From b56ec957b854a97078196231d41d27918cb81dfe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E8=80=81=E5=88=98?= <632171029@qq.com> Date: Sun, 7 Apr 2024 09:37:40 +0800 Subject: [PATCH] batch impl init --- .github/workflows/main.yml | 192 +- .gitignore | 48 +- .travis.yml | 38 +- IMPLS.yml | 246 +- LICENSE | 774 +- Makefile | 720 +- Makefile.impls | 398 +- README.md | 2962 ++++---- ci.sh | 166 +- docs/FAQ.md | 410 +- docs/Hints.md | 246 +- docs/TODO | 280 +- docs/cheatsheet.html | 514 +- docs/exercises.md | 258 +- docs/graph/README.md | 92 +- docs/graph/all_data.json | 3918 +++++----- docs/graph/base_data.yaml | 176 +- docs/graph/collect_data.js | 582 +- docs/graph/graph_languages.js | 608 +- docs/graph/index.html | 362 +- docs/graph/package.json | 22 +- docs/index.html | 594 +- docs/step_notes.txt | 824 +- docs/web/ansi.css | 344 +- docs/web/base.css | 444 +- docs/web/console.css | 126 +- docs/web/fonts/exo-black-webfont.svg | 490 +- docs/web/fonts/exo-bold-webfont.svg | 490 +- docs/web/fonts/exo-regular-webfont.svg | 490 +- docs/web/himera.css | 560 +- docs/web/layout.css | 200 +- docs/web/mal.js | 1952 ++--- docs/web/skeleton.css | 472 +- examples/clojurewest2014.mal | 252 +- examples/exercises.mal | 326 +- examples/hello.mal | 4 +- examples/presentation.mal | 244 +- get-ci-matrix.py | 132 +- impls/.gitignore | 300 +- impls/ada.2/Dockerfile | 50 +- impls/ada.2/Makefile | 148 +- impls/ada.2/README | 92 +- impls/ada.2/core.adb | 918 +-- impls/ada.2/core.ads | 16 +- impls/ada.2/envs.adb | 218 +- impls/ada.2/envs.ads | 114 +- impls/ada.2/err.adb | 134 +- impls/ada.2/err.ads | 100 +- impls/ada.2/garbage_collected.adb | 108 +- impls/ada.2/garbage_collected.ads | 92 +- impls/ada.2/printer.adb | 328 +- impls/ada.2/printer.ads | 38 +- impls/ada.2/reader.adb | 534 +- impls/ada.2/reader.ads | 20 +- impls/ada.2/readline.adb | 64 +- impls/ada.2/readline.ads | 14 +- impls/ada.2/run | 4 +- impls/ada.2/step0_repl.adb | 90 +- impls/ada.2/step1_read_print.adb | 130 +- impls/ada.2/step2_eval.adb | 390 +- impls/ada.2/step3_env.adb | 442 +- impls/ada.2/step4_if_fn_do.adb | 526 +- impls/ada.2/step5_tco.adb | 592 +- impls/ada.2/step6_file.adb | 646 +- impls/ada.2/step7_quote.adb | 784 +- impls/ada.2/step8_macros.adb | 894 +-- impls/ada.2/step9_try.adb | 954 +-- impls/ada.2/stepa_mal.adb | 970 +-- impls/ada.2/types-atoms.adb | 130 +- impls/ada.2/types-atoms.ads | 48 +- impls/ada.2/types-builtins.adb | 62 +- impls/ada.2/types-builtins.ads | 56 +- impls/ada.2/types-fns.adb | 118 +- impls/ada.2/types-fns.ads | 90 +- impls/ada.2/types-maps.adb | 400 +- impls/ada.2/types-maps.ads | 124 +- impls/ada.2/types-sequences.adb | 454 +- impls/ada.2/types-sequences.ads | 80 +- impls/ada.2/types-strings.adb | 68 +- impls/ada.2/types-strings.ads | 98 +- impls/ada.2/types.adb | 116 +- impls/ada.2/types.ads | 180 +- impls/ada/Dockerfile | 50 +- impls/ada/Makefile | 46 +- impls/ada/core.adb | 2574 +++---- impls/ada/core.ads | 20 +- impls/ada/envs.adb | 292 +- impls/ada/envs.ads | 128 +- impls/ada/eval_callback.ads | 22 +- impls/ada/printer.adb | 24 +- impls/ada/printer.ads | 14 +- impls/ada/reader.adb | 780 +- impls/ada/reader.ads | 28 +- impls/ada/run | 4 +- impls/ada/smart_pointers.adb | 98 +- impls/ada/smart_pointers.ads | 78 +- impls/ada/step0_repl.adb | 68 +- impls/ada/step1_read_print.adb | 88 +- impls/ada/step2_eval.adb | 472 +- impls/ada/step3_env.adb | 538 +- impls/ada/step4_if_fn_do.adb | 646 +- impls/ada/step5_tco.adb | 754 +- impls/ada/step6_file.adb | 820 +- impls/ada/step7_quote.adb | 998 +-- impls/ada/step8_macros.adb | 1156 +-- impls/ada/step9_try.adb | 1262 ++-- impls/ada/stepa_mal.adb | 1266 ++-- impls/ada/types-hash_map.adb | 570 +- impls/ada/types-hash_map.ads | 166 +- impls/ada/types-vector.adb | 392 +- impls/ada/types-vector.ads | 132 +- impls/ada/types.adb | 2392 +++--- impls/ada/types.ads | 884 +-- impls/awk/Dockerfile | 50 +- impls/awk/Makefile | 40 +- impls/awk/core.awk | 2276 +++--- impls/awk/env.awk | 252 +- impls/awk/printer.awk | 126 +- impls/awk/reader.awk | 370 +- impls/awk/run | 4 +- impls/awk/step0_repl.awk | 70 +- impls/awk/step1_read_print.awk | 104 +- impls/awk/step2_eval.awk | 386 +- impls/awk/step3_env.awk | 554 +- impls/awk/step4_if_fn_do.awk | 664 +- impls/awk/step5_tco.awk | 678 +- impls/awk/step6_file.awk | 726 +- impls/awk/step7_quote.awk | 950 +-- impls/awk/step8_macros.awk | 1150 +-- impls/awk/step9_try.awk | 1274 ++-- impls/awk/stepA_mal.awk | 1282 ++-- impls/awk/tests/step5_tco.mal | 4 +- impls/awk/types.awk | 436 +- impls/bash/Dockerfile | 48 +- impls/bash/Makefile | 38 +- impls/bash/core.sh | 850 +-- impls/bash/env.sh | 160 +- impls/bash/printer.sh | 208 +- impls/bash/reader.sh | 334 +- impls/bash/run | 4 +- impls/bash/step0_repl.sh | 40 +- impls/bash/step1_read_print.sh | 86 +- impls/bash/step2_eval.sh | 196 +- impls/bash/step3_env.sh | 238 +- impls/bash/step4_if_fn_do.sh | 288 +- impls/bash/step5_tco.sh | 326 +- impls/bash/step6_file.sh | 352 +- impls/bash/step7_quote.sh | 458 +- impls/bash/step8_macros.sh | 550 +- impls/bash/step9_try.sh | 576 +- impls/bash/stepA_mal.sh | 600 +- impls/bash/tests/stepA_mal.mal | 64 +- impls/bash/types.sh | 744 +- impls/basic/.args.mal | 2 +- impls/basic/Dockerfile | 92 +- impls/basic/Makefile | 124 +- impls/basic/basicpp.py | 694 +- impls/basic/core.in.bas | 1276 ++-- impls/basic/debug.in.bas | 440 +- impls/basic/env.in.bas | 178 +- impls/basic/mem.in.bas | 782 +- impls/basic/printer.in.bas | 232 +- impls/basic/reader.in.bas | 550 +- impls/basic/readline.in.bas | 8 +- impls/basic/readline_char.in.bas | 62 +- impls/basic/readline_line.in.bas | 12 +- impls/basic/run | 16 +- impls/basic/step0_repl.in.bas | 88 +- impls/basic/step1_read_print.in.bas | 134 +- impls/basic/step2_eval.in.bas | 504 +- impls/basic/step3_env.in.bas | 626 +- impls/basic/step4_if_fn_do.in.bas | 742 +- impls/basic/step5_tco.in.bas | 790 +- impls/basic/step6_file.in.bas | 852 +-- impls/basic/step7_quote.in.bas | 1124 +-- impls/basic/step8_macros.in.bas | 1268 ++-- impls/basic/step9_try.in.bas | 1338 ++-- impls/basic/stepA_mal.in.bas | 1356 ++-- impls/basic/types.in.bas | 618 +- impls/basic/variables.txt | 218 +- impls/batch/LinearList_LSS_SLL.bat | 105 + impls/batch/Queue_LSS.bat | 146 + impls/batch/Stack_LSS.bat | 154 + impls/batch/reader.bat | 216 + impls/batch/step0_repl.bat | 106 + impls/batch/step1_read_print.bat | 106 + impls/bbc-basic/Dockerfile | 62 +- impls/bbc-basic/Makefile | 10 +- impls/bbc-basic/README.md | 186 +- impls/bbc-basic/core.bas | 990 +-- impls/bbc-basic/env.bas | 84 +- impls/bbc-basic/printer.bas | 132 +- impls/bbc-basic/reader.bas | 396 +- impls/bbc-basic/riscos/.gitignore | 2 +- impls/bbc-basic/riscos/setup,feb | 4 +- impls/bbc-basic/riscos/tokenize,ffe | 72 +- impls/bbc-basic/run | 6 +- impls/bbc-basic/step0_repl.bas | 50 +- impls/bbc-basic/step1_read_print.bas | 72 +- impls/bbc-basic/step2_eval.bas | 174 +- impls/bbc-basic/step3_env.bas | 210 +- impls/bbc-basic/step4_if_fn_do.bas | 248 +- impls/bbc-basic/step5_tco.bas | 276 +- impls/bbc-basic/step6_file.bas | 400 +- impls/bbc-basic/step7_quote.bas | 470 +- impls/bbc-basic/step8_macros.bas | 532 +- impls/bbc-basic/step9_try.bas | 620 +- impls/bbc-basic/stepA_mal.bas | 624 +- impls/bbc-basic/types.bas | 1418 ++-- impls/c.2/Dockerfile | 56 +- impls/c.2/Makefile | 186 +- impls/c.2/core.c | 3992 +++++----- impls/c.2/core.h | 44 +- impls/c.2/env.c | 134 +- impls/c.2/env.h | 46 +- impls/c.2/libs/hashmap/hashmap.c | 186 +- impls/c.2/libs/hashmap/hashmap.h | 30 +- impls/c.2/libs/linked_list/linked_list.c | 342 +- impls/c.2/libs/linked_list/linked_list.h | 64 +- impls/c.2/printer.c | 510 +- impls/c.2/printer.h | 30 +- impls/c.2/reader.c | 1326 ++-- impls/c.2/reader.h | 114 +- impls/c.2/run | 4 +- impls/c.2/step0_repl.c | 120 +- impls/c.2/step1_read_print.c | 126 +- impls/c.2/step2_eval.c | 610 +- impls/c.2/step3_env.c | 714 +- impls/c.2/step4_if_fn_do.c | 980 +-- impls/c.2/step5_tco.c | 1064 +-- impls/c.2/step6_file.c | 1172 +-- impls/c.2/step7_quote.c | 1576 ++-- impls/c.2/step8_macros.c | 1794 ++--- impls/c.2/step9_try.c | 1936 ++--- impls/c.2/stepA_mal.c | 1984 ++--- impls/c.2/tests/stepA_mal.mal | 44 +- impls/c.2/types.c | 566 +- impls/c.2/types.h | 200 +- impls/c/Dockerfile | 56 +- impls/c/Makefile | 122 +- impls/c/core.c | 1188 +-- impls/c/core.h | 30 +- impls/c/env.c | 114 +- impls/c/interop.c | 344 +- impls/c/interop.h | 12 +- impls/c/printer.c | 308 +- impls/c/printer.h | 18 +- impls/c/reader.c | 520 +- impls/c/reader.h | 46 +- impls/c/readline.c | 150 +- impls/c/readline.h | 12 +- impls/c/run | 4 +- impls/c/step0_repl.c | 88 +- impls/c/step1_read_print.c | 172 +- impls/c/step2_eval.c | 314 +- impls/c/step3_env.c | 364 +- impls/c/step4_if_fn_do.c | 440 +- impls/c/step5_tco.c | 466 +- impls/c/step6_file.c | 506 +- impls/c/step7_quote.c | 608 +- impls/c/step8_macros.c | 694 +- impls/c/step9_try.c | 744 +- impls/c/stepA_mal.c | 758 +- impls/c/tests/step5_tco.mal | 4 +- impls/c/tests/stepA_mal.mal | 46 +- impls/c/types.c | 1040 +-- impls/c/types.h | 394 +- impls/chuck/Dockerfile | 64 +- impls/chuck/Makefile | 10 +- impls/chuck/chuck.md | 234 +- impls/chuck/core.ck | 200 +- impls/chuck/env.ck | 184 +- impls/chuck/func.ck | 70 +- impls/chuck/notes.md | 310 +- impls/chuck/printer.ck | 152 +- impls/chuck/reader.ck | 480 +- impls/chuck/readline.ck | 144 +- impls/chuck/run | 10 +- impls/chuck/step0_repl.ck | 84 +- impls/chuck/step1_read_print.ck | 166 +- impls/chuck/step2_eval.ck | 380 +- impls/chuck/step3_env.ck | 438 +- impls/chuck/step4_if_fn_do.ck | 580 +- impls/chuck/step5_tco.ck | 592 +- impls/chuck/step6_file.ck | 698 +- impls/chuck/step7_quote.ck | 820 +- impls/chuck/step8_macros.ck | 964 +-- impls/chuck/step9_try.ck | 998 +-- impls/chuck/stepA_mal.ck | 1004 +-- impls/chuck/tests/step5_tco.mal | 4 +- impls/chuck/types/MalObject.ck | 200 +- impls/chuck/types/MalSubr.ck | 34 +- impls/chuck/types/boxed/Int.ck | 22 +- impls/chuck/types/boxed/String.ck | 260 +- impls/chuck/types/mal/MalAtom.ck | 66 +- impls/chuck/types/mal/MalError.ck | 42 +- impls/chuck/types/mal/MalFalse.ck | 56 +- impls/chuck/types/mal/MalHashMap.ck | 142 +- impls/chuck/types/mal/MalInt.ck | 66 +- impls/chuck/types/mal/MalKeyword.ck | 66 +- impls/chuck/types/mal/MalList.ck | 66 +- impls/chuck/types/mal/MalNil.ck | 56 +- impls/chuck/types/mal/MalString.ck | 66 +- impls/chuck/types/mal/MalSymbol.ck | 66 +- impls/chuck/types/mal/MalTrue.ck | 56 +- impls/chuck/types/mal/MalVector.ck | 66 +- impls/chuck/types/subr/MalAdd.ck | 20 +- impls/chuck/types/subr/MalApply.ck | 24 +- impls/chuck/types/subr/MalAssoc.ck | 90 +- impls/chuck/types/subr/MalAtomify.ck | 16 +- impls/chuck/types/subr/MalConcat.ck | 30 +- impls/chuck/types/subr/MalConj.ck | 34 +- impls/chuck/types/subr/MalCons.ck | 18 +- impls/chuck/types/subr/MalCount.ck | 32 +- impls/chuck/types/subr/MalDeref.ck | 14 +- impls/chuck/types/subr/MalDissoc.ck | 66 +- impls/chuck/types/subr/MalDiv.ck | 20 +- impls/chuck/types/subr/MalDoReset.ck | 24 +- impls/chuck/types/subr/MalDoSwap.ck | 30 +- impls/chuck/types/subr/MalEqual.ck | 252 +- impls/chuck/types/subr/MalFirst.ck | 46 +- impls/chuck/types/subr/MalGet.ck | 82 +- impls/chuck/types/subr/MalGreater.ck | 34 +- impls/chuck/types/subr/MalGreaterEqual.ck | 34 +- impls/chuck/types/subr/MalHashMapify.ck | 14 +- impls/chuck/types/subr/MalIsAtom.ck | 28 +- impls/chuck/types/subr/MalIsContains.ck | 70 +- impls/chuck/types/subr/MalIsEmpty.ck | 30 +- impls/chuck/types/subr/MalIsFalse.ck | 32 +- impls/chuck/types/subr/MalIsFn.ck | 30 +- impls/chuck/types/subr/MalIsHashMap.ck | 32 +- impls/chuck/types/subr/MalIsKeyword.ck | 32 +- impls/chuck/types/subr/MalIsList.ck | 28 +- impls/chuck/types/subr/MalIsMacro.ck | 28 +- impls/chuck/types/subr/MalIsNil.ck | 32 +- impls/chuck/types/subr/MalIsNumber.ck | 28 +- impls/chuck/types/subr/MalIsString.ck | 28 +- impls/chuck/types/subr/MalIsSymbol.ck | 32 +- impls/chuck/types/subr/MalIsTrue.ck | 32 +- impls/chuck/types/subr/MalIsVector.ck | 32 +- impls/chuck/types/subr/MalKeys.ck | 30 +- impls/chuck/types/subr/MalKeywordify.ck | 16 +- impls/chuck/types/subr/MalLess.ck | 34 +- impls/chuck/types/subr/MalLessEqual.ck | 34 +- impls/chuck/types/subr/MalListify.ck | 14 +- impls/chuck/types/subr/MalMap.ck | 44 +- impls/chuck/types/subr/MalMeta.ck | 32 +- impls/chuck/types/subr/MalMul.ck | 20 +- impls/chuck/types/subr/MalNth.ck | 34 +- impls/chuck/types/subr/MalPrStr.ck | 28 +- impls/chuck/types/subr/MalPrintln.ck | 30 +- impls/chuck/types/subr/MalPrn.ck | 30 +- impls/chuck/types/subr/MalReadStr.ck | 16 +- impls/chuck/types/subr/MalReadline.ck | 34 +- impls/chuck/types/subr/MalRest.ck | 44 +- impls/chuck/types/subr/MalSeq.ck | 90 +- impls/chuck/types/subr/MalSequential.ck | 32 +- impls/chuck/types/subr/MalSlurp.ck | 40 +- impls/chuck/types/subr/MalStr.ck | 28 +- impls/chuck/types/subr/MalSub.ck | 20 +- impls/chuck/types/subr/MalSymbolify.ck | 16 +- impls/chuck/types/subr/MalThrow.ck | 14 +- impls/chuck/types/subr/MalTimeMs.ck | 36 +- impls/chuck/types/subr/MalVals.ck | 30 +- impls/chuck/types/subr/MalVec.ck | 30 +- impls/chuck/types/subr/MalVectorify.ck | 14 +- impls/chuck/types/subr/MalWithMeta.ck | 30 +- impls/chuck/util/Constants.ck | 20 +- impls/chuck/util/Util.ck | 62 +- impls/clojure/Dockerfile | 112 +- impls/clojure/Makefile | 72 +- impls/clojure/package.json | 18 +- impls/clojure/project.clj | 88 +- impls/clojure/run | 16 +- impls/clojure/src/mal/core.cljc | 190 +- impls/clojure/src/mal/env.cljc | 72 +- impls/clojure/src/mal/node_readline.js | 92 +- impls/clojure/src/mal/printer.cljc | 58 +- impls/clojure/src/mal/reader.cljc | 162 +- impls/clojure/src/mal/readline.clj | 80 +- impls/clojure/src/mal/readline.cljs | 6 +- impls/clojure/src/mal/step0_repl.cljc | 56 +- impls/clojure/src/mal/step1_read_print.cljc | 72 +- impls/clojure/src/mal/step2_eval.cljc | 136 +- impls/clojure/src/mal/step3_env.cljc | 164 +- impls/clojure/src/mal/step4_if_fn_do.cljc | 198 +- impls/clojure/src/mal/step5_tco.cljc | 216 +- impls/clojure/src/mal/step6_file.cljc | 228 +- impls/clojure/src/mal/step7_quote.cljc | 286 +- impls/clojure/src/mal/step8_macros.cljc | 356 +- impls/clojure/src/mal/step9_try.cljc | 396 +- impls/clojure/src/mal/stepA_mal.cljc | 420 +- impls/clojure/tests/step5_tco.mal | 30 +- impls/clojure/tests/stepA_mal.mal | 44 +- impls/coffee/Dockerfile | 78 +- impls/coffee/Makefile | 60 +- impls/coffee/core.coffee | 216 +- impls/coffee/env.coffee | 62 +- impls/coffee/node_readline.coffee | 78 +- impls/coffee/package.json | 18 +- impls/coffee/printer.coffee | 50 +- impls/coffee/reader.coffee | 176 +- impls/coffee/run | 4 +- impls/coffee/step0_repl.coffee | 40 +- impls/coffee/step1_read_print.coffee | 58 +- impls/coffee/step2_eval.coffee | 110 +- impls/coffee/step3_env.coffee | 132 +- impls/coffee/step4_if_fn_do.coffee | 158 +- impls/coffee/step5_tco.coffee | 170 +- impls/coffee/step6_file.coffee | 186 +- impls/coffee/step7_quote.coffee | 230 +- impls/coffee/step8_macros.coffee | 270 +- impls/coffee/step9_try.coffee | 296 +- impls/coffee/stepA_mal.coffee | 312 +- impls/coffee/tests/step5_tco.mal | 30 +- impls/coffee/tests/stepA_mal.mal | 48 +- impls/coffee/types.coffee | 246 +- impls/common-lisp/Dockerfile | 102 +- impls/common-lisp/Makefile | 134 +- impls/common-lisp/README.org | 200 +- impls/common-lisp/fake-readline.lisp | 36 +- impls/common-lisp/run | 4 +- impls/common-lisp/run-abcl.lisp | 20 +- impls/common-lisp/run-mkcl.lisp | 42 +- impls/common-lisp/src/core.lisp | 720 +- impls/common-lisp/src/env.lisp | 132 +- impls/common-lisp/src/printer.lisp | 106 +- impls/common-lisp/src/reader.lisp | 374 +- impls/common-lisp/src/step0_repl.lisp | 152 +- impls/common-lisp/src/step1_read_print.lisp | 164 +- impls/common-lisp/src/step2_eval.lisp | 322 +- impls/common-lisp/src/step3_env.lisp | 376 +- impls/common-lisp/src/step4_if_fn_do.lisp | 384 +- impls/common-lisp/src/step5_tco.lisp | 406 +- impls/common-lisp/src/step6_file.lisp | 448 +- impls/common-lisp/src/step7_quote.lisp | 520 +- impls/common-lisp/src/step8_macros.lisp | 630 +- impls/common-lisp/src/step9_try.lisp | 678 +- impls/common-lisp/src/stepA_mal.lisp | 694 +- impls/common-lisp/src/types.lisp | 386 +- impls/common-lisp/src/utils.lisp | 84 +- impls/common-lisp/step0_repl.asd | 48 +- impls/common-lisp/step1_read_print.asd | 64 +- impls/common-lisp/step2_eval.asd | 66 +- impls/common-lisp/step3_env.asd | 66 +- impls/common-lisp/step4_if_fn_do.asd | 68 +- impls/common-lisp/step5_tco.asd | 68 +- impls/common-lisp/step6_file.asd | 68 +- impls/common-lisp/step7_quote.asd | 68 +- impls/common-lisp/step8_macros.asd | 68 +- impls/common-lisp/step9_try.asd | 68 +- impls/common-lisp/stepA_mal.asd | 68 +- impls/common-lisp/tests/stepA_mal.mal | 122 +- impls/cpp/.gitignore | 10 +- impls/cpp/Core.cpp | 1118 +-- impls/cpp/Debug.h | 90 +- impls/cpp/Dockerfile | 50 +- impls/cpp/Environment.cpp | 146 +- impls/cpp/Environment.h | 58 +- impls/cpp/MAL.h | 64 +- impls/cpp/Makefile | 108 +- impls/cpp/README.md | 80 +- impls/cpp/ReadLine.cpp | 70 +- impls/cpp/ReadLine.h | 34 +- impls/cpp/Reader.cpp | 456 +- impls/cpp/RefCountedPtr.h | 154 +- impls/cpp/StaticList.h | 100 +- impls/cpp/String.cpp | 176 +- impls/cpp/String.h | 36 +- impls/cpp/Types.cpp | 996 +-- impls/cpp/Types.h | 748 +- impls/cpp/Validation.cpp | 66 +- impls/cpp/Validation.h | 32 +- impls/cpp/docker.sh | 68 +- impls/cpp/run | 4 +- impls/cpp/step0_repl.cpp | 84 +- impls/cpp/step1_read_print.cpp | 132 +- impls/cpp/step2_eval.cpp | 236 +- impls/cpp/step3_env.cpp | 228 +- impls/cpp/step4_if_fn_do.cpp | 332 +- impls/cpp/step5_tco.cpp | 346 +- impls/cpp/step6_file.cpp | 396 +- impls/cpp/step7_quote.cpp | 516 +- impls/cpp/step8_macros.cpp | 612 +- impls/cpp/step9_try.cpp | 710 +- impls/cpp/stepA_mal.cpp | 714 +- impls/cpp/tests/step5_tco.mal | 4 +- impls/crystal/Dockerfile | 60 +- impls/crystal/Makefile | 66 +- impls/crystal/core.cr | 922 +-- impls/crystal/env.cr | 132 +- impls/crystal/error.cr | 50 +- impls/crystal/printer.cr | 68 +- impls/crystal/reader.cr | 278 +- impls/crystal/run | 4 +- impls/crystal/step0_repl.cr | 52 +- impls/crystal/step1_read_print.cr | 76 +- impls/crystal/step2_eval.cr | 194 +- impls/crystal/step3_env.cr | 240 +- impls/crystal/step4_if_fn_do.cr | 272 +- impls/crystal/step5_tco.cr | 340 +- impls/crystal/step6_file.cr | 366 +- impls/crystal/step7_quote.cr | 456 +- impls/crystal/step8_macros.cr | 552 +- impls/crystal/step9_try.cr | 586 +- impls/crystal/stepA_mal.cr | 604 +- impls/crystal/tests/step5_tco.mal | 4 +- impls/crystal/types.cr | 226 +- impls/cs/Dockerfile | 50 +- impls/cs/Makefile | 86 +- impls/cs/core.cs | 788 +- impls/cs/env.cs | 110 +- impls/cs/getline.cs | 2174 +++--- impls/cs/interop.cs | 132 +- impls/cs/printer.cs | 98 +- impls/cs/reader.cs | 318 +- impls/cs/readline.cs | 48 +- impls/cs/run | 4 +- impls/cs/step0_repl.cs | 94 +- impls/cs/step1_read_print.cs | 108 +- impls/cs/step2_eval.cs | 218 +- impls/cs/step3_env.cs | 268 +- impls/cs/step4_if_fn_do.cs | 316 +- impls/cs/step5_tco.cs | 344 +- impls/cs/step6_file.cs | 374 +- impls/cs/step7_quote.cs | 464 +- impls/cs/step8_macros.cs | 546 +- impls/cs/step9_try.cs | 596 +- impls/cs/stepA_mal.cs | 600 +- impls/cs/tests/step5_tco.mal | 4 +- impls/cs/types.cs | 716 +- impls/d/Dockerfile | 62 +- impls/d/Makefile | 108 +- impls/d/env.d | 106 +- impls/d/main.di | 8 +- impls/d/mal_core.d | 854 +-- impls/d/printer.d | 12 +- impls/d/reader.d | 382 +- impls/d/readline.d | 120 +- impls/d/run | 4 +- impls/d/step0_repl.d | 70 +- impls/d/step1_read_print.d | 90 +- impls/d/step2_eval.d | 264 +- impls/d/step3_env.d | 306 +- impls/d/step4_if_fn_do.d | 334 +- impls/d/step5_tco.d | 366 +- impls/d/step6_file.d | 424 +- impls/d/step7_quote.d | 508 +- impls/d/step8_macros.d | 600 +- impls/d/step9_try.d | 666 +- impls/d/stepA_mal.d | 672 +- impls/d/tests/step5_tco.mal | 4 +- impls/d/types.d | 908 +-- impls/dart/.analysis_options | 14 +- impls/dart/.packages | 4 +- impls/dart/Dockerfile | 58 +- impls/dart/Makefile | 10 +- impls/dart/core.dart | 606 +- impls/dart/env.dart | 108 +- impls/dart/printer.dart | 94 +- impls/dart/pubspec.lock | 8 +- impls/dart/pubspec.yaml | 6 +- impls/dart/reader.dart | 298 +- impls/dart/run | 4 +- impls/dart/step0_repl.dart | 40 +- impls/dart/step1_read_print.dart | 68 +- impls/dart/step2_eval.dart | 172 +- impls/dart/step3_env.dart | 252 +- impls/dart/step4_if_fn_do.dart | 284 +- impls/dart/step5_tco.dart | 314 +- impls/dart/step6_file.dart | 336 +- impls/dart/step7_quote.dart | 410 +- impls/dart/step8_macros.dart | 498 +- impls/dart/step9_try.dart | 548 +- impls/dart/stepA_mal.dart | 554 +- impls/dart/types.dart | 540 +- impls/elisp/Dockerfile | 52 +- impls/elisp/Makefile | 6 +- impls/elisp/mal/core.el | 468 +- impls/elisp/mal/env.el | 68 +- impls/elisp/mal/func.el | 50 +- impls/elisp/mal/printer.el | 118 +- impls/elisp/mal/reader.el | 316 +- impls/elisp/mal/types.el | 208 +- impls/elisp/run | 4 +- impls/elisp/step0_repl.el | 60 +- impls/elisp/step1_read_print.el | 102 +- impls/elisp/step2_eval.el | 164 +- impls/elisp/step3_env.el | 204 +- impls/elisp/step4_if_fn_do.el | 256 +- impls/elisp/step5_tco.el | 292 +- impls/elisp/step6_file.el | 314 +- impls/elisp/step7_quote.el | 378 +- impls/elisp/step8_macros.el | 422 +- impls/elisp/step9_try.el | 454 +- impls/elisp/stepA_mal.el | 458 +- impls/elisp/tests/step5_tco.mal | 30 +- impls/elisp/tests/stepA_mal.mal | 42 +- impls/elixir/Dockerfile | 60 +- impls/elixir/Makefile | 34 +- impls/elixir/lib/mal.ex | 4 +- impls/elixir/lib/mal/atom.ex | 50 +- impls/elixir/lib/mal/core.ex | 498 +- impls/elixir/lib/mal/env.ex | 120 +- impls/elixir/lib/mal/printer.ex | 100 +- impls/elixir/lib/mal/reader.ex | 202 +- impls/elixir/lib/mal/types.ex | 84 +- impls/elixir/lib/mix/tasks/step0_repl.ex | 60 +- .../elixir/lib/mix/tasks/step1_read_print.ex | 60 +- impls/elixir/lib/mix/tasks/step2_eval.ex | 140 +- impls/elixir/lib/mix/tasks/step3_env.ex | 190 +- impls/elixir/lib/mix/tasks/step4_if_fn_do.ex | 272 +- impls/elixir/lib/mix/tasks/step5_tco.ex | 278 +- impls/elixir/lib/mix/tasks/step6_file.ex | 318 +- impls/elixir/lib/mix/tasks/step7_quote.ex | 370 +- impls/elixir/lib/mix/tasks/step8_macros.ex | 464 +- impls/elixir/lib/mix/tasks/step9_try.ex | 518 +- impls/elixir/lib/mix/tasks/stepA_mal.ex | 536 +- impls/elixir/mix.exs | 76 +- impls/elixir/run | 6 +- impls/elixir/tests/step5_tco.mal | 4 +- impls/elm/.dockerignore | 2 +- impls/elm/Core.elm | 1930 ++--- impls/elm/Dockerfile | 76 +- impls/elm/Env.elm | 848 +-- impls/elm/Eval.elm | 476 +- impls/elm/IO.elm | 142 +- impls/elm/Makefile | 80 +- impls/elm/Printer.elm | 304 +- impls/elm/Reader.elm | 402 +- impls/elm/Types.elm | 214 +- impls/elm/Utils.elm | 230 +- impls/elm/bootstrap.js | 62 +- impls/elm/elm-package.json | 30 +- impls/elm/node_readline.js | 94 +- impls/elm/package.json | 34 +- impls/elm/run | 4 +- impls/elm/step0_repl.elm | 156 +- impls/elm/step1_read_print.elm | 212 +- impls/elm/step2_eval.elm | 510 +- impls/elm/step3_env.elm | 628 +- impls/elm/step4_if_fn_do.elm | 996 +-- impls/elm/step5_tco.elm | 1072 +-- impls/elm/step6_file.elm | 1212 +-- impls/elm/step7_quote.elm | 1286 ++-- impls/elm/step8_macros.elm | 1424 ++-- impls/elm/step9_try.elm | 1472 ++-- impls/elm/stepA_mal.elm | 1486 ++-- impls/erlang/Dockerfile | 70 +- impls/erlang/Makefile | 74 +- impls/erlang/rebar.config | 48 +- impls/erlang/rebar.config.script | 22 +- impls/erlang/run | 4 +- impls/erlang/src/atom.erl | 138 +- impls/erlang/src/core.erl | 798 +- impls/erlang/src/env.erl | 346 +- impls/erlang/src/mal.app.src | 22 +- impls/erlang/src/printer.erl | 118 +- impls/erlang/src/reader.erl | 526 +- impls/erlang/src/step0_repl.erl | 60 +- impls/erlang/src/step1_read_print.erl | 72 +- impls/erlang/src/step2_eval.erl | 160 +- impls/erlang/src/step3_env.erl | 200 +- impls/erlang/src/step4_if_fn_do.erl | 256 +- impls/erlang/src/step5_tco.erl | 256 +- impls/erlang/src/step6_file.erl | 290 +- impls/erlang/src/step7_quote.erl | 358 +- impls/erlang/src/step8_macros.erl | 464 +- impls/erlang/src/step9_try.erl | 500 +- impls/erlang/src/stepA_mal.erl | 504 +- impls/erlang/src/types.erl | 326 +- impls/erlang/tests/step5_tco.mal | 4 +- impls/es6/Dockerfile | 68 +- impls/es6/Makefile | 58 +- impls/es6/core.mjs | 226 +- impls/es6/env.mjs | 34 +- impls/es6/node_readline.js | 92 +- impls/es6/package.json | 24 +- impls/es6/printer.mjs | 70 +- impls/es6/reader.mjs | 240 +- impls/es6/run | 4 +- impls/es6/step0_repl.mjs | 40 +- impls/es6/step1_read_print.mjs | 56 +- impls/es6/step2_eval.mjs | 114 +- impls/es6/step3_env.mjs | 136 +- impls/es6/step4_if_fn_do.mjs | 164 +- impls/es6/step5_tco.mjs | 192 +- impls/es6/step6_file.mjs | 212 +- impls/es6/step7_quote.mjs | 272 +- impls/es6/step8_macros.mjs | 314 +- impls/es6/step9_try.mjs | 336 +- impls/es6/stepA_mal.mjs | 338 +- impls/es6/tests/step5_tco.mal | 30 +- impls/es6/types.mjs | 136 +- impls/factor/Dockerfile | 62 +- impls/factor/Makefile | 62 +- impls/factor/lib/core/core-tests.factor | 16 +- impls/factor/lib/core/core.factor | 172 +- impls/factor/lib/env/env-tests.factor | 64 +- impls/factor/lib/env/env.factor | 64 +- impls/factor/lib/printer/printer-tests.factor | 30 +- impls/factor/lib/printer/printer.factor | 64 +- impls/factor/lib/reader/reader-tests.factor | 24 +- impls/factor/lib/reader/reader.factor | 160 +- impls/factor/lib/types/types.factor | 102 +- impls/factor/run | 4 +- impls/factor/step0_repl/deploy.factor | 32 +- impls/factor/step0_repl/step0_repl.factor | 42 +- impls/factor/step1_read_print/deploy.factor | 32 +- .../step1_read_print/step1_read_print.factor | 54 +- impls/factor/step2_eval/deploy.factor | 32 +- impls/factor/step2_eval/step2_eval.factor | 98 +- impls/factor/step3_env/deploy.factor | 32 +- impls/factor/step3_env/step3_env.factor | 138 +- impls/factor/step4_if_fn_do/deploy.factor | 32 +- .../step4_if_fn_do/step4_if_fn_do.factor | 176 +- impls/factor/step5_tco/deploy.factor | 32 +- impls/factor/step5_tco/step5_tco.factor | 192 +- impls/factor/step6_file/deploy.factor | 32 +- impls/factor/step6_file/step6_file.factor | 220 +- impls/factor/step7_quote/deploy.factor | 32 +- impls/factor/step7_quote/step7_quote.factor | 290 +- impls/factor/step8_macros/deploy.factor | 32 +- impls/factor/step8_macros/step8_macros.factor | 328 +- impls/factor/step9_try/deploy.factor | 32 +- impls/factor/step9_try/step9_try.factor | 352 +- impls/factor/stepA_mal/deploy.factor | 32 +- impls/factor/stepA_mal/stepA_mal.factor | 356 +- impls/factor/tests/step5_tco.mal | 30 +- impls/fantom/Dockerfile | 76 +- impls/fantom/Makefile | 36 +- impls/fantom/run | 8 +- impls/fantom/src/mallib/build.fan | 22 +- impls/fantom/src/mallib/fan/core.fan | 236 +- impls/fantom/src/mallib/fan/env.fan | 80 +- impls/fantom/src/mallib/fan/interop.fan | 130 +- impls/fantom/src/mallib/fan/reader.fan | 216 +- impls/fantom/src/mallib/fan/types.fan | 468 +- impls/fantom/src/step0_repl/build.fan | 22 +- impls/fantom/src/step0_repl/fan/main.fan | 64 +- impls/fantom/src/step1_read_print/build.fan | 22 +- .../fantom/src/step1_read_print/fan/main.fan | 74 +- impls/fantom/src/step2_eval/build.fan | 22 +- impls/fantom/src/step2_eval/fan/main.fan | 140 +- impls/fantom/src/step3_env/build.fan | 22 +- impls/fantom/src/step3_env/fan/main.fan | 158 +- impls/fantom/src/step4_if_fn_do/build.fan | 22 +- impls/fantom/src/step4_if_fn_do/fan/main.fan | 182 +- impls/fantom/src/step5_tco/build.fan | 22 +- impls/fantom/src/step5_tco/fan/main.fan | 226 +- impls/fantom/src/step6_file/build.fan | 22 +- impls/fantom/src/step6_file/fan/main.fan | 244 +- impls/fantom/src/step7_quote/build.fan | 22 +- impls/fantom/src/step7_quote/fan/main.fan | 336 +- impls/fantom/src/step8_macros/build.fan | 22 +- impls/fantom/src/step8_macros/fan/main.fan | 396 +- impls/fantom/src/step9_try/build.fan | 22 +- impls/fantom/src/step9_try/fan/main.fan | 424 +- impls/fantom/src/stepA_mal/build.fan | 22 +- impls/fantom/src/stepA_mal/fan/main.fan | 428 +- impls/fantom/tests/step5_tco.mal | 30 +- impls/fantom/tests/stepA_mal.mal | 76 +- impls/fennel/Dockerfile | 102 +- impls/fennel/Makefile | 4 +- impls/fennel/core.fnl | 1630 ++-- impls/fennel/env.fnl | 198 +- impls/fennel/printer.fnl | 184 +- impls/fennel/reader.fnl | 400 +- impls/fennel/run | 6 +- impls/fennel/step0_repl.fnl | 42 +- impls/fennel/step1_read_print.fnl | 78 +- impls/fennel/step2_eval.fnl | 178 +- impls/fennel/step3_env.fnl | 230 +- impls/fennel/step4_if_fn_do.fnl | 272 +- impls/fennel/step5_tco.fnl | 300 +- impls/fennel/step6_file.fnl | 350 +- impls/fennel/step7_quote.fnl | 446 +- impls/fennel/step8_macros.fnl | 556 +- impls/fennel/step9_try.fnl | 622 +- impls/fennel/stepA_mal.fnl | 632 +- impls/fennel/types.fnl | 640 +- impls/fennel/utils.fnl | 274 +- impls/forth/Dockerfile | 48 +- impls/forth/Makefile | 38 +- impls/forth/core.fs | 498 +- impls/forth/env.fs | 76 +- impls/forth/misc-tests.fs | 200 +- impls/forth/printer.fs | 226 +- impls/forth/reader.fs | 302 +- impls/forth/run | 4 +- impls/forth/step0_repl.fs | 50 +- impls/forth/step1_read_print.fs | 90 +- impls/forth/step2_eval.fs | 264 +- impls/forth/step3_env.fs | 336 +- impls/forth/step4_if_fn_do.fs | 460 +- impls/forth/step5_tco.fs | 482 +- impls/forth/step6_file.fs | 574 +- impls/forth/step7_quote.fs | 712 +- impls/forth/step8_macros.fs | 764 +- impls/forth/step9_try.fs | 850 +-- impls/forth/stepA_mal.fs | 868 +-- impls/forth/str.fs | 146 +- impls/forth/tests/step5_tco.mal | 30 +- impls/forth/tests/stepA_mal.mal | 82 +- impls/forth/types.fs | 1338 ++-- impls/fsharp/Dockerfile | 54 +- impls/fsharp/Makefile | 92 +- impls/fsharp/core.fs | 618 +- impls/fsharp/env.fs | 264 +- impls/fsharp/error.fs | 42 +- impls/fsharp/node.fs | 176 +- impls/fsharp/printer.fs | 174 +- impls/fsharp/reader.fs | 176 +- impls/fsharp/readline.fs | 32 +- impls/fsharp/run | 4 +- impls/fsharp/step0_repl.fs | 60 +- impls/fsharp/step1_read_print.fs | 86 +- impls/fsharp/step2_eval.fs | 126 +- impls/fsharp/step3_env.fs | 198 +- impls/fsharp/step4_if_fn_do.fs | 284 +- impls/fsharp/step5_tco.fs | 288 +- impls/fsharp/step6_file.fs | 340 +- impls/fsharp/step7_quote.fs | 392 +- impls/fsharp/step8_macros.fs | 450 +- impls/fsharp/step9_try.fs | 494 +- impls/fsharp/stepA_mal.fs | 518 +- impls/fsharp/terminal.cs | 2178 +++--- impls/fsharp/tests/step5_tco.mal | 4 +- impls/fsharp/tokenizer.fs | 230 +- impls/fsharp/types.fs | 268 +- impls/gnu-smalltalk/Dockerfile | 52 +- impls/gnu-smalltalk/Makefile | 6 +- impls/gnu-smalltalk/core.st | 510 +- impls/gnu-smalltalk/env.st | 106 +- impls/gnu-smalltalk/func.st | 56 +- impls/gnu-smalltalk/printer.st | 112 +- impls/gnu-smalltalk/reader.st | 340 +- impls/gnu-smalltalk/readline.st | 40 +- impls/gnu-smalltalk/run | 4 +- impls/gnu-smalltalk/step0_repl.st | 86 +- impls/gnu-smalltalk/step1_read_print.st | 100 +- impls/gnu-smalltalk/step2_eval.st | 186 +- impls/gnu-smalltalk/step3_env.st | 230 +- impls/gnu-smalltalk/step4_if_fn_do.st | 286 +- impls/gnu-smalltalk/step5_tco.st | 360 +- impls/gnu-smalltalk/step6_file.st | 384 +- impls/gnu-smalltalk/step7_quote.st | 498 +- impls/gnu-smalltalk/step8_macros.st | 606 +- impls/gnu-smalltalk/step9_try.st | 648 +- impls/gnu-smalltalk/stepA_mal.st | 652 +- impls/gnu-smalltalk/tests/stepA_mal.mal | 22 +- impls/gnu-smalltalk/types.st | 406 +- impls/gnu-smalltalk/util.st | 180 +- impls/go/Dockerfile | 56 +- impls/go/Makefile | 66 +- impls/go/run | 4 +- impls/go/src/core/core.go | 1134 +-- impls/go/src/env/env.go | 130 +- impls/go/src/printer/printer.go | 124 +- impls/go/src/reader/reader.go | 446 +- impls/go/src/readline/readline.go | 158 +- impls/go/src/step0_repl/step0_repl.go | 84 +- .../src/step1_read_print/step1_read_print.go | 132 +- impls/go/src/step2_eval/step2_eval.go | 332 +- impls/go/src/step3_env/step3_env.go | 418 +- impls/go/src/step4_if_fn_do/step4_if_fn_do.go | 436 +- impls/go/src/step5_tco/step5_tco.go | 456 +- impls/go/src/step6_file/step6_file.go | 496 +- impls/go/src/step7_quote/step7_quote.go | 598 +- impls/go/src/step8_macros/step8_macros.go | 712 +- impls/go/src/step9_try/step9_try.go | 768 +- impls/go/src/stepA_mal/stepA_mal.go | 772 +- impls/go/src/types/types.go | 560 +- impls/go/tests/step2_eval.mal | 68 +- impls/go/tests/step4_if_fn_do.mal | 68 +- impls/go/tests/step5_tco.mal | 4 +- impls/groovy/Dockerfile | 60 +- impls/groovy/GroovyWrapper.groovy | 152 +- impls/groovy/Makefile | 76 +- impls/groovy/core.groovy | 272 +- impls/groovy/env.groovy | 110 +- impls/groovy/printer.groovy | 88 +- impls/groovy/reader.groovy | 310 +- impls/groovy/run | 4 +- impls/groovy/step0_repl.groovy | 64 +- impls/groovy/step1_read_print.groovy | 76 +- impls/groovy/step2_eval.groovy | 140 +- impls/groovy/step3_env.groovy | 156 +- impls/groovy/step4_if_fn_do.groovy | 200 +- impls/groovy/step5_tco.groovy | 232 +- impls/groovy/step6_file.groovy | 248 +- impls/groovy/step7_quote.groovy | 328 +- impls/groovy/step8_macros.groovy | 392 +- impls/groovy/step9_try.groovy | 428 +- impls/groovy/stepA_mal.groovy | 430 +- impls/groovy/tests/step5_tco.mal | 30 +- impls/groovy/types.groovy | 242 +- impls/guile/Dockerfile | 66 +- impls/guile/Makefile | 34 +- impls/guile/core.scm | 540 +- impls/guile/env.scm | 128 +- impls/guile/pcre.scm | 272 +- impls/guile/printer.scm | 120 +- impls/guile/reader.scm | 268 +- impls/guile/readline.scm | 64 +- impls/guile/run | 6 +- impls/guile/step0_repl.scm | 76 +- impls/guile/step1_read_print.scm | 84 +- impls/guile/step2_eval.scm | 136 +- impls/guile/step3_env.scm | 174 +- impls/guile/step4_if_fn_do.scm | 214 +- impls/guile/step5_tco.scm | 266 +- impls/guile/step6_file.scm | 284 +- impls/guile/step7_quote.scm | 302 +- impls/guile/step8_macros.scm | 342 +- impls/guile/step9_try.scm | 388 +- impls/guile/stepA_mal.scm | 388 +- impls/guile/types.scm | 220 +- impls/haskell/Core.hs | 800 +- impls/haskell/Dockerfile | 70 +- impls/haskell/Env.hs | 120 +- impls/haskell/Makefile | 42 +- impls/haskell/Printer.hs | 76 +- impls/haskell/Reader.hs | 246 +- impls/haskell/Readline.hs | 70 +- impls/haskell/Types.hs | 146 +- impls/haskell/run | 4 +- impls/haskell/step0_repl.hs | 86 +- impls/haskell/step1_read_print.hs | 98 +- impls/haskell/step2_eval.hs | 206 +- impls/haskell/step3_env.hs | 258 +- impls/haskell/step4_if_fn_do.hs | 304 +- impls/haskell/step5_tco.hs | 304 +- impls/haskell/step6_file.hs | 332 +- impls/haskell/step7_quote.hs | 386 +- impls/haskell/step8_macros.hs | 432 +- impls/haskell/step9_try.hs | 452 +- impls/haskell/stepA_mal.hs | 456 +- impls/haskell/tests/step5_tco.mal | 4 +- impls/haxe/Compat.hx | 140 +- impls/haxe/Dockerfile | 106 +- impls/haxe/Makefile | 208 +- impls/haxe/Step0_repl.hx | 72 +- impls/haxe/Step1_read_print.hx | 84 +- impls/haxe/Step2_eval.hx | 184 +- impls/haxe/Step3_env.hx | 206 +- impls/haxe/Step4_if_fn_do.hx | 238 +- impls/haxe/Step5_tco.hx | 268 +- impls/haxe/Step6_file.hx | 298 +- impls/haxe/Step7_quote.hx | 362 +- impls/haxe/Step8_macros.hx | 438 +- impls/haxe/Step9_try.hx | 482 +- impls/haxe/StepA_mal.hx | 486 +- impls/haxe/core/Core.hx | 802 +- impls/haxe/env/Env.hx | 124 +- impls/haxe/node_readline.js | 92 +- impls/haxe/package.json | 16 +- impls/haxe/printer/Printer.hx | 110 +- impls/haxe/reader/BlankLine.hx | 12 +- impls/haxe/reader/Reader.hx | 274 +- impls/haxe/run | 16 +- impls/haxe/tests/step5_tco.mal | 30 +- impls/haxe/types/MalException.hx | 20 +- impls/haxe/types/Types.hx | 514 +- impls/hy/Dockerfile | 56 +- impls/hy/Makefile | 14 +- impls/hy/core.hy | 196 +- impls/hy/env.hy | 62 +- impls/hy/mal_types.hy | 30 +- impls/hy/printer.hy | 50 +- impls/hy/reader.hy | 192 +- impls/hy/run | 4 +- impls/hy/step0_repl.hy | 44 +- impls/hy/step1_read_print.hy | 60 +- impls/hy/step2_eval.hy | 128 +- impls/hy/step3_env.hy | 160 +- impls/hy/step4_if_fn_do.hy | 208 +- impls/hy/step5_tco.hy | 242 +- impls/hy/step6_file.hy | 256 +- impls/hy/step7_quote.hy | 310 +- impls/hy/step8_macros.hy | 368 +- impls/hy/step9_try.hy | 392 +- impls/hy/stepA_mal.hy | 396 +- impls/hy/tests/step5_tco.mal | 30 +- impls/io/Dockerfile | 66 +- impls/io/Env.io | 90 +- impls/io/Makefile | 8 +- impls/io/MalCore.io | 308 +- impls/io/MalReader.io | 184 +- impls/io/MalReadline.io | 38 +- impls/io/MalTypes.io | 268 +- impls/io/run | 12 +- impls/io/step0_repl.io | 36 +- impls/io/step1_read_print.io | 44 +- impls/io/step2_eval.io | 102 +- impls/io/step3_env.io | 136 +- impls/io/step4_if_fn_do.io | 154 +- impls/io/step5_tco.io | 184 +- impls/io/step6_file.io | 202 +- impls/io/step7_quote.io | 250 +- impls/io/step8_macros.io | 302 +- impls/io/step9_try.io | 324 +- impls/io/stepA_mal.io | 328 +- impls/io/tests/step5_tco.mal | 4 +- impls/io/tests/stepA_mal.mal | 66 +- impls/janet/Dockerfile | 58 +- impls/janet/Makefile | 4 +- impls/janet/core.janet | 1554 ++-- impls/janet/env.janet | 100 +- impls/janet/printer.janet | 202 +- impls/janet/reader.janet | 622 +- impls/janet/run | 6 +- impls/janet/step0_repl.janet | 62 +- impls/janet/step1_read_print.janet | 98 +- impls/janet/step2_eval.janet | 190 +- impls/janet/step3_env.janet | 228 +- impls/janet/step4_if_fn_do.janet | 260 +- impls/janet/step5_tco.janet | 298 +- impls/janet/step6_file.janet | 354 +- impls/janet/step7_quote.janet | 460 +- impls/janet/step8_macros.janet | 556 +- impls/janet/step9_try.janet | 606 +- impls/janet/stepA_mal.janet | 616 +- impls/janet/tests/stepA_mal.mal | 84 +- impls/janet/types.janet | 490 +- impls/janet/utils.janet | 6 +- impls/java-truffle/.gitignore | 20 +- impls/java-truffle/Makefile | 16 +- impls/java-truffle/README.md | 1398 ++-- impls/java-truffle/build.gradle | 56 +- impls/java-truffle/make-native.sh | 16 +- impls/java-truffle/run | 40 +- impls/java-truffle/settings.gradle | 10 +- .../src/main/java/truffle/mal/Core.java | 3028 ++++---- .../src/main/java/truffle/mal/MalEnv.java | 746 +- .../src/main/java/truffle/mal/Printer.java | 200 +- .../src/main/java/truffle/mal/Reader.java | 332 +- .../src/main/java/truffle/mal/Types.java | 1108 +-- .../java/truffle/mal/step1_read_print.java | 52 +- .../src/main/java/truffle/mal/step2_eval.java | 516 +- .../src/main/java/truffle/mal/step3_env.java | 614 +- .../main/java/truffle/mal/step4_if_fn_do.java | 1064 +-- .../src/main/java/truffle/mal/step5_tco.java | 1124 +-- .../src/main/java/truffle/mal/step6_file.java | 1158 +-- .../main/java/truffle/mal/step7_quote.java | 1246 +-- .../main/java/truffle/mal/step8_macros.java | 1424 ++-- .../src/main/java/truffle/mal/step9_try.java | 1500 ++-- .../src/main/java/truffle/mal/stepA_mal.java | 1514 ++-- .../main/java/truffle/mal/stepB_calls.java | 1594 ++-- .../main/java/truffle/mal/stepC_slots.java | 1696 ++--- .../main/java/truffle/mal/stepD_caching.java | 1720 ++--- .../main/java/truffle/mal/stepE_macros.java | 1810 ++--- impls/java/Dockerfile | 56 +- impls/java/Makefile | 60 +- impls/java/pom.xml | 190 +- impls/java/run | 18 +- impls/java/src/main/java/mal/core.java | 1266 ++-- impls/java/src/main/java/mal/env.java | 116 +- impls/java/src/main/java/mal/printer.java | 106 +- impls/java/src/main/java/mal/reader.java | 302 +- impls/java/src/main/java/mal/readline.java | 210 +- impls/java/src/main/java/mal/step0_repl.java | 96 +- .../src/main/java/mal/step1_read_print.java | 122 +- impls/java/src/main/java/mal/step2_eval.java | 276 +- impls/java/src/main/java/mal/step3_env.java | 316 +- .../src/main/java/mal/step4_if_fn_do.java | 330 +- impls/java/src/main/java/mal/step5_tco.java | 356 +- impls/java/src/main/java/mal/step6_file.java | 392 +- impls/java/src/main/java/mal/step7_quote.java | 470 +- .../java/src/main/java/mal/step8_macros.java | 556 +- impls/java/src/main/java/mal/step9_try.java | 618 +- impls/java/src/main/java/mal/stepA_mal.java | 622 +- impls/java/src/main/java/mal/types.java | 762 +- impls/java/tests/step5_tco.mal | 30 +- impls/jq/Dockerfile | 64 +- impls/jq/Makefile | 6 +- impls/jq/core.jq | 984 +-- impls/jq/env.jq | 560 +- impls/jq/interp.jq | 354 +- impls/jq/printer.jq | 56 +- impls/jq/reader.jq | 622 +- impls/jq/rts.py | 224 +- impls/jq/run | 6 +- impls/jq/step0_repl.jq | 54 +- impls/jq/step1_read_print.jq | 84 +- impls/jq/step2_eval.jq | 240 +- impls/jq/step3_env.jq | 436 +- impls/jq/step4_if_fn_do.jq | 1132 +-- impls/jq/step5_tco.jq | 1164 +-- impls/jq/step6_file.jq | 506 +- impls/jq/step7_quote.jq | 626 +- impls/jq/step8_macros.jq | 762 +- impls/jq/step9_try.jq | 820 +- impls/jq/stepA_mal.jq | 844 +-- impls/jq/utils.jq | 302 +- impls/js/Dockerfile | 68 +- impls/js/Makefile | 86 +- impls/js/core.js | 544 +- impls/js/env.js | 104 +- impls/js/interop.js | 78 +- impls/js/jq_readline.js | 46 +- impls/js/node_readline.js | 92 +- impls/js/package.json | 16 +- impls/js/printer.js | 100 +- impls/js/reader.js | 264 +- impls/js/run | 4 +- impls/js/step0_repl.js | 64 +- impls/js/step1_read_print.js | 82 +- impls/js/step2_eval.js | 170 +- impls/js/step3_env.js | 190 +- impls/js/step4_if_fn_do.js | 222 +- impls/js/step5_tco.js | 244 +- impls/js/step6_file.js | 264 +- impls/js/step7_quote.js | 324 +- impls/js/step8_macros.js | 378 +- impls/js/step9_try.js | 400 +- impls/js/stepA_mal.js | 404 +- impls/js/tests/common.js | 30 +- impls/js/tests/reader.js | 138 +- impls/js/tests/step5_tco.mal | 30 +- impls/js/tests/stepA_mal.mal | 78 +- impls/js/tests/types.js | 192 +- impls/js/types.js | 460 +- impls/julia/Dockerfile | 58 +- impls/julia/Makefile | 8 +- impls/julia/core.jl | 282 +- impls/julia/env.jl | 110 +- impls/julia/printer.jl | 80 +- impls/julia/reader.jl | 264 +- impls/julia/readline_mod.jl | 30 +- impls/julia/run | 4 +- impls/julia/step0_repl.jl | 60 +- impls/julia/step1_read_print.jl | 86 +- impls/julia/step2_eval.jl | 130 +- impls/julia/step3_env.jl | 154 +- impls/julia/step4_if_fn_do.jl | 194 +- impls/julia/step5_tco.jl | 232 +- impls/julia/step6_file.jl | 248 +- impls/julia/step7_quote.jl | 320 +- impls/julia/step8_macros.jl | 376 +- impls/julia/step9_try.jl | 412 +- impls/julia/stepA_mal.jl | 416 +- impls/julia/tests/step5_tco.mal | 30 +- impls/julia/types.jl | 162 +- impls/kotlin/Dockerfile | 68 +- impls/kotlin/Makefile | 46 +- impls/kotlin/run | 4 +- impls/kotlin/src/mal/core.kt | 484 +- impls/kotlin/src/mal/env.kt | 72 +- impls/kotlin/src/mal/printer.kt | 54 +- impls/kotlin/src/mal/reader.kt | 312 +- impls/kotlin/src/mal/readline.kt | 16 +- impls/kotlin/src/mal/step0_repl.kt | 38 +- impls/kotlin/src/mal/step1_read_print.kt | 44 +- impls/kotlin/src/mal/step2_eval.kt | 90 +- impls/kotlin/src/mal/step3_env.kt | 122 +- impls/kotlin/src/mal/step4_if_fn_do.kt | 206 +- impls/kotlin/src/mal/step5_tco.kt | 206 +- impls/kotlin/src/mal/step6_file.kt | 228 +- impls/kotlin/src/mal/step7_quote.kt | 310 +- impls/kotlin/src/mal/step8_macros.kt | 372 +- impls/kotlin/src/mal/step9_try.kt | 404 +- impls/kotlin/src/mal/stepA_mal.kt | 406 +- impls/kotlin/src/mal/types.kt | 444 +- impls/kotlin/tests/step5_tco.mal | 30 +- impls/lib/README.md | 64 +- impls/lib/alias-hacks.mal | 44 +- impls/lib/benchmark.mal | 30 +- impls/lib/equality.mal | 154 +- impls/lib/load-file-once.mal | 32 +- impls/lib/memoize.mal | 50 +- impls/lib/perf.mal | 82 +- impls/lib/pprint.mal | 86 +- impls/lib/protocols.mal | 190 +- impls/lib/reducers.mal | 64 +- impls/lib/test_cascade.mal | 134 +- impls/lib/threading.mal | 68 +- impls/lib/trivial.mal | 40 +- impls/livescript/Dockerfile | 68 +- impls/livescript/Makefile | 62 +- impls/livescript/core.ls | 698 +- impls/livescript/env.ls | 42 +- impls/livescript/node_readline.js | 94 +- impls/livescript/package.json | 36 +- impls/livescript/printer.ls | 100 +- impls/livescript/reader.ls | 362 +- impls/livescript/run | 4 +- impls/livescript/step0_repl.ls | 56 +- impls/livescript/step1_read_print.ls | 36 +- impls/livescript/step2_eval.ls | 106 +- impls/livescript/step3_env.ls | 252 +- impls/livescript/step4_if_fn_do.ls | 398 +- impls/livescript/step5_tco.ls | 434 +- impls/livescript/step6_file.ls | 494 +- impls/livescript/step7_quote.ls | 620 +- impls/livescript/step8_macros.ls | 742 +- impls/livescript/step9_try.ls | 804 +- impls/livescript/stepA_mal.ls | 812 +- impls/livescript/utils.ls | 12 +- impls/logo/Dockerfile | 98 +- impls/logo/Makefile | 42 +- impls/logo/core.lg | 876 +-- impls/logo/env.lg | 102 +- impls/logo/examples/tree.mal | 50 +- impls/logo/printer.lg | 108 +- impls/logo/reader.lg | 442 +- impls/logo/readline.lg | 54 +- impls/logo/run | 4 +- impls/logo/step0_repl.lg | 62 +- impls/logo/step1_read_print.lg | 82 +- impls/logo/step2_eval.lg | 156 +- impls/logo/step3_env.lg | 192 +- impls/logo/step4_if_fn_do.lg | 226 +- impls/logo/step5_tco.lg | 246 +- impls/logo/step6_file.lg | 302 +- impls/logo/step7_quote.lg | 372 +- impls/logo/step8_macros.lg | 440 +- impls/logo/step9_try.lg | 478 +- impls/logo/stepA_mal.lg | 482 +- impls/logo/tests/stepA_mal.mal | 60 +- impls/logo/types.lg | 342 +- impls/lua/Dockerfile | 86 +- impls/lua/Makefile | 78 +- impls/lua/core.lua | 650 +- impls/lua/env.lua | 106 +- impls/lua/printer.lua | 110 +- impls/lua/reader.lua | 264 +- impls/lua/readline.lua | 82 +- impls/lua/run | 4 +- impls/lua/step0_repl.lua | 58 +- impls/lua/step1_read_print.lua | 94 +- impls/lua/step2_eval.lua | 160 +- impls/lua/step3_env.lua | 186 +- impls/lua/step4_if_fn_do.lua | 222 +- impls/lua/step5_tco.lua | 238 +- impls/lua/step6_file.lua | 258 +- impls/lua/step7_quote.lua | 336 +- impls/lua/step8_macros.lua | 392 +- impls/lua/step9_try.lua | 432 +- impls/lua/stepA_mal.lua | 438 +- impls/lua/tests/step5_tco.mal | 30 +- impls/lua/tests/stepA_mal.mal | 76 +- impls/lua/types.lua | 458 +- impls/lua/utils.lua | 106 +- impls/make/Dockerfile | 48 +- impls/make/Makefile | 62 +- impls/make/core.mk | 608 +- impls/make/env.mk | 100 +- impls/make/gmsl.mk | 124 +- impls/make/numbers.mk | 1032 +-- impls/make/printer.mk | 94 +- impls/make/reader.mk | 402 +- impls/make/readline.mk | 46 +- impls/make/rules.mk | 68 +- impls/make/run | 4 +- impls/make/step0_repl.mk | 50 +- impls/make/step1_read_print.mk | 64 +- impls/make/step2_eval.mk | 150 +- impls/make/step3_env.mk | 196 +- impls/make/step4_if_fn_do.mk | 232 +- impls/make/step6_file.mk | 262 +- impls/make/step7_quote.mk | 312 +- impls/make/step8_macros.mk | 358 +- impls/make/step9_try.mk | 388 +- impls/make/stepA_mal.mk | 402 +- impls/make/tests/stepA_mal.mal | 38 +- impls/make/types.mk | 536 +- impls/make/util.mk | 198 +- impls/mal/Dockerfile | 68 +- impls/mal/Makefile | 20 +- impls/mal/core.mal | 22 +- impls/mal/env.mal | 80 +- impls/mal/run | 18 +- impls/mal/step0_repl.mal | 50 +- impls/mal/step1_read_print.mal | 56 +- impls/mal/step2_eval.mal | 140 +- impls/mal/step3_env.mal | 178 +- impls/mal/step4_if_fn_do.mal | 206 +- impls/mal/step6_file.mal | 216 +- impls/mal/step7_quote.mal | 270 +- impls/mal/step8_macros.mal | 304 +- impls/mal/step9_try.mal | 326 +- impls/mal/stepA_mal.mal | 330 +- impls/matlab/+types/Atom.m | 20 +- impls/matlab/+types/Function.m | 48 +- impls/matlab/+types/HashMap.m | 132 +- impls/matlab/+types/List.m | 134 +- impls/matlab/+types/MalException.m | 22 +- impls/matlab/+types/Nil.m | 20 +- impls/matlab/+types/Reader.m | 54 +- impls/matlab/+types/Symbol.m | 26 +- impls/matlab/+types/Vector.m | 42 +- impls/matlab/.dockerignore | 2 +- impls/matlab/Dict.m | 122 +- impls/matlab/Dockerfile | 70 +- impls/matlab/Env.m | 134 +- impls/matlab/Makefile | 8 +- impls/matlab/core.m | 608 +- impls/matlab/printer.m | 110 +- impls/matlab/reader.m | 262 +- impls/matlab/run | 26 +- impls/matlab/step0_repl.m | 56 +- impls/matlab/step1_read_print.m | 78 +- impls/matlab/step2_eval.m | 178 +- impls/matlab/step3_env.m | 202 +- impls/matlab/step4_if_fn_do.m | 250 +- impls/matlab/step5_tco.m | 276 +- impls/matlab/step6_file.m | 294 +- impls/matlab/step7_quote.m | 384 +- impls/matlab/step8_macros.m | 450 +- impls/matlab/step9_try.m | 516 +- impls/matlab/stepA_mal.m | 520 +- impls/matlab/type_utils.m | 208 +- impls/miniMAL/Dockerfile | 74 +- impls/miniMAL/Makefile | 60 +- impls/miniMAL/core.json | 388 +- impls/miniMAL/env.json | 84 +- impls/miniMAL/miniMAL-core.json | 280 +- impls/miniMAL/node_readline.js | 92 +- impls/miniMAL/package.json | 18 +- impls/miniMAL/printer.json | 132 +- impls/miniMAL/reader.json | 260 +- impls/miniMAL/run | 6 +- impls/miniMAL/step0_repl.json | 44 +- impls/miniMAL/step1_read_print.json | 54 +- impls/miniMAL/step2_eval.json | 124 +- impls/miniMAL/step3_env.json | 152 +- impls/miniMAL/step4_if_fn_do.json | 194 +- impls/miniMAL/step5_tco.json | 210 +- impls/miniMAL/step6_file.json | 224 +- impls/miniMAL/step7_quote.json | 290 +- impls/miniMAL/step8_macros.json | 340 +- impls/miniMAL/step9_try.json | 366 +- impls/miniMAL/stepA_mal.json | 372 +- impls/miniMAL/tests/step5_tco.mal | 4 +- impls/miniMAL/types.json | 332 +- impls/nasm/Dockerfile | 52 +- impls/nasm/Makefile | 34 +- impls/nasm/README.md | 60 +- impls/nasm/core.asm | 6694 ++++++++--------- impls/nasm/env.asm | 618 +- impls/nasm/exceptions.asm | 276 +- impls/nasm/macros.mac | 98 +- impls/nasm/printer.asm | 1088 +-- impls/nasm/reader.asm | 2236 +++--- impls/nasm/run | 6 +- impls/nasm/step0_repl.asm | 164 +- impls/nasm/step1_read_print.asm | 212 +- impls/nasm/step2_eval.asm | 1366 ++-- impls/nasm/step3_env.asm | 2156 +++--- impls/nasm/step4_if_fn_do.asm | 2764 +++---- impls/nasm/step5_tco.asm | 3174 ++++---- impls/nasm/step6_file.asm | 3402 ++++----- impls/nasm/step7_quote.asm | 4152 +++++----- impls/nasm/step8_macros.asm | 4590 +++++------ impls/nasm/step9_try.asm | 5082 ++++++------- impls/nasm/stepA_mal.asm | 5150 ++++++------- impls/nasm/system.asm | 466 +- impls/nasm/types.asm | 3928 +++++----- impls/nim/Dockerfile | 70 +- impls/nim/Makefile | 54 +- impls/nim/core.nim | 492 +- impls/nim/env.nim | 50 +- impls/nim/mal.nimble | 22 +- impls/nim/nim.cfg | 2 +- impls/nim/printer.nim | 54 +- impls/nim/reader.nim | 232 +- impls/nim/run | 4 +- impls/nim/step0_repl.nim | 22 +- impls/nim/step1_read_print.nim | 28 +- impls/nim/step2_eval.nim | 106 +- impls/nim/step3_env.nim | 142 +- impls/nim/step4_if_fn_do.nim | 210 +- impls/nim/step5_tco.nim | 234 +- impls/nim/step6_file.nim | 254 +- impls/nim/step7_quote.nim | 328 +- impls/nim/step8_macros.nim | 372 +- impls/nim/step9_try.nim | 418 +- impls/nim/stepA_mal.nim | 424 +- impls/nim/tests/step5_tco.mal | 4 +- impls/nim/types.nim | 322 +- impls/objc/Dockerfile | 124 +- impls/objc/Makefile | 100 +- impls/objc/core.h | 14 +- impls/objc/core.m | 716 +- impls/objc/env.h | 6 +- impls/objc/env.m | 150 +- impls/objc/mal_readline.c | 150 +- impls/objc/mal_readline.h | 12 +- impls/objc/malfunc.h | 48 +- impls/objc/malfunc.m | 98 +- impls/objc/printer.h | 6 +- impls/objc/printer.m | 116 +- impls/objc/reader.h | 4 +- impls/objc/reader.m | 388 +- impls/objc/run | 4 +- impls/objc/step0_repl.m | 76 +- impls/objc/step1_read_print.m | 96 +- impls/objc/step2_eval.m | 222 +- impls/objc/step3_env.m | 248 +- impls/objc/step4_if_fn_do.m | 298 +- impls/objc/step5_tco.m | 302 +- impls/objc/step6_file.m | 344 +- impls/objc/step7_quote.m | 428 +- impls/objc/step8_macros.m | 498 +- impls/objc/step9_try.m | 536 +- impls/objc/stepA_mal.m | 538 +- impls/objc/tests/step5_tco.mal | 4 +- impls/objc/types.h | 188 +- impls/objc/types.m | 350 +- impls/objpascal/Dockerfile | 50 +- impls/objpascal/Makefile | 62 +- impls/objpascal/core.pas | 1264 ++-- impls/objpascal/mal_env.pas | 202 +- impls/objpascal/mal_func.pas | 114 +- impls/objpascal/mal_readline.pas | 98 +- impls/objpascal/mal_types.pas | 774 +- impls/objpascal/printer.pas | 228 +- impls/objpascal/reader.pas | 470 +- impls/objpascal/run | 4 +- impls/objpascal/step0_repl.pas | 94 +- impls/objpascal/step1_read_print.pas | 114 +- impls/objpascal/step2_eval.pas | 302 +- impls/objpascal/step3_env.pas | 346 +- impls/objpascal/step4_if_fn_do.pas | 398 +- impls/objpascal/step5_tco.pas | 404 +- impls/objpascal/step6_file.pas | 446 +- impls/objpascal/step7_quote.pas | 548 +- impls/objpascal/step8_macros.pas | 660 +- impls/objpascal/step9_try.pas | 710 +- impls/objpascal/stepA_mal.pas | 716 +- impls/objpascal/tests/step5_tco.mal | 4 +- impls/ocaml/Dockerfile | 50 +- impls/ocaml/Makefile | 66 +- impls/ocaml/core.ml | 484 +- impls/ocaml/env.ml | 66 +- impls/ocaml/printer.ml | 76 +- impls/ocaml/reader.ml | 250 +- impls/ocaml/run | 4 +- impls/ocaml/step0_repl.ml | 46 +- impls/ocaml/step1_read_print.ml | 30 +- impls/ocaml/step2_eval.ml | 128 +- impls/ocaml/step3_env.ml | 148 +- impls/ocaml/step4_if_fn_do.ml | 168 +- impls/ocaml/step6_file.ml | 190 +- impls/ocaml/step7_quote.ml | 228 +- impls/ocaml/step8_macros.ml | 292 +- impls/ocaml/step9_try.ml | 336 +- impls/ocaml/stepA_mal.ml | 342 +- impls/ocaml/tests/step5_tco.mal | 4 +- impls/ocaml/types.ml | 138 +- impls/perl/Dockerfile | 48 +- impls/perl/Makefile | 50 +- impls/perl/README.md | 56 +- impls/perl/core.pm | 486 +- impls/perl/env.pm | 126 +- impls/perl/interop.pm | 66 +- impls/perl/printer.pm | 92 +- impls/perl/reader.pm | 236 +- impls/perl/readline.pm | 146 +- impls/perl/run | 4 +- impls/perl/step0_repl.pl | 78 +- impls/perl/step1_read_print.pl | 116 +- impls/perl/step2_eval.pl | 180 +- impls/perl/step3_env.pl | 226 +- impls/perl/step4_if_fn_do.pl | 270 +- impls/perl/step5_tco.pl | 282 +- impls/perl/step6_file.pl | 302 +- impls/perl/step7_quote.pl | 384 +- impls/perl/step8_macros.pl | 460 +- impls/perl/step9_try.pl | 508 +- impls/perl/stepA_mal.pl | 510 +- impls/perl/tests/step5_tco.mal | 30 +- impls/perl/tests/stepA_mal.mal | 60 +- impls/perl/types.pm | 394 +- impls/perl6/Dockerfile | 68 +- impls/perl6/Makefile | 8 +- impls/perl6/core.pm | 210 +- impls/perl6/env.pm | 72 +- impls/perl6/printer.pm | 58 +- impls/perl6/reader.pm | 174 +- impls/perl6/run | 4 +- impls/perl6/step0_repl.pl | 54 +- impls/perl6/step1_read_print.pl | 60 +- impls/perl6/step2_eval.pl | 104 +- impls/perl6/step3_env.pl | 134 +- impls/perl6/step4_if_fn_do.pl | 160 +- impls/perl6/step5_tco.pl | 182 +- impls/perl6/step6_file.pl | 198 +- impls/perl6/step7_quote.pl | 264 +- impls/perl6/step8_macros.pl | 310 +- impls/perl6/step9_try.pl | 332 +- impls/perl6/stepA_mal.pl | 336 +- impls/perl6/tests/stepA_mal.mal | 96 +- impls/perl6/types.pm | 188 +- impls/php/Dockerfile | 48 +- impls/php/Makefile | 42 +- impls/php/README.md | 84 +- impls/php/core.php | 574 +- impls/php/env.php | 112 +- impls/php/interop.php | 160 +- impls/php/printer.php | 122 +- impls/php/reader.php | 256 +- impls/php/readline.php | 82 +- impls/php/run | 4 +- impls/php/step0_repl.php | 68 +- impls/php/step1_read_print.php | 88 +- impls/php/step2_eval.php | 166 +- impls/php/step3_env.php | 200 +- impls/php/step4_if_fn_do.php | 242 +- impls/php/step5_tco.php | 266 +- impls/php/step6_file.php | 294 +- impls/php/step7_quote.php | 374 +- impls/php/step8_macros.php | 434 +- impls/php/step9_try.php | 474 +- impls/php/stepA_mal.php | 496 +- impls/php/tests/step5_tco.mal | 4 +- impls/php/tests/stepA_mal.mal | 90 +- impls/php/types.php | 450 +- impls/php/webrunner.php | 16 +- impls/picolisp/Dockerfile | 52 +- impls/picolisp/Makefile | 6 +- impls/picolisp/core.l | 360 +- impls/picolisp/env.l | 48 +- impls/picolisp/func.l | 40 +- impls/picolisp/printer.l | 56 +- impls/picolisp/reader.l | 252 +- impls/picolisp/readline.l | 38 +- impls/picolisp/run | 4 +- impls/picolisp/step0_repl.l | 56 +- impls/picolisp/step1_read_print.l | 72 +- impls/picolisp/step2_eval.l | 118 +- impls/picolisp/step3_env.l | 142 +- impls/picolisp/step4_if_fn_do.l | 180 +- impls/picolisp/step5_tco.l | 188 +- impls/picolisp/step6_file.l | 200 +- impls/picolisp/step7_quote.l | 264 +- impls/picolisp/step8_macros.l | 312 +- impls/picolisp/step9_try.l | 336 +- impls/picolisp/stepA_mal.l | 340 +- impls/picolisp/tests/step5_tco.mal | 4 +- impls/picolisp/tests/stepA_mal.mal | 34 +- impls/picolisp/types.l | 202 +- impls/pike/Core.pmod | 196 +- impls/pike/Dockerfile | 48 +- impls/pike/Env.pmod | 90 +- impls/pike/Interop.pmod | 66 +- impls/pike/Makefile | 38 +- impls/pike/Printer.pmod | 14 +- impls/pike/Reader.pmod | 244 +- impls/pike/Readline.pmod | 8 +- impls/pike/Types.pmod | 920 +-- impls/pike/run | 4 +- impls/pike/step0_repl.pike | 68 +- impls/pike/step1_read_print.pike | 82 +- impls/pike/step2_eval.pike | 150 +- impls/pike/step3_env.pike | 176 +- impls/pike/step4_if_fn_do.pike | 212 +- impls/pike/step5_tco.pike | 248 +- impls/pike/step6_file.pike | 264 +- impls/pike/step7_quote.pike | 360 +- impls/pike/step8_macros.pike | 422 +- impls/pike/step9_try.pike | 462 +- impls/pike/stepA_mal.pike | 466 +- impls/pike/tests/step5_tco.mal | 30 +- impls/pike/tests/stepA_mal.mal | 72 +- impls/plpgsql/Dockerfile | 74 +- impls/plpgsql/Makefile | 6 +- impls/plpgsql/core.sql | 1168 +-- impls/plpgsql/entrypoint.sh | 50 +- impls/plpgsql/envs.sql | 266 +- impls/plpgsql/init.sql | 26 +- impls/plpgsql/io.sql | 448 +- impls/plpgsql/printer.sql | 222 +- impls/plpgsql/reader.sql | 376 +- impls/plpgsql/run | 4 +- impls/plpgsql/step0_repl.sql | 118 +- impls/plpgsql/step1_read_print.sql | 124 +- impls/plpgsql/step2_eval.sql | 324 +- impls/plpgsql/step3_env.sql | 392 +- impls/plpgsql/step4_if_fn_do.sql | 426 +- impls/plpgsql/step5_tco.sql | 444 +- impls/plpgsql/step6_file.sql | 498 +- impls/plpgsql/step7_quote.sql | 634 +- impls/plpgsql/step8_macros.sql | 726 +- impls/plpgsql/step9_try.sql | 764 +- impls/plpgsql/stepA_mal.sql | 768 +- impls/plpgsql/types.sql | 1406 ++-- impls/plpgsql/wrap.sh | 150 +- impls/plsql/Dockerfile | 68 +- impls/plsql/Dockerfile-oracle | 12 +- impls/plsql/Dockerfile-postgres | 44 +- impls/plsql/Makefile | 6 +- impls/plsql/core.sql | 1264 ++-- impls/plsql/entrypoint.sh | 34 +- impls/plsql/env.sql | 296 +- impls/plsql/io.sql | 500 +- impls/plsql/login.sql | 50 +- impls/plsql/printer.sql | 256 +- impls/plsql/reader.sql | 472 +- impls/plsql/run | 4 +- impls/plsql/step0_repl.sql | 128 +- impls/plsql/step1_read_print.sql | 146 +- impls/plsql/step2_eval.sql | 356 +- impls/plsql/step3_env.sql | 430 +- impls/plsql/step4_if_fn_do.sql | 406 +- impls/plsql/step5_tco.sql | 420 +- impls/plsql/step6_file.sql | 548 +- impls/plsql/step7_quote.sql | 646 +- impls/plsql/step8_macros.sql | 760 +- impls/plsql/step9_try.sql | 940 +-- impls/plsql/stepA_mal.sql | 944 +-- impls/plsql/types.sql | 1276 ++-- impls/plsql/wrap.sh | 244 +- impls/powershell/Dockerfile | 72 +- impls/powershell/Makefile | 8 +- impls/powershell/core.psm1 | 358 +- impls/powershell/env.psm1 | 114 +- impls/powershell/printer.psm1 | 118 +- impls/powershell/reader.psm1 | 260 +- impls/powershell/run | 4 +- impls/powershell/step0_repl.ps1 | 16 +- impls/powershell/step1_read_print.ps1 | 74 +- ...step2_eval - \345\211\257\346\234\254.ps1" | 69 + impls/powershell/step2_eval.ps1 | 138 +- impls/powershell/step3_env.ps1 | 168 +- impls/powershell/step4_if_fn_do.ps1 | 218 +- impls/powershell/step5_tco.ps1 | 244 +- impls/powershell/step6_file.ps1 | 262 +- impls/powershell/step7_quote.ps1 | 352 +- impls/powershell/step8_macros.ps1 | 412 +- impls/powershell/step9_try.ps1 | 452 +- impls/powershell/stepA_mal.ps1 | 456 +- impls/powershell/types.psm1 | 676 +- impls/prolog/Dockerfile | 42 +- impls/prolog/Makefile | 4 +- impls/prolog/core.pl | 528 +- impls/prolog/env.pl | 62 +- impls/prolog/printer.pl | 124 +- impls/prolog/reader.pl | 130 +- impls/prolog/run | 4 +- impls/prolog/step0_repl.pl | 82 +- impls/prolog/step1_read_print.pl | 88 +- impls/prolog/step2_eval.pl | 172 +- impls/prolog/step3_env.pl | 214 +- impls/prolog/step4_if_fn_do.pl | 284 +- impls/prolog/step6_file.pl | 318 +- impls/prolog/step7_quote.pl | 396 +- impls/prolog/step8_macros.pl | 456 +- impls/prolog/step9_try.pl | 482 +- impls/prolog/stepA_mal.pl | 488 +- impls/prolog/tests/stepA_mal.mal | 58 +- impls/prolog/types.pl | 362 +- impls/prolog/utils.pl | 92 +- impls/ps/Dockerfile | 50 +- impls/ps/Makefile | 40 +- impls/ps/core.ps | Bin 8862 -> 9208 bytes impls/ps/env.ps | Bin 1437 -> 1494 bytes impls/ps/interop.ps | Bin 524 -> 545 bytes impls/ps/printer.ps | Bin 3484 -> 3599 bytes impls/ps/reader.ps | Bin 8844 -> 9124 bytes impls/ps/run | 4 +- impls/ps/step0_repl.ps | Bin 566 -> 606 bytes impls/ps/step1_read_print.ps | Bin 869 -> 920 bytes impls/ps/step2_eval.ps | Bin 2120 -> 2217 bytes impls/ps/step3_env.ps | Bin 2699 -> 2811 bytes impls/ps/step4_if_fn_do.ps | Bin 3842 -> 3985 bytes impls/ps/step5_tco.ps | Bin 4163 -> 4318 bytes impls/ps/step6_file.ps | Bin 4672 -> 4840 bytes impls/ps/step7_quote.ps | Bin 5996 -> 6219 bytes impls/ps/step8_macros.ps | Bin 7362 -> 7627 bytes impls/ps/step9_try.ps | Bin 9215 -> 9523 bytes impls/ps/stepA_mal.ps | Bin 9655 -> 9974 bytes impls/ps/tests/step5_tco.mal | 30 +- impls/ps/tests/stepA_mal.mal | 50 +- impls/ps/types.ps | Bin 9867 -> 10311 bytes impls/purs/.gitignore | 24 +- impls/purs/Dockerfile | 74 +- impls/purs/Makefile | 68 +- impls/purs/package.json | 10 +- impls/purs/packages.dhall | 208 +- impls/purs/run | 2 +- impls/purs/spago.dhall | 86 +- impls/purs/src/Core.purs | 1028 +-- impls/purs/src/Env.purs | 90 +- impls/purs/src/Printer.purs | 162 +- impls/purs/src/Reader.purs | 344 +- impls/purs/src/Readline.js | 32 +- impls/purs/src/Readline.purs | 30 +- impls/purs/src/Types.purs | 268 +- impls/purs/src/step0_repl.purs | 102 +- impls/purs/src/step1_read_print.purs | 120 +- impls/purs/src/step2_eval.purs | 218 +- impls/purs/src/step3_env.purs | 284 +- impls/purs/src/step4_if_fn_do.purs | 376 +- impls/purs/src/step5_tco.purs | 462 +- impls/purs/src/step6_file.purs | 488 +- impls/purs/src/step7_quote.purs | 596 +- impls/purs/src/step8_macros.purs | 670 +- impls/purs/src/step9_try.purs | 710 +- impls/purs/src/stepA_mal.purs | 716 +- impls/python.2/.gitignore | 6 +- impls/python.2/Dockerfile | 62 +- impls/python.2/Makefile | 12 +- impls/python.2/core.py | 854 +-- impls/python.2/env.py | 104 +- impls/python.2/mal_types.py | 578 +- impls/python.2/reader.py | 402 +- impls/python.2/run | 4 +- impls/python.2/step0_repl.py | 56 +- impls/python.2/step1_read_print.py | 76 +- impls/python.2/step2_eval.py | 146 +- impls/python.2/step3_env.py | 198 +- impls/python.2/step4_if_fn_do.py | 254 +- impls/python.2/step5_tco.py | 288 +- impls/python.2/step6_file.py | 350 +- impls/python.2/step7_quote.py | 428 +- impls/python.2/step8_macros.py | 540 +- impls/python.2/step9_try.py | 558 +- impls/python.2/stepA_mal.py | 574 +- impls/python.2/tests/test_step2.py | 24 +- impls/python.2/tests/test_step3.py | 308 +- impls/python.2/tests/test_step4.py | 424 +- impls/python.2/tests/test_step5.py | 42 +- impls/python.2/tests/test_step6.py | 144 +- impls/python.2/tests/test_step7.py | 54 +- impls/python.2/tests/test_step8.py | 200 +- impls/python.2/tests/test_step9.py | 286 +- impls/python.2/tests/test_stepA.py | 134 +- impls/python/Dockerfile | 56 +- impls/python/Makefile | 44 +- impls/python/core.py | 388 +- impls/python/env.py | 56 +- impls/python/mal_readline.py | 64 +- impls/python/mal_types.py | 294 +- impls/python/printer.py | 68 +- impls/python/reader.py | 220 +- impls/python/run | 4 +- impls/python/step0_repl.py | 58 +- impls/python/step1_read_print.py | 64 +- impls/python/step2_eval.py | 120 +- impls/python/step3_env.py | 142 +- impls/python/step4_if_fn_do.py | 174 +- impls/python/step5_tco.py | 192 +- impls/python/step6_file.py | 206 +- impls/python/step7_quote.py | 266 +- impls/python/step8_macros.py | 310 +- impls/python/step9_try.py | 358 +- impls/python/stepA_mal.py | 368 +- impls/python/tests/step5_tco.mal | 30 +- impls/python/tests/stepA_mal.mal | 46 +- impls/r/Dockerfile | 48 +- impls/r/Makefile | 70 +- impls/r/core.r | 408 +- impls/r/env.r | 84 +- impls/r/printer.r | 114 +- impls/r/reader.r | 282 +- impls/r/readline.r | 88 +- impls/r/run | 4 +- impls/r/step0_repl.r | 54 +- impls/r/step1_read_print.r | 64 +- impls/r/step2_eval.r | 132 +- impls/r/step3_env.r | 162 +- impls/r/step4_if_fn_do.r | 200 +- impls/r/step5_tco.r | 216 +- impls/r/step6_file.r | 240 +- impls/r/step7_quote.r | 324 +- impls/r/step8_macros.r | 380 +- impls/r/step9_try.r | 416 +- impls/r/stepA_mal.r | 420 +- impls/r/tests/step5_tco.mal | 30 +- impls/r/types.r | 370 +- impls/racket/Dockerfile | 50 +- impls/racket/Makefile | 28 +- impls/racket/core.rkt | 244 +- impls/racket/env.rkt | 94 +- impls/racket/printer.rkt | 88 +- impls/racket/reader.rkt | 166 +- impls/racket/readline.rkt | 72 +- impls/racket/run | 4 +- impls/racket/step0_repl.rkt | 54 +- impls/racket/step1_read_print.rkt | 60 +- impls/racket/step2_eval.rkt | 98 +- impls/racket/step3_env.rkt | 122 +- impls/racket/step4_if_fn_do.rkt | 164 +- impls/racket/step5_tco.rkt | 182 +- impls/racket/step6_file.rkt | 194 +- impls/racket/step7_quote.rkt | 252 +- impls/racket/step8_macros.rkt | 300 +- impls/racket/step9_try.rkt | 336 +- impls/racket/stepA_mal.rkt | 346 +- impls/racket/tests/step5_tco.mal | 4 +- impls/racket/types.rkt | 246 +- impls/rexx/.gitignore | 2 +- impls/rexx/Dockerfile | 52 +- impls/rexx/Makefile | 48 +- impls/rexx/core.rexx | 1028 +-- impls/rexx/env.rexx | 118 +- impls/rexx/printer.rexx | 108 +- impls/rexx/reader.rexx | 412 +- impls/rexx/readline.rexx | 16 +- impls/rexx/run | 4 +- impls/rexx/step0_repl.rexx | 46 +- impls/rexx/step1_read_print.rexx | 70 +- impls/rexx/step2_eval.rexx | 254 +- impls/rexx/step3_env.rexx | 302 +- impls/rexx/step4_if_fn_do.rexx | 352 +- impls/rexx/step5_tco.rexx | 366 +- impls/rexx/step6_file.rexx | 428 +- impls/rexx/step7_quote.rexx | 520 +- impls/rexx/step8_macros.rexx | 580 +- impls/rexx/step9_try.rexx | 624 +- impls/rexx/stepA_mal.rexx | 630 +- impls/rexx/tests/step5_tco.mal | 4 +- impls/rexx/tests/stepA_mal.mal | 46 +- impls/rexx/types.rexx | 502 +- impls/rpython/Dockerfile | 94 +- impls/rpython/Makefile | 64 +- impls/rpython/core.py | 890 +-- impls/rpython/env.py | 80 +- impls/rpython/mal_readline.py | 72 +- impls/rpython/mal_types.py | 546 +- impls/rpython/printer.py | 120 +- impls/rpython/reader.py | 276 +- impls/rpython/run | 4 +- impls/rpython/step0_repl.py | 84 +- impls/rpython/step1_read_print.py | 96 +- impls/rpython/step2_eval.py | 222 +- impls/rpython/step3_env.py | 248 +- impls/rpython/step4_if_fn_do.py | 246 +- impls/rpython/step5_tco.py | 264 +- impls/rpython/step6_file.py | 294 +- impls/rpython/step7_quote.py | 360 +- impls/rpython/step8_macros.py | 412 +- impls/rpython/step9_try.py | 448 +- impls/rpython/stepA_mal.py | 476 +- impls/rpython/tests/step5_tco.mal | 30 +- impls/ruby.2/Dockerfile | 48 +- impls/ruby.2/Makefile | 38 +- impls/ruby.2/core.rb | 1070 +-- impls/ruby.2/env.rb | 108 +- impls/ruby.2/errors.rb | 106 +- impls/ruby.2/printer.rb | 110 +- impls/ruby.2/reader.rb | 536 +- impls/ruby.2/run | 4 +- impls/ruby.2/step0_repl.rb | 50 +- impls/ruby.2/step1_read_print.rb | 90 +- impls/ruby.2/step2_eval.rb | 188 +- impls/ruby.2/step3_env.rb | 236 +- impls/ruby.2/step4_if_fn_do.rb | 324 +- impls/ruby.2/step5_tco.rb | 350 +- impls/ruby.2/step6_file.rb | 398 +- impls/ruby.2/step7_quote.rb | 506 +- impls/ruby.2/step8_macros.rb | 590 +- impls/ruby.2/step9_try.rb | 662 +- impls/ruby.2/stepA_mal.rb | 690 +- impls/ruby.2/types.rb | 434 +- impls/ruby/Dockerfile | 48 +- impls/ruby/Makefile | 38 +- impls/ruby/core.rb | 146 +- impls/ruby/env.rb | 74 +- impls/ruby/mal_readline.rb | 44 +- impls/ruby/printer.rb | 58 +- impls/ruby/reader.rb | 172 +- impls/ruby/run | 4 +- impls/ruby/step0_repl.rb | 52 +- impls/ruby/step1_read_print.rb | 68 +- impls/ruby/step2_eval.rb | 136 +- impls/ruby/step3_env.rb | 160 +- impls/ruby/step4_if_fn_do.rb | 196 +- impls/ruby/step5_tco.rb | 216 +- impls/ruby/step6_file.rb | 232 +- impls/ruby/step7_quote.rb | 306 +- impls/ruby/step8_macros.rb | 370 +- impls/ruby/step9_try.rb | 408 +- impls/ruby/stepA_mal.rb | 424 +- impls/ruby/tests/step5_tco.mal | 30 +- impls/ruby/tests/stepA_mal.mal | 54 +- impls/ruby/types.rb | 150 +- impls/rust/.gitignore | 2 +- impls/rust/Cargo.lock | 912 +-- impls/rust/Cargo.toml | 114 +- impls/rust/Dockerfile | 10 +- impls/rust/Makefile | 62 +- impls/rust/core.rs | 702 +- impls/rust/env.rs | 170 +- impls/rust/printer.rs | 122 +- impls/rust/reader.rs | 312 +- impls/rust/run | 4 +- impls/rust/step0_repl.rs | 62 +- impls/rust/step1_read_print.rs | 102 +- impls/rust/step2_eval.rs | 272 +- impls/rust/step3_env.rs | 324 +- impls/rust/step4_if_fn_do.rs | 368 +- impls/rust/step5_tco.rs | 440 +- impls/rust/step6_file.rs | 492 +- impls/rust/step7_quote.rs | 578 +- impls/rust/step8_macros.rs | 726 +- impls/rust/step9_try.rs | 768 +- impls/rust/stepA_mal.rs | 776 +- impls/rust/types.rs | 480 +- impls/scala/Dockerfile | 72 +- impls/scala/Makefile | 46 +- impls/scala/assembly.sbt | 12 +- impls/scala/build.sbt | 12 +- impls/scala/core.scala | 638 +- impls/scala/env.scala | 84 +- impls/scala/printer.scala | 86 +- impls/scala/project/assembly.sbt | 2 +- impls/scala/reader.scala | 194 +- impls/scala/run | 4 +- impls/scala/step0_repl.scala | 66 +- impls/scala/step1_read_print.scala | 78 +- impls/scala/step2_eval.scala | 150 +- impls/scala/step3_env.scala | 184 +- impls/scala/step4_if_fn_do.scala | 226 +- impls/scala/step5_tco.scala | 248 +- impls/scala/step6_file.scala | 266 +- impls/scala/step7_quote.scala | 358 +- impls/scala/step8_macros.scala | 448 +- impls/scala/step9_try.scala | 490 +- impls/scala/stepA_mal.scala | 494 +- impls/scala/tests/step5_tco.mal | 30 +- impls/scala/types.scala | 448 +- impls/scheme/.gitignore | 20 +- impls/scheme/Dockerfile | 118 +- impls/scheme/Makefile | 174 +- impls/scheme/lib/core.sld | 604 +- impls/scheme/lib/env.sld | 98 +- impls/scheme/lib/printer.sld | 124 +- impls/scheme/lib/reader.sld | 366 +- impls/scheme/lib/types.sld | 140 +- impls/scheme/lib/util.sld | 326 +- impls/scheme/run | 52 +- impls/scheme/step0_repl.scm | 66 +- impls/scheme/step1_read_print.scm | 72 +- impls/scheme/step2_eval.scm | 124 +- impls/scheme/step3_env.scm | 166 +- impls/scheme/step4_if_fn_do.scm | 230 +- impls/scheme/step5_tco.scm | 242 +- impls/scheme/step6_file.scm | 262 +- impls/scheme/step7_quote.scm | 318 +- impls/scheme/step8_macros.scm | 396 +- impls/scheme/step9_try.scm | 432 +- impls/scheme/stepA_mal.scm | 438 +- impls/scheme/tests/stepA_mal.mal | 34 +- impls/skew/Dockerfile | 78 +- impls/skew/Makefile | 54 +- impls/skew/core.sk | 206 +- impls/skew/env.sk | 76 +- impls/skew/printer.sk | 6 +- impls/skew/reader.sk | 280 +- impls/skew/run | 4 +- impls/skew/step0_repl.sk | 48 +- impls/skew/step1_read_print.sk | 58 +- impls/skew/step2_eval.sk | 128 +- impls/skew/step3_env.sk | 144 +- impls/skew/step4_if_fn_do.sk | 180 +- impls/skew/step5_tco.sk | 220 +- impls/skew/step6_file.sk | 234 +- impls/skew/step7_quote.sk | 310 +- impls/skew/step8_macros.sk | 374 +- impls/skew/step9_try.sk | 408 +- impls/skew/stepA_mal.sk | 412 +- impls/skew/tests/step5_tco.mal | 30 +- impls/skew/types.sk | 500 +- impls/skew/util.sk | 110 +- impls/sml/.gitignore | 8 +- impls/sml/Dockerfile | 62 +- impls/sml/LargeInt.sml | 12 +- impls/sml/Makefile | 122 +- impls/sml/README.md | 68 +- impls/sml/core.sml | 410 +- impls/sml/env.sml | 22 +- impls/sml/main.sml | 2 +- impls/sml/printer.sml | 44 +- impls/sml/reader.sml | 322 +- impls/sml/run | 4 +- impls/sml/step0_repl.mlb | 12 +- impls/sml/step0_repl.sml | 50 +- impls/sml/step1_read_print.mlb | 20 +- impls/sml/step1_read_print.sml | 54 +- impls/sml/step2_eval.mlb | 22 +- impls/sml/step2_eval.sml | 136 +- impls/sml/step3_env.mlb | 22 +- impls/sml/step3_env.sml | 168 +- impls/sml/step4_if_fn_do.mlb | 24 +- impls/sml/step4_if_fn_do.sml | 164 +- impls/sml/step6_file.mlb | 24 +- impls/sml/step6_file.sml | 200 +- impls/sml/step7_quote.mlb | 24 +- impls/sml/step7_quote.sml | 236 +- impls/sml/step8_macros.mlb | 24 +- impls/sml/step8_macros.sml | 288 +- impls/sml/step9_try.mlb | 24 +- impls/sml/step9_try.sml | 314 +- impls/sml/stepA_mal.mlb | 24 +- impls/sml/stepA_mal.sml | 318 +- impls/sml/types.sml | 96 +- impls/sml/util.sml | 84 +- impls/swift/Makefile | 456 +- impls/swift/bridging-header.h | 30 +- impls/swift/core.swift | 1540 ++-- impls/swift/env.swift | 228 +- impls/swift/main.swift | 36 +- impls/swift/printer.swift | 54 +- impls/swift/reader.swift | 406 +- impls/swift/readline.swift | 92 +- impls/swift/run | 4 +- impls/swift/step0_repl.swift | 128 +- impls/swift/step1_read_print.swift | 150 +- impls/swift/step2_eval.swift | 340 +- impls/swift/step3_env.swift | 468 +- impls/swift/step4_if_fn_do.swift | 574 +- impls/swift/step5_tco.swift | 764 +- impls/swift/step6_file.swift | 840 +-- impls/swift/step7_quote.swift | 1042 +-- impls/swift/step8_macros.swift | 1150 +-- impls/swift/step9_try.swift | 1216 +-- impls/swift/stepA_mal.swift | 1220 +-- impls/swift/templates/add_steps.sh | 46 +- impls/swift/templates/filter_steps.sh | 18 +- impls/swift/templates/step.swift | 1608 ++-- impls/swift/tests/step5_tco.mal | 30 +- impls/swift/types_class.swift | 2202 +++--- impls/swift/types_enum.swift | 2020 ++--- impls/swift3/Dockerfile | 88 +- impls/swift3/Makefile | 58 +- impls/swift3/Sources/core.swift | 934 +-- impls/swift3/Sources/env.swift | 178 +- impls/swift3/Sources/printer.swift | 86 +- impls/swift3/Sources/reader.swift | 414 +- impls/swift3/Sources/step0_repl/main.swift | 20 +- .../Sources/step1_read_print/main.swift | 70 +- impls/swift3/Sources/step2_eval/main.swift | 176 +- impls/swift3/Sources/step3_env/main.swift | 230 +- .../swift3/Sources/step4_if_fn_do/main.swift | 266 +- impls/swift3/Sources/step5_tco/main.swift | 276 +- impls/swift3/Sources/step6_file/main.swift | 306 +- impls/swift3/Sources/step7_quote/main.swift | 408 +- impls/swift3/Sources/step8_macros/main.swift | 510 +- impls/swift3/Sources/step9_try/main.swift | 576 +- impls/swift3/Sources/stepA_mal/main.swift | 578 +- impls/swift3/Sources/types.swift | 424 +- impls/swift3/run | 4 +- impls/swift3/tests/step5_tco.mal | 4 +- impls/swift4/Dockerfile | 88 +- impls/swift4/Makefile | 56 +- impls/swift4/Sources/core.swift | 420 +- impls/swift4/Sources/env.swift | 86 +- impls/swift4/Sources/printer.swift | 102 +- impls/swift4/Sources/reader.swift | 294 +- impls/swift4/Sources/step0_repl/main.swift | 54 +- .../Sources/step1_read_print/main.swift | 66 +- impls/swift4/Sources/step2_eval/main.swift | 160 +- impls/swift4/Sources/step3_env/main.swift | 192 +- .../swift4/Sources/step4_if_fn_do/main.swift | 220 +- impls/swift4/Sources/step5_tco/main.swift | 278 +- impls/swift4/Sources/step6_file/main.swift | 276 +- impls/swift4/Sources/step7_quote/main.swift | 372 +- impls/swift4/Sources/step8_macros/main.swift | 434 +- impls/swift4/Sources/step9_try/main.swift | 470 +- impls/swift4/Sources/stepA_mal/main.swift | 476 +- impls/swift4/Sources/types.swift | 302 +- impls/swift4/run | 4 +- impls/swift5/.gitignore | 14 +- impls/swift5/Dockerfile | 88 +- impls/swift5/Makefile | 18 +- impls/swift5/Package.swift | 84 +- impls/swift5/Sources/core/Core.swift | 1134 +-- impls/swift5/Sources/core/Env.swift | 92 +- impls/swift5/Sources/core/Errors.swift | 114 +- impls/swift5/Sources/core/Parser.swift | 420 +- impls/swift5/Sources/core/Printer.swift | 110 +- impls/swift5/Sources/core/Reader.swift | 292 +- impls/swift5/Sources/core/Types.swift | 248 +- impls/swift5/Sources/core/Utils.swift | 22 +- impls/swift5/Sources/step0_repl/main.swift | 46 +- .../Sources/step1_read_print/main.swift | 62 +- impls/swift5/Sources/step2_eval/main.swift | 150 +- impls/swift5/Sources/step3_env/main.swift | 212 +- .../swift5/Sources/step4_if_fn_do/main.swift | 258 +- impls/swift5/Sources/step5_tco/main.swift | 294 +- impls/swift5/Sources/step6_file/main.swift | 318 +- impls/swift5/Sources/step7_quote/main.swift | 410 +- impls/swift5/Sources/step8_macros/main.swift | 474 +- impls/swift5/Sources/step9_try/main.swift | 512 +- impls/swift5/Sources/stepA_mal/main.swift | 520 +- impls/swift5/run | 4 +- impls/tcl/Dockerfile | 52 +- impls/tcl/Makefile | 38 +- impls/tcl/core.tcl | 950 +-- impls/tcl/env.tcl | 98 +- impls/tcl/mal_readline.tcl | 108 +- impls/tcl/printer.tcl | 112 +- impls/tcl/reader.tcl | 252 +- impls/tcl/run | 4 +- impls/tcl/step0_repl.tcl | 66 +- impls/tcl/step1_read_print.tcl | 76 +- impls/tcl/step2_eval.tcl | 214 +- impls/tcl/step3_env.tcl | 244 +- impls/tcl/step4_if_fn_do.tcl | 316 +- impls/tcl/step5_tco.tcl | 326 +- impls/tcl/step6_file.tcl | 364 +- impls/tcl/step7_quote.tcl | 474 +- impls/tcl/step8_macros.tcl | 570 +- impls/tcl/step9_try.tcl | 616 +- impls/tcl/stepA_mal.tcl | 628 +- impls/tcl/tests/step5_tco.mal | 30 +- impls/tcl/tests/stepA_mal.mal | 56 +- impls/tcl/types.tcl | 402 +- impls/tests/busywork.mal | 62 +- impls/tests/computations.mal | 34 +- impls/tests/docker-build.sh | 12 +- impls/tests/docker-run.sh | 18 +- impls/tests/docker/Dockerfile | 356 +- impls/tests/inc.mal | 8 +- impls/tests/incA.mal | 6 +- impls/tests/incB.mal | 10 +- impls/tests/incC.mal | 4 +- impls/tests/lib/alias-hacks.mal | 110 +- impls/tests/lib/equality.mal | 122 +- impls/tests/lib/load-file-once-inc.mal | 2 +- impls/tests/lib/load-file-once.mal | 88 +- impls/tests/lib/memoize.mal | 36 +- impls/tests/lib/pprint.mal | 78 +- impls/tests/lib/protocols.mal | 162 +- impls/tests/lib/reducers.mal | 66 +- impls/tests/lib/test_cascade.mal | 92 +- impls/tests/lib/threading.mal | 46 +- impls/tests/lib/trivial.mal | 32 +- impls/tests/perf1.mal | 26 +- impls/tests/perf2.mal | 22 +- impls/tests/perf3.mal | 40 +- impls/tests/print_argv.mal | 4 +- impls/tests/run_argv_test.sh | 78 +- ...step0_repl - \345\211\257\346\234\254.mal" | 66 + impls/tests/step0_repl.mal | 132 +- impls/tests/step1_read_print.mal | 572 +- ...step2_eval - \345\211\257\346\234\254.mal" | 49 + impls/tests/step2_eval.mal | 98 +- impls/tests/step3_env.mal | 174 +- impls/tests/step4_if_fn_do.mal | 1000 +-- impls/tests/step5_tco.mal | 46 +- impls/tests/step6_file.mal | 384 +- impls/tests/step7_quote.mal | 698 +- impls/tests/step8_macros.mal | 330 +- impls/tests/step9_try.mal | 806 +- impls/tests/stepA_mal.mal | 600 +- impls/tests/test.txt | 2 +- impls/tests/travis_trigger.sh | 156 +- impls/ts/.gitignore | 10 +- impls/ts/Dockerfile | 68 +- impls/ts/Makefile | 38 +- impls/ts/core.ts | 882 +-- impls/ts/env.ts | 96 +- impls/ts/node_readline.ts | 90 +- impls/ts/package.json | 60 +- impls/ts/printer.ts | 84 +- impls/ts/reader.ts | 292 +- impls/ts/run | 4 +- impls/ts/step0_repl.ts | 70 +- impls/ts/step1_read_print.ts | 82 +- impls/ts/step2_eval.ts | 176 +- impls/ts/step3_env.ts | 244 +- impls/ts/step4_if_fn_do.ts | 338 +- impls/ts/step5_tco.ts | 350 +- impls/ts/step6_file.ts | 380 +- impls/ts/step7_quote.ts | 490 +- impls/ts/step8_macros.ts | 624 +- impls/ts/step9_try.ts | 674 +- impls/ts/stepA_mal.ts | 678 +- impls/ts/tsconfig.json | 42 +- impls/ts/types.ts | 820 +- impls/vala/.gitignore | 6 +- impls/vala/Dockerfile | 48 +- impls/vala/Makefile | 104 +- impls/vala/README.md | 120 +- impls/vala/core.vala | 2406 +++--- impls/vala/env.vala | 152 +- impls/vala/gc.vala | 392 +- impls/vala/printer.vala | 116 +- impls/vala/reader.vala | 366 +- impls/vala/run | 4 +- impls/vala/step0_repl.vala | 72 +- impls/vala/step1_read_print.vala | 98 +- impls/vala/step2_eval.vala | 340 +- impls/vala/step3_env.vala | 436 +- impls/vala/step4_if_fn_do.vala | 442 +- impls/vala/step5_tco.vala | 466 +- impls/vala/step6_file.vala | 542 +- impls/vala/step7_quote.vala | 704 +- impls/vala/step8_macros.vala | 782 +- impls/vala/step9_try.vala | 874 +-- impls/vala/stepA_mal.vala | 878 +-- impls/vala/types.vala | 576 +- impls/vb/Dockerfile | 50 +- impls/vb/Makefile | 78 +- impls/vb/core.vb | 1086 +-- impls/vb/env.vb | 110 +- impls/vb/getline.cs | 2178 +++--- impls/vb/printer.vb | 104 +- impls/vb/reader.vb | 374 +- impls/vb/readline.vb | 64 +- impls/vb/run | 4 +- impls/vb/step0_repl.vb | 96 +- impls/vb/step1_read_print.vb | 118 +- impls/vb/step2_eval.vb | 268 +- impls/vb/step3_env.vb | 310 +- impls/vb/step4_if_fn_do.vb | 376 +- impls/vb/step5_tco.vb | 394 +- impls/vb/step6_file.vb | 430 +- impls/vb/step7_quote.vb | 526 +- impls/vb/step8_macros.vb | 604 +- impls/vb/step9_try.vb | 658 +- impls/vb/stepA_mal.vb | 662 +- impls/vb/tests/step5_tco.mal | 4 +- impls/vb/types.vb | 946 +-- impls/vbs/core.vbs | 1732 ++--- impls/vbs/env.vbs | 124 +- impls/vbs/install.vbs | 2 +- impls/vbs/printer.vbs | 186 +- impls/vbs/reader.vbs | 574 +- impls/vbs/step0_repl.vbs | 56 +- impls/vbs/step1_read_print.vbs | 112 +- impls/vbs/step2_eval.vbs | 390 +- impls/vbs/step3_env.vbs | 412 +- impls/vbs/step4_if_fn_do.vbs | 440 +- impls/vbs/step5_tco.vbs | 482 +- impls/vbs/step6_file.vbs | 538 +- impls/vbs/step7_quote.vbs | 786 +- impls/vbs/step8_macros.vbs | 900 +-- impls/vbs/step9_try.vbs | 1034 +-- impls/vbs/stepA_mal.vbs | 1038 +-- impls/vbs/tests/step4_if_fn_do.mal | 10 +- impls/vbs/tests/step9_try.mal | 8 +- impls/vbs/types.vbs | 1222 +-- impls/vhdl/.gitignore | 2 +- impls/vhdl/Dockerfile | 60 +- impls/vhdl/Makefile | 70 +- impls/vhdl/core.vhdl | 1372 ++-- impls/vhdl/env.vhdl | 144 +- impls/vhdl/pkg_readline.vhdl | 72 +- impls/vhdl/printer.vhdl | 194 +- impls/vhdl/reader.vhdl | 732 +- impls/vhdl/run | 4 +- impls/vhdl/run_vhdl.sh | 42 +- impls/vhdl/step0_repl.vhdl | 90 +- impls/vhdl/step1_read_print.vhdl | 140 +- impls/vhdl/step2_eval.vhdl | 334 +- impls/vhdl/step3_env.vhdl | 400 +- impls/vhdl/step4_if_fn_do.vhdl | 454 +- impls/vhdl/step5_tco.vhdl | 476 +- impls/vhdl/step6_file.vhdl | 664 +- impls/vhdl/step7_quote.vhdl | 832 +- impls/vhdl/step8_macros.vhdl | 952 +-- impls/vhdl/step9_try.vhdl | 1068 +-- impls/vhdl/stepA_mal.vhdl | 1072 +-- impls/vhdl/types.vhdl | 756 +- impls/vimscript/.gitignore | 4 +- impls/vimscript/Dockerfile | 68 +- impls/vimscript/Makefile | 60 +- impls/vimscript/core.vim | 470 +- impls/vimscript/env.vim | 122 +- impls/vimscript/printer.vim | 120 +- impls/vimscript/reader.vim | 330 +- impls/vimscript/readline.vim | 46 +- impls/vimscript/run | 6 +- impls/vimscript/run_vimscript.sh | 34 +- impls/vimscript/step0_repl.vim | 58 +- impls/vimscript/step1_read_print.vim | 72 +- impls/vimscript/step2_eval.vim | 152 +- impls/vimscript/step3_env.vim | 184 +- impls/vimscript/step4_if_fn_do.vim | 240 +- impls/vimscript/step5_tco.vim | 266 +- impls/vimscript/step6_file.vim | 306 +- impls/vimscript/step7_quote.vim | 390 +- impls/vimscript/step8_macros.vim | 464 +- impls/vimscript/step9_try.vim | 544 +- impls/vimscript/stepA_mal.vim | 550 +- impls/vimscript/tests/step5_tco.mal | 30 +- impls/vimscript/tests/stepA_mal.mal | 82 +- impls/vimscript/types.vim | 558 +- impls/vimscript/vimextras.c | 88 +- impls/wasm/Dockerfile | 396 +- impls/wasm/Makefile | 94 +- impls/wasm/core.wam | 1462 ++-- impls/wasm/debug.wam | 570 +- impls/wasm/env.wam | 208 +- impls/wasm/mem.wam | 930 +-- impls/wasm/node_readline.js | 92 +- impls/wasm/package.json | 20 +- impls/wasm/platform_direct.wam | 112 +- impls/wasm/platform_libc.wam | 222 +- impls/wasm/platform_wasi.wam | 386 +- impls/wasm/printer.wam | 364 +- impls/wasm/printf.wam | 452 +- impls/wasm/reader.wam | 646 +- impls/wasm/run | 40 +- impls/wasm/run.js | 312 +- impls/wasm/step0_repl.wam | 98 +- impls/wasm/step1_read_print.wam | 162 +- impls/wasm/step2_eval.wam | 466 +- impls/wasm/step3_env.wam | 562 +- impls/wasm/step4_if_fn_do.wam | 650 +- impls/wasm/step5_tco.wam | 748 +- impls/wasm/step6_file.wam | 860 +-- impls/wasm/step7_quote.wam | 1052 +-- impls/wasm/step8_macros.wam | 1220 +-- impls/wasm/step9_try.wam | 1314 ++-- impls/wasm/stepA_mal.wam | 1318 ++-- impls/wasm/string.wam | 430 +- impls/wasm/types.wam | 834 +- impls/wren/Dockerfile | 66 +- impls/wren/Makefile | 38 +- impls/wren/README.md | 30 +- impls/wren/core.wren | 212 +- impls/wren/env.wren | 80 +- impls/wren/interop.wren | 46 +- impls/wren/printer.wren | 60 +- impls/wren/reader.wren | 340 +- impls/wren/readline.wren | 28 +- impls/wren/run | 4 +- impls/wren/step0_repl.wren | 60 +- impls/wren/step1_read_print.wren | 72 +- impls/wren/step2_eval.wren | 132 +- impls/wren/step3_env.wren | 156 +- impls/wren/step4_if_fn_do.wren | 180 +- impls/wren/step5_tco.wren | 224 +- impls/wren/step6_file.wren | 244 +- impls/wren/step7_quote.wren | 326 +- impls/wren/step8_macros.wren | 374 +- impls/wren/step9_try.wren | 416 +- impls/wren/stepA_mal.wren | 420 +- impls/wren/tests/step5_tco.mal | 4 +- impls/wren/tests/stepA_mal.mal | 68 +- impls/wren/types.wren | 260 +- impls/wren/wren-add-gettimeofday.patch | 68 +- impls/xslt/Dockerfile | 66 +- impls/xslt/Makefile | 14 +- impls/xslt/core.xslt | 1604 ++-- impls/xslt/env.xslt | 438 +- impls/xslt/harness.py | 306 +- impls/xslt/printer.xslt | 394 +- impls/xslt/reader.xslt | 1034 +-- impls/xslt/readline.xslt | 24 +- impls/xslt/run | 4 +- impls/xslt/step0_repl.inc.xslt | 94 +- impls/xslt/step0_repl.xslt | 90 +- impls/xslt/step1_read_print.inc.xslt | 148 +- impls/xslt/step1_read_print.xslt | 90 +- impls/xslt/step2_eval.inc.xslt | 514 +- impls/xslt/step2_eval.xslt | 90 +- impls/xslt/step3_env.inc.xslt | 754 +- impls/xslt/step3_env.xslt | 90 +- impls/xslt/step4_if_fn_do.inc.xslt | 1046 +-- impls/xslt/step4_if_fn_do.xslt | 90 +- impls/xslt/step6_file.inc.xslt | 1296 ++-- impls/xslt/step6_file.xslt | 90 +- impls/xslt/step7_quote.inc.xslt | 1612 ++-- impls/xslt/step7_quote.xslt | 90 +- impls/xslt/step8_macros.inc.xslt | 1864 ++--- impls/xslt/step8_macros.xslt | 90 +- impls/xslt/step9_try.inc.xslt | 2204 +++--- impls/xslt/step9_try.xslt | 90 +- impls/xslt/stepA_mal.inc.xslt | 2248 +++--- impls/xslt/stepA_mal.xslt | 90 +- impls/xslt/test.xslt | 12 +- impls/yorick/Dockerfile | 52 +- impls/yorick/Makefile | 34 +- impls/yorick/core.i | 768 +- impls/yorick/env.i | 88 +- impls/yorick/hash.i | 158 +- impls/yorick/printer.i | 100 +- impls/yorick/reader.i | 318 +- impls/yorick/run | 6 +- impls/yorick/step0_repl.i | 66 +- impls/yorick/step1_read_print.i | 86 +- impls/yorick/step2_eval.i | 192 +- impls/yorick/step3_env.i | 226 +- impls/yorick/step4_if_fn_do.i | 306 +- impls/yorick/step5_tco.i | 320 +- impls/yorick/step6_file.i | 376 +- impls/yorick/step7_quote.i | 464 +- impls/yorick/step8_macros.i | 534 +- impls/yorick/step9_try.i | 576 +- impls/yorick/stepA_mal.i | 580 +- impls/yorick/tests/stepA_mal.mal | 66 +- impls/yorick/types.i | 332 +- impls/zig/Dockerfile | 66 +- impls/zig/Makefile | 32 +- impls/zig/build.zig | 70 +- impls/zig/core.zig | 1708 ++--- impls/zig/env.zig | 320 +- impls/zig/error.zig | 40 +- impls/zig/hmap.zig | 116 +- impls/zig/linked_list.zig | 116 +- impls/zig/logging_alloc.zig | 70 +- impls/zig/printer.zig | 462 +- impls/zig/reader.zig | 682 +- impls/zig/readline.zig | 100 +- impls/zig/run | 4 +- impls/zig/step0_repl.zig | 72 +- impls/zig/step1_read_print.zig | 92 +- impls/zig/step2_eval.zig | 392 +- impls/zig/step3_env.zig | 508 +- impls/zig/step4_if_fn_do.zig | 574 +- impls/zig/step5_tco.zig | 604 +- impls/zig/step6_file.zig | 742 +- impls/zig/step7_quote.zig | 912 +-- impls/zig/step8_macros.zig | 1070 +-- impls/zig/step9_try.zig | 1224 +-- impls/zig/stepA_mal.zig | 1256 ++-- impls/zig/types.zig | 942 +-- impls/zig/utils.zig | 96 +- process/guide.md | 3496 ++++----- process/step0_repl.txt | 22 +- process/step1_read_print.txt | 28 +- process/step2_eval.txt | 52 +- process/step3_env.txt | 78 +- process/step4_if_fn_do.txt | 142 +- process/step5_tco.txt | 146 +- process/step6_file.txt | 172 +- process/step7_quote.txt | 186 +- process/step8_macros.txt | 212 +- process/step9_try.txt | 258 +- process/stepA_mal.txt | 284 +- runtest.cmd | 22 + runtest.log | 1212 +++ runtest.py | 215 +- test-nt.log | Bin 0 -> 118266 bytes test-posix.log | 1224 +++ ...7\346\234\254\346\226\207\346\241\243.txt" | 21 + 2433 files changed, 365388 insertions(+), 361795 deletions(-) create mode 100644 impls/batch/LinearList_LSS_SLL.bat create mode 100644 impls/batch/Queue_LSS.bat create mode 100644 impls/batch/Stack_LSS.bat create mode 100644 impls/batch/reader.bat create mode 100644 impls/batch/step0_repl.bat create mode 100644 impls/batch/step1_read_print.bat create mode 100644 "impls/powershell/step2_eval - \345\211\257\346\234\254.ps1" create mode 100644 "impls/tests/step0_repl - \345\211\257\346\234\254.mal" create mode 100644 "impls/tests/step2_eval - \345\211\257\346\234\254.mal" create mode 100644 runtest.cmd create mode 100644 runtest.log create mode 100644 test-nt.log create mode 100644 test-posix.log create mode 100644 "\346\226\260\345\273\272\346\226\207\346\234\254\346\226\207\346\241\243.txt" diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 1bd6ad7bf4..2886920b3b 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -1,96 +1,96 @@ -name: Build and Test - -on: - push: {} - pull_request: {} - workflow_dispatch: - inputs: - impls: - description: 'Space separated list of impls to test (or all)' - required: true - default: 'all' - -jobs: - get-matrix: - runs-on: ubuntu-20.04 - outputs: - do-linux: ${{ steps.get-matrix-step.outputs.do-linux }} - matrix-linux: ${{ steps.get-matrix-step.outputs.linux }} - do-macos: ${{ steps.get-matrix-step.outputs.do-macos }} - matrix-macos: ${{ steps.get-matrix-step.outputs.macos }} - steps: - - uses: actions/checkout@v2 - - id: files - if: ${{ github.event_name != 'workflow_dispatch' }} - uses: kanaka/get-changed-files@v1 - - id: get-matrix-step - run: | - export OVERRIDE_IMPLS="${{ github.event.inputs.impls }}" # " - echo "OVERRIDE_IMPLS: ${OVERRIDE_IMPLS}" - ./get-ci-matrix.py ${{ steps.files.outputs.all }} - - linux: - needs: get-matrix - if: ${{ needs.get-matrix.outputs.do-linux == 'true' }} - runs-on: ubuntu-20.04 - strategy: - fail-fast: false - matrix: ${{ fromJson(needs.get-matrix.outputs.matrix-linux) }} - steps: - - uses: actions/checkout@v2 - - name: Build - run: | - export ${{ matrix.IMPL }} - ./ci.sh build ${IMPL} - - name: Step Tests - run: | - export ${{ matrix.IMPL }} - ./ci.sh test ${IMPL} - - name: Regression Tests - run: | - export ${{ matrix.IMPL }} - STEP=stepA REGRESS=1 HARD=1 OPTIONAL=0 ./ci.sh test ${IMPL} - - name: Performance Tests - run: | - export ${{ matrix.IMPL }} - ./ci.sh perf ${IMPL} - - name: Archive logs and debug output - uses: actions/upload-artifact@v2 - with: - name: logs - path: | - *.log - *.debug - - macos: - needs: get-matrix - if: ${{ needs.get-matrix.outputs.do-macos == 'true' }} - runs-on: macos-10.15 - strategy: - fail-fast: false - matrix: ${{ fromJson(needs.get-matrix.outputs.matrix-macos) }} - steps: - - uses: actions/checkout@v2 - - name: Build - run: | - export ${{ matrix.IMPL }} - ./ci.sh build ${IMPL} - - name: Step Tests - run: | - export ${{ matrix.IMPL }} - ./ci.sh test ${IMPL} - - name: Regression Tests - run: | - export ${{ matrix.IMPL }} - STEP=stepA REGRESS=1 HARD=1 OPTIONAL=0 ./ci.sh test ${IMPL} - - name: Performance Tests - run: | - export ${{ matrix.IMPL }} - ./ci.sh perf ${IMPL} - - name: Archive logs and debug output - uses: actions/upload-artifact@v2 - with: - name: logs - path: | - *.log - *.debug +name: Build and Test + +on: + push: {} + pull_request: {} + workflow_dispatch: + inputs: + impls: + description: 'Space separated list of impls to test (or all)' + required: true + default: 'all' + +jobs: + get-matrix: + runs-on: ubuntu-20.04 + outputs: + do-linux: ${{ steps.get-matrix-step.outputs.do-linux }} + matrix-linux: ${{ steps.get-matrix-step.outputs.linux }} + do-macos: ${{ steps.get-matrix-step.outputs.do-macos }} + matrix-macos: ${{ steps.get-matrix-step.outputs.macos }} + steps: + - uses: actions/checkout@v2 + - id: files + if: ${{ github.event_name != 'workflow_dispatch' }} + uses: kanaka/get-changed-files@v1 + - id: get-matrix-step + run: | + export OVERRIDE_IMPLS="${{ github.event.inputs.impls }}" # " + echo "OVERRIDE_IMPLS: ${OVERRIDE_IMPLS}" + ./get-ci-matrix.py ${{ steps.files.outputs.all }} + + linux: + needs: get-matrix + if: ${{ needs.get-matrix.outputs.do-linux == 'true' }} + runs-on: ubuntu-20.04 + strategy: + fail-fast: false + matrix: ${{ fromJson(needs.get-matrix.outputs.matrix-linux) }} + steps: + - uses: actions/checkout@v2 + - name: Build + run: | + export ${{ matrix.IMPL }} + ./ci.sh build ${IMPL} + - name: Step Tests + run: | + export ${{ matrix.IMPL }} + ./ci.sh test ${IMPL} + - name: Regression Tests + run: | + export ${{ matrix.IMPL }} + STEP=stepA REGRESS=1 HARD=1 OPTIONAL=0 ./ci.sh test ${IMPL} + - name: Performance Tests + run: | + export ${{ matrix.IMPL }} + ./ci.sh perf ${IMPL} + - name: Archive logs and debug output + uses: actions/upload-artifact@v2 + with: + name: logs + path: | + *.log + *.debug + + macos: + needs: get-matrix + if: ${{ needs.get-matrix.outputs.do-macos == 'true' }} + runs-on: macos-10.15 + strategy: + fail-fast: false + matrix: ${{ fromJson(needs.get-matrix.outputs.matrix-macos) }} + steps: + - uses: actions/checkout@v2 + - name: Build + run: | + export ${{ matrix.IMPL }} + ./ci.sh build ${IMPL} + - name: Step Tests + run: | + export ${{ matrix.IMPL }} + ./ci.sh test ${IMPL} + - name: Regression Tests + run: | + export ${{ matrix.IMPL }} + STEP=stepA REGRESS=1 HARD=1 OPTIONAL=0 ./ci.sh test ${IMPL} + - name: Performance Tests + run: | + export ${{ matrix.IMPL }} + ./ci.sh perf ${IMPL} + - name: Archive logs and debug output + uses: actions/upload-artifact@v2 + with: + name: logs + path: | + *.log + *.debug diff --git a/.gitignore b/.gitignore index 80c2c84ac5..4ccd030b8c 100644 --- a/.gitignore +++ b/.gitignore @@ -1,24 +1,24 @@ -.DS_Store -.bash_history -.cache -.cargo -.config -.mal-history -.mal_history -.crystal -.lein -.m2 -.ivy2 -.sbt -.npm -.node-gyp -package-lock.json -*/experiments -node_modules -*/notes -GPATH -GTAGS -GRTAGS -logs -old -tmp/ +.DS_Store +.bash_history +.cache +.cargo +.config +.mal-history +.mal_history +.crystal +.lein +.m2 +.ivy2 +.sbt +.npm +.node-gyp +package-lock.json +*/experiments +node_modules +*/notes +GPATH +GTAGS +GRTAGS +logs +old +tmp/ diff --git a/.travis.yml b/.travis.yml index 0e27995da0..a432c5d6f2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,19 +1,19 @@ -sudo: required - -# matrix layout based on: -# https://github.com/libressl-portable/portable/blob/9e090286b55def5ca2c0cc375c65023a70d8796e/.travis.yml - -matrix: - include: - - {env: IMPL=objc NO_DOCKER=1, os: osx, osx_image: xcode7} - - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7.3} - - {env: IMPL=swift3 NO_DOCKER=1, os: osx, osx_image: xcode8} - - {env: IMPL=swift4 NO_DOCKER=1, os: osx, osx_image: xcode10} - - {env: IMPL=swift5 NO_DOCKER=1, os: osx, osx_image: xcode11} - -script: - # Build, test, perf - - ./ci.sh build ${IMPL} - - ./ci.sh test ${IMPL} - - STEP=stepA REGRESS=1 HARD=1 OPTIONAL=0 ./ci.sh test ${IMPL} - - ./ci.sh perf ${IMPL} +sudo: required + +# matrix layout based on: +# https://github.com/libressl-portable/portable/blob/9e090286b55def5ca2c0cc375c65023a70d8796e/.travis.yml + +matrix: + include: + - {env: IMPL=objc NO_DOCKER=1, os: osx, osx_image: xcode7} + - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7.3} + - {env: IMPL=swift3 NO_DOCKER=1, os: osx, osx_image: xcode8} + - {env: IMPL=swift4 NO_DOCKER=1, os: osx, osx_image: xcode10} + - {env: IMPL=swift5 NO_DOCKER=1, os: osx, osx_image: xcode11} + +script: + # Build, test, perf + - ./ci.sh build ${IMPL} + - ./ci.sh test ${IMPL} + - STEP=stepA REGRESS=1 HARD=1 OPTIONAL=0 ./ci.sh test ${IMPL} + - ./ci.sh perf ${IMPL} diff --git a/IMPLS.yml b/IMPLS.yml index f89b099b56..dcc3be9d4a 100644 --- a/IMPLS.yml +++ b/IMPLS.yml @@ -1,123 +1,123 @@ -IMPL: - - {IMPL: ada} - - {IMPL: ada.2} - - {IMPL: awk} - - {IMPL: bash, NO_SELF_HOST: 1} # step8 timeout - - {IMPL: basic, basic_MODE: cbm, NO_SELF_HOST: 1} # step4 OOM - - {IMPL: basic, basic_MODE: qbasic, NO_SELF_HOST: 1} # step4 OOM - - {IMPL: bbc-basic} - - {IMPL: c} - - {IMPL: c.2} - - {IMPL: cpp} - - {IMPL: coffee} - - {IMPL: cs} - - {IMPL: chuck, NO_SELF_HOST_PERF: 1} # perf OOM - - {IMPL: clojure, clojure_MODE: clj} - - {IMPL: clojure, clojure_MODE: cljs} - - {IMPL: common-lisp} - - {IMPL: crystal} - - {IMPL: d, d_MODE: gdc} - - {IMPL: d, d_MODE: ldc2} - - {IMPL: d, d_MODE: dmd} - - {IMPL: dart} - - {IMPL: elisp} - - {IMPL: elixir} - - {IMPL: elm} - - {IMPL: erlang, NO_SELF_HOST: 1} # step8 OOM - - {IMPL: es6} - - {IMPL: factor} - - {IMPL: fantom} - - {IMPL: fennel} - - {IMPL: forth} - - {IMPL: fsharp} - - {IMPL: go} - - {IMPL: groovy} - - {IMPL: gnu-smalltalk} - - {IMPL: guile} - - {IMPL: haskell} - - {IMPL: haxe, haxe_MODE: neko} - - {IMPL: haxe, haxe_MODE: python} - - {IMPL: haxe, haxe_MODE: cpp, SLOW: 1} - - {IMPL: haxe, haxe_MODE: js} - - {IMPL: hy} - - {IMPL: io, NO_SELF_HOST_PERF: 1} # perf OOM - - {IMPL: janet} - - {IMPL: java} - - {IMPL: java-truffle} - - {IMPL: jq} - - {IMPL: js} - - {IMPL: julia} - - {IMPL: kotlin} - - {IMPL: livescript} - - {IMPL: logo, NO_SELF_HOST: 1} # step4 timeout - - {IMPL: lua} - - {IMPL: make, NO_SELF_HOST: 1} # step4 timeout - - {IMPL: mal, MAL_IMPL: js, BUILD_IMPL: js, NO_SELF_HOST: 1} - - {IMPL: mal, MAL_IMPL: js-mal, BUILD_IMPL: js, NO_SELF_HOST: 1, NO_PERF: 1, SLOW: 1} - - {IMPL: mal, MAL_IMPL: nim, BUILD_IMPL: nim, NO_SELF_HOST: 1} - - {IMPL: mal, MAL_IMPL: nim-mal, BUILD_IMPL: nim, NO_SELF_HOST: 1, NO_PERF: 1, SLOW: 1} - - {IMPL: matlab, NO_SELF_HOST_PERF: 1} # Octave, perf timeout - - {IMPL: miniMAL, NO_SELF_HOST_PERF: 1, SLOW: 1} # perf timeout - - {IMPL: nasm, NO_SELF_HOST_PERF: 1} # perf OOM - - {IMPL: nim} - - {IMPL: objpascal} - - {IMPL: objc} - - {IMPL: ocaml} - - {IMPL: perl} - - {IMPL: perl6} - - {IMPL: php} - - {IMPL: picolisp} - - {IMPL: pike} - - {IMPL: plpgsql, NO_SELF_HOST: 1, SLOW: 1} # step3 timeout -# - {IMPL: plsql} - - {IMPL: prolog} - - {IMPL: ps} - - {IMPL: powershell, NO_SELF_HOST_PERF: 1} - - {IMPL: purs} - - {IMPL: python, python_MODE: python2} - - {IMPL: python, python_MODE: python3} - - {IMPL: python.2} - - {IMPL: r} - - {IMPL: racket} - - {IMPL: rexx} - - {IMPL: rpython, SLOW: 1} - - {IMPL: ruby} - - {IMPL: ruby.2} - - {IMPL: rust} - - {IMPL: scala} - - {IMPL: scheme, scheme_MODE: chibi} - - {IMPL: scheme, scheme_MODE: kawa} - - {IMPL: scheme, scheme_MODE: gauche} - - {IMPL: scheme, scheme_MODE: chicken} - - {IMPL: scheme, scheme_MODE: sagittarius} - - {IMPL: scheme, scheme_MODE: cyclone} -# - {IMPL: scheme, scheme_MODE: foment} - - {IMPL: skew} - - {IMPL: sml, sml_MODE: polyml} - - {IMPL: sml, sml_MODE: mlton} - - {IMPL: sml, sml_MODE: mosml} - - {IMPL: tcl} - - {IMPL: ts} - - {IMPL: vala} - - {IMPL: vb} - - {IMPL: vhdl, NO_SELF_HOST_PERF: 1} # perf timeout - - {IMPL: vimscript} - # no self-host perf for wasm due to mac stack overflow - - {IMPL: wasm, wasm_MODE: wasmtime, NO_SELF_HOST_PERF: 1, NO_PERF: 1} - - {IMPL: wasm, wasm_MODE: wasmer, NO_SELF_HOST_PERF: 1, NO_PERF: 1} - - {IMPL: wasm, wasm_MODE: lucet, NO_SELF_HOST_PERF: 1, NO_PERF: 1} - #- {IMPL: wasm, wasm_MODE: wax, NO_SELF_HOST_PERF: 1} # Hangs on GH Actions - - {IMPL: wasm, wasm_MODE: node, NO_SELF_HOST_PERF: 1, NO_PERF: 1} - #- {IMPL: wasm, wasm_MODE: warpy, NO_SELF_HOST_PERF: 1} # Hangs on GH Actions - #- {IMPL: wasm, wasm_MODE: wace_libc, NO_SELF_HOST_PERF: 1} # Hangs on GH Actions - - {IMPL: wren} - - {IMPL: xslt} - - {IMPL: yorick} - - {IMPL: zig} - - # See .travis.yml (for older osx / xcode tests) -# - {IMPL: objc, NO_DOCKER: 1, OS: xcode7}} -# - {IMPL: swift, NO_DOCKER: 1, OS: xcode7.3}} -# - {IMPL: swift3, NO_DOCKER: 1, OS: xcode8}} -# - {IMPL: swift4, NO_DOCKER: 1, OS: xcode10}} - - {IMPL: swift5, NO_DOCKER: 1, OS: macos} +IMPL: + - {IMPL: ada} + - {IMPL: ada.2} + - {IMPL: awk} + - {IMPL: bash, NO_SELF_HOST: 1} # step8 timeout + - {IMPL: basic, basic_MODE: cbm, NO_SELF_HOST: 1} # step4 OOM + - {IMPL: basic, basic_MODE: qbasic, NO_SELF_HOST: 1} # step4 OOM + - {IMPL: bbc-basic} + - {IMPL: c} + - {IMPL: c.2} + - {IMPL: cpp} + - {IMPL: coffee} + - {IMPL: cs} + - {IMPL: chuck, NO_SELF_HOST_PERF: 1} # perf OOM + - {IMPL: clojure, clojure_MODE: clj} + - {IMPL: clojure, clojure_MODE: cljs} + - {IMPL: common-lisp} + - {IMPL: crystal} + - {IMPL: d, d_MODE: gdc} + - {IMPL: d, d_MODE: ldc2} + - {IMPL: d, d_MODE: dmd} + - {IMPL: dart} + - {IMPL: elisp} + - {IMPL: elixir} + - {IMPL: elm} + - {IMPL: erlang, NO_SELF_HOST: 1} # step8 OOM + - {IMPL: es6} + - {IMPL: factor} + - {IMPL: fantom} + - {IMPL: fennel} + - {IMPL: forth} + - {IMPL: fsharp} + - {IMPL: go} + - {IMPL: groovy} + - {IMPL: gnu-smalltalk} + - {IMPL: guile} + - {IMPL: haskell} + - {IMPL: haxe, haxe_MODE: neko} + - {IMPL: haxe, haxe_MODE: python} + - {IMPL: haxe, haxe_MODE: cpp, SLOW: 1} + - {IMPL: haxe, haxe_MODE: js} + - {IMPL: hy} + - {IMPL: io, NO_SELF_HOST_PERF: 1} # perf OOM + - {IMPL: janet} + - {IMPL: java} + - {IMPL: java-truffle} + - {IMPL: jq} + - {IMPL: js} + - {IMPL: julia} + - {IMPL: kotlin} + - {IMPL: livescript} + - {IMPL: logo, NO_SELF_HOST: 1} # step4 timeout + - {IMPL: lua} + - {IMPL: make, NO_SELF_HOST: 1} # step4 timeout + - {IMPL: mal, MAL_IMPL: js, BUILD_IMPL: js, NO_SELF_HOST: 1} + - {IMPL: mal, MAL_IMPL: js-mal, BUILD_IMPL: js, NO_SELF_HOST: 1, NO_PERF: 1, SLOW: 1} + - {IMPL: mal, MAL_IMPL: nim, BUILD_IMPL: nim, NO_SELF_HOST: 1} + - {IMPL: mal, MAL_IMPL: nim-mal, BUILD_IMPL: nim, NO_SELF_HOST: 1, NO_PERF: 1, SLOW: 1} + - {IMPL: matlab, NO_SELF_HOST_PERF: 1} # Octave, perf timeout + - {IMPL: miniMAL, NO_SELF_HOST_PERF: 1, SLOW: 1} # perf timeout + - {IMPL: nasm, NO_SELF_HOST_PERF: 1} # perf OOM + - {IMPL: nim} + - {IMPL: objpascal} + - {IMPL: objc} + - {IMPL: ocaml} + - {IMPL: perl} + - {IMPL: perl6} + - {IMPL: php} + - {IMPL: picolisp} + - {IMPL: pike} + - {IMPL: plpgsql, NO_SELF_HOST: 1, SLOW: 1} # step3 timeout +# - {IMPL: plsql} + - {IMPL: prolog} + - {IMPL: ps} + - {IMPL: powershell, NO_SELF_HOST_PERF: 1} + - {IMPL: purs} + - {IMPL: python, python_MODE: python2} + - {IMPL: python, python_MODE: python3} + - {IMPL: python.2} + - {IMPL: r} + - {IMPL: racket} + - {IMPL: rexx} + - {IMPL: rpython, SLOW: 1} + - {IMPL: ruby} + - {IMPL: ruby.2} + - {IMPL: rust} + - {IMPL: scala} + - {IMPL: scheme, scheme_MODE: chibi} + - {IMPL: scheme, scheme_MODE: kawa} + - {IMPL: scheme, scheme_MODE: gauche} + - {IMPL: scheme, scheme_MODE: chicken} + - {IMPL: scheme, scheme_MODE: sagittarius} + - {IMPL: scheme, scheme_MODE: cyclone} +# - {IMPL: scheme, scheme_MODE: foment} + - {IMPL: skew} + - {IMPL: sml, sml_MODE: polyml} + - {IMPL: sml, sml_MODE: mlton} + - {IMPL: sml, sml_MODE: mosml} + - {IMPL: tcl} + - {IMPL: ts} + - {IMPL: vala} + - {IMPL: vb} + - {IMPL: vhdl, NO_SELF_HOST_PERF: 1} # perf timeout + - {IMPL: vimscript} + # no self-host perf for wasm due to mac stack overflow + - {IMPL: wasm, wasm_MODE: wasmtime, NO_SELF_HOST_PERF: 1, NO_PERF: 1} + - {IMPL: wasm, wasm_MODE: wasmer, NO_SELF_HOST_PERF: 1, NO_PERF: 1} + - {IMPL: wasm, wasm_MODE: lucet, NO_SELF_HOST_PERF: 1, NO_PERF: 1} + #- {IMPL: wasm, wasm_MODE: wax, NO_SELF_HOST_PERF: 1} # Hangs on GH Actions + - {IMPL: wasm, wasm_MODE: node, NO_SELF_HOST_PERF: 1, NO_PERF: 1} + #- {IMPL: wasm, wasm_MODE: warpy, NO_SELF_HOST_PERF: 1} # Hangs on GH Actions + #- {IMPL: wasm, wasm_MODE: wace_libc, NO_SELF_HOST_PERF: 1} # Hangs on GH Actions + - {IMPL: wren} + - {IMPL: xslt} + - {IMPL: yorick} + - {IMPL: zig} + + # See .travis.yml (for older osx / xcode tests) +# - {IMPL: objc, NO_DOCKER: 1, OS: xcode7}} +# - {IMPL: swift, NO_DOCKER: 1, OS: xcode7.3}} +# - {IMPL: swift3, NO_DOCKER: 1, OS: xcode8}} +# - {IMPL: swift4, NO_DOCKER: 1, OS: xcode10}} + - {IMPL: swift5, NO_DOCKER: 1, OS: macos} diff --git a/LICENSE b/LICENSE index 88b2867725..42fa5d3592 100644 --- a/LICENSE +++ b/LICENSE @@ -1,387 +1,387 @@ -Copyright (C) 2015 Joel Martin - -Mal (make-a-lisp) is licensed under the MPL 2.0 (Mozilla Public -License 2.0). The text of the MPL 2.0 license is included below and -can be found at https://www.mozilla.org/MPL/2.0/ - -Many of the implementations run or compile using a line editing -library. In some cases, the implementations provide an option in the -code to switch between the GNU GPL licensed GNU readline library and -the BSD licensed editline (libedit) library. - - -Mozilla Public License Version 2.0 -================================== - -1. Definitions --------------- - -1.1. "Contributor" - means each individual or legal entity that creates, contributes to - the creation of, or owns Covered Software. - -1.2. "Contributor Version" - means the combination of the Contributions of others (if any) used - by a Contributor and that particular Contributor's Contribution. - -1.3. "Contribution" - means Covered Software of a particular Contributor. - -1.4. "Covered Software" - means Source Code Form to which the initial Contributor has attached - the notice in Exhibit A, the Executable Form of such Source Code - Form, and Modifications of such Source Code Form, in each case - including portions thereof. - -1.5. "Incompatible With Secondary Licenses" - means - - (a) that the initial Contributor has attached the notice described - in Exhibit B to the Covered Software; or - - (b) that the Covered Software was made available under the terms of - version 1.1 or earlier of the License, but not also under the - terms of a Secondary License. - -1.6. "Executable Form" - means any form of the work other than Source Code Form. - -1.7. "Larger Work" - means a work that combines Covered Software with other material, in - a separate file or files, that is not Covered Software. - -1.8. "License" - means this document. - -1.9. "Licensable" - means having the right to grant, to the maximum extent possible, - whether at the time of the initial grant or subsequently, any and - all of the rights conveyed by this License. - -1.10. "Modifications" - means any of the following: - - (a) any file in Source Code Form that results from an addition to, - deletion from, or modification of the contents of Covered - Software; or - - (b) any new file in Source Code Form that contains any Covered - Software. - -1.11. "Patent Claims" of a Contributor - means any patent claim(s), including without limitation, method, - process, and apparatus claims, in any patent Licensable by such - Contributor that would be infringed, but for the grant of the - License, by the making, using, selling, offering for sale, having - made, import, or transfer of either its Contributions or its - Contributor Version. - -1.12. "Secondary License" - means either the GNU General Public License, Version 2.0, the GNU - Lesser General Public License, Version 2.1, the GNU Affero General - Public License, Version 3.0, or any later versions of those - licenses. - -1.13. "Source Code Form" - means the form of the work preferred for making modifications. - -1.14. "You" (or "Your") - means an individual or a legal entity exercising rights under this - License. For legal entities, "You" includes any entity that - controls, is controlled by, or is under common control with You. For - purposes of this definition, "control" means (a) the power, direct - or indirect, to cause the direction or management of such entity, - whether by contract or otherwise, or (b) ownership of more than - fifty percent (50%) of the outstanding shares or beneficial - ownership of such entity. - -2. License Grants and Conditions --------------------------------- - -2.1. Grants - -Each Contributor hereby grants You a world-wide, royalty-free, -non-exclusive license: - -(a) under intellectual property rights (other than patent or trademark) - Licensable by such Contributor to use, reproduce, make available, - modify, display, perform, distribute, and otherwise exploit its - Contributions, either on an unmodified basis, with Modifications, or - as part of a Larger Work; and - -(b) under Patent Claims of such Contributor to make, use, sell, offer - for sale, have made, import, and otherwise transfer either its - Contributions or its Contributor Version. - -2.2. Effective Date - -The licenses granted in Section 2.1 with respect to any Contribution -become effective for each Contribution on the date the Contributor first -distributes such Contribution. - -2.3. Limitations on Grant Scope - -The licenses granted in this Section 2 are the only rights granted under -this License. No additional rights or licenses will be implied from the -distribution or licensing of Covered Software under this License. -Notwithstanding Section 2.1(b) above, no patent license is granted by a -Contributor: - -(a) for any code that a Contributor has removed from Covered Software; - or - -(b) for infringements caused by: (i) Your and any other third party's - modifications of Covered Software, or (ii) the combination of its - Contributions with other software (except as part of its Contributor - Version); or - -(c) under Patent Claims infringed by Covered Software in the absence of - its Contributions. - -This License does not grant any rights in the trademarks, service marks, -or logos of any Contributor (except as may be necessary to comply with -the notice requirements in Section 3.4). - -2.4. Subsequent Licenses - -No Contributor makes additional grants as a result of Your choice to -distribute the Covered Software under a subsequent version of this -License (see Section 10.2) or under the terms of a Secondary License (if -permitted under the terms of Section 3.3). - -2.5. Representation - -Each Contributor represents that the Contributor believes its -Contributions are its original creation(s) or it has sufficient rights -to grant the rights to its Contributions conveyed by this License. - -2.6. Fair Use - -This License is not intended to limit any rights You have under -applicable copyright doctrines of fair use, fair dealing, or other -equivalents. - -2.7. Conditions - -Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted -in Section 2.1. - -3. Responsibilities -------------------- - -3.1. Distribution of Source Form - -All distribution of Covered Software in Source Code Form, including any -Modifications that You create or to which You contribute, must be under -the terms of this License. You must inform recipients that the Source -Code Form of the Covered Software is governed by the terms of this -License, and how they can obtain a copy of this License. You may not -attempt to alter or restrict the recipients' rights in the Source Code -Form. - -3.2. Distribution of Executable Form - -If You distribute Covered Software in Executable Form then: - -(a) such Covered Software must also be made available in Source Code - Form, as described in Section 3.1, and You must inform recipients of - the Executable Form how they can obtain a copy of such Source Code - Form by reasonable means in a timely manner, at a charge no more - than the cost of distribution to the recipient; and - -(b) You may distribute such Executable Form under the terms of this - License, or sublicense it under different terms, provided that the - license for the Executable Form does not attempt to limit or alter - the recipients' rights in the Source Code Form under this License. - -3.3. Distribution of a Larger Work - -You may create and distribute a Larger Work under terms of Your choice, -provided that You also comply with the requirements of this License for -the Covered Software. If the Larger Work is a combination of Covered -Software with a work governed by one or more Secondary Licenses, and the -Covered Software is not Incompatible With Secondary Licenses, this -License permits You to additionally distribute such Covered Software -under the terms of such Secondary License(s), so that the recipient of -the Larger Work may, at their option, further distribute the Covered -Software under the terms of either this License or such Secondary -License(s). - -3.4. Notices - -You may not remove or alter the substance of any license notices -(including copyright notices, patent notices, disclaimers of warranty, -or limitations of liability) contained within the Source Code Form of -the Covered Software, except that You may alter any license notices to -the extent required to remedy known factual inaccuracies. - -3.5. Application of Additional Terms - -You may choose to offer, and to charge a fee for, warranty, support, -indemnity or liability obligations to one or more recipients of Covered -Software. However, You may do so only on Your own behalf, and not on -behalf of any Contributor. You must make it absolutely clear that any -such warranty, support, indemnity, or liability obligation is offered by -You alone, and You hereby agree to indemnify every Contributor for any -liability incurred by such Contributor as a result of warranty, support, -indemnity or liability terms You offer. You may include additional -disclaimers of warranty and limitations of liability specific to any -jurisdiction. - -4. Inability to Comply Due to Statute or Regulation ---------------------------------------------------- - -If it is impossible for You to comply with any of the terms of this -License with respect to some or all of the Covered Software due to -statute, judicial order, or regulation then You must: (a) comply with -the terms of this License to the maximum extent possible; and (b) -describe the limitations and the code they affect. Such description must -be placed in a text file included with all distributions of the Covered -Software under this License. Except to the extent prohibited by statute -or regulation, such description must be sufficiently detailed for a -recipient of ordinary skill to be able to understand it. - -5. Termination --------------- - -5.1. The rights granted under this License will terminate automatically -if You fail to comply with any of its terms. However, if You become -compliant, then the rights granted under this License from a particular -Contributor are reinstated (a) provisionally, unless and until such -Contributor explicitly and finally terminates Your grants, and (b) on an -ongoing basis, if such Contributor fails to notify You of the -non-compliance by some reasonable means prior to 60 days after You have -come back into compliance. Moreover, Your grants from a particular -Contributor are reinstated on an ongoing basis if such Contributor -notifies You of the non-compliance by some reasonable means, this is the -first time You have received notice of non-compliance with this License -from such Contributor, and You become compliant prior to 30 days after -Your receipt of the notice. - -5.2. If You initiate litigation against any entity by asserting a patent -infringement claim (excluding declaratory judgment actions, -counter-claims, and cross-claims) alleging that a Contributor Version -directly or indirectly infringes any patent, then the rights granted to -You by any and all Contributors for the Covered Software under Section -2.1 of this License shall terminate. - -5.3. In the event of termination under Sections 5.1 or 5.2 above, all -end user license agreements (excluding distributors and resellers) which -have been validly granted by You or Your distributors under this License -prior to termination shall survive termination. - -************************************************************************ -* * -* 6. Disclaimer of Warranty * -* ------------------------- * -* * -* Covered Software is provided under this License on an "as is" * -* basis, without warranty of any kind, either expressed, implied, or * -* statutory, including, without limitation, warranties that the * -* Covered Software is free of defects, merchantable, fit for a * -* particular purpose or non-infringing. The entire risk as to the * -* quality and performance of the Covered Software is with You. * -* Should any Covered Software prove defective in any respect, You * -* (not any Contributor) assume the cost of any necessary servicing, * -* repair, or correction. This disclaimer of warranty constitutes an * -* essential part of this License. No use of any Covered Software is * -* authorized under this License except under this disclaimer. * -* * -************************************************************************ - -************************************************************************ -* * -* 7. Limitation of Liability * -* -------------------------- * -* * -* Under no circumstances and under no legal theory, whether tort * -* (including negligence), contract, or otherwise, shall any * -* Contributor, or anyone who distributes Covered Software as * -* permitted above, be liable to You for any direct, indirect, * -* special, incidental, or consequential damages of any character * -* including, without limitation, damages for lost profits, loss of * -* goodwill, work stoppage, computer failure or malfunction, or any * -* and all other commercial damages or losses, even if such party * -* shall have been informed of the possibility of such damages. This * -* limitation of liability shall not apply to liability for death or * -* personal injury resulting from such party's negligence to the * -* extent applicable law prohibits such limitation. Some * -* jurisdictions do not allow the exclusion or limitation of * -* incidental or consequential damages, so this exclusion and * -* limitation may not apply to You. * -* * -************************************************************************ - -8. Litigation -------------- - -Any litigation relating to this License may be brought only in the -courts of a jurisdiction where the defendant maintains its principal -place of business and such litigation shall be governed by laws of that -jurisdiction, without reference to its conflict-of-law provisions. -Nothing in this Section shall prevent a party's ability to bring -cross-claims or counter-claims. - -9. Miscellaneous ----------------- - -This License represents the complete agreement concerning the subject -matter hereof. If any provision of this License is held to be -unenforceable, such provision shall be reformed only to the extent -necessary to make it enforceable. Any law or regulation which provides -that the language of a contract shall be construed against the drafter -shall not be used to construe this License against a Contributor. - -10. Versions of the License ---------------------------- - -10.1. New Versions - -Mozilla Foundation is the license steward. Except as provided in Section -10.3, no one other than the license steward has the right to modify or -publish new versions of this License. Each version will be given a -distinguishing version number. - -10.2. Effect of New Versions - -You may distribute the Covered Software under the terms of the version -of the License under which You originally received the Covered Software, -or under the terms of any subsequent version published by the license -steward. - -10.3. Modified Versions - -If you create software not governed by this License, and you want to -create a new license for such software, you may create and use a -modified version of this License if you rename the license and remove -any references to the name of the license steward (except to note that -such modified license differs from this License). - -10.4. Distributing Source Code Form that is Incompatible With Secondary -Licenses - -If You choose to distribute Source Code Form that is Incompatible With -Secondary Licenses under the terms of this version of the License, the -notice described in Exhibit B of this License must be attached. - -Exhibit A - Source Code Form License Notice -------------------------------------------- - - This Source Code Form is subject to the terms of the Mozilla Public - License, v. 2.0. If a copy of the MPL was not distributed with this - file, You can obtain one at http://mozilla.org/MPL/2.0/. - -If it is not possible or desirable to put the notice in a particular -file, then You may include the notice in a location (such as a LICENSE -file in a relevant directory) where a recipient would be likely to look -for such a notice. - -You may add additional accurate notices of copyright ownership. - -Exhibit B - "Incompatible With Secondary Licenses" Notice ---------------------------------------------------------- - - This Source Code Form is "Incompatible With Secondary Licenses", as - defined by the Mozilla Public License, v. 2.0. - - +Copyright (C) 2015 Joel Martin + +Mal (make-a-lisp) is licensed under the MPL 2.0 (Mozilla Public +License 2.0). The text of the MPL 2.0 license is included below and +can be found at https://www.mozilla.org/MPL/2.0/ + +Many of the implementations run or compile using a line editing +library. In some cases, the implementations provide an option in the +code to switch between the GNU GPL licensed GNU readline library and +the BSD licensed editline (libedit) library. + + +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. + + diff --git a/Makefile b/Makefile index 7d47ad44fb..9ae7e06173 100644 --- a/Makefile +++ b/Makefile @@ -1,360 +1,360 @@ -# Usage/help -all help: - @echo - @echo 'USAGE:' - @echo - @echo 'Rules/Targets:' - @echo - @echo 'make "IMPL" # build all steps of IMPL' - @echo 'make "build^IMPL" # build all steps of IMPL' - @echo 'make "IMPL^STEP" # build STEP of IMPL' - @echo 'make "build^IMPL^STEP" # build STEP of IMPL' - @echo - @echo 'make "test" # test all implementations' - @echo 'make "test^IMPL" # test all steps of IMPL' - @echo 'make "test^STEP" # test STEP for all implementations' - @echo 'make "test^IMPL^STEP" # test STEP of IMPL' - @echo - @echo 'make "perf" # run microbenchmarks for all implementations' - @echo 'make "perf^IMPL" # run microbenchmarks for IMPL' - @echo - @echo 'make "repl^IMPL" # run stepA of IMPL' - @echo 'make "repl^IMPL^STEP" # test STEP of IMPL' - @echo - @echo 'make "clean" # run 'make clean' for all implementations' - @echo 'make "clean^IMPL" # run 'make clean' for IMPL' - @echo - @echo 'make "stats" # run 'make stats' for all implementations' - @echo 'make "stats-lisp" # run 'make stats-lisp' for all implementations' - @echo 'make "stats^IMPL" # run 'make stats' for IMPL' - @echo 'make "stats-lisp^IMPL" # run 'make stats-lisp' for IMPL' - @echo - @echo 'Options/Settings:' - @echo - @echo 'make MAL_IMPL=IMPL "test^mal..." # use IMPL for self-host tests' - @echo 'make REGRESS=1 "test..." # test with previous step tests too' - @echo 'make DOCKERIZE=1 ... # to dockerize above rules/targets' - @echo 'make TEST_OPTS="--opt ..." # options to pass to runtest.py' - @echo - @echo 'Other:' - @echo - @echo 'make "docker-build^IMPL" # build docker image for IMPL' - @echo - @echo 'make "docker-shell^IMPL" # start bash shell in docker image for IMPL' - @echo - -# Implementation specific settings are here: -include Makefile.impls - -# -# General command line settings -# - -MAL_IMPL = js - -# Path to loccount for counting LOC stats -LOCCOUNT = loccount - -# Extra options to pass to runtest.py -TEST_OPTS = - -# Test with previous test files not just the test files for the -# current step. Step 0 and 1 tests are special and not included in -# later steps. -REGRESS = - -HARD= -DEFERRABLE=1 -OPTIONAL=1 - -# Run target/rule within docker image for the implementation -DOCKERIZE = - - -# -# General settings and utility functions -# - -EXTENSION = .mal - -step0 = step0_repl -step1 = step1_read_print -step2 = step2_eval -step3 = step3_env -step4 = step4_if_fn_do -step5 = step5_tco -step6 = step6_file -step7 = step7_quote -step8 = step8_macros -step9 = step9_try -stepA = stepA_mal - -argv_STEP = step6_file - - -regress_step0 = step0 -regress_step1 = step1 -regress_step2 = step2 -regress_step3 = $(regress_step2) step3 -regress_step4 = $(regress_step3) step4 -regress_step5 = $(regress_step4) step5 -regress_step6 = $(regress_step5) step6 -regress_step7 = $(regress_step6) step7 -regress_step8 = $(regress_step7) step8 -regress_step9 = $(regress_step8) step9 -regress_stepA = $(regress_step9) stepA - -# Needed some argument munging -COMMA = , -noop = -SPACE = $(noop) $(noop) -export FACTOR_ROOTS := . - -opt_HARD = $(if $(strip $(HARD)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(HARD)),--hard,),) -opt_DEFERRABLE = $(if $(strip $(DEFERRABLE)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(DEFERRABLE)),--deferrable,--no-deferrable),--no-deferrable) -opt_OPTIONAL = $(if $(strip $(OPTIONAL)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(OPTIONAL)),--optional,--no-optional),--no-optional) - -# Return list of test files for a given step. If REGRESS is set then -# test files will include step 2 tests through tests for the step -# being tested. -STEP_TEST_FILES = $(strip $(wildcard \ - $(foreach s,$(if $(strip $(REGRESS)),\ - $(filter-out $(if $(filter $(1),$(step5_EXCLUDES)),step5,),\ - $(regress_$(2)))\ - ,$(2)),\ - impls/$(1)/tests/$($(s))$(EXTENSION) impls/tests/$($(s))$(EXTENSION)))) - -# DOCKERIZE utility functions -lc = $(subst A,a,$(subst B,b,$(subst C,c,$(subst D,d,$(subst E,e,$(subst F,f,$(subst G,g,$(subst H,h,$(subst I,i,$(subst J,j,$(subst K,k,$(subst L,l,$(subst M,m,$(subst N,n,$(subst O,o,$(subst P,p,$(subst Q,q,$(subst R,r,$(subst S,s,$(subst T,t,$(subst U,u,$(subst V,v,$(subst W,w,$(subst X,x,$(subst Y,y,$(subst Z,z,$1)))))))))))))))))))))))))) -impl_to_image = kanaka/mal-test-$(call lc,$(1)) - -actual_impl = $(if $(filter mal,$(1)),$(patsubst %-mal,%,$(MAL_IMPL)),$(1)) - -# Takes impl -# Returns nothing if DOCKERIZE is not set, otherwise returns the -# docker prefix necessary to run make within the docker environment -# for this impl -get_build_command = $(strip $(foreach mode,$(1)_MODE, \ - $(if $(strip $(DOCKERIZE)),\ - docker run \ - -it --rm -u $(shell id -u) \ - -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal \ - -w /mal/impls/$(1) \ - $(if $(strip $($(mode))),-e $(mode)=$($(mode)),) \ - $(if $(filter factor,$(1)),-e FACTOR_ROOTS=$(FACTOR_ROOTS),) \ - $(call impl_to_image,$(1)) \ - $(MAKE) $(if $(strip $($(mode))),$(mode)=$($(mode)),) \ - ,\ - $(MAKE) $(if $(strip $($(mode))),$(mode)=$($(mode)),) -C impls/$(impl)))) - -# Takes impl and step args. Optional env vars and dockerize args -# Returns a command prefix (docker command and environment variables) -# necessary to launch the given impl and step -get_run_prefix = $(strip $(foreach mode,$(call actual_impl,$(1))_MODE, \ - $(if $(strip $(DOCKERIZE) $(4)),\ - docker run -e STEP=$($2) -e MAL_IMPL=$(MAL_IMPL) \ - -it --rm -u $(shell id -u) \ - -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal \ - -w /mal/impls/$(call actual_impl,$(1)) \ - $(if $(strip $($(mode))),-e $(mode)=$($(mode)),) \ - $(if $(filter factor,$(1)),-e FACTOR_ROOTS=$(FACTOR_ROOTS),) \ - $(foreach env,$(3),-e $(env)) \ - $(call impl_to_image,$(call actual_impl,$(1))) \ - ,\ - env STEP=$($2) MAL_IMPL=$(MAL_IMPL) \ - $(if $(strip $($(mode))),$(mode)=$($(mode)),) \ - $(if $(filter factor,$(1)),FACTOR_ROOTS=$(FACTOR_ROOTS),) \ - $(3)))) - -# Takes impl and step -# Returns the runtest command prefix (with runtest options) for testing the given step -get_runtest_cmd = $(call get_run_prefix,$(1),$(2),$(if $(filter cs fsharp mal tcl vb,$(1)),RAW=1,)) \ - ../../runtest.py $(opt_HARD) $(opt_DEFERRABLE) $(opt_OPTIONAL) $(call $(1)_TEST_OPTS) $(TEST_OPTS) - -# Takes impl and step -# Returns the runtest command prefix (with runtest options) for testing the given step -get_argvtest_cmd = $(call get_run_prefix,$(1),$(2)) ../tests/run_argv_test.sh - -# Derived lists -STEPS = $(sort $(filter-out %_EXCLUDES,$(filter step%,$(.VARIABLES)))) -DO_IMPLS = $(filter-out $(SKIP_IMPLS),$(IMPLS)) -IMPL_TESTS = $(foreach impl,$(DO_IMPLS),test^$(impl)) -STEP_TESTS = $(foreach step,$(STEPS),test^$(step)) -ALL_TESTS = $(filter-out $(foreach e,$(step5_EXCLUDES),test^$(e)^step5),\ - $(strip $(sort \ - $(foreach impl,$(DO_IMPLS),\ - $(foreach step,$(STEPS),test^$(impl)^$(step)))))) -ALL_BUILDS = $(strip $(sort \ - $(foreach impl,$(DO_IMPLS),\ - $(foreach step,$(STEPS),build^$(impl)^$(step))))) - -DOCKER_BUILD = $(foreach impl,$(DO_IMPLS),docker-build^$(impl)) - -DOCKER_SHELL = $(foreach impl,$(DO_IMPLS),docker-shell^$(impl)) - -IMPL_PERF = $(foreach impl,$(filter-out $(perf_EXCLUDES),$(DO_IMPLS)),perf^$(impl)) - -IMPL_STATS = $(foreach impl,$(DO_IMPLS),stats^$(impl)) - -IMPL_REPL = $(foreach impl,$(DO_IMPLS),repl^$(impl)) -ALL_REPL = $(strip $(sort \ - $(foreach impl,$(DO_IMPLS),\ - $(foreach step,$(STEPS),repl^$(impl)^$(step))))) - - -# -# Build rules -# - -# Enable secondary expansion for all rules -.SECONDEXPANSION: - -# Build a program in an implementation directory -# Make sure we always try and build first because the dependencies are -# encoded in the implementation Makefile not here -.PHONY: $(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s)))) -$(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s)))): - $(foreach impl,$(word 2,$(subst /, ,$(@))),\ - $(if $(DOCKERIZE), \ - $(call get_build_command,$(impl)) $(patsubst impls/$(impl)/%,%,$(@)), \ - $(call get_build_command,$(impl)) $(subst impls/$(impl)/,,$(@)))) - -# Allow IMPL, build^IMPL, IMPL^STEP, and build^IMPL^STEP -$(DO_IMPLS): $$(foreach s,$$(STEPS),$$(call $$(@)_STEP_TO_PROG,$$(s))) - -$(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),build^$(i))): $$(foreach s,$$(STEPS),$$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(s))) - -$(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(i)^$(s))): $$(call $$(word 1,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 2,$$(subst ^, ,$$(@)))) - -$(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),build^$(i)^$(s))): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(subst ^, ,$$(@)))) - - - -# -# Test rules -# - -$(ALL_TESTS): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(subst ^, ,$$(@)))) - @$(foreach impl,$(word 2,$(subst ^, ,$(@))),\ - $(foreach step,$(word 3,$(subst ^, ,$(@))),\ - echo "(call STEP_TEST_FILES,$(impl),$(step)): $(call STEP_TEST_FILES,$(impl),$(step))" && \ - cd impls/$(call actual_impl,$(impl)) && \ - $(foreach test,$(patsubst impls/%,%,$(call STEP_TEST_FILES,$(impl),$(step))),\ - echo '----------------------------------------------' && \ - echo 'Testing $@; step file: $+, test file: $(test)' && \ - echo 'Running: $(call get_runtest_cmd,$(impl),$(step)) ../$(test) -- ../$(impl)/run' && \ - $(call get_runtest_cmd,$(impl),$(step)) ../$(test) -- ../$(impl)/run && \ - $(if $(filter tests/$(argv_STEP)$(EXTENSION),$(test)),\ - echo '----------------------------------------------' && \ - echo 'Testing ARGV of $@; step file: $+' && \ - echo 'Running: $(call get_argvtest_cmd,$(impl),$(step)) ../$(impl)/run ' && \ - $(call get_argvtest_cmd,$(impl),$(step)) ../$(impl)/run && ,\ - true && ))\ - true)) - -# Allow test, tests, test^STEP, test^IMPL, and test^IMPL^STEP -test: $(ALL_TESTS) -tests: $(ALL_TESTS) - -$(IMPL_TESTS): $$(filter $$@^%,$$(ALL_TESTS)) - -$(STEP_TESTS): $$(foreach step,$$(subst test^,,$$@),$$(filter %^$$(step),$$(ALL_TESTS))) - - -# -# Docker build rules -# - -docker-build: $(DOCKER_BUILD) - -$(DOCKER_BUILD): - @echo "----------------------------------------------"; \ - $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ - echo "Running: docker build -t $(call impl_to_image,$(impl)) .:"; \ - cd impls/$(impl) && docker build -t $(call impl_to_image,$(impl)) .) - -# -# Docker shell rules -# - -$(DOCKER_SHELL): - @echo "----------------------------------------------"; \ - $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ - echo "Running: $(call get_run_prefix,$(impl),stepA,,dockerize) bash"; \ - $(call get_run_prefix,$(impl),stepA,,dockerize) bash) - - -# -# Performance test rules -# - -perf: $(IMPL_PERF) - -$(IMPL_PERF): - @echo "----------------------------------------------"; \ - $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ - cd impls/$(call actual_impl,$(impl)); \ - echo "Performance test for $(impl):"; \ - echo 'Running: $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf1.mal'; \ - $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf1.mal; \ - echo 'Running: $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf2.mal'; \ - $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf2.mal; \ - echo 'Running: $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf3.mal'; \ - $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf3.mal) - - -# -# REPL invocation rules -# - -$(ALL_REPL): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(subst ^, ,$$(@)))) - @$(foreach impl,$(word 2,$(subst ^, ,$(@))),\ - $(foreach step,$(word 3,$(subst ^, ,$(@))),\ - cd impls/$(call actual_impl,$(impl)); \ - echo 'REPL implementation $(impl), step file: $+'; \ - echo 'Running: $(call get_run_prefix,$(impl),$(step)) ../$(impl)/run $(RUN_ARGS)'; \ - $(call get_run_prefix,$(impl),$(step)) ../$(impl)/run $(RUN_ARGS);)) - -# Allow repl^IMPL^STEP and repl^IMPL (which starts REPL of stepA) -$(IMPL_REPL): $$@^stepA - -# -# Stats test rules -# - -# For a concise summary: -# make stats | egrep -A1 "^Stats for|^all" | egrep -v "^all|^--" -stats: $(IMPL_STATS) - -$(IMPL_STATS): - @$(foreach impl,$(word 2,$(subst ^, ,$(@))),\ - echo "Stats for $(impl):"; \ - $(LOCCOUNT) -x "[sS]tep[0-9]_.*|[.]md$$|tests|examples|Makefile|package.json|tsconfig.json|Cargo.toml|project.clj|node_modules|getline.cs|terminal.cs|elm-stuff|objpascal/regexpr|rdyncall|swift/templates" impls/$(impl)) - -# -# Utility functions -# -print-%: - @echo "$($(*))" - -# -# Recursive rules (call make FOO in each subdirectory) -# - -define recur_template -.PHONY: $(1) -$(1): $(2) -$(2): - @echo "----------------------------------------------"; \ - $$(foreach impl,$$(word 2,$$(subst ^, ,$$(@))),\ - echo "Running: $$(call get_build_command,$$(impl)) --no-print-directory $(1)"; \ - $$(call get_build_command,$$(impl)) --no-print-directory $(1)) -endef - -recur_impls_ = $(filter-out $(foreach impl,$($(1)_EXCLUDES),$(1)^$(impl)),$(foreach impl,$(IMPLS),$(1)^$(impl))) - -# recursive clean -$(eval $(call recur_template,clean,$(call recur_impls_,clean))) - -# recursive dist -$(eval $(call recur_template,dist,$(call recur_impls_,dist))) +# Usage/help +all help: + @echo + @echo 'USAGE:' + @echo + @echo 'Rules/Targets:' + @echo + @echo 'make "IMPL" # build all steps of IMPL' + @echo 'make "build^IMPL" # build all steps of IMPL' + @echo 'make "IMPL^STEP" # build STEP of IMPL' + @echo 'make "build^IMPL^STEP" # build STEP of IMPL' + @echo + @echo 'make "test" # test all implementations' + @echo 'make "test^IMPL" # test all steps of IMPL' + @echo 'make "test^STEP" # test STEP for all implementations' + @echo 'make "test^IMPL^STEP" # test STEP of IMPL' + @echo + @echo 'make "perf" # run microbenchmarks for all implementations' + @echo 'make "perf^IMPL" # run microbenchmarks for IMPL' + @echo + @echo 'make "repl^IMPL" # run stepA of IMPL' + @echo 'make "repl^IMPL^STEP" # test STEP of IMPL' + @echo + @echo 'make "clean" # run 'make clean' for all implementations' + @echo 'make "clean^IMPL" # run 'make clean' for IMPL' + @echo + @echo 'make "stats" # run 'make stats' for all implementations' + @echo 'make "stats-lisp" # run 'make stats-lisp' for all implementations' + @echo 'make "stats^IMPL" # run 'make stats' for IMPL' + @echo 'make "stats-lisp^IMPL" # run 'make stats-lisp' for IMPL' + @echo + @echo 'Options/Settings:' + @echo + @echo 'make MAL_IMPL=IMPL "test^mal..." # use IMPL for self-host tests' + @echo 'make REGRESS=1 "test..." # test with previous step tests too' + @echo 'make DOCKERIZE=1 ... # to dockerize above rules/targets' + @echo 'make TEST_OPTS="--opt ..." # options to pass to runtest.py' + @echo + @echo 'Other:' + @echo + @echo 'make "docker-build^IMPL" # build docker image for IMPL' + @echo + @echo 'make "docker-shell^IMPL" # start bash shell in docker image for IMPL' + @echo + +# Implementation specific settings are here: +include Makefile.impls + +# +# General command line settings +# + +MAL_IMPL = js + +# Path to loccount for counting LOC stats +LOCCOUNT = loccount + +# Extra options to pass to runtest.py +TEST_OPTS = + +# Test with previous test files not just the test files for the +# current step. Step 0 and 1 tests are special and not included in +# later steps. +REGRESS = + +HARD= +DEFERRABLE=1 +OPTIONAL=1 + +# Run target/rule within docker image for the implementation +DOCKERIZE = + + +# +# General settings and utility functions +# + +EXTENSION = .mal + +step0 = step0_repl +step1 = step1_read_print +step2 = step2_eval +step3 = step3_env +step4 = step4_if_fn_do +step5 = step5_tco +step6 = step6_file +step7 = step7_quote +step8 = step8_macros +step9 = step9_try +stepA = stepA_mal + +argv_STEP = step6_file + + +regress_step0 = step0 +regress_step1 = step1 +regress_step2 = step2 +regress_step3 = $(regress_step2) step3 +regress_step4 = $(regress_step3) step4 +regress_step5 = $(regress_step4) step5 +regress_step6 = $(regress_step5) step6 +regress_step7 = $(regress_step6) step7 +regress_step8 = $(regress_step7) step8 +regress_step9 = $(regress_step8) step9 +regress_stepA = $(regress_step9) stepA + +# Needed some argument munging +COMMA = , +noop = +SPACE = $(noop) $(noop) +export FACTOR_ROOTS := . + +opt_HARD = $(if $(strip $(HARD)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(HARD)),--hard,),) +opt_DEFERRABLE = $(if $(strip $(DEFERRABLE)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(DEFERRABLE)),--deferrable,--no-deferrable),--no-deferrable) +opt_OPTIONAL = $(if $(strip $(OPTIONAL)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(OPTIONAL)),--optional,--no-optional),--no-optional) + +# Return list of test files for a given step. If REGRESS is set then +# test files will include step 2 tests through tests for the step +# being tested. +STEP_TEST_FILES = $(strip $(wildcard \ + $(foreach s,$(if $(strip $(REGRESS)),\ + $(filter-out $(if $(filter $(1),$(step5_EXCLUDES)),step5,),\ + $(regress_$(2)))\ + ,$(2)),\ + impls/$(1)/tests/$($(s))$(EXTENSION) impls/tests/$($(s))$(EXTENSION)))) + +# DOCKERIZE utility functions +lc = $(subst A,a,$(subst B,b,$(subst C,c,$(subst D,d,$(subst E,e,$(subst F,f,$(subst G,g,$(subst H,h,$(subst I,i,$(subst J,j,$(subst K,k,$(subst L,l,$(subst M,m,$(subst N,n,$(subst O,o,$(subst P,p,$(subst Q,q,$(subst R,r,$(subst S,s,$(subst T,t,$(subst U,u,$(subst V,v,$(subst W,w,$(subst X,x,$(subst Y,y,$(subst Z,z,$1)))))))))))))))))))))))))) +impl_to_image = kanaka/mal-test-$(call lc,$(1)) + +actual_impl = $(if $(filter mal,$(1)),$(patsubst %-mal,%,$(MAL_IMPL)),$(1)) + +# Takes impl +# Returns nothing if DOCKERIZE is not set, otherwise returns the +# docker prefix necessary to run make within the docker environment +# for this impl +get_build_command = $(strip $(foreach mode,$(1)_MODE, \ + $(if $(strip $(DOCKERIZE)),\ + docker run \ + -it --rm -u $(shell id -u) \ + -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal \ + -w /mal/impls/$(1) \ + $(if $(strip $($(mode))),-e $(mode)=$($(mode)),) \ + $(if $(filter factor,$(1)),-e FACTOR_ROOTS=$(FACTOR_ROOTS),) \ + $(call impl_to_image,$(1)) \ + $(MAKE) $(if $(strip $($(mode))),$(mode)=$($(mode)),) \ + ,\ + $(MAKE) $(if $(strip $($(mode))),$(mode)=$($(mode)),) -C impls/$(impl)))) + +# Takes impl and step args. Optional env vars and dockerize args +# Returns a command prefix (docker command and environment variables) +# necessary to launch the given impl and step +get_run_prefix = $(strip $(foreach mode,$(call actual_impl,$(1))_MODE, \ + $(if $(strip $(DOCKERIZE) $(4)),\ + docker run -e STEP=$($2) -e MAL_IMPL=$(MAL_IMPL) \ + -it --rm -u $(shell id -u) \ + -v $(dir $(abspath $(lastword $(MAKEFILE_LIST)))):/mal \ + -w /mal/impls/$(call actual_impl,$(1)) \ + $(if $(strip $($(mode))),-e $(mode)=$($(mode)),) \ + $(if $(filter factor,$(1)),-e FACTOR_ROOTS=$(FACTOR_ROOTS),) \ + $(foreach env,$(3),-e $(env)) \ + $(call impl_to_image,$(call actual_impl,$(1))) \ + ,\ + env STEP=$($2) MAL_IMPL=$(MAL_IMPL) \ + $(if $(strip $($(mode))),$(mode)=$($(mode)),) \ + $(if $(filter factor,$(1)),FACTOR_ROOTS=$(FACTOR_ROOTS),) \ + $(3)))) + +# Takes impl and step +# Returns the runtest command prefix (with runtest options) for testing the given step +get_runtest_cmd = $(call get_run_prefix,$(1),$(2),$(if $(filter cs fsharp mal tcl vb,$(1)),RAW=1,)) \ + ../../runtest.py $(opt_HARD) $(opt_DEFERRABLE) $(opt_OPTIONAL) $(call $(1)_TEST_OPTS) $(TEST_OPTS) + +# Takes impl and step +# Returns the runtest command prefix (with runtest options) for testing the given step +get_argvtest_cmd = $(call get_run_prefix,$(1),$(2)) ../tests/run_argv_test.sh + +# Derived lists +STEPS = $(sort $(filter-out %_EXCLUDES,$(filter step%,$(.VARIABLES)))) +DO_IMPLS = $(filter-out $(SKIP_IMPLS),$(IMPLS)) +IMPL_TESTS = $(foreach impl,$(DO_IMPLS),test^$(impl)) +STEP_TESTS = $(foreach step,$(STEPS),test^$(step)) +ALL_TESTS = $(filter-out $(foreach e,$(step5_EXCLUDES),test^$(e)^step5),\ + $(strip $(sort \ + $(foreach impl,$(DO_IMPLS),\ + $(foreach step,$(STEPS),test^$(impl)^$(step)))))) +ALL_BUILDS = $(strip $(sort \ + $(foreach impl,$(DO_IMPLS),\ + $(foreach step,$(STEPS),build^$(impl)^$(step))))) + +DOCKER_BUILD = $(foreach impl,$(DO_IMPLS),docker-build^$(impl)) + +DOCKER_SHELL = $(foreach impl,$(DO_IMPLS),docker-shell^$(impl)) + +IMPL_PERF = $(foreach impl,$(filter-out $(perf_EXCLUDES),$(DO_IMPLS)),perf^$(impl)) + +IMPL_STATS = $(foreach impl,$(DO_IMPLS),stats^$(impl)) + +IMPL_REPL = $(foreach impl,$(DO_IMPLS),repl^$(impl)) +ALL_REPL = $(strip $(sort \ + $(foreach impl,$(DO_IMPLS),\ + $(foreach step,$(STEPS),repl^$(impl)^$(step))))) + + +# +# Build rules +# + +# Enable secondary expansion for all rules +.SECONDEXPANSION: + +# Build a program in an implementation directory +# Make sure we always try and build first because the dependencies are +# encoded in the implementation Makefile not here +.PHONY: $(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s)))) +$(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(call $(i)_STEP_TO_PROG,$(s)))): + $(foreach impl,$(word 2,$(subst /, ,$(@))),\ + $(if $(DOCKERIZE), \ + $(call get_build_command,$(impl)) $(patsubst impls/$(impl)/%,%,$(@)), \ + $(call get_build_command,$(impl)) $(subst impls/$(impl)/,,$(@)))) + +# Allow IMPL, build^IMPL, IMPL^STEP, and build^IMPL^STEP +$(DO_IMPLS): $$(foreach s,$$(STEPS),$$(call $$(@)_STEP_TO_PROG,$$(s))) + +$(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),build^$(i))): $$(foreach s,$$(STEPS),$$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(s))) + +$(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),$(i)^$(s))): $$(call $$(word 1,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 2,$$(subst ^, ,$$(@)))) + +$(foreach i,$(DO_IMPLS),$(foreach s,$(STEPS),build^$(i)^$(s))): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(subst ^, ,$$(@)))) + + + +# +# Test rules +# + +$(ALL_TESTS): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(subst ^, ,$$(@)))) + @$(foreach impl,$(word 2,$(subst ^, ,$(@))),\ + $(foreach step,$(word 3,$(subst ^, ,$(@))),\ + echo "(call STEP_TEST_FILES,$(impl),$(step)): $(call STEP_TEST_FILES,$(impl),$(step))" && \ + cd impls/$(call actual_impl,$(impl)) && \ + $(foreach test,$(patsubst impls/%,%,$(call STEP_TEST_FILES,$(impl),$(step))),\ + echo '----------------------------------------------' && \ + echo 'Testing $@; step file: $+, test file: $(test)' && \ + echo 'Running: $(call get_runtest_cmd,$(impl),$(step)) ../$(test) -- ../$(impl)/run' && \ + $(call get_runtest_cmd,$(impl),$(step)) ../$(test) -- ../$(impl)/run && \ + $(if $(filter tests/$(argv_STEP)$(EXTENSION),$(test)),\ + echo '----------------------------------------------' && \ + echo 'Testing ARGV of $@; step file: $+' && \ + echo 'Running: $(call get_argvtest_cmd,$(impl),$(step)) ../$(impl)/run ' && \ + $(call get_argvtest_cmd,$(impl),$(step)) ../$(impl)/run && ,\ + true && ))\ + true)) + +# Allow test, tests, test^STEP, test^IMPL, and test^IMPL^STEP +test: $(ALL_TESTS) +tests: $(ALL_TESTS) + +$(IMPL_TESTS): $$(filter $$@^%,$$(ALL_TESTS)) + +$(STEP_TESTS): $$(foreach step,$$(subst test^,,$$@),$$(filter %^$$(step),$$(ALL_TESTS))) + + +# +# Docker build rules +# + +docker-build: $(DOCKER_BUILD) + +$(DOCKER_BUILD): + @echo "----------------------------------------------"; \ + $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ + echo "Running: docker build -t $(call impl_to_image,$(impl)) .:"; \ + cd impls/$(impl) && docker build -t $(call impl_to_image,$(impl)) .) + +# +# Docker shell rules +# + +$(DOCKER_SHELL): + @echo "----------------------------------------------"; \ + $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ + echo "Running: $(call get_run_prefix,$(impl),stepA,,dockerize) bash"; \ + $(call get_run_prefix,$(impl),stepA,,dockerize) bash) + + +# +# Performance test rules +# + +perf: $(IMPL_PERF) + +$(IMPL_PERF): + @echo "----------------------------------------------"; \ + $(foreach impl,$(word 2,$(subst ^, ,$(@))),\ + cd impls/$(call actual_impl,$(impl)); \ + echo "Performance test for $(impl):"; \ + echo 'Running: $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf1.mal'; \ + $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf1.mal; \ + echo 'Running: $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf2.mal'; \ + $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf2.mal; \ + echo 'Running: $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf3.mal'; \ + $(call get_run_prefix,$(impl),stepA) ../$(impl)/run ../tests/perf3.mal) + + +# +# REPL invocation rules +# + +$(ALL_REPL): $$(call $$(word 2,$$(subst ^, ,$$(@)))_STEP_TO_PROG,$$(word 3,$$(subst ^, ,$$(@)))) + @$(foreach impl,$(word 2,$(subst ^, ,$(@))),\ + $(foreach step,$(word 3,$(subst ^, ,$(@))),\ + cd impls/$(call actual_impl,$(impl)); \ + echo 'REPL implementation $(impl), step file: $+'; \ + echo 'Running: $(call get_run_prefix,$(impl),$(step)) ../$(impl)/run $(RUN_ARGS)'; \ + $(call get_run_prefix,$(impl),$(step)) ../$(impl)/run $(RUN_ARGS);)) + +# Allow repl^IMPL^STEP and repl^IMPL (which starts REPL of stepA) +$(IMPL_REPL): $$@^stepA + +# +# Stats test rules +# + +# For a concise summary: +# make stats | egrep -A1 "^Stats for|^all" | egrep -v "^all|^--" +stats: $(IMPL_STATS) + +$(IMPL_STATS): + @$(foreach impl,$(word 2,$(subst ^, ,$(@))),\ + echo "Stats for $(impl):"; \ + $(LOCCOUNT) -x "[sS]tep[0-9]_.*|[.]md$$|tests|examples|Makefile|package.json|tsconfig.json|Cargo.toml|project.clj|node_modules|getline.cs|terminal.cs|elm-stuff|objpascal/regexpr|rdyncall|swift/templates" impls/$(impl)) + +# +# Utility functions +# +print-%: + @echo "$($(*))" + +# +# Recursive rules (call make FOO in each subdirectory) +# + +define recur_template +.PHONY: $(1) +$(1): $(2) +$(2): + @echo "----------------------------------------------"; \ + $$(foreach impl,$$(word 2,$$(subst ^, ,$$(@))),\ + echo "Running: $$(call get_build_command,$$(impl)) --no-print-directory $(1)"; \ + $$(call get_build_command,$$(impl)) --no-print-directory $(1)) +endef + +recur_impls_ = $(filter-out $(foreach impl,$($(1)_EXCLUDES),$(1)^$(impl)),$(foreach impl,$(IMPLS),$(1)^$(impl))) + +# recursive clean +$(eval $(call recur_template,clean,$(call recur_impls_,clean))) + +# recursive dist +$(eval $(call recur_template,dist,$(call recur_impls_,dist))) diff --git a/Makefile.impls b/Makefile.impls index 6ac35b23e5..b091d7ab0c 100644 --- a/Makefile.impls +++ b/Makefile.impls @@ -1,199 +1,199 @@ -# HOWTO add a new implementation (named "foo"): -# - Add "foo" to the IMPLS variable (alphabetical order) -# - Add a new "foo_STEP_TO_PROG" variable. -# - Add an "impls/foo/run" script. -# - Add an "impls/foo/Makefile" -# - Add an "impls/foo/Dockerfile" -# - Implement each step in "impls/foo/". - -# -# Implementation specific command line settings -# - -# cbm or qbasic -basic_MODE = cbm -# clj or cljs (Clojure vs ClojureScript/lumo) -clojure_MODE = clj -# gdc, ldc2, or dmd -d_MODE = gdc -# python, js, cpp, or neko -haxe_MODE = neko -# octave or matlab -matlab_MODE = octave -# python, python2 or python3 -python_MODE = python -# scheme (chibi, kawa, gauche, chicken, sagittarius, cyclone, foment) -scheme_MODE = chibi -# sml (polyml, mlton, mosml) -sml_MODE = polyml -# wasmtime wasmer lucet wax node warpy wace_libc -wasm_MODE = wasmtime - - -# -# Implementation specific settings -# - -IMPLS = ada ada.2 awk bash basic bbc-basic c c.2 chuck clojure coffee common-lisp cpp crystal cs d dart \ - elisp elixir elm erlang es6 factor fantom fennel forth fsharp go groovy gnu-smalltalk \ - guile haskell haxe hy io janet java java-truffle js jq julia kotlin livescript logo lua make mal \ - matlab miniMAL nasm nim objc objpascal ocaml perl perl6 php picolisp pike plpgsql \ - plsql powershell prolog ps purs python python.2 r racket rexx rpython ruby ruby.2 rust scala scheme skew sml \ - swift swift3 swift4 swift5 tcl ts vala vb vhdl vimscript wasm wren yorick xslt zig - -step5_EXCLUDES += bash # never completes at 10,000 -step5_EXCLUDES += basic # too slow, and limited to ints of 2^16 -step5_EXCLUDES += logo # too slow for 10,000 -step5_EXCLUDES += make # no TCO capability (iteration or recursion) -step5_EXCLUDES += mal # host impl dependent -step5_EXCLUDES += matlab # never completes at 10,000 -step5_EXCLUDES += plpgsql # too slow for 10,000 -step5_EXCLUDES += plsql # too slow for 10,000 -step5_EXCLUDES += powershell # too slow for 10,000 -step5_EXCLUDES += prolog # no iteration (but interpreter does TCO implicitly) -step5_EXCLUDES += sml # not implemented :( -step5_EXCLUDES += $(if $(filter cpp,$(haxe_MODE)),haxe,) # cpp finishes 10,000, segfaults at 100,000 -step5_EXCLUDES += xslt # iteration cannot be expressed - -dist_EXCLUDES += mal -# TODO: still need to implement dist -dist_EXCLUDES += guile io julia matlab swift - - -# Extra options to pass to runtest.py -bbc-basic_TEST_OPTS = --test-timeout 60 -guile_TEST_OPTS = --test-timeout 120 -io_TEST_OPTS = --test-timeout 120 -java-truffle_TEST_OPTS = --start-timeout 30 -logo_TEST_OPTS = --start-timeout 60 --test-timeout 120 -mal_TEST_OPTS = --start-timeout 60 --test-timeout 120 -miniMAL_TEST_OPTS = --start-timeout 60 --test-timeout 120 -perl6_TEST_OPTS = --test-timeout=60 -plpgsql_TEST_OPTS = --start-timeout 60 --test-timeout 180 -plsql_TEST_OPTS = --start-timeout 120 --test-timeout 120 -vimscript_TEST_OPTS = --test-timeout 30 -ifeq ($(MAL_IMPL),vimscript) -mal_TEST_OPTS = --start-timeout 60 --test-timeout 180 -else ifeq ($(MAL_IMPL),powershell) -mal_TEST_OPTS = --start-timeout 60 --test-timeout 180 -endif -xslt_TEST_OPTS = --test-timeout 120 - - -# -# Implementation specific utility functions -# - -basic_STEP_TO_PROG_cbm = impls/basic/$($(1)).bas -basic_STEP_TO_PROG_qbasic = impls/basic/$($(1)) - -clojure_STEP_TO_PROG_clj = impls/clojure/target/$($(1)).jar -clojure_STEP_TO_PROG_cljs = impls/clojure/src/mal/$($(1)).cljc - -haxe_STEP_TO_PROG_neko = impls/haxe/$($(1)).n -haxe_STEP_TO_PROG_python = impls/haxe/$($(1)).py -haxe_STEP_TO_PROG_cpp = impls/haxe/cpp/$($(1)) -haxe_STEP_TO_PROG_js = impls/haxe/$($(1)).js - -scheme_STEP_TO_PROG_chibi = impls/scheme/$($(1)).scm -scheme_STEP_TO_PROG_kawa = impls/scheme/out/$($(1)).class -scheme_STEP_TO_PROG_gauche = impls/scheme/$($(1)).scm -scheme_STEP_TO_PROG_chicken = impls/scheme/$($(1)) -scheme_STEP_TO_PROG_sagittarius = impls/scheme/$($(1)).scm -scheme_STEP_TO_PROG_cyclone = impls/scheme/$($(1)) -scheme_STEP_TO_PROG_foment = impls/scheme/$($(1)).scm - -# Map of step (e.g. "step8") to executable file for that step -ada_STEP_TO_PROG = impls/ada/$($(1)) -ada.2_STEP_TO_PROG = impls/ada.2/$($(1)) -awk_STEP_TO_PROG = impls/awk/$($(1)).awk -bash_STEP_TO_PROG = impls/bash/$($(1)).sh -basic_STEP_TO_PROG = $(basic_STEP_TO_PROG_$(basic_MODE)) -bbc-basic_STEP_TO_PROG = impls/bbc-basic/$($(1)).bas -c_STEP_TO_PROG = impls/c/$($(1)) -c.2_STEP_TO_PROG = impls/c.2/$($(1)) -chuck_STEP_TO_PROG = impls/chuck/$($(1)).ck -clojure_STEP_TO_PROG = $(clojure_STEP_TO_PROG_$(clojure_MODE)) -coffee_STEP_TO_PROG = impls/coffee/$($(1)).coffee -common-lisp_STEP_TO_PROG = impls/common-lisp/$($(1)) -cpp_STEP_TO_PROG = impls/cpp/$($(1)) -crystal_STEP_TO_PROG = impls/crystal/$($(1)) -cs_STEP_TO_PROG = impls/cs/$($(1)).exe -d_STEP_TO_PROG = impls/d/$($(1)) -dart_STEP_TO_PROG = impls/dart/$($(1)).dart -elisp_STEP_TO_PROG = impls/elisp/$($(1)).el -elixir_STEP_TO_PROG = impls/elixir/lib/mix/tasks/$($(1)).ex -elm_STEP_TO_PROG = impls/elm/$($(1)).js -erlang_STEP_TO_PROG = impls/erlang/$($(1)) -es6_STEP_TO_PROG = impls/es6/$($(1)).mjs -factor_STEP_TO_PROG = impls/factor/$($(1))/$($(1)).factor -fantom_STEP_TO_PROG = impls/fantom/lib/fan/$($(1)).pod -fennel_STEP_TO_PROG = impls/fennel/$($(1)).fnl -forth_STEP_TO_PROG = impls/forth/$($(1)).fs -fsharp_STEP_TO_PROG = impls/fsharp/$($(1)).exe -go_STEP_TO_PROG = impls/go/$($(1)) -groovy_STEP_TO_PROG = impls/groovy/$($(1)).groovy -gnu-smalltalk_STEP_TO_PROG = impls/gnu-smalltalk/$($(1)).st -guile_STEP_TO_PROG = impls/guile/$($(1)).scm -haskell_STEP_TO_PROG = impls/haskell/$($(1)) -haxe_STEP_TO_PROG = $(haxe_STEP_TO_PROG_$(haxe_MODE)) -hy_STEP_TO_PROG = impls/hy/$($(1)).hy -io_STEP_TO_PROG = impls/io/$($(1)).io -janet_STEP_TO_PROG = impls/janet/$($(1)).janet -java_STEP_TO_PROG = impls/java/target/classes/mal/$($(1)).class -java-truffle_STEP_TO_PROG = impls/java-truffle/build/classes/java/main/truffle/mal/$($(1)).class -js_STEP_TO_PROG = impls/js/$($(1)).js -jq_STEP_PROG = impls/jq/$($(1)).jq -julia_STEP_TO_PROG = impls/julia/$($(1)).jl -kotlin_STEP_TO_PROG = impls/kotlin/$($(1)).jar -livescript_STEP_TO_PROG = impls/livescript/$($(1)).js -logo_STEP_TO_PROG = impls/logo/$($(1)).lg -lua_STEP_TO_PROG = impls/lua/$($(1)).lua -make_STEP_TO_PROG = impls/make/$($(1)).mk -mal_STEP_TO_PROG = impls/mal/$($(1)).mal -matlab_STEP_TO_PROG = impls/matlab/$($(1)).m -miniMAL_STEP_TO_PROG = impls/miniMAL/$($(1)).json -nasm_STEP_TO_PROG = impls/nasm/$($(1)) -nim_STEP_TO_PROG = impls/nim/$($(1)) -objc_STEP_TO_PROG = impls/objc/$($(1)) -objpascal_STEP_TO_PROG = impls/objpascal/$($(1)) -ocaml_STEP_TO_PROG = impls/ocaml/$($(1)) -perl_STEP_TO_PROG = impls/perl/$($(1)).pl -perl6_STEP_TO_PROG = impls/perl6/$($(1)).pl -php_STEP_TO_PROG = impls/php/$($(1)).php -picolisp_STEP_TO_PROG = impls/picolisp/$($(1)).l -pike_STEP_TO_PROG = impls/pike/$($(1)).pike -plpgsql_STEP_TO_PROG = impls/plpgsql/$($(1)).sql -plsql_STEP_TO_PROG = impls/plsql/$($(1)).sql -powershell_STEP_TO_PROG = impls/powershell/$($(1)).ps1 -prolog_STEP_TO_PROG = impls/prolog/$($(1)).pl -ps_STEP_TO_PROG = impls/ps/$($(1)).ps -purs_STEP_TO_PROG = impls/purs/$($(1)).js -python_STEP_TO_PROG = impls/python/$($(1)).py -python.2_STEP_TO_PROG = impls/python.2/$($(1)).py -r_STEP_TO_PROG = impls/r/$($(1)).r -racket_STEP_TO_PROG = impls/racket/$($(1)).rkt -rexx_STEP_TO_PROG = impls/rexx/$($(1)).rexxpp -rpython_STEP_TO_PROG = impls/rpython/$($(1)) -ruby_STEP_TO_PROG = impls/ruby/$($(1)).rb -ruby.2_STEP_TO_PROG = impls/ruby.2/$($(1)).rb -rust_STEP_TO_PROG = impls/rust/$($(1)) -scala_STEP_TO_PROG = impls/scala/target/scala-2.11/classes/$($(1)).class -scheme_STEP_TO_PROG = $(scheme_STEP_TO_PROG_$(scheme_MODE)) -skew_STEP_TO_PROG = impls/skew/$($(1)).js -sml_STEP_TO_PROG = impls/sml/$($(1)) -swift_STEP_TO_PROG = impls/swift/$($(1)) -swift3_STEP_TO_PROG = impls/swift3/$($(1)) -swift4_STEP_TO_PROG = impls/swift4/$($(1)) -swift5_STEP_TO_PROG = impls/swift5/$($(1)) -tcl_STEP_TO_PROG = impls/tcl/$($(1)).tcl -ts_STEP_TO_PROG = impls/ts/$($(1)).js -vala_STEP_TO_PROG = impls/vala/$($(1)) -vb_STEP_TO_PROG = impls/vb/$($(1)).exe -vhdl_STEP_TO_PROG = impls/vhdl/$($(1)) -vimscript_STEP_TO_PROG = impls/vimscript/$($(1)).vim -wasm_STEP_TO_PROG = impls/wasm/$($(1)).$(if $(filter lucet,$(wasm_MODE)),so,wasm) -wren_STEP_TO_PROG = impls/wren/$($(1)).wren -yorick_STEP_TO_PROG = impls/yorick/$($(1)).i -xslt_STEP_TO_PROG = impls/xslt/$($(1)) -zig_STEP_TO_PROG = impls/zig/$($(1)) +# HOWTO add a new implementation (named "foo"): +# - Add "foo" to the IMPLS variable (alphabetical order) +# - Add a new "foo_STEP_TO_PROG" variable. +# - Add an "impls/foo/run" script. +# - Add an "impls/foo/Makefile" +# - Add an "impls/foo/Dockerfile" +# - Implement each step in "impls/foo/". + +# +# Implementation specific command line settings +# + +# cbm or qbasic +basic_MODE = cbm +# clj or cljs (Clojure vs ClojureScript/lumo) +clojure_MODE = clj +# gdc, ldc2, or dmd +d_MODE = gdc +# python, js, cpp, or neko +haxe_MODE = neko +# octave or matlab +matlab_MODE = octave +# python, python2 or python3 +python_MODE = python +# scheme (chibi, kawa, gauche, chicken, sagittarius, cyclone, foment) +scheme_MODE = chibi +# sml (polyml, mlton, mosml) +sml_MODE = polyml +# wasmtime wasmer lucet wax node warpy wace_libc +wasm_MODE = wasmtime + + +# +# Implementation specific settings +# + +IMPLS = ada ada.2 awk bash basic bbc-basic c c.2 chuck clojure coffee common-lisp cpp crystal cs d dart \ + elisp elixir elm erlang es6 factor fantom fennel forth fsharp go groovy gnu-smalltalk \ + guile haskell haxe hy io janet java java-truffle js jq julia kotlin livescript logo lua make mal \ + matlab miniMAL nasm nim objc objpascal ocaml perl perl6 php picolisp pike plpgsql \ + plsql powershell prolog ps purs python python.2 r racket rexx rpython ruby ruby.2 rust scala scheme skew sml \ + swift swift3 swift4 swift5 tcl ts vala vb vhdl vimscript wasm wren yorick xslt zig + +step5_EXCLUDES += bash # never completes at 10,000 +step5_EXCLUDES += basic # too slow, and limited to ints of 2^16 +step5_EXCLUDES += logo # too slow for 10,000 +step5_EXCLUDES += make # no TCO capability (iteration or recursion) +step5_EXCLUDES += mal # host impl dependent +step5_EXCLUDES += matlab # never completes at 10,000 +step5_EXCLUDES += plpgsql # too slow for 10,000 +step5_EXCLUDES += plsql # too slow for 10,000 +step5_EXCLUDES += powershell # too slow for 10,000 +step5_EXCLUDES += prolog # no iteration (but interpreter does TCO implicitly) +step5_EXCLUDES += sml # not implemented :( +step5_EXCLUDES += $(if $(filter cpp,$(haxe_MODE)),haxe,) # cpp finishes 10,000, segfaults at 100,000 +step5_EXCLUDES += xslt # iteration cannot be expressed + +dist_EXCLUDES += mal +# TODO: still need to implement dist +dist_EXCLUDES += guile io julia matlab swift + + +# Extra options to pass to runtest.py +bbc-basic_TEST_OPTS = --test-timeout 60 +guile_TEST_OPTS = --test-timeout 120 +io_TEST_OPTS = --test-timeout 120 +java-truffle_TEST_OPTS = --start-timeout 30 +logo_TEST_OPTS = --start-timeout 60 --test-timeout 120 +mal_TEST_OPTS = --start-timeout 60 --test-timeout 120 +miniMAL_TEST_OPTS = --start-timeout 60 --test-timeout 120 +perl6_TEST_OPTS = --test-timeout=60 +plpgsql_TEST_OPTS = --start-timeout 60 --test-timeout 180 +plsql_TEST_OPTS = --start-timeout 120 --test-timeout 120 +vimscript_TEST_OPTS = --test-timeout 30 +ifeq ($(MAL_IMPL),vimscript) +mal_TEST_OPTS = --start-timeout 60 --test-timeout 180 +else ifeq ($(MAL_IMPL),powershell) +mal_TEST_OPTS = --start-timeout 60 --test-timeout 180 +endif +xslt_TEST_OPTS = --test-timeout 120 + + +# +# Implementation specific utility functions +# + +basic_STEP_TO_PROG_cbm = impls/basic/$($(1)).bas +basic_STEP_TO_PROG_qbasic = impls/basic/$($(1)) + +clojure_STEP_TO_PROG_clj = impls/clojure/target/$($(1)).jar +clojure_STEP_TO_PROG_cljs = impls/clojure/src/mal/$($(1)).cljc + +haxe_STEP_TO_PROG_neko = impls/haxe/$($(1)).n +haxe_STEP_TO_PROG_python = impls/haxe/$($(1)).py +haxe_STEP_TO_PROG_cpp = impls/haxe/cpp/$($(1)) +haxe_STEP_TO_PROG_js = impls/haxe/$($(1)).js + +scheme_STEP_TO_PROG_chibi = impls/scheme/$($(1)).scm +scheme_STEP_TO_PROG_kawa = impls/scheme/out/$($(1)).class +scheme_STEP_TO_PROG_gauche = impls/scheme/$($(1)).scm +scheme_STEP_TO_PROG_chicken = impls/scheme/$($(1)) +scheme_STEP_TO_PROG_sagittarius = impls/scheme/$($(1)).scm +scheme_STEP_TO_PROG_cyclone = impls/scheme/$($(1)) +scheme_STEP_TO_PROG_foment = impls/scheme/$($(1)).scm + +# Map of step (e.g. "step8") to executable file for that step +ada_STEP_TO_PROG = impls/ada/$($(1)) +ada.2_STEP_TO_PROG = impls/ada.2/$($(1)) +awk_STEP_TO_PROG = impls/awk/$($(1)).awk +bash_STEP_TO_PROG = impls/bash/$($(1)).sh +basic_STEP_TO_PROG = $(basic_STEP_TO_PROG_$(basic_MODE)) +bbc-basic_STEP_TO_PROG = impls/bbc-basic/$($(1)).bas +c_STEP_TO_PROG = impls/c/$($(1)) +c.2_STEP_TO_PROG = impls/c.2/$($(1)) +chuck_STEP_TO_PROG = impls/chuck/$($(1)).ck +clojure_STEP_TO_PROG = $(clojure_STEP_TO_PROG_$(clojure_MODE)) +coffee_STEP_TO_PROG = impls/coffee/$($(1)).coffee +common-lisp_STEP_TO_PROG = impls/common-lisp/$($(1)) +cpp_STEP_TO_PROG = impls/cpp/$($(1)) +crystal_STEP_TO_PROG = impls/crystal/$($(1)) +cs_STEP_TO_PROG = impls/cs/$($(1)).exe +d_STEP_TO_PROG = impls/d/$($(1)) +dart_STEP_TO_PROG = impls/dart/$($(1)).dart +elisp_STEP_TO_PROG = impls/elisp/$($(1)).el +elixir_STEP_TO_PROG = impls/elixir/lib/mix/tasks/$($(1)).ex +elm_STEP_TO_PROG = impls/elm/$($(1)).js +erlang_STEP_TO_PROG = impls/erlang/$($(1)) +es6_STEP_TO_PROG = impls/es6/$($(1)).mjs +factor_STEP_TO_PROG = impls/factor/$($(1))/$($(1)).factor +fantom_STEP_TO_PROG = impls/fantom/lib/fan/$($(1)).pod +fennel_STEP_TO_PROG = impls/fennel/$($(1)).fnl +forth_STEP_TO_PROG = impls/forth/$($(1)).fs +fsharp_STEP_TO_PROG = impls/fsharp/$($(1)).exe +go_STEP_TO_PROG = impls/go/$($(1)) +groovy_STEP_TO_PROG = impls/groovy/$($(1)).groovy +gnu-smalltalk_STEP_TO_PROG = impls/gnu-smalltalk/$($(1)).st +guile_STEP_TO_PROG = impls/guile/$($(1)).scm +haskell_STEP_TO_PROG = impls/haskell/$($(1)) +haxe_STEP_TO_PROG = $(haxe_STEP_TO_PROG_$(haxe_MODE)) +hy_STEP_TO_PROG = impls/hy/$($(1)).hy +io_STEP_TO_PROG = impls/io/$($(1)).io +janet_STEP_TO_PROG = impls/janet/$($(1)).janet +java_STEP_TO_PROG = impls/java/target/classes/mal/$($(1)).class +java-truffle_STEP_TO_PROG = impls/java-truffle/build/classes/java/main/truffle/mal/$($(1)).class +js_STEP_TO_PROG = impls/js/$($(1)).js +jq_STEP_PROG = impls/jq/$($(1)).jq +julia_STEP_TO_PROG = impls/julia/$($(1)).jl +kotlin_STEP_TO_PROG = impls/kotlin/$($(1)).jar +livescript_STEP_TO_PROG = impls/livescript/$($(1)).js +logo_STEP_TO_PROG = impls/logo/$($(1)).lg +lua_STEP_TO_PROG = impls/lua/$($(1)).lua +make_STEP_TO_PROG = impls/make/$($(1)).mk +mal_STEP_TO_PROG = impls/mal/$($(1)).mal +matlab_STEP_TO_PROG = impls/matlab/$($(1)).m +miniMAL_STEP_TO_PROG = impls/miniMAL/$($(1)).json +nasm_STEP_TO_PROG = impls/nasm/$($(1)) +nim_STEP_TO_PROG = impls/nim/$($(1)) +objc_STEP_TO_PROG = impls/objc/$($(1)) +objpascal_STEP_TO_PROG = impls/objpascal/$($(1)) +ocaml_STEP_TO_PROG = impls/ocaml/$($(1)) +perl_STEP_TO_PROG = impls/perl/$($(1)).pl +perl6_STEP_TO_PROG = impls/perl6/$($(1)).pl +php_STEP_TO_PROG = impls/php/$($(1)).php +picolisp_STEP_TO_PROG = impls/picolisp/$($(1)).l +pike_STEP_TO_PROG = impls/pike/$($(1)).pike +plpgsql_STEP_TO_PROG = impls/plpgsql/$($(1)).sql +plsql_STEP_TO_PROG = impls/plsql/$($(1)).sql +powershell_STEP_TO_PROG = impls/powershell/$($(1)).ps1 +prolog_STEP_TO_PROG = impls/prolog/$($(1)).pl +ps_STEP_TO_PROG = impls/ps/$($(1)).ps +purs_STEP_TO_PROG = impls/purs/$($(1)).js +python_STEP_TO_PROG = impls/python/$($(1)).py +python.2_STEP_TO_PROG = impls/python.2/$($(1)).py +r_STEP_TO_PROG = impls/r/$($(1)).r +racket_STEP_TO_PROG = impls/racket/$($(1)).rkt +rexx_STEP_TO_PROG = impls/rexx/$($(1)).rexxpp +rpython_STEP_TO_PROG = impls/rpython/$($(1)) +ruby_STEP_TO_PROG = impls/ruby/$($(1)).rb +ruby.2_STEP_TO_PROG = impls/ruby.2/$($(1)).rb +rust_STEP_TO_PROG = impls/rust/$($(1)) +scala_STEP_TO_PROG = impls/scala/target/scala-2.11/classes/$($(1)).class +scheme_STEP_TO_PROG = $(scheme_STEP_TO_PROG_$(scheme_MODE)) +skew_STEP_TO_PROG = impls/skew/$($(1)).js +sml_STEP_TO_PROG = impls/sml/$($(1)) +swift_STEP_TO_PROG = impls/swift/$($(1)) +swift3_STEP_TO_PROG = impls/swift3/$($(1)) +swift4_STEP_TO_PROG = impls/swift4/$($(1)) +swift5_STEP_TO_PROG = impls/swift5/$($(1)) +tcl_STEP_TO_PROG = impls/tcl/$($(1)).tcl +ts_STEP_TO_PROG = impls/ts/$($(1)).js +vala_STEP_TO_PROG = impls/vala/$($(1)) +vb_STEP_TO_PROG = impls/vb/$($(1)).exe +vhdl_STEP_TO_PROG = impls/vhdl/$($(1)) +vimscript_STEP_TO_PROG = impls/vimscript/$($(1)).vim +wasm_STEP_TO_PROG = impls/wasm/$($(1)).$(if $(filter lucet,$(wasm_MODE)),so,wasm) +wren_STEP_TO_PROG = impls/wren/$($(1)).wren +yorick_STEP_TO_PROG = impls/yorick/$($(1)).i +xslt_STEP_TO_PROG = impls/xslt/$($(1)) +zig_STEP_TO_PROG = impls/zig/$($(1)) diff --git a/README.md b/README.md index f16b1d4de0..e3c9cf3d70 100644 --- a/README.md +++ b/README.md @@ -1,1481 +1,1481 @@ -# mal - Make a Lisp - -[![Build Status](https://travis-ci.org/kanaka/mal.svg?branch=master)](https://travis-ci.org/kanaka/mal) - -## Description - -**1. Mal is a Clojure inspired Lisp interpreter** - -**2. Mal is a learning tool** - -Each implementation of mal is separated into -11 incremental, self-contained (and testable) steps that demonstrate -core concepts of Lisp. The last step is capable of self-hosting -(running the mal implementation of mal). See the [make-a-lisp process -guide](process/guide.md). - -The make-a-lisp steps are: - -* [step0_repl](process/guide.md#step0) -* [step1_read_print](process/guide.md#step1) -* [step2_eval](process/guide.md#step2) -* [step3_env](process/guide.md#step3) -* [step4_if_fn_do](process/guide.md#step4) -* [step5_tco](process/guide.md#step5) -* [step6_file](process/guide.md#step6) -* [step7_quote](process/guide.md#step7) -* [step8_macros](process/guide.md#step8) -* [step9_try](process/guide.md#step9) -* [stepA_mal](process/guide.md#stepA) - -Each make-a-lisp step has an associated architectural diagram. That elements -that are new for that step are highlighted in red. -Here is the final diagram for [step A](process/guide.md#stepA): - -![stepA_mal architecture](process/stepA_mal.png) - -If you are interested in creating a mal implementation (or just -interested in using mal for something), you are welcome to to join our -[Discord](https://discord.gg/CKgnNbJBpF) or join #mal on -[libera.chat](https://libera.chat/). In addition to the [make-a-lisp -process guide](process/guide.md) there is also a [mal/make-a-lisp -FAQ](docs/FAQ.md) where I attempt to answer some common questions. - - -**3. Mal is implemented in 87 languages (93 different implementations and 115 runtime modes)** - -| Language | Creator | -| -------- | ------- | -| [Ada](#ada) | [Chris Moore](https://github.com/zmower) | -| [Ada #2](#ada2) | [Nicolas Boulenguez](https://github.com/asarhaddon) | -| [GNU Awk](#gnu-awk) | [Miutsuru Kariya](https://github.com/kariya-mitsuru) | -| [Bash 4](#bash-4) | [Joel Martin](https://github.com/kanaka) | -| [BASIC](#basic-c64-and-qbasic) (C64 & QBasic) | [Joel Martin](https://github.com/kanaka) | -| [BBC BASIC V](#bbc-basic-v) | [Ben Harris](https://github.com/bjh21) | -| [C](#c) | [Joel Martin](https://github.com/kanaka) | -| [C #2](#c2) | [Duncan Watts](https://github.com/fungiblecog) | -| [C++](#c-1) | [Stephen Thirlwall](https://github.com/sdt) | -| [C#](#c-2) | [Joel Martin](https://github.com/kanaka) | -| [ChucK](#chuck) | [Vasilij Schneidermann](https://github.com/wasamasa) | -| [Clojure](#clojure) (Clojure & ClojureScript) | [Joel Martin](https://github.com/kanaka) | -| [CoffeeScript](#coffeescript) | [Joel Martin](https://github.com/kanaka) | -| [Common Lisp](#common-lisp) | [Iqbal Ansari](https://github.com/iqbalansari) | -| [Crystal](#crystal) | [Linda_pp](https://github.com/rhysd) | -| [D](#d) | [Dov Murik](https://github.com/dubek) | -| [Dart](#dart) | [Harry Terkelsen](https://github.com/hterkelsen) | -| [Elixir](#elixir) | [Martin Ek](https://github.com/ekmartin) | -| [Elm](#elm) | [Jos van Bakel](https://github.com/c0deaddict) | -| [Emacs Lisp](#emacs-lisp) | [Vasilij Schneidermann](https://github.com/wasamasa) | -| [Erlang](#erlang) | [Nathan Fiedler](https://github.com/nlfiedler) | -| [ES6](#es6-ecmascript-2015) (ECMAScript 2015) | [Joel Martin](https://github.com/kanaka) | -| [F#](#f) | [Peter Stephens](https://github.com/pstephens) | -| [Factor](#factor) | [Jordan Lewis](https://github.com/jordanlewis) | -| [Fantom](#fantom) | [Dov Murik](https://github.com/dubek) | -| [Fennel](#fennel) | [sogaiu](https://github.com/sogaiu) | -| [Forth](#forth) | [Chris Houser](https://github.com/chouser) | -| [GNU Guile](#gnu-guile-21) | [Mu Lei](https://github.com/NalaGinrut) | -| [GNU Smalltalk](#gnu-smalltalk) | [Vasilij Schneidermann](https://github.com/wasamasa) | -| [Go](#go) | [Joel Martin](https://github.com/kanaka) | -| [Groovy](#groovy) | [Joel Martin](https://github.com/kanaka) | -| [Haskell](#haskell) | [Joel Martin](https://github.com/kanaka) | -| [Haxe](#haxe-neko-python-c-and-javascript) (Neko, Python, C++, & JS) | [Joel Martin](https://github.com/kanaka) | -| [Hy](#hy) | [Joel Martin](https://github.com/kanaka) | -| [Io](#io) | [Dov Murik](https://github.com/dubek) | -| [Janet](#janet) | [sogaiu](https://github.com/sogaiu) | -| [Java](#java-17) | [Joel Martin](https://github.com/kanaka) | -| [Java](#java-using-truffle-for-graalvm) (Truffle/GraalVM) | [Matt McGill](https://github.com/mmcgill) -| [JavaScript](#javascriptnode) ([Demo](http://kanaka.github.io/mal)) | [Joel Martin](https://github.com/kanaka) | -| [jq](#jq) | [Ali MohammadPur](https://github.com/alimpfard) | -| [Julia](#julia) | [Joel Martin](https://github.com/kanaka) | -| [Kotlin](#kotlin) | [Javier Fernandez-Ivern](https://github.com/ivern) | -| [LiveScript](#livescript) | [Jos van Bakel](https://github.com/c0deaddict) | -| [Logo](#logo) | [Dov Murik](https://github.com/dubek) | -| [Lua](#lua) | [Joel Martin](https://github.com/kanaka) | -| [GNU Make](#gnu-make-381) | [Joel Martin](https://github.com/kanaka) | -| [mal itself](#mal) | [Joel Martin](https://github.com/kanaka) | -| [MATLAB](#matlab-gnu-octave-and-matlab) (GNU Octave & MATLAB) | [Joel Martin](https://github.com/kanaka) | -| [miniMAL](#minimal) ([Repo](https://github.com/kanaka/miniMAL), [Demo](https://kanaka.github.io/miniMAL/)) | [Joel Martin](https://github.com/kanaka) | -| [NASM](#nasm) | [Ben Dudson](https://github.com/bendudson) | -| [Nim](#nim-104) | [Dennis Felsing](https://github.com/def-) | -| [Object Pascal](#object-pascal) | [Joel Martin](https://github.com/kanaka) | -| [Objective C](#objective-c) | [Joel Martin](https://github.com/kanaka) | -| [OCaml](#ocaml-4010) | [Chris Houser](https://github.com/chouser) | -| [Perl](#perl-5) | [Joel Martin](https://github.com/kanaka) | -| [Perl 6](#perl-6) | [Hinrik Örn Sigurðsson](https://github.com/hinrik) | -| [PHP](#php-53) | [Joel Martin](https://github.com/kanaka) | -| [Picolisp](#picolisp) | [Vasilij Schneidermann](https://github.com/wasamasa) | -| [Pike](#pike) | [Dov Murik](https://github.com/dubek) | -| [PL/pgSQL](#plpgsql-postgresql-sql-procedural-language) (PostgreSQL) | [Joel Martin](https://github.com/kanaka) | -| [PL/SQL](#plsql-oracle-sql-procedural-language) (Oracle) | [Joel Martin](https://github.com/kanaka) | -| [PostScript](#postscript-level-23) | [Joel Martin](https://github.com/kanaka) | -| [PowerShell](#powershell) | [Joel Martin](https://github.com/kanaka) | -| [Prolog](#prolog-logical-language) | [Nicolas Boulenguez](https://github.com/asarhaddon) | -| [PureScript](#purescript) | [mrsekut](https://github.com/mrsekut) | -| [Python](#python-2x-and-3x) (2.X & 3.X) | [Joel Martin](https://github.com/kanaka) | -| [Python #2](#python2-3x) (3.X) | [Gavin Lewis](https://github.com/epylar) | -| [RPython](#rpython) | [Joel Martin](https://github.com/kanaka) | -| [R](#r) | [Joel Martin](https://github.com/kanaka) | -| [Racket](#racket-53) | [Joel Martin](https://github.com/kanaka) | -| [Rexx](#rexx) | [Dov Murik](https://github.com/dubek) | -| [Ruby](#ruby-19) | [Joel Martin](https://github.com/kanaka) | -| [Ruby #2](#ruby) | [Ryan Cook](https://github.com/cookrn) | -| [Rust](#rust-138) | [Joel Martin](https://github.com/kanaka) | -| [Scala](#scala) | [Joel Martin](https://github.com/kanaka) | -| [Scheme (R7RS)](#scheme-r7rs) | [Vasilij Schneidermann](https://github.com/wasamasa) | -| [Skew](#skew) | [Dov Murik](https://github.com/dubek) | -| [Standard ML](#sml) | [Fabian Bergström](https://github.com/fabjan) | -| [Swift 2](#swift) | [Keith Rollin](https://github.com/keith-rollin) | -| [Swift 3](#swift-3) | [Joel Martin](https://github.com/kanaka) | -| [Swift 4](#swift-4) | [陆遥](https://github.com/LispLY) | -| [Swift 5](#swift-5) | [Oleg Montak](https://github.com/MontakOleg) | -| [Tcl](#tcl-86) | [Dov Murik](https://github.com/dubek) | -| [TypeScript](#typescript) | [Masahiro Wakame](https://github.com/vvakame) | -| [Vala](#vala) | [Simon Tatham](https://github.com/sgtatham) | -| [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) | -| [Yorick](#yorick) | [Dov Murik](https://github.com/dubek) | -| [Zig](#zig) | [Josh Tobin](https://github.com/rjtobin) | - - -## Presentations - -Mal was presented publicly for the first time in a lightning talk at -Clojure West 2014 (unfortunately there is no video). See -examples/clojurewest2014.mal for the presentation that was given at the -conference (yes, the presentation is a mal program). - -At Midwest.io 2015, Joel Martin gave a presentation on Mal titled -"Achievement Unlocked: A Better Path to Language Learning". -[Video](https://www.youtube.com/watch?v=lgyOAiRtZGw), -[Slides](http://kanaka.github.io/midwest.io.mal/). - -More recently Joel gave a presentation on "Make Your Own Lisp Interpreter -in 10 Incremental Steps" at LambdaConf 2016: -[Part 1](https://www.youtube.com/watch?v=jVhupfthTEk), -[Part 2](https://www.youtube.com/watch?v=X5OQBMGpaTU), -[Part 3](https://www.youtube.com/watch?v=6mARZzGgX4U), -[Part 4](https://www.youtube.com/watch?v=dCO1SYR5kDU), -[Slides](http://kanaka.github.io/lambdaconf/). - -## Building/running implementations - -The simplest way to run any given implementation is to use docker. -Every implementation has a docker image pre-built with language -dependencies installed. You can launch the REPL using a convenient -target in the top level Makefile (where IMPL is the implementation -directory name and stepX is the step to run): - -``` -make DOCKERIZE=1 "repl^IMPL^stepX" - # OR stepA is the default step: -make DOCKERIZE=1 "repl^IMPL" -``` - -## External Implementations - -The following implementations are maintained as separate projects: - -### HolyC - -* [by Alexander Bagnalla](https://github.com/bagnalla/holyc_mal) - -### Rust - -* [by Tim Morgan](https://github.com/seven1m/mal-rust) -* [by vi](https://github.com/vi/mal-rust-vi) - using [Pest](https://pest.rs/) grammar, not using typical Mal infrastructure (cargo-ized steps and built-in converted tests). - -### Q - -* [by Ali Mohammad Pur](https://github.com/alimpfard/mal/tree/q/impls/q) - The Q implementation works fine but it requires a proprietary manual download that can't be Dockerized (or integrated into the mal CI pipeline) so for now it remains a separate project. - - -## Other mal Projects - - * [malc](https://github.com/dubek/malc) - Mal (Make A Lisp) compiler. Compiles a Mal program to LLVM assembly language, then binary. - * [malcc](https://github.com/seven1m/malcc) - malcc is an incremental compiler implementation for the Mal language. It uses the Tiny C Compiler as the compiler backend and has full support for the Mal language, including macros, tail-call elimination, and even run-time eval. ["I Built a Lisp Compiler"](https://mpov.timmorgan.org/i-built-a-lisp-compiler/) post about the process. - * [frock](https://github.com/chr15m/frock) - Clojure-flavoured PHP. Uses mal/php to run programs. - * [flk](https://github.com/chr15m/flk) - A LISP that runs wherever Bash is - * [glisp](https://github.com/baku89/glisp) - Self-bootstrapping graphic design tool on Lisp. [Live Demo](https://baku89.com/glisp/) - - -## Implementation Details - -### Ada - -The Ada implementation was developed with GNAT 4.9 on debian. It also -compiles unchanged on windows if you have windows versions of git, -GNAT and (optionally) make. There are no external dependencies -(readline not implemented). - -``` -cd impls/ada -make -./stepX_YYY -``` - -### Ada.2 - -The second Ada implementation was developed with GNAT 8 and links with -the GNU readline library. - -``` -cd impls/ada -make -./stepX_YYY -``` - -### GNU awk - -The GNU awk implementation of mal has been tested with GNU awk 4.1.1. - -``` -cd impls/gawk -gawk -O -f stepX_YYY.awk -``` - -### Bash 4 - -``` -cd impls/bash -bash stepX_YYY.sh -``` - -### BASIC (C64 and QBasic) - -The BASIC implementation uses a preprocessor that can generate BASIC -code that is compatible with both C64 BASIC (CBM v2) and QBasic. The -C64 mode has been tested with -[cbmbasic](https://github.com/kanaka/cbmbasic) (the patched version is -currently required to fix issues with line input) and the QBasic mode -has been tested with [qb64](http://www.qb64.net/). - -Generate C64 code and run it using cbmbasic: - -``` -cd impls/basic -make stepX_YYY.bas -STEP=stepX_YYY ./run -``` - -Generate QBasic code and load it into qb64: - -``` -cd impls/basic -make MODE=qbasic stepX_YYY.bas -./qb64 stepX_YYY.bas -``` - -Thanks to [Steven Syrek](https://github.com/sjsyrek) for the original -inspiration for this implementation. - -### BBC BASIC V - -The BBC BASIC V implementation can run in the Brandy interpreter: - -``` -cd impls/bbc-basic -brandy -quit stepX_YYY.bbc -``` - -Or in ARM BBC BASIC V under RISC OS 3 or later: - -``` -*Dir bbc-basic.riscos -*Run setup -*Run stepX_YYY -``` - -### C - -The C implementation of mal requires the following libraries (lib and -header packages): glib, libffi6, libgc, and either the libedit or GNU readline -library. - -``` -cd impls/c -make -./stepX_YYY -``` - -### C.2 - -The second C implementation of mal requires the following libraries (lib and -header packages): libedit, libgc, libdl, and libffi. - -``` -cd impls/c.2 -make -./stepX_YYY -``` - - -### C++ - -The C++ implementation of mal requires g++-4.9 or clang++-3.5 and -a readline compatible library to build. See the `cpp/README.md` for -more details: - -``` -cd impls/cpp -make - # OR -make CXX=clang++-3.5 -./stepX_YYY -``` - - -### C# ### - -The C# implementation of mal has been tested on Linux using the Mono -C# compiler (mcs) and the Mono runtime (version 2.10.8.1). Both are -required to build and run the C# implementation. - -``` -cd impls/cs -make -mono ./stepX_YYY.exe -``` - -### ChucK - -The ChucK implementation has been tested with ChucK 1.3.5.2. - -``` -cd impls/chuck -./run -``` - -### Clojure - -For the most part the Clojure implementation requires Clojure 1.5, -however, to pass all tests, Clojure 1.8.0-RC4 is required. - -``` -cd impls/clojure -lein with-profile +stepX trampoline run -``` - -### CoffeeScript - -``` -sudo npm install -g coffee-script -cd impls/coffee -coffee ./stepX_YYY -``` - -### Common Lisp - -The implementation has been tested with SBCL, CCL, CMUCL, GNU CLISP, ECL and -Allegro CL on Ubuntu 16.04 and Ubuntu 12.04, see -the [README](impls/common-lisp/README.org) for more details. Provided you have the -dependencies mentioned installed, do the following to run the implementation - -``` -cd impls/common-lisp -make -./run -``` - -### Crystal - -The Crystal implementation of mal has been tested with Crystal 0.26.1. - -``` -cd impls/crystal -crystal run ./stepX_YYY.cr - # OR -make # needed to run tests -./stepX_YYY -``` - -### D - -The D implementation of mal was tested with GDC 4.8. It requires the GNU -readline library. - -``` -cd impls/d -make -./stepX_YYY -``` - -### Dart - -The Dart implementation has been tested with Dart 1.20. - -``` -cd impls/dart -dart ./stepX_YYY -``` - -### Emacs Lisp - -The Emacs Lisp implementation of mal has been tested with Emacs 24.3 -and 24.5. While there is very basic readline editing (`` -and `C-d` work, `C-c` cancels the process), it is recommended to use -`rlwrap`. - -``` -cd impls/elisp -emacs -Q --batch --load stepX_YYY.el -# with full readline support -rlwrap emacs -Q --batch --load stepX_YYY.el -``` - -### Elixir - -The Elixir implementation of mal has been tested with Elixir 1.0.5. - -``` -cd impls/elixir -mix stepX_YYY -# Or with readline/line editing functionality: -iex -S mix stepX_YYY -``` - -### Elm - -The Elm implementation of mal has been tested with Elm 0.18.0 - -``` -cd impls/elm -make stepX_YYY.js -STEP=stepX_YYY ./run -``` - -### Erlang - -The Erlang implementation of mal requires [Erlang/OTP R17](http://www.erlang.org/download.html) -and [rebar](https://github.com/rebar/rebar) to build. - -``` -cd impls/erlang -make - # OR -MAL_STEP=stepX_YYY rebar compile escriptize # build individual step -./stepX_YYY -``` - -### ES6 (ECMAScript 2015) - -The ES6 / ECMAScript 2015 implementation uses the -[babel](https://babeljs.io) compiler to generate ES5 compatible -JavaScript. The generated code has been tested with Node 0.12.4. - -``` -cd impls/es6 -make -node build/stepX_YYY.js -``` - - -### F# ### - -The F# implementation of mal has been tested on Linux using the Mono -F# compiler (fsharpc) and the Mono runtime (version 3.12.1). The mono C# -compiler (mcs) is also necessary to compile the readline dependency. All are -required to build and run the F# implementation. - -``` -cd impls/fsharp -make -mono ./stepX_YYY.exe -``` - -### Factor - -The Factor implementation of mal has been tested with Factor 0.97 -([factorcode.org](http://factorcode.org)). - -``` -cd impls/factor -FACTOR_ROOTS=. factor -run=stepX_YYY -``` - -### Fantom - -The Fantom implementation of mal has been tested with Fantom 1.0.70. - -``` -cd impls/fantom -make lib/fan/stepX_YYY.pod -STEP=stepX_YYY ./run -``` - -### Fennel - -The Fennel implementation of mal has been tested with Fennel version -0.9.1 on Lua 5.4. - -``` -cd impls/fennel -fennel ./stepX_YYY.fnl -``` - -### Forth - -``` -cd impls/forth -gforth stepX_YYY.fs -``` - -### GNU Guile 2.1+ - -``` -cd impls/guile -guile -L ./ stepX_YYY.scm -``` - -### GNU Smalltalk - -The Smalltalk implementation of mal has been tested with GNU Smalltalk 3.2.91. - -``` -cd impls/gnu-smalltalk -./run -``` - -### Go - -The Go implementation of mal requires that go is installed on on the -path. The implementation has been tested with Go 1.3.1. - -``` -cd impls/go -make -./stepX_YYY -``` - - -### Groovy - -The Groovy implementation of mal requires Groovy to run and has been -tested with Groovy 1.8.6. - -``` -cd impls/groovy -make -groovy ./stepX_YYY.groovy -``` - -### Haskell - -The Haskell implementation requires the ghc compiler version 7.10.1 or -later and also the Haskell parsec and readline (or editline) packages. - -``` -cd impls/haskell -make -./stepX_YYY -``` - -### Haxe (Neko, Python, C++ and JavaScript) - -The Haxe implementation of mal requires Haxe version 3.2 to compile. -Four different Haxe targets are supported: Neko, Python, C++, and -JavaScript. - -``` -cd impls/haxe -# Neko -make all-neko -neko ./stepX_YYY.n -# Python -make all-python -python3 ./stepX_YYY.py -# C++ -make all-cpp -./cpp/stepX_YYY -# JavaScript -make all-js -node ./stepX_YYY.js -``` - -### Hy - -The Hy implementation of mal has been tested with Hy 0.13.0. - -``` -cd impls/hy -./stepX_YYY.hy -``` - -### Io - -The Io implementation of mal has been tested with Io version 20110905. - -``` -cd impls/io -io ./stepX_YYY.io -``` - -### Janet - -The Janet implementation of mal has been tested with Janet version 1.12.2. - -``` -cd impls/janet -janet ./stepX_YYY.janet -``` - -### Java 1.7 - -The Java implementation of mal requires maven2 to build. - -``` -cd impls/java -mvn compile -mvn -quiet exec:java -Dexec.mainClass=mal.stepX_YYY - # OR -mvn -quiet exec:java -Dexec.mainClass=mal.stepX_YYY -Dexec.args="CMDLINE_ARGS" -``` - -### Java, using Truffle for GraalVM - -This Java implementation will run on OpenJDK, but can run -as much as 30x faster on GraalVM thanks to the Truffle framework. -It's been tested with OpenJDK 11, GraalVM CE 20.1.0, and -GraalVM CE 21.1.0. - -``` -cd impls/java-truffle -./gradlew build -STEP=stepX_YYY ./run -``` - -### JavaScript/Node - -``` -cd impls/js -npm install -node stepX_YYY.js -``` - -### Julia - -The Julia implementation of mal requires Julia 0.4. - -``` -cd impls/julia -julia stepX_YYY.jl -``` - -### jq - -Tested against version 1.6, with a lot of cheating in the IO department - -``` -cd impls/jq -STEP=stepA_YYY ./run - # with Debug -DEBUG=true STEP=stepA_YYY ./run -``` - -### Kotlin - -The Kotlin implementation of mal has been tested with Kotlin 1.0. - -``` -cd impls/kotlin -make -java -jar stepX_YYY.jar -``` - -### LiveScript - -The LiveScript implementation of mal has been tested with LiveScript 1.5. - -``` -cd impls/livescript -make -node_modules/.bin/lsc stepX_YYY.ls -``` - -### Logo - -The Logo implementation of mal has been tested with UCBLogo 6.0. - -``` -cd impls/logo -logo stepX_YYY.lg -``` - -### Lua - -The Lua implementation of mal has been tested with Lua 5.3.5 The -implementation requires luarocks to be installed. - -``` -cd impls/lua -make # to build and link linenoise.so and rex_pcre.so -./stepX_YYY.lua -``` - -### Mal - -Running the mal implementation of mal involves running stepA of one of -the other implementations and passing the mal step to run as a command -line argument. - -``` -cd impls/IMPL -IMPL_STEPA_CMD ../mal/stepX_YYY.mal - -``` - -### GNU Make 3.81 - -``` -cd impls/make -make -f stepX_YYY.mk -``` - -### NASM - -The NASM implementation of mal is written for x86-64 Linux, and has been tested -with Linux 3.16.0-4-amd64 and NASM version 2.11.05. - -``` -cd impls/nasm -make -./stepX_YYY -``` - -### Nim 1.0.4 - -The Nim implementation of mal has been tested with Nim 1.0.4. - -``` -cd impls/nim -make - # OR -nimble build -./stepX_YYY -``` - -### Object Pascal - -The Object Pascal implementation of mal has been built and tested on -Linux using the Free Pascal compiler version 2.6.2 and 2.6.4. - -``` -cd impls/objpascal -make -./stepX_YYY -``` - -### Objective C - -The Objective C implementation of mal has been built and tested on -Linux using clang/LLVM 3.6. It has also been built and tested on OS -X using XCode 7. - -``` -cd impls/objc -make -./stepX_YYY -``` - -### OCaml 4.01.0 - -``` -cd impls/ocaml -make -./stepX_YYY -``` - -### MATLAB (GNU Octave and MATLAB) - -The MatLab implementation has been tested with GNU Octave 4.2.1. -It has also been tested with MATLAB version R2014a on Linux. Note that -MATLAB is a commercial product. - -``` -cd impls/matlab -./stepX_YYY -octave -q --no-gui --no-history --eval "stepX_YYY();quit;" -matlab -nodisplay -nosplash -nodesktop -nojvm -r "stepX_YYY();quit;" - # OR with command line arguments -octave -q --no-gui --no-history --eval "stepX_YYY('arg1','arg2');quit;" -matlab -nodisplay -nosplash -nodesktop -nojvm -r "stepX_YYY('arg1','arg2');quit;" -``` - -### miniMAL - -[miniMAL](https://github.com/kanaka/miniMAL) is small Lisp interpreter -implemented in less than 1024 bytes of JavaScript. To run the miniMAL -implementation of mal you need to download/install the miniMAL -interpreter (which requires Node.js). -``` -cd impls/miniMAL -# Download miniMAL and dependencies -npm install -export PATH=`pwd`/node_modules/minimal-lisp/:$PATH -# Now run mal implementation in miniMAL -miniMAL ./stepX_YYY -``` - -### Perl 5 - -The Perl 5 implementation should work with perl 5.19.3 and later. - -For readline line editing support, install Term::ReadLine::Perl or -Term::ReadLine::Gnu from CPAN. - -``` -cd impls/perl -perl stepX_YYY.pl -``` - -### Perl 6 - -The Perl 6 implementation was tested on Rakudo Perl 6 2016.04. - -``` -cd impls/perl6 -perl6 stepX_YYY.pl -``` - -### PHP 5.3 - -The PHP implementation of mal requires the php command line interface -to run. - -``` -cd impls/php -php stepX_YYY.php -``` - -### Picolisp - -The Picolisp implementation requires libreadline and Picolisp 3.1.11 -or later. - -``` -cd impls/picolisp -./run -``` - -### Pike - -The Pike implementation was tested on Pike 8.0. - -``` -cd impls/pike -pike stepX_YYY.pike -``` - -### PL/pgSQL (PostgreSQL SQL Procedural Language) - -The PL/pgSQL implementation of mal requires a running PostgreSQL server -(the "kanaka/mal-test-plpgsql" docker image automatically starts -a PostgreSQL server). The implementation connects to the PostgreSQL server -and create a database named "mal" to store tables and stored -procedures. The wrapper script uses the psql command to connect to the -server and defaults to the user "postgres" but this can be overridden -with the PSQL_USER environment variable. A password can be specified -using the PGPASSWORD environment variable. The implementation has been -tested with PostgreSQL 9.4. - -``` -cd impls/plpgsql -./wrap.sh stepX_YYY.sql - # OR -PSQL_USER=myuser PGPASSWORD=mypass ./wrap.sh stepX_YYY.sql -``` - -### PL/SQL (Oracle SQL Procedural Language) - -The PL/SQL implementation of mal requires a running Oracle DB -server (the "kanaka/mal-test-plsql" docker image automatically -starts an Oracle Express server). The implementation connects to the -Oracle server to create types, tables and stored procedures. The -default SQL\*Plus logon value (username/password@connect_identifier) is -"system/oracle" but this can be overridden with the ORACLE_LOGON -environment variable. The implementation has been tested with Oracle -Express Edition 11g Release 2. Note that any SQL\*Plus connection -warnings (user password expiration, etc) will interfere with the -ability of the wrapper script to communicate with the DB. - -``` -cd impls/plsql -./wrap.sh stepX_YYY.sql - # OR -ORACLE_LOGON=myuser/mypass@ORCL ./wrap.sh stepX_YYY.sql -``` - -### PostScript Level 2/3 - -The PostScript implementation of mal requires Ghostscript to run. It -has been tested with Ghostscript 9.10. - -``` -cd impls/ps -gs -q -dNODISPLAY -I./ stepX_YYY.ps -``` - -### PowerShell - -The PowerShell implementation of mal requires the PowerShell script -language. It has been tested with PowerShell 6.0.0 Alpha 9 on Linux. - -``` -cd impls/powershell -powershell ./stepX_YYY.ps1 -``` - -### Prolog - -The Prolog implementation uses some constructs specific to SWI-Prolog, -includes readline support and has been tested on Debian GNU/Linux with -version 8.2.1. - -``` -cd impls/prolog -swipl stepX_YYY -``` - -### PureScript -The PureScript implementation requires the spago compiler version 0.20.2. - -``` -cd impls/purs -make -node ./stepX_YYY.js -``` - -### Python (2.X and 3.X) - -``` -cd impls/python -python stepX_YYY.py -``` - -### Python.2 (3.X) - -The second Python implementation makes heavy use of type annotations and uses the Arpeggio parser library. - -``` -# Recommended: do these steps in a Python virtual environment. -pip3 install Arpeggio==1.9.0 -python3 stepX_YYY.py -``` - -### RPython - -You must have [rpython](https://rpython.readthedocs.org/) on your path -(included with [pypy](https://bitbucket.org/pypy/pypy/)). - -``` -cd impls/rpython -make # this takes a very long time -./stepX_YYY -``` - -### R - -The R implementation of mal requires R (r-base-core) to run. - -``` -cd impls/r -make libs # to download and build rdyncall -Rscript stepX_YYY.r -``` - -### Racket (5.3) - -The Racket implementation of mal requires the Racket -compiler/interpreter to run. - -``` -cd impls/racket -./stepX_YYY.rkt -``` - -### Rexx - -The Rexx implementation of mal has been tested with Regina Rexx 3.6. - -``` -cd impls/rexx -make -rexx -a ./stepX_YYY.rexxpp -``` - -### Ruby (1.9+) - -``` -cd impls/ruby -ruby stepX_YYY.rb -``` - -### Ruby #2 - -A second Ruby implementation with the following goals: - -- No global variables -- No modification (monkey-patching) of core Ruby classes -- Modularized into the `Mal` module namespace - -``` -cd impls/ruby.2 -ruby stepX_YYY.rb -``` - -### Rust (1.38+) - -The rust implementation of mal requires the rust compiler and build -tool (cargo) to build. - -``` -cd impls/rust -cargo run --release --bin stepX_YYY -``` - -### Scala ### - -Install scala and sbt (http://www.scala-sbt.org/0.13/tutorial/Installing-sbt-on-Linux.html): - -``` -cd impls/scala -sbt 'run-main stepX_YYY' - # OR -sbt compile -scala -classpath target/scala*/classes stepX_YYY -``` - -### Scheme (R7RS) ### - -The Scheme implementation of MAL has been tested with Chibi-Scheme -0.10, Kawa 3.1.1, Gauche 0.9.6, CHICKEN 5.1.0, Sagittarius 0.9.7, -Cyclone 0.32.0 (Git version) and Foment 0.4 (Git version). You should -be able to get it running on other conforming R7RS implementations -after figuring out how libraries are loaded and adjusting the -`Makefile` and `run` script accordingly. - -``` -cd impls/scheme -# chibi -scheme_MODE=chibi ./run -# kawa -make kawa -scheme_MODE=kawa ./run -# gauche -scheme_MODE=gauche ./run -# chicken -make chicken -scheme_MODE=chicken ./run -# sagittarius -scheme_MODE=sagittarius ./run -# cyclone -make cyclone -scheme_MODE=cyclone ./run -# foment -scheme_MODE=foment ./run -``` - -### Skew ### - -The Skew implementation of mal has been tested with Skew 0.7.42. - -``` -cd impls/skew -make -node stepX_YYY.js -``` - - -### Standard ML (Poly/ML, MLton, Moscow ML) - -The Standard ML implementation of mal requires an -[SML97](https://github.com/SMLFamily/The-Definition-of-Standard-ML-Revised) -implementation. The Makefile supports Poly/ML, MLton, Moscow ML, and has -been tested with Poly/ML 5.8.1, MLton 20210117, and Moscow ML version 2.10. - -``` -cd impls/sml -# Poly/ML -make sml_MODE=polyml -./stepX_YYY -# MLton -make sml_MODE=mlton -./stepX_YYY -# Moscow ML -make sml_MODE=mosml -./stepX_YYY -``` - - -### Swift - -The Swift implementation of mal requires the Swift 2.0 compiler (XCode -7.0) to build. Older versions will not work due to changes in the -language and standard library. - -``` -cd impls/swift -make -./stepX_YYY -``` - -### Swift 3 - -The Swift 3 implementation of mal requires the Swift 3.0 compiler. It -has been tested with Swift 3 Preview 3. - -``` -cd impls/swift3 -make -./stepX_YYY -``` - -### Swift 4 - -The Swift 4 implementation of mal requires the Swift 4.0 compiler. It -has been tested with Swift 4.2.3 release. - -``` -cd impls/swift4 -make -./stepX_YYY -``` - -### Swift 5 - -The Swift 5 implementation of mal requires the Swift 5.0 compiler. It -has been tested with Swift 5.1.1 release. - -``` -cd impls/swift5 -swift run stepX_YYY -``` - -### Tcl 8.6 - -The Tcl implementation of mal requires Tcl 8.6 to run. For readline line -editing support, install tclreadline. - -``` -cd impls/tcl -tclsh ./stepX_YYY.tcl -``` - -### TypeScript - -The TypeScript implementation of mal requires the TypeScript 2.2 compiler. -It has been tested with Node.js v6. - -``` -cd impls/ts -make -node ./stepX_YYY.js -``` - -### Vala - -The Vala implementation of mal has been tested with the Vala 0.40.8 -compiler. You will need to install `valac` and `libreadline-dev` or -equivalent. - -``` -cd impls/vala -make -./stepX_YYY -``` - -### VHDL - -The VHDL implementation of mal has been tested with GHDL 0.29. - -``` -cd impls/vhdl -make -./run_vhdl.sh ./stepX_YYY -``` - -### Vimscript - -The Vimscript implementation of mal requires Vim 8.0 to run. - -``` -cd impls/vimscript -./run_vimscript.sh ./stepX_YYY.vim -``` - -### Visual Basic.NET ### - -The VB.NET implementation of mal has been tested on Linux using the Mono -VB compiler (vbnc) and the Mono runtime (version 2.10.8.1). Both are -required to build and run the VB.NET implementation. - -``` -cd impls/vb -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 -[Wam](https://github.com/kanaka/wam) (WebAssembly Macro language) and -runs under several different non-web embeddings (runtimes): -[node](https://nodejs.org), -[wasmtime](https://github.com/CraneStation/wasmtime), -[wasmer](https://wasmer.io), -[lucet](https://github.com/fastly/lucet), -[wax](https://github.com/kanaka/wac), -[wace](https://github.com/kanaka/wac), -[warpy](https://github.com/kanaka/warpy). - -``` -cd impls/wasm -# node -make wasm_MODE=node -./run.js ./stepX_YYY.wasm -# wasmtime -make wasm_MODE=wasmtime -wasmtime --dir=./ --dir=../ --dir=/ ./stepX_YYY.wasm -# wasmer -make wasm_MODE=wasmer -wasmer run --dir=./ --dir=../ --dir=/ ./stepX_YYY.wasm -# lucet -make wasm_MODE=lucet -lucet-wasi --dir=./:./ --dir=../:../ --dir=/:/ ./stepX_YYY.so -# wax -make wasm_MODE=wax -wax ./stepX_YYY.wasm -# wace -make wasm_MODE=wace_libc -wace ./stepX_YYY.wasm -# warpy -make wasm_MODE=warpy -warpy --argv --memory-pages 256 ./stepX_YYY.wasm -``` - -### XSLT - -The XSLT implementation of mal is written with XSLT 3 and tested on Saxon 9.9.1.6 Home Edition. - -``` -cd impls/xslt -STEP=stepX_YY ./run -``` - -### Wren - -The Wren implementation of mal was tested on Wren 0.2.0. - -``` -cd impls/wren -wren ./stepX_YYY.wren -``` - -### Yorick - -The Yorick implementation of mal was tested on Yorick 2.2.04. - -``` -cd impls/yorick -yorick -batch ./stepX_YYY.i -``` - -### Zig - -The Zig implementation of mal was tested on Zig 0.5. - -``` -cd impls/zig -zig build stepX_YYY -``` - - - -## Running tests - -The top level Makefile has a number of useful targets to assist with -implementation development and testing. The `help` target provides -a list of the targets and options: - -``` -make help -``` - -### Functional tests - -The are almost 800 generic functional tests (for all implementations) -in the `tests/` directory. Each step has a corresponding test file -containing tests specific to that step. The `runtest.py` test harness -launches a Mal step implementation and then feeds the tests one at -a time to the implementation and compares the output/return value to -the expected output/return value. - -* To run all the tests across all implementations (be prepared to wait): - -``` -make test -``` - -* To run all tests against a single implementation: - -``` -make "test^IMPL" - -# e.g. -make "test^clojure" -make "test^js" -``` - -* To run tests for a single step against all implementations: - -``` -make "test^stepX" - -# e.g. -make "test^step2" -make "test^step7" -``` - -* To run tests for a specific step against a single implementation: - -``` -make "test^IMPL^stepX" - -# e.g -make "test^ruby^step3" -make "test^ps^step4" -``` - -### Self-hosted functional tests - -* To run the functional tests in self-hosted mode, you specify `mal` - as the test implementation and use the `MAL_IMPL` make variable - to change the underlying host language (default is JavaScript): -``` -make MAL_IMPL=IMPL "test^mal^step2" - -# e.g. -make "test^mal^step2" # js is default -make MAL_IMPL=ruby "test^mal^step2" -make MAL_IMPL=python "test^mal^step2" -``` - -### Starting the REPL - -* To start the REPL of an implementation in a specific step: - -``` -make "repl^IMPL^stepX" - -# e.g -make "repl^ruby^step3" -make "repl^ps^step4" -``` - -* If you omit the step, then `stepA` is used: - -``` -make "repl^IMPL" - -# e.g -make "repl^ruby" -make "repl^ps" -``` - -* To start the REPL of the self-hosted implementation, specify `mal` as the - REPL implementation and use the `MAL_IMPL` make variable to change the - underlying host language (default is JavaScript): -``` -make MAL_IMPL=IMPL "repl^mal^stepX" - -# e.g. -make "repl^mal^step2" # js is default -make MAL_IMPL=ruby "repl^mal^step2" -make MAL_IMPL=python "repl^mal" -``` - -### Performance tests - -Warning: These performance tests are neither statistically valid nor -comprehensive; runtime performance is a not a primary goal of mal. If -you draw any serious conclusions from these performance tests, then -please contact me about some amazing oceanfront property in Kansas -that I'm willing to sell you for cheap. - -* To run performance tests against a single implementation: -``` -make "perf^IMPL" - -# e.g. -make "perf^js" -``` - -* To run performance tests against all implementations: -``` -make "perf" -``` - -### Generating language statistics - -* To report line and byte statistics for a single implementation: -``` -make "stats^IMPL" - -# e.g. -make "stats^js" -``` - -## Dockerized testing - -Every implementation directory contains a Dockerfile to create -a docker image containing all the dependencies for that -implementation. In addition, the top-level Makefile contains support -for running the tests target (and perf, stats, repl, etc) within -a docker container for that implementation by passing *"DOCKERIZE=1"* -on the make command line. For example: - -``` -make DOCKERIZE=1 "test^js^step3" -``` - -Existing implementations already have docker images built and pushed -to the docker registry. However, if -you wish to build or rebuild a docker image locally, the toplevel -Makefile provides a rule for building docker images: - -``` -make "docker-build^IMPL" -``` - - -**Notes**: -* Docker images are named *"kanaka/mal-test-IMPL"* -* JVM-based language implementations (Groovy, Java, Clojure, Scala): - you will probably need to run this command once manually - first `make DOCKERIZE=1 "repl^IMPL"` before you can run tests because - runtime dependencies need to be downloaded to avoid the tests timing - out. These dependencies are downloaded to dot-files in the /mal - directory so they will persist between runs. - - -## License - -Mal (make-a-lisp) is licensed under the MPL 2.0 (Mozilla Public -License 2.0). See LICENSE.txt for more details. +# mal - Make a Lisp + +[![Build Status](https://travis-ci.org/kanaka/mal.svg?branch=master)](https://travis-ci.org/kanaka/mal) + +## Description + +**1. Mal is a Clojure inspired Lisp interpreter** + +**2. Mal is a learning tool** + +Each implementation of mal is separated into +11 incremental, self-contained (and testable) steps that demonstrate +core concepts of Lisp. The last step is capable of self-hosting +(running the mal implementation of mal). See the [make-a-lisp process +guide](process/guide.md). + +The make-a-lisp steps are: + +* [step0_repl](process/guide.md#step0) +* [step1_read_print](process/guide.md#step1) +* [step2_eval](process/guide.md#step2) +* [step3_env](process/guide.md#step3) +* [step4_if_fn_do](process/guide.md#step4) +* [step5_tco](process/guide.md#step5) +* [step6_file](process/guide.md#step6) +* [step7_quote](process/guide.md#step7) +* [step8_macros](process/guide.md#step8) +* [step9_try](process/guide.md#step9) +* [stepA_mal](process/guide.md#stepA) + +Each make-a-lisp step has an associated architectural diagram. That elements +that are new for that step are highlighted in red. +Here is the final diagram for [step A](process/guide.md#stepA): + +![stepA_mal architecture](process/stepA_mal.png) + +If you are interested in creating a mal implementation (or just +interested in using mal for something), you are welcome to to join our +[Discord](https://discord.gg/CKgnNbJBpF) or join #mal on +[libera.chat](https://libera.chat/). In addition to the [make-a-lisp +process guide](process/guide.md) there is also a [mal/make-a-lisp +FAQ](docs/FAQ.md) where I attempt to answer some common questions. + + +**3. Mal is implemented in 87 languages (93 different implementations and 115 runtime modes)** + +| Language | Creator | +| -------- | ------- | +| [Ada](#ada) | [Chris Moore](https://github.com/zmower) | +| [Ada #2](#ada2) | [Nicolas Boulenguez](https://github.com/asarhaddon) | +| [GNU Awk](#gnu-awk) | [Miutsuru Kariya](https://github.com/kariya-mitsuru) | +| [Bash 4](#bash-4) | [Joel Martin](https://github.com/kanaka) | +| [BASIC](#basic-c64-and-qbasic) (C64 & QBasic) | [Joel Martin](https://github.com/kanaka) | +| [BBC BASIC V](#bbc-basic-v) | [Ben Harris](https://github.com/bjh21) | +| [C](#c) | [Joel Martin](https://github.com/kanaka) | +| [C #2](#c2) | [Duncan Watts](https://github.com/fungiblecog) | +| [C++](#c-1) | [Stephen Thirlwall](https://github.com/sdt) | +| [C#](#c-2) | [Joel Martin](https://github.com/kanaka) | +| [ChucK](#chuck) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Clojure](#clojure) (Clojure & ClojureScript) | [Joel Martin](https://github.com/kanaka) | +| [CoffeeScript](#coffeescript) | [Joel Martin](https://github.com/kanaka) | +| [Common Lisp](#common-lisp) | [Iqbal Ansari](https://github.com/iqbalansari) | +| [Crystal](#crystal) | [Linda_pp](https://github.com/rhysd) | +| [D](#d) | [Dov Murik](https://github.com/dubek) | +| [Dart](#dart) | [Harry Terkelsen](https://github.com/hterkelsen) | +| [Elixir](#elixir) | [Martin Ek](https://github.com/ekmartin) | +| [Elm](#elm) | [Jos van Bakel](https://github.com/c0deaddict) | +| [Emacs Lisp](#emacs-lisp) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Erlang](#erlang) | [Nathan Fiedler](https://github.com/nlfiedler) | +| [ES6](#es6-ecmascript-2015) (ECMAScript 2015) | [Joel Martin](https://github.com/kanaka) | +| [F#](#f) | [Peter Stephens](https://github.com/pstephens) | +| [Factor](#factor) | [Jordan Lewis](https://github.com/jordanlewis) | +| [Fantom](#fantom) | [Dov Murik](https://github.com/dubek) | +| [Fennel](#fennel) | [sogaiu](https://github.com/sogaiu) | +| [Forth](#forth) | [Chris Houser](https://github.com/chouser) | +| [GNU Guile](#gnu-guile-21) | [Mu Lei](https://github.com/NalaGinrut) | +| [GNU Smalltalk](#gnu-smalltalk) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Go](#go) | [Joel Martin](https://github.com/kanaka) | +| [Groovy](#groovy) | [Joel Martin](https://github.com/kanaka) | +| [Haskell](#haskell) | [Joel Martin](https://github.com/kanaka) | +| [Haxe](#haxe-neko-python-c-and-javascript) (Neko, Python, C++, & JS) | [Joel Martin](https://github.com/kanaka) | +| [Hy](#hy) | [Joel Martin](https://github.com/kanaka) | +| [Io](#io) | [Dov Murik](https://github.com/dubek) | +| [Janet](#janet) | [sogaiu](https://github.com/sogaiu) | +| [Java](#java-17) | [Joel Martin](https://github.com/kanaka) | +| [Java](#java-using-truffle-for-graalvm) (Truffle/GraalVM) | [Matt McGill](https://github.com/mmcgill) +| [JavaScript](#javascriptnode) ([Demo](http://kanaka.github.io/mal)) | [Joel Martin](https://github.com/kanaka) | +| [jq](#jq) | [Ali MohammadPur](https://github.com/alimpfard) | +| [Julia](#julia) | [Joel Martin](https://github.com/kanaka) | +| [Kotlin](#kotlin) | [Javier Fernandez-Ivern](https://github.com/ivern) | +| [LiveScript](#livescript) | [Jos van Bakel](https://github.com/c0deaddict) | +| [Logo](#logo) | [Dov Murik](https://github.com/dubek) | +| [Lua](#lua) | [Joel Martin](https://github.com/kanaka) | +| [GNU Make](#gnu-make-381) | [Joel Martin](https://github.com/kanaka) | +| [mal itself](#mal) | [Joel Martin](https://github.com/kanaka) | +| [MATLAB](#matlab-gnu-octave-and-matlab) (GNU Octave & MATLAB) | [Joel Martin](https://github.com/kanaka) | +| [miniMAL](#minimal) ([Repo](https://github.com/kanaka/miniMAL), [Demo](https://kanaka.github.io/miniMAL/)) | [Joel Martin](https://github.com/kanaka) | +| [NASM](#nasm) | [Ben Dudson](https://github.com/bendudson) | +| [Nim](#nim-104) | [Dennis Felsing](https://github.com/def-) | +| [Object Pascal](#object-pascal) | [Joel Martin](https://github.com/kanaka) | +| [Objective C](#objective-c) | [Joel Martin](https://github.com/kanaka) | +| [OCaml](#ocaml-4010) | [Chris Houser](https://github.com/chouser) | +| [Perl](#perl-5) | [Joel Martin](https://github.com/kanaka) | +| [Perl 6](#perl-6) | [Hinrik Örn Sigurðsson](https://github.com/hinrik) | +| [PHP](#php-53) | [Joel Martin](https://github.com/kanaka) | +| [Picolisp](#picolisp) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Pike](#pike) | [Dov Murik](https://github.com/dubek) | +| [PL/pgSQL](#plpgsql-postgresql-sql-procedural-language) (PostgreSQL) | [Joel Martin](https://github.com/kanaka) | +| [PL/SQL](#plsql-oracle-sql-procedural-language) (Oracle) | [Joel Martin](https://github.com/kanaka) | +| [PostScript](#postscript-level-23) | [Joel Martin](https://github.com/kanaka) | +| [PowerShell](#powershell) | [Joel Martin](https://github.com/kanaka) | +| [Prolog](#prolog-logical-language) | [Nicolas Boulenguez](https://github.com/asarhaddon) | +| [PureScript](#purescript) | [mrsekut](https://github.com/mrsekut) | +| [Python](#python-2x-and-3x) (2.X & 3.X) | [Joel Martin](https://github.com/kanaka) | +| [Python #2](#python2-3x) (3.X) | [Gavin Lewis](https://github.com/epylar) | +| [RPython](#rpython) | [Joel Martin](https://github.com/kanaka) | +| [R](#r) | [Joel Martin](https://github.com/kanaka) | +| [Racket](#racket-53) | [Joel Martin](https://github.com/kanaka) | +| [Rexx](#rexx) | [Dov Murik](https://github.com/dubek) | +| [Ruby](#ruby-19) | [Joel Martin](https://github.com/kanaka) | +| [Ruby #2](#ruby) | [Ryan Cook](https://github.com/cookrn) | +| [Rust](#rust-138) | [Joel Martin](https://github.com/kanaka) | +| [Scala](#scala) | [Joel Martin](https://github.com/kanaka) | +| [Scheme (R7RS)](#scheme-r7rs) | [Vasilij Schneidermann](https://github.com/wasamasa) | +| [Skew](#skew) | [Dov Murik](https://github.com/dubek) | +| [Standard ML](#sml) | [Fabian Bergström](https://github.com/fabjan) | +| [Swift 2](#swift) | [Keith Rollin](https://github.com/keith-rollin) | +| [Swift 3](#swift-3) | [Joel Martin](https://github.com/kanaka) | +| [Swift 4](#swift-4) | [陆遥](https://github.com/LispLY) | +| [Swift 5](#swift-5) | [Oleg Montak](https://github.com/MontakOleg) | +| [Tcl](#tcl-86) | [Dov Murik](https://github.com/dubek) | +| [TypeScript](#typescript) | [Masahiro Wakame](https://github.com/vvakame) | +| [Vala](#vala) | [Simon Tatham](https://github.com/sgtatham) | +| [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) | +| [Yorick](#yorick) | [Dov Murik](https://github.com/dubek) | +| [Zig](#zig) | [Josh Tobin](https://github.com/rjtobin) | + + +## Presentations + +Mal was presented publicly for the first time in a lightning talk at +Clojure West 2014 (unfortunately there is no video). See +examples/clojurewest2014.mal for the presentation that was given at the +conference (yes, the presentation is a mal program). + +At Midwest.io 2015, Joel Martin gave a presentation on Mal titled +"Achievement Unlocked: A Better Path to Language Learning". +[Video](https://www.youtube.com/watch?v=lgyOAiRtZGw), +[Slides](http://kanaka.github.io/midwest.io.mal/). + +More recently Joel gave a presentation on "Make Your Own Lisp Interpreter +in 10 Incremental Steps" at LambdaConf 2016: +[Part 1](https://www.youtube.com/watch?v=jVhupfthTEk), +[Part 2](https://www.youtube.com/watch?v=X5OQBMGpaTU), +[Part 3](https://www.youtube.com/watch?v=6mARZzGgX4U), +[Part 4](https://www.youtube.com/watch?v=dCO1SYR5kDU), +[Slides](http://kanaka.github.io/lambdaconf/). + +## Building/running implementations + +The simplest way to run any given implementation is to use docker. +Every implementation has a docker image pre-built with language +dependencies installed. You can launch the REPL using a convenient +target in the top level Makefile (where IMPL is the implementation +directory name and stepX is the step to run): + +``` +make DOCKERIZE=1 "repl^IMPL^stepX" + # OR stepA is the default step: +make DOCKERIZE=1 "repl^IMPL" +``` + +## External Implementations + +The following implementations are maintained as separate projects: + +### HolyC + +* [by Alexander Bagnalla](https://github.com/bagnalla/holyc_mal) + +### Rust + +* [by Tim Morgan](https://github.com/seven1m/mal-rust) +* [by vi](https://github.com/vi/mal-rust-vi) - using [Pest](https://pest.rs/) grammar, not using typical Mal infrastructure (cargo-ized steps and built-in converted tests). + +### Q + +* [by Ali Mohammad Pur](https://github.com/alimpfard/mal/tree/q/impls/q) - The Q implementation works fine but it requires a proprietary manual download that can't be Dockerized (or integrated into the mal CI pipeline) so for now it remains a separate project. + + +## Other mal Projects + + * [malc](https://github.com/dubek/malc) - Mal (Make A Lisp) compiler. Compiles a Mal program to LLVM assembly language, then binary. + * [malcc](https://github.com/seven1m/malcc) - malcc is an incremental compiler implementation for the Mal language. It uses the Tiny C Compiler as the compiler backend and has full support for the Mal language, including macros, tail-call elimination, and even run-time eval. ["I Built a Lisp Compiler"](https://mpov.timmorgan.org/i-built-a-lisp-compiler/) post about the process. + * [frock](https://github.com/chr15m/frock) - Clojure-flavoured PHP. Uses mal/php to run programs. + * [flk](https://github.com/chr15m/flk) - A LISP that runs wherever Bash is + * [glisp](https://github.com/baku89/glisp) - Self-bootstrapping graphic design tool on Lisp. [Live Demo](https://baku89.com/glisp/) + + +## Implementation Details + +### Ada + +The Ada implementation was developed with GNAT 4.9 on debian. It also +compiles unchanged on windows if you have windows versions of git, +GNAT and (optionally) make. There are no external dependencies +(readline not implemented). + +``` +cd impls/ada +make +./stepX_YYY +``` + +### Ada.2 + +The second Ada implementation was developed with GNAT 8 and links with +the GNU readline library. + +``` +cd impls/ada +make +./stepX_YYY +``` + +### GNU awk + +The GNU awk implementation of mal has been tested with GNU awk 4.1.1. + +``` +cd impls/gawk +gawk -O -f stepX_YYY.awk +``` + +### Bash 4 + +``` +cd impls/bash +bash stepX_YYY.sh +``` + +### BASIC (C64 and QBasic) + +The BASIC implementation uses a preprocessor that can generate BASIC +code that is compatible with both C64 BASIC (CBM v2) and QBasic. The +C64 mode has been tested with +[cbmbasic](https://github.com/kanaka/cbmbasic) (the patched version is +currently required to fix issues with line input) and the QBasic mode +has been tested with [qb64](http://www.qb64.net/). + +Generate C64 code and run it using cbmbasic: + +``` +cd impls/basic +make stepX_YYY.bas +STEP=stepX_YYY ./run +``` + +Generate QBasic code and load it into qb64: + +``` +cd impls/basic +make MODE=qbasic stepX_YYY.bas +./qb64 stepX_YYY.bas +``` + +Thanks to [Steven Syrek](https://github.com/sjsyrek) for the original +inspiration for this implementation. + +### BBC BASIC V + +The BBC BASIC V implementation can run in the Brandy interpreter: + +``` +cd impls/bbc-basic +brandy -quit stepX_YYY.bbc +``` + +Or in ARM BBC BASIC V under RISC OS 3 or later: + +``` +*Dir bbc-basic.riscos +*Run setup +*Run stepX_YYY +``` + +### C + +The C implementation of mal requires the following libraries (lib and +header packages): glib, libffi6, libgc, and either the libedit or GNU readline +library. + +``` +cd impls/c +make +./stepX_YYY +``` + +### C.2 + +The second C implementation of mal requires the following libraries (lib and +header packages): libedit, libgc, libdl, and libffi. + +``` +cd impls/c.2 +make +./stepX_YYY +``` + + +### C++ + +The C++ implementation of mal requires g++-4.9 or clang++-3.5 and +a readline compatible library to build. See the `cpp/README.md` for +more details: + +``` +cd impls/cpp +make + # OR +make CXX=clang++-3.5 +./stepX_YYY +``` + + +### C# ### + +The C# implementation of mal has been tested on Linux using the Mono +C# compiler (mcs) and the Mono runtime (version 2.10.8.1). Both are +required to build and run the C# implementation. + +``` +cd impls/cs +make +mono ./stepX_YYY.exe +``` + +### ChucK + +The ChucK implementation has been tested with ChucK 1.3.5.2. + +``` +cd impls/chuck +./run +``` + +### Clojure + +For the most part the Clojure implementation requires Clojure 1.5, +however, to pass all tests, Clojure 1.8.0-RC4 is required. + +``` +cd impls/clojure +lein with-profile +stepX trampoline run +``` + +### CoffeeScript + +``` +sudo npm install -g coffee-script +cd impls/coffee +coffee ./stepX_YYY +``` + +### Common Lisp + +The implementation has been tested with SBCL, CCL, CMUCL, GNU CLISP, ECL and +Allegro CL on Ubuntu 16.04 and Ubuntu 12.04, see +the [README](impls/common-lisp/README.org) for more details. Provided you have the +dependencies mentioned installed, do the following to run the implementation + +``` +cd impls/common-lisp +make +./run +``` + +### Crystal + +The Crystal implementation of mal has been tested with Crystal 0.26.1. + +``` +cd impls/crystal +crystal run ./stepX_YYY.cr + # OR +make # needed to run tests +./stepX_YYY +``` + +### D + +The D implementation of mal was tested with GDC 4.8. It requires the GNU +readline library. + +``` +cd impls/d +make +./stepX_YYY +``` + +### Dart + +The Dart implementation has been tested with Dart 1.20. + +``` +cd impls/dart +dart ./stepX_YYY +``` + +### Emacs Lisp + +The Emacs Lisp implementation of mal has been tested with Emacs 24.3 +and 24.5. While there is very basic readline editing (`` +and `C-d` work, `C-c` cancels the process), it is recommended to use +`rlwrap`. + +``` +cd impls/elisp +emacs -Q --batch --load stepX_YYY.el +# with full readline support +rlwrap emacs -Q --batch --load stepX_YYY.el +``` + +### Elixir + +The Elixir implementation of mal has been tested with Elixir 1.0.5. + +``` +cd impls/elixir +mix stepX_YYY +# Or with readline/line editing functionality: +iex -S mix stepX_YYY +``` + +### Elm + +The Elm implementation of mal has been tested with Elm 0.18.0 + +``` +cd impls/elm +make stepX_YYY.js +STEP=stepX_YYY ./run +``` + +### Erlang + +The Erlang implementation of mal requires [Erlang/OTP R17](http://www.erlang.org/download.html) +and [rebar](https://github.com/rebar/rebar) to build. + +``` +cd impls/erlang +make + # OR +MAL_STEP=stepX_YYY rebar compile escriptize # build individual step +./stepX_YYY +``` + +### ES6 (ECMAScript 2015) + +The ES6 / ECMAScript 2015 implementation uses the +[babel](https://babeljs.io) compiler to generate ES5 compatible +JavaScript. The generated code has been tested with Node 0.12.4. + +``` +cd impls/es6 +make +node build/stepX_YYY.js +``` + + +### F# ### + +The F# implementation of mal has been tested on Linux using the Mono +F# compiler (fsharpc) and the Mono runtime (version 3.12.1). The mono C# +compiler (mcs) is also necessary to compile the readline dependency. All are +required to build and run the F# implementation. + +``` +cd impls/fsharp +make +mono ./stepX_YYY.exe +``` + +### Factor + +The Factor implementation of mal has been tested with Factor 0.97 +([factorcode.org](http://factorcode.org)). + +``` +cd impls/factor +FACTOR_ROOTS=. factor -run=stepX_YYY +``` + +### Fantom + +The Fantom implementation of mal has been tested with Fantom 1.0.70. + +``` +cd impls/fantom +make lib/fan/stepX_YYY.pod +STEP=stepX_YYY ./run +``` + +### Fennel + +The Fennel implementation of mal has been tested with Fennel version +0.9.1 on Lua 5.4. + +``` +cd impls/fennel +fennel ./stepX_YYY.fnl +``` + +### Forth + +``` +cd impls/forth +gforth stepX_YYY.fs +``` + +### GNU Guile 2.1+ + +``` +cd impls/guile +guile -L ./ stepX_YYY.scm +``` + +### GNU Smalltalk + +The Smalltalk implementation of mal has been tested with GNU Smalltalk 3.2.91. + +``` +cd impls/gnu-smalltalk +./run +``` + +### Go + +The Go implementation of mal requires that go is installed on on the +path. The implementation has been tested with Go 1.3.1. + +``` +cd impls/go +make +./stepX_YYY +``` + + +### Groovy + +The Groovy implementation of mal requires Groovy to run and has been +tested with Groovy 1.8.6. + +``` +cd impls/groovy +make +groovy ./stepX_YYY.groovy +``` + +### Haskell + +The Haskell implementation requires the ghc compiler version 7.10.1 or +later and also the Haskell parsec and readline (or editline) packages. + +``` +cd impls/haskell +make +./stepX_YYY +``` + +### Haxe (Neko, Python, C++ and JavaScript) + +The Haxe implementation of mal requires Haxe version 3.2 to compile. +Four different Haxe targets are supported: Neko, Python, C++, and +JavaScript. + +``` +cd impls/haxe +# Neko +make all-neko +neko ./stepX_YYY.n +# Python +make all-python +python3 ./stepX_YYY.py +# C++ +make all-cpp +./cpp/stepX_YYY +# JavaScript +make all-js +node ./stepX_YYY.js +``` + +### Hy + +The Hy implementation of mal has been tested with Hy 0.13.0. + +``` +cd impls/hy +./stepX_YYY.hy +``` + +### Io + +The Io implementation of mal has been tested with Io version 20110905. + +``` +cd impls/io +io ./stepX_YYY.io +``` + +### Janet + +The Janet implementation of mal has been tested with Janet version 1.12.2. + +``` +cd impls/janet +janet ./stepX_YYY.janet +``` + +### Java 1.7 + +The Java implementation of mal requires maven2 to build. + +``` +cd impls/java +mvn compile +mvn -quiet exec:java -Dexec.mainClass=mal.stepX_YYY + # OR +mvn -quiet exec:java -Dexec.mainClass=mal.stepX_YYY -Dexec.args="CMDLINE_ARGS" +``` + +### Java, using Truffle for GraalVM + +This Java implementation will run on OpenJDK, but can run +as much as 30x faster on GraalVM thanks to the Truffle framework. +It's been tested with OpenJDK 11, GraalVM CE 20.1.0, and +GraalVM CE 21.1.0. + +``` +cd impls/java-truffle +./gradlew build +STEP=stepX_YYY ./run +``` + +### JavaScript/Node + +``` +cd impls/js +npm install +node stepX_YYY.js +``` + +### Julia + +The Julia implementation of mal requires Julia 0.4. + +``` +cd impls/julia +julia stepX_YYY.jl +``` + +### jq + +Tested against version 1.6, with a lot of cheating in the IO department + +``` +cd impls/jq +STEP=stepA_YYY ./run + # with Debug +DEBUG=true STEP=stepA_YYY ./run +``` + +### Kotlin + +The Kotlin implementation of mal has been tested with Kotlin 1.0. + +``` +cd impls/kotlin +make +java -jar stepX_YYY.jar +``` + +### LiveScript + +The LiveScript implementation of mal has been tested with LiveScript 1.5. + +``` +cd impls/livescript +make +node_modules/.bin/lsc stepX_YYY.ls +``` + +### Logo + +The Logo implementation of mal has been tested with UCBLogo 6.0. + +``` +cd impls/logo +logo stepX_YYY.lg +``` + +### Lua + +The Lua implementation of mal has been tested with Lua 5.3.5 The +implementation requires luarocks to be installed. + +``` +cd impls/lua +make # to build and link linenoise.so and rex_pcre.so +./stepX_YYY.lua +``` + +### Mal + +Running the mal implementation of mal involves running stepA of one of +the other implementations and passing the mal step to run as a command +line argument. + +``` +cd impls/IMPL +IMPL_STEPA_CMD ../mal/stepX_YYY.mal + +``` + +### GNU Make 3.81 + +``` +cd impls/make +make -f stepX_YYY.mk +``` + +### NASM + +The NASM implementation of mal is written for x86-64 Linux, and has been tested +with Linux 3.16.0-4-amd64 and NASM version 2.11.05. + +``` +cd impls/nasm +make +./stepX_YYY +``` + +### Nim 1.0.4 + +The Nim implementation of mal has been tested with Nim 1.0.4. + +``` +cd impls/nim +make + # OR +nimble build +./stepX_YYY +``` + +### Object Pascal + +The Object Pascal implementation of mal has been built and tested on +Linux using the Free Pascal compiler version 2.6.2 and 2.6.4. + +``` +cd impls/objpascal +make +./stepX_YYY +``` + +### Objective C + +The Objective C implementation of mal has been built and tested on +Linux using clang/LLVM 3.6. It has also been built and tested on OS +X using XCode 7. + +``` +cd impls/objc +make +./stepX_YYY +``` + +### OCaml 4.01.0 + +``` +cd impls/ocaml +make +./stepX_YYY +``` + +### MATLAB (GNU Octave and MATLAB) + +The MatLab implementation has been tested with GNU Octave 4.2.1. +It has also been tested with MATLAB version R2014a on Linux. Note that +MATLAB is a commercial product. + +``` +cd impls/matlab +./stepX_YYY +octave -q --no-gui --no-history --eval "stepX_YYY();quit;" +matlab -nodisplay -nosplash -nodesktop -nojvm -r "stepX_YYY();quit;" + # OR with command line arguments +octave -q --no-gui --no-history --eval "stepX_YYY('arg1','arg2');quit;" +matlab -nodisplay -nosplash -nodesktop -nojvm -r "stepX_YYY('arg1','arg2');quit;" +``` + +### miniMAL + +[miniMAL](https://github.com/kanaka/miniMAL) is small Lisp interpreter +implemented in less than 1024 bytes of JavaScript. To run the miniMAL +implementation of mal you need to download/install the miniMAL +interpreter (which requires Node.js). +``` +cd impls/miniMAL +# Download miniMAL and dependencies +npm install +export PATH=`pwd`/node_modules/minimal-lisp/:$PATH +# Now run mal implementation in miniMAL +miniMAL ./stepX_YYY +``` + +### Perl 5 + +The Perl 5 implementation should work with perl 5.19.3 and later. + +For readline line editing support, install Term::ReadLine::Perl or +Term::ReadLine::Gnu from CPAN. + +``` +cd impls/perl +perl stepX_YYY.pl +``` + +### Perl 6 + +The Perl 6 implementation was tested on Rakudo Perl 6 2016.04. + +``` +cd impls/perl6 +perl6 stepX_YYY.pl +``` + +### PHP 5.3 + +The PHP implementation of mal requires the php command line interface +to run. + +``` +cd impls/php +php stepX_YYY.php +``` + +### Picolisp + +The Picolisp implementation requires libreadline and Picolisp 3.1.11 +or later. + +``` +cd impls/picolisp +./run +``` + +### Pike + +The Pike implementation was tested on Pike 8.0. + +``` +cd impls/pike +pike stepX_YYY.pike +``` + +### PL/pgSQL (PostgreSQL SQL Procedural Language) + +The PL/pgSQL implementation of mal requires a running PostgreSQL server +(the "kanaka/mal-test-plpgsql" docker image automatically starts +a PostgreSQL server). The implementation connects to the PostgreSQL server +and create a database named "mal" to store tables and stored +procedures. The wrapper script uses the psql command to connect to the +server and defaults to the user "postgres" but this can be overridden +with the PSQL_USER environment variable. A password can be specified +using the PGPASSWORD environment variable. The implementation has been +tested with PostgreSQL 9.4. + +``` +cd impls/plpgsql +./wrap.sh stepX_YYY.sql + # OR +PSQL_USER=myuser PGPASSWORD=mypass ./wrap.sh stepX_YYY.sql +``` + +### PL/SQL (Oracle SQL Procedural Language) + +The PL/SQL implementation of mal requires a running Oracle DB +server (the "kanaka/mal-test-plsql" docker image automatically +starts an Oracle Express server). The implementation connects to the +Oracle server to create types, tables and stored procedures. The +default SQL\*Plus logon value (username/password@connect_identifier) is +"system/oracle" but this can be overridden with the ORACLE_LOGON +environment variable. The implementation has been tested with Oracle +Express Edition 11g Release 2. Note that any SQL\*Plus connection +warnings (user password expiration, etc) will interfere with the +ability of the wrapper script to communicate with the DB. + +``` +cd impls/plsql +./wrap.sh stepX_YYY.sql + # OR +ORACLE_LOGON=myuser/mypass@ORCL ./wrap.sh stepX_YYY.sql +``` + +### PostScript Level 2/3 + +The PostScript implementation of mal requires Ghostscript to run. It +has been tested with Ghostscript 9.10. + +``` +cd impls/ps +gs -q -dNODISPLAY -I./ stepX_YYY.ps +``` + +### PowerShell + +The PowerShell implementation of mal requires the PowerShell script +language. It has been tested with PowerShell 6.0.0 Alpha 9 on Linux. + +``` +cd impls/powershell +powershell ./stepX_YYY.ps1 +``` + +### Prolog + +The Prolog implementation uses some constructs specific to SWI-Prolog, +includes readline support and has been tested on Debian GNU/Linux with +version 8.2.1. + +``` +cd impls/prolog +swipl stepX_YYY +``` + +### PureScript +The PureScript implementation requires the spago compiler version 0.20.2. + +``` +cd impls/purs +make +node ./stepX_YYY.js +``` + +### Python (2.X and 3.X) + +``` +cd impls/python +python stepX_YYY.py +``` + +### Python.2 (3.X) + +The second Python implementation makes heavy use of type annotations and uses the Arpeggio parser library. + +``` +# Recommended: do these steps in a Python virtual environment. +pip3 install Arpeggio==1.9.0 +python3 stepX_YYY.py +``` + +### RPython + +You must have [rpython](https://rpython.readthedocs.org/) on your path +(included with [pypy](https://bitbucket.org/pypy/pypy/)). + +``` +cd impls/rpython +make # this takes a very long time +./stepX_YYY +``` + +### R + +The R implementation of mal requires R (r-base-core) to run. + +``` +cd impls/r +make libs # to download and build rdyncall +Rscript stepX_YYY.r +``` + +### Racket (5.3) + +The Racket implementation of mal requires the Racket +compiler/interpreter to run. + +``` +cd impls/racket +./stepX_YYY.rkt +``` + +### Rexx + +The Rexx implementation of mal has been tested with Regina Rexx 3.6. + +``` +cd impls/rexx +make +rexx -a ./stepX_YYY.rexxpp +``` + +### Ruby (1.9+) + +``` +cd impls/ruby +ruby stepX_YYY.rb +``` + +### Ruby #2 + +A second Ruby implementation with the following goals: + +- No global variables +- No modification (monkey-patching) of core Ruby classes +- Modularized into the `Mal` module namespace + +``` +cd impls/ruby.2 +ruby stepX_YYY.rb +``` + +### Rust (1.38+) + +The rust implementation of mal requires the rust compiler and build +tool (cargo) to build. + +``` +cd impls/rust +cargo run --release --bin stepX_YYY +``` + +### Scala ### + +Install scala and sbt (http://www.scala-sbt.org/0.13/tutorial/Installing-sbt-on-Linux.html): + +``` +cd impls/scala +sbt 'run-main stepX_YYY' + # OR +sbt compile +scala -classpath target/scala*/classes stepX_YYY +``` + +### Scheme (R7RS) ### + +The Scheme implementation of MAL has been tested with Chibi-Scheme +0.10, Kawa 3.1.1, Gauche 0.9.6, CHICKEN 5.1.0, Sagittarius 0.9.7, +Cyclone 0.32.0 (Git version) and Foment 0.4 (Git version). You should +be able to get it running on other conforming R7RS implementations +after figuring out how libraries are loaded and adjusting the +`Makefile` and `run` script accordingly. + +``` +cd impls/scheme +# chibi +scheme_MODE=chibi ./run +# kawa +make kawa +scheme_MODE=kawa ./run +# gauche +scheme_MODE=gauche ./run +# chicken +make chicken +scheme_MODE=chicken ./run +# sagittarius +scheme_MODE=sagittarius ./run +# cyclone +make cyclone +scheme_MODE=cyclone ./run +# foment +scheme_MODE=foment ./run +``` + +### Skew ### + +The Skew implementation of mal has been tested with Skew 0.7.42. + +``` +cd impls/skew +make +node stepX_YYY.js +``` + + +### Standard ML (Poly/ML, MLton, Moscow ML) + +The Standard ML implementation of mal requires an +[SML97](https://github.com/SMLFamily/The-Definition-of-Standard-ML-Revised) +implementation. The Makefile supports Poly/ML, MLton, Moscow ML, and has +been tested with Poly/ML 5.8.1, MLton 20210117, and Moscow ML version 2.10. + +``` +cd impls/sml +# Poly/ML +make sml_MODE=polyml +./stepX_YYY +# MLton +make sml_MODE=mlton +./stepX_YYY +# Moscow ML +make sml_MODE=mosml +./stepX_YYY +``` + + +### Swift + +The Swift implementation of mal requires the Swift 2.0 compiler (XCode +7.0) to build. Older versions will not work due to changes in the +language and standard library. + +``` +cd impls/swift +make +./stepX_YYY +``` + +### Swift 3 + +The Swift 3 implementation of mal requires the Swift 3.0 compiler. It +has been tested with Swift 3 Preview 3. + +``` +cd impls/swift3 +make +./stepX_YYY +``` + +### Swift 4 + +The Swift 4 implementation of mal requires the Swift 4.0 compiler. It +has been tested with Swift 4.2.3 release. + +``` +cd impls/swift4 +make +./stepX_YYY +``` + +### Swift 5 + +The Swift 5 implementation of mal requires the Swift 5.0 compiler. It +has been tested with Swift 5.1.1 release. + +``` +cd impls/swift5 +swift run stepX_YYY +``` + +### Tcl 8.6 + +The Tcl implementation of mal requires Tcl 8.6 to run. For readline line +editing support, install tclreadline. + +``` +cd impls/tcl +tclsh ./stepX_YYY.tcl +``` + +### TypeScript + +The TypeScript implementation of mal requires the TypeScript 2.2 compiler. +It has been tested with Node.js v6. + +``` +cd impls/ts +make +node ./stepX_YYY.js +``` + +### Vala + +The Vala implementation of mal has been tested with the Vala 0.40.8 +compiler. You will need to install `valac` and `libreadline-dev` or +equivalent. + +``` +cd impls/vala +make +./stepX_YYY +``` + +### VHDL + +The VHDL implementation of mal has been tested with GHDL 0.29. + +``` +cd impls/vhdl +make +./run_vhdl.sh ./stepX_YYY +``` + +### Vimscript + +The Vimscript implementation of mal requires Vim 8.0 to run. + +``` +cd impls/vimscript +./run_vimscript.sh ./stepX_YYY.vim +``` + +### Visual Basic.NET ### + +The VB.NET implementation of mal has been tested on Linux using the Mono +VB compiler (vbnc) and the Mono runtime (version 2.10.8.1). Both are +required to build and run the VB.NET implementation. + +``` +cd impls/vb +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 +[Wam](https://github.com/kanaka/wam) (WebAssembly Macro language) and +runs under several different non-web embeddings (runtimes): +[node](https://nodejs.org), +[wasmtime](https://github.com/CraneStation/wasmtime), +[wasmer](https://wasmer.io), +[lucet](https://github.com/fastly/lucet), +[wax](https://github.com/kanaka/wac), +[wace](https://github.com/kanaka/wac), +[warpy](https://github.com/kanaka/warpy). + +``` +cd impls/wasm +# node +make wasm_MODE=node +./run.js ./stepX_YYY.wasm +# wasmtime +make wasm_MODE=wasmtime +wasmtime --dir=./ --dir=../ --dir=/ ./stepX_YYY.wasm +# wasmer +make wasm_MODE=wasmer +wasmer run --dir=./ --dir=../ --dir=/ ./stepX_YYY.wasm +# lucet +make wasm_MODE=lucet +lucet-wasi --dir=./:./ --dir=../:../ --dir=/:/ ./stepX_YYY.so +# wax +make wasm_MODE=wax +wax ./stepX_YYY.wasm +# wace +make wasm_MODE=wace_libc +wace ./stepX_YYY.wasm +# warpy +make wasm_MODE=warpy +warpy --argv --memory-pages 256 ./stepX_YYY.wasm +``` + +### XSLT + +The XSLT implementation of mal is written with XSLT 3 and tested on Saxon 9.9.1.6 Home Edition. + +``` +cd impls/xslt +STEP=stepX_YY ./run +``` + +### Wren + +The Wren implementation of mal was tested on Wren 0.2.0. + +``` +cd impls/wren +wren ./stepX_YYY.wren +``` + +### Yorick + +The Yorick implementation of mal was tested on Yorick 2.2.04. + +``` +cd impls/yorick +yorick -batch ./stepX_YYY.i +``` + +### Zig + +The Zig implementation of mal was tested on Zig 0.5. + +``` +cd impls/zig +zig build stepX_YYY +``` + + + +## Running tests + +The top level Makefile has a number of useful targets to assist with +implementation development and testing. The `help` target provides +a list of the targets and options: + +``` +make help +``` + +### Functional tests + +The are almost 800 generic functional tests (for all implementations) +in the `tests/` directory. Each step has a corresponding test file +containing tests specific to that step. The `runtest.py` test harness +launches a Mal step implementation and then feeds the tests one at +a time to the implementation and compares the output/return value to +the expected output/return value. + +* To run all the tests across all implementations (be prepared to wait): + +``` +make test +``` + +* To run all tests against a single implementation: + +``` +make "test^IMPL" + +# e.g. +make "test^clojure" +make "test^js" +``` + +* To run tests for a single step against all implementations: + +``` +make "test^stepX" + +# e.g. +make "test^step2" +make "test^step7" +``` + +* To run tests for a specific step against a single implementation: + +``` +make "test^IMPL^stepX" + +# e.g +make "test^ruby^step3" +make "test^ps^step4" +``` + +### Self-hosted functional tests + +* To run the functional tests in self-hosted mode, you specify `mal` + as the test implementation and use the `MAL_IMPL` make variable + to change the underlying host language (default is JavaScript): +``` +make MAL_IMPL=IMPL "test^mal^step2" + +# e.g. +make "test^mal^step2" # js is default +make MAL_IMPL=ruby "test^mal^step2" +make MAL_IMPL=python "test^mal^step2" +``` + +### Starting the REPL + +* To start the REPL of an implementation in a specific step: + +``` +make "repl^IMPL^stepX" + +# e.g +make "repl^ruby^step3" +make "repl^ps^step4" +``` + +* If you omit the step, then `stepA` is used: + +``` +make "repl^IMPL" + +# e.g +make "repl^ruby" +make "repl^ps" +``` + +* To start the REPL of the self-hosted implementation, specify `mal` as the + REPL implementation and use the `MAL_IMPL` make variable to change the + underlying host language (default is JavaScript): +``` +make MAL_IMPL=IMPL "repl^mal^stepX" + +# e.g. +make "repl^mal^step2" # js is default +make MAL_IMPL=ruby "repl^mal^step2" +make MAL_IMPL=python "repl^mal" +``` + +### Performance tests + +Warning: These performance tests are neither statistically valid nor +comprehensive; runtime performance is a not a primary goal of mal. If +you draw any serious conclusions from these performance tests, then +please contact me about some amazing oceanfront property in Kansas +that I'm willing to sell you for cheap. + +* To run performance tests against a single implementation: +``` +make "perf^IMPL" + +# e.g. +make "perf^js" +``` + +* To run performance tests against all implementations: +``` +make "perf" +``` + +### Generating language statistics + +* To report line and byte statistics for a single implementation: +``` +make "stats^IMPL" + +# e.g. +make "stats^js" +``` + +## Dockerized testing + +Every implementation directory contains a Dockerfile to create +a docker image containing all the dependencies for that +implementation. In addition, the top-level Makefile contains support +for running the tests target (and perf, stats, repl, etc) within +a docker container for that implementation by passing *"DOCKERIZE=1"* +on the make command line. For example: + +``` +make DOCKERIZE=1 "test^js^step3" +``` + +Existing implementations already have docker images built and pushed +to the docker registry. However, if +you wish to build or rebuild a docker image locally, the toplevel +Makefile provides a rule for building docker images: + +``` +make "docker-build^IMPL" +``` + + +**Notes**: +* Docker images are named *"kanaka/mal-test-IMPL"* +* JVM-based language implementations (Groovy, Java, Clojure, Scala): + you will probably need to run this command once manually + first `make DOCKERIZE=1 "repl^IMPL"` before you can run tests because + runtime dependencies need to be downloaded to avoid the tests timing + out. These dependencies are downloaded to dot-files in the /mal + directory so they will persist between runs. + + +## License + +Mal (make-a-lisp) is licensed under the MPL 2.0 (Mozilla Public +License 2.0). See LICENSE.txt for more details. diff --git a/ci.sh b/ci.sh index 400045fbeb..a12f5d8d49 100755 --- a/ci.sh +++ b/ci.sh @@ -1,83 +1,83 @@ -#!/bin/bash - -set -ex - -ACTION=${1} -IMPL=${2} - -die() { local ret=$1; shift; echo >&2 "${*}"; exit $ret; } - -# Environment variable configuration -BUILD_IMPL=${BUILD_IMPL:-${IMPL}} - -if [ "${DO_SELF_HOST}" ]; then - MAL_IMPL=${IMPL} - IMPL=mal -fi - -if [ "${DO_HARD}" ]; then - TEST_OPTS="${TEST_OPTS} --hard" -fi - -raw_mode_var=${MAL_IMPL:-${IMPL}}_MODE -mode_var=${raw_mode_var/-/__} -mode_var=${mode_var/./__} -mode_val=${!mode_var} - -MAKE="make ${mode_val:+${mode_var}=${mode_val}}" - -log_prefix="${ACTION}${REGRESS:+-regress}-${IMPL}${mode_val:+-${mode_val}}${MAL_IMPL:+-${MAL_IMPL}}" -TEST_OPTS="${TEST_OPTS} --debug-file ../../${log_prefix}.debug" - -# Log everything below this point: -exec &> >(tee ./${log_prefix}.log) - -if [ "${NO_PERF}" -a "${ACTION}" = "perf" ]; then - die 0 "Skipping perf test" -fi -if [ "${NO_SELF_HOST}" -a "${DO_SELF_HOST}" ]; then - die 0 "Skipping ${ACTION} of ${MAL_IMPL} self-host" -fi -if [ "${NO_SELF_HOST_PERF}" -a "${DO_SELF_HOST}" -a "${ACTION}" = "perf" ]; then - die 0 "Skipping only perf test for ${MAL_IMPL} self-host" -fi - -echo "ACTION: ${ACTION}" -echo "IMPL: ${IMPL}" -echo "BUILD_IMPL: ${BUILD_IMPL}" -echo "MAL_IMPL: ${MAL_IMPL}" -echo "TEST_OPTS: ${TEST_OPTS}" - -# If NO_DOCKER is blank then launch use a docker image, otherwise use -# the Travis/Github Actions image/tools directly. -if [ -z "${NO_DOCKER}" ]; then - img_impl=$(echo "${MAL_IMPL:-${IMPL}}" | tr '[:upper:]' '[:lower:]') - # We could just use make DOCKERIZE=1 instead but that does add - # non-trivial startup overhead for each step. - MAKE="docker run -i -u $(id -u) -v `pwd`:/mal kanaka/mal-test-${img_impl%%-mal} ${MAKE}" -fi - -case "${ACTION}" in -build) - # rpython often fails on step9 in compute_vars_longevity - # so build step9, then continue with the full build - if [ "${BUILD_IMPL}" = "rpython" ]; then - ${MAKE} -C "impls/${BUILD_IMPL}" step9_try || true - fi - ${MAKE} -C "impls/${BUILD_IMPL}" - ;; -test|perf) - [ "${ACTION}" = "perf" ] && STEP= - if ! ${MAKE} TEST_OPTS="${TEST_OPTS}" \ - ${MAL_IMPL:+MAL_IMPL=${MAL_IMPL}} \ - ${REGRESS:+REGRESS=${REGRESS}} \ - ${HARD:+HARD=${HARD}} \ - ${DEFERRABLE:+DEFERRABLE=${DEFERRABLE}} \ - ${OPTIONAL:+OPTIONAL=${OPTIONAL}} \ - ${ACTION}^${IMPL}${STEP:+^${STEP}}; then - # print debug-file on error - cat ${log_prefix}.debug - false - fi - ;; -esac +#!/bin/bash + +set -ex + +ACTION=${1} +IMPL=${2} + +die() { local ret=$1; shift; echo >&2 "${*}"; exit $ret; } + +# Environment variable configuration +BUILD_IMPL=${BUILD_IMPL:-${IMPL}} + +if [ "${DO_SELF_HOST}" ]; then + MAL_IMPL=${IMPL} + IMPL=mal +fi + +if [ "${DO_HARD}" ]; then + TEST_OPTS="${TEST_OPTS} --hard" +fi + +raw_mode_var=${MAL_IMPL:-${IMPL}}_MODE +mode_var=${raw_mode_var/-/__} +mode_var=${mode_var/./__} +mode_val=${!mode_var} + +MAKE="make ${mode_val:+${mode_var}=${mode_val}}" + +log_prefix="${ACTION}${REGRESS:+-regress}-${IMPL}${mode_val:+-${mode_val}}${MAL_IMPL:+-${MAL_IMPL}}" +TEST_OPTS="${TEST_OPTS} --debug-file ../../${log_prefix}.debug" + +# Log everything below this point: +exec &> >(tee ./${log_prefix}.log) + +if [ "${NO_PERF}" -a "${ACTION}" = "perf" ]; then + die 0 "Skipping perf test" +fi +if [ "${NO_SELF_HOST}" -a "${DO_SELF_HOST}" ]; then + die 0 "Skipping ${ACTION} of ${MAL_IMPL} self-host" +fi +if [ "${NO_SELF_HOST_PERF}" -a "${DO_SELF_HOST}" -a "${ACTION}" = "perf" ]; then + die 0 "Skipping only perf test for ${MAL_IMPL} self-host" +fi + +echo "ACTION: ${ACTION}" +echo "IMPL: ${IMPL}" +echo "BUILD_IMPL: ${BUILD_IMPL}" +echo "MAL_IMPL: ${MAL_IMPL}" +echo "TEST_OPTS: ${TEST_OPTS}" + +# If NO_DOCKER is blank then launch use a docker image, otherwise use +# the Travis/Github Actions image/tools directly. +if [ -z "${NO_DOCKER}" ]; then + img_impl=$(echo "${MAL_IMPL:-${IMPL}}" | tr '[:upper:]' '[:lower:]') + # We could just use make DOCKERIZE=1 instead but that does add + # non-trivial startup overhead for each step. + MAKE="docker run -i -u $(id -u) -v `pwd`:/mal kanaka/mal-test-${img_impl%%-mal} ${MAKE}" +fi + +case "${ACTION}" in +build) + # rpython often fails on step9 in compute_vars_longevity + # so build step9, then continue with the full build + if [ "${BUILD_IMPL}" = "rpython" ]; then + ${MAKE} -C "impls/${BUILD_IMPL}" step9_try || true + fi + ${MAKE} -C "impls/${BUILD_IMPL}" + ;; +test|perf) + [ "${ACTION}" = "perf" ] && STEP= + if ! ${MAKE} TEST_OPTS="${TEST_OPTS}" \ + ${MAL_IMPL:+MAL_IMPL=${MAL_IMPL}} \ + ${REGRESS:+REGRESS=${REGRESS}} \ + ${HARD:+HARD=${HARD}} \ + ${DEFERRABLE:+DEFERRABLE=${DEFERRABLE}} \ + ${OPTIONAL:+OPTIONAL=${OPTIONAL}} \ + ${ACTION}^${IMPL}${STEP:+^${STEP}}; then + # print debug-file on error + cat ${log_prefix}.debug + false + fi + ;; +esac diff --git a/docs/FAQ.md b/docs/FAQ.md index 49af1d7eee..779fa96325 100644 --- a/docs/FAQ.md +++ b/docs/FAQ.md @@ -1,205 +1,205 @@ -# Mal/Make-a-Lisp FAQ - - - -### Why did you create mal/make-a-lisp? -### OR Why the name "mal"? -### OR Why? -### OR Wat? - -In November of 2013, Alan Dipert gave a [lightning talk at -Clojure/conj](https://www.youtube.com/watch?v=bmHTFo2Rf2w#t=28m55s) -about [gherkin](https://github.com/alandipert/gherkin), a Lisp -implemented in bash. His presentation led me to ask myself the question -of whether a Lisp could be created using the GNU Make macro language. -As you have probably guessed, the answer to that question is yes. - -Interestingly, the current pedagogical/educational purpose of mal -happened due to a semantic naming accident (naming is such a fraught -task in computer science). If I am remembering correctly, the name -"mal" original meant "MAke Lisp". I do not remember precisely why -I continued to create more implementations, apart from the fact that -it was a fun challenge, but after the make implementation, many of the -others were relatively easy. At some point during that process, -I realized that the multiple implementations and incremental steps -(which was originally just for my own clarity) was a useful learning -tool and so the "mal" name became a double entendre for "Make, A Lisp" -and "make-a-lisp" (and eventually just the latter given that the make -implementation is now just a small part of the whole). - - - - -### Why is some code split into steps and some code not? - -The split between code that goes in steps and code that goes into other files -is not completely arbitrary (a bit arbitrary, but not completely). My rule of -thumb is something like this: if the code is specific and necessary for -implementing a Lisp then it belongs in the step files. If the purpose of the -code is for implementing new dynamic data-types/objects and the functions or -methods that operate on those types, then it goes in separate files. - -If the target language has types and functions that resemble mal types, then -those files tend to be very small or non-existent. Examples: - -* the mal implementation has no types, reader, printer files and - has a trivial core file (just to hoist underlying functions) -* the Clojure implementation has no types file and a fairly trivial - core file -* ruby types and the functions that operate on them are very "Lispy" - so the Ruby types file and core file are very small. - -The env file is somewhat more arbitrary, however, it is -a self-contained module that is implemented early and changes very -little after that, so I decided to separate it. Also, for languages -that have hierarchical maps/dictionaries (e.g. Javascript -objects/prototype chain), you do not necessarily need an env file. - -Another way of summarizing this answer is that the step files -represent the core of what makes something a Lisp, the rest of the -modules are just language specific details (they may be the harder -than the Lisp part, but that is due to the nature of the target -language not because of Lisp functionality per se). - - - - -### Why are the mal/make-a-lisp steps structured the way they are? - -### OR Why is X functionality in step Y instead of step Z? - -There is no single consistent rule that I have used to determine which -functionality goes in which step and the arrangement has changed -numerous times since the beginning of the project. There are several -different goals that I try and balance in determining which -functionality goes into which step: - -* **Optimize Lisp learning**: I want developers who are unfamiliar with - Lisp to be able to use the project and guide to learn about Lisp - without becoming overwhelmed. In many Lisp introductions, concepts - like quoting and homoiconicity (i.e. a user exposed eval function) - are introduced early. But these are fairly foreign to most other - languages so they are introduced in later steps in mal. I also try - to not to concentrate too many Lisp concepts in a single step. So - many steps contain one or two Lisp concepts plus some core function - additions that support those concepts. - -* **Optimize implementation language learning (equal-ish step - sizing)**: I try to structure the steps so that the target - implementation can be learned incrementally. This goal is the one - that has caused me to refactor the steps the most. Different - languages have different areas that they optimize and make simple - for the developer. For example, in Java (prior to 8) and PostScript - creating the equivalent of anonymous functions and function closures - is painful. In other languages, function closures are trivial, but - IO and error handling are tedious when you are first learning the - language (I am looking at you Haskell). So this goal is really about - trying to balance step size across multiple languages. - -* **Practical results early and continuous feedback**: it is - a scientific fact that many small rewards are more motivating than - a single large reward (citation intentionally omitted, get a small - reward by googling it yourself). Each step in mal adds new - functionality that can actually be exercised by the implementer and, - just as importantly, easily tested. - -Also, the step structure of mal/make-a-lisp is not perfect. It never -will be perfect, but there are some areas that could be improved. The -most glaring problem is that step1 is on the heavy/large size because -in most languages you have to implement a good portion of the -reader/printer before you can begin using/testing the step. The -compromise I have settled on for now is to put extra detail in the -process guide for step1 and to be clear that many of the types are -deferrable until later. But I am always open to suggestions. - - - - -### Will you add my new implementation? - -Absolutely! I want mal to have a idiomatic implementation in every -programming language. - -Here are a few guidelines for getting your implementation accepted -into the main repository: - -* Your implementation should follow the existing mal steps and - structure: Lisp-centric code (eval, eval_ast, quasiquote, - macroexpand) in the step files, other code in reader, printer, env, - and core files. See [code layout rationale](#code_split) above. - I encourage you to create implementations that take mal in new - directions for your own learning and experimentation, but for it to - be included in the main repository I ask that it follows the steps - and structure. - -* Your implementation should stick as much as possible to the accepted - idioms and conventions in that language. Try to create an - implementation that will not make an expert in that language say - "Woah, that's a strange way of doing things". And on that topic, - I make no guarantees that the existing implementations are - particularly idiomatic in their target languages (improvements are - welcome). However, if it is clear to me that your implementation is - not idiomatic in a given language then I will probably ask you to - improve it first. - -* Your implementation needs to be complete enough to self-host. This - means that all the mandatory tests should pass in both direct and - self-hosted modes: - ```bash - make "test^[IMPL_NAME]" - make MAL_IMPL=[IMPL_NAME] "test^mal" - ``` - You do not need to pass the final optional tests for stepA that are - marked as optional and not needed for self-hosting (except for the - `time-ms` function which is needed to run the micro-benchmark tests). - -* Create a `Dockerfile` in your directory that installs all the - packages necessary to build and run your implementation. Refer to other - implementations for examples of what the Dockerfile should contain. - Build your docker image and tag it `kanaka/mal-test-[IMPL_NAME]`. - The top-level Makefile has support for building/testing within - docker with the `DOCKERIZE` flag: - ```bash - make DOCKERIZE=1 "test^[IMPL_NAME]" - make DOCKERIZE=1 MAL_IMPL=[IMPL_NAME] "test^mal" - ``` - -* Make sure the CI build and test scripts pass locally: - ```bash - ./ci.sh build [IMPL_NAME] - ./ci.sh test [IMPL_NAME] - ``` - -* If you are creating a new implementation for an existing - implementation (or somebody beats you to the punch while you are - working on it), there is still a chance I will merge your - implementation. If you can make a compelling argument that your - implementation is more idiomatic or significantly better in some way - than the existing implementation then I may replace the existing - one. However, if your approach is different or unique from the - existing implementation, there is still a good chance I will merge - your implementation side-by-side with the existing one. At the very - least, even if I decide not to merge your implementation, I am - certainly willing to link to you implementation once it is - completed. - -* You do not need to implement line editing (i.e. readline) - functionality for your implementation, however, it is a nice - convenience for users of your implementation and I personally find - it saves a lot of time when I am creating a new implementation to - have line edit support early in the process. - -### Why do some mal forms end in "\*" or "!" (swap!, def!, let\*, etc)? - -The forms that end in a bang mutate something: -* **def!** mutates the current environment -* **swap!** and **reset!** mutate an atom to refer to a new value - -The forms that end in a star are similar to similar Clojure forms but -are more limited in functionality: -* **fn\*** does not do parameter destructuring and only supports - a single body form. -* **let\*** does not do parameter destructuring -* **try\*** and **catch\*** do not support type matching of - exceptions - +# Mal/Make-a-Lisp FAQ + + + +### Why did you create mal/make-a-lisp? +### OR Why the name "mal"? +### OR Why? +### OR Wat? + +In November of 2013, Alan Dipert gave a [lightning talk at +Clojure/conj](https://www.youtube.com/watch?v=bmHTFo2Rf2w#t=28m55s) +about [gherkin](https://github.com/alandipert/gherkin), a Lisp +implemented in bash. His presentation led me to ask myself the question +of whether a Lisp could be created using the GNU Make macro language. +As you have probably guessed, the answer to that question is yes. + +Interestingly, the current pedagogical/educational purpose of mal +happened due to a semantic naming accident (naming is such a fraught +task in computer science). If I am remembering correctly, the name +"mal" original meant "MAke Lisp". I do not remember precisely why +I continued to create more implementations, apart from the fact that +it was a fun challenge, but after the make implementation, many of the +others were relatively easy. At some point during that process, +I realized that the multiple implementations and incremental steps +(which was originally just for my own clarity) was a useful learning +tool and so the "mal" name became a double entendre for "Make, A Lisp" +and "make-a-lisp" (and eventually just the latter given that the make +implementation is now just a small part of the whole). + + + + +### Why is some code split into steps and some code not? + +The split between code that goes in steps and code that goes into other files +is not completely arbitrary (a bit arbitrary, but not completely). My rule of +thumb is something like this: if the code is specific and necessary for +implementing a Lisp then it belongs in the step files. If the purpose of the +code is for implementing new dynamic data-types/objects and the functions or +methods that operate on those types, then it goes in separate files. + +If the target language has types and functions that resemble mal types, then +those files tend to be very small or non-existent. Examples: + +* the mal implementation has no types, reader, printer files and + has a trivial core file (just to hoist underlying functions) +* the Clojure implementation has no types file and a fairly trivial + core file +* ruby types and the functions that operate on them are very "Lispy" + so the Ruby types file and core file are very small. + +The env file is somewhat more arbitrary, however, it is +a self-contained module that is implemented early and changes very +little after that, so I decided to separate it. Also, for languages +that have hierarchical maps/dictionaries (e.g. Javascript +objects/prototype chain), you do not necessarily need an env file. + +Another way of summarizing this answer is that the step files +represent the core of what makes something a Lisp, the rest of the +modules are just language specific details (they may be the harder +than the Lisp part, but that is due to the nature of the target +language not because of Lisp functionality per se). + + + + +### Why are the mal/make-a-lisp steps structured the way they are? + +### OR Why is X functionality in step Y instead of step Z? + +There is no single consistent rule that I have used to determine which +functionality goes in which step and the arrangement has changed +numerous times since the beginning of the project. There are several +different goals that I try and balance in determining which +functionality goes into which step: + +* **Optimize Lisp learning**: I want developers who are unfamiliar with + Lisp to be able to use the project and guide to learn about Lisp + without becoming overwhelmed. In many Lisp introductions, concepts + like quoting and homoiconicity (i.e. a user exposed eval function) + are introduced early. But these are fairly foreign to most other + languages so they are introduced in later steps in mal. I also try + to not to concentrate too many Lisp concepts in a single step. So + many steps contain one or two Lisp concepts plus some core function + additions that support those concepts. + +* **Optimize implementation language learning (equal-ish step + sizing)**: I try to structure the steps so that the target + implementation can be learned incrementally. This goal is the one + that has caused me to refactor the steps the most. Different + languages have different areas that they optimize and make simple + for the developer. For example, in Java (prior to 8) and PostScript + creating the equivalent of anonymous functions and function closures + is painful. In other languages, function closures are trivial, but + IO and error handling are tedious when you are first learning the + language (I am looking at you Haskell). So this goal is really about + trying to balance step size across multiple languages. + +* **Practical results early and continuous feedback**: it is + a scientific fact that many small rewards are more motivating than + a single large reward (citation intentionally omitted, get a small + reward by googling it yourself). Each step in mal adds new + functionality that can actually be exercised by the implementer and, + just as importantly, easily tested. + +Also, the step structure of mal/make-a-lisp is not perfect. It never +will be perfect, but there are some areas that could be improved. The +most glaring problem is that step1 is on the heavy/large size because +in most languages you have to implement a good portion of the +reader/printer before you can begin using/testing the step. The +compromise I have settled on for now is to put extra detail in the +process guide for step1 and to be clear that many of the types are +deferrable until later. But I am always open to suggestions. + + + + +### Will you add my new implementation? + +Absolutely! I want mal to have a idiomatic implementation in every +programming language. + +Here are a few guidelines for getting your implementation accepted +into the main repository: + +* Your implementation should follow the existing mal steps and + structure: Lisp-centric code (eval, eval_ast, quasiquote, + macroexpand) in the step files, other code in reader, printer, env, + and core files. See [code layout rationale](#code_split) above. + I encourage you to create implementations that take mal in new + directions for your own learning and experimentation, but for it to + be included in the main repository I ask that it follows the steps + and structure. + +* Your implementation should stick as much as possible to the accepted + idioms and conventions in that language. Try to create an + implementation that will not make an expert in that language say + "Woah, that's a strange way of doing things". And on that topic, + I make no guarantees that the existing implementations are + particularly idiomatic in their target languages (improvements are + welcome). However, if it is clear to me that your implementation is + not idiomatic in a given language then I will probably ask you to + improve it first. + +* Your implementation needs to be complete enough to self-host. This + means that all the mandatory tests should pass in both direct and + self-hosted modes: + ```bash + make "test^[IMPL_NAME]" + make MAL_IMPL=[IMPL_NAME] "test^mal" + ``` + You do not need to pass the final optional tests for stepA that are + marked as optional and not needed for self-hosting (except for the + `time-ms` function which is needed to run the micro-benchmark tests). + +* Create a `Dockerfile` in your directory that installs all the + packages necessary to build and run your implementation. Refer to other + implementations for examples of what the Dockerfile should contain. + Build your docker image and tag it `kanaka/mal-test-[IMPL_NAME]`. + The top-level Makefile has support for building/testing within + docker with the `DOCKERIZE` flag: + ```bash + make DOCKERIZE=1 "test^[IMPL_NAME]" + make DOCKERIZE=1 MAL_IMPL=[IMPL_NAME] "test^mal" + ``` + +* Make sure the CI build and test scripts pass locally: + ```bash + ./ci.sh build [IMPL_NAME] + ./ci.sh test [IMPL_NAME] + ``` + +* If you are creating a new implementation for an existing + implementation (or somebody beats you to the punch while you are + working on it), there is still a chance I will merge your + implementation. If you can make a compelling argument that your + implementation is more idiomatic or significantly better in some way + than the existing implementation then I may replace the existing + one. However, if your approach is different or unique from the + existing implementation, there is still a good chance I will merge + your implementation side-by-side with the existing one. At the very + least, even if I decide not to merge your implementation, I am + certainly willing to link to you implementation once it is + completed. + +* You do not need to implement line editing (i.e. readline) + functionality for your implementation, however, it is a nice + convenience for users of your implementation and I personally find + it saves a lot of time when I am creating a new implementation to + have line edit support early in the process. + +### Why do some mal forms end in "\*" or "!" (swap!, def!, let\*, etc)? + +The forms that end in a bang mutate something: +* **def!** mutates the current environment +* **swap!** and **reset!** mutate an atom to refer to a new value + +The forms that end in a star are similar to similar Clojure forms but +are more limited in functionality: +* **fn\*** does not do parameter destructuring and only supports + a single body form. +* **let\*** does not do parameter destructuring +* **try\*** and **catch\*** do not support type matching of + exceptions + diff --git a/docs/Hints.md b/docs/Hints.md index 3686cc833d..df229b3883 100644 --- a/docs/Hints.md +++ b/docs/Hints.md @@ -1,123 +1,123 @@ -# Mal/Make-a-Lisp Implementation Hints - - - -### How do I get milliseconds since epoch for the "time-ms" function? -### Does the "time-ms" function have to return millisecond since epoch? - -Most languages usually have some way to do this natively even though -it might be buried deeply in the language. If you are having trouble -finding how to do this in your target language, consider asking the -question on stackoverflow (if it has not been asked already) or asking -on a discussion channel for your language because there is a good -chance somebody there knows how and will answer quickly (if there is -a native way at all). - -As a last resort you can always shell out and call the date command -like this: - -``` -date +%s%3N -``` - -There are currently two implementations where this method was -necessary (probably): bash and make. Unfortunately this method is -limited to Linux/UNIX. - -Also, "time-ms" technically just needs to return accurate milliseconds -since some arbitrary point in time (even program start) in order to be -used correctly for timing/benchmarking. For consistency it is best if -it returns epoch milliseconds, but this is not strictly required if -you language limitations make it difficult (e.g. size limit of -integers). - - - - -### How do I implement core/native functions if my language does not have any sort of function references (function pointers, closures, lambdas, etc)? -### How do I implement mal functions in step4 if I do not have function references? - -There are very few language that do not have any sort of function -references so I suggest asking about the specific problem you are -having on stackoverflow or a discussion channel for your language. In -the rare case where you have a language without some sort of function -reference abstraction, then you may have to implement a single -function with a large switch statement (or equivalent) that calls out -to the appropriate native core function ("+", "list", "throw", etc). -In other words, you create a function that implements "function -references" rather than using a feature of your language. You will -still need to store the symbol names for those function in the base -REPL environment but you will have some sort of tagging or marker that -will indicate to the `EVAL` function that it should call your "big -switch" function. - -In addition, if your language has no sort of closure/anonymous -function capability (note that with sufficient object oriented -features you can implement closure like functionality), then in step4 -you will need to borrow the way that functions are implemented from -step5. In other words, functions become a normal data type that stores -the function body (AST), the parameter list and the environment at the -time the function is defined. When the function is invoked, `EVAL` -will then evaluate these stored items rather than invoking a function -closure. It is less convenient to have to do this at step4, but the -bright side is that step5 will be simpler because you just have to -implement the TCO loop because you have already refactored how -functions are stored in step4. - - - -### How do I implement terminal input and output in a language which does not have standard I/O capabilities? - -If your target language has some way to get data in and out while it -is running (even if it is not standard terminal or file I/O) then you -will need to create some sort of wrapper script (see -`vimscript/run_vimscript.sh`) or call out to a shell script (see -`make/readline.mk` and `make/util.mk`) or implement some other -"appropriate" hack to to get the data in and out. As long -as your implementation can be used with the test runner and the hack -is just for working around I/O limitations in your target language, -it is considered legitimate for upstream inclusion. - -### How do I read the command-line arguments if my language runtime doesn't support access to them? - -Most languages give access to the command-line arguments that were passed to -the program, either as an argument to the `main` function (like `argc` and -`argv` in C) or as a global variable (like `sys.argv` in Python). If your -target language doesn't have such mechanisms, consider adding a wrapper script -that will read the command-line arguments that were passed to the script and -pass them to the program in a way that the program can read. This might be -through an environment variable (if the target language allows reading from -environment variables) or through a temporary file. - - - - -### How can I implement the reader without using a mutable object? - -You do not need a mutable object, but you do need someway of keeping -track of the current position in the token list. One way to implement -this is to pass both the token list and the current position to the -reader functions (read_form, read_list, read_atom, etc) and return -both the parsed AST and the new token list position. If your language -does not allow multiple values to be returned from functions then you -may need to define a data structure to return both the new position -and the parsed AST together. In other words, the pseudo-code would -look something like this: - -``` -ast, position = read_list(tokens, position) -``` - ---- - -Answers for the following questions are TBD. - -### How do I implement slurp in a language without the ability to read raw file data? - - - -### How do I support raising/throwing arbitrary objects in a language that does not support that? -### What do I do if my implementation language only supports string exceptions? - - - +# Mal/Make-a-Lisp Implementation Hints + + + +### How do I get milliseconds since epoch for the "time-ms" function? +### Does the "time-ms" function have to return millisecond since epoch? + +Most languages usually have some way to do this natively even though +it might be buried deeply in the language. If you are having trouble +finding how to do this in your target language, consider asking the +question on stackoverflow (if it has not been asked already) or asking +on a discussion channel for your language because there is a good +chance somebody there knows how and will answer quickly (if there is +a native way at all). + +As a last resort you can always shell out and call the date command +like this: + +``` +date +%s%3N +``` + +There are currently two implementations where this method was +necessary (probably): bash and make. Unfortunately this method is +limited to Linux/UNIX. + +Also, "time-ms" technically just needs to return accurate milliseconds +since some arbitrary point in time (even program start) in order to be +used correctly for timing/benchmarking. For consistency it is best if +it returns epoch milliseconds, but this is not strictly required if +you language limitations make it difficult (e.g. size limit of +integers). + + + + +### How do I implement core/native functions if my language does not have any sort of function references (function pointers, closures, lambdas, etc)? +### How do I implement mal functions in step4 if I do not have function references? + +There are very few language that do not have any sort of function +references so I suggest asking about the specific problem you are +having on stackoverflow or a discussion channel for your language. In +the rare case where you have a language without some sort of function +reference abstraction, then you may have to implement a single +function with a large switch statement (or equivalent) that calls out +to the appropriate native core function ("+", "list", "throw", etc). +In other words, you create a function that implements "function +references" rather than using a feature of your language. You will +still need to store the symbol names for those function in the base +REPL environment but you will have some sort of tagging or marker that +will indicate to the `EVAL` function that it should call your "big +switch" function. + +In addition, if your language has no sort of closure/anonymous +function capability (note that with sufficient object oriented +features you can implement closure like functionality), then in step4 +you will need to borrow the way that functions are implemented from +step5. In other words, functions become a normal data type that stores +the function body (AST), the parameter list and the environment at the +time the function is defined. When the function is invoked, `EVAL` +will then evaluate these stored items rather than invoking a function +closure. It is less convenient to have to do this at step4, but the +bright side is that step5 will be simpler because you just have to +implement the TCO loop because you have already refactored how +functions are stored in step4. + + + +### How do I implement terminal input and output in a language which does not have standard I/O capabilities? + +If your target language has some way to get data in and out while it +is running (even if it is not standard terminal or file I/O) then you +will need to create some sort of wrapper script (see +`vimscript/run_vimscript.sh`) or call out to a shell script (see +`make/readline.mk` and `make/util.mk`) or implement some other +"appropriate" hack to to get the data in and out. As long +as your implementation can be used with the test runner and the hack +is just for working around I/O limitations in your target language, +it is considered legitimate for upstream inclusion. + +### How do I read the command-line arguments if my language runtime doesn't support access to them? + +Most languages give access to the command-line arguments that were passed to +the program, either as an argument to the `main` function (like `argc` and +`argv` in C) or as a global variable (like `sys.argv` in Python). If your +target language doesn't have such mechanisms, consider adding a wrapper script +that will read the command-line arguments that were passed to the script and +pass them to the program in a way that the program can read. This might be +through an environment variable (if the target language allows reading from +environment variables) or through a temporary file. + + + + +### How can I implement the reader without using a mutable object? + +You do not need a mutable object, but you do need someway of keeping +track of the current position in the token list. One way to implement +this is to pass both the token list and the current position to the +reader functions (read_form, read_list, read_atom, etc) and return +both the parsed AST and the new token list position. If your language +does not allow multiple values to be returned from functions then you +may need to define a data structure to return both the new position +and the parsed AST together. In other words, the pseudo-code would +look something like this: + +``` +ast, position = read_list(tokens, position) +``` + +--- + +Answers for the following questions are TBD. + +### How do I implement slurp in a language without the ability to read raw file data? + + + +### How do I support raising/throwing arbitrary objects in a language that does not support that? +### What do I do if my implementation language only supports string exceptions? + + + diff --git a/docs/TODO b/docs/TODO index 8be2f0284a..563553d552 100644 --- a/docs/TODO +++ b/docs/TODO @@ -1,140 +1,140 @@ -In process/stepA.gliffy, add inc and remove *gensym-counter*. -Then refresh the .png files. - ---------------------------------------------- - -General: - - add chat bot for #mal - - move tokenizer.mal and reader.mal from malc to ./lib directory - - - Finish guide.md - - mention that identifier names are suggested. some have run - into collisions with READ,EVAL,PRINT in case insensitive - languages - - simplify: "X argument (list element Y)" -> ast[Y] - - more clarity about when to peek and poke in read_list and - read_form - - tokenizer: use first group rather than whole match (to - eliminate whitespace/commas) - -All Implementations: - - regular expression matching in runtest - - add re (use in rep) everywhere and use that (to avoid printing) - - fix stepA soft failures: lua matlab miniMAL perl racket - -Other ideas for All: - - propagate/print errors when self-hosted - - redefine (defmacro!) as (def! (macro*)) - - Fix/implement interop in more implementations - - - metadata on symbols (as per Clojure) - - metadata as a map only. ^ merges metadata in the reader itself. - Line numbers in metadata from reader. - - protocols! - - https://github.com/pixie-lang/pixie - - http://www.toccata.io/2015/01/Mapping/ - - namespaces - - environments first class: *ENV*, *outer* defined by env-new - - namespaces is *namespaces* map in environment which maps namespace - names to other environments. - - def! become an alias for (env-set! *ENV* 'sym value) - - Namespace lookup: go up the environment hierarchy until - a *namespaces* map is found with the namespace name being - looked up. Then the symbol would be looked up starting in - the namespace environment. Need protocols first probably. - - - multi-line REPL read - - loop/recur ? - - gensym reader inside quasiquote - - standalone executable - - ---------------------------------------------- - -Bash: - - explore using ${!prefix*} syntax (more like make impl) - - GC - -C: - - come up with better way to do 20 vararg code - -C#: - - accumulates line breaks with mal/clojurewest2014.mal - - interop: http://www.ckode.dk/programming/eval-in-c-yes-its-possible/ - -CoffeeScript: - - make target to compile to JS - -Go: - - consider variable arguments in places where it makes sense - https://gobyexample.com/variadic-functions - -Haskell: - - TCO using seq/bang patterns: - http://stackoverflow.com/questions/9149183/tail-optimization-guarantee-loop-encoding-in-haskell - - immediately exits mal/clojurewest2014.mal ("\/" exception) - -Java: - - build step, don't use mvn in run script - - Use gradle instead of mvn - http://blog.paralleluniverse.co/2014/05/01/modern-java/ - -Javascript: - - interop: adopt techniques from miniMAL - -Make: - - allow '_' in make variable names - - hash-map with space in key string - - errors should propagate up from within load-file - - GC: explore using "undefine" directive in Make 3.82 - -Mal: - - line numbers in errors - - step5_tco - -miniMAL: - - figure out why {} literals are "static"/persistent - -ObjPascal: - - verify that GC/reference counting works - - fix comment by itself error at REPL - -plpgsql: - - maybe combine wrap.sh and run - -Perl: - - fix metadata on native functions - - fix extra line breaks at REPL - -Postscript: - - add negative numbers - - fix blank line after comments - - fix command line arg processing (doesn't run file specified) - -Powershell: - - convert function with "abc_def" to "abc-def" - - remove extraneous return statements at end of functions - - remove unnecessary semi-colons - - use ArrayList instead of Array for performance - - new test to test Keys/keys as hash-map key - - test *? predicates with nil - -R: - - tracebacks in errors - - fix running from different directory - -Racket - - metadata on collections - -Rust: - - fix 'make all' invocation of cargo build - -Scala - - readline - - fix exception when finished running something on command line - -VHDL: - - combine run_vhdl.sh and run - -vimscript: - - combine run_vimscript.sh and run +In process/stepA.gliffy, add inc and remove *gensym-counter*. +Then refresh the .png files. + +--------------------------------------------- + +General: + - add chat bot for #mal + - move tokenizer.mal and reader.mal from malc to ./lib directory + + - Finish guide.md + - mention that identifier names are suggested. some have run + into collisions with READ,EVAL,PRINT in case insensitive + languages + - simplify: "X argument (list element Y)" -> ast[Y] + - more clarity about when to peek and poke in read_list and + read_form + - tokenizer: use first group rather than whole match (to + eliminate whitespace/commas) + +All Implementations: + - regular expression matching in runtest + - add re (use in rep) everywhere and use that (to avoid printing) + - fix stepA soft failures: lua matlab miniMAL perl racket + +Other ideas for All: + - propagate/print errors when self-hosted + - redefine (defmacro!) as (def! (macro*)) + - Fix/implement interop in more implementations + + - metadata on symbols (as per Clojure) + - metadata as a map only. ^ merges metadata in the reader itself. + Line numbers in metadata from reader. + - protocols! + - https://github.com/pixie-lang/pixie + - http://www.toccata.io/2015/01/Mapping/ + - namespaces + - environments first class: *ENV*, *outer* defined by env-new + - namespaces is *namespaces* map in environment which maps namespace + names to other environments. + - def! become an alias for (env-set! *ENV* 'sym value) + - Namespace lookup: go up the environment hierarchy until + a *namespaces* map is found with the namespace name being + looked up. Then the symbol would be looked up starting in + the namespace environment. Need protocols first probably. + + - multi-line REPL read + - loop/recur ? + - gensym reader inside quasiquote + - standalone executable + + +--------------------------------------------- + +Bash: + - explore using ${!prefix*} syntax (more like make impl) + - GC + +C: + - come up with better way to do 20 vararg code + +C#: + - accumulates line breaks with mal/clojurewest2014.mal + - interop: http://www.ckode.dk/programming/eval-in-c-yes-its-possible/ + +CoffeeScript: + - make target to compile to JS + +Go: + - consider variable arguments in places where it makes sense + https://gobyexample.com/variadic-functions + +Haskell: + - TCO using seq/bang patterns: + http://stackoverflow.com/questions/9149183/tail-optimization-guarantee-loop-encoding-in-haskell + - immediately exits mal/clojurewest2014.mal ("\/" exception) + +Java: + - build step, don't use mvn in run script + - Use gradle instead of mvn + http://blog.paralleluniverse.co/2014/05/01/modern-java/ + +Javascript: + - interop: adopt techniques from miniMAL + +Make: + - allow '_' in make variable names + - hash-map with space in key string + - errors should propagate up from within load-file + - GC: explore using "undefine" directive in Make 3.82 + +Mal: + - line numbers in errors + - step5_tco + +miniMAL: + - figure out why {} literals are "static"/persistent + +ObjPascal: + - verify that GC/reference counting works + - fix comment by itself error at REPL + +plpgsql: + - maybe combine wrap.sh and run + +Perl: + - fix metadata on native functions + - fix extra line breaks at REPL + +Postscript: + - add negative numbers + - fix blank line after comments + - fix command line arg processing (doesn't run file specified) + +Powershell: + - convert function with "abc_def" to "abc-def" + - remove extraneous return statements at end of functions + - remove unnecessary semi-colons + - use ArrayList instead of Array for performance + - new test to test Keys/keys as hash-map key + - test *? predicates with nil + +R: + - tracebacks in errors + - fix running from different directory + +Racket + - metadata on collections + +Rust: + - fix 'make all' invocation of cargo build + +Scala + - readline + - fix exception when finished running something on command line + +VHDL: + - combine run_vhdl.sh and run + +vimscript: + - combine run_vimscript.sh and run diff --git a/docs/cheatsheet.html b/docs/cheatsheet.html index 28719052b3..70f5ee44f1 100644 --- a/docs/cheatsheet.html +++ b/docs/cheatsheet.html @@ -1,257 +1,257 @@ - - - - - -

Make-A-Lisp Cheatsheet

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Step 1 Step 6
- -
reader.EXT:
-  Reader(tokens) object: position, next(), peek()
-  tokenize:  /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/
-  read_atom: int, float, string (escaped), keyword, nil, true, false, symbol
-  read_list: repeatedly read_form until end token (EOF is error)
-  read_form: expand reader macros, read_list (vector/maps too), or read_atom
-  read_str:  tokenize, error if no tokens, call read_form(Reader(tokens))
-printer.EXT:
-  pr_str(ast, print_readably):
-    - map pr_str across collections
-    - unescape strings if print_readably
-step1_read_print.EXT:
-  main(args): loop: writeline PRINT(EVAL(READ(readline()), ""))
-
- 		-
core.EXT:
-  read-string: call reader.read_str
-  slurp: return file content as a string
-  atom, atom?, deref, reset!, swap!: atom functions
-step6_file.EXT:
-  main(args):
-    - add eval and *ARGV* to repl_env
-    - define load-file using rep
-    - if args, set *ARGV* to rest(args) and call load-file with args[0]
-
-
-
-
-
-
   
Step 2 Step 7
-
step2_eval.EXT:
-  eval_ast(ast, env): lookup symbols in env, map EVAL across collections
-  EVAL(ast, env):
-    - if not list?(ast), return eval_ast(ast, env)
-    - otherwise apply (ast is a list):
-      el = eval_ast(ast, env)
-      return el[0](rest(el))
-  main(args): loop: writeline PRINT(EVAL(READ(readline()), {+: add, ...}))
-
-
-
-
- 		-
core.EXT:
-  cons, concat: sequence functions
-step7_quote.EXT:
-  quasiquote(ast):
-    - ast is empty or not a list   -> (quote ast)
-    - (unquote FOO)                -> FOO
-    - ((splice-unquote FOO) BAR..) -> (concat FOO quasiquote(BAR...))
-    - (FOO BAR...)                 -> (cons FOO quasiquote(BAR...))
-  EVAL(ast, env):
-    - quote      -> return ast[1]
-    - quasiquote -> set ast to quasiquote(ast[1]), loop
-
-
   
Step 3 Step 8
-
env.EXT:
-  Env(outer) object: data, set(k, v), find(k), get(k)
-step3_env.EXT:
-  eval_ast(ast, env): switch to env.get for symbol lookup
-  EVAL(ast, env):
-    - def!  -> return env.set(ast[1], EVAL(ast[2], env))
-    - let*  -> create new env let_env
-               for each ODD/EVEN pair in ast[1]:
-                 let_env.set(ODD, EVAL(EVEN, let_env))
-               return EVAL(ast[2], let_env)
-  main(args): populate repl_env with numeric functions using repl_env.set
-
- 		-
core.EXT:
-  nth, first, rest: sequence functions
-step8_macros.EXT:
-  macroexpand(ast, env):
-    - while env.get(ast[0]) is a macro: ast = env.get(ast[0])(rest(ast))
-  EVAL(ast, env):
-    - before apply section, add ast = macroexpand(ast, env)
-    - defmacro!   -> same as def!, but set mal function macro flag
-    - macroexpand -> return macroexpand(ast[1], env)
-
-
-
-
   
Step 4 Step 9
-
env.EXT:
-  Env(outer, binds, exprs) object: map binds to exprs, handle "&" as variadic
-core.EXT:
-  =: recursive compare of collections
-  pr-str, str: return pr_str(arg, true) join " ", pr_str(arg, false) join ""
-  prn, println: print pr_str(arg, true) join "", pr_str(arg, false) join ""
-  <, <=, >, >=, +, -, *, /: numeric comparison and numeric operations
-  list, list?, empty?, count: sequence functions
-step4_do_if_fn.EXT:
-  EVAL(ast, env):
-    - do  -> return last element of eval_ast(ast, env)
-    - if  -> if EVAL(ast[1], env): return EVAL(ast[2], env)
-             else                : return EVAL(ast[3], env)
-    - fn* -> return closure:
-               (args) -> EVAL(ast[2], new Env(env, ast[1], args))
-  main(args): populate repl_env with core functions, define not using rep()
-
- 		-
core.EXT:
-  throw: raise mal value as exception (maybe wrap in native exception)
-  vector, vector?: sequence functions
-  hash-map, get, contains?, keys, vals: hash-map functions
-  assoc, dissoc: immutable hash-map transform functions
-  apply(f, args..., last): return f(concat(args, last))
-  map(f, args): return list of mapping f on each args
-step9_try.EXT:
-  EVAL(ast, env):
-    - try* -> try EVAL(ast[1], env)
-                catch exception exc (unwrap if necessary):
-                  new err_env with ast[2][1] symbol bound to exc
-                  EVAL(ast[2][2], err_env)
-
-
-
-
-
   
Step 5 Step A
-
step5_tco.EXT:
-  EVAL(ast, env):
-    - top level loop in EVAL
-    - let*  -> set env to let_env, set ast to ast[2], loop
-    - do    -> eval_ast of middle elements, sets ast to last element, loop
-    - if    -> set ast to ast[2] or ast[3] (or nil) depending condition, loop
-    - fn*   -> return new mal function type f with:
-                f.ast=ast[2], f.params=ast[1], f.env=env
-    - apply -> el = eval_ast(ast, env)
-               f = el[0]
-               if f is a mal function: ast = f.ast and env = f.env, loop
-               else                  : return el[0](rest(el))
-
-
- 		-
core.EXT:
-  string?: true if string
-  readline: prompt and read a line of input (synchronous)
-  time-ms: return milliseconds since epoch (1970-1-1)
-  conj, seq: type specific sequence functions
-  meta, with-meta: metadata functions
-step9_try.EXT:
-  EVAL(ast, env):
-    - set *host-language* in repl_env to host language name
-  main(args): rep("(println (str \"Mal [\" *host-language* \"]\"))")
-
-
   
- - + + + + + +

Make-A-Lisp Cheatsheet

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Step 1 Step 6
+ +
reader.EXT:
+  Reader(tokens) object: position, next(), peek()
+  tokenize:  /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/
+  read_atom: int, float, string (escaped), keyword, nil, true, false, symbol
+  read_list: repeatedly read_form until end token (EOF is error)
+  read_form: expand reader macros, read_list (vector/maps too), or read_atom
+  read_str:  tokenize, error if no tokens, call read_form(Reader(tokens))
+printer.EXT:
+  pr_str(ast, print_readably):
+    - map pr_str across collections
+    - unescape strings if print_readably
+step1_read_print.EXT:
+  main(args): loop: writeline PRINT(EVAL(READ(readline()), ""))
+
+ 		+
core.EXT:
+  read-string: call reader.read_str
+  slurp: return file content as a string
+  atom, atom?, deref, reset!, swap!: atom functions
+step6_file.EXT:
+  main(args):
+    - add eval and *ARGV* to repl_env
+    - define load-file using rep
+    - if args, set *ARGV* to rest(args) and call load-file with args[0]
+
+
+
+
+
+
   
Step 2 Step 7
+
step2_eval.EXT:
+  eval_ast(ast, env): lookup symbols in env, map EVAL across collections
+  EVAL(ast, env):
+    - if not list?(ast), return eval_ast(ast, env)
+    - otherwise apply (ast is a list):
+      el = eval_ast(ast, env)
+      return el[0](rest(el))
+  main(args): loop: writeline PRINT(EVAL(READ(readline()), {+: add, ...}))
+
+
+
+
+ 		+
core.EXT:
+  cons, concat: sequence functions
+step7_quote.EXT:
+  quasiquote(ast):
+    - ast is empty or not a list   -> (quote ast)
+    - (unquote FOO)                -> FOO
+    - ((splice-unquote FOO) BAR..) -> (concat FOO quasiquote(BAR...))
+    - (FOO BAR...)                 -> (cons FOO quasiquote(BAR...))
+  EVAL(ast, env):
+    - quote      -> return ast[1]
+    - quasiquote -> set ast to quasiquote(ast[1]), loop
+
+
   
Step 3 Step 8
+
env.EXT:
+  Env(outer) object: data, set(k, v), find(k), get(k)
+step3_env.EXT:
+  eval_ast(ast, env): switch to env.get for symbol lookup
+  EVAL(ast, env):
+    - def!  -> return env.set(ast[1], EVAL(ast[2], env))
+    - let*  -> create new env let_env
+               for each ODD/EVEN pair in ast[1]:
+                 let_env.set(ODD, EVAL(EVEN, let_env))
+               return EVAL(ast[2], let_env)
+  main(args): populate repl_env with numeric functions using repl_env.set
+
+ 		+
core.EXT:
+  nth, first, rest: sequence functions
+step8_macros.EXT:
+  macroexpand(ast, env):
+    - while env.get(ast[0]) is a macro: ast = env.get(ast[0])(rest(ast))
+  EVAL(ast, env):
+    - before apply section, add ast = macroexpand(ast, env)
+    - defmacro!   -> same as def!, but set mal function macro flag
+    - macroexpand -> return macroexpand(ast[1], env)
+
+
+
+
   
Step 4 Step 9
+
env.EXT:
+  Env(outer, binds, exprs) object: map binds to exprs, handle "&" as variadic
+core.EXT:
+  =: recursive compare of collections
+  pr-str, str: return pr_str(arg, true) join " ", pr_str(arg, false) join ""
+  prn, println: print pr_str(arg, true) join "", pr_str(arg, false) join ""
+  <, <=, >, >=, +, -, *, /: numeric comparison and numeric operations
+  list, list?, empty?, count: sequence functions
+step4_do_if_fn.EXT:
+  EVAL(ast, env):
+    - do  -> return last element of eval_ast(ast, env)
+    - if  -> if EVAL(ast[1], env): return EVAL(ast[2], env)
+             else                : return EVAL(ast[3], env)
+    - fn* -> return closure:
+               (args) -> EVAL(ast[2], new Env(env, ast[1], args))
+  main(args): populate repl_env with core functions, define not using rep()
+
+ 		+
core.EXT:
+  throw: raise mal value as exception (maybe wrap in native exception)
+  vector, vector?: sequence functions
+  hash-map, get, contains?, keys, vals: hash-map functions
+  assoc, dissoc: immutable hash-map transform functions
+  apply(f, args..., last): return f(concat(args, last))
+  map(f, args): return list of mapping f on each args
+step9_try.EXT:
+  EVAL(ast, env):
+    - try* -> try EVAL(ast[1], env)
+                catch exception exc (unwrap if necessary):
+                  new err_env with ast[2][1] symbol bound to exc
+                  EVAL(ast[2][2], err_env)
+
+
+
+
+
   
Step 5 Step A
+
step5_tco.EXT:
+  EVAL(ast, env):
+    - top level loop in EVAL
+    - let*  -> set env to let_env, set ast to ast[2], loop
+    - do    -> eval_ast of middle elements, sets ast to last element, loop
+    - if    -> set ast to ast[2] or ast[3] (or nil) depending condition, loop
+    - fn*   -> return new mal function type f with:
+                f.ast=ast[2], f.params=ast[1], f.env=env
+    - apply -> el = eval_ast(ast, env)
+               f = el[0]
+               if f is a mal function: ast = f.ast and env = f.env, loop
+               else                  : return el[0](rest(el))
+
+
+ 		+
core.EXT:
+  string?: true if string
+  readline: prompt and read a line of input (synchronous)
+  time-ms: return milliseconds since epoch (1970-1-1)
+  conj, seq: type specific sequence functions
+  meta, with-meta: metadata functions
+step9_try.EXT:
+  EVAL(ast, env):
+    - set *host-language* in repl_env to host language name
+  main(args): rep("(println (str \"Mal [\" *host-language* \"]\"))")
+
+
   
+ + diff --git a/docs/exercises.md b/docs/exercises.md index 6fa7869417..c9885c549b 100644 --- a/docs/exercises.md +++ b/docs/exercises.md @@ -1,129 +1,129 @@ -# Exercises to learn MAL - -The process introduces LISP by describing the internals of selected -low-level constructs. As a complementary and more traditional -approach, you may want to solve the following exercises in the MAL -language itself, using any of the existing implementations. - -You are encouraged to use the shortcuts defined in the step files -(`not`...) and `the `lib/` subdirectory (`reduce`...) whenever you -find that they increase the readability. - -The difficulty is progressive in each section, but they focus on -related topics and it is recommended to start them in parallel. - -Some solutions are given in the `examples` directory. Feel free to -submit new solutions, or new exercises. - -## Replace parts of the process with native constructs - -Once you have a working implementation, you may want to implement -parts of the process inside the MAL language itself. This has no other -purpose than learning the MAL language. Once it exists, a built-in -implementation will always be more efficient than a native -implementation. Also, the functions described in MAL process are -selected for educative purposes, so portability accross -implementations does not matter much. - -You may easily check your answers by passing them directly to the -interpreter. They will hide the built-in functions carrying the same -names, and the usual tests will check them. -``` -make REGRESS=1 TEST_OPTS='--hard --pre-eval=\(load-file\ \"../answer.mal\"\)' test^IMPL^stepA -``` - -- Implement `nil?`, `true?`, `false?`, `empty?` and `sequential` with - another built-in function. - -- Implement `>`, `<=` and `>=` with `<`. - -- Implement `list`, `vec`, `prn`, `hash-map` and `swap!` as non-recursive - functions. - -- Implement `count`, `nth`, `map`, `concat` and `conj` with the empty - constructor `()`, `empty?`, `cons`, `first` and `rest`. - - You may use `or` to make the definition of `nth` a bit less ugly, - but avoid `cond` because its definition refers to `nth`. - - Let `count` and `nth` benefit from tail call optimization. - - Try to replace explicit recursions with calls to `reduce` and `foldr`. - - Once you have tested your solution, you should comment at least - `nth`. Many implementations, for example `foldr` in `core.mal`, - rely on an efficient `nth` built-in function. - -- Implement the `do` special as a non-recursive function. The special - form will hide your implementation, so in order to test it, you will - need to give it another name and adapt the test accordingly. - -- Implement quoting with macros. - The same remark applies. - -- Implement most of `let*` as a macro that uses `fn*` and recursion. - The same remark applies. - A macro is necessary because a function would attempt to evaluate - the first argument. - - Once your answer passes most tests and you understand which part is - tricky, you should search for black magic recipes on the web. Few of - us mortals are known to have invented a full solution on their own. - -- Implement `apply`. - -- Implement maps using lists. - - Recall how maps must be evaluated. - - In the tests, you may want to replace `{...}` with `(hash-map ...)`. - - An easy solution relies on lists alterning keys and values, so - that the `hash-map` is only a list in reverse order so that the - last definition takes precedence during searches. - - As a more performant solution will use lists to construct trees, - and ideally keep them balanced. You will find examples in most - teaching material about functional languages. - - Recall that `dissoc` is an optional feature. One you can implement - dissoc is by assoc'ing a replacement value that is a magic delete - keyword (e.g.: `__..DELETED..__`) which allows you to shadow - values in the lower levels of the structure. The hash map - functions have to detect that and do the right thing. e.g. `(keys - ...)` might have to keep track of deleted values as it is scanning - the tree and not add those keys when it finds them further down - the tree. - -- Implement macros within MAL. - -## More folds - -- Compute the sum of a sequence of numbers. -- Compute the product of a sequence of numbers. - -- Compute the logical conjunction ("and") and disjunction ("or") of a - sequence of MAL values interpreted as boolean values. For example, - `(conjunction [true 1 0 "" "a" nil true {}])` - should evaluate to `false` or `nil` because of the `nil` element. - - Why are folds not the best solution here, in terms of average - performances? - -- Does "-2-3-4" translate to `(reduce - 0 [2 3 4])`? - -- Suggest better solutions for - `(reduce str "" xs)` and - `(reduce concat [] xs)`. - -- What does `(reduce (fn* [acc _] acc) xs)` nil answer? - -- The answer is `(fn* [xs] (reduce (fn* [_ x] x) nil xs))`. - What was the question? - -- What is the intent of - `(reduce (fn* [acc x] (if (< acc x) x acc)) 0 xs)`? - - Why is it the wrong answer? - -- Though `(sum (map count xs))` or `(count (apply concat xs))` can be - considered more readable, implement the same effect with a single loop. -- Compute the maximal length in a list of lists. - -- How would you name - `(fn* [& fs] (foldr (fn* [f acc] (fn* [x] (f (acc x)))) identity fs))`? +# Exercises to learn MAL + +The process introduces LISP by describing the internals of selected +low-level constructs. As a complementary and more traditional +approach, you may want to solve the following exercises in the MAL +language itself, using any of the existing implementations. + +You are encouraged to use the shortcuts defined in the step files +(`not`...) and `the `lib/` subdirectory (`reduce`...) whenever you +find that they increase the readability. + +The difficulty is progressive in each section, but they focus on +related topics and it is recommended to start them in parallel. + +Some solutions are given in the `examples` directory. Feel free to +submit new solutions, or new exercises. + +## Replace parts of the process with native constructs + +Once you have a working implementation, you may want to implement +parts of the process inside the MAL language itself. This has no other +purpose than learning the MAL language. Once it exists, a built-in +implementation will always be more efficient than a native +implementation. Also, the functions described in MAL process are +selected for educative purposes, so portability accross +implementations does not matter much. + +You may easily check your answers by passing them directly to the +interpreter. They will hide the built-in functions carrying the same +names, and the usual tests will check them. +``` +make REGRESS=1 TEST_OPTS='--hard --pre-eval=\(load-file\ \"../answer.mal\"\)' test^IMPL^stepA +``` + +- Implement `nil?`, `true?`, `false?`, `empty?` and `sequential` with + another built-in function. + +- Implement `>`, `<=` and `>=` with `<`. + +- Implement `list`, `vec`, `prn`, `hash-map` and `swap!` as non-recursive + functions. + +- Implement `count`, `nth`, `map`, `concat` and `conj` with the empty + constructor `()`, `empty?`, `cons`, `first` and `rest`. + + You may use `or` to make the definition of `nth` a bit less ugly, + but avoid `cond` because its definition refers to `nth`. + + Let `count` and `nth` benefit from tail call optimization. + + Try to replace explicit recursions with calls to `reduce` and `foldr`. + + Once you have tested your solution, you should comment at least + `nth`. Many implementations, for example `foldr` in `core.mal`, + rely on an efficient `nth` built-in function. + +- Implement the `do` special as a non-recursive function. The special + form will hide your implementation, so in order to test it, you will + need to give it another name and adapt the test accordingly. + +- Implement quoting with macros. + The same remark applies. + +- Implement most of `let*` as a macro that uses `fn*` and recursion. + The same remark applies. + A macro is necessary because a function would attempt to evaluate + the first argument. + + Once your answer passes most tests and you understand which part is + tricky, you should search for black magic recipes on the web. Few of + us mortals are known to have invented a full solution on their own. + +- Implement `apply`. + +- Implement maps using lists. + - Recall how maps must be evaluated. + - In the tests, you may want to replace `{...}` with `(hash-map ...)`. + - An easy solution relies on lists alterning keys and values, so + that the `hash-map` is only a list in reverse order so that the + last definition takes precedence during searches. + - As a more performant solution will use lists to construct trees, + and ideally keep them balanced. You will find examples in most + teaching material about functional languages. + - Recall that `dissoc` is an optional feature. One you can implement + dissoc is by assoc'ing a replacement value that is a magic delete + keyword (e.g.: `__..DELETED..__`) which allows you to shadow + values in the lower levels of the structure. The hash map + functions have to detect that and do the right thing. e.g. `(keys + ...)` might have to keep track of deleted values as it is scanning + the tree and not add those keys when it finds them further down + the tree. + +- Implement macros within MAL. + +## More folds + +- Compute the sum of a sequence of numbers. +- Compute the product of a sequence of numbers. + +- Compute the logical conjunction ("and") and disjunction ("or") of a + sequence of MAL values interpreted as boolean values. For example, + `(conjunction [true 1 0 "" "a" nil true {}])` + should evaluate to `false` or `nil` because of the `nil` element. + + Why are folds not the best solution here, in terms of average + performances? + +- Does "-2-3-4" translate to `(reduce - 0 [2 3 4])`? + +- Suggest better solutions for + `(reduce str "" xs)` and + `(reduce concat [] xs)`. + +- What does `(reduce (fn* [acc _] acc) xs)` nil answer? + +- The answer is `(fn* [xs] (reduce (fn* [_ x] x) nil xs))`. + What was the question? + +- What is the intent of + `(reduce (fn* [acc x] (if (< acc x) x acc)) 0 xs)`? + + Why is it the wrong answer? + +- Though `(sum (map count xs))` or `(count (apply concat xs))` can be + considered more readable, implement the same effect with a single loop. +- Compute the maximal length in a list of lists. + +- How would you name + `(fn* [& fs] (foldr (fn* [f acc] (fn* [x] (f (acc x)))) identity fs))`? diff --git a/docs/graph/README.md b/docs/graph/README.md index dbcd3b2001..05a86f2e71 100644 --- a/docs/graph/README.md +++ b/docs/graph/README.md @@ -1,46 +1,46 @@ -# Mal Implementation Stats Graph - - -## Updating the data - -* Install prerequisites: - -``` -sudo aptitude install ruby2.3-dev -sudo gem install travis --no-rdoc --no-ri -``` - -* Download the latest successful travis build (BUILD is the travis - build number): - -``` -cd docs/graph - -BUILD=1490 - -for x in $(seq 1 109); do echo ${BUILD}/${x}; mkdir -p logs/${BUILD}; while ! travis logs ${BUILD}.${x} > logs/${BUILD}/${x}; do true; done; done -``` - -* Run the [StackOverflow tags query](https://data.stackexchange.com/stackoverflow/query/edit/1013465) and update the CSV link: - -``` -export SO_TAG_CSV_URL=... # from the query page - E.G. -export SO_TAG_CSV_URL=https://data.stackexchange.com/stackoverflow/csv/1451851 -``` - -* Remove/clean all generated files: - -``` -make -C ../.. clean -``` - -* Download GitHub and StackOverflow data and generate the final - combined data set: - -``` -PATH=$PATH:~/personal/programming/loccount - -npm install -time VERBOSE=1 node ./collect_data.js logs/${BUILD}/ all_data.json -``` +# Mal Implementation Stats Graph + + +## Updating the data + +* Install prerequisites: + +``` +sudo aptitude install ruby2.3-dev +sudo gem install travis --no-rdoc --no-ri +``` + +* Download the latest successful travis build (BUILD is the travis + build number): + +``` +cd docs/graph + +BUILD=1490 + +for x in $(seq 1 109); do echo ${BUILD}/${x}; mkdir -p logs/${BUILD}; while ! travis logs ${BUILD}.${x} > logs/${BUILD}/${x}; do true; done; done +``` + +* Run the [StackOverflow tags query](https://data.stackexchange.com/stackoverflow/query/edit/1013465) and update the CSV link: + +``` +export SO_TAG_CSV_URL=... # from the query page + E.G. +export SO_TAG_CSV_URL=https://data.stackexchange.com/stackoverflow/csv/1451851 +``` + +* Remove/clean all generated files: + +``` +make -C ../.. clean +``` + +* Download GitHub and StackOverflow data and generate the final + combined data set: + +``` +PATH=$PATH:~/personal/programming/loccount + +npm install +time VERBOSE=1 node ./collect_data.js logs/${BUILD}/ all_data.json +``` diff --git a/docs/graph/all_data.json b/docs/graph/all_data.json index 75f4c831b6..1a835d7afe 100644 --- a/docs/graph/all_data.json +++ b/docs/graph/all_data.json @@ -1,1960 +1,1960 @@ -{ - "ada": { - "dir": "ada", - "name": "Ada", - "syntax": "Algol", - "type_check": "Static", - "modes": [], - "perf1": 6, - "perf2": 17, - "perf3": 1761, - "pull_count": 221, - "pull_rank": 62, - "push_count": 22283, - "push_rank": 55, - "star_count": 453, - "star_rank": 63, - "sloc": 3577, - "files": 19, - "author_name": "Chris Moore", - "author_url": "https://github.com/zmower", - "so_count": 1766, - "so_rank": 53, - "lloc": 2234 - }, - "ada.2": { - "dir": "ada.2", - "name": "Ada #2", - "syntax": "Algol", - "type_check": "Static", - "modes": [], - "perf1": 1, - "perf2": 1, - "perf3": 109806, - "pull_count": 221, - "pull_rank": 63, - "push_count": 22283, - "push_rank": 56, - "star_count": 453, - "star_rank": 64, - "sloc": 2297, - "files": 30, - "author_name": "Nicolas Boulenguez", - "author_url": "https://github.com/asarhaddon", - "so_count": 1766, - "so_rank": 54, - "lloc": 1453 - }, - "awk": { - "dir": "awk", - "name": "GNU Awk", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 11, - "perf2": 35, - "perf3": 927, - "pull_count": null, - "pull_rank": null, - "push_count": 4386, - "push_rank": 66, - "star_count": 7270, - "star_rank": 52, - "sloc": 2166, - "files": 7, - "author_name": "Miutsuru Kariya", - "author_url": "https://github.com/kariya-mitsuru", - "so_count": 25813, - "so_rank": 25, - "lloc": 0 - }, - "bash": { - "dir": "bash", - "name": "Bash 4", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 1234, - "perf2": 5244, - "perf3": 7, - "pull_count": 577934, - "pull_rank": 13, - "push_count": 4486723, - "push_rank": 11, - "star_count": 1558390, - "star_rank": 17, - "sloc": 1117, - "files": 7, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 119582, - "so_rank": 15, - "lloc": 0 - }, - "basic": { - "dir": "basic", - "name": "BASIC", - "syntax": "OTHER", - "type_check": "Static", - "modes": [ - "cbm", - "qbasic" - ], - "perf1": 6, - "perf2": 21, - "perf3": 1349, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 1927, - "files": 13, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 695, - "so_rank": 59, - "lloc": 1664 - }, - "bbc-basic": { - "dir": "bbc-basic", - "name": "BBC BASIC V", - "syntax": "OTHER", - "type_check": "Static", - "modes": [], - "perf1": 60, - "perf2": 210, - "perf3": 170, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 1362, - "files": 7, - "author_name": "Ben Harris", - "author_url": "https://github.com/bjh21", - "so_count": 8, - "so_rank": 76, - "lloc": 1360 - }, - "c": { - "dir": "c", - "name": "C", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 0, - "perf2": 1, - "perf3": 25447, - "pull_count": 955093, - "pull_rank": 10, - "push_count": 5864079, - "push_rank": 9, - "star_count": 2641471, - "star_rank": 11, - "sloc": 1987, - "files": 15, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 319293, - "so_rank": 9, - "lloc": 1059 - }, - "cpp": { - "dir": "cpp", - "name": "C++", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 1, - "perf2": 1, - "perf3": 25536, - "pull_count": 1643054, - "pull_rank": 8, - "push_count": 8812939, - "push_rank": 7, - "star_count": 3275964, - "star_rank": 7, - "sloc": 2034, - "files": 19, - "author_name": "Stephen Thirlwall", - "author_url": "https://github.com/sdt", - "so_count": 711718, - "so_rank": 7, - "lloc": 938 - }, - "cs": { - "dir": "cs", - "name": "C#", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 7, - "perf2": 8, - "perf3": 23049, - "pull_count": 907768, - "pull_rank": 11, - "push_count": 5255212, - "push_rank": 10, - "star_count": 1632082, - "star_rank": 16, - "sloc": 1201, - "files": 9, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 1402937, - "so_rank": 5, - "lloc": 581 - }, - "chuck": { - "dir": "chuck", - "name": "ChucK", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 28, - "perf2": 81, - "perf3": 163, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 2481, - "files": 86, - "author_name": "Vasilij Schneidermann", - "author_url": "https://github.com/wasamasa", - "so_count": 20, - "so_rank": 74, - "lloc": 950 - }, - "clojure": { - "dir": "clojure", - "name": "Clojure", - "syntax": "Lisp", - "type_check": "Dynamic", - "modes": [ - "clj", - "cljs" - ], - "perf1": 18, - "perf2": 43, - "perf3": 5090, - "pull_count": 98488, - "pull_rank": 25, - "push_count": 508141, - "push_rank": 25, - "star_count": 247564, - "star_rank": 25, - "sloc": 413, - "files": 9, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 15984, - "so_rank": 32, - "lloc": 0 - }, - "coffee": { - "dir": "coffee", - "name": "CoffeeScript", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 4, - "perf2": 15, - "perf3": 26375, - "pull_count": 188214, - "pull_rank": 21, - "push_count": 703056, - "push_rank": 22, - "star_count": 534981, - "star_rank": 19, - "sloc": 450, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 9705, - "so_rank": 36, - "lloc": 0 - }, - "common-lisp": { - "dir": "common-lisp", - "name": "Common Lisp", - "syntax": "Lisp", - "type_check": "Dynamic", - "modes": [], - "perf1": 0, - "perf2": 2, - "perf3": 21668, - "pull_count": 8302, - "pull_rank": 48, - "push_count": 94199, - "push_rank": 42, - "star_count": 37376, - "star_rank": 39, - "sloc": 1018, - "files": 11, - "author_name": "Iqbal Ansari", - "author_url": "https://github.com/iqbalansari", - "so_count": 5087, - "so_rank": 45, - "lloc": 0 - }, - "crystal": { - "dir": "crystal", - "name": "Crystal", - "syntax": "OTHER", - "type_check": "Static", - "modes": [], - "perf1": 0, - "perf2": 1, - "perf3": 44247, - "pull_count": 8464, - "pull_rank": 47, - "push_count": 28368, - "push_rank": 54, - "star_count": 22253, - "star_rank": 47, - "sloc": 919, - "files": 8, - "author_name": "Linda_pp", - "author_url": "https://github.com/rhysd", - "so_count": 529, - "so_rank": 60, - "lloc": 0 - }, - "d": { - "dir": "d", - "name": "D", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 0, - "perf2": 2, - "perf3": 30773, - "pull_count": 7793, - "pull_rank": 50, - "push_count": 70193, - "push_rank": 48, - "star_count": 18026, - "star_rank": 49, - "sloc": 1317, - "files": 8, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 2531, - "so_rank": 52, - "lloc": 563 - }, - "dart": { - "dir": "dart", - "name": "Dart", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 10, - "perf2": 32, - "perf3": 731, - "pull_count": 59821, - "pull_rank": 33, - "push_count": 152206, - "push_rank": 38, - "star_count": 80668, - "star_rank": 34, - "sloc": 957, - "files": 8, - "author_name": "Harry Terkelsen", - "author_url": "https://github.com/hterkelsen", - "so_count": 24386, - "so_rank": 27, - "lloc": 469 - }, - "elixir": { - "dir": "elixir", - "name": "Elixir", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 10, - "perf2": 40, - "perf3": 968, - "pull_count": 74008, - "pull_rank": 28, - "push_count": 189422, - "push_rank": 36, - "star_count": 155370, - "star_rank": 26, - "sloc": 688, - "files": 10, - "author_name": "Martin Ek", - "author_url": "https://github.com/ekmartin", - "so_count": 7458, - "so_rank": 39, - "lloc": 0 - }, - "elm": { - "dir": "elm", - "name": "Elm", - "syntax": "ML", - "type_check": "Static", - "modes": [], - "perf1": 42, - "perf2": 121, - "perf3": 1341, - "pull_count": 11804, - "pull_rank": 44, - "push_count": 53310, - "push_rank": 49, - "star_count": 32741, - "star_rank": 42, - "sloc": 2348, - "files": 12, - "author_name": "Jos van Bakel", - "author_url": "https://github.com/c0deaddict", - "so_count": 1607, - "so_rank": 55, - "lloc": 0 - }, - "elisp": { - "dir": "elisp", - "name": "Emacs Lisp", - "syntax": "Lisp", - "type_check": "Dynamic", - "modes": [], - "perf1": 14, - "perf2": 51, - "perf3": 824, - "pull_count": 52498, - "pull_rank": 34, - "push_count": 314946, - "push_rank": 28, - "star_count": 133893, - "star_rank": 29, - "sloc": 753, - "files": 8, - "author_name": "Vasilij Schneidermann", - "author_url": "https://github.com/wasamasa", - "so_count": 3693, - "so_rank": 49, - "lloc": 0 - }, - "erlang": { - "dir": "erlang", - "name": "Erlang", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 36, - "perf2": 75, - "perf3": 249, - "pull_count": 67000, - "pull_rank": 30, - "push_count": 258565, - "push_rank": 31, - "star_count": 125110, - "star_rank": 30, - "sloc": 1127, - "files": 8, - "author_name": "Nathan Fiedler", - "author_url": "https://github.com/nlfiedler", - "so_count": 8677, - "so_rank": 37, - "lloc": 0 - }, - "es6": { - "dir": "es6", - "name": "ES6", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 3, - "perf2": 15, - "perf3": 21287, - "pull_count": 6304275, - "pull_rank": 2, - "push_count": 25379428, - "push_rank": 2, - "star_count": 20003913, - "star_rank": 2, - "sloc": 469, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 208944, - "so_rank": 13, - "lloc": 0 - }, - "fsharp": { - "dir": "fsharp", - "name": "F#", - "syntax": "ML", - "type_check": "Static", - "modes": [], - "perf1": 6, - "perf2": 6, - "perf3": 29682, - "pull_count": 28170, - "pull_rank": 38, - "push_count": 131779, - "push_rank": 39, - "star_count": 34126, - "star_rank": 41, - "sloc": 1080, - "files": 11, - "author_name": "Peter Stephens", - "author_url": "https://github.com/pstephens", - "so_count": 15293, - "so_rank": 33, - "lloc": 2 - }, - "factor": { - "dir": "factor", - "name": "Factor", - "syntax": "Stack", - "type_check": "Dynamic", - "modes": [], - "perf1": 1, - "perf2": 1, - "perf3": 41423, - "pull_count": null, - "pull_rank": null, - "push_count": 12251, - "push_rank": 62, - "star_count": 100, - "star_rank": 67, - "sloc": 373, - "files": 8, - "author_name": "Jordan Lewis", - "author_url": "https://github.com/jordanlewis", - "so_count": 62, - "so_rank": 69, - "lloc": 0 - }, - "fantom": { - "dir": "fantom", - "name": "Fantom", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 24, - "perf2": 20, - "perf3": 78813, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 706, - "files": 9, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 56, - "so_rank": 70, - "lloc": 0 - }, - "forth": { - "dir": "forth", - "name": "Forth", - "syntax": "Stack", - "type_check": "OTHER", - "modes": [], - "perf1": 2, - "perf2": 8, - "perf3": 3769, - "pull_count": null, - "pull_rank": null, - "push_count": 7173, - "push_rank": 64, - "star_count": 422, - "star_rank": 65, - "sloc": 1387, - "files": 8, - "author_name": "Chris Houser", - "author_url": "https://github.com/chouser", - "so_count": 220, - "so_rank": 63, - "lloc": 0 - }, - "guile": { - "dir": "guile", - "name": "GNU Guile", - "syntax": "Lisp", - "type_check": "Dynamic", - "modes": [], - "perf1": 2, - "perf2": 7, - "perf3": 5084, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 738, - "files": 9, - "author_name": "Mu Lei", - "author_url": "https://github.com/NalaGinrut", - "so_count": 205, - "so_rank": 64, - "lloc": 0 - }, - "gnu-smalltalk": { - "dir": "gnu-smalltalk", - "name": "GNU Smalltalk", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 9, - "perf2": 29, - "perf3": 1223, - "pull_count": 12157, - "pull_rank": 43, - "push_count": 45508, - "push_rank": 50, - "star_count": 2461, - "star_rank": 60, - "sloc": 1036, - "files": 10, - "author_name": "Vasilij Schneidermann", - "author_url": "https://github.com/wasamasa", - "so_count": 101, - "so_rank": 66, - "lloc": 0 - }, - "go": { - "dir": "go", - "name": "Go", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 1, - "perf2": 4, - "perf3": 15723, - "pull_count": 1544908, - "pull_rank": 9, - "push_count": 3775028, - "push_rank": 12, - "star_count": 4549081, - "star_rank": 6, - "sloc": 1437, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 42897, - "so_rank": 22, - "lloc": 689 - }, - "groovy": { - "dir": "groovy", - "name": "Groovy", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 312, - "perf2": 746, - "perf3": 432, - "pull_count": 95277, - "pull_rank": 26, - "push_count": 369907, - "push_rank": 27, - "star_count": 113888, - "star_rank": 32, - "sloc": 666, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 24411, - "so_rank": 26, - "lloc": 0 - }, - "haskell": { - "dir": "haskell", - "name": "Haskell", - "syntax": "ML", - "type_check": "Static", - "modes": [], - "perf1": 1, - "perf2": 5, - "perf3": 13086, - "pull_count": 112254, - "pull_rank": 23, - "push_count": 795668, - "push_rank": 20, - "star_count": 268686, - "star_rank": 23, - "sloc": 688, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 42877, - "so_rank": 23, - "lloc": 0 - }, - "haxe": { - "dir": "haxe", - "name": "Haxe", - "syntax": "C", - "type_check": "Static", - "modes": [ - "neko", - "python", - "cpp", - "js" - ], - "perf1": 3, - "perf2": 16, - "perf3": 22443, - "pull_count": 13168, - "pull_rank": 42, - "push_count": 72533, - "push_rank": 46, - "star_count": 26516, - "star_rank": 45, - "sloc": 1113, - "files": 11, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 1456, - "so_rank": 56, - "lloc": 462 - }, - "hy": { - "dir": "hy", - "name": "Hy", - "syntax": "Lisp", - "type_check": "Dynamic", - "modes": [], - "perf1": 16, - "perf2": 61, - "perf3": 628, - "pull_count": 108, - "pull_rank": 64, - "push_count": 1442, - "push_rank": 67, - "star_count": 308, - "star_rank": 66, - "sloc": 381, - "files": 7, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 36, - "so_rank": 73, - "lloc": 0 - }, - "io": { - "dir": "io", - "name": "Io", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 236, - "perf2": 822, - "perf3": 38, - "pull_count": null, - "pull_rank": null, - "push_count": 224, - "push_rank": 68, - "star_count": null, - "star_rank": null, - "sloc": 526, - "files": 7, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 15173, - "so_rank": 34, - "lloc": 0 - }, - "java": { - "dir": "java", - "name": "Java", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 13, - "perf2": 16, - "perf3": 101403, - "pull_count": 2806217, - "pull_rank": 5, - "push_count": 13507281, - "push_rank": 5, - "star_count": 7179519, - "star_rank": 5, - "sloc": 1543, - "files": 9, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 1623967, - "so_rank": 2, - "lloc": 698 - }, - "js": { - "dir": "js", - "name": "JavaScript", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 3, - "perf2": 17, - "perf3": 20616, - "pull_count": 6304275, - "pull_rank": 1, - "push_count": 25379428, - "push_rank": 1, - "star_count": 20003913, - "star_rank": 1, - "sloc": 851, - "files": 10, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 3406494, - "so_rank": 1, - "lloc": 0 - }, - "jq": { - "dir": "jq", - "name": "jq", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 124.784912109375, - "perf2": 316.791015625, - "perf3": 41, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 1801, - "files": 9, - "author_name": "Ali MohammadPur", - "author_url": "https://github.com/alimpfard", - "so_count": 2794, - "so_rank": 51, - "lloc": 0 - }, - "julia": { - "dir": "julia", - "name": "Julia", - "syntax": "Algol", - "type_check": "Dynamic", - "modes": [], - "perf1": 61, - "perf2": 17, - "perf3": 4531, - "pull_count": 49634, - "pull_rank": 35, - "push_count": 209318, - "push_rank": 35, - "star_count": 40736, - "star_rank": 38, - "sloc": 556, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 6280, - "so_rank": 42, - "lloc": 0 - }, - "kotlin": { - "dir": "kotlin", - "name": "Kotlin", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 13, - "perf2": 45, - "perf3": 49803, - "pull_count": 82740, - "pull_rank": 27, - "push_count": 286890, - "push_rank": 29, - "star_count": 252618, - "star_rank": 24, - "sloc": 737, - "files": 8, - "author_name": "Javier Fernandez-Ivern", - "author_url": "https://github.com/ivern", - "so_count": 33094, - "so_rank": 24, - "lloc": 0 - }, - "livescript": { - "dir": "livescript", - "name": "LiveScript", - "syntax": "ML", - "type_check": "Dynamic", - "modes": [], - "perf1": 5, - "perf2": 15, - "perf3": 11438, - "pull_count": 238, - "pull_rank": 61, - "push_count": 14627, - "push_rank": 60, - "star_count": 8990, - "star_rank": 51, - "sloc": 762, - "files": 8, - "author_name": "Jos van Bakel", - "author_url": "https://github.com/c0deaddict", - "so_count": 66, - "so_rank": 67, - "lloc": 0 - }, - "logo": { - "dir": "logo", - "name": "Logo", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 12894, - "perf2": 41700, - "perf3": 0, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 1022, - "files": 8, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 45, - "so_rank": 71, - "lloc": 0 - }, - "lua": { - "dir": "lua", - "name": "Lua", - "syntax": "Algol", - "type_check": "Dynamic", - "modes": [], - "perf1": 8, - "perf2": 27, - "perf3": 1436, - "pull_count": 110392, - "pull_rank": 24, - "push_count": 630988, - "push_rank": 24, - "star_count": 275531, - "star_rank": 22, - "sloc": 920, - "files": 9, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 16329, - "so_rank": 31, - "lloc": 0 - }, - "make": { - "dir": "make", - "name": "GNU Make", - "syntax": "OTHER", - "type_check": "OTHER", - "modes": [], - "perf1": 3300, - "perf2": 16544, - "perf3": 2, - "pull_count": 71627, - "pull_rank": 29, - "push_count": 275049, - "push_rank": 30, - "star_count": 68614, - "star_rank": 35, - "sloc": 1031, - "files": 12, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 19981, - "so_rank": 29, - "lloc": 0 - }, - "mal": { - "dir": "mal", - "name": "mal itself", - "syntax": "Lisp", - "type_check": "Dynamic", - "modes": [], - "perf1": 88, - "perf2": 421, - "perf3": 90, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 207, - "files": 4, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 0, - "so_rank": 84, - "lloc": 0 - }, - "matlab": { - "dir": "matlab", - "name": "MATLAB", - "syntax": "Algol", - "type_check": "Dynamic", - "modes": [], - "perf1": 1042, - "perf2": 3654, - "perf3": 9, - "pull_count": 2984, - "pull_rank": 57, - "push_count": 14280, - "push_rank": 61, - "star_count": 3086, - "star_rank": 59, - "sloc": 1086, - "files": 17, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 86207, - "so_rank": 18, - "lloc": 0 - }, - "miniMAL": { - "dir": "miniMAL", - "name": "miniMAL", - "syntax": "JSON", - "type_check": "Dynamic", - "modes": [], - "perf1": 821, - "perf2": 3251, - "perf3": 11, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 836, - "files": 9, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 0, - "so_rank": 81, - "lloc": 0 - }, - "nasm": { - "dir": "nasm", - "name": "NASM", - "syntax": "OTHER", - "type_check": "OTHER", - "modes": [], - "perf1": 1, - "perf2": 1, - "perf3": 36581, - "pull_count": 10523, - "pull_rank": 45, - "push_count": 98138, - "push_rank": 41, - "star_count": 35975, - "star_rank": 40, - "sloc": 6170, - "files": 9, - "author_name": "Ben Dudson", - "author_url": "https://github.com/bendudson", - "so_count": 3740, - "so_rank": 48, - "lloc": 0 - }, - "nim": { - "dir": "nim", - "name": "Nim", - "syntax": "Python", - "type_check": "Static", - "modes": [], - "perf1": 1, - "perf2": 1, - "perf3": 39173, - "pull_count": 2009, - "pull_rank": 58, - "push_count": 9302, - "push_rank": 63, - "star_count": 6954, - "star_rank": 53, - "sloc": 610, - "files": 7, - "author_name": "Dennis Felsing", - "author_url": "https://github.com/def-", - "so_count": 0, - "so_rank": 80, - "lloc": 0 - }, - "objpascal": { - "dir": "objpascal", - "name": "Object Pascal", - "syntax": "Algol", - "type_check": "Static", - "modes": [], - "perf1": 2, - "perf2": 8, - "perf3": 4264, - "pull_count": 5881, - "pull_rank": 51, - "push_count": 77775, - "push_rank": 45, - "star_count": 26713, - "star_rank": 44, - "sloc": 1608, - "files": 9, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 59299, - "so_rank": 21, - "lloc": 995 - }, - "objc": { - "dir": "objc", - "name": "Objective C", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 4, - "perf2": 16, - "perf3": 2175, - "pull_count": 284470, - "pull_rank": 15, - "push_count": 1356112, - "push_rank": 14, - "star_count": 3173498, - "star_rank": 9, - "sloc": 1132, - "files": 16, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 288979, - "so_rank": 10, - "lloc": 501 - }, - "ocaml": { - "dir": "ocaml", - "name": "OCaml", - "syntax": "ML", - "type_check": "Static", - "modes": [], - "perf1": 0, - "perf2": 1, - "perf3": 35638, - "pull_count": 63111, - "pull_rank": 31, - "push_count": 244361, - "push_rank": 33, - "star_count": 99996, - "star_rank": 33, - "sloc": 560, - "files": 7, - "author_name": "Chris Houser", - "author_url": "https://github.com/chouser", - "so_count": 6012, - "so_rank": 43, - "lloc": 0 - }, - "perl": { - "dir": "perl", - "name": "Perl", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 7, - "perf2": 27, - "perf3": 1486, - "pull_count": 128831, - "pull_rank": 22, - "push_count": 677400, - "push_rank": 23, - "star_count": 139906, - "star_rank": 28, - "sloc": 812, - "files": 9, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 64002, - "so_rank": 20, - "lloc": 412 - }, - "perl6": { - "dir": "perl6", - "name": "Perl 6", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 256, - "perf2": 746, - "perf3": 38, - "pull_count": 3720, - "pull_rank": 54, - "push_count": 18069, - "push_rank": 59, - "star_count": 1314, - "star_rank": 61, - "sloc": 459, - "files": 7, - "author_name": "Hinrik Örn Sigurðsson", - "author_url": "https://github.com/hinrik", - "so_count": 0, - "so_rank": 79, - "lloc": 156 - }, - "php": { - "dir": "php", - "name": "PHP", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 6, - "perf2": 21, - "perf3": 1662, - "pull_count": 2110353, - "pull_rank": 7, - "push_count": 9601954, - "push_rank": 6, - "star_count": 3273737, - "star_rank": 8, - "sloc": 938, - "files": 10, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 1325705, - "so_rank": 6, - "lloc": 514 - }, - "picolisp": { - "dir": "picolisp", - "name": "Picolisp", - "syntax": "Lisp", - "type_check": "Dynamic", - "modes": [], - "perf1": 1, - "perf2": 4, - "perf3": 7689, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 561, - "files": 9, - "author_name": "Vasilij Schneidermann", - "author_url": "https://github.com/wasamasa", - "so_count": 6, - "so_rank": 78, - "lloc": 0 - }, - "pike": { - "dir": "pike", - "name": "Pike", - "syntax": "C", - "type_check": "OTHER", - "modes": [], - "perf1": 3, - "perf2": 10, - "perf3": 3684, - "pull_count": null, - "pull_rank": null, - "push_count": 103, - "push_rank": 69, - "star_count": null, - "star_rank": null, - "sloc": 861, - "files": 9, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 12, - "so_rank": 75, - "lloc": 427 - }, - "plpgsql": { - "dir": "plpgsql", - "name": "PL/pgSQL", - "syntax": "Algol", - "type_check": "Static", - "modes": [], - "perf1": 389, - "perf2": 1898, - "perf3": 24, - "pull_count": 18439, - "pull_rank": 41, - "push_count": 93224, - "push_rank": 43, - "star_count": 19492, - "star_rank": 48, - "sloc": 1848, - "files": 11, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 3059, - "so_rank": 50, - "lloc": 0 - }, - "plsql": { - "dir": "plsql", - "name": "PL/SQL", - "syntax": "Algol", - "type_check": "Static", - "modes": [], - "perf1": null, - "perf2": null, - "perf3": 0, - "pull_count": 10393, - "pull_rank": 46, - "push_count": 34307, - "push_rank": 51, - "star_count": 4745, - "star_rank": 57, - "sloc": 2195, - "files": 11, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 22058, - "so_rank": 28, - "lloc": 0 - }, - "powershell": { - "dir": "powershell", - "name": "PowerShell", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 1169, - "perf2": 4627, - "perf3": 8, - "pull_count": 62578, - "pull_rank": 32, - "push_count": 236684, - "push_rank": 34, - "star_count": 116882, - "star_rank": 31, - "sloc": 790, - "files": 7, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 75976, - "so_rank": 19, - "lloc": 0 - }, - "ps": { - "dir": "ps", - "name": "PostScript", - "syntax": "Stack", - "type_check": "Dynamic", - "modes": [], - "perf1": 30, - "perf2": 171, - "perf3": 276, - "pull_count": 1644, - "pull_rank": 59, - "push_count": 19912, - "push_rank": 58, - "star_count": 1034, - "star_rank": 62, - "sloc": 1235, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 476, - "so_rank": 61, - "lloc": 0 - }, - "python": { - "dir": "python", - "name": "Python", - "syntax": "Python", - "type_check": "Dynamic", - "modes": [ - "python2", - "python3" - ], - "perf1": 6, - "perf2": 24, - "perf3": 1565, - "pull_count": 4379644, - "pull_rank": 3, - "push_count": 16425146, - "push_rank": 3, - "star_count": 7834904, - "star_rank": 3, - "sloc": 583, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 1618481, - "so_rank": 3, - "lloc": 0 - }, - "python.2": { - "dir": "python.2", - "name": "Python #2", - "syntax": "Python", - "type_check": "Dynamic", - "modes": [], - "perf1": 8, - "perf2": 30, - "perf3": 1289, - "pull_count": 4379644, - "pull_rank": 4, - "push_count": 16425146, - "push_rank": 4, - "star_count": 7834904, - "star_rank": 4, - "sloc": 965, - "files": 6, - "author_name": "Gavin Lewis", - "author_url": "https://github.com/epylar", - "so_count": 1618481, - "so_rank": 4, - "lloc": 0 - }, - "rpython": { - "dir": "rpython", - "name": "RPython", - "syntax": "Python", - "type_check": "Static", - "modes": [], - "perf1": 1, - "perf2": 1, - "perf3": 95295, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 1012, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 64, - "so_rank": 68, - "lloc": 0 - }, - "r": { - "dir": "r", - "name": "R", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 56, - "perf2": 194, - "perf3": 179, - "pull_count": 46637, - "pull_rank": 36, - "push_count": 490385, - "push_rank": 26, - "star_count": 65937, - "star_rank": 36, - "sloc": 733, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 322017, - "so_rank": 8, - "lloc": 0 - }, - "racket": { - "dir": "racket", - "name": "Racket", - "syntax": "Lisp", - "type_check": "Dynamic", - "modes": [], - "perf1": 2, - "perf2": 5, - "perf3": 7546, - "pull_count": 3167, - "pull_rank": 56, - "push_count": 29122, - "push_rank": 53, - "star_count": 6672, - "star_rank": 54, - "sloc": 510, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 4683, - "so_rank": 47, - "lloc": 0 - }, - "rexx": { - "dir": "rexx", - "name": "Rexx", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 117, - "perf2": 457, - "perf3": 82, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 1210, - "files": 8, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 139, - "so_rank": 65, - "lloc": 0 - }, - "ruby": { - "dir": "ruby", - "name": "Ruby", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 2, - "perf2": 5, - "perf3": 5726, - "pull_count": 2335479, - "pull_rank": 6, - "push_count": 6368990, - "push_rank": 8, - "star_count": 3024866, - "star_rank": 10, - "sloc": 451, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 209973, - "so_rank": 12, - "lloc": 0 - }, - "rust": { - "dir": "rust", - "name": "Rust", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 0, - "perf2": 1, - "perf3": 24833, - "pull_count": 231464, - "pull_rank": 20, - "push_count": 779153, - "push_rank": 21, - "star_count": 493142, - "star_rank": 20, - "sloc": 1147, - "files": 7, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 14713, - "so_rank": 35, - "lloc": 179 - }, - "scala": { - "dir": "scala", - "name": "Scala", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 25, - "perf2": 40, - "perf3": 54155, - "pull_count": 380802, - "pull_rank": 14, - "push_count": 1209536, - "push_rank": 15, - "star_count": 469698, - "star_rank": 21, - "sloc": 816, - "files": 7, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 94482, - "so_rank": 17, - "lloc": 0 - }, - "scheme": { - "dir": "scheme", - "name": "Scheme (R7RS)", - "syntax": "Lisp", - "type_check": "Dynamic", - "modes": [ - "chibi", - "kawa", - "gauche", - "chicken", - "sagittarius", - "cyclone", - "foment" - ], - "perf1": 4, - "perf2": 12, - "perf3": 3300, - "pull_count": 4067, - "pull_rank": 53, - "push_count": 70230, - "push_rank": 47, - "star_count": 24230, - "star_rank": 46, - "sloc": 921, - "files": 8, - "author_name": "Vasilij Schneidermann", - "author_url": "https://github.com/wasamasa", - "so_count": 7007, - "so_rank": 40, - "lloc": 0 - }, - "skew": { - "dir": "skew", - "name": "Skew", - "syntax": "OTHER", - "type_check": "Static", - "modes": [], - "perf1": 3, - "perf2": 8, - "perf3": 4275, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 713, - "files": 8, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 307, - "so_rank": 62, - "lloc": 0 - }, - "swift": { - "dir": "swift", - "name": "Swift 2", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 2, - "perf2": 6, - "perf3": 6276, - "pull_count": 267533, - "pull_rank": 16, - "push_count": 1007930, - "push_rank": 16, - "star_count": 2232496, - "star_rank": 12, - "sloc": 2454, - "files": 10, - "author_name": "Keith Rollin", - "author_url": "https://github.com/keith-rollin", - "so_count": 8498, - "so_rank": 38, - "lloc": 0 - }, - "swift3": { - "dir": "swift3", - "name": "Swift 3", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 7, - "perf2": 21, - "perf3": 1576, - "pull_count": 267533, - "pull_rank": 17, - "push_count": 1007930, - "push_rank": 17, - "star_count": 2232496, - "star_rank": 13, - "sloc": 1159, - "files": 7, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 18306, - "so_rank": 30, - "lloc": 0 - }, - "swift4": { - "dir": "swift4", - "name": "Swift 4", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 3, - "perf2": 11, - "perf3": 3150, - "pull_count": 267533, - "pull_rank": 18, - "push_count": 1007930, - "push_rank": 18, - "star_count": 2232496, - "star_rank": 14, - "sloc": 735, - "files": 7, - "author_name": "陆遥", - "author_url": "https://github.com/LispLY", - "so_count": 5596, - "so_rank": 44, - "lloc": 0 - }, - "swift5": { - "dir": "swift5", - "name": "Swift 5", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 2, - "perf2": 7, - "perf3": 4376, - "pull_count": 267533, - "pull_rank": 19, - "push_count": 1007930, - "push_rank": 19, - "star_count": 2232496, - "star_rank": 15, - "sloc": 1221, - "files": 11, - "author_name": "Oleg Montak", - "author_url": "https://github.com/MontakOleg", - "so_count": 259095, - "so_rank": 11, - "lloc": 0 - }, - "tcl": { - "dir": "tcl", - "name": "Tcl", - "syntax": "OTHER", - "type_check": "Dynamic", - "modes": [], - "perf1": 19, - "perf2": 68, - "perf3": 492, - "pull_count": 3399, - "pull_rank": 55, - "push_count": 29686, - "push_rank": 52, - "star_count": 3525, - "star_rank": 58, - "sloc": 1065, - "files": 8, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 6451, - "so_rank": 41, - "lloc": 0 - }, - "ts": { - "dir": "ts", - "name": "TypeScript", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 2, - "perf2": 9, - "perf3": 42027, - "pull_count": 796454, - "pull_rank": 12, - "push_count": 1902035, - "push_rank": 13, - "star_count": 1364269, - "star_rank": 18, - "sloc": 1271, - "files": 8, - "author_name": "Masahiro Wakame", - "author_url": "https://github.com/vvakame", - "so_count": 103029, - "so_rank": 16, - "lloc": 0 - }, - "vala": { - "dir": "vala", - "name": "Vala", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 4, - "perf2": 16, - "perf3": 2367, - "pull_count": 8062, - "pull_rank": 49, - "push_count": 82567, - "push_rank": 44, - "star_count": 31421, - "star_rank": 43, - "sloc": 2209, - "files": 8, - "author_name": "Simon Tatham", - "author_url": "https://github.com/sgtatham", - "so_count": 841, - "so_rank": 57, - "lloc": 1098 - }, - "vhdl": { - "dir": "vhdl", - "name": "VHDL", - "syntax": "Algol", - "type_check": "Static", - "modes": [], - "perf1": 2, - "perf2": 6, - "perf3": 5204, - "pull_count": 240, - "pull_rank": 60, - "push_count": 21203, - "push_rank": 57, - "star_count": 5902, - "star_rank": 56, - "sloc": 1920, - "files": 9, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 5013, - "so_rank": 46, - "lloc": 0 - }, - "vimscript": { - "dir": "vimscript", - "name": "Vimscript", - "syntax": "Algol", - "type_check": "Dynamic", - "modes": [], - "perf1": 130, - "perf2": 581, - "perf3": 73, - "pull_count": 21140, - "pull_rank": 39, - "push_count": 155625, - "push_rank": 37, - "star_count": 140033, - "star_rank": 27, - "sloc": 982, - "files": 10, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 41, - "so_rank": 72, - "lloc": 12 - }, - "vb": { - "dir": "vb", - "name": "Visual Basic.NET", - "syntax": "Algol", - "type_check": "Static", - "modes": [], - "perf1": 8, - "perf2": 9, - "perf3": 19152, - "pull_count": 31745, - "pull_rank": 37, - "push_count": 116528, - "push_rank": 40, - "star_count": 13449, - "star_rank": 50, - "sloc": 1460, - "files": 8, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 127657, - "so_rank": 14, - "lloc": 0 - }, - "wasm": { - "dir": "wasm", - "name": "WebAssembly", - "syntax": "Lisp", - "type_check": "Static", - "modes": [ - "wace_libc", - "node", - "warpy" - ], - "perf1": 4, - "perf2": 6, - "perf3": 5518, - "pull_count": 4588, - "pull_rank": 52, - "push_count": 6630, - "push_rank": 65, - "star_count": 6337, - "star_rank": 55, - "sloc": 3051, - "files": 16, - "author_name": "Joel Martin", - "author_url": "https://github.com/kanaka", - "so_count": 756, - "so_rank": 58, - "lloc": 0 - }, - "wren": { - "dir": "wren", - "name": "Wren", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 1, - "perf2": 7, - "perf3": 4619, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 639, - "files": 9, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 0, - "so_rank": 82, - "lloc": 0 - }, - "yorick": { - "dir": "yorick", - "name": "Yorick", - "syntax": "C", - "type_check": "Dynamic", - "modes": [], - "perf1": 51, - "perf2": 228, - "perf3": 191, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 1010, - "files": 8, - "author_name": "Dov Murik", - "author_url": "https://github.com/dubek", - "so_count": 0, - "so_rank": 83, - "lloc": 106 - }, - "zig": { - "dir": "zig", - "name": "Zig", - "syntax": "C", - "type_check": "Static", - "modes": [], - "perf1": 1, - "perf2": 3, - "perf3": 7244, - "pull_count": null, - "pull_rank": null, - "push_count": null, - "push_rank": null, - "star_count": null, - "star_rank": null, - "sloc": 2673, - "files": 14, - "author_name": "Josh Tobin", - "author_url": "https://github.com/rjtobin", - "so_count": 6, - "so_rank": 77, - "lloc": 0 - } +{ + "ada": { + "dir": "ada", + "name": "Ada", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 6, + "perf2": 17, + "perf3": 1761, + "pull_count": 221, + "pull_rank": 62, + "push_count": 22283, + "push_rank": 55, + "star_count": 453, + "star_rank": 63, + "sloc": 3577, + "files": 19, + "author_name": "Chris Moore", + "author_url": "https://github.com/zmower", + "so_count": 1766, + "so_rank": 53, + "lloc": 2234 + }, + "ada.2": { + "dir": "ada.2", + "name": "Ada #2", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 1, + "perf3": 109806, + "pull_count": 221, + "pull_rank": 63, + "push_count": 22283, + "push_rank": 56, + "star_count": 453, + "star_rank": 64, + "sloc": 2297, + "files": 30, + "author_name": "Nicolas Boulenguez", + "author_url": "https://github.com/asarhaddon", + "so_count": 1766, + "so_rank": 54, + "lloc": 1453 + }, + "awk": { + "dir": "awk", + "name": "GNU Awk", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 11, + "perf2": 35, + "perf3": 927, + "pull_count": null, + "pull_rank": null, + "push_count": 4386, + "push_rank": 66, + "star_count": 7270, + "star_rank": 52, + "sloc": 2166, + "files": 7, + "author_name": "Miutsuru Kariya", + "author_url": "https://github.com/kariya-mitsuru", + "so_count": 25813, + "so_rank": 25, + "lloc": 0 + }, + "bash": { + "dir": "bash", + "name": "Bash 4", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 1234, + "perf2": 5244, + "perf3": 7, + "pull_count": 577934, + "pull_rank": 13, + "push_count": 4486723, + "push_rank": 11, + "star_count": 1558390, + "star_rank": 17, + "sloc": 1117, + "files": 7, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 119582, + "so_rank": 15, + "lloc": 0 + }, + "basic": { + "dir": "basic", + "name": "BASIC", + "syntax": "OTHER", + "type_check": "Static", + "modes": [ + "cbm", + "qbasic" + ], + "perf1": 6, + "perf2": 21, + "perf3": 1349, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 1927, + "files": 13, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 695, + "so_rank": 59, + "lloc": 1664 + }, + "bbc-basic": { + "dir": "bbc-basic", + "name": "BBC BASIC V", + "syntax": "OTHER", + "type_check": "Static", + "modes": [], + "perf1": 60, + "perf2": 210, + "perf3": 170, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 1362, + "files": 7, + "author_name": "Ben Harris", + "author_url": "https://github.com/bjh21", + "so_count": 8, + "so_rank": 76, + "lloc": 1360 + }, + "c": { + "dir": "c", + "name": "C", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 0, + "perf2": 1, + "perf3": 25447, + "pull_count": 955093, + "pull_rank": 10, + "push_count": 5864079, + "push_rank": 9, + "star_count": 2641471, + "star_rank": 11, + "sloc": 1987, + "files": 15, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 319293, + "so_rank": 9, + "lloc": 1059 + }, + "cpp": { + "dir": "cpp", + "name": "C++", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 1, + "perf3": 25536, + "pull_count": 1643054, + "pull_rank": 8, + "push_count": 8812939, + "push_rank": 7, + "star_count": 3275964, + "star_rank": 7, + "sloc": 2034, + "files": 19, + "author_name": "Stephen Thirlwall", + "author_url": "https://github.com/sdt", + "so_count": 711718, + "so_rank": 7, + "lloc": 938 + }, + "cs": { + "dir": "cs", + "name": "C#", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 7, + "perf2": 8, + "perf3": 23049, + "pull_count": 907768, + "pull_rank": 11, + "push_count": 5255212, + "push_rank": 10, + "star_count": 1632082, + "star_rank": 16, + "sloc": 1201, + "files": 9, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 1402937, + "so_rank": 5, + "lloc": 581 + }, + "chuck": { + "dir": "chuck", + "name": "ChucK", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 28, + "perf2": 81, + "perf3": 163, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 2481, + "files": 86, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "so_count": 20, + "so_rank": 74, + "lloc": 950 + }, + "clojure": { + "dir": "clojure", + "name": "Clojure", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [ + "clj", + "cljs" + ], + "perf1": 18, + "perf2": 43, + "perf3": 5090, + "pull_count": 98488, + "pull_rank": 25, + "push_count": 508141, + "push_rank": 25, + "star_count": 247564, + "star_rank": 25, + "sloc": 413, + "files": 9, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 15984, + "so_rank": 32, + "lloc": 0 + }, + "coffee": { + "dir": "coffee", + "name": "CoffeeScript", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 4, + "perf2": 15, + "perf3": 26375, + "pull_count": 188214, + "pull_rank": 21, + "push_count": 703056, + "push_rank": 22, + "star_count": 534981, + "star_rank": 19, + "sloc": 450, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 9705, + "so_rank": 36, + "lloc": 0 + }, + "common-lisp": { + "dir": "common-lisp", + "name": "Common Lisp", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 0, + "perf2": 2, + "perf3": 21668, + "pull_count": 8302, + "pull_rank": 48, + "push_count": 94199, + "push_rank": 42, + "star_count": 37376, + "star_rank": 39, + "sloc": 1018, + "files": 11, + "author_name": "Iqbal Ansari", + "author_url": "https://github.com/iqbalansari", + "so_count": 5087, + "so_rank": 45, + "lloc": 0 + }, + "crystal": { + "dir": "crystal", + "name": "Crystal", + "syntax": "OTHER", + "type_check": "Static", + "modes": [], + "perf1": 0, + "perf2": 1, + "perf3": 44247, + "pull_count": 8464, + "pull_rank": 47, + "push_count": 28368, + "push_rank": 54, + "star_count": 22253, + "star_rank": 47, + "sloc": 919, + "files": 8, + "author_name": "Linda_pp", + "author_url": "https://github.com/rhysd", + "so_count": 529, + "so_rank": 60, + "lloc": 0 + }, + "d": { + "dir": "d", + "name": "D", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 0, + "perf2": 2, + "perf3": 30773, + "pull_count": 7793, + "pull_rank": 50, + "push_count": 70193, + "push_rank": 48, + "star_count": 18026, + "star_rank": 49, + "sloc": 1317, + "files": 8, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 2531, + "so_rank": 52, + "lloc": 563 + }, + "dart": { + "dir": "dart", + "name": "Dart", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 10, + "perf2": 32, + "perf3": 731, + "pull_count": 59821, + "pull_rank": 33, + "push_count": 152206, + "push_rank": 38, + "star_count": 80668, + "star_rank": 34, + "sloc": 957, + "files": 8, + "author_name": "Harry Terkelsen", + "author_url": "https://github.com/hterkelsen", + "so_count": 24386, + "so_rank": 27, + "lloc": 469 + }, + "elixir": { + "dir": "elixir", + "name": "Elixir", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 10, + "perf2": 40, + "perf3": 968, + "pull_count": 74008, + "pull_rank": 28, + "push_count": 189422, + "push_rank": 36, + "star_count": 155370, + "star_rank": 26, + "sloc": 688, + "files": 10, + "author_name": "Martin Ek", + "author_url": "https://github.com/ekmartin", + "so_count": 7458, + "so_rank": 39, + "lloc": 0 + }, + "elm": { + "dir": "elm", + "name": "Elm", + "syntax": "ML", + "type_check": "Static", + "modes": [], + "perf1": 42, + "perf2": 121, + "perf3": 1341, + "pull_count": 11804, + "pull_rank": 44, + "push_count": 53310, + "push_rank": 49, + "star_count": 32741, + "star_rank": 42, + "sloc": 2348, + "files": 12, + "author_name": "Jos van Bakel", + "author_url": "https://github.com/c0deaddict", + "so_count": 1607, + "so_rank": 55, + "lloc": 0 + }, + "elisp": { + "dir": "elisp", + "name": "Emacs Lisp", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 14, + "perf2": 51, + "perf3": 824, + "pull_count": 52498, + "pull_rank": 34, + "push_count": 314946, + "push_rank": 28, + "star_count": 133893, + "star_rank": 29, + "sloc": 753, + "files": 8, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "so_count": 3693, + "so_rank": 49, + "lloc": 0 + }, + "erlang": { + "dir": "erlang", + "name": "Erlang", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 36, + "perf2": 75, + "perf3": 249, + "pull_count": 67000, + "pull_rank": 30, + "push_count": 258565, + "push_rank": 31, + "star_count": 125110, + "star_rank": 30, + "sloc": 1127, + "files": 8, + "author_name": "Nathan Fiedler", + "author_url": "https://github.com/nlfiedler", + "so_count": 8677, + "so_rank": 37, + "lloc": 0 + }, + "es6": { + "dir": "es6", + "name": "ES6", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 3, + "perf2": 15, + "perf3": 21287, + "pull_count": 6304275, + "pull_rank": 2, + "push_count": 25379428, + "push_rank": 2, + "star_count": 20003913, + "star_rank": 2, + "sloc": 469, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 208944, + "so_rank": 13, + "lloc": 0 + }, + "fsharp": { + "dir": "fsharp", + "name": "F#", + "syntax": "ML", + "type_check": "Static", + "modes": [], + "perf1": 6, + "perf2": 6, + "perf3": 29682, + "pull_count": 28170, + "pull_rank": 38, + "push_count": 131779, + "push_rank": 39, + "star_count": 34126, + "star_rank": 41, + "sloc": 1080, + "files": 11, + "author_name": "Peter Stephens", + "author_url": "https://github.com/pstephens", + "so_count": 15293, + "so_rank": 33, + "lloc": 2 + }, + "factor": { + "dir": "factor", + "name": "Factor", + "syntax": "Stack", + "type_check": "Dynamic", + "modes": [], + "perf1": 1, + "perf2": 1, + "perf3": 41423, + "pull_count": null, + "pull_rank": null, + "push_count": 12251, + "push_rank": 62, + "star_count": 100, + "star_rank": 67, + "sloc": 373, + "files": 8, + "author_name": "Jordan Lewis", + "author_url": "https://github.com/jordanlewis", + "so_count": 62, + "so_rank": 69, + "lloc": 0 + }, + "fantom": { + "dir": "fantom", + "name": "Fantom", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 24, + "perf2": 20, + "perf3": 78813, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 706, + "files": 9, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 56, + "so_rank": 70, + "lloc": 0 + }, + "forth": { + "dir": "forth", + "name": "Forth", + "syntax": "Stack", + "type_check": "OTHER", + "modes": [], + "perf1": 2, + "perf2": 8, + "perf3": 3769, + "pull_count": null, + "pull_rank": null, + "push_count": 7173, + "push_rank": 64, + "star_count": 422, + "star_rank": 65, + "sloc": 1387, + "files": 8, + "author_name": "Chris Houser", + "author_url": "https://github.com/chouser", + "so_count": 220, + "so_rank": 63, + "lloc": 0 + }, + "guile": { + "dir": "guile", + "name": "GNU Guile", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 2, + "perf2": 7, + "perf3": 5084, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 738, + "files": 9, + "author_name": "Mu Lei", + "author_url": "https://github.com/NalaGinrut", + "so_count": 205, + "so_rank": 64, + "lloc": 0 + }, + "gnu-smalltalk": { + "dir": "gnu-smalltalk", + "name": "GNU Smalltalk", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 9, + "perf2": 29, + "perf3": 1223, + "pull_count": 12157, + "pull_rank": 43, + "push_count": 45508, + "push_rank": 50, + "star_count": 2461, + "star_rank": 60, + "sloc": 1036, + "files": 10, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "so_count": 101, + "so_rank": 66, + "lloc": 0 + }, + "go": { + "dir": "go", + "name": "Go", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 4, + "perf3": 15723, + "pull_count": 1544908, + "pull_rank": 9, + "push_count": 3775028, + "push_rank": 12, + "star_count": 4549081, + "star_rank": 6, + "sloc": 1437, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 42897, + "so_rank": 22, + "lloc": 689 + }, + "groovy": { + "dir": "groovy", + "name": "Groovy", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 312, + "perf2": 746, + "perf3": 432, + "pull_count": 95277, + "pull_rank": 26, + "push_count": 369907, + "push_rank": 27, + "star_count": 113888, + "star_rank": 32, + "sloc": 666, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 24411, + "so_rank": 26, + "lloc": 0 + }, + "haskell": { + "dir": "haskell", + "name": "Haskell", + "syntax": "ML", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 5, + "perf3": 13086, + "pull_count": 112254, + "pull_rank": 23, + "push_count": 795668, + "push_rank": 20, + "star_count": 268686, + "star_rank": 23, + "sloc": 688, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 42877, + "so_rank": 23, + "lloc": 0 + }, + "haxe": { + "dir": "haxe", + "name": "Haxe", + "syntax": "C", + "type_check": "Static", + "modes": [ + "neko", + "python", + "cpp", + "js" + ], + "perf1": 3, + "perf2": 16, + "perf3": 22443, + "pull_count": 13168, + "pull_rank": 42, + "push_count": 72533, + "push_rank": 46, + "star_count": 26516, + "star_rank": 45, + "sloc": 1113, + "files": 11, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 1456, + "so_rank": 56, + "lloc": 462 + }, + "hy": { + "dir": "hy", + "name": "Hy", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 16, + "perf2": 61, + "perf3": 628, + "pull_count": 108, + "pull_rank": 64, + "push_count": 1442, + "push_rank": 67, + "star_count": 308, + "star_rank": 66, + "sloc": 381, + "files": 7, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 36, + "so_rank": 73, + "lloc": 0 + }, + "io": { + "dir": "io", + "name": "Io", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 236, + "perf2": 822, + "perf3": 38, + "pull_count": null, + "pull_rank": null, + "push_count": 224, + "push_rank": 68, + "star_count": null, + "star_rank": null, + "sloc": 526, + "files": 7, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 15173, + "so_rank": 34, + "lloc": 0 + }, + "java": { + "dir": "java", + "name": "Java", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 13, + "perf2": 16, + "perf3": 101403, + "pull_count": 2806217, + "pull_rank": 5, + "push_count": 13507281, + "push_rank": 5, + "star_count": 7179519, + "star_rank": 5, + "sloc": 1543, + "files": 9, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 1623967, + "so_rank": 2, + "lloc": 698 + }, + "js": { + "dir": "js", + "name": "JavaScript", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 3, + "perf2": 17, + "perf3": 20616, + "pull_count": 6304275, + "pull_rank": 1, + "push_count": 25379428, + "push_rank": 1, + "star_count": 20003913, + "star_rank": 1, + "sloc": 851, + "files": 10, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 3406494, + "so_rank": 1, + "lloc": 0 + }, + "jq": { + "dir": "jq", + "name": "jq", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 124.784912109375, + "perf2": 316.791015625, + "perf3": 41, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 1801, + "files": 9, + "author_name": "Ali MohammadPur", + "author_url": "https://github.com/alimpfard", + "so_count": 2794, + "so_rank": 51, + "lloc": 0 + }, + "julia": { + "dir": "julia", + "name": "Julia", + "syntax": "Algol", + "type_check": "Dynamic", + "modes": [], + "perf1": 61, + "perf2": 17, + "perf3": 4531, + "pull_count": 49634, + "pull_rank": 35, + "push_count": 209318, + "push_rank": 35, + "star_count": 40736, + "star_rank": 38, + "sloc": 556, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 6280, + "so_rank": 42, + "lloc": 0 + }, + "kotlin": { + "dir": "kotlin", + "name": "Kotlin", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 13, + "perf2": 45, + "perf3": 49803, + "pull_count": 82740, + "pull_rank": 27, + "push_count": 286890, + "push_rank": 29, + "star_count": 252618, + "star_rank": 24, + "sloc": 737, + "files": 8, + "author_name": "Javier Fernandez-Ivern", + "author_url": "https://github.com/ivern", + "so_count": 33094, + "so_rank": 24, + "lloc": 0 + }, + "livescript": { + "dir": "livescript", + "name": "LiveScript", + "syntax": "ML", + "type_check": "Dynamic", + "modes": [], + "perf1": 5, + "perf2": 15, + "perf3": 11438, + "pull_count": 238, + "pull_rank": 61, + "push_count": 14627, + "push_rank": 60, + "star_count": 8990, + "star_rank": 51, + "sloc": 762, + "files": 8, + "author_name": "Jos van Bakel", + "author_url": "https://github.com/c0deaddict", + "so_count": 66, + "so_rank": 67, + "lloc": 0 + }, + "logo": { + "dir": "logo", + "name": "Logo", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 12894, + "perf2": 41700, + "perf3": 0, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 1022, + "files": 8, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 45, + "so_rank": 71, + "lloc": 0 + }, + "lua": { + "dir": "lua", + "name": "Lua", + "syntax": "Algol", + "type_check": "Dynamic", + "modes": [], + "perf1": 8, + "perf2": 27, + "perf3": 1436, + "pull_count": 110392, + "pull_rank": 24, + "push_count": 630988, + "push_rank": 24, + "star_count": 275531, + "star_rank": 22, + "sloc": 920, + "files": 9, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 16329, + "so_rank": 31, + "lloc": 0 + }, + "make": { + "dir": "make", + "name": "GNU Make", + "syntax": "OTHER", + "type_check": "OTHER", + "modes": [], + "perf1": 3300, + "perf2": 16544, + "perf3": 2, + "pull_count": 71627, + "pull_rank": 29, + "push_count": 275049, + "push_rank": 30, + "star_count": 68614, + "star_rank": 35, + "sloc": 1031, + "files": 12, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 19981, + "so_rank": 29, + "lloc": 0 + }, + "mal": { + "dir": "mal", + "name": "mal itself", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 88, + "perf2": 421, + "perf3": 90, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 207, + "files": 4, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 0, + "so_rank": 84, + "lloc": 0 + }, + "matlab": { + "dir": "matlab", + "name": "MATLAB", + "syntax": "Algol", + "type_check": "Dynamic", + "modes": [], + "perf1": 1042, + "perf2": 3654, + "perf3": 9, + "pull_count": 2984, + "pull_rank": 57, + "push_count": 14280, + "push_rank": 61, + "star_count": 3086, + "star_rank": 59, + "sloc": 1086, + "files": 17, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 86207, + "so_rank": 18, + "lloc": 0 + }, + "miniMAL": { + "dir": "miniMAL", + "name": "miniMAL", + "syntax": "JSON", + "type_check": "Dynamic", + "modes": [], + "perf1": 821, + "perf2": 3251, + "perf3": 11, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 836, + "files": 9, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 0, + "so_rank": 81, + "lloc": 0 + }, + "nasm": { + "dir": "nasm", + "name": "NASM", + "syntax": "OTHER", + "type_check": "OTHER", + "modes": [], + "perf1": 1, + "perf2": 1, + "perf3": 36581, + "pull_count": 10523, + "pull_rank": 45, + "push_count": 98138, + "push_rank": 41, + "star_count": 35975, + "star_rank": 40, + "sloc": 6170, + "files": 9, + "author_name": "Ben Dudson", + "author_url": "https://github.com/bendudson", + "so_count": 3740, + "so_rank": 48, + "lloc": 0 + }, + "nim": { + "dir": "nim", + "name": "Nim", + "syntax": "Python", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 1, + "perf3": 39173, + "pull_count": 2009, + "pull_rank": 58, + "push_count": 9302, + "push_rank": 63, + "star_count": 6954, + "star_rank": 53, + "sloc": 610, + "files": 7, + "author_name": "Dennis Felsing", + "author_url": "https://github.com/def-", + "so_count": 0, + "so_rank": 80, + "lloc": 0 + }, + "objpascal": { + "dir": "objpascal", + "name": "Object Pascal", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 2, + "perf2": 8, + "perf3": 4264, + "pull_count": 5881, + "pull_rank": 51, + "push_count": 77775, + "push_rank": 45, + "star_count": 26713, + "star_rank": 44, + "sloc": 1608, + "files": 9, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 59299, + "so_rank": 21, + "lloc": 995 + }, + "objc": { + "dir": "objc", + "name": "Objective C", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 4, + "perf2": 16, + "perf3": 2175, + "pull_count": 284470, + "pull_rank": 15, + "push_count": 1356112, + "push_rank": 14, + "star_count": 3173498, + "star_rank": 9, + "sloc": 1132, + "files": 16, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 288979, + "so_rank": 10, + "lloc": 501 + }, + "ocaml": { + "dir": "ocaml", + "name": "OCaml", + "syntax": "ML", + "type_check": "Static", + "modes": [], + "perf1": 0, + "perf2": 1, + "perf3": 35638, + "pull_count": 63111, + "pull_rank": 31, + "push_count": 244361, + "push_rank": 33, + "star_count": 99996, + "star_rank": 33, + "sloc": 560, + "files": 7, + "author_name": "Chris Houser", + "author_url": "https://github.com/chouser", + "so_count": 6012, + "so_rank": 43, + "lloc": 0 + }, + "perl": { + "dir": "perl", + "name": "Perl", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 7, + "perf2": 27, + "perf3": 1486, + "pull_count": 128831, + "pull_rank": 22, + "push_count": 677400, + "push_rank": 23, + "star_count": 139906, + "star_rank": 28, + "sloc": 812, + "files": 9, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 64002, + "so_rank": 20, + "lloc": 412 + }, + "perl6": { + "dir": "perl6", + "name": "Perl 6", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 256, + "perf2": 746, + "perf3": 38, + "pull_count": 3720, + "pull_rank": 54, + "push_count": 18069, + "push_rank": 59, + "star_count": 1314, + "star_rank": 61, + "sloc": 459, + "files": 7, + "author_name": "Hinrik Örn Sigurðsson", + "author_url": "https://github.com/hinrik", + "so_count": 0, + "so_rank": 79, + "lloc": 156 + }, + "php": { + "dir": "php", + "name": "PHP", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 6, + "perf2": 21, + "perf3": 1662, + "pull_count": 2110353, + "pull_rank": 7, + "push_count": 9601954, + "push_rank": 6, + "star_count": 3273737, + "star_rank": 8, + "sloc": 938, + "files": 10, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 1325705, + "so_rank": 6, + "lloc": 514 + }, + "picolisp": { + "dir": "picolisp", + "name": "Picolisp", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 1, + "perf2": 4, + "perf3": 7689, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 561, + "files": 9, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "so_count": 6, + "so_rank": 78, + "lloc": 0 + }, + "pike": { + "dir": "pike", + "name": "Pike", + "syntax": "C", + "type_check": "OTHER", + "modes": [], + "perf1": 3, + "perf2": 10, + "perf3": 3684, + "pull_count": null, + "pull_rank": null, + "push_count": 103, + "push_rank": 69, + "star_count": null, + "star_rank": null, + "sloc": 861, + "files": 9, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 12, + "so_rank": 75, + "lloc": 427 + }, + "plpgsql": { + "dir": "plpgsql", + "name": "PL/pgSQL", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 389, + "perf2": 1898, + "perf3": 24, + "pull_count": 18439, + "pull_rank": 41, + "push_count": 93224, + "push_rank": 43, + "star_count": 19492, + "star_rank": 48, + "sloc": 1848, + "files": 11, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 3059, + "so_rank": 50, + "lloc": 0 + }, + "plsql": { + "dir": "plsql", + "name": "PL/SQL", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": null, + "perf2": null, + "perf3": 0, + "pull_count": 10393, + "pull_rank": 46, + "push_count": 34307, + "push_rank": 51, + "star_count": 4745, + "star_rank": 57, + "sloc": 2195, + "files": 11, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 22058, + "so_rank": 28, + "lloc": 0 + }, + "powershell": { + "dir": "powershell", + "name": "PowerShell", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 1169, + "perf2": 4627, + "perf3": 8, + "pull_count": 62578, + "pull_rank": 32, + "push_count": 236684, + "push_rank": 34, + "star_count": 116882, + "star_rank": 31, + "sloc": 790, + "files": 7, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 75976, + "so_rank": 19, + "lloc": 0 + }, + "ps": { + "dir": "ps", + "name": "PostScript", + "syntax": "Stack", + "type_check": "Dynamic", + "modes": [], + "perf1": 30, + "perf2": 171, + "perf3": 276, + "pull_count": 1644, + "pull_rank": 59, + "push_count": 19912, + "push_rank": 58, + "star_count": 1034, + "star_rank": 62, + "sloc": 1235, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 476, + "so_rank": 61, + "lloc": 0 + }, + "python": { + "dir": "python", + "name": "Python", + "syntax": "Python", + "type_check": "Dynamic", + "modes": [ + "python2", + "python3" + ], + "perf1": 6, + "perf2": 24, + "perf3": 1565, + "pull_count": 4379644, + "pull_rank": 3, + "push_count": 16425146, + "push_rank": 3, + "star_count": 7834904, + "star_rank": 3, + "sloc": 583, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 1618481, + "so_rank": 3, + "lloc": 0 + }, + "python.2": { + "dir": "python.2", + "name": "Python #2", + "syntax": "Python", + "type_check": "Dynamic", + "modes": [], + "perf1": 8, + "perf2": 30, + "perf3": 1289, + "pull_count": 4379644, + "pull_rank": 4, + "push_count": 16425146, + "push_rank": 4, + "star_count": 7834904, + "star_rank": 4, + "sloc": 965, + "files": 6, + "author_name": "Gavin Lewis", + "author_url": "https://github.com/epylar", + "so_count": 1618481, + "so_rank": 4, + "lloc": 0 + }, + "rpython": { + "dir": "rpython", + "name": "RPython", + "syntax": "Python", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 1, + "perf3": 95295, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 1012, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 64, + "so_rank": 68, + "lloc": 0 + }, + "r": { + "dir": "r", + "name": "R", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 56, + "perf2": 194, + "perf3": 179, + "pull_count": 46637, + "pull_rank": 36, + "push_count": 490385, + "push_rank": 26, + "star_count": 65937, + "star_rank": 36, + "sloc": 733, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 322017, + "so_rank": 8, + "lloc": 0 + }, + "racket": { + "dir": "racket", + "name": "Racket", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [], + "perf1": 2, + "perf2": 5, + "perf3": 7546, + "pull_count": 3167, + "pull_rank": 56, + "push_count": 29122, + "push_rank": 53, + "star_count": 6672, + "star_rank": 54, + "sloc": 510, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 4683, + "so_rank": 47, + "lloc": 0 + }, + "rexx": { + "dir": "rexx", + "name": "Rexx", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 117, + "perf2": 457, + "perf3": 82, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 1210, + "files": 8, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 139, + "so_rank": 65, + "lloc": 0 + }, + "ruby": { + "dir": "ruby", + "name": "Ruby", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 2, + "perf2": 5, + "perf3": 5726, + "pull_count": 2335479, + "pull_rank": 6, + "push_count": 6368990, + "push_rank": 8, + "star_count": 3024866, + "star_rank": 10, + "sloc": 451, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 209973, + "so_rank": 12, + "lloc": 0 + }, + "rust": { + "dir": "rust", + "name": "Rust", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 0, + "perf2": 1, + "perf3": 24833, + "pull_count": 231464, + "pull_rank": 20, + "push_count": 779153, + "push_rank": 21, + "star_count": 493142, + "star_rank": 20, + "sloc": 1147, + "files": 7, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 14713, + "so_rank": 35, + "lloc": 179 + }, + "scala": { + "dir": "scala", + "name": "Scala", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 25, + "perf2": 40, + "perf3": 54155, + "pull_count": 380802, + "pull_rank": 14, + "push_count": 1209536, + "push_rank": 15, + "star_count": 469698, + "star_rank": 21, + "sloc": 816, + "files": 7, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 94482, + "so_rank": 17, + "lloc": 0 + }, + "scheme": { + "dir": "scheme", + "name": "Scheme (R7RS)", + "syntax": "Lisp", + "type_check": "Dynamic", + "modes": [ + "chibi", + "kawa", + "gauche", + "chicken", + "sagittarius", + "cyclone", + "foment" + ], + "perf1": 4, + "perf2": 12, + "perf3": 3300, + "pull_count": 4067, + "pull_rank": 53, + "push_count": 70230, + "push_rank": 47, + "star_count": 24230, + "star_rank": 46, + "sloc": 921, + "files": 8, + "author_name": "Vasilij Schneidermann", + "author_url": "https://github.com/wasamasa", + "so_count": 7007, + "so_rank": 40, + "lloc": 0 + }, + "skew": { + "dir": "skew", + "name": "Skew", + "syntax": "OTHER", + "type_check": "Static", + "modes": [], + "perf1": 3, + "perf2": 8, + "perf3": 4275, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 713, + "files": 8, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 307, + "so_rank": 62, + "lloc": 0 + }, + "swift": { + "dir": "swift", + "name": "Swift 2", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 2, + "perf2": 6, + "perf3": 6276, + "pull_count": 267533, + "pull_rank": 16, + "push_count": 1007930, + "push_rank": 16, + "star_count": 2232496, + "star_rank": 12, + "sloc": 2454, + "files": 10, + "author_name": "Keith Rollin", + "author_url": "https://github.com/keith-rollin", + "so_count": 8498, + "so_rank": 38, + "lloc": 0 + }, + "swift3": { + "dir": "swift3", + "name": "Swift 3", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 7, + "perf2": 21, + "perf3": 1576, + "pull_count": 267533, + "pull_rank": 17, + "push_count": 1007930, + "push_rank": 17, + "star_count": 2232496, + "star_rank": 13, + "sloc": 1159, + "files": 7, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 18306, + "so_rank": 30, + "lloc": 0 + }, + "swift4": { + "dir": "swift4", + "name": "Swift 4", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 3, + "perf2": 11, + "perf3": 3150, + "pull_count": 267533, + "pull_rank": 18, + "push_count": 1007930, + "push_rank": 18, + "star_count": 2232496, + "star_rank": 14, + "sloc": 735, + "files": 7, + "author_name": "陆遥", + "author_url": "https://github.com/LispLY", + "so_count": 5596, + "so_rank": 44, + "lloc": 0 + }, + "swift5": { + "dir": "swift5", + "name": "Swift 5", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 2, + "perf2": 7, + "perf3": 4376, + "pull_count": 267533, + "pull_rank": 19, + "push_count": 1007930, + "push_rank": 19, + "star_count": 2232496, + "star_rank": 15, + "sloc": 1221, + "files": 11, + "author_name": "Oleg Montak", + "author_url": "https://github.com/MontakOleg", + "so_count": 259095, + "so_rank": 11, + "lloc": 0 + }, + "tcl": { + "dir": "tcl", + "name": "Tcl", + "syntax": "OTHER", + "type_check": "Dynamic", + "modes": [], + "perf1": 19, + "perf2": 68, + "perf3": 492, + "pull_count": 3399, + "pull_rank": 55, + "push_count": 29686, + "push_rank": 52, + "star_count": 3525, + "star_rank": 58, + "sloc": 1065, + "files": 8, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 6451, + "so_rank": 41, + "lloc": 0 + }, + "ts": { + "dir": "ts", + "name": "TypeScript", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 2, + "perf2": 9, + "perf3": 42027, + "pull_count": 796454, + "pull_rank": 12, + "push_count": 1902035, + "push_rank": 13, + "star_count": 1364269, + "star_rank": 18, + "sloc": 1271, + "files": 8, + "author_name": "Masahiro Wakame", + "author_url": "https://github.com/vvakame", + "so_count": 103029, + "so_rank": 16, + "lloc": 0 + }, + "vala": { + "dir": "vala", + "name": "Vala", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 4, + "perf2": 16, + "perf3": 2367, + "pull_count": 8062, + "pull_rank": 49, + "push_count": 82567, + "push_rank": 44, + "star_count": 31421, + "star_rank": 43, + "sloc": 2209, + "files": 8, + "author_name": "Simon Tatham", + "author_url": "https://github.com/sgtatham", + "so_count": 841, + "so_rank": 57, + "lloc": 1098 + }, + "vhdl": { + "dir": "vhdl", + "name": "VHDL", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 2, + "perf2": 6, + "perf3": 5204, + "pull_count": 240, + "pull_rank": 60, + "push_count": 21203, + "push_rank": 57, + "star_count": 5902, + "star_rank": 56, + "sloc": 1920, + "files": 9, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 5013, + "so_rank": 46, + "lloc": 0 + }, + "vimscript": { + "dir": "vimscript", + "name": "Vimscript", + "syntax": "Algol", + "type_check": "Dynamic", + "modes": [], + "perf1": 130, + "perf2": 581, + "perf3": 73, + "pull_count": 21140, + "pull_rank": 39, + "push_count": 155625, + "push_rank": 37, + "star_count": 140033, + "star_rank": 27, + "sloc": 982, + "files": 10, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 41, + "so_rank": 72, + "lloc": 12 + }, + "vb": { + "dir": "vb", + "name": "Visual Basic.NET", + "syntax": "Algol", + "type_check": "Static", + "modes": [], + "perf1": 8, + "perf2": 9, + "perf3": 19152, + "pull_count": 31745, + "pull_rank": 37, + "push_count": 116528, + "push_rank": 40, + "star_count": 13449, + "star_rank": 50, + "sloc": 1460, + "files": 8, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 127657, + "so_rank": 14, + "lloc": 0 + }, + "wasm": { + "dir": "wasm", + "name": "WebAssembly", + "syntax": "Lisp", + "type_check": "Static", + "modes": [ + "wace_libc", + "node", + "warpy" + ], + "perf1": 4, + "perf2": 6, + "perf3": 5518, + "pull_count": 4588, + "pull_rank": 52, + "push_count": 6630, + "push_rank": 65, + "star_count": 6337, + "star_rank": 55, + "sloc": 3051, + "files": 16, + "author_name": "Joel Martin", + "author_url": "https://github.com/kanaka", + "so_count": 756, + "so_rank": 58, + "lloc": 0 + }, + "wren": { + "dir": "wren", + "name": "Wren", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 1, + "perf2": 7, + "perf3": 4619, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 639, + "files": 9, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 0, + "so_rank": 82, + "lloc": 0 + }, + "yorick": { + "dir": "yorick", + "name": "Yorick", + "syntax": "C", + "type_check": "Dynamic", + "modes": [], + "perf1": 51, + "perf2": 228, + "perf3": 191, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 1010, + "files": 8, + "author_name": "Dov Murik", + "author_url": "https://github.com/dubek", + "so_count": 0, + "so_rank": 83, + "lloc": 106 + }, + "zig": { + "dir": "zig", + "name": "Zig", + "syntax": "C", + "type_check": "Static", + "modes": [], + "perf1": 1, + "perf2": 3, + "perf3": 7244, + "pull_count": null, + "pull_rank": null, + "push_count": null, + "push_rank": null, + "star_count": null, + "star_rank": null, + "sloc": 2673, + "files": 14, + "author_name": "Josh Tobin", + "author_url": "https://github.com/rjtobin", + "so_count": 6, + "so_rank": 77, + "lloc": 0 + } } \ No newline at end of file diff --git a/docs/graph/base_data.yaml b/docs/graph/base_data.yaml index 3ff703d35a..45daa40bec 100644 --- a/docs/graph/base_data.yaml +++ b/docs/graph/base_data.yaml @@ -1,88 +1,88 @@ -headers: - - [dir , name , syntax , type_check , modes] - -languages: - - [ada , Ada , Algol , Static , []] - - [ada.2 , 'Ada #2' , Algol , Static , []] - - [awk , GNU Awk , C , Dynamic , []] - - [bash , Bash 4 , OTHER , Dynamic , []] - - [basic , BASIC , OTHER , Static , [cbm, qbasic]] - - [bbc-basic , BBC BASIC V , OTHER , Static , []] - - [c , C , C , Static , []] - - [cpp , C++ , C , Static , []] - - [cs , C# , C , Static , []] - - [chuck , ChucK , C , Static , []] - - [clojure , Clojure , Lisp , Dynamic , [clj, cljs]] - - [coffee , CoffeeScript , OTHER , Dynamic , []] - - [common-lisp , Common Lisp , Lisp , Dynamic , []] - - [crystal , Crystal , OTHER , Static , []] - - [d , D , C , Static , []] - - [dart , Dart , C , Static , []] - - [elixir , Elixir , OTHER , Dynamic , []] - - [elm , Elm , ML , Static , []] - - [elisp , Emacs Lisp , Lisp , Dynamic , []] - - [erlang , Erlang , OTHER , Dynamic , []] - - [es6 , ES6 , C , Dynamic , []] - - [fsharp , F# , ML , Static , []] - - [factor , Factor , Stack , Dynamic , []] - - [fantom , Fantom , C , Static , []] - - [forth , Forth , Stack , OTHER , []] - - [guile , GNU Guile , Lisp , Dynamic , []] - - [gnu-smalltalk , GNU Smalltalk , OTHER , Dynamic , []] - - [go , Go , C , Static , []] - - [groovy , Groovy , C , Dynamic , []] - - [haskell , Haskell , ML , Static , []] - - [haxe , Haxe , C , Static , [neko,python,cpp,js]] - - [hy , Hy , Lisp , Dynamic , []] - - [io , Io , OTHER , Dynamic , []] - - [java , Java , C , Static , []] - - [js , JavaScript , C , Dynamic , []] - - [jq , jq , OTHER , Dynamic , []] - - [julia , Julia , Algol , Dynamic , []] - - [kotlin , Kotlin , C , Static , []] - - [livescript , LiveScript , ML , Dynamic , []] - - [logo , Logo , OTHER , Dynamic , []] - - [lua , Lua , Algol , Dynamic , []] - - [make , GNU Make , OTHER , OTHER , []] - - [mal , mal itself , Lisp , Dynamic , []] - - [matlab , MATLAB , Algol , Dynamic , []] - - [miniMAL , miniMAL , JSON , Dynamic , []] - - [nasm , NASM , OTHER , OTHER , []] - - [nim , Nim , Python , Static , []] - - [objpascal , Object Pascal , Algol , Static , []] - - [objc , Objective C , C , Static , []] - - [ocaml , OCaml , ML , Static , []] - - [perl , Perl , C , Dynamic , []] - - [perl6 , Perl 6 , C , Dynamic , []] - - [php , PHP , C , Dynamic , []] - - [picolisp , Picolisp , Lisp , Dynamic , []] - - [pike , Pike , C , OTHER , []] - - [plpgsql , PL/pgSQL , Algol , Static , []] - - [plsql , PL/SQL , Algol , Static , []] - - [powershell , PowerShell , OTHER , Dynamic , []] - - [ps , PostScript , Stack , Dynamic , []] - - [python , Python , Python , Dynamic , [python2,python3]] - - [python.2 , 'Python #2' , Python , Dynamic , []] - - [rpython , RPython , Python , Static , []] - - [r , R , C , Dynamic , []] - - [racket , Racket , Lisp , Dynamic , []] - - [rexx , Rexx , OTHER , Dynamic , []] - - [ruby , Ruby , OTHER , Dynamic , []] - - [rust , Rust , C , Static , []] - - [scala , Scala , C , Static , []] - - [scheme , Scheme (R7RS) , Lisp , Dynamic , [chibi,kawa,gauche,chicken,sagittarius,cyclone,foment]] - - [skew , Skew , OTHER , Static , []] - - [swift , Swift 2 , C , Static , []] - - [swift3 , Swift 3 , C , Static , []] - - [swift4 , Swift 4 , C , Static , []] - - [swift5 , Swift 5 , C , Static , []] - - [tcl , Tcl , OTHER , Dynamic , []] - - [ts , TypeScript , C , Static , []] - - [vala , Vala , C , Static , []] - - [vhdl , VHDL , Algol , Static , []] - - [vimscript , Vimscript , Algol , Dynamic , []] - - [vb , Visual Basic.NET , Algol , Static , []] - - [wasm , WebAssembly , Lisp , Static , [wace_libc,node,warpy]] - - [wren , Wren , C , Dynamic , []] - - [yorick , Yorick , C , Dynamic , []] - - [zig , Zig , C , Static , []] +headers: + - [dir , name , syntax , type_check , modes] + +languages: + - [ada , Ada , Algol , Static , []] + - [ada.2 , 'Ada #2' , Algol , Static , []] + - [awk , GNU Awk , C , Dynamic , []] + - [bash , Bash 4 , OTHER , Dynamic , []] + - [basic , BASIC , OTHER , Static , [cbm, qbasic]] + - [bbc-basic , BBC BASIC V , OTHER , Static , []] + - [c , C , C , Static , []] + - [cpp , C++ , C , Static , []] + - [cs , C# , C , Static , []] + - [chuck , ChucK , C , Static , []] + - [clojure , Clojure , Lisp , Dynamic , [clj, cljs]] + - [coffee , CoffeeScript , OTHER , Dynamic , []] + - [common-lisp , Common Lisp , Lisp , Dynamic , []] + - [crystal , Crystal , OTHER , Static , []] + - [d , D , C , Static , []] + - [dart , Dart , C , Static , []] + - [elixir , Elixir , OTHER , Dynamic , []] + - [elm , Elm , ML , Static , []] + - [elisp , Emacs Lisp , Lisp , Dynamic , []] + - [erlang , Erlang , OTHER , Dynamic , []] + - [es6 , ES6 , C , Dynamic , []] + - [fsharp , F# , ML , Static , []] + - [factor , Factor , Stack , Dynamic , []] + - [fantom , Fantom , C , Static , []] + - [forth , Forth , Stack , OTHER , []] + - [guile , GNU Guile , Lisp , Dynamic , []] + - [gnu-smalltalk , GNU Smalltalk , OTHER , Dynamic , []] + - [go , Go , C , Static , []] + - [groovy , Groovy , C , Dynamic , []] + - [haskell , Haskell , ML , Static , []] + - [haxe , Haxe , C , Static , [neko,python,cpp,js]] + - [hy , Hy , Lisp , Dynamic , []] + - [io , Io , OTHER , Dynamic , []] + - [java , Java , C , Static , []] + - [js , JavaScript , C , Dynamic , []] + - [jq , jq , OTHER , Dynamic , []] + - [julia , Julia , Algol , Dynamic , []] + - [kotlin , Kotlin , C , Static , []] + - [livescript , LiveScript , ML , Dynamic , []] + - [logo , Logo , OTHER , Dynamic , []] + - [lua , Lua , Algol , Dynamic , []] + - [make , GNU Make , OTHER , OTHER , []] + - [mal , mal itself , Lisp , Dynamic , []] + - [matlab , MATLAB , Algol , Dynamic , []] + - [miniMAL , miniMAL , JSON , Dynamic , []] + - [nasm , NASM , OTHER , OTHER , []] + - [nim , Nim , Python , Static , []] + - [objpascal , Object Pascal , Algol , Static , []] + - [objc , Objective C , C , Static , []] + - [ocaml , OCaml , ML , Static , []] + - [perl , Perl , C , Dynamic , []] + - [perl6 , Perl 6 , C , Dynamic , []] + - [php , PHP , C , Dynamic , []] + - [picolisp , Picolisp , Lisp , Dynamic , []] + - [pike , Pike , C , OTHER , []] + - [plpgsql , PL/pgSQL , Algol , Static , []] + - [plsql , PL/SQL , Algol , Static , []] + - [powershell , PowerShell , OTHER , Dynamic , []] + - [ps , PostScript , Stack , Dynamic , []] + - [python , Python , Python , Dynamic , [python2,python3]] + - [python.2 , 'Python #2' , Python , Dynamic , []] + - [rpython , RPython , Python , Static , []] + - [r , R , C , Dynamic , []] + - [racket , Racket , Lisp , Dynamic , []] + - [rexx , Rexx , OTHER , Dynamic , []] + - [ruby , Ruby , OTHER , Dynamic , []] + - [rust , Rust , C , Static , []] + - [scala , Scala , C , Static , []] + - [scheme , Scheme (R7RS) , Lisp , Dynamic , [chibi,kawa,gauche,chicken,sagittarius,cyclone,foment]] + - [skew , Skew , OTHER , Static , []] + - [swift , Swift 2 , C , Static , []] + - [swift3 , Swift 3 , C , Static , []] + - [swift4 , Swift 4 , C , Static , []] + - [swift5 , Swift 5 , C , Static , []] + - [tcl , Tcl , OTHER , Dynamic , []] + - [ts , TypeScript , C , Static , []] + - [vala , Vala , C , Static , []] + - [vhdl , VHDL , Algol , Static , []] + - [vimscript , Vimscript , Algol , Dynamic , []] + - [vb , Visual Basic.NET , Algol , Static , []] + - [wasm , WebAssembly , Lisp , Static , [wace_libc,node,warpy]] + - [wren , Wren , C , Dynamic , []] + - [yorick , Yorick , C , Dynamic , []] + - [zig , Zig , C , Static , []] diff --git a/docs/graph/collect_data.js b/docs/graph/collect_data.js index 736ae8c509..521e74d184 100755 --- a/docs/graph/collect_data.js +++ b/docs/graph/collect_data.js @@ -1,291 +1,291 @@ -#!/usr/bin/env python - -const { promisify } = require('util') -const readFile = promisify(require('fs').readFile) -const writeFile = promisify(require('fs').writeFile) -const readdir = promisify(require('fs').readdir) -const path = require('path') -const yaml = require('js-yaml') -const csv = require('csvtojson') -const request = require('request-promise-native') -const exec = promisify(require('child_process').exec) - -const VERBOSE = process.env['VERBOSE'] || false -const BASE_PATH = process.env['BASE_PATH'] || 'base_data.yaml' -const README_PATH = process.env['README_PATH'] || '../../README.md' -const MAL_PATH = process.env['MAL_PATH'] || '../../' - -// GitHut 2.0 Pull Requests -const GITHUT_PULL_URL = process.env['GITHUT_PULL_URL'] || 'https://raw.githubusercontent.com/madnight/githut/master/src/data/gh-pull-request.json' -// GitHut 2.0 Pushes -const GITHUT_PUSH_URL = process.env['GITHUT_PUSH_URL'] || 'https://raw.githubusercontent.com/madnight/githut/master/src/data/gh-push-event.json' -// GitHut 2.0 Stars -const GITHUT_STAR_URL = process.env['GITHUT_STAR_URL'] || 'https://raw.githubusercontent.com/madnight/githut/master/src/data/gh-star-event.json' - -// Refresh this link using this Query page: -// https://data.stackexchange.com/stackoverflow/query/edit/1013465 -const SO_TAG_CSV_URL = process.env['SO_TAG_CSV_URL'] || 'https://data.stackexchange.com/stackoverflow/csv/1252107' - - -const githutToNames = { - 'Awk': ['GNU Awk'], - 'Ada': ['Ada', 'Ada #2'], - 'Shell': ['Bash 4'], - 'JavaScript': ['JavaScript', 'ES6'], - 'Makefile': ['GNU Make'], - 'Matlab': ['MATLAB'], - 'Assembly': ['NASM'], - 'Pascal': ['Object Pascal'], - 'Objective-C': ['Objective C'], - 'PLpgSQL': ['PL/pgSQL'], - 'PLSQL': ['PL/SQL'], - 'Python': ['Python', 'Python #2'], - 'Scheme': ['Scheme (R7RS)'], - 'Smalltalk': ['GNU Smalltalk'], - 'Swift': ['Swift 2', 'Swift 3', 'Swift 4', 'Swift 5'], - 'Vim script': ['Vimscript'], - 'Visual Basic': ['Visual Basic.NET'], -} -const dirToSOTags = { - 'ada.2': ['ada'], - 'bbc-basic': ['bbc-micro'], - 'cpp': ['c++', 'c++98', 'c++11', 'c++14', 'c++17'], - 'coffee': ['coffeescript'], - 'crystal': ['crystal-lang'], - 'cs': ['c#', 'c#-2.0', 'c#-3.0', 'c#-4.0'], - 'es6': ['ecmascript-6', 'es6-promise', 'es6-modules', 'es6-class', 'reactjs'], - 'fsharp': ['f#', 'f#-interactive', 'f#-data', 'f#-3.0'], - 'factor': ['factor-lang'], - 'js': ['javascript', 'node.js', 'jquery', 'angular'], - 'logo': ['logo-lang'], - 'make': ['makefile'], - 'objpascal': ['delphi', 'freepascal', 'delphi-7', 'delphi-2007', 'delphi-2009', 'delphi-2010', 'delphi-xe', 'delphi-xe2', 'delphi-xe3', 'delphi-xe4', 'delphi-xe5', 'delphi-xe7'], - 'objc': ['objective-c'], - 'python': ['python', 'python-3.x', 'python-2.7'], - 'python.2': ['python', 'python-3.x', 'python-2.7'], - 'swift': ['swift2'], - 'swift3': ['swift3'], - 'swift4': ['swift4'], - 'swift5': ['swift', 'swift4', 'swift5'], - 'ts': ['typescript', 'typescript-generics', 'typescript2.0'], - 'vimscript': ['viml'], - 'vb': ['vb.net'], - 'wasm': ['webassembly'], -} - -function vlog(...args) { - if (VERBOSE) { - console.log(...args) - } -} - -function die(code, ...args) { - console.error(...args) - process.exit(code) -} - -async function main() { - const logsPath = path.resolve(process.argv[2]) - const outPath = path.resolve(process.argv[3]) - - vlog(`Loading base data yaml from '${BASE_PATH}`) - const baseYaml = yaml.safeLoad(await readFile(BASE_PATH, 'utf8')) - vlog(`Loading README text from '${README_PATH}`) - const readmeLines = (await readFile(README_PATH, 'utf8')).split(/\n/) - vlog(`Downloading GitHut Pulls HTML from '${GITHUT_PULL_URL}`) - const githutPullText = (await request(GITHUT_PULL_URL)) - vlog(`Downloading GitHut Pushes HTML from '${GITHUT_PUSH_URL}`) - const githutPushText = (await request(GITHUT_PUSH_URL)) - vlog(`Downloading GitHut Stars HTML from '${GITHUT_STAR_URL}`) - const githutStarText = (await request(GITHUT_STAR_URL)) - vlog(`Downloading StackOverflow Tag CSV from '${SO_TAG_CSV_URL}`) - const soTagList = await csv().fromStream(request.get(SO_TAG_CSV_URL)) - vlog(`Loading log data from '${logsPath}'`) - const logFiles = (await readdir(logsPath)) - .map(x => parseInt(x)) - .sort((a, b) => a - b) - let logData = [] - for (const f of logFiles) { - if (!(/^[0-9]+$/.exec(f))) { continue } - const path = logsPath + "/" + f - logData.push([await readFile(path, 'utf8'), path, f]) - } - - let dirs = [] - let names = [] - let dataList = [] - let dataByDir = {} - let dataByName = {} - - vlog(`Processing base data`) - for (let d of baseYaml['languages']) { - let data = {'dir': d[0], - 'name': d[1], - 'syntax': d[2], - 'type_check': d[3], - 'modes': d[4], - 'perf1': null, - 'perf2': null, - 'perf3': 0, - 'pull_count': null, - 'pull_rank': null, - 'push_count': null, - 'push_rank': null, - 'star_count': null, - 'star_rank': null, - 'sloc': 0, - 'files': 0} - dirs.push(d[0]) - names.push(d[1]) - dataList.push(data) - dataByDir[d[0]] = data - dataByName[d[1]] = data - } - - - vlog(`Processing README implementations table`) - const readme_re = /^\| \[([^\[]*)\].* \| \[([^|]*)\]\(([^|]*)\) *\| *$/ - for (let row of readmeLines.filter(l => /^\| [\[]/.exec(l))) { - t = readme_re.exec(row) - if (t) { - if (t[1] in dataByName) { - let data = dataByName[t[1]] - data.author_name = t[2] - data.author_url = t[3] - } else { - die(1, `README language '${t[1]}' not found in base data`) - } - } else { - die(1, `No match for README table row: ${row}`) - } - } - - - function githutProcess(textData, kind) { - const gMap = JSON.parse(textData) - .reduce((m, d) => (m[d.name] = parseInt(d.count) + (m[d.name] || 0), m), {}) - const gdata = Object.entries(gMap) - .sort(([k1,v1],[k2,v2]) => v2 - v1) - let curRank = 1 - for (let [gname, gcount] of gdata) { - const names = githutToNames[gname] || [gname] - for (let name of names) { - if (name in dataByName) { - dataByName[name][kind + '_count'] = gcount - dataByName[name][kind + '_rank'] = curRank - vlog(` ${dataByName[name].dir} count: ${gcount}, rank: ${curRank}`) - curRank += 1 - } else { - vlog(` ignoring GitHut language ${name}`) - } - } - } - return curRank; - } - vlog(`Processing GitHut Pull Request data`) - githutProcess(githutPullText, 'pull') - vlog(`Processing GitHut Push data`) - githutProcess(githutPushText, 'push') - vlog(`Processing GitHut Stars data`) - githutProcess(githutStarText, 'star') - - - vlog(`Processing StackOverflow tag data`) - const soMap = soTagList - //.map(d => ({tag: d.TagName, count: parseInt(d.Rate)})) - //.sort((a,b) => b.count - a.count) - .reduce((m,d) => (m[d.TagName] = parseInt(d.Rate), m), {}) - soMap['mal'] = 0 // NOTE/TODO: StackOverflow mal is something else - for (let dir of dirs) { - if (!('so_count' in dataByDir[dir])) { - dataByDir[dir]['so_count'] = 0 - } - let tags = dirToSOTags[dir] - if (!tags) { - if (dir in soMap) { - tags = [dir] - } else { - vlog(` ${dir} not found as StackOverflow tag`) - tags = [] - } - } - for (let tag of tags) { - if (tag in soMap) { - dataByDir[dir]['so_count'] += soMap[tag] - //vlog(` ${dir} count: ${count}`) - } else { - die(1, `${tag} not found in soMap`) - } - } - } - vlog() - let curRank = 1 - let soSort = Object.values(dataByDir).sort((a,b) => b.so_count - a.so_count) - for (let data of soSort) { - data.so_rank = curRank - vlog(` ${data.dir} so_count: ${data.so_count}, rank: ${curRank}`) - curRank += 1 - } - const maxSORank = curRank - - - vlog(`Processing log file data`) - const perf_run_re = /Running:.*\.\.\/tests\/(perf[0-9])\.mal/ - const perf_num_re = /Elapsed time: ([0-9.]+) msecs|iters over 10 seconds: ([0-9]+)/ - for (let [log, file, idx] of logData) { - const dir_match = (/export IMPL=(\S+)/i).exec(log) - if (!dir_match) { die(1, `no IMPL found in ${file}`) } - const dir = dir_match[1] - const data = dataByDir[dir] -// if (data.perf1 !== null) { -// vlog(` ${dir} already has perf data, ignoring ${file}`) -// continue -// } - const perfs = {} - const logLines = log.split(/\n/) - for (let i = 0; i < logLines.length; i++) { - const match_run = perf_run_re.exec(logLines[i]) - if (match_run) { - // Find the result line - let match_num = null - do { - i += 1 - match_num = perf_num_re.exec(logLines[i]) - if (match_num) { - num = parseFloat(match_num[1] || match_num[2], 10) - perfs[match_run[1]] = num - } - } while ((!match_num) && i < logLines.length) - } - } - if ((perfs.perf3 > data.perf3) || !data.perf3) { - data.perf1 = perfs.perf1 - data.perf2 = perfs.perf2 - data.perf3 = perfs.perf3 - vlog(` ${dir}: ${perfs.perf1}, ${perfs.perf2}, ${perfs.perf3}`) - } else { - vlog(` ${dir}: ${perfs.perf1}, ${perfs.perf2}, ${perfs.perf3} (perf3 is worse, ignoring log ${idx})`) - } - } - - - vlog(`Gathering LOC stats`) - const stat_re = /SLOC=([0-9]+).*LLOC=([0-9]+).*in ([0-9]+) files/ - process.chdir(MAL_PATH) - for (let data of dataList) { - const { stdout, stderr } = await exec(`make "stats^${data.dir}"`) - const match = stat_re.exec(stdout.split(/\n/)[1]) - data.sloc = parseInt(match[1], 10) - data.lloc = parseInt(match[2], 10) - data.files = parseInt(match[3], 10) - vlog(` ${data.dir}: sloc: ${data.sloc}, lloc: ${data.lloc}, files: ${data.files}`) - } - - - vlog(`Writing full lanaguage data to ${outPath}`) - await writeFile(outPath, JSON.stringify(dataByDir, null, 2)) - - process.exit(0) -} - -main() +#!/usr/bin/env python + +const { promisify } = require('util') +const readFile = promisify(require('fs').readFile) +const writeFile = promisify(require('fs').writeFile) +const readdir = promisify(require('fs').readdir) +const path = require('path') +const yaml = require('js-yaml') +const csv = require('csvtojson') +const request = require('request-promise-native') +const exec = promisify(require('child_process').exec) + +const VERBOSE = process.env['VERBOSE'] || false +const BASE_PATH = process.env['BASE_PATH'] || 'base_data.yaml' +const README_PATH = process.env['README_PATH'] || '../../README.md' +const MAL_PATH = process.env['MAL_PATH'] || '../../' + +// GitHut 2.0 Pull Requests +const GITHUT_PULL_URL = process.env['GITHUT_PULL_URL'] || 'https://raw.githubusercontent.com/madnight/githut/master/src/data/gh-pull-request.json' +// GitHut 2.0 Pushes +const GITHUT_PUSH_URL = process.env['GITHUT_PUSH_URL'] || 'https://raw.githubusercontent.com/madnight/githut/master/src/data/gh-push-event.json' +// GitHut 2.0 Stars +const GITHUT_STAR_URL = process.env['GITHUT_STAR_URL'] || 'https://raw.githubusercontent.com/madnight/githut/master/src/data/gh-star-event.json' + +// Refresh this link using this Query page: +// https://data.stackexchange.com/stackoverflow/query/edit/1013465 +const SO_TAG_CSV_URL = process.env['SO_TAG_CSV_URL'] || 'https://data.stackexchange.com/stackoverflow/csv/1252107' + + +const githutToNames = { + 'Awk': ['GNU Awk'], + 'Ada': ['Ada', 'Ada #2'], + 'Shell': ['Bash 4'], + 'JavaScript': ['JavaScript', 'ES6'], + 'Makefile': ['GNU Make'], + 'Matlab': ['MATLAB'], + 'Assembly': ['NASM'], + 'Pascal': ['Object Pascal'], + 'Objective-C': ['Objective C'], + 'PLpgSQL': ['PL/pgSQL'], + 'PLSQL': ['PL/SQL'], + 'Python': ['Python', 'Python #2'], + 'Scheme': ['Scheme (R7RS)'], + 'Smalltalk': ['GNU Smalltalk'], + 'Swift': ['Swift 2', 'Swift 3', 'Swift 4', 'Swift 5'], + 'Vim script': ['Vimscript'], + 'Visual Basic': ['Visual Basic.NET'], +} +const dirToSOTags = { + 'ada.2': ['ada'], + 'bbc-basic': ['bbc-micro'], + 'cpp': ['c++', 'c++98', 'c++11', 'c++14', 'c++17'], + 'coffee': ['coffeescript'], + 'crystal': ['crystal-lang'], + 'cs': ['c#', 'c#-2.0', 'c#-3.0', 'c#-4.0'], + 'es6': ['ecmascript-6', 'es6-promise', 'es6-modules', 'es6-class', 'reactjs'], + 'fsharp': ['f#', 'f#-interactive', 'f#-data', 'f#-3.0'], + 'factor': ['factor-lang'], + 'js': ['javascript', 'node.js', 'jquery', 'angular'], + 'logo': ['logo-lang'], + 'make': ['makefile'], + 'objpascal': ['delphi', 'freepascal', 'delphi-7', 'delphi-2007', 'delphi-2009', 'delphi-2010', 'delphi-xe', 'delphi-xe2', 'delphi-xe3', 'delphi-xe4', 'delphi-xe5', 'delphi-xe7'], + 'objc': ['objective-c'], + 'python': ['python', 'python-3.x', 'python-2.7'], + 'python.2': ['python', 'python-3.x', 'python-2.7'], + 'swift': ['swift2'], + 'swift3': ['swift3'], + 'swift4': ['swift4'], + 'swift5': ['swift', 'swift4', 'swift5'], + 'ts': ['typescript', 'typescript-generics', 'typescript2.0'], + 'vimscript': ['viml'], + 'vb': ['vb.net'], + 'wasm': ['webassembly'], +} + +function vlog(...args) { + if (VERBOSE) { + console.log(...args) + } +} + +function die(code, ...args) { + console.error(...args) + process.exit(code) +} + +async function main() { + const logsPath = path.resolve(process.argv[2]) + const outPath = path.resolve(process.argv[3]) + + vlog(`Loading base data yaml from '${BASE_PATH}`) + const baseYaml = yaml.safeLoad(await readFile(BASE_PATH, 'utf8')) + vlog(`Loading README text from '${README_PATH}`) + const readmeLines = (await readFile(README_PATH, 'utf8')).split(/\n/) + vlog(`Downloading GitHut Pulls HTML from '${GITHUT_PULL_URL}`) + const githutPullText = (await request(GITHUT_PULL_URL)) + vlog(`Downloading GitHut Pushes HTML from '${GITHUT_PUSH_URL}`) + const githutPushText = (await request(GITHUT_PUSH_URL)) + vlog(`Downloading GitHut Stars HTML from '${GITHUT_STAR_URL}`) + const githutStarText = (await request(GITHUT_STAR_URL)) + vlog(`Downloading StackOverflow Tag CSV from '${SO_TAG_CSV_URL}`) + const soTagList = await csv().fromStream(request.get(SO_TAG_CSV_URL)) + vlog(`Loading log data from '${logsPath}'`) + const logFiles = (await readdir(logsPath)) + .map(x => parseInt(x)) + .sort((a, b) => a - b) + let logData = [] + for (const f of logFiles) { + if (!(/^[0-9]+$/.exec(f))) { continue } + const path = logsPath + "/" + f + logData.push([await readFile(path, 'utf8'), path, f]) + } + + let dirs = [] + let names = [] + let dataList = [] + let dataByDir = {} + let dataByName = {} + + vlog(`Processing base data`) + for (let d of baseYaml['languages']) { + let data = {'dir': d[0], + 'name': d[1], + 'syntax': d[2], + 'type_check': d[3], + 'modes': d[4], + 'perf1': null, + 'perf2': null, + 'perf3': 0, + 'pull_count': null, + 'pull_rank': null, + 'push_count': null, + 'push_rank': null, + 'star_count': null, + 'star_rank': null, + 'sloc': 0, + 'files': 0} + dirs.push(d[0]) + names.push(d[1]) + dataList.push(data) + dataByDir[d[0]] = data + dataByName[d[1]] = data + } + + + vlog(`Processing README implementations table`) + const readme_re = /^\| \[([^\[]*)\].* \| \[([^|]*)\]\(([^|]*)\) *\| *$/ + for (let row of readmeLines.filter(l => /^\| [\[]/.exec(l))) { + t = readme_re.exec(row) + if (t) { + if (t[1] in dataByName) { + let data = dataByName[t[1]] + data.author_name = t[2] + data.author_url = t[3] + } else { + die(1, `README language '${t[1]}' not found in base data`) + } + } else { + die(1, `No match for README table row: ${row}`) + } + } + + + function githutProcess(textData, kind) { + const gMap = JSON.parse(textData) + .reduce((m, d) => (m[d.name] = parseInt(d.count) + (m[d.name] || 0), m), {}) + const gdata = Object.entries(gMap) + .sort(([k1,v1],[k2,v2]) => v2 - v1) + let curRank = 1 + for (let [gname, gcount] of gdata) { + const names = githutToNames[gname] || [gname] + for (let name of names) { + if (name in dataByName) { + dataByName[name][kind + '_count'] = gcount + dataByName[name][kind + '_rank'] = curRank + vlog(` ${dataByName[name].dir} count: ${gcount}, rank: ${curRank}`) + curRank += 1 + } else { + vlog(` ignoring GitHut language ${name}`) + } + } + } + return curRank; + } + vlog(`Processing GitHut Pull Request data`) + githutProcess(githutPullText, 'pull') + vlog(`Processing GitHut Push data`) + githutProcess(githutPushText, 'push') + vlog(`Processing GitHut Stars data`) + githutProcess(githutStarText, 'star') + + + vlog(`Processing StackOverflow tag data`) + const soMap = soTagList + //.map(d => ({tag: d.TagName, count: parseInt(d.Rate)})) + //.sort((a,b) => b.count - a.count) + .reduce((m,d) => (m[d.TagName] = parseInt(d.Rate), m), {}) + soMap['mal'] = 0 // NOTE/TODO: StackOverflow mal is something else + for (let dir of dirs) { + if (!('so_count' in dataByDir[dir])) { + dataByDir[dir]['so_count'] = 0 + } + let tags = dirToSOTags[dir] + if (!tags) { + if (dir in soMap) { + tags = [dir] + } else { + vlog(` ${dir} not found as StackOverflow tag`) + tags = [] + } + } + for (let tag of tags) { + if (tag in soMap) { + dataByDir[dir]['so_count'] += soMap[tag] + //vlog(` ${dir} count: ${count}`) + } else { + die(1, `${tag} not found in soMap`) + } + } + } + vlog() + let curRank = 1 + let soSort = Object.values(dataByDir).sort((a,b) => b.so_count - a.so_count) + for (let data of soSort) { + data.so_rank = curRank + vlog(` ${data.dir} so_count: ${data.so_count}, rank: ${curRank}`) + curRank += 1 + } + const maxSORank = curRank + + + vlog(`Processing log file data`) + const perf_run_re = /Running:.*\.\.\/tests\/(perf[0-9])\.mal/ + const perf_num_re = /Elapsed time: ([0-9.]+) msecs|iters over 10 seconds: ([0-9]+)/ + for (let [log, file, idx] of logData) { + const dir_match = (/export IMPL=(\S+)/i).exec(log) + if (!dir_match) { die(1, `no IMPL found in ${file}`) } + const dir = dir_match[1] + const data = dataByDir[dir] +// if (data.perf1 !== null) { +// vlog(` ${dir} already has perf data, ignoring ${file}`) +// continue +// } + const perfs = {} + const logLines = log.split(/\n/) + for (let i = 0; i < logLines.length; i++) { + const match_run = perf_run_re.exec(logLines[i]) + if (match_run) { + // Find the result line + let match_num = null + do { + i += 1 + match_num = perf_num_re.exec(logLines[i]) + if (match_num) { + num = parseFloat(match_num[1] || match_num[2], 10) + perfs[match_run[1]] = num + } + } while ((!match_num) && i < logLines.length) + } + } + if ((perfs.perf3 > data.perf3) || !data.perf3) { + data.perf1 = perfs.perf1 + data.perf2 = perfs.perf2 + data.perf3 = perfs.perf3 + vlog(` ${dir}: ${perfs.perf1}, ${perfs.perf2}, ${perfs.perf3}`) + } else { + vlog(` ${dir}: ${perfs.perf1}, ${perfs.perf2}, ${perfs.perf3} (perf3 is worse, ignoring log ${idx})`) + } + } + + + vlog(`Gathering LOC stats`) + const stat_re = /SLOC=([0-9]+).*LLOC=([0-9]+).*in ([0-9]+) files/ + process.chdir(MAL_PATH) + for (let data of dataList) { + const { stdout, stderr } = await exec(`make "stats^${data.dir}"`) + const match = stat_re.exec(stdout.split(/\n/)[1]) + data.sloc = parseInt(match[1], 10) + data.lloc = parseInt(match[2], 10) + data.files = parseInt(match[3], 10) + vlog(` ${data.dir}: sloc: ${data.sloc}, lloc: ${data.lloc}, files: ${data.files}`) + } + + + vlog(`Writing full lanaguage data to ${outPath}`) + await writeFile(outPath, JSON.stringify(dataByDir, null, 2)) + + process.exit(0) +} + +main() diff --git a/docs/graph/graph_languages.js b/docs/graph/graph_languages.js index e42d9051e4..ee2c9a8790 100644 --- a/docs/graph/graph_languages.js +++ b/docs/graph/graph_languages.js @@ -1,304 +1,304 @@ -const malColors = [ - "#1f77b4","#bf7f0e","#4cb00c","#b62728","#9467bd","#bc664b","#b377c2","#0fbf6f","#bcbd22","#17beef", - "#1f6784","#8f7f0e","#4c800c","#862728","#54678d","#8c564b","#8377c2","#0f8f6f","#8c8d22","#178eef", - "#1f97d4","#ff7f0e","#4cf00c","#f62728","#c467fd","#fc764b","#f377c2","#0fff6f","#fcfd22","#17feef", -] - -const axisMap = { - 'pull_rank': 'GH PRs', - 'push_rank': 'GH Pushes', - 'star_rank': 'GH Stars', - 'so_rank': 'SO Tags', - 'perf1': 'Perf 1', - 'perf2': 'Perf 2', - 'perf3': 'Perf 3', - 'sloc': 'SLOC size', - 'files': 'File count', -} -const colorMap = { - 'syntax': 'Syntax Style', - 'type_check': 'Type Discipline', - 'author_name': 'Author', -} -const axisKeySet = new Set(Object.keys(axisMap)) -const colorKeySet = new Set(['type_check', 'syntax', 'author_name']) - -const perfSet = new Set(['perf1', 'perf2', 'perf3']) -const invertSet = new Set(['pull_rank', 'push_rank', 'star_rank', 'so_rank', 'perf1', 'perf2']) -const perfLogSet = new Set(['perf1', 'perf2', 'sloc', 'files']) - -let cfg = { - ckey: 'syntax', - xkey: 'push_rank', - ykey: 'perf3', - skey: 'sloc', - - xlog: false, - ylog: true, -} - -let allData -let graphData = [] -let chart - -// -// Util functions -// - -function malExtent(data, key) { - let extent = d3.extent(Object.values(data), d => d[key]) - // pad the bottom rank so it's not on the opposite axis line - if (key.endsWith('_rank')) { - extent[0] = 0.99 // Setting this to 1 breaks log scale render - extent[extent.length-1] += 1 - } - // Replace 0's with 0.01 to prevent divide by zero errors - if (extent[0] === 0) { extent[0] = 0.0001 } - if (extent[extent.length-1] === 0) { extent[extent.length-1] = 0.0001 } - // For rankings, perf1, and perf2 reverse the Axis range - if (invertSet.has(key)) { - extent.reverse() - } - return extent -} - -function malScale(log) { - return log ? d3.scale.log() : d3.scale.linear() -} - -function malTickValues(key, log) { - if (log && perfSet.has(key)) { - return [1, 10, 100, 1000, 10000, 100000] - } else { - return null - } -} - -function malCircleSize(key, min, max, val) { - let size = (val || 0.01) - (min - 0.01) - if (invertSet.has(key)) { - size = (max + 0.01) - size - } -// if (perfLogSet.has(key)) { -// size = Math.log(size) -// } -// console.log(key, max, val, size) - return size -} - - -// -// UI / Axis Data / query parameters -// - -// Parser query string and update cfg map with valid config options -(function parseQuery(q) { - const pairs = (q[0] === '?' ? q.substr(1) : q).split('&') - for (const [p1, p2] of pairs.map(p => p.split('='))) { - let k = decodeURIComponent(p1).toLowerCase() - let v = p2 ? decodeURIComponent(p2) : true - if (v in {"true":1,"1":1,"yes":1}) { v = true } - if (v in {"false":1,"0":1,"no":1}) { v = false } - if (k in cfg && (axisKeySet.has(v) || colorKeySet.has(v))) { - cfg[k] = v - } - if ((new Set(['xlog', 'ylog'])).has(k) && typeof v === 'boolean') { - cfg[k] = v - } - } -})(location.search) - -// Generate the control buttons and set the checked elements based on -// the cfg -function ctlChange(evt) { - if (new Set(['xlog', 'ylog']).has(evt.target.name)) { - cfg[evt.target.name] = evt.target.checked - } else { - cfg[evt.target.name] = evt.target.value - } - const query = Object.entries(cfg).map(([k,v]) => k + "=" + v).join('&') - history.pushState(null, '', '?' + query) - updateGraphData() -} -for (let key of ['ckey', 'xkey', 'ykey', 'skey']) { - const parent = document.getElementById(key + '-controls') - const ctlMap = ({ - 'ckey': colorMap, - 'xkey': Object.assign({}, axisMap, {'xlog': 'Log Scale'}), - 'ykey': Object.assign({}, axisMap, {'ylog': 'Log Scale'}), - 'skey': axisMap, - })[key] - for (let [val, name] of Object.entries(ctlMap)) { - const log = (new Set(['xlog', 'ylog']).has(val)) ? val : false - const ctl = document.createElement('input') - ctl.class = 'selects' - ctl.type = log ? 'checkbox' : 'radio' - ctl.name = log ? log : key - ctl.value = log ? true : val - if ((log && cfg[val] === true) || cfg[key] === val) { - ctl.checked = true - } - ctl.addEventListener('change', ctlChange) - parent.appendChild(ctl) - parent.appendChild(document.createTextNode(name)) - } -} - -// -// Graph rendering / updating -// - -function updateGraphData() { - let xMax = 0 - let yMax = 0 - let sMin = null - let sMax = null - const colorSet = new Set(Object.values(allData).map(d => d[cfg.ckey])) - const colorList = Array.from(colorSet.values()) - // empty the graphData without recreating it - while (graphData.length > 0) { graphData.pop() } - graphData.push(...colorList.map(t => ({key: t, values: []}))) - for (let dir of Object.keys(allData)) { - const impl = allData[dir] - if (impl[cfg.xkey] > xMax) { xMax = impl[cfg.xkey] } - if (impl[cfg.ykey] > yMax) { yMax = impl[cfg.ykey] } - if (sMin === null) { sMin = impl[cfg.skey] } - if (impl[cfg.skey] < sMin) { sMin = impl[cfg.skey] } - if (impl[cfg.skey] > sMax) { sMax = impl[cfg.skey] } - } - for (let dir of Object.keys(allData)) { - const impl = allData[dir] - // Invert size for inverted data - graphData[colorList.indexOf(impl[cfg.ckey])].values.push({ - x: impl[cfg.xkey] || 0, - y: impl[cfg.ykey] || 0, - size: malCircleSize(cfg.skey, sMin, sMax, impl[cfg.skey]), - shape: 'circle', - label: impl.name, - impl: impl, - }) - } - - // Update the axes domain, scale and tick values - chart.xDomain(malExtent(allData, cfg.xkey)) - chart.yDomain(malExtent(allData, cfg.ykey)) - chart.xScale(malScale(cfg.xlog)) - chart.yScale(malScale(cfg.ylog)) - chart.xAxis.tickValues(malTickValues(cfg.xkey, cfg.xlog)) - chart.yAxis.tickValues(malTickValues(cfg.ykey, cfg.ylog)) - chart.xAxis.axisLabel(axisMap[cfg.xkey]) - chart.yAxis.axisLabel(axisMap[cfg.ykey]) - - // Update the graph - d3.select('#mal svg') - .data([graphData]) - .transition().duration(350).ease('linear') - .call(chart) - - chart.update() - - nv.utils.windowResize(chart.update) -} - -nv.addGraph(function() { - chart = nv.models.scatterChart() - .showDistX(true) - .showDistY(true) - .showLabels(true) - .duration(300) - .color(malColors) - chart.dispatch.on('renderEnd', function() { - //console.log('render complete') - }) - chart.dispatch.on('stateChange', function(e) { - nv.log('New State:', JSON.stringify(e)) - }) - chart.tooltip.contentGenerator(function(obj) { - const i = obj.point.impl - return '

' + i.name + '

' + - '
    ' + - '
  • Syntax Style: ' + i.syntax + - '
  • Type Discipline: ' + i.type_check + - '
  • GitHub:' + - '
      ' + - '
    • PR Count: ' + (i.pull_count || 'unknown') + - '
    • PR Rank: ' + i.pull_rank + - '
    • Push Count: ' + (i.push_count || 'unknown') + - '
    • Push Rank: ' + i.push_rank + - '
    • Star Count: ' + (i.star_count || 'unknown') + - '
    • Star Rank: ' + i.star_rank + - '
    ' + - '
  • StackOverflow:' + - '
      ' + - '
    • Tag Count: ' + (i.so_count || 'unknown') + - '
    • Tag Rank: ' + i.so_rank + - '
    ' + - '

  • ' + - '
  • Perf 1: ' + i.perf1 + ' ms
    ' + - '
  • Perf 2: ' + i.perf2 + ' ms
    ' + - '
  • Perf 3: ' + i.perf3 + ' iters / 10 sec
    ' + - '
  • SLOC: ' + i.sloc + ' lines
    ' + - '
  • Author: ' + i.author_name + '
    ' + - '    ' + i.author_url.replace(/https?:\/\//, '') + - '
' - }) - - // Load and mangle the data - d3.json("all_data.json", function (error, data) { - allData = data - - console.log(`Filling in missing data attributes`) - const dataList = Object.values(allData) - // leave a gap between ranked impls and those with no rank - const rankGap = 10 - const maxPullRank = Math.max(...dataList.map(d => d.pull_rank)) - const maxPushRank = Math.max(...dataList.map(d => d.push_rank)) - const maxStarRank = Math.max(...dataList.map(d => d.star_rank)) - const maxSORank = Math.max(...dataList.map(d => d.so_rank)) - const maxPerf1 = dataList.reduce((a, d) => d.perf1 > a ? d.perf1 : a, 0) - const maxPerf2 = dataList.reduce((a, d) => d.perf2 > a ? d.perf1 : a, 0) - for (let d of dataList) { - if (d.pull_rank === null) { - d.pull_rank = maxPullRank + rankGap - console.log(` set pull_rank to ${d.pull_rank} for ${d.dir}`) - } - if (d.push_rank === null) { - d.push_rank = maxPushRank + rankGap - console.log(` set push_rank to ${d.push_rank} for ${d.dir}`) - } - if (d.star_rank === null) { - d.star_rank = maxStarRank + rankGap - console.log(` set star_rank to ${d.star_rank} for ${d.dir}`) - } - if (d.so_count === 0) { - d.so_rank = maxSORank + rankGap - console.log(` set so_rank to ${d.so_rank} for ${d.dir}`) - } - if (d.perf1 === null) { - d.perf1 = maxPerf1 - console.log(` set perf1 to ${maxPerf1} for ${d.dir}`) - } - if (d.perf2 === null) { - d.perf2 = maxPerf2 - console.log(` set perf2 to ${maxPerf2} for ${d.dir}`) - } - } - - console.log(`Adjusting perf numbers to avoid 0`) - for (let d of dataList) { - if (d.perf1 === 0) { d.perf1 = 0.9 } - if (d.perf2 === 0) { d.perf2 = 0.9 } - if (d.perf3 === 0) { d.perf3 = 0.01 } - } - - // NOTE: TODO: major hack to workaround bug with switching - // to/from logarithmic mode. Seems to require at least one - // value to be less than 1 for it to work - allData.rpython.perf2 = 0.9 - - updateGraphData() - }) - - return chart -}) - +const malColors = [ + "#1f77b4","#bf7f0e","#4cb00c","#b62728","#9467bd","#bc664b","#b377c2","#0fbf6f","#bcbd22","#17beef", + "#1f6784","#8f7f0e","#4c800c","#862728","#54678d","#8c564b","#8377c2","#0f8f6f","#8c8d22","#178eef", + "#1f97d4","#ff7f0e","#4cf00c","#f62728","#c467fd","#fc764b","#f377c2","#0fff6f","#fcfd22","#17feef", +] + +const axisMap = { + 'pull_rank': 'GH PRs', + 'push_rank': 'GH Pushes', + 'star_rank': 'GH Stars', + 'so_rank': 'SO Tags', + 'perf1': 'Perf 1', + 'perf2': 'Perf 2', + 'perf3': 'Perf 3', + 'sloc': 'SLOC size', + 'files': 'File count', +} +const colorMap = { + 'syntax': 'Syntax Style', + 'type_check': 'Type Discipline', + 'author_name': 'Author', +} +const axisKeySet = new Set(Object.keys(axisMap)) +const colorKeySet = new Set(['type_check', 'syntax', 'author_name']) + +const perfSet = new Set(['perf1', 'perf2', 'perf3']) +const invertSet = new Set(['pull_rank', 'push_rank', 'star_rank', 'so_rank', 'perf1', 'perf2']) +const perfLogSet = new Set(['perf1', 'perf2', 'sloc', 'files']) + +let cfg = { + ckey: 'syntax', + xkey: 'push_rank', + ykey: 'perf3', + skey: 'sloc', + + xlog: false, + ylog: true, +} + +let allData +let graphData = [] +let chart + +// +// Util functions +// + +function malExtent(data, key) { + let extent = d3.extent(Object.values(data), d => d[key]) + // pad the bottom rank so it's not on the opposite axis line + if (key.endsWith('_rank')) { + extent[0] = 0.99 // Setting this to 1 breaks log scale render + extent[extent.length-1] += 1 + } + // Replace 0's with 0.01 to prevent divide by zero errors + if (extent[0] === 0) { extent[0] = 0.0001 } + if (extent[extent.length-1] === 0) { extent[extent.length-1] = 0.0001 } + // For rankings, perf1, and perf2 reverse the Axis range + if (invertSet.has(key)) { + extent.reverse() + } + return extent +} + +function malScale(log) { + return log ? d3.scale.log() : d3.scale.linear() +} + +function malTickValues(key, log) { + if (log && perfSet.has(key)) { + return [1, 10, 100, 1000, 10000, 100000] + } else { + return null + } +} + +function malCircleSize(key, min, max, val) { + let size = (val || 0.01) - (min - 0.01) + if (invertSet.has(key)) { + size = (max + 0.01) - size + } +// if (perfLogSet.has(key)) { +// size = Math.log(size) +// } +// console.log(key, max, val, size) + return size +} + + +// +// UI / Axis Data / query parameters +// + +// Parser query string and update cfg map with valid config options +(function parseQuery(q) { + const pairs = (q[0] === '?' ? q.substr(1) : q).split('&') + for (const [p1, p2] of pairs.map(p => p.split('='))) { + let k = decodeURIComponent(p1).toLowerCase() + let v = p2 ? decodeURIComponent(p2) : true + if (v in {"true":1,"1":1,"yes":1}) { v = true } + if (v in {"false":1,"0":1,"no":1}) { v = false } + if (k in cfg && (axisKeySet.has(v) || colorKeySet.has(v))) { + cfg[k] = v + } + if ((new Set(['xlog', 'ylog'])).has(k) && typeof v === 'boolean') { + cfg[k] = v + } + } +})(location.search) + +// Generate the control buttons and set the checked elements based on +// the cfg +function ctlChange(evt) { + if (new Set(['xlog', 'ylog']).has(evt.target.name)) { + cfg[evt.target.name] = evt.target.checked + } else { + cfg[evt.target.name] = evt.target.value + } + const query = Object.entries(cfg).map(([k,v]) => k + "=" + v).join('&') + history.pushState(null, '', '?' + query) + updateGraphData() +} +for (let key of ['ckey', 'xkey', 'ykey', 'skey']) { + const parent = document.getElementById(key + '-controls') + const ctlMap = ({ + 'ckey': colorMap, + 'xkey': Object.assign({}, axisMap, {'xlog': 'Log Scale'}), + 'ykey': Object.assign({}, axisMap, {'ylog': 'Log Scale'}), + 'skey': axisMap, + })[key] + for (let [val, name] of Object.entries(ctlMap)) { + const log = (new Set(['xlog', 'ylog']).has(val)) ? val : false + const ctl = document.createElement('input') + ctl.class = 'selects' + ctl.type = log ? 'checkbox' : 'radio' + ctl.name = log ? log : key + ctl.value = log ? true : val + if ((log && cfg[val] === true) || cfg[key] === val) { + ctl.checked = true + } + ctl.addEventListener('change', ctlChange) + parent.appendChild(ctl) + parent.appendChild(document.createTextNode(name)) + } +} + +// +// Graph rendering / updating +// + +function updateGraphData() { + let xMax = 0 + let yMax = 0 + let sMin = null + let sMax = null + const colorSet = new Set(Object.values(allData).map(d => d[cfg.ckey])) + const colorList = Array.from(colorSet.values()) + // empty the graphData without recreating it + while (graphData.length > 0) { graphData.pop() } + graphData.push(...colorList.map(t => ({key: t, values: []}))) + for (let dir of Object.keys(allData)) { + const impl = allData[dir] + if (impl[cfg.xkey] > xMax) { xMax = impl[cfg.xkey] } + if (impl[cfg.ykey] > yMax) { yMax = impl[cfg.ykey] } + if (sMin === null) { sMin = impl[cfg.skey] } + if (impl[cfg.skey] < sMin) { sMin = impl[cfg.skey] } + if (impl[cfg.skey] > sMax) { sMax = impl[cfg.skey] } + } + for (let dir of Object.keys(allData)) { + const impl = allData[dir] + // Invert size for inverted data + graphData[colorList.indexOf(impl[cfg.ckey])].values.push({ + x: impl[cfg.xkey] || 0, + y: impl[cfg.ykey] || 0, + size: malCircleSize(cfg.skey, sMin, sMax, impl[cfg.skey]), + shape: 'circle', + label: impl.name, + impl: impl, + }) + } + + // Update the axes domain, scale and tick values + chart.xDomain(malExtent(allData, cfg.xkey)) + chart.yDomain(malExtent(allData, cfg.ykey)) + chart.xScale(malScale(cfg.xlog)) + chart.yScale(malScale(cfg.ylog)) + chart.xAxis.tickValues(malTickValues(cfg.xkey, cfg.xlog)) + chart.yAxis.tickValues(malTickValues(cfg.ykey, cfg.ylog)) + chart.xAxis.axisLabel(axisMap[cfg.xkey]) + chart.yAxis.axisLabel(axisMap[cfg.ykey]) + + // Update the graph + d3.select('#mal svg') + .data([graphData]) + .transition().duration(350).ease('linear') + .call(chart) + + chart.update() + + nv.utils.windowResize(chart.update) +} + +nv.addGraph(function() { + chart = nv.models.scatterChart() + .showDistX(true) + .showDistY(true) + .showLabels(true) + .duration(300) + .color(malColors) + chart.dispatch.on('renderEnd', function() { + //console.log('render complete') + }) + chart.dispatch.on('stateChange', function(e) { + nv.log('New State:', JSON.stringify(e)) + }) + chart.tooltip.contentGenerator(function(obj) { + const i = obj.point.impl + return '

' + i.name + '

' + + '
    ' + + '
  • Syntax Style: ' + i.syntax + + '
  • Type Discipline: ' + i.type_check + + '
  • GitHub:' + + '
      ' + + '
    • PR Count: ' + (i.pull_count || 'unknown') + + '
    • PR Rank: ' + i.pull_rank + + '
    • Push Count: ' + (i.push_count || 'unknown') + + '
    • Push Rank: ' + i.push_rank + + '
    • Star Count: ' + (i.star_count || 'unknown') + + '
    • Star Rank: ' + i.star_rank + + '
    ' + + '
  • StackOverflow:' + + '
      ' + + '
    • Tag Count: ' + (i.so_count || 'unknown') + + '
    • Tag Rank: ' + i.so_rank + + '
    ' + + '

  • ' + + '
  • Perf 1: ' + i.perf1 + ' ms
    ' + + '
  • Perf 2: ' + i.perf2 + ' ms
    ' + + '
  • Perf 3: ' + i.perf3 + ' iters / 10 sec
    ' + + '
  • SLOC: ' + i.sloc + ' lines
    ' + + '
  • Author: ' + i.author_name + '
    ' + + '    ' + i.author_url.replace(/https?:\/\//, '') + + '
' + }) + + // Load and mangle the data + d3.json("all_data.json", function (error, data) { + allData = data + + console.log(`Filling in missing data attributes`) + const dataList = Object.values(allData) + // leave a gap between ranked impls and those with no rank + const rankGap = 10 + const maxPullRank = Math.max(...dataList.map(d => d.pull_rank)) + const maxPushRank = Math.max(...dataList.map(d => d.push_rank)) + const maxStarRank = Math.max(...dataList.map(d => d.star_rank)) + const maxSORank = Math.max(...dataList.map(d => d.so_rank)) + const maxPerf1 = dataList.reduce((a, d) => d.perf1 > a ? d.perf1 : a, 0) + const maxPerf2 = dataList.reduce((a, d) => d.perf2 > a ? d.perf1 : a, 0) + for (let d of dataList) { + if (d.pull_rank === null) { + d.pull_rank = maxPullRank + rankGap + console.log(` set pull_rank to ${d.pull_rank} for ${d.dir}`) + } + if (d.push_rank === null) { + d.push_rank = maxPushRank + rankGap + console.log(` set push_rank to ${d.push_rank} for ${d.dir}`) + } + if (d.star_rank === null) { + d.star_rank = maxStarRank + rankGap + console.log(` set star_rank to ${d.star_rank} for ${d.dir}`) + } + if (d.so_count === 0) { + d.so_rank = maxSORank + rankGap + console.log(` set so_rank to ${d.so_rank} for ${d.dir}`) + } + if (d.perf1 === null) { + d.perf1 = maxPerf1 + console.log(` set perf1 to ${maxPerf1} for ${d.dir}`) + } + if (d.perf2 === null) { + d.perf2 = maxPerf2 + console.log(` set perf2 to ${maxPerf2} for ${d.dir}`) + } + } + + console.log(`Adjusting perf numbers to avoid 0`) + for (let d of dataList) { + if (d.perf1 === 0) { d.perf1 = 0.9 } + if (d.perf2 === 0) { d.perf2 = 0.9 } + if (d.perf3 === 0) { d.perf3 = 0.01 } + } + + // NOTE: TODO: major hack to workaround bug with switching + // to/from logarithmic mode. Seems to require at least one + // value to be less than 1 for it to work + allData.rpython.perf2 = 0.9 + + updateGraphData() + }) + + return chart +}) + diff --git a/docs/graph/index.html b/docs/graph/index.html index 668dab3cfe..4988421b5f 100644 --- a/docs/graph/index.html +++ b/docs/graph/index.html @@ -1,181 +1,181 @@ - - - - - - - - - - - -
-

Mal Implementation Stats

-
- -
- - - - - - - - - - - - - - - - - - -
-
- - -
-

Important Caveats:

-

The data on this graph is very specific to Mal. - Do not use this data to directly compare programming - languages.

-
    -
  • Bad takeaway: "Language X is faster than - language Y"
    • -
  • Good takeway: "The mal impl in - language X is faster than the one - in language Y for the 'perf 3' microbenchmark"
    • -
-

Here are some reasons (non-exhaustive) why this data - should be taken with a grain of salt:

-
    -
  • The focus of the make-a-lisp process is on learning - (either Lisp or the target language). The resulting - implementations have a common structure that is - intended for understandability and consistency - between implementations. They are not structured or - intended to have optimal runtime performance or code - concision.
    • -
  • Mal implementations are created by different - authors and the authors have varying levels of - experience with the target language and they often - created a mal implementation with the goal of learning - the target language.
    • -
  • While the overall structure of each mal - implementation is similar, the implementation details - are up to the author.
    • -
  • There are hundreds of tests that each implementation - must pass before being accepted into the tree. - However, the mal language has no formal - specification so authors make choices - about whether and how to handle edge cases that are - not covered by the tests. For example, mal - implementations have different levels of runtime error - checking.
    • -
  • The performance benchmarks are very narrow in - focus and these numbers should not be extrapolated - casually. For example, the 'perf 3' microbenchmark - repeats a macro and data structure manipulation test - repeatedly for 10 seconds and counts the number of - iterations through the test. Languages with runtime - optimization (e.g. JIT) tend to do particularly well - at this benchmark (RPython, JVM-based, etc).
    • -
-

Other Notes:

-
    -
  • Syntax style and type discipline are best effort - and based on Wikipedia information and personal - experience. There are also other aspects to type - discipline (strong, gradual, duck, etc) that are not - currently included.
    • -
  • The GitHub information was gathered by the GitHut - 2.0 project and then translated into a ordinal - ranking of implementations relative to each other. -
  • The StackOverflow information was generated - by a tag - count query and then translated into a ordinal - ranking of implementations relative to each other. -
  • Not all languages have GitHub or StackOverflow data - so a gap of 10 ticks is introduced between the - ranked languages and the languages with no data.
    • -
-
-
- 		Color data:
X-Axis data:
Y-Axis data:
Circle size:
-
- -
- -
- - - - - - - + + + + + + + + + + + +
+

Mal Implementation Stats

+
+ +
+ + + + + + + + + + + + + + + + + + +
+
+ + +
+

Important Caveats:

+

The data on this graph is very specific to Mal. + Do not use this data to directly compare programming + languages.

+
    +
  • Bad takeaway: "Language X is faster than + language Y"
    • +
  • Good takeway: "The mal impl in + language X is faster than the one + in language Y for the 'perf 3' microbenchmark"
    • +
+

Here are some reasons (non-exhaustive) why this data + should be taken with a grain of salt:

+
    +
  • The focus of the make-a-lisp process is on learning + (either Lisp or the target language). The resulting + implementations have a common structure that is + intended for understandability and consistency + between implementations. They are not structured or + intended to have optimal runtime performance or code + concision.
    • +
  • Mal implementations are created by different + authors and the authors have varying levels of + experience with the target language and they often + created a mal implementation with the goal of learning + the target language.
    • +
  • While the overall structure of each mal + implementation is similar, the implementation details + are up to the author.
    • +
  • There are hundreds of tests that each implementation + must pass before being accepted into the tree. + However, the mal language has no formal + specification so authors make choices + about whether and how to handle edge cases that are + not covered by the tests. For example, mal + implementations have different levels of runtime error + checking.
    • +
  • The performance benchmarks are very narrow in + focus and these numbers should not be extrapolated + casually. For example, the 'perf 3' microbenchmark + repeats a macro and data structure manipulation test + repeatedly for 10 seconds and counts the number of + iterations through the test. Languages with runtime + optimization (e.g. JIT) tend to do particularly well + at this benchmark (RPython, JVM-based, etc).
    • +
+

Other Notes:

+
    +
  • Syntax style and type discipline are best effort + and based on Wikipedia information and personal + experience. There are also other aspects to type + discipline (strong, gradual, duck, etc) that are not + currently included.
    • +
  • The GitHub information was gathered by the GitHut + 2.0 project and then translated into a ordinal + ranking of implementations relative to each other. +
  • The StackOverflow information was generated + by a tag + count query and then translated into a ordinal + ranking of implementations relative to each other. +
  • Not all languages have GitHub or StackOverflow data + so a gap of 10 ticks is introduced between the + ranked languages and the languages with no data.
    • +
+
+
+ 		Color data:
X-Axis data:
Y-Axis data:
Circle size:
+
+ +
+ +
+ + + + + + + diff --git a/docs/graph/package.json b/docs/graph/package.json index ec6e07712d..ba529de9e4 100644 --- a/docs/graph/package.json +++ b/docs/graph/package.json @@ -1,11 +1,11 @@ -{ - "name": "mal_graph", - "version": "0.0.1", - "description": "Graph Mal Languages", - "dependencies": { - "js-yaml": "3.13.1", - "csvtojson": "2.0.8", - "request": "2.88.0", - "request-promise-native": "1.0.7" - } -} +{ + "name": "mal_graph", + "version": "0.0.1", + "description": "Graph Mal Languages", + "dependencies": { + "js-yaml": "3.13.1", + "csvtojson": "2.0.8", + "request": "2.88.0", + "request-promise-native": "1.0.7" + } +} diff --git a/docs/index.html b/docs/index.html index c3f9809962..9ddb94871c 100644 --- a/docs/index.html +++ b/docs/index.html @@ -1,297 +1,297 @@ - - - - - - - - - - - - - - Mal Web REPL - - -
-

Mal

- -

Mal Web REPL

- - - -
-
-
-
- -

 

-
-
-
- View source on Github

-
-
- -
- -
-

Mal at a glance

-
- -
-
-

Datatypes

- - - - - - - - - - - - - - - - - -
Maps{"key1" "val1", "key2" 123}
Lists(1 2 3 "four")
Vectors[1 2 3 4 "a" "b" "c" 1 2]
Scalarsa-symbol, "a string", :a_keyword, 123, nil, true, false
-
-
-

Functions

- - - - - - - - - - - - - -
Calling(<function> - <args*>)
Defining named functions(def! <name> - (fn* - [<args*>] - <action>))
Anonymous function(fn* - [<args*>] - <action>)
-
-
-

Useful Macros and Special Forms

- - - - - - - - - - - - - - - - - - - - - - -
Conditionalsif cond or
Multiple Actions (side-effects)(do - <action*>...)
Defining thingsdef! defmacro! let*
Quoting' ` ~ ~@
Examining macrosmacroexpand
-
-
- -
-
-

Useful Functions

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Math+ - * /
Comparison/Boolean= < > <= >= not
Predicatesnil? true? false? symbol? keyword? string? list? vector? map? sequential?
Data processingmap apply
Data createlist vector hash-map
Data inspectionfirst rest get keys vals count get nth contains? empty?
Data manipulationconj cons concat assoc dissoc
Lists and Vectorsfirst rest nth seq
Hash Mapsget keys vals contains?
Stringsstr pr-str seq
Atomsatom atom? deref[@] reset! swap!
Metameta with-meta[^]
Outputprintln prn
-
-
-

JavaScript Interop

- - - - - - - - - -
Evaluate JavaScript(js-eval "JS string to eval")
Method call/access(. js-fn arg...)
-
-
- -
- - - -
- - - - - - - + + + + + + + + + + + + + + Mal Web REPL + + +
+

Mal

+ +

Mal Web REPL

+ + + +
+
+
+
+ +

 

+
+
+
+ View source on Github

+
+
+ +
+ +
+

Mal at a glance

+
+ +
+
+

Datatypes

+ + + + + + + + + + + + + + + + + +
Maps{"key1" "val1", "key2" 123}
Lists(1 2 3 "four")
Vectors[1 2 3 4 "a" "b" "c" 1 2]
Scalarsa-symbol, "a string", :a_keyword, 123, nil, true, false
+
+
+

Functions

+ + + + + + + + + + + + + +
Calling(<function> + <args*>)
Defining named functions(def! <name> + (fn* + [<args*>] + <action>))
Anonymous function(fn* + [<args*>] + <action>)
+
+
+

Useful Macros and Special Forms

+ + + + + + + + + + + + + + + + + + + + + + +
Conditionalsif cond or
Multiple Actions (side-effects)(do + <action*>...)
Defining thingsdef! defmacro! let*
Quoting' ` ~ ~@
Examining macrosmacroexpand
+
+
+ +
+
+

Useful Functions

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Math+ - * /
Comparison/Boolean= < > <= >= not
Predicatesnil? true? false? symbol? keyword? string? list? vector? map? sequential?
Data processingmap apply
Data createlist vector hash-map
Data inspectionfirst rest get keys vals count get nth contains? empty?
Data manipulationconj cons concat assoc dissoc
Lists and Vectorsfirst rest nth seq
Hash Mapsget keys vals contains?
Stringsstr pr-str seq
Atomsatom atom? deref[@] reset! swap!
Metameta with-meta[^]
Outputprintln prn
+
+
+

JavaScript Interop

+ + + + + + + + + +
Evaluate JavaScript(js-eval "JS string to eval")
Method call/access(. js-fn arg...)
+
+
+ +
+ + + +
+ + + + + + + diff --git a/docs/step_notes.txt b/docs/step_notes.txt index df6a74e6ad..d8d00dd63c 100644 --- a/docs/step_notes.txt +++ b/docs/step_notes.txt @@ -1,412 +1,412 @@ -Step Notes: - -- step0_repl - - prompt, input, READ, EVAL, PRINT, output - - readline module - - display prompt, read line of input - - Details: - - get your language compiler/interpreter running - - create step0_repl.EXT - - loop that reads input, calls rep, writes output, exits - on EOF/Ctrl-D - - rep calls PRINT(EVAL(READ(str))) - - READ, EVAL, PRINT just return input parameter - - modify toplevel Makefile - - add language (directory name) to IMPLS - - add _STEP_TO_PROG entry - - add _RUNSTEP entry - - for a compiled language, add /Makefile - - targets: all, step*, stats, stats-lisp, - -- use native eval in EVAL if available - -- libedit/GNU readline: - - use existing lib, wrap shell call or implement - - load history file on first call - - add non-blank lines to history - - append to history file - -- step1_read_print - - types module: - - add boxed types if no language equivalent: - - nil, true, false, symbol, integer, string, list - - error types if necessary - - reader module: - - stateful reader object - - alternative: mutate token list - - tokenize (if regex available) - - standard regex pattern: "/[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:\\.|[^\\\"])*\"|;.*|[^\s\[\]{}('\"`,;)]*)/" - - read_str - - read_form(new Reader(tokenize(str))) - - read_form - - detect errors - - call read_list or read_atom - - read_list - - read_form until ')' - - return array (boxed) - - read_atom (not atom type) - - return scalar boxed type: - - nil, true, false, symbol, integer, string - - skip unquoting - - printer module: - - _pr_str: - - stringify boxed types to their Mal representations - - list/array is recursive - - skip quoting - - repl loop - - catch errors, print them and continue - - impls without exception handling will need to have a global - variable with checks for it at the beginning of critical - code sections - - Details: - - copy step0_repl.EXT to step1_read_print.EXT - - modify Makefile if compiled - - call reader.read_str from READ - - pass through type returned from read_str through - READ/EVAL/PRINT - - create reader.EXT - - if regex support (much easier) then tokenize with this: - /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g - - add read_str: - - call tokenize - - handle blank line (exceptions, return code, global - depending on lang features) - - read_str -> read_form -> {read_list, read_atom} - - mutable reader thing - - create printer.EXT - - _pr_str function which basically reverses read_str and - returns a string representation - - run `make test^EXT^step1`. Much of the basics should pass up - to vectors - - implement read_hash_map (can refactor read_list) - - import read_vector - - probably want to define types for List and Vector in - types.EXT that extend or wrap native arrays - - run `make test^EXT^step1`. All mandatory should pass - -- comments - -- vectors - - Basically: two array types that retain their boxed types, can be - challenging depending on the language (e.g. JS, PHP: no clean - way to derive new array types). - - types module: - - add vector boxed type - - derived from array if possible - - pr_str: - - vector is recursive - - sequential? - - reader module: - - read_vector: - - re-use read_list but with different constructor, delims - -- hash-maps - - reader module: - - re-use read_list function and apply that using hash-map - constructor - - types module: - - pr_str addition - - hash-map, map?, assoc, dissoc, get, contains?, keys, - vals (probably assoc! and dissoc! for internal) - - eval_map: eval the keys and values of hash_maps - - EVAL: - - if hash_map, call eval_map on it - -- step2_eval - - types module: - - symbol?, list? (if no simple idiomatic impl type check) - - first, rest, nth on list - - eval_ast: - - if symbol, return value of looking up in env - - if list, eval each item, return new list - - otherwise, just return unchanged ast - - EVAL/apply: - - if not a list, call eval_ast - - otherwise, apply first item to eval_ast of (rest ast) - - repl_env as simple one level hash map (assoc. array) - - store function as hash_map value - - Details: - - copy step1_read_print.EXT to step2_eval.EXT - - create repl_env hash_map) with +, -, *, / - - store anon func as values if possible - - types.EXT - - implement symbol? (symbol_Q) and list? (list_Q) - - add env param to EVAL and add to rep EVAL call - - EVAL - - if not list call eval_ast - - otherwise eval_ast, and call first arg with rest - - eval_ast - - if symbol?, lookup in env - - if List, EVAL each and return eval's list - - otherwise, return original - - optional: handle vector and hash-map in eval_ast - -- vectors - - eval each item, return new vector - -- hash-maps - - eval each value, return new hash_map - -- step3_env - - types module: - - may need function type if HashMap is strongly typed (e.g. Java) - - env type: - - find, set, get (no binds/exprs in constructor yet) - - EVAL/apply: - - def! - mutate current environment - - let* - create new environment with bindings - - Details: - - cp step2_eval.EXT to step3_env.EXT - - add env.EXT if lang support file dep cycles, otherwise, add - to types.EXT - - Env type - - find, get, set methods/functions - - use Env type instead of map/assoc. array - - eval_ast: use method for lookup - - EVAL: - - switch on first symbol - - def! - - set env[a1] to EVAL(a2, env) - - let* - - loop through let building up let_env - - EVAL(a2, let_env) - - move apply to default - -- step4_if_fn_do - - types module: - - function type if no closures in impl language - - _equal_Q function (recursive) - - reader module - - string unescaping - - printer module - - print_readably option for pr_str - - add function printing to pr_str - - string escaping in pr_str - - core module (export via core_ns): - - export equal_Q from types as = - - move arith operations here - - add arith comparison functions - - pr_str, str, prn, println - - list, list?, count, empty? - - env module: - - add binds/exprs handling to Env constructor with variable arity - - EVAL: - - do: - - if: - - fn*: - - simple if language supports closures - - otherwise needs a way of representing functions that can - have associated metadata - - define "not" using REP/RE - - Details: - - cp step3_env.EXT to step4_env.EXT - - modify Makefile if compiled - - env.EXT - - add binds and exprs args. Create new environments with - exprs bound to binds. If & symbol, bind rest of exprs to - next bind symbol - - EVAL: - - do: - - eval_ast [1:], then return last eval'd element - - if - - EVAL(a1) - - if true EVAL(a2) - - else EVAL(a3), unless no a3 then return nil - - fn* - - if available use function closures to return a new - native function that calls EVAL(a2, Env(env, a1, fargs)) - - otherwise, store exp, params and env in a structure - - core.EXT - - create ns object to hold core namespace - - move numeric operators here - - add comparison operators - - add list, list?, empty?, count - - run make test^EXT^step4 - - implement equal?/equal_Q in types.EXT and refer in core.ns - - implement not as rep("(def! not (fn* (a) (if a false true)))") - - run make test^EXT^step4: should pass everything except - string routines - - implement: pr-str, str, prn, println in core.EXT and - refer in core.ns - - should leverage pr-str from printer.EXT - - add reader/printer string quote/unquote - -- step5_tco - - types module: - - mal function type: - - stores: eval, exp, env, params - - eval is EVAL in native mal case (needed for map function - later), otherwise reference to platform function - - if metadata support, then store exp, env, params as - metadata - - printer - - add printing of mal function type - - EVAL: - - while loop around whole thing - - cases where we directly return result of EVAL, instead set - ast and env to what would be put in the EVAL, then loop. - - do, if, "apply" - - "apply" - - if mal function type - - set env to new Env based on properties on the function - - if native function, same as before - - Details: - - types.EXT - - create Mal function type to store eval, exp, env, params - - cp step4_if_fn_do.EXT to step5_tco.EXT - - wrap EVAL in infinite while loop - - in let*, do, and if: - - set ast and env and loop (no return) - - in fn* create Mal function type - - if compiled, update Makefile - - in apply, test if Mal function type: - - if so, generate new env from stored env, args and callee - params - - set ast to stored ast - - -- step6_file - - core module: - - read-string, slurp functions - - define eval and load-file functions - - set *ARGV* - - if files on command line, use load-file to run first argument - using rest as arguments - - Details: - - cp step5_tco.EXT to step6_file.EXT - - if compiled update Makefile - - add eval to repl_env - - if no (or limited closures) may have to add an "eval" - case to EVAL and use function which gets root of - environment to env.EXT (see rust). - - add empty *ARGV* list to repl_env - - in core.ns: - - wrap printer.read-str as read-string - - implement slurp - - implement load-file using rep - - test: - (load-file "../tests/inc.mal") - (inc3 10) - - implement command line execution - - test: - ./step6_file ../tests/incA.mal - =>9 - - implement comments in reader.EXT (ignore in tokenize) - -- step7_quote - - add is_pair and quasiquote functions - - rewrite ast using cons/concat functions - - if vectors, use sequential? instead of list? in is_pair - - EVAL: - - add 'quote', 'quasiquote' cases - - core module: - - add cons and concat functions - - reader module: - - add reader macros to read_form for quote, unquote, - splice-unquote and quasiquote - - Details: - - cp step6_file.EXT to step6_quote.EXT - - if compiled update Makefile - - implement reader macros (', `, ~, ~@) in reader - - retest make test^go^step1 - - add is_pair and quasiquote - - add quote and quasiquote cases to EVAL - - implement cons and concat in core.EXT - - retest test^go^step7 - -- step8_macros - - types - - capability to store ismacro property in function - - core module: - - add first, rest, nth functions - - add is_macro_call and macroexpand - - recursively macroexpand lists - - if applying a macro function, run it on the ast first before - continuing - - call macroexpand apply in EVAL before apply - - EVAL: - - add 'defmacro!' and 'macroexpand' - - set ismacro property on function - - Details: - - cp step7_quote.EXT to step8_macros.EXT - - if compiled update Makefile - - add isMacro property to Mal Function type - - may need to go back and adjust step5-7 - - implement is_macro_call and macroexpand - - call macroexpand on ast before apply in EVAL - - add defmacro! and macroexpand to EVAL switch - - make test^go^step8 should pass some basic macros - - add nth, first, and rest to core.ns - - make test^go^step8 should now pass - -- step9_try - - core module: - - throw function - - apply, map functions: should not directly call EVAL, which - requires the function object to be runnable - - readline - - nil?, true?, false? - - EVAL: - - try*/catch*: for normal exceptions, extracts string - otherwise extracts full value - - set and print *host-language* - - define cond and or macros using REP/RE - - Details: - - cp step8_macros.EXT to stepA_try.EXT - - if compiled update Makefile - - core.ns implement nil?, true?, false?, symbol?, sequential?, - vector, vector? - - add mal error type which wraps normal mal type - - in core.ns add throw which wraps type in mal error type - and throws/raises/sets exception - - add try*/catch* support to EVAL - - if mal error type, bind to catch* bind symbol - - otherwise, bind string of error to catch* bind symbol - - implement apply, map in core.ns - - make test^go^stepA - - implement readline.EXT - - provide option (e.g. commented out) to link with GNU - readline (GPL) or libedit (BSD) - - add hash-map functions: hash-map, map?, assoc, dissoc, get, - contains?, keys, vals - - add metadata support to List, Vector, HashMap, and Functions - - add reader macro - - may need to box HashMap and native functions - - add atom type, reader macro and functions: with_meta, meta - - get `make test^go^stepA` to fully pass - - get `./stepA_try ../mal/step1_read_print` to pass - - continue for each mal step until ../mal/stepA_try - - Now self-hosting! - - -- Extra definitions needed for self-hosting - - core module: - - symbol?, sequential? (if not already) - - vector, vector? - - -- atoms - - reader module: - - @a reader macro -> (deref a) - - core module: - - pr_str case - - atom type, atom, atom?, deref, reset!, swap! - -- metadata - - reader module: - - ^ reader macro reads ^meta obj -> (with-meta obj meta) - - types module: - - support meta property on collections: lists, vectors, - hash-maps, functions, atoms - - clone/copy of collections - - core module: - - add with-meta, meta functions - -- Other misc: - - conj function - -- stepA_mal - - convert returned data to mal data - - recursive, similar to pr_str - - Details: - +Step Notes: + +- step0_repl + - prompt, input, READ, EVAL, PRINT, output + - readline module + - display prompt, read line of input + - Details: + - get your language compiler/interpreter running + - create step0_repl.EXT + - loop that reads input, calls rep, writes output, exits + on EOF/Ctrl-D + - rep calls PRINT(EVAL(READ(str))) + - READ, EVAL, PRINT just return input parameter + - modify toplevel Makefile + - add language (directory name) to IMPLS + - add _STEP_TO_PROG entry + - add _RUNSTEP entry + - for a compiled language, add /Makefile + - targets: all, step*, stats, stats-lisp, + +- use native eval in EVAL if available + +- libedit/GNU readline: + - use existing lib, wrap shell call or implement + - load history file on first call + - add non-blank lines to history + - append to history file + +- step1_read_print + - types module: + - add boxed types if no language equivalent: + - nil, true, false, symbol, integer, string, list + - error types if necessary + - reader module: + - stateful reader object + - alternative: mutate token list + - tokenize (if regex available) + - standard regex pattern: "/[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:\\.|[^\\\"])*\"|;.*|[^\s\[\]{}('\"`,;)]*)/" + - read_str + - read_form(new Reader(tokenize(str))) + - read_form + - detect errors + - call read_list or read_atom + - read_list + - read_form until ')' + - return array (boxed) + - read_atom (not atom type) + - return scalar boxed type: + - nil, true, false, symbol, integer, string + - skip unquoting + - printer module: + - _pr_str: + - stringify boxed types to their Mal representations + - list/array is recursive + - skip quoting + - repl loop + - catch errors, print them and continue + - impls without exception handling will need to have a global + variable with checks for it at the beginning of critical + code sections + - Details: + - copy step0_repl.EXT to step1_read_print.EXT + - modify Makefile if compiled + - call reader.read_str from READ + - pass through type returned from read_str through + READ/EVAL/PRINT + - create reader.EXT + - if regex support (much easier) then tokenize with this: + /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g + - add read_str: + - call tokenize + - handle blank line (exceptions, return code, global + depending on lang features) + - read_str -> read_form -> {read_list, read_atom} + - mutable reader thing + - create printer.EXT + - _pr_str function which basically reverses read_str and + returns a string representation + - run `make test^EXT^step1`. Much of the basics should pass up + to vectors + - implement read_hash_map (can refactor read_list) + - import read_vector + - probably want to define types for List and Vector in + types.EXT that extend or wrap native arrays + - run `make test^EXT^step1`. All mandatory should pass + +- comments + +- vectors + - Basically: two array types that retain their boxed types, can be + challenging depending on the language (e.g. JS, PHP: no clean + way to derive new array types). + - types module: + - add vector boxed type + - derived from array if possible + - pr_str: + - vector is recursive + - sequential? + - reader module: + - read_vector: + - re-use read_list but with different constructor, delims + +- hash-maps + - reader module: + - re-use read_list function and apply that using hash-map + constructor + - types module: + - pr_str addition + - hash-map, map?, assoc, dissoc, get, contains?, keys, + vals (probably assoc! and dissoc! for internal) + - eval_map: eval the keys and values of hash_maps + - EVAL: + - if hash_map, call eval_map on it + +- step2_eval + - types module: + - symbol?, list? (if no simple idiomatic impl type check) + - first, rest, nth on list + - eval_ast: + - if symbol, return value of looking up in env + - if list, eval each item, return new list + - otherwise, just return unchanged ast + - EVAL/apply: + - if not a list, call eval_ast + - otherwise, apply first item to eval_ast of (rest ast) + - repl_env as simple one level hash map (assoc. array) + - store function as hash_map value + - Details: + - copy step1_read_print.EXT to step2_eval.EXT + - create repl_env hash_map) with +, -, *, / + - store anon func as values if possible + - types.EXT + - implement symbol? (symbol_Q) and list? (list_Q) + - add env param to EVAL and add to rep EVAL call + - EVAL + - if not list call eval_ast + - otherwise eval_ast, and call first arg with rest + - eval_ast + - if symbol?, lookup in env + - if List, EVAL each and return eval's list + - otherwise, return original + - optional: handle vector and hash-map in eval_ast + +- vectors + - eval each item, return new vector + +- hash-maps + - eval each value, return new hash_map + +- step3_env + - types module: + - may need function type if HashMap is strongly typed (e.g. Java) + - env type: + - find, set, get (no binds/exprs in constructor yet) + - EVAL/apply: + - def! - mutate current environment + - let* - create new environment with bindings + - Details: + - cp step2_eval.EXT to step3_env.EXT + - add env.EXT if lang support file dep cycles, otherwise, add + to types.EXT + - Env type + - find, get, set methods/functions + - use Env type instead of map/assoc. array + - eval_ast: use method for lookup + - EVAL: + - switch on first symbol + - def! + - set env[a1] to EVAL(a2, env) + - let* + - loop through let building up let_env + - EVAL(a2, let_env) + - move apply to default + +- step4_if_fn_do + - types module: + - function type if no closures in impl language + - _equal_Q function (recursive) + - reader module + - string unescaping + - printer module + - print_readably option for pr_str + - add function printing to pr_str + - string escaping in pr_str + - core module (export via core_ns): + - export equal_Q from types as = + - move arith operations here + - add arith comparison functions + - pr_str, str, prn, println + - list, list?, count, empty? + - env module: + - add binds/exprs handling to Env constructor with variable arity + - EVAL: + - do: + - if: + - fn*: + - simple if language supports closures + - otherwise needs a way of representing functions that can + have associated metadata + - define "not" using REP/RE + - Details: + - cp step3_env.EXT to step4_env.EXT + - modify Makefile if compiled + - env.EXT + - add binds and exprs args. Create new environments with + exprs bound to binds. If & symbol, bind rest of exprs to + next bind symbol + - EVAL: + - do: + - eval_ast [1:], then return last eval'd element + - if + - EVAL(a1) + - if true EVAL(a2) + - else EVAL(a3), unless no a3 then return nil + - fn* + - if available use function closures to return a new + native function that calls EVAL(a2, Env(env, a1, fargs)) + - otherwise, store exp, params and env in a structure + - core.EXT + - create ns object to hold core namespace + - move numeric operators here + - add comparison operators + - add list, list?, empty?, count + - run make test^EXT^step4 + - implement equal?/equal_Q in types.EXT and refer in core.ns + - implement not as rep("(def! not (fn* (a) (if a false true)))") + - run make test^EXT^step4: should pass everything except + string routines + - implement: pr-str, str, prn, println in core.EXT and + refer in core.ns + - should leverage pr-str from printer.EXT + - add reader/printer string quote/unquote + +- step5_tco + - types module: + - mal function type: + - stores: eval, exp, env, params + - eval is EVAL in native mal case (needed for map function + later), otherwise reference to platform function + - if metadata support, then store exp, env, params as + metadata + - printer + - add printing of mal function type + - EVAL: + - while loop around whole thing + - cases where we directly return result of EVAL, instead set + ast and env to what would be put in the EVAL, then loop. + - do, if, "apply" + - "apply" + - if mal function type + - set env to new Env based on properties on the function + - if native function, same as before + - Details: + - types.EXT + - create Mal function type to store eval, exp, env, params + - cp step4_if_fn_do.EXT to step5_tco.EXT + - wrap EVAL in infinite while loop + - in let*, do, and if: + - set ast and env and loop (no return) + - in fn* create Mal function type + - if compiled, update Makefile + - in apply, test if Mal function type: + - if so, generate new env from stored env, args and callee + params + - set ast to stored ast + + +- step6_file + - core module: + - read-string, slurp functions + - define eval and load-file functions + - set *ARGV* + - if files on command line, use load-file to run first argument + using rest as arguments + - Details: + - cp step5_tco.EXT to step6_file.EXT + - if compiled update Makefile + - add eval to repl_env + - if no (or limited closures) may have to add an "eval" + case to EVAL and use function which gets root of + environment to env.EXT (see rust). + - add empty *ARGV* list to repl_env + - in core.ns: + - wrap printer.read-str as read-string + - implement slurp + - implement load-file using rep + - test: + (load-file "../tests/inc.mal") + (inc3 10) + - implement command line execution + - test: + ./step6_file ../tests/incA.mal + =>9 + - implement comments in reader.EXT (ignore in tokenize) + +- step7_quote + - add is_pair and quasiquote functions + - rewrite ast using cons/concat functions + - if vectors, use sequential? instead of list? in is_pair + - EVAL: + - add 'quote', 'quasiquote' cases + - core module: + - add cons and concat functions + - reader module: + - add reader macros to read_form for quote, unquote, + splice-unquote and quasiquote + - Details: + - cp step6_file.EXT to step6_quote.EXT + - if compiled update Makefile + - implement reader macros (', `, ~, ~@) in reader + - retest make test^go^step1 + - add is_pair and quasiquote + - add quote and quasiquote cases to EVAL + - implement cons and concat in core.EXT + - retest test^go^step7 + +- step8_macros + - types + - capability to store ismacro property in function + - core module: + - add first, rest, nth functions + - add is_macro_call and macroexpand + - recursively macroexpand lists + - if applying a macro function, run it on the ast first before + continuing + - call macroexpand apply in EVAL before apply + - EVAL: + - add 'defmacro!' and 'macroexpand' + - set ismacro property on function + - Details: + - cp step7_quote.EXT to step8_macros.EXT + - if compiled update Makefile + - add isMacro property to Mal Function type + - may need to go back and adjust step5-7 + - implement is_macro_call and macroexpand + - call macroexpand on ast before apply in EVAL + - add defmacro! and macroexpand to EVAL switch + - make test^go^step8 should pass some basic macros + - add nth, first, and rest to core.ns + - make test^go^step8 should now pass + +- step9_try + - core module: + - throw function + - apply, map functions: should not directly call EVAL, which + requires the function object to be runnable + - readline + - nil?, true?, false? + - EVAL: + - try*/catch*: for normal exceptions, extracts string + otherwise extracts full value + - set and print *host-language* + - define cond and or macros using REP/RE + - Details: + - cp step8_macros.EXT to stepA_try.EXT + - if compiled update Makefile + - core.ns implement nil?, true?, false?, symbol?, sequential?, + vector, vector? + - add mal error type which wraps normal mal type + - in core.ns add throw which wraps type in mal error type + and throws/raises/sets exception + - add try*/catch* support to EVAL + - if mal error type, bind to catch* bind symbol + - otherwise, bind string of error to catch* bind symbol + - implement apply, map in core.ns + - make test^go^stepA + - implement readline.EXT + - provide option (e.g. commented out) to link with GNU + readline (GPL) or libedit (BSD) + - add hash-map functions: hash-map, map?, assoc, dissoc, get, + contains?, keys, vals + - add metadata support to List, Vector, HashMap, and Functions + - add reader macro + - may need to box HashMap and native functions + - add atom type, reader macro and functions: with_meta, meta + - get `make test^go^stepA` to fully pass + - get `./stepA_try ../mal/step1_read_print` to pass + - continue for each mal step until ../mal/stepA_try + - Now self-hosting! + + +- Extra definitions needed for self-hosting + - core module: + - symbol?, sequential? (if not already) + - vector, vector? + + +- atoms + - reader module: + - @a reader macro -> (deref a) + - core module: + - pr_str case + - atom type, atom, atom?, deref, reset!, swap! + +- metadata + - reader module: + - ^ reader macro reads ^meta obj -> (with-meta obj meta) + - types module: + - support meta property on collections: lists, vectors, + hash-maps, functions, atoms + - clone/copy of collections + - core module: + - add with-meta, meta functions + +- Other misc: + - conj function + +- stepA_mal + - convert returned data to mal data + - recursive, similar to pr_str + - Details: + diff --git a/docs/web/ansi.css b/docs/web/ansi.css index 296cfc6089..220cb44901 100644 --- a/docs/web/ansi.css +++ b/docs/web/ansi.css @@ -1,172 +1,172 @@ -.jqconsole-ansi-bold { - font-weight: bold!important; -} - -.jqconsole-ansi-lighter { - font-weight: lighter!important; -} - -.jqconsole-ansi-italic { - font-style: italic!important; -} - -.jqconsole-ansi-underline { - text-decoration: underline!important; -} - -@-webkit-keyframes blinker { - from { opacity: 1.0; } - to { opacity: 0.0; } -} - -@-moz-keyframes blinker { - from { opacity: 1.0; } - to { opacity: 0.0; } -} - -@-ms-keyframes blinker { - from { opacity: 1.0; } - to { opacity: 0.0; } -} - -@-o-keyframes blinker { - from { opacity: 1.0; } - to { opacity: 0.0; } -} - -.jqconsole-ansi-blink { - -webkit-animation-name: blinker; - -moz-animation-name: blinker; - -ms-animation-name: blinker; - -o-animation-name: blinker; - -webkit-animation-iteration-count: infinite; - -moz-animation-iteration-count: infinite; - -ms-animation-iteration-count: infinite; - -o-animation-iteration-count: infinite; - -webkit-animation-timing-function: cubic-bezier(1.0,0,0,1.0); - -ms-animation-timing-function: cubic-bezier(1.0,0,0,1.0); - -o-animation-timing-function: cubic-bezier(1.0,0,0,1.0); - -moz-animation-timing-function: cubic-bezier(1.0,0,0,1.0); - -webkit-animation-duration: 1s; - -moz-animation-duration: 1s; - -o-animation-duration: 1s; - -ms-animation-duration: 1s; -} - -.jqconsole-ansi-blink-rapid { - -webkit-animation-name: blinker; - -moz-animation-name: blinker; - -ms-animation-name: blinker; - -o-animation-name: blinker; - -webkit-animation-iteration-count: infinite; - -moz-animation-iteration-count: infinite; - -ms-animation-iteration-count: infinite; - -o-animation-iteration-count: infinite; - -webkit-animation-timing-function: cubic-bezier(1.0,0,0,1.0); - -ms-animation-timing-function: cubic-bezier(1.0,0,0,1.0); - -o-animation-timing-function: cubic-bezier(1.0,0,0,1.0); - -moz-animation-timing-function: cubic-bezier(1.0,0,0,1.0); - -webkit-animation-duration: 0.5s; - -moz-animation-duration: 0.5s; - -o-animation-duration: 0.5s; - -ms-animation-duration: 0.5s; -} - - -.jqconsole-ansi-hidden { - visibility:hidden!important; -} - -.jqconsole-ansi-line-through { - text-decoration: line-through; -} - -.jqconsole-ansi-fonts-1 { - -} -.jqconsole-ansi-fonts-2 { - -} -.jqconsole-ansi-fonts-3 { - -} -.jqconsole-ansi-fonts-4 { - -} -.jqconsole-ansi-fonts-5 { - -} -.jqconsole-ansi-fonts-6 { - -} -.jqconsole-ansi-fonts-7 { - -} -.jqconsole-ansi-fonts-8 { - -} -.jqconsole-ansi-fonts-9 { - -} - -.jqconsole-ansi-fraktur { - -} - -.jqconsole-ansi-color-black { - color: black!important; -} -.jqconsole-ansi-color-red { - color: red!important; -} -.jqconsole-ansi-color-green { - color: green!important; -} -.jqconsole-ansi-color-yellow { - color: yellow!important; -} -.jqconsole-ansi-color-blue { - color: blue!important; -} -.jqconsole-ansi-color-magenta { - color: magenta!important; -} -.jqconsole-ansi-color-cyan { - color: cyan!important; -} -.jqconsole-ansi-color-white { - color: white!important; -} - -.jqconsole-ansi-background-color-black { - background-color: black!important; -} -.jqconsole-ansi-background-color-red { - background-color: red!important; -} -.jqconsole-ansi-background-color-green { - background-color: green!important; -} -.jqconsole-ansi-background-color-yellow { - background-color: yellow!important; -} -.jqconsole-ansi-background-color-blue { - background-color: blue!important; -} -.jqconsole-ansi-background-color-magenta { - background-color: magenta!important; -} -.jqconsole-ansi-background-color-cyan { - background-color: cyan!important; -} -.jqconsole-ansi-background-color-white { - background-color: white!important; -} - -.jqconsole-ansi-framed { - border: 1px solid!important; -} -.jqconsole-ansi-overline { - text-decoration: overline!important; -} - +.jqconsole-ansi-bold { + font-weight: bold!important; +} + +.jqconsole-ansi-lighter { + font-weight: lighter!important; +} + +.jqconsole-ansi-italic { + font-style: italic!important; +} + +.jqconsole-ansi-underline { + text-decoration: underline!important; +} + +@-webkit-keyframes blinker { + from { opacity: 1.0; } + to { opacity: 0.0; } +} + +@-moz-keyframes blinker { + from { opacity: 1.0; } + to { opacity: 0.0; } +} + +@-ms-keyframes blinker { + from { opacity: 1.0; } + to { opacity: 0.0; } +} + +@-o-keyframes blinker { + from { opacity: 1.0; } + to { opacity: 0.0; } +} + +.jqconsole-ansi-blink { + -webkit-animation-name: blinker; + -moz-animation-name: blinker; + -ms-animation-name: blinker; + -o-animation-name: blinker; + -webkit-animation-iteration-count: infinite; + -moz-animation-iteration-count: infinite; + -ms-animation-iteration-count: infinite; + -o-animation-iteration-count: infinite; + -webkit-animation-timing-function: cubic-bezier(1.0,0,0,1.0); + -ms-animation-timing-function: cubic-bezier(1.0,0,0,1.0); + -o-animation-timing-function: cubic-bezier(1.0,0,0,1.0); + -moz-animation-timing-function: cubic-bezier(1.0,0,0,1.0); + -webkit-animation-duration: 1s; + -moz-animation-duration: 1s; + -o-animation-duration: 1s; + -ms-animation-duration: 1s; +} + +.jqconsole-ansi-blink-rapid { + -webkit-animation-name: blinker; + -moz-animation-name: blinker; + -ms-animation-name: blinker; + -o-animation-name: blinker; + -webkit-animation-iteration-count: infinite; + -moz-animation-iteration-count: infinite; + -ms-animation-iteration-count: infinite; + -o-animation-iteration-count: infinite; + -webkit-animation-timing-function: cubic-bezier(1.0,0,0,1.0); + -ms-animation-timing-function: cubic-bezier(1.0,0,0,1.0); + -o-animation-timing-function: cubic-bezier(1.0,0,0,1.0); + -moz-animation-timing-function: cubic-bezier(1.0,0,0,1.0); + -webkit-animation-duration: 0.5s; + -moz-animation-duration: 0.5s; + -o-animation-duration: 0.5s; + -ms-animation-duration: 0.5s; +} + + +.jqconsole-ansi-hidden { + visibility:hidden!important; +} + +.jqconsole-ansi-line-through { + text-decoration: line-through; +} + +.jqconsole-ansi-fonts-1 { + +} +.jqconsole-ansi-fonts-2 { + +} +.jqconsole-ansi-fonts-3 { + +} +.jqconsole-ansi-fonts-4 { + +} +.jqconsole-ansi-fonts-5 { + +} +.jqconsole-ansi-fonts-6 { + +} +.jqconsole-ansi-fonts-7 { + +} +.jqconsole-ansi-fonts-8 { + +} +.jqconsole-ansi-fonts-9 { + +} + +.jqconsole-ansi-fraktur { + +} + +.jqconsole-ansi-color-black { + color: black!important; +} +.jqconsole-ansi-color-red { + color: red!important; +} +.jqconsole-ansi-color-green { + color: green!important; +} +.jqconsole-ansi-color-yellow { + color: yellow!important; +} +.jqconsole-ansi-color-blue { + color: blue!important; +} +.jqconsole-ansi-color-magenta { + color: magenta!important; +} +.jqconsole-ansi-color-cyan { + color: cyan!important; +} +.jqconsole-ansi-color-white { + color: white!important; +} + +.jqconsole-ansi-background-color-black { + background-color: black!important; +} +.jqconsole-ansi-background-color-red { + background-color: red!important; +} +.jqconsole-ansi-background-color-green { + background-color: green!important; +} +.jqconsole-ansi-background-color-yellow { + background-color: yellow!important; +} +.jqconsole-ansi-background-color-blue { + background-color: blue!important; +} +.jqconsole-ansi-background-color-magenta { + background-color: magenta!important; +} +.jqconsole-ansi-background-color-cyan { + background-color: cyan!important; +} +.jqconsole-ansi-background-color-white { + background-color: white!important; +} + +.jqconsole-ansi-framed { + border: 1px solid!important; +} +.jqconsole-ansi-overline { + text-decoration: overline!important; +} + diff --git a/docs/web/base.css b/docs/web/base.css index 9e62c9cb8f..e169022387 100644 --- a/docs/web/base.css +++ b/docs/web/base.css @@ -1,222 +1,222 @@ -/* -* Skeleton V1.0.2 -* Copyright 2011, Dave Gamache -* www.getskeleton.com -* Free to use under the MIT license. -* http://www.opensource.org/licenses/mit-license.php -* 5/20/2011 -*/ - - -/* Table of Content -================================================== - #Reset & Basics - #Basic Styles - #Site Styles - #Typography - #Links - #Lists - #Images - #Buttons - #Tabs - #Forms - #Misc */ - - -/* #Reset & Basics (Inspired by E. Meyers) -================================================== */ - html, body, div, span, applet, object, iframe, h1, h2, h3, h4, h5, h6, p, blockquote, pre, a, abbr, acronym, address, big, cite, code, del, dfn, em, img, ins, kbd, q, s, samp, small, strike, strong, sub, sup, tt, var, b, u, i, center, dl, dt, dd, ol, ul, li, fieldset, form, label, legend, table, caption, tbody, tfoot, thead, tr, th, td, article, aside, canvas, details, embed, figure, figcaption, footer, header, hgroup, menu, nav, output, ruby, section, summary, time, mark, audio, video { - margin: 0; - padding: 0; - border: 0; - font-size: 100%; - font: inherit; - vertical-align: baseline; } - article, aside, details, figcaption, figure, footer, header, hgroup, menu, nav, section { - display: block; } - body { - line-height: 1; } - ol, ul { - list-style: none; } - blockquote, q { - quotes: none; } - blockquote:before, blockquote:after, - q:before, q:after { - content: ''; - content: none; } - table { - border-collapse: collapse; - border-spacing: 0; } - - -/* #Basic Styles -================================================== */ - body { - background: #ebe7d7 url(bg-body.png); - font: 14px/21px "HelveticaNeue", "Helvetica Neue", Helvetica, Arial, sans-serif; - color: #444; - -webkit-font-smoothing: antialiased; /* Fix for webkit rendering */ - } - - -/* #Typography -================================================== */ - h1, h2, h3, h4, h5, h6 { - font-weight: normal; } - h1 a, h2 a, h3 a, h4 a, h5 a, h6 a { font-weight: inherit; } - h1 { - font-size: 56px; - line-height: 50px; - font-family: "ExoBlack"; - text-transform: uppercase; - color: #8f4732; - margin-bottom: 10px; - text-shadow: 1px 1px 1px #a9a17c; - } - h2 { - font-size: 18px; - line-height: 40px; - margin-top: -45px; - font-family: "ExoBold"; - color: #327a8e; - float: right; - } - h3 { - font-size: 24px; - line-height: 34px; - margin-top: 20px; - margin-left: 10px; - font-family: "ExoBold"; - color: #327a8e; - } - h4 { - font-size: 18px; - line-height: 30px; - margin-bottom: 4px; - font-family: "ExoBold"; - color: #444; - } - h5 { font-size: 17px; line-height: 24px; } - h6 { font-size: 14px; line-height: 21px; } - .subheader { color: #777; } - - p { margin: 0 0 20px 0; } - p img { margin: 0; } - p.lead { font-size: 21px; line-height: 27px; color: #777; } - - em { font-style: italic; } - strong { font-weight: bold; color: #333; } - small { font-size: 80%; } - -/* Blockquotes */ - blockquote, blockquote p { font-size: 17px; line-height: 24px; color: #777; font-style: italic; } - blockquote { margin: 0 0 20px; padding: 9px 20px 0 19px; border-left: 1px solid #ddd; } - blockquote cite { display: block; font-size: 12px; color: #555; } - blockquote cite:before { content: "\2014 \0020"; } - blockquote cite a, blockquote cite a:visited, blockquote cite a:visited { color: #555; } - - hr { border: solid #ddd; border-width: 1px 0 0; clear: both; margin: 10px 0 30px; height: 0; } - - -/* #Links -================================================== */ - a, a:visited { color: #333; text-decoration: underline; outline: 0; } - a:hover, a:focus { color: #000; } - p a, p a:visited { line-height: inherit; } - - -/* #Lists -================================================== */ - ul, ol { margin-bottom: 20px; } - ul { list-style: none outside; } - ol { list-style: decimal; } - ol, ul.square, ul.circle, ul.disc { margin-left: 30px; } - ul.square { list-style: square outside; } - ul.circle { list-style: circle outside; } - ul.disc { list-style: disc outside; } - ul ul, ul ol, - ol ol, ol ul { margin: 4px 0 5px 30px; font-size: 90%; } - ul ul li, ul ol li, - ol ol li, ol ul li { margin-bottom: 6px; } - li { line-height: 18px; margin-bottom: 12px; } - ul.large li { line-height: 21px; } - li p { line-height: 21px; } - -/* #Images -================================================== */ -/* - The purpose of the below declaration is to make sure images don't - exceed the width of columns they are put into when resizing window. - Unfortunately, this declaration breaks certain lightbox, slider or other plugins, - so the best solution is to individually call these properties on images that - are children of the grid that you want to resize with grid. - - img { - max-width: 100%; - height: auto; } - -*/ - - -/* #Forms -================================================== */ - - form { - margin-bottom: 20px; } - fieldset { - margin-bottom: 20px; } - input[type="text"], - input[type="password"], - input[type="email"], - textarea, - select { - border: 1px solid #ccc; - padding: 6px 4px; - outline: none; - -moz-border-radius: 2px; - -webkit-border-radius: 2px; - border-radius: 2px; - font: 13px "HelveticaNeue", "Helvetica Neue", Helvetica, Arial, sans-serif; - color: #777; - margin: 0; - width: 210px; - max-width: 100%; - display: block; - margin-bottom: 20px; - background: #fff; } - select { - padding: 0; } - input[type="text"]:focus, - input[type="password"]:focus, - input[type="email"]:focus, - textarea:focus { - border: 1px solid #aaa; - color: #444; - -moz-box-shadow: 0 0 3px rgba(0,0,0,.2); - -webkit-box-shadow: 0 0 3px rgba(0,0,0,.2); - box-shadow: 0 0 3px rgba(0,0,0,.2); } - textarea { - min-height: 60px; } - label, - legend { - display: block; - font-weight: bold; - font-size: 13px; } - select { - width: 220px; } - input[type="checkbox"] { - display: inline; } - label span, - legend span { - font-weight: normal; - font-size: 13px; - color: #444; } - -/* #Misc -================================================== */ - .remove-bottom { margin-bottom: 0 !important; } - .half-bottom { margin-bottom: 10px !important; } - .add-bottom { margin-bottom: 20px !important; } - - - +/* +* Skeleton V1.0.2 +* Copyright 2011, Dave Gamache +* www.getskeleton.com +* Free to use under the MIT license. +* http://www.opensource.org/licenses/mit-license.php +* 5/20/2011 +*/ + + +/* Table of Content +================================================== + #Reset & Basics + #Basic Styles + #Site Styles + #Typography + #Links + #Lists + #Images + #Buttons + #Tabs + #Forms + #Misc */ + + +/* #Reset & Basics (Inspired by E. Meyers) +================================================== */ + html, body, div, span, applet, object, iframe, h1, h2, h3, h4, h5, h6, p, blockquote, pre, a, abbr, acronym, address, big, cite, code, del, dfn, em, img, ins, kbd, q, s, samp, small, strike, strong, sub, sup, tt, var, b, u, i, center, dl, dt, dd, ol, ul, li, fieldset, form, label, legend, table, caption, tbody, tfoot, thead, tr, th, td, article, aside, canvas, details, embed, figure, figcaption, footer, header, hgroup, menu, nav, output, ruby, section, summary, time, mark, audio, video { + margin: 0; + padding: 0; + border: 0; + font-size: 100%; + font: inherit; + vertical-align: baseline; } + article, aside, details, figcaption, figure, footer, header, hgroup, menu, nav, section { + display: block; } + body { + line-height: 1; } + ol, ul { + list-style: none; } + blockquote, q { + quotes: none; } + blockquote:before, blockquote:after, + q:before, q:after { + content: ''; + content: none; } + table { + border-collapse: collapse; + border-spacing: 0; } + + +/* #Basic Styles +================================================== */ + body { + background: #ebe7d7 url(bg-body.png); + font: 14px/21px "HelveticaNeue", "Helvetica Neue", Helvetica, Arial, sans-serif; + color: #444; + -webkit-font-smoothing: antialiased; /* Fix for webkit rendering */ + } + + +/* #Typography +================================================== */ + h1, h2, h3, h4, h5, h6 { + font-weight: normal; } + h1 a, h2 a, h3 a, h4 a, h5 a, h6 a { font-weight: inherit; } + h1 { + font-size: 56px; + line-height: 50px; + font-family: "ExoBlack"; + text-transform: uppercase; + color: #8f4732; + margin-bottom: 10px; + text-shadow: 1px 1px 1px #a9a17c; + } + h2 { + font-size: 18px; + line-height: 40px; + margin-top: -45px; + font-family: "ExoBold"; + color: #327a8e; + float: right; + } + h3 { + font-size: 24px; + line-height: 34px; + margin-top: 20px; + margin-left: 10px; + font-family: "ExoBold"; + color: #327a8e; + } + h4 { + font-size: 18px; + line-height: 30px; + margin-bottom: 4px; + font-family: "ExoBold"; + color: #444; + } + h5 { font-size: 17px; line-height: 24px; } + h6 { font-size: 14px; line-height: 21px; } + .subheader { color: #777; } + + p { margin: 0 0 20px 0; } + p img { margin: 0; } + p.lead { font-size: 21px; line-height: 27px; color: #777; } + + em { font-style: italic; } + strong { font-weight: bold; color: #333; } + small { font-size: 80%; } + +/* Blockquotes */ + blockquote, blockquote p { font-size: 17px; line-height: 24px; color: #777; font-style: italic; } + blockquote { margin: 0 0 20px; padding: 9px 20px 0 19px; border-left: 1px solid #ddd; } + blockquote cite { display: block; font-size: 12px; color: #555; } + blockquote cite:before { content: "\2014 \0020"; } + blockquote cite a, blockquote cite a:visited, blockquote cite a:visited { color: #555; } + + hr { border: solid #ddd; border-width: 1px 0 0; clear: both; margin: 10px 0 30px; height: 0; } + + +/* #Links +================================================== */ + a, a:visited { color: #333; text-decoration: underline; outline: 0; } + a:hover, a:focus { color: #000; } + p a, p a:visited { line-height: inherit; } + + +/* #Lists +================================================== */ + ul, ol { margin-bottom: 20px; } + ul { list-style: none outside; } + ol { list-style: decimal; } + ol, ul.square, ul.circle, ul.disc { margin-left: 30px; } + ul.square { list-style: square outside; } + ul.circle { list-style: circle outside; } + ul.disc { list-style: disc outside; } + ul ul, ul ol, + ol ol, ol ul { margin: 4px 0 5px 30px; font-size: 90%; } + ul ul li, ul ol li, + ol ol li, ol ul li { margin-bottom: 6px; } + li { line-height: 18px; margin-bottom: 12px; } + ul.large li { line-height: 21px; } + li p { line-height: 21px; } + +/* #Images +================================================== */ +/* + The purpose of the below declaration is to make sure images don't + exceed the width of columns they are put into when resizing window. + Unfortunately, this declaration breaks certain lightbox, slider or other plugins, + so the best solution is to individually call these properties on images that + are children of the grid that you want to resize with grid. + + img { + max-width: 100%; + height: auto; } + +*/ + + +/* #Forms +================================================== */ + + form { + margin-bottom: 20px; } + fieldset { + margin-bottom: 20px; } + input[type="text"], + input[type="password"], + input[type="email"], + textarea, + select { + border: 1px solid #ccc; + padding: 6px 4px; + outline: none; + -moz-border-radius: 2px; + -webkit-border-radius: 2px; + border-radius: 2px; + font: 13px "HelveticaNeue", "Helvetica Neue", Helvetica, Arial, sans-serif; + color: #777; + margin: 0; + width: 210px; + max-width: 100%; + display: block; + margin-bottom: 20px; + background: #fff; } + select { + padding: 0; } + input[type="text"]:focus, + input[type="password"]:focus, + input[type="email"]:focus, + textarea:focus { + border: 1px solid #aaa; + color: #444; + -moz-box-shadow: 0 0 3px rgba(0,0,0,.2); + -webkit-box-shadow: 0 0 3px rgba(0,0,0,.2); + box-shadow: 0 0 3px rgba(0,0,0,.2); } + textarea { + min-height: 60px; } + label, + legend { + display: block; + font-weight: bold; + font-size: 13px; } + select { + width: 220px; } + input[type="checkbox"] { + display: inline; } + label span, + legend span { + font-weight: normal; + font-size: 13px; + color: #444; } + +/* #Misc +================================================== */ + .remove-bottom { margin-bottom: 0 !important; } + .half-bottom { margin-bottom: 10px !important; } + .add-bottom { margin-bottom: 20px !important; } + + + diff --git a/docs/web/console.css b/docs/web/console.css index 5454fd1170..26b87da002 100644 --- a/docs/web/console.css +++ b/docs/web/console.css @@ -1,63 +1,63 @@ -/* Outer console element */ -#console { -} -/* The inner console element. */ -.jqconsole { - background-color: black;; -} -.jqconsole-prompt { - color: #0d0; -} -.jqconsole-old-prompt { - color: #0b0; - font-weight: normal; -} -.jqconsole-input { - color: #dd0; -} -.jqconsole-old-input { - color: #bb0; - font-weight: normal; -} -.jqconsole-output { - font-weight: lighter; - font-family:monospace; - color: grey; -} -.jqconsole-return { - font-weight: normal; - font-family:monospace; - color: white; -} -.jqconsole-error { - font-weight: normal; - font-family:monospace; - color: red; -} -/* The cursor. */ -.jqconsole-cursor { - font-weight: normal; - font-family:monospace; - background-color: #BDB; -} -/* The cursor color when the console looses focus. */ -.jqconsole-blurred .jqconsole-cursor { - font-weight: normal; - font-family:monospace; - background-color: #444; -} -.brace { - color: #00FFFF; -} -.paren { - color: #FF00FF; -} -.bracket { - color: #FFFF00; -} -.dquote { - color: #FF8888; -} -.jqconsole-composition { - background-color: red; -} +/* Outer console element */ +#console { +} +/* The inner console element. */ +.jqconsole { + background-color: black;; +} +.jqconsole-prompt { + color: #0d0; +} +.jqconsole-old-prompt { + color: #0b0; + font-weight: normal; +} +.jqconsole-input { + color: #dd0; +} +.jqconsole-old-input { + color: #bb0; + font-weight: normal; +} +.jqconsole-output { + font-weight: lighter; + font-family:monospace; + color: grey; +} +.jqconsole-return { + font-weight: normal; + font-family:monospace; + color: white; +} +.jqconsole-error { + font-weight: normal; + font-family:monospace; + color: red; +} +/* The cursor. */ +.jqconsole-cursor { + font-weight: normal; + font-family:monospace; + background-color: #BDB; +} +/* The cursor color when the console looses focus. */ +.jqconsole-blurred .jqconsole-cursor { + font-weight: normal; + font-family:monospace; + background-color: #444; +} +.brace { + color: #00FFFF; +} +.paren { + color: #FF00FF; +} +.bracket { + color: #FFFF00; +} +.dquote { + color: #FF8888; +} +.jqconsole-composition { + background-color: red; +} diff --git a/docs/web/fonts/exo-black-webfont.svg b/docs/web/fonts/exo-black-webfont.svg index 350998091e..b1b8eb73ec 100644 --- a/docs/web/fonts/exo-black-webfont.svg +++ b/docs/web/fonts/exo-black-webfont.svg @@ -1,246 +1,246 @@ - - - - -This is a custom SVG webfont generated by Font Squirrel. -Copyright : Copyright c 2011 Natanael Gama exondiscoveredcom with Reserved Font Name Exo -Designer : Natanael Gama - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + +This is a custom SVG webfont generated by Font Squirrel. +Copyright : Copyright c 2011 Natanael Gama exondiscoveredcom with Reserved Font Name Exo +Designer : Natanael Gama + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/docs/web/fonts/exo-bold-webfont.svg b/docs/web/fonts/exo-bold-webfont.svg index 96c023459b..68120cc7a8 100644 --- a/docs/web/fonts/exo-bold-webfont.svg +++ b/docs/web/fonts/exo-bold-webfont.svg @@ -1,246 +1,246 @@ - - - - -This is a custom SVG webfont generated by Font Squirrel. -Copyright : Copyright c 2011 Natanael Gama exondiscoveredcom with Reserved Font Name Exo -Designer : Natanael Gama - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + +This is a custom SVG webfont generated by Font Squirrel. +Copyright : Copyright c 2011 Natanael Gama exondiscoveredcom with Reserved Font Name Exo +Designer : Natanael Gama + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/docs/web/fonts/exo-regular-webfont.svg b/docs/web/fonts/exo-regular-webfont.svg index 87f3554842..72bfc14020 100644 --- a/docs/web/fonts/exo-regular-webfont.svg +++ b/docs/web/fonts/exo-regular-webfont.svg @@ -1,246 +1,246 @@ - - - - -This is a custom SVG webfont generated by Font Squirrel. -Copyright : Copyright c 2011 Natanael Gama exondiscoveredcom with Reserved Font Name Exo -Designer : Natanael Gama - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + +This is a custom SVG webfont generated by Font Squirrel. +Copyright : Copyright c 2011 Natanael Gama exondiscoveredcom with Reserved Font Name Exo +Designer : Natanael Gama + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/docs/web/himera.css b/docs/web/himera.css index 139588d847..45b906541c 100644 --- a/docs/web/himera.css +++ b/docs/web/himera.css @@ -1,280 +1,280 @@ -/* Additional Classes --------------------------------------------- */ - -.source { - font-family: "ExoRegular"; - font-size: 18px; - height: 31px; - margin-top: 20px; - text-align: right; -} - -.source img { - margin-left: 5px; - vertical-align: sub; -} - -.source a { - text-decoration: none; -} - -.rule { - background: url(bg-rule.png); - height: 12px; - clear: both; - margin-top: 20px; - margin-bottom: 20px; -} - -.cheat-box-container { - background-color: rgba(213,207,180,0.4); - border-radius: 5px; - -moz-border-radius: 5px; - margin-top: 20px; -} - -.cheat-box { - padding: 20px; -} - -table { - font-family: monospace; - margin-top: 20px; - width: 100%; -} - -td { - padding: 3px; -} - -.row-one { - background-color: #f2efe4; -} - -.row-label { - color: #666; - font-family: "ExoBold"; - text-transform: uppercase; -} - -.footer-logo { - font-size: 18px; - font-family: "ExoBlack"; - text-transform: uppercase; - color: #8f4732; -} - -ul.footer-links { - float: right; -} - -.footer-links li { - font-family: "ExoRegular"; - font-size: 14px; - display: inline; - list-style-type: none; - margin-left: 10px; - text-transform: uppercase; -} - -.footer-links li a { - color: #327a8e; - text-decoration: none; -} - -.footer-links li a:hover { - color: #333; -} - -.tiny-note { - font-size: small; -} - -/* Editor ---------------------------------------------- */ - -.CodeMirror { - position: relative; - height: 320px; - background: #fbfbf8; - border-radius: 5px; - -moz-border-radius: 5px; - border: 1px solid #d5ceb4; -} - -/* Console --------------------------------------------- */ - -#console { - position: relative; - height: 220px; - background: #fbfbf8; - border-radius: 5px; - -moz-border-radius: 5px; - border: 1px solid #d5ceb4; -} - -/* Console --------------------------------------------- */ -/* The console container element */ -#console { - position: relative; - height: 320px; - background-color:#fbfbf8;; -} -/* The inner console element. */ -.jqconsole { - background: #fbfbf8; - border-radius: 5px; - -moz-border-radius: 5px; - border: 1px solid #d5ceb4; - padding: 10px; - - white-space: pre-wrap; - word-wrap: break-word; -} -/* The cursor. */ -.jqconsole-cursor { - font-weight: normal; - font-family:monospace; - background-color: #000; -} -/* The cursor color when the console looses focus. */ -.jqconsole-blurred .jqconsole-cursor { - font-weight: normal; - font-family:monospace; - background-color: #7F7F7F; -} -/* The current prompt text color */ -.jqconsole-prompt { - font-weight: normal; - font-family:monospace; - color: #000; -} -/* The command history */ -.jqconsole-old-prompt { - font-weight: normal; - font-family:monospace; - color: #000; -} -/* The text color when in input mode. */ -.jqconsole-input { - font-weight: normal; - font-family:monospace; - color: #000; -} -/* Previously entered input. */ -.jqconsole-old-input { - color: #000; - font-weight: normal; - font-family:monospace; -} -/* The text color of the output. */ -.jqconsole-output { - font-weight: normal; - font-family:monospace; - color: #000; -} - -.jqconsole-inner { - /*width:580px;*/ - height:200px; - margin: 10px 10px; - overflow:auto; - text-align:left; -} - -.jqconsole-message-value { - color:#333; - font-family:monospace; - padding:0.1em; -} - -.jqconsole-prompt-box { - color:#444; font-family:monospace; -} - -.jqconsole-focus span.jquery-console-cursor { - background:#333; color:#eee; font-weight:bold; -} - -.jqconsole-message-error { - font-family:sans-serif; - font-weight:bold; - padding:0.1em; - color:#ef0505; -} - -.jqconsole-message-success { - color:#187718; font-family:monospace; - padding:0.1em; -} - - -.ebnf { - color:#444; font-family:monospace; - text-transform: uppercase; -} - -.doc-link { - font-size: 0.65em; - text-decoration: none; -} - -/* Synonym Styles */ - -#himera-synonym h1 { - margin-left: 10px; -} - -#himera-synonym h1 div { - font-size: 16px; - color: black; -} - -#himera-synonym h4, -#himera-synonym h5 { - margin-left: 10px; -} - -#himera-synonym .cheat-box-container { - margin-top: 0px; - background-color: rgb(255, 250, 240); - border: 1px solid #ccc; - box-sizing: border-box; - -webkit-box-sizing: border-box; - -moz-box-sizing: border-box; - -webkit-box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); - -moz-box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); - -o-box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); - -ms-box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); - box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); -} - -#himera-synonym pre { - font-size: 13px; - font-family: monospace; -} - -.syn-section { - clear: both; - float: left; - margin-bottom: 20px; -} - -#himera-synonym table { - margin: 0; - padding: 0; -} - -#himera-synonym .container { - margin: 0; - overflow-x: hidden !important; - overflow-y: hidden !important; -} - -h1 a { - text-decoration: none; - color: inherit; -} - -h1 a:visited { - text-decoration: none; - color: inherit; -} +/* Additional Classes --------------------------------------------- */ + +.source { + font-family: "ExoRegular"; + font-size: 18px; + height: 31px; + margin-top: 20px; + text-align: right; +} + +.source img { + margin-left: 5px; + vertical-align: sub; +} + +.source a { + text-decoration: none; +} + +.rule { + background: url(bg-rule.png); + height: 12px; + clear: both; + margin-top: 20px; + margin-bottom: 20px; +} + +.cheat-box-container { + background-color: rgba(213,207,180,0.4); + border-radius: 5px; + -moz-border-radius: 5px; + margin-top: 20px; +} + +.cheat-box { + padding: 20px; +} + +table { + font-family: monospace; + margin-top: 20px; + width: 100%; +} + +td { + padding: 3px; +} + +.row-one { + background-color: #f2efe4; +} + +.row-label { + color: #666; + font-family: "ExoBold"; + text-transform: uppercase; +} + +.footer-logo { + font-size: 18px; + font-family: "ExoBlack"; + text-transform: uppercase; + color: #8f4732; +} + +ul.footer-links { + float: right; +} + +.footer-links li { + font-family: "ExoRegular"; + font-size: 14px; + display: inline; + list-style-type: none; + margin-left: 10px; + text-transform: uppercase; +} + +.footer-links li a { + color: #327a8e; + text-decoration: none; +} + +.footer-links li a:hover { + color: #333; +} + +.tiny-note { + font-size: small; +} + +/* Editor ---------------------------------------------- */ + +.CodeMirror { + position: relative; + height: 320px; + background: #fbfbf8; + border-radius: 5px; + -moz-border-radius: 5px; + border: 1px solid #d5ceb4; +} + +/* Console --------------------------------------------- */ + +#console { + position: relative; + height: 220px; + background: #fbfbf8; + border-radius: 5px; + -moz-border-radius: 5px; + border: 1px solid #d5ceb4; +} + +/* Console --------------------------------------------- */ +/* The console container element */ +#console { + position: relative; + height: 320px; + background-color:#fbfbf8;; +} +/* The inner console element. */ +.jqconsole { + background: #fbfbf8; + border-radius: 5px; + -moz-border-radius: 5px; + border: 1px solid #d5ceb4; + padding: 10px; + + white-space: pre-wrap; + word-wrap: break-word; +} +/* The cursor. */ +.jqconsole-cursor { + font-weight: normal; + font-family:monospace; + background-color: #000; +} +/* The cursor color when the console looses focus. */ +.jqconsole-blurred .jqconsole-cursor { + font-weight: normal; + font-family:monospace; + background-color: #7F7F7F; +} +/* The current prompt text color */ +.jqconsole-prompt { + font-weight: normal; + font-family:monospace; + color: #000; +} +/* The command history */ +.jqconsole-old-prompt { + font-weight: normal; + font-family:monospace; + color: #000; +} +/* The text color when in input mode. */ +.jqconsole-input { + font-weight: normal; + font-family:monospace; + color: #000; +} +/* Previously entered input. */ +.jqconsole-old-input { + color: #000; + font-weight: normal; + font-family:monospace; +} +/* The text color of the output. */ +.jqconsole-output { + font-weight: normal; + font-family:monospace; + color: #000; +} + +.jqconsole-inner { + /*width:580px;*/ + height:200px; + margin: 10px 10px; + overflow:auto; + text-align:left; +} + +.jqconsole-message-value { + color:#333; + font-family:monospace; + padding:0.1em; +} + +.jqconsole-prompt-box { + color:#444; font-family:monospace; +} + +.jqconsole-focus span.jquery-console-cursor { + background:#333; color:#eee; font-weight:bold; +} + +.jqconsole-message-error { + font-family:sans-serif; + font-weight:bold; + padding:0.1em; + color:#ef0505; +} + +.jqconsole-message-success { + color:#187718; font-family:monospace; + padding:0.1em; +} + + +.ebnf { + color:#444; font-family:monospace; + text-transform: uppercase; +} + +.doc-link { + font-size: 0.65em; + text-decoration: none; +} + +/* Synonym Styles */ + +#himera-synonym h1 { + margin-left: 10px; +} + +#himera-synonym h1 div { + font-size: 16px; + color: black; +} + +#himera-synonym h4, +#himera-synonym h5 { + margin-left: 10px; +} + +#himera-synonym .cheat-box-container { + margin-top: 0px; + background-color: rgb(255, 250, 240); + border: 1px solid #ccc; + box-sizing: border-box; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + -webkit-box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); + -moz-box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); + -o-box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); + -ms-box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); + box-shadow: inset 0 1px 2px rgba(0, 0, 0, .1); +} + +#himera-synonym pre { + font-size: 13px; + font-family: monospace; +} + +.syn-section { + clear: both; + float: left; + margin-bottom: 20px; +} + +#himera-synonym table { + margin: 0; + padding: 0; +} + +#himera-synonym .container { + margin: 0; + overflow-x: hidden !important; + overflow-y: hidden !important; +} + +h1 a { + text-decoration: none; + color: inherit; +} + +h1 a:visited { + text-decoration: none; + color: inherit; +} diff --git a/docs/web/layout.css b/docs/web/layout.css index 9c5feab594..25b62a0aa2 100644 --- a/docs/web/layout.css +++ b/docs/web/layout.css @@ -1,100 +1,100 @@ -/* -* Skeleton V1.0.2 -* Copyright 2011, Dave Gamache -* www.getskeleton.com -* Free to use under the MIT license. -* http://www.opensource.org/licenses/mit-license.php -* 5/20/2011 -*/ - -/* Table of Content -================================================== - #Site Styles - #Page Styles - #Media Queries - #Font-Face */ - -/* #Site Styles -================================================== */ - -/* #Page Styles -================================================== */ - -/* #Media Queries -================================================== */ - - /* iPad Portrait/Browser */ - @media only screen and (min-width: 768px) and (max-width: 991px) {} - - /* Mobile/Browser */ - @media only screen and (max-width: 767px) {} - - /* Mobile Landscape/Browser */ - @media only screen and (min-width: 480px) and (max-width: 767px) {} - - /* Anything smaller than standard 960 */ - @media only screen and (max-width: 959px) { - h1 { - font-size: 48px; - } - h2 { - font-size: 16px; - float: none; - line-height: 150%; - margin-top: -10px; - } - h3 { - font-size: 18px; - } - h4 { - font-size: 14px; - } - .source p { - font-size: 16px; - } - } - - /* iPad Portrait Only */ - @media only screen and (min-width: 768px) and (max-width: 991px) and (max-device-width: 1000px) {} - - /* Mobile Only */ - @media only screen and (max-width: 767px) and (max-device-width: 1000px) {} - - /* Mobile Landscape Only */ - @media only screen and (min-width: 480px) and (max-width: 767px) and (max-device-width: 1000px) {} - - -/* Fonts --------------------------------------------- */ - -@font-face { - font-family: 'ExoBold'; - src: url('fonts/exo-bold-webfont.eot'); - src: url('fonts/exo-bold-webfont.eot?#iefix') format('embedded-opentype'), - url('fonts/exo-bold-webfont.woff') format('woff'), - url('fonts/exo-bold-webfont.ttf') format('truetype'), - url('fonts/exo-bold-webfont.svg#ExoBold') format('svg'); - font-weight: normal; - font-style: normal; -} - -@font-face { - font-family: 'ExoBlack'; - src: url('fonts/exo-black-webfont.eot'); - src: url('fonts/exo-black-webfont.eot?#iefix') format('embedded-opentype'), - url('fonts/exo-black-webfont.woff') format('woff'), - url('fonts/exo-black-webfont.ttf') format('truetype'), - url('fonts/exo-black-webfont.svg#ExoBlack') format('svg'); - font-weight: normal; - font-style: normal; -} - -@font-face { - font-family: 'ExoRegular'; - src: url('fonts/exo-regular-webfont.eot'); - src: url('fonts/exo-regular-webfont.eot?#iefix') format('embedded-opentype'), - url('fonts/exo-regular-webfont.woff') format('woff'), - url('fonts/exo-regular-webfont.ttf') format('truetype'), - url('fonts/exo-regular-webfont.svg#ExoRegular') format('svg'); - font-weight: normal; - font-style: normal; -} +/* +* Skeleton V1.0.2 +* Copyright 2011, Dave Gamache +* www.getskeleton.com +* Free to use under the MIT license. +* http://www.opensource.org/licenses/mit-license.php +* 5/20/2011 +*/ + +/* Table of Content +================================================== + #Site Styles + #Page Styles + #Media Queries + #Font-Face */ + +/* #Site Styles +================================================== */ + +/* #Page Styles +================================================== */ + +/* #Media Queries +================================================== */ + + /* iPad Portrait/Browser */ + @media only screen and (min-width: 768px) and (max-width: 991px) {} + + /* Mobile/Browser */ + @media only screen and (max-width: 767px) {} + + /* Mobile Landscape/Browser */ + @media only screen and (min-width: 480px) and (max-width: 767px) {} + + /* Anything smaller than standard 960 */ + @media only screen and (max-width: 959px) { + h1 { + font-size: 48px; + } + h2 { + font-size: 16px; + float: none; + line-height: 150%; + margin-top: -10px; + } + h3 { + font-size: 18px; + } + h4 { + font-size: 14px; + } + .source p { + font-size: 16px; + } + } + + /* iPad Portrait Only */ + @media only screen and (min-width: 768px) and (max-width: 991px) and (max-device-width: 1000px) {} + + /* Mobile Only */ + @media only screen and (max-width: 767px) and (max-device-width: 1000px) {} + + /* Mobile Landscape Only */ + @media only screen and (min-width: 480px) and (max-width: 767px) and (max-device-width: 1000px) {} + + +/* Fonts --------------------------------------------- */ + +@font-face { + font-family: 'ExoBold'; + src: url('fonts/exo-bold-webfont.eot'); + src: url('fonts/exo-bold-webfont.eot?#iefix') format('embedded-opentype'), + url('fonts/exo-bold-webfont.woff') format('woff'), + url('fonts/exo-bold-webfont.ttf') format('truetype'), + url('fonts/exo-bold-webfont.svg#ExoBold') format('svg'); + font-weight: normal; + font-style: normal; +} + +@font-face { + font-family: 'ExoBlack'; + src: url('fonts/exo-black-webfont.eot'); + src: url('fonts/exo-black-webfont.eot?#iefix') format('embedded-opentype'), + url('fonts/exo-black-webfont.woff') format('woff'), + url('fonts/exo-black-webfont.ttf') format('truetype'), + url('fonts/exo-black-webfont.svg#ExoBlack') format('svg'); + font-weight: normal; + font-style: normal; +} + +@font-face { + font-family: 'ExoRegular'; + src: url('fonts/exo-regular-webfont.eot'); + src: url('fonts/exo-regular-webfont.eot?#iefix') format('embedded-opentype'), + url('fonts/exo-regular-webfont.woff') format('woff'), + url('fonts/exo-regular-webfont.ttf') format('truetype'), + url('fonts/exo-regular-webfont.svg#ExoRegular') format('svg'); + font-weight: normal; + font-style: normal; +} diff --git a/docs/web/mal.js b/docs/web/mal.js index fc9919d4c2..9295bdd8bb 100644 --- a/docs/web/mal.js +++ b/docs/web/mal.js @@ -1,976 +1,976 @@ -var max_history_length = 1000; - -function jq_load_history(jq) { - if (localStorage['mal_history']) { - var lines = JSON.parse(localStorage['mal_history']); - if (lines.length > max_history_length) { - lines = lines.slice(lines.length-max_history_length); - } - jq.SetHistory(lines); - } -} - -function jq_save_history(jq) { - var lines = jq.GetHistory(); - localStorage['mal_history'] = JSON.stringify(lines); -} - - -var readline = { - 'readline': function(prompt_str) { - return prompt(prompt_str); - }}; - -// Node vs browser behavior -var types = {}; -if (typeof module === 'undefined') { - var exports = types; -} - -// General functions - -function _obj_type(obj) { - if (_symbol_Q(obj)) { return 'symbol'; } - else if (_list_Q(obj)) { return 'list'; } - else if (_vector_Q(obj)) { return 'vector'; } - else if (_hash_map_Q(obj)) { return 'hash-map'; } - else if (_nil_Q(obj)) { return 'nil'; } - else if (_true_Q(obj)) { return 'true'; } - else if (_false_Q(obj)) { return 'false'; } - else if (_atom_Q(obj)) { return 'atom'; } - else { - switch (typeof(obj)) { - case 'number': return 'number'; - case 'function': return 'function'; - case 'string': return obj[0] == '\u029e' ? 'keyword' : 'string'; - default: throw new Error("Unknown type '" + typeof(obj) + "'"); - } - } -} - -function _sequential_Q(lst) { return _list_Q(lst) || _vector_Q(lst); } - - -function _equal_Q (a, b) { - var ota = _obj_type(a), otb = _obj_type(b); - if (!(ota === otb || (_sequential_Q(a) && _sequential_Q(b)))) { - return false; - } - switch (ota) { - case 'symbol': return a.value === b.value; - case 'list': - case 'vector': - if (a.length !== b.length) { return false; } - for (var i=0; i 0 ? obj : null; - } else if (types._vector_Q(obj)) { - return obj.length > 0 ? Array.prototype.slice.call(obj, 0): null; - } else if (types._string_Q(obj)) { - return obj.length > 0 ? obj.split('') : null; - } else if (obj === null) { - return null; - } else { - throw new Error("seq: called on non-sequence"); - } -} - - -function apply(f) { - var args = Array.prototype.slice.call(arguments, 1); - return f.apply(f, args.slice(0, args.length-1).concat(args[args.length-1])); -} - -function map(f, lst) { - return lst.map(function(el){ return f(el); }); -} - - -// Metadata functions -function with_meta(obj, m) { - var new_obj = types._clone(obj); - new_obj.__meta__ = m; - return new_obj; -} - -function meta(obj) { - // TODO: support symbols and atoms - if ((!types._sequential_Q(obj)) && - (!(types._hash_map_Q(obj))) && - (!(types._function_Q(obj)))) { - throw new Error("attempt to get metadata from: " + types._obj_type(obj)); - } - return obj.__meta__; -} - - -// Atom functions -function deref(atm) { return atm.val; } -function reset_BANG(atm, val) { return atm.val = val; } -function swap_BANG(atm, f) { - var args = [atm.val].concat(Array.prototype.slice.call(arguments, 2)); - atm.val = f.apply(f, args); - return atm.val; -} - -function js_eval(str) { - return interop.js_to_mal(eval(str.toString())); -} - -function js_method_call(object_method_str) { - var args = Array.prototype.slice.call(arguments, 1), - r = interop.resolve_js(object_method_str), - obj = r[0], f = r[1]; - var res = f.apply(obj, args); - return interop.js_to_mal(res); -} - -// types.ns is namespace of type functions -var ns = {'type': types._obj_type, - '=': types._equal_Q, - 'throw': mal_throw, - 'nil?': types._nil_Q, - 'true?': types._true_Q, - 'false?': types._false_Q, - 'number?': types._number_Q, - 'string?': types._string_Q, - 'symbol': types._symbol, - 'symbol?': types._symbol_Q, - 'keyword': types._keyword, - 'keyword?': types._keyword_Q, - 'fn?': types._fn_Q, - 'macro?': types._macro_Q, - - 'pr-str': pr_str, - 'str': str, - 'prn': prn, - 'println': println, - 'readline': readline.readline, - 'read-string': reader.read_str, - 'slurp': slurp, - '<' : function(a,b){return a' : function(a,b){return a>b;}, - '>=' : function(a,b){return a>=b;}, - '+' : function(a,b){return a+b;}, - '-' : function(a,b){return a-b;}, - '*' : function(a,b){return a*b;}, - '/' : function(a,b){return a/b;}, - "time-ms": time_ms, - - 'list': types._list, - 'list?': types._list_Q, - 'vector': types._vector, - 'vector?': types._vector_Q, - 'hash-map': types._hash_map, - 'map?': types._hash_map_Q, - 'assoc': assoc, - 'dissoc': dissoc, - 'get': get, - 'contains?': contains_Q, - 'keys': keys, - 'vals': vals, - - 'sequential?': types._sequential_Q, - 'cons': cons, - 'concat': concat, - 'nth': nth, - 'first': first, - 'rest': rest, - 'empty?': empty_Q, - 'count': count, - 'apply': apply, - 'map': map, - - 'conj': conj, - 'seq': seq, - - 'with-meta': with_meta, - 'meta': meta, - 'atom': types._atom, - 'atom?': types._atom_Q, - "deref": deref, - "reset!": reset_BANG, - "swap!": swap_BANG, - - 'js-eval': js_eval, - '.': js_method_call -}; - -exports.ns = core.ns = ns; -if (typeof module !== 'undefined') { -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function is_pair(x) { - return types._sequential_Q(x) && x.length > 0; -} - -function quasiquote(ast) { - if (!is_pair(ast)) { - return [types._symbol("quote"), ast]; - } else if (types._symbol_Q(ast[0]) && ast[0].value === 'unquote') { - return ast[1]; - } else if (is_pair(ast[0]) && ast[0][0].value === 'splice-unquote') { - return [types._symbol("concat"), - ast[0][1], - quasiquote(ast.slice(1))]; - } else { - return [types._symbol("cons"), - quasiquote(ast[0]), - quasiquote(ast.slice(1))]; - } -} - -function is_macro_call(ast, env) { - return types._list_Q(ast) && - types._symbol_Q(ast[0]) && - env.find(ast[0]) && - env.get(ast[0])._ismacro_; -} - -function macroexpand(ast, env) { - while (is_macro_call(ast, env)) { - var mac = env.get(ast[0]); - ast = mac.apply(mac, ast.slice(1)); - } - return ast; -} - -function eval_ast(ast, env) { - if (types._symbol_Q(ast)) { - return env.get(ast); - } else if (types._list_Q(ast)) { - return ast.map(function(a) { return EVAL(a, env); }); - } else if (types._vector_Q(ast)) { - var v = ast.map(function(a) { return EVAL(a, env); }); - v.__isvector__ = true; - return v; - } else if (types._hash_map_Q(ast)) { - var new_hm = {}; - for (k in ast) { - new_hm[EVAL(k, env)] = EVAL(ast[k], env); - } - return new_hm; - } else { - return ast; - } -} - -function _EVAL(ast, env) { - while (true) { - - //printer.println("EVAL:", printer._pr_str(ast, true)); - if (!types._list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - ast = macroexpand(ast, env); - if (!types._list_Q(ast)) { - return eval_ast(ast, env); - } - if (ast.length === 0) { - return ast; - } - - var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; - switch (a0.value) { - case "def!": - var res = EVAL(a2, env); - return env.set(a1, res); - case "let*": - var let_env = new Env(env); - for (var i=0; i < a1.length; i+=2) { - let_env.set(a1[i], EVAL(a1[i+1], let_env)); - } - ast = a2; - env = let_env; - break; - case "quote": - return a1; - case "quasiquote": - ast = quasiquote(a1); - break; - case 'defmacro!': - var func = EVAL(a2, env); - func._ismacro_ = true; - return env.set(a1, func); - case 'macroexpand': - return macroexpand(a1, env); - case "try*": - try { - return EVAL(a1, env); - } catch (exc) { - if (a2 && a2[0].value === "catch*") { - if (exc instanceof Error) { exc = exc.message; } - return EVAL(a2[2], new Env(env, [a2[1]], [exc])); - } else { - throw exc; - } - } - case "do": - eval_ast(ast.slice(1, -1), env); - ast = ast[ast.length-1]; - break; - case "if": - var cond = EVAL(a1, env); - if (cond === null || cond === false) { - ast = (typeof a3 !== "undefined") ? a3 : null; - } else { - ast = a2; - } - break; - case "fn*": - return types._function(EVAL, Env, a2, env, a1); - default: - var el = eval_ast(ast, env), f = el[0]; - if (f.__ast__) { - ast = f.__ast__; - env = f.__gen_env__(el.slice(1)); - } else { - return f.apply(f, el.slice(1)); - } - } - - } -} - -function EVAL(ast, env) { - var result = _EVAL(ast, env); - return (typeof result !== "undefined") ? result : null; -} - -// print -function PRINT(exp) { - return printer._pr_str(exp, true); -} - -// repl -var repl_env = new Env(); -var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; - -// core.js: defined using javascript -for (var n in core.ns) { repl_env.set(types._symbol(n), core.ns[n]); } -repl_env.set(types._symbol('eval'), function(ast) { - return EVAL(ast, repl_env); }); -repl_env.set(types._symbol('*ARGV*'), []); - -// core.mal: defined using the language itself -rep("(def! *host-language* \"javascript\")") -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"); -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("(def! inc (fn* [x] (+ x 1)))"); -rep("(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str \"G__\" (swap! counter inc))))))"); -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)))))))))"); - -if (typeof process !== 'undefined' && process.argv.length > 2) { - repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); - rep('(load-file "' + process.argv[2] + '")'); - process.exit(0); -} - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - rep("(println (str \"Mal [\" *host-language* \"]\"))"); - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +var max_history_length = 1000; + +function jq_load_history(jq) { + if (localStorage['mal_history']) { + var lines = JSON.parse(localStorage['mal_history']); + if (lines.length > max_history_length) { + lines = lines.slice(lines.length-max_history_length); + } + jq.SetHistory(lines); + } +} + +function jq_save_history(jq) { + var lines = jq.GetHistory(); + localStorage['mal_history'] = JSON.stringify(lines); +} + + +var readline = { + 'readline': function(prompt_str) { + return prompt(prompt_str); + }}; + +// Node vs browser behavior +var types = {}; +if (typeof module === 'undefined') { + var exports = types; +} + +// General functions + +function _obj_type(obj) { + if (_symbol_Q(obj)) { return 'symbol'; } + else if (_list_Q(obj)) { return 'list'; } + else if (_vector_Q(obj)) { return 'vector'; } + else if (_hash_map_Q(obj)) { return 'hash-map'; } + else if (_nil_Q(obj)) { return 'nil'; } + else if (_true_Q(obj)) { return 'true'; } + else if (_false_Q(obj)) { return 'false'; } + else if (_atom_Q(obj)) { return 'atom'; } + else { + switch (typeof(obj)) { + case 'number': return 'number'; + case 'function': return 'function'; + case 'string': return obj[0] == '\u029e' ? 'keyword' : 'string'; + default: throw new Error("Unknown type '" + typeof(obj) + "'"); + } + } +} + +function _sequential_Q(lst) { return _list_Q(lst) || _vector_Q(lst); } + + +function _equal_Q (a, b) { + var ota = _obj_type(a), otb = _obj_type(b); + if (!(ota === otb || (_sequential_Q(a) && _sequential_Q(b)))) { + return false; + } + switch (ota) { + case 'symbol': return a.value === b.value; + case 'list': + case 'vector': + if (a.length !== b.length) { return false; } + for (var i=0; i 0 ? obj : null; + } else if (types._vector_Q(obj)) { + return obj.length > 0 ? Array.prototype.slice.call(obj, 0): null; + } else if (types._string_Q(obj)) { + return obj.length > 0 ? obj.split('') : null; + } else if (obj === null) { + return null; + } else { + throw new Error("seq: called on non-sequence"); + } +} + + +function apply(f) { + var args = Array.prototype.slice.call(arguments, 1); + return f.apply(f, args.slice(0, args.length-1).concat(args[args.length-1])); +} + +function map(f, lst) { + return lst.map(function(el){ return f(el); }); +} + + +// Metadata functions +function with_meta(obj, m) { + var new_obj = types._clone(obj); + new_obj.__meta__ = m; + return new_obj; +} + +function meta(obj) { + // TODO: support symbols and atoms + if ((!types._sequential_Q(obj)) && + (!(types._hash_map_Q(obj))) && + (!(types._function_Q(obj)))) { + throw new Error("attempt to get metadata from: " + types._obj_type(obj)); + } + return obj.__meta__; +} + + +// Atom functions +function deref(atm) { return atm.val; } +function reset_BANG(atm, val) { return atm.val = val; } +function swap_BANG(atm, f) { + var args = [atm.val].concat(Array.prototype.slice.call(arguments, 2)); + atm.val = f.apply(f, args); + return atm.val; +} + +function js_eval(str) { + return interop.js_to_mal(eval(str.toString())); +} + +function js_method_call(object_method_str) { + var args = Array.prototype.slice.call(arguments, 1), + r = interop.resolve_js(object_method_str), + obj = r[0], f = r[1]; + var res = f.apply(obj, args); + return interop.js_to_mal(res); +} + +// types.ns is namespace of type functions +var ns = {'type': types._obj_type, + '=': types._equal_Q, + 'throw': mal_throw, + 'nil?': types._nil_Q, + 'true?': types._true_Q, + 'false?': types._false_Q, + 'number?': types._number_Q, + 'string?': types._string_Q, + 'symbol': types._symbol, + 'symbol?': types._symbol_Q, + 'keyword': types._keyword, + 'keyword?': types._keyword_Q, + 'fn?': types._fn_Q, + 'macro?': types._macro_Q, + + 'pr-str': pr_str, + 'str': str, + 'prn': prn, + 'println': println, + 'readline': readline.readline, + 'read-string': reader.read_str, + 'slurp': slurp, + '<' : function(a,b){return a' : function(a,b){return a>b;}, + '>=' : function(a,b){return a>=b;}, + '+' : function(a,b){return a+b;}, + '-' : function(a,b){return a-b;}, + '*' : function(a,b){return a*b;}, + '/' : function(a,b){return a/b;}, + "time-ms": time_ms, + + 'list': types._list, + 'list?': types._list_Q, + 'vector': types._vector, + 'vector?': types._vector_Q, + 'hash-map': types._hash_map, + 'map?': types._hash_map_Q, + 'assoc': assoc, + 'dissoc': dissoc, + 'get': get, + 'contains?': contains_Q, + 'keys': keys, + 'vals': vals, + + 'sequential?': types._sequential_Q, + 'cons': cons, + 'concat': concat, + 'nth': nth, + 'first': first, + 'rest': rest, + 'empty?': empty_Q, + 'count': count, + 'apply': apply, + 'map': map, + + 'conj': conj, + 'seq': seq, + + 'with-meta': with_meta, + 'meta': meta, + 'atom': types._atom, + 'atom?': types._atom_Q, + "deref": deref, + "reset!": reset_BANG, + "swap!": swap_BANG, + + 'js-eval': js_eval, + '.': js_method_call +}; + +exports.ns = core.ns = ns; +if (typeof module !== 'undefined') { +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function is_pair(x) { + return types._sequential_Q(x) && x.length > 0; +} + +function quasiquote(ast) { + if (!is_pair(ast)) { + return [types._symbol("quote"), ast]; + } else if (types._symbol_Q(ast[0]) && ast[0].value === 'unquote') { + return ast[1]; + } else if (is_pair(ast[0]) && ast[0][0].value === 'splice-unquote') { + return [types._symbol("concat"), + ast[0][1], + quasiquote(ast.slice(1))]; + } else { + return [types._symbol("cons"), + quasiquote(ast[0]), + quasiquote(ast.slice(1))]; + } +} + +function is_macro_call(ast, env) { + return types._list_Q(ast) && + types._symbol_Q(ast[0]) && + env.find(ast[0]) && + env.get(ast[0])._ismacro_; +} + +function macroexpand(ast, env) { + while (is_macro_call(ast, env)) { + var mac = env.get(ast[0]); + ast = mac.apply(mac, ast.slice(1)); + } + return ast; +} + +function eval_ast(ast, env) { + if (types._symbol_Q(ast)) { + return env.get(ast); + } else if (types._list_Q(ast)) { + return ast.map(function(a) { return EVAL(a, env); }); + } else if (types._vector_Q(ast)) { + var v = ast.map(function(a) { return EVAL(a, env); }); + v.__isvector__ = true; + return v; + } else if (types._hash_map_Q(ast)) { + var new_hm = {}; + for (k in ast) { + new_hm[EVAL(k, env)] = EVAL(ast[k], env); + } + return new_hm; + } else { + return ast; + } +} + +function _EVAL(ast, env) { + while (true) { + + //printer.println("EVAL:", printer._pr_str(ast, true)); + if (!types._list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + ast = macroexpand(ast, env); + if (!types._list_Q(ast)) { + return eval_ast(ast, env); + } + if (ast.length === 0) { + return ast; + } + + var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; + switch (a0.value) { + case "def!": + var res = EVAL(a2, env); + return env.set(a1, res); + case "let*": + var let_env = new Env(env); + for (var i=0; i < a1.length; i+=2) { + let_env.set(a1[i], EVAL(a1[i+1], let_env)); + } + ast = a2; + env = let_env; + break; + case "quote": + return a1; + case "quasiquote": + ast = quasiquote(a1); + break; + case 'defmacro!': + var func = EVAL(a2, env); + func._ismacro_ = true; + return env.set(a1, func); + case 'macroexpand': + return macroexpand(a1, env); + case "try*": + try { + return EVAL(a1, env); + } catch (exc) { + if (a2 && a2[0].value === "catch*") { + if (exc instanceof Error) { exc = exc.message; } + return EVAL(a2[2], new Env(env, [a2[1]], [exc])); + } else { + throw exc; + } + } + case "do": + eval_ast(ast.slice(1, -1), env); + ast = ast[ast.length-1]; + break; + case "if": + var cond = EVAL(a1, env); + if (cond === null || cond === false) { + ast = (typeof a3 !== "undefined") ? a3 : null; + } else { + ast = a2; + } + break; + case "fn*": + return types._function(EVAL, Env, a2, env, a1); + default: + var el = eval_ast(ast, env), f = el[0]; + if (f.__ast__) { + ast = f.__ast__; + env = f.__gen_env__(el.slice(1)); + } else { + return f.apply(f, el.slice(1)); + } + } + + } +} + +function EVAL(ast, env) { + var result = _EVAL(ast, env); + return (typeof result !== "undefined") ? result : null; +} + +// print +function PRINT(exp) { + return printer._pr_str(exp, true); +} + +// repl +var repl_env = new Env(); +var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; + +// core.js: defined using javascript +for (var n in core.ns) { repl_env.set(types._symbol(n), core.ns[n]); } +repl_env.set(types._symbol('eval'), function(ast) { + return EVAL(ast, repl_env); }); +repl_env.set(types._symbol('*ARGV*'), []); + +// core.mal: defined using the language itself +rep("(def! *host-language* \"javascript\")") +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"); +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("(def! inc (fn* [x] (+ x 1)))"); +rep("(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str \"G__\" (swap! counter inc))))))"); +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)))))))))"); + +if (typeof process !== 'undefined' && process.argv.length > 2) { + repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); + rep('(load-file "' + process.argv[2] + '")'); + process.exit(0); +} + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + rep("(println (str \"Mal [\" *host-language* \"]\"))"); + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/docs/web/skeleton.css b/docs/web/skeleton.css index 31e2a618c8..cb2c423163 100644 --- a/docs/web/skeleton.css +++ b/docs/web/skeleton.css @@ -1,237 +1,237 @@ -/* -* Skeleton V1.0.2 -* Copyright 2011, Dave Gamache -* www.getskeleton.com -* Free to use under the MIT license. -* http://www.opensource.org/licenses/mit-license.php -* 5/20/2011 -*/ - - -/* Table of Contents -================================================== - #Base 960 Grid - #Tablet (Portrait) - #Mobile (Portrait) - #Mobile (Landscape) - #Clearing */ - - - -/* #Base 960 Grid -================================================== */ - - .container { position: relative; width: 960px; margin: 30px auto; padding: 0; } - .column, .columns { float: left; display: inline; margin-left: 10px; margin-right: 10px; } - .row { margin-bottom: 20px; } - - /* Nested Column Classes */ - .column.alpha, .columns.alpha { margin-left: 0; } - .column.omega, .columns.omega { margin-right: 0; } - - /* Base Grid */ - .container .one.column { width: 40px; } - .container .two.columns { width: 100px; } - .container .three.columns { width: 160px; } - .container .four.columns { width: 220px; } - .container .five.columns { width: 280px; } - .container .six.columns { width: 340px; } - .container .seven.columns { width: 400px; } - .container .eight.columns { width: 460px; } - .container .nine.columns { width: 520px; } - .container .ten.columns { width: 580px; } - .container .eleven.columns { width: 640px; } - .container .twelve.columns { width: 700px; } - .container .thirteen.columns { width: 760px; } - .container .fourteen.columns { width: 820px; } - .container .fifteen.columns { width: 880px; } - .container .sixteen.columns { width: 940px; } - - .container .one-third.column { width: 300px; } - .container .two-thirds.column { width: 620px; } - - /* Offsets */ - .container .offset-by-one { padding-left: 60px; } - .container .offset-by-two { padding-left: 120px; } - .container .offset-by-three { padding-left: 180px; } - .container .offset-by-four { padding-left: 240px; } - .container .offset-by-five { padding-left: 300px; } - .container .offset-by-six { padding-left: 360px; } - .container .offset-by-seven { padding-left: 420px; } - .container .offset-by-eight { padding-left: 480px; } - .container .offset-by-nine { padding-left: 540px; } - .container .offset-by-ten { padding-left: 600px; } - .container .offset-by-eleven { padding-left: 660px; } - .container .offset-by-twelve { padding-left: 720px; } - .container .offset-by-thirteen { padding-left: 780px; } - .container .offset-by-fourteen { padding-left: 840px; } - .container .offset-by-fifteen { padding-left: 900px; } - - - -/* #Tablet (Portrait) -================================================== */ - - /* Note: Design for a width of 768px */ - - @media only screen and (min-width: 768px) and (max-width: 959px) { - .container { width: 768px; } - .container .column, - .container .columns { margin-left: 10px; margin-right: 10px; } - .column.alpha, .columns.alpha { margin-left: 0; margin-right: 10px; } - .column.omega, .columns.omega { margin-right: 0; margin-left: 10px; } - - .container .one.column { width: 28px; } - .container .two.columns { width: 76px; } - .container .three.columns { width: 124px; } - .container .four.columns { width: 172px; } - .container .five.columns { width: 220px; } - .container .six.columns { width: 268px; } - .container .seven.columns { width: 316px; } - .container .eight.columns { width: 364px; } - .container .nine.columns { width: 412px; } - .container .ten.columns { width: 460px; } - .container .eleven.columns { width: 508px; } - .container .twelve.columns { width: 556px; } - .container .thirteen.columns { width: 604px; } - .container .fourteen.columns { width: 652px; } - .container .fifteen.columns { width: 700px; } - .container .sixteen.columns { width: 748px; } - - .container .one-third.column { width: 236px; } - .container .two-thirds.column { width: 492px; } - - /* Offsets */ - .container .offset-by-one { padding-left: 48px; } - .container .offset-by-two { padding-left: 96px; } - .container .offset-by-three { padding-left: 144px; } - .container .offset-by-four { padding-left: 192px; } - .container .offset-by-five { padding-left: 288px; } - .container .offset-by-six { padding-left: 336px; } - .container .offset-by-seven { padding-left: 348px; } - .container .offset-by-eight { padding-left: 432px; } - .container .offset-by-nine { padding-left: 480px; } - .container .offset-by-ten { padding-left: 528px; } - .container .offset-by-eleven { padding-left: 576px; } - .container .offset-by-twelve { padding-left: 624px; } - .container .offset-by-thirteen { padding-left: 672px; } - .container .offset-by-fourteen { padding-left: 720px; } - .container .offset-by-fifteen { padding-left: 900px; } - } - - -/* #Mobile (Portrait) -================================================== */ - - /* Note: Design for a width of 320px */ - - @media only screen and (max-width: 767px) { - .container { width: 300px; } - .columns, .column { margin: 0; } - - .container .one.column, - .container .two.columns, - .container .three.columns, - .container .four.columns, - .container .five.columns, - .container .six.columns, - .container .seven.columns, - .container .eight.columns, - .container .nine.columns, - .container .ten.columns, - .container .eleven.columns, - .container .twelve.columns, - .container .thirteen.columns, - .container .fourteen.columns, - .container .fifteen.columns, - .container .sixteen.columns, - .container .one-third.column, - .container .two-thirds.column { width: 300px; } - - /* Offsets */ - .container .offset-by-one, - .container .offset-by-two, - .container .offset-by-three, - .container .offset-by-four, - .container .offset-by-five, - .container .offset-by-six, - .container .offset-by-seven, - .container .offset-by-eight, - .container .offset-by-nine, - .container .offset-by-ten, - .container .offset-by-eleven, - .container .offset-by-twelve, - .container .offset-by-thirteen, - .container .offset-by-fourteen, - .container .offset-by-fifteen { padding-left: 0; } - - } - - -/* #Mobile (Landscape) -================================================== */ - - /* Note: Design for a width of 480px */ - - @media only screen and (min-width: 480px) and (max-width: 767px) { - .container { width: 420px; } - .columns, .column { margin: 0; } - - .container .one.column, - .container .two.columns, - .container .three.columns, - .container .four.columns, - .container .five.columns, - .container .six.columns, - .container .seven.columns, - .container .eight.columns, - .container .nine.columns, - .container .ten.columns, - .container .eleven.columns, - .container .twelve.columns, - .container .thirteen.columns, - .container .fourteen.columns, - .container .fifteen.columns, - .container .sixteen.columns, - .container .one-third.column, - .container .two-thirds.column { width: 420px; } - } - - -/* #Clearing -================================================== */ - - /* Self Clearing Goodness */ - .container:after { content: "\0020"; display: block; height: 0; clear: both; visibility: hidden; } - - /* Use clearfix class on parent to clear nested columns, - or wrap each row of columns in a
*/ - .clearfix:before, - .clearfix:after, - .row:before, - .row:after { - content: '\0020'; - display: block; - overflow: hidden; - visibility: hidden; - width: 0; - height: 0; } - .row:after, - .clearfix:after { - clear: both; } - .row, - .clearfix { - zoom: 1; } - - /* You can also use a
to clear columns */ - .clear { - clear: both; - display: block; - overflow: hidden; - visibility: hidden; - width: 0; - height: 0; - } - - +/* +* Skeleton V1.0.2 +* Copyright 2011, Dave Gamache +* www.getskeleton.com +* Free to use under the MIT license. +* http://www.opensource.org/licenses/mit-license.php +* 5/20/2011 +*/ + + +/* Table of Contents +================================================== + #Base 960 Grid + #Tablet (Portrait) + #Mobile (Portrait) + #Mobile (Landscape) + #Clearing */ + + + +/* #Base 960 Grid +================================================== */ + + .container { position: relative; width: 960px; margin: 30px auto; padding: 0; } + .column, .columns { float: left; display: inline; margin-left: 10px; margin-right: 10px; } + .row { margin-bottom: 20px; } + + /* Nested Column Classes */ + .column.alpha, .columns.alpha { margin-left: 0; } + .column.omega, .columns.omega { margin-right: 0; } + + /* Base Grid */ + .container .one.column { width: 40px; } + .container .two.columns { width: 100px; } + .container .three.columns { width: 160px; } + .container .four.columns { width: 220px; } + .container .five.columns { width: 280px; } + .container .six.columns { width: 340px; } + .container .seven.columns { width: 400px; } + .container .eight.columns { width: 460px; } + .container .nine.columns { width: 520px; } + .container .ten.columns { width: 580px; } + .container .eleven.columns { width: 640px; } + .container .twelve.columns { width: 700px; } + .container .thirteen.columns { width: 760px; } + .container .fourteen.columns { width: 820px; } + .container .fifteen.columns { width: 880px; } + .container .sixteen.columns { width: 940px; } + + .container .one-third.column { width: 300px; } + .container .two-thirds.column { width: 620px; } + + /* Offsets */ + .container .offset-by-one { padding-left: 60px; } + .container .offset-by-two { padding-left: 120px; } + .container .offset-by-three { padding-left: 180px; } + .container .offset-by-four { padding-left: 240px; } + .container .offset-by-five { padding-left: 300px; } + .container .offset-by-six { padding-left: 360px; } + .container .offset-by-seven { padding-left: 420px; } + .container .offset-by-eight { padding-left: 480px; } + .container .offset-by-nine { padding-left: 540px; } + .container .offset-by-ten { padding-left: 600px; } + .container .offset-by-eleven { padding-left: 660px; } + .container .offset-by-twelve { padding-left: 720px; } + .container .offset-by-thirteen { padding-left: 780px; } + .container .offset-by-fourteen { padding-left: 840px; } + .container .offset-by-fifteen { padding-left: 900px; } + + + +/* #Tablet (Portrait) +================================================== */ + + /* Note: Design for a width of 768px */ + + @media only screen and (min-width: 768px) and (max-width: 959px) { + .container { width: 768px; } + .container .column, + .container .columns { margin-left: 10px; margin-right: 10px; } + .column.alpha, .columns.alpha { margin-left: 0; margin-right: 10px; } + .column.omega, .columns.omega { margin-right: 0; margin-left: 10px; } + + .container .one.column { width: 28px; } + .container .two.columns { width: 76px; } + .container .three.columns { width: 124px; } + .container .four.columns { width: 172px; } + .container .five.columns { width: 220px; } + .container .six.columns { width: 268px; } + .container .seven.columns { width: 316px; } + .container .eight.columns { width: 364px; } + .container .nine.columns { width: 412px; } + .container .ten.columns { width: 460px; } + .container .eleven.columns { width: 508px; } + .container .twelve.columns { width: 556px; } + .container .thirteen.columns { width: 604px; } + .container .fourteen.columns { width: 652px; } + .container .fifteen.columns { width: 700px; } + .container .sixteen.columns { width: 748px; } + + .container .one-third.column { width: 236px; } + .container .two-thirds.column { width: 492px; } + + /* Offsets */ + .container .offset-by-one { padding-left: 48px; } + .container .offset-by-two { padding-left: 96px; } + .container .offset-by-three { padding-left: 144px; } + .container .offset-by-four { padding-left: 192px; } + .container .offset-by-five { padding-left: 288px; } + .container .offset-by-six { padding-left: 336px; } + .container .offset-by-seven { padding-left: 348px; } + .container .offset-by-eight { padding-left: 432px; } + .container .offset-by-nine { padding-left: 480px; } + .container .offset-by-ten { padding-left: 528px; } + .container .offset-by-eleven { padding-left: 576px; } + .container .offset-by-twelve { padding-left: 624px; } + .container .offset-by-thirteen { padding-left: 672px; } + .container .offset-by-fourteen { padding-left: 720px; } + .container .offset-by-fifteen { padding-left: 900px; } + } + + +/* #Mobile (Portrait) +================================================== */ + + /* Note: Design for a width of 320px */ + + @media only screen and (max-width: 767px) { + .container { width: 300px; } + .columns, .column { margin: 0; } + + .container .one.column, + .container .two.columns, + .container .three.columns, + .container .four.columns, + .container .five.columns, + .container .six.columns, + .container .seven.columns, + .container .eight.columns, + .container .nine.columns, + .container .ten.columns, + .container .eleven.columns, + .container .twelve.columns, + .container .thirteen.columns, + .container .fourteen.columns, + .container .fifteen.columns, + .container .sixteen.columns, + .container .one-third.column, + .container .two-thirds.column { width: 300px; } + + /* Offsets */ + .container .offset-by-one, + .container .offset-by-two, + .container .offset-by-three, + .container .offset-by-four, + .container .offset-by-five, + .container .offset-by-six, + .container .offset-by-seven, + .container .offset-by-eight, + .container .offset-by-nine, + .container .offset-by-ten, + .container .offset-by-eleven, + .container .offset-by-twelve, + .container .offset-by-thirteen, + .container .offset-by-fourteen, + .container .offset-by-fifteen { padding-left: 0; } + + } + + +/* #Mobile (Landscape) +================================================== */ + + /* Note: Design for a width of 480px */ + + @media only screen and (min-width: 480px) and (max-width: 767px) { + .container { width: 420px; } + .columns, .column { margin: 0; } + + .container .one.column, + .container .two.columns, + .container .three.columns, + .container .four.columns, + .container .five.columns, + .container .six.columns, + .container .seven.columns, + .container .eight.columns, + .container .nine.columns, + .container .ten.columns, + .container .eleven.columns, + .container .twelve.columns, + .container .thirteen.columns, + .container .fourteen.columns, + .container .fifteen.columns, + .container .sixteen.columns, + .container .one-third.column, + .container .two-thirds.column { width: 420px; } + } + + +/* #Clearing +================================================== */ + + /* Self Clearing Goodness */ + .container:after { content: "\0020"; display: block; height: 0; clear: both; visibility: hidden; } + + /* Use clearfix class on parent to clear nested columns, + or wrap each row of columns in a
*/ + .clearfix:before, + .clearfix:after, + .row:before, + .row:after { + content: '\0020'; + display: block; + overflow: hidden; + visibility: hidden; + width: 0; + height: 0; } + .row:after, + .clearfix:after { + clear: both; } + .row, + .clearfix { + zoom: 1; } + + /* You can also use a
to clear columns */ + .clear { + clear: both; + display: block; + overflow: hidden; + visibility: hidden; + width: 0; + height: 0; + } + + \ No newline at end of file diff --git a/examples/clojurewest2014.mal b/examples/clojurewest2014.mal index c88afe2d69..7d4ed06f09 100755 --- a/examples/clojurewest2014.mal +++ b/examples/clojurewest2014.mal @@ -1,126 +1,126 @@ -;; Mal Presentation - -(def! clear - (fn* () - (str ""))) - -(def! bold - (fn* (s) - (str "" s ""))) - -(def! blue - (fn* (s) - (str "" s ""))) - -(def! title - (fn* (s) - (bold (blue (str s "\n"))))) - -(def! title2 - (fn* (s) - (bold (blue s)))) - - -(def! conj-slides - (list - (list - (title2 " __ __ _ _") - (title2 "| \\/ | / \\ | |") - (title2 "| |\\/| | / _ \\ | | ") - (title2 "| | | |/ ___ \\| |___ ") - (title2 "|_| |_/_/ \\_\\_____|")) - (list - (title "gherkin") - "- a lisp1 written in bash4") - (list - (title "mal - an interpreter for a subset of Clojure")) - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4" - "- and Javascript") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4" - "- and Javascript" - "- and Python") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4" - "- and Javascript" - "- and Python" - "- and Clojure") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4" - "- and Javascript" - "- and Python" - "- and Clojure" - "- and C and Java and PHP") - (list - (title "things it has") - "- scalars: integers, strings, symbols, nil, true, false" - "- immutable collections: lists, vectors, hash-maps" - "- metadata, atoms" - "- def!, fn*, let*" - " - varargs: (fn* (x y & more) ...)" - "- tail call optimization" - " - except GNU make implementation (no iteration)" - "- macros (quote, unquote, quasiquote, splice-quote)" - "- almost 300 unit tests" - "- REPL with readline (GNU readline or libedit)") - (list - (title "things it does not have") - "- performance" - "- namespaces" - "- keywords" - "- GC (in bash, make, C implementations)" - "- lots of other things") - (list - (title "why?") - "- because!") - (list - (title "why?") - "- because!" - "- gherkin was an inspiration to higher levels of crazy" - "- evolved into learning tool" - "- way to learn about Lisp and also the target language" - "- each implementation broken into small 10 steps") - (list - (title "thanks to:") - "- Peter Norvig: inspiration: lispy" - " - http://norvig.com/lispy.html" - "- Alan Dipert: gherkin, original gherkin slides" - " - https://github.com/alandipert/gherkin") - (list - (title "mal - Make a Lisp") - "https://github.com/kanaka/mal") - (list - (title "demo")))) - -(def! present - (fn* (slides) - (if (> (count slides) 0) - (do - ;;(py!* "import os; r = os.system('clear')") - ;;(sh* "clear") - ;;(make* "$(shell clear)") - (println (clear)) - - ;;(prn (first slides)) - (apply println (map (fn* (line) (str "\n " line)) (first slides))) - (println "\n\n\n") - (readline "") - (present (rest slides)))))) - -(present conj-slides) +;; Mal Presentation + +(def! clear + (fn* () + (str ""))) + +(def! bold + (fn* (s) + (str "" s ""))) + +(def! blue + (fn* (s) + (str "" s ""))) + +(def! title + (fn* (s) + (bold (blue (str s "\n"))))) + +(def! title2 + (fn* (s) + (bold (blue s)))) + + +(def! conj-slides + (list + (list + (title2 " __ __ _ _") + (title2 "| \\/ | / \\ | |") + (title2 "| |\\/| | / _ \\ | | ") + (title2 "| | | |/ ___ \\| |___ ") + (title2 "|_| |_/_/ \\_\\_____|")) + (list + (title "gherkin") + "- a lisp1 written in bash4") + (list + (title "mal - an interpreter for a subset of Clojure")) + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4" + "- and Javascript") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4" + "- and Javascript" + "- and Python") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4" + "- and Javascript" + "- and Python" + "- and Clojure") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4" + "- and Javascript" + "- and Python" + "- and Clojure" + "- and C and Java and PHP") + (list + (title "things it has") + "- scalars: integers, strings, symbols, nil, true, false" + "- immutable collections: lists, vectors, hash-maps" + "- metadata, atoms" + "- def!, fn*, let*" + " - varargs: (fn* (x y & more) ...)" + "- tail call optimization" + " - except GNU make implementation (no iteration)" + "- macros (quote, unquote, quasiquote, splice-quote)" + "- almost 300 unit tests" + "- REPL with readline (GNU readline or libedit)") + (list + (title "things it does not have") + "- performance" + "- namespaces" + "- keywords" + "- GC (in bash, make, C implementations)" + "- lots of other things") + (list + (title "why?") + "- because!") + (list + (title "why?") + "- because!" + "- gherkin was an inspiration to higher levels of crazy" + "- evolved into learning tool" + "- way to learn about Lisp and also the target language" + "- each implementation broken into small 10 steps") + (list + (title "thanks to:") + "- Peter Norvig: inspiration: lispy" + " - http://norvig.com/lispy.html" + "- Alan Dipert: gherkin, original gherkin slides" + " - https://github.com/alandipert/gherkin") + (list + (title "mal - Make a Lisp") + "https://github.com/kanaka/mal") + (list + (title "demo")))) + +(def! present + (fn* (slides) + (if (> (count slides) 0) + (do + ;;(py!* "import os; r = os.system('clear')") + ;;(sh* "clear") + ;;(make* "$(shell clear)") + (println (clear)) + + ;;(prn (first slides)) + (apply println (map (fn* (line) (str "\n " line)) (first slides))) + (println "\n\n\n") + (readline "") + (present (rest slides)))))) + +(present conj-slides) diff --git a/examples/exercises.mal b/examples/exercises.mal index babdfc7e67..5eea8fbca2 100644 --- a/examples/exercises.mal +++ b/examples/exercises.mal @@ -1,163 +1,163 @@ -;; These are the answers to the questions in ../docs/exercise.md. - -;; In order to avoid unexpected circular dependencies among solutions, -;; this answer file attempts to be self-contained. -(def! reduce (fn* (f init xs) - (if (empty? xs) init (reduce f (f init (first xs)) (rest xs))))) -(def! foldr (fn* [f init xs] - (if (empty? xs) init (f (first xs) (foldr f init (rest xs)))))) - -;; Reimplementations. - -(def! nil? (fn* [x] (= x nil ))) -(def! true? (fn* [x] (= x true ))) -(def! false? (fn* [x] (= x false))) -(def! empty? (fn* [x] (= x [] ))) - -(def! sequential? - (fn* [x] - (if (list? x) true (vector? x)))) - -(def! > (fn* [a b] (< b a) )) -(def! <= (fn* [a b] (not (< b a)))) -(def! >= (fn* [a b] (not (< a b)))) - -(def! list (fn* [& xs] xs)) -(def! vec (fn* [xs] (apply vector xs))) -(def! prn (fn* [& xs] (println (apply pr-str xs)))) -(def! hash-map (fn* [& xs] (apply assoc {} xs))) -(def! swap! (fn* [a f & xs] (reset! a (apply f (deref a) xs)))) - -(def! count - (fn* [xs] - (if (nil? xs) - 0 - (reduce (fn* [acc _] (+ 1 acc)) 0 xs)))) -(def! nth - (fn* [xs index] - (if (if (<= 0 index) (not (empty? xs))) ; logical and - (if (= 0 index) - (first xs) - (nth (rest xs) (- index 1))) - (throw "nth: index out of range")))) -(def! map - (fn* [f xs] - (foldr (fn* [x acc] (cons (f x) acc)) () xs))) -(def! concat - (fn* [& xs] - (foldr (fn* [x acc] (foldr cons acc x)) () xs))) -(def! conj - (fn* [xs & ys] - (if (vector? xs) - (vec (concat xs ys)) - (reduce (fn* [acc x] (cons x acc)) xs ys)))) - -(def! do2 (fn* [& xs] (nth xs (- (count xs) 1)))) -(def! do3 (fn* [& xs] (reduce (fn* [_ x] x) nil xs))) -;; do2 will probably be more efficient when lists are implemented as -;; arrays with direct indexing, but when they are implemented as -;; linked lists, do3 may win because it only does one traversal. - -(defmacro! quote2 (fn* [ast] - (list (fn* [] ast)))) -(def! _quasiquote_iter (fn* [x acc] - (if (if (list? x) (= (first x) 'splice-unquote)) ; logical and - (list 'concat (first (rest x)) acc) - (list 'cons (list 'quasiquote2 x) acc)))) -(defmacro! quasiquote2 (fn* [ast] - (if (list? ast) - (if (= (first ast) 'unquote) - (first (rest ast)) - (foldr _quasiquote_iter () ast)) - (if (vector? ast) - (list 'vec (foldr _quasiquote_iter () ast)) - (list 'quote ast))))) - -;; Interpret kvs as [k1 v1 k2 v2 ... kn vn] and returns -;; (f k1 v1 (f k2 v2 (f ... (f kn vn)))). -(def! _foldr_pairs (fn* [f init kvs] - (if (empty? kvs) - init - (let* [key (first kvs) - rst (rest kvs) - val (first rst) - acc (_foldr_pairs f init (rest rst))] - (f key val acc))))) -(defmacro! let*A (fn* [binds form] - (let* [formal (_foldr_pairs (fn* [key val acc] (cons key acc)) () binds) - actual (_foldr_pairs (fn* [key val acc] (cons val acc)) () binds)] - `((fn* ~formal ~form) ~@actual)))) -;; Fails for (let* [a 1 b (+ 1 a)] b) -(defmacro! let*B (fn* [binds form] - (let* [f (fn* [key val acc] - `((fn* [~key] ~acc) ~val))] - (_foldr_pairs f form binds)))) -;; Fails for (let* (cst (fn* (n) (if (= n 0) nil (cst (- n 1))))) (cst 1)) -(def! _c_combinator (fn* [x] (x x))) -(def! _d_combinator (fn* [f] (fn* [x] (f (fn* [v] ((x x) v)))))) -(def! _Y_combinator (fn* [x] (_c_combinator (_d_combinator x)))) -(defmacro! let*C (fn* [binds form] - (let* [f (fn* [key val acc] - `((fn* [~key] ~acc) (_Y_combinator (fn* [~key] ~val))))] - (_foldr_pairs f form binds)))) -;; Fails for mutual recursion. -;; See http://okmij.org/ftp/Computation/fixed-point-combinators.html -;; if you are motivated to implement solution D. - -(def! apply - ;; Replace (f a b [c d]) with ('f 'a 'b 'c 'd) then evaluate the - ;; resulting function call (the surrounding environment does not - ;; matter when evaluating a function call). - ;; Use nil as marker to detect deepest recursive call. - (let* [q (fn* [x] (list 'quote x)) - iter (fn* [x acc] - (if (nil? acc) ; x is the last element (a sequence) - (map q x) - (cons (q x) acc)))] - (fn* [& xs] (eval (foldr iter nil xs))))) - -;; Folds - -(def! sum (fn* [xs] (reduce + 0 xs))) -(def! product (fn* [xs] (reduce * 1 xs))) - -(def! conjunction - (let* [and2 (fn* [acc x] (if acc x false))] - (fn* [xs] - (reduce and2 true xs)))) -(def! disjunction - (let* [or2 (fn* [acc x] (if acc true x))] - (fn* [xs] - (reduce or2 false xs)))) -;; It would be faster to stop the iteration on first failure -;; (conjunction) or success (disjunction). Even better, `or` in the -;; stepA and `and` in `core.mal` stop evaluating their arguments. - -;; Yes, -2-3-4 means (((0-2)-3)-4). - -;; `(reduce str "" xs)` is equivalent to `apply str xs` -;; and `(reduce concat () xs)` is equivalent to `apply concat xs`. -;; The built-in iterations are probably faster. - -;; `(reduce (fn* [acc _] acc) nil xs)` is equivalent to `nil`. - -;; For (reduce (fn* [acc x] x) nil xs))), see do3 above. - -;; `(reduce (fn* [acc x] (if (< acc x) x acc)) 0 xs)` computes the -;; maximum of a list of non-negative integers. It is hard to find an -;; initial value fitting all purposes. - -(def! sum_len - (let* [add_len (fn* [acc x] (+ acc (count x)))] - (fn* [xs] - (reduce add_len 0 xs)))) -(def! max_len - (let* [update_max (fn* [acc x] (let* [l (count x)] (if (< acc l) l acc)))] - (fn* [xs] - (reduce update_max 0 xs)))) - -;; (fn* [& fs] (foldr (fn* [f acc] (fn* [x] (f (acc x)))) identity fs)) -;; computes the composition of an arbitrary number of functions. -;; The first anonymous function is the mathematical composition. -;; For practical purposes, `->` and `->>` in `core.mal` are more -;; efficient and general. +;; These are the answers to the questions in ../docs/exercise.md. + +;; In order to avoid unexpected circular dependencies among solutions, +;; this answer file attempts to be self-contained. +(def! reduce (fn* (f init xs) + (if (empty? xs) init (reduce f (f init (first xs)) (rest xs))))) +(def! foldr (fn* [f init xs] + (if (empty? xs) init (f (first xs) (foldr f init (rest xs)))))) + +;; Reimplementations. + +(def! nil? (fn* [x] (= x nil ))) +(def! true? (fn* [x] (= x true ))) +(def! false? (fn* [x] (= x false))) +(def! empty? (fn* [x] (= x [] ))) + +(def! sequential? + (fn* [x] + (if (list? x) true (vector? x)))) + +(def! > (fn* [a b] (< b a) )) +(def! <= (fn* [a b] (not (< b a)))) +(def! >= (fn* [a b] (not (< a b)))) + +(def! list (fn* [& xs] xs)) +(def! vec (fn* [xs] (apply vector xs))) +(def! prn (fn* [& xs] (println (apply pr-str xs)))) +(def! hash-map (fn* [& xs] (apply assoc {} xs))) +(def! swap! (fn* [a f & xs] (reset! a (apply f (deref a) xs)))) + +(def! count + (fn* [xs] + (if (nil? xs) + 0 + (reduce (fn* [acc _] (+ 1 acc)) 0 xs)))) +(def! nth + (fn* [xs index] + (if (if (<= 0 index) (not (empty? xs))) ; logical and + (if (= 0 index) + (first xs) + (nth (rest xs) (- index 1))) + (throw "nth: index out of range")))) +(def! map + (fn* [f xs] + (foldr (fn* [x acc] (cons (f x) acc)) () xs))) +(def! concat + (fn* [& xs] + (foldr (fn* [x acc] (foldr cons acc x)) () xs))) +(def! conj + (fn* [xs & ys] + (if (vector? xs) + (vec (concat xs ys)) + (reduce (fn* [acc x] (cons x acc)) xs ys)))) + +(def! do2 (fn* [& xs] (nth xs (- (count xs) 1)))) +(def! do3 (fn* [& xs] (reduce (fn* [_ x] x) nil xs))) +;; do2 will probably be more efficient when lists are implemented as +;; arrays with direct indexing, but when they are implemented as +;; linked lists, do3 may win because it only does one traversal. + +(defmacro! quote2 (fn* [ast] + (list (fn* [] ast)))) +(def! _quasiquote_iter (fn* [x acc] + (if (if (list? x) (= (first x) 'splice-unquote)) ; logical and + (list 'concat (first (rest x)) acc) + (list 'cons (list 'quasiquote2 x) acc)))) +(defmacro! quasiquote2 (fn* [ast] + (if (list? ast) + (if (= (first ast) 'unquote) + (first (rest ast)) + (foldr _quasiquote_iter () ast)) + (if (vector? ast) + (list 'vec (foldr _quasiquote_iter () ast)) + (list 'quote ast))))) + +;; Interpret kvs as [k1 v1 k2 v2 ... kn vn] and returns +;; (f k1 v1 (f k2 v2 (f ... (f kn vn)))). +(def! _foldr_pairs (fn* [f init kvs] + (if (empty? kvs) + init + (let* [key (first kvs) + rst (rest kvs) + val (first rst) + acc (_foldr_pairs f init (rest rst))] + (f key val acc))))) +(defmacro! let*A (fn* [binds form] + (let* [formal (_foldr_pairs (fn* [key val acc] (cons key acc)) () binds) + actual (_foldr_pairs (fn* [key val acc] (cons val acc)) () binds)] + `((fn* ~formal ~form) ~@actual)))) +;; Fails for (let* [a 1 b (+ 1 a)] b) +(defmacro! let*B (fn* [binds form] + (let* [f (fn* [key val acc] + `((fn* [~key] ~acc) ~val))] + (_foldr_pairs f form binds)))) +;; Fails for (let* (cst (fn* (n) (if (= n 0) nil (cst (- n 1))))) (cst 1)) +(def! _c_combinator (fn* [x] (x x))) +(def! _d_combinator (fn* [f] (fn* [x] (f (fn* [v] ((x x) v)))))) +(def! _Y_combinator (fn* [x] (_c_combinator (_d_combinator x)))) +(defmacro! let*C (fn* [binds form] + (let* [f (fn* [key val acc] + `((fn* [~key] ~acc) (_Y_combinator (fn* [~key] ~val))))] + (_foldr_pairs f form binds)))) +;; Fails for mutual recursion. +;; See http://okmij.org/ftp/Computation/fixed-point-combinators.html +;; if you are motivated to implement solution D. + +(def! apply + ;; Replace (f a b [c d]) with ('f 'a 'b 'c 'd) then evaluate the + ;; resulting function call (the surrounding environment does not + ;; matter when evaluating a function call). + ;; Use nil as marker to detect deepest recursive call. + (let* [q (fn* [x] (list 'quote x)) + iter (fn* [x acc] + (if (nil? acc) ; x is the last element (a sequence) + (map q x) + (cons (q x) acc)))] + (fn* [& xs] (eval (foldr iter nil xs))))) + +;; Folds + +(def! sum (fn* [xs] (reduce + 0 xs))) +(def! product (fn* [xs] (reduce * 1 xs))) + +(def! conjunction + (let* [and2 (fn* [acc x] (if acc x false))] + (fn* [xs] + (reduce and2 true xs)))) +(def! disjunction + (let* [or2 (fn* [acc x] (if acc true x))] + (fn* [xs] + (reduce or2 false xs)))) +;; It would be faster to stop the iteration on first failure +;; (conjunction) or success (disjunction). Even better, `or` in the +;; stepA and `and` in `core.mal` stop evaluating their arguments. + +;; Yes, -2-3-4 means (((0-2)-3)-4). + +;; `(reduce str "" xs)` is equivalent to `apply str xs` +;; and `(reduce concat () xs)` is equivalent to `apply concat xs`. +;; The built-in iterations are probably faster. + +;; `(reduce (fn* [acc _] acc) nil xs)` is equivalent to `nil`. + +;; For (reduce (fn* [acc x] x) nil xs))), see do3 above. + +;; `(reduce (fn* [acc x] (if (< acc x) x acc)) 0 xs)` computes the +;; maximum of a list of non-negative integers. It is hard to find an +;; initial value fitting all purposes. + +(def! sum_len + (let* [add_len (fn* [acc x] (+ acc (count x)))] + (fn* [xs] + (reduce add_len 0 xs)))) +(def! max_len + (let* [update_max (fn* [acc x] (let* [l (count x)] (if (< acc l) l acc)))] + (fn* [xs] + (reduce update_max 0 xs)))) + +;; (fn* [& fs] (foldr (fn* [f acc] (fn* [x] (f (acc x)))) identity fs)) +;; computes the composition of an arbitrary number of functions. +;; The first anonymous function is the mathematical composition. +;; For practical purposes, `->` and `->>` in `core.mal` are more +;; efficient and general. diff --git a/examples/hello.mal b/examples/hello.mal index 165efc4f65..d52d5c172d 100644 --- a/examples/hello.mal +++ b/examples/hello.mal @@ -1,2 +1,2 @@ -(println "hello world\n\nanother line") -(println "and another line") +(println "hello world\n\nanother line") +(println "and another line") diff --git a/examples/presentation.mal b/examples/presentation.mal index 4e0c3383bc..d09a4e3bc5 100755 --- a/examples/presentation.mal +++ b/examples/presentation.mal @@ -1,122 +1,122 @@ -;; Mal Presentation - -(def! clear - (fn* () - (str ""))) - -(def! bold - (fn* (s) - (str "" s ""))) - -(def! blue - (fn* (s) - (str "" s ""))) - -(def! title - (fn* (s) - (bold (blue (str s "\n"))))) - -(def! title2 - (fn* (s) - (bold (blue s)))) - - -(def! slides - (list - (list - (title2 " __ __ _ _") - (title2 "| \/ | / \ | |") - (title2 "| |\/| | / _ \ | | ") - (title2 "| | | |/ ___ \| |___ ") - (title2 "|_| |_/_/ \_\_____|")) - (list - (title "gherkin") - "- a lisp1 written in bash4") - (list - (title "mal - an interpreter for a subset of Clojure")) - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4" - "- and Javascript") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4" - "- and Javascript" - "- and Python") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4" - "- and Javascript" - "- and Python" - "- and Clojure") - (list - (title "mal - an interpreter for a subset of Clojure") - "- written in GNU make" - "- and Bash 4" - "- and Javascript" - "- and Python" - "- and Clojure" - "- and 17 other languages") - (list - (title "things it has") - "- scalars: integers, strings, symbols, keywords, nil, true, false" - "- immutable collections: lists, vectors, hash-maps" - "- metadata, atoms" - "- def!, fn*, let*" - " - varargs: (fn* (x y & more) ...)" - "- tail call optimization" - " - except GNU make implementation (no iteration)" - "- macros (quote, unquote, quasiquote, splice-quote)" - "- over 500 unit tests" - "- REPL with line editing (GNU readline/libedit/linenoise)") - (list - (title "things it does not have") - "- performance" - "- namespaces" - "- GC (in bash, make, C implementations)" - "- protocols :-(" - "- lots of other things") - (list - (title "why?") - "- because!") - (list - (title "why?") - "- because!" - "- gherkin was an inspiration to higher levels of crazy" - "- evolved into learning tool" - "- way to learn about Lisp and also the target language" - "- each implementation broken into small 11 steps") - (list - (title "thanks to:") - "- Peter Norvig: inspiration: lispy" - " - http://norvig.com/lispy.html" - "- Alan Dipert: gherkin, original gherkin slides" - " - https://github.com/alandipert/gherkin") - (list - (title "mal - Make a Lisp") - "https://github.com/kanaka/mal") - (list - (title "demo")))) - -(def! present - (fn* (slides) - (if (> (count slides) 0) - (do - (println (clear)) - - (apply println (map (fn* (line) (str "\n " line)) (first slides))) - (println "\n\n\n") - (readline "") - (present (rest slides)))))) - -(present slides) +;; Mal Presentation + +(def! clear + (fn* () + (str ""))) + +(def! bold + (fn* (s) + (str "" s ""))) + +(def! blue + (fn* (s) + (str "" s ""))) + +(def! title + (fn* (s) + (bold (blue (str s "\n"))))) + +(def! title2 + (fn* (s) + (bold (blue s)))) + + +(def! slides + (list + (list + (title2 " __ __ _ _") + (title2 "| \/ | / \ | |") + (title2 "| |\/| | / _ \ | | ") + (title2 "| | | |/ ___ \| |___ ") + (title2 "|_| |_/_/ \_\_____|")) + (list + (title "gherkin") + "- a lisp1 written in bash4") + (list + (title "mal - an interpreter for a subset of Clojure")) + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4" + "- and Javascript") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4" + "- and Javascript" + "- and Python") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4" + "- and Javascript" + "- and Python" + "- and Clojure") + (list + (title "mal - an interpreter for a subset of Clojure") + "- written in GNU make" + "- and Bash 4" + "- and Javascript" + "- and Python" + "- and Clojure" + "- and 17 other languages") + (list + (title "things it has") + "- scalars: integers, strings, symbols, keywords, nil, true, false" + "- immutable collections: lists, vectors, hash-maps" + "- metadata, atoms" + "- def!, fn*, let*" + " - varargs: (fn* (x y & more) ...)" + "- tail call optimization" + " - except GNU make implementation (no iteration)" + "- macros (quote, unquote, quasiquote, splice-quote)" + "- over 500 unit tests" + "- REPL with line editing (GNU readline/libedit/linenoise)") + (list + (title "things it does not have") + "- performance" + "- namespaces" + "- GC (in bash, make, C implementations)" + "- protocols :-(" + "- lots of other things") + (list + (title "why?") + "- because!") + (list + (title "why?") + "- because!" + "- gherkin was an inspiration to higher levels of crazy" + "- evolved into learning tool" + "- way to learn about Lisp and also the target language" + "- each implementation broken into small 11 steps") + (list + (title "thanks to:") + "- Peter Norvig: inspiration: lispy" + " - http://norvig.com/lispy.html" + "- Alan Dipert: gherkin, original gherkin slides" + " - https://github.com/alandipert/gherkin") + (list + (title "mal - Make a Lisp") + "https://github.com/kanaka/mal") + (list + (title "demo")))) + +(def! present + (fn* (slides) + (if (> (count slides) 0) + (do + (println (clear)) + + (apply println (map (fn* (line) (str "\n " line)) (first slides))) + (println "\n\n\n") + (readline "") + (present (rest slides)))))) + +(present slides) diff --git a/get-ci-matrix.py b/get-ci-matrix.py index debcb172f3..60e2b560ab 100755 --- a/get-ci-matrix.py +++ b/get-ci-matrix.py @@ -1,66 +1,66 @@ -#!/usr/bin/env python3 - -import json -import os -import re -import sys -import yaml - -IMPLS_FILE = "IMPLS.yml" -RE_IGNORE = re.compile(r'(^LICENSE$|^README.md$|^docs/|^process/)') -RE_IMPL = re.compile(r'^impls/(?!lib|tests)([^/]*)/') - -OVERRIDE_IMPLS = os.environ.get('OVERRIDE_IMPLS', '').split() - -def impl_text(impl): - s = "IMPL=%s" % impl['IMPL'] - for k, v in impl.items(): - if k == 'IMPL': continue - s += " %s=%s" % (k, v) - return s - -all_changes = sys.argv[1:] -# code changes that are not just to docs -code_changes = set([c for c in all_changes if not RE_IGNORE.search(c)]) -# actual changes to implementations -impl_changes = set([c for c in all_changes if RE_IMPL.search(c)]) -# names of changed implementations -run_impls = set([RE_IMPL.search(c).groups()[0] for c in impl_changes]) - -do_full = (len(code_changes) != len(impl_changes)) - -# If we have non-implementation code changes then we will add all -# implementations to the test matrix -if OVERRIDE_IMPLS: - run_impls = OVERRIDE_IMPLS - if 'all' in OVERRIDE_IMPLS: - do_full = True - - -print("OVERRIDE_IMPLS: %s" % OVERRIDE_IMPLS) -print("code_changes: %s (%d)" % (code_changes, len(code_changes))) -print("impl_changes: %s (%d)" % (impl_changes, len(impl_changes))) -print("run_impls: %s (%d)" % (run_impls, len(run_impls))) -print("do_full: %s" % do_full) - -# Load the full implementation description file -all_impls = yaml.safe_load(open(IMPLS_FILE)) - -# Accumulate and output linux and macos implementations separately -linux_impls = [] -macos_impls = [] -for impl in all_impls['IMPL']: - targ = linux_impls - if 'OS' in impl and impl['OS'] == 'macos': - targ = macos_impls - # Run implementations with actual changes first before running - # other impls triggered by non-impl code changes - if impl['IMPL'] in run_impls: - targ.insert(0, impl_text(impl)) - elif do_full: - targ.append(impl_text(impl)) - -print("::set-output name=do-linux::%s" % json.dumps(len(linux_impls)>0)) -print("::set-output name=do-macos::%s" % json.dumps(len(macos_impls)>0)) -print("::set-output name=linux::{\"IMPL\":%s}" % json.dumps(linux_impls)) -print("::set-output name=macos::{\"IMPL\":%s}" % json.dumps(macos_impls)) +#!/usr/bin/env python3 + +import json +import os +import re +import sys +import yaml + +IMPLS_FILE = "IMPLS.yml" +RE_IGNORE = re.compile(r'(^LICENSE$|^README.md$|^docs/|^process/)') +RE_IMPL = re.compile(r'^impls/(?!lib|tests)([^/]*)/') + +OVERRIDE_IMPLS = os.environ.get('OVERRIDE_IMPLS', '').split() + +def impl_text(impl): + s = "IMPL=%s" % impl['IMPL'] + for k, v in impl.items(): + if k == 'IMPL': continue + s += " %s=%s" % (k, v) + return s + +all_changes = sys.argv[1:] +# code changes that are not just to docs +code_changes = set([c for c in all_changes if not RE_IGNORE.search(c)]) +# actual changes to implementations +impl_changes = set([c for c in all_changes if RE_IMPL.search(c)]) +# names of changed implementations +run_impls = set([RE_IMPL.search(c).groups()[0] for c in impl_changes]) + +do_full = (len(code_changes) != len(impl_changes)) + +# If we have non-implementation code changes then we will add all +# implementations to the test matrix +if OVERRIDE_IMPLS: + run_impls = OVERRIDE_IMPLS + if 'all' in OVERRIDE_IMPLS: + do_full = True + + +print("OVERRIDE_IMPLS: %s" % OVERRIDE_IMPLS) +print("code_changes: %s (%d)" % (code_changes, len(code_changes))) +print("impl_changes: %s (%d)" % (impl_changes, len(impl_changes))) +print("run_impls: %s (%d)" % (run_impls, len(run_impls))) +print("do_full: %s" % do_full) + +# Load the full implementation description file +all_impls = yaml.safe_load(open(IMPLS_FILE)) + +# Accumulate and output linux and macos implementations separately +linux_impls = [] +macos_impls = [] +for impl in all_impls['IMPL']: + targ = linux_impls + if 'OS' in impl and impl['OS'] == 'macos': + targ = macos_impls + # Run implementations with actual changes first before running + # other impls triggered by non-impl code changes + if impl['IMPL'] in run_impls: + targ.insert(0, impl_text(impl)) + elif do_full: + targ.append(impl_text(impl)) + +print("::set-output name=do-linux::%s" % json.dumps(len(linux_impls)>0)) +print("::set-output name=do-macos::%s" % json.dumps(len(macos_impls)>0)) +print("::set-output name=linux::{\"IMPL\":%s}" % json.dumps(linux_impls)) +print("::set-output name=macos::{\"IMPL\":%s}" % json.dumps(macos_impls)) diff --git a/impls/.gitignore b/impls/.gitignore index 0e09605289..f795bd0a4f 100644 --- a/impls/.gitignore +++ b/impls/.gitignore @@ -1,150 +1,150 @@ -.DS_Store -.bash_history -.cache -.cargo -.config -.mal-history -.crystal -.lein -.m2 -.ivy2 -.sbt -.npm -.node-gyp -package-lock.json -.elm -*/experiments -*/node_modules -*.o -*.pyc -*/step0_repl -*/step1_read_print -*/step2_eval -*/step3_env -*/step4_if_fn_do -*/step5_tco -*/step6_file -*/step7_quote -*/step8_macros -*/step9_try -*/stepA_mal -*/mal -*/notes - -logs -old - -ada/obj/ -awk/mal.awk -bash/mal.sh -clojure/mal.jar -clojure/target -clojure/.lein-repl-history -coffee/mal.coffee -cs/*.exe -cs/*.dll -cs/*.mdb -d/*.o -elixir/_build -elixir/deps -elixir/erl_crash.dump -elixir/*.ez -erlang/ebin -erlang/.rebar -erlang/src/*.beam -es6/mal.js -es6/.esm-cache -factor/mal.factor -fantom/lib -forth/mal.fs -fsharp/*.exe -fsharp/*.dll -fsharp/*.mdb -go/step* -groovy/*.class -groovy/mal.jar -haskell/*.hi -haskell/*.o -haxe/*.n -haxe/*.py -haxe/cpp/ -haxe/*.js -java/mal.jar -java/target/ -java/dependency-reduced-pom.xml -.npm/ -.node-gyp/ -js/mal.js -js/web/mal.js -kotlin/*.jar -kotlin/.idea -kotlin/*.iml -lua/lib -lua/linenoise.so -lua/rex_pcre.so -lua/mal.lua -make/mal.mk -mal/mal.mal -matlab/octave-workspace -miniMAL/mal.json -nim/nimcache* -objc/*.d -ocaml/*.cmi -ocaml/*.cmo -ocaml/*.swp -ocaml/*.cmx -ocaml/*.o -ocaml/mal_lib.* -objpascal/*.o -objpascal/*.ppu -objpascal/pas-readline -objpascal/regexpr/Source/RegExpr.ppu -perl/mal.pl -perl6/.precomp/ -php/mal.php -php/mal-web.php -ps/mal.ps -python/mal.pyz -r/mal.r -ruby/mal.rb -.cargo/ -rust/target/ -rust/Cargo.lock -rust/.cargo -r/lib -scala/mal.jar -scala/target -scala/project -skew/*.js -tcl/mal.tcl -vb/*.exe -vb/*.dll -vimscript/mal.vim -clisp/*.fas -clisp/*.lib -basic/step0_repl.bas -basic/step1_read_print.bas -basic/step2_eval.bas -basic/step3_env.bas -basic/step4_if_fn_do.bas -basic/step5_tco.bas -basic/step6_file.bas -basic/step7_quote.bas -basic/step8_macros.bas -basic/step9_try.bas -basic/stepA_mal.bas -basic/*.prg -common-lisp/*.fasl -common-lisp/*.lib -common-lisp/images/* -common-lisp/hist/* -livescript/*.js -!livescript/node_readline.js -livescript/node_modules -elm/node_modules -elm/elm-stuff -elm/*.js -!elm/node_readline.js -!elm/bootstrap.js -wasm/*.wat -wasm/*.wasm +.DS_Store +.bash_history +.cache +.cargo +.config +.mal-history +.crystal +.lein +.m2 +.ivy2 +.sbt +.npm +.node-gyp +package-lock.json +.elm +*/experiments +*/node_modules +*.o +*.pyc +*/step0_repl +*/step1_read_print +*/step2_eval +*/step3_env +*/step4_if_fn_do +*/step5_tco +*/step6_file +*/step7_quote +*/step8_macros +*/step9_try +*/stepA_mal +*/mal +*/notes + +logs +old + +ada/obj/ +awk/mal.awk +bash/mal.sh +clojure/mal.jar +clojure/target +clojure/.lein-repl-history +coffee/mal.coffee +cs/*.exe +cs/*.dll +cs/*.mdb +d/*.o +elixir/_build +elixir/deps +elixir/erl_crash.dump +elixir/*.ez +erlang/ebin +erlang/.rebar +erlang/src/*.beam +es6/mal.js +es6/.esm-cache +factor/mal.factor +fantom/lib +forth/mal.fs +fsharp/*.exe +fsharp/*.dll +fsharp/*.mdb +go/step* +groovy/*.class +groovy/mal.jar +haskell/*.hi +haskell/*.o +haxe/*.n +haxe/*.py +haxe/cpp/ +haxe/*.js +java/mal.jar +java/target/ +java/dependency-reduced-pom.xml +.npm/ +.node-gyp/ +js/mal.js +js/web/mal.js +kotlin/*.jar +kotlin/.idea +kotlin/*.iml +lua/lib +lua/linenoise.so +lua/rex_pcre.so +lua/mal.lua +make/mal.mk +mal/mal.mal +matlab/octave-workspace +miniMAL/mal.json +nim/nimcache* +objc/*.d +ocaml/*.cmi +ocaml/*.cmo +ocaml/*.swp +ocaml/*.cmx +ocaml/*.o +ocaml/mal_lib.* +objpascal/*.o +objpascal/*.ppu +objpascal/pas-readline +objpascal/regexpr/Source/RegExpr.ppu +perl/mal.pl +perl6/.precomp/ +php/mal.php +php/mal-web.php +ps/mal.ps +python/mal.pyz +r/mal.r +ruby/mal.rb +.cargo/ +rust/target/ +rust/Cargo.lock +rust/.cargo +r/lib +scala/mal.jar +scala/target +scala/project +skew/*.js +tcl/mal.tcl +vb/*.exe +vb/*.dll +vimscript/mal.vim +clisp/*.fas +clisp/*.lib +basic/step0_repl.bas +basic/step1_read_print.bas +basic/step2_eval.bas +basic/step3_env.bas +basic/step4_if_fn_do.bas +basic/step5_tco.bas +basic/step6_file.bas +basic/step7_quote.bas +basic/step8_macros.bas +basic/step9_try.bas +basic/stepA_mal.bas +basic/*.prg +common-lisp/*.fasl +common-lisp/*.lib +common-lisp/images/* +common-lisp/hist/* +livescript/*.js +!livescript/node_readline.js +livescript/node_modules +elm/node_modules +elm/elm-stuff +elm/*.js +!elm/node_readline.js +!elm/bootstrap.js +wasm/*.wat +wasm/*.wasm diff --git a/impls/ada.2/Dockerfile b/impls/ada.2/Dockerfile index b05b41362e..5ed3b3ff5a 100644 --- a/impls/ada.2/Dockerfile +++ b/impls/ada.2/Dockerfile @@ -1,25 +1,25 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# GNU Ada compiler -RUN apt-get -y install gnat-8 +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# GNU Ada compiler +RUN apt-get -y install gnat-8 diff --git a/impls/ada.2/Makefile b/impls/ada.2/Makefile index 2b17dda639..7a1a1ae0e7 100644 --- a/impls/ada.2/Makefile +++ b/impls/ada.2/Makefile @@ -1,74 +1,74 @@ -ifdef DEBUG - ADAFLAGS := -Wall -Wextra -gnatw.eH.Y -gnatySdouxy -gnatVa -g -gnataEfoqQ \ - -fstack-check -pg - LDFLAGS := -pg -else - # -O3 is not recommended as the default by the GCC documentation, - # and -O2 seems to produce slightly better performances. - ADAFLAGS := -O2 -gnatnp -endif - -# Compiler arguments. -CARGS = $(ADAFLAGS) -# Linker arguments. -LARGS = $(LDFLAGS) -lreadline - -step0 := step0_repl -step13 := step1_read_print \ - step2_eval \ - step3_env -step49 := step4_if_fn_do \ - step5_tco \ - step6_file \ - step7_quote \ - step8_macros \ - step9_try -stepa := stepA_mal -steps := $(step0) $(step13) $(step49) $(stepa) - -.PHONY: all clean -all: $(steps) -clean: - $(RM) *~ *.adt *.ali *.o b~*.ad[bs] gmon.out $(steps) - -# Tell Make how to detect out-of-date executables, and let gnatmake do -# the rest when it must be executed. -sources = $(foreach unit,$1,$(unit).adb $(unit).ads) -TYPES := $(call sources,\ - envs \ - err \ - garbage_collected \ - printer \ - reader \ - readline \ - types \ - types-atoms \ - types-builtins \ - types-fns \ - types-maps \ - types-sequences \ - types-strings \ -) -CORE := $(call sources,\ - core \ -) - -$(step0) : %: %.adb -$(step13): %: %.adb $(TYPES) -$(step49): %: %.adb $(TYPES) $(CORE) -$(stepa) : stepA%: stepa%.adb $(TYPES) $(CORE) -$(steps) : - gnatmake $< -o $@ -cargs $(CARGS) -largs $(LARGS) - -.PHONY: steps.diff -steps.diff: - diff -u step0_*.adb step1_*.adb || true - diff -u step1_*.adb step2_*.adb || true - diff -u step2_*.adb step3_*.adb || true - diff -u step3_*.adb step4_*.adb || true - diff -u step4_*.adb step5_*.adb || true - diff -u step5_*.adb step6_*.adb || true - diff -u step6_*.adb step7_*.adb || true - diff -u step7_*.adb step8_*.adb || true - diff -u step8_*.adb step9_*.adb || true - diff -u step9_*.adb stepa_*.adb || true +ifdef DEBUG + ADAFLAGS := -Wall -Wextra -gnatw.eH.Y -gnatySdouxy -gnatVa -g -gnataEfoqQ \ + -fstack-check -pg + LDFLAGS := -pg +else + # -O3 is not recommended as the default by the GCC documentation, + # and -O2 seems to produce slightly better performances. + ADAFLAGS := -O2 -gnatnp +endif + +# Compiler arguments. +CARGS = $(ADAFLAGS) +# Linker arguments. +LARGS = $(LDFLAGS) -lreadline + +step0 := step0_repl +step13 := step1_read_print \ + step2_eval \ + step3_env +step49 := step4_if_fn_do \ + step5_tco \ + step6_file \ + step7_quote \ + step8_macros \ + step9_try +stepa := stepA_mal +steps := $(step0) $(step13) $(step49) $(stepa) + +.PHONY: all clean +all: $(steps) +clean: + $(RM) *~ *.adt *.ali *.o b~*.ad[bs] gmon.out $(steps) + +# Tell Make how to detect out-of-date executables, and let gnatmake do +# the rest when it must be executed. +sources = $(foreach unit,$1,$(unit).adb $(unit).ads) +TYPES := $(call sources,\ + envs \ + err \ + garbage_collected \ + printer \ + reader \ + readline \ + types \ + types-atoms \ + types-builtins \ + types-fns \ + types-maps \ + types-sequences \ + types-strings \ +) +CORE := $(call sources,\ + core \ +) + +$(step0) : %: %.adb +$(step13): %: %.adb $(TYPES) +$(step49): %: %.adb $(TYPES) $(CORE) +$(stepa) : stepA%: stepa%.adb $(TYPES) $(CORE) +$(steps) : + gnatmake $< -o $@ -cargs $(CARGS) -largs $(LARGS) + +.PHONY: steps.diff +steps.diff: + diff -u step0_*.adb step1_*.adb || true + diff -u step1_*.adb step2_*.adb || true + diff -u step2_*.adb step3_*.adb || true + diff -u step3_*.adb step4_*.adb || true + diff -u step4_*.adb step5_*.adb || true + diff -u step5_*.adb step6_*.adb || true + diff -u step6_*.adb step7_*.adb || true + diff -u step7_*.adb step8_*.adb || true + diff -u step8_*.adb step9_*.adb || true + diff -u step9_*.adb stepa_*.adb || true diff --git a/impls/ada.2/README b/impls/ada.2/README index 4bb287d496..d7450a96cc 100644 --- a/impls/ada.2/README +++ b/impls/ada.2/README @@ -1,46 +1,46 @@ -Comparison with the first Ada implementation. --- - -The first implementation was deliberately compatible with all Ada -compilers, while this one illustrates various Ada 2012 features: -assertions, preconditions, invariants, initial assignment for limited -types, limited imports... - -The variant MAL type is implemented with a discriminant instead of -object-style dispatching. This allows more static and dynamic checks, -but also two crucial performance improvements: -* Nil, boolean, integers and pointers to built-in functions are passed - by value without dynamic allocation. -* Lists are implemented as C-style arrays, and can often be - allocated on the stack. - -Another difference is that a minimal form of garbage collecting is -implemented, removing objects not referenced from the main -environment. Reference counting does not seem efficient even for symbols, -and never deallocates cyclic structures. The implementation collects -garbage after each Read-Eval-Print cycle. It would be much more -difficult to collect garbage inside scripts. If this is ever done, it -would be better to reimplement load-file in Ada and run a cycle after -each root evaluation. -It is possible to execute the recursion marking references in parallel -with the recursion printing the result, which does not modify anything -and ignores the reference marking. This works but is less performant -than sequential execution even with Linux threads and a single task -initialized at startup. -Each pointer type goes on using its own memory pool, enabling better -performance when the designated subtype has a fixed size. - -The eventual performances compete with C-style languages, allthough -all user input is checked (implicit language-defined checks like array -bounds and discriminant consistency are only enabled during tests). - -Debugging --- - -Uncaught exceptions are reported with an execution trace (excluding -TCO cycles). This has become possible in step9, but has been -backported to former steps as this is really handy for debugging. - -Some environment variables increase verbosity. -# dbgread= ./stepAmal trace reader recursion -# dbgeval= ./stepAmal trace eval recursion (including TCO) +Comparison with the first Ada implementation. +-- + +The first implementation was deliberately compatible with all Ada +compilers, while this one illustrates various Ada 2012 features: +assertions, preconditions, invariants, initial assignment for limited +types, limited imports... + +The variant MAL type is implemented with a discriminant instead of +object-style dispatching. This allows more static and dynamic checks, +but also two crucial performance improvements: +* Nil, boolean, integers and pointers to built-in functions are passed + by value without dynamic allocation. +* Lists are implemented as C-style arrays, and can often be + allocated on the stack. + +Another difference is that a minimal form of garbage collecting is +implemented, removing objects not referenced from the main +environment. Reference counting does not seem efficient even for symbols, +and never deallocates cyclic structures. The implementation collects +garbage after each Read-Eval-Print cycle. It would be much more +difficult to collect garbage inside scripts. If this is ever done, it +would be better to reimplement load-file in Ada and run a cycle after +each root evaluation. +It is possible to execute the recursion marking references in parallel +with the recursion printing the result, which does not modify anything +and ignores the reference marking. This works but is less performant +than sequential execution even with Linux threads and a single task +initialized at startup. +Each pointer type goes on using its own memory pool, enabling better +performance when the designated subtype has a fixed size. + +The eventual performances compete with C-style languages, allthough +all user input is checked (implicit language-defined checks like array +bounds and discriminant consistency are only enabled during tests). + +Debugging +-- + +Uncaught exceptions are reported with an execution trace (excluding +TCO cycles). This has become possible in step9, but has been +backported to former steps as this is really handy for debugging. + +Some environment variables increase verbosity. +# dbgread= ./stepAmal trace reader recursion +# dbgeval= ./stepAmal trace eval recursion (including TCO) diff --git a/impls/ada.2/core.adb b/impls/ada.2/core.adb index 8fa7ac5987..2303242d11 100644 --- a/impls/ada.2/core.adb +++ b/impls/ada.2/core.adb @@ -1,459 +1,459 @@ -with Ada.Calendar; -with Ada.Characters.Latin_1; -with Ada.Strings.Unbounded; -with Ada.Text_IO.Unbounded_IO; - -with Err; -with Printer; -with Reader; -with Types.Atoms; -with Types.Builtins; -with Types.Fns; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -package body Core is - - package ASU renames Ada.Strings.Unbounded; - use all type Types.Kind_Type; - - -- Used by time_ms. - Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock; - - generic - Kind : in Types.Kind_Type; - function Generic_Kind_Test (Args : in Types.T_Array) return Types.T; - function Generic_Kind_Test (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return (Kind_Boolean, Args (Args'First).Kind = Kind); - end Generic_Kind_Test; - - generic - with function Ada_Operator (Left, Right : in Integer) return Integer; - function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T; - function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 2 - and then Args (Args'First).Kind = Kind_Number - and then Args (Args'Last).Kind = Kind_Number, - "expected two numbers"); - return (Kind_Number, Ada_Operator (Args (Args'First).Number, - Args (Args'Last).Number)); - end Generic_Mal_Operator; - - generic - with function Ada_Operator (Left, Right : in Integer) return Boolean; - function Generic_Comparison (Args : in Types.T_Array) return Types.T; - function Generic_Comparison (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 2 - and then Args (Args'First).Kind = Kind_Number - and then Args (Args'Last).Kind = Kind_Number, - "expected two numbers"); - return (Kind_Boolean, Ada_Operator (Args (Args'First).Number, - Args (Args'Last).Number)); - end Generic_Comparison; - - function Addition is new Generic_Mal_Operator ("+"); - function Apply (Args : in Types.T_Array) return Types.T; - function Division is new Generic_Mal_Operator ("/"); - function Equals (Args : in Types.T_Array) return Types.T; - function Greater_Equal is new Generic_Comparison (">="); - function Greater_Than is new Generic_Comparison (">"); - function Is_Atom is new Generic_Kind_Test (Kind_Atom); - function Is_False (Args : in Types.T_Array) return Types.T; - function Is_Function (Args : in Types.T_Array) return Types.T; - function Is_Keyword is new Generic_Kind_Test (Kind_Keyword); - function Is_List is new Generic_Kind_Test (Kind_List); - function Is_Macro is new Generic_Kind_Test (Kind_Macro); - function Is_Map is new Generic_Kind_Test (Kind_Map); - function Is_Nil is new Generic_Kind_Test (Kind_Nil); - function Is_Number is new Generic_Kind_Test (Kind_Number); - function Is_Sequential (Args : in Types.T_Array) return Types.T; - function Is_String is new Generic_Kind_Test (Kind_String); - function Is_Symbol is new Generic_Kind_Test (Kind_Symbol); - function Is_True (Args : in Types.T_Array) return Types.T; - function Is_Vector is new Generic_Kind_Test (Kind_Vector); - function Keyword (Args : in Types.T_Array) return Types.T; - function Less_Equal is new Generic_Comparison ("<="); - function Less_Than is new Generic_Comparison ("<"); - function Meta (Args : in Types.T_Array) return Types.T; - function Pr_Str (Args : in Types.T_Array) return Types.T; - function Println (Args : in Types.T_Array) return Types.T; - function Prn (Args : in Types.T_Array) return Types.T; - function Product is new Generic_Mal_Operator ("*"); - function Read_String (Args : in Types.T_Array) return Types.T; - function Readline (Args : in Types.T_Array) return Types.T; - function Seq (Args : in Types.T_Array) return Types.T; - function Slurp (Args : in Types.T_Array) return Types.T; - function Str (Args : in Types.T_Array) return Types.T; - function Subtraction is new Generic_Mal_Operator ("-"); - function Symbol (Args : in Types.T_Array) return Types.T; - function Time_Ms (Args : in Types.T_Array) return Types.T; - function With_Meta (Args : in Types.T_Array) return Types.T; - - ---------------------------------------------------------------------- - - function Apply (Args : in Types.T_Array) return Types.T is - begin - Err.Check (2 <= Args'Length - and then Args (Args'Last).Kind in Types.Kind_Sequence, - "expected a function, optional arguments then a sequence"); - declare - use type Types.T_Array; - F : Types.T renames Args (Args'First); - A : constant Types.T_Array - := Args (Args'First + 1 .. Args'Last - 1) - & Args (Args'Last).Sequence.all.Data; - begin - case F.Kind is - when Kind_Builtin => - return F.Builtin.all (A); - when Kind_Builtin_With_Meta => - return F.Builtin_With_Meta.all.Builtin.all (A); - when Kind_Fn => - return F.Fn.all.Apply (A); - when others => - Err.Raise_With ("parameter 1 must be a function"); - end case; - end; - end Apply; - - function Equals (Args : in Types.T_Array) return Types.T is - use type Types.T; - begin - Err.Check (Args'Length = 2, "expected 2 parameters"); - return (Kind_Boolean, Args (Args'First) = Args (Args'Last)); - end Equals; - - function Is_False (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean - and then not Args (Args'First).Ada_Boolean); - end Is_False; - - function Is_Function (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return (Kind_Boolean, Args (Args'First).Kind in Types.Kind_Function); - end Is_Function; - - function Is_Sequential (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return (Kind_Boolean, Args (Args'First).Kind in Types.Kind_Sequence); - end Is_Sequential; - - function Is_True (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean - and then Args (Args'First).Ada_Boolean); - end Is_True; - - function Keyword (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1 - and then Args (Args'First).Kind in Types.Kind_Key, - "expected a keyword or a string"); - return (Kind_Keyword, Args (Args'First).Str); - end Keyword; - - function Meta (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - declare - A1 : Types.T renames Args (Args'First); - begin - case A1.Kind is - when Types.Kind_Sequence => - return A1.Sequence.all.Meta; - when Kind_Map => - return A1.Map.all.Meta; - when Kind_Fn => - return A1.Fn.all.Meta; - when Kind_Builtin_With_Meta => - return A1.Builtin_With_Meta.all.Meta; - when Kind_Builtin => - return Types.Nil; - when others => - Err.Raise_With ("expected a function, map or sequence"); - end case; - end; - end Meta; - - procedure NS_Add_To_Repl (Repl : in Envs.Ptr) is - procedure P (S : in String; - B : in Types.Builtin_Ptr) with Inline; - procedure P (S : in String; - B : in Types.Builtin_Ptr) - is - begin - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc (S)), - (Kind_Builtin, B)); - end P; - begin - P ("+", Addition'Access); - P ("apply", Apply'Access); - P ("assoc", Types.Maps.Assoc'Access); - P ("atom", Types.Atoms.Atom'Access); - P ("concat", Types.Sequences.Concat'Access); - P ("conj", Types.Sequences.Conj'Access); - P ("cons", Types.Sequences.Cons'Access); - P ("contains?", Types.Maps.Contains'Access); - P ("count", Types.Sequences.Count'Access); - P ("deref", Types.Atoms.Deref'Access); - P ("dissoc", Types.Maps.Dissoc'Access); - P ("/", Division'Access); - P ("=", Equals'Access); - P ("first", Types.Sequences.First'Access); - P ("get", Types.Maps.Get'Access); - P (">=", Greater_Equal'Access); - P (">", Greater_Than'Access); - P ("hash-map", Types.Maps.Hash_Map'Access); - P ("atom?", Is_Atom'Access); - P ("empty?", Types.Sequences.Is_Empty'Access); - P ("false?", Is_False'Access); - P ("fn?", Is_Function'Access); - P ("keyword?", Is_Keyword'Access); - P ("list?", Is_List'Access); - P ("macro?", Is_Macro'Access); - P ("map?", Is_Map'Access); - P ("nil?", Is_Nil'Access); - P ("number?", Is_Number'Access); - P ("sequential?", Is_Sequential'Access); - P ("string?", Is_String'Access); - P ("symbol?", Is_Symbol'Access); - P ("true?", Is_True'Access); - P ("vector?", Is_Vector'Access); - P ("keys", Types.Maps.Keys'Access); - P ("keyword", Keyword'Access); - P ("<=", Less_Equal'Access); - P ("<", Less_Than'Access); - P ("list", Types.Sequences.List'Access); - P ("map", Types.Sequences.Map'Access); - P ("meta", Meta'Access); - P ("nth", Types.Sequences.Nth'Access); - P ("pr-str", Pr_Str'Access); - P ("println", Println'Access); - P ("prn", Prn'Access); - P ("*", Product'Access); - P ("read-string", Read_String'Access); - P ("readline", Readline'Access); - P ("reset!", Types.Atoms.Reset'Access); - P ("rest", Types.Sequences.Rest'Access); - P ("seq", Seq'Access); - P ("slurp", Slurp'Access); - P ("str", Str'Access); - P ("-", Subtraction'Access); - P ("swap!", Types.Atoms.Swap'Access); - P ("symbol", Symbol'Access); - P ("throw", Err.Throw'Access); - P ("time-ms", Time_Ms'Access); - P ("vals", Types.Maps.Vals'Access); - P ("vec", Types.Sequences.Vec'Access); - P ("vector", Types.Sequences.Vector'Access); - P ("with-meta", With_Meta'Access); - end NS_Add_To_Repl; - - function Pr_Str (Args : in Types.T_Array) return Types.T is - R : ASU.Unbounded_String; - Started : Boolean := False; - begin - for A of Args loop - if Started then - ASU.Append (R, ' '); - else - Started := True; - end if; - Printer.Pr_Str (R, A); - end loop; - return (Kind_String, Types.Strings.Alloc (ASU.To_String (R))); - end Pr_Str; - - function Println (Args : in Types.T_Array) return Types.T is - Started : Boolean := False; - Buffer : ASU.Unbounded_String; - begin - for A of Args loop - if Started then - ASU.Append (Buffer, ' '); - else - Started := True; - end if; - Printer.Pr_Str (Buffer, A, Readably => False); - end loop; - Ada.Text_IO.Unbounded_IO.Put_Line (Buffer); - return Types.Nil; - end Println; - - function Prn (Args : in Types.T_Array) return Types.T is - -- Calling Pr_Str would create an intermediate copy. - Buffer : ASU.Unbounded_String; - Started : Boolean := False; - begin - for A of Args loop - if Started then - ASU.Append (Buffer, ' '); - else - Started := True; - end if; - Printer.Pr_Str (Buffer, A); - end loop; - Ada.Text_IO.Unbounded_IO.Put_Line (Buffer); - return Types.Nil; - end Prn; - - function Readline (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String, - "expected a string"); - Ada.Text_IO.Put (Args (Args'First).Str.all.To_String); - if Ada.Text_IO.End_Of_File then - return Types.Nil; - else - return (Kind_String, Types.Strings.Alloc (Ada.Text_IO.Get_Line)); - end if; - end Readline; - - function Read_String (Args : in Types.T_Array) return Types.T is - Result : Types.T; - procedure Process (Element : in String); - procedure Process (Element : in String) is - R : constant Types.T_Array := Reader.Read_Str (Element); - begin - Err.Check (R'Length = 1, "parameter must contain 1 expression"); - Result := R (R'First); - end Process; - begin - Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String, - "expected a string"); - Args (Args'First).Str.all.Query_Element (Process'Access); - return Result; - end Read_String; - - function Seq (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - case Args (Args'First).Kind is - when Kind_Nil => - return Types.Nil; - when Kind_String => - declare - Result : Types.T; - procedure Process (S : in String); - procedure Process (S : in String) is - begin - if S'Length = 0 then - Result := Types.Nil; - else - Result := (Kind_List, - Types.Sequences.Constructor (S'Length)); - for I in S'Range loop - Result.Sequence.all.Data (S'First - 1 + I) - := (Kind_String, Types.Strings.Alloc (S (I .. I))); - end loop; - end if; - end Process; - begin - Args (Args'First).Str.all.Query_Element (Process'Access); - return Result; - end; - when Types.Kind_Sequence => - if Args (Args'First).Sequence.all.Length = 0 then - return Types.Nil; - else - return (Kind_List, Args (Args'First).Sequence); - end if; - when others => - Err.Raise_With ("expected nil, a sequence or a string"); - end case; - end Seq; - - function Slurp (Args : in Types.T_Array) return Types.T is - use Ada.Text_IO; - File : File_Type; - Buffer : ASU.Unbounded_String; - begin - Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String, - "expected a string"); - Open (File, In_File, Args (Args'First).Str.all.To_String); - while not End_Of_File (File) loop - ASU.Append (Buffer, Get_Line (File)); - ASU.Append (Buffer, Ada.Characters.Latin_1.LF); - end loop; - Close (File); - return (Kind_String, Types.Strings.Alloc (ASU.To_String (Buffer))); - exception - -- Catch I/O errors, but not Err.Error... - when E : Status_Error | Name_Error | Use_Error | Mode_Error => - if Is_Open (File) then - Close (File); - end if; - Err.Raise_In_Mal (E); - end Slurp; - - function Str (Args : in Types.T_Array) return Types.T is - R : ASU.Unbounded_String; - begin - for Arg of Args loop - Printer.Pr_Str (R, Arg, Readably => False); - end loop; - return (Kind_String, Types.Strings.Alloc (ASU.To_String (R))); - end Str; - - function Symbol (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String, - "expected a string"); - return (Kind_Symbol, Args (Args'First).Str); - end Symbol; - - function Time_Ms (Args : in Types.T_Array) return Types.T is - use type Ada.Calendar.Time; - begin - Err.Check (Args'Length = 0, "expected no parameter"); - return (Kind_Number, - Integer (1000.0 * (Ada.Calendar.Clock - Start_Time))); - end Time_Ms; - - function With_Meta (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 2, "expected 2 parameters"); - declare - A1 : Types.T renames Args (Args'First); - A2 : Types.T renames Args (Args'Last); - begin - case A1.Kind is - when Kind_Builtin_With_Meta => - return A1.Builtin_With_Meta.all.With_Meta (A2); - when Kind_Builtin => - return Types.Builtins.With_Meta (A1.Builtin, A2); - when Kind_List => - return R : constant Types.T - := Types.Sequences.List (A1.Sequence.all.Data) - do - R.Sequence.all.Meta := A2; - end return; - when Kind_Vector => - return R : constant Types.T - := Types.Sequences.Vector (A1.Sequence.all.Data) - do - R.Sequence.all.Meta := A2; - end return; - when Kind_Map => - return A1.Map.all.With_Meta (A2); - when Kind_Fn => - return (Kind_Fn, Types.Fns.New_Function - (A1.Fn.all.Params, A1.Fn.all.Ast, A1.Fn.all.Env, A2)); - when others => - Err.Raise_With - ("parameter 1 must be a function, map or sequence"); - end case; - end; - end With_Meta; - -end Core; +with Ada.Calendar; +with Ada.Characters.Latin_1; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; + +with Err; +with Printer; +with Reader; +with Types.Atoms; +with Types.Builtins; +with Types.Fns; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +package body Core is + + package ASU renames Ada.Strings.Unbounded; + use all type Types.Kind_Type; + + -- Used by time_ms. + Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock; + + generic + Kind : in Types.Kind_Type; + function Generic_Kind_Test (Args : in Types.T_Array) return Types.T; + function Generic_Kind_Test (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind = Kind); + end Generic_Kind_Test; + + generic + with function Ada_Operator (Left, Right : in Integer) return Integer; + function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T; + function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 2 + and then Args (Args'First).Kind = Kind_Number + and then Args (Args'Last).Kind = Kind_Number, + "expected two numbers"); + return (Kind_Number, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number)); + end Generic_Mal_Operator; + + generic + with function Ada_Operator (Left, Right : in Integer) return Boolean; + function Generic_Comparison (Args : in Types.T_Array) return Types.T; + function Generic_Comparison (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 2 + and then Args (Args'First).Kind = Kind_Number + and then Args (Args'Last).Kind = Kind_Number, + "expected two numbers"); + return (Kind_Boolean, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number)); + end Generic_Comparison; + + function Addition is new Generic_Mal_Operator ("+"); + function Apply (Args : in Types.T_Array) return Types.T; + function Division is new Generic_Mal_Operator ("/"); + function Equals (Args : in Types.T_Array) return Types.T; + function Greater_Equal is new Generic_Comparison (">="); + function Greater_Than is new Generic_Comparison (">"); + function Is_Atom is new Generic_Kind_Test (Kind_Atom); + function Is_False (Args : in Types.T_Array) return Types.T; + function Is_Function (Args : in Types.T_Array) return Types.T; + function Is_Keyword is new Generic_Kind_Test (Kind_Keyword); + function Is_List is new Generic_Kind_Test (Kind_List); + function Is_Macro is new Generic_Kind_Test (Kind_Macro); + function Is_Map is new Generic_Kind_Test (Kind_Map); + function Is_Nil is new Generic_Kind_Test (Kind_Nil); + function Is_Number is new Generic_Kind_Test (Kind_Number); + function Is_Sequential (Args : in Types.T_Array) return Types.T; + function Is_String is new Generic_Kind_Test (Kind_String); + function Is_Symbol is new Generic_Kind_Test (Kind_Symbol); + function Is_True (Args : in Types.T_Array) return Types.T; + function Is_Vector is new Generic_Kind_Test (Kind_Vector); + function Keyword (Args : in Types.T_Array) return Types.T; + function Less_Equal is new Generic_Comparison ("<="); + function Less_Than is new Generic_Comparison ("<"); + function Meta (Args : in Types.T_Array) return Types.T; + function Pr_Str (Args : in Types.T_Array) return Types.T; + function Println (Args : in Types.T_Array) return Types.T; + function Prn (Args : in Types.T_Array) return Types.T; + function Product is new Generic_Mal_Operator ("*"); + function Read_String (Args : in Types.T_Array) return Types.T; + function Readline (Args : in Types.T_Array) return Types.T; + function Seq (Args : in Types.T_Array) return Types.T; + function Slurp (Args : in Types.T_Array) return Types.T; + function Str (Args : in Types.T_Array) return Types.T; + function Subtraction is new Generic_Mal_Operator ("-"); + function Symbol (Args : in Types.T_Array) return Types.T; + function Time_Ms (Args : in Types.T_Array) return Types.T; + function With_Meta (Args : in Types.T_Array) return Types.T; + + ---------------------------------------------------------------------- + + function Apply (Args : in Types.T_Array) return Types.T is + begin + Err.Check (2 <= Args'Length + and then Args (Args'Last).Kind in Types.Kind_Sequence, + "expected a function, optional arguments then a sequence"); + declare + use type Types.T_Array; + F : Types.T renames Args (Args'First); + A : constant Types.T_Array + := Args (Args'First + 1 .. Args'Last - 1) + & Args (Args'Last).Sequence.all.Data; + begin + case F.Kind is + when Kind_Builtin => + return F.Builtin.all (A); + when Kind_Builtin_With_Meta => + return F.Builtin_With_Meta.all.Builtin.all (A); + when Kind_Fn => + return F.Fn.all.Apply (A); + when others => + Err.Raise_With ("parameter 1 must be a function"); + end case; + end; + end Apply; + + function Equals (Args : in Types.T_Array) return Types.T is + use type Types.T; + begin + Err.Check (Args'Length = 2, "expected 2 parameters"); + return (Kind_Boolean, Args (Args'First) = Args (Args'Last)); + end Equals; + + function Is_False (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean + and then not Args (Args'First).Ada_Boolean); + end Is_False; + + function Is_Function (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind in Types.Kind_Function); + end Is_Function; + + function Is_Sequential (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind in Types.Kind_Sequence); + end Is_Sequential; + + function Is_True (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean + and then Args (Args'First).Ada_Boolean); + end Is_True; + + function Keyword (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1 + and then Args (Args'First).Kind in Types.Kind_Key, + "expected a keyword or a string"); + return (Kind_Keyword, Args (Args'First).Str); + end Keyword; + + function Meta (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + declare + A1 : Types.T renames Args (Args'First); + begin + case A1.Kind is + when Types.Kind_Sequence => + return A1.Sequence.all.Meta; + when Kind_Map => + return A1.Map.all.Meta; + when Kind_Fn => + return A1.Fn.all.Meta; + when Kind_Builtin_With_Meta => + return A1.Builtin_With_Meta.all.Meta; + when Kind_Builtin => + return Types.Nil; + when others => + Err.Raise_With ("expected a function, map or sequence"); + end case; + end; + end Meta; + + procedure NS_Add_To_Repl (Repl : in Envs.Ptr) is + procedure P (S : in String; + B : in Types.Builtin_Ptr) with Inline; + procedure P (S : in String; + B : in Types.Builtin_Ptr) + is + begin + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc (S)), + (Kind_Builtin, B)); + end P; + begin + P ("+", Addition'Access); + P ("apply", Apply'Access); + P ("assoc", Types.Maps.Assoc'Access); + P ("atom", Types.Atoms.Atom'Access); + P ("concat", Types.Sequences.Concat'Access); + P ("conj", Types.Sequences.Conj'Access); + P ("cons", Types.Sequences.Cons'Access); + P ("contains?", Types.Maps.Contains'Access); + P ("count", Types.Sequences.Count'Access); + P ("deref", Types.Atoms.Deref'Access); + P ("dissoc", Types.Maps.Dissoc'Access); + P ("/", Division'Access); + P ("=", Equals'Access); + P ("first", Types.Sequences.First'Access); + P ("get", Types.Maps.Get'Access); + P (">=", Greater_Equal'Access); + P (">", Greater_Than'Access); + P ("hash-map", Types.Maps.Hash_Map'Access); + P ("atom?", Is_Atom'Access); + P ("empty?", Types.Sequences.Is_Empty'Access); + P ("false?", Is_False'Access); + P ("fn?", Is_Function'Access); + P ("keyword?", Is_Keyword'Access); + P ("list?", Is_List'Access); + P ("macro?", Is_Macro'Access); + P ("map?", Is_Map'Access); + P ("nil?", Is_Nil'Access); + P ("number?", Is_Number'Access); + P ("sequential?", Is_Sequential'Access); + P ("string?", Is_String'Access); + P ("symbol?", Is_Symbol'Access); + P ("true?", Is_True'Access); + P ("vector?", Is_Vector'Access); + P ("keys", Types.Maps.Keys'Access); + P ("keyword", Keyword'Access); + P ("<=", Less_Equal'Access); + P ("<", Less_Than'Access); + P ("list", Types.Sequences.List'Access); + P ("map", Types.Sequences.Map'Access); + P ("meta", Meta'Access); + P ("nth", Types.Sequences.Nth'Access); + P ("pr-str", Pr_Str'Access); + P ("println", Println'Access); + P ("prn", Prn'Access); + P ("*", Product'Access); + P ("read-string", Read_String'Access); + P ("readline", Readline'Access); + P ("reset!", Types.Atoms.Reset'Access); + P ("rest", Types.Sequences.Rest'Access); + P ("seq", Seq'Access); + P ("slurp", Slurp'Access); + P ("str", Str'Access); + P ("-", Subtraction'Access); + P ("swap!", Types.Atoms.Swap'Access); + P ("symbol", Symbol'Access); + P ("throw", Err.Throw'Access); + P ("time-ms", Time_Ms'Access); + P ("vals", Types.Maps.Vals'Access); + P ("vec", Types.Sequences.Vec'Access); + P ("vector", Types.Sequences.Vector'Access); + P ("with-meta", With_Meta'Access); + end NS_Add_To_Repl; + + function Pr_Str (Args : in Types.T_Array) return Types.T is + R : ASU.Unbounded_String; + Started : Boolean := False; + begin + for A of Args loop + if Started then + ASU.Append (R, ' '); + else + Started := True; + end if; + Printer.Pr_Str (R, A); + end loop; + return (Kind_String, Types.Strings.Alloc (ASU.To_String (R))); + end Pr_Str; + + function Println (Args : in Types.T_Array) return Types.T is + Started : Boolean := False; + Buffer : ASU.Unbounded_String; + begin + for A of Args loop + if Started then + ASU.Append (Buffer, ' '); + else + Started := True; + end if; + Printer.Pr_Str (Buffer, A, Readably => False); + end loop; + Ada.Text_IO.Unbounded_IO.Put_Line (Buffer); + return Types.Nil; + end Println; + + function Prn (Args : in Types.T_Array) return Types.T is + -- Calling Pr_Str would create an intermediate copy. + Buffer : ASU.Unbounded_String; + Started : Boolean := False; + begin + for A of Args loop + if Started then + ASU.Append (Buffer, ' '); + else + Started := True; + end if; + Printer.Pr_Str (Buffer, A); + end loop; + Ada.Text_IO.Unbounded_IO.Put_Line (Buffer); + return Types.Nil; + end Prn; + + function Readline (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String, + "expected a string"); + Ada.Text_IO.Put (Args (Args'First).Str.all.To_String); + if Ada.Text_IO.End_Of_File then + return Types.Nil; + else + return (Kind_String, Types.Strings.Alloc (Ada.Text_IO.Get_Line)); + end if; + end Readline; + + function Read_String (Args : in Types.T_Array) return Types.T is + Result : Types.T; + procedure Process (Element : in String); + procedure Process (Element : in String) is + R : constant Types.T_Array := Reader.Read_Str (Element); + begin + Err.Check (R'Length = 1, "parameter must contain 1 expression"); + Result := R (R'First); + end Process; + begin + Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String, + "expected a string"); + Args (Args'First).Str.all.Query_Element (Process'Access); + return Result; + end Read_String; + + function Seq (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + case Args (Args'First).Kind is + when Kind_Nil => + return Types.Nil; + when Kind_String => + declare + Result : Types.T; + procedure Process (S : in String); + procedure Process (S : in String) is + begin + if S'Length = 0 then + Result := Types.Nil; + else + Result := (Kind_List, + Types.Sequences.Constructor (S'Length)); + for I in S'Range loop + Result.Sequence.all.Data (S'First - 1 + I) + := (Kind_String, Types.Strings.Alloc (S (I .. I))); + end loop; + end if; + end Process; + begin + Args (Args'First).Str.all.Query_Element (Process'Access); + return Result; + end; + when Types.Kind_Sequence => + if Args (Args'First).Sequence.all.Length = 0 then + return Types.Nil; + else + return (Kind_List, Args (Args'First).Sequence); + end if; + when others => + Err.Raise_With ("expected nil, a sequence or a string"); + end case; + end Seq; + + function Slurp (Args : in Types.T_Array) return Types.T is + use Ada.Text_IO; + File : File_Type; + Buffer : ASU.Unbounded_String; + begin + Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String, + "expected a string"); + Open (File, In_File, Args (Args'First).Str.all.To_String); + while not End_Of_File (File) loop + ASU.Append (Buffer, Get_Line (File)); + ASU.Append (Buffer, Ada.Characters.Latin_1.LF); + end loop; + Close (File); + return (Kind_String, Types.Strings.Alloc (ASU.To_String (Buffer))); + exception + -- Catch I/O errors, but not Err.Error... + when E : Status_Error | Name_Error | Use_Error | Mode_Error => + if Is_Open (File) then + Close (File); + end if; + Err.Raise_In_Mal (E); + end Slurp; + + function Str (Args : in Types.T_Array) return Types.T is + R : ASU.Unbounded_String; + begin + for Arg of Args loop + Printer.Pr_Str (R, Arg, Readably => False); + end loop; + return (Kind_String, Types.Strings.Alloc (ASU.To_String (R))); + end Str; + + function Symbol (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String, + "expected a string"); + return (Kind_Symbol, Args (Args'First).Str); + end Symbol; + + function Time_Ms (Args : in Types.T_Array) return Types.T is + use type Ada.Calendar.Time; + begin + Err.Check (Args'Length = 0, "expected no parameter"); + return (Kind_Number, + Integer (1000.0 * (Ada.Calendar.Clock - Start_Time))); + end Time_Ms; + + function With_Meta (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 2, "expected 2 parameters"); + declare + A1 : Types.T renames Args (Args'First); + A2 : Types.T renames Args (Args'Last); + begin + case A1.Kind is + when Kind_Builtin_With_Meta => + return A1.Builtin_With_Meta.all.With_Meta (A2); + when Kind_Builtin => + return Types.Builtins.With_Meta (A1.Builtin, A2); + when Kind_List => + return R : constant Types.T + := Types.Sequences.List (A1.Sequence.all.Data) + do + R.Sequence.all.Meta := A2; + end return; + when Kind_Vector => + return R : constant Types.T + := Types.Sequences.Vector (A1.Sequence.all.Data) + do + R.Sequence.all.Meta := A2; + end return; + when Kind_Map => + return A1.Map.all.With_Meta (A2); + when Kind_Fn => + return (Kind_Fn, Types.Fns.New_Function + (A1.Fn.all.Params, A1.Fn.all.Ast, A1.Fn.all.Env, A2)); + when others => + Err.Raise_With + ("parameter 1 must be a function, map or sequence"); + end case; + end; + end With_Meta; + +end Core; diff --git a/impls/ada.2/core.ads b/impls/ada.2/core.ads index bc2858d659..50e04141db 100644 --- a/impls/ada.2/core.ads +++ b/impls/ada.2/core.ads @@ -1,8 +1,8 @@ -with Envs; - -package Core is - - procedure NS_Add_To_Repl (Repl : in Envs.Ptr); - -- Add built-in functions. - -end Core; +with Envs; + +package Core is + + procedure NS_Add_To_Repl (Repl : in Envs.Ptr); + -- Add built-in functions. + +end Core; diff --git a/impls/ada.2/envs.adb b/impls/ada.2/envs.adb index 8638b92513..7ed7c93a05 100644 --- a/impls/ada.2/envs.adb +++ b/impls/ada.2/envs.adb @@ -1,109 +1,109 @@ -with Ada.Text_IO.Unbounded_IO; - -with Err; -with Printer; -with Types.Sequences; - -package body Envs is - - use all type Types.Kind_Type; - use type Types.Strings.Instance; - - ---------------------------------------------------------------------- - - procedure Dump_Stack (Env : in Instance) is - use Ada.Text_IO; - begin - Put ("environment:"); - for P in Env.Data.Iterate loop - -- Do not print builtins for repl. - if HM.Element (P).Kind /= Kind_Builtin or Env.Outer /= null then - Put (" "); - HM.Key (P).all.Query_Element (Put'Access); - Put (':'); - Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P))); - New_Line; - end if; - end loop; - if Env.Outer /= null then - Put ("outer is "); - Env.Outer.all.Dump_Stack; - end if; - end Dump_Stack; - - function Get (Env : in Instance; - Key : in Types.String_Ptr) return Types.T - is - Position : HM.Cursor := Env.Data.Find (Key); - Ref : Link; - begin - if not HM.Has_Element (Position) then - Ref := Env.Outer; - loop - if Ref = null then - -- Not using Err.Check, which would compute the - -- argument even if the assertion holds... - Err.Raise_With ("'" & Key.To_String & "' not found"); - end if; - Position := Ref.all.Data.Find (Key); - exit when HM.Has_Element (Position); - Ref := Ref.all.Outer; - end loop; - end if; - return HM.Element (Position); - end Get; - - procedure Keep_References (Object : in out Instance) is - begin - for Position in Object.Data.Iterate loop - HM.Key (Position).all.Keep; - Types.Keep (HM.Element (Position)); - end loop; - if Object.Outer /= null then - Object.Outer.all.Keep; - end if; - end Keep_References; - - function New_Env (Outer : in Link := null) return Ptr is - Ref : constant Ptr := new Instance; - begin - Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); - Ref.all.Outer := Outer; - return Ref; - end New_Env; - - procedure Set_Binds (Env : in out Instance; - Binds : in Types.T_Array; - Exprs : in Types.T_Array) - is - begin - if 2 <= Binds'Length and then Binds (Binds'Last - 1).Str.all = "&" then - Err.Check (Binds'Length - 2 <= Exprs'Length, - "not enough actual parameters for vararg function"); - for I in 0 .. Binds'Length - 3 loop - Env.Data.Include (Key => Binds (Binds'First + I).Str, - New_Item => Exprs (Exprs'First + I)); - end loop; - Env.Data.Include (Key => Binds (Binds'Last).Str, - New_Item => Types.Sequences.List - (Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last))); - else - Err.Check (Binds'Length = Exprs'Length, - "wrong parameter count for (not vararg) function"); - for I in 0 .. Binds'Length - 1 loop - Env.Data.Include (Key => Binds (Binds'First + I).Str, - New_Item => Exprs (Exprs'First + I)); - end loop; - end if; - end Set_Binds; - - procedure Set (Env : in out Instance; - Key : in Types.T; - New_Item : in Types.T) - is - begin - Err.Check (Key.Kind = Kind_Symbol, "environment keys must be symbols"); - Env.Data.Include (Key.Str, New_Item); - end Set; - -end Envs; +with Ada.Text_IO.Unbounded_IO; + +with Err; +with Printer; +with Types.Sequences; + +package body Envs is + + use all type Types.Kind_Type; + use type Types.Strings.Instance; + + ---------------------------------------------------------------------- + + procedure Dump_Stack (Env : in Instance) is + use Ada.Text_IO; + begin + Put ("environment:"); + for P in Env.Data.Iterate loop + -- Do not print builtins for repl. + if HM.Element (P).Kind /= Kind_Builtin or Env.Outer /= null then + Put (" "); + HM.Key (P).all.Query_Element (Put'Access); + Put (':'); + Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P))); + New_Line; + end if; + end loop; + if Env.Outer /= null then + Put ("outer is "); + Env.Outer.all.Dump_Stack; + end if; + end Dump_Stack; + + function Get (Env : in Instance; + Key : in Types.String_Ptr) return Types.T + is + Position : HM.Cursor := Env.Data.Find (Key); + Ref : Link; + begin + if not HM.Has_Element (Position) then + Ref := Env.Outer; + loop + if Ref = null then + -- Not using Err.Check, which would compute the + -- argument even if the assertion holds... + Err.Raise_With ("'" & Key.To_String & "' not found"); + end if; + Position := Ref.all.Data.Find (Key); + exit when HM.Has_Element (Position); + Ref := Ref.all.Outer; + end loop; + end if; + return HM.Element (Position); + end Get; + + procedure Keep_References (Object : in out Instance) is + begin + for Position in Object.Data.Iterate loop + HM.Key (Position).all.Keep; + Types.Keep (HM.Element (Position)); + end loop; + if Object.Outer /= null then + Object.Outer.all.Keep; + end if; + end Keep_References; + + function New_Env (Outer : in Link := null) return Ptr is + Ref : constant Ptr := new Instance; + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + Ref.all.Outer := Outer; + return Ref; + end New_Env; + + procedure Set_Binds (Env : in out Instance; + Binds : in Types.T_Array; + Exprs : in Types.T_Array) + is + begin + if 2 <= Binds'Length and then Binds (Binds'Last - 1).Str.all = "&" then + Err.Check (Binds'Length - 2 <= Exprs'Length, + "not enough actual parameters for vararg function"); + for I in 0 .. Binds'Length - 3 loop + Env.Data.Include (Key => Binds (Binds'First + I).Str, + New_Item => Exprs (Exprs'First + I)); + end loop; + Env.Data.Include (Key => Binds (Binds'Last).Str, + New_Item => Types.Sequences.List + (Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last))); + else + Err.Check (Binds'Length = Exprs'Length, + "wrong parameter count for (not vararg) function"); + for I in 0 .. Binds'Length - 1 loop + Env.Data.Include (Key => Binds (Binds'First + I).Str, + New_Item => Exprs (Exprs'First + I)); + end loop; + end if; + end Set_Binds; + + procedure Set (Env : in out Instance; + Key : in Types.T; + New_Item : in Types.T) + is + begin + Err.Check (Key.Kind = Kind_Symbol, "environment keys must be symbols"); + Env.Data.Include (Key.Str, New_Item); + end Set; + +end Envs; diff --git a/impls/ada.2/envs.ads b/impls/ada.2/envs.ads index e6652dbcab..8b542cb366 100644 --- a/impls/ada.2/envs.ads +++ b/impls/ada.2/envs.ads @@ -1,57 +1,57 @@ -private with Ada.Containers.Hashed_Maps; - -with Garbage_Collected; -with Types.Strings; - -package Envs is - - -- This package should be named Env, but Ada does not allow formal - -- parameters to be named like a package dependency, and it seems - -- that readability inside Eval is more important. - - type Instance (<>) is abstract new Garbage_Collected.Instance with private; - type Link is access Instance; - subtype Ptr is not null Link; - - function New_Env (Outer : in Link := null) return Ptr with Inline; - -- Set_Binds is provided as distinct subprograms because we some - -- time spare the creation of a subenvironment. - - procedure Set_Binds (Env : in out Instance; - Binds : in Types.T_Array; - Exprs : in Types.T_Array); - -- Equivalent to successive calls to Set, except that if Binds - -- ends with "&" followed by a symbol, the trailing symbol - -- receives all remaining values as a list. - - function Get (Env : in Instance; - Key : in Types.String_Ptr) return Types.T; - - procedure Set (Env : in out Instance; - Key : in Types.T; - New_Item : in Types.T) with Inline; - -- Raises an exception if Key is not a symbol. - - -- Debug. - procedure Dump_Stack (Env : in Instance); - -private - - package HM is new Ada.Containers.Hashed_Maps - (Key_Type => Types.String_Ptr, - Element_Type => Types.T, - Hash => Types.Strings.Hash, - Equivalent_Keys => Types.Strings.Same_Contents, - "=" => Types."="); - - -- It may be tempting to subclass Types.Map, but this would not - -- simplify the code much. And adding metadata to a structure that - -- is allocated very often has a cost. - - type Instance is new Garbage_Collected.Instance with record - Outer : Link; - Data : HM.Map; - end record; - overriding procedure Keep_References (Object : in out Instance) with Inline; - -end Envs; +private with Ada.Containers.Hashed_Maps; + +with Garbage_Collected; +with Types.Strings; + +package Envs is + + -- This package should be named Env, but Ada does not allow formal + -- parameters to be named like a package dependency, and it seems + -- that readability inside Eval is more important. + + type Instance (<>) is abstract new Garbage_Collected.Instance with private; + type Link is access Instance; + subtype Ptr is not null Link; + + function New_Env (Outer : in Link := null) return Ptr with Inline; + -- Set_Binds is provided as distinct subprograms because we some + -- time spare the creation of a subenvironment. + + procedure Set_Binds (Env : in out Instance; + Binds : in Types.T_Array; + Exprs : in Types.T_Array); + -- Equivalent to successive calls to Set, except that if Binds + -- ends with "&" followed by a symbol, the trailing symbol + -- receives all remaining values as a list. + + function Get (Env : in Instance; + Key : in Types.String_Ptr) return Types.T; + + procedure Set (Env : in out Instance; + Key : in Types.T; + New_Item : in Types.T) with Inline; + -- Raises an exception if Key is not a symbol. + + -- Debug. + procedure Dump_Stack (Env : in Instance); + +private + + package HM is new Ada.Containers.Hashed_Maps + (Key_Type => Types.String_Ptr, + Element_Type => Types.T, + Hash => Types.Strings.Hash, + Equivalent_Keys => Types.Strings.Same_Contents, + "=" => Types."="); + + -- It may be tempting to subclass Types.Map, but this would not + -- simplify the code much. And adding metadata to a structure that + -- is allocated very often has a cost. + + type Instance is new Garbage_Collected.Instance with record + Outer : Link; + Data : HM.Map; + end record; + overriding procedure Keep_References (Object : in out Instance) with Inline; + +end Envs; diff --git a/impls/ada.2/err.adb b/impls/ada.2/err.adb index e2411f16ae..c43f7cbcf8 100644 --- a/impls/ada.2/err.adb +++ b/impls/ada.2/err.adb @@ -1,67 +1,67 @@ -with Ada.Characters.Latin_1; - -with Printer; -with Types.Strings; - -package body Err is - - use Ada.Strings.Unbounded; - - ---------------------------------------------------------------------- - - procedure Add_Trace_Line (Action : in String; - Ast : in Types.T) - is - begin - Append (Trace, " in "); - Append (Trace, Action); - Append (Trace, ": "); - Printer.Pr_Str (Trace, Ast); - Append (Trace, Ada.Characters.Latin_1.LF); - end Add_Trace_Line; - - procedure Check (Condition : in Boolean; - Message : in String) - is - begin - if not Condition then - Raise_With (Message); - end if; - end Check; - - procedure Raise_In_Mal (E : in Ada.Exceptions.Exception_Occurrence) is - Message : String renames Ada.Exceptions.Exception_Information (E); - procedure Process (S : in String); - procedure Process (S : in String) is - begin - Append (Trace, S); - end Process; - begin - Data := (Types.Kind_String, Types.Strings.Alloc (Message)); - Set_Unbounded_String (Trace, "Uncaught exception: "); - Data.Str.all.Query_Element (Process'Access); - raise Error; - end Raise_In_Mal; - - procedure Raise_With (Message : in String) is - begin - Data := (Types.Kind_String, Types.Strings.Alloc (Message)); - Set_Unbounded_String (Trace, "Uncaught exception: "); - Append (Trace, Message); - Append (Trace, Ada.Characters.Latin_1.LF); - raise Error; - end Raise_With; - - function Throw (Args : in Types.T_Array) return Types.T is - begin - Check (Args'Length = 1, "expected 1 parameter"); - Data := Args (Args'First); - Set_Unbounded_String (Trace, "Uncaught exception: "); - Printer.Pr_Str (Trace, Data); - Append (Trace, Ada.Characters.Latin_1.LF); - -- A raise value is equivalent to a raise statement, but - -- silents a compiler warning. - return raise Error; - end Throw; - -end Err; +with Ada.Characters.Latin_1; + +with Printer; +with Types.Strings; + +package body Err is + + use Ada.Strings.Unbounded; + + ---------------------------------------------------------------------- + + procedure Add_Trace_Line (Action : in String; + Ast : in Types.T) + is + begin + Append (Trace, " in "); + Append (Trace, Action); + Append (Trace, ": "); + Printer.Pr_Str (Trace, Ast); + Append (Trace, Ada.Characters.Latin_1.LF); + end Add_Trace_Line; + + procedure Check (Condition : in Boolean; + Message : in String) + is + begin + if not Condition then + Raise_With (Message); + end if; + end Check; + + procedure Raise_In_Mal (E : in Ada.Exceptions.Exception_Occurrence) is + Message : String renames Ada.Exceptions.Exception_Information (E); + procedure Process (S : in String); + procedure Process (S : in String) is + begin + Append (Trace, S); + end Process; + begin + Data := (Types.Kind_String, Types.Strings.Alloc (Message)); + Set_Unbounded_String (Trace, "Uncaught exception: "); + Data.Str.all.Query_Element (Process'Access); + raise Error; + end Raise_In_Mal; + + procedure Raise_With (Message : in String) is + begin + Data := (Types.Kind_String, Types.Strings.Alloc (Message)); + Set_Unbounded_String (Trace, "Uncaught exception: "); + Append (Trace, Message); + Append (Trace, Ada.Characters.Latin_1.LF); + raise Error; + end Raise_With; + + function Throw (Args : in Types.T_Array) return Types.T is + begin + Check (Args'Length = 1, "expected 1 parameter"); + Data := Args (Args'First); + Set_Unbounded_String (Trace, "Uncaught exception: "); + Printer.Pr_Str (Trace, Data); + Append (Trace, Ada.Characters.Latin_1.LF); + -- A raise value is equivalent to a raise statement, but + -- silents a compiler warning. + return raise Error; + end Throw; + +end Err; diff --git a/impls/ada.2/err.ads b/impls/ada.2/err.ads index a83078a7e0..90fbe2bb6a 100644 --- a/impls/ada.2/err.ads +++ b/impls/ada.2/err.ads @@ -1,50 +1,50 @@ -with Ada.Exceptions; -with Ada.Strings.Unbounded; - -with Types; --- We declare a variable of type Types.T. -pragma Elaborate (Types); - -package Err is - - -- Error handling. - - -- Built-in function. - function Throw (Args : in Types.T_Array) return Types.T; - - -- Ada exceptions can only carry an immutable String in each - -- occurence, so we require a global variable to store the last - -- exception as a Mal object anyway, and may as well use it for - -- simple string messages. - - Error : exception; - Data : Types.T; - Trace : Ada.Strings.Unbounded.Unbounded_String; - - -- Convenient shortcuts. - - procedure Raise_With (Message : in String) with No_Return; - -- Similar to a "raise with Message" Ada statement. - -- Store the message into Data, - -- store the message and "Uncaught exception: " into Trace, - -- then raise Error. - - procedure Raise_In_Mal (E : in Ada.Exceptions.Exception_Occurrence) - with No_Return; - -- Raise_With (Ada.Exceptions.Exception_Information (E)) - - procedure Add_Trace_Line (Action : in String; - Ast : in Types.T); - -- Appends a line like "Action: Ast" to Trace. - - procedure Check (Condition : in Boolean; - Message : in String) with Inline; - -- Raise_With if Condition fails. - - -- It is probably more efficient to construct a boolean and call - -- this procedure once, as "inline" is only a recommendation. - - -- Beware of the classical performance issue that the Message is - -- formatted even if the Condition does not hold. - -end Err; +with Ada.Exceptions; +with Ada.Strings.Unbounded; + +with Types; +-- We declare a variable of type Types.T. +pragma Elaborate (Types); + +package Err is + + -- Error handling. + + -- Built-in function. + function Throw (Args : in Types.T_Array) return Types.T; + + -- Ada exceptions can only carry an immutable String in each + -- occurence, so we require a global variable to store the last + -- exception as a Mal object anyway, and may as well use it for + -- simple string messages. + + Error : exception; + Data : Types.T; + Trace : Ada.Strings.Unbounded.Unbounded_String; + + -- Convenient shortcuts. + + procedure Raise_With (Message : in String) with No_Return; + -- Similar to a "raise with Message" Ada statement. + -- Store the message into Data, + -- store the message and "Uncaught exception: " into Trace, + -- then raise Error. + + procedure Raise_In_Mal (E : in Ada.Exceptions.Exception_Occurrence) + with No_Return; + -- Raise_With (Ada.Exceptions.Exception_Information (E)) + + procedure Add_Trace_Line (Action : in String; + Ast : in Types.T); + -- Appends a line like "Action: Ast" to Trace. + + procedure Check (Condition : in Boolean; + Message : in String) with Inline; + -- Raise_With if Condition fails. + + -- It is probably more efficient to construct a boolean and call + -- this procedure once, as "inline" is only a recommendation. + + -- Beware of the classical performance issue that the Message is + -- formatted even if the Condition does not hold. + +end Err; diff --git a/impls/ada.2/garbage_collected.adb b/impls/ada.2/garbage_collected.adb index 373f26d977..09dd66c962 100644 --- a/impls/ada.2/garbage_collected.adb +++ b/impls/ada.2/garbage_collected.adb @@ -1,54 +1,54 @@ -with Ada.Unchecked_Deallocation; - -package body Garbage_Collected is - - procedure Free is new Ada.Unchecked_Deallocation (Class, Link); - - Top : Link := null; - - ---------------------------------------------------------------------- - - procedure Clean is - Current : Link := Top; - Previous : Link; - begin - while Current /= null and then not Current.all.Kept loop - Previous := Current; - Current := Current.all.Next; - Free (Previous); - end loop; - Top := Current; - while Current /= null loop - if Current.all.Kept then - Current.all.Kept := False; - Previous := Current; - else - Previous.all.Next := Current.all.Next; - Free (Current); - end if; - Current := Previous.all.Next; - end loop; - end Clean; - - procedure Keep (Object : in out Class) is - begin - if not Object.Kept then - Object.Kept := True; - Object.Keep_References; -- dispatching - end if; - end Keep; - - procedure Check_Allocations is - begin - pragma Assert (Top = null); - end Check_Allocations; - - procedure Register (Ref : in Pointer) is - begin - pragma Assert (Ref.all.Kept = False); - pragma Assert (Ref.all.Next = null); - Ref.all.Next := Top; - Top := Ref; - end Register; - -end Garbage_Collected; +with Ada.Unchecked_Deallocation; + +package body Garbage_Collected is + + procedure Free is new Ada.Unchecked_Deallocation (Class, Link); + + Top : Link := null; + + ---------------------------------------------------------------------- + + procedure Clean is + Current : Link := Top; + Previous : Link; + begin + while Current /= null and then not Current.all.Kept loop + Previous := Current; + Current := Current.all.Next; + Free (Previous); + end loop; + Top := Current; + while Current /= null loop + if Current.all.Kept then + Current.all.Kept := False; + Previous := Current; + else + Previous.all.Next := Current.all.Next; + Free (Current); + end if; + Current := Previous.all.Next; + end loop; + end Clean; + + procedure Keep (Object : in out Class) is + begin + if not Object.Kept then + Object.Kept := True; + Object.Keep_References; -- dispatching + end if; + end Keep; + + procedure Check_Allocations is + begin + pragma Assert (Top = null); + end Check_Allocations; + + procedure Register (Ref : in Pointer) is + begin + pragma Assert (Ref.all.Kept = False); + pragma Assert (Ref.all.Next = null); + Ref.all.Next := Top; + Top := Ref; + end Register; + +end Garbage_Collected; diff --git a/impls/ada.2/garbage_collected.ads b/impls/ada.2/garbage_collected.ads index 1f23f2b980..cd7a2da6ea 100644 --- a/impls/ada.2/garbage_collected.ads +++ b/impls/ada.2/garbage_collected.ads @@ -1,46 +1,46 @@ -package Garbage_Collected is - - -- A generic would not be convenient for lists. We want the - -- extended type to be able to have a discriminant. - - -- However, we keep the dispatching in a single enumeration for - -- efficiency and clarity of the source. - - type Instance is abstract tagged limited private; - subtype Class is Instance'Class; - type Link is access all Class; - subtype Pointer is not null Link; - - procedure Keep_References (Object : in out Instance) is null with Inline; - -- A dispatching call in Keep allows subclasses to override this - -- in order to Keep each of the internal reference they maintain. - - -- The following methods have no reason to be overridden. - - procedure Keep (Object : in out Class) with Inline; - -- Mark this object so that it is not deleted by next clean, - -- then make a dispatching call to Keep_References. - -- Does nothing if it has already been called for this object - -- since startup or last Clean. - - procedure Register (Ref : in Pointer) with Inline; - -- Each subclass defines its own allocation pool, but every call - -- to new must be followed by a call to Register. - - procedure Clean; - -- For each object for which Keep has not been called since - -- startup or last clean, make a dispatching call to Finalize, - -- then deallocate the memory for the object. - - -- Debug. - procedure Check_Allocations; - -- Does nothing if assertions are disabled. - -private - - type Instance is abstract tagged limited record - Kept : Boolean := False; - Next : Link := null; - end record; - -end Garbage_Collected; +package Garbage_Collected is + + -- A generic would not be convenient for lists. We want the + -- extended type to be able to have a discriminant. + + -- However, we keep the dispatching in a single enumeration for + -- efficiency and clarity of the source. + + type Instance is abstract tagged limited private; + subtype Class is Instance'Class; + type Link is access all Class; + subtype Pointer is not null Link; + + procedure Keep_References (Object : in out Instance) is null with Inline; + -- A dispatching call in Keep allows subclasses to override this + -- in order to Keep each of the internal reference they maintain. + + -- The following methods have no reason to be overridden. + + procedure Keep (Object : in out Class) with Inline; + -- Mark this object so that it is not deleted by next clean, + -- then make a dispatching call to Keep_References. + -- Does nothing if it has already been called for this object + -- since startup or last Clean. + + procedure Register (Ref : in Pointer) with Inline; + -- Each subclass defines its own allocation pool, but every call + -- to new must be followed by a call to Register. + + procedure Clean; + -- For each object for which Keep has not been called since + -- startup or last clean, make a dispatching call to Finalize, + -- then deallocate the memory for the object. + + -- Debug. + procedure Check_Allocations; + -- Does nothing if assertions are disabled. + +private + + type Instance is abstract tagged limited record + Kept : Boolean := False; + Next : Link := null; + end record; + +end Garbage_Collected; diff --git a/impls/ada.2/printer.adb b/impls/ada.2/printer.adb index 0891cd741f..81613b3f20 100644 --- a/impls/ada.2/printer.adb +++ b/impls/ada.2/printer.adb @@ -1,164 +1,164 @@ -with Ada.Characters.Latin_1; - -with Types.Atoms; -with Types.Fns; -with Types.Maps; -pragma Warnings (Off, "unit ""Types.Sequences"" is not referenced"); -with Types.Sequences; -pragma Warnings (On, "unit ""Types.Sequences"" is not referenced"); - -package body Printer is - - use Ada.Strings.Unbounded; - use all type Types.Kind_Type; - - procedure Pr_Str (Buffer : in out Unbounded_String; - Ast : in Types.T; - Readably : in Boolean := True) - is - - procedure Print_Form (Form_Ast : in Types.T); - -- The recursive function traversing Ast for Pr_Str. - -- Form_Ast is the current node. - - -- Helpers for Print_Form. - procedure Print_Number (Number : in Integer); - procedure Print_List (List : in Types.T_Array); - procedure Print_Map (Map : in Types.Maps.Instance); - procedure Print_Readably (S : in String); - procedure Print_String (S : in String); - - ---------------------------------------------------------------------- - - procedure Print_Form (Form_Ast : in Types.T) is - begin - case Form_Ast.Kind is - when Kind_Nil => - Append (Buffer, "nil"); - when Kind_Boolean => - if Form_Ast.Ada_Boolean then - Append (Buffer, "true"); - else - Append (Buffer, "false"); - end if; - when Kind_Symbol => - Form_Ast.Str.all.Query_Element (Print_String'Access); - when Kind_Number => - Print_Number (Form_Ast.Number); - when Kind_Keyword => - Append (Buffer, ':'); - Form_Ast.Str.all.Query_Element (Print_String'Access); - when Kind_String => - if Readably then - Append (Buffer, '"'); - Form_Ast.Str.all.Query_Element (Print_Readably'Access); - Append (Buffer, '"'); - else - Form_Ast.Str.all.Query_Element (Print_String'Access); - end if; - when Kind_List => - Append (Buffer, '('); - Print_List (Form_Ast.Sequence.all.Data); - Append (Buffer, ')'); - when Kind_Vector => - Append (Buffer, '['); - Print_List (Form_Ast.Sequence.all.Data); - Append (Buffer, ']'); - when Kind_Map => - Append (Buffer, '{'); - Print_Map (Form_Ast.Map.all); - Append (Buffer, '}'); - when Kind_Builtin | Kind_Builtin_With_Meta => - Append (Buffer, "#"); - when Kind_Fn => - Append (Buffer, "# "); - Print_Form (Form_Ast.Fn.all.Ast); - Append (Buffer, '>'); - when Kind_Macro => - Append (Buffer, "# "); - Print_Form (Form_Ast.Fn.all.Ast); - Append (Buffer, '>'); - when Kind_Atom => - Append (Buffer, "(atom "); - Print_Form (Form_Ast.Atom.all.Deref); - Append (Buffer, ')'); - end case; - end Print_Form; - - procedure Print_List (List : in Types.T_Array) is - begin - if 0 < List'Length then - Print_Form (List (List'First)); - for I in List'First + 1 .. List'Last loop - Append (Buffer, ' '); - Print_Form (List (I)); - end loop; - end if; - end Print_List; - - procedure Print_Map (Map : in Types.Maps.Instance) is - use all type Types.Maps.Cursor; - Position : Types.Maps.Cursor := Map.First; - begin - if Has_Element (Position) then - loop - Print_Form (Key (Position)); - Append (Buffer, ' '); - Print_Form (Element (Position)); - Next (Position); - exit when not Has_Element (Position); - Append (Buffer, ' '); - end loop; - end if; - end Print_Map; - - procedure Print_Number (Number : in Integer) is - Image : constant String := Integer'Image (Number); - First : Positive := Image'First; - begin - if Image (First) = ' ' then - First := First + 1; - end if; - Append (Buffer, Image (First .. Image'Last)); - end Print_Number; - - procedure Print_Readably (S : in String) is - begin - for C of S loop - case C is - when '"' | '\' => - Append (Buffer, '\'); - Append (Buffer, C); - when Ada.Characters.Latin_1.LF => - Append (Buffer, "\n"); - when others => - Append (Buffer, C); - end case; - end loop; - end Print_Readably; - - procedure Print_String (S : in String) is - begin - Append (Buffer, S); - end Print_String; - - ---------------------------------------------------------------------- - - begin -- Pr_Str - Print_Form (Ast); - end Pr_Str; - - function Pr_Str (Ast : in Types.T; - Readably : in Boolean := True) return Unbounded_String - is - begin - return Buffer : Unbounded_String do - Pr_Str (Buffer, Ast, Readably); - end return; - end Pr_Str; - -end Printer; +with Ada.Characters.Latin_1; + +with Types.Atoms; +with Types.Fns; +with Types.Maps; +pragma Warnings (Off, "unit ""Types.Sequences"" is not referenced"); +with Types.Sequences; +pragma Warnings (On, "unit ""Types.Sequences"" is not referenced"); + +package body Printer is + + use Ada.Strings.Unbounded; + use all type Types.Kind_Type; + + procedure Pr_Str (Buffer : in out Unbounded_String; + Ast : in Types.T; + Readably : in Boolean := True) + is + + procedure Print_Form (Form_Ast : in Types.T); + -- The recursive function traversing Ast for Pr_Str. + -- Form_Ast is the current node. + + -- Helpers for Print_Form. + procedure Print_Number (Number : in Integer); + procedure Print_List (List : in Types.T_Array); + procedure Print_Map (Map : in Types.Maps.Instance); + procedure Print_Readably (S : in String); + procedure Print_String (S : in String); + + ---------------------------------------------------------------------- + + procedure Print_Form (Form_Ast : in Types.T) is + begin + case Form_Ast.Kind is + when Kind_Nil => + Append (Buffer, "nil"); + when Kind_Boolean => + if Form_Ast.Ada_Boolean then + Append (Buffer, "true"); + else + Append (Buffer, "false"); + end if; + when Kind_Symbol => + Form_Ast.Str.all.Query_Element (Print_String'Access); + when Kind_Number => + Print_Number (Form_Ast.Number); + when Kind_Keyword => + Append (Buffer, ':'); + Form_Ast.Str.all.Query_Element (Print_String'Access); + when Kind_String => + if Readably then + Append (Buffer, '"'); + Form_Ast.Str.all.Query_Element (Print_Readably'Access); + Append (Buffer, '"'); + else + Form_Ast.Str.all.Query_Element (Print_String'Access); + end if; + when Kind_List => + Append (Buffer, '('); + Print_List (Form_Ast.Sequence.all.Data); + Append (Buffer, ')'); + when Kind_Vector => + Append (Buffer, '['); + Print_List (Form_Ast.Sequence.all.Data); + Append (Buffer, ']'); + when Kind_Map => + Append (Buffer, '{'); + Print_Map (Form_Ast.Map.all); + Append (Buffer, '}'); + when Kind_Builtin | Kind_Builtin_With_Meta => + Append (Buffer, "#"); + when Kind_Fn => + Append (Buffer, "# "); + Print_Form (Form_Ast.Fn.all.Ast); + Append (Buffer, '>'); + when Kind_Macro => + Append (Buffer, "# "); + Print_Form (Form_Ast.Fn.all.Ast); + Append (Buffer, '>'); + when Kind_Atom => + Append (Buffer, "(atom "); + Print_Form (Form_Ast.Atom.all.Deref); + Append (Buffer, ')'); + end case; + end Print_Form; + + procedure Print_List (List : in Types.T_Array) is + begin + if 0 < List'Length then + Print_Form (List (List'First)); + for I in List'First + 1 .. List'Last loop + Append (Buffer, ' '); + Print_Form (List (I)); + end loop; + end if; + end Print_List; + + procedure Print_Map (Map : in Types.Maps.Instance) is + use all type Types.Maps.Cursor; + Position : Types.Maps.Cursor := Map.First; + begin + if Has_Element (Position) then + loop + Print_Form (Key (Position)); + Append (Buffer, ' '); + Print_Form (Element (Position)); + Next (Position); + exit when not Has_Element (Position); + Append (Buffer, ' '); + end loop; + end if; + end Print_Map; + + procedure Print_Number (Number : in Integer) is + Image : constant String := Integer'Image (Number); + First : Positive := Image'First; + begin + if Image (First) = ' ' then + First := First + 1; + end if; + Append (Buffer, Image (First .. Image'Last)); + end Print_Number; + + procedure Print_Readably (S : in String) is + begin + for C of S loop + case C is + when '"' | '\' => + Append (Buffer, '\'); + Append (Buffer, C); + when Ada.Characters.Latin_1.LF => + Append (Buffer, "\n"); + when others => + Append (Buffer, C); + end case; + end loop; + end Print_Readably; + + procedure Print_String (S : in String) is + begin + Append (Buffer, S); + end Print_String; + + ---------------------------------------------------------------------- + + begin -- Pr_Str + Print_Form (Ast); + end Pr_Str; + + function Pr_Str (Ast : in Types.T; + Readably : in Boolean := True) return Unbounded_String + is + begin + return Buffer : Unbounded_String do + Pr_Str (Buffer, Ast, Readably); + end return; + end Pr_Str; + +end Printer; diff --git a/impls/ada.2/printer.ads b/impls/ada.2/printer.ads index 22646dc659..d971e6c6ee 100644 --- a/impls/ada.2/printer.ads +++ b/impls/ada.2/printer.ads @@ -1,19 +1,19 @@ -with Ada.Strings.Unbounded; - -with Types; - -package Printer is - - procedure Pr_Str - (Buffer : in out Ada.Strings.Unbounded.Unbounded_String; - Ast : in Types.T; - Readably : in Boolean := True); - -- Append the text to Buffer. - - function Pr_Str (Ast : in Types.T; - Readably : in Boolean := True) - return Ada.Strings.Unbounded.Unbounded_String; - -- Return a freshly created unbounded string. - -- Convenient, but inefficient. - -end Printer; +with Ada.Strings.Unbounded; + +with Types; + +package Printer is + + procedure Pr_Str + (Buffer : in out Ada.Strings.Unbounded.Unbounded_String; + Ast : in Types.T; + Readably : in Boolean := True); + -- Append the text to Buffer. + + function Pr_Str (Ast : in Types.T; + Readably : in Boolean := True) + return Ada.Strings.Unbounded.Unbounded_String; + -- Return a freshly created unbounded string. + -- Convenient, but inefficient. + +end Printer; diff --git a/impls/ada.2/reader.adb b/impls/ada.2/reader.adb index 65037e84cf..992b3dce45 100644 --- a/impls/ada.2/reader.adb +++ b/impls/ada.2/reader.adb @@ -1,267 +1,267 @@ -with Ada.Characters.Handling; -with Ada.Characters.Latin_1; -with Ada.Environment_Variables; -with Ada.Strings.Maps.Constants; -with Ada.Strings.Unbounded; -with Ada.Text_IO.Unbounded_IO; - -with Err; -with Printer; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -package body Reader is - - Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbgread"); - - use all type Types.Kind_Type; - use all type Ada.Strings.Maps.Character_Set; - - Ignored_Set : constant Ada.Strings.Maps.Character_Set - := Ada.Strings.Maps.Constants.Control_Set - or To_Set (" ,;"); - - Symbol_Set : constant Ada.Strings.Maps.Character_Set - := not (Ignored_Set or To_Set ("""'()@[]^`{}~")); - - function Read_Str (Source : in String) return Types.T_Array is - - I : Positive := Source'First; - -- Index in Source of the currently read character. - - -- Big arrays on the stack are faster than repeated dynamic - -- reallocations. This single buffer is used by all Read_List - -- recursive invocations, and by Read_Str. - Buffer : Types.T_Array (1 .. Source'Length); - B_Last : Natural := Buffer'First - 1; - -- Index in Buffer of the currently written MAL expression. - - function Read_Form return Types.T; - -- The recursive part of Read_Str. - - -- Helpers for Read_Form: - - procedure Skip_Ignored; - -- Check if the current character is ignorable or a comment. - -- Increment I until it exceeds Source'Last or designates - -- an interesting character. - - procedure Skip_Digits with Inline; - -- Increment I at least once, until I exceeds Source'Last or - -- designates something else than a decimal digit. - - procedure Skip_Symbol with Inline; - -- Check if the current character is allowed in a symbol name. - -- Increment I until it exceeds Source'Last or stops - -- designating an allowed character. - - -- Read_Atom has been merged into the same case/switch - -- statement, for clarity and efficiency. - - function Read_List (Ending : in Character) return Natural; - -- Returns the index of the last elements in Buffer. - -- The elements have been stored in Buffer (B_Last .. result). - - function Read_Quote (Symbol : in String) return Types.T; - - function Read_String return Types.T; - - function Read_With_Meta return Types.T; - - ---------------------------------------------------------------------- - - function Read_List (Ending : in Character) return Natural is - Opening : constant Character := Source (I); - Old : constant Natural := B_Last; - Result : Positive; - begin - I := I + 1; -- Skip (, [ or {. - loop - Skip_Ignored; - Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'"); - exit when Source (I) = Ending; - B_Last := B_Last + 1; - Buffer (B_Last) := Read_Form; - end loop; - I := I + 1; -- Skip ), ] or }. - Result := B_Last; - B_Last := Old; - return Result; - end Read_List; - - function Read_Quote (Symbol : in String) return Types.T is - R : constant Types.Sequence_Ptr := Types.Sequences.Constructor (2); - begin - I := I + 1; -- Skip the initial ' or similar. - R.all.Data (1) := (Kind_Symbol, Types.Strings.Alloc (Symbol)); - Skip_Ignored; - Err.Check (I <= Source'Last, "Incomplete '" & Symbol & "'"); - R.all.Data (2) := Read_Form; - return (Kind_List, R); - end Read_Quote; - - function Read_Form return Types.T is - -- After I has been increased, current token is be - -- Source (F .. I - 1). - F : Positive; - R : Types.T; -- The result of this function. - begin - case Source (I) is - when ')' | ']' | '}' => - Err.Raise_With ("unbalanced '" & Source (I) & "'"); - when '"' => - R := Read_String; - when ':' => - I := I + 1; - F := I; - Skip_Symbol; - R := (Kind_Keyword, Types.Strings.Alloc (Source (F .. I - 1))); - when '-' => - F := I; - Skip_Digits; - if F + 1 < I then - R := (Kind_Number, Integer'Value (Source (F .. I - 1))); - else - Skip_Symbol; - R := (Kind_Symbol, - Types.Strings.Alloc (Source (F .. I - 1))); - end if; - when '~' => - if I < Source'Last and then Source (I + 1) = '@' then - I := I + 1; - R := Read_Quote ("splice-unquote"); - else - R := Read_Quote ("unquote"); - end if; - when '0' .. '9' => - F := I; - Skip_Digits; - R := (Kind_Number, Integer'Value (Source (F .. I - 1))); - when ''' => - R := Read_Quote ("quote"); - when '`' => - R := Read_Quote ("quasiquote"); - when '@' => - R := Read_Quote ("deref"); - when '^' => - R := Read_With_Meta; - when '(' => - R := Types.Sequences.List - (Buffer (B_Last + 1 .. Read_List (')'))); - when '[' => - R := Types.Sequences.Vector - (Buffer (B_Last + 1 .. Read_List (']'))); - when '{' => - R := Types.Maps.Hash_Map - (Buffer (B_Last + 1 .. Read_List ('}'))); - when others => - F := I; - Skip_Symbol; - if Source (F .. I - 1) = "false" then - R := (Kind_Boolean, False); - elsif Source (F .. I - 1) = "nil" then - R := Types.Nil; - elsif Source (F .. I - 1) = "true" then - R := (Kind_Boolean, True); - else - R := (Kind_Symbol, - Types.Strings.Alloc (Source (F .. I - 1))); - end if; - end case; - if Debug then - Ada.Text_IO.Put ("reader: "); - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (R)); - end if; - return R; - end Read_Form; - - function Read_String return Types.T is - use Ada.Strings.Unbounded; - Result : Unbounded_String; - begin - loop - I := I + 1; - Err.Check (I <= Source'Last, "unbalanced '""'"); - case Source (I) is - when '"' => - exit; - when '\' => - I := I + 1; - Err.Check (I <= Source'Last, "unbalanced '""'"); - case Source (I) is - when '\' | '"' => - Append (Result, Source (I)); - when 'n' => - Append (Result, Ada.Characters.Latin_1.LF); - when others => - Append (Result, Source (I - 1 .. I)); - end case; - when others => - Append (Result, Source (I)); - end case; - end loop; - I := I + 1; -- Skip closing double quote. - return (Kind_String, Types.Strings.Alloc (To_String (Result))); - end Read_String; - - function Read_With_Meta return Types.T is - List : constant Types.Sequence_Ptr := Types.Sequences.Constructor (3); - begin - I := I + 1; -- Skip the initial ^. - List.all.Data (1) := (Kind_Symbol, Types.Strings.Alloc ("with-meta")); - for I in reverse 2 .. 3 loop - Skip_Ignored; - Err.Check (I <= Source'Last, "Incomplete 'with-meta'"); - List.all.Data (I) := Read_Form; - end loop; - return (Kind_List, List); - end Read_With_Meta; - - procedure Skip_Digits is - use Ada.Characters.Handling; - begin - loop - I := I + 1; - exit when Source'Last < I; - exit when not Is_Digit (Source (I)); - end loop; - end Skip_Digits; - - procedure Skip_Ignored is - use Ada.Characters.Handling; - begin - Ignored : while I <= Source'Last - and then Is_In (Source (I), Ignored_Set) - loop - if Source (I) = ';' then - Comment : loop - I := I + 1; - exit Ignored when Source'Last < I; - exit Comment when Is_Line_Terminator (Source (I)); - end loop Comment; - end if; - I := I + 1; - end loop Ignored; - end Skip_Ignored; - - procedure Skip_Symbol is - begin - while I <= Source'Last and then Is_In (Source (I), Symbol_Set) loop - I := I + 1; - end loop; - end Skip_Symbol; - - ---------------------------------------------------------------------- - - begin -- Read_Str - loop - Skip_Ignored; - exit when Source'Last < I; - B_Last := B_Last + 1; - Buffer (B_Last) := Read_Form; - end loop; - return Buffer (Buffer'First .. B_Last); - end Read_Str; - -end Reader; +with Ada.Characters.Handling; +with Ada.Characters.Latin_1; +with Ada.Environment_Variables; +with Ada.Strings.Maps.Constants; +with Ada.Strings.Unbounded; +with Ada.Text_IO.Unbounded_IO; + +with Err; +with Printer; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +package body Reader is + + Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbgread"); + + use all type Types.Kind_Type; + use all type Ada.Strings.Maps.Character_Set; + + Ignored_Set : constant Ada.Strings.Maps.Character_Set + := Ada.Strings.Maps.Constants.Control_Set + or To_Set (" ,;"); + + Symbol_Set : constant Ada.Strings.Maps.Character_Set + := not (Ignored_Set or To_Set ("""'()@[]^`{}~")); + + function Read_Str (Source : in String) return Types.T_Array is + + I : Positive := Source'First; + -- Index in Source of the currently read character. + + -- Big arrays on the stack are faster than repeated dynamic + -- reallocations. This single buffer is used by all Read_List + -- recursive invocations, and by Read_Str. + Buffer : Types.T_Array (1 .. Source'Length); + B_Last : Natural := Buffer'First - 1; + -- Index in Buffer of the currently written MAL expression. + + function Read_Form return Types.T; + -- The recursive part of Read_Str. + + -- Helpers for Read_Form: + + procedure Skip_Ignored; + -- Check if the current character is ignorable or a comment. + -- Increment I until it exceeds Source'Last or designates + -- an interesting character. + + procedure Skip_Digits with Inline; + -- Increment I at least once, until I exceeds Source'Last or + -- designates something else than a decimal digit. + + procedure Skip_Symbol with Inline; + -- Check if the current character is allowed in a symbol name. + -- Increment I until it exceeds Source'Last or stops + -- designating an allowed character. + + -- Read_Atom has been merged into the same case/switch + -- statement, for clarity and efficiency. + + function Read_List (Ending : in Character) return Natural; + -- Returns the index of the last elements in Buffer. + -- The elements have been stored in Buffer (B_Last .. result). + + function Read_Quote (Symbol : in String) return Types.T; + + function Read_String return Types.T; + + function Read_With_Meta return Types.T; + + ---------------------------------------------------------------------- + + function Read_List (Ending : in Character) return Natural is + Opening : constant Character := Source (I); + Old : constant Natural := B_Last; + Result : Positive; + begin + I := I + 1; -- Skip (, [ or {. + loop + Skip_Ignored; + Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'"); + exit when Source (I) = Ending; + B_Last := B_Last + 1; + Buffer (B_Last) := Read_Form; + end loop; + I := I + 1; -- Skip ), ] or }. + Result := B_Last; + B_Last := Old; + return Result; + end Read_List; + + function Read_Quote (Symbol : in String) return Types.T is + R : constant Types.Sequence_Ptr := Types.Sequences.Constructor (2); + begin + I := I + 1; -- Skip the initial ' or similar. + R.all.Data (1) := (Kind_Symbol, Types.Strings.Alloc (Symbol)); + Skip_Ignored; + Err.Check (I <= Source'Last, "Incomplete '" & Symbol & "'"); + R.all.Data (2) := Read_Form; + return (Kind_List, R); + end Read_Quote; + + function Read_Form return Types.T is + -- After I has been increased, current token is be + -- Source (F .. I - 1). + F : Positive; + R : Types.T; -- The result of this function. + begin + case Source (I) is + when ')' | ']' | '}' => + Err.Raise_With ("unbalanced '" & Source (I) & "'"); + when '"' => + R := Read_String; + when ':' => + I := I + 1; + F := I; + Skip_Symbol; + R := (Kind_Keyword, Types.Strings.Alloc (Source (F .. I - 1))); + when '-' => + F := I; + Skip_Digits; + if F + 1 < I then + R := (Kind_Number, Integer'Value (Source (F .. I - 1))); + else + Skip_Symbol; + R := (Kind_Symbol, + Types.Strings.Alloc (Source (F .. I - 1))); + end if; + when '~' => + if I < Source'Last and then Source (I + 1) = '@' then + I := I + 1; + R := Read_Quote ("splice-unquote"); + else + R := Read_Quote ("unquote"); + end if; + when '0' .. '9' => + F := I; + Skip_Digits; + R := (Kind_Number, Integer'Value (Source (F .. I - 1))); + when ''' => + R := Read_Quote ("quote"); + when '`' => + R := Read_Quote ("quasiquote"); + when '@' => + R := Read_Quote ("deref"); + when '^' => + R := Read_With_Meta; + when '(' => + R := Types.Sequences.List + (Buffer (B_Last + 1 .. Read_List (')'))); + when '[' => + R := Types.Sequences.Vector + (Buffer (B_Last + 1 .. Read_List (']'))); + when '{' => + R := Types.Maps.Hash_Map + (Buffer (B_Last + 1 .. Read_List ('}'))); + when others => + F := I; + Skip_Symbol; + if Source (F .. I - 1) = "false" then + R := (Kind_Boolean, False); + elsif Source (F .. I - 1) = "nil" then + R := Types.Nil; + elsif Source (F .. I - 1) = "true" then + R := (Kind_Boolean, True); + else + R := (Kind_Symbol, + Types.Strings.Alloc (Source (F .. I - 1))); + end if; + end case; + if Debug then + Ada.Text_IO.Put ("reader: "); + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (R)); + end if; + return R; + end Read_Form; + + function Read_String return Types.T is + use Ada.Strings.Unbounded; + Result : Unbounded_String; + begin + loop + I := I + 1; + Err.Check (I <= Source'Last, "unbalanced '""'"); + case Source (I) is + when '"' => + exit; + when '\' => + I := I + 1; + Err.Check (I <= Source'Last, "unbalanced '""'"); + case Source (I) is + when '\' | '"' => + Append (Result, Source (I)); + when 'n' => + Append (Result, Ada.Characters.Latin_1.LF); + when others => + Append (Result, Source (I - 1 .. I)); + end case; + when others => + Append (Result, Source (I)); + end case; + end loop; + I := I + 1; -- Skip closing double quote. + return (Kind_String, Types.Strings.Alloc (To_String (Result))); + end Read_String; + + function Read_With_Meta return Types.T is + List : constant Types.Sequence_Ptr := Types.Sequences.Constructor (3); + begin + I := I + 1; -- Skip the initial ^. + List.all.Data (1) := (Kind_Symbol, Types.Strings.Alloc ("with-meta")); + for I in reverse 2 .. 3 loop + Skip_Ignored; + Err.Check (I <= Source'Last, "Incomplete 'with-meta'"); + List.all.Data (I) := Read_Form; + end loop; + return (Kind_List, List); + end Read_With_Meta; + + procedure Skip_Digits is + use Ada.Characters.Handling; + begin + loop + I := I + 1; + exit when Source'Last < I; + exit when not Is_Digit (Source (I)); + end loop; + end Skip_Digits; + + procedure Skip_Ignored is + use Ada.Characters.Handling; + begin + Ignored : while I <= Source'Last + and then Is_In (Source (I), Ignored_Set) + loop + if Source (I) = ';' then + Comment : loop + I := I + 1; + exit Ignored when Source'Last < I; + exit Comment when Is_Line_Terminator (Source (I)); + end loop Comment; + end if; + I := I + 1; + end loop Ignored; + end Skip_Ignored; + + procedure Skip_Symbol is + begin + while I <= Source'Last and then Is_In (Source (I), Symbol_Set) loop + I := I + 1; + end loop; + end Skip_Symbol; + + ---------------------------------------------------------------------- + + begin -- Read_Str + loop + Skip_Ignored; + exit when Source'Last < I; + B_Last := B_Last + 1; + Buffer (B_Last) := Read_Form; + end loop; + return Buffer (Buffer'First .. B_Last); + end Read_Str; + +end Reader; diff --git a/impls/ada.2/reader.ads b/impls/ada.2/reader.ads index 033fc33e16..5b678af3b1 100644 --- a/impls/ada.2/reader.ads +++ b/impls/ada.2/reader.ads @@ -1,10 +1,10 @@ -with Types; - -package Reader is - - function Read_Str (Source : in String) return Types.T_Array; - -- The language does not explicitly define what happens when the - -- input string contains more than one expression. - -- This implementation returns all of them. - -end Reader; +with Types; + +package Reader is + + function Read_Str (Source : in String) return Types.T_Array; + -- The language does not explicitly define what happens when the + -- input string contains more than one expression. + -- This implementation returns all of them. + +end Reader; diff --git a/impls/ada.2/readline.adb b/impls/ada.2/readline.adb index 882b347387..cf1a44442e 100644 --- a/impls/ada.2/readline.adb +++ b/impls/ada.2/readline.adb @@ -1,32 +1,32 @@ -with Interfaces.C.Strings; - -package body Readline is - - function Input (Prompt : in String) return String is - - use Interfaces.C; - use Interfaces.C.Strings; - - function C_Readline (Prompt : in char_array) return chars_ptr - with Import, Convention => C, External_Name => "readline"; - - procedure Add_History (Line : in chars_ptr) - with Import, Convention => C, External_Name => "add_history"; - - procedure Free (Line : in chars_ptr) - with Import, Convention => C, External_Name => "free"; - - C_Line : constant chars_ptr := C_Readline (To_C (Prompt)); - begin - if C_Line = Null_Ptr then - raise End_Of_File; - end if; - return Ada_Line : constant String := Value (C_Line) do - if Ada_Line /= "" then - Add_History (C_Line); - end if; - Free (C_Line); - end return; - end Input; - -end Readline; +with Interfaces.C.Strings; + +package body Readline is + + function Input (Prompt : in String) return String is + + use Interfaces.C; + use Interfaces.C.Strings; + + function C_Readline (Prompt : in char_array) return chars_ptr + with Import, Convention => C, External_Name => "readline"; + + procedure Add_History (Line : in chars_ptr) + with Import, Convention => C, External_Name => "add_history"; + + procedure Free (Line : in chars_ptr) + with Import, Convention => C, External_Name => "free"; + + C_Line : constant chars_ptr := C_Readline (To_C (Prompt)); + begin + if C_Line = Null_Ptr then + raise End_Of_File; + end if; + return Ada_Line : constant String := Value (C_Line) do + if Ada_Line /= "" then + Add_History (C_Line); + end if; + Free (C_Line); + end return; + end Input; + +end Readline; diff --git a/impls/ada.2/readline.ads b/impls/ada.2/readline.ads index 81bdb839db..04d50e3b40 100644 --- a/impls/ada.2/readline.ads +++ b/impls/ada.2/readline.ads @@ -1,7 +1,7 @@ -package Readline is - - function Input (Prompt : in String) return String; - - End_Of_File : exception; - -end Readline; +package Readline is + + function Input (Prompt : in String) return String; + + End_Of_File : exception; + +end Readline; diff --git a/impls/ada.2/run b/impls/ada.2/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/ada.2/run +++ b/impls/ada.2/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/ada.2/step0_repl.adb b/impls/ada.2/step0_repl.adb index 5a09040d98..74f5538add 100644 --- a/impls/ada.2/step0_repl.adb +++ b/impls/ada.2/step0_repl.adb @@ -1,45 +1,45 @@ -with Ada.Text_IO; - -with Readline; - -procedure Step0_Repl is - - function Read return String with Inline; - - function Eval (Ast : in String) return String; - - procedure Print (Ast : in String) with Inline; - - procedure Rep with Inline; - - ---------------------------------------------------------------------- - - function Eval (Ast : in String) return String - is (Ast); - - procedure Print (Ast : in String) is - begin - Ada.Text_IO.Put_Line (Ast); - end Print; - - function Read return String is (Readline.Input ("user> ")); - - procedure Rep is - begin - Print (Eval (Read)); - end Rep; - - ---------------------------------------------------------------------- - -begin - loop - begin - Rep; - exception - when Readline.End_Of_File => - exit; - end; - -- Other exceptions are really unexpected. - end loop; - Ada.Text_IO.New_Line; -end Step0_Repl; +with Ada.Text_IO; + +with Readline; + +procedure Step0_Repl is + + function Read return String with Inline; + + function Eval (Ast : in String) return String; + + procedure Print (Ast : in String) with Inline; + + procedure Rep with Inline; + + ---------------------------------------------------------------------- + + function Eval (Ast : in String) return String + is (Ast); + + procedure Print (Ast : in String) is + begin + Ada.Text_IO.Put_Line (Ast); + end Print; + + function Read return String is (Readline.Input ("user> ")); + + procedure Rep is + begin + Print (Eval (Read)); + end Rep; + + ---------------------------------------------------------------------- + +begin + loop + begin + Rep; + exception + when Readline.End_Of_File => + exit; + end; + -- Other exceptions are really unexpected. + end loop; + Ada.Text_IO.New_Line; +end Step0_Repl; diff --git a/impls/ada.2/step1_read_print.adb b/impls/ada.2/step1_read_print.adb index 4079879e94..03f9a22d8f 100644 --- a/impls/ada.2/step1_read_print.adb +++ b/impls/ada.2/step1_read_print.adb @@ -1,65 +1,65 @@ -with Ada.Text_IO.Unbounded_IO; - -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types; - -procedure Step1_Read_Print is - - function Read return Types.T_Array with Inline; - - function Eval (Ast : in Types.T) return Types.T; - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep with Inline; - - ---------------------------------------------------------------------- - - function Eval (Ast : in Types.T) return Types.T is (Ast); - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep is - begin - for Expression of Read loop - Print (Eval (Expression)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - -begin - loop - begin - Rep; - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - -- No data survives at this stage, Repl only contains static - -- pointers to built-in functions. - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end Step1_Read_Print; +with Ada.Text_IO.Unbounded_IO; + +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types; + +procedure Step1_Read_Print is + + function Read return Types.T_Array with Inline; + + function Eval (Ast : in Types.T) return Types.T; + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep with Inline; + + ---------------------------------------------------------------------- + + function Eval (Ast : in Types.T) return Types.T is (Ast); + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep is + begin + for Expression of Read loop + Print (Eval (Expression)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + +begin + loop + begin + Rep; + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + -- No data survives at this stage, Repl only contains static + -- pointers to built-in functions. + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end Step1_Read_Print; diff --git a/impls/ada.2/step2_eval.adb b/impls/ada.2/step2_eval.adb index 7eadeb6990..3911c09517 100644 --- a/impls/ada.2/step2_eval.adb +++ b/impls/ada.2/step2_eval.adb @@ -1,195 +1,195 @@ -with Ada.Environment_Variables; -with Ada.Containers.Indefinite_Hashed_Maps; -with Ada.Strings.Hash; -with Ada.Text_IO.Unbounded_IO; - -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -procedure Step2_Eval is - - Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); - - use type Types.T; - use all type Types.Kind_Type; - - package Envs is new Ada.Containers.Indefinite_Hashed_Maps - (Key_Type => String, - Element_Type => Types.Builtin_Ptr, - Hash => Ada.Strings.Hash, - Equivalent_Keys => "=", - "=" => Types."="); - - function Read return Types.T_Array with Inline; - - function Eval (Ast : in Types.T; - Env : in Envs.Map) return Types.T; - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep (Env : in Envs.Map) with Inline; - - generic - with function Ada_Operator (Left, Right : in Integer) return Integer; - function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Map) return Types.T; - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Map) return Types.T; - -- Helpers for the Eval function. - - ---------------------------------------------------------------------- - - function Eval (Ast : in Types.T; - Env : in Envs.Map) return Types.T - is - First : Types.T; - begin - if Dbgeval then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put ("EVAL: "); - Print (Ast); - end if; - - case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - return Ast; - when Kind_Symbol => - declare - S : constant String := Ast.Str.all.To_String; - C : constant Envs.Cursor := Env.Find (S); - begin - -- The predefined error message does not pass tests. - Err.Check (Envs.Has_Element (C), "'" & S & "' not found"); - return (Kind_Builtin, Envs.Element (C)); - end; - when Kind_Map => - return Eval_Map (Ast.Map.all, Env); - when Kind_Vector => - return Eval_Vector (Ast.Sequence.all, Env); - when Kind_List => - null; - end case; - - -- Ast is a list. - if Ast.Sequence.all.Length = 0 then - return Ast; - end if; - First := Ast.Sequence.all.Data (1); - - -- Ast is a non-empty list, First is its first element. - First := Eval (First, Env); - - -- Apply phase. - -- Ast is a non-empty list, - -- First is its evaluated first element. - Err.Check (First.Kind = Kind_Builtin, - "first element must be a function"); - -- We are applying a function. Evaluate its arguments. - declare - Args : Types.T_Array (2 .. Ast.Sequence.all.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - return First.Builtin.all (Args); - end; - exception - when Err.Error => - Err.Add_Trace_Line ("eval", Ast); - raise; - end Eval; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Map) return Types.T - is - use all type Types.Maps.Cursor; - -- Copy the whole map so that keys are not hashed again. - Result : constant Types.T := Types.Maps.New_Map (Source); - Position : Types.Maps.Cursor := Result.Map.all.First; - begin - while Has_Element (Position) loop - Result.Map.all.Replace_Element (Position, - Eval (Element (Position), Env)); - Next (Position); - end loop; - return Result; - end Eval_Map; - - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Map) return Types.T - is - Ref : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Source.Length); - begin - for I in Source.Data'Range loop - Ref.all.Data (I) := Eval (Source.Data (I), Env); - end loop; - return (Kind_Vector, Ref); - end Eval_Vector; - - function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T - is (Kind_Number, Ada_Operator (Args (Args'First).Number, - Args (Args'Last).Number)); - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep (Env : in Envs.Map) is - begin - for Expression of Read loop - Print (Eval (Expression, Env)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - - function Addition is new Generic_Mal_Operator ("+"); - function Subtraction is new Generic_Mal_Operator ("-"); - function Product is new Generic_Mal_Operator ("*"); - function Division is new Generic_Mal_Operator ("/"); - - Repl : Envs.Map; -begin - Repl.Insert ("+", Addition 'Unrestricted_Access); - Repl.Insert ("-", Subtraction'Unrestricted_Access); - Repl.Insert ("*", Product 'Unrestricted_Access); - Repl.Insert ("/", Division 'Unrestricted_Access); - loop - begin - Rep (Repl); - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - -- No data survives at this stage, Repl only contains static - -- pointers to built-in functions. - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end Step2_Eval; +with Ada.Environment_Variables; +with Ada.Containers.Indefinite_Hashed_Maps; +with Ada.Strings.Hash; +with Ada.Text_IO.Unbounded_IO; + +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +procedure Step2_Eval is + + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + + use type Types.T; + use all type Types.Kind_Type; + + package Envs is new Ada.Containers.Indefinite_Hashed_Maps + (Key_Type => String, + Element_Type => Types.Builtin_Ptr, + Hash => Ada.Strings.Hash, + Equivalent_Keys => "=", + "=" => Types."="); + + function Read return Types.T_Array with Inline; + + function Eval (Ast : in Types.T; + Env : in Envs.Map) return Types.T; + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep (Env : in Envs.Map) with Inline; + + generic + with function Ada_Operator (Left, Right : in Integer) return Integer; + function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Map) return Types.T; + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Map) return Types.T; + -- Helpers for the Eval function. + + ---------------------------------------------------------------------- + + function Eval (Ast : in Types.T; + Env : in Envs.Map) return Types.T + is + First : Types.T; + begin + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + end if; + + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + return Ast; + when Kind_Symbol => + declare + S : constant String := Ast.Str.all.To_String; + C : constant Envs.Cursor := Env.Find (S); + begin + -- The predefined error message does not pass tests. + Err.Check (Envs.Has_Element (C), "'" & S & "' not found"); + return (Kind_Builtin, Envs.Element (C)); + end; + when Kind_Map => + return Eval_Map (Ast.Map.all, Env); + when Kind_Vector => + return Eval_Vector (Ast.Sequence.all, Env); + when Kind_List => + null; + end case; + + -- Ast is a list. + if Ast.Sequence.all.Length = 0 then + return Ast; + end if; + First := Ast.Sequence.all.Data (1); + + -- Ast is a non-empty list, First is its first element. + First := Eval (First, Env); + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its evaluated first element. + Err.Check (First.Kind = Kind_Builtin, + "first element must be a function"); + -- We are applying a function. Evaluate its arguments. + declare + Args : Types.T_Array (2 .. Ast.Sequence.all.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + return First.Builtin.all (Args); + end; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; + end Eval; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Map) return Types.T + is + use all type Types.Maps.Cursor; + -- Copy the whole map so that keys are not hashed again. + Result : constant Types.T := Types.Maps.New_Map (Source); + Position : Types.Maps.Cursor := Result.Map.all.First; + begin + while Has_Element (Position) loop + Result.Map.all.Replace_Element (Position, + Eval (Element (Position), Env)); + Next (Position); + end loop; + return Result; + end Eval_Map; + + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Map) return Types.T + is + Ref : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Source.Length); + begin + for I in Source.Data'Range loop + Ref.all.Data (I) := Eval (Source.Data (I), Env); + end loop; + return (Kind_Vector, Ref); + end Eval_Vector; + + function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T + is (Kind_Number, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number)); + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Map) is + begin + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + + function Addition is new Generic_Mal_Operator ("+"); + function Subtraction is new Generic_Mal_Operator ("-"); + function Product is new Generic_Mal_Operator ("*"); + function Division is new Generic_Mal_Operator ("/"); + + Repl : Envs.Map; +begin + Repl.Insert ("+", Addition 'Unrestricted_Access); + Repl.Insert ("-", Subtraction'Unrestricted_Access); + Repl.Insert ("*", Product 'Unrestricted_Access); + Repl.Insert ("/", Division 'Unrestricted_Access); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + -- No data survives at this stage, Repl only contains static + -- pointers to built-in functions. + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end Step2_Eval; diff --git a/impls/ada.2/step3_env.adb b/impls/ada.2/step3_env.adb index cee5987d7a..c1ee6d91d1 100644 --- a/impls/ada.2/step3_env.adb +++ b/impls/ada.2/step3_env.adb @@ -1,221 +1,221 @@ -with Ada.Environment_Variables; -with Ada.Text_IO.Unbounded_IO; - -with Envs; -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -procedure Step3_Env is - - Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); - - use type Types.T; - use all type Types.Kind_Type; - use type Types.Strings.Instance; - - function Read return Types.T_Array with Inline; - - function Eval (Ast : in Types.T; - Env : in Envs.Ptr) return Types.T; - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep (Env : in Envs.Ptr) with Inline; - - generic - with function Ada_Operator (Left, Right : in Integer) return Integer; - function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T; - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T; - -- Helpers for the Eval function. - - ---------------------------------------------------------------------- - - function Eval (Ast : in Types.T; - Env : in Envs.Ptr) return Types.T - is - First : Types.T; - begin - if Dbgeval then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put ("EVAL: "); - Print (Ast); - Envs.Dump_Stack (Env.all); - end if; - - case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - return Ast; - when Kind_Symbol => - return Env.all.Get (Ast.Str); - when Kind_Map => - return Eval_Map (Ast.Map.all, Env); - when Kind_Vector => - return Eval_Vector (Ast.Sequence.all, Env); - when Kind_List => - null; - end case; - - -- Ast is a list. - if Ast.Sequence.all.Length = 0 then - return Ast; - end if; - First := Ast.Sequence.all.Data (1); - - -- Special forms - -- Ast is a non-empty list, First is its first element. - case First.Kind is - when Kind_Symbol => - if First.Str.all = "let*" then - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, - "expected a sequence then a value"); - declare - Bindings : Types.T_Array - renames Ast.Sequence.all.Data (2).Sequence.all.Data; - New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env); - begin - Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); - for I in 0 .. Bindings'Length / 2 - 1 loop - New_Env.all.Set (Bindings (Bindings'First + 2 * I), - Eval (Bindings (Bindings'First + 2 * I + 1), New_Env)); - -- This call checks key kind. - end loop; - return Eval (Ast.Sequence.all.Data (3), New_Env); - end; - elsif First.Str.all = "def!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - begin - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - else - First := Eval (First, Env); - end if; - when others => - First := Eval (First, Env); - end case; - - -- Apply phase. - -- Ast is a non-empty list, - -- First is its non-special evaluated first element. - Err.Check (First.Kind = Kind_Builtin, - "first element must be a function"); - -- We are applying a function. Evaluate its arguments. - declare - Args : Types.T_Array (2 .. Ast.Sequence.all.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - return First.Builtin.all (Args); - end; - exception - when Err.Error => - Err.Add_Trace_Line ("eval", Ast); - raise; - end Eval; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T - is - use all type Types.Maps.Cursor; - -- Copy the whole map so that keys are not hashed again. - Result : constant Types.T := Types.Maps.New_Map (Source); - Position : Types.Maps.Cursor := Result.Map.all.First; - begin - while Has_Element (Position) loop - Result.Map.all.Replace_Element (Position, - Eval (Element (Position), Env)); - Next (Position); - end loop; - return Result; - end Eval_Map; - - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T - is - Ref : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Source.Length); - begin - for I in Source.Data'Range loop - Ref.all.Data (I) := Eval (Source.Data (I), Env); - end loop; - return (Kind_Vector, Ref); - end Eval_Vector; - - function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T - is (Kind_Number, Ada_Operator (Args (Args'First).Number, - Args (Args'Last).Number)); - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep (Env : in Envs.Ptr) is - begin - for Expression of Read loop - Print (Eval (Expression, Env)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - - function Addition is new Generic_Mal_Operator ("+"); - function Subtraction is new Generic_Mal_Operator ("-"); - function Product is new Generic_Mal_Operator ("*"); - function Division is new Generic_Mal_Operator ("/"); - - Repl : constant Envs.Ptr := Envs.New_Env; -begin - -- Add Core functions into the top environment. - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("+")), - (Kind_Builtin, Addition 'Unrestricted_Access)); - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("-")), - (Kind_Builtin, Subtraction'Unrestricted_Access)); - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*")), - (Kind_Builtin, Product 'Unrestricted_Access)); - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("/")), - (Kind_Builtin, Division 'Unrestricted_Access)); - -- Execute user commands. - loop - begin - Rep (Repl); - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - Repl.all.Keep; - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end Step3_Env; +with Ada.Environment_Variables; +with Ada.Text_IO.Unbounded_IO; + +with Envs; +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +procedure Step3_Env is + + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + + use type Types.T; + use all type Types.Kind_Type; + use type Types.Strings.Instance; + + function Read return Types.T_Array with Inline; + + function Eval (Ast : in Types.T; + Env : in Envs.Ptr) return Types.T; + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep (Env : in Envs.Ptr) with Inline; + + generic + with function Ada_Operator (Left, Right : in Integer) return Integer; + function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T; + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T; + -- Helpers for the Eval function. + + ---------------------------------------------------------------------- + + function Eval (Ast : in Types.T; + Env : in Envs.Ptr) return Types.T + is + First : Types.T; + begin + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + Envs.Dump_Stack (Env.all); + end if; + + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + return Ast; + when Kind_Symbol => + return Env.all.Get (Ast.Str); + when Kind_Map => + return Eval_Map (Ast.Map.all, Env); + when Kind_Vector => + return Eval_Vector (Ast.Sequence.all, Env); + when Kind_List => + null; + end case; + + -- Ast is a list. + if Ast.Sequence.all.Length = 0 then + return Ast; + end if; + First := Ast.Sequence.all.Data (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Str.all = "let*" then + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, + "expected a sequence then a value"); + declare + Bindings : Types.T_Array + renames Ast.Sequence.all.Data (2).Sequence.all.Data; + New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env); + begin + Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); + for I in 0 .. Bindings'Length / 2 - 1 loop + New_Env.all.Set (Bindings (Bindings'First + 2 * I), + Eval (Bindings (Bindings'First + 2 * I + 1), New_Env)); + -- This call checks key kind. + end loop; + return Eval (Ast.Sequence.all.Data (3), New_Env); + end; + elsif First.Str.all = "def!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + begin + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + else + First := Eval (First, Env); + end if; + when others => + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + Err.Check (First.Kind = Kind_Builtin, + "first element must be a function"); + -- We are applying a function. Evaluate its arguments. + declare + Args : Types.T_Array (2 .. Ast.Sequence.all.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + return First.Builtin.all (Args); + end; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; + end Eval; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T + is + use all type Types.Maps.Cursor; + -- Copy the whole map so that keys are not hashed again. + Result : constant Types.T := Types.Maps.New_Map (Source); + Position : Types.Maps.Cursor := Result.Map.all.First; + begin + while Has_Element (Position) loop + Result.Map.all.Replace_Element (Position, + Eval (Element (Position), Env)); + Next (Position); + end loop; + return Result; + end Eval_Map; + + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T + is + Ref : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Source.Length); + begin + for I in Source.Data'Range loop + Ref.all.Data (I) := Eval (Source.Data (I), Env); + end loop; + return (Kind_Vector, Ref); + end Eval_Vector; + + function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T + is (Kind_Number, Ada_Operator (Args (Args'First).Number, + Args (Args'Last).Number)); + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + + function Addition is new Generic_Mal_Operator ("+"); + function Subtraction is new Generic_Mal_Operator ("-"); + function Product is new Generic_Mal_Operator ("*"); + function Division is new Generic_Mal_Operator ("/"); + + Repl : constant Envs.Ptr := Envs.New_Env; +begin + -- Add Core functions into the top environment. + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("+")), + (Kind_Builtin, Addition 'Unrestricted_Access)); + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("-")), + (Kind_Builtin, Subtraction'Unrestricted_Access)); + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*")), + (Kind_Builtin, Product 'Unrestricted_Access)); + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("/")), + (Kind_Builtin, Division 'Unrestricted_Access)); + -- Execute user commands. + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end Step3_Env; diff --git a/impls/ada.2/step4_if_fn_do.adb b/impls/ada.2/step4_if_fn_do.adb index 687e1c2e27..108c80f5f7 100644 --- a/impls/ada.2/step4_if_fn_do.adb +++ b/impls/ada.2/step4_if_fn_do.adb @@ -1,263 +1,263 @@ -with Ada.Environment_Variables; -with Ada.Text_IO.Unbounded_IO; - -with Core; -with Envs; -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types.Fns; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -procedure Step4_If_Fn_Do is - - Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); - - use type Types.T; - use all type Types.Kind_Type; - use type Types.Strings.Instance; - - function Read return Types.T_Array with Inline; - - function Eval (Ast : in Types.T; - Env : in Envs.Ptr) return Types.T; - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep (Env : in Envs.Ptr) with Inline; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T; - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T; - -- Helpers for the Eval function. - - procedure Exec (Script : in String; - Env : in Envs.Ptr) with Inline; - -- Read the script, eval its elements, but ignore the result. - - ---------------------------------------------------------------------- - - function Eval (Ast : in Types.T; - Env : in Envs.Ptr) return Types.T - is - First : Types.T; - begin - if Dbgeval then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put ("EVAL: "); - Print (Ast); - Envs.Dump_Stack (Env.all); - end if; - - case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - return Ast; - when Kind_Symbol => - return Env.all.Get (Ast.Str); - when Kind_Map => - return Eval_Map (Ast.Map.all, Env); - when Kind_Vector => - return Eval_Vector (Ast.Sequence.all, Env); - when Kind_List => - null; - end case; - - -- Ast is a list. - if Ast.Sequence.all.Length = 0 then - return Ast; - end if; - First := Ast.Sequence.all.Data (1); - - -- Special forms - -- Ast is a non-empty list, First is its first element. - case First.Kind is - when Kind_Symbol => - if First.Str.all = "if" then - Err.Check (Ast.Sequence.all.Length in 3 .. 4, - "expected 2 or 3 parameters"); - declare - Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); - begin - if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then - return Eval (Ast.Sequence.all.Data (3), Env); - elsif Ast.Sequence.all.Length = 3 then - return Types.Nil; - else - return Eval (Ast.Sequence.all.Data (4), Env); - end if; - end; - elsif First.Str.all = "let*" then - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, - "expected a sequence then a value"); - declare - Bindings : Types.T_Array - renames Ast.Sequence.all.Data (2).Sequence.all.Data; - New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env); - begin - Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); - for I in 0 .. Bindings'Length / 2 - 1 loop - New_Env.all.Set (Bindings (Bindings'First + 2 * I), - Eval (Bindings (Bindings'First + 2 * I + 1), New_Env)); - -- This call checks key kind. - end loop; - return Eval (Ast.Sequence.all.Data (3), New_Env); - end; - elsif First.Str.all = "def!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - begin - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "do" then - Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); - declare - Result : Types.T; - begin - for I in 2 .. Ast.Sequence.all.Length loop - Result := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - return Result; - end; - elsif First.Str.all = "fn*" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Params : Types.T renames Ast.Sequence.all.Data (2); - begin - Err.Check (Params.Kind in Types.Kind_Sequence, - "first argument of fn* must be a sequence"); - return (Kind_Fn, Types.Fns.New_Function - (Params => Params.Sequence, - Ast => Ast.Sequence.all.Data (3), - Env => Env)); - end; - else - First := Eval (First, Env); - end if; - when others => - First := Eval (First, Env); - end case; - - -- Apply phase. - -- Ast is a non-empty list, - -- First is its non-special evaluated first element. - Err.Check (First.Kind in Types.Kind_Function, - "first element must be a function"); - -- We are applying a function. Evaluate its arguments. - declare - Args : Types.T_Array (2 .. Ast.Sequence.all.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - if First.Kind = Kind_Builtin then - return First.Builtin.all (Args); - end if; - return First.Fn.all.Apply (Args); - end; - exception - when Err.Error => - Err.Add_Trace_Line ("eval", Ast); - raise; - end Eval; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T - is - use all type Types.Maps.Cursor; - -- Copy the whole map so that keys are not hashed again. - Result : constant Types.T := Types.Maps.New_Map (Source); - Position : Types.Maps.Cursor := Result.Map.all.First; - begin - while Has_Element (Position) loop - Result.Map.all.Replace_Element (Position, - Eval (Element (Position), Env)); - Next (Position); - end loop; - return Result; - end Eval_Map; - - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T - is - Ref : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Source.Length); - begin - for I in Source.Data'Range loop - Ref.all.Data (I) := Eval (Source.Data (I), Env); - end loop; - return (Kind_Vector, Ref); - end Eval_Vector; - - procedure Exec (Script : in String; - Env : in Envs.Ptr) - is - Result : Types.T; - begin - for Expression of Reader.Read_Str (Script) loop - Result := Eval (Expression, Env); - end loop; - pragma Unreferenced (Result); - end Exec; - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep (Env : in Envs.Ptr) is - begin - for Expression of Read loop - Print (Eval (Expression, Env)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - - Startup : constant String - := "(def! not (fn* (a) (if a false true)))"; - Repl : constant Envs.Ptr := Envs.New_Env; -begin - -- Show the Eval function to other packages. - Types.Fns.Eval_Cb := Eval'Unrestricted_Access; - -- Add Core functions into the top environment. - Core.NS_Add_To_Repl (Repl); - -- Native startup procedure. - Exec (Startup, Repl); - -- Execute user commands. - loop - begin - Rep (Repl); - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - Repl.all.Keep; - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end Step4_If_Fn_Do; +with Ada.Environment_Variables; +with Ada.Text_IO.Unbounded_IO; + +with Core; +with Envs; +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types.Fns; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +procedure Step4_If_Fn_Do is + + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + + use type Types.T; + use all type Types.Kind_Type; + use type Types.Strings.Instance; + + function Read return Types.T_Array with Inline; + + function Eval (Ast : in Types.T; + Env : in Envs.Ptr) return Types.T; + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep (Env : in Envs.Ptr) with Inline; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T; + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T; + -- Helpers for the Eval function. + + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. + + ---------------------------------------------------------------------- + + function Eval (Ast : in Types.T; + Env : in Envs.Ptr) return Types.T + is + First : Types.T; + begin + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + Envs.Dump_Stack (Env.all); + end if; + + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + return Ast; + when Kind_Symbol => + return Env.all.Get (Ast.Str); + when Kind_Map => + return Eval_Map (Ast.Map.all, Env); + when Kind_Vector => + return Eval_Vector (Ast.Sequence.all, Env); + when Kind_List => + null; + end case; + + -- Ast is a list. + if Ast.Sequence.all.Length = 0 then + return Ast; + end if; + First := Ast.Sequence.all.Data (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Str.all = "if" then + Err.Check (Ast.Sequence.all.Length in 3 .. 4, + "expected 2 or 3 parameters"); + declare + Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); + begin + if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then + return Eval (Ast.Sequence.all.Data (3), Env); + elsif Ast.Sequence.all.Length = 3 then + return Types.Nil; + else + return Eval (Ast.Sequence.all.Data (4), Env); + end if; + end; + elsif First.Str.all = "let*" then + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, + "expected a sequence then a value"); + declare + Bindings : Types.T_Array + renames Ast.Sequence.all.Data (2).Sequence.all.Data; + New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env); + begin + Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); + for I in 0 .. Bindings'Length / 2 - 1 loop + New_Env.all.Set (Bindings (Bindings'First + 2 * I), + Eval (Bindings (Bindings'First + 2 * I + 1), New_Env)); + -- This call checks key kind. + end loop; + return Eval (Ast.Sequence.all.Data (3), New_Env); + end; + elsif First.Str.all = "def!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + begin + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "do" then + Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); + declare + Result : Types.T; + begin + for I in 2 .. Ast.Sequence.all.Length loop + Result := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + return Result; + end; + elsif First.Str.all = "fn*" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Params : Types.T renames Ast.Sequence.all.Data (2); + begin + Err.Check (Params.Kind in Types.Kind_Sequence, + "first argument of fn* must be a sequence"); + return (Kind_Fn, Types.Fns.New_Function + (Params => Params.Sequence, + Ast => Ast.Sequence.all.Data (3), + Env => Env)); + end; + else + First := Eval (First, Env); + end if; + when others => + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + Err.Check (First.Kind in Types.Kind_Function, + "first element must be a function"); + -- We are applying a function. Evaluate its arguments. + declare + Args : Types.T_Array (2 .. Ast.Sequence.all.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + if First.Kind = Kind_Builtin then + return First.Builtin.all (Args); + end if; + return First.Fn.all.Apply (Args); + end; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; + end Eval; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T + is + use all type Types.Maps.Cursor; + -- Copy the whole map so that keys are not hashed again. + Result : constant Types.T := Types.Maps.New_Map (Source); + Position : Types.Maps.Cursor := Result.Map.all.First; + begin + while Has_Element (Position) loop + Result.Map.all.Replace_Element (Position, + Eval (Element (Position), Env)); + Next (Position); + end loop; + return Result; + end Eval_Map; + + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T + is + Ref : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Source.Length); + begin + for I in Source.Data'Range loop + Ref.all.Data (I) := Eval (Source.Data (I), Env); + end loop; + return (Kind_Vector, Ref); + end Eval_Vector; + + procedure Exec (Script : in String; + Env : in Envs.Ptr) + is + Result : Types.T; + begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; + pragma Unreferenced (Result); + end Exec; + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + + Startup : constant String + := "(def! not (fn* (a) (if a false true)))"; + Repl : constant Envs.Ptr := Envs.New_Env; +begin + -- Show the Eval function to other packages. + Types.Fns.Eval_Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + Core.NS_Add_To_Repl (Repl); + -- Native startup procedure. + Exec (Startup, Repl); + -- Execute user commands. + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end Step4_If_Fn_Do; diff --git a/impls/ada.2/step5_tco.adb b/impls/ada.2/step5_tco.adb index b69dbe3853..cd03173f4c 100644 --- a/impls/ada.2/step5_tco.adb +++ b/impls/ada.2/step5_tco.adb @@ -1,296 +1,296 @@ -with Ada.Environment_Variables; -with Ada.Text_IO.Unbounded_IO; - -with Core; -with Envs; -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types.Fns; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -procedure Step5_Tco is - - Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); - - use type Types.T; - use all type Types.Kind_Type; - use type Types.Strings.Instance; - - function Read return Types.T_Array with Inline; - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T; - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep (Env : in Envs.Ptr) with Inline; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T; - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T; - -- Helpers for the Eval function. - - procedure Exec (Script : in String; - Env : in Envs.Ptr) with Inline; - -- Read the script, eval its elements, but ignore the result. - - ---------------------------------------------------------------------- - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T - is - -- Use local variables, that can be rewritten when tail call - -- optimization goes to <>. - Ast : Types.T := Ast0; - Env : Envs.Ptr := Env0; - Env_Reusable : Boolean := False; - -- True when the environment has been created in this recursion - -- level, and has not yet been referenced by a closure. If so, - -- we can reuse it instead of creating a subenvironment. - First : Types.T; - begin - <> - if Dbgeval then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put ("EVAL: "); - Print (Ast); - Envs.Dump_Stack (Env.all); - end if; - - case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - return Ast; - when Kind_Symbol => - return Env.all.Get (Ast.Str); - when Kind_Map => - return Eval_Map (Ast.Map.all, Env); - when Kind_Vector => - return Eval_Vector (Ast.Sequence.all, Env); - when Kind_List => - null; - end case; - - -- Ast is a list. - if Ast.Sequence.all.Length = 0 then - return Ast; - end if; - First := Ast.Sequence.all.Data (1); - - -- Special forms - -- Ast is a non-empty list, First is its first element. - case First.Kind is - when Kind_Symbol => - if First.Str.all = "if" then - Err.Check (Ast.Sequence.all.Length in 3 .. 4, - "expected 2 or 3 parameters"); - declare - Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); - begin - if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then - Ast := Ast.Sequence.all.Data (3); - goto Restart; - elsif Ast.Sequence.all.Length = 3 then - return Types.Nil; - else - Ast := Ast.Sequence.all.Data (4); - goto Restart; - end if; - end; - elsif First.Str.all = "let*" then - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, - "expected a sequence then a value"); - declare - Bindings : Types.T_Array - renames Ast.Sequence.all.Data (2).Sequence.all.Data; - begin - Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); - if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); - Env_Reusable := True; - end if; - for I in 0 .. Bindings'Length / 2 - 1 loop - Env.all.Set (Bindings (Bindings'First + 2 * I), - Eval (Bindings (Bindings'First + 2 * I + 1), Env)); - -- This call checks key kind. - end loop; - Ast := Ast.Sequence.all.Data (3); - goto Restart; - end; - elsif First.Str.all = "def!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - begin - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "do" then - Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); - declare - Result : Types.T; - begin - for I in 2 .. Ast.Sequence.all.Length - 1 loop - Result := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - pragma Unreferenced (Result); - end; - Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); - goto Restart; - elsif First.Str.all = "fn*" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Params : Types.T renames Ast.Sequence.all.Data (2); - begin - Err.Check (Params.Kind in Types.Kind_Sequence, - "first argument of fn* must be a sequence"); - Env_Reusable := False; - return (Kind_Fn, Types.Fns.New_Function - (Params => Params.Sequence, - Ast => Ast.Sequence.all.Data (3), - Env => Env)); - end; - else - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - First := Env.all.Get (First.Str); - end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - null; - when Types.Kind_Sequence | Kind_Map => - -- Lists are definitely worth a recursion, and the two other - -- cases should be rare (they will report an error later). - First := Eval (First, Env); - end case; - - -- Apply phase. - -- Ast is a non-empty list, - -- First is its non-special evaluated first element. - Err.Check (First.Kind in Types.Kind_Function, - "first element must be a function"); - -- We are applying a function. Evaluate its arguments. - declare - Args : Types.T_Array (2 .. Ast.Sequence.all.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - if First.Kind = Kind_Builtin then - return First.Builtin.all (Args); - end if; - -- Like Types.Fns.Apply, except that we use TCO. - Env := Envs.New_Env (Outer => First.Fn.all.Env); - Env_Reusable := True; - Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, - Exprs => Args); - Ast := First.Fn.all.Ast; - goto Restart; - end; - exception - when Err.Error => - Err.Add_Trace_Line ("eval", Ast); - raise; - end Eval; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T - is - use all type Types.Maps.Cursor; - -- Copy the whole map so that keys are not hashed again. - Result : constant Types.T := Types.Maps.New_Map (Source); - Position : Types.Maps.Cursor := Result.Map.all.First; - begin - while Has_Element (Position) loop - Result.Map.all.Replace_Element (Position, - Eval (Element (Position), Env)); - Next (Position); - end loop; - return Result; - end Eval_Map; - - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T - is - Ref : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Source.Length); - begin - for I in Source.Data'Range loop - Ref.all.Data (I) := Eval (Source.Data (I), Env); - end loop; - return (Kind_Vector, Ref); - end Eval_Vector; - - procedure Exec (Script : in String; - Env : in Envs.Ptr) - is - Result : Types.T; - begin - for Expression of Reader.Read_Str (Script) loop - Result := Eval (Expression, Env); - end loop; - pragma Unreferenced (Result); - end Exec; - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep (Env : in Envs.Ptr) is - begin - for Expression of Read loop - Print (Eval (Expression, Env)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - - Startup : constant String - := "(def! not (fn* (a) (if a false true)))"; - Repl : constant Envs.Ptr := Envs.New_Env; -begin - -- Show the Eval function to other packages. - Types.Fns.Eval_Cb := Eval'Unrestricted_Access; - -- Add Core functions into the top environment. - Core.NS_Add_To_Repl (Repl); - -- Native startup procedure. - Exec (Startup, Repl); - -- Execute user commands. - loop - begin - Rep (Repl); - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - Repl.all.Keep; - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end Step5_Tco; +with Ada.Environment_Variables; +with Ada.Text_IO.Unbounded_IO; + +with Core; +with Envs; +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types.Fns; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +procedure Step5_Tco is + + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + + use type Types.T; + use all type Types.Kind_Type; + use type Types.Strings.Instance; + + function Read return Types.T_Array with Inline; + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T; + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep (Env : in Envs.Ptr) with Inline; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T; + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T; + -- Helpers for the Eval function. + + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. + + ---------------------------------------------------------------------- + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T + is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Types.T := Ast0; + Env : Envs.Ptr := Env0; + Env_Reusable : Boolean := False; + -- True when the environment has been created in this recursion + -- level, and has not yet been referenced by a closure. If so, + -- we can reuse it instead of creating a subenvironment. + First : Types.T; + begin + <> + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + Envs.Dump_Stack (Env.all); + end if; + + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + return Ast; + when Kind_Symbol => + return Env.all.Get (Ast.Str); + when Kind_Map => + return Eval_Map (Ast.Map.all, Env); + when Kind_Vector => + return Eval_Vector (Ast.Sequence.all, Env); + when Kind_List => + null; + end case; + + -- Ast is a list. + if Ast.Sequence.all.Length = 0 then + return Ast; + end if; + First := Ast.Sequence.all.Data (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Str.all = "if" then + Err.Check (Ast.Sequence.all.Length in 3 .. 4, + "expected 2 or 3 parameters"); + declare + Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); + begin + if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then + Ast := Ast.Sequence.all.Data (3); + goto Restart; + elsif Ast.Sequence.all.Length = 3 then + return Types.Nil; + else + Ast := Ast.Sequence.all.Data (4); + goto Restart; + end if; + end; + elsif First.Str.all = "let*" then + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, + "expected a sequence then a value"); + declare + Bindings : Types.T_Array + renames Ast.Sequence.all.Data (2).Sequence.all.Data; + begin + Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); + if not Env_Reusable then + Env := Envs.New_Env (Outer => Env); + Env_Reusable := True; + end if; + for I in 0 .. Bindings'Length / 2 - 1 loop + Env.all.Set (Bindings (Bindings'First + 2 * I), + Eval (Bindings (Bindings'First + 2 * I + 1), Env)); + -- This call checks key kind. + end loop; + Ast := Ast.Sequence.all.Data (3); + goto Restart; + end; + elsif First.Str.all = "def!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + begin + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "do" then + Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); + declare + Result : Types.T; + begin + for I in 2 .. Ast.Sequence.all.Length - 1 loop + Result := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + pragma Unreferenced (Result); + end; + Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); + goto Restart; + elsif First.Str.all = "fn*" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Params : Types.T renames Ast.Sequence.all.Data (2); + begin + Err.Check (Params.Kind in Types.Kind_Sequence, + "first argument of fn* must be a sequence"); + Env_Reusable := False; + return (Kind_Fn, Types.Fns.New_Function + (Params => Params.Sequence, + Ast => Ast.Sequence.all.Data (3), + Env => Env)); + end; + else + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + First := Env.all.Get (First.Str); + end if; + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Types.Kind_Sequence | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + Err.Check (First.Kind in Types.Kind_Function, + "first element must be a function"); + -- We are applying a function. Evaluate its arguments. + declare + Args : Types.T_Array (2 .. Ast.Sequence.all.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + if First.Kind = Kind_Builtin then + return First.Builtin.all (Args); + end if; + -- Like Types.Fns.Apply, except that we use TCO. + Env := Envs.New_Env (Outer => First.Fn.all.Env); + Env_Reusable := True; + Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, + Exprs => Args); + Ast := First.Fn.all.Ast; + goto Restart; + end; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; + end Eval; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T + is + use all type Types.Maps.Cursor; + -- Copy the whole map so that keys are not hashed again. + Result : constant Types.T := Types.Maps.New_Map (Source); + Position : Types.Maps.Cursor := Result.Map.all.First; + begin + while Has_Element (Position) loop + Result.Map.all.Replace_Element (Position, + Eval (Element (Position), Env)); + Next (Position); + end loop; + return Result; + end Eval_Map; + + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T + is + Ref : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Source.Length); + begin + for I in Source.Data'Range loop + Ref.all.Data (I) := Eval (Source.Data (I), Env); + end loop; + return (Kind_Vector, Ref); + end Eval_Vector; + + procedure Exec (Script : in String; + Env : in Envs.Ptr) + is + Result : Types.T; + begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; + pragma Unreferenced (Result); + end Exec; + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + + Startup : constant String + := "(def! not (fn* (a) (if a false true)))"; + Repl : constant Envs.Ptr := Envs.New_Env; +begin + -- Show the Eval function to other packages. + Types.Fns.Eval_Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + Core.NS_Add_To_Repl (Repl); + -- Native startup procedure. + Exec (Startup, Repl); + -- Execute user commands. + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end Step5_Tco; diff --git a/impls/ada.2/step6_file.adb b/impls/ada.2/step6_file.adb index 18cc6a92e8..b44fa24746 100644 --- a/impls/ada.2/step6_file.adb +++ b/impls/ada.2/step6_file.adb @@ -1,323 +1,323 @@ -with Ada.Command_Line; -with Ada.Environment_Variables; -with Ada.Text_IO.Unbounded_IO; - -with Core; -with Envs; -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types.Fns; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -procedure Step6_File is - - Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); - - use type Types.T; - use all type Types.Kind_Type; - use type Types.Strings.Instance; - package ACL renames Ada.Command_Line; - - function Read return Types.T_Array with Inline; - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T; - function Eval_Builtin (Args : in Types.T_Array) return Types.T; - -- The built-in variant needs to see the Repl variable. - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep (Env : in Envs.Ptr) with Inline; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T; - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T; - -- Helpers for the Eval function. - - procedure Exec (Script : in String; - Env : in Envs.Ptr) with Inline; - -- Read the script, eval its elements, but ignore the result. - - ---------------------------------------------------------------------- - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T - is - -- Use local variables, that can be rewritten when tail call - -- optimization goes to <>. - Ast : Types.T := Ast0; - Env : Envs.Ptr := Env0; - Env_Reusable : Boolean := False; - -- True when the environment has been created in this recursion - -- level, and has not yet been referenced by a closure. If so, - -- we can reuse it instead of creating a subenvironment. - First : Types.T; - begin - <> - if Dbgeval then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put ("EVAL: "); - Print (Ast); - Envs.Dump_Stack (Env.all); - end if; - - case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - return Ast; - when Kind_Symbol => - return Env.all.Get (Ast.Str); - when Kind_Map => - return Eval_Map (Ast.Map.all, Env); - when Kind_Vector => - return Eval_Vector (Ast.Sequence.all, Env); - when Kind_List => - null; - end case; - - -- Ast is a list. - if Ast.Sequence.all.Length = 0 then - return Ast; - end if; - First := Ast.Sequence.all.Data (1); - - -- Special forms - -- Ast is a non-empty list, First is its first element. - case First.Kind is - when Kind_Symbol => - if First.Str.all = "if" then - Err.Check (Ast.Sequence.all.Length in 3 .. 4, - "expected 2 or 3 parameters"); - declare - Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); - begin - if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then - Ast := Ast.Sequence.all.Data (3); - goto Restart; - elsif Ast.Sequence.all.Length = 3 then - return Types.Nil; - else - Ast := Ast.Sequence.all.Data (4); - goto Restart; - end if; - end; - elsif First.Str.all = "let*" then - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, - "expected a sequence then a value"); - declare - Bindings : Types.T_Array - renames Ast.Sequence.all.Data (2).Sequence.all.Data; - begin - Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); - if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); - Env_Reusable := True; - end if; - for I in 0 .. Bindings'Length / 2 - 1 loop - Env.all.Set (Bindings (Bindings'First + 2 * I), - Eval (Bindings (Bindings'First + 2 * I + 1), Env)); - -- This call checks key kind. - end loop; - Ast := Ast.Sequence.all.Data (3); - goto Restart; - end; - elsif First.Str.all = "def!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - begin - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "do" then - Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); - declare - Result : Types.T; - begin - for I in 2 .. Ast.Sequence.all.Length - 1 loop - Result := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - pragma Unreferenced (Result); - end; - Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); - goto Restart; - elsif First.Str.all = "fn*" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Params : Types.T renames Ast.Sequence.all.Data (2); - begin - Err.Check (Params.Kind in Types.Kind_Sequence, - "first argument of fn* must be a sequence"); - Env_Reusable := False; - return (Kind_Fn, Types.Fns.New_Function - (Params => Params.Sequence, - Ast => Ast.Sequence.all.Data (3), - Env => Env)); - end; - else - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - First := Env.all.Get (First.Str); - end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - null; - when Types.Kind_Sequence | Kind_Map => - -- Lists are definitely worth a recursion, and the two other - -- cases should be rare (they will report an error later). - First := Eval (First, Env); - end case; - - -- Apply phase. - -- Ast is a non-empty list, - -- First is its non-special evaluated first element. - Err.Check (First.Kind in Types.Kind_Function, - "first element must be a function"); - -- We are applying a function. Evaluate its arguments. - declare - Args : Types.T_Array (2 .. Ast.Sequence.all.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - if First.Kind = Kind_Builtin then - return First.Builtin.all (Args); - end if; - -- Like Types.Fns.Apply, except that we use TCO. - Env := Envs.New_Env (Outer => First.Fn.all.Env); - Env_Reusable := True; - Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, - Exprs => Args); - Ast := First.Fn.all.Ast; - goto Restart; - end; - exception - when Err.Error => - Err.Add_Trace_Line ("eval", Ast); - raise; - end Eval; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T - is - use all type Types.Maps.Cursor; - -- Copy the whole map so that keys are not hashed again. - Result : constant Types.T := Types.Maps.New_Map (Source); - Position : Types.Maps.Cursor := Result.Map.all.First; - begin - while Has_Element (Position) loop - Result.Map.all.Replace_Element (Position, - Eval (Element (Position), Env)); - Next (Position); - end loop; - return Result; - end Eval_Map; - - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T - is - Ref : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Source.Length); - begin - for I in Source.Data'Range loop - Ref.all.Data (I) := Eval (Source.Data (I), Env); - end loop; - return (Kind_Vector, Ref); - end Eval_Vector; - - procedure Exec (Script : in String; - Env : in Envs.Ptr) - is - Result : Types.T; - begin - for Expression of Reader.Read_Str (Script) loop - Result := Eval (Expression, Env); - end loop; - pragma Unreferenced (Result); - end Exec; - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep (Env : in Envs.Ptr) is - begin - for Expression of Read loop - Print (Eval (Expression, Env)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - - Startup : constant String - := "(def! not (fn* (a) (if a false true)))" - & "(def! load-file (fn* (f)" - & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"; - Repl : constant Envs.Ptr := Envs.New_Env; - function Eval_Builtin (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return Eval (Args (Args'First), Repl); - end Eval_Builtin; - Script : constant Boolean := 0 < ACL.Argument_Count; - Argv : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); -begin - -- Show the Eval function to other packages. - Types.Fns.Eval_Cb := Eval'Unrestricted_Access; - -- Add Core functions into the top environment. - Core.NS_Add_To_Repl (Repl); - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), - (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); - -- Native startup procedure. - Exec (Startup, Repl); - -- Define ARGV from command line arguments. - for I in 2 .. ACL.Argument_Count loop - Argv.all.Data (I - 1) := (Kind_String, - Types.Strings.Alloc (ACL.Argument (I))); - end loop; - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), - (Kind_List, Argv)); - -- Execute user commands. - if Script then - Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); - else - loop - begin - Rep (Repl); - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - Repl.all.Keep; - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - end if; - - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end Step6_File; +with Ada.Command_Line; +with Ada.Environment_Variables; +with Ada.Text_IO.Unbounded_IO; + +with Core; +with Envs; +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types.Fns; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +procedure Step6_File is + + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + + use type Types.T; + use all type Types.Kind_Type; + use type Types.Strings.Instance; + package ACL renames Ada.Command_Line; + + function Read return Types.T_Array with Inline; + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T; + function Eval_Builtin (Args : in Types.T_Array) return Types.T; + -- The built-in variant needs to see the Repl variable. + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep (Env : in Envs.Ptr) with Inline; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T; + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T; + -- Helpers for the Eval function. + + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. + + ---------------------------------------------------------------------- + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T + is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Types.T := Ast0; + Env : Envs.Ptr := Env0; + Env_Reusable : Boolean := False; + -- True when the environment has been created in this recursion + -- level, and has not yet been referenced by a closure. If so, + -- we can reuse it instead of creating a subenvironment. + First : Types.T; + begin + <> + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + Envs.Dump_Stack (Env.all); + end if; + + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + return Ast; + when Kind_Symbol => + return Env.all.Get (Ast.Str); + when Kind_Map => + return Eval_Map (Ast.Map.all, Env); + when Kind_Vector => + return Eval_Vector (Ast.Sequence.all, Env); + when Kind_List => + null; + end case; + + -- Ast is a list. + if Ast.Sequence.all.Length = 0 then + return Ast; + end if; + First := Ast.Sequence.all.Data (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Str.all = "if" then + Err.Check (Ast.Sequence.all.Length in 3 .. 4, + "expected 2 or 3 parameters"); + declare + Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); + begin + if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then + Ast := Ast.Sequence.all.Data (3); + goto Restart; + elsif Ast.Sequence.all.Length = 3 then + return Types.Nil; + else + Ast := Ast.Sequence.all.Data (4); + goto Restart; + end if; + end; + elsif First.Str.all = "let*" then + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, + "expected a sequence then a value"); + declare + Bindings : Types.T_Array + renames Ast.Sequence.all.Data (2).Sequence.all.Data; + begin + Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); + if not Env_Reusable then + Env := Envs.New_Env (Outer => Env); + Env_Reusable := True; + end if; + for I in 0 .. Bindings'Length / 2 - 1 loop + Env.all.Set (Bindings (Bindings'First + 2 * I), + Eval (Bindings (Bindings'First + 2 * I + 1), Env)); + -- This call checks key kind. + end loop; + Ast := Ast.Sequence.all.Data (3); + goto Restart; + end; + elsif First.Str.all = "def!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + begin + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "do" then + Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); + declare + Result : Types.T; + begin + for I in 2 .. Ast.Sequence.all.Length - 1 loop + Result := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + pragma Unreferenced (Result); + end; + Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); + goto Restart; + elsif First.Str.all = "fn*" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Params : Types.T renames Ast.Sequence.all.Data (2); + begin + Err.Check (Params.Kind in Types.Kind_Sequence, + "first argument of fn* must be a sequence"); + Env_Reusable := False; + return (Kind_Fn, Types.Fns.New_Function + (Params => Params.Sequence, + Ast => Ast.Sequence.all.Data (3), + Env => Env)); + end; + else + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + First := Env.all.Get (First.Str); + end if; + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Types.Kind_Sequence | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + Err.Check (First.Kind in Types.Kind_Function, + "first element must be a function"); + -- We are applying a function. Evaluate its arguments. + declare + Args : Types.T_Array (2 .. Ast.Sequence.all.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + if First.Kind = Kind_Builtin then + return First.Builtin.all (Args); + end if; + -- Like Types.Fns.Apply, except that we use TCO. + Env := Envs.New_Env (Outer => First.Fn.all.Env); + Env_Reusable := True; + Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, + Exprs => Args); + Ast := First.Fn.all.Ast; + goto Restart; + end; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; + end Eval; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T + is + use all type Types.Maps.Cursor; + -- Copy the whole map so that keys are not hashed again. + Result : constant Types.T := Types.Maps.New_Map (Source); + Position : Types.Maps.Cursor := Result.Map.all.First; + begin + while Has_Element (Position) loop + Result.Map.all.Replace_Element (Position, + Eval (Element (Position), Env)); + Next (Position); + end loop; + return Result; + end Eval_Map; + + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T + is + Ref : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Source.Length); + begin + for I in Source.Data'Range loop + Ref.all.Data (I) := Eval (Source.Data (I), Env); + end loop; + return (Kind_Vector, Ref); + end Eval_Vector; + + procedure Exec (Script : in String; + Env : in Envs.Ptr) + is + Result : Types.T; + begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; + pragma Unreferenced (Result); + end Exec; + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); +begin + -- Show the Eval function to other packages. + Types.Fns.Eval_Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + Core.NS_Add_To_Repl (Repl); + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); + -- Native startup procedure. + Exec (Startup, Repl); + -- Define ARGV from command line arguments. + for I in 2 .. ACL.Argument_Count loop + Argv.all.Data (I - 1) := (Kind_String, + Types.Strings.Alloc (ACL.Argument (I))); + end loop; + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), + (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); + else + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + end if; + + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end Step6_File; diff --git a/impls/ada.2/step7_quote.adb b/impls/ada.2/step7_quote.adb index 94182fb1b7..f485e85418 100644 --- a/impls/ada.2/step7_quote.adb +++ b/impls/ada.2/step7_quote.adb @@ -1,392 +1,392 @@ -with Ada.Command_Line; -with Ada.Environment_Variables; -with Ada.Text_IO.Unbounded_IO; - -with Core; -with Envs; -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types.Fns; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -procedure Step7_Quote is - - Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); - - use type Types.T; - use all type Types.Kind_Type; - use type Types.Strings.Instance; - package ACL renames Ada.Command_Line; - - function Read return Types.T_Array with Inline; - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T; - function Eval_Builtin (Args : in Types.T_Array) return Types.T; - -- The built-in variant needs to see the Repl variable. - - function Quasiquote (Ast : in Types.T) return Types.T; - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep (Env : in Envs.Ptr) with Inline; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T; - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T; - -- Helpers for the Eval function. - - procedure Exec (Script : in String; - Env : in Envs.Ptr) with Inline; - -- Read the script, eval its elements, but ignore the result. - - ---------------------------------------------------------------------- - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T - is - -- Use local variables, that can be rewritten when tail call - -- optimization goes to <>. - Ast : Types.T := Ast0; - Env : Envs.Ptr := Env0; - Env_Reusable : Boolean := False; - -- True when the environment has been created in this recursion - -- level, and has not yet been referenced by a closure. If so, - -- we can reuse it instead of creating a subenvironment. - First : Types.T; - begin - <> - if Dbgeval then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put ("EVAL: "); - Print (Ast); - Envs.Dump_Stack (Env.all); - end if; - - case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - return Ast; - when Kind_Symbol => - return Env.all.Get (Ast.Str); - when Kind_Map => - return Eval_Map (Ast.Map.all, Env); - when Kind_Vector => - return Eval_Vector (Ast.Sequence.all, Env); - when Kind_List => - null; - end case; - - -- Ast is a list. - if Ast.Sequence.all.Length = 0 then - return Ast; - end if; - First := Ast.Sequence.all.Data (1); - - -- Special forms - -- Ast is a non-empty list, First is its first element. - case First.Kind is - when Kind_Symbol => - if First.Str.all = "if" then - Err.Check (Ast.Sequence.all.Length in 3 .. 4, - "expected 2 or 3 parameters"); - declare - Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); - begin - if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then - Ast := Ast.Sequence.all.Data (3); - goto Restart; - elsif Ast.Sequence.all.Length = 3 then - return Types.Nil; - else - Ast := Ast.Sequence.all.Data (4); - goto Restart; - end if; - end; - elsif First.Str.all = "let*" then - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, - "expected a sequence then a value"); - declare - Bindings : Types.T_Array - renames Ast.Sequence.all.Data (2).Sequence.all.Data; - begin - Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); - if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); - Env_Reusable := True; - end if; - for I in 0 .. Bindings'Length / 2 - 1 loop - Env.all.Set (Bindings (Bindings'First + 2 * I), - Eval (Bindings (Bindings'First + 2 * I + 1), Env)); - -- This call checks key kind. - end loop; - Ast := Ast.Sequence.all.Data (3); - goto Restart; - end; - elsif First.Str.all = "quote" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Ast.Sequence.all.Data (2); - elsif First.Str.all = "def!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - begin - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "do" then - Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); - declare - Result : Types.T; - begin - for I in 2 .. Ast.Sequence.all.Length - 1 loop - Result := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - pragma Unreferenced (Result); - end; - Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); - goto Restart; - elsif First.Str.all = "fn*" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Params : Types.T renames Ast.Sequence.all.Data (2); - begin - Err.Check (Params.Kind in Types.Kind_Sequence, - "first argument of fn* must be a sequence"); - Env_Reusable := False; - return (Kind_Fn, Types.Fns.New_Function - (Params => Params.Sequence, - Ast => Ast.Sequence.all.Data (3), - Env => Env)); - end; - elsif First.Str.all = "quasiquoteexpand" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Quasiquote (Ast.Sequence.all.Data (2)); - elsif First.Str.all = "quasiquote" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - Ast := Quasiquote (Ast.Sequence.all.Data (2)); - goto Restart; - else - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - First := Env.all.Get (First.Str); - end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - null; - when Types.Kind_Sequence | Kind_Map => - -- Lists are definitely worth a recursion, and the two other - -- cases should be rare (they will report an error later). - First := Eval (First, Env); - end case; - - -- Apply phase. - -- Ast is a non-empty list, - -- First is its non-special evaluated first element. - Err.Check (First.Kind in Types.Kind_Function, - "first element must be a function"); - -- We are applying a function. Evaluate its arguments. - declare - Args : Types.T_Array (2 .. Ast.Sequence.all.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - if First.Kind = Kind_Builtin then - return First.Builtin.all (Args); - end if; - -- Like Types.Fns.Apply, except that we use TCO. - Env := Envs.New_Env (Outer => First.Fn.all.Env); - Env_Reusable := True; - Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, - Exprs => Args); - Ast := First.Fn.all.Ast; - goto Restart; - end; - exception - when Err.Error => - Err.Add_Trace_Line ("eval", Ast); - raise; - end Eval; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T - is - use all type Types.Maps.Cursor; - -- Copy the whole map so that keys are not hashed again. - Result : constant Types.T := Types.Maps.New_Map (Source); - Position : Types.Maps.Cursor := Result.Map.all.First; - begin - while Has_Element (Position) loop - Result.Map.all.Replace_Element (Position, - Eval (Element (Position), Env)); - Next (Position); - end loop; - return Result; - end Eval_Map; - - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T - is - Ref : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Source.Length); - begin - for I in Source.Data'Range loop - Ref.all.Data (I) := Eval (Source.Data (I), Env); - end loop; - return (Kind_Vector, Ref); - end Eval_Vector; - - procedure Exec (Script : in String; - Env : in Envs.Ptr) - is - Result : Types.T; - begin - for Expression of Reader.Read_Str (Script) loop - Result := Eval (Expression, Env); - end loop; - pragma Unreferenced (Result); - end Exec; - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Quasiquote (Ast : in Types.T) return Types.T is - - function Qq_Seq return Types.T; - function Starts_With (Sequence : Types.T_Array; - Symbol : String) return Boolean; - - function Qq_Seq return Types.T is - Result : Types.T := Types.Sequences.List ((1 .. 0 => Types.Nil)); - begin - for Elt of reverse Ast.Sequence.all.Data loop - if Elt.Kind = Kind_List - and then Starts_With (Elt.Sequence.all.Data, "splice-unquote") - then - Err.Check (Elt.Sequence.all.Length = 2, - "splice-unquote expects 1 parameter"); - Result := Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("concat")), - Elt.Sequence.all.Data (2), Result)); - else - Result := Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("cons")), - Quasiquote (Elt), Result)); - end if; - end loop; - return Result; - end Qq_Seq; - - function Starts_With (Sequence : Types.T_Array; - Symbol : String) return Boolean is - (0 < Sequence'Length - and then Sequence (Sequence'First).Kind = Kind_Symbol - and then Sequence (Sequence'First).Str.all = Symbol); - - begin - case Ast.Kind is - when Kind_List => - if Starts_With (Ast.Sequence.all.Data, "unquote") then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Ast.Sequence.all.Data (2); - else - return Qq_Seq; - end if; - when Kind_Vector => - return Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("vec")), Qq_Seq)); - when Kind_Map | Kind_Symbol => - return Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("quote")), Ast)); - when others => - return Ast; - end case; - exception - when Err.Error => - Err.Add_Trace_Line ("quasiquote", Ast); - raise; - end Quasiquote; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep (Env : in Envs.Ptr) is - begin - for Expression of Read loop - Print (Eval (Expression, Env)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - - Startup : constant String - := "(def! not (fn* (a) (if a false true)))" - & "(def! load-file (fn* (f)" - & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"; - Repl : constant Envs.Ptr := Envs.New_Env; - function Eval_Builtin (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return Eval (Args (Args'First), Repl); - end Eval_Builtin; - Script : constant Boolean := 0 < ACL.Argument_Count; - Argv : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); -begin - -- Show the Eval function to other packages. - Types.Fns.Eval_Cb := Eval'Unrestricted_Access; - -- Add Core functions into the top environment. - Core.NS_Add_To_Repl (Repl); - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), - (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); - -- Native startup procedure. - Exec (Startup, Repl); - -- Define ARGV from command line arguments. - for I in 2 .. ACL.Argument_Count loop - Argv.all.Data (I - 1) := (Kind_String, - Types.Strings.Alloc (ACL.Argument (I))); - end loop; - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), - (Kind_List, Argv)); - -- Execute user commands. - if Script then - Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); - else - loop - begin - Rep (Repl); - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - Repl.all.Keep; - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - end if; - - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end Step7_Quote; +with Ada.Command_Line; +with Ada.Environment_Variables; +with Ada.Text_IO.Unbounded_IO; + +with Core; +with Envs; +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types.Fns; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +procedure Step7_Quote is + + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + + use type Types.T; + use all type Types.Kind_Type; + use type Types.Strings.Instance; + package ACL renames Ada.Command_Line; + + function Read return Types.T_Array with Inline; + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T; + function Eval_Builtin (Args : in Types.T_Array) return Types.T; + -- The built-in variant needs to see the Repl variable. + + function Quasiquote (Ast : in Types.T) return Types.T; + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep (Env : in Envs.Ptr) with Inline; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T; + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T; + -- Helpers for the Eval function. + + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. + + ---------------------------------------------------------------------- + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T + is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Types.T := Ast0; + Env : Envs.Ptr := Env0; + Env_Reusable : Boolean := False; + -- True when the environment has been created in this recursion + -- level, and has not yet been referenced by a closure. If so, + -- we can reuse it instead of creating a subenvironment. + First : Types.T; + begin + <> + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + Envs.Dump_Stack (Env.all); + end if; + + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + return Ast; + when Kind_Symbol => + return Env.all.Get (Ast.Str); + when Kind_Map => + return Eval_Map (Ast.Map.all, Env); + when Kind_Vector => + return Eval_Vector (Ast.Sequence.all, Env); + when Kind_List => + null; + end case; + + -- Ast is a list. + if Ast.Sequence.all.Length = 0 then + return Ast; + end if; + First := Ast.Sequence.all.Data (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Str.all = "if" then + Err.Check (Ast.Sequence.all.Length in 3 .. 4, + "expected 2 or 3 parameters"); + declare + Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); + begin + if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then + Ast := Ast.Sequence.all.Data (3); + goto Restart; + elsif Ast.Sequence.all.Length = 3 then + return Types.Nil; + else + Ast := Ast.Sequence.all.Data (4); + goto Restart; + end if; + end; + elsif First.Str.all = "let*" then + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, + "expected a sequence then a value"); + declare + Bindings : Types.T_Array + renames Ast.Sequence.all.Data (2).Sequence.all.Data; + begin + Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); + if not Env_Reusable then + Env := Envs.New_Env (Outer => Env); + Env_Reusable := True; + end if; + for I in 0 .. Bindings'Length / 2 - 1 loop + Env.all.Set (Bindings (Bindings'First + 2 * I), + Eval (Bindings (Bindings'First + 2 * I + 1), Env)); + -- This call checks key kind. + end loop; + Ast := Ast.Sequence.all.Data (3); + goto Restart; + end; + elsif First.Str.all = "quote" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all.Data (2); + elsif First.Str.all = "def!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + begin + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "do" then + Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); + declare + Result : Types.T; + begin + for I in 2 .. Ast.Sequence.all.Length - 1 loop + Result := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + pragma Unreferenced (Result); + end; + Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); + goto Restart; + elsif First.Str.all = "fn*" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Params : Types.T renames Ast.Sequence.all.Data (2); + begin + Err.Check (Params.Kind in Types.Kind_Sequence, + "first argument of fn* must be a sequence"); + Env_Reusable := False; + return (Kind_Fn, Types.Fns.New_Function + (Params => Params.Sequence, + Ast => Ast.Sequence.all.Data (3), + Env => Env)); + end; + elsif First.Str.all = "quasiquoteexpand" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence.all.Data (2)); + elsif First.Str.all = "quasiquote" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + Ast := Quasiquote (Ast.Sequence.all.Data (2)); + goto Restart; + else + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + First := Env.all.Get (First.Str); + end if; + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Types.Kind_Sequence | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + Err.Check (First.Kind in Types.Kind_Function, + "first element must be a function"); + -- We are applying a function. Evaluate its arguments. + declare + Args : Types.T_Array (2 .. Ast.Sequence.all.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + if First.Kind = Kind_Builtin then + return First.Builtin.all (Args); + end if; + -- Like Types.Fns.Apply, except that we use TCO. + Env := Envs.New_Env (Outer => First.Fn.all.Env); + Env_Reusable := True; + Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, + Exprs => Args); + Ast := First.Fn.all.Ast; + goto Restart; + end; + exception + when Err.Error => + Err.Add_Trace_Line ("eval", Ast); + raise; + end Eval; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T + is + use all type Types.Maps.Cursor; + -- Copy the whole map so that keys are not hashed again. + Result : constant Types.T := Types.Maps.New_Map (Source); + Position : Types.Maps.Cursor := Result.Map.all.First; + begin + while Has_Element (Position) loop + Result.Map.all.Replace_Element (Position, + Eval (Element (Position), Env)); + Next (Position); + end loop; + return Result; + end Eval_Map; + + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T + is + Ref : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Source.Length); + begin + for I in Source.Data'Range loop + Ref.all.Data (I) := Eval (Source.Data (I), Env); + end loop; + return (Kind_Vector, Ref); + end Eval_Vector; + + procedure Exec (Script : in String; + Env : in Envs.Ptr) + is + Result : Types.T; + begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; + pragma Unreferenced (Result); + end Exec; + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Quasiquote (Ast : in Types.T) return Types.T is + + function Qq_Seq return Types.T; + function Starts_With (Sequence : Types.T_Array; + Symbol : String) return Boolean; + + function Qq_Seq return Types.T is + Result : Types.T := Types.Sequences.List ((1 .. 0 => Types.Nil)); + begin + for Elt of reverse Ast.Sequence.all.Data loop + if Elt.Kind = Kind_List + and then Starts_With (Elt.Sequence.all.Data, "splice-unquote") + then + Err.Check (Elt.Sequence.all.Length = 2, + "splice-unquote expects 1 parameter"); + Result := Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("concat")), + Elt.Sequence.all.Data (2), Result)); + else + Result := Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("cons")), + Quasiquote (Elt), Result)); + end if; + end loop; + return Result; + end Qq_Seq; + + function Starts_With (Sequence : Types.T_Array; + Symbol : String) return Boolean is + (0 < Sequence'Length + and then Sequence (Sequence'First).Kind = Kind_Symbol + and then Sequence (Sequence'First).Str.all = Symbol); + + begin + case Ast.Kind is + when Kind_List => + if Starts_With (Ast.Sequence.all.Data, "unquote") then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all.Data (2); + else + return Qq_Seq; + end if; + when Kind_Vector => + return Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("vec")), Qq_Seq)); + when Kind_Map | Kind_Symbol => + return Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("quote")), Ast)); + when others => + return Ast; + end case; + exception + when Err.Error => + Err.Add_Trace_Line ("quasiquote", Ast); + raise; + end Quasiquote; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); +begin + -- Show the Eval function to other packages. + Types.Fns.Eval_Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + Core.NS_Add_To_Repl (Repl); + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); + -- Native startup procedure. + Exec (Startup, Repl); + -- Define ARGV from command line arguments. + for I in 2 .. ACL.Argument_Count loop + Argv.all.Data (I - 1) := (Kind_String, + Types.Strings.Alloc (ACL.Argument (I))); + end loop; + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), + (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); + else + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + end if; + + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end Step7_Quote; diff --git a/impls/ada.2/step8_macros.adb b/impls/ada.2/step8_macros.adb index 1f7951b2d4..f48a098a2d 100644 --- a/impls/ada.2/step8_macros.adb +++ b/impls/ada.2/step8_macros.adb @@ -1,447 +1,447 @@ -with Ada.Command_Line; -with Ada.Environment_Variables; -with Ada.Text_IO.Unbounded_IO; - -with Core; -with Envs; -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types.Fns; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -procedure Step8_Macros is - - Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); - - use type Types.T; - use all type Types.Kind_Type; - use type Types.Strings.Instance; - package ACL renames Ada.Command_Line; - - function Read return Types.T_Array with Inline; - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T; - function Eval_Builtin (Args : in Types.T_Array) return Types.T; - -- The built-in variant needs to see the Repl variable. - - function Quasiquote (Ast : in Types.T) return Types.T; - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep (Env : in Envs.Ptr) with Inline; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T; - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T; - -- Helpers for the Eval function. - - procedure Exec (Script : in String; - Env : in Envs.Ptr) with Inline; - -- Read the script, eval its elements, but ignore the result. - - ---------------------------------------------------------------------- - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T - is - -- Use local variables, that can be rewritten when tail call - -- optimization goes to <>. - Ast : Types.T := Ast0; - Env : Envs.Ptr := Env0; - Env_Reusable : Boolean := False; - -- True when the environment has been created in this recursion - -- level, and has not yet been referenced by a closure. If so, - -- we can reuse it instead of creating a subenvironment. - Macroexpanding : Boolean := False; - First : Types.T; - begin - <> - if Dbgeval then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put ("EVAL: "); - Print (Ast); - Envs.Dump_Stack (Env.all); - end if; - - case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - return Ast; - when Kind_Symbol => - return Env.all.Get (Ast.Str); - when Kind_Map => - return Eval_Map (Ast.Map.all, Env); - when Kind_Vector => - return Eval_Vector (Ast.Sequence.all, Env); - when Kind_List => - null; - end case; - - -- Ast is a list. - if Ast.Sequence.all.Length = 0 then - return Ast; - end if; - First := Ast.Sequence.all.Data (1); - - -- Special forms - -- Ast is a non-empty list, First is its first element. - case First.Kind is - when Kind_Symbol => - if First.Str.all = "if" then - Err.Check (Ast.Sequence.all.Length in 3 .. 4, - "expected 2 or 3 parameters"); - declare - Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); - begin - if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then - Ast := Ast.Sequence.all.Data (3); - goto Restart; - elsif Ast.Sequence.all.Length = 3 then - return Types.Nil; - else - Ast := Ast.Sequence.all.Data (4); - goto Restart; - end if; - end; - elsif First.Str.all = "let*" then - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, - "expected a sequence then a value"); - declare - Bindings : Types.T_Array - renames Ast.Sequence.all.Data (2).Sequence.all.Data; - begin - Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); - if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); - Env_Reusable := True; - end if; - for I in 0 .. Bindings'Length / 2 - 1 loop - Env.all.Set (Bindings (Bindings'First + 2 * I), - Eval (Bindings (Bindings'First + 2 * I + 1), Env)); - -- This call checks key kind. - end loop; - Ast := Ast.Sequence.all.Data (3); - goto Restart; - end; - elsif First.Str.all = "quote" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Ast.Sequence.all.Data (2); - elsif First.Str.all = "def!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - begin - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "defmacro!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - Val : Types.T; - begin - Err.Check (Fun.Kind = Kind_Fn, "expected a function"); - Val := (Kind_Macro, Types.Fns.New_Function - (Params => Fun.Fn.all.Params, - Ast => Fun.Fn.all.Ast, - Env => Fun.Fn.all.Env)); - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "do" then - Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); - declare - Result : Types.T; - begin - for I in 2 .. Ast.Sequence.all.Length - 1 loop - Result := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - pragma Unreferenced (Result); - end; - Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); - goto Restart; - elsif First.Str.all = "fn*" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Params : Types.T renames Ast.Sequence.all.Data (2); - begin - Err.Check (Params.Kind in Types.Kind_Sequence, - "first argument of fn* must be a sequence"); - Env_Reusable := False; - return (Kind_Fn, Types.Fns.New_Function - (Params => Params.Sequence, - Ast => Ast.Sequence.all.Data (3), - Env => Env)); - end; - elsif First.Str.all = "macroexpand" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - Macroexpanding := True; - Ast := Ast.Sequence.all.Data (2); - goto Restart; - elsif First.Str.all = "quasiquoteexpand" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Quasiquote (Ast.Sequence.all.Data (2)); - elsif First.Str.all = "quasiquote" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - Ast := Quasiquote (Ast.Sequence.all.Data (2)); - goto Restart; - else - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - First := Env.all.Get (First.Str); - end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - null; - when Types.Kind_Sequence | Kind_Map => - -- Lists are definitely worth a recursion, and the two other - -- cases should be rare (they will report an error later). - First := Eval (First, Env); - end case; - - -- Apply phase. - -- Ast is a non-empty list, - -- First is its non-special evaluated first element. - case First.Kind is - when Kind_Macro => - -- Use the unevaluated arguments. - if Macroexpanding then - -- Evaluate the macro with tail call optimization. - if not Env_Reusable then - Env := Envs.New_Env (Outer => First.Fn.all.Env); - Env_Reusable := True; - end if; - Env.all.Set_Binds - (Binds => First.Fn.all.Params.all.Data, - Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); - Ast := First.Fn.all.Ast; - goto Restart; - else - -- Evaluate the macro normally. - Ast := First.Fn.all.Apply - (Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); - -- Then evaluate the result with TCO. - goto Restart; - end if; - when Types.Kind_Function => - null; - when others => - Err.Raise_With ("first element must be a function or macro"); - end case; - -- We are applying a function. Evaluate its arguments. - declare - Args : Types.T_Array (2 .. Ast.Sequence.all.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - if First.Kind = Kind_Builtin then - return First.Builtin.all (Args); - end if; - -- Like Types.Fns.Apply, except that we use TCO. - Env := Envs.New_Env (Outer => First.Fn.all.Env); - Env_Reusable := True; - Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, - Exprs => Args); - Ast := First.Fn.all.Ast; - goto Restart; - end; - exception - when Err.Error => - if Macroexpanding then - Err.Add_Trace_Line ("macroexpand", Ast); - else - Err.Add_Trace_Line ("eval", Ast); - end if; - raise; - end Eval; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T - is - use all type Types.Maps.Cursor; - -- Copy the whole map so that keys are not hashed again. - Result : constant Types.T := Types.Maps.New_Map (Source); - Position : Types.Maps.Cursor := Result.Map.all.First; - begin - while Has_Element (Position) loop - Result.Map.all.Replace_Element (Position, - Eval (Element (Position), Env)); - Next (Position); - end loop; - return Result; - end Eval_Map; - - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T - is - Ref : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Source.Length); - begin - for I in Source.Data'Range loop - Ref.all.Data (I) := Eval (Source.Data (I), Env); - end loop; - return (Kind_Vector, Ref); - end Eval_Vector; - - procedure Exec (Script : in String; - Env : in Envs.Ptr) - is - Result : Types.T; - begin - for Expression of Reader.Read_Str (Script) loop - Result := Eval (Expression, Env); - end loop; - pragma Unreferenced (Result); - end Exec; - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Quasiquote (Ast : in Types.T) return Types.T is - - function Qq_Seq return Types.T; - function Starts_With (Sequence : Types.T_Array; - Symbol : String) return Boolean; - - function Qq_Seq return Types.T is - Result : Types.T := Types.Sequences.List ((1 .. 0 => Types.Nil)); - begin - for Elt of reverse Ast.Sequence.all.Data loop - if Elt.Kind = Kind_List - and then Starts_With (Elt.Sequence.all.Data, "splice-unquote") - then - Err.Check (Elt.Sequence.all.Length = 2, - "splice-unquote expects 1 parameter"); - Result := Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("concat")), - Elt.Sequence.all.Data (2), Result)); - else - Result := Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("cons")), - Quasiquote (Elt), Result)); - end if; - end loop; - return Result; - end Qq_Seq; - - function Starts_With (Sequence : Types.T_Array; - Symbol : String) return Boolean is - (0 < Sequence'Length - and then Sequence (Sequence'First).Kind = Kind_Symbol - and then Sequence (Sequence'First).Str.all = Symbol); - - begin - case Ast.Kind is - when Kind_List => - if Starts_With (Ast.Sequence.all.Data, "unquote") then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Ast.Sequence.all.Data (2); - else - return Qq_Seq; - end if; - when Kind_Vector => - return Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("vec")), Qq_Seq)); - when Kind_Map | Kind_Symbol => - return Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("quote")), Ast)); - when others => - return Ast; - end case; - exception - when Err.Error => - Err.Add_Trace_Line ("quasiquote", Ast); - raise; - end Quasiquote; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep (Env : in Envs.Ptr) is - begin - for Expression of Read loop - Print (Eval (Expression, Env)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - - Startup : constant String - := "(def! not (fn* (a) (if a false true)))" - & "(def! load-file (fn* (f)" - & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" - & "(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)))))))"; - Repl : constant Envs.Ptr := Envs.New_Env; - function Eval_Builtin (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return Eval (Args (Args'First), Repl); - end Eval_Builtin; - Script : constant Boolean := 0 < ACL.Argument_Count; - Argv : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); -begin - -- Show the Eval function to other packages. - Types.Fns.Eval_Cb := Eval'Unrestricted_Access; - -- Add Core functions into the top environment. - Core.NS_Add_To_Repl (Repl); - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), - (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); - -- Native startup procedure. - Exec (Startup, Repl); - -- Define ARGV from command line arguments. - for I in 2 .. ACL.Argument_Count loop - Argv.all.Data (I - 1) := (Kind_String, - Types.Strings.Alloc (ACL.Argument (I))); - end loop; - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), - (Kind_List, Argv)); - -- Execute user commands. - if Script then - Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); - else - loop - begin - Rep (Repl); - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - Repl.all.Keep; - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - end if; - - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end Step8_Macros; +with Ada.Command_Line; +with Ada.Environment_Variables; +with Ada.Text_IO.Unbounded_IO; + +with Core; +with Envs; +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types.Fns; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +procedure Step8_Macros is + + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + + use type Types.T; + use all type Types.Kind_Type; + use type Types.Strings.Instance; + package ACL renames Ada.Command_Line; + + function Read return Types.T_Array with Inline; + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T; + function Eval_Builtin (Args : in Types.T_Array) return Types.T; + -- The built-in variant needs to see the Repl variable. + + function Quasiquote (Ast : in Types.T) return Types.T; + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep (Env : in Envs.Ptr) with Inline; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T; + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T; + -- Helpers for the Eval function. + + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. + + ---------------------------------------------------------------------- + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T + is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Types.T := Ast0; + Env : Envs.Ptr := Env0; + Env_Reusable : Boolean := False; + -- True when the environment has been created in this recursion + -- level, and has not yet been referenced by a closure. If so, + -- we can reuse it instead of creating a subenvironment. + Macroexpanding : Boolean := False; + First : Types.T; + begin + <> + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + Envs.Dump_Stack (Env.all); + end if; + + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + return Ast; + when Kind_Symbol => + return Env.all.Get (Ast.Str); + when Kind_Map => + return Eval_Map (Ast.Map.all, Env); + when Kind_Vector => + return Eval_Vector (Ast.Sequence.all, Env); + when Kind_List => + null; + end case; + + -- Ast is a list. + if Ast.Sequence.all.Length = 0 then + return Ast; + end if; + First := Ast.Sequence.all.Data (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Str.all = "if" then + Err.Check (Ast.Sequence.all.Length in 3 .. 4, + "expected 2 or 3 parameters"); + declare + Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); + begin + if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then + Ast := Ast.Sequence.all.Data (3); + goto Restart; + elsif Ast.Sequence.all.Length = 3 then + return Types.Nil; + else + Ast := Ast.Sequence.all.Data (4); + goto Restart; + end if; + end; + elsif First.Str.all = "let*" then + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, + "expected a sequence then a value"); + declare + Bindings : Types.T_Array + renames Ast.Sequence.all.Data (2).Sequence.all.Data; + begin + Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); + if not Env_Reusable then + Env := Envs.New_Env (Outer => Env); + Env_Reusable := True; + end if; + for I in 0 .. Bindings'Length / 2 - 1 loop + Env.all.Set (Bindings (Bindings'First + 2 * I), + Eval (Bindings (Bindings'First + 2 * I + 1), Env)); + -- This call checks key kind. + end loop; + Ast := Ast.Sequence.all.Data (3); + goto Restart; + end; + elsif First.Str.all = "quote" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all.Data (2); + elsif First.Str.all = "def!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + begin + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "defmacro!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + Val : Types.T; + begin + Err.Check (Fun.Kind = Kind_Fn, "expected a function"); + Val := (Kind_Macro, Types.Fns.New_Function + (Params => Fun.Fn.all.Params, + Ast => Fun.Fn.all.Ast, + Env => Fun.Fn.all.Env)); + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "do" then + Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); + declare + Result : Types.T; + begin + for I in 2 .. Ast.Sequence.all.Length - 1 loop + Result := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + pragma Unreferenced (Result); + end; + Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); + goto Restart; + elsif First.Str.all = "fn*" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Params : Types.T renames Ast.Sequence.all.Data (2); + begin + Err.Check (Params.Kind in Types.Kind_Sequence, + "first argument of fn* must be a sequence"); + Env_Reusable := False; + return (Kind_Fn, Types.Fns.New_Function + (Params => Params.Sequence, + Ast => Ast.Sequence.all.Data (3), + Env => Env)); + end; + elsif First.Str.all = "macroexpand" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + Macroexpanding := True; + Ast := Ast.Sequence.all.Data (2); + goto Restart; + elsif First.Str.all = "quasiquoteexpand" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence.all.Data (2)); + elsif First.Str.all = "quasiquote" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + Ast := Quasiquote (Ast.Sequence.all.Data (2)); + goto Restart; + else + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + First := Env.all.Get (First.Str); + end if; + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Types.Kind_Sequence | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is + when Kind_Macro => + -- Use the unevaluated arguments. + if Macroexpanding then + -- Evaluate the macro with tail call optimization. + if not Env_Reusable then + Env := Envs.New_Env (Outer => First.Fn.all.Env); + Env_Reusable := True; + end if; + Env.all.Set_Binds + (Binds => First.Fn.all.Params.all.Data, + Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); + Ast := First.Fn.all.Ast; + goto Restart; + else + -- Evaluate the macro normally. + Ast := First.Fn.all.Apply + (Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); + -- Then evaluate the result with TCO. + goto Restart; + end if; + when Types.Kind_Function => + null; + when others => + Err.Raise_With ("first element must be a function or macro"); + end case; + -- We are applying a function. Evaluate its arguments. + declare + Args : Types.T_Array (2 .. Ast.Sequence.all.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + if First.Kind = Kind_Builtin then + return First.Builtin.all (Args); + end if; + -- Like Types.Fns.Apply, except that we use TCO. + Env := Envs.New_Env (Outer => First.Fn.all.Env); + Env_Reusable := True; + Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, + Exprs => Args); + Ast := First.Fn.all.Ast; + goto Restart; + end; + exception + when Err.Error => + if Macroexpanding then + Err.Add_Trace_Line ("macroexpand", Ast); + else + Err.Add_Trace_Line ("eval", Ast); + end if; + raise; + end Eval; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T + is + use all type Types.Maps.Cursor; + -- Copy the whole map so that keys are not hashed again. + Result : constant Types.T := Types.Maps.New_Map (Source); + Position : Types.Maps.Cursor := Result.Map.all.First; + begin + while Has_Element (Position) loop + Result.Map.all.Replace_Element (Position, + Eval (Element (Position), Env)); + Next (Position); + end loop; + return Result; + end Eval_Map; + + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T + is + Ref : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Source.Length); + begin + for I in Source.Data'Range loop + Ref.all.Data (I) := Eval (Source.Data (I), Env); + end loop; + return (Kind_Vector, Ref); + end Eval_Vector; + + procedure Exec (Script : in String; + Env : in Envs.Ptr) + is + Result : Types.T; + begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; + pragma Unreferenced (Result); + end Exec; + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Quasiquote (Ast : in Types.T) return Types.T is + + function Qq_Seq return Types.T; + function Starts_With (Sequence : Types.T_Array; + Symbol : String) return Boolean; + + function Qq_Seq return Types.T is + Result : Types.T := Types.Sequences.List ((1 .. 0 => Types.Nil)); + begin + for Elt of reverse Ast.Sequence.all.Data loop + if Elt.Kind = Kind_List + and then Starts_With (Elt.Sequence.all.Data, "splice-unquote") + then + Err.Check (Elt.Sequence.all.Length = 2, + "splice-unquote expects 1 parameter"); + Result := Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("concat")), + Elt.Sequence.all.Data (2), Result)); + else + Result := Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("cons")), + Quasiquote (Elt), Result)); + end if; + end loop; + return Result; + end Qq_Seq; + + function Starts_With (Sequence : Types.T_Array; + Symbol : String) return Boolean is + (0 < Sequence'Length + and then Sequence (Sequence'First).Kind = Kind_Symbol + and then Sequence (Sequence'First).Str.all = Symbol); + + begin + case Ast.Kind is + when Kind_List => + if Starts_With (Ast.Sequence.all.Data, "unquote") then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all.Data (2); + else + return Qq_Seq; + end if; + when Kind_Vector => + return Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("vec")), Qq_Seq)); + when Kind_Map | Kind_Symbol => + return Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("quote")), Ast)); + when others => + return Ast; + end case; + exception + when Err.Error => + Err.Add_Trace_Line ("quasiquote", Ast); + raise; + end Quasiquote; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" + & "(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)))))))"; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); +begin + -- Show the Eval function to other packages. + Types.Fns.Eval_Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + Core.NS_Add_To_Repl (Repl); + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); + -- Native startup procedure. + Exec (Startup, Repl); + -- Define ARGV from command line arguments. + for I in 2 .. ACL.Argument_Count loop + Argv.all.Data (I - 1) := (Kind_String, + Types.Strings.Alloc (ACL.Argument (I))); + end loop; + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), + (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); + else + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + end if; + + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end Step8_Macros; diff --git a/impls/ada.2/step9_try.adb b/impls/ada.2/step9_try.adb index 333c7adf12..4bbc71b9b5 100644 --- a/impls/ada.2/step9_try.adb +++ b/impls/ada.2/step9_try.adb @@ -1,477 +1,477 @@ -with Ada.Command_Line; -with Ada.Environment_Variables; -with Ada.Text_IO.Unbounded_IO; - -with Core; -with Envs; -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types.Fns; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -procedure Step9_Try is - - Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); - - use type Types.T; - use all type Types.Kind_Type; - use type Types.Strings.Instance; - package ACL renames Ada.Command_Line; - - function Read return Types.T_Array with Inline; - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T; - function Eval_Builtin (Args : in Types.T_Array) return Types.T; - -- The built-in variant needs to see the Repl variable. - - function Quasiquote (Ast : in Types.T) return Types.T; - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep (Env : in Envs.Ptr) with Inline; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T; - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T; - -- Helpers for the Eval function. - - procedure Exec (Script : in String; - Env : in Envs.Ptr) with Inline; - -- Read the script, eval its elements, but ignore the result. - - ---------------------------------------------------------------------- - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T - is - -- Use local variables, that can be rewritten when tail call - -- optimization goes to <>. - Ast : Types.T := Ast0; - Env : Envs.Ptr := Env0; - Env_Reusable : Boolean := False; - -- True when the environment has been created in this recursion - -- level, and has not yet been referenced by a closure. If so, - -- we can reuse it instead of creating a subenvironment. - Macroexpanding : Boolean := False; - First : Types.T; - begin - <> - if Dbgeval then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put ("EVAL: "); - Print (Ast); - Envs.Dump_Stack (Env.all); - end if; - - case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - return Ast; - when Kind_Symbol => - return Env.all.Get (Ast.Str); - when Kind_Map => - return Eval_Map (Ast.Map.all, Env); - when Kind_Vector => - return Eval_Vector (Ast.Sequence.all, Env); - when Kind_List => - null; - end case; - - -- Ast is a list. - if Ast.Sequence.all.Length = 0 then - return Ast; - end if; - First := Ast.Sequence.all.Data (1); - - -- Special forms - -- Ast is a non-empty list, First is its first element. - case First.Kind is - when Kind_Symbol => - if First.Str.all = "if" then - Err.Check (Ast.Sequence.all.Length in 3 .. 4, - "expected 2 or 3 parameters"); - declare - Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); - begin - if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then - Ast := Ast.Sequence.all.Data (3); - goto Restart; - elsif Ast.Sequence.all.Length = 3 then - return Types.Nil; - else - Ast := Ast.Sequence.all.Data (4); - goto Restart; - end if; - end; - elsif First.Str.all = "let*" then - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, - "expected a sequence then a value"); - declare - Bindings : Types.T_Array - renames Ast.Sequence.all.Data (2).Sequence.all.Data; - begin - Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); - if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); - Env_Reusable := True; - end if; - for I in 0 .. Bindings'Length / 2 - 1 loop - Env.all.Set (Bindings (Bindings'First + 2 * I), - Eval (Bindings (Bindings'First + 2 * I + 1), Env)); - -- This call checks key kind. - end loop; - Ast := Ast.Sequence.all.Data (3); - goto Restart; - end; - elsif First.Str.all = "quote" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Ast.Sequence.all.Data (2); - elsif First.Str.all = "def!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - begin - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "defmacro!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - Val : Types.T; - begin - Err.Check (Fun.Kind = Kind_Fn, "expected a function"); - Val := (Kind_Macro, Types.Fns.New_Function - (Params => Fun.Fn.all.Params, - Ast => Fun.Fn.all.Ast, - Env => Fun.Fn.all.Env)); - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "do" then - Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); - declare - Result : Types.T; - begin - for I in 2 .. Ast.Sequence.all.Length - 1 loop - Result := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - pragma Unreferenced (Result); - end; - Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); - goto Restart; - elsif First.Str.all = "fn*" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Params : Types.T renames Ast.Sequence.all.Data (2); - begin - Err.Check (Params.Kind in Types.Kind_Sequence, - "first argument of fn* must be a sequence"); - Env_Reusable := False; - return (Kind_Fn, Types.Fns.New_Function - (Params => Params.Sequence, - Ast => Ast.Sequence.all.Data (3), - Env => Env)); - end; - elsif First.Str.all = "macroexpand" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - Macroexpanding := True; - Ast := Ast.Sequence.all.Data (2); - goto Restart; - elsif First.Str.all = "quasiquoteexpand" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Quasiquote (Ast.Sequence.all.Data (2)); - elsif First.Str.all = "quasiquote" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - Ast := Quasiquote (Ast.Sequence.all.Data (2)); - goto Restart; - elsif First.Str.all = "try*" then - if Ast.Sequence.all.Length = 2 then - Ast := Ast.Sequence.all.Data (2); - goto Restart; - end if; - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (3).Kind = Kind_List, - "expected 1 parameter, maybe followed by a list"); - declare - A3 : Types.T_Array - renames Ast.Sequence.all.Data (3).Sequence.all.Data; - begin - Err.Check (A3'Length = 3 - and then A3 (A3'First).Kind = Kind_Symbol - and then A3 (A3'First).Str.all = "catch*", - "3rd parameter if present must be a catch* list"); - begin - return Eval (Ast.Sequence.all.Data (2), Env); - exception - when Err.Error => - null; - end; - if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); - Env_Reusable := True; - end if; - Env.all.Set (A3 (A3'First + 1), Err.Data); -- check key kind - Ast := A3 (A3'Last); - goto Restart; - end; - else - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - First := Env.all.Get (First.Str); - end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - null; - when Types.Kind_Sequence | Kind_Map => - -- Lists are definitely worth a recursion, and the two other - -- cases should be rare (they will report an error later). - First := Eval (First, Env); - end case; - - -- Apply phase. - -- Ast is a non-empty list, - -- First is its non-special evaluated first element. - case First.Kind is - when Kind_Macro => - -- Use the unevaluated arguments. - if Macroexpanding then - -- Evaluate the macro with tail call optimization. - if not Env_Reusable then - Env := Envs.New_Env (Outer => First.Fn.all.Env); - Env_Reusable := True; - end if; - Env.all.Set_Binds - (Binds => First.Fn.all.Params.all.Data, - Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); - Ast := First.Fn.all.Ast; - goto Restart; - else - -- Evaluate the macro normally. - Ast := First.Fn.all.Apply - (Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); - -- Then evaluate the result with TCO. - goto Restart; - end if; - when Types.Kind_Function => - null; - when others => - Err.Raise_With ("first element must be a function or macro"); - end case; - -- We are applying a function. Evaluate its arguments. - declare - Args : Types.T_Array (2 .. Ast.Sequence.all.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - if First.Kind = Kind_Builtin then - return First.Builtin.all (Args); - end if; - -- Like Types.Fns.Apply, except that we use TCO. - Env := Envs.New_Env (Outer => First.Fn.all.Env); - Env_Reusable := True; - Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, - Exprs => Args); - Ast := First.Fn.all.Ast; - goto Restart; - end; - exception - when Err.Error => - if Macroexpanding then - Err.Add_Trace_Line ("macroexpand", Ast); - else - Err.Add_Trace_Line ("eval", Ast); - end if; - raise; - end Eval; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T - is - use all type Types.Maps.Cursor; - -- Copy the whole map so that keys are not hashed again. - Result : constant Types.T := Types.Maps.New_Map (Source); - Position : Types.Maps.Cursor := Result.Map.all.First; - begin - while Has_Element (Position) loop - Result.Map.all.Replace_Element (Position, - Eval (Element (Position), Env)); - Next (Position); - end loop; - return Result; - end Eval_Map; - - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T - is - Ref : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Source.Length); - begin - for I in Source.Data'Range loop - Ref.all.Data (I) := Eval (Source.Data (I), Env); - end loop; - return (Kind_Vector, Ref); - end Eval_Vector; - - procedure Exec (Script : in String; - Env : in Envs.Ptr) - is - Result : Types.T; - begin - for Expression of Reader.Read_Str (Script) loop - Result := Eval (Expression, Env); - end loop; - pragma Unreferenced (Result); - end Exec; - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Quasiquote (Ast : in Types.T) return Types.T is - - function Qq_Seq return Types.T; - function Starts_With (Sequence : Types.T_Array; - Symbol : String) return Boolean; - - function Qq_Seq return Types.T is - Result : Types.T := Types.Sequences.List ((1 .. 0 => Types.Nil)); - begin - for Elt of reverse Ast.Sequence.all.Data loop - if Elt.Kind = Kind_List - and then Starts_With (Elt.Sequence.all.Data, "splice-unquote") - then - Err.Check (Elt.Sequence.all.Length = 2, - "splice-unquote expects 1 parameter"); - Result := Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("concat")), - Elt.Sequence.all.Data (2), Result)); - else - Result := Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("cons")), - Quasiquote (Elt), Result)); - end if; - end loop; - return Result; - end Qq_Seq; - - function Starts_With (Sequence : Types.T_Array; - Symbol : String) return Boolean is - (0 < Sequence'Length - and then Sequence (Sequence'First).Kind = Kind_Symbol - and then Sequence (Sequence'First).Str.all = Symbol); - - begin - case Ast.Kind is - when Kind_List => - if Starts_With (Ast.Sequence.all.Data, "unquote") then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Ast.Sequence.all.Data (2); - else - return Qq_Seq; - end if; - when Kind_Vector => - return Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("vec")), Qq_Seq)); - when Kind_Map | Kind_Symbol => - return Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("quote")), Ast)); - when others => - return Ast; - end case; - exception - when Err.Error => - Err.Add_Trace_Line ("quasiquote", Ast); - raise; - end Quasiquote; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep (Env : in Envs.Ptr) is - begin - for Expression of Read loop - Print (Eval (Expression, Env)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - - Startup : constant String - := "(def! not (fn* (a) (if a false true)))" - & "(def! load-file (fn* (f)" - & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" - & "(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)))))))"; - Repl : constant Envs.Ptr := Envs.New_Env; - function Eval_Builtin (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return Eval (Args (Args'First), Repl); - end Eval_Builtin; - Script : constant Boolean := 0 < ACL.Argument_Count; - Argv : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); -begin - -- Show the Eval function to other packages. - Types.Fns.Eval_Cb := Eval'Unrestricted_Access; - -- Add Core functions into the top environment. - Core.NS_Add_To_Repl (Repl); - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), - (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); - -- Native startup procedure. - Exec (Startup, Repl); - -- Define ARGV from command line arguments. - for I in 2 .. ACL.Argument_Count loop - Argv.all.Data (I - 1) := (Kind_String, - Types.Strings.Alloc (ACL.Argument (I))); - end loop; - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), - (Kind_List, Argv)); - -- Execute user commands. - if Script then - Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); - else - loop - begin - Rep (Repl); - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - Repl.all.Keep; - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - end if; - - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end Step9_Try; +with Ada.Command_Line; +with Ada.Environment_Variables; +with Ada.Text_IO.Unbounded_IO; + +with Core; +with Envs; +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types.Fns; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +procedure Step9_Try is + + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + + use type Types.T; + use all type Types.Kind_Type; + use type Types.Strings.Instance; + package ACL renames Ada.Command_Line; + + function Read return Types.T_Array with Inline; + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T; + function Eval_Builtin (Args : in Types.T_Array) return Types.T; + -- The built-in variant needs to see the Repl variable. + + function Quasiquote (Ast : in Types.T) return Types.T; + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep (Env : in Envs.Ptr) with Inline; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T; + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T; + -- Helpers for the Eval function. + + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. + + ---------------------------------------------------------------------- + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T + is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Types.T := Ast0; + Env : Envs.Ptr := Env0; + Env_Reusable : Boolean := False; + -- True when the environment has been created in this recursion + -- level, and has not yet been referenced by a closure. If so, + -- we can reuse it instead of creating a subenvironment. + Macroexpanding : Boolean := False; + First : Types.T; + begin + <> + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + Envs.Dump_Stack (Env.all); + end if; + + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + return Ast; + when Kind_Symbol => + return Env.all.Get (Ast.Str); + when Kind_Map => + return Eval_Map (Ast.Map.all, Env); + when Kind_Vector => + return Eval_Vector (Ast.Sequence.all, Env); + when Kind_List => + null; + end case; + + -- Ast is a list. + if Ast.Sequence.all.Length = 0 then + return Ast; + end if; + First := Ast.Sequence.all.Data (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Str.all = "if" then + Err.Check (Ast.Sequence.all.Length in 3 .. 4, + "expected 2 or 3 parameters"); + declare + Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); + begin + if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then + Ast := Ast.Sequence.all.Data (3); + goto Restart; + elsif Ast.Sequence.all.Length = 3 then + return Types.Nil; + else + Ast := Ast.Sequence.all.Data (4); + goto Restart; + end if; + end; + elsif First.Str.all = "let*" then + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, + "expected a sequence then a value"); + declare + Bindings : Types.T_Array + renames Ast.Sequence.all.Data (2).Sequence.all.Data; + begin + Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); + if not Env_Reusable then + Env := Envs.New_Env (Outer => Env); + Env_Reusable := True; + end if; + for I in 0 .. Bindings'Length / 2 - 1 loop + Env.all.Set (Bindings (Bindings'First + 2 * I), + Eval (Bindings (Bindings'First + 2 * I + 1), Env)); + -- This call checks key kind. + end loop; + Ast := Ast.Sequence.all.Data (3); + goto Restart; + end; + elsif First.Str.all = "quote" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all.Data (2); + elsif First.Str.all = "def!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + begin + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "defmacro!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + Val : Types.T; + begin + Err.Check (Fun.Kind = Kind_Fn, "expected a function"); + Val := (Kind_Macro, Types.Fns.New_Function + (Params => Fun.Fn.all.Params, + Ast => Fun.Fn.all.Ast, + Env => Fun.Fn.all.Env)); + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "do" then + Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); + declare + Result : Types.T; + begin + for I in 2 .. Ast.Sequence.all.Length - 1 loop + Result := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + pragma Unreferenced (Result); + end; + Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); + goto Restart; + elsif First.Str.all = "fn*" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Params : Types.T renames Ast.Sequence.all.Data (2); + begin + Err.Check (Params.Kind in Types.Kind_Sequence, + "first argument of fn* must be a sequence"); + Env_Reusable := False; + return (Kind_Fn, Types.Fns.New_Function + (Params => Params.Sequence, + Ast => Ast.Sequence.all.Data (3), + Env => Env)); + end; + elsif First.Str.all = "macroexpand" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + Macroexpanding := True; + Ast := Ast.Sequence.all.Data (2); + goto Restart; + elsif First.Str.all = "quasiquoteexpand" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence.all.Data (2)); + elsif First.Str.all = "quasiquote" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + Ast := Quasiquote (Ast.Sequence.all.Data (2)); + goto Restart; + elsif First.Str.all = "try*" then + if Ast.Sequence.all.Length = 2 then + Ast := Ast.Sequence.all.Data (2); + goto Restart; + end if; + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (3).Kind = Kind_List, + "expected 1 parameter, maybe followed by a list"); + declare + A3 : Types.T_Array + renames Ast.Sequence.all.Data (3).Sequence.all.Data; + begin + Err.Check (A3'Length = 3 + and then A3 (A3'First).Kind = Kind_Symbol + and then A3 (A3'First).Str.all = "catch*", + "3rd parameter if present must be a catch* list"); + begin + return Eval (Ast.Sequence.all.Data (2), Env); + exception + when Err.Error => + null; + end; + if not Env_Reusable then + Env := Envs.New_Env (Outer => Env); + Env_Reusable := True; + end if; + Env.all.Set (A3 (A3'First + 1), Err.Data); -- check key kind + Ast := A3 (A3'Last); + goto Restart; + end; + else + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + First := Env.all.Get (First.Str); + end if; + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Types.Kind_Sequence | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is + when Kind_Macro => + -- Use the unevaluated arguments. + if Macroexpanding then + -- Evaluate the macro with tail call optimization. + if not Env_Reusable then + Env := Envs.New_Env (Outer => First.Fn.all.Env); + Env_Reusable := True; + end if; + Env.all.Set_Binds + (Binds => First.Fn.all.Params.all.Data, + Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); + Ast := First.Fn.all.Ast; + goto Restart; + else + -- Evaluate the macro normally. + Ast := First.Fn.all.Apply + (Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); + -- Then evaluate the result with TCO. + goto Restart; + end if; + when Types.Kind_Function => + null; + when others => + Err.Raise_With ("first element must be a function or macro"); + end case; + -- We are applying a function. Evaluate its arguments. + declare + Args : Types.T_Array (2 .. Ast.Sequence.all.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + if First.Kind = Kind_Builtin then + return First.Builtin.all (Args); + end if; + -- Like Types.Fns.Apply, except that we use TCO. + Env := Envs.New_Env (Outer => First.Fn.all.Env); + Env_Reusable := True; + Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, + Exprs => Args); + Ast := First.Fn.all.Ast; + goto Restart; + end; + exception + when Err.Error => + if Macroexpanding then + Err.Add_Trace_Line ("macroexpand", Ast); + else + Err.Add_Trace_Line ("eval", Ast); + end if; + raise; + end Eval; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T + is + use all type Types.Maps.Cursor; + -- Copy the whole map so that keys are not hashed again. + Result : constant Types.T := Types.Maps.New_Map (Source); + Position : Types.Maps.Cursor := Result.Map.all.First; + begin + while Has_Element (Position) loop + Result.Map.all.Replace_Element (Position, + Eval (Element (Position), Env)); + Next (Position); + end loop; + return Result; + end Eval_Map; + + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T + is + Ref : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Source.Length); + begin + for I in Source.Data'Range loop + Ref.all.Data (I) := Eval (Source.Data (I), Env); + end loop; + return (Kind_Vector, Ref); + end Eval_Vector; + + procedure Exec (Script : in String; + Env : in Envs.Ptr) + is + Result : Types.T; + begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; + pragma Unreferenced (Result); + end Exec; + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Quasiquote (Ast : in Types.T) return Types.T is + + function Qq_Seq return Types.T; + function Starts_With (Sequence : Types.T_Array; + Symbol : String) return Boolean; + + function Qq_Seq return Types.T is + Result : Types.T := Types.Sequences.List ((1 .. 0 => Types.Nil)); + begin + for Elt of reverse Ast.Sequence.all.Data loop + if Elt.Kind = Kind_List + and then Starts_With (Elt.Sequence.all.Data, "splice-unquote") + then + Err.Check (Elt.Sequence.all.Length = 2, + "splice-unquote expects 1 parameter"); + Result := Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("concat")), + Elt.Sequence.all.Data (2), Result)); + else + Result := Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("cons")), + Quasiquote (Elt), Result)); + end if; + end loop; + return Result; + end Qq_Seq; + + function Starts_With (Sequence : Types.T_Array; + Symbol : String) return Boolean is + (0 < Sequence'Length + and then Sequence (Sequence'First).Kind = Kind_Symbol + and then Sequence (Sequence'First).Str.all = Symbol); + + begin + case Ast.Kind is + when Kind_List => + if Starts_With (Ast.Sequence.all.Data, "unquote") then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all.Data (2); + else + return Qq_Seq; + end if; + when Kind_Vector => + return Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("vec")), Qq_Seq)); + when Kind_Map | Kind_Symbol => + return Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("quote")), Ast)); + when others => + return Ast; + end case; + exception + when Err.Error => + Err.Add_Trace_Line ("quasiquote", Ast); + raise; + end Quasiquote; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" + & "(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)))))))"; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); +begin + -- Show the Eval function to other packages. + Types.Fns.Eval_Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + Core.NS_Add_To_Repl (Repl); + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); + -- Native startup procedure. + Exec (Startup, Repl); + -- Define ARGV from command line arguments. + for I in 2 .. ACL.Argument_Count loop + Argv.all.Data (I - 1) := (Kind_String, + Types.Strings.Alloc (ACL.Argument (I))); + end loop; + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), + (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); + else + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + end if; + + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end Step9_Try; diff --git a/impls/ada.2/stepa_mal.adb b/impls/ada.2/stepa_mal.adb index 59a1ad7fd1..eabce22085 100644 --- a/impls/ada.2/stepa_mal.adb +++ b/impls/ada.2/stepa_mal.adb @@ -1,485 +1,485 @@ -with Ada.Command_Line; -with Ada.Environment_Variables; -with Ada.Text_IO.Unbounded_IO; - -with Core; -with Envs; -with Err; -with Garbage_Collected; -with Printer; -with Reader; -with Readline; -with Types.Builtins; -with Types.Fns; -with Types.Maps; -with Types.Sequences; -with Types.Strings; - -procedure StepA_Mal is - - Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); - - use type Types.T; - use all type Types.Kind_Type; - use type Types.Strings.Instance; - package ACL renames Ada.Command_Line; - - function Read return Types.T_Array with Inline; - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T; - function Eval_Builtin (Args : in Types.T_Array) return Types.T; - -- The built-in variant needs to see the Repl variable. - - function Quasiquote (Ast : in Types.T) return Types.T; - - procedure Print (Ast : in Types.T) with Inline; - - procedure Rep (Env : in Envs.Ptr) with Inline; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T; - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T; - -- Helpers for the Eval function. - - procedure Exec (Script : in String; - Env : in Envs.Ptr) with Inline; - -- Read the script, eval its elements, but ignore the result. - - ---------------------------------------------------------------------- - - function Eval (Ast0 : in Types.T; - Env0 : in Envs.Ptr) return Types.T - is - -- Use local variables, that can be rewritten when tail call - -- optimization goes to <>. - Ast : Types.T := Ast0; - Env : Envs.Ptr := Env0; - Env_Reusable : Boolean := False; - -- True when the environment has been created in this recursion - -- level, and has not yet been referenced by a closure. If so, - -- we can reuse it instead of creating a subenvironment. - Macroexpanding : Boolean := False; - First : Types.T; - begin - <> - if Dbgeval then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put ("EVAL: "); - Print (Ast); - Envs.Dump_Stack (Env.all); - end if; - - case Ast.Kind is - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - return Ast; - when Kind_Symbol => - return Env.all.Get (Ast.Str); - when Kind_Map => - return Eval_Map (Ast.Map.all, Env); - when Kind_Vector => - return Eval_Vector (Ast.Sequence.all, Env); - when Kind_List => - null; - end case; - - -- Ast is a list. - if Ast.Sequence.all.Length = 0 then - return Ast; - end if; - First := Ast.Sequence.all.Data (1); - - -- Special forms - -- Ast is a non-empty list, First is its first element. - case First.Kind is - when Kind_Symbol => - if First.Str.all = "if" then - Err.Check (Ast.Sequence.all.Length in 3 .. 4, - "expected 2 or 3 parameters"); - declare - Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); - begin - if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then - Ast := Ast.Sequence.all.Data (3); - goto Restart; - elsif Ast.Sequence.all.Length = 3 then - return Types.Nil; - else - Ast := Ast.Sequence.all.Data (4); - goto Restart; - end if; - end; - elsif First.Str.all = "let*" then - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, - "expected a sequence then a value"); - declare - Bindings : Types.T_Array - renames Ast.Sequence.all.Data (2).Sequence.all.Data; - begin - Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); - if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); - Env_Reusable := True; - end if; - for I in 0 .. Bindings'Length / 2 - 1 loop - Env.all.Set (Bindings (Bindings'First + 2 * I), - Eval (Bindings (Bindings'First + 2 * I + 1), Env)); - -- This call checks key kind. - end loop; - Ast := Ast.Sequence.all.Data (3); - goto Restart; - end; - elsif First.Str.all = "quote" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Ast.Sequence.all.Data (2); - elsif First.Str.all = "def!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - begin - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "defmacro!" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Key : Types.T renames Ast.Sequence.all.Data (2); - Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); - Val : Types.T; - begin - Err.Check (Fun.Kind = Kind_Fn, "expected a function"); - Val := (Kind_Macro, Types.Fns.New_Function - (Params => Fun.Fn.all.Params, - Ast => Fun.Fn.all.Ast, - Env => Fun.Fn.all.Env)); - Env.all.Set (Key, Val); -- Check key kind. - return Val; - end; - elsif First.Str.all = "do" then - Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); - declare - Result : Types.T; - begin - for I in 2 .. Ast.Sequence.all.Length - 1 loop - Result := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - pragma Unreferenced (Result); - end; - Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); - goto Restart; - elsif First.Str.all = "fn*" then - Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); - declare - Params : Types.T renames Ast.Sequence.all.Data (2); - begin - Err.Check (Params.Kind in Types.Kind_Sequence, - "first argument of fn* must be a sequence"); - Env_Reusable := False; - return (Kind_Fn, Types.Fns.New_Function - (Params => Params.Sequence, - Ast => Ast.Sequence.all.Data (3), - Env => Env)); - end; - elsif First.Str.all = "macroexpand" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - Macroexpanding := True; - Ast := Ast.Sequence.all.Data (2); - goto Restart; - elsif First.Str.all = "quasiquoteexpand" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Quasiquote (Ast.Sequence.all.Data (2)); - elsif First.Str.all = "quasiquote" then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - Ast := Quasiquote (Ast.Sequence.all.Data (2)); - goto Restart; - elsif First.Str.all = "try*" then - if Ast.Sequence.all.Length = 2 then - Ast := Ast.Sequence.all.Data (2); - goto Restart; - end if; - Err.Check (Ast.Sequence.all.Length = 3 - and then Ast.Sequence.all.Data (3).Kind = Kind_List, - "expected 1 parameter, maybe followed by a list"); - declare - A3 : Types.T_Array - renames Ast.Sequence.all.Data (3).Sequence.all.Data; - begin - Err.Check (A3'Length = 3 - and then A3 (A3'First).Kind = Kind_Symbol - and then A3 (A3'First).Str.all = "catch*", - "3rd parameter if present must be a catch* list"); - begin - return Eval (Ast.Sequence.all.Data (2), Env); - exception - when Err.Error => - null; - end; - if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); - Env_Reusable := True; - end if; - Env.all.Set (A3 (A3'First + 1), Err.Data); -- check key kind - Ast := A3 (A3'Last); - goto Restart; - end; - else - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - First := Env.all.Get (First.Str); - end if; - when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key - | Kind_Macro | Types.Kind_Function => - -- Equivalent to First := Eval (First, Env) - -- except that we already know enough to spare a recursive call. - null; - when Types.Kind_Sequence | Kind_Map => - -- Lists are definitely worth a recursion, and the two other - -- cases should be rare (they will report an error later). - First := Eval (First, Env); - end case; - - -- Apply phase. - -- Ast is a non-empty list, - -- First is its non-special evaluated first element. - case First.Kind is - when Kind_Macro => - -- Use the unevaluated arguments. - if Macroexpanding then - -- Evaluate the macro with tail call optimization. - if not Env_Reusable then - Env := Envs.New_Env (Outer => First.Fn.all.Env); - Env_Reusable := True; - end if; - Env.all.Set_Binds - (Binds => First.Fn.all.Params.all.Data, - Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); - Ast := First.Fn.all.Ast; - goto Restart; - else - -- Evaluate the macro normally. - Ast := First.Fn.all.Apply - (Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); - -- Then evaluate the result with TCO. - goto Restart; - end if; - when Types.Kind_Function => - null; - when others => - Err.Raise_With ("first element must be a function or macro"); - end case; - -- We are applying a function. Evaluate its arguments. - declare - Args : Types.T_Array (2 .. Ast.Sequence.all.Length); - begin - for I in Args'Range loop - Args (I) := Eval (Ast.Sequence.all.Data (I), Env); - end loop; - case First.Kind is - when Kind_Builtin => - return First.Builtin.all (Args); - when Kind_Builtin_With_Meta => - return First.Builtin_With_Meta.all.Builtin.all (Args); - when others => - null; - end case; - -- Like Types.Fns.Apply, except that we use TCO. - Env := Envs.New_Env (Outer => First.Fn.all.Env); - Env_Reusable := True; - Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, - Exprs => Args); - Ast := First.Fn.all.Ast; - goto Restart; - end; - exception - when Err.Error => - if Macroexpanding then - Err.Add_Trace_Line ("macroexpand", Ast); - else - Err.Add_Trace_Line ("eval", Ast); - end if; - raise; - end Eval; - - function Eval_Map (Source : in Types.Maps.Instance; - Env : in Envs.Ptr) return Types.T - is - use all type Types.Maps.Cursor; - -- Copy the whole map so that keys are not hashed again. - Result : constant Types.T := Types.Maps.New_Map (Source); - Position : Types.Maps.Cursor := Result.Map.all.First; - begin - while Has_Element (Position) loop - Result.Map.all.Replace_Element (Position, - Eval (Element (Position), Env)); - Next (Position); - end loop; - return Result; - end Eval_Map; - - function Eval_Vector (Source : in Types.Sequences.Instance; - Env : in Envs.Ptr) return Types.T - is - Ref : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Source.Length); - begin - for I in Source.Data'Range loop - Ref.all.Data (I) := Eval (Source.Data (I), Env); - end loop; - return (Kind_Vector, Ref); - end Eval_Vector; - - procedure Exec (Script : in String; - Env : in Envs.Ptr) - is - Result : Types.T; - begin - for Expression of Reader.Read_Str (Script) loop - Result := Eval (Expression, Env); - end loop; - pragma Unreferenced (Result); - end Exec; - - procedure Print (Ast : in Types.T) is - begin - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); - end Print; - - function Quasiquote (Ast : in Types.T) return Types.T is - - function Qq_Seq return Types.T; - function Starts_With (Sequence : Types.T_Array; - Symbol : String) return Boolean; - - function Qq_Seq return Types.T is - Result : Types.T := Types.Sequences.List ((1 .. 0 => Types.Nil)); - begin - for Elt of reverse Ast.Sequence.all.Data loop - if Elt.Kind = Kind_List - and then Starts_With (Elt.Sequence.all.Data, "splice-unquote") - then - Err.Check (Elt.Sequence.all.Length = 2, - "splice-unquote expects 1 parameter"); - Result := Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("concat")), - Elt.Sequence.all.Data (2), Result)); - else - Result := Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("cons")), - Quasiquote (Elt), Result)); - end if; - end loop; - return Result; - end Qq_Seq; - - function Starts_With (Sequence : Types.T_Array; - Symbol : String) return Boolean is - (0 < Sequence'Length - and then Sequence (Sequence'First).Kind = Kind_Symbol - and then Sequence (Sequence'First).Str.all = Symbol); - - begin - case Ast.Kind is - when Kind_List => - if Starts_With (Ast.Sequence.all.Data, "unquote") then - Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); - return Ast.Sequence.all.Data (2); - else - return Qq_Seq; - end if; - when Kind_Vector => - return Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("vec")), Qq_Seq)); - when Kind_Map | Kind_Symbol => - return Types.Sequences.List - (((Kind_Symbol, Types.Strings.Alloc ("quote")), Ast)); - when others => - return Ast; - end case; - exception - when Err.Error => - Err.Add_Trace_Line ("quasiquote", Ast); - raise; - end Quasiquote; - - function Read return Types.T_Array - is (Reader.Read_Str (Readline.Input ("user> "))); - - procedure Rep (Env : in Envs.Ptr) is - begin - for Expression of Read loop - Print (Eval (Expression, Env)); - end loop; - end Rep; - - ---------------------------------------------------------------------- - - Startup : constant String - := "(def! not (fn* (a) (if a false true)))" - & "(def! load-file (fn* (f)" - & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" - & "(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)))))))" - & "(def! *host-language* ""ada.2"")"; - Repl : constant Envs.Ptr := Envs.New_Env; - function Eval_Builtin (Args : in Types.T_Array) return Types.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return Eval (Args (Args'First), Repl); - end Eval_Builtin; - Script : constant Boolean := 0 < ACL.Argument_Count; - Argv : constant Types.Sequence_Ptr - := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); -begin - -- Show the Eval function to other packages. - Types.Fns.Eval_Cb := Eval'Unrestricted_Access; - -- Add Core functions into the top environment. - Core.NS_Add_To_Repl (Repl); - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), - (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); - -- Native startup procedure. - Exec (Startup, Repl); - -- Define ARGV from command line arguments. - for I in 2 .. ACL.Argument_Count loop - Argv.all.Data (I - 1) := (Kind_String, - Types.Strings.Alloc (ACL.Argument (I))); - end loop; - Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), - (Kind_List, Argv)); - -- Execute user commands. - if Script then - Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); - else - Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl); - loop - begin - Rep (Repl); - exception - when Readline.End_Of_File => - exit; - when Err.Error => - Ada.Text_IO.Unbounded_IO.Put (Err.Trace); - end; - -- Other exceptions are really unexpected. - - -- Collect garbage. - Err.Data := Types.Nil; - Repl.all.Keep; - Garbage_Collected.Clean; - end loop; - Ada.Text_IO.New_Line; - end if; - - -- If assertions are enabled, check deallocations. - -- Normal runs do not need to deallocate before termination. - -- Beware that all pointers are now dangling. - pragma Debug (Garbage_Collected.Clean); - Garbage_Collected.Check_Allocations; -end StepA_Mal; +with Ada.Command_Line; +with Ada.Environment_Variables; +with Ada.Text_IO.Unbounded_IO; + +with Core; +with Envs; +with Err; +with Garbage_Collected; +with Printer; +with Reader; +with Readline; +with Types.Builtins; +with Types.Fns; +with Types.Maps; +with Types.Sequences; +with Types.Strings; + +procedure StepA_Mal is + + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); + + use type Types.T; + use all type Types.Kind_Type; + use type Types.Strings.Instance; + package ACL renames Ada.Command_Line; + + function Read return Types.T_Array with Inline; + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T; + function Eval_Builtin (Args : in Types.T_Array) return Types.T; + -- The built-in variant needs to see the Repl variable. + + function Quasiquote (Ast : in Types.T) return Types.T; + + procedure Print (Ast : in Types.T) with Inline; + + procedure Rep (Env : in Envs.Ptr) with Inline; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T; + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T; + -- Helpers for the Eval function. + + procedure Exec (Script : in String; + Env : in Envs.Ptr) with Inline; + -- Read the script, eval its elements, but ignore the result. + + ---------------------------------------------------------------------- + + function Eval (Ast0 : in Types.T; + Env0 : in Envs.Ptr) return Types.T + is + -- Use local variables, that can be rewritten when tail call + -- optimization goes to <>. + Ast : Types.T := Ast0; + Env : Envs.Ptr := Env0; + Env_Reusable : Boolean := False; + -- True when the environment has been created in this recursion + -- level, and has not yet been referenced by a closure. If so, + -- we can reuse it instead of creating a subenvironment. + Macroexpanding : Boolean := False; + First : Types.T; + begin + <> + if Dbgeval then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("EVAL: "); + Print (Ast); + Envs.Dump_Stack (Env.all); + end if; + + case Ast.Kind is + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + return Ast; + when Kind_Symbol => + return Env.all.Get (Ast.Str); + when Kind_Map => + return Eval_Map (Ast.Map.all, Env); + when Kind_Vector => + return Eval_Vector (Ast.Sequence.all, Env); + when Kind_List => + null; + end case; + + -- Ast is a list. + if Ast.Sequence.all.Length = 0 then + return Ast; + end if; + First := Ast.Sequence.all.Data (1); + + -- Special forms + -- Ast is a non-empty list, First is its first element. + case First.Kind is + when Kind_Symbol => + if First.Str.all = "if" then + Err.Check (Ast.Sequence.all.Length in 3 .. 4, + "expected 2 or 3 parameters"); + declare + Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); + begin + if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then + Ast := Ast.Sequence.all.Data (3); + goto Restart; + elsif Ast.Sequence.all.Length = 3 then + return Types.Nil; + else + Ast := Ast.Sequence.all.Data (4); + goto Restart; + end if; + end; + elsif First.Str.all = "let*" then + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, + "expected a sequence then a value"); + declare + Bindings : Types.T_Array + renames Ast.Sequence.all.Data (2).Sequence.all.Data; + begin + Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); + if not Env_Reusable then + Env := Envs.New_Env (Outer => Env); + Env_Reusable := True; + end if; + for I in 0 .. Bindings'Length / 2 - 1 loop + Env.all.Set (Bindings (Bindings'First + 2 * I), + Eval (Bindings (Bindings'First + 2 * I + 1), Env)); + -- This call checks key kind. + end loop; + Ast := Ast.Sequence.all.Data (3); + goto Restart; + end; + elsif First.Str.all = "quote" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all.Data (2); + elsif First.Str.all = "def!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + begin + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "defmacro!" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Key : Types.T renames Ast.Sequence.all.Data (2); + Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); + Val : Types.T; + begin + Err.Check (Fun.Kind = Kind_Fn, "expected a function"); + Val := (Kind_Macro, Types.Fns.New_Function + (Params => Fun.Fn.all.Params, + Ast => Fun.Fn.all.Ast, + Env => Fun.Fn.all.Env)); + Env.all.Set (Key, Val); -- Check key kind. + return Val; + end; + elsif First.Str.all = "do" then + Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); + declare + Result : Types.T; + begin + for I in 2 .. Ast.Sequence.all.Length - 1 loop + Result := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + pragma Unreferenced (Result); + end; + Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); + goto Restart; + elsif First.Str.all = "fn*" then + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + declare + Params : Types.T renames Ast.Sequence.all.Data (2); + begin + Err.Check (Params.Kind in Types.Kind_Sequence, + "first argument of fn* must be a sequence"); + Env_Reusable := False; + return (Kind_Fn, Types.Fns.New_Function + (Params => Params.Sequence, + Ast => Ast.Sequence.all.Data (3), + Env => Env)); + end; + elsif First.Str.all = "macroexpand" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + Macroexpanding := True; + Ast := Ast.Sequence.all.Data (2); + goto Restart; + elsif First.Str.all = "quasiquoteexpand" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence.all.Data (2)); + elsif First.Str.all = "quasiquote" then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + Ast := Quasiquote (Ast.Sequence.all.Data (2)); + goto Restart; + elsif First.Str.all = "try*" then + if Ast.Sequence.all.Length = 2 then + Ast := Ast.Sequence.all.Data (2); + goto Restart; + end if; + Err.Check (Ast.Sequence.all.Length = 3 + and then Ast.Sequence.all.Data (3).Kind = Kind_List, + "expected 1 parameter, maybe followed by a list"); + declare + A3 : Types.T_Array + renames Ast.Sequence.all.Data (3).Sequence.all.Data; + begin + Err.Check (A3'Length = 3 + and then A3 (A3'First).Kind = Kind_Symbol + and then A3 (A3'First).Str.all = "catch*", + "3rd parameter if present must be a catch* list"); + begin + return Eval (Ast.Sequence.all.Data (2), Env); + exception + when Err.Error => + null; + end; + if not Env_Reusable then + Env := Envs.New_Env (Outer => Env); + Env_Reusable := True; + end if; + Env.all.Set (A3 (A3'First + 1), Err.Data); -- check key kind + Ast := A3 (A3'Last); + goto Restart; + end; + else + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + First := Env.all.Get (First.Str); + end if; + when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key + | Kind_Macro | Types.Kind_Function => + -- Equivalent to First := Eval (First, Env) + -- except that we already know enough to spare a recursive call. + null; + when Types.Kind_Sequence | Kind_Map => + -- Lists are definitely worth a recursion, and the two other + -- cases should be rare (they will report an error later). + First := Eval (First, Env); + end case; + + -- Apply phase. + -- Ast is a non-empty list, + -- First is its non-special evaluated first element. + case First.Kind is + when Kind_Macro => + -- Use the unevaluated arguments. + if Macroexpanding then + -- Evaluate the macro with tail call optimization. + if not Env_Reusable then + Env := Envs.New_Env (Outer => First.Fn.all.Env); + Env_Reusable := True; + end if; + Env.all.Set_Binds + (Binds => First.Fn.all.Params.all.Data, + Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); + Ast := First.Fn.all.Ast; + goto Restart; + else + -- Evaluate the macro normally. + Ast := First.Fn.all.Apply + (Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); + -- Then evaluate the result with TCO. + goto Restart; + end if; + when Types.Kind_Function => + null; + when others => + Err.Raise_With ("first element must be a function or macro"); + end case; + -- We are applying a function. Evaluate its arguments. + declare + Args : Types.T_Array (2 .. Ast.Sequence.all.Length); + begin + for I in Args'Range loop + Args (I) := Eval (Ast.Sequence.all.Data (I), Env); + end loop; + case First.Kind is + when Kind_Builtin => + return First.Builtin.all (Args); + when Kind_Builtin_With_Meta => + return First.Builtin_With_Meta.all.Builtin.all (Args); + when others => + null; + end case; + -- Like Types.Fns.Apply, except that we use TCO. + Env := Envs.New_Env (Outer => First.Fn.all.Env); + Env_Reusable := True; + Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, + Exprs => Args); + Ast := First.Fn.all.Ast; + goto Restart; + end; + exception + when Err.Error => + if Macroexpanding then + Err.Add_Trace_Line ("macroexpand", Ast); + else + Err.Add_Trace_Line ("eval", Ast); + end if; + raise; + end Eval; + + function Eval_Map (Source : in Types.Maps.Instance; + Env : in Envs.Ptr) return Types.T + is + use all type Types.Maps.Cursor; + -- Copy the whole map so that keys are not hashed again. + Result : constant Types.T := Types.Maps.New_Map (Source); + Position : Types.Maps.Cursor := Result.Map.all.First; + begin + while Has_Element (Position) loop + Result.Map.all.Replace_Element (Position, + Eval (Element (Position), Env)); + Next (Position); + end loop; + return Result; + end Eval_Map; + + function Eval_Vector (Source : in Types.Sequences.Instance; + Env : in Envs.Ptr) return Types.T + is + Ref : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Source.Length); + begin + for I in Source.Data'Range loop + Ref.all.Data (I) := Eval (Source.Data (I), Env); + end loop; + return (Kind_Vector, Ref); + end Eval_Vector; + + procedure Exec (Script : in String; + Env : in Envs.Ptr) + is + Result : Types.T; + begin + for Expression of Reader.Read_Str (Script) loop + Result := Eval (Expression, Env); + end loop; + pragma Unreferenced (Result); + end Exec; + + procedure Print (Ast : in Types.T) is + begin + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); + end Print; + + function Quasiquote (Ast : in Types.T) return Types.T is + + function Qq_Seq return Types.T; + function Starts_With (Sequence : Types.T_Array; + Symbol : String) return Boolean; + + function Qq_Seq return Types.T is + Result : Types.T := Types.Sequences.List ((1 .. 0 => Types.Nil)); + begin + for Elt of reverse Ast.Sequence.all.Data loop + if Elt.Kind = Kind_List + and then Starts_With (Elt.Sequence.all.Data, "splice-unquote") + then + Err.Check (Elt.Sequence.all.Length = 2, + "splice-unquote expects 1 parameter"); + Result := Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("concat")), + Elt.Sequence.all.Data (2), Result)); + else + Result := Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("cons")), + Quasiquote (Elt), Result)); + end if; + end loop; + return Result; + end Qq_Seq; + + function Starts_With (Sequence : Types.T_Array; + Symbol : String) return Boolean is + (0 < Sequence'Length + and then Sequence (Sequence'First).Kind = Kind_Symbol + and then Sequence (Sequence'First).Str.all = Symbol); + + begin + case Ast.Kind is + when Kind_List => + if Starts_With (Ast.Sequence.all.Data, "unquote") then + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all.Data (2); + else + return Qq_Seq; + end if; + when Kind_Vector => + return Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("vec")), Qq_Seq)); + when Kind_Map | Kind_Symbol => + return Types.Sequences.List + (((Kind_Symbol, Types.Strings.Alloc ("quote")), Ast)); + when others => + return Ast; + end case; + exception + when Err.Error => + Err.Add_Trace_Line ("quasiquote", Ast); + raise; + end Quasiquote; + + function Read return Types.T_Array + is (Reader.Read_Str (Readline.Input ("user> "))); + + procedure Rep (Env : in Envs.Ptr) is + begin + for Expression of Read loop + Print (Eval (Expression, Env)); + end loop; + end Rep; + + ---------------------------------------------------------------------- + + Startup : constant String + := "(def! not (fn* (a) (if a false true)))" + & "(def! load-file (fn* (f)" + & " (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" + & "(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)))))))" + & "(def! *host-language* ""ada.2"")"; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Types.T_Array) return Types.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : constant Types.Sequence_Ptr + := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); +begin + -- Show the Eval function to other packages. + Types.Fns.Eval_Cb := Eval'Unrestricted_Access; + -- Add Core functions into the top environment. + Core.NS_Add_To_Repl (Repl); + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); + -- Native startup procedure. + Exec (Startup, Repl); + -- Define ARGV from command line arguments. + for I in 2 .. ACL.Argument_Count loop + Argv.all.Data (I - 1) := (Kind_String, + Types.Strings.Alloc (ACL.Argument (I))); + end loop; + Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), + (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); + else + Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl); + loop + begin + Rep (Repl); + exception + when Readline.End_Of_File => + exit; + when Err.Error => + Ada.Text_IO.Unbounded_IO.Put (Err.Trace); + end; + -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Types.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; + end loop; + Ada.Text_IO.New_Line; + end if; + + -- If assertions are enabled, check deallocations. + -- Normal runs do not need to deallocate before termination. + -- Beware that all pointers are now dangling. + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; +end StepA_Mal; diff --git a/impls/ada.2/types-atoms.adb b/impls/ada.2/types-atoms.adb index 848cf54592..805e0c59e7 100644 --- a/impls/ada.2/types-atoms.adb +++ b/impls/ada.2/types-atoms.adb @@ -1,65 +1,65 @@ -with Err; -with Types.Builtins; -with Types.Fns; - -package body Types.Atoms is - - function Atom (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - declare - Ref : constant Atom_Ptr := new Instance; - begin - Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); - Ref.all.Data := Args (Args'First); - return (Kind_Atom, Ref); - end; - end Atom; - - function Deref (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Atom, - "expected an atom"); - return Args (Args'First).Atom.all.Data; - end Deref; - - function Deref (Item : in Instance) return T - is (Item.Data); - - procedure Keep_References (Object : in out Instance) is - begin - Keep (Object.Data); - end Keep_References; - - function Reset (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 2 and then Args (Args'First).Kind = Kind_Atom, - "expected an atom then a value"); - Args (Args'First).Atom.all.Data := Args (Args'Last); - return Args (Args'Last); - end Reset; - - function Swap (Args : in T_Array) return T is - begin - Err.Check (2 <= Args'Length and then Args (Args'First).Kind = Kind_Atom, - "expected an atom, a function, then optional arguments"); - declare - X : T renames Args (Args'First).Atom.all.Data; - F : T renames Args (Args'First + 1); - A : constant T_Array := X & Args (Args'First + 2 .. Args'Last); - begin - case F.Kind is - when Kind_Builtin => - X := F.Builtin.all (A); - when Kind_Builtin_With_Meta => - X := F.Builtin_With_Meta.all.Builtin.all (A); - when Kind_Fn => - X := F.Fn.all.Apply (A); - when others => - Err.Raise_With ("parameter 2 must be a function"); - end case; - return X; - end; - end Swap; - -end Types.Atoms; +with Err; +with Types.Builtins; +with Types.Fns; + +package body Types.Atoms is + + function Atom (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + declare + Ref : constant Atom_Ptr := new Instance; + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + Ref.all.Data := Args (Args'First); + return (Kind_Atom, Ref); + end; + end Atom; + + function Deref (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Atom, + "expected an atom"); + return Args (Args'First).Atom.all.Data; + end Deref; + + function Deref (Item : in Instance) return T + is (Item.Data); + + procedure Keep_References (Object : in out Instance) is + begin + Keep (Object.Data); + end Keep_References; + + function Reset (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 2 and then Args (Args'First).Kind = Kind_Atom, + "expected an atom then a value"); + Args (Args'First).Atom.all.Data := Args (Args'Last); + return Args (Args'Last); + end Reset; + + function Swap (Args : in T_Array) return T is + begin + Err.Check (2 <= Args'Length and then Args (Args'First).Kind = Kind_Atom, + "expected an atom, a function, then optional arguments"); + declare + X : T renames Args (Args'First).Atom.all.Data; + F : T renames Args (Args'First + 1); + A : constant T_Array := X & Args (Args'First + 2 .. Args'Last); + begin + case F.Kind is + when Kind_Builtin => + X := F.Builtin.all (A); + when Kind_Builtin_With_Meta => + X := F.Builtin_With_Meta.all.Builtin.all (A); + when Kind_Fn => + X := F.Fn.all.Apply (A); + when others => + Err.Raise_With ("parameter 2 must be a function"); + end case; + return X; + end; + end Swap; + +end Types.Atoms; diff --git a/impls/ada.2/types-atoms.ads b/impls/ada.2/types-atoms.ads index 8764ad4442..00d736a421 100644 --- a/impls/ada.2/types-atoms.ads +++ b/impls/ada.2/types-atoms.ads @@ -1,24 +1,24 @@ -with Garbage_Collected; - -package Types.Atoms is - - type Instance (<>) is abstract new Garbage_Collected.Instance with private; - - -- Built-in functions. - function Atom (Args : in T_Array) return T; - function Deref (Args : in T_Array) return T; - function Reset (Args : in T_Array) return T; - function Swap (Args : in T_Array) return T; - - -- Helper for print. - function Deref (Item : in Instance) return T with Inline; - -private - - type Instance is new Garbage_Collected.Instance with record - Data : T; - end record; - - overriding procedure Keep_References (Object : in out Instance) with Inline; - -end Types.Atoms; +with Garbage_Collected; + +package Types.Atoms is + + type Instance (<>) is abstract new Garbage_Collected.Instance with private; + + -- Built-in functions. + function Atom (Args : in T_Array) return T; + function Deref (Args : in T_Array) return T; + function Reset (Args : in T_Array) return T; + function Swap (Args : in T_Array) return T; + + -- Helper for print. + function Deref (Item : in Instance) return T with Inline; + +private + + type Instance is new Garbage_Collected.Instance with record + Data : T; + end record; + + overriding procedure Keep_References (Object : in out Instance) with Inline; + +end Types.Atoms; diff --git a/impls/ada.2/types-builtins.adb b/impls/ada.2/types-builtins.adb index cd85b526a5..41f88e7365 100644 --- a/impls/ada.2/types-builtins.adb +++ b/impls/ada.2/types-builtins.adb @@ -1,31 +1,31 @@ -package body Types.Builtins is - - function Builtin (Item : in Instance) return Builtin_Ptr - is (Item.F_Builtin); - - procedure Keep_References (Object : in out Instance) is - begin - Keep (Object.F_Meta); - end Keep_References; - - function Meta (Item : in Instance) return T - is (Item.F_Meta); - - function With_Meta (Builtin : in Builtin_Ptr; - Metadata : in T) return T - is - -- Builtin is not null and requires an immediate initialization. - Ref : constant Builtin_With_Meta_Ptr - := new Instance'(Garbage_Collected.Instance with - F_Builtin => Builtin, - F_Meta => Metadata); - begin - Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); - return (Kind_Builtin_With_Meta, Ref); - end With_Meta; - - function With_Meta (Builtin : in Instance; - Metadata : in T) return T - is (With_Meta (Builtin.F_Builtin, Metadata)); - -end Types.Builtins; +package body Types.Builtins is + + function Builtin (Item : in Instance) return Builtin_Ptr + is (Item.F_Builtin); + + procedure Keep_References (Object : in out Instance) is + begin + Keep (Object.F_Meta); + end Keep_References; + + function Meta (Item : in Instance) return T + is (Item.F_Meta); + + function With_Meta (Builtin : in Builtin_Ptr; + Metadata : in T) return T + is + -- Builtin is not null and requires an immediate initialization. + Ref : constant Builtin_With_Meta_Ptr + := new Instance'(Garbage_Collected.Instance with + F_Builtin => Builtin, + F_Meta => Metadata); + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + return (Kind_Builtin_With_Meta, Ref); + end With_Meta; + + function With_Meta (Builtin : in Instance; + Metadata : in T) return T + is (With_Meta (Builtin.F_Builtin, Metadata)); + +end Types.Builtins; diff --git a/impls/ada.2/types-builtins.ads b/impls/ada.2/types-builtins.ads index 3da6a1c8f8..da7befe389 100644 --- a/impls/ada.2/types-builtins.ads +++ b/impls/ada.2/types-builtins.ads @@ -1,28 +1,28 @@ -with Garbage_Collected; - -package Types.Builtins is - - -- Types.Mal.Builtin_Ptr is efficient and sufficient for most - -- purposes, as native function need no deallocation. The type - -- below is only useful to add metadata to a built-in. - - type Instance (<>) is abstract new Garbage_Collected.Instance with private; - - function With_Meta (Builtin : in Builtin_Ptr; - Metadata : in T) return T with Inline; - function With_Meta (Builtin : in Instance; - Metadata : in T) return T with Inline; - - function Meta (Item : in Instance) return T with Inline; - function Builtin (Item : in Instance) return Builtin_Ptr with Inline; - -private - - type Instance is new Garbage_Collected.Instance with record - F_Builtin : Builtin_Ptr; - F_Meta : T; - end record; - - overriding procedure Keep_References (Object : in out Instance) with Inline; - -end Types.Builtins; +with Garbage_Collected; + +package Types.Builtins is + + -- Types.Mal.Builtin_Ptr is efficient and sufficient for most + -- purposes, as native function need no deallocation. The type + -- below is only useful to add metadata to a built-in. + + type Instance (<>) is abstract new Garbage_Collected.Instance with private; + + function With_Meta (Builtin : in Builtin_Ptr; + Metadata : in T) return T with Inline; + function With_Meta (Builtin : in Instance; + Metadata : in T) return T with Inline; + + function Meta (Item : in Instance) return T with Inline; + function Builtin (Item : in Instance) return Builtin_Ptr with Inline; + +private + + type Instance is new Garbage_Collected.Instance with record + F_Builtin : Builtin_Ptr; + F_Meta : T; + end record; + + overriding procedure Keep_References (Object : in out Instance) with Inline; + +end Types.Builtins; diff --git a/impls/ada.2/types-fns.adb b/impls/ada.2/types-fns.adb index 6deb6e063d..9a284389a7 100644 --- a/impls/ada.2/types-fns.adb +++ b/impls/ada.2/types-fns.adb @@ -1,59 +1,59 @@ -with Err; -pragma Warnings (Off, "unit ""Types.Sequences"" is not referenced"); -with Types.Sequences; -pragma Warnings (On, "unit ""Types.Sequences"" is not referenced"); - -package body Types.Fns is - - function Apply (Item : in Instance; - Args : in T_Array) return T - is - Env : constant Envs.Ptr := Envs.New_Env (Outer => Item.F_Env); - begin - Env.all.Set_Binds (Binds => Item.F_Params.all.Data, - Exprs => Args); - return Eval_Cb.all (Ast => Item.F_Ast, - Env => Env); - end Apply; - - function Ast (Item : in Instance) return T - is (Item.F_Ast); - - function Env (Item : in Instance) return Envs.Ptr - is (Item.F_Env); - - procedure Keep_References (Object : in out Instance) is - begin - Keep (Object.F_Ast); - Object.F_Params.all.Keep; - Object.F_Env.all.Keep; - Keep (Object.F_Meta); - end Keep_References; - - function Meta (Item : in Instance) return T - is (Item.F_Meta); - - function New_Function (Params : in Sequence_Ptr; - Ast : in T; - Env : in Envs.Ptr; - Metadata : in T := Nil) return Fn_Ptr - is - -- Env and Params are not null and require an immediate - -- initialization. - Ref : constant Fn_Ptr - := new Instance'(Garbage_Collected.Instance with - F_Ast => Ast, - F_Env => Env, - F_Meta => Metadata, - F_Params => Params); - begin - Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); - Err.Check ((for all P of Params.all.Data => P.Kind = Kind_Symbol), - "formal parameters must be symbols"); - return Ref; - end New_Function; - - function Params (Item : in Instance) return Sequence_Ptr - is (Item.F_Params); - -end Types.Fns; +with Err; +pragma Warnings (Off, "unit ""Types.Sequences"" is not referenced"); +with Types.Sequences; +pragma Warnings (On, "unit ""Types.Sequences"" is not referenced"); + +package body Types.Fns is + + function Apply (Item : in Instance; + Args : in T_Array) return T + is + Env : constant Envs.Ptr := Envs.New_Env (Outer => Item.F_Env); + begin + Env.all.Set_Binds (Binds => Item.F_Params.all.Data, + Exprs => Args); + return Eval_Cb.all (Ast => Item.F_Ast, + Env => Env); + end Apply; + + function Ast (Item : in Instance) return T + is (Item.F_Ast); + + function Env (Item : in Instance) return Envs.Ptr + is (Item.F_Env); + + procedure Keep_References (Object : in out Instance) is + begin + Keep (Object.F_Ast); + Object.F_Params.all.Keep; + Object.F_Env.all.Keep; + Keep (Object.F_Meta); + end Keep_References; + + function Meta (Item : in Instance) return T + is (Item.F_Meta); + + function New_Function (Params : in Sequence_Ptr; + Ast : in T; + Env : in Envs.Ptr; + Metadata : in T := Nil) return Fn_Ptr + is + -- Env and Params are not null and require an immediate + -- initialization. + Ref : constant Fn_Ptr + := new Instance'(Garbage_Collected.Instance with + F_Ast => Ast, + F_Env => Env, + F_Meta => Metadata, + F_Params => Params); + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + Err.Check ((for all P of Params.all.Data => P.Kind = Kind_Symbol), + "formal parameters must be symbols"); + return Ref; + end New_Function; + + function Params (Item : in Instance) return Sequence_Ptr + is (Item.F_Params); + +end Types.Fns; diff --git a/impls/ada.2/types-fns.ads b/impls/ada.2/types-fns.ads index 7a0b8f56ca..21b55a4be0 100644 --- a/impls/ada.2/types-fns.ads +++ b/impls/ada.2/types-fns.ads @@ -1,45 +1,45 @@ -with Envs; -with Garbage_Collected; - -package Types.Fns is - - Eval_Cb : access function (Ast : in T; - Env : in Envs.Ptr) return T; - -- The main program must register this global callback to the main - -- eval function before Apply is called. - - type Instance (<>) is abstract new Garbage_Collected.Instance with private; - - function New_Function (Params : in Sequence_Ptr; - Ast : in T; - Env : in Envs.Ptr; - Metadata : in T := Nil) return Fn_Ptr - with Inline; - -- Raise an exception if Params contains something else than symbols. - - function Params (Item : in Instance) return Sequence_Ptr - with Inline; - function Ast (Item : in Instance) return T with Inline; - -- Useful to print. - - function Apply (Item : in Instance; - Args : in T_Array) return T with Inline; - -- Duplicated in the step files because of TCO. - - function Env (Item : in Instance) return Envs.Ptr with Inline; - -- Required for TCO, instead of Apply. - - function Meta (Item : in Instance) return T with Inline; - -private - - type Instance is new Garbage_Collected.Instance - with record - F_Ast : T; - F_Env : Envs.Ptr; - F_Meta : T; - F_Params : Sequence_Ptr; - end record; - overriding procedure Keep_References (Object : in out Instance) with Inline; - -end Types.Fns; +with Envs; +with Garbage_Collected; + +package Types.Fns is + + Eval_Cb : access function (Ast : in T; + Env : in Envs.Ptr) return T; + -- The main program must register this global callback to the main + -- eval function before Apply is called. + + type Instance (<>) is abstract new Garbage_Collected.Instance with private; + + function New_Function (Params : in Sequence_Ptr; + Ast : in T; + Env : in Envs.Ptr; + Metadata : in T := Nil) return Fn_Ptr + with Inline; + -- Raise an exception if Params contains something else than symbols. + + function Params (Item : in Instance) return Sequence_Ptr + with Inline; + function Ast (Item : in Instance) return T with Inline; + -- Useful to print. + + function Apply (Item : in Instance; + Args : in T_Array) return T with Inline; + -- Duplicated in the step files because of TCO. + + function Env (Item : in Instance) return Envs.Ptr with Inline; + -- Required for TCO, instead of Apply. + + function Meta (Item : in Instance) return T with Inline; + +private + + type Instance is new Garbage_Collected.Instance + with record + F_Ast : T; + F_Env : Envs.Ptr; + F_Meta : T; + F_Params : Sequence_Ptr; + end record; + overriding procedure Keep_References (Object : in out Instance) with Inline; + +end Types.Fns; diff --git a/impls/ada.2/types-maps.adb b/impls/ada.2/types-maps.adb index 1b9f939877..98445078cc 100644 --- a/impls/ada.2/types-maps.adb +++ b/impls/ada.2/types-maps.adb @@ -1,200 +1,200 @@ -with Err; -with Types.Sequences; -with Types.Strings; - -package body Types.Maps is - - use type HM.Map; - - function Assoc (Initial : in HM.Map; - Bind : in T_Array) return T; - - function Constructor return Map_Ptr with Inline; - - ---------------------------------------------------------------------- - - function "=" (Left, Right : in Instance) return Boolean - is (Left.Data = Right.Data); - - function Assoc (Initial : in HM.Map; - Bind : in T_Array) return T - is - begin - Err.Check (Bind'Length mod 2 = 0, "expected an even bind count"); - declare - Len : constant Natural := Bind'Length / 2; - Ref : constant Map_Ptr := Constructor; - begin - Ref.all.Data := Initial; - for I in 0 .. Len - 1 loop - Ref.all.Data.Include (Bind (Bind'First + 2 * I), - Bind (Bind'First + 2 * I + 1)); - end loop; - return (Kind_Map, Ref); - end; - end Assoc; - - function Assoc (Args : in T_Array) return T is - begin - Err.Check (0 < Args'Length and then Args (Args'First).Kind = Kind_Map, - "first parameter must be a map"); - return Assoc (Args (Args'First).Map.all.Data, - Args (Args'First + 1 .. Args'Last)); - end Assoc; - - function Constructor return Map_Ptr is - Ref : constant Map_Ptr := new Instance; - begin - Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); - return Ref; - end Constructor; - - function Contains (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 2 and then Args (Args'First).Kind = Kind_Map, - "expected a map then a key"); - return (Kind_Boolean, - Args (Args'First).Map.all.Data.Contains (Args (Args'Last))); - end Contains; - - function Dissoc (Args : in T_Array) return T is - begin - Err.Check (0 < Args'Length and then Args (Args'First).Kind = Kind_Map, - "expected a map then keys"); - declare - Ref : constant Map_Ptr := Constructor; - begin - Ref.all.Data := Args (Args'First).Map.all.Data; - for I in Args'First + 1 .. Args'Last loop - Ref.all.Data.Exclude (Args (I)); - -- This call checks the kind of the key. - end loop; - return (Kind_Map, Ref); - end; - end Dissoc; - - function Element (Position : in Cursor) return T - is (HM.Element (HM.Cursor (Position))); - - function First (Container : in Instance) return Cursor - is (Cursor (Container.Data.First)); - - function Get (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 2, "expected 2 parameters"); - case Args (Args'First).Kind is - when Kind_Nil => - Err.Check (Args (Args'Last).Kind in Kind_Key, - "key must be a keyword or string"); - return Nil; - when Kind_Map => - declare - Position : constant HM.Cursor - := Args (Args'First).Map.all.Data.Find (Args (Args'Last)); - begin - if HM.Has_Element (Position) then - return HM.Element (Position); - else - return Nil; - end if; - end; - when others => - Err.Raise_With ("parameter 1 must be nil or a map"); - end case; - end Get; - - function Has_Element (Position : in Cursor) return Boolean - is (HM.Has_Element (HM.Cursor (Position))); - - function Hash (Item : in T) return Ada.Containers.Hash_Type is - begin - Err.Check (Item.Kind in Kind_Key, "keys must be keywords or strings"); - return Strings.Hash (Item.Str); - end Hash; - - function Hash_Map (Args : in T_Array) return T - is (Assoc (HM.Empty_Map, Args)); - - procedure Keep_References (Object : in out Instance) is - begin - for Position in Object.Data.Iterate loop - Keep (HM.Key (Position)); - Keep (HM.Element (Position)); - end loop; - Keep (Object.F_Meta); - end Keep_References; - - function Key (Position : in Cursor) return T - is (HM.Key (HM.Cursor (Position))); - - function Keys (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Map, - "expected a map"); - declare - A1 : HM.Map renames Args (Args'First).Map.all.Data; - Ref : constant Sequence_Ptr - := Sequences.Constructor (Natural (A1.Length)); - I : Positive := 1; - begin - for Position in A1.Iterate loop - Ref.all.Data (I) := HM.Key (Position); - I := I + 1; - end loop; - return (Kind_List, Ref); - end; - end Keys; - - function Meta (Container : in Instance) return T - is (Container.F_Meta); - - procedure Next (Position : in out Cursor) is - begin - HM.Next (HM.Cursor (Position)); - end Next; - - function New_Map (Source : in Instance) return T - is - Ref : constant Map_Ptr := Constructor; - begin - Ref.all.Data := Source.Data; - return (Kind_Map, Ref); - end New_Map; - - procedure Replace_Element (Container : in out Instance; - Position : in Cursor; - New_Item : in T) - is - begin - Container.Data.Replace_Element (HM.Cursor (Position), New_Item); - end Replace_Element; - - function Vals (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Map, - "expected a map"); - declare - A1 : HM.Map renames Args (Args'First).Map.all.Data; - R : constant Sequence_Ptr - := Sequences.Constructor (Natural (A1.Length)); - I : Positive := 1; - begin - for Element of A1 loop - R.all.Data (I) := Element; - I := I + 1; - end loop; - return (Kind_List, R); - end; - end Vals; - - function With_Meta (Container : in Instance; - Metadata : in T) return T - is - Ref : constant Map_Ptr := Constructor; - begin - Ref.all.Data := Container.Data; - Ref.all.F_Meta := Metadata; - return (Kind_Map, Ref); - end With_Meta; - -end Types.Maps; +with Err; +with Types.Sequences; +with Types.Strings; + +package body Types.Maps is + + use type HM.Map; + + function Assoc (Initial : in HM.Map; + Bind : in T_Array) return T; + + function Constructor return Map_Ptr with Inline; + + ---------------------------------------------------------------------- + + function "=" (Left, Right : in Instance) return Boolean + is (Left.Data = Right.Data); + + function Assoc (Initial : in HM.Map; + Bind : in T_Array) return T + is + begin + Err.Check (Bind'Length mod 2 = 0, "expected an even bind count"); + declare + Len : constant Natural := Bind'Length / 2; + Ref : constant Map_Ptr := Constructor; + begin + Ref.all.Data := Initial; + for I in 0 .. Len - 1 loop + Ref.all.Data.Include (Bind (Bind'First + 2 * I), + Bind (Bind'First + 2 * I + 1)); + end loop; + return (Kind_Map, Ref); + end; + end Assoc; + + function Assoc (Args : in T_Array) return T is + begin + Err.Check (0 < Args'Length and then Args (Args'First).Kind = Kind_Map, + "first parameter must be a map"); + return Assoc (Args (Args'First).Map.all.Data, + Args (Args'First + 1 .. Args'Last)); + end Assoc; + + function Constructor return Map_Ptr is + Ref : constant Map_Ptr := new Instance; + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + return Ref; + end Constructor; + + function Contains (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 2 and then Args (Args'First).Kind = Kind_Map, + "expected a map then a key"); + return (Kind_Boolean, + Args (Args'First).Map.all.Data.Contains (Args (Args'Last))); + end Contains; + + function Dissoc (Args : in T_Array) return T is + begin + Err.Check (0 < Args'Length and then Args (Args'First).Kind = Kind_Map, + "expected a map then keys"); + declare + Ref : constant Map_Ptr := Constructor; + begin + Ref.all.Data := Args (Args'First).Map.all.Data; + for I in Args'First + 1 .. Args'Last loop + Ref.all.Data.Exclude (Args (I)); + -- This call checks the kind of the key. + end loop; + return (Kind_Map, Ref); + end; + end Dissoc; + + function Element (Position : in Cursor) return T + is (HM.Element (HM.Cursor (Position))); + + function First (Container : in Instance) return Cursor + is (Cursor (Container.Data.First)); + + function Get (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 2, "expected 2 parameters"); + case Args (Args'First).Kind is + when Kind_Nil => + Err.Check (Args (Args'Last).Kind in Kind_Key, + "key must be a keyword or string"); + return Nil; + when Kind_Map => + declare + Position : constant HM.Cursor + := Args (Args'First).Map.all.Data.Find (Args (Args'Last)); + begin + if HM.Has_Element (Position) then + return HM.Element (Position); + else + return Nil; + end if; + end; + when others => + Err.Raise_With ("parameter 1 must be nil or a map"); + end case; + end Get; + + function Has_Element (Position : in Cursor) return Boolean + is (HM.Has_Element (HM.Cursor (Position))); + + function Hash (Item : in T) return Ada.Containers.Hash_Type is + begin + Err.Check (Item.Kind in Kind_Key, "keys must be keywords or strings"); + return Strings.Hash (Item.Str); + end Hash; + + function Hash_Map (Args : in T_Array) return T + is (Assoc (HM.Empty_Map, Args)); + + procedure Keep_References (Object : in out Instance) is + begin + for Position in Object.Data.Iterate loop + Keep (HM.Key (Position)); + Keep (HM.Element (Position)); + end loop; + Keep (Object.F_Meta); + end Keep_References; + + function Key (Position : in Cursor) return T + is (HM.Key (HM.Cursor (Position))); + + function Keys (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Map, + "expected a map"); + declare + A1 : HM.Map renames Args (Args'First).Map.all.Data; + Ref : constant Sequence_Ptr + := Sequences.Constructor (Natural (A1.Length)); + I : Positive := 1; + begin + for Position in A1.Iterate loop + Ref.all.Data (I) := HM.Key (Position); + I := I + 1; + end loop; + return (Kind_List, Ref); + end; + end Keys; + + function Meta (Container : in Instance) return T + is (Container.F_Meta); + + procedure Next (Position : in out Cursor) is + begin + HM.Next (HM.Cursor (Position)); + end Next; + + function New_Map (Source : in Instance) return T + is + Ref : constant Map_Ptr := Constructor; + begin + Ref.all.Data := Source.Data; + return (Kind_Map, Ref); + end New_Map; + + procedure Replace_Element (Container : in out Instance; + Position : in Cursor; + New_Item : in T) + is + begin + Container.Data.Replace_Element (HM.Cursor (Position), New_Item); + end Replace_Element; + + function Vals (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Map, + "expected a map"); + declare + A1 : HM.Map renames Args (Args'First).Map.all.Data; + R : constant Sequence_Ptr + := Sequences.Constructor (Natural (A1.Length)); + I : Positive := 1; + begin + for Element of A1 loop + R.all.Data (I) := Element; + I := I + 1; + end loop; + return (Kind_List, R); + end; + end Vals; + + function With_Meta (Container : in Instance; + Metadata : in T) return T + is + Ref : constant Map_Ptr := Constructor; + begin + Ref.all.Data := Container.Data; + Ref.all.F_Meta := Metadata; + return (Kind_Map, Ref); + end With_Meta; + +end Types.Maps; diff --git a/impls/ada.2/types-maps.ads b/impls/ada.2/types-maps.ads index 09f481c293..674323ffba 100644 --- a/impls/ada.2/types-maps.ads +++ b/impls/ada.2/types-maps.ads @@ -1,62 +1,62 @@ -private with Ada.Containers.Hashed_Maps; - -with Garbage_Collected; - -package Types.Maps is - - -- All function receiving a key check that its kind is keyword or - -- string. - - type Instance (<>) is abstract new Garbage_Collected.Instance with private; - - -- Built-in functions. - function Assoc (Args : in T_Array) return T; - function Contains (Args : in T_Array) return T; - function Dissoc (Args : in T_Array) return T; - function Get (Args : in T_Array) return T; - function Hash_Map (Args : in T_Array) return T; - function Keys (Args : in T_Array) return T; - function Vals (Args : in T_Array) return T; - - function "=" (Left, Right : in Instance) return Boolean with Inline; - - -- Used to print each element of a map. - type Cursor (<>) is limited private; - function Has_Element (Position : in Cursor) return Boolean with Inline; - function Key (Position : in Cursor) return T with Inline; - function Element (Position : in Cursor) return T with Inline; - function First (Container : in Instance) return Cursor with Inline; - procedure Next (Position : in out Cursor) with Inline; - - -- Used to evaluate each element of a map. - function New_Map (Source : in Instance) return T with Inline; - procedure Replace_Element (Container : in out Instance; - Position : in Cursor; - New_Item : in T) with Inline; - - function Meta (Container : in Instance) return T with Inline; - function With_Meta (Container : in Instance; - Metadata : in T) return T with Inline; - -private - - function Hash (Item : in T) return Ada.Containers.Hash_Type with Inline; - -- This function also checks the kind of the key, and raise an - -- error in case of problem. - - package HM is new Ada.Containers.Hashed_Maps (Key_Type => T, - Element_Type => T, - Hash => Hash, - Equivalent_Keys => "=", - "=" => "="); - - type Instance is new Garbage_Collected.Instance with record - Data : HM.Map; - F_Meta : T; - end record; - - overriding procedure Keep_References (Object : in out Instance) with Inline; - - type Cursor is new HM.Cursor; - -end Types.Maps; +private with Ada.Containers.Hashed_Maps; + +with Garbage_Collected; + +package Types.Maps is + + -- All function receiving a key check that its kind is keyword or + -- string. + + type Instance (<>) is abstract new Garbage_Collected.Instance with private; + + -- Built-in functions. + function Assoc (Args : in T_Array) return T; + function Contains (Args : in T_Array) return T; + function Dissoc (Args : in T_Array) return T; + function Get (Args : in T_Array) return T; + function Hash_Map (Args : in T_Array) return T; + function Keys (Args : in T_Array) return T; + function Vals (Args : in T_Array) return T; + + function "=" (Left, Right : in Instance) return Boolean with Inline; + + -- Used to print each element of a map. + type Cursor (<>) is limited private; + function Has_Element (Position : in Cursor) return Boolean with Inline; + function Key (Position : in Cursor) return T with Inline; + function Element (Position : in Cursor) return T with Inline; + function First (Container : in Instance) return Cursor with Inline; + procedure Next (Position : in out Cursor) with Inline; + + -- Used to evaluate each element of a map. + function New_Map (Source : in Instance) return T with Inline; + procedure Replace_Element (Container : in out Instance; + Position : in Cursor; + New_Item : in T) with Inline; + + function Meta (Container : in Instance) return T with Inline; + function With_Meta (Container : in Instance; + Metadata : in T) return T with Inline; + +private + + function Hash (Item : in T) return Ada.Containers.Hash_Type with Inline; + -- This function also checks the kind of the key, and raise an + -- error in case of problem. + + package HM is new Ada.Containers.Hashed_Maps (Key_Type => T, + Element_Type => T, + Hash => Hash, + Equivalent_Keys => "=", + "=" => "="); + + type Instance is new Garbage_Collected.Instance with record + Data : HM.Map; + F_Meta : T; + end record; + + overriding procedure Keep_References (Object : in out Instance) with Inline; + + type Cursor is new HM.Cursor; + +end Types.Maps; diff --git a/impls/ada.2/types-sequences.adb b/impls/ada.2/types-sequences.adb index c2604658a7..69c1f15855 100644 --- a/impls/ada.2/types-sequences.adb +++ b/impls/ada.2/types-sequences.adb @@ -1,227 +1,227 @@ -with Err; -with Types.Fns; -with Types.Builtins; - -package body Types.Sequences is - - function "=" (Left, Right : in Instance) return Boolean is - -- Should become Left.all.Data = Right.all.Data when - -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed. - begin - return Left.Length = Right.Length - and then - (for all I in 1 .. Left.Data'Length => Left.Data (I) = Right.Data (I)); - end "="; - - function Concat (Args : in T_Array) return T is - Sum : Natural := 0; - First : Positive := 1; - Last : Natural; - begin - Err.Check ((for all A of Args => A.Kind in Kind_Sequence), - "expected sequences"); - for Arg of Args loop - Sum := Sum + Arg.Sequence.all.Data'Length; - end loop; - declare - Ref : constant Sequence_Ptr := Constructor (Sum); - begin - for Arg of Args loop - Last := First - 1 + Arg.Sequence.all.Data'Last; - Ref.all.Data (First .. Last) := Arg.Sequence.all.Data; - First := Last + 1; - end loop; - return (Kind_List, Ref); - end; - end Concat; - - function Conj (Args : in T_Array) return T is - begin - Err.Check (0 < Args'Length, "expected at least 1 parameter"); - case Args (Args'First).Kind is - when Kind_Sequence => - declare - Data : T_Array renames Args (Args'First).Sequence.all.Data; - Last : constant Natural := Args'Length - 1 + Data'Length; - -- Avoid exceptions until Ref is controlled. - Ref : constant Sequence_Ptr := Constructor (Last); - begin - if Args (Args'First).Kind = Kind_List then - for I in 1 .. Args'Length - 1 loop - Ref.all.Data (I) := Args (Args'Last - I + 1); - end loop; - Ref.all.Data (Args'Length .. Last) := Data; - return (Kind_List, Ref); - else - Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last); - return (Kind_Vector, Ref); - end if; - end; - when others => - Err.Raise_With ("parameter 1 must be a sequence"); - end case; - end Conj; - - function Cons (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 2 - and then Args (Args'Last).Kind in Kind_Sequence, - "expected a value then a sequence"); - declare - Head : T renames Args (Args'First); - Tail : T_Array renames Args (Args'Last).Sequence.all.Data; - Ref : constant Sequence_Ptr := Constructor (1 + Tail'Length); - begin - Ref.all.Data := Head & Tail; - return (Kind_List, Ref); - end; - end Cons; - - function Constructor (Length : in Natural) return Sequence_Ptr is - Ref : constant Sequence_Ptr := new Instance (Length); - begin - Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); - return Ref; - end Constructor; - - function Count (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - case Args (Args'First).Kind is - when Kind_Nil => - return (Kind_Number, 0); - when Kind_Sequence => - return (Kind_Number, Args (Args'First).Sequence.all.Data'Length); - when others => - Err.Raise_With ("parameter must be nil or a sequence"); - end case; - end Count; - - function First (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - case Args (Args'First).Kind is - when Kind_Nil => - return Nil; - when Kind_Sequence => - declare - Data : T_Array renames Args (Args'First).Sequence.all.Data; - begin - if Data'Length = 0 then - return Nil; - else - return Data (Data'First); - end if; - end; - when others => - Err.Raise_With ("parameter must be nil or a sequence"); - end case; - end First; - - function Is_Empty (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 1 - and then Args (Args'First).Kind in Kind_Sequence, - "expected a sequence"); - return (Kind_Boolean, Args (Args'First).Sequence.all.Data'Length = 0); - end Is_Empty; - - procedure Keep_References (Object : in out Instance) is - begin - Keep (Object.Meta); - for M of Object.Data loop - Keep (M); - end loop; - end Keep_References; - - function List (Args : in T_Array) return T - is - Ref : constant Sequence_Ptr := Constructor (Args'Length); - begin - Ref.all.Data := Args; - return (Kind_List, Ref); - end List; - - function Map (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 2 - and then Args (Args'Last).Kind in Kind_Sequence, - "expected a function then a sequence"); - declare - F : T renames Args (Args'First); - Src : T_Array renames Args (Args'Last).Sequence.all.Data; - Ref : constant Sequence_Ptr := Constructor (Src'Length); - begin - case F.Kind is - when Kind_Builtin => - for I in Src'Range loop - Ref.all.Data (I) := F.Builtin.all (Src (I .. I)); - end loop; - when Kind_Builtin_With_Meta => - for I in Src'Range loop - Ref.all.Data (I) - := F.Builtin_With_Meta.all.Builtin.all (Src (I .. I)); - end loop; - when Kind_Fn => - for I in Src'Range loop - Ref.all.Data (I) := F.Fn.all.Apply (Src (I .. I)); - end loop; - when others => - Err.Raise_With ("parameter 1 must be a function"); - end case; - return (Kind_List, Ref); - end; - end Map; - - function Nth (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 2 - and then Args (Args'First).Kind in Kind_Sequence - and then Args (Args'Last).Kind = Kind_Number, - "expected a sequence then a number"); - declare - L : T_Array renames Args (Args'First).Sequence.all.Data; - I : constant Integer := Args (Args'Last).Number + 1; - begin - Err.Check (I in L'Range, "index out of bounds"); - return L (I); - end; - end Nth; - - function Rest (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - case Args (Args'First).Kind is - when Kind_Nil => - return (Kind_List, Constructor (0)); - when Kind_Sequence => - declare - A1 : T_Array renames Args (Args'First).Sequence.all.Data; - Ref : constant Sequence_Ptr - := Constructor (Integer'Max (0, A1'Length - 1)); - begin - Ref.all.Data := A1 (A1'First + 1 .. A1'Last); - return (Kind_List, Ref); - end; - when others => - Err.Raise_With ("parameter must be nil or a sequence"); - end case; - end Rest; - - function Vec (Args : in T_Array) return T is - begin - Err.Check (Args'Length = 1 - and then Args (Args'First).Kind in Kind_Sequence, - "expects a sequence"); - return (Kind_Vector, Args (Args'First).Sequence); - end Vec; - - function Vector (Args : in T_Array) return T - is - Ref : constant Sequence_Ptr := Constructor (Args'Length); - begin - Ref.all.Data := Args; - return (Kind_Vector, Ref); - end Vector; - -end Types.Sequences; +with Err; +with Types.Fns; +with Types.Builtins; + +package body Types.Sequences is + + function "=" (Left, Right : in Instance) return Boolean is + -- Should become Left.all.Data = Right.all.Data when + -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed. + begin + return Left.Length = Right.Length + and then + (for all I in 1 .. Left.Data'Length => Left.Data (I) = Right.Data (I)); + end "="; + + function Concat (Args : in T_Array) return T is + Sum : Natural := 0; + First : Positive := 1; + Last : Natural; + begin + Err.Check ((for all A of Args => A.Kind in Kind_Sequence), + "expected sequences"); + for Arg of Args loop + Sum := Sum + Arg.Sequence.all.Data'Length; + end loop; + declare + Ref : constant Sequence_Ptr := Constructor (Sum); + begin + for Arg of Args loop + Last := First - 1 + Arg.Sequence.all.Data'Last; + Ref.all.Data (First .. Last) := Arg.Sequence.all.Data; + First := Last + 1; + end loop; + return (Kind_List, Ref); + end; + end Concat; + + function Conj (Args : in T_Array) return T is + begin + Err.Check (0 < Args'Length, "expected at least 1 parameter"); + case Args (Args'First).Kind is + when Kind_Sequence => + declare + Data : T_Array renames Args (Args'First).Sequence.all.Data; + Last : constant Natural := Args'Length - 1 + Data'Length; + -- Avoid exceptions until Ref is controlled. + Ref : constant Sequence_Ptr := Constructor (Last); + begin + if Args (Args'First).Kind = Kind_List then + for I in 1 .. Args'Length - 1 loop + Ref.all.Data (I) := Args (Args'Last - I + 1); + end loop; + Ref.all.Data (Args'Length .. Last) := Data; + return (Kind_List, Ref); + else + Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last); + return (Kind_Vector, Ref); + end if; + end; + when others => + Err.Raise_With ("parameter 1 must be a sequence"); + end case; + end Conj; + + function Cons (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 2 + and then Args (Args'Last).Kind in Kind_Sequence, + "expected a value then a sequence"); + declare + Head : T renames Args (Args'First); + Tail : T_Array renames Args (Args'Last).Sequence.all.Data; + Ref : constant Sequence_Ptr := Constructor (1 + Tail'Length); + begin + Ref.all.Data := Head & Tail; + return (Kind_List, Ref); + end; + end Cons; + + function Constructor (Length : in Natural) return Sequence_Ptr is + Ref : constant Sequence_Ptr := new Instance (Length); + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + return Ref; + end Constructor; + + function Count (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + case Args (Args'First).Kind is + when Kind_Nil => + return (Kind_Number, 0); + when Kind_Sequence => + return (Kind_Number, Args (Args'First).Sequence.all.Data'Length); + when others => + Err.Raise_With ("parameter must be nil or a sequence"); + end case; + end Count; + + function First (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + case Args (Args'First).Kind is + when Kind_Nil => + return Nil; + when Kind_Sequence => + declare + Data : T_Array renames Args (Args'First).Sequence.all.Data; + begin + if Data'Length = 0 then + return Nil; + else + return Data (Data'First); + end if; + end; + when others => + Err.Raise_With ("parameter must be nil or a sequence"); + end case; + end First; + + function Is_Empty (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 1 + and then Args (Args'First).Kind in Kind_Sequence, + "expected a sequence"); + return (Kind_Boolean, Args (Args'First).Sequence.all.Data'Length = 0); + end Is_Empty; + + procedure Keep_References (Object : in out Instance) is + begin + Keep (Object.Meta); + for M of Object.Data loop + Keep (M); + end loop; + end Keep_References; + + function List (Args : in T_Array) return T + is + Ref : constant Sequence_Ptr := Constructor (Args'Length); + begin + Ref.all.Data := Args; + return (Kind_List, Ref); + end List; + + function Map (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 2 + and then Args (Args'Last).Kind in Kind_Sequence, + "expected a function then a sequence"); + declare + F : T renames Args (Args'First); + Src : T_Array renames Args (Args'Last).Sequence.all.Data; + Ref : constant Sequence_Ptr := Constructor (Src'Length); + begin + case F.Kind is + when Kind_Builtin => + for I in Src'Range loop + Ref.all.Data (I) := F.Builtin.all (Src (I .. I)); + end loop; + when Kind_Builtin_With_Meta => + for I in Src'Range loop + Ref.all.Data (I) + := F.Builtin_With_Meta.all.Builtin.all (Src (I .. I)); + end loop; + when Kind_Fn => + for I in Src'Range loop + Ref.all.Data (I) := F.Fn.all.Apply (Src (I .. I)); + end loop; + when others => + Err.Raise_With ("parameter 1 must be a function"); + end case; + return (Kind_List, Ref); + end; + end Map; + + function Nth (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 2 + and then Args (Args'First).Kind in Kind_Sequence + and then Args (Args'Last).Kind = Kind_Number, + "expected a sequence then a number"); + declare + L : T_Array renames Args (Args'First).Sequence.all.Data; + I : constant Integer := Args (Args'Last).Number + 1; + begin + Err.Check (I in L'Range, "index out of bounds"); + return L (I); + end; + end Nth; + + function Rest (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + case Args (Args'First).Kind is + when Kind_Nil => + return (Kind_List, Constructor (0)); + when Kind_Sequence => + declare + A1 : T_Array renames Args (Args'First).Sequence.all.Data; + Ref : constant Sequence_Ptr + := Constructor (Integer'Max (0, A1'Length - 1)); + begin + Ref.all.Data := A1 (A1'First + 1 .. A1'Last); + return (Kind_List, Ref); + end; + when others => + Err.Raise_With ("parameter must be nil or a sequence"); + end case; + end Rest; + + function Vec (Args : in T_Array) return T is + begin + Err.Check (Args'Length = 1 + and then Args (Args'First).Kind in Kind_Sequence, + "expects a sequence"); + return (Kind_Vector, Args (Args'First).Sequence); + end Vec; + + function Vector (Args : in T_Array) return T + is + Ref : constant Sequence_Ptr := Constructor (Args'Length); + begin + Ref.all.Data := Args; + return (Kind_Vector, Ref); + end Vector; + +end Types.Sequences; diff --git a/impls/ada.2/types-sequences.ads b/impls/ada.2/types-sequences.ads index f45bdbdec6..559419f40b 100644 --- a/impls/ada.2/types-sequences.ads +++ b/impls/ada.2/types-sequences.ads @@ -1,40 +1,40 @@ -with Garbage_Collected; - -package Types.Sequences is - - -- Hiding the implementation would either cause a significative - -- performance hit (the compiler performs better optimization with - -- explicit arrays) or a convoluted interface (demonstrated for - -- strings and maps, where the balance is different). - - type Instance (Length : Natural) is new Garbage_Collected.Instance with - record - Meta : T; - Data : T_Array (1 .. Length); - end record; - - -- Built-in functions. - function Concat (Args : in T_Array) return T; - function Conj (Args : in T_Array) return T; - function Cons (Args : in T_Array) return T; - function Count (Args : in T_Array) return T; - function First (Args : in T_Array) return T; - function Is_Empty (Args : in T_Array) return T; - function List (Args : in T_Array) return T; - function Map (Args : in T_Array) return T; - function Nth (Args : in T_Array) return T; - function Rest (Args : in T_Array) return T; - function Vec (Args : in T_Array) return T; - function Vector (Args : in T_Array) return T; - - -- New instances must be created via this constructor. - function Constructor (Length : in Natural) return Sequence_Ptr with Inline; - - -- Helper for Types."=". - function "=" (Left, Right : in Instance) return Boolean; - -private - - overriding procedure Keep_References (Object : in out Instance) with Inline; - -end Types.Sequences; +with Garbage_Collected; + +package Types.Sequences is + + -- Hiding the implementation would either cause a significative + -- performance hit (the compiler performs better optimization with + -- explicit arrays) or a convoluted interface (demonstrated for + -- strings and maps, where the balance is different). + + type Instance (Length : Natural) is new Garbage_Collected.Instance with + record + Meta : T; + Data : T_Array (1 .. Length); + end record; + + -- Built-in functions. + function Concat (Args : in T_Array) return T; + function Conj (Args : in T_Array) return T; + function Cons (Args : in T_Array) return T; + function Count (Args : in T_Array) return T; + function First (Args : in T_Array) return T; + function Is_Empty (Args : in T_Array) return T; + function List (Args : in T_Array) return T; + function Map (Args : in T_Array) return T; + function Nth (Args : in T_Array) return T; + function Rest (Args : in T_Array) return T; + function Vec (Args : in T_Array) return T; + function Vector (Args : in T_Array) return T; + + -- New instances must be created via this constructor. + function Constructor (Length : in Natural) return Sequence_Ptr with Inline; + + -- Helper for Types."=". + function "=" (Left, Right : in Instance) return Boolean; + +private + + overriding procedure Keep_References (Object : in out Instance) with Inline; + +end Types.Sequences; diff --git a/impls/ada.2/types-strings.adb b/impls/ada.2/types-strings.adb index a51f01fdbe..cc7582fffa 100644 --- a/impls/ada.2/types-strings.adb +++ b/impls/ada.2/types-strings.adb @@ -1,34 +1,34 @@ -with Ada.Strings.Hash; - -package body Types.Strings is - - function "=" (Left : in Instance; - Right : in String) return Boolean - is (Left.Data = Right); - - function Alloc (Data : in String) return String_Ptr is - Ref : constant String_Ptr := new Instance (Data'Length); - begin - Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); - Ref.all.Data := Data; - return Ref; - end Alloc; - - function Hash (Item : in String_Ptr) return Ada.Containers.Hash_Type - is (Ada.Strings.Hash (Item.all.Data)); - - procedure Query_Element - (Container : in Instance; - Process : not null access procedure (Element : in String)) - is - begin - Process.all (Container.Data); - end Query_Element; - - function Same_Contents (Left, Right : in String_Ptr) return Boolean - is (Left = Right or else Left.all.Data = Right.all.Data); - - function To_String (Container : in Instance) return String - is (Container.Data); - -end Types.Strings; +with Ada.Strings.Hash; + +package body Types.Strings is + + function "=" (Left : in Instance; + Right : in String) return Boolean + is (Left.Data = Right); + + function Alloc (Data : in String) return String_Ptr is + Ref : constant String_Ptr := new Instance (Data'Length); + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + Ref.all.Data := Data; + return Ref; + end Alloc; + + function Hash (Item : in String_Ptr) return Ada.Containers.Hash_Type + is (Ada.Strings.Hash (Item.all.Data)); + + procedure Query_Element + (Container : in Instance; + Process : not null access procedure (Element : in String)) + is + begin + Process.all (Container.Data); + end Query_Element; + + function Same_Contents (Left, Right : in String_Ptr) return Boolean + is (Left = Right or else Left.all.Data = Right.all.Data); + + function To_String (Container : in Instance) return String + is (Container.Data); + +end Types.Strings; diff --git a/impls/ada.2/types-strings.ads b/impls/ada.2/types-strings.ads index 58bd0c6377..08f8646642 100644 --- a/impls/ada.2/types-strings.ads +++ b/impls/ada.2/types-strings.ads @@ -1,49 +1,49 @@ -with Ada.Containers; - -with Garbage_Collected; - -package Types.Strings is - - ------------------------------------ - -- Keywords, Strings and Symbols -- - ------------------------------------ - - -- Tests seem to show that manual garbage collection is faster - -- than reference counting in Ada.Strings.Unbounded, probably - -- because we know that the values will never change. - - -- Also, maintaining a global structure in order to avoid similar - -- symbol allocations does not seem to improve performances. - - type Instance (<>) is abstract new Garbage_Collected.Instance with private; - - function Alloc (Data : in String) return String_Ptr - with Inline; - - function "=" (Left : in Instance; - Right : in String) return Boolean - with Inline; - - -- This kind of accessor is more efficient than a function - -- returning an array. - procedure Query_Element - (Container : in Instance; - Process : not null access procedure (Element : in String)); - - -- These methods could be implemented with Query_Element, - -- but we want to optimize Envs.Get. - function Hash (Item : in String_Ptr) return Ada.Containers.Hash_Type - with Inline; - function Same_Contents (Left, Right : in String_Ptr) return Boolean - with Inline; - - -- When readability is more important than copying a string. - function To_String (Container : in Instance) return String with Inline; - -private - - type Instance (Last : Natural) is new Garbage_Collected.Instance with record - Data : String (1 .. Last); - end record; - -end Types.Strings; +with Ada.Containers; + +with Garbage_Collected; + +package Types.Strings is + + ------------------------------------ + -- Keywords, Strings and Symbols -- + ------------------------------------ + + -- Tests seem to show that manual garbage collection is faster + -- than reference counting in Ada.Strings.Unbounded, probably + -- because we know that the values will never change. + + -- Also, maintaining a global structure in order to avoid similar + -- symbol allocations does not seem to improve performances. + + type Instance (<>) is abstract new Garbage_Collected.Instance with private; + + function Alloc (Data : in String) return String_Ptr + with Inline; + + function "=" (Left : in Instance; + Right : in String) return Boolean + with Inline; + + -- This kind of accessor is more efficient than a function + -- returning an array. + procedure Query_Element + (Container : in Instance; + Process : not null access procedure (Element : in String)); + + -- These methods could be implemented with Query_Element, + -- but we want to optimize Envs.Get. + function Hash (Item : in String_Ptr) return Ada.Containers.Hash_Type + with Inline; + function Same_Contents (Left, Right : in String_Ptr) return Boolean + with Inline; + + -- When readability is more important than copying a string. + function To_String (Container : in Instance) return String with Inline; + +private + + type Instance (Last : Natural) is new Garbage_Collected.Instance with record + Data : String (1 .. Last); + end record; + +end Types.Strings; diff --git a/impls/ada.2/types.adb b/impls/ada.2/types.adb index 6b0ebf0a53..3892dd10a7 100644 --- a/impls/ada.2/types.adb +++ b/impls/ada.2/types.adb @@ -1,58 +1,58 @@ -pragma Warnings (Off, "no entities of ""Types.*"" are referenced"); -with Types.Atoms; -with Types.Builtins; -with Types.Fns; -with Types.Maps; -with Types.Sequences; -pragma Warnings (On, "no entities of ""Types.*"" are referenced"); -with Types.Strings; - -package body Types is - - function "=" (Left, Right : in T) return Boolean - is (case Left.Kind is - when Kind_Nil => - Right.Kind = Kind_Nil, - when Kind_Boolean => - Right.Kind = Kind_Boolean - and then Left.Ada_Boolean = Right.Ada_Boolean, - when Kind_Number => - Right.Kind = Kind_Number and then Left.Number = Right.Number, - -- Here comes the part that differs from the predefined equality. - when Kind_Key | Kind_Symbol => - Right.Kind = Left.Kind - and then Strings.Same_Contents (Left.Str, Right.Str), - when Kind_Sequence => - Right.Kind in Kind_Sequence - and then (Left.Sequence = Right.Sequence - or else Sequences."=" (Left.Sequence.all, Right.Sequence.all)), - when Kind_Map => - Right.Kind = Kind_Map - and then (Left.Map = Right.Map - or else Maps."=" (Left.Map.all, Right.Map.all)), - -- Also, comparing functions is an interesting problem. - when others => - False); - - procedure Keep (Object : in T) is - -- No dynamic dispatching happens here. - begin - case Object.Kind is - when Kind_Nil | Kind_Boolean | Kind_Number | Kind_Builtin => - null; - when Kind_Key | Kind_Symbol => - Object.Str.all.Keep; - when Kind_Atom => - Object.Atom.all.Keep; - when Kind_Sequence => - Object.Sequence.all.Keep; - when Kind_Map => - Object.Map.all.Keep; - when Kind_Builtin_With_Meta => - Object.Builtin_With_Meta.all.Keep; - when Kind_Fn | Kind_Macro => - Object.Fn.all.Keep; - end case; - end Keep; - -end Types; +pragma Warnings (Off, "no entities of ""Types.*"" are referenced"); +with Types.Atoms; +with Types.Builtins; +with Types.Fns; +with Types.Maps; +with Types.Sequences; +pragma Warnings (On, "no entities of ""Types.*"" are referenced"); +with Types.Strings; + +package body Types is + + function "=" (Left, Right : in T) return Boolean + is (case Left.Kind is + when Kind_Nil => + Right.Kind = Kind_Nil, + when Kind_Boolean => + Right.Kind = Kind_Boolean + and then Left.Ada_Boolean = Right.Ada_Boolean, + when Kind_Number => + Right.Kind = Kind_Number and then Left.Number = Right.Number, + -- Here comes the part that differs from the predefined equality. + when Kind_Key | Kind_Symbol => + Right.Kind = Left.Kind + and then Strings.Same_Contents (Left.Str, Right.Str), + when Kind_Sequence => + Right.Kind in Kind_Sequence + and then (Left.Sequence = Right.Sequence + or else Sequences."=" (Left.Sequence.all, Right.Sequence.all)), + when Kind_Map => + Right.Kind = Kind_Map + and then (Left.Map = Right.Map + or else Maps."=" (Left.Map.all, Right.Map.all)), + -- Also, comparing functions is an interesting problem. + when others => + False); + + procedure Keep (Object : in T) is + -- No dynamic dispatching happens here. + begin + case Object.Kind is + when Kind_Nil | Kind_Boolean | Kind_Number | Kind_Builtin => + null; + when Kind_Key | Kind_Symbol => + Object.Str.all.Keep; + when Kind_Atom => + Object.Atom.all.Keep; + when Kind_Sequence => + Object.Sequence.all.Keep; + when Kind_Map => + Object.Map.all.Keep; + when Kind_Builtin_With_Meta => + Object.Builtin_With_Meta.all.Keep; + when Kind_Fn | Kind_Macro => + Object.Fn.all.Keep; + end case; + end Keep; + +end Types; diff --git a/impls/ada.2/types.ads b/impls/ada.2/types.ads index 011288b6cd..a742daf7c8 100644 --- a/impls/ada.2/types.ads +++ b/impls/ada.2/types.ads @@ -1,90 +1,90 @@ -limited with Types.Atoms; -limited with Types.Builtins; -limited with Types.Fns; -limited with Types.Maps; -limited with Types.Sequences; -limited with Types.Strings; - -package Types is - - -- A type with a default value for the discriminant is the Ada - -- equivalent of a C union. It uses a fixed size, and allows - -- efficient arrays. A class hierarchy would make this impossible, - -- for little gain. - -- Native types may seem to consume too much memory, but - -- 1/ they require no allocation/deallocation. - -- 2/ the overhead would actually be higher with an intermediate - -- reference (the size of the pointer plus the size of the native - -- type, while an union uses the minimum of both and a single - -- memory area ). - - -- The idea is inspired from the Haskell and OCaml interpreters, - -- which use a bit to distinguish pointers from integers. Ada - -- allows to specify the bit position of each component, but - -- generating such architecture-dependent definitions seems a lot - -- of work for MAL. - - -- The Ada tradition is to give explicit names to types, but this - -- one will be used very often. - - type Kind_Type is - (Kind_Nil, - Kind_Atom, - Kind_Boolean, - Kind_Number, - Kind_Symbol, - Kind_Keyword, Kind_String, - Kind_List, Kind_Vector, - Kind_Map, - Kind_Macro, Kind_Fn, Kind_Builtin_With_Meta, Kind_Builtin); - - subtype Kind_Key is Kind_Type range Kind_Keyword .. Kind_String; - subtype Kind_Sequence is Kind_Type range Kind_List .. Kind_Vector; - subtype Kind_Function is Kind_Type range Kind_Fn .. Kind_Builtin; - - type T; - type T_Array; - type Atom_Ptr is not null access Atoms.Instance; - type Builtin_Ptr is not null access function (Args : in T_Array) return T; - type Builtin_With_Meta_Ptr is not null access Builtins.Instance; - type Fn_Ptr is not null access Fns.Instance; - type Map_Ptr is not null access Maps.Instance; - type Sequence_Ptr is not null access Sequences.Instance; - type String_Ptr is not null access Strings.Instance; - - type T (Kind : Kind_Type := Kind_Nil) is record - case Kind is - when Kind_Nil => - null; - when Kind_Boolean => - Ada_Boolean : Boolean; - when Kind_Number => - Number : Integer; - when Kind_Atom => - Atom : Atom_Ptr; - when Kind_Key | Kind_Symbol => - Str : String_Ptr; - when Kind_Sequence => - Sequence : Sequence_Ptr; - when Kind_Map => - Map : Map_Ptr; - when Kind_Builtin => - Builtin : Builtin_Ptr; - when Kind_Builtin_With_Meta => - Builtin_With_Meta : Builtin_With_Meta_Ptr; - when Kind_Fn | Kind_Macro => - Fn : Fn_Ptr; - end case; - end record; - - -- Useful for recursive automatic definition of equality for - -- composite types like the array type below. - function "=" (Left, Right : in T) return Boolean with Inline; - - Nil : constant T := (Kind => Kind_Nil); - - procedure Keep (Object : in T) with Inline; - - type T_Array is array (Positive range <>) of T; - -end Types; +limited with Types.Atoms; +limited with Types.Builtins; +limited with Types.Fns; +limited with Types.Maps; +limited with Types.Sequences; +limited with Types.Strings; + +package Types is + + -- A type with a default value for the discriminant is the Ada + -- equivalent of a C union. It uses a fixed size, and allows + -- efficient arrays. A class hierarchy would make this impossible, + -- for little gain. + -- Native types may seem to consume too much memory, but + -- 1/ they require no allocation/deallocation. + -- 2/ the overhead would actually be higher with an intermediate + -- reference (the size of the pointer plus the size of the native + -- type, while an union uses the minimum of both and a single + -- memory area ). + + -- The idea is inspired from the Haskell and OCaml interpreters, + -- which use a bit to distinguish pointers from integers. Ada + -- allows to specify the bit position of each component, but + -- generating such architecture-dependent definitions seems a lot + -- of work for MAL. + + -- The Ada tradition is to give explicit names to types, but this + -- one will be used very often. + + type Kind_Type is + (Kind_Nil, + Kind_Atom, + Kind_Boolean, + Kind_Number, + Kind_Symbol, + Kind_Keyword, Kind_String, + Kind_List, Kind_Vector, + Kind_Map, + Kind_Macro, Kind_Fn, Kind_Builtin_With_Meta, Kind_Builtin); + + subtype Kind_Key is Kind_Type range Kind_Keyword .. Kind_String; + subtype Kind_Sequence is Kind_Type range Kind_List .. Kind_Vector; + subtype Kind_Function is Kind_Type range Kind_Fn .. Kind_Builtin; + + type T; + type T_Array; + type Atom_Ptr is not null access Atoms.Instance; + type Builtin_Ptr is not null access function (Args : in T_Array) return T; + type Builtin_With_Meta_Ptr is not null access Builtins.Instance; + type Fn_Ptr is not null access Fns.Instance; + type Map_Ptr is not null access Maps.Instance; + type Sequence_Ptr is not null access Sequences.Instance; + type String_Ptr is not null access Strings.Instance; + + type T (Kind : Kind_Type := Kind_Nil) is record + case Kind is + when Kind_Nil => + null; + when Kind_Boolean => + Ada_Boolean : Boolean; + when Kind_Number => + Number : Integer; + when Kind_Atom => + Atom : Atom_Ptr; + when Kind_Key | Kind_Symbol => + Str : String_Ptr; + when Kind_Sequence => + Sequence : Sequence_Ptr; + when Kind_Map => + Map : Map_Ptr; + when Kind_Builtin => + Builtin : Builtin_Ptr; + when Kind_Builtin_With_Meta => + Builtin_With_Meta : Builtin_With_Meta_Ptr; + when Kind_Fn | Kind_Macro => + Fn : Fn_Ptr; + end case; + end record; + + -- Useful for recursive automatic definition of equality for + -- composite types like the array type below. + function "=" (Left, Right : in T) return Boolean with Inline; + + Nil : constant T := (Kind => Kind_Nil); + + procedure Keep (Object : in T) with Inline; + + type T_Array is array (Positive range <>) of T; + +end Types; diff --git a/impls/ada/Dockerfile b/impls/ada/Dockerfile index 5eb272abe0..7e167b0cd0 100755 --- a/impls/ada/Dockerfile +++ b/impls/ada/Dockerfile @@ -1,25 +1,25 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# GNU Ada compiler -RUN apt-get -y install gnat-4.9 +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# GNU Ada compiler +RUN apt-get -y install gnat-4.9 diff --git a/impls/ada/Makefile b/impls/ada/Makefile index 99f58b8b46..9a23a14ded 100644 --- a/impls/ada/Makefile +++ b/impls/ada/Makefile @@ -1,23 +1,23 @@ -PROGS=step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ - step5_tco step6_file step7_quote step8_macros step9_try - -all: ${PROGS} stepA_mal - -obj: - mkdir -p $@ - -# stepA_mal is awkward because GNAT requires the filename to be lowercase -${PROGS} stepa_mal: force obj - gnatmake -O3 -gnata $@.adb -D obj - -# so we make stepa_mal and just move it. -stepA_mal: stepa_mal - mv $< $@ - -clean: - rm -f ${PROGS} - rm -rf obj - -.PHONY: force - -force: +PROGS=step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ + step5_tco step6_file step7_quote step8_macros step9_try + +all: ${PROGS} stepA_mal + +obj: + mkdir -p $@ + +# stepA_mal is awkward because GNAT requires the filename to be lowercase +${PROGS} stepa_mal: force obj + gnatmake -O3 -gnata $@.adb -D obj + +# so we make stepa_mal and just move it. +stepA_mal: stepa_mal + mv $< $@ + +clean: + rm -f ${PROGS} + rm -rf obj + +.PHONY: force + +force: diff --git a/impls/ada/core.adb b/impls/ada/core.adb index 0a365834c5..05d10c5ef9 100644 --- a/impls/ada/core.adb +++ b/impls/ada/core.adb @@ -1,1287 +1,1287 @@ -with Ada.Calendar; -with Ada.Characters.Latin_1; -with Ada.Strings.Unbounded; -with Ada.Text_IO; -with Eval_Callback; -with Reader; -with Smart_Pointers; -with Types; -with Types.Hash_Map; -with Types.Vector; - -package body Core is - - use Types; - - -- primitive functions on Smart_Pointer, - function "+" is new Arith_Op ("+", "+"); - function "-" is new Arith_Op ("-", "-"); - function "*" is new Arith_Op ("*", "*"); - function "/" is new Arith_Op ("/", "/"); - - function "<" is new Rel_Op ("<", "<"); - function "<=" is new Rel_Op ("<=", "<="); - function ">" is new Rel_Op (">", ">"); - function ">=" is new Rel_Op (">=", ">="); - - - function Eval_As_Boolean (MH : Types.Mal_Handle) return Boolean is - use Types; - Res : Boolean; - begin - case Deref (MH).Sym_Type is - when Bool => - Res := Deref_Bool (MH).Get_Bool; - when Nil => - Res := False; --- when List => --- declare --- L : List_Mal_Type; --- begin --- L := Deref_List (MH).all; --- Res := not Is_Null (L); --- end; - when others => -- Everything else - Res := True; - end case; - return Res; - end Eval_As_Boolean; - - - function Throw (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - Types.Mal_Exception_Value := First_Param; - raise Mal_Exception; - return First_Param; -- Keep the compiler happy. - end Throw; - - - function Is_True (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return New_Bool_Mal_Type - (Deref (First_Param).Sym_Type = Bool and then - Deref_Bool (First_Param).Get_Bool); - end Is_True; - - - function Is_False (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return New_Bool_Mal_Type - (Deref (First_Param).Sym_Type = Bool and then - not Deref_Bool (First_Param).Get_Bool); - end Is_False; - - - function Is_Nil (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return New_Bool_Mal_Type - (Deref (First_Param).Sym_Type = Nil); - end Is_Nil; - - - function Meta (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return Deref (First_Param).Get_Meta; - end Meta; - - - function With_Meta (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Meta_Param, Res : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - Rest_List := Deref_List (Cdr (Rest_List)).all; - Meta_Param := Car (Rest_List); - Res := Copy (First_Param); - Deref (Res).Set_Meta (Meta_Param); - return Res; - end With_Meta; - - - function New_Atom (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return New_Atom_Mal_Type (First_Param); - end New_Atom; - - function Is_Atom (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Atom); - end Is_Atom; - - - function Deref_Atm (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return Deref_Atom (First_Param).Get_Atom; - end Deref_Atm; - - - function Reset (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Atom_Param, New_Val : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - Atom_Param := Car (Rest_List); - Rest_List := Deref_List (Cdr (Rest_List)).all; - New_Val := Car (Rest_List); - Deref_Atom (Atom_Param).Set_Atom (New_Val); - return New_Val; - end Reset; - - - function Swap (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Atom_Param, Atom_Val, New_Val : Mal_Handle; - Rest_List : Types.List_Mal_Type; - Rest_List_Class : Types.List_Class_Ptr; - Func_Param, Param_List : Mal_Handle; - begin - Rest_List := Deref_List (Rest_Handle).all; - Atom_Param := Car (Rest_List); - Rest_List := Deref_List (Cdr (Rest_List)).all; - Func_Param := Car (Rest_List); - Param_List := Cdr (Rest_List); - - Rest_List_Class := Deref_List_Class (Param_List); - Param_List := Rest_List_Class.Duplicate; - Atom_Val := Deref_Atom (Atom_Param).Get_Atom; - Param_List := Prepend (Atom_Val, Deref_List (Param_List).all); - case Deref (Func_Param).Sym_Type is - when Lambda => - New_Val := Deref_Lambda (Func_Param).Apply (Param_List); - when Func => - New_Val := Deref_Func (Func_Param).Call_Func (Param_List); - when others => raise Runtime_Exception with "Swap with bad func"; - end case; - Deref_Atom (Atom_Param).Set_Atom (New_Val); - return New_Val; - end Swap; - - - function Is_List (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return New_Bool_Mal_Type - (Deref (First_Param).Sym_Type = List and then - Deref_List (First_Param).Get_List_Type = List_List); - end Is_List; - - - function Is_Vector (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return New_Bool_Mal_Type - (Deref (First_Param).Sym_Type = List and then - Deref_List (First_Param).Get_List_Type = Vector_List); - end Is_Vector; - - - function Is_Map (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return New_Bool_Mal_Type - (Deref (First_Param).Sym_Type = List and then - Deref_List (First_Param).Get_List_Type = Hashed_List); - end Is_Map; - - - function Is_Sequential (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return New_Bool_Mal_Type - (Deref (First_Param).Sym_Type = List and then - Deref_List (First_Param).Get_List_Type /= Hashed_List); - end Is_Sequential; - - - function Is_Empty (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - List : List_Class_Ptr; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - List := Deref_List_Class (First_Param); - return New_Bool_Mal_Type (Is_Null (List.all)); - end Is_Empty; - - - function Eval_As_List (MH : Types.Mal_Handle) return List_Mal_Type is - begin - case Deref (MH).Sym_Type is - when List => return Deref_List (MH).all; - when Nil => return Null_List (List_List); - when others => null; - end case; - raise Runtime_Exception with "Expecting a List"; - return Null_List (List_List); - end Eval_As_List; - - - function Count (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Evaled_List : Mal_Handle; - L : List_Mal_Type; - Rest_List : Types.List_Mal_Type; - N : Natural; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - if Deref (First_Param).Sym_Type = List and then - Deref_List (First_Param).Get_List_Type = Vector_List then - N := Deref_List_Class (First_Param).Length; - else - L := Eval_As_List (First_Param); - N := L.Length; - end if; - return New_Int_Mal_Type (N); - end Count; - - - function Cons (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Types.List_Mal_Type; - First_Param, List_Handle : Mal_Handle; - List : List_Mal_Type; - List_Class : List_Class_Ptr; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - List_Handle := Cdr (Rest_List); - List := Deref_List (List_Handle).all; - List_Handle := Car (List); - List_Class := Deref_List_Class (List_Handle); - return Prepend (First_Param, List_Class.all); - end Cons; - - - function Concat (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - return Types.Concat (Rest_List); - end Concat; - - - function First (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Types.List_Mal_Type; - First_List : Types.List_Class_Ptr; - First_Param : Mal_Handle; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - if Deref (First_Param).Sym_Type = Nil then - return New_Nil_Mal_Type; - end if; - First_List := Deref_List_Class (First_Param); - if Is_Null (First_List.all) then - return New_Nil_Mal_Type; - else - return Types.Car (First_List.all); - end if; - end First; - - - function Rest (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Types.List_Mal_Type; - First_Param, Container : Mal_Handle; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - if Deref (First_Param).Sym_Type = Nil then - return New_List_Mal_Type (List_List); - end if; - Container := Deref_List_Class (First_Param).Cdr; - return Deref_List_Class (Container).Duplicate; - end Rest; - - - function Nth (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - -- Rest_List, First_List : Types.List_Mal_Type; - Rest_List : Types.List_Mal_Type; - First_List : Types.List_Class_Ptr; - First_Param, List_Handle, Num_Handle : Mal_Handle; - List : List_Mal_Type; - Index : Types.Int_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - First_List := Deref_List_Class (First_Param); - List_Handle := Cdr (Rest_List); - List := Deref_List (List_Handle).all; - Num_Handle := Car (List); - Index := Deref_Int (Num_Handle).all; - return Types.Nth (First_List.all, Natural (Index.Get_Int_Val)); - end Nth; - - - function Apply (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - - Results_Handle, First_Param : Mal_Handle; - Rest_List : List_Mal_Type; - Results_List : List_Ptr; - - begin - - -- The rest of the line. - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - Rest_List := Deref_List (Cdr (Rest_List)).all; - - Results_Handle := New_List_Mal_Type (List_List); - Results_List := Deref_List (Results_Handle); - - -- The last item is a list or a vector which gets flattened so that - -- (apply f (A B) C (D E)) becomes (f (A B) C D E) - while not Is_Null (Rest_List) loop - declare - Part_Handle : Mal_Handle; - begin - Part_Handle := Car (Rest_List); - Rest_List := Deref_List (Cdr (Rest_List)).all; - - -- Is Part_Handle the last item in the list? - if Is_Null (Rest_List) then - declare - The_List : List_Class_Ptr; - List_Item : Mal_Handle; - Next_List : Mal_Handle; - begin - The_List := Deref_List_Class (Part_Handle); - while not Is_Null (The_List.all) loop - List_Item := Car (The_List.all); - Append (Results_List.all, List_Item); - Next_List := Cdr (The_List.all); - The_List := Deref_List_Class (Next_List); - end loop; - end; - else - Append (Results_List.all, Part_Handle); - end if; - end; - end loop; - - -- The apply part... - if Deref (First_Param).Sym_Type = Func then - return Call_Func (Deref_Func (First_Param).all, Results_Handle); - elsif Deref (First_Param).Sym_Type = Lambda then - declare - - L : Lambda_Mal_Type; - E : Envs.Env_Handle; - Param_Names : List_Mal_Type; - Res : Mal_Handle; - - begin - - L := Deref_Lambda (First_Param).all; - E := Envs.New_Env (L.Get_Env); - - Param_Names := Deref_List (L.Get_Params).all; - - if Envs.Bind (E, Param_Names, Results_List.all) then - - return Eval_Callback.Eval.all (L.Get_Expr, E); - - else - - raise Runtime_Exception with "Bind failed in Apply"; - - end if; - - end; - - else -- neither a Lambda or a Func - raise Runtime_Exception with "Deref called on non-Func/Lambda"; - end if; - - end Apply; - - - function Map (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - - Rest_List, Results_List : List_Mal_Type; - Func_Handle, List_Handle, Results_Handle : Mal_Handle; - - begin - - -- The rest of the line. - Rest_List := Deref_List (Rest_Handle).all; - - Func_Handle := Car (Rest_List); - List_Handle := Nth (Rest_List, 1); - - Results_Handle := New_List_Mal_Type (List_List); - Results_List := Deref_List (Results_Handle).all; - - while not Is_Null (Deref_List_Class (List_Handle).all) loop - - declare - Parts_Handle : Mal_Handle; - begin - Parts_Handle := - Make_New_List - ((1 => Func_Handle, - 2 => Make_New_List - ((1 => Car (Deref_List_Class (List_Handle).all))))); - - List_Handle := Cdr (Deref_List_Class (List_Handle).all); - - Append - (Results_List, - Apply (Parts_Handle)); - - end; - - end loop; - - return New_List_Mal_Type (Results_List); - - end Map; - - - function Symbol (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - - Sym_Handle : Mal_Handle; - Rest_List : List_Mal_Type; - - begin - - -- The rest of the line. - Rest_List := Deref_List (Rest_Handle).all; - - Sym_Handle := Car (Rest_List); - - return New_Symbol_Mal_Type (Deref_String (Sym_Handle).Get_String); - - end Symbol; - - - function Is_Symbol (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - - Sym_Handle : Mal_Handle; - Rest_List : List_Mal_Type; - Res : Boolean; - - begin - Rest_List := Deref_List (Rest_Handle).all; - Sym_Handle := Car (Rest_List); - if Deref (Sym_Handle).Sym_Type = Sym then - Res := Deref_Sym (Sym_Handle).Get_Sym (1) /= ':'; - else - Res := False; - end if; - return New_Bool_Mal_Type (Res); - end Is_Symbol; - - - function Is_String (Rest_Handle : Mal_Handle) return Types.Mal_Handle is - First_Param : Mal_Handle; - begin - First_Param := Car (Deref_List (Rest_Handle).all); - return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Str); - end Is_String; - - - function Keyword (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - - Sym_Handle : Mal_Handle; - Rest_List : List_Mal_Type; - - begin - - -- The rest of the line. - Rest_List := Deref_List (Rest_Handle).all; - - Sym_Handle := Car (Rest_List); - - case Deref (Sym_Handle).Sym_Type is - when Str => - return New_Symbol_Mal_Type (':' & Deref_String (Sym_Handle).Get_String); - when Sym => - if Deref_Sym (Sym_Handle).Get_Sym (1) = ':' then - return Sym_Handle; - end if; - when others => - null; - end case; - - raise Runtime_Exception with "keyword: expects a keyword or string"; - - end Keyword; - - - function Is_Keyword (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - - Sym_Handle : Mal_Handle; - Rest_List : List_Mal_Type; - Res : Boolean; - - begin - Rest_List := Deref_List (Rest_Handle).all; - Sym_Handle := Car (Rest_List); - if Deref (Sym_Handle).Sym_Type = Sym then - Res := Deref_Sym (Sym_Handle).Get_Sym (1) = ':'; - else - Res := False; - end if; - return New_Bool_Mal_Type (Res); - end Is_Keyword; - - - function Is_Number (Rest_Handle : Mal_Handle) return Types.Mal_Handle is - First_Param : Mal_Handle; - begin - First_Param := Car (Deref_List (Rest_Handle).all); - return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Int); - end Is_Number; - - - function Is_Fn (Rest_Handle : Mal_Handle) return Types.Mal_Handle is - First_Param : Mal_Handle; - Res : Boolean; - begin - First_Param := Car (Deref_List (Rest_Handle).all); - case Deref (First_Param).Sym_Type is - when Func => - Res := True; - when Lambda => - Res := not Deref_Lambda (First_Param).Get_Is_Macro; - when others => - Res := False; - end case; - return New_Bool_Mal_Type (Res); - end Is_Fn; - - - function Is_Macro (Rest_Handle : Mal_Handle) return Types.Mal_Handle is - First_Param : Mal_Handle; - begin - First_Param := Car (Deref_List (Rest_Handle).all); - return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Lambda and then Deref_Lambda (First_Param).Get_Is_Macro); - end Is_Macro; - - - function New_List (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - return New_List_Mal_Type (The_List => Rest_List); - end New_List; - - - function New_Vector (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : List_Mal_Type; - Res : Mal_Handle; - use Types.Vector; - begin - Res := New_Vector_Mal_Type; - Rest_List := Deref_List (Rest_Handle).all; - while not Is_Null (Rest_List) loop - Deref_Vector (Res).Append (Car (Rest_List)); - Rest_List := Deref_List (Cdr (Rest_List)).all; - end loop; - return Res; - end New_Vector; - - - function Vec (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - begin - First_Param := Car (Deref_List (Rest_Handle).all); - if Deref (First_Param).Sym_Type /= List then - raise Runtime_Exception with "Expecting a sequence"; - end if; - case Deref_List_Class (First_Param).Get_List_Type is - when Hashed_List => - raise Runtime_Exception with "Expecting a sequence"; - when Vector_List => - return First_Param; - when List_List => - return New_Vector (First_Param); - end case; - end Vec; - - - function New_Map (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : List_Mal_Type; - Res : Mal_Handle; - begin - Res := Hash_Map.New_Hash_Map_Mal_Type; - Rest_List := Deref_List (Rest_Handle).all; - while not Is_Null (Rest_List) loop - Hash_Map.Deref_Hash (Res).Append (Car (Rest_List)); - Rest_List := Deref_List (Cdr (Rest_List)).all; - end loop; - return Res; - end New_Map; - - - function Assoc (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Mal_Handle; - Map : Hash_Map.Hash_Map_Mal_Type; - begin - Rest_List := Rest_Handle; - Map := Hash_Map.Deref_Hash (Car (Deref_List (Rest_List).all)).all; - Rest_List := Cdr (Deref_List (Rest_List).all); - return Hash_Map.Assoc (Map, Rest_List); - end Assoc; - - - function Dis_Assoc (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Mal_Handle; - Map : Hash_Map.Hash_Map_Mal_Type; - begin - Rest_List := Rest_Handle; - Map := Hash_Map.Deref_Hash (Car (Deref_List (Rest_List).all)).all; - Rest_List := Cdr (Deref_List (Rest_List).all); - return Hash_Map.Dis_Assoc (Map, Rest_List); - end Dis_Assoc; - - - function Get_Key (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : List_Mal_Type; - Map : Hash_Map.Hash_Map_Mal_Type; - Map_Param, Key : Mal_Handle; - The_Sym : Sym_Types; - begin - - Rest_List := Deref_List (Rest_Handle).all; - Map_Param := Car (Rest_List); - The_Sym := Deref (Map_Param).Sym_Type; - if The_Sym = Sym or The_Sym = Nil then - -- Either its nil or its some other atom - -- which makes no sense! - return New_Nil_Mal_Type; - end if; - - -- Assume a map from here on in. - Map := Hash_Map.Deref_Hash (Car (Rest_List)).all; - Rest_List := Deref_List (Cdr (Rest_List)).all; - Key := Car (Rest_List); - - return Map.Get (Key); - - end Get_Key; - - - function Contains_Key (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : List_Mal_Type; - Map : Hash_Map.Hash_Map_Mal_Type; - Key : Mal_Handle; - begin - Rest_List := Deref_List (Rest_Handle).all; - Map := Hash_Map.Deref_Hash (Car (Rest_List)).all; - Rest_List := Deref_List (Cdr (Rest_List)).all; - Key := Car (Rest_List); - return New_Bool_Mal_Type (Hash_Map.Contains (Map, Key)); - end Contains_Key; - - - function All_Keys (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : List_Mal_Type; - Map : Hash_Map.Hash_Map_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - Map := Hash_Map.Deref_Hash (Car (Rest_List)).all; - return Hash_Map.All_Keys (Map); - end All_Keys; - - - function All_Values (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : List_Mal_Type; - Map : Hash_Map.Hash_Map_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - Map := Hash_Map.Deref_Hash (Car (Rest_List)).all; - return Hash_Map.All_Values (Map); - end All_Values; - - - -- Take a list with two parameters and produce a single result - -- using the Op access-to-function parameter. - function Reduce2 - (Op : Binary_Func_Access; LH : Mal_Handle) - return Mal_Handle is - Left, Right : Mal_Handle; - L, Rest_List : List_Mal_Type; - begin - L := Deref_List (LH).all; - Left := Car (L); - Rest_List := Deref_List (Cdr (L)).all; - Right := Car (Rest_List); - return Op (Left, Right); - end Reduce2; - - - function Plus (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 ("+"'Access, Rest_Handle); - end Plus; - - - function Minus (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 ("-"'Access, Rest_Handle); - end Minus; - - - function Mult (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 ("*"'Access, Rest_Handle); - end Mult; - - - function Divide (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 ("/"'Access, Rest_Handle); - end Divide; - - - function LT (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 ("<"'Access, Rest_Handle); - end LT; - - - function LTE (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 ("<="'Access, Rest_Handle); - end LTE; - - - function GT (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (">"'Access, Rest_Handle); - end GT; - - - function GTE (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (">="'Access, Rest_Handle); - end GTE; - - - function EQ (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (Types."="'Access, Rest_Handle); - end EQ; - - - function Pr_Str (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return New_String_Mal_Type (Deref_List (Rest_Handle).Pr_Str); - end Pr_Str; - - - function Prn (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - Ada.Text_IO.Put_Line (Deref_List (Rest_Handle).Pr_Str); - return New_Nil_Mal_Type; - end Prn; - - - function Println (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - Ada.Text_IO.Put_Line (Deref_List (Rest_Handle).Pr_Str (False)); - return New_Nil_Mal_Type; - end Println; - - - function Str (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return New_String_Mal_Type (Deref_List (Rest_Handle).Cat_Str (False)); - end Str; - - - function Read_String (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Types.List_Mal_Type; - First_Param : Mal_Handle; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return Reader.Read_Str (Deref_String (First_Param).Get_String); - end Read_String; - - - function Read_Line (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Types.List_Mal_Type; - First_Param : Mal_Handle; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - -- Output the prompt. - Ada.Text_IO.Put (Deref_String (First_Param).Get_String); - -- Get the text. - return New_String_Mal_Type (Ada.Text_IO.Get_Line); - end Read_Line; - - - function Slurp (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : Types.List_Mal_Type; - First_Param : Mal_Handle; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - declare - Unquoted_Str : String := Deref_String (First_Param).Get_String; - use Ada.Text_IO; - Fn : Ada.Text_IO.File_Type; - File_Str : Ada.Strings.Unbounded.Unbounded_String := - Ada.Strings.Unbounded.Null_Unbounded_String; - I : Natural := 0; - begin - Ada.Text_IO.Open (Fn, In_File, Unquoted_Str); - while not End_Of_File (Fn) loop - declare - Line_Str : constant String := Get_Line (Fn); - begin - if Line_Str'Length > 0 then - Ada.Strings.Unbounded.Append (File_Str, Line_Str); - Ada.Strings.Unbounded.Append (File_Str, Ada.Characters.Latin_1.LF); - end if; - end; - end loop; - Ada.Text_IO.Close (Fn); - return New_String_Mal_Type (Ada.Strings.Unbounded.To_String (File_Str)); - end; - end Slurp; - - - function Conj (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - Rest_List : List_Mal_Type; - First_Param, Res : Mal_Handle; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - Rest_List := Deref_List (Cdr (Rest_List)).all; - - -- Is this a List or a Vector? - case Deref_List (First_Param).Get_List_Type is - when List_List => - Res := Copy (First_Param); - while not Is_Null (Rest_List) loop - Res := Prepend (To_List => Deref_List (Res).all, Op => Car (Rest_List)); - Rest_List := Deref_List (Cdr (Rest_List)).all; - end loop; - return Res; - when Vector_List => - Res := Copy (First_Param); - while not Is_Null (Rest_List) loop - Vector.Append (Vector.Deref_Vector (Res).all, Car (Rest_List)); - Rest_List := Deref_List (Cdr (Rest_List)).all; - end loop; - return Res; - when Hashed_List => raise Runtime_Exception with "Conj on Hashed_Map"; - end case; - end Conj; - - - function Seq (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param, Res : Mal_Handle; - begin - First_Param := Car (Deref_List (Rest_Handle).all); - case Deref (First_Param).Sym_Type is - when Nil => return First_Param; - when List => - case Deref_List (First_Param).Get_List_Type is - when List_List => - if Is_Null (Deref_List (First_Param).all) then - return New_Nil_Mal_Type; - else - return First_Param; - end if; - when Vector_List => - if Vector.Is_Null (Vector.Deref_Vector (First_Param).all) then - return New_Nil_Mal_Type; - else - return Vector.Duplicate (Vector.Deref_Vector (First_Param).all); - end if; - when others => raise Runtime_Exception; - end case; - when Str => - declare - Param_Str : String := Deref_String (First_Param).Get_String; - String1 : String (1 .. 1); - L_Ptr : List_Ptr; - begin - if Param_Str'Length = 0 then - return New_Nil_Mal_Type; -- "" - else - Res := New_List_Mal_Type (List_List); - L_Ptr := Deref_List (Res); - for I in Param_Str'First .. Param_Str'Last loop - String1 (1) := Param_Str (I); - Append (L_Ptr.all, New_String_Mal_Type (String1)); - end loop; - return Res; - end if; - end; - when others => raise Runtime_Exception; - end case; - end Seq; - - - Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock; - - function Time_Ms (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - D : Duration; - use Ada.Calendar; - begin - D := Clock - Start_Time; -- seconds - D := D * 1000.0; -- milli-seconds - return New_Int_Mal_Type (Integer (D)); -- ms rounded to the nearest one - end Time_Ms; - - - procedure Init (Repl_Env : Envs.Env_Handle) is - begin - - Envs.Set (Repl_Env, "*host-language*", Types.New_String_Mal_Type ("Ada")); - - Envs.Set (Repl_Env, - "true?", - New_Func_Mal_Type ("true?", Is_True'access)); - - Envs.Set (Repl_Env, - "false?", - New_Func_Mal_Type ("false?", Is_False'access)); - - Envs.Set (Repl_Env, - "meta", - New_Func_Mal_Type ("meta", Meta'access)); - - Envs.Set (Repl_Env, - "with-meta", - New_Func_Mal_Type ("with-meta", With_Meta'access)); - - Envs.Set (Repl_Env, - "nil?", - New_Func_Mal_Type ("nil?", Is_Nil'access)); - - Envs.Set (Repl_Env, - "throw", - New_Func_Mal_Type ("throw", Throw'access)); - - Envs.Set (Repl_Env, - "atom", - New_Func_Mal_Type ("atom", New_Atom'access)); - - Envs.Set (Repl_Env, - "atom?", - New_Func_Mal_Type ("atom?", Is_Atom'access)); - - Envs.Set (Repl_Env, - "deref", - New_Func_Mal_Type ("deref", Deref_Atm'access)); - - Envs.Set (Repl_Env, - "reset!", - New_Func_Mal_Type ("reset!", Reset'access)); - - Envs.Set (Repl_Env, - "swap!", - New_Func_Mal_Type ("swap!", Swap'access)); - - Envs.Set (Repl_Env, - "list", - New_Func_Mal_Type ("list", New_List'access)); - - Envs.Set (Repl_Env, - "list?", - New_Func_Mal_Type ("list?", Is_List'access)); - - Envs.Set (Repl_Env, - "vec", - New_Func_Mal_Type ("vec", Vec'access)); - - Envs.Set (Repl_Env, - "vector", - New_Func_Mal_Type ("vector", New_Vector'access)); - - Envs.Set (Repl_Env, - "vector?", - New_Func_Mal_Type ("vector?", Is_Vector'access)); - - Envs.Set (Repl_Env, - "hash-map", - New_Func_Mal_Type ("hash-map", New_Map'access)); - - Envs.Set (Repl_Env, - "assoc", - New_Func_Mal_Type ("assoc", Assoc'access)); - - Envs.Set (Repl_Env, - "dissoc", - New_Func_Mal_Type ("dissoc", Dis_Assoc'access)); - - Envs.Set (Repl_Env, - "get", - New_Func_Mal_Type ("get", Get_Key'access)); - - Envs.Set (Repl_Env, - "keys", - New_Func_Mal_Type ("keys", All_Keys'access)); - - Envs.Set (Repl_Env, - "vals", - New_Func_Mal_Type ("vals", All_Values'access)); - - Envs.Set (Repl_Env, - "map?", - New_Func_Mal_Type ("map?", Is_Map'access)); - - Envs.Set (Repl_Env, - "contains?", - New_Func_Mal_Type ("contains?", Contains_Key'access)); - - Envs.Set (Repl_Env, - "sequential?", - New_Func_Mal_Type ("sequential?", Is_Sequential'access)); - - Envs.Set (Repl_Env, - "empty?", - New_Func_Mal_Type ("empty?", Is_Empty'access)); - - Envs.Set (Repl_Env, - "count", - New_Func_Mal_Type ("count", Count'access)); - - Envs.Set (Repl_Env, - "cons", - New_Func_Mal_Type ("cons", Cons'access)); - - Envs.Set (Repl_Env, - "concat", - New_Func_Mal_Type ("concat", Concat'access)); - - Envs.Set (Repl_Env, - "first", - New_Func_Mal_Type ("first", First'access)); - - Envs.Set (Repl_Env, - "rest", - New_Func_Mal_Type ("rest", Rest'access)); - - Envs.Set (Repl_Env, - "nth", - New_Func_Mal_Type ("nth", Nth'access)); - - Envs.Set (Repl_Env, - "map", - New_Func_Mal_Type ("map", Map'access)); - - Envs.Set (Repl_Env, - "apply", - New_Func_Mal_Type ("apply", Apply'access)); - - Envs.Set (Repl_Env, - "symbol", - New_Func_Mal_Type ("symbol", Symbol'access)); - - Envs.Set (Repl_Env, - "symbol?", - New_Func_Mal_Type ("symbol?", Is_Symbol'access)); - - Envs.Set (Repl_Env, - "string?", - New_Func_Mal_Type ("string?", Is_String'access)); - - Envs.Set (Repl_Env, - "keyword", - New_Func_Mal_Type ("keyword", Keyword'access)); - - Envs.Set (Repl_Env, - "keyword?", - New_Func_Mal_Type ("keyword?", Is_Keyword'access)); - - Envs.Set (Repl_Env, - "number?", - New_Func_Mal_Type ("number?", Is_Number'access)); - - Envs.Set (Repl_Env, - "fn?", - New_Func_Mal_Type ("fn?", Is_Fn'access)); - - Envs.Set (Repl_Env, - "macro?", - New_Func_Mal_Type ("macro?", Is_Macro'access)); - - Envs.Set (Repl_Env, - "pr-str", - New_Func_Mal_Type ("pr-str", Pr_Str'access)); - - Envs.Set (Repl_Env, - "str", - New_Func_Mal_Type ("str", Str'access)); - - Envs.Set (Repl_Env, - "prn", - New_Func_Mal_Type ("prn", Prn'access)); - - Envs.Set (Repl_Env, - "println", - New_Func_Mal_Type ("println", Println'access)); - - Envs.Set (Repl_Env, - "read-string", - New_Func_Mal_Type ("read-string", Read_String'access)); - - Envs.Set (Repl_Env, - "readline", - New_Func_Mal_Type ("readline", Read_Line'access)); - - Envs.Set (Repl_Env, - "slurp", - New_Func_Mal_Type ("slurp", Slurp'access)); - - Envs.Set (Repl_Env, - "conj", - New_Func_Mal_Type ("conj", Conj'access)); - - Envs.Set (Repl_Env, - "seq", - New_Func_Mal_Type ("seq", Seq'access)); - - Envs.Set (Repl_Env, - "time-ms", - New_Func_Mal_Type ("time-ms", Time_Ms'access)); - - Envs.Set (Repl_Env, - "+", - New_Func_Mal_Type ("+", Plus'access)); - - Envs.Set (Repl_Env, - "-", - New_Func_Mal_Type ("-", Minus'access)); - - Envs.Set (Repl_Env, - "*", - New_Func_Mal_Type ("*", Mult'access)); - - Envs.Set (Repl_Env, - "/", - New_Func_Mal_Type ("/", Divide'access)); - - Envs.Set (Repl_Env, - "<", - New_Func_Mal_Type ("<", LT'access)); - - Envs.Set (Repl_Env, - "<=", - New_Func_Mal_Type ("<=", LTE'access)); - - Envs.Set (Repl_Env, - ">", - New_Func_Mal_Type (">", GT'access)); - - Envs.Set (Repl_Env, - ">=", - New_Func_Mal_Type (">=", GTE'access)); - - Envs.Set (Repl_Env, - "=", - New_Func_Mal_Type ("=", EQ'access)); - - end Init; - - -end Core; +with Ada.Calendar; +with Ada.Characters.Latin_1; +with Ada.Strings.Unbounded; +with Ada.Text_IO; +with Eval_Callback; +with Reader; +with Smart_Pointers; +with Types; +with Types.Hash_Map; +with Types.Vector; + +package body Core is + + use Types; + + -- primitive functions on Smart_Pointer, + function "+" is new Arith_Op ("+", "+"); + function "-" is new Arith_Op ("-", "-"); + function "*" is new Arith_Op ("*", "*"); + function "/" is new Arith_Op ("/", "/"); + + function "<" is new Rel_Op ("<", "<"); + function "<=" is new Rel_Op ("<=", "<="); + function ">" is new Rel_Op (">", ">"); + function ">=" is new Rel_Op (">=", ">="); + + + function Eval_As_Boolean (MH : Types.Mal_Handle) return Boolean is + use Types; + Res : Boolean; + begin + case Deref (MH).Sym_Type is + when Bool => + Res := Deref_Bool (MH).Get_Bool; + when Nil => + Res := False; +-- when List => +-- declare +-- L : List_Mal_Type; +-- begin +-- L := Deref_List (MH).all; +-- Res := not Is_Null (L); +-- end; + when others => -- Everything else + Res := True; + end case; + return Res; + end Eval_As_Boolean; + + + function Throw (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + Types.Mal_Exception_Value := First_Param; + raise Mal_Exception; + return First_Param; -- Keep the compiler happy. + end Throw; + + + function Is_True (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return New_Bool_Mal_Type + (Deref (First_Param).Sym_Type = Bool and then + Deref_Bool (First_Param).Get_Bool); + end Is_True; + + + function Is_False (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return New_Bool_Mal_Type + (Deref (First_Param).Sym_Type = Bool and then + not Deref_Bool (First_Param).Get_Bool); + end Is_False; + + + function Is_Nil (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return New_Bool_Mal_Type + (Deref (First_Param).Sym_Type = Nil); + end Is_Nil; + + + function Meta (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return Deref (First_Param).Get_Meta; + end Meta; + + + function With_Meta (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Meta_Param, Res : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + Rest_List := Deref_List (Cdr (Rest_List)).all; + Meta_Param := Car (Rest_List); + Res := Copy (First_Param); + Deref (Res).Set_Meta (Meta_Param); + return Res; + end With_Meta; + + + function New_Atom (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return New_Atom_Mal_Type (First_Param); + end New_Atom; + + function Is_Atom (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Atom); + end Is_Atom; + + + function Deref_Atm (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return Deref_Atom (First_Param).Get_Atom; + end Deref_Atm; + + + function Reset (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Atom_Param, New_Val : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + Atom_Param := Car (Rest_List); + Rest_List := Deref_List (Cdr (Rest_List)).all; + New_Val := Car (Rest_List); + Deref_Atom (Atom_Param).Set_Atom (New_Val); + return New_Val; + end Reset; + + + function Swap (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Atom_Param, Atom_Val, New_Val : Mal_Handle; + Rest_List : Types.List_Mal_Type; + Rest_List_Class : Types.List_Class_Ptr; + Func_Param, Param_List : Mal_Handle; + begin + Rest_List := Deref_List (Rest_Handle).all; + Atom_Param := Car (Rest_List); + Rest_List := Deref_List (Cdr (Rest_List)).all; + Func_Param := Car (Rest_List); + Param_List := Cdr (Rest_List); + + Rest_List_Class := Deref_List_Class (Param_List); + Param_List := Rest_List_Class.Duplicate; + Atom_Val := Deref_Atom (Atom_Param).Get_Atom; + Param_List := Prepend (Atom_Val, Deref_List (Param_List).all); + case Deref (Func_Param).Sym_Type is + when Lambda => + New_Val := Deref_Lambda (Func_Param).Apply (Param_List); + when Func => + New_Val := Deref_Func (Func_Param).Call_Func (Param_List); + when others => raise Runtime_Exception with "Swap with bad func"; + end case; + Deref_Atom (Atom_Param).Set_Atom (New_Val); + return New_Val; + end Swap; + + + function Is_List (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return New_Bool_Mal_Type + (Deref (First_Param).Sym_Type = List and then + Deref_List (First_Param).Get_List_Type = List_List); + end Is_List; + + + function Is_Vector (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return New_Bool_Mal_Type + (Deref (First_Param).Sym_Type = List and then + Deref_List (First_Param).Get_List_Type = Vector_List); + end Is_Vector; + + + function Is_Map (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return New_Bool_Mal_Type + (Deref (First_Param).Sym_Type = List and then + Deref_List (First_Param).Get_List_Type = Hashed_List); + end Is_Map; + + + function Is_Sequential (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return New_Bool_Mal_Type + (Deref (First_Param).Sym_Type = List and then + Deref_List (First_Param).Get_List_Type /= Hashed_List); + end Is_Sequential; + + + function Is_Empty (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + List : List_Class_Ptr; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + List := Deref_List_Class (First_Param); + return New_Bool_Mal_Type (Is_Null (List.all)); + end Is_Empty; + + + function Eval_As_List (MH : Types.Mal_Handle) return List_Mal_Type is + begin + case Deref (MH).Sym_Type is + when List => return Deref_List (MH).all; + when Nil => return Null_List (List_List); + when others => null; + end case; + raise Runtime_Exception with "Expecting a List"; + return Null_List (List_List); + end Eval_As_List; + + + function Count (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Evaled_List : Mal_Handle; + L : List_Mal_Type; + Rest_List : Types.List_Mal_Type; + N : Natural; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + if Deref (First_Param).Sym_Type = List and then + Deref_List (First_Param).Get_List_Type = Vector_List then + N := Deref_List_Class (First_Param).Length; + else + L := Eval_As_List (First_Param); + N := L.Length; + end if; + return New_Int_Mal_Type (N); + end Count; + + + function Cons (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Types.List_Mal_Type; + First_Param, List_Handle : Mal_Handle; + List : List_Mal_Type; + List_Class : List_Class_Ptr; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + List_Handle := Cdr (Rest_List); + List := Deref_List (List_Handle).all; + List_Handle := Car (List); + List_Class := Deref_List_Class (List_Handle); + return Prepend (First_Param, List_Class.all); + end Cons; + + + function Concat (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + return Types.Concat (Rest_List); + end Concat; + + + function First (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Types.List_Mal_Type; + First_List : Types.List_Class_Ptr; + First_Param : Mal_Handle; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + if Deref (First_Param).Sym_Type = Nil then + return New_Nil_Mal_Type; + end if; + First_List := Deref_List_Class (First_Param); + if Is_Null (First_List.all) then + return New_Nil_Mal_Type; + else + return Types.Car (First_List.all); + end if; + end First; + + + function Rest (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Types.List_Mal_Type; + First_Param, Container : Mal_Handle; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + if Deref (First_Param).Sym_Type = Nil then + return New_List_Mal_Type (List_List); + end if; + Container := Deref_List_Class (First_Param).Cdr; + return Deref_List_Class (Container).Duplicate; + end Rest; + + + function Nth (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + -- Rest_List, First_List : Types.List_Mal_Type; + Rest_List : Types.List_Mal_Type; + First_List : Types.List_Class_Ptr; + First_Param, List_Handle, Num_Handle : Mal_Handle; + List : List_Mal_Type; + Index : Types.Int_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + First_List := Deref_List_Class (First_Param); + List_Handle := Cdr (Rest_List); + List := Deref_List (List_Handle).all; + Num_Handle := Car (List); + Index := Deref_Int (Num_Handle).all; + return Types.Nth (First_List.all, Natural (Index.Get_Int_Val)); + end Nth; + + + function Apply (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + + Results_Handle, First_Param : Mal_Handle; + Rest_List : List_Mal_Type; + Results_List : List_Ptr; + + begin + + -- The rest of the line. + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + Rest_List := Deref_List (Cdr (Rest_List)).all; + + Results_Handle := New_List_Mal_Type (List_List); + Results_List := Deref_List (Results_Handle); + + -- The last item is a list or a vector which gets flattened so that + -- (apply f (A B) C (D E)) becomes (f (A B) C D E) + while not Is_Null (Rest_List) loop + declare + Part_Handle : Mal_Handle; + begin + Part_Handle := Car (Rest_List); + Rest_List := Deref_List (Cdr (Rest_List)).all; + + -- Is Part_Handle the last item in the list? + if Is_Null (Rest_List) then + declare + The_List : List_Class_Ptr; + List_Item : Mal_Handle; + Next_List : Mal_Handle; + begin + The_List := Deref_List_Class (Part_Handle); + while not Is_Null (The_List.all) loop + List_Item := Car (The_List.all); + Append (Results_List.all, List_Item); + Next_List := Cdr (The_List.all); + The_List := Deref_List_Class (Next_List); + end loop; + end; + else + Append (Results_List.all, Part_Handle); + end if; + end; + end loop; + + -- The apply part... + if Deref (First_Param).Sym_Type = Func then + return Call_Func (Deref_Func (First_Param).all, Results_Handle); + elsif Deref (First_Param).Sym_Type = Lambda then + declare + + L : Lambda_Mal_Type; + E : Envs.Env_Handle; + Param_Names : List_Mal_Type; + Res : Mal_Handle; + + begin + + L := Deref_Lambda (First_Param).all; + E := Envs.New_Env (L.Get_Env); + + Param_Names := Deref_List (L.Get_Params).all; + + if Envs.Bind (E, Param_Names, Results_List.all) then + + return Eval_Callback.Eval.all (L.Get_Expr, E); + + else + + raise Runtime_Exception with "Bind failed in Apply"; + + end if; + + end; + + else -- neither a Lambda or a Func + raise Runtime_Exception with "Deref called on non-Func/Lambda"; + end if; + + end Apply; + + + function Map (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + + Rest_List, Results_List : List_Mal_Type; + Func_Handle, List_Handle, Results_Handle : Mal_Handle; + + begin + + -- The rest of the line. + Rest_List := Deref_List (Rest_Handle).all; + + Func_Handle := Car (Rest_List); + List_Handle := Nth (Rest_List, 1); + + Results_Handle := New_List_Mal_Type (List_List); + Results_List := Deref_List (Results_Handle).all; + + while not Is_Null (Deref_List_Class (List_Handle).all) loop + + declare + Parts_Handle : Mal_Handle; + begin + Parts_Handle := + Make_New_List + ((1 => Func_Handle, + 2 => Make_New_List + ((1 => Car (Deref_List_Class (List_Handle).all))))); + + List_Handle := Cdr (Deref_List_Class (List_Handle).all); + + Append + (Results_List, + Apply (Parts_Handle)); + + end; + + end loop; + + return New_List_Mal_Type (Results_List); + + end Map; + + + function Symbol (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + + Sym_Handle : Mal_Handle; + Rest_List : List_Mal_Type; + + begin + + -- The rest of the line. + Rest_List := Deref_List (Rest_Handle).all; + + Sym_Handle := Car (Rest_List); + + return New_Symbol_Mal_Type (Deref_String (Sym_Handle).Get_String); + + end Symbol; + + + function Is_Symbol (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + + Sym_Handle : Mal_Handle; + Rest_List : List_Mal_Type; + Res : Boolean; + + begin + Rest_List := Deref_List (Rest_Handle).all; + Sym_Handle := Car (Rest_List); + if Deref (Sym_Handle).Sym_Type = Sym then + Res := Deref_Sym (Sym_Handle).Get_Sym (1) /= ':'; + else + Res := False; + end if; + return New_Bool_Mal_Type (Res); + end Is_Symbol; + + + function Is_String (Rest_Handle : Mal_Handle) return Types.Mal_Handle is + First_Param : Mal_Handle; + begin + First_Param := Car (Deref_List (Rest_Handle).all); + return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Str); + end Is_String; + + + function Keyword (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + + Sym_Handle : Mal_Handle; + Rest_List : List_Mal_Type; + + begin + + -- The rest of the line. + Rest_List := Deref_List (Rest_Handle).all; + + Sym_Handle := Car (Rest_List); + + case Deref (Sym_Handle).Sym_Type is + when Str => + return New_Symbol_Mal_Type (':' & Deref_String (Sym_Handle).Get_String); + when Sym => + if Deref_Sym (Sym_Handle).Get_Sym (1) = ':' then + return Sym_Handle; + end if; + when others => + null; + end case; + + raise Runtime_Exception with "keyword: expects a keyword or string"; + + end Keyword; + + + function Is_Keyword (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + + Sym_Handle : Mal_Handle; + Rest_List : List_Mal_Type; + Res : Boolean; + + begin + Rest_List := Deref_List (Rest_Handle).all; + Sym_Handle := Car (Rest_List); + if Deref (Sym_Handle).Sym_Type = Sym then + Res := Deref_Sym (Sym_Handle).Get_Sym (1) = ':'; + else + Res := False; + end if; + return New_Bool_Mal_Type (Res); + end Is_Keyword; + + + function Is_Number (Rest_Handle : Mal_Handle) return Types.Mal_Handle is + First_Param : Mal_Handle; + begin + First_Param := Car (Deref_List (Rest_Handle).all); + return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Int); + end Is_Number; + + + function Is_Fn (Rest_Handle : Mal_Handle) return Types.Mal_Handle is + First_Param : Mal_Handle; + Res : Boolean; + begin + First_Param := Car (Deref_List (Rest_Handle).all); + case Deref (First_Param).Sym_Type is + when Func => + Res := True; + when Lambda => + Res := not Deref_Lambda (First_Param).Get_Is_Macro; + when others => + Res := False; + end case; + return New_Bool_Mal_Type (Res); + end Is_Fn; + + + function Is_Macro (Rest_Handle : Mal_Handle) return Types.Mal_Handle is + First_Param : Mal_Handle; + begin + First_Param := Car (Deref_List (Rest_Handle).all); + return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Lambda and then Deref_Lambda (First_Param).Get_Is_Macro); + end Is_Macro; + + + function New_List (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + return New_List_Mal_Type (The_List => Rest_List); + end New_List; + + + function New_Vector (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : List_Mal_Type; + Res : Mal_Handle; + use Types.Vector; + begin + Res := New_Vector_Mal_Type; + Rest_List := Deref_List (Rest_Handle).all; + while not Is_Null (Rest_List) loop + Deref_Vector (Res).Append (Car (Rest_List)); + Rest_List := Deref_List (Cdr (Rest_List)).all; + end loop; + return Res; + end New_Vector; + + + function Vec (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + begin + First_Param := Car (Deref_List (Rest_Handle).all); + if Deref (First_Param).Sym_Type /= List then + raise Runtime_Exception with "Expecting a sequence"; + end if; + case Deref_List_Class (First_Param).Get_List_Type is + when Hashed_List => + raise Runtime_Exception with "Expecting a sequence"; + when Vector_List => + return First_Param; + when List_List => + return New_Vector (First_Param); + end case; + end Vec; + + + function New_Map (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : List_Mal_Type; + Res : Mal_Handle; + begin + Res := Hash_Map.New_Hash_Map_Mal_Type; + Rest_List := Deref_List (Rest_Handle).all; + while not Is_Null (Rest_List) loop + Hash_Map.Deref_Hash (Res).Append (Car (Rest_List)); + Rest_List := Deref_List (Cdr (Rest_List)).all; + end loop; + return Res; + end New_Map; + + + function Assoc (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Mal_Handle; + Map : Hash_Map.Hash_Map_Mal_Type; + begin + Rest_List := Rest_Handle; + Map := Hash_Map.Deref_Hash (Car (Deref_List (Rest_List).all)).all; + Rest_List := Cdr (Deref_List (Rest_List).all); + return Hash_Map.Assoc (Map, Rest_List); + end Assoc; + + + function Dis_Assoc (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Mal_Handle; + Map : Hash_Map.Hash_Map_Mal_Type; + begin + Rest_List := Rest_Handle; + Map := Hash_Map.Deref_Hash (Car (Deref_List (Rest_List).all)).all; + Rest_List := Cdr (Deref_List (Rest_List).all); + return Hash_Map.Dis_Assoc (Map, Rest_List); + end Dis_Assoc; + + + function Get_Key (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : List_Mal_Type; + Map : Hash_Map.Hash_Map_Mal_Type; + Map_Param, Key : Mal_Handle; + The_Sym : Sym_Types; + begin + + Rest_List := Deref_List (Rest_Handle).all; + Map_Param := Car (Rest_List); + The_Sym := Deref (Map_Param).Sym_Type; + if The_Sym = Sym or The_Sym = Nil then + -- Either its nil or its some other atom + -- which makes no sense! + return New_Nil_Mal_Type; + end if; + + -- Assume a map from here on in. + Map := Hash_Map.Deref_Hash (Car (Rest_List)).all; + Rest_List := Deref_List (Cdr (Rest_List)).all; + Key := Car (Rest_List); + + return Map.Get (Key); + + end Get_Key; + + + function Contains_Key (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : List_Mal_Type; + Map : Hash_Map.Hash_Map_Mal_Type; + Key : Mal_Handle; + begin + Rest_List := Deref_List (Rest_Handle).all; + Map := Hash_Map.Deref_Hash (Car (Rest_List)).all; + Rest_List := Deref_List (Cdr (Rest_List)).all; + Key := Car (Rest_List); + return New_Bool_Mal_Type (Hash_Map.Contains (Map, Key)); + end Contains_Key; + + + function All_Keys (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : List_Mal_Type; + Map : Hash_Map.Hash_Map_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + Map := Hash_Map.Deref_Hash (Car (Rest_List)).all; + return Hash_Map.All_Keys (Map); + end All_Keys; + + + function All_Values (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : List_Mal_Type; + Map : Hash_Map.Hash_Map_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + Map := Hash_Map.Deref_Hash (Car (Rest_List)).all; + return Hash_Map.All_Values (Map); + end All_Values; + + + -- Take a list with two parameters and produce a single result + -- using the Op access-to-function parameter. + function Reduce2 + (Op : Binary_Func_Access; LH : Mal_Handle) + return Mal_Handle is + Left, Right : Mal_Handle; + L, Rest_List : List_Mal_Type; + begin + L := Deref_List (LH).all; + Left := Car (L); + Rest_List := Deref_List (Cdr (L)).all; + Right := Car (Rest_List); + return Op (Left, Right); + end Reduce2; + + + function Plus (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 ("+"'Access, Rest_Handle); + end Plus; + + + function Minus (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 ("-"'Access, Rest_Handle); + end Minus; + + + function Mult (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 ("*"'Access, Rest_Handle); + end Mult; + + + function Divide (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 ("/"'Access, Rest_Handle); + end Divide; + + + function LT (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 ("<"'Access, Rest_Handle); + end LT; + + + function LTE (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 ("<="'Access, Rest_Handle); + end LTE; + + + function GT (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (">"'Access, Rest_Handle); + end GT; + + + function GTE (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (">="'Access, Rest_Handle); + end GTE; + + + function EQ (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (Types."="'Access, Rest_Handle); + end EQ; + + + function Pr_Str (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return New_String_Mal_Type (Deref_List (Rest_Handle).Pr_Str); + end Pr_Str; + + + function Prn (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + Ada.Text_IO.Put_Line (Deref_List (Rest_Handle).Pr_Str); + return New_Nil_Mal_Type; + end Prn; + + + function Println (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + Ada.Text_IO.Put_Line (Deref_List (Rest_Handle).Pr_Str (False)); + return New_Nil_Mal_Type; + end Println; + + + function Str (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return New_String_Mal_Type (Deref_List (Rest_Handle).Cat_Str (False)); + end Str; + + + function Read_String (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Types.List_Mal_Type; + First_Param : Mal_Handle; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return Reader.Read_Str (Deref_String (First_Param).Get_String); + end Read_String; + + + function Read_Line (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Types.List_Mal_Type; + First_Param : Mal_Handle; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + -- Output the prompt. + Ada.Text_IO.Put (Deref_String (First_Param).Get_String); + -- Get the text. + return New_String_Mal_Type (Ada.Text_IO.Get_Line); + end Read_Line; + + + function Slurp (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : Types.List_Mal_Type; + First_Param : Mal_Handle; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + declare + Unquoted_Str : String := Deref_String (First_Param).Get_String; + use Ada.Text_IO; + Fn : Ada.Text_IO.File_Type; + File_Str : Ada.Strings.Unbounded.Unbounded_String := + Ada.Strings.Unbounded.Null_Unbounded_String; + I : Natural := 0; + begin + Ada.Text_IO.Open (Fn, In_File, Unquoted_Str); + while not End_Of_File (Fn) loop + declare + Line_Str : constant String := Get_Line (Fn); + begin + if Line_Str'Length > 0 then + Ada.Strings.Unbounded.Append (File_Str, Line_Str); + Ada.Strings.Unbounded.Append (File_Str, Ada.Characters.Latin_1.LF); + end if; + end; + end loop; + Ada.Text_IO.Close (Fn); + return New_String_Mal_Type (Ada.Strings.Unbounded.To_String (File_Str)); + end; + end Slurp; + + + function Conj (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + Rest_List : List_Mal_Type; + First_Param, Res : Mal_Handle; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + Rest_List := Deref_List (Cdr (Rest_List)).all; + + -- Is this a List or a Vector? + case Deref_List (First_Param).Get_List_Type is + when List_List => + Res := Copy (First_Param); + while not Is_Null (Rest_List) loop + Res := Prepend (To_List => Deref_List (Res).all, Op => Car (Rest_List)); + Rest_List := Deref_List (Cdr (Rest_List)).all; + end loop; + return Res; + when Vector_List => + Res := Copy (First_Param); + while not Is_Null (Rest_List) loop + Vector.Append (Vector.Deref_Vector (Res).all, Car (Rest_List)); + Rest_List := Deref_List (Cdr (Rest_List)).all; + end loop; + return Res; + when Hashed_List => raise Runtime_Exception with "Conj on Hashed_Map"; + end case; + end Conj; + + + function Seq (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param, Res : Mal_Handle; + begin + First_Param := Car (Deref_List (Rest_Handle).all); + case Deref (First_Param).Sym_Type is + when Nil => return First_Param; + when List => + case Deref_List (First_Param).Get_List_Type is + when List_List => + if Is_Null (Deref_List (First_Param).all) then + return New_Nil_Mal_Type; + else + return First_Param; + end if; + when Vector_List => + if Vector.Is_Null (Vector.Deref_Vector (First_Param).all) then + return New_Nil_Mal_Type; + else + return Vector.Duplicate (Vector.Deref_Vector (First_Param).all); + end if; + when others => raise Runtime_Exception; + end case; + when Str => + declare + Param_Str : String := Deref_String (First_Param).Get_String; + String1 : String (1 .. 1); + L_Ptr : List_Ptr; + begin + if Param_Str'Length = 0 then + return New_Nil_Mal_Type; -- "" + else + Res := New_List_Mal_Type (List_List); + L_Ptr := Deref_List (Res); + for I in Param_Str'First .. Param_Str'Last loop + String1 (1) := Param_Str (I); + Append (L_Ptr.all, New_String_Mal_Type (String1)); + end loop; + return Res; + end if; + end; + when others => raise Runtime_Exception; + end case; + end Seq; + + + Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + + function Time_Ms (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + D : Duration; + use Ada.Calendar; + begin + D := Clock - Start_Time; -- seconds + D := D * 1000.0; -- milli-seconds + return New_Int_Mal_Type (Integer (D)); -- ms rounded to the nearest one + end Time_Ms; + + + procedure Init (Repl_Env : Envs.Env_Handle) is + begin + + Envs.Set (Repl_Env, "*host-language*", Types.New_String_Mal_Type ("Ada")); + + Envs.Set (Repl_Env, + "true?", + New_Func_Mal_Type ("true?", Is_True'access)); + + Envs.Set (Repl_Env, + "false?", + New_Func_Mal_Type ("false?", Is_False'access)); + + Envs.Set (Repl_Env, + "meta", + New_Func_Mal_Type ("meta", Meta'access)); + + Envs.Set (Repl_Env, + "with-meta", + New_Func_Mal_Type ("with-meta", With_Meta'access)); + + Envs.Set (Repl_Env, + "nil?", + New_Func_Mal_Type ("nil?", Is_Nil'access)); + + Envs.Set (Repl_Env, + "throw", + New_Func_Mal_Type ("throw", Throw'access)); + + Envs.Set (Repl_Env, + "atom", + New_Func_Mal_Type ("atom", New_Atom'access)); + + Envs.Set (Repl_Env, + "atom?", + New_Func_Mal_Type ("atom?", Is_Atom'access)); + + Envs.Set (Repl_Env, + "deref", + New_Func_Mal_Type ("deref", Deref_Atm'access)); + + Envs.Set (Repl_Env, + "reset!", + New_Func_Mal_Type ("reset!", Reset'access)); + + Envs.Set (Repl_Env, + "swap!", + New_Func_Mal_Type ("swap!", Swap'access)); + + Envs.Set (Repl_Env, + "list", + New_Func_Mal_Type ("list", New_List'access)); + + Envs.Set (Repl_Env, + "list?", + New_Func_Mal_Type ("list?", Is_List'access)); + + Envs.Set (Repl_Env, + "vec", + New_Func_Mal_Type ("vec", Vec'access)); + + Envs.Set (Repl_Env, + "vector", + New_Func_Mal_Type ("vector", New_Vector'access)); + + Envs.Set (Repl_Env, + "vector?", + New_Func_Mal_Type ("vector?", Is_Vector'access)); + + Envs.Set (Repl_Env, + "hash-map", + New_Func_Mal_Type ("hash-map", New_Map'access)); + + Envs.Set (Repl_Env, + "assoc", + New_Func_Mal_Type ("assoc", Assoc'access)); + + Envs.Set (Repl_Env, + "dissoc", + New_Func_Mal_Type ("dissoc", Dis_Assoc'access)); + + Envs.Set (Repl_Env, + "get", + New_Func_Mal_Type ("get", Get_Key'access)); + + Envs.Set (Repl_Env, + "keys", + New_Func_Mal_Type ("keys", All_Keys'access)); + + Envs.Set (Repl_Env, + "vals", + New_Func_Mal_Type ("vals", All_Values'access)); + + Envs.Set (Repl_Env, + "map?", + New_Func_Mal_Type ("map?", Is_Map'access)); + + Envs.Set (Repl_Env, + "contains?", + New_Func_Mal_Type ("contains?", Contains_Key'access)); + + Envs.Set (Repl_Env, + "sequential?", + New_Func_Mal_Type ("sequential?", Is_Sequential'access)); + + Envs.Set (Repl_Env, + "empty?", + New_Func_Mal_Type ("empty?", Is_Empty'access)); + + Envs.Set (Repl_Env, + "count", + New_Func_Mal_Type ("count", Count'access)); + + Envs.Set (Repl_Env, + "cons", + New_Func_Mal_Type ("cons", Cons'access)); + + Envs.Set (Repl_Env, + "concat", + New_Func_Mal_Type ("concat", Concat'access)); + + Envs.Set (Repl_Env, + "first", + New_Func_Mal_Type ("first", First'access)); + + Envs.Set (Repl_Env, + "rest", + New_Func_Mal_Type ("rest", Rest'access)); + + Envs.Set (Repl_Env, + "nth", + New_Func_Mal_Type ("nth", Nth'access)); + + Envs.Set (Repl_Env, + "map", + New_Func_Mal_Type ("map", Map'access)); + + Envs.Set (Repl_Env, + "apply", + New_Func_Mal_Type ("apply", Apply'access)); + + Envs.Set (Repl_Env, + "symbol", + New_Func_Mal_Type ("symbol", Symbol'access)); + + Envs.Set (Repl_Env, + "symbol?", + New_Func_Mal_Type ("symbol?", Is_Symbol'access)); + + Envs.Set (Repl_Env, + "string?", + New_Func_Mal_Type ("string?", Is_String'access)); + + Envs.Set (Repl_Env, + "keyword", + New_Func_Mal_Type ("keyword", Keyword'access)); + + Envs.Set (Repl_Env, + "keyword?", + New_Func_Mal_Type ("keyword?", Is_Keyword'access)); + + Envs.Set (Repl_Env, + "number?", + New_Func_Mal_Type ("number?", Is_Number'access)); + + Envs.Set (Repl_Env, + "fn?", + New_Func_Mal_Type ("fn?", Is_Fn'access)); + + Envs.Set (Repl_Env, + "macro?", + New_Func_Mal_Type ("macro?", Is_Macro'access)); + + Envs.Set (Repl_Env, + "pr-str", + New_Func_Mal_Type ("pr-str", Pr_Str'access)); + + Envs.Set (Repl_Env, + "str", + New_Func_Mal_Type ("str", Str'access)); + + Envs.Set (Repl_Env, + "prn", + New_Func_Mal_Type ("prn", Prn'access)); + + Envs.Set (Repl_Env, + "println", + New_Func_Mal_Type ("println", Println'access)); + + Envs.Set (Repl_Env, + "read-string", + New_Func_Mal_Type ("read-string", Read_String'access)); + + Envs.Set (Repl_Env, + "readline", + New_Func_Mal_Type ("readline", Read_Line'access)); + + Envs.Set (Repl_Env, + "slurp", + New_Func_Mal_Type ("slurp", Slurp'access)); + + Envs.Set (Repl_Env, + "conj", + New_Func_Mal_Type ("conj", Conj'access)); + + Envs.Set (Repl_Env, + "seq", + New_Func_Mal_Type ("seq", Seq'access)); + + Envs.Set (Repl_Env, + "time-ms", + New_Func_Mal_Type ("time-ms", Time_Ms'access)); + + Envs.Set (Repl_Env, + "+", + New_Func_Mal_Type ("+", Plus'access)); + + Envs.Set (Repl_Env, + "-", + New_Func_Mal_Type ("-", Minus'access)); + + Envs.Set (Repl_Env, + "*", + New_Func_Mal_Type ("*", Mult'access)); + + Envs.Set (Repl_Env, + "/", + New_Func_Mal_Type ("/", Divide'access)); + + Envs.Set (Repl_Env, + "<", + New_Func_Mal_Type ("<", LT'access)); + + Envs.Set (Repl_Env, + "<=", + New_Func_Mal_Type ("<=", LTE'access)); + + Envs.Set (Repl_Env, + ">", + New_Func_Mal_Type (">", GT'access)); + + Envs.Set (Repl_Env, + ">=", + New_Func_Mal_Type (">=", GTE'access)); + + Envs.Set (Repl_Env, + "=", + New_Func_Mal_Type ("=", EQ'access)); + + end Init; + + +end Core; diff --git a/impls/ada/core.ads b/impls/ada/core.ads index d4e253e505..1692221641 100644 --- a/impls/ada/core.ads +++ b/impls/ada/core.ads @@ -1,10 +1,10 @@ -with Envs; - -package Core is - - -- Init puts core functions into a new Env. - procedure Init (Repl_Env : Envs.Env_Handle); - - Evaluation_Error : exception; - -end Core; +with Envs; + +package Core is + + -- Init puts core functions into a new Env. + procedure Init (Repl_Env : Envs.Env_Handle); + + Evaluation_Error : exception; + +end Core; diff --git a/impls/ada/envs.adb b/impls/ada/envs.adb index 0739ad0cfd..b5b7e760a5 100644 --- a/impls/ada/envs.adb +++ b/impls/ada/envs.adb @@ -1,146 +1,146 @@ -with Ada.Text_IO; -with Types; -with Unchecked_Deallocation; - -package body Envs is - - - function Is_Null (E : Env_Handle) return Boolean is - use Smart_Pointers; - begin - return E = Null_Env_Handle; - end Is_Null; - - - function New_Env (Outer : Env_Handle := Null_Env_Handle) return Env_Handle is - use Smart_Pointers; - Level : Natural; - begin - if Is_Null (Outer) then - Level := 0; - else - Level := Deref (Outer).Level + 1; - end if; - if Debug then - Ada.Text_IO.Put_Line - ("Envs: Creating at level " & Natural'Image (Level)); - end if; - return Env_Handle (Smart_Pointers.New_Ptr (new Env' - (Base_Class with The_Map => String_Mal_Hash.Empty_Map, - Outer_Env => Outer, - Level => Level))); - end New_Env; - - - procedure Set - (E : Env_Handle; - Key : String; - Elem : Smart_Pointers.Smart_Pointer) is - begin - if Debug then - Ada.Text_IO.Put_Line - ("Envs: Setting " & Key & - " to " & Types.Deref (Elem).To_String & - " at level " & Natural'Image (Deref (E).Level)); - end if; - String_Mal_Hash.Include - (Container => Deref (E).The_Map, - Key => Ada.Strings.Unbounded.To_Unbounded_String (Key), - New_Item => Elem); - end Set; - - - function Get (E : Env_Handle; Key: String) - return Smart_Pointers.Smart_Pointer is - - use String_Mal_Hash; - C : Cursor; - - begin - - if Debug then - Ada.Text_IO.Put_Line - ("Envs: Finding " & Key & - " at level " & Natural'Image (Deref (E).Level)); - end if; - - C := Find (Deref (E).The_Map, - Ada.Strings.Unbounded.To_Unbounded_String (Key)); - - if C = No_Element then - - if Is_Null (Deref (E).Outer_Env) then - raise Not_Found; - else - return Get (Deref (E).Outer_Env, Key); - end if; - - else - return Element (C); - end if; - - end Get; - - - procedure Set_Outer - (E : Env_Handle; Outer_Env : Env_Handle) is - begin - -- Attempt to avoid making loops. - if Deref (E).Level /= 0 then - Deref (E).Outer_Env := Outer_Env; - end if; - end Set_Outer; - - - function To_String (E : Env_Handle) return String is - use String_Mal_Hash, Ada.Strings.Unbounded; - C : Cursor; - Res : Unbounded_String; - begin - C := First (Deref (E).The_Map); - while C /= No_Element loop - Append (Res, Key (C) & " => " & Types.To_String (Types.Deref (Element (C)).all) & ", "); - C := Next (C); - end loop; - return To_String (Res); - end To_String; - - - -- Sym and Exprs are lists. Bind Sets Keys in Syms to the corresponding - -- expression in Exprs. Returns true if all the parameters were bound. - function Bind (Env : Env_Handle; Syms, Exprs : Types.List_Mal_Type) - return Boolean is - use Types; - S, Expr : List_Mal_Type; - First_Sym : Sym_Ptr; - begin - S := Syms; - Expr := Exprs; - while not Is_Null (S) loop - - First_Sym := Deref_Sym (Car (S)); - - if First_Sym.Get_Sym = "&" then - S := Deref_List (Cdr (S)).all; - First_Sym := Deref_Sym (Car (S)); - Set (Env, First_Sym.Get_Sym, New_List_Mal_Type (Expr)); - return True; - end if; - - Set (Env, First_Sym.Get_Sym, Car (Expr)); - S := Deref_List (Cdr (S)).all; - exit when Is_Null (Expr); - Expr := Deref_List (Cdr (Expr)).all; - - end loop; - return Is_Null (S); - end Bind; - - - function Deref (SP : Env_Handle) return Env_Ptr is - begin - return Env_Ptr (Smart_Pointers.Deref (Smart_Pointers.Smart_Pointer (SP))); - end Deref; - - -end Envs; +with Ada.Text_IO; +with Types; +with Unchecked_Deallocation; + +package body Envs is + + + function Is_Null (E : Env_Handle) return Boolean is + use Smart_Pointers; + begin + return E = Null_Env_Handle; + end Is_Null; + + + function New_Env (Outer : Env_Handle := Null_Env_Handle) return Env_Handle is + use Smart_Pointers; + Level : Natural; + begin + if Is_Null (Outer) then + Level := 0; + else + Level := Deref (Outer).Level + 1; + end if; + if Debug then + Ada.Text_IO.Put_Line + ("Envs: Creating at level " & Natural'Image (Level)); + end if; + return Env_Handle (Smart_Pointers.New_Ptr (new Env' + (Base_Class with The_Map => String_Mal_Hash.Empty_Map, + Outer_Env => Outer, + Level => Level))); + end New_Env; + + + procedure Set + (E : Env_Handle; + Key : String; + Elem : Smart_Pointers.Smart_Pointer) is + begin + if Debug then + Ada.Text_IO.Put_Line + ("Envs: Setting " & Key & + " to " & Types.Deref (Elem).To_String & + " at level " & Natural'Image (Deref (E).Level)); + end if; + String_Mal_Hash.Include + (Container => Deref (E).The_Map, + Key => Ada.Strings.Unbounded.To_Unbounded_String (Key), + New_Item => Elem); + end Set; + + + function Get (E : Env_Handle; Key: String) + return Smart_Pointers.Smart_Pointer is + + use String_Mal_Hash; + C : Cursor; + + begin + + if Debug then + Ada.Text_IO.Put_Line + ("Envs: Finding " & Key & + " at level " & Natural'Image (Deref (E).Level)); + end if; + + C := Find (Deref (E).The_Map, + Ada.Strings.Unbounded.To_Unbounded_String (Key)); + + if C = No_Element then + + if Is_Null (Deref (E).Outer_Env) then + raise Not_Found; + else + return Get (Deref (E).Outer_Env, Key); + end if; + + else + return Element (C); + end if; + + end Get; + + + procedure Set_Outer + (E : Env_Handle; Outer_Env : Env_Handle) is + begin + -- Attempt to avoid making loops. + if Deref (E).Level /= 0 then + Deref (E).Outer_Env := Outer_Env; + end if; + end Set_Outer; + + + function To_String (E : Env_Handle) return String is + use String_Mal_Hash, Ada.Strings.Unbounded; + C : Cursor; + Res : Unbounded_String; + begin + C := First (Deref (E).The_Map); + while C /= No_Element loop + Append (Res, Key (C) & " => " & Types.To_String (Types.Deref (Element (C)).all) & ", "); + C := Next (C); + end loop; + return To_String (Res); + end To_String; + + + -- Sym and Exprs are lists. Bind Sets Keys in Syms to the corresponding + -- expression in Exprs. Returns true if all the parameters were bound. + function Bind (Env : Env_Handle; Syms, Exprs : Types.List_Mal_Type) + return Boolean is + use Types; + S, Expr : List_Mal_Type; + First_Sym : Sym_Ptr; + begin + S := Syms; + Expr := Exprs; + while not Is_Null (S) loop + + First_Sym := Deref_Sym (Car (S)); + + if First_Sym.Get_Sym = "&" then + S := Deref_List (Cdr (S)).all; + First_Sym := Deref_Sym (Car (S)); + Set (Env, First_Sym.Get_Sym, New_List_Mal_Type (Expr)); + return True; + end if; + + Set (Env, First_Sym.Get_Sym, Car (Expr)); + S := Deref_List (Cdr (S)).all; + exit when Is_Null (Expr); + Expr := Deref_List (Cdr (Expr)).all; + + end loop; + return Is_Null (S); + end Bind; + + + function Deref (SP : Env_Handle) return Env_Ptr is + begin + return Env_Ptr (Smart_Pointers.Deref (Smart_Pointers.Smart_Pointer (SP))); + end Deref; + + +end Envs; diff --git a/impls/ada/envs.ads b/impls/ada/envs.ads index ce0f1f21fa..b3dbe7423d 100644 --- a/impls/ada/envs.ads +++ b/impls/ada/envs.ads @@ -1,64 +1,64 @@ -with Ada.Containers.Hashed_Maps; -with Ada.Strings.Unbounded.Hash; -with Smart_Pointers; -limited with Types; - -package Envs is - - type Env_Handle is private; - - Null_Env_Handle : constant Env_Handle; - - function New_Env (Outer : Env_Handle := Null_Env_Handle) return Env_Handle; - - -- Set adds an element to the environment E. - procedure Set - (E : Env_Handle; - Key : String; - Elem : Smart_Pointers.Smart_Pointer); - - -- Get finds a key in the E env. If it can't be found it looks - -- in an outer env. If it runs out of envs, Not Found is raised. - function Get (E : Env_Handle; Key : String) return Smart_Pointers.Smart_Pointer; - - Not_Found : exception; - - procedure Set_Outer - (E : Env_Handle; Outer_Env : Env_Handle); - - -- Sym and Exprs are lists. Bind Sets Keys in Syms to the corresponding - -- expression in Exprs. Returns true if all the parameters were bound. - function Bind (Env : Env_Handle; Syms, Exprs : Types.List_Mal_Type) - return Boolean; - - function To_String (E : Env_Handle) return String; - - Debug : Boolean := False; - -private - - type Env_Handle is new Smart_Pointers.Smart_Pointer; - - Null_Env_Handle : constant Env_Handle := - Env_Handle (Smart_Pointers.Null_Smart_Pointer); - - function Is_Null (E : Env_Handle) return Boolean; - - package String_Mal_Hash is new Ada.Containers.Hashed_Maps - (Key_Type => Ada.Strings.Unbounded.Unbounded_String, - Element_Type => Smart_Pointers.Smart_Pointer, - Hash => Ada.Strings.Unbounded.Hash, - Equivalent_Keys => Ada.Strings.Unbounded."=", - "=" => Smart_Pointers."="); - - type Env is new Smart_Pointers.Base_Class with record - The_Map : String_Mal_Hash.Map; - Outer_Env : Env_Handle; - Level: Natural; - end record; - - type Env_Ptr is access all Env; - - function Deref (SP : Env_Handle) return Env_Ptr; - -end Envs; +with Ada.Containers.Hashed_Maps; +with Ada.Strings.Unbounded.Hash; +with Smart_Pointers; +limited with Types; + +package Envs is + + type Env_Handle is private; + + Null_Env_Handle : constant Env_Handle; + + function New_Env (Outer : Env_Handle := Null_Env_Handle) return Env_Handle; + + -- Set adds an element to the environment E. + procedure Set + (E : Env_Handle; + Key : String; + Elem : Smart_Pointers.Smart_Pointer); + + -- Get finds a key in the E env. If it can't be found it looks + -- in an outer env. If it runs out of envs, Not Found is raised. + function Get (E : Env_Handle; Key : String) return Smart_Pointers.Smart_Pointer; + + Not_Found : exception; + + procedure Set_Outer + (E : Env_Handle; Outer_Env : Env_Handle); + + -- Sym and Exprs are lists. Bind Sets Keys in Syms to the corresponding + -- expression in Exprs. Returns true if all the parameters were bound. + function Bind (Env : Env_Handle; Syms, Exprs : Types.List_Mal_Type) + return Boolean; + + function To_String (E : Env_Handle) return String; + + Debug : Boolean := False; + +private + + type Env_Handle is new Smart_Pointers.Smart_Pointer; + + Null_Env_Handle : constant Env_Handle := + Env_Handle (Smart_Pointers.Null_Smart_Pointer); + + function Is_Null (E : Env_Handle) return Boolean; + + package String_Mal_Hash is new Ada.Containers.Hashed_Maps + (Key_Type => Ada.Strings.Unbounded.Unbounded_String, + Element_Type => Smart_Pointers.Smart_Pointer, + Hash => Ada.Strings.Unbounded.Hash, + Equivalent_Keys => Ada.Strings.Unbounded."=", + "=" => Smart_Pointers."="); + + type Env is new Smart_Pointers.Base_Class with record + The_Map : String_Mal_Hash.Map; + Outer_Env : Env_Handle; + Level: Natural; + end record; + + type Env_Ptr is access all Env; + + function Deref (SP : Env_Handle) return Env_Ptr; + +end Envs; diff --git a/impls/ada/eval_callback.ads b/impls/ada/eval_callback.ads index ea422996b3..2c42785f4a 100644 --- a/impls/ada/eval_callback.ads +++ b/impls/ada/eval_callback.ads @@ -1,11 +1,11 @@ -with Envs; -with Types; - -package Eval_Callback is - - type Eval_Func is access - function (MH : Types.Mal_Handle; Env : Envs.Env_Handle) return Types.Mal_Handle; - - Eval : Eval_Func; - -end Eval_Callback; +with Envs; +with Types; + +package Eval_Callback is + + type Eval_Func is access + function (MH : Types.Mal_Handle; Env : Envs.Env_Handle) return Types.Mal_Handle; + + Eval : Eval_Func; + +end Eval_Callback; diff --git a/impls/ada/printer.adb b/impls/ada/printer.adb index 67d139bb9e..6f2cb43fdb 100644 --- a/impls/ada/printer.adb +++ b/impls/ada/printer.adb @@ -1,12 +1,12 @@ -package body Printer is - - function Pr_Str (M : Types.Mal_Handle) return String is - begin - if Types.Is_Null (M) then - return ""; - else - return Types.To_String (Types.Deref (M).all); - end if; - end Pr_Str; - -end Printer; +package body Printer is + + function Pr_Str (M : Types.Mal_Handle) return String is + begin + if Types.Is_Null (M) then + return ""; + else + return Types.To_String (Types.Deref (M).all); + end if; + end Pr_Str; + +end Printer; diff --git a/impls/ada/printer.ads b/impls/ada/printer.ads index 8e9fc671a0..425cbe9298 100644 --- a/impls/ada/printer.ads +++ b/impls/ada/printer.ads @@ -1,7 +1,7 @@ -with Types; - -package Printer is - - function Pr_Str (M : Types.Mal_Handle) return String; - -end Printer; +with Types; + +package Printer is + + function Pr_Str (M : Types.Mal_Handle) return String; + +end Printer; diff --git a/impls/ada/reader.adb b/impls/ada/reader.adb index 94ecc4ac70..0d7e632a9d 100644 --- a/impls/ada/reader.adb +++ b/impls/ada/reader.adb @@ -1,390 +1,390 @@ -with Ada.IO_Exceptions; -with Ada.Characters.Latin_1; -with Ada.Exceptions; -with Ada.Strings.Maps.Constants; -with Ada.Strings.Unbounded; -with Ada.Text_IO; -with Smart_Pointers; -with Types.Vector; -with Types.Hash_Map; - -package body Reader is - - use Types; - - package ACL renames Ada.Characters.Latin_1; - - type Lexemes is (Ignored_Tok, - Start_List_Tok, Start_Vector_Tok, Start_Hash_Tok, - Meta_Tok, Deref_Tok, - Quote_Tok, Quasi_Quote_Tok, Splice_Unq_Tok, Unquote_Tok, - Int_Tok, Float_Tok, - Str_Tok, Sym_Tok); - - type Token (ID : Lexemes := Ignored_Tok) is record - case ID is - when Int_Tok => - Int_Val : Mal_Integer; - when Float_Tok => - Float_Val : Mal_Float; - when Str_Tok | Sym_Tok => - Start_Char, Stop_Char : Natural; - when others => null; - end case; - end record; - - Lisp_Whitespace : constant Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps.To_Set - (ACL.HT & ACL.LF & ACL.CR & ACL.Space & ACL.Comma); - - -- [^\s\[\]{}('"`,;)] - Terminator_Syms : Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps."or" - (Lisp_Whitespace, - Ada.Strings.Maps.To_Set ("[]{}('""`,;)")); - - -- The unterminated string error - String_Error : exception; - - - function Convert_String (S : String) return String is - use Ada.Strings.Unbounded; - Res : Unbounded_String; - I : Positive; - Str_Last : Natural; - begin - Str_Last := S'Last; - I := S'First; - while I <= Str_Last loop - if S (I) = '\' then - if I+1 > Str_Last then - Append (Res, S (I)); - I := I + 1; - elsif S (I+1) = 'n' then - Append (Res, Ada.Characters.Latin_1.LF); - I := I + 2; - elsif S (I+1) = '"' then - Append (Res, S (I+1)); - I := I + 2; - elsif S (I+1) = '\' then - Append (Res, S (I+1)); - I := I + 2; - else - Append (Res, S (I)); - I := I + 1; - end if; - else - Append (Res, S (I)); - I := I + 1; - end if; - end loop; - return To_String (Res); - end Convert_String; - - Str_Len : Natural := 0; - Saved_Line : Ada.Strings.Unbounded.Unbounded_String; - Char_To_Read : Natural := 1; - - function Get_Token return Token is - Res : Token; - I, J : Natural; - use Ada.Strings.Unbounded; - begin - - <> - - -- Skip over whitespace... - I := Char_To_Read; - while I <= Str_Len and then - Ada.Strings.Maps.Is_In (Element (Saved_Line, I), Lisp_Whitespace) loop - I := I + 1; - end loop; - - -- Filter out lines consisting of only whitespace - if I > Str_Len then - return (ID => Ignored_Tok); - end if; - - J := I; - - case Element (Saved_Line, J) is - - when ''' => Res := (ID => Quote_Tok); Char_To_Read := J+1; - - when '`' => Res := (ID => Quasi_Quote_Tok); Char_To_Read := J+1; - - when '~' => -- Tilde - - if J+1 <= Str_Len and then Element (Saved_Line, J+1) = '@' then - Res := (ID => Splice_Unq_Tok); - Char_To_Read := J+2; - else - -- Just a Tilde - Res := (ID => Unquote_Tok); - Char_To_Read := J+1; - end if; - - when '(' => Res := (ID => Start_List_Tok); Char_To_Read := J+1; - when '[' => Res := (ID => Start_Vector_Tok); Char_To_Read := J+1; - when '{' => Res := (ID => Start_Hash_Tok); Char_To_Read := J+1; - - when '^' => Res := (ID => Meta_Tok); Char_To_Read := J+1; - when '@' => Res := (ID => Deref_Tok); Char_To_Read := J+1; - - when ']' | '}' | ')' => - - Res := (ID => Sym_Tok, Start_Char => J, Stop_Char => J); - Char_To_Read := J+1; - - when '"' => -- a string - - loop - if Str_Len <= J then - raise String_Error; - end if; - J := J + 1; - exit when Element (Saved_Line, J) = '"'; - if Element (Saved_Line, J) = '\' then - J := J + 1; - end if; - end loop; - - Res := (ID => Str_Tok, Start_Char => I, Stop_Char => J); - Char_To_Read := J + 1; - - when ';' => -- a comment - - -- Read to the end of the line or until - -- the saved_line string is exhausted. - -- NB if we reach the end we don't care - -- what the last char was. - while J < Str_Len and Element (Saved_Line, J) /= ACL.LF loop - J := J + 1; - end loop; - if J = Str_Len then - Res := (ID => Ignored_Tok); - else - Char_To_Read := J + 1; - -- was: Res := Get_Token; - goto Tail_Call_Opt; - end if; - - when others => -- an atom - - while J <= Str_Len and then - not Ada.Strings.Maps.Is_In (Element (Saved_Line, J), Terminator_Syms) loop - J := J + 1; - end loop; - - -- Either we ran out of string or - -- the one at J was the start of a new token - Char_To_Read := J; - J := J - 1; - - declare - Dots : Natural; - All_Digits : Boolean; - begin - -- check if all digits or . - Dots := 0; - All_Digits := True; - for K in I .. J loop - if (K = I and K /= J) and then Element (Saved_Line, K) = '-' then - null; - elsif Element (Saved_Line, K) = '.' then - Dots := Dots + 1; - elsif not (Element (Saved_Line, K) in '0' .. '9') then - All_Digits := False; - exit; - end if; - end loop; - - if All_Digits then - if Dots = 0 then - Res := - (ID => Int_Tok, - Int_Val => Mal_Integer'Value (Slice (Saved_Line, I, J))); - elsif Dots = 1 then - Res := - (ID => Float_Tok, - Float_Val => Mal_Float'Value (Slice (Saved_Line, I, J))); - else - Res := (ID => Sym_Tok, Start_Char => I, Stop_Char => J); - end if; - else - Res := (ID => Sym_Tok, Start_Char => I, Stop_Char => J); - end if; - - end; - - end case; - - return Res; - - end Get_Token; - - - function Read_List (LT : Types.List_Types) - return Types.Mal_Handle is - - MTA : Mal_Handle; - - begin - - MTA := Read_Form; - - declare - List_SP : Mal_Handle; - List_P : List_Class_Ptr; - Close : String (1..1) := (1 => Types.Closing (LT)); - begin - - case LT is - when List_List => List_SP := New_List_Mal_Type (List_Type => LT); - when Vector_List => List_SP := Vector.New_Vector_Mal_Type; - when Hashed_List => List_SP := Hash_Map.New_Hash_Map_Mal_Type; - end case; - - -- Need to append to a variable so... - List_P := Deref_List_Class (List_SP); - - loop - - if Is_Null (MTA) then - return New_Error_Mal_Type (Str => "expected '" & Close & "', got EOF"); - end if; - - exit when Deref (MTA).Sym_Type = Sym and then - Symbol_Mal_Type (Deref (MTA).all).Get_Sym = Close; - - Append (List_P.all, MTA); - - MTA := Read_Form; - - end loop; - - return List_SP; - - end; - - end Read_List; - - - function Read_Form return Types.Mal_Handle is - Tok : Token; - MTS : Mal_Handle; - use Ada.Strings.Unbounded; - begin - - Tok := Get_Token; - - case Tok.ID is - - when Ignored_Tok => return Smart_Pointers.Null_Smart_Pointer; - - when Int_Tok => return New_Int_Mal_Type (Tok.Int_Val); - - when Float_Tok => return New_Float_Mal_Type (Tok.Float_Val); - - when Start_List_Tok => return Read_List (List_List); - - when Start_Vector_Tok => return Read_List (Vector_List); - - when Start_Hash_Tok => return Read_List (Hashed_List); - - when Meta_Tok => - - declare - Meta, Obj : Mal_Handle; - begin - Meta := Read_Form; - Obj := Read_Form; - return Make_New_List - ((1 => New_Symbol_Mal_Type ("with-meta"), - 2 => Obj, - 3 => Meta)); - end; - - when Deref_Tok => - - return Make_New_List - ((1 => New_Symbol_Mal_Type ("deref"), - 2 => Read_Form)); - - when Quote_Tok => - - return Make_New_List - ((1 => New_Symbol_Mal_Type ("quote"), - 2 => Read_Form)); - - when Quasi_Quote_Tok => - - return Make_New_List - ((1 => New_Symbol_Mal_Type ("quasiquote"), - 2 => Read_Form)); - - when Splice_Unq_Tok => - - return Make_New_List - ((1 => New_Symbol_Mal_Type ("splice-unquote"), - 2 => Read_Form)); - - when Unquote_Tok => - - return Make_New_List - ((1 => New_Symbol_Mal_Type ("unquote"), - 2 => Read_Form)); - - when Str_Tok => - - -- +/-1 strips out the double quotes. - -- Convert_String converts backquoted charaters to raw format. - return New_String_Mal_Type - (Convert_String - (Slice (Saved_Line, Tok.Start_Char + 1, Tok.Stop_Char - 1))); - - when Sym_Tok => - - -- Mal interpreter is required to know about true, false and nil. - declare - S : String := Slice (Saved_Line, Tok.Start_Char, Tok.Stop_Char); - begin - if S = "true" then - return New_Bool_Mal_Type (True); - elsif S = "false" then - return New_Bool_Mal_Type (False); - elsif S = "nil" then - return New_Nil_Mal_Type; - else - return New_Symbol_Mal_Type (S); - end if; - end; - - end case; - - end Read_Form; - - - procedure Lex_Init (S : String) is - begin - Str_Len := S'Length; - Saved_Line := Ada.Strings.Unbounded.To_Unbounded_String (S); - Char_To_Read := 1; - end Lex_Init; - - - function Read_Str (S : String) return Types.Mal_Handle is - I, Str_Len : Natural := S'Length; - begin - - Lex_Init (S); - - return Read_Form; - - exception - when String_Error => - return New_Error_Mal_Type (Str => "expected '""', got EOF"); - end Read_Str; - - -end Reader; +with Ada.IO_Exceptions; +with Ada.Characters.Latin_1; +with Ada.Exceptions; +with Ada.Strings.Maps.Constants; +with Ada.Strings.Unbounded; +with Ada.Text_IO; +with Smart_Pointers; +with Types.Vector; +with Types.Hash_Map; + +package body Reader is + + use Types; + + package ACL renames Ada.Characters.Latin_1; + + type Lexemes is (Ignored_Tok, + Start_List_Tok, Start_Vector_Tok, Start_Hash_Tok, + Meta_Tok, Deref_Tok, + Quote_Tok, Quasi_Quote_Tok, Splice_Unq_Tok, Unquote_Tok, + Int_Tok, Float_Tok, + Str_Tok, Sym_Tok); + + type Token (ID : Lexemes := Ignored_Tok) is record + case ID is + when Int_Tok => + Int_Val : Mal_Integer; + when Float_Tok => + Float_Val : Mal_Float; + when Str_Tok | Sym_Tok => + Start_Char, Stop_Char : Natural; + when others => null; + end case; + end record; + + Lisp_Whitespace : constant Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set + (ACL.HT & ACL.LF & ACL.CR & ACL.Space & ACL.Comma); + + -- [^\s\[\]{}('"`,;)] + Terminator_Syms : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps."or" + (Lisp_Whitespace, + Ada.Strings.Maps.To_Set ("[]{}('""`,;)")); + + -- The unterminated string error + String_Error : exception; + + + function Convert_String (S : String) return String is + use Ada.Strings.Unbounded; + Res : Unbounded_String; + I : Positive; + Str_Last : Natural; + begin + Str_Last := S'Last; + I := S'First; + while I <= Str_Last loop + if S (I) = '\' then + if I+1 > Str_Last then + Append (Res, S (I)); + I := I + 1; + elsif S (I+1) = 'n' then + Append (Res, Ada.Characters.Latin_1.LF); + I := I + 2; + elsif S (I+1) = '"' then + Append (Res, S (I+1)); + I := I + 2; + elsif S (I+1) = '\' then + Append (Res, S (I+1)); + I := I + 2; + else + Append (Res, S (I)); + I := I + 1; + end if; + else + Append (Res, S (I)); + I := I + 1; + end if; + end loop; + return To_String (Res); + end Convert_String; + + Str_Len : Natural := 0; + Saved_Line : Ada.Strings.Unbounded.Unbounded_String; + Char_To_Read : Natural := 1; + + function Get_Token return Token is + Res : Token; + I, J : Natural; + use Ada.Strings.Unbounded; + begin + + <> + + -- Skip over whitespace... + I := Char_To_Read; + while I <= Str_Len and then + Ada.Strings.Maps.Is_In (Element (Saved_Line, I), Lisp_Whitespace) loop + I := I + 1; + end loop; + + -- Filter out lines consisting of only whitespace + if I > Str_Len then + return (ID => Ignored_Tok); + end if; + + J := I; + + case Element (Saved_Line, J) is + + when ''' => Res := (ID => Quote_Tok); Char_To_Read := J+1; + + when '`' => Res := (ID => Quasi_Quote_Tok); Char_To_Read := J+1; + + when '~' => -- Tilde + + if J+1 <= Str_Len and then Element (Saved_Line, J+1) = '@' then + Res := (ID => Splice_Unq_Tok); + Char_To_Read := J+2; + else + -- Just a Tilde + Res := (ID => Unquote_Tok); + Char_To_Read := J+1; + end if; + + when '(' => Res := (ID => Start_List_Tok); Char_To_Read := J+1; + when '[' => Res := (ID => Start_Vector_Tok); Char_To_Read := J+1; + when '{' => Res := (ID => Start_Hash_Tok); Char_To_Read := J+1; + + when '^' => Res := (ID => Meta_Tok); Char_To_Read := J+1; + when '@' => Res := (ID => Deref_Tok); Char_To_Read := J+1; + + when ']' | '}' | ')' => + + Res := (ID => Sym_Tok, Start_Char => J, Stop_Char => J); + Char_To_Read := J+1; + + when '"' => -- a string + + loop + if Str_Len <= J then + raise String_Error; + end if; + J := J + 1; + exit when Element (Saved_Line, J) = '"'; + if Element (Saved_Line, J) = '\' then + J := J + 1; + end if; + end loop; + + Res := (ID => Str_Tok, Start_Char => I, Stop_Char => J); + Char_To_Read := J + 1; + + when ';' => -- a comment + + -- Read to the end of the line or until + -- the saved_line string is exhausted. + -- NB if we reach the end we don't care + -- what the last char was. + while J < Str_Len and Element (Saved_Line, J) /= ACL.LF loop + J := J + 1; + end loop; + if J = Str_Len then + Res := (ID => Ignored_Tok); + else + Char_To_Read := J + 1; + -- was: Res := Get_Token; + goto Tail_Call_Opt; + end if; + + when others => -- an atom + + while J <= Str_Len and then + not Ada.Strings.Maps.Is_In (Element (Saved_Line, J), Terminator_Syms) loop + J := J + 1; + end loop; + + -- Either we ran out of string or + -- the one at J was the start of a new token + Char_To_Read := J; + J := J - 1; + + declare + Dots : Natural; + All_Digits : Boolean; + begin + -- check if all digits or . + Dots := 0; + All_Digits := True; + for K in I .. J loop + if (K = I and K /= J) and then Element (Saved_Line, K) = '-' then + null; + elsif Element (Saved_Line, K) = '.' then + Dots := Dots + 1; + elsif not (Element (Saved_Line, K) in '0' .. '9') then + All_Digits := False; + exit; + end if; + end loop; + + if All_Digits then + if Dots = 0 then + Res := + (ID => Int_Tok, + Int_Val => Mal_Integer'Value (Slice (Saved_Line, I, J))); + elsif Dots = 1 then + Res := + (ID => Float_Tok, + Float_Val => Mal_Float'Value (Slice (Saved_Line, I, J))); + else + Res := (ID => Sym_Tok, Start_Char => I, Stop_Char => J); + end if; + else + Res := (ID => Sym_Tok, Start_Char => I, Stop_Char => J); + end if; + + end; + + end case; + + return Res; + + end Get_Token; + + + function Read_List (LT : Types.List_Types) + return Types.Mal_Handle is + + MTA : Mal_Handle; + + begin + + MTA := Read_Form; + + declare + List_SP : Mal_Handle; + List_P : List_Class_Ptr; + Close : String (1..1) := (1 => Types.Closing (LT)); + begin + + case LT is + when List_List => List_SP := New_List_Mal_Type (List_Type => LT); + when Vector_List => List_SP := Vector.New_Vector_Mal_Type; + when Hashed_List => List_SP := Hash_Map.New_Hash_Map_Mal_Type; + end case; + + -- Need to append to a variable so... + List_P := Deref_List_Class (List_SP); + + loop + + if Is_Null (MTA) then + return New_Error_Mal_Type (Str => "expected '" & Close & "', got EOF"); + end if; + + exit when Deref (MTA).Sym_Type = Sym and then + Symbol_Mal_Type (Deref (MTA).all).Get_Sym = Close; + + Append (List_P.all, MTA); + + MTA := Read_Form; + + end loop; + + return List_SP; + + end; + + end Read_List; + + + function Read_Form return Types.Mal_Handle is + Tok : Token; + MTS : Mal_Handle; + use Ada.Strings.Unbounded; + begin + + Tok := Get_Token; + + case Tok.ID is + + when Ignored_Tok => return Smart_Pointers.Null_Smart_Pointer; + + when Int_Tok => return New_Int_Mal_Type (Tok.Int_Val); + + when Float_Tok => return New_Float_Mal_Type (Tok.Float_Val); + + when Start_List_Tok => return Read_List (List_List); + + when Start_Vector_Tok => return Read_List (Vector_List); + + when Start_Hash_Tok => return Read_List (Hashed_List); + + when Meta_Tok => + + declare + Meta, Obj : Mal_Handle; + begin + Meta := Read_Form; + Obj := Read_Form; + return Make_New_List + ((1 => New_Symbol_Mal_Type ("with-meta"), + 2 => Obj, + 3 => Meta)); + end; + + when Deref_Tok => + + return Make_New_List + ((1 => New_Symbol_Mal_Type ("deref"), + 2 => Read_Form)); + + when Quote_Tok => + + return Make_New_List + ((1 => New_Symbol_Mal_Type ("quote"), + 2 => Read_Form)); + + when Quasi_Quote_Tok => + + return Make_New_List + ((1 => New_Symbol_Mal_Type ("quasiquote"), + 2 => Read_Form)); + + when Splice_Unq_Tok => + + return Make_New_List + ((1 => New_Symbol_Mal_Type ("splice-unquote"), + 2 => Read_Form)); + + when Unquote_Tok => + + return Make_New_List + ((1 => New_Symbol_Mal_Type ("unquote"), + 2 => Read_Form)); + + when Str_Tok => + + -- +/-1 strips out the double quotes. + -- Convert_String converts backquoted charaters to raw format. + return New_String_Mal_Type + (Convert_String + (Slice (Saved_Line, Tok.Start_Char + 1, Tok.Stop_Char - 1))); + + when Sym_Tok => + + -- Mal interpreter is required to know about true, false and nil. + declare + S : String := Slice (Saved_Line, Tok.Start_Char, Tok.Stop_Char); + begin + if S = "true" then + return New_Bool_Mal_Type (True); + elsif S = "false" then + return New_Bool_Mal_Type (False); + elsif S = "nil" then + return New_Nil_Mal_Type; + else + return New_Symbol_Mal_Type (S); + end if; + end; + + end case; + + end Read_Form; + + + procedure Lex_Init (S : String) is + begin + Str_Len := S'Length; + Saved_Line := Ada.Strings.Unbounded.To_Unbounded_String (S); + Char_To_Read := 1; + end Lex_Init; + + + function Read_Str (S : String) return Types.Mal_Handle is + I, Str_Len : Natural := S'Length; + begin + + Lex_Init (S); + + return Read_Form; + + exception + when String_Error => + return New_Error_Mal_Type (Str => "expected '""', got EOF"); + end Read_Str; + + +end Reader; diff --git a/impls/ada/reader.ads b/impls/ada/reader.ads index 402b3aabbe..114bab159f 100644 --- a/impls/ada/reader.ads +++ b/impls/ada/reader.ads @@ -1,14 +1,14 @@ -with Types; - -package Reader is - - -- This is the Parser (returns an AST) - function Read_Str (S : String) return Types.Mal_Handle; - -private - - procedure Lex_Init (S : String); - - function Read_Form return Types.Mal_Handle; - -end Reader; +with Types; + +package Reader is + + -- This is the Parser (returns an AST) + function Read_Str (S : String) return Types.Mal_Handle; + +private + + procedure Lex_Init (S : String); + + function Read_Form return Types.Mal_Handle; + +end Reader; diff --git a/impls/ada/run b/impls/ada/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/ada/run +++ b/impls/ada/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/ada/smart_pointers.adb b/impls/ada/smart_pointers.adb index 37c7b67723..c7e3a8fc26 100644 --- a/impls/ada/smart_pointers.adb +++ b/impls/ada/smart_pointers.adb @@ -1,49 +1,49 @@ -with Ada.Unchecked_Deallocation; - -package body Smart_Pointers is - - - function New_Ptr (Base_Class : Base_Class_Accessor) return Smart_Pointer is - begin - return Smart_Pointer' - (Ada.Finalization.Controlled with Pointer => Base_Class); - end New_Ptr; - - - function Deref (Ptr : Smart_Pointer) return Base_Class_Accessor is - begin - return Ptr.Pointer; - end Deref; - - - overriding procedure Adjust (Object : in out Smart_Pointer) is - begin - if Object.Pointer /= null then - Object.Pointer.Ref_Count := Object.Pointer.Ref_Count + 1; - end if; - end Adjust; - - - procedure Free is - new Ada.Unchecked_Deallocation (Base_Class'Class, Base_Class_Accessor); - - overriding procedure Finalize (Object : in out Smart_Pointer) is - begin - if Object.Pointer /= null then - if Object.Pointer.Ref_Count > 0 then - Object.Pointer.Ref_Count := Object.Pointer.Ref_Count - 1; - if Object.Pointer.Ref_Count = 0 then - Free (Object.Pointer); - end if; - end if; - end if; - end Finalize; - - - function Is_Null (Ptr : Smart_Pointer) return Boolean is - begin - return Ptr = Null_Smart_Pointer; - end Is_Null; - - -end Smart_Pointers; +with Ada.Unchecked_Deallocation; + +package body Smart_Pointers is + + + function New_Ptr (Base_Class : Base_Class_Accessor) return Smart_Pointer is + begin + return Smart_Pointer' + (Ada.Finalization.Controlled with Pointer => Base_Class); + end New_Ptr; + + + function Deref (Ptr : Smart_Pointer) return Base_Class_Accessor is + begin + return Ptr.Pointer; + end Deref; + + + overriding procedure Adjust (Object : in out Smart_Pointer) is + begin + if Object.Pointer /= null then + Object.Pointer.Ref_Count := Object.Pointer.Ref_Count + 1; + end if; + end Adjust; + + + procedure Free is + new Ada.Unchecked_Deallocation (Base_Class'Class, Base_Class_Accessor); + + overriding procedure Finalize (Object : in out Smart_Pointer) is + begin + if Object.Pointer /= null then + if Object.Pointer.Ref_Count > 0 then + Object.Pointer.Ref_Count := Object.Pointer.Ref_Count - 1; + if Object.Pointer.Ref_Count = 0 then + Free (Object.Pointer); + end if; + end if; + end if; + end Finalize; + + + function Is_Null (Ptr : Smart_Pointer) return Boolean is + begin + return Ptr = Null_Smart_Pointer; + end Is_Null; + + +end Smart_Pointers; diff --git a/impls/ada/smart_pointers.ads b/impls/ada/smart_pointers.ads index 837461bf92..0ae36bc466 100644 --- a/impls/ada/smart_pointers.ads +++ b/impls/ada/smart_pointers.ads @@ -1,39 +1,39 @@ -with Ada.Finalization; - -package Smart_Pointers is - - -- Classes we want to track derrive from Base Class. - type Base_Class is abstract tagged private; - - type Base_Class_Accessor is access Base_Class'Class; - - - type Smart_Pointer is private; - - function New_Ptr (Base_Class : Base_Class_Accessor) return Smart_Pointer; - - function Deref (Ptr : Smart_Pointer) return Base_Class_Accessor; - - Null_Smart_Pointer : constant Smart_Pointer; - - function Is_Null (Ptr : Smart_Pointer) return Boolean; - -private - - type Base_Class is abstract tagged record - Ref_Count : Natural := 1; - end record; - - - type Smart_Pointer is new Ada.Finalization.Controlled with record - Pointer : Base_Class_Accessor; - end record; - - overriding procedure Adjust (Object : in out Smart_Pointer); - - overriding procedure Finalize (Object : in out Smart_Pointer); - - Null_Smart_Pointer : constant Smart_Pointer := - (Ada.Finalization.Controlled with Pointer => null); - -end Smart_Pointers; +with Ada.Finalization; + +package Smart_Pointers is + + -- Classes we want to track derrive from Base Class. + type Base_Class is abstract tagged private; + + type Base_Class_Accessor is access Base_Class'Class; + + + type Smart_Pointer is private; + + function New_Ptr (Base_Class : Base_Class_Accessor) return Smart_Pointer; + + function Deref (Ptr : Smart_Pointer) return Base_Class_Accessor; + + Null_Smart_Pointer : constant Smart_Pointer; + + function Is_Null (Ptr : Smart_Pointer) return Boolean; + +private + + type Base_Class is abstract tagged record + Ref_Count : Natural := 1; + end record; + + + type Smart_Pointer is new Ada.Finalization.Controlled with record + Pointer : Base_Class_Accessor; + end record; + + overriding procedure Adjust (Object : in out Smart_Pointer); + + overriding procedure Finalize (Object : in out Smart_Pointer); + + Null_Smart_Pointer : constant Smart_Pointer := + (Ada.Finalization.Controlled with Pointer => null); + +end Smart_Pointers; diff --git a/impls/ada/step0_repl.adb b/impls/ada/step0_repl.adb index 456b8a302e..a7121d2f89 100644 --- a/impls/ada/step0_repl.adb +++ b/impls/ada/step0_repl.adb @@ -1,34 +1,34 @@ -with Ada.Text_IO; - -procedure Step0_Repl is - - function Read (Param : String) return String is - begin - return Param; - end Read; - - function Eval (Param : String) return String is - begin - return Param; - end Eval; - - function Print (Param : String) return String is - begin - return Param; - end Print; - - function Rep (Param : String) return String is - Read_Str : String := Read (Param); - Eval_Str : String := Eval (Read_Str); - Print_Str : String := Print (Eval_Str); - begin - return Print_Str; - end Rep; - -begin - loop - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line)); - end loop; -end Step0_Repl; +with Ada.Text_IO; + +procedure Step0_Repl is + + function Read (Param : String) return String is + begin + return Param; + end Read; + + function Eval (Param : String) return String is + begin + return Param; + end Eval; + + function Print (Param : String) return String is + begin + return Param; + end Print; + + function Rep (Param : String) return String is + Read_Str : String := Read (Param); + Eval_Str : String := Eval (Read_Str); + Print_Str : String := Print (Eval_Str); + begin + return Print_Str; + end Rep; + +begin + loop + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line)); + end loop; +end Step0_Repl; diff --git a/impls/ada/step1_read_print.adb b/impls/ada/step1_read_print.adb index 4969ad34c3..b46db5b13c 100644 --- a/impls/ada/step1_read_print.adb +++ b/impls/ada/step1_read_print.adb @@ -1,44 +1,44 @@ -with Ada.Text_IO; -with Printer; -with Reader; -with Types; - -procedure Step1_Read_Print is - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - function Eval (Param : Types.Mal_Handle) return Types.Mal_Handle is - begin - return Param; - end Eval; - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - function Rep (Param : String) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST); - return Print (Evaluated_AST); - end if; - - end Rep; - -begin - loop - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line)); - end loop; -end Step1_Read_Print; +with Ada.Text_IO; +with Printer; +with Reader; +with Types; + +procedure Step1_Read_Print is + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + function Eval (Param : Types.Mal_Handle) return Types.Mal_Handle is + begin + return Param; + end Eval; + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST); + return Print (Evaluated_AST); + end if; + + end Rep; + +begin + loop + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line)); + end loop; +end Step1_Read_Print; diff --git a/impls/ada/step2_eval.adb b/impls/ada/step2_eval.adb index 6f0e281d8a..079ee022f0 100644 --- a/impls/ada/step2_eval.adb +++ b/impls/ada/step2_eval.adb @@ -1,236 +1,236 @@ -with Ada.Containers.Hashed_Maps; -with Ada.Strings.Unbounded.Hash; -with Ada.Text_IO; -with Ada.Exceptions; -with Printer; -with Reader; -with Smart_Pointers; -with Types; - -procedure Step2_Eval is - - use Types; - - -- primitive functions on Smart_Pointer, - function "+" is new Arith_Op ("+", "+"); - function "-" is new Arith_Op ("-", "-"); - function "*" is new Arith_Op ("*", "*"); - function "/" is new Arith_Op ("/", "/"); - - -- Take a list with two parameters and produce a single result - -- using the Op access-to-function parameter. - function Reduce2 - (Op : Binary_Func_Access; LH : Mal_Handle) - return Mal_Handle is - Left, Right : Mal_Handle; - L, Rest_List : List_Mal_Type; - begin - L := Deref_List (LH).all; - Left := Car (L); - Rest_List := Deref_List (Cdr (L)).all; - Right := Car (Rest_List); - return Op (Left, Right); - end Reduce2; - - - function Plus (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (Step2_Eval."+"'Unrestricted_Access, Rest_Handle); - end Plus; - - - function Minus (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (Step2_Eval."-"'Unrestricted_Access, Rest_Handle); - end Minus; - - - function Mult (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (Step2_Eval."*"'Unrestricted_Access, Rest_Handle); - end Mult; - - - function Divide (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (Step2_Eval."/"'Unrestricted_Access, Rest_Handle); - end Divide; - - - package String_Mal_Hash is new Ada.Containers.Hashed_Maps - (Key_Type => Ada.Strings.Unbounded.Unbounded_String, - Element_Type => Smart_Pointers.Smart_Pointer, - Hash => Ada.Strings.Unbounded.Hash, - Equivalent_Keys => Ada.Strings.Unbounded."=", - "=" => Smart_Pointers."="); - - Not_Found : exception; - - function Get (M : String_Mal_Hash.Map; K : String) return Mal_Handle is - use String_Mal_Hash; - C : Cursor; - begin - C := Find (M, Ada.Strings.Unbounded.To_Unbounded_String (K)); - if C = No_Element then - raise Not_Found; - else - return Element (C); - end if; - end Get; - - - Repl_Env : String_Mal_Hash.Map; - - - function Eval (Param : Types.Mal_Handle; Env : String_Mal_Hash.Map) - return Types.Mal_Handle; - - - Debug : Boolean := False; - - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - - function Eval_Ast - (Ast : Mal_Handle; Env : String_Mal_Hash.Map) - return Mal_Handle is - - function Call_Eval (A : Mal_Handle) return Mal_Handle is - begin - return Eval (A, Env); - end Call_Eval; - - begin - - case Deref (Ast).Sym_Type is - - when Sym => - - declare - Sym : Mal_String := Deref_Sym (Ast).Get_Sym; - begin - -- if keyword, return it. Otherwise look it up in the environment. - if Sym(1) = ':' then - return Ast; - else - return Get (Env, Sym); - end if; - exception - when Not_Found => - raise Not_Found with ("'" & Sym & "' not found"); - end; - - when List => - - return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); - - when others => return Ast; - - end case; - - end Eval_Ast; - - - function Eval (Param : Mal_Handle; Env : String_Mal_Hash.Map) - return Mal_Handle is - First_Elem : Mal_Handle; - begin - - if Debug then - Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type = List and then - Deref_List (Param).Get_List_Type = List_List then - - declare - Evaled_H, First_Param : Mal_Handle; - Evaled_List : List_Mal_Type; - Param_List : List_Mal_Type; - begin - Param_List := Deref_List (Param).all; - - -- Deal with empty list.. - if Param_List.Length = 0 then - return Param; - end if; - - Evaled_H := Eval_Ast (Param, Env); - Evaled_List := Deref_List (Evaled_H).all; - First_Param := Car (Evaled_List); - return Call_Func (Deref_Func (First_Param).all, Cdr (Evaled_List)); - end; - - else -- Not a List_List - - return Eval_Ast (Param, Env); - - end if; - - end Eval; - - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - - function Rep (Param : String; Env : String_Mal_Hash.Map) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; - - end Rep; - -begin - - String_Mal_Hash.Include - (Container => Repl_Env, - Key => Ada.Strings.Unbounded.To_Unbounded_String ("+"), - New_Item => New_Func_Mal_Type ("+", Plus'Unrestricted_access)); - - String_Mal_Hash.Include - (Container => Repl_Env, - Key => Ada.Strings.Unbounded.To_Unbounded_String ("-"), - New_Item => New_Func_Mal_Type ("-", Minus'Unrestricted_access)); - - String_Mal_Hash.Include - (Container => Repl_Env, - Key => Ada.Strings.Unbounded.To_Unbounded_String ("*"), - New_Item => New_Func_Mal_Type ("*", Mult'Unrestricted_access)); - - String_Mal_Hash.Include - (Container => Repl_Env, - Key => Ada.Strings.Unbounded.To_Unbounded_String ("/"), - New_Item => New_Func_Mal_Type ("/", Divide'Unrestricted_access)); - - loop - begin - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); - exception - when E : others => - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - Ada.Exceptions.Exception_Information (E)); - end; - end loop; -end Step2_Eval; +with Ada.Containers.Hashed_Maps; +with Ada.Strings.Unbounded.Hash; +with Ada.Text_IO; +with Ada.Exceptions; +with Printer; +with Reader; +with Smart_Pointers; +with Types; + +procedure Step2_Eval is + + use Types; + + -- primitive functions on Smart_Pointer, + function "+" is new Arith_Op ("+", "+"); + function "-" is new Arith_Op ("-", "-"); + function "*" is new Arith_Op ("*", "*"); + function "/" is new Arith_Op ("/", "/"); + + -- Take a list with two parameters and produce a single result + -- using the Op access-to-function parameter. + function Reduce2 + (Op : Binary_Func_Access; LH : Mal_Handle) + return Mal_Handle is + Left, Right : Mal_Handle; + L, Rest_List : List_Mal_Type; + begin + L := Deref_List (LH).all; + Left := Car (L); + Rest_List := Deref_List (Cdr (L)).all; + Right := Car (Rest_List); + return Op (Left, Right); + end Reduce2; + + + function Plus (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (Step2_Eval."+"'Unrestricted_Access, Rest_Handle); + end Plus; + + + function Minus (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (Step2_Eval."-"'Unrestricted_Access, Rest_Handle); + end Minus; + + + function Mult (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (Step2_Eval."*"'Unrestricted_Access, Rest_Handle); + end Mult; + + + function Divide (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (Step2_Eval."/"'Unrestricted_Access, Rest_Handle); + end Divide; + + + package String_Mal_Hash is new Ada.Containers.Hashed_Maps + (Key_Type => Ada.Strings.Unbounded.Unbounded_String, + Element_Type => Smart_Pointers.Smart_Pointer, + Hash => Ada.Strings.Unbounded.Hash, + Equivalent_Keys => Ada.Strings.Unbounded."=", + "=" => Smart_Pointers."="); + + Not_Found : exception; + + function Get (M : String_Mal_Hash.Map; K : String) return Mal_Handle is + use String_Mal_Hash; + C : Cursor; + begin + C := Find (M, Ada.Strings.Unbounded.To_Unbounded_String (K)); + if C = No_Element then + raise Not_Found; + else + return Element (C); + end if; + end Get; + + + Repl_Env : String_Mal_Hash.Map; + + + function Eval (Param : Types.Mal_Handle; Env : String_Mal_Hash.Map) + return Types.Mal_Handle; + + + Debug : Boolean := False; + + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + function Eval_Ast + (Ast : Mal_Handle; Env : String_Mal_Hash.Map) + return Mal_Handle is + + function Call_Eval (A : Mal_Handle) return Mal_Handle is + begin + return Eval (A, Env); + end Call_Eval; + + begin + + case Deref (Ast).Sym_Type is + + when Sym => + + declare + Sym : Mal_String := Deref_Sym (Ast).Get_Sym; + begin + -- if keyword, return it. Otherwise look it up in the environment. + if Sym(1) = ':' then + return Ast; + else + return Get (Env, Sym); + end if; + exception + when Not_Found => + raise Not_Found with ("'" & Sym & "' not found"); + end; + + when List => + + return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); + + when others => return Ast; + + end case; + + end Eval_Ast; + + + function Eval (Param : Mal_Handle; Env : String_Mal_Hash.Map) + return Mal_Handle is + First_Elem : Mal_Handle; + begin + + if Debug then + Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type = List and then + Deref_List (Param).Get_List_Type = List_List then + + declare + Evaled_H, First_Param : Mal_Handle; + Evaled_List : List_Mal_Type; + Param_List : List_Mal_Type; + begin + Param_List := Deref_List (Param).all; + + -- Deal with empty list.. + if Param_List.Length = 0 then + return Param; + end if; + + Evaled_H := Eval_Ast (Param, Env); + Evaled_List := Deref_List (Evaled_H).all; + First_Param := Car (Evaled_List); + return Call_Func (Deref_Func (First_Param).all, Cdr (Evaled_List)); + end; + + else -- Not a List_List + + return Eval_Ast (Param, Env); + + end if; + + end Eval; + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + + function Rep (Param : String; Env : String_Mal_Hash.Map) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; + + end Rep; + +begin + + String_Mal_Hash.Include + (Container => Repl_Env, + Key => Ada.Strings.Unbounded.To_Unbounded_String ("+"), + New_Item => New_Func_Mal_Type ("+", Plus'Unrestricted_access)); + + String_Mal_Hash.Include + (Container => Repl_Env, + Key => Ada.Strings.Unbounded.To_Unbounded_String ("-"), + New_Item => New_Func_Mal_Type ("-", Minus'Unrestricted_access)); + + String_Mal_Hash.Include + (Container => Repl_Env, + Key => Ada.Strings.Unbounded.To_Unbounded_String ("*"), + New_Item => New_Func_Mal_Type ("*", Mult'Unrestricted_access)); + + String_Mal_Hash.Include + (Container => Repl_Env, + Key => Ada.Strings.Unbounded.To_Unbounded_String ("/"), + New_Item => New_Func_Mal_Type ("/", Divide'Unrestricted_access)); + + loop + begin + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); + exception + when E : others => + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Ada.Exceptions.Exception_Information (E)); + end; + end loop; +end Step2_Eval; diff --git a/impls/ada/step3_env.adb b/impls/ada/step3_env.adb index cca59b36f9..4e110d8375 100644 --- a/impls/ada/step3_env.adb +++ b/impls/ada/step3_env.adb @@ -1,269 +1,269 @@ -with Ada.Command_Line; -with Ada.Exceptions; -with Ada.Text_IO; -with Envs; -with Eval_Callback; -with Printer; -with Reader; -with Smart_Pointers; -with Types; - -procedure Step3_Env is - - use Types; - - -- primitive functions on Smart_Pointer, - function "+" is new Arith_Op ("+", "+"); - function "-" is new Arith_Op ("-", "-"); - function "*" is new Arith_Op ("*", "*"); - function "/" is new Arith_Op ("/", "/"); - - -- Take a list with two parameters and produce a single result - -- using the Op access-to-function parameter. - function Reduce2 - (Op : Binary_Func_Access; LH : Mal_Handle) - return Mal_Handle is - Left, Right : Mal_Handle; - L, Rest_List : List_Mal_Type; - begin - L := Deref_List (LH).all; - Left := Car (L); - Rest_List := Deref_List (Cdr (L)).all; - Right := Car (Rest_List); - return Op (Left, Right); - end Reduce2; - - - function Plus (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (Step3_Env."+"'Unrestricted_Access, Rest_Handle); - end Plus; - - - function Minus (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (Step3_Env."-"'Unrestricted_Access, Rest_Handle); - end Minus; - - - function Mult (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (Step3_Env."*"'Unrestricted_Access, Rest_Handle); - end Mult; - - - function Divide (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - begin - return Reduce2 (Step3_Env."/"'Unrestricted_Access, Rest_Handle); - end Divide; - - - function Eval (Param : Types.Mal_Handle; Env : Envs.Env_Handle) - return Types.Mal_Handle; - - Debug : Boolean := False; - - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - - function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Fn: expected symbol as name"); - Fn_Body := Nth (Args, 1); - Res := Eval (Fn_Body, Env); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Fn; - - - function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Defs, Expr, Res : Mal_Handle; - E : Envs.Env_Handle; - begin - E := Envs.New_Env (Env); - Defs := Car (Args); - Deref_List_Class (Defs).Add_Defs (E); - Expr := Car (Deref_List (Cdr (Args)).all); - Res := Eval (Expr, E); - return Res; - end Let_Processing; - - - function Eval_Ast - (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - - function Call_Eval (A : Mal_Handle) return Mal_Handle is - begin - return Eval (A, Env); - end Call_Eval; - - begin - - case Deref (Ast).Sym_Type is - - when Sym => - - declare - Sym : Mal_String := Deref_Sym (Ast).Get_Sym; - begin - -- if keyword, return it. Otherwise look it up in the environment. - if Sym(1) = ':' then - return Ast; - else - return Envs.Get (Env, Sym); - end if; - exception - when Envs.Not_Found => - raise Envs.Not_Found with ("'" & Sym & "' not found"); - end; - - when List => - - return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); - - when others => return Ast; - - end case; - - end Eval_Ast; - - - function Eval (Param : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - First_Elem : Mal_Handle; - begin - - if Debug then - Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type = List and then - Deref_List (Param).Get_List_Type = List_List then - - declare - Evaled_H, First_Param, Rest_List : Mal_Handle; - Param_List : List_Mal_Type; - begin - Param_List := Deref_List (Param).all; - - -- Deal with empty list.. - if Param_List.Length = 0 then - return Param; - end if; - - First_Param := Car (Param_List); - Rest_List := Cdr (Param_List); - - if Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "def!" then - return Def_Fn (Deref_List (Rest_List).all, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "let*" then - return Let_Processing (Deref_List (Rest_List).all, Env); - else - -- The APPLY section. - Evaled_H := Eval_Ast (Param, Env); - Param_List := Deref_List (Evaled_H).all; - First_Param := Car (Param_List); - return Call_Func (Deref_Func (First_Param).all, Cdr (Param_List)); - end if; - - end; - - else -- Not a List_List - - return Eval_Ast (Param, Env); - - end if; - - end Eval; - - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; - - end Rep; - - - procedure Init (Env : Envs.Env_Handle) is - begin - - Envs.Set (Env, - "+", - New_Func_Mal_Type ("+", Plus'Unrestricted_Access)); - - Envs.Set (Env, - "-", - New_Func_Mal_Type ("-", Minus'Unrestricted_Access)); - - Envs.Set (Env, - "*", - New_Func_Mal_Type ("*", Mult'Unrestricted_Access)); - - Envs.Set (Env, - "/", - New_Func_Mal_Type ("/", Divide'Unrestricted_Access)); - - end Init; - - - Repl_Env : Envs.Env_Handle; -begin - - -- Save a function pointer back to the Eval function. - -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK - -- as we know Eval will be in scope for the lifetime of the program. - Eval_Callback.Eval := Eval'Unrestricted_Access; - - if Ada.Command_Line.Argument_Count > 0 then - if Ada.Command_Line.Argument (1) = "-d" then - Debug := True; - end if; - end if; - - Repl_Env := Envs.New_Env; - - Init (Repl_Env); - - loop - begin - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); - exception - when E : others => - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - Ada.Exceptions.Exception_Information (E)); - end; - end loop; -end Step3_Env; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Text_IO; +with Envs; +with Eval_Callback; +with Printer; +with Reader; +with Smart_Pointers; +with Types; + +procedure Step3_Env is + + use Types; + + -- primitive functions on Smart_Pointer, + function "+" is new Arith_Op ("+", "+"); + function "-" is new Arith_Op ("-", "-"); + function "*" is new Arith_Op ("*", "*"); + function "/" is new Arith_Op ("/", "/"); + + -- Take a list with two parameters and produce a single result + -- using the Op access-to-function parameter. + function Reduce2 + (Op : Binary_Func_Access; LH : Mal_Handle) + return Mal_Handle is + Left, Right : Mal_Handle; + L, Rest_List : List_Mal_Type; + begin + L := Deref_List (LH).all; + Left := Car (L); + Rest_List := Deref_List (Cdr (L)).all; + Right := Car (Rest_List); + return Op (Left, Right); + end Reduce2; + + + function Plus (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (Step3_Env."+"'Unrestricted_Access, Rest_Handle); + end Plus; + + + function Minus (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (Step3_Env."-"'Unrestricted_Access, Rest_Handle); + end Minus; + + + function Mult (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (Step3_Env."*"'Unrestricted_Access, Rest_Handle); + end Mult; + + + function Divide (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + begin + return Reduce2 (Step3_Env."/"'Unrestricted_Access, Rest_Handle); + end Divide; + + + function Eval (Param : Types.Mal_Handle; Env : Envs.Env_Handle) + return Types.Mal_Handle; + + Debug : Boolean := False; + + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Fn: expected symbol as name"); + Fn_Body := Nth (Args, 1); + Res := Eval (Fn_Body, Env); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Fn; + + + function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Defs, Expr, Res : Mal_Handle; + E : Envs.Env_Handle; + begin + E := Envs.New_Env (Env); + Defs := Car (Args); + Deref_List_Class (Defs).Add_Defs (E); + Expr := Car (Deref_List (Cdr (Args)).all); + Res := Eval (Expr, E); + return Res; + end Let_Processing; + + + function Eval_Ast + (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + + function Call_Eval (A : Mal_Handle) return Mal_Handle is + begin + return Eval (A, Env); + end Call_Eval; + + begin + + case Deref (Ast).Sym_Type is + + when Sym => + + declare + Sym : Mal_String := Deref_Sym (Ast).Get_Sym; + begin + -- if keyword, return it. Otherwise look it up in the environment. + if Sym(1) = ':' then + return Ast; + else + return Envs.Get (Env, Sym); + end if; + exception + when Envs.Not_Found => + raise Envs.Not_Found with ("'" & Sym & "' not found"); + end; + + when List => + + return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); + + when others => return Ast; + + end case; + + end Eval_Ast; + + + function Eval (Param : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + First_Elem : Mal_Handle; + begin + + if Debug then + Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type = List and then + Deref_List (Param).Get_List_Type = List_List then + + declare + Evaled_H, First_Param, Rest_List : Mal_Handle; + Param_List : List_Mal_Type; + begin + Param_List := Deref_List (Param).all; + + -- Deal with empty list.. + if Param_List.Length = 0 then + return Param; + end if; + + First_Param := Car (Param_List); + Rest_List := Cdr (Param_List); + + if Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "def!" then + return Def_Fn (Deref_List (Rest_List).all, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "let*" then + return Let_Processing (Deref_List (Rest_List).all, Env); + else + -- The APPLY section. + Evaled_H := Eval_Ast (Param, Env); + Param_List := Deref_List (Evaled_H).all; + First_Param := Car (Param_List); + return Call_Func (Deref_Func (First_Param).all, Cdr (Param_List)); + end if; + + end; + + else -- Not a List_List + + return Eval_Ast (Param, Env); + + end if; + + end Eval; + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String; Env : Envs.Env_Handle) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; + + end Rep; + + + procedure Init (Env : Envs.Env_Handle) is + begin + + Envs.Set (Env, + "+", + New_Func_Mal_Type ("+", Plus'Unrestricted_Access)); + + Envs.Set (Env, + "-", + New_Func_Mal_Type ("-", Minus'Unrestricted_Access)); + + Envs.Set (Env, + "*", + New_Func_Mal_Type ("*", Mult'Unrestricted_Access)); + + Envs.Set (Env, + "/", + New_Func_Mal_Type ("/", Divide'Unrestricted_Access)); + + end Init; + + + Repl_Env : Envs.Env_Handle; +begin + + -- Save a function pointer back to the Eval function. + -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK + -- as we know Eval will be in scope for the lifetime of the program. + Eval_Callback.Eval := Eval'Unrestricted_Access; + + if Ada.Command_Line.Argument_Count > 0 then + if Ada.Command_Line.Argument (1) = "-d" then + Debug := True; + end if; + end if; + + Repl_Env := Envs.New_Env; + + Init (Repl_Env); + + loop + begin + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); + exception + when E : others => + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Ada.Exceptions.Exception_Information (E)); + end; + end loop; +end Step3_Env; diff --git a/impls/ada/step4_if_fn_do.adb b/impls/ada/step4_if_fn_do.adb index d41e9bc084..28b7218b6f 100644 --- a/impls/ada/step4_if_fn_do.adb +++ b/impls/ada/step4_if_fn_do.adb @@ -1,323 +1,323 @@ -with Ada.Command_Line; -with Ada.Exceptions; -with Ada.Text_IO; -with Core; -with Envs; -with Eval_Callback; -with Printer; -with Reader; -with Smart_Pointers; -with Types; - -procedure Step4_If_Fn_Do is - - use Types; - - function Eval (Param : Types.Mal_Handle; Env : Envs.Env_Handle) - return Types.Mal_Handle; - - Debug : Boolean := False; - - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - - function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Fn: expected symbol as name"); - Fn_Body := Nth (Args, 1); - Res := Eval (Fn_Body, Env); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Fn; - - - function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Defs, Expr, Res : Mal_Handle; - E : Envs.Env_Handle; - begin - E := Envs.New_Env (Env); - Defs := Car (Args); - Deref_List_Class (Defs).Add_Defs (E); - Expr := Car (Deref_List (Cdr (Args)).all); - Res := Eval (Expr, E); - return Res; - end Let_Processing; - - - function Do_Processing (Do_List : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - D : List_Mal_Type; - Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer; - begin - if Debug then - Ada.Text_IO.Put_Line ("Do-ing " & To_String (Do_List)); - end if; - D := Do_List; - while not Is_Null (D) loop - Res := Eval (Car (D), Env); - D := Deref_List (Cdr(D)).all; - end loop; - return Res; - end Do_Processing; - - - function Eval_As_Boolean (MH : Mal_Handle) return Boolean is - Res : Boolean; - begin - case Deref (MH).Sym_Type is - when Bool => - Res := Deref_Bool (MH).Get_Bool; - when Nil => - return False; --- when List => --- declare --- L : List_Mal_Type; --- begin --- L := Deref_List (MH).all; --- Res := not Is_Null (L); --- end; - when others => -- Everything else - Res := True; - end case; - return Res; - end Eval_As_Boolean; - - - function Eval_Ast - (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - - function Call_Eval (A : Mal_Handle) return Mal_Handle is - begin - return Eval (A, Env); - end Call_Eval; - - begin - - case Deref (Ast).Sym_Type is - - when Sym => - - declare - Sym : Mal_String := Deref_Sym (Ast).Get_Sym; - begin - -- if keyword, return it. Otherwise look it up in the environment. - if Sym(1) = ':' then - return Ast; - else - return Envs.Get (Env, Sym); - end if; - exception - when Envs.Not_Found => - raise Envs.Not_Found with ("'" & Sym & "' not found"); - end; - - when List => - - return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); - - when others => return Ast; - - end case; - - end Eval_Ast; - - - function Eval (Param : Mal_Handle; Env : Envs.Env_Handle) return Mal_Handle is - First_Param, Rest_Params : Mal_Handle; - Rest_List, Param_List : List_Mal_Type; - begin - - if Debug then - Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type = List and then - Deref_List (Param).Get_List_Type = List_List then - - Param_List := Deref_List (Param).all; - - -- Deal with empty list.. - if Param_List.Length = 0 then - return Param; - end if; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "def!" then - - return Def_Fn (Rest_List, Env); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "let*" then - - return Let_Processing (Rest_List, Env); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "do" then - - return Do_Processing (Rest_List, Env); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "if" then - - declare - Cond, True_Part, False_Part : Mal_Handle; - Cond_Bool : Boolean; - pragma Assert (Length (Rest_List) = 2 or Length (Rest_List) = 3, - "If_Processing: not 2 or 3 parameters"); - L : List_Mal_Type; - begin - - Cond := Eval (Car (Rest_List), Env); - - Cond_Bool := Eval_As_Boolean (Cond); - - if Cond_Bool then - L := Deref_List (Cdr (Rest_List)).all; - return Eval (Car (L), Env); - else - if Length (Rest_List) = 3 then - L := Deref_List (Cdr (Rest_List)).all; - L := Deref_List (Cdr (L)).all; - return Eval (Car (L), Env); - else - return New_Nil_Mal_Type; - end if; - end if; - - end; - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "fn*" then - - return New_Lambda_Mal_Type - (Params => Car (Rest_List), - Expr => Nth (Rest_List, 1), - Env => Env); - - else - - -- The APPLY section. - declare - Evaled_H : Mal_Handle; - begin - Evaled_H := Eval_Ast (Param, Env); - - Param_List := Deref_List (Evaled_H).all; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Func then - return Call_Func (Deref_Func (First_Param).all, Rest_Params); - elsif Deref (First_Param).Sym_Type = Lambda then - return Apply (Deref_Lambda (First_Param).all, Rest_Params); - else - raise Mal_Exception; - end if; - - end; - - end if; - - else -- Not a List_List - - return Eval_Ast (Param, Env); - - end if; - - end Eval; - - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; - - end Rep; - - - Repl_Env : Envs.Env_Handle; - - - -- This op uses Repl_Env directly. - - - procedure RE (Str : Mal_String) is - Discarded : Mal_Handle; - begin - Discarded := Eval (Read (Str), Repl_Env); - end RE; - - - Cmd_Args : Natural; - -begin - - -- Save a function pointer back to the Eval function. - -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK - -- as we know Eval will be in scope for the lifetime of the program. - Eval_Callback.Eval := Eval'Unrestricted_Access; - - Cmd_Args := 0; - while Ada.Command_Line.Argument_Count > Cmd_Args loop - Cmd_Args := Cmd_Args + 1; - if Ada.Command_Line.Argument (Cmd_Args) = "-d" then - Debug := True; - elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then - Envs.Debug := True; - end if; - end loop; - - Repl_Env := Envs.New_Env; - - Core.Init (Repl_Env); - - RE ("(def! not (fn* (a) (if a false true)))"); - - loop - begin - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); - exception - when E : others => - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - "Error: " & Ada.Exceptions.Exception_Information (E)); - if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - Printer.Pr_Str (Types.Mal_Exception_Value)); - Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; - end if; - end; - end loop; -end Step4_If_Fn_Do; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Text_IO; +with Core; +with Envs; +with Eval_Callback; +with Printer; +with Reader; +with Smart_Pointers; +with Types; + +procedure Step4_If_Fn_Do is + + use Types; + + function Eval (Param : Types.Mal_Handle; Env : Envs.Env_Handle) + return Types.Mal_Handle; + + Debug : Boolean := False; + + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Fn: expected symbol as name"); + Fn_Body := Nth (Args, 1); + Res := Eval (Fn_Body, Env); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Fn; + + + function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Defs, Expr, Res : Mal_Handle; + E : Envs.Env_Handle; + begin + E := Envs.New_Env (Env); + Defs := Car (Args); + Deref_List_Class (Defs).Add_Defs (E); + Expr := Car (Deref_List (Cdr (Args)).all); + Res := Eval (Expr, E); + return Res; + end Let_Processing; + + + function Do_Processing (Do_List : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + D : List_Mal_Type; + Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer; + begin + if Debug then + Ada.Text_IO.Put_Line ("Do-ing " & To_String (Do_List)); + end if; + D := Do_List; + while not Is_Null (D) loop + Res := Eval (Car (D), Env); + D := Deref_List (Cdr(D)).all; + end loop; + return Res; + end Do_Processing; + + + function Eval_As_Boolean (MH : Mal_Handle) return Boolean is + Res : Boolean; + begin + case Deref (MH).Sym_Type is + when Bool => + Res := Deref_Bool (MH).Get_Bool; + when Nil => + return False; +-- when List => +-- declare +-- L : List_Mal_Type; +-- begin +-- L := Deref_List (MH).all; +-- Res := not Is_Null (L); +-- end; + when others => -- Everything else + Res := True; + end case; + return Res; + end Eval_As_Boolean; + + + function Eval_Ast + (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + + function Call_Eval (A : Mal_Handle) return Mal_Handle is + begin + return Eval (A, Env); + end Call_Eval; + + begin + + case Deref (Ast).Sym_Type is + + when Sym => + + declare + Sym : Mal_String := Deref_Sym (Ast).Get_Sym; + begin + -- if keyword, return it. Otherwise look it up in the environment. + if Sym(1) = ':' then + return Ast; + else + return Envs.Get (Env, Sym); + end if; + exception + when Envs.Not_Found => + raise Envs.Not_Found with ("'" & Sym & "' not found"); + end; + + when List => + + return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); + + when others => return Ast; + + end case; + + end Eval_Ast; + + + function Eval (Param : Mal_Handle; Env : Envs.Env_Handle) return Mal_Handle is + First_Param, Rest_Params : Mal_Handle; + Rest_List, Param_List : List_Mal_Type; + begin + + if Debug then + Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type = List and then + Deref_List (Param).Get_List_Type = List_List then + + Param_List := Deref_List (Param).all; + + -- Deal with empty list.. + if Param_List.Length = 0 then + return Param; + end if; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "def!" then + + return Def_Fn (Rest_List, Env); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "let*" then + + return Let_Processing (Rest_List, Env); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "do" then + + return Do_Processing (Rest_List, Env); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "if" then + + declare + Cond, True_Part, False_Part : Mal_Handle; + Cond_Bool : Boolean; + pragma Assert (Length (Rest_List) = 2 or Length (Rest_List) = 3, + "If_Processing: not 2 or 3 parameters"); + L : List_Mal_Type; + begin + + Cond := Eval (Car (Rest_List), Env); + + Cond_Bool := Eval_As_Boolean (Cond); + + if Cond_Bool then + L := Deref_List (Cdr (Rest_List)).all; + return Eval (Car (L), Env); + else + if Length (Rest_List) = 3 then + L := Deref_List (Cdr (Rest_List)).all; + L := Deref_List (Cdr (L)).all; + return Eval (Car (L), Env); + else + return New_Nil_Mal_Type; + end if; + end if; + + end; + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "fn*" then + + return New_Lambda_Mal_Type + (Params => Car (Rest_List), + Expr => Nth (Rest_List, 1), + Env => Env); + + else + + -- The APPLY section. + declare + Evaled_H : Mal_Handle; + begin + Evaled_H := Eval_Ast (Param, Env); + + Param_List := Deref_List (Evaled_H).all; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Func then + return Call_Func (Deref_Func (First_Param).all, Rest_Params); + elsif Deref (First_Param).Sym_Type = Lambda then + return Apply (Deref_Lambda (First_Param).all, Rest_Params); + else + raise Mal_Exception; + end if; + + end; + + end if; + + else -- Not a List_List + + return Eval_Ast (Param, Env); + + end if; + + end Eval; + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String; Env : Envs.Env_Handle) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; + + end Rep; + + + Repl_Env : Envs.Env_Handle; + + + -- This op uses Repl_Env directly. + + + procedure RE (Str : Mal_String) is + Discarded : Mal_Handle; + begin + Discarded := Eval (Read (Str), Repl_Env); + end RE; + + + Cmd_Args : Natural; + +begin + + -- Save a function pointer back to the Eval function. + -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK + -- as we know Eval will be in scope for the lifetime of the program. + Eval_Callback.Eval := Eval'Unrestricted_Access; + + Cmd_Args := 0; + while Ada.Command_Line.Argument_Count > Cmd_Args loop + Cmd_Args := Cmd_Args + 1; + if Ada.Command_Line.Argument (Cmd_Args) = "-d" then + Debug := True; + elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then + Envs.Debug := True; + end if; + end loop; + + Repl_Env := Envs.New_Env; + + Core.Init (Repl_Env); + + RE ("(def! not (fn* (a) (if a false true)))"); + + loop + begin + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); + exception + when E : others => + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; + end; + end loop; +end Step4_If_Fn_Do; diff --git a/impls/ada/step5_tco.adb b/impls/ada/step5_tco.adb index 2234b21309..3d844761c1 100644 --- a/impls/ada/step5_tco.adb +++ b/impls/ada/step5_tco.adb @@ -1,377 +1,377 @@ -with Ada.Command_Line; -with Ada.Exceptions; -with Ada.Text_IO; -with Core; -with Envs; -with Eval_Callback; -with Printer; -with Reader; -with Smart_Pointers; -with Types; - -procedure Step5_TCO is - - use Types; - - -- Forward declaration of Eval. - function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) return Mal_Handle; - - Debug : Boolean := False; - - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - - function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Fn: expected atom as name"); - Fn_Body := Nth (Args, 1); - Res := Eval (Fn_Body, Env); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Fn; - - - function Eval_As_Boolean (MH : Mal_Handle) return Boolean is - Res : Boolean; - begin - case Deref (MH).Sym_Type is - when Bool => - Res := Deref_Bool (MH).Get_Bool; - when Nil => - return False; --- when List => --- declare --- L : List_Mal_Type; --- begin --- L := Deref_List (MH).all; --- Res := not Is_Null (L); --- end; - when others => -- Everything else - Res := True; - end case; - return Res; - end Eval_As_Boolean; - - - function Eval_Ast - (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - - function Call_Eval (A : Mal_Handle) return Mal_Handle is - begin - return Eval (A, Env); - end Call_Eval; - - begin - - case Deref (Ast).Sym_Type is - - when Sym => - - declare - Sym : Mal_String := Deref_Sym (Ast).Get_Sym; - begin - -- if keyword, return it. Otherwise look it up in the environment. - if Sym(1) = ':' then - return Ast; - else - return Envs.Get (Env, Sym); - end if; - exception - when Envs.Not_Found => - raise Envs.Not_Found with ("'" & Sym & "' not found"); - end; - - when List => - - return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); - - when others => return Ast; - - end case; - - end Eval_Ast; - - - function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) - return Mal_Handle is - Param : Mal_Handle; - Env : Envs.Env_Handle; - First_Param, Rest_Params : Mal_Handle; - Rest_List, Param_List : List_Mal_Type; - begin - - Param := AParam; - Env := AnEnv; - - <> - - if Debug then - Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type = List and then - Deref_List (Param).Get_List_Type = List_List then - - Param_List := Deref_List (Param).all; - - -- Deal with empty list.. - if Param_List.Length = 0 then - return Param; - end if; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "def!" then - return Def_Fn (Rest_List, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "let*" then - declare - Defs, Expr, Res : Mal_Handle; - E : Envs.Env_Handle; - begin - E := Envs.New_Env (Env); - Defs := Car (Rest_List); - Deref_List_Class (Defs).Add_Defs (E); - Expr := Car (Deref_List (Cdr (Rest_List)).all); - Param := Expr; - Env := E; - goto Tail_Call_Opt; - -- was: - -- Res := Eval (Expr, E); - -- return Res; - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "do" then - declare - D : List_Mal_Type; - E : Mal_Handle; - begin - - if Debug then - Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); - end if; - - if Is_Null (Rest_List) then - return Rest_Params; - end if; - - -- Loop processes Evals all but last entry - D := Rest_List; - loop - E := Car (D); - D := Deref_List (Cdr (D)).all; - exit when Is_Null (D); - E := Eval (E, Env); - end loop; - - Param := E; - goto Tail_Call_Opt; - - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "if" then - declare - Args : List_Mal_Type := Rest_List; - - Cond, True_Part, False_Part : Mal_Handle; - Cond_Bool : Boolean; - pragma Assert (Length (Args) = 2 or Length (Args) = 3, - "If_Processing: not 2 or 3 parameters"); - L : List_Mal_Type; - begin - - Cond := Eval (Car (Args), Env); - - Cond_Bool := Eval_As_Boolean (Cond); - - if Cond_Bool then - L := Deref_List (Cdr (Args)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - if Length (Args) = 3 then - L := Deref_List (Cdr (Args)).all; - L := Deref_List (Cdr (L)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - return New_Nil_Mal_Type; - end if; - end if; - end; - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "fn*" then - - return New_Lambda_Mal_Type - (Params => Car (Rest_List), - Expr => Nth (Rest_List, 1), - Env => Env); - - else - - -- The APPLY section. - declare - Evaled_H : Mal_Handle; - begin - Evaled_H := Eval_Ast (Param, Env); - - Param_List := Deref_List (Evaled_H).all; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Func then - return Call_Func (Deref_Func (First_Param).all, Rest_Params); - elsif Deref (First_Param).Sym_Type = Lambda then - declare - - L : Lambda_Mal_Type; - E : Envs.Env_Handle; - Param_Names : List_Mal_Type; - Res : Mal_Handle; - - begin - - L := Deref_Lambda (First_Param).all; - E := Envs.New_Env (L.Get_Env); - - Param_Names := Deref_List (L.Get_Params).all; - - if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then - - Param := L.Get_Expr; - Env := E; - goto Tail_Call_Opt; - -- was: return Eval (L.Get_Expr, E); - - else - - raise Mal_Exception with "Bind failed in Apply"; - - end if; - - end; - - else -- neither a Lambda or a Func - raise Mal_Exception; - end if; - - end; - - end if; - - else -- Not a List_List - - return Eval_Ast (Param, Env); - - end if; - - end Eval; - - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; - - end Rep; - - - Repl_Env : Envs.Env_Handle; - - - -- These two ops use Repl_Env directly. - - - procedure RE (Str : Mal_String) is - Discarded : Mal_Handle; - begin - Discarded := Eval (Read (Str), Repl_Env); - end RE; - - - function Do_Eval (Rest_Handle : Mal_Handle; Env : Envs.Env_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return Eval_Callback.Eval.all (First_Param, Repl_Env); - end Do_Eval; - - Cmd_Args : Natural; - -begin - - -- Save a function pointer back to the Eval function. - -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK - -- as we know Eval will be in scope for the lifetime of the program. - Eval_Callback.Eval := Eval'Unrestricted_Access; - - Cmd_Args := 0; - while Ada.Command_Line.Argument_Count > Cmd_Args loop - Cmd_Args := Cmd_Args + 1; - if Ada.Command_Line.Argument (Cmd_Args) = "-d" then - Debug := True; - elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then - Envs.Debug := True; - end if; - end loop; - - Repl_Env := Envs.New_Env; - - Core.Init (Repl_Env); - - RE ("(def! not (fn* (a) (if a false true)))"); - - loop - begin - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); - exception - when E : others => - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - "Error: " & Ada.Exceptions.Exception_Information (E)); - if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - Printer.Pr_Str (Types.Mal_Exception_Value)); - Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; - end if; - end; - end loop; -end Step5_TCO; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Text_IO; +with Core; +with Envs; +with Eval_Callback; +with Printer; +with Reader; +with Smart_Pointers; +with Types; + +procedure Step5_TCO is + + use Types; + + -- Forward declaration of Eval. + function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) return Mal_Handle; + + Debug : Boolean := False; + + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Fn: expected atom as name"); + Fn_Body := Nth (Args, 1); + Res := Eval (Fn_Body, Env); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Fn; + + + function Eval_As_Boolean (MH : Mal_Handle) return Boolean is + Res : Boolean; + begin + case Deref (MH).Sym_Type is + when Bool => + Res := Deref_Bool (MH).Get_Bool; + when Nil => + return False; +-- when List => +-- declare +-- L : List_Mal_Type; +-- begin +-- L := Deref_List (MH).all; +-- Res := not Is_Null (L); +-- end; + when others => -- Everything else + Res := True; + end case; + return Res; + end Eval_As_Boolean; + + + function Eval_Ast + (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + + function Call_Eval (A : Mal_Handle) return Mal_Handle is + begin + return Eval (A, Env); + end Call_Eval; + + begin + + case Deref (Ast).Sym_Type is + + when Sym => + + declare + Sym : Mal_String := Deref_Sym (Ast).Get_Sym; + begin + -- if keyword, return it. Otherwise look it up in the environment. + if Sym(1) = ':' then + return Ast; + else + return Envs.Get (Env, Sym); + end if; + exception + when Envs.Not_Found => + raise Envs.Not_Found with ("'" & Sym & "' not found"); + end; + + when List => + + return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); + + when others => return Ast; + + end case; + + end Eval_Ast; + + + function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) + return Mal_Handle is + Param : Mal_Handle; + Env : Envs.Env_Handle; + First_Param, Rest_Params : Mal_Handle; + Rest_List, Param_List : List_Mal_Type; + begin + + Param := AParam; + Env := AnEnv; + + <> + + if Debug then + Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type = List and then + Deref_List (Param).Get_List_Type = List_List then + + Param_List := Deref_List (Param).all; + + -- Deal with empty list.. + if Param_List.Length = 0 then + return Param; + end if; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "def!" then + return Def_Fn (Rest_List, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "let*" then + declare + Defs, Expr, Res : Mal_Handle; + E : Envs.Env_Handle; + begin + E := Envs.New_Env (Env); + Defs := Car (Rest_List); + Deref_List_Class (Defs).Add_Defs (E); + Expr := Car (Deref_List (Cdr (Rest_List)).all); + Param := Expr; + Env := E; + goto Tail_Call_Opt; + -- was: + -- Res := Eval (Expr, E); + -- return Res; + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "do" then + declare + D : List_Mal_Type; + E : Mal_Handle; + begin + + if Debug then + Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); + end if; + + if Is_Null (Rest_List) then + return Rest_Params; + end if; + + -- Loop processes Evals all but last entry + D := Rest_List; + loop + E := Car (D); + D := Deref_List (Cdr (D)).all; + exit when Is_Null (D); + E := Eval (E, Env); + end loop; + + Param := E; + goto Tail_Call_Opt; + + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "if" then + declare + Args : List_Mal_Type := Rest_List; + + Cond, True_Part, False_Part : Mal_Handle; + Cond_Bool : Boolean; + pragma Assert (Length (Args) = 2 or Length (Args) = 3, + "If_Processing: not 2 or 3 parameters"); + L : List_Mal_Type; + begin + + Cond := Eval (Car (Args), Env); + + Cond_Bool := Eval_As_Boolean (Cond); + + if Cond_Bool then + L := Deref_List (Cdr (Args)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + if Length (Args) = 3 then + L := Deref_List (Cdr (Args)).all; + L := Deref_List (Cdr (L)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + return New_Nil_Mal_Type; + end if; + end if; + end; + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "fn*" then + + return New_Lambda_Mal_Type + (Params => Car (Rest_List), + Expr => Nth (Rest_List, 1), + Env => Env); + + else + + -- The APPLY section. + declare + Evaled_H : Mal_Handle; + begin + Evaled_H := Eval_Ast (Param, Env); + + Param_List := Deref_List (Evaled_H).all; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Func then + return Call_Func (Deref_Func (First_Param).all, Rest_Params); + elsif Deref (First_Param).Sym_Type = Lambda then + declare + + L : Lambda_Mal_Type; + E : Envs.Env_Handle; + Param_Names : List_Mal_Type; + Res : Mal_Handle; + + begin + + L := Deref_Lambda (First_Param).all; + E := Envs.New_Env (L.Get_Env); + + Param_Names := Deref_List (L.Get_Params).all; + + if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then + + Param := L.Get_Expr; + Env := E; + goto Tail_Call_Opt; + -- was: return Eval (L.Get_Expr, E); + + else + + raise Mal_Exception with "Bind failed in Apply"; + + end if; + + end; + + else -- neither a Lambda or a Func + raise Mal_Exception; + end if; + + end; + + end if; + + else -- Not a List_List + + return Eval_Ast (Param, Env); + + end if; + + end Eval; + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String; Env : Envs.Env_Handle) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; + + end Rep; + + + Repl_Env : Envs.Env_Handle; + + + -- These two ops use Repl_Env directly. + + + procedure RE (Str : Mal_String) is + Discarded : Mal_Handle; + begin + Discarded := Eval (Read (Str), Repl_Env); + end RE; + + + function Do_Eval (Rest_Handle : Mal_Handle; Env : Envs.Env_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return Eval_Callback.Eval.all (First_Param, Repl_Env); + end Do_Eval; + + Cmd_Args : Natural; + +begin + + -- Save a function pointer back to the Eval function. + -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK + -- as we know Eval will be in scope for the lifetime of the program. + Eval_Callback.Eval := Eval'Unrestricted_Access; + + Cmd_Args := 0; + while Ada.Command_Line.Argument_Count > Cmd_Args loop + Cmd_Args := Cmd_Args + 1; + if Ada.Command_Line.Argument (Cmd_Args) = "-d" then + Debug := True; + elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then + Envs.Debug := True; + end if; + end loop; + + Repl_Env := Envs.New_Env; + + Core.Init (Repl_Env); + + RE ("(def! not (fn* (a) (if a false true)))"); + + loop + begin + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); + exception + when E : others => + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; + end; + end loop; +end Step5_TCO; diff --git a/impls/ada/step6_file.adb b/impls/ada/step6_file.adb index a02969cc68..881c0b8d13 100644 --- a/impls/ada/step6_file.adb +++ b/impls/ada/step6_file.adb @@ -1,410 +1,410 @@ -with Ada.Command_Line; -with Ada.Exceptions; -with Ada.Text_IO; -with Core; -with Envs; -with Eval_Callback; -with Printer; -with Reader; -with Smart_Pointers; -with Types; - -procedure Step6_File is - - use Types; - - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - - -- Forward declaration of Eval. - function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) - return Types.Mal_Handle; - - - Debug : Boolean := False; - - - function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Fn: expected atom as name"); - Fn_Body := Nth (Args, 1); - Res := Eval (Fn_Body, Env); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Fn; - - - function Eval_As_Boolean (MH : Mal_Handle) return Boolean is - Res : Boolean; - begin - case Deref (MH).Sym_Type is - when Bool => - Res := Deref_Bool (MH).Get_Bool; - when Nil => - return False; --- when List => --- declare --- L : List_Mal_Type; --- begin --- L := Deref_List (MH).all; --- Res := not Is_Null (L); --- end; - when others => -- Everything else - Res := True; - end case; - return Res; - end Eval_As_Boolean; - - - function Eval_Ast - (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - - function Call_Eval (A : Mal_Handle) return Mal_Handle is - begin - return Eval (A, Env); - end Call_Eval; - - begin - - case Deref (Ast).Sym_Type is - - when Sym => - - declare - Sym : Mal_String := Deref_Sym (Ast).Get_Sym; - begin - -- if keyword, return it. Otherwise look it up in the environment. - if Sym(1) = ':' then - return Ast; - else - return Envs.Get (Env, Sym); - end if; - exception - when Envs.Not_Found => - raise Envs.Not_Found with ("'" & Sym & "' not found"); - end; - - when List => - - return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); - - when others => return Ast; - - end case; - - end Eval_Ast; - - - function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) - return Mal_Handle is - Param : Mal_Handle; - Env : Envs.Env_Handle; - First_Param, Rest_Params : Mal_Handle; - Rest_List, Param_List : List_Mal_Type; - begin - - Param := AParam; - Env := AnEnv; - - <> - - if Debug then - Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type = List and then - Deref_List (Param).Get_List_Type = List_List then - - Param_List := Deref_List (Param).all; - - -- Deal with empty list.. - if Param_List.Length = 0 then - return Param; - end if; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "def!" then - return Def_Fn (Rest_List, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "let*" then - declare - Defs, Expr, Res : Mal_Handle; - E : Envs.Env_Handle; - begin - E := Envs.New_Env (Env); - Defs := Car (Rest_List); - Deref_List_Class (Defs).Add_Defs (E); - Expr := Car (Deref_List (Cdr (Rest_List)).all); - Param := Expr; - Env := E; - goto Tail_Call_Opt; - -- was: - -- Res := Eval (Expr, E); - -- return Res; - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "do" then - declare - D : List_Mal_Type; - E : Mal_Handle; - begin - - if Debug then - Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); - end if; - - if Is_Null (Rest_List) then - return Rest_Params; - end if; - - -- Loop processes Evals all but last entry - D := Rest_List; - loop - E := Car (D); - D := Deref_List (Cdr (D)).all; - exit when Is_Null (D); - E := Eval (E, Env); - end loop; - - Param := E; - goto Tail_Call_Opt; - - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "if" then - declare - Args : List_Mal_Type := Rest_List; - - Cond, True_Part, False_Part : Mal_Handle; - Cond_Bool : Boolean; - pragma Assert (Length (Args) = 2 or Length (Args) = 3, - "If_Processing: not 2 or 3 parameters"); - L : List_Mal_Type; - begin - - Cond := Eval (Car (Args), Env); - - Cond_Bool := Eval_As_Boolean (Cond); - - if Cond_Bool then - L := Deref_List (Cdr (Args)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - if Length (Args) = 3 then - L := Deref_List (Cdr (Args)).all; - L := Deref_List (Cdr (L)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - return New_Nil_Mal_Type; - end if; - end if; - end; - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "fn*" then - - return New_Lambda_Mal_Type - (Params => Car (Rest_List), - Expr => Nth (Rest_List, 1), - Env => Env); - - else - - -- The APPLY section. - declare - Evaled_H : Mal_Handle; - begin - Evaled_H := Eval_Ast (Param, Env); - - Param_List := Deref_List (Evaled_H).all; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Func then - return Call_Func (Deref_Func (First_Param).all, Rest_Params); - elsif Deref (First_Param).Sym_Type = Lambda then - declare - - L : Lambda_Mal_Type; - E : Envs.Env_Handle; - Param_Names : List_Mal_Type; - Res : Mal_Handle; - - begin - - L := Deref_Lambda (First_Param).all; - E := Envs.New_Env (L.Get_Env); - - Param_Names := Deref_List (L.Get_Params).all; - - if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then - - Param := L.Get_Expr; - Env := E; - goto Tail_Call_Opt; - -- was: return Eval (L.Get_Expr, E); - - else - - raise Runtime_Exception with "Bind failed in Apply"; - - end if; - - end; - - else -- neither a Lambda or a Func - raise Runtime_Exception with "Deref called on non-Func/Lambda"; - end if; - - end; - - end if; - - else -- not a List_List - - return Eval_Ast (Param, Env); - - end if; - - end Eval; - - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; - - end Rep; - - - Repl_Env : Envs.Env_Handle; - - - -- These two ops use Repl_Env directly. - - - procedure RE (Str : Mal_String) is - Discarded : Mal_Handle; - begin - Discarded := Eval (Read (Str), Repl_Env); - end RE; - - - function Do_Eval (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return Eval_Callback.Eval.all (First_Param, Repl_Env); - end Do_Eval; - - - Cmd_Args, File_Param : Natural; - Command_Args : Types.Mal_Handle; - Command_List : Types.List_Ptr; - File_Processed : Boolean := False; - -begin - - -- Save a function pointer back to the Eval function. - -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK - -- as we know Eval will be in scope for the lifetime of the program. - Eval_Callback.Eval := Eval'Unrestricted_Access; - - Repl_Env := Envs.New_Env; - - -- Core init also creates the first environment. - -- This is needed for the def!'s below. - Core.Init (Repl_Env); - - -- Register the eval command. This needs to be done here rather than Core.Init - -- as it requires direct access to Repl_Env. - Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); - - RE ("(def! not (fn* (a) (if a false true)))"); - RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); - - -- Command line processing. - - Cmd_Args := 0; - Command_Args := Types.New_List_Mal_Type (Types.List_List); - Command_List := Types.Deref_List (Command_Args); - - while Ada.Command_Line.Argument_Count > Cmd_Args loop - - Cmd_Args := Cmd_Args + 1; - if Ada.Command_Line.Argument (Cmd_Args) = "-d" then - Debug := True; - elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then - Envs.Debug := True; - elsif not File_Processed then - File_Param := Cmd_Args; - File_Processed := True; - else - Command_List.Append - (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); - end if; - - end loop; - - Envs.Set (Repl_Env, "*ARGV*", Command_Args); - - if File_Processed then - RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); - else - loop - begin - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); - exception - when E : others => - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - "Error: " & Ada.Exceptions.Exception_Information (E)); - if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - Printer.Pr_Str (Types.Mal_Exception_Value)); - Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; - end if; - end; - end loop; - end if; -end Step6_File; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Text_IO; +with Core; +with Envs; +with Eval_Callback; +with Printer; +with Reader; +with Smart_Pointers; +with Types; + +procedure Step6_File is + + use Types; + + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + -- Forward declaration of Eval. + function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) + return Types.Mal_Handle; + + + Debug : Boolean := False; + + + function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Fn: expected atom as name"); + Fn_Body := Nth (Args, 1); + Res := Eval (Fn_Body, Env); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Fn; + + + function Eval_As_Boolean (MH : Mal_Handle) return Boolean is + Res : Boolean; + begin + case Deref (MH).Sym_Type is + when Bool => + Res := Deref_Bool (MH).Get_Bool; + when Nil => + return False; +-- when List => +-- declare +-- L : List_Mal_Type; +-- begin +-- L := Deref_List (MH).all; +-- Res := not Is_Null (L); +-- end; + when others => -- Everything else + Res := True; + end case; + return Res; + end Eval_As_Boolean; + + + function Eval_Ast + (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + + function Call_Eval (A : Mal_Handle) return Mal_Handle is + begin + return Eval (A, Env); + end Call_Eval; + + begin + + case Deref (Ast).Sym_Type is + + when Sym => + + declare + Sym : Mal_String := Deref_Sym (Ast).Get_Sym; + begin + -- if keyword, return it. Otherwise look it up in the environment. + if Sym(1) = ':' then + return Ast; + else + return Envs.Get (Env, Sym); + end if; + exception + when Envs.Not_Found => + raise Envs.Not_Found with ("'" & Sym & "' not found"); + end; + + when List => + + return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); + + when others => return Ast; + + end case; + + end Eval_Ast; + + + function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) + return Mal_Handle is + Param : Mal_Handle; + Env : Envs.Env_Handle; + First_Param, Rest_Params : Mal_Handle; + Rest_List, Param_List : List_Mal_Type; + begin + + Param := AParam; + Env := AnEnv; + + <> + + if Debug then + Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type = List and then + Deref_List (Param).Get_List_Type = List_List then + + Param_List := Deref_List (Param).all; + + -- Deal with empty list.. + if Param_List.Length = 0 then + return Param; + end if; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "def!" then + return Def_Fn (Rest_List, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "let*" then + declare + Defs, Expr, Res : Mal_Handle; + E : Envs.Env_Handle; + begin + E := Envs.New_Env (Env); + Defs := Car (Rest_List); + Deref_List_Class (Defs).Add_Defs (E); + Expr := Car (Deref_List (Cdr (Rest_List)).all); + Param := Expr; + Env := E; + goto Tail_Call_Opt; + -- was: + -- Res := Eval (Expr, E); + -- return Res; + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "do" then + declare + D : List_Mal_Type; + E : Mal_Handle; + begin + + if Debug then + Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); + end if; + + if Is_Null (Rest_List) then + return Rest_Params; + end if; + + -- Loop processes Evals all but last entry + D := Rest_List; + loop + E := Car (D); + D := Deref_List (Cdr (D)).all; + exit when Is_Null (D); + E := Eval (E, Env); + end loop; + + Param := E; + goto Tail_Call_Opt; + + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "if" then + declare + Args : List_Mal_Type := Rest_List; + + Cond, True_Part, False_Part : Mal_Handle; + Cond_Bool : Boolean; + pragma Assert (Length (Args) = 2 or Length (Args) = 3, + "If_Processing: not 2 or 3 parameters"); + L : List_Mal_Type; + begin + + Cond := Eval (Car (Args), Env); + + Cond_Bool := Eval_As_Boolean (Cond); + + if Cond_Bool then + L := Deref_List (Cdr (Args)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + if Length (Args) = 3 then + L := Deref_List (Cdr (Args)).all; + L := Deref_List (Cdr (L)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + return New_Nil_Mal_Type; + end if; + end if; + end; + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "fn*" then + + return New_Lambda_Mal_Type + (Params => Car (Rest_List), + Expr => Nth (Rest_List, 1), + Env => Env); + + else + + -- The APPLY section. + declare + Evaled_H : Mal_Handle; + begin + Evaled_H := Eval_Ast (Param, Env); + + Param_List := Deref_List (Evaled_H).all; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Func then + return Call_Func (Deref_Func (First_Param).all, Rest_Params); + elsif Deref (First_Param).Sym_Type = Lambda then + declare + + L : Lambda_Mal_Type; + E : Envs.Env_Handle; + Param_Names : List_Mal_Type; + Res : Mal_Handle; + + begin + + L := Deref_Lambda (First_Param).all; + E := Envs.New_Env (L.Get_Env); + + Param_Names := Deref_List (L.Get_Params).all; + + if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then + + Param := L.Get_Expr; + Env := E; + goto Tail_Call_Opt; + -- was: return Eval (L.Get_Expr, E); + + else + + raise Runtime_Exception with "Bind failed in Apply"; + + end if; + + end; + + else -- neither a Lambda or a Func + raise Runtime_Exception with "Deref called on non-Func/Lambda"; + end if; + + end; + + end if; + + else -- not a List_List + + return Eval_Ast (Param, Env); + + end if; + + end Eval; + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String; Env : Envs.Env_Handle) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; + + end Rep; + + + Repl_Env : Envs.Env_Handle; + + + -- These two ops use Repl_Env directly. + + + procedure RE (Str : Mal_String) is + Discarded : Mal_Handle; + begin + Discarded := Eval (Read (Str), Repl_Env); + end RE; + + + function Do_Eval (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return Eval_Callback.Eval.all (First_Param, Repl_Env); + end Do_Eval; + + + Cmd_Args, File_Param : Natural; + Command_Args : Types.Mal_Handle; + Command_List : Types.List_Ptr; + File_Processed : Boolean := False; + +begin + + -- Save a function pointer back to the Eval function. + -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK + -- as we know Eval will be in scope for the lifetime of the program. + Eval_Callback.Eval := Eval'Unrestricted_Access; + + Repl_Env := Envs.New_Env; + + -- Core init also creates the first environment. + -- This is needed for the def!'s below. + Core.Init (Repl_Env); + + -- Register the eval command. This needs to be done here rather than Core.Init + -- as it requires direct access to Repl_Env. + Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); + + RE ("(def! not (fn* (a) (if a false true)))"); + RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); + + -- Command line processing. + + Cmd_Args := 0; + Command_Args := Types.New_List_Mal_Type (Types.List_List); + Command_List := Types.Deref_List (Command_Args); + + while Ada.Command_Line.Argument_Count > Cmd_Args loop + + Cmd_Args := Cmd_Args + 1; + if Ada.Command_Line.Argument (Cmd_Args) = "-d" then + Debug := True; + elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then + Envs.Debug := True; + elsif not File_Processed then + File_Param := Cmd_Args; + File_Processed := True; + else + Command_List.Append + (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); + end if; + + end loop; + + Envs.Set (Repl_Env, "*ARGV*", Command_Args); + + if File_Processed then + RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); + else + loop + begin + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); + exception + when E : others => + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; + end; + end loop; + end if; +end Step6_File; diff --git a/impls/ada/step7_quote.adb b/impls/ada/step7_quote.adb index 52babdae9f..f0f10fd249 100644 --- a/impls/ada/step7_quote.adb +++ b/impls/ada/step7_quote.adb @@ -1,499 +1,499 @@ -with Ada.Command_Line; -with Ada.Exceptions; -with Ada.Text_IO; -with Core; -with Envs; -with Eval_Callback; -with Printer; -with Reader; -with Smart_Pointers; -with Types; - -procedure Step7_Quote is - - use Types; - - function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) - return Types.Mal_Handle; - - Debug : Boolean := False; - - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - - function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Fn: expected atom as name"); - Fn_Body := Nth (Args, 1); - Res := Eval (Fn_Body, Env); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Fn; - - - function Eval_As_Boolean (MH : Mal_Handle) return Boolean is - Res : Boolean; - begin - case Deref (MH).Sym_Type is - when Bool => - Res := Deref_Bool (MH).Get_Bool; - when Nil => - return False; --- when List => --- declare --- L : List_Mal_Type; --- begin --- L := Deref_List (MH).all; --- Res := not Is_Null (L); --- end; - when others => -- Everything else - Res := True; - end case; - return Res; - end Eval_As_Boolean; - - - function Eval_Ast - (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - - function Call_Eval (A : Mal_Handle) return Mal_Handle is - begin - return Eval (A, Env); - end Call_Eval; - - begin - - case Deref (Ast).Sym_Type is - - when Sym => - - declare - Sym : Mal_String := Deref_Sym (Ast).Get_Sym; - begin - -- if keyword, return it. Otherwise look it up in the environment. - if Sym(1) = ':' then - return Ast; - else - return Envs.Get (Env, Sym); - end if; - exception - when Envs.Not_Found => - raise Envs.Not_Found with ("'" & Sym & "' not found"); - end; - - when List => - - return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); - - when others => return Ast; - - end case; - - end Eval_Ast; - - function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is - A0 : Mal_Handle; - begin - if Deref (Ast).Sym_Type /= List - or else Deref_List_Class (Ast).Get_List_Type /= List_List - or else Deref_List (Ast).Is_Null - then - return False; - end if; - A0 := Deref_List (Ast).Car; - return Deref (A0).Sym_Type = Sym - and then Deref_Sym (A0).Get_Sym = Symbol; - end Starts_With; - - function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is - Res, Elt, New_Res : Mal_Handle; - L : List_Ptr; - begin - - if Debug then - Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type not in Sym | List then - -- No need to quote, Eval would not affect these anyway. - return Param; - end if; - - if Deref (Param).Sym_Type /= List or else - Deref_List_Class (Param).Get_List_Type = Hashed_List then - - -- return a new list containing: a symbol named "quote" and ast. - Res := New_List_Mal_Type (List_List); - L := Deref_List (Res); - L.Append (New_Symbol_Mal_Type ("quote")); - L.Append (Param); - return Res; - - end if; - - -- if the first element of ast is a symbol named "unquote": - if Starts_With (Param, "unquote") then - -- return the second element of ast.` - return Deref_List_Class (Param).Nth (1); - - end if; - - Res := New_List_Mal_Type (List_List); - - for I in reverse 0 .. Deref_List_Class (Param).Length - 1 loop - Elt := Deref_List_Class (Param).Nth (I); - New_Res := New_List_Mal_Type (List_List); - L := Deref_List (New_Res); - if Starts_With (Elt, "splice-unquote") then - L.Append (New_Symbol_Mal_Type ("concat")); - L.Append (Deref_List (Elt).Nth (1)); - else - L.Append (New_Symbol_Mal_Type ("cons")); - L.Append (Quasi_Quote_Processing (Elt)); - end if; - L.Append (Res); - Res := New_Res; - end loop; - - if Deref_List_Class (Param).Get_List_Type = Vector_List then - New_Res := New_List_Mal_Type (List_List); - L := Deref_List (New_Res); - L.Append (New_Symbol_Mal_Type ("vec")); - L.Append (Res); - Res := New_Res; - end if; - - return Res; - - end Quasi_Quote_Processing; - - - function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) - return Mal_Handle is - Param : Mal_Handle; - Env : Envs.Env_Handle; - First_Param, Rest_Params : Mal_Handle; - Rest_List, Param_List : List_Mal_Type; - begin - - Param := AParam; - Env := AnEnv; - - <> - - if Debug then - Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type = List and then - Deref_List (Param).Get_List_Type = List_List then - - Param_List := Deref_List (Param).all; - - -- Deal with empty list.. - if Param_List.Length = 0 then - return Param; - end if; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "def!" then - return Def_Fn (Rest_List, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "let*" then - declare - Defs, Expr, Res : Mal_Handle; - E : Envs.Env_Handle; - begin - E := Envs.New_Env (Env); - Defs := Car (Rest_List); - Deref_List_Class (Defs).Add_Defs (E); - Expr := Car (Deref_List (Cdr (Rest_List)).all); - Param := Expr; - Env := E; - goto Tail_Call_Opt; - -- was: - -- Res := Eval (Expr, E); - -- return Res; - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "do" then - declare - D : List_Mal_Type; - E : Mal_Handle; - begin - - if Debug then - Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); - end if; - - if Is_Null (Rest_List) then - return Rest_Params; - end if; - - -- Loop processes Evals all but last entry - D := Rest_List; - loop - E := Car (D); - D := Deref_List (Cdr (D)).all; - exit when Is_Null (D); - E := Eval (E, Env); - end loop; - - Param := E; - goto Tail_Call_Opt; - - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "if" then - declare - Args : List_Mal_Type := Rest_List; - - Cond, True_Part, False_Part : Mal_Handle; - Cond_Bool : Boolean; - pragma Assert (Length (Args) = 2 or Length (Args) = 3, - "If_Processing: not 2 or 3 parameters"); - L : List_Mal_Type; - begin - - Cond := Eval (Car (Args), Env); - - Cond_Bool := Eval_As_Boolean (Cond); - - if Cond_Bool then - L := Deref_List (Cdr (Args)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - if Length (Args) = 3 then - L := Deref_List (Cdr (Args)).all; - L := Deref_List (Cdr (L)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - return New_Nil_Mal_Type; - end if; - end if; - end; - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "fn*" then - - return New_Lambda_Mal_Type - (Params => Car (Rest_List), - Expr => Nth (Rest_List, 1), - Env => Env); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quote" then - - return Car (Rest_List); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then - - return Quasi_Quote_Processing (Car (Rest_List)); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quasiquote" then - - Param := Quasi_Quote_Processing (Car (Rest_List)); - goto Tail_Call_Opt; - - else - - -- The APPLY section. - declare - Evaled_H : Mal_Handle; - begin - Evaled_H := Eval_Ast (Param, Env); - - Param_List := Deref_List (Evaled_H).all; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Func then - return Call_Func (Deref_Func (First_Param).all, Rest_Params); - elsif Deref (First_Param).Sym_Type = Lambda then - declare - - L : Lambda_Mal_Type; - E : Envs.Env_Handle; - Param_Names : List_Mal_Type; - Res : Mal_Handle; - - begin - - L := Deref_Lambda (First_Param).all; - E := Envs.New_Env (L.Get_Env); - - Param_Names := Deref_List (L.Get_Params).all; - - if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then - - Param := L.Get_Expr; - Env := E; - goto Tail_Call_Opt; - -- was: return Eval (L.Get_Expr, E); - - else - - raise Runtime_Exception with "Bind failed in Apply"; - - end if; - - end; - - else -- neither a Lambda or a Func - raise Runtime_Exception with "Deref called on non-Func/Lambda"; - end if; - - end; - - end if; - - else -- not a List_List - - return Eval_Ast (Param, Env); - - end if; - - end Eval; - - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; - - end Rep; - - - Repl_Env : Envs.Env_Handle; - - - -- These two ops use Repl_Env directly. - - - procedure RE (Str : Mal_String) is - Discarded : Mal_Handle; - begin - Discarded := Eval (Read (Str), Repl_Env); - end RE; - - - function Do_Eval (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return Eval_Callback.Eval.all (First_Param, Repl_Env); - end Do_Eval; - - - Cmd_Args, File_Param : Natural; - Command_Args : Types.Mal_Handle; - Command_List : Types.List_Ptr; - File_Processed : Boolean := False; - -begin - - -- Save a function pointer back to the Eval function. - -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK - -- as we know Eval will be in scope for the lifetime of the program. - Eval_Callback.Eval := Eval'Unrestricted_Access; - - Repl_Env := Envs.New_Env; - - -- Core init also creates the first environment. - -- This is needed for the def!'s below. - Core.Init (Repl_Env); - - -- Register the eval command. This needs to be done here rather than Core.Init - -- as it requires direct access to Repl_Env. - Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); - - RE ("(def! not (fn* (a) (if a false true)))"); - RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); - - -- Command line processing. - - Cmd_Args := 0; - Command_Args := Types.New_List_Mal_Type (Types.List_List); - Command_List := Types.Deref_List (Command_Args); - - while Ada.Command_Line.Argument_Count > Cmd_Args loop - - Cmd_Args := Cmd_Args + 1; - if Ada.Command_Line.Argument (Cmd_Args) = "-d" then - Debug := True; - elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then - Envs.Debug := True; - elsif not File_Processed then - File_Param := Cmd_Args; - File_Processed := True; - else - Command_List.Append - (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); - end if; - - end loop; - - Envs.Set (Repl_Env, "*ARGV*", Command_Args); - - if File_Processed then - RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); - else - loop - begin - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); - exception - when E : others => - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - "Error: " & Ada.Exceptions.Exception_Information (E)); - if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - Printer.Pr_Str (Types.Mal_Exception_Value)); - Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; - end if; - end; - end loop; - end if; -end Step7_Quote; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Text_IO; +with Core; +with Envs; +with Eval_Callback; +with Printer; +with Reader; +with Smart_Pointers; +with Types; + +procedure Step7_Quote is + + use Types; + + function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) + return Types.Mal_Handle; + + Debug : Boolean := False; + + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Fn: expected atom as name"); + Fn_Body := Nth (Args, 1); + Res := Eval (Fn_Body, Env); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Fn; + + + function Eval_As_Boolean (MH : Mal_Handle) return Boolean is + Res : Boolean; + begin + case Deref (MH).Sym_Type is + when Bool => + Res := Deref_Bool (MH).Get_Bool; + when Nil => + return False; +-- when List => +-- declare +-- L : List_Mal_Type; +-- begin +-- L := Deref_List (MH).all; +-- Res := not Is_Null (L); +-- end; + when others => -- Everything else + Res := True; + end case; + return Res; + end Eval_As_Boolean; + + + function Eval_Ast + (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + + function Call_Eval (A : Mal_Handle) return Mal_Handle is + begin + return Eval (A, Env); + end Call_Eval; + + begin + + case Deref (Ast).Sym_Type is + + when Sym => + + declare + Sym : Mal_String := Deref_Sym (Ast).Get_Sym; + begin + -- if keyword, return it. Otherwise look it up in the environment. + if Sym(1) = ':' then + return Ast; + else + return Envs.Get (Env, Sym); + end if; + exception + when Envs.Not_Found => + raise Envs.Not_Found with ("'" & Sym & "' not found"); + end; + + when List => + + return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); + + when others => return Ast; + + end case; + + end Eval_Ast; + + function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is + A0 : Mal_Handle; + begin + if Deref (Ast).Sym_Type /= List + or else Deref_List_Class (Ast).Get_List_Type /= List_List + or else Deref_List (Ast).Is_Null + then + return False; + end if; + A0 := Deref_List (Ast).Car; + return Deref (A0).Sym_Type = Sym + and then Deref_Sym (A0).Get_Sym = Symbol; + end Starts_With; + + function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is + Res, Elt, New_Res : Mal_Handle; + L : List_Ptr; + begin + + if Debug then + Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type not in Sym | List then + -- No need to quote, Eval would not affect these anyway. + return Param; + end if; + + if Deref (Param).Sym_Type /= List or else + Deref_List_Class (Param).Get_List_Type = Hashed_List then + + -- return a new list containing: a symbol named "quote" and ast. + Res := New_List_Mal_Type (List_List); + L := Deref_List (Res); + L.Append (New_Symbol_Mal_Type ("quote")); + L.Append (Param); + return Res; + + end if; + + -- if the first element of ast is a symbol named "unquote": + if Starts_With (Param, "unquote") then + -- return the second element of ast.` + return Deref_List_Class (Param).Nth (1); + + end if; + + Res := New_List_Mal_Type (List_List); + + for I in reverse 0 .. Deref_List_Class (Param).Length - 1 loop + Elt := Deref_List_Class (Param).Nth (I); + New_Res := New_List_Mal_Type (List_List); + L := Deref_List (New_Res); + if Starts_With (Elt, "splice-unquote") then + L.Append (New_Symbol_Mal_Type ("concat")); + L.Append (Deref_List (Elt).Nth (1)); + else + L.Append (New_Symbol_Mal_Type ("cons")); + L.Append (Quasi_Quote_Processing (Elt)); + end if; + L.Append (Res); + Res := New_Res; + end loop; + + if Deref_List_Class (Param).Get_List_Type = Vector_List then + New_Res := New_List_Mal_Type (List_List); + L := Deref_List (New_Res); + L.Append (New_Symbol_Mal_Type ("vec")); + L.Append (Res); + Res := New_Res; + end if; + + return Res; + + end Quasi_Quote_Processing; + + + function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) + return Mal_Handle is + Param : Mal_Handle; + Env : Envs.Env_Handle; + First_Param, Rest_Params : Mal_Handle; + Rest_List, Param_List : List_Mal_Type; + begin + + Param := AParam; + Env := AnEnv; + + <> + + if Debug then + Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type = List and then + Deref_List (Param).Get_List_Type = List_List then + + Param_List := Deref_List (Param).all; + + -- Deal with empty list.. + if Param_List.Length = 0 then + return Param; + end if; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "def!" then + return Def_Fn (Rest_List, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "let*" then + declare + Defs, Expr, Res : Mal_Handle; + E : Envs.Env_Handle; + begin + E := Envs.New_Env (Env); + Defs := Car (Rest_List); + Deref_List_Class (Defs).Add_Defs (E); + Expr := Car (Deref_List (Cdr (Rest_List)).all); + Param := Expr; + Env := E; + goto Tail_Call_Opt; + -- was: + -- Res := Eval (Expr, E); + -- return Res; + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "do" then + declare + D : List_Mal_Type; + E : Mal_Handle; + begin + + if Debug then + Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); + end if; + + if Is_Null (Rest_List) then + return Rest_Params; + end if; + + -- Loop processes Evals all but last entry + D := Rest_List; + loop + E := Car (D); + D := Deref_List (Cdr (D)).all; + exit when Is_Null (D); + E := Eval (E, Env); + end loop; + + Param := E; + goto Tail_Call_Opt; + + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "if" then + declare + Args : List_Mal_Type := Rest_List; + + Cond, True_Part, False_Part : Mal_Handle; + Cond_Bool : Boolean; + pragma Assert (Length (Args) = 2 or Length (Args) = 3, + "If_Processing: not 2 or 3 parameters"); + L : List_Mal_Type; + begin + + Cond := Eval (Car (Args), Env); + + Cond_Bool := Eval_As_Boolean (Cond); + + if Cond_Bool then + L := Deref_List (Cdr (Args)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + if Length (Args) = 3 then + L := Deref_List (Cdr (Args)).all; + L := Deref_List (Cdr (L)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + return New_Nil_Mal_Type; + end if; + end if; + end; + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "fn*" then + + return New_Lambda_Mal_Type + (Params => Car (Rest_List), + Expr => Nth (Rest_List, 1), + Env => Env); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quote" then + + return Car (Rest_List); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then + + return Quasi_Quote_Processing (Car (Rest_List)); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quasiquote" then + + Param := Quasi_Quote_Processing (Car (Rest_List)); + goto Tail_Call_Opt; + + else + + -- The APPLY section. + declare + Evaled_H : Mal_Handle; + begin + Evaled_H := Eval_Ast (Param, Env); + + Param_List := Deref_List (Evaled_H).all; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Func then + return Call_Func (Deref_Func (First_Param).all, Rest_Params); + elsif Deref (First_Param).Sym_Type = Lambda then + declare + + L : Lambda_Mal_Type; + E : Envs.Env_Handle; + Param_Names : List_Mal_Type; + Res : Mal_Handle; + + begin + + L := Deref_Lambda (First_Param).all; + E := Envs.New_Env (L.Get_Env); + + Param_Names := Deref_List (L.Get_Params).all; + + if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then + + Param := L.Get_Expr; + Env := E; + goto Tail_Call_Opt; + -- was: return Eval (L.Get_Expr, E); + + else + + raise Runtime_Exception with "Bind failed in Apply"; + + end if; + + end; + + else -- neither a Lambda or a Func + raise Runtime_Exception with "Deref called on non-Func/Lambda"; + end if; + + end; + + end if; + + else -- not a List_List + + return Eval_Ast (Param, Env); + + end if; + + end Eval; + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String; Env : Envs.Env_Handle) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; + + end Rep; + + + Repl_Env : Envs.Env_Handle; + + + -- These two ops use Repl_Env directly. + + + procedure RE (Str : Mal_String) is + Discarded : Mal_Handle; + begin + Discarded := Eval (Read (Str), Repl_Env); + end RE; + + + function Do_Eval (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return Eval_Callback.Eval.all (First_Param, Repl_Env); + end Do_Eval; + + + Cmd_Args, File_Param : Natural; + Command_Args : Types.Mal_Handle; + Command_List : Types.List_Ptr; + File_Processed : Boolean := False; + +begin + + -- Save a function pointer back to the Eval function. + -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK + -- as we know Eval will be in scope for the lifetime of the program. + Eval_Callback.Eval := Eval'Unrestricted_Access; + + Repl_Env := Envs.New_Env; + + -- Core init also creates the first environment. + -- This is needed for the def!'s below. + Core.Init (Repl_Env); + + -- Register the eval command. This needs to be done here rather than Core.Init + -- as it requires direct access to Repl_Env. + Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); + + RE ("(def! not (fn* (a) (if a false true)))"); + RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); + + -- Command line processing. + + Cmd_Args := 0; + Command_Args := Types.New_List_Mal_Type (Types.List_List); + Command_List := Types.Deref_List (Command_Args); + + while Ada.Command_Line.Argument_Count > Cmd_Args loop + + Cmd_Args := Cmd_Args + 1; + if Ada.Command_Line.Argument (Cmd_Args) = "-d" then + Debug := True; + elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then + Envs.Debug := True; + elsif not File_Processed then + File_Param := Cmd_Args; + File_Processed := True; + else + Command_List.Append + (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); + end if; + + end loop; + + Envs.Set (Repl_Env, "*ARGV*", Command_Args); + + if File_Processed then + RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); + else + loop + begin + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); + exception + when E : others => + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; + end; + end loop; + end if; +end Step7_Quote; diff --git a/impls/ada/step8_macros.adb b/impls/ada/step8_macros.adb index 5c6a0a1199..3ed83d6466 100644 --- a/impls/ada/step8_macros.adb +++ b/impls/ada/step8_macros.adb @@ -1,578 +1,578 @@ -with Ada.Command_Line; -with Ada.Exceptions; -with Ada.Text_IO; -with Core; -with Envs; -with Eval_Callback; -with Printer; -with Reader; -with Smart_Pointers; -with Types; - -procedure Step8_Macros is - - use Types; - - function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) - return Types.Mal_Handle; - - Debug : Boolean := False; - - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - - function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Fn: expected atom as name"); - Fn_Body := Nth (Args, 1); - Res := Eval (Fn_Body, Env); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Fn; - - - function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - Lambda_P : Lambda_Ptr; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Macro: expected atom as name"); - Fn_Body := Car (Deref_List (Cdr (Args)).all); - Res := Eval (Fn_Body, Env); - Lambda_P := Deref_Lambda (Res); - Res := New_Lambda_Mal_Type (Params => Lambda_P.all.Get_Params, - Expr => Lambda_P.all.Get_Expr, - Env => Lambda_P.all.Get_Env); - Deref_Lambda (Res).Set_Is_Macro (True); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Macro; - - - function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - Res : Mal_Handle; - E : Envs.Env_Handle; - LMT : List_Mal_Type; - LP : Lambda_Ptr; - begin - - Res := Ast; - - loop - - if Deref (Res).Sym_Type /= List then - exit; - end if; - - LMT := Deref_List (Res).all; - - -- Get the macro in the list from the env - -- or return null if not applicable. - LP := Get_Macro (Res, Env); - - exit when LP = null or else not LP.Get_Is_Macro; - - declare - Fn_List : Mal_Handle := Cdr (LMT); - Params : List_Mal_Type; - begin - E := Envs.New_Env (LP.Get_Env); - - Params := Deref_List (LP.Get_Params).all; - if Envs.Bind (E, Params, Deref_List (Fn_List).all) then - - Res := Eval (LP.Get_Expr, E); - - end if; - - end; - - end loop; - - return Res; - - end Macro_Expand; - - - function Eval_As_Boolean (MH : Mal_Handle) return Boolean is - Res : Boolean; - begin - case Deref (MH).Sym_Type is - when Bool => - Res := Deref_Bool (MH).Get_Bool; - when Nil => - return False; --- when List => --- declare --- L : List_Mal_Type; --- begin --- L := Deref_List (MH).all; --- Res := not Is_Null (L); --- end; - when others => -- Everything else - Res := True; - end case; - return Res; - end Eval_As_Boolean; - - - function Eval_Ast - (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - - function Call_Eval (A : Mal_Handle) return Mal_Handle is - begin - return Eval (A, Env); - end Call_Eval; - - begin - - case Deref (Ast).Sym_Type is - - when Sym => - - declare - Sym : Mal_String := Deref_Sym (Ast).Get_Sym; - begin - -- if keyword, return it. Otherwise look it up in the environment. - if Sym(1) = ':' then - return Ast; - else - return Envs.Get (Env, Sym); - end if; - exception - when Envs.Not_Found => - raise Envs.Not_Found with ("'" & Sym & "' not found"); - end; - - when List => - - return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); - - when others => return Ast; - - end case; - - end Eval_Ast; - - function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is - A0 : Mal_Handle; - begin - if Deref (Ast).Sym_Type /= List - or else Deref_List_Class (Ast).Get_List_Type /= List_List - or else Deref_List (Ast).Is_Null - then - return False; - end if; - A0 := Deref_List (Ast).Car; - return Deref (A0).Sym_Type = Sym - and then Deref_Sym (A0).Get_Sym = Symbol; - end Starts_With; - - function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is - Res, Elt, New_Res : Mal_Handle; - L : List_Ptr; - begin - - if Debug then - Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type not in Sym | List then - -- No need to quote, Eval would not affect these anyway. - return Param; - end if; - - if Deref (Param).Sym_Type /= List or else - Deref_List_Class (Param).Get_List_Type = Hashed_List then - - -- return a new list containing: a symbol named "quote" and ast. - Res := New_List_Mal_Type (List_List); - L := Deref_List (Res); - L.Append (New_Symbol_Mal_Type ("quote")); - L.Append (Param); - return Res; - - end if; - - -- if the first element of ast is a symbol named "unquote": - if Starts_With (Param, "unquote") then - -- return the second element of ast.` - return Deref_List_Class (Param).Nth (1); - - end if; - - Res := New_List_Mal_Type (List_List); - - for I in reverse 0 .. Deref_List_Class (Param).Length - 1 loop - Elt := Deref_List_Class (Param).Nth (I); - New_Res := New_List_Mal_Type (List_List); - L := Deref_List (New_Res); - if Starts_With (Elt, "splice-unquote") then - L.Append (New_Symbol_Mal_Type ("concat")); - L.Append (Deref_List (Elt).Nth (1)); - else - L.Append (New_Symbol_Mal_Type ("cons")); - L.Append (Quasi_Quote_Processing (Elt)); - end if; - L.Append (Res); - Res := New_Res; - end loop; - - if Deref_List_Class (Param).Get_List_Type = Vector_List then - New_Res := New_List_Mal_Type (List_List); - L := Deref_List (New_Res); - L.Append (New_Symbol_Mal_Type ("vec")); - L.Append (Res); - Res := New_Res; - end if; - - return Res; - - end Quasi_Quote_Processing; - - - function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) - return Mal_Handle is - Param : Mal_Handle; - Env : Envs.Env_Handle; - First_Param, Rest_Params : Mal_Handle; - Rest_List, Param_List : List_Mal_Type; - begin - - Param := AParam; - Env := AnEnv; - - <> - - if Debug then - Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); - end if; - - Param := Macro_Expand (Param, Env); - - if Debug then - Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type = List and then - Deref_List (Param).Get_List_Type = List_List then - - Param_List := Deref_List (Param).all; - - -- Deal with empty list.. - if Param_List.Length = 0 then - return Param; - end if; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "def!" then - return Def_Fn (Rest_List, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "defmacro!" then - return Def_Macro (Rest_List, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "macroexpand" then - return Macro_Expand (Car (Rest_List), Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "let*" then - declare - Defs, Expr, Res : Mal_Handle; - E : Envs.Env_Handle; - begin - E := Envs.New_Env (Env); - Defs := Car (Rest_List); - Deref_List_Class (Defs).Add_Defs (E); - Expr := Car (Deref_List (Cdr (Rest_List)).all); - Param := Expr; - Env := E; - goto Tail_Call_Opt; - -- was: - -- Res := Eval (Expr, E); - -- return Res; - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "do" then - declare - D : List_Mal_Type; - E : Mal_Handle; - begin - - if Debug then - Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); - end if; - - if Is_Null (Rest_List) then - return Rest_Params; - end if; - - -- Loop processes Evals all but last entry - D := Rest_List; - loop - E := Car (D); - D := Deref_List (Cdr (D)).all; - exit when Is_Null (D); - E := Eval (E, Env); - end loop; - - Param := E; - goto Tail_Call_Opt; - - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "if" then - declare - Args : List_Mal_Type := Rest_List; - - Cond, True_Part, False_Part : Mal_Handle; - Cond_Bool : Boolean; - pragma Assert (Length (Args) = 2 or Length (Args) = 3, - "If_Processing: not 2 or 3 parameters"); - L : List_Mal_Type; - begin - - Cond := Eval (Car (Args), Env); - - Cond_Bool := Eval_As_Boolean (Cond); - - if Cond_Bool then - L := Deref_List (Cdr (Args)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - if Length (Args) = 3 then - L := Deref_List (Cdr (Args)).all; - L := Deref_List (Cdr (L)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - return New_Nil_Mal_Type; - end if; - end if; - end; - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "fn*" then - - return New_Lambda_Mal_Type - (Params => Car (Rest_List), - Expr => Nth (Rest_List, 1), - Env => Env); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quote" then - - return Car (Rest_List); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then - - return Quasi_Quote_Processing (Car (Rest_List)); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quasiquote" then - - Param := Quasi_Quote_Processing (Car (Rest_List)); - goto Tail_Call_Opt; - - else - - -- The APPLY section. - declare - Evaled_H : Mal_Handle; - begin - Evaled_H := Eval_Ast (Param, Env); - - Param_List := Deref_List (Evaled_H).all; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Func then - return Call_Func (Deref_Func (First_Param).all, Rest_Params); - elsif Deref (First_Param).Sym_Type = Lambda then - declare - - L : Lambda_Mal_Type; - E : Envs.Env_Handle; - Param_Names : List_Mal_Type; - Res : Mal_Handle; - - begin - - L := Deref_Lambda (First_Param).all; - E := Envs.New_Env (L.Get_Env); - - Param_Names := Deref_List (L.Get_Params).all; - - if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then - - Param := L.Get_Expr; - Env := E; - goto Tail_Call_Opt; - -- was: return Eval (L.Get_Expr, E); - - else - - raise Runtime_Exception with "Bind failed in Apply"; - - end if; - - end; - - else -- neither a Lambda or a Func - raise Runtime_Exception with "Deref called on non-Func/Lambda"; - end if; - - end; - - end if; - - else -- not a List_List - - return Eval_Ast (Param, Env); - - end if; - - end Eval; - - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; - - end Rep; - - - Repl_Env : Envs.Env_Handle; - - - -- These two ops use Repl_Env directly. - - - procedure RE (Str : Mal_String) is - Discarded : Mal_Handle; - begin - Discarded := Eval (Read (Str), Repl_Env); - end RE; - - - function Do_Eval (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return Eval_Callback.Eval.all (First_Param, Repl_Env); - end Do_Eval; - - - Cmd_Args, File_Param : Natural; - Command_Args : Types.Mal_Handle; - Command_List : Types.List_Ptr; - File_Processed : Boolean := False; - -begin - - -- Save a function pointer back to the Eval function. - -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK - -- as we know Eval will be in scope for the lifetime of the program. - Eval_Callback.Eval := Eval'Unrestricted_Access; - - Repl_Env := Envs.New_Env; - - -- Core init also creates the first environment. - -- This is needed for the def!'s below. - Core.Init (Repl_Env); - - -- Register the eval command. This needs to be done here rather than Core.Init - -- as it requires direct access to Repl_Env. - Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); - - RE ("(def! not (fn* (a) (if a false true)))"); - RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); - RE ("(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)))))))"); - - -- Command line processing. - - Cmd_Args := 0; - Command_Args := Types.New_List_Mal_Type (Types.List_List); - Command_List := Types.Deref_List (Command_Args); - - while Ada.Command_Line.Argument_Count > Cmd_Args loop - - Cmd_Args := Cmd_Args + 1; - if Ada.Command_Line.Argument (Cmd_Args) = "-d" then - Debug := True; - elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then - Envs.Debug := True; - elsif not File_Processed then - File_Param := Cmd_Args; - File_Processed := True; - else - Command_List.Append - (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); - end if; - - end loop; - - Envs.Set (Repl_Env, "*ARGV*", Command_Args); - - if File_Processed then - RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); - else - loop - begin - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); - exception - when E : others => - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - "Error: " & Ada.Exceptions.Exception_Information (E)); - if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - Printer.Pr_Str (Types.Mal_Exception_Value)); - Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; - end if; - end; - end loop; - end if; -end Step8_Macros; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Text_IO; +with Core; +with Envs; +with Eval_Callback; +with Printer; +with Reader; +with Smart_Pointers; +with Types; + +procedure Step8_Macros is + + use Types; + + function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) + return Types.Mal_Handle; + + Debug : Boolean := False; + + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Fn: expected atom as name"); + Fn_Body := Nth (Args, 1); + Res := Eval (Fn_Body, Env); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Fn; + + + function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + Lambda_P : Lambda_Ptr; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Macro: expected atom as name"); + Fn_Body := Car (Deref_List (Cdr (Args)).all); + Res := Eval (Fn_Body, Env); + Lambda_P := Deref_Lambda (Res); + Res := New_Lambda_Mal_Type (Params => Lambda_P.all.Get_Params, + Expr => Lambda_P.all.Get_Expr, + Env => Lambda_P.all.Get_Env); + Deref_Lambda (Res).Set_Is_Macro (True); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Macro; + + + function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + Res : Mal_Handle; + E : Envs.Env_Handle; + LMT : List_Mal_Type; + LP : Lambda_Ptr; + begin + + Res := Ast; + + loop + + if Deref (Res).Sym_Type /= List then + exit; + end if; + + LMT := Deref_List (Res).all; + + -- Get the macro in the list from the env + -- or return null if not applicable. + LP := Get_Macro (Res, Env); + + exit when LP = null or else not LP.Get_Is_Macro; + + declare + Fn_List : Mal_Handle := Cdr (LMT); + Params : List_Mal_Type; + begin + E := Envs.New_Env (LP.Get_Env); + + Params := Deref_List (LP.Get_Params).all; + if Envs.Bind (E, Params, Deref_List (Fn_List).all) then + + Res := Eval (LP.Get_Expr, E); + + end if; + + end; + + end loop; + + return Res; + + end Macro_Expand; + + + function Eval_As_Boolean (MH : Mal_Handle) return Boolean is + Res : Boolean; + begin + case Deref (MH).Sym_Type is + when Bool => + Res := Deref_Bool (MH).Get_Bool; + when Nil => + return False; +-- when List => +-- declare +-- L : List_Mal_Type; +-- begin +-- L := Deref_List (MH).all; +-- Res := not Is_Null (L); +-- end; + when others => -- Everything else + Res := True; + end case; + return Res; + end Eval_As_Boolean; + + + function Eval_Ast + (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + + function Call_Eval (A : Mal_Handle) return Mal_Handle is + begin + return Eval (A, Env); + end Call_Eval; + + begin + + case Deref (Ast).Sym_Type is + + when Sym => + + declare + Sym : Mal_String := Deref_Sym (Ast).Get_Sym; + begin + -- if keyword, return it. Otherwise look it up in the environment. + if Sym(1) = ':' then + return Ast; + else + return Envs.Get (Env, Sym); + end if; + exception + when Envs.Not_Found => + raise Envs.Not_Found with ("'" & Sym & "' not found"); + end; + + when List => + + return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); + + when others => return Ast; + + end case; + + end Eval_Ast; + + function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is + A0 : Mal_Handle; + begin + if Deref (Ast).Sym_Type /= List + or else Deref_List_Class (Ast).Get_List_Type /= List_List + or else Deref_List (Ast).Is_Null + then + return False; + end if; + A0 := Deref_List (Ast).Car; + return Deref (A0).Sym_Type = Sym + and then Deref_Sym (A0).Get_Sym = Symbol; + end Starts_With; + + function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is + Res, Elt, New_Res : Mal_Handle; + L : List_Ptr; + begin + + if Debug then + Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type not in Sym | List then + -- No need to quote, Eval would not affect these anyway. + return Param; + end if; + + if Deref (Param).Sym_Type /= List or else + Deref_List_Class (Param).Get_List_Type = Hashed_List then + + -- return a new list containing: a symbol named "quote" and ast. + Res := New_List_Mal_Type (List_List); + L := Deref_List (Res); + L.Append (New_Symbol_Mal_Type ("quote")); + L.Append (Param); + return Res; + + end if; + + -- if the first element of ast is a symbol named "unquote": + if Starts_With (Param, "unquote") then + -- return the second element of ast.` + return Deref_List_Class (Param).Nth (1); + + end if; + + Res := New_List_Mal_Type (List_List); + + for I in reverse 0 .. Deref_List_Class (Param).Length - 1 loop + Elt := Deref_List_Class (Param).Nth (I); + New_Res := New_List_Mal_Type (List_List); + L := Deref_List (New_Res); + if Starts_With (Elt, "splice-unquote") then + L.Append (New_Symbol_Mal_Type ("concat")); + L.Append (Deref_List (Elt).Nth (1)); + else + L.Append (New_Symbol_Mal_Type ("cons")); + L.Append (Quasi_Quote_Processing (Elt)); + end if; + L.Append (Res); + Res := New_Res; + end loop; + + if Deref_List_Class (Param).Get_List_Type = Vector_List then + New_Res := New_List_Mal_Type (List_List); + L := Deref_List (New_Res); + L.Append (New_Symbol_Mal_Type ("vec")); + L.Append (Res); + Res := New_Res; + end if; + + return Res; + + end Quasi_Quote_Processing; + + + function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) + return Mal_Handle is + Param : Mal_Handle; + Env : Envs.Env_Handle; + First_Param, Rest_Params : Mal_Handle; + Rest_List, Param_List : List_Mal_Type; + begin + + Param := AParam; + Env := AnEnv; + + <> + + if Debug then + Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + end if; + + Param := Macro_Expand (Param, Env); + + if Debug then + Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type = List and then + Deref_List (Param).Get_List_Type = List_List then + + Param_List := Deref_List (Param).all; + + -- Deal with empty list.. + if Param_List.Length = 0 then + return Param; + end if; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "def!" then + return Def_Fn (Rest_List, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "defmacro!" then + return Def_Macro (Rest_List, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "macroexpand" then + return Macro_Expand (Car (Rest_List), Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "let*" then + declare + Defs, Expr, Res : Mal_Handle; + E : Envs.Env_Handle; + begin + E := Envs.New_Env (Env); + Defs := Car (Rest_List); + Deref_List_Class (Defs).Add_Defs (E); + Expr := Car (Deref_List (Cdr (Rest_List)).all); + Param := Expr; + Env := E; + goto Tail_Call_Opt; + -- was: + -- Res := Eval (Expr, E); + -- return Res; + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "do" then + declare + D : List_Mal_Type; + E : Mal_Handle; + begin + + if Debug then + Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); + end if; + + if Is_Null (Rest_List) then + return Rest_Params; + end if; + + -- Loop processes Evals all but last entry + D := Rest_List; + loop + E := Car (D); + D := Deref_List (Cdr (D)).all; + exit when Is_Null (D); + E := Eval (E, Env); + end loop; + + Param := E; + goto Tail_Call_Opt; + + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "if" then + declare + Args : List_Mal_Type := Rest_List; + + Cond, True_Part, False_Part : Mal_Handle; + Cond_Bool : Boolean; + pragma Assert (Length (Args) = 2 or Length (Args) = 3, + "If_Processing: not 2 or 3 parameters"); + L : List_Mal_Type; + begin + + Cond := Eval (Car (Args), Env); + + Cond_Bool := Eval_As_Boolean (Cond); + + if Cond_Bool then + L := Deref_List (Cdr (Args)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + if Length (Args) = 3 then + L := Deref_List (Cdr (Args)).all; + L := Deref_List (Cdr (L)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + return New_Nil_Mal_Type; + end if; + end if; + end; + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "fn*" then + + return New_Lambda_Mal_Type + (Params => Car (Rest_List), + Expr => Nth (Rest_List, 1), + Env => Env); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quote" then + + return Car (Rest_List); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then + + return Quasi_Quote_Processing (Car (Rest_List)); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quasiquote" then + + Param := Quasi_Quote_Processing (Car (Rest_List)); + goto Tail_Call_Opt; + + else + + -- The APPLY section. + declare + Evaled_H : Mal_Handle; + begin + Evaled_H := Eval_Ast (Param, Env); + + Param_List := Deref_List (Evaled_H).all; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Func then + return Call_Func (Deref_Func (First_Param).all, Rest_Params); + elsif Deref (First_Param).Sym_Type = Lambda then + declare + + L : Lambda_Mal_Type; + E : Envs.Env_Handle; + Param_Names : List_Mal_Type; + Res : Mal_Handle; + + begin + + L := Deref_Lambda (First_Param).all; + E := Envs.New_Env (L.Get_Env); + + Param_Names := Deref_List (L.Get_Params).all; + + if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then + + Param := L.Get_Expr; + Env := E; + goto Tail_Call_Opt; + -- was: return Eval (L.Get_Expr, E); + + else + + raise Runtime_Exception with "Bind failed in Apply"; + + end if; + + end; + + else -- neither a Lambda or a Func + raise Runtime_Exception with "Deref called on non-Func/Lambda"; + end if; + + end; + + end if; + + else -- not a List_List + + return Eval_Ast (Param, Env); + + end if; + + end Eval; + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String; Env : Envs.Env_Handle) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; + + end Rep; + + + Repl_Env : Envs.Env_Handle; + + + -- These two ops use Repl_Env directly. + + + procedure RE (Str : Mal_String) is + Discarded : Mal_Handle; + begin + Discarded := Eval (Read (Str), Repl_Env); + end RE; + + + function Do_Eval (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return Eval_Callback.Eval.all (First_Param, Repl_Env); + end Do_Eval; + + + Cmd_Args, File_Param : Natural; + Command_Args : Types.Mal_Handle; + Command_List : Types.List_Ptr; + File_Processed : Boolean := False; + +begin + + -- Save a function pointer back to the Eval function. + -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK + -- as we know Eval will be in scope for the lifetime of the program. + Eval_Callback.Eval := Eval'Unrestricted_Access; + + Repl_Env := Envs.New_Env; + + -- Core init also creates the first environment. + -- This is needed for the def!'s below. + Core.Init (Repl_Env); + + -- Register the eval command. This needs to be done here rather than Core.Init + -- as it requires direct access to Repl_Env. + Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); + + RE ("(def! not (fn* (a) (if a false true)))"); + RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); + RE ("(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)))))))"); + + -- Command line processing. + + Cmd_Args := 0; + Command_Args := Types.New_List_Mal_Type (Types.List_List); + Command_List := Types.Deref_List (Command_Args); + + while Ada.Command_Line.Argument_Count > Cmd_Args loop + + Cmd_Args := Cmd_Args + 1; + if Ada.Command_Line.Argument (Cmd_Args) = "-d" then + Debug := True; + elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then + Envs.Debug := True; + elsif not File_Processed then + File_Param := Cmd_Args; + File_Processed := True; + else + Command_List.Append + (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); + end if; + + end loop; + + Envs.Set (Repl_Env, "*ARGV*", Command_Args); + + if File_Processed then + RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); + else + loop + begin + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); + exception + when E : others => + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; + end; + end loop; + end if; +end Step8_Macros; diff --git a/impls/ada/step9_try.adb b/impls/ada/step9_try.adb index 2d52272ae5..d4bbba4f96 100644 --- a/impls/ada/step9_try.adb +++ b/impls/ada/step9_try.adb @@ -1,631 +1,631 @@ -with Ada.Command_Line; -with Ada.Exceptions; -with Ada.Text_IO; -with Core; -with Envs; -with Eval_Callback; -with Printer; -with Reader; -with Smart_Pointers; -with Types; - -procedure Step9_Try is - - use Types; - - function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) - return Types.Mal_Handle; - - Debug : Boolean := False; - - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - - function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Fn: expected atom as name"); - Fn_Body := Nth (Args, 1); - Res := Eval (Fn_Body, Env); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Fn; - - - function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - Lambda_P : Lambda_Ptr; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Macro: expected atom as name"); - Fn_Body := Car (Deref_List (Cdr (Args)).all); - Res := Eval (Fn_Body, Env); - Lambda_P := Deref_Lambda (Res); - Res := New_Lambda_Mal_Type (Params => Lambda_P.all.Get_Params, - Expr => Lambda_P.all.Get_Expr, - Env => Lambda_P.all.Get_Env); - Deref_Lambda (Res).Set_Is_Macro (True); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Macro; - - - function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - Res : Mal_Handle; - E : Envs.Env_Handle; - LMT : List_Mal_Type; - LP : Lambda_Ptr; - begin - - Res := Ast; - - loop - - if Deref (Res).Sym_Type /= List then - exit; - end if; - - LMT := Deref_List (Res).all; - - -- Get the macro in the list from the env - -- or return null if not applicable. - LP := Get_Macro (Res, Env); - - exit when LP = null or else not LP.Get_Is_Macro; - - declare - Fn_List : Mal_Handle := Cdr (LMT); - Params : List_Mal_Type; - begin - E := Envs.New_Env (LP.Get_Env); - - Params := Deref_List (LP.Get_Params).all; - if Envs.Bind (E, Params, Deref_List (Fn_List).all) then - - Res := Eval (LP.Get_Expr, E); - - end if; - - end; - - end loop; - - return Res; - - end Macro_Expand; - - - function Eval_As_Boolean (MH : Mal_Handle) return Boolean is - Res : Boolean; - begin - case Deref (MH).Sym_Type is - when Bool => - Res := Deref_Bool (MH).Get_Bool; - when Nil => - return False; --- when List => --- declare --- L : List_Mal_Type; --- begin --- L := Deref_List (MH).all; --- Res := not Is_Null (L); --- end; - when others => -- Everything else - Res := True; - end case; - return Res; - end Eval_As_Boolean; - - - function Eval_Ast - (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - - function Call_Eval (A : Mal_Handle) return Mal_Handle is - begin - return Eval (A, Env); - end Call_Eval; - - begin - - case Deref (Ast).Sym_Type is - - when Sym => - - declare - Sym : Mal_String := Deref_Sym (Ast).Get_Sym; - begin - -- if keyword, return it. Otherwise look it up in the environment. - if Sym(1) = ':' then - return Ast; - else - return Envs.Get (Env, Sym); - end if; - exception - when Envs.Not_Found => - raise Envs.Not_Found with ("'" & Sym & "' not found"); - end; - - when List => - - return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); - - when others => return Ast; - - end case; - - end Eval_Ast; - - function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is - A0 : Mal_Handle; - begin - if Deref (Ast).Sym_Type /= List - or else Deref_List_Class (Ast).Get_List_Type /= List_List - or else Deref_List (Ast).Is_Null - then - return False; - end if; - A0 := Deref_List (Ast).Car; - return Deref (A0).Sym_Type = Sym - and then Deref_Sym (A0).Get_Sym = Symbol; - end Starts_With; - - function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is - Res, Elt, New_Res : Mal_Handle; - L : List_Ptr; - begin - - if Debug then - Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type not in Sym | List then - -- No need to quote, Eval would not affect these anyway. - return Param; - end if; - - if Deref (Param).Sym_Type /= List or else - Deref_List_Class (Param).Get_List_Type = Hashed_List then - - -- return a new list containing: a symbol named "quote" and ast. - Res := New_List_Mal_Type (List_List); - L := Deref_List (Res); - L.Append (New_Symbol_Mal_Type ("quote")); - L.Append (Param); - return Res; - - end if; - - -- if the first element of ast is a symbol named "unquote": - if Starts_With (Param, "unquote") then - -- return the second element of ast.` - return Deref_List_Class (Param).Nth (1); - - end if; - - Res := New_List_Mal_Type (List_List); - - for I in reverse 0 .. Deref_List_Class (Param).Length - 1 loop - Elt := Deref_List_Class (Param).Nth (I); - New_Res := New_List_Mal_Type (List_List); - L := Deref_List (New_Res); - if Starts_With (Elt, "splice-unquote") then - L.Append (New_Symbol_Mal_Type ("concat")); - L.Append (Deref_List (Elt).Nth (1)); - else - L.Append (New_Symbol_Mal_Type ("cons")); - L.Append (Quasi_Quote_Processing (Elt)); - end if; - L.Append (Res); - Res := New_Res; - end loop; - - if Deref_List_Class (Param).Get_List_Type = Vector_List then - New_Res := New_List_Mal_Type (List_List); - L := Deref_List (New_Res); - L.Append (New_Symbol_Mal_Type ("vec")); - L.Append (Res); - Res := New_Res; - end if; - - return Res; - - end Quasi_Quote_Processing; - - - function Catch_Processing - (Try_Line : Mal_Handle; - ExStr : Mal_Handle; - Env : Envs.Env_Handle) - return Mal_Handle is - - L, CL, CL2, CL3 : List_Mal_Type; - C : Mal_Handle; - New_Env : Envs.Env_Handle; - - begin - - L := Deref_List (Try_Line).all; - C := Car (L); - -- CL is the list with the catch in. - CL := Deref_List (C).all; - - CL2 := Deref_List (Cdr (CL)).all; - New_Env := Envs.New_Env (Env); - Envs.Set (New_Env, Deref_Sym (Car (CL2)).Get_Sym, ExStr); - - CL3 := Deref_List (Cdr (CL2)).all; - return Eval (Car (CL3), New_Env); - end Catch_Processing; - - - function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) - return Mal_Handle is - Param : Mal_Handle; - Env : Envs.Env_Handle; - First_Param, Rest_Params : Mal_Handle; - Rest_List, Param_List : List_Mal_Type; - begin - - Param := AParam; - Env := AnEnv; - - <> - - if Debug then - Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); - end if; - - Param := Macro_Expand (Param, Env); - - if Debug then - Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type = List and then - Deref_List (Param).Get_List_Type = List_List then - - Param_List := Deref_List (Param).all; - - -- Deal with empty list.. - if Param_List.Length = 0 then - return Param; - end if; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "def!" then - return Def_Fn (Rest_List, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "defmacro!" then - return Def_Macro (Rest_List, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "macroexpand" then - return Macro_Expand (Car (Rest_List), Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "let*" then - declare - Defs, Expr, Res : Mal_Handle; - E : Envs.Env_Handle; - begin - E := Envs.New_Env (Env); - Defs := Car (Rest_List); - Deref_List_Class (Defs).Add_Defs (E); - Expr := Car (Deref_List (Cdr (Rest_List)).all); - Param := Expr; - Env := E; - goto Tail_Call_Opt; - -- was: - -- Res := Eval (Expr, E); - -- return Res; - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "do" then - declare - D : List_Mal_Type; - E : Mal_Handle; - begin - - if Debug then - Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); - end if; - - if Is_Null (Rest_List) then - return Rest_Params; - end if; - - -- Loop processes Evals all but last entry - D := Rest_List; - loop - E := Car (D); - D := Deref_List (Cdr (D)).all; - exit when Is_Null (D); - E := Eval (E, Env); - end loop; - - Param := E; - goto Tail_Call_Opt; - - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "if" then - declare - Args : List_Mal_Type := Rest_List; - - Cond, True_Part, False_Part : Mal_Handle; - Cond_Bool : Boolean; - pragma Assert (Length (Args) = 2 or Length (Args) = 3, - "If_Processing: not 2 or 3 parameters"); - L : List_Mal_Type; - begin - - Cond := Eval (Car (Args), Env); - - Cond_Bool := Eval_As_Boolean (Cond); - - if Cond_Bool then - L := Deref_List (Cdr (Args)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - if Length (Args) = 3 then - L := Deref_List (Cdr (Args)).all; - L := Deref_List (Cdr (L)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - return New_Nil_Mal_Type; - end if; - end if; - end; - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "fn*" then - - return New_Lambda_Mal_Type - (Params => Car (Rest_List), - Expr => Nth (Rest_List, 1), - Env => Env); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quote" then - - return Car (Rest_List); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then - - return Quasi_Quote_Processing (Car (Rest_List)); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quasiquote" then - - Param := Quasi_Quote_Processing (Car (Rest_List)); - goto Tail_Call_Opt; - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "try*" then - - if Length (Rest_List) = 1 then - return Eval (Car (Rest_List), Env); - end if; - declare - Res : Mal_Handle; - begin - return Eval (Car (Rest_List), Env); - exception - when Mal_Exception => - Res := Catch_Processing - (Cdr (Rest_List), - Types.Mal_Exception_Value, - Env); - Types.Mal_Exception_Value := - Smart_Pointers.Null_Smart_Pointer; - return Res; - when E : others => - return Catch_Processing - (Cdr (Rest_List), - New_String_Mal_Type - (Ada.Exceptions.Exception_Message (E)), - Env); - end; - - else - - -- The APPLY section. - declare - Evaled_H : Mal_Handle; - begin - Evaled_H := Eval_Ast (Param, Env); - - Param_List := Deref_List (Evaled_H).all; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Func then - return Call_Func (Deref_Func (First_Param).all, Rest_Params); - elsif Deref (First_Param).Sym_Type = Lambda then - declare - - L : Lambda_Mal_Type; - E : Envs.Env_Handle; - Param_Names : List_Mal_Type; - Res : Mal_Handle; - - begin - - L := Deref_Lambda (First_Param).all; - E := Envs.New_Env (L.Get_Env); - - Param_Names := Deref_List (L.Get_Params).all; - - if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then - - Param := L.Get_Expr; - Env := E; - goto Tail_Call_Opt; - -- was: return Eval (L.Get_Expr, E); - - else - - raise Runtime_Exception with "Bind failed in Apply"; - - end if; - - end; - - else -- neither a Lambda or a Func - raise Runtime_Exception with "Deref called on non-Func/Lambda"; - end if; - - end; - - end if; - - else -- not a List_List - - return Eval_Ast (Param, Env); - - end if; - - end Eval; - - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; - - end Rep; - - - Repl_Env : Envs.Env_Handle; - - - -- These two ops use Repl_Env directly. - - - procedure RE (Str : Mal_String) is - Discarded : Mal_Handle; - begin - Discarded := Eval (Read (Str), Repl_Env); - end RE; - - - function Do_Eval (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return Eval_Callback.Eval.all (First_Param, Repl_Env); - end Do_Eval; - - - Cmd_Args, File_Param : Natural; - Command_Args : Types.Mal_Handle; - Command_List : Types.List_Ptr; - File_Processed : Boolean := False; - -begin - - -- Save a function pointer back to the Eval function. - -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK - -- as we know Eval will be in scope for the lifetime of the program. - Eval_Callback.Eval := Eval'Unrestricted_Access; - - Repl_Env := Envs.New_Env; - - -- Core init also creates the first environment. - -- This is needed for the def!'s below. - Core.Init (Repl_Env); - - -- Register the eval command. This needs to be done here rather than Core.Init - -- as it requires direct access to Repl_Env. - Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); - - RE ("(def! not (fn* (a) (if a false true)))"); - RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); - RE ("(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)))))))"); - - -- Command line processing. - - Cmd_Args := 0; - Command_Args := Types.New_List_Mal_Type (Types.List_List); - Command_List := Types.Deref_List (Command_Args); - - while Ada.Command_Line.Argument_Count > Cmd_Args loop - - Cmd_Args := Cmd_Args + 1; - if Ada.Command_Line.Argument (Cmd_Args) = "-d" then - Debug := True; - elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then - Envs.Debug := True; - elsif not File_Processed then - File_Param := Cmd_Args; - File_Processed := True; - else - Command_List.Append - (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); - end if; - - end loop; - - Envs.Set (Repl_Env, "*ARGV*", Command_Args); - - if File_Processed then - RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); - else - loop - begin - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); - exception - when E : others => - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - "Error: " & Ada.Exceptions.Exception_Information (E)); - if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - Printer.Pr_Str (Types.Mal_Exception_Value)); - Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; - end if; - end; - end loop; - end if; -end Step9_Try; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Text_IO; +with Core; +with Envs; +with Eval_Callback; +with Printer; +with Reader; +with Smart_Pointers; +with Types; + +procedure Step9_Try is + + use Types; + + function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) + return Types.Mal_Handle; + + Debug : Boolean := False; + + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Fn: expected atom as name"); + Fn_Body := Nth (Args, 1); + Res := Eval (Fn_Body, Env); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Fn; + + + function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + Lambda_P : Lambda_Ptr; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Macro: expected atom as name"); + Fn_Body := Car (Deref_List (Cdr (Args)).all); + Res := Eval (Fn_Body, Env); + Lambda_P := Deref_Lambda (Res); + Res := New_Lambda_Mal_Type (Params => Lambda_P.all.Get_Params, + Expr => Lambda_P.all.Get_Expr, + Env => Lambda_P.all.Get_Env); + Deref_Lambda (Res).Set_Is_Macro (True); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Macro; + + + function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + Res : Mal_Handle; + E : Envs.Env_Handle; + LMT : List_Mal_Type; + LP : Lambda_Ptr; + begin + + Res := Ast; + + loop + + if Deref (Res).Sym_Type /= List then + exit; + end if; + + LMT := Deref_List (Res).all; + + -- Get the macro in the list from the env + -- or return null if not applicable. + LP := Get_Macro (Res, Env); + + exit when LP = null or else not LP.Get_Is_Macro; + + declare + Fn_List : Mal_Handle := Cdr (LMT); + Params : List_Mal_Type; + begin + E := Envs.New_Env (LP.Get_Env); + + Params := Deref_List (LP.Get_Params).all; + if Envs.Bind (E, Params, Deref_List (Fn_List).all) then + + Res := Eval (LP.Get_Expr, E); + + end if; + + end; + + end loop; + + return Res; + + end Macro_Expand; + + + function Eval_As_Boolean (MH : Mal_Handle) return Boolean is + Res : Boolean; + begin + case Deref (MH).Sym_Type is + when Bool => + Res := Deref_Bool (MH).Get_Bool; + when Nil => + return False; +-- when List => +-- declare +-- L : List_Mal_Type; +-- begin +-- L := Deref_List (MH).all; +-- Res := not Is_Null (L); +-- end; + when others => -- Everything else + Res := True; + end case; + return Res; + end Eval_As_Boolean; + + + function Eval_Ast + (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + + function Call_Eval (A : Mal_Handle) return Mal_Handle is + begin + return Eval (A, Env); + end Call_Eval; + + begin + + case Deref (Ast).Sym_Type is + + when Sym => + + declare + Sym : Mal_String := Deref_Sym (Ast).Get_Sym; + begin + -- if keyword, return it. Otherwise look it up in the environment. + if Sym(1) = ':' then + return Ast; + else + return Envs.Get (Env, Sym); + end if; + exception + when Envs.Not_Found => + raise Envs.Not_Found with ("'" & Sym & "' not found"); + end; + + when List => + + return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); + + when others => return Ast; + + end case; + + end Eval_Ast; + + function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is + A0 : Mal_Handle; + begin + if Deref (Ast).Sym_Type /= List + or else Deref_List_Class (Ast).Get_List_Type /= List_List + or else Deref_List (Ast).Is_Null + then + return False; + end if; + A0 := Deref_List (Ast).Car; + return Deref (A0).Sym_Type = Sym + and then Deref_Sym (A0).Get_Sym = Symbol; + end Starts_With; + + function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is + Res, Elt, New_Res : Mal_Handle; + L : List_Ptr; + begin + + if Debug then + Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type not in Sym | List then + -- No need to quote, Eval would not affect these anyway. + return Param; + end if; + + if Deref (Param).Sym_Type /= List or else + Deref_List_Class (Param).Get_List_Type = Hashed_List then + + -- return a new list containing: a symbol named "quote" and ast. + Res := New_List_Mal_Type (List_List); + L := Deref_List (Res); + L.Append (New_Symbol_Mal_Type ("quote")); + L.Append (Param); + return Res; + + end if; + + -- if the first element of ast is a symbol named "unquote": + if Starts_With (Param, "unquote") then + -- return the second element of ast.` + return Deref_List_Class (Param).Nth (1); + + end if; + + Res := New_List_Mal_Type (List_List); + + for I in reverse 0 .. Deref_List_Class (Param).Length - 1 loop + Elt := Deref_List_Class (Param).Nth (I); + New_Res := New_List_Mal_Type (List_List); + L := Deref_List (New_Res); + if Starts_With (Elt, "splice-unquote") then + L.Append (New_Symbol_Mal_Type ("concat")); + L.Append (Deref_List (Elt).Nth (1)); + else + L.Append (New_Symbol_Mal_Type ("cons")); + L.Append (Quasi_Quote_Processing (Elt)); + end if; + L.Append (Res); + Res := New_Res; + end loop; + + if Deref_List_Class (Param).Get_List_Type = Vector_List then + New_Res := New_List_Mal_Type (List_List); + L := Deref_List (New_Res); + L.Append (New_Symbol_Mal_Type ("vec")); + L.Append (Res); + Res := New_Res; + end if; + + return Res; + + end Quasi_Quote_Processing; + + + function Catch_Processing + (Try_Line : Mal_Handle; + ExStr : Mal_Handle; + Env : Envs.Env_Handle) + return Mal_Handle is + + L, CL, CL2, CL3 : List_Mal_Type; + C : Mal_Handle; + New_Env : Envs.Env_Handle; + + begin + + L := Deref_List (Try_Line).all; + C := Car (L); + -- CL is the list with the catch in. + CL := Deref_List (C).all; + + CL2 := Deref_List (Cdr (CL)).all; + New_Env := Envs.New_Env (Env); + Envs.Set (New_Env, Deref_Sym (Car (CL2)).Get_Sym, ExStr); + + CL3 := Deref_List (Cdr (CL2)).all; + return Eval (Car (CL3), New_Env); + end Catch_Processing; + + + function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) + return Mal_Handle is + Param : Mal_Handle; + Env : Envs.Env_Handle; + First_Param, Rest_Params : Mal_Handle; + Rest_List, Param_List : List_Mal_Type; + begin + + Param := AParam; + Env := AnEnv; + + <> + + if Debug then + Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + end if; + + Param := Macro_Expand (Param, Env); + + if Debug then + Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type = List and then + Deref_List (Param).Get_List_Type = List_List then + + Param_List := Deref_List (Param).all; + + -- Deal with empty list.. + if Param_List.Length = 0 then + return Param; + end if; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "def!" then + return Def_Fn (Rest_List, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "defmacro!" then + return Def_Macro (Rest_List, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "macroexpand" then + return Macro_Expand (Car (Rest_List), Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "let*" then + declare + Defs, Expr, Res : Mal_Handle; + E : Envs.Env_Handle; + begin + E := Envs.New_Env (Env); + Defs := Car (Rest_List); + Deref_List_Class (Defs).Add_Defs (E); + Expr := Car (Deref_List (Cdr (Rest_List)).all); + Param := Expr; + Env := E; + goto Tail_Call_Opt; + -- was: + -- Res := Eval (Expr, E); + -- return Res; + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "do" then + declare + D : List_Mal_Type; + E : Mal_Handle; + begin + + if Debug then + Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); + end if; + + if Is_Null (Rest_List) then + return Rest_Params; + end if; + + -- Loop processes Evals all but last entry + D := Rest_List; + loop + E := Car (D); + D := Deref_List (Cdr (D)).all; + exit when Is_Null (D); + E := Eval (E, Env); + end loop; + + Param := E; + goto Tail_Call_Opt; + + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "if" then + declare + Args : List_Mal_Type := Rest_List; + + Cond, True_Part, False_Part : Mal_Handle; + Cond_Bool : Boolean; + pragma Assert (Length (Args) = 2 or Length (Args) = 3, + "If_Processing: not 2 or 3 parameters"); + L : List_Mal_Type; + begin + + Cond := Eval (Car (Args), Env); + + Cond_Bool := Eval_As_Boolean (Cond); + + if Cond_Bool then + L := Deref_List (Cdr (Args)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + if Length (Args) = 3 then + L := Deref_List (Cdr (Args)).all; + L := Deref_List (Cdr (L)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + return New_Nil_Mal_Type; + end if; + end if; + end; + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "fn*" then + + return New_Lambda_Mal_Type + (Params => Car (Rest_List), + Expr => Nth (Rest_List, 1), + Env => Env); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quote" then + + return Car (Rest_List); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then + + return Quasi_Quote_Processing (Car (Rest_List)); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quasiquote" then + + Param := Quasi_Quote_Processing (Car (Rest_List)); + goto Tail_Call_Opt; + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "try*" then + + if Length (Rest_List) = 1 then + return Eval (Car (Rest_List), Env); + end if; + declare + Res : Mal_Handle; + begin + return Eval (Car (Rest_List), Env); + exception + when Mal_Exception => + Res := Catch_Processing + (Cdr (Rest_List), + Types.Mal_Exception_Value, + Env); + Types.Mal_Exception_Value := + Smart_Pointers.Null_Smart_Pointer; + return Res; + when E : others => + return Catch_Processing + (Cdr (Rest_List), + New_String_Mal_Type + (Ada.Exceptions.Exception_Message (E)), + Env); + end; + + else + + -- The APPLY section. + declare + Evaled_H : Mal_Handle; + begin + Evaled_H := Eval_Ast (Param, Env); + + Param_List := Deref_List (Evaled_H).all; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Func then + return Call_Func (Deref_Func (First_Param).all, Rest_Params); + elsif Deref (First_Param).Sym_Type = Lambda then + declare + + L : Lambda_Mal_Type; + E : Envs.Env_Handle; + Param_Names : List_Mal_Type; + Res : Mal_Handle; + + begin + + L := Deref_Lambda (First_Param).all; + E := Envs.New_Env (L.Get_Env); + + Param_Names := Deref_List (L.Get_Params).all; + + if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then + + Param := L.Get_Expr; + Env := E; + goto Tail_Call_Opt; + -- was: return Eval (L.Get_Expr, E); + + else + + raise Runtime_Exception with "Bind failed in Apply"; + + end if; + + end; + + else -- neither a Lambda or a Func + raise Runtime_Exception with "Deref called on non-Func/Lambda"; + end if; + + end; + + end if; + + else -- not a List_List + + return Eval_Ast (Param, Env); + + end if; + + end Eval; + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String; Env : Envs.Env_Handle) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; + + end Rep; + + + Repl_Env : Envs.Env_Handle; + + + -- These two ops use Repl_Env directly. + + + procedure RE (Str : Mal_String) is + Discarded : Mal_Handle; + begin + Discarded := Eval (Read (Str), Repl_Env); + end RE; + + + function Do_Eval (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return Eval_Callback.Eval.all (First_Param, Repl_Env); + end Do_Eval; + + + Cmd_Args, File_Param : Natural; + Command_Args : Types.Mal_Handle; + Command_List : Types.List_Ptr; + File_Processed : Boolean := False; + +begin + + -- Save a function pointer back to the Eval function. + -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK + -- as we know Eval will be in scope for the lifetime of the program. + Eval_Callback.Eval := Eval'Unrestricted_Access; + + Repl_Env := Envs.New_Env; + + -- Core init also creates the first environment. + -- This is needed for the def!'s below. + Core.Init (Repl_Env); + + -- Register the eval command. This needs to be done here rather than Core.Init + -- as it requires direct access to Repl_Env. + Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); + + RE ("(def! not (fn* (a) (if a false true)))"); + RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); + RE ("(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)))))))"); + + -- Command line processing. + + Cmd_Args := 0; + Command_Args := Types.New_List_Mal_Type (Types.List_List); + Command_List := Types.Deref_List (Command_Args); + + while Ada.Command_Line.Argument_Count > Cmd_Args loop + + Cmd_Args := Cmd_Args + 1; + if Ada.Command_Line.Argument (Cmd_Args) = "-d" then + Debug := True; + elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then + Envs.Debug := True; + elsif not File_Processed then + File_Param := Cmd_Args; + File_Processed := True; + else + Command_List.Append + (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); + end if; + + end loop; + + Envs.Set (Repl_Env, "*ARGV*", Command_Args); + + if File_Processed then + RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); + else + loop + begin + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); + exception + when E : others => + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; + end; + end loop; + end if; +end Step9_Try; diff --git a/impls/ada/stepa_mal.adb b/impls/ada/stepa_mal.adb index 1d0b71fd60..195d32cfe0 100644 --- a/impls/ada/stepa_mal.adb +++ b/impls/ada/stepa_mal.adb @@ -1,633 +1,633 @@ -with Ada.Command_Line; -with Ada.Exceptions; -with Ada.Text_IO; -with Core; -with Envs; -with Eval_Callback; -with Printer; -with Reader; -with Smart_Pointers; -with Types; - -procedure StepA_Mal is - - use Types; - - function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) - return Types.Mal_Handle; - - Debug : Boolean := False; - - - function Read (Param : String) return Types.Mal_Handle is - begin - return Reader.Read_Str (Param); - end Read; - - - function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Fn: expected atom as name"); - Fn_Body := Nth (Args, 1); - Res := Eval (Fn_Body, Env); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Fn; - - - function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is - Name, Fn_Body, Res : Mal_Handle; - Lambda_P : Lambda_Ptr; - begin - Name := Car (Args); - pragma Assert (Deref (Name).Sym_Type = Sym, - "Def_Macro: expected atom as name"); - Fn_Body := Car (Deref_List (Cdr (Args)).all); - Res := Eval (Fn_Body, Env); - Lambda_P := Deref_Lambda (Res); - Res := New_Lambda_Mal_Type (Params => Lambda_P.all.Get_Params, - Expr => Lambda_P.all.Get_Expr, - Env => Lambda_P.all.Get_Env); - Deref_Lambda (Res).Set_Is_Macro (True); - Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); - return Res; - end Def_Macro; - - - function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - Res : Mal_Handle; - E : Envs.Env_Handle; - LMT : List_Mal_Type; - LP : Lambda_Ptr; - begin - - Res := Ast; - - loop - - if Deref (Res).Sym_Type /= List then - exit; - end if; - - LMT := Deref_List (Res).all; - - -- Get the macro in the list from the env - -- or return null if not applicable. - LP := Get_Macro (Res, Env); - - exit when LP = null or else not LP.Get_Is_Macro; - - declare - Fn_List : Mal_Handle := Cdr (LMT); - Params : List_Mal_Type; - begin - E := Envs.New_Env (LP.Get_Env); - - Params := Deref_List (LP.Get_Params).all; - - if Envs.Bind (E, Params, Deref_List (Fn_List).all) then - - Res := Eval (LP.Get_Expr, E); - - end if; - - end; - - end loop; - - return Res; - - end Macro_Expand; - - - function Eval_As_Boolean (MH : Mal_Handle) return Boolean is - Res : Boolean; - begin - case Deref (MH).Sym_Type is - when Bool => - Res := Deref_Bool (MH).Get_Bool; - when Nil => - return False; --- when List => --- declare --- L : List_Mal_Type; --- begin --- L := Deref_List (MH).all; --- Res := not Is_Null (L); --- end; - when others => -- Everything else - Res := True; - end case; - return Res; - end Eval_As_Boolean; - - - function Eval_Ast - (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - - function Call_Eval (A : Mal_Handle) return Mal_Handle is - begin - return Eval (A, Env); - end Call_Eval; - - begin - - case Deref (Ast).Sym_Type is - - when Sym => - - declare - Sym : Mal_String := Deref_Sym (Ast).Get_Sym; - begin - -- if keyword, return it. Otherwise look it up in the environment. - if Sym(1) = ':' then - return Ast; - else - return Envs.Get (Env, Sym); - end if; - exception - when Envs.Not_Found => - raise Envs.Not_Found with ("'" & Sym & "' not found"); - end; - - when List => - - return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); - - when others => return Ast; - - end case; - - end Eval_Ast; - - function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is - A0 : Mal_Handle; - begin - if Deref (Ast).Sym_Type /= List - or else Deref_List_Class (Ast).Get_List_Type /= List_List - or else Deref_List (Ast).Is_Null - then - return False; - end if; - A0 := Deref_List (Ast).Car; - return Deref (A0).Sym_Type = Sym - and then Deref_Sym (A0).Get_Sym = Symbol; - end Starts_With; - - function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is - Res, Elt, New_Res : Mal_Handle; - L : List_Ptr; - begin - - if Debug then - Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type not in Sym | List then - -- No need to quote, Eval would not affect these anyway. - return Param; - end if; - - if Deref (Param).Sym_Type /= List or else - Deref_List_Class (Param).Get_List_Type = Hashed_List then - - -- return a new list containing: a symbol named "quote" and ast. - Res := New_List_Mal_Type (List_List); - L := Deref_List (Res); - L.Append (New_Symbol_Mal_Type ("quote")); - L.Append (Param); - return Res; - - end if; - - -- if the first element of ast is a symbol named "unquote": - if Starts_With (Param, "unquote") then - -- return the second element of ast.` - return Deref_List_Class (Param).Nth (1); - - end if; - - Res := New_List_Mal_Type (List_List); - - for I in reverse 0 .. Deref_List_Class (Param).Length - 1 loop - Elt := Deref_List_Class (Param).Nth (I); - New_Res := New_List_Mal_Type (List_List); - L := Deref_List (New_Res); - if Starts_With (Elt, "splice-unquote") then - L.Append (New_Symbol_Mal_Type ("concat")); - L.Append (Deref_List (Elt).Nth (1)); - else - L.Append (New_Symbol_Mal_Type ("cons")); - L.Append (Quasi_Quote_Processing (Elt)); - end if; - L.Append (Res); - Res := New_Res; - end loop; - - if Deref_List_Class (Param).Get_List_Type = Vector_List then - New_Res := New_List_Mal_Type (List_List); - L := Deref_List (New_Res); - L.Append (New_Symbol_Mal_Type ("vec")); - L.Append (Res); - Res := New_Res; - end if; - - return Res; - - end Quasi_Quote_Processing; - - - function Catch_Processing - (Try_Line : Mal_Handle; - ExStr : Mal_Handle; - Env : Envs.Env_Handle) - return Mal_Handle is - - L, CL, CL2, CL3 : List_Mal_Type; - C : Mal_Handle; - New_Env : Envs.Env_Handle; - - begin - - L := Deref_List (Try_Line).all; - C := Car (L); - -- CL is the list with the catch in. - CL := Deref_List (C).all; - - CL2 := Deref_List (Cdr (CL)).all; - New_Env := Envs.New_Env (Env); - Envs.Set (New_Env, Deref_Sym (Car (CL2)).Get_Sym, ExStr); - - CL3 := Deref_List (Cdr (CL2)).all; - return Eval (Car (CL3), New_Env); - end Catch_Processing; - - - function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) - return Mal_Handle is - Param : Mal_Handle; - Env : Envs.Env_Handle; - First_Param, Rest_Params : Mal_Handle; - Rest_List, Param_List : List_Mal_Type; - begin - - Param := AParam; - Env := AnEnv; - - <> - - if Debug then - Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); - end if; - - Param := Macro_Expand (Param, Env); - - if Debug then - Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String); - end if; - - if Deref (Param).Sym_Type = List and then - Deref_List (Param).Get_List_Type = List_List then - - Param_List := Deref_List (Param).all; - - -- Deal with empty list.. - if Param_List.Length = 0 then - return Param; - end if; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "def!" then - return Def_Fn (Rest_List, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "defmacro!" then - return Def_Macro (Rest_List, Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "macroexpand" then - return Macro_Expand (Car (Rest_List), Env); - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "let*" then - declare - Defs, Expr, Res : Mal_Handle; - E : Envs.Env_Handle; - begin - E := Envs.New_Env (Env); - Defs := Car (Rest_List); - Deref_List_Class (Defs).Add_Defs (E); - Expr := Car (Deref_List (Cdr (Rest_List)).all); - Param := Expr; - Env := E; - goto Tail_Call_Opt; - -- was: - -- Res := Eval (Expr, E); - -- return Res; - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "do" then - declare - D : List_Mal_Type; - E : Mal_Handle; - begin - - if Debug then - Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); - end if; - - if Is_Null (Rest_List) then - return Rest_Params; - end if; - - -- Loop processes Evals all but last entry - D := Rest_List; - loop - E := Car (D); - D := Deref_List (Cdr (D)).all; - exit when Is_Null (D); - E := Eval (E, Env); - end loop; - - Param := E; - goto Tail_Call_Opt; - - end; - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "if" then - declare - Args : List_Mal_Type := Rest_List; - - Cond, True_Part, False_Part : Mal_Handle; - Cond_Bool : Boolean; - pragma Assert (Length (Args) = 2 or Length (Args) = 3, - "If_Processing: not 2 or 3 parameters"); - L : List_Mal_Type; - begin - - Cond := Eval (Car (Args), Env); - - Cond_Bool := Eval_As_Boolean (Cond); - - if Cond_Bool then - L := Deref_List (Cdr (Args)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - if Length (Args) = 3 then - L := Deref_List (Cdr (Args)).all; - L := Deref_List (Cdr (L)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- was: return Eval (Car (L), Env); - else - return New_Nil_Mal_Type; - end if; - end if; - end; - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "fn*" then - - return New_Lambda_Mal_Type - (Params => Car (Rest_List), - Expr => Nth (Rest_List, 1), - Env => Env); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quote" then - - return Car (Rest_List); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then - - return Quasi_Quote_Processing (Car (Rest_List)); - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "quasiquote" then - - Param := Quasi_Quote_Processing (Car (Rest_List)); - goto Tail_Call_Opt; - - elsif Deref (First_Param).Sym_Type = Sym and then - Deref_Sym (First_Param).Get_Sym = "try*" then - - if Length (Rest_List) = 1 then - return Eval (Car (Rest_List), Env); - end if; - declare - Res : Mal_Handle; - begin - return Eval (Car (Rest_List), Env); - exception - when Mal_Exception => - Res := Catch_Processing - (Cdr (Rest_List), - Types.Mal_Exception_Value, - Env); - Types.Mal_Exception_Value := - Smart_Pointers.Null_Smart_Pointer; - return Res; - when E : others => - return Catch_Processing - (Cdr (Rest_List), - New_String_Mal_Type - (Ada.Exceptions.Exception_Message (E)), - Env); - end; - - else - - -- The APPLY section. - declare - Evaled_H : Mal_Handle; - begin - Evaled_H := Eval_Ast (Param, Env); - - Param_List := Deref_List (Evaled_H).all; - - First_Param := Car (Param_List); - Rest_Params := Cdr (Param_List); - Rest_List := Deref_List (Rest_Params).all; - - if Deref (First_Param).Sym_Type = Func then - return Call_Func (Deref_Func (First_Param).all, Rest_Params); - elsif Deref (First_Param).Sym_Type = Lambda then - declare - - L : Lambda_Mal_Type; - E : Envs.Env_Handle; - Param_Names : List_Mal_Type; - Res : Mal_Handle; - - begin - - L := Deref_Lambda (First_Param).all; - E := Envs.New_Env (L.Get_Env); - - Param_Names := Deref_List (L.Get_Params).all; - - if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then - - Param := L.Get_Expr; - Env := E; - goto Tail_Call_Opt; - -- was: return Eval (L.Get_Expr, E); - - else - - raise Runtime_Exception with "Bind failed in Apply"; - - end if; - - end; - - else -- neither a Lambda or a Func - raise Runtime_Exception with "Deref called on non-Func/Lambda"; - end if; - - end; - - end if; - - else -- not a List_List - - return Eval_Ast (Param, Env); - - end if; - - end Eval; - - - function Print (Param : Types.Mal_Handle) return String is - begin - return Printer.Pr_Str (Param); - end Print; - - function Rep (Param : String; Env : Envs.Env_Handle) return String is - AST, Evaluated_AST : Types.Mal_Handle; - begin - - AST := Read (Param); - - if Types.Is_Null (AST) then - return ""; - else - Evaluated_AST := Eval (AST, Env); - return Print (Evaluated_AST); - end if; - - end Rep; - - - Repl_Env : Envs.Env_Handle; - - - -- These two ops use Repl_Env directly. - - - procedure RE (Str : Mal_String) is - Discarded : Mal_Handle; - begin - Discarded := Eval (Read (Str), Repl_Env); - end RE; - - - function Do_Eval (Rest_Handle : Mal_Handle) - return Types.Mal_Handle is - First_Param : Mal_Handle; - Rest_List : Types.List_Mal_Type; - begin - Rest_List := Deref_List (Rest_Handle).all; - First_Param := Car (Rest_List); - return Eval_Callback.Eval.all (First_Param, Repl_Env); - end Do_Eval; - - - Cmd_Args, File_Param : Natural; - Command_Args : Types.Mal_Handle; - Command_List : Types.List_Ptr; - File_Processed : Boolean := False; - -begin - - -- Save a function pointer back to the Eval function. - -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK - -- as we know Eval will be in scope for the lifetime of the program. - Eval_Callback.Eval := Eval'Unrestricted_Access; - - Repl_Env := Envs.New_Env; - - -- Core init also creates the first environment. - -- This is needed for the def!'s below. - Core.Init (Repl_Env); - - -- Register the eval command. This needs to be done here rather than Core.Init - -- as it requires direct access to Repl_Env. - Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); - - RE ("(def! not (fn* (a) (if a false true)))"); - RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); - RE ("(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)))))))"); - - -- Command line processing. - - Cmd_Args := 0; - Command_Args := Types.New_List_Mal_Type (Types.List_List); - Command_List := Types.Deref_List (Command_Args); - - while Ada.Command_Line.Argument_Count > Cmd_Args loop - - Cmd_Args := Cmd_Args + 1; - if Ada.Command_Line.Argument (Cmd_Args) = "-d" then - Debug := True; - elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then - Envs.Debug := True; - elsif not File_Processed then - File_Param := Cmd_Args; - File_Processed := True; - else - Command_List.Append - (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); - end if; - - end loop; - - Envs.Set (Repl_Env, "*ARGV*", Command_Args); - - if File_Processed then - RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); - else - RE("(println (str ""Mal ["" *host-language* ""]""))"); - loop - begin - Ada.Text_IO.Put ("user> "); - exit when Ada.Text_IO.End_Of_File; - Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); - exception - when E : others => - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - "Error: " & Ada.Exceptions.Exception_Information (E)); - if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then - Ada.Text_IO.Put_Line - (Ada.Text_IO.Standard_Error, - Printer.Pr_Str (Types.Mal_Exception_Value)); - Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; - end if; - end; - end loop; - end if; -end StepA_Mal; +with Ada.Command_Line; +with Ada.Exceptions; +with Ada.Text_IO; +with Core; +with Envs; +with Eval_Callback; +with Printer; +with Reader; +with Smart_Pointers; +with Types; + +procedure StepA_Mal is + + use Types; + + function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle) + return Types.Mal_Handle; + + Debug : Boolean := False; + + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Fn: expected atom as name"); + Fn_Body := Nth (Args, 1); + Res := Eval (Fn_Body, Env); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Fn; + + + function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle) + return Mal_Handle is + Name, Fn_Body, Res : Mal_Handle; + Lambda_P : Lambda_Ptr; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Sym, + "Def_Macro: expected atom as name"); + Fn_Body := Car (Deref_List (Cdr (Args)).all); + Res := Eval (Fn_Body, Env); + Lambda_P := Deref_Lambda (Res); + Res := New_Lambda_Mal_Type (Params => Lambda_P.all.Get_Params, + Expr => Lambda_P.all.Get_Expr, + Env => Lambda_P.all.Get_Env); + Deref_Lambda (Res).Set_Is_Macro (True); + Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res); + return Res; + end Def_Macro; + + + function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + Res : Mal_Handle; + E : Envs.Env_Handle; + LMT : List_Mal_Type; + LP : Lambda_Ptr; + begin + + Res := Ast; + + loop + + if Deref (Res).Sym_Type /= List then + exit; + end if; + + LMT := Deref_List (Res).all; + + -- Get the macro in the list from the env + -- or return null if not applicable. + LP := Get_Macro (Res, Env); + + exit when LP = null or else not LP.Get_Is_Macro; + + declare + Fn_List : Mal_Handle := Cdr (LMT); + Params : List_Mal_Type; + begin + E := Envs.New_Env (LP.Get_Env); + + Params := Deref_List (LP.Get_Params).all; + + if Envs.Bind (E, Params, Deref_List (Fn_List).all) then + + Res := Eval (LP.Get_Expr, E); + + end if; + + end; + + end loop; + + return Res; + + end Macro_Expand; + + + function Eval_As_Boolean (MH : Mal_Handle) return Boolean is + Res : Boolean; + begin + case Deref (MH).Sym_Type is + when Bool => + Res := Deref_Bool (MH).Get_Bool; + when Nil => + return False; +-- when List => +-- declare +-- L : List_Mal_Type; +-- begin +-- L := Deref_List (MH).all; +-- Res := not Is_Null (L); +-- end; + when others => -- Everything else + Res := True; + end case; + return Res; + end Eval_As_Boolean; + + + function Eval_Ast + (Ast : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + + function Call_Eval (A : Mal_Handle) return Mal_Handle is + begin + return Eval (A, Env); + end Call_Eval; + + begin + + case Deref (Ast).Sym_Type is + + when Sym => + + declare + Sym : Mal_String := Deref_Sym (Ast).Get_Sym; + begin + -- if keyword, return it. Otherwise look it up in the environment. + if Sym(1) = ':' then + return Ast; + else + return Envs.Get (Env, Sym); + end if; + exception + when Envs.Not_Found => + raise Envs.Not_Found with ("'" & Sym & "' not found"); + end; + + when List => + + return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all); + + when others => return Ast; + + end case; + + end Eval_Ast; + + function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is + A0 : Mal_Handle; + begin + if Deref (Ast).Sym_Type /= List + or else Deref_List_Class (Ast).Get_List_Type /= List_List + or else Deref_List (Ast).Is_Null + then + return False; + end if; + A0 := Deref_List (Ast).Car; + return Deref (A0).Sym_Type = Sym + and then Deref_Sym (A0).Get_Sym = Symbol; + end Starts_With; + + function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is + Res, Elt, New_Res : Mal_Handle; + L : List_Ptr; + begin + + if Debug then + Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type not in Sym | List then + -- No need to quote, Eval would not affect these anyway. + return Param; + end if; + + if Deref (Param).Sym_Type /= List or else + Deref_List_Class (Param).Get_List_Type = Hashed_List then + + -- return a new list containing: a symbol named "quote" and ast. + Res := New_List_Mal_Type (List_List); + L := Deref_List (Res); + L.Append (New_Symbol_Mal_Type ("quote")); + L.Append (Param); + return Res; + + end if; + + -- if the first element of ast is a symbol named "unquote": + if Starts_With (Param, "unquote") then + -- return the second element of ast.` + return Deref_List_Class (Param).Nth (1); + + end if; + + Res := New_List_Mal_Type (List_List); + + for I in reverse 0 .. Deref_List_Class (Param).Length - 1 loop + Elt := Deref_List_Class (Param).Nth (I); + New_Res := New_List_Mal_Type (List_List); + L := Deref_List (New_Res); + if Starts_With (Elt, "splice-unquote") then + L.Append (New_Symbol_Mal_Type ("concat")); + L.Append (Deref_List (Elt).Nth (1)); + else + L.Append (New_Symbol_Mal_Type ("cons")); + L.Append (Quasi_Quote_Processing (Elt)); + end if; + L.Append (Res); + Res := New_Res; + end loop; + + if Deref_List_Class (Param).Get_List_Type = Vector_List then + New_Res := New_List_Mal_Type (List_List); + L := Deref_List (New_Res); + L.Append (New_Symbol_Mal_Type ("vec")); + L.Append (Res); + Res := New_Res; + end if; + + return Res; + + end Quasi_Quote_Processing; + + + function Catch_Processing + (Try_Line : Mal_Handle; + ExStr : Mal_Handle; + Env : Envs.Env_Handle) + return Mal_Handle is + + L, CL, CL2, CL3 : List_Mal_Type; + C : Mal_Handle; + New_Env : Envs.Env_Handle; + + begin + + L := Deref_List (Try_Line).all; + C := Car (L); + -- CL is the list with the catch in. + CL := Deref_List (C).all; + + CL2 := Deref_List (Cdr (CL)).all; + New_Env := Envs.New_Env (Env); + Envs.Set (New_Env, Deref_Sym (Car (CL2)).Get_Sym, ExStr); + + CL3 := Deref_List (Cdr (CL2)).all; + return Eval (Car (CL3), New_Env); + end Catch_Processing; + + + function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) + return Mal_Handle is + Param : Mal_Handle; + Env : Envs.Env_Handle; + First_Param, Rest_Params : Mal_Handle; + Rest_List, Param_List : List_Mal_Type; + begin + + Param := AParam; + Env := AnEnv; + + <> + + if Debug then + Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + end if; + + Param := Macro_Expand (Param, Env); + + if Debug then + Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String); + end if; + + if Deref (Param).Sym_Type = List and then + Deref_List (Param).Get_List_Type = List_List then + + Param_List := Deref_List (Param).all; + + -- Deal with empty list.. + if Param_List.Length = 0 then + return Param; + end if; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "def!" then + return Def_Fn (Rest_List, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "defmacro!" then + return Def_Macro (Rest_List, Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "macroexpand" then + return Macro_Expand (Car (Rest_List), Env); + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "let*" then + declare + Defs, Expr, Res : Mal_Handle; + E : Envs.Env_Handle; + begin + E := Envs.New_Env (Env); + Defs := Car (Rest_List); + Deref_List_Class (Defs).Add_Defs (E); + Expr := Car (Deref_List (Cdr (Rest_List)).all); + Param := Expr; + Env := E; + goto Tail_Call_Opt; + -- was: + -- Res := Eval (Expr, E); + -- return Res; + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "do" then + declare + D : List_Mal_Type; + E : Mal_Handle; + begin + + if Debug then + Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List)); + end if; + + if Is_Null (Rest_List) then + return Rest_Params; + end if; + + -- Loop processes Evals all but last entry + D := Rest_List; + loop + E := Car (D); + D := Deref_List (Cdr (D)).all; + exit when Is_Null (D); + E := Eval (E, Env); + end loop; + + Param := E; + goto Tail_Call_Opt; + + end; + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "if" then + declare + Args : List_Mal_Type := Rest_List; + + Cond, True_Part, False_Part : Mal_Handle; + Cond_Bool : Boolean; + pragma Assert (Length (Args) = 2 or Length (Args) = 3, + "If_Processing: not 2 or 3 parameters"); + L : List_Mal_Type; + begin + + Cond := Eval (Car (Args), Env); + + Cond_Bool := Eval_As_Boolean (Cond); + + if Cond_Bool then + L := Deref_List (Cdr (Args)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + if Length (Args) = 3 then + L := Deref_List (Cdr (Args)).all; + L := Deref_List (Cdr (L)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + return New_Nil_Mal_Type; + end if; + end if; + end; + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "fn*" then + + return New_Lambda_Mal_Type + (Params => Car (Rest_List), + Expr => Nth (Rest_List, 1), + Env => Env); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quote" then + + return Car (Rest_List); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then + + return Quasi_Quote_Processing (Car (Rest_List)); + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "quasiquote" then + + Param := Quasi_Quote_Processing (Car (Rest_List)); + goto Tail_Call_Opt; + + elsif Deref (First_Param).Sym_Type = Sym and then + Deref_Sym (First_Param).Get_Sym = "try*" then + + if Length (Rest_List) = 1 then + return Eval (Car (Rest_List), Env); + end if; + declare + Res : Mal_Handle; + begin + return Eval (Car (Rest_List), Env); + exception + when Mal_Exception => + Res := Catch_Processing + (Cdr (Rest_List), + Types.Mal_Exception_Value, + Env); + Types.Mal_Exception_Value := + Smart_Pointers.Null_Smart_Pointer; + return Res; + when E : others => + return Catch_Processing + (Cdr (Rest_List), + New_String_Mal_Type + (Ada.Exceptions.Exception_Message (E)), + Env); + end; + + else + + -- The APPLY section. + declare + Evaled_H : Mal_Handle; + begin + Evaled_H := Eval_Ast (Param, Env); + + Param_List := Deref_List (Evaled_H).all; + + First_Param := Car (Param_List); + Rest_Params := Cdr (Param_List); + Rest_List := Deref_List (Rest_Params).all; + + if Deref (First_Param).Sym_Type = Func then + return Call_Func (Deref_Func (First_Param).all, Rest_Params); + elsif Deref (First_Param).Sym_Type = Lambda then + declare + + L : Lambda_Mal_Type; + E : Envs.Env_Handle; + Param_Names : List_Mal_Type; + Res : Mal_Handle; + + begin + + L := Deref_Lambda (First_Param).all; + E := Envs.New_Env (L.Get_Env); + + Param_Names := Deref_List (L.Get_Params).all; + + if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then + + Param := L.Get_Expr; + Env := E; + goto Tail_Call_Opt; + -- was: return Eval (L.Get_Expr, E); + + else + + raise Runtime_Exception with "Bind failed in Apply"; + + end if; + + end; + + else -- neither a Lambda or a Func + raise Runtime_Exception with "Deref called on non-Func/Lambda"; + end if; + + end; + + end if; + + else -- not a List_List + + return Eval_Ast (Param, Env); + + end if; + + end Eval; + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String; Env : Envs.Env_Handle) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Eval (AST, Env); + return Print (Evaluated_AST); + end if; + + end Rep; + + + Repl_Env : Envs.Env_Handle; + + + -- These two ops use Repl_Env directly. + + + procedure RE (Str : Mal_String) is + Discarded : Mal_Handle; + begin + Discarded := Eval (Read (Str), Repl_Env); + end RE; + + + function Do_Eval (Rest_Handle : Mal_Handle) + return Types.Mal_Handle is + First_Param : Mal_Handle; + Rest_List : Types.List_Mal_Type; + begin + Rest_List := Deref_List (Rest_Handle).all; + First_Param := Car (Rest_List); + return Eval_Callback.Eval.all (First_Param, Repl_Env); + end Do_Eval; + + + Cmd_Args, File_Param : Natural; + Command_Args : Types.Mal_Handle; + Command_List : Types.List_Ptr; + File_Processed : Boolean := False; + +begin + + -- Save a function pointer back to the Eval function. + -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK + -- as we know Eval will be in scope for the lifetime of the program. + Eval_Callback.Eval := Eval'Unrestricted_Access; + + Repl_Env := Envs.New_Env; + + -- Core init also creates the first environment. + -- This is needed for the def!'s below. + Core.Init (Repl_Env); + + -- Register the eval command. This needs to be done here rather than Core.Init + -- as it requires direct access to Repl_Env. + Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access)); + + RE ("(def! not (fn* (a) (if a false true)))"); + RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))"); + RE ("(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)))))))"); + + -- Command line processing. + + Cmd_Args := 0; + Command_Args := Types.New_List_Mal_Type (Types.List_List); + Command_List := Types.Deref_List (Command_Args); + + while Ada.Command_Line.Argument_Count > Cmd_Args loop + + Cmd_Args := Cmd_Args + 1; + if Ada.Command_Line.Argument (Cmd_Args) = "-d" then + Debug := True; + elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then + Envs.Debug := True; + elsif not File_Processed then + File_Param := Cmd_Args; + File_Processed := True; + else + Command_List.Append + (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); + end if; + + end loop; + + Envs.Set (Repl_Env, "*ARGV*", Command_Args); + + if File_Processed then + RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)"); + else + RE("(println (str ""Mal ["" *host-language* ""]""))"); + loop + begin + Ada.Text_IO.Put ("user> "); + exit when Ada.Text_IO.End_Of_File; + Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env)); + exception + when E : others => + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + "Error: " & Ada.Exceptions.Exception_Information (E)); + if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then + Ada.Text_IO.Put_Line + (Ada.Text_IO.Standard_Error, + Printer.Pr_Str (Types.Mal_Exception_Value)); + Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer; + end if; + end; + end loop; + end if; +end StepA_Mal; diff --git a/impls/ada/types-hash_map.adb b/impls/ada/types-hash_map.adb index f672a7d21d..b6d7abd84a 100644 --- a/impls/ada/types-hash_map.adb +++ b/impls/ada/types-hash_map.adb @@ -1,285 +1,285 @@ -with Ada.Strings.Unbounded.Hash; -with Smart_Pointers; - -package body Types.Hash_Map is - - function "=" (A, B : Hash_Map_Mal_Type) return Boolean is - A_Key, A_Elem, B_Elem : Mal_Handle; - use Mal_Mal_Hash; - C : Cursor; - begin - if A.Length /= B.Length then - return False; - end if; - C := A.Hash.First; - while Has_Element (C) loop - A_Key := Key (C); - A_Elem := Element (C); - B_Elem := Mal_Mal_Hash.Element (B.Hash, A_Key); - if A_Elem /= B_Elem then - return False; - end if; - Next (C); - end loop; - return True; - end "="; - - function New_Hash_Map_Mal_Type - return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Hash_Map_Mal_Type' - (Mal_Type with - List_Type => Hashed_List, - The_List => Smart_Pointers.Null_Smart_Pointer, - Last_Elem => Smart_Pointers.Null_Smart_Pointer, - Is_Key_Expected => True, - Next_Key => Smart_Pointers.Null_Smart_Pointer, - Hash => Mal_Mal_Hash.Empty_Map)); - end New_Hash_Map_Mal_Type; - - overriding function Prepend (Op : Mal_Handle; To_Vector : Hash_Map_Mal_Type) - return Mal_Handle is - begin - raise Not_Appropriate; - return Smart_Pointers.Null_Smart_Pointer; - end Prepend; - - overriding procedure Append (V : in out Hash_Map_Mal_Type; E : Mal_Handle) is - begin - if V.Is_Key_Expected then - V.Next_Key := E; - else - Mal_Mal_Hash.Include - (Container => V.Hash, - Key => V.Next_Key, - New_Item => E); - end if; - V.Is_Key_Expected := not V.Is_Key_Expected; - end Append; - - overriding function Length (L : Hash_Map_Mal_Type) return Natural is - begin - return Natural (L.Hash.Length); - end Length; - - overriding function Is_Null (L : Hash_Map_Mal_Type) return Boolean is - begin - return L.Hash.Is_Empty; - end Is_Null; - - overriding function Null_List (L : List_Types) return Hash_Map_Mal_Type is - begin - return - Hash_Map_Mal_Type' - (Mal_Type with - List_Type => Hashed_List, - The_List => Smart_Pointers.Null_Smart_Pointer, - Last_Elem => Smart_Pointers.Null_Smart_Pointer, - Is_Key_Expected => False, - Next_Key => Smart_Pointers.Null_Smart_Pointer, - Hash => Mal_Mal_Hash.Empty_Map); - end Null_List; - - -- Duplicate copies the list (logically). This is to allow concatenation, - -- The result is always a List_List. - overriding function Duplicate (The_List : Hash_Map_Mal_Type) return Mal_Handle is - begin - raise Not_Appropriate; - return Smart_Pointers.Null_Smart_Pointer; - end Duplicate; - - overriding function Nth (L :Hash_Map_Mal_Type; N : Natural) return Mal_Handle is - begin - raise Not_Appropriate; - return Smart_Pointers.Null_Smart_Pointer; - end Nth; - - overriding procedure Add_Defs (Defs : Hash_Map_Mal_Type; Env : Envs.Env_Handle) is - begin - raise Not_Appropriate; - end Add_Defs; - - -- Get the first item in the list: - overriding function Car (L : Hash_Map_Mal_Type) return Mal_Handle is - begin - raise Not_Appropriate; - return Smart_Pointers.Null_Smart_Pointer; - end Car; - - -- Get the rest of the list (second item onwards) - overriding function Cdr (L : Hash_Map_Mal_Type) return Mal_Handle is - begin - raise Not_Appropriate; - return Smart_Pointers.Null_Smart_Pointer; - end Cdr; - - - overriding function Map - (Func_Ptr : Func_Access; - L : Hash_Map_Mal_Type) - return Mal_Handle is - Res : Mal_Handle; - use Mal_Mal_Hash; - C : Cursor; - begin - Res := New_Hash_Map_Mal_Type; - C := L.Hash.First; - while Has_Element (C) loop - -- Assuming we're not applying the func to the keys too. - Deref_Hash (Res).Hash.Include - (Key => Key (C), - New_Item => Func_Ptr (Element (C))); - Next (C); - end loop; - return Res; - end Map; - - function Assoc (H : Hash_Map_Mal_Type; List : Mal_Handle) return Mal_Handle is - Res : Mal_Handle; - Rest_List : List_Mal_Type; - use Mal_Mal_Hash; - C : Cursor; - begin - Res := New_Hash_Map_Mal_Type; - Rest_List := Deref_List (List).all; - - -- Copy arg into result. - Deref_Hash (Res).Hash := H.Hash; - - while not Is_Null (Rest_List) loop - Deref_Hash (Res).Append (Car (Rest_List)); - Rest_List := Deref_List (Cdr (Rest_List)).all; - end loop; - return Res; - end Assoc; - - - function Dis_Assoc (H : Hash_Map_Mal_Type; List : Mal_Handle) return Mal_Handle is - Res : Mal_Handle; - Rest_List : List_Mal_Type; - use Mal_Mal_Hash; - C : Cursor; - begin - Res := New_Hash_Map_Mal_Type; - Rest_List := Deref_List (List).all; - - -- Copy arg into result. - Deref_Hash (Res).Hash := H.Hash; - - while not Is_Null (Rest_List) loop - Mal_Mal_Hash.Exclude (Deref_Hash (Res).Hash, Car (Rest_List)); - Rest_List := Deref_List (Cdr (Rest_List)).all; - end loop; - return Res; - end Dis_Assoc; - - - function Get (H : Hash_Map_Mal_Type; Key : Mal_Handle) return Mal_Handle is - use Mal_Mal_Hash; - C : Cursor; - begin - C := Mal_Mal_Hash.Find (H.Hash, Key); - if Has_Element (C) then - return Element (C); - else - return New_Nil_Mal_Type; - end if; - end Get; - - - function All_Keys (H : Hash_Map_Mal_Type) return Mal_Handle is - Res, Map_Key : Mal_Handle; - use Mal_Mal_Hash; - C : Cursor; - begin - Res := New_List_Mal_Type (List_List); - C := H.Hash.First; - while Has_Element (C) loop - Map_Key := Key (C); - Deref_List (Res).Append (Map_Key); - Next (C); - end loop; - return Res; - end All_Keys; - - - function All_Values (H : Hash_Map_Mal_Type) return Mal_Handle is - Res, Map_Val : Mal_Handle; - use Mal_Mal_Hash; - C : Cursor; - begin - Res := New_List_Mal_Type (List_List); - C := H.Hash.First; - while Has_Element (C) loop - Map_Val := Element (C); - Deref_List (Res).Append (Map_Val); - Next (C); - end loop; - return Res; - end All_Values; - - - function Contains (H : Hash_Map_Mal_Type; Key : Mal_Handle) return Boolean is - begin - return Mal_Mal_Hash.Contains (H.Hash, Key); - end Contains; - - function Deref_Hash (SP : Mal_Handle) return Hash_Ptr is - begin - return Hash_Ptr (Deref (SP)); - end Deref_Hash; - - function Hash (M : Mal_Handle) return Ada.Containers.Hash_Type is - begin - return Ada.Strings.Unbounded.Hash - (Ada.Strings.Unbounded.To_Unbounded_String - (Deref (M).To_String)); - end Hash; - - overriding function To_Str - (T : Hash_Map_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - use Ada.Containers; - begin - if (T.Hash.Length = 0) then - return Opening (T.List_Type) & - Closing (T.List_Type); - else - declare - Res : Ada.Strings.Unbounded.Unbounded_String; - use Mal_Mal_Hash; - C : Cursor; - begin - C := First (T.Hash); - - Res := Ada.Strings.Unbounded."&" - (Opening (T.List_Type), - Ada.Strings.Unbounded.To_Unbounded_String - (To_String (Deref (Key (C)).all, Print_Readably))); - Res := Ada.Strings.Unbounded."&" (Res, " "); - Res := Ada.Strings.Unbounded."&" - (Res, - Ada.Strings.Unbounded.To_Unbounded_String - (To_String (Deref (Element (C)).all, Print_Readably))); - Next (C); - while Has_Element (C) loop - Res := Ada.Strings.Unbounded."&" (Res, " "); - Res := Ada.Strings.Unbounded."&" - (Res, - Ada.Strings.Unbounded.To_Unbounded_String - (To_String (Deref (Key (C)).all, Print_Readably))); - Res := Ada.Strings.Unbounded."&" (Res, " "); - Res := Ada.Strings.Unbounded."&" - (Res, - Ada.Strings.Unbounded.To_Unbounded_String - (To_String (Deref (Element (C)).all, Print_Readably))); - Next (C); - end loop; - Res := Ada.Strings.Unbounded."&" (Res, Closing (T.List_Type)); - return Ada.Strings.Unbounded.To_String (Res); - end; - end if; - end To_Str; - -end Types.Hash_Map; +with Ada.Strings.Unbounded.Hash; +with Smart_Pointers; + +package body Types.Hash_Map is + + function "=" (A, B : Hash_Map_Mal_Type) return Boolean is + A_Key, A_Elem, B_Elem : Mal_Handle; + use Mal_Mal_Hash; + C : Cursor; + begin + if A.Length /= B.Length then + return False; + end if; + C := A.Hash.First; + while Has_Element (C) loop + A_Key := Key (C); + A_Elem := Element (C); + B_Elem := Mal_Mal_Hash.Element (B.Hash, A_Key); + if A_Elem /= B_Elem then + return False; + end if; + Next (C); + end loop; + return True; + end "="; + + function New_Hash_Map_Mal_Type + return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Hash_Map_Mal_Type' + (Mal_Type with + List_Type => Hashed_List, + The_List => Smart_Pointers.Null_Smart_Pointer, + Last_Elem => Smart_Pointers.Null_Smart_Pointer, + Is_Key_Expected => True, + Next_Key => Smart_Pointers.Null_Smart_Pointer, + Hash => Mal_Mal_Hash.Empty_Map)); + end New_Hash_Map_Mal_Type; + + overriding function Prepend (Op : Mal_Handle; To_Vector : Hash_Map_Mal_Type) + return Mal_Handle is + begin + raise Not_Appropriate; + return Smart_Pointers.Null_Smart_Pointer; + end Prepend; + + overriding procedure Append (V : in out Hash_Map_Mal_Type; E : Mal_Handle) is + begin + if V.Is_Key_Expected then + V.Next_Key := E; + else + Mal_Mal_Hash.Include + (Container => V.Hash, + Key => V.Next_Key, + New_Item => E); + end if; + V.Is_Key_Expected := not V.Is_Key_Expected; + end Append; + + overriding function Length (L : Hash_Map_Mal_Type) return Natural is + begin + return Natural (L.Hash.Length); + end Length; + + overriding function Is_Null (L : Hash_Map_Mal_Type) return Boolean is + begin + return L.Hash.Is_Empty; + end Is_Null; + + overriding function Null_List (L : List_Types) return Hash_Map_Mal_Type is + begin + return + Hash_Map_Mal_Type' + (Mal_Type with + List_Type => Hashed_List, + The_List => Smart_Pointers.Null_Smart_Pointer, + Last_Elem => Smart_Pointers.Null_Smart_Pointer, + Is_Key_Expected => False, + Next_Key => Smart_Pointers.Null_Smart_Pointer, + Hash => Mal_Mal_Hash.Empty_Map); + end Null_List; + + -- Duplicate copies the list (logically). This is to allow concatenation, + -- The result is always a List_List. + overriding function Duplicate (The_List : Hash_Map_Mal_Type) return Mal_Handle is + begin + raise Not_Appropriate; + return Smart_Pointers.Null_Smart_Pointer; + end Duplicate; + + overriding function Nth (L :Hash_Map_Mal_Type; N : Natural) return Mal_Handle is + begin + raise Not_Appropriate; + return Smart_Pointers.Null_Smart_Pointer; + end Nth; + + overriding procedure Add_Defs (Defs : Hash_Map_Mal_Type; Env : Envs.Env_Handle) is + begin + raise Not_Appropriate; + end Add_Defs; + + -- Get the first item in the list: + overriding function Car (L : Hash_Map_Mal_Type) return Mal_Handle is + begin + raise Not_Appropriate; + return Smart_Pointers.Null_Smart_Pointer; + end Car; + + -- Get the rest of the list (second item onwards) + overriding function Cdr (L : Hash_Map_Mal_Type) return Mal_Handle is + begin + raise Not_Appropriate; + return Smart_Pointers.Null_Smart_Pointer; + end Cdr; + + + overriding function Map + (Func_Ptr : Func_Access; + L : Hash_Map_Mal_Type) + return Mal_Handle is + Res : Mal_Handle; + use Mal_Mal_Hash; + C : Cursor; + begin + Res := New_Hash_Map_Mal_Type; + C := L.Hash.First; + while Has_Element (C) loop + -- Assuming we're not applying the func to the keys too. + Deref_Hash (Res).Hash.Include + (Key => Key (C), + New_Item => Func_Ptr (Element (C))); + Next (C); + end loop; + return Res; + end Map; + + function Assoc (H : Hash_Map_Mal_Type; List : Mal_Handle) return Mal_Handle is + Res : Mal_Handle; + Rest_List : List_Mal_Type; + use Mal_Mal_Hash; + C : Cursor; + begin + Res := New_Hash_Map_Mal_Type; + Rest_List := Deref_List (List).all; + + -- Copy arg into result. + Deref_Hash (Res).Hash := H.Hash; + + while not Is_Null (Rest_List) loop + Deref_Hash (Res).Append (Car (Rest_List)); + Rest_List := Deref_List (Cdr (Rest_List)).all; + end loop; + return Res; + end Assoc; + + + function Dis_Assoc (H : Hash_Map_Mal_Type; List : Mal_Handle) return Mal_Handle is + Res : Mal_Handle; + Rest_List : List_Mal_Type; + use Mal_Mal_Hash; + C : Cursor; + begin + Res := New_Hash_Map_Mal_Type; + Rest_List := Deref_List (List).all; + + -- Copy arg into result. + Deref_Hash (Res).Hash := H.Hash; + + while not Is_Null (Rest_List) loop + Mal_Mal_Hash.Exclude (Deref_Hash (Res).Hash, Car (Rest_List)); + Rest_List := Deref_List (Cdr (Rest_List)).all; + end loop; + return Res; + end Dis_Assoc; + + + function Get (H : Hash_Map_Mal_Type; Key : Mal_Handle) return Mal_Handle is + use Mal_Mal_Hash; + C : Cursor; + begin + C := Mal_Mal_Hash.Find (H.Hash, Key); + if Has_Element (C) then + return Element (C); + else + return New_Nil_Mal_Type; + end if; + end Get; + + + function All_Keys (H : Hash_Map_Mal_Type) return Mal_Handle is + Res, Map_Key : Mal_Handle; + use Mal_Mal_Hash; + C : Cursor; + begin + Res := New_List_Mal_Type (List_List); + C := H.Hash.First; + while Has_Element (C) loop + Map_Key := Key (C); + Deref_List (Res).Append (Map_Key); + Next (C); + end loop; + return Res; + end All_Keys; + + + function All_Values (H : Hash_Map_Mal_Type) return Mal_Handle is + Res, Map_Val : Mal_Handle; + use Mal_Mal_Hash; + C : Cursor; + begin + Res := New_List_Mal_Type (List_List); + C := H.Hash.First; + while Has_Element (C) loop + Map_Val := Element (C); + Deref_List (Res).Append (Map_Val); + Next (C); + end loop; + return Res; + end All_Values; + + + function Contains (H : Hash_Map_Mal_Type; Key : Mal_Handle) return Boolean is + begin + return Mal_Mal_Hash.Contains (H.Hash, Key); + end Contains; + + function Deref_Hash (SP : Mal_Handle) return Hash_Ptr is + begin + return Hash_Ptr (Deref (SP)); + end Deref_Hash; + + function Hash (M : Mal_Handle) return Ada.Containers.Hash_Type is + begin + return Ada.Strings.Unbounded.Hash + (Ada.Strings.Unbounded.To_Unbounded_String + (Deref (M).To_String)); + end Hash; + + overriding function To_Str + (T : Hash_Map_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + use Ada.Containers; + begin + if (T.Hash.Length = 0) then + return Opening (T.List_Type) & + Closing (T.List_Type); + else + declare + Res : Ada.Strings.Unbounded.Unbounded_String; + use Mal_Mal_Hash; + C : Cursor; + begin + C := First (T.Hash); + + Res := Ada.Strings.Unbounded."&" + (Opening (T.List_Type), + Ada.Strings.Unbounded.To_Unbounded_String + (To_String (Deref (Key (C)).all, Print_Readably))); + Res := Ada.Strings.Unbounded."&" (Res, " "); + Res := Ada.Strings.Unbounded."&" + (Res, + Ada.Strings.Unbounded.To_Unbounded_String + (To_String (Deref (Element (C)).all, Print_Readably))); + Next (C); + while Has_Element (C) loop + Res := Ada.Strings.Unbounded."&" (Res, " "); + Res := Ada.Strings.Unbounded."&" + (Res, + Ada.Strings.Unbounded.To_Unbounded_String + (To_String (Deref (Key (C)).all, Print_Readably))); + Res := Ada.Strings.Unbounded."&" (Res, " "); + Res := Ada.Strings.Unbounded."&" + (Res, + Ada.Strings.Unbounded.To_Unbounded_String + (To_String (Deref (Element (C)).all, Print_Readably))); + Next (C); + end loop; + Res := Ada.Strings.Unbounded."&" (Res, Closing (T.List_Type)); + return Ada.Strings.Unbounded.To_String (Res); + end; + end if; + end To_Str; + +end Types.Hash_Map; diff --git a/impls/ada/types-hash_map.ads b/impls/ada/types-hash_map.ads index 10d9e4274e..35ee2bc923 100644 --- a/impls/ada/types-hash_map.ads +++ b/impls/ada/types-hash_map.ads @@ -1,83 +1,83 @@ -with Ada.Containers.Hashed_Maps; -with Smart_Pointers; -with Envs; - -package Types.Hash_Map is - - type Hash_Map_Mal_Type is new List_Mal_Type with private; - - function New_Hash_Map_Mal_Type - return Mal_Handle; - - function "=" (A, B : Hash_Map_Mal_Type) return Boolean; - - overriding function Prepend (Op : Mal_Handle; To_Vector : Hash_Map_Mal_Type) - return Mal_Handle; - - overriding procedure Append (V : in out Hash_Map_Mal_Type; E : Mal_Handle); - - overriding function Length (L : Hash_Map_Mal_Type) return Natural; - - overriding function Is_Null (L : Hash_Map_Mal_Type) return Boolean; - - overriding function Null_List (L : List_Types) return Hash_Map_Mal_Type; - - -- Duplicate copies the list (logically). This is to allow concatenation, - -- The result is always a List_List. - overriding function Duplicate (The_List : Hash_Map_Mal_Type) return Mal_Handle; - - overriding function Nth (L :Hash_Map_Mal_Type; N : Natural) return Mal_Handle; - - overriding procedure Add_Defs (Defs : Hash_Map_Mal_Type; Env : Envs.Env_Handle); - - -- Get the first item in the list: - overriding function Car (L : Hash_Map_Mal_Type) return Mal_Handle; - - -- Get the rest of the list (second item onwards) - overriding function Cdr (L : Hash_Map_Mal_Type) return Mal_Handle; - - overriding function Map - (Func_Ptr : Func_Access; - L : Hash_Map_Mal_Type) - return Mal_Handle; - - function Assoc (H : Hash_Map_Mal_Type; List : Mal_Handle) return Mal_Handle; - - function Dis_Assoc (H : Hash_Map_Mal_Type; List : Mal_Handle) return Mal_Handle; - - function Get (H : Hash_Map_Mal_Type; Key : Mal_Handle) return Mal_Handle; - - function All_Keys (H : Hash_Map_Mal_Type) return Mal_Handle; - - function All_Values (H : Hash_Map_Mal_Type) return Mal_Handle; - - function Contains (H : Hash_Map_Mal_Type; Key : Mal_Handle) return Boolean; - - type Hash_Ptr is access all Hash_Map_Mal_Type; - - function Deref_Hash (SP : Mal_Handle) return Hash_Ptr; - - Not_Appropriate : exception; - -private - - function Hash (M : Mal_Handle) return Ada.Containers.Hash_Type; - - package Mal_Mal_Hash is new Ada.Containers.Hashed_Maps - (Key_Type => Mal_Handle, - Element_Type => Mal_Handle, - Hash => Hash, - Equivalent_Keys => "=", - "=" => "="); - - type Hash_Map_Mal_Type is new List_Mal_Type with record - Is_Key_Expected : Boolean := True; - Next_Key : Mal_Handle; - Hash : Mal_Mal_Hash.Map; - end record; - - overriding function To_Str - (T : Hash_Map_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - -end Types.Hash_Map; +with Ada.Containers.Hashed_Maps; +with Smart_Pointers; +with Envs; + +package Types.Hash_Map is + + type Hash_Map_Mal_Type is new List_Mal_Type with private; + + function New_Hash_Map_Mal_Type + return Mal_Handle; + + function "=" (A, B : Hash_Map_Mal_Type) return Boolean; + + overriding function Prepend (Op : Mal_Handle; To_Vector : Hash_Map_Mal_Type) + return Mal_Handle; + + overriding procedure Append (V : in out Hash_Map_Mal_Type; E : Mal_Handle); + + overriding function Length (L : Hash_Map_Mal_Type) return Natural; + + overriding function Is_Null (L : Hash_Map_Mal_Type) return Boolean; + + overriding function Null_List (L : List_Types) return Hash_Map_Mal_Type; + + -- Duplicate copies the list (logically). This is to allow concatenation, + -- The result is always a List_List. + overriding function Duplicate (The_List : Hash_Map_Mal_Type) return Mal_Handle; + + overriding function Nth (L :Hash_Map_Mal_Type; N : Natural) return Mal_Handle; + + overriding procedure Add_Defs (Defs : Hash_Map_Mal_Type; Env : Envs.Env_Handle); + + -- Get the first item in the list: + overriding function Car (L : Hash_Map_Mal_Type) return Mal_Handle; + + -- Get the rest of the list (second item onwards) + overriding function Cdr (L : Hash_Map_Mal_Type) return Mal_Handle; + + overriding function Map + (Func_Ptr : Func_Access; + L : Hash_Map_Mal_Type) + return Mal_Handle; + + function Assoc (H : Hash_Map_Mal_Type; List : Mal_Handle) return Mal_Handle; + + function Dis_Assoc (H : Hash_Map_Mal_Type; List : Mal_Handle) return Mal_Handle; + + function Get (H : Hash_Map_Mal_Type; Key : Mal_Handle) return Mal_Handle; + + function All_Keys (H : Hash_Map_Mal_Type) return Mal_Handle; + + function All_Values (H : Hash_Map_Mal_Type) return Mal_Handle; + + function Contains (H : Hash_Map_Mal_Type; Key : Mal_Handle) return Boolean; + + type Hash_Ptr is access all Hash_Map_Mal_Type; + + function Deref_Hash (SP : Mal_Handle) return Hash_Ptr; + + Not_Appropriate : exception; + +private + + function Hash (M : Mal_Handle) return Ada.Containers.Hash_Type; + + package Mal_Mal_Hash is new Ada.Containers.Hashed_Maps + (Key_Type => Mal_Handle, + Element_Type => Mal_Handle, + Hash => Hash, + Equivalent_Keys => "=", + "=" => "="); + + type Hash_Map_Mal_Type is new List_Mal_Type with record + Is_Key_Expected : Boolean := True; + Next_Key : Mal_Handle; + Hash : Mal_Mal_Hash.Map; + end record; + + overriding function To_Str + (T : Hash_Map_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + +end Types.Hash_Map; diff --git a/impls/ada/types-vector.adb b/impls/ada/types-vector.adb index b4dc70f56e..d42ad9d980 100644 --- a/impls/ada/types-vector.adb +++ b/impls/ada/types-vector.adb @@ -1,196 +1,196 @@ -with Ada.Strings.Unbounded; -with Ada.Text_IO; -with Eval_Callback; - -package body Types.Vector is - - - function New_Vector_Mal_Type - return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Vector_Mal_Type' - (Mal_Type with - List_Type => Vector_List, - The_List => Smart_Pointers.Null_Smart_Pointer, - Last_Elem => Smart_Pointers.Null_Smart_Pointer, - Vec => Mal_Vectors.Empty_Vector)); - end New_Vector_Mal_Type; - - - overriding function Prepend (Op : Mal_Handle; To_Vector : Vector_Mal_Type) - return Mal_Handle is - begin - return Types.Prepend (Op, Deref_List (To_Vector.Duplicate).all); - end Prepend; - - - overriding procedure Append (V : in out Vector_Mal_Type; E : Mal_Handle) is - begin - Mal_Vectors.Append (V.Vec, E); - end Append; - - - overriding function Is_Null (L : Vector_Mal_Type) return Boolean is - use Ada.Containers; - begin - return L.Vec.Is_Empty; - end Is_Null; - - - overriding function Null_List (L : List_Types) return Vector_Mal_Type is - begin - return Vector_Mal_Type' - (Mal_Type with - List_Type => Vector_List, - The_List => Smart_Pointers.Null_Smart_Pointer, - Last_Elem => Smart_Pointers.Null_Smart_Pointer, - Vec => Mal_Vectors.Empty_Vector); - end Null_List; - - - -- Duplicate copies the list (logically). This is to allow concatenation, - -- The result is always a List_List. - overriding function Duplicate (The_List : Vector_Mal_Type) return Mal_Handle is - Res : Mal_Handle; - use Mal_Vectors; - C : Cursor; - begin - Res := New_List_Mal_Type (List_List); - C := First (The_List.Vec); - while Has_Element (C) loop - Deref_List (Res).Append (Element (C)); - Next (C); - end loop; - return Res; - end Duplicate; - - - function Length (L : Vector_Mal_Type) return Natural is - begin - return Natural (L.Vec.Length); - end Length; - - - procedure Add_Defs (Defs : Vector_Mal_Type; Env : Envs.Env_Handle) is - C, D : Cursor; - begin - C := Defs.Vec.First; - while Has_Element (C) loop - D := Next (C); - exit when not Has_Element (D); - Envs.Set - (Env, - Deref_Sym (Element (C)).Get_Sym, - Eval_Callback.Eval.all (Element (D), Env)); - C := Next (D); - end loop; - end Add_Defs; - - - overriding function Nth (L : Vector_Mal_Type; N : Natural) return Mal_Handle is - begin - if N >= L.Length then - raise Runtime_Exception with "Nth (vector): Index out of range"; - else - return Mal_Vectors.Element (L.Vec, Vec_Index (N)); - end if; - end Nth; - - - -- Get the first item in the list: - overriding function Car (L : Vector_Mal_Type) return Mal_Handle is - begin - return L.Vec.Element (0); - end Car; - - -- Get the rest of the list (second item onwards) - - overriding function Cdr (L : Vector_Mal_Type) return Mal_Handle is - Res : Mal_Handle; - Vec_P : Vector_Ptr; - C : Mal_Vectors.Cursor; - I : Vec_Index; - use Ada.Containers; - begin - Res := New_Vector_Mal_Type; - if L.Vec.Length < 2 then - return Res; - end if; - Vec_P := Deref_Vector (Res); - Vec_P.Vec := To_Vector (L.Vec.Length - 1); - - -- Set C to second entry. - C := L.Vec.First; - Mal_Vectors.Next (C); - - I := 0; - while Mal_Vectors.Has_Element (C) loop - Mal_Vectors.Replace_Element (Vec_P.Vec, I, Mal_Vectors.Element (C)); - Mal_Vectors.Next (C); - I := I + 1; - end loop; - return Res; - end Cdr; - - overriding function Map - (Func_Ptr : Func_Access; - L : Vector_Mal_Type) - return Mal_Handle is - Res : Mal_Handle; - use Mal_Vectors; - C : Cursor; - begin - Res := New_Vector_Mal_Type; - C := First (L.Vec); - while Has_Element (C) loop - Deref_Vector (Res).Append (Func_Ptr.all (Element (C))); - Next (C); - end loop; - return Res; - end Map; - - - function Deref_Vector (SP : Mal_Handle) return Vector_Ptr is - begin - return Vector_Ptr (Deref (SP)); - end Deref_Vector; - - - overriding function To_Str - (T : Vector_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - use Ada.Containers; - begin - if (T.Vec.Length = 0) then - return Opening (T.List_Type) & - Closing (T.List_Type); - else - declare - Res : Ada.Strings.Unbounded.Unbounded_String; - use Mal_Vectors; - C : Cursor; - begin - C := First (T.Vec); - - Res := Ada.Strings.Unbounded."&" - (Opening (T.List_Type), - Ada.Strings.Unbounded.To_Unbounded_String - (To_String (Deref (Element (C)).all, Print_Readably))); - Next (C); - while Has_Element (C) loop - Res := Ada.Strings.Unbounded."&" (Res, " "); - Res := Ada.Strings.Unbounded."&" - (Res, - Ada.Strings.Unbounded.To_Unbounded_String - (To_String (Deref (Element (C)).all, Print_Readably))); - Next (C); - end loop; - Res := Ada.Strings.Unbounded."&" (Res, Closing (T.List_Type)); - return Ada.Strings.Unbounded.To_String (Res); - end; - end if; - end To_Str; - - -end Types.Vector; +with Ada.Strings.Unbounded; +with Ada.Text_IO; +with Eval_Callback; + +package body Types.Vector is + + + function New_Vector_Mal_Type + return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Vector_Mal_Type' + (Mal_Type with + List_Type => Vector_List, + The_List => Smart_Pointers.Null_Smart_Pointer, + Last_Elem => Smart_Pointers.Null_Smart_Pointer, + Vec => Mal_Vectors.Empty_Vector)); + end New_Vector_Mal_Type; + + + overriding function Prepend (Op : Mal_Handle; To_Vector : Vector_Mal_Type) + return Mal_Handle is + begin + return Types.Prepend (Op, Deref_List (To_Vector.Duplicate).all); + end Prepend; + + + overriding procedure Append (V : in out Vector_Mal_Type; E : Mal_Handle) is + begin + Mal_Vectors.Append (V.Vec, E); + end Append; + + + overriding function Is_Null (L : Vector_Mal_Type) return Boolean is + use Ada.Containers; + begin + return L.Vec.Is_Empty; + end Is_Null; + + + overriding function Null_List (L : List_Types) return Vector_Mal_Type is + begin + return Vector_Mal_Type' + (Mal_Type with + List_Type => Vector_List, + The_List => Smart_Pointers.Null_Smart_Pointer, + Last_Elem => Smart_Pointers.Null_Smart_Pointer, + Vec => Mal_Vectors.Empty_Vector); + end Null_List; + + + -- Duplicate copies the list (logically). This is to allow concatenation, + -- The result is always a List_List. + overriding function Duplicate (The_List : Vector_Mal_Type) return Mal_Handle is + Res : Mal_Handle; + use Mal_Vectors; + C : Cursor; + begin + Res := New_List_Mal_Type (List_List); + C := First (The_List.Vec); + while Has_Element (C) loop + Deref_List (Res).Append (Element (C)); + Next (C); + end loop; + return Res; + end Duplicate; + + + function Length (L : Vector_Mal_Type) return Natural is + begin + return Natural (L.Vec.Length); + end Length; + + + procedure Add_Defs (Defs : Vector_Mal_Type; Env : Envs.Env_Handle) is + C, D : Cursor; + begin + C := Defs.Vec.First; + while Has_Element (C) loop + D := Next (C); + exit when not Has_Element (D); + Envs.Set + (Env, + Deref_Sym (Element (C)).Get_Sym, + Eval_Callback.Eval.all (Element (D), Env)); + C := Next (D); + end loop; + end Add_Defs; + + + overriding function Nth (L : Vector_Mal_Type; N : Natural) return Mal_Handle is + begin + if N >= L.Length then + raise Runtime_Exception with "Nth (vector): Index out of range"; + else + return Mal_Vectors.Element (L.Vec, Vec_Index (N)); + end if; + end Nth; + + + -- Get the first item in the list: + overriding function Car (L : Vector_Mal_Type) return Mal_Handle is + begin + return L.Vec.Element (0); + end Car; + + -- Get the rest of the list (second item onwards) + + overriding function Cdr (L : Vector_Mal_Type) return Mal_Handle is + Res : Mal_Handle; + Vec_P : Vector_Ptr; + C : Mal_Vectors.Cursor; + I : Vec_Index; + use Ada.Containers; + begin + Res := New_Vector_Mal_Type; + if L.Vec.Length < 2 then + return Res; + end if; + Vec_P := Deref_Vector (Res); + Vec_P.Vec := To_Vector (L.Vec.Length - 1); + + -- Set C to second entry. + C := L.Vec.First; + Mal_Vectors.Next (C); + + I := 0; + while Mal_Vectors.Has_Element (C) loop + Mal_Vectors.Replace_Element (Vec_P.Vec, I, Mal_Vectors.Element (C)); + Mal_Vectors.Next (C); + I := I + 1; + end loop; + return Res; + end Cdr; + + overriding function Map + (Func_Ptr : Func_Access; + L : Vector_Mal_Type) + return Mal_Handle is + Res : Mal_Handle; + use Mal_Vectors; + C : Cursor; + begin + Res := New_Vector_Mal_Type; + C := First (L.Vec); + while Has_Element (C) loop + Deref_Vector (Res).Append (Func_Ptr.all (Element (C))); + Next (C); + end loop; + return Res; + end Map; + + + function Deref_Vector (SP : Mal_Handle) return Vector_Ptr is + begin + return Vector_Ptr (Deref (SP)); + end Deref_Vector; + + + overriding function To_Str + (T : Vector_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + use Ada.Containers; + begin + if (T.Vec.Length = 0) then + return Opening (T.List_Type) & + Closing (T.List_Type); + else + declare + Res : Ada.Strings.Unbounded.Unbounded_String; + use Mal_Vectors; + C : Cursor; + begin + C := First (T.Vec); + + Res := Ada.Strings.Unbounded."&" + (Opening (T.List_Type), + Ada.Strings.Unbounded.To_Unbounded_String + (To_String (Deref (Element (C)).all, Print_Readably))); + Next (C); + while Has_Element (C) loop + Res := Ada.Strings.Unbounded."&" (Res, " "); + Res := Ada.Strings.Unbounded."&" + (Res, + Ada.Strings.Unbounded.To_Unbounded_String + (To_String (Deref (Element (C)).all, Print_Readably))); + Next (C); + end loop; + Res := Ada.Strings.Unbounded."&" (Res, Closing (T.List_Type)); + return Ada.Strings.Unbounded.To_String (Res); + end; + end if; + end To_Str; + + +end Types.Vector; diff --git a/impls/ada/types-vector.ads b/impls/ada/types-vector.ads index 27d6c57771..51ef074fcd 100644 --- a/impls/ada/types-vector.ads +++ b/impls/ada/types-vector.ads @@ -1,66 +1,66 @@ -with Ada.Containers.Vectors; -with Ada.Strings.Unbounded; -with Smart_Pointers; -with Envs; - -package Types.Vector is - - type Vector_Mal_Type is new List_Mal_Type with private; - - function New_Vector_Mal_Type - return Mal_Handle; - - overriding function Prepend (Op : Mal_Handle; To_Vector : Vector_Mal_Type) - return Mal_Handle; - - overriding procedure Append (V : in out Vector_Mal_Type; E : Mal_Handle); - - overriding function Length (L : Vector_Mal_Type) return Natural; - - overriding function Is_Null (L : Vector_Mal_Type) return Boolean; - - overriding function Null_List (L : List_Types) return Vector_Mal_Type; - - -- Duplicate copies the list (logically). This is to allow concatenation, - -- The result is always a List_List. - overriding function Duplicate (The_List : Vector_Mal_Type) return Mal_Handle; - - overriding function Nth (L : Vector_Mal_Type; N : Natural) return Mal_Handle; - - overriding procedure Add_Defs (Defs : Vector_Mal_Type; Env : Envs.Env_Handle); - - -- Get the first item in the list: - overriding function Car (L : Vector_Mal_Type) return Mal_Handle; - - -- Get the rest of the list (second item onwards) - overriding function Cdr (L : Vector_Mal_Type) return Mal_Handle; - - overriding function Map - (Func_Ptr : Func_Access; - L : Vector_Mal_Type) - return Mal_Handle; - - type Vector_Ptr is access all Vector_Mal_Type; - - function Deref_Vector (SP : Mal_Handle) return Vector_Ptr; - -private - - subtype Vec_Index is Integer range 0 .. 100; - package Mal_Vectors is new - Ada.Containers.Vectors - (Index_Type => Vec_Index, - Element_Type => Mal_Handle, - "=" => "="); - - use Mal_Vectors; - - type Vector_Mal_Type is new List_Mal_Type with record - Vec : Mal_Vectors.Vector; - end record; - - overriding function To_Str - (T : Vector_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - -end Types.Vector; +with Ada.Containers.Vectors; +with Ada.Strings.Unbounded; +with Smart_Pointers; +with Envs; + +package Types.Vector is + + type Vector_Mal_Type is new List_Mal_Type with private; + + function New_Vector_Mal_Type + return Mal_Handle; + + overriding function Prepend (Op : Mal_Handle; To_Vector : Vector_Mal_Type) + return Mal_Handle; + + overriding procedure Append (V : in out Vector_Mal_Type; E : Mal_Handle); + + overriding function Length (L : Vector_Mal_Type) return Natural; + + overriding function Is_Null (L : Vector_Mal_Type) return Boolean; + + overriding function Null_List (L : List_Types) return Vector_Mal_Type; + + -- Duplicate copies the list (logically). This is to allow concatenation, + -- The result is always a List_List. + overriding function Duplicate (The_List : Vector_Mal_Type) return Mal_Handle; + + overriding function Nth (L : Vector_Mal_Type; N : Natural) return Mal_Handle; + + overriding procedure Add_Defs (Defs : Vector_Mal_Type; Env : Envs.Env_Handle); + + -- Get the first item in the list: + overriding function Car (L : Vector_Mal_Type) return Mal_Handle; + + -- Get the rest of the list (second item onwards) + overriding function Cdr (L : Vector_Mal_Type) return Mal_Handle; + + overriding function Map + (Func_Ptr : Func_Access; + L : Vector_Mal_Type) + return Mal_Handle; + + type Vector_Ptr is access all Vector_Mal_Type; + + function Deref_Vector (SP : Mal_Handle) return Vector_Ptr; + +private + + subtype Vec_Index is Integer range 0 .. 100; + package Mal_Vectors is new + Ada.Containers.Vectors + (Index_Type => Vec_Index, + Element_Type => Mal_Handle, + "=" => "="); + + use Mal_Vectors; + + type Vector_Mal_Type is new List_Mal_Type with record + Vec : Mal_Vectors.Vector; + end record; + + overriding function To_Str + (T : Vector_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + +end Types.Vector; diff --git a/impls/ada/types.adb b/impls/ada/types.adb index 29b8d2b181..31299fb14f 100644 --- a/impls/ada/types.adb +++ b/impls/ada/types.adb @@ -1,1196 +1,1196 @@ -with Ada.Characters.Latin_1; -with Ada.Strings.Fixed; -with Ada.Strings.Maps.Constants; -with Ada.Text_IO; -with Ada.Unchecked_Deallocation; -with Envs; -with Eval_Callback; -with Smart_Pointers; -with Types.Vector; -with Types.Hash_Map; - -package body Types is - - package ACL renames Ada.Characters.Latin_1; - - function Nodes_Equal (A, B : Mal_Handle) return Boolean; - - - function "=" (A, B : Mal_Handle) return Mal_Handle is - begin - return New_Bool_Mal_Type (A = B); - end "="; - - - function Compare_List_And_Vector (A : List_Mal_Type; B : List_Mal_Type'Class) - return Boolean is - First_Node, First_Index : Mal_Handle; - I : Natural := 0; - begin - First_Node := A.The_List; - loop - if not Is_Null (First_Node) and I < B.Length then - First_Index := B.Nth (I); - if not "=" (Deref_Node (First_Node).Data, First_Index) then - return False; - end if; - First_Node := Deref_Node (First_Node).Next; - I := I + 1; - else - return Is_Null (First_Node) and I = B.Length; - end if; - end loop; - end Compare_List_And_Vector; - - - function "=" (A, B : Mal_Handle) return Boolean is - use Types.Vector; - use Types.Hash_Map; - begin - - if (not Is_Null (A) and not Is_Null (B)) and then - Deref (A).Sym_Type = Deref (B).Sym_Type then - - case Deref (A).Sym_Type is - when Nil => - return True; -- Both nil. - when Int => - return (Deref_Int (A).Get_Int_Val = Deref_Int (B).Get_Int_Val); - when Floating => - return (Deref_Float (A).Get_Float_Val = Deref_Float (B).Get_Float_Val); - when Bool => - return (Deref_Bool (A).Get_Bool = Deref_Bool (B).Get_Bool); - when List => - -- When Types.Vector was added, the choice was: - -- 1) use interfaces (because you need a class hierachy for the containers - -- and a corresponding hierarchy for the cursors and Ada is single dispatch - -- + interfaces. - -- 2) map out the combinations here and use nth to access vector items. - case Deref_List (A).Get_List_Type is - when List_List => - case Deref_List (B).Get_List_Type is - when List_List => - return Nodes_Equal (Deref_List (A).The_List, Deref_List (B).The_List); - when Vector_List => - return Compare_List_And_Vector - (Deref_List (A).all, Deref_List_Class (B).all); - when Hashed_List => return False; -- Comparing a list and a hash - end case; - when Vector_List => - case Deref_List (B).Get_List_Type is - when List_List => - return Compare_List_And_Vector - (Deref_List (B).all, Deref_List_Class (A).all); - when Vector_List => - return Vector."=" (Deref_Vector (A).all, Deref_Vector (B).all); - when Hashed_List => return False; -- Comparing a vector and a hash - end case; - when Hashed_List => - case Deref_List (B).Get_List_Type is - when List_List => return False; -- Comparing a list and a hash - when Vector_List => return False; -- Comparing a vector and a hash - when Hashed_List => - return Hash_Map."=" (Deref_Hash (A).all, Deref_Hash (B).all); - end case; - end case; - when Str => - return (Deref_String (A).Get_String = Deref_String (B).Get_String); - when Sym => - return (Deref_Sym (A).Get_Sym = Deref_Sym (B).Get_Sym); - when Atom => - return (Deref_Atom (A).Get_Atom = Deref_Atom (B).Get_Atom); - when Func => - return (Deref_Func (A).Get_Func_Name = Deref_Func (B).Get_Func_Name); - when Node => - return (Deref_Int(A).Get_Int_Val = Deref_Int(B).Get_Int_Val); - when Lambda => - return (Deref_Int(A).Get_Int_Val = Deref_Int(B).Get_Int_Val); - when Error => - return (Deref_Int(A).Get_Int_Val = Deref_Int(B).Get_Int_Val); - end case; - elsif Is_Null (A) and Is_Null (B) then - return True; - else -- either one of the args is null or the sym_types don't match - return False; - end if; - end "="; - - function Get_Meta (T : Mal_Type) return Mal_Handle is - begin - if T.Meta = Smart_Pointers.Null_Smart_Pointer then - return New_Nil_Mal_Type; - else - return T.Meta; - end if; - end Get_Meta; - - procedure Set_Meta (T : in out Mal_Type'Class; SP : Mal_Handle) is - begin - T.Meta := SP; - end Set_Meta; - - function Copy (M : Mal_Handle) return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Mal_Type'Class'(Deref (M).all)); - end Copy; - - function To_String (T : Mal_Type'Class; Print_Readably : Boolean := True) - return Mal_String is - begin - return To_Str (T, Print_Readably); - end To_String; - - function Is_Macro_Call (T : Mal_Type'Class; Env : Envs.Env_Handle) return Boolean is - L : List_Mal_Type; - First_Elem, Func : Mal_Handle; - begin - - if T.Sym_Type /= List then - return False; - end if; - - L := List_Mal_Type (T); - - if Is_Null (L) then - return False; - end if; - - First_Elem := Car (L); - - if Deref (First_Elem).Sym_Type /= Sym then - return False; - end if; - - Func := Envs.Get (Env, Deref_Sym (First_Elem).Get_Sym); - - if Deref (Func).Sym_Type /= Lambda then - return False; - end if; - - return Deref_Lambda (Func).Get_Is_Macro; - - exception - when Envs.Not_Found => return False; - end Is_Macro_Call; - - - -- A helper function that just view converts the smart pointer. - function Deref (S : Mal_Handle) return Mal_Ptr is - begin - return Mal_Ptr (Smart_Pointers.Deref (S)); - end Deref; - - -- A helper function to detect null smart pointers. - function Is_Null (S : Mal_Handle) return Boolean is - use Smart_Pointers; - begin - return Smart_Pointers."="(S, Null_Smart_Pointer); - end Is_Null; - - - -- To_Str on the abstract type... - function To_Str (T : Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - raise Constraint_Error; -- Tha'll teach 'ee - return ""; -- Keeps the compiler happy. - end To_Str; - - - function New_Nil_Mal_Type return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Nil_Mal_Type'(Mal_Type with null record)); - end New_Nil_Mal_Type; - - overriding function Sym_Type (T : Nil_Mal_Type) return Sym_Types is - begin - return Nil; - end Sym_Type; - - overriding function To_Str (T : Nil_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - return "nil"; - end To_Str; - - - function New_Int_Mal_Type (Int : Mal_Integer) return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Int_Mal_Type'(Mal_Type with Int_Val => Int)); - end New_Int_Mal_Type; - - overriding function Sym_Type (T : Int_Mal_Type) return Sym_Types is - begin - return Int; - end Sym_Type; - - function Get_Int_Val (T : Int_Mal_Type) return Mal_Integer is - begin - return T.Int_Val; - end Get_Int_Val; - - overriding function To_Str - (T : Int_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - Res : Mal_String := Mal_Integer'Image (T.Int_Val); - begin - return Ada.Strings.Fixed.Trim (Res, Ada.Strings.Left); - end To_Str; - - function Deref_Int (SP : Mal_Handle) return Int_Ptr is - begin - return Int_Ptr (Deref (SP)); - end Deref_Int; - - - function New_Float_Mal_Type (Floating : Mal_Float) return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Float_Mal_Type'(Mal_Type with Float_Val => Floating)); - end New_Float_Mal_Type; - - overriding function Sym_Type (T : Float_Mal_Type) return Sym_Types is - begin - return Floating; - end Sym_Type; - - function Get_Float_Val (T : Float_Mal_Type) return Mal_Float is - begin - return T.Float_Val; - end Get_Float_Val; - - overriding function To_Str - (T : Float_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - Res : Mal_String := Mal_Float'Image (T.Float_Val); - begin - return Ada.Strings.Fixed.Trim (Res, Ada.Strings.Left); - end To_Str; - - function Deref_Float (SP : Mal_Handle) return Float_Ptr is - begin - return Float_Ptr (Deref (SP)); - end Deref_Float; - - - function New_Bool_Mal_Type (Bool : Boolean) return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Bool_Mal_Type'(Mal_Type with Bool_Val => Bool)); - end New_Bool_Mal_Type; - - overriding function Sym_Type (T : Bool_Mal_Type) return Sym_Types is - begin - return Bool; - end Sym_Type; - - function Get_Bool (T : Bool_Mal_Type) return Boolean is - begin - return T.Bool_Val; - end Get_Bool; - - overriding function To_Str - (T : Bool_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - Res : Mal_String := Boolean'Image (T.Bool_Val); - begin - return Ada.Strings.Fixed.Translate - (Res, Ada.Strings.Maps.Constants.Lower_Case_Map); - end To_Str; - - function Deref_Bool (SP : Mal_Handle) return Bool_Ptr is - begin - return Bool_Ptr (Deref (SP)); - end Deref_Bool; - - - function New_String_Mal_Type (Str : Mal_String) return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new String_Mal_Type' (Mal_Type with The_String => - Ada.Strings.Unbounded.To_Unbounded_String (Str))); - end New_String_Mal_Type; - - overriding function Sym_Type (T : String_Mal_Type) return Sym_Types is - begin - return Str; - end Sym_Type; - - function Get_String (T : String_Mal_Type) return Mal_String is - begin - return Ada.Strings.Unbounded.To_String (T.The_String); - end Get_String; - - function Deref_String (SP : Mal_Handle) return String_Ptr is - begin - return String_Ptr (Deref (SP)); - end Deref_String; - - - overriding function To_Str - (T : String_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - use Ada.Strings.Unbounded; - I : Positive := 1; - Str_Len : Natural; - Res : Unbounded_String; - Ch : Character; - begin - if Print_Readably then - Append (Res, '"'); - Str_Len := Length (T.The_String); - while I <= Str_Len loop - Ch := Element (T.The_String, I); - if Ch = '"' then - Append (Res, "\"""); - elsif Ch = '\' then - Append (Res, "\\"); - elsif Ch = Ada.Characters.Latin_1.LF then - Append (Res, "\n"); - else - Append (Res, Ch); - end if; - I := I + 1; - end loop; - Append (Res, '"'); - return To_String (Res); - else - return To_String (T.The_String); - end if; - end To_Str; - - - function New_Symbol_Mal_Type (Str : Mal_String) return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Symbol_Mal_Type'(Mal_Type with The_Symbol => - Ada.Strings.Unbounded.To_Unbounded_String (Str))); - end New_Symbol_Mal_Type; - - overriding function Sym_Type (T : Symbol_Mal_Type) return Sym_Types is - begin - return Sym; - end Sym_Type; - - function Get_Sym (T : Symbol_Mal_Type) return Mal_String is - begin - return Ada.Strings.Unbounded.To_String (T.The_Symbol); - end Get_Sym; - - function Deref_Sym (S : Mal_Handle) return Sym_Ptr is - begin - return Sym_Ptr (Deref (S)); - end Deref_Sym; - - overriding function To_Str - (T : Symbol_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - return Ada.Strings.Unbounded.To_String (T.The_Symbol); - end To_Str; - - - function New_Atom_Mal_Type (MH : Mal_Handle) return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Atom_Mal_Type'(Mal_Type with The_Atom => MH)); - end New_Atom_Mal_Type; - - overriding function Sym_Type (T : Atom_Mal_Type) return Sym_Types is - begin - return Atom; - end Sym_Type; - - function Get_Atom (T : Atom_Mal_Type) return Mal_Handle is - begin - return T.The_Atom; - end Get_Atom; - - procedure Set_Atom (T : in out Atom_Mal_Type; New_Val : Mal_Handle) is - begin - T.The_Atom := New_Val; - end Set_Atom; - - function Deref_Atom (S : Mal_Handle) return Atom_Ptr is - begin - return Atom_Ptr (Deref (S)); - end Deref_Atom; - - overriding function To_Str - (T : Atom_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - return "(atom " & To_String (Deref (T.The_Atom).all) & ')'; - end To_Str; - - - function New_Func_Mal_Type (Str : Mal_String; F : Builtin_Func) - return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Func_Mal_Type'(Mal_Type with - Func_Name => Ada.Strings.Unbounded.To_Unbounded_String (Str), - Func_P => F)); - end New_Func_Mal_Type; - - overriding function Sym_Type (T : Func_Mal_Type) return Sym_Types is - begin - return Func; - end Sym_Type; - - function Get_Func_Name (T : Func_Mal_Type) return Mal_String is - begin - return Ada.Strings.Unbounded.To_String (T.Func_Name); - end Get_Func_Name; - - function Call_Func - (FMT : Func_Mal_Type; Rest_List : Mal_Handle) - return Mal_Handle is - begin - return FMT.Func_P (Rest_List); - end Call_Func; - - function Deref_Func (S : Mal_Handle) return Func_Ptr is - begin - return Func_Ptr (Deref (S)); - end Deref_Func; - - overriding function To_Str - (T : Func_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - return Ada.Strings.Unbounded.To_String (T.Func_Name); - end To_Str; - - - function New_Error_Mal_Type (Str : Mal_String) return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Error_Mal_Type'(Mal_Type with Error_Msg => - Ada.Strings.Unbounded.To_Unbounded_String (Str))); - end New_Error_Mal_Type; - - overriding function Sym_Type (T : Error_Mal_Type) return Sym_Types is - begin - return Error; - end Sym_Type; - - overriding function To_Str - (T : Error_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - return Ada.Strings.Unbounded.To_String (T.Error_Msg); - end To_Str; - - - function Nodes_Equal (A, B : Mal_Handle) return Boolean is - begin - if (not Is_Null (A) and not Is_Null (B)) and then - Deref (A).Sym_Type = Deref (B).Sym_Type then - if Deref (A).Sym_Type = Node then - return - Nodes_Equal (Deref_Node (A).Data, Deref_Node (B).Data) and then - Nodes_Equal (Deref_Node (A).Next, Deref_Node (B).Next); - else - return A = B; - end if; - elsif Is_Null (A) and Is_Null (B) then - return True; - else -- either one of the args is null or the sym_types don't match - return False; - end if; - end Nodes_Equal; - - - function New_Node_Mal_Type - (Data : Mal_Handle; - Next : Mal_Handle := Smart_Pointers.Null_Smart_Pointer) - return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Node_Mal_Type' - (Mal_Type with Data => Data, Next => Next)); - end New_Node_Mal_Type; - - - overriding function Sym_Type (T : Node_Mal_Type) return Sym_Types is - begin - return Node; - end Sym_Type; - - - -- Get the first item in the list: - function Car (L : List_Mal_Type) return Mal_Handle is - begin - if Is_Null (L.The_List) then - return Smart_Pointers.Null_Smart_Pointer; - else - return Deref_Node (L.The_List).Data; - end if; - end Car; - - - -- Get the rest of the list (second item onwards) - function Cdr (L : List_Mal_Type) return Mal_Handle is - Res : Mal_Handle; - LP : List_Ptr; - begin - - Res := New_List_Mal_Type (L.List_Type); - - if Is_Null (L.The_List) or else - Is_Null (Deref_Node (L.The_List).Next) then - return Res; - else - LP := Deref_List (Res); - LP.The_List := Deref_Node (L.The_List).Next; - LP.Last_Elem := L.Last_Elem; - return Res; - end if; - end Cdr; - - - function Length (L : List_Mal_Type) return Natural is - Res : Natural; - NP : Node_Ptr; - begin - Res := 0; - NP := Deref_Node (L.The_List); - while NP /= null loop - Res := Res + 1; - NP := Deref_Node (NP.Next); - end loop; - return Res; - end Length; - - - function Is_Null (L : List_Mal_Type) return Boolean is - use Smart_Pointers; - begin - return Smart_Pointers."="(L.The_List, Null_Smart_Pointer); - end Is_Null; - - - function Null_List (L : List_Types) return List_Mal_Type is - begin - return (Mal_Type with List_Type => L, - The_List => Smart_Pointers.Null_Smart_Pointer, - Last_Elem => Smart_Pointers.Null_Smart_Pointer); - end Null_List; - - - function Map - (Func_Ptr : Func_Access; - L : List_Mal_Type) - return Mal_Handle is - - Res, Old_List, First_New_Node, New_List : Mal_Handle; - LP : List_Ptr; - - begin - - Res := New_List_Mal_Type (List_Type => L.Get_List_Type); - - Old_List := L.The_List; - - if Is_Null (Old_List) then - return Res; - end if; - - First_New_Node := New_Node_Mal_Type (Func_Ptr.all (Deref_Node (Old_List).Data)); - - New_List := First_New_Node; - - Old_List := Deref_Node (Old_List).Next; - - while not Is_Null (Old_List) loop - - Deref_Node (New_List).Next := - New_Node_Mal_Type (Func_Ptr.all (Deref_Node (Old_List).Data)); - - New_List := Deref_Node (New_List).Next; - - Old_List := Deref_Node (Old_List).Next; - - end loop; - - LP := Deref_List (Res); - LP.The_List := First_New_Node; - LP.Last_Elem := New_List; - - return Res; - - end Map; - - - function Reduce - (Func_Ptr : Binary_Func_Access; - L : List_Mal_Type) - return Mal_Handle is - - C_Node : Node_Ptr; - Res : Mal_Handle; - use Smart_Pointers; - - begin - - C_Node := Deref_Node (L.The_List); - - if C_Node = null then - return Smart_Pointers.Null_Smart_Pointer; - end if; - - Res := C_Node.Data; - while not Is_Null (C_Node.Next) loop - C_Node := Deref_Node (C_Node.Next); - Res := Func_Ptr (Res, C_Node.Data); - end loop; - - return Res; - - end Reduce; - - - overriding function To_Str - (T : Node_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - if Is_Null (T.Data) then - -- Left is null and by implication so is right. - return ""; - elsif Is_Null (T.Next) then - -- Left is not null but right is. - return To_Str (Deref (T.Data).all, Print_Readably); - else - -- Left and right are both not null. - return To_Str (Deref (T.Data).all, Print_Readably) & - " " & - To_Str (Deref (T.Next).all, Print_Readably); - end if; - end To_Str; - - - function Cat_Str (T : Node_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - if Is_Null (T.Data) then - -- Left is null and by implication so is right. - return ""; - elsif Is_Null (T.Next) then - -- Left is not null but right is. - return To_Str (Deref (T.Data).all, Print_Readably); - - -- Left and right are both not null. - else - return To_Str (Deref (T.Data).all, Print_Readably) & - Cat_Str (Deref_Node (T.Next).all, Print_Readably); - end if; - end Cat_Str; - - - function Deref_Node (SP : Mal_Handle) return Node_Ptr is - begin - return Node_Ptr (Deref (SP)); - end Deref_Node; - - - function "=" (A, B : List_Mal_Type) return Boolean is - begin - return Nodes_Equal (A.The_List, B.The_List); - end "="; - - function New_List_Mal_Type - (The_List : List_Mal_Type) - return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new List_Mal_Type'(Mal_Type with - List_Type => The_List.List_Type, - The_List => The_List.The_List, - Last_Elem => The_List.Last_Elem)); - end New_List_Mal_Type; - - - function New_List_Mal_Type - (List_Type : List_Types; - The_First_Node : Mal_Handle := Smart_Pointers.Null_Smart_Pointer) - return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new List_Mal_Type' - (Mal_Type with - List_Type => List_Type, - The_List => The_First_Node, - Last_Elem => The_First_Node)); - end New_List_Mal_Type; - - - function Make_New_List (Handle_List : Handle_Lists) return Mal_Handle is - - List_SP : Mal_Handle; - List_P : List_Ptr; - - begin - List_SP := New_List_Mal_Type (List_Type => List_List); - List_P := Deref_List (List_SP); - for I in Handle_List'Range loop - Append (List_P.all, Handle_List (I)); - end loop; - return List_SP; - end Make_New_List; - - - overriding function Sym_Type (T : List_Mal_Type) return Sym_Types is - begin - return List; - end Sym_Type; - - - function Get_List_Type (L : List_Mal_Type) return List_Types is - begin - return L.List_Type; - end Get_List_Type; - - - function Prepend (Op : Mal_Handle; To_List : List_Mal_Type) - return Mal_Handle is - begin - return New_List_Mal_Type - (List_List, - New_Node_Mal_Type (Op, To_List.The_List)); - end Prepend; - - - procedure Append (To_List : in out List_Mal_Type; Op : Mal_Handle) is - begin - if Is_Null (Op) then - return; -- Say what - end if; - - -- If the list is null just insert the new element - -- else use the last_elem pointer to insert it and then update it. - if Is_Null (To_List.The_List) then - To_List.The_List := New_Node_Mal_Type (Op); - To_List.Last_Elem := To_List.The_List; - else - Deref_Node (To_List.Last_Elem).Next := New_Node_Mal_Type (Op); - To_List.Last_Elem := Deref_Node (To_List.Last_Elem).Next; - end if; - end Append; - - - -- Duplicate copies the list (logically). This is to allow concatenation, - -- The result is always a List_List. - function Duplicate (The_List : List_Mal_Type) return Mal_Handle is - Res, Old_List, First_New_Node, New_List : Mal_Handle; - LP : List_Ptr; - begin - - Res := New_List_Mal_Type (List_List); - - Old_List := The_List.The_List; - - if Is_Null (Old_List) then - return Res; - end if; - - First_New_Node := New_Node_Mal_Type (Deref_Node (Old_List).Data); - New_List := First_New_Node; - Old_List := Deref_Node (Old_List).Next; - - while not Is_Null (Old_List) loop - - Deref_Node (New_List).Next := New_Node_Mal_Type (Deref_Node (Old_List).Data); - New_List := Deref_Node (New_List).Next; - Old_List := Deref_Node (Old_List).Next; - - end loop; - - LP := Deref_List (Res); - LP.The_List := First_New_Node; - LP.Last_Elem := New_List; - - return Res; - - end Duplicate; - - - function Nth (L : List_Mal_Type; N : Natural) return Mal_Handle is - - C : Natural; - Next : Mal_Handle; - - begin - - C := 0; - - Next := L.The_List; - - while not Is_Null (Next) loop - - if C >= N then - return Deref_Node (Next).Data; - end if; - - C := C + 1; - - Next := Deref_Node (Next).Next; - - end loop; - - raise Runtime_Exception with "Nth (list): Index out of range"; - - end Nth; - - - function Concat (Rest_Handle : List_Mal_Type) - return Types.Mal_Handle is - Rest_List : Types.List_Mal_Type; - List : Types.List_Class_Ptr; - Res_List_Handle, Dup_List : Mal_Handle; - Last_Node_P : Mal_Handle := Smart_Pointers.Null_Smart_Pointer; - begin - Rest_List := Rest_Handle; - - -- Set the result to the null list. - Res_List_Handle := New_List_Mal_Type (List_List); - - while not Is_Null (Rest_List) loop - - -- Find the next list in the list... - List := Deref_List_Class (Car (Rest_List)); - - -- Duplicate nodes to its contents. - Dup_List := Duplicate (List.all); - - -- If we haven't inserted a list yet, then take the duplicated list whole. - if Is_Null (Last_Node_P) then - Res_List_Handle := Dup_List; - else - -- Note that the first inserted list may have been the null list - -- and so may the newly duplicated one... - Deref_Node (Last_Node_P).Next := Deref_List (Dup_List).The_List; - if Is_Null (Deref_List (Res_List_Handle).The_List) then - Deref_List (Res_list_Handle).The_List := - Deref_List (Dup_List).The_List; - end if; - if not Is_Null (Deref_List (Dup_List).Last_Elem) then - Deref_List (Res_List_Handle).Last_Elem := - Deref_List (Dup_List).Last_Elem; - end if; - end if; - - Last_Node_P := Deref_List (Dup_List).Last_Elem; - - Rest_List := Deref_List (Cdr (Rest_List)).all; - - end loop; - - return Res_List_Handle; - - end Concat; - - - procedure Add_Defs (Defs : List_Mal_Type; Env : Envs.Env_Handle) is - D, L : List_Mal_Type; - begin - D := Defs; - while not Is_Null (D) loop - L := Deref_List (Cdr (D)).all; - Envs.Set - (Env, - Deref_Sym (Car (D)).Get_Sym, - Eval_Callback.Eval.all (Car (L), Env)); - D := Deref_List (Cdr(L)).all; - end loop; - end Add_Defs; - - - function Deref_List (SP : Mal_Handle) return List_Ptr is - begin - return List_Ptr (Deref (SP)); - end Deref_List; - - - function Deref_List_Class (SP : Mal_Handle) return List_Class_Ptr is - begin - return List_Class_Ptr (Deref (SP)); - end Deref_List_Class; - - - overriding function To_Str - (T : List_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - if Is_Null (T.The_List) then - return Opening (T.List_Type) & - Closing (T.List_Type); - else - return Opening (T.List_Type) & - To_String (Deref (T.The_List).all, Print_Readably) & - Closing (T.List_Type); - end if; - end To_Str; - - - function Pr_Str (T : List_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - if Is_Null (T.The_List) then - return ""; - else - return To_String (Deref_Node (T.The_List).all, Print_Readably); - end if; - end Pr_Str; - - - function Cat_Str (T : List_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin - if Is_Null (T.The_List) then - return ""; - else - return Cat_Str (Deref_Node (T.The_List).all, Print_Readably); - end if; - end Cat_Str; - - - function Opening (LT : List_Types) return Character is - Res : Character; - begin - case LT is - when List_List => - Res := '('; - when Vector_List => - Res := '['; - when Hashed_List => - Res := '{'; - end case; - return Res; - end Opening; - - - function Closing (LT : List_Types) return Character is - Res : Character; - begin - case LT is - when List_List => - Res := ')'; - when Vector_List => - Res := ']'; - when Hashed_List => - Res := '}'; - end case; - return Res; - end Closing; - - - function New_Lambda_Mal_Type - (Params : Mal_Handle; Expr : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is - begin - return Smart_Pointers.New_Ptr - (new Lambda_Mal_Type' - (Mal_Type with - Params => Params, - Expr => Expr, - Env => Env, - Is_Macro => False)); - end New_Lambda_Mal_Type; - - overriding function Sym_Type (T : Lambda_Mal_Type) return Sym_Types is - begin - return Lambda; - end Sym_Type; - - function Get_Env (L : Lambda_Mal_Type) return Envs.Env_Handle is - begin - return L.Env; - end Get_Env; - - procedure Set_Env (L : in out Lambda_Mal_Type; Env : Envs.Env_Handle) is - begin - L.Env := Env; - end Set_Env; - - function Get_Params (L : Lambda_Mal_Type) return Mal_Handle is - begin - if Deref (L.Params).Sym_Type = List and then - Deref_List (L.Params).Get_List_Type = Vector_List then - -- Its a vector and we need a list... - return Deref_List_Class (L.Params).Duplicate; - else - return L.Params; - end if; - end Get_Params; - - function Get_Expr (L : Lambda_Mal_Type) return Mal_Handle is - begin - return L.Expr; - end Get_Expr; - - function Get_Is_Macro (L : Lambda_Mal_Type) return Boolean is - begin - return L.Is_Macro; - end Get_Is_Macro; - - procedure Set_Is_Macro (L : in out Lambda_Mal_Type; B : Boolean) is - begin - L.Is_Macro := B; - end Set_Is_Macro; - - - function Apply - (L : Lambda_Mal_Type; - Param_List : Mal_Handle) - return Mal_Handle is - - E : Envs.Env_Handle; - Param_Names : List_Mal_Type; - Res : Mal_Handle; - - begin - - E := Envs.New_Env (L.Env); - - Param_Names := Deref_List (L.Get_Params).all; - - if Envs.Bind (E, Param_Names, Deref_List (Param_List).all) then - - Res := Eval_Callback.Eval.all (L.Get_Expr, E); - - else - - raise Runtime_Exception with "Bind failed in Apply"; - - end if; - - return Res; - - end Apply; - - - function Get_Macro (T : Mal_Handle; Env : Envs.Env_Handle) return Lambda_Ptr is - L : List_Mal_Type; - First_Elem, Func : Mal_Handle; - begin - - if Deref (T).Sym_Type /= List then - return null; - end if; - - L := Deref_List (T).all; - - if Is_Null (L) then - return null; - end if; - - First_Elem := Car (L); - - if Deref (First_Elem).Sym_Type /= Sym then - return null; - end if; - - Func := Envs.Get (Env, Deref_Sym (First_Elem).Get_Sym); - - if Deref (Func).Sym_Type /= Lambda then - return null; - end if; - - return Deref_Lambda (Func); - - exception - when Envs.Not_Found => return null; - end Get_Macro; - - - overriding function To_Str - (T : Lambda_Mal_Type; Print_Readably : Boolean := True) - return Mal_String is - begin --- return "(lambda " & Ada.Strings.Unbounded.To_String (T.Rep) & ")"; - return "#"; - end To_Str; - - function Deref_Lambda (SP : Mal_Handle) return Lambda_Ptr is - begin - return Lambda_Ptr (Deref (SP)); - end Deref_Lambda; - - - function Arith_Op (A, B : Mal_Handle) return Mal_Handle is - use Types; - A_Sym_Type : Sym_Types; - B_Sym_Type : Sym_Types; - begin - - if Is_Null (A) then - if Is_Null (B) then - -- both null, gotta be zero. - return New_Int_Mal_Type (0); - else -- A is null but B is not. - return Arith_Op (New_Int_Mal_Type (0), B); - end if; - elsif Is_Null (B) then - -- A is not null but B is. - return Arith_Op (A, New_Int_Mal_Type (0)); - end if; - - -- else both A and B and not null.:wq - A_Sym_Type := Deref (A).Sym_Type; - B_Sym_Type := Deref (B).Sym_Type; - if A_Sym_Type = Int and B_Sym_Type = Int then - return New_Int_Mal_Type - (Int_Op (Deref_Int (A).Get_Int_Val, Deref_Int (B).Get_Int_Val)); - elsif A_Sym_Type = Int and B_Sym_Type = Floating then - return New_Float_Mal_Type - (Float_Op (Mal_Float (Deref_Int (A).Get_Int_Val), - Deref_Float (B).Get_Float_Val)); - elsif A_Sym_Type = Floating and B_Sym_Type = Int then - return New_Float_Mal_Type - (Float_Op (Deref_Float (A).Get_Float_Val, - Mal_Float (Deref_Float (B).Get_Float_Val))); - elsif A_Sym_Type = Floating and B_Sym_Type = Floating then - return New_Float_Mal_Type - (Float_Op (Deref_Float (A).Get_Float_Val, - Deref_Float (B).Get_Float_Val)); - else - if A_Sym_Type = Error then - return A; - elsif B_Sym_Type = Error then - return B; - else - return New_Error_Mal_Type ("Invalid operands"); - end if; - end if; - end Arith_Op; - - - function Rel_Op (A, B : Mal_Handle) return Mal_Handle is - use Types; - A_Sym_Type : Sym_Types := Deref (A).Sym_Type; - B_Sym_Type : Sym_Types := Deref (B).Sym_Type; - begin - if A_Sym_Type = Int and B_Sym_Type = Int then - return New_Bool_Mal_Type - (Int_Rel_Op (Deref_Int (A).Get_Int_Val, Deref_Int (B).Get_Int_Val)); - elsif A_Sym_Type = Int and B_Sym_Type = Floating then - return New_Bool_Mal_Type - (Float_Rel_Op (Mal_Float (Deref_Int (A).Get_Int_Val), - Deref_Float (B).Get_Float_Val)); - elsif A_Sym_Type = Floating and B_Sym_Type = Int then - return New_Bool_Mal_Type - (Float_Rel_Op (Deref_Float (A).Get_Float_Val, - Mal_Float (Deref_Float (B).Get_Float_Val))); - else - return New_Bool_Mal_Type - (Float_Rel_Op (Deref_Float (A).Get_Float_Val, - Deref_Float (B).Get_Float_Val)); - end if; - end Rel_Op; - - -end Types; +with Ada.Characters.Latin_1; +with Ada.Strings.Fixed; +with Ada.Strings.Maps.Constants; +with Ada.Text_IO; +with Ada.Unchecked_Deallocation; +with Envs; +with Eval_Callback; +with Smart_Pointers; +with Types.Vector; +with Types.Hash_Map; + +package body Types is + + package ACL renames Ada.Characters.Latin_1; + + function Nodes_Equal (A, B : Mal_Handle) return Boolean; + + + function "=" (A, B : Mal_Handle) return Mal_Handle is + begin + return New_Bool_Mal_Type (A = B); + end "="; + + + function Compare_List_And_Vector (A : List_Mal_Type; B : List_Mal_Type'Class) + return Boolean is + First_Node, First_Index : Mal_Handle; + I : Natural := 0; + begin + First_Node := A.The_List; + loop + if not Is_Null (First_Node) and I < B.Length then + First_Index := B.Nth (I); + if not "=" (Deref_Node (First_Node).Data, First_Index) then + return False; + end if; + First_Node := Deref_Node (First_Node).Next; + I := I + 1; + else + return Is_Null (First_Node) and I = B.Length; + end if; + end loop; + end Compare_List_And_Vector; + + + function "=" (A, B : Mal_Handle) return Boolean is + use Types.Vector; + use Types.Hash_Map; + begin + + if (not Is_Null (A) and not Is_Null (B)) and then + Deref (A).Sym_Type = Deref (B).Sym_Type then + + case Deref (A).Sym_Type is + when Nil => + return True; -- Both nil. + when Int => + return (Deref_Int (A).Get_Int_Val = Deref_Int (B).Get_Int_Val); + when Floating => + return (Deref_Float (A).Get_Float_Val = Deref_Float (B).Get_Float_Val); + when Bool => + return (Deref_Bool (A).Get_Bool = Deref_Bool (B).Get_Bool); + when List => + -- When Types.Vector was added, the choice was: + -- 1) use interfaces (because you need a class hierachy for the containers + -- and a corresponding hierarchy for the cursors and Ada is single dispatch + -- + interfaces. + -- 2) map out the combinations here and use nth to access vector items. + case Deref_List (A).Get_List_Type is + when List_List => + case Deref_List (B).Get_List_Type is + when List_List => + return Nodes_Equal (Deref_List (A).The_List, Deref_List (B).The_List); + when Vector_List => + return Compare_List_And_Vector + (Deref_List (A).all, Deref_List_Class (B).all); + when Hashed_List => return False; -- Comparing a list and a hash + end case; + when Vector_List => + case Deref_List (B).Get_List_Type is + when List_List => + return Compare_List_And_Vector + (Deref_List (B).all, Deref_List_Class (A).all); + when Vector_List => + return Vector."=" (Deref_Vector (A).all, Deref_Vector (B).all); + when Hashed_List => return False; -- Comparing a vector and a hash + end case; + when Hashed_List => + case Deref_List (B).Get_List_Type is + when List_List => return False; -- Comparing a list and a hash + when Vector_List => return False; -- Comparing a vector and a hash + when Hashed_List => + return Hash_Map."=" (Deref_Hash (A).all, Deref_Hash (B).all); + end case; + end case; + when Str => + return (Deref_String (A).Get_String = Deref_String (B).Get_String); + when Sym => + return (Deref_Sym (A).Get_Sym = Deref_Sym (B).Get_Sym); + when Atom => + return (Deref_Atom (A).Get_Atom = Deref_Atom (B).Get_Atom); + when Func => + return (Deref_Func (A).Get_Func_Name = Deref_Func (B).Get_Func_Name); + when Node => + return (Deref_Int(A).Get_Int_Val = Deref_Int(B).Get_Int_Val); + when Lambda => + return (Deref_Int(A).Get_Int_Val = Deref_Int(B).Get_Int_Val); + when Error => + return (Deref_Int(A).Get_Int_Val = Deref_Int(B).Get_Int_Val); + end case; + elsif Is_Null (A) and Is_Null (B) then + return True; + else -- either one of the args is null or the sym_types don't match + return False; + end if; + end "="; + + function Get_Meta (T : Mal_Type) return Mal_Handle is + begin + if T.Meta = Smart_Pointers.Null_Smart_Pointer then + return New_Nil_Mal_Type; + else + return T.Meta; + end if; + end Get_Meta; + + procedure Set_Meta (T : in out Mal_Type'Class; SP : Mal_Handle) is + begin + T.Meta := SP; + end Set_Meta; + + function Copy (M : Mal_Handle) return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Mal_Type'Class'(Deref (M).all)); + end Copy; + + function To_String (T : Mal_Type'Class; Print_Readably : Boolean := True) + return Mal_String is + begin + return To_Str (T, Print_Readably); + end To_String; + + function Is_Macro_Call (T : Mal_Type'Class; Env : Envs.Env_Handle) return Boolean is + L : List_Mal_Type; + First_Elem, Func : Mal_Handle; + begin + + if T.Sym_Type /= List then + return False; + end if; + + L := List_Mal_Type (T); + + if Is_Null (L) then + return False; + end if; + + First_Elem := Car (L); + + if Deref (First_Elem).Sym_Type /= Sym then + return False; + end if; + + Func := Envs.Get (Env, Deref_Sym (First_Elem).Get_Sym); + + if Deref (Func).Sym_Type /= Lambda then + return False; + end if; + + return Deref_Lambda (Func).Get_Is_Macro; + + exception + when Envs.Not_Found => return False; + end Is_Macro_Call; + + + -- A helper function that just view converts the smart pointer. + function Deref (S : Mal_Handle) return Mal_Ptr is + begin + return Mal_Ptr (Smart_Pointers.Deref (S)); + end Deref; + + -- A helper function to detect null smart pointers. + function Is_Null (S : Mal_Handle) return Boolean is + use Smart_Pointers; + begin + return Smart_Pointers."="(S, Null_Smart_Pointer); + end Is_Null; + + + -- To_Str on the abstract type... + function To_Str (T : Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + raise Constraint_Error; -- Tha'll teach 'ee + return ""; -- Keeps the compiler happy. + end To_Str; + + + function New_Nil_Mal_Type return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Nil_Mal_Type'(Mal_Type with null record)); + end New_Nil_Mal_Type; + + overriding function Sym_Type (T : Nil_Mal_Type) return Sym_Types is + begin + return Nil; + end Sym_Type; + + overriding function To_Str (T : Nil_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + return "nil"; + end To_Str; + + + function New_Int_Mal_Type (Int : Mal_Integer) return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Int_Mal_Type'(Mal_Type with Int_Val => Int)); + end New_Int_Mal_Type; + + overriding function Sym_Type (T : Int_Mal_Type) return Sym_Types is + begin + return Int; + end Sym_Type; + + function Get_Int_Val (T : Int_Mal_Type) return Mal_Integer is + begin + return T.Int_Val; + end Get_Int_Val; + + overriding function To_Str + (T : Int_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + Res : Mal_String := Mal_Integer'Image (T.Int_Val); + begin + return Ada.Strings.Fixed.Trim (Res, Ada.Strings.Left); + end To_Str; + + function Deref_Int (SP : Mal_Handle) return Int_Ptr is + begin + return Int_Ptr (Deref (SP)); + end Deref_Int; + + + function New_Float_Mal_Type (Floating : Mal_Float) return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Float_Mal_Type'(Mal_Type with Float_Val => Floating)); + end New_Float_Mal_Type; + + overriding function Sym_Type (T : Float_Mal_Type) return Sym_Types is + begin + return Floating; + end Sym_Type; + + function Get_Float_Val (T : Float_Mal_Type) return Mal_Float is + begin + return T.Float_Val; + end Get_Float_Val; + + overriding function To_Str + (T : Float_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + Res : Mal_String := Mal_Float'Image (T.Float_Val); + begin + return Ada.Strings.Fixed.Trim (Res, Ada.Strings.Left); + end To_Str; + + function Deref_Float (SP : Mal_Handle) return Float_Ptr is + begin + return Float_Ptr (Deref (SP)); + end Deref_Float; + + + function New_Bool_Mal_Type (Bool : Boolean) return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Bool_Mal_Type'(Mal_Type with Bool_Val => Bool)); + end New_Bool_Mal_Type; + + overriding function Sym_Type (T : Bool_Mal_Type) return Sym_Types is + begin + return Bool; + end Sym_Type; + + function Get_Bool (T : Bool_Mal_Type) return Boolean is + begin + return T.Bool_Val; + end Get_Bool; + + overriding function To_Str + (T : Bool_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + Res : Mal_String := Boolean'Image (T.Bool_Val); + begin + return Ada.Strings.Fixed.Translate + (Res, Ada.Strings.Maps.Constants.Lower_Case_Map); + end To_Str; + + function Deref_Bool (SP : Mal_Handle) return Bool_Ptr is + begin + return Bool_Ptr (Deref (SP)); + end Deref_Bool; + + + function New_String_Mal_Type (Str : Mal_String) return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new String_Mal_Type' (Mal_Type with The_String => + Ada.Strings.Unbounded.To_Unbounded_String (Str))); + end New_String_Mal_Type; + + overriding function Sym_Type (T : String_Mal_Type) return Sym_Types is + begin + return Str; + end Sym_Type; + + function Get_String (T : String_Mal_Type) return Mal_String is + begin + return Ada.Strings.Unbounded.To_String (T.The_String); + end Get_String; + + function Deref_String (SP : Mal_Handle) return String_Ptr is + begin + return String_Ptr (Deref (SP)); + end Deref_String; + + + overriding function To_Str + (T : String_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + use Ada.Strings.Unbounded; + I : Positive := 1; + Str_Len : Natural; + Res : Unbounded_String; + Ch : Character; + begin + if Print_Readably then + Append (Res, '"'); + Str_Len := Length (T.The_String); + while I <= Str_Len loop + Ch := Element (T.The_String, I); + if Ch = '"' then + Append (Res, "\"""); + elsif Ch = '\' then + Append (Res, "\\"); + elsif Ch = Ada.Characters.Latin_1.LF then + Append (Res, "\n"); + else + Append (Res, Ch); + end if; + I := I + 1; + end loop; + Append (Res, '"'); + return To_String (Res); + else + return To_String (T.The_String); + end if; + end To_Str; + + + function New_Symbol_Mal_Type (Str : Mal_String) return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Symbol_Mal_Type'(Mal_Type with The_Symbol => + Ada.Strings.Unbounded.To_Unbounded_String (Str))); + end New_Symbol_Mal_Type; + + overriding function Sym_Type (T : Symbol_Mal_Type) return Sym_Types is + begin + return Sym; + end Sym_Type; + + function Get_Sym (T : Symbol_Mal_Type) return Mal_String is + begin + return Ada.Strings.Unbounded.To_String (T.The_Symbol); + end Get_Sym; + + function Deref_Sym (S : Mal_Handle) return Sym_Ptr is + begin + return Sym_Ptr (Deref (S)); + end Deref_Sym; + + overriding function To_Str + (T : Symbol_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + return Ada.Strings.Unbounded.To_String (T.The_Symbol); + end To_Str; + + + function New_Atom_Mal_Type (MH : Mal_Handle) return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Atom_Mal_Type'(Mal_Type with The_Atom => MH)); + end New_Atom_Mal_Type; + + overriding function Sym_Type (T : Atom_Mal_Type) return Sym_Types is + begin + return Atom; + end Sym_Type; + + function Get_Atom (T : Atom_Mal_Type) return Mal_Handle is + begin + return T.The_Atom; + end Get_Atom; + + procedure Set_Atom (T : in out Atom_Mal_Type; New_Val : Mal_Handle) is + begin + T.The_Atom := New_Val; + end Set_Atom; + + function Deref_Atom (S : Mal_Handle) return Atom_Ptr is + begin + return Atom_Ptr (Deref (S)); + end Deref_Atom; + + overriding function To_Str + (T : Atom_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + return "(atom " & To_String (Deref (T.The_Atom).all) & ')'; + end To_Str; + + + function New_Func_Mal_Type (Str : Mal_String; F : Builtin_Func) + return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Func_Mal_Type'(Mal_Type with + Func_Name => Ada.Strings.Unbounded.To_Unbounded_String (Str), + Func_P => F)); + end New_Func_Mal_Type; + + overriding function Sym_Type (T : Func_Mal_Type) return Sym_Types is + begin + return Func; + end Sym_Type; + + function Get_Func_Name (T : Func_Mal_Type) return Mal_String is + begin + return Ada.Strings.Unbounded.To_String (T.Func_Name); + end Get_Func_Name; + + function Call_Func + (FMT : Func_Mal_Type; Rest_List : Mal_Handle) + return Mal_Handle is + begin + return FMT.Func_P (Rest_List); + end Call_Func; + + function Deref_Func (S : Mal_Handle) return Func_Ptr is + begin + return Func_Ptr (Deref (S)); + end Deref_Func; + + overriding function To_Str + (T : Func_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + return Ada.Strings.Unbounded.To_String (T.Func_Name); + end To_Str; + + + function New_Error_Mal_Type (Str : Mal_String) return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Error_Mal_Type'(Mal_Type with Error_Msg => + Ada.Strings.Unbounded.To_Unbounded_String (Str))); + end New_Error_Mal_Type; + + overriding function Sym_Type (T : Error_Mal_Type) return Sym_Types is + begin + return Error; + end Sym_Type; + + overriding function To_Str + (T : Error_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + return Ada.Strings.Unbounded.To_String (T.Error_Msg); + end To_Str; + + + function Nodes_Equal (A, B : Mal_Handle) return Boolean is + begin + if (not Is_Null (A) and not Is_Null (B)) and then + Deref (A).Sym_Type = Deref (B).Sym_Type then + if Deref (A).Sym_Type = Node then + return + Nodes_Equal (Deref_Node (A).Data, Deref_Node (B).Data) and then + Nodes_Equal (Deref_Node (A).Next, Deref_Node (B).Next); + else + return A = B; + end if; + elsif Is_Null (A) and Is_Null (B) then + return True; + else -- either one of the args is null or the sym_types don't match + return False; + end if; + end Nodes_Equal; + + + function New_Node_Mal_Type + (Data : Mal_Handle; + Next : Mal_Handle := Smart_Pointers.Null_Smart_Pointer) + return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Node_Mal_Type' + (Mal_Type with Data => Data, Next => Next)); + end New_Node_Mal_Type; + + + overriding function Sym_Type (T : Node_Mal_Type) return Sym_Types is + begin + return Node; + end Sym_Type; + + + -- Get the first item in the list: + function Car (L : List_Mal_Type) return Mal_Handle is + begin + if Is_Null (L.The_List) then + return Smart_Pointers.Null_Smart_Pointer; + else + return Deref_Node (L.The_List).Data; + end if; + end Car; + + + -- Get the rest of the list (second item onwards) + function Cdr (L : List_Mal_Type) return Mal_Handle is + Res : Mal_Handle; + LP : List_Ptr; + begin + + Res := New_List_Mal_Type (L.List_Type); + + if Is_Null (L.The_List) or else + Is_Null (Deref_Node (L.The_List).Next) then + return Res; + else + LP := Deref_List (Res); + LP.The_List := Deref_Node (L.The_List).Next; + LP.Last_Elem := L.Last_Elem; + return Res; + end if; + end Cdr; + + + function Length (L : List_Mal_Type) return Natural is + Res : Natural; + NP : Node_Ptr; + begin + Res := 0; + NP := Deref_Node (L.The_List); + while NP /= null loop + Res := Res + 1; + NP := Deref_Node (NP.Next); + end loop; + return Res; + end Length; + + + function Is_Null (L : List_Mal_Type) return Boolean is + use Smart_Pointers; + begin + return Smart_Pointers."="(L.The_List, Null_Smart_Pointer); + end Is_Null; + + + function Null_List (L : List_Types) return List_Mal_Type is + begin + return (Mal_Type with List_Type => L, + The_List => Smart_Pointers.Null_Smart_Pointer, + Last_Elem => Smart_Pointers.Null_Smart_Pointer); + end Null_List; + + + function Map + (Func_Ptr : Func_Access; + L : List_Mal_Type) + return Mal_Handle is + + Res, Old_List, First_New_Node, New_List : Mal_Handle; + LP : List_Ptr; + + begin + + Res := New_List_Mal_Type (List_Type => L.Get_List_Type); + + Old_List := L.The_List; + + if Is_Null (Old_List) then + return Res; + end if; + + First_New_Node := New_Node_Mal_Type (Func_Ptr.all (Deref_Node (Old_List).Data)); + + New_List := First_New_Node; + + Old_List := Deref_Node (Old_List).Next; + + while not Is_Null (Old_List) loop + + Deref_Node (New_List).Next := + New_Node_Mal_Type (Func_Ptr.all (Deref_Node (Old_List).Data)); + + New_List := Deref_Node (New_List).Next; + + Old_List := Deref_Node (Old_List).Next; + + end loop; + + LP := Deref_List (Res); + LP.The_List := First_New_Node; + LP.Last_Elem := New_List; + + return Res; + + end Map; + + + function Reduce + (Func_Ptr : Binary_Func_Access; + L : List_Mal_Type) + return Mal_Handle is + + C_Node : Node_Ptr; + Res : Mal_Handle; + use Smart_Pointers; + + begin + + C_Node := Deref_Node (L.The_List); + + if C_Node = null then + return Smart_Pointers.Null_Smart_Pointer; + end if; + + Res := C_Node.Data; + while not Is_Null (C_Node.Next) loop + C_Node := Deref_Node (C_Node.Next); + Res := Func_Ptr (Res, C_Node.Data); + end loop; + + return Res; + + end Reduce; + + + overriding function To_Str + (T : Node_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + if Is_Null (T.Data) then + -- Left is null and by implication so is right. + return ""; + elsif Is_Null (T.Next) then + -- Left is not null but right is. + return To_Str (Deref (T.Data).all, Print_Readably); + else + -- Left and right are both not null. + return To_Str (Deref (T.Data).all, Print_Readably) & + " " & + To_Str (Deref (T.Next).all, Print_Readably); + end if; + end To_Str; + + + function Cat_Str (T : Node_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + if Is_Null (T.Data) then + -- Left is null and by implication so is right. + return ""; + elsif Is_Null (T.Next) then + -- Left is not null but right is. + return To_Str (Deref (T.Data).all, Print_Readably); + + -- Left and right are both not null. + else + return To_Str (Deref (T.Data).all, Print_Readably) & + Cat_Str (Deref_Node (T.Next).all, Print_Readably); + end if; + end Cat_Str; + + + function Deref_Node (SP : Mal_Handle) return Node_Ptr is + begin + return Node_Ptr (Deref (SP)); + end Deref_Node; + + + function "=" (A, B : List_Mal_Type) return Boolean is + begin + return Nodes_Equal (A.The_List, B.The_List); + end "="; + + function New_List_Mal_Type + (The_List : List_Mal_Type) + return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new List_Mal_Type'(Mal_Type with + List_Type => The_List.List_Type, + The_List => The_List.The_List, + Last_Elem => The_List.Last_Elem)); + end New_List_Mal_Type; + + + function New_List_Mal_Type + (List_Type : List_Types; + The_First_Node : Mal_Handle := Smart_Pointers.Null_Smart_Pointer) + return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new List_Mal_Type' + (Mal_Type with + List_Type => List_Type, + The_List => The_First_Node, + Last_Elem => The_First_Node)); + end New_List_Mal_Type; + + + function Make_New_List (Handle_List : Handle_Lists) return Mal_Handle is + + List_SP : Mal_Handle; + List_P : List_Ptr; + + begin + List_SP := New_List_Mal_Type (List_Type => List_List); + List_P := Deref_List (List_SP); + for I in Handle_List'Range loop + Append (List_P.all, Handle_List (I)); + end loop; + return List_SP; + end Make_New_List; + + + overriding function Sym_Type (T : List_Mal_Type) return Sym_Types is + begin + return List; + end Sym_Type; + + + function Get_List_Type (L : List_Mal_Type) return List_Types is + begin + return L.List_Type; + end Get_List_Type; + + + function Prepend (Op : Mal_Handle; To_List : List_Mal_Type) + return Mal_Handle is + begin + return New_List_Mal_Type + (List_List, + New_Node_Mal_Type (Op, To_List.The_List)); + end Prepend; + + + procedure Append (To_List : in out List_Mal_Type; Op : Mal_Handle) is + begin + if Is_Null (Op) then + return; -- Say what + end if; + + -- If the list is null just insert the new element + -- else use the last_elem pointer to insert it and then update it. + if Is_Null (To_List.The_List) then + To_List.The_List := New_Node_Mal_Type (Op); + To_List.Last_Elem := To_List.The_List; + else + Deref_Node (To_List.Last_Elem).Next := New_Node_Mal_Type (Op); + To_List.Last_Elem := Deref_Node (To_List.Last_Elem).Next; + end if; + end Append; + + + -- Duplicate copies the list (logically). This is to allow concatenation, + -- The result is always a List_List. + function Duplicate (The_List : List_Mal_Type) return Mal_Handle is + Res, Old_List, First_New_Node, New_List : Mal_Handle; + LP : List_Ptr; + begin + + Res := New_List_Mal_Type (List_List); + + Old_List := The_List.The_List; + + if Is_Null (Old_List) then + return Res; + end if; + + First_New_Node := New_Node_Mal_Type (Deref_Node (Old_List).Data); + New_List := First_New_Node; + Old_List := Deref_Node (Old_List).Next; + + while not Is_Null (Old_List) loop + + Deref_Node (New_List).Next := New_Node_Mal_Type (Deref_Node (Old_List).Data); + New_List := Deref_Node (New_List).Next; + Old_List := Deref_Node (Old_List).Next; + + end loop; + + LP := Deref_List (Res); + LP.The_List := First_New_Node; + LP.Last_Elem := New_List; + + return Res; + + end Duplicate; + + + function Nth (L : List_Mal_Type; N : Natural) return Mal_Handle is + + C : Natural; + Next : Mal_Handle; + + begin + + C := 0; + + Next := L.The_List; + + while not Is_Null (Next) loop + + if C >= N then + return Deref_Node (Next).Data; + end if; + + C := C + 1; + + Next := Deref_Node (Next).Next; + + end loop; + + raise Runtime_Exception with "Nth (list): Index out of range"; + + end Nth; + + + function Concat (Rest_Handle : List_Mal_Type) + return Types.Mal_Handle is + Rest_List : Types.List_Mal_Type; + List : Types.List_Class_Ptr; + Res_List_Handle, Dup_List : Mal_Handle; + Last_Node_P : Mal_Handle := Smart_Pointers.Null_Smart_Pointer; + begin + Rest_List := Rest_Handle; + + -- Set the result to the null list. + Res_List_Handle := New_List_Mal_Type (List_List); + + while not Is_Null (Rest_List) loop + + -- Find the next list in the list... + List := Deref_List_Class (Car (Rest_List)); + + -- Duplicate nodes to its contents. + Dup_List := Duplicate (List.all); + + -- If we haven't inserted a list yet, then take the duplicated list whole. + if Is_Null (Last_Node_P) then + Res_List_Handle := Dup_List; + else + -- Note that the first inserted list may have been the null list + -- and so may the newly duplicated one... + Deref_Node (Last_Node_P).Next := Deref_List (Dup_List).The_List; + if Is_Null (Deref_List (Res_List_Handle).The_List) then + Deref_List (Res_list_Handle).The_List := + Deref_List (Dup_List).The_List; + end if; + if not Is_Null (Deref_List (Dup_List).Last_Elem) then + Deref_List (Res_List_Handle).Last_Elem := + Deref_List (Dup_List).Last_Elem; + end if; + end if; + + Last_Node_P := Deref_List (Dup_List).Last_Elem; + + Rest_List := Deref_List (Cdr (Rest_List)).all; + + end loop; + + return Res_List_Handle; + + end Concat; + + + procedure Add_Defs (Defs : List_Mal_Type; Env : Envs.Env_Handle) is + D, L : List_Mal_Type; + begin + D := Defs; + while not Is_Null (D) loop + L := Deref_List (Cdr (D)).all; + Envs.Set + (Env, + Deref_Sym (Car (D)).Get_Sym, + Eval_Callback.Eval.all (Car (L), Env)); + D := Deref_List (Cdr(L)).all; + end loop; + end Add_Defs; + + + function Deref_List (SP : Mal_Handle) return List_Ptr is + begin + return List_Ptr (Deref (SP)); + end Deref_List; + + + function Deref_List_Class (SP : Mal_Handle) return List_Class_Ptr is + begin + return List_Class_Ptr (Deref (SP)); + end Deref_List_Class; + + + overriding function To_Str + (T : List_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + if Is_Null (T.The_List) then + return Opening (T.List_Type) & + Closing (T.List_Type); + else + return Opening (T.List_Type) & + To_String (Deref (T.The_List).all, Print_Readably) & + Closing (T.List_Type); + end if; + end To_Str; + + + function Pr_Str (T : List_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + if Is_Null (T.The_List) then + return ""; + else + return To_String (Deref_Node (T.The_List).all, Print_Readably); + end if; + end Pr_Str; + + + function Cat_Str (T : List_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin + if Is_Null (T.The_List) then + return ""; + else + return Cat_Str (Deref_Node (T.The_List).all, Print_Readably); + end if; + end Cat_Str; + + + function Opening (LT : List_Types) return Character is + Res : Character; + begin + case LT is + when List_List => + Res := '('; + when Vector_List => + Res := '['; + when Hashed_List => + Res := '{'; + end case; + return Res; + end Opening; + + + function Closing (LT : List_Types) return Character is + Res : Character; + begin + case LT is + when List_List => + Res := ')'; + when Vector_List => + Res := ']'; + when Hashed_List => + Res := '}'; + end case; + return Res; + end Closing; + + + function New_Lambda_Mal_Type + (Params : Mal_Handle; Expr : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle is + begin + return Smart_Pointers.New_Ptr + (new Lambda_Mal_Type' + (Mal_Type with + Params => Params, + Expr => Expr, + Env => Env, + Is_Macro => False)); + end New_Lambda_Mal_Type; + + overriding function Sym_Type (T : Lambda_Mal_Type) return Sym_Types is + begin + return Lambda; + end Sym_Type; + + function Get_Env (L : Lambda_Mal_Type) return Envs.Env_Handle is + begin + return L.Env; + end Get_Env; + + procedure Set_Env (L : in out Lambda_Mal_Type; Env : Envs.Env_Handle) is + begin + L.Env := Env; + end Set_Env; + + function Get_Params (L : Lambda_Mal_Type) return Mal_Handle is + begin + if Deref (L.Params).Sym_Type = List and then + Deref_List (L.Params).Get_List_Type = Vector_List then + -- Its a vector and we need a list... + return Deref_List_Class (L.Params).Duplicate; + else + return L.Params; + end if; + end Get_Params; + + function Get_Expr (L : Lambda_Mal_Type) return Mal_Handle is + begin + return L.Expr; + end Get_Expr; + + function Get_Is_Macro (L : Lambda_Mal_Type) return Boolean is + begin + return L.Is_Macro; + end Get_Is_Macro; + + procedure Set_Is_Macro (L : in out Lambda_Mal_Type; B : Boolean) is + begin + L.Is_Macro := B; + end Set_Is_Macro; + + + function Apply + (L : Lambda_Mal_Type; + Param_List : Mal_Handle) + return Mal_Handle is + + E : Envs.Env_Handle; + Param_Names : List_Mal_Type; + Res : Mal_Handle; + + begin + + E := Envs.New_Env (L.Env); + + Param_Names := Deref_List (L.Get_Params).all; + + if Envs.Bind (E, Param_Names, Deref_List (Param_List).all) then + + Res := Eval_Callback.Eval.all (L.Get_Expr, E); + + else + + raise Runtime_Exception with "Bind failed in Apply"; + + end if; + + return Res; + + end Apply; + + + function Get_Macro (T : Mal_Handle; Env : Envs.Env_Handle) return Lambda_Ptr is + L : List_Mal_Type; + First_Elem, Func : Mal_Handle; + begin + + if Deref (T).Sym_Type /= List then + return null; + end if; + + L := Deref_List (T).all; + + if Is_Null (L) then + return null; + end if; + + First_Elem := Car (L); + + if Deref (First_Elem).Sym_Type /= Sym then + return null; + end if; + + Func := Envs.Get (Env, Deref_Sym (First_Elem).Get_Sym); + + if Deref (Func).Sym_Type /= Lambda then + return null; + end if; + + return Deref_Lambda (Func); + + exception + when Envs.Not_Found => return null; + end Get_Macro; + + + overriding function To_Str + (T : Lambda_Mal_Type; Print_Readably : Boolean := True) + return Mal_String is + begin +-- return "(lambda " & Ada.Strings.Unbounded.To_String (T.Rep) & ")"; + return "#"; + end To_Str; + + function Deref_Lambda (SP : Mal_Handle) return Lambda_Ptr is + begin + return Lambda_Ptr (Deref (SP)); + end Deref_Lambda; + + + function Arith_Op (A, B : Mal_Handle) return Mal_Handle is + use Types; + A_Sym_Type : Sym_Types; + B_Sym_Type : Sym_Types; + begin + + if Is_Null (A) then + if Is_Null (B) then + -- both null, gotta be zero. + return New_Int_Mal_Type (0); + else -- A is null but B is not. + return Arith_Op (New_Int_Mal_Type (0), B); + end if; + elsif Is_Null (B) then + -- A is not null but B is. + return Arith_Op (A, New_Int_Mal_Type (0)); + end if; + + -- else both A and B and not null.:wq + A_Sym_Type := Deref (A).Sym_Type; + B_Sym_Type := Deref (B).Sym_Type; + if A_Sym_Type = Int and B_Sym_Type = Int then + return New_Int_Mal_Type + (Int_Op (Deref_Int (A).Get_Int_Val, Deref_Int (B).Get_Int_Val)); + elsif A_Sym_Type = Int and B_Sym_Type = Floating then + return New_Float_Mal_Type + (Float_Op (Mal_Float (Deref_Int (A).Get_Int_Val), + Deref_Float (B).Get_Float_Val)); + elsif A_Sym_Type = Floating and B_Sym_Type = Int then + return New_Float_Mal_Type + (Float_Op (Deref_Float (A).Get_Float_Val, + Mal_Float (Deref_Float (B).Get_Float_Val))); + elsif A_Sym_Type = Floating and B_Sym_Type = Floating then + return New_Float_Mal_Type + (Float_Op (Deref_Float (A).Get_Float_Val, + Deref_Float (B).Get_Float_Val)); + else + if A_Sym_Type = Error then + return A; + elsif B_Sym_Type = Error then + return B; + else + return New_Error_Mal_Type ("Invalid operands"); + end if; + end if; + end Arith_Op; + + + function Rel_Op (A, B : Mal_Handle) return Mal_Handle is + use Types; + A_Sym_Type : Sym_Types := Deref (A).Sym_Type; + B_Sym_Type : Sym_Types := Deref (B).Sym_Type; + begin + if A_Sym_Type = Int and B_Sym_Type = Int then + return New_Bool_Mal_Type + (Int_Rel_Op (Deref_Int (A).Get_Int_Val, Deref_Int (B).Get_Int_Val)); + elsif A_Sym_Type = Int and B_Sym_Type = Floating then + return New_Bool_Mal_Type + (Float_Rel_Op (Mal_Float (Deref_Int (A).Get_Int_Val), + Deref_Float (B).Get_Float_Val)); + elsif A_Sym_Type = Floating and B_Sym_Type = Int then + return New_Bool_Mal_Type + (Float_Rel_Op (Deref_Float (A).Get_Float_Val, + Mal_Float (Deref_Float (B).Get_Float_Val))); + else + return New_Bool_Mal_Type + (Float_Rel_Op (Deref_Float (A).Get_Float_Val, + Deref_Float (B).Get_Float_Val)); + end if; + end Rel_Op; + + +end Types; diff --git a/impls/ada/types.ads b/impls/ada/types.ads index 8329453bca..f0874779c3 100644 --- a/impls/ada/types.ads +++ b/impls/ada/types.ads @@ -1,442 +1,442 @@ --- This started out as a simple public variant record. --- Then smart pointers were added. They were part of the Mal_Type and --- were required to be public because of the dependencies and --- how the variant record was public. Not very Ada-like. --- The third version bites the bullet and delares Mal_Type as tagged. --- Smart pointers are an OO version in a separate package. --- The Doubly_Linked_Lists have been replaced with a tree-like list instead... --- The tree-like list has been replaced with a singly linked list. Sigh. - --- WARNING! This code contains: --- Recursive data structures. --- Object-based smart pointers. --- Object-oriented code. --- And strong-typing! - --- Chris M Moore 25/03/2015 - -with Ada.Strings.Unbounded; -with Smart_Pointers; -with Envs; - -package Types is - - -- Some simple types. Not supposed to use the standard types directly. - - subtype Mal_Float is Float; - subtype Mal_Integer is Integer; - subtype Mal_String is String; - - -- Start off with the top-level abstract type. - - subtype Mal_Handle is Smart_Pointers.Smart_Pointer; - - function "=" (A, B : Mal_Handle) return Mal_Handle; - - function "=" (A, B : Mal_Handle) return Boolean; - - type Sym_Types is (Nil, Bool, Int, Floating, Str, Sym, Atom, Node, - List, Func, Lambda, Error); - - type Mal_Type is abstract new Smart_Pointers.Base_Class with private; - - function Sym_Type (T : Mal_Type) return Sym_Types is abstract; - - function Get_Meta (T : Mal_Type) return Mal_Handle; - - procedure Set_Meta (T : in out Mal_Type'Class; SP : Mal_Handle); - - function Copy (M : Mal_Handle) return Mal_Handle; - - function To_String (T : Mal_Type'Class; Print_Readably : Boolean := True) - return Mal_String; - - function Is_Macro_Call (T : Mal_Type'Class; Env : Envs.Env_Handle) return Boolean; - - type Mal_Ptr is access all Mal_Type'Class; - - -- A helper function that just view converts the smart pointer to - -- a Mal_Type'Class pointer. - function Deref (S : Mal_Handle) return Mal_Ptr; - - -- A helper function to detect null smart pointers. - function Is_Null (S : Mal_Handle) return Boolean; - - -- Derived types. All boilerplate from here. - - type Nil_Mal_Type is new Mal_Type with private; - - function New_Nil_Mal_Type return Mal_Handle; - - overriding function Sym_Type (T : Nil_Mal_Type) return Sym_Types; - - - type Int_Mal_Type is new Mal_Type with private; - - function New_Int_Mal_Type (Int : Mal_Integer) return Mal_Handle; - - overriding function Sym_Type (T : Int_Mal_Type) return Sym_Types; - - function Get_Int_Val (T : Int_Mal_Type) return Mal_Integer; - - type Int_Ptr is access all Int_Mal_Type; - - function Deref_Int (SP : Mal_Handle) return Int_Ptr; - - - type Float_Mal_Type is new Mal_Type with private; - - function New_Float_Mal_Type (Floating : Mal_Float) return Mal_Handle; - - overriding function Sym_Type (T : Float_Mal_Type) return Sym_Types; - - function Get_Float_Val (T : Float_Mal_Type) return Mal_Float; - - type Float_Ptr is access all Float_Mal_Type; - - function Deref_Float (SP : Mal_Handle) return Float_Ptr; - - - type Bool_Mal_Type is new Mal_Type with private; - - function New_Bool_Mal_Type (Bool : Boolean) return Mal_Handle; - - overriding function Sym_Type (T : Bool_Mal_Type) return Sym_Types; - - function Get_Bool (T : Bool_Mal_Type) return Boolean; - - type Bool_Ptr is access all Bool_Mal_Type; - - function Deref_Bool (SP : Mal_Handle) return Bool_Ptr; - - - type String_Mal_Type is new Mal_Type with private; - - function New_String_Mal_Type (Str : Mal_String) return Mal_Handle; - - overriding function Sym_Type (T : String_Mal_Type) return Sym_Types; - - function Get_String (T : String_Mal_Type) return Mal_String; - - type String_Ptr is access all String_Mal_Type; - - function Deref_String (SP : Mal_Handle) return String_Ptr; - - - type Symbol_Mal_Type is new Mal_Type with private; - - function New_Symbol_Mal_Type (Str : Mal_String) return Mal_Handle; - - overriding function Sym_Type (T : Symbol_Mal_Type) return Sym_Types; - - function Get_Sym (T : Symbol_Mal_Type) return Mal_String; - - type Sym_Ptr is access all Symbol_Mal_Type; - - function Deref_Sym (S : Mal_Handle) return Sym_Ptr; - - - - type Atom_Mal_Type is new Mal_Type with private; - - function New_Atom_Mal_Type (MH : Mal_Handle) return Mal_Handle; - - overriding function Sym_Type (T : Atom_Mal_Type) return Sym_Types; - - function Get_Atom (T : Atom_Mal_Type) return Mal_Handle; - - procedure Set_Atom (T : in out Atom_Mal_Type; New_Val : Mal_Handle); - - type Atom_Ptr is access all Atom_Mal_Type; - - function Deref_Atom (S : Mal_Handle) return Atom_Ptr; - - - - type Error_Mal_Type is new Mal_Type with private; - - function New_Error_Mal_Type (Str : Mal_String) return Mal_Handle; - - overriding function Sym_Type (T : Error_Mal_Type) return Sym_Types; - - - -- Lists. - - type List_Types is (List_List, Vector_List, Hashed_List); - function Opening (LT : List_Types) return Character; - function Closing (LT : List_Types) return Character; - - type List_Mal_Type is new Mal_Type with private; - - function "=" (A, B : List_Mal_Type) return Boolean; - - function New_List_Mal_Type - (List_Type : List_Types; - The_First_Node : Mal_Handle := Smart_Pointers.Null_Smart_Pointer) - return Mal_Handle; - - function New_List_Mal_Type - (The_List : List_Mal_Type) - return Mal_Handle; - - type Handle_Lists is array (Positive range <>) of Mal_Handle; - - -- Make a new list of the form: (Handle_List(1), Handle_List(2)...) - function Make_New_List (Handle_List : Handle_Lists) return Mal_Handle; - - overriding function Sym_Type (T : List_Mal_Type) return Sym_Types; - - function Get_List_Type (L : List_Mal_Type) return List_Types; - - function Prepend (Op : Mal_Handle; To_List : List_Mal_Type) - return Mal_Handle; - - procedure Append (To_List : in out List_Mal_Type; Op : Mal_Handle); - - function Length (L : List_Mal_Type) return Natural; - - function Nth (L : List_Mal_Type; N : Natural) return Mal_Handle; - - procedure Add_Defs (Defs : List_Mal_Type; Env : Envs.Env_Handle); - - -- Get the first item in the list: - function Car (L : List_Mal_Type) return Mal_Handle; - - -- Get the rest of the list (second item onwards) - function Cdr (L : List_Mal_Type) return Mal_Handle; - - type Func_Access is access - function (Elem : Mal_Handle) - return Mal_Handle; - - function Map - (Func_Ptr : Func_Access; - L : List_Mal_Type) - return Mal_Handle; - - type Binary_Func_Access is access - function (A, B : Mal_Handle) - return Mal_Handle; - - function Reduce - (Func_Ptr : Binary_Func_Access; - L : List_Mal_Type) - return Mal_Handle; - - function Is_Null (L : List_Mal_Type) return Boolean; - - function Null_List (L : List_Types) return List_Mal_Type; - - function Pr_Str (T : List_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - function Cat_Str (T : List_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - function Concat (Rest_Handle : List_Mal_Type) - return Types.Mal_Handle; -- a new list - - -- Duplicate copies the list (logically). This is to allow concatenation, - -- The result is always a List_List. - function Duplicate (The_List : List_Mal_Type) return Mal_Handle; - - type List_Ptr is access all List_Mal_Type; - - function Deref_List (SP : Mal_Handle) return List_Ptr; - - type List_Class_Ptr is access all List_Mal_Type'Class; - - function Deref_List_Class (SP : Mal_Handle) return List_Class_Ptr; - - - type Func_Mal_Type is new Mal_Type with private; - - type Builtin_Func is access - function (MH : Mal_Handle) return Mal_Handle; - - function New_Func_Mal_Type (Str : Mal_String; F : Builtin_Func) - return Mal_Handle; - - overriding function Sym_Type (T : Func_Mal_Type) return Sym_Types; - - function Get_Func_Name (T : Func_Mal_Type) return Mal_String; - - function Call_Func - (FMT : Func_Mal_Type; Rest_List : Mal_Handle) - return Mal_Handle; - - type Func_Ptr is access all Func_Mal_Type; - - function Deref_Func (S : Mal_Handle) return Func_Ptr; - - - - type Lambda_Mal_Type is new Mal_Type with private; - - function New_Lambda_Mal_Type - (Params : Mal_Handle; Expr : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle; - - overriding function Sym_Type (T : Lambda_Mal_Type) return Sym_Types; - - function Get_Env (L : Lambda_Mal_Type) return Envs.Env_Handle; - - procedure Set_Env (L : in out Lambda_Mal_Type; Env : Envs.Env_Handle); - - function Get_Params (L : Lambda_Mal_Type) return Mal_Handle; - - function Get_Expr (L : Lambda_Mal_Type) return Mal_Handle; - - function Get_Is_Macro (L : Lambda_Mal_Type) return Boolean; - - procedure Set_Is_Macro (L : in out Lambda_Mal_Type; B : Boolean); - - function Apply - (L : Lambda_Mal_Type; - Param_List : Mal_Handle) return Mal_Handle; - - type Lambda_Ptr is access all Lambda_Mal_Type; - - function Get_Macro (T : Mal_Handle; Env : Envs.Env_Handle) return Lambda_Ptr; - - function Deref_Lambda (SP : Mal_Handle) return Lambda_Ptr; - - generic - with function Int_Op (A, B : Mal_Integer) return Mal_Integer; - with function Float_Op (A, B : Mal_Float) return Mal_Float; - function Arith_Op (A, B : Mal_Handle) return Mal_Handle; - - generic - with function Int_Rel_Op (A, B : Mal_Integer) return Boolean; - with function Float_Rel_Op (A, B : Mal_Float) return Boolean; - function Rel_Op (A, B : Mal_Handle) return Mal_Handle; - - Runtime_Exception : exception; - - Mal_Exception : exception; -- So tempting to call this Mal_Function but... - - Mal_Exception_Value : Mal_Handle; -- Used by mal's throw command - -private - - type Mal_Type is abstract new Smart_Pointers.Base_Class with record - Meta : Mal_Handle; - end record; - - -- Not allowed to be abstract and private. RM 3.9.3(10) - -- So if you call this it'll just raise an exception. - function To_Str (T : Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Nil_Mal_Type is new Mal_Type with null record; - - overriding function To_Str (T : Nil_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Int_Mal_Type is new Mal_Type with record - Int_Val : Mal_Integer; - end record; - - overriding function To_Str (T : Int_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Float_Mal_Type is new Mal_Type with record - Float_Val : Mal_Float; - end record; - - overriding function To_Str (T : Float_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Bool_Mal_Type is new Mal_Type with record - Bool_Val : Boolean; - end record; - - overriding function To_Str (T : Bool_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type String_Mal_Type is new Mal_Type with record - The_String : Ada.Strings.Unbounded.Unbounded_String; - end record; - - overriding function To_Str (T : String_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Symbol_Mal_Type is new Mal_Type with record - The_Symbol : Ada.Strings.Unbounded.Unbounded_String; - end record; - - overriding function To_Str (T : Symbol_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Atom_Mal_Type is new Mal_Type with record - The_Atom : Mal_Handle; - end record; - - overriding function To_Str (T : Atom_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Func_Mal_Type is new Mal_Type with record - Func_Name : Ada.Strings.Unbounded.Unbounded_String; - Func_P : Builtin_Func; - end record; - - overriding function To_Str (T : Func_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Error_Mal_Type is new Mal_Type with record - Error_Msg : Ada.Strings.Unbounded.Unbounded_String; - end record; - - overriding function To_Str (T : Error_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - - -- Nodes have to be a differnt type from a List; - -- otherwise how do you represent a list within a list? - type Node_Mal_Type is new Mal_Type with record - Data : Mal_Handle; - Next : Mal_Handle; -- This is always a Node_Mal_Type handle - end record; - - function New_Node_Mal_Type - (Data : Mal_Handle; - Next : Mal_Handle := Smart_Pointers.Null_Smart_Pointer) - return Mal_Handle; - - overriding function Sym_Type (T : Node_Mal_Type) return Sym_Types; - - overriding function To_Str - (T : Node_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Node_Ptr is access all Node_Mal_Type; - - function Deref_Node (SP : Mal_Handle) return Node_Ptr; - - - type List_Mal_Type is new Mal_Type with record - List_Type : List_Types; - The_List : Mal_Handle; - Last_Elem : Mal_Handle; - end record; - - overriding function To_Str - (T : List_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - type Container_Cursor is tagged record - The_Node : Node_Ptr := null; - end record; - - type Lambda_Mal_Type is new Mal_Type with record - Params, Expr : Mal_Handle; - Env : Envs.Env_Handle; - Is_Macro : Boolean; - end record; - - overriding function To_Str - (T : Lambda_Mal_Type; Print_Readably : Boolean := True) - return Mal_String; - - -end Types; +-- This started out as a simple public variant record. +-- Then smart pointers were added. They were part of the Mal_Type and +-- were required to be public because of the dependencies and +-- how the variant record was public. Not very Ada-like. +-- The third version bites the bullet and delares Mal_Type as tagged. +-- Smart pointers are an OO version in a separate package. +-- The Doubly_Linked_Lists have been replaced with a tree-like list instead... +-- The tree-like list has been replaced with a singly linked list. Sigh. + +-- WARNING! This code contains: +-- Recursive data structures. +-- Object-based smart pointers. +-- Object-oriented code. +-- And strong-typing! + +-- Chris M Moore 25/03/2015 + +with Ada.Strings.Unbounded; +with Smart_Pointers; +with Envs; + +package Types is + + -- Some simple types. Not supposed to use the standard types directly. + + subtype Mal_Float is Float; + subtype Mal_Integer is Integer; + subtype Mal_String is String; + + -- Start off with the top-level abstract type. + + subtype Mal_Handle is Smart_Pointers.Smart_Pointer; + + function "=" (A, B : Mal_Handle) return Mal_Handle; + + function "=" (A, B : Mal_Handle) return Boolean; + + type Sym_Types is (Nil, Bool, Int, Floating, Str, Sym, Atom, Node, + List, Func, Lambda, Error); + + type Mal_Type is abstract new Smart_Pointers.Base_Class with private; + + function Sym_Type (T : Mal_Type) return Sym_Types is abstract; + + function Get_Meta (T : Mal_Type) return Mal_Handle; + + procedure Set_Meta (T : in out Mal_Type'Class; SP : Mal_Handle); + + function Copy (M : Mal_Handle) return Mal_Handle; + + function To_String (T : Mal_Type'Class; Print_Readably : Boolean := True) + return Mal_String; + + function Is_Macro_Call (T : Mal_Type'Class; Env : Envs.Env_Handle) return Boolean; + + type Mal_Ptr is access all Mal_Type'Class; + + -- A helper function that just view converts the smart pointer to + -- a Mal_Type'Class pointer. + function Deref (S : Mal_Handle) return Mal_Ptr; + + -- A helper function to detect null smart pointers. + function Is_Null (S : Mal_Handle) return Boolean; + + -- Derived types. All boilerplate from here. + + type Nil_Mal_Type is new Mal_Type with private; + + function New_Nil_Mal_Type return Mal_Handle; + + overriding function Sym_Type (T : Nil_Mal_Type) return Sym_Types; + + + type Int_Mal_Type is new Mal_Type with private; + + function New_Int_Mal_Type (Int : Mal_Integer) return Mal_Handle; + + overriding function Sym_Type (T : Int_Mal_Type) return Sym_Types; + + function Get_Int_Val (T : Int_Mal_Type) return Mal_Integer; + + type Int_Ptr is access all Int_Mal_Type; + + function Deref_Int (SP : Mal_Handle) return Int_Ptr; + + + type Float_Mal_Type is new Mal_Type with private; + + function New_Float_Mal_Type (Floating : Mal_Float) return Mal_Handle; + + overriding function Sym_Type (T : Float_Mal_Type) return Sym_Types; + + function Get_Float_Val (T : Float_Mal_Type) return Mal_Float; + + type Float_Ptr is access all Float_Mal_Type; + + function Deref_Float (SP : Mal_Handle) return Float_Ptr; + + + type Bool_Mal_Type is new Mal_Type with private; + + function New_Bool_Mal_Type (Bool : Boolean) return Mal_Handle; + + overriding function Sym_Type (T : Bool_Mal_Type) return Sym_Types; + + function Get_Bool (T : Bool_Mal_Type) return Boolean; + + type Bool_Ptr is access all Bool_Mal_Type; + + function Deref_Bool (SP : Mal_Handle) return Bool_Ptr; + + + type String_Mal_Type is new Mal_Type with private; + + function New_String_Mal_Type (Str : Mal_String) return Mal_Handle; + + overriding function Sym_Type (T : String_Mal_Type) return Sym_Types; + + function Get_String (T : String_Mal_Type) return Mal_String; + + type String_Ptr is access all String_Mal_Type; + + function Deref_String (SP : Mal_Handle) return String_Ptr; + + + type Symbol_Mal_Type is new Mal_Type with private; + + function New_Symbol_Mal_Type (Str : Mal_String) return Mal_Handle; + + overriding function Sym_Type (T : Symbol_Mal_Type) return Sym_Types; + + function Get_Sym (T : Symbol_Mal_Type) return Mal_String; + + type Sym_Ptr is access all Symbol_Mal_Type; + + function Deref_Sym (S : Mal_Handle) return Sym_Ptr; + + + + type Atom_Mal_Type is new Mal_Type with private; + + function New_Atom_Mal_Type (MH : Mal_Handle) return Mal_Handle; + + overriding function Sym_Type (T : Atom_Mal_Type) return Sym_Types; + + function Get_Atom (T : Atom_Mal_Type) return Mal_Handle; + + procedure Set_Atom (T : in out Atom_Mal_Type; New_Val : Mal_Handle); + + type Atom_Ptr is access all Atom_Mal_Type; + + function Deref_Atom (S : Mal_Handle) return Atom_Ptr; + + + + type Error_Mal_Type is new Mal_Type with private; + + function New_Error_Mal_Type (Str : Mal_String) return Mal_Handle; + + overriding function Sym_Type (T : Error_Mal_Type) return Sym_Types; + + + -- Lists. + + type List_Types is (List_List, Vector_List, Hashed_List); + function Opening (LT : List_Types) return Character; + function Closing (LT : List_Types) return Character; + + type List_Mal_Type is new Mal_Type with private; + + function "=" (A, B : List_Mal_Type) return Boolean; + + function New_List_Mal_Type + (List_Type : List_Types; + The_First_Node : Mal_Handle := Smart_Pointers.Null_Smart_Pointer) + return Mal_Handle; + + function New_List_Mal_Type + (The_List : List_Mal_Type) + return Mal_Handle; + + type Handle_Lists is array (Positive range <>) of Mal_Handle; + + -- Make a new list of the form: (Handle_List(1), Handle_List(2)...) + function Make_New_List (Handle_List : Handle_Lists) return Mal_Handle; + + overriding function Sym_Type (T : List_Mal_Type) return Sym_Types; + + function Get_List_Type (L : List_Mal_Type) return List_Types; + + function Prepend (Op : Mal_Handle; To_List : List_Mal_Type) + return Mal_Handle; + + procedure Append (To_List : in out List_Mal_Type; Op : Mal_Handle); + + function Length (L : List_Mal_Type) return Natural; + + function Nth (L : List_Mal_Type; N : Natural) return Mal_Handle; + + procedure Add_Defs (Defs : List_Mal_Type; Env : Envs.Env_Handle); + + -- Get the first item in the list: + function Car (L : List_Mal_Type) return Mal_Handle; + + -- Get the rest of the list (second item onwards) + function Cdr (L : List_Mal_Type) return Mal_Handle; + + type Func_Access is access + function (Elem : Mal_Handle) + return Mal_Handle; + + function Map + (Func_Ptr : Func_Access; + L : List_Mal_Type) + return Mal_Handle; + + type Binary_Func_Access is access + function (A, B : Mal_Handle) + return Mal_Handle; + + function Reduce + (Func_Ptr : Binary_Func_Access; + L : List_Mal_Type) + return Mal_Handle; + + function Is_Null (L : List_Mal_Type) return Boolean; + + function Null_List (L : List_Types) return List_Mal_Type; + + function Pr_Str (T : List_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + function Cat_Str (T : List_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + function Concat (Rest_Handle : List_Mal_Type) + return Types.Mal_Handle; -- a new list + + -- Duplicate copies the list (logically). This is to allow concatenation, + -- The result is always a List_List. + function Duplicate (The_List : List_Mal_Type) return Mal_Handle; + + type List_Ptr is access all List_Mal_Type; + + function Deref_List (SP : Mal_Handle) return List_Ptr; + + type List_Class_Ptr is access all List_Mal_Type'Class; + + function Deref_List_Class (SP : Mal_Handle) return List_Class_Ptr; + + + type Func_Mal_Type is new Mal_Type with private; + + type Builtin_Func is access + function (MH : Mal_Handle) return Mal_Handle; + + function New_Func_Mal_Type (Str : Mal_String; F : Builtin_Func) + return Mal_Handle; + + overriding function Sym_Type (T : Func_Mal_Type) return Sym_Types; + + function Get_Func_Name (T : Func_Mal_Type) return Mal_String; + + function Call_Func + (FMT : Func_Mal_Type; Rest_List : Mal_Handle) + return Mal_Handle; + + type Func_Ptr is access all Func_Mal_Type; + + function Deref_Func (S : Mal_Handle) return Func_Ptr; + + + + type Lambda_Mal_Type is new Mal_Type with private; + + function New_Lambda_Mal_Type + (Params : Mal_Handle; Expr : Mal_Handle; Env : Envs.Env_Handle) + return Mal_Handle; + + overriding function Sym_Type (T : Lambda_Mal_Type) return Sym_Types; + + function Get_Env (L : Lambda_Mal_Type) return Envs.Env_Handle; + + procedure Set_Env (L : in out Lambda_Mal_Type; Env : Envs.Env_Handle); + + function Get_Params (L : Lambda_Mal_Type) return Mal_Handle; + + function Get_Expr (L : Lambda_Mal_Type) return Mal_Handle; + + function Get_Is_Macro (L : Lambda_Mal_Type) return Boolean; + + procedure Set_Is_Macro (L : in out Lambda_Mal_Type; B : Boolean); + + function Apply + (L : Lambda_Mal_Type; + Param_List : Mal_Handle) return Mal_Handle; + + type Lambda_Ptr is access all Lambda_Mal_Type; + + function Get_Macro (T : Mal_Handle; Env : Envs.Env_Handle) return Lambda_Ptr; + + function Deref_Lambda (SP : Mal_Handle) return Lambda_Ptr; + + generic + with function Int_Op (A, B : Mal_Integer) return Mal_Integer; + with function Float_Op (A, B : Mal_Float) return Mal_Float; + function Arith_Op (A, B : Mal_Handle) return Mal_Handle; + + generic + with function Int_Rel_Op (A, B : Mal_Integer) return Boolean; + with function Float_Rel_Op (A, B : Mal_Float) return Boolean; + function Rel_Op (A, B : Mal_Handle) return Mal_Handle; + + Runtime_Exception : exception; + + Mal_Exception : exception; -- So tempting to call this Mal_Function but... + + Mal_Exception_Value : Mal_Handle; -- Used by mal's throw command + +private + + type Mal_Type is abstract new Smart_Pointers.Base_Class with record + Meta : Mal_Handle; + end record; + + -- Not allowed to be abstract and private. RM 3.9.3(10) + -- So if you call this it'll just raise an exception. + function To_Str (T : Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Nil_Mal_Type is new Mal_Type with null record; + + overriding function To_Str (T : Nil_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Int_Mal_Type is new Mal_Type with record + Int_Val : Mal_Integer; + end record; + + overriding function To_Str (T : Int_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Float_Mal_Type is new Mal_Type with record + Float_Val : Mal_Float; + end record; + + overriding function To_Str (T : Float_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Bool_Mal_Type is new Mal_Type with record + Bool_Val : Boolean; + end record; + + overriding function To_Str (T : Bool_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type String_Mal_Type is new Mal_Type with record + The_String : Ada.Strings.Unbounded.Unbounded_String; + end record; + + overriding function To_Str (T : String_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Symbol_Mal_Type is new Mal_Type with record + The_Symbol : Ada.Strings.Unbounded.Unbounded_String; + end record; + + overriding function To_Str (T : Symbol_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Atom_Mal_Type is new Mal_Type with record + The_Atom : Mal_Handle; + end record; + + overriding function To_Str (T : Atom_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Func_Mal_Type is new Mal_Type with record + Func_Name : Ada.Strings.Unbounded.Unbounded_String; + Func_P : Builtin_Func; + end record; + + overriding function To_Str (T : Func_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Error_Mal_Type is new Mal_Type with record + Error_Msg : Ada.Strings.Unbounded.Unbounded_String; + end record; + + overriding function To_Str (T : Error_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + + -- Nodes have to be a differnt type from a List; + -- otherwise how do you represent a list within a list? + type Node_Mal_Type is new Mal_Type with record + Data : Mal_Handle; + Next : Mal_Handle; -- This is always a Node_Mal_Type handle + end record; + + function New_Node_Mal_Type + (Data : Mal_Handle; + Next : Mal_Handle := Smart_Pointers.Null_Smart_Pointer) + return Mal_Handle; + + overriding function Sym_Type (T : Node_Mal_Type) return Sym_Types; + + overriding function To_Str + (T : Node_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Node_Ptr is access all Node_Mal_Type; + + function Deref_Node (SP : Mal_Handle) return Node_Ptr; + + + type List_Mal_Type is new Mal_Type with record + List_Type : List_Types; + The_List : Mal_Handle; + Last_Elem : Mal_Handle; + end record; + + overriding function To_Str + (T : List_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + type Container_Cursor is tagged record + The_Node : Node_Ptr := null; + end record; + + type Lambda_Mal_Type is new Mal_Type with record + Params, Expr : Mal_Handle; + Env : Envs.Env_Handle; + Is_Macro : Boolean; + end record; + + overriding function To_Str + (T : Lambda_Mal_Type; Print_Readably : Boolean := True) + return Mal_String; + + +end Types; diff --git a/impls/awk/Dockerfile b/impls/awk/Dockerfile index 9d0e12cee1..fc4d03a7f6 100644 --- a/impls/awk/Dockerfile +++ b/impls/awk/Dockerfile @@ -1,25 +1,25 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# GNU Awk -RUN apt-get -y install gawk +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# GNU Awk +RUN apt-get -y install gawk diff --git a/impls/awk/Makefile b/impls/awk/Makefile index ce864e0845..0bcce3fd9a 100644 --- a/impls/awk/Makefile +++ b/impls/awk/Makefile @@ -1,20 +1,20 @@ -SOURCES_BASE = types.awk reader.awk printer.awk -SOURCES_LISP = env.awk core.awk stepA_mal.awk -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.awk mal - -mal.awk: $(SOURCES) - echo 'arbitrary_long_name==0 "exec" "/usr/bin/gawk" "-O" "-f" "$$0" "$$@"' > $@ - cat $+ | grep -v "^@include " >> $@ - -mal: mal.awk - echo '#!/bin/sh' > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.awk mal +SOURCES_BASE = types.awk reader.awk printer.awk +SOURCES_LISP = env.awk core.awk stepA_mal.awk +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.awk mal + +mal.awk: $(SOURCES) + echo 'arbitrary_long_name==0 "exec" "/usr/bin/gawk" "-O" "-f" "$$0" "$$@"' > $@ + cat $+ | grep -v "^@include " >> $@ + +mal: mal.awk + echo '#!/bin/sh' > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.awk mal diff --git a/impls/awk/core.awk b/impls/awk/core.awk index e7dc0b98fb..938b6f6d5d 100644 --- a/impls/awk/core.awk +++ b/impls/awk/core.awk @@ -1,1138 +1,1138 @@ -@load "readfile" -@load "time" - -function core_eq_sub(lhs, rhs, i, len) -{ - if (lhs ~ /^[([]/ && rhs ~ /^[([]/) { - lhs = substr(lhs, 2) - rhs = substr(rhs, 2) - len = types_heap[lhs]["len"] - if (len != types_heap[rhs]["len"]) { - return 0 - } - for (i = 0; i < len; ++i) { - if (!core_eq_sub(types_heap[lhs][i], types_heap[rhs][i])) { - return 0 - } - } - return 1 - } else if (lhs ~ /^\{/ && rhs ~ /^\{/) { - lhs = substr(lhs, 2) - rhs = substr(rhs, 2) - if (length(types_heap[lhs]) != length(types_heap[rhs])) { - return 0 - } - for (i in types_heap[lhs]) { - if (types_heap[lhs][i] ~ /^["':+#([{?&$%]/ && - !core_eq_sub(types_heap[lhs][i], types_heap[rhs][i])) { - return 0 - } - } - return 1 - } else { - return lhs == rhs - } -} - -function core_eq(idx) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '='. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - return core_eq_sub(types_heap[idx][1], types_heap[idx][2]) ? "#true" : "#false" -} - -function core_throw(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'throw'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return "!" types_addref(types_heap[idx][1]) -} - - - -function core_nilp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'nil?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] == "#nil" ? "#true" : "#false" -} - -function core_truep(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'true?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] == "#true" ? "#true" : "#false" -} - -function core_falsep(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'false?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] == "#false" ? "#true" : "#false" -} - -function core_stringp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'string?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] ~ /^"/ ? "#true" : "#false" -} - -function core_symbol(idx, str) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'symbol'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - str = types_heap[idx][1] - if (str !~ /^"/) { - return "!\"Incompatible type for argument 1 of builtin function 'symbol'. Expects string, supplied " types_typename(str) "." - } - return "'" substr(str, 2) -} - -function core_symbolp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'symbol?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] ~ /^'/ ? "#true" : "#false" -} - -function core_keyword(idx, str) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'keyword'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - str = types_heap[idx][1] - switch (str) { - case /^:/: - return str - case /^"/: - return "::" substr(str, 2) - } - return "!\"Incompatible type for argument 1 of builtin function 'keyword'. Expects string or keyword, supplied " types_typename(str) "." -} - -function core_keywordp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'keyword?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] ~ /^:/ ? "#true" : "#false" -} - -function core_numberp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'number?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] ~ /^\+/ ? "#true" : "#false" -} - -function core_fnp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'fn?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - f = types_heap[idx][1] - return f ~ /^[$&%]/ && !types_heap[substr(f, 2)]["is_macro"] ? "#true" : "#false" -} - -function core_macrop(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'macro?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - f = types_heap[idx][1] - return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] ? "#true" : "#false" -} - - - -function core_pr_str(idx, i, len, result) -{ - len = types_heap[idx]["len"] - for (i = 1; i < len; ++i) { - result = result printer_pr_str(types_heap[idx][i], 1) " " - } - return "\"" substr(result, 1, length(result) - 1) -} - -function core_str(idx, i, len, result) -{ - len = types_heap[idx]["len"] - for (i = 1; i < len; ++i) { - result = result printer_pr_str(types_heap[idx][i], 0) - } - return "\"" result -} - -function core_prn(idx, i, len, result) -{ - len = types_heap[idx]["len"] - for (i = 1; i < len; ++i) { - result = result printer_pr_str(types_heap[idx][i], 1) " " - } - print substr(result, 1, length(result) - 1) - return "#nil" -} - -function core_println(idx, i, len, result) -{ - len = types_heap[idx]["len"] - for (i = 1; i < len; ++i) { - result = result printer_pr_str(types_heap[idx][i], 0) " " - } - print substr(result, 1, length(result) - 1) - return "#nil" -} - -function core_read_string(idx, str) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'read-string'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - str = types_heap[idx][1] - if (str !~ /^"/) { - return "!\"Incompatible type for argument 1 of builtin function 'read-string'. Expects string, supplied " types_typename(str) "." - } - return reader_read_str(substr(str, 2)) -} - -function core_readline(idx, prompt, var) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'readline'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - prompt = types_heap[idx][1] - if (prompt !~ /^"/) { - return "!\"Incompatible type for argument 1 of builtin function 'readline'. Expects string, supplied " types_typename(prompt) "." - } - printf("%s", printer_pr_str(prompt, 0)) - return getline var <= 0 ? "#nil" : "\"" var -} - -function core_slurp(idx, filename, str) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'slurp'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - filename = types_heap[idx][1] - if (filename !~ /^"/) { - return "!\"Incompatible type for argument 1 of builtin function 'slurp'. Expects string, supplied " types_typename(filename) "." - } - str = readfile(substr(filename, 2)) - if (str == "" && ERRNO != "") { - return "!\"cannot read file '" filename "', ERRNO = " ERRNO - } - return "\"" str -} - - - -function core_lt(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '<'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '<'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '<'. Expects number, supplied " types_typename(rhs) "." - } - return substr(lhs, 2) + 0 < substr(rhs, 2) + 0 ? "#true" : "#false" -} - -function core_le(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '<='. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '<='. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '<='. Expects number, supplied " types_typename(rhs) "." - } - return substr(lhs, 2) + 0 <= substr(rhs, 2) + 0 ? "#true" : "#false" -} - -function core_gt(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '>'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '>'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '>'. Expects number, supplied " types_typename(rhs) "." - } - return substr(lhs, 2) + 0 > substr(rhs, 2) + 0 ? "#true" : "#false" -} - -function core_ge(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '>='. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '>='. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '>='. Expects number, supplied " types_typename(rhs) "." - } - return substr(lhs, 2) + 0 >= substr(rhs, 2) + 0 ? "#true" : "#false" -} - -function core_add(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '+'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '+'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '+'. Expects number, supplied " types_typename(rhs) "." - } - return "+" (substr(lhs, 2) + substr(rhs, 2)) -} - -function core_subtract(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '-'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '-'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '-'. Expects number, supplied " types_typename(rhs) "." - } - return "+" (substr(lhs, 2) - substr(rhs, 2)) -} - -function core_multiply(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '*'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '*'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '*'. Expects number, supplied " types_typename(rhs) "." - } - return "+" (substr(lhs, 2) * substr(rhs, 2)) -} - -function core_divide(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '/'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '/'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '/'. Expects number, supplied " types_typename(rhs) "." - } - return "+" int(substr(lhs, 2) / substr(rhs, 2)) -} - -function core_time_ms(idx) -{ - if (types_heap[idx]["len"] != 1) { - return "!\"Invalid argument length for builtin function 'time-ms'. Expects no arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - return "+" int(gettimeofday() * 1000) -} - - - -function core_list(idx, new_idx, len, i) -{ - new_idx = types_allocate() - len = types_heap[idx]["len"] - for (i = 1; i < len; ++i) { - types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i]) - } - types_heap[new_idx]["len"] = len - 1 - return "(" new_idx -} - -function core_listp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'list?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] ~ /^\(/ ? "#true" : "#false" -} - -function core_vector(idx, new_idx, len, i) -{ - new_idx = types_allocate() - len = types_heap[idx]["len"] - for (i = 1; i < len; ++i) { - types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i]) - } - types_heap[new_idx]["len"] = len - 1 - return "[" new_idx -} - -function core_vectorp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'vector?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] ~ /^\[/ ? "#true" : "#false" -} - -function core_hash_map(idx, len, new_idx, i, key) -{ - len = types_heap[idx]["len"] - if (len % 2 != 1) { - return "!\"Invalid argument length for builtin function 'hash-map'. Expects even number of arguments, supplied " (len - 1) "." - } - new_idx = types_allocate() - for (i = 1; i < len; i += 2) { - key = types_heap[idx][i] - if (key !~ /^[":]/) { - types_release("{" new_idx) - return "!\"Incompatible type for key argument of builtin function 'hash-map'. Expects string or keyword, supplied " types_typename(key) "." - } - if (key in types_heap[new_idx]) { - types_release(types_heap[new_idx][key]) - } - types_addref(types_heap[new_idx][key] = types_heap[idx][i + 1]) - } - return "{" new_idx -} - -function core_mapp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'map?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] ~ /^\{/ ? "#true" : "#false" -} - -function core_assoc(idx, len, map, i, key, add_list, new_idx, map_idx) -{ - len = types_heap[idx]["len"] - if (len % 2 != 0) { - return "!\"Invalid argument length for builtin function 'assoc'. Expects odd number of arguments, supplied " (len - 1) "." - } - map = types_heap[idx][1] - if (map !~ /^\{/) { - return "!\"Incompatible type for argument 1 of builtin function 'assoc'. Expects hash-map, supplied " types_typename(map) "." - } - for (i = 2; i < len; i += 2) { - key = types_heap[idx][i] - if (key !~ /^[":]/) { - return "!\"Incompatible type for key argument of builtin function 'assoc'. Expects string or keyword, supplied " types_typename(key) "." - } - add_list[key] = types_heap[idx][i + 1] - } - new_idx = types_allocate() - map_idx = substr(map, 2) - for (key in types_heap[map_idx]) { - if (key ~ /^[":]|^meta$/ && !(key in add_list)) { - types_addref(types_heap[new_idx][key] = types_heap[map_idx][key]) - } - } - for (key in add_list) { - types_addref(types_heap[new_idx][key] = add_list[key]) - } - return "{" new_idx -} - -function core_dissoc(idx, len, map, i, key, del_list, new_idx, map_idx) -{ - len = types_heap[idx]["len"] - if (len < 2) { - return "!\"Invalid argument length for builtin function 'dissoc'. Expects at least 1 argument, supplied " (len - 1) "." - } - map = types_heap[idx][1] - if (map !~ /^\{/) { - return "!\"Incompatible type for argument 1 of builtin function 'dissoc'. Expects hash-map, supplied " types_typename(map) "." - } - for (i = 2; i < len; ++i) { - key = types_heap[idx][i] - if (key !~ /^[":]/) { - return "!\"Incompatible type for key argument of builtin function 'dissoc'. Expects string or keyword, supplied " types_typename(key) "." - } - del_list[key] = "1" - } - new_idx = types_allocate() - map_idx = substr(map, 2) - for (key in types_heap[map_idx]) { - if (key ~ /^[":]|^meta$/ && !(key in del_list)) { - types_addref(types_heap[new_idx][key] = types_heap[map_idx][key]) - } - } - return "{" new_idx -} - -function core_get(idx, map, key, map_idx) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function 'get'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - map = types_heap[idx][1] - if (map !~ /^\{/ && map != "#nil") { - return "!\"Incompatible type for argument 1 of builtin function 'get'. Expects hash-map or nil, supplied " types_typename(map) "." - } - key = types_heap[idx][2] - if (key !~ /^[":]/) { - return "!\"Incompatible type for argument 2 of builtin function 'get'. Expects string or keyword, supplied " types_typename(key) "." - } - if (map != "#nil" && key in types_heap[map_idx = substr(map, 2)]) { - return types_addref(types_heap[map_idx][key]) - } else { - return "#nil" - } -} - -function core_containsp(idx, map, key) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function 'contains?'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - map = types_heap[idx][1] - if (map !~ /^\{/) { - return "!\"Incompatible type for argument 1 of builtin function 'contains?'. Expects hash-map, supplied " types_typename(map) "." - } - key = types_heap[idx][2] - if (key !~ /^[":]/) { - return "!\"Incompatible type for argument 2 of builtin function 'contains?'. Expects string or keyword, supplied " types_typename(key) "." - } - return key in types_heap[substr(map, 2)] ? "#true" : "#false" -} - -function core_keys(idx, map, map_idx, new_idx, len, key) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'keys'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - map = types_heap[idx][1] - if (map !~ /^\{/) { - return "!\"Incompatible type for argument 1 of builtin function 'keys'. Expects hash-map, supplied " types_typename(map) "." - } - map_idx = substr(map, 2) - new_idx = types_allocate() - len = 0 - for (key in types_heap[map_idx]) { - if (key ~ /^[":]/) { - types_heap[new_idx][len++] = key - } - } - types_heap[new_idx]["len"] = len - return "(" new_idx -} - -function core_vals(idx, map, map_idx, new_idx, len, key) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'vals'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - map = types_heap[idx][1] - if (map !~ /^\{/) { - return "!\"Incompatible type for argument 1 of builtin function 'vals'. Expects hash-map, supplied " types_typename(map) "." - } - map_idx = substr(map, 2) - new_idx = types_allocate() - len = 0 - for (key in types_heap[map_idx]) { - if (key ~ /^[":]/) { - types_addref(types_heap[new_idx][len++] = types_heap[map_idx][key]) - } - } - types_heap[new_idx]["len"] = len - return "(" new_idx -} - - - -function core_sequentialp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'sequential?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] ~ /^[([]/ ? "#true" : "#false" -} - -function core_cons(idx, lst, lst_idx, new_idx, len, i) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function 'cons'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lst = types_heap[idx][2] - if (lst !~ /^[([]/) { - return "!\"Incompatible type for argument 1 of builtin function 'cons'. Expects list or vector, supplied " types_typename(lst) "." - } - lst_idx = substr(lst, 2) - new_idx = types_allocate() - types_addref(types_heap[new_idx][0] = types_heap[idx][1]) - len = types_heap[lst_idx]["len"] - for (i = 0; i < len; ++i) { - types_addref(types_heap[new_idx][i + 1] = types_heap[lst_idx][i]) - } - types_heap[new_idx]["len"] = len + 1 - return "(" new_idx -} - -function core_concat(idx, new_idx, new_len, len, i, lst, lst_idx, lst_len, j) -{ - new_idx = types_allocate() - new_len = 0 - len = types_heap[idx]["len"] - for (i = 1; i < len; ++i) { - lst = types_heap[idx][i] - if (lst !~ /^[([]/) { - types_heap[new_idx]["len"] = new_len - types_release("(" new_idx) - return "!\"Incompatible type for argument ' (i - 1) ' of builtin function 'concat'. Expects list or vector, supplied " types_typename(lst) "." - } - lst_idx = substr(lst, 2) - lst_len = types_heap[lst_idx]["len"] - for (j = 0; j < lst_len; ++j) { - types_addref(types_heap[new_idx][new_len++] = types_heap[lst_idx][j]) - } - } - types_heap[new_idx]["len"] = new_len - return "(" new_idx -} - -function core_vec(idx, new_idx, len) -{ - len = types_heap[idx]["len"] - if (len != 2) - return "!\"Invalid argument length for builtin function 'vec'. Expects exactly 1 argument, supplied " (len - 1) "." - idx = types_heap[idx][1] - if (idx !~ /^[([]/) { - return "!\"Incompatible type for argument 1 of builtin function 'vec'. Expects list or vector, supplied " types_typename(idx) "." - } - idx = substr(idx, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - types_heap[new_idx]["len"] = len - while (len--) - types_addref(types_heap[new_idx][len] = types_heap[idx][len]) - return "[" new_idx -} - -function core_nth(idx, lst, num, n, lst_idx) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function 'nth'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lst = types_heap[idx][1] - if (lst !~ /^[([]/) { - return "!\"Incompatible type for argument 1 of builtin function 'nth'. Expects list or vector, supplied " types_typename(lst) "." - } - num = types_heap[idx][2] - if (num !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function 'nth'. Expects number, supplied " types_typename(num) "." - } - n = substr(num, 2) + 0 - lst_idx = substr(lst, 2) - if (n < 0 || types_heap[lst_idx]["len"] <= n) { - return "!\"Index out of range. Sequence length is " types_heap[lst_idx]["len"] ", supplied " n "." - } - return types_addref(types_heap[lst_idx][n]) -} - -function core_first(idx, lst, lst_idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'first'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lst = types_heap[idx][1] - if (lst == "#nil") { - return "#nil" - } - if (lst !~ /^[([]/) { - return "!\"Incompatible type for argument 1 of builtin function 'first'. Expects list, vector or nil, supplied " types_typename(lst) "." - } - lst_idx = substr(lst, 2) - return types_heap[lst_idx]["len"] == 0 ? "#nil" : types_addref(types_heap[lst_idx][0]) -} - -function core_rest(idx, lst, lst_idx, lst_len, new_idx, i) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'rest'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lst = types_heap[idx][1] - if (lst == "#nil") { - new_idx = types_allocate() - types_heap[new_idx]["len"] = 0 - return "(" new_idx - } - if (lst !~ /^[([]/) { - return "!\"Incompatible type for argument 1 of builtin function 'rest'. Expects list, vector or nil, supplied " types_typename(lst) "." - } - lst_idx = substr(lst, 2) - lst_len = types_heap[lst_idx]["len"] - new_idx = types_allocate() - for (i = 1; i < lst_len; ++i) { - types_addref(types_heap[new_idx][i - 1] = types_heap[lst_idx][i]) - } - types_heap[new_idx]["len"] = lst_len - 1 - return "(" new_idx -} - -function core_emptyp(idx, lst) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'empty?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - lst = types_heap[idx][1] - if (lst !~ /^[([]/) { - return "!\"Incompatible type for argument 1 of builtin function 'empty?'. Expects list or vector, supplied " types_typename(lst) "." - } - return types_heap[substr(lst, 2)]["len"] == 0 ? "#true" : "#false" -} - -function core_count(idx, lst) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'count'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - lst = types_heap[idx][1] - if (lst ~ /^[([]/) { - return "+" types_heap[substr(lst, 2)]["len"] - } - if (lst == "#nil") { - return "+0" - } - return "!\"Incompatible type for argument 1 of builtin function 'count'. Expects list, vector or nil, supplied " types_typename(lst) "." -} - -function core_apply(idx, len, f, lst, new_idx, i, lst_idx, lst_len, f_idx, env, ret) -{ - len = types_heap[idx]["len"] - if (len < 3) { - return "!\"Invalid argument length for builtin function 'apply'. Expects at least 2 arguments, supplied " (len - 1) "." - } - f = types_heap[idx][1] - if (f !~ /^[$&%]/) { - return "!\"Incompatible type for argument 1 of builtin function 'apply'. Expects function, supplied " types_typename(f) "." - } - lst = types_heap[idx][len - 1] - if (lst !~ /^[([]/) { - return "!\"Incompatible type for argument ' (len - 1) ' of builtin function 'apply'. Expects list or vector, supplied " types_typename(lst) "." - } - - new_idx = types_allocate() - types_addref(types_heap[new_idx][0] = f) - for (i = 2; i < len - 1; ++i) { - types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i]) - } - lst_idx = substr(lst, 2) - lst_len = types_heap[lst_idx]["len"] - for (i = 0; i < lst_len; ++i) { - types_addref(types_heap[new_idx][len + i - 2] = types_heap[lst_idx][i]) - } - types_heap[new_idx]["len"] = len + lst_len - 2 - - f_idx = substr(f, 2) - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], new_idx) - types_release("(" new_idx) - if (env ~ /^!/) { - return env - } - ret = EVAL(types_addref(types_heap[f_idx]["body"]), env) - env_release(env) - return ret - case /^%/: - f_idx = types_heap[f_idx]["func"] - case /^&/: - ret = @f_idx(new_idx) - types_release("(" new_idx) - return ret - } -} - -function core_map(idx, f, lst, f_idx, lst_idx, lst_len, new_idx, expr_idx, i, env, ret, val) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function 'map'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - f = types_heap[idx][1] - if (f !~ /^[$&%]/) { - return "!\"Incompatible type for argument 1 of builtin function 'map'. Expects function, supplied " types_typename(f) "." - } - lst = types_heap[idx][2] - if (lst !~ /^[([]/) { - return "!\"Incompatible type for argument 2 of builtin function 'map'. Expects list or vector, supplied " types_typename(lst) "." - } - f_idx = substr(f, 2) - lst_idx = substr(lst, 2) - lst_len = types_heap[lst_idx]["len"] - new_idx = types_allocate() - types_heap[new_idx][0] = f - types_heap[new_idx]["len"] = 2 - expr_idx = types_allocate() - for (i = 0; i < lst_len; ++i) { - types_heap[new_idx][1] = types_heap[lst_idx][i] - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], new_idx) - if (env ~ /^!/) { - types_heap[expr_idx]["len"] = i - types_heap[new_idx]["len"] = 0 - types_release("(" expr_idx) - types_release("(" new_idx) - return env - } - ret = EVAL(types_addref(types_heap[f_idx]["body"]), env) - env_release(env) - break - case /^%/: - f_idx = types_heap[f_idx]["func"] - case /^&/: - ret = @f_idx(new_idx) - break - } - if (ret ~ /^!/) { - types_heap[expr_idx]["len"] = i - types_heap[new_idx]["len"] = 0 - types_release("(" expr_idx) - types_release("(" new_idx) - return ret - } - types_heap[expr_idx][i] = ret - } - types_heap[expr_idx]["len"] = lst_len - types_heap[new_idx]["len"] = 0 - types_release("(" new_idx) - return "(" expr_idx -} - - - -function core_conj(idx, len, lst, lst_idx, lst_len, new_idx, i, j) -{ - len = types_heap[idx]["len"] - if (len < 3) { - return "!\"Invalid argument length for builtin function 'conj'. Expects at least 2 arguments, supplied " (len - 1) "." - } - lst = types_heap[idx][1] - if (lst !~ /^[([]/) { - return "!\"Incompatible type for argument 1 of builtin function 'conj'. Expects list or vector, supplied " types_typename(lst) "." - } - lst_idx = substr(lst, 2) - lst_len = types_heap[lst_idx]["len"] - new_idx = types_allocate() - j = 0 - if (lst ~ /^\(/) { - for (i = len - 1; i >= 2; --i) { - types_addref(types_heap[new_idx][j++] = types_heap[idx][i]) - } - for (i = 0; i < lst_len; ++i) { - types_addref(types_heap[new_idx][j++] = types_heap[lst_idx][i]) - } - } else { - for (i = 0; i < lst_len; ++i) { - types_addref(types_heap[new_idx][j++] = types_heap[lst_idx][i]) - } - for (i = 2; i < len; ++i) { - types_addref(types_heap[new_idx][j++] = types_heap[idx][i]) - } - } - types_addref(types_heap[new_idx]["meta"] = types_heap[lst_idx]["meta"]) - types_heap[new_idx]["len"] = j - return substr(lst, 1, 1) new_idx -} - -function core_seq(idx, obj, obj_idx, new_idx, i, len, chars) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'seq'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - obj = types_heap[idx][1] - if (obj ~ /^[(]/) { - if (types_heap[substr(obj, 2)]["len"] == 0) { - return "#nil" - } - return types_addref(obj) - } else if (obj ~ /^\[/) { - obj_idx = substr(obj, 2) - len = types_heap[obj_idx]["len"] - if (len == 0) { return "#nil" } - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i]) - } - types_heap[new_idx]["len"] = len - return "(" new_idx - } else if (obj ~ /^"/) { - obj_idx = substr(obj, 2) - len = length(obj_idx) - if (len == 0) { return "#nil" } - new_idx = types_allocate() - split(obj_idx, chars, "") - for (i = 0; i <= len; ++i) { - types_heap[new_idx][i] = "\"" chars[i+1] - } - types_heap[new_idx]["len"] = len - return "(" new_idx - } else if (obj == "#nil") { - return "#nil" - } else { - return "!\"seq: called on non-sequence" - } -} - - -function core_meta(idx, obj, obj_idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'meta'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - obj = types_heap[idx][1] - if (obj ~ /^[([{$%]/ && "meta" in types_heap[obj_idx = substr(obj, 2)]) { - return types_addref(types_heap[obj_idx]["meta"]) - } - return "#nil" -} - -function core_with_meta(idx, obj, obj_idx, new_idx, i, len) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function 'with-meta'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - obj = types_heap[idx][1] - obj_idx = substr(obj, 2) - new_idx = types_allocate() - types_addref(types_heap[new_idx]["meta"] = types_heap[idx][2]) - switch (obj) { - case /^[([]/: - len = types_heap[obj_idx]["len"] - for (i = 0; i < len; ++i) { - types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i]) - } - types_heap[new_idx]["len"] = len - return substr(obj, 1, 1) new_idx - case /^\{/: - for (i in types_heap[obj_idx]) { - if (i ~ /^[":]/) { - types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i]) - } - } - return "{" new_idx - case /^\$/: - types_addref(types_heap[new_idx]["params"] = types_heap[obj_idx]["params"]) - types_addref(types_heap[new_idx]["body"] = types_heap[obj_idx]["body"]) - env_addref(types_heap[new_idx]["env"] = types_heap[obj_idx]["env"]) - return "$" new_idx - case /^&/: - types_heap[new_idx]["func"] = obj_idx - return "%" new_idx - case /^%/: - types_heap[new_idx]["func"] = types_heap[obj_idx]["func"] - return "%" new_idx - default: - types_release("{" new_idx) - return "!\"Incompatible type for argument 1 of builtin function 'with-meta'. Expects list, vector, hash-map or function, supplied " types_typename(lst) "." - } -} - -function core_atom(idx, atom_idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'atom'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - atom_idx = types_allocate() - types_addref(types_heap[atom_idx]["obj"] = types_heap[idx][1]) - return "?" atom_idx -} - -function core_atomp(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'atom?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return types_heap[idx][1] ~ /^\?/ ? "#true" : "#false" -} - -function core_deref(idx, atom) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'deref'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - atom = types_heap[idx][1] - if (atom !~ /^\?/) { - return "!\"Incompatible type for argument 1 of builtin function 'deref'. Expects atom, supplied " types_typename(atom) "." - } - return types_addref(types_heap[substr(atom, 2)]["obj"]) -} - -function core_reset(idx, atom, atom_idx) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function 'reset!'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - atom = types_heap[idx][1] - if (atom !~ /^\?/) { - return "!\"Incompatible type for argument 1 of builtin function 'reset!'. Expects atom, supplied " types_typename(atom) "." - } - atom_idx = substr(atom, 2) - types_release(types_heap[atom_idx]["obj"]) - return types_addref(types_heap[atom_idx]["obj"] = types_heap[idx][2]) -} - -function core_swap(idx, expr, atom, f, lst_idx, ret, f_idx, env, i, len, atom_idx) -{ - len = types_heap[idx]["len"] - if (len < 3) { - return "!\"Invalid argument length for builtin function 'swap!'. Expects at least 2 arguments, supplied " (len - 1) "." - } - atom = types_heap[idx][1] - if (atom !~ /^\?/) { - return "!\"Incompatible type for argument 1 of builtin function 'swap!'. Expects atom, supplied " types_typename(atom) "." - } - f = types_heap[idx][2] - if (f !~ /^[&$%]/) { - return "!\"Incompatible type for argument 2 of builtin function 'swap!'. Expects function, supplied " types_typename(f) "." - } - lst_idx = types_allocate() - atom_idx = substr(atom, 2) - types_addref(types_heap[lst_idx][0] = f) - types_addref(types_heap[lst_idx][1] = types_heap[atom_idx]["obj"]) - for (i = 3; i < len; ++i) { - types_addref(types_heap[lst_idx][i - 1] = types_heap[idx][i]) - } - types_heap[lst_idx]["len"] = len - 1 - - f_idx = substr(f, 2) - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], lst_idx) - types_release("(" lst_idx) - if (env ~ /^!/) { - return env - } - ret = EVAL(types_addref(types_heap[f_idx]["body"]), env) - env_release(env) - break - case /^%/: - f_idx = types_heap[f_idx]["func"] - case /^&/: - ret = @f_idx(lst_idx) - types_release("(" lst_idx) - break - } - - if (ret ~ /^!/) { - return ret - } - types_release(types_heap[atom_idx]["obj"]) - return types_addref(types_heap[atom_idx]["obj"] = ret) -} - -function core_init() -{ - core_ns["'="] = "&core_eq" - core_ns["'throw"] = "&core_throw" - - core_ns["'nil?"] = "&core_nilp" - core_ns["'true?"] = "&core_truep" - core_ns["'false?"] = "&core_falsep" - core_ns["'string?"] = "&core_stringp" - core_ns["'symbol"] = "&core_symbol" - core_ns["'symbol?"] = "&core_symbolp" - core_ns["'keyword"] = "&core_keyword" - core_ns["'keyword?"] = "&core_keywordp" - core_ns["'number?"] = "&core_numberp" - core_ns["'fn?"] = "&core_fnp" - core_ns["'macro?"] = "&core_macrop" - - core_ns["'pr-str"] = "&core_pr_str" - core_ns["'str"] = "&core_str" - core_ns["'prn"] = "&core_prn" - core_ns["'println"] = "&core_println" - core_ns["'read-string"] = "&core_read_string" - core_ns["'readline"] = "&core_readline" - core_ns["'slurp"] = "&core_slurp" - - core_ns["'<"] = "&core_lt" - core_ns["'<="] = "&core_le" - core_ns["'>"] = "&core_gt" - core_ns["'>="] = "&core_ge" - core_ns["'+"] = "&core_add" - core_ns["'-"] = "&core_subtract" - core_ns["'*"] = "&core_multiply" - core_ns["'/"] = "&core_divide" - core_ns["'time-ms"] = "&core_time_ms" - - core_ns["'list"] = "&core_list" - core_ns["'list?"] = "&core_listp" - core_ns["'vec"] = "&core_vec" - core_ns["'vector"] = "&core_vector" - core_ns["'vector?"] = "&core_vectorp" - core_ns["'hash-map"] = "&core_hash_map" - core_ns["'map?"] = "&core_mapp" - core_ns["'assoc"] = "&core_assoc" - core_ns["'dissoc"] = "&core_dissoc" - core_ns["'get"] = "&core_get" - core_ns["'contains?"] = "&core_containsp" - core_ns["'keys"] = "&core_keys" - core_ns["'vals"] = "&core_vals" - - core_ns["'sequential?"] = "&core_sequentialp" - core_ns["'cons"] = "&core_cons" - core_ns["'concat"] = "&core_concat" - core_ns["'nth"] = "&core_nth" - core_ns["'first"] = "&core_first" - core_ns["'rest"] = "&core_rest" - core_ns["'empty?"] = "&core_emptyp" - core_ns["'count"] = "&core_count" - core_ns["'apply"] = "&core_apply" - core_ns["'map"] = "&core_map" - - core_ns["'conj"] = "&core_conj" - core_ns["'seq"] = "&core_seq" - - core_ns["'meta"] = "&core_meta" - core_ns["'with-meta"] = "&core_with_meta" - core_ns["'atom"] = "&core_atom" - core_ns["'atom?"] = "&core_atomp" - core_ns["'deref"] = "&core_deref" - core_ns["'reset!"] = "&core_reset" - core_ns["'swap!"] = "&core_swap" -} - - - -BEGIN { - core_init() -} +@load "readfile" +@load "time" + +function core_eq_sub(lhs, rhs, i, len) +{ + if (lhs ~ /^[([]/ && rhs ~ /^[([]/) { + lhs = substr(lhs, 2) + rhs = substr(rhs, 2) + len = types_heap[lhs]["len"] + if (len != types_heap[rhs]["len"]) { + return 0 + } + for (i = 0; i < len; ++i) { + if (!core_eq_sub(types_heap[lhs][i], types_heap[rhs][i])) { + return 0 + } + } + return 1 + } else if (lhs ~ /^\{/ && rhs ~ /^\{/) { + lhs = substr(lhs, 2) + rhs = substr(rhs, 2) + if (length(types_heap[lhs]) != length(types_heap[rhs])) { + return 0 + } + for (i in types_heap[lhs]) { + if (types_heap[lhs][i] ~ /^["':+#([{?&$%]/ && + !core_eq_sub(types_heap[lhs][i], types_heap[rhs][i])) { + return 0 + } + } + return 1 + } else { + return lhs == rhs + } +} + +function core_eq(idx) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '='. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + return core_eq_sub(types_heap[idx][1], types_heap[idx][2]) ? "#true" : "#false" +} + +function core_throw(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'throw'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return "!" types_addref(types_heap[idx][1]) +} + + + +function core_nilp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'nil?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] == "#nil" ? "#true" : "#false" +} + +function core_truep(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'true?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] == "#true" ? "#true" : "#false" +} + +function core_falsep(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'false?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] == "#false" ? "#true" : "#false" +} + +function core_stringp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'string?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^"/ ? "#true" : "#false" +} + +function core_symbol(idx, str) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'symbol'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + str = types_heap[idx][1] + if (str !~ /^"/) { + return "!\"Incompatible type for argument 1 of builtin function 'symbol'. Expects string, supplied " types_typename(str) "." + } + return "'" substr(str, 2) +} + +function core_symbolp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'symbol?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^'/ ? "#true" : "#false" +} + +function core_keyword(idx, str) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'keyword'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + str = types_heap[idx][1] + switch (str) { + case /^:/: + return str + case /^"/: + return "::" substr(str, 2) + } + return "!\"Incompatible type for argument 1 of builtin function 'keyword'. Expects string or keyword, supplied " types_typename(str) "." +} + +function core_keywordp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'keyword?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^:/ ? "#true" : "#false" +} + +function core_numberp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'number?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^\+/ ? "#true" : "#false" +} + +function core_fnp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'fn?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + f = types_heap[idx][1] + return f ~ /^[$&%]/ && !types_heap[substr(f, 2)]["is_macro"] ? "#true" : "#false" +} + +function core_macrop(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'macro?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + f = types_heap[idx][1] + return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] ? "#true" : "#false" +} + + + +function core_pr_str(idx, i, len, result) +{ + len = types_heap[idx]["len"] + for (i = 1; i < len; ++i) { + result = result printer_pr_str(types_heap[idx][i], 1) " " + } + return "\"" substr(result, 1, length(result) - 1) +} + +function core_str(idx, i, len, result) +{ + len = types_heap[idx]["len"] + for (i = 1; i < len; ++i) { + result = result printer_pr_str(types_heap[idx][i], 0) + } + return "\"" result +} + +function core_prn(idx, i, len, result) +{ + len = types_heap[idx]["len"] + for (i = 1; i < len; ++i) { + result = result printer_pr_str(types_heap[idx][i], 1) " " + } + print substr(result, 1, length(result) - 1) + return "#nil" +} + +function core_println(idx, i, len, result) +{ + len = types_heap[idx]["len"] + for (i = 1; i < len; ++i) { + result = result printer_pr_str(types_heap[idx][i], 0) " " + } + print substr(result, 1, length(result) - 1) + return "#nil" +} + +function core_read_string(idx, str) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'read-string'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + str = types_heap[idx][1] + if (str !~ /^"/) { + return "!\"Incompatible type for argument 1 of builtin function 'read-string'. Expects string, supplied " types_typename(str) "." + } + return reader_read_str(substr(str, 2)) +} + +function core_readline(idx, prompt, var) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'readline'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + prompt = types_heap[idx][1] + if (prompt !~ /^"/) { + return "!\"Incompatible type for argument 1 of builtin function 'readline'. Expects string, supplied " types_typename(prompt) "." + } + printf("%s", printer_pr_str(prompt, 0)) + return getline var <= 0 ? "#nil" : "\"" var +} + +function core_slurp(idx, filename, str) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'slurp'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + filename = types_heap[idx][1] + if (filename !~ /^"/) { + return "!\"Incompatible type for argument 1 of builtin function 'slurp'. Expects string, supplied " types_typename(filename) "." + } + str = readfile(substr(filename, 2)) + if (str == "" && ERRNO != "") { + return "!\"cannot read file '" filename "', ERRNO = " ERRNO + } + return "\"" str +} + + + +function core_lt(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '<'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '<'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '<'. Expects number, supplied " types_typename(rhs) "." + } + return substr(lhs, 2) + 0 < substr(rhs, 2) + 0 ? "#true" : "#false" +} + +function core_le(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '<='. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '<='. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '<='. Expects number, supplied " types_typename(rhs) "." + } + return substr(lhs, 2) + 0 <= substr(rhs, 2) + 0 ? "#true" : "#false" +} + +function core_gt(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '>'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '>'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '>'. Expects number, supplied " types_typename(rhs) "." + } + return substr(lhs, 2) + 0 > substr(rhs, 2) + 0 ? "#true" : "#false" +} + +function core_ge(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '>='. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '>='. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '>='. Expects number, supplied " types_typename(rhs) "." + } + return substr(lhs, 2) + 0 >= substr(rhs, 2) + 0 ? "#true" : "#false" +} + +function core_add(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '+'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '+'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '+'. Expects number, supplied " types_typename(rhs) "." + } + return "+" (substr(lhs, 2) + substr(rhs, 2)) +} + +function core_subtract(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '-'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '-'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '-'. Expects number, supplied " types_typename(rhs) "." + } + return "+" (substr(lhs, 2) - substr(rhs, 2)) +} + +function core_multiply(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '*'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '*'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '*'. Expects number, supplied " types_typename(rhs) "." + } + return "+" (substr(lhs, 2) * substr(rhs, 2)) +} + +function core_divide(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '/'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '/'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '/'. Expects number, supplied " types_typename(rhs) "." + } + return "+" int(substr(lhs, 2) / substr(rhs, 2)) +} + +function core_time_ms(idx) +{ + if (types_heap[idx]["len"] != 1) { + return "!\"Invalid argument length for builtin function 'time-ms'. Expects no arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + return "+" int(gettimeofday() * 1000) +} + + + +function core_list(idx, new_idx, len, i) +{ + new_idx = types_allocate() + len = types_heap[idx]["len"] + for (i = 1; i < len; ++i) { + types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i]) + } + types_heap[new_idx]["len"] = len - 1 + return "(" new_idx +} + +function core_listp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'list?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^\(/ ? "#true" : "#false" +} + +function core_vector(idx, new_idx, len, i) +{ + new_idx = types_allocate() + len = types_heap[idx]["len"] + for (i = 1; i < len; ++i) { + types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i]) + } + types_heap[new_idx]["len"] = len - 1 + return "[" new_idx +} + +function core_vectorp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'vector?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^\[/ ? "#true" : "#false" +} + +function core_hash_map(idx, len, new_idx, i, key) +{ + len = types_heap[idx]["len"] + if (len % 2 != 1) { + return "!\"Invalid argument length for builtin function 'hash-map'. Expects even number of arguments, supplied " (len - 1) "." + } + new_idx = types_allocate() + for (i = 1; i < len; i += 2) { + key = types_heap[idx][i] + if (key !~ /^[":]/) { + types_release("{" new_idx) + return "!\"Incompatible type for key argument of builtin function 'hash-map'. Expects string or keyword, supplied " types_typename(key) "." + } + if (key in types_heap[new_idx]) { + types_release(types_heap[new_idx][key]) + } + types_addref(types_heap[new_idx][key] = types_heap[idx][i + 1]) + } + return "{" new_idx +} + +function core_mapp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'map?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^\{/ ? "#true" : "#false" +} + +function core_assoc(idx, len, map, i, key, add_list, new_idx, map_idx) +{ + len = types_heap[idx]["len"] + if (len % 2 != 0) { + return "!\"Invalid argument length for builtin function 'assoc'. Expects odd number of arguments, supplied " (len - 1) "." + } + map = types_heap[idx][1] + if (map !~ /^\{/) { + return "!\"Incompatible type for argument 1 of builtin function 'assoc'. Expects hash-map, supplied " types_typename(map) "." + } + for (i = 2; i < len; i += 2) { + key = types_heap[idx][i] + if (key !~ /^[":]/) { + return "!\"Incompatible type for key argument of builtin function 'assoc'. Expects string or keyword, supplied " types_typename(key) "." + } + add_list[key] = types_heap[idx][i + 1] + } + new_idx = types_allocate() + map_idx = substr(map, 2) + for (key in types_heap[map_idx]) { + if (key ~ /^[":]|^meta$/ && !(key in add_list)) { + types_addref(types_heap[new_idx][key] = types_heap[map_idx][key]) + } + } + for (key in add_list) { + types_addref(types_heap[new_idx][key] = add_list[key]) + } + return "{" new_idx +} + +function core_dissoc(idx, len, map, i, key, del_list, new_idx, map_idx) +{ + len = types_heap[idx]["len"] + if (len < 2) { + return "!\"Invalid argument length for builtin function 'dissoc'. Expects at least 1 argument, supplied " (len - 1) "." + } + map = types_heap[idx][1] + if (map !~ /^\{/) { + return "!\"Incompatible type for argument 1 of builtin function 'dissoc'. Expects hash-map, supplied " types_typename(map) "." + } + for (i = 2; i < len; ++i) { + key = types_heap[idx][i] + if (key !~ /^[":]/) { + return "!\"Incompatible type for key argument of builtin function 'dissoc'. Expects string or keyword, supplied " types_typename(key) "." + } + del_list[key] = "1" + } + new_idx = types_allocate() + map_idx = substr(map, 2) + for (key in types_heap[map_idx]) { + if (key ~ /^[":]|^meta$/ && !(key in del_list)) { + types_addref(types_heap[new_idx][key] = types_heap[map_idx][key]) + } + } + return "{" new_idx +} + +function core_get(idx, map, key, map_idx) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function 'get'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + map = types_heap[idx][1] + if (map !~ /^\{/ && map != "#nil") { + return "!\"Incompatible type for argument 1 of builtin function 'get'. Expects hash-map or nil, supplied " types_typename(map) "." + } + key = types_heap[idx][2] + if (key !~ /^[":]/) { + return "!\"Incompatible type for argument 2 of builtin function 'get'. Expects string or keyword, supplied " types_typename(key) "." + } + if (map != "#nil" && key in types_heap[map_idx = substr(map, 2)]) { + return types_addref(types_heap[map_idx][key]) + } else { + return "#nil" + } +} + +function core_containsp(idx, map, key) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function 'contains?'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + map = types_heap[idx][1] + if (map !~ /^\{/) { + return "!\"Incompatible type for argument 1 of builtin function 'contains?'. Expects hash-map, supplied " types_typename(map) "." + } + key = types_heap[idx][2] + if (key !~ /^[":]/) { + return "!\"Incompatible type for argument 2 of builtin function 'contains?'. Expects string or keyword, supplied " types_typename(key) "." + } + return key in types_heap[substr(map, 2)] ? "#true" : "#false" +} + +function core_keys(idx, map, map_idx, new_idx, len, key) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'keys'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + map = types_heap[idx][1] + if (map !~ /^\{/) { + return "!\"Incompatible type for argument 1 of builtin function 'keys'. Expects hash-map, supplied " types_typename(map) "." + } + map_idx = substr(map, 2) + new_idx = types_allocate() + len = 0 + for (key in types_heap[map_idx]) { + if (key ~ /^[":]/) { + types_heap[new_idx][len++] = key + } + } + types_heap[new_idx]["len"] = len + return "(" new_idx +} + +function core_vals(idx, map, map_idx, new_idx, len, key) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'vals'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + map = types_heap[idx][1] + if (map !~ /^\{/) { + return "!\"Incompatible type for argument 1 of builtin function 'vals'. Expects hash-map, supplied " types_typename(map) "." + } + map_idx = substr(map, 2) + new_idx = types_allocate() + len = 0 + for (key in types_heap[map_idx]) { + if (key ~ /^[":]/) { + types_addref(types_heap[new_idx][len++] = types_heap[map_idx][key]) + } + } + types_heap[new_idx]["len"] = len + return "(" new_idx +} + + + +function core_sequentialp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'sequential?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^[([]/ ? "#true" : "#false" +} + +function core_cons(idx, lst, lst_idx, new_idx, len, i) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function 'cons'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lst = types_heap[idx][2] + if (lst !~ /^[([]/) { + return "!\"Incompatible type for argument 1 of builtin function 'cons'. Expects list or vector, supplied " types_typename(lst) "." + } + lst_idx = substr(lst, 2) + new_idx = types_allocate() + types_addref(types_heap[new_idx][0] = types_heap[idx][1]) + len = types_heap[lst_idx]["len"] + for (i = 0; i < len; ++i) { + types_addref(types_heap[new_idx][i + 1] = types_heap[lst_idx][i]) + } + types_heap[new_idx]["len"] = len + 1 + return "(" new_idx +} + +function core_concat(idx, new_idx, new_len, len, i, lst, lst_idx, lst_len, j) +{ + new_idx = types_allocate() + new_len = 0 + len = types_heap[idx]["len"] + for (i = 1; i < len; ++i) { + lst = types_heap[idx][i] + if (lst !~ /^[([]/) { + types_heap[new_idx]["len"] = new_len + types_release("(" new_idx) + return "!\"Incompatible type for argument ' (i - 1) ' of builtin function 'concat'. Expects list or vector, supplied " types_typename(lst) "." + } + lst_idx = substr(lst, 2) + lst_len = types_heap[lst_idx]["len"] + for (j = 0; j < lst_len; ++j) { + types_addref(types_heap[new_idx][new_len++] = types_heap[lst_idx][j]) + } + } + types_heap[new_idx]["len"] = new_len + return "(" new_idx +} + +function core_vec(idx, new_idx, len) +{ + len = types_heap[idx]["len"] + if (len != 2) + return "!\"Invalid argument length for builtin function 'vec'. Expects exactly 1 argument, supplied " (len - 1) "." + idx = types_heap[idx][1] + if (idx !~ /^[([]/) { + return "!\"Incompatible type for argument 1 of builtin function 'vec'. Expects list or vector, supplied " types_typename(idx) "." + } + idx = substr(idx, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + types_heap[new_idx]["len"] = len + while (len--) + types_addref(types_heap[new_idx][len] = types_heap[idx][len]) + return "[" new_idx +} + +function core_nth(idx, lst, num, n, lst_idx) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function 'nth'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lst = types_heap[idx][1] + if (lst !~ /^[([]/) { + return "!\"Incompatible type for argument 1 of builtin function 'nth'. Expects list or vector, supplied " types_typename(lst) "." + } + num = types_heap[idx][2] + if (num !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function 'nth'. Expects number, supplied " types_typename(num) "." + } + n = substr(num, 2) + 0 + lst_idx = substr(lst, 2) + if (n < 0 || types_heap[lst_idx]["len"] <= n) { + return "!\"Index out of range. Sequence length is " types_heap[lst_idx]["len"] ", supplied " n "." + } + return types_addref(types_heap[lst_idx][n]) +} + +function core_first(idx, lst, lst_idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'first'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lst = types_heap[idx][1] + if (lst == "#nil") { + return "#nil" + } + if (lst !~ /^[([]/) { + return "!\"Incompatible type for argument 1 of builtin function 'first'. Expects list, vector or nil, supplied " types_typename(lst) "." + } + lst_idx = substr(lst, 2) + return types_heap[lst_idx]["len"] == 0 ? "#nil" : types_addref(types_heap[lst_idx][0]) +} + +function core_rest(idx, lst, lst_idx, lst_len, new_idx, i) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'rest'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lst = types_heap[idx][1] + if (lst == "#nil") { + new_idx = types_allocate() + types_heap[new_idx]["len"] = 0 + return "(" new_idx + } + if (lst !~ /^[([]/) { + return "!\"Incompatible type for argument 1 of builtin function 'rest'. Expects list, vector or nil, supplied " types_typename(lst) "." + } + lst_idx = substr(lst, 2) + lst_len = types_heap[lst_idx]["len"] + new_idx = types_allocate() + for (i = 1; i < lst_len; ++i) { + types_addref(types_heap[new_idx][i - 1] = types_heap[lst_idx][i]) + } + types_heap[new_idx]["len"] = lst_len - 1 + return "(" new_idx +} + +function core_emptyp(idx, lst) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'empty?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + lst = types_heap[idx][1] + if (lst !~ /^[([]/) { + return "!\"Incompatible type for argument 1 of builtin function 'empty?'. Expects list or vector, supplied " types_typename(lst) "." + } + return types_heap[substr(lst, 2)]["len"] == 0 ? "#true" : "#false" +} + +function core_count(idx, lst) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'count'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + lst = types_heap[idx][1] + if (lst ~ /^[([]/) { + return "+" types_heap[substr(lst, 2)]["len"] + } + if (lst == "#nil") { + return "+0" + } + return "!\"Incompatible type for argument 1 of builtin function 'count'. Expects list, vector or nil, supplied " types_typename(lst) "." +} + +function core_apply(idx, len, f, lst, new_idx, i, lst_idx, lst_len, f_idx, env, ret) +{ + len = types_heap[idx]["len"] + if (len < 3) { + return "!\"Invalid argument length for builtin function 'apply'. Expects at least 2 arguments, supplied " (len - 1) "." + } + f = types_heap[idx][1] + if (f !~ /^[$&%]/) { + return "!\"Incompatible type for argument 1 of builtin function 'apply'. Expects function, supplied " types_typename(f) "." + } + lst = types_heap[idx][len - 1] + if (lst !~ /^[([]/) { + return "!\"Incompatible type for argument ' (len - 1) ' of builtin function 'apply'. Expects list or vector, supplied " types_typename(lst) "." + } + + new_idx = types_allocate() + types_addref(types_heap[new_idx][0] = f) + for (i = 2; i < len - 1; ++i) { + types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i]) + } + lst_idx = substr(lst, 2) + lst_len = types_heap[lst_idx]["len"] + for (i = 0; i < lst_len; ++i) { + types_addref(types_heap[new_idx][len + i - 2] = types_heap[lst_idx][i]) + } + types_heap[new_idx]["len"] = len + lst_len - 2 + + f_idx = substr(f, 2) + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], new_idx) + types_release("(" new_idx) + if (env ~ /^!/) { + return env + } + ret = EVAL(types_addref(types_heap[f_idx]["body"]), env) + env_release(env) + return ret + case /^%/: + f_idx = types_heap[f_idx]["func"] + case /^&/: + ret = @f_idx(new_idx) + types_release("(" new_idx) + return ret + } +} + +function core_map(idx, f, lst, f_idx, lst_idx, lst_len, new_idx, expr_idx, i, env, ret, val) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function 'map'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + f = types_heap[idx][1] + if (f !~ /^[$&%]/) { + return "!\"Incompatible type for argument 1 of builtin function 'map'. Expects function, supplied " types_typename(f) "." + } + lst = types_heap[idx][2] + if (lst !~ /^[([]/) { + return "!\"Incompatible type for argument 2 of builtin function 'map'. Expects list or vector, supplied " types_typename(lst) "." + } + f_idx = substr(f, 2) + lst_idx = substr(lst, 2) + lst_len = types_heap[lst_idx]["len"] + new_idx = types_allocate() + types_heap[new_idx][0] = f + types_heap[new_idx]["len"] = 2 + expr_idx = types_allocate() + for (i = 0; i < lst_len; ++i) { + types_heap[new_idx][1] = types_heap[lst_idx][i] + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], new_idx) + if (env ~ /^!/) { + types_heap[expr_idx]["len"] = i + types_heap[new_idx]["len"] = 0 + types_release("(" expr_idx) + types_release("(" new_idx) + return env + } + ret = EVAL(types_addref(types_heap[f_idx]["body"]), env) + env_release(env) + break + case /^%/: + f_idx = types_heap[f_idx]["func"] + case /^&/: + ret = @f_idx(new_idx) + break + } + if (ret ~ /^!/) { + types_heap[expr_idx]["len"] = i + types_heap[new_idx]["len"] = 0 + types_release("(" expr_idx) + types_release("(" new_idx) + return ret + } + types_heap[expr_idx][i] = ret + } + types_heap[expr_idx]["len"] = lst_len + types_heap[new_idx]["len"] = 0 + types_release("(" new_idx) + return "(" expr_idx +} + + + +function core_conj(idx, len, lst, lst_idx, lst_len, new_idx, i, j) +{ + len = types_heap[idx]["len"] + if (len < 3) { + return "!\"Invalid argument length for builtin function 'conj'. Expects at least 2 arguments, supplied " (len - 1) "." + } + lst = types_heap[idx][1] + if (lst !~ /^[([]/) { + return "!\"Incompatible type for argument 1 of builtin function 'conj'. Expects list or vector, supplied " types_typename(lst) "." + } + lst_idx = substr(lst, 2) + lst_len = types_heap[lst_idx]["len"] + new_idx = types_allocate() + j = 0 + if (lst ~ /^\(/) { + for (i = len - 1; i >= 2; --i) { + types_addref(types_heap[new_idx][j++] = types_heap[idx][i]) + } + for (i = 0; i < lst_len; ++i) { + types_addref(types_heap[new_idx][j++] = types_heap[lst_idx][i]) + } + } else { + for (i = 0; i < lst_len; ++i) { + types_addref(types_heap[new_idx][j++] = types_heap[lst_idx][i]) + } + for (i = 2; i < len; ++i) { + types_addref(types_heap[new_idx][j++] = types_heap[idx][i]) + } + } + types_addref(types_heap[new_idx]["meta"] = types_heap[lst_idx]["meta"]) + types_heap[new_idx]["len"] = j + return substr(lst, 1, 1) new_idx +} + +function core_seq(idx, obj, obj_idx, new_idx, i, len, chars) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'seq'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + obj = types_heap[idx][1] + if (obj ~ /^[(]/) { + if (types_heap[substr(obj, 2)]["len"] == 0) { + return "#nil" + } + return types_addref(obj) + } else if (obj ~ /^\[/) { + obj_idx = substr(obj, 2) + len = types_heap[obj_idx]["len"] + if (len == 0) { return "#nil" } + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i]) + } + types_heap[new_idx]["len"] = len + return "(" new_idx + } else if (obj ~ /^"/) { + obj_idx = substr(obj, 2) + len = length(obj_idx) + if (len == 0) { return "#nil" } + new_idx = types_allocate() + split(obj_idx, chars, "") + for (i = 0; i <= len; ++i) { + types_heap[new_idx][i] = "\"" chars[i+1] + } + types_heap[new_idx]["len"] = len + return "(" new_idx + } else if (obj == "#nil") { + return "#nil" + } else { + return "!\"seq: called on non-sequence" + } +} + + +function core_meta(idx, obj, obj_idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'meta'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + obj = types_heap[idx][1] + if (obj ~ /^[([{$%]/ && "meta" in types_heap[obj_idx = substr(obj, 2)]) { + return types_addref(types_heap[obj_idx]["meta"]) + } + return "#nil" +} + +function core_with_meta(idx, obj, obj_idx, new_idx, i, len) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function 'with-meta'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + obj = types_heap[idx][1] + obj_idx = substr(obj, 2) + new_idx = types_allocate() + types_addref(types_heap[new_idx]["meta"] = types_heap[idx][2]) + switch (obj) { + case /^[([]/: + len = types_heap[obj_idx]["len"] + for (i = 0; i < len; ++i) { + types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i]) + } + types_heap[new_idx]["len"] = len + return substr(obj, 1, 1) new_idx + case /^\{/: + for (i in types_heap[obj_idx]) { + if (i ~ /^[":]/) { + types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i]) + } + } + return "{" new_idx + case /^\$/: + types_addref(types_heap[new_idx]["params"] = types_heap[obj_idx]["params"]) + types_addref(types_heap[new_idx]["body"] = types_heap[obj_idx]["body"]) + env_addref(types_heap[new_idx]["env"] = types_heap[obj_idx]["env"]) + return "$" new_idx + case /^&/: + types_heap[new_idx]["func"] = obj_idx + return "%" new_idx + case /^%/: + types_heap[new_idx]["func"] = types_heap[obj_idx]["func"] + return "%" new_idx + default: + types_release("{" new_idx) + return "!\"Incompatible type for argument 1 of builtin function 'with-meta'. Expects list, vector, hash-map or function, supplied " types_typename(lst) "." + } +} + +function core_atom(idx, atom_idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'atom'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + atom_idx = types_allocate() + types_addref(types_heap[atom_idx]["obj"] = types_heap[idx][1]) + return "?" atom_idx +} + +function core_atomp(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'atom?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return types_heap[idx][1] ~ /^\?/ ? "#true" : "#false" +} + +function core_deref(idx, atom) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'deref'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + atom = types_heap[idx][1] + if (atom !~ /^\?/) { + return "!\"Incompatible type for argument 1 of builtin function 'deref'. Expects atom, supplied " types_typename(atom) "." + } + return types_addref(types_heap[substr(atom, 2)]["obj"]) +} + +function core_reset(idx, atom, atom_idx) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function 'reset!'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + atom = types_heap[idx][1] + if (atom !~ /^\?/) { + return "!\"Incompatible type for argument 1 of builtin function 'reset!'. Expects atom, supplied " types_typename(atom) "." + } + atom_idx = substr(atom, 2) + types_release(types_heap[atom_idx]["obj"]) + return types_addref(types_heap[atom_idx]["obj"] = types_heap[idx][2]) +} + +function core_swap(idx, expr, atom, f, lst_idx, ret, f_idx, env, i, len, atom_idx) +{ + len = types_heap[idx]["len"] + if (len < 3) { + return "!\"Invalid argument length for builtin function 'swap!'. Expects at least 2 arguments, supplied " (len - 1) "." + } + atom = types_heap[idx][1] + if (atom !~ /^\?/) { + return "!\"Incompatible type for argument 1 of builtin function 'swap!'. Expects atom, supplied " types_typename(atom) "." + } + f = types_heap[idx][2] + if (f !~ /^[&$%]/) { + return "!\"Incompatible type for argument 2 of builtin function 'swap!'. Expects function, supplied " types_typename(f) "." + } + lst_idx = types_allocate() + atom_idx = substr(atom, 2) + types_addref(types_heap[lst_idx][0] = f) + types_addref(types_heap[lst_idx][1] = types_heap[atom_idx]["obj"]) + for (i = 3; i < len; ++i) { + types_addref(types_heap[lst_idx][i - 1] = types_heap[idx][i]) + } + types_heap[lst_idx]["len"] = len - 1 + + f_idx = substr(f, 2) + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], lst_idx) + types_release("(" lst_idx) + if (env ~ /^!/) { + return env + } + ret = EVAL(types_addref(types_heap[f_idx]["body"]), env) + env_release(env) + break + case /^%/: + f_idx = types_heap[f_idx]["func"] + case /^&/: + ret = @f_idx(lst_idx) + types_release("(" lst_idx) + break + } + + if (ret ~ /^!/) { + return ret + } + types_release(types_heap[atom_idx]["obj"]) + return types_addref(types_heap[atom_idx]["obj"] = ret) +} + +function core_init() +{ + core_ns["'="] = "&core_eq" + core_ns["'throw"] = "&core_throw" + + core_ns["'nil?"] = "&core_nilp" + core_ns["'true?"] = "&core_truep" + core_ns["'false?"] = "&core_falsep" + core_ns["'string?"] = "&core_stringp" + core_ns["'symbol"] = "&core_symbol" + core_ns["'symbol?"] = "&core_symbolp" + core_ns["'keyword"] = "&core_keyword" + core_ns["'keyword?"] = "&core_keywordp" + core_ns["'number?"] = "&core_numberp" + core_ns["'fn?"] = "&core_fnp" + core_ns["'macro?"] = "&core_macrop" + + core_ns["'pr-str"] = "&core_pr_str" + core_ns["'str"] = "&core_str" + core_ns["'prn"] = "&core_prn" + core_ns["'println"] = "&core_println" + core_ns["'read-string"] = "&core_read_string" + core_ns["'readline"] = "&core_readline" + core_ns["'slurp"] = "&core_slurp" + + core_ns["'<"] = "&core_lt" + core_ns["'<="] = "&core_le" + core_ns["'>"] = "&core_gt" + core_ns["'>="] = "&core_ge" + core_ns["'+"] = "&core_add" + core_ns["'-"] = "&core_subtract" + core_ns["'*"] = "&core_multiply" + core_ns["'/"] = "&core_divide" + core_ns["'time-ms"] = "&core_time_ms" + + core_ns["'list"] = "&core_list" + core_ns["'list?"] = "&core_listp" + core_ns["'vec"] = "&core_vec" + core_ns["'vector"] = "&core_vector" + core_ns["'vector?"] = "&core_vectorp" + core_ns["'hash-map"] = "&core_hash_map" + core_ns["'map?"] = "&core_mapp" + core_ns["'assoc"] = "&core_assoc" + core_ns["'dissoc"] = "&core_dissoc" + core_ns["'get"] = "&core_get" + core_ns["'contains?"] = "&core_containsp" + core_ns["'keys"] = "&core_keys" + core_ns["'vals"] = "&core_vals" + + core_ns["'sequential?"] = "&core_sequentialp" + core_ns["'cons"] = "&core_cons" + core_ns["'concat"] = "&core_concat" + core_ns["'nth"] = "&core_nth" + core_ns["'first"] = "&core_first" + core_ns["'rest"] = "&core_rest" + core_ns["'empty?"] = "&core_emptyp" + core_ns["'count"] = "&core_count" + core_ns["'apply"] = "&core_apply" + core_ns["'map"] = "&core_map" + + core_ns["'conj"] = "&core_conj" + core_ns["'seq"] = "&core_seq" + + core_ns["'meta"] = "&core_meta" + core_ns["'with-meta"] = "&core_with_meta" + core_ns["'atom"] = "&core_atom" + core_ns["'atom?"] = "&core_atomp" + core_ns["'deref"] = "&core_deref" + core_ns["'reset!"] = "&core_reset" + core_ns["'swap!"] = "&core_swap" +} + + + +BEGIN { + core_init() +} diff --git a/impls/awk/env.awk b/impls/awk/env.awk index 078f4558a4..cc39da73d5 100644 --- a/impls/awk/env.awk +++ b/impls/awk/env.awk @@ -1,126 +1,126 @@ -function env_new(outer, params, args, idx, len, i, j, lst, param) -{ - if (params != "") { - params = substr(params, 2) - len = types_heap[params]["len"] - if (len >= 2 && types_heap[params][len - 2] == "'&") { - if (types_heap[args]["len"] < len - 1) { - return "!\"Invalid argument length for the function. Expects at least " (len - 2) " arguments, supplied " (types_heap[args]["len"] - 1) "." - } - } else { - if (types_heap[args]["len"] != len + 1) { - return "!\"Invalid argument length for the function. Expects exactly " len " arguments, supplied " (types_heap[args]["len"] - 1) "." - } - } - } - env_heap[env_heap_index]["ref"] = 1 - env_heap[env_heap_index]["outer"] = outer - if (params != "") { - for (i = 0; i < len; ++i) { - param = types_heap[params][i] - if (param == "'&") { - idx = types_allocate() - env_set(env_heap_index, types_heap[params][++i], "(" idx) - len = types_heap[args]["len"] - for (j = 0; i < len; ++j) { - types_addref(types_heap[idx][j] = types_heap[args][i++]) - } - types_heap[idx]["len"] = j - break - } - env_set(env_heap_index, param, types_heap[args][i + 1]) - types_addref(types_heap[args][i + 1]) - } - } - if (outer != "") { - env_addref(outer) - } - return env_heap_index++ -} - -function env_set(env, key, val) -{ - if (key in env_heap[env]) { - types_release(env_heap[env][key]) - } - if (val ~ /^\&/) { - env_builtinnames[substr(val, 2)] = substr(key, 2) - } - env_heap[env][key] = val -} - -function env_find(env, key) -{ - while (env != "") { - if (key in env_heap[env]) { - return env - } - env = env_heap[env]["outer"] - } - return env -} - -function env_get(env, key) -{ - env = env_find(env, key) - if (env != "") { - return env_heap[env][key] - } - return "!\"'" substr(key, 2) "' not found" -} - -function env_addref(env) -{ - env_heap[env]["ref"]++ -} - -function env_release(env, i, outer) -{ - while (env != "" && --env_heap[env]["ref"] == 0) { - for (i in env_heap[env]) { - if (i ~ /^'/) { - types_release(env_heap[env][i]) - } - } - outer = env_heap[env]["outer"] - delete env_heap[env] - env = outer - } -} - -function env_dump(i, j) -{ - for (i = 0; i < env_heap_index; i++) { - if (i in env_heap) { - if (isarray(env_heap[i])) { - if (!("checked" in env_heap[i]) || env_heap[i]["checked"] != env_heap[i]["ref"]) { - for (j in env_heap[i]) { - print " env_heap[" i "][" j "] = " env_heap[i][j] - } - } - } else { - print " env_heap[" i "] = " env_heap[i] - } - } - } -} - -function env_check(env, i, outer) -{ - if (env_heap[env]["checked"]++) { - return - } - for (i in env_heap[env]) { - if (i != "ref" && i != "outer") { - types_check(env_heap[env][i]) - } - } - outer = env_heap[env]["outer"] - if (outer in env_heap) { - env_check(outer) - } -} - -BEGIN { - env_heap_index = 0 -} +function env_new(outer, params, args, idx, len, i, j, lst, param) +{ + if (params != "") { + params = substr(params, 2) + len = types_heap[params]["len"] + if (len >= 2 && types_heap[params][len - 2] == "'&") { + if (types_heap[args]["len"] < len - 1) { + return "!\"Invalid argument length for the function. Expects at least " (len - 2) " arguments, supplied " (types_heap[args]["len"] - 1) "." + } + } else { + if (types_heap[args]["len"] != len + 1) { + return "!\"Invalid argument length for the function. Expects exactly " len " arguments, supplied " (types_heap[args]["len"] - 1) "." + } + } + } + env_heap[env_heap_index]["ref"] = 1 + env_heap[env_heap_index]["outer"] = outer + if (params != "") { + for (i = 0; i < len; ++i) { + param = types_heap[params][i] + if (param == "'&") { + idx = types_allocate() + env_set(env_heap_index, types_heap[params][++i], "(" idx) + len = types_heap[args]["len"] + for (j = 0; i < len; ++j) { + types_addref(types_heap[idx][j] = types_heap[args][i++]) + } + types_heap[idx]["len"] = j + break + } + env_set(env_heap_index, param, types_heap[args][i + 1]) + types_addref(types_heap[args][i + 1]) + } + } + if (outer != "") { + env_addref(outer) + } + return env_heap_index++ +} + +function env_set(env, key, val) +{ + if (key in env_heap[env]) { + types_release(env_heap[env][key]) + } + if (val ~ /^\&/) { + env_builtinnames[substr(val, 2)] = substr(key, 2) + } + env_heap[env][key] = val +} + +function env_find(env, key) +{ + while (env != "") { + if (key in env_heap[env]) { + return env + } + env = env_heap[env]["outer"] + } + return env +} + +function env_get(env, key) +{ + env = env_find(env, key) + if (env != "") { + return env_heap[env][key] + } + return "!\"'" substr(key, 2) "' not found" +} + +function env_addref(env) +{ + env_heap[env]["ref"]++ +} + +function env_release(env, i, outer) +{ + while (env != "" && --env_heap[env]["ref"] == 0) { + for (i in env_heap[env]) { + if (i ~ /^'/) { + types_release(env_heap[env][i]) + } + } + outer = env_heap[env]["outer"] + delete env_heap[env] + env = outer + } +} + +function env_dump(i, j) +{ + for (i = 0; i < env_heap_index; i++) { + if (i in env_heap) { + if (isarray(env_heap[i])) { + if (!("checked" in env_heap[i]) || env_heap[i]["checked"] != env_heap[i]["ref"]) { + for (j in env_heap[i]) { + print " env_heap[" i "][" j "] = " env_heap[i][j] + } + } + } else { + print " env_heap[" i "] = " env_heap[i] + } + } + } +} + +function env_check(env, i, outer) +{ + if (env_heap[env]["checked"]++) { + return + } + for (i in env_heap[env]) { + if (i != "ref" && i != "outer") { + types_check(env_heap[env][i]) + } + } + outer = env_heap[env]["outer"] + if (outer in env_heap) { + env_check(outer) + } +} + +BEGIN { + env_heap_index = 0 +} diff --git a/impls/awk/printer.awk b/impls/awk/printer.awk index f8f62d7726..5486ff7005 100644 --- a/impls/awk/printer.awk +++ b/impls/awk/printer.awk @@ -1,63 +1,63 @@ -function printer_pr_list(expr, print_readably, idx, len, i, str) -{ - idx = substr(expr, 2) - len = types_heap[idx]["len"] - for (i = 0; i < len; ++i) { - str = str printer_pr_str(types_heap[idx][i], print_readably) " " - } - return substr(str, 1, length(str) - 1) -} - -function printer_pr_hash(expr, print_readably, idx, var, str) -{ - idx = substr(expr, 2) - for (var in types_heap[idx]) { - switch (var) { - case /^"/: - str = str printer_pr_string(var, print_readably) " " printer_pr_str(types_heap[idx][var], print_readably) " " - break - case /^:/: - str = str substr(var, 2) " " printer_pr_str(types_heap[idx][var], print_readably) " " - break - } - } - return substr(str, 1, length(str) - 1) -} - -function printer_pr_string(expr, print_readably, v, r) -{ - if (!print_readably) { - return substr(expr, 2) - } - expr = substr(expr, 2) - while (match(expr, /["\n\\]/, r)) { - v = v substr(expr, 1, RSTART - 1) (r[0] == "\n" ? "\\n" : "\\" r[0]) - expr = substr(expr, RSTART + RLENGTH) - } - return "\"" v expr "\"" -} - -function printer_pr_str(expr, print_readably, var) -{ - switch (expr) { - case /^\(/: - return "(" printer_pr_list(expr, print_readably) ")" - case /^\[/: - return "[" printer_pr_list(expr, print_readably) "]" - case /^\{/: - return "{" printer_pr_hash(expr, print_readably) "}" - case /^"/: - return printer_pr_string(expr, print_readably) - case /^\$/: - var = substr(expr, 2) - return "# (fn* " printer_pr_str(types_heap[var]["params"], print_readably) " " printer_pr_str(types_heap[var]["body"], print_readably) ")" - case /^&/: - return "#" - case /^%/: - return "#" - case /^\?/: - return "(atom " printer_pr_str(types_heap[substr(expr, 2)]["obj"], print_readably) ")" - default: - return substr(expr, 2) - } -} +function printer_pr_list(expr, print_readably, idx, len, i, str) +{ + idx = substr(expr, 2) + len = types_heap[idx]["len"] + for (i = 0; i < len; ++i) { + str = str printer_pr_str(types_heap[idx][i], print_readably) " " + } + return substr(str, 1, length(str) - 1) +} + +function printer_pr_hash(expr, print_readably, idx, var, str) +{ + idx = substr(expr, 2) + for (var in types_heap[idx]) { + switch (var) { + case /^"/: + str = str printer_pr_string(var, print_readably) " " printer_pr_str(types_heap[idx][var], print_readably) " " + break + case /^:/: + str = str substr(var, 2) " " printer_pr_str(types_heap[idx][var], print_readably) " " + break + } + } + return substr(str, 1, length(str) - 1) +} + +function printer_pr_string(expr, print_readably, v, r) +{ + if (!print_readably) { + return substr(expr, 2) + } + expr = substr(expr, 2) + while (match(expr, /["\n\\]/, r)) { + v = v substr(expr, 1, RSTART - 1) (r[0] == "\n" ? "\\n" : "\\" r[0]) + expr = substr(expr, RSTART + RLENGTH) + } + return "\"" v expr "\"" +} + +function printer_pr_str(expr, print_readably, var) +{ + switch (expr) { + case /^\(/: + return "(" printer_pr_list(expr, print_readably) ")" + case /^\[/: + return "[" printer_pr_list(expr, print_readably) "]" + case /^\{/: + return "{" printer_pr_hash(expr, print_readably) "}" + case /^"/: + return printer_pr_string(expr, print_readably) + case /^\$/: + var = substr(expr, 2) + return "# (fn* " printer_pr_str(types_heap[var]["params"], print_readably) " " printer_pr_str(types_heap[var]["body"], print_readably) ")" + case /^&/: + return "#" + case /^%/: + return "#" + case /^\?/: + return "(atom " printer_pr_str(types_heap[substr(expr, 2)]["obj"], print_readably) ")" + default: + return substr(expr, 2) + } +} diff --git a/impls/awk/reader.awk b/impls/awk/reader.awk index 31e51ab6bb..709a5ffdcc 100644 --- a/impls/awk/reader.awk +++ b/impls/awk/reader.awk @@ -1,185 +1,185 @@ -function reader_read_string(token, v, r) -{ - token = substr(token, 1, length(token) - 1) - gsub(/\\\\/, "\xf7", token) - gsub(/\\"/, "\"", token) - gsub(/\\n/, "\n", token) - gsub("\xf7", "\\", token) - return token -} - -function reader_read_atom(token) -{ - switch (token) { - case "true": - case "false": - case "nil": - return "#" token - case /^:/: - return ":" token - case /^"/: - if (token ~ /^\"(\\.|[^\\"])*\"$/) { - return reader_read_string(token) - } else { - return "!\"Expected '\"', got EOF." - } - case /^-?[0-9]+$/: - return "+" token - default: - return "'" token - } -} - -function reader_read_list(reader, type, end, idx, len, ret) -{ - idx = types_allocate() - len = 0 - while (reader["curidx"] in reader) { - if (reader[reader["curidx"]] == end) { - types_heap[idx]["len"] = len - reader["curidx"]++ - return type idx - } - ret = reader_read_from(reader) - if (ret ~ /^!/) { - types_heap[idx]["len"] = len - types_release(type idx) - return ret - } - types_heap[idx][len++] = ret - } - types_heap[idx]["len"] = len - types_release(type idx) - return "!\"expected '" end "', got EOF" -} - -function reader_read_hash(reader, idx, key, val) -{ - idx = types_allocate() - while (reader["curidx"] in reader) { - if (reader[reader["curidx"]] == "}") { - reader["curidx"]++ - return "{" idx - } - key = reader_read_from(reader) - if (key ~ /^!/) { - types_release("{" idx) - return key - } - if (key !~ /^[":]/) { - types_release(key) - types_release("{" idx) - return "!\"Hash-map key must be string or keyword." - } - if (!(reader["curidx"] in reader)) { - types_release("{" idx) - return "!\"Element count of hash-map must be even." - } - val = reader_read_from(reader) - if (val ~ /^!/) { - types_release("{" idx) - return val - } - types_heap[idx][key] = val - } - types_release("{" idx) - return "!\"expected '}', got EOF" -} - -function reader_read_abbrev(reader, symbol, val, idx) -{ - val = reader_read_from(reader) - if (val ~ /^!/) { - return val - } - idx = types_allocate() - types_heap[idx]["len"] = 2 - types_heap[idx][0] = symbol - types_heap[idx][1] = val - return "(" idx -} - -function reader_read_with_meta(reader, meta, val, idx) -{ - meta = reader_read_from(reader) - if (meta ~ /^!/) { - return meta - } - val = reader_read_from(reader) - if (val ~ /^!/) { - types_release(meta) - return val - } - idx = types_allocate() - types_heap[idx]["len"] = 3 - types_heap[idx][0] = "'with-meta" - types_heap[idx][1] = val - types_heap[idx][2] = meta - return "(" idx -} - -function reader_read_from(reader, current) -{ - current = reader[reader["curidx"]++] - switch (current) { - case "(": - return reader_read_list(reader, "(", ")") - case "[": - return reader_read_list(reader, "[", "]") - case "{": - return reader_read_hash(reader) - case ")": - case "]": - case "}": - return "!\"Unexpected token '" current "'." - case "'": - return reader_read_abbrev(reader, "'quote") - case "`": - return reader_read_abbrev(reader, "'quasiquote") - case "~": - return reader_read_abbrev(reader, "'unquote") - case "~@": - return reader_read_abbrev(reader, "'splice-unquote") - case "@": - return reader_read_abbrev(reader, "'deref") - case "^": - return reader_read_with_meta(reader) - default: - return reader_read_atom(current) - } -} - -function reader_tokenizer(str, reader, len, r) -{ - for (len = 0; match(str, /^[ \t\r\n,]*(~@|[\[\]{}()'`~^@]|\"(\\.|[^\\"])*\"?|;[^\r\n]*|[^ \t\r\n\[\]{}('"`,;)^~@][^ \t\r\n\[\]{}('"`,;)]*)/, r); ) { - if (substr(r[1], 1, 1) != ";") { - reader[len++] = r[1] - } - str = substr(str, RSTART + RLENGTH) - } - if (str !~ /^[ \t\r\n,]*$/) { - return "!\"Cannot tokenize '" str "'." - } - reader["len"] = len - return "" -} - -function reader_read_str(str, reader, ret) -{ - ret = reader_tokenizer(str, reader) - if (ret != "") { - return ret - } - if (reader["len"] == 0) { - return "#nil" - } - ret = reader_read_from(reader) - if (ret ~ /^!/) { - return ret - } - if (reader["len"] != reader["curidx"]) { - types_release(ret) - return "!\"Unexpected token '" reader[reader["curidx"]] "'." - } - return ret -} +function reader_read_string(token, v, r) +{ + token = substr(token, 1, length(token) - 1) + gsub(/\\\\/, "\xf7", token) + gsub(/\\"/, "\"", token) + gsub(/\\n/, "\n", token) + gsub("\xf7", "\\", token) + return token +} + +function reader_read_atom(token) +{ + switch (token) { + case "true": + case "false": + case "nil": + return "#" token + case /^:/: + return ":" token + case /^"/: + if (token ~ /^\"(\\.|[^\\"])*\"$/) { + return reader_read_string(token) + } else { + return "!\"Expected '\"', got EOF." + } + case /^-?[0-9]+$/: + return "+" token + default: + return "'" token + } +} + +function reader_read_list(reader, type, end, idx, len, ret) +{ + idx = types_allocate() + len = 0 + while (reader["curidx"] in reader) { + if (reader[reader["curidx"]] == end) { + types_heap[idx]["len"] = len + reader["curidx"]++ + return type idx + } + ret = reader_read_from(reader) + if (ret ~ /^!/) { + types_heap[idx]["len"] = len + types_release(type idx) + return ret + } + types_heap[idx][len++] = ret + } + types_heap[idx]["len"] = len + types_release(type idx) + return "!\"expected '" end "', got EOF" +} + +function reader_read_hash(reader, idx, key, val) +{ + idx = types_allocate() + while (reader["curidx"] in reader) { + if (reader[reader["curidx"]] == "}") { + reader["curidx"]++ + return "{" idx + } + key = reader_read_from(reader) + if (key ~ /^!/) { + types_release("{" idx) + return key + } + if (key !~ /^[":]/) { + types_release(key) + types_release("{" idx) + return "!\"Hash-map key must be string or keyword." + } + if (!(reader["curidx"] in reader)) { + types_release("{" idx) + return "!\"Element count of hash-map must be even." + } + val = reader_read_from(reader) + if (val ~ /^!/) { + types_release("{" idx) + return val + } + types_heap[idx][key] = val + } + types_release("{" idx) + return "!\"expected '}', got EOF" +} + +function reader_read_abbrev(reader, symbol, val, idx) +{ + val = reader_read_from(reader) + if (val ~ /^!/) { + return val + } + idx = types_allocate() + types_heap[idx]["len"] = 2 + types_heap[idx][0] = symbol + types_heap[idx][1] = val + return "(" idx +} + +function reader_read_with_meta(reader, meta, val, idx) +{ + meta = reader_read_from(reader) + if (meta ~ /^!/) { + return meta + } + val = reader_read_from(reader) + if (val ~ /^!/) { + types_release(meta) + return val + } + idx = types_allocate() + types_heap[idx]["len"] = 3 + types_heap[idx][0] = "'with-meta" + types_heap[idx][1] = val + types_heap[idx][2] = meta + return "(" idx +} + +function reader_read_from(reader, current) +{ + current = reader[reader["curidx"]++] + switch (current) { + case "(": + return reader_read_list(reader, "(", ")") + case "[": + return reader_read_list(reader, "[", "]") + case "{": + return reader_read_hash(reader) + case ")": + case "]": + case "}": + return "!\"Unexpected token '" current "'." + case "'": + return reader_read_abbrev(reader, "'quote") + case "`": + return reader_read_abbrev(reader, "'quasiquote") + case "~": + return reader_read_abbrev(reader, "'unquote") + case "~@": + return reader_read_abbrev(reader, "'splice-unquote") + case "@": + return reader_read_abbrev(reader, "'deref") + case "^": + return reader_read_with_meta(reader) + default: + return reader_read_atom(current) + } +} + +function reader_tokenizer(str, reader, len, r) +{ + for (len = 0; match(str, /^[ \t\r\n,]*(~@|[\[\]{}()'`~^@]|\"(\\.|[^\\"])*\"?|;[^\r\n]*|[^ \t\r\n\[\]{}('"`,;)^~@][^ \t\r\n\[\]{}('"`,;)]*)/, r); ) { + if (substr(r[1], 1, 1) != ";") { + reader[len++] = r[1] + } + str = substr(str, RSTART + RLENGTH) + } + if (str !~ /^[ \t\r\n,]*$/) { + return "!\"Cannot tokenize '" str "'." + } + reader["len"] = len + return "" +} + +function reader_read_str(str, reader, ret) +{ + ret = reader_tokenizer(str, reader) + if (ret != "") { + return ret + } + if (reader["len"] == 0) { + return "#nil" + } + ret = reader_read_from(reader) + if (ret ~ /^!/) { + return ret + } + if (reader["len"] != reader["curidx"]) { + types_release(ret) + return "!\"Unexpected token '" reader[reader["curidx"]] "'." + } + return ret +} diff --git a/impls/awk/run b/impls/awk/run index 72be264a5c..b67dc453ed 100755 --- a/impls/awk/run +++ b/impls/awk/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec awk -O -f $(dirname $0)/${STEP:-stepA_mal}.awk "${@}" +#!/bin/bash +exec awk -O -f $(dirname $0)/${STEP:-stepA_mal}.awk "${@}" diff --git a/impls/awk/step0_repl.awk b/impls/awk/step0_repl.awk index bb731fd7ee..853e212621 100644 --- a/impls/awk/step0_repl.awk +++ b/impls/awk/step0_repl.awk @@ -1,35 +1,35 @@ -function READ(str) -{ - return str -} - -function EVAL(ast) -{ - return ast -} - -function PRINT(expr) -{ - return expr -} - -function rep(str) -{ - return PRINT(EVAL(READ(str))) -} - -function main(str) -{ - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - print rep(str) - } -} - -BEGIN { - main() - exit(0) -} +function READ(str) +{ + return str +} + +function EVAL(ast) +{ + return ast +} + +function PRINT(expr) +{ + return expr +} + +function rep(str) +{ + return PRINT(EVAL(READ(str))) +} + +function main(str) +{ + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + print rep(str) + } +} + +BEGIN { + main() + exit(0) +} diff --git a/impls/awk/step1_read_print.awk b/impls/awk/step1_read_print.awk index a3cdfc7504..1728a95ff6 100644 --- a/impls/awk/step1_read_print.awk +++ b/impls/awk/step1_read_print.awk @@ -1,52 +1,52 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -function EVAL(ast) -{ - return ast -} - -function PRINT(expr) -{ - return printer_pr_str(expr, 1) -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function main(str, ret) -{ - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +function EVAL(ast) +{ + return ast +} + +function PRINT(expr) +{ + return printer_pr_str(expr, 1) +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function main(str, ret) +{ + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + exit(0) +} diff --git a/impls/awk/step2_eval.awk b/impls/awk/step2_eval.awk index 145a7cf44c..8945aae1a0 100644 --- a/impls/awk/step2_eval.awk +++ b/impls/awk/step2_eval.awk @@ -1,193 +1,193 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -function eval_ast(ast, env, i, idx, len, new_idx, ret) -{ - switch (ast) { - case /^'/: - if (ast in env) { - return types_addref(env[ast]) - } - return "!\"'" substr(ast, 2) "' not found" - case /^[([]/: - idx = substr(ast, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_heap[new_idx]["len"] = i - types_release(substr(ast, 1, 1) new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - types_heap[new_idx]["len"] = len - return substr(ast, 1, 1) new_idx - case /^\{/: - idx = substr(ast, 2) - new_idx = types_allocate() - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release("{" new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - } - return "{" new_idx - default: - return ast - } -} - -function EVAL(ast, env, new_ast, ret, idx, f, f_idx) -{ - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - return ret - } - idx = substr(ast, 2) - if (types_heap[idx]["len"] == 0) { - return ast - } - new_ast = eval_ast(ast, env) - types_release(ast) - if (new_ast ~ /^!/) { - return new_ast - } - idx = substr(new_ast, 2) - f = types_heap[idx][0] - if (f ~ /^&/) { - f_idx = substr(f, 2) - ret = @f_idx(idx) - types_release(new_ast) - return ret - } else { - types_release(new_ast) - return "!\"First element of list must be function, supplied " types_typename(f) "." - } -} - -function PRINT(expr, str) -{ - str = printer_pr_str(expr, 1) - types_release(expr) - return str -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast, repl_env) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function add(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '+'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '+'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '+'. Expects number, supplied " types_typename(rhs) "." - } - return "+" (substr(lhs, 2) + substr(rhs, 2)) -} - -function subtract(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '-'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '-'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '-'. Expects number, supplied " types_typename(rhs) "." - } - return "+" (substr(lhs, 2) - substr(rhs, 2)) -} - -function multiply(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '*'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '*'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '*'. Expects number, supplied " types_typename(rhs) "." - } - return "+" (substr(lhs, 2) * substr(rhs, 2)) -} - -function divide(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '/'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '/'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '/'. Expects number, supplied " types_typename(rhs) "." - } - return "+" int(substr(lhs, 2) / substr(rhs, 2)) -} - -function main(str, ret) -{ - repl_env["'+"] = "&add" - repl_env["'-"] = "&subtract" - repl_env["'*"] = "&multiply" - repl_env["'/"] = "÷" - env_builtinnames["add"] = "+" - env_builtinnames["subtract"] = "-" - env_builtinnames["multiply"] = "*" - env_builtinnames["divide"] = "/" - - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +function eval_ast(ast, env, i, idx, len, new_idx, ret) +{ + switch (ast) { + case /^'/: + if (ast in env) { + return types_addref(env[ast]) + } + return "!\"'" substr(ast, 2) "' not found" + case /^[([]/: + idx = substr(ast, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_heap[new_idx]["len"] = i + types_release(substr(ast, 1, 1) new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + types_heap[new_idx]["len"] = len + return substr(ast, 1, 1) new_idx + case /^\{/: + idx = substr(ast, 2) + new_idx = types_allocate() + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release("{" new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + } + return "{" new_idx + default: + return ast + } +} + +function EVAL(ast, env, new_ast, ret, idx, f, f_idx) +{ + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + return ret + } + idx = substr(ast, 2) + if (types_heap[idx]["len"] == 0) { + return ast + } + new_ast = eval_ast(ast, env) + types_release(ast) + if (new_ast ~ /^!/) { + return new_ast + } + idx = substr(new_ast, 2) + f = types_heap[idx][0] + if (f ~ /^&/) { + f_idx = substr(f, 2) + ret = @f_idx(idx) + types_release(new_ast) + return ret + } else { + types_release(new_ast) + return "!\"First element of list must be function, supplied " types_typename(f) "." + } +} + +function PRINT(expr, str) +{ + str = printer_pr_str(expr, 1) + types_release(expr) + return str +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast, repl_env) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function add(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '+'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '+'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '+'. Expects number, supplied " types_typename(rhs) "." + } + return "+" (substr(lhs, 2) + substr(rhs, 2)) +} + +function subtract(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '-'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '-'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '-'. Expects number, supplied " types_typename(rhs) "." + } + return "+" (substr(lhs, 2) - substr(rhs, 2)) +} + +function multiply(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '*'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '*'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '*'. Expects number, supplied " types_typename(rhs) "." + } + return "+" (substr(lhs, 2) * substr(rhs, 2)) +} + +function divide(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '/'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '/'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '/'. Expects number, supplied " types_typename(rhs) "." + } + return "+" int(substr(lhs, 2) / substr(rhs, 2)) +} + +function main(str, ret) +{ + repl_env["'+"] = "&add" + repl_env["'-"] = "&subtract" + repl_env["'*"] = "&multiply" + repl_env["'/"] = "÷" + env_builtinnames["add"] = "+" + env_builtinnames["subtract"] = "-" + env_builtinnames["multiply"] = "*" + env_builtinnames["divide"] = "/" + + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + exit(0) +} diff --git a/impls/awk/step3_env.awk b/impls/awk/step3_env.awk index 203ef50a45..b8bd694d7f 100644 --- a/impls/awk/step3_env.awk +++ b/impls/awk/step3_env.awk @@ -1,277 +1,277 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" -@include "env.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -function eval_ast(ast, env, i, idx, len, new_idx, ret) -{ - switch (ast) { - case /^'/: - ret = env_get(env, ast) - if (ret !~ /^!/) { - types_addref(ret) - } - return ret - case /^[([]/: - idx = substr(ast, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_heap[new_idx]["len"] = i - types_release(substr(ast, 1, 1) new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - types_heap[new_idx]["len"] = len - return substr(ast, 1, 1) new_idx - case /^\{/: - idx = substr(ast, 2) - new_idx = types_allocate() - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release("{" new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - } - return "{" new_idx - default: - return ast - } -} - -function EVAL_def(ast, env, idx, sym, ret, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - if (ret !~ /^!/) { - env_set(env, sym, ret) - types_addref(ret) - } - types_release(ast) - env_release(env) - return ret -} - -function EVAL_let(ast, env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - if (params_len % 2 != 0) { - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." - } - new_env = env_new(env) - env_release(env) - for (i = 0; i < params_len; i += 2) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(new_env) - return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) - if (ret ~ /^!/) { - types_release(ast) - env_release(new_env) - return ret - } - env_set(new_env, sym, ret) - } - types_addref(body = types_heap[idx][2]) - types_release(ast) - ret = EVAL(body, new_env) - env_release(new_env) - return ret -} - -function EVAL(ast, env, new_ast, ret, idx, f, f_idx) -{ - env_addref(env) - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - idx = substr(ast, 2) - if (types_heap[idx]["len"] == 0) { - env_release(env) - return ast - } - switch (types_heap[idx][0]) { - case "'def!": - return EVAL_def(ast, env) - case "'let*": - return EVAL_let(ast, env) - default: - new_ast = eval_ast(ast, env) - types_release(ast) - env_release(env) - if (new_ast ~ /^!/) { - return new_ast - } - idx = substr(new_ast, 2) - f = types_heap[idx][0] - if (f ~ /^&/) { - f_idx = substr(f, 2) - ret = @f_idx(idx) - types_release(new_ast) - return ret - } else { - types_release(new_ast) - return "!\"First element of list must be function, supplied " types_typename(f) "." - } - } -} - -function PRINT(expr, str) -{ - str = printer_pr_str(expr, 1) - types_release(expr) - return str -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast, repl_env) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function add(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '+'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '+'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '+'. Expects number, supplied " types_typename(rhs) "." - } - return "+" (substr(lhs, 2) + substr(rhs, 2)) -} - -function subtract(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '-'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '-'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '-'. Expects number, supplied " types_typename(rhs) "." - } - return "+" (substr(lhs, 2) - substr(rhs, 2)) -} - -function multiply(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '*'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '*'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '*'. Expects number, supplied " types_typename(rhs) "." - } - return "+" (substr(lhs, 2) * substr(rhs, 2)) -} - -function divide(idx, lhs, rhs) -{ - if (types_heap[idx]["len"] != 3) { - return "!\"Invalid argument length for builtin function '/'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." - } - lhs = types_heap[idx][1] - if (lhs !~ /^\+/) { - return "!\"Incompatible type for argument 1 of builtin function '/'. Expects number, supplied " types_typename(lhs) "." - } - rhs = types_heap[idx][2] - if (rhs !~ /^\+/) { - return "!\"Incompatible type for argument 2 of builtin function '/'. Expects number, supplied " types_typename(rhs) "." - } - return "+" int(substr(lhs, 2) / substr(rhs, 2)) -} - -function main(str, ret) -{ - repl_env = env_new() - env_set(repl_env, "'+", "&add") - env_set(repl_env, "'-", "&subtract") - env_set(repl_env, "'*", "&multiply") - env_set(repl_env, "'/", "÷") - - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - env_check(0) - env_dump() - types_dump() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" +@include "env.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +function eval_ast(ast, env, i, idx, len, new_idx, ret) +{ + switch (ast) { + case /^'/: + ret = env_get(env, ast) + if (ret !~ /^!/) { + types_addref(ret) + } + return ret + case /^[([]/: + idx = substr(ast, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_heap[new_idx]["len"] = i + types_release(substr(ast, 1, 1) new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + types_heap[new_idx]["len"] = len + return substr(ast, 1, 1) new_idx + case /^\{/: + idx = substr(ast, 2) + new_idx = types_allocate() + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release("{" new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + } + return "{" new_idx + default: + return ast + } +} + +function EVAL_def(ast, env, idx, sym, ret, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + if (ret !~ /^!/) { + env_set(env, sym, ret) + types_addref(ret) + } + types_release(ast) + env_release(env) + return ret +} + +function EVAL_let(ast, env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + if (params_len % 2 != 0) { + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." + } + new_env = env_new(env) + env_release(env) + for (i = 0; i < params_len; i += 2) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(new_env) + return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) + if (ret ~ /^!/) { + types_release(ast) + env_release(new_env) + return ret + } + env_set(new_env, sym, ret) + } + types_addref(body = types_heap[idx][2]) + types_release(ast) + ret = EVAL(body, new_env) + env_release(new_env) + return ret +} + +function EVAL(ast, env, new_ast, ret, idx, f, f_idx) +{ + env_addref(env) + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + idx = substr(ast, 2) + if (types_heap[idx]["len"] == 0) { + env_release(env) + return ast + } + switch (types_heap[idx][0]) { + case "'def!": + return EVAL_def(ast, env) + case "'let*": + return EVAL_let(ast, env) + default: + new_ast = eval_ast(ast, env) + types_release(ast) + env_release(env) + if (new_ast ~ /^!/) { + return new_ast + } + idx = substr(new_ast, 2) + f = types_heap[idx][0] + if (f ~ /^&/) { + f_idx = substr(f, 2) + ret = @f_idx(idx) + types_release(new_ast) + return ret + } else { + types_release(new_ast) + return "!\"First element of list must be function, supplied " types_typename(f) "." + } + } +} + +function PRINT(expr, str) +{ + str = printer_pr_str(expr, 1) + types_release(expr) + return str +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast, repl_env) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function add(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '+'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '+'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '+'. Expects number, supplied " types_typename(rhs) "." + } + return "+" (substr(lhs, 2) + substr(rhs, 2)) +} + +function subtract(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '-'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '-'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '-'. Expects number, supplied " types_typename(rhs) "." + } + return "+" (substr(lhs, 2) - substr(rhs, 2)) +} + +function multiply(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '*'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '*'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '*'. Expects number, supplied " types_typename(rhs) "." + } + return "+" (substr(lhs, 2) * substr(rhs, 2)) +} + +function divide(idx, lhs, rhs) +{ + if (types_heap[idx]["len"] != 3) { + return "!\"Invalid argument length for builtin function '/'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." + } + lhs = types_heap[idx][1] + if (lhs !~ /^\+/) { + return "!\"Incompatible type for argument 1 of builtin function '/'. Expects number, supplied " types_typename(lhs) "." + } + rhs = types_heap[idx][2] + if (rhs !~ /^\+/) { + return "!\"Incompatible type for argument 2 of builtin function '/'. Expects number, supplied " types_typename(rhs) "." + } + return "+" int(substr(lhs, 2) / substr(rhs, 2)) +} + +function main(str, ret) +{ + repl_env = env_new() + env_set(repl_env, "'+", "&add") + env_set(repl_env, "'-", "&subtract") + env_set(repl_env, "'*", "&multiply") + env_set(repl_env, "'/", "÷") + + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + env_check(0) + env_dump() + types_dump() + exit(0) +} diff --git a/impls/awk/step4_if_fn_do.awk b/impls/awk/step4_if_fn_do.awk index f05112a415..521540a03c 100644 --- a/impls/awk/step4_if_fn_do.awk +++ b/impls/awk/step4_if_fn_do.awk @@ -1,332 +1,332 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" -@include "env.awk" -@include "core.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -function eval_ast(ast, env, i, idx, len, new_idx, ret) -{ - switch (ast) { - case /^'/: - ret = env_get(env, ast) - if (ret !~ /^!/) { - types_addref(ret) - } - return ret - case /^[([]/: - idx = substr(ast, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_heap[new_idx]["len"] = i - types_release(substr(ast, 1, 1) new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - types_heap[new_idx]["len"] = len - return substr(ast, 1, 1) new_idx - case /^\{/: - idx = substr(ast, 2) - new_idx = types_allocate() - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release("{" new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - } - return "{" new_idx - default: - return ast - } -} - -function EVAL_def(ast, env, idx, sym, ret, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - if (ret !~ /^!/) { - env_set(env, sym, ret) - types_addref(ret) - } - types_release(ast) - env_release(env) - return ret -} - -function EVAL_let(ast, env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - if (params_len % 2 != 0) { - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." - } - new_env = env_new(env) - env_release(env) - for (i = 0; i < params_len; i += 2) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(new_env) - return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) - if (ret ~ /^!/) { - types_release(ast) - env_release(new_env) - return ret - } - env_set(new_env, sym, ret) - } - types_addref(body = types_heap[idx][2]) - types_release(ast) - ret = EVAL(body, new_env) - env_release(new_env) - return ret -} - -function EVAL_do(ast, env, idx, len, i, ret) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 1) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." - } - for (i = 1; i < len - 1; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_release(ret) - } - ret = EVAL(types_addref(types_heap[idx][len - 1]), env) - types_release(ast) - env_release(env) - return ret -} - -function EVAL_if(ast, env, idx, len, ret, body) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len != 3 && len != 4) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." - } - ret = EVAL(types_addref(types_heap[idx][1]), env) - if (ret ~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_release(ret) - switch (ret) { - case "#nil": - case "#false": - if (len == 3) { - types_release(ast) - env_release(env) - return "#nil" - } else { - types_addref(body = types_heap[idx][3]) - } - break - default: - types_addref(body = types_heap[idx][2]) - break - } - ret = EVAL(body, env) - types_release(ast) - env_release(env) - return ret -} - -function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - for (i = 0; i < params_len; ++i) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." - } - if (sym == "'&" && i + 2 != params_len) { - types_release(ast) - env_release(env) - return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." - } - } - f_idx = types_allocate() - types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) - types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) - types_heap[f_idx]["env"] = env - types_release(ast) - return "$" f_idx -} - -function EVAL(ast, env, new_ast, ret, idx, f, f_idx) -{ - env_addref(env) - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - idx = substr(ast, 2) - if (types_heap[idx]["len"] == 0) { - env_release(env) - return ast - } - switch (types_heap[idx][0]) { - case "'def!": - return EVAL_def(ast, env) - case "'let*": - return EVAL_let(ast, env) - case "'do": - return EVAL_do(ast, env) - case "'if": - return EVAL_if(ast, env) - case "'fn*": - return EVAL_fn(ast, env) - default: - new_ast = eval_ast(ast, env) - types_release(ast) - env_release(env) - if (new_ast ~ /^!/) { - return new_ast - } - idx = substr(new_ast, 2) - f = types_heap[idx][0] - f_idx = substr(f, 2) - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - if (env ~ /^!/) { - types_release(new_ast) - return env - } - types_addref(ast = types_heap[f_idx]["body"]) - types_release(new_ast) - ret = EVAL(ast, env) - env_release(env) - return ret - case /^&/: - ret = @f_idx(idx) - types_release(new_ast) - return ret - default: - types_release(new_ast) - return "!\"First element of list must be function, supplied " types_typename(f) "." - } - } -} - -function PRINT(expr, str) -{ - str = printer_pr_str(expr, 1) - types_release(expr) - return str -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast, repl_env) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function main(str, ret, i) -{ - repl_env = env_new() - for (i in core_ns) { - env_set(repl_env, i, core_ns[i]) - } - - rep("(def! not (fn* (a) (if a false true)))") - - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - env_check(0) - env_dump() - types_dump() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" +@include "env.awk" +@include "core.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +function eval_ast(ast, env, i, idx, len, new_idx, ret) +{ + switch (ast) { + case /^'/: + ret = env_get(env, ast) + if (ret !~ /^!/) { + types_addref(ret) + } + return ret + case /^[([]/: + idx = substr(ast, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_heap[new_idx]["len"] = i + types_release(substr(ast, 1, 1) new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + types_heap[new_idx]["len"] = len + return substr(ast, 1, 1) new_idx + case /^\{/: + idx = substr(ast, 2) + new_idx = types_allocate() + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release("{" new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + } + return "{" new_idx + default: + return ast + } +} + +function EVAL_def(ast, env, idx, sym, ret, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + if (ret !~ /^!/) { + env_set(env, sym, ret) + types_addref(ret) + } + types_release(ast) + env_release(env) + return ret +} + +function EVAL_let(ast, env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + if (params_len % 2 != 0) { + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." + } + new_env = env_new(env) + env_release(env) + for (i = 0; i < params_len; i += 2) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(new_env) + return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) + if (ret ~ /^!/) { + types_release(ast) + env_release(new_env) + return ret + } + env_set(new_env, sym, ret) + } + types_addref(body = types_heap[idx][2]) + types_release(ast) + ret = EVAL(body, new_env) + env_release(new_env) + return ret +} + +function EVAL_do(ast, env, idx, len, i, ret) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 1) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." + } + for (i = 1; i < len - 1; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_release(ret) + } + ret = EVAL(types_addref(types_heap[idx][len - 1]), env) + types_release(ast) + env_release(env) + return ret +} + +function EVAL_if(ast, env, idx, len, ret, body) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len != 3 && len != 4) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." + } + ret = EVAL(types_addref(types_heap[idx][1]), env) + if (ret ~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_release(ret) + switch (ret) { + case "#nil": + case "#false": + if (len == 3) { + types_release(ast) + env_release(env) + return "#nil" + } else { + types_addref(body = types_heap[idx][3]) + } + break + default: + types_addref(body = types_heap[idx][2]) + break + } + ret = EVAL(body, env) + types_release(ast) + env_release(env) + return ret +} + +function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + for (i = 0; i < params_len; ++i) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." + } + if (sym == "'&" && i + 2 != params_len) { + types_release(ast) + env_release(env) + return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." + } + } + f_idx = types_allocate() + types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) + types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) + types_heap[f_idx]["env"] = env + types_release(ast) + return "$" f_idx +} + +function EVAL(ast, env, new_ast, ret, idx, f, f_idx) +{ + env_addref(env) + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + idx = substr(ast, 2) + if (types_heap[idx]["len"] == 0) { + env_release(env) + return ast + } + switch (types_heap[idx][0]) { + case "'def!": + return EVAL_def(ast, env) + case "'let*": + return EVAL_let(ast, env) + case "'do": + return EVAL_do(ast, env) + case "'if": + return EVAL_if(ast, env) + case "'fn*": + return EVAL_fn(ast, env) + default: + new_ast = eval_ast(ast, env) + types_release(ast) + env_release(env) + if (new_ast ~ /^!/) { + return new_ast + } + idx = substr(new_ast, 2) + f = types_heap[idx][0] + f_idx = substr(f, 2) + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + if (env ~ /^!/) { + types_release(new_ast) + return env + } + types_addref(ast = types_heap[f_idx]["body"]) + types_release(new_ast) + ret = EVAL(ast, env) + env_release(env) + return ret + case /^&/: + ret = @f_idx(idx) + types_release(new_ast) + return ret + default: + types_release(new_ast) + return "!\"First element of list must be function, supplied " types_typename(f) "." + } + } +} + +function PRINT(expr, str) +{ + str = printer_pr_str(expr, 1) + types_release(expr) + return str +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast, repl_env) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function main(str, ret, i) +{ + repl_env = env_new() + for (i in core_ns) { + env_set(repl_env, i, core_ns[i]) + } + + rep("(def! not (fn* (a) (if a false true)))") + + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + env_check(0) + env_dump() + types_dump() + exit(0) +} diff --git a/impls/awk/step5_tco.awk b/impls/awk/step5_tco.awk index 43810458bc..78a992f0b3 100644 --- a/impls/awk/step5_tco.awk +++ b/impls/awk/step5_tco.awk @@ -1,339 +1,339 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" -@include "env.awk" -@include "core.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -function eval_ast(ast, env, i, idx, len, new_idx, ret) -{ - switch (ast) { - case /^'/: - ret = env_get(env, ast) - if (ret !~ /^!/) { - types_addref(ret) - } - return ret - case /^[([]/: - idx = substr(ast, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_heap[new_idx]["len"] = i - types_release(substr(ast, 1, 1) new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - types_heap[new_idx]["len"] = len - return substr(ast, 1, 1) new_idx - case /^\{/: - idx = substr(ast, 2) - new_idx = types_allocate() - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release("{" new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - } - return "{" new_idx - default: - return ast - } -} - -function EVAL_def(ast, env, idx, sym, ret, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - if (ret !~ /^!/) { - env_set(env, sym, ret) - types_addref(ret) - } - types_release(ast) - env_release(env) - return ret -} - -function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - if (params_len % 2 != 0) { - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." - } - new_env = env_new(env) - env_release(env) - for (i = 0; i < params_len; i += 2) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(new_env) - return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) - if (ret ~ /^!/) { - types_release(ast) - env_release(new_env) - return ret - } - env_set(new_env, sym, ret) - } - types_addref(body = types_heap[idx][2]) - types_release(ast) - ret_env[0] = new_env - return body -} - -function EVAL_do(ast, env, idx, len, i, body, ret) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 1) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." - } - for (i = 1; i < len - 1; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_release(ret) - } - types_addref(body = types_heap[idx][len - 1]) - types_release(ast) - return body -} - -function EVAL_if(ast, env, idx, len, ret, body) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len != 3 && len != 4) { - types_release(ast) - return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." - } - ret = EVAL(types_addref(types_heap[idx][1]), env) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - types_release(ret) - switch (ret) { - case "#nil": - case "#false": - if (len == 3) { - body = "#nil" - } else { - types_addref(body = types_heap[idx][3]) - } - break - default: - types_addref(body = types_heap[idx][2]) - break - } - types_release(ast) - return body -} - -function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - for (i = 0; i < params_len; ++i) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." - } - if (sym == "'&" && i + 2 != params_len) { - types_release(ast) - env_release(env) - return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." - } - } - f_idx = types_allocate() - types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) - types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) - types_heap[f_idx]["env"] = env - types_release(ast) - return "$" f_idx -} - -function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env) -{ - env_addref(env) - for (;;) { - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 0) { - env_release(env) - return ast - } - switch (types_heap[idx][0]) { - case "'def!": - return EVAL_def(ast, env) - case "'let*": - ast = EVAL_let(ast, env, ret_env) - if (ast ~ /^!/) { - return ast - } - env = ret_env[0] - continue - case "'do": - ast = EVAL_do(ast, env) - if (ast ~ /^!/) { - return ast - } - continue - case "'if": - ast = EVAL_if(ast, env) - if (ast !~ /^['([{]/) { - env_release(env) - return ast - } - continue - case "'fn*": - return EVAL_fn(ast, env) - default: - new_ast = eval_ast(ast, env) - types_release(ast) - env_release(env) - if (new_ast ~ /^!/) { - return new_ast - } - idx = substr(new_ast, 2) - f = types_heap[idx][0] - f_idx = substr(f, 2) - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - if (env ~ /^!/) { - types_release(new_ast) - return env - } - types_addref(ast = types_heap[f_idx]["body"]) - types_release(new_ast) - continue - case /^&/: - ret = @f_idx(idx) - types_release(new_ast) - return ret - default: - types_release(new_ast) - return "!\"First element of list must be function, supplied " types_typename(f) "." - } - } - } -} - -function PRINT(expr, str) -{ - str = printer_pr_str(expr, 1) - types_release(expr) - return str -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast, repl_env) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function main(str, ret, i) -{ - repl_env = env_new() - for (i in core_ns) { - env_set(repl_env, i, core_ns[i]) - } - - rep("(def! not (fn* (a) (if a false true)))") - - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - env_check(0) - env_dump() - types_dump() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" +@include "env.awk" +@include "core.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +function eval_ast(ast, env, i, idx, len, new_idx, ret) +{ + switch (ast) { + case /^'/: + ret = env_get(env, ast) + if (ret !~ /^!/) { + types_addref(ret) + } + return ret + case /^[([]/: + idx = substr(ast, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_heap[new_idx]["len"] = i + types_release(substr(ast, 1, 1) new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + types_heap[new_idx]["len"] = len + return substr(ast, 1, 1) new_idx + case /^\{/: + idx = substr(ast, 2) + new_idx = types_allocate() + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release("{" new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + } + return "{" new_idx + default: + return ast + } +} + +function EVAL_def(ast, env, idx, sym, ret, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + if (ret !~ /^!/) { + env_set(env, sym, ret) + types_addref(ret) + } + types_release(ast) + env_release(env) + return ret +} + +function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + if (params_len % 2 != 0) { + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." + } + new_env = env_new(env) + env_release(env) + for (i = 0; i < params_len; i += 2) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(new_env) + return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) + if (ret ~ /^!/) { + types_release(ast) + env_release(new_env) + return ret + } + env_set(new_env, sym, ret) + } + types_addref(body = types_heap[idx][2]) + types_release(ast) + ret_env[0] = new_env + return body +} + +function EVAL_do(ast, env, idx, len, i, body, ret) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 1) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." + } + for (i = 1; i < len - 1; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_release(ret) + } + types_addref(body = types_heap[idx][len - 1]) + types_release(ast) + return body +} + +function EVAL_if(ast, env, idx, len, ret, body) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len != 3 && len != 4) { + types_release(ast) + return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." + } + ret = EVAL(types_addref(types_heap[idx][1]), env) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + types_release(ret) + switch (ret) { + case "#nil": + case "#false": + if (len == 3) { + body = "#nil" + } else { + types_addref(body = types_heap[idx][3]) + } + break + default: + types_addref(body = types_heap[idx][2]) + break + } + types_release(ast) + return body +} + +function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + for (i = 0; i < params_len; ++i) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." + } + if (sym == "'&" && i + 2 != params_len) { + types_release(ast) + env_release(env) + return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." + } + } + f_idx = types_allocate() + types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) + types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) + types_heap[f_idx]["env"] = env + types_release(ast) + return "$" f_idx +} + +function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env) +{ + env_addref(env) + for (;;) { + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 0) { + env_release(env) + return ast + } + switch (types_heap[idx][0]) { + case "'def!": + return EVAL_def(ast, env) + case "'let*": + ast = EVAL_let(ast, env, ret_env) + if (ast ~ /^!/) { + return ast + } + env = ret_env[0] + continue + case "'do": + ast = EVAL_do(ast, env) + if (ast ~ /^!/) { + return ast + } + continue + case "'if": + ast = EVAL_if(ast, env) + if (ast !~ /^['([{]/) { + env_release(env) + return ast + } + continue + case "'fn*": + return EVAL_fn(ast, env) + default: + new_ast = eval_ast(ast, env) + types_release(ast) + env_release(env) + if (new_ast ~ /^!/) { + return new_ast + } + idx = substr(new_ast, 2) + f = types_heap[idx][0] + f_idx = substr(f, 2) + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + if (env ~ /^!/) { + types_release(new_ast) + return env + } + types_addref(ast = types_heap[f_idx]["body"]) + types_release(new_ast) + continue + case /^&/: + ret = @f_idx(idx) + types_release(new_ast) + return ret + default: + types_release(new_ast) + return "!\"First element of list must be function, supplied " types_typename(f) "." + } + } + } +} + +function PRINT(expr, str) +{ + str = printer_pr_str(expr, 1) + types_release(expr) + return str +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast, repl_env) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function main(str, ret, i) +{ + repl_env = env_new() + for (i in core_ns) { + env_set(repl_env, i, core_ns[i]) + } + + rep("(def! not (fn* (a) (if a false true)))") + + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + env_check(0) + env_dump() + types_dump() + exit(0) +} diff --git a/impls/awk/step6_file.awk b/impls/awk/step6_file.awk index 369bd0557b..e71cc901e1 100644 --- a/impls/awk/step6_file.awk +++ b/impls/awk/step6_file.awk @@ -1,363 +1,363 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" -@include "env.awk" -@include "core.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -function eval_ast(ast, env, i, idx, len, new_idx, ret) -{ - switch (ast) { - case /^'/: - ret = env_get(env, ast) - if (ret !~ /^!/) { - types_addref(ret) - } - return ret - case /^[([]/: - idx = substr(ast, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_heap[new_idx]["len"] = i - types_release(substr(ast, 1, 1) new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - types_heap[new_idx]["len"] = len - return substr(ast, 1, 1) new_idx - case /^\{/: - idx = substr(ast, 2) - new_idx = types_allocate() - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release("{" new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - } - return "{" new_idx - default: - return ast - } -} - -function EVAL_def(ast, env, idx, sym, ret, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - if (ret !~ /^!/) { - env_set(env, sym, ret) - types_addref(ret) - } - types_release(ast) - env_release(env) - return ret -} - -function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - if (params_len % 2 != 0) { - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." - } - new_env = env_new(env) - env_release(env) - for (i = 0; i < params_len; i += 2) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(new_env) - return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) - if (ret ~ /^!/) { - types_release(ast) - env_release(new_env) - return ret - } - env_set(new_env, sym, ret) - } - types_addref(body = types_heap[idx][2]) - types_release(ast) - ret_env[0] = new_env - return body -} - -function EVAL_do(ast, env, idx, len, i, body, ret) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 1) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." - } - for (i = 1; i < len - 1; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_release(ret) - } - types_addref(body = types_heap[idx][len - 1]) - types_release(ast) - return body -} - -function EVAL_if(ast, env, idx, len, ret, body) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len != 3 && len != 4) { - types_release(ast) - return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." - } - ret = EVAL(types_addref(types_heap[idx][1]), env) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - types_release(ret) - switch (ret) { - case "#nil": - case "#false": - if (len == 3) { - body = "#nil" - } else { - types_addref(body = types_heap[idx][3]) - } - break - default: - types_addref(body = types_heap[idx][2]) - break - } - types_release(ast) - return body -} - -function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - for (i = 0; i < params_len; ++i) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." - } - if (sym == "'&" && i + 2 != params_len) { - types_release(ast) - env_release(env) - return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." - } - } - f_idx = types_allocate() - types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) - types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) - types_heap[f_idx]["env"] = env - types_release(ast) - return "$" f_idx -} - -function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env) -{ - env_addref(env) - for (;;) { - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 0) { - env_release(env) - return ast - } - switch (types_heap[idx][0]) { - case "'def!": - return EVAL_def(ast, env) - case "'let*": - ast = EVAL_let(ast, env, ret_env) - if (ast ~ /^!/) { - return ast - } - env = ret_env[0] - continue - case "'do": - ast = EVAL_do(ast, env) - if (ast ~ /^!/) { - return ast - } - continue - case "'if": - ast = EVAL_if(ast, env) - if (ast !~ /^['([{]/) { - env_release(env) - return ast - } - continue - case "'fn*": - return EVAL_fn(ast, env) - default: - new_ast = eval_ast(ast, env) - types_release(ast) - env_release(env) - if (new_ast ~ /^!/) { - return new_ast - } - idx = substr(new_ast, 2) - f = types_heap[idx][0] - f_idx = substr(f, 2) - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - if (env ~ /^!/) { - types_release(new_ast) - return env - } - types_addref(ast = types_heap[f_idx]["body"]) - types_release(new_ast) - continue - case /^&/: - ret = @f_idx(idx) - types_release(new_ast) - return ret - default: - types_release(new_ast) - return "!\"First element of list must be function, supplied " types_typename(f) "." - } - } - } -} - -function PRINT(expr, str) -{ - str = printer_pr_str(expr, 1) - types_release(expr) - return str -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast, repl_env) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function eval(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return EVAL(types_addref(types_heap[idx][1]), repl_env) -} - -function main(str, ret, i, idx) -{ - repl_env = env_new() - for (i in core_ns) { - env_set(repl_env, i, core_ns[i]) - } - - env_set(repl_env, "'eval", "&eval") - - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") - - idx = types_allocate() - env_set(repl_env, "'*ARGV*", "(" idx) - if (ARGC > 1) { - for (i = 2; i < ARGC; ++i) { - types_heap[idx][i - 2] = "\"" ARGV[i] - } - types_heap[idx]["len"] = ARGC - 2 - ARGC = 1 - rep("(load-file \"" ARGV[1] "\")") - return - } - types_heap[idx]["len"] = 0 - - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - env_check(0) - env_dump() - types_dump() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" +@include "env.awk" +@include "core.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +function eval_ast(ast, env, i, idx, len, new_idx, ret) +{ + switch (ast) { + case /^'/: + ret = env_get(env, ast) + if (ret !~ /^!/) { + types_addref(ret) + } + return ret + case /^[([]/: + idx = substr(ast, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_heap[new_idx]["len"] = i + types_release(substr(ast, 1, 1) new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + types_heap[new_idx]["len"] = len + return substr(ast, 1, 1) new_idx + case /^\{/: + idx = substr(ast, 2) + new_idx = types_allocate() + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release("{" new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + } + return "{" new_idx + default: + return ast + } +} + +function EVAL_def(ast, env, idx, sym, ret, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + if (ret !~ /^!/) { + env_set(env, sym, ret) + types_addref(ret) + } + types_release(ast) + env_release(env) + return ret +} + +function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + if (params_len % 2 != 0) { + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." + } + new_env = env_new(env) + env_release(env) + for (i = 0; i < params_len; i += 2) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(new_env) + return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) + if (ret ~ /^!/) { + types_release(ast) + env_release(new_env) + return ret + } + env_set(new_env, sym, ret) + } + types_addref(body = types_heap[idx][2]) + types_release(ast) + ret_env[0] = new_env + return body +} + +function EVAL_do(ast, env, idx, len, i, body, ret) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 1) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." + } + for (i = 1; i < len - 1; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_release(ret) + } + types_addref(body = types_heap[idx][len - 1]) + types_release(ast) + return body +} + +function EVAL_if(ast, env, idx, len, ret, body) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len != 3 && len != 4) { + types_release(ast) + return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." + } + ret = EVAL(types_addref(types_heap[idx][1]), env) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + types_release(ret) + switch (ret) { + case "#nil": + case "#false": + if (len == 3) { + body = "#nil" + } else { + types_addref(body = types_heap[idx][3]) + } + break + default: + types_addref(body = types_heap[idx][2]) + break + } + types_release(ast) + return body +} + +function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + for (i = 0; i < params_len; ++i) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." + } + if (sym == "'&" && i + 2 != params_len) { + types_release(ast) + env_release(env) + return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." + } + } + f_idx = types_allocate() + types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) + types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) + types_heap[f_idx]["env"] = env + types_release(ast) + return "$" f_idx +} + +function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env) +{ + env_addref(env) + for (;;) { + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 0) { + env_release(env) + return ast + } + switch (types_heap[idx][0]) { + case "'def!": + return EVAL_def(ast, env) + case "'let*": + ast = EVAL_let(ast, env, ret_env) + if (ast ~ /^!/) { + return ast + } + env = ret_env[0] + continue + case "'do": + ast = EVAL_do(ast, env) + if (ast ~ /^!/) { + return ast + } + continue + case "'if": + ast = EVAL_if(ast, env) + if (ast !~ /^['([{]/) { + env_release(env) + return ast + } + continue + case "'fn*": + return EVAL_fn(ast, env) + default: + new_ast = eval_ast(ast, env) + types_release(ast) + env_release(env) + if (new_ast ~ /^!/) { + return new_ast + } + idx = substr(new_ast, 2) + f = types_heap[idx][0] + f_idx = substr(f, 2) + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + if (env ~ /^!/) { + types_release(new_ast) + return env + } + types_addref(ast = types_heap[f_idx]["body"]) + types_release(new_ast) + continue + case /^&/: + ret = @f_idx(idx) + types_release(new_ast) + return ret + default: + types_release(new_ast) + return "!\"First element of list must be function, supplied " types_typename(f) "." + } + } + } +} + +function PRINT(expr, str) +{ + str = printer_pr_str(expr, 1) + types_release(expr) + return str +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast, repl_env) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function eval(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return EVAL(types_addref(types_heap[idx][1]), repl_env) +} + +function main(str, ret, i, idx) +{ + repl_env = env_new() + for (i in core_ns) { + env_set(repl_env, i, core_ns[i]) + } + + env_set(repl_env, "'eval", "&eval") + + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") + + idx = types_allocate() + env_set(repl_env, "'*ARGV*", "(" idx) + if (ARGC > 1) { + for (i = 2; i < ARGC; ++i) { + types_heap[idx][i - 2] = "\"" ARGV[i] + } + types_heap[idx]["len"] = ARGC - 2 + ARGC = 1 + rep("(load-file \"" ARGV[1] "\")") + return + } + types_heap[idx]["len"] = 0 + + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + env_check(0) + env_dump() + types_dump() + exit(0) +} diff --git a/impls/awk/step7_quote.awk b/impls/awk/step7_quote.awk index c089c03fa1..635f51b93f 100644 --- a/impls/awk/step7_quote.awk +++ b/impls/awk/step7_quote.awk @@ -1,475 +1,475 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" -@include "env.awk" -@include "core.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -# Return 0, an error or the unquote argument (second element of ast). -function starts_with(ast, sym, idx, len) -{ - if (ast !~ /^\(/) - return 0 - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (!len || types_heap[idx][0] != sym) - return 0 - if (len != 2) - return "!\"'" sym "' expects 1 argument, not " (len - 1) "." - return types_heap[idx][1] -} - -function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous) -{ - if (ast !~ /^[(['{]/) { - return ast - } - if (ast ~ /['\{]/) { - new_idx = types_allocate() - types_heap[new_idx][0] = "'quote" - types_heap[new_idx][1] = ast - types_heap[new_idx]["len"] = 2 - return "(" new_idx - } - ret = starts_with(ast, "'unquote") - if (ret ~ /^!/) { - types_release(ast) - return ret - } - if (ret) { - types_addref(ret) - types_release(ast) - return ret - } - new_idx = types_allocate() - types_heap[new_idx]["len"] = 0 - ast_idx = substr(ast, 2) - for (elt_i=types_heap[ast_idx]["len"]-1; 0<=elt_i; elt_i--) { - elt = types_heap[ast_idx][elt_i] - ret = starts_with(elt, "'splice-unquote") - if (ret ~ /^!/) { - types_release("(" new_idx) - types_release(ast) - return ret - } - if (ret) { - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'concat" - types_heap[new_idx][1] = types_addref(ret) - types_heap[new_idx][2] = previous - types_heap[new_idx]["len"] = 3 - } else { - ret = quasiquote(types_addref(elt)) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'cons" - types_heap[new_idx][1] = ret - types_heap[new_idx][2] = previous - types_heap[new_idx]["len"] = 3 - } - } - if (ast ~ /^\[/) { - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'vec" - types_heap[new_idx][1] = previous - types_heap[new_idx]["len"] = 2 - } - types_release(ast) - return "(" new_idx -} - -function eval_ast(ast, env, i, idx, len, new_idx, ret) -{ - switch (ast) { - case /^'/: - ret = env_get(env, ast) - if (ret !~ /^!/) { - types_addref(ret) - } - return ret - case /^[([]/: - idx = substr(ast, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_heap[new_idx]["len"] = i - types_release(substr(ast, 1, 1) new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - types_heap[new_idx]["len"] = len - return substr(ast, 1, 1) new_idx - case /^\{/: - idx = substr(ast, 2) - new_idx = types_allocate() - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release("{" new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - } - return "{" new_idx - default: - return ast - } -} - -function EVAL_def(ast, env, idx, sym, ret, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - if (ret !~ /^!/) { - env_set(env, sym, ret) - types_addref(ret) - } - types_release(ast) - env_release(env) - return ret -} - -function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - if (params_len % 2 != 0) { - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." - } - new_env = env_new(env) - env_release(env) - for (i = 0; i < params_len; i += 2) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(new_env) - return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) - if (ret ~ /^!/) { - types_release(ast) - env_release(new_env) - return ret - } - env_set(new_env, sym, ret) - } - types_addref(body = types_heap[idx][2]) - types_release(ast) - ret_env[0] = new_env - return body -} - -function EVAL_do(ast, env, idx, len, i, body, ret) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 1) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." - } - for (i = 1; i < len - 1; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_release(ret) - } - types_addref(body = types_heap[idx][len - 1]) - types_release(ast) - return body -} - -function EVAL_if(ast, env, idx, len, ret, body) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len != 3 && len != 4) { - types_release(ast) - return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." - } - ret = EVAL(types_addref(types_heap[idx][1]), env) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - types_release(ret) - switch (ret) { - case "#nil": - case "#false": - if (len == 3) { - body = "#nil" - } else { - types_addref(body = types_heap[idx][3]) - } - break - default: - types_addref(body = types_heap[idx][2]) - break - } - types_release(ast) - return body -} - -function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - for (i = 0; i < params_len; ++i) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." - } - if (sym == "'&" && i + 2 != params_len) { - types_release(ast) - env_release(env) - return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." - } - } - f_idx = types_allocate() - types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) - types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) - types_heap[f_idx]["env"] = env - types_release(ast) - return "$" f_idx -} - -function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env) -{ - env_addref(env) - for (;;) { - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 0) { - env_release(env) - return ast - } - switch (types_heap[idx][0]) { - case "'def!": - return EVAL_def(ast, env) - case "'let*": - ast = EVAL_let(ast, env, ret_env) - if (ast ~ /^!/) { - return ast - } - env = ret_env[0] - continue - case "'quote": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - env_release(env) - return body - case "'quasiquoteexpand": - env_release(env) - if (len != 2) { - types_release(ast) - return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - return quasiquote(body) - case "'quasiquote": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - ast = quasiquote(body) - if (ast ~ /^!/) { - env_release(env) - return ast - } - continue - case "'do": - ast = EVAL_do(ast, env) - if (ast ~ /^!/) { - return ast - } - continue - case "'if": - ast = EVAL_if(ast, env) - if (ast !~ /^['([{]/) { - env_release(env) - return ast - } - continue - case "'fn*": - return EVAL_fn(ast, env) - default: - new_ast = eval_ast(ast, env) - types_release(ast) - env_release(env) - if (new_ast ~ /^!/) { - return new_ast - } - idx = substr(new_ast, 2) - f = types_heap[idx][0] - f_idx = substr(f, 2) - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - if (env ~ /^!/) { - types_release(new_ast) - return env - } - types_addref(ast = types_heap[f_idx]["body"]) - types_release(new_ast) - continue - case /^&/: - ret = @f_idx(idx) - types_release(new_ast) - return ret - default: - types_release(new_ast) - return "!\"First element of list must be function, supplied " types_typename(f) "." - } - } - } -} - -function PRINT(expr, str) -{ - str = printer_pr_str(expr, 1) - types_release(expr) - return str -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast, repl_env) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function eval(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return EVAL(types_addref(types_heap[idx][1]), repl_env) -} - -function main(str, ret, i, idx) -{ - repl_env = env_new() - for (i in core_ns) { - env_set(repl_env, i, core_ns[i]) - } - - env_set(repl_env, "'eval", "&eval") - - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") - - idx = types_allocate() - env_set(repl_env, "'*ARGV*", "(" idx) - if (ARGC > 1) { - for (i = 2; i < ARGC; ++i) { - types_heap[idx][i - 2] = "\"" ARGV[i] - } - types_heap[idx]["len"] = ARGC - 2 - ARGC = 1 - rep("(load-file \"" ARGV[1] "\")") - return - } - types_heap[idx]["len"] = 0 - - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - env_check(0) - env_dump() - types_dump() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" +@include "env.awk" +@include "core.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +# Return 0, an error or the unquote argument (second element of ast). +function starts_with(ast, sym, idx, len) +{ + if (ast !~ /^\(/) + return 0 + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (!len || types_heap[idx][0] != sym) + return 0 + if (len != 2) + return "!\"'" sym "' expects 1 argument, not " (len - 1) "." + return types_heap[idx][1] +} + +function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous) +{ + if (ast !~ /^[(['{]/) { + return ast + } + if (ast ~ /['\{]/) { + new_idx = types_allocate() + types_heap[new_idx][0] = "'quote" + types_heap[new_idx][1] = ast + types_heap[new_idx]["len"] = 2 + return "(" new_idx + } + ret = starts_with(ast, "'unquote") + if (ret ~ /^!/) { + types_release(ast) + return ret + } + if (ret) { + types_addref(ret) + types_release(ast) + return ret + } + new_idx = types_allocate() + types_heap[new_idx]["len"] = 0 + ast_idx = substr(ast, 2) + for (elt_i=types_heap[ast_idx]["len"]-1; 0<=elt_i; elt_i--) { + elt = types_heap[ast_idx][elt_i] + ret = starts_with(elt, "'splice-unquote") + if (ret ~ /^!/) { + types_release("(" new_idx) + types_release(ast) + return ret + } + if (ret) { + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'concat" + types_heap[new_idx][1] = types_addref(ret) + types_heap[new_idx][2] = previous + types_heap[new_idx]["len"] = 3 + } else { + ret = quasiquote(types_addref(elt)) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'cons" + types_heap[new_idx][1] = ret + types_heap[new_idx][2] = previous + types_heap[new_idx]["len"] = 3 + } + } + if (ast ~ /^\[/) { + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'vec" + types_heap[new_idx][1] = previous + types_heap[new_idx]["len"] = 2 + } + types_release(ast) + return "(" new_idx +} + +function eval_ast(ast, env, i, idx, len, new_idx, ret) +{ + switch (ast) { + case /^'/: + ret = env_get(env, ast) + if (ret !~ /^!/) { + types_addref(ret) + } + return ret + case /^[([]/: + idx = substr(ast, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_heap[new_idx]["len"] = i + types_release(substr(ast, 1, 1) new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + types_heap[new_idx]["len"] = len + return substr(ast, 1, 1) new_idx + case /^\{/: + idx = substr(ast, 2) + new_idx = types_allocate() + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release("{" new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + } + return "{" new_idx + default: + return ast + } +} + +function EVAL_def(ast, env, idx, sym, ret, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + if (ret !~ /^!/) { + env_set(env, sym, ret) + types_addref(ret) + } + types_release(ast) + env_release(env) + return ret +} + +function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + if (params_len % 2 != 0) { + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." + } + new_env = env_new(env) + env_release(env) + for (i = 0; i < params_len; i += 2) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(new_env) + return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) + if (ret ~ /^!/) { + types_release(ast) + env_release(new_env) + return ret + } + env_set(new_env, sym, ret) + } + types_addref(body = types_heap[idx][2]) + types_release(ast) + ret_env[0] = new_env + return body +} + +function EVAL_do(ast, env, idx, len, i, body, ret) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 1) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." + } + for (i = 1; i < len - 1; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_release(ret) + } + types_addref(body = types_heap[idx][len - 1]) + types_release(ast) + return body +} + +function EVAL_if(ast, env, idx, len, ret, body) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len != 3 && len != 4) { + types_release(ast) + return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." + } + ret = EVAL(types_addref(types_heap[idx][1]), env) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + types_release(ret) + switch (ret) { + case "#nil": + case "#false": + if (len == 3) { + body = "#nil" + } else { + types_addref(body = types_heap[idx][3]) + } + break + default: + types_addref(body = types_heap[idx][2]) + break + } + types_release(ast) + return body +} + +function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + for (i = 0; i < params_len; ++i) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." + } + if (sym == "'&" && i + 2 != params_len) { + types_release(ast) + env_release(env) + return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." + } + } + f_idx = types_allocate() + types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) + types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) + types_heap[f_idx]["env"] = env + types_release(ast) + return "$" f_idx +} + +function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env) +{ + env_addref(env) + for (;;) { + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 0) { + env_release(env) + return ast + } + switch (types_heap[idx][0]) { + case "'def!": + return EVAL_def(ast, env) + case "'let*": + ast = EVAL_let(ast, env, ret_env) + if (ast ~ /^!/) { + return ast + } + env = ret_env[0] + continue + case "'quote": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + env_release(env) + return body + case "'quasiquoteexpand": + env_release(env) + if (len != 2) { + types_release(ast) + return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + return quasiquote(body) + case "'quasiquote": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + ast = quasiquote(body) + if (ast ~ /^!/) { + env_release(env) + return ast + } + continue + case "'do": + ast = EVAL_do(ast, env) + if (ast ~ /^!/) { + return ast + } + continue + case "'if": + ast = EVAL_if(ast, env) + if (ast !~ /^['([{]/) { + env_release(env) + return ast + } + continue + case "'fn*": + return EVAL_fn(ast, env) + default: + new_ast = eval_ast(ast, env) + types_release(ast) + env_release(env) + if (new_ast ~ /^!/) { + return new_ast + } + idx = substr(new_ast, 2) + f = types_heap[idx][0] + f_idx = substr(f, 2) + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + if (env ~ /^!/) { + types_release(new_ast) + return env + } + types_addref(ast = types_heap[f_idx]["body"]) + types_release(new_ast) + continue + case /^&/: + ret = @f_idx(idx) + types_release(new_ast) + return ret + default: + types_release(new_ast) + return "!\"First element of list must be function, supplied " types_typename(f) "." + } + } + } +} + +function PRINT(expr, str) +{ + str = printer_pr_str(expr, 1) + types_release(expr) + return str +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast, repl_env) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function eval(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return EVAL(types_addref(types_heap[idx][1]), repl_env) +} + +function main(str, ret, i, idx) +{ + repl_env = env_new() + for (i in core_ns) { + env_set(repl_env, i, core_ns[i]) + } + + env_set(repl_env, "'eval", "&eval") + + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") + + idx = types_allocate() + env_set(repl_env, "'*ARGV*", "(" idx) + if (ARGC > 1) { + for (i = 2; i < ARGC; ++i) { + types_heap[idx][i - 2] = "\"" ARGV[i] + } + types_heap[idx]["len"] = ARGC - 2 + ARGC = 1 + rep("(load-file \"" ARGV[1] "\")") + return + } + types_heap[idx]["len"] = 0 + + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + env_check(0) + env_dump() + types_dump() + exit(0) +} diff --git a/impls/awk/step8_macros.awk b/impls/awk/step8_macros.awk index ca20cc123b..15d9ab1af3 100644 --- a/impls/awk/step8_macros.awk +++ b/impls/awk/step8_macros.awk @@ -1,575 +1,575 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" -@include "env.awk" -@include "core.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -# Return 0, an error or the unquote argument (second element of ast). -function starts_with(ast, sym, idx, len) -{ - if (ast !~ /^\(/) - return 0 - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (!len || types_heap[idx][0] != sym) - return 0 - if (len != 2) - return "!\"'" sym "' expects 1 argument, not " (len - 1) "." - return types_heap[idx][1] -} - -function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous) -{ - if (ast !~ /^[(['{]/) { - return ast - } - if (ast ~ /['\{]/) { - new_idx = types_allocate() - types_heap[new_idx][0] = "'quote" - types_heap[new_idx][1] = ast - types_heap[new_idx]["len"] = 2 - return "(" new_idx - } - ret = starts_with(ast, "'unquote") - if (ret ~ /^!/) { - types_release(ast) - return ret - } - if (ret) { - types_addref(ret) - types_release(ast) - return ret - } - new_idx = types_allocate() - types_heap[new_idx]["len"] = 0 - ast_idx = substr(ast, 2) - for (elt_i=types_heap[ast_idx]["len"]-1; 0<=elt_i; elt_i--) { - elt = types_heap[ast_idx][elt_i] - ret = starts_with(elt, "'splice-unquote") - if (ret ~ /^!/) { - types_release("(" new_idx) - types_release(ast) - return ret - } - if (ret) { - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'concat" - types_heap[new_idx][1] = types_addref(ret) - types_heap[new_idx][2] = previous - types_heap[new_idx]["len"] = 3 - } else { - ret = quasiquote(types_addref(elt)) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'cons" - types_heap[new_idx][1] = ret - types_heap[new_idx][2] = previous - types_heap[new_idx]["len"] = 3 - } - } - if (ast ~ /^\[/) { - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'vec" - types_heap[new_idx][1] = previous - types_heap[new_idx]["len"] = 2 - } - types_release(ast) - return "(" new_idx -} - -function is_macro_call(ast, env, idx, len, sym, f) -{ - if (ast !~ /^\(/) return 0 - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 0) return 0 - sym = types_heap[idx][0] - if (sym !~ /^'/) return 0 - f = env_get(env, sym) - return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] -} - -function macroexpand(ast, env, idx, f_idx, new_env) -{ - while (is_macro_call(ast, env)) { - idx = substr(ast, 2) - f_idx = substr(env_get(env, types_heap[idx][0]), 2) - new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - types_release(ast) - if (new_env ~ /^!/) { - return new_env - } - types_addref(ast = types_heap[f_idx]["body"]) - ast = EVAL(ast, new_env) - env_release(new_env) - if (ast ~ /^!/) { - return ast - } - } - return ast -} - -function eval_ast(ast, env, i, idx, len, new_idx, ret) -{ - switch (ast) { - case /^'/: - ret = env_get(env, ast) - if (ret !~ /^!/) { - types_addref(ret) - } - return ret - case /^[([]/: - idx = substr(ast, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_heap[new_idx]["len"] = i - types_release(substr(ast, 1, 1) new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - types_heap[new_idx]["len"] = len - return substr(ast, 1, 1) new_idx - case /^\{/: - idx = substr(ast, 2) - new_idx = types_allocate() - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release("{" new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - } - return "{" new_idx - default: - return ast - } -} - -function EVAL_def(ast, env, idx, sym, ret, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - if (ret !~ /^!/) { - env_set(env, sym, ret) - types_addref(ret) - } - types_release(ast) - env_release(env) - return ret -} - -function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - if (params_len % 2 != 0) { - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." - } - new_env = env_new(env) - env_release(env) - for (i = 0; i < params_len; i += 2) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(new_env) - return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) - if (ret ~ /^!/) { - types_release(ast) - env_release(new_env) - return ret - } - env_set(new_env, sym, ret) - } - types_addref(body = types_heap[idx][2]) - types_release(ast) - ret_env[0] = new_env - return body -} - -function EVAL_defmacro(ast, env, idx, sym, ret, len, fun_idx, mac_idx) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'defmacro!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'defmacro!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - types_release(ast) - if (ret ~ /^!/) { - env_release(env) - return ret - } - if (ret !~ /^\$/) { - types_release(ret) - env_release(env) - return "!\"Incompatible type for argument 2 of 'defmacro!'. Expects function, supplied " types_typename(ret) "." - } - - # Replace `ret` with a clone setting the `is_macro` bit. - fun_idx = substr(ret, 2) - mac_idx = types_allocate() - types_addref(types_heap[mac_idx]["params"] = types_heap[fun_idx]["params"]) - types_addref(types_heap[mac_idx]["body"] = types_heap[fun_idx]["body"]) - env_addref(types_heap[mac_idx]["env"] = types_heap[fun_idx]["env"]) - types_heap[mac_idx]["is_macro"] = 1 - types_release(ret) - ret = "$" mac_idx - - env_set(env, sym, ret) - types_addref(ret) - env_release(env) - return ret -} - -function EVAL_do(ast, env, idx, len, i, body, ret) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 1) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." - } - for (i = 1; i < len - 1; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_release(ret) - } - types_addref(body = types_heap[idx][len - 1]) - types_release(ast) - return body -} - -function EVAL_if(ast, env, idx, len, ret, body) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len != 3 && len != 4) { - types_release(ast) - return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." - } - ret = EVAL(types_addref(types_heap[idx][1]), env) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - types_release(ret) - switch (ret) { - case "#nil": - case "#false": - if (len == 3) { - body = "#nil" - } else { - types_addref(body = types_heap[idx][3]) - } - break - default: - types_addref(body = types_heap[idx][2]) - break - } - types_release(ast) - return body -} - -function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - for (i = 0; i < params_len; ++i) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." - } - if (sym == "'&" && i + 2 != params_len) { - types_release(ast) - env_release(env) - return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." - } - } - f_idx = types_allocate() - types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) - types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) - types_heap[f_idx]["env"] = env - types_release(ast) - return "$" f_idx -} - -function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env) -{ - env_addref(env) - for (;;) { - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - if (types_heap[substr(ast, 2)]["len"] == 0) { - env_release(env) - return ast - } - ast = macroexpand(ast, env) - if (ast ~ /^!/) { - env_release(env) - return ast - } - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - idx = substr(ast, 2) - len = types_heap[idx]["len"] - switch (types_heap[idx][0]) { - case "'def!": - return EVAL_def(ast, env) - case "'let*": - ast = EVAL_let(ast, env, ret_env) - if (ast ~ /^!/) { - return ast - } - env = ret_env[0] - continue - case "'quote": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - env_release(env) - return body - case "'quasiquoteexpand": - env_release(env) - if (len != 2) { - types_release(ast) - return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - return quasiquote(body) - case "'quasiquote": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - ast = quasiquote(body) - if (ast ~ /^!/) { - env_release(env) - return ast - } - continue - case "'defmacro!": - return EVAL_defmacro(ast, env) - case "'macroexpand": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - ret = macroexpand(body, env) - env_release(env) - return ret - case "'do": - ast = EVAL_do(ast, env) - if (ast ~ /^!/) { - return ast - } - continue - case "'if": - ast = EVAL_if(ast, env) - if (ast !~ /^['([{]/) { - env_release(env) - return ast - } - continue - case "'fn*": - return EVAL_fn(ast, env) - default: - new_ast = eval_ast(ast, env) - types_release(ast) - env_release(env) - if (new_ast ~ /^!/) { - return new_ast - } - idx = substr(new_ast, 2) - f = types_heap[idx][0] - f_idx = substr(f, 2) - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - if (env ~ /^!/) { - types_release(new_ast) - return env - } - types_addref(ast = types_heap[f_idx]["body"]) - types_release(new_ast) - continue - case /^&/: - ret = @f_idx(idx) - types_release(new_ast) - return ret - default: - types_release(new_ast) - return "!\"First element of list must be function, supplied " types_typename(f) "." - } - } - } -} - -function PRINT(expr, str) -{ - str = printer_pr_str(expr, 1) - types_release(expr) - return str -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast, repl_env) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function eval(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return EVAL(types_addref(types_heap[idx][1]), repl_env) -} - -function main(str, ret, i, idx) -{ - repl_env = env_new() - for (i in core_ns) { - env_set(repl_env, i, core_ns[i]) - } - - env_set(repl_env, "'eval", "&eval") - - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") - 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)))))))") - - idx = types_allocate() - env_set(repl_env, "'*ARGV*", "(" idx) - if (ARGC > 1) { - for (i = 2; i < ARGC; ++i) { - types_heap[idx][i - 2] = "\"" ARGV[i] - } - types_heap[idx]["len"] = ARGC - 2 - ARGC = 1 - rep("(load-file \"" ARGV[1] "\")") - return - } - types_heap[idx]["len"] = 0 - - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - env_check(0) - env_dump() - types_dump() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" +@include "env.awk" +@include "core.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +# Return 0, an error or the unquote argument (second element of ast). +function starts_with(ast, sym, idx, len) +{ + if (ast !~ /^\(/) + return 0 + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (!len || types_heap[idx][0] != sym) + return 0 + if (len != 2) + return "!\"'" sym "' expects 1 argument, not " (len - 1) "." + return types_heap[idx][1] +} + +function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous) +{ + if (ast !~ /^[(['{]/) { + return ast + } + if (ast ~ /['\{]/) { + new_idx = types_allocate() + types_heap[new_idx][0] = "'quote" + types_heap[new_idx][1] = ast + types_heap[new_idx]["len"] = 2 + return "(" new_idx + } + ret = starts_with(ast, "'unquote") + if (ret ~ /^!/) { + types_release(ast) + return ret + } + if (ret) { + types_addref(ret) + types_release(ast) + return ret + } + new_idx = types_allocate() + types_heap[new_idx]["len"] = 0 + ast_idx = substr(ast, 2) + for (elt_i=types_heap[ast_idx]["len"]-1; 0<=elt_i; elt_i--) { + elt = types_heap[ast_idx][elt_i] + ret = starts_with(elt, "'splice-unquote") + if (ret ~ /^!/) { + types_release("(" new_idx) + types_release(ast) + return ret + } + if (ret) { + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'concat" + types_heap[new_idx][1] = types_addref(ret) + types_heap[new_idx][2] = previous + types_heap[new_idx]["len"] = 3 + } else { + ret = quasiquote(types_addref(elt)) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'cons" + types_heap[new_idx][1] = ret + types_heap[new_idx][2] = previous + types_heap[new_idx]["len"] = 3 + } + } + if (ast ~ /^\[/) { + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'vec" + types_heap[new_idx][1] = previous + types_heap[new_idx]["len"] = 2 + } + types_release(ast) + return "(" new_idx +} + +function is_macro_call(ast, env, idx, len, sym, f) +{ + if (ast !~ /^\(/) return 0 + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 0) return 0 + sym = types_heap[idx][0] + if (sym !~ /^'/) return 0 + f = env_get(env, sym) + return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] +} + +function macroexpand(ast, env, idx, f_idx, new_env) +{ + while (is_macro_call(ast, env)) { + idx = substr(ast, 2) + f_idx = substr(env_get(env, types_heap[idx][0]), 2) + new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + types_release(ast) + if (new_env ~ /^!/) { + return new_env + } + types_addref(ast = types_heap[f_idx]["body"]) + ast = EVAL(ast, new_env) + env_release(new_env) + if (ast ~ /^!/) { + return ast + } + } + return ast +} + +function eval_ast(ast, env, i, idx, len, new_idx, ret) +{ + switch (ast) { + case /^'/: + ret = env_get(env, ast) + if (ret !~ /^!/) { + types_addref(ret) + } + return ret + case /^[([]/: + idx = substr(ast, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_heap[new_idx]["len"] = i + types_release(substr(ast, 1, 1) new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + types_heap[new_idx]["len"] = len + return substr(ast, 1, 1) new_idx + case /^\{/: + idx = substr(ast, 2) + new_idx = types_allocate() + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release("{" new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + } + return "{" new_idx + default: + return ast + } +} + +function EVAL_def(ast, env, idx, sym, ret, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + if (ret !~ /^!/) { + env_set(env, sym, ret) + types_addref(ret) + } + types_release(ast) + env_release(env) + return ret +} + +function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + if (params_len % 2 != 0) { + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." + } + new_env = env_new(env) + env_release(env) + for (i = 0; i < params_len; i += 2) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(new_env) + return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) + if (ret ~ /^!/) { + types_release(ast) + env_release(new_env) + return ret + } + env_set(new_env, sym, ret) + } + types_addref(body = types_heap[idx][2]) + types_release(ast) + ret_env[0] = new_env + return body +} + +function EVAL_defmacro(ast, env, idx, sym, ret, len, fun_idx, mac_idx) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'defmacro!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'defmacro!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + types_release(ast) + if (ret ~ /^!/) { + env_release(env) + return ret + } + if (ret !~ /^\$/) { + types_release(ret) + env_release(env) + return "!\"Incompatible type for argument 2 of 'defmacro!'. Expects function, supplied " types_typename(ret) "." + } + + # Replace `ret` with a clone setting the `is_macro` bit. + fun_idx = substr(ret, 2) + mac_idx = types_allocate() + types_addref(types_heap[mac_idx]["params"] = types_heap[fun_idx]["params"]) + types_addref(types_heap[mac_idx]["body"] = types_heap[fun_idx]["body"]) + env_addref(types_heap[mac_idx]["env"] = types_heap[fun_idx]["env"]) + types_heap[mac_idx]["is_macro"] = 1 + types_release(ret) + ret = "$" mac_idx + + env_set(env, sym, ret) + types_addref(ret) + env_release(env) + return ret +} + +function EVAL_do(ast, env, idx, len, i, body, ret) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 1) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." + } + for (i = 1; i < len - 1; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_release(ret) + } + types_addref(body = types_heap[idx][len - 1]) + types_release(ast) + return body +} + +function EVAL_if(ast, env, idx, len, ret, body) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len != 3 && len != 4) { + types_release(ast) + return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." + } + ret = EVAL(types_addref(types_heap[idx][1]), env) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + types_release(ret) + switch (ret) { + case "#nil": + case "#false": + if (len == 3) { + body = "#nil" + } else { + types_addref(body = types_heap[idx][3]) + } + break + default: + types_addref(body = types_heap[idx][2]) + break + } + types_release(ast) + return body +} + +function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + for (i = 0; i < params_len; ++i) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." + } + if (sym == "'&" && i + 2 != params_len) { + types_release(ast) + env_release(env) + return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." + } + } + f_idx = types_allocate() + types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) + types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) + types_heap[f_idx]["env"] = env + types_release(ast) + return "$" f_idx +} + +function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env) +{ + env_addref(env) + for (;;) { + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + if (types_heap[substr(ast, 2)]["len"] == 0) { + env_release(env) + return ast + } + ast = macroexpand(ast, env) + if (ast ~ /^!/) { + env_release(env) + return ast + } + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + idx = substr(ast, 2) + len = types_heap[idx]["len"] + switch (types_heap[idx][0]) { + case "'def!": + return EVAL_def(ast, env) + case "'let*": + ast = EVAL_let(ast, env, ret_env) + if (ast ~ /^!/) { + return ast + } + env = ret_env[0] + continue + case "'quote": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + env_release(env) + return body + case "'quasiquoteexpand": + env_release(env) + if (len != 2) { + types_release(ast) + return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + return quasiquote(body) + case "'quasiquote": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + ast = quasiquote(body) + if (ast ~ /^!/) { + env_release(env) + return ast + } + continue + case "'defmacro!": + return EVAL_defmacro(ast, env) + case "'macroexpand": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + ret = macroexpand(body, env) + env_release(env) + return ret + case "'do": + ast = EVAL_do(ast, env) + if (ast ~ /^!/) { + return ast + } + continue + case "'if": + ast = EVAL_if(ast, env) + if (ast !~ /^['([{]/) { + env_release(env) + return ast + } + continue + case "'fn*": + return EVAL_fn(ast, env) + default: + new_ast = eval_ast(ast, env) + types_release(ast) + env_release(env) + if (new_ast ~ /^!/) { + return new_ast + } + idx = substr(new_ast, 2) + f = types_heap[idx][0] + f_idx = substr(f, 2) + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + if (env ~ /^!/) { + types_release(new_ast) + return env + } + types_addref(ast = types_heap[f_idx]["body"]) + types_release(new_ast) + continue + case /^&/: + ret = @f_idx(idx) + types_release(new_ast) + return ret + default: + types_release(new_ast) + return "!\"First element of list must be function, supplied " types_typename(f) "." + } + } + } +} + +function PRINT(expr, str) +{ + str = printer_pr_str(expr, 1) + types_release(expr) + return str +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast, repl_env) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function eval(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return EVAL(types_addref(types_heap[idx][1]), repl_env) +} + +function main(str, ret, i, idx) +{ + repl_env = env_new() + for (i in core_ns) { + env_set(repl_env, i, core_ns[i]) + } + + env_set(repl_env, "'eval", "&eval") + + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") + 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)))))))") + + idx = types_allocate() + env_set(repl_env, "'*ARGV*", "(" idx) + if (ARGC > 1) { + for (i = 2; i < ARGC; ++i) { + types_heap[idx][i - 2] = "\"" ARGV[i] + } + types_heap[idx]["len"] = ARGC - 2 + ARGC = 1 + rep("(load-file \"" ARGV[1] "\")") + return + } + types_heap[idx]["len"] = 0 + + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + env_check(0) + env_dump() + types_dump() + exit(0) +} diff --git a/impls/awk/step9_try.awk b/impls/awk/step9_try.awk index d0c4a16d2b..601ecbb4e0 100644 --- a/impls/awk/step9_try.awk +++ b/impls/awk/step9_try.awk @@ -1,637 +1,637 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" -@include "env.awk" -@include "core.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -# Return 0, an error or the unquote argument (second element of ast). -function starts_with(ast, sym, idx, len) -{ - if (ast !~ /^\(/) - return 0 - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (!len || types_heap[idx][0] != sym) - return 0 - if (len != 2) - return "!\"'" sym "' expects 1 argument, not " (len - 1) "." - return types_heap[idx][1] -} - -function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous) -{ - if (ast !~ /^[(['{]/) { - return ast - } - if (ast ~ /['\{]/) { - new_idx = types_allocate() - types_heap[new_idx][0] = "'quote" - types_heap[new_idx][1] = ast - types_heap[new_idx]["len"] = 2 - return "(" new_idx - } - ret = starts_with(ast, "'unquote") - if (ret ~ /^!/) { - types_release(ast) - return ret - } - if (ret) { - types_addref(ret) - types_release(ast) - return ret - } - new_idx = types_allocate() - types_heap[new_idx]["len"] = 0 - ast_idx = substr(ast, 2) - for (elt_i=types_heap[ast_idx]["len"]-1; 0<=elt_i; elt_i--) { - elt = types_heap[ast_idx][elt_i] - ret = starts_with(elt, "'splice-unquote") - if (ret ~ /^!/) { - types_release("(" new_idx) - types_release(ast) - return ret - } - if (ret) { - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'concat" - types_heap[new_idx][1] = types_addref(ret) - types_heap[new_idx][2] = previous - types_heap[new_idx]["len"] = 3 - } else { - ret = quasiquote(types_addref(elt)) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'cons" - types_heap[new_idx][1] = ret - types_heap[new_idx][2] = previous - types_heap[new_idx]["len"] = 3 - } - } - if (ast ~ /^\[/) { - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'vec" - types_heap[new_idx][1] = previous - types_heap[new_idx]["len"] = 2 - } - types_release(ast) - return "(" new_idx -} - -function is_macro_call(ast, env, idx, len, sym, f) -{ - if (ast !~ /^\(/) return 0 - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 0) return 0 - sym = types_heap[idx][0] - if (sym !~ /^'/) return 0 - f = env_get(env, sym) - return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] -} - -function macroexpand(ast, env, idx, f_idx, new_env) -{ - while (is_macro_call(ast, env)) { - idx = substr(ast, 2) - f_idx = substr(env_get(env, types_heap[idx][0]), 2) - new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - types_release(ast) - if (new_env ~ /^!/) { - return new_env - } - types_addref(ast = types_heap[f_idx]["body"]) - ast = EVAL(ast, new_env) - env_release(new_env) - if (ast ~ /^!/) { - return ast - } - } - return ast -} - -function eval_ast(ast, env, i, idx, len, new_idx, ret) -{ - switch (ast) { - case /^'/: - ret = env_get(env, ast) - if (ret !~ /^!/) { - types_addref(ret) - } - return ret - case /^[([]/: - idx = substr(ast, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_heap[new_idx]["len"] = i - types_release(substr(ast, 1, 1) new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - types_heap[new_idx]["len"] = len - return substr(ast, 1, 1) new_idx - case /^\{/: - idx = substr(ast, 2) - new_idx = types_allocate() - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release("{" new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - } - return "{" new_idx - default: - return ast - } -} - -function EVAL_def(ast, env, idx, sym, ret, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - if (ret !~ /^!/) { - env_set(env, sym, ret) - types_addref(ret) - } - types_release(ast) - env_release(env) - return ret -} - -function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - if (params_len % 2 != 0) { - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." - } - new_env = env_new(env) - env_release(env) - for (i = 0; i < params_len; i += 2) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(new_env) - return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) - if (ret ~ /^!/) { - types_release(ast) - env_release(new_env) - return ret - } - env_set(new_env, sym, ret) - } - types_addref(body = types_heap[idx][2]) - types_release(ast) - ret_env[0] = new_env - return body -} - -function EVAL_defmacro(ast, env, idx, sym, ret, len, fun_idx, mac_idx) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'defmacro!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'defmacro!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - types_release(ast) - if (ret ~ /^!/) { - env_release(env) - return ret - } - if (ret !~ /^\$/) { - types_release(ret) - env_release(env) - return "!\"Incompatible type for argument 2 of 'defmacro!'. Expects function, supplied " types_typename(ret) "." - } - - # Replace `ret` with a clone setting the `is_macro` bit. - fun_idx = substr(ret, 2) - mac_idx = types_allocate() - types_addref(types_heap[mac_idx]["params"] = types_heap[fun_idx]["params"]) - types_addref(types_heap[mac_idx]["body"] = types_heap[fun_idx]["body"]) - env_addref(types_heap[mac_idx]["env"] = types_heap[fun_idx]["env"]) - types_heap[mac_idx]["is_macro"] = 1 - types_release(ret) - ret = "$" mac_idx - - env_set(env, sym, ret) - types_addref(ret) - env_release(env) - return ret -} - -function EVAL_try(ast, env, catch_body, catch_env, idx, catch, catch_idx, catch_sym, ret, len, str) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len != 2 && len != 3) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'try*'. Expects 1 or 2 arguments, supplied" (len - 1) "." - } - if (len == 2) { - ret = EVAL(types_addref(types_heap[idx][1]), env) - types_release(ast) - env_release(env) - return ret - } - catch = types_heap[idx][2] - if (catch !~ /^\(/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 2 of 'try*'. Expects list, supplied " types_typename(catch) "." - } - catch_idx = substr(catch, 2) - if (types_heap[catch_idx]["len"] != 3) { - len = types_heap[catch_idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 2 of 'try*'. Expects exactly 3 elements, supplied " len "." - } - if (types_heap[catch_idx][0] != "'catch*") { - str = printer_pr_str(types_heap[catch_idx][0]) - types_release(ast) - env_release(env) - return "!\"Invalid first element of argument 2 of 'try*'. Expects symbol 'catch*', supplied '" str "'." - } - catch_sym = types_heap[catch_idx][1] - if (catch_sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for second element of argument 2 of 'try*'. Expects symbol, supplied " types_typename(catch_sym) "." - } - ret = EVAL(types_addref(types_heap[idx][1]), env) - if (ret !~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_addref(catch_body[0] = types_heap[catch_idx][2]) - catch_env[0] = env_new(env) - env_release(env) - env_set(catch_env[0], catch_sym, substr(ret, 2)) - types_release(ast) - return "" -} - -function EVAL_do(ast, env, idx, len, i, body, ret) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 1) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." - } - for (i = 1; i < len - 1; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_release(ret) - } - types_addref(body = types_heap[idx][len - 1]) - types_release(ast) - return body -} - -function EVAL_if(ast, env, idx, len, ret, body) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len != 3 && len != 4) { - types_release(ast) - return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." - } - ret = EVAL(types_addref(types_heap[idx][1]), env) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - types_release(ret) - switch (ret) { - case "#nil": - case "#false": - if (len == 3) { - body = "#nil" - } else { - types_addref(body = types_heap[idx][3]) - } - break - default: - types_addref(body = types_heap[idx][2]) - break - } - types_release(ast) - return body -} - -function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - for (i = 0; i < params_len; ++i) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." - } - if (sym == "'&" && i + 2 != params_len) { - types_release(ast) - env_release(env) - return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." - } - } - f_idx = types_allocate() - types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) - types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) - types_heap[f_idx]["env"] = env - types_release(ast) - return "$" f_idx -} - -function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret_env) -{ - env_addref(env) - for (;;) { - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - if (types_heap[substr(ast, 2)]["len"] == 0) { - env_release(env) - return ast - } - ast = macroexpand(ast, env) - if (ast ~ /^!/) { - env_release(env) - return ast - } - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - idx = substr(ast, 2) - len = types_heap[idx]["len"] - switch (types_heap[idx][0]) { - case "'def!": - return EVAL_def(ast, env) - case "'let*": - ast = EVAL_let(ast, env, ret_env) - if (ast ~ /^!/) { - return ast - } - env = ret_env[0] - continue - case "'quote": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - env_release(env) - return body - case "'quasiquoteexpand": - env_release(env) - if (len != 2) { - types_release(ast) - return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - return quasiquote(body) - case "'quasiquote": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - ast = quasiquote(body) - if (ast ~ /^!/) { - env_release(env) - return ast - } - continue - case "'defmacro!": - return EVAL_defmacro(ast, env) - case "'macroexpand": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - ret = macroexpand(body, env) - env_release(env) - return ret - case "'try*": - ret = EVAL_try(ast, env, ret_body, ret_env) - if (ret != "") { - return ret - } - ast = ret_body[0] - env = ret_env[0] - continue - case "'do": - ast = EVAL_do(ast, env) - if (ast ~ /^!/) { - return ast - } - continue - case "'if": - ast = EVAL_if(ast, env) - if (ast !~ /^['([{]/) { - env_release(env) - return ast - } - continue - case "'fn*": - return EVAL_fn(ast, env) - default: - new_ast = eval_ast(ast, env) - types_release(ast) - env_release(env) - if (new_ast ~ /^!/) { - return new_ast - } - idx = substr(new_ast, 2) - f = types_heap[idx][0] - f_idx = substr(f, 2) - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - if (env ~ /^!/) { - types_release(new_ast) - return env - } - types_addref(ast = types_heap[f_idx]["body"]) - types_release(new_ast) - continue - case /^&/: - ret = @f_idx(idx) - types_release(new_ast) - return ret - default: - types_release(new_ast) - return "!\"First element of list must be function, supplied " types_typename(f) "." - } - } - } -} - -function PRINT(expr, str) -{ - str = printer_pr_str(expr, 1) - types_release(expr) - return str -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast, repl_env) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function eval(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return EVAL(types_addref(types_heap[idx][1]), repl_env) -} - -function main(str, ret, i, idx) -{ - repl_env = env_new() - for (i in core_ns) { - env_set(repl_env, i, core_ns[i]) - } - - env_set(repl_env, "'eval", "&eval") - - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") - 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)))))))") - - idx = types_allocate() - env_set(repl_env, "'*ARGV*", "(" idx) - if (ARGC > 1) { - for (i = 2; i < ARGC; ++i) { - types_heap[idx][i - 2] = "\"" ARGV[i] - } - types_heap[idx]["len"] = ARGC - 2 - ARGC = 1 - rep("(load-file \"" ARGV[1] "\")") - return - } - types_heap[idx]["len"] = 0 - - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - env_check(0) - env_dump() - types_dump() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" +@include "env.awk" +@include "core.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +# Return 0, an error or the unquote argument (second element of ast). +function starts_with(ast, sym, idx, len) +{ + if (ast !~ /^\(/) + return 0 + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (!len || types_heap[idx][0] != sym) + return 0 + if (len != 2) + return "!\"'" sym "' expects 1 argument, not " (len - 1) "." + return types_heap[idx][1] +} + +function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous) +{ + if (ast !~ /^[(['{]/) { + return ast + } + if (ast ~ /['\{]/) { + new_idx = types_allocate() + types_heap[new_idx][0] = "'quote" + types_heap[new_idx][1] = ast + types_heap[new_idx]["len"] = 2 + return "(" new_idx + } + ret = starts_with(ast, "'unquote") + if (ret ~ /^!/) { + types_release(ast) + return ret + } + if (ret) { + types_addref(ret) + types_release(ast) + return ret + } + new_idx = types_allocate() + types_heap[new_idx]["len"] = 0 + ast_idx = substr(ast, 2) + for (elt_i=types_heap[ast_idx]["len"]-1; 0<=elt_i; elt_i--) { + elt = types_heap[ast_idx][elt_i] + ret = starts_with(elt, "'splice-unquote") + if (ret ~ /^!/) { + types_release("(" new_idx) + types_release(ast) + return ret + } + if (ret) { + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'concat" + types_heap[new_idx][1] = types_addref(ret) + types_heap[new_idx][2] = previous + types_heap[new_idx]["len"] = 3 + } else { + ret = quasiquote(types_addref(elt)) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'cons" + types_heap[new_idx][1] = ret + types_heap[new_idx][2] = previous + types_heap[new_idx]["len"] = 3 + } + } + if (ast ~ /^\[/) { + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'vec" + types_heap[new_idx][1] = previous + types_heap[new_idx]["len"] = 2 + } + types_release(ast) + return "(" new_idx +} + +function is_macro_call(ast, env, idx, len, sym, f) +{ + if (ast !~ /^\(/) return 0 + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 0) return 0 + sym = types_heap[idx][0] + if (sym !~ /^'/) return 0 + f = env_get(env, sym) + return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] +} + +function macroexpand(ast, env, idx, f_idx, new_env) +{ + while (is_macro_call(ast, env)) { + idx = substr(ast, 2) + f_idx = substr(env_get(env, types_heap[idx][0]), 2) + new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + types_release(ast) + if (new_env ~ /^!/) { + return new_env + } + types_addref(ast = types_heap[f_idx]["body"]) + ast = EVAL(ast, new_env) + env_release(new_env) + if (ast ~ /^!/) { + return ast + } + } + return ast +} + +function eval_ast(ast, env, i, idx, len, new_idx, ret) +{ + switch (ast) { + case /^'/: + ret = env_get(env, ast) + if (ret !~ /^!/) { + types_addref(ret) + } + return ret + case /^[([]/: + idx = substr(ast, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_heap[new_idx]["len"] = i + types_release(substr(ast, 1, 1) new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + types_heap[new_idx]["len"] = len + return substr(ast, 1, 1) new_idx + case /^\{/: + idx = substr(ast, 2) + new_idx = types_allocate() + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release("{" new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + } + return "{" new_idx + default: + return ast + } +} + +function EVAL_def(ast, env, idx, sym, ret, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + if (ret !~ /^!/) { + env_set(env, sym, ret) + types_addref(ret) + } + types_release(ast) + env_release(env) + return ret +} + +function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + if (params_len % 2 != 0) { + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." + } + new_env = env_new(env) + env_release(env) + for (i = 0; i < params_len; i += 2) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(new_env) + return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) + if (ret ~ /^!/) { + types_release(ast) + env_release(new_env) + return ret + } + env_set(new_env, sym, ret) + } + types_addref(body = types_heap[idx][2]) + types_release(ast) + ret_env[0] = new_env + return body +} + +function EVAL_defmacro(ast, env, idx, sym, ret, len, fun_idx, mac_idx) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'defmacro!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'defmacro!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + types_release(ast) + if (ret ~ /^!/) { + env_release(env) + return ret + } + if (ret !~ /^\$/) { + types_release(ret) + env_release(env) + return "!\"Incompatible type for argument 2 of 'defmacro!'. Expects function, supplied " types_typename(ret) "." + } + + # Replace `ret` with a clone setting the `is_macro` bit. + fun_idx = substr(ret, 2) + mac_idx = types_allocate() + types_addref(types_heap[mac_idx]["params"] = types_heap[fun_idx]["params"]) + types_addref(types_heap[mac_idx]["body"] = types_heap[fun_idx]["body"]) + env_addref(types_heap[mac_idx]["env"] = types_heap[fun_idx]["env"]) + types_heap[mac_idx]["is_macro"] = 1 + types_release(ret) + ret = "$" mac_idx + + env_set(env, sym, ret) + types_addref(ret) + env_release(env) + return ret +} + +function EVAL_try(ast, env, catch_body, catch_env, idx, catch, catch_idx, catch_sym, ret, len, str) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len != 2 && len != 3) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'try*'. Expects 1 or 2 arguments, supplied" (len - 1) "." + } + if (len == 2) { + ret = EVAL(types_addref(types_heap[idx][1]), env) + types_release(ast) + env_release(env) + return ret + } + catch = types_heap[idx][2] + if (catch !~ /^\(/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 2 of 'try*'. Expects list, supplied " types_typename(catch) "." + } + catch_idx = substr(catch, 2) + if (types_heap[catch_idx]["len"] != 3) { + len = types_heap[catch_idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 2 of 'try*'. Expects exactly 3 elements, supplied " len "." + } + if (types_heap[catch_idx][0] != "'catch*") { + str = printer_pr_str(types_heap[catch_idx][0]) + types_release(ast) + env_release(env) + return "!\"Invalid first element of argument 2 of 'try*'. Expects symbol 'catch*', supplied '" str "'." + } + catch_sym = types_heap[catch_idx][1] + if (catch_sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for second element of argument 2 of 'try*'. Expects symbol, supplied " types_typename(catch_sym) "." + } + ret = EVAL(types_addref(types_heap[idx][1]), env) + if (ret !~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_addref(catch_body[0] = types_heap[catch_idx][2]) + catch_env[0] = env_new(env) + env_release(env) + env_set(catch_env[0], catch_sym, substr(ret, 2)) + types_release(ast) + return "" +} + +function EVAL_do(ast, env, idx, len, i, body, ret) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 1) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." + } + for (i = 1; i < len - 1; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_release(ret) + } + types_addref(body = types_heap[idx][len - 1]) + types_release(ast) + return body +} + +function EVAL_if(ast, env, idx, len, ret, body) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len != 3 && len != 4) { + types_release(ast) + return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." + } + ret = EVAL(types_addref(types_heap[idx][1]), env) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + types_release(ret) + switch (ret) { + case "#nil": + case "#false": + if (len == 3) { + body = "#nil" + } else { + types_addref(body = types_heap[idx][3]) + } + break + default: + types_addref(body = types_heap[idx][2]) + break + } + types_release(ast) + return body +} + +function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + for (i = 0; i < params_len; ++i) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." + } + if (sym == "'&" && i + 2 != params_len) { + types_release(ast) + env_release(env) + return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." + } + } + f_idx = types_allocate() + types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) + types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) + types_heap[f_idx]["env"] = env + types_release(ast) + return "$" f_idx +} + +function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret_env) +{ + env_addref(env) + for (;;) { + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + if (types_heap[substr(ast, 2)]["len"] == 0) { + env_release(env) + return ast + } + ast = macroexpand(ast, env) + if (ast ~ /^!/) { + env_release(env) + return ast + } + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + idx = substr(ast, 2) + len = types_heap[idx]["len"] + switch (types_heap[idx][0]) { + case "'def!": + return EVAL_def(ast, env) + case "'let*": + ast = EVAL_let(ast, env, ret_env) + if (ast ~ /^!/) { + return ast + } + env = ret_env[0] + continue + case "'quote": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + env_release(env) + return body + case "'quasiquoteexpand": + env_release(env) + if (len != 2) { + types_release(ast) + return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + return quasiquote(body) + case "'quasiquote": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + ast = quasiquote(body) + if (ast ~ /^!/) { + env_release(env) + return ast + } + continue + case "'defmacro!": + return EVAL_defmacro(ast, env) + case "'macroexpand": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + ret = macroexpand(body, env) + env_release(env) + return ret + case "'try*": + ret = EVAL_try(ast, env, ret_body, ret_env) + if (ret != "") { + return ret + } + ast = ret_body[0] + env = ret_env[0] + continue + case "'do": + ast = EVAL_do(ast, env) + if (ast ~ /^!/) { + return ast + } + continue + case "'if": + ast = EVAL_if(ast, env) + if (ast !~ /^['([{]/) { + env_release(env) + return ast + } + continue + case "'fn*": + return EVAL_fn(ast, env) + default: + new_ast = eval_ast(ast, env) + types_release(ast) + env_release(env) + if (new_ast ~ /^!/) { + return new_ast + } + idx = substr(new_ast, 2) + f = types_heap[idx][0] + f_idx = substr(f, 2) + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + if (env ~ /^!/) { + types_release(new_ast) + return env + } + types_addref(ast = types_heap[f_idx]["body"]) + types_release(new_ast) + continue + case /^&/: + ret = @f_idx(idx) + types_release(new_ast) + return ret + default: + types_release(new_ast) + return "!\"First element of list must be function, supplied " types_typename(f) "." + } + } + } +} + +function PRINT(expr, str) +{ + str = printer_pr_str(expr, 1) + types_release(expr) + return str +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast, repl_env) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function eval(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return EVAL(types_addref(types_heap[idx][1]), repl_env) +} + +function main(str, ret, i, idx) +{ + repl_env = env_new() + for (i in core_ns) { + env_set(repl_env, i, core_ns[i]) + } + + env_set(repl_env, "'eval", "&eval") + + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") + 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)))))))") + + idx = types_allocate() + env_set(repl_env, "'*ARGV*", "(" idx) + if (ARGC > 1) { + for (i = 2; i < ARGC; ++i) { + types_heap[idx][i - 2] = "\"" ARGV[i] + } + types_heap[idx]["len"] = ARGC - 2 + ARGC = 1 + rep("(load-file \"" ARGV[1] "\")") + return + } + types_heap[idx]["len"] = 0 + + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + env_check(0) + env_dump() + types_dump() + exit(0) +} diff --git a/impls/awk/stepA_mal.awk b/impls/awk/stepA_mal.awk index 045d483a98..efbb181828 100644 --- a/impls/awk/stepA_mal.awk +++ b/impls/awk/stepA_mal.awk @@ -1,641 +1,641 @@ -@include "types.awk" -@include "reader.awk" -@include "printer.awk" -@include "env.awk" -@include "core.awk" - -function READ(str) -{ - return reader_read_str(str) -} - -# Return 0, an error or the unquote argument (second element of ast). -function starts_with(ast, sym, idx, len) -{ - if (ast !~ /^\(/) - return 0 - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (!len || types_heap[idx][0] != sym) - return 0 - if (len != 2) - return "!\"'" sym "' expects 1 argument, not " (len - 1) "." - return types_heap[idx][1] -} - -function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous) -{ - if (ast !~ /^[(['{]/) { - return ast - } - if (ast ~ /['\{]/) { - new_idx = types_allocate() - types_heap[new_idx][0] = "'quote" - types_heap[new_idx][1] = ast - types_heap[new_idx]["len"] = 2 - return "(" new_idx - } - ret = starts_with(ast, "'unquote") - if (ret ~ /^!/) { - types_release(ast) - return ret - } - if (ret) { - types_addref(ret) - types_release(ast) - return ret - } - new_idx = types_allocate() - types_heap[new_idx]["len"] = 0 - ast_idx = substr(ast, 2) - for (elt_i=types_heap[ast_idx]["len"]-1; 0<=elt_i; elt_i--) { - elt = types_heap[ast_idx][elt_i] - ret = starts_with(elt, "'splice-unquote") - if (ret ~ /^!/) { - types_release("(" new_idx) - types_release(ast) - return ret - } - if (ret) { - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'concat" - types_heap[new_idx][1] = types_addref(ret) - types_heap[new_idx][2] = previous - types_heap[new_idx]["len"] = 3 - } else { - ret = quasiquote(types_addref(elt)) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'cons" - types_heap[new_idx][1] = ret - types_heap[new_idx][2] = previous - types_heap[new_idx]["len"] = 3 - } - } - if (ast ~ /^\[/) { - previous = "(" new_idx - new_idx = types_allocate() - types_heap[new_idx][0] = "'vec" - types_heap[new_idx][1] = previous - types_heap[new_idx]["len"] = 2 - } - types_release(ast) - return "(" new_idx -} - -function is_macro_call(ast, env, idx, len, sym, f) -{ - if (ast !~ /^\(/) return 0 - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 0) return 0 - sym = types_heap[idx][0] - if (sym !~ /^'/) return 0 - f = env_get(env, sym) - return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] -} - -function macroexpand(ast, env, idx, f_idx, new_env) -{ - while (is_macro_call(ast, env)) { - idx = substr(ast, 2) - f_idx = substr(env_get(env, types_heap[idx][0]), 2) - new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - types_release(ast) - if (new_env ~ /^!/) { - return new_env - } - types_addref(ast = types_heap[f_idx]["body"]) - ast = EVAL(ast, new_env) - env_release(new_env) - if (ast ~ /^!/) { - return ast - } - } - return ast -} - -function eval_ast(ast, env, i, idx, len, new_idx, ret) -{ - switch (ast) { - case /^'/: - ret = env_get(env, ast) - if (ret !~ /^!/) { - types_addref(ret) - } - return ret - case /^[([]/: - idx = substr(ast, 2) - len = types_heap[idx]["len"] - new_idx = types_allocate() - for (i = 0; i < len; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_heap[new_idx]["len"] = i - types_release(substr(ast, 1, 1) new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - types_heap[new_idx]["len"] = len - return substr(ast, 1, 1) new_idx - case /^\{/: - idx = substr(ast, 2) - new_idx = types_allocate() - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release("{" new_idx) - return ret - } - types_heap[new_idx][i] = ret - } - } - return "{" new_idx - default: - return ast - } -} - -function EVAL_def(ast, env, idx, sym, ret, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - if (ret !~ /^!/) { - env_set(env, sym, ret) - types_addref(ret) - } - types_release(ast) - env_release(env) - return ret -} - -function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - if (params_len % 2 != 0) { - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." - } - new_env = env_new(env) - env_release(env) - for (i = 0; i < params_len; i += 2) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(new_env) - return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) - if (ret ~ /^!/) { - types_release(ast) - env_release(new_env) - return ret - } - env_set(new_env, sym, ret) - } - types_addref(body = types_heap[idx][2]) - types_release(ast) - ret_env[0] = new_env - return body -} - -function EVAL_defmacro(ast, env, idx, sym, ret, len, fun_idx, mac_idx) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'defmacro!'. Expects exactly 2 arguments, supplied" (len - 1) "." - } - sym = types_heap[idx][1] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'defmacro!'. Expects symbol, supplied " types_typename(sym) "." - } - ret = EVAL(types_addref(types_heap[idx][2]), env) - types_release(ast) - if (ret ~ /^!/) { - env_release(env) - return ret - } - if (ret !~ /^\$/) { - types_release(ret) - env_release(env) - return "!\"Incompatible type for argument 2 of 'defmacro!'. Expects function, supplied " types_typename(ret) "." - } - - # Replace `ret` with a clone setting the `is_macro` bit. - fun_idx = substr(ret, 2) - mac_idx = types_allocate() - types_addref(types_heap[mac_idx]["params"] = types_heap[fun_idx]["params"]) - types_addref(types_heap[mac_idx]["body"] = types_heap[fun_idx]["body"]) - env_addref(types_heap[mac_idx]["env"] = types_heap[fun_idx]["env"]) - types_heap[mac_idx]["is_macro"] = 1 - types_release(ret) - ret = "$" mac_idx - - env_set(env, sym, ret) - types_addref(ret) - env_release(env) - return ret -} - -function EVAL_try(ast, env, catch_body, catch_env, idx, catch, catch_idx, catch_sym, ret, len, str) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len != 2 && len != 3) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'try*'. Expects 1 or 2 arguments, supplied" (len - 1) "." - } - if (len == 2) { - ret = EVAL(types_addref(types_heap[idx][1]), env) - types_release(ast) - env_release(env) - return ret - } - catch = types_heap[idx][2] - if (catch !~ /^\(/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 2 of 'try*'. Expects list, supplied " types_typename(catch) "." - } - catch_idx = substr(catch, 2) - if (types_heap[catch_idx]["len"] != 3) { - len = types_heap[catch_idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid elements count for argument 2 of 'try*'. Expects exactly 3 elements, supplied " len "." - } - if (types_heap[catch_idx][0] != "'catch*") { - str = printer_pr_str(types_heap[catch_idx][0]) - types_release(ast) - env_release(env) - return "!\"Invalid first element of argument 2 of 'try*'. Expects symbol 'catch*', supplied '" str "'." - } - catch_sym = types_heap[catch_idx][1] - if (catch_sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for second element of argument 2 of 'try*'. Expects symbol, supplied " types_typename(catch_sym) "." - } - ret = EVAL(types_addref(types_heap[idx][1]), env) - if (ret !~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_addref(catch_body[0] = types_heap[catch_idx][2]) - catch_env[0] = env_new(env) - env_release(env) - env_set(catch_env[0], catch_sym, substr(ret, 2)) - types_release(ast) - return "" -} - -function EVAL_do(ast, env, idx, len, i, body, ret) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len == 1) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." - } - for (i = 1; i < len - 1; ++i) { - ret = EVAL(types_addref(types_heap[idx][i]), env) - if (ret ~ /^!/) { - types_release(ast) - env_release(env) - return ret - } - types_release(ret) - } - types_addref(body = types_heap[idx][len - 1]) - types_release(ast) - return body -} - -function EVAL_if(ast, env, idx, len, ret, body) -{ - idx = substr(ast, 2) - len = types_heap[idx]["len"] - if (len != 3 && len != 4) { - types_release(ast) - return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." - } - ret = EVAL(types_addref(types_heap[idx][1]), env) - if (ret ~ /^!/) { - types_release(ast) - return ret - } - types_release(ret) - switch (ret) { - case "#nil": - case "#false": - if (len == 3) { - body = "#nil" - } else { - types_addref(body = types_heap[idx][3]) - } - break - default: - types_addref(body = types_heap[idx][2]) - break - } - types_release(ast) - return body -} - -function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) -{ - idx = substr(ast, 2) - if (types_heap[idx]["len"] != 3) { - len = types_heap[idx]["len"] - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." - } - params = types_heap[idx][1] - if (params !~ /^[([]/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." - } - params_idx = substr(params, 2) - params_len = types_heap[params_idx]["len"] - for (i = 0; i < params_len; ++i) { - sym = types_heap[params_idx][i] - if (sym !~ /^'/) { - types_release(ast) - env_release(env) - return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." - } - if (sym == "'&" && i + 2 != params_len) { - types_release(ast) - env_release(env) - return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." - } - } - f_idx = types_allocate() - types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) - types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) - types_heap[f_idx]["env"] = env - types_release(ast) - return "$" f_idx -} - -function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret_env) -{ - env_addref(env) - for (;;) { - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - if (types_heap[substr(ast, 2)]["len"] == 0) { - env_release(env) - return ast - } - ast = macroexpand(ast, env) - if (ast ~ /^!/) { - env_release(env) - return ast - } - if (ast !~ /^\(/) { - ret = eval_ast(ast, env) - types_release(ast) - env_release(env) - return ret - } - idx = substr(ast, 2) - len = types_heap[idx]["len"] - switch (types_heap[idx][0]) { - case "'def!": - return EVAL_def(ast, env) - case "'let*": - ast = EVAL_let(ast, env, ret_env) - if (ast ~ /^!/) { - return ast - } - env = ret_env[0] - continue - case "'quote": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - env_release(env) - return body - case "'quasiquoteexpand": - env_release(env) - if (len != 2) { - types_release(ast) - return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - return quasiquote(body) - case "'quasiquote": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - ast = quasiquote(body) - if (ast ~ /^!/) { - env_release(env) - return ast - } - continue - case "'defmacro!": - return EVAL_defmacro(ast, env) - case "'macroexpand": - if (len != 2) { - types_release(ast) - env_release(env) - return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "." - } - types_addref(body = types_heap[idx][1]) - types_release(ast) - ret = macroexpand(body, env) - env_release(env) - return ret - case "'try*": - ret = EVAL_try(ast, env, ret_body, ret_env) - if (ret != "") { - return ret - } - ast = ret_body[0] - env = ret_env[0] - continue - case "'do": - ast = EVAL_do(ast, env) - if (ast ~ /^!/) { - return ast - } - continue - case "'if": - ast = EVAL_if(ast, env) - if (ast !~ /^['([{]/) { - env_release(env) - return ast - } - continue - case "'fn*": - return EVAL_fn(ast, env) - default: - new_ast = eval_ast(ast, env) - types_release(ast) - env_release(env) - if (new_ast ~ /^!/) { - return new_ast - } - idx = substr(new_ast, 2) - f = types_heap[idx][0] - f_idx = substr(f, 2) - switch (f) { - case /^\$/: - env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) - if (env ~ /^!/) { - types_release(new_ast) - return env - } - types_addref(ast = types_heap[f_idx]["body"]) - types_release(new_ast) - continue - case /^%/: - f_idx = types_heap[f_idx]["func"] - case /^&/: - ret = @f_idx(idx) - types_release(new_ast) - return ret - default: - types_release(new_ast) - return "!\"First element of list must be function, supplied " types_typename(f) "." - } - } - } -} - -function PRINT(expr, str) -{ - str = printer_pr_str(expr, 1) - types_release(expr) - return str -} - -function rep(str, ast, expr) -{ - ast = READ(str) - if (ast ~ /^!/) { - return ast - } - expr = EVAL(ast, repl_env) - if (expr ~ /^!/) { - return expr - } - return PRINT(expr) -} - -function eval(idx) -{ - if (types_heap[idx]["len"] != 2) { - return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." - } - return EVAL(types_addref(types_heap[idx][1]), repl_env) -} - -function main(str, ret, i, idx) -{ - repl_env = env_new() - for (i in core_ns) { - env_set(repl_env, i, core_ns[i]) - } - - env_set(repl_env, "'eval", "&eval") - - rep("(def! *host-language* \"GNU awk\")") - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") - 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)))))))") - - idx = types_allocate() - env_set(repl_env, "'*ARGV*", "(" idx) - if (ARGC > 1) { - for (i = 2; i < ARGC; ++i) { - types_heap[idx][i - 2] = "\"" ARGV[i] - } - types_heap[idx]["len"] = ARGC - 2 - ARGC = 1 - rep("(load-file \"" ARGV[1] "\")") - return - } - types_heap[idx]["len"] = 0 - - rep("(println (str \"Mal [\" *host-language* \"]\"))") - while (1) { - printf("user> ") - if (getline str <= 0) { - break - } - ret = rep(str) - if (ret ~ /^!/) { - print "ERROR: " printer_pr_str(substr(ret, 2)) - } else { - print ret - } - } -} - -BEGIN { - main() - env_check(0) - env_dump() - types_dump() - exit(0) -} +@include "types.awk" +@include "reader.awk" +@include "printer.awk" +@include "env.awk" +@include "core.awk" + +function READ(str) +{ + return reader_read_str(str) +} + +# Return 0, an error or the unquote argument (second element of ast). +function starts_with(ast, sym, idx, len) +{ + if (ast !~ /^\(/) + return 0 + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (!len || types_heap[idx][0] != sym) + return 0 + if (len != 2) + return "!\"'" sym "' expects 1 argument, not " (len - 1) "." + return types_heap[idx][1] +} + +function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous) +{ + if (ast !~ /^[(['{]/) { + return ast + } + if (ast ~ /['\{]/) { + new_idx = types_allocate() + types_heap[new_idx][0] = "'quote" + types_heap[new_idx][1] = ast + types_heap[new_idx]["len"] = 2 + return "(" new_idx + } + ret = starts_with(ast, "'unquote") + if (ret ~ /^!/) { + types_release(ast) + return ret + } + if (ret) { + types_addref(ret) + types_release(ast) + return ret + } + new_idx = types_allocate() + types_heap[new_idx]["len"] = 0 + ast_idx = substr(ast, 2) + for (elt_i=types_heap[ast_idx]["len"]-1; 0<=elt_i; elt_i--) { + elt = types_heap[ast_idx][elt_i] + ret = starts_with(elt, "'splice-unquote") + if (ret ~ /^!/) { + types_release("(" new_idx) + types_release(ast) + return ret + } + if (ret) { + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'concat" + types_heap[new_idx][1] = types_addref(ret) + types_heap[new_idx][2] = previous + types_heap[new_idx]["len"] = 3 + } else { + ret = quasiquote(types_addref(elt)) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'cons" + types_heap[new_idx][1] = ret + types_heap[new_idx][2] = previous + types_heap[new_idx]["len"] = 3 + } + } + if (ast ~ /^\[/) { + previous = "(" new_idx + new_idx = types_allocate() + types_heap[new_idx][0] = "'vec" + types_heap[new_idx][1] = previous + types_heap[new_idx]["len"] = 2 + } + types_release(ast) + return "(" new_idx +} + +function is_macro_call(ast, env, idx, len, sym, f) +{ + if (ast !~ /^\(/) return 0 + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 0) return 0 + sym = types_heap[idx][0] + if (sym !~ /^'/) return 0 + f = env_get(env, sym) + return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] +} + +function macroexpand(ast, env, idx, f_idx, new_env) +{ + while (is_macro_call(ast, env)) { + idx = substr(ast, 2) + f_idx = substr(env_get(env, types_heap[idx][0]), 2) + new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + types_release(ast) + if (new_env ~ /^!/) { + return new_env + } + types_addref(ast = types_heap[f_idx]["body"]) + ast = EVAL(ast, new_env) + env_release(new_env) + if (ast ~ /^!/) { + return ast + } + } + return ast +} + +function eval_ast(ast, env, i, idx, len, new_idx, ret) +{ + switch (ast) { + case /^'/: + ret = env_get(env, ast) + if (ret !~ /^!/) { + types_addref(ret) + } + return ret + case /^[([]/: + idx = substr(ast, 2) + len = types_heap[idx]["len"] + new_idx = types_allocate() + for (i = 0; i < len; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_heap[new_idx]["len"] = i + types_release(substr(ast, 1, 1) new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + types_heap[new_idx]["len"] = len + return substr(ast, 1, 1) new_idx + case /^\{/: + idx = substr(ast, 2) + new_idx = types_allocate() + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release("{" new_idx) + return ret + } + types_heap[new_idx][i] = ret + } + } + return "{" new_idx + default: + return ast + } +} + +function EVAL_def(ast, env, idx, sym, ret, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + if (ret !~ /^!/) { + env_set(env, sym, ret) + types_addref(ret) + } + types_release(ast) + env_release(env) + return ret +} + +function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + if (params_len % 2 != 0) { + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." + } + new_env = env_new(env) + env_release(env) + for (i = 0; i < params_len; i += 2) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(new_env) + return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) + if (ret ~ /^!/) { + types_release(ast) + env_release(new_env) + return ret + } + env_set(new_env, sym, ret) + } + types_addref(body = types_heap[idx][2]) + types_release(ast) + ret_env[0] = new_env + return body +} + +function EVAL_defmacro(ast, env, idx, sym, ret, len, fun_idx, mac_idx) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'defmacro!'. Expects exactly 2 arguments, supplied" (len - 1) "." + } + sym = types_heap[idx][1] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'defmacro!'. Expects symbol, supplied " types_typename(sym) "." + } + ret = EVAL(types_addref(types_heap[idx][2]), env) + types_release(ast) + if (ret ~ /^!/) { + env_release(env) + return ret + } + if (ret !~ /^\$/) { + types_release(ret) + env_release(env) + return "!\"Incompatible type for argument 2 of 'defmacro!'. Expects function, supplied " types_typename(ret) "." + } + + # Replace `ret` with a clone setting the `is_macro` bit. + fun_idx = substr(ret, 2) + mac_idx = types_allocate() + types_addref(types_heap[mac_idx]["params"] = types_heap[fun_idx]["params"]) + types_addref(types_heap[mac_idx]["body"] = types_heap[fun_idx]["body"]) + env_addref(types_heap[mac_idx]["env"] = types_heap[fun_idx]["env"]) + types_heap[mac_idx]["is_macro"] = 1 + types_release(ret) + ret = "$" mac_idx + + env_set(env, sym, ret) + types_addref(ret) + env_release(env) + return ret +} + +function EVAL_try(ast, env, catch_body, catch_env, idx, catch, catch_idx, catch_sym, ret, len, str) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len != 2 && len != 3) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'try*'. Expects 1 or 2 arguments, supplied" (len - 1) "." + } + if (len == 2) { + ret = EVAL(types_addref(types_heap[idx][1]), env) + types_release(ast) + env_release(env) + return ret + } + catch = types_heap[idx][2] + if (catch !~ /^\(/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 2 of 'try*'. Expects list, supplied " types_typename(catch) "." + } + catch_idx = substr(catch, 2) + if (types_heap[catch_idx]["len"] != 3) { + len = types_heap[catch_idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid elements count for argument 2 of 'try*'. Expects exactly 3 elements, supplied " len "." + } + if (types_heap[catch_idx][0] != "'catch*") { + str = printer_pr_str(types_heap[catch_idx][0]) + types_release(ast) + env_release(env) + return "!\"Invalid first element of argument 2 of 'try*'. Expects symbol 'catch*', supplied '" str "'." + } + catch_sym = types_heap[catch_idx][1] + if (catch_sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for second element of argument 2 of 'try*'. Expects symbol, supplied " types_typename(catch_sym) "." + } + ret = EVAL(types_addref(types_heap[idx][1]), env) + if (ret !~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_addref(catch_body[0] = types_heap[catch_idx][2]) + catch_env[0] = env_new(env) + env_release(env) + env_set(catch_env[0], catch_sym, substr(ret, 2)) + types_release(ast) + return "" +} + +function EVAL_do(ast, env, idx, len, i, body, ret) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len == 1) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." + } + for (i = 1; i < len - 1; ++i) { + ret = EVAL(types_addref(types_heap[idx][i]), env) + if (ret ~ /^!/) { + types_release(ast) + env_release(env) + return ret + } + types_release(ret) + } + types_addref(body = types_heap[idx][len - 1]) + types_release(ast) + return body +} + +function EVAL_if(ast, env, idx, len, ret, body) +{ + idx = substr(ast, 2) + len = types_heap[idx]["len"] + if (len != 3 && len != 4) { + types_release(ast) + return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." + } + ret = EVAL(types_addref(types_heap[idx][1]), env) + if (ret ~ /^!/) { + types_release(ast) + return ret + } + types_release(ret) + switch (ret) { + case "#nil": + case "#false": + if (len == 3) { + body = "#nil" + } else { + types_addref(body = types_heap[idx][3]) + } + break + default: + types_addref(body = types_heap[idx][2]) + break + } + types_release(ast) + return body +} + +function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) +{ + idx = substr(ast, 2) + if (types_heap[idx]["len"] != 3) { + len = types_heap[idx]["len"] + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." + } + params = types_heap[idx][1] + if (params !~ /^[([]/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." + } + params_idx = substr(params, 2) + params_len = types_heap[params_idx]["len"] + for (i = 0; i < params_len; ++i) { + sym = types_heap[params_idx][i] + if (sym !~ /^'/) { + types_release(ast) + env_release(env) + return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." + } + if (sym == "'&" && i + 2 != params_len) { + types_release(ast) + env_release(env) + return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." + } + } + f_idx = types_allocate() + types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) + types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) + types_heap[f_idx]["env"] = env + types_release(ast) + return "$" f_idx +} + +function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret_env) +{ + env_addref(env) + for (;;) { + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + if (types_heap[substr(ast, 2)]["len"] == 0) { + env_release(env) + return ast + } + ast = macroexpand(ast, env) + if (ast ~ /^!/) { + env_release(env) + return ast + } + if (ast !~ /^\(/) { + ret = eval_ast(ast, env) + types_release(ast) + env_release(env) + return ret + } + idx = substr(ast, 2) + len = types_heap[idx]["len"] + switch (types_heap[idx][0]) { + case "'def!": + return EVAL_def(ast, env) + case "'let*": + ast = EVAL_let(ast, env, ret_env) + if (ast ~ /^!/) { + return ast + } + env = ret_env[0] + continue + case "'quote": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + env_release(env) + return body + case "'quasiquoteexpand": + env_release(env) + if (len != 2) { + types_release(ast) + return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + return quasiquote(body) + case "'quasiquote": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + ast = quasiquote(body) + if (ast ~ /^!/) { + env_release(env) + return ast + } + continue + case "'defmacro!": + return EVAL_defmacro(ast, env) + case "'macroexpand": + if (len != 2) { + types_release(ast) + env_release(env) + return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "." + } + types_addref(body = types_heap[idx][1]) + types_release(ast) + ret = macroexpand(body, env) + env_release(env) + return ret + case "'try*": + ret = EVAL_try(ast, env, ret_body, ret_env) + if (ret != "") { + return ret + } + ast = ret_body[0] + env = ret_env[0] + continue + case "'do": + ast = EVAL_do(ast, env) + if (ast ~ /^!/) { + return ast + } + continue + case "'if": + ast = EVAL_if(ast, env) + if (ast !~ /^['([{]/) { + env_release(env) + return ast + } + continue + case "'fn*": + return EVAL_fn(ast, env) + default: + new_ast = eval_ast(ast, env) + types_release(ast) + env_release(env) + if (new_ast ~ /^!/) { + return new_ast + } + idx = substr(new_ast, 2) + f = types_heap[idx][0] + f_idx = substr(f, 2) + switch (f) { + case /^\$/: + env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) + if (env ~ /^!/) { + types_release(new_ast) + return env + } + types_addref(ast = types_heap[f_idx]["body"]) + types_release(new_ast) + continue + case /^%/: + f_idx = types_heap[f_idx]["func"] + case /^&/: + ret = @f_idx(idx) + types_release(new_ast) + return ret + default: + types_release(new_ast) + return "!\"First element of list must be function, supplied " types_typename(f) "." + } + } + } +} + +function PRINT(expr, str) +{ + str = printer_pr_str(expr, 1) + types_release(expr) + return str +} + +function rep(str, ast, expr) +{ + ast = READ(str) + if (ast ~ /^!/) { + return ast + } + expr = EVAL(ast, repl_env) + if (expr ~ /^!/) { + return expr + } + return PRINT(expr) +} + +function eval(idx) +{ + if (types_heap[idx]["len"] != 2) { + return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." + } + return EVAL(types_addref(types_heap[idx][1]), repl_env) +} + +function main(str, ret, i, idx) +{ + repl_env = env_new() + for (i in core_ns) { + env_set(repl_env, i, core_ns[i]) + } + + env_set(repl_env, "'eval", "&eval") + + rep("(def! *host-language* \"GNU awk\")") + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") + 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)))))))") + + idx = types_allocate() + env_set(repl_env, "'*ARGV*", "(" idx) + if (ARGC > 1) { + for (i = 2; i < ARGC; ++i) { + types_heap[idx][i - 2] = "\"" ARGV[i] + } + types_heap[idx]["len"] = ARGC - 2 + ARGC = 1 + rep("(load-file \"" ARGV[1] "\")") + return + } + types_heap[idx]["len"] = 0 + + rep("(println (str \"Mal [\" *host-language* \"]\"))") + while (1) { + printf("user> ") + if (getline str <= 0) { + break + } + ret = rep(str) + if (ret ~ /^!/) { + print "ERROR: " printer_pr_str(substr(ret, 2)) + } else { + print ret + } + } +} + +BEGIN { + main() + env_check(0) + env_dump() + types_dump() + exit(0) +} diff --git a/impls/awk/tests/step5_tco.mal b/impls/awk/tests/step5_tco.mal index b0bfbe0470..4f1f8e1f22 100644 --- a/impls/awk/tests/step5_tco.mal +++ b/impls/awk/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; awk: skipping non-TCO recursion -;; Reason: completes up to 50,000 +;; awk: skipping non-TCO recursion +;; Reason: completes up to 50,000 diff --git a/impls/awk/types.awk b/impls/awk/types.awk index 68410ce499..3087173140 100644 --- a/impls/awk/types.awk +++ b/impls/awk/types.awk @@ -1,218 +1,218 @@ - -# string" -# symbol ' -# keyword : -# number + -# nil # -# true # -# false # -# list ( -# vector [ -# hash { -# atom ? -# builtin function & -# builtin function with meta % -# user defined function $ - -function types_allocate() -{ - types_heap[types_heap_index]["ref"] = 1 - return types_heap_index++ -} - -function types_addref(ast) -{ - if (ast ~ /^[([{$%?]/) { - ++types_heap[substr(ast, 2)]["ref"] - } - return ast -} - -function types_release(ast, idx, ref, i, len) -{ - switch (ast) { - case /^[([]/: - idx = substr(ast, 2) - ref = --types_heap[idx]["ref"] - if (ref <= 0) { - if (ref < 0) { - print "ref count error:" ast ", " ref - } - len = types_heap[idx]["len"] - for (i = 0; i < len; ++i) { - types_release(types_heap[idx][i]) - } - types_release(types_heap[idx]["meta"]) - delete types_heap[idx] - } - return - case /^\{/: - idx = substr(ast, 2) - ref = --types_heap[idx]["ref"] - if (ref <= 0) { - if (ref < 0) { - print "ref count error:" ast ", " ref - } - for (i in types_heap[idx]) { - if (i ~ /^[":]/) { - types_release(types_heap[idx][i]) - } - } - types_release(types_heap[idx]["meta"]) - delete types_heap[idx] - } - return - case /^\$/: - idx = substr(ast, 2) - ref = --types_heap[idx]["ref"] - if (ref <= 0) { - if (ref < 0) { - print "ref count error:" ast ", " ref - } - types_release(types_heap[idx]["params"]) - types_release(types_heap[idx]["body"]) - types_release(types_heap[idx]["meta"]) - env_release(types_heap[idx]["env"]) - delete types_heap[idx] - } - return - case /^%/: - idx = substr(ast, 2) - ref = --types_heap[idx]["ref"] - if (ref <= 0) { - if (ref < 0) { - print "ref count error:" ast ", " ref - } - types_release(types_heap[idx]["meta"]) - delete types_heap[idx] - } - return - case /^\?/: - idx = substr(ast, 2) - ref = --types_heap[idx]["ref"] - if (ref <= 0) { - if (ref < 0) { - print "ref count error:" ast ", " ref - } - types_release(types_heap[idx]["obj"]) - delete types_heap[idx] - } - } -} - -function types_check(val, idx, len, i) -{ - if (val !~ /^[([{?%$]/) { - return - } - idx = substr(val, 2) - if (!(idx in types_heap)) { - print "dangling reference " val - return - } - if (types_heap[idx]["checked"]++) { - return - } - #types_heap[idx]["checked"] = 1 - switch (val) { - case /^[([]/: - if (!("len" in types_heap[idx])) { - print "length not found in " val - return - } - len = types_heap[idx]["len"] - for (i = 0; i < len; ++i) { - if (!(i in types_heap[idx])) { - print "sequence corrupted in " val " of " i - } else { - types_check(types_heap[idx][i]) - } - } - types_check(types_heap[idx]["meta"]) - return - case /^\{/: - for (i in types_heap[idx]) { - if (i != "ref") { - types_check(types_heap[idx][i]) - } - } - return - case /^\?/: - if (!("obj" in types_heap[idx])) { - print "atom corrupted in " val - } else { - types_check(types_heap[idx]["obj"]) - } - types_check(types_heap[idx]["meta"]) - return - case /^%/: - if (!("func" in types_heap[idx])) { - print "function corrupted in " val - } else { - types_check(types_heap[idx]["func"]) - } - types_check(types_heap[idx]["meta"]) - return - case /^\$/: - if (!("body" in types_heap[idx])) { - print "function body corrupted in " val - } else { - types_check(types_heap[idx]["body"]) - } - if (!("params" in types_heap[idx])) { - print "function params corrupted in " val - } else { - types_check(types_heap[idx]["params"]) - } - if (!("env" in types_heap[idx])) { - print "function env corrupted in " val - } else { - env_check(types_heap[idx]["env"]) - } - types_check(types_heap[idx]["meta"]) - return - default: - print "unknown type " val - return - } -} - -function types_dump(i, j) -{ - for (i = 0; i < types_heap_index; i++) { - if (i in types_heap) { - if (isarray(types_heap[i])) { - if (!("checked" in types_heap[i]) || types_heap[i]["checked"] != types_heap[i]["ref"]) { - for (j in types_heap[i]) { - print " types_heap[" i "][" j "] = " types_heap[i][j] - } - } - } else { - print " types_heap[" i "] = " types_heap[i] - } - } - } -} - -function types_typename(str) -{ - switch (str) { - case /^"/: return "string" - case /^'/: return "symbol" - case /^:/: return "keyword" - case /^\+/: return "number" - case /^#nil$/: return "nil" - case /^#true$/: return "true" - case /^#false$/: return "false" - case /^\(/: return "list" - case /^\[/: return "vector" - case /^\{/: return "hash" - case /^\?/: return "atom" - case /^[&%]/: return "builtin function" - case /^\$/: return "user defined function" - } -} - -BEGIN { - types_heap_index = 0 -} + +# string" +# symbol ' +# keyword : +# number + +# nil # +# true # +# false # +# list ( +# vector [ +# hash { +# atom ? +# builtin function & +# builtin function with meta % +# user defined function $ + +function types_allocate() +{ + types_heap[types_heap_index]["ref"] = 1 + return types_heap_index++ +} + +function types_addref(ast) +{ + if (ast ~ /^[([{$%?]/) { + ++types_heap[substr(ast, 2)]["ref"] + } + return ast +} + +function types_release(ast, idx, ref, i, len) +{ + switch (ast) { + case /^[([]/: + idx = substr(ast, 2) + ref = --types_heap[idx]["ref"] + if (ref <= 0) { + if (ref < 0) { + print "ref count error:" ast ", " ref + } + len = types_heap[idx]["len"] + for (i = 0; i < len; ++i) { + types_release(types_heap[idx][i]) + } + types_release(types_heap[idx]["meta"]) + delete types_heap[idx] + } + return + case /^\{/: + idx = substr(ast, 2) + ref = --types_heap[idx]["ref"] + if (ref <= 0) { + if (ref < 0) { + print "ref count error:" ast ", " ref + } + for (i in types_heap[idx]) { + if (i ~ /^[":]/) { + types_release(types_heap[idx][i]) + } + } + types_release(types_heap[idx]["meta"]) + delete types_heap[idx] + } + return + case /^\$/: + idx = substr(ast, 2) + ref = --types_heap[idx]["ref"] + if (ref <= 0) { + if (ref < 0) { + print "ref count error:" ast ", " ref + } + types_release(types_heap[idx]["params"]) + types_release(types_heap[idx]["body"]) + types_release(types_heap[idx]["meta"]) + env_release(types_heap[idx]["env"]) + delete types_heap[idx] + } + return + case /^%/: + idx = substr(ast, 2) + ref = --types_heap[idx]["ref"] + if (ref <= 0) { + if (ref < 0) { + print "ref count error:" ast ", " ref + } + types_release(types_heap[idx]["meta"]) + delete types_heap[idx] + } + return + case /^\?/: + idx = substr(ast, 2) + ref = --types_heap[idx]["ref"] + if (ref <= 0) { + if (ref < 0) { + print "ref count error:" ast ", " ref + } + types_release(types_heap[idx]["obj"]) + delete types_heap[idx] + } + } +} + +function types_check(val, idx, len, i) +{ + if (val !~ /^[([{?%$]/) { + return + } + idx = substr(val, 2) + if (!(idx in types_heap)) { + print "dangling reference " val + return + } + if (types_heap[idx]["checked"]++) { + return + } + #types_heap[idx]["checked"] = 1 + switch (val) { + case /^[([]/: + if (!("len" in types_heap[idx])) { + print "length not found in " val + return + } + len = types_heap[idx]["len"] + for (i = 0; i < len; ++i) { + if (!(i in types_heap[idx])) { + print "sequence corrupted in " val " of " i + } else { + types_check(types_heap[idx][i]) + } + } + types_check(types_heap[idx]["meta"]) + return + case /^\{/: + for (i in types_heap[idx]) { + if (i != "ref") { + types_check(types_heap[idx][i]) + } + } + return + case /^\?/: + if (!("obj" in types_heap[idx])) { + print "atom corrupted in " val + } else { + types_check(types_heap[idx]["obj"]) + } + types_check(types_heap[idx]["meta"]) + return + case /^%/: + if (!("func" in types_heap[idx])) { + print "function corrupted in " val + } else { + types_check(types_heap[idx]["func"]) + } + types_check(types_heap[idx]["meta"]) + return + case /^\$/: + if (!("body" in types_heap[idx])) { + print "function body corrupted in " val + } else { + types_check(types_heap[idx]["body"]) + } + if (!("params" in types_heap[idx])) { + print "function params corrupted in " val + } else { + types_check(types_heap[idx]["params"]) + } + if (!("env" in types_heap[idx])) { + print "function env corrupted in " val + } else { + env_check(types_heap[idx]["env"]) + } + types_check(types_heap[idx]["meta"]) + return + default: + print "unknown type " val + return + } +} + +function types_dump(i, j) +{ + for (i = 0; i < types_heap_index; i++) { + if (i in types_heap) { + if (isarray(types_heap[i])) { + if (!("checked" in types_heap[i]) || types_heap[i]["checked"] != types_heap[i]["ref"]) { + for (j in types_heap[i]) { + print " types_heap[" i "][" j "] = " types_heap[i][j] + } + } + } else { + print " types_heap[" i "] = " types_heap[i] + } + } + } +} + +function types_typename(str) +{ + switch (str) { + case /^"/: return "string" + case /^'/: return "symbol" + case /^:/: return "keyword" + case /^\+/: return "number" + case /^#nil$/: return "nil" + case /^#true$/: return "true" + case /^#false$/: return "false" + case /^\(/: return "list" + case /^\[/: return "vector" + case /^\{/: return "hash" + case /^\?/: return "atom" + case /^[&%]/: return "builtin function" + case /^\$/: return "user defined function" + } +} + +BEGIN { + types_heap_index = 0 +} diff --git a/impls/bash/Dockerfile b/impls/bash/Dockerfile index 71720eb5e5..656b5f6b40 100644 --- a/impls/bash/Dockerfile +++ b/impls/bash/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Nothing additional needed for bash +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Nothing additional needed for bash diff --git a/impls/bash/Makefile b/impls/bash/Makefile index 0f7bc0396a..9fd5c0053e 100644 --- a/impls/bash/Makefile +++ b/impls/bash/Makefile @@ -1,19 +1,19 @@ -SOURCES_BASE = types.sh reader.sh printer.sh -SOURCES_LISP = env.sh core.sh stepA_mal.sh -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.sh mal - -mal.sh: $(SOURCES) - cat $+ | grep -v "^source " > $@ - -mal: mal.sh - echo "#!/usr/bin/env bash" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.sh mal +SOURCES_BASE = types.sh reader.sh printer.sh +SOURCES_LISP = env.sh core.sh stepA_mal.sh +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.sh mal + +mal.sh: $(SOURCES) + cat $+ | grep -v "^source " > $@ + +mal: mal.sh + echo "#!/usr/bin/env bash" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.sh mal diff --git a/impls/bash/core.sh b/impls/bash/core.sh index 28119cc7ab..9f10a3c98b 100644 --- a/impls/bash/core.sh +++ b/impls/bash/core.sh @@ -1,425 +1,425 @@ -# -# mal (Make a Lisp) object types -# - -if [ -z "${__mal_core_included__}" ]; then -__mal_core_included=true - -source $(dirname $0)/types.sh -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh - -# Exceptions/Errors - -throw() { - __ERROR="${1}" - r= -} - - -# General functions - -obj_type () { - _obj_type "${1}" - _string "${r}" -} - -equal? () { - _equal? "${1}" "${2}" && r="${__true}" || r="${__false}" -} - - -# Scalar functions - -nil? () { _nil? "${1}" && r="${__true}" || r="${__false}"; } -true? () { _true? "${1}" && r="${__true}" || r="${__false}"; } -false? () { _false? "${1}" && r="${__true}" || r="${__false}"; } - - -# Symbol functions - -symbol () { _symbol "${ANON["${1}"]}"; } - -symbol? () { _symbol? "${1}" && r="${__true}" || r="${__false}"; } - - -# Keyword functions - -keyword () { _keyword "${ANON["${1}"]}"; } - -keyword? () { _keyword? "${1}" && r="${__true}" || r="${__false}"; } - - -# Number functions - -number? () { _number? "${1}" && r="${__true}" || r="${__false}"; } - -num_plus () { r=$(( ${ANON["${1}"]} + ${ANON["${2}"]} )); _number "${r}"; } -num_minus () { r=$(( ${ANON["${1}"]} - ${ANON["${2}"]} )); _number "${r}"; } -num_multiply () { r=$(( ${ANON["${1}"]} * ${ANON["${2}"]} )); _number "${r}"; } -num_divide () { r=$(( ${ANON["${1}"]} / ${ANON["${2}"]} )); _number "${r}"; } - -_num_bool () { [[ "${1}" = "1" ]] && r="${__true}" || r="${__false}"; } -num_gt () { r=$(( ${ANON["${1}"]} > ${ANON["${2}"]} )); _num_bool "${r}"; } -num_gte () { r=$(( ${ANON["${1}"]} >= ${ANON["${2}"]} )); _num_bool "${r}"; } -num_lt () { r=$(( ${ANON["${1}"]} < ${ANON["${2}"]} )); _num_bool "${r}"; } -num_lte () { r=$(( ${ANON["${1}"]} <= ${ANON["${2}"]} )); _num_bool "${r}"; } - -# return number of milliseconds since epoch -time_ms () { - local ms=$(date +%s%3N) - _number "${ms}" -} - - -# String functions - -string? () { _string? "${1}" && ( ! _keyword? "${1}" ) && r="${__true}" || r="${__false}"; } - -pr_str () { - local res="" - for x in "${@}"; do _pr_str "${x}" yes; res="${res} ${r}"; done - _string "${res:1}" -} - -str () { - local res="" - for x in "${@}"; do _pr_str "${x}"; res="${res}${r}"; done - _string "${res}" -} - -prn () { - local res="" - for x in "${@}"; do _pr_str "${x}" yes; res="${res} ${r}"; done - echo "${res:1}" - r="${__nil}"; -} - -println () { - local res="" - for x in "${@}"; do _pr_str "${x}"; res="${res} ${r}"; done - echo "${res:1}" - r="${__nil}"; -} - -readline () { - READLINE "${ANON["${1}"]}" && _string "${r}" || r="${__nil}" -} - -read_string () { - READ_STR "${ANON["${1}"]}" -} - -slurp () { - local lines - mapfile lines < "${ANON["${1}"]}" - local text="${lines[*]}"; text=${text//$'\n' /$'\n'} - _string "${text}" -} - - -# Function functions -function? () { _function? "${1}" && [ -z "${ANON["${1}_ismacro_"]}" ] && r="${__true}" || r="${__false}"; } -macro? () { _function? "${1}" && [ "${ANON["${1}_ismacro_"]}" ] && r="${__true}" || r="${__false}"; } - - -# List functions -list? () { _list? "${1}" && r="${__true}" || r="${__false}"; } - - -# Vector functions (same as lists for now) -vector? () { _vector? "${1}" && r="${__true}" || r="${__false}"; } - - -# Hash map (associative array) functions -hash_map? () { _hash_map? "${1}" && r="${__true}" || r="${__false}"; } - -# Return new hash map with keys/values updated -assoc () { - if ! _hash_map? "${1}"; then - _error "assoc onto non-hash-map" - return - fi - _copy_hash_map "${1}"; shift - local name="${r}" - local obj=${ANON["${name}"]} - declare -A -g ${obj} - - while [[ "${1}" ]]; do - eval ${obj}[\"${ANON["${1}"]}\"]=\"${2}\" - shift; shift - done - r="${name}" -} - -dissoc () { - if ! _hash_map? "${1}"; then - _error "dissoc from non-hash-map" - return - fi - _copy_hash_map "${1}"; shift - local name="${r}" - local obj=${ANON["${name}"]} - declare -A -g ${obj} - - while [[ "${1}" ]]; do - eval unset ${obj}[\"${ANON["${1}"]}\"] - shift - done - r="${name}" -} - -_get () { - _obj_type "${1}"; local ot="${r}" - case "${ot}" in - hash_map) - local obj="${ANON["${1}"]}" - eval r="\${${obj}[\"${2}\"]}" ;; - list|vector) - _nth "${1}" "${2}" ;; - nil) - r="${__nil}" ;; - esac -} -get () { - _get "${1}" "${ANON["${2}"]}" - [[ "${r}" ]] || r="${__nil}" -} - -contains? () { _contains? "${1}" "${ANON["${2}"]}" && r="${__true}" || r="${__false}"; } - -keys () { - local obj="${ANON["${1}"]}" - local kstrs= - eval local keys="\${!${obj}[@]}" - for k in ${keys}; do - _string "${k}" - kstrs="${kstrs} ${r}" - done - - __new_obj_hash_code - r="list_${r}" - ANON["${r}"]="${kstrs:1}" -} - -vals () { - local obj="${ANON["${1}"]}" - local kvals= - local val= - eval local keys="\${!${obj}[@]}" - for k in ${keys}; do - eval val="\${${obj}["\${k}"]}" - kvals="${kvals} ${val}" - done - - __new_obj_hash_code - r="list_${r}" - ANON["${r}"]="${kvals:1}" -} - - -# sequence operations - -sequential? () { - _sequential? "${1}" && r="${__true}" || r="${__false}" -} - -cons () { - _list ${1} ${ANON["${2}"]} -} - -concat () { - _list - local acc="" - for item in "${@}"; do - acc="${acc} ${ANON["${item}"]}" - done - ANON["${r}"]="${acc:1}" -} - -nth () { - _nth "${1}" "${ANON["${2}"]}" - if [ -z "${r}" ]; then - _error "nth: index out of bounds" - return - fi -} - -empty? () { _empty? "${1}" && r="${__true}" || r="${__false}"; } - -count () { - _count "${1}" - _number "${r}" -} - -apply () { - local f="${ANON["${1}"]}"; shift - local items="${@:1:$(( ${#@} -1 ))} ${ANON["${!#}"]}" - eval ${f%%@*} ${items} -} - -# Takes a function object and an list object and invokes the function -# on each element of the list, returning a new list of the results. -map () { - local f="${ANON["${1}"]}"; shift - #echo _map "${f}" "${@}" - _map "${f}" "${@}" -} - -conj () { - local obj="${1}"; shift - local obj_data="${ANON["${obj}"]}" - __new_obj_like "${obj}" - if _list? "${obj}"; then - ANON["${r}"]="${obj_data:+${obj_data}}" - for elem in ${@}; do - ANON["${r}"]="${elem} ${ANON["${r}"]}" - done - - else - ANON["${r}"]="${obj_data:+${obj_data} }${*}" - fi -} - -seq () { - local obj="${1}"; shift - local obj_data="${ANON["${obj}"]}" - - - if _list? "${obj}"; then - _count "${obj}" - if [ "${r}" -eq 0 ]; then r="${__nil}"; return; fi - r="${obj}" - elif _vector? "${obj}"; then - _count "${obj}" - if [ "${r}" -eq 0 ]; then r="${__nil}"; return; fi - __new_obj_hash_code - r="list_${r}" - ANON["${r}"]="${obj_data}" - elif _string? "${obj}"; then - if [ "${#obj_data}" -eq 0 ]; then r="${__nil}"; return; fi - local i=0 acc="" - for (( i=0; i < ${#obj_data}; i++ )); do - _string "${obj_data:$i:1}" - acc="${acc} ${r}" - done - _list - ANON["${r}"]="${acc:1}" - elif _nil? "${obj}"; then - r="${__nil}" - else - throw "seq: called on non-sequence" - fi -} - - -# Metadata functions - -with_meta () { - local obj="${1}"; shift - local meta_data="${1}"; shift - __new_obj_like "${obj}" - ANON["${r}"]="${ANON["${obj}"]}" - local meta_obj="meta_${r#*_}" - ANON["${meta_obj}"]="${meta_data}" -} - -meta () { - r="${ANON["meta_${1#*_}"]}" - [[ "${r}" ]] || r="${__nil}" -} - - -# Atom functions - -atom? () { _atom? "${1}" && r="${__true}" || r="${__false}"; } -deref () { - # TODO: double-check atom type - r=${ANON["${1}"]} -} -reset_BANG () { - local atm="${1}"; shift - ANON["${atm}"]="${*}" - r="${*}" -} -swap_BANG () { - local atm="${1}"; shift - local f="${ANON["${1}"]}"; shift - ${f%%@*} "${ANON["${atm}"]}" "${@}" - ANON["${atm}"]="${r}" -} - - - -# Namespace of core functions - -declare -A core_ns=( - [type]=obj_type - [=]=equal? - [throw]=throw - [nil?]=nil? - [true?]=true? - [false?]=false? - [string?]=string? - [symbol]=symbol - [symbol?]=symbol? - [keyword]=keyword - [keyword?]=keyword? - [number?]=number? - [fn?]=function? - [macro?]=macro? - - [pr-str]=pr_str - [str]=str - [prn]=prn - [println]=println - [readline]=readline - [read-string]=read_string - [slurp]=slurp - ['<']=num_lt - ['<=']=num_lte - ['>']=num_gt - ['>=']=num_gte - [+]=num_plus - [-]=num_minus - [__STAR__]=num_multiply - [/]=num_divide - [time-ms]=time_ms - - [list]=_list - [list?]=list? - [vector]=_vector - [vector?]=vector? - [hash-map]=_hash_map - [map?]=hash_map? - [assoc]=assoc - [dissoc]=dissoc - [get]=get - [contains?]=contains? - [keys]=keys - [vals]=vals - - [sequential?]=sequential? - [cons]=cons - [concat]=concat - [vec]=vec - [nth]=nth - [first]=_first - [rest]=_rest - [empty?]=empty? - [count]=count - [apply]=apply - [map]=map - - [conj]=conj - [seq]=seq - - [with-meta]=with_meta - [meta]=meta - [atom]=_atom - [atom?]=atom? - [deref]=deref - [reset!]=reset_BANG - [swap!]=swap_BANG) - -fi +# +# mal (Make a Lisp) object types +# + +if [ -z "${__mal_core_included__}" ]; then +__mal_core_included=true + +source $(dirname $0)/types.sh +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh + +# Exceptions/Errors + +throw() { + __ERROR="${1}" + r= +} + + +# General functions + +obj_type () { + _obj_type "${1}" + _string "${r}" +} + +equal? () { + _equal? "${1}" "${2}" && r="${__true}" || r="${__false}" +} + + +# Scalar functions + +nil? () { _nil? "${1}" && r="${__true}" || r="${__false}"; } +true? () { _true? "${1}" && r="${__true}" || r="${__false}"; } +false? () { _false? "${1}" && r="${__true}" || r="${__false}"; } + + +# Symbol functions + +symbol () { _symbol "${ANON["${1}"]}"; } + +symbol? () { _symbol? "${1}" && r="${__true}" || r="${__false}"; } + + +# Keyword functions + +keyword () { _keyword "${ANON["${1}"]}"; } + +keyword? () { _keyword? "${1}" && r="${__true}" || r="${__false}"; } + + +# Number functions + +number? () { _number? "${1}" && r="${__true}" || r="${__false}"; } + +num_plus () { r=$(( ${ANON["${1}"]} + ${ANON["${2}"]} )); _number "${r}"; } +num_minus () { r=$(( ${ANON["${1}"]} - ${ANON["${2}"]} )); _number "${r}"; } +num_multiply () { r=$(( ${ANON["${1}"]} * ${ANON["${2}"]} )); _number "${r}"; } +num_divide () { r=$(( ${ANON["${1}"]} / ${ANON["${2}"]} )); _number "${r}"; } + +_num_bool () { [[ "${1}" = "1" ]] && r="${__true}" || r="${__false}"; } +num_gt () { r=$(( ${ANON["${1}"]} > ${ANON["${2}"]} )); _num_bool "${r}"; } +num_gte () { r=$(( ${ANON["${1}"]} >= ${ANON["${2}"]} )); _num_bool "${r}"; } +num_lt () { r=$(( ${ANON["${1}"]} < ${ANON["${2}"]} )); _num_bool "${r}"; } +num_lte () { r=$(( ${ANON["${1}"]} <= ${ANON["${2}"]} )); _num_bool "${r}"; } + +# return number of milliseconds since epoch +time_ms () { + local ms=$(date +%s%3N) + _number "${ms}" +} + + +# String functions + +string? () { _string? "${1}" && ( ! _keyword? "${1}" ) && r="${__true}" || r="${__false}"; } + +pr_str () { + local res="" + for x in "${@}"; do _pr_str "${x}" yes; res="${res} ${r}"; done + _string "${res:1}" +} + +str () { + local res="" + for x in "${@}"; do _pr_str "${x}"; res="${res}${r}"; done + _string "${res}" +} + +prn () { + local res="" + for x in "${@}"; do _pr_str "${x}" yes; res="${res} ${r}"; done + echo "${res:1}" + r="${__nil}"; +} + +println () { + local res="" + for x in "${@}"; do _pr_str "${x}"; res="${res} ${r}"; done + echo "${res:1}" + r="${__nil}"; +} + +readline () { + READLINE "${ANON["${1}"]}" && _string "${r}" || r="${__nil}" +} + +read_string () { + READ_STR "${ANON["${1}"]}" +} + +slurp () { + local lines + mapfile lines < "${ANON["${1}"]}" + local text="${lines[*]}"; text=${text//$'\n' /$'\n'} + _string "${text}" +} + + +# Function functions +function? () { _function? "${1}" && [ -z "${ANON["${1}_ismacro_"]}" ] && r="${__true}" || r="${__false}"; } +macro? () { _function? "${1}" && [ "${ANON["${1}_ismacro_"]}" ] && r="${__true}" || r="${__false}"; } + + +# List functions +list? () { _list? "${1}" && r="${__true}" || r="${__false}"; } + + +# Vector functions (same as lists for now) +vector? () { _vector? "${1}" && r="${__true}" || r="${__false}"; } + + +# Hash map (associative array) functions +hash_map? () { _hash_map? "${1}" && r="${__true}" || r="${__false}"; } + +# Return new hash map with keys/values updated +assoc () { + if ! _hash_map? "${1}"; then + _error "assoc onto non-hash-map" + return + fi + _copy_hash_map "${1}"; shift + local name="${r}" + local obj=${ANON["${name}"]} + declare -A -g ${obj} + + while [[ "${1}" ]]; do + eval ${obj}[\"${ANON["${1}"]}\"]=\"${2}\" + shift; shift + done + r="${name}" +} + +dissoc () { + if ! _hash_map? "${1}"; then + _error "dissoc from non-hash-map" + return + fi + _copy_hash_map "${1}"; shift + local name="${r}" + local obj=${ANON["${name}"]} + declare -A -g ${obj} + + while [[ "${1}" ]]; do + eval unset ${obj}[\"${ANON["${1}"]}\"] + shift + done + r="${name}" +} + +_get () { + _obj_type "${1}"; local ot="${r}" + case "${ot}" in + hash_map) + local obj="${ANON["${1}"]}" + eval r="\${${obj}[\"${2}\"]}" ;; + list|vector) + _nth "${1}" "${2}" ;; + nil) + r="${__nil}" ;; + esac +} +get () { + _get "${1}" "${ANON["${2}"]}" + [[ "${r}" ]] || r="${__nil}" +} + +contains? () { _contains? "${1}" "${ANON["${2}"]}" && r="${__true}" || r="${__false}"; } + +keys () { + local obj="${ANON["${1}"]}" + local kstrs= + eval local keys="\${!${obj}[@]}" + for k in ${keys}; do + _string "${k}" + kstrs="${kstrs} ${r}" + done + + __new_obj_hash_code + r="list_${r}" + ANON["${r}"]="${kstrs:1}" +} + +vals () { + local obj="${ANON["${1}"]}" + local kvals= + local val= + eval local keys="\${!${obj}[@]}" + for k in ${keys}; do + eval val="\${${obj}["\${k}"]}" + kvals="${kvals} ${val}" + done + + __new_obj_hash_code + r="list_${r}" + ANON["${r}"]="${kvals:1}" +} + + +# sequence operations + +sequential? () { + _sequential? "${1}" && r="${__true}" || r="${__false}" +} + +cons () { + _list ${1} ${ANON["${2}"]} +} + +concat () { + _list + local acc="" + for item in "${@}"; do + acc="${acc} ${ANON["${item}"]}" + done + ANON["${r}"]="${acc:1}" +} + +nth () { + _nth "${1}" "${ANON["${2}"]}" + if [ -z "${r}" ]; then + _error "nth: index out of bounds" + return + fi +} + +empty? () { _empty? "${1}" && r="${__true}" || r="${__false}"; } + +count () { + _count "${1}" + _number "${r}" +} + +apply () { + local f="${ANON["${1}"]}"; shift + local items="${@:1:$(( ${#@} -1 ))} ${ANON["${!#}"]}" + eval ${f%%@*} ${items} +} + +# Takes a function object and an list object and invokes the function +# on each element of the list, returning a new list of the results. +map () { + local f="${ANON["${1}"]}"; shift + #echo _map "${f}" "${@}" + _map "${f}" "${@}" +} + +conj () { + local obj="${1}"; shift + local obj_data="${ANON["${obj}"]}" + __new_obj_like "${obj}" + if _list? "${obj}"; then + ANON["${r}"]="${obj_data:+${obj_data}}" + for elem in ${@}; do + ANON["${r}"]="${elem} ${ANON["${r}"]}" + done + + else + ANON["${r}"]="${obj_data:+${obj_data} }${*}" + fi +} + +seq () { + local obj="${1}"; shift + local obj_data="${ANON["${obj}"]}" + + + if _list? "${obj}"; then + _count "${obj}" + if [ "${r}" -eq 0 ]; then r="${__nil}"; return; fi + r="${obj}" + elif _vector? "${obj}"; then + _count "${obj}" + if [ "${r}" -eq 0 ]; then r="${__nil}"; return; fi + __new_obj_hash_code + r="list_${r}" + ANON["${r}"]="${obj_data}" + elif _string? "${obj}"; then + if [ "${#obj_data}" -eq 0 ]; then r="${__nil}"; return; fi + local i=0 acc="" + for (( i=0; i < ${#obj_data}; i++ )); do + _string "${obj_data:$i:1}" + acc="${acc} ${r}" + done + _list + ANON["${r}"]="${acc:1}" + elif _nil? "${obj}"; then + r="${__nil}" + else + throw "seq: called on non-sequence" + fi +} + + +# Metadata functions + +with_meta () { + local obj="${1}"; shift + local meta_data="${1}"; shift + __new_obj_like "${obj}" + ANON["${r}"]="${ANON["${obj}"]}" + local meta_obj="meta_${r#*_}" + ANON["${meta_obj}"]="${meta_data}" +} + +meta () { + r="${ANON["meta_${1#*_}"]}" + [[ "${r}" ]] || r="${__nil}" +} + + +# Atom functions + +atom? () { _atom? "${1}" && r="${__true}" || r="${__false}"; } +deref () { + # TODO: double-check atom type + r=${ANON["${1}"]} +} +reset_BANG () { + local atm="${1}"; shift + ANON["${atm}"]="${*}" + r="${*}" +} +swap_BANG () { + local atm="${1}"; shift + local f="${ANON["${1}"]}"; shift + ${f%%@*} "${ANON["${atm}"]}" "${@}" + ANON["${atm}"]="${r}" +} + + + +# Namespace of core functions + +declare -A core_ns=( + [type]=obj_type + [=]=equal? + [throw]=throw + [nil?]=nil? + [true?]=true? + [false?]=false? + [string?]=string? + [symbol]=symbol + [symbol?]=symbol? + [keyword]=keyword + [keyword?]=keyword? + [number?]=number? + [fn?]=function? + [macro?]=macro? + + [pr-str]=pr_str + [str]=str + [prn]=prn + [println]=println + [readline]=readline + [read-string]=read_string + [slurp]=slurp + ['<']=num_lt + ['<=']=num_lte + ['>']=num_gt + ['>=']=num_gte + [+]=num_plus + [-]=num_minus + [__STAR__]=num_multiply + [/]=num_divide + [time-ms]=time_ms + + [list]=_list + [list?]=list? + [vector]=_vector + [vector?]=vector? + [hash-map]=_hash_map + [map?]=hash_map? + [assoc]=assoc + [dissoc]=dissoc + [get]=get + [contains?]=contains? + [keys]=keys + [vals]=vals + + [sequential?]=sequential? + [cons]=cons + [concat]=concat + [vec]=vec + [nth]=nth + [first]=_first + [rest]=_rest + [empty?]=empty? + [count]=count + [apply]=apply + [map]=map + + [conj]=conj + [seq]=seq + + [with-meta]=with_meta + [meta]=meta + [atom]=_atom + [atom?]=atom? + [deref]=deref + [reset!]=reset_BANG + [swap!]=swap_BANG) + +fi diff --git a/impls/bash/env.sh b/impls/bash/env.sh index d7646909eb..b62d8b633b 100644 --- a/impls/bash/env.sh +++ b/impls/bash/env.sh @@ -1,80 +1,80 @@ -# -# mal (Make a Lisp) environment definition -# - -if [ -z "${__mal_env_included__}" ]; then -__mal_env_included=true - -source $(dirname $0)/types.sh - -# Any environment is a hash_map with an __outer__ key that refers to -# a parent environment (or nil) -ENV () { - r= - _hash_map - local env="${r}" - if [[ "${1}" ]]; then - outer="${1}"; shift - _assoc! "${env}" "__outer__" "${outer}" - else - _assoc! "${env}" "__outer__" "${__nil}" - fi - r="${env}" - - if [[ "${1}" && "${@}" ]]; then - local binds=(${ANON["${1}"]}); shift - local idx=0 - while [[ "${binds["${idx}"]}" ]]; do - local fp="${ANON["${binds["${idx}"]}"]}" - if [[ "${fp}" == "&" ]]; then - idx=$(( idx + 1 )) - fp="${ANON["${binds["${idx}"]}"]}" - _list "${@}" - _assoc! "${env}" "${fp}" "${r}" - break - else - _assoc! "${env}" "${fp}" "${1}" - shift - idx=$(( idx + 1 )) - fi - done - fi - r="${env}" -} - -# Find the environment with the key set and return the environment -ENV_FIND () { - if _contains? "${1}" "${ANON["${2}"]}"; then - r="${1}" - else - local obj="${ANON["${1}"]}" - eval 'local outer=${'${obj}'["__outer__"]}' - if [[ "${outer}" && "${outer}" != "${__nil}" ]]; then - ENV_FIND "${outer}" "${2}" - else - r= - fi - fi -} - -# Find the environment with the key set and return the value of the -# key in that environment. If no environment contains the key then -# return an error -ENV_GET () { - ENV_FIND "${1}" "${2}" - local env="${r}" - local key="${ANON["${2}"]}" - if [[ "${r}" ]]; then - local obj="${ANON["${env}"]}" - eval 'r=${'${obj}'["'${key}'"]}' - else - _error "'${key}' not found" - fi -} - -ENV_SET () { - local key="${ANON["${2}"]}" - _assoc! "${1}" "${key}" "${3}" -} - -fi +# +# mal (Make a Lisp) environment definition +# + +if [ -z "${__mal_env_included__}" ]; then +__mal_env_included=true + +source $(dirname $0)/types.sh + +# Any environment is a hash_map with an __outer__ key that refers to +# a parent environment (or nil) +ENV () { + r= + _hash_map + local env="${r}" + if [[ "${1}" ]]; then + outer="${1}"; shift + _assoc! "${env}" "__outer__" "${outer}" + else + _assoc! "${env}" "__outer__" "${__nil}" + fi + r="${env}" + + if [[ "${1}" && "${@}" ]]; then + local binds=(${ANON["${1}"]}); shift + local idx=0 + while [[ "${binds["${idx}"]}" ]]; do + local fp="${ANON["${binds["${idx}"]}"]}" + if [[ "${fp}" == "&" ]]; then + idx=$(( idx + 1 )) + fp="${ANON["${binds["${idx}"]}"]}" + _list "${@}" + _assoc! "${env}" "${fp}" "${r}" + break + else + _assoc! "${env}" "${fp}" "${1}" + shift + idx=$(( idx + 1 )) + fi + done + fi + r="${env}" +} + +# Find the environment with the key set and return the environment +ENV_FIND () { + if _contains? "${1}" "${ANON["${2}"]}"; then + r="${1}" + else + local obj="${ANON["${1}"]}" + eval 'local outer=${'${obj}'["__outer__"]}' + if [[ "${outer}" && "${outer}" != "${__nil}" ]]; then + ENV_FIND "${outer}" "${2}" + else + r= + fi + fi +} + +# Find the environment with the key set and return the value of the +# key in that environment. If no environment contains the key then +# return an error +ENV_GET () { + ENV_FIND "${1}" "${2}" + local env="${r}" + local key="${ANON["${2}"]}" + if [[ "${r}" ]]; then + local obj="${ANON["${env}"]}" + eval 'r=${'${obj}'["'${key}'"]}' + else + _error "'${key}' not found" + fi +} + +ENV_SET () { + local key="${ANON["${2}"]}" + _assoc! "${1}" "${key}" "${3}" +} + +fi diff --git a/impls/bash/printer.sh b/impls/bash/printer.sh index 125b568e81..3ffa2869a3 100644 --- a/impls/bash/printer.sh +++ b/impls/bash/printer.sh @@ -1,104 +1,104 @@ -# -# mal (Make a Lisp) printer -# - -if [ -z "${__mal_printer_included__}" ]; then -__mal_printer_included=true - -source $(dirname $0)/types.sh - -_pr_str () { - local print_readably="${2}" - _obj_type "${1}"; local ot="${r}" - if [[ -z "${ot}" ]]; then - _error "_pr_str failed on '${1}'" - r="<${1}>" - else - eval ${ot}_pr_str "${1}" "${print_readably}" - fi -} - -nil_pr_str () { r="nil"; } -true_pr_str () { r="true"; } -false_pr_str () { r="false"; } - -number_pr_str () { r="${ANON["${1}"]}"; } - -symbol_pr_str () { - r="${ANON["${1}"]}" - r="${r//__STAR__/*}" -} - -keyword_pr_str () { - string_pr_str "${1}" -} - -_raw_string_pr_str () { - local s="${1}" - local print_readably="${2}" - if [[ "${s:0:1}" = "${__keyw}" ]]; then - r=":${s:1}" - elif [[ "${s:0:2}" = "${__keyw}" ]]; then - r=":${s:2}" - elif [ "${print_readably}" == "yes" ]; then - s="${s//\\/\\\\}" - s="${s//\"/\\\"}" - r="\"${s//$'\n'/\\n}\"" - else - r="${s}" - fi - r="${r//__STAR__/$'*'}" -} - -string_pr_str () { - _raw_string_pr_str "${ANON["${1}"]}" "${2}" -} - -function_pr_str () { r="${ANON["${1}"]}"; } - -bash_pr_str () { - r="$(declare -f -p ${1})" -} - -hash_map_pr_str () { - local print_readably="${2}" - local res=""; local val="" - local hm="${ANON["${1}"]}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - _raw_string_pr_str "${key}" "${print_readably}" - res="${res} ${r}" - eval val="\${${hm}[\"${key}\"]}" - _pr_str "${val}" "${print_readably}" - res="${res} ${r}" - done - r="{${res:1}}" -} - -vector_pr_str () { - local print_readably="${2}" - local res="" - for elem in ${ANON["${1}"]}; do - _pr_str "${elem}" "${print_readably}" - res="${res} ${r}" - done - r="[${res:1}]" -} - -list_pr_str () { - local print_readably="${2}" - local res="" - for elem in ${ANON["${1}"]}; do - _pr_str "${elem}" "${print_readably}" - res="${res} ${r}" - done - r="(${res:1})" -} - -atom_pr_str () { - local print_readably="${2}" - _pr_str "${ANON["${1}"]}" "${print_readably}" - r="(atom ${r})"; -} - -fi +# +# mal (Make a Lisp) printer +# + +if [ -z "${__mal_printer_included__}" ]; then +__mal_printer_included=true + +source $(dirname $0)/types.sh + +_pr_str () { + local print_readably="${2}" + _obj_type "${1}"; local ot="${r}" + if [[ -z "${ot}" ]]; then + _error "_pr_str failed on '${1}'" + r="<${1}>" + else + eval ${ot}_pr_str "${1}" "${print_readably}" + fi +} + +nil_pr_str () { r="nil"; } +true_pr_str () { r="true"; } +false_pr_str () { r="false"; } + +number_pr_str () { r="${ANON["${1}"]}"; } + +symbol_pr_str () { + r="${ANON["${1}"]}" + r="${r//__STAR__/*}" +} + +keyword_pr_str () { + string_pr_str "${1}" +} + +_raw_string_pr_str () { + local s="${1}" + local print_readably="${2}" + if [[ "${s:0:1}" = "${__keyw}" ]]; then + r=":${s:1}" + elif [[ "${s:0:2}" = "${__keyw}" ]]; then + r=":${s:2}" + elif [ "${print_readably}" == "yes" ]; then + s="${s//\\/\\\\}" + s="${s//\"/\\\"}" + r="\"${s//$'\n'/\\n}\"" + else + r="${s}" + fi + r="${r//__STAR__/$'*'}" +} + +string_pr_str () { + _raw_string_pr_str "${ANON["${1}"]}" "${2}" +} + +function_pr_str () { r="${ANON["${1}"]}"; } + +bash_pr_str () { + r="$(declare -f -p ${1})" +} + +hash_map_pr_str () { + local print_readably="${2}" + local res=""; local val="" + local hm="${ANON["${1}"]}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + _raw_string_pr_str "${key}" "${print_readably}" + res="${res} ${r}" + eval val="\${${hm}[\"${key}\"]}" + _pr_str "${val}" "${print_readably}" + res="${res} ${r}" + done + r="{${res:1}}" +} + +vector_pr_str () { + local print_readably="${2}" + local res="" + for elem in ${ANON["${1}"]}; do + _pr_str "${elem}" "${print_readably}" + res="${res} ${r}" + done + r="[${res:1}]" +} + +list_pr_str () { + local print_readably="${2}" + local res="" + for elem in ${ANON["${1}"]}; do + _pr_str "${elem}" "${print_readably}" + res="${res} ${r}" + done + r="(${res:1})" +} + +atom_pr_str () { + local print_readably="${2}" + _pr_str "${ANON["${1}"]}" "${print_readably}" + r="(atom ${r})"; +} + +fi diff --git a/impls/bash/reader.sh b/impls/bash/reader.sh index 6e1ed362c0..fdc3ce6bd9 100644 --- a/impls/bash/reader.sh +++ b/impls/bash/reader.sh @@ -1,167 +1,167 @@ -# -# mal (Make Lisp) Parser/Reader -# - -if [ -z "${__mal_readerr_included__}" ]; then -__mal_readerr_included=true - -source $(dirname $0)/types.sh - -READ_ATOM () { - local token=${__reader_tokens[${__reader_idx}]} - __reader_idx=$(( __reader_idx + 1 )) - case "${token}" in - [0-9]*) _number "${token}" ;; - -[0-9]*) _number "${token}" ;; - \"*) if [[ ! "${token}" =~ ^\"(\\.|[^\\\"])*\"$ ]]; then - _error "expected '\"', got EOF" - return - fi - token="${token:1:-1}" - token="${token//\\\\/${__keyw}}" - token="${token//\\\"/\"}" - token="${token//\\n/$'\n'}" - token="${token//${__keyw}/\\}" - _string "${token}" ;; - :*) _keyword "${token:1}" ;; - nil) r="${__nil}" ;; - true) r="${__true}" ;; - false) r="${__false}" ;; - *) _symbol "${token}" ;; - esac -} - -# Return seqence of tokens into r. -# ${1}: Type of r (vector, list) -# ${2}: starting symbol -# ${3}: ending symbol -READ_SEQ () { - local start="${1}" - local end="${2}" - local items="" - local token=${__reader_tokens[${__reader_idx}]} - __reader_idx=$(( __reader_idx + 1 )) - if [[ "${token}" != "${start}" ]]; then - r= - _error "expected '${start}'" - return - fi - token=${__reader_tokens[${__reader_idx}]} - while [[ "${token}" != "${end}" ]]; do - if [[ ! "${token}" ]]; then - r= - _error "expected '${end}', got EOF" - return - fi - READ_FORM - items="${items} ${r}" - token=${__reader_tokens[${__reader_idx}]} - done - __reader_idx=$(( __reader_idx + 1 )) - r="${items:1}" -} - -# Return form in r -READ_FORM () { - local token=${__reader_tokens[${__reader_idx}]} - case "${token}" in - \') __reader_idx=$(( __reader_idx + 1 )) - _symbol quote; local q="${r}" - READ_FORM; local f="${r}" - _list "${q}" "${f}" ;; - \`) __reader_idx=$(( __reader_idx + 1 )) - _symbol quasiquote; local q="${r}" - READ_FORM; local f="${r}" - _list "${q}" "${f}" ;; - \~) __reader_idx=$(( __reader_idx + 1 )) - _symbol unquote; local q="${r}" - READ_FORM; local f="${r}" - _list "${q}" "${f}" ;; - \~\@) __reader_idx=$(( __reader_idx + 1 )) - _symbol splice-unquote; local q="${r}" - READ_FORM; local f="${r}" - _list "${q}" "${f}" ;; - ^) __reader_idx=$(( __reader_idx + 1 )) - _symbol with-meta; local wm="${r}" - READ_FORM; local meta="${r}" - READ_FORM; local obj="${r}" - _list "${wm}" "${obj}" "${meta}" ;; - @) __reader_idx=$(( __reader_idx + 1 )) - _symbol deref; local d="${r}" - READ_FORM; local f="${r}" - _list "${d}" "${f}" ;; - \)) _error "unexpected ')'" ;; - \() READ_SEQ "(" ")" - _list ${r} ;; - \]) _error "unexpected ']'" ;; - \[) READ_SEQ "[" "]" - _vector ${r} ;; - \}) _error "unexpected '}'" ;; - \{) READ_SEQ "{" "}" - _hash_map ${r} ;; - *) READ_ATOM - esac -} - -TOKEN_PAT=$'^^([][{}\\(\\)^@])|^(~@)|^("(\\\\.|[^\\"])*"?)|^(;[^\n]*)|^([~\'`])|^([^][ ~`\'";{}\\(\\)^@,\n]+)|^(,)|^([[:space:]]+)' - -# Returns __reader_tokens as an indexed array of tokens -TOKENIZE () { - local data="${*}" - local datalen=${#data} - local idx=0 - local chunk=0 - local chunksz=500 - local token= - local str= - - __reader_idx=0 - declare -a -g __reader_tokens=() # global array - while true; do - if (( ${#str} < ( chunksz / 2) )) && (( chunk < datalen )); then - str="${str}${data:${chunk}:${chunksz}}" - chunk=$(( chunk + ${chunksz} )) - fi - (( ${#str} == 0 )) && break - [[ "${str}" =~ ${TOKEN_PAT} ]] - token=${BASH_REMATCH[0]} - str="${str:${#token}}" - token="${token}" - #echo "MATCH: '${token}' / [${str}]" - if ! [[ "${token}" =~ (^[,]$|^[[:space:]]*;.*$|^[[:space:]]*$) ]]; then - __reader_tokens[${idx}]="${token}" - idx=$(( idx + 1 )) - fi - if [ -z "${token}" ]; then - _error "Tokenizing error at: ${str:0:50}" - return 1 - fi - done -} - -# read-str from a raw "string" or from a string object. Retruns object -# read in r. -READ_STR () { - declare -a __reader_tokens - TOKENIZE "${*}" || return 1 # sets __reader_tokens - #set | grep ^__reader_tokens - if [ -z "${__reader_tokens[0]}" ]; then - r= - return 1 # No tokens - fi - READ_FORM - #echo "Token: ${r}: <${ANON["${r}"]}>" - return -} - -# Call readline and save the history. Returns the string read in r. -READLINE_EOF= -READLINE_HISTORY_FILE=${HOME}/.mal-history -READLINE () { - history -r "${READLINE_HISTORY_FILE}" 2>/dev/null || true - read -r -e -p "${1}" r || return "$?" - history -s -- "${r}" - history -a "${READLINE_HISTORY_FILE}" 2>/dev/null || true -} - -fi +# +# mal (Make Lisp) Parser/Reader +# + +if [ -z "${__mal_readerr_included__}" ]; then +__mal_readerr_included=true + +source $(dirname $0)/types.sh + +READ_ATOM () { + local token=${__reader_tokens[${__reader_idx}]} + __reader_idx=$(( __reader_idx + 1 )) + case "${token}" in + [0-9]*) _number "${token}" ;; + -[0-9]*) _number "${token}" ;; + \"*) if [[ ! "${token}" =~ ^\"(\\.|[^\\\"])*\"$ ]]; then + _error "expected '\"', got EOF" + return + fi + token="${token:1:-1}" + token="${token//\\\\/${__keyw}}" + token="${token//\\\"/\"}" + token="${token//\\n/$'\n'}" + token="${token//${__keyw}/\\}" + _string "${token}" ;; + :*) _keyword "${token:1}" ;; + nil) r="${__nil}" ;; + true) r="${__true}" ;; + false) r="${__false}" ;; + *) _symbol "${token}" ;; + esac +} + +# Return seqence of tokens into r. +# ${1}: Type of r (vector, list) +# ${2}: starting symbol +# ${3}: ending symbol +READ_SEQ () { + local start="${1}" + local end="${2}" + local items="" + local token=${__reader_tokens[${__reader_idx}]} + __reader_idx=$(( __reader_idx + 1 )) + if [[ "${token}" != "${start}" ]]; then + r= + _error "expected '${start}'" + return + fi + token=${__reader_tokens[${__reader_idx}]} + while [[ "${token}" != "${end}" ]]; do + if [[ ! "${token}" ]]; then + r= + _error "expected '${end}', got EOF" + return + fi + READ_FORM + items="${items} ${r}" + token=${__reader_tokens[${__reader_idx}]} + done + __reader_idx=$(( __reader_idx + 1 )) + r="${items:1}" +} + +# Return form in r +READ_FORM () { + local token=${__reader_tokens[${__reader_idx}]} + case "${token}" in + \') __reader_idx=$(( __reader_idx + 1 )) + _symbol quote; local q="${r}" + READ_FORM; local f="${r}" + _list "${q}" "${f}" ;; + \`) __reader_idx=$(( __reader_idx + 1 )) + _symbol quasiquote; local q="${r}" + READ_FORM; local f="${r}" + _list "${q}" "${f}" ;; + \~) __reader_idx=$(( __reader_idx + 1 )) + _symbol unquote; local q="${r}" + READ_FORM; local f="${r}" + _list "${q}" "${f}" ;; + \~\@) __reader_idx=$(( __reader_idx + 1 )) + _symbol splice-unquote; local q="${r}" + READ_FORM; local f="${r}" + _list "${q}" "${f}" ;; + ^) __reader_idx=$(( __reader_idx + 1 )) + _symbol with-meta; local wm="${r}" + READ_FORM; local meta="${r}" + READ_FORM; local obj="${r}" + _list "${wm}" "${obj}" "${meta}" ;; + @) __reader_idx=$(( __reader_idx + 1 )) + _symbol deref; local d="${r}" + READ_FORM; local f="${r}" + _list "${d}" "${f}" ;; + \)) _error "unexpected ')'" ;; + \() READ_SEQ "(" ")" + _list ${r} ;; + \]) _error "unexpected ']'" ;; + \[) READ_SEQ "[" "]" + _vector ${r} ;; + \}) _error "unexpected '}'" ;; + \{) READ_SEQ "{" "}" + _hash_map ${r} ;; + *) READ_ATOM + esac +} + +TOKEN_PAT=$'^^([][{}\\(\\)^@])|^(~@)|^("(\\\\.|[^\\"])*"?)|^(;[^\n]*)|^([~\'`])|^([^][ ~`\'";{}\\(\\)^@,\n]+)|^(,)|^([[:space:]]+)' + +# Returns __reader_tokens as an indexed array of tokens +TOKENIZE () { + local data="${*}" + local datalen=${#data} + local idx=0 + local chunk=0 + local chunksz=500 + local token= + local str= + + __reader_idx=0 + declare -a -g __reader_tokens=() # global array + while true; do + if (( ${#str} < ( chunksz / 2) )) && (( chunk < datalen )); then + str="${str}${data:${chunk}:${chunksz}}" + chunk=$(( chunk + ${chunksz} )) + fi + (( ${#str} == 0 )) && break + [[ "${str}" =~ ${TOKEN_PAT} ]] + token=${BASH_REMATCH[0]} + str="${str:${#token}}" + token="${token}" + #echo "MATCH: '${token}' / [${str}]" + if ! [[ "${token}" =~ (^[,]$|^[[:space:]]*;.*$|^[[:space:]]*$) ]]; then + __reader_tokens[${idx}]="${token}" + idx=$(( idx + 1 )) + fi + if [ -z "${token}" ]; then + _error "Tokenizing error at: ${str:0:50}" + return 1 + fi + done +} + +# read-str from a raw "string" or from a string object. Retruns object +# read in r. +READ_STR () { + declare -a __reader_tokens + TOKENIZE "${*}" || return 1 # sets __reader_tokens + #set | grep ^__reader_tokens + if [ -z "${__reader_tokens[0]}" ]; then + r= + return 1 # No tokens + fi + READ_FORM + #echo "Token: ${r}: <${ANON["${r}"]}>" + return +} + +# Call readline and save the history. Returns the string read in r. +READLINE_EOF= +READLINE_HISTORY_FILE=${HOME}/.mal-history +READLINE () { + history -r "${READLINE_HISTORY_FILE}" 2>/dev/null || true + read -r -e -p "${1}" r || return "$?" + history -s -- "${r}" + history -a "${READLINE_HISTORY_FILE}" 2>/dev/null || true +} + +fi diff --git a/impls/bash/run b/impls/bash/run index 536c542f13..40ca68e63d 100755 --- a/impls/bash/run +++ b/impls/bash/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec bash $(dirname $0)/${STEP:-stepA_mal}.sh "${@}" +#!/bin/bash +exec bash $(dirname $0)/${STEP:-stepA_mal}.sh "${@}" diff --git a/impls/bash/step0_repl.sh b/impls/bash/step0_repl.sh index 97bce61d17..d40b5349da 100755 --- a/impls/bash/step0_repl.sh +++ b/impls/bash/step0_repl.sh @@ -1,20 +1,20 @@ -#!/usr/bin/env bash - -READ () { - read -u 0 -e -p "user> " r -} - -EVAL () { - r="${1}" -} - -PRINT () { - r="${1}" -} - -while true; do - READ - EVAL "${r}" - PRINT "${r}" - echo "${r}" -done +#!/usr/bin/env bash + +READ () { + read -u 0 -e -p "user> " r +} + +EVAL () { + r="${1}" +} + +PRINT () { + r="${1}" +} + +while true; do + READ + EVAL "${r}" + PRINT "${r}" + echo "${r}" +done diff --git a/impls/bash/step1_read_print.sh b/impls/bash/step1_read_print.sh index 8011fa6b86..054a6f2a81 100755 --- a/impls/bash/step1_read_print.sh +++ b/impls/bash/step1_read_print.sh @@ -1,43 +1,43 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -EVAL () { - local ast="${1}" - local env="${2}" - r= - [[ "${__ERROR}" ]] && return 1 - r="${ast}" -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" no - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -REP () { - READ "${1}" - EVAL "${r}" - PRINT "${r}" -} - -# repl loop -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +EVAL () { + local ast="${1}" + local env="${2}" + r= + [[ "${__ERROR}" ]] && return 1 + r="${ast}" +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" no + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +REP () { + READ "${1}" + EVAL "${r}" + PRINT "${r}" +} + +# repl loop +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/step2_eval.sh b/impls/bash/step2_eval.sh index 15083b937e..c8e89e87cd 100755 --- a/impls/bash/step2_eval.sh +++ b/impls/bash/step2_eval.sh @@ -1,98 +1,98 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -EVAL_AST () { - local ast="${1}" env="${2}" - #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - case "${ot}" in - symbol) - local val="${ANON["${ast}"]}" - eval r="\${${env}["${val}"]}" - [ "${r}" ] || _error "'${val}' not found" ;; - list) - _map_with_type _list EVAL "${ast}" "${env}" ;; - vector) - _map_with_type _vector EVAL "${ast}" "${env}" ;; - hash_map) - local res="" key= val="" hm="${ANON["${ast}"]}" - _hash_map; local new_hm="${r}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - eval val="\${${hm}[\"${key}\"]}" - EVAL "${val}" "${env}" - _assoc! "${new_hm}" "${key}" "${r}" - done - r="${new_hm}" ;; - *) - r="${ast}" ;; - esac -} - -EVAL () { - local ast="${1}" env="${2}" - r= - [[ "${__ERROR}" ]] && return 1 - #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - if [[ "${ot}" != "list" ]]; then - EVAL_AST "${ast}" "${env}" - return - fi - - # apply list - _empty? "${ast}" && r="${ast}" && return - - EVAL_AST "${ast}" "${env}" - [[ "${__ERROR}" ]] && return 1 - local el="${r}" - _first "${el}"; local f="${r}" - _rest "${el}"; local args="${ANON["${r}"]}" - #echo "invoke: ${f} ${args}" - eval ${f} ${args} -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -declare -A REPL_ENV -REP () { - r= - READ "${1}" - EVAL "${r}" REPL_ENV - PRINT "${r}" -} - -plus () { r=$(( ${ANON["${1}"]} + ${ANON["${2}"]} )); _number "${r}"; } -minus () { r=$(( ${ANON["${1}"]} - ${ANON["${2}"]} )); _number "${r}"; } -multiply () { r=$(( ${ANON["${1}"]} * ${ANON["${2}"]} )); _number "${r}"; } -divide () { r=$(( ${ANON["${1}"]} / ${ANON["${2}"]} )); _number "${r}"; } - -REPL_ENV["+"]=plus -REPL_ENV["-"]=minus -REPL_ENV["__STAR__"]=multiply -REPL_ENV["/"]=divide - -# repl loop -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +EVAL_AST () { + local ast="${1}" env="${2}" + #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + case "${ot}" in + symbol) + local val="${ANON["${ast}"]}" + eval r="\${${env}["${val}"]}" + [ "${r}" ] || _error "'${val}' not found" ;; + list) + _map_with_type _list EVAL "${ast}" "${env}" ;; + vector) + _map_with_type _vector EVAL "${ast}" "${env}" ;; + hash_map) + local res="" key= val="" hm="${ANON["${ast}"]}" + _hash_map; local new_hm="${r}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + eval val="\${${hm}[\"${key}\"]}" + EVAL "${val}" "${env}" + _assoc! "${new_hm}" "${key}" "${r}" + done + r="${new_hm}" ;; + *) + r="${ast}" ;; + esac +} + +EVAL () { + local ast="${1}" env="${2}" + r= + [[ "${__ERROR}" ]] && return 1 + #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + if [[ "${ot}" != "list" ]]; then + EVAL_AST "${ast}" "${env}" + return + fi + + # apply list + _empty? "${ast}" && r="${ast}" && return + + EVAL_AST "${ast}" "${env}" + [[ "${__ERROR}" ]] && return 1 + local el="${r}" + _first "${el}"; local f="${r}" + _rest "${el}"; local args="${ANON["${r}"]}" + #echo "invoke: ${f} ${args}" + eval ${f} ${args} +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" yes + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +declare -A REPL_ENV +REP () { + r= + READ "${1}" + EVAL "${r}" REPL_ENV + PRINT "${r}" +} + +plus () { r=$(( ${ANON["${1}"]} + ${ANON["${2}"]} )); _number "${r}"; } +minus () { r=$(( ${ANON["${1}"]} - ${ANON["${2}"]} )); _number "${r}"; } +multiply () { r=$(( ${ANON["${1}"]} * ${ANON["${2}"]} )); _number "${r}"; } +divide () { r=$(( ${ANON["${1}"]} / ${ANON["${2}"]} )); _number "${r}"; } + +REPL_ENV["+"]=plus +REPL_ENV["-"]=minus +REPL_ENV["__STAR__"]=multiply +REPL_ENV["/"]=divide + +# repl loop +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/step3_env.sh b/impls/bash/step3_env.sh index 2200c8362c..e50cb12a70 100755 --- a/impls/bash/step3_env.sh +++ b/impls/bash/step3_env.sh @@ -1,119 +1,119 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh -source $(dirname $0)/env.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -EVAL_AST () { - local ast="${1}" env="${2}" - #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - case "${ot}" in - symbol) - ENV_GET "${env}" "${ast}" - return ;; - list) - _map_with_type _list EVAL "${ast}" "${env}" ;; - vector) - _map_with_type _vector EVAL "${ast}" "${env}" ;; - hash_map) - local res="" key= val="" hm="${ANON["${ast}"]}" - _hash_map; local new_hm="${r}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - eval val="\${${hm}[\"${key}\"]}" - EVAL "${val}" "${env}" - _assoc! "${new_hm}" "${key}" "${r}" - done - r="${new_hm}" ;; - *) - r="${ast}" ;; - esac -} - -EVAL () { - local ast="${1}" env="${2}" - r= - [[ "${__ERROR}" ]] && return 1 - #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - if [[ "${ot}" != "list" ]]; then - EVAL_AST "${ast}" "${env}" - return - fi - - # apply list - _empty? "${ast}" && r="${ast}" && return - - _nth "${ast}" 0; local a0="${r}" - _nth "${ast}" 1; local a1="${r}" - _nth "${ast}" 2; local a2="${r}" - case "${ANON["${a0}"]}" in - def!) EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - ENV_SET "${env}" "${a1}" "${r}" - return ;; - let__STAR__) ENV "${env}"; local let_env="${r}" - local let_pairs=(${ANON["${a1}"]}) - local idx=0 - #echo "let: [${let_pairs[*]}] for ${a2}" - while [[ "${let_pairs["${idx}"]}" ]]; do - EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" - ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" - idx=$(( idx + 2)) - done - EVAL "${a2}" "${let_env}" - return ;; - *) EVAL_AST "${ast}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - local el="${r}" - _first "${el}"; local f="${r}" - _rest "${el}"; local args="${ANON["${r}"]}" - #echo "invoke: ${f} ${args}" - eval ${f} ${args} - return ;; - esac -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -ENV; REPL_ENV="${r}" -REP () { - r= - READ "${1}" - EVAL "${r}" "${REPL_ENV}" - PRINT "${r}" -} - -plus () { r=$(( ${ANON["${1}"]} + ${ANON["${2}"]} )); _number "${r}"; } -minus () { r=$(( ${ANON["${1}"]} - ${ANON["${2}"]} )); _number "${r}"; } -multiply () { r=$(( ${ANON["${1}"]} * ${ANON["${2}"]} )); _number "${r}"; } -divide () { r=$(( ${ANON["${1}"]} / ${ANON["${2}"]} )); _number "${r}"; } - -_symbol "+"; ENV_SET "${REPL_ENV}" "${r}" plus -_symbol "-"; ENV_SET "${REPL_ENV}" "${r}" minus -_symbol "__STAR__"; ENV_SET "${REPL_ENV}" "${r}" multiply -_symbol "/"; ENV_SET "${REPL_ENV}" "${r}" divide - -# repl loop -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh +source $(dirname $0)/env.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +EVAL_AST () { + local ast="${1}" env="${2}" + #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + case "${ot}" in + symbol) + ENV_GET "${env}" "${ast}" + return ;; + list) + _map_with_type _list EVAL "${ast}" "${env}" ;; + vector) + _map_with_type _vector EVAL "${ast}" "${env}" ;; + hash_map) + local res="" key= val="" hm="${ANON["${ast}"]}" + _hash_map; local new_hm="${r}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + eval val="\${${hm}[\"${key}\"]}" + EVAL "${val}" "${env}" + _assoc! "${new_hm}" "${key}" "${r}" + done + r="${new_hm}" ;; + *) + r="${ast}" ;; + esac +} + +EVAL () { + local ast="${1}" env="${2}" + r= + [[ "${__ERROR}" ]] && return 1 + #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + if [[ "${ot}" != "list" ]]; then + EVAL_AST "${ast}" "${env}" + return + fi + + # apply list + _empty? "${ast}" && r="${ast}" && return + + _nth "${ast}" 0; local a0="${r}" + _nth "${ast}" 1; local a1="${r}" + _nth "${ast}" 2; local a2="${r}" + case "${ANON["${a0}"]}" in + def!) EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + ENV_SET "${env}" "${a1}" "${r}" + return ;; + let__STAR__) ENV "${env}"; local let_env="${r}" + local let_pairs=(${ANON["${a1}"]}) + local idx=0 + #echo "let: [${let_pairs[*]}] for ${a2}" + while [[ "${let_pairs["${idx}"]}" ]]; do + EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" + ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" + idx=$(( idx + 2)) + done + EVAL "${a2}" "${let_env}" + return ;; + *) EVAL_AST "${ast}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + local el="${r}" + _first "${el}"; local f="${r}" + _rest "${el}"; local args="${ANON["${r}"]}" + #echo "invoke: ${f} ${args}" + eval ${f} ${args} + return ;; + esac +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" yes + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +ENV; REPL_ENV="${r}" +REP () { + r= + READ "${1}" + EVAL "${r}" "${REPL_ENV}" + PRINT "${r}" +} + +plus () { r=$(( ${ANON["${1}"]} + ${ANON["${2}"]} )); _number "${r}"; } +minus () { r=$(( ${ANON["${1}"]} - ${ANON["${2}"]} )); _number "${r}"; } +multiply () { r=$(( ${ANON["${1}"]} * ${ANON["${2}"]} )); _number "${r}"; } +divide () { r=$(( ${ANON["${1}"]} / ${ANON["${2}"]} )); _number "${r}"; } + +_symbol "+"; ENV_SET "${REPL_ENV}" "${r}" plus +_symbol "-"; ENV_SET "${REPL_ENV}" "${r}" minus +_symbol "__STAR__"; ENV_SET "${REPL_ENV}" "${r}" multiply +_symbol "/"; ENV_SET "${REPL_ENV}" "${r}" divide + +# repl loop +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/step4_if_fn_do.sh b/impls/bash/step4_if_fn_do.sh index e701e9fb25..8dba539ba1 100755 --- a/impls/bash/step4_if_fn_do.sh +++ b/impls/bash/step4_if_fn_do.sh @@ -1,144 +1,144 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh -source $(dirname $0)/env.sh -source $(dirname $0)/core.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -EVAL_AST () { - local ast="${1}" env="${2}" - #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - case "${ot}" in - symbol) - ENV_GET "${env}" "${ast}" - return ;; - list) - _map_with_type _list EVAL "${ast}" "${env}" ;; - vector) - _map_with_type _vector EVAL "${ast}" "${env}" ;; - hash_map) - local res="" key= val="" hm="${ANON["${ast}"]}" - _hash_map; local new_hm="${r}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - eval val="\${${hm}[\"${key}\"]}" - EVAL "${val}" "${env}" - _assoc! "${new_hm}" "${key}" "${r}" - done - r="${new_hm}" ;; - *) - r="${ast}" ;; - esac -} - -EVAL () { - local ast="${1}" env="${2}" - r= - [[ "${__ERROR}" ]] && return 1 - #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - if [[ "${ot}" != "list" ]]; then - EVAL_AST "${ast}" "${env}" - return - fi - - # apply list - _empty? "${ast}" && r="${ast}" && return - - _nth "${ast}" 0; local a0="${r}" - _nth "${ast}" 1; local a1="${r}" - _nth "${ast}" 2; local a2="${r}" - case "${ANON["${a0}"]}" in - def!) EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - ENV_SET "${env}" "${a1}" "${r}" - return ;; - let__STAR__) ENV "${env}"; local let_env="${r}" - local let_pairs=(${ANON["${a1}"]}) - local idx=0 - #echo "let: [${let_pairs[*]}] for ${a2}" - while [[ "${let_pairs["${idx}"]}" ]]; do - EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" - ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" - idx=$(( idx + 2)) - done - EVAL "${a2}" "${let_env}" - return ;; - do) _rest "${ast}" - EVAL_AST "${r}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - _last "${r}" - return ;; - if) EVAL "${a1}" "${env}" - [[ "${__ERROR}" ]] && return 1 - if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then - # eval false form - _nth "${ast}" 3; local a3="${r}" - if [[ "${a3}" ]]; then - EVAL "${a3}" "${env}" - else - r="${__nil}" - fi - else - # eval true condition - EVAL "${a2}" "${env}" - fi - return ;; - fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ - EVAL \"${a2}\" \"\${r}\"" - return ;; - *) EVAL_AST "${ast}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - local el="${r}" - _first "${el}"; local f="${ANON["${r}"]}" - _rest "${el}"; local args="${ANON["${r}"]}" - #echo "invoke: ${f} ${args}" - eval ${f} ${args} - return ;; - esac -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -ENV; REPL_ENV="${r}" -REP () { - r= - READ "${1}" - EVAL "${r}" "${REPL_ENV}" - PRINT "${r}" -} - -# core.sh: defined using bash -_fref () { - _symbol "${1}"; local sym="${r}" - _function "${2} \"\${@}\"" - ENV_SET "${REPL_ENV}" "${sym}" "${r}" -} -for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done - -# core.mal: defined using the language itself -REP "(def! not (fn* (a) (if a false true)))" - -# repl loop -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh +source $(dirname $0)/env.sh +source $(dirname $0)/core.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +EVAL_AST () { + local ast="${1}" env="${2}" + #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + case "${ot}" in + symbol) + ENV_GET "${env}" "${ast}" + return ;; + list) + _map_with_type _list EVAL "${ast}" "${env}" ;; + vector) + _map_with_type _vector EVAL "${ast}" "${env}" ;; + hash_map) + local res="" key= val="" hm="${ANON["${ast}"]}" + _hash_map; local new_hm="${r}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + eval val="\${${hm}[\"${key}\"]}" + EVAL "${val}" "${env}" + _assoc! "${new_hm}" "${key}" "${r}" + done + r="${new_hm}" ;; + *) + r="${ast}" ;; + esac +} + +EVAL () { + local ast="${1}" env="${2}" + r= + [[ "${__ERROR}" ]] && return 1 + #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + if [[ "${ot}" != "list" ]]; then + EVAL_AST "${ast}" "${env}" + return + fi + + # apply list + _empty? "${ast}" && r="${ast}" && return + + _nth "${ast}" 0; local a0="${r}" + _nth "${ast}" 1; local a1="${r}" + _nth "${ast}" 2; local a2="${r}" + case "${ANON["${a0}"]}" in + def!) EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + ENV_SET "${env}" "${a1}" "${r}" + return ;; + let__STAR__) ENV "${env}"; local let_env="${r}" + local let_pairs=(${ANON["${a1}"]}) + local idx=0 + #echo "let: [${let_pairs[*]}] for ${a2}" + while [[ "${let_pairs["${idx}"]}" ]]; do + EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" + ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" + idx=$(( idx + 2)) + done + EVAL "${a2}" "${let_env}" + return ;; + do) _rest "${ast}" + EVAL_AST "${r}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + _last "${r}" + return ;; + if) EVAL "${a1}" "${env}" + [[ "${__ERROR}" ]] && return 1 + if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then + # eval false form + _nth "${ast}" 3; local a3="${r}" + if [[ "${a3}" ]]; then + EVAL "${a3}" "${env}" + else + r="${__nil}" + fi + else + # eval true condition + EVAL "${a2}" "${env}" + fi + return ;; + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + EVAL \"${a2}\" \"\${r}\"" + return ;; + *) EVAL_AST "${ast}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + local el="${r}" + _first "${el}"; local f="${ANON["${r}"]}" + _rest "${el}"; local args="${ANON["${r}"]}" + #echo "invoke: ${f} ${args}" + eval ${f} ${args} + return ;; + esac +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" yes + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +ENV; REPL_ENV="${r}" +REP () { + r= + READ "${1}" + EVAL "${r}" "${REPL_ENV}" + PRINT "${r}" +} + +# core.sh: defined using bash +_fref () { + _symbol "${1}"; local sym="${r}" + _function "${2} \"\${@}\"" + ENV_SET "${REPL_ENV}" "${sym}" "${r}" +} +for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done + +# core.mal: defined using the language itself +REP "(def! not (fn* (a) (if a false true)))" + +# repl loop +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/step5_tco.sh b/impls/bash/step5_tco.sh index e7eda09a7b..cb6b6aba26 100755 --- a/impls/bash/step5_tco.sh +++ b/impls/bash/step5_tco.sh @@ -1,163 +1,163 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh -source $(dirname $0)/env.sh -source $(dirname $0)/core.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -EVAL_AST () { - local ast="${1}" env="${2}" - #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - case "${ot}" in - symbol) - ENV_GET "${env}" "${ast}" - return ;; - list) - _map_with_type _list EVAL "${ast}" "${env}" ;; - vector) - _map_with_type _vector EVAL "${ast}" "${env}" ;; - hash_map) - local res="" key= val="" hm="${ANON["${ast}"]}" - _hash_map; local new_hm="${r}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - eval val="\${${hm}[\"${key}\"]}" - EVAL "${val}" "${env}" - _assoc! "${new_hm}" "${key}" "${r}" - done - r="${new_hm}" ;; - *) - r="${ast}" ;; - esac -} - -EVAL () { - local ast="${1}" env="${2}" - while true; do - r= - [[ "${__ERROR}" ]] && return 1 - #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - if [[ "${ot}" != "list" ]]; then - EVAL_AST "${ast}" "${env}" - return - fi - - # apply list - _empty? "${ast}" && r="${ast}" && return - - _nth "${ast}" 0; local a0="${r}" - _nth "${ast}" 1; local a1="${r}" - _nth "${ast}" 2; local a2="${r}" - case "${ANON["${a0}"]}" in - def!) EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - ENV_SET "${env}" "${a1}" "${r}" - return ;; - let__STAR__) ENV "${env}"; local let_env="${r}" - local let_pairs=(${ANON["${a1}"]}) - local idx=0 - #echo "let: [${let_pairs[*]}] for ${a2}" - while [[ "${let_pairs["${idx}"]}" ]]; do - EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" - ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" - idx=$(( idx + 2)) - done - ast="${a2}" - env="${let_env}" - # Continue loop - ;; - do) _count "${ast}" - _slice "${ast}" 1 $(( ${r} - 2 )) - EVAL_AST "${r}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - _last "${ast}" - ast="${r}" - # Continue loop - ;; - if) EVAL "${a1}" "${env}" - [[ "${__ERROR}" ]] && return 1 - if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then - # eval false form - _nth "${ast}" 3; local a3="${r}" - if [[ "${a3}" ]]; then - ast="${a3}" - else - r="${__nil}" - return - fi - else - # eval true condition - ast="${a2}" - fi - # Continue loop - ;; - fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ - EVAL \"${a2}\" \"\${r}\"" \ - "${a2}" "${env}" "${a1}" - return ;; - *) EVAL_AST "${ast}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - local el="${r}" - _first "${el}"; local f="${ANON["${r}"]}" - _rest "${el}"; local args="${ANON["${r}"]}" - #echo "invoke: [${f}] ${args}" - if [[ "${f//@/ }" != "${f}" ]]; then - set -- ${f//@/ } - ast="${2}" - ENV "${3}" "${4}" ${args} - env="${r}" - else - eval ${f%%@*} ${args} - return - fi - # Continue loop - ;; - esac - done -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -ENV; REPL_ENV="${r}" -REP () { - r= - READ "${1}" - EVAL "${r}" "${REPL_ENV}" - PRINT "${r}" -} - -# core.sh: defined using bash -_fref () { - _symbol "${1}"; local sym="${r}" - _function "${2} \"\${@}\"" - ENV_SET "${REPL_ENV}" "${sym}" "${r}" -} -for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done - -# core.mal: defined using the language itself -REP "(def! not (fn* (a) (if a false true)))" - -# repl loop -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh +source $(dirname $0)/env.sh +source $(dirname $0)/core.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +EVAL_AST () { + local ast="${1}" env="${2}" + #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + case "${ot}" in + symbol) + ENV_GET "${env}" "${ast}" + return ;; + list) + _map_with_type _list EVAL "${ast}" "${env}" ;; + vector) + _map_with_type _vector EVAL "${ast}" "${env}" ;; + hash_map) + local res="" key= val="" hm="${ANON["${ast}"]}" + _hash_map; local new_hm="${r}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + eval val="\${${hm}[\"${key}\"]}" + EVAL "${val}" "${env}" + _assoc! "${new_hm}" "${key}" "${r}" + done + r="${new_hm}" ;; + *) + r="${ast}" ;; + esac +} + +EVAL () { + local ast="${1}" env="${2}" + while true; do + r= + [[ "${__ERROR}" ]] && return 1 + #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + if [[ "${ot}" != "list" ]]; then + EVAL_AST "${ast}" "${env}" + return + fi + + # apply list + _empty? "${ast}" && r="${ast}" && return + + _nth "${ast}" 0; local a0="${r}" + _nth "${ast}" 1; local a1="${r}" + _nth "${ast}" 2; local a2="${r}" + case "${ANON["${a0}"]}" in + def!) EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + ENV_SET "${env}" "${a1}" "${r}" + return ;; + let__STAR__) ENV "${env}"; local let_env="${r}" + local let_pairs=(${ANON["${a1}"]}) + local idx=0 + #echo "let: [${let_pairs[*]}] for ${a2}" + while [[ "${let_pairs["${idx}"]}" ]]; do + EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" + ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" + idx=$(( idx + 2)) + done + ast="${a2}" + env="${let_env}" + # Continue loop + ;; + do) _count "${ast}" + _slice "${ast}" 1 $(( ${r} - 2 )) + EVAL_AST "${r}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + _last "${ast}" + ast="${r}" + # Continue loop + ;; + if) EVAL "${a1}" "${env}" + [[ "${__ERROR}" ]] && return 1 + if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then + # eval false form + _nth "${ast}" 3; local a3="${r}" + if [[ "${a3}" ]]; then + ast="${a3}" + else + r="${__nil}" + return + fi + else + # eval true condition + ast="${a2}" + fi + # Continue loop + ;; + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + EVAL \"${a2}\" \"\${r}\"" \ + "${a2}" "${env}" "${a1}" + return ;; + *) EVAL_AST "${ast}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + local el="${r}" + _first "${el}"; local f="${ANON["${r}"]}" + _rest "${el}"; local args="${ANON["${r}"]}" + #echo "invoke: [${f}] ${args}" + if [[ "${f//@/ }" != "${f}" ]]; then + set -- ${f//@/ } + ast="${2}" + ENV "${3}" "${4}" ${args} + env="${r}" + else + eval ${f%%@*} ${args} + return + fi + # Continue loop + ;; + esac + done +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" yes + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +ENV; REPL_ENV="${r}" +REP () { + r= + READ "${1}" + EVAL "${r}" "${REPL_ENV}" + PRINT "${r}" +} + +# core.sh: defined using bash +_fref () { + _symbol "${1}"; local sym="${r}" + _function "${2} \"\${@}\"" + ENV_SET "${REPL_ENV}" "${sym}" "${r}" +} +for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done + +# core.mal: defined using the language itself +REP "(def! not (fn* (a) (if a false true)))" + +# repl loop +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/step6_file.sh b/impls/bash/step6_file.sh index 4d430883e8..23ece3d43a 100755 --- a/impls/bash/step6_file.sh +++ b/impls/bash/step6_file.sh @@ -1,176 +1,176 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh -source $(dirname $0)/env.sh -source $(dirname $0)/core.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -EVAL_AST () { - local ast="${1}" env="${2}" - #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - case "${ot}" in - symbol) - ENV_GET "${env}" "${ast}" - return ;; - list) - _map_with_type _list EVAL "${ast}" "${env}" ;; - vector) - _map_with_type _vector EVAL "${ast}" "${env}" ;; - hash_map) - local res="" key= val="" hm="${ANON["${ast}"]}" - _hash_map; local new_hm="${r}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - eval val="\${${hm}[\"${key}\"]}" - EVAL "${val}" "${env}" - _assoc! "${new_hm}" "${key}" "${r}" - done - r="${new_hm}" ;; - *) - r="${ast}" ;; - esac -} - -EVAL () { - local ast="${1}" env="${2}" - while true; do - r= - [[ "${__ERROR}" ]] && return 1 - #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - if [[ "${ot}" != "list" ]]; then - EVAL_AST "${ast}" "${env}" - return - fi - - # apply list - _empty? "${ast}" && r="${ast}" && return - - _nth "${ast}" 0; local a0="${r}" - _nth "${ast}" 1; local a1="${r}" - _nth "${ast}" 2; local a2="${r}" - case "${ANON["${a0}"]}" in - def!) EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - ENV_SET "${env}" "${a1}" "${r}" - return ;; - let__STAR__) ENV "${env}"; local let_env="${r}" - local let_pairs=(${ANON["${a1}"]}) - local idx=0 - #echo "let: [${let_pairs[*]}] for ${a2}" - while [[ "${let_pairs["${idx}"]}" ]]; do - EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" - ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" - idx=$(( idx + 2)) - done - ast="${a2}" - env="${let_env}" - # Continue loop - ;; - do) _count "${ast}" - _slice "${ast}" 1 $(( ${r} - 2 )) - EVAL_AST "${r}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - _last "${ast}" - ast="${r}" - # Continue loop - ;; - if) EVAL "${a1}" "${env}" - [[ "${__ERROR}" ]] && return 1 - if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then - # eval false form - _nth "${ast}" 3; local a3="${r}" - if [[ "${a3}" ]]; then - ast="${a3}" - else - r="${__nil}" - return - fi - else - # eval true condition - ast="${a2}" - fi - # Continue loop - ;; - fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ - EVAL \"${a2}\" \"\${r}\"" \ - "${a2}" "${env}" "${a1}" - return ;; - *) EVAL_AST "${ast}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - local el="${r}" - _first "${el}"; local f="${ANON["${r}"]}" - _rest "${el}"; local args="${ANON["${r}"]}" - #echo "invoke: [${f}] ${args}" - if [[ "${f//@/ }" != "${f}" ]]; then - set -- ${f//@/ } - ast="${2}" - ENV "${3}" "${4}" ${args} - env="${r}" - else - eval ${f%%@*} ${args} - return - fi - # Continue loop - ;; - esac - done -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -ENV; REPL_ENV="${r}" -REP () { - r= - READ "${1}" - EVAL "${r}" "${REPL_ENV}" - PRINT "${r}" -} - -# core.sh: defined using bash -_fref () { - _symbol "${1}"; local sym="${r}" - _function "${2} \"\${@}\"" - ENV_SET "${REPL_ENV}" "${sym}" "${r}" -} -for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done -_eval () { EVAL "${1}" "${REPL_ENV}"; } -_fref "eval" _eval -_list; argv="${r}" -for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done -_symbol "__STAR__ARGV__STAR__" -ENV_SET "${REPL_ENV}" "${r}" "${argv}"; - -# core.mal: defined using the language itself -REP "(def! not (fn* (a) (if a false true)))" -REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - -# load/run file from command line (then exit) -if [[ "${1}" ]]; then - REP "(load-file \"${1}\")" - exit 0 -fi - -# repl loop -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh +source $(dirname $0)/env.sh +source $(dirname $0)/core.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +EVAL_AST () { + local ast="${1}" env="${2}" + #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + case "${ot}" in + symbol) + ENV_GET "${env}" "${ast}" + return ;; + list) + _map_with_type _list EVAL "${ast}" "${env}" ;; + vector) + _map_with_type _vector EVAL "${ast}" "${env}" ;; + hash_map) + local res="" key= val="" hm="${ANON["${ast}"]}" + _hash_map; local new_hm="${r}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + eval val="\${${hm}[\"${key}\"]}" + EVAL "${val}" "${env}" + _assoc! "${new_hm}" "${key}" "${r}" + done + r="${new_hm}" ;; + *) + r="${ast}" ;; + esac +} + +EVAL () { + local ast="${1}" env="${2}" + while true; do + r= + [[ "${__ERROR}" ]] && return 1 + #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + if [[ "${ot}" != "list" ]]; then + EVAL_AST "${ast}" "${env}" + return + fi + + # apply list + _empty? "${ast}" && r="${ast}" && return + + _nth "${ast}" 0; local a0="${r}" + _nth "${ast}" 1; local a1="${r}" + _nth "${ast}" 2; local a2="${r}" + case "${ANON["${a0}"]}" in + def!) EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + ENV_SET "${env}" "${a1}" "${r}" + return ;; + let__STAR__) ENV "${env}"; local let_env="${r}" + local let_pairs=(${ANON["${a1}"]}) + local idx=0 + #echo "let: [${let_pairs[*]}] for ${a2}" + while [[ "${let_pairs["${idx}"]}" ]]; do + EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" + ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" + idx=$(( idx + 2)) + done + ast="${a2}" + env="${let_env}" + # Continue loop + ;; + do) _count "${ast}" + _slice "${ast}" 1 $(( ${r} - 2 )) + EVAL_AST "${r}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + _last "${ast}" + ast="${r}" + # Continue loop + ;; + if) EVAL "${a1}" "${env}" + [[ "${__ERROR}" ]] && return 1 + if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then + # eval false form + _nth "${ast}" 3; local a3="${r}" + if [[ "${a3}" ]]; then + ast="${a3}" + else + r="${__nil}" + return + fi + else + # eval true condition + ast="${a2}" + fi + # Continue loop + ;; + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + EVAL \"${a2}\" \"\${r}\"" \ + "${a2}" "${env}" "${a1}" + return ;; + *) EVAL_AST "${ast}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + local el="${r}" + _first "${el}"; local f="${ANON["${r}"]}" + _rest "${el}"; local args="${ANON["${r}"]}" + #echo "invoke: [${f}] ${args}" + if [[ "${f//@/ }" != "${f}" ]]; then + set -- ${f//@/ } + ast="${2}" + ENV "${3}" "${4}" ${args} + env="${r}" + else + eval ${f%%@*} ${args} + return + fi + # Continue loop + ;; + esac + done +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" yes + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +ENV; REPL_ENV="${r}" +REP () { + r= + READ "${1}" + EVAL "${r}" "${REPL_ENV}" + PRINT "${r}" +} + +# core.sh: defined using bash +_fref () { + _symbol "${1}"; local sym="${r}" + _function "${2} \"\${@}\"" + ENV_SET "${REPL_ENV}" "${sym}" "${r}" +} +for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done +_eval () { EVAL "${1}" "${REPL_ENV}"; } +_fref "eval" _eval +_list; argv="${r}" +for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done +_symbol "__STAR__ARGV__STAR__" +ENV_SET "${REPL_ENV}" "${r}" "${argv}"; + +# core.mal: defined using the language itself +REP "(def! not (fn* (a) (if a false true)))" +REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + +# load/run file from command line (then exit) +if [[ "${1}" ]]; then + REP "(load-file \"${1}\")" + exit 0 +fi + +# repl loop +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/step7_quote.sh b/impls/bash/step7_quote.sh index f6076fc85a..7b577cbd86 100755 --- a/impls/bash/step7_quote.sh +++ b/impls/bash/step7_quote.sh @@ -1,229 +1,229 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh -source $(dirname $0)/env.sh -source $(dirname $0)/core.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -starts_with () { - _list? "$1" && _first "$1" && _symbol? "$r" && [ "${ANON[$r]}" = "$2" ] -} - -QUASIQUOTE () { - _obj_type "$1" - case "$r" in - list) - if starts_with "$1" unquote; then - _nth "$1" 1 - else - qqIter "$1" - fi ;; - vector) - _symbol vec; local a="$r" - qqIter "$1" - _list "$a" "$r" ;; - symbol|hash_map) - _symbol quote - _list "$r" "$1" ;; - *) - r="$1" ;; - esac -} - -qqIter () { - if _empty? "$1"; then - _list - else - _nth "${1}" 0; local a0="$r" - if starts_with "$a0" splice-unquote; then - _symbol concat; local a="$r" - _nth "$a0" 1; local b="$r" - else - _symbol cons; local a="$r" - QUASIQUOTE "$a0"; local b="$r" - fi - _rest "$1" - qqIter "$r" - _list "$a" "$b" "$r" - fi -} - -EVAL_AST () { - local ast="${1}" env="${2}" - #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - case "${ot}" in - symbol) - ENV_GET "${env}" "${ast}" - return ;; - list) - _map_with_type _list EVAL "${ast}" "${env}" ;; - vector) - _map_with_type _vector EVAL "${ast}" "${env}" ;; - hash_map) - local res="" key= val="" hm="${ANON["${ast}"]}" - _hash_map; local new_hm="${r}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - eval val="\${${hm}[\"${key}\"]}" - EVAL "${val}" "${env}" - _assoc! "${new_hm}" "${key}" "${r}" - done - r="${new_hm}" ;; - *) - r="${ast}" ;; - esac -} - -EVAL () { - local ast="${1}" env="${2}" - while true; do - r= - [[ "${__ERROR}" ]] && return 1 - #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" - if ! _list? "${ast}"; then - EVAL_AST "${ast}" "${env}" - return - fi - - # apply list - _empty? "${ast}" && r="${ast}" && return - - _nth "${ast}" 0; local a0="${r}" - _nth "${ast}" 1; local a1="${r}" - _nth "${ast}" 2; local a2="${r}" - case "${ANON["${a0}"]}" in - def!) EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - ENV_SET "${env}" "${a1}" "${r}" - return ;; - let__STAR__) ENV "${env}"; local let_env="${r}" - local let_pairs=(${ANON["${a1}"]}) - local idx=0 - #echo "let: [${let_pairs[*]}] for ${a2}" - while [[ "${let_pairs["${idx}"]}" ]]; do - EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" - ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" - idx=$(( idx + 2)) - done - ast="${a2}" - env="${let_env}" - # Continue loop - ;; - quote) - r="${a1}" - return ;; - quasiquoteexpand) - QUASIQUOTE "${a1}" - return ;; - quasiquote) - QUASIQUOTE "${a1}" - ast="${r}" - # Continue loop - ;; - do) _count "${ast}" - _slice "${ast}" 1 $(( ${r} - 2 )) - EVAL_AST "${r}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - _last "${ast}" - ast="${r}" - # Continue loop - ;; - if) EVAL "${a1}" "${env}" - [[ "${__ERROR}" ]] && return 1 - if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then - # eval false form - _nth "${ast}" 3; local a3="${r}" - if [[ "${a3}" ]]; then - ast="${a3}" - else - r="${__nil}" - return - fi - else - # eval true condition - ast="${a2}" - fi - # Continue loop - ;; - fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ - EVAL \"${a2}\" \"\${r}\"" \ - "${a2}" "${env}" "${a1}" - return ;; - *) EVAL_AST "${ast}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - local el="${r}" - _first "${el}"; local f="${ANON["${r}"]}" - _rest "${el}"; local args="${ANON["${r}"]}" - #echo "invoke: [${f}] ${args}" - if [[ "${f//@/ }" != "${f}" ]]; then - set -- ${f//@/ } - ast="${2}" - ENV "${3}" "${4}" ${args} - env="${r}" - else - eval ${f%%@*} ${args} - return - fi - # Continue loop - ;; - esac - done -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -ENV; REPL_ENV="${r}" -REP () { - r= - READ "${1}" - EVAL "${r}" "${REPL_ENV}" - PRINT "${r}" -} - -# core.sh: defined using bash -_fref () { - _symbol "${1}"; local sym="${r}" - _function "${2} \"\${@}\"" - ENV_SET "${REPL_ENV}" "${sym}" "${r}" -} -for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done -_eval () { EVAL "${1}" "${REPL_ENV}"; } -_fref "eval" _eval -_list; argv="${r}" -for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done -_symbol "__STAR__ARGV__STAR__" -ENV_SET "${REPL_ENV}" "${r}" "${argv}"; - -# core.mal: defined using the language itself -REP "(def! not (fn* (a) (if a false true)))" -REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - -# load/run file from command line (then exit) -if [[ "${1}" ]]; then - REP "(load-file \"${1}\")" - exit 0 -fi - -# repl loop -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh +source $(dirname $0)/env.sh +source $(dirname $0)/core.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +starts_with () { + _list? "$1" && _first "$1" && _symbol? "$r" && [ "${ANON[$r]}" = "$2" ] +} + +QUASIQUOTE () { + _obj_type "$1" + case "$r" in + list) + if starts_with "$1" unquote; then + _nth "$1" 1 + else + qqIter "$1" + fi ;; + vector) + _symbol vec; local a="$r" + qqIter "$1" + _list "$a" "$r" ;; + symbol|hash_map) + _symbol quote + _list "$r" "$1" ;; + *) + r="$1" ;; + esac +} + +qqIter () { + if _empty? "$1"; then + _list + else + _nth "${1}" 0; local a0="$r" + if starts_with "$a0" splice-unquote; then + _symbol concat; local a="$r" + _nth "$a0" 1; local b="$r" + else + _symbol cons; local a="$r" + QUASIQUOTE "$a0"; local b="$r" + fi + _rest "$1" + qqIter "$r" + _list "$a" "$b" "$r" + fi +} + +EVAL_AST () { + local ast="${1}" env="${2}" + #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + case "${ot}" in + symbol) + ENV_GET "${env}" "${ast}" + return ;; + list) + _map_with_type _list EVAL "${ast}" "${env}" ;; + vector) + _map_with_type _vector EVAL "${ast}" "${env}" ;; + hash_map) + local res="" key= val="" hm="${ANON["${ast}"]}" + _hash_map; local new_hm="${r}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + eval val="\${${hm}[\"${key}\"]}" + EVAL "${val}" "${env}" + _assoc! "${new_hm}" "${key}" "${r}" + done + r="${new_hm}" ;; + *) + r="${ast}" ;; + esac +} + +EVAL () { + local ast="${1}" env="${2}" + while true; do + r= + [[ "${__ERROR}" ]] && return 1 + #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" + if ! _list? "${ast}"; then + EVAL_AST "${ast}" "${env}" + return + fi + + # apply list + _empty? "${ast}" && r="${ast}" && return + + _nth "${ast}" 0; local a0="${r}" + _nth "${ast}" 1; local a1="${r}" + _nth "${ast}" 2; local a2="${r}" + case "${ANON["${a0}"]}" in + def!) EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + ENV_SET "${env}" "${a1}" "${r}" + return ;; + let__STAR__) ENV "${env}"; local let_env="${r}" + local let_pairs=(${ANON["${a1}"]}) + local idx=0 + #echo "let: [${let_pairs[*]}] for ${a2}" + while [[ "${let_pairs["${idx}"]}" ]]; do + EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" + ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" + idx=$(( idx + 2)) + done + ast="${a2}" + env="${let_env}" + # Continue loop + ;; + quote) + r="${a1}" + return ;; + quasiquoteexpand) + QUASIQUOTE "${a1}" + return ;; + quasiquote) + QUASIQUOTE "${a1}" + ast="${r}" + # Continue loop + ;; + do) _count "${ast}" + _slice "${ast}" 1 $(( ${r} - 2 )) + EVAL_AST "${r}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + _last "${ast}" + ast="${r}" + # Continue loop + ;; + if) EVAL "${a1}" "${env}" + [[ "${__ERROR}" ]] && return 1 + if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then + # eval false form + _nth "${ast}" 3; local a3="${r}" + if [[ "${a3}" ]]; then + ast="${a3}" + else + r="${__nil}" + return + fi + else + # eval true condition + ast="${a2}" + fi + # Continue loop + ;; + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + EVAL \"${a2}\" \"\${r}\"" \ + "${a2}" "${env}" "${a1}" + return ;; + *) EVAL_AST "${ast}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + local el="${r}" + _first "${el}"; local f="${ANON["${r}"]}" + _rest "${el}"; local args="${ANON["${r}"]}" + #echo "invoke: [${f}] ${args}" + if [[ "${f//@/ }" != "${f}" ]]; then + set -- ${f//@/ } + ast="${2}" + ENV "${3}" "${4}" ${args} + env="${r}" + else + eval ${f%%@*} ${args} + return + fi + # Continue loop + ;; + esac + done +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" yes + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +ENV; REPL_ENV="${r}" +REP () { + r= + READ "${1}" + EVAL "${r}" "${REPL_ENV}" + PRINT "${r}" +} + +# core.sh: defined using bash +_fref () { + _symbol "${1}"; local sym="${r}" + _function "${2} \"\${@}\"" + ENV_SET "${REPL_ENV}" "${sym}" "${r}" +} +for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done +_eval () { EVAL "${1}" "${REPL_ENV}"; } +_fref "eval" _eval +_list; argv="${r}" +for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done +_symbol "__STAR__ARGV__STAR__" +ENV_SET "${REPL_ENV}" "${r}" "${argv}"; + +# core.mal: defined using the language itself +REP "(def! not (fn* (a) (if a false true)))" +REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + +# load/run file from command line (then exit) +if [[ "${1}" ]]; then + REP "(load-file \"${1}\")" + exit 0 +fi + +# repl loop +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/step8_macros.sh b/impls/bash/step8_macros.sh index 2a632c89b7..31970373d3 100755 --- a/impls/bash/step8_macros.sh +++ b/impls/bash/step8_macros.sh @@ -1,275 +1,275 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh -source $(dirname $0)/env.sh -source $(dirname $0)/core.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -starts_with () { - _list? "$1" && _first "$1" && _symbol? "$r" && [ "${ANON[$r]}" = "$2" ] -} - -QUASIQUOTE () { - _obj_type "$1" - case "$r" in - list) - if starts_with "$1" unquote; then - _nth "$1" 1 - else - qqIter "$1" - fi ;; - vector) - _symbol vec; local a="$r" - qqIter "$1" - _list "$a" "$r" ;; - symbol|hash_map) - _symbol quote - _list "$r" "$1" ;; - *) - r="$1" ;; - esac -} - -qqIter () { - if _empty? "$1"; then - _list - else - _nth "${1}" 0; local a0="$r" - if starts_with "$a0" splice-unquote; then - _symbol concat; local a="$r" - _nth "$a0" 1; local b="$r" - else - _symbol cons; local a="$r" - QUASIQUOTE "$a0"; local b="$r" - fi - _rest "$1" - qqIter "$r" - _list "$a" "$b" "$r" - fi -} - -IS_MACRO_CALL () { - if ! _list? "${1}"; then return 1; fi - _nth "${1}" 0; local a0="${r}" - if _symbol? "${a0}"; then - ENV_FIND "${2}" "${a0}" - if [[ "${r}" ]]; then - ENV_GET "${2}" "${a0}" - [ "${ANON["${r}_ismacro_"]}" ] - return $? - fi - fi - return 1 -} - -MACROEXPAND () { - local ast="${1}" env="${2}" - while IS_MACRO_CALL "${ast}" "${env}"; do - _nth "${ast}" 0; local a0="${r}" - ENV_GET "${env}" "${a0}"; local mac="${ANON["${r}"]}" - _rest "${ast}" - ${mac%%@*} ${ANON["${r}"]} - ast="${r}" - done - r="${ast}" -} - - -EVAL_AST () { - local ast="${1}" env="${2}" - #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - case "${ot}" in - symbol) - ENV_GET "${env}" "${ast}" - return ;; - list) - _map_with_type _list EVAL "${ast}" "${env}" ;; - vector) - _map_with_type _vector EVAL "${ast}" "${env}" ;; - hash_map) - local res="" key= val="" hm="${ANON["${ast}"]}" - _hash_map; local new_hm="${r}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - eval val="\${${hm}[\"${key}\"]}" - EVAL "${val}" "${env}" - _assoc! "${new_hm}" "${key}" "${r}" - done - r="${new_hm}" ;; - *) - r="${ast}" ;; - esac -} - -EVAL () { - local ast="${1}" env="${2}" - while true; do - r= - [[ "${__ERROR}" ]] && return 1 - #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" - if ! _list? "${ast}"; then - EVAL_AST "${ast}" "${env}" - return - fi - - # apply list - MACROEXPAND "${ast}" "${env}" - ast="${r}" - if ! _list? "${ast}"; then - EVAL_AST "${ast}" "${env}" - return - fi - _empty? "${ast}" && r="${ast}" && return - - _nth "${ast}" 0; local a0="${r}" - _nth "${ast}" 1; local a1="${r}" - _nth "${ast}" 2; local a2="${r}" - case "${ANON["${a0}"]}" in - def!) EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - ENV_SET "${env}" "${a1}" "${r}" - return ;; - let__STAR__) ENV "${env}"; local let_env="${r}" - local let_pairs=(${ANON["${a1}"]}) - local idx=0 - #echo "let: [${let_pairs[*]}] for ${a2}" - while [[ "${let_pairs["${idx}"]}" ]]; do - EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" - ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" - idx=$(( idx + 2)) - done - ast="${a2}" - env="${let_env}" - # Continue loop - ;; - quote) - r="${a1}" - return ;; - quasiquoteexpand) - QUASIQUOTE "${a1}" - return ;; - quasiquote) - QUASIQUOTE "${a1}" - ast="${r}" - # Continue loop - ;; - defmacro!) - EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - local func="${r}" - __new_obj_like "${func}" - ANON["${r}"]="${ANON["${func}"]}" - ANON["${r}_ismacro_"]="yes" - ENV_SET "${env}" "${a1}" "${r}" - return ;; - macroexpand) - MACROEXPAND "${a1}" "${env}" - return ;; - do) _count "${ast}" - _slice "${ast}" 1 $(( ${r} - 2 )) - EVAL_AST "${r}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - _last "${ast}" - ast="${r}" - # Continue loop - ;; - if) EVAL "${a1}" "${env}" - [[ "${__ERROR}" ]] && return 1 - if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then - # eval false form - _nth "${ast}" 3; local a3="${r}" - if [[ "${a3}" ]]; then - ast="${a3}" - else - r="${__nil}" - return - fi - else - # eval true condition - ast="${a2}" - fi - # Continue loop - ;; - fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ - EVAL \"${a2}\" \"\${r}\"" \ - "${a2}" "${env}" "${a1}" - return ;; - *) EVAL_AST "${ast}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - local el="${r}" - _first "${el}"; local f="${ANON["${r}"]}" - _rest "${el}"; local args="${ANON["${r}"]}" - #echo "invoke: [${f}] ${args}" - if [[ "${f//@/ }" != "${f}" ]]; then - set -- ${f//@/ } - ast="${2}" - ENV "${3}" "${4}" ${args} - env="${r}" - else - eval ${f%%@*} ${args} - return - fi - # Continue loop - ;; - esac - done -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -ENV; REPL_ENV="${r}" -REP () { - r= - READ "${1}" - EVAL "${r}" "${REPL_ENV}" - PRINT "${r}" -} - -# core.sh: defined using bash -_fref () { - _symbol "${1}"; local sym="${r}" - _function "${2} \"\${@}\"" - ENV_SET "${REPL_ENV}" "${sym}" "${r}" -} -for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done -_eval () { EVAL "${1}" "${REPL_ENV}"; } -_fref "eval" _eval -_list; argv="${r}" -for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done -_symbol "__STAR__ARGV__STAR__" -ENV_SET "${REPL_ENV}" "${r}" "${argv}"; - -# core.mal: defined using the language itself -REP "(def! not (fn* (a) (if a false true)))" -REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -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)))))))" - -# load/run file from command line (then exit) -if [[ "${1}" ]]; then - REP "(load-file \"${1}\")" - exit 0 -fi - -# repl loop -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh +source $(dirname $0)/env.sh +source $(dirname $0)/core.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +starts_with () { + _list? "$1" && _first "$1" && _symbol? "$r" && [ "${ANON[$r]}" = "$2" ] +} + +QUASIQUOTE () { + _obj_type "$1" + case "$r" in + list) + if starts_with "$1" unquote; then + _nth "$1" 1 + else + qqIter "$1" + fi ;; + vector) + _symbol vec; local a="$r" + qqIter "$1" + _list "$a" "$r" ;; + symbol|hash_map) + _symbol quote + _list "$r" "$1" ;; + *) + r="$1" ;; + esac +} + +qqIter () { + if _empty? "$1"; then + _list + else + _nth "${1}" 0; local a0="$r" + if starts_with "$a0" splice-unquote; then + _symbol concat; local a="$r" + _nth "$a0" 1; local b="$r" + else + _symbol cons; local a="$r" + QUASIQUOTE "$a0"; local b="$r" + fi + _rest "$1" + qqIter "$r" + _list "$a" "$b" "$r" + fi +} + +IS_MACRO_CALL () { + if ! _list? "${1}"; then return 1; fi + _nth "${1}" 0; local a0="${r}" + if _symbol? "${a0}"; then + ENV_FIND "${2}" "${a0}" + if [[ "${r}" ]]; then + ENV_GET "${2}" "${a0}" + [ "${ANON["${r}_ismacro_"]}" ] + return $? + fi + fi + return 1 +} + +MACROEXPAND () { + local ast="${1}" env="${2}" + while IS_MACRO_CALL "${ast}" "${env}"; do + _nth "${ast}" 0; local a0="${r}" + ENV_GET "${env}" "${a0}"; local mac="${ANON["${r}"]}" + _rest "${ast}" + ${mac%%@*} ${ANON["${r}"]} + ast="${r}" + done + r="${ast}" +} + + +EVAL_AST () { + local ast="${1}" env="${2}" + #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + case "${ot}" in + symbol) + ENV_GET "${env}" "${ast}" + return ;; + list) + _map_with_type _list EVAL "${ast}" "${env}" ;; + vector) + _map_with_type _vector EVAL "${ast}" "${env}" ;; + hash_map) + local res="" key= val="" hm="${ANON["${ast}"]}" + _hash_map; local new_hm="${r}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + eval val="\${${hm}[\"${key}\"]}" + EVAL "${val}" "${env}" + _assoc! "${new_hm}" "${key}" "${r}" + done + r="${new_hm}" ;; + *) + r="${ast}" ;; + esac +} + +EVAL () { + local ast="${1}" env="${2}" + while true; do + r= + [[ "${__ERROR}" ]] && return 1 + #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" + if ! _list? "${ast}"; then + EVAL_AST "${ast}" "${env}" + return + fi + + # apply list + MACROEXPAND "${ast}" "${env}" + ast="${r}" + if ! _list? "${ast}"; then + EVAL_AST "${ast}" "${env}" + return + fi + _empty? "${ast}" && r="${ast}" && return + + _nth "${ast}" 0; local a0="${r}" + _nth "${ast}" 1; local a1="${r}" + _nth "${ast}" 2; local a2="${r}" + case "${ANON["${a0}"]}" in + def!) EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + ENV_SET "${env}" "${a1}" "${r}" + return ;; + let__STAR__) ENV "${env}"; local let_env="${r}" + local let_pairs=(${ANON["${a1}"]}) + local idx=0 + #echo "let: [${let_pairs[*]}] for ${a2}" + while [[ "${let_pairs["${idx}"]}" ]]; do + EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" + ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" + idx=$(( idx + 2)) + done + ast="${a2}" + env="${let_env}" + # Continue loop + ;; + quote) + r="${a1}" + return ;; + quasiquoteexpand) + QUASIQUOTE "${a1}" + return ;; + quasiquote) + QUASIQUOTE "${a1}" + ast="${r}" + # Continue loop + ;; + defmacro!) + EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + local func="${r}" + __new_obj_like "${func}" + ANON["${r}"]="${ANON["${func}"]}" + ANON["${r}_ismacro_"]="yes" + ENV_SET "${env}" "${a1}" "${r}" + return ;; + macroexpand) + MACROEXPAND "${a1}" "${env}" + return ;; + do) _count "${ast}" + _slice "${ast}" 1 $(( ${r} - 2 )) + EVAL_AST "${r}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + _last "${ast}" + ast="${r}" + # Continue loop + ;; + if) EVAL "${a1}" "${env}" + [[ "${__ERROR}" ]] && return 1 + if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then + # eval false form + _nth "${ast}" 3; local a3="${r}" + if [[ "${a3}" ]]; then + ast="${a3}" + else + r="${__nil}" + return + fi + else + # eval true condition + ast="${a2}" + fi + # Continue loop + ;; + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + EVAL \"${a2}\" \"\${r}\"" \ + "${a2}" "${env}" "${a1}" + return ;; + *) EVAL_AST "${ast}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + local el="${r}" + _first "${el}"; local f="${ANON["${r}"]}" + _rest "${el}"; local args="${ANON["${r}"]}" + #echo "invoke: [${f}] ${args}" + if [[ "${f//@/ }" != "${f}" ]]; then + set -- ${f//@/ } + ast="${2}" + ENV "${3}" "${4}" ${args} + env="${r}" + else + eval ${f%%@*} ${args} + return + fi + # Continue loop + ;; + esac + done +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" yes + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +ENV; REPL_ENV="${r}" +REP () { + r= + READ "${1}" + EVAL "${r}" "${REPL_ENV}" + PRINT "${r}" +} + +# core.sh: defined using bash +_fref () { + _symbol "${1}"; local sym="${r}" + _function "${2} \"\${@}\"" + ENV_SET "${REPL_ENV}" "${sym}" "${r}" +} +for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done +_eval () { EVAL "${1}" "${REPL_ENV}"; } +_fref "eval" _eval +_list; argv="${r}" +for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done +_symbol "__STAR__ARGV__STAR__" +ENV_SET "${REPL_ENV}" "${r}" "${argv}"; + +# core.mal: defined using the language itself +REP "(def! not (fn* (a) (if a false true)))" +REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +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)))))))" + +# load/run file from command line (then exit) +if [[ "${1}" ]]; then + REP "(load-file \"${1}\")" + exit 0 +fi + +# repl loop +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/step9_try.sh b/impls/bash/step9_try.sh index 7b824e847c..de94e901f7 100755 --- a/impls/bash/step9_try.sh +++ b/impls/bash/step9_try.sh @@ -1,288 +1,288 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh -source $(dirname $0)/env.sh -source $(dirname $0)/core.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -starts_with () { - _list? "$1" && _first "$1" && _symbol? "$r" && [ "${ANON[$r]}" = "$2" ] -} - -QUASIQUOTE () { - _obj_type "$1" - case "$r" in - list) - if starts_with "$1" unquote; then - _nth "$1" 1 - else - qqIter "$1" - fi ;; - vector) - _symbol vec; local a="$r" - qqIter "$1" - _list "$a" "$r" ;; - symbol|hash_map) - _symbol quote - _list "$r" "$1" ;; - *) - r="$1" ;; - esac -} - -qqIter () { - if _empty? "$1"; then - _list - else - _nth "${1}" 0; local a0="$r" - if starts_with "$a0" splice-unquote; then - _symbol concat; local a="$r" - _nth "$a0" 1; local b="$r" - else - _symbol cons; local a="$r" - QUASIQUOTE "$a0"; local b="$r" - fi - _rest "$1" - qqIter "$r" - _list "$a" "$b" "$r" - fi -} - -IS_MACRO_CALL () { - if ! _list? "${1}"; then return 1; fi - _nth "${1}" 0; local a0="${r}" - if _symbol? "${a0}"; then - ENV_FIND "${2}" "${a0}" - if [[ "${r}" ]]; then - ENV_GET "${2}" "${a0}" - [ "${ANON["${r}_ismacro_"]}" ] - return $? - fi - fi - return 1 -} - -MACROEXPAND () { - local ast="${1}" env="${2}" - while IS_MACRO_CALL "${ast}" "${env}"; do - _nth "${ast}" 0; local a0="${r}" - ENV_GET "${env}" "${a0}"; local mac="${ANON["${r}"]}" - _rest "${ast}" - ${mac%%@*} ${ANON["${r}"]} - ast="${r}" - done - r="${ast}" -} - - -EVAL_AST () { - local ast="${1}" env="${2}" - #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - case "${ot}" in - symbol) - ENV_GET "${env}" "${ast}" - return ;; - list) - _map_with_type _list EVAL "${ast}" "${env}" ;; - vector) - _map_with_type _vector EVAL "${ast}" "${env}" ;; - hash_map) - local res="" key= val="" hm="${ANON["${ast}"]}" - _hash_map; local new_hm="${r}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - eval val="\${${hm}[\"${key}\"]}" - EVAL "${val}" "${env}" - _assoc! "${new_hm}" "${key}" "${r}" - done - r="${new_hm}" ;; - *) - r="${ast}" ;; - esac -} - -EVAL () { - local ast="${1}" env="${2}" - while true; do - r= - [[ "${__ERROR}" ]] && return 1 - #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" - if ! _list? "${ast}"; then - EVAL_AST "${ast}" "${env}" - return - fi - - # apply list - MACROEXPAND "${ast}" "${env}" - ast="${r}" - if ! _list? "${ast}"; then - EVAL_AST "${ast}" "${env}" - return - fi - _empty? "${ast}" && r="${ast}" && return - - _nth "${ast}" 0; local a0="${r}" - _nth "${ast}" 1; local a1="${r}" - _nth "${ast}" 2; local a2="${r}" - case "${ANON["${a0}"]}" in - def!) EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - ENV_SET "${env}" "${a1}" "${r}" - return ;; - let__STAR__) ENV "${env}"; local let_env="${r}" - local let_pairs=(${ANON["${a1}"]}) - local idx=0 - #echo "let: [${let_pairs[*]}] for ${a2}" - while [[ "${let_pairs["${idx}"]}" ]]; do - EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" - ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" - idx=$(( idx + 2)) - done - ast="${a2}" - env="${let_env}" - # Continue loop - ;; - quote) - r="${a1}" - return ;; - quasiquoteexpand) - QUASIQUOTE "${a1}" - return ;; - quasiquote) - QUASIQUOTE "${a1}" - ast="${r}" - # Continue loop - ;; - defmacro!) - EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - local func="${r}" - __new_obj_like "${func}" - ANON["${r}"]="${ANON["${func}"]}" - ANON["${r}_ismacro_"]="yes" - ENV_SET "${env}" "${a1}" "${r}" - return ;; - macroexpand) - MACROEXPAND "${a1}" "${env}" - return ;; - try__STAR__) EVAL "${a1}" "${env}" - [[ -z "${__ERROR}" ]] && return - _nth "${a2}" 0; local a20="${r}" - if [ "${ANON["${a20}"]}" == "catch__STAR__" ]; then - _nth "${a2}" 1; local a21="${r}" - _nth "${a2}" 2; local a22="${r}" - _list "${a21}"; local binds="${r}" - ENV "${env}" "${binds}" "${__ERROR}" - local try_env="${r}" - __ERROR= - EVAL "${a22}" "${try_env}" - fi # if no catch* clause, just propagate __ERROR - return ;; - do) _count "${ast}" - _slice "${ast}" 1 $(( ${r} - 2 )) - EVAL_AST "${r}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - _last "${ast}" - ast="${r}" - # Continue loop - ;; - if) EVAL "${a1}" "${env}" - [[ "${__ERROR}" ]] && return 1 - if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then - # eval false form - _nth "${ast}" 3; local a3="${r}" - if [[ "${a3}" ]]; then - ast="${a3}" - else - r="${__nil}" - return - fi - else - # eval true condition - ast="${a2}" - fi - # Continue loop - ;; - fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ - EVAL \"${a2}\" \"\${r}\"" \ - "${a2}" "${env}" "${a1}" - return ;; - *) EVAL_AST "${ast}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - local el="${r}" - _first "${el}"; local f="${ANON["${r}"]}" - _rest "${el}"; local args="${ANON["${r}"]}" - #echo "invoke: [${f}] ${args}" - if [[ "${f//@/ }" != "${f}" ]]; then - set -- ${f//@/ } - ast="${2}" - ENV "${3}" "${4}" ${args} - env="${r}" - else - eval ${f%%@*} ${args} - return - fi - # Continue loop - ;; - esac - done -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -ENV; REPL_ENV="${r}" -REP () { - r= - READ "${1}" - EVAL "${r}" "${REPL_ENV}" - PRINT "${r}" -} - -# core.sh: defined using bash -_fref () { - _symbol "${1}"; local sym="${r}" - _function "${2} \"\${@}\"" - ENV_SET "${REPL_ENV}" "${sym}" "${r}" -} -for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done -_eval () { EVAL "${1}" "${REPL_ENV}"; } -_fref "eval" _eval -_list; argv="${r}" -for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done -_symbol "__STAR__ARGV__STAR__" -ENV_SET "${REPL_ENV}" "${r}" "${argv}"; - -# core.mal: defined using the language itself -REP "(def! not (fn* (a) (if a false true)))" -REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -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)))))))" - -# load/run file from command line (then exit) -if [[ "${1}" ]]; then - REP "(load-file \"${1}\")" - exit 0 -fi - -# repl loop -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh +source $(dirname $0)/env.sh +source $(dirname $0)/core.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +starts_with () { + _list? "$1" && _first "$1" && _symbol? "$r" && [ "${ANON[$r]}" = "$2" ] +} + +QUASIQUOTE () { + _obj_type "$1" + case "$r" in + list) + if starts_with "$1" unquote; then + _nth "$1" 1 + else + qqIter "$1" + fi ;; + vector) + _symbol vec; local a="$r" + qqIter "$1" + _list "$a" "$r" ;; + symbol|hash_map) + _symbol quote + _list "$r" "$1" ;; + *) + r="$1" ;; + esac +} + +qqIter () { + if _empty? "$1"; then + _list + else + _nth "${1}" 0; local a0="$r" + if starts_with "$a0" splice-unquote; then + _symbol concat; local a="$r" + _nth "$a0" 1; local b="$r" + else + _symbol cons; local a="$r" + QUASIQUOTE "$a0"; local b="$r" + fi + _rest "$1" + qqIter "$r" + _list "$a" "$b" "$r" + fi +} + +IS_MACRO_CALL () { + if ! _list? "${1}"; then return 1; fi + _nth "${1}" 0; local a0="${r}" + if _symbol? "${a0}"; then + ENV_FIND "${2}" "${a0}" + if [[ "${r}" ]]; then + ENV_GET "${2}" "${a0}" + [ "${ANON["${r}_ismacro_"]}" ] + return $? + fi + fi + return 1 +} + +MACROEXPAND () { + local ast="${1}" env="${2}" + while IS_MACRO_CALL "${ast}" "${env}"; do + _nth "${ast}" 0; local a0="${r}" + ENV_GET "${env}" "${a0}"; local mac="${ANON["${r}"]}" + _rest "${ast}" + ${mac%%@*} ${ANON["${r}"]} + ast="${r}" + done + r="${ast}" +} + + +EVAL_AST () { + local ast="${1}" env="${2}" + #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + case "${ot}" in + symbol) + ENV_GET "${env}" "${ast}" + return ;; + list) + _map_with_type _list EVAL "${ast}" "${env}" ;; + vector) + _map_with_type _vector EVAL "${ast}" "${env}" ;; + hash_map) + local res="" key= val="" hm="${ANON["${ast}"]}" + _hash_map; local new_hm="${r}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + eval val="\${${hm}[\"${key}\"]}" + EVAL "${val}" "${env}" + _assoc! "${new_hm}" "${key}" "${r}" + done + r="${new_hm}" ;; + *) + r="${ast}" ;; + esac +} + +EVAL () { + local ast="${1}" env="${2}" + while true; do + r= + [[ "${__ERROR}" ]] && return 1 + #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" + if ! _list? "${ast}"; then + EVAL_AST "${ast}" "${env}" + return + fi + + # apply list + MACROEXPAND "${ast}" "${env}" + ast="${r}" + if ! _list? "${ast}"; then + EVAL_AST "${ast}" "${env}" + return + fi + _empty? "${ast}" && r="${ast}" && return + + _nth "${ast}" 0; local a0="${r}" + _nth "${ast}" 1; local a1="${r}" + _nth "${ast}" 2; local a2="${r}" + case "${ANON["${a0}"]}" in + def!) EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + ENV_SET "${env}" "${a1}" "${r}" + return ;; + let__STAR__) ENV "${env}"; local let_env="${r}" + local let_pairs=(${ANON["${a1}"]}) + local idx=0 + #echo "let: [${let_pairs[*]}] for ${a2}" + while [[ "${let_pairs["${idx}"]}" ]]; do + EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" + ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" + idx=$(( idx + 2)) + done + ast="${a2}" + env="${let_env}" + # Continue loop + ;; + quote) + r="${a1}" + return ;; + quasiquoteexpand) + QUASIQUOTE "${a1}" + return ;; + quasiquote) + QUASIQUOTE "${a1}" + ast="${r}" + # Continue loop + ;; + defmacro!) + EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + local func="${r}" + __new_obj_like "${func}" + ANON["${r}"]="${ANON["${func}"]}" + ANON["${r}_ismacro_"]="yes" + ENV_SET "${env}" "${a1}" "${r}" + return ;; + macroexpand) + MACROEXPAND "${a1}" "${env}" + return ;; + try__STAR__) EVAL "${a1}" "${env}" + [[ -z "${__ERROR}" ]] && return + _nth "${a2}" 0; local a20="${r}" + if [ "${ANON["${a20}"]}" == "catch__STAR__" ]; then + _nth "${a2}" 1; local a21="${r}" + _nth "${a2}" 2; local a22="${r}" + _list "${a21}"; local binds="${r}" + ENV "${env}" "${binds}" "${__ERROR}" + local try_env="${r}" + __ERROR= + EVAL "${a22}" "${try_env}" + fi # if no catch* clause, just propagate __ERROR + return ;; + do) _count "${ast}" + _slice "${ast}" 1 $(( ${r} - 2 )) + EVAL_AST "${r}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + _last "${ast}" + ast="${r}" + # Continue loop + ;; + if) EVAL "${a1}" "${env}" + [[ "${__ERROR}" ]] && return 1 + if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then + # eval false form + _nth "${ast}" 3; local a3="${r}" + if [[ "${a3}" ]]; then + ast="${a3}" + else + r="${__nil}" + return + fi + else + # eval true condition + ast="${a2}" + fi + # Continue loop + ;; + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + EVAL \"${a2}\" \"\${r}\"" \ + "${a2}" "${env}" "${a1}" + return ;; + *) EVAL_AST "${ast}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + local el="${r}" + _first "${el}"; local f="${ANON["${r}"]}" + _rest "${el}"; local args="${ANON["${r}"]}" + #echo "invoke: [${f}] ${args}" + if [[ "${f//@/ }" != "${f}" ]]; then + set -- ${f//@/ } + ast="${2}" + ENV "${3}" "${4}" ${args} + env="${r}" + else + eval ${f%%@*} ${args} + return + fi + # Continue loop + ;; + esac + done +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" yes + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +ENV; REPL_ENV="${r}" +REP () { + r= + READ "${1}" + EVAL "${r}" "${REPL_ENV}" + PRINT "${r}" +} + +# core.sh: defined using bash +_fref () { + _symbol "${1}"; local sym="${r}" + _function "${2} \"\${@}\"" + ENV_SET "${REPL_ENV}" "${sym}" "${r}" +} +for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done +_eval () { EVAL "${1}" "${REPL_ENV}"; } +_fref "eval" _eval +_list; argv="${r}" +for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done +_symbol "__STAR__ARGV__STAR__" +ENV_SET "${REPL_ENV}" "${r}" "${argv}"; + +# core.mal: defined using the language itself +REP "(def! not (fn* (a) (if a false true)))" +REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +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)))))))" + +# load/run file from command line (then exit) +if [[ "${1}" ]]; then + REP "(load-file \"${1}\")" + exit 0 +fi + +# repl loop +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/stepA_mal.sh b/impls/bash/stepA_mal.sh index df1543cfa5..1612923a89 100755 --- a/impls/bash/stepA_mal.sh +++ b/impls/bash/stepA_mal.sh @@ -1,300 +1,300 @@ -#!/usr/bin/env bash - -source $(dirname $0)/reader.sh -source $(dirname $0)/printer.sh -source $(dirname $0)/env.sh -source $(dirname $0)/core.sh - -# read -READ () { - [ "${1}" ] && r="${1}" || READLINE - READ_STR "${r}" -} - -# eval -starts_with () { - _list? "$1" && _first "$1" && _symbol? "$r" && [ "${ANON[$r]}" = "$2" ] -} - -QUASIQUOTE () { - _obj_type "$1" - case "$r" in - list) - if starts_with "$1" unquote; then - _nth "$1" 1 - else - qqIter "$1" - fi ;; - vector) - _symbol vec; local a="$r" - qqIter "$1" - _list "$a" "$r" ;; - symbol|hash_map) - _symbol quote - _list "$r" "$1" ;; - *) - r="$1" ;; - esac -} - -qqIter () { - if _empty? "$1"; then - _list - else - _nth "${1}" 0; local a0="$r" - if starts_with "$a0" splice-unquote; then - _symbol concat; local a="$r" - _nth "$a0" 1; local b="$r" - else - _symbol cons; local a="$r" - QUASIQUOTE "$a0"; local b="$r" - fi - _rest "$1" - qqIter "$r" - _list "$a" "$b" "$r" - fi -} - -IS_MACRO_CALL () { - if ! _list? "${1}"; then return 1; fi - _nth "${1}" 0; local a0="${r}" - if _symbol? "${a0}"; then - ENV_FIND "${2}" "${a0}" - if [[ "${r}" ]]; then - ENV_GET "${2}" "${a0}" - [ "${ANON["${r}_ismacro_"]}" ] - return $? - fi - fi - return 1 -} - -MACROEXPAND () { - local ast="${1}" env="${2}" - while IS_MACRO_CALL "${ast}" "${env}"; do - _nth "${ast}" 0; local a0="${r}" - ENV_GET "${env}" "${a0}"; local mac="${ANON["${r}"]}" - _rest "${ast}" - ${mac%%@*} ${ANON["${r}"]} - ast="${r}" - done - r="${ast}" -} - - -EVAL_AST () { - local ast="${1}" env="${2}" - #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" - _obj_type "${ast}"; local ot="${r}" - case "${ot}" in - symbol) - ENV_GET "${env}" "${ast}" - return ;; - list) - _map_with_type _list EVAL "${ast}" "${env}" ;; - vector) - _map_with_type _vector EVAL "${ast}" "${env}" ;; - hash_map) - local res="" key= val="" hm="${ANON["${ast}"]}" - _hash_map; local new_hm="${r}" - eval local keys="\${!${hm}[@]}" - for key in ${keys}; do - eval val="\${${hm}[\"${key}\"]}" - EVAL "${val}" "${env}" - _assoc! "${new_hm}" "${key}" "${r}" - done - r="${new_hm}" ;; - *) - r="${ast}" ;; - esac -} - -EVAL () { - local ast="${1}" env="${2}" - while true; do - r= - [[ "${__ERROR}" ]] && return 1 - #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" - if ! _list? "${ast}"; then - EVAL_AST "${ast}" "${env}" - return - fi - - # apply list - MACROEXPAND "${ast}" "${env}" - ast="${r}" - if ! _list? "${ast}"; then - EVAL_AST "${ast}" "${env}" - return - fi - _empty? "${ast}" && r="${ast}" && return - - _nth "${ast}" 0; local a0="${r}" - _nth "${ast}" 1; local a1="${r}" - _nth "${ast}" 2; local a2="${r}" - case "${ANON["${a0}"]}" in - def!) EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - ENV_SET "${env}" "${a1}" "${r}" - return ;; - let__STAR__) ENV "${env}"; local let_env="${r}" - local let_pairs=(${ANON["${a1}"]}) - local idx=0 - #echo "let: [${let_pairs[*]}] for ${a2}" - while [[ "${let_pairs["${idx}"]}" ]]; do - EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" - ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" - idx=$(( idx + 2)) - done - ast="${a2}" - env="${let_env}" - # Continue loop - ;; - quote) - r="${a1}" - return ;; - quasiquoteexpand) - QUASIQUOTE "${a1}" - return ;; - quasiquote) - QUASIQUOTE "${a1}" - ast="${r}" - # Continue loop - ;; - defmacro!) - EVAL "${a2}" "${env}" - [[ "${__ERROR}" ]] && return 1 - local func="${r}" - __new_obj_like "${func}" - ANON["${r}"]="${ANON["${func}"]}" - ANON["${r}_ismacro_"]="yes" - ENV_SET "${env}" "${a1}" "${r}" - return ;; - macroexpand) - MACROEXPAND "${a1}" "${env}" - return ;; - sh__STAR__) EVAL "${a1}" "${env}" - local output="" - local line="" - r="${ANON["${r}"]}" - r="${r//__STAR__/*}" - while read -r line || [ -n "${line}" ]; do - output="${output}${line}"$'\n' - done < <(eval "${r}") - _string "${output%$'\n'}" - return ;; - try__STAR__) EVAL "${a1}" "${env}" - [[ -z "${__ERROR}" ]] && return - _nth "${a2}" 0; local a20="${r}" - if [ "${ANON["${a20}"]}" == "catch__STAR__" ]; then - _nth "${a2}" 1; local a21="${r}" - _nth "${a2}" 2; local a22="${r}" - _list "${a21}"; local binds="${r}" - ENV "${env}" "${binds}" "${__ERROR}" - local try_env="${r}" - __ERROR= - EVAL "${a22}" "${try_env}" - fi # if no catch* clause, just propagate __ERROR - return ;; - do) _count "${ast}" - _slice "${ast}" 1 $(( ${r} - 2 )) - EVAL_AST "${r}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - _last "${ast}" - ast="${r}" - # Continue loop - ;; - if) EVAL "${a1}" "${env}" - [[ "${__ERROR}" ]] && return 1 - if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then - # eval false form - _nth "${ast}" 3; local a3="${r}" - if [[ "${a3}" ]]; then - ast="${a3}" - else - r="${__nil}" - return - fi - else - # eval true condition - ast="${a2}" - fi - # Continue loop - ;; - fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ - EVAL \"${a2}\" \"\${r}\"" \ - "${a2}" "${env}" "${a1}" - return ;; - *) EVAL_AST "${ast}" "${env}" - [[ "${__ERROR}" ]] && r= && return 1 - local el="${r}" - _first "${el}"; local f="${ANON["${r}"]}" - _rest "${el}"; local args="${ANON["${r}"]}" - #echo "invoke: [${f}] ${args}" - if [[ "${f//@/ }" != "${f}" ]]; then - set -- ${f//@/ } - ast="${2}" - ENV "${3}" "${4}" ${args} - env="${r}" - else - eval ${f%%@*} ${args} - return - fi - # Continue loop - ;; - esac - done -} - -# print -PRINT () { - if [[ "${__ERROR}" ]]; then - _pr_str "${__ERROR}" yes - r="Error: ${r}" - __ERROR= - else - _pr_str "${1}" yes - fi -} - -# repl -ENV; REPL_ENV="${r}" -REP () { - r= - READ "${1}" - EVAL "${r}" "${REPL_ENV}" - PRINT "${r}" -} - -# core.sh: defined using bash -_fref () { - _symbol "${1}"; local sym="${r}" - _function "${2} \"\${@}\"" - ENV_SET "${REPL_ENV}" "${sym}" "${r}" -} -for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done -_eval () { EVAL "${1}" "${REPL_ENV}"; } -_fref "eval" _eval -_list; argv="${r}" -for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done -_symbol "__STAR__ARGV__STAR__" -ENV_SET "${REPL_ENV}" "${r}" "${argv}"; - -# core.mal: defined using the language itself -REP "(def! *host-language* \"bash\")" -REP "(def! not (fn* (a) (if a false true)))" -REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -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)))))))" - -# load/run file from command line (then exit) -if [[ "${1}" ]]; then - REP "(load-file \"${1}\")" - exit 0 -fi - -# repl loop -REP "(println (str \"Mal [\" *host-language* \"]\"))" -while true; do - READLINE "user> " || exit "$?" - [[ "${r}" ]] && REP "${r}" && echo "${r}" -done +#!/usr/bin/env bash + +source $(dirname $0)/reader.sh +source $(dirname $0)/printer.sh +source $(dirname $0)/env.sh +source $(dirname $0)/core.sh + +# read +READ () { + [ "${1}" ] && r="${1}" || READLINE + READ_STR "${r}" +} + +# eval +starts_with () { + _list? "$1" && _first "$1" && _symbol? "$r" && [ "${ANON[$r]}" = "$2" ] +} + +QUASIQUOTE () { + _obj_type "$1" + case "$r" in + list) + if starts_with "$1" unquote; then + _nth "$1" 1 + else + qqIter "$1" + fi ;; + vector) + _symbol vec; local a="$r" + qqIter "$1" + _list "$a" "$r" ;; + symbol|hash_map) + _symbol quote + _list "$r" "$1" ;; + *) + r="$1" ;; + esac +} + +qqIter () { + if _empty? "$1"; then + _list + else + _nth "${1}" 0; local a0="$r" + if starts_with "$a0" splice-unquote; then + _symbol concat; local a="$r" + _nth "$a0" 1; local b="$r" + else + _symbol cons; local a="$r" + QUASIQUOTE "$a0"; local b="$r" + fi + _rest "$1" + qqIter "$r" + _list "$a" "$b" "$r" + fi +} + +IS_MACRO_CALL () { + if ! _list? "${1}"; then return 1; fi + _nth "${1}" 0; local a0="${r}" + if _symbol? "${a0}"; then + ENV_FIND "${2}" "${a0}" + if [[ "${r}" ]]; then + ENV_GET "${2}" "${a0}" + [ "${ANON["${r}_ismacro_"]}" ] + return $? + fi + fi + return 1 +} + +MACROEXPAND () { + local ast="${1}" env="${2}" + while IS_MACRO_CALL "${ast}" "${env}"; do + _nth "${ast}" 0; local a0="${r}" + ENV_GET "${env}" "${a0}"; local mac="${ANON["${r}"]}" + _rest "${ast}" + ${mac%%@*} ${ANON["${r}"]} + ast="${r}" + done + r="${ast}" +} + + +EVAL_AST () { + local ast="${1}" env="${2}" + #_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'" + _obj_type "${ast}"; local ot="${r}" + case "${ot}" in + symbol) + ENV_GET "${env}" "${ast}" + return ;; + list) + _map_with_type _list EVAL "${ast}" "${env}" ;; + vector) + _map_with_type _vector EVAL "${ast}" "${env}" ;; + hash_map) + local res="" key= val="" hm="${ANON["${ast}"]}" + _hash_map; local new_hm="${r}" + eval local keys="\${!${hm}[@]}" + for key in ${keys}; do + eval val="\${${hm}[\"${key}\"]}" + EVAL "${val}" "${env}" + _assoc! "${new_hm}" "${key}" "${r}" + done + r="${new_hm}" ;; + *) + r="${ast}" ;; + esac +} + +EVAL () { + local ast="${1}" env="${2}" + while true; do + r= + [[ "${__ERROR}" ]] && return 1 + #_pr_str "${ast}"; echo "EVAL '${r} / ${env}'" + if ! _list? "${ast}"; then + EVAL_AST "${ast}" "${env}" + return + fi + + # apply list + MACROEXPAND "${ast}" "${env}" + ast="${r}" + if ! _list? "${ast}"; then + EVAL_AST "${ast}" "${env}" + return + fi + _empty? "${ast}" && r="${ast}" && return + + _nth "${ast}" 0; local a0="${r}" + _nth "${ast}" 1; local a1="${r}" + _nth "${ast}" 2; local a2="${r}" + case "${ANON["${a0}"]}" in + def!) EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + ENV_SET "${env}" "${a1}" "${r}" + return ;; + let__STAR__) ENV "${env}"; local let_env="${r}" + local let_pairs=(${ANON["${a1}"]}) + local idx=0 + #echo "let: [${let_pairs[*]}] for ${a2}" + while [[ "${let_pairs["${idx}"]}" ]]; do + EVAL "${let_pairs[$(( idx + 1))]}" "${let_env}" + ENV_SET "${let_env}" "${let_pairs[${idx}]}" "${r}" + idx=$(( idx + 2)) + done + ast="${a2}" + env="${let_env}" + # Continue loop + ;; + quote) + r="${a1}" + return ;; + quasiquoteexpand) + QUASIQUOTE "${a1}" + return ;; + quasiquote) + QUASIQUOTE "${a1}" + ast="${r}" + # Continue loop + ;; + defmacro!) + EVAL "${a2}" "${env}" + [[ "${__ERROR}" ]] && return 1 + local func="${r}" + __new_obj_like "${func}" + ANON["${r}"]="${ANON["${func}"]}" + ANON["${r}_ismacro_"]="yes" + ENV_SET "${env}" "${a1}" "${r}" + return ;; + macroexpand) + MACROEXPAND "${a1}" "${env}" + return ;; + sh__STAR__) EVAL "${a1}" "${env}" + local output="" + local line="" + r="${ANON["${r}"]}" + r="${r//__STAR__/*}" + while read -r line || [ -n "${line}" ]; do + output="${output}${line}"$'\n' + done < <(eval "${r}") + _string "${output%$'\n'}" + return ;; + try__STAR__) EVAL "${a1}" "${env}" + [[ -z "${__ERROR}" ]] && return + _nth "${a2}" 0; local a20="${r}" + if [ "${ANON["${a20}"]}" == "catch__STAR__" ]; then + _nth "${a2}" 1; local a21="${r}" + _nth "${a2}" 2; local a22="${r}" + _list "${a21}"; local binds="${r}" + ENV "${env}" "${binds}" "${__ERROR}" + local try_env="${r}" + __ERROR= + EVAL "${a22}" "${try_env}" + fi # if no catch* clause, just propagate __ERROR + return ;; + do) _count "${ast}" + _slice "${ast}" 1 $(( ${r} - 2 )) + EVAL_AST "${r}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + _last "${ast}" + ast="${r}" + # Continue loop + ;; + if) EVAL "${a1}" "${env}" + [[ "${__ERROR}" ]] && return 1 + if [[ "${r}" == "${__false}" || "${r}" == "${__nil}" ]]; then + # eval false form + _nth "${ast}" 3; local a3="${r}" + if [[ "${a3}" ]]; then + ast="${a3}" + else + r="${__nil}" + return + fi + else + # eval true condition + ast="${a2}" + fi + # Continue loop + ;; + fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \ + EVAL \"${a2}\" \"\${r}\"" \ + "${a2}" "${env}" "${a1}" + return ;; + *) EVAL_AST "${ast}" "${env}" + [[ "${__ERROR}" ]] && r= && return 1 + local el="${r}" + _first "${el}"; local f="${ANON["${r}"]}" + _rest "${el}"; local args="${ANON["${r}"]}" + #echo "invoke: [${f}] ${args}" + if [[ "${f//@/ }" != "${f}" ]]; then + set -- ${f//@/ } + ast="${2}" + ENV "${3}" "${4}" ${args} + env="${r}" + else + eval ${f%%@*} ${args} + return + fi + # Continue loop + ;; + esac + done +} + +# print +PRINT () { + if [[ "${__ERROR}" ]]; then + _pr_str "${__ERROR}" yes + r="Error: ${r}" + __ERROR= + else + _pr_str "${1}" yes + fi +} + +# repl +ENV; REPL_ENV="${r}" +REP () { + r= + READ "${1}" + EVAL "${r}" "${REPL_ENV}" + PRINT "${r}" +} + +# core.sh: defined using bash +_fref () { + _symbol "${1}"; local sym="${r}" + _function "${2} \"\${@}\"" + ENV_SET "${REPL_ENV}" "${sym}" "${r}" +} +for n in "${!core_ns[@]}"; do _fref "${n}" "${core_ns["${n}"]}"; done +_eval () { EVAL "${1}" "${REPL_ENV}"; } +_fref "eval" _eval +_list; argv="${r}" +for _arg in "${@:2}"; do _string "${_arg}"; _conj! "${argv}" "${r}"; done +_symbol "__STAR__ARGV__STAR__" +ENV_SET "${REPL_ENV}" "${r}" "${argv}"; + +# core.mal: defined using the language itself +REP "(def! *host-language* \"bash\")" +REP "(def! not (fn* (a) (if a false true)))" +REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +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)))))))" + +# load/run file from command line (then exit) +if [[ "${1}" ]]; then + REP "(load-file \"${1}\")" + exit 0 +fi + +# repl loop +REP "(println (str \"Mal [\" *host-language* \"]\"))" +while true; do + READLINE "user> " || exit "$?" + [[ "${r}" ]] && REP "${r}" && echo "${r}" +done diff --git a/impls/bash/tests/stepA_mal.mal b/impls/bash/tests/stepA_mal.mal index f977055b71..35bdd77928 100644 --- a/impls/bash/tests/stepA_mal.mal +++ b/impls/bash/tests/stepA_mal.mal @@ -1,32 +1,32 @@ -;; Testing basic bash interop - -(sh* "echo 7") -;=>"7" - -(sh* "echo >&2 hello") -;/hello -;=>"" - -(sh* "foo=8; echo ${foo}") -;=>"8" - -(sh* "for x in a b c; do echo -n \"X${x}Y \"; done; echo") -;=>"XaY XbY XcY" - -(sh* "for x in 1 2 3; do echo -n \"$((1+$x)) \"; done; echo") -;=>"2 3 4" - -(sh* "for x in {1..10}; do echo $x; done") -;=>"1\n2\n3\n4\n5\n6\n7\n8\n9\n10" - -(sh* "echo -n {1..3}") -;=>"1 2 3" - -(sh* "echo hello; echo foo; echo yes;") -;=>"hello\nfoo\nyes" - -(sh* "grep -oE '\[.*!\]' core.sh") -;=>"[reset!]\n[swap!]" - -(sh* "ls cor*.sh") -;=>"core.sh" +;; Testing basic bash interop + +(sh* "echo 7") +;=>"7" + +(sh* "echo >&2 hello") +;/hello +;=>"" + +(sh* "foo=8; echo ${foo}") +;=>"8" + +(sh* "for x in a b c; do echo -n \"X${x}Y \"; done; echo") +;=>"XaY XbY XcY" + +(sh* "for x in 1 2 3; do echo -n \"$((1+$x)) \"; done; echo") +;=>"2 3 4" + +(sh* "for x in {1..10}; do echo $x; done") +;=>"1\n2\n3\n4\n5\n6\n7\n8\n9\n10" + +(sh* "echo -n {1..3}") +;=>"1 2 3" + +(sh* "echo hello; echo foo; echo yes;") +;=>"hello\nfoo\nyes" + +(sh* "grep -oE '\[.*!\]' core.sh") +;=>"[reset!]\n[swap!]" + +(sh* "ls cor*.sh") +;=>"core.sh" diff --git a/impls/bash/types.sh b/impls/bash/types.sh index 556cca0436..1b11b22442 100644 --- a/impls/bash/types.sh +++ b/impls/bash/types.sh @@ -1,372 +1,372 @@ -# -# mal (Make a Lisp) object types -# - -if [ -z "${__mal_types_included__}" ]; then -__mal_types_included=true - -declare -A ANON - -__obj_magic=__5bal7 -__keyw=$(echo -en "\xCA\x9E") # \u029E -__obj_hash_code=${__obj_hash_code:-0} - -__new_obj_hash_code () { - __obj_hash_code=$(( __obj_hash_code + 1)) - r="${__obj_hash_code}" -} - -__new_obj () { - __new_obj_hash_code - r="${1}_${r}" -} - -__new_obj_like () { - __new_obj_hash_code - r="${1%_*}_${r}" -} - - -# Errors/Exceptions - -__ERROR= -_error() { - _string "${1}" - __ERROR="${r}" - r= -} - - - -# -# General functions -# - -# Return the type of the object (or "make" if it's not a object -_obj_type () { - local type="${1:0:4}" - r= - case "${type}" in - symb) r="symbol" ;; - list) r="list" ;; - numb) r="number" ;; - func) r="function" ;; - strn) - local s="${ANON["${1}"]}" - if [[ "${1:0:1}" = "${__keyw}" ]] \ - || [[ "${1:0:2}" = "${__keyw}" ]]; then - r="keyword" - else - r="string" - fi ;; - _nil) r="nil" ;; - true) r="true" ;; - fals) r="false" ;; - vect) r="vector" ;; - hmap) r="hash_map" ;; - atom) r="atom" ;; - undf) r="undefined" ;; - *) r="bash" ;; - esac -} - -_equal? () { - _obj_type "${1}"; local ot1="${r}" - _obj_type "${2}"; local ot2="${r}" - if [[ "${ot1}" != "${ot2}" ]]; then - if ! _sequential? "${1}" || ! _sequential? "${2}"; then - return 1 - fi - fi - case "${ot1}" in - string|symbol|keyword|number) - [[ "${ANON["${1}"]}" == "${ANON["${2}"]}" ]] ;; - list|vector) - _count "${1}"; local sz1="${r}" - _count "${2}"; local sz2="${r}" - [[ "${sz1}" == "${sz2}" ]] || return 1 - local a1=(${ANON["${1}"]}) - local a2=(${ANON["${2}"]}) - for ((i=0;i<${#a1[*]};i++)); do - _equal? "${a1[${i}]}" "${a2[${i}]}" || return 1 - done - ;; - hash_map) - local hm1="${ANON["${1}"]}" - eval local ks1="\${!${hm1}[@]}" - local hm2="${ANON["${2}"]}" - eval local ks2="\${!${hm2}[@]}" - [[ "${#ks1}" == "${#ks2}" ]] || return 1 - for k in ${ks1}; do - eval v1="\${${hm1}[\"${k}\"]}" - eval v2="\${${hm2}[\"${k}\"]}" - [ "${v1}" ] || return 1 - [ "${v2}" ] || return 1 - _equal? "${v1}" "${v2}" || return 1 - done - ;; - *) - [[ "${1}" == "${2}" ]] ;; - esac -} - -# Constant atomic values - -__nil=_nil_0 -__true=true_0 -__false=fals_0 - -_nil? () { [[ ${1} =~ ^_nil_ ]]; } -_true? () { [[ ${1} =~ ^true_ ]]; } -_false? () { [[ ${1} =~ ^fals_ ]]; } - - -# Symbols - -_symbol () { - __new_obj_hash_code - r="symb_${r}" - ANON["${r}"]="${1//\*/__STAR__}" -} -_symbol? () { [[ ${1} =~ ^symb_ ]]; } - - -# Keywords - -_keyword () { - local k="${1}" - __new_obj_hash_code - r="strn_${r}" - if [[ "${1:0:1}" = "${__keyw}" ]] \ - || [[ "${1:0:2}" = "${__keyw}" ]]; then - true - else - k="${__keyw}${1}" - fi - ANON["${r}"]="${k//\*/__STAR__}" -} -_keyword? () { - [[ ${1} =~ ^strn_ ]] || return 1 - local s="${ANON["${1}"]}" - [[ "${s:0:1}" = "${__keyw}" ]] || [[ "${s:0:2}" = "${__keyw}" ]] -} - - -# Numbers - -_number () { - __new_obj_hash_code - r="numb_${r}" - ANON["${r}"]="${1}" -} -_number? () { [[ ${1} =~ ^numb_ ]]; } - - -# Strings - -_string () { - __new_obj_hash_code - r="strn_${r}" - ANON["${r}"]="${1//\*/__STAR__}" -} -_string? () { [[ ${1} =~ ^strn_ ]]; } - - -# Functions -# Return a function object. The first parameter is the -# function 'source'. -_function () { - __new_obj_hash_code - eval "function ${__obj_magic}_func_${r} () { ${1%;} ; }" - r="func_${r}" - if [[ "${2}" ]]; then - # Native function - ANON["${r}"]="${__obj_magic}_${r}@${2}@${3}@${4}" - else - # Bash function - ANON["${r}"]="${__obj_magic}_${r}" - fi -} -_function? () { [[ ${1} =~ ^func_ ]]; } - - -# Lists - -_list () { - __new_obj_hash_code - r="list_${r}" - ANON["${r}"]="${*}" -} -_list? () { [[ ${1} =~ ^list_ ]]; } - - -# Vectors - -_vector () { - __new_obj_hash_code - r="vector_${r}" - ANON["${r}"]="${*}" -} -_vector? () { [[ ${1} =~ ^vector_ ]]; } - -vec () { - __new_obj_hash_code - r="vector_$r" - ANON["$r"]=${ANON["$1"]} -} - - -# hash maps (associative arrays) - -_hash_map () { - __new_obj_hash_code - local name="hmap_${r}" - local obj="${__obj_magic}_${name}" - declare -A -g ${obj}; eval "${obj}=()" - ANON["${name}"]="${obj}" - - while [[ "${1}" ]]; do - eval ${obj}[\"${ANON["${1}"]}\"]=\"${2}\" - shift; shift - done - - r="${name}" -} -_hash_map? () { [[ ${1} =~ ^hmap_ ]]; } - -_contains? () { - local obj="${ANON["${1}"]}" - eval [[ "\${${obj}[\"${2}\"]+isset}" ]] -} - -_copy_hash_map () { - local orig_obj="${ANON["${1}"]}" - _hash_map - local name="${r}" - local obj="${ANON["${name}"]}" - - # Copy the existing key/values to the new object - local temp=$(typeset -p ${orig_obj}) - eval ${temp/#declare -A ${orig_obj}=/declare -A -g ${obj}=} - r="${name}" -} - -# Return same hash map with keys/values added/mutated in place -_assoc! () { - local obj=${ANON["${1}"]}; shift - declare -A -g ${obj} - - # Set the key/values specified - while [[ "${1}" ]]; do - eval ${obj}[\"${1}\"]=\"${2}\" - shift; shift - done -} - -# Return same hash map with keys/values deleted/mutated in place -_dissoc! () { - local obj=${ANON["${1}"]}; shift - declare -A -g ${obj} - - # Delete the key/values specified - while [[ "${1}" ]]; do - eval unset ${obj}[\"${1}\"] - shift - done -} - - -# Atoms - -_atom() { - __new_obj_hash_code - r="atom_${r}" - ANON["${r}"]="${*}" -} -_atom? () { [[ ${1} =~ ^atom_ ]]; } - - -# sequence operations - -_sequential? () { - _list? "${1}" || _vector? "${1}" -} - -_nth () { - local temp=(${ANON["${1}"]}) - r="${temp[${2}]}" -} - -_first () { - local temp="${ANON["${1}"]}" - r="${temp%% *}" - [ "${r}" ] || r="${__nil}" -} - -_last () { - local temp="${ANON["${1}"]}" - r="${temp##* }" -} - -# Creates a new vector/list of the everything after but the first -# element -_rest () { - local temp="${ANON["${1}"]}" - _list - if [[ "${temp#* }" == "${temp}" ]]; then - ANON["${r}"]= - else - ANON["${r}"]="${temp#* }" - fi -} - - -_empty? () { [[ -z "${ANON["${1}"]}" ]]; } - -# conj that mutates in place (and always appends) -_conj! () { - local obj="${1}"; shift - local obj_data="${ANON["${obj}"]}" - ANON["${obj}"]="${obj_data:+${obj_data} }${*}" - r="${1}" -} - - - -_count () { - if _nil? "${1}"; then - r="0" - else - local temp=(${ANON["${1}"]}) - r=${#temp[*]} - fi -} - -# Slice a sequence object $1 starting at $2 of length $3 -_slice () { - local temp=(${ANON["${1}"]}) - __new_obj_like "${1}" - ANON["${r}"]="${temp[@]:${2}:${3}}" -} - -# Takes a bash function and an list object and invokes the function on -# each element of the list, returning a new list (or vector) of the results. -_map_with_type () { - local constructor="${1}"; shift - local f="${1}"; shift - local items="${ANON["${1}"]}"; shift - eval "${constructor}"; local new_seq="${r}" - for v in ${items}; do - #echo eval ${f%%@*} "${v}" "${@}" - eval ${f%%@*} "${v}" "${@}" - [[ "${__ERROR}" ]] && r= && return 1 - _conj! "${new_seq}" "${r}" - done - r="${new_seq}" -} - -_map () { - _map_with_type _list "${@}" -} - -fi +# +# mal (Make a Lisp) object types +# + +if [ -z "${__mal_types_included__}" ]; then +__mal_types_included=true + +declare -A ANON + +__obj_magic=__5bal7 +__keyw=$(echo -en "\xCA\x9E") # \u029E +__obj_hash_code=${__obj_hash_code:-0} + +__new_obj_hash_code () { + __obj_hash_code=$(( __obj_hash_code + 1)) + r="${__obj_hash_code}" +} + +__new_obj () { + __new_obj_hash_code + r="${1}_${r}" +} + +__new_obj_like () { + __new_obj_hash_code + r="${1%_*}_${r}" +} + + +# Errors/Exceptions + +__ERROR= +_error() { + _string "${1}" + __ERROR="${r}" + r= +} + + + +# +# General functions +# + +# Return the type of the object (or "make" if it's not a object +_obj_type () { + local type="${1:0:4}" + r= + case "${type}" in + symb) r="symbol" ;; + list) r="list" ;; + numb) r="number" ;; + func) r="function" ;; + strn) + local s="${ANON["${1}"]}" + if [[ "${1:0:1}" = "${__keyw}" ]] \ + || [[ "${1:0:2}" = "${__keyw}" ]]; then + r="keyword" + else + r="string" + fi ;; + _nil) r="nil" ;; + true) r="true" ;; + fals) r="false" ;; + vect) r="vector" ;; + hmap) r="hash_map" ;; + atom) r="atom" ;; + undf) r="undefined" ;; + *) r="bash" ;; + esac +} + +_equal? () { + _obj_type "${1}"; local ot1="${r}" + _obj_type "${2}"; local ot2="${r}" + if [[ "${ot1}" != "${ot2}" ]]; then + if ! _sequential? "${1}" || ! _sequential? "${2}"; then + return 1 + fi + fi + case "${ot1}" in + string|symbol|keyword|number) + [[ "${ANON["${1}"]}" == "${ANON["${2}"]}" ]] ;; + list|vector) + _count "${1}"; local sz1="${r}" + _count "${2}"; local sz2="${r}" + [[ "${sz1}" == "${sz2}" ]] || return 1 + local a1=(${ANON["${1}"]}) + local a2=(${ANON["${2}"]}) + for ((i=0;i<${#a1[*]};i++)); do + _equal? "${a1[${i}]}" "${a2[${i}]}" || return 1 + done + ;; + hash_map) + local hm1="${ANON["${1}"]}" + eval local ks1="\${!${hm1}[@]}" + local hm2="${ANON["${2}"]}" + eval local ks2="\${!${hm2}[@]}" + [[ "${#ks1}" == "${#ks2}" ]] || return 1 + for k in ${ks1}; do + eval v1="\${${hm1}[\"${k}\"]}" + eval v2="\${${hm2}[\"${k}\"]}" + [ "${v1}" ] || return 1 + [ "${v2}" ] || return 1 + _equal? "${v1}" "${v2}" || return 1 + done + ;; + *) + [[ "${1}" == "${2}" ]] ;; + esac +} + +# Constant atomic values + +__nil=_nil_0 +__true=true_0 +__false=fals_0 + +_nil? () { [[ ${1} =~ ^_nil_ ]]; } +_true? () { [[ ${1} =~ ^true_ ]]; } +_false? () { [[ ${1} =~ ^fals_ ]]; } + + +# Symbols + +_symbol () { + __new_obj_hash_code + r="symb_${r}" + ANON["${r}"]="${1//\*/__STAR__}" +} +_symbol? () { [[ ${1} =~ ^symb_ ]]; } + + +# Keywords + +_keyword () { + local k="${1}" + __new_obj_hash_code + r="strn_${r}" + if [[ "${1:0:1}" = "${__keyw}" ]] \ + || [[ "${1:0:2}" = "${__keyw}" ]]; then + true + else + k="${__keyw}${1}" + fi + ANON["${r}"]="${k//\*/__STAR__}" +} +_keyword? () { + [[ ${1} =~ ^strn_ ]] || return 1 + local s="${ANON["${1}"]}" + [[ "${s:0:1}" = "${__keyw}" ]] || [[ "${s:0:2}" = "${__keyw}" ]] +} + + +# Numbers + +_number () { + __new_obj_hash_code + r="numb_${r}" + ANON["${r}"]="${1}" +} +_number? () { [[ ${1} =~ ^numb_ ]]; } + + +# Strings + +_string () { + __new_obj_hash_code + r="strn_${r}" + ANON["${r}"]="${1//\*/__STAR__}" +} +_string? () { [[ ${1} =~ ^strn_ ]]; } + + +# Functions +# Return a function object. The first parameter is the +# function 'source'. +_function () { + __new_obj_hash_code + eval "function ${__obj_magic}_func_${r} () { ${1%;} ; }" + r="func_${r}" + if [[ "${2}" ]]; then + # Native function + ANON["${r}"]="${__obj_magic}_${r}@${2}@${3}@${4}" + else + # Bash function + ANON["${r}"]="${__obj_magic}_${r}" + fi +} +_function? () { [[ ${1} =~ ^func_ ]]; } + + +# Lists + +_list () { + __new_obj_hash_code + r="list_${r}" + ANON["${r}"]="${*}" +} +_list? () { [[ ${1} =~ ^list_ ]]; } + + +# Vectors + +_vector () { + __new_obj_hash_code + r="vector_${r}" + ANON["${r}"]="${*}" +} +_vector? () { [[ ${1} =~ ^vector_ ]]; } + +vec () { + __new_obj_hash_code + r="vector_$r" + ANON["$r"]=${ANON["$1"]} +} + + +# hash maps (associative arrays) + +_hash_map () { + __new_obj_hash_code + local name="hmap_${r}" + local obj="${__obj_magic}_${name}" + declare -A -g ${obj}; eval "${obj}=()" + ANON["${name}"]="${obj}" + + while [[ "${1}" ]]; do + eval ${obj}[\"${ANON["${1}"]}\"]=\"${2}\" + shift; shift + done + + r="${name}" +} +_hash_map? () { [[ ${1} =~ ^hmap_ ]]; } + +_contains? () { + local obj="${ANON["${1}"]}" + eval [[ "\${${obj}[\"${2}\"]+isset}" ]] +} + +_copy_hash_map () { + local orig_obj="${ANON["${1}"]}" + _hash_map + local name="${r}" + local obj="${ANON["${name}"]}" + + # Copy the existing key/values to the new object + local temp=$(typeset -p ${orig_obj}) + eval ${temp/#declare -A ${orig_obj}=/declare -A -g ${obj}=} + r="${name}" +} + +# Return same hash map with keys/values added/mutated in place +_assoc! () { + local obj=${ANON["${1}"]}; shift + declare -A -g ${obj} + + # Set the key/values specified + while [[ "${1}" ]]; do + eval ${obj}[\"${1}\"]=\"${2}\" + shift; shift + done +} + +# Return same hash map with keys/values deleted/mutated in place +_dissoc! () { + local obj=${ANON["${1}"]}; shift + declare -A -g ${obj} + + # Delete the key/values specified + while [[ "${1}" ]]; do + eval unset ${obj}[\"${1}\"] + shift + done +} + + +# Atoms + +_atom() { + __new_obj_hash_code + r="atom_${r}" + ANON["${r}"]="${*}" +} +_atom? () { [[ ${1} =~ ^atom_ ]]; } + + +# sequence operations + +_sequential? () { + _list? "${1}" || _vector? "${1}" +} + +_nth () { + local temp=(${ANON["${1}"]}) + r="${temp[${2}]}" +} + +_first () { + local temp="${ANON["${1}"]}" + r="${temp%% *}" + [ "${r}" ] || r="${__nil}" +} + +_last () { + local temp="${ANON["${1}"]}" + r="${temp##* }" +} + +# Creates a new vector/list of the everything after but the first +# element +_rest () { + local temp="${ANON["${1}"]}" + _list + if [[ "${temp#* }" == "${temp}" ]]; then + ANON["${r}"]= + else + ANON["${r}"]="${temp#* }" + fi +} + + +_empty? () { [[ -z "${ANON["${1}"]}" ]]; } + +# conj that mutates in place (and always appends) +_conj! () { + local obj="${1}"; shift + local obj_data="${ANON["${obj}"]}" + ANON["${obj}"]="${obj_data:+${obj_data} }${*}" + r="${1}" +} + + + +_count () { + if _nil? "${1}"; then + r="0" + else + local temp=(${ANON["${1}"]}) + r=${#temp[*]} + fi +} + +# Slice a sequence object $1 starting at $2 of length $3 +_slice () { + local temp=(${ANON["${1}"]}) + __new_obj_like "${1}" + ANON["${r}"]="${temp[@]:${2}:${3}}" +} + +# Takes a bash function and an list object and invokes the function on +# each element of the list, returning a new list (or vector) of the results. +_map_with_type () { + local constructor="${1}"; shift + local f="${1}"; shift + local items="${ANON["${1}"]}"; shift + eval "${constructor}"; local new_seq="${r}" + for v in ${items}; do + #echo eval ${f%%@*} "${v}" "${@}" + eval ${f%%@*} "${v}" "${@}" + [[ "${__ERROR}" ]] && r= && return 1 + _conj! "${new_seq}" "${r}" + done + r="${new_seq}" +} + +_map () { + _map_with_type _list "${@}" +} + +fi diff --git a/impls/basic/.args.mal b/impls/basic/.args.mal index db54c0e912..36dad77071 100644 --- a/impls/basic/.args.mal +++ b/impls/basic/.args.mal @@ -1 +1 @@ -(def! -*ARGS*- (list )) +(def! -*ARGS*- (list )) diff --git a/impls/basic/Dockerfile b/impls/basic/Dockerfile index 928b1b1c62..c859368e9f 100644 --- a/impls/basic/Dockerfile +++ b/impls/basic/Dockerfile @@ -1,46 +1,46 @@ -FROM ubuntu:wily -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# cbmbasic -RUN apt-get install -y gcc unzip patch -RUN cd /tmp && \ - curl -L https://github.com/kanaka/cbmbasic/archive/master.zip -o cbmbasic.zip && \ - unzip cbmbasic.zip && \ - cd cbmbasic-master && \ - make && \ - cp cbmbasic /usr/bin/cbmbasic && \ - cd .. && \ - rm -r cbmbasic* - -RUN apt-get install -y g++ mesa-common-dev libglu1-mesa-dev libasound2-dev wget -RUN cd /tmp && \ - curl -L http://www.qb64.net/release/official/2017_02_09__02_14_38-1.1-20170120.51/linux/qb64-1.1-20170120.51-lnx.tar.gz | tar xzf - && \ - cd qb64 && \ - find . -name '*.sh' -exec sed -i "s/\r//g" {} \; && \ - env EUID=1 ./setup_lnx.sh && \ - mkdir -p /usr/share/qb64 && \ - cp -a qb64 internal LICENSE programs source /usr/share/qb64/ && \ - echo '#!/bin/sh\ncd /usr/share/qb64\n./qb64 "${@}"' > /usr/bin/qb64 && \ - chmod +x /usr/bin/qb64 - - +FROM ubuntu:wily +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# cbmbasic +RUN apt-get install -y gcc unzip patch +RUN cd /tmp && \ + curl -L https://github.com/kanaka/cbmbasic/archive/master.zip -o cbmbasic.zip && \ + unzip cbmbasic.zip && \ + cd cbmbasic-master && \ + make && \ + cp cbmbasic /usr/bin/cbmbasic && \ + cd .. && \ + rm -r cbmbasic* + +RUN apt-get install -y g++ mesa-common-dev libglu1-mesa-dev libasound2-dev wget +RUN cd /tmp && \ + curl -L http://www.qb64.net/release/official/2017_02_09__02_14_38-1.1-20170120.51/linux/qb64-1.1-20170120.51-lnx.tar.gz | tar xzf - && \ + cd qb64 && \ + find . -name '*.sh' -exec sed -i "s/\r//g" {} \; && \ + env EUID=1 ./setup_lnx.sh && \ + mkdir -p /usr/share/qb64 && \ + cp -a qb64 internal LICENSE programs source /usr/share/qb64/ && \ + echo '#!/bin/sh\ncd /usr/share/qb64\n./qb64 "${@}"' > /usr/bin/qb64 && \ + chmod +x /usr/bin/qb64 + + diff --git a/impls/basic/Makefile b/impls/basic/Makefile index df8eba0b28..77dd6029f7 100644 --- a/impls/basic/Makefile +++ b/impls/basic/Makefile @@ -1,62 +1,62 @@ -basic_MODE = cbm -BASICPP_OPTS = --mode $(basic_MODE) - -QB64 = qb64 - -STEPS4_A = step4_if_fn_do.bas step5_tco.bas step6_file.bas \ - step7_quote.bas step8_macros.bas step9_try.bas stepA_mal.bas -STEPS3_A = step3_env.bas $(STEPS4_A) -STEPS1_A = step1_read_print.bas step2_eval.bas $(STEPS3_A) -STEPS0_A = step0_repl.bas $(STEPS1_A) - -all: $(if $(filter qbasic,$(basic_MODE)),$(subst .bas,,$(STEPS0_A)),$(STEPS0_A)) - -$(STEPS0_A): readline.in.bas readline_line.in.bas readline_char.in.bas -$(STEPS1_A): debug.in.bas mem.in.bas types.in.bas reader.in.bas printer.in.bas -$(STEPS3_A): env.in.bas -$(STEPS4_A): core.in.bas - - - -step%.bas: step%.in.bas - ./basicpp.py $(BASICPP_OPTS) $< > $@ - -tests/%.bas: tests/%.in.bas - ./basicpp.py $(BASICPP_OPTS) $< > $@ - -# QBasic specific compilation rule -step%: step%.bas - $(QB64) -x $(abspath $<) -o $(abspath $@) - -# CBM/C64 image rules - -%.prg: %.bas - cat $< | tr "A-Z" "a-z" > $<.tmp - #cat $< | sed 's/["]\@["]\@!/\L&/g' > $<.tmp - petcat -w2 -nc -o $@ $<.tmp - #rm $<.tmp - -mal.prg: stepA_mal.prg - cp $< $@ - -.args.mal.prg: .args.mal - petcat -text -w2 -o $@ $< - -core.mal.prg: ../core.mal - petcat -text -w2 -o $@ $< - -mal.d64: mal.prg .args.mal.prg core.mal.prg - c1541 -format "mal,01" d64 $@ \ - -attach $@ \ - -write $< mal \ - -write .args.mal.prg .args.mal \ - -write core.mal.prg core.mal - - -# Clean and Stats rules - -.PHONY: clean - -clean: - rm -f $(STEPS0_A) $(subst .bas,,$(STEPS0_A)) *.d64 *.prg qb64 - rm -rf ./internal +basic_MODE = cbm +BASICPP_OPTS = --mode $(basic_MODE) + +QB64 = qb64 + +STEPS4_A = step4_if_fn_do.bas step5_tco.bas step6_file.bas \ + step7_quote.bas step8_macros.bas step9_try.bas stepA_mal.bas +STEPS3_A = step3_env.bas $(STEPS4_A) +STEPS1_A = step1_read_print.bas step2_eval.bas $(STEPS3_A) +STEPS0_A = step0_repl.bas $(STEPS1_A) + +all: $(if $(filter qbasic,$(basic_MODE)),$(subst .bas,,$(STEPS0_A)),$(STEPS0_A)) + +$(STEPS0_A): readline.in.bas readline_line.in.bas readline_char.in.bas +$(STEPS1_A): debug.in.bas mem.in.bas types.in.bas reader.in.bas printer.in.bas +$(STEPS3_A): env.in.bas +$(STEPS4_A): core.in.bas + + + +step%.bas: step%.in.bas + ./basicpp.py $(BASICPP_OPTS) $< > $@ + +tests/%.bas: tests/%.in.bas + ./basicpp.py $(BASICPP_OPTS) $< > $@ + +# QBasic specific compilation rule +step%: step%.bas + $(QB64) -x $(abspath $<) -o $(abspath $@) + +# CBM/C64 image rules + +%.prg: %.bas + cat $< | tr "A-Z" "a-z" > $<.tmp + #cat $< | sed 's/["]\@["]\@!/\L&/g' > $<.tmp + petcat -w2 -nc -o $@ $<.tmp + #rm $<.tmp + +mal.prg: stepA_mal.prg + cp $< $@ + +.args.mal.prg: .args.mal + petcat -text -w2 -o $@ $< + +core.mal.prg: ../core.mal + petcat -text -w2 -o $@ $< + +mal.d64: mal.prg .args.mal.prg core.mal.prg + c1541 -format "mal,01" d64 $@ \ + -attach $@ \ + -write $< mal \ + -write .args.mal.prg .args.mal \ + -write core.mal.prg core.mal + + +# Clean and Stats rules + +.PHONY: clean + +clean: + rm -f $(STEPS0_A) $(subst .bas,,$(STEPS0_A)) *.d64 *.prg qb64 + rm -rf ./internal diff --git a/impls/basic/basicpp.py b/impls/basic/basicpp.py index cb2f6223f8..41240833ec 100755 --- a/impls/basic/basicpp.py +++ b/impls/basic/basicpp.py @@ -1,347 +1,347 @@ -#!/usr/bin/env python - -from __future__ import print_function -import argparse -import re -import sys - -def debug(*args, **kwargs): - print(*args, file=sys.stderr, **kwargs) - -def parse_args(): - parser = argparse.ArgumentParser(description='Preprocess Basic code.') - parser.add_argument('infiles', type=str, nargs='+', - help='the Basic files to preprocess') - parser.add_argument('--mode', choices=["cbm", "qbasic"], default="cbm") - parser.add_argument('--sub-mode', choices=["noui", "ui"], default="noui") - parser.add_argument('--keep-rems', action='store_true', default=False, - help='The type of REMs to keep (0 (none) -> 4 (all)') - parser.add_argument('--keep-blank-lines', action='store_true', default=False, - help='Keep blank lines from the original file') - parser.add_argument('--keep-indent', action='store_true', default=False, - help='Keep line identing') - parser.add_argument('--skip-misc-fixups', action='store_true', default=False, - help='Skip miscellaneous fixup/shrink fixups') - parser.add_argument('--skip-combine-lines', action='store_true', default=False, - help='Do not combine lines using the ":" separator') - - args = parser.parse_args() - args.full_mode = "%s-%s" % (args.mode, args.sub_mode) - if args.keep_rems and not args.skip_combine_lines: - debug("Option --keep-rems implies --skip-combine-lines ") - args.skip_combine_lines = True - - if args.mode == 'qbasic' and not args.skip_misc_fixups: - debug("Mode 'qbasic' implies --skip-misc-fixups") - args.skip_misc_fixups = True - - return args - -# pull in include files -def resolve_includes(orig_lines, args): - included = {} - lines = orig_lines[:] - position = 0 - while position < len(lines): - line = lines[position] - m = re.match(r"^(?:#([^ ]*) )? *REM \$INCLUDE: '([^'\n]*)' *$", line) - if m: - mode = m.group(1) - f = m.group(2) - if mode and mode != args.mode and mode != args.full_mode: - position += 1 - elif f not in included: - ilines = [l.rstrip() for l in open(f).readlines()] - if args.keep_rems: lines.append("REM vvv BEGIN '%s' vvv" % f) - lines[position:position+1] = ilines - if args.keep_rems: lines.append("REM ^^^ END '%s' ^^^" % f) - else: - debug("Ignoring already included file: %s" % f) - else: - position += 1 - return lines - -def resolve_mode(orig_lines, args): - lines = [] - for line in orig_lines: - m = re.match(r"^ *#([^ \n]*) *([^\n]*)$", line) - if m: - if m.group(1) == args.mode: - lines.append(m.group(2)) - elif m.group(1) == args.full_mode: - lines.append(m.group(2)) - continue - lines.append(line) - return lines - -def drop_blank_lines(orig_lines): - lines = [] - for line in orig_lines: - if re.match(r"^\W*$", line): continue - lines.append(line) - return lines - - -def drop_rems(orig_lines): - lines = [] - for line in orig_lines: - if re.match(r"^ *REM", line): - continue - m = re.match(r"^(.*): *REM .*$", line) - if m: - lines.append(m.group(1)) - else: - lines.append(line) - return lines - -def remove_indent(orig_lines): - lines = [] - for line in orig_lines: - m = re.match(r"^ *([^ \n].*)$", line) - lines.append(m.group(1)) - return lines - -def misc_fixups(orig_lines): - text = "\n".join(orig_lines) - - # Remove GOTO after THEN - text = re.sub(r"\bTHEN GOTO\b", "THEN", text) - - # Remove spaces after keywords - text = re.sub(r"\bIF ", "IF", text) - text = re.sub(r"\bPRINT *", "PRINT", text) - text = re.sub(r"\bDIM ", "DIM", text) - text = re.sub(r"\OPEN ", "OPEN", text) - text = re.sub(r"\bGET ", "GET", text) - text = re.sub(r"\bPOKE ", "POKE", text) - text = re.sub(r"\bCLOSE ", "CLOSE", text) - text = re.sub(r"\bFOR ", "FOR", text) - text = re.sub(r" TO ", "TO", text) - text = re.sub(r"\bNEXT ", "NEXT", text) - - # Remove spaces around GOTO/GOSUB/THEN - text = re.sub(r" *GOTO *", "GOTO", text) - text = re.sub(r" *GOSUB *", "GOSUB", text) - text = re.sub(r" *THEN *", r"THEN", text) - - # Remove spaces around AND/OR except after ST - text = re.sub(r"(?OR", text) - - return text.split("\n") - -def finalize(lines, args): - labels_lines = {} - lines_labels = {} - call_index = {} - - cur_sub = None - - # number lines, remove labels (but track line number), and replace - # CALLs with a stack based GOTO - src_lines = lines - lines = [] - lnum=1 - for line in src_lines: - - # Drop labels (track line number for GOTO/GOSUB) - m = re.match(r"^ *([^ :\n]*): *$", line) - if m: - label = m.groups(1)[0] - labels_lines[label] = lnum - lines_labels[lnum] = label - continue - - if re.match(r".*CALL *([^ :\n]*) *:", line): - raise Exception("CALL is not the last thing on line %s" % lnum) - - # Replace CALLs (track line number for replacement later) - #m = re.match(r"\bCALL *([^ :]*) *$", line) - m = re.match(r"(.*)CALL *([^ :\n]*) *$", line) - if m: - prefix = m.groups(1)[0] - sub = m.groups(1)[1] - if not call_index.has_key(sub): - call_index[sub] = 0 - call_index[sub] += 1 - label = sub+"_"+str(call_index[sub]) - - # Replace the CALL with stack based GOTO - if args.mode == "cbm": - lines.append("%s %sQ=%s:GOSUBPUSH_Q:GOTO%s" % ( - lnum, prefix, call_index[sub], sub)) - else: - lines.append("%s %sX=X+1:X%%(X)=%s:GOTO %s" % ( - lnum, prefix, call_index[sub], sub)) - lnum += 1 - - # Add the return spot - labels_lines[label] = lnum - lines_labels[lnum] = label - continue - - lines.append("%s %s" % (lnum, line)) - lnum += 1 - - # remove SUB (but track lines), and replace END SUB with ON GOTO - # that returns to original caller - src_lines = lines - lines = [] - lnum=1 - for line in src_lines: - # Drop subroutine defs (track line number for CALLS) - m = re.match(r"^([0-9][0-9]*) *SUB *([^ \n]*) *$", line) - if m: - lnum = int(m.groups(1)[0])+1 - label = m.groups(1)[1] - cur_sub = label - labels_lines[label] = lnum - lines_labels[lnum] = label - continue - - # Drop END SUB (track line number for replacement later) - m = re.match(r"^([0-9][0-9]*) *END SUB *$", line) - if m: - if cur_sub == None: - raise Exception("END SUB found without preceeding SUB") - lnum = int(m.groups(1)[0]) - index = call_index[cur_sub] - - ret_labels = [cur_sub+"_"+str(i) for i in range(1, index+1)] - if args.mode == "cbm": - line = "%s GOSUBPOP_Q:ONQGOTO%s" % (lnum, ",".join(ret_labels)) - else: - line = "%s X=X-1:ON X%%(X+1) GOTO %s" % (lnum, ",".join(ret_labels)) - cur_sub = None - - lines.append(line) - - def update_labels_lines(text, a, b): - stext = "" - while stext != text: - stext = text - text = re.sub(r"(THEN *)%s\b" % a, r"\g<1>%s" % b, stext) - #text = re.sub(r"(THEN)%s\b" % a, r"THEN%s" % b, stext) - if args.mode == "cbm": - text = re.sub(r"ON *([^:\n]*) *GOTO *([^:\n]*)\b%s\b" % a, r"ON\g<1>GOTO\g<2>%s" % b, text) - text = re.sub(r"ON *([^:\n]*) *GOSUB *([^:\n]*)\b%s\b" % a, r"ON\g<1>GOSUB\g<2>%s" % b, text) - else: - text = re.sub(r"(ON [^:\n]* *GOTO *[^:\n]*)\b%s\b" % a, r"\g<1>%s" % b, text) - text = re.sub(r"(ON [^:\n]* *GOSUB *[^:\n]*)\b%s\b" % a, r"\g<1>%s" % b, text) - text = re.sub(r"(GOSUB *)%s\b" % a, r"\g<1>%s" % b, text) - text = re.sub(r"(GOTO *)%s\b" % a, r"\g<1>%s" % b, text) - #text = re.sub(r"(GOTO)%s\b" % a, r"\1%s" % b, text) - return text - - # search for and replace GOTO/GOSUBs - src_lines = lines - text = "\n".join(lines) - for label, lnum in labels_lines.items(): - text = update_labels_lines(text, label, lnum) - lines = text.split("\n") - - # combine lines - if not args.skip_combine_lines: - renumber = {} - src_lines = lines - lines = [] - pos = 0 - acc_line = "" - def renum(line): - lnum = len(lines)+1 - renumber[old_num] = lnum - return "%s %s" % (lnum, line) - while pos < len(src_lines): - line = src_lines[pos] - m = re.match(r"^([0-9]*) (.*)$", line) - old_num = int(m.group(1)) - line = m.group(2) - - if acc_line == "": - # Starting a new line - acc_line = renum(line) - elif old_num in lines_labels or re.match(r"^ *FOR\b.*", line): - # This is a GOTO/GOSUB target or FOR loop so it must - # be on a line by itself - lines.append(acc_line) - acc_line = renum(line) - elif re.match(r".*(?:GOTO|THEN|RETURN).*", acc_line): - # GOTO/THEN/RETURN are last thing on the line - lines.append(acc_line) - acc_line = renum(line) - # TODO: not sure why this is 88 rather than 80 - elif len(acc_line) + 1 + len(line) < 88: - # Continue building up the line - acc_line = acc_line + ":" + line - # GOTO/IF/RETURN must be the last things on a line so - # start a new line - if re.match(r".*(?:GOTO|THEN|RETURN).*", line): - lines.append(acc_line) - acc_line = "" - else: - # Too long so start a new line - lines.append(acc_line) - acc_line = renum(line) - pos += 1 - if acc_line != "": - lines.append(acc_line) - - # Finally renumber GOTO/GOSUBS - src_lines = lines - text = "\n".join(lines) - # search for and replace GOTO/GOSUBs - for a in sorted(renumber.keys()): - b = renumber[a] - text = update_labels_lines(text, a, b) - lines = text.split("\n") - - # Force non-UI QBasic to use text console. LINE INPUT also needs - # to be used instead in character-by-character READLINE - if args.full_mode == "qbasic-noui": - # Add console program prefix for qb64/qbasic - lines = ["$CONSOLE", - "$SCREENHIDE", - "_DEST _CONSOLE"] + lines - - return lines - -if __name__ == '__main__': - args = parse_args() - - debug("Preprocessing basic files: "+", ".join(args.infiles)) - - # read in lines - lines = [l.rstrip() for f in args.infiles - for l in open(f).readlines()] - debug("Original lines: %s" % len(lines)) - - # pull in include files - lines = resolve_includes(lines, args) - debug("Lines after includes: %s" % len(lines)) - - lines = resolve_mode(lines, args) - debug("Lines after resolving mode specific lines: %s" % len(lines)) - - # drop blank lines - if not args.keep_blank_lines: - lines = drop_blank_lines(lines) - debug("Lines after dropping blank lines: %s" % len(lines)) - - # keep/drop REMs - if not args.keep_rems: - lines = drop_rems(lines) - debug("Lines after dropping REMs: %s" % len(lines)) - - # keep/remove the indenting - if not args.keep_indent: - lines = remove_indent(lines) - - # apply some miscellaneous simple fixups/regex transforms - if not args.skip_misc_fixups: - lines = misc_fixups(lines) - - # number lines, drop/keep labels, combine lines - lines = finalize(lines, args) - debug("Lines after finalizing: %s" % len(lines)) - - print("\n".join(lines)) +#!/usr/bin/env python + +from __future__ import print_function +import argparse +import re +import sys + +def debug(*args, **kwargs): + print(*args, file=sys.stderr, **kwargs) + +def parse_args(): + parser = argparse.ArgumentParser(description='Preprocess Basic code.') + parser.add_argument('infiles', type=str, nargs='+', + help='the Basic files to preprocess') + parser.add_argument('--mode', choices=["cbm", "qbasic"], default="cbm") + parser.add_argument('--sub-mode', choices=["noui", "ui"], default="noui") + parser.add_argument('--keep-rems', action='store_true', default=False, + help='The type of REMs to keep (0 (none) -> 4 (all)') + parser.add_argument('--keep-blank-lines', action='store_true', default=False, + help='Keep blank lines from the original file') + parser.add_argument('--keep-indent', action='store_true', default=False, + help='Keep line identing') + parser.add_argument('--skip-misc-fixups', action='store_true', default=False, + help='Skip miscellaneous fixup/shrink fixups') + parser.add_argument('--skip-combine-lines', action='store_true', default=False, + help='Do not combine lines using the ":" separator') + + args = parser.parse_args() + args.full_mode = "%s-%s" % (args.mode, args.sub_mode) + if args.keep_rems and not args.skip_combine_lines: + debug("Option --keep-rems implies --skip-combine-lines ") + args.skip_combine_lines = True + + if args.mode == 'qbasic' and not args.skip_misc_fixups: + debug("Mode 'qbasic' implies --skip-misc-fixups") + args.skip_misc_fixups = True + + return args + +# pull in include files +def resolve_includes(orig_lines, args): + included = {} + lines = orig_lines[:] + position = 0 + while position < len(lines): + line = lines[position] + m = re.match(r"^(?:#([^ ]*) )? *REM \$INCLUDE: '([^'\n]*)' *$", line) + if m: + mode = m.group(1) + f = m.group(2) + if mode and mode != args.mode and mode != args.full_mode: + position += 1 + elif f not in included: + ilines = [l.rstrip() for l in open(f).readlines()] + if args.keep_rems: lines.append("REM vvv BEGIN '%s' vvv" % f) + lines[position:position+1] = ilines + if args.keep_rems: lines.append("REM ^^^ END '%s' ^^^" % f) + else: + debug("Ignoring already included file: %s" % f) + else: + position += 1 + return lines + +def resolve_mode(orig_lines, args): + lines = [] + for line in orig_lines: + m = re.match(r"^ *#([^ \n]*) *([^\n]*)$", line) + if m: + if m.group(1) == args.mode: + lines.append(m.group(2)) + elif m.group(1) == args.full_mode: + lines.append(m.group(2)) + continue + lines.append(line) + return lines + +def drop_blank_lines(orig_lines): + lines = [] + for line in orig_lines: + if re.match(r"^\W*$", line): continue + lines.append(line) + return lines + + +def drop_rems(orig_lines): + lines = [] + for line in orig_lines: + if re.match(r"^ *REM", line): + continue + m = re.match(r"^(.*): *REM .*$", line) + if m: + lines.append(m.group(1)) + else: + lines.append(line) + return lines + +def remove_indent(orig_lines): + lines = [] + for line in orig_lines: + m = re.match(r"^ *([^ \n].*)$", line) + lines.append(m.group(1)) + return lines + +def misc_fixups(orig_lines): + text = "\n".join(orig_lines) + + # Remove GOTO after THEN + text = re.sub(r"\bTHEN GOTO\b", "THEN", text) + + # Remove spaces after keywords + text = re.sub(r"\bIF ", "IF", text) + text = re.sub(r"\bPRINT *", "PRINT", text) + text = re.sub(r"\bDIM ", "DIM", text) + text = re.sub(r"\OPEN ", "OPEN", text) + text = re.sub(r"\bGET ", "GET", text) + text = re.sub(r"\bPOKE ", "POKE", text) + text = re.sub(r"\bCLOSE ", "CLOSE", text) + text = re.sub(r"\bFOR ", "FOR", text) + text = re.sub(r" TO ", "TO", text) + text = re.sub(r"\bNEXT ", "NEXT", text) + + # Remove spaces around GOTO/GOSUB/THEN + text = re.sub(r" *GOTO *", "GOTO", text) + text = re.sub(r" *GOSUB *", "GOSUB", text) + text = re.sub(r" *THEN *", r"THEN", text) + + # Remove spaces around AND/OR except after ST + text = re.sub(r"(?OR", text) + + return text.split("\n") + +def finalize(lines, args): + labels_lines = {} + lines_labels = {} + call_index = {} + + cur_sub = None + + # number lines, remove labels (but track line number), and replace + # CALLs with a stack based GOTO + src_lines = lines + lines = [] + lnum=1 + for line in src_lines: + + # Drop labels (track line number for GOTO/GOSUB) + m = re.match(r"^ *([^ :\n]*): *$", line) + if m: + label = m.groups(1)[0] + labels_lines[label] = lnum + lines_labels[lnum] = label + continue + + if re.match(r".*CALL *([^ :\n]*) *:", line): + raise Exception("CALL is not the last thing on line %s" % lnum) + + # Replace CALLs (track line number for replacement later) + #m = re.match(r"\bCALL *([^ :]*) *$", line) + m = re.match(r"(.*)CALL *([^ :\n]*) *$", line) + if m: + prefix = m.groups(1)[0] + sub = m.groups(1)[1] + if not call_index.has_key(sub): + call_index[sub] = 0 + call_index[sub] += 1 + label = sub+"_"+str(call_index[sub]) + + # Replace the CALL with stack based GOTO + if args.mode == "cbm": + lines.append("%s %sQ=%s:GOSUBPUSH_Q:GOTO%s" % ( + lnum, prefix, call_index[sub], sub)) + else: + lines.append("%s %sX=X+1:X%%(X)=%s:GOTO %s" % ( + lnum, prefix, call_index[sub], sub)) + lnum += 1 + + # Add the return spot + labels_lines[label] = lnum + lines_labels[lnum] = label + continue + + lines.append("%s %s" % (lnum, line)) + lnum += 1 + + # remove SUB (but track lines), and replace END SUB with ON GOTO + # that returns to original caller + src_lines = lines + lines = [] + lnum=1 + for line in src_lines: + # Drop subroutine defs (track line number for CALLS) + m = re.match(r"^([0-9][0-9]*) *SUB *([^ \n]*) *$", line) + if m: + lnum = int(m.groups(1)[0])+1 + label = m.groups(1)[1] + cur_sub = label + labels_lines[label] = lnum + lines_labels[lnum] = label + continue + + # Drop END SUB (track line number for replacement later) + m = re.match(r"^([0-9][0-9]*) *END SUB *$", line) + if m: + if cur_sub == None: + raise Exception("END SUB found without preceeding SUB") + lnum = int(m.groups(1)[0]) + index = call_index[cur_sub] + + ret_labels = [cur_sub+"_"+str(i) for i in range(1, index+1)] + if args.mode == "cbm": + line = "%s GOSUBPOP_Q:ONQGOTO%s" % (lnum, ",".join(ret_labels)) + else: + line = "%s X=X-1:ON X%%(X+1) GOTO %s" % (lnum, ",".join(ret_labels)) + cur_sub = None + + lines.append(line) + + def update_labels_lines(text, a, b): + stext = "" + while stext != text: + stext = text + text = re.sub(r"(THEN *)%s\b" % a, r"\g<1>%s" % b, stext) + #text = re.sub(r"(THEN)%s\b" % a, r"THEN%s" % b, stext) + if args.mode == "cbm": + text = re.sub(r"ON *([^:\n]*) *GOTO *([^:\n]*)\b%s\b" % a, r"ON\g<1>GOTO\g<2>%s" % b, text) + text = re.sub(r"ON *([^:\n]*) *GOSUB *([^:\n]*)\b%s\b" % a, r"ON\g<1>GOSUB\g<2>%s" % b, text) + else: + text = re.sub(r"(ON [^:\n]* *GOTO *[^:\n]*)\b%s\b" % a, r"\g<1>%s" % b, text) + text = re.sub(r"(ON [^:\n]* *GOSUB *[^:\n]*)\b%s\b" % a, r"\g<1>%s" % b, text) + text = re.sub(r"(GOSUB *)%s\b" % a, r"\g<1>%s" % b, text) + text = re.sub(r"(GOTO *)%s\b" % a, r"\g<1>%s" % b, text) + #text = re.sub(r"(GOTO)%s\b" % a, r"\1%s" % b, text) + return text + + # search for and replace GOTO/GOSUBs + src_lines = lines + text = "\n".join(lines) + for label, lnum in labels_lines.items(): + text = update_labels_lines(text, label, lnum) + lines = text.split("\n") + + # combine lines + if not args.skip_combine_lines: + renumber = {} + src_lines = lines + lines = [] + pos = 0 + acc_line = "" + def renum(line): + lnum = len(lines)+1 + renumber[old_num] = lnum + return "%s %s" % (lnum, line) + while pos < len(src_lines): + line = src_lines[pos] + m = re.match(r"^([0-9]*) (.*)$", line) + old_num = int(m.group(1)) + line = m.group(2) + + if acc_line == "": + # Starting a new line + acc_line = renum(line) + elif old_num in lines_labels or re.match(r"^ *FOR\b.*", line): + # This is a GOTO/GOSUB target or FOR loop so it must + # be on a line by itself + lines.append(acc_line) + acc_line = renum(line) + elif re.match(r".*(?:GOTO|THEN|RETURN).*", acc_line): + # GOTO/THEN/RETURN are last thing on the line + lines.append(acc_line) + acc_line = renum(line) + # TODO: not sure why this is 88 rather than 80 + elif len(acc_line) + 1 + len(line) < 88: + # Continue building up the line + acc_line = acc_line + ":" + line + # GOTO/IF/RETURN must be the last things on a line so + # start a new line + if re.match(r".*(?:GOTO|THEN|RETURN).*", line): + lines.append(acc_line) + acc_line = "" + else: + # Too long so start a new line + lines.append(acc_line) + acc_line = renum(line) + pos += 1 + if acc_line != "": + lines.append(acc_line) + + # Finally renumber GOTO/GOSUBS + src_lines = lines + text = "\n".join(lines) + # search for and replace GOTO/GOSUBs + for a in sorted(renumber.keys()): + b = renumber[a] + text = update_labels_lines(text, a, b) + lines = text.split("\n") + + # Force non-UI QBasic to use text console. LINE INPUT also needs + # to be used instead in character-by-character READLINE + if args.full_mode == "qbasic-noui": + # Add console program prefix for qb64/qbasic + lines = ["$CONSOLE", + "$SCREENHIDE", + "_DEST _CONSOLE"] + lines + + return lines + +if __name__ == '__main__': + args = parse_args() + + debug("Preprocessing basic files: "+", ".join(args.infiles)) + + # read in lines + lines = [l.rstrip() for f in args.infiles + for l in open(f).readlines()] + debug("Original lines: %s" % len(lines)) + + # pull in include files + lines = resolve_includes(lines, args) + debug("Lines after includes: %s" % len(lines)) + + lines = resolve_mode(lines, args) + debug("Lines after resolving mode specific lines: %s" % len(lines)) + + # drop blank lines + if not args.keep_blank_lines: + lines = drop_blank_lines(lines) + debug("Lines after dropping blank lines: %s" % len(lines)) + + # keep/drop REMs + if not args.keep_rems: + lines = drop_rems(lines) + debug("Lines after dropping REMs: %s" % len(lines)) + + # keep/remove the indenting + if not args.keep_indent: + lines = remove_indent(lines) + + # apply some miscellaneous simple fixups/regex transforms + if not args.skip_misc_fixups: + lines = misc_fixups(lines) + + # number lines, drop/keep labels, combine lines + lines = finalize(lines, args) + debug("Lines after finalizing: %s" % len(lines)) + + print("\n".join(lines)) diff --git a/impls/basic/core.in.bas b/impls/basic/core.in.bas index f2376729b7..dff58b4ce9 100644 --- a/impls/basic/core.in.bas +++ b/impls/basic/core.in.bas @@ -1,638 +1,638 @@ -REM APPLY should really be in types.in.bas but it is here because it -REM calls DO_TCO_FUNCTION so it will cause syntax errors for steps1-3 -REM if it is in types.in.bas because there are unresolved labels. - -REM APPLY(F, AR) -> R -REM - restores E -REM - call using GOTO and with return label/address on the stack -SUB APPLY - REM if metadata, get the actual object - GOSUB TYPE_F - IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F - - ON T-8 GOTO APPLY_FUNCTION,APPLY_MAL_FUNCTION,APPLY_MAL_FUNCTION - - APPLY_FUNCTION: - REM regular function - IF Z%(F+1)<64 THEN GOSUB DO_FUNCTION:GOTO APPLY_DONE - REM for recur functions (apply, map, swap!), use GOTO - IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION - GOTO APPLY_DONE - - APPLY_MAL_FUNCTION: - Q=E:GOSUB PUSH_Q: REM save the current environment - - REM create new environ using env and params stored in the - REM function and bind the params to the apply arguments - C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS - - A=Z%(F+1):E=R:CALL EVAL - - AY=E:GOSUB RELEASE: REM release the new environment - - GOSUB POP_Q:E=Q: REM pop/restore the saved environment - - APPLY_DONE: -END SUB - - -REM DO_TCO_FUNCTION(F, AR) -SUB DO_TCO_FUNCTION - G=Z%(F+1) - - REM Get argument values - A=Z%(AR+2) - B=Z%(Z%(AR+1)+2) - -REM PRINT "F:"+STR$(F)+", Z%(F):"+STR$(Z%(F))+", G:"+STR$(G) - ON G-64 GOTO DO_APPLY,DO_MAP,DO_SWAP_BANG - - DO_APPLY: - F=A - AR=Z%(AR+1) - A=AR:GOSUB COUNT:C=R - - A=Z%(AR+2) - REM no intermediate args, but not a list, so convert it first - GOSUB TYPE_A - IF C<=1 AND T<>6 THEN T=6:GOSUB FORCE_SEQ_TYPE:GOTO DO_APPLY_2 - REM no intermediate args, just call APPLY directly - IF C<=1 THEN GOTO DO_APPLY_1 - - REM prepend intermediate args to final args element - A=AR:B=0:C=C-1:GOSUB SLICE - REM release the terminator of new list (we skip over it) - REM we already checked for an empty list above, so R6 is pointer - REM a real non-empty list - AY=Z%(R6+1):GOSUB RELEASE - REM attach end of slice to final args element - A2=Z%(A+2) - Z%(R6+1)=A2 - Z%(A2)=Z%(A2)+32 - - GOTO DO_APPLY_2 - - DO_APPLY_1: - AR=A:CALL APPLY - - GOTO DO_TCO_FUNCTION_DONE - - DO_APPLY_2: - GOSUB PUSH_R: REM push/save new args for release - - AR=R:CALL APPLY - - REM pop/release new args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - GOTO DO_TCO_FUNCTION_DONE - - DO_MAP: - F=A - - REM setup the stack for the loop - T=6:GOSUB MAP_LOOP_START - - DO_MAP_LOOP: - IF Z%(B+1)=0 THEN GOTO DO_MAP_DONE - - REM create argument list for apply - T=6:L=6:M=Z%(B+2):GOSUB ALLOC - - GOSUB PUSH_R: REM push argument list - Q=F:GOSUB PUSH_Q: REM push F - Q=B:GOSUB PUSH_Q: REM push B - - AR=R:CALL APPLY - - GOSUB POP_Q:B=Q: REM pop B - GOSUB POP_Q:F=Q: REM pop F - GOSUB POP_Q: REM pop apply args and release them - AY=Q:GOSUB RELEASE - - REM main value is result of apply - M=R - - B=Z%(B+1): REM go to the next element - - REM if error, release the unattached element - IF ER<>-2 THEN AY=R:GOSUB RELEASE:GOTO DO_MAP_DONE - - REM update the return sequence structure - REM release N since list takes full ownership - C=1:T=6:GOSUB MAP_LOOP_UPDATE - - GOTO DO_MAP_LOOP - - DO_MAP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO DO_TCO_FUNCTION_DONE - - DO_SWAP_BANG: - F=B - - REM add atom to front of the args list - T=6:L=Z%(Z%(AR+1)+1):M=Z%(A+1):GOSUB ALLOC: REM cons - AR=R - - REM push args for release after - Q=AR:GOSUB PUSH_Q - - REM push atom - GOSUB PUSH_A - - CALL APPLY - - REM pop atom - GOSUB POP_A - - REM pop and release args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - - REM use reset to update the value - B=R:GOSUB DO_RESET_BANG - - REM but decrease ref cnt of return by 1 (not sure why) - AY=R:GOSUB RELEASE - - GOTO DO_TCO_FUNCTION_DONE - - DO_TCO_FUNCTION_DONE: -END SUB - -REM DO_FUNCTION(F, AR) -DO_FUNCTION: - REM Get the function number - G=Z%(F+1) - - REM Get argument values - A=Z%(AR+2):A1=Z%(A+1) - B=Z%(Z%(AR+1)+2):B1=Z%(B+1) - - REM Switch on the function number - REM MEMORY DEBUGGING: - REM IF G>60 THEN ER=-1:E$="unknown function"+STR$(G):RETURN - ON INT(G/10)+1 GOTO DO_1_9,DO_10_19,DO_20_29,DO_30_39,DO_40_49,DO_50_59,DO_60_69 - - DO_1_9: - ON G GOTO DO_EQUAL_Q,DO_THROW,DO_NIL_Q,DO_TRUE_Q,DO_FALSE_Q,DO_STRING_Q,DO_SYMBOL,DO_SYMBOL_Q,DO_KEYWORD - DO_10_19: - ON G-9 GOTO DO_KEYWORD_Q,DO_NUMBER_Q,DO_FN_Q,DO_MACRO_Q,DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE - DO_20_29: - ON G-19 GOTO DO_SLURP,DO_LT,DO_LTE,DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS - DO_30_39: - ON G-29 GOTO DO_LIST,DO_LIST_Q,DO_VECTOR,DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q,DO_ASSOC,DO_THROW,DO_GET,DO_CONTAINS - DO_40_49: - ON G-39 GOTO DO_KEYS,DO_VALS,DO_SEQUENTIAL_Q,DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT - DO_50_59: - ON G-49 GOTO DO_CONJ,DO_SEQ,DO_WITH_META,DO_META,DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_EVAL,DO_READ_FILE - DO_60_69: - ON G-59 GOTO DO_VEC,DO_PR_MEMORY_SUMMARY - - DO_EQUAL_Q: - GOSUB EQUAL_Q - GOTO RETURN_TRUE_FALSE - DO_THROW: - ER=A - Z%(ER)=Z%(ER)+32 - R=-1 - RETURN - DO_NIL_Q: - R=A=0 - GOTO RETURN_TRUE_FALSE - DO_TRUE_Q: - R=A=4 - GOTO RETURN_TRUE_FALSE - DO_FALSE_Q: - R=A=2 - GOTO RETURN_TRUE_FALSE - DO_STRING_Q: - R=0 - GOSUB TYPE_A - IF T<>4 THEN GOTO RETURN_TRUE_FALSE - IF MID$(S$(A1),1,1)=CHR$(127) THEN GOTO RETURN_TRUE_FALSE - R=1 - GOTO RETURN_TRUE_FALSE - DO_SYMBOL: - B$=S$(A1) - T=5:GOSUB STRING - RETURN - DO_SYMBOL_Q: - GOSUB TYPE_A - R=T=5 - GOTO RETURN_TRUE_FALSE - DO_KEYWORD: - B$=S$(A1) - IF MID$(B$,1,1)<>CHR$(127) THEN B$=CHR$(127)+B$ - T=4:GOSUB STRING - RETURN - DO_KEYWORD_Q: - R=0 - GOSUB TYPE_A - IF T<>4 THEN GOTO RETURN_TRUE_FALSE - IF MID$(S$(A1),1,1)<>CHR$(127) THEN GOTO RETURN_TRUE_FALSE - R=1 - GOTO RETURN_TRUE_FALSE - DO_NUMBER_Q: - GOSUB TYPE_A - R=T=2 - GOTO RETURN_TRUE_FALSE - DO_FN_Q: - GOSUB TYPE_A - R=T=9 OR T=10 - GOTO RETURN_TRUE_FALSE - DO_MACRO_Q: - GOSUB TYPE_A - R=T=11 - GOTO RETURN_TRUE_FALSE - - DO_PR_STR: - AZ=AR:B=1:B$=" ":GOSUB PR_STR_SEQ - B$=R$:T=4:GOSUB STRING - RETURN - DO_STR: - AZ=AR:B=0:B$="":GOSUB PR_STR_SEQ - B$=R$:T=4:GOSUB STRING - RETURN - DO_PRN: - AZ=AR:B=1:B$=" ":GOSUB PR_STR_SEQ - PRINT R$ - R=0 - GOTO INC_REF_R - DO_PRINTLN: - AZ=AR:B=0:B$=" ":GOSUB PR_STR_SEQ - PRINT R$ - R=0 - GOTO INC_REF_R - DO_READ_STRING: - A$=S$(A1) - GOSUB READ_STR - RETURN - DO_READLINE: - A$=S$(A1):GOSUB READLINE - IF EZ>0 THEN EZ=0:R=0:GOTO INC_REF_R - B$=R$:T=4:GOSUB STRING - RETURN - DO_SLURP: - R$="" - EZ=0 - #cbm OPEN 2,8,0,S$(A1) - #qbasic A$=S$(A1) - #qbasic IF NOT _FILEEXISTS(A$) THEN ER=-1:E$="File not found":RETURN - #qbasic OPEN A$ FOR INPUT AS #2 - DO_SLURP_LOOP: - C$="" - RJ=1:GOSUB READ_FILE_CHAR - #cbm IF ASC(C$)=10 THEN R$=R$+CHR$(13) - #qbasic IF ASC(C$)=10 THEN R$=R$+CHR$(10) - IF (ASC(C$)<>10) AND (C$<>"") THEN R$=R$+C$ - IF EZ>0 THEN GOTO DO_SLURP_DONE - GOTO DO_SLURP_LOOP - DO_SLURP_DONE: - CLOSE 2 - IF ER>-2 THEN RETURN - B$=R$:T=4:GOSUB STRING - RETURN - - DO_LT: - R=A1B1 - GOTO RETURN_TRUE_FALSE - DO_GTE: - R=A1>=B1 - GOTO RETURN_TRUE_FALSE - - DO_ADD: - T=2:L=A1+B1:GOSUB ALLOC - RETURN - DO_SUB: - T=2:L=A1-B1:GOSUB ALLOC - RETURN - DO_MULT: - T=2:L=A1*B1:GOSUB ALLOC - RETURN - DO_DIV: - T=2:L=A1/B1:GOSUB ALLOC - RETURN - DO_TIME_MS: - #cbm T=2:L=INT((TI-BT)*16.667):GOSUB ALLOC - #qbasic T=2:L=INT((TIMER(0.001)-BT#)*1000):GOSUB ALLOC - RETURN - - DO_LIST: - R=AR - GOTO INC_REF_R - DO_LIST_Q: - GOSUB LIST_Q - GOTO RETURN_TRUE_FALSE - DO_VECTOR: - A=AR:T=7:GOTO FORCE_SEQ_TYPE - DO_VECTOR_Q: - GOSUB TYPE_A - R=T=7 - GOTO RETURN_TRUE_FALSE - DO_HASH_MAP: - REM setup the stack for the loop - T=8:GOSUB MAP_LOOP_START - - A=AR - DO_HASH_MAP_LOOP: - IF Z%(A+1)=0 THEN GOTO DO_HASH_MAP_LOOP_DONE - - M=Z%(A+2) - N=Z%(Z%(A+1)+2) - - A=Z%(Z%(A+1)+1): REM skip two - - REM update the return sequence structure - REM do not release M and N since we are pulling them from the - REM arguments (and not creating them here) - C=0:GOSUB MAP_LOOP_UPDATE - - GOTO DO_HASH_MAP_LOOP - - DO_HASH_MAP_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - RETURN - - DO_MAP_Q: - GOSUB TYPE_A - R=T=8 - GOTO RETURN_TRUE_FALSE - DO_ASSOC: - H=A - AR=Z%(AR+1) - DO_ASSOC_LOOP: - K=Z%(AR+2) - C=Z%(Z%(AR+1)+2) - Z%(H)=Z%(H)+32 - GOSUB ASSOC1:H=R - AR=Z%(Z%(AR+1)+1) - IF AR=0 OR Z%(AR+1)=0 THEN RETURN - GOTO DO_ASSOC_LOOP - DO_GET: - IF A=0 THEN R=0:GOTO INC_REF_R - H=A:K=B:GOSUB HASHMAP_GET - GOTO INC_REF_R - DO_CONTAINS: - H=A:K=B:GOSUB HASHMAP_CONTAINS - GOTO RETURN_TRUE_FALSE - DO_KEYS: - T1=0 - GOTO DO_KEYS_VALS - DO_VALS: - T1=1 - DO_KEYS_VALS: - REM setup the stack for the loop - T=6:GOSUB MAP_LOOP_START - - DO_KEYS_VALS_LOOP: - IF Z%(A+1)=0 THEN GOTO DO_KEYS_VALS_LOOP_DONE - - IF T1=0 THEN M=Z%(A+2) - IF T1=1 THEN M=Z%(A+3) - - A=Z%(A+1): REM next element - - REM update the return sequence structure - REM do not release N since we are pulling it from the - REM hash-map (and not creating them here) - C=0:GOSUB MAP_LOOP_UPDATE - - GOTO DO_KEYS_VALS_LOOP - - DO_KEYS_VALS_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - RETURN - - DO_SEQUENTIAL_Q: - GOSUB TYPE_A - R=T=6 OR T=7 - GOTO RETURN_TRUE_FALSE - DO_CONS: - T=6:L=B:M=A:GOSUB ALLOC - RETURN - DO_CONCAT: - REM always a list - R=6:GOSUB INC_REF_R - GOSUB PUSH_R: REM current value - GOSUB PUSH_R: REM return value - - DO_CONCAT_LOOP: - IF AR<16 THEN GOTO DO_CONCAT_DONE: REM no more elements - - REM slice/copy current element to a list - A=Z%(AR+2) - IF A<16 THEN GOTO DO_CONCAT_LOOP_NEXT: REM skip empty elements - B=0:C=-1:GOSUB SLICE - - GOSUB PEEK_Q: REM return value - REM if this is the first element, set return element - IF Q=6 THEN Q=R:GOSUB PUT_Q:GOTO DO_CONCAT_LOOP_AGAIN - REM otherwise Q<>6, so attach current to sliced - GOSUB PEEK_Q_1 - Z%(Q+1)=R - - DO_CONCAT_LOOP_AGAIN: - REM update current to end of sliced list - Q=R6:GOSUB PUT_Q_1 - REM dec empty since no longer part of slice - AY=6:GOSUB RELEASE - DO_CONCAT_LOOP_NEXT: - REM next list element - AR=Z%(AR+1) - GOTO DO_CONCAT_LOOP - - DO_CONCAT_DONE: - GOSUB POP_R: REM pop return value - GOSUB POP_Q: REM pop current - RETURN - DO_VEC: - T=7:GOTO FORCE_SEQ_TYPE - - DO_NTH: - B=B1 - GOSUB COUNT - IF R<=B THEN R=-1:ER=-1:E$="nth: index out of range":RETURN - DO_NTH_LOOP: - IF B=0 THEN GOTO DO_NTH_DONE - B=B-1 - A=Z%(A+1) - GOTO DO_NTH_LOOP - DO_NTH_DONE: - R=Z%(A+2) - GOTO INC_REF_R - DO_FIRST: - R=0 - IF A=0 THEN GOTO INC_REF_R - IF A1<>0 THEN R=Z%(A+2) - GOTO INC_REF_R - DO_REST: - IF A=0 THEN R=6:GOTO INC_REF_R - IF A1<>0 THEN A=A1: REM get the next sequence element - T=6:GOSUB FORCE_SEQ_TYPE - RETURN - DO_EMPTY_Q: - R=A1=0 - GOTO RETURN_TRUE_FALSE - DO_COUNT: - GOSUB COUNT - T=2:L=R:GOSUB ALLOC - RETURN - DO_CONJ: - R=0 - GOTO INC_REF_R - DO_SEQ: - R=0 - GOTO INC_REF_R - - DO_WITH_META: - GOSUB TYPE_A - REM remove existing metadata first - IF T=14 THEN A=A1:GOTO DO_WITH_META - T=14:L=A:M=B:GOSUB ALLOC - RETURN - DO_META: - R=0 - GOSUB TYPE_A - IF T=14 THEN R=Z%(A+2) - GOTO INC_REF_R - DO_ATOM: - T=12:L=A:GOSUB ALLOC - RETURN - DO_ATOM_Q: - GOSUB TYPE_A - R=T=12 - GOTO RETURN_TRUE_FALSE - DO_DEREF: - R=A1 - GOTO INC_REF_R - DO_RESET_BANG: - R=B - REM release current value - REM can't use A1 here because DO_RESET_BANG is called from swap! - AY=Z%(A+1):GOSUB RELEASE - REM inc ref by 2 for atom ownership and since we are returning it - Z%(R)=Z%(R)+64 - REM update value - Z%(A+1)=R - RETURN - - DO_EVAL: - Q=E:GOSUB PUSH_Q: REM push/save environment - E=D:CALL EVAL - GOSUB POP_Q:E=Q - RETURN - - DO_READ_FILE: - A$=S$(A1) - GOSUB READ_FILE - RETURN - - REM DO_PR_MEMORY: - REM P1=ZT:P2=-1:GOSUB PR_MEMORY - REM RETURN - DO_PR_MEMORY_SUMMARY: - REM GOSUB PR_MEMORY_SUMMARY - GOSUB PR_MEMORY_SUMMARY_SMALL - R=0 - GOTO INC_REF_R - RETURN - -INIT_CORE_SET_FUNCTION: - T=9:L=A:GOSUB ALLOC: REM native function - C=R:GOSUB ENV_SET_S - A=A+1 - RETURN - -REM INIT_CORE_NS(E) -INIT_CORE_NS: - REM create the environment mapping - REM must match DO_FUNCTION mappings - - A=1 - B$="=":GOSUB INIT_CORE_SET_FUNCTION: REM A=1 - B$="throw":GOSUB INIT_CORE_SET_FUNCTION: REM A=2 - B$="nil?":GOSUB INIT_CORE_SET_FUNCTION: REM A=3 - B$="true?":GOSUB INIT_CORE_SET_FUNCTION: REM A=4 - B$="false?":GOSUB INIT_CORE_SET_FUNCTION: REM A=5 - B$="string?":GOSUB INIT_CORE_SET_FUNCTION: REM A=6 - B$="symbol":GOSUB INIT_CORE_SET_FUNCTION: REM A=7 - B$="symbol?":GOSUB INIT_CORE_SET_FUNCTION: REM A=8 - B$="keyword":GOSUB INIT_CORE_SET_FUNCTION: REM A=9 - B$="keyword?":GOSUB INIT_CORE_SET_FUNCTION: REM A=10 - B$="number?":GOSUB INIT_CORE_SET_FUNCTION: REM A=11 - B$="fn?":GOSUB INIT_CORE_SET_FUNCTION: REM A=12 - B$="macro?":GOSUB INIT_CORE_SET_FUNCTION: REM A=13 - - B$="pr-str":GOSUB INIT_CORE_SET_FUNCTION: REM A=14 - B$="str":GOSUB INIT_CORE_SET_FUNCTION: REM A=15 - B$="prn":GOSUB INIT_CORE_SET_FUNCTION: REM A=16 - B$="println":GOSUB INIT_CORE_SET_FUNCTION: REM A=17 - B$="read-string":GOSUB INIT_CORE_SET_FUNCTION: REM A=18 - B$="readline":GOSUB INIT_CORE_SET_FUNCTION: REM A=19 - B$="slurp":GOSUB INIT_CORE_SET_FUNCTION: REM A=20 - - B$="<":GOSUB INIT_CORE_SET_FUNCTION: REM A=21 - B$="<=":GOSUB INIT_CORE_SET_FUNCTION: REM A=22 - B$=">":GOSUB INIT_CORE_SET_FUNCTION: REM A=23 - B$=">=":GOSUB INIT_CORE_SET_FUNCTION: REM A=24 - B$="+":GOSUB INIT_CORE_SET_FUNCTION: REM A=25 - B$="-":GOSUB INIT_CORE_SET_FUNCTION: REM A=26 - B$="*":GOSUB INIT_CORE_SET_FUNCTION: REM A=27 - B$="/":GOSUB INIT_CORE_SET_FUNCTION: REM A=28 - B$="time-ms":GOSUB INIT_CORE_SET_FUNCTION: REM A=29 - - B$="list":GOSUB INIT_CORE_SET_FUNCTION: REM A=30 - B$="list?":GOSUB INIT_CORE_SET_FUNCTION: REM A=31 - B$="vector":GOSUB INIT_CORE_SET_FUNCTION: REM A=32 - B$="vector?":GOSUB INIT_CORE_SET_FUNCTION: REM A=33 - B$="hash-map":GOSUB INIT_CORE_SET_FUNCTION: REM A=34 - B$="map?":GOSUB INIT_CORE_SET_FUNCTION: REM A=35 - B$="assoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=36 - B$="dissoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=37 - B$="get":GOSUB INIT_CORE_SET_FUNCTION: REM A=38 - B$="contains?":GOSUB INIT_CORE_SET_FUNCTION: REM A=39 - B$="keys":GOSUB INIT_CORE_SET_FUNCTION: REM A=40 - B$="vals":GOSUB INIT_CORE_SET_FUNCTION: REM A=41 - - B$="sequential?":GOSUB INIT_CORE_SET_FUNCTION: REM A=42 - B$="cons":GOSUB INIT_CORE_SET_FUNCTION: REM A=43 - B$="concat":GOSUB INIT_CORE_SET_FUNCTION: REM A=44 - B$="nth":GOSUB INIT_CORE_SET_FUNCTION: REM A=45 - B$="first":GOSUB INIT_CORE_SET_FUNCTION: REM A=46 - B$="rest":GOSUB INIT_CORE_SET_FUNCTION: REM A=47 - B$="empty?":GOSUB INIT_CORE_SET_FUNCTION: REM A=48 - B$="count":GOSUB INIT_CORE_SET_FUNCTION: REM A=49 - - B$="conj":GOSUB INIT_CORE_SET_FUNCTION: REM A=50 - B$="seq":GOSUB INIT_CORE_SET_FUNCTION: REM A=51 - - B$="with-meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=52 - B$="meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=53 - B$="atom":GOSUB INIT_CORE_SET_FUNCTION: REM A=54 - B$="atom?":GOSUB INIT_CORE_SET_FUNCTION: REM A=55 - B$="deref":GOSUB INIT_CORE_SET_FUNCTION: REM A=56 - B$="reset!":GOSUB INIT_CORE_SET_FUNCTION: REM A=57 - - B$="eval":GOSUB INIT_CORE_SET_FUNCTION: REM A=58 - B$="read-file":GOSUB INIT_CORE_SET_FUNCTION: REM A=59 - B$="vec":GOSUB INIT_CORE_SET_FUNCTION: REM A=60 - B$="pr-memory-summary":GOSUB INIT_CORE_SET_FUNCTION: REM A=61 - - REM these are in DO_TCO_FUNCTION - A=65 - B$="apply":GOSUB INIT_CORE_SET_FUNCTION: REM A=65 - B$="map":GOSUB INIT_CORE_SET_FUNCTION: REM A=66 - B$="swap!":GOSUB INIT_CORE_SET_FUNCTION: REM A=67 - - RETURN +REM APPLY should really be in types.in.bas but it is here because it +REM calls DO_TCO_FUNCTION so it will cause syntax errors for steps1-3 +REM if it is in types.in.bas because there are unresolved labels. + +REM APPLY(F, AR) -> R +REM - restores E +REM - call using GOTO and with return label/address on the stack +SUB APPLY + REM if metadata, get the actual object + GOSUB TYPE_F + IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F + + ON T-8 GOTO APPLY_FUNCTION,APPLY_MAL_FUNCTION,APPLY_MAL_FUNCTION + + APPLY_FUNCTION: + REM regular function + IF Z%(F+1)<64 THEN GOSUB DO_FUNCTION:GOTO APPLY_DONE + REM for recur functions (apply, map, swap!), use GOTO + IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION + GOTO APPLY_DONE + + APPLY_MAL_FUNCTION: + Q=E:GOSUB PUSH_Q: REM save the current environment + + REM create new environ using env and params stored in the + REM function and bind the params to the apply arguments + C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS + + A=Z%(F+1):E=R:CALL EVAL + + AY=E:GOSUB RELEASE: REM release the new environment + + GOSUB POP_Q:E=Q: REM pop/restore the saved environment + + APPLY_DONE: +END SUB + + +REM DO_TCO_FUNCTION(F, AR) +SUB DO_TCO_FUNCTION + G=Z%(F+1) + + REM Get argument values + A=Z%(AR+2) + B=Z%(Z%(AR+1)+2) + +REM PRINT "F:"+STR$(F)+", Z%(F):"+STR$(Z%(F))+", G:"+STR$(G) + ON G-64 GOTO DO_APPLY,DO_MAP,DO_SWAP_BANG + + DO_APPLY: + F=A + AR=Z%(AR+1) + A=AR:GOSUB COUNT:C=R + + A=Z%(AR+2) + REM no intermediate args, but not a list, so convert it first + GOSUB TYPE_A + IF C<=1 AND T<>6 THEN T=6:GOSUB FORCE_SEQ_TYPE:GOTO DO_APPLY_2 + REM no intermediate args, just call APPLY directly + IF C<=1 THEN GOTO DO_APPLY_1 + + REM prepend intermediate args to final args element + A=AR:B=0:C=C-1:GOSUB SLICE + REM release the terminator of new list (we skip over it) + REM we already checked for an empty list above, so R6 is pointer + REM a real non-empty list + AY=Z%(R6+1):GOSUB RELEASE + REM attach end of slice to final args element + A2=Z%(A+2) + Z%(R6+1)=A2 + Z%(A2)=Z%(A2)+32 + + GOTO DO_APPLY_2 + + DO_APPLY_1: + AR=A:CALL APPLY + + GOTO DO_TCO_FUNCTION_DONE + + DO_APPLY_2: + GOSUB PUSH_R: REM push/save new args for release + + AR=R:CALL APPLY + + REM pop/release new args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + GOTO DO_TCO_FUNCTION_DONE + + DO_MAP: + F=A + + REM setup the stack for the loop + T=6:GOSUB MAP_LOOP_START + + DO_MAP_LOOP: + IF Z%(B+1)=0 THEN GOTO DO_MAP_DONE + + REM create argument list for apply + T=6:L=6:M=Z%(B+2):GOSUB ALLOC + + GOSUB PUSH_R: REM push argument list + Q=F:GOSUB PUSH_Q: REM push F + Q=B:GOSUB PUSH_Q: REM push B + + AR=R:CALL APPLY + + GOSUB POP_Q:B=Q: REM pop B + GOSUB POP_Q:F=Q: REM pop F + GOSUB POP_Q: REM pop apply args and release them + AY=Q:GOSUB RELEASE + + REM main value is result of apply + M=R + + B=Z%(B+1): REM go to the next element + + REM if error, release the unattached element + IF ER<>-2 THEN AY=R:GOSUB RELEASE:GOTO DO_MAP_DONE + + REM update the return sequence structure + REM release N since list takes full ownership + C=1:T=6:GOSUB MAP_LOOP_UPDATE + + GOTO DO_MAP_LOOP + + DO_MAP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO DO_TCO_FUNCTION_DONE + + DO_SWAP_BANG: + F=B + + REM add atom to front of the args list + T=6:L=Z%(Z%(AR+1)+1):M=Z%(A+1):GOSUB ALLOC: REM cons + AR=R + + REM push args for release after + Q=AR:GOSUB PUSH_Q + + REM push atom + GOSUB PUSH_A + + CALL APPLY + + REM pop atom + GOSUB POP_A + + REM pop and release args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + + REM use reset to update the value + B=R:GOSUB DO_RESET_BANG + + REM but decrease ref cnt of return by 1 (not sure why) + AY=R:GOSUB RELEASE + + GOTO DO_TCO_FUNCTION_DONE + + DO_TCO_FUNCTION_DONE: +END SUB + +REM DO_FUNCTION(F, AR) +DO_FUNCTION: + REM Get the function number + G=Z%(F+1) + + REM Get argument values + A=Z%(AR+2):A1=Z%(A+1) + B=Z%(Z%(AR+1)+2):B1=Z%(B+1) + + REM Switch on the function number + REM MEMORY DEBUGGING: + REM IF G>60 THEN ER=-1:E$="unknown function"+STR$(G):RETURN + ON INT(G/10)+1 GOTO DO_1_9,DO_10_19,DO_20_29,DO_30_39,DO_40_49,DO_50_59,DO_60_69 + + DO_1_9: + ON G GOTO DO_EQUAL_Q,DO_THROW,DO_NIL_Q,DO_TRUE_Q,DO_FALSE_Q,DO_STRING_Q,DO_SYMBOL,DO_SYMBOL_Q,DO_KEYWORD + DO_10_19: + ON G-9 GOTO DO_KEYWORD_Q,DO_NUMBER_Q,DO_FN_Q,DO_MACRO_Q,DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE + DO_20_29: + ON G-19 GOTO DO_SLURP,DO_LT,DO_LTE,DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS + DO_30_39: + ON G-29 GOTO DO_LIST,DO_LIST_Q,DO_VECTOR,DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q,DO_ASSOC,DO_THROW,DO_GET,DO_CONTAINS + DO_40_49: + ON G-39 GOTO DO_KEYS,DO_VALS,DO_SEQUENTIAL_Q,DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT + DO_50_59: + ON G-49 GOTO DO_CONJ,DO_SEQ,DO_WITH_META,DO_META,DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_EVAL,DO_READ_FILE + DO_60_69: + ON G-59 GOTO DO_VEC,DO_PR_MEMORY_SUMMARY + + DO_EQUAL_Q: + GOSUB EQUAL_Q + GOTO RETURN_TRUE_FALSE + DO_THROW: + ER=A + Z%(ER)=Z%(ER)+32 + R=-1 + RETURN + DO_NIL_Q: + R=A=0 + GOTO RETURN_TRUE_FALSE + DO_TRUE_Q: + R=A=4 + GOTO RETURN_TRUE_FALSE + DO_FALSE_Q: + R=A=2 + GOTO RETURN_TRUE_FALSE + DO_STRING_Q: + R=0 + GOSUB TYPE_A + IF T<>4 THEN GOTO RETURN_TRUE_FALSE + IF MID$(S$(A1),1,1)=CHR$(127) THEN GOTO RETURN_TRUE_FALSE + R=1 + GOTO RETURN_TRUE_FALSE + DO_SYMBOL: + B$=S$(A1) + T=5:GOSUB STRING + RETURN + DO_SYMBOL_Q: + GOSUB TYPE_A + R=T=5 + GOTO RETURN_TRUE_FALSE + DO_KEYWORD: + B$=S$(A1) + IF MID$(B$,1,1)<>CHR$(127) THEN B$=CHR$(127)+B$ + T=4:GOSUB STRING + RETURN + DO_KEYWORD_Q: + R=0 + GOSUB TYPE_A + IF T<>4 THEN GOTO RETURN_TRUE_FALSE + IF MID$(S$(A1),1,1)<>CHR$(127) THEN GOTO RETURN_TRUE_FALSE + R=1 + GOTO RETURN_TRUE_FALSE + DO_NUMBER_Q: + GOSUB TYPE_A + R=T=2 + GOTO RETURN_TRUE_FALSE + DO_FN_Q: + GOSUB TYPE_A + R=T=9 OR T=10 + GOTO RETURN_TRUE_FALSE + DO_MACRO_Q: + GOSUB TYPE_A + R=T=11 + GOTO RETURN_TRUE_FALSE + + DO_PR_STR: + AZ=AR:B=1:B$=" ":GOSUB PR_STR_SEQ + B$=R$:T=4:GOSUB STRING + RETURN + DO_STR: + AZ=AR:B=0:B$="":GOSUB PR_STR_SEQ + B$=R$:T=4:GOSUB STRING + RETURN + DO_PRN: + AZ=AR:B=1:B$=" ":GOSUB PR_STR_SEQ + PRINT R$ + R=0 + GOTO INC_REF_R + DO_PRINTLN: + AZ=AR:B=0:B$=" ":GOSUB PR_STR_SEQ + PRINT R$ + R=0 + GOTO INC_REF_R + DO_READ_STRING: + A$=S$(A1) + GOSUB READ_STR + RETURN + DO_READLINE: + A$=S$(A1):GOSUB READLINE + IF EZ>0 THEN EZ=0:R=0:GOTO INC_REF_R + B$=R$:T=4:GOSUB STRING + RETURN + DO_SLURP: + R$="" + EZ=0 + #cbm OPEN 2,8,0,S$(A1) + #qbasic A$=S$(A1) + #qbasic IF NOT _FILEEXISTS(A$) THEN ER=-1:E$="File not found":RETURN + #qbasic OPEN A$ FOR INPUT AS #2 + DO_SLURP_LOOP: + C$="" + RJ=1:GOSUB READ_FILE_CHAR + #cbm IF ASC(C$)=10 THEN R$=R$+CHR$(13) + #qbasic IF ASC(C$)=10 THEN R$=R$+CHR$(10) + IF (ASC(C$)<>10) AND (C$<>"") THEN R$=R$+C$ + IF EZ>0 THEN GOTO DO_SLURP_DONE + GOTO DO_SLURP_LOOP + DO_SLURP_DONE: + CLOSE 2 + IF ER>-2 THEN RETURN + B$=R$:T=4:GOSUB STRING + RETURN + + DO_LT: + R=A1B1 + GOTO RETURN_TRUE_FALSE + DO_GTE: + R=A1>=B1 + GOTO RETURN_TRUE_FALSE + + DO_ADD: + T=2:L=A1+B1:GOSUB ALLOC + RETURN + DO_SUB: + T=2:L=A1-B1:GOSUB ALLOC + RETURN + DO_MULT: + T=2:L=A1*B1:GOSUB ALLOC + RETURN + DO_DIV: + T=2:L=A1/B1:GOSUB ALLOC + RETURN + DO_TIME_MS: + #cbm T=2:L=INT((TI-BT)*16.667):GOSUB ALLOC + #qbasic T=2:L=INT((TIMER(0.001)-BT#)*1000):GOSUB ALLOC + RETURN + + DO_LIST: + R=AR + GOTO INC_REF_R + DO_LIST_Q: + GOSUB LIST_Q + GOTO RETURN_TRUE_FALSE + DO_VECTOR: + A=AR:T=7:GOTO FORCE_SEQ_TYPE + DO_VECTOR_Q: + GOSUB TYPE_A + R=T=7 + GOTO RETURN_TRUE_FALSE + DO_HASH_MAP: + REM setup the stack for the loop + T=8:GOSUB MAP_LOOP_START + + A=AR + DO_HASH_MAP_LOOP: + IF Z%(A+1)=0 THEN GOTO DO_HASH_MAP_LOOP_DONE + + M=Z%(A+2) + N=Z%(Z%(A+1)+2) + + A=Z%(Z%(A+1)+1): REM skip two + + REM update the return sequence structure + REM do not release M and N since we are pulling them from the + REM arguments (and not creating them here) + C=0:GOSUB MAP_LOOP_UPDATE + + GOTO DO_HASH_MAP_LOOP + + DO_HASH_MAP_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + RETURN + + DO_MAP_Q: + GOSUB TYPE_A + R=T=8 + GOTO RETURN_TRUE_FALSE + DO_ASSOC: + H=A + AR=Z%(AR+1) + DO_ASSOC_LOOP: + K=Z%(AR+2) + C=Z%(Z%(AR+1)+2) + Z%(H)=Z%(H)+32 + GOSUB ASSOC1:H=R + AR=Z%(Z%(AR+1)+1) + IF AR=0 OR Z%(AR+1)=0 THEN RETURN + GOTO DO_ASSOC_LOOP + DO_GET: + IF A=0 THEN R=0:GOTO INC_REF_R + H=A:K=B:GOSUB HASHMAP_GET + GOTO INC_REF_R + DO_CONTAINS: + H=A:K=B:GOSUB HASHMAP_CONTAINS + GOTO RETURN_TRUE_FALSE + DO_KEYS: + T1=0 + GOTO DO_KEYS_VALS + DO_VALS: + T1=1 + DO_KEYS_VALS: + REM setup the stack for the loop + T=6:GOSUB MAP_LOOP_START + + DO_KEYS_VALS_LOOP: + IF Z%(A+1)=0 THEN GOTO DO_KEYS_VALS_LOOP_DONE + + IF T1=0 THEN M=Z%(A+2) + IF T1=1 THEN M=Z%(A+3) + + A=Z%(A+1): REM next element + + REM update the return sequence structure + REM do not release N since we are pulling it from the + REM hash-map (and not creating them here) + C=0:GOSUB MAP_LOOP_UPDATE + + GOTO DO_KEYS_VALS_LOOP + + DO_KEYS_VALS_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + RETURN + + DO_SEQUENTIAL_Q: + GOSUB TYPE_A + R=T=6 OR T=7 + GOTO RETURN_TRUE_FALSE + DO_CONS: + T=6:L=B:M=A:GOSUB ALLOC + RETURN + DO_CONCAT: + REM always a list + R=6:GOSUB INC_REF_R + GOSUB PUSH_R: REM current value + GOSUB PUSH_R: REM return value + + DO_CONCAT_LOOP: + IF AR<16 THEN GOTO DO_CONCAT_DONE: REM no more elements + + REM slice/copy current element to a list + A=Z%(AR+2) + IF A<16 THEN GOTO DO_CONCAT_LOOP_NEXT: REM skip empty elements + B=0:C=-1:GOSUB SLICE + + GOSUB PEEK_Q: REM return value + REM if this is the first element, set return element + IF Q=6 THEN Q=R:GOSUB PUT_Q:GOTO DO_CONCAT_LOOP_AGAIN + REM otherwise Q<>6, so attach current to sliced + GOSUB PEEK_Q_1 + Z%(Q+1)=R + + DO_CONCAT_LOOP_AGAIN: + REM update current to end of sliced list + Q=R6:GOSUB PUT_Q_1 + REM dec empty since no longer part of slice + AY=6:GOSUB RELEASE + DO_CONCAT_LOOP_NEXT: + REM next list element + AR=Z%(AR+1) + GOTO DO_CONCAT_LOOP + + DO_CONCAT_DONE: + GOSUB POP_R: REM pop return value + GOSUB POP_Q: REM pop current + RETURN + DO_VEC: + T=7:GOTO FORCE_SEQ_TYPE + + DO_NTH: + B=B1 + GOSUB COUNT + IF R<=B THEN R=-1:ER=-1:E$="nth: index out of range":RETURN + DO_NTH_LOOP: + IF B=0 THEN GOTO DO_NTH_DONE + B=B-1 + A=Z%(A+1) + GOTO DO_NTH_LOOP + DO_NTH_DONE: + R=Z%(A+2) + GOTO INC_REF_R + DO_FIRST: + R=0 + IF A=0 THEN GOTO INC_REF_R + IF A1<>0 THEN R=Z%(A+2) + GOTO INC_REF_R + DO_REST: + IF A=0 THEN R=6:GOTO INC_REF_R + IF A1<>0 THEN A=A1: REM get the next sequence element + T=6:GOSUB FORCE_SEQ_TYPE + RETURN + DO_EMPTY_Q: + R=A1=0 + GOTO RETURN_TRUE_FALSE + DO_COUNT: + GOSUB COUNT + T=2:L=R:GOSUB ALLOC + RETURN + DO_CONJ: + R=0 + GOTO INC_REF_R + DO_SEQ: + R=0 + GOTO INC_REF_R + + DO_WITH_META: + GOSUB TYPE_A + REM remove existing metadata first + IF T=14 THEN A=A1:GOTO DO_WITH_META + T=14:L=A:M=B:GOSUB ALLOC + RETURN + DO_META: + R=0 + GOSUB TYPE_A + IF T=14 THEN R=Z%(A+2) + GOTO INC_REF_R + DO_ATOM: + T=12:L=A:GOSUB ALLOC + RETURN + DO_ATOM_Q: + GOSUB TYPE_A + R=T=12 + GOTO RETURN_TRUE_FALSE + DO_DEREF: + R=A1 + GOTO INC_REF_R + DO_RESET_BANG: + R=B + REM release current value + REM can't use A1 here because DO_RESET_BANG is called from swap! + AY=Z%(A+1):GOSUB RELEASE + REM inc ref by 2 for atom ownership and since we are returning it + Z%(R)=Z%(R)+64 + REM update value + Z%(A+1)=R + RETURN + + DO_EVAL: + Q=E:GOSUB PUSH_Q: REM push/save environment + E=D:CALL EVAL + GOSUB POP_Q:E=Q + RETURN + + DO_READ_FILE: + A$=S$(A1) + GOSUB READ_FILE + RETURN + + REM DO_PR_MEMORY: + REM P1=ZT:P2=-1:GOSUB PR_MEMORY + REM RETURN + DO_PR_MEMORY_SUMMARY: + REM GOSUB PR_MEMORY_SUMMARY + GOSUB PR_MEMORY_SUMMARY_SMALL + R=0 + GOTO INC_REF_R + RETURN + +INIT_CORE_SET_FUNCTION: + T=9:L=A:GOSUB ALLOC: REM native function + C=R:GOSUB ENV_SET_S + A=A+1 + RETURN + +REM INIT_CORE_NS(E) +INIT_CORE_NS: + REM create the environment mapping + REM must match DO_FUNCTION mappings + + A=1 + B$="=":GOSUB INIT_CORE_SET_FUNCTION: REM A=1 + B$="throw":GOSUB INIT_CORE_SET_FUNCTION: REM A=2 + B$="nil?":GOSUB INIT_CORE_SET_FUNCTION: REM A=3 + B$="true?":GOSUB INIT_CORE_SET_FUNCTION: REM A=4 + B$="false?":GOSUB INIT_CORE_SET_FUNCTION: REM A=5 + B$="string?":GOSUB INIT_CORE_SET_FUNCTION: REM A=6 + B$="symbol":GOSUB INIT_CORE_SET_FUNCTION: REM A=7 + B$="symbol?":GOSUB INIT_CORE_SET_FUNCTION: REM A=8 + B$="keyword":GOSUB INIT_CORE_SET_FUNCTION: REM A=9 + B$="keyword?":GOSUB INIT_CORE_SET_FUNCTION: REM A=10 + B$="number?":GOSUB INIT_CORE_SET_FUNCTION: REM A=11 + B$="fn?":GOSUB INIT_CORE_SET_FUNCTION: REM A=12 + B$="macro?":GOSUB INIT_CORE_SET_FUNCTION: REM A=13 + + B$="pr-str":GOSUB INIT_CORE_SET_FUNCTION: REM A=14 + B$="str":GOSUB INIT_CORE_SET_FUNCTION: REM A=15 + B$="prn":GOSUB INIT_CORE_SET_FUNCTION: REM A=16 + B$="println":GOSUB INIT_CORE_SET_FUNCTION: REM A=17 + B$="read-string":GOSUB INIT_CORE_SET_FUNCTION: REM A=18 + B$="readline":GOSUB INIT_CORE_SET_FUNCTION: REM A=19 + B$="slurp":GOSUB INIT_CORE_SET_FUNCTION: REM A=20 + + B$="<":GOSUB INIT_CORE_SET_FUNCTION: REM A=21 + B$="<=":GOSUB INIT_CORE_SET_FUNCTION: REM A=22 + B$=">":GOSUB INIT_CORE_SET_FUNCTION: REM A=23 + B$=">=":GOSUB INIT_CORE_SET_FUNCTION: REM A=24 + B$="+":GOSUB INIT_CORE_SET_FUNCTION: REM A=25 + B$="-":GOSUB INIT_CORE_SET_FUNCTION: REM A=26 + B$="*":GOSUB INIT_CORE_SET_FUNCTION: REM A=27 + B$="/":GOSUB INIT_CORE_SET_FUNCTION: REM A=28 + B$="time-ms":GOSUB INIT_CORE_SET_FUNCTION: REM A=29 + + B$="list":GOSUB INIT_CORE_SET_FUNCTION: REM A=30 + B$="list?":GOSUB INIT_CORE_SET_FUNCTION: REM A=31 + B$="vector":GOSUB INIT_CORE_SET_FUNCTION: REM A=32 + B$="vector?":GOSUB INIT_CORE_SET_FUNCTION: REM A=33 + B$="hash-map":GOSUB INIT_CORE_SET_FUNCTION: REM A=34 + B$="map?":GOSUB INIT_CORE_SET_FUNCTION: REM A=35 + B$="assoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=36 + B$="dissoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=37 + B$="get":GOSUB INIT_CORE_SET_FUNCTION: REM A=38 + B$="contains?":GOSUB INIT_CORE_SET_FUNCTION: REM A=39 + B$="keys":GOSUB INIT_CORE_SET_FUNCTION: REM A=40 + B$="vals":GOSUB INIT_CORE_SET_FUNCTION: REM A=41 + + B$="sequential?":GOSUB INIT_CORE_SET_FUNCTION: REM A=42 + B$="cons":GOSUB INIT_CORE_SET_FUNCTION: REM A=43 + B$="concat":GOSUB INIT_CORE_SET_FUNCTION: REM A=44 + B$="nth":GOSUB INIT_CORE_SET_FUNCTION: REM A=45 + B$="first":GOSUB INIT_CORE_SET_FUNCTION: REM A=46 + B$="rest":GOSUB INIT_CORE_SET_FUNCTION: REM A=47 + B$="empty?":GOSUB INIT_CORE_SET_FUNCTION: REM A=48 + B$="count":GOSUB INIT_CORE_SET_FUNCTION: REM A=49 + + B$="conj":GOSUB INIT_CORE_SET_FUNCTION: REM A=50 + B$="seq":GOSUB INIT_CORE_SET_FUNCTION: REM A=51 + + B$="with-meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=52 + B$="meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=53 + B$="atom":GOSUB INIT_CORE_SET_FUNCTION: REM A=54 + B$="atom?":GOSUB INIT_CORE_SET_FUNCTION: REM A=55 + B$="deref":GOSUB INIT_CORE_SET_FUNCTION: REM A=56 + B$="reset!":GOSUB INIT_CORE_SET_FUNCTION: REM A=57 + + B$="eval":GOSUB INIT_CORE_SET_FUNCTION: REM A=58 + B$="read-file":GOSUB INIT_CORE_SET_FUNCTION: REM A=59 + B$="vec":GOSUB INIT_CORE_SET_FUNCTION: REM A=60 + B$="pr-memory-summary":GOSUB INIT_CORE_SET_FUNCTION: REM A=61 + + REM these are in DO_TCO_FUNCTION + A=65 + B$="apply":GOSUB INIT_CORE_SET_FUNCTION: REM A=65 + B$="map":GOSUB INIT_CORE_SET_FUNCTION: REM A=66 + B$="swap!":GOSUB INIT_CORE_SET_FUNCTION: REM A=67 + + RETURN diff --git a/impls/basic/debug.in.bas b/impls/basic/debug.in.bas index 4d8b1ff297..1ef461afb2 100644 --- a/impls/basic/debug.in.bas +++ b/impls/basic/debug.in.bas @@ -1,220 +1,220 @@ -REM CHECK_FREE_LIST() -> P2 -CHECK_FREE_LIST: - REM start and accumulator - P1=ZK - P2=0 - CHECK_FREE_LIST_LOOP: - IF P1>=ZI THEN RETURN - REM MEMORY DEBUGGING: - REM IF (Z%(P1)AND 31)<>15 THEN PRINT "corrupt free:"+STR$(P1):END - P2=P2+(Z%(P1)AND-32)/32 - P1=Z%(P1+1) - GOTO CHECK_FREE_LIST_LOOP - -PR_MEMORY_SUMMARY_SMALL: - #cbm P0=FRE(0) - - GOSUB CHECK_FREE_LIST - #cbm PRINT "Free:"+STR$(FRE(0))+", "; - PRINT "Values:"+STR$(ZI-1-P2)+", Emptys:"; - FOR P=0 TO 4 STEP 2:GOSUB PR_MEMORY_SUMMARY_SMALL_1:NEXT P - FOR P=6 TO 12 STEP 3:GOSUB PR_MEMORY_SUMMARY_SMALL_1:NEXT P - PRINT - RETURN - PR_MEMORY_SUMMARY_SMALL_1: - PRINT STR$(INT(Z%(P)/32))+","; - RETURN - -REM REM COUNT_STRINGS() -> P2 -REM COUNT_STRINGS: -REM P1=0 -REM P2=0 -REM COUNT_STRINGS_LOOP: -REM IF P1>S-1 THEN RETURN -REM IF S%(P1)>0 THEN P2=P2+1 -REM P1=P1+1 -REM GOTO COUNT_STRINGS_LOOP -REM -REM PR_MEMORY_SUMMARY: -REM #cbm P0=FRE(0) -REM -REM PRINT -REM #cbm PRINT "Free (FRE) :"+STR$(P0) -REM GOSUB CHECK_FREE_LIST: REM get count in P2 -REM PRINT "Values (Z%) :"+STR$(ZI-1-P2)+" /"+STR$(Z1) -REM REM PRINT " max:"+STR$(ZI-1); -REM REM PRINT ", freed:"+STR$(P2)+", after repl_env:"+STR$(ZT) -REM GOSUB COUNT_STRINGS -REM PRINT "Strings (S$) :"+STR$(P2)+" /"+STR$(Z2) -REM #qbasic PRINT "Stack (X%) :"+STR$(X+1)+" /"+STR$(Z3) -REM #cbm PRINT "Stack :"+STR$(X+2-Z3)+" / 1920" -REM RETURN -REM -REM #cbm PR_MEMORY_MAP: -REM #cbm PRINT -REM #cbm P1=PEEK(43)+PEEK(44)*256 -REM #cbm P2=PEEK(45)+PEEK(46)*256 -REM #cbm P3=PEEK(47)+PEEK(48)*256 -REM #cbm P4=PEEK(49)+PEEK(50)*256 -REM #cbm P5=PEEK(51)+PEEK(52)*256 -REM #cbm P6=PEEK(53)+PEEK(54)*256 -REM #cbm P7=PEEK(55)+PEEK(56)*256 -REM #cbm PRINT "BASIC beg. :"STR$(P1) -REM #cbm PRINT "Variable beg.:"STR$(P2) -REM #cbm PRINT "Array beg. :"STR$(P3) -REM #cbm PRINT "Array end :"STR$(P4) -REM #cbm PRINT "String beg. :"STR$(P5) -REM #cbm PRINT "String cur. :"STR$(P6) -REM #cbm PRINT "BASIC end :"STR$(P7) -REM #cbm PRINT -REM #cbm PRINT "Program Code :"STR$(P2-P1) -REM #cbm PRINT "Variables :"STR$(P3-P2) -REM #cbm PRINT "Arrays :"STR$(P4-P3) -REM #cbm PRINT "String Heap :"STR$(P7-P5) -REM #cbm RETURN -REM -REM REM PR_MEMORY_VALUE(I) -> J: -REM REM - I is memory value to print -REM REM - I is returned as last byte of value printed -REM REM - J is returned as type -REM PR_MEMORY_VALUE: -REM J=Z%(I)AND 31 -REM P3=Z%(I+1) -REM PRINT " "+STR$(I)+": type:"+STR$(J); -REM IF J<>15 THEN PRINT ", refs:"+STR$((Z%(I)-J)/32); -REM IF J=15 THEN PRINT ", size:"+STR$((Z%(I)AND-32)/32); -REM PRINT ", ["+STR$(Z%(I));+" |"+STR$(P3); -REM IF J<6 OR J=9 OR J=12 OR J=15 THEN PRINT " | --- | --- ]";:GOTO PR_MEM_SKIP -REM PRINT " |"+STR$(Z%(I+2)); -REM IF J=6 OR J=7 OR J=13 OR J=14 THEN PRINT " | --- ]";:GOTO PR_MEM_SKIP -REM PRINT " |"+STR$(Z%(I+3))+" ]"; -REM PR_MEM_SKIP: -REM PRINT " >> "; -REM ON J+1 GOTO PR_ENTRY_NIL,PR_ENTRY_BOOL,PR_ENTRY_INT,PR_ENTRY_FLOAT,PR_ENTRY_STR,PR_ENTRY_SYM,PR_ENTRY_LIST,PR_ENTRY_VECTOR,PR_ENTRY_HASH_MAP,PR_ENTRY_FN,PR_ENTRY_MALFN,PR_ENTRY_MAC,PR_ENTRY_ATOM,PR_ENTRY_ENV,PR_ENTRY_META,PR_ENTRY_FREE -REM PRINT "Unknown type:"+STR$(J):END -REM -REM PR_ENTRY_NIL: -REM PRINT "nil" -REM I=I+1 -REM RETURN -REM PR_ENTRY_BOOL: -REM IF P3=0 THEN PRINT "false" -REM IF P3=1 THEN PRINT "true" -REM I=I+1 -REM RETURN -REM PR_ENTRY_INT: -REM PR_ENTRY_FLOAT: -REM PRINT STR$(P3) -REM I=I+1 -REM RETURN -REM PR_ENTRY_STR: -REM PRINT "'"+S$(P3)+"'" -REM I=I+1 -REM RETURN -REM PR_ENTRY_SYM: -REM PRINT S$(P3) -REM I=I+1 -REM RETURN -REM PR_ENTRY_LIST: -REM I=I+2 -REM IF I<16 THEN PRINT "()":RETURN -REM PRINT "(..."+STR$(Z%(I))+" ...)" -REM RETURN -REM PR_ENTRY_VECTOR: -REM I=I+2 -REM IF I<16 THEN PRINT "[]":RETURN -REM PRINT "[..."+STR$(Z%(I))+" ...]" -REM RETURN -REM PR_ENTRY_HASH_MAP: -REM I=I+3 -REM IF I<16 THEN PRINT "{}":RETURN -REM IF J=8 THEN PRINT "{... key:"+STR$(Z%(I-1))+", val:"+STR$(Z%(I))+" ...}" -REM RETURN -REM PR_ENTRY_FN: -REM PRINT "#" -REM I=I+1 -REM RETURN -REM PR_ENTRY_MALFN: -REM PR_ENTRY_MAC: -REM IF I=11 THEN PRINT "MACRO "; -REM PRINT "(fn* param:"+STR$(Z%(I))+", env:"+STR$(Z%(I+1))+")" -REM I=I+3 -REM RETURN -REM PR_ENTRY_ATOM: -REM PRINT "(atom val:"+STR$(P3)+")" -REM I=I+1 -REM RETURN -REM PR_ENTRY_ENV: -REM PRINT "#" -REM I=I+2 -REM RETURN -REM PR_ENTRY_META: -REM PRINT "#" -REM I=I+2 -REM RETURN -REM PR_ENTRY_FREE: -REM PRINT "FREE next:"+STR$(P3); -REM IF I=ZK THEN PRINT " (free list start)"; -REM PRINT -REM I=I-1+(Z%(I)AND-32)/32 -REM RETURN -REM -REM REM PR_OBJECT(P1) -> nil -REM PR_OBJECT: -REM RD=0 -REM -REM IF P1=-1 THEN PRINT " "+STR$(-1)+": ---":RETURN -REM RD=RD+1 -REM Q=P1:GOSUB PUSH_Q -REM -REM PR_OBJ_LOOP: -REM IF RD=0 THEN RETURN -REM RD=RD-1 -REM -REM GOSUB PEEK_Q:I=Q -REM REM IF I<15 THEN GOSUB POP_Q:GOTO PR_OBJ_LOOP -REM GOSUB PR_MEMORY_VALUE -REM REM J holds type now -REM GOSUB POP_Q:I=Q -REM -REM IF J<6 OR J=9 THEN GOTO PR_OBJ_LOOP: REM no contained references -REM REM reference in first position -REM IF Z%(I+1)<>0 THEN RD=RD+1:Q=Z%(I+1):GOSUB PUSH_Q -REM IF J=12 OR J=15 THEN PR_OBJ_LOOP: REM no more reference -REM REM reference in second position -REM IF Z%(I+2)<>0 THEN RD=RD+1:Q=Z%(I+2):GOSUB PUSH_Q -REM IF J=6 OR J=7 OR J=13 OR J=14 THEN PR_OBJ_LOOP: REM no more references -REM IF Z%(I+3)<>0 THEN RD=RD+1:Q=Z%(I+3):GOSUB PUSH_Q -REM GOTO PR_OBJ_LOOP -REM -REM REM PR_MEMORY(P1, P2) -> nil -REM PR_MEMORY: -REM IF P2"+STR$(P2); -REM PRINT " (ZI: "+STR$(ZI)+", ZK: "+STR$(ZK)+"):" -REM IF P2P2 THEN GOTO PR_MEMORY_AFTER_VALUES -REM GOSUB PR_MEMORY_VALUE -REM I=I+1 -REM GOTO PR_MEMORY_VALUE_LOOP -REM PR_MEMORY_AFTER_VALUES: -REM PRINT "S$ String Memory (S: "+STR$(S)+"):" -REM IF S<=0 THEN PRINT " ---":GOTO PR_MEMORY_SKIP_STRINGS -REM FOR I=0 TO S-1 -REM PRINT " "+STR$(I)+": '"+S$(I)+"'" -REM NEXT I -REM PR_MEMORY_SKIP_STRINGS: -REM PRINT "X% Stack Memory (X: "+STR$(X)+"):" -REM #cbm IF X P2 +CHECK_FREE_LIST: + REM start and accumulator + P1=ZK + P2=0 + CHECK_FREE_LIST_LOOP: + IF P1>=ZI THEN RETURN + REM MEMORY DEBUGGING: + REM IF (Z%(P1)AND 31)<>15 THEN PRINT "corrupt free:"+STR$(P1):END + P2=P2+(Z%(P1)AND-32)/32 + P1=Z%(P1+1) + GOTO CHECK_FREE_LIST_LOOP + +PR_MEMORY_SUMMARY_SMALL: + #cbm P0=FRE(0) + + GOSUB CHECK_FREE_LIST + #cbm PRINT "Free:"+STR$(FRE(0))+", "; + PRINT "Values:"+STR$(ZI-1-P2)+", Emptys:"; + FOR P=0 TO 4 STEP 2:GOSUB PR_MEMORY_SUMMARY_SMALL_1:NEXT P + FOR P=6 TO 12 STEP 3:GOSUB PR_MEMORY_SUMMARY_SMALL_1:NEXT P + PRINT + RETURN + PR_MEMORY_SUMMARY_SMALL_1: + PRINT STR$(INT(Z%(P)/32))+","; + RETURN + +REM REM COUNT_STRINGS() -> P2 +REM COUNT_STRINGS: +REM P1=0 +REM P2=0 +REM COUNT_STRINGS_LOOP: +REM IF P1>S-1 THEN RETURN +REM IF S%(P1)>0 THEN P2=P2+1 +REM P1=P1+1 +REM GOTO COUNT_STRINGS_LOOP +REM +REM PR_MEMORY_SUMMARY: +REM #cbm P0=FRE(0) +REM +REM PRINT +REM #cbm PRINT "Free (FRE) :"+STR$(P0) +REM GOSUB CHECK_FREE_LIST: REM get count in P2 +REM PRINT "Values (Z%) :"+STR$(ZI-1-P2)+" /"+STR$(Z1) +REM REM PRINT " max:"+STR$(ZI-1); +REM REM PRINT ", freed:"+STR$(P2)+", after repl_env:"+STR$(ZT) +REM GOSUB COUNT_STRINGS +REM PRINT "Strings (S$) :"+STR$(P2)+" /"+STR$(Z2) +REM #qbasic PRINT "Stack (X%) :"+STR$(X+1)+" /"+STR$(Z3) +REM #cbm PRINT "Stack :"+STR$(X+2-Z3)+" / 1920" +REM RETURN +REM +REM #cbm PR_MEMORY_MAP: +REM #cbm PRINT +REM #cbm P1=PEEK(43)+PEEK(44)*256 +REM #cbm P2=PEEK(45)+PEEK(46)*256 +REM #cbm P3=PEEK(47)+PEEK(48)*256 +REM #cbm P4=PEEK(49)+PEEK(50)*256 +REM #cbm P5=PEEK(51)+PEEK(52)*256 +REM #cbm P6=PEEK(53)+PEEK(54)*256 +REM #cbm P7=PEEK(55)+PEEK(56)*256 +REM #cbm PRINT "BASIC beg. :"STR$(P1) +REM #cbm PRINT "Variable beg.:"STR$(P2) +REM #cbm PRINT "Array beg. :"STR$(P3) +REM #cbm PRINT "Array end :"STR$(P4) +REM #cbm PRINT "String beg. :"STR$(P5) +REM #cbm PRINT "String cur. :"STR$(P6) +REM #cbm PRINT "BASIC end :"STR$(P7) +REM #cbm PRINT +REM #cbm PRINT "Program Code :"STR$(P2-P1) +REM #cbm PRINT "Variables :"STR$(P3-P2) +REM #cbm PRINT "Arrays :"STR$(P4-P3) +REM #cbm PRINT "String Heap :"STR$(P7-P5) +REM #cbm RETURN +REM +REM REM PR_MEMORY_VALUE(I) -> J: +REM REM - I is memory value to print +REM REM - I is returned as last byte of value printed +REM REM - J is returned as type +REM PR_MEMORY_VALUE: +REM J=Z%(I)AND 31 +REM P3=Z%(I+1) +REM PRINT " "+STR$(I)+": type:"+STR$(J); +REM IF J<>15 THEN PRINT ", refs:"+STR$((Z%(I)-J)/32); +REM IF J=15 THEN PRINT ", size:"+STR$((Z%(I)AND-32)/32); +REM PRINT ", ["+STR$(Z%(I));+" |"+STR$(P3); +REM IF J<6 OR J=9 OR J=12 OR J=15 THEN PRINT " | --- | --- ]";:GOTO PR_MEM_SKIP +REM PRINT " |"+STR$(Z%(I+2)); +REM IF J=6 OR J=7 OR J=13 OR J=14 THEN PRINT " | --- ]";:GOTO PR_MEM_SKIP +REM PRINT " |"+STR$(Z%(I+3))+" ]"; +REM PR_MEM_SKIP: +REM PRINT " >> "; +REM ON J+1 GOTO PR_ENTRY_NIL,PR_ENTRY_BOOL,PR_ENTRY_INT,PR_ENTRY_FLOAT,PR_ENTRY_STR,PR_ENTRY_SYM,PR_ENTRY_LIST,PR_ENTRY_VECTOR,PR_ENTRY_HASH_MAP,PR_ENTRY_FN,PR_ENTRY_MALFN,PR_ENTRY_MAC,PR_ENTRY_ATOM,PR_ENTRY_ENV,PR_ENTRY_META,PR_ENTRY_FREE +REM PRINT "Unknown type:"+STR$(J):END +REM +REM PR_ENTRY_NIL: +REM PRINT "nil" +REM I=I+1 +REM RETURN +REM PR_ENTRY_BOOL: +REM IF P3=0 THEN PRINT "false" +REM IF P3=1 THEN PRINT "true" +REM I=I+1 +REM RETURN +REM PR_ENTRY_INT: +REM PR_ENTRY_FLOAT: +REM PRINT STR$(P3) +REM I=I+1 +REM RETURN +REM PR_ENTRY_STR: +REM PRINT "'"+S$(P3)+"'" +REM I=I+1 +REM RETURN +REM PR_ENTRY_SYM: +REM PRINT S$(P3) +REM I=I+1 +REM RETURN +REM PR_ENTRY_LIST: +REM I=I+2 +REM IF I<16 THEN PRINT "()":RETURN +REM PRINT "(..."+STR$(Z%(I))+" ...)" +REM RETURN +REM PR_ENTRY_VECTOR: +REM I=I+2 +REM IF I<16 THEN PRINT "[]":RETURN +REM PRINT "[..."+STR$(Z%(I))+" ...]" +REM RETURN +REM PR_ENTRY_HASH_MAP: +REM I=I+3 +REM IF I<16 THEN PRINT "{}":RETURN +REM IF J=8 THEN PRINT "{... key:"+STR$(Z%(I-1))+", val:"+STR$(Z%(I))+" ...}" +REM RETURN +REM PR_ENTRY_FN: +REM PRINT "#" +REM I=I+1 +REM RETURN +REM PR_ENTRY_MALFN: +REM PR_ENTRY_MAC: +REM IF I=11 THEN PRINT "MACRO "; +REM PRINT "(fn* param:"+STR$(Z%(I))+", env:"+STR$(Z%(I+1))+")" +REM I=I+3 +REM RETURN +REM PR_ENTRY_ATOM: +REM PRINT "(atom val:"+STR$(P3)+")" +REM I=I+1 +REM RETURN +REM PR_ENTRY_ENV: +REM PRINT "#" +REM I=I+2 +REM RETURN +REM PR_ENTRY_META: +REM PRINT "#" +REM I=I+2 +REM RETURN +REM PR_ENTRY_FREE: +REM PRINT "FREE next:"+STR$(P3); +REM IF I=ZK THEN PRINT " (free list start)"; +REM PRINT +REM I=I-1+(Z%(I)AND-32)/32 +REM RETURN +REM +REM REM PR_OBJECT(P1) -> nil +REM PR_OBJECT: +REM RD=0 +REM +REM IF P1=-1 THEN PRINT " "+STR$(-1)+": ---":RETURN +REM RD=RD+1 +REM Q=P1:GOSUB PUSH_Q +REM +REM PR_OBJ_LOOP: +REM IF RD=0 THEN RETURN +REM RD=RD-1 +REM +REM GOSUB PEEK_Q:I=Q +REM REM IF I<15 THEN GOSUB POP_Q:GOTO PR_OBJ_LOOP +REM GOSUB PR_MEMORY_VALUE +REM REM J holds type now +REM GOSUB POP_Q:I=Q +REM +REM IF J<6 OR J=9 THEN GOTO PR_OBJ_LOOP: REM no contained references +REM REM reference in first position +REM IF Z%(I+1)<>0 THEN RD=RD+1:Q=Z%(I+1):GOSUB PUSH_Q +REM IF J=12 OR J=15 THEN PR_OBJ_LOOP: REM no more reference +REM REM reference in second position +REM IF Z%(I+2)<>0 THEN RD=RD+1:Q=Z%(I+2):GOSUB PUSH_Q +REM IF J=6 OR J=7 OR J=13 OR J=14 THEN PR_OBJ_LOOP: REM no more references +REM IF Z%(I+3)<>0 THEN RD=RD+1:Q=Z%(I+3):GOSUB PUSH_Q +REM GOTO PR_OBJ_LOOP +REM +REM REM PR_MEMORY(P1, P2) -> nil +REM PR_MEMORY: +REM IF P2"+STR$(P2); +REM PRINT " (ZI: "+STR$(ZI)+", ZK: "+STR$(ZK)+"):" +REM IF P2P2 THEN GOTO PR_MEMORY_AFTER_VALUES +REM GOSUB PR_MEMORY_VALUE +REM I=I+1 +REM GOTO PR_MEMORY_VALUE_LOOP +REM PR_MEMORY_AFTER_VALUES: +REM PRINT "S$ String Memory (S: "+STR$(S)+"):" +REM IF S<=0 THEN PRINT " ---":GOTO PR_MEMORY_SKIP_STRINGS +REM FOR I=0 TO S-1 +REM PRINT " "+STR$(I)+": '"+S$(I)+"'" +REM NEXT I +REM PR_MEMORY_SKIP_STRINGS: +REM PRINT "X% Stack Memory (X: "+STR$(X)+"):" +REM #cbm IF X R -ENV_NEW: - REM allocate the data hashmap - GOSUB HASHMAP - AY=R - - REM set the outer and data pointer - T=13:L=R:M=C:GOSUB ALLOC - GOSUB RELEASE: REM environment takes ownership - RETURN - -REM see RELEASE types.in.bas for environment cleanup - -REM ENV_NEW_BINDS(C, A, B) -> R -ENV_NEW_BINDS: - GOSUB ENV_NEW - E=R - REM process bindings - ENV_NEW_BINDS_LOOP: - IF Z%(A+1)=0 THEN R=E:RETURN - REM get/deref the key from A - K=Z%(A+2) - - IF S$(Z%(K+1))="&" THEN GOTO EVAL_NEW_BINDS_VARGS - - EVAL_NEW_BINDS_1x1: - REM get/deref the key from B - C=Z%(B+2) - REM set the binding in the environment data - GOSUB ENV_SET - REM go to next element of A and B - A=Z%(A+1) - B=Z%(B+1) - GOTO ENV_NEW_BINDS_LOOP - - EVAL_NEW_BINDS_VARGS: - REM get/deref the key from next element of A - A=Z%(A+1) - K=Z%(A+2) - REM the value is the remaining list in B - A=B:T=6:GOSUB FORCE_SEQ_TYPE - C=R - REM set the binding in the environment data - GOSUB ENV_SET - R=E - AY=C:GOSUB RELEASE: REM list is owned by environment - RETURN - -REM ENV_SET(E, K, C) -> R -ENV_SET: - H=Z%(E+1) - GOSUB ASSOC1 - Z%(E+1)=R - R=C - RETURN - -REM ENV_SET_S(E, B$, C) -> R -ENV_SET_S: - H=Z%(E+1) - GOSUB ASSOC1_S - Z%(E+1)=R - R=C - RETURN - -REM ENV_FIND(E, K) -> R -REM Returns environment (R) containing K. If found, value found is -REM in R4 -SUB ENV_FIND - T=E - ENV_FIND_LOOP: - H=Z%(T+1) - REM More efficient to use GET for value (R) and contains? (R3) - GOSUB HASHMAP_GET - REM if we found it, save value in R4 for ENV_GET - IF R3=1 THEN R4=R:R=T:GOTO ENV_FIND_DONE - T=Z%(T+2): REM get outer environment - IF T>0 THEN GOTO ENV_FIND_LOOP - R=-1 - ENV_FIND_DONE: -END SUB - -REM ENV_GET(E, K) -> R -ENV_GET: - CALL ENV_FIND - IF R=-1 THEN ER=-1:E$="'"+S$(Z%(K+1))+"' not found":GOTO ENV_GET_RETURN - R=R4 - GOSUB INC_REF_R - GOTO ENV_GET_RETURN + +REM ENV_NEW(C) -> R +ENV_NEW: + REM allocate the data hashmap + GOSUB HASHMAP + AY=R + + REM set the outer and data pointer + T=13:L=R:M=C:GOSUB ALLOC + GOSUB RELEASE: REM environment takes ownership + RETURN + +REM see RELEASE types.in.bas for environment cleanup + +REM ENV_NEW_BINDS(C, A, B) -> R +ENV_NEW_BINDS: + GOSUB ENV_NEW + E=R + REM process bindings + ENV_NEW_BINDS_LOOP: + IF Z%(A+1)=0 THEN R=E:RETURN + REM get/deref the key from A + K=Z%(A+2) + + IF S$(Z%(K+1))="&" THEN GOTO EVAL_NEW_BINDS_VARGS + + EVAL_NEW_BINDS_1x1: + REM get/deref the key from B + C=Z%(B+2) + REM set the binding in the environment data + GOSUB ENV_SET + REM go to next element of A and B + A=Z%(A+1) + B=Z%(B+1) + GOTO ENV_NEW_BINDS_LOOP + + EVAL_NEW_BINDS_VARGS: + REM get/deref the key from next element of A + A=Z%(A+1) + K=Z%(A+2) + REM the value is the remaining list in B + A=B:T=6:GOSUB FORCE_SEQ_TYPE + C=R + REM set the binding in the environment data + GOSUB ENV_SET + R=E + AY=C:GOSUB RELEASE: REM list is owned by environment + RETURN + +REM ENV_SET(E, K, C) -> R +ENV_SET: + H=Z%(E+1) + GOSUB ASSOC1 + Z%(E+1)=R + R=C + RETURN + +REM ENV_SET_S(E, B$, C) -> R +ENV_SET_S: + H=Z%(E+1) + GOSUB ASSOC1_S + Z%(E+1)=R + R=C + RETURN + +REM ENV_FIND(E, K) -> R +REM Returns environment (R) containing K. If found, value found is +REM in R4 +SUB ENV_FIND + T=E + ENV_FIND_LOOP: + H=Z%(T+1) + REM More efficient to use GET for value (R) and contains? (R3) + GOSUB HASHMAP_GET + REM if we found it, save value in R4 for ENV_GET + IF R3=1 THEN R4=R:R=T:GOTO ENV_FIND_DONE + T=Z%(T+2): REM get outer environment + IF T>0 THEN GOTO ENV_FIND_LOOP + R=-1 + ENV_FIND_DONE: +END SUB + +REM ENV_GET(E, K) -> R +ENV_GET: + CALL ENV_FIND + IF R=-1 THEN ER=-1:E$="'"+S$(Z%(K+1))+"' not found":GOTO ENV_GET_RETURN + R=R4 + GOSUB INC_REF_R + GOTO ENV_GET_RETURN diff --git a/impls/basic/mem.in.bas b/impls/basic/mem.in.bas index d4a6d54570..fa9d2c8339 100644 --- a/impls/basic/mem.in.bas +++ b/impls/basic/mem.in.bas @@ -1,391 +1,391 @@ -REM Memory layout: -REM -REM type bytes -REM ---------- ---------- -REM nil ref/ 0 | 0 | | -REM false ref/ 1 | 0 | | -REM true ref/ 1 | 1 | | -REM integer ref/ 2 | int | | -REM float ref/ 3 | ??? | | -REM string/kw ref/ 4 | S$ idx | | -REM symbol ref/ 5 | S$ idx | | -REM list ref/ 6 | next Z% idx | val Z% idx | -REM vector ref/ 7 | next Z% idx | val Z% idx | -REM hashmap ref/ 8 | next Z% idx | key Z% idx | val Z% idx -REM function ref/ 9 | fn idx | | -REM mal function ref/10 | body Z% idx | param Z% idx | env Z% idx -REM macro fn ref/11 | body Z% idx | param Z% idx | env Z% idx -REM atom ref/12 | val Z% idx | | -REM environment ref/13 | hmap Z% idx | outer Z% idx | -REM metadata ref/14 | obj Z% idx | meta Z% idx | -REM FREE sz/15 | next Z% idx | | -REM -REM Locations 0-15 are for constant/persistent values: -REM 0: nil -REM 2: false -REM 4: true -REM 6: empty list -REM 9: empty vector -REM 12: empty hash-map - -REM Note: DIM_MEMORY for C64 BASIC and the INIT_MEMORY function are at -REM end of this file for efficiency on C64. The most commonly used -REM function should be at the top since C64 BASIC scans line numbers -REM for every GOTO/GOSUB. On the other hand, QBasic requires that -REM arrays are dimensioned at the top of the file, not just as the -REM first operation on that array so DIM_MEMORY for QBasic is here at -REM the top. - -#qbasic DIM_MEMORY: -#qbasic T=0 -#qbasic -#qbasic Z1=8191+1424: REM Z% (boxed memory) size (2 bytes each) -#qbasic Z2=199: REM S$/S% (string memory) size (3+2 bytes each) -#qbasic Z3=200: REM X% (call stack) size (2 bytes each) -#qbasic Z4=64: REM Y% (release stack) size (4 bytes each) -#qbasic -#qbasic REM boxed element memory -#qbasic DIM Z%(Z1): REM TYPE ARRAY -#qbasic -#qbasic REM string memory storage -#qbasic S=0:DIM S$(Z2):DIM S%(Z2) -#qbasic -#qbasic REM call/logic stack -#qbasic X=-1:DIM X%(Z3): REM stack of Z% indexes -#qbasic -#qbasic REM pending release stack -#qbasic Y=-1:DIM Y%(Z4,1): REM stack of Z% indexes and level/LV values -#qbasic -#qbasic RETURN - -REM stack functions - -#qbasic PUSH_A: -#qbasic X=X+1:X%(X)=A:RETURN -#qbasic POP_A: -#qbasic A=X%(X):X=X-1:RETURN -#qbasic -#qbasic PUSH_R: -#qbasic X=X+1:X%(X)=R:RETURN -#qbasic POP_R: -#qbasic R=X%(X):X=X-1:RETURN -#qbasic -#qbasic PUSH_Q: -#qbasic X=X+1:X%(X)=Q:RETURN -#qbasic POP_Q: -#qbasic Q=X%(X):X=X-1:RETURN -#qbasic PEEK_Q: -#qbasic Q=X%(X):RETURN -#qbasic PEEK_Q_1: -#qbasic Q=X%(X-1):RETURN -#qbasic PEEK_Q_2: -#qbasic Q=X%(X-2):RETURN -#qbasic PEEK_Q_Q: -#qbasic Q=X%(X-Q):RETURN -#qbasic PUT_Q: -#qbasic X%(X)=Q:RETURN -#qbasic PUT_Q_1: -#qbasic X%(X-1)=Q:RETURN -#qbasic PUT_Q_2: -#qbasic X%(X-2)=Q:RETURN - -#cbm PUSH_A: -#cbm X=X+2:POKE X,A AND255:POKE X+1,A/256:RETURN -#cbm POP_A: -#cbm A=PEEK(X)+PEEK(X+1)*256:X=X-2:RETURN -#cbm -#cbm PUSH_R: -#cbm X=X+2:POKE X,R AND255:POKE X+1,R/256:RETURN -#cbm POP_R: -#cbm R=PEEK(X)+PEEK(X+1)*256:X=X-2:RETURN -#cbm -#cbm PUSH_Q: -#cbm X=X+2:POKE X,Q AND255:POKE X+1,Q/256:RETURN -#cbm POP_Q: -#cbm Q=PEEK(X)+PEEK(X+1)*256:X=X-2:RETURN -#cbm PEEK_Q: -#cbm Q=PEEK(X)+PEEK(X+1)*256:RETURN -#cbm PEEK_Q_1: -#cbm Q=PEEK(X-2)+PEEK(X-1)*256:RETURN -#cbm PEEK_Q_2: -#cbm Q=PEEK(X-4)+PEEK(X-3)*256:RETURN -#cbm PEEK_Q_Q: -#cbm Q=PEEK(X-Q*2)+PEEK(X-Q*2+1)*256:RETURN -#cbm PUT_Q: -#cbm POKE X,Q AND255:POKE X+1,Q/256:RETURN -#cbm PUT_Q_1: -#cbm POKE X-2,Q AND255:POKE X-1,Q/256:RETURN -#cbm PUT_Q_2: -#cbm POKE X-4,Q AND255:POKE X-3,Q/256:RETURN - -REM memory functions - -REM ALLOC(T,L) -> R -REM ALLOC(T,L,M) -> R -REM ALLOC(T,L,M,N) -> R -REM L is value for Z%(R+1) -REM M is value for Z%(R+2), if SZ>2 -REM N is value for Z%(R+3), if SZ>3 -ALLOC: - SZ=3 - IF T<6 OR T=9 OR T=12 THEN SZ=2 - IF T=8 OR T=10 OR T=11 THEN SZ=4 - REM PRINT "ALLOC T: "+STR$(T)+", SZ: "+STR$(SZ)+", ZK: "+STR$(ZK) - U=ZK - R=ZK - ALLOC_LOOP: - IF R=ZI THEN GOTO ALLOC_UNUSED - REM TODO sanity check that type is 15 - IF ((Z%(R)AND-32)/32)=SZ THEN GOTO ALLOC_MIDDLE - REM PRINT "ALLOC search: U: "+STR$(U)+", R: "+STR$(R) - U=R: REM previous set to current - R=Z%(R+1): REM current set to next - GOTO ALLOC_LOOP - ALLOC_MIDDLE: - REM PRINT "ALLOC_MIDDLE: U: "+STR$(U)+", R: "+STR$(R) - REM set free pointer (ZK) to next free - IF R=ZK THEN ZK=Z%(R+1) - REM set previous free to next free - IF R<>ZK THEN Z%(U+1)=Z%(R+1) - GOTO ALLOC_DONE - ALLOC_UNUSED: - REM PRINT "ALLOC_UNUSED ZI: "+STR$(ZI)+", U: "+STR$(U)+", R: "+STR$(R) - IF R+SZ>Z1 THEN GOSUB PR_MEMORY_SUMMARY_SMALL:PRINT "Out of mal memory!":END - ZI=ZI+SZ - IF U=R THEN ZK=ZI - REM set previous free to new memory top - IF U<>R THEN Z%(U+1)=ZI - GOTO ALLOC_DONE - ALLOC_DONE: - Z%(R)=T+32 - REM set Z%(R+1) to default L - Z%(R+1)=L - IF T>5 AND T<>9 THEN Z%(L)=Z%(L)+32: REM value is a Z% idx - IF SZ>2 THEN Z%(M)=Z%(M)+32:Z%(R+2)=M - IF SZ>3 THEN Z%(N)=Z%(N)+32:Z%(R+3)=N - - RETURN - -REM FREE(AY, SZ) -> nil -FREE: - REM assumes reference count cleanup already (see RELEASE) - Z%(AY)=(SZ*32)+15: REM set type(15) and size - Z%(AY+1)=ZK - ZK=AY - IF SZ>=3 THEN Z%(AY+2)=0 - IF SZ=4 THEN Z%(AY+3)=0 - REM TODO: fail if SZ>4 - RETURN - - -REM RELEASE(AY) -> nil -REM R should not be affected by this call -RELEASE: - RC=0 - - GOTO RELEASE_ONE - - RELEASE_TOP: - - IF RC=0 THEN RETURN - - REM pop next object to release, decrease remaining count - GOSUB POP_Q:AY=Q - RC=RC-1 - - RELEASE_ONE: - IF AY=-1 THEN RETURN - - U=Z%(AY)AND 31: REM type - V=Z%(AY+1): REM main value/reference - - REM set the size - REM TODO: share with ALLOC calculation - SZ=3 - IF U<6 OR U=9 OR U=12 THEN SZ=2 - IF U=8 OR U=10 OR U=11 THEN SZ=4 - - REM AZ=AY: B=1: GOSUB PR_STR - REM PRINT "RELEASE AY:"+STR$(AY)+" ["+R$+"] (byte0:"+STR$(Z%(AY))+", SZ:"+STR$(SZ)+")" - - REM sanity check not already freed - REM MEMORY DEBUGGING: - REM IF U=15 THEN PRINT "RELEASE of free:"+STR$(AY):END - REM IF Z%(AY)<15 THEN PRINT "RELEASE of unowned:"+STR$(AY):END - - REM decrease reference count by one - Z%(AY)=Z%(AY)-32 - - REM nil, false, true, empty sequences - REM MEMORY DEBUGGING: - REM IF AY<16 AND Z%(AY)<32 THEN PRINT "RELEASE of empty:"+STR$(AY):END - IF AY<16 THEN GOTO RELEASE_TOP - - REM our reference count is not 0, so don't release - IF Z%(AY)>=32 GOTO RELEASE_TOP - - REM switch on type - ON U+1 GOSUB RELEASE_SIMPLE,RELEASE_SIMPLE,RELEASE_SIMPLE,RELEASE_SIMPLE,RELEASE_STRING,RELEASE_STRING,RELEASE_SEQ,RELEASE_SEQ,RELEASE_HASH_MAP,RELEASE_SIMPLE,RELEASE_MAL_FUNCTION,RELEASE_MAL_FUNCTION,RELEASE_ATOM,RELEASE_ENV,RELEASE_METADATA - - REM free the current element and continue, SZ already set - GOSUB FREE - GOTO RELEASE_TOP - - RELEASE_SIMPLE: - RETURN - RELEASE_STRING: - REM string type, release interned string, then FREE reference - REM MEMORY DEBUGGING: - REM IF S%(V)=0 THEN PRINT "RELEASE of free string:"+STR$(S%(V)):END - S%(V)=S%(V)-1 - IF S%(V)=0 THEN S$(V)="": REM free BASIC string - REM free the atom itself - RETURN - RELEASE_SEQ: - IF V=0 THEN RETURN - REM add value and next element to stack - RC=RC+2 - Q=Z%(AY+2):GOSUB PUSH_Q - Q=V:GOSUB PUSH_Q - RETURN - RELEASE_HASH_MAP: - IF V=0 THEN RETURN - REM add key, value and next element to stack - RC=RC+3 - Q=Z%(AY+2):GOSUB PUSH_Q - Q=Z%(AY+3):GOSUB PUSH_Q - Q=V:GOSUB PUSH_Q - RETURN - RELEASE_ATOM: - REM add contained/referred value - RC=RC+1 - Q=V:GOSUB PUSH_Q - REM free the atom itself - RETURN - RELEASE_MAL_FUNCTION: - REM add ast, params and environment to stack - RC=RC+3 - Q=V:GOSUB PUSH_Q - Q=Z%(AY+2):GOSUB PUSH_Q - Q=Z%(AY+3):GOSUB PUSH_Q - REM free the current 3 element mal_function - RETURN - RELEASE_ENV: - REM add the hashmap data to the stack - RC=RC+1 - Q=V:GOSUB PUSH_Q - REM if outer set, add outer env to stack - IF Z%(AY+2)<>0 THEN RC=RC+1:Q=Z%(AY+2):GOSUB PUSH_Q - RETURN - RELEASE_METADATA: - REM add object and metadata object - RC=RC+2 - Q=V:GOSUB PUSH_Q - Q=Z%(AY+2):GOSUB PUSH_Q - RETURN - - -REM INC_REF_R(R) -> R -REM - return R with 1 ref cnt increase -REM - call with GOTO to return at caller callsite -REM - call with GOSUB to return to caller -INC_REF_R: - Z%(R)=Z%(R)+32 - RETURN - -REM RETURN_TRUE_FALSE(R) -> R -REM - take BASIC true/false R, return mal true/false R with ref cnt -REM - called with GOTO as a return RETURN -RETURN_TRUE_FALSE: - IF R THEN R=4 - IF R=0 THEN R=2 - GOTO INC_REF_R - - -REM release stack functions - -#qbasic PEND_A_LV: -#qbasic Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV:RETURN -#qbasic -#qbasic REM RELEASE_PEND(LV) -> nil -#qbasic RELEASE_PEND: -#qbasic IF Y<0 THEN RETURN -#qbasic IF Y%(Y,1)<=LV THEN RETURN -#qbasic REM PRINT "RELEASE_PEND releasing:"+STR$(Y%(Y,0)) -#qbasic AY=Y%(Y,0):GOSUB RELEASE -#qbasic Y=Y-1 -#qbasic GOTO RELEASE_PEND - -#cbm PEND_A_LV: -#cbm Y=Y+4:POKE Y,A AND255:POKE Y+1,A/256 -#cbm POKE Y+2,LV AND255:POKE Y+3,LV/256:RETURN -#cbm -#cbm REM RELEASE_PEND(LV) -> nil -#cbm RELEASE_PEND: -#cbm IF Y=0 : pointer to error object - ER=-2 - E$="" - - REM Predefine nil, false, true, and an empty sequences - FOR I=0 TO 15:Z%(I)=0:NEXT I - Z%(0)=32: REM nil - Z%(2)=1+32: REM false - Z%(4)=1+32:Z%(5)=1: REM true - Z%(6)=6+32: REM emtpy list - Z%(9)=7+32: REM empty vector - Z%(12)=8+32: REM empty hash-map - - REM start of unused memory - ZI=16 - - REM start of free list - ZK=16 - - REM start of time clock - #cbm BT=TI - #qbasic BT#=TIMER(0.001) - - RETURN - - +REM Memory layout: +REM +REM type bytes +REM ---------- ---------- +REM nil ref/ 0 | 0 | | +REM false ref/ 1 | 0 | | +REM true ref/ 1 | 1 | | +REM integer ref/ 2 | int | | +REM float ref/ 3 | ??? | | +REM string/kw ref/ 4 | S$ idx | | +REM symbol ref/ 5 | S$ idx | | +REM list ref/ 6 | next Z% idx | val Z% idx | +REM vector ref/ 7 | next Z% idx | val Z% idx | +REM hashmap ref/ 8 | next Z% idx | key Z% idx | val Z% idx +REM function ref/ 9 | fn idx | | +REM mal function ref/10 | body Z% idx | param Z% idx | env Z% idx +REM macro fn ref/11 | body Z% idx | param Z% idx | env Z% idx +REM atom ref/12 | val Z% idx | | +REM environment ref/13 | hmap Z% idx | outer Z% idx | +REM metadata ref/14 | obj Z% idx | meta Z% idx | +REM FREE sz/15 | next Z% idx | | +REM +REM Locations 0-15 are for constant/persistent values: +REM 0: nil +REM 2: false +REM 4: true +REM 6: empty list +REM 9: empty vector +REM 12: empty hash-map + +REM Note: DIM_MEMORY for C64 BASIC and the INIT_MEMORY function are at +REM end of this file for efficiency on C64. The most commonly used +REM function should be at the top since C64 BASIC scans line numbers +REM for every GOTO/GOSUB. On the other hand, QBasic requires that +REM arrays are dimensioned at the top of the file, not just as the +REM first operation on that array so DIM_MEMORY for QBasic is here at +REM the top. + +#qbasic DIM_MEMORY: +#qbasic T=0 +#qbasic +#qbasic Z1=8191+1424: REM Z% (boxed memory) size (2 bytes each) +#qbasic Z2=199: REM S$/S% (string memory) size (3+2 bytes each) +#qbasic Z3=200: REM X% (call stack) size (2 bytes each) +#qbasic Z4=64: REM Y% (release stack) size (4 bytes each) +#qbasic +#qbasic REM boxed element memory +#qbasic DIM Z%(Z1): REM TYPE ARRAY +#qbasic +#qbasic REM string memory storage +#qbasic S=0:DIM S$(Z2):DIM S%(Z2) +#qbasic +#qbasic REM call/logic stack +#qbasic X=-1:DIM X%(Z3): REM stack of Z% indexes +#qbasic +#qbasic REM pending release stack +#qbasic Y=-1:DIM Y%(Z4,1): REM stack of Z% indexes and level/LV values +#qbasic +#qbasic RETURN + +REM stack functions + +#qbasic PUSH_A: +#qbasic X=X+1:X%(X)=A:RETURN +#qbasic POP_A: +#qbasic A=X%(X):X=X-1:RETURN +#qbasic +#qbasic PUSH_R: +#qbasic X=X+1:X%(X)=R:RETURN +#qbasic POP_R: +#qbasic R=X%(X):X=X-1:RETURN +#qbasic +#qbasic PUSH_Q: +#qbasic X=X+1:X%(X)=Q:RETURN +#qbasic POP_Q: +#qbasic Q=X%(X):X=X-1:RETURN +#qbasic PEEK_Q: +#qbasic Q=X%(X):RETURN +#qbasic PEEK_Q_1: +#qbasic Q=X%(X-1):RETURN +#qbasic PEEK_Q_2: +#qbasic Q=X%(X-2):RETURN +#qbasic PEEK_Q_Q: +#qbasic Q=X%(X-Q):RETURN +#qbasic PUT_Q: +#qbasic X%(X)=Q:RETURN +#qbasic PUT_Q_1: +#qbasic X%(X-1)=Q:RETURN +#qbasic PUT_Q_2: +#qbasic X%(X-2)=Q:RETURN + +#cbm PUSH_A: +#cbm X=X+2:POKE X,A AND255:POKE X+1,A/256:RETURN +#cbm POP_A: +#cbm A=PEEK(X)+PEEK(X+1)*256:X=X-2:RETURN +#cbm +#cbm PUSH_R: +#cbm X=X+2:POKE X,R AND255:POKE X+1,R/256:RETURN +#cbm POP_R: +#cbm R=PEEK(X)+PEEK(X+1)*256:X=X-2:RETURN +#cbm +#cbm PUSH_Q: +#cbm X=X+2:POKE X,Q AND255:POKE X+1,Q/256:RETURN +#cbm POP_Q: +#cbm Q=PEEK(X)+PEEK(X+1)*256:X=X-2:RETURN +#cbm PEEK_Q: +#cbm Q=PEEK(X)+PEEK(X+1)*256:RETURN +#cbm PEEK_Q_1: +#cbm Q=PEEK(X-2)+PEEK(X-1)*256:RETURN +#cbm PEEK_Q_2: +#cbm Q=PEEK(X-4)+PEEK(X-3)*256:RETURN +#cbm PEEK_Q_Q: +#cbm Q=PEEK(X-Q*2)+PEEK(X-Q*2+1)*256:RETURN +#cbm PUT_Q: +#cbm POKE X,Q AND255:POKE X+1,Q/256:RETURN +#cbm PUT_Q_1: +#cbm POKE X-2,Q AND255:POKE X-1,Q/256:RETURN +#cbm PUT_Q_2: +#cbm POKE X-4,Q AND255:POKE X-3,Q/256:RETURN + +REM memory functions + +REM ALLOC(T,L) -> R +REM ALLOC(T,L,M) -> R +REM ALLOC(T,L,M,N) -> R +REM L is value for Z%(R+1) +REM M is value for Z%(R+2), if SZ>2 +REM N is value for Z%(R+3), if SZ>3 +ALLOC: + SZ=3 + IF T<6 OR T=9 OR T=12 THEN SZ=2 + IF T=8 OR T=10 OR T=11 THEN SZ=4 + REM PRINT "ALLOC T: "+STR$(T)+", SZ: "+STR$(SZ)+", ZK: "+STR$(ZK) + U=ZK + R=ZK + ALLOC_LOOP: + IF R=ZI THEN GOTO ALLOC_UNUSED + REM TODO sanity check that type is 15 + IF ((Z%(R)AND-32)/32)=SZ THEN GOTO ALLOC_MIDDLE + REM PRINT "ALLOC search: U: "+STR$(U)+", R: "+STR$(R) + U=R: REM previous set to current + R=Z%(R+1): REM current set to next + GOTO ALLOC_LOOP + ALLOC_MIDDLE: + REM PRINT "ALLOC_MIDDLE: U: "+STR$(U)+", R: "+STR$(R) + REM set free pointer (ZK) to next free + IF R=ZK THEN ZK=Z%(R+1) + REM set previous free to next free + IF R<>ZK THEN Z%(U+1)=Z%(R+1) + GOTO ALLOC_DONE + ALLOC_UNUSED: + REM PRINT "ALLOC_UNUSED ZI: "+STR$(ZI)+", U: "+STR$(U)+", R: "+STR$(R) + IF R+SZ>Z1 THEN GOSUB PR_MEMORY_SUMMARY_SMALL:PRINT "Out of mal memory!":END + ZI=ZI+SZ + IF U=R THEN ZK=ZI + REM set previous free to new memory top + IF U<>R THEN Z%(U+1)=ZI + GOTO ALLOC_DONE + ALLOC_DONE: + Z%(R)=T+32 + REM set Z%(R+1) to default L + Z%(R+1)=L + IF T>5 AND T<>9 THEN Z%(L)=Z%(L)+32: REM value is a Z% idx + IF SZ>2 THEN Z%(M)=Z%(M)+32:Z%(R+2)=M + IF SZ>3 THEN Z%(N)=Z%(N)+32:Z%(R+3)=N + + RETURN + +REM FREE(AY, SZ) -> nil +FREE: + REM assumes reference count cleanup already (see RELEASE) + Z%(AY)=(SZ*32)+15: REM set type(15) and size + Z%(AY+1)=ZK + ZK=AY + IF SZ>=3 THEN Z%(AY+2)=0 + IF SZ=4 THEN Z%(AY+3)=0 + REM TODO: fail if SZ>4 + RETURN + + +REM RELEASE(AY) -> nil +REM R should not be affected by this call +RELEASE: + RC=0 + + GOTO RELEASE_ONE + + RELEASE_TOP: + + IF RC=0 THEN RETURN + + REM pop next object to release, decrease remaining count + GOSUB POP_Q:AY=Q + RC=RC-1 + + RELEASE_ONE: + IF AY=-1 THEN RETURN + + U=Z%(AY)AND 31: REM type + V=Z%(AY+1): REM main value/reference + + REM set the size + REM TODO: share with ALLOC calculation + SZ=3 + IF U<6 OR U=9 OR U=12 THEN SZ=2 + IF U=8 OR U=10 OR U=11 THEN SZ=4 + + REM AZ=AY: B=1: GOSUB PR_STR + REM PRINT "RELEASE AY:"+STR$(AY)+" ["+R$+"] (byte0:"+STR$(Z%(AY))+", SZ:"+STR$(SZ)+")" + + REM sanity check not already freed + REM MEMORY DEBUGGING: + REM IF U=15 THEN PRINT "RELEASE of free:"+STR$(AY):END + REM IF Z%(AY)<15 THEN PRINT "RELEASE of unowned:"+STR$(AY):END + + REM decrease reference count by one + Z%(AY)=Z%(AY)-32 + + REM nil, false, true, empty sequences + REM MEMORY DEBUGGING: + REM IF AY<16 AND Z%(AY)<32 THEN PRINT "RELEASE of empty:"+STR$(AY):END + IF AY<16 THEN GOTO RELEASE_TOP + + REM our reference count is not 0, so don't release + IF Z%(AY)>=32 GOTO RELEASE_TOP + + REM switch on type + ON U+1 GOSUB RELEASE_SIMPLE,RELEASE_SIMPLE,RELEASE_SIMPLE,RELEASE_SIMPLE,RELEASE_STRING,RELEASE_STRING,RELEASE_SEQ,RELEASE_SEQ,RELEASE_HASH_MAP,RELEASE_SIMPLE,RELEASE_MAL_FUNCTION,RELEASE_MAL_FUNCTION,RELEASE_ATOM,RELEASE_ENV,RELEASE_METADATA + + REM free the current element and continue, SZ already set + GOSUB FREE + GOTO RELEASE_TOP + + RELEASE_SIMPLE: + RETURN + RELEASE_STRING: + REM string type, release interned string, then FREE reference + REM MEMORY DEBUGGING: + REM IF S%(V)=0 THEN PRINT "RELEASE of free string:"+STR$(S%(V)):END + S%(V)=S%(V)-1 + IF S%(V)=0 THEN S$(V)="": REM free BASIC string + REM free the atom itself + RETURN + RELEASE_SEQ: + IF V=0 THEN RETURN + REM add value and next element to stack + RC=RC+2 + Q=Z%(AY+2):GOSUB PUSH_Q + Q=V:GOSUB PUSH_Q + RETURN + RELEASE_HASH_MAP: + IF V=0 THEN RETURN + REM add key, value and next element to stack + RC=RC+3 + Q=Z%(AY+2):GOSUB PUSH_Q + Q=Z%(AY+3):GOSUB PUSH_Q + Q=V:GOSUB PUSH_Q + RETURN + RELEASE_ATOM: + REM add contained/referred value + RC=RC+1 + Q=V:GOSUB PUSH_Q + REM free the atom itself + RETURN + RELEASE_MAL_FUNCTION: + REM add ast, params and environment to stack + RC=RC+3 + Q=V:GOSUB PUSH_Q + Q=Z%(AY+2):GOSUB PUSH_Q + Q=Z%(AY+3):GOSUB PUSH_Q + REM free the current 3 element mal_function + RETURN + RELEASE_ENV: + REM add the hashmap data to the stack + RC=RC+1 + Q=V:GOSUB PUSH_Q + REM if outer set, add outer env to stack + IF Z%(AY+2)<>0 THEN RC=RC+1:Q=Z%(AY+2):GOSUB PUSH_Q + RETURN + RELEASE_METADATA: + REM add object and metadata object + RC=RC+2 + Q=V:GOSUB PUSH_Q + Q=Z%(AY+2):GOSUB PUSH_Q + RETURN + + +REM INC_REF_R(R) -> R +REM - return R with 1 ref cnt increase +REM - call with GOTO to return at caller callsite +REM - call with GOSUB to return to caller +INC_REF_R: + Z%(R)=Z%(R)+32 + RETURN + +REM RETURN_TRUE_FALSE(R) -> R +REM - take BASIC true/false R, return mal true/false R with ref cnt +REM - called with GOTO as a return RETURN +RETURN_TRUE_FALSE: + IF R THEN R=4 + IF R=0 THEN R=2 + GOTO INC_REF_R + + +REM release stack functions + +#qbasic PEND_A_LV: +#qbasic Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV:RETURN +#qbasic +#qbasic REM RELEASE_PEND(LV) -> nil +#qbasic RELEASE_PEND: +#qbasic IF Y<0 THEN RETURN +#qbasic IF Y%(Y,1)<=LV THEN RETURN +#qbasic REM PRINT "RELEASE_PEND releasing:"+STR$(Y%(Y,0)) +#qbasic AY=Y%(Y,0):GOSUB RELEASE +#qbasic Y=Y-1 +#qbasic GOTO RELEASE_PEND + +#cbm PEND_A_LV: +#cbm Y=Y+4:POKE Y,A AND255:POKE Y+1,A/256 +#cbm POKE Y+2,LV AND255:POKE Y+3,LV/256:RETURN +#cbm +#cbm REM RELEASE_PEND(LV) -> nil +#cbm RELEASE_PEND: +#cbm IF Y=0 : pointer to error object + ER=-2 + E$="" + + REM Predefine nil, false, true, and an empty sequences + FOR I=0 TO 15:Z%(I)=0:NEXT I + Z%(0)=32: REM nil + Z%(2)=1+32: REM false + Z%(4)=1+32:Z%(5)=1: REM true + Z%(6)=6+32: REM emtpy list + Z%(9)=7+32: REM empty vector + Z%(12)=8+32: REM empty hash-map + + REM start of unused memory + ZI=16 + + REM start of free list + ZK=16 + + REM start of time clock + #cbm BT=TI + #qbasic BT#=TIMER(0.001) + + RETURN + + diff --git a/impls/basic/printer.in.bas b/impls/basic/printer.in.bas index 55c6360b47..2f6b227f12 100644 --- a/impls/basic/printer.in.bas +++ b/impls/basic/printer.in.bas @@ -1,116 +1,116 @@ -REM PR_STR(AZ, B) -> R$ -PR_STR: - R$="" - PR_STR_RECUR: - T=Z%(AZ)AND 31 - U=Z%(AZ+1) - REM PRINT "AZ: "+STR$(AZ)+", T: "+STR$(T)+", U: "+STR$(U) - IF T=0 THEN R$="nil":RETURN - REM if metadata, then get actual object - IF T>=14 THEN AZ=U:GOTO PR_STR_RECUR - ON T GOTO PR_BOOLEAN,PR_INTEGER,PR_UNKNOWN,PR_STRING_MAYBE,PR_SYMBOL,PR_SEQ,PR_SEQ,PR_SEQ,PR_FUNCTION,PR_MAL_FUNCTION,PR_MAL_FUNCTION,PR_ATOM,PR_ENV,PR_RECUR,PR_FREE - - PR_UNKNOWN: - REM MEMORY DEBUGGING: - REM R$="#" - RETURN - PR_RECUR: - AZ=U - GOTO PR_STR_RECUR - PR_BOOLEAN: - R$="true" - IF U=0 THEN R$="false" - RETURN - PR_INTEGER: - T$=STR$(U) - REM Remove initial space - IF U>=0 THEN T$=RIGHT$(T$,LEN(T$)-1) - R$=R$+T$ - RETURN - PR_STRING_MAYBE: - R$=S$(U) - IF LEN(R$)=0 THEN GOTO PR_STRING - IF MID$(R$,1,1)=CHR$(127) THEN R$=":"+MID$(R$,2,LEN(R$)-1):RETURN - PR_STRING: - IF B=1 THEN GOTO PR_STRING_READABLY - RETURN - PR_STRING_READABLY: - S1$="\":S2$="\\":GOSUB REPLACE: REM escape backslash " - S1$=CHR$(34):S2$="\"+CHR$(34):GOSUB REPLACE: REM escape quotes " - #cbm S1$=CHR$(13):S2$="\n":GOSUB REPLACE: REM escape newlines - #qbasic S1$=CHR$(10):S2$="\n":GOSUB REPLACE: REM escape newlines - R$=CHR$(34)+R$+CHR$(34) - RETURN - PR_SYMBOL: - R$=S$(U) - RETURN - PR_SEQ: - REM push the type and where we are in the sequence - Q=T:GOSUB PUSH_Q - Q=AZ:GOSUB PUSH_Q - REM save the current rendered string - S$(S)=R$:S=S+1 - PR_SEQ_LOOP: - IF Z%(AZ+1)=0 THEN GOTO PR_SEQ_DONE - AZ=Z%(AZ+2):GOSUB PR_STR:GOSUB PEEK_Q_1:T=Q - REM append what we just rendered it - S$(S-1)=S$(S-1)+R$ - - REM if this is a hash-map, print the next element - IF T=8 THEN GOSUB PEEK_Q:AZ=Z%(Q+3):GOSUB PR_STR:S$(S-1)=S$(S-1)+" "+R$ - - REM restore current seq type - GOSUB PEEK_Q_1:T=Q - REM Go to next list element - GOSUB PEEK_Q - AZ=Z%(Q+1) - Q=AZ:GOSUB PUT_Q - IF Z%(AZ+1)<>0 THEN S$(S-1)=S$(S-1)+" " - GOTO PR_SEQ_LOOP - PR_SEQ_DONE: - REM restore the current string - S=S-1:R$=S$(S) - REM pop where we are the sequence and type - GOSUB POP_Q - GOSUB POP_Q:T=Q: REM get type - IF T=6 THEN R$="("+R$+")" - IF T=7 THEN R$="["+R$+"]" - IF T=8 THEN R$="{"+R$+"}" - RETURN - PR_FUNCTION: - R$="#" - RETURN - PR_MAL_FUNCTION: - T1=AZ - AZ=Z%(T1+2):GOSUB PR_STR - REM append what we just rendered it - S$(S)="(fn* "+R$:S=S+1 - AZ=Z%(T1+1):GOSUB PR_STR - S=S-1 - R$=S$(S)+" "+R$+")" - RETURN - PR_ATOM: - AZ=U:GOSUB PR_STR - R$="(atom "+R$+")" - RETURN - PR_ENV: - R$="#" - RETURN - PR_FREE: - R$="#" - RETURN - -REM PR_STR_SEQ(AZ, B, B$) -> R$ -REM - B is print_readably -REM - B$ is the separator -PR_STR_SEQ: - V=AZ - S$(S)="":S=S+1 - PR_STR_SEQ_LOOP: - IF Z%(V+1)=0 THEN S=S-1:R$=S$(S):RETURN - AZ=Z%(V+2):GOSUB PR_STR - REM goto the next sequence element - V=Z%(V+1) - IF Z%(V+1)=0 THEN S$(S-1)=S$(S-1)+R$ - IF Z%(V+1)<>0 THEN S$(S-1)=S$(S-1)+R$+B$ - GOTO PR_STR_SEQ_LOOP +REM PR_STR(AZ, B) -> R$ +PR_STR: + R$="" + PR_STR_RECUR: + T=Z%(AZ)AND 31 + U=Z%(AZ+1) + REM PRINT "AZ: "+STR$(AZ)+", T: "+STR$(T)+", U: "+STR$(U) + IF T=0 THEN R$="nil":RETURN + REM if metadata, then get actual object + IF T>=14 THEN AZ=U:GOTO PR_STR_RECUR + ON T GOTO PR_BOOLEAN,PR_INTEGER,PR_UNKNOWN,PR_STRING_MAYBE,PR_SYMBOL,PR_SEQ,PR_SEQ,PR_SEQ,PR_FUNCTION,PR_MAL_FUNCTION,PR_MAL_FUNCTION,PR_ATOM,PR_ENV,PR_RECUR,PR_FREE + + PR_UNKNOWN: + REM MEMORY DEBUGGING: + REM R$="#" + RETURN + PR_RECUR: + AZ=U + GOTO PR_STR_RECUR + PR_BOOLEAN: + R$="true" + IF U=0 THEN R$="false" + RETURN + PR_INTEGER: + T$=STR$(U) + REM Remove initial space + IF U>=0 THEN T$=RIGHT$(T$,LEN(T$)-1) + R$=R$+T$ + RETURN + PR_STRING_MAYBE: + R$=S$(U) + IF LEN(R$)=0 THEN GOTO PR_STRING + IF MID$(R$,1,1)=CHR$(127) THEN R$=":"+MID$(R$,2,LEN(R$)-1):RETURN + PR_STRING: + IF B=1 THEN GOTO PR_STRING_READABLY + RETURN + PR_STRING_READABLY: + S1$="\":S2$="\\":GOSUB REPLACE: REM escape backslash " + S1$=CHR$(34):S2$="\"+CHR$(34):GOSUB REPLACE: REM escape quotes " + #cbm S1$=CHR$(13):S2$="\n":GOSUB REPLACE: REM escape newlines + #qbasic S1$=CHR$(10):S2$="\n":GOSUB REPLACE: REM escape newlines + R$=CHR$(34)+R$+CHR$(34) + RETURN + PR_SYMBOL: + R$=S$(U) + RETURN + PR_SEQ: + REM push the type and where we are in the sequence + Q=T:GOSUB PUSH_Q + Q=AZ:GOSUB PUSH_Q + REM save the current rendered string + S$(S)=R$:S=S+1 + PR_SEQ_LOOP: + IF Z%(AZ+1)=0 THEN GOTO PR_SEQ_DONE + AZ=Z%(AZ+2):GOSUB PR_STR:GOSUB PEEK_Q_1:T=Q + REM append what we just rendered it + S$(S-1)=S$(S-1)+R$ + + REM if this is a hash-map, print the next element + IF T=8 THEN GOSUB PEEK_Q:AZ=Z%(Q+3):GOSUB PR_STR:S$(S-1)=S$(S-1)+" "+R$ + + REM restore current seq type + GOSUB PEEK_Q_1:T=Q + REM Go to next list element + GOSUB PEEK_Q + AZ=Z%(Q+1) + Q=AZ:GOSUB PUT_Q + IF Z%(AZ+1)<>0 THEN S$(S-1)=S$(S-1)+" " + GOTO PR_SEQ_LOOP + PR_SEQ_DONE: + REM restore the current string + S=S-1:R$=S$(S) + REM pop where we are the sequence and type + GOSUB POP_Q + GOSUB POP_Q:T=Q: REM get type + IF T=6 THEN R$="("+R$+")" + IF T=7 THEN R$="["+R$+"]" + IF T=8 THEN R$="{"+R$+"}" + RETURN + PR_FUNCTION: + R$="#" + RETURN + PR_MAL_FUNCTION: + T1=AZ + AZ=Z%(T1+2):GOSUB PR_STR + REM append what we just rendered it + S$(S)="(fn* "+R$:S=S+1 + AZ=Z%(T1+1):GOSUB PR_STR + S=S-1 + R$=S$(S)+" "+R$+")" + RETURN + PR_ATOM: + AZ=U:GOSUB PR_STR + R$="(atom "+R$+")" + RETURN + PR_ENV: + R$="#" + RETURN + PR_FREE: + R$="#" + RETURN + +REM PR_STR_SEQ(AZ, B, B$) -> R$ +REM - B is print_readably +REM - B$ is the separator +PR_STR_SEQ: + V=AZ + S$(S)="":S=S+1 + PR_STR_SEQ_LOOP: + IF Z%(V+1)=0 THEN S=S-1:R$=S$(S):RETURN + AZ=Z%(V+2):GOSUB PR_STR + REM goto the next sequence element + V=Z%(V+1) + IF Z%(V+1)=0 THEN S$(S-1)=S$(S-1)+R$ + IF Z%(V+1)<>0 THEN S$(S-1)=S$(S-1)+R$+B$ + GOTO PR_STR_SEQ_LOOP diff --git a/impls/basic/reader.in.bas b/impls/basic/reader.in.bas index 5301904135..21e4c6e95e 100644 --- a/impls/basic/reader.in.bas +++ b/impls/basic/reader.in.bas @@ -1,275 +1,275 @@ -REM READ_TOKEN(RF=0, A$, RI) -> T$ -REM READ_TOKEN(RF=1) -> T$ -READ_TOKEN: - IF RF=1 THEN RF=2:T$="(":RETURN - IF RF=2 THEN RF=3:T$="do":RETURN - GOSUB SKIP_SPACES - REM PRINT "READ_TOKEN: "+STR$(RI)+", "+MID$(A$,RI,1) - GOSUB READ_CHAR - IF C$=";" THEN GOSUB SKIP_TO_EOL:GOTO READ_TOKEN - T$=C$ - IF T$="(" OR T$=")" OR T$="[" OR T$="]" OR T$="{" OR T$="}" OR T$="'" OR T$="`" OR T$="@" THEN RETURN - GOSUB PEEK_CHAR: REM peek at next character - IF T$="~" AND C$<>"@" THEN RETURN - S1=0:S2=0: REM S1: INSTRING?, S2: ESCAPED? - IF T$=CHR$(34) THEN S1=1 - READ_TOKEN_LOOP: - GOSUB PEEK_CHAR: REM peek at next character - IF C$="" THEN RETURN - IF S1 THEN GOTO READ_TOKEN_CONT - IF C$=" " OR C$="," OR C$=CHR$(13) OR C$=CHR$(10) THEN RETURN - IF C$="(" OR C$=")" OR C$="[" OR C$="]" OR C$="{" OR C$="}" THEN RETURN - READ_TOKEN_CONT: - GOSUB READ_CHAR - T$=T$+C$ - IF T$="~@" THEN RETURN - IF S1=0 OR S2=1 THEN S2=0:GOTO READ_TOKEN_LOOP - REM S1=1 (INSTRING?) and S2=0 (not ESCAPED?) - IF C$=CHR$(92) THEN S2=1 - IF C$=CHR$(34) THEN RETURN - GOTO READ_TOKEN_LOOP - - -REM READ_CHAR(A$, RI) -> C$ -READ_CHAR: - RJ=1:GOSUB DO_READ_CHAR - RETURN - -REM PEEK_CHAR(A$, RI) -> C$ -PEEK_CHAR: - RJ=0:GOSUB DO_READ_CHAR - RETURN - -REM DO_READ_CHAR(RJ, A$, RI): -REM - RI is position in A$ -REM - RJ=1 is read, RJ=0 is peek -DO_READ_CHAR: - C$="" - IF RF>0 THEN GOTO READ_FILE_CHAR - IF RI<=LEN(A$) THEN C$=MID$(A$,RI,1):RI=RI+RJ - RETURN - -REM READ_FILE_CHAR(RJ) -> C$ -REM - RJ=1 is read, RJ=0 is peek -REM - D$ is global used for already read pending character -REM - EZ is global used for end of file state -READ_FILE_CHAR: - IF D$<>"" THEN C$=D$:IF RJ=0 THEN RETURN - IF D$<>"" AND RJ=1 THEN D$="":RETURN - D$="" - IF EZ>2 THEN C$="" - IF EZ=2 THEN C$=")" - IF EZ=1 THEN C$=CHR$(10) - IF EZ>0 THEN EZ=EZ+RJ:RETURN - #cbm GET#2,C$ - #qbasic C$=INPUT$(1,2) - #qbasic IF EOF(2) THEN EZ=1:RETURN - IF RJ=0 THEN D$=C$ - #cbm IF (ST AND 64) THEN EZ=1:RETURN - #cbm IF (ST AND 255) THEN EZ=1:ER=-1:E$="File read error"+STR$(ST) - RETURN - -SKIP_SPACES: - GOSUB PEEK_CHAR: REM peek at next character - IF C$=" " OR C$="," OR C$=CHR$(13) OR C$=CHR$(10) THEN GOSUB READ_CHAR:GOTO SKIP_SPACES - RETURN - -SKIP_TO_EOL: - GOSUB READ_CHAR - IF C$="" OR C$=CHR$(13) OR C$=CHR$(10) THEN RETURN - GOTO SKIP_TO_EOL - - -REM READ_FORM(A$, RI, RF) -> R -SUB READ_FORM - Q=T:GOSUB PUSH_Q: REM save current value of T - READ_FORM_RECUR: - IF ER<>-2 THEN GOTO READ_FORM_RETURN - GOSUB READ_TOKEN - REM PRINT "READ_FORM T$: ["+T$+"]" - IF T$="" THEN R=0:GOSUB INC_REF_R:GOTO READ_FORM_RETURN - IF T$="nil" THEN T=0:GOTO READ_NIL_BOOL - IF T$="false" THEN T=1:GOTO READ_NIL_BOOL - IF T$="true" THEN T=2:GOTO READ_NIL_BOOL - IF T$="'" THEN B$="quote":GOTO READ_MACRO - IF T$="`" THEN B$="quasiquote":GOTO READ_MACRO - IF T$="~" THEN B$="unquote":GOTO READ_MACRO - IF T$="~@" THEN B$="splice-unquote":GOTO READ_MACRO - IF T$="^" THEN B$="with-meta":GOTO READ_MACRO - IF T$="@" THEN B$="deref":GOTO READ_MACRO - C$=MID$(T$,1,1) - REM PRINT "C$: ["+C$+"]("+STR$(ASC(C$))+")" - IF C$>="0" AND C$<="9" THEN GOTO READ_NUMBER - IF C$="-" THEN GOTO READ_SYMBOL_MAYBE - - IF C$=CHR$(34) THEN GOTO READ_STRING - IF C$=":" THEN GOTO READ_KEYWORD - REM set end character in Q and read the sequence - IF C$="(" THEN T=6:Q=41:GOTO READ_SEQ_START: REM ")" - IF C$="[" THEN T=7:Q=93:GOTO READ_SEQ_START: REM "]" - IF C$="{" THEN T=8:Q=125:GOTO READ_SEQ_START: REM "}" - IF C$=")" OR C$="]" OR C$="}" THEN R=-1:ER=-1:E$="unexpected "+C$:GOTO READ_FORM_RETURN - GOTO READ_SYMBOL - - READ_NIL_BOOL: - REM PRINT "READ_NIL_BOOL" - R=T*2 - GOSUB INC_REF_R - GOTO READ_FORM_RETURN - READ_NUMBER: - REM PRINT "READ_NUMBER" - T=2:L=VAL(T$):GOSUB ALLOC - GOTO READ_FORM_RETURN - READ_MACRO: - REM push macro type - Q=-1*(T$="^"):GOSUB PUSH_Q - - REM B$ is set above - T=5:GOSUB STRING - REM push string - GOSUB PUSH_R - - CALL READ_FORM - REM push first form - GOSUB PUSH_R - IF ER>-2 THEN GOTO READ_MACRO_DONE - - GOSUB PEEK_Q_2 - IF Q THEN GOTO READ_MACRO_3 - - READ_MACRO_2: - GOSUB PEEK_Q_1:B=Q - GOSUB PEEK_Q:A=Q - GOSUB LIST2 - GOTO READ_MACRO_DONE - - READ_MACRO_3: - CALL READ_FORM - GOSUB PEEK_Q_1:C=Q - B=R - GOSUB PEEK_Q:A=Q - GOSUB LIST3 - AY=C:GOSUB RELEASE - - READ_MACRO_DONE: - REM release values, list has ownership - AY=B:GOSUB RELEASE - AY=A:GOSUB RELEASE - - REM pop the stack - GOSUB POP_Q: REM pop first form - GOSUB POP_Q: REM pop string - GOSUB POP_Q: REM pop macro type - T$="": REM necessary to prevent unexpected EOF errors - GOTO READ_FORM_RETURN - - READ_STRING: - REM PRINT "READ_STRING" - C=ASC(MID$(T$,LEN(T$),1)) - IF C<>34 THEN R=-1:ER=-1:E$="expected '"+CHR$(34)+"', got EOF":GOTO READ_FORM_RETURN - J=2:R$="" - READ_STRING_LOOP: - #qbasic I=INSTR(J,T$,CHR$(92)) - #cbm I=J - #cbm INSTR_LOOP: - #cbm IF I>LEN(T$) THEN I=0:GOTO INSTR_DONE - #cbm IF MID$(T$,I,1)=CHR$(92) THEN GOTO INSTR_DONE - #cbm I=I+1 - #cbm GOTO INSTR_LOOP - #cbm INSTR_DONE: - IF I=0 THEN GOTO READ_STRING_DONE - R$=R$+MID$(T$,J,I-J) - C$=MID$(T$,I+1,1) - #qbasic IF C$="n" THEN R$=R$+CHR$(10) ELSE R$=R$+C$ - #cbm IF C$="n" THEN R$=R$+CHR$(13) - #cbm IF C$<>"n" THEN R$=R$+C$ - J=I+2 - GOTO READ_STRING_LOOP - READ_STRING_DONE: - IF J=LEN(T$)+1 THEN R=-1:ER=-1:E$="expected '"+CHR$(34)+"', got EOF":GOTO READ_FORM_RETURN - R$=R$+MID$(T$,J,LEN(T$)-J) - REM intern string value - B$=R$:T=4:GOSUB STRING - GOTO READ_FORM_RETURN - READ_KEYWORD: - R$=CHR$(127)+MID$(T$,2,LEN(T$)-1) - B$=R$:T=4:GOSUB STRING - GOTO READ_FORM_RETURN - READ_SYMBOL_MAYBE: - C$=MID$(T$,2,1) - IF C$>="0" AND C$<="9" THEN GOTO READ_NUMBER - READ_SYMBOL: - REM PRINT "READ_SYMBOL" - B$=T$:T=5:GOSUB STRING - GOTO READ_FORM_RETURN - - READ_SEQ_START: - SD=SD+1 - - GOSUB PUSH_Q: REM push return character - - REM setup the stack for the loop, T has type - GOSUB MAP_LOOP_START - - READ_SEQ_LOOP: - - REM TODO: reduce redundancy with READ_TOKEN - GOSUB SKIP_SPACES - GOSUB PEEK_CHAR: REM peek at next character - IF C$="" THEN ER=-1:E$="unexpected EOF":GOTO READ_SEQ_DONE - IF C$=";" THEN GOSUB SKIP_TO_EOL:GOTO READ_SEQ_LOOP - Q=3:GOSUB PEEK_Q_Q - IF C$=CHR$(Q) THEN GOSUB READ_CHAR:GOTO READ_SEQ_DONE - - CALL READ_FORM - M=R: REM value (or key for hash-maps) - - REM if error, release the unattached element - IF ER<>-2 THEN AY=R:GOSUB RELEASE:GOTO READ_SEQ_DONE - - REM if this is a hash-map, READ_FORM again - IF T=8 THEN GOSUB PUSH_R:CALL READ_FORM - IF T=8 THEN N=R:GOSUB POP_Q:M=Q: REM set key and value - - REM update the return sequence structure - REM release N since list takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - GOTO READ_SEQ_LOOP - - READ_SEQ_DONE: - SD=SD-1 - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - - GOSUB POP_Q: REM pop end character ptr - GOTO READ_FORM_RETURN - - READ_FORM_RETURN: - GOSUB POP_Q:T=Q: REM restore current value of T - -END SUB - - -REM READ_STR(A$) -> R -READ_STR: - RI=1: REM index into A$ - RF=0: REM not reading from file - SD=0: REM sequence read depth - CALL READ_FORM - RETURN - -REM READ_FILE(A$) -> R -READ_FILE: - RF=1: REM reading from file - EZ=0: REM file read state (1: EOF) - SD=0: REM sequence read depth - D$="": REM pending read/peek character - #cbm OPEN 2,8,0,A$ - #qbasic IF NOT _FILEEXISTS(A$) THEN ER=-1:E$="File not found":RETURN - #qbasic OPEN A$ FOR INPUT AS #2 - REM READ_TOKEN adds "(do ... )" - CALL READ_FORM - CLOSE 2 - EZ=0 - RETURN +REM READ_TOKEN(RF=0, A$, RI) -> T$ +REM READ_TOKEN(RF=1) -> T$ +READ_TOKEN: + IF RF=1 THEN RF=2:T$="(":RETURN + IF RF=2 THEN RF=3:T$="do":RETURN + GOSUB SKIP_SPACES + REM PRINT "READ_TOKEN: "+STR$(RI)+", "+MID$(A$,RI,1) + GOSUB READ_CHAR + IF C$=";" THEN GOSUB SKIP_TO_EOL:GOTO READ_TOKEN + T$=C$ + IF T$="(" OR T$=")" OR T$="[" OR T$="]" OR T$="{" OR T$="}" OR T$="'" OR T$="`" OR T$="@" THEN RETURN + GOSUB PEEK_CHAR: REM peek at next character + IF T$="~" AND C$<>"@" THEN RETURN + S1=0:S2=0: REM S1: INSTRING?, S2: ESCAPED? + IF T$=CHR$(34) THEN S1=1 + READ_TOKEN_LOOP: + GOSUB PEEK_CHAR: REM peek at next character + IF C$="" THEN RETURN + IF S1 THEN GOTO READ_TOKEN_CONT + IF C$=" " OR C$="," OR C$=CHR$(13) OR C$=CHR$(10) THEN RETURN + IF C$="(" OR C$=")" OR C$="[" OR C$="]" OR C$="{" OR C$="}" THEN RETURN + READ_TOKEN_CONT: + GOSUB READ_CHAR + T$=T$+C$ + IF T$="~@" THEN RETURN + IF S1=0 OR S2=1 THEN S2=0:GOTO READ_TOKEN_LOOP + REM S1=1 (INSTRING?) and S2=0 (not ESCAPED?) + IF C$=CHR$(92) THEN S2=1 + IF C$=CHR$(34) THEN RETURN + GOTO READ_TOKEN_LOOP + + +REM READ_CHAR(A$, RI) -> C$ +READ_CHAR: + RJ=1:GOSUB DO_READ_CHAR + RETURN + +REM PEEK_CHAR(A$, RI) -> C$ +PEEK_CHAR: + RJ=0:GOSUB DO_READ_CHAR + RETURN + +REM DO_READ_CHAR(RJ, A$, RI): +REM - RI is position in A$ +REM - RJ=1 is read, RJ=0 is peek +DO_READ_CHAR: + C$="" + IF RF>0 THEN GOTO READ_FILE_CHAR + IF RI<=LEN(A$) THEN C$=MID$(A$,RI,1):RI=RI+RJ + RETURN + +REM READ_FILE_CHAR(RJ) -> C$ +REM - RJ=1 is read, RJ=0 is peek +REM - D$ is global used for already read pending character +REM - EZ is global used for end of file state +READ_FILE_CHAR: + IF D$<>"" THEN C$=D$:IF RJ=0 THEN RETURN + IF D$<>"" AND RJ=1 THEN D$="":RETURN + D$="" + IF EZ>2 THEN C$="" + IF EZ=2 THEN C$=")" + IF EZ=1 THEN C$=CHR$(10) + IF EZ>0 THEN EZ=EZ+RJ:RETURN + #cbm GET#2,C$ + #qbasic C$=INPUT$(1,2) + #qbasic IF EOF(2) THEN EZ=1:RETURN + IF RJ=0 THEN D$=C$ + #cbm IF (ST AND 64) THEN EZ=1:RETURN + #cbm IF (ST AND 255) THEN EZ=1:ER=-1:E$="File read error"+STR$(ST) + RETURN + +SKIP_SPACES: + GOSUB PEEK_CHAR: REM peek at next character + IF C$=" " OR C$="," OR C$=CHR$(13) OR C$=CHR$(10) THEN GOSUB READ_CHAR:GOTO SKIP_SPACES + RETURN + +SKIP_TO_EOL: + GOSUB READ_CHAR + IF C$="" OR C$=CHR$(13) OR C$=CHR$(10) THEN RETURN + GOTO SKIP_TO_EOL + + +REM READ_FORM(A$, RI, RF) -> R +SUB READ_FORM + Q=T:GOSUB PUSH_Q: REM save current value of T + READ_FORM_RECUR: + IF ER<>-2 THEN GOTO READ_FORM_RETURN + GOSUB READ_TOKEN + REM PRINT "READ_FORM T$: ["+T$+"]" + IF T$="" THEN R=0:GOSUB INC_REF_R:GOTO READ_FORM_RETURN + IF T$="nil" THEN T=0:GOTO READ_NIL_BOOL + IF T$="false" THEN T=1:GOTO READ_NIL_BOOL + IF T$="true" THEN T=2:GOTO READ_NIL_BOOL + IF T$="'" THEN B$="quote":GOTO READ_MACRO + IF T$="`" THEN B$="quasiquote":GOTO READ_MACRO + IF T$="~" THEN B$="unquote":GOTO READ_MACRO + IF T$="~@" THEN B$="splice-unquote":GOTO READ_MACRO + IF T$="^" THEN B$="with-meta":GOTO READ_MACRO + IF T$="@" THEN B$="deref":GOTO READ_MACRO + C$=MID$(T$,1,1) + REM PRINT "C$: ["+C$+"]("+STR$(ASC(C$))+")" + IF C$>="0" AND C$<="9" THEN GOTO READ_NUMBER + IF C$="-" THEN GOTO READ_SYMBOL_MAYBE + + IF C$=CHR$(34) THEN GOTO READ_STRING + IF C$=":" THEN GOTO READ_KEYWORD + REM set end character in Q and read the sequence + IF C$="(" THEN T=6:Q=41:GOTO READ_SEQ_START: REM ")" + IF C$="[" THEN T=7:Q=93:GOTO READ_SEQ_START: REM "]" + IF C$="{" THEN T=8:Q=125:GOTO READ_SEQ_START: REM "}" + IF C$=")" OR C$="]" OR C$="}" THEN R=-1:ER=-1:E$="unexpected "+C$:GOTO READ_FORM_RETURN + GOTO READ_SYMBOL + + READ_NIL_BOOL: + REM PRINT "READ_NIL_BOOL" + R=T*2 + GOSUB INC_REF_R + GOTO READ_FORM_RETURN + READ_NUMBER: + REM PRINT "READ_NUMBER" + T=2:L=VAL(T$):GOSUB ALLOC + GOTO READ_FORM_RETURN + READ_MACRO: + REM push macro type + Q=-1*(T$="^"):GOSUB PUSH_Q + + REM B$ is set above + T=5:GOSUB STRING + REM push string + GOSUB PUSH_R + + CALL READ_FORM + REM push first form + GOSUB PUSH_R + IF ER>-2 THEN GOTO READ_MACRO_DONE + + GOSUB PEEK_Q_2 + IF Q THEN GOTO READ_MACRO_3 + + READ_MACRO_2: + GOSUB PEEK_Q_1:B=Q + GOSUB PEEK_Q:A=Q + GOSUB LIST2 + GOTO READ_MACRO_DONE + + READ_MACRO_3: + CALL READ_FORM + GOSUB PEEK_Q_1:C=Q + B=R + GOSUB PEEK_Q:A=Q + GOSUB LIST3 + AY=C:GOSUB RELEASE + + READ_MACRO_DONE: + REM release values, list has ownership + AY=B:GOSUB RELEASE + AY=A:GOSUB RELEASE + + REM pop the stack + GOSUB POP_Q: REM pop first form + GOSUB POP_Q: REM pop string + GOSUB POP_Q: REM pop macro type + T$="": REM necessary to prevent unexpected EOF errors + GOTO READ_FORM_RETURN + + READ_STRING: + REM PRINT "READ_STRING" + C=ASC(MID$(T$,LEN(T$),1)) + IF C<>34 THEN R=-1:ER=-1:E$="expected '"+CHR$(34)+"', got EOF":GOTO READ_FORM_RETURN + J=2:R$="" + READ_STRING_LOOP: + #qbasic I=INSTR(J,T$,CHR$(92)) + #cbm I=J + #cbm INSTR_LOOP: + #cbm IF I>LEN(T$) THEN I=0:GOTO INSTR_DONE + #cbm IF MID$(T$,I,1)=CHR$(92) THEN GOTO INSTR_DONE + #cbm I=I+1 + #cbm GOTO INSTR_LOOP + #cbm INSTR_DONE: + IF I=0 THEN GOTO READ_STRING_DONE + R$=R$+MID$(T$,J,I-J) + C$=MID$(T$,I+1,1) + #qbasic IF C$="n" THEN R$=R$+CHR$(10) ELSE R$=R$+C$ + #cbm IF C$="n" THEN R$=R$+CHR$(13) + #cbm IF C$<>"n" THEN R$=R$+C$ + J=I+2 + GOTO READ_STRING_LOOP + READ_STRING_DONE: + IF J=LEN(T$)+1 THEN R=-1:ER=-1:E$="expected '"+CHR$(34)+"', got EOF":GOTO READ_FORM_RETURN + R$=R$+MID$(T$,J,LEN(T$)-J) + REM intern string value + B$=R$:T=4:GOSUB STRING + GOTO READ_FORM_RETURN + READ_KEYWORD: + R$=CHR$(127)+MID$(T$,2,LEN(T$)-1) + B$=R$:T=4:GOSUB STRING + GOTO READ_FORM_RETURN + READ_SYMBOL_MAYBE: + C$=MID$(T$,2,1) + IF C$>="0" AND C$<="9" THEN GOTO READ_NUMBER + READ_SYMBOL: + REM PRINT "READ_SYMBOL" + B$=T$:T=5:GOSUB STRING + GOTO READ_FORM_RETURN + + READ_SEQ_START: + SD=SD+1 + + GOSUB PUSH_Q: REM push return character + + REM setup the stack for the loop, T has type + GOSUB MAP_LOOP_START + + READ_SEQ_LOOP: + + REM TODO: reduce redundancy with READ_TOKEN + GOSUB SKIP_SPACES + GOSUB PEEK_CHAR: REM peek at next character + IF C$="" THEN ER=-1:E$="unexpected EOF":GOTO READ_SEQ_DONE + IF C$=";" THEN GOSUB SKIP_TO_EOL:GOTO READ_SEQ_LOOP + Q=3:GOSUB PEEK_Q_Q + IF C$=CHR$(Q) THEN GOSUB READ_CHAR:GOTO READ_SEQ_DONE + + CALL READ_FORM + M=R: REM value (or key for hash-maps) + + REM if error, release the unattached element + IF ER<>-2 THEN AY=R:GOSUB RELEASE:GOTO READ_SEQ_DONE + + REM if this is a hash-map, READ_FORM again + IF T=8 THEN GOSUB PUSH_R:CALL READ_FORM + IF T=8 THEN N=R:GOSUB POP_Q:M=Q: REM set key and value + + REM update the return sequence structure + REM release N since list takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + GOTO READ_SEQ_LOOP + + READ_SEQ_DONE: + SD=SD-1 + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + + GOSUB POP_Q: REM pop end character ptr + GOTO READ_FORM_RETURN + + READ_FORM_RETURN: + GOSUB POP_Q:T=Q: REM restore current value of T + +END SUB + + +REM READ_STR(A$) -> R +READ_STR: + RI=1: REM index into A$ + RF=0: REM not reading from file + SD=0: REM sequence read depth + CALL READ_FORM + RETURN + +REM READ_FILE(A$) -> R +READ_FILE: + RF=1: REM reading from file + EZ=0: REM file read state (1: EOF) + SD=0: REM sequence read depth + D$="": REM pending read/peek character + #cbm OPEN 2,8,0,A$ + #qbasic IF NOT _FILEEXISTS(A$) THEN ER=-1:E$="File not found":RETURN + #qbasic OPEN A$ FOR INPUT AS #2 + REM READ_TOKEN adds "(do ... )" + CALL READ_FORM + CLOSE 2 + EZ=0 + RETURN diff --git a/impls/basic/readline.in.bas b/impls/basic/readline.in.bas index 67cbaa76ba..6791831a10 100644 --- a/impls/basic/readline.in.bas +++ b/impls/basic/readline.in.bas @@ -1,4 +1,4 @@ - -#cbm REM $INCLUDE: 'readline_char.in.bas' -#qbasic-ui REM $INCLUDE: 'readline_char.in.bas' -#qbasic-noui REM $INCLUDE: 'readline_line.in.bas' + +#cbm REM $INCLUDE: 'readline_char.in.bas' +#qbasic-ui REM $INCLUDE: 'readline_char.in.bas' +#qbasic-noui REM $INCLUDE: 'readline_line.in.bas' diff --git a/impls/basic/readline_char.in.bas b/impls/basic/readline_char.in.bas index 75b7996343..05effd4d1a 100644 --- a/impls/basic/readline_char.in.bas +++ b/impls/basic/readline_char.in.bas @@ -1,31 +1,31 @@ -REM READLINE(A$) -> R$ -READLINE: - EZ=0 - PRINT A$; - C$="":R$="":C=0 - READCH: - #cbm GET C$ - #qbasic C$=INKEY$ - IF C$="" THEN GOTO READCH - C=ASC(C$) - REM PRINT C - #qbasic IF ASC(C$)=8 THEN C=20:C$=CHR$(20) - IF C=4 OR C=0 THEN EZ=1:GOTO RL_DONE: REM EOF - IF C=127 OR C=20 THEN GOSUB RL_BACKSPACE - IF C=127 OR C=20 THEN GOTO READCH - IF (C<32 OR C>127) AND C<>13 THEN GOTO READCH - PRINT C$; - IF LEN(R$)<255 AND C$<>CHR$(13) THEN R$=R$+C$ - IF LEN(R$)<255 AND C$<>CHR$(13) THEN GOTO READCH - RL_DONE: - RETURN - - REM Assumes R$ has input buffer - RL_BACKSPACE: - IF LEN(R$)=0 THEN RETURN - R$=LEFT$(R$,LEN(R$)-1) - #cbm PRINT CHR$(157)+" "+CHR$(157); - #qbasic LOCATE ,POS(0)-1 - #qbasic PRINT " "; - #qbasic LOCATE ,POS(0)-1 - RETURN +REM READLINE(A$) -> R$ +READLINE: + EZ=0 + PRINT A$; + C$="":R$="":C=0 + READCH: + #cbm GET C$ + #qbasic C$=INKEY$ + IF C$="" THEN GOTO READCH + C=ASC(C$) + REM PRINT C + #qbasic IF ASC(C$)=8 THEN C=20:C$=CHR$(20) + IF C=4 OR C=0 THEN EZ=1:GOTO RL_DONE: REM EOF + IF C=127 OR C=20 THEN GOSUB RL_BACKSPACE + IF C=127 OR C=20 THEN GOTO READCH + IF (C<32 OR C>127) AND C<>13 THEN GOTO READCH + PRINT C$; + IF LEN(R$)<255 AND C$<>CHR$(13) THEN R$=R$+C$ + IF LEN(R$)<255 AND C$<>CHR$(13) THEN GOTO READCH + RL_DONE: + RETURN + + REM Assumes R$ has input buffer + RL_BACKSPACE: + IF LEN(R$)=0 THEN RETURN + R$=LEFT$(R$,LEN(R$)-1) + #cbm PRINT CHR$(157)+" "+CHR$(157); + #qbasic LOCATE ,POS(0)-1 + #qbasic PRINT " "; + #qbasic LOCATE ,POS(0)-1 + RETURN diff --git a/impls/basic/readline_line.in.bas b/impls/basic/readline_line.in.bas index 3d65f4172f..39f0681d63 100644 --- a/impls/basic/readline_line.in.bas +++ b/impls/basic/readline_line.in.bas @@ -1,6 +1,6 @@ -REM READLINE(A$) -> R$ -READLINE: - EZ=0 - PRINT A$ ; - LINE INPUT ; R$ - RETURN +REM READLINE(A$) -> R$ +READLINE: + EZ=0 + PRINT A$ ; + LINE INPUT ; R$ + RETURN diff --git a/impls/basic/run b/impls/basic/run index fac3d8c50b..95933506b4 100755 --- a/impls/basic/run +++ b/impls/basic/run @@ -1,8 +1,8 @@ -#!/bin/bash -cd $(dirname $0) -(echo "(def! -*ARGS*- (list $(for a in "${@}"; do echo -n " \"${a}\""; done)))") > .args.mal -case ${basic_MODE:-cbm} in - cbm) exec cbmbasic ${STEP:-stepA_mal}.bas "${@}" ;; - qbasic) exec ./${STEP:-stepA_mal} "${@}" ;; - *) echo "Invalid basic_MODE: ${basic_MODE}"; exit 2 ;; -esac +#!/bin/bash +cd $(dirname $0) +(echo "(def! -*ARGS*- (list $(for a in "${@}"; do echo -n " \"${a}\""; done)))") > .args.mal +case ${basic_MODE:-cbm} in + cbm) exec cbmbasic ${STEP:-stepA_mal}.bas "${@}" ;; + qbasic) exec ./${STEP:-stepA_mal} "${@}" ;; + *) echo "Invalid basic_MODE: ${basic_MODE}"; exit 2 ;; +esac diff --git a/impls/basic/step0_repl.in.bas b/impls/basic/step0_repl.in.bas index a7c3e74b2b..c6aaf80378 100755 --- a/impls/basic/step0_repl.in.bas +++ b/impls/basic/step0_repl.in.bas @@ -1,44 +1,44 @@ -GOTO MAIN - -REM $INCLUDE: 'readline.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R$ -MAL_READ: - R$=A$ - RETURN - -REM EVAL(A$, E) -> R$ -EVAL: - R$=A$ - RETURN - -REM PRINT(A$) -> R$ -MAL_PRINT: - R$=A$ - RETURN - -REM REP(A$) -> R$ -REP: - GOSUB MAL_READ - A=R:GOSUB EVAL - A=R:GOSUB MAL_PRINT - RETURN - -REM MAIN program -MAIN: - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - - A$=R$:GOSUB REP: REM call REP - - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - +GOTO MAIN + +REM $INCLUDE: 'readline.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R$ +MAL_READ: + R$=A$ + RETURN + +REM EVAL(A$, E) -> R$ +EVAL: + R$=A$ + RETURN + +REM PRINT(A$) -> R$ +MAL_PRINT: + R$=A$ + RETURN + +REM REP(A$) -> R$ +REP: + GOSUB MAL_READ + A=R:GOSUB EVAL + A=R:GOSUB MAL_PRINT + RETURN + +REM MAIN program +MAIN: + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + + A$=R$:GOSUB REP: REM call REP + + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + diff --git a/impls/basic/step1_read_print.in.bas b/impls/basic/step1_read_print.in.bas index aa0c45f310..9f2f37df5a 100755 --- a/impls/basic/step1_read_print.in.bas +++ b/impls/basic/step1_read_print.in.bas @@ -1,67 +1,67 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R -MAL_READ: - GOSUB READ_STR - RETURN - -REM EVAL(A, E) -> R -SUB EVAL - R=A -END SUB - -REM PRINT(A) -> R$ -MAL_PRINT: - AZ=A:B=1:GOSUB PR_STR - RETURN - -REM REP(A$) -> R$ -SUB REP - GOSUB MAL_READ - IF ER<>-2 THEN GOTO REP_DONE - - A=R:CALL EVAL - IF ER<>-2 THEN GOTO REP_DONE - - A=R:GOSUB MAL_PRINT - - REP_DONE: - REM Release memory from EVAL - AY=R:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - ZT=ZI: REM top of memory after base repl_env - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R +MAL_READ: + GOSUB READ_STR + RETURN + +REM EVAL(A, E) -> R +SUB EVAL + R=A +END SUB + +REM PRINT(A) -> R$ +MAL_PRINT: + AZ=A:B=1:GOSUB PR_STR + RETURN + +REM REP(A$) -> R$ +SUB REP + GOSUB MAL_READ + IF ER<>-2 THEN GOTO REP_DONE + + A=R:CALL EVAL + IF ER<>-2 THEN GOTO REP_DONE + + A=R:GOSUB MAL_PRINT + + REP_DONE: + REM Release memory from EVAL + AY=R:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + ZT=ZI: REM top of memory after base repl_env + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/step2_eval.in.bas b/impls/basic/step2_eval.in.bas index 062f83cd3f..c92db7c270 100755 --- a/impls/basic/step2_eval.in.bas +++ b/impls/basic/step2_eval.in.bas @@ -1,252 +1,252 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R -MAL_READ: - GOSUB READ_STR - RETURN - -REM EVAL_AST(A, E) -> R -SUB EVAL_AST - LV=LV+1 - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_AST_RETURN - - GOSUB TYPE_A - IF T=5 THEN GOTO EVAL_AST_SYMBOL - IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ - - REM scalar: deref to actual value and inc ref cnt - R=A - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SYMBOL: - H=E:K=A:GOSUB HASHMAP_GET - IF R3=0 THEN R=-1:ER=-1:E$="'"+S$(Z%(A+1))+"' not found":GOTO EVAL_AST_RETURN - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SEQ: - REM setup the stack for the loop - GOSUB MAP_LOOP_START - - EVAL_AST_SEQ_LOOP: - REM check if we are done evaluating the source sequence - IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM call EVAL for each entry - GOSUB PUSH_A - IF T<>8 THEN A=Z%(A+2) - IF T=8 THEN A=Z%(A+3) - Q=T:GOSUB PUSH_Q: REM push/save type - CALL EVAL - GOSUB POP_Q:T=Q: REM pop/restore type - GOSUB POP_A - M=R - - REM if error, release the unattached element - REM TODO: is R=0 correct? - IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE - - REM for hash-maps, copy the key (inc ref since we are going to - REM release it below) - IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 - - - REM update the return sequence structure - REM release N (and M if T=8) since seq takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - REM process the next sequence entry from source list - A=Z%(A+1) - - GOTO EVAL_AST_SEQ_LOOP - EVAL_AST_SEQ_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO EVAL_AST_RETURN - - EVAL_AST_RETURN: - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - - LV=LV-1 -END SUB - -REM EVAL(A, E) -> R -SUB EVAL - LV=LV+1: REM track basic return stack level - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM AZ=A:B=1:GOSUB PR_STR - REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" - - GOSUB LIST_Q - IF R THEN GOTO APPLY_LIST - REM ELSE - CALL EVAL_AST - GOTO EVAL_RETURN - - APPLY_LIST: - GOSUB EMPTY_Q - IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN - - EVAL_INVOKE: - CALL EVAL_AST - W=R - - REM if error, return f/args for release by caller - IF ER<>-2 THEN GOTO EVAL_RETURN - - AR=Z%(R+1): REM rest - F=Z%(R+2) - - GOSUB TYPE_F - IF T<>9 THEN R=-1:ER=-1:E$="apply of non-function":GOTO EVAL_INVOKE_DONE - GOSUB DO_FUNCTION - EVAL_INVOKE_DONE: - AY=W:GOSUB RELEASE - GOTO EVAL_RETURN - - EVAL_RETURN: - - LV=LV-1: REM track basic return stack level - - REM trigger GC - #cbm T=FRE(0) - #qbasic T=0 - - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - -END SUB - -REM DO_FUNCTION(F, AR) -DO_FUNCTION: - AZ=F:GOSUB PR_STR - F$=R$ - AZ=AR:GOSUB PR_STR - AR$=R$ - - REM Get the function number - G=Z%(F+1) - - REM Get argument values - A=Z%(Z%(AR+2)+1) - B=Z%(Z%(Z%(AR+1)+2)+1) - - REM Switch on the function number - IF G=1 THEN GOTO DO_ADD - IF G=2 THEN GOTO DO_SUB - IF G=3 THEN GOTO DO_MULT - IF G=4 THEN GOTO DO_DIV - ER=-1:E$="unknown function"+STR$(G):RETURN - - DO_ADD: - T=2:L=A+B:GOSUB ALLOC - GOTO DO_FUNCTION_DONE - DO_SUB: - T=2:L=A-B:GOSUB ALLOC - GOTO DO_FUNCTION_DONE - DO_MULT: - T=2:L=A*B:GOSUB ALLOC - GOTO DO_FUNCTION_DONE - DO_DIV: - T=2:L=A/B:GOSUB ALLOC - GOTO DO_FUNCTION_DONE - - DO_FUNCTION_DONE: - RETURN - -REM PRINT(A) -> R$ -MAL_PRINT: - AZ=A:B=1:GOSUB PR_STR - RETURN - -REM REP(A$) -> R$ -REM Assume D has repl_env -SUB REP - R1=-1:R2=-1 - GOSUB MAL_READ - R1=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:E=D:CALL EVAL - R2=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:GOSUB MAL_PRINT - - REP_DONE: - REM Release memory from MAL_READ and EVAL - AY=R2:GOSUB RELEASE - AY=R1:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - LV=0 - - REM create repl_env - GOSUB HASHMAP:D=R - - REM + function - T=9:L=1:GOSUB ALLOC: REM native function - H=D:B$="+":C=R:GOSUB ASSOC1_S:D=R - - REM - function - T=9:L=2:GOSUB ALLOC: REM native function - H=D:B$="-":C=R:GOSUB ASSOC1_S:D=R - - REM * function - T=9:L=3:GOSUB ALLOC: REM native function - H=D:B$="*":C=R:GOSUB ASSOC1_S:D=R - - REM / function - T=9:L=4:GOSUB ALLOC: REM native function - H=D:B$="/":C=R:GOSUB ASSOC1_S:D=R - - ZT=ZI: REM top of memory after base repl_env - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R +MAL_READ: + GOSUB READ_STR + RETURN + +REM EVAL_AST(A, E) -> R +SUB EVAL_AST + LV=LV+1 + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_AST_RETURN + + GOSUB TYPE_A + IF T=5 THEN GOTO EVAL_AST_SYMBOL + IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ + + REM scalar: deref to actual value and inc ref cnt + R=A + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SYMBOL: + H=E:K=A:GOSUB HASHMAP_GET + IF R3=0 THEN R=-1:ER=-1:E$="'"+S$(Z%(A+1))+"' not found":GOTO EVAL_AST_RETURN + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SEQ: + REM setup the stack for the loop + GOSUB MAP_LOOP_START + + EVAL_AST_SEQ_LOOP: + REM check if we are done evaluating the source sequence + IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM call EVAL for each entry + GOSUB PUSH_A + IF T<>8 THEN A=Z%(A+2) + IF T=8 THEN A=Z%(A+3) + Q=T:GOSUB PUSH_Q: REM push/save type + CALL EVAL + GOSUB POP_Q:T=Q: REM pop/restore type + GOSUB POP_A + M=R + + REM if error, release the unattached element + REM TODO: is R=0 correct? + IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE + + REM for hash-maps, copy the key (inc ref since we are going to + REM release it below) + IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 + + + REM update the return sequence structure + REM release N (and M if T=8) since seq takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + REM process the next sequence entry from source list + A=Z%(A+1) + + GOTO EVAL_AST_SEQ_LOOP + EVAL_AST_SEQ_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO EVAL_AST_RETURN + + EVAL_AST_RETURN: + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + + LV=LV-1 +END SUB + +REM EVAL(A, E) -> R +SUB EVAL + LV=LV+1: REM track basic return stack level + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM AZ=A:B=1:GOSUB PR_STR + REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" + + GOSUB LIST_Q + IF R THEN GOTO APPLY_LIST + REM ELSE + CALL EVAL_AST + GOTO EVAL_RETURN + + APPLY_LIST: + GOSUB EMPTY_Q + IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN + + EVAL_INVOKE: + CALL EVAL_AST + W=R + + REM if error, return f/args for release by caller + IF ER<>-2 THEN GOTO EVAL_RETURN + + AR=Z%(R+1): REM rest + F=Z%(R+2) + + GOSUB TYPE_F + IF T<>9 THEN R=-1:ER=-1:E$="apply of non-function":GOTO EVAL_INVOKE_DONE + GOSUB DO_FUNCTION + EVAL_INVOKE_DONE: + AY=W:GOSUB RELEASE + GOTO EVAL_RETURN + + EVAL_RETURN: + + LV=LV-1: REM track basic return stack level + + REM trigger GC + #cbm T=FRE(0) + #qbasic T=0 + + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + +END SUB + +REM DO_FUNCTION(F, AR) +DO_FUNCTION: + AZ=F:GOSUB PR_STR + F$=R$ + AZ=AR:GOSUB PR_STR + AR$=R$ + + REM Get the function number + G=Z%(F+1) + + REM Get argument values + A=Z%(Z%(AR+2)+1) + B=Z%(Z%(Z%(AR+1)+2)+1) + + REM Switch on the function number + IF G=1 THEN GOTO DO_ADD + IF G=2 THEN GOTO DO_SUB + IF G=3 THEN GOTO DO_MULT + IF G=4 THEN GOTO DO_DIV + ER=-1:E$="unknown function"+STR$(G):RETURN + + DO_ADD: + T=2:L=A+B:GOSUB ALLOC + GOTO DO_FUNCTION_DONE + DO_SUB: + T=2:L=A-B:GOSUB ALLOC + GOTO DO_FUNCTION_DONE + DO_MULT: + T=2:L=A*B:GOSUB ALLOC + GOTO DO_FUNCTION_DONE + DO_DIV: + T=2:L=A/B:GOSUB ALLOC + GOTO DO_FUNCTION_DONE + + DO_FUNCTION_DONE: + RETURN + +REM PRINT(A) -> R$ +MAL_PRINT: + AZ=A:B=1:GOSUB PR_STR + RETURN + +REM REP(A$) -> R$ +REM Assume D has repl_env +SUB REP + R1=-1:R2=-1 + GOSUB MAL_READ + R1=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:E=D:CALL EVAL + R2=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:GOSUB MAL_PRINT + + REP_DONE: + REM Release memory from MAL_READ and EVAL + AY=R2:GOSUB RELEASE + AY=R1:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + LV=0 + + REM create repl_env + GOSUB HASHMAP:D=R + + REM + function + T=9:L=1:GOSUB ALLOC: REM native function + H=D:B$="+":C=R:GOSUB ASSOC1_S:D=R + + REM - function + T=9:L=2:GOSUB ALLOC: REM native function + H=D:B$="-":C=R:GOSUB ASSOC1_S:D=R + + REM * function + T=9:L=3:GOSUB ALLOC: REM native function + H=D:B$="*":C=R:GOSUB ASSOC1_S:D=R + + REM / function + T=9:L=4:GOSUB ALLOC: REM native function + H=D:B$="/":C=R:GOSUB ASSOC1_S:D=R + + ZT=ZI: REM top of memory after base repl_env + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/step3_env.in.bas b/impls/basic/step3_env.in.bas index 8340fd2732..af304d5b65 100755 --- a/impls/basic/step3_env.in.bas +++ b/impls/basic/step3_env.in.bas @@ -1,313 +1,313 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' -REM $INCLUDE: 'env.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R -MAL_READ: - GOSUB READ_STR - RETURN - -REM EVAL_AST(A, E) -> R -SUB EVAL_AST - LV=LV+1 - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_AST_RETURN - - GOSUB TYPE_A - IF T=5 THEN GOTO EVAL_AST_SYMBOL - IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ - - REM scalar: deref to actual value and inc ref cnt - R=A - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SYMBOL: - K=A:GOTO ENV_GET - ENV_GET_RETURN: - GOTO EVAL_AST_RETURN - - EVAL_AST_SEQ: - REM setup the stack for the loop - GOSUB MAP_LOOP_START - - EVAL_AST_SEQ_LOOP: - REM check if we are done evaluating the source sequence - IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM call EVAL for each entry - GOSUB PUSH_A - IF T<>8 THEN A=Z%(A+2) - IF T=8 THEN A=Z%(A+3) - Q=T:GOSUB PUSH_Q: REM push/save type - CALL EVAL - GOSUB POP_Q:T=Q: REM pop/restore type - GOSUB POP_A - M=R - - REM if error, release the unattached element - REM TODO: is R=0 correct? - IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE - - REM for hash-maps, copy the key (inc ref since we are going to - REM release it below) - IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 - - - REM update the return sequence structure - REM release N (and M if T=8) since seq takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - REM process the next sequence entry from source list - A=Z%(A+1) - - GOTO EVAL_AST_SEQ_LOOP - EVAL_AST_SEQ_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO EVAL_AST_RETURN - - EVAL_AST_RETURN: - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - - LV=LV-1 -END SUB - -REM EVAL(A, E) -> R -SUB EVAL - LV=LV+1: REM track basic return stack level - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM AZ=A:B=1:GOSUB PR_STR - REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" - - GOSUB LIST_Q - IF R THEN GOTO APPLY_LIST - REM ELSE - CALL EVAL_AST - GOTO EVAL_RETURN - - APPLY_LIST: - GOSUB EMPTY_Q - IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN - - A0=Z%(A+2) - - REM get symbol in A$ - IF (Z%(A0)AND 31)<>5 THEN A$="" - IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) - - IF A$="def!" THEN GOTO EVAL_DEF - IF A$="let*" THEN GOTO EVAL_LET - GOTO EVAL_INVOKE - - EVAL_GET_A3: - A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) - EVAL_GET_A2: - A2=Z%(Z%(Z%(A+1)+1)+2) - EVAL_GET_A1: - A1=Z%(Z%(A+1)+2) - RETURN - - EVAL_DEF: - REM PRINT "def!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q - A=A2:CALL EVAL: REM eval a2 - GOSUB POP_Q:A1=Q - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM set a1 in env to a2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_LET: - REM PRINT "let*" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A2:GOSUB PUSH_Q: REM push/save A2 - REM create new environment with outer as current environment - C=E:GOSUB ENV_NEW - E=R - EVAL_LET_LOOP: - IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE - - Q=A1:GOSUB PUSH_Q: REM push A1 - REM eval current A1 odd element - A=Z%(Z%(A1+1)+2):CALL EVAL - GOSUB POP_Q:A1=Q: REM pop A1 - - IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE - - REM set key/value in the environment - K=Z%(A1+2):C=R:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership - - REM skip to the next pair of A1 elements - A1=Z%(Z%(A1+1)+1) - GOTO EVAL_LET_LOOP - - EVAL_LET_LOOP_DONE: - GOSUB POP_Q:A2=Q: REM pop A2 - A=A2:CALL EVAL: REM eval A2 using let_env - GOTO EVAL_RETURN - EVAL_INVOKE: - CALL EVAL_AST - W=R - - REM if error, return f/args for release by caller - IF ER<>-2 THEN GOTO EVAL_RETURN - - AR=Z%(R+1): REM rest - F=Z%(R+2) - - GOSUB TYPE_F - IF T<>9 THEN R=-1:ER=-1:E$="apply of non-function":GOTO EVAL_INVOKE_DONE - GOSUB DO_FUNCTION - EVAL_INVOKE_DONE: - AY=W:GOSUB RELEASE - GOTO EVAL_RETURN - - EVAL_RETURN: - REM release environment if not the top one on the stack - GOSUB PEEK_Q_1 - IF E<>Q THEN AY=E:GOSUB RELEASE - - LV=LV-1: REM track basic return stack level - - REM trigger GC - #cbm T=FRE(0) - #qbasic T=0 - - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - -END SUB - -REM DO_FUNCTION(F, AR) -DO_FUNCTION: - REM Get the function number - G=Z%(F+1) - - REM Get argument values - A=Z%(Z%(AR+2)+1) - B=Z%(Z%(Z%(AR+1)+2)+1) - - REM Switch on the function number - IF G=1 THEN GOTO DO_ADD - IF G=2 THEN GOTO DO_SUB - IF G=3 THEN GOTO DO_MULT - IF G=4 THEN GOTO DO_DIV - ER=-1:E$="unknown function"+STR$(G):RETURN - - DO_ADD: - T=2:L=A+B:GOSUB ALLOC - GOTO DO_FUNCTION_DONE - DO_SUB: - T=2:L=A-B:GOSUB ALLOC - GOTO DO_FUNCTION_DONE - DO_MULT: - T=2:L=A*B:GOSUB ALLOC - GOTO DO_FUNCTION_DONE - DO_DIV: - T=2:L=A/B:GOSUB ALLOC - GOTO DO_FUNCTION_DONE - - DO_FUNCTION_DONE: - RETURN - -REM PRINT(A) -> R$ -MAL_PRINT: - AZ=A:B=1:GOSUB PR_STR - RETURN - -REM REP(A$) -> R$ -REM Assume D has repl_env -SUB REP - R1=-1:R2=-1 - GOSUB MAL_READ - R1=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:E=D:CALL EVAL - R2=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:GOSUB MAL_PRINT - - REP_DONE: - REM Release memory from MAL_READ and EVAL - AY=R2:GOSUB RELEASE - AY=R1:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - LV=0 - - REM create repl_env - C=0:GOSUB ENV_NEW:D=R - - E=D - REM + function - T=9:L=1:GOSUB ALLOC: REM native function - B$="+":C=R:GOSUB ENV_SET_S - - REM - function - T=9:L=2:GOSUB ALLOC: REM native function - B$="-":C=R:GOSUB ENV_SET_S - - REM * function - T=9:L=3:GOSUB ALLOC: REM native function - B$="*":C=R:GOSUB ENV_SET_S - - REM / function - T=9:L=4:GOSUB ALLOC: REM native function - B$="/":C=R:GOSUB ENV_SET_S - - ZT=ZI: REM top of memory after base repl_env - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' +REM $INCLUDE: 'env.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R +MAL_READ: + GOSUB READ_STR + RETURN + +REM EVAL_AST(A, E) -> R +SUB EVAL_AST + LV=LV+1 + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_AST_RETURN + + GOSUB TYPE_A + IF T=5 THEN GOTO EVAL_AST_SYMBOL + IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ + + REM scalar: deref to actual value and inc ref cnt + R=A + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SYMBOL: + K=A:GOTO ENV_GET + ENV_GET_RETURN: + GOTO EVAL_AST_RETURN + + EVAL_AST_SEQ: + REM setup the stack for the loop + GOSUB MAP_LOOP_START + + EVAL_AST_SEQ_LOOP: + REM check if we are done evaluating the source sequence + IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM call EVAL for each entry + GOSUB PUSH_A + IF T<>8 THEN A=Z%(A+2) + IF T=8 THEN A=Z%(A+3) + Q=T:GOSUB PUSH_Q: REM push/save type + CALL EVAL + GOSUB POP_Q:T=Q: REM pop/restore type + GOSUB POP_A + M=R + + REM if error, release the unattached element + REM TODO: is R=0 correct? + IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE + + REM for hash-maps, copy the key (inc ref since we are going to + REM release it below) + IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 + + + REM update the return sequence structure + REM release N (and M if T=8) since seq takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + REM process the next sequence entry from source list + A=Z%(A+1) + + GOTO EVAL_AST_SEQ_LOOP + EVAL_AST_SEQ_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO EVAL_AST_RETURN + + EVAL_AST_RETURN: + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + + LV=LV-1 +END SUB + +REM EVAL(A, E) -> R +SUB EVAL + LV=LV+1: REM track basic return stack level + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM AZ=A:B=1:GOSUB PR_STR + REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" + + GOSUB LIST_Q + IF R THEN GOTO APPLY_LIST + REM ELSE + CALL EVAL_AST + GOTO EVAL_RETURN + + APPLY_LIST: + GOSUB EMPTY_Q + IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN + + A0=Z%(A+2) + + REM get symbol in A$ + IF (Z%(A0)AND 31)<>5 THEN A$="" + IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) + + IF A$="def!" THEN GOTO EVAL_DEF + IF A$="let*" THEN GOTO EVAL_LET + GOTO EVAL_INVOKE + + EVAL_GET_A3: + A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) + EVAL_GET_A2: + A2=Z%(Z%(Z%(A+1)+1)+2) + EVAL_GET_A1: + A1=Z%(Z%(A+1)+2) + RETURN + + EVAL_DEF: + REM PRINT "def!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q + A=A2:CALL EVAL: REM eval a2 + GOSUB POP_Q:A1=Q + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM set a1 in env to a2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_LET: + REM PRINT "let*" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A2:GOSUB PUSH_Q: REM push/save A2 + REM create new environment with outer as current environment + C=E:GOSUB ENV_NEW + E=R + EVAL_LET_LOOP: + IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE + + Q=A1:GOSUB PUSH_Q: REM push A1 + REM eval current A1 odd element + A=Z%(Z%(A1+1)+2):CALL EVAL + GOSUB POP_Q:A1=Q: REM pop A1 + + IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE + + REM set key/value in the environment + K=Z%(A1+2):C=R:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership + + REM skip to the next pair of A1 elements + A1=Z%(Z%(A1+1)+1) + GOTO EVAL_LET_LOOP + + EVAL_LET_LOOP_DONE: + GOSUB POP_Q:A2=Q: REM pop A2 + A=A2:CALL EVAL: REM eval A2 using let_env + GOTO EVAL_RETURN + EVAL_INVOKE: + CALL EVAL_AST + W=R + + REM if error, return f/args for release by caller + IF ER<>-2 THEN GOTO EVAL_RETURN + + AR=Z%(R+1): REM rest + F=Z%(R+2) + + GOSUB TYPE_F + IF T<>9 THEN R=-1:ER=-1:E$="apply of non-function":GOTO EVAL_INVOKE_DONE + GOSUB DO_FUNCTION + EVAL_INVOKE_DONE: + AY=W:GOSUB RELEASE + GOTO EVAL_RETURN + + EVAL_RETURN: + REM release environment if not the top one on the stack + GOSUB PEEK_Q_1 + IF E<>Q THEN AY=E:GOSUB RELEASE + + LV=LV-1: REM track basic return stack level + + REM trigger GC + #cbm T=FRE(0) + #qbasic T=0 + + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + +END SUB + +REM DO_FUNCTION(F, AR) +DO_FUNCTION: + REM Get the function number + G=Z%(F+1) + + REM Get argument values + A=Z%(Z%(AR+2)+1) + B=Z%(Z%(Z%(AR+1)+2)+1) + + REM Switch on the function number + IF G=1 THEN GOTO DO_ADD + IF G=2 THEN GOTO DO_SUB + IF G=3 THEN GOTO DO_MULT + IF G=4 THEN GOTO DO_DIV + ER=-1:E$="unknown function"+STR$(G):RETURN + + DO_ADD: + T=2:L=A+B:GOSUB ALLOC + GOTO DO_FUNCTION_DONE + DO_SUB: + T=2:L=A-B:GOSUB ALLOC + GOTO DO_FUNCTION_DONE + DO_MULT: + T=2:L=A*B:GOSUB ALLOC + GOTO DO_FUNCTION_DONE + DO_DIV: + T=2:L=A/B:GOSUB ALLOC + GOTO DO_FUNCTION_DONE + + DO_FUNCTION_DONE: + RETURN + +REM PRINT(A) -> R$ +MAL_PRINT: + AZ=A:B=1:GOSUB PR_STR + RETURN + +REM REP(A$) -> R$ +REM Assume D has repl_env +SUB REP + R1=-1:R2=-1 + GOSUB MAL_READ + R1=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:E=D:CALL EVAL + R2=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:GOSUB MAL_PRINT + + REP_DONE: + REM Release memory from MAL_READ and EVAL + AY=R2:GOSUB RELEASE + AY=R1:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + LV=0 + + REM create repl_env + C=0:GOSUB ENV_NEW:D=R + + E=D + REM + function + T=9:L=1:GOSUB ALLOC: REM native function + B$="+":C=R:GOSUB ENV_SET_S + + REM - function + T=9:L=2:GOSUB ALLOC: REM native function + B$="-":C=R:GOSUB ENV_SET_S + + REM * function + T=9:L=3:GOSUB ALLOC: REM native function + B$="*":C=R:GOSUB ENV_SET_S + + REM / function + T=9:L=4:GOSUB ALLOC: REM native function + B$="/":C=R:GOSUB ENV_SET_S + + ZT=ZI: REM top of memory after base repl_env + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/step4_if_fn_do.in.bas b/impls/basic/step4_if_fn_do.in.bas index c5a1a9d829..b916c2da0e 100755 --- a/impls/basic/step4_if_fn_do.in.bas +++ b/impls/basic/step4_if_fn_do.in.bas @@ -1,371 +1,371 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' -REM $INCLUDE: 'env.in.bas' -REM $INCLUDE: 'core.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R -MAL_READ: - GOSUB READ_STR - RETURN - -REM EVAL_AST(A, E) -> R -SUB EVAL_AST - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_AST_RETURN - - GOSUB TYPE_A - IF T=5 THEN GOTO EVAL_AST_SYMBOL - IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ - - REM scalar: deref to actual value and inc ref cnt - R=A - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SYMBOL: - K=A:GOTO ENV_GET - ENV_GET_RETURN: - GOTO EVAL_AST_RETURN - - EVAL_AST_SEQ: - REM setup the stack for the loop - GOSUB MAP_LOOP_START - - EVAL_AST_SEQ_LOOP: - REM check if we are done evaluating the source sequence - IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM call EVAL for each entry - GOSUB PUSH_A - IF T<>8 THEN A=Z%(A+2) - IF T=8 THEN A=Z%(A+3) - Q=T:GOSUB PUSH_Q: REM push/save type - CALL EVAL - GOSUB POP_Q:T=Q: REM pop/restore type - GOSUB POP_A - M=R - - REM if error, release the unattached element - REM TODO: is R=0 correct? - IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE - - REM for hash-maps, copy the key (inc ref since we are going to - REM release it below) - IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 - - - REM update the return sequence structure - REM release N (and M if T=8) since seq takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - REM process the next sequence entry from source list - A=Z%(A+1) - - GOTO EVAL_AST_SEQ_LOOP - EVAL_AST_SEQ_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO EVAL_AST_RETURN - - EVAL_AST_RETURN: - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q -END SUB - -REM EVAL(A, E) -> R -SUB EVAL - LV=LV+1: REM track basic return stack level - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) - - EVAL_TCO_RECUR: - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM AZ=A:B=1:GOSUB PR_STR - REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" - - GOSUB LIST_Q - IF R THEN GOTO APPLY_LIST - REM ELSE - CALL EVAL_AST - GOTO EVAL_RETURN - - APPLY_LIST: - GOSUB EMPTY_Q - IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN - - A0=Z%(A+2) - - REM get symbol in A$ - IF (Z%(A0)AND 31)<>5 THEN A$="" - IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) - - IF A$="def!" THEN GOTO EVAL_DEF - IF A$="let*" THEN GOTO EVAL_LET - IF A$="do" THEN GOTO EVAL_DO - IF A$="if" THEN GOTO EVAL_IF - IF A$="fn*" THEN GOTO EVAL_FN - GOTO EVAL_INVOKE - - EVAL_GET_A3: - A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) - EVAL_GET_A2: - A2=Z%(Z%(Z%(A+1)+1)+2) - EVAL_GET_A1: - A1=Z%(Z%(A+1)+2) - RETURN - - EVAL_DEF: - REM PRINT "def!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q - A=A2:CALL EVAL: REM eval a2 - GOSUB POP_Q:A1=Q - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM set a1 in env to a2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_LET: - REM PRINT "let*" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A2:GOSUB PUSH_Q: REM push/save A2 - REM create new environment with outer as current environment - C=E:GOSUB ENV_NEW - E=R - EVAL_LET_LOOP: - IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE - - Q=A1:GOSUB PUSH_Q: REM push A1 - REM eval current A1 odd element - A=Z%(Z%(A1+1)+2):CALL EVAL - GOSUB POP_Q:A1=Q: REM pop A1 - - IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE - - REM set key/value in the environment - K=Z%(A1+2):C=R:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership - - REM skip to the next pair of A1 elements - A1=Z%(Z%(A1+1)+1) - GOTO EVAL_LET_LOOP - - EVAL_LET_LOOP_DONE: - GOSUB POP_Q:A2=Q: REM pop A2 - A=A2:CALL EVAL: REM eval A2 using let_env - GOTO EVAL_RETURN - EVAL_DO: - A=Z%(A+1): REM rest - - CALL EVAL_AST - - GOSUB PUSH_R: REM push eval'd list - A=R:GOSUB LAST: REM return the last element - GOSUB POP_Q:AY=Q: REM pop eval'd list - GOSUB RELEASE: REM release the eval'd list - GOTO EVAL_RETURN - - EVAL_IF: - GOSUB EVAL_GET_A1: REM set A1 - GOSUB PUSH_A: REM push/save A - A=A1:CALL EVAL - GOSUB POP_A: REM pop/restore A - IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE - - EVAL_IF_TRUE: - AY=R:GOSUB RELEASE - GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - EVAL_IF_FALSE: - AY=R:GOSUB RELEASE - REM if no false case (A3), return nil - GOSUB COUNT - IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN - GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL - A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_FN: - GOSUB EVAL_GET_A2: REM set A1 and A2 - T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function - GOTO EVAL_RETURN - - EVAL_INVOKE: - CALL EVAL_AST - - REM if error, return f/args for release by caller - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM push f/args for release after call - GOSUB PUSH_R - - AR=Z%(R+1): REM rest - F=Z%(R+2) - - REM if metadata, get the actual object - GOSUB TYPE_F - IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F - - ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION - - REM if error, pop and return f/args for release by caller - GOSUB POP_R - ER=-1:E$="apply of non-function":GOTO EVAL_RETURN - - EVAL_DO_FUNCTION: - REM regular function - IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP - REM for recur functions (apply, map, swap!), use GOTO - IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION - EVAL_DO_FUNCTION_SKIP: - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - GOTO EVAL_RETURN - - EVAL_DO_MAL_FUNCTION: - Q=E:GOSUB PUSH_Q: REM save the current environment for release - - REM create new environ using env and params stored in function - C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS - - REM release previous env if it is not the top one on the - REM stack (X%(X-2)) because our new env refers to it and - REM we no longer need to track it (since we are TCO recurring) - GOSUB POP_Q:AY=Q - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - REM claim the AST before releasing the list containing it - A=Z%(F+1):Z%(A)=Z%(A)+32 - REM add AST to pending release queue to free as soon as EVAL - REM actually returns (LV+1) - LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - - REM A set above - E=R:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_RETURN: - REM AZ=R: B=1: GOSUB PR_STR - REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) - - REM release environment if not the top one on the stack - GOSUB PEEK_Q_1 - IF E<>Q THEN AY=E:GOSUB RELEASE - - LV=LV-1: REM track basic return stack level - - REM release everything we couldn't release earlier - GOSUB RELEASE_PEND - - REM trigger GC - #cbm T=FRE(0) - #qbasic T=0 - - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - -END SUB - -REM PRINT(A) -> R$ -MAL_PRINT: - AZ=A:B=1:GOSUB PR_STR - RETURN - -REM RE(A$) -> R -REM Assume D has repl_env -REM caller must release result -RE: - R1=-1 - GOSUB MAL_READ - R1=R - IF ER<>-2 THEN GOTO RE_DONE - - A=R:E=D:CALL EVAL - - RE_DONE: - REM Release memory from MAL_READ - AY=R1:GOSUB RELEASE - RETURN: REM caller must release result of EVAL - -REM REP(A$) -> R$ -REM Assume D has repl_env -SUB REP - R2=-1 - - GOSUB RE - R2=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:GOSUB MAL_PRINT - - REP_DONE: - REM Release memory from MAL_READ and EVAL - AY=R2:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - LV=0 - - REM create repl_env - C=0:GOSUB ENV_NEW:D=R - - REM core.EXT: defined in Basic - E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env - - ZT=ZI: REM top of memory after base repl_env - - REM core.mal: defined using the language itself - A$="(def! not (fn* (a) (if a false true)))" - GOSUB RE:AY=R:GOSUB RELEASE - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' +REM $INCLUDE: 'env.in.bas' +REM $INCLUDE: 'core.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R +MAL_READ: + GOSUB READ_STR + RETURN + +REM EVAL_AST(A, E) -> R +SUB EVAL_AST + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_AST_RETURN + + GOSUB TYPE_A + IF T=5 THEN GOTO EVAL_AST_SYMBOL + IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ + + REM scalar: deref to actual value and inc ref cnt + R=A + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SYMBOL: + K=A:GOTO ENV_GET + ENV_GET_RETURN: + GOTO EVAL_AST_RETURN + + EVAL_AST_SEQ: + REM setup the stack for the loop + GOSUB MAP_LOOP_START + + EVAL_AST_SEQ_LOOP: + REM check if we are done evaluating the source sequence + IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM call EVAL for each entry + GOSUB PUSH_A + IF T<>8 THEN A=Z%(A+2) + IF T=8 THEN A=Z%(A+3) + Q=T:GOSUB PUSH_Q: REM push/save type + CALL EVAL + GOSUB POP_Q:T=Q: REM pop/restore type + GOSUB POP_A + M=R + + REM if error, release the unattached element + REM TODO: is R=0 correct? + IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE + + REM for hash-maps, copy the key (inc ref since we are going to + REM release it below) + IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 + + + REM update the return sequence structure + REM release N (and M if T=8) since seq takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + REM process the next sequence entry from source list + A=Z%(A+1) + + GOTO EVAL_AST_SEQ_LOOP + EVAL_AST_SEQ_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO EVAL_AST_RETURN + + EVAL_AST_RETURN: + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q +END SUB + +REM EVAL(A, E) -> R +SUB EVAL + LV=LV+1: REM track basic return stack level + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) + + EVAL_TCO_RECUR: + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM AZ=A:B=1:GOSUB PR_STR + REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" + + GOSUB LIST_Q + IF R THEN GOTO APPLY_LIST + REM ELSE + CALL EVAL_AST + GOTO EVAL_RETURN + + APPLY_LIST: + GOSUB EMPTY_Q + IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN + + A0=Z%(A+2) + + REM get symbol in A$ + IF (Z%(A0)AND 31)<>5 THEN A$="" + IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) + + IF A$="def!" THEN GOTO EVAL_DEF + IF A$="let*" THEN GOTO EVAL_LET + IF A$="do" THEN GOTO EVAL_DO + IF A$="if" THEN GOTO EVAL_IF + IF A$="fn*" THEN GOTO EVAL_FN + GOTO EVAL_INVOKE + + EVAL_GET_A3: + A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) + EVAL_GET_A2: + A2=Z%(Z%(Z%(A+1)+1)+2) + EVAL_GET_A1: + A1=Z%(Z%(A+1)+2) + RETURN + + EVAL_DEF: + REM PRINT "def!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q + A=A2:CALL EVAL: REM eval a2 + GOSUB POP_Q:A1=Q + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM set a1 in env to a2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_LET: + REM PRINT "let*" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A2:GOSUB PUSH_Q: REM push/save A2 + REM create new environment with outer as current environment + C=E:GOSUB ENV_NEW + E=R + EVAL_LET_LOOP: + IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE + + Q=A1:GOSUB PUSH_Q: REM push A1 + REM eval current A1 odd element + A=Z%(Z%(A1+1)+2):CALL EVAL + GOSUB POP_Q:A1=Q: REM pop A1 + + IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE + + REM set key/value in the environment + K=Z%(A1+2):C=R:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership + + REM skip to the next pair of A1 elements + A1=Z%(Z%(A1+1)+1) + GOTO EVAL_LET_LOOP + + EVAL_LET_LOOP_DONE: + GOSUB POP_Q:A2=Q: REM pop A2 + A=A2:CALL EVAL: REM eval A2 using let_env + GOTO EVAL_RETURN + EVAL_DO: + A=Z%(A+1): REM rest + + CALL EVAL_AST + + GOSUB PUSH_R: REM push eval'd list + A=R:GOSUB LAST: REM return the last element + GOSUB POP_Q:AY=Q: REM pop eval'd list + GOSUB RELEASE: REM release the eval'd list + GOTO EVAL_RETURN + + EVAL_IF: + GOSUB EVAL_GET_A1: REM set A1 + GOSUB PUSH_A: REM push/save A + A=A1:CALL EVAL + GOSUB POP_A: REM pop/restore A + IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE + + EVAL_IF_TRUE: + AY=R:GOSUB RELEASE + GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + EVAL_IF_FALSE: + AY=R:GOSUB RELEASE + REM if no false case (A3), return nil + GOSUB COUNT + IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN + GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL + A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_FN: + GOSUB EVAL_GET_A2: REM set A1 and A2 + T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function + GOTO EVAL_RETURN + + EVAL_INVOKE: + CALL EVAL_AST + + REM if error, return f/args for release by caller + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM push f/args for release after call + GOSUB PUSH_R + + AR=Z%(R+1): REM rest + F=Z%(R+2) + + REM if metadata, get the actual object + GOSUB TYPE_F + IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F + + ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION + + REM if error, pop and return f/args for release by caller + GOSUB POP_R + ER=-1:E$="apply of non-function":GOTO EVAL_RETURN + + EVAL_DO_FUNCTION: + REM regular function + IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP + REM for recur functions (apply, map, swap!), use GOTO + IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION + EVAL_DO_FUNCTION_SKIP: + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + GOTO EVAL_RETURN + + EVAL_DO_MAL_FUNCTION: + Q=E:GOSUB PUSH_Q: REM save the current environment for release + + REM create new environ using env and params stored in function + C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS + + REM release previous env if it is not the top one on the + REM stack (X%(X-2)) because our new env refers to it and + REM we no longer need to track it (since we are TCO recurring) + GOSUB POP_Q:AY=Q + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + REM claim the AST before releasing the list containing it + A=Z%(F+1):Z%(A)=Z%(A)+32 + REM add AST to pending release queue to free as soon as EVAL + REM actually returns (LV+1) + LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + + REM A set above + E=R:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_RETURN: + REM AZ=R: B=1: GOSUB PR_STR + REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) + + REM release environment if not the top one on the stack + GOSUB PEEK_Q_1 + IF E<>Q THEN AY=E:GOSUB RELEASE + + LV=LV-1: REM track basic return stack level + + REM release everything we couldn't release earlier + GOSUB RELEASE_PEND + + REM trigger GC + #cbm T=FRE(0) + #qbasic T=0 + + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + +END SUB + +REM PRINT(A) -> R$ +MAL_PRINT: + AZ=A:B=1:GOSUB PR_STR + RETURN + +REM RE(A$) -> R +REM Assume D has repl_env +REM caller must release result +RE: + R1=-1 + GOSUB MAL_READ + R1=R + IF ER<>-2 THEN GOTO RE_DONE + + A=R:E=D:CALL EVAL + + RE_DONE: + REM Release memory from MAL_READ + AY=R1:GOSUB RELEASE + RETURN: REM caller must release result of EVAL + +REM REP(A$) -> R$ +REM Assume D has repl_env +SUB REP + R2=-1 + + GOSUB RE + R2=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:GOSUB MAL_PRINT + + REP_DONE: + REM Release memory from MAL_READ and EVAL + AY=R2:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + LV=0 + + REM create repl_env + C=0:GOSUB ENV_NEW:D=R + + REM core.EXT: defined in Basic + E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env + + ZT=ZI: REM top of memory after base repl_env + + REM core.mal: defined using the language itself + A$="(def! not (fn* (a) (if a false true)))" + GOSUB RE:AY=R:GOSUB RELEASE + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/step5_tco.in.bas b/impls/basic/step5_tco.in.bas index 2c460fd43e..3ab876525c 100755 --- a/impls/basic/step5_tco.in.bas +++ b/impls/basic/step5_tco.in.bas @@ -1,395 +1,395 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' -REM $INCLUDE: 'env.in.bas' -REM $INCLUDE: 'core.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R -MAL_READ: - GOSUB READ_STR - RETURN - -REM EVAL_AST(A, E) -> R -SUB EVAL_AST - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_AST_RETURN - - GOSUB TYPE_A - IF T=5 THEN GOTO EVAL_AST_SYMBOL - IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ - - REM scalar: deref to actual value and inc ref cnt - R=A - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SYMBOL: - K=A:GOTO ENV_GET - ENV_GET_RETURN: - GOTO EVAL_AST_RETURN - - EVAL_AST_SEQ: - REM setup the stack for the loop - GOSUB MAP_LOOP_START - - EVAL_AST_SEQ_LOOP: - REM check if we are done evaluating the source sequence - IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM if we are returning to DO, then skip last element - REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to - REM return early and for TCO to work - Q=5:GOSUB PEEK_Q_Q - IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM call EVAL for each entry - GOSUB PUSH_A - IF T<>8 THEN A=Z%(A+2) - IF T=8 THEN A=Z%(A+3) - Q=T:GOSUB PUSH_Q: REM push/save type - CALL EVAL - GOSUB POP_Q:T=Q: REM pop/restore type - GOSUB POP_A - M=R - - REM if error, release the unattached element - REM TODO: is R=0 correct? - IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE - - REM for hash-maps, copy the key (inc ref since we are going to - REM release it below) - IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 - - - REM update the return sequence structure - REM release N (and M if T=8) since seq takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - REM process the next sequence entry from source list - A=Z%(A+1) - - GOTO EVAL_AST_SEQ_LOOP - EVAL_AST_SEQ_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO EVAL_AST_RETURN - - EVAL_AST_RETURN: - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q -END SUB - -REM EVAL(A, E) -> R -SUB EVAL - LV=LV+1: REM track basic return stack level - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) - - EVAL_TCO_RECUR: - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM AZ=A:B=1:GOSUB PR_STR - REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" - - GOSUB LIST_Q - IF R THEN GOTO APPLY_LIST - REM ELSE - CALL EVAL_AST - GOTO EVAL_RETURN - - APPLY_LIST: - GOSUB EMPTY_Q - IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN - - A0=Z%(A+2) - - REM get symbol in A$ - IF (Z%(A0)AND 31)<>5 THEN A$="" - IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) - - IF A$="def!" THEN GOTO EVAL_DEF - IF A$="let*" THEN GOTO EVAL_LET - IF A$="do" THEN GOTO EVAL_DO - IF A$="if" THEN GOTO EVAL_IF - IF A$="fn*" THEN GOTO EVAL_FN - GOTO EVAL_INVOKE - - EVAL_GET_A3: - A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) - EVAL_GET_A2: - A2=Z%(Z%(Z%(A+1)+1)+2) - EVAL_GET_A1: - A1=Z%(Z%(A+1)+2) - RETURN - - EVAL_DEF: - REM PRINT "def!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q - A=A2:CALL EVAL: REM eval a2 - GOSUB POP_Q:A1=Q - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM set a1 in env to a2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_LET: - REM PRINT "let*" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A2:GOSUB PUSH_Q: REM push/save A2 - Q=E:GOSUB PUSH_Q: REM push env for for later release - - REM create new environment with outer as current environment - C=E:GOSUB ENV_NEW - E=R - EVAL_LET_LOOP: - IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE - - Q=A1:GOSUB PUSH_Q: REM push A1 - REM eval current A1 odd element - A=Z%(Z%(A1+1)+2):CALL EVAL - GOSUB POP_Q:A1=Q: REM pop A1 - - IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE - - REM set key/value in the environment - K=Z%(A1+2):C=R:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership - - REM skip to the next pair of A1 elements - A1=Z%(Z%(A1+1)+1) - GOTO EVAL_LET_LOOP - - EVAL_LET_LOOP_DONE: - GOSUB POP_Q:AY=Q: REM pop previous env - - REM release previous environment if not the current EVAL env - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - GOSUB POP_Q:A2=Q: REM pop A2 - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_DO: - A=Z%(A+1): REM rest - GOSUB PUSH_A: REM push/save A - - REM this must be EVAL_AST call #2 for EVAL_AST to return early - REM and for TCO to work - CALL EVAL_AST - - REM cleanup - AY=R: REM get eval'd list for release - - GOSUB POP_A: REM pop/restore original A for LAST - GOSUB LAST: REM get last element for return - A=R: REM new recur AST - - REM cleanup - GOSUB RELEASE: REM release eval'd list - AY=A:GOSUB RELEASE: REM release LAST value (not sure why) - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_IF: - GOSUB EVAL_GET_A1: REM set A1 - GOSUB PUSH_A: REM push/save A - A=A1:CALL EVAL - GOSUB POP_A: REM pop/restore A - IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE - - EVAL_IF_TRUE: - AY=R:GOSUB RELEASE - GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - EVAL_IF_FALSE: - AY=R:GOSUB RELEASE - REM if no false case (A3), return nil - GOSUB COUNT - IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN - GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL - A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_FN: - GOSUB EVAL_GET_A2: REM set A1 and A2 - T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function - GOTO EVAL_RETURN - - EVAL_INVOKE: - CALL EVAL_AST - - REM if error, return f/args for release by caller - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM push f/args for release after call - GOSUB PUSH_R - - AR=Z%(R+1): REM rest - F=Z%(R+2) - - REM if metadata, get the actual object - GOSUB TYPE_F - IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F - - ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION - - REM if error, pop and return f/args for release by caller - GOSUB POP_R - ER=-1:E$="apply of non-function":GOTO EVAL_RETURN - - EVAL_DO_FUNCTION: - REM regular function - IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP - REM for recur functions (apply, map, swap!), use GOTO - IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION - EVAL_DO_FUNCTION_SKIP: - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - GOTO EVAL_RETURN - - EVAL_DO_MAL_FUNCTION: - Q=E:GOSUB PUSH_Q: REM save the current environment for release - - REM create new environ using env and params stored in function - C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS - - REM release previous env if it is not the top one on the - REM stack (X%(X-2)) because our new env refers to it and - REM we no longer need to track it (since we are TCO recurring) - GOSUB POP_Q:AY=Q - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - REM claim the AST before releasing the list containing it - A=Z%(F+1):Z%(A)=Z%(A)+32 - REM add AST to pending release queue to free as soon as EVAL - REM actually returns (LV+1) - LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - - REM A set above - E=R:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_RETURN: - REM AZ=R: B=1: GOSUB PR_STR - REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) - - REM release environment if not the top one on the stack - GOSUB PEEK_Q_1 - IF E<>Q THEN AY=E:GOSUB RELEASE - - LV=LV-1: REM track basic return stack level - - REM release everything we couldn't release earlier - GOSUB RELEASE_PEND - - REM trigger GC - #cbm T=FRE(0) - #qbasic T=0 - - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - -END SUB - -REM PRINT(A) -> R$ -MAL_PRINT: - AZ=A:B=1:GOSUB PR_STR - RETURN - -REM RE(A$) -> R -REM Assume D has repl_env -REM caller must release result -RE: - R1=-1 - GOSUB MAL_READ - R1=R - IF ER<>-2 THEN GOTO RE_DONE - - A=R:E=D:CALL EVAL - - RE_DONE: - REM Release memory from MAL_READ - AY=R1:GOSUB RELEASE - RETURN: REM caller must release result of EVAL - -REM REP(A$) -> R$ -REM Assume D has repl_env -SUB REP - R2=-1 - - GOSUB RE - R2=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:GOSUB MAL_PRINT - - REP_DONE: - REM Release memory from MAL_READ and EVAL - AY=R2:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - LV=0 - - REM create repl_env - C=0:GOSUB ENV_NEW:D=R - - REM core.EXT: defined in Basic - E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env - - ZT=ZI: REM top of memory after base repl_env - - REM core.mal: defined using the language itself - A$="(def! not (fn* (a) (if a false true)))" - GOSUB RE:AY=R:GOSUB RELEASE - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' +REM $INCLUDE: 'env.in.bas' +REM $INCLUDE: 'core.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R +MAL_READ: + GOSUB READ_STR + RETURN + +REM EVAL_AST(A, E) -> R +SUB EVAL_AST + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_AST_RETURN + + GOSUB TYPE_A + IF T=5 THEN GOTO EVAL_AST_SYMBOL + IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ + + REM scalar: deref to actual value and inc ref cnt + R=A + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SYMBOL: + K=A:GOTO ENV_GET + ENV_GET_RETURN: + GOTO EVAL_AST_RETURN + + EVAL_AST_SEQ: + REM setup the stack for the loop + GOSUB MAP_LOOP_START + + EVAL_AST_SEQ_LOOP: + REM check if we are done evaluating the source sequence + IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM if we are returning to DO, then skip last element + REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to + REM return early and for TCO to work + Q=5:GOSUB PEEK_Q_Q + IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM call EVAL for each entry + GOSUB PUSH_A + IF T<>8 THEN A=Z%(A+2) + IF T=8 THEN A=Z%(A+3) + Q=T:GOSUB PUSH_Q: REM push/save type + CALL EVAL + GOSUB POP_Q:T=Q: REM pop/restore type + GOSUB POP_A + M=R + + REM if error, release the unattached element + REM TODO: is R=0 correct? + IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE + + REM for hash-maps, copy the key (inc ref since we are going to + REM release it below) + IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 + + + REM update the return sequence structure + REM release N (and M if T=8) since seq takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + REM process the next sequence entry from source list + A=Z%(A+1) + + GOTO EVAL_AST_SEQ_LOOP + EVAL_AST_SEQ_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO EVAL_AST_RETURN + + EVAL_AST_RETURN: + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q +END SUB + +REM EVAL(A, E) -> R +SUB EVAL + LV=LV+1: REM track basic return stack level + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) + + EVAL_TCO_RECUR: + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM AZ=A:B=1:GOSUB PR_STR + REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" + + GOSUB LIST_Q + IF R THEN GOTO APPLY_LIST + REM ELSE + CALL EVAL_AST + GOTO EVAL_RETURN + + APPLY_LIST: + GOSUB EMPTY_Q + IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN + + A0=Z%(A+2) + + REM get symbol in A$ + IF (Z%(A0)AND 31)<>5 THEN A$="" + IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) + + IF A$="def!" THEN GOTO EVAL_DEF + IF A$="let*" THEN GOTO EVAL_LET + IF A$="do" THEN GOTO EVAL_DO + IF A$="if" THEN GOTO EVAL_IF + IF A$="fn*" THEN GOTO EVAL_FN + GOTO EVAL_INVOKE + + EVAL_GET_A3: + A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) + EVAL_GET_A2: + A2=Z%(Z%(Z%(A+1)+1)+2) + EVAL_GET_A1: + A1=Z%(Z%(A+1)+2) + RETURN + + EVAL_DEF: + REM PRINT "def!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q + A=A2:CALL EVAL: REM eval a2 + GOSUB POP_Q:A1=Q + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM set a1 in env to a2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_LET: + REM PRINT "let*" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A2:GOSUB PUSH_Q: REM push/save A2 + Q=E:GOSUB PUSH_Q: REM push env for for later release + + REM create new environment with outer as current environment + C=E:GOSUB ENV_NEW + E=R + EVAL_LET_LOOP: + IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE + + Q=A1:GOSUB PUSH_Q: REM push A1 + REM eval current A1 odd element + A=Z%(Z%(A1+1)+2):CALL EVAL + GOSUB POP_Q:A1=Q: REM pop A1 + + IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE + + REM set key/value in the environment + K=Z%(A1+2):C=R:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership + + REM skip to the next pair of A1 elements + A1=Z%(Z%(A1+1)+1) + GOTO EVAL_LET_LOOP + + EVAL_LET_LOOP_DONE: + GOSUB POP_Q:AY=Q: REM pop previous env + + REM release previous environment if not the current EVAL env + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + GOSUB POP_Q:A2=Q: REM pop A2 + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_DO: + A=Z%(A+1): REM rest + GOSUB PUSH_A: REM push/save A + + REM this must be EVAL_AST call #2 for EVAL_AST to return early + REM and for TCO to work + CALL EVAL_AST + + REM cleanup + AY=R: REM get eval'd list for release + + GOSUB POP_A: REM pop/restore original A for LAST + GOSUB LAST: REM get last element for return + A=R: REM new recur AST + + REM cleanup + GOSUB RELEASE: REM release eval'd list + AY=A:GOSUB RELEASE: REM release LAST value (not sure why) + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_IF: + GOSUB EVAL_GET_A1: REM set A1 + GOSUB PUSH_A: REM push/save A + A=A1:CALL EVAL + GOSUB POP_A: REM pop/restore A + IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE + + EVAL_IF_TRUE: + AY=R:GOSUB RELEASE + GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + EVAL_IF_FALSE: + AY=R:GOSUB RELEASE + REM if no false case (A3), return nil + GOSUB COUNT + IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN + GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL + A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_FN: + GOSUB EVAL_GET_A2: REM set A1 and A2 + T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function + GOTO EVAL_RETURN + + EVAL_INVOKE: + CALL EVAL_AST + + REM if error, return f/args for release by caller + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM push f/args for release after call + GOSUB PUSH_R + + AR=Z%(R+1): REM rest + F=Z%(R+2) + + REM if metadata, get the actual object + GOSUB TYPE_F + IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F + + ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION + + REM if error, pop and return f/args for release by caller + GOSUB POP_R + ER=-1:E$="apply of non-function":GOTO EVAL_RETURN + + EVAL_DO_FUNCTION: + REM regular function + IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP + REM for recur functions (apply, map, swap!), use GOTO + IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION + EVAL_DO_FUNCTION_SKIP: + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + GOTO EVAL_RETURN + + EVAL_DO_MAL_FUNCTION: + Q=E:GOSUB PUSH_Q: REM save the current environment for release + + REM create new environ using env and params stored in function + C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS + + REM release previous env if it is not the top one on the + REM stack (X%(X-2)) because our new env refers to it and + REM we no longer need to track it (since we are TCO recurring) + GOSUB POP_Q:AY=Q + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + REM claim the AST before releasing the list containing it + A=Z%(F+1):Z%(A)=Z%(A)+32 + REM add AST to pending release queue to free as soon as EVAL + REM actually returns (LV+1) + LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + + REM A set above + E=R:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_RETURN: + REM AZ=R: B=1: GOSUB PR_STR + REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) + + REM release environment if not the top one on the stack + GOSUB PEEK_Q_1 + IF E<>Q THEN AY=E:GOSUB RELEASE + + LV=LV-1: REM track basic return stack level + + REM release everything we couldn't release earlier + GOSUB RELEASE_PEND + + REM trigger GC + #cbm T=FRE(0) + #qbasic T=0 + + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + +END SUB + +REM PRINT(A) -> R$ +MAL_PRINT: + AZ=A:B=1:GOSUB PR_STR + RETURN + +REM RE(A$) -> R +REM Assume D has repl_env +REM caller must release result +RE: + R1=-1 + GOSUB MAL_READ + R1=R + IF ER<>-2 THEN GOTO RE_DONE + + A=R:E=D:CALL EVAL + + RE_DONE: + REM Release memory from MAL_READ + AY=R1:GOSUB RELEASE + RETURN: REM caller must release result of EVAL + +REM REP(A$) -> R$ +REM Assume D has repl_env +SUB REP + R2=-1 + + GOSUB RE + R2=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:GOSUB MAL_PRINT + + REP_DONE: + REM Release memory from MAL_READ and EVAL + AY=R2:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + LV=0 + + REM create repl_env + C=0:GOSUB ENV_NEW:D=R + + REM core.EXT: defined in Basic + E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env + + ZT=ZI: REM top of memory after base repl_env + + REM core.mal: defined using the language itself + A$="(def! not (fn* (a) (if a false true)))" + GOSUB RE:AY=R:GOSUB RELEASE + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/step6_file.in.bas b/impls/basic/step6_file.in.bas index bc4c64002c..78326fc45d 100755 --- a/impls/basic/step6_file.in.bas +++ b/impls/basic/step6_file.in.bas @@ -1,426 +1,426 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' -REM $INCLUDE: 'env.in.bas' -REM $INCLUDE: 'core.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R -MAL_READ: - GOSUB READ_STR - RETURN - -REM EVAL_AST(A, E) -> R -SUB EVAL_AST - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_AST_RETURN - - GOSUB TYPE_A - IF T=5 THEN GOTO EVAL_AST_SYMBOL - IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ - - REM scalar: deref to actual value and inc ref cnt - R=A - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SYMBOL: - K=A:GOTO ENV_GET - ENV_GET_RETURN: - GOTO EVAL_AST_RETURN - - EVAL_AST_SEQ: - REM setup the stack for the loop - GOSUB MAP_LOOP_START - - EVAL_AST_SEQ_LOOP: - REM check if we are done evaluating the source sequence - IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM if we are returning to DO, then skip last element - REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to - REM return early and for TCO to work - Q=5:GOSUB PEEK_Q_Q - IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM call EVAL for each entry - GOSUB PUSH_A - IF T<>8 THEN A=Z%(A+2) - IF T=8 THEN A=Z%(A+3) - Q=T:GOSUB PUSH_Q: REM push/save type - CALL EVAL - GOSUB POP_Q:T=Q: REM pop/restore type - GOSUB POP_A - M=R - - REM if error, release the unattached element - REM TODO: is R=0 correct? - IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE - - REM for hash-maps, copy the key (inc ref since we are going to - REM release it below) - IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 - - - REM update the return sequence structure - REM release N (and M if T=8) since seq takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - REM process the next sequence entry from source list - A=Z%(A+1) - - GOTO EVAL_AST_SEQ_LOOP - EVAL_AST_SEQ_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO EVAL_AST_RETURN - - EVAL_AST_RETURN: - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q -END SUB - -REM EVAL(A, E) -> R -SUB EVAL - LV=LV+1: REM track basic return stack level - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) - - EVAL_TCO_RECUR: - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM AZ=A:B=1:GOSUB PR_STR - REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" - - GOSUB LIST_Q - IF R THEN GOTO APPLY_LIST - REM ELSE - CALL EVAL_AST - GOTO EVAL_RETURN - - APPLY_LIST: - GOSUB EMPTY_Q - IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN - - A0=Z%(A+2) - - REM get symbol in A$ - IF (Z%(A0)AND 31)<>5 THEN A$="" - IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) - - IF A$="def!" THEN GOTO EVAL_DEF - IF A$="let*" THEN GOTO EVAL_LET - IF A$="do" THEN GOTO EVAL_DO - IF A$="if" THEN GOTO EVAL_IF - IF A$="fn*" THEN GOTO EVAL_FN - GOTO EVAL_INVOKE - - EVAL_GET_A3: - A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) - EVAL_GET_A2: - A2=Z%(Z%(Z%(A+1)+1)+2) - EVAL_GET_A1: - A1=Z%(Z%(A+1)+2) - RETURN - - EVAL_DEF: - REM PRINT "def!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q - A=A2:CALL EVAL: REM eval a2 - GOSUB POP_Q:A1=Q - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM set a1 in env to a2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_LET: - REM PRINT "let*" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A2:GOSUB PUSH_Q: REM push/save A2 - Q=E:GOSUB PUSH_Q: REM push env for for later release - - REM create new environment with outer as current environment - C=E:GOSUB ENV_NEW - E=R - EVAL_LET_LOOP: - IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE - - Q=A1:GOSUB PUSH_Q: REM push A1 - REM eval current A1 odd element - A=Z%(Z%(A1+1)+2):CALL EVAL - GOSUB POP_Q:A1=Q: REM pop A1 - - IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE - - REM set key/value in the environment - K=Z%(A1+2):C=R:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership - - REM skip to the next pair of A1 elements - A1=Z%(Z%(A1+1)+1) - GOTO EVAL_LET_LOOP - - EVAL_LET_LOOP_DONE: - GOSUB POP_Q:AY=Q: REM pop previous env - - REM release previous environment if not the current EVAL env - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - GOSUB POP_Q:A2=Q: REM pop A2 - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_DO: - A=Z%(A+1): REM rest - GOSUB PUSH_A: REM push/save A - - REM this must be EVAL_AST call #2 for EVAL_AST to return early - REM and for TCO to work - CALL EVAL_AST - - REM cleanup - AY=R: REM get eval'd list for release - - GOSUB POP_A: REM pop/restore original A for LAST - GOSUB LAST: REM get last element for return - A=R: REM new recur AST - - REM cleanup - GOSUB RELEASE: REM release eval'd list - AY=A:GOSUB RELEASE: REM release LAST value (not sure why) - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_IF: - GOSUB EVAL_GET_A1: REM set A1 - GOSUB PUSH_A: REM push/save A - A=A1:CALL EVAL - GOSUB POP_A: REM pop/restore A - IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE - - EVAL_IF_TRUE: - AY=R:GOSUB RELEASE - GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - EVAL_IF_FALSE: - AY=R:GOSUB RELEASE - REM if no false case (A3), return nil - GOSUB COUNT - IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN - GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL - A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_FN: - GOSUB EVAL_GET_A2: REM set A1 and A2 - T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function - GOTO EVAL_RETURN - - EVAL_INVOKE: - CALL EVAL_AST - - REM if error, return f/args for release by caller - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM push f/args for release after call - GOSUB PUSH_R - - AR=Z%(R+1): REM rest - F=Z%(R+2) - - REM if metadata, get the actual object - GOSUB TYPE_F - IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F - - ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION - - REM if error, pop and return f/args for release by caller - GOSUB POP_R - ER=-1:E$="apply of non-function":GOTO EVAL_RETURN - - EVAL_DO_FUNCTION: - REM regular function - IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP - REM for recur functions (apply, map, swap!), use GOTO - IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION - EVAL_DO_FUNCTION_SKIP: - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - GOTO EVAL_RETURN - - EVAL_DO_MAL_FUNCTION: - Q=E:GOSUB PUSH_Q: REM save the current environment for release - - REM create new environ using env and params stored in function - C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS - - REM release previous env if it is not the top one on the - REM stack (X%(X-2)) because our new env refers to it and - REM we no longer need to track it (since we are TCO recurring) - GOSUB POP_Q:AY=Q - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - REM claim the AST before releasing the list containing it - A=Z%(F+1):Z%(A)=Z%(A)+32 - REM add AST to pending release queue to free as soon as EVAL - REM actually returns (LV+1) - LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - - REM A set above - E=R:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_RETURN: - REM AZ=R: B=1: GOSUB PR_STR - REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) - - REM release environment if not the top one on the stack - GOSUB PEEK_Q_1 - IF E<>Q THEN AY=E:GOSUB RELEASE - - LV=LV-1: REM track basic return stack level - - REM release everything we couldn't release earlier - GOSUB RELEASE_PEND - - REM trigger GC - #cbm T=FRE(0) - #qbasic T=0 - - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - -END SUB - -REM PRINT(A) -> R$ -MAL_PRINT: - AZ=A:B=1:GOSUB PR_STR - RETURN - -REM RE(A$) -> R -REM Assume D has repl_env -REM caller must release result -RE: - R1=-1 - GOSUB MAL_READ - R1=R - IF ER<>-2 THEN GOTO RE_DONE - - A=R:E=D:CALL EVAL - - RE_DONE: - REM Release memory from MAL_READ - AY=R1:GOSUB RELEASE - RETURN: REM caller must release result of EVAL - -REM REP(A$) -> R$ -REM Assume D has repl_env -SUB REP - R2=-1 - - GOSUB RE - R2=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:GOSUB MAL_PRINT - - REP_DONE: - REM Release memory from MAL_READ and EVAL - AY=R2:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - LV=0 - - REM create repl_env - C=0:GOSUB ENV_NEW:D=R - - REM core.EXT: defined in Basic - E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env - - ZT=ZI: REM top of memory after base repl_env - - REM core.mal: defined using the language itself - A$="(def! not (fn* (a) (if a false true)))" - GOSUB RE:AY=R:GOSUB RELEASE - - A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM load the args file - A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" - GOSUB RE:AY=R:GOSUB RELEASE - - IF ER>-2 THEN GOSUB PRINT_ERROR:END - - REM set the argument list - A$="(def! *ARGV* (rest -*ARGS*-))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM get the first argument - A$="(first -*ARGS*-)" - GOSUB RE - - REM no arguments, start REPL loop - IF R<16 THEN GOTO REPL_LOOP - - REM if there is an argument, then run it as a program - - RUN_PROG: - REM free up first arg because we get it again - AY=R:GOSUB RELEASE - REM run a single mal program and exit - A$="(load-file (first -*ARGS*-))" - GOSUB RE - IF ER<>-2 THEN GOSUB PRINT_ERROR - GOTO QUIT - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' +REM $INCLUDE: 'env.in.bas' +REM $INCLUDE: 'core.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R +MAL_READ: + GOSUB READ_STR + RETURN + +REM EVAL_AST(A, E) -> R +SUB EVAL_AST + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_AST_RETURN + + GOSUB TYPE_A + IF T=5 THEN GOTO EVAL_AST_SYMBOL + IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ + + REM scalar: deref to actual value and inc ref cnt + R=A + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SYMBOL: + K=A:GOTO ENV_GET + ENV_GET_RETURN: + GOTO EVAL_AST_RETURN + + EVAL_AST_SEQ: + REM setup the stack for the loop + GOSUB MAP_LOOP_START + + EVAL_AST_SEQ_LOOP: + REM check if we are done evaluating the source sequence + IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM if we are returning to DO, then skip last element + REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to + REM return early and for TCO to work + Q=5:GOSUB PEEK_Q_Q + IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM call EVAL for each entry + GOSUB PUSH_A + IF T<>8 THEN A=Z%(A+2) + IF T=8 THEN A=Z%(A+3) + Q=T:GOSUB PUSH_Q: REM push/save type + CALL EVAL + GOSUB POP_Q:T=Q: REM pop/restore type + GOSUB POP_A + M=R + + REM if error, release the unattached element + REM TODO: is R=0 correct? + IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE + + REM for hash-maps, copy the key (inc ref since we are going to + REM release it below) + IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 + + + REM update the return sequence structure + REM release N (and M if T=8) since seq takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + REM process the next sequence entry from source list + A=Z%(A+1) + + GOTO EVAL_AST_SEQ_LOOP + EVAL_AST_SEQ_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO EVAL_AST_RETURN + + EVAL_AST_RETURN: + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q +END SUB + +REM EVAL(A, E) -> R +SUB EVAL + LV=LV+1: REM track basic return stack level + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) + + EVAL_TCO_RECUR: + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM AZ=A:B=1:GOSUB PR_STR + REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" + + GOSUB LIST_Q + IF R THEN GOTO APPLY_LIST + REM ELSE + CALL EVAL_AST + GOTO EVAL_RETURN + + APPLY_LIST: + GOSUB EMPTY_Q + IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN + + A0=Z%(A+2) + + REM get symbol in A$ + IF (Z%(A0)AND 31)<>5 THEN A$="" + IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) + + IF A$="def!" THEN GOTO EVAL_DEF + IF A$="let*" THEN GOTO EVAL_LET + IF A$="do" THEN GOTO EVAL_DO + IF A$="if" THEN GOTO EVAL_IF + IF A$="fn*" THEN GOTO EVAL_FN + GOTO EVAL_INVOKE + + EVAL_GET_A3: + A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) + EVAL_GET_A2: + A2=Z%(Z%(Z%(A+1)+1)+2) + EVAL_GET_A1: + A1=Z%(Z%(A+1)+2) + RETURN + + EVAL_DEF: + REM PRINT "def!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q + A=A2:CALL EVAL: REM eval a2 + GOSUB POP_Q:A1=Q + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM set a1 in env to a2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_LET: + REM PRINT "let*" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A2:GOSUB PUSH_Q: REM push/save A2 + Q=E:GOSUB PUSH_Q: REM push env for for later release + + REM create new environment with outer as current environment + C=E:GOSUB ENV_NEW + E=R + EVAL_LET_LOOP: + IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE + + Q=A1:GOSUB PUSH_Q: REM push A1 + REM eval current A1 odd element + A=Z%(Z%(A1+1)+2):CALL EVAL + GOSUB POP_Q:A1=Q: REM pop A1 + + IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE + + REM set key/value in the environment + K=Z%(A1+2):C=R:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership + + REM skip to the next pair of A1 elements + A1=Z%(Z%(A1+1)+1) + GOTO EVAL_LET_LOOP + + EVAL_LET_LOOP_DONE: + GOSUB POP_Q:AY=Q: REM pop previous env + + REM release previous environment if not the current EVAL env + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + GOSUB POP_Q:A2=Q: REM pop A2 + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_DO: + A=Z%(A+1): REM rest + GOSUB PUSH_A: REM push/save A + + REM this must be EVAL_AST call #2 for EVAL_AST to return early + REM and for TCO to work + CALL EVAL_AST + + REM cleanup + AY=R: REM get eval'd list for release + + GOSUB POP_A: REM pop/restore original A for LAST + GOSUB LAST: REM get last element for return + A=R: REM new recur AST + + REM cleanup + GOSUB RELEASE: REM release eval'd list + AY=A:GOSUB RELEASE: REM release LAST value (not sure why) + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_IF: + GOSUB EVAL_GET_A1: REM set A1 + GOSUB PUSH_A: REM push/save A + A=A1:CALL EVAL + GOSUB POP_A: REM pop/restore A + IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE + + EVAL_IF_TRUE: + AY=R:GOSUB RELEASE + GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + EVAL_IF_FALSE: + AY=R:GOSUB RELEASE + REM if no false case (A3), return nil + GOSUB COUNT + IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN + GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL + A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_FN: + GOSUB EVAL_GET_A2: REM set A1 and A2 + T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function + GOTO EVAL_RETURN + + EVAL_INVOKE: + CALL EVAL_AST + + REM if error, return f/args for release by caller + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM push f/args for release after call + GOSUB PUSH_R + + AR=Z%(R+1): REM rest + F=Z%(R+2) + + REM if metadata, get the actual object + GOSUB TYPE_F + IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F + + ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION + + REM if error, pop and return f/args for release by caller + GOSUB POP_R + ER=-1:E$="apply of non-function":GOTO EVAL_RETURN + + EVAL_DO_FUNCTION: + REM regular function + IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP + REM for recur functions (apply, map, swap!), use GOTO + IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION + EVAL_DO_FUNCTION_SKIP: + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + GOTO EVAL_RETURN + + EVAL_DO_MAL_FUNCTION: + Q=E:GOSUB PUSH_Q: REM save the current environment for release + + REM create new environ using env and params stored in function + C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS + + REM release previous env if it is not the top one on the + REM stack (X%(X-2)) because our new env refers to it and + REM we no longer need to track it (since we are TCO recurring) + GOSUB POP_Q:AY=Q + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + REM claim the AST before releasing the list containing it + A=Z%(F+1):Z%(A)=Z%(A)+32 + REM add AST to pending release queue to free as soon as EVAL + REM actually returns (LV+1) + LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + + REM A set above + E=R:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_RETURN: + REM AZ=R: B=1: GOSUB PR_STR + REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) + + REM release environment if not the top one on the stack + GOSUB PEEK_Q_1 + IF E<>Q THEN AY=E:GOSUB RELEASE + + LV=LV-1: REM track basic return stack level + + REM release everything we couldn't release earlier + GOSUB RELEASE_PEND + + REM trigger GC + #cbm T=FRE(0) + #qbasic T=0 + + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + +END SUB + +REM PRINT(A) -> R$ +MAL_PRINT: + AZ=A:B=1:GOSUB PR_STR + RETURN + +REM RE(A$) -> R +REM Assume D has repl_env +REM caller must release result +RE: + R1=-1 + GOSUB MAL_READ + R1=R + IF ER<>-2 THEN GOTO RE_DONE + + A=R:E=D:CALL EVAL + + RE_DONE: + REM Release memory from MAL_READ + AY=R1:GOSUB RELEASE + RETURN: REM caller must release result of EVAL + +REM REP(A$) -> R$ +REM Assume D has repl_env +SUB REP + R2=-1 + + GOSUB RE + R2=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:GOSUB MAL_PRINT + + REP_DONE: + REM Release memory from MAL_READ and EVAL + AY=R2:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + LV=0 + + REM create repl_env + C=0:GOSUB ENV_NEW:D=R + + REM core.EXT: defined in Basic + E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env + + ZT=ZI: REM top of memory after base repl_env + + REM core.mal: defined using the language itself + A$="(def! not (fn* (a) (if a false true)))" + GOSUB RE:AY=R:GOSUB RELEASE + + A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM load the args file + A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" + GOSUB RE:AY=R:GOSUB RELEASE + + IF ER>-2 THEN GOSUB PRINT_ERROR:END + + REM set the argument list + A$="(def! *ARGV* (rest -*ARGS*-))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM get the first argument + A$="(first -*ARGS*-)" + GOSUB RE + + REM no arguments, start REPL loop + IF R<16 THEN GOTO REPL_LOOP + + REM if there is an argument, then run it as a program + + RUN_PROG: + REM free up first arg because we get it again + AY=R:GOSUB RELEASE + REM run a single mal program and exit + A$="(load-file (first -*ARGS*-))" + GOSUB RE + IF ER<>-2 THEN GOSUB PRINT_ERROR + GOTO QUIT + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/step7_quote.in.bas b/impls/basic/step7_quote.in.bas index 68e546e495..44ea8081c6 100755 --- a/impls/basic/step7_quote.in.bas +++ b/impls/basic/step7_quote.in.bas @@ -1,562 +1,562 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' -REM $INCLUDE: 'env.in.bas' -REM $INCLUDE: 'core.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R -MAL_READ: - GOSUB READ_STR - RETURN - -REM QUASIQUOTE(A) -> R -SUB QUASIQUOTE - GOSUB TYPE_A - IF T<5 OR T>8 THEN GOTO QQ_UNCHANGED - IF T=5 OR T=8 THEN GOTO QQ_QUOTE - IF T=7 THEN GOTO QQ_VECTOR - IF (Z%(A+1)=0) THEN GOTO QQ_LIST - R=Z%(A+2) - IF (Z%(R)AND 31)<>5 THEN GOTO QQ_LIST - IF S$(Z%(R+1))<>"unquote" THEN GOTO QQ_LIST - GOTO QQ_UNQUOTE - - QQ_UNCHANGED: - R=A - GOSUB INC_REF_R - - GOTO QQ_DONE - - QQ_QUOTE: - REM ['quote, ast] - B$="quote":T=5:GOSUB STRING - B=R:GOSUB LIST2 - AY=B:GOSUB RELEASE - - GOTO QQ_DONE - - QQ_VECTOR: - REM ['vec, (qq_foldr ast)] - CALL QQ_FOLDR - A=R - B$="vec":T=5:GOSUB STRING:B=R - GOSUB LIST2 - AY=A:GOSUB RELEASE - AY=B:GOSUB RELEASE - - GOTO QQ_DONE - - QQ_UNQUOTE: - REM [ast[1]] - R=Z%(Z%(A+1)+2) - GOSUB INC_REF_R - - GOTO QQ_DONE - - QQ_LIST: - CALL QQ_FOLDR - -QQ_DONE: -END SUB - -REM Quasiquote right fold (A) -> R. -REM Used for unquoted lists (GOTO), vectors (GOSUB), -REM and recursively (GOSUB). -SUB QQ_FOLDR - IF A=0 THEN GOTO QQ_EMPTY - IF Z%(A+1)=0 THEN GOTO QQ_EMPTY - GOTO QQ_NOTEMPTY - - QQ_EMPTY: - REM empty list/vector -> empty list - R=6 - GOSUB INC_REF_R - - GOTO QQ_FOLDR_DONE - - QQ_NOTEMPTY: - REM Execute QQ_FOLDR recursively with (rest A) - GOSUB PUSH_A - A=Z%(A+1):CALL QQ_FOLDR - GOSUB POP_A - - REM Set A to elt = (first A) - A=Z%(A+2) - - REM Quasiquote transition function: - REM A: current element, R: accumulator -> R: new accumulator - - REM check if A is a list starting with splice-unquote - GOSUB TYPE_A - IF T<>6 THEN GOTO QQ_DEFAULT - IF (Z%(A+1)=0) THEN GOTO QQ_DEFAULT - B=Z%(A+2) - IF (Z%(B)AND 31)<>5 THEN GOTO QQ_DEFAULT - IF S$(Z%(B+1))<>"splice-unquote" THEN GOTO QQ_DEFAULT - - REM ('concat, A[1], R) - B=Z%(Z%(A+1)+2) - A=R - B$="concat":T=5:GOSUB STRING:C=R - GOSUB LIST3 - REM release inner quasiquoted since outer list takes ownership - AY=A:GOSUB RELEASE - AY=C:GOSUB RELEASE - - GOTO QQ_FOLDR_DONE - - QQ_DEFAULT: - REM ('cons, quasiquote(A), R) - GOSUB PUSH_R - CALL QUASIQUOTE - B=R - B$="cons":T=5:GOSUB STRING:C=R - GOSUB POP_A - GOSUB LIST3 - REM release inner quasiquoted since outer list takes ownership - AY=A:GOSUB RELEASE - AY=B:GOSUB RELEASE - AY=C:GOSUB RELEASE - -QQ_FOLDR_DONE: -END SUB - - -REM EVAL_AST(A, E) -> R -SUB EVAL_AST - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_AST_RETURN - - GOSUB TYPE_A - IF T=5 THEN GOTO EVAL_AST_SYMBOL - IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ - - REM scalar: deref to actual value and inc ref cnt - R=A - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SYMBOL: - K=A:GOTO ENV_GET - ENV_GET_RETURN: - GOTO EVAL_AST_RETURN - - EVAL_AST_SEQ: - REM setup the stack for the loop - GOSUB MAP_LOOP_START - - EVAL_AST_SEQ_LOOP: - REM check if we are done evaluating the source sequence - IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM if we are returning to DO, then skip last element - REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to - REM return early and for TCO to work - Q=5:GOSUB PEEK_Q_Q - IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM call EVAL for each entry - GOSUB PUSH_A - IF T<>8 THEN A=Z%(A+2) - IF T=8 THEN A=Z%(A+3) - Q=T:GOSUB PUSH_Q: REM push/save type - CALL EVAL - GOSUB POP_Q:T=Q: REM pop/restore type - GOSUB POP_A - M=R - - REM if error, release the unattached element - REM TODO: is R=0 correct? - IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE - - REM for hash-maps, copy the key (inc ref since we are going to - REM release it below) - IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 - - - REM update the return sequence structure - REM release N (and M if T=8) since seq takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - REM process the next sequence entry from source list - A=Z%(A+1) - - GOTO EVAL_AST_SEQ_LOOP - EVAL_AST_SEQ_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO EVAL_AST_RETURN - - EVAL_AST_RETURN: - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q -END SUB - -REM EVAL(A, E) -> R -SUB EVAL - LV=LV+1: REM track basic return stack level - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) - - EVAL_TCO_RECUR: - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM AZ=A:B=1:GOSUB PR_STR - REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" - - GOSUB LIST_Q - IF R THEN GOTO APPLY_LIST - REM ELSE - CALL EVAL_AST - GOTO EVAL_RETURN - - APPLY_LIST: - GOSUB EMPTY_Q - IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN - - A0=Z%(A+2) - - REM get symbol in A$ - IF (Z%(A0)AND 31)<>5 THEN A$="" - IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) - - IF A$="def!" THEN GOTO EVAL_DEF - IF A$="let*" THEN GOTO EVAL_LET - IF A$="quote" THEN GOTO EVAL_QUOTE - IF A$="quasiquoteexpand" THEN GOTO EVAL_QUASIQUOTEEXPAND - IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE - IF A$="do" THEN GOTO EVAL_DO - IF A$="if" THEN GOTO EVAL_IF - IF A$="fn*" THEN GOTO EVAL_FN - GOTO EVAL_INVOKE - - EVAL_GET_A3: - A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) - EVAL_GET_A2: - A2=Z%(Z%(Z%(A+1)+1)+2) - EVAL_GET_A1: - A1=Z%(Z%(A+1)+2) - RETURN - - EVAL_DEF: - REM PRINT "def!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q - A=A2:CALL EVAL: REM eval a2 - GOSUB POP_Q:A1=Q - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM set a1 in env to a2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_LET: - REM PRINT "let*" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A2:GOSUB PUSH_Q: REM push/save A2 - Q=E:GOSUB PUSH_Q: REM push env for for later release - - REM create new environment with outer as current environment - C=E:GOSUB ENV_NEW - E=R - EVAL_LET_LOOP: - IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE - - Q=A1:GOSUB PUSH_Q: REM push A1 - REM eval current A1 odd element - A=Z%(Z%(A1+1)+2):CALL EVAL - GOSUB POP_Q:A1=Q: REM pop A1 - - IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE - - REM set key/value in the environment - K=Z%(A1+2):C=R:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership - - REM skip to the next pair of A1 elements - A1=Z%(Z%(A1+1)+1) - GOTO EVAL_LET_LOOP - - EVAL_LET_LOOP_DONE: - GOSUB POP_Q:AY=Q: REM pop previous env - - REM release previous environment if not the current EVAL env - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - GOSUB POP_Q:A2=Q: REM pop A2 - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_DO: - A=Z%(A+1): REM rest - GOSUB PUSH_A: REM push/save A - - REM this must be EVAL_AST call #2 for EVAL_AST to return early - REM and for TCO to work - CALL EVAL_AST - - REM cleanup - AY=R: REM get eval'd list for release - - GOSUB POP_A: REM pop/restore original A for LAST - GOSUB LAST: REM get last element for return - A=R: REM new recur AST - - REM cleanup - GOSUB RELEASE: REM release eval'd list - AY=A:GOSUB RELEASE: REM release LAST value (not sure why) - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_QUOTE: - R=Z%(Z%(A+1)+2) - GOSUB INC_REF_R - GOTO EVAL_RETURN - - EVAL_QUASIQUOTEEXPAND: - R=Z%(Z%(A+1)+2) - A=R:CALL QUASIQUOTE - GOTO EVAL_RETURN - - EVAL_QUASIQUOTE: - R=Z%(Z%(A+1)+2) - A=R:CALL QUASIQUOTE - A=R - REM add quasiquote result to pending release queue to free when - REM next lower EVAL level returns (LV) - GOSUB PEND_A_LV - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_IF: - GOSUB EVAL_GET_A1: REM set A1 - GOSUB PUSH_A: REM push/save A - A=A1:CALL EVAL - GOSUB POP_A: REM pop/restore A - IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE - - EVAL_IF_TRUE: - AY=R:GOSUB RELEASE - GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - EVAL_IF_FALSE: - AY=R:GOSUB RELEASE - REM if no false case (A3), return nil - GOSUB COUNT - IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN - GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL - A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_FN: - GOSUB EVAL_GET_A2: REM set A1 and A2 - T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function - GOTO EVAL_RETURN - - EVAL_INVOKE: - CALL EVAL_AST - - REM if error, return f/args for release by caller - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM push f/args for release after call - GOSUB PUSH_R - - AR=Z%(R+1): REM rest - F=Z%(R+2) - - REM if metadata, get the actual object - GOSUB TYPE_F - IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F - - ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION - - REM if error, pop and return f/args for release by caller - GOSUB POP_R - ER=-1:E$="apply of non-function":GOTO EVAL_RETURN - - EVAL_DO_FUNCTION: - REM regular function - IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP - REM for recur functions (apply, map, swap!), use GOTO - IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION - EVAL_DO_FUNCTION_SKIP: - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - GOTO EVAL_RETURN - - EVAL_DO_MAL_FUNCTION: - Q=E:GOSUB PUSH_Q: REM save the current environment for release - - REM create new environ using env and params stored in function - C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS - - REM release previous env if it is not the top one on the - REM stack (X%(X-2)) because our new env refers to it and - REM we no longer need to track it (since we are TCO recurring) - GOSUB POP_Q:AY=Q - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - REM claim the AST before releasing the list containing it - A=Z%(F+1):Z%(A)=Z%(A)+32 - REM add AST to pending release queue to free as soon as EVAL - REM actually returns (LV+1) - LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - - REM A set above - E=R:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_RETURN: - REM AZ=R: B=1: GOSUB PR_STR - REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) - - REM release environment if not the top one on the stack - GOSUB PEEK_Q_1 - IF E<>Q THEN AY=E:GOSUB RELEASE - - LV=LV-1: REM track basic return stack level - - REM release everything we couldn't release earlier - GOSUB RELEASE_PEND - - REM trigger GC - #cbm T=FRE(0) - #qbasic T=0 - - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - -END SUB - -REM PRINT(A) -> R$ -MAL_PRINT: - AZ=A:B=1:GOSUB PR_STR - RETURN - -REM RE(A$) -> R -REM Assume D has repl_env -REM caller must release result -RE: - R1=-1 - GOSUB MAL_READ - R1=R - IF ER<>-2 THEN GOTO RE_DONE - - A=R:E=D:CALL EVAL - - RE_DONE: - REM Release memory from MAL_READ - AY=R1:GOSUB RELEASE - RETURN: REM caller must release result of EVAL - -REM REP(A$) -> R$ -REM Assume D has repl_env -SUB REP - R2=-1 - - GOSUB RE - R2=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:GOSUB MAL_PRINT - - REP_DONE: - REM Release memory from MAL_READ and EVAL - AY=R2:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - LV=0 - - REM create repl_env - C=0:GOSUB ENV_NEW:D=R - - REM core.EXT: defined in Basic - E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env - - ZT=ZI: REM top of memory after base repl_env - - REM core.mal: defined using the language itself - A$="(def! not (fn* (a) (if a false true)))" - GOSUB RE:AY=R:GOSUB RELEASE - - A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM load the args file - A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" - GOSUB RE:AY=R:GOSUB RELEASE - - IF ER>-2 THEN GOSUB PRINT_ERROR:END - - REM set the argument list - A$="(def! *ARGV* (rest -*ARGS*-))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM get the first argument - A$="(first -*ARGS*-)" - GOSUB RE - - REM no arguments, start REPL loop - IF R<16 THEN GOTO REPL_LOOP - - REM if there is an argument, then run it as a program - - RUN_PROG: - REM free up first arg because we get it again - AY=R:GOSUB RELEASE - REM run a single mal program and exit - A$="(load-file (first -*ARGS*-))" - GOSUB RE - IF ER<>-2 THEN GOSUB PRINT_ERROR - GOTO QUIT - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' +REM $INCLUDE: 'env.in.bas' +REM $INCLUDE: 'core.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R +MAL_READ: + GOSUB READ_STR + RETURN + +REM QUASIQUOTE(A) -> R +SUB QUASIQUOTE + GOSUB TYPE_A + IF T<5 OR T>8 THEN GOTO QQ_UNCHANGED + IF T=5 OR T=8 THEN GOTO QQ_QUOTE + IF T=7 THEN GOTO QQ_VECTOR + IF (Z%(A+1)=0) THEN GOTO QQ_LIST + R=Z%(A+2) + IF (Z%(R)AND 31)<>5 THEN GOTO QQ_LIST + IF S$(Z%(R+1))<>"unquote" THEN GOTO QQ_LIST + GOTO QQ_UNQUOTE + + QQ_UNCHANGED: + R=A + GOSUB INC_REF_R + + GOTO QQ_DONE + + QQ_QUOTE: + REM ['quote, ast] + B$="quote":T=5:GOSUB STRING + B=R:GOSUB LIST2 + AY=B:GOSUB RELEASE + + GOTO QQ_DONE + + QQ_VECTOR: + REM ['vec, (qq_foldr ast)] + CALL QQ_FOLDR + A=R + B$="vec":T=5:GOSUB STRING:B=R + GOSUB LIST2 + AY=A:GOSUB RELEASE + AY=B:GOSUB RELEASE + + GOTO QQ_DONE + + QQ_UNQUOTE: + REM [ast[1]] + R=Z%(Z%(A+1)+2) + GOSUB INC_REF_R + + GOTO QQ_DONE + + QQ_LIST: + CALL QQ_FOLDR + +QQ_DONE: +END SUB + +REM Quasiquote right fold (A) -> R. +REM Used for unquoted lists (GOTO), vectors (GOSUB), +REM and recursively (GOSUB). +SUB QQ_FOLDR + IF A=0 THEN GOTO QQ_EMPTY + IF Z%(A+1)=0 THEN GOTO QQ_EMPTY + GOTO QQ_NOTEMPTY + + QQ_EMPTY: + REM empty list/vector -> empty list + R=6 + GOSUB INC_REF_R + + GOTO QQ_FOLDR_DONE + + QQ_NOTEMPTY: + REM Execute QQ_FOLDR recursively with (rest A) + GOSUB PUSH_A + A=Z%(A+1):CALL QQ_FOLDR + GOSUB POP_A + + REM Set A to elt = (first A) + A=Z%(A+2) + + REM Quasiquote transition function: + REM A: current element, R: accumulator -> R: new accumulator + + REM check if A is a list starting with splice-unquote + GOSUB TYPE_A + IF T<>6 THEN GOTO QQ_DEFAULT + IF (Z%(A+1)=0) THEN GOTO QQ_DEFAULT + B=Z%(A+2) + IF (Z%(B)AND 31)<>5 THEN GOTO QQ_DEFAULT + IF S$(Z%(B+1))<>"splice-unquote" THEN GOTO QQ_DEFAULT + + REM ('concat, A[1], R) + B=Z%(Z%(A+1)+2) + A=R + B$="concat":T=5:GOSUB STRING:C=R + GOSUB LIST3 + REM release inner quasiquoted since outer list takes ownership + AY=A:GOSUB RELEASE + AY=C:GOSUB RELEASE + + GOTO QQ_FOLDR_DONE + + QQ_DEFAULT: + REM ('cons, quasiquote(A), R) + GOSUB PUSH_R + CALL QUASIQUOTE + B=R + B$="cons":T=5:GOSUB STRING:C=R + GOSUB POP_A + GOSUB LIST3 + REM release inner quasiquoted since outer list takes ownership + AY=A:GOSUB RELEASE + AY=B:GOSUB RELEASE + AY=C:GOSUB RELEASE + +QQ_FOLDR_DONE: +END SUB + + +REM EVAL_AST(A, E) -> R +SUB EVAL_AST + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_AST_RETURN + + GOSUB TYPE_A + IF T=5 THEN GOTO EVAL_AST_SYMBOL + IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ + + REM scalar: deref to actual value and inc ref cnt + R=A + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SYMBOL: + K=A:GOTO ENV_GET + ENV_GET_RETURN: + GOTO EVAL_AST_RETURN + + EVAL_AST_SEQ: + REM setup the stack for the loop + GOSUB MAP_LOOP_START + + EVAL_AST_SEQ_LOOP: + REM check if we are done evaluating the source sequence + IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM if we are returning to DO, then skip last element + REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to + REM return early and for TCO to work + Q=5:GOSUB PEEK_Q_Q + IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM call EVAL for each entry + GOSUB PUSH_A + IF T<>8 THEN A=Z%(A+2) + IF T=8 THEN A=Z%(A+3) + Q=T:GOSUB PUSH_Q: REM push/save type + CALL EVAL + GOSUB POP_Q:T=Q: REM pop/restore type + GOSUB POP_A + M=R + + REM if error, release the unattached element + REM TODO: is R=0 correct? + IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE + + REM for hash-maps, copy the key (inc ref since we are going to + REM release it below) + IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 + + + REM update the return sequence structure + REM release N (and M if T=8) since seq takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + REM process the next sequence entry from source list + A=Z%(A+1) + + GOTO EVAL_AST_SEQ_LOOP + EVAL_AST_SEQ_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO EVAL_AST_RETURN + + EVAL_AST_RETURN: + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q +END SUB + +REM EVAL(A, E) -> R +SUB EVAL + LV=LV+1: REM track basic return stack level + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) + + EVAL_TCO_RECUR: + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM AZ=A:B=1:GOSUB PR_STR + REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" + + GOSUB LIST_Q + IF R THEN GOTO APPLY_LIST + REM ELSE + CALL EVAL_AST + GOTO EVAL_RETURN + + APPLY_LIST: + GOSUB EMPTY_Q + IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN + + A0=Z%(A+2) + + REM get symbol in A$ + IF (Z%(A0)AND 31)<>5 THEN A$="" + IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) + + IF A$="def!" THEN GOTO EVAL_DEF + IF A$="let*" THEN GOTO EVAL_LET + IF A$="quote" THEN GOTO EVAL_QUOTE + IF A$="quasiquoteexpand" THEN GOTO EVAL_QUASIQUOTEEXPAND + IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE + IF A$="do" THEN GOTO EVAL_DO + IF A$="if" THEN GOTO EVAL_IF + IF A$="fn*" THEN GOTO EVAL_FN + GOTO EVAL_INVOKE + + EVAL_GET_A3: + A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) + EVAL_GET_A2: + A2=Z%(Z%(Z%(A+1)+1)+2) + EVAL_GET_A1: + A1=Z%(Z%(A+1)+2) + RETURN + + EVAL_DEF: + REM PRINT "def!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q + A=A2:CALL EVAL: REM eval a2 + GOSUB POP_Q:A1=Q + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM set a1 in env to a2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_LET: + REM PRINT "let*" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A2:GOSUB PUSH_Q: REM push/save A2 + Q=E:GOSUB PUSH_Q: REM push env for for later release + + REM create new environment with outer as current environment + C=E:GOSUB ENV_NEW + E=R + EVAL_LET_LOOP: + IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE + + Q=A1:GOSUB PUSH_Q: REM push A1 + REM eval current A1 odd element + A=Z%(Z%(A1+1)+2):CALL EVAL + GOSUB POP_Q:A1=Q: REM pop A1 + + IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE + + REM set key/value in the environment + K=Z%(A1+2):C=R:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership + + REM skip to the next pair of A1 elements + A1=Z%(Z%(A1+1)+1) + GOTO EVAL_LET_LOOP + + EVAL_LET_LOOP_DONE: + GOSUB POP_Q:AY=Q: REM pop previous env + + REM release previous environment if not the current EVAL env + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + GOSUB POP_Q:A2=Q: REM pop A2 + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_DO: + A=Z%(A+1): REM rest + GOSUB PUSH_A: REM push/save A + + REM this must be EVAL_AST call #2 for EVAL_AST to return early + REM and for TCO to work + CALL EVAL_AST + + REM cleanup + AY=R: REM get eval'd list for release + + GOSUB POP_A: REM pop/restore original A for LAST + GOSUB LAST: REM get last element for return + A=R: REM new recur AST + + REM cleanup + GOSUB RELEASE: REM release eval'd list + AY=A:GOSUB RELEASE: REM release LAST value (not sure why) + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_QUOTE: + R=Z%(Z%(A+1)+2) + GOSUB INC_REF_R + GOTO EVAL_RETURN + + EVAL_QUASIQUOTEEXPAND: + R=Z%(Z%(A+1)+2) + A=R:CALL QUASIQUOTE + GOTO EVAL_RETURN + + EVAL_QUASIQUOTE: + R=Z%(Z%(A+1)+2) + A=R:CALL QUASIQUOTE + A=R + REM add quasiquote result to pending release queue to free when + REM next lower EVAL level returns (LV) + GOSUB PEND_A_LV + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_IF: + GOSUB EVAL_GET_A1: REM set A1 + GOSUB PUSH_A: REM push/save A + A=A1:CALL EVAL + GOSUB POP_A: REM pop/restore A + IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE + + EVAL_IF_TRUE: + AY=R:GOSUB RELEASE + GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + EVAL_IF_FALSE: + AY=R:GOSUB RELEASE + REM if no false case (A3), return nil + GOSUB COUNT + IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN + GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL + A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_FN: + GOSUB EVAL_GET_A2: REM set A1 and A2 + T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function + GOTO EVAL_RETURN + + EVAL_INVOKE: + CALL EVAL_AST + + REM if error, return f/args for release by caller + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM push f/args for release after call + GOSUB PUSH_R + + AR=Z%(R+1): REM rest + F=Z%(R+2) + + REM if metadata, get the actual object + GOSUB TYPE_F + IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F + + ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION + + REM if error, pop and return f/args for release by caller + GOSUB POP_R + ER=-1:E$="apply of non-function":GOTO EVAL_RETURN + + EVAL_DO_FUNCTION: + REM regular function + IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP + REM for recur functions (apply, map, swap!), use GOTO + IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION + EVAL_DO_FUNCTION_SKIP: + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + GOTO EVAL_RETURN + + EVAL_DO_MAL_FUNCTION: + Q=E:GOSUB PUSH_Q: REM save the current environment for release + + REM create new environ using env and params stored in function + C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS + + REM release previous env if it is not the top one on the + REM stack (X%(X-2)) because our new env refers to it and + REM we no longer need to track it (since we are TCO recurring) + GOSUB POP_Q:AY=Q + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + REM claim the AST before releasing the list containing it + A=Z%(F+1):Z%(A)=Z%(A)+32 + REM add AST to pending release queue to free as soon as EVAL + REM actually returns (LV+1) + LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + + REM A set above + E=R:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_RETURN: + REM AZ=R: B=1: GOSUB PR_STR + REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) + + REM release environment if not the top one on the stack + GOSUB PEEK_Q_1 + IF E<>Q THEN AY=E:GOSUB RELEASE + + LV=LV-1: REM track basic return stack level + + REM release everything we couldn't release earlier + GOSUB RELEASE_PEND + + REM trigger GC + #cbm T=FRE(0) + #qbasic T=0 + + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + +END SUB + +REM PRINT(A) -> R$ +MAL_PRINT: + AZ=A:B=1:GOSUB PR_STR + RETURN + +REM RE(A$) -> R +REM Assume D has repl_env +REM caller must release result +RE: + R1=-1 + GOSUB MAL_READ + R1=R + IF ER<>-2 THEN GOTO RE_DONE + + A=R:E=D:CALL EVAL + + RE_DONE: + REM Release memory from MAL_READ + AY=R1:GOSUB RELEASE + RETURN: REM caller must release result of EVAL + +REM REP(A$) -> R$ +REM Assume D has repl_env +SUB REP + R2=-1 + + GOSUB RE + R2=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:GOSUB MAL_PRINT + + REP_DONE: + REM Release memory from MAL_READ and EVAL + AY=R2:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + LV=0 + + REM create repl_env + C=0:GOSUB ENV_NEW:D=R + + REM core.EXT: defined in Basic + E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env + + ZT=ZI: REM top of memory after base repl_env + + REM core.mal: defined using the language itself + A$="(def! not (fn* (a) (if a false true)))" + GOSUB RE:AY=R:GOSUB RELEASE + + A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM load the args file + A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" + GOSUB RE:AY=R:GOSUB RELEASE + + IF ER>-2 THEN GOSUB PRINT_ERROR:END + + REM set the argument list + A$="(def! *ARGV* (rest -*ARGS*-))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM get the first argument + A$="(first -*ARGS*-)" + GOSUB RE + + REM no arguments, start REPL loop + IF R<16 THEN GOTO REPL_LOOP + + REM if there is an argument, then run it as a program + + RUN_PROG: + REM free up first arg because we get it again + AY=R:GOSUB RELEASE + REM run a single mal program and exit + A$="(load-file (first -*ARGS*-))" + GOSUB RE + IF ER<>-2 THEN GOSUB PRINT_ERROR + GOTO QUIT + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/step8_macros.in.bas b/impls/basic/step8_macros.in.bas index 0e7418a310..ac5596354c 100755 --- a/impls/basic/step8_macros.in.bas +++ b/impls/basic/step8_macros.in.bas @@ -1,634 +1,634 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' -REM $INCLUDE: 'env.in.bas' -REM $INCLUDE: 'core.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R -MAL_READ: - GOSUB READ_STR - RETURN - -REM QUASIQUOTE(A) -> R -SUB QUASIQUOTE - GOSUB TYPE_A - IF T<5 OR T>8 THEN GOTO QQ_UNCHANGED - IF T=5 OR T=8 THEN GOTO QQ_QUOTE - IF T=7 THEN GOTO QQ_VECTOR - IF (Z%(A+1)=0) THEN GOTO QQ_LIST - R=Z%(A+2) - IF (Z%(R)AND 31)<>5 THEN GOTO QQ_LIST - IF S$(Z%(R+1))<>"unquote" THEN GOTO QQ_LIST - GOTO QQ_UNQUOTE - - QQ_UNCHANGED: - R=A - GOSUB INC_REF_R - - GOTO QQ_DONE - - QQ_QUOTE: - REM ['quote, ast] - B$="quote":T=5:GOSUB STRING - B=R:GOSUB LIST2 - AY=B:GOSUB RELEASE - - GOTO QQ_DONE - - QQ_VECTOR: - REM ['vec, (qq_foldr ast)] - CALL QQ_FOLDR - A=R - B$="vec":T=5:GOSUB STRING:B=R - GOSUB LIST2 - AY=A:GOSUB RELEASE - AY=B:GOSUB RELEASE - - GOTO QQ_DONE - - QQ_UNQUOTE: - REM [ast[1]] - R=Z%(Z%(A+1)+2) - GOSUB INC_REF_R - - GOTO QQ_DONE - - QQ_LIST: - CALL QQ_FOLDR - -QQ_DONE: -END SUB - -REM Quasiquote right fold (A) -> R. -REM Used for unquoted lists (GOTO), vectors (GOSUB), -REM and recursively (GOSUB). -SUB QQ_FOLDR - IF A=0 THEN GOTO QQ_EMPTY - IF Z%(A+1)=0 THEN GOTO QQ_EMPTY - GOTO QQ_NOTEMPTY - - QQ_EMPTY: - REM empty list/vector -> empty list - R=6 - GOSUB INC_REF_R - - GOTO QQ_FOLDR_DONE - - QQ_NOTEMPTY: - REM Execute QQ_FOLDR recursively with (rest A) - GOSUB PUSH_A - A=Z%(A+1):CALL QQ_FOLDR - GOSUB POP_A - - REM Set A to elt = (first A) - A=Z%(A+2) - - REM Quasiquote transition function: - REM A: current element, R: accumulator -> R: new accumulator - - REM check if A is a list starting with splice-unquote - GOSUB TYPE_A - IF T<>6 THEN GOTO QQ_DEFAULT - IF (Z%(A+1)=0) THEN GOTO QQ_DEFAULT - B=Z%(A+2) - IF (Z%(B)AND 31)<>5 THEN GOTO QQ_DEFAULT - IF S$(Z%(B+1))<>"splice-unquote" THEN GOTO QQ_DEFAULT - - REM ('concat, A[1], R) - B=Z%(Z%(A+1)+2) - A=R - B$="concat":T=5:GOSUB STRING:C=R - GOSUB LIST3 - REM release inner quasiquoted since outer list takes ownership - AY=A:GOSUB RELEASE - AY=C:GOSUB RELEASE - - GOTO QQ_FOLDR_DONE - - QQ_DEFAULT: - REM ('cons, quasiquote(A), R) - GOSUB PUSH_R - CALL QUASIQUOTE - B=R - B$="cons":T=5:GOSUB STRING:C=R - GOSUB POP_A - GOSUB LIST3 - REM release inner quasiquoted since outer list takes ownership - AY=A:GOSUB RELEASE - AY=B:GOSUB RELEASE - AY=C:GOSUB RELEASE - -QQ_FOLDR_DONE: -END SUB - -REM MACROEXPAND(A, E) -> A: -SUB MACROEXPAND - GOSUB PUSH_A - - MACROEXPAND_LOOP: - REM list? - GOSUB TYPE_A - IF T<>6 THEN GOTO MACROEXPAND_DONE - REM non-empty? - IF Z%(A+1)=0 THEN GOTO MACROEXPAND_DONE - B=Z%(A+2) - REM symbol? in first position - IF (Z%(B)AND 31)<>5 THEN GOTO MACROEXPAND_DONE - REM defined in environment? - K=B:CALL ENV_FIND - IF R=-1 THEN GOTO MACROEXPAND_DONE - B=R4 - REM macro? - IF (Z%(B)AND 31)<>11 THEN GOTO MACROEXPAND_DONE - - F=B:AR=Z%(A+1):CALL APPLY - A=R - - GOSUB PEEK_Q:AY=Q - REM if previous A was not the first A into macroexpand (i.e. an - REM intermediate form) then free it - IF A<>AY THEN GOSUB PEND_A_LV - - IF ER<>-2 THEN GOTO MACROEXPAND_DONE - GOTO MACROEXPAND_LOOP - - MACROEXPAND_DONE: - GOSUB POP_Q: REM pop original A -END SUB - -REM EVAL_AST(A, E) -> R -SUB EVAL_AST - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_AST_RETURN - - GOSUB TYPE_A - IF T=5 THEN GOTO EVAL_AST_SYMBOL - IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ - - REM scalar: deref to actual value and inc ref cnt - R=A - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SYMBOL: - K=A:GOTO ENV_GET - ENV_GET_RETURN: - GOTO EVAL_AST_RETURN - - EVAL_AST_SEQ: - REM setup the stack for the loop - GOSUB MAP_LOOP_START - - EVAL_AST_SEQ_LOOP: - REM check if we are done evaluating the source sequence - IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM if we are returning to DO, then skip last element - REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to - REM return early and for TCO to work - Q=5:GOSUB PEEK_Q_Q - IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM call EVAL for each entry - GOSUB PUSH_A - IF T<>8 THEN A=Z%(A+2) - IF T=8 THEN A=Z%(A+3) - Q=T:GOSUB PUSH_Q: REM push/save type - CALL EVAL - GOSUB POP_Q:T=Q: REM pop/restore type - GOSUB POP_A - M=R - - REM if error, release the unattached element - REM TODO: is R=0 correct? - IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE - - REM for hash-maps, copy the key (inc ref since we are going to - REM release it below) - IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 - - - REM update the return sequence structure - REM release N (and M if T=8) since seq takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - REM process the next sequence entry from source list - A=Z%(A+1) - - GOTO EVAL_AST_SEQ_LOOP - EVAL_AST_SEQ_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO EVAL_AST_RETURN - - EVAL_AST_RETURN: - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q -END SUB - -REM EVAL(A, E) -> R -SUB EVAL - LV=LV+1: REM track basic return stack level - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) - - EVAL_TCO_RECUR: - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM AZ=A:B=1:GOSUB PR_STR - REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" - - GOSUB LIST_Q - IF R THEN GOTO APPLY_LIST - EVAL_NOT_LIST: - REM ELSE - CALL EVAL_AST - GOTO EVAL_RETURN - - APPLY_LIST: - CALL MACROEXPAND - - GOSUB LIST_Q - IF R<>1 THEN GOTO EVAL_NOT_LIST - - GOSUB EMPTY_Q - IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN - - A0=Z%(A+2) - - REM get symbol in A$ - IF (Z%(A0)AND 31)<>5 THEN A$="" - IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) - - IF A$="def!" THEN GOTO EVAL_DEF - IF A$="let*" THEN GOTO EVAL_LET - IF A$="quote" THEN GOTO EVAL_QUOTE - IF A$="quasiquoteexpand" THEN GOTO EVAL_QUASIQUOTEEXPAND - IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE - IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO - IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND - IF A$="do" THEN GOTO EVAL_DO - IF A$="if" THEN GOTO EVAL_IF - IF A$="fn*" THEN GOTO EVAL_FN - GOTO EVAL_INVOKE - - EVAL_GET_A3: - A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) - EVAL_GET_A2: - A2=Z%(Z%(Z%(A+1)+1)+2) - EVAL_GET_A1: - A1=Z%(Z%(A+1)+2) - RETURN - - EVAL_DEF: - REM PRINT "def!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q - A=A2:CALL EVAL: REM eval a2 - GOSUB POP_Q:A1=Q - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM set a1 in env to a2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_LET: - REM PRINT "let*" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A2:GOSUB PUSH_Q: REM push/save A2 - Q=E:GOSUB PUSH_Q: REM push env for for later release - - REM create new environment with outer as current environment - C=E:GOSUB ENV_NEW - E=R - EVAL_LET_LOOP: - IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE - - Q=A1:GOSUB PUSH_Q: REM push A1 - REM eval current A1 odd element - A=Z%(Z%(A1+1)+2):CALL EVAL - GOSUB POP_Q:A1=Q: REM pop A1 - - IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE - - REM set key/value in the environment - K=Z%(A1+2):C=R:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership - - REM skip to the next pair of A1 elements - A1=Z%(Z%(A1+1)+1) - GOTO EVAL_LET_LOOP - - EVAL_LET_LOOP_DONE: - GOSUB POP_Q:AY=Q: REM pop previous env - - REM release previous environment if not the current EVAL env - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - GOSUB POP_Q:A2=Q: REM pop A2 - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_DO: - A=Z%(A+1): REM rest - GOSUB PUSH_A: REM push/save A - - REM this must be EVAL_AST call #2 for EVAL_AST to return early - REM and for TCO to work - CALL EVAL_AST - - REM cleanup - AY=R: REM get eval'd list for release - - GOSUB POP_A: REM pop/restore original A for LAST - GOSUB LAST: REM get last element for return - A=R: REM new recur AST - - REM cleanup - GOSUB RELEASE: REM release eval'd list - AY=A:GOSUB RELEASE: REM release LAST value (not sure why) - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_QUOTE: - R=Z%(Z%(A+1)+2) - GOSUB INC_REF_R - GOTO EVAL_RETURN - - EVAL_QUASIQUOTEEXPAND: - R=Z%(Z%(A+1)+2) - A=R:CALL QUASIQUOTE - GOTO EVAL_RETURN - - EVAL_QUASIQUOTE: - R=Z%(Z%(A+1)+2) - A=R:CALL QUASIQUOTE - A=R - REM add quasiquote result to pending release queue to free when - REM next lower EVAL level returns (LV) - GOSUB PEND_A_LV - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_DEFMACRO: - REM PRINT "defmacro!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q: REM push A1 - A=A2:CALL EVAL: REM eval A2 - GOSUB POP_Q:A1=Q: REM pop A1 - - REM change function to macro - Z%(R)=Z%(R)+1 - - REM set A1 in env to A2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_MACROEXPAND: - REM PRINT "macroexpand" - R=Z%(Z%(A+1)+2) - A=R:CALL MACROEXPAND - R=A - - REM since we are returning it unevaluated, inc the ref cnt - GOSUB INC_REF_R - GOTO EVAL_RETURN - - EVAL_IF: - GOSUB EVAL_GET_A1: REM set A1 - GOSUB PUSH_A: REM push/save A - A=A1:CALL EVAL - GOSUB POP_A: REM pop/restore A - IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE - - EVAL_IF_TRUE: - AY=R:GOSUB RELEASE - GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - EVAL_IF_FALSE: - AY=R:GOSUB RELEASE - REM if no false case (A3), return nil - GOSUB COUNT - IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN - GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL - A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_FN: - GOSUB EVAL_GET_A2: REM set A1 and A2 - T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function - GOTO EVAL_RETURN - - EVAL_INVOKE: - CALL EVAL_AST - - REM if error, return f/args for release by caller - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM push f/args for release after call - GOSUB PUSH_R - - AR=Z%(R+1): REM rest - F=Z%(R+2) - - REM if metadata, get the actual object - GOSUB TYPE_F - IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F - - ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION - - REM if error, pop and return f/args for release by caller - GOSUB POP_R - ER=-1:E$="apply of non-function":GOTO EVAL_RETURN - - EVAL_DO_FUNCTION: - REM regular function - IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP - REM for recur functions (apply, map, swap!), use GOTO - IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION - EVAL_DO_FUNCTION_SKIP: - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - GOTO EVAL_RETURN - - EVAL_DO_MAL_FUNCTION: - Q=E:GOSUB PUSH_Q: REM save the current environment for release - - REM create new environ using env and params stored in function - C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS - - REM release previous env if it is not the top one on the - REM stack (X%(X-2)) because our new env refers to it and - REM we no longer need to track it (since we are TCO recurring) - GOSUB POP_Q:AY=Q - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - REM claim the AST before releasing the list containing it - A=Z%(F+1):Z%(A)=Z%(A)+32 - REM add AST to pending release queue to free as soon as EVAL - REM actually returns (LV+1) - LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - - REM A set above - E=R:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_RETURN: - REM AZ=R: B=1: GOSUB PR_STR - REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) - - REM release environment if not the top one on the stack - GOSUB PEEK_Q_1 - IF E<>Q THEN AY=E:GOSUB RELEASE - - LV=LV-1: REM track basic return stack level - - REM release everything we couldn't release earlier - GOSUB RELEASE_PEND - - REM trigger GC - #cbm T=FRE(0) - #qbasic T=0 - - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - -END SUB - -REM PRINT(A) -> R$ -MAL_PRINT: - AZ=A:B=1:GOSUB PR_STR - RETURN - -REM RE(A$) -> R -REM Assume D has repl_env -REM caller must release result -RE: - R1=-1 - GOSUB MAL_READ - R1=R - IF ER<>-2 THEN GOTO RE_DONE - - A=R:E=D:CALL EVAL - - RE_DONE: - REM Release memory from MAL_READ - AY=R1:GOSUB RELEASE - RETURN: REM caller must release result of EVAL - -REM REP(A$) -> R$ -REM Assume D has repl_env -SUB REP - R2=-1 - - GOSUB RE - R2=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:GOSUB MAL_PRINT - - REP_DONE: - REM Release memory from MAL_READ and EVAL - AY=R2:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - LV=0 - - REM create repl_env - C=0:GOSUB ENV_NEW:D=R - - REM core.EXT: defined in Basic - E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env - - ZT=ZI: REM top of memory after base repl_env - - REM core.mal: defined using the language itself - A$="(def! not (fn* (a) (if a false true)))" - GOSUB RE:AY=R:GOSUB RELEASE - - A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" - GOSUB RE:AY=R:GOSUB RELEASE - - A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)" - A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of" - A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM load the args file - A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" - GOSUB RE:AY=R:GOSUB RELEASE - - IF ER>-2 THEN GOSUB PRINT_ERROR:END - - REM set the argument list - A$="(def! *ARGV* (rest -*ARGS*-))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM get the first argument - A$="(first -*ARGS*-)" - GOSUB RE - - REM no arguments, start REPL loop - IF R<16 THEN GOTO REPL_LOOP - - REM if there is an argument, then run it as a program - - RUN_PROG: - REM free up first arg because we get it again - AY=R:GOSUB RELEASE - REM run a single mal program and exit - A$="(load-file (first -*ARGS*-))" - GOSUB RE - IF ER<>-2 THEN GOSUB PRINT_ERROR - GOTO QUIT - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' +REM $INCLUDE: 'env.in.bas' +REM $INCLUDE: 'core.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R +MAL_READ: + GOSUB READ_STR + RETURN + +REM QUASIQUOTE(A) -> R +SUB QUASIQUOTE + GOSUB TYPE_A + IF T<5 OR T>8 THEN GOTO QQ_UNCHANGED + IF T=5 OR T=8 THEN GOTO QQ_QUOTE + IF T=7 THEN GOTO QQ_VECTOR + IF (Z%(A+1)=0) THEN GOTO QQ_LIST + R=Z%(A+2) + IF (Z%(R)AND 31)<>5 THEN GOTO QQ_LIST + IF S$(Z%(R+1))<>"unquote" THEN GOTO QQ_LIST + GOTO QQ_UNQUOTE + + QQ_UNCHANGED: + R=A + GOSUB INC_REF_R + + GOTO QQ_DONE + + QQ_QUOTE: + REM ['quote, ast] + B$="quote":T=5:GOSUB STRING + B=R:GOSUB LIST2 + AY=B:GOSUB RELEASE + + GOTO QQ_DONE + + QQ_VECTOR: + REM ['vec, (qq_foldr ast)] + CALL QQ_FOLDR + A=R + B$="vec":T=5:GOSUB STRING:B=R + GOSUB LIST2 + AY=A:GOSUB RELEASE + AY=B:GOSUB RELEASE + + GOTO QQ_DONE + + QQ_UNQUOTE: + REM [ast[1]] + R=Z%(Z%(A+1)+2) + GOSUB INC_REF_R + + GOTO QQ_DONE + + QQ_LIST: + CALL QQ_FOLDR + +QQ_DONE: +END SUB + +REM Quasiquote right fold (A) -> R. +REM Used for unquoted lists (GOTO), vectors (GOSUB), +REM and recursively (GOSUB). +SUB QQ_FOLDR + IF A=0 THEN GOTO QQ_EMPTY + IF Z%(A+1)=0 THEN GOTO QQ_EMPTY + GOTO QQ_NOTEMPTY + + QQ_EMPTY: + REM empty list/vector -> empty list + R=6 + GOSUB INC_REF_R + + GOTO QQ_FOLDR_DONE + + QQ_NOTEMPTY: + REM Execute QQ_FOLDR recursively with (rest A) + GOSUB PUSH_A + A=Z%(A+1):CALL QQ_FOLDR + GOSUB POP_A + + REM Set A to elt = (first A) + A=Z%(A+2) + + REM Quasiquote transition function: + REM A: current element, R: accumulator -> R: new accumulator + + REM check if A is a list starting with splice-unquote + GOSUB TYPE_A + IF T<>6 THEN GOTO QQ_DEFAULT + IF (Z%(A+1)=0) THEN GOTO QQ_DEFAULT + B=Z%(A+2) + IF (Z%(B)AND 31)<>5 THEN GOTO QQ_DEFAULT + IF S$(Z%(B+1))<>"splice-unquote" THEN GOTO QQ_DEFAULT + + REM ('concat, A[1], R) + B=Z%(Z%(A+1)+2) + A=R + B$="concat":T=5:GOSUB STRING:C=R + GOSUB LIST3 + REM release inner quasiquoted since outer list takes ownership + AY=A:GOSUB RELEASE + AY=C:GOSUB RELEASE + + GOTO QQ_FOLDR_DONE + + QQ_DEFAULT: + REM ('cons, quasiquote(A), R) + GOSUB PUSH_R + CALL QUASIQUOTE + B=R + B$="cons":T=5:GOSUB STRING:C=R + GOSUB POP_A + GOSUB LIST3 + REM release inner quasiquoted since outer list takes ownership + AY=A:GOSUB RELEASE + AY=B:GOSUB RELEASE + AY=C:GOSUB RELEASE + +QQ_FOLDR_DONE: +END SUB + +REM MACROEXPAND(A, E) -> A: +SUB MACROEXPAND + GOSUB PUSH_A + + MACROEXPAND_LOOP: + REM list? + GOSUB TYPE_A + IF T<>6 THEN GOTO MACROEXPAND_DONE + REM non-empty? + IF Z%(A+1)=0 THEN GOTO MACROEXPAND_DONE + B=Z%(A+2) + REM symbol? in first position + IF (Z%(B)AND 31)<>5 THEN GOTO MACROEXPAND_DONE + REM defined in environment? + K=B:CALL ENV_FIND + IF R=-1 THEN GOTO MACROEXPAND_DONE + B=R4 + REM macro? + IF (Z%(B)AND 31)<>11 THEN GOTO MACROEXPAND_DONE + + F=B:AR=Z%(A+1):CALL APPLY + A=R + + GOSUB PEEK_Q:AY=Q + REM if previous A was not the first A into macroexpand (i.e. an + REM intermediate form) then free it + IF A<>AY THEN GOSUB PEND_A_LV + + IF ER<>-2 THEN GOTO MACROEXPAND_DONE + GOTO MACROEXPAND_LOOP + + MACROEXPAND_DONE: + GOSUB POP_Q: REM pop original A +END SUB + +REM EVAL_AST(A, E) -> R +SUB EVAL_AST + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_AST_RETURN + + GOSUB TYPE_A + IF T=5 THEN GOTO EVAL_AST_SYMBOL + IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ + + REM scalar: deref to actual value and inc ref cnt + R=A + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SYMBOL: + K=A:GOTO ENV_GET + ENV_GET_RETURN: + GOTO EVAL_AST_RETURN + + EVAL_AST_SEQ: + REM setup the stack for the loop + GOSUB MAP_LOOP_START + + EVAL_AST_SEQ_LOOP: + REM check if we are done evaluating the source sequence + IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM if we are returning to DO, then skip last element + REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to + REM return early and for TCO to work + Q=5:GOSUB PEEK_Q_Q + IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM call EVAL for each entry + GOSUB PUSH_A + IF T<>8 THEN A=Z%(A+2) + IF T=8 THEN A=Z%(A+3) + Q=T:GOSUB PUSH_Q: REM push/save type + CALL EVAL + GOSUB POP_Q:T=Q: REM pop/restore type + GOSUB POP_A + M=R + + REM if error, release the unattached element + REM TODO: is R=0 correct? + IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE + + REM for hash-maps, copy the key (inc ref since we are going to + REM release it below) + IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 + + + REM update the return sequence structure + REM release N (and M if T=8) since seq takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + REM process the next sequence entry from source list + A=Z%(A+1) + + GOTO EVAL_AST_SEQ_LOOP + EVAL_AST_SEQ_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO EVAL_AST_RETURN + + EVAL_AST_RETURN: + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q +END SUB + +REM EVAL(A, E) -> R +SUB EVAL + LV=LV+1: REM track basic return stack level + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) + + EVAL_TCO_RECUR: + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM AZ=A:B=1:GOSUB PR_STR + REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" + + GOSUB LIST_Q + IF R THEN GOTO APPLY_LIST + EVAL_NOT_LIST: + REM ELSE + CALL EVAL_AST + GOTO EVAL_RETURN + + APPLY_LIST: + CALL MACROEXPAND + + GOSUB LIST_Q + IF R<>1 THEN GOTO EVAL_NOT_LIST + + GOSUB EMPTY_Q + IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN + + A0=Z%(A+2) + + REM get symbol in A$ + IF (Z%(A0)AND 31)<>5 THEN A$="" + IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) + + IF A$="def!" THEN GOTO EVAL_DEF + IF A$="let*" THEN GOTO EVAL_LET + IF A$="quote" THEN GOTO EVAL_QUOTE + IF A$="quasiquoteexpand" THEN GOTO EVAL_QUASIQUOTEEXPAND + IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE + IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO + IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND + IF A$="do" THEN GOTO EVAL_DO + IF A$="if" THEN GOTO EVAL_IF + IF A$="fn*" THEN GOTO EVAL_FN + GOTO EVAL_INVOKE + + EVAL_GET_A3: + A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) + EVAL_GET_A2: + A2=Z%(Z%(Z%(A+1)+1)+2) + EVAL_GET_A1: + A1=Z%(Z%(A+1)+2) + RETURN + + EVAL_DEF: + REM PRINT "def!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q + A=A2:CALL EVAL: REM eval a2 + GOSUB POP_Q:A1=Q + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM set a1 in env to a2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_LET: + REM PRINT "let*" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A2:GOSUB PUSH_Q: REM push/save A2 + Q=E:GOSUB PUSH_Q: REM push env for for later release + + REM create new environment with outer as current environment + C=E:GOSUB ENV_NEW + E=R + EVAL_LET_LOOP: + IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE + + Q=A1:GOSUB PUSH_Q: REM push A1 + REM eval current A1 odd element + A=Z%(Z%(A1+1)+2):CALL EVAL + GOSUB POP_Q:A1=Q: REM pop A1 + + IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE + + REM set key/value in the environment + K=Z%(A1+2):C=R:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership + + REM skip to the next pair of A1 elements + A1=Z%(Z%(A1+1)+1) + GOTO EVAL_LET_LOOP + + EVAL_LET_LOOP_DONE: + GOSUB POP_Q:AY=Q: REM pop previous env + + REM release previous environment if not the current EVAL env + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + GOSUB POP_Q:A2=Q: REM pop A2 + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_DO: + A=Z%(A+1): REM rest + GOSUB PUSH_A: REM push/save A + + REM this must be EVAL_AST call #2 for EVAL_AST to return early + REM and for TCO to work + CALL EVAL_AST + + REM cleanup + AY=R: REM get eval'd list for release + + GOSUB POP_A: REM pop/restore original A for LAST + GOSUB LAST: REM get last element for return + A=R: REM new recur AST + + REM cleanup + GOSUB RELEASE: REM release eval'd list + AY=A:GOSUB RELEASE: REM release LAST value (not sure why) + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_QUOTE: + R=Z%(Z%(A+1)+2) + GOSUB INC_REF_R + GOTO EVAL_RETURN + + EVAL_QUASIQUOTEEXPAND: + R=Z%(Z%(A+1)+2) + A=R:CALL QUASIQUOTE + GOTO EVAL_RETURN + + EVAL_QUASIQUOTE: + R=Z%(Z%(A+1)+2) + A=R:CALL QUASIQUOTE + A=R + REM add quasiquote result to pending release queue to free when + REM next lower EVAL level returns (LV) + GOSUB PEND_A_LV + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_DEFMACRO: + REM PRINT "defmacro!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q: REM push A1 + A=A2:CALL EVAL: REM eval A2 + GOSUB POP_Q:A1=Q: REM pop A1 + + REM change function to macro + Z%(R)=Z%(R)+1 + + REM set A1 in env to A2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_MACROEXPAND: + REM PRINT "macroexpand" + R=Z%(Z%(A+1)+2) + A=R:CALL MACROEXPAND + R=A + + REM since we are returning it unevaluated, inc the ref cnt + GOSUB INC_REF_R + GOTO EVAL_RETURN + + EVAL_IF: + GOSUB EVAL_GET_A1: REM set A1 + GOSUB PUSH_A: REM push/save A + A=A1:CALL EVAL + GOSUB POP_A: REM pop/restore A + IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE + + EVAL_IF_TRUE: + AY=R:GOSUB RELEASE + GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + EVAL_IF_FALSE: + AY=R:GOSUB RELEASE + REM if no false case (A3), return nil + GOSUB COUNT + IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN + GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL + A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_FN: + GOSUB EVAL_GET_A2: REM set A1 and A2 + T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function + GOTO EVAL_RETURN + + EVAL_INVOKE: + CALL EVAL_AST + + REM if error, return f/args for release by caller + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM push f/args for release after call + GOSUB PUSH_R + + AR=Z%(R+1): REM rest + F=Z%(R+2) + + REM if metadata, get the actual object + GOSUB TYPE_F + IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F + + ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION + + REM if error, pop and return f/args for release by caller + GOSUB POP_R + ER=-1:E$="apply of non-function":GOTO EVAL_RETURN + + EVAL_DO_FUNCTION: + REM regular function + IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP + REM for recur functions (apply, map, swap!), use GOTO + IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION + EVAL_DO_FUNCTION_SKIP: + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + GOTO EVAL_RETURN + + EVAL_DO_MAL_FUNCTION: + Q=E:GOSUB PUSH_Q: REM save the current environment for release + + REM create new environ using env and params stored in function + C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS + + REM release previous env if it is not the top one on the + REM stack (X%(X-2)) because our new env refers to it and + REM we no longer need to track it (since we are TCO recurring) + GOSUB POP_Q:AY=Q + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + REM claim the AST before releasing the list containing it + A=Z%(F+1):Z%(A)=Z%(A)+32 + REM add AST to pending release queue to free as soon as EVAL + REM actually returns (LV+1) + LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + + REM A set above + E=R:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_RETURN: + REM AZ=R: B=1: GOSUB PR_STR + REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) + + REM release environment if not the top one on the stack + GOSUB PEEK_Q_1 + IF E<>Q THEN AY=E:GOSUB RELEASE + + LV=LV-1: REM track basic return stack level + + REM release everything we couldn't release earlier + GOSUB RELEASE_PEND + + REM trigger GC + #cbm T=FRE(0) + #qbasic T=0 + + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + +END SUB + +REM PRINT(A) -> R$ +MAL_PRINT: + AZ=A:B=1:GOSUB PR_STR + RETURN + +REM RE(A$) -> R +REM Assume D has repl_env +REM caller must release result +RE: + R1=-1 + GOSUB MAL_READ + R1=R + IF ER<>-2 THEN GOTO RE_DONE + + A=R:E=D:CALL EVAL + + RE_DONE: + REM Release memory from MAL_READ + AY=R1:GOSUB RELEASE + RETURN: REM caller must release result of EVAL + +REM REP(A$) -> R$ +REM Assume D has repl_env +SUB REP + R2=-1 + + GOSUB RE + R2=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:GOSUB MAL_PRINT + + REP_DONE: + REM Release memory from MAL_READ and EVAL + AY=R2:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + LV=0 + + REM create repl_env + C=0:GOSUB ENV_NEW:D=R + + REM core.EXT: defined in Basic + E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env + + ZT=ZI: REM top of memory after base repl_env + + REM core.mal: defined using the language itself + A$="(def! not (fn* (a) (if a false true)))" + GOSUB RE:AY=R:GOSUB RELEASE + + A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" + GOSUB RE:AY=R:GOSUB RELEASE + + A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)" + A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of" + A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM load the args file + A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" + GOSUB RE:AY=R:GOSUB RELEASE + + IF ER>-2 THEN GOSUB PRINT_ERROR:END + + REM set the argument list + A$="(def! *ARGV* (rest -*ARGS*-))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM get the first argument + A$="(first -*ARGS*-)" + GOSUB RE + + REM no arguments, start REPL loop + IF R<16 THEN GOTO REPL_LOOP + + REM if there is an argument, then run it as a program + + RUN_PROG: + REM free up first arg because we get it again + AY=R:GOSUB RELEASE + REM run a single mal program and exit + A$="(load-file (first -*ARGS*-))" + GOSUB RE + IF ER<>-2 THEN GOSUB PRINT_ERROR + GOTO QUIT + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/step9_try.in.bas b/impls/basic/step9_try.in.bas index 51b9c0899e..767d771d08 100755 --- a/impls/basic/step9_try.in.bas +++ b/impls/basic/step9_try.in.bas @@ -1,669 +1,669 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' -REM $INCLUDE: 'env.in.bas' -REM $INCLUDE: 'core.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ(A$) -> R -MAL_READ: - GOSUB READ_STR - RETURN - -REM QUASIQUOTE(A) -> R -SUB QUASIQUOTE - GOSUB TYPE_A - IF T<5 OR T>8 THEN GOTO QQ_UNCHANGED - IF T=5 OR T=8 THEN GOTO QQ_QUOTE - IF T=7 THEN GOTO QQ_VECTOR - IF (Z%(A+1)=0) THEN GOTO QQ_LIST - R=Z%(A+2) - IF (Z%(R)AND 31)<>5 THEN GOTO QQ_LIST - IF S$(Z%(R+1))<>"unquote" THEN GOTO QQ_LIST - GOTO QQ_UNQUOTE - - QQ_UNCHANGED: - R=A - GOSUB INC_REF_R - - GOTO QQ_DONE - - QQ_QUOTE: - REM ['quote, ast] - B$="quote":T=5:GOSUB STRING - B=R:GOSUB LIST2 - AY=B:GOSUB RELEASE - - GOTO QQ_DONE - - QQ_VECTOR: - REM ['vec, (qq_foldr ast)] - CALL QQ_FOLDR - A=R - B$="vec":T=5:GOSUB STRING:B=R - GOSUB LIST2 - AY=A:GOSUB RELEASE - AY=B:GOSUB RELEASE - - GOTO QQ_DONE - - QQ_UNQUOTE: - REM [ast[1]] - R=Z%(Z%(A+1)+2) - GOSUB INC_REF_R - - GOTO QQ_DONE - - QQ_LIST: - CALL QQ_FOLDR - -QQ_DONE: -END SUB - -REM Quasiquote right fold (A) -> R. -REM Used for unquoted lists (GOTO), vectors (GOSUB), -REM and recursively (GOSUB). -SUB QQ_FOLDR - IF A=0 THEN GOTO QQ_EMPTY - IF Z%(A+1)=0 THEN GOTO QQ_EMPTY - GOTO QQ_NOTEMPTY - - QQ_EMPTY: - REM empty list/vector -> empty list - R=6 - GOSUB INC_REF_R - - GOTO QQ_FOLDR_DONE - - QQ_NOTEMPTY: - REM Execute QQ_FOLDR recursively with (rest A) - GOSUB PUSH_A - A=Z%(A+1):CALL QQ_FOLDR - GOSUB POP_A - - REM Set A to elt = (first A) - A=Z%(A+2) - - REM Quasiquote transition function: - REM A: current element, R: accumulator -> R: new accumulator - - REM check if A is a list starting with splice-unquote - GOSUB TYPE_A - IF T<>6 THEN GOTO QQ_DEFAULT - IF (Z%(A+1)=0) THEN GOTO QQ_DEFAULT - B=Z%(A+2) - IF (Z%(B)AND 31)<>5 THEN GOTO QQ_DEFAULT - IF S$(Z%(B+1))<>"splice-unquote" THEN GOTO QQ_DEFAULT - - REM ('concat, A[1], R) - B=Z%(Z%(A+1)+2) - A=R - B$="concat":T=5:GOSUB STRING:C=R - GOSUB LIST3 - REM release inner quasiquoted since outer list takes ownership - AY=A:GOSUB RELEASE - AY=C:GOSUB RELEASE - - GOTO QQ_FOLDR_DONE - - QQ_DEFAULT: - REM ('cons, quasiquote(A), R) - GOSUB PUSH_R - CALL QUASIQUOTE - B=R - B$="cons":T=5:GOSUB STRING:C=R - GOSUB POP_A - GOSUB LIST3 - REM release inner quasiquoted since outer list takes ownership - AY=A:GOSUB RELEASE - AY=B:GOSUB RELEASE - AY=C:GOSUB RELEASE - -QQ_FOLDR_DONE: -END SUB - -REM MACROEXPAND(A, E) -> A: -SUB MACROEXPAND - GOSUB PUSH_A - - MACROEXPAND_LOOP: - REM list? - GOSUB TYPE_A - IF T<>6 THEN GOTO MACROEXPAND_DONE - REM non-empty? - IF Z%(A+1)=0 THEN GOTO MACROEXPAND_DONE - B=Z%(A+2) - REM symbol? in first position - IF (Z%(B)AND 31)<>5 THEN GOTO MACROEXPAND_DONE - REM defined in environment? - K=B:CALL ENV_FIND - IF R=-1 THEN GOTO MACROEXPAND_DONE - B=R4 - REM macro? - IF (Z%(B)AND 31)<>11 THEN GOTO MACROEXPAND_DONE - - F=B:AR=Z%(A+1):CALL APPLY - A=R - - GOSUB PEEK_Q:AY=Q - REM if previous A was not the first A into macroexpand (i.e. an - REM intermediate form) then free it - IF A<>AY THEN GOSUB PEND_A_LV - - IF ER<>-2 THEN GOTO MACROEXPAND_DONE - GOTO MACROEXPAND_LOOP - - MACROEXPAND_DONE: - GOSUB POP_Q: REM pop original A -END SUB - -REM EVAL_AST(A, E) -> R -SUB EVAL_AST - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_AST_RETURN - - GOSUB TYPE_A - IF T=5 THEN GOTO EVAL_AST_SYMBOL - IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ - - REM scalar: deref to actual value and inc ref cnt - R=A - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SYMBOL: - K=A:GOTO ENV_GET - ENV_GET_RETURN: - GOTO EVAL_AST_RETURN - - EVAL_AST_SEQ: - REM setup the stack for the loop - GOSUB MAP_LOOP_START - - EVAL_AST_SEQ_LOOP: - REM check if we are done evaluating the source sequence - IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM if we are returning to DO, then skip last element - REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to - REM return early and for TCO to work - Q=5:GOSUB PEEK_Q_Q - IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM call EVAL for each entry - GOSUB PUSH_A - IF T<>8 THEN A=Z%(A+2) - IF T=8 THEN A=Z%(A+3) - Q=T:GOSUB PUSH_Q: REM push/save type - CALL EVAL - GOSUB POP_Q:T=Q: REM pop/restore type - GOSUB POP_A - M=R - - REM if error, release the unattached element - REM TODO: is R=0 correct? - IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE - - REM for hash-maps, copy the key (inc ref since we are going to - REM release it below) - IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 - - - REM update the return sequence structure - REM release N (and M if T=8) since seq takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - REM process the next sequence entry from source list - A=Z%(A+1) - - GOTO EVAL_AST_SEQ_LOOP - EVAL_AST_SEQ_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO EVAL_AST_RETURN - - EVAL_AST_RETURN: - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q -END SUB - -REM EVAL(A, E) -> R -SUB EVAL - LV=LV+1: REM track basic return stack level - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) - - EVAL_TCO_RECUR: - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM AZ=A:B=1:GOSUB PR_STR - REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" - - GOSUB LIST_Q - IF R THEN GOTO APPLY_LIST - EVAL_NOT_LIST: - REM ELSE - CALL EVAL_AST - GOTO EVAL_RETURN - - APPLY_LIST: - CALL MACROEXPAND - - GOSUB LIST_Q - IF R<>1 THEN GOTO EVAL_NOT_LIST - - GOSUB EMPTY_Q - IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN - - A0=Z%(A+2) - - REM get symbol in A$ - IF (Z%(A0)AND 31)<>5 THEN A$="" - IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) - - IF A$="def!" THEN GOTO EVAL_DEF - IF A$="let*" THEN GOTO EVAL_LET - IF A$="quote" THEN GOTO EVAL_QUOTE - IF A$="quasiquoteexpand" THEN GOTO EVAL_QUASIQUOTEEXPAND - IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE - IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO - IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND - IF A$="try*" THEN GOTO EVAL_TRY - IF A$="do" THEN GOTO EVAL_DO - IF A$="if" THEN GOTO EVAL_IF - IF A$="fn*" THEN GOTO EVAL_FN - GOTO EVAL_INVOKE - - EVAL_GET_A3: - A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) - EVAL_GET_A2: - A2=Z%(Z%(Z%(A+1)+1)+2) - EVAL_GET_A1: - A1=Z%(Z%(A+1)+2) - RETURN - - EVAL_DEF: - REM PRINT "def!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q - A=A2:CALL EVAL: REM eval a2 - GOSUB POP_Q:A1=Q - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM set a1 in env to a2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_LET: - REM PRINT "let*" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A2:GOSUB PUSH_Q: REM push/save A2 - Q=E:GOSUB PUSH_Q: REM push env for for later release - - REM create new environment with outer as current environment - C=E:GOSUB ENV_NEW - E=R - EVAL_LET_LOOP: - IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE - - Q=A1:GOSUB PUSH_Q: REM push A1 - REM eval current A1 odd element - A=Z%(Z%(A1+1)+2):CALL EVAL - GOSUB POP_Q:A1=Q: REM pop A1 - - IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE - - REM set key/value in the environment - K=Z%(A1+2):C=R:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership - - REM skip to the next pair of A1 elements - A1=Z%(Z%(A1+1)+1) - GOTO EVAL_LET_LOOP - - EVAL_LET_LOOP_DONE: - GOSUB POP_Q:AY=Q: REM pop previous env - - REM release previous environment if not the current EVAL env - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - GOSUB POP_Q:A2=Q: REM pop A2 - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_DO: - A=Z%(A+1): REM rest - GOSUB PUSH_A: REM push/save A - - REM this must be EVAL_AST call #2 for EVAL_AST to return early - REM and for TCO to work - CALL EVAL_AST - - REM cleanup - AY=R: REM get eval'd list for release - - GOSUB POP_A: REM pop/restore original A for LAST - GOSUB LAST: REM get last element for return - A=R: REM new recur AST - - REM cleanup - GOSUB RELEASE: REM release eval'd list - AY=A:GOSUB RELEASE: REM release LAST value (not sure why) - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_QUOTE: - R=Z%(Z%(A+1)+2) - GOSUB INC_REF_R - GOTO EVAL_RETURN - - EVAL_QUASIQUOTEEXPAND: - R=Z%(Z%(A+1)+2) - A=R:CALL QUASIQUOTE - GOTO EVAL_RETURN - - EVAL_QUASIQUOTE: - R=Z%(Z%(A+1)+2) - A=R:CALL QUASIQUOTE - A=R - REM add quasiquote result to pending release queue to free when - REM next lower EVAL level returns (LV) - GOSUB PEND_A_LV - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_DEFMACRO: - REM PRINT "defmacro!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q: REM push A1 - A=A2:CALL EVAL: REM eval A2 - GOSUB POP_Q:A1=Q: REM pop A1 - - REM change function to macro - Z%(R)=Z%(R)+1 - - REM set A1 in env to A2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_MACROEXPAND: - REM PRINT "macroexpand" - R=Z%(Z%(A+1)+2) - A=R:CALL MACROEXPAND - R=A - - REM since we are returning it unevaluated, inc the ref cnt - GOSUB INC_REF_R - GOTO EVAL_RETURN - - EVAL_TRY: - REM PRINT "try*" - GOSUB EVAL_GET_A1: REM set A1 - - GOSUB PUSH_A: REM push/save A - A=A1:CALL EVAL: REM eval A1 - GOSUB POP_A: REM pop/restore A - - GOSUB EVAL_GET_A2: REM set A1 and A2 - - REM if there is no error or catch block then return - IF ER=-2 OR A2=0 THEN GOTO EVAL_RETURN - - REM create environment for the catch block eval - C=E:GOSUB ENV_NEW:E=R - - A=A2:GOSUB EVAL_GET_A2: REM set A1 and A2 from catch block - - REM create object for ER=-1 type raw string errors - IF ER=-1 THEN B$=E$:T=4:GOSUB STRING:ER=R:GOSUB INC_REF_R - - REM bind the catch symbol to the error object - K=A1:C=ER:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, env took ownership - - REM unset error for catch eval - ER=-2:E$="" - - A=A2:CALL EVAL - - GOTO EVAL_RETURN - - EVAL_IF: - GOSUB EVAL_GET_A1: REM set A1 - GOSUB PUSH_A: REM push/save A - A=A1:CALL EVAL - GOSUB POP_A: REM pop/restore A - IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE - - EVAL_IF_TRUE: - AY=R:GOSUB RELEASE - GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - EVAL_IF_FALSE: - AY=R:GOSUB RELEASE - REM if no false case (A3), return nil - GOSUB COUNT - IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN - GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL - A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_FN: - GOSUB EVAL_GET_A2: REM set A1 and A2 - T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function - GOTO EVAL_RETURN - - EVAL_INVOKE: - CALL EVAL_AST - - REM if error, return f/args for release by caller - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM push f/args for release after call - GOSUB PUSH_R - - AR=Z%(R+1): REM rest - F=Z%(R+2) - - REM if metadata, get the actual object - GOSUB TYPE_F - IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F - - ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION - - REM if error, pop and return f/args for release by caller - GOSUB POP_R - ER=-1:E$="apply of non-function":GOTO EVAL_RETURN - - EVAL_DO_FUNCTION: - REM regular function - IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP - REM for recur functions (apply, map, swap!), use GOTO - IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION - EVAL_DO_FUNCTION_SKIP: - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - GOTO EVAL_RETURN - - EVAL_DO_MAL_FUNCTION: - Q=E:GOSUB PUSH_Q: REM save the current environment for release - - REM create new environ using env and params stored in function - C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS - - REM release previous env if it is not the top one on the - REM stack (X%(X-2)) because our new env refers to it and - REM we no longer need to track it (since we are TCO recurring) - GOSUB POP_Q:AY=Q - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - REM claim the AST before releasing the list containing it - A=Z%(F+1):Z%(A)=Z%(A)+32 - REM add AST to pending release queue to free as soon as EVAL - REM actually returns (LV+1) - LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - - REM A set above - E=R:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_RETURN: - REM AZ=R: B=1: GOSUB PR_STR - REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) - - REM release environment if not the top one on the stack - GOSUB PEEK_Q_1 - IF E<>Q THEN AY=E:GOSUB RELEASE - - LV=LV-1: REM track basic return stack level - - REM release everything we couldn't release earlier - GOSUB RELEASE_PEND - - REM trigger GC - #cbm T=FRE(0) - #qbasic T=0 - - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - -END SUB - -REM PRINT(A) -> R$ -MAL_PRINT: - AZ=A:B=1:GOSUB PR_STR - RETURN - -REM RE(A$) -> R -REM Assume D has repl_env -REM caller must release result -RE: - R1=-1 - GOSUB MAL_READ - R1=R - IF ER<>-2 THEN GOTO RE_DONE - - A=R:E=D:CALL EVAL - - RE_DONE: - REM Release memory from MAL_READ - AY=R1:GOSUB RELEASE - RETURN: REM caller must release result of EVAL - -REM REP(A$) -> R$ -REM Assume D has repl_env -SUB REP - R2=-1 - - GOSUB RE - R2=R - IF ER<>-2 THEN GOTO REP_DONE - - A=R:GOSUB MAL_PRINT - - REP_DONE: - REM Release memory from MAL_READ and EVAL - AY=R2:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - LV=0 - - REM create repl_env - C=0:GOSUB ENV_NEW:D=R - - REM core.EXT: defined in Basic - E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env - - ZT=ZI: REM top of memory after base repl_env - - REM core.mal: defined using the language itself - A$="(def! not (fn* (a) (if a false true)))" - GOSUB RE:AY=R:GOSUB RELEASE - - A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" - GOSUB RE:AY=R:GOSUB RELEASE - - A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)" - A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of" - A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM load the args file - A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" - GOSUB RE:AY=R:GOSUB RELEASE - - IF ER>-2 THEN GOSUB PRINT_ERROR:END - - REM set the argument list - A$="(def! *ARGV* (rest -*ARGS*-))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM get the first argument - A$="(first -*ARGS*-)" - GOSUB RE - - REM no arguments, start REPL loop - IF R<16 THEN GOTO REPL_LOOP - - REM if there is an argument, then run it as a program - - RUN_PROG: - REM free up first arg because we get it again - AY=R:GOSUB RELEASE - REM run a single mal program and exit - A$="(load-file (first -*ARGS*-))" - GOSUB RE - IF ER<>-2 THEN GOSUB PRINT_ERROR - GOTO QUIT - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - REM if the error is an object, then print and free it - IF ER>=0 THEN AZ=ER:B=0:GOSUB PR_STR:E$=R$:AY=ER:GOSUB RELEASE - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' +REM $INCLUDE: 'env.in.bas' +REM $INCLUDE: 'core.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ(A$) -> R +MAL_READ: + GOSUB READ_STR + RETURN + +REM QUASIQUOTE(A) -> R +SUB QUASIQUOTE + GOSUB TYPE_A + IF T<5 OR T>8 THEN GOTO QQ_UNCHANGED + IF T=5 OR T=8 THEN GOTO QQ_QUOTE + IF T=7 THEN GOTO QQ_VECTOR + IF (Z%(A+1)=0) THEN GOTO QQ_LIST + R=Z%(A+2) + IF (Z%(R)AND 31)<>5 THEN GOTO QQ_LIST + IF S$(Z%(R+1))<>"unquote" THEN GOTO QQ_LIST + GOTO QQ_UNQUOTE + + QQ_UNCHANGED: + R=A + GOSUB INC_REF_R + + GOTO QQ_DONE + + QQ_QUOTE: + REM ['quote, ast] + B$="quote":T=5:GOSUB STRING + B=R:GOSUB LIST2 + AY=B:GOSUB RELEASE + + GOTO QQ_DONE + + QQ_VECTOR: + REM ['vec, (qq_foldr ast)] + CALL QQ_FOLDR + A=R + B$="vec":T=5:GOSUB STRING:B=R + GOSUB LIST2 + AY=A:GOSUB RELEASE + AY=B:GOSUB RELEASE + + GOTO QQ_DONE + + QQ_UNQUOTE: + REM [ast[1]] + R=Z%(Z%(A+1)+2) + GOSUB INC_REF_R + + GOTO QQ_DONE + + QQ_LIST: + CALL QQ_FOLDR + +QQ_DONE: +END SUB + +REM Quasiquote right fold (A) -> R. +REM Used for unquoted lists (GOTO), vectors (GOSUB), +REM and recursively (GOSUB). +SUB QQ_FOLDR + IF A=0 THEN GOTO QQ_EMPTY + IF Z%(A+1)=0 THEN GOTO QQ_EMPTY + GOTO QQ_NOTEMPTY + + QQ_EMPTY: + REM empty list/vector -> empty list + R=6 + GOSUB INC_REF_R + + GOTO QQ_FOLDR_DONE + + QQ_NOTEMPTY: + REM Execute QQ_FOLDR recursively with (rest A) + GOSUB PUSH_A + A=Z%(A+1):CALL QQ_FOLDR + GOSUB POP_A + + REM Set A to elt = (first A) + A=Z%(A+2) + + REM Quasiquote transition function: + REM A: current element, R: accumulator -> R: new accumulator + + REM check if A is a list starting with splice-unquote + GOSUB TYPE_A + IF T<>6 THEN GOTO QQ_DEFAULT + IF (Z%(A+1)=0) THEN GOTO QQ_DEFAULT + B=Z%(A+2) + IF (Z%(B)AND 31)<>5 THEN GOTO QQ_DEFAULT + IF S$(Z%(B+1))<>"splice-unquote" THEN GOTO QQ_DEFAULT + + REM ('concat, A[1], R) + B=Z%(Z%(A+1)+2) + A=R + B$="concat":T=5:GOSUB STRING:C=R + GOSUB LIST3 + REM release inner quasiquoted since outer list takes ownership + AY=A:GOSUB RELEASE + AY=C:GOSUB RELEASE + + GOTO QQ_FOLDR_DONE + + QQ_DEFAULT: + REM ('cons, quasiquote(A), R) + GOSUB PUSH_R + CALL QUASIQUOTE + B=R + B$="cons":T=5:GOSUB STRING:C=R + GOSUB POP_A + GOSUB LIST3 + REM release inner quasiquoted since outer list takes ownership + AY=A:GOSUB RELEASE + AY=B:GOSUB RELEASE + AY=C:GOSUB RELEASE + +QQ_FOLDR_DONE: +END SUB + +REM MACROEXPAND(A, E) -> A: +SUB MACROEXPAND + GOSUB PUSH_A + + MACROEXPAND_LOOP: + REM list? + GOSUB TYPE_A + IF T<>6 THEN GOTO MACROEXPAND_DONE + REM non-empty? + IF Z%(A+1)=0 THEN GOTO MACROEXPAND_DONE + B=Z%(A+2) + REM symbol? in first position + IF (Z%(B)AND 31)<>5 THEN GOTO MACROEXPAND_DONE + REM defined in environment? + K=B:CALL ENV_FIND + IF R=-1 THEN GOTO MACROEXPAND_DONE + B=R4 + REM macro? + IF (Z%(B)AND 31)<>11 THEN GOTO MACROEXPAND_DONE + + F=B:AR=Z%(A+1):CALL APPLY + A=R + + GOSUB PEEK_Q:AY=Q + REM if previous A was not the first A into macroexpand (i.e. an + REM intermediate form) then free it + IF A<>AY THEN GOSUB PEND_A_LV + + IF ER<>-2 THEN GOTO MACROEXPAND_DONE + GOTO MACROEXPAND_LOOP + + MACROEXPAND_DONE: + GOSUB POP_Q: REM pop original A +END SUB + +REM EVAL_AST(A, E) -> R +SUB EVAL_AST + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_AST_RETURN + + GOSUB TYPE_A + IF T=5 THEN GOTO EVAL_AST_SYMBOL + IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ + + REM scalar: deref to actual value and inc ref cnt + R=A + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SYMBOL: + K=A:GOTO ENV_GET + ENV_GET_RETURN: + GOTO EVAL_AST_RETURN + + EVAL_AST_SEQ: + REM setup the stack for the loop + GOSUB MAP_LOOP_START + + EVAL_AST_SEQ_LOOP: + REM check if we are done evaluating the source sequence + IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM if we are returning to DO, then skip last element + REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to + REM return early and for TCO to work + Q=5:GOSUB PEEK_Q_Q + IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM call EVAL for each entry + GOSUB PUSH_A + IF T<>8 THEN A=Z%(A+2) + IF T=8 THEN A=Z%(A+3) + Q=T:GOSUB PUSH_Q: REM push/save type + CALL EVAL + GOSUB POP_Q:T=Q: REM pop/restore type + GOSUB POP_A + M=R + + REM if error, release the unattached element + REM TODO: is R=0 correct? + IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE + + REM for hash-maps, copy the key (inc ref since we are going to + REM release it below) + IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 + + + REM update the return sequence structure + REM release N (and M if T=8) since seq takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + REM process the next sequence entry from source list + A=Z%(A+1) + + GOTO EVAL_AST_SEQ_LOOP + EVAL_AST_SEQ_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO EVAL_AST_RETURN + + EVAL_AST_RETURN: + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q +END SUB + +REM EVAL(A, E) -> R +SUB EVAL + LV=LV+1: REM track basic return stack level + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) + + EVAL_TCO_RECUR: + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM AZ=A:B=1:GOSUB PR_STR + REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" + + GOSUB LIST_Q + IF R THEN GOTO APPLY_LIST + EVAL_NOT_LIST: + REM ELSE + CALL EVAL_AST + GOTO EVAL_RETURN + + APPLY_LIST: + CALL MACROEXPAND + + GOSUB LIST_Q + IF R<>1 THEN GOTO EVAL_NOT_LIST + + GOSUB EMPTY_Q + IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN + + A0=Z%(A+2) + + REM get symbol in A$ + IF (Z%(A0)AND 31)<>5 THEN A$="" + IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) + + IF A$="def!" THEN GOTO EVAL_DEF + IF A$="let*" THEN GOTO EVAL_LET + IF A$="quote" THEN GOTO EVAL_QUOTE + IF A$="quasiquoteexpand" THEN GOTO EVAL_QUASIQUOTEEXPAND + IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE + IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO + IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND + IF A$="try*" THEN GOTO EVAL_TRY + IF A$="do" THEN GOTO EVAL_DO + IF A$="if" THEN GOTO EVAL_IF + IF A$="fn*" THEN GOTO EVAL_FN + GOTO EVAL_INVOKE + + EVAL_GET_A3: + A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) + EVAL_GET_A2: + A2=Z%(Z%(Z%(A+1)+1)+2) + EVAL_GET_A1: + A1=Z%(Z%(A+1)+2) + RETURN + + EVAL_DEF: + REM PRINT "def!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q + A=A2:CALL EVAL: REM eval a2 + GOSUB POP_Q:A1=Q + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM set a1 in env to a2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_LET: + REM PRINT "let*" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A2:GOSUB PUSH_Q: REM push/save A2 + Q=E:GOSUB PUSH_Q: REM push env for for later release + + REM create new environment with outer as current environment + C=E:GOSUB ENV_NEW + E=R + EVAL_LET_LOOP: + IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE + + Q=A1:GOSUB PUSH_Q: REM push A1 + REM eval current A1 odd element + A=Z%(Z%(A1+1)+2):CALL EVAL + GOSUB POP_Q:A1=Q: REM pop A1 + + IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE + + REM set key/value in the environment + K=Z%(A1+2):C=R:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership + + REM skip to the next pair of A1 elements + A1=Z%(Z%(A1+1)+1) + GOTO EVAL_LET_LOOP + + EVAL_LET_LOOP_DONE: + GOSUB POP_Q:AY=Q: REM pop previous env + + REM release previous environment if not the current EVAL env + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + GOSUB POP_Q:A2=Q: REM pop A2 + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_DO: + A=Z%(A+1): REM rest + GOSUB PUSH_A: REM push/save A + + REM this must be EVAL_AST call #2 for EVAL_AST to return early + REM and for TCO to work + CALL EVAL_AST + + REM cleanup + AY=R: REM get eval'd list for release + + GOSUB POP_A: REM pop/restore original A for LAST + GOSUB LAST: REM get last element for return + A=R: REM new recur AST + + REM cleanup + GOSUB RELEASE: REM release eval'd list + AY=A:GOSUB RELEASE: REM release LAST value (not sure why) + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_QUOTE: + R=Z%(Z%(A+1)+2) + GOSUB INC_REF_R + GOTO EVAL_RETURN + + EVAL_QUASIQUOTEEXPAND: + R=Z%(Z%(A+1)+2) + A=R:CALL QUASIQUOTE + GOTO EVAL_RETURN + + EVAL_QUASIQUOTE: + R=Z%(Z%(A+1)+2) + A=R:CALL QUASIQUOTE + A=R + REM add quasiquote result to pending release queue to free when + REM next lower EVAL level returns (LV) + GOSUB PEND_A_LV + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_DEFMACRO: + REM PRINT "defmacro!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q: REM push A1 + A=A2:CALL EVAL: REM eval A2 + GOSUB POP_Q:A1=Q: REM pop A1 + + REM change function to macro + Z%(R)=Z%(R)+1 + + REM set A1 in env to A2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_MACROEXPAND: + REM PRINT "macroexpand" + R=Z%(Z%(A+1)+2) + A=R:CALL MACROEXPAND + R=A + + REM since we are returning it unevaluated, inc the ref cnt + GOSUB INC_REF_R + GOTO EVAL_RETURN + + EVAL_TRY: + REM PRINT "try*" + GOSUB EVAL_GET_A1: REM set A1 + + GOSUB PUSH_A: REM push/save A + A=A1:CALL EVAL: REM eval A1 + GOSUB POP_A: REM pop/restore A + + GOSUB EVAL_GET_A2: REM set A1 and A2 + + REM if there is no error or catch block then return + IF ER=-2 OR A2=0 THEN GOTO EVAL_RETURN + + REM create environment for the catch block eval + C=E:GOSUB ENV_NEW:E=R + + A=A2:GOSUB EVAL_GET_A2: REM set A1 and A2 from catch block + + REM create object for ER=-1 type raw string errors + IF ER=-1 THEN B$=E$:T=4:GOSUB STRING:ER=R:GOSUB INC_REF_R + + REM bind the catch symbol to the error object + K=A1:C=ER:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, env took ownership + + REM unset error for catch eval + ER=-2:E$="" + + A=A2:CALL EVAL + + GOTO EVAL_RETURN + + EVAL_IF: + GOSUB EVAL_GET_A1: REM set A1 + GOSUB PUSH_A: REM push/save A + A=A1:CALL EVAL + GOSUB POP_A: REM pop/restore A + IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE + + EVAL_IF_TRUE: + AY=R:GOSUB RELEASE + GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + EVAL_IF_FALSE: + AY=R:GOSUB RELEASE + REM if no false case (A3), return nil + GOSUB COUNT + IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN + GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL + A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_FN: + GOSUB EVAL_GET_A2: REM set A1 and A2 + T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function + GOTO EVAL_RETURN + + EVAL_INVOKE: + CALL EVAL_AST + + REM if error, return f/args for release by caller + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM push f/args for release after call + GOSUB PUSH_R + + AR=Z%(R+1): REM rest + F=Z%(R+2) + + REM if metadata, get the actual object + GOSUB TYPE_F + IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F + + ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION + + REM if error, pop and return f/args for release by caller + GOSUB POP_R + ER=-1:E$="apply of non-function":GOTO EVAL_RETURN + + EVAL_DO_FUNCTION: + REM regular function + IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP + REM for recur functions (apply, map, swap!), use GOTO + IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION + EVAL_DO_FUNCTION_SKIP: + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + GOTO EVAL_RETURN + + EVAL_DO_MAL_FUNCTION: + Q=E:GOSUB PUSH_Q: REM save the current environment for release + + REM create new environ using env and params stored in function + C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS + + REM release previous env if it is not the top one on the + REM stack (X%(X-2)) because our new env refers to it and + REM we no longer need to track it (since we are TCO recurring) + GOSUB POP_Q:AY=Q + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + REM claim the AST before releasing the list containing it + A=Z%(F+1):Z%(A)=Z%(A)+32 + REM add AST to pending release queue to free as soon as EVAL + REM actually returns (LV+1) + LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + + REM A set above + E=R:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_RETURN: + REM AZ=R: B=1: GOSUB PR_STR + REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) + + REM release environment if not the top one on the stack + GOSUB PEEK_Q_1 + IF E<>Q THEN AY=E:GOSUB RELEASE + + LV=LV-1: REM track basic return stack level + + REM release everything we couldn't release earlier + GOSUB RELEASE_PEND + + REM trigger GC + #cbm T=FRE(0) + #qbasic T=0 + + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + +END SUB + +REM PRINT(A) -> R$ +MAL_PRINT: + AZ=A:B=1:GOSUB PR_STR + RETURN + +REM RE(A$) -> R +REM Assume D has repl_env +REM caller must release result +RE: + R1=-1 + GOSUB MAL_READ + R1=R + IF ER<>-2 THEN GOTO RE_DONE + + A=R:E=D:CALL EVAL + + RE_DONE: + REM Release memory from MAL_READ + AY=R1:GOSUB RELEASE + RETURN: REM caller must release result of EVAL + +REM REP(A$) -> R$ +REM Assume D has repl_env +SUB REP + R2=-1 + + GOSUB RE + R2=R + IF ER<>-2 THEN GOTO REP_DONE + + A=R:GOSUB MAL_PRINT + + REP_DONE: + REM Release memory from MAL_READ and EVAL + AY=R2:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + LV=0 + + REM create repl_env + C=0:GOSUB ENV_NEW:D=R + + REM core.EXT: defined in Basic + E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env + + ZT=ZI: REM top of memory after base repl_env + + REM core.mal: defined using the language itself + A$="(def! not (fn* (a) (if a false true)))" + GOSUB RE:AY=R:GOSUB RELEASE + + A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" + GOSUB RE:AY=R:GOSUB RELEASE + + A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)" + A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of" + A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM load the args file + A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" + GOSUB RE:AY=R:GOSUB RELEASE + + IF ER>-2 THEN GOSUB PRINT_ERROR:END + + REM set the argument list + A$="(def! *ARGV* (rest -*ARGS*-))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM get the first argument + A$="(first -*ARGS*-)" + GOSUB RE + + REM no arguments, start REPL loop + IF R<16 THEN GOTO REPL_LOOP + + REM if there is an argument, then run it as a program + + RUN_PROG: + REM free up first arg because we get it again + AY=R:GOSUB RELEASE + REM run a single mal program and exit + A$="(load-file (first -*ARGS*-))" + GOSUB RE + IF ER<>-2 THEN GOSUB PRINT_ERROR + GOTO QUIT + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + REM if the error is an object, then print and free it + IF ER>=0 THEN AZ=ER:B=0:GOSUB PR_STR:E$=R$:AY=ER:GOSUB RELEASE + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/stepA_mal.in.bas b/impls/basic/stepA_mal.in.bas index 9a3790ff1c..6e5db691e7 100755 --- a/impls/basic/stepA_mal.in.bas +++ b/impls/basic/stepA_mal.in.bas @@ -1,678 +1,678 @@ -GOTO MAIN - -REM $INCLUDE: 'mem.in.bas' -REM $INCLUDE: 'types.in.bas' -REM $INCLUDE: 'readline.in.bas' -REM $INCLUDE: 'reader.in.bas' -REM $INCLUDE: 'printer.in.bas' -REM $INCLUDE: 'env.in.bas' -REM $INCLUDE: 'core.in.bas' - -REM $INCLUDE: 'debug.in.bas' - -REM READ is inlined in RE - -REM QUASIQUOTE(A) -> R -SUB QUASIQUOTE - GOSUB TYPE_A - IF T<5 OR T>8 THEN GOTO QQ_UNCHANGED - IF T=5 OR T=8 THEN GOTO QQ_QUOTE - IF T=7 THEN GOTO QQ_VECTOR - IF (Z%(A+1)=0) THEN GOTO QQ_LIST - R=Z%(A+2) - IF (Z%(R)AND 31)<>5 THEN GOTO QQ_LIST - IF S$(Z%(R+1))<>"unquote" THEN GOTO QQ_LIST - GOTO QQ_UNQUOTE - - QQ_UNCHANGED: - R=A - GOSUB INC_REF_R - - GOTO QQ_DONE - - QQ_QUOTE: - REM ['quote, ast] - B$="quote":T=5:GOSUB STRING - B=R:GOSUB LIST2 - AY=B:GOSUB RELEASE - - GOTO QQ_DONE - - QQ_VECTOR: - REM ['vec, (qq_foldr ast)] - CALL QQ_FOLDR - A=R - B$="vec":T=5:GOSUB STRING:B=R - GOSUB LIST2 - AY=A:GOSUB RELEASE - AY=B:GOSUB RELEASE - - GOTO QQ_DONE - - QQ_UNQUOTE: - REM [ast[1]] - R=Z%(Z%(A+1)+2) - GOSUB INC_REF_R - - GOTO QQ_DONE - - QQ_LIST: - CALL QQ_FOLDR - -QQ_DONE: -END SUB - -REM Quasiquote right fold (A) -> R. -REM Used for unquoted lists (GOTO), vectors (GOSUB), -REM and recursively (GOSUB). -SUB QQ_FOLDR - IF A=0 THEN GOTO QQ_EMPTY - IF Z%(A+1)=0 THEN GOTO QQ_EMPTY - GOTO QQ_NOTEMPTY - - QQ_EMPTY: - REM empty list/vector -> empty list - R=6 - GOSUB INC_REF_R - - GOTO QQ_FOLDR_DONE - - QQ_NOTEMPTY: - REM Execute QQ_FOLDR recursively with (rest A) - GOSUB PUSH_A - A=Z%(A+1):CALL QQ_FOLDR - GOSUB POP_A - - REM Set A to elt = (first A) - A=Z%(A+2) - - REM Quasiquote transition function: - REM A: current element, R: accumulator -> R: new accumulator - - REM check if A is a list starting with splice-unquote - GOSUB TYPE_A - IF T<>6 THEN GOTO QQ_DEFAULT - IF (Z%(A+1)=0) THEN GOTO QQ_DEFAULT - B=Z%(A+2) - IF (Z%(B)AND 31)<>5 THEN GOTO QQ_DEFAULT - IF S$(Z%(B+1))<>"splice-unquote" THEN GOTO QQ_DEFAULT - - REM ('concat, A[1], R) - B=Z%(Z%(A+1)+2) - A=R - B$="concat":T=5:GOSUB STRING:C=R - GOSUB LIST3 - REM release inner quasiquoted since outer list takes ownership - AY=A:GOSUB RELEASE - AY=C:GOSUB RELEASE - - GOTO QQ_FOLDR_DONE - - QQ_DEFAULT: - REM ('cons, quasiquote(A), R) - GOSUB PUSH_R - CALL QUASIQUOTE - B=R - B$="cons":T=5:GOSUB STRING:C=R - GOSUB POP_A - GOSUB LIST3 - REM release inner quasiquoted since outer list takes ownership - AY=A:GOSUB RELEASE - AY=B:GOSUB RELEASE - AY=C:GOSUB RELEASE - -QQ_FOLDR_DONE: -END SUB - -REM MACROEXPAND(A, E) -> A: -SUB MACROEXPAND - GOSUB PUSH_A - - MACROEXPAND_LOOP: - REM list? - GOSUB TYPE_A - IF T<>6 THEN GOTO MACROEXPAND_DONE - REM non-empty? - IF Z%(A+1)=0 THEN GOTO MACROEXPAND_DONE - B=Z%(A+2) - REM symbol? in first position - IF (Z%(B)AND 31)<>5 THEN GOTO MACROEXPAND_DONE - REM defined in environment? - K=B:CALL ENV_FIND - IF R=-1 THEN GOTO MACROEXPAND_DONE - B=R4 - REM macro? - IF (Z%(B)AND 31)<>11 THEN GOTO MACROEXPAND_DONE - - F=B:AR=Z%(A+1):CALL APPLY - A=R - - GOSUB PEEK_Q:AY=Q - REM if previous A was not the first A into macroexpand (i.e. an - REM intermediate form) then free it - IF A<>AY THEN GOSUB PEND_A_LV - - IF ER<>-2 THEN GOTO MACROEXPAND_DONE - GOTO MACROEXPAND_LOOP - - MACROEXPAND_DONE: - GOSUB POP_Q: REM pop original A -END SUB - -REM EVAL_AST(A, E) -> R -SUB EVAL_AST - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - IF ER<>-2 THEN GOTO EVAL_AST_RETURN - - GOSUB TYPE_A - IF T=5 THEN GOTO EVAL_AST_SYMBOL - IF T>5 AND T<9 THEN GOTO EVAL_AST_SEQ - - REM scalar: deref to actual value and inc ref cnt - R=A - GOSUB INC_REF_R - GOTO EVAL_AST_RETURN - - EVAL_AST_SYMBOL: - K=A:GOTO ENV_GET - ENV_GET_RETURN: - GOTO EVAL_AST_RETURN - - EVAL_AST_SEQ: - REM setup the stack for the loop - GOSUB MAP_LOOP_START - - EVAL_AST_SEQ_LOOP: - REM check if we are done evaluating the source sequence - IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM if we are returning to DO, then skip last element - REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to - REM return early and for TCO to work - Q=5:GOSUB PEEK_Q_Q - IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE - - REM call EVAL for each entry - GOSUB PUSH_A - IF T<>8 THEN A=Z%(A+2) - IF T=8 THEN A=Z%(A+3) - Q=T:GOSUB PUSH_Q: REM push/save type - CALL EVAL - GOSUB POP_Q:T=Q: REM pop/restore type - GOSUB POP_A - M=R - - REM if error, release the unattached element - REM TODO: is R=0 correct? - IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE - - REM for hash-maps, copy the key (inc ref since we are going to - REM release it below) - IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 - - - REM update the return sequence structure - REM release N (and M if T=8) since seq takes full ownership - C=1:GOSUB MAP_LOOP_UPDATE - - REM process the next sequence entry from source list - A=Z%(A+1) - - GOTO EVAL_AST_SEQ_LOOP - EVAL_AST_SEQ_LOOP_DONE: - REM cleanup stack and get return value - GOSUB MAP_LOOP_DONE - GOTO EVAL_AST_RETURN - - EVAL_AST_RETURN: - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q -END SUB - -REM EVAL(A, E) -> R -SUB EVAL - LV=LV+1: REM track basic return stack level - - REM push A and E on the stack - Q=E:GOSUB PUSH_Q - GOSUB PUSH_A - - REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) - - EVAL_TCO_RECUR: - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM AZ=A:B=1:GOSUB PR_STR - REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" - - GOSUB LIST_Q - IF R THEN GOTO APPLY_LIST - EVAL_NOT_LIST: - REM ELSE - CALL EVAL_AST - GOTO EVAL_RETURN - - APPLY_LIST: - CALL MACROEXPAND - - GOSUB LIST_Q - IF R<>1 THEN GOTO EVAL_NOT_LIST - - GOSUB EMPTY_Q - IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN - - A0=Z%(A+2) - - REM get symbol in A$ - IF (Z%(A0)AND 31)<>5 THEN A$="" - IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) - - IF A$="def!" THEN GOTO EVAL_DEF - IF A$="let*" THEN GOTO EVAL_LET - IF A$="quote" THEN GOTO EVAL_QUOTE - IF A$="quasiquoteexpand" THEN GOTO EVAL_QUASIQUOTEEXPAND - IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE - IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO - IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND - IF A$="try*" THEN GOTO EVAL_TRY - IF A$="do" THEN GOTO EVAL_DO - IF A$="if" THEN GOTO EVAL_IF - IF A$="fn*" THEN GOTO EVAL_FN - GOTO EVAL_INVOKE - - EVAL_GET_A3: - A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) - EVAL_GET_A2: - A2=Z%(Z%(Z%(A+1)+1)+2) - EVAL_GET_A1: - A1=Z%(Z%(A+1)+2) - RETURN - - EVAL_DEF: - REM PRINT "def!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q - A=A2:CALL EVAL: REM eval a2 - GOSUB POP_Q:A1=Q - - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM set a1 in env to a2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_LET: - REM PRINT "let*" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A2:GOSUB PUSH_Q: REM push/save A2 - Q=E:GOSUB PUSH_Q: REM push env for for later release - - REM create new environment with outer as current environment - C=E:GOSUB ENV_NEW - E=R - EVAL_LET_LOOP: - IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE - - Q=A1:GOSUB PUSH_Q: REM push A1 - REM eval current A1 odd element - A=Z%(Z%(A1+1)+2):CALL EVAL - GOSUB POP_Q:A1=Q: REM pop A1 - - IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE - - REM set key/value in the environment - K=Z%(A1+2):C=R:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership - - REM skip to the next pair of A1 elements - A1=Z%(Z%(A1+1)+1) - GOTO EVAL_LET_LOOP - - EVAL_LET_LOOP_DONE: - GOSUB POP_Q:AY=Q: REM pop previous env - - REM release previous environment if not the current EVAL env - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - GOSUB POP_Q:A2=Q: REM pop A2 - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_DO: - A=Z%(A+1): REM rest - GOSUB PUSH_A: REM push/save A - - REM this must be EVAL_AST call #2 for EVAL_AST to return early - REM and for TCO to work - CALL EVAL_AST - - REM cleanup - AY=R: REM get eval'd list for release - - GOSUB POP_A: REM pop/restore original A for LAST - GOSUB LAST: REM get last element for return - A=R: REM new recur AST - - REM cleanup - GOSUB RELEASE: REM release eval'd list - AY=A:GOSUB RELEASE: REM release LAST value (not sure why) - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_QUOTE: - R=Z%(Z%(A+1)+2) - GOSUB INC_REF_R - GOTO EVAL_RETURN - - EVAL_QUASIQUOTEEXPAND: - R=Z%(Z%(A+1)+2) - A=R:CALL QUASIQUOTE - GOTO EVAL_RETURN - - EVAL_QUASIQUOTE: - R=Z%(Z%(A+1)+2) - A=R:CALL QUASIQUOTE - A=R - REM add quasiquote result to pending release queue to free when - REM next lower EVAL level returns (LV) - GOSUB PEND_A_LV - - GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_DEFMACRO: - REM PRINT "defmacro!" - GOSUB EVAL_GET_A2: REM set A1 and A2 - - Q=A1:GOSUB PUSH_Q: REM push A1 - A=A2:CALL EVAL: REM eval A2 - GOSUB POP_Q:A1=Q: REM pop A1 - - REM change function to macro - Z%(R)=Z%(R)+1 - - REM set A1 in env to A2 - K=A1:C=R:GOSUB ENV_SET - GOTO EVAL_RETURN - - EVAL_MACROEXPAND: - REM PRINT "macroexpand" - R=Z%(Z%(A+1)+2) - A=R:CALL MACROEXPAND - R=A - - REM since we are returning it unevaluated, inc the ref cnt - GOSUB INC_REF_R - GOTO EVAL_RETURN - - EVAL_TRY: - REM PRINT "try*" - GOSUB EVAL_GET_A1: REM set A1 - - GOSUB PUSH_A: REM push/save A - A=A1:CALL EVAL: REM eval A1 - GOSUB POP_A: REM pop/restore A - - GOSUB EVAL_GET_A2: REM set A1 and A2 - - REM if there is no error or catch block then return - IF ER=-2 OR A2=0 THEN GOTO EVAL_RETURN - - REM create environment for the catch block eval - C=E:GOSUB ENV_NEW:E=R - - A=A2:GOSUB EVAL_GET_A2: REM set A1 and A2 from catch block - - REM create object for ER=-1 type raw string errors - IF ER=-1 THEN B$=E$:T=4:GOSUB STRING:ER=R:GOSUB INC_REF_R - - REM bind the catch symbol to the error object - K=A1:C=ER:GOSUB ENV_SET - AY=R:GOSUB RELEASE: REM release our use, env took ownership - - REM unset error for catch eval - ER=-2:E$="" - - A=A2:CALL EVAL - - GOTO EVAL_RETURN - - EVAL_IF: - GOSUB EVAL_GET_A1: REM set A1 - GOSUB PUSH_A: REM push/save A - A=A1:CALL EVAL - GOSUB POP_A: REM pop/restore A - IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE - - EVAL_IF_TRUE: - AY=R:GOSUB RELEASE - GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL - A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop - EVAL_IF_FALSE: - AY=R:GOSUB RELEASE - REM if no false case (A3), return nil - GOSUB COUNT - IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN - GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL - A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_FN: - GOSUB EVAL_GET_A2: REM set A1 and A2 - T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function - GOTO EVAL_RETURN - - EVAL_INVOKE: - CALL EVAL_AST - - REM if error, return f/args for release by caller - IF ER<>-2 THEN GOTO EVAL_RETURN - - REM push f/args for release after call - GOSUB PUSH_R - - AR=Z%(R+1): REM rest - F=Z%(R+2) - - REM if metadata, get the actual object - GOSUB TYPE_F - IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F - - ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION - - REM if error, pop and return f/args for release by caller - GOSUB POP_R - ER=-1:E$="apply of non-function":GOTO EVAL_RETURN - - EVAL_DO_FUNCTION: - REM regular function - IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP - REM for recur functions (apply, map, swap!), use GOTO - IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION - EVAL_DO_FUNCTION_SKIP: - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - GOTO EVAL_RETURN - - EVAL_DO_MAL_FUNCTION: - Q=E:GOSUB PUSH_Q: REM save the current environment for release - - REM create new environ using env and params stored in function - C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS - - REM release previous env if it is not the top one on the - REM stack (X%(X-2)) because our new env refers to it and - REM we no longer need to track it (since we are TCO recurring) - GOSUB POP_Q:AY=Q - GOSUB PEEK_Q_2 - IF AY<>Q THEN GOSUB RELEASE - - REM claim the AST before releasing the list containing it - A=Z%(F+1):Z%(A)=Z%(A)+32 - REM add AST to pending release queue to free as soon as EVAL - REM actually returns (LV+1) - LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 - - REM pop and release f/args - GOSUB POP_Q:AY=Q - GOSUB RELEASE - - REM A set above - E=R:GOTO EVAL_TCO_RECUR: REM TCO loop - - EVAL_RETURN: - REM AZ=R: B=1: GOSUB PR_STR - REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) - - REM release environment if not the top one on the stack - GOSUB PEEK_Q_1 - IF E<>Q THEN AY=E:GOSUB RELEASE - - LV=LV-1: REM track basic return stack level - - REM release everything we couldn't release earlier - GOSUB RELEASE_PEND - - REM trigger GC - #cbm T=FRE(0) - #qbasic T=0 - - REM pop A and E off the stack - GOSUB POP_A - GOSUB POP_Q:E=Q - -END SUB - -REM PRINT is inlined in REP - - -REM RE(A$) -> R -REM Assume D has repl_env -REM caller must release result -RE: - R1=-1 - GOSUB READ_STR: REM inlined MAL_READ - R1=R - IF ER<>-2 THEN GOTO RE_DONE - - A=R:E=D:CALL EVAL - - RE_DONE: - REM Release memory from MAL_READ - AY=R1:GOSUB RELEASE - RETURN: REM caller must release result of EVAL - -REM REP(A$) -> R$ -REM Assume D has repl_env -SUB REP - R2=-1 - - GOSUB RE - R2=R - IF ER<>-2 THEN GOTO REP_DONE - - AZ=R:B=1:GOSUB PR_STR: REM MAL_PRINT - - REP_DONE: - REM Release memory from MAL_READ and EVAL - AY=R2:GOSUB RELEASE -END SUB - -REM MAIN program -MAIN: - GOSUB INIT_MEMORY - - LV=0 - - REM create repl_env - C=0:GOSUB ENV_NEW:D=R - - REM core.EXT: defined in Basic - E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env - - ZT=ZI: REM top of memory after base repl_env - - REM core.mal: defined using the language itself - #cbm A$="(def! *host-language* "+CHR$(34)+"C64 BASIC"+CHR$(34)+")" - #qbasic A$="(def! *host-language* "+CHR$(34)+"QBasic"+CHR$(34)+")" - GOSUB RE:AY=R:GOSUB RELEASE - - A$="(def! not (fn* (a) (if a false true)))" - GOSUB RE:AY=R:GOSUB RELEASE - - A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" - GOSUB RE:AY=R:GOSUB RELEASE - - A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)" - A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of" - A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM load the args file - A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" - GOSUB RE:AY=R:GOSUB RELEASE - - IF ER>-2 THEN GOSUB PRINT_ERROR:END - - REM set the argument list - A$="(def! *ARGV* (rest -*ARGS*-))" - GOSUB RE:AY=R:GOSUB RELEASE - - REM get the first argument - A$="(first -*ARGS*-)" - GOSUB RE - - REM no arguments, start REPL loop - IF R<16 THEN GOTO REPL - - REM if there is an argument, then run it as a program - - RUN_PROG: - REM free up first arg because we get it again - AY=R:GOSUB RELEASE - REM run a single mal program and exit - A$="(load-file (first -*ARGS*-))" - GOSUB RE - IF ER<>-2 THEN GOSUB PRINT_ERROR - GOTO QUIT - - REPL: - REM print the REPL startup header - REM save memory by printing this directly - #cbm PRINT "Mal [C64 BASIC]" - #qbasic PRINT "Mal [QBasic]" - - REPL_LOOP: - A$="user> ":GOSUB READLINE: REM call input parser - IF EZ=1 THEN GOTO QUIT - IF R$="" THEN GOTO REPL_LOOP - - A$=R$:CALL REP: REM call REP - - IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP - PRINT R$ - GOTO REPL_LOOP - - QUIT: - REM GOSUB PR_MEMORY_SUMMARY_SMALL - REM GOSUB PR_MEMORY_MAP - REM P1=0:P2=ZI:GOSUB PR_MEMORY - REM P1=D:GOSUB PR_OBJECT - REM P1=ZK:GOSUB PR_OBJECT - #cbm END - #qbasic SYSTEM - - PRINT_ERROR: - REM if the error is an object, then print and free it - IF ER>=0 THEN AZ=ER:B=0:GOSUB PR_STR:E$=R$:AY=ER:GOSUB RELEASE - PRINT "Error: "+E$ - ER=-2:E$="" - RETURN - +GOTO MAIN + +REM $INCLUDE: 'mem.in.bas' +REM $INCLUDE: 'types.in.bas' +REM $INCLUDE: 'readline.in.bas' +REM $INCLUDE: 'reader.in.bas' +REM $INCLUDE: 'printer.in.bas' +REM $INCLUDE: 'env.in.bas' +REM $INCLUDE: 'core.in.bas' + +REM $INCLUDE: 'debug.in.bas' + +REM READ is inlined in RE + +REM QUASIQUOTE(A) -> R +SUB QUASIQUOTE + GOSUB TYPE_A + IF T<5 OR T>8 THEN GOTO QQ_UNCHANGED + IF T=5 OR T=8 THEN GOTO QQ_QUOTE + IF T=7 THEN GOTO QQ_VECTOR + IF (Z%(A+1)=0) THEN GOTO QQ_LIST + R=Z%(A+2) + IF (Z%(R)AND 31)<>5 THEN GOTO QQ_LIST + IF S$(Z%(R+1))<>"unquote" THEN GOTO QQ_LIST + GOTO QQ_UNQUOTE + + QQ_UNCHANGED: + R=A + GOSUB INC_REF_R + + GOTO QQ_DONE + + QQ_QUOTE: + REM ['quote, ast] + B$="quote":T=5:GOSUB STRING + B=R:GOSUB LIST2 + AY=B:GOSUB RELEASE + + GOTO QQ_DONE + + QQ_VECTOR: + REM ['vec, (qq_foldr ast)] + CALL QQ_FOLDR + A=R + B$="vec":T=5:GOSUB STRING:B=R + GOSUB LIST2 + AY=A:GOSUB RELEASE + AY=B:GOSUB RELEASE + + GOTO QQ_DONE + + QQ_UNQUOTE: + REM [ast[1]] + R=Z%(Z%(A+1)+2) + GOSUB INC_REF_R + + GOTO QQ_DONE + + QQ_LIST: + CALL QQ_FOLDR + +QQ_DONE: +END SUB + +REM Quasiquote right fold (A) -> R. +REM Used for unquoted lists (GOTO), vectors (GOSUB), +REM and recursively (GOSUB). +SUB QQ_FOLDR + IF A=0 THEN GOTO QQ_EMPTY + IF Z%(A+1)=0 THEN GOTO QQ_EMPTY + GOTO QQ_NOTEMPTY + + QQ_EMPTY: + REM empty list/vector -> empty list + R=6 + GOSUB INC_REF_R + + GOTO QQ_FOLDR_DONE + + QQ_NOTEMPTY: + REM Execute QQ_FOLDR recursively with (rest A) + GOSUB PUSH_A + A=Z%(A+1):CALL QQ_FOLDR + GOSUB POP_A + + REM Set A to elt = (first A) + A=Z%(A+2) + + REM Quasiquote transition function: + REM A: current element, R: accumulator -> R: new accumulator + + REM check if A is a list starting with splice-unquote + GOSUB TYPE_A + IF T<>6 THEN GOTO QQ_DEFAULT + IF (Z%(A+1)=0) THEN GOTO QQ_DEFAULT + B=Z%(A+2) + IF (Z%(B)AND 31)<>5 THEN GOTO QQ_DEFAULT + IF S$(Z%(B+1))<>"splice-unquote" THEN GOTO QQ_DEFAULT + + REM ('concat, A[1], R) + B=Z%(Z%(A+1)+2) + A=R + B$="concat":T=5:GOSUB STRING:C=R + GOSUB LIST3 + REM release inner quasiquoted since outer list takes ownership + AY=A:GOSUB RELEASE + AY=C:GOSUB RELEASE + + GOTO QQ_FOLDR_DONE + + QQ_DEFAULT: + REM ('cons, quasiquote(A), R) + GOSUB PUSH_R + CALL QUASIQUOTE + B=R + B$="cons":T=5:GOSUB STRING:C=R + GOSUB POP_A + GOSUB LIST3 + REM release inner quasiquoted since outer list takes ownership + AY=A:GOSUB RELEASE + AY=B:GOSUB RELEASE + AY=C:GOSUB RELEASE + +QQ_FOLDR_DONE: +END SUB + +REM MACROEXPAND(A, E) -> A: +SUB MACROEXPAND + GOSUB PUSH_A + + MACROEXPAND_LOOP: + REM list? + GOSUB TYPE_A + IF T<>6 THEN GOTO MACROEXPAND_DONE + REM non-empty? + IF Z%(A+1)=0 THEN GOTO MACROEXPAND_DONE + B=Z%(A+2) + REM symbol? in first position + IF (Z%(B)AND 31)<>5 THEN GOTO MACROEXPAND_DONE + REM defined in environment? + K=B:CALL ENV_FIND + IF R=-1 THEN GOTO MACROEXPAND_DONE + B=R4 + REM macro? + IF (Z%(B)AND 31)<>11 THEN GOTO MACROEXPAND_DONE + + F=B:AR=Z%(A+1):CALL APPLY + A=R + + GOSUB PEEK_Q:AY=Q + REM if previous A was not the first A into macroexpand (i.e. an + REM intermediate form) then free it + IF A<>AY THEN GOSUB PEND_A_LV + + IF ER<>-2 THEN GOTO MACROEXPAND_DONE + GOTO MACROEXPAND_LOOP + + MACROEXPAND_DONE: + GOSUB POP_Q: REM pop original A +END SUB + +REM EVAL_AST(A, E) -> R +SUB EVAL_AST + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + IF ER<>-2 THEN GOTO EVAL_AST_RETURN + + GOSUB TYPE_A + IF T=5 THEN GOTO EVAL_AST_SYMBOL + IF T>5 AND T<9 THEN GOTO EVAL_AST_SEQ + + REM scalar: deref to actual value and inc ref cnt + R=A + GOSUB INC_REF_R + GOTO EVAL_AST_RETURN + + EVAL_AST_SYMBOL: + K=A:GOTO ENV_GET + ENV_GET_RETURN: + GOTO EVAL_AST_RETURN + + EVAL_AST_SEQ: + REM setup the stack for the loop + GOSUB MAP_LOOP_START + + EVAL_AST_SEQ_LOOP: + REM check if we are done evaluating the source sequence + IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM if we are returning to DO, then skip last element + REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to + REM return early and for TCO to work + Q=5:GOSUB PEEK_Q_Q + IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE + + REM call EVAL for each entry + GOSUB PUSH_A + IF T<>8 THEN A=Z%(A+2) + IF T=8 THEN A=Z%(A+3) + Q=T:GOSUB PUSH_Q: REM push/save type + CALL EVAL + GOSUB POP_Q:T=Q: REM pop/restore type + GOSUB POP_A + M=R + + REM if error, release the unattached element + REM TODO: is R=0 correct? + IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE + + REM for hash-maps, copy the key (inc ref since we are going to + REM release it below) + IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 + + + REM update the return sequence structure + REM release N (and M if T=8) since seq takes full ownership + C=1:GOSUB MAP_LOOP_UPDATE + + REM process the next sequence entry from source list + A=Z%(A+1) + + GOTO EVAL_AST_SEQ_LOOP + EVAL_AST_SEQ_LOOP_DONE: + REM cleanup stack and get return value + GOSUB MAP_LOOP_DONE + GOTO EVAL_AST_RETURN + + EVAL_AST_RETURN: + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q +END SUB + +REM EVAL(A, E) -> R +SUB EVAL + LV=LV+1: REM track basic return stack level + + REM push A and E on the stack + Q=E:GOSUB PUSH_Q + GOSUB PUSH_A + + REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) + + EVAL_TCO_RECUR: + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM AZ=A:B=1:GOSUB PR_STR + REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" + + GOSUB LIST_Q + IF R THEN GOTO APPLY_LIST + EVAL_NOT_LIST: + REM ELSE + CALL EVAL_AST + GOTO EVAL_RETURN + + APPLY_LIST: + CALL MACROEXPAND + + GOSUB LIST_Q + IF R<>1 THEN GOTO EVAL_NOT_LIST + + GOSUB EMPTY_Q + IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN + + A0=Z%(A+2) + + REM get symbol in A$ + IF (Z%(A0)AND 31)<>5 THEN A$="" + IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) + + IF A$="def!" THEN GOTO EVAL_DEF + IF A$="let*" THEN GOTO EVAL_LET + IF A$="quote" THEN GOTO EVAL_QUOTE + IF A$="quasiquoteexpand" THEN GOTO EVAL_QUASIQUOTEEXPAND + IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE + IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO + IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND + IF A$="try*" THEN GOTO EVAL_TRY + IF A$="do" THEN GOTO EVAL_DO + IF A$="if" THEN GOTO EVAL_IF + IF A$="fn*" THEN GOTO EVAL_FN + GOTO EVAL_INVOKE + + EVAL_GET_A3: + A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) + EVAL_GET_A2: + A2=Z%(Z%(Z%(A+1)+1)+2) + EVAL_GET_A1: + A1=Z%(Z%(A+1)+2) + RETURN + + EVAL_DEF: + REM PRINT "def!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q + A=A2:CALL EVAL: REM eval a2 + GOSUB POP_Q:A1=Q + + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM set a1 in env to a2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_LET: + REM PRINT "let*" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A2:GOSUB PUSH_Q: REM push/save A2 + Q=E:GOSUB PUSH_Q: REM push env for for later release + + REM create new environment with outer as current environment + C=E:GOSUB ENV_NEW + E=R + EVAL_LET_LOOP: + IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE + + Q=A1:GOSUB PUSH_Q: REM push A1 + REM eval current A1 odd element + A=Z%(Z%(A1+1)+2):CALL EVAL + GOSUB POP_Q:A1=Q: REM pop A1 + + IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE + + REM set key/value in the environment + K=Z%(A1+2):C=R:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership + + REM skip to the next pair of A1 elements + A1=Z%(Z%(A1+1)+1) + GOTO EVAL_LET_LOOP + + EVAL_LET_LOOP_DONE: + GOSUB POP_Q:AY=Q: REM pop previous env + + REM release previous environment if not the current EVAL env + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + GOSUB POP_Q:A2=Q: REM pop A2 + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_DO: + A=Z%(A+1): REM rest + GOSUB PUSH_A: REM push/save A + + REM this must be EVAL_AST call #2 for EVAL_AST to return early + REM and for TCO to work + CALL EVAL_AST + + REM cleanup + AY=R: REM get eval'd list for release + + GOSUB POP_A: REM pop/restore original A for LAST + GOSUB LAST: REM get last element for return + A=R: REM new recur AST + + REM cleanup + GOSUB RELEASE: REM release eval'd list + AY=A:GOSUB RELEASE: REM release LAST value (not sure why) + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_QUOTE: + R=Z%(Z%(A+1)+2) + GOSUB INC_REF_R + GOTO EVAL_RETURN + + EVAL_QUASIQUOTEEXPAND: + R=Z%(Z%(A+1)+2) + A=R:CALL QUASIQUOTE + GOTO EVAL_RETURN + + EVAL_QUASIQUOTE: + R=Z%(Z%(A+1)+2) + A=R:CALL QUASIQUOTE + A=R + REM add quasiquote result to pending release queue to free when + REM next lower EVAL level returns (LV) + GOSUB PEND_A_LV + + GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_DEFMACRO: + REM PRINT "defmacro!" + GOSUB EVAL_GET_A2: REM set A1 and A2 + + Q=A1:GOSUB PUSH_Q: REM push A1 + A=A2:CALL EVAL: REM eval A2 + GOSUB POP_Q:A1=Q: REM pop A1 + + REM change function to macro + Z%(R)=Z%(R)+1 + + REM set A1 in env to A2 + K=A1:C=R:GOSUB ENV_SET + GOTO EVAL_RETURN + + EVAL_MACROEXPAND: + REM PRINT "macroexpand" + R=Z%(Z%(A+1)+2) + A=R:CALL MACROEXPAND + R=A + + REM since we are returning it unevaluated, inc the ref cnt + GOSUB INC_REF_R + GOTO EVAL_RETURN + + EVAL_TRY: + REM PRINT "try*" + GOSUB EVAL_GET_A1: REM set A1 + + GOSUB PUSH_A: REM push/save A + A=A1:CALL EVAL: REM eval A1 + GOSUB POP_A: REM pop/restore A + + GOSUB EVAL_GET_A2: REM set A1 and A2 + + REM if there is no error or catch block then return + IF ER=-2 OR A2=0 THEN GOTO EVAL_RETURN + + REM create environment for the catch block eval + C=E:GOSUB ENV_NEW:E=R + + A=A2:GOSUB EVAL_GET_A2: REM set A1 and A2 from catch block + + REM create object for ER=-1 type raw string errors + IF ER=-1 THEN B$=E$:T=4:GOSUB STRING:ER=R:GOSUB INC_REF_R + + REM bind the catch symbol to the error object + K=A1:C=ER:GOSUB ENV_SET + AY=R:GOSUB RELEASE: REM release our use, env took ownership + + REM unset error for catch eval + ER=-2:E$="" + + A=A2:CALL EVAL + + GOTO EVAL_RETURN + + EVAL_IF: + GOSUB EVAL_GET_A1: REM set A1 + GOSUB PUSH_A: REM push/save A + A=A1:CALL EVAL + GOSUB POP_A: REM pop/restore A + IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE + + EVAL_IF_TRUE: + AY=R:GOSUB RELEASE + GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL + A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop + EVAL_IF_FALSE: + AY=R:GOSUB RELEASE + REM if no false case (A3), return nil + GOSUB COUNT + IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN + GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL + A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_FN: + GOSUB EVAL_GET_A2: REM set A1 and A2 + T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function + GOTO EVAL_RETURN + + EVAL_INVOKE: + CALL EVAL_AST + + REM if error, return f/args for release by caller + IF ER<>-2 THEN GOTO EVAL_RETURN + + REM push f/args for release after call + GOSUB PUSH_R + + AR=Z%(R+1): REM rest + F=Z%(R+2) + + REM if metadata, get the actual object + GOSUB TYPE_F + IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F + + ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION + + REM if error, pop and return f/args for release by caller + GOSUB POP_R + ER=-1:E$="apply of non-function":GOTO EVAL_RETURN + + EVAL_DO_FUNCTION: + REM regular function + IF Z%(F+1)<65 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP + REM for recur functions (apply, map, swap!), use GOTO + IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION + EVAL_DO_FUNCTION_SKIP: + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + GOTO EVAL_RETURN + + EVAL_DO_MAL_FUNCTION: + Q=E:GOSUB PUSH_Q: REM save the current environment for release + + REM create new environ using env and params stored in function + C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS + + REM release previous env if it is not the top one on the + REM stack (X%(X-2)) because our new env refers to it and + REM we no longer need to track it (since we are TCO recurring) + GOSUB POP_Q:AY=Q + GOSUB PEEK_Q_2 + IF AY<>Q THEN GOSUB RELEASE + + REM claim the AST before releasing the list containing it + A=Z%(F+1):Z%(A)=Z%(A)+32 + REM add AST to pending release queue to free as soon as EVAL + REM actually returns (LV+1) + LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 + + REM pop and release f/args + GOSUB POP_Q:AY=Q + GOSUB RELEASE + + REM A set above + E=R:GOTO EVAL_TCO_RECUR: REM TCO loop + + EVAL_RETURN: + REM AZ=R: B=1: GOSUB PR_STR + REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) + + REM release environment if not the top one on the stack + GOSUB PEEK_Q_1 + IF E<>Q THEN AY=E:GOSUB RELEASE + + LV=LV-1: REM track basic return stack level + + REM release everything we couldn't release earlier + GOSUB RELEASE_PEND + + REM trigger GC + #cbm T=FRE(0) + #qbasic T=0 + + REM pop A and E off the stack + GOSUB POP_A + GOSUB POP_Q:E=Q + +END SUB + +REM PRINT is inlined in REP + + +REM RE(A$) -> R +REM Assume D has repl_env +REM caller must release result +RE: + R1=-1 + GOSUB READ_STR: REM inlined MAL_READ + R1=R + IF ER<>-2 THEN GOTO RE_DONE + + A=R:E=D:CALL EVAL + + RE_DONE: + REM Release memory from MAL_READ + AY=R1:GOSUB RELEASE + RETURN: REM caller must release result of EVAL + +REM REP(A$) -> R$ +REM Assume D has repl_env +SUB REP + R2=-1 + + GOSUB RE + R2=R + IF ER<>-2 THEN GOTO REP_DONE + + AZ=R:B=1:GOSUB PR_STR: REM MAL_PRINT + + REP_DONE: + REM Release memory from MAL_READ and EVAL + AY=R2:GOSUB RELEASE +END SUB + +REM MAIN program +MAIN: + GOSUB INIT_MEMORY + + LV=0 + + REM create repl_env + C=0:GOSUB ENV_NEW:D=R + + REM core.EXT: defined in Basic + E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env + + ZT=ZI: REM top of memory after base repl_env + + REM core.mal: defined using the language itself + #cbm A$="(def! *host-language* "+CHR$(34)+"C64 BASIC"+CHR$(34)+")" + #qbasic A$="(def! *host-language* "+CHR$(34)+"QBasic"+CHR$(34)+")" + GOSUB RE:AY=R:GOSUB RELEASE + + A$="(def! not (fn* (a) (if a false true)))" + GOSUB RE:AY=R:GOSUB RELEASE + + A$="(def! load-file (fn* (f) (do (eval (read-file f)) nil)))" + GOSUB RE:AY=R:GOSUB RELEASE + + A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)" + A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of" + A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM load the args file + A$="(load-file "+CHR$(34)+".args.mal"+CHR$(34)+")" + GOSUB RE:AY=R:GOSUB RELEASE + + IF ER>-2 THEN GOSUB PRINT_ERROR:END + + REM set the argument list + A$="(def! *ARGV* (rest -*ARGS*-))" + GOSUB RE:AY=R:GOSUB RELEASE + + REM get the first argument + A$="(first -*ARGS*-)" + GOSUB RE + + REM no arguments, start REPL loop + IF R<16 THEN GOTO REPL + + REM if there is an argument, then run it as a program + + RUN_PROG: + REM free up first arg because we get it again + AY=R:GOSUB RELEASE + REM run a single mal program and exit + A$="(load-file (first -*ARGS*-))" + GOSUB RE + IF ER<>-2 THEN GOSUB PRINT_ERROR + GOTO QUIT + + REPL: + REM print the REPL startup header + REM save memory by printing this directly + #cbm PRINT "Mal [C64 BASIC]" + #qbasic PRINT "Mal [QBasic]" + + REPL_LOOP: + A$="user> ":GOSUB READLINE: REM call input parser + IF EZ=1 THEN GOTO QUIT + IF R$="" THEN GOTO REPL_LOOP + + A$=R$:CALL REP: REM call REP + + IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP + PRINT R$ + GOTO REPL_LOOP + + QUIT: + REM GOSUB PR_MEMORY_SUMMARY_SMALL + REM GOSUB PR_MEMORY_MAP + REM P1=0:P2=ZI:GOSUB PR_MEMORY + REM P1=D:GOSUB PR_OBJECT + REM P1=ZK:GOSUB PR_OBJECT + #cbm END + #qbasic SYSTEM + + PRINT_ERROR: + REM if the error is an object, then print and free it + IF ER>=0 THEN AZ=ER:B=0:GOSUB PR_STR:E$=R$:AY=ER:GOSUB RELEASE + PRINT "Error: "+E$ + ER=-2:E$="" + RETURN + diff --git a/impls/basic/types.in.bas b/impls/basic/types.in.bas index a5853e1e8d..a9fdb08a0f 100644 --- a/impls/basic/types.in.bas +++ b/impls/basic/types.in.bas @@ -1,309 +1,309 @@ -REM general functions - -REM TYPE_A(A) -> T -TYPE_A: - T=Z%(A)AND 31 - RETURN - -REM TYPE_F(F) -> T -TYPE_F: - T=Z%(F)AND 31 - RETURN - -REM EQUAL_Q(A, B) -> R -EQUAL_Q: - ED=0: REM recursion depth - R=-1: REM return value - - EQUAL_Q_RECUR: - - REM push A and B - GOSUB PUSH_A - Q=B:GOSUB PUSH_Q - ED=ED+1 - - GOSUB TYPE_A - T2=Z%(B)AND 31 - IF T>5 AND T<8 AND T2>5 AND T2<8 THEN GOTO EQUAL_Q_SEQ - IF T=8 AND T2=8 THEN GOTO EQUAL_Q_HM - - IF T<>T2 OR Z%(A+1)<>Z%(B+1) THEN R=0 - GOTO EQUAL_Q_DONE - - EQUAL_Q_SEQ: - IF Z%(A+1)=0 AND Z%(B+1)=0 THEN GOTO EQUAL_Q_DONE - IF Z%(A+1)=0 OR Z%(B+1)=0 THEN R=0:GOTO EQUAL_Q_DONE - - REM compare the elements - A=Z%(A+2):B=Z%(B+2) - GOTO EQUAL_Q_RECUR - - EQUAL_Q_SEQ_CONTINUE: - REM next elements of the sequences - GOSUB PEEK_Q_1:A=Q - GOSUB PEEK_Q:B=Q - A=Z%(A+1):B=Z%(B+1) - Q=A:GOSUB PUT_Q_1 - Q=B:GOSUB PUT_Q - GOTO EQUAL_Q_SEQ - - EQUAL_Q_HM: - R=0 - GOTO EQUAL_Q_DONE - - EQUAL_Q_DONE: - REM pop current A and B - GOSUB POP_Q - GOSUB POP_Q - ED=ED-1 - IF R>-1 AND ED>0 THEN GOTO EQUAL_Q_DONE: REM unwind - IF ED=0 AND R=-1 THEN R=1 - IF ED=0 THEN RETURN - GOTO EQUAL_Q_SEQ_CONTINUE - -REM string functions - -REM STRING(B$, T) -> R -REM intern string and allocate reference (return Z% index) -STRING: - IF S=0 THEN GOTO STRING_NOT_FOUND - - REM search for matching string in S$ - I=0 - STRING_FIND_LOOP: - IF I>S-1 THEN GOTO STRING_NOT_FOUND - IF S%(I)>0 AND B$=S$(I) THEN GOTO STRING_DONE - I=I+1 - GOTO STRING_FIND_LOOP - - STRING_NOT_FOUND: - I=S-1 - STRING_FIND_GAP_LOOP: - REM TODO: don't search core function names (store position) - IF I=-1 THEN GOTO STRING_NEW - IF S%(I)=0 THEN GOTO STRING_SET - I=I-1 - GOTO STRING_FIND_GAP_LOOP - - STRING_NEW: - I=S - S=S+1 - REM fallthrough - - STRING_SET: - S$(I)=B$ - REM fallthrough - - STRING_DONE: - S%(I)=S%(I)+1 - L=I:GOSUB ALLOC - RETURN - -REM REPLACE(R$, S1$, S2$) -> R$ -REPLACE: - T3$=R$ - R$="" - I=1 - J=LEN(T3$) - REPLACE_LOOP: - IF I>J THEN RETURN - C$=MID$(T3$,I,LEN(S1$)) - IF C$=S1$ THEN R$=R$+S2$:I=I+LEN(S1$) - IF C$<>S1$ THEN R$=R$+MID$(T3$,I,1):I=I+1 - GOTO REPLACE_LOOP - - -REM sequence functions - -REM FORCE_SEQ_TYPE(A,T) -> R -FORCE_SEQ_TYPE: - REM if it's already the right type, inc ref cnt and return it - IF (Z%(A)AND 31)=T THEN R=A:GOTO INC_REF_R - REM if it's empty, return the empty sequence match T - IF A<16 THEN R=(T-4)*3:GOTO INC_REF_R - REM otherwise, copy first element to turn it into correct type - B=Z%(A+2): REM value to copy - L=Z%(A+1):M=B:GOSUB ALLOC: REM T already set - IF Z%(A+1)=0 THEN RETURN - RETURN - -REM MAP_LOOP_START(T): -REM - setup stack for map loop -MAP_LOOP_START: - REM point to empty sequence to start off - R=(T-4)*3: REM calculate location of empty seq - - GOSUB PUSH_R: REM push return ptr - GOSUB PUSH_R: REM push empty ptr - GOSUB PUSH_R: REM push current ptr - GOTO INC_REF_R - -REM MAP_LOOP_UPDATE(C,M): -REM MAP_LOOP_UPDATE(C,M,N): -REM - called after M (and N if T=8) are set -REM - C indicates whether to free M (and N if T=8) -REM - update the structure of the return sequence -MAP_LOOP_UPDATE: - GOSUB PEEK_Q_1:L=Q: REM empty ptr - - GOSUB ALLOC: REM allocate new sequence element - - REM sequence took ownership - AY=L:GOSUB RELEASE - IF C THEN AY=M:GOSUB RELEASE - IF C AND T=8 THEN AY=N:GOSUB RELEASE - - REM if not first element, set current next to point to new element - GOSUB PEEK_Q - IF Q>14 THEN Z%(Q+1)=R - REM if first element, set return to new element - IF Q<15 THEN Q=R:GOSUB PUT_Q_2 - Q=R:GOSUB PUT_Q: REM update current ptr to new element - - RETURN - -REM MAP_LOOP_DONE() -> R -REM - cleanup stack and set return value -MAP_LOOP_DONE: - GOSUB POP_Q: REM pop current ptr - GOSUB POP_Q: REM pop empty ptr - GOSUB POP_R: REM pop return ptr - RETURN - - -REM LIST_Q(A) -> R -LIST_Q: - R=0 - GOSUB TYPE_A - IF T=6 THEN R=1 - RETURN - -REM EMPTY_Q(A) -> R -EMPTY_Q: - R=0 - IF Z%(A+1)=0 THEN R=1 - RETURN - -REM COUNT(A) -> R -REM - returns length of list, not a Z% index -COUNT: - GOSUB PUSH_A - R=-1 - DO_COUNT_LOOP: - R=R+1 - IF Z%(A+1)<>0 THEN A=Z%(A+1):GOTO DO_COUNT_LOOP - GOSUB POP_A - RETURN - -REM LAST(A) -> R -LAST: - REM TODO check that actually a list/vector - IF Z%(A+1)=0 THEN R=0:RETURN: REM empty seq, return nil - W=0 - LAST_LOOP: - IF Z%(A+1)=0 THEN GOTO LAST_DONE: REM end, return previous value - W=A: REM current becomes previous entry - A=Z%(A+1): REM next entry - GOTO LAST_LOOP - LAST_DONE: - R=Z%(W+2) - GOTO INC_REF_R - -REM SLICE(A,B,C) -> R -REM make copy of sequence A from index B to C -REM returns R6 as reference to last element of slice before empty -REM returns A as next element following slice (of original) -SLICE: - I=0 - R=6: REM always a list - GOSUB INC_REF_R - R6=-1: REM last list element before empty - W=R: REM temporary for return as R - REM advance A to position B - SLICE_FIND_B: - IF I0 THEN A=Z%(A+1):I=I+1:GOTO SLICE_FIND_B - SLICE_LOOP: - REM if current position is C, then return - IF C<>-1 AND I>=C THEN R=W:RETURN - REM if we reached end of A, then return - IF Z%(A+1)=0 THEN R=W:RETURN - REM allocate new list element with copied value - T=6:L=6:M=Z%(A+2):GOSUB ALLOC - REM sequence took ownership - AY=L:GOSUB RELEASE - REM if not first element, set last to point to new element - IF R6>-1 THEN Z%(R6+1)=R - REM if first element, set return value to new element - IF R6=-1 THEN W=R - R6=R: REM update last list element - REM advance to next element of A - A=Z%(A+1) - I=I+1 - GOTO SLICE_LOOP - -REM LIST2(B,A) -> R -LIST2: - REM last element is 3 (empty list), second element is A - T=6:L=6:M=A:GOSUB ALLOC - - REM first element is B - T=6:L=R:M=B:GOSUB ALLOC - AY=L:GOSUB RELEASE: REM new list takes ownership of previous - - RETURN - -REM LIST3(C,B,A) -> R -LIST3: - GOSUB LIST2 - - REM first element is C - T=6:L=R:M=C:GOSUB ALLOC - AY=L:GOSUB RELEASE: REM new list takes ownership of previous - - RETURN - - -REM hashmap functions - -REM HASHMAP() -> R -HASHMAP: - REM just point to static empty hash-map - R=12 - GOTO INC_REF_R - -REM ASSOC1(H, K, C) -> R -ASSOC1: - REM create key/value entry - T=8:L=H:M=K:N=C:GOSUB ALLOC - AY=L:GOSUB RELEASE: REM we took ownership of previous hashmap - RETURN - -REM ASSOC1_S(H, B$, C) -> R -ASSOC1_S: - REM add the key string - T=4:GOSUB STRING - K=R:GOSUB ASSOC1 - AY=K:GOSUB RELEASE: REM map took ownership of key - RETURN - -REM HASHMAP_GET(H, K) -> R -REM - returns R3 with whether we found it or not -HASHMAP_GET: - B$=S$(Z%(K+1)): REM search key string - R3=0: REM whether found or not (for HASHMAP_CONTAINS) - R=0 - HASHMAP_GET_LOOP: - REM no matching key found - IF Z%(H+1)=0 THEN R=0:RETURN - REM get search string is equal to key string we found it - IF B$=S$(Z%(Z%(H+2)+1)) THEN R3=1:R=Z%(H+3):RETURN - REM skip to next key/value - H=Z%(H+1) - GOTO HASHMAP_GET_LOOP - -REM HASHMAP_CONTAINS(H, K) -> R -HASHMAP_CONTAINS: - GOSUB HASHMAP_GET - R=R3 - RETURN - +REM general functions + +REM TYPE_A(A) -> T +TYPE_A: + T=Z%(A)AND 31 + RETURN + +REM TYPE_F(F) -> T +TYPE_F: + T=Z%(F)AND 31 + RETURN + +REM EQUAL_Q(A, B) -> R +EQUAL_Q: + ED=0: REM recursion depth + R=-1: REM return value + + EQUAL_Q_RECUR: + + REM push A and B + GOSUB PUSH_A + Q=B:GOSUB PUSH_Q + ED=ED+1 + + GOSUB TYPE_A + T2=Z%(B)AND 31 + IF T>5 AND T<8 AND T2>5 AND T2<8 THEN GOTO EQUAL_Q_SEQ + IF T=8 AND T2=8 THEN GOTO EQUAL_Q_HM + + IF T<>T2 OR Z%(A+1)<>Z%(B+1) THEN R=0 + GOTO EQUAL_Q_DONE + + EQUAL_Q_SEQ: + IF Z%(A+1)=0 AND Z%(B+1)=0 THEN GOTO EQUAL_Q_DONE + IF Z%(A+1)=0 OR Z%(B+1)=0 THEN R=0:GOTO EQUAL_Q_DONE + + REM compare the elements + A=Z%(A+2):B=Z%(B+2) + GOTO EQUAL_Q_RECUR + + EQUAL_Q_SEQ_CONTINUE: + REM next elements of the sequences + GOSUB PEEK_Q_1:A=Q + GOSUB PEEK_Q:B=Q + A=Z%(A+1):B=Z%(B+1) + Q=A:GOSUB PUT_Q_1 + Q=B:GOSUB PUT_Q + GOTO EQUAL_Q_SEQ + + EQUAL_Q_HM: + R=0 + GOTO EQUAL_Q_DONE + + EQUAL_Q_DONE: + REM pop current A and B + GOSUB POP_Q + GOSUB POP_Q + ED=ED-1 + IF R>-1 AND ED>0 THEN GOTO EQUAL_Q_DONE: REM unwind + IF ED=0 AND R=-1 THEN R=1 + IF ED=0 THEN RETURN + GOTO EQUAL_Q_SEQ_CONTINUE + +REM string functions + +REM STRING(B$, T) -> R +REM intern string and allocate reference (return Z% index) +STRING: + IF S=0 THEN GOTO STRING_NOT_FOUND + + REM search for matching string in S$ + I=0 + STRING_FIND_LOOP: + IF I>S-1 THEN GOTO STRING_NOT_FOUND + IF S%(I)>0 AND B$=S$(I) THEN GOTO STRING_DONE + I=I+1 + GOTO STRING_FIND_LOOP + + STRING_NOT_FOUND: + I=S-1 + STRING_FIND_GAP_LOOP: + REM TODO: don't search core function names (store position) + IF I=-1 THEN GOTO STRING_NEW + IF S%(I)=0 THEN GOTO STRING_SET + I=I-1 + GOTO STRING_FIND_GAP_LOOP + + STRING_NEW: + I=S + S=S+1 + REM fallthrough + + STRING_SET: + S$(I)=B$ + REM fallthrough + + STRING_DONE: + S%(I)=S%(I)+1 + L=I:GOSUB ALLOC + RETURN + +REM REPLACE(R$, S1$, S2$) -> R$ +REPLACE: + T3$=R$ + R$="" + I=1 + J=LEN(T3$) + REPLACE_LOOP: + IF I>J THEN RETURN + C$=MID$(T3$,I,LEN(S1$)) + IF C$=S1$ THEN R$=R$+S2$:I=I+LEN(S1$) + IF C$<>S1$ THEN R$=R$+MID$(T3$,I,1):I=I+1 + GOTO REPLACE_LOOP + + +REM sequence functions + +REM FORCE_SEQ_TYPE(A,T) -> R +FORCE_SEQ_TYPE: + REM if it's already the right type, inc ref cnt and return it + IF (Z%(A)AND 31)=T THEN R=A:GOTO INC_REF_R + REM if it's empty, return the empty sequence match T + IF A<16 THEN R=(T-4)*3:GOTO INC_REF_R + REM otherwise, copy first element to turn it into correct type + B=Z%(A+2): REM value to copy + L=Z%(A+1):M=B:GOSUB ALLOC: REM T already set + IF Z%(A+1)=0 THEN RETURN + RETURN + +REM MAP_LOOP_START(T): +REM - setup stack for map loop +MAP_LOOP_START: + REM point to empty sequence to start off + R=(T-4)*3: REM calculate location of empty seq + + GOSUB PUSH_R: REM push return ptr + GOSUB PUSH_R: REM push empty ptr + GOSUB PUSH_R: REM push current ptr + GOTO INC_REF_R + +REM MAP_LOOP_UPDATE(C,M): +REM MAP_LOOP_UPDATE(C,M,N): +REM - called after M (and N if T=8) are set +REM - C indicates whether to free M (and N if T=8) +REM - update the structure of the return sequence +MAP_LOOP_UPDATE: + GOSUB PEEK_Q_1:L=Q: REM empty ptr + + GOSUB ALLOC: REM allocate new sequence element + + REM sequence took ownership + AY=L:GOSUB RELEASE + IF C THEN AY=M:GOSUB RELEASE + IF C AND T=8 THEN AY=N:GOSUB RELEASE + + REM if not first element, set current next to point to new element + GOSUB PEEK_Q + IF Q>14 THEN Z%(Q+1)=R + REM if first element, set return to new element + IF Q<15 THEN Q=R:GOSUB PUT_Q_2 + Q=R:GOSUB PUT_Q: REM update current ptr to new element + + RETURN + +REM MAP_LOOP_DONE() -> R +REM - cleanup stack and set return value +MAP_LOOP_DONE: + GOSUB POP_Q: REM pop current ptr + GOSUB POP_Q: REM pop empty ptr + GOSUB POP_R: REM pop return ptr + RETURN + + +REM LIST_Q(A) -> R +LIST_Q: + R=0 + GOSUB TYPE_A + IF T=6 THEN R=1 + RETURN + +REM EMPTY_Q(A) -> R +EMPTY_Q: + R=0 + IF Z%(A+1)=0 THEN R=1 + RETURN + +REM COUNT(A) -> R +REM - returns length of list, not a Z% index +COUNT: + GOSUB PUSH_A + R=-1 + DO_COUNT_LOOP: + R=R+1 + IF Z%(A+1)<>0 THEN A=Z%(A+1):GOTO DO_COUNT_LOOP + GOSUB POP_A + RETURN + +REM LAST(A) -> R +LAST: + REM TODO check that actually a list/vector + IF Z%(A+1)=0 THEN R=0:RETURN: REM empty seq, return nil + W=0 + LAST_LOOP: + IF Z%(A+1)=0 THEN GOTO LAST_DONE: REM end, return previous value + W=A: REM current becomes previous entry + A=Z%(A+1): REM next entry + GOTO LAST_LOOP + LAST_DONE: + R=Z%(W+2) + GOTO INC_REF_R + +REM SLICE(A,B,C) -> R +REM make copy of sequence A from index B to C +REM returns R6 as reference to last element of slice before empty +REM returns A as next element following slice (of original) +SLICE: + I=0 + R=6: REM always a list + GOSUB INC_REF_R + R6=-1: REM last list element before empty + W=R: REM temporary for return as R + REM advance A to position B + SLICE_FIND_B: + IF I0 THEN A=Z%(A+1):I=I+1:GOTO SLICE_FIND_B + SLICE_LOOP: + REM if current position is C, then return + IF C<>-1 AND I>=C THEN R=W:RETURN + REM if we reached end of A, then return + IF Z%(A+1)=0 THEN R=W:RETURN + REM allocate new list element with copied value + T=6:L=6:M=Z%(A+2):GOSUB ALLOC + REM sequence took ownership + AY=L:GOSUB RELEASE + REM if not first element, set last to point to new element + IF R6>-1 THEN Z%(R6+1)=R + REM if first element, set return value to new element + IF R6=-1 THEN W=R + R6=R: REM update last list element + REM advance to next element of A + A=Z%(A+1) + I=I+1 + GOTO SLICE_LOOP + +REM LIST2(B,A) -> R +LIST2: + REM last element is 3 (empty list), second element is A + T=6:L=6:M=A:GOSUB ALLOC + + REM first element is B + T=6:L=R:M=B:GOSUB ALLOC + AY=L:GOSUB RELEASE: REM new list takes ownership of previous + + RETURN + +REM LIST3(C,B,A) -> R +LIST3: + GOSUB LIST2 + + REM first element is C + T=6:L=R:M=C:GOSUB ALLOC + AY=L:GOSUB RELEASE: REM new list takes ownership of previous + + RETURN + + +REM hashmap functions + +REM HASHMAP() -> R +HASHMAP: + REM just point to static empty hash-map + R=12 + GOTO INC_REF_R + +REM ASSOC1(H, K, C) -> R +ASSOC1: + REM create key/value entry + T=8:L=H:M=K:N=C:GOSUB ALLOC + AY=L:GOSUB RELEASE: REM we took ownership of previous hashmap + RETURN + +REM ASSOC1_S(H, B$, C) -> R +ASSOC1_S: + REM add the key string + T=4:GOSUB STRING + K=R:GOSUB ASSOC1 + AY=K:GOSUB RELEASE: REM map took ownership of key + RETURN + +REM HASHMAP_GET(H, K) -> R +REM - returns R3 with whether we found it or not +HASHMAP_GET: + B$=S$(Z%(K+1)): REM search key string + R3=0: REM whether found or not (for HASHMAP_CONTAINS) + R=0 + HASHMAP_GET_LOOP: + REM no matching key found + IF Z%(H+1)=0 THEN R=0:RETURN + REM get search string is equal to key string we found it + IF B$=S$(Z%(Z%(H+2)+1)) THEN R3=1:R=Z%(H+3):RETURN + REM skip to next key/value + H=Z%(H+1) + GOTO HASHMAP_GET_LOOP + +REM HASHMAP_CONTAINS(H, K) -> R +HASHMAP_CONTAINS: + GOSUB HASHMAP_GET + R=R3 + RETURN + diff --git a/impls/basic/variables.txt b/impls/basic/variables.txt index 3e7afc7623..70f72555e4 100644 --- a/impls/basic/variables.txt +++ b/impls/basic/variables.txt @@ -1,109 +1,109 @@ -Global Unique: - -Z% : boxed memory values -Z1 : Z% size -Z2 : S$ size -Z3 : stack start address (cbm) or X% size (qbasic) -Z4 : release stack start address (cbm) or Y% size (qbasic) -ZI : start of unused memory (index into Z%) -ZK : start of free list (index into Z%) -ZT : top of memory after repl env allocations - -S$ : string memory storage -S : next free index in S$ - -X% : logic/call stack (Z% indexes) -X : top element of X% stack - -Y% : pending release stack [index into Z%, eval level] -Y : top element of Y% stack - -D : root repl environment - -BT : begin time (TI) -ER : error type (-2: none, -1: string, >=0: object) -E$ : error string (ER=-1) -EZ : READLINE EOF return, READ_FILE EOF temp - -LV : EVAL stack call level/depth - -RI : reader current string position -RJ : READ_TOKEN current character index - - -Calling arguments/temporaries: - -A : common call argument (especially EVAL, EVAL_AST) -A$ : common call argument (READLINE, reader, string temp, key value) -B : common call argument -B$ : STRING arg (HASHMAP_GET temp), PR_STR_SEQ separator - : INIT_CORE_SET_FUNCTION, ENV_SET_S, ASSOC1_S -C : common call argument, DO_TCO_FUNCTION temp in DO_APPLY -E : environment (EVAL, EVAL_AST) -F : function -H : hash map -K : hash map key (Z% index) -L : ALLOC* Z%(R,1) default -M : ALLOC* Z%(R+1,0) default -N : ALLOC* Z%(R+1,1) default -R : common return value -R$ : common string return value -T : type arg, common temp -Q : PUSH*, POP*, PEEK* return value (and PEEK_Q_Q call arg) - -AR : APPLY, DO_*_FUNCTION arg list -AY : RELEASE/FREE arg -AZ : PR_STR arg -P1 : PR_MEMORY*, PR_OBJECT, CHECK_FREE_LIST start -P2 : PR_MEMORY*, PR_OBJECT, CHECK_FREE_LIST end -P3 : PR_OBJECT, PR_MEMORY_VALUE -R1 : REP, RE - MAL_READ result temp -R2 : REP, RE - EVAL result temp -R3 : HASHMAP_GET, DO_HASH_MAP, DO_KEYS_VALS temp and return value -R4 : ENV_FIND temp and return value -R6 : SLICE return value (last element) -SZ : size argument to ALLOC -S1$ : REPLACE needle -S2$ : REPLACE replacement - - -Other temporaries: - -A0 : EVAL ast elements -A1 : EVAL ast elements, DO_FUNCTION temp -A2 : EVAL ast elements, DO_FUNCTION temp -A3 : EVAL ast elements -B1 : DO_FUNCTION temp - -CZ : DO_CONCAT stack position -ED : EQUAL_Q recursion depth counter -RD : PR_OBJECT recursion depth -SD : READ_STR sequence read recursion depth - -C$ : READ_TOKEN, SKIP_SPACES, SKIP_TO_EOL current character -D$ : READ_TOKEN/READ_FILE_CHAR temp -G : function value ON GOTO switch flag, EVAL_AST changed flag -I : STRING, REPLACE, SLICE, PR_MEMORY, PR_OBJECT, PR_MEMORY_VALUE -J : REPLACE, PR_MEMORY_VALUE -U : ALLOC, RELEASE, PR_STR temp -V : RELEASE, PR_STR_SEQ temp -W : SLICE, LAST, QUASIQUOTE, DO_HASH_MAP, DO_KEYS_VALS, step2-3 EVAL temp -P : PR_MEMORY_SUMMARY_SMALL -RC : RELEASE remaining number of elements to release -RF : reader reading from file flag -S1 : READ_TOKEN in a string? -S2 : READ_TOKEN escaped? -T$ : READ_* current token string -T1 : EQUAL_Q, PR_STR, DO_KEYS_VALS temp -T2 : EQUAL_Q, DO_KEY_VALS, HASH_MAP_GET -T3$ : REPLACE temp - - -Unused: - -O - - -Counting number of times each variable is assigned: - sed 's/:/\n /g' readline.in.bas types.in.bas reader.in.bas printer.in.bas env.in.bas core.in.bas stepA_mal.in.bas | grep "[A-Z][A-Z0-9]*[%$]*=" | sed 's/.*[^A-Z]\([A-Z][A-Z0-9]*[%$]*\)=.*/\1/g' | sort | uniq -c | sort -n - +Global Unique: + +Z% : boxed memory values +Z1 : Z% size +Z2 : S$ size +Z3 : stack start address (cbm) or X% size (qbasic) +Z4 : release stack start address (cbm) or Y% size (qbasic) +ZI : start of unused memory (index into Z%) +ZK : start of free list (index into Z%) +ZT : top of memory after repl env allocations + +S$ : string memory storage +S : next free index in S$ + +X% : logic/call stack (Z% indexes) +X : top element of X% stack + +Y% : pending release stack [index into Z%, eval level] +Y : top element of Y% stack + +D : root repl environment + +BT : begin time (TI) +ER : error type (-2: none, -1: string, >=0: object) +E$ : error string (ER=-1) +EZ : READLINE EOF return, READ_FILE EOF temp + +LV : EVAL stack call level/depth + +RI : reader current string position +RJ : READ_TOKEN current character index + + +Calling arguments/temporaries: + +A : common call argument (especially EVAL, EVAL_AST) +A$ : common call argument (READLINE, reader, string temp, key value) +B : common call argument +B$ : STRING arg (HASHMAP_GET temp), PR_STR_SEQ separator + : INIT_CORE_SET_FUNCTION, ENV_SET_S, ASSOC1_S +C : common call argument, DO_TCO_FUNCTION temp in DO_APPLY +E : environment (EVAL, EVAL_AST) +F : function +H : hash map +K : hash map key (Z% index) +L : ALLOC* Z%(R,1) default +M : ALLOC* Z%(R+1,0) default +N : ALLOC* Z%(R+1,1) default +R : common return value +R$ : common string return value +T : type arg, common temp +Q : PUSH*, POP*, PEEK* return value (and PEEK_Q_Q call arg) + +AR : APPLY, DO_*_FUNCTION arg list +AY : RELEASE/FREE arg +AZ : PR_STR arg +P1 : PR_MEMORY*, PR_OBJECT, CHECK_FREE_LIST start +P2 : PR_MEMORY*, PR_OBJECT, CHECK_FREE_LIST end +P3 : PR_OBJECT, PR_MEMORY_VALUE +R1 : REP, RE - MAL_READ result temp +R2 : REP, RE - EVAL result temp +R3 : HASHMAP_GET, DO_HASH_MAP, DO_KEYS_VALS temp and return value +R4 : ENV_FIND temp and return value +R6 : SLICE return value (last element) +SZ : size argument to ALLOC +S1$ : REPLACE needle +S2$ : REPLACE replacement + + +Other temporaries: + +A0 : EVAL ast elements +A1 : EVAL ast elements, DO_FUNCTION temp +A2 : EVAL ast elements, DO_FUNCTION temp +A3 : EVAL ast elements +B1 : DO_FUNCTION temp + +CZ : DO_CONCAT stack position +ED : EQUAL_Q recursion depth counter +RD : PR_OBJECT recursion depth +SD : READ_STR sequence read recursion depth + +C$ : READ_TOKEN, SKIP_SPACES, SKIP_TO_EOL current character +D$ : READ_TOKEN/READ_FILE_CHAR temp +G : function value ON GOTO switch flag, EVAL_AST changed flag +I : STRING, REPLACE, SLICE, PR_MEMORY, PR_OBJECT, PR_MEMORY_VALUE +J : REPLACE, PR_MEMORY_VALUE +U : ALLOC, RELEASE, PR_STR temp +V : RELEASE, PR_STR_SEQ temp +W : SLICE, LAST, QUASIQUOTE, DO_HASH_MAP, DO_KEYS_VALS, step2-3 EVAL temp +P : PR_MEMORY_SUMMARY_SMALL +RC : RELEASE remaining number of elements to release +RF : reader reading from file flag +S1 : READ_TOKEN in a string? +S2 : READ_TOKEN escaped? +T$ : READ_* current token string +T1 : EQUAL_Q, PR_STR, DO_KEYS_VALS temp +T2 : EQUAL_Q, DO_KEY_VALS, HASH_MAP_GET +T3$ : REPLACE temp + + +Unused: + +O + + +Counting number of times each variable is assigned: + sed 's/:/\n /g' readline.in.bas types.in.bas reader.in.bas printer.in.bas env.in.bas core.in.bas stepA_mal.in.bas | grep "[A-Z][A-Z0-9]*[%$]*=" | sed 's/.*[^A-Z]\([A-Z][A-Z0-9]*[%$]*\)=.*/\1/g' | sort | uniq -c | sort -n + diff --git a/impls/batch/LinearList_LSS_SLL.bat b/impls/batch/LinearList_LSS_SLL.bat new file mode 100644 index 0000000000..83f16031ae --- /dev/null +++ b/impls/batch/LinearList_LSS_SLL.bat @@ -0,0 +1,105 @@ +::Code by OldLiu +::д + +::Start + Set "_TMP_Arguments_=%*" + If "!_TMP_Arguments_:~,1!" Equ ":" ( + Set "_TMP_Arguments_=!_TMP_Arguments_:~1!" + ) + Call :LinearList_LSS_SLL_!_TMP_Arguments_! + Set _TMP_Arguments_= +Goto :Eof + +::LinearList_LSS_SLL Begin + :LinearList_LSS_SLL_GetRandom + Set /A ErrorLevel=%random%%%10000+%random%*10000 + If !ErrorLevel! Equ 0 Goto GetRandom + If Defined Memory[!ErrorLevel!].Data Goto GetRandom + Goto :Eof + + :LinearList_LSS_SLL_Init ListName + Call :LinearList_LSS_SLL_GetRandom + Set /A %~1=ErrorLevel + Set Memory[!ErrorLevel!].Data=ListHead + Set /A Memory[!ErrorLevel!].Next=0 + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_Clear ListName + Call :LinearList_LSS_SLL_DeleteNextNode "%~1" + If !ErrorLevel! Equ 0 Goto :LinearList_LSS_SLL_Clear + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_Delete ListName + Call :LinearList_LSS_SLL_Clear "%~1" + Set Memory[!%~1!].Data= + Set Memory[!%~1!].Next= + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_GetLength ListName + Set /A _LinearList_LSS_SLL_GetLength_TMP_ListLength_=0 + Set /A _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_=%~1 + :LinearList_LSS_SLL_GetLength_Loop + Call :LinearList_LSS_SLL_GetNextNodePtr _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_ + Set /A _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_=ErrorLevel + If !_LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_! Neq 0 ( + Set /A _LinearList_LSS_SLL_GetLength_TMP_ListLength_+=1 + Goto LinearList_LSS_SLL_GetLength_Loop + ) + Set /A ErrorLevel=_LinearList_LSS_SLL_GetLength_TMP_ListLength_ + Set _LinearList_LSS_SLL_GetLength_TMP_ListLength_= + Set _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_= + Goto :Eof + + :LinearList_LSS_SLL_IsEmpty ListName + :LinearList_LSS_SLL_GetNextNodePtr NodePtr + Set /A _LinearList_LSS_SLL_GetNextNodePtr_TMP_NodePtr_=%~1 + Set /A ErrorLevel=Memory[!_LinearList_LSS_SLL_GetNextNodePtr_TMP_NodePtr_!].Next + Set _LinearList_LSS_SLL_GetNextNodePtr_TMP_NodePtr_= + Goto :Eof + + :LinearList_LSS_SLL_InsertNextNode NodePtr VarToInsert + Set /A _LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_=%~1 + Set /A _LinearList_LSS_SLL_InsertNextNode_TMP_NextNodePtr_=Memory[!_LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_!].Next + Call :LinearList_LSS_SLL_GetRandom + Set /A Memory[!_LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_!].Next=ErrorLevel + Set /A Memory[!ErrorLevel!].Next=_LinearList_LSS_SLL_InsertNextNode_TMP_NextNodePtr_ + Set "Memory[!ErrorLevel!].Data=!%~2!" + Set _LinearList_LSS_SLL_InsertNextNode_TMP_NextNodePtr_= + Set _LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_= + Goto :Eof + + :LinearList_LSS_SLL_DeleteNextNode NodePtr [VarToSaveNextNodeElemValue] + Set /A _LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_=%~1 + Set /A _LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_=Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_!].Next + If !_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_! Equ 0 ( + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_= + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_= + Set /A ErrorLevel=1 + Goto :Eof + ) + Set /A Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_!].Next=Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Next + If "%~2" Neq "" Call Set "%~2=%%Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Data%%" + Set Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Next= + Set Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Data= + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_= + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_= + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_GetNodeElem NodePtr VarToSaveElemValue + Set /A LinearList_LSS_SLL_GetNodeElem_TMP_NodePtr_=%~1 + Call Set "%~2=%%Memory[!LinearList_LSS_SLL_GetNodeElem_TMP_NodePtr_!].Data%%" + Set LinearList_LSS_SLL_GetNodeElem_TMP_NodePtr_= + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_EditNodeElem NodePtr VarToReplaceElemValue + Set /A LinearList_LSS_SLL_EditNodeElem_TMP_NodePtr_=%~1 + Set "Memory[!LinearList_LSS_SLL_EditNodeElem_TMP_NodePtr_!].Data=!%~2!" + Set LinearList_LSS_SLL_EditNodeElem_TMP_NodePtr_= + Set /A ErrorLevel=0 + Goto :Eof +::LinearList_LSS_SLL End \ No newline at end of file diff --git a/impls/batch/Queue_LSS.bat b/impls/batch/Queue_LSS.bat new file mode 100644 index 0000000000..7788e4a499 --- /dev/null +++ b/impls/batch/Queue_LSS.bat @@ -0,0 +1,146 @@ +::Code by OldLiu +::д + +::Start + Set "_TMP_Arguments_=%*" + If "!_TMP_Arguments_:~,1!" Equ ":" ( + Set "_TMP_Arguments_=!_TMP_Arguments_:~1!" + ) + Call :Queue_LSS_!_TMP_Arguments_! + Set _TMP_Arguments_= +Goto :Eof + +::Queue_LSS(require LinearList_LSS_SLL) Begin + :Queue_LSS_Init QueueName + Call :LinearList_LSS_SLL_Init "%~1" + Call :LinearList_LSS_SLL_EditNodeElem "%~1" "%~1" + Goto :Eof + + :Queue_LSS_Clear QueueName + Call :LinearList_LSS_SLL_Clear "%~1" + Set /A _Queue_LSS_Clear_TMP_HeadNodePtr=%~1 + Call :LinearList_LSS_SLL_EditNodeElem "%~1" "_Queue_LSS_Clear_TMP_HeadNodePtr" + Set _Queue_LSS_Clear_TMP_HeadNodePtr= + Goto :Eof + + :Queue_LSS_Delete QueueName + Call :LinearList_LSS_SLL_Delete "%~1" + Goto :Eof + + :Queue_LSS_IsEmpty QueueName + Call :LinearList_LSS_SLL_IsEmpty "%~1" + Goto :Eof + + :Queue_LSS_Enqueue QueueName VarToInsert + Call :LinearList_LSS_SLL_GetNodeElem "%~1" _Queue_LSS_Enqueue_TMP_QueueRearPtr + Call :LinearList_LSS_SLL_InsertNextNode _Queue_LSS_Enqueue_TMP_QueueRearPtr "%~2" + Call :LinearList_LSS_SLL_EditNodeElem "%~1" ErrorLevel + Goto :Eof + + :Queue_LSS_Dequeue QueueName [VarToReturn] + Call :LinearList_LSS_SLL_DeleteNextNode "%~1" "%~2" + If !ErrorLevel! Neq 0 Goto :Eof + Call :Queue_LSS_IsEmpty "%~1" + If !ErrorLevel! Equ 0 Call :Queue_LSS_Clear "%~1" + Set /A ErrorLevel=0 + Goto :Eof + + :Queue_LSS_Peep QueueName VarToReturn + Call :LinearList_LSS_SLL_GetNextNodePtr "%~1" + Call :LinearList_LSS_SLL_GetNodeElem ErrorLevel "%~2" + Goto :Eof +::Queue_LSS End + +::LinearList_LSS_SLL Begin + :LinearList_LSS_SLL_GetRandom + Set /A ErrorLevel=%random%%%10000+%random%*10000 + If !ErrorLevel! Equ 0 Goto GetRandom + If Defined Memory[!ErrorLevel!].Data Goto GetRandom + Goto :Eof + + :LinearList_LSS_SLL_Init ListName + Call :LinearList_LSS_SLL_GetRandom + Set /A %~1=ErrorLevel + Set Memory[!ErrorLevel!].Data=ListHead + Set /A Memory[!ErrorLevel!].Next=0 + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_Clear ListName + Call :LinearList_LSS_SLL_DeleteNextNode "%~1" + If !ErrorLevel! Equ 0 Goto :LinearList_LSS_SLL_Clear + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_Delete ListName + Call :LinearList_LSS_SLL_Clear "%~1" + Set Memory[!%~1!].Data= + Set Memory[!%~1!].Next= + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_GetLength ListName + Set /A _LinearList_LSS_SLL_GetLength_TMP_ListLength_=0 + Set /A _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_=%~1 + :LinearList_LSS_SLL_GetLength_Loop + Call :LinearList_LSS_SLL_GetNextNodePtr _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_ + Set /A _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_=ErrorLevel + If !_LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_! Neq 0 ( + Set /A _LinearList_LSS_SLL_GetLength_TMP_ListLength_+=1 + Goto LinearList_LSS_SLL_GetLength_Loop + ) + Set /A ErrorLevel=_LinearList_LSS_SLL_GetLength_TMP_ListLength_ + Set _LinearList_LSS_SLL_GetLength_TMP_ListLength_= + Set _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_= + Goto :Eof + + :LinearList_LSS_SLL_IsEmpty ListName + :LinearList_LSS_SLL_GetNextNodePtr NodePtr + Set /A _LinearList_LSS_SLL_GetNextNodePtr_TMP_NodePtr_=%~1 + Set /A ErrorLevel=Memory[!_LinearList_LSS_SLL_GetNextNodePtr_TMP_NodePtr_!].Next + Set _LinearList_LSS_SLL_GetNextNodePtr_TMP_NodePtr_= + Goto :Eof + + :LinearList_LSS_SLL_InsertNextNode NodePtr VarToInsert + Set /A _LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_=%~1 + Set /A _LinearList_LSS_SLL_InsertNextNode_TMP_NextNodePtr_=Memory[!_LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_!].Next + Call :LinearList_LSS_SLL_GetRandom + Set /A Memory[!_LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_!].Next=ErrorLevel + Set /A Memory[!ErrorLevel!].Next=_LinearList_LSS_SLL_InsertNextNode_TMP_NextNodePtr_ + Set "Memory[!ErrorLevel!].Data=!%~2!" + Set _LinearList_LSS_SLL_InsertNextNode_TMP_NextNodePtr_= + Set _LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_= + Goto :Eof + + :LinearList_LSS_SLL_DeleteNextNode NodePtr [VarToSaveNextNodeElemValue] + Set /A _LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_=%~1 + Set /A _LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_=Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_!].Next + If !_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_! Equ 0 ( + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_= + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_= + Set /A ErrorLevel=1 + Goto :Eof + ) + Set /A Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_!].Next=Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Next + If "%~2" Neq "" Call Set "%~2=%%Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Data%%" + Set Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Next= + Set Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Data= + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_= + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_= + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_GetNodeElem NodePtr VarToSaveElemValue + Set /A LinearList_LSS_SLL_GetNodeElem_TMP_NodePtr_=%~1 + Call Set "%~2=%%Memory[!LinearList_LSS_SLL_GetNodeElem_TMP_NodePtr_!].Data%%" + Set LinearList_LSS_SLL_GetNodeElem_TMP_NodePtr_= + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_EditNodeElem NodePtr VarToReplaceElemValue + Set /A LinearList_LSS_SLL_EditNodeElem_TMP_NodePtr_=%~1 + Set "Memory[!LinearList_LSS_SLL_EditNodeElem_TMP_NodePtr_!].Data=!%~2!" + Set LinearList_LSS_SLL_EditNodeElem_TMP_NodePtr_= + Set /A ErrorLevel=0 + Goto :Eof +::LinearList_LSS_SLL End \ No newline at end of file diff --git a/impls/batch/Stack_LSS.bat b/impls/batch/Stack_LSS.bat new file mode 100644 index 0000000000..01e55b02ae --- /dev/null +++ b/impls/batch/Stack_LSS.bat @@ -0,0 +1,154 @@ +::Code by OldLiu +::д + +::Start + Set "_TMP_Arguments_=%*" + If "!_TMP_Arguments_:~,1!" Equ ":" ( + Set "_TMP_Arguments_=!_TMP_Arguments_:~1!" + ) + Call :Stack_LSS_!_TMP_Arguments_! + Set _TMP_Arguments_= +Goto :Eof + +::Stack_LSS(require LinearList_LSS_SLL) Begin + :Stack_LSS_Init StackName + Call :LinearList_LSS_SLL_Init "%~1" + Goto :Eof + + :Stack_LSS_Clear StackName + Call :LinearList_LSS_SLL_Clear "%~1" + Goto :Eof + + :Stack_LSS_Delete StackName + Call :LinearList_LSS_SLL_Delete "%~1" + Goto :Eof + + :Stack_LSS_IsEmpty StackName + Call :LinearList_LSS_SLL_IsEmpty "%~1" + Goto :Eof + + :Stack_LSS_GetLength StackName + Call :LinearList_LSS_SLL_GetLength "%~1" + Goto :Eof + + :Stack_LSS_Push StackName VarToPush + Call :LinearList_LSS_SLL_InsertNextNode "%~1" "%~2" + Set /A ErrorLevel=0 + Goto :Eof + + :Stack_LSS_Pop StackName VarToReturn + Call :LinearList_LSS_SLL_DeleteNextNode "%~1" "%~2" + Goto :Eof + + :Stack_LSS_GetTopElem StackName VarToReturn + Call :LinearList_LSS_SLL_GetNextNodePtr "%~1" + If !ErrorLevel! Equ 0 ( + Set /A ErrorLevel=1 + Goto :Eof + ) + Call :LinearList_LSS_SLL_GetNodeElem ErrorLevel "%~2" + Goto :Eof + + :Stack_LSS_EditTopElem StackName VarToReplaceWith + Call :LinearList_LSS_SLL_GetNextNodePtr "%~1" + If !ErrorLevel! Equ 0 ( + Set /A ErrorLevel=1 + Goto :Eof + ) + Call :LinearList_LSS_SLL_EditNodeElem ErrorLevel "%~2" + Goto :Eof +::Stack_LSS End + +::LinearList_LSS_SLL Begin + :LinearList_LSS_SLL_GetRandom + Set /A ErrorLevel=%random%%%10000+%random%*10000 + If !ErrorLevel! Equ 0 Goto GetRandom + If Defined Memory[!ErrorLevel!].Data Goto GetRandom + Goto :Eof + + :LinearList_LSS_SLL_Init ListName + Call :LinearList_LSS_SLL_GetRandom + Set /A %~1=ErrorLevel + Set Memory[!ErrorLevel!].Data=ListHead + Set /A Memory[!ErrorLevel!].Next=0 + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_Clear ListName + Call :LinearList_LSS_SLL_DeleteNextNode "%~1" + If !ErrorLevel! Equ 0 Goto :LinearList_LSS_SLL_Clear + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_Delete ListName + Call :LinearList_LSS_SLL_Clear "%~1" + Set Memory[!%~1!].Data= + Set Memory[!%~1!].Next= + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_GetLength ListName + Set /A _LinearList_LSS_SLL_GetLength_TMP_ListLength_=0 + Set /A _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_=%~1 + :LinearList_LSS_SLL_GetLength_Loop + Call :LinearList_LSS_SLL_GetNextNodePtr _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_ + Set /A _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_=ErrorLevel + If !_LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_! Neq 0 ( + Set /A _LinearList_LSS_SLL_GetLength_TMP_ListLength_+=1 + Goto LinearList_LSS_SLL_GetLength_Loop + ) + Set /A ErrorLevel=_LinearList_LSS_SLL_GetLength_TMP_ListLength_ + Set _LinearList_LSS_SLL_GetLength_TMP_ListLength_= + Set _LinearList_LSS_SLL_GetLength_TMP_Next_Node_Ptr_= + Goto :Eof + + :LinearList_LSS_SLL_IsEmpty ListName + :LinearList_LSS_SLL_GetNextNodePtr NodePtr + Set /A _LinearList_LSS_SLL_GetNextNodePtr_TMP_NodePtr_=%~1 + Set /A ErrorLevel=Memory[!_LinearList_LSS_SLL_GetNextNodePtr_TMP_NodePtr_!].Next + Set _LinearList_LSS_SLL_GetNextNodePtr_TMP_NodePtr_= + Goto :Eof + + :LinearList_LSS_SLL_InsertNextNode NodePtr VarToInsert + Set /A _LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_=%~1 + Set /A _LinearList_LSS_SLL_InsertNextNode_TMP_NextNodePtr_=Memory[!_LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_!].Next + Call :LinearList_LSS_SLL_GetRandom + Set /A Memory[!_LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_!].Next=ErrorLevel + Set /A Memory[!ErrorLevel!].Next=_LinearList_LSS_SLL_InsertNextNode_TMP_NextNodePtr_ + Set "Memory[!ErrorLevel!].Data=!%~2!" + Set _LinearList_LSS_SLL_InsertNextNode_TMP_NextNodePtr_= + Set _LinearList_LSS_SLL_InsertNextNode_TMP_NodePtr_= + Goto :Eof + + :LinearList_LSS_SLL_DeleteNextNode NodePtr [VarToSaveNextNodeElemValue] + Set /A _LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_=%~1 + Set /A _LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_=Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_!].Next + If !_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_! Equ 0 ( + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_= + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_= + Set /A ErrorLevel=1 + Goto :Eof + ) + Set /A Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_!].Next=Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Next + If "%~2" Neq "" Call Set "%~2=%%Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Data%%" + Set Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Next= + Set Memory[!_LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_!].Data= + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_Next_Node_Ptr_= + Set _LinearList_LSS_SLL_DeleteNextNode_TMP_NodePtr_= + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_GetNodeElem NodePtr VarToSaveElemValue + Set /A LinearList_LSS_SLL_GetNodeElem_TMP_NodePtr_=%~1 + Call Set "%~2=%%Memory[!LinearList_LSS_SLL_GetNodeElem_TMP_NodePtr_!].Data%%" + Set LinearList_LSS_SLL_GetNodeElem_TMP_NodePtr_= + Set /A ErrorLevel=0 + Goto :Eof + + :LinearList_LSS_SLL_EditNodeElem NodePtr VarToReplaceElemValue + Set /A LinearList_LSS_SLL_EditNodeElem_TMP_NodePtr_=%~1 + Set "Memory[!LinearList_LSS_SLL_EditNodeElem_TMP_NodePtr_!].Data=!%~2!" + Set LinearList_LSS_SLL_EditNodeElem_TMP_NodePtr_= + Set /A ErrorLevel=0 + Goto :Eof +::LinearList_LSS_SLL End \ No newline at end of file diff --git a/impls/batch/reader.bat b/impls/batch/reader.bat new file mode 100644 index 0000000000..66c092f7e3 --- /dev/null +++ b/impls/batch/reader.bat @@ -0,0 +1,216 @@ +Set "List=call "%~dp0LinearList_LSS_SLL.bat"" +Set "Queue=call "%~dp0Queue_LSS.bat"" +Set "Stack=call "%~dp0Stack_LSS.bat"" + +::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 str + call :tokenize "%~1" + call :read_form "!re!" +goto :eof + +:tokenize str + !Queue! :Init tokens + set "str=%~1" + :tokenizing + if "!str:~,1!" == " " ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "str=!str:~1!" + goto tokenizing + ) else if "!str:~,1!" == " " ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "str=!str:~1!" + goto tokenizing + ) else if "!str:~,1!" == "," ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "str=!str:~1!" + goto tokenizing + ) else if "!str:~,2!" == "~@" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set tmp=~@ + set "str=!str:~2!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == "[" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=[" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == "]" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=]" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == "(" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=(" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == ")" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=)" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == "{" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp={" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == "}" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=}" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == "'" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp='" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == "`" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=`" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == "~" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=~" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == "@" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=@" + set "str=!str:~1!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,9!" == "#$Caret$#" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=#$Caret$#" + set "str=!str:~9!" + !Queue! :Enqueue tokens tmp + ) else if "!str:~,20!" == "#$Double_Quotation$#" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "tmp=#$Double_Quotation$#" + set "str=!str:~20!" + :string_read + if not "!str:~,20!" == "#$Double_Quotation$#" ( + set "tmp=!tmp!!str:~,1!" + set "str=!str:~1!" + goto string_read + ) else ( + set "tmp=!tmp!!str:~,20!" + set "str=!str:~20!" + if "!tmp:~-21,1!" == "\" ( + goto string_read + ) + ) + !Queue! :Enqueue tokens tmp + ) else if "!str:~,1!" == ";" ( + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + !Queue! :Enqueue tokens str + set "str=" + ) else if defined str ( + set "normal=!normal!!str:~,1!" + set "str=!str:~1!" + goto tokenizing + ) + if defined normal ( + !Queue! :Enqueue tokens normal + set normal= + ) + set "re=!tokens!" +goto :eof + +:read_form tokens_queue + !List! :Init GrammarTree + !Stack! :Init VariableBackup + set "tokens_queue=%~1" + :read_form_loop + !Queue! :IsEmpty tokens_queue + if not "!ErrorLevel!" == "0" ( + !Queue! :Peep tokens_queue token + if "!token!" == "(" ( + call :read_list "!tokens_queue!" + ) else ( + call :read_atom "!tokens_queue!" + ) + goto read_form_loop + ) +goto :eof + +:read_list tokens_queue + set "tokens_queue=%~1" + !Queue! :Dequeue tokens_queue token + :read_list_loop + !Queue! :IsEmpty tokens_queue + if not "!ErrorLevel!" == "0" ( + !Queue! :Peep tokens_queue token + if "!token!" == ")" ( + !Queue! :Dequeue tokens_queue token + ) else ( + call :read_form "!tokens_queue!" + goto read_list_loop + ) + ) +goto :eof + +:read_atom tokens_queue + set "tokens_queue=%~1" + !Queue! :Dequeue tokens_queue token + +goto :eof diff --git a/impls/batch/step0_repl.bat b/impls/batch/step0_repl.bat new file mode 100644 index 0000000000..fe195fb1d1 --- /dev/null +++ b/impls/batch/step0_repl.bat @@ -0,0 +1,106 @@ +@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:"=#$Double_Quotation$#%" + rem Batch can't deal with "!" when delayed expansion is enabled, so replace it to a special string. + call set "input=%%input:!=#$Exclamation$#%%" + setlocal ENABLEDELAYEDEXPANSION + %improve speed start% ( + rem Batch has some problem in "^" processing, so replace it. + set "input=!input:^=#$Caret$#!" + rem replace %. + set input_formated= + :replacement_loop + if defined input ( + if "!input:~,1!" == "%%" ( + set "input_formated=!input_formated!#$Percent$#" + ) else ( + set "input_formated=!input_formated!!input:~,1!" + ) + set "input=!input:~1!" + goto replacement_loop + ) + 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 "tokens=* eol=" %%a in ("!re!") do ( + endlocal + set "re=%%~a" + ) + goto :eof + + :EVAL + setlocal + set "re=%~1" + for /f "tokens=* eol=" %%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:~,15!" == "#$Exclamation$#" ( + set "output_buffer=!output_buffer!^!" + set "output=!output:~15!" + goto output_loop + ) else if "!output:~,9!" == "#$Caret$#" ( + set "output_buffer=!output_buffer!^^" + set "output=!output:~9!" + goto output_loop + ) else if "!output:~,20!" == "#$Double_Quotation$#" ( + set "output_buffer=!output_buffer!^"" + set "output=!output:~20!" + 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:~,11!" == "#$Percent$#" ( + set "output_buffer=!output_buffer!%%" + set "output=!output:~11!" + 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 "tokens=* eol=" %%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/batch/step1_read_print.bat b/impls/batch/step1_read_print.bat new file mode 100644 index 0000000000..fe195fb1d1 --- /dev/null +++ b/impls/batch/step1_read_print.bat @@ -0,0 +1,106 @@ +@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:"=#$Double_Quotation$#%" + rem Batch can't deal with "!" when delayed expansion is enabled, so replace it to a special string. + call set "input=%%input:!=#$Exclamation$#%%" + setlocal ENABLEDELAYEDEXPANSION + %improve speed start% ( + rem Batch has some problem in "^" processing, so replace it. + set "input=!input:^=#$Caret$#!" + rem replace %. + set input_formated= + :replacement_loop + if defined input ( + if "!input:~,1!" == "%%" ( + set "input_formated=!input_formated!#$Percent$#" + ) else ( + set "input_formated=!input_formated!!input:~,1!" + ) + set "input=!input:~1!" + goto replacement_loop + ) + 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 "tokens=* eol=" %%a in ("!re!") do ( + endlocal + set "re=%%~a" + ) + goto :eof + + :EVAL + setlocal + set "re=%~1" + for /f "tokens=* eol=" %%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:~,15!" == "#$Exclamation$#" ( + set "output_buffer=!output_buffer!^!" + set "output=!output:~15!" + goto output_loop + ) else if "!output:~,9!" == "#$Caret$#" ( + set "output_buffer=!output_buffer!^^" + set "output=!output:~9!" + goto output_loop + ) else if "!output:~,20!" == "#$Double_Quotation$#" ( + set "output_buffer=!output_buffer!^"" + set "output=!output:~20!" + 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:~,11!" == "#$Percent$#" ( + set "output_buffer=!output_buffer!%%" + set "output=!output:~11!" + 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 "tokens=* eol=" %%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/bbc-basic/Dockerfile b/impls/bbc-basic/Dockerfile index 32af593a86..9c4e36fc59 100644 --- a/impls/bbc-basic/Dockerfile +++ b/impls/bbc-basic/Dockerfile @@ -1,31 +1,31 @@ -FROM ubuntu:18.04 - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# These may be necessary for some base Ubuntu containers. -# RUN sed 's/^deb/deb-src/' \ -# < /etc/apt/sources.list > /etc/apt/sources.list.d/deb-src.list -# RUN apt-get update - -RUN apt-get build-dep -y brandy -RUN cd /tmp && apt-get source brandy && cd brandy-* && \ - make -f makefile.text && cp sbrandy /usr/bin/sbrandy && \ - cd /tmp && rm -rf brandy* +FROM ubuntu:18.04 + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# These may be necessary for some base Ubuntu containers. +# RUN sed 's/^deb/deb-src/' \ +# < /etc/apt/sources.list > /etc/apt/sources.list.d/deb-src.list +# RUN apt-get update + +RUN apt-get build-dep -y brandy +RUN cd /tmp && apt-get source brandy && cd brandy-* && \ + make -f makefile.text && cp sbrandy /usr/bin/sbrandy && \ + cd /tmp && rm -rf brandy* diff --git a/impls/bbc-basic/Makefile b/impls/bbc-basic/Makefile index 16aee59775..354e1ddb22 100644 --- a/impls/bbc-basic/Makefile +++ b/impls/bbc-basic/Makefile @@ -1,5 +1,5 @@ -all: - -.PHONY: clean - -clean: +all: + +.PHONY: clean + +clean: diff --git a/impls/bbc-basic/README.md b/impls/bbc-basic/README.md index 5a7cafc960..b54f853640 100644 --- a/impls/bbc-basic/README.md +++ b/impls/bbc-basic/README.md @@ -1,93 +1,93 @@ -# Introduction - -This is an implementation of mal in BBC BASIC V. While there -is already an implementation of mal in BASIC (in the "basic" -directory), it's targeted at much more primitive versions of BASIC and -relies on a pre-processor, both of which make it fairly un-idiomatic -as a BBC BASIC V program. - -BBC BASIC V is the version of BBC BASIC supplied with Acorn's -ARM-based computers from the mid-1980s. It has substantial -enhancements from the 6502-based versions of BBC BASIC, which were -themselves at the advanced end of 8-bit BASICs. Mal uses many of the -advanced features of BBC BASIC V and porting it to older versions -would be difficult. - -Mal is intended to run on all versions of BBC BASIC V and BBC BASIC -VI, as well as on Brandy 1.20.1. For compatibility with Brandy, it -avoids operating system calls where possible. The only exception -is that is has separate mechanisms for reading command-line arguments -under Brandy and RISC OS. - -# Running under Unix - -On Unix systems, this mal implementation can run on the Brandy -interpreter. The tests require the "simple text" build, but mal will -work interactively in graphical builds as well. You can invoke mal -like this: - -``` -cd bbc-basic -brandy stepA_mal.bbc -``` - -# Running under RISC OS - -To run mal under RISC OS, you obviously need to get the files onto -your RISC OS system, and you also need to arrange to tokenize the -BASIC source files. There are scripts to do the latter in the -`riscos` directory, but they do require that the mal source tree be -available under RISC OS without its filenames' being truncated, which -may restrict with filing systems can be used. The HostFS supplied -with ArcEm works fine. - -Once you have the files in RISC OS, you can set things up by running: - -``` -*Dir bbc-basic.riscos -*Run setup -``` - -Then you can invoke the interpreter directly: - -``` -*Run stepA_mal -``` - -At present, there's no filename translation in the `slurp` function, -so many of the example mal programs will fail because they can't load -`core.mal`. - -# Interesting features - -This appears to be the first mal implementation that uses an table-driven -deterministic finite automoton (a state machine) to implement its -tokenizer. - -The mal heap is represented as a large array of fixed-size objects. -Lists and vectors are linked lists of these objects, while hash-maps -are crit-bit trees. - -Mal exceptions are implemented as BBC BASIC errors. Errors generated -by mal are numbered from &40E80900. - -## Assigned error numbers - -No.| Description ----|------------ -&00| Native mal error generated by 'throw' -&1x| Object not of type 'x' -&1F| Miscellaneous type mismatch -&20| Invalid operation on empty list -&21| Wrong number of arguments to function -&22| Undefined symbol -&23| Subscript out of range -&24| Invalid 'catch*' clause -&30| Unexpected end of input -&31| Unexpected ')' -&32| Hash-map key mush be a string -&40| File not found -&50| Out of memory -&Fx| Internal errors (indicating a bug in mal) -&F0| Unprintable value -&F1| Call to non-existent core function +# Introduction + +This is an implementation of mal in BBC BASIC V. While there +is already an implementation of mal in BASIC (in the "basic" +directory), it's targeted at much more primitive versions of BASIC and +relies on a pre-processor, both of which make it fairly un-idiomatic +as a BBC BASIC V program. + +BBC BASIC V is the version of BBC BASIC supplied with Acorn's +ARM-based computers from the mid-1980s. It has substantial +enhancements from the 6502-based versions of BBC BASIC, which were +themselves at the advanced end of 8-bit BASICs. Mal uses many of the +advanced features of BBC BASIC V and porting it to older versions +would be difficult. + +Mal is intended to run on all versions of BBC BASIC V and BBC BASIC +VI, as well as on Brandy 1.20.1. For compatibility with Brandy, it +avoids operating system calls where possible. The only exception +is that is has separate mechanisms for reading command-line arguments +under Brandy and RISC OS. + +# Running under Unix + +On Unix systems, this mal implementation can run on the Brandy +interpreter. The tests require the "simple text" build, but mal will +work interactively in graphical builds as well. You can invoke mal +like this: + +``` +cd bbc-basic +brandy stepA_mal.bbc +``` + +# Running under RISC OS + +To run mal under RISC OS, you obviously need to get the files onto +your RISC OS system, and you also need to arrange to tokenize the +BASIC source files. There are scripts to do the latter in the +`riscos` directory, but they do require that the mal source tree be +available under RISC OS without its filenames' being truncated, which +may restrict with filing systems can be used. The HostFS supplied +with ArcEm works fine. + +Once you have the files in RISC OS, you can set things up by running: + +``` +*Dir bbc-basic.riscos +*Run setup +``` + +Then you can invoke the interpreter directly: + +``` +*Run stepA_mal +``` + +At present, there's no filename translation in the `slurp` function, +so many of the example mal programs will fail because they can't load +`core.mal`. + +# Interesting features + +This appears to be the first mal implementation that uses an table-driven +deterministic finite automoton (a state machine) to implement its +tokenizer. + +The mal heap is represented as a large array of fixed-size objects. +Lists and vectors are linked lists of these objects, while hash-maps +are crit-bit trees. + +Mal exceptions are implemented as BBC BASIC errors. Errors generated +by mal are numbered from &40E80900. + +## Assigned error numbers + +No.| Description +---|------------ +&00| Native mal error generated by 'throw' +&1x| Object not of type 'x' +&1F| Miscellaneous type mismatch +&20| Invalid operation on empty list +&21| Wrong number of arguments to function +&22| Undefined symbol +&23| Subscript out of range +&24| Invalid 'catch*' clause +&30| Unexpected end of input +&31| Unexpected ')' +&32| Hash-map key mush be a string +&40| File not found +&50| Out of memory +&Fx| Internal errors (indicating a bug in mal) +&F0| Unprintable value +&F1| Call to non-existent core function diff --git a/impls/bbc-basic/core.bas b/impls/bbc-basic/core.bas index 37cdbc2a93..4d2a88fc21 100644 --- a/impls/bbc-basic/core.bas +++ b/impls/bbc-basic/core.bas @@ -1,495 +1,495 @@ -REM > core function library for mal in BBC BASIC - -REM BBC BASIC doesn't have function pointers. There are essentially -REM two ways to work around this. One is to use the BASIC EVAL function, -REM constructing a string that will call an arbitrary function with the -REM specified arguments. The other is to us a big CASE statement. -REM Following the suggestion in Hints.md, this code takes the latter -REM approach. - -DEF PROCcore_ns - RESTORE +0 - REM The actual DATA statements are embedded in the dispatch table below. -ENDPROC - -REM Call a core function, taking the function number and a mal list of -REM objects to pass as arguments. -DEF FNcore_call(fn%, args%) - LOCAL args%(), arg$ - DIM args%(1) - CASE fn% OF - DATA +, 0 - WHEN 0 - PROCcore_prepare_args("ii", "+") - =FNalloc_int(args%(0) + args%(1)) - DATA -, 1 - WHEN 1 - PROCcore_prepare_args("ii", "-") - =FNalloc_int(args%(0) - args%(1)) - DATA *, 2 - WHEN 2 - PROCcore_prepare_args("ii", "*") - =FNalloc_int(args%(0) * args%(1)) - DATA /, 3 - WHEN 3 - PROCcore_prepare_args("ii", "/") - =FNalloc_int(args%(0) DIV args%(1)) - DATA list, 5 - WHEN 5 - =FNas_list(args%) - DATA list?, 6 - WHEN 6 - PROCcore_prepare_args("?", "list?") - =FNalloc_boolean(FNis_list(args%(0))) - DATA empty?, 7 - WHEN 7 - PROCcore_prepare_args("l", "empty?") - =FNalloc_boolean(FNis_empty(args%(0))) - DATA count, 8 - WHEN 8 - PROCcore_prepare_args("C", "count") - IF FNis_nil(args%(0)) THEN =FNalloc_int(0) - =FNalloc_int(FNcount(args%(0))) - DATA =, 9 - WHEN 9 - PROCcore_prepare_args("??", "=") - =FNalloc_boolean(FNcore_equal(args%(0), args%(1))) - DATA <, 10 - WHEN 10 - PROCcore_prepare_args("ii", "<") - =FNalloc_boolean(args%(0) < args%(1)) - DATA <=, 11 - WHEN 11 - PROCcore_prepare_args("ii", "<=") - =FNalloc_boolean(args%(0) <= args%(1)) - DATA >, 12 - WHEN 12 - PROCcore_prepare_args("ii", ">") - =FNalloc_boolean(args%(0) > args%(1)) - DATA >=, 13 - WHEN 13 - PROCcore_prepare_args("ii", ">=") - =FNalloc_boolean(args%(0) >= args%(1)) - DATA read-string, 14 - WHEN 14 - PROCcore_prepare_args("t", "read-string") - =FNread_str(args%(0)) - DATA slurp, 15 - WHEN 15 - PROCcore_prepare_args("s", "slurp") - =FNcore_slurp(arg$) - DATA eval, 16 - WHEN 16 - PROCcore_prepare_args("?", "eval") - =FNEVAL(args%(0), repl_env%) - DATA pr-str, 17 - WHEN 17 - =FNcore_print(TRUE, " ", args%) - DATA str, 18 - WHEN 18 - =FNcore_print(FALSE, "", args%) - DATA prn, 4 - WHEN 4 - PRINT FNunbox_string(FNcore_print(TRUE, " ", args%)) - =FNnil - DATA println, 19 - WHEN 19 - PRINT FNunbox_string(FNcore_print(FALSE, " ", args%)) - =FNnil - DATA atom, 20 - WHEN 20 - PROCcore_prepare_args("?", "atom") - =FNalloc_atom(args%(0)) - DATA atom?, 21 - WHEN 21 - PROCcore_prepare_args("?", "atom?") - =FNalloc_boolean(FNis_atom(args%(0))) - DATA deref, 22 - WHEN 22 - PROCcore_prepare_args("a", "deref") - =FNatom_deref(args%(0)) - DATA reset!, 23 - WHEN 23 - PROCcore_prepare_args("a?", "reset!") - PROCatom_reset(args%(0), args%(1)) - =args%(1) - DATA swap!, 24 - WHEN 24 - PROCcore_prepare_args("af*", "swap!") - PROCatom_reset(args%(0), FNcore_apply(args%(1), FNalloc_pair(FNatom_deref(args%(0)), args%))) - =FNatom_deref(args%(0)) - DATA cons, 25 - WHEN 25 - PROCcore_prepare_args("?l", "cons") - =FNalloc_pair(args%(0), args%(1)) - DATA concat, 26 - WHEN 26 - =FNcore_concat(args%) - DATA nth, 27 - WHEN 27 - PROCcore_prepare_args("li", "nth") - =FNnth(args%(0), args%(1)) - DATA first, 28 - WHEN 28 - PROCcore_prepare_args("C", "first") - IF FNis_nil(args%(0)) THEN =FNnil - =FNfirst(args%(0)) - DATA rest, 29 - WHEN 29 - PROCcore_prepare_args("C", "rest") - IF FNis_nil(args%(0)) THEN =FNempty - =FNas_list(FNrest(args%(0))) - DATA throw, 30 - WHEN 30 - PROCcore_prepare_args("?", "throw") - MAL_ERR% = args%(0) - ERROR &40E80900, "Mal exception: " + FNunbox_string(FNpr_str(args%(0), FALSE)) - DATA apply, 31 - WHEN 31 - PROCcore_prepare_args("f?*", "apply") - =FNcore_apply(args%(0), FNcore_apply_args(FNalloc_pair(args%(1), args%))) - DATA map, 32 - WHEN 32 - PROCcore_prepare_args("fl", "map") - =FNcore_map(args%(0), args%(1)) - DATA nil?, 33 - WHEN 33 - PROCcore_prepare_args("?", "nil?") - =FNalloc_boolean(FNis_nil(args%(0))) - DATA true?, 34 - WHEN 34 - PROCcore_prepare_args("?", "true?") - IF NOT FNis_boolean(args%(0)) THEN =FNalloc_boolean(FALSE) - =args%(0) - DATA false?, 35 - WHEN 35 - PROCcore_prepare_args("?", "false?") - IF NOT FNis_boolean(args%(0)) THEN =FNalloc_boolean(FALSE) - =FNalloc_boolean(NOT FNunbox_boolean(args%(0))) - DATA symbol?, 36 - WHEN 36 - PROCcore_prepare_args("?", "symbol?") - =FNalloc_boolean(FNis_symbol(args%(0))) - DATA symbol, 37 - WHEN 37 - PROCcore_prepare_args("s", "symbol") - =FNalloc_symbol(arg$) - DATA keyword, 38 - WHEN 38 - PROCcore_prepare_args("s", "keyword") - IF LEFT$(arg$, 1) <> CHR$(127) THEN arg$ = CHR$(127) + arg$ - =FNalloc_string(arg$) - DATA keyword?, 39 - WHEN 39 - PROCcore_prepare_args("?", "keyword?") - IF FNis_string(args%(0)) THEN - =FNalloc_boolean(LEFT$(FNunbox_string(args%(0)), 1) = CHR$(127)) - ENDIF - =FNalloc_boolean(FALSE) - DATA vector, 40 - WHEN 40 - =FNas_vector(args%) - DATA vector?, 41 - WHEN 41 - PROCcore_prepare_args("?", "vector?") - =FNalloc_boolean(FNis_vector(args%(0))) - DATA sequential?, 42 - WHEN 42 - PROCcore_prepare_args("?", "sequential?") - =FNalloc_boolean(FNis_seq(args%(0))) - DATA hash-map, 43 - WHEN 43 - =FNcore_assoc(FNempty_hashmap, args%) - DATA map?, 44 - WHEN 44 - PROCcore_prepare_args("?", "map?") - =FNalloc_boolean(FNis_hashmap(args%(0))) - DATA assoc, 45 - WHEN 45 - PROCcore_prepare_args("h*", "assoc") - =FNcore_assoc(args%(0), args%) - DATA dissoc, 46 - WHEN 46 - PROCcore_prepare_args("h*", "dissoc") - WHILE NOT FNis_empty(args%) - args%(0) = FNhashmap_remove(args%(0), FNunbox_string(FNfirst(args%))) - args% = FNrest(args%) - ENDWHILE - =args%(0) - DATA get, 47 - WHEN 47 - IF FNis_nil(FNfirst(args%)) THEN =FNnil - PROCcore_prepare_args("hs", "get") - =FNhashmap_get(args%(0), arg$) - DATA contains?, 48 - WHEN 48 - PROCcore_prepare_args("hs", "contains?") - =FNalloc_boolean(FNhashmap_contains(args%(0), arg$)) - DATA keys, 49 - WHEN 49 - PROCcore_prepare_args("h", "keys") - =FNhashmap_keys(args%(0)) - DATA vals, 50 - WHEN 50 - PROCcore_prepare_args("h", "vals") - =FNhashmap_vals(args%(0)) - DATA readline, 51 - WHEN 51 - PROCcore_prepare_args("s", "readline") - PRINT arg$; - LINE INPUT "" arg$ - =FNalloc_string(arg$) - DATA meta, 52 - WHEN 52 - PROCcore_prepare_args("?", "meta") - =FNmeta(args%(0)) - DATA with-meta, 53 - WHEN 53 - PROCcore_prepare_args("??", "with-meta") - =FNwith_meta(args%(0), args%(1)) - DATA time-ms, 54 - WHEN 54 - PROCcore_prepare_args("", "time-ms") - =FNalloc_int(TIME * 10) - DATA conj, 55 - WHEN 55 - PROCcore_prepare_args("l*", "conj") - IF FNis_list(args%(0)) THEN - WHILE NOT FNis_empty(args%) - args%(0) = FNalloc_pair(FNfirst(args%), args%(0)) - args% = FNrest(args%) - ENDWHILE - =args%(0) - ELSE : REM args%(0) is a vector - =FNas_vector(FNcore_concat1(args%(0), args%)) - ENDIF - DATA string?, 56 - WHEN 56 - PROCcore_prepare_args("?", "string?") - IF FNis_string(args%(0)) THEN - =FNalloc_boolean(LEFT$(FNunbox_string(args%(0)), 1) <> CHR$(127)) - ENDIF - =FNalloc_boolean(FALSE) - DATA number?, 57 - WHEN 57 - PROCcore_prepare_args("?", "number?") - =FNalloc_boolean(FNis_int(args%(0))) - DATA fn?, 58 - WHEN 58 - PROCcore_prepare_args("?", "fn?") - =FNalloc_boolean(FNis_nonmacro_fn(args%(0)) OR FNis_corefn(args%(0))) - DATA macro?, 59 - WHEN 59 - PROCcore_prepare_args("?", "macro?") - =FNalloc_boolean(FNis_macro(args%(0))) - DATA seq, 60 - WHEN 60 - PROCcore_prepare_args("?", "seq") - =FNcore_seq(args%(0)) - DATA vec, 61 - WHEN 61 - PROCcore_prepare_args("l", "vec") - =FNas_vector(args%(0)) - DATA "", -1 - ENDCASE -ERROR &40E809F1, "Call to non-existent core function" - -DEF PROCcore_prepare_args(spec$, fn$) - REM Check that a core function is being provided with the correct - REM number and type of arguments and unbox them as appropriate. - REM spec$ is the argument specification as a string. Each character - REM represents an argument: - - REM "i" - Must be an integer; unbox into args%() - REM "s" - Must be a string; unbox into arg$ - REM "t" - Must be a string; stuff into args%() - REM "l" - Must be a sequence; stuff into args%() - REM "f" - Must be a function; stuff into args%() - REM "a" - Must be an atom; stuff into args%() - REM "h" - Must be a hash-map; stuff into args%() - REM "C" - Must be 'count'able stuff into args%() - REM "?" - Any single argument stuff into args%() - REM "*" - Any number of (trailing) arguments; leave in args% - - REM This function shares some local variables with FNcore_call. - - LOCAL i%, val% - - IF RIGHT$(spec$) = "*" THEN - spec$ = LEFT$(spec$) - IF FNcount(args%) < LEN(spec$) THEN - ERROR &40E80921, "Core function '"+fn$+"' requires at least "+STR$(LEN(spec$))+" arguments" - ENDIF - ELSE - IF FNcount(args%) <> LEN(spec$) THEN - ERROR &40E80921, "Core function '"+fn$+"' requires "+STR$(LEN(spec$))+" arguments" - ENDIF - ENDIF - FOR i% = 1 TO LEN(spec$) - val% = FNfirst(args%) - CASE MID$(spec$, i%, 1) OF - WHEN "i" - IF NOT FNis_int(val%) THEN - ERROR &40E80911, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be an integer" - ENDIF - args%(i% - 1) = FNunbox_int(val%) - WHEN "s" - IF NOT FNis_string(val%) THEN - ERROR &40E80914, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a string" - ENDIF - arg$ = FNunbox_string(val%) - WHEN "t" - IF NOT FNis_string(val%) THEN - ERROR &40E80914, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a string" - ENDIF - args%(i% - 1) = val% - WHEN "l" - IF NOT FNis_seq(val%) THEN - ERROR &40E80916, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a sequence" - ENDIF - args%(i% - 1) = val% - WHEN "f" - IF NOT FNis_fn(val%) AND NOT FNis_corefn(val%) THEN - ERROR &40E80919, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a function" - ENDIF - args%(i% - 1) = val% - WHEN "a" - IF NOT FNis_atom(val%) THEN - ERROR &40E8091C, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be an atom" - ENDIF - args%(i% - 1) = val% - WHEN "h" - IF NOT FNis_hashmap(val%) THEN - ERROR &40E8091D, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a hash-map" - ENDIF - args%(i% - 1) = val% - WHEN "C" - IF NOT FNis_seq(val%) AND NOT FNis_nil(val%) THEN - ERROR &40E8091F, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a countable value" - ENDIF - args%(i% - 1) = val% - WHEN "?" - args%(i% - 1) = val% - ENDCASE - args% = FNrest(args%) - NEXT i% -ENDPROC - -REM Innards of the '=' function. -DEF FNcore_equal(a%, b%) - IF a% = b% THEN =TRUE - IF FNis_int(a%) AND FNis_int(b%) THEN =FNunbox_int(a%) = FNunbox_int(b%) - IF FNis_symbol(a%) AND FNis_symbol(b%) THEN - =FNunbox_symbol(a%) = FNunbox_symbol(b%) - ENDIF - IF FNis_string(a%) AND FNis_string(b%) THEN - =FNunbox_string(a%) = FNunbox_string(b%) - ENDIF - IF FNis_seq(a%) AND FNis_seq(b%) THEN - IF FNis_empty(a%) AND FNis_empty(b%) THEN =TRUE - IF FNis_empty(a%) <> FNis_empty(b%) THEN =FALSE - IF NOT FNcore_equal(FNfirst(a%), FNfirst(b%)) THEN =FALSE - =FNcore_equal(FNrest(a%), FNrest(b%)) - ENDIF - IF FNis_hashmap(a%) AND FNis_hashmap(b%) THEN - REM Take advantage of the sorted keys in our hash-maps. - IF FNcore_equal(FNhashmap_keys(a%), FNhashmap_keys(b%)) THEN - IF FNcore_equal(FNhashmap_vals(a%), FNhashmap_vals(b%)) THEN =TRUE - ENDIF - ENDIF -=FALSE - -REM Innards of the 'slurp' function. -DEF FNcore_slurp(file$) - LOCAL f%, out% - f% = OPENIN(file$) - IF f% = 0 THEN ERROR &40E80940, "File '"+file$+"' not found" - out% = FNcore_slurp_channel(f%) - CLOSE#f% -=out% - -DEF FNcore_slurp_channel(f%) - LOCAL this% - IF EOF#f% THEN =FNalloc_string("") - REM GET$# doesn't include a trailing newline. - this% = FNalloc_string(GET$#f% + CHR$(10)) -=FNstring_concat(this%, FNcore_slurp_channel(f%)) - -REM General-purpose printing function -DEF FNcore_print(print_readably%, sep$, args%) - LOCAL out% - IF FNis_empty(args%) THEN =FNalloc_string("") - out% = FNpr_str(FNfirst(args%), print_readably%) - args% = FNrest(args%) - WHILE NOT FNis_empty(args%) - out% = FNstring_append(out%, sep$) - out% = FNstring_concat(out%, FNpr_str(FNfirst(args%), print_readably%)) - args% = FNrest(args%) - ENDWHILE -=out% - -REM Innards of the 'apply' function, also used by 'swap!' -DEF FNcore_apply(fn%, args%) - LOCAL ast%, env% - IF FNis_corefn(fn%) THEN =FNcore_call(FNunbox_corefn(fn%), args%) - IF FNis_fn(fn%) THEN - ast% = FNfn_ast(fn%) - env% = FNnew_env(FNfn_env(fn%), FNfn_params(fn%), args%) - =FNEVAL(ast%, env%) - ENDIF -ERROR &40E80918, "Not a function" - -REM Innards of 'concat' function -DEF FNcore_concat(args%) - LOCAL tail% - IF FNis_empty(args%) THEN =FNempty - tail% = FNcore_concat(FNrest(args%)) -=FNcore_concat1(FNfirst(args%), tail%) - -DEF FNcore_concat1(prefix%, tail%) - IF FNis_empty(prefix%) THEN =tail% -=FNalloc_pair(FNfirst(prefix%), FNcore_concat1(FNrest(prefix%), tail%)) - -REM Recursively assemble the argument list for 'apply' -DEF FNcore_apply_args(args%) - IF FNis_empty(FNrest(args%)) THEN =FNfirst(args%) -=FNalloc_pair(FNfirst(args%), FNcore_apply_args(FNrest(args%))) - -REM Innards of the 'map' function -DEF FNcore_map(fn%, args%) - LOCAL car%, cdr% - IF FNis_empty(args%) THEN =args% - car% = FNcore_apply(fn%, FNalloc_pair(FNfirst(args%), FNempty)) - cdr% = FNcore_map(fn%, FNrest(args%)) -=FNalloc_pair(car%, cdr%) - -REM Innards of the 'hash-map' function -DEF FNcore_assoc(map%, args%) - LOCAL args%() - DIM args%(1) - WHILE NOT FNis_empty(args%) - PROCcore_prepare_args("s?*", "hash-map") - map% = FNhashmap_set(map%, arg$, args%(1)) - ENDWHILE -=map% - -REM Innards of the 'seq' function -DEF FNcore_seq(val%) - LOCAL s$, i% - IF FNis_empty(val%) OR FNis_nil(val%) THEN =FNnil - IF FNis_list(val%) THEN =val% - IF FNis_vector(val%) THEN =FNas_list(val%) - IF FNis_string(val%) THEN - s$ = FNunbox_string(val%) - IF s$ = "" THEN =FNnil - val% = FNempty - FOR i% = LEN(s$) TO 1 STEP -1 - val% = FNalloc_pair(FNalloc_string(MID$(s$, i%, 1)), val%) - NEXT i% - =val% - ENDIF -ERROR &40E8091F, "Argument to 'seq' must be list, vector, string, or nil" - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM > core function library for mal in BBC BASIC + +REM BBC BASIC doesn't have function pointers. There are essentially +REM two ways to work around this. One is to use the BASIC EVAL function, +REM constructing a string that will call an arbitrary function with the +REM specified arguments. The other is to us a big CASE statement. +REM Following the suggestion in Hints.md, this code takes the latter +REM approach. + +DEF PROCcore_ns + RESTORE +0 + REM The actual DATA statements are embedded in the dispatch table below. +ENDPROC + +REM Call a core function, taking the function number and a mal list of +REM objects to pass as arguments. +DEF FNcore_call(fn%, args%) + LOCAL args%(), arg$ + DIM args%(1) + CASE fn% OF + DATA +, 0 + WHEN 0 + PROCcore_prepare_args("ii", "+") + =FNalloc_int(args%(0) + args%(1)) + DATA -, 1 + WHEN 1 + PROCcore_prepare_args("ii", "-") + =FNalloc_int(args%(0) - args%(1)) + DATA *, 2 + WHEN 2 + PROCcore_prepare_args("ii", "*") + =FNalloc_int(args%(0) * args%(1)) + DATA /, 3 + WHEN 3 + PROCcore_prepare_args("ii", "/") + =FNalloc_int(args%(0) DIV args%(1)) + DATA list, 5 + WHEN 5 + =FNas_list(args%) + DATA list?, 6 + WHEN 6 + PROCcore_prepare_args("?", "list?") + =FNalloc_boolean(FNis_list(args%(0))) + DATA empty?, 7 + WHEN 7 + PROCcore_prepare_args("l", "empty?") + =FNalloc_boolean(FNis_empty(args%(0))) + DATA count, 8 + WHEN 8 + PROCcore_prepare_args("C", "count") + IF FNis_nil(args%(0)) THEN =FNalloc_int(0) + =FNalloc_int(FNcount(args%(0))) + DATA =, 9 + WHEN 9 + PROCcore_prepare_args("??", "=") + =FNalloc_boolean(FNcore_equal(args%(0), args%(1))) + DATA <, 10 + WHEN 10 + PROCcore_prepare_args("ii", "<") + =FNalloc_boolean(args%(0) < args%(1)) + DATA <=, 11 + WHEN 11 + PROCcore_prepare_args("ii", "<=") + =FNalloc_boolean(args%(0) <= args%(1)) + DATA >, 12 + WHEN 12 + PROCcore_prepare_args("ii", ">") + =FNalloc_boolean(args%(0) > args%(1)) + DATA >=, 13 + WHEN 13 + PROCcore_prepare_args("ii", ">=") + =FNalloc_boolean(args%(0) >= args%(1)) + DATA read-string, 14 + WHEN 14 + PROCcore_prepare_args("t", "read-string") + =FNread_str(args%(0)) + DATA slurp, 15 + WHEN 15 + PROCcore_prepare_args("s", "slurp") + =FNcore_slurp(arg$) + DATA eval, 16 + WHEN 16 + PROCcore_prepare_args("?", "eval") + =FNEVAL(args%(0), repl_env%) + DATA pr-str, 17 + WHEN 17 + =FNcore_print(TRUE, " ", args%) + DATA str, 18 + WHEN 18 + =FNcore_print(FALSE, "", args%) + DATA prn, 4 + WHEN 4 + PRINT FNunbox_string(FNcore_print(TRUE, " ", args%)) + =FNnil + DATA println, 19 + WHEN 19 + PRINT FNunbox_string(FNcore_print(FALSE, " ", args%)) + =FNnil + DATA atom, 20 + WHEN 20 + PROCcore_prepare_args("?", "atom") + =FNalloc_atom(args%(0)) + DATA atom?, 21 + WHEN 21 + PROCcore_prepare_args("?", "atom?") + =FNalloc_boolean(FNis_atom(args%(0))) + DATA deref, 22 + WHEN 22 + PROCcore_prepare_args("a", "deref") + =FNatom_deref(args%(0)) + DATA reset!, 23 + WHEN 23 + PROCcore_prepare_args("a?", "reset!") + PROCatom_reset(args%(0), args%(1)) + =args%(1) + DATA swap!, 24 + WHEN 24 + PROCcore_prepare_args("af*", "swap!") + PROCatom_reset(args%(0), FNcore_apply(args%(1), FNalloc_pair(FNatom_deref(args%(0)), args%))) + =FNatom_deref(args%(0)) + DATA cons, 25 + WHEN 25 + PROCcore_prepare_args("?l", "cons") + =FNalloc_pair(args%(0), args%(1)) + DATA concat, 26 + WHEN 26 + =FNcore_concat(args%) + DATA nth, 27 + WHEN 27 + PROCcore_prepare_args("li", "nth") + =FNnth(args%(0), args%(1)) + DATA first, 28 + WHEN 28 + PROCcore_prepare_args("C", "first") + IF FNis_nil(args%(0)) THEN =FNnil + =FNfirst(args%(0)) + DATA rest, 29 + WHEN 29 + PROCcore_prepare_args("C", "rest") + IF FNis_nil(args%(0)) THEN =FNempty + =FNas_list(FNrest(args%(0))) + DATA throw, 30 + WHEN 30 + PROCcore_prepare_args("?", "throw") + MAL_ERR% = args%(0) + ERROR &40E80900, "Mal exception: " + FNunbox_string(FNpr_str(args%(0), FALSE)) + DATA apply, 31 + WHEN 31 + PROCcore_prepare_args("f?*", "apply") + =FNcore_apply(args%(0), FNcore_apply_args(FNalloc_pair(args%(1), args%))) + DATA map, 32 + WHEN 32 + PROCcore_prepare_args("fl", "map") + =FNcore_map(args%(0), args%(1)) + DATA nil?, 33 + WHEN 33 + PROCcore_prepare_args("?", "nil?") + =FNalloc_boolean(FNis_nil(args%(0))) + DATA true?, 34 + WHEN 34 + PROCcore_prepare_args("?", "true?") + IF NOT FNis_boolean(args%(0)) THEN =FNalloc_boolean(FALSE) + =args%(0) + DATA false?, 35 + WHEN 35 + PROCcore_prepare_args("?", "false?") + IF NOT FNis_boolean(args%(0)) THEN =FNalloc_boolean(FALSE) + =FNalloc_boolean(NOT FNunbox_boolean(args%(0))) + DATA symbol?, 36 + WHEN 36 + PROCcore_prepare_args("?", "symbol?") + =FNalloc_boolean(FNis_symbol(args%(0))) + DATA symbol, 37 + WHEN 37 + PROCcore_prepare_args("s", "symbol") + =FNalloc_symbol(arg$) + DATA keyword, 38 + WHEN 38 + PROCcore_prepare_args("s", "keyword") + IF LEFT$(arg$, 1) <> CHR$(127) THEN arg$ = CHR$(127) + arg$ + =FNalloc_string(arg$) + DATA keyword?, 39 + WHEN 39 + PROCcore_prepare_args("?", "keyword?") + IF FNis_string(args%(0)) THEN + =FNalloc_boolean(LEFT$(FNunbox_string(args%(0)), 1) = CHR$(127)) + ENDIF + =FNalloc_boolean(FALSE) + DATA vector, 40 + WHEN 40 + =FNas_vector(args%) + DATA vector?, 41 + WHEN 41 + PROCcore_prepare_args("?", "vector?") + =FNalloc_boolean(FNis_vector(args%(0))) + DATA sequential?, 42 + WHEN 42 + PROCcore_prepare_args("?", "sequential?") + =FNalloc_boolean(FNis_seq(args%(0))) + DATA hash-map, 43 + WHEN 43 + =FNcore_assoc(FNempty_hashmap, args%) + DATA map?, 44 + WHEN 44 + PROCcore_prepare_args("?", "map?") + =FNalloc_boolean(FNis_hashmap(args%(0))) + DATA assoc, 45 + WHEN 45 + PROCcore_prepare_args("h*", "assoc") + =FNcore_assoc(args%(0), args%) + DATA dissoc, 46 + WHEN 46 + PROCcore_prepare_args("h*", "dissoc") + WHILE NOT FNis_empty(args%) + args%(0) = FNhashmap_remove(args%(0), FNunbox_string(FNfirst(args%))) + args% = FNrest(args%) + ENDWHILE + =args%(0) + DATA get, 47 + WHEN 47 + IF FNis_nil(FNfirst(args%)) THEN =FNnil + PROCcore_prepare_args("hs", "get") + =FNhashmap_get(args%(0), arg$) + DATA contains?, 48 + WHEN 48 + PROCcore_prepare_args("hs", "contains?") + =FNalloc_boolean(FNhashmap_contains(args%(0), arg$)) + DATA keys, 49 + WHEN 49 + PROCcore_prepare_args("h", "keys") + =FNhashmap_keys(args%(0)) + DATA vals, 50 + WHEN 50 + PROCcore_prepare_args("h", "vals") + =FNhashmap_vals(args%(0)) + DATA readline, 51 + WHEN 51 + PROCcore_prepare_args("s", "readline") + PRINT arg$; + LINE INPUT "" arg$ + =FNalloc_string(arg$) + DATA meta, 52 + WHEN 52 + PROCcore_prepare_args("?", "meta") + =FNmeta(args%(0)) + DATA with-meta, 53 + WHEN 53 + PROCcore_prepare_args("??", "with-meta") + =FNwith_meta(args%(0), args%(1)) + DATA time-ms, 54 + WHEN 54 + PROCcore_prepare_args("", "time-ms") + =FNalloc_int(TIME * 10) + DATA conj, 55 + WHEN 55 + PROCcore_prepare_args("l*", "conj") + IF FNis_list(args%(0)) THEN + WHILE NOT FNis_empty(args%) + args%(0) = FNalloc_pair(FNfirst(args%), args%(0)) + args% = FNrest(args%) + ENDWHILE + =args%(0) + ELSE : REM args%(0) is a vector + =FNas_vector(FNcore_concat1(args%(0), args%)) + ENDIF + DATA string?, 56 + WHEN 56 + PROCcore_prepare_args("?", "string?") + IF FNis_string(args%(0)) THEN + =FNalloc_boolean(LEFT$(FNunbox_string(args%(0)), 1) <> CHR$(127)) + ENDIF + =FNalloc_boolean(FALSE) + DATA number?, 57 + WHEN 57 + PROCcore_prepare_args("?", "number?") + =FNalloc_boolean(FNis_int(args%(0))) + DATA fn?, 58 + WHEN 58 + PROCcore_prepare_args("?", "fn?") + =FNalloc_boolean(FNis_nonmacro_fn(args%(0)) OR FNis_corefn(args%(0))) + DATA macro?, 59 + WHEN 59 + PROCcore_prepare_args("?", "macro?") + =FNalloc_boolean(FNis_macro(args%(0))) + DATA seq, 60 + WHEN 60 + PROCcore_prepare_args("?", "seq") + =FNcore_seq(args%(0)) + DATA vec, 61 + WHEN 61 + PROCcore_prepare_args("l", "vec") + =FNas_vector(args%(0)) + DATA "", -1 + ENDCASE +ERROR &40E809F1, "Call to non-existent core function" + +DEF PROCcore_prepare_args(spec$, fn$) + REM Check that a core function is being provided with the correct + REM number and type of arguments and unbox them as appropriate. + REM spec$ is the argument specification as a string. Each character + REM represents an argument: + + REM "i" - Must be an integer; unbox into args%() + REM "s" - Must be a string; unbox into arg$ + REM "t" - Must be a string; stuff into args%() + REM "l" - Must be a sequence; stuff into args%() + REM "f" - Must be a function; stuff into args%() + REM "a" - Must be an atom; stuff into args%() + REM "h" - Must be a hash-map; stuff into args%() + REM "C" - Must be 'count'able stuff into args%() + REM "?" - Any single argument stuff into args%() + REM "*" - Any number of (trailing) arguments; leave in args% + + REM This function shares some local variables with FNcore_call. + + LOCAL i%, val% + + IF RIGHT$(spec$) = "*" THEN + spec$ = LEFT$(spec$) + IF FNcount(args%) < LEN(spec$) THEN + ERROR &40E80921, "Core function '"+fn$+"' requires at least "+STR$(LEN(spec$))+" arguments" + ENDIF + ELSE + IF FNcount(args%) <> LEN(spec$) THEN + ERROR &40E80921, "Core function '"+fn$+"' requires "+STR$(LEN(spec$))+" arguments" + ENDIF + ENDIF + FOR i% = 1 TO LEN(spec$) + val% = FNfirst(args%) + CASE MID$(spec$, i%, 1) OF + WHEN "i" + IF NOT FNis_int(val%) THEN + ERROR &40E80911, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be an integer" + ENDIF + args%(i% - 1) = FNunbox_int(val%) + WHEN "s" + IF NOT FNis_string(val%) THEN + ERROR &40E80914, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a string" + ENDIF + arg$ = FNunbox_string(val%) + WHEN "t" + IF NOT FNis_string(val%) THEN + ERROR &40E80914, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a string" + ENDIF + args%(i% - 1) = val% + WHEN "l" + IF NOT FNis_seq(val%) THEN + ERROR &40E80916, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a sequence" + ENDIF + args%(i% - 1) = val% + WHEN "f" + IF NOT FNis_fn(val%) AND NOT FNis_corefn(val%) THEN + ERROR &40E80919, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a function" + ENDIF + args%(i% - 1) = val% + WHEN "a" + IF NOT FNis_atom(val%) THEN + ERROR &40E8091C, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be an atom" + ENDIF + args%(i% - 1) = val% + WHEN "h" + IF NOT FNis_hashmap(val%) THEN + ERROR &40E8091D, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a hash-map" + ENDIF + args%(i% - 1) = val% + WHEN "C" + IF NOT FNis_seq(val%) AND NOT FNis_nil(val%) THEN + ERROR &40E8091F, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a countable value" + ENDIF + args%(i% - 1) = val% + WHEN "?" + args%(i% - 1) = val% + ENDCASE + args% = FNrest(args%) + NEXT i% +ENDPROC + +REM Innards of the '=' function. +DEF FNcore_equal(a%, b%) + IF a% = b% THEN =TRUE + IF FNis_int(a%) AND FNis_int(b%) THEN =FNunbox_int(a%) = FNunbox_int(b%) + IF FNis_symbol(a%) AND FNis_symbol(b%) THEN + =FNunbox_symbol(a%) = FNunbox_symbol(b%) + ENDIF + IF FNis_string(a%) AND FNis_string(b%) THEN + =FNunbox_string(a%) = FNunbox_string(b%) + ENDIF + IF FNis_seq(a%) AND FNis_seq(b%) THEN + IF FNis_empty(a%) AND FNis_empty(b%) THEN =TRUE + IF FNis_empty(a%) <> FNis_empty(b%) THEN =FALSE + IF NOT FNcore_equal(FNfirst(a%), FNfirst(b%)) THEN =FALSE + =FNcore_equal(FNrest(a%), FNrest(b%)) + ENDIF + IF FNis_hashmap(a%) AND FNis_hashmap(b%) THEN + REM Take advantage of the sorted keys in our hash-maps. + IF FNcore_equal(FNhashmap_keys(a%), FNhashmap_keys(b%)) THEN + IF FNcore_equal(FNhashmap_vals(a%), FNhashmap_vals(b%)) THEN =TRUE + ENDIF + ENDIF +=FALSE + +REM Innards of the 'slurp' function. +DEF FNcore_slurp(file$) + LOCAL f%, out% + f% = OPENIN(file$) + IF f% = 0 THEN ERROR &40E80940, "File '"+file$+"' not found" + out% = FNcore_slurp_channel(f%) + CLOSE#f% +=out% + +DEF FNcore_slurp_channel(f%) + LOCAL this% + IF EOF#f% THEN =FNalloc_string("") + REM GET$# doesn't include a trailing newline. + this% = FNalloc_string(GET$#f% + CHR$(10)) +=FNstring_concat(this%, FNcore_slurp_channel(f%)) + +REM General-purpose printing function +DEF FNcore_print(print_readably%, sep$, args%) + LOCAL out% + IF FNis_empty(args%) THEN =FNalloc_string("") + out% = FNpr_str(FNfirst(args%), print_readably%) + args% = FNrest(args%) + WHILE NOT FNis_empty(args%) + out% = FNstring_append(out%, sep$) + out% = FNstring_concat(out%, FNpr_str(FNfirst(args%), print_readably%)) + args% = FNrest(args%) + ENDWHILE +=out% + +REM Innards of the 'apply' function, also used by 'swap!' +DEF FNcore_apply(fn%, args%) + LOCAL ast%, env% + IF FNis_corefn(fn%) THEN =FNcore_call(FNunbox_corefn(fn%), args%) + IF FNis_fn(fn%) THEN + ast% = FNfn_ast(fn%) + env% = FNnew_env(FNfn_env(fn%), FNfn_params(fn%), args%) + =FNEVAL(ast%, env%) + ENDIF +ERROR &40E80918, "Not a function" + +REM Innards of 'concat' function +DEF FNcore_concat(args%) + LOCAL tail% + IF FNis_empty(args%) THEN =FNempty + tail% = FNcore_concat(FNrest(args%)) +=FNcore_concat1(FNfirst(args%), tail%) + +DEF FNcore_concat1(prefix%, tail%) + IF FNis_empty(prefix%) THEN =tail% +=FNalloc_pair(FNfirst(prefix%), FNcore_concat1(FNrest(prefix%), tail%)) + +REM Recursively assemble the argument list for 'apply' +DEF FNcore_apply_args(args%) + IF FNis_empty(FNrest(args%)) THEN =FNfirst(args%) +=FNalloc_pair(FNfirst(args%), FNcore_apply_args(FNrest(args%))) + +REM Innards of the 'map' function +DEF FNcore_map(fn%, args%) + LOCAL car%, cdr% + IF FNis_empty(args%) THEN =args% + car% = FNcore_apply(fn%, FNalloc_pair(FNfirst(args%), FNempty)) + cdr% = FNcore_map(fn%, FNrest(args%)) +=FNalloc_pair(car%, cdr%) + +REM Innards of the 'hash-map' function +DEF FNcore_assoc(map%, args%) + LOCAL args%() + DIM args%(1) + WHILE NOT FNis_empty(args%) + PROCcore_prepare_args("s?*", "hash-map") + map% = FNhashmap_set(map%, arg$, args%(1)) + ENDWHILE +=map% + +REM Innards of the 'seq' function +DEF FNcore_seq(val%) + LOCAL s$, i% + IF FNis_empty(val%) OR FNis_nil(val%) THEN =FNnil + IF FNis_list(val%) THEN =val% + IF FNis_vector(val%) THEN =FNas_list(val%) + IF FNis_string(val%) THEN + s$ = FNunbox_string(val%) + IF s$ = "" THEN =FNnil + val% = FNempty + FOR i% = LEN(s$) TO 1 STEP -1 + val% = FNalloc_pair(FNalloc_string(MID$(s$, i%, 1)), val%) + NEXT i% + =val% + ENDIF +ERROR &40E8091F, "Argument to 'seq' must be list, vector, string, or nil" + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/env.bas b/impls/bbc-basic/env.bas index c588a2f491..f6f0bbf4c2 100644 --- a/impls/bbc-basic/env.bas +++ b/impls/bbc-basic/env.bas @@ -1,42 +1,42 @@ -REM > env library for mal in BBC BASIC - -DEF FNnew_env(outer%, binds%, exprs%) - LOCAL env% - env% = FNalloc_environment(outer%) - WHILE NOT FNis_empty(binds%) - IF FNunbox_symbol(FNfirst(binds%)) = "&" THEN - PROCenv_set(env%, FNnth(binds%, 1), FNas_list(exprs%)) - binds% = FNempty - ELSE - PROCenv_set(env%, FNfirst(binds%), FNfirst(exprs%)) - binds% = FNrest(binds%) : exprs% = FNrest(exprs%) - ENDIF - ENDWHILE -=env% - -DEF PROCenv_set(env%, keysym%, val%) - LOCAL data% - data% = FNenvironment_data(env%) - data% = FNhashmap_set(data%, FNunbox_symbol(keysym%), val%) - PROCenvironment_set_data(env%, data%) -ENDPROC - -DEF FNenv_find(env%, keysym%) - LOCAL val%, outer%, key$ - key$ = FNunbox_symbol(keysym%) - WHILE NOT FNis_nil(env%) - IF FNhashmap_contains(FNenvironment_data(env%), key$) THEN =env% - env% = FNenvironment_outer(env%) - ENDWHILE -=FNnil - -DEF FNenv_get(env%, keysym%) - LOCAL key$ - env% = FNenv_find(env%, keysym%) - key$ = FNunbox_symbol(keysym%) - IF FNis_nil(env%) THEN ERROR &40E80922, "'"+key$+"' not found" -=FNhashmap_get(FNenvironment_data(env%), key$) - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM > env library for mal in BBC BASIC + +DEF FNnew_env(outer%, binds%, exprs%) + LOCAL env% + env% = FNalloc_environment(outer%) + WHILE NOT FNis_empty(binds%) + IF FNunbox_symbol(FNfirst(binds%)) = "&" THEN + PROCenv_set(env%, FNnth(binds%, 1), FNas_list(exprs%)) + binds% = FNempty + ELSE + PROCenv_set(env%, FNfirst(binds%), FNfirst(exprs%)) + binds% = FNrest(binds%) : exprs% = FNrest(exprs%) + ENDIF + ENDWHILE +=env% + +DEF PROCenv_set(env%, keysym%, val%) + LOCAL data% + data% = FNenvironment_data(env%) + data% = FNhashmap_set(data%, FNunbox_symbol(keysym%), val%) + PROCenvironment_set_data(env%, data%) +ENDPROC + +DEF FNenv_find(env%, keysym%) + LOCAL val%, outer%, key$ + key$ = FNunbox_symbol(keysym%) + WHILE NOT FNis_nil(env%) + IF FNhashmap_contains(FNenvironment_data(env%), key$) THEN =env% + env% = FNenvironment_outer(env%) + ENDWHILE +=FNnil + +DEF FNenv_get(env%, keysym%) + LOCAL key$ + env% = FNenv_find(env%, keysym%) + key$ = FNunbox_symbol(keysym%) + IF FNis_nil(env%) THEN ERROR &40E80922, "'"+key$+"' not found" +=FNhashmap_get(FNenvironment_data(env%), key$) + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/printer.bas b/impls/bbc-basic/printer.bas index 15f1aa8c1c..8ddac2ced2 100644 --- a/impls/bbc-basic/printer.bas +++ b/impls/bbc-basic/printer.bas @@ -1,66 +1,66 @@ -REM > printer library for mal in BBC BASIC - -DEF FNpr_str(val%, print_readably%) - LOCAL ret%, term$, val$, keys%, vals% - IF FNis_nil(val%) THEN =FNalloc_string("nil") - IF FNis_boolean(val%) THEN - IF FNunbox_boolean(val%) THEN =FNalloc_string("true") - =FNalloc_string("false") - ENDIF - IF FNis_int(val%) THEN =FNalloc_string(STR$(FNunbox_int(val%))) - IF FNis_string(val%) THEN - IF FNstring_chr(val%, 1) = CHR$(127) THEN =FNalloc_string(":" + MID$(FNunbox_string(val%), 2)) - IF print_readably% THEN =FNalloc_string(FNformat_string(FNunbox_string(val%))) ELSE =val% - ENDIF - IF FNis_symbol(val%) THEN =FNalloc_string(FNunbox_symbol(val%)) - IF FNis_corefn(val%) OR FNis_fn(val%) THEN =FNalloc_string("#") - IF FNis_seq(val%) THEN - IF FNis_vector(val%) THEN - ret% = FNalloc_string("[") : term$ = "]" - ELSE - ret% = FNalloc_string("(") : term$ = ")" - ENDIF - WHILE NOT FNis_empty(val%) - IF FNstring_len(ret%) > 1 THEN ret% = FNstring_append(ret%, " ") - ret% = FNstring_concat(ret%, FNpr_str(FNfirst(val%), print_readably%)) - val% = FNrest(val%) - ENDWHILE - =FNstring_append(ret%, term$) - ENDIF - IF FNis_hashmap(val%) THEN - ret% = FNalloc_string("{") - keys% = FNhashmap_keys(val%) - vals% = FNhashmap_vals(val%) - WHILE NOT FNis_empty(keys%) - IF FNstring_len(ret%) > 1 THEN ret% = FNstring_append(ret%, " ") - ret% = FNstring_concat(ret%, FNpr_str(FNfirst(keys%), print_readably%)) - ret% = FNstring_append(ret%, " ") - ret% = FNstring_concat(ret%, FNpr_str(FNfirst(vals%), print_readably%)) - keys% = FNrest(keys%) - vals% = FNrest(vals%) - ENDWHILE - =FNstring_append(ret%, "}") - ENDIF - IF FNis_atom(val%) THEN - ret% = FNalloc_string("(atom ") - ret% = FNstring_concat(ret%, FNpr_str(FNatom_deref(val%), print_readably%)) - =FNstring_append(ret%, ")") - ENDIF - ERROR &40E809F0, "Unprintable value" - -DEF FNformat_string(strval$) - LOCAL ptr%, c$, out$ - IF strval$ = "" THEN ="""""" - FOR ptr% = 1 TO LEN(strval$) - c$ = MID$(strval$, ptr%, 1) - CASE c$ OF - WHEN "\", """": out$ += "\" + c$ - WHEN CHR$(10): out$ += "\n" - OTHERWISE: out$ += c$ - ENDCASE - NEXT ptr% -="""" + out$ + """" - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM > printer library for mal in BBC BASIC + +DEF FNpr_str(val%, print_readably%) + LOCAL ret%, term$, val$, keys%, vals% + IF FNis_nil(val%) THEN =FNalloc_string("nil") + IF FNis_boolean(val%) THEN + IF FNunbox_boolean(val%) THEN =FNalloc_string("true") + =FNalloc_string("false") + ENDIF + IF FNis_int(val%) THEN =FNalloc_string(STR$(FNunbox_int(val%))) + IF FNis_string(val%) THEN + IF FNstring_chr(val%, 1) = CHR$(127) THEN =FNalloc_string(":" + MID$(FNunbox_string(val%), 2)) + IF print_readably% THEN =FNalloc_string(FNformat_string(FNunbox_string(val%))) ELSE =val% + ENDIF + IF FNis_symbol(val%) THEN =FNalloc_string(FNunbox_symbol(val%)) + IF FNis_corefn(val%) OR FNis_fn(val%) THEN =FNalloc_string("#") + IF FNis_seq(val%) THEN + IF FNis_vector(val%) THEN + ret% = FNalloc_string("[") : term$ = "]" + ELSE + ret% = FNalloc_string("(") : term$ = ")" + ENDIF + WHILE NOT FNis_empty(val%) + IF FNstring_len(ret%) > 1 THEN ret% = FNstring_append(ret%, " ") + ret% = FNstring_concat(ret%, FNpr_str(FNfirst(val%), print_readably%)) + val% = FNrest(val%) + ENDWHILE + =FNstring_append(ret%, term$) + ENDIF + IF FNis_hashmap(val%) THEN + ret% = FNalloc_string("{") + keys% = FNhashmap_keys(val%) + vals% = FNhashmap_vals(val%) + WHILE NOT FNis_empty(keys%) + IF FNstring_len(ret%) > 1 THEN ret% = FNstring_append(ret%, " ") + ret% = FNstring_concat(ret%, FNpr_str(FNfirst(keys%), print_readably%)) + ret% = FNstring_append(ret%, " ") + ret% = FNstring_concat(ret%, FNpr_str(FNfirst(vals%), print_readably%)) + keys% = FNrest(keys%) + vals% = FNrest(vals%) + ENDWHILE + =FNstring_append(ret%, "}") + ENDIF + IF FNis_atom(val%) THEN + ret% = FNalloc_string("(atom ") + ret% = FNstring_concat(ret%, FNpr_str(FNatom_deref(val%), print_readably%)) + =FNstring_append(ret%, ")") + ENDIF + ERROR &40E809F0, "Unprintable value" + +DEF FNformat_string(strval$) + LOCAL ptr%, c$, out$ + IF strval$ = "" THEN ="""""" + FOR ptr% = 1 TO LEN(strval$) + c$ = MID$(strval$, ptr%, 1) + CASE c$ OF + WHEN "\", """": out$ += "\" + c$ + WHEN CHR$(10): out$ += "\n" + OTHERWISE: out$ += c$ + ENDCASE + NEXT ptr% +="""" + out$ + """" + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/reader.bas b/impls/bbc-basic/reader.bas index 18e736d69f..9ea3aaab6f 100644 --- a/impls/bbc-basic/reader.bas +++ b/impls/bbc-basic/reader.bas @@ -1,198 +1,198 @@ -REM > reader library for mal in BBC BASIC - -REM ** Reader ** - -REM The Reader object is implemented as an array and a mutable pointer. - -DEF FNreader_peek(tokens$(), RETURN tokptr%) -=tokens$(tokptr%) - -DEF FNreader_next(token$(), RETURN tokptr%) - tokptr% += 1 -=tokens$(tokptr% - 1) - -DEF FNread_str(src%) - LOCAL ntokens%, tokptr%, tokens$() - DIM tokens$(2048) - ntokens% = FNtokenize(src%, tokens$()) - tokptr% = 0 -=FNread_form(tokens$(), tokptr%) - -REM ** Tokenizer ** - -DEF FNtokenize(src%, tokens$()) - REM The tokenizer is implemented explicitly as a deterministic - REM finite automaton. - LOCAL p%, state%, tok$, tokptr%, c$, rc$, match$, action% - LOCAL DATA - - state% = 1 - tokptr% = 0 - tok$ = "" - FOR p% = 1 TO FNstring_len(src%) - c$ = FNstring_chr(src%, p%) - rc$ = c$ - REM Convert some characters to ones that are easier to put into - REM DATA statements. These substitutions are only used for - REM matching: the token still contains the original character. - CASE ASC(c$) OF - REM Fold some upper-case letters together so that we can re-use - REM them to represent more awkward characters. - WHEN 78, 81: c$ = "A" - REM Now convert newlines into "N" - WHEN 10: c$ = "N" - REM These are the other characters that Perl's "\s" escape matches. - WHEN 9, 11, 12, 13: c$ = " " - REM Brandy has a bug whereby it doesn't correctly parse strings - REM in DATA statements that begin with quotation marks, so convert - REM quotation marks to "Q". - WHEN 34: c$ = "Q" - ENDCASE - REM The state table consists of a DATA statement for each current - REM state, which triples representing transitions. Each triple - REM consists of a string of characters to match, an action, and a - REM next state. A matching string of "" matches any character, - REM and hence marks the end of a state. - - REM Actions are: - REM 0: Add this character to the current token - REM 1: Emit token; start a new token with this character - REM 5: Emit token; skip this character - - RESTORE +state% - REM state 1: Initial state, or inside a bare word - DATA " N,",5,1, "~",1,5, "[]{}()'`^@",1,3, Q,1,7, ";",5,11, "",0,1 - REM state 3: Just seen the end of a token - DATA " N,",5,1, "~",1,5, "[]{}()'`^@",1,3, Q,1,7, ";",5,11, "",1,1 - REM state 5: Just seen a "~" - DATA " N,",5,1, "@",0,3, "~",1,5, "[]{}()'`^@",1,3, Q,1,7, ";",5,11, "",1,1 - REM state 7: Inside a quoted string - DATA "\",0,9, Q,0,3, "",0,7 - REM state 9: After a backslash in a string - DATA "",0,7 - REM state 11: Inside a comment - DATA N,5,3, "",5,11 - - REM Find a matching transition from the current state. - REM PRINT ;state%;"-->"; - REPEAT - READ match$, action%, state% - REM PRINT "[";match$;"](";action%;",";state%;")"; - UNTIL match$ = "" OR INSTR(match$, c$) > 0 - REM PRINT ;"-->";state% - - REM Execute any actions. - IF action% AND 1 AND tokens$(tokptr%) <> "" THEN tokptr% += 1 - IF (action% AND 4) = 0 THEN tokens$(tokptr%) += rc$ - NEXT p% - IF tokens$(tokptr%) <> "" THEN tokptr% += 1 -=tokptr% - -REM ** More Reader ** - -DEF FNread_form(tokens$(), RETURN tokptr%) - LOCAL tok$, x% - tok$ = FNreader_peek(tokens$(), tokptr%) - CASE tok$ OF - WHEN "" : ERROR &40E80930, "Unexpected end of input" - WHEN "(": =FNread_list(tokens$(), tokptr%) - WHEN "[": =FNread_vector(tokens$(), tokptr%) - WHEN "{": =FNread_hashmap(tokens$(), tokptr%) - WHEN ")", "]", "}": ERROR &40E80931, "Unexpected '"+tok$ +"'" - WHEN "'": =FNreader_macro("quote", tokens$(), tokptr%) - WHEN "`": =FNreader_macro("quasiquote", tokens$(), tokptr%) - WHEN "~": =FNreader_macro("unquote", tokens$(), tokptr%) - WHEN "~@":=FNreader_macro("splice-unquote", tokens$(), tokptr%) - WHEN "@": =FNreader_macro("deref", tokens$(), tokptr%) - WHEN "^": =FNread_with_meta(tokens$(), tokptr%) - ENDCASE -=FNread_atom(tokens$(), tokptr%) - -DEF FNread_list(tokens$(), RETURN tokptr%) - LOCAL tok$ - tok$ = FNreader_next(tokens$(), tokptr%) : REM skip over "(" -=FNread_list_tail(tokens$(), tokptr%, ")") - -DEF FNread_vector(tokens$(), RETURN tokptr%) - LOCAL tok$ - tok$ = FNreader_next(tokens$(), tokptr%) : REM skip over "[" -=FNas_vector(FNread_list_tail(tokens$(), tokptr%, "]")) - -DEF FNread_list_tail(tokens$(), RETURN tokptr%, term$) - LOCAL tok$, car%, cdr% - IF FNreader_peek(tokens$(), tokptr%) = term$ THEN - tok$ = FNreader_next(tokens$(), tokptr%) - =FNempty - ENDIF - car% = FNread_form(tokens$(), tokptr%) - cdr% = FNread_list_tail(tokens$(), tokptr%, term$) -=FNalloc_pair(car%, cdr%) - -DEF FNread_hashmap(tokens$(), RETURN tokptr%) - LOCAL tok$, map%, key%, val% - tok$ = FNreader_next(tokens$(), tokptr%) : REM skip over "{" - map% = FNempty_hashmap - WHILE FNreader_peek(tokens$(), tokptr%) <> "}" - key% = FNread_form(tokens$(), tokptr%) - IF NOT FNis_string(key%) ERROR &40E80932, "Hash-map key must be a string" - val% = FNread_form(tokens$(), tokptr%) - map% = FNhashmap_set(map%, FNunbox_string(key%), val%) - ENDWHILE - tok$ = FNreader_next(tokens$(), tokptr%) : REM skip over "}" -=map% - -DEF FNreader_macro(quote$, token$(), RETURN tokptr%) - LOCAL tok$ - tok$ = FNreader_next(tokens$(), tokptr%) : REM skip quoting token -=FNalloc_list2(FNalloc_symbol(quote$), FNread_form(tokens$(), tokptr%)) - -DEF FNread_with_meta(token$(), RETURN tokptr%) - LOCAL tok$, wm%, base%, meta% - tok$ = FNreader_next(tokens$(), tokptr%) : REM skip '^' token - wm% = FNalloc_symbol("with-meta") - meta% = FNread_form(tokens$(), tokptr%) - base% = FNread_form(tokens$(), tokptr%) -=FNalloc_list3(wm%, base%, meta%) - -DEF FNis_token_numeric(tok$) - LOCAL i%, c% - IF LEFT$(tok$, 1) = "-" THEN tok$ = MID$(tok$, 2) - IF LEN(tok$) = 0 THEN =FALSE - FOR i% = 1 TO LEN(tok$) - c% = ASC(MID$(tok$, i%, 1)) - IF c% < &30 OR c% > &39 THEN =FALSE - NEXT i% -=TRUE - -DEF FNread_atom(tokens$(), RETURN tokptr%) - LOCAL strval$ - strval$ = FNreader_next(tokens$(), tokptr%) - IF strval$ = "nil" THEN =FNnil - IF strval$ = "true" THEN =FNalloc_boolean(TRUE) - IF strval$ = "false" THEN =FNalloc_boolean(FALSE) - IF LEFT$(strval$, 1) = """" THEN =FNalloc_string(FNunquote_string(strval$)) - IF LEFT$(strval$, 1) = ":" THEN =FNalloc_string(CHR$(127) + MID$(strval$, 2)) - IF FNis_token_numeric(strval$) THEN =FNalloc_int(VAL(strval$)) -=FNalloc_symbol(strval$) - -DEF FNunquote_string(strval$) - LOCAL inptr%, bs%, out$, c$ - IF RIGHT$(strval$, 1) <> """" THEN ERROR &40E80930, "Unexpected end of input" - inptr% = 2 - REPEAT - bs% = INSTR(strval$, "\", inptr%) - IF bs% > 0 THEN - out$ += MID$(strval$, inptr%, bs% - inptr%) - c$ = MID$(strval$, bs% + 1, 1) - IF c$ = "n" THEN c$ = CHR$(10) - out$ += c$ - inptr% = bs% + 2 - ENDIF - UNTIL bs% = 0 - IF inptr% = LEN(strval$) + 1 THEN ERROR &40E80930, "Unexpected end of input" - out$ += MID$(strval$, inptr%, LEN(strval$) - inptr%) -=out$ - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM > reader library for mal in BBC BASIC + +REM ** Reader ** + +REM The Reader object is implemented as an array and a mutable pointer. + +DEF FNreader_peek(tokens$(), RETURN tokptr%) +=tokens$(tokptr%) + +DEF FNreader_next(token$(), RETURN tokptr%) + tokptr% += 1 +=tokens$(tokptr% - 1) + +DEF FNread_str(src%) + LOCAL ntokens%, tokptr%, tokens$() + DIM tokens$(2048) + ntokens% = FNtokenize(src%, tokens$()) + tokptr% = 0 +=FNread_form(tokens$(), tokptr%) + +REM ** Tokenizer ** + +DEF FNtokenize(src%, tokens$()) + REM The tokenizer is implemented explicitly as a deterministic + REM finite automaton. + LOCAL p%, state%, tok$, tokptr%, c$, rc$, match$, action% + LOCAL DATA + + state% = 1 + tokptr% = 0 + tok$ = "" + FOR p% = 1 TO FNstring_len(src%) + c$ = FNstring_chr(src%, p%) + rc$ = c$ + REM Convert some characters to ones that are easier to put into + REM DATA statements. These substitutions are only used for + REM matching: the token still contains the original character. + CASE ASC(c$) OF + REM Fold some upper-case letters together so that we can re-use + REM them to represent more awkward characters. + WHEN 78, 81: c$ = "A" + REM Now convert newlines into "N" + WHEN 10: c$ = "N" + REM These are the other characters that Perl's "\s" escape matches. + WHEN 9, 11, 12, 13: c$ = " " + REM Brandy has a bug whereby it doesn't correctly parse strings + REM in DATA statements that begin with quotation marks, so convert + REM quotation marks to "Q". + WHEN 34: c$ = "Q" + ENDCASE + REM The state table consists of a DATA statement for each current + REM state, which triples representing transitions. Each triple + REM consists of a string of characters to match, an action, and a + REM next state. A matching string of "" matches any character, + REM and hence marks the end of a state. + + REM Actions are: + REM 0: Add this character to the current token + REM 1: Emit token; start a new token with this character + REM 5: Emit token; skip this character + + RESTORE +state% + REM state 1: Initial state, or inside a bare word + DATA " N,",5,1, "~",1,5, "[]{}()'`^@",1,3, Q,1,7, ";",5,11, "",0,1 + REM state 3: Just seen the end of a token + DATA " N,",5,1, "~",1,5, "[]{}()'`^@",1,3, Q,1,7, ";",5,11, "",1,1 + REM state 5: Just seen a "~" + DATA " N,",5,1, "@",0,3, "~",1,5, "[]{}()'`^@",1,3, Q,1,7, ";",5,11, "",1,1 + REM state 7: Inside a quoted string + DATA "\",0,9, Q,0,3, "",0,7 + REM state 9: After a backslash in a string + DATA "",0,7 + REM state 11: Inside a comment + DATA N,5,3, "",5,11 + + REM Find a matching transition from the current state. + REM PRINT ;state%;"-->"; + REPEAT + READ match$, action%, state% + REM PRINT "[";match$;"](";action%;",";state%;")"; + UNTIL match$ = "" OR INSTR(match$, c$) > 0 + REM PRINT ;"-->";state% + + REM Execute any actions. + IF action% AND 1 AND tokens$(tokptr%) <> "" THEN tokptr% += 1 + IF (action% AND 4) = 0 THEN tokens$(tokptr%) += rc$ + NEXT p% + IF tokens$(tokptr%) <> "" THEN tokptr% += 1 +=tokptr% + +REM ** More Reader ** + +DEF FNread_form(tokens$(), RETURN tokptr%) + LOCAL tok$, x% + tok$ = FNreader_peek(tokens$(), tokptr%) + CASE tok$ OF + WHEN "" : ERROR &40E80930, "Unexpected end of input" + WHEN "(": =FNread_list(tokens$(), tokptr%) + WHEN "[": =FNread_vector(tokens$(), tokptr%) + WHEN "{": =FNread_hashmap(tokens$(), tokptr%) + WHEN ")", "]", "}": ERROR &40E80931, "Unexpected '"+tok$ +"'" + WHEN "'": =FNreader_macro("quote", tokens$(), tokptr%) + WHEN "`": =FNreader_macro("quasiquote", tokens$(), tokptr%) + WHEN "~": =FNreader_macro("unquote", tokens$(), tokptr%) + WHEN "~@":=FNreader_macro("splice-unquote", tokens$(), tokptr%) + WHEN "@": =FNreader_macro("deref", tokens$(), tokptr%) + WHEN "^": =FNread_with_meta(tokens$(), tokptr%) + ENDCASE +=FNread_atom(tokens$(), tokptr%) + +DEF FNread_list(tokens$(), RETURN tokptr%) + LOCAL tok$ + tok$ = FNreader_next(tokens$(), tokptr%) : REM skip over "(" +=FNread_list_tail(tokens$(), tokptr%, ")") + +DEF FNread_vector(tokens$(), RETURN tokptr%) + LOCAL tok$ + tok$ = FNreader_next(tokens$(), tokptr%) : REM skip over "[" +=FNas_vector(FNread_list_tail(tokens$(), tokptr%, "]")) + +DEF FNread_list_tail(tokens$(), RETURN tokptr%, term$) + LOCAL tok$, car%, cdr% + IF FNreader_peek(tokens$(), tokptr%) = term$ THEN + tok$ = FNreader_next(tokens$(), tokptr%) + =FNempty + ENDIF + car% = FNread_form(tokens$(), tokptr%) + cdr% = FNread_list_tail(tokens$(), tokptr%, term$) +=FNalloc_pair(car%, cdr%) + +DEF FNread_hashmap(tokens$(), RETURN tokptr%) + LOCAL tok$, map%, key%, val% + tok$ = FNreader_next(tokens$(), tokptr%) : REM skip over "{" + map% = FNempty_hashmap + WHILE FNreader_peek(tokens$(), tokptr%) <> "}" + key% = FNread_form(tokens$(), tokptr%) + IF NOT FNis_string(key%) ERROR &40E80932, "Hash-map key must be a string" + val% = FNread_form(tokens$(), tokptr%) + map% = FNhashmap_set(map%, FNunbox_string(key%), val%) + ENDWHILE + tok$ = FNreader_next(tokens$(), tokptr%) : REM skip over "}" +=map% + +DEF FNreader_macro(quote$, token$(), RETURN tokptr%) + LOCAL tok$ + tok$ = FNreader_next(tokens$(), tokptr%) : REM skip quoting token +=FNalloc_list2(FNalloc_symbol(quote$), FNread_form(tokens$(), tokptr%)) + +DEF FNread_with_meta(token$(), RETURN tokptr%) + LOCAL tok$, wm%, base%, meta% + tok$ = FNreader_next(tokens$(), tokptr%) : REM skip '^' token + wm% = FNalloc_symbol("with-meta") + meta% = FNread_form(tokens$(), tokptr%) + base% = FNread_form(tokens$(), tokptr%) +=FNalloc_list3(wm%, base%, meta%) + +DEF FNis_token_numeric(tok$) + LOCAL i%, c% + IF LEFT$(tok$, 1) = "-" THEN tok$ = MID$(tok$, 2) + IF LEN(tok$) = 0 THEN =FALSE + FOR i% = 1 TO LEN(tok$) + c% = ASC(MID$(tok$, i%, 1)) + IF c% < &30 OR c% > &39 THEN =FALSE + NEXT i% +=TRUE + +DEF FNread_atom(tokens$(), RETURN tokptr%) + LOCAL strval$ + strval$ = FNreader_next(tokens$(), tokptr%) + IF strval$ = "nil" THEN =FNnil + IF strval$ = "true" THEN =FNalloc_boolean(TRUE) + IF strval$ = "false" THEN =FNalloc_boolean(FALSE) + IF LEFT$(strval$, 1) = """" THEN =FNalloc_string(FNunquote_string(strval$)) + IF LEFT$(strval$, 1) = ":" THEN =FNalloc_string(CHR$(127) + MID$(strval$, 2)) + IF FNis_token_numeric(strval$) THEN =FNalloc_int(VAL(strval$)) +=FNalloc_symbol(strval$) + +DEF FNunquote_string(strval$) + LOCAL inptr%, bs%, out$, c$ + IF RIGHT$(strval$, 1) <> """" THEN ERROR &40E80930, "Unexpected end of input" + inptr% = 2 + REPEAT + bs% = INSTR(strval$, "\", inptr%) + IF bs% > 0 THEN + out$ += MID$(strval$, inptr%, bs% - inptr%) + c$ = MID$(strval$, bs% + 1, 1) + IF c$ = "n" THEN c$ = CHR$(10) + out$ += c$ + inptr% = bs% + 2 + ENDIF + UNTIL bs% = 0 + IF inptr% = LEN(strval$) + 1 THEN ERROR &40E80930, "Unexpected end of input" + out$ += MID$(strval$, inptr%, LEN(strval$) - inptr%) +=out$ + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/riscos/.gitignore b/impls/bbc-basic/riscos/.gitignore index 22421ae290..b042efcfda 100644 --- a/impls/bbc-basic/riscos/.gitignore +++ b/impls/bbc-basic/riscos/.gitignore @@ -1 +1 @@ -*,ffb +*,ffb diff --git a/impls/bbc-basic/riscos/setup,feb b/impls/bbc-basic/riscos/setup,feb index a99ea78e63..0335aec99e 100644 --- a/impls/bbc-basic/riscos/setup,feb +++ b/impls/bbc-basic/riscos/setup,feb @@ -1,2 +1,2 @@ -| This Obey file sets up the environment for running mal on RISC OS. -BASIC { < tokenize } +| This Obey file sets up the environment for running mal on RISC OS. +BASIC { < tokenize } diff --git a/impls/bbc-basic/riscos/tokenize,ffe b/impls/bbc-basic/riscos/tokenize,ffe index f192e6f9da..322e6eeadf 100644 --- a/impls/bbc-basic/riscos/tokenize,ffe +++ b/impls/bbc-basic/riscos/tokenize,ffe @@ -1,36 +1,36 @@ -REM Tokenizing libraries... -TEXTLOAD "^.core/bas" -SAVE "core" -TEXTLOAD "^.env/bas" -SAVE "env" -TEXTLOAD "^.printer/bas" -SAVE "printer" -TEXTLOAD "^.reader/bas" -SAVE "reader" -TEXTLOAD "^.types/bas" -SAVE "types" -REM Tokenizing steps... -TEXTLOAD "^.step0_repl/bas" -SAVE "step0_repl" -TEXTLOAD "^.step1_read_print/bas" -SAVE "step1_read_print" -TEXTLOAD "^.step2_eval/bas" -SAVE "step2_eval" -TEXTLOAD "^.step3_env/bas" -SAVE "step3_env" -TEXTLOAD "^.step4_if_fn_do/bas" -SAVE "step4_if_fn_do" -TEXTLOAD "^.step5_tco/bas" -SAVE "step5_tco" -TEXTLOAD "^.step6_file/bas" -SAVE "step6_file" -TEXTLOAD "^.step7_quote/bas" -SAVE "step7_quote" -TEXTLOAD "^.step8_macros/bas" -SAVE "step8_macros" -TEXTLOAD "^.step9_try/bas" -SAVE "step9_try" -TEXTLOAD "^.stepA_mal/bas" -SAVE "stepA_mal" -REM All done. -QUIT +REM Tokenizing libraries... +TEXTLOAD "^.core/bas" +SAVE "core" +TEXTLOAD "^.env/bas" +SAVE "env" +TEXTLOAD "^.printer/bas" +SAVE "printer" +TEXTLOAD "^.reader/bas" +SAVE "reader" +TEXTLOAD "^.types/bas" +SAVE "types" +REM Tokenizing steps... +TEXTLOAD "^.step0_repl/bas" +SAVE "step0_repl" +TEXTLOAD "^.step1_read_print/bas" +SAVE "step1_read_print" +TEXTLOAD "^.step2_eval/bas" +SAVE "step2_eval" +TEXTLOAD "^.step3_env/bas" +SAVE "step3_env" +TEXTLOAD "^.step4_if_fn_do/bas" +SAVE "step4_if_fn_do" +TEXTLOAD "^.step5_tco/bas" +SAVE "step5_tco" +TEXTLOAD "^.step6_file/bas" +SAVE "step6_file" +TEXTLOAD "^.step7_quote/bas" +SAVE "step7_quote" +TEXTLOAD "^.step8_macros/bas" +SAVE "step8_macros" +TEXTLOAD "^.step9_try/bas" +SAVE "step9_try" +TEXTLOAD "^.stepA_mal/bas" +SAVE "stepA_mal" +REM All done. +QUIT diff --git a/impls/bbc-basic/run b/impls/bbc-basic/run index a417467df0..238e2de156 100755 --- a/impls/bbc-basic/run +++ b/impls/bbc-basic/run @@ -1,3 +1,3 @@ -#! /bin/bash -exec "${BRANDY:-sbrandy}" -size 1024k \ - -path ../bbc-basic -quit $(dirname $0)/${STEP:-stepA_mal}.bas "${@}" +#! /bin/bash +exec "${BRANDY:-sbrandy}" -size 1024k \ + -path ../bbc-basic -quit $(dirname $0)/${STEP:-stepA_mal}.bas "${@}" diff --git a/impls/bbc-basic/step0_repl.bas b/impls/bbc-basic/step0_repl.bas index aa2a41261e..3148a33b75 100644 --- a/impls/bbc-basic/step0_repl.bas +++ b/impls/bbc-basic/step0_repl.bas @@ -1,25 +1,25 @@ -REM Step 0 of mal in BBC BASIC - -REPEAT - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=a$ - -DEF FNEVAL(a$) -=a$ - -DEF FNPRINT(a$) -=a$ - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$))) - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 0 of mal in BBC BASIC + +REPEAT + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=a$ + +DEF FNEVAL(a$) +=a$ + +DEF FNPRINT(a$) +=a$ + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$))) + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/step1_read_print.bas b/impls/bbc-basic/step1_read_print.bas index eae2bd5fa6..ba8d59b9d0 100644 --- a/impls/bbc-basic/step1_read_print.bas +++ b/impls/bbc-basic/step1_read_print.bas @@ -1,36 +1,36 @@ -REM Step 1 of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" - -PROCtypes_init - -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNEVAL(a%) -=a% - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$))) - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 1 of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" + +PROCtypes_init + +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNEVAL(a%) +=a% + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$))) + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/step2_eval.bas b/impls/bbc-basic/step2_eval.bas index 837b632c8b..b36c65836b 100644 --- a/impls/bbc-basic/step2_eval.bas +++ b/impls/bbc-basic/step2_eval.bas @@ -1,87 +1,87 @@ -REM Step 2 of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" - -PROCtypes_init - -REM These correspond with the CASE statement in FNcore_call -repl_env% = FNempty_hashmap -repl_env% = FNhashmap_set(repl_env%, "+", FNalloc_corefn(0)) -repl_env% = FNhashmap_set(repl_env%, "-", FNalloc_corefn(1)) -repl_env% = FNhashmap_set(repl_env%, "*", FNalloc_corefn(2)) -repl_env% = FNhashmap_set(repl_env%, "/", FNalloc_corefn(3)) - -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNEVAL(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - IF FNis_empty(ast%) THEN =ast% - ast% = FNeval_ast(ast%, env%) -=FNcore_call(FNunbox_corefn(FNfirst(ast%)), FNrest(ast%)) - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) - -DEF FNeval_ast(ast%, env%) - LOCAL val%, car%, cdr%, map%, keys%, key$ - IF FNis_symbol(ast%) THEN - val% = FNhashmap_get(env%, FNunbox_symbol(ast%)) - IF val% = FNnil THEN ERROR &40E80922, "Symbol not in environment" - =val% - ENDIF - IF FNis_seq(ast%) THEN - IF FNis_empty(ast%) THEN =ast% - car% = FNEVAL(FNfirst(ast%), env%) - cdr% = FNeval_ast(FNrest(ast%), env%) - IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) - =FNalloc_pair(car%, cdr%) - ENDIF - IF FNis_hashmap(ast%) THEN - map% = FNempty_hashmap - keys% = FNhashmap_keys(ast%) - WHILE NOT FNis_empty(keys%) - key$ = FNunbox_string(FNfirst(keys%)) - map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) - keys% = FNrest(keys%) - ENDWHILE - =map% - ENDIF -=ast% - -REM Call a core function, taking the function number and a mal list of -REM objects to pass as arguments. -DEF FNcore_call(fn%, args%) - LOCAL x%, y%, z% - x% = FNunbox_int(FNfirst(args%)) - y% = FNunbox_int(FNfirst(FNrest(args%))) - CASE fn% OF - WHEN 0 : z% = x% + y% - WHEN 1 : z% = x% - y% - WHEN 2 : z% = x% * y% - WHEN 3 : z% = x% DIV y% - OTHERWISE : ERROR &40E809F1, "Call to non-existent core function" - ENDCASE -=FNalloc_int(z%) - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 2 of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" + +PROCtypes_init + +REM These correspond with the CASE statement in FNcore_call +repl_env% = FNempty_hashmap +repl_env% = FNhashmap_set(repl_env%, "+", FNalloc_corefn(0)) +repl_env% = FNhashmap_set(repl_env%, "-", FNalloc_corefn(1)) +repl_env% = FNhashmap_set(repl_env%, "*", FNalloc_corefn(2)) +repl_env% = FNhashmap_set(repl_env%, "/", FNalloc_corefn(3)) + +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNEVAL(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + IF FNis_empty(ast%) THEN =ast% + ast% = FNeval_ast(ast%, env%) +=FNcore_call(FNunbox_corefn(FNfirst(ast%)), FNrest(ast%)) + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) + +DEF FNeval_ast(ast%, env%) + LOCAL val%, car%, cdr%, map%, keys%, key$ + IF FNis_symbol(ast%) THEN + val% = FNhashmap_get(env%, FNunbox_symbol(ast%)) + IF val% = FNnil THEN ERROR &40E80922, "Symbol not in environment" + =val% + ENDIF + IF FNis_seq(ast%) THEN + IF FNis_empty(ast%) THEN =ast% + car% = FNEVAL(FNfirst(ast%), env%) + cdr% = FNeval_ast(FNrest(ast%), env%) + IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) + =FNalloc_pair(car%, cdr%) + ENDIF + IF FNis_hashmap(ast%) THEN + map% = FNempty_hashmap + keys% = FNhashmap_keys(ast%) + WHILE NOT FNis_empty(keys%) + key$ = FNunbox_string(FNfirst(keys%)) + map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) + keys% = FNrest(keys%) + ENDWHILE + =map% + ENDIF +=ast% + +REM Call a core function, taking the function number and a mal list of +REM objects to pass as arguments. +DEF FNcore_call(fn%, args%) + LOCAL x%, y%, z% + x% = FNunbox_int(FNfirst(args%)) + y% = FNunbox_int(FNfirst(FNrest(args%))) + CASE fn% OF + WHEN 0 : z% = x% + y% + WHEN 1 : z% = x% - y% + WHEN 2 : z% = x% * y% + WHEN 3 : z% = x% DIV y% + OTHERWISE : ERROR &40E809F1, "Call to non-existent core function" + ENDCASE +=FNalloc_int(z%) + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/step3_env.bas b/impls/bbc-basic/step3_env.bas index 864f17b5ba..b156b9ec63 100644 --- a/impls/bbc-basic/step3_env.bas +++ b/impls/bbc-basic/step3_env.bas @@ -1,105 +1,105 @@ -REM Step 3 of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" -LIBRARY "env" - -PROCtypes_init - -REM These correspond with the CASE statement in FNcore_call -repl_env% = FNalloc_environment(FNnil) -PROCenv_set(repl_env%, FNalloc_symbol("+"), FNalloc_corefn(0)) -PROCenv_set(repl_env%, FNalloc_symbol("-"), FNalloc_corefn(1)) -PROCenv_set(repl_env%, FNalloc_symbol("*"), FNalloc_corefn(2)) -PROCenv_set(repl_env%, FNalloc_symbol("/"), FNalloc_corefn(3)) - -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNEVAL(ast%, env%) - LOCAL car% - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - IF FNis_empty(ast%) THEN =ast% - car% = FNfirst(ast%) - IF FNis_symbol(car%) THEN - CASE FNunbox_symbol(car%) OF - REM Special forms - WHEN "def!" - LOCAL val% - val% = FNEVAL(FNnth(ast%, 2), env%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "let*" - LOCAL bindings% - env% = FNalloc_environment(env%) - bindings% = FNnth(ast%, 1) - WHILE NOT FNis_empty(bindings%) - PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) - bindings% = FNrest(FNrest(bindings%)) - ENDWHILE - =FNEVAL(FNnth(ast%, 2), env%) - ENDCASE - ENDIF - ast% = FNeval_ast(ast%, env%) -=FNcore_call(FNunbox_corefn(FNfirst(ast%)), FNrest(ast%)) - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) - -DEF FNeval_ast(ast%, env%) - LOCAL val%, car%, cdr%, map%, keys%, key$ - IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) - IF FNis_seq(ast%) THEN - IF FNis_empty(ast%) THEN =ast% - car% = FNEVAL(FNfirst(ast%), env%) - cdr% = FNeval_ast(FNrest(ast%), env%) - IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) - =FNalloc_pair(car%, cdr%) - ENDIF - IF FNis_hashmap(ast%) THEN - map% = FNempty_hashmap - keys% = FNhashmap_keys(ast%) - WHILE NOT FNis_empty(keys%) - key$ = FNunbox_string(FNfirst(keys%)) - map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) - keys% = FNrest(keys%) - ENDWHILE - =map% - ENDIF -=ast% - -REM Call a core function, taking the function number and a mal list of -REM objects to pass as arguments. -DEF FNcore_call(fn%, args%) - LOCAL x%, y%, z% - x% = FNunbox_int(FNfirst(args%)) - y% = FNunbox_int(FNfirst(FNrest(args%))) - CASE fn% OF - WHEN 0 : z% = x% + y% - WHEN 1 : z% = x% - y% - WHEN 2 : z% = x% * y% - WHEN 3 : z% = x% DIV y% - OTHERWISE : ERROR &40E809F1, "Call to non-existent core function" - ENDCASE -=FNalloc_int(z%) - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 3 of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" +LIBRARY "env" + +PROCtypes_init + +REM These correspond with the CASE statement in FNcore_call +repl_env% = FNalloc_environment(FNnil) +PROCenv_set(repl_env%, FNalloc_symbol("+"), FNalloc_corefn(0)) +PROCenv_set(repl_env%, FNalloc_symbol("-"), FNalloc_corefn(1)) +PROCenv_set(repl_env%, FNalloc_symbol("*"), FNalloc_corefn(2)) +PROCenv_set(repl_env%, FNalloc_symbol("/"), FNalloc_corefn(3)) + +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNEVAL(ast%, env%) + LOCAL car% + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + IF FNis_empty(ast%) THEN =ast% + car% = FNfirst(ast%) + IF FNis_symbol(car%) THEN + CASE FNunbox_symbol(car%) OF + REM Special forms + WHEN "def!" + LOCAL val% + val% = FNEVAL(FNnth(ast%, 2), env%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "let*" + LOCAL bindings% + env% = FNalloc_environment(env%) + bindings% = FNnth(ast%, 1) + WHILE NOT FNis_empty(bindings%) + PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) + bindings% = FNrest(FNrest(bindings%)) + ENDWHILE + =FNEVAL(FNnth(ast%, 2), env%) + ENDCASE + ENDIF + ast% = FNeval_ast(ast%, env%) +=FNcore_call(FNunbox_corefn(FNfirst(ast%)), FNrest(ast%)) + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) + +DEF FNeval_ast(ast%, env%) + LOCAL val%, car%, cdr%, map%, keys%, key$ + IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) + IF FNis_seq(ast%) THEN + IF FNis_empty(ast%) THEN =ast% + car% = FNEVAL(FNfirst(ast%), env%) + cdr% = FNeval_ast(FNrest(ast%), env%) + IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) + =FNalloc_pair(car%, cdr%) + ENDIF + IF FNis_hashmap(ast%) THEN + map% = FNempty_hashmap + keys% = FNhashmap_keys(ast%) + WHILE NOT FNis_empty(keys%) + key$ = FNunbox_string(FNfirst(keys%)) + map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) + keys% = FNrest(keys%) + ENDWHILE + =map% + ENDIF +=ast% + +REM Call a core function, taking the function number and a mal list of +REM objects to pass as arguments. +DEF FNcore_call(fn%, args%) + LOCAL x%, y%, z% + x% = FNunbox_int(FNfirst(args%)) + y% = FNunbox_int(FNfirst(FNrest(args%))) + CASE fn% OF + WHEN 0 : z% = x% + y% + WHEN 1 : z% = x% - y% + WHEN 2 : z% = x% * y% + WHEN 3 : z% = x% DIV y% + OTHERWISE : ERROR &40E809F1, "Call to non-existent core function" + ENDCASE +=FNalloc_int(z%) + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/step4_if_fn_do.bas b/impls/bbc-basic/step4_if_fn_do.bas index 0e22c5b043..d04bb20d33 100644 --- a/impls/bbc-basic/step4_if_fn_do.bas +++ b/impls/bbc-basic/step4_if_fn_do.bas @@ -1,124 +1,124 @@ -REM Step 4 of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" -LIBRARY "env" -LIBRARY "core" - -PROCtypes_init - -repl_env% = FNalloc_environment(FNnil) -PROCcore_ns : REM This sets the data pointer -REPEAT - READ sym$, i% - IF sym$ <> "" THEN - PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) - ENDIF -UNTIL sym$ = "" - -val$ = FNrep("(def! not (fn* (a) (if a false true)))") - -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNEVAL(ast%, env%) - PROCgc - PROCgc_enter -=FNgc_exit(FNEVAL_(ast%, env%)) - -DEF FNEVAL_(ast%, env%) - LOCAL car% - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - IF FNis_empty(ast%) THEN =ast% - car% = FNfirst(ast%) - IF FNis_symbol(car%) THEN - CASE FNunbox_symbol(car%) OF - REM Special forms - WHEN "def!" - LOCAL val% - val% = FNEVAL(FNnth(ast%, 2), env%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "let*" - LOCAL bindings% - env% = FNalloc_environment(env%) - bindings% = FNnth(ast%, 1) - WHILE NOT FNis_empty(bindings%) - PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) - bindings% = FNrest(FNrest(bindings%)) - ENDWHILE - =FNEVAL(FNnth(ast%, 2), env%) - WHEN "do" - LOCAL val% - ast% = FNeval_ast(FNrest(ast%), env%) - REPEAT - val% = FNfirst(ast%) - ast% = FNrest(ast%) - UNTIL FNis_empty(ast%) - =val% - WHEN "if" - IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN - =FNEVAL(FNnth(ast%, 2), env%) - ENDIF - IF FNcount(ast%) = 3 THEN =FNnil - =FNEVAL(FNnth(ast%, 3), env%) - WHEN "fn*" - =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) - ENDCASE - ENDIF - ast% = FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - IF FNis_fn(car%) THEN - env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) - =FNEVAL(FNfn_ast(car%), env%) - ENDIF - IF FNis_corefn(car%) THEN - =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) - ENDIF - ERROR &40E80918, "Not a function" - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) - -DEF FNeval_ast(ast%, env%) - LOCAL val%, car%, cdr%, map%, keys%, key$ - IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) - IF FNis_seq(ast%) THEN - IF FNis_empty(ast%) THEN =ast% - car% = FNEVAL(FNfirst(ast%), env%) - cdr% = FNeval_ast(FNrest(ast%), env%) - IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) - =FNalloc_pair(car%, cdr%) - ENDIF - IF FNis_hashmap(ast%) THEN - map% = FNempty_hashmap - keys% = FNhashmap_keys(ast%) - WHILE NOT FNis_empty(keys%) - key$ = FNunbox_string(FNfirst(keys%)) - map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) - keys% = FNrest(keys%) - ENDWHILE - =map% - ENDIF -=ast% - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 4 of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" +LIBRARY "env" +LIBRARY "core" + +PROCtypes_init + +repl_env% = FNalloc_environment(FNnil) +PROCcore_ns : REM This sets the data pointer +REPEAT + READ sym$, i% + IF sym$ <> "" THEN + PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) + ENDIF +UNTIL sym$ = "" + +val$ = FNrep("(def! not (fn* (a) (if a false true)))") + +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNEVAL(ast%, env%) + PROCgc + PROCgc_enter +=FNgc_exit(FNEVAL_(ast%, env%)) + +DEF FNEVAL_(ast%, env%) + LOCAL car% + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + IF FNis_empty(ast%) THEN =ast% + car% = FNfirst(ast%) + IF FNis_symbol(car%) THEN + CASE FNunbox_symbol(car%) OF + REM Special forms + WHEN "def!" + LOCAL val% + val% = FNEVAL(FNnth(ast%, 2), env%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "let*" + LOCAL bindings% + env% = FNalloc_environment(env%) + bindings% = FNnth(ast%, 1) + WHILE NOT FNis_empty(bindings%) + PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) + bindings% = FNrest(FNrest(bindings%)) + ENDWHILE + =FNEVAL(FNnth(ast%, 2), env%) + WHEN "do" + LOCAL val% + ast% = FNeval_ast(FNrest(ast%), env%) + REPEAT + val% = FNfirst(ast%) + ast% = FNrest(ast%) + UNTIL FNis_empty(ast%) + =val% + WHEN "if" + IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN + =FNEVAL(FNnth(ast%, 2), env%) + ENDIF + IF FNcount(ast%) = 3 THEN =FNnil + =FNEVAL(FNnth(ast%, 3), env%) + WHEN "fn*" + =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) + ENDCASE + ENDIF + ast% = FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + IF FNis_fn(car%) THEN + env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) + =FNEVAL(FNfn_ast(car%), env%) + ENDIF + IF FNis_corefn(car%) THEN + =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) + ENDIF + ERROR &40E80918, "Not a function" + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) + +DEF FNeval_ast(ast%, env%) + LOCAL val%, car%, cdr%, map%, keys%, key$ + IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) + IF FNis_seq(ast%) THEN + IF FNis_empty(ast%) THEN =ast% + car% = FNEVAL(FNfirst(ast%), env%) + cdr% = FNeval_ast(FNrest(ast%), env%) + IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) + =FNalloc_pair(car%, cdr%) + ENDIF + IF FNis_hashmap(ast%) THEN + map% = FNempty_hashmap + keys% = FNhashmap_keys(ast%) + WHILE NOT FNis_empty(keys%) + key$ = FNunbox_string(FNfirst(keys%)) + map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) + keys% = FNrest(keys%) + ENDWHILE + =map% + ENDIF +=ast% + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/step5_tco.bas b/impls/bbc-basic/step5_tco.bas index 746c4cd0a3..7a1d77e780 100644 --- a/impls/bbc-basic/step5_tco.bas +++ b/impls/bbc-basic/step5_tco.bas @@ -1,138 +1,138 @@ -REM Step 5 of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" -LIBRARY "env" -LIBRARY "core" - -PROCtypes_init - -repl_env% = FNalloc_environment(FNnil) -PROCcore_ns : REM This sets the data pointer -REPEAT - READ sym$, i% - IF sym$ <> "" THEN - PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) - ENDIF -UNTIL sym$ = "" - -val$ = FNrep("(def! not (fn* (a) (if a false true)))") - -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNEVAL(ast%, env%) - PROCgc_enter -=FNgc_exit(FNEVAL_(ast%, env%)) - -DEF FNEVAL_(ast%, env%) - LOCAL car%, specialform%, val%, bindings% - REPEAT - PROCgc_keep_only2(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - IF FNis_empty(ast%) THEN =ast% - car% = FNfirst(ast%) - specialform% = FALSE - IF FNis_symbol(car%) THEN - specialform% = TRUE - CASE FNunbox_symbol(car%) OF - REM Special forms - WHEN "def!" - val% = FNEVAL(FNnth(ast%, 2), env%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "let*" - env% = FNalloc_environment(env%) - bindings% = FNnth(ast%, 1) - WHILE NOT FNis_empty(bindings%) - PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) - bindings% = FNrest(FNrest(bindings%)) - ENDWHILE - ast% = FNnth(ast%, 2) - REM Loop round for tail-call optimisation. - WHEN "do" - REM The guide has us call FNeval_ast on the sub-list that excludes - REM the last element of ast%, but that's a bit painful without - REM native list slicing, so it's easier to just re-implement the - REM bit of FNeval_ast that we need. - ast% = FNrest(ast%) - WHILE NOT FNis_empty(FNrest(ast%)) - val% = FNEVAL(FNfirst(ast%), env%) - ast% = FNrest(ast%) - ENDWHILE - ast% = FNfirst(ast%) - WHEN "if" - IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN - ast% = FNnth(ast%, 2) - ELSE - IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) - ENDIF - REM Loop round for tail-call optimisation. - WHEN "fn*" - =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) - OTHERWISE - specialform% = FALSE - ENDCASE - ENDIF - IF NOT specialform% THEN - REM This is the "apply" part. - ast% = FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - IF FNis_corefn(car%) THEN - =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) - ENDIF - IF FNis_fn(car%) THEN - env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) - ast% = FNfn_ast(car%) - REM Loop round for tail-call optimisation. - ELSE - ERROR &40E80918, "Not a function" - ENDIF - ENDIF - UNTIL FALSE - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) - -DEF FNeval_ast(ast%, env%) - LOCAL val%, car%, cdr%, map%, keys%, key$ - IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) - IF FNis_seq(ast%) THEN - IF FNis_empty(ast%) THEN =ast% - car% = FNEVAL(FNfirst(ast%), env%) - cdr% = FNeval_ast(FNrest(ast%), env%) - IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) - =FNalloc_pair(car%, cdr%) - ENDIF - IF FNis_hashmap(ast%) THEN - map% = FNempty_hashmap - keys% = FNhashmap_keys(ast%) - WHILE NOT FNis_empty(keys%) - key$ = FNunbox_string(FNfirst(keys%)) - map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) - keys% = FNrest(keys%) - ENDWHILE - =map% - ENDIF -=ast% - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 5 of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" +LIBRARY "env" +LIBRARY "core" + +PROCtypes_init + +repl_env% = FNalloc_environment(FNnil) +PROCcore_ns : REM This sets the data pointer +REPEAT + READ sym$, i% + IF sym$ <> "" THEN + PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) + ENDIF +UNTIL sym$ = "" + +val$ = FNrep("(def! not (fn* (a) (if a false true)))") + +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNEVAL(ast%, env%) + PROCgc_enter +=FNgc_exit(FNEVAL_(ast%, env%)) + +DEF FNEVAL_(ast%, env%) + LOCAL car%, specialform%, val%, bindings% + REPEAT + PROCgc_keep_only2(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + IF FNis_empty(ast%) THEN =ast% + car% = FNfirst(ast%) + specialform% = FALSE + IF FNis_symbol(car%) THEN + specialform% = TRUE + CASE FNunbox_symbol(car%) OF + REM Special forms + WHEN "def!" + val% = FNEVAL(FNnth(ast%, 2), env%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "let*" + env% = FNalloc_environment(env%) + bindings% = FNnth(ast%, 1) + WHILE NOT FNis_empty(bindings%) + PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) + bindings% = FNrest(FNrest(bindings%)) + ENDWHILE + ast% = FNnth(ast%, 2) + REM Loop round for tail-call optimisation. + WHEN "do" + REM The guide has us call FNeval_ast on the sub-list that excludes + REM the last element of ast%, but that's a bit painful without + REM native list slicing, so it's easier to just re-implement the + REM bit of FNeval_ast that we need. + ast% = FNrest(ast%) + WHILE NOT FNis_empty(FNrest(ast%)) + val% = FNEVAL(FNfirst(ast%), env%) + ast% = FNrest(ast%) + ENDWHILE + ast% = FNfirst(ast%) + WHEN "if" + IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN + ast% = FNnth(ast%, 2) + ELSE + IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) + ENDIF + REM Loop round for tail-call optimisation. + WHEN "fn*" + =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) + OTHERWISE + specialform% = FALSE + ENDCASE + ENDIF + IF NOT specialform% THEN + REM This is the "apply" part. + ast% = FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + IF FNis_corefn(car%) THEN + =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) + ENDIF + IF FNis_fn(car%) THEN + env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) + ast% = FNfn_ast(car%) + REM Loop round for tail-call optimisation. + ELSE + ERROR &40E80918, "Not a function" + ENDIF + ENDIF + UNTIL FALSE + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) + +DEF FNeval_ast(ast%, env%) + LOCAL val%, car%, cdr%, map%, keys%, key$ + IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) + IF FNis_seq(ast%) THEN + IF FNis_empty(ast%) THEN =ast% + car% = FNEVAL(FNfirst(ast%), env%) + cdr% = FNeval_ast(FNrest(ast%), env%) + IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) + =FNalloc_pair(car%, cdr%) + ENDIF + IF FNis_hashmap(ast%) THEN + map% = FNempty_hashmap + keys% = FNhashmap_keys(ast%) + WHILE NOT FNis_empty(keys%) + key$ = FNunbox_string(FNfirst(keys%)) + map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) + keys% = FNrest(keys%) + ENDWHILE + =map% + ENDIF +=ast% + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/step6_file.bas b/impls/bbc-basic/step6_file.bas index 6c682b2178..f1b700daeb 100644 --- a/impls/bbc-basic/step6_file.bas +++ b/impls/bbc-basic/step6_file.bas @@ -1,200 +1,200 @@ -REM Step 6 of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" -LIBRARY "env" -LIBRARY "core" - -PROCtypes_init - -repl_env% = FNalloc_environment(FNnil) -PROCcore_ns : REM This sets the data pointer -REPEAT - READ sym$, i% - IF sym$ <> "" THEN - PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) - ENDIF -UNTIL sym$ = "" - -REM Initial forms to evaluate -RESTORE +0 -DATA (def! not (fn* (a) (if a false true))) -DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) -DATA "" -REPEAT - READ form$ - IF form$ <> "" THEN val$ = FNrep(form$) -UNTIL form$ = "" - -argv% = FNget_argv - -IF FNis_empty(argv%) THEN - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) -ELSE - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) - val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") - END -ENDIF - -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNEVAL(ast%, env%) - PROCgc_enter -=FNgc_exit(FNEVAL_(ast%, env%)) - -DEF FNEVAL_(ast%, env%) - LOCAL car%, specialform%, val%, bindings% - REPEAT - PROCgc_keep_only2(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - IF FNis_empty(ast%) THEN =ast% - car% = FNfirst(ast%) - specialform% = FALSE - IF FNis_symbol(car%) THEN - specialform% = TRUE - CASE FNunbox_symbol(car%) OF - REM Special forms - WHEN "def!" - val% = FNEVAL(FNnth(ast%, 2), env%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "let*" - env% = FNalloc_environment(env%) - bindings% = FNnth(ast%, 1) - WHILE NOT FNis_empty(bindings%) - PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) - bindings% = FNrest(FNrest(bindings%)) - ENDWHILE - ast% = FNnth(ast%, 2) - REM Loop round for tail-call optimisation. - WHEN "do" - REM The guide has us call FNeval_ast on the sub-list that excludes - REM the last element of ast%, but that's a bit painful without - REM native list slicing, so it's easier to just re-implement the - REM bit of FNeval_ast that we need. - ast% = FNrest(ast%) - WHILE NOT FNis_empty(FNrest(ast%)) - val% = FNEVAL(FNfirst(ast%), env%) - ast% = FNrest(ast%) - ENDWHILE - ast% = FNfirst(ast%) - WHEN "if" - IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN - ast% = FNnth(ast%, 2) - ELSE - IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) - ENDIF - REM Loop round for tail-call optimisation. - WHEN "fn*" - =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) - OTHERWISE - specialform% = FALSE - ENDCASE - ENDIF - IF NOT specialform% THEN - REM This is the "apply" part. - ast% = FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - IF FNis_corefn(car%) THEN - =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) - ENDIF - IF FNis_fn(car%) THEN - env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) - ast% = FNfn_ast(car%) - REM Loop round for tail-call optimisation. - ELSE - ERROR &40E80918, "Not a function" - ENDIF - ENDIF - UNTIL FALSE - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) - -DEF FNeval_ast(ast%, env%) - LOCAL val%, car%, cdr%, map%, keys%, key$ - IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) - IF FNis_seq(ast%) THEN - IF FNis_empty(ast%) THEN =ast% - car% = FNEVAL(FNfirst(ast%), env%) - cdr% = FNeval_ast(FNrest(ast%), env%) - IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) - =FNalloc_pair(car%, cdr%) - ENDIF - IF FNis_hashmap(ast%) THEN - map% = FNempty_hashmap - keys% = FNhashmap_keys(ast%) - WHILE NOT FNis_empty(keys%) - key$ = FNunbox_string(FNfirst(keys%)) - map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) - keys% = FNrest(keys%) - ENDWHILE - =map% - ENDIF -=ast% - -DEF FNget_argv - PROCgc_enter - LOCAL argv%, rargv%, cmdptr%, arg$, len% - argv% = FNempty - IF !PAGE = &D7C1C7C5 THEN - REM Running under Brandy, so ARGC and ARGV$ are usable. - IF ARGC >= 1 THEN - FOR i% = ARGC TO 1 STEP -1 - argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) - NEXT i% - ENDIF - ELSE - IF (INKEY(-256) AND &F0) = &A0 THEN - rargv% = FNempty - REM Running under RISC OS - REM Vexingly, we can only get the command line that was passed to - REM the BASIC interpreter. This means that we need to extract - REM the arguments from that. Typically, we will have been started - REM with "BASIC -quit ". - - DIM q% 256 - SYS "OS_GetEnv" TO cmdptr% - WHILE ?cmdptr% >= 32 - SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% - q%?len% = 13 - rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) - ENDWHILE - REM Put argv back into the right order. - WHILE NOT FNis_empty(rargv%) - argv% = FNalloc_pair(FNfirst(rargv%), argv%) - rargv% = FNrest(rargv%) - ENDWHILE - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "BASIC" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "-quit" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip filename - ENDIF - ENDIF -=FNgc_exit(argv%) - - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 6 of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" +LIBRARY "env" +LIBRARY "core" + +PROCtypes_init + +repl_env% = FNalloc_environment(FNnil) +PROCcore_ns : REM This sets the data pointer +REPEAT + READ sym$, i% + IF sym$ <> "" THEN + PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) + ENDIF +UNTIL sym$ = "" + +REM Initial forms to evaluate +RESTORE +0 +DATA (def! not (fn* (a) (if a false true))) +DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) +DATA "" +REPEAT + READ form$ + IF form$ <> "" THEN val$ = FNrep(form$) +UNTIL form$ = "" + +argv% = FNget_argv + +IF FNis_empty(argv%) THEN + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) +ELSE + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) + val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") + END +ENDIF + +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNEVAL(ast%, env%) + PROCgc_enter +=FNgc_exit(FNEVAL_(ast%, env%)) + +DEF FNEVAL_(ast%, env%) + LOCAL car%, specialform%, val%, bindings% + REPEAT + PROCgc_keep_only2(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + IF FNis_empty(ast%) THEN =ast% + car% = FNfirst(ast%) + specialform% = FALSE + IF FNis_symbol(car%) THEN + specialform% = TRUE + CASE FNunbox_symbol(car%) OF + REM Special forms + WHEN "def!" + val% = FNEVAL(FNnth(ast%, 2), env%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "let*" + env% = FNalloc_environment(env%) + bindings% = FNnth(ast%, 1) + WHILE NOT FNis_empty(bindings%) + PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) + bindings% = FNrest(FNrest(bindings%)) + ENDWHILE + ast% = FNnth(ast%, 2) + REM Loop round for tail-call optimisation. + WHEN "do" + REM The guide has us call FNeval_ast on the sub-list that excludes + REM the last element of ast%, but that's a bit painful without + REM native list slicing, so it's easier to just re-implement the + REM bit of FNeval_ast that we need. + ast% = FNrest(ast%) + WHILE NOT FNis_empty(FNrest(ast%)) + val% = FNEVAL(FNfirst(ast%), env%) + ast% = FNrest(ast%) + ENDWHILE + ast% = FNfirst(ast%) + WHEN "if" + IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN + ast% = FNnth(ast%, 2) + ELSE + IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) + ENDIF + REM Loop round for tail-call optimisation. + WHEN "fn*" + =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) + OTHERWISE + specialform% = FALSE + ENDCASE + ENDIF + IF NOT specialform% THEN + REM This is the "apply" part. + ast% = FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + IF FNis_corefn(car%) THEN + =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) + ENDIF + IF FNis_fn(car%) THEN + env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) + ast% = FNfn_ast(car%) + REM Loop round for tail-call optimisation. + ELSE + ERROR &40E80918, "Not a function" + ENDIF + ENDIF + UNTIL FALSE + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) + +DEF FNeval_ast(ast%, env%) + LOCAL val%, car%, cdr%, map%, keys%, key$ + IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) + IF FNis_seq(ast%) THEN + IF FNis_empty(ast%) THEN =ast% + car% = FNEVAL(FNfirst(ast%), env%) + cdr% = FNeval_ast(FNrest(ast%), env%) + IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) + =FNalloc_pair(car%, cdr%) + ENDIF + IF FNis_hashmap(ast%) THEN + map% = FNempty_hashmap + keys% = FNhashmap_keys(ast%) + WHILE NOT FNis_empty(keys%) + key$ = FNunbox_string(FNfirst(keys%)) + map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) + keys% = FNrest(keys%) + ENDWHILE + =map% + ENDIF +=ast% + +DEF FNget_argv + PROCgc_enter + LOCAL argv%, rargv%, cmdptr%, arg$, len% + argv% = FNempty + IF !PAGE = &D7C1C7C5 THEN + REM Running under Brandy, so ARGC and ARGV$ are usable. + IF ARGC >= 1 THEN + FOR i% = ARGC TO 1 STEP -1 + argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) + NEXT i% + ENDIF + ELSE + IF (INKEY(-256) AND &F0) = &A0 THEN + rargv% = FNempty + REM Running under RISC OS + REM Vexingly, we can only get the command line that was passed to + REM the BASIC interpreter. This means that we need to extract + REM the arguments from that. Typically, we will have been started + REM with "BASIC -quit ". + + DIM q% 256 + SYS "OS_GetEnv" TO cmdptr% + WHILE ?cmdptr% >= 32 + SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% + q%?len% = 13 + rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) + ENDWHILE + REM Put argv back into the right order. + WHILE NOT FNis_empty(rargv%) + argv% = FNalloc_pair(FNfirst(rargv%), argv%) + rargv% = FNrest(rargv%) + ENDWHILE + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "BASIC" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "-quit" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip filename + ENDIF + ENDIF +=FNgc_exit(argv%) + + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/step7_quote.bas b/impls/bbc-basic/step7_quote.bas index 5d3fdb1b42..ec11e9e24c 100644 --- a/impls/bbc-basic/step7_quote.bas +++ b/impls/bbc-basic/step7_quote.bas @@ -1,235 +1,235 @@ -REM Step 7 of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" -LIBRARY "env" -LIBRARY "core" - -PROCtypes_init - -repl_env% = FNalloc_environment(FNnil) -PROCcore_ns : REM This sets the data pointer -REPEAT - READ sym$, i% - IF sym$ <> "" THEN - PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) - ENDIF -UNTIL sym$ = "" - -REM Initial forms to evaluate -RESTORE +0 -DATA (def! not (fn* (a) (if a false true))) -DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) -DATA "" -REPEAT - READ form$ - IF form$ <> "" THEN val$ = FNrep(form$) -UNTIL form$ = "" - -argv% = FNget_argv - -IF FNis_empty(argv%) THEN - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) -ELSE - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) - val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") - END -ENDIF - -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNstarts_with(ast%, sym$) - LOCAL a0% - IF NOT FNis_list(ast%) THEN =FALSE - a0% = FNfirst(ast%) - IF NOT FNis_symbol(a0%) THEN =FALSE - =FNunbox_symbol(a0%) = sym$ - -DEF FNqq_elts(seq%) - LOCAL elt%, acc% - IF FNis_empty(seq%) THEN =FNempty - elt% = FNfirst(seq%) - acc% = FNqq_elts(FNrest(seq%)) - IF FNstarts_with(elt%, "splice-unquote") THEN - =FNalloc_list3(FNalloc_symbol("concat"), FNnth(elt%, 1), acc%) - ENDIF - =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(elt%), acc%) - -DEF FNquasiquote(ast%) - IF FNstarts_with(ast%, "unquote") THEN =FNnth(ast%, 1) - IF FNis_list(ast%) THEN =FNqq_elts(ast%) - IF FNis_vector(ast%) THEN - =FNalloc_list2(FNalloc_symbol("vec"), FNqq_elts(ast%)) - ENDIF - IF FNis_symbol(ast%) OR FNis_hashmap(ast%) THEN - =FNalloc_list2(FNalloc_symbol("quote"), ast%) - ENDIF - =ast% - -DEF FNEVAL(ast%, env%) - PROCgc_enter -=FNgc_exit(FNEVAL_(ast%, env%)) - -DEF FNEVAL_(ast%, env%) - LOCAL car%, specialform%, val%, bindings% - REPEAT - PROCgc_keep_only2(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - IF FNis_empty(ast%) THEN =ast% - car% = FNfirst(ast%) - specialform% = FALSE - IF FNis_symbol(car%) THEN - specialform% = TRUE - CASE FNunbox_symbol(car%) OF - REM Special forms - WHEN "def!" - val% = FNEVAL(FNnth(ast%, 2), env%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "let*" - env% = FNalloc_environment(env%) - bindings% = FNnth(ast%, 1) - WHILE NOT FNis_empty(bindings%) - PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) - bindings% = FNrest(FNrest(bindings%)) - ENDWHILE - ast% = FNnth(ast%, 2) - REM Loop round for tail-call optimisation. - WHEN "do" - REM The guide has us call FNeval_ast on the sub-list that excludes - REM the last element of ast%, but that's a bit painful without - REM native list slicing, so it's easier to just re-implement the - REM bit of FNeval_ast that we need. - ast% = FNrest(ast%) - WHILE NOT FNis_empty(FNrest(ast%)) - val% = FNEVAL(FNfirst(ast%), env%) - ast% = FNrest(ast%) - ENDWHILE - ast% = FNfirst(ast%) - WHEN "if" - IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN - ast% = FNnth(ast%, 2) - ELSE - IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) - ENDIF - REM Loop round for tail-call optimisation. - WHEN "fn*" - =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) - WHEN "quote" - =FNnth(ast%, 1) - WHEN "quasiquoteexpand" - = FNquasiquote(FNnth(ast%, 1)) - WHEN "quasiquote" - ast% = FNquasiquote(FNnth(ast%, 1)) - REM Loop round for tail-call optimisation - OTHERWISE - specialform% = FALSE - ENDCASE - ENDIF - IF NOT specialform% THEN - REM This is the "apply" part. - ast% = FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - IF FNis_corefn(car%) THEN - =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) - ENDIF - IF FNis_fn(car%) THEN - env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) - ast% = FNfn_ast(car%) - REM Loop round for tail-call optimisation. - ELSE - ERROR &40E80918, "Not a function" - ENDIF - ENDIF - UNTIL FALSE - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) - -DEF FNeval_ast(ast%, env%) - LOCAL val%, car%, cdr%, map%, keys%, key$ - IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) - IF FNis_seq(ast%) THEN - IF FNis_empty(ast%) THEN =ast% - car% = FNEVAL(FNfirst(ast%), env%) - cdr% = FNeval_ast(FNrest(ast%), env%) - IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) - =FNalloc_pair(car%, cdr%) - ENDIF - IF FNis_hashmap(ast%) THEN - map% = FNempty_hashmap - keys% = FNhashmap_keys(ast%) - WHILE NOT FNis_empty(keys%) - key$ = FNunbox_string(FNfirst(keys%)) - map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) - keys% = FNrest(keys%) - ENDWHILE - =map% - ENDIF -=ast% - -DEF FNget_argv - PROCgc_enter - LOCAL argv%, rargv%, cmdptr%, arg$, len% - argv% = FNempty - IF !PAGE = &D7C1C7C5 THEN - REM Running under Brandy, so ARGC and ARGV$ are usable. - IF ARGC >= 1 THEN - FOR i% = ARGC TO 1 STEP -1 - argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) - NEXT i% - ENDIF - ELSE - IF (INKEY(-256) AND &F0) = &A0 THEN - rargv% = FNempty - REM Running under RISC OS - REM Vexingly, we can only get the command line that was passed to - REM the BASIC interpreter. This means that we need to extract - REM the arguments from that. Typically, we will have been started - REM with "BASIC -quit ". - - DIM q% 256 - SYS "OS_GetEnv" TO cmdptr% - WHILE ?cmdptr% >= 32 - SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% - q%?len% = 13 - rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) - ENDWHILE - REM Put argv back into the right order. - WHILE NOT FNis_empty(rargv%) - argv% = FNalloc_pair(FNfirst(rargv%), argv%) - rargv% = FNrest(rargv%) - ENDWHILE - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "BASIC" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "-quit" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip filename - ENDIF - ENDIF -=FNgc_exit(argv%) - - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 7 of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" +LIBRARY "env" +LIBRARY "core" + +PROCtypes_init + +repl_env% = FNalloc_environment(FNnil) +PROCcore_ns : REM This sets the data pointer +REPEAT + READ sym$, i% + IF sym$ <> "" THEN + PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) + ENDIF +UNTIL sym$ = "" + +REM Initial forms to evaluate +RESTORE +0 +DATA (def! not (fn* (a) (if a false true))) +DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) +DATA "" +REPEAT + READ form$ + IF form$ <> "" THEN val$ = FNrep(form$) +UNTIL form$ = "" + +argv% = FNget_argv + +IF FNis_empty(argv%) THEN + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) +ELSE + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) + val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") + END +ENDIF + +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNstarts_with(ast%, sym$) + LOCAL a0% + IF NOT FNis_list(ast%) THEN =FALSE + a0% = FNfirst(ast%) + IF NOT FNis_symbol(a0%) THEN =FALSE + =FNunbox_symbol(a0%) = sym$ + +DEF FNqq_elts(seq%) + LOCAL elt%, acc% + IF FNis_empty(seq%) THEN =FNempty + elt% = FNfirst(seq%) + acc% = FNqq_elts(FNrest(seq%)) + IF FNstarts_with(elt%, "splice-unquote") THEN + =FNalloc_list3(FNalloc_symbol("concat"), FNnth(elt%, 1), acc%) + ENDIF + =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(elt%), acc%) + +DEF FNquasiquote(ast%) + IF FNstarts_with(ast%, "unquote") THEN =FNnth(ast%, 1) + IF FNis_list(ast%) THEN =FNqq_elts(ast%) + IF FNis_vector(ast%) THEN + =FNalloc_list2(FNalloc_symbol("vec"), FNqq_elts(ast%)) + ENDIF + IF FNis_symbol(ast%) OR FNis_hashmap(ast%) THEN + =FNalloc_list2(FNalloc_symbol("quote"), ast%) + ENDIF + =ast% + +DEF FNEVAL(ast%, env%) + PROCgc_enter +=FNgc_exit(FNEVAL_(ast%, env%)) + +DEF FNEVAL_(ast%, env%) + LOCAL car%, specialform%, val%, bindings% + REPEAT + PROCgc_keep_only2(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + IF FNis_empty(ast%) THEN =ast% + car% = FNfirst(ast%) + specialform% = FALSE + IF FNis_symbol(car%) THEN + specialform% = TRUE + CASE FNunbox_symbol(car%) OF + REM Special forms + WHEN "def!" + val% = FNEVAL(FNnth(ast%, 2), env%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "let*" + env% = FNalloc_environment(env%) + bindings% = FNnth(ast%, 1) + WHILE NOT FNis_empty(bindings%) + PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) + bindings% = FNrest(FNrest(bindings%)) + ENDWHILE + ast% = FNnth(ast%, 2) + REM Loop round for tail-call optimisation. + WHEN "do" + REM The guide has us call FNeval_ast on the sub-list that excludes + REM the last element of ast%, but that's a bit painful without + REM native list slicing, so it's easier to just re-implement the + REM bit of FNeval_ast that we need. + ast% = FNrest(ast%) + WHILE NOT FNis_empty(FNrest(ast%)) + val% = FNEVAL(FNfirst(ast%), env%) + ast% = FNrest(ast%) + ENDWHILE + ast% = FNfirst(ast%) + WHEN "if" + IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN + ast% = FNnth(ast%, 2) + ELSE + IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) + ENDIF + REM Loop round for tail-call optimisation. + WHEN "fn*" + =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) + WHEN "quote" + =FNnth(ast%, 1) + WHEN "quasiquoteexpand" + = FNquasiquote(FNnth(ast%, 1)) + WHEN "quasiquote" + ast% = FNquasiquote(FNnth(ast%, 1)) + REM Loop round for tail-call optimisation + OTHERWISE + specialform% = FALSE + ENDCASE + ENDIF + IF NOT specialform% THEN + REM This is the "apply" part. + ast% = FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + IF FNis_corefn(car%) THEN + =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) + ENDIF + IF FNis_fn(car%) THEN + env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) + ast% = FNfn_ast(car%) + REM Loop round for tail-call optimisation. + ELSE + ERROR &40E80918, "Not a function" + ENDIF + ENDIF + UNTIL FALSE + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) + +DEF FNeval_ast(ast%, env%) + LOCAL val%, car%, cdr%, map%, keys%, key$ + IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) + IF FNis_seq(ast%) THEN + IF FNis_empty(ast%) THEN =ast% + car% = FNEVAL(FNfirst(ast%), env%) + cdr% = FNeval_ast(FNrest(ast%), env%) + IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) + =FNalloc_pair(car%, cdr%) + ENDIF + IF FNis_hashmap(ast%) THEN + map% = FNempty_hashmap + keys% = FNhashmap_keys(ast%) + WHILE NOT FNis_empty(keys%) + key$ = FNunbox_string(FNfirst(keys%)) + map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) + keys% = FNrest(keys%) + ENDWHILE + =map% + ENDIF +=ast% + +DEF FNget_argv + PROCgc_enter + LOCAL argv%, rargv%, cmdptr%, arg$, len% + argv% = FNempty + IF !PAGE = &D7C1C7C5 THEN + REM Running under Brandy, so ARGC and ARGV$ are usable. + IF ARGC >= 1 THEN + FOR i% = ARGC TO 1 STEP -1 + argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) + NEXT i% + ENDIF + ELSE + IF (INKEY(-256) AND &F0) = &A0 THEN + rargv% = FNempty + REM Running under RISC OS + REM Vexingly, we can only get the command line that was passed to + REM the BASIC interpreter. This means that we need to extract + REM the arguments from that. Typically, we will have been started + REM with "BASIC -quit ". + + DIM q% 256 + SYS "OS_GetEnv" TO cmdptr% + WHILE ?cmdptr% >= 32 + SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% + q%?len% = 13 + rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) + ENDWHILE + REM Put argv back into the right order. + WHILE NOT FNis_empty(rargv%) + argv% = FNalloc_pair(FNfirst(rargv%), argv%) + rargv% = FNrest(rargv%) + ENDWHILE + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "BASIC" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "-quit" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip filename + ENDIF + ENDIF +=FNgc_exit(argv%) + + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/step8_macros.bas b/impls/bbc-basic/step8_macros.bas index 5f50ab2854..efa7da3b26 100644 --- a/impls/bbc-basic/step8_macros.bas +++ b/impls/bbc-basic/step8_macros.bas @@ -1,266 +1,266 @@ -REM Step 8 of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" -LIBRARY "env" -LIBRARY "core" - -PROCtypes_init - -repl_env% = FNalloc_environment(FNnil) -PROCcore_ns : REM This sets the data pointer -REPEAT - READ sym$, i% - IF sym$ <> "" THEN - PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) - ENDIF -UNTIL sym$ = "" - -REM Initial forms to evaluate -RESTORE +0 -DATA (def! not (fn* (a) (if a false true))) -DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) -DATA (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))))))) -DATA "" -REPEAT - READ form$ - IF form$ <> "" THEN val$ = FNrep(form$) -UNTIL form$ = "" - -argv% = FNget_argv - -IF FNis_empty(argv%) THEN - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) -ELSE - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) - val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") - END -ENDIF - -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNstarts_with(ast%, sym$) - LOCAL a0% - IF NOT FNis_list(ast%) THEN =FALSE - a0% = FNfirst(ast%) - IF NOT FNis_symbol(a0%) THEN =FALSE - =FNunbox_symbol(a0%) = sym$ - -DEF FNqq_elts(seq%) - LOCAL elt%, acc% - IF FNis_empty(seq%) THEN =FNempty - elt% = FNfirst(seq%) - acc% = FNqq_elts(FNrest(seq%)) - IF FNstarts_with(elt%, "splice-unquote") THEN - =FNalloc_list3(FNalloc_symbol("concat"), FNnth(elt%, 1), acc%) - ENDIF - =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(elt%), acc%) - -DEF FNquasiquote(ast%) - IF FNstarts_with(ast%, "unquote") THEN =FNnth(ast%, 1) - IF FNis_list(ast%) THEN =FNqq_elts(ast%) - IF FNis_vector(ast%) THEN - =FNalloc_list2(FNalloc_symbol("vec"), FNqq_elts(ast%)) - ENDIF - IF FNis_symbol(ast%) OR FNis_hashmap(ast%) THEN - =FNalloc_list2(FNalloc_symbol("quote"), ast%) - ENDIF - =ast% - -DEF FNis_macro_call(ast%, env%) - LOCAL car%, val% - IF NOT FNis_list(ast%) THEN =FALSE - car% = FNfirst(ast%) - IF NOT FNis_symbol(car%) THEN =FALSE - IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE - val% = FNenv_get(env%, car%) -=FNis_macro(val%) - -DEF FNmacroexpand(ast%, env%) - LOCAL mac%, macenv%, macast% - WHILE FNis_macro_call(ast%, env%) - REM PRINT "expanded ";FNpr_str(ast%, TRUE); - mac% = FNenv_get(env%, FNfirst(ast%)) - macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%)) - macast% = FNfn_ast(mac%) - ast% = FNEVAL(macast%, macenv%) - REM PRINT " to ";FNpr_str(ast%, TRUE) - ENDWHILE -=ast% - -DEF FNEVAL(ast%, env%) - PROCgc_enter -=FNgc_exit(FNEVAL_(ast%, env%)) - -DEF FNEVAL_(ast%, env%) - LOCAL car%, specialform%, val%, bindings% - REPEAT - PROCgc_keep_only2(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - IF FNis_empty(ast%) THEN =ast% - ast% = FNmacroexpand(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - specialform% = FALSE - IF FNis_symbol(car%) THEN - specialform% = TRUE - CASE FNunbox_symbol(car%) OF - REM Special forms - WHEN "def!" - val% = FNEVAL(FNnth(ast%, 2), env%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "defmacro!" - val% = FNEVAL(FNnth(ast%, 2), env%) - IF FNis_fn(val%) THEN val% = FNas_macro(val%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "let*" - env% = FNalloc_environment(env%) - bindings% = FNnth(ast%, 1) - WHILE NOT FNis_empty(bindings%) - PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) - bindings% = FNrest(FNrest(bindings%)) - ENDWHILE - ast% = FNnth(ast%, 2) - REM Loop round for tail-call optimisation. - WHEN "do" - REM The guide has us call FNeval_ast on the sub-list that excludes - REM the last element of ast%, but that's a bit painful without - REM native list slicing, so it's easier to just re-implement the - REM bit of FNeval_ast that we need. - ast% = FNrest(ast%) - WHILE NOT FNis_empty(FNrest(ast%)) - val% = FNEVAL(FNfirst(ast%), env%) - ast% = FNrest(ast%) - ENDWHILE - ast% = FNfirst(ast%) - WHEN "if" - IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN - ast% = FNnth(ast%, 2) - ELSE - IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) - ENDIF - REM Loop round for tail-call optimisation. - WHEN "fn*" - =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) - WHEN "quote" - =FNnth(ast%, 1) - WHEN "quasiquoteexpand" - = FNquasiquote(FNnth(ast%, 1)) - WHEN "quasiquote" - ast% = FNquasiquote(FNnth(ast%, 1)) - REM Loop round for tail-call optimisation - WHEN "macroexpand" - =FNmacroexpand(FNnth(ast%, 1), env%) - OTHERWISE - specialform% = FALSE - ENDCASE - ENDIF - IF NOT specialform% THEN - REM This is the "apply" part. - ast% = FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - IF FNis_corefn(car%) THEN - =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) - ENDIF - IF FNis_fn(car%) THEN - env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) - ast% = FNfn_ast(car%) - REM Loop round for tail-call optimisation. - ELSE - ERROR &40E80918, "Not a function" - ENDIF - ENDIF - UNTIL FALSE - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) - -DEF FNeval_ast(ast%, env%) - LOCAL val%, car%, cdr%, map%, keys%, key$ - IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) - IF FNis_seq(ast%) THEN - IF FNis_empty(ast%) THEN =ast% - car% = FNEVAL(FNfirst(ast%), env%) - cdr% = FNeval_ast(FNrest(ast%), env%) - IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) - =FNalloc_pair(car%, cdr%) - ENDIF - IF FNis_hashmap(ast%) THEN - map% = FNempty_hashmap - keys% = FNhashmap_keys(ast%) - WHILE NOT FNis_empty(keys%) - key$ = FNunbox_string(FNfirst(keys%)) - map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) - keys% = FNrest(keys%) - ENDWHILE - =map% - ENDIF -=ast% - -DEF FNget_argv - PROCgc_enter - LOCAL argv%, rargv%, cmdptr%, arg$, len% - argv% = FNempty - IF !PAGE = &D7C1C7C5 THEN - REM Running under Brandy, so ARGC and ARGV$ are usable. - IF ARGC >= 1 THEN - FOR i% = ARGC TO 1 STEP -1 - argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) - NEXT i% - ENDIF - ELSE - IF (INKEY(-256) AND &F0) = &A0 THEN - rargv% = FNempty - REM Running under RISC OS - REM Vexingly, we can only get the command line that was passed to - REM the BASIC interpreter. This means that we need to extract - REM the arguments from that. Typically, we will have been started - REM with "BASIC -quit ". - - DIM q% 256 - SYS "OS_GetEnv" TO cmdptr% - WHILE ?cmdptr% >= 32 - SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% - q%?len% = 13 - rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) - ENDWHILE - REM Put argv back into the right order. - WHILE NOT FNis_empty(rargv%) - argv% = FNalloc_pair(FNfirst(rargv%), argv%) - rargv% = FNrest(rargv%) - ENDWHILE - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "BASIC" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "-quit" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip filename - ENDIF - ENDIF -=FNgc_exit(argv%) - - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 8 of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" +LIBRARY "env" +LIBRARY "core" + +PROCtypes_init + +repl_env% = FNalloc_environment(FNnil) +PROCcore_ns : REM This sets the data pointer +REPEAT + READ sym$, i% + IF sym$ <> "" THEN + PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) + ENDIF +UNTIL sym$ = "" + +REM Initial forms to evaluate +RESTORE +0 +DATA (def! not (fn* (a) (if a false true))) +DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) +DATA (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))))))) +DATA "" +REPEAT + READ form$ + IF form$ <> "" THEN val$ = FNrep(form$) +UNTIL form$ = "" + +argv% = FNget_argv + +IF FNis_empty(argv%) THEN + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) +ELSE + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) + val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") + END +ENDIF + +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNstarts_with(ast%, sym$) + LOCAL a0% + IF NOT FNis_list(ast%) THEN =FALSE + a0% = FNfirst(ast%) + IF NOT FNis_symbol(a0%) THEN =FALSE + =FNunbox_symbol(a0%) = sym$ + +DEF FNqq_elts(seq%) + LOCAL elt%, acc% + IF FNis_empty(seq%) THEN =FNempty + elt% = FNfirst(seq%) + acc% = FNqq_elts(FNrest(seq%)) + IF FNstarts_with(elt%, "splice-unquote") THEN + =FNalloc_list3(FNalloc_symbol("concat"), FNnth(elt%, 1), acc%) + ENDIF + =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(elt%), acc%) + +DEF FNquasiquote(ast%) + IF FNstarts_with(ast%, "unquote") THEN =FNnth(ast%, 1) + IF FNis_list(ast%) THEN =FNqq_elts(ast%) + IF FNis_vector(ast%) THEN + =FNalloc_list2(FNalloc_symbol("vec"), FNqq_elts(ast%)) + ENDIF + IF FNis_symbol(ast%) OR FNis_hashmap(ast%) THEN + =FNalloc_list2(FNalloc_symbol("quote"), ast%) + ENDIF + =ast% + +DEF FNis_macro_call(ast%, env%) + LOCAL car%, val% + IF NOT FNis_list(ast%) THEN =FALSE + car% = FNfirst(ast%) + IF NOT FNis_symbol(car%) THEN =FALSE + IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE + val% = FNenv_get(env%, car%) +=FNis_macro(val%) + +DEF FNmacroexpand(ast%, env%) + LOCAL mac%, macenv%, macast% + WHILE FNis_macro_call(ast%, env%) + REM PRINT "expanded ";FNpr_str(ast%, TRUE); + mac% = FNenv_get(env%, FNfirst(ast%)) + macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%)) + macast% = FNfn_ast(mac%) + ast% = FNEVAL(macast%, macenv%) + REM PRINT " to ";FNpr_str(ast%, TRUE) + ENDWHILE +=ast% + +DEF FNEVAL(ast%, env%) + PROCgc_enter +=FNgc_exit(FNEVAL_(ast%, env%)) + +DEF FNEVAL_(ast%, env%) + LOCAL car%, specialform%, val%, bindings% + REPEAT + PROCgc_keep_only2(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + IF FNis_empty(ast%) THEN =ast% + ast% = FNmacroexpand(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + specialform% = FALSE + IF FNis_symbol(car%) THEN + specialform% = TRUE + CASE FNunbox_symbol(car%) OF + REM Special forms + WHEN "def!" + val% = FNEVAL(FNnth(ast%, 2), env%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "defmacro!" + val% = FNEVAL(FNnth(ast%, 2), env%) + IF FNis_fn(val%) THEN val% = FNas_macro(val%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "let*" + env% = FNalloc_environment(env%) + bindings% = FNnth(ast%, 1) + WHILE NOT FNis_empty(bindings%) + PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) + bindings% = FNrest(FNrest(bindings%)) + ENDWHILE + ast% = FNnth(ast%, 2) + REM Loop round for tail-call optimisation. + WHEN "do" + REM The guide has us call FNeval_ast on the sub-list that excludes + REM the last element of ast%, but that's a bit painful without + REM native list slicing, so it's easier to just re-implement the + REM bit of FNeval_ast that we need. + ast% = FNrest(ast%) + WHILE NOT FNis_empty(FNrest(ast%)) + val% = FNEVAL(FNfirst(ast%), env%) + ast% = FNrest(ast%) + ENDWHILE + ast% = FNfirst(ast%) + WHEN "if" + IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN + ast% = FNnth(ast%, 2) + ELSE + IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) + ENDIF + REM Loop round for tail-call optimisation. + WHEN "fn*" + =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) + WHEN "quote" + =FNnth(ast%, 1) + WHEN "quasiquoteexpand" + = FNquasiquote(FNnth(ast%, 1)) + WHEN "quasiquote" + ast% = FNquasiquote(FNnth(ast%, 1)) + REM Loop round for tail-call optimisation + WHEN "macroexpand" + =FNmacroexpand(FNnth(ast%, 1), env%) + OTHERWISE + specialform% = FALSE + ENDCASE + ENDIF + IF NOT specialform% THEN + REM This is the "apply" part. + ast% = FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + IF FNis_corefn(car%) THEN + =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) + ENDIF + IF FNis_fn(car%) THEN + env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) + ast% = FNfn_ast(car%) + REM Loop round for tail-call optimisation. + ELSE + ERROR &40E80918, "Not a function" + ENDIF + ENDIF + UNTIL FALSE + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) + +DEF FNeval_ast(ast%, env%) + LOCAL val%, car%, cdr%, map%, keys%, key$ + IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) + IF FNis_seq(ast%) THEN + IF FNis_empty(ast%) THEN =ast% + car% = FNEVAL(FNfirst(ast%), env%) + cdr% = FNeval_ast(FNrest(ast%), env%) + IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) + =FNalloc_pair(car%, cdr%) + ENDIF + IF FNis_hashmap(ast%) THEN + map% = FNempty_hashmap + keys% = FNhashmap_keys(ast%) + WHILE NOT FNis_empty(keys%) + key$ = FNunbox_string(FNfirst(keys%)) + map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) + keys% = FNrest(keys%) + ENDWHILE + =map% + ENDIF +=ast% + +DEF FNget_argv + PROCgc_enter + LOCAL argv%, rargv%, cmdptr%, arg$, len% + argv% = FNempty + IF !PAGE = &D7C1C7C5 THEN + REM Running under Brandy, so ARGC and ARGV$ are usable. + IF ARGC >= 1 THEN + FOR i% = ARGC TO 1 STEP -1 + argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) + NEXT i% + ENDIF + ELSE + IF (INKEY(-256) AND &F0) = &A0 THEN + rargv% = FNempty + REM Running under RISC OS + REM Vexingly, we can only get the command line that was passed to + REM the BASIC interpreter. This means that we need to extract + REM the arguments from that. Typically, we will have been started + REM with "BASIC -quit ". + + DIM q% 256 + SYS "OS_GetEnv" TO cmdptr% + WHILE ?cmdptr% >= 32 + SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% + q%?len% = 13 + rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) + ENDWHILE + REM Put argv back into the right order. + WHILE NOT FNis_empty(rargv%) + argv% = FNalloc_pair(FNfirst(rargv%), argv%) + rargv% = FNrest(rargv%) + ENDWHILE + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "BASIC" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "-quit" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip filename + ENDIF + ENDIF +=FNgc_exit(argv%) + + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/step9_try.bas b/impls/bbc-basic/step9_try.bas index 61d1036f89..b30cb087f3 100644 --- a/impls/bbc-basic/step9_try.bas +++ b/impls/bbc-basic/step9_try.bas @@ -1,310 +1,310 @@ -REM Step 9 of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" -LIBRARY "env" -LIBRARY "core" - -PROCtypes_init - -repl_env% = FNalloc_environment(FNnil) -PROCcore_ns : REM This sets the data pointer -REPEAT - READ sym$, i% - IF sym$ <> "" THEN - PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) - ENDIF -UNTIL sym$ = "" - -REM Initial forms to evaluate -RESTORE +0 -DATA (def! not (fn* (a) (if a false true))) -DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) -DATA (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))))))) -DATA "" -REPEAT - READ form$ - IF form$ <> "" THEN val$ = FNrep(form$) -UNTIL form$ = "" - -argv% = FNget_argv - -IF FNis_empty(argv%) THEN - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) -ELSE - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) - val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") - END -ENDIF - -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNstarts_with(ast%, sym$) - LOCAL a0% - IF NOT FNis_list(ast%) THEN =FALSE - a0% = FNfirst(ast%) - IF NOT FNis_symbol(a0%) THEN =FALSE - =FNunbox_symbol(a0%) = sym$ - -DEF FNqq_elts(seq%) - LOCAL elt%, acc% - IF FNis_empty(seq%) THEN =FNempty - elt% = FNfirst(seq%) - acc% = FNqq_elts(FNrest(seq%)) - IF FNstarts_with(elt%, "splice-unquote") THEN - =FNalloc_list3(FNalloc_symbol("concat"), FNnth(elt%, 1), acc%) - ENDIF - =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(elt%), acc%) - -DEF FNquasiquote(ast%) - IF FNstarts_with(ast%, "unquote") THEN =FNnth(ast%, 1) - IF FNis_list(ast%) THEN =FNqq_elts(ast%) - IF FNis_vector(ast%) THEN - =FNalloc_list2(FNalloc_symbol("vec"), FNqq_elts(ast%)) - ENDIF - IF FNis_symbol(ast%) OR FNis_hashmap(ast%) THEN - =FNalloc_list2(FNalloc_symbol("quote"), ast%) - ENDIF - =ast% - -DEF FNis_macro_call(ast%, env%) - LOCAL car%, val% - IF NOT FNis_list(ast%) THEN =FALSE - car% = FNfirst(ast%) - IF NOT FNis_symbol(car%) THEN =FALSE - IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE - val% = FNenv_get(env%, car%) -=FNis_macro(val%) - -DEF FNmacroexpand(ast%, env%) - LOCAL mac%, macenv%, macast% - WHILE FNis_macro_call(ast%, env%) - REM PRINT "expanded ";FNpr_str(ast%, TRUE); - mac% = FNenv_get(env%, FNfirst(ast%)) - macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%)) - macast% = FNfn_ast(mac%) - ast% = FNEVAL(macast%, macenv%) - REM PRINT " to ";FNpr_str(ast%, TRUE) - ENDWHILE -=ast% - -DEF FNtry_catch(ast%, env%) - LOCAL is_error%, ret% - REM If there's no 'catch*' clause then we just evaluate the 'try*'. - IF FNcount(ast%) < 3 THEN =FNEVAL(FNnth(ast%, 1), env%) - IF FNunbox_symbol(FNfirst(FNnth(ast%, 2))) <> "catch*" THEN - ERROR &40E80924, "Invalid 'catch*' clause" - ENDIF - ret% = FNtry(FNnth(ast%, 1), env%, is_error%) - IF is_error% THEN =FNcatch(FNnth(ast%, 2), env%, ret%) -=ret% - -REM Evaluate an expression, returning either the result or an exception -REM raised during evaluation. is_error% indicates which it was. -DEF FNtry(ast%, env%, RETURN is_error%) - LOCAL trysav% - trysav% = FNgc_save - is_error% = FALSE - LOCAL ERROR - ON ERROR LOCAL is_error% = TRUE : =FNgc_restore(trysav%, FNwrap_exception) -=FNgc_restore(trysav%, FNEVAL(ast%, env%)) - -REM Return a mal value corresponding to the most-recently thrown exception. -DEF FNwrap_exception - REM There are three cases to handle. When the error was generated - REM by 'throw', we should return the value that 'throw' stashed in - REM MAL_ERR%. When the error was generated by mal, we should just - REM return the error message. When the error was generated by BASIC - REM or the OS, we should wrap the message and the error number in - REM a hash-map. - IF ERR = &40E80900 THEN =MAL_ERR% : REM Error generated by 'throw' - IF (ERR AND &FFFFFF00) = &40E80900 THEN =FNalloc_string(REPORT$) - LOCAL e% - e% = FNhashmap_set(FNempty_hashmap, "err", FNalloc_int(ERR)) -=FNhashmap_set(e%, "message", FNalloc_string(REPORT$)) - -DEF FNcatch(ast%, env%, err%) - LOCAL binds%, exprs% - binds% = FNalloc_pair(FNnth(ast%, 1), FNempty) - exprs% = FNalloc_pair(err%, FNempty) - env% = FNnew_env(env%, binds%, exprs%) -=FNEVAL(FNnth(ast%, 2), env%) - -DEF FNEVAL(ast%, env%) - PROCgc_enter -=FNgc_exit(FNEVAL_(ast%, env%)) - -DEF FNEVAL_(ast%, env%) - LOCAL car%, specialform%, val%, bindings% - REPEAT - PROCgc_keep_only2(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - IF FNis_empty(ast%) THEN =ast% - ast% = FNmacroexpand(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - specialform% = FALSE - IF FNis_symbol(car%) THEN - specialform% = TRUE - CASE FNunbox_symbol(car%) OF - REM Special forms - WHEN "def!" - val% = FNEVAL(FNnth(ast%, 2), env%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "defmacro!" - val% = FNEVAL(FNnth(ast%, 2), env%) - IF FNis_fn(val%) THEN val% = FNas_macro(val%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "let*" - env% = FNalloc_environment(env%) - bindings% = FNnth(ast%, 1) - WHILE NOT FNis_empty(bindings%) - PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) - bindings% = FNrest(FNrest(bindings%)) - ENDWHILE - ast% = FNnth(ast%, 2) - REM Loop round for tail-call optimisation. - WHEN "do" - REM The guide has us call FNeval_ast on the sub-list that excludes - REM the last element of ast%, but that's a bit painful without - REM native list slicing, so it's easier to just re-implement the - REM bit of FNeval_ast that we need. - ast% = FNrest(ast%) - WHILE NOT FNis_empty(FNrest(ast%)) - val% = FNEVAL(FNfirst(ast%), env%) - ast% = FNrest(ast%) - ENDWHILE - ast% = FNfirst(ast%) - WHEN "if" - IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN - ast% = FNnth(ast%, 2) - ELSE - IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) - ENDIF - REM Loop round for tail-call optimisation. - WHEN "fn*" - =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) - WHEN "quote" - =FNnth(ast%, 1) - WHEN "quasiquoteexpand" - = FNquasiquote(FNnth(ast%, 1)) - WHEN "quasiquote" - ast% = FNquasiquote(FNnth(ast%, 1)) - REM Loop round for tail-call optimisation - WHEN "macroexpand" - =FNmacroexpand(FNnth(ast%, 1), env%) - WHEN "try*" - =FNtry_catch(ast%, env%) - OTHERWISE - specialform% = FALSE - ENDCASE - ENDIF - IF NOT specialform% THEN - REM This is the "apply" part. - ast% = FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - IF FNis_corefn(car%) THEN - =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) - ENDIF - IF FNis_fn(car%) THEN - env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) - ast% = FNfn_ast(car%) - REM Loop round for tail-call optimisation. - ELSE - ERROR &40E80918, "Not a function" - ENDIF - ENDIF - UNTIL FALSE - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) - -DEF FNeval_ast(ast%, env%) - LOCAL val%, car%, cdr%, map%, keys%, key$ - IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) - IF FNis_seq(ast%) THEN - IF FNis_empty(ast%) THEN =ast% - car% = FNEVAL(FNfirst(ast%), env%) - cdr% = FNeval_ast(FNrest(ast%), env%) - IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) - =FNalloc_pair(car%, cdr%) - ENDIF - IF FNis_hashmap(ast%) THEN - map% = FNempty_hashmap - keys% = FNhashmap_keys(ast%) - WHILE NOT FNis_empty(keys%) - key$ = FNunbox_string(FNfirst(keys%)) - map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) - keys% = FNrest(keys%) - ENDWHILE - =map% - ENDIF -=ast% - -DEF FNget_argv - PROCgc_enter - LOCAL argv%, rargv%, cmdptr%, arg$, len% - argv% = FNempty - IF !PAGE = &D7C1C7C5 THEN - REM Running under Brandy, so ARGC and ARGV$ are usable. - IF ARGC >= 1 THEN - FOR i% = ARGC TO 1 STEP -1 - argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) - NEXT i% - ENDIF - ELSE - IF (INKEY(-256) AND &F0) = &A0 THEN - rargv% = FNempty - REM Running under RISC OS - REM Vexingly, we can only get the command line that was passed to - REM the BASIC interpreter. This means that we need to extract - REM the arguments from that. Typically, we will have been started - REM with "BASIC -quit ". - - DIM q% 256 - SYS "OS_GetEnv" TO cmdptr% - WHILE ?cmdptr% >= 32 - SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% - q%?len% = 13 - rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) - ENDWHILE - REM Put argv back into the right order. - WHILE NOT FNis_empty(rargv%) - argv% = FNalloc_pair(FNfirst(rargv%), argv%) - rargv% = FNrest(rargv%) - ENDWHILE - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "BASIC" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "-quit" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip filename - ENDIF - ENDIF -=FNgc_exit(argv%) - - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step 9 of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" +LIBRARY "env" +LIBRARY "core" + +PROCtypes_init + +repl_env% = FNalloc_environment(FNnil) +PROCcore_ns : REM This sets the data pointer +REPEAT + READ sym$, i% + IF sym$ <> "" THEN + PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) + ENDIF +UNTIL sym$ = "" + +REM Initial forms to evaluate +RESTORE +0 +DATA (def! not (fn* (a) (if a false true))) +DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) +DATA (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))))))) +DATA "" +REPEAT + READ form$ + IF form$ <> "" THEN val$ = FNrep(form$) +UNTIL form$ = "" + +argv% = FNget_argv + +IF FNis_empty(argv%) THEN + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) +ELSE + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) + val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") + END +ENDIF + +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNstarts_with(ast%, sym$) + LOCAL a0% + IF NOT FNis_list(ast%) THEN =FALSE + a0% = FNfirst(ast%) + IF NOT FNis_symbol(a0%) THEN =FALSE + =FNunbox_symbol(a0%) = sym$ + +DEF FNqq_elts(seq%) + LOCAL elt%, acc% + IF FNis_empty(seq%) THEN =FNempty + elt% = FNfirst(seq%) + acc% = FNqq_elts(FNrest(seq%)) + IF FNstarts_with(elt%, "splice-unquote") THEN + =FNalloc_list3(FNalloc_symbol("concat"), FNnth(elt%, 1), acc%) + ENDIF + =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(elt%), acc%) + +DEF FNquasiquote(ast%) + IF FNstarts_with(ast%, "unquote") THEN =FNnth(ast%, 1) + IF FNis_list(ast%) THEN =FNqq_elts(ast%) + IF FNis_vector(ast%) THEN + =FNalloc_list2(FNalloc_symbol("vec"), FNqq_elts(ast%)) + ENDIF + IF FNis_symbol(ast%) OR FNis_hashmap(ast%) THEN + =FNalloc_list2(FNalloc_symbol("quote"), ast%) + ENDIF + =ast% + +DEF FNis_macro_call(ast%, env%) + LOCAL car%, val% + IF NOT FNis_list(ast%) THEN =FALSE + car% = FNfirst(ast%) + IF NOT FNis_symbol(car%) THEN =FALSE + IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE + val% = FNenv_get(env%, car%) +=FNis_macro(val%) + +DEF FNmacroexpand(ast%, env%) + LOCAL mac%, macenv%, macast% + WHILE FNis_macro_call(ast%, env%) + REM PRINT "expanded ";FNpr_str(ast%, TRUE); + mac% = FNenv_get(env%, FNfirst(ast%)) + macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%)) + macast% = FNfn_ast(mac%) + ast% = FNEVAL(macast%, macenv%) + REM PRINT " to ";FNpr_str(ast%, TRUE) + ENDWHILE +=ast% + +DEF FNtry_catch(ast%, env%) + LOCAL is_error%, ret% + REM If there's no 'catch*' clause then we just evaluate the 'try*'. + IF FNcount(ast%) < 3 THEN =FNEVAL(FNnth(ast%, 1), env%) + IF FNunbox_symbol(FNfirst(FNnth(ast%, 2))) <> "catch*" THEN + ERROR &40E80924, "Invalid 'catch*' clause" + ENDIF + ret% = FNtry(FNnth(ast%, 1), env%, is_error%) + IF is_error% THEN =FNcatch(FNnth(ast%, 2), env%, ret%) +=ret% + +REM Evaluate an expression, returning either the result or an exception +REM raised during evaluation. is_error% indicates which it was. +DEF FNtry(ast%, env%, RETURN is_error%) + LOCAL trysav% + trysav% = FNgc_save + is_error% = FALSE + LOCAL ERROR + ON ERROR LOCAL is_error% = TRUE : =FNgc_restore(trysav%, FNwrap_exception) +=FNgc_restore(trysav%, FNEVAL(ast%, env%)) + +REM Return a mal value corresponding to the most-recently thrown exception. +DEF FNwrap_exception + REM There are three cases to handle. When the error was generated + REM by 'throw', we should return the value that 'throw' stashed in + REM MAL_ERR%. When the error was generated by mal, we should just + REM return the error message. When the error was generated by BASIC + REM or the OS, we should wrap the message and the error number in + REM a hash-map. + IF ERR = &40E80900 THEN =MAL_ERR% : REM Error generated by 'throw' + IF (ERR AND &FFFFFF00) = &40E80900 THEN =FNalloc_string(REPORT$) + LOCAL e% + e% = FNhashmap_set(FNempty_hashmap, "err", FNalloc_int(ERR)) +=FNhashmap_set(e%, "message", FNalloc_string(REPORT$)) + +DEF FNcatch(ast%, env%, err%) + LOCAL binds%, exprs% + binds% = FNalloc_pair(FNnth(ast%, 1), FNempty) + exprs% = FNalloc_pair(err%, FNempty) + env% = FNnew_env(env%, binds%, exprs%) +=FNEVAL(FNnth(ast%, 2), env%) + +DEF FNEVAL(ast%, env%) + PROCgc_enter +=FNgc_exit(FNEVAL_(ast%, env%)) + +DEF FNEVAL_(ast%, env%) + LOCAL car%, specialform%, val%, bindings% + REPEAT + PROCgc_keep_only2(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + IF FNis_empty(ast%) THEN =ast% + ast% = FNmacroexpand(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + specialform% = FALSE + IF FNis_symbol(car%) THEN + specialform% = TRUE + CASE FNunbox_symbol(car%) OF + REM Special forms + WHEN "def!" + val% = FNEVAL(FNnth(ast%, 2), env%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "defmacro!" + val% = FNEVAL(FNnth(ast%, 2), env%) + IF FNis_fn(val%) THEN val% = FNas_macro(val%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "let*" + env% = FNalloc_environment(env%) + bindings% = FNnth(ast%, 1) + WHILE NOT FNis_empty(bindings%) + PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) + bindings% = FNrest(FNrest(bindings%)) + ENDWHILE + ast% = FNnth(ast%, 2) + REM Loop round for tail-call optimisation. + WHEN "do" + REM The guide has us call FNeval_ast on the sub-list that excludes + REM the last element of ast%, but that's a bit painful without + REM native list slicing, so it's easier to just re-implement the + REM bit of FNeval_ast that we need. + ast% = FNrest(ast%) + WHILE NOT FNis_empty(FNrest(ast%)) + val% = FNEVAL(FNfirst(ast%), env%) + ast% = FNrest(ast%) + ENDWHILE + ast% = FNfirst(ast%) + WHEN "if" + IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN + ast% = FNnth(ast%, 2) + ELSE + IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) + ENDIF + REM Loop round for tail-call optimisation. + WHEN "fn*" + =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) + WHEN "quote" + =FNnth(ast%, 1) + WHEN "quasiquoteexpand" + = FNquasiquote(FNnth(ast%, 1)) + WHEN "quasiquote" + ast% = FNquasiquote(FNnth(ast%, 1)) + REM Loop round for tail-call optimisation + WHEN "macroexpand" + =FNmacroexpand(FNnth(ast%, 1), env%) + WHEN "try*" + =FNtry_catch(ast%, env%) + OTHERWISE + specialform% = FALSE + ENDCASE + ENDIF + IF NOT specialform% THEN + REM This is the "apply" part. + ast% = FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + IF FNis_corefn(car%) THEN + =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) + ENDIF + IF FNis_fn(car%) THEN + env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) + ast% = FNfn_ast(car%) + REM Loop round for tail-call optimisation. + ELSE + ERROR &40E80918, "Not a function" + ENDIF + ENDIF + UNTIL FALSE + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) + +DEF FNeval_ast(ast%, env%) + LOCAL val%, car%, cdr%, map%, keys%, key$ + IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) + IF FNis_seq(ast%) THEN + IF FNis_empty(ast%) THEN =ast% + car% = FNEVAL(FNfirst(ast%), env%) + cdr% = FNeval_ast(FNrest(ast%), env%) + IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) + =FNalloc_pair(car%, cdr%) + ENDIF + IF FNis_hashmap(ast%) THEN + map% = FNempty_hashmap + keys% = FNhashmap_keys(ast%) + WHILE NOT FNis_empty(keys%) + key$ = FNunbox_string(FNfirst(keys%)) + map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) + keys% = FNrest(keys%) + ENDWHILE + =map% + ENDIF +=ast% + +DEF FNget_argv + PROCgc_enter + LOCAL argv%, rargv%, cmdptr%, arg$, len% + argv% = FNempty + IF !PAGE = &D7C1C7C5 THEN + REM Running under Brandy, so ARGC and ARGV$ are usable. + IF ARGC >= 1 THEN + FOR i% = ARGC TO 1 STEP -1 + argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) + NEXT i% + ENDIF + ELSE + IF (INKEY(-256) AND &F0) = &A0 THEN + rargv% = FNempty + REM Running under RISC OS + REM Vexingly, we can only get the command line that was passed to + REM the BASIC interpreter. This means that we need to extract + REM the arguments from that. Typically, we will have been started + REM with "BASIC -quit ". + + DIM q% 256 + SYS "OS_GetEnv" TO cmdptr% + WHILE ?cmdptr% >= 32 + SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% + q%?len% = 13 + rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) + ENDWHILE + REM Put argv back into the right order. + WHILE NOT FNis_empty(rargv%) + argv% = FNalloc_pair(FNfirst(rargv%), argv%) + rargv% = FNrest(rargv%) + ENDWHILE + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "BASIC" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "-quit" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip filename + ENDIF + ENDIF +=FNgc_exit(argv%) + + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/stepA_mal.bas b/impls/bbc-basic/stepA_mal.bas index 2ca19477fb..d469eb7af0 100644 --- a/impls/bbc-basic/stepA_mal.bas +++ b/impls/bbc-basic/stepA_mal.bas @@ -1,312 +1,312 @@ -REM Step A of mal in BBC BASIC - -LIBRARY "types" -LIBRARY "reader" -LIBRARY "printer" -LIBRARY "env" -LIBRARY "core" - -PROCtypes_init - -repl_env% = FNalloc_environment(FNnil) -PROCcore_ns : REM This sets the data pointer -REPEAT - READ sym$, i% - IF sym$ <> "" THEN - PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) - ENDIF -UNTIL sym$ = "" - -REM Initial forms to evaluate -RESTORE +0 -DATA (def! not (fn* (a) (if a false true))) -DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) -DATA (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))))))) -DATA (def! *host-language* "BBC BASIC V") -DATA "" -REPEAT - READ form$ - IF form$ <> "" THEN val$ = FNrep(form$) -UNTIL form$ = "" - -argv% = FNget_argv - -IF FNis_empty(argv%) THEN - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) -ELSE - PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) - val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") - END -ENDIF - -val$ = FNrep("(println (str ""Mal ["" *host-language* ""]""))") -sav% = FNgc_save -REPEAT - REM Catch all errors apart from "Escape". - ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ - PROCgc_restore(sav%) - sav% = FNgc_save - PRINT "user> "; - LINE INPUT "" line$ - PRINT FNrep(line$) -UNTIL FALSE - -END - -DEF FNREAD(a$) -=FNread_str(FNalloc_string(a$)) - -DEF FNstarts_with(ast%, sym$) - LOCAL a0% - IF NOT FNis_list(ast%) THEN =FALSE - a0% = FNfirst(ast%) - IF NOT FNis_symbol(a0%) THEN =FALSE - =FNunbox_symbol(a0%) = sym$ - -DEF FNqq_elts(seq%) - LOCAL elt%, acc% - IF FNis_empty(seq%) THEN =FNempty - elt% = FNfirst(seq%) - acc% = FNqq_elts(FNrest(seq%)) - IF FNstarts_with(elt%, "splice-unquote") THEN - =FNalloc_list3(FNalloc_symbol("concat"), FNnth(elt%, 1), acc%) - ENDIF - =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(elt%), acc%) - -DEF FNquasiquote(ast%) - IF FNstarts_with(ast%, "unquote") THEN =FNnth(ast%, 1) - IF FNis_list(ast%) THEN =FNqq_elts(ast%) - IF FNis_vector(ast%) THEN - =FNalloc_list2(FNalloc_symbol("vec"), FNqq_elts(ast%)) - ENDIF - IF FNis_symbol(ast%) OR FNis_hashmap(ast%) THEN - =FNalloc_list2(FNalloc_symbol("quote"), ast%) - ENDIF - =ast% - -DEF FNis_macro_call(ast%, env%) - LOCAL car%, val% - IF NOT FNis_list(ast%) THEN =FALSE - car% = FNfirst(ast%) - IF NOT FNis_symbol(car%) THEN =FALSE - IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE - val% = FNenv_get(env%, car%) -=FNis_macro(val%) - -DEF FNmacroexpand(ast%, env%) - LOCAL mac%, macenv%, macast% - WHILE FNis_macro_call(ast%, env%) - REM PRINT "expanded ";FNpr_str(ast%, TRUE); - mac% = FNenv_get(env%, FNfirst(ast%)) - macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%)) - macast% = FNfn_ast(mac%) - ast% = FNEVAL(macast%, macenv%) - REM PRINT " to ";FNpr_str(ast%, TRUE) - ENDWHILE -=ast% - -DEF FNtry_catch(ast%, env%) - LOCAL is_error%, ret% - REM If there's no 'catch*' clause then we just evaluate the 'try*'. - IF FNcount(ast%) < 3 THEN =FNEVAL(FNnth(ast%, 1), env%) - IF FNunbox_symbol(FNfirst(FNnth(ast%, 2))) <> "catch*" THEN - ERROR &40E80924, "Invalid 'catch*' clause" - ENDIF - ret% = FNtry(FNnth(ast%, 1), env%, is_error%) - IF is_error% THEN =FNcatch(FNnth(ast%, 2), env%, ret%) -=ret% - -REM Evaluate an expression, returning either the result or an exception -REM raised during evaluation. is_error% indicates which it was. -DEF FNtry(ast%, env%, RETURN is_error%) - LOCAL trysav% - trysav% = FNgc_save - is_error% = FALSE - LOCAL ERROR - ON ERROR LOCAL is_error% = TRUE : =FNgc_restore(trysav%, FNwrap_exception) -=FNgc_restore(trysav%, FNEVAL(ast%, env%)) - -REM Return a mal value corresponding to the most-recently thrown exception. -DEF FNwrap_exception - REM There are three cases to handle. When the error was generated - REM by 'throw', we should return the value that 'throw' stashed in - REM MAL_ERR%. When the error was generated by mal, we should just - REM return the error message. When the error was generated by BASIC - REM or the OS, we should wrap the message and the error number in - REM a hash-map. - IF ERR = &40E80900 THEN =MAL_ERR% : REM Error generated by 'throw' - IF (ERR AND &FFFFFF00) = &40E80900 THEN =FNalloc_string(REPORT$) - LOCAL e% - e% = FNhashmap_set(FNempty_hashmap, "err", FNalloc_int(ERR)) -=FNhashmap_set(e%, "message", FNalloc_string(REPORT$)) - -DEF FNcatch(ast%, env%, err%) - LOCAL binds%, exprs% - binds% = FNalloc_pair(FNnth(ast%, 1), FNempty) - exprs% = FNalloc_pair(err%, FNempty) - env% = FNnew_env(env%, binds%, exprs%) -=FNEVAL(FNnth(ast%, 2), env%) - -DEF FNEVAL(ast%, env%) - PROCgc_enter -=FNgc_exit(FNEVAL_(ast%, env%)) - -DEF FNEVAL_(ast%, env%) - LOCAL car%, specialform%, val%, bindings% - REPEAT - PROCgc_keep_only2(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - IF FNis_empty(ast%) THEN =ast% - ast% = FNmacroexpand(ast%, env%) - IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - specialform% = FALSE - IF FNis_symbol(car%) THEN - specialform% = TRUE - CASE FNunbox_symbol(car%) OF - REM Special forms - WHEN "def!" - val% = FNEVAL(FNnth(ast%, 2), env%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "defmacro!" - val% = FNEVAL(FNnth(ast%, 2), env%) - IF FNis_fn(val%) THEN val% = FNas_macro(val%) - PROCenv_set(env%, FNnth(ast%, 1), val%) - =val% - WHEN "let*" - env% = FNalloc_environment(env%) - bindings% = FNnth(ast%, 1) - WHILE NOT FNis_empty(bindings%) - PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) - bindings% = FNrest(FNrest(bindings%)) - ENDWHILE - ast% = FNnth(ast%, 2) - REM Loop round for tail-call optimisation. - WHEN "do" - REM The guide has us call FNeval_ast on the sub-list that excludes - REM the last element of ast%, but that's a bit painful without - REM native list slicing, so it's easier to just re-implement the - REM bit of FNeval_ast that we need. - ast% = FNrest(ast%) - WHILE NOT FNis_empty(FNrest(ast%)) - val% = FNEVAL(FNfirst(ast%), env%) - ast% = FNrest(ast%) - ENDWHILE - ast% = FNfirst(ast%) - WHEN "if" - IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN - ast% = FNnth(ast%, 2) - ELSE - IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) - ENDIF - REM Loop round for tail-call optimisation. - WHEN "fn*" - =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) - WHEN "quote" - =FNnth(ast%, 1) - WHEN "quasiquoteexpand" - = FNquasiquote(FNnth(ast%, 1)) - WHEN "quasiquote" - ast% = FNquasiquote(FNnth(ast%, 1)) - REM Loop round for tail-call optimisation - WHEN "macroexpand" - =FNmacroexpand(FNnth(ast%, 1), env%) - WHEN "try*" - =FNtry_catch(ast%, env%) - OTHERWISE - specialform% = FALSE - ENDCASE - ENDIF - IF NOT specialform% THEN - REM This is the "apply" part. - ast% = FNeval_ast(ast%, env%) - car% = FNfirst(ast%) - IF FNis_corefn(car%) THEN - =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) - ENDIF - IF FNis_fn(car%) THEN - env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) - ast% = FNfn_ast(car%) - REM Loop round for tail-call optimisation. - ELSE - ERROR &40E80918, "Not a function" - ENDIF - ENDIF - UNTIL FALSE - -DEF FNPRINT(a%) -=FNunbox_string(FNpr_str(a%, TRUE)) - -DEF FNrep(a$) -=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) - -DEF FNeval_ast(ast%, env%) - LOCAL val%, car%, cdr%, map%, keys%, key$ - IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) - IF FNis_seq(ast%) THEN - IF FNis_empty(ast%) THEN =ast% - car% = FNEVAL(FNfirst(ast%), env%) - cdr% = FNeval_ast(FNrest(ast%), env%) - IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) - =FNalloc_pair(car%, cdr%) - ENDIF - IF FNis_hashmap(ast%) THEN - map% = FNempty_hashmap - keys% = FNhashmap_keys(ast%) - WHILE NOT FNis_empty(keys%) - key$ = FNunbox_string(FNfirst(keys%)) - map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) - keys% = FNrest(keys%) - ENDWHILE - =map% - ENDIF -=ast% - -DEF FNget_argv - PROCgc_enter - LOCAL argv%, rargv%, cmdptr%, arg$, len% - argv% = FNempty - IF !PAGE = &D7C1C7C5 THEN - REM Running under Brandy, so ARGC and ARGV$ are usable. - IF ARGC >= 1 THEN - FOR i% = ARGC TO 1 STEP -1 - argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) - NEXT i% - ENDIF - ELSE - IF (INKEY(-256) AND &F0) = &A0 THEN - rargv% = FNempty - REM Running under RISC OS - REM Vexingly, we can only get the command line that was passed to - REM the BASIC interpreter. This means that we need to extract - REM the arguments from that. Typically, we will have been started - REM with "BASIC -quit ". - - DIM q% 256 - SYS "OS_GetEnv" TO cmdptr% - WHILE ?cmdptr% >= 32 - SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% - q%?len% = 13 - rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) - ENDWHILE - REM Put argv back into the right order. - WHILE NOT FNis_empty(rargv%) - argv% = FNalloc_pair(FNfirst(rargv%), argv%) - rargv% = FNrest(rargv%) - ENDWHILE - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "BASIC" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip "-quit" - IF FNis_empty(argv%) THEN =FNgc_exit(argv%) - argv% = FNrest(argv%) : REM skip filename - ENDIF - ENDIF -=FNgc_exit(argv%) - - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM Step A of mal in BBC BASIC + +LIBRARY "types" +LIBRARY "reader" +LIBRARY "printer" +LIBRARY "env" +LIBRARY "core" + +PROCtypes_init + +repl_env% = FNalloc_environment(FNnil) +PROCcore_ns : REM This sets the data pointer +REPEAT + READ sym$, i% + IF sym$ <> "" THEN + PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%)) + ENDIF +UNTIL sym$ = "" + +REM Initial forms to evaluate +RESTORE +0 +DATA (def! not (fn* (a) (if a false true))) +DATA (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) +DATA (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))))))) +DATA (def! *host-language* "BBC BASIC V") +DATA "" +REPEAT + READ form$ + IF form$ <> "" THEN val$ = FNrep(form$) +UNTIL form$ = "" + +argv% = FNget_argv + +IF FNis_empty(argv%) THEN + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty) +ELSE + PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%)) + val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")") + END +ENDIF + +val$ = FNrep("(println (str ""Mal ["" *host-language* ""]""))") +sav% = FNgc_save +REPEAT + REM Catch all errors apart from "Escape". + ON ERROR LOCAL IF ERR = 17 ON ERROR OFF: ERROR ERR, REPORT$ ELSE PRINT REPORT$ + PROCgc_restore(sav%) + sav% = FNgc_save + PRINT "user> "; + LINE INPUT "" line$ + PRINT FNrep(line$) +UNTIL FALSE + +END + +DEF FNREAD(a$) +=FNread_str(FNalloc_string(a$)) + +DEF FNstarts_with(ast%, sym$) + LOCAL a0% + IF NOT FNis_list(ast%) THEN =FALSE + a0% = FNfirst(ast%) + IF NOT FNis_symbol(a0%) THEN =FALSE + =FNunbox_symbol(a0%) = sym$ + +DEF FNqq_elts(seq%) + LOCAL elt%, acc% + IF FNis_empty(seq%) THEN =FNempty + elt% = FNfirst(seq%) + acc% = FNqq_elts(FNrest(seq%)) + IF FNstarts_with(elt%, "splice-unquote") THEN + =FNalloc_list3(FNalloc_symbol("concat"), FNnth(elt%, 1), acc%) + ENDIF + =FNalloc_list3(FNalloc_symbol("cons"), FNquasiquote(elt%), acc%) + +DEF FNquasiquote(ast%) + IF FNstarts_with(ast%, "unquote") THEN =FNnth(ast%, 1) + IF FNis_list(ast%) THEN =FNqq_elts(ast%) + IF FNis_vector(ast%) THEN + =FNalloc_list2(FNalloc_symbol("vec"), FNqq_elts(ast%)) + ENDIF + IF FNis_symbol(ast%) OR FNis_hashmap(ast%) THEN + =FNalloc_list2(FNalloc_symbol("quote"), ast%) + ENDIF + =ast% + +DEF FNis_macro_call(ast%, env%) + LOCAL car%, val% + IF NOT FNis_list(ast%) THEN =FALSE + car% = FNfirst(ast%) + IF NOT FNis_symbol(car%) THEN =FALSE + IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE + val% = FNenv_get(env%, car%) +=FNis_macro(val%) + +DEF FNmacroexpand(ast%, env%) + LOCAL mac%, macenv%, macast% + WHILE FNis_macro_call(ast%, env%) + REM PRINT "expanded ";FNpr_str(ast%, TRUE); + mac% = FNenv_get(env%, FNfirst(ast%)) + macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%)) + macast% = FNfn_ast(mac%) + ast% = FNEVAL(macast%, macenv%) + REM PRINT " to ";FNpr_str(ast%, TRUE) + ENDWHILE +=ast% + +DEF FNtry_catch(ast%, env%) + LOCAL is_error%, ret% + REM If there's no 'catch*' clause then we just evaluate the 'try*'. + IF FNcount(ast%) < 3 THEN =FNEVAL(FNnth(ast%, 1), env%) + IF FNunbox_symbol(FNfirst(FNnth(ast%, 2))) <> "catch*" THEN + ERROR &40E80924, "Invalid 'catch*' clause" + ENDIF + ret% = FNtry(FNnth(ast%, 1), env%, is_error%) + IF is_error% THEN =FNcatch(FNnth(ast%, 2), env%, ret%) +=ret% + +REM Evaluate an expression, returning either the result or an exception +REM raised during evaluation. is_error% indicates which it was. +DEF FNtry(ast%, env%, RETURN is_error%) + LOCAL trysav% + trysav% = FNgc_save + is_error% = FALSE + LOCAL ERROR + ON ERROR LOCAL is_error% = TRUE : =FNgc_restore(trysav%, FNwrap_exception) +=FNgc_restore(trysav%, FNEVAL(ast%, env%)) + +REM Return a mal value corresponding to the most-recently thrown exception. +DEF FNwrap_exception + REM There are three cases to handle. When the error was generated + REM by 'throw', we should return the value that 'throw' stashed in + REM MAL_ERR%. When the error was generated by mal, we should just + REM return the error message. When the error was generated by BASIC + REM or the OS, we should wrap the message and the error number in + REM a hash-map. + IF ERR = &40E80900 THEN =MAL_ERR% : REM Error generated by 'throw' + IF (ERR AND &FFFFFF00) = &40E80900 THEN =FNalloc_string(REPORT$) + LOCAL e% + e% = FNhashmap_set(FNempty_hashmap, "err", FNalloc_int(ERR)) +=FNhashmap_set(e%, "message", FNalloc_string(REPORT$)) + +DEF FNcatch(ast%, env%, err%) + LOCAL binds%, exprs% + binds% = FNalloc_pair(FNnth(ast%, 1), FNempty) + exprs% = FNalloc_pair(err%, FNempty) + env% = FNnew_env(env%, binds%, exprs%) +=FNEVAL(FNnth(ast%, 2), env%) + +DEF FNEVAL(ast%, env%) + PROCgc_enter +=FNgc_exit(FNEVAL_(ast%, env%)) + +DEF FNEVAL_(ast%, env%) + LOCAL car%, specialform%, val%, bindings% + REPEAT + PROCgc_keep_only2(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + IF FNis_empty(ast%) THEN =ast% + ast% = FNmacroexpand(ast%, env%) + IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + specialform% = FALSE + IF FNis_symbol(car%) THEN + specialform% = TRUE + CASE FNunbox_symbol(car%) OF + REM Special forms + WHEN "def!" + val% = FNEVAL(FNnth(ast%, 2), env%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "defmacro!" + val% = FNEVAL(FNnth(ast%, 2), env%) + IF FNis_fn(val%) THEN val% = FNas_macro(val%) + PROCenv_set(env%, FNnth(ast%, 1), val%) + =val% + WHEN "let*" + env% = FNalloc_environment(env%) + bindings% = FNnth(ast%, 1) + WHILE NOT FNis_empty(bindings%) + PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%)) + bindings% = FNrest(FNrest(bindings%)) + ENDWHILE + ast% = FNnth(ast%, 2) + REM Loop round for tail-call optimisation. + WHEN "do" + REM The guide has us call FNeval_ast on the sub-list that excludes + REM the last element of ast%, but that's a bit painful without + REM native list slicing, so it's easier to just re-implement the + REM bit of FNeval_ast that we need. + ast% = FNrest(ast%) + WHILE NOT FNis_empty(FNrest(ast%)) + val% = FNEVAL(FNfirst(ast%), env%) + ast% = FNrest(ast%) + ENDWHILE + ast% = FNfirst(ast%) + WHEN "if" + IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN + ast% = FNnth(ast%, 2) + ELSE + IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3) + ENDIF + REM Loop round for tail-call optimisation. + WHEN "fn*" + =FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%) + WHEN "quote" + =FNnth(ast%, 1) + WHEN "quasiquoteexpand" + = FNquasiquote(FNnth(ast%, 1)) + WHEN "quasiquote" + ast% = FNquasiquote(FNnth(ast%, 1)) + REM Loop round for tail-call optimisation + WHEN "macroexpand" + =FNmacroexpand(FNnth(ast%, 1), env%) + WHEN "try*" + =FNtry_catch(ast%, env%) + OTHERWISE + specialform% = FALSE + ENDCASE + ENDIF + IF NOT specialform% THEN + REM This is the "apply" part. + ast% = FNeval_ast(ast%, env%) + car% = FNfirst(ast%) + IF FNis_corefn(car%) THEN + =FNcore_call(FNunbox_corefn(car%), FNrest(ast%)) + ENDIF + IF FNis_fn(car%) THEN + env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%)) + ast% = FNfn_ast(car%) + REM Loop round for tail-call optimisation. + ELSE + ERROR &40E80918, "Not a function" + ENDIF + ENDIF + UNTIL FALSE + +DEF FNPRINT(a%) +=FNunbox_string(FNpr_str(a%, TRUE)) + +DEF FNrep(a$) +=FNPRINT(FNEVAL(FNREAD(a$), repl_env%)) + +DEF FNeval_ast(ast%, env%) + LOCAL val%, car%, cdr%, map%, keys%, key$ + IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%) + IF FNis_seq(ast%) THEN + IF FNis_empty(ast%) THEN =ast% + car% = FNEVAL(FNfirst(ast%), env%) + cdr% = FNeval_ast(FNrest(ast%), env%) + IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%) + =FNalloc_pair(car%, cdr%) + ENDIF + IF FNis_hashmap(ast%) THEN + map% = FNempty_hashmap + keys% = FNhashmap_keys(ast%) + WHILE NOT FNis_empty(keys%) + key$ = FNunbox_string(FNfirst(keys%)) + map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%)) + keys% = FNrest(keys%) + ENDWHILE + =map% + ENDIF +=ast% + +DEF FNget_argv + PROCgc_enter + LOCAL argv%, rargv%, cmdptr%, arg$, len% + argv% = FNempty + IF !PAGE = &D7C1C7C5 THEN + REM Running under Brandy, so ARGC and ARGV$ are usable. + IF ARGC >= 1 THEN + FOR i% = ARGC TO 1 STEP -1 + argv% = FNalloc_pair(FNalloc_string(ARGV$(i%)), argv%) + NEXT i% + ENDIF + ELSE + IF (INKEY(-256) AND &F0) = &A0 THEN + rargv% = FNempty + REM Running under RISC OS + REM Vexingly, we can only get the command line that was passed to + REM the BASIC interpreter. This means that we need to extract + REM the arguments from that. Typically, we will have been started + REM with "BASIC -quit ". + + DIM q% 256 + SYS "OS_GetEnv" TO cmdptr% + WHILE ?cmdptr% >= 32 + SYS "OS_GSTrans", cmdptr%, q%, &20000000 + 256 TO cmdptr%, , len% + q%?len% = 13 + rargv% = FNalloc_pair(FNalloc_string($q%), rargv%) + ENDWHILE + REM Put argv back into the right order. + WHILE NOT FNis_empty(rargv%) + argv% = FNalloc_pair(FNfirst(rargv%), argv%) + rargv% = FNrest(rargv%) + ENDWHILE + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "BASIC" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + IF FNunbox_string(FNfirst(argv%)) <> "-quit" THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip "-quit" + IF FNis_empty(argv%) THEN =FNgc_exit(argv%) + argv% = FNrest(argv%) : REM skip filename + ENDIF + ENDIF +=FNgc_exit(argv%) + + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/bbc-basic/types.bas b/impls/bbc-basic/types.bas index b1f3413fb6..083af93d83 100644 --- a/impls/bbc-basic/types.bas +++ b/impls/bbc-basic/types.bas @@ -1,709 +1,709 @@ -REM > types library for mal in BBC BASIC - -REM This library should be the only thing that understands the -REM implementation of mal data types in BBC BASIC. All other -REM code should use routines in this library to access them. - -REM As far as other code is concerned, a mal object is just an -REM opaque 32-bit integer, which might be a pointer, or might not. - -REM All mal objects live in an array, Z%(), with string values held -REM in a parallel array, Z$(). There's one row in Z%(), and one -REM entry in Z$(), for each mal object. - -REM Z%(x,0) holds the type of an object and other small amounts of -REM information. The bottom bit indicates the semantics of Z%(x,1): - -REM &01 : Z%(x,1) is a pointer into Z%() - -REM Z%(x,2) and Z%(x,3) are always pointers into Z%(), to 'nil' if nothing -REM else. - -REM The &40 bit is used to distinguish empty lists, vectors and hash-maps. -REM The &80 bit distinguishes vectors from lists and macros from functions. - -REM sS%() is a shadow stack, used to keep track of which mal values might -REM be referenced from local variables at a given depth of the BASIC call -REM stack. It grows upwards. sSP% points to the first unused word. sFP% -REM points to the start of the current shadow stack frame. The first word -REM of each shadow stack frame is the saved value of sFP%. The rest are -REM mal values. - -REM Types are: -REM &00 nil -REM &04 boolean -REM &08 integer -REM &0C core function -REM &01 atom -REM &05 free block -REM &09 list/vector (each object is a cons cell) -REM &0D environment -REM &11 hash-map internal node -REM &15 mal function (first part) -REM &19 mal function (second part) -REM &02 string/keyword -REM &06 symbol -REM &0A hash-map leaf node - -REM Formats of individual objects are defined below. - -DEF PROCtypes_init - REM Mal's heap has to be statically dimensioned, but we also - REM need to leave enough space for BASIC's stack and heap. - REM The BASIC heap is where all strings live. - REM - REM Each row of Z%() consumes 16 bytes. The size of each entry - REM in Z$() varies by platform: 5 bytes in ARM BBC BASIC V, - REM 8 bytes in Brandy on a 32-bit system, 16 bytes in Brandy on - REM a 64-bit system. - - DIM Z%((HIMEM-LOMEM)/110,3), Z$((HIMEM-LOMEM)/110) - DIM sS%((HIMEM-LOMEM)/64) - - Z%(1,0) = &04 : REM false - Z%(2,0) = &04 : Z%(2,1) = TRUE : REM true - Z%(3,0) = &49 : Z%(3,1) = 3 : REM empty list - Z%(4,0) = &C9 : Z%(4,1) = 4 : REM empty vector - Z%(5,0) = &51 : REM empty hashmap - next_Z% = 6 - sSP% = 1 - sFP% = 0 - F% = 0 -ENDPROC - -DEF FNtype_of(val%) -=Z%(val%,0) AND &1F - -DEF PROCgc_enter - REM PRINT ;sFP%; - sS%(sSP%) = sFP% - sFP% = sSP% - sSP% += 1 - REM PRINT " >>> ";sFP% -ENDPROC - -REM FNgc_save is equivalent to PROCgc_enter except that it returns a -REM value that can be passed to PROCgc_restore to pop all the stack -REM frames back to (and including) the one pushed by FNgc_save. -DEF FNgc_save - PROCgc_enter -=sFP% - -DEF PROCgc_exit - REM PRINT ;sS%(sFP%);" <<< ";sFP% - sSP% = sFP% - sFP% = sS%(sFP%) -ENDPROC - -DEF PROCgc_restore(oldFP%) - sFP% = oldFP% - REM PRINT "!!! FP reset" - PROCgc_exit -ENDPROC - -DEF FNref_local(val%) - sS%(sSP%) = val% - sSP% += 1 -=val% - -DEF FNgc_exit(val%) - PROCgc_exit -=FNref_local(val%) - -DEF FNgc_restore(oldFP%, val%) - PROCgc_restore(oldFP%) -=FNref_local(val%) - -DEF PROCgc_keep_only2(val1%, val2%) - PROCgc_exit - PROCgc_enter - val1% = FNref_local(val1%) - val2% = FNref_local(val2%) -ENDPROC - -DEF FNmalloc(type%) - LOCAL val% - REM If the heap is full, collect garbage first. - IF F% = 0 AND next_Z% > DIM(Z%(),1) THEN - PROCgc - IF F% = 0 ERROR &40E80950, "Out of mal heap memory" - ENDIF - IF F% <> 0 THEN - val% = F% - F% = Z%(val%,1) - ELSE - val% = next_Z% - next_Z% += 1 - ENDIF - Z%(val%,0) = type% -=FNref_local(val%) - -DEF PROCfree(val%) - Z%(val%,0) = &05 - Z%(val%,1) = F% - Z%(val%,2) = 0 - Z%(val%,3) = 0 - Z$(val%) = "" - F% = val% -ENDPROC - -DEF PROCgc - REM PRINT "** START GC **" - PROCgc_markall - PROCgc_sweep - REM PRINT "** FINISH GC **" -ENDPROC - -DEF PROCgc_markall - LOCAL sp%, fp% - fp% = sFP% - REM PRINT ">>marking..."; - FOR sp% = sSP% - 1 TO 0 STEP -1 - IF sp% = fp% THEN - fp% = sS%(sp%) - REM PRINT " / "; - ELSE PROCgc_mark(sS%(sp%)) - ENDIF - NEXT sp% - REM PRINT -ENDPROC - -DEF PROCgc_mark(val%) - IF (Z%(val%,0) AND &100) = 0 THEN - REM PRINT " ";val%; - Z%(val%,0) += &100 - IF (Z%(val%,0) AND &01) THEN PROCgc_mark(Z%(val%,1)) - PROCgc_mark(Z%(val%,2)) - PROCgc_mark(Z%(val%,3)) - ENDIF -ENDPROC - -DEF PROCgc_sweep - LOCAL val% - REM PRINT ">>sweeping ..."; - FOR val% = 6 TO next_Z% - 1 - IF FNtype_of(val%) <> &05 AND (Z%(val%,0) AND &100) = 0 THEN - REM PRINT " ";val%; - PROCfree(val%) - ELSE - Z%(val%,0) -= &100 - ENDIF - NEXT val% - REM PRINT -ENDPROC - -DEF FNmeta(val%) -=Z%(val%,3) - -DEF FNwith_meta(val%, meta%) - LOCAL newval% - newval% = FNmalloc(Z%(val%,0)) - Z%(newval%,1) = Z%(val%,1) - Z%(newval%,2) = Z%(val%,2) - Z%(newval%,3) = meta% - Z$(newval%) = Z$(val%) -=newval% - -REM ** Nil ** - -DEF FNis_nil(val%) -=FNtype_of(val%) = 0 - -DEF FNnil -=0 - -REM ** Boolean ** - -REM Z%(x,1) = TRUE or FALSE - -DEF FNis_boolean(val%) -=FNtype_of(val%) = &04 - -DEF FNalloc_boolean(bval%) - IF bval% THEN =2 -=1 - -DEF FNunbox_boolean(val%) - IF NOT FNis_boolean(val%) THEN ERROR &40E80911, "Not a boolean" -=Z%(val%,1) - -DEF FNis_truish(val%) - IF FNis_nil(val%) THEN =FALSE - IF FNis_boolean(val%) THEN =FNunbox_boolean(val%) -=TRUE - -REM ** Integers ** - -REM Z%(x,1) = integer value - -DEF FNis_int(val%) -=FNtype_of(val%) = &08 - -DEF FNalloc_int(ival%) - LOCAL val% - val% = FNmalloc(&08) - Z%(val%,1) = ival% -=val% - -DEF FNunbox_int(val%) - IF NOT FNis_int(val%) THEN ERROR &40E80912, "Not an integer" -=Z%(val%,1) - -REM ** Strings and keywords ** - -REM Z$(x) is the string value -REM Z%(x,2) points to the next part of the string -REM A keyword is a string with first character CHR$(127). - -DEF FNis_string(val%) -=FNtype_of(val%) = &02 - -DEF FNalloc_string(sval$) - LOCAL val% - val% = FNmalloc(&02) - Z$(val%) = sval$ -=val% - -DEF FNunbox_string(val%) - IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string" - IF NOT FNis_nil(Z%(val%,2)) ERROR &40E80914, "Cannot unbox a long string" -=Z$(val%) - -DEF FNstring_append(val%, add$) - LOCAL newval% - IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string" - newval% = FNalloc_string(Z$(val%)) - IF FNis_nil(Z%(val%,2)) THEN - IF LEN(Z$(newval%)) + LEN(add$) <= 255 THEN - Z$(newval%) += add$ - ELSE - Z%(newval%,2) = FNalloc_string(add$) - ENDIF - ELSE - Z%(newval%,2) = FNstring_append(Z%(val%,2), add$) - ENDIF -=newval% - -DEF FNstring_concat(val%, add%) - LOCAL newval% - IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string" - IF NOT FNis_string(add%) THEN ERROR &40E80914, "Not a string" - newval% = FNalloc_string(Z$(val%)) - IF FNis_nil(Z%(val%,2)) THEN - IF LEN(Z$(newval%)) + LEN(Z$(add%)) <= 255 THEN - Z$(newval%) += Z$(add%) - Z%(newval%,2) = Z%(add%,2) - ELSE - Z%(newval%,2) = add% - ENDIF - ELSE - Z%(newval%,2) = FNstring_concat(Z%(val%,2), add%) - ENDIF -=newval% - -DEF FNstring_len(val%) - LOCAL len% - WHILE NOT FNis_nil(val%) - len% += LEN(Z$(val%)) - val% = Z%(val%,2) - ENDWHILE -=len% - -DEF FNstring_chr(val%, pos%) - WHILE pos% > LEN(Z$(val%)) - pos% -= LEN(Z$(val%)) - val% = Z%(val%,2) - IF FNis_nil(val%) THEN ="" - ENDWHILE -=MID$(Z$(val%), pos%, 1) - -REM ** Symbols ** - -REM Z$(x) = value of the symbol - -DEF FNis_symbol(val%) -=FNtype_of(val%) = &06 - -DEF FNalloc_symbol(sval$) - LOCAL val% - val% = FNmalloc(&06) - Z$(val%) = sval$ -=val% - -DEF FNunbox_symbol(val%) - IF NOT FNis_symbol(val%) THEN ERROR &40E80915, "Not a symbol" -=Z$(val%) - -REM ** Lists and vectors ** - -REM Lists and vectors are both represented as linked lists: the only -REM difference is in the state of the is_vector flag in the head cell -REM of the list. Note that this means that the tail of a list may be -REM a vector, and vice versa. FNas_list and FNas_vector can be used -REM to convert a sequence to a particular type as necessary. - -REM Z%(x,0) AND &80 = is_vector flag -REM Z%(x,1) = index in Z%() of next pair -REM Z%(x,2) = index in Z%() of first element - -REM The empty list is a distinguished value, with elements that match -REM the spec of 'first' and 'rest'. - -DEF FNempty -=3 - -DEF FNempty_vector -=4 - -DEF FNalloc_pair(car%, cdr%) - LOCAL val% - val% = FNmalloc(&09) - Z%(val%,2) = car% - Z%(val%,1) = cdr% -=val% - -DEF FNalloc_vector_pair(car%, cdr%) - LOCAL val% - val% = FNalloc_pair(car%, cdr%) - Z%(val%,0) = Z%(val%,0) OR &80 -=val% - -DEF FNis_empty(val%) -=(Z%(val%,0) AND &40) = &40 - -DEF FNis_seq(val%) -=FNtype_of(val%) = &09 - -DEF FNis_list(val%) -=FNtype_of(val%) = &09 AND (Z%(val%, 0) AND &80) = &00 - -DEF FNis_vector(val%) -=FNtype_of(val%) = &09 AND (Z%(val%, 0) AND &80) = &80 - -DEF FNas_list(val%) - IF FNis_list(val%) THEN =val% - IF FNis_empty(val%) THEN =FNempty -=FNalloc_pair(FNfirst(val%), FNrest(val%)) - -DEF FNas_vector(val%) - IF FNis_vector(val%) THEN =val% - IF FNis_empty(val%) THEN =FNempty_vector -=FNalloc_vector_pair(FNfirst(val%), FNrest(val%)) - -DEF FNfirst(val%) - IF NOT FNis_seq(val%) THEN ERROR &40E80916, "Can't get car of non-sequence" -=FNref_local(Z%(val%,2)) - -DEF FNrest(val%) - IF NOT FNis_seq(val%) THEN ERROR &40E80916, "Can't get cdr of non-sequence" -=FNref_local(Z%(val%,1)) - -DEF FNalloc_list2(val0%, val1%) - =FNalloc_pair(val0%, FNalloc_pair(val1%, FNempty)) - -DEF FNalloc_list3(val0%, val1%, val2%) - =FNalloc_pair(val0%, FNalloc_pair(val1%, FNalloc_pair(val2%, FNempty))) - -DEF FNcount(val%) - LOCAL i% - WHILE NOT FNis_empty(val%) - val% = FNrest(val%) - i% += 1 - ENDWHILE -= i% - -DEF FNnth(val%, n%) - WHILE n% > 0 - IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range" - val% = FNrest(val%) - n% -= 1 - ENDWHILE - IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range" -=FNfirst(val%) - -REM ** Core functions ** - -REM Z%(x,1) = index of function in FNcore_call - -DEF FNis_corefn(val%) -=FNtype_of(val%) = &0C - -DEF FNalloc_corefn(fn%) - LOCAL val% - val% = FNmalloc(&0C) - Z%(val%,1) = fn% -=val% - -DEF FNunbox_corefn(val%) - IF NOT FNis_corefn(val%) THEN ERROR &40E80919, "Not a core function" -=Z%(val%,1) - -REM ** Hash-maps ** - -REM Hash-maps are represented as a crit-bit tree. - -REM An internal node has: -REM Z%(x,0) >> 16 = next bit of key to check -REM Z%(x,1) = index in Z%() of left child (if next bit of key is 0) -REM Z%(x,2) = index in Z%() of right child (if next bit of key is 1) - -REM A leaf node has -REM Z$(x) = key -REM Z%(x,2) = index in Z%() of value - -REM The empty hash-map is a special value containing no data. - -DEF FNempty_hashmap -=5 - -DEF FNhashmap_alloc_leaf(key$, val%) - LOCAL entry% - entry% = FNmalloc(&0A) - Z$(entry%) = key$ - Z%(entry%,2) = val% -=entry% - -DEF FNhashmap_alloc_node(bit%, left%, right%) - LOCAL entry% - entry% = FNmalloc(&11) - Z%(entry%,0) += (bit% << 16) - Z%(entry%,1) = left% - Z%(entry%,2) = right% -=entry% - -DEF FNis_hashmap(val%) - LOCAL t% - t% = FNtype_of(val%) -=t% = &11 OR t% = &0A - -DEF FNkey_bit(key$, bit%) - LOCAL cnum% - cnum% = bit% >> 3 - IF cnum% >= LEN(key$) THEN =FALSE -=ASC(MID$(key$, cnum% + 1, 1)) AND (&80 >> (bit% AND 7)) - -DEF FNkey_bitdiff(key1$, key2$) - LOCAL bit% - WHILE FNkey_bit(key1$, bit%) = FNkey_bit(key2$, bit%) - bit% += 1 - ENDWHILE -=bit% - -DEF FNhashmap_set(map%, key$, val%) - LOCAL bit%, nearest% - IF FNis_empty(map%) THEN =FNhashmap_alloc_leaf(key$, val%) - nearest% = FNhashmap_find(map%, key$) - IF Z$(nearest%) = key$ THEN =FNhashmap_replace(map%, key$, val%) - bit% = FNkey_bitdiff(key$, Z$(nearest%)) -=FNhashmap_insert(map%, bit%, key$, val%) - -DEF FNhashmap_insert(map%, bit%, key$, val%) - LOCAL left%, right% - IF FNtype_of(map%) = &11 AND (Z%(map%,0) >> 16) < bit% THEN - IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN - left% = Z%(map%,1) - right% = FNhashmap_insert(Z%(map%,2), bit%, key$, val%) - ELSE - left% = FNhashmap_insert(Z%(map%,1), bit%, key$, val%) - right% = Z%(map%,2) - ENDIF - =FNhashmap_alloc_node(Z%(map%,0)>>16, left%, right%) - ENDIF - IF FNkey_bit(key$, bit%) THEN - left% = map% - right% = FNhashmap_alloc_leaf(key$, val%) - ELSE - left% = FNhashmap_alloc_leaf(key$, val%) - right% = map% - ENDIF -=FNhashmap_alloc_node(bit%, left%, right%) - - -REM Replace a known-present key in a non-empty hashmap. -DEF FNhashmap_replace(map%, key$, val%) - LOCAL left%, right% - IF FNtype_of(map%) = &0A THEN =FNhashmap_alloc_leaf(key$, val%) - IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN - left% = Z%(map%,1) - right% = FNhashmap_replace(Z%(map%,2), key$, val%) - ELSE - left% = FNhashmap_replace(Z%(map%,1), key$, val%) - right% = Z%(map%,2) - ENDIF -=FNhashmap_alloc_node(Z%(map%,0)>>16, left%, right%) - -DEF FNhashmap_remove(map%, key$) - LOCAL child% - IF FNis_empty(map%) THEN =map% - IF FNtype_of(map%) = &0A THEN - IF Z$(map%) = key$ THEN =FNempty_hashmap - ENDIF - IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN - child% = FNhashmap_remove(Z%(map%,2), key$) - IF FNis_empty(child%) THEN =Z%(map%,1) - =FNhashmap_alloc_node(Z%(map%,0)>>16, Z%(map%,1), child%) - ELSE - child% = FNhashmap_remove(Z%(map%,1), key$) - IF FNis_empty(child%) THEN =Z%(map%,2) - =FNhashmap_alloc_node(Z%(map%,0)>>16, child%, Z%(map%,2)) - ENDIF - -REM FNhashmap_find finds the nearest entry in a non-empty hash-map to -REM the key requested, and returns the entire entry. -DEF FNhashmap_find(map%, key$) - WHILE FNtype_of(map%) = &11 - IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN map% = Z%(map%,2) ELSE map% = Z%(map%,1) - ENDWHILE -=map% - -DEF FNhashmap_get(map%, key$) - IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap" - IF FNis_empty(map%) THEN =FNnil - map% = FNhashmap_find(map%, key$) -IF Z$(map%) = key$ THEN =FNref_local(Z%(map%,2)) ELSE =FNnil - -DEF FNhashmap_contains(map%, key$) - IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap" - IF FNis_empty(map%) THEN =FALSE - map% = FNhashmap_find(map%, key$) -=Z$(map%) = key$ - -DEF FNhashmap_keys(map%) -=FNhashmap_keys1(map%, FNempty) - -DEF FNhashmap_keys1(map%, acc%) - IF FNis_empty(map%) THEN =acc% - IF FNtype_of(map%) = &0A THEN - =FNalloc_pair(FNalloc_string(Z$(map%)), acc%) - ENDIF -=FNhashmap_keys1(Z%(map%,1), FNhashmap_keys1(Z%(map%,2), acc%)) - -DEF FNhashmap_vals(map%) -=FNhashmap_vals1(map%, FNempty) - -DEF FNhashmap_vals1(map%, acc%) - IF FNis_empty(map%) THEN =acc% - IF FNtype_of(map%) = &0A THEN - =FNalloc_pair(Z%(map%,2), acc%) - ENDIF -=FNhashmap_vals1(Z%(map%,1), FNhashmap_vals1(Z%(map%,2), acc%)) - -DEF PROChashmap_dump(map%) - IF FNis_empty(map%) THEN - PRINT "[empty]" - ELSE - PRINT "[-----]" - PROChashmap_dump_internal(map%, "") - ENDIF -ENDPROC - -DEF PROChashmap_dump_internal(map%, prefix$) - IF FNtype_of(map%) = &0A PRINT prefix$;Z$(map%) - IF FNtype_of(map%) = &11 THEN - PRINT prefix$;"<";Z%(map%,0) >> 16;">" - PROChashmap_dump_internal(Z%(map%,1), prefix$ + "L ") - PROChashmap_dump_internal(Z%(map%,2), prefix$ + "R ") - ENDIF -ENDPROC - -REM ** Functions ** - -REM A function is represented by two cells: -REM Z%(x,0) AND &80 = is_macro flag -REM Z%(x,1) = index in Z%() of ast -REM Z%(x,2) = y - -REM Z%(y,1) = index in Z%() of params -REM Z%(y,2) = index in Z%() of env - -DEF FNis_fn(val%) -=FNtype_of(val%) = &15 - -DEF FNis_nonmacro_fn(val%) -=FNtype_of(val%) = &15 AND (Z%(val%, 0) AND &80) = &00 - -DEF FNis_macro(val%) -=FNtype_of(val%) = &15 AND (Z%(val%, 0) AND &80) = &80 - -DEF FNalloc_fn(ast%, params%, env%) - LOCAL val1%, val2% - val1% = FNmalloc(&15) - Z%(val1%,1) = ast% - val2% = FNmalloc(&19) - Z%(val1%,2) = val2% - Z%(val2%,1) = params% - Z%(val2%,2) = env% -=val1% - -DEF FNas_macro(val%) - IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function" - LOCAL newval% - newval% = FNmalloc(Z%(val%,0) OR &80) - Z%(newval%,1) = Z%(val%,1) - Z%(newval%,2) = Z%(val%,2) - Z%(newval%,3) = Z%(val%,3) -=newval% - -DEF FNfn_ast(val%) - IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function" -=FNref_local(Z%(val%,1)) - -DEF FNfn_params(val%) - IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function" -=FNref_local(Z%(Z%(val%,2),1)) - -DEF FNfn_env(val%) - IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function" -=FNref_local(Z%(Z%(val%,2),2)) - -REM ** Atoms ** - -REM Z%(x,1) = index in Z% of current referent - -DEF FNis_atom(val%) -=FNtype_of(val%) = &01 - -DEF FNalloc_atom(contents%) - LOCAL val% - val% = FNmalloc(&01) - Z%(val%,1) = contents% -=val% - -DEF FNatom_deref(val%) -=FNref_local(Z%(val%,1)) - -DEF PROCatom_reset(val%, contents%) - Z%(val%,1) = contents% -ENDPROC - -REM ** Environments ** - -REM Z%(x,1) = index in Z% of hash-map -REM Z%(x,2) = index in Z% of outer environment - -DEF FNis_environment(val%) -=FNtype_of(val%) = &0D - -DEF FNalloc_environment(outer%) - LOCAL val% - val% = FNmalloc(&0D) - Z%(val%,1) = FNempty_hashmap - Z%(val%,2) = outer% -=val% - -DEF FNenvironment_data(val%) - IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment" -=FNref_local(Z%(val%,1)) - -DEF PROCenvironment_set_data(val%, data%) - IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment" - Z%(val%,1) = data% -ENDPROC - -DEF FNenvironment_outer(val%) - IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment" -=FNref_local(Z%(val%,2)) - -REM Local Variables: -REM indent-tabs-mode: nil -REM End: +REM > types library for mal in BBC BASIC + +REM This library should be the only thing that understands the +REM implementation of mal data types in BBC BASIC. All other +REM code should use routines in this library to access them. + +REM As far as other code is concerned, a mal object is just an +REM opaque 32-bit integer, which might be a pointer, or might not. + +REM All mal objects live in an array, Z%(), with string values held +REM in a parallel array, Z$(). There's one row in Z%(), and one +REM entry in Z$(), for each mal object. + +REM Z%(x,0) holds the type of an object and other small amounts of +REM information. The bottom bit indicates the semantics of Z%(x,1): + +REM &01 : Z%(x,1) is a pointer into Z%() + +REM Z%(x,2) and Z%(x,3) are always pointers into Z%(), to 'nil' if nothing +REM else. + +REM The &40 bit is used to distinguish empty lists, vectors and hash-maps. +REM The &80 bit distinguishes vectors from lists and macros from functions. + +REM sS%() is a shadow stack, used to keep track of which mal values might +REM be referenced from local variables at a given depth of the BASIC call +REM stack. It grows upwards. sSP% points to the first unused word. sFP% +REM points to the start of the current shadow stack frame. The first word +REM of each shadow stack frame is the saved value of sFP%. The rest are +REM mal values. + +REM Types are: +REM &00 nil +REM &04 boolean +REM &08 integer +REM &0C core function +REM &01 atom +REM &05 free block +REM &09 list/vector (each object is a cons cell) +REM &0D environment +REM &11 hash-map internal node +REM &15 mal function (first part) +REM &19 mal function (second part) +REM &02 string/keyword +REM &06 symbol +REM &0A hash-map leaf node + +REM Formats of individual objects are defined below. + +DEF PROCtypes_init + REM Mal's heap has to be statically dimensioned, but we also + REM need to leave enough space for BASIC's stack and heap. + REM The BASIC heap is where all strings live. + REM + REM Each row of Z%() consumes 16 bytes. The size of each entry + REM in Z$() varies by platform: 5 bytes in ARM BBC BASIC V, + REM 8 bytes in Brandy on a 32-bit system, 16 bytes in Brandy on + REM a 64-bit system. + + DIM Z%((HIMEM-LOMEM)/110,3), Z$((HIMEM-LOMEM)/110) + DIM sS%((HIMEM-LOMEM)/64) + + Z%(1,0) = &04 : REM false + Z%(2,0) = &04 : Z%(2,1) = TRUE : REM true + Z%(3,0) = &49 : Z%(3,1) = 3 : REM empty list + Z%(4,0) = &C9 : Z%(4,1) = 4 : REM empty vector + Z%(5,0) = &51 : REM empty hashmap + next_Z% = 6 + sSP% = 1 + sFP% = 0 + F% = 0 +ENDPROC + +DEF FNtype_of(val%) +=Z%(val%,0) AND &1F + +DEF PROCgc_enter + REM PRINT ;sFP%; + sS%(sSP%) = sFP% + sFP% = sSP% + sSP% += 1 + REM PRINT " >>> ";sFP% +ENDPROC + +REM FNgc_save is equivalent to PROCgc_enter except that it returns a +REM value that can be passed to PROCgc_restore to pop all the stack +REM frames back to (and including) the one pushed by FNgc_save. +DEF FNgc_save + PROCgc_enter +=sFP% + +DEF PROCgc_exit + REM PRINT ;sS%(sFP%);" <<< ";sFP% + sSP% = sFP% + sFP% = sS%(sFP%) +ENDPROC + +DEF PROCgc_restore(oldFP%) + sFP% = oldFP% + REM PRINT "!!! FP reset" + PROCgc_exit +ENDPROC + +DEF FNref_local(val%) + sS%(sSP%) = val% + sSP% += 1 +=val% + +DEF FNgc_exit(val%) + PROCgc_exit +=FNref_local(val%) + +DEF FNgc_restore(oldFP%, val%) + PROCgc_restore(oldFP%) +=FNref_local(val%) + +DEF PROCgc_keep_only2(val1%, val2%) + PROCgc_exit + PROCgc_enter + val1% = FNref_local(val1%) + val2% = FNref_local(val2%) +ENDPROC + +DEF FNmalloc(type%) + LOCAL val% + REM If the heap is full, collect garbage first. + IF F% = 0 AND next_Z% > DIM(Z%(),1) THEN + PROCgc + IF F% = 0 ERROR &40E80950, "Out of mal heap memory" + ENDIF + IF F% <> 0 THEN + val% = F% + F% = Z%(val%,1) + ELSE + val% = next_Z% + next_Z% += 1 + ENDIF + Z%(val%,0) = type% +=FNref_local(val%) + +DEF PROCfree(val%) + Z%(val%,0) = &05 + Z%(val%,1) = F% + Z%(val%,2) = 0 + Z%(val%,3) = 0 + Z$(val%) = "" + F% = val% +ENDPROC + +DEF PROCgc + REM PRINT "** START GC **" + PROCgc_markall + PROCgc_sweep + REM PRINT "** FINISH GC **" +ENDPROC + +DEF PROCgc_markall + LOCAL sp%, fp% + fp% = sFP% + REM PRINT ">>marking..."; + FOR sp% = sSP% - 1 TO 0 STEP -1 + IF sp% = fp% THEN + fp% = sS%(sp%) + REM PRINT " / "; + ELSE PROCgc_mark(sS%(sp%)) + ENDIF + NEXT sp% + REM PRINT +ENDPROC + +DEF PROCgc_mark(val%) + IF (Z%(val%,0) AND &100) = 0 THEN + REM PRINT " ";val%; + Z%(val%,0) += &100 + IF (Z%(val%,0) AND &01) THEN PROCgc_mark(Z%(val%,1)) + PROCgc_mark(Z%(val%,2)) + PROCgc_mark(Z%(val%,3)) + ENDIF +ENDPROC + +DEF PROCgc_sweep + LOCAL val% + REM PRINT ">>sweeping ..."; + FOR val% = 6 TO next_Z% - 1 + IF FNtype_of(val%) <> &05 AND (Z%(val%,0) AND &100) = 0 THEN + REM PRINT " ";val%; + PROCfree(val%) + ELSE + Z%(val%,0) -= &100 + ENDIF + NEXT val% + REM PRINT +ENDPROC + +DEF FNmeta(val%) +=Z%(val%,3) + +DEF FNwith_meta(val%, meta%) + LOCAL newval% + newval% = FNmalloc(Z%(val%,0)) + Z%(newval%,1) = Z%(val%,1) + Z%(newval%,2) = Z%(val%,2) + Z%(newval%,3) = meta% + Z$(newval%) = Z$(val%) +=newval% + +REM ** Nil ** + +DEF FNis_nil(val%) +=FNtype_of(val%) = 0 + +DEF FNnil +=0 + +REM ** Boolean ** + +REM Z%(x,1) = TRUE or FALSE + +DEF FNis_boolean(val%) +=FNtype_of(val%) = &04 + +DEF FNalloc_boolean(bval%) + IF bval% THEN =2 +=1 + +DEF FNunbox_boolean(val%) + IF NOT FNis_boolean(val%) THEN ERROR &40E80911, "Not a boolean" +=Z%(val%,1) + +DEF FNis_truish(val%) + IF FNis_nil(val%) THEN =FALSE + IF FNis_boolean(val%) THEN =FNunbox_boolean(val%) +=TRUE + +REM ** Integers ** + +REM Z%(x,1) = integer value + +DEF FNis_int(val%) +=FNtype_of(val%) = &08 + +DEF FNalloc_int(ival%) + LOCAL val% + val% = FNmalloc(&08) + Z%(val%,1) = ival% +=val% + +DEF FNunbox_int(val%) + IF NOT FNis_int(val%) THEN ERROR &40E80912, "Not an integer" +=Z%(val%,1) + +REM ** Strings and keywords ** + +REM Z$(x) is the string value +REM Z%(x,2) points to the next part of the string +REM A keyword is a string with first character CHR$(127). + +DEF FNis_string(val%) +=FNtype_of(val%) = &02 + +DEF FNalloc_string(sval$) + LOCAL val% + val% = FNmalloc(&02) + Z$(val%) = sval$ +=val% + +DEF FNunbox_string(val%) + IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string" + IF NOT FNis_nil(Z%(val%,2)) ERROR &40E80914, "Cannot unbox a long string" +=Z$(val%) + +DEF FNstring_append(val%, add$) + LOCAL newval% + IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string" + newval% = FNalloc_string(Z$(val%)) + IF FNis_nil(Z%(val%,2)) THEN + IF LEN(Z$(newval%)) + LEN(add$) <= 255 THEN + Z$(newval%) += add$ + ELSE + Z%(newval%,2) = FNalloc_string(add$) + ENDIF + ELSE + Z%(newval%,2) = FNstring_append(Z%(val%,2), add$) + ENDIF +=newval% + +DEF FNstring_concat(val%, add%) + LOCAL newval% + IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string" + IF NOT FNis_string(add%) THEN ERROR &40E80914, "Not a string" + newval% = FNalloc_string(Z$(val%)) + IF FNis_nil(Z%(val%,2)) THEN + IF LEN(Z$(newval%)) + LEN(Z$(add%)) <= 255 THEN + Z$(newval%) += Z$(add%) + Z%(newval%,2) = Z%(add%,2) + ELSE + Z%(newval%,2) = add% + ENDIF + ELSE + Z%(newval%,2) = FNstring_concat(Z%(val%,2), add%) + ENDIF +=newval% + +DEF FNstring_len(val%) + LOCAL len% + WHILE NOT FNis_nil(val%) + len% += LEN(Z$(val%)) + val% = Z%(val%,2) + ENDWHILE +=len% + +DEF FNstring_chr(val%, pos%) + WHILE pos% > LEN(Z$(val%)) + pos% -= LEN(Z$(val%)) + val% = Z%(val%,2) + IF FNis_nil(val%) THEN ="" + ENDWHILE +=MID$(Z$(val%), pos%, 1) + +REM ** Symbols ** + +REM Z$(x) = value of the symbol + +DEF FNis_symbol(val%) +=FNtype_of(val%) = &06 + +DEF FNalloc_symbol(sval$) + LOCAL val% + val% = FNmalloc(&06) + Z$(val%) = sval$ +=val% + +DEF FNunbox_symbol(val%) + IF NOT FNis_symbol(val%) THEN ERROR &40E80915, "Not a symbol" +=Z$(val%) + +REM ** Lists and vectors ** + +REM Lists and vectors are both represented as linked lists: the only +REM difference is in the state of the is_vector flag in the head cell +REM of the list. Note that this means that the tail of a list may be +REM a vector, and vice versa. FNas_list and FNas_vector can be used +REM to convert a sequence to a particular type as necessary. + +REM Z%(x,0) AND &80 = is_vector flag +REM Z%(x,1) = index in Z%() of next pair +REM Z%(x,2) = index in Z%() of first element + +REM The empty list is a distinguished value, with elements that match +REM the spec of 'first' and 'rest'. + +DEF FNempty +=3 + +DEF FNempty_vector +=4 + +DEF FNalloc_pair(car%, cdr%) + LOCAL val% + val% = FNmalloc(&09) + Z%(val%,2) = car% + Z%(val%,1) = cdr% +=val% + +DEF FNalloc_vector_pair(car%, cdr%) + LOCAL val% + val% = FNalloc_pair(car%, cdr%) + Z%(val%,0) = Z%(val%,0) OR &80 +=val% + +DEF FNis_empty(val%) +=(Z%(val%,0) AND &40) = &40 + +DEF FNis_seq(val%) +=FNtype_of(val%) = &09 + +DEF FNis_list(val%) +=FNtype_of(val%) = &09 AND (Z%(val%, 0) AND &80) = &00 + +DEF FNis_vector(val%) +=FNtype_of(val%) = &09 AND (Z%(val%, 0) AND &80) = &80 + +DEF FNas_list(val%) + IF FNis_list(val%) THEN =val% + IF FNis_empty(val%) THEN =FNempty +=FNalloc_pair(FNfirst(val%), FNrest(val%)) + +DEF FNas_vector(val%) + IF FNis_vector(val%) THEN =val% + IF FNis_empty(val%) THEN =FNempty_vector +=FNalloc_vector_pair(FNfirst(val%), FNrest(val%)) + +DEF FNfirst(val%) + IF NOT FNis_seq(val%) THEN ERROR &40E80916, "Can't get car of non-sequence" +=FNref_local(Z%(val%,2)) + +DEF FNrest(val%) + IF NOT FNis_seq(val%) THEN ERROR &40E80916, "Can't get cdr of non-sequence" +=FNref_local(Z%(val%,1)) + +DEF FNalloc_list2(val0%, val1%) + =FNalloc_pair(val0%, FNalloc_pair(val1%, FNempty)) + +DEF FNalloc_list3(val0%, val1%, val2%) + =FNalloc_pair(val0%, FNalloc_pair(val1%, FNalloc_pair(val2%, FNempty))) + +DEF FNcount(val%) + LOCAL i% + WHILE NOT FNis_empty(val%) + val% = FNrest(val%) + i% += 1 + ENDWHILE += i% + +DEF FNnth(val%, n%) + WHILE n% > 0 + IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range" + val% = FNrest(val%) + n% -= 1 + ENDWHILE + IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range" +=FNfirst(val%) + +REM ** Core functions ** + +REM Z%(x,1) = index of function in FNcore_call + +DEF FNis_corefn(val%) +=FNtype_of(val%) = &0C + +DEF FNalloc_corefn(fn%) + LOCAL val% + val% = FNmalloc(&0C) + Z%(val%,1) = fn% +=val% + +DEF FNunbox_corefn(val%) + IF NOT FNis_corefn(val%) THEN ERROR &40E80919, "Not a core function" +=Z%(val%,1) + +REM ** Hash-maps ** + +REM Hash-maps are represented as a crit-bit tree. + +REM An internal node has: +REM Z%(x,0) >> 16 = next bit of key to check +REM Z%(x,1) = index in Z%() of left child (if next bit of key is 0) +REM Z%(x,2) = index in Z%() of right child (if next bit of key is 1) + +REM A leaf node has +REM Z$(x) = key +REM Z%(x,2) = index in Z%() of value + +REM The empty hash-map is a special value containing no data. + +DEF FNempty_hashmap +=5 + +DEF FNhashmap_alloc_leaf(key$, val%) + LOCAL entry% + entry% = FNmalloc(&0A) + Z$(entry%) = key$ + Z%(entry%,2) = val% +=entry% + +DEF FNhashmap_alloc_node(bit%, left%, right%) + LOCAL entry% + entry% = FNmalloc(&11) + Z%(entry%,0) += (bit% << 16) + Z%(entry%,1) = left% + Z%(entry%,2) = right% +=entry% + +DEF FNis_hashmap(val%) + LOCAL t% + t% = FNtype_of(val%) +=t% = &11 OR t% = &0A + +DEF FNkey_bit(key$, bit%) + LOCAL cnum% + cnum% = bit% >> 3 + IF cnum% >= LEN(key$) THEN =FALSE +=ASC(MID$(key$, cnum% + 1, 1)) AND (&80 >> (bit% AND 7)) + +DEF FNkey_bitdiff(key1$, key2$) + LOCAL bit% + WHILE FNkey_bit(key1$, bit%) = FNkey_bit(key2$, bit%) + bit% += 1 + ENDWHILE +=bit% + +DEF FNhashmap_set(map%, key$, val%) + LOCAL bit%, nearest% + IF FNis_empty(map%) THEN =FNhashmap_alloc_leaf(key$, val%) + nearest% = FNhashmap_find(map%, key$) + IF Z$(nearest%) = key$ THEN =FNhashmap_replace(map%, key$, val%) + bit% = FNkey_bitdiff(key$, Z$(nearest%)) +=FNhashmap_insert(map%, bit%, key$, val%) + +DEF FNhashmap_insert(map%, bit%, key$, val%) + LOCAL left%, right% + IF FNtype_of(map%) = &11 AND (Z%(map%,0) >> 16) < bit% THEN + IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN + left% = Z%(map%,1) + right% = FNhashmap_insert(Z%(map%,2), bit%, key$, val%) + ELSE + left% = FNhashmap_insert(Z%(map%,1), bit%, key$, val%) + right% = Z%(map%,2) + ENDIF + =FNhashmap_alloc_node(Z%(map%,0)>>16, left%, right%) + ENDIF + IF FNkey_bit(key$, bit%) THEN + left% = map% + right% = FNhashmap_alloc_leaf(key$, val%) + ELSE + left% = FNhashmap_alloc_leaf(key$, val%) + right% = map% + ENDIF +=FNhashmap_alloc_node(bit%, left%, right%) + + +REM Replace a known-present key in a non-empty hashmap. +DEF FNhashmap_replace(map%, key$, val%) + LOCAL left%, right% + IF FNtype_of(map%) = &0A THEN =FNhashmap_alloc_leaf(key$, val%) + IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN + left% = Z%(map%,1) + right% = FNhashmap_replace(Z%(map%,2), key$, val%) + ELSE + left% = FNhashmap_replace(Z%(map%,1), key$, val%) + right% = Z%(map%,2) + ENDIF +=FNhashmap_alloc_node(Z%(map%,0)>>16, left%, right%) + +DEF FNhashmap_remove(map%, key$) + LOCAL child% + IF FNis_empty(map%) THEN =map% + IF FNtype_of(map%) = &0A THEN + IF Z$(map%) = key$ THEN =FNempty_hashmap + ENDIF + IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN + child% = FNhashmap_remove(Z%(map%,2), key$) + IF FNis_empty(child%) THEN =Z%(map%,1) + =FNhashmap_alloc_node(Z%(map%,0)>>16, Z%(map%,1), child%) + ELSE + child% = FNhashmap_remove(Z%(map%,1), key$) + IF FNis_empty(child%) THEN =Z%(map%,2) + =FNhashmap_alloc_node(Z%(map%,0)>>16, child%, Z%(map%,2)) + ENDIF + +REM FNhashmap_find finds the nearest entry in a non-empty hash-map to +REM the key requested, and returns the entire entry. +DEF FNhashmap_find(map%, key$) + WHILE FNtype_of(map%) = &11 + IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN map% = Z%(map%,2) ELSE map% = Z%(map%,1) + ENDWHILE +=map% + +DEF FNhashmap_get(map%, key$) + IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap" + IF FNis_empty(map%) THEN =FNnil + map% = FNhashmap_find(map%, key$) +IF Z$(map%) = key$ THEN =FNref_local(Z%(map%,2)) ELSE =FNnil + +DEF FNhashmap_contains(map%, key$) + IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap" + IF FNis_empty(map%) THEN =FALSE + map% = FNhashmap_find(map%, key$) +=Z$(map%) = key$ + +DEF FNhashmap_keys(map%) +=FNhashmap_keys1(map%, FNempty) + +DEF FNhashmap_keys1(map%, acc%) + IF FNis_empty(map%) THEN =acc% + IF FNtype_of(map%) = &0A THEN + =FNalloc_pair(FNalloc_string(Z$(map%)), acc%) + ENDIF +=FNhashmap_keys1(Z%(map%,1), FNhashmap_keys1(Z%(map%,2), acc%)) + +DEF FNhashmap_vals(map%) +=FNhashmap_vals1(map%, FNempty) + +DEF FNhashmap_vals1(map%, acc%) + IF FNis_empty(map%) THEN =acc% + IF FNtype_of(map%) = &0A THEN + =FNalloc_pair(Z%(map%,2), acc%) + ENDIF +=FNhashmap_vals1(Z%(map%,1), FNhashmap_vals1(Z%(map%,2), acc%)) + +DEF PROChashmap_dump(map%) + IF FNis_empty(map%) THEN + PRINT "[empty]" + ELSE + PRINT "[-----]" + PROChashmap_dump_internal(map%, "") + ENDIF +ENDPROC + +DEF PROChashmap_dump_internal(map%, prefix$) + IF FNtype_of(map%) = &0A PRINT prefix$;Z$(map%) + IF FNtype_of(map%) = &11 THEN + PRINT prefix$;"<";Z%(map%,0) >> 16;">" + PROChashmap_dump_internal(Z%(map%,1), prefix$ + "L ") + PROChashmap_dump_internal(Z%(map%,2), prefix$ + "R ") + ENDIF +ENDPROC + +REM ** Functions ** + +REM A function is represented by two cells: +REM Z%(x,0) AND &80 = is_macro flag +REM Z%(x,1) = index in Z%() of ast +REM Z%(x,2) = y + +REM Z%(y,1) = index in Z%() of params +REM Z%(y,2) = index in Z%() of env + +DEF FNis_fn(val%) +=FNtype_of(val%) = &15 + +DEF FNis_nonmacro_fn(val%) +=FNtype_of(val%) = &15 AND (Z%(val%, 0) AND &80) = &00 + +DEF FNis_macro(val%) +=FNtype_of(val%) = &15 AND (Z%(val%, 0) AND &80) = &80 + +DEF FNalloc_fn(ast%, params%, env%) + LOCAL val1%, val2% + val1% = FNmalloc(&15) + Z%(val1%,1) = ast% + val2% = FNmalloc(&19) + Z%(val1%,2) = val2% + Z%(val2%,1) = params% + Z%(val2%,2) = env% +=val1% + +DEF FNas_macro(val%) + IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function" + LOCAL newval% + newval% = FNmalloc(Z%(val%,0) OR &80) + Z%(newval%,1) = Z%(val%,1) + Z%(newval%,2) = Z%(val%,2) + Z%(newval%,3) = Z%(val%,3) +=newval% + +DEF FNfn_ast(val%) + IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function" +=FNref_local(Z%(val%,1)) + +DEF FNfn_params(val%) + IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function" +=FNref_local(Z%(Z%(val%,2),1)) + +DEF FNfn_env(val%) + IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function" +=FNref_local(Z%(Z%(val%,2),2)) + +REM ** Atoms ** + +REM Z%(x,1) = index in Z% of current referent + +DEF FNis_atom(val%) +=FNtype_of(val%) = &01 + +DEF FNalloc_atom(contents%) + LOCAL val% + val% = FNmalloc(&01) + Z%(val%,1) = contents% +=val% + +DEF FNatom_deref(val%) +=FNref_local(Z%(val%,1)) + +DEF PROCatom_reset(val%, contents%) + Z%(val%,1) = contents% +ENDPROC + +REM ** Environments ** + +REM Z%(x,1) = index in Z% of hash-map +REM Z%(x,2) = index in Z% of outer environment + +DEF FNis_environment(val%) +=FNtype_of(val%) = &0D + +DEF FNalloc_environment(outer%) + LOCAL val% + val% = FNmalloc(&0D) + Z%(val%,1) = FNempty_hashmap + Z%(val%,2) = outer% +=val% + +DEF FNenvironment_data(val%) + IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment" +=FNref_local(Z%(val%,1)) + +DEF PROCenvironment_set_data(val%, data%) + IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment" + Z%(val%,1) = data% +ENDPROC + +DEF FNenvironment_outer(val%) + IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment" +=FNref_local(Z%(val%,2)) + +REM Local Variables: +REM indent-tabs-mode: nil +REM End: diff --git a/impls/c.2/Dockerfile b/impls/c.2/Dockerfile index 79bab2ecad..3c711368fa 100644 --- a/impls/c.2/Dockerfile +++ b/impls/c.2/Dockerfile @@ -1,28 +1,28 @@ -FROM ubuntu:bionic -MAINTAINER Duncan Watts - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -#RUN apt-get -y install curl - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install gcc -RUN apt-get -y install gcc - -# Libraries needed for the C impl -RUN apt-get -y install libffi-dev libgc-dev libedit-dev +FROM ubuntu:bionic +MAINTAINER Duncan Watts + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +#RUN apt-get -y install curl + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install gcc +RUN apt-get -y install gcc + +# Libraries needed for the C impl +RUN apt-get -y install libffi-dev libgc-dev libedit-dev diff --git a/impls/c.2/Makefile b/impls/c.2/Makefile index 2fac2f28f6..3d22e23ff8 100644 --- a/impls/c.2/Makefile +++ b/impls/c.2/Makefile @@ -1,93 +1,93 @@ -CC = gcc - -CFLAGS = -std=c99 -g -Wall - -LIBS = -ledit -lgc -FFI_LIBS = -ldl -lffi - -SRC = reader.c printer.c types.c env.c core.c -HEADERS = reader.h printer.h types.h env.h core.h - -LIB_DIR = ./libs -LIB_LIST_H = $(LIB_DIR)/linked_list/linked_list.h -LIB_LIST_SRC = $(LIB_DIR)/linked_list/linked_list.c - -LIB_MAP_H = $(LIB_DIR)/hashmap/hashmap.h -LIB_MAP_SRC = $(LIB_DIR)/hashmap/hashmap.c - -LIBS_H = $(LIB_LIST_H) $(LIB_MAP_H) -LIBS_SRC = $(LIB_LIST_SRC) $(LIB_MAP_SRC) - -S0_SRC = step0_repl.c -S1_SRC = step1_read_print.c reader.c types.c printer.c $(LIB_LIST_SRC) -S2_SRC = step2_eval.c reader.c types.c printer.c $(LIBS_SRC) -S3_SRC = step3_env.c reader.c types.c printer.c env.c $(LIBS_SRC) -S4_SRC = step4_if_fn_do.c $(SRC) $(LIBS_SRC) -S5_SRC = step5_tco.c $(SRC) $(LIBS_SRC) -S6_SRC = step6_file.c $(SRC) $(LIBS_SRC) -S7_SRC = step7_quote.c $(SRC) $(LIBS_SRC) -S8_SRC = step8_macros.c $(SRC) $(LIBS_SRC) -S9_SRC = step9_try.c $(SRC) $(LIBS_SRC) -SA_SRC = stepA_mal.c $(SRC) $(LIBS_SRC) - -S0_HEADERS = -S1_HEADERS = reader.h types.h printer.h $(LIB_LIST_H) -S2_HEADERS = reader.h types.h printer.h $(LIBS_H) -S3_HEADERS = reader.h types.h printer.h env.h $(LIBS_H) -S4_HEADERS = $(HEADERS) $(LIBS_H) -S5_HEADERS = $(HEADERS) $(LIBS_H) -S6_HEADERS = $(HEADERS) $(LIBS_H) -S7_HEADERS = $(HEADERS) $(LIBS_H) -S8_HEADERS = $(HEADERS) $(LIBS_H) -S9_HEADERS = $(HEADERS) $(LIBS_H) -SA_HEADERS = $(HEADERS) $(LIBS_H) - -S0 = step0_repl -S1 = step1_read_print -S2 = step2_eval -S3 = step3_env -S4 = step4_if_fn_do -S5 = step5_tco -S6 = step6_file -S7 = step7_quote -S8 = step8_macros -S9 = step9_try -SA = stepA_mal - -all: $(S0) $(S1) $(S2) $(S3) $(S4) $(S5) $(S6) $(S7) $(S8) $(S9) $(SA) - -$(S0): $(S0_SRC) $(S0_HEADERS) - $(CC) $(CFLAGS) $(S0_SRC) $(LIBS) -o $(S0) - -$(S1): $(S1_SRC) $(S1_HEADERS) - $(CC) $(CFLAGS) $(S1_SRC) $(LIBS) -o $(S1) - -$(S2): $(S2_SRC) $(S2_HEADERS) - $(CC) $(CFLAGS) $(S2_SRC) $(LIBS) -o $(S2) - -$(S3): $(S3_SRC) $(S3_HEADERS) - $(CC) $(CFLAGS) $(S3_SRC) $(LIBS) -o $(S3) - -$(S4): $(S4_SRC) $(S4_HEADERS) - $(CC) $(CFLAGS) $(S4_SRC) $(LIBS) -o $(S4) - -$(S5): $(S5_SRC) $(S5_HEADERS) - $(CC) $(CFLAGS) $(S5_SRC) $(LIBS) -o $(S5) - -$(S6): $(S6_SRC) $(S6_HEADERS) - $(CC) $(CFLAGS) $(S6_SRC) $(LIBS) -o $(S6) - -$(S7): $(S7_SRC) $(S7_HEADERS) - $(CC) $(CFLAGS) $(S7_SRC) $(LIBS) -o $(S7) - -$(S8): $(S8_SRC) $(S8_HEADERS) - $(CC) $(CFLAGS) $(S8_SRC) $(LIBS) -o $(S8) - -$(S9): $(S9_SRC) $(S9_HEADERS) - $(CC) $(CFLAGS) $(S9_SRC) $(LIBS) -o $(S9) - -$(SA): $(SA_SRC) $(SA_HEADERS) - $(CC) $(CFLAGS) $(SA_SRC) $(LIBS) $(FFI_LIBS) -DWITH_FFI -o $(SA) - -.PHONY clean: - rm -f $(S0) $(S1) $(S2) $(S3) $(S4) $(S5) $(S6) $(S7) $(S8) $(S9) $(SA) +CC = gcc + +CFLAGS = -std=c99 -g -Wall + +LIBS = -ledit -lgc +FFI_LIBS = -ldl -lffi + +SRC = reader.c printer.c types.c env.c core.c +HEADERS = reader.h printer.h types.h env.h core.h + +LIB_DIR = ./libs +LIB_LIST_H = $(LIB_DIR)/linked_list/linked_list.h +LIB_LIST_SRC = $(LIB_DIR)/linked_list/linked_list.c + +LIB_MAP_H = $(LIB_DIR)/hashmap/hashmap.h +LIB_MAP_SRC = $(LIB_DIR)/hashmap/hashmap.c + +LIBS_H = $(LIB_LIST_H) $(LIB_MAP_H) +LIBS_SRC = $(LIB_LIST_SRC) $(LIB_MAP_SRC) + +S0_SRC = step0_repl.c +S1_SRC = step1_read_print.c reader.c types.c printer.c $(LIB_LIST_SRC) +S2_SRC = step2_eval.c reader.c types.c printer.c $(LIBS_SRC) +S3_SRC = step3_env.c reader.c types.c printer.c env.c $(LIBS_SRC) +S4_SRC = step4_if_fn_do.c $(SRC) $(LIBS_SRC) +S5_SRC = step5_tco.c $(SRC) $(LIBS_SRC) +S6_SRC = step6_file.c $(SRC) $(LIBS_SRC) +S7_SRC = step7_quote.c $(SRC) $(LIBS_SRC) +S8_SRC = step8_macros.c $(SRC) $(LIBS_SRC) +S9_SRC = step9_try.c $(SRC) $(LIBS_SRC) +SA_SRC = stepA_mal.c $(SRC) $(LIBS_SRC) + +S0_HEADERS = +S1_HEADERS = reader.h types.h printer.h $(LIB_LIST_H) +S2_HEADERS = reader.h types.h printer.h $(LIBS_H) +S3_HEADERS = reader.h types.h printer.h env.h $(LIBS_H) +S4_HEADERS = $(HEADERS) $(LIBS_H) +S5_HEADERS = $(HEADERS) $(LIBS_H) +S6_HEADERS = $(HEADERS) $(LIBS_H) +S7_HEADERS = $(HEADERS) $(LIBS_H) +S8_HEADERS = $(HEADERS) $(LIBS_H) +S9_HEADERS = $(HEADERS) $(LIBS_H) +SA_HEADERS = $(HEADERS) $(LIBS_H) + +S0 = step0_repl +S1 = step1_read_print +S2 = step2_eval +S3 = step3_env +S4 = step4_if_fn_do +S5 = step5_tco +S6 = step6_file +S7 = step7_quote +S8 = step8_macros +S9 = step9_try +SA = stepA_mal + +all: $(S0) $(S1) $(S2) $(S3) $(S4) $(S5) $(S6) $(S7) $(S8) $(S9) $(SA) + +$(S0): $(S0_SRC) $(S0_HEADERS) + $(CC) $(CFLAGS) $(S0_SRC) $(LIBS) -o $(S0) + +$(S1): $(S1_SRC) $(S1_HEADERS) + $(CC) $(CFLAGS) $(S1_SRC) $(LIBS) -o $(S1) + +$(S2): $(S2_SRC) $(S2_HEADERS) + $(CC) $(CFLAGS) $(S2_SRC) $(LIBS) -o $(S2) + +$(S3): $(S3_SRC) $(S3_HEADERS) + $(CC) $(CFLAGS) $(S3_SRC) $(LIBS) -o $(S3) + +$(S4): $(S4_SRC) $(S4_HEADERS) + $(CC) $(CFLAGS) $(S4_SRC) $(LIBS) -o $(S4) + +$(S5): $(S5_SRC) $(S5_HEADERS) + $(CC) $(CFLAGS) $(S5_SRC) $(LIBS) -o $(S5) + +$(S6): $(S6_SRC) $(S6_HEADERS) + $(CC) $(CFLAGS) $(S6_SRC) $(LIBS) -o $(S6) + +$(S7): $(S7_SRC) $(S7_HEADERS) + $(CC) $(CFLAGS) $(S7_SRC) $(LIBS) -o $(S7) + +$(S8): $(S8_SRC) $(S8_HEADERS) + $(CC) $(CFLAGS) $(S8_SRC) $(LIBS) -o $(S8) + +$(S9): $(S9_SRC) $(S9_HEADERS) + $(CC) $(CFLAGS) $(S9_SRC) $(LIBS) -o $(S9) + +$(SA): $(SA_SRC) $(SA_HEADERS) + $(CC) $(CFLAGS) $(SA_SRC) $(LIBS) $(FFI_LIBS) -DWITH_FFI -o $(SA) + +.PHONY clean: + rm -f $(S0) $(S1) $(S2) $(S3) $(S4) $(S5) $(S6) $(S7) $(S8) $(S9) $(SA) diff --git a/impls/c.2/core.c b/impls/c.2/core.c index 5dfce4bdc2..e9f1637258 100644 --- a/impls/c.2/core.c +++ b/impls/c.2/core.c @@ -1,1996 +1,1996 @@ -#include -#include -#include -#include -#include - -/* only needed for ffi */ -#ifdef WITH_FFI -#include -#include -#endif - -#include "libs/hashmap/hashmap.h" -#include "core.h" -#include "types.h" -#include "printer.h" -#include "reader.h" -#include "env.h" - -#define STRING_BUFFER_SIZE 128 - -/* forward references to main file */ -MalType* apply(MalType* fn, list args); - -/* core ns functions */ -MalType* mal_add(list); -MalType* mal_sub(list); -MalType* mal_mul(list); -MalType* mal_div(list); - -MalType* mal_prn(list); -MalType* mal_println(list); -MalType* mal_pr_str(list); -MalType* mal_str(list); -MalType* mal_read_string(list); -MalType* mal_slurp(list); - -MalType* mal_list(list); -MalType* mal_list_questionmark(list); -MalType* mal_empty_questionmark(list); -MalType* mal_count(list); -MalType* mal_cons(list); -MalType* mal_concat(list); -MalType* mal_nth(list); -MalType* mal_first(list); -MalType* mal_rest(list); - -MalType* mal_equals(list); -MalType* mal_lessthan(list); -MalType* mal_lessthanorequalto(list); -MalType* mal_greaterthan(list); -MalType* mal_greaterthanorequalto(list); - -MalType* mal_atom(list); -MalType* mal_atom_questionmark(list); -MalType* mal_deref(list); -MalType* mal_reset_bang(list); -MalType* mal_swap_bang(list); - -MalType* mal_throw(list); -MalType* mal_apply(list); -MalType* mal_map(list); - -MalType* mal_nil_questionmark(list); -MalType* mal_true_questionmark(list); -MalType* mal_false_questionmark(list); -MalType* mal_symbol_questionmark(list); -MalType* mal_keyword_questionmark(list); -MalType* mal_symbol(list); -MalType* mal_keyword(list); - -MalType* mal_vec(list); -MalType* mal_vector(list); -MalType* mal_vector_questionmark(list); -MalType* mal_sequential_questionmark(list); -MalType* mal_hash_map(list); -MalType* mal_map_questionmark(list); -MalType* mal_assoc(list); -MalType* mal_dissoc(list); -MalType* mal_get(list); -MalType* mal_contains_questionmark(list); -MalType* mal_keys(list); -MalType* mal_vals(list); -MalType* mal_string_questionmark(list); -MalType* mal_number_questionmark(list); -MalType* mal_fn_questionmark(list); -MalType* mal_macro_questionmark(list); - -MalType* mal_time_ms(list); -MalType* mal_conj(list); -MalType* mal_seq(list); -MalType* mal_meta(list); -MalType* mal_with_meta(list); - -/* only needed for ffi */ -#ifdef WITH_FFI -MalType* mal_dot(list); -#endif - -ns* ns_make_core() { - - ns* core = GC_MALLOC(sizeof(*core)); - - hashmap core_functions = NULL; - - /* arithmetic */ - core_functions = hashmap_put(core_functions, "+", mal_add); - core_functions = hashmap_put(core_functions, "-", mal_sub); - core_functions = hashmap_put(core_functions, "*", mal_mul); - core_functions = hashmap_put(core_functions, "/", mal_div); - - /* strings */ - core_functions = hashmap_put(core_functions, "prn", mal_prn); - core_functions = hashmap_put(core_functions, "pr-str", mal_pr_str); - core_functions = hashmap_put(core_functions, "str", mal_str); - core_functions = hashmap_put(core_functions, "println", mal_println); - core_functions = hashmap_put(core_functions, "read-string", mal_read_string); - - /* files */ - core_functions = hashmap_put(core_functions, "slurp", mal_slurp); - - /* lists */ - core_functions = hashmap_put(core_functions, "list", mal_list); - core_functions = hashmap_put(core_functions, "empty?", mal_empty_questionmark); - core_functions = hashmap_put(core_functions, "count", mal_count); - core_functions = hashmap_put(core_functions, "cons", mal_cons); - core_functions = hashmap_put(core_functions, "concat", mal_concat); - core_functions = hashmap_put(core_functions, "nth", mal_nth); - core_functions = hashmap_put(core_functions, "first", mal_first); - core_functions = hashmap_put(core_functions, "rest", mal_rest); - - /* predicates */ - core_functions = hashmap_put(core_functions, "=", mal_equals); - core_functions = hashmap_put(core_functions, "<", mal_lessthan); - core_functions = hashmap_put(core_functions, "<=", mal_lessthanorequalto); - core_functions = hashmap_put(core_functions, ">", mal_greaterthan); - core_functions = hashmap_put(core_functions, ">=", mal_greaterthanorequalto); - - core_functions = hashmap_put(core_functions, "list?", mal_list_questionmark); - core_functions = hashmap_put(core_functions, "nil?", mal_nil_questionmark); - core_functions = hashmap_put(core_functions, "true?", mal_true_questionmark); - core_functions = hashmap_put(core_functions, "false?", mal_false_questionmark); - core_functions = hashmap_put(core_functions, "symbol?", mal_symbol_questionmark); - core_functions = hashmap_put(core_functions, "keyword?", mal_keyword_questionmark); - core_functions = hashmap_put(core_functions, "vector?", mal_vector_questionmark); - core_functions = hashmap_put(core_functions, "sequential?", mal_sequential_questionmark); - core_functions = hashmap_put(core_functions, "map?", mal_map_questionmark); - core_functions = hashmap_put(core_functions, "string?", mal_string_questionmark); - core_functions = hashmap_put(core_functions, "number?", mal_number_questionmark); - core_functions = hashmap_put(core_functions, "fn?", mal_fn_questionmark); - core_functions = hashmap_put(core_functions, "macro?", mal_macro_questionmark); - - /* atoms */ - core_functions = hashmap_put(core_functions, "atom", mal_atom); - core_functions = hashmap_put(core_functions, "atom?", mal_atom_questionmark); - core_functions = hashmap_put(core_functions, "deref", mal_deref); - core_functions = hashmap_put(core_functions, "reset!", mal_reset_bang); - core_functions = hashmap_put(core_functions, "swap!", mal_swap_bang); - - /* other */ - core_functions = hashmap_put(core_functions, "throw", mal_throw); - core_functions = hashmap_put(core_functions, "apply", mal_apply); - core_functions = hashmap_put(core_functions, "map", mal_map); - - core_functions = hashmap_put(core_functions, "symbol", mal_symbol); - core_functions = hashmap_put(core_functions, "keyword", mal_keyword); - core_functions = hashmap_put(core_functions, "vec", mal_vec); - core_functions = hashmap_put(core_functions, "vector", mal_vector); - core_functions = hashmap_put(core_functions, "hash-map", mal_hash_map); - - /* hash-maps */ - core_functions = hashmap_put(core_functions, "contains?", mal_contains_questionmark); - core_functions = hashmap_put(core_functions, "assoc", mal_assoc); - core_functions = hashmap_put(core_functions, "dissoc", mal_dissoc); - core_functions = hashmap_put(core_functions, "get", mal_get); - core_functions = hashmap_put(core_functions, "keys", mal_keys); - core_functions = hashmap_put(core_functions, "vals", mal_vals); - - /* misc */ - core_functions = hashmap_put(core_functions, "time-ms", mal_time_ms); - core_functions = hashmap_put(core_functions, "conj", mal_conj); - core_functions = hashmap_put(core_functions, "seq", mal_seq); - core_functions = hashmap_put(core_functions, "meta", mal_meta); - core_functions = hashmap_put(core_functions, "with-meta", mal_with_meta); - - /* only needed for ffi */ - #ifdef WITH_FFI - core_functions = hashmap_put(core_functions, ".", mal_dot); - #endif - - core->mappings = core_functions; - return core; -} - -/* core function definitons */ - -MalType* mal_add(list args) { - /* Accepts any number of arguments */ - - int return_float = 0; - - long i_sum = 0; - double r_sum = 0.0; - - while(args) { - - MalType* val = args->data; - if (!is_number(val)) { - return make_error("'+': expected numerical arguments"); - } - - if (is_integer(val) && !return_float) { - i_sum = i_sum + val->value.mal_integer; - } - else if (is_integer(val)) { - r_sum = (double)i_sum + r_sum + val->value.mal_integer; - i_sum = 0; - } - else { - r_sum = (double)i_sum + r_sum + val->value.mal_float; - i_sum = 0; - return_float = 1; - } - args = args->next; - } - - if (return_float) { - return make_float(r_sum); - } else { - return make_integer(i_sum); - } -} - -MalType* mal_sub(list args) { - /* Accepts any number of arguments */ - - int return_float = 0; - - long i_sum = 0; - double r_sum = 0.0; - - if (args) { - - MalType* val = args->data; - args = args->next; - - if (!is_number(val)) { - return make_error_fmt("'-': expected numerical arguments"); - } - - if (is_integer(val)) { - i_sum = val->value.mal_integer; - } else { - r_sum = val->value.mal_float; - return_float = 1; - } - - while(args) { - - val = args->data; - - if (!is_number(val)) { - return make_error_fmt("'-': expected numerical arguments"); - } - - if (is_integer(val) && !return_float) { - i_sum = i_sum - val->value.mal_integer; - } - else if (is_integer(val)) { - r_sum = (double)i_sum + r_sum - (double)val->value.mal_integer; - i_sum = 0; - } - else { - r_sum = (double)i_sum + r_sum - val->value.mal_float; - i_sum = 0; - return_float = 1; - } - args = args->next; - } - } - - if (return_float) { - return make_float(r_sum); - } else { - return make_integer(i_sum); - } -} - - -MalType* mal_mul(list args) { - /* Accepts any number of arguments */ - - int return_float = 0; - - long i_product = 1; - double r_product = 1.0; - - while(args) { - - MalType* val = args->data; - - if (!is_number(val)) { - return make_error_fmt("'*': expected numerical arguments"); - } - - if (is_integer(val) && !return_float) { - i_product *= val->value.mal_integer; - } - else if (is_integer(val)) { - r_product *= (double)val->value.mal_integer; - r_product *= (double)i_product; - i_product = 1; - } - else { - r_product *= (double)i_product; - r_product *= val->value.mal_float; - i_product = 1; - return_float = 1; - } - args = args->next; - } - - if (return_float) { - return make_float(r_product); - } else { - return make_integer(i_product); - } -} - -MalType* mal_div(list args) { - /* Accepts any number of arguments */ - - int return_float = 0; - - long i_product = 1; - double r_product = 1.0; - - if (args) { - MalType* val = args->data; - - if (!is_number(val)) { - return make_error_fmt("'/': expected numerical arguments"); - } - - if (is_integer(val)) { - i_product = val->value.mal_integer; - } else { - r_product = val->value.mal_float; - return_float = 1; - } - - args = args->next; - - while(args) { - - val = args->data; - - if (!is_number(val)) { - return make_error_fmt("'/': expected numerical arguments"); - } - - /* integer division */ - if (is_integer(val) && !return_float) { - i_product /= val->value.mal_integer; - } - /* promote integer to double */ - else if (is_integer(val)) { - if (i_product != 1) { - r_product = (double)i_product / (double)val->value.mal_integer; - i_product = 1; - } else { - r_product /= (double)val->value.mal_integer; - } - } - /* double division */ - else { - return_float = 1; - if (i_product != 1) { - r_product = (double)i_product / val->value.mal_float; - i_product = 1; - } else { - r_product /= val->value.mal_float; - } - } - args = args->next; - } - } - - if (return_float) { - return make_float(r_product); - } else { - return make_integer(i_product); - } -} - -MalType* mal_lessthan(list args) { - - if (!args || !args->next || args->next->next) { - return make_error_fmt("'<': expected exactly two arguments"); - } - - MalType* first_val = args->data; - MalType* second_val = args->next->data; - - if (!is_number(first_val) || !is_number(second_val)) { - return make_error_fmt("'<': expected numerical arguments"); - } - - int cmp = 0; - - if (is_integer(first_val) && is_integer(second_val)) { - cmp = (first_val->value.mal_integer < second_val->value.mal_integer); - } - else if (is_integer(first_val) && is_float(second_val)) { - cmp = (first_val->value.mal_integer < second_val->value.mal_float); - } - else if (is_float(first_val) && is_integer(second_val)) { - cmp = (first_val->value.mal_float < second_val->value.mal_integer); - } - else if (is_float(first_val) && is_float(second_val)) { - cmp = (first_val->value.mal_float < second_val->value.mal_float); - } - else { - /* shouldn't happen unless new numerical type is added */ - return make_error_fmt("'<': unknown numerical type"); - } - - if (cmp) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_lessthanorequalto(list args) { - - if (!args || !args->next || args->next->next) { - return make_error_fmt("'<=': expected exactly two arguments"); - } - - MalType* first_val = args->data; - MalType* second_val = args->next->data; - - if (!is_number(first_val) || !is_number(second_val)) { - return make_error_fmt("'<=': expected numerical arguments"); - } - - int cmp = 0; - - if (is_integer(first_val) && is_integer(second_val)) { - cmp = (first_val->value.mal_integer <= second_val->value.mal_integer); - } - else if (is_integer(first_val) && is_float(second_val)) { - cmp = (first_val->value.mal_integer <= second_val->value.mal_float); - } - else if (is_float(first_val) && is_integer(second_val)) { - cmp = (first_val->value.mal_float <= second_val->value.mal_integer); - } - else if (is_float(first_val) && is_float(second_val)) { - cmp = (first_val->value.mal_float < second_val->value.mal_float); - } - else { - /* shouldn't happen unless new numerical type is added */ - return make_error_fmt("'<=': unknown numerical type"); - } - - if (cmp) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_greaterthan(list args) { - - if (!args || !args->next || args->next->next) { - return make_error_fmt("'>': expected exactly two arguments"); - } - - MalType* first_val = args->data; - MalType* second_val = args->next->data; - - if (!is_number(first_val) || !is_number(second_val)) { - return make_error_fmt("'>': expected numerical arguments"); - } - - int cmp = 0; - - if (is_integer(first_val) && is_integer(second_val)) { - cmp = (first_val->value.mal_integer > second_val->value.mal_integer); - } - else if (is_integer(first_val) && is_float(second_val)) { - cmp = (first_val->value.mal_integer > second_val->value.mal_float); - } - else if (is_float(first_val) && is_integer(second_val)) { - cmp = (first_val->value.mal_float > second_val->value.mal_integer); - } - else if (is_float(first_val) && is_float(second_val)) { - cmp = (first_val->value.mal_float > second_val->value.mal_float); - } - else { - /* shouldn't happen unless new numerical type is added */ - return make_error_fmt("'>': unknown numerical type"); - } - - if (cmp) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_greaterthanorequalto(list args) { - - if (!args || !args->next || args->next->next) { - return make_error_fmt("'>=': expected exactly two arguments"); - } - - MalType* first_val = args->data; - MalType* second_val = args->next->data; - - if (!is_number(first_val) || !is_number(second_val)) { - return make_error_fmt("'>=': expected numerical arguments"); - } - - int cmp = 0; - - if (is_integer(first_val) && is_integer(second_val)) { - cmp = (first_val->value.mal_integer >= second_val->value.mal_integer); - } - else if (is_integer(first_val) && is_float(second_val)) { - cmp = (first_val->value.mal_integer >= second_val->value.mal_float); - } - else if (is_float(first_val) && is_integer(second_val)) { - cmp = (first_val->value.mal_float >= second_val->value.mal_integer); - } - else if (is_float(first_val) && is_float(second_val)) { - cmp = (first_val->value.mal_float >= second_val->value.mal_float); - } - else { - /* shouldn't happen unless new numerical type is added */ - return make_error_fmt("'>=': unknown numerical type"); - } - - if (cmp) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_equals(list args) { - /* Accepts any type of arguments */ - - if (!args || !args->next || args->next->next) { - return make_error_fmt("'=': expected exactly two arguments"); - } - - MalType* first_val = args->data; - MalType* second_val = args->next->data; - - if (is_sequential(first_val) && is_sequential(second_val)) { - return equal_lists(first_val, second_val); - } - else if (first_val->type != second_val->type) { - return make_false(); - } - else { - - switch(first_val->type) { - - case MALTYPE_INTEGER: - - if (first_val->value.mal_integer == second_val->value.mal_integer) { - return make_true(); - } else { - return make_false(); - } - break; - - case MALTYPE_FLOAT: - - if (first_val->value.mal_float == second_val->value.mal_float) { - return make_true(); - } else { - return make_false(); - } - break; - - case MALTYPE_SYMBOL: - - if (strcmp(first_val->value.mal_symbol, second_val->value.mal_symbol) == 0) { - return make_true(); - } else { - return make_false(); - } - break; - - case MALTYPE_STRING: - if (strcmp(first_val->value.mal_string, second_val->value.mal_string) == 0) { - return make_true(); - } else { - return make_false(); - } - break; - - case MALTYPE_KEYWORD: - if (strcmp(first_val->value.mal_keyword, second_val->value.mal_keyword) == 0) { - return make_true(); - } else { - return make_false(); - } - break; - - case MALTYPE_HASHMAP: - return equal_hashmaps(first_val, second_val); - break; - - case MALTYPE_TRUE: - case MALTYPE_FALSE: - case MALTYPE_NIL: - - return make_true(); - break; - - case MALTYPE_FUNCTION: - - if (first_val->value.mal_function == second_val->value.mal_function) { - return make_true(); - } else { - return make_false(); - } - break; - - case MALTYPE_CLOSURE: - - if (&first_val->value.mal_closure == &second_val->value.mal_closure) { - return make_true(); - } else { - return make_false(); - } - break; - } - } - return make_false(); -} - -MalType* mal_list(list args) { - /* Accepts any number and type of arguments */ - return make_list(args); -} - -MalType* mal_nth(list args) { - - if (!args || !args->next || args->next->next) { - return make_error("'nth': Expected exactly two arguments"); - } - - MalType* lst = args->data; - MalType* n = args->next->data; - - if (!is_sequential(lst)) { - return make_error_fmt("'nth': first argument is not a list or vector: '%s'\n", pr_str(lst, UNREADABLY)); - } - - if (!is_integer(n)) { - return make_error_fmt("'nth': second argument is not an integer: '%s'\n", pr_str(lst, UNREADABLY)); - } - - MalType* result = list_nth(lst->value.mal_list, n->value.mal_integer); - - if (result) { - return result; - } - else { - return make_error_fmt("'nth': index %s out of bounds for: '%s'\n", \ - pr_str(n, UNREADABLY), pr_str(lst, UNREADABLY)); - } -} - -MalType* mal_first(list args) { - - if (!args || args->next) { - return make_error("'first': expected exactly one argument"); - } - - MalType* lst = args->data; - - if (!is_sequential(lst) && !is_nil(lst)) { - return make_error("'first': expected a list or vector"); - } - - MalType* result = list_first(lst->value.mal_list); - - if (result) { - return result; - } - else { - return make_nil(); - } -} - -MalType* mal_rest(list args) { - - if (!args || args->next) { - return make_error("'rest': expected exactly one argument"); - } - - MalType* lst = args->data; - - if (!is_sequential(lst) && !is_nil(lst)) { - return make_error("'rest': expected a list or vector"); - } - - list result = list_rest(lst->value.mal_list); - - if (lst) { - return make_list(result); - } - else { - return make_nil(); - } -} - - -MalType* mal_cons(list args) { - - if (!args || (args->next && args->next->next)) { - return make_error("'cons': Expected exactly two arguments"); - } - - MalType* lst = args->next->data; - if (is_sequential(lst)) { - return make_list(list_push(lst->value.mal_list, args->data)); - } - else if (is_nil(lst)) { - return make_list(list_push(NULL, args->data)); - } - else { - return make_error_fmt("'cons': second argument is not a list or vector: '%s'\n", \ - pr_str(lst, UNREADABLY)); - } -} - -MalType* mal_concat(list args) { - - /* return an empty list for no arguments */ - if (!args) { - return make_list(NULL); - } - - list new_list = NULL; - while (args) { - - MalType* val = args->data; - - /* skip nils */ - if (is_nil(val)) { - args = args->next; - continue; - } - /* concatenate lists and vectors */ - else if (is_sequential(val)) { - - list lst = val->value.mal_list; - new_list = list_concatenate(new_list, lst); - args = args->next; - } - /* raise an error for any non-sequence types */ - else { - return make_error_fmt("'concat': all arguments must be lists or vectors '%s'", \ - pr_str(val, UNREADABLY)); - } - } - return make_list(new_list); -} - -MalType* mal_count(list args) { - - if (args->next) { - return make_error_fmt("'count': too many arguments"); - } - - MalType* val = args->data; - if (!is_sequential(val) && !is_nil(val)) { - return make_error_fmt("'count': argument is not a list or vector: '%s'\n", \ - pr_str(val, UNREADABLY)); - } - return make_integer(list_count(val->value.mal_list)); -} - - -MalType* mal_list_questionmark(list args) { - - if (args->next) { - return make_error_fmt("'list?': too many arguments"); - } - - MalType* val = args->data; - if (is_list(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_empty_questionmark(list args) { - - if (args->next) { - return make_error_fmt("'empty?': too many arguments"); - } - - MalType* val = args->data; - if (!is_sequential(val)) { - return make_error_fmt("'empty?': argument is not a list or vector: '%s'\n", pr_str(val, UNREADABLY)); - } - - if (!val->value.mal_list) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_pr_str(list args) { - /* Accepts any number and type of arguments */ - return as_str(args, READABLY, " "); -} - -MalType* mal_str(list args) { - /* Accepts any number and type of arguments */ - return as_str(args, UNREADABLY, ""); -} - -MalType* mal_prn(list args) { - /* Accepts any number and type of arguments */ - return print(args, READABLY, " "); -} - -MalType* mal_println(list args) { - /* Accepts any number and type of arguments */ - return print(args, UNREADABLY, " "); -} - -MalType* mal_read_string(list args) { - - if (!args || args->next) { - return make_error_fmt("'read-string': expected exactly one argument"); - } - - MalType* val = args->data; - if (!is_string(val)) { - return make_error_fmt("'read-string': expected a string argument '%s'", pr_str(val, UNREADABLY)); - } - return read_str(val->value.mal_string); -} - -MalType* mal_slurp(list args) { - - if (args->next) { - return make_error_fmt("'slurp': too many arguments"); - } - - MalType* filename = args->data; - if (!is_string(filename)) { - return make_error_fmt("'slurp': expected a string argument"); - } - - long file_length = 0; - FILE* file = fopen(filename->value.mal_string, "rb"); - - if (!file){ - return make_error_fmt("'slurp': file not found '%s'", pr_str(filename, UNREADABLY)); - } - - fseek(file, 0, SEEK_END); - file_length = ftell(file); - fseek(file, 0, SEEK_SET); - - char* buffer = (char*)GC_MALLOC(sizeof(*buffer) * file_length + 1); - if (file_length != fread(buffer, sizeof(*buffer), file_length, file)) { - return make_error_fmt("'slurp': failed to read file '%s'", pr_str(filename, UNREADABLY)); - } - - fclose(file); - - buffer[file_length] = '\0'; - return make_string(buffer); -} - -MalType* mal_atom(list args) { - - if (!args || args->next) { - return make_error_fmt("'atom': expected exactly one argument"); - } - - MalType* val = args->data; - return make_atom(val); -} - -MalType* mal_atom_questionmark(list args) { - - if (!args || args->next) { - return make_error_fmt("'atom?': expected exactly one argument"); - } - - MalType* val = args->data; - - if (is_atom(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_deref(list args) { - - if (!args || args->next) { - return make_error_fmt("'deref': expected exactly one argument"); - } - - MalType* val = args->data; - - if (!is_atom(val)) { - return make_error_fmt("'deref': value is not an atom '%s'", pr_str(val, UNREADABLY)); - } - - return val->value.mal_atom; -} - -MalType* mal_reset_bang(list args) { - - if (!args || args->next->next) { - return make_error_fmt("'reset!': expected exactly two arguments"); - } - - MalType* val = args->data; - - if (!is_atom(val)) { - return make_error_fmt("'reset!': value is not an atom '%s'", pr_str(val, UNREADABLY)); - } - - val->value.mal_atom = args->next->data; - return args->next->data; -} - -MalType* mal_swap_bang(list args) { - - MalType* val = args->data; - - if (!is_atom(val)) { - return make_error_fmt("'swap!': first argument is not an atom '%s'", pr_str(val, UNREADABLY)); - } - - MalType* fn = args->next->data; - - if (!is_callable(fn)) { - return make_error_fmt("'swap!': second argument is not callable '%s'", pr_str(fn, UNREADABLY)); - } - - list fn_args = args->next->next; - fn_args = list_push(fn_args, val->value.mal_atom); - - MalType* result = apply(fn, fn_args); - - if (is_error(result)) { - return result; - } - else { - val->value.mal_atom = result; - return result; - } -} - -MalType* mal_throw(list args) { - - if (!args || args->next) { - return make_error_fmt("'throw': expected exactly one argument"); - } - - MalType* val = args->data; - - /* re-throw an existing exception */ - if (is_error(val)) { - return val; - } - /* create a new exception */ - else { - return wrap_error(val); - } -} - -MalType* mal_apply(list args) { - - if (!args || !args->next) { - return make_error("'apply': expected at least two arguments"); - } - - MalType* func = args->data; - - if (!is_callable(func)) { - return make_error("'apply': first argument must be callable"); - } - - /* assemble loose arguments */ - args = args->next; - list lst = NULL; - while(args->next) { - lst = list_push(lst, args->data); - args = args->next; - } - - MalType* final = args->data; - - if (is_sequential(final)) { - lst = list_concatenate(list_reverse(lst), final->value.mal_list); - } - else { - lst = list_push(lst, final); - lst = list_reverse(lst); - } - - return apply(func, lst); -} - -MalType* mal_map(list args) { - - if (!args || !args->next || args->next->next) { - return make_error("'map': expected two arguments"); - } - - MalType* func = args->data; - - if (!is_callable(func)) { - return make_error("'map': first argument must be a function"); - } - - MalType* arg = args->next->data; - - if (!is_sequential(arg)) { - return make_error("'map': second argument must be a list or vector"); - } - - list arg_list = arg->value.mal_list; - list result_list = NULL; - - while(arg_list) { - - MalType* result = apply(func, list_make(arg_list->data)); - - /* early return if error */ - if (is_error(result)) { - return result; - } - else { - result_list = list_push(result_list, result); - } - arg_list = arg_list->next; - } - return make_list(list_reverse(result_list)); -} - -MalType* mal_nil_questionmark(list args) { - - if (!args || args->next) { - return make_error("'nil?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_nil(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_true_questionmark(list args) { - - if (!args || args->next) { - return make_error("'true?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_true(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_false_questionmark(list args) { - - if (!args || args->next) { - return make_error("'false?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_false(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_symbol_questionmark(list args) { - - if (!args || args->next) { - return make_error("'symbol?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_symbol(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_symbol(list args) { - - if (!args || args->next) { - return make_error("'symbol': expected a single argument"); - } - - MalType* val = args->data; - - if (!is_string(val)) { - return make_error("'symbol': expected a string argument"); - } - else { - return make_symbol(val->value.mal_string); - } -} - -MalType* mal_keyword(list args) { - - if (!args || args->next) { - return make_error("'keyword': expected a single argument"); - } - - MalType* val = args->data; - - if (!is_string(val) && !is_keyword(val)) { - return make_error("'keyword': expected a string argument"); - } - else { - return make_keyword(val->value.mal_string); - } -} - -MalType* mal_keyword_questionmark(list args) { - - if (!args || args->next) { - return make_error("'keyword?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_keyword(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_vec(list args) { - - /* Accepts a single argument */ - - if (!args || args->next) { - return make_error("'vec': expected a single argument"); - } - - MalType* val = args->data; - - if (!is_vector(val) && !is_list(val) && !is_hashmap(val)) { - return make_error("'vec': expected a vector, list or hashmap"); - } - - MalType* new_val = copy_type(val); - new_val->type = MALTYPE_VECTOR; - - return new_val; -} - -MalType* mal_vector(list args) { - /* Accepts any number and type of arguments */ - return make_vector(args); -} - -MalType* mal_vector_questionmark(list args) { - - if (!args || args->next) { - return make_error("'vector?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_vector(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_sequential_questionmark(list args) { - - if (!args || args->next) { - return make_error("'sequential?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_sequential(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_hash_map(list args) { - - if (args && list_count(args) % 2 == 1) { - return make_error("'hashmap': odd number of arguments, expected key/value pairs"); - } - - list args_iterator = args; - while (args_iterator) { - - MalType* val = args_iterator->data; - - if (!is_keyword(val) && !is_string(val) && !is_symbol(val)) { - return make_error("'hashmap': keys must be keywords, symbols or strings"); - } - args_iterator = args_iterator->next; - args_iterator = args_iterator->next; - } - - return make_hashmap(args); -} - -MalType* mal_map_questionmark(list args) { - - if (!args || args->next) { - return make_error("'map?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_hashmap(val)) { - return make_true(); - } - else { - return make_false(); - } -} - - -MalType* mal_get(list args) { - /* TODO: implement a proper hashmap */ - - if (!args || args->next->next) { - return make_error("'get': expected exactly two arguments"); - } - - MalType* map = args->data; - - if (!is_hashmap(map) && !is_nil(map)) { - return make_error("'get': expected a map for the first argument"); - } - - MalType* result = hashmap_getf(map->value.mal_list, get_fn(args->next->data), get_fn); - - if (!result) { - return make_nil(); - } - - return result; -} - -MalType* mal_contains_questionmark(list args) { - - if (!args || args->next->next) { - return make_error("'contains?': expected exactly two arguments"); - } - - MalType* map = args->data; - - if (!is_hashmap(map)) { - return make_error("'contains?': expected a map for the first argument"); - } - - MalType* result = hashmap_getf(map->value.mal_list, get_fn(args->next->data), get_fn); - - if (!result) { - return make_false(); - } - else { - return make_true(); - } -} - -MalType* mal_assoc(list args) { - - if (!args || !args->next || !args->next->next) { - return make_error("'assoc': expected at least three arguments"); - } - - MalType* map = args->data; - - if (!is_hashmap(map)) { - return make_error("'assoc': expected a map for the first argument"); - } - - if (list_count(args->next)%2 != 0) { - return make_error("'assoc': expected even number of key/value pairs"); - } - - - list new_lst = list_reverse(list_copy(map->value.mal_list)); - args = args->next; - - while (args) { - - /* try to update copy in-place */ - hashmap result = hashmap_updatef(new_lst, get_fn(args->data), args->next->data, get_fn); - - if (result) { - new_lst = result; - } - /* add a new key/value pair */ - else { - new_lst = list_push(new_lst,args->next->data); - new_lst = list_push(new_lst,args->data); - } - args = args->next->next; - } - return make_hashmap(new_lst); -} - -MalType* mal_dissoc(list args) { - - if (!args || !args->next) { - return make_error("'dissoc': expected at least two arguments"); - } - - MalType* map = args->data; - - if (!is_hashmap(map)) { - return make_error("'dissoc': expected a map for the first argument"); - } - - list source_list = map->value.mal_list; - list new_list = NULL; - args = args->next; - - while(source_list) { - - list dis_args = args; - long dis = 0; - - - while(dis_args) { - - list tmp = NULL; - tmp = list_push(tmp, source_list->data); - tmp = list_push(tmp, dis_args->data); - MalType* cmp = mal_equals(tmp); - - if (is_true(cmp)) { - dis = 1; - break; - } - dis_args = dis_args->next; - } - - if (!dis) { - new_list = list_push(new_list, source_list->data); - new_list = list_push(new_list, source_list->next->data); - } - source_list = source_list->next->next; - } - - return make_hashmap(list_reverse(new_list)); -} - - -MalType* mal_keys(list args) { - - if (!args || args->next) { - return make_error("'keys': expected exactly one argument"); - } - - MalType* map = args->data; - - if (!is_hashmap(map)) { - return make_error("'keys': expected a map"); - } - - list lst = map->value.mal_list; - if (!lst) { - return make_list(NULL); - } - - list result = list_make(lst->data); - while(lst->next->next) { - - lst = lst->next->next; - result = list_push(result, lst->data); - } - return make_list(result); -} - -MalType* mal_vals(list args) { - - if (!args || args->next) { - return make_error("'vals': expected exactly one argument"); - } - - MalType* map = args->data; - - if (!is_hashmap(map)) { - return make_error("'vals': expected a map"); - } - - list lst = map->value.mal_list; - if (!lst) { - return make_list(NULL); - } - - lst = lst->next; - list result = list_make(lst->data); - while(lst->next) { - - lst = lst->next->next; - result = list_push(result, lst->data); - } - return make_list(result); -} - -MalType* mal_string_questionmark(list args) { - - if (!args || args->next) { - return make_error("'string?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_string(val)) { - return make_true(); - } - else { - return make_false(); - } -} - - -MalType* mal_number_questionmark(list args) { - - if (!args || args->next) { - return make_error("'number?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_number(val)) { - return make_true(); - } - else { - return make_false(); - } -} - - -MalType* mal_fn_questionmark(list args) { - - if (!args || args->next) { - return make_error("'fn?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_callable(val) && !is_macro(val)) { - return make_true(); - } - else { - return make_false(); - } -} - -MalType* mal_macro_questionmark(list args) { - - if (!args || args->next) { - return make_error("'macro?': expected a single argument"); - } - - MalType* val = args->data; - - if (is_macro(val)) { - return make_true(); - } - else { - return make_false(); - } -} - - -MalType* mal_time_ms(list args) { - - struct timeval tv; - gettimeofday(&tv, NULL); - long ms = tv.tv_sec * 1000 + tv.tv_usec/1000.0 + 0.5; - - return make_float(ms); -} - - -MalType* mal_conj(list args) { - - if (!args || !args->next) { - return make_error("'conj': Expected at least two arguments"); - } - - MalType* lst = args->data; - - if (!is_sequential(lst)) { - return make_error_fmt("'conj': first argument is not a list or vector: '%s'\n", \ - pr_str(lst, UNREADABLY)); - } - - list rest = args->next; - - if (is_list(lst)) { - - list new_lst = list_reverse(list_copy(lst->value.mal_list)); - - while(rest) { - new_lst = list_push(new_lst, rest->data); - rest = rest->next; - } - return make_list(new_lst); - } - else /* is_vector(lst) */ { - - list new_lst = list_copy(lst->value.mal_list); - - while(rest) { - new_lst = list_push(new_lst, rest->data); - rest = rest->next; - } - return make_vector(list_reverse(new_lst)); - } -} - -MalType* mal_seq(list args) { - - if (!args || args->next) { - return make_error("'seq': expected exactly one argument"); - } - - MalType* val = args->data; - - if (is_sequential(val)) { - - /* empy list or vector */ - if (!val->value.mal_list) { - return make_nil(); - } - else { - return make_list(val->value.mal_list); - } - } - else if (is_string(val)) { - - /* empty string */ - if (*(val->value.mal_string) == '\0') { - return make_nil(); - } - else { - - char* ch = val->value.mal_string; - list lst = NULL; - - while(*ch != '\0') { - char* new_ch = GC_MALLOC(sizeof(*new_ch)); - strncpy(new_ch, ch, 1); - - lst = list_push(lst, make_string(new_ch)); - ch++; - } - return make_list(list_reverse(lst)); - } - } - else if (is_nil(val)) { - return make_nil(); - } - else { - return make_error("'seq': expected a list, vector or string"); - } -} - -MalType* mal_meta(list args) { - - if (!args || args->next) { - return make_error("'meta': expected exactly one argument"); - } - - MalType* val = args->data; - - if (!is_sequential(val) && !is_hashmap(val) && !is_callable(val)) { - return make_error("'meta': metadata not supported for data type"); - } - - if (!val->metadata) { - return make_nil(); - } else { - return val->metadata; - } -} - -MalType* mal_with_meta(list args) { - - if (!args || !args->next || args->next->next) { - return make_error("'with-meta': expected exactly two arguments"); - } - - MalType* val = args->data; - - if (!is_sequential(val) && !is_hashmap(val) && !is_callable(val)) { - return make_error("'with-meta': metadata not supported for data type"); - } - - MalType* metadata = args->next->data; - - MalType* new_val = copy_type(val); - new_val->metadata = metadata; - - return new_val; -} - - -/* helper functions */ - -MalType* as_str(list args, int readably, char* separator) { - - long buffer_length = STRING_BUFFER_SIZE; - long separator_length = strlen(separator); - char* buffer = GC_MALLOC(sizeof(*buffer) * STRING_BUFFER_SIZE); - long char_count = 0; - - while(args) { - - MalType* arg = args->data; - char* str = pr_str(arg, readably); - int len = strlen(str); - - char_count += len; - char_count += separator_length; - if (char_count >= buffer_length) { - buffer = GC_REALLOC(buffer, sizeof(*buffer) * char_count + 1); - } - - strncat(buffer, str, char_count); - args = args->next; - - if (args) { - strcat(buffer, separator); - } - } - return make_string(buffer); -} - -MalType* print(list args, int readably, char* separator) { - - while(args) { - - printf("%s", pr_str(args->data, readably)); - args = args->next; - - if (args) { - printf("%s", separator); - } - } - printf("\n"); - - return make_nil(); -} - -MalType* equal_lists(MalType* list1, MalType* list2) { - - list first = list1->value.mal_list; - list second = list2->value.mal_list; - - if (list_count(first) != list_count(second)) { - return make_false(); - } - else { - - while(first && second) { - - list args = NULL; - args = list_push(args, second->data); - args = list_push(args, first->data); - - MalType* cmp = mal_equals(args); - - if (is_false(cmp)) { - return make_false(); - break; - } - first = first->next; - second = second->next; - } - return make_true(); - } -} - -MalType* equal_hashmaps(MalType* map1, MalType* map2) { - - list first = map1->value.mal_list; - list second = map2->value.mal_list; - - if (!first && !second) { - return make_true(); - } - - if (list_count(first) != list_count(second)) { - return make_false(); - } - - while (first) { - - MalType* key1 = first->data; - MalType* val1 = first->next->data; - MalType* val2 = hashmap_getf(second, get_fn(key1), get_fn); - - if (!val2) { - return make_false(); - } - - list args = NULL; - args = list_push(args, val1); - args = list_push(args, val2); - - MalType* cmp = mal_equals(args); - - if (is_false(cmp)) { - return make_false(); - break; - } - first = first->next->next; - } - return make_true(); -} - -/* helper function for get */ -char* get_fn(gptr data) { - - MalType* val = data; - - switch (val->type) { - - case MALTYPE_STRING: - - return (val->value.mal_string); - break; - - case MALTYPE_SYMBOL: - - return (val->value.mal_symbol); - break; - - case MALTYPE_KEYWORD: - - return (val->value.mal_keyword); - break; - - default: - return NULL; - } -} - -#ifdef WITH_FFI -MalType* mal_dot(list args) { - - /* (. "lib" "return type" "function" "arg1 type" "arg 1" ...) */ - - if (!args || !args->next || !args->next->next) { - return make_error("'.': expected at least three arguments"); - } - - MalType* lib_name = (MalType*)args->data; - - if (!is_string(lib_name) && !is_nil(lib_name)) { - return make_error("'.': expected library name or nil for first argument"); - } - - MalType* return_type = (MalType*)args->next->data; - - if (!is_string(return_type)) { - return make_error("'.': expected string (return type) for second argument"); - } - - MalType* fn_name = (MalType*)args->next->next->data; - - if (!is_string(fn_name)) { - return make_error("'.': expected string (function name) for third argument"); - } - - int args_count = list_count(args) - 3; - - if (args_count % 2 == 1) { - return make_error("'.': expected even number of argument types and values"); - } - - list arg_types_list = NULL; - list arg_vals_list = NULL; - - args = args->next->next->next; - while(args) { - - MalType* val_type = (MalType*)args->data; - MalType* val = (MalType*)args->next->data; - - if (!is_string(val_type)) { - return make_error_fmt("'.': expected strings for argument types: '%s'", pr_str(val_type, UNREADABLY)); - } - - arg_types_list = list_push(arg_types_list, val_type); - arg_vals_list = list_push(arg_vals_list, val); - - args = args->next->next; - } - - arg_types_list = list_reverse(arg_types_list); - arg_vals_list = list_reverse(arg_vals_list); - - /* open a shared library dynamically and get hold of a function */ - gptr lib_handle; - if (!is_nil(lib_name)) { - lib_handle = dlopen(lib_name->value.mal_string, RTLD_LAZY); - } else { - lib_handle = dlopen(NULL, RTLD_LAZY); - } - - if (!lib_handle) { - return make_error_fmt("'ffi`' reports: %s", dlerror()); - } - - gptr fn = dlsym(lib_handle, fn_name->value.mal_string); - - char* error; - if ((error = dlerror()) != NULL) { - return make_error_fmt("'ffi' dlsym could not get handle to function '%s': %s", fn_name->value.mal_string, error); - } - - /* use libffi to call function */ - - ffi_cif cif; - ffi_type* ret_type; - ffi_type* arg_types[20]; - void* arg_vals[20]; - ffi_status status; - ffi_type* ffi_get_type(char *type, MalType* err); - - MalType* mal_err = make_nil(); - - /* set return type */ - MalType* make_type(char *type); - MalType* retval = make_type(return_type->value.mal_string); - - ret_type = ffi_get_type(return_type->value.mal_string, mal_err); - if (is_error(mal_err)) { return mal_err; } - - int arg_count = list_count(arg_types_list); - - /* Set the argument types and values */ - for (int i = 0; i < arg_count; i++) { - - MalType* val_type = (MalType*)arg_types_list->data; - arg_types[i] = ffi_get_type(val_type->value.mal_string, mal_err); - if (is_error(mal_err)) { return mal_err; } - - MalType* val = (MalType*)arg_vals_list->data; - arg_vals[i] = &(val->value); - - arg_types_list = arg_types_list->next; - arg_vals_list = arg_vals_list->next; - } - - /* perform the call */ - status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, arg_count, ret_type, arg_types); - - if (status != FFI_OK) { - return make_error_fmt("'ffi' call to ffi_prep_cif failed with code: %d\n", status); - } - - ffi_call(&cif, FFI_FN(fn), &retval->value, arg_vals); - - /* close the library */ - dlclose(lib_handle); - - if (ret_type == &ffi_type_void) { - return make_nil(); - } else { - return retval; - } -} - -/* helper function for ffi */ -ffi_type* ffi_get_type(char *type, MalType* err) { - - if ((strcmp("void", type) == 0)) { - - return &ffi_type_void; - } - else if ((strcmp("string", type) == 0) || - (strcmp("char*", type) == 0) || - (strcmp("char *", type) == 0)) { - - return &ffi_type_pointer; - } - else if ((strcmp("integer", type) == 0) || - (strcmp("int64", type) == 0)) { - - return &ffi_type_sint64; - } - else if ((strcmp("int32", type) == 0)) { - - return &ffi_type_sint32; - } - else if (strcmp("double", type) == 0) { - - return &ffi_type_double; - } - else if (strcmp("float", type) == 0) { - return &ffi_type_float; - } - else { - err = make_error_fmt("'ffi' type not recognised '%'", type); - return NULL; - } -} - -/* helper function for ffi */ -MalType* make_type(char *type) { - - if ((strcmp("void", type) == 0)) { - - return make_nil(); - } - else if ((strcmp("string", type) == 0) || - (strcmp("char*", type) == 0) || - (strcmp("char *", type) == 0)) { - - return make_string(""); - } - else if ((strcmp("integer", type) == 0) || - (strcmp("int64", type) == 0)) { - - return make_integer(0); - } - else if ((strcmp("int32", type) == 0)) { - return make_integer(0); - } - else if (strcmp("double", type) == 0) { - - return make_float(0); - } - else if (strcmp("float", type) == 0) { - - return make_float(0); - } - else { - return make_error_fmt("'ffi' type not supported '%s'", type); - } -} -#endif +#include +#include +#include +#include +#include + +/* only needed for ffi */ +#ifdef WITH_FFI +#include +#include +#endif + +#include "libs/hashmap/hashmap.h" +#include "core.h" +#include "types.h" +#include "printer.h" +#include "reader.h" +#include "env.h" + +#define STRING_BUFFER_SIZE 128 + +/* forward references to main file */ +MalType* apply(MalType* fn, list args); + +/* core ns functions */ +MalType* mal_add(list); +MalType* mal_sub(list); +MalType* mal_mul(list); +MalType* mal_div(list); + +MalType* mal_prn(list); +MalType* mal_println(list); +MalType* mal_pr_str(list); +MalType* mal_str(list); +MalType* mal_read_string(list); +MalType* mal_slurp(list); + +MalType* mal_list(list); +MalType* mal_list_questionmark(list); +MalType* mal_empty_questionmark(list); +MalType* mal_count(list); +MalType* mal_cons(list); +MalType* mal_concat(list); +MalType* mal_nth(list); +MalType* mal_first(list); +MalType* mal_rest(list); + +MalType* mal_equals(list); +MalType* mal_lessthan(list); +MalType* mal_lessthanorequalto(list); +MalType* mal_greaterthan(list); +MalType* mal_greaterthanorequalto(list); + +MalType* mal_atom(list); +MalType* mal_atom_questionmark(list); +MalType* mal_deref(list); +MalType* mal_reset_bang(list); +MalType* mal_swap_bang(list); + +MalType* mal_throw(list); +MalType* mal_apply(list); +MalType* mal_map(list); + +MalType* mal_nil_questionmark(list); +MalType* mal_true_questionmark(list); +MalType* mal_false_questionmark(list); +MalType* mal_symbol_questionmark(list); +MalType* mal_keyword_questionmark(list); +MalType* mal_symbol(list); +MalType* mal_keyword(list); + +MalType* mal_vec(list); +MalType* mal_vector(list); +MalType* mal_vector_questionmark(list); +MalType* mal_sequential_questionmark(list); +MalType* mal_hash_map(list); +MalType* mal_map_questionmark(list); +MalType* mal_assoc(list); +MalType* mal_dissoc(list); +MalType* mal_get(list); +MalType* mal_contains_questionmark(list); +MalType* mal_keys(list); +MalType* mal_vals(list); +MalType* mal_string_questionmark(list); +MalType* mal_number_questionmark(list); +MalType* mal_fn_questionmark(list); +MalType* mal_macro_questionmark(list); + +MalType* mal_time_ms(list); +MalType* mal_conj(list); +MalType* mal_seq(list); +MalType* mal_meta(list); +MalType* mal_with_meta(list); + +/* only needed for ffi */ +#ifdef WITH_FFI +MalType* mal_dot(list); +#endif + +ns* ns_make_core() { + + ns* core = GC_MALLOC(sizeof(*core)); + + hashmap core_functions = NULL; + + /* arithmetic */ + core_functions = hashmap_put(core_functions, "+", mal_add); + core_functions = hashmap_put(core_functions, "-", mal_sub); + core_functions = hashmap_put(core_functions, "*", mal_mul); + core_functions = hashmap_put(core_functions, "/", mal_div); + + /* strings */ + core_functions = hashmap_put(core_functions, "prn", mal_prn); + core_functions = hashmap_put(core_functions, "pr-str", mal_pr_str); + core_functions = hashmap_put(core_functions, "str", mal_str); + core_functions = hashmap_put(core_functions, "println", mal_println); + core_functions = hashmap_put(core_functions, "read-string", mal_read_string); + + /* files */ + core_functions = hashmap_put(core_functions, "slurp", mal_slurp); + + /* lists */ + core_functions = hashmap_put(core_functions, "list", mal_list); + core_functions = hashmap_put(core_functions, "empty?", mal_empty_questionmark); + core_functions = hashmap_put(core_functions, "count", mal_count); + core_functions = hashmap_put(core_functions, "cons", mal_cons); + core_functions = hashmap_put(core_functions, "concat", mal_concat); + core_functions = hashmap_put(core_functions, "nth", mal_nth); + core_functions = hashmap_put(core_functions, "first", mal_first); + core_functions = hashmap_put(core_functions, "rest", mal_rest); + + /* predicates */ + core_functions = hashmap_put(core_functions, "=", mal_equals); + core_functions = hashmap_put(core_functions, "<", mal_lessthan); + core_functions = hashmap_put(core_functions, "<=", mal_lessthanorequalto); + core_functions = hashmap_put(core_functions, ">", mal_greaterthan); + core_functions = hashmap_put(core_functions, ">=", mal_greaterthanorequalto); + + core_functions = hashmap_put(core_functions, "list?", mal_list_questionmark); + core_functions = hashmap_put(core_functions, "nil?", mal_nil_questionmark); + core_functions = hashmap_put(core_functions, "true?", mal_true_questionmark); + core_functions = hashmap_put(core_functions, "false?", mal_false_questionmark); + core_functions = hashmap_put(core_functions, "symbol?", mal_symbol_questionmark); + core_functions = hashmap_put(core_functions, "keyword?", mal_keyword_questionmark); + core_functions = hashmap_put(core_functions, "vector?", mal_vector_questionmark); + core_functions = hashmap_put(core_functions, "sequential?", mal_sequential_questionmark); + core_functions = hashmap_put(core_functions, "map?", mal_map_questionmark); + core_functions = hashmap_put(core_functions, "string?", mal_string_questionmark); + core_functions = hashmap_put(core_functions, "number?", mal_number_questionmark); + core_functions = hashmap_put(core_functions, "fn?", mal_fn_questionmark); + core_functions = hashmap_put(core_functions, "macro?", mal_macro_questionmark); + + /* atoms */ + core_functions = hashmap_put(core_functions, "atom", mal_atom); + core_functions = hashmap_put(core_functions, "atom?", mal_atom_questionmark); + core_functions = hashmap_put(core_functions, "deref", mal_deref); + core_functions = hashmap_put(core_functions, "reset!", mal_reset_bang); + core_functions = hashmap_put(core_functions, "swap!", mal_swap_bang); + + /* other */ + core_functions = hashmap_put(core_functions, "throw", mal_throw); + core_functions = hashmap_put(core_functions, "apply", mal_apply); + core_functions = hashmap_put(core_functions, "map", mal_map); + + core_functions = hashmap_put(core_functions, "symbol", mal_symbol); + core_functions = hashmap_put(core_functions, "keyword", mal_keyword); + core_functions = hashmap_put(core_functions, "vec", mal_vec); + core_functions = hashmap_put(core_functions, "vector", mal_vector); + core_functions = hashmap_put(core_functions, "hash-map", mal_hash_map); + + /* hash-maps */ + core_functions = hashmap_put(core_functions, "contains?", mal_contains_questionmark); + core_functions = hashmap_put(core_functions, "assoc", mal_assoc); + core_functions = hashmap_put(core_functions, "dissoc", mal_dissoc); + core_functions = hashmap_put(core_functions, "get", mal_get); + core_functions = hashmap_put(core_functions, "keys", mal_keys); + core_functions = hashmap_put(core_functions, "vals", mal_vals); + + /* misc */ + core_functions = hashmap_put(core_functions, "time-ms", mal_time_ms); + core_functions = hashmap_put(core_functions, "conj", mal_conj); + core_functions = hashmap_put(core_functions, "seq", mal_seq); + core_functions = hashmap_put(core_functions, "meta", mal_meta); + core_functions = hashmap_put(core_functions, "with-meta", mal_with_meta); + + /* only needed for ffi */ + #ifdef WITH_FFI + core_functions = hashmap_put(core_functions, ".", mal_dot); + #endif + + core->mappings = core_functions; + return core; +} + +/* core function definitons */ + +MalType* mal_add(list args) { + /* Accepts any number of arguments */ + + int return_float = 0; + + long i_sum = 0; + double r_sum = 0.0; + + while(args) { + + MalType* val = args->data; + if (!is_number(val)) { + return make_error("'+': expected numerical arguments"); + } + + if (is_integer(val) && !return_float) { + i_sum = i_sum + val->value.mal_integer; + } + else if (is_integer(val)) { + r_sum = (double)i_sum + r_sum + val->value.mal_integer; + i_sum = 0; + } + else { + r_sum = (double)i_sum + r_sum + val->value.mal_float; + i_sum = 0; + return_float = 1; + } + args = args->next; + } + + if (return_float) { + return make_float(r_sum); + } else { + return make_integer(i_sum); + } +} + +MalType* mal_sub(list args) { + /* Accepts any number of arguments */ + + int return_float = 0; + + long i_sum = 0; + double r_sum = 0.0; + + if (args) { + + MalType* val = args->data; + args = args->next; + + if (!is_number(val)) { + return make_error_fmt("'-': expected numerical arguments"); + } + + if (is_integer(val)) { + i_sum = val->value.mal_integer; + } else { + r_sum = val->value.mal_float; + return_float = 1; + } + + while(args) { + + val = args->data; + + if (!is_number(val)) { + return make_error_fmt("'-': expected numerical arguments"); + } + + if (is_integer(val) && !return_float) { + i_sum = i_sum - val->value.mal_integer; + } + else if (is_integer(val)) { + r_sum = (double)i_sum + r_sum - (double)val->value.mal_integer; + i_sum = 0; + } + else { + r_sum = (double)i_sum + r_sum - val->value.mal_float; + i_sum = 0; + return_float = 1; + } + args = args->next; + } + } + + if (return_float) { + return make_float(r_sum); + } else { + return make_integer(i_sum); + } +} + + +MalType* mal_mul(list args) { + /* Accepts any number of arguments */ + + int return_float = 0; + + long i_product = 1; + double r_product = 1.0; + + while(args) { + + MalType* val = args->data; + + if (!is_number(val)) { + return make_error_fmt("'*': expected numerical arguments"); + } + + if (is_integer(val) && !return_float) { + i_product *= val->value.mal_integer; + } + else if (is_integer(val)) { + r_product *= (double)val->value.mal_integer; + r_product *= (double)i_product; + i_product = 1; + } + else { + r_product *= (double)i_product; + r_product *= val->value.mal_float; + i_product = 1; + return_float = 1; + } + args = args->next; + } + + if (return_float) { + return make_float(r_product); + } else { + return make_integer(i_product); + } +} + +MalType* mal_div(list args) { + /* Accepts any number of arguments */ + + int return_float = 0; + + long i_product = 1; + double r_product = 1.0; + + if (args) { + MalType* val = args->data; + + if (!is_number(val)) { + return make_error_fmt("'/': expected numerical arguments"); + } + + if (is_integer(val)) { + i_product = val->value.mal_integer; + } else { + r_product = val->value.mal_float; + return_float = 1; + } + + args = args->next; + + while(args) { + + val = args->data; + + if (!is_number(val)) { + return make_error_fmt("'/': expected numerical arguments"); + } + + /* integer division */ + if (is_integer(val) && !return_float) { + i_product /= val->value.mal_integer; + } + /* promote integer to double */ + else if (is_integer(val)) { + if (i_product != 1) { + r_product = (double)i_product / (double)val->value.mal_integer; + i_product = 1; + } else { + r_product /= (double)val->value.mal_integer; + } + } + /* double division */ + else { + return_float = 1; + if (i_product != 1) { + r_product = (double)i_product / val->value.mal_float; + i_product = 1; + } else { + r_product /= val->value.mal_float; + } + } + args = args->next; + } + } + + if (return_float) { + return make_float(r_product); + } else { + return make_integer(i_product); + } +} + +MalType* mal_lessthan(list args) { + + if (!args || !args->next || args->next->next) { + return make_error_fmt("'<': expected exactly two arguments"); + } + + MalType* first_val = args->data; + MalType* second_val = args->next->data; + + if (!is_number(first_val) || !is_number(second_val)) { + return make_error_fmt("'<': expected numerical arguments"); + } + + int cmp = 0; + + if (is_integer(first_val) && is_integer(second_val)) { + cmp = (first_val->value.mal_integer < second_val->value.mal_integer); + } + else if (is_integer(first_val) && is_float(second_val)) { + cmp = (first_val->value.mal_integer < second_val->value.mal_float); + } + else if (is_float(first_val) && is_integer(second_val)) { + cmp = (first_val->value.mal_float < second_val->value.mal_integer); + } + else if (is_float(first_val) && is_float(second_val)) { + cmp = (first_val->value.mal_float < second_val->value.mal_float); + } + else { + /* shouldn't happen unless new numerical type is added */ + return make_error_fmt("'<': unknown numerical type"); + } + + if (cmp) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_lessthanorequalto(list args) { + + if (!args || !args->next || args->next->next) { + return make_error_fmt("'<=': expected exactly two arguments"); + } + + MalType* first_val = args->data; + MalType* second_val = args->next->data; + + if (!is_number(first_val) || !is_number(second_val)) { + return make_error_fmt("'<=': expected numerical arguments"); + } + + int cmp = 0; + + if (is_integer(first_val) && is_integer(second_val)) { + cmp = (first_val->value.mal_integer <= second_val->value.mal_integer); + } + else if (is_integer(first_val) && is_float(second_val)) { + cmp = (first_val->value.mal_integer <= second_val->value.mal_float); + } + else if (is_float(first_val) && is_integer(second_val)) { + cmp = (first_val->value.mal_float <= second_val->value.mal_integer); + } + else if (is_float(first_val) && is_float(second_val)) { + cmp = (first_val->value.mal_float < second_val->value.mal_float); + } + else { + /* shouldn't happen unless new numerical type is added */ + return make_error_fmt("'<=': unknown numerical type"); + } + + if (cmp) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_greaterthan(list args) { + + if (!args || !args->next || args->next->next) { + return make_error_fmt("'>': expected exactly two arguments"); + } + + MalType* first_val = args->data; + MalType* second_val = args->next->data; + + if (!is_number(first_val) || !is_number(second_val)) { + return make_error_fmt("'>': expected numerical arguments"); + } + + int cmp = 0; + + if (is_integer(first_val) && is_integer(second_val)) { + cmp = (first_val->value.mal_integer > second_val->value.mal_integer); + } + else if (is_integer(first_val) && is_float(second_val)) { + cmp = (first_val->value.mal_integer > second_val->value.mal_float); + } + else if (is_float(first_val) && is_integer(second_val)) { + cmp = (first_val->value.mal_float > second_val->value.mal_integer); + } + else if (is_float(first_val) && is_float(second_val)) { + cmp = (first_val->value.mal_float > second_val->value.mal_float); + } + else { + /* shouldn't happen unless new numerical type is added */ + return make_error_fmt("'>': unknown numerical type"); + } + + if (cmp) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_greaterthanorequalto(list args) { + + if (!args || !args->next || args->next->next) { + return make_error_fmt("'>=': expected exactly two arguments"); + } + + MalType* first_val = args->data; + MalType* second_val = args->next->data; + + if (!is_number(first_val) || !is_number(second_val)) { + return make_error_fmt("'>=': expected numerical arguments"); + } + + int cmp = 0; + + if (is_integer(first_val) && is_integer(second_val)) { + cmp = (first_val->value.mal_integer >= second_val->value.mal_integer); + } + else if (is_integer(first_val) && is_float(second_val)) { + cmp = (first_val->value.mal_integer >= second_val->value.mal_float); + } + else if (is_float(first_val) && is_integer(second_val)) { + cmp = (first_val->value.mal_float >= second_val->value.mal_integer); + } + else if (is_float(first_val) && is_float(second_val)) { + cmp = (first_val->value.mal_float >= second_val->value.mal_float); + } + else { + /* shouldn't happen unless new numerical type is added */ + return make_error_fmt("'>=': unknown numerical type"); + } + + if (cmp) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_equals(list args) { + /* Accepts any type of arguments */ + + if (!args || !args->next || args->next->next) { + return make_error_fmt("'=': expected exactly two arguments"); + } + + MalType* first_val = args->data; + MalType* second_val = args->next->data; + + if (is_sequential(first_val) && is_sequential(second_val)) { + return equal_lists(first_val, second_val); + } + else if (first_val->type != second_val->type) { + return make_false(); + } + else { + + switch(first_val->type) { + + case MALTYPE_INTEGER: + + if (first_val->value.mal_integer == second_val->value.mal_integer) { + return make_true(); + } else { + return make_false(); + } + break; + + case MALTYPE_FLOAT: + + if (first_val->value.mal_float == second_val->value.mal_float) { + return make_true(); + } else { + return make_false(); + } + break; + + case MALTYPE_SYMBOL: + + if (strcmp(first_val->value.mal_symbol, second_val->value.mal_symbol) == 0) { + return make_true(); + } else { + return make_false(); + } + break; + + case MALTYPE_STRING: + if (strcmp(first_val->value.mal_string, second_val->value.mal_string) == 0) { + return make_true(); + } else { + return make_false(); + } + break; + + case MALTYPE_KEYWORD: + if (strcmp(first_val->value.mal_keyword, second_val->value.mal_keyword) == 0) { + return make_true(); + } else { + return make_false(); + } + break; + + case MALTYPE_HASHMAP: + return equal_hashmaps(first_val, second_val); + break; + + case MALTYPE_TRUE: + case MALTYPE_FALSE: + case MALTYPE_NIL: + + return make_true(); + break; + + case MALTYPE_FUNCTION: + + if (first_val->value.mal_function == second_val->value.mal_function) { + return make_true(); + } else { + return make_false(); + } + break; + + case MALTYPE_CLOSURE: + + if (&first_val->value.mal_closure == &second_val->value.mal_closure) { + return make_true(); + } else { + return make_false(); + } + break; + } + } + return make_false(); +} + +MalType* mal_list(list args) { + /* Accepts any number and type of arguments */ + return make_list(args); +} + +MalType* mal_nth(list args) { + + if (!args || !args->next || args->next->next) { + return make_error("'nth': Expected exactly two arguments"); + } + + MalType* lst = args->data; + MalType* n = args->next->data; + + if (!is_sequential(lst)) { + return make_error_fmt("'nth': first argument is not a list or vector: '%s'\n", pr_str(lst, UNREADABLY)); + } + + if (!is_integer(n)) { + return make_error_fmt("'nth': second argument is not an integer: '%s'\n", pr_str(lst, UNREADABLY)); + } + + MalType* result = list_nth(lst->value.mal_list, n->value.mal_integer); + + if (result) { + return result; + } + else { + return make_error_fmt("'nth': index %s out of bounds for: '%s'\n", \ + pr_str(n, UNREADABLY), pr_str(lst, UNREADABLY)); + } +} + +MalType* mal_first(list args) { + + if (!args || args->next) { + return make_error("'first': expected exactly one argument"); + } + + MalType* lst = args->data; + + if (!is_sequential(lst) && !is_nil(lst)) { + return make_error("'first': expected a list or vector"); + } + + MalType* result = list_first(lst->value.mal_list); + + if (result) { + return result; + } + else { + return make_nil(); + } +} + +MalType* mal_rest(list args) { + + if (!args || args->next) { + return make_error("'rest': expected exactly one argument"); + } + + MalType* lst = args->data; + + if (!is_sequential(lst) && !is_nil(lst)) { + return make_error("'rest': expected a list or vector"); + } + + list result = list_rest(lst->value.mal_list); + + if (lst) { + return make_list(result); + } + else { + return make_nil(); + } +} + + +MalType* mal_cons(list args) { + + if (!args || (args->next && args->next->next)) { + return make_error("'cons': Expected exactly two arguments"); + } + + MalType* lst = args->next->data; + if (is_sequential(lst)) { + return make_list(list_push(lst->value.mal_list, args->data)); + } + else if (is_nil(lst)) { + return make_list(list_push(NULL, args->data)); + } + else { + return make_error_fmt("'cons': second argument is not a list or vector: '%s'\n", \ + pr_str(lst, UNREADABLY)); + } +} + +MalType* mal_concat(list args) { + + /* return an empty list for no arguments */ + if (!args) { + return make_list(NULL); + } + + list new_list = NULL; + while (args) { + + MalType* val = args->data; + + /* skip nils */ + if (is_nil(val)) { + args = args->next; + continue; + } + /* concatenate lists and vectors */ + else if (is_sequential(val)) { + + list lst = val->value.mal_list; + new_list = list_concatenate(new_list, lst); + args = args->next; + } + /* raise an error for any non-sequence types */ + else { + return make_error_fmt("'concat': all arguments must be lists or vectors '%s'", \ + pr_str(val, UNREADABLY)); + } + } + return make_list(new_list); +} + +MalType* mal_count(list args) { + + if (args->next) { + return make_error_fmt("'count': too many arguments"); + } + + MalType* val = args->data; + if (!is_sequential(val) && !is_nil(val)) { + return make_error_fmt("'count': argument is not a list or vector: '%s'\n", \ + pr_str(val, UNREADABLY)); + } + return make_integer(list_count(val->value.mal_list)); +} + + +MalType* mal_list_questionmark(list args) { + + if (args->next) { + return make_error_fmt("'list?': too many arguments"); + } + + MalType* val = args->data; + if (is_list(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_empty_questionmark(list args) { + + if (args->next) { + return make_error_fmt("'empty?': too many arguments"); + } + + MalType* val = args->data; + if (!is_sequential(val)) { + return make_error_fmt("'empty?': argument is not a list or vector: '%s'\n", pr_str(val, UNREADABLY)); + } + + if (!val->value.mal_list) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_pr_str(list args) { + /* Accepts any number and type of arguments */ + return as_str(args, READABLY, " "); +} + +MalType* mal_str(list args) { + /* Accepts any number and type of arguments */ + return as_str(args, UNREADABLY, ""); +} + +MalType* mal_prn(list args) { + /* Accepts any number and type of arguments */ + return print(args, READABLY, " "); +} + +MalType* mal_println(list args) { + /* Accepts any number and type of arguments */ + return print(args, UNREADABLY, " "); +} + +MalType* mal_read_string(list args) { + + if (!args || args->next) { + return make_error_fmt("'read-string': expected exactly one argument"); + } + + MalType* val = args->data; + if (!is_string(val)) { + return make_error_fmt("'read-string': expected a string argument '%s'", pr_str(val, UNREADABLY)); + } + return read_str(val->value.mal_string); +} + +MalType* mal_slurp(list args) { + + if (args->next) { + return make_error_fmt("'slurp': too many arguments"); + } + + MalType* filename = args->data; + if (!is_string(filename)) { + return make_error_fmt("'slurp': expected a string argument"); + } + + long file_length = 0; + FILE* file = fopen(filename->value.mal_string, "rb"); + + if (!file){ + return make_error_fmt("'slurp': file not found '%s'", pr_str(filename, UNREADABLY)); + } + + fseek(file, 0, SEEK_END); + file_length = ftell(file); + fseek(file, 0, SEEK_SET); + + char* buffer = (char*)GC_MALLOC(sizeof(*buffer) * file_length + 1); + if (file_length != fread(buffer, sizeof(*buffer), file_length, file)) { + return make_error_fmt("'slurp': failed to read file '%s'", pr_str(filename, UNREADABLY)); + } + + fclose(file); + + buffer[file_length] = '\0'; + return make_string(buffer); +} + +MalType* mal_atom(list args) { + + if (!args || args->next) { + return make_error_fmt("'atom': expected exactly one argument"); + } + + MalType* val = args->data; + return make_atom(val); +} + +MalType* mal_atom_questionmark(list args) { + + if (!args || args->next) { + return make_error_fmt("'atom?': expected exactly one argument"); + } + + MalType* val = args->data; + + if (is_atom(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_deref(list args) { + + if (!args || args->next) { + return make_error_fmt("'deref': expected exactly one argument"); + } + + MalType* val = args->data; + + if (!is_atom(val)) { + return make_error_fmt("'deref': value is not an atom '%s'", pr_str(val, UNREADABLY)); + } + + return val->value.mal_atom; +} + +MalType* mal_reset_bang(list args) { + + if (!args || args->next->next) { + return make_error_fmt("'reset!': expected exactly two arguments"); + } + + MalType* val = args->data; + + if (!is_atom(val)) { + return make_error_fmt("'reset!': value is not an atom '%s'", pr_str(val, UNREADABLY)); + } + + val->value.mal_atom = args->next->data; + return args->next->data; +} + +MalType* mal_swap_bang(list args) { + + MalType* val = args->data; + + if (!is_atom(val)) { + return make_error_fmt("'swap!': first argument is not an atom '%s'", pr_str(val, UNREADABLY)); + } + + MalType* fn = args->next->data; + + if (!is_callable(fn)) { + return make_error_fmt("'swap!': second argument is not callable '%s'", pr_str(fn, UNREADABLY)); + } + + list fn_args = args->next->next; + fn_args = list_push(fn_args, val->value.mal_atom); + + MalType* result = apply(fn, fn_args); + + if (is_error(result)) { + return result; + } + else { + val->value.mal_atom = result; + return result; + } +} + +MalType* mal_throw(list args) { + + if (!args || args->next) { + return make_error_fmt("'throw': expected exactly one argument"); + } + + MalType* val = args->data; + + /* re-throw an existing exception */ + if (is_error(val)) { + return val; + } + /* create a new exception */ + else { + return wrap_error(val); + } +} + +MalType* mal_apply(list args) { + + if (!args || !args->next) { + return make_error("'apply': expected at least two arguments"); + } + + MalType* func = args->data; + + if (!is_callable(func)) { + return make_error("'apply': first argument must be callable"); + } + + /* assemble loose arguments */ + args = args->next; + list lst = NULL; + while(args->next) { + lst = list_push(lst, args->data); + args = args->next; + } + + MalType* final = args->data; + + if (is_sequential(final)) { + lst = list_concatenate(list_reverse(lst), final->value.mal_list); + } + else { + lst = list_push(lst, final); + lst = list_reverse(lst); + } + + return apply(func, lst); +} + +MalType* mal_map(list args) { + + if (!args || !args->next || args->next->next) { + return make_error("'map': expected two arguments"); + } + + MalType* func = args->data; + + if (!is_callable(func)) { + return make_error("'map': first argument must be a function"); + } + + MalType* arg = args->next->data; + + if (!is_sequential(arg)) { + return make_error("'map': second argument must be a list or vector"); + } + + list arg_list = arg->value.mal_list; + list result_list = NULL; + + while(arg_list) { + + MalType* result = apply(func, list_make(arg_list->data)); + + /* early return if error */ + if (is_error(result)) { + return result; + } + else { + result_list = list_push(result_list, result); + } + arg_list = arg_list->next; + } + return make_list(list_reverse(result_list)); +} + +MalType* mal_nil_questionmark(list args) { + + if (!args || args->next) { + return make_error("'nil?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_nil(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_true_questionmark(list args) { + + if (!args || args->next) { + return make_error("'true?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_true(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_false_questionmark(list args) { + + if (!args || args->next) { + return make_error("'false?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_false(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_symbol_questionmark(list args) { + + if (!args || args->next) { + return make_error("'symbol?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_symbol(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_symbol(list args) { + + if (!args || args->next) { + return make_error("'symbol': expected a single argument"); + } + + MalType* val = args->data; + + if (!is_string(val)) { + return make_error("'symbol': expected a string argument"); + } + else { + return make_symbol(val->value.mal_string); + } +} + +MalType* mal_keyword(list args) { + + if (!args || args->next) { + return make_error("'keyword': expected a single argument"); + } + + MalType* val = args->data; + + if (!is_string(val) && !is_keyword(val)) { + return make_error("'keyword': expected a string argument"); + } + else { + return make_keyword(val->value.mal_string); + } +} + +MalType* mal_keyword_questionmark(list args) { + + if (!args || args->next) { + return make_error("'keyword?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_keyword(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_vec(list args) { + + /* Accepts a single argument */ + + if (!args || args->next) { + return make_error("'vec': expected a single argument"); + } + + MalType* val = args->data; + + if (!is_vector(val) && !is_list(val) && !is_hashmap(val)) { + return make_error("'vec': expected a vector, list or hashmap"); + } + + MalType* new_val = copy_type(val); + new_val->type = MALTYPE_VECTOR; + + return new_val; +} + +MalType* mal_vector(list args) { + /* Accepts any number and type of arguments */ + return make_vector(args); +} + +MalType* mal_vector_questionmark(list args) { + + if (!args || args->next) { + return make_error("'vector?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_vector(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_sequential_questionmark(list args) { + + if (!args || args->next) { + return make_error("'sequential?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_sequential(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_hash_map(list args) { + + if (args && list_count(args) % 2 == 1) { + return make_error("'hashmap': odd number of arguments, expected key/value pairs"); + } + + list args_iterator = args; + while (args_iterator) { + + MalType* val = args_iterator->data; + + if (!is_keyword(val) && !is_string(val) && !is_symbol(val)) { + return make_error("'hashmap': keys must be keywords, symbols or strings"); + } + args_iterator = args_iterator->next; + args_iterator = args_iterator->next; + } + + return make_hashmap(args); +} + +MalType* mal_map_questionmark(list args) { + + if (!args || args->next) { + return make_error("'map?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_hashmap(val)) { + return make_true(); + } + else { + return make_false(); + } +} + + +MalType* mal_get(list args) { + /* TODO: implement a proper hashmap */ + + if (!args || args->next->next) { + return make_error("'get': expected exactly two arguments"); + } + + MalType* map = args->data; + + if (!is_hashmap(map) && !is_nil(map)) { + return make_error("'get': expected a map for the first argument"); + } + + MalType* result = hashmap_getf(map->value.mal_list, get_fn(args->next->data), get_fn); + + if (!result) { + return make_nil(); + } + + return result; +} + +MalType* mal_contains_questionmark(list args) { + + if (!args || args->next->next) { + return make_error("'contains?': expected exactly two arguments"); + } + + MalType* map = args->data; + + if (!is_hashmap(map)) { + return make_error("'contains?': expected a map for the first argument"); + } + + MalType* result = hashmap_getf(map->value.mal_list, get_fn(args->next->data), get_fn); + + if (!result) { + return make_false(); + } + else { + return make_true(); + } +} + +MalType* mal_assoc(list args) { + + if (!args || !args->next || !args->next->next) { + return make_error("'assoc': expected at least three arguments"); + } + + MalType* map = args->data; + + if (!is_hashmap(map)) { + return make_error("'assoc': expected a map for the first argument"); + } + + if (list_count(args->next)%2 != 0) { + return make_error("'assoc': expected even number of key/value pairs"); + } + + + list new_lst = list_reverse(list_copy(map->value.mal_list)); + args = args->next; + + while (args) { + + /* try to update copy in-place */ + hashmap result = hashmap_updatef(new_lst, get_fn(args->data), args->next->data, get_fn); + + if (result) { + new_lst = result; + } + /* add a new key/value pair */ + else { + new_lst = list_push(new_lst,args->next->data); + new_lst = list_push(new_lst,args->data); + } + args = args->next->next; + } + return make_hashmap(new_lst); +} + +MalType* mal_dissoc(list args) { + + if (!args || !args->next) { + return make_error("'dissoc': expected at least two arguments"); + } + + MalType* map = args->data; + + if (!is_hashmap(map)) { + return make_error("'dissoc': expected a map for the first argument"); + } + + list source_list = map->value.mal_list; + list new_list = NULL; + args = args->next; + + while(source_list) { + + list dis_args = args; + long dis = 0; + + + while(dis_args) { + + list tmp = NULL; + tmp = list_push(tmp, source_list->data); + tmp = list_push(tmp, dis_args->data); + MalType* cmp = mal_equals(tmp); + + if (is_true(cmp)) { + dis = 1; + break; + } + dis_args = dis_args->next; + } + + if (!dis) { + new_list = list_push(new_list, source_list->data); + new_list = list_push(new_list, source_list->next->data); + } + source_list = source_list->next->next; + } + + return make_hashmap(list_reverse(new_list)); +} + + +MalType* mal_keys(list args) { + + if (!args || args->next) { + return make_error("'keys': expected exactly one argument"); + } + + MalType* map = args->data; + + if (!is_hashmap(map)) { + return make_error("'keys': expected a map"); + } + + list lst = map->value.mal_list; + if (!lst) { + return make_list(NULL); + } + + list result = list_make(lst->data); + while(lst->next->next) { + + lst = lst->next->next; + result = list_push(result, lst->data); + } + return make_list(result); +} + +MalType* mal_vals(list args) { + + if (!args || args->next) { + return make_error("'vals': expected exactly one argument"); + } + + MalType* map = args->data; + + if (!is_hashmap(map)) { + return make_error("'vals': expected a map"); + } + + list lst = map->value.mal_list; + if (!lst) { + return make_list(NULL); + } + + lst = lst->next; + list result = list_make(lst->data); + while(lst->next) { + + lst = lst->next->next; + result = list_push(result, lst->data); + } + return make_list(result); +} + +MalType* mal_string_questionmark(list args) { + + if (!args || args->next) { + return make_error("'string?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_string(val)) { + return make_true(); + } + else { + return make_false(); + } +} + + +MalType* mal_number_questionmark(list args) { + + if (!args || args->next) { + return make_error("'number?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_number(val)) { + return make_true(); + } + else { + return make_false(); + } +} + + +MalType* mal_fn_questionmark(list args) { + + if (!args || args->next) { + return make_error("'fn?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_callable(val) && !is_macro(val)) { + return make_true(); + } + else { + return make_false(); + } +} + +MalType* mal_macro_questionmark(list args) { + + if (!args || args->next) { + return make_error("'macro?': expected a single argument"); + } + + MalType* val = args->data; + + if (is_macro(val)) { + return make_true(); + } + else { + return make_false(); + } +} + + +MalType* mal_time_ms(list args) { + + struct timeval tv; + gettimeofday(&tv, NULL); + long ms = tv.tv_sec * 1000 + tv.tv_usec/1000.0 + 0.5; + + return make_float(ms); +} + + +MalType* mal_conj(list args) { + + if (!args || !args->next) { + return make_error("'conj': Expected at least two arguments"); + } + + MalType* lst = args->data; + + if (!is_sequential(lst)) { + return make_error_fmt("'conj': first argument is not a list or vector: '%s'\n", \ + pr_str(lst, UNREADABLY)); + } + + list rest = args->next; + + if (is_list(lst)) { + + list new_lst = list_reverse(list_copy(lst->value.mal_list)); + + while(rest) { + new_lst = list_push(new_lst, rest->data); + rest = rest->next; + } + return make_list(new_lst); + } + else /* is_vector(lst) */ { + + list new_lst = list_copy(lst->value.mal_list); + + while(rest) { + new_lst = list_push(new_lst, rest->data); + rest = rest->next; + } + return make_vector(list_reverse(new_lst)); + } +} + +MalType* mal_seq(list args) { + + if (!args || args->next) { + return make_error("'seq': expected exactly one argument"); + } + + MalType* val = args->data; + + if (is_sequential(val)) { + + /* empy list or vector */ + if (!val->value.mal_list) { + return make_nil(); + } + else { + return make_list(val->value.mal_list); + } + } + else if (is_string(val)) { + + /* empty string */ + if (*(val->value.mal_string) == '\0') { + return make_nil(); + } + else { + + char* ch = val->value.mal_string; + list lst = NULL; + + while(*ch != '\0') { + char* new_ch = GC_MALLOC(sizeof(*new_ch)); + strncpy(new_ch, ch, 1); + + lst = list_push(lst, make_string(new_ch)); + ch++; + } + return make_list(list_reverse(lst)); + } + } + else if (is_nil(val)) { + return make_nil(); + } + else { + return make_error("'seq': expected a list, vector or string"); + } +} + +MalType* mal_meta(list args) { + + if (!args || args->next) { + return make_error("'meta': expected exactly one argument"); + } + + MalType* val = args->data; + + if (!is_sequential(val) && !is_hashmap(val) && !is_callable(val)) { + return make_error("'meta': metadata not supported for data type"); + } + + if (!val->metadata) { + return make_nil(); + } else { + return val->metadata; + } +} + +MalType* mal_with_meta(list args) { + + if (!args || !args->next || args->next->next) { + return make_error("'with-meta': expected exactly two arguments"); + } + + MalType* val = args->data; + + if (!is_sequential(val) && !is_hashmap(val) && !is_callable(val)) { + return make_error("'with-meta': metadata not supported for data type"); + } + + MalType* metadata = args->next->data; + + MalType* new_val = copy_type(val); + new_val->metadata = metadata; + + return new_val; +} + + +/* helper functions */ + +MalType* as_str(list args, int readably, char* separator) { + + long buffer_length = STRING_BUFFER_SIZE; + long separator_length = strlen(separator); + char* buffer = GC_MALLOC(sizeof(*buffer) * STRING_BUFFER_SIZE); + long char_count = 0; + + while(args) { + + MalType* arg = args->data; + char* str = pr_str(arg, readably); + int len = strlen(str); + + char_count += len; + char_count += separator_length; + if (char_count >= buffer_length) { + buffer = GC_REALLOC(buffer, sizeof(*buffer) * char_count + 1); + } + + strncat(buffer, str, char_count); + args = args->next; + + if (args) { + strcat(buffer, separator); + } + } + return make_string(buffer); +} + +MalType* print(list args, int readably, char* separator) { + + while(args) { + + printf("%s", pr_str(args->data, readably)); + args = args->next; + + if (args) { + printf("%s", separator); + } + } + printf("\n"); + + return make_nil(); +} + +MalType* equal_lists(MalType* list1, MalType* list2) { + + list first = list1->value.mal_list; + list second = list2->value.mal_list; + + if (list_count(first) != list_count(second)) { + return make_false(); + } + else { + + while(first && second) { + + list args = NULL; + args = list_push(args, second->data); + args = list_push(args, first->data); + + MalType* cmp = mal_equals(args); + + if (is_false(cmp)) { + return make_false(); + break; + } + first = first->next; + second = second->next; + } + return make_true(); + } +} + +MalType* equal_hashmaps(MalType* map1, MalType* map2) { + + list first = map1->value.mal_list; + list second = map2->value.mal_list; + + if (!first && !second) { + return make_true(); + } + + if (list_count(first) != list_count(second)) { + return make_false(); + } + + while (first) { + + MalType* key1 = first->data; + MalType* val1 = first->next->data; + MalType* val2 = hashmap_getf(second, get_fn(key1), get_fn); + + if (!val2) { + return make_false(); + } + + list args = NULL; + args = list_push(args, val1); + args = list_push(args, val2); + + MalType* cmp = mal_equals(args); + + if (is_false(cmp)) { + return make_false(); + break; + } + first = first->next->next; + } + return make_true(); +} + +/* helper function for get */ +char* get_fn(gptr data) { + + MalType* val = data; + + switch (val->type) { + + case MALTYPE_STRING: + + return (val->value.mal_string); + break; + + case MALTYPE_SYMBOL: + + return (val->value.mal_symbol); + break; + + case MALTYPE_KEYWORD: + + return (val->value.mal_keyword); + break; + + default: + return NULL; + } +} + +#ifdef WITH_FFI +MalType* mal_dot(list args) { + + /* (. "lib" "return type" "function" "arg1 type" "arg 1" ...) */ + + if (!args || !args->next || !args->next->next) { + return make_error("'.': expected at least three arguments"); + } + + MalType* lib_name = (MalType*)args->data; + + if (!is_string(lib_name) && !is_nil(lib_name)) { + return make_error("'.': expected library name or nil for first argument"); + } + + MalType* return_type = (MalType*)args->next->data; + + if (!is_string(return_type)) { + return make_error("'.': expected string (return type) for second argument"); + } + + MalType* fn_name = (MalType*)args->next->next->data; + + if (!is_string(fn_name)) { + return make_error("'.': expected string (function name) for third argument"); + } + + int args_count = list_count(args) - 3; + + if (args_count % 2 == 1) { + return make_error("'.': expected even number of argument types and values"); + } + + list arg_types_list = NULL; + list arg_vals_list = NULL; + + args = args->next->next->next; + while(args) { + + MalType* val_type = (MalType*)args->data; + MalType* val = (MalType*)args->next->data; + + if (!is_string(val_type)) { + return make_error_fmt("'.': expected strings for argument types: '%s'", pr_str(val_type, UNREADABLY)); + } + + arg_types_list = list_push(arg_types_list, val_type); + arg_vals_list = list_push(arg_vals_list, val); + + args = args->next->next; + } + + arg_types_list = list_reverse(arg_types_list); + arg_vals_list = list_reverse(arg_vals_list); + + /* open a shared library dynamically and get hold of a function */ + gptr lib_handle; + if (!is_nil(lib_name)) { + lib_handle = dlopen(lib_name->value.mal_string, RTLD_LAZY); + } else { + lib_handle = dlopen(NULL, RTLD_LAZY); + } + + if (!lib_handle) { + return make_error_fmt("'ffi`' reports: %s", dlerror()); + } + + gptr fn = dlsym(lib_handle, fn_name->value.mal_string); + + char* error; + if ((error = dlerror()) != NULL) { + return make_error_fmt("'ffi' dlsym could not get handle to function '%s': %s", fn_name->value.mal_string, error); + } + + /* use libffi to call function */ + + ffi_cif cif; + ffi_type* ret_type; + ffi_type* arg_types[20]; + void* arg_vals[20]; + ffi_status status; + ffi_type* ffi_get_type(char *type, MalType* err); + + MalType* mal_err = make_nil(); + + /* set return type */ + MalType* make_type(char *type); + MalType* retval = make_type(return_type->value.mal_string); + + ret_type = ffi_get_type(return_type->value.mal_string, mal_err); + if (is_error(mal_err)) { return mal_err; } + + int arg_count = list_count(arg_types_list); + + /* Set the argument types and values */ + for (int i = 0; i < arg_count; i++) { + + MalType* val_type = (MalType*)arg_types_list->data; + arg_types[i] = ffi_get_type(val_type->value.mal_string, mal_err); + if (is_error(mal_err)) { return mal_err; } + + MalType* val = (MalType*)arg_vals_list->data; + arg_vals[i] = &(val->value); + + arg_types_list = arg_types_list->next; + arg_vals_list = arg_vals_list->next; + } + + /* perform the call */ + status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, arg_count, ret_type, arg_types); + + if (status != FFI_OK) { + return make_error_fmt("'ffi' call to ffi_prep_cif failed with code: %d\n", status); + } + + ffi_call(&cif, FFI_FN(fn), &retval->value, arg_vals); + + /* close the library */ + dlclose(lib_handle); + + if (ret_type == &ffi_type_void) { + return make_nil(); + } else { + return retval; + } +} + +/* helper function for ffi */ +ffi_type* ffi_get_type(char *type, MalType* err) { + + if ((strcmp("void", type) == 0)) { + + return &ffi_type_void; + } + else if ((strcmp("string", type) == 0) || + (strcmp("char*", type) == 0) || + (strcmp("char *", type) == 0)) { + + return &ffi_type_pointer; + } + else if ((strcmp("integer", type) == 0) || + (strcmp("int64", type) == 0)) { + + return &ffi_type_sint64; + } + else if ((strcmp("int32", type) == 0)) { + + return &ffi_type_sint32; + } + else if (strcmp("double", type) == 0) { + + return &ffi_type_double; + } + else if (strcmp("float", type) == 0) { + return &ffi_type_float; + } + else { + err = make_error_fmt("'ffi' type not recognised '%'", type); + return NULL; + } +} + +/* helper function for ffi */ +MalType* make_type(char *type) { + + if ((strcmp("void", type) == 0)) { + + return make_nil(); + } + else if ((strcmp("string", type) == 0) || + (strcmp("char*", type) == 0) || + (strcmp("char *", type) == 0)) { + + return make_string(""); + } + else if ((strcmp("integer", type) == 0) || + (strcmp("int64", type) == 0)) { + + return make_integer(0); + } + else if ((strcmp("int32", type) == 0)) { + return make_integer(0); + } + else if (strcmp("double", type) == 0) { + + return make_float(0); + } + else if (strcmp("float", type) == 0) { + + return make_float(0); + } + else { + return make_error_fmt("'ffi' type not supported '%s'", type); + } +} +#endif diff --git a/impls/c.2/core.h b/impls/c.2/core.h index 89ab88ea3b..a5b5eeaa94 100644 --- a/impls/c.2/core.h +++ b/impls/c.2/core.h @@ -1,22 +1,22 @@ -#ifndef _MAL_CORE_H -#define _MAL_CORE_H - -#include "libs/hashmap/hashmap.h" -#include "types.h" - -typedef struct ns_s ns; - -struct ns_s { - - hashmap mappings; - -}; - -ns* ns_make_core(); -MalType* as_str(list args, int readably, char* separator); -MalType* print(list args, int readably, char* separator); -char* get_fn(gptr data); -MalType* equal_lists(MalType* lst1, MalType* lst2); -MalType* equal_hashmaps(MalType* map1, MalType* map2); - -#endif +#ifndef _MAL_CORE_H +#define _MAL_CORE_H + +#include "libs/hashmap/hashmap.h" +#include "types.h" + +typedef struct ns_s ns; + +struct ns_s { + + hashmap mappings; + +}; + +ns* ns_make_core(); +MalType* as_str(list args, int readably, char* separator); +MalType* print(list args, int readably, char* separator); +char* get_fn(gptr data); +MalType* equal_lists(MalType* lst1, MalType* lst2); +MalType* equal_hashmaps(MalType* map1, MalType* map2); + +#endif diff --git a/impls/c.2/env.c b/impls/c.2/env.c index 458de15215..ccd69b4655 100644 --- a/impls/c.2/env.c +++ b/impls/c.2/env.c @@ -1,67 +1,67 @@ -#include -#include - -#include "libs/hashmap/hashmap.h" -#include "types.h" -#include "env.h" -#include "reader.h" - -/* Note: caller must make sure enough exprs to match symbols */ -Env* env_make(Env* outer, list symbol_list, list exprs_list, MalType* more_symbol) { - - Env* env = GC_MALLOC(sizeof(*env)); - env->outer = outer; - env->data = NULL; - - while (symbol_list) { - - env = env_set(env, symbol_list->data, exprs_list->data); - - symbol_list = symbol_list->next; - exprs_list = exprs_list->next; - } - - /* set the 'more' symbol if there is one */ - if (more_symbol) { - env = env_set(env, more_symbol, make_list(exprs_list)); - } - return env; -} - -Env* env_set(Env* current, MalType* symbol, MalType* value) { - - current->data = hashmap_put(current->data, symbol->value.mal_symbol, value); - return current; -} - -Env* env_find(Env* current, MalType* symbol) { - - MalType* val = hashmap_get(current->data, symbol->value.mal_symbol); - - if (val) { - return current; - } - else if (current->outer) { - return env_find(current->outer, symbol); - } - else { - return NULL; /* not found */ - } -} - -MalType* env_get(Env* current, MalType* symbol) { - - Env* env = env_find(current, symbol); - - if (env) { - return hashmap_get(env->data, symbol->value.mal_symbol); - } - else { - return make_error_fmt("'%s' not found", symbol->value.mal_symbol); - } -} - -Env* env_set_C_fn(Env* current, char* symbol_name, MalType*(*fn)(list)) { - - return env_set(current, make_symbol(symbol_name), make_function(fn)); -} +#include +#include + +#include "libs/hashmap/hashmap.h" +#include "types.h" +#include "env.h" +#include "reader.h" + +/* Note: caller must make sure enough exprs to match symbols */ +Env* env_make(Env* outer, list symbol_list, list exprs_list, MalType* more_symbol) { + + Env* env = GC_MALLOC(sizeof(*env)); + env->outer = outer; + env->data = NULL; + + while (symbol_list) { + + env = env_set(env, symbol_list->data, exprs_list->data); + + symbol_list = symbol_list->next; + exprs_list = exprs_list->next; + } + + /* set the 'more' symbol if there is one */ + if (more_symbol) { + env = env_set(env, more_symbol, make_list(exprs_list)); + } + return env; +} + +Env* env_set(Env* current, MalType* symbol, MalType* value) { + + current->data = hashmap_put(current->data, symbol->value.mal_symbol, value); + return current; +} + +Env* env_find(Env* current, MalType* symbol) { + + MalType* val = hashmap_get(current->data, symbol->value.mal_symbol); + + if (val) { + return current; + } + else if (current->outer) { + return env_find(current->outer, symbol); + } + else { + return NULL; /* not found */ + } +} + +MalType* env_get(Env* current, MalType* symbol) { + + Env* env = env_find(current, symbol); + + if (env) { + return hashmap_get(env->data, symbol->value.mal_symbol); + } + else { + return make_error_fmt("'%s' not found", symbol->value.mal_symbol); + } +} + +Env* env_set_C_fn(Env* current, char* symbol_name, MalType*(*fn)(list)) { + + return env_set(current, make_symbol(symbol_name), make_function(fn)); +} diff --git a/impls/c.2/env.h b/impls/c.2/env.h index 825249dc94..07bc045951 100644 --- a/impls/c.2/env.h +++ b/impls/c.2/env.h @@ -1,23 +1,23 @@ -#ifndef _MAL_ENV_H -#define _MAL_ENV_H - -#include "libs/linked_list/linked_list.h" -#include "libs/hashmap/hashmap.h" -#include "types.h" - -typedef struct Env_s Env; - -struct Env_s { - - struct Env_s* outer; - hashmap data; - -}; - -Env* env_make(Env* outer, list binds, list exprs, MalType* variadic_symbol); -Env* env_set(Env* current, MalType* symbol, MalType* value); -Env* env_set_C_fn(Env* current, char* symbol_name, MalType*(*fn)(list)); -MalType* env_get(Env* current, MalType* symbol); -Env* env_find(Env* current, MalType* symbol); - -#endif +#ifndef _MAL_ENV_H +#define _MAL_ENV_H + +#include "libs/linked_list/linked_list.h" +#include "libs/hashmap/hashmap.h" +#include "types.h" + +typedef struct Env_s Env; + +struct Env_s { + + struct Env_s* outer; + hashmap data; + +}; + +Env* env_make(Env* outer, list binds, list exprs, MalType* variadic_symbol); +Env* env_set(Env* current, MalType* symbol, MalType* value); +Env* env_set_C_fn(Env* current, char* symbol_name, MalType*(*fn)(list)); +MalType* env_get(Env* current, MalType* symbol); +Env* env_find(Env* current, MalType* symbol); + +#endif diff --git a/impls/c.2/libs/hashmap/hashmap.c b/impls/c.2/libs/hashmap/hashmap.c index 9b29198cd0..b3b8afacc5 100644 --- a/impls/c.2/libs/hashmap/hashmap.c +++ b/impls/c.2/libs/hashmap/hashmap.c @@ -1,93 +1,93 @@ -#include -#include -#include - -#include "hashmap.h" - -hashmap hashmap_make(char* keystring, gptr data_ptr) { - - list map = list_make(data_ptr); - map = list_push(map, keystring); - - return map; -} - -hashmap hashmap_put(hashmap map, char* keystring, gptr data_ptr) { - - map = list_push(map, data_ptr); - map = list_push(map, keystring); - - return map; -} - -gptr hashmap_get(hashmap map, char* keystring) { - - /* handle empty case */ - if (!map) { - return NULL; - } - - list lst = map; - - while(lst) { - - if (strcmp(keystring, (char*)lst->data) == 0) { - return (lst->next)->data; /* return next item in list which is the value */ - } - else { - lst = (lst->next)->next; /* skip the next item in the list to get to the next key */ - } - } - return NULL; /* not found */ -} - - -gptr hashmap_getf(hashmap map, char* keystring, char*(*fn)(gptr)) { - - /* handle empty case */ - if (!map) { - return NULL; - } - - list lst = map; - - while(lst) { - - /* apply fn to the data to get a string */ - char* item = fn(lst->data); - - if (strcmp(keystring, item) == 0) { - return (lst->next)->data; /* return next item in list which is the value */ - } - else { - lst = (lst->next)->next; /* skip the next item in the list to get to the next key */ - } - } - return NULL; /* not found */ -} - -hashmap hashmap_updatef(hashmap map, char* keystring, gptr value, char*(*fn)(gptr)) { - - /* handle empty case */ - if (!map) { - return NULL; - } - - list lst = map; - - while(lst) { - - /* apply fn to the data to get a string */ - char* item = fn(lst->data); - - if (strcmp(keystring, item) == 0) { - (lst->next)->data = value; /* update the next item in list which is the value */ - return map; /* update made */ - } - else { - lst = (lst->next)->next; /* skip the next item in the list to get to the next key */ - } - } - - return NULL; /* no update */ -} +#include +#include +#include + +#include "hashmap.h" + +hashmap hashmap_make(char* keystring, gptr data_ptr) { + + list map = list_make(data_ptr); + map = list_push(map, keystring); + + return map; +} + +hashmap hashmap_put(hashmap map, char* keystring, gptr data_ptr) { + + map = list_push(map, data_ptr); + map = list_push(map, keystring); + + return map; +} + +gptr hashmap_get(hashmap map, char* keystring) { + + /* handle empty case */ + if (!map) { + return NULL; + } + + list lst = map; + + while(lst) { + + if (strcmp(keystring, (char*)lst->data) == 0) { + return (lst->next)->data; /* return next item in list which is the value */ + } + else { + lst = (lst->next)->next; /* skip the next item in the list to get to the next key */ + } + } + return NULL; /* not found */ +} + + +gptr hashmap_getf(hashmap map, char* keystring, char*(*fn)(gptr)) { + + /* handle empty case */ + if (!map) { + return NULL; + } + + list lst = map; + + while(lst) { + + /* apply fn to the data to get a string */ + char* item = fn(lst->data); + + if (strcmp(keystring, item) == 0) { + return (lst->next)->data; /* return next item in list which is the value */ + } + else { + lst = (lst->next)->next; /* skip the next item in the list to get to the next key */ + } + } + return NULL; /* not found */ +} + +hashmap hashmap_updatef(hashmap map, char* keystring, gptr value, char*(*fn)(gptr)) { + + /* handle empty case */ + if (!map) { + return NULL; + } + + list lst = map; + + while(lst) { + + /* apply fn to the data to get a string */ + char* item = fn(lst->data); + + if (strcmp(keystring, item) == 0) { + (lst->next)->data = value; /* update the next item in list which is the value */ + return map; /* update made */ + } + else { + lst = (lst->next)->next; /* skip the next item in the list to get to the next key */ + } + } + + return NULL; /* no update */ +} diff --git a/impls/c.2/libs/hashmap/hashmap.h b/impls/c.2/libs/hashmap/hashmap.h index ae848cb05a..fa698ac480 100644 --- a/impls/c.2/libs/hashmap/hashmap.h +++ b/impls/c.2/libs/hashmap/hashmap.h @@ -1,15 +1,15 @@ -#ifndef _MAL_HASHMAP_H -#define _MAL_HASHMAP_H - -#include "../linked_list/linked_list.h" - -/* a hashmap is just a list with alternating key/value pairs */ -typedef list hashmap; - -hashmap hashmap_make(char* keystring, gptr data_ptr); -hashmap hashmap_put(hashmap map, char* keystring, gptr data_ptr); -gptr hashmap_get(hashmap map, char* keystring); -gptr hashmap_getf(hashmap map, char* keystring, char*(*fn)(gptr)); -hashmap hashmap_updatef(hashmap map, char* keystring, gptr value, char*(*fn)(gptr)); - -#endif +#ifndef _MAL_HASHMAP_H +#define _MAL_HASHMAP_H + +#include "../linked_list/linked_list.h" + +/* a hashmap is just a list with alternating key/value pairs */ +typedef list hashmap; + +hashmap hashmap_make(char* keystring, gptr data_ptr); +hashmap hashmap_put(hashmap map, char* keystring, gptr data_ptr); +gptr hashmap_get(hashmap map, char* keystring); +gptr hashmap_getf(hashmap map, char* keystring, char*(*fn)(gptr)); +hashmap hashmap_updatef(hashmap map, char* keystring, gptr value, char*(*fn)(gptr)); + +#endif diff --git a/impls/c.2/libs/linked_list/linked_list.c b/impls/c.2/libs/linked_list/linked_list.c index 4c9ef709c6..f477f163e8 100644 --- a/impls/c.2/libs/linked_list/linked_list.c +++ b/impls/c.2/libs/linked_list/linked_list.c @@ -1,171 +1,171 @@ -#include -#include -#include -#include "linked_list.h" - -list list_make(gptr data_ptr) { - - return list_push(NULL, data_ptr); -} - -list list_push(list lst, gptr data_ptr) { - - pair* new_head = GC_malloc(sizeof(pair)); - new_head->data = data_ptr; - new_head->next = lst; - - return new_head; -} - -gptr list_peek(list lst) { - - return (lst ? lst->data : NULL); -} - -list list_pop(list lst) { - return (lst ? lst->next : NULL); -} - -long list_count(list lst) { - - /* handle empty case */ - if (!lst) { - return 0; - } - - long counter = 1; - - while(lst->next) { - - counter++; - lst = lst->next; - } - - return counter; -} - -list list_reverse(list lst) { - - /* list is not empty and has more than one element */ - if (lst && lst->next) { - - pair *prev = NULL, *next = NULL, *current = lst; - - while (current) { - - /* stash current value of next pointer --> */ - next = current->next; - - /* reverse the next pointer on current pair <-- */ - current->next = prev; - - /* move on to next pair and repeat --> */ - prev = current; - current = next; - - } - - lst = prev; /* head of list is in prev when current = NULL */ - } - - return lst; -} - -list list_concatenate(list lst1, list lst2) { - - list new_lst = NULL; - list iterator = NULL; - - while (lst2) { - - gptr val = lst2->data; - new_lst = list_push(new_lst, val); - lst2 = lst2->next; - } - new_lst = list_reverse(new_lst); - - lst1 = list_reverse(lst1); - - iterator = lst1; - while (iterator) { - - gptr val = iterator->data; - new_lst = list_push(new_lst, val); - iterator = iterator->next; - } - - lst1 = list_reverse(lst1); - return new_lst; -} - -gptr list_nth(list lst, int n) { - - int idx = 0; - while (lst) { - - if (n == idx) { - return lst->data; - } - idx++; - lst = lst->next; - } - return NULL; -} - -gptr list_first(list lst) { - - if (lst) { - return lst->data; - } - else { - return NULL; - } -} - -list list_rest(list lst) { - - if (lst) { - return lst->next; - } - else { - return NULL; - } -} - -list list_copy(list lst) { - - if(!lst) { - return NULL; - } - - list new_lst = NULL; - while(lst) { - - new_lst = list_push(new_lst, lst->data); - lst = lst->next; - } - return new_lst; -} - -long list_findf(list lst, char* keystring, char*(*fn)(gptr)) { - - /* handle empty case */ - if (!lst) { - return -1; - } - - list current = lst; - while(current) { - - /* apply fn to the data to get a string */ - char* item = fn(current->data); - - if (strcmp(keystring, item) == 0) { - return (current - lst); /* return the index of the first match */ - } - else { - current = current->next; /* skip the next item in the list to*/ - } - } - return -1; /* not found */ -} +#include +#include +#include +#include "linked_list.h" + +list list_make(gptr data_ptr) { + + return list_push(NULL, data_ptr); +} + +list list_push(list lst, gptr data_ptr) { + + pair* new_head = GC_malloc(sizeof(pair)); + new_head->data = data_ptr; + new_head->next = lst; + + return new_head; +} + +gptr list_peek(list lst) { + + return (lst ? lst->data : NULL); +} + +list list_pop(list lst) { + return (lst ? lst->next : NULL); +} + +long list_count(list lst) { + + /* handle empty case */ + if (!lst) { + return 0; + } + + long counter = 1; + + while(lst->next) { + + counter++; + lst = lst->next; + } + + return counter; +} + +list list_reverse(list lst) { + + /* list is not empty and has more than one element */ + if (lst && lst->next) { + + pair *prev = NULL, *next = NULL, *current = lst; + + while (current) { + + /* stash current value of next pointer --> */ + next = current->next; + + /* reverse the next pointer on current pair <-- */ + current->next = prev; + + /* move on to next pair and repeat --> */ + prev = current; + current = next; + + } + + lst = prev; /* head of list is in prev when current = NULL */ + } + + return lst; +} + +list list_concatenate(list lst1, list lst2) { + + list new_lst = NULL; + list iterator = NULL; + + while (lst2) { + + gptr val = lst2->data; + new_lst = list_push(new_lst, val); + lst2 = lst2->next; + } + new_lst = list_reverse(new_lst); + + lst1 = list_reverse(lst1); + + iterator = lst1; + while (iterator) { + + gptr val = iterator->data; + new_lst = list_push(new_lst, val); + iterator = iterator->next; + } + + lst1 = list_reverse(lst1); + return new_lst; +} + +gptr list_nth(list lst, int n) { + + int idx = 0; + while (lst) { + + if (n == idx) { + return lst->data; + } + idx++; + lst = lst->next; + } + return NULL; +} + +gptr list_first(list lst) { + + if (lst) { + return lst->data; + } + else { + return NULL; + } +} + +list list_rest(list lst) { + + if (lst) { + return lst->next; + } + else { + return NULL; + } +} + +list list_copy(list lst) { + + if(!lst) { + return NULL; + } + + list new_lst = NULL; + while(lst) { + + new_lst = list_push(new_lst, lst->data); + lst = lst->next; + } + return new_lst; +} + +long list_findf(list lst, char* keystring, char*(*fn)(gptr)) { + + /* handle empty case */ + if (!lst) { + return -1; + } + + list current = lst; + while(current) { + + /* apply fn to the data to get a string */ + char* item = fn(current->data); + + if (strcmp(keystring, item) == 0) { + return (current - lst); /* return the index of the first match */ + } + else { + current = current->next; /* skip the next item in the list to*/ + } + } + return -1; /* not found */ +} diff --git a/impls/c.2/libs/linked_list/linked_list.h b/impls/c.2/libs/linked_list/linked_list.h index fa25b49eab..57621fe6c9 100644 --- a/impls/c.2/libs/linked_list/linked_list.h +++ b/impls/c.2/libs/linked_list/linked_list.h @@ -1,32 +1,32 @@ -#ifndef _MAL_LINKED_LIST_H -#define _MAL_LINKED_LIST_H - -/* simplify references to void pointers */ -typedef void* gptr; - -/* linked list is constructed of pairs */ -typedef struct pair_s { - - gptr data; - struct pair_s *next; - -} pair; - -/* a list is just a pointer to the pair at the head of the list */ -typedef pair* list; - -/* interface */ -list list_make(gptr data_ptr); -list list_push(list lst, gptr data_ptr); -gptr list_peek(list lst); -gptr list_nth(list lst, int n); -gptr list_first(list lst); -list list_rest(list lst); -list list_pop(list lst); -list list_reverse(list lst); -long list_count(list lst); -list list_concatenate(list lst1, list lst2); -list list_copy(list lst); -long list_findf(list lst, char* keystring, char*(*fn)(gptr)); - -#endif +#ifndef _MAL_LINKED_LIST_H +#define _MAL_LINKED_LIST_H + +/* simplify references to void pointers */ +typedef void* gptr; + +/* linked list is constructed of pairs */ +typedef struct pair_s { + + gptr data; + struct pair_s *next; + +} pair; + +/* a list is just a pointer to the pair at the head of the list */ +typedef pair* list; + +/* interface */ +list list_make(gptr data_ptr); +list list_push(list lst, gptr data_ptr); +gptr list_peek(list lst); +gptr list_nth(list lst, int n); +gptr list_first(list lst); +list list_rest(list lst); +list list_pop(list lst); +list list_reverse(list lst); +long list_count(list lst); +list list_concatenate(list lst1, list lst2); +list list_copy(list lst); +long list_findf(list lst, char* keystring, char*(*fn)(gptr)); + +#endif diff --git a/impls/c.2/printer.c b/impls/c.2/printer.c index d12ec6c436..1801987ffe 100644 --- a/impls/c.2/printer.c +++ b/impls/c.2/printer.c @@ -1,255 +1,255 @@ -#include -#include -#include -#include - -#include "printer.h" - -#define PRINT_NIL "nil" -#define PRINT_TRUE "true" -#define PRINT_FALSE "false" - -#define INTEGER_BUFFER_SIZE 16 -#define SYMBOL_BUFFER_SIZE 32 -#define FUNCTION_BUFFER_SIZE 256 -#define STRING_BUFFER_SIZE 256 -#define LIST_BUFFER_SIZE 1024 - -char* pr_str(MalType* val, int readably) { - - if (!val) { - return ""; - } - - switch(val->type) { - - case MALTYPE_SYMBOL: - - return snprintfbuf(SYMBOL_BUFFER_SIZE, "%s", val->value.mal_symbol); - break; - - case MALTYPE_KEYWORD: - - return snprintfbuf(SYMBOL_BUFFER_SIZE, ":%s", val->value.mal_keyword); - break; - - case MALTYPE_INTEGER: - - return snprintfbuf(SYMBOL_BUFFER_SIZE, "%ld", val->value.mal_integer); - break; - - case MALTYPE_FLOAT: - - return snprintfbuf(SYMBOL_BUFFER_SIZE, "%lf", val->value.mal_float); - break; - - case MALTYPE_STRING: - - if (readably) { - return snprintfbuf(STRING_BUFFER_SIZE, "%s", escape_string(val->value.mal_string)); - } - else { - return snprintfbuf(STRING_BUFFER_SIZE, "%s",val->value.mal_string); - } - break; - - case MALTYPE_TRUE: - - return PRINT_TRUE; - break; - - case MALTYPE_FALSE: - - return PRINT_FALSE; - break; - - case MALTYPE_NIL: - - return PRINT_NIL; - break; - - case MALTYPE_LIST: - - return pr_str_list(val->value.mal_list, readably, "(", ")", " "); - break; - - case MALTYPE_VECTOR: - - return pr_str_list(val->value.mal_list, readably, "[", "]", " "); - break; - - case MALTYPE_HASHMAP: - - return pr_str_list(val->value.mal_list, readably, "{", "}", " "); - break; - - case MALTYPE_FUNCTION: - - return snprintfbuf(FUNCTION_BUFFER_SIZE, "#", val->value.mal_function); - break; - - case MALTYPE_CLOSURE: - { - MalType* definition = (val->value.mal_closure)->definition; - MalType* parameters = (val->value.mal_closure)->parameters; - MalType* more_symbol = (val->value.mal_closure)->more_symbol; - - list lst = parameters->value.mal_list; - - if (more_symbol) { - lst = list_reverse(lst); - lst = list_push(lst, make_symbol(snprintfbuf(STRING_BUFFER_SIZE, "%s%s", "&", more_symbol->value.mal_symbol))); - lst = list_reverse(lst); - } - - if (val->is_macro) { - return snprintfbuf(FUNCTION_BUFFER_SIZE, "#value.mal_atom, readably)); - break; - - case MALTYPE_ERROR: - - return snprintfbuf(STRING_BUFFER_SIZE, "Uncaught error: %s", pr_str(val->value.mal_error, UNREADABLY)); - break; - - default: - /* can't happen unless a new MalType is added */ - return "Printer error: unknown type\n"; - break; - } -} - - -char* pr_str_list(list lst, int readably, char* start_delimiter, char* end_delimiter, char* separator) { - - char* list_buffer = GC_MALLOC(sizeof(*list_buffer) * LIST_BUFFER_SIZE); - long buffer_length = LIST_BUFFER_SIZE; - - /* add the start delimiter */ - list_buffer = strcpy(list_buffer, start_delimiter); - - long len = strlen(start_delimiter); - long count = len; - - while (lst) { - - /* concatenate next element */ - MalType* data = lst->data; - char* str = pr_str(data, readably); - - len = strlen(str); - count += len; - - if (count >= buffer_length) { - buffer_length += (count + 1); - list_buffer = GC_REALLOC(list_buffer, buffer_length); - } - - strncat(list_buffer, str, len); - lst = lst->next; - - if (lst) { - len = strlen(separator); - count += len; - - if (count >= buffer_length) { - buffer_length += (count + 1); - list_buffer = GC_REALLOC(list_buffer, buffer_length); - } - /* add the separator */ - strncat(list_buffer, separator, len); - } - } - - if (count >= buffer_length) { - len = strlen(end_delimiter); - count += len; - - buffer_length += (count + 1); - list_buffer = GC_REALLOC(list_buffer, buffer_length); - } - - /* add the end delimiter */ - strncat(list_buffer, end_delimiter, len); - - return list_buffer; -} - - -char* escape_string(char* str) { - - long buffer_length = 2*(strlen(str) + 1) ; /* allocate a reasonable initial buffer size */ - char* buffer = GC_MALLOC(sizeof(*buffer) * buffer_length); - - strcpy(buffer,"\""); - - char* curr = str; - while(*curr != '\0') { - - switch (*curr) { - - case '"': - strcat(buffer, "\\\""); - break; - - case '\\': - strcat(buffer, "\\\\"); - break; - - case 0x0A: - strcat(buffer, "\\n"); - break; - - default: - strncat(buffer, curr, 1); - } - curr++; - - /* check for overflow and increase buffer size */ - if ((curr - str) >= buffer_length) { - buffer_length *= 2; - buffer = GC_REALLOC(buffer, sizeof(*buffer) * buffer_length); - } - } - - strcat(buffer, "\""); - - /* trim the buffer to the size of the actual escaped string */ - buffer_length = strlen(buffer); - buffer = GC_REALLOC(buffer, sizeof(*buffer) * buffer_length + 1); - - return buffer; -} - -char* snprintfbuf(long initial_size, char* fmt, ...) { - /* this is just a wrapper for the *printf family that ensures the - string is long enough to hold the contents */ - - va_list argptr; - va_start(argptr, fmt); - - char* buffer = GC_MALLOC(sizeof(*buffer) * initial_size); - long n = vsnprintf(buffer, initial_size, fmt, argptr); - va_end(argptr); - - if (n > initial_size) { - va_start(argptr, fmt); - - buffer = GC_REALLOC(buffer, sizeof(*buffer) * n); - vsnprintf(buffer, n, fmt, argptr); - - va_end(argptr); - } - return buffer; -} +#include +#include +#include +#include + +#include "printer.h" + +#define PRINT_NIL "nil" +#define PRINT_TRUE "true" +#define PRINT_FALSE "false" + +#define INTEGER_BUFFER_SIZE 16 +#define SYMBOL_BUFFER_SIZE 32 +#define FUNCTION_BUFFER_SIZE 256 +#define STRING_BUFFER_SIZE 256 +#define LIST_BUFFER_SIZE 1024 + +char* pr_str(MalType* val, int readably) { + + if (!val) { + return ""; + } + + switch(val->type) { + + case MALTYPE_SYMBOL: + + return snprintfbuf(SYMBOL_BUFFER_SIZE, "%s", val->value.mal_symbol); + break; + + case MALTYPE_KEYWORD: + + return snprintfbuf(SYMBOL_BUFFER_SIZE, ":%s", val->value.mal_keyword); + break; + + case MALTYPE_INTEGER: + + return snprintfbuf(SYMBOL_BUFFER_SIZE, "%ld", val->value.mal_integer); + break; + + case MALTYPE_FLOAT: + + return snprintfbuf(SYMBOL_BUFFER_SIZE, "%lf", val->value.mal_float); + break; + + case MALTYPE_STRING: + + if (readably) { + return snprintfbuf(STRING_BUFFER_SIZE, "%s", escape_string(val->value.mal_string)); + } + else { + return snprintfbuf(STRING_BUFFER_SIZE, "%s",val->value.mal_string); + } + break; + + case MALTYPE_TRUE: + + return PRINT_TRUE; + break; + + case MALTYPE_FALSE: + + return PRINT_FALSE; + break; + + case MALTYPE_NIL: + + return PRINT_NIL; + break; + + case MALTYPE_LIST: + + return pr_str_list(val->value.mal_list, readably, "(", ")", " "); + break; + + case MALTYPE_VECTOR: + + return pr_str_list(val->value.mal_list, readably, "[", "]", " "); + break; + + case MALTYPE_HASHMAP: + + return pr_str_list(val->value.mal_list, readably, "{", "}", " "); + break; + + case MALTYPE_FUNCTION: + + return snprintfbuf(FUNCTION_BUFFER_SIZE, "#", val->value.mal_function); + break; + + case MALTYPE_CLOSURE: + { + MalType* definition = (val->value.mal_closure)->definition; + MalType* parameters = (val->value.mal_closure)->parameters; + MalType* more_symbol = (val->value.mal_closure)->more_symbol; + + list lst = parameters->value.mal_list; + + if (more_symbol) { + lst = list_reverse(lst); + lst = list_push(lst, make_symbol(snprintfbuf(STRING_BUFFER_SIZE, "%s%s", "&", more_symbol->value.mal_symbol))); + lst = list_reverse(lst); + } + + if (val->is_macro) { + return snprintfbuf(FUNCTION_BUFFER_SIZE, "#value.mal_atom, readably)); + break; + + case MALTYPE_ERROR: + + return snprintfbuf(STRING_BUFFER_SIZE, "Uncaught error: %s", pr_str(val->value.mal_error, UNREADABLY)); + break; + + default: + /* can't happen unless a new MalType is added */ + return "Printer error: unknown type\n"; + break; + } +} + + +char* pr_str_list(list lst, int readably, char* start_delimiter, char* end_delimiter, char* separator) { + + char* list_buffer = GC_MALLOC(sizeof(*list_buffer) * LIST_BUFFER_SIZE); + long buffer_length = LIST_BUFFER_SIZE; + + /* add the start delimiter */ + list_buffer = strcpy(list_buffer, start_delimiter); + + long len = strlen(start_delimiter); + long count = len; + + while (lst) { + + /* concatenate next element */ + MalType* data = lst->data; + char* str = pr_str(data, readably); + + len = strlen(str); + count += len; + + if (count >= buffer_length) { + buffer_length += (count + 1); + list_buffer = GC_REALLOC(list_buffer, buffer_length); + } + + strncat(list_buffer, str, len); + lst = lst->next; + + if (lst) { + len = strlen(separator); + count += len; + + if (count >= buffer_length) { + buffer_length += (count + 1); + list_buffer = GC_REALLOC(list_buffer, buffer_length); + } + /* add the separator */ + strncat(list_buffer, separator, len); + } + } + + if (count >= buffer_length) { + len = strlen(end_delimiter); + count += len; + + buffer_length += (count + 1); + list_buffer = GC_REALLOC(list_buffer, buffer_length); + } + + /* add the end delimiter */ + strncat(list_buffer, end_delimiter, len); + + return list_buffer; +} + + +char* escape_string(char* str) { + + long buffer_length = 2*(strlen(str) + 1) ; /* allocate a reasonable initial buffer size */ + char* buffer = GC_MALLOC(sizeof(*buffer) * buffer_length); + + strcpy(buffer,"\""); + + char* curr = str; + while(*curr != '\0') { + + switch (*curr) { + + case '"': + strcat(buffer, "\\\""); + break; + + case '\\': + strcat(buffer, "\\\\"); + break; + + case 0x0A: + strcat(buffer, "\\n"); + break; + + default: + strncat(buffer, curr, 1); + } + curr++; + + /* check for overflow and increase buffer size */ + if ((curr - str) >= buffer_length) { + buffer_length *= 2; + buffer = GC_REALLOC(buffer, sizeof(*buffer) * buffer_length); + } + } + + strcat(buffer, "\""); + + /* trim the buffer to the size of the actual escaped string */ + buffer_length = strlen(buffer); + buffer = GC_REALLOC(buffer, sizeof(*buffer) * buffer_length + 1); + + return buffer; +} + +char* snprintfbuf(long initial_size, char* fmt, ...) { + /* this is just a wrapper for the *printf family that ensures the + string is long enough to hold the contents */ + + va_list argptr; + va_start(argptr, fmt); + + char* buffer = GC_MALLOC(sizeof(*buffer) * initial_size); + long n = vsnprintf(buffer, initial_size, fmt, argptr); + va_end(argptr); + + if (n > initial_size) { + va_start(argptr, fmt); + + buffer = GC_REALLOC(buffer, sizeof(*buffer) * n); + vsnprintf(buffer, n, fmt, argptr); + + va_end(argptr); + } + return buffer; +} diff --git a/impls/c.2/printer.h b/impls/c.2/printer.h index 3de3dfdd15..258253182c 100644 --- a/impls/c.2/printer.h +++ b/impls/c.2/printer.h @@ -1,15 +1,15 @@ -#ifndef _PRINTER_H -#define _PRINTER_H - -#include -#include "types.h" - -#define UNREADABLY 0 -#define READABLY 1 - -char* pr_str(MalType* mal_val, int readably); -char* pr_str_list(list lst, int readably, char* start_delimiter, char* end_delimiter, char* separator); -char* escape_string(char* str); -char* snprintfbuf(long initial_size, char* fmt, ...); - -#endif +#ifndef _PRINTER_H +#define _PRINTER_H + +#include +#include "types.h" + +#define UNREADABLY 0 +#define READABLY 1 + +char* pr_str(MalType* mal_val, int readably); +char* pr_str_list(list lst, int readably, char* start_delimiter, char* end_delimiter, char* separator); +char* escape_string(char* str); +char* snprintfbuf(long initial_size, char* fmt, ...); + +#endif diff --git a/impls/c.2/reader.c b/impls/c.2/reader.c index 18f9bf2057..90b97850da 100644 --- a/impls/c.2/reader.c +++ b/impls/c.2/reader.c @@ -1,663 +1,663 @@ -#include -#include -#include -#include -#include - -#include "reader.h" - -#define TOKEN_SPECIAL_CHARACTER 1 -#define TOKEN_STRING 2 -#define TOKEN_INTEGER 3 -#define TOKEN_FLOAT 4 -#define TOKEN_SYMBOL 5 -#define TOKEN_COMMENT 6 -#define TOKEN_KEYWORD 7 -#define TOKEN_TRUE 8 -#define TOKEN_FALSE 9 -#define TOKEN_NIL 10 - -#define SYMBOL_NIL "nil" -#define SYMBOL_TRUE "true" -#define SYMBOL_FALSE "false" -#define SYMBOL_QUOTE "quote" -#define SYMBOL_QUASIQUOTE "quasiquote" -#define SYMBOL_UNQUOTE "unquote" -#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" -#define SYMBOL_DEREF "deref" -#define SYMBOL_WITH_META "with-meta" - -Reader* reader_make(long token_capacity) { - - Reader* reader = GC_MALLOC(sizeof(*reader)); - - reader->max_tokens = token_capacity; - reader->position = 0; - reader->token_count = 0; - reader->token_data = GC_MALLOC(sizeof(Token*) * token_capacity); - reader->error = NULL; - - return reader; -} - -Reader* reader_append(Reader* reader, Token* token) { - - if (reader->token_count < reader->max_tokens) { - - reader->token_data[reader->token_count] = token; - reader->token_count++; - } - else { - /* TODO: expand the storage more intelligently */ - reader->max_tokens *= 2; - reader = GC_REALLOC(reader, sizeof(*reader) * reader->max_tokens); - reader->token_data[reader->token_count] = token; - reader->token_count++; - } - return reader; -} - -Token* reader_peek(const Reader* reader) { - - return (reader->token_data[reader->position]); -} - -Token* reader_next(Reader* reader) { - - Token* tok = reader->token_data[reader->position]; - - if (reader->position == -1) { - return NULL; - } - else if (reader->position < reader->token_count) { - (reader->position)++; - return tok; - } - else { - reader->position = -1; - return tok; - } -} - -void reader_print(Reader* reader) { - /* NOTE: needed for debugging the reader only */ - - Token* tok; - - for (long i = 0; i < reader->token_count; i++) { - - tok = reader_next(reader); - - switch (tok->type) { - case TOKEN_SPECIAL_CHARACTER: - printf("special character: %s", tok->data); - break; - case TOKEN_STRING: - printf("string: %s", tok->data); - break; - case TOKEN_INTEGER: - printf("integer: %s", tok->data); - break; - case TOKEN_FLOAT: - printf("float: %s", tok->data); - break; - case TOKEN_SYMBOL: - printf("symbol: %s", tok->data); - break; - case TOKEN_COMMENT: - printf("comment: \"%s\"", tok->data); - break; - case TOKEN_KEYWORD: - printf("keyword: %s", tok->data); - break; - case TOKEN_TRUE: - printf("true: %s", tok->data); - break; - case TOKEN_FALSE: - printf("false: %s", tok->data); - break; - case TOKEN_NIL: - printf("nil: %s", tok->data); - break; - } - /* print an error for any tokens with an error string */ - tok->error ? printf(" - %s", tok->error) : 0; - } -} - -MalType* read_str(char* token_string) { - - Reader* reader = tokenize(token_string); - - if (reader->error) { - return make_error_fmt("Reader error: %s", reader->error); - } - else if (reader->token_count == 0) { - return make_nil(); - } - else { - return read_form(reader); - } -} - -Reader* tokenize(char* token_string) { - - /* allocate enough space for a Reader */ - /* TODO: over-allocates space */ - Reader* reader = reader_make(strlen(token_string)); - - for (char* next = token_string; *next != '\0';) { - - Token* token = NULL; - - switch (*next) { - /* skip whitespace */ - case ' ': - case ',': - case 0x0A: /* newline */ - next++; - token = NULL; /* no token for whitespace */ - break; - - /* single character token */ - case '[': - case '\\': - case ']': - case '{': - case '}': - case '(': - case ')': - case '\'': - case '@': - case '`': - case '^': - next = read_fixed_length_token(next, &token, 1); - break; - - /* single or double character token */ - case '~': - if ( *(next + 1) == '@' ) { - next = read_fixed_length_token(next, &token, 2); - } - else { - next = read_fixed_length_token(next, &token, 1); - } - break; - - /* read string of characters within double quotes */ - case '"': - next = read_string_token(next, &token); - break; - - /* read a comment - all remaining input until newline */ - case ';': - next = read_comment_token(next, &token); - token = NULL; /* skip token for comments */ - break; - - /* read an integer */ - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - next = read_number_token(next, &token); - // next = read_integer_token(next, &token); - break; - - /* integer may be prefixed with +/- */ - case '+': - case '-': - if (isdigit(next[1])) { - next = read_number_token(next, &token); - // next = read_integer_token(next, &token); - } - else { /* if not digits it is part of a symbol */ - next = read_symbol_token(next, &token); - } - break; - - /* read keyword */ - case ':': - next = read_keyword_token(next, &token); - break; - - /* read anything else as a symbol */ - default: - next = read_symbol_token(next, &token); - break; - } - - if (!token) { - /* if no token was read (whitespace or comments) - continue the loop */ - continue; - } - else { - - if (token->error) { - /* report any errors with an early return */ - reader = reader_append(reader, token); - reader->error = token->error; - return reader; - } - /* otherwise append the token and continue */ - reader = reader_append(reader, token); - } - } - return reader; -} - -char* read_fixed_length_token(char* current, Token** ptoken, int n) { - - *ptoken = token_allocate(current, n, TOKEN_SPECIAL_CHARACTER, NULL); - return (current + n); -} - -char* read_terminated_token (char* current, Token** ptoken, int token_type) { - - static char* const terminating_characters = " ,[](){};\n"; - - /* search for first terminating character */ - char* end = strpbrk(current, terminating_characters); - - /* if terminating character is not found it implies the end of the string */ - long token_length = !end ? strlen(current) : (end - current); - - /* next token starts with the terminating character */ - *ptoken = token_allocate(current, token_length, token_type, NULL); - return (current + token_length); -} - -char* read_symbol_token (char* current, Token** ptoken) { - - char* next = read_terminated_token(current, ptoken, TOKEN_SYMBOL); - - /* check for reserved symbols */ - if (strcmp((*ptoken)->data, SYMBOL_NIL) == 0) { - (*ptoken)->type = TOKEN_NIL; - } - else if (strcmp((*ptoken)->data, SYMBOL_TRUE) == 0) { - (*ptoken)->type = TOKEN_TRUE; - } - else if (strcmp((*ptoken)->data, SYMBOL_FALSE) == 0) { - (*ptoken)->type = TOKEN_FALSE; - } - - /* TODO: check for invalid characters */ - return next; -} - - -char* read_keyword_token (char* current, Token** ptoken) { - - /* TODO: check for invalid characters */ - return read_terminated_token(current + 1, ptoken, TOKEN_KEYWORD); -} - -char* read_number_token(char* current, Token** ptoken) { - - int has_decimal_point = 0; - - char* next = read_terminated_token(current, ptoken, TOKEN_INTEGER); - long token_length = next - current; - - /* first char is either digit or '+' or '-' - check the rest consists of valid characters */ - for (long i = 1; i < token_length; i++) { - - if ((*ptoken)->data[i] == '.' && has_decimal_point) { - (*ptoken)->error = "Invalid character reading number"; - break; - } - else if ((*ptoken)->data[i] == '.' && !has_decimal_point) { - has_decimal_point = 1; - (*ptoken)->type = TOKEN_FLOAT; - break; - } - else if (!(isdigit((*ptoken)->data[i]))) { - (*ptoken)->error = "Invalid character reading number"; - break; - } - } - return next; -} - -char* read_string_token(char* current, Token** ptoken) { - - char *start, *end, *error = NULL; - long token_length = 0; - - start = current + 1; - - while(1) { - end = strchr(start, '"'); /* find the next " character */ - - /* handle failure to find closing quotes - implies end of input has been reached */ - if (!end) { - end = current + strlen(current); - token_length = strlen(current); - - error = "EOF reached with unterminated string"; - break; - } - /* if the character preceding the " is a '\' character (escape), need to check if it is escaping the " and if it - is then keep searching from the next character */ - else if ( *(end - 1) == '\\') { - - char* back_ptr = end - 1; - while (*back_ptr == '\\') { - back_ptr--; /* back up to count the escape characters '\' */ - } - - long escape_chars = (end - 1) - back_ptr; - - if (escape_chars % 2 == 1) { /* odd number of '\' chars means " is not quoted */ - start = end + 1; /* so keep searching */ - } else { - /* even number of '\' characters means we found the terminating quote mark */ - token_length = (end - current - 1); /* quotes are excluded from string token */ - break; - } - } - else { - token_length = (end - current - 1); /* quotes are excluded from string token */ - break; - } - } - - char* unescaped_string = unescape_string(current + 1, token_length); - *ptoken = token_allocate(unescaped_string, strlen(unescaped_string), TOKEN_STRING, error); - - return (end + 1); -} - -char* read_comment_token(char* current, Token** ptoken) { - /* comment includes all remaining characters to the next newline */ - - /* search for newline character */ - char* end = strchr(current, 0x0A); - - /* if newline is not found it implies the end of string is reached */ - long token_chars = !end ? strlen(current) : (end - current); - - *ptoken = token_allocate(current, token_chars, TOKEN_COMMENT, NULL); - - return (current + token_chars + 1); /* next token starts with the char after the newline */ -} - -MalType* read_form(Reader* reader) { - - if (reader->token_count > 0) { - - Token* tok = reader_peek(reader); - if (tok->type == TOKEN_SPECIAL_CHARACTER) { - - switch(tok->data[0]) { - - case '(': - return read_list(reader); - break; - - case '[': - return read_vector(reader); - break; - - case '{': - return read_hashmap(reader); - break; - - case '\'': - /* create and return a MalType list (quote read_form) */ - return make_symbol_list(reader, SYMBOL_QUOTE); - break; - - case '`': - /* create and return a MalType list (quasiquote read_form) */ - return make_symbol_list(reader, SYMBOL_QUASIQUOTE); - break; - - case '~': - if (tok->data[1] == '@') { - /* create and return a MalType list (splice-unquote read_form) */ - return make_symbol_list(reader, SYMBOL_SPLICE_UNQUOTE); - } - else { - /* create and return a MalType list (unquote read_form) */ - return make_symbol_list(reader, SYMBOL_UNQUOTE); - } - case '@': - /* create and return a MalType list (deref read_form) */ - return make_symbol_list(reader, SYMBOL_DEREF); - - case '^': - /* create and return a MalType list (with-meta - where first form should ne a metadata map and second form is somethingh - that can have metadata attached */ - reader_next(reader); - - /* grab the components of the list */ - MalType* symbol = make_symbol(SYMBOL_WITH_META); - MalType* first_form = read_form(reader); - MalType* second_form = read_form(reader); - - /* push the symbol and the following forms onto a list */ - list lst = NULL; - lst = list_push(lst, symbol); - lst = list_push(lst, second_form); - lst = list_push(lst, first_form); - lst = list_reverse(lst); - - return make_list(lst); - - default: - /* shouldn't happen */ - return make_error_fmt("Reader error: Unknown special character '%c'", tok->data[0]); - } - - } else { /* Not a special character */ - return read_atom(reader); - } - } - else { /* no tokens */ - return NULL; - } -} - -MalType* read_list(Reader* reader) { - - MalType* retval = read_matched_delimiters(reader, '(', ')' ); - - if (is_error(retval)) { - retval = make_error("Reader error: unbalanced parenthesis '()'"); - } - else { - retval->type = MALTYPE_LIST; - } - return retval; -} - -MalType* read_vector(Reader* reader) { - - MalType* retval = read_matched_delimiters(reader, '[', ']' ); - - if (is_error(retval)) { - retval = make_error("Reader error: unbalanced brackets '[]'"); - } - else { - retval->type = MALTYPE_VECTOR; - } - return retval; -} - -MalType* read_hashmap(Reader* reader) { - - MalType* retval = read_matched_delimiters(reader, '{', '}' ); - - if (is_error(retval)) { - retval = make_error("Reader error: unbalanced braces '{}'"); - } - else if (list_count(retval->value.mal_list)%2 != 0) { - retval = make_error("Reader error: missing value in map literal"); - } - else { - retval->type = MALTYPE_HASHMAP; - } - return retval; -} - -MalType* read_matched_delimiters(Reader* reader, char start_delimiter, char end_delimiter) { -/* TODO: separate implementation of hashmap and vector */ - - Token* tok = reader_next(reader); - list lst = NULL; - - if (reader_peek(reader)->data[0] == end_delimiter) { - reader_next(reader); - return make_list(NULL); - } - else { - while (tok->data[0] != end_delimiter) { - - MalType* val = read_form(reader); - lst = list_push(lst, (gptr)val); - - tok = reader_peek(reader); - - if (!tok) { - /* unbalanced parentheses */ - return make_error(""); - } - } - reader_next(reader); - - return make_list(list_reverse(lst)); - } -} - -MalType* read_atom(Reader* reader) { - - Token* tok = reader_next(reader); - - switch (tok->type) { - - case TOKEN_SPECIAL_CHARACTER: - return make_symbol(tok->data); - break; - - case TOKEN_COMMENT: - return make_error("Error: comment found in token strea"); - break; - - case TOKEN_STRING: - return make_string(tok->data); - break; - - case TOKEN_INTEGER: - return make_integer(strtol(tok->data, NULL, 10)); - break; - - case TOKEN_FLOAT: - return make_float(atof(tok->data)); - break; - - case TOKEN_SYMBOL: - return make_symbol(tok->data); - break; - - case TOKEN_KEYWORD: - return make_keyword(tok->data); - break; - - case TOKEN_TRUE: - return make_true(); - break; - - case TOKEN_FALSE: - return make_false(); - break; - - case TOKEN_NIL: - return make_nil(); - break; - } - return make_error("Reader error: Unknown atom type"); -} - -MalType* make_symbol_list(Reader* reader, char* symbol_name) { - - reader_next(reader); - list lst = NULL; - - /* push the symbol and the following form onto the list */ - lst = list_push(lst, make_symbol(symbol_name)); - lst = list_push(lst, read_form(reader)); - - return make_list(list_reverse(lst)); -} - -Token* token_allocate(char* str, long num_chars, int type, char* error) { - - /* allocate space for the string */ - char* data = GC_MALLOC(sizeof(*data) * num_chars + 1); /* include space for null byte */ - strncpy (data, str, num_chars); /* copy num_chars characters into data */ - data[num_chars] = '\0'; /* manually add the null byte */ - - /* allocate space for the token struct */ - Token* token = GC_MALLOC(sizeof(*token)); - token->data = data; - token->type = type; - token->error = error; - - return token; -} - -char* unescape_string(char* str, long length) { - - char* dest = GC_MALLOC(sizeof(*dest)*length + 1); - - long j = 0; - for (long i = 0; i < length; i++) { - - /* look for the quoting character */ - if (str[i] == '\\') { - - switch (str[i+1]) { - - /* replace '\"' with normal '"' */ - case '"': - dest[j++]='"'; - i++; /* skip extra char */ - break; - - /* replace '\n' with newline 0x0A */ - case 'n': - dest[j++]= 0x0A; - i++; /* skip extra char */ - break; - - /* replace '\\' with '\' */ - case '\\': - dest[j++]= '\\'; - i++; /* skip extra char */ - break; - - default: - /* just a '\' symbol so copy it */ - dest[j++]='\\'; - } - } - /* not a quote so copy it */ - else { - dest[j++] = str[i]; - } - } - dest[j] = '\0'; - - return dest; -} +#include +#include +#include +#include +#include + +#include "reader.h" + +#define TOKEN_SPECIAL_CHARACTER 1 +#define TOKEN_STRING 2 +#define TOKEN_INTEGER 3 +#define TOKEN_FLOAT 4 +#define TOKEN_SYMBOL 5 +#define TOKEN_COMMENT 6 +#define TOKEN_KEYWORD 7 +#define TOKEN_TRUE 8 +#define TOKEN_FALSE 9 +#define TOKEN_NIL 10 + +#define SYMBOL_NIL "nil" +#define SYMBOL_TRUE "true" +#define SYMBOL_FALSE "false" +#define SYMBOL_QUOTE "quote" +#define SYMBOL_QUASIQUOTE "quasiquote" +#define SYMBOL_UNQUOTE "unquote" +#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" +#define SYMBOL_DEREF "deref" +#define SYMBOL_WITH_META "with-meta" + +Reader* reader_make(long token_capacity) { + + Reader* reader = GC_MALLOC(sizeof(*reader)); + + reader->max_tokens = token_capacity; + reader->position = 0; + reader->token_count = 0; + reader->token_data = GC_MALLOC(sizeof(Token*) * token_capacity); + reader->error = NULL; + + return reader; +} + +Reader* reader_append(Reader* reader, Token* token) { + + if (reader->token_count < reader->max_tokens) { + + reader->token_data[reader->token_count] = token; + reader->token_count++; + } + else { + /* TODO: expand the storage more intelligently */ + reader->max_tokens *= 2; + reader = GC_REALLOC(reader, sizeof(*reader) * reader->max_tokens); + reader->token_data[reader->token_count] = token; + reader->token_count++; + } + return reader; +} + +Token* reader_peek(const Reader* reader) { + + return (reader->token_data[reader->position]); +} + +Token* reader_next(Reader* reader) { + + Token* tok = reader->token_data[reader->position]; + + if (reader->position == -1) { + return NULL; + } + else if (reader->position < reader->token_count) { + (reader->position)++; + return tok; + } + else { + reader->position = -1; + return tok; + } +} + +void reader_print(Reader* reader) { + /* NOTE: needed for debugging the reader only */ + + Token* tok; + + for (long i = 0; i < reader->token_count; i++) { + + tok = reader_next(reader); + + switch (tok->type) { + case TOKEN_SPECIAL_CHARACTER: + printf("special character: %s", tok->data); + break; + case TOKEN_STRING: + printf("string: %s", tok->data); + break; + case TOKEN_INTEGER: + printf("integer: %s", tok->data); + break; + case TOKEN_FLOAT: + printf("float: %s", tok->data); + break; + case TOKEN_SYMBOL: + printf("symbol: %s", tok->data); + break; + case TOKEN_COMMENT: + printf("comment: \"%s\"", tok->data); + break; + case TOKEN_KEYWORD: + printf("keyword: %s", tok->data); + break; + case TOKEN_TRUE: + printf("true: %s", tok->data); + break; + case TOKEN_FALSE: + printf("false: %s", tok->data); + break; + case TOKEN_NIL: + printf("nil: %s", tok->data); + break; + } + /* print an error for any tokens with an error string */ + tok->error ? printf(" - %s", tok->error) : 0; + } +} + +MalType* read_str(char* token_string) { + + Reader* reader = tokenize(token_string); + + if (reader->error) { + return make_error_fmt("Reader error: %s", reader->error); + } + else if (reader->token_count == 0) { + return make_nil(); + } + else { + return read_form(reader); + } +} + +Reader* tokenize(char* token_string) { + + /* allocate enough space for a Reader */ + /* TODO: over-allocates space */ + Reader* reader = reader_make(strlen(token_string)); + + for (char* next = token_string; *next != '\0';) { + + Token* token = NULL; + + switch (*next) { + /* skip whitespace */ + case ' ': + case ',': + case 0x0A: /* newline */ + next++; + token = NULL; /* no token for whitespace */ + break; + + /* single character token */ + case '[': + case '\\': + case ']': + case '{': + case '}': + case '(': + case ')': + case '\'': + case '@': + case '`': + case '^': + next = read_fixed_length_token(next, &token, 1); + break; + + /* single or double character token */ + case '~': + if ( *(next + 1) == '@' ) { + next = read_fixed_length_token(next, &token, 2); + } + else { + next = read_fixed_length_token(next, &token, 1); + } + break; + + /* read string of characters within double quotes */ + case '"': + next = read_string_token(next, &token); + break; + + /* read a comment - all remaining input until newline */ + case ';': + next = read_comment_token(next, &token); + token = NULL; /* skip token for comments */ + break; + + /* read an integer */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + next = read_number_token(next, &token); + // next = read_integer_token(next, &token); + break; + + /* integer may be prefixed with +/- */ + case '+': + case '-': + if (isdigit(next[1])) { + next = read_number_token(next, &token); + // next = read_integer_token(next, &token); + } + else { /* if not digits it is part of a symbol */ + next = read_symbol_token(next, &token); + } + break; + + /* read keyword */ + case ':': + next = read_keyword_token(next, &token); + break; + + /* read anything else as a symbol */ + default: + next = read_symbol_token(next, &token); + break; + } + + if (!token) { + /* if no token was read (whitespace or comments) + continue the loop */ + continue; + } + else { + + if (token->error) { + /* report any errors with an early return */ + reader = reader_append(reader, token); + reader->error = token->error; + return reader; + } + /* otherwise append the token and continue */ + reader = reader_append(reader, token); + } + } + return reader; +} + +char* read_fixed_length_token(char* current, Token** ptoken, int n) { + + *ptoken = token_allocate(current, n, TOKEN_SPECIAL_CHARACTER, NULL); + return (current + n); +} + +char* read_terminated_token (char* current, Token** ptoken, int token_type) { + + static char* const terminating_characters = " ,[](){};\n"; + + /* search for first terminating character */ + char* end = strpbrk(current, terminating_characters); + + /* if terminating character is not found it implies the end of the string */ + long token_length = !end ? strlen(current) : (end - current); + + /* next token starts with the terminating character */ + *ptoken = token_allocate(current, token_length, token_type, NULL); + return (current + token_length); +} + +char* read_symbol_token (char* current, Token** ptoken) { + + char* next = read_terminated_token(current, ptoken, TOKEN_SYMBOL); + + /* check for reserved symbols */ + if (strcmp((*ptoken)->data, SYMBOL_NIL) == 0) { + (*ptoken)->type = TOKEN_NIL; + } + else if (strcmp((*ptoken)->data, SYMBOL_TRUE) == 0) { + (*ptoken)->type = TOKEN_TRUE; + } + else if (strcmp((*ptoken)->data, SYMBOL_FALSE) == 0) { + (*ptoken)->type = TOKEN_FALSE; + } + + /* TODO: check for invalid characters */ + return next; +} + + +char* read_keyword_token (char* current, Token** ptoken) { + + /* TODO: check for invalid characters */ + return read_terminated_token(current + 1, ptoken, TOKEN_KEYWORD); +} + +char* read_number_token(char* current, Token** ptoken) { + + int has_decimal_point = 0; + + char* next = read_terminated_token(current, ptoken, TOKEN_INTEGER); + long token_length = next - current; + + /* first char is either digit or '+' or '-' + check the rest consists of valid characters */ + for (long i = 1; i < token_length; i++) { + + if ((*ptoken)->data[i] == '.' && has_decimal_point) { + (*ptoken)->error = "Invalid character reading number"; + break; + } + else if ((*ptoken)->data[i] == '.' && !has_decimal_point) { + has_decimal_point = 1; + (*ptoken)->type = TOKEN_FLOAT; + break; + } + else if (!(isdigit((*ptoken)->data[i]))) { + (*ptoken)->error = "Invalid character reading number"; + break; + } + } + return next; +} + +char* read_string_token(char* current, Token** ptoken) { + + char *start, *end, *error = NULL; + long token_length = 0; + + start = current + 1; + + while(1) { + end = strchr(start, '"'); /* find the next " character */ + + /* handle failure to find closing quotes - implies end of input has been reached */ + if (!end) { + end = current + strlen(current); + token_length = strlen(current); + + error = "EOF reached with unterminated string"; + break; + } + /* if the character preceding the " is a '\' character (escape), need to check if it is escaping the " and if it + is then keep searching from the next character */ + else if ( *(end - 1) == '\\') { + + char* back_ptr = end - 1; + while (*back_ptr == '\\') { + back_ptr--; /* back up to count the escape characters '\' */ + } + + long escape_chars = (end - 1) - back_ptr; + + if (escape_chars % 2 == 1) { /* odd number of '\' chars means " is not quoted */ + start = end + 1; /* so keep searching */ + } else { + /* even number of '\' characters means we found the terminating quote mark */ + token_length = (end - current - 1); /* quotes are excluded from string token */ + break; + } + } + else { + token_length = (end - current - 1); /* quotes are excluded from string token */ + break; + } + } + + char* unescaped_string = unescape_string(current + 1, token_length); + *ptoken = token_allocate(unescaped_string, strlen(unescaped_string), TOKEN_STRING, error); + + return (end + 1); +} + +char* read_comment_token(char* current, Token** ptoken) { + /* comment includes all remaining characters to the next newline */ + + /* search for newline character */ + char* end = strchr(current, 0x0A); + + /* if newline is not found it implies the end of string is reached */ + long token_chars = !end ? strlen(current) : (end - current); + + *ptoken = token_allocate(current, token_chars, TOKEN_COMMENT, NULL); + + return (current + token_chars + 1); /* next token starts with the char after the newline */ +} + +MalType* read_form(Reader* reader) { + + if (reader->token_count > 0) { + + Token* tok = reader_peek(reader); + if (tok->type == TOKEN_SPECIAL_CHARACTER) { + + switch(tok->data[0]) { + + case '(': + return read_list(reader); + break; + + case '[': + return read_vector(reader); + break; + + case '{': + return read_hashmap(reader); + break; + + case '\'': + /* create and return a MalType list (quote read_form) */ + return make_symbol_list(reader, SYMBOL_QUOTE); + break; + + case '`': + /* create and return a MalType list (quasiquote read_form) */ + return make_symbol_list(reader, SYMBOL_QUASIQUOTE); + break; + + case '~': + if (tok->data[1] == '@') { + /* create and return a MalType list (splice-unquote read_form) */ + return make_symbol_list(reader, SYMBOL_SPLICE_UNQUOTE); + } + else { + /* create and return a MalType list (unquote read_form) */ + return make_symbol_list(reader, SYMBOL_UNQUOTE); + } + case '@': + /* create and return a MalType list (deref read_form) */ + return make_symbol_list(reader, SYMBOL_DEREF); + + case '^': + /* create and return a MalType list (with-meta + where first form should ne a metadata map and second form is somethingh + that can have metadata attached */ + reader_next(reader); + + /* grab the components of the list */ + MalType* symbol = make_symbol(SYMBOL_WITH_META); + MalType* first_form = read_form(reader); + MalType* second_form = read_form(reader); + + /* push the symbol and the following forms onto a list */ + list lst = NULL; + lst = list_push(lst, symbol); + lst = list_push(lst, second_form); + lst = list_push(lst, first_form); + lst = list_reverse(lst); + + return make_list(lst); + + default: + /* shouldn't happen */ + return make_error_fmt("Reader error: Unknown special character '%c'", tok->data[0]); + } + + } else { /* Not a special character */ + return read_atom(reader); + } + } + else { /* no tokens */ + return NULL; + } +} + +MalType* read_list(Reader* reader) { + + MalType* retval = read_matched_delimiters(reader, '(', ')' ); + + if (is_error(retval)) { + retval = make_error("Reader error: unbalanced parenthesis '()'"); + } + else { + retval->type = MALTYPE_LIST; + } + return retval; +} + +MalType* read_vector(Reader* reader) { + + MalType* retval = read_matched_delimiters(reader, '[', ']' ); + + if (is_error(retval)) { + retval = make_error("Reader error: unbalanced brackets '[]'"); + } + else { + retval->type = MALTYPE_VECTOR; + } + return retval; +} + +MalType* read_hashmap(Reader* reader) { + + MalType* retval = read_matched_delimiters(reader, '{', '}' ); + + if (is_error(retval)) { + retval = make_error("Reader error: unbalanced braces '{}'"); + } + else if (list_count(retval->value.mal_list)%2 != 0) { + retval = make_error("Reader error: missing value in map literal"); + } + else { + retval->type = MALTYPE_HASHMAP; + } + return retval; +} + +MalType* read_matched_delimiters(Reader* reader, char start_delimiter, char end_delimiter) { +/* TODO: separate implementation of hashmap and vector */ + + Token* tok = reader_next(reader); + list lst = NULL; + + if (reader_peek(reader)->data[0] == end_delimiter) { + reader_next(reader); + return make_list(NULL); + } + else { + while (tok->data[0] != end_delimiter) { + + MalType* val = read_form(reader); + lst = list_push(lst, (gptr)val); + + tok = reader_peek(reader); + + if (!tok) { + /* unbalanced parentheses */ + return make_error(""); + } + } + reader_next(reader); + + return make_list(list_reverse(lst)); + } +} + +MalType* read_atom(Reader* reader) { + + Token* tok = reader_next(reader); + + switch (tok->type) { + + case TOKEN_SPECIAL_CHARACTER: + return make_symbol(tok->data); + break; + + case TOKEN_COMMENT: + return make_error("Error: comment found in token strea"); + break; + + case TOKEN_STRING: + return make_string(tok->data); + break; + + case TOKEN_INTEGER: + return make_integer(strtol(tok->data, NULL, 10)); + break; + + case TOKEN_FLOAT: + return make_float(atof(tok->data)); + break; + + case TOKEN_SYMBOL: + return make_symbol(tok->data); + break; + + case TOKEN_KEYWORD: + return make_keyword(tok->data); + break; + + case TOKEN_TRUE: + return make_true(); + break; + + case TOKEN_FALSE: + return make_false(); + break; + + case TOKEN_NIL: + return make_nil(); + break; + } + return make_error("Reader error: Unknown atom type"); +} + +MalType* make_symbol_list(Reader* reader, char* symbol_name) { + + reader_next(reader); + list lst = NULL; + + /* push the symbol and the following form onto the list */ + lst = list_push(lst, make_symbol(symbol_name)); + lst = list_push(lst, read_form(reader)); + + return make_list(list_reverse(lst)); +} + +Token* token_allocate(char* str, long num_chars, int type, char* error) { + + /* allocate space for the string */ + char* data = GC_MALLOC(sizeof(*data) * num_chars + 1); /* include space for null byte */ + strncpy (data, str, num_chars); /* copy num_chars characters into data */ + data[num_chars] = '\0'; /* manually add the null byte */ + + /* allocate space for the token struct */ + Token* token = GC_MALLOC(sizeof(*token)); + token->data = data; + token->type = type; + token->error = error; + + return token; +} + +char* unescape_string(char* str, long length) { + + char* dest = GC_MALLOC(sizeof(*dest)*length + 1); + + long j = 0; + for (long i = 0; i < length; i++) { + + /* look for the quoting character */ + if (str[i] == '\\') { + + switch (str[i+1]) { + + /* replace '\"' with normal '"' */ + case '"': + dest[j++]='"'; + i++; /* skip extra char */ + break; + + /* replace '\n' with newline 0x0A */ + case 'n': + dest[j++]= 0x0A; + i++; /* skip extra char */ + break; + + /* replace '\\' with '\' */ + case '\\': + dest[j++]= '\\'; + i++; /* skip extra char */ + break; + + default: + /* just a '\' symbol so copy it */ + dest[j++]='\\'; + } + } + /* not a quote so copy it */ + else { + dest[j++] = str[i]; + } + } + dest[j] = '\0'; + + return dest; +} diff --git a/impls/c.2/reader.h b/impls/c.2/reader.h index c982d7f8e8..8380166f82 100644 --- a/impls/c.2/reader.h +++ b/impls/c.2/reader.h @@ -1,57 +1,57 @@ -#ifndef _MAL_READER_H -#define _MAL_READER_H - -#include "types.h" - -typedef struct Token_s { - - int type; - char* data; - char* error; - -} Token; - -typedef struct Reader_s { - - long position; // current position in the array - long token_count; // number of tokens in the array - long max_tokens; // maximum number of tokens the array can hold - Token** token_data; // pointer to an array of Tokens - char* error; // error message - -} Reader; - -/* reader object */ -Reader* reader_make(long token_capacity); -Reader* reader_append(Reader* reader, Token* token); -Token* reader_peek(const Reader* reader); -Token* reader_next(Reader* reader); -Token* reader_get_at(const Reader* reader, long i); -void reader_print(Reader* reader); - -/* tokenizing the input */ -Reader* tokenize(char* token_string); -char* read_fixed_length_token(char* current, Token** ptoken, int n); -char* read_string_token(char* current, Token** ptoken); -char* read_comment_token(char* current, Token** ptoken); -//char* read_integer_token(char* current, Token** ptoken); -char* read_number_token(char* current, Token** ptoken); -char* read_symbol_token(char* current, Token** ptoken); -char* read_keyword_token(char* current, Token** ptoken); - -/* reading the tokens into types */ -MalType* read_str(char* token_string); -MalType* read_form(Reader* reader); -MalType* read_atom(Reader* reader); -MalType* read_list(Reader* reader); -MalType* read_vector(Reader* reader); -MalType* read_hashmap(Reader* reader); - -/* utility functions */ -char* read_terminated_token (char* current, Token** ptoken, int type); -MalType* read_matched_delimiters(Reader* reader, char start_delimiter, char end_delimiter); -MalType* make_symbol_list(Reader* reader, char* symbol_name); -Token* token_allocate(char* str, long num_chars, int type, char* error); -char* unescape_string(char* str, long length); - -#endif +#ifndef _MAL_READER_H +#define _MAL_READER_H + +#include "types.h" + +typedef struct Token_s { + + int type; + char* data; + char* error; + +} Token; + +typedef struct Reader_s { + + long position; // current position in the array + long token_count; // number of tokens in the array + long max_tokens; // maximum number of tokens the array can hold + Token** token_data; // pointer to an array of Tokens + char* error; // error message + +} Reader; + +/* reader object */ +Reader* reader_make(long token_capacity); +Reader* reader_append(Reader* reader, Token* token); +Token* reader_peek(const Reader* reader); +Token* reader_next(Reader* reader); +Token* reader_get_at(const Reader* reader, long i); +void reader_print(Reader* reader); + +/* tokenizing the input */ +Reader* tokenize(char* token_string); +char* read_fixed_length_token(char* current, Token** ptoken, int n); +char* read_string_token(char* current, Token** ptoken); +char* read_comment_token(char* current, Token** ptoken); +//char* read_integer_token(char* current, Token** ptoken); +char* read_number_token(char* current, Token** ptoken); +char* read_symbol_token(char* current, Token** ptoken); +char* read_keyword_token(char* current, Token** ptoken); + +/* reading the tokens into types */ +MalType* read_str(char* token_string); +MalType* read_form(Reader* reader); +MalType* read_atom(Reader* reader); +MalType* read_list(Reader* reader); +MalType* read_vector(Reader* reader); +MalType* read_hashmap(Reader* reader); + +/* utility functions */ +char* read_terminated_token (char* current, Token** ptoken, int type); +MalType* read_matched_delimiters(Reader* reader, char start_delimiter, char end_delimiter); +MalType* make_symbol_list(Reader* reader, char* symbol_name); +Token* token_allocate(char* str, long num_chars, int type, char* error); +char* unescape_string(char* str, long length); + +#endif diff --git a/impls/c.2/run b/impls/c.2/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/c.2/run +++ b/impls/c.2/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/c.2/step0_repl.c b/impls/c.2/step0_repl.c index fd980eed25..25fc6f950d 100644 --- a/impls/c.2/step0_repl.c +++ b/impls/c.2/step0_repl.c @@ -1,60 +1,60 @@ -#include -#include - -#include -#include - -#define PROMPT_STRING "user> " - - -char* READ(char* str) { - - return str; -} - -char* EVAL(char* str) { - - return str; -} - -void PRINT(char* str) { - - printf("%s\n", str); -} - -void rep(char* str) { - - PRINT(EVAL(READ(str))); -} - - -int main(int argc, char** argv) { - - /* Greeting message */ - puts("Make-a-lisp version 0.0.1\n"); - puts("Press Ctrl+d to exit\n"); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input); - - /* have to release the memory used by readline */ - free(input); - } - - return 0; -} +#include +#include + +#include +#include + +#define PROMPT_STRING "user> " + + +char* READ(char* str) { + + return str; +} + +char* EVAL(char* str) { + + return str; +} + +void PRINT(char* str) { + + printf("%s\n", str); +} + +void rep(char* str) { + + PRINT(EVAL(READ(str))); +} + + +int main(int argc, char** argv) { + + /* Greeting message */ + puts("Make-a-lisp version 0.0.1\n"); + puts("Press Ctrl+d to exit\n"); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input); + + /* have to release the memory used by readline */ + free(input); + } + + return 0; +} diff --git a/impls/c.2/step1_read_print.c b/impls/c.2/step1_read_print.c index a522df15fd..68c0d6b79c 100644 --- a/impls/c.2/step1_read_print.c +++ b/impls/c.2/step1_read_print.c @@ -1,63 +1,63 @@ -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* val) { - - return val; -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str) { - - PRINT(EVAL(READ(str))); -} - -int main(int argc, char** argv) { - - /* Greeting message */ - puts("Make-a-lisp version 0.0.2\n"); - puts("Press Ctrl+d to exit\n"); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input); - - /* have to release the memory used by readline */ - free(input); - } - - return 0; -} +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* val) { + + return val; +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str) { + + PRINT(EVAL(READ(str))); +} + +int main(int argc, char** argv) { + + /* Greeting message */ + puts("Make-a-lisp version 0.0.2\n"); + puts("Press Ctrl+d to exit\n"); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input); + + /* have to release the memory used by readline */ + free(input); + } + + return 0; +} diff --git a/impls/c.2/step2_eval.c b/impls/c.2/step2_eval.c index 0b0d6424d9..42a072e20e 100644 --- a/impls/c.2/step2_eval.c +++ b/impls/c.2/step2_eval.c @@ -1,305 +1,305 @@ -#include -#include -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" -#include "env.h" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* ast, Env* env) { - - /* forward references */ - MalType* eval_ast(MalType* ast, Env* env); - - /* NULL */ - if (!ast) { return make_nil(); } - - /* not a list */ - if (!is_list(ast)) { return eval_ast(ast, env); } - - /* empty list */ - if (ast->value.mal_list == NULL) { return ast; } - - /* list */ - - /* evaluate the list */ - MalType* evaluated_list = eval_ast(ast, env); - - if (is_error(evaluated_list)) { return evaluated_list; } - - /* apply the first element of the list to the arguments */ - list evlst = evaluated_list->value.mal_list; - MalType* func = evlst->data; - - if (is_function(func)) { - return (*func->value.mal_function)(evlst->next); - } - else { - return make_error_fmt("Error: first item in list is not callable: %s.", \ - pr_str(func, UNREADABLY)); - } -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str, Env* env) { - - PRINT(EVAL(READ(str), env)); -} - -int main(int argc, char** argv) { - - MalType* mal_add(list args); - MalType* mal_sub(list args); - MalType* mal_mul(list args); - MalType* mal_div(list args); - - /* Greeting message */ - puts("Make-a-lisp version 0.0.2\n"); - puts("Press Ctrl+d to exit\n"); - - MalType* func_add = make_function(&mal_add); - MalType* func_sub = make_function(&mal_sub); - MalType* func_mul = make_function(&mal_mul); - MalType* func_div = make_function(&mal_div); - - hashmap g = hashmap_make("+", func_add); - g = hashmap_put(g, "-", func_sub); - g = hashmap_put(g, "*", func_mul); - g = hashmap_put(g, "/", func_div); - - Env* repl_env = GC_MALLOC(sizeof(*repl_env)); - repl_env->data = g; - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input, repl_env); - - /* have to release the memory used by readline */ - free(input); - } - - return 0; -} - -MalType* eval_ast(MalType* ast, Env* env) { - - /* forward references */ - list evaluate_list(list lst, Env* env); - list evaluate_vector(list lst, Env* env); - list evaluate_hashmap(list lst, Env* env); - - if (is_symbol(ast)) { - - MalType* symbol_value = hashmap_get(env->data, ast->value.mal_symbol); - - if (symbol_value) { - return symbol_value; - } else { - return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); - } - } - else if (is_list(ast)) { - - list result = evaluate_list(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_list(result); - } else { - return result->data; - } - } - else if (is_vector(ast)) { - - list result = evaluate_vector(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_vector(result); - } else { - return result->data; - } - } - else if (is_hashmap(ast)) { - - list result = evaluate_hashmap(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_hashmap(result); - } else { - return result->data; - } - } - else { - return ast; - } -} - -list evaluate_list(list lst, Env* env) { - - list evlst = NULL; - while (lst) { - evlst = list_push(evlst, EVAL(lst->data, env)); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_vector(list lst, Env* env) { - /* TODO: implement a real vector */ - list evlst = NULL; - while (lst) { - evlst = list_push(evlst, EVAL(lst->data, env)); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_hashmap(list lst, Env* env) { - /* TODO: implement a real hashmap */ - list evlst = NULL; - while (lst) { - - /* keys are unevaluated */ - evlst = list_push(evlst, lst->data); - lst = lst->next; - /* values are evaluated */ - evlst = list_push(evlst, EVAL(lst->data, env)); - lst = lst->next; - } - return list_reverse(evlst); -} - -MalType* mal_add(list args) { - - MalType* result = GC_MALLOC(sizeof(*result)); - result->type = MALTYPE_INTEGER; - - list arg_list = args; - - long sum = 0; - while(arg_list) { - - MalType* val = arg_list->data; - /* TODO: check argument type */ - - sum = sum + val->value.mal_integer; - - arg_list = arg_list->next; - } - - result->value.mal_integer = sum; - return result; -} - -MalType* mal_sub(list args) { - - long sum; - MalType* result = GC_MALLOC(sizeof(*result)); - result->type = MALTYPE_INTEGER; - - list arg_list = args; - if (arg_list) { - - MalType* first_val = arg_list->data; - arg_list = arg_list->next; - /* TODO: check argument type */ - - sum = first_val->value.mal_integer; - while(arg_list) { - - MalType* val = arg_list->data; - /* TODO: check argument type */ - - sum = sum - val->value.mal_integer; - - arg_list = arg_list->next; - } - } - else { - sum = 0; - } - - result->value.mal_integer = sum; - return result; -} - -MalType* mal_mul(list args) { - - MalType* result = GC_MALLOC(sizeof(*result)); - result->type = MALTYPE_INTEGER; - - list arg_list = args; - - long product = 1; - while(arg_list) { - - MalType* val = arg_list->data; - /* TODO: check argument type */ - - product *= val->value.mal_integer; - - arg_list = arg_list->next; - } - - result->value.mal_integer = product; - return result; -} - -MalType* mal_div(list args) { - - long product; - MalType* result = GC_MALLOC(sizeof(*result)); - result->type = MALTYPE_INTEGER; - - list arg_list = args; - - if (arg_list) { - MalType* first_val = arg_list->data; - /* TODO: check argument type */ - product = first_val->value.mal_integer; - arg_list = arg_list->next; - - while(arg_list) { - - MalType* val = arg_list->data; - /* TODO: check argument type */ - - product /= (val->value.mal_integer); - arg_list = arg_list->next; - } - } else { - product = 1; - } - result->value.mal_integer = product; - return result; -} +#include +#include +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" +#include "env.h" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* ast, Env* env) { + + /* forward references */ + MalType* eval_ast(MalType* ast, Env* env); + + /* NULL */ + if (!ast) { return make_nil(); } + + /* not a list */ + if (!is_list(ast)) { return eval_ast(ast, env); } + + /* empty list */ + if (ast->value.mal_list == NULL) { return ast; } + + /* list */ + + /* evaluate the list */ + MalType* evaluated_list = eval_ast(ast, env); + + if (is_error(evaluated_list)) { return evaluated_list; } + + /* apply the first element of the list to the arguments */ + list evlst = evaluated_list->value.mal_list; + MalType* func = evlst->data; + + if (is_function(func)) { + return (*func->value.mal_function)(evlst->next); + } + else { + return make_error_fmt("Error: first item in list is not callable: %s.", \ + pr_str(func, UNREADABLY)); + } +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str, Env* env) { + + PRINT(EVAL(READ(str), env)); +} + +int main(int argc, char** argv) { + + MalType* mal_add(list args); + MalType* mal_sub(list args); + MalType* mal_mul(list args); + MalType* mal_div(list args); + + /* Greeting message */ + puts("Make-a-lisp version 0.0.2\n"); + puts("Press Ctrl+d to exit\n"); + + MalType* func_add = make_function(&mal_add); + MalType* func_sub = make_function(&mal_sub); + MalType* func_mul = make_function(&mal_mul); + MalType* func_div = make_function(&mal_div); + + hashmap g = hashmap_make("+", func_add); + g = hashmap_put(g, "-", func_sub); + g = hashmap_put(g, "*", func_mul); + g = hashmap_put(g, "/", func_div); + + Env* repl_env = GC_MALLOC(sizeof(*repl_env)); + repl_env->data = g; + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input, repl_env); + + /* have to release the memory used by readline */ + free(input); + } + + return 0; +} + +MalType* eval_ast(MalType* ast, Env* env) { + + /* forward references */ + list evaluate_list(list lst, Env* env); + list evaluate_vector(list lst, Env* env); + list evaluate_hashmap(list lst, Env* env); + + if (is_symbol(ast)) { + + MalType* symbol_value = hashmap_get(env->data, ast->value.mal_symbol); + + if (symbol_value) { + return symbol_value; + } else { + return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); + } + } + else if (is_list(ast)) { + + list result = evaluate_list(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_list(result); + } else { + return result->data; + } + } + else if (is_vector(ast)) { + + list result = evaluate_vector(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_vector(result); + } else { + return result->data; + } + } + else if (is_hashmap(ast)) { + + list result = evaluate_hashmap(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_hashmap(result); + } else { + return result->data; + } + } + else { + return ast; + } +} + +list evaluate_list(list lst, Env* env) { + + list evlst = NULL; + while (lst) { + evlst = list_push(evlst, EVAL(lst->data, env)); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_vector(list lst, Env* env) { + /* TODO: implement a real vector */ + list evlst = NULL; + while (lst) { + evlst = list_push(evlst, EVAL(lst->data, env)); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_hashmap(list lst, Env* env) { + /* TODO: implement a real hashmap */ + list evlst = NULL; + while (lst) { + + /* keys are unevaluated */ + evlst = list_push(evlst, lst->data); + lst = lst->next; + /* values are evaluated */ + evlst = list_push(evlst, EVAL(lst->data, env)); + lst = lst->next; + } + return list_reverse(evlst); +} + +MalType* mal_add(list args) { + + MalType* result = GC_MALLOC(sizeof(*result)); + result->type = MALTYPE_INTEGER; + + list arg_list = args; + + long sum = 0; + while(arg_list) { + + MalType* val = arg_list->data; + /* TODO: check argument type */ + + sum = sum + val->value.mal_integer; + + arg_list = arg_list->next; + } + + result->value.mal_integer = sum; + return result; +} + +MalType* mal_sub(list args) { + + long sum; + MalType* result = GC_MALLOC(sizeof(*result)); + result->type = MALTYPE_INTEGER; + + list arg_list = args; + if (arg_list) { + + MalType* first_val = arg_list->data; + arg_list = arg_list->next; + /* TODO: check argument type */ + + sum = first_val->value.mal_integer; + while(arg_list) { + + MalType* val = arg_list->data; + /* TODO: check argument type */ + + sum = sum - val->value.mal_integer; + + arg_list = arg_list->next; + } + } + else { + sum = 0; + } + + result->value.mal_integer = sum; + return result; +} + +MalType* mal_mul(list args) { + + MalType* result = GC_MALLOC(sizeof(*result)); + result->type = MALTYPE_INTEGER; + + list arg_list = args; + + long product = 1; + while(arg_list) { + + MalType* val = arg_list->data; + /* TODO: check argument type */ + + product *= val->value.mal_integer; + + arg_list = arg_list->next; + } + + result->value.mal_integer = product; + return result; +} + +MalType* mal_div(list args) { + + long product; + MalType* result = GC_MALLOC(sizeof(*result)); + result->type = MALTYPE_INTEGER; + + list arg_list = args; + + if (arg_list) { + MalType* first_val = arg_list->data; + /* TODO: check argument type */ + product = first_val->value.mal_integer; + arg_list = arg_list->next; + + while(arg_list) { + + MalType* val = arg_list->data; + /* TODO: check argument type */ + + product /= (val->value.mal_integer); + arg_list = arg_list->next; + } + } else { + product = 1; + } + result->value.mal_integer = product; + return result; +} diff --git a/impls/c.2/step3_env.c b/impls/c.2/step3_env.c index bebfdb4989..a02d50e635 100644 --- a/impls/c.2/step3_env.c +++ b/impls/c.2/step3_env.c @@ -1,357 +1,357 @@ -#include -#include -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" -#include "env.h" - -#define SYMBOL_DEFBANG "def!" -#define SYMBOL_LETSTAR "let*" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* ast, Env* env) { - - /* forward references */ - MalType* eval_ast(MalType* ast, Env* env); - MalType* eval_defbang(MalType* ast, Env* env); - MalType* eval_letstar(MalType* ast, Env* env); - - /* NULL */ - if (!ast) { return make_nil(); } - - /* not a list */ - if (!is_list(ast)) { return eval_ast(ast, env); } - - /* empty list */ - if (ast->value.mal_list == NULL) { return ast; } - - /* list */ - MalType* first = (ast->value.mal_list)->data; - char* symbol = first->value.mal_symbol; - - if (is_symbol(first)) { - - /* handle special symbols first */ - if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { - return eval_defbang(ast, env); - } - else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { - return eval_letstar(ast, env); - } - } - /* first element is not a special symbol */ - MalType* evaluated_list = eval_ast(ast, env); - - if (is_error(evaluated_list)) { return evaluated_list; } - - /* apply the first element of the list to the arguments */ - list evlst = evaluated_list->value.mal_list; - MalType* func = evlst->data; - - if (is_function(func)) { - return (*func->value.mal_function)(evlst->next); - } - else { - return make_error_fmt("Error: first item in list is not callable: %s.", \ - pr_str(func, UNREADABLY)); - } -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str, Env* env) { - - PRINT(EVAL(READ(str), env)); -} - -int main(int argc, char** argv) { - - MalType* mal_add(list args); - MalType* mal_sub(list args); - MalType* mal_mul(list args); - MalType* mal_div(list args); - - /* Greeting message */ - puts("Make-a-lisp version 0.0.3\n"); - puts("Press Ctrl+d to exit\n"); - - Env* repl_env = env_make(NULL, NULL, NULL, NULL); - repl_env = env_set_C_fn(repl_env, "+", mal_add); - repl_env = env_set_C_fn(repl_env, "-", mal_sub); - repl_env = env_set_C_fn(repl_env, "*", mal_mul); - repl_env = env_set_C_fn(repl_env, "/", mal_div); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input, repl_env); - - /* have to release the memory used by readline */ - free(input); - } - - return 0; -} - -MalType* eval_ast(MalType* ast, Env* env) { - - /* forward references */ - list evaluate_list(list lst, Env* env); - list evaluate_vector(list lst, Env* env); - list evaluate_hashmap(list lst, Env* env); - - if (is_symbol(ast)) { - - MalType* symbol_value = env_get(env, ast); - - if (symbol_value) { - return symbol_value; - } else { - return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); - } - } - else if (is_list(ast)) { - - list result = evaluate_list(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_list(result); - } else { - return result->data; - } - } - else if (is_vector(ast)) { - - list result = evaluate_vector(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_vector(result); - } else { - return result->data; - } - } - else if (is_hashmap(ast)) { - - list result = evaluate_hashmap(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_hashmap(result); - } else { - return result->data; - } - } - else { - return ast; - } -} - -MalType* eval_defbang(MalType* ast, Env* env) { - - list lst = (ast->value.mal_list)->next; - - /* TODO: Check the number and types of parameters */ - MalType* defbang_symbol = lst->data; - MalType* defbang_value = lst->next->data; - - MalType* result = EVAL(defbang_value, env); - - if (!is_error(result)) { - env_set(env, defbang_symbol, result); - } - return result; -} - -MalType* eval_letstar(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - lst = lst->next; - - /* TODO: Check the bindings list is valid, has an even number of elements, etc*/ - Env* letstar_env = env_make(env, NULL, NULL, NULL); - - MalType* letstar_bindings = lst->data; - list letstar_bindings_list = letstar_bindings->value.mal_list; - - /* evaluate the bindings */ - while(letstar_bindings_list) { - - MalType* symbol = letstar_bindings_list->data; - MalType* value = letstar_bindings_list->next->data; - letstar_env = env_set(letstar_env, symbol, EVAL(value, letstar_env)); - - letstar_bindings_list = letstar_bindings_list->next->next; /* pop symbol and value*/ - } - - /* evaluate the forms in the presence of bindings */ - MalType* forms = lst->next->data; - return EVAL(forms, letstar_env); -} - -list evaluate_list(list lst, Env* env) { - - list evlst = NULL; - while (lst) { - evlst = list_push(evlst, EVAL(lst->data, env)); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_vector(list lst, Env* env) { - /* TODO: implement a real vector */ - list evlst = NULL; - while (lst) { - evlst = list_push(evlst, EVAL(lst->data, env)); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_hashmap(list lst, Env* env) { - /* TODO: implement a real hashmap */ - list evlst = NULL; - while (lst) { - - /* keys are unevaluated */ - evlst = list_push(evlst, lst->data); - lst = lst->next; - /* values are evaluated */ - evlst = list_push(evlst, EVAL(lst->data, env)); - lst = lst->next; - } - return list_reverse(evlst); -} - -MalType* mal_add(list args) { - - MalType* result = GC_MALLOC(sizeof(*result)); - result->type = MALTYPE_INTEGER; - - list arg_list = args; - - long sum = 0; - while(arg_list) { - - MalType* val = arg_list->data; - /* TODO: check argument type */ - - sum = sum + val->value.mal_integer; - - arg_list = arg_list->next; - } - - result->value.mal_integer = sum; - return result; -} - -MalType* mal_sub(list args) { - - long sum; - MalType* result = GC_MALLOC(sizeof(*result)); - result->type = MALTYPE_INTEGER; - - list arg_list = args; - if (arg_list) { - - MalType* first_val = arg_list->data; - arg_list = arg_list->next; - /* TODO: check argument type */ - - sum = first_val->value.mal_integer; - while(arg_list) { - - MalType* val = arg_list->data; - /* TODO: check argument type */ - - sum = sum - val->value.mal_integer; - - arg_list = arg_list->next; - } - } - else { - sum = 0; - } - - result->value.mal_integer = sum; - return result; -} - -MalType* mal_mul(list args) { - - MalType* result = GC_MALLOC(sizeof(*result)); - result->type = MALTYPE_INTEGER; - - list arg_list = args; - - long product = 1; - while(arg_list) { - - MalType* val = arg_list->data; - /* TODO: check argument type */ - - product *= val->value.mal_integer; - - arg_list = arg_list->next; - } - - result->value.mal_integer = product; - return result; -} - -MalType* mal_div(list args) { - - long product; - MalType* result = GC_MALLOC(sizeof(*result)); - result->type = MALTYPE_INTEGER; - - list arg_list = args; - - if (arg_list) { - MalType* first_val = arg_list->data; - /* TODO: check argument type */ - product = first_val->value.mal_integer; - arg_list = arg_list->next; - - while(arg_list) { - - MalType* val = arg_list->data; - /* TODO: check argument type */ - - product /= (val->value.mal_integer); - arg_list = arg_list->next; - } - } else { - product = 1; - } - result->value.mal_integer = product; - return result; -} +#include +#include +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" +#include "env.h" + +#define SYMBOL_DEFBANG "def!" +#define SYMBOL_LETSTAR "let*" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* ast, Env* env) { + + /* forward references */ + MalType* eval_ast(MalType* ast, Env* env); + MalType* eval_defbang(MalType* ast, Env* env); + MalType* eval_letstar(MalType* ast, Env* env); + + /* NULL */ + if (!ast) { return make_nil(); } + + /* not a list */ + if (!is_list(ast)) { return eval_ast(ast, env); } + + /* empty list */ + if (ast->value.mal_list == NULL) { return ast; } + + /* list */ + MalType* first = (ast->value.mal_list)->data; + char* symbol = first->value.mal_symbol; + + if (is_symbol(first)) { + + /* handle special symbols first */ + if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { + return eval_defbang(ast, env); + } + else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { + return eval_letstar(ast, env); + } + } + /* first element is not a special symbol */ + MalType* evaluated_list = eval_ast(ast, env); + + if (is_error(evaluated_list)) { return evaluated_list; } + + /* apply the first element of the list to the arguments */ + list evlst = evaluated_list->value.mal_list; + MalType* func = evlst->data; + + if (is_function(func)) { + return (*func->value.mal_function)(evlst->next); + } + else { + return make_error_fmt("Error: first item in list is not callable: %s.", \ + pr_str(func, UNREADABLY)); + } +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str, Env* env) { + + PRINT(EVAL(READ(str), env)); +} + +int main(int argc, char** argv) { + + MalType* mal_add(list args); + MalType* mal_sub(list args); + MalType* mal_mul(list args); + MalType* mal_div(list args); + + /* Greeting message */ + puts("Make-a-lisp version 0.0.3\n"); + puts("Press Ctrl+d to exit\n"); + + Env* repl_env = env_make(NULL, NULL, NULL, NULL); + repl_env = env_set_C_fn(repl_env, "+", mal_add); + repl_env = env_set_C_fn(repl_env, "-", mal_sub); + repl_env = env_set_C_fn(repl_env, "*", mal_mul); + repl_env = env_set_C_fn(repl_env, "/", mal_div); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input, repl_env); + + /* have to release the memory used by readline */ + free(input); + } + + return 0; +} + +MalType* eval_ast(MalType* ast, Env* env) { + + /* forward references */ + list evaluate_list(list lst, Env* env); + list evaluate_vector(list lst, Env* env); + list evaluate_hashmap(list lst, Env* env); + + if (is_symbol(ast)) { + + MalType* symbol_value = env_get(env, ast); + + if (symbol_value) { + return symbol_value; + } else { + return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); + } + } + else if (is_list(ast)) { + + list result = evaluate_list(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_list(result); + } else { + return result->data; + } + } + else if (is_vector(ast)) { + + list result = evaluate_vector(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_vector(result); + } else { + return result->data; + } + } + else if (is_hashmap(ast)) { + + list result = evaluate_hashmap(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_hashmap(result); + } else { + return result->data; + } + } + else { + return ast; + } +} + +MalType* eval_defbang(MalType* ast, Env* env) { + + list lst = (ast->value.mal_list)->next; + + /* TODO: Check the number and types of parameters */ + MalType* defbang_symbol = lst->data; + MalType* defbang_value = lst->next->data; + + MalType* result = EVAL(defbang_value, env); + + if (!is_error(result)) { + env_set(env, defbang_symbol, result); + } + return result; +} + +MalType* eval_letstar(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + lst = lst->next; + + /* TODO: Check the bindings list is valid, has an even number of elements, etc*/ + Env* letstar_env = env_make(env, NULL, NULL, NULL); + + MalType* letstar_bindings = lst->data; + list letstar_bindings_list = letstar_bindings->value.mal_list; + + /* evaluate the bindings */ + while(letstar_bindings_list) { + + MalType* symbol = letstar_bindings_list->data; + MalType* value = letstar_bindings_list->next->data; + letstar_env = env_set(letstar_env, symbol, EVAL(value, letstar_env)); + + letstar_bindings_list = letstar_bindings_list->next->next; /* pop symbol and value*/ + } + + /* evaluate the forms in the presence of bindings */ + MalType* forms = lst->next->data; + return EVAL(forms, letstar_env); +} + +list evaluate_list(list lst, Env* env) { + + list evlst = NULL; + while (lst) { + evlst = list_push(evlst, EVAL(lst->data, env)); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_vector(list lst, Env* env) { + /* TODO: implement a real vector */ + list evlst = NULL; + while (lst) { + evlst = list_push(evlst, EVAL(lst->data, env)); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_hashmap(list lst, Env* env) { + /* TODO: implement a real hashmap */ + list evlst = NULL; + while (lst) { + + /* keys are unevaluated */ + evlst = list_push(evlst, lst->data); + lst = lst->next; + /* values are evaluated */ + evlst = list_push(evlst, EVAL(lst->data, env)); + lst = lst->next; + } + return list_reverse(evlst); +} + +MalType* mal_add(list args) { + + MalType* result = GC_MALLOC(sizeof(*result)); + result->type = MALTYPE_INTEGER; + + list arg_list = args; + + long sum = 0; + while(arg_list) { + + MalType* val = arg_list->data; + /* TODO: check argument type */ + + sum = sum + val->value.mal_integer; + + arg_list = arg_list->next; + } + + result->value.mal_integer = sum; + return result; +} + +MalType* mal_sub(list args) { + + long sum; + MalType* result = GC_MALLOC(sizeof(*result)); + result->type = MALTYPE_INTEGER; + + list arg_list = args; + if (arg_list) { + + MalType* first_val = arg_list->data; + arg_list = arg_list->next; + /* TODO: check argument type */ + + sum = first_val->value.mal_integer; + while(arg_list) { + + MalType* val = arg_list->data; + /* TODO: check argument type */ + + sum = sum - val->value.mal_integer; + + arg_list = arg_list->next; + } + } + else { + sum = 0; + } + + result->value.mal_integer = sum; + return result; +} + +MalType* mal_mul(list args) { + + MalType* result = GC_MALLOC(sizeof(*result)); + result->type = MALTYPE_INTEGER; + + list arg_list = args; + + long product = 1; + while(arg_list) { + + MalType* val = arg_list->data; + /* TODO: check argument type */ + + product *= val->value.mal_integer; + + arg_list = arg_list->next; + } + + result->value.mal_integer = product; + return result; +} + +MalType* mal_div(list args) { + + long product; + MalType* result = GC_MALLOC(sizeof(*result)); + result->type = MALTYPE_INTEGER; + + list arg_list = args; + + if (arg_list) { + MalType* first_val = arg_list->data; + /* TODO: check argument type */ + product = first_val->value.mal_integer; + arg_list = arg_list->next; + + while(arg_list) { + + MalType* val = arg_list->data; + /* TODO: check argument type */ + + product /= (val->value.mal_integer); + arg_list = arg_list->next; + } + } else { + product = 1; + } + result->value.mal_integer = product; + return result; +} diff --git a/impls/c.2/step4_if_fn_do.c b/impls/c.2/step4_if_fn_do.c index 93cdf63e25..c80b8b36b8 100644 --- a/impls/c.2/step4_if_fn_do.c +++ b/impls/c.2/step4_if_fn_do.c @@ -1,490 +1,490 @@ -#include -#include -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" -#include "env.h" -#include "core.h" - -#define SYMBOL_DEFBANG "def!" -#define SYMBOL_LETSTAR "let*" -#define SYMBOL_IF "if" -#define SYMBOL_FNSTAR "fn*" -#define SYMBOL_DO "do" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* ast, Env* env) { - - /* forward references */ - MalType* eval_ast(MalType* ast, Env* env); - MalType* eval_defbang(MalType* ast, Env* env); - MalType* eval_letstar(MalType* ast, Env* env); - MalType* eval_if(MalType* ast, Env* env); - MalType* eval_fnstar(MalType* ast, Env* env); - MalType* eval_do(MalType* ast, Env* env); - - /* NULL */ - if (!ast) { return make_nil(); } - - /* not a list */ - if (!is_list(ast)) { return eval_ast(ast, env); } - - /* empty list */ - if (ast->value.mal_list == NULL) { return ast; } - - /* list */ - MalType* first = (ast->value.mal_list)->data; - char* symbol = first->value.mal_symbol; - - if (is_symbol(first)) { - - /* handle special symbols first */ - if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { - return eval_defbang(ast, env); - } - else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { - return eval_letstar(ast, env); - } - else if (strcmp(symbol, SYMBOL_IF) == 0) { - return eval_if(ast, env); - } - else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { - return eval_fnstar(ast, env); - } - else if (strcmp(symbol, SYMBOL_DO) == 0) { - return eval_do(ast, env); - } - } - /* first element is not a special symbol */ - MalType* evaluated_list = eval_ast(ast, env); - - if (is_error(evaluated_list)) { return evaluated_list; } - - /* apply the first element of the list to the arguments */ - list evlst = evaluated_list->value.mal_list; - MalType* func = evlst->data; - - if (is_function(func)) { - return (*func->value.mal_function)(evlst->next); - } - else if (is_closure(func)) { - - MalClosure* closure = func->value.mal_closure; - list params = (closure->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(evlst->next); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !closure->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - - Env* new_env = env_make(closure->env, params, evlst->next, closure->more_symbol); - return EVAL(closure->definition, new_env); - } - } - else { - return make_error_fmt("Error: first item in list is not callable: %s.", \ - pr_str(func, UNREADABLY)); - } -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str, Env* env) { - - PRINT(EVAL(READ(str), env)); -} - -int main(int argc, char** argv) { - - /* Greeting message */ - puts("Make-a-lisp version 0.0.4\n"); - puts("Press Ctrl+d to exit\n"); - - Env* repl_env = env_make(NULL, NULL, NULL, NULL); - - ns* core = ns_make_core(); - hashmap mappings = core->mappings; - - while (mappings) { - char* symbol = mappings->data; - MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; - - env_set_C_fn(repl_env, symbol, function); - - /* pop symbol and function from hashmap/list */ - mappings = mappings->next->next; - } - - /* add not function */ - /* not using rep as it prints the result */ - EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input, repl_env); - - /* have to release the memory used by readline */ - free(input); - } - - return 0; -} - -MalType* eval_ast(MalType* ast, Env* env) { - - /* forward references */ - list evaluate_list(list lst, Env* env); - list evaluate_vector(list lst, Env* env); - list evaluate_hashmap(list lst, Env* env); - - if (is_symbol(ast)) { - - MalType* symbol_value = env_get(env, ast); - - if (symbol_value) { - return symbol_value; - } else { - return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); - } - } - else if (is_list(ast)) { - - list result = evaluate_list(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_list(result); - } else { - return result->data; - } - } - else if (is_vector(ast)) { - - list result = evaluate_vector(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_vector(result); - } else { - return result->data; - } - } - else if (is_hashmap(ast)) { - - list result = evaluate_hashmap(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_hashmap(result); - } else { - return result->data; - } - } - else { - return ast; - } -} - -MalType* eval_defbang(MalType* ast, Env* env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'def!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'def!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, env); - - if (!is_error(result)){ - env = env_set(env, defbang_symbol, result); - } - return result; -} - -MalType* eval_letstar(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_error("'let*': missing bindings list"); - } - - MalType* bindings = lst->next->data; - MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); - - if (!is_sequential(bindings)) { - return make_error("'let*': first argument is not list or vector"); - } - - list bindings_list = bindings->value.mal_list; - if (list_count(bindings_list) % 2 == 1) { - return make_error("'let*': expected an even number of binding pairs"); - } - - Env* letstar_env = env_make(env, NULL, NULL, NULL); - - /* evaluate the bindings */ - while(bindings_list) { - - MalType* symbol = bindings_list->data; - MalType* value = EVAL(bindings_list->next->data, letstar_env); - - /* early return from error */ - if (is_error(value)) { return value; } - - env_set(letstar_env, symbol, value); - bindings_list = bindings_list->next->next; - } - return EVAL(forms, letstar_env); -} - -MalType* eval_if(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - - if (!lst->next || !lst->next->next) { - return make_error("'if': too few arguments"); - } - - if (lst->next->next->next && lst->next->next->next->next) { - return make_error("'if': too many arguments"); - } - - MalType* condition = EVAL(lst->next->data, env); - - if (is_error(condition)) { return condition; } - - if (is_false(condition) || is_nil(condition)) { - - /* check whether false branch is present */ - if (lst->next->next->next) { - return EVAL(lst->next->next->next->data, env); - } - else { - return make_nil(); - } - - } else { - return EVAL(lst->next->next->data, env); - } -} - -MalType* eval_fnstar(MalType* ast, Env* env) { - - /* forward reference */ - MalType* regularise_parameters(list* params, MalType** more); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_error("'fn*': missing argument list"); - } - else if (!lst->next->next) { - return make_error("'fn*': missing function body"); - } - - MalType* params = lst->next->data; - list params_list = params->value.mal_list; - - MalType* more_symbol = NULL; - - MalType* result = regularise_parameters(¶ms_list, &more_symbol); - if (is_error(result)) { return result; } - - MalType* definition = lst->next->next->data; - MalType* regular_params = make_list(params_list); - - return make_closure(env, regular_params, definition, more_symbol); -} - -MalType* eval_do(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - - /* handle empty 'do' */ - if (!lst->next) { return make_nil(); } - - /* evaluate all but the last form */ - lst = lst->next; - while (lst->next) { - - MalType* val = EVAL(lst->data, env); - - /* return error early */ - if (is_error(val)) { return val; } - lst = lst->next; - } - /* return the last value */ - return EVAL(lst->data, env); -} - -list evaluate_list(list lst, Env* env) { - - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_vector(list lst, Env* env) { - /* TODO: implement a real vector */ - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_hashmap(list lst, Env* env) { - /* TODO: implement a real hashmap */ - list evlst = NULL; - while (lst) { - - /* keys are unevaluated */ - evlst = list_push(evlst, lst->data); - lst = lst->next; - - /* values are evaluated */ - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -MalType* regularise_parameters(list* args, MalType** more_symbol) { - - /* forward reference */ - char* symbol_fn(gptr data); - - list regular_args = NULL; - while (*args) { - - MalType* val = (*args)->data; - - if (!is_symbol(val)) { - return make_error_fmt("non-symbol found in fn argument list '%s'", \ - pr_str(val, UNREADABLY)); - } - - if (val->value.mal_symbol[0] == '&') { - - /* & is found but there is no symbol */ - if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { - return make_error("missing symbol after '&' in argument list"); - } - /* & is found and there is a single symbol after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && - is_symbol((*args)->next->data) && !(*args)->next->next)) { - - /* TODO: check symbol is no a duplicate of one already on the list */ - *more_symbol = (*args)->next->data; - break; - } - /* & is found and there extra symbols after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { - return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ - pr_str((*args)->next->data, UNREADABLY), \ - pr_str((*args)->next->next->data, UNREADABLY)); - } - /* & is found as part of the symbol and no other symbols */ - else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { - *more_symbol = make_symbol((val->value.mal_symbol + 1)); - break; - } - /* & is found as part of the symbol but there are other symbols after */ - else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { - return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ - pr_str(val, UNREADABLY), \ - pr_str((*args)->next->data, UNREADABLY)); - } - } - - /* & is not found - add the symbol to the regular argument list */ - else { - - if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { - return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); - } - else { - regular_args = list_push(regular_args, val); - } - } - *args = (*args)->next; - } - - *args = list_reverse(regular_args); - return make_nil(); -} - -char* symbol_fn(gptr data) { - MalType* val = data; - return (val->value.mal_symbol); -} - -/* silence the compiler after swap!, apply, and map are added to the core */ -MalType* apply(MalType* ast, Env* env) { - return make_nil(); -} +#include +#include +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" +#include "env.h" +#include "core.h" + +#define SYMBOL_DEFBANG "def!" +#define SYMBOL_LETSTAR "let*" +#define SYMBOL_IF "if" +#define SYMBOL_FNSTAR "fn*" +#define SYMBOL_DO "do" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* ast, Env* env) { + + /* forward references */ + MalType* eval_ast(MalType* ast, Env* env); + MalType* eval_defbang(MalType* ast, Env* env); + MalType* eval_letstar(MalType* ast, Env* env); + MalType* eval_if(MalType* ast, Env* env); + MalType* eval_fnstar(MalType* ast, Env* env); + MalType* eval_do(MalType* ast, Env* env); + + /* NULL */ + if (!ast) { return make_nil(); } + + /* not a list */ + if (!is_list(ast)) { return eval_ast(ast, env); } + + /* empty list */ + if (ast->value.mal_list == NULL) { return ast; } + + /* list */ + MalType* first = (ast->value.mal_list)->data; + char* symbol = first->value.mal_symbol; + + if (is_symbol(first)) { + + /* handle special symbols first */ + if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { + return eval_defbang(ast, env); + } + else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { + return eval_letstar(ast, env); + } + else if (strcmp(symbol, SYMBOL_IF) == 0) { + return eval_if(ast, env); + } + else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { + return eval_fnstar(ast, env); + } + else if (strcmp(symbol, SYMBOL_DO) == 0) { + return eval_do(ast, env); + } + } + /* first element is not a special symbol */ + MalType* evaluated_list = eval_ast(ast, env); + + if (is_error(evaluated_list)) { return evaluated_list; } + + /* apply the first element of the list to the arguments */ + list evlst = evaluated_list->value.mal_list; + MalType* func = evlst->data; + + if (is_function(func)) { + return (*func->value.mal_function)(evlst->next); + } + else if (is_closure(func)) { + + MalClosure* closure = func->value.mal_closure; + list params = (closure->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(evlst->next); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !closure->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + + Env* new_env = env_make(closure->env, params, evlst->next, closure->more_symbol); + return EVAL(closure->definition, new_env); + } + } + else { + return make_error_fmt("Error: first item in list is not callable: %s.", \ + pr_str(func, UNREADABLY)); + } +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str, Env* env) { + + PRINT(EVAL(READ(str), env)); +} + +int main(int argc, char** argv) { + + /* Greeting message */ + puts("Make-a-lisp version 0.0.4\n"); + puts("Press Ctrl+d to exit\n"); + + Env* repl_env = env_make(NULL, NULL, NULL, NULL); + + ns* core = ns_make_core(); + hashmap mappings = core->mappings; + + while (mappings) { + char* symbol = mappings->data; + MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; + + env_set_C_fn(repl_env, symbol, function); + + /* pop symbol and function from hashmap/list */ + mappings = mappings->next->next; + } + + /* add not function */ + /* not using rep as it prints the result */ + EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input, repl_env); + + /* have to release the memory used by readline */ + free(input); + } + + return 0; +} + +MalType* eval_ast(MalType* ast, Env* env) { + + /* forward references */ + list evaluate_list(list lst, Env* env); + list evaluate_vector(list lst, Env* env); + list evaluate_hashmap(list lst, Env* env); + + if (is_symbol(ast)) { + + MalType* symbol_value = env_get(env, ast); + + if (symbol_value) { + return symbol_value; + } else { + return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); + } + } + else if (is_list(ast)) { + + list result = evaluate_list(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_list(result); + } else { + return result->data; + } + } + else if (is_vector(ast)) { + + list result = evaluate_vector(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_vector(result); + } else { + return result->data; + } + } + else if (is_hashmap(ast)) { + + list result = evaluate_hashmap(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_hashmap(result); + } else { + return result->data; + } + } + else { + return ast; + } +} + +MalType* eval_defbang(MalType* ast, Env* env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'def!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'def!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, env); + + if (!is_error(result)){ + env = env_set(env, defbang_symbol, result); + } + return result; +} + +MalType* eval_letstar(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_error("'let*': missing bindings list"); + } + + MalType* bindings = lst->next->data; + MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); + + if (!is_sequential(bindings)) { + return make_error("'let*': first argument is not list or vector"); + } + + list bindings_list = bindings->value.mal_list; + if (list_count(bindings_list) % 2 == 1) { + return make_error("'let*': expected an even number of binding pairs"); + } + + Env* letstar_env = env_make(env, NULL, NULL, NULL); + + /* evaluate the bindings */ + while(bindings_list) { + + MalType* symbol = bindings_list->data; + MalType* value = EVAL(bindings_list->next->data, letstar_env); + + /* early return from error */ + if (is_error(value)) { return value; } + + env_set(letstar_env, symbol, value); + bindings_list = bindings_list->next->next; + } + return EVAL(forms, letstar_env); +} + +MalType* eval_if(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + + if (!lst->next || !lst->next->next) { + return make_error("'if': too few arguments"); + } + + if (lst->next->next->next && lst->next->next->next->next) { + return make_error("'if': too many arguments"); + } + + MalType* condition = EVAL(lst->next->data, env); + + if (is_error(condition)) { return condition; } + + if (is_false(condition) || is_nil(condition)) { + + /* check whether false branch is present */ + if (lst->next->next->next) { + return EVAL(lst->next->next->next->data, env); + } + else { + return make_nil(); + } + + } else { + return EVAL(lst->next->next->data, env); + } +} + +MalType* eval_fnstar(MalType* ast, Env* env) { + + /* forward reference */ + MalType* regularise_parameters(list* params, MalType** more); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_error("'fn*': missing argument list"); + } + else if (!lst->next->next) { + return make_error("'fn*': missing function body"); + } + + MalType* params = lst->next->data; + list params_list = params->value.mal_list; + + MalType* more_symbol = NULL; + + MalType* result = regularise_parameters(¶ms_list, &more_symbol); + if (is_error(result)) { return result; } + + MalType* definition = lst->next->next->data; + MalType* regular_params = make_list(params_list); + + return make_closure(env, regular_params, definition, more_symbol); +} + +MalType* eval_do(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + + /* handle empty 'do' */ + if (!lst->next) { return make_nil(); } + + /* evaluate all but the last form */ + lst = lst->next; + while (lst->next) { + + MalType* val = EVAL(lst->data, env); + + /* return error early */ + if (is_error(val)) { return val; } + lst = lst->next; + } + /* return the last value */ + return EVAL(lst->data, env); +} + +list evaluate_list(list lst, Env* env) { + + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_vector(list lst, Env* env) { + /* TODO: implement a real vector */ + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_hashmap(list lst, Env* env) { + /* TODO: implement a real hashmap */ + list evlst = NULL; + while (lst) { + + /* keys are unevaluated */ + evlst = list_push(evlst, lst->data); + lst = lst->next; + + /* values are evaluated */ + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +MalType* regularise_parameters(list* args, MalType** more_symbol) { + + /* forward reference */ + char* symbol_fn(gptr data); + + list regular_args = NULL; + while (*args) { + + MalType* val = (*args)->data; + + if (!is_symbol(val)) { + return make_error_fmt("non-symbol found in fn argument list '%s'", \ + pr_str(val, UNREADABLY)); + } + + if (val->value.mal_symbol[0] == '&') { + + /* & is found but there is no symbol */ + if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { + return make_error("missing symbol after '&' in argument list"); + } + /* & is found and there is a single symbol after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && + is_symbol((*args)->next->data) && !(*args)->next->next)) { + + /* TODO: check symbol is no a duplicate of one already on the list */ + *more_symbol = (*args)->next->data; + break; + } + /* & is found and there extra symbols after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { + return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ + pr_str((*args)->next->data, UNREADABLY), \ + pr_str((*args)->next->next->data, UNREADABLY)); + } + /* & is found as part of the symbol and no other symbols */ + else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { + *more_symbol = make_symbol((val->value.mal_symbol + 1)); + break; + } + /* & is found as part of the symbol but there are other symbols after */ + else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { + return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ + pr_str(val, UNREADABLY), \ + pr_str((*args)->next->data, UNREADABLY)); + } + } + + /* & is not found - add the symbol to the regular argument list */ + else { + + if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { + return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); + } + else { + regular_args = list_push(regular_args, val); + } + } + *args = (*args)->next; + } + + *args = list_reverse(regular_args); + return make_nil(); +} + +char* symbol_fn(gptr data) { + MalType* val = data; + return (val->value.mal_symbol); +} + +/* silence the compiler after swap!, apply, and map are added to the core */ +MalType* apply(MalType* ast, Env* env) { + return make_nil(); +} diff --git a/impls/c.2/step5_tco.c b/impls/c.2/step5_tco.c index 78fbf40535..9f31fbc891 100644 --- a/impls/c.2/step5_tco.c +++ b/impls/c.2/step5_tco.c @@ -1,532 +1,532 @@ -#include -#include -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" -#include "env.h" -#include "core.h" - -#define SYMBOL_DEFBANG "def!" -#define SYMBOL_LETSTAR "let*" -#define SYMBOL_IF "if" -#define SYMBOL_FNSTAR "fn*" -#define SYMBOL_DO "do" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* ast, Env* env) { - - /* forward references */ - MalType* eval_ast(MalType* ast, Env* env); - MalType* eval_defbang(MalType* ast, Env** env); - void eval_letstar(MalType** ast, Env** env); - void eval_if(MalType** ast, Env** env); - MalType* eval_fnstar(MalType* ast, Env* env); - MalType* eval_do(MalType* ast, Env* env); - - /* Use goto to jump here rather than calling eval for tail-call elimination */ - TCE_entry_point: - - /* NULL */ - if (!ast) { return make_nil(); } - - /* not a list */ - if (!is_list(ast)) { return eval_ast(ast, env); } - - /* empty list */ - if (ast->value.mal_list == NULL) { return ast; } - - /* list */ - MalType* first = (ast->value.mal_list)->data; - char* symbol = first->value.mal_symbol; - - if (is_symbol(first)) { - - /* handle special symbols first */ - if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { - return eval_defbang(ast, &env); - } - else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - eval_letstar(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_IF) == 0) { - - /* TCE - modify ast directly and jump back to eval */ - eval_if(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { - return eval_fnstar(ast, env); - } - else if (strcmp(symbol, SYMBOL_DO) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - ast = eval_do(ast, env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - } - /* first element is not a special symbol */ - MalType* evaluated_list = eval_ast(ast, env); - - /* apply the first element of the list to the arguments */ - list evlst = evaluated_list->value.mal_list; - MalType* func = evlst->data; - - if (is_function(func)) { - return (*func->value.mal_function)(evlst->next); - } - else if (is_closure(func)) { - - MalClosure* closure = func->value.mal_closure; - list params = (closure->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(evlst->next); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !closure->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - - /* TCE - modify ast and env directly and jump back to eval */ - env = env_make(closure->env, params, evlst->next, closure->more_symbol); - ast = func->value.mal_closure->definition; - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - } - else { - return make_error_fmt("first item in list is not callable: '%s'", \ - pr_str(func, UNREADABLY)); - } -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str, Env* env) { - - PRINT(EVAL(READ(str), env)); -} - -int main(int argc, char** argv) { - - /* Greeting message */ - puts("Make-a-lisp version 0.0.5\n"); - puts("Press Ctrl+d to exit\n"); - - Env* repl_env = env_make(NULL, NULL, NULL, NULL); - - ns* core = ns_make_core(); - hashmap mappings = core->mappings; - - while (mappings) { - char* symbol = mappings->data; - MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; - - env_set_C_fn(repl_env, symbol, function); - - /* pop symbol and function from hashmap/list */ - mappings = mappings->next->next; - } - - /* add not function */ - /* not using rep as it prints the result */ - EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input, repl_env); - - /* have to release the memory used by readline */ - free(input); - } - - return 0; -} - -MalType* eval_ast(MalType* ast, Env* env) { - - /* forward references */ - list evaluate_list(list lst, Env* env); - list evaluate_vector(list lst, Env* env); - list evaluate_hashmap(list lst, Env* env); - - if (is_symbol(ast)) { - - MalType* symbol_value = env_get(env, ast); - - if (symbol_value) { - return symbol_value; - } else { - return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); - } - } - else if (is_list(ast)) { - - list result = evaluate_list(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_list(result); - } else { - return result->data; - } - } - else if (is_vector(ast)) { - - list result = evaluate_vector(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_vector(result); - } else { - return result->data; - } - } - else if (is_hashmap(ast)) { - - list result = evaluate_hashmap(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_hashmap(result); - } else { - return result->data; - } - } - else { - return ast; - } -} - -MalType* eval_defbang(MalType* ast, Env** env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'def!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'def!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, *env); - - if (!is_error(result)){ - *env = env_set(*env, defbang_symbol, result); - } - return result; -} - -void eval_letstar(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next) { - *ast = make_error("'let*': missing bindings list"); - return; - } - - MalType* bindings = lst->next->data; - MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); - - if (!is_sequential(bindings)) { - *ast = make_error("'let*': first argument is not list or vector"); - return; - } - - list bindings_list = bindings->value.mal_list; - if (list_count(bindings_list) % 2 == 1) { - *ast = make_error("'let*': expected an even number of binding pairs"); - return; - } - - Env* letstar_env = env_make(*env, NULL, NULL, NULL); - - /* evaluate the bindings */ - while(bindings_list) { - - MalType* symbol = bindings_list->data; - MalType* value = EVAL(bindings_list->next->data, letstar_env); - - /* early return from error */ - if (is_error(value)) { - *ast = value; - return; - } - - env_set(letstar_env, symbol, value); - bindings_list = bindings_list->next->next; - } - - *env = letstar_env; - *ast = forms; - return; -} - -void eval_if(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next || !lst->next->next) { - *ast = make_error("'if': too few arguments"); - return; - } - - if (lst->next->next->next && lst->next->next->next->next) { - *ast = make_error("'if': too many arguments"); - return; - } - - MalType* condition = EVAL(lst->next->data, *env); - - if (is_error(condition)) { - *ast = condition; - return; - } - - if (is_false(condition) || is_nil(condition)) { - - /* check whether false branch is present */ - if (lst->next->next->next) { - *ast = lst->next->next->next->data; - return; - } - else { - *ast = make_nil(); - return; - } - - } else { - *ast = lst->next->next->data; - return; - } -} - -MalType* eval_fnstar(MalType* ast, Env* env) { - - /* forward reference */ - MalType* regularise_parameters(list* params, MalType** more); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_error("'fn*': missing argument list"); - } - else if (!lst->next->next) { - return make_error("'fn*': missing function body"); - } - - MalType* params = lst->next->data; - list params_list = params->value.mal_list; - - MalType* more_symbol = NULL; - - MalType* result = regularise_parameters(¶ms_list, &more_symbol); - if (is_error(result)) { return result; } - - MalType* definition = lst->next->next->data; - MalType* regular_params = make_list(params_list); - - return make_closure(env, regular_params, definition, more_symbol); -} - -MalType* eval_do(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - - /* handle empty 'do' */ - if (!lst->next) { - return make_nil(); - } - - /* evaluate all but the last form */ - lst = lst->next; - while (lst->next) { - - MalType* val = EVAL(lst->data, env); - - /* return error early */ - if (is_error(val)) { - return val; - } - lst = lst->next; - } - /* return the last form for TCE evaluation */ - return lst->data; -} - -list evaluate_list(list lst, Env* env) { - - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_vector(list lst, Env* env) { - /* TODO: implement a real vector */ - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_hashmap(list lst, Env* env) { - /* TODO: implement a real hashmap */ - list evlst = NULL; - while (lst) { - - /* keys are unevaluated */ - evlst = list_push(evlst, lst->data); - lst = lst->next; - - /* values are evaluated */ - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -MalType* regularise_parameters(list* args, MalType** more_symbol) { - - /* forward reference */ - char* symbol_fn(gptr data); - - list regular_args = NULL; - while (*args) { - - MalType* val = (*args)->data; - - if (!is_symbol(val)) { - return make_error_fmt("non-symbol found in fn argument list '%s'", \ - pr_str(val, UNREADABLY)); - } - - if (val->value.mal_symbol[0] == '&') { - - /* & is found but there is no symbol */ - if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { - return make_error("missing symbol after '&' in argument list"); - } - /* & is found and there is a single symbol after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && - is_symbol((*args)->next->data) && !(*args)->next->next)) { - - /* TODO: check symbol is no a duplicate of one already on the list */ - *more_symbol = (*args)->next->data; - break; - } - /* & is found and there extra symbols after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { - return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ - pr_str((*args)->next->data, UNREADABLY), \ - pr_str((*args)->next->next->data, UNREADABLY)); - } - /* & is found as part of the symbol and no other symbols */ - else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { - *more_symbol = make_symbol((val->value.mal_symbol + 1)); - break; - } - /* & is found as part of the symbol but there are other symbols after */ - else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { - return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ - pr_str(val, UNREADABLY), \ - pr_str((*args)->next->data, UNREADABLY)); - } - } - - /* & is not found - add the symbol to the regular argument list */ - else { - - if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { - return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); - } - else { - regular_args = list_push(regular_args, val); - } - } - *args = (*args)->next; - } - - *args = list_reverse(regular_args); - return make_nil(); -} - -char* symbol_fn(gptr data) { - MalType* val = data; - return (val->value.mal_symbol); -} - -/* silence the compiler after swap!, apply, and map - are added to the core */ -MalType* apply(MalType* ast, Env* env) { - return make_nil(); -} +#include +#include +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" +#include "env.h" +#include "core.h" + +#define SYMBOL_DEFBANG "def!" +#define SYMBOL_LETSTAR "let*" +#define SYMBOL_IF "if" +#define SYMBOL_FNSTAR "fn*" +#define SYMBOL_DO "do" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* ast, Env* env) { + + /* forward references */ + MalType* eval_ast(MalType* ast, Env* env); + MalType* eval_defbang(MalType* ast, Env** env); + void eval_letstar(MalType** ast, Env** env); + void eval_if(MalType** ast, Env** env); + MalType* eval_fnstar(MalType* ast, Env* env); + MalType* eval_do(MalType* ast, Env* env); + + /* Use goto to jump here rather than calling eval for tail-call elimination */ + TCE_entry_point: + + /* NULL */ + if (!ast) { return make_nil(); } + + /* not a list */ + if (!is_list(ast)) { return eval_ast(ast, env); } + + /* empty list */ + if (ast->value.mal_list == NULL) { return ast; } + + /* list */ + MalType* first = (ast->value.mal_list)->data; + char* symbol = first->value.mal_symbol; + + if (is_symbol(first)) { + + /* handle special symbols first */ + if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { + return eval_defbang(ast, &env); + } + else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + eval_letstar(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_IF) == 0) { + + /* TCE - modify ast directly and jump back to eval */ + eval_if(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { + return eval_fnstar(ast, env); + } + else if (strcmp(symbol, SYMBOL_DO) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + ast = eval_do(ast, env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + } + /* first element is not a special symbol */ + MalType* evaluated_list = eval_ast(ast, env); + + /* apply the first element of the list to the arguments */ + list evlst = evaluated_list->value.mal_list; + MalType* func = evlst->data; + + if (is_function(func)) { + return (*func->value.mal_function)(evlst->next); + } + else if (is_closure(func)) { + + MalClosure* closure = func->value.mal_closure; + list params = (closure->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(evlst->next); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !closure->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + + /* TCE - modify ast and env directly and jump back to eval */ + env = env_make(closure->env, params, evlst->next, closure->more_symbol); + ast = func->value.mal_closure->definition; + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + } + else { + return make_error_fmt("first item in list is not callable: '%s'", \ + pr_str(func, UNREADABLY)); + } +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str, Env* env) { + + PRINT(EVAL(READ(str), env)); +} + +int main(int argc, char** argv) { + + /* Greeting message */ + puts("Make-a-lisp version 0.0.5\n"); + puts("Press Ctrl+d to exit\n"); + + Env* repl_env = env_make(NULL, NULL, NULL, NULL); + + ns* core = ns_make_core(); + hashmap mappings = core->mappings; + + while (mappings) { + char* symbol = mappings->data; + MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; + + env_set_C_fn(repl_env, symbol, function); + + /* pop symbol and function from hashmap/list */ + mappings = mappings->next->next; + } + + /* add not function */ + /* not using rep as it prints the result */ + EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input, repl_env); + + /* have to release the memory used by readline */ + free(input); + } + + return 0; +} + +MalType* eval_ast(MalType* ast, Env* env) { + + /* forward references */ + list evaluate_list(list lst, Env* env); + list evaluate_vector(list lst, Env* env); + list evaluate_hashmap(list lst, Env* env); + + if (is_symbol(ast)) { + + MalType* symbol_value = env_get(env, ast); + + if (symbol_value) { + return symbol_value; + } else { + return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); + } + } + else if (is_list(ast)) { + + list result = evaluate_list(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_list(result); + } else { + return result->data; + } + } + else if (is_vector(ast)) { + + list result = evaluate_vector(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_vector(result); + } else { + return result->data; + } + } + else if (is_hashmap(ast)) { + + list result = evaluate_hashmap(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_hashmap(result); + } else { + return result->data; + } + } + else { + return ast; + } +} + +MalType* eval_defbang(MalType* ast, Env** env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'def!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'def!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, *env); + + if (!is_error(result)){ + *env = env_set(*env, defbang_symbol, result); + } + return result; +} + +void eval_letstar(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next) { + *ast = make_error("'let*': missing bindings list"); + return; + } + + MalType* bindings = lst->next->data; + MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); + + if (!is_sequential(bindings)) { + *ast = make_error("'let*': first argument is not list or vector"); + return; + } + + list bindings_list = bindings->value.mal_list; + if (list_count(bindings_list) % 2 == 1) { + *ast = make_error("'let*': expected an even number of binding pairs"); + return; + } + + Env* letstar_env = env_make(*env, NULL, NULL, NULL); + + /* evaluate the bindings */ + while(bindings_list) { + + MalType* symbol = bindings_list->data; + MalType* value = EVAL(bindings_list->next->data, letstar_env); + + /* early return from error */ + if (is_error(value)) { + *ast = value; + return; + } + + env_set(letstar_env, symbol, value); + bindings_list = bindings_list->next->next; + } + + *env = letstar_env; + *ast = forms; + return; +} + +void eval_if(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next || !lst->next->next) { + *ast = make_error("'if': too few arguments"); + return; + } + + if (lst->next->next->next && lst->next->next->next->next) { + *ast = make_error("'if': too many arguments"); + return; + } + + MalType* condition = EVAL(lst->next->data, *env); + + if (is_error(condition)) { + *ast = condition; + return; + } + + if (is_false(condition) || is_nil(condition)) { + + /* check whether false branch is present */ + if (lst->next->next->next) { + *ast = lst->next->next->next->data; + return; + } + else { + *ast = make_nil(); + return; + } + + } else { + *ast = lst->next->next->data; + return; + } +} + +MalType* eval_fnstar(MalType* ast, Env* env) { + + /* forward reference */ + MalType* regularise_parameters(list* params, MalType** more); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_error("'fn*': missing argument list"); + } + else if (!lst->next->next) { + return make_error("'fn*': missing function body"); + } + + MalType* params = lst->next->data; + list params_list = params->value.mal_list; + + MalType* more_symbol = NULL; + + MalType* result = regularise_parameters(¶ms_list, &more_symbol); + if (is_error(result)) { return result; } + + MalType* definition = lst->next->next->data; + MalType* regular_params = make_list(params_list); + + return make_closure(env, regular_params, definition, more_symbol); +} + +MalType* eval_do(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + + /* handle empty 'do' */ + if (!lst->next) { + return make_nil(); + } + + /* evaluate all but the last form */ + lst = lst->next; + while (lst->next) { + + MalType* val = EVAL(lst->data, env); + + /* return error early */ + if (is_error(val)) { + return val; + } + lst = lst->next; + } + /* return the last form for TCE evaluation */ + return lst->data; +} + +list evaluate_list(list lst, Env* env) { + + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_vector(list lst, Env* env) { + /* TODO: implement a real vector */ + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_hashmap(list lst, Env* env) { + /* TODO: implement a real hashmap */ + list evlst = NULL; + while (lst) { + + /* keys are unevaluated */ + evlst = list_push(evlst, lst->data); + lst = lst->next; + + /* values are evaluated */ + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +MalType* regularise_parameters(list* args, MalType** more_symbol) { + + /* forward reference */ + char* symbol_fn(gptr data); + + list regular_args = NULL; + while (*args) { + + MalType* val = (*args)->data; + + if (!is_symbol(val)) { + return make_error_fmt("non-symbol found in fn argument list '%s'", \ + pr_str(val, UNREADABLY)); + } + + if (val->value.mal_symbol[0] == '&') { + + /* & is found but there is no symbol */ + if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { + return make_error("missing symbol after '&' in argument list"); + } + /* & is found and there is a single symbol after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && + is_symbol((*args)->next->data) && !(*args)->next->next)) { + + /* TODO: check symbol is no a duplicate of one already on the list */ + *more_symbol = (*args)->next->data; + break; + } + /* & is found and there extra symbols after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { + return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ + pr_str((*args)->next->data, UNREADABLY), \ + pr_str((*args)->next->next->data, UNREADABLY)); + } + /* & is found as part of the symbol and no other symbols */ + else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { + *more_symbol = make_symbol((val->value.mal_symbol + 1)); + break; + } + /* & is found as part of the symbol but there are other symbols after */ + else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { + return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ + pr_str(val, UNREADABLY), \ + pr_str((*args)->next->data, UNREADABLY)); + } + } + + /* & is not found - add the symbol to the regular argument list */ + else { + + if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { + return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); + } + else { + regular_args = list_push(regular_args, val); + } + } + *args = (*args)->next; + } + + *args = list_reverse(regular_args); + return make_nil(); +} + +char* symbol_fn(gptr data) { + MalType* val = data; + return (val->value.mal_symbol); +} + +/* silence the compiler after swap!, apply, and map + are added to the core */ +MalType* apply(MalType* ast, Env* env) { + return make_nil(); +} diff --git a/impls/c.2/step6_file.c b/impls/c.2/step6_file.c index 4e73fb78b2..249d81cb19 100644 --- a/impls/c.2/step6_file.c +++ b/impls/c.2/step6_file.c @@ -1,586 +1,586 @@ -#include -#include -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" -#include "env.h" -#include "core.h" - -#define SYMBOL_DEFBANG "def!" -#define SYMBOL_LETSTAR "let*" -#define SYMBOL_IF "if" -#define SYMBOL_FNSTAR "fn*" -#define SYMBOL_DO "do" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* ast, Env* env) { - - /* forward references */ - MalType* eval_ast(MalType* ast, Env* env); - MalType* eval_defbang(MalType* ast, Env** env); - void eval_letstar(MalType** ast, Env** env); - void eval_if(MalType** ast, Env** env); - MalType* eval_fnstar(MalType* ast, Env* env); - MalType* eval_do(MalType* ast, Env* env); - - /* Use goto to jump here rather than calling eval for tail-call elimination */ - TCE_entry_point: - - /* NULL */ - if (!ast) { return make_nil(); } - - /* not a list */ - if (!is_list(ast)) { return eval_ast(ast, env); } - - /* empty list */ - if (ast->value.mal_list == NULL) { return ast; } - - /* list */ - MalType* first = (ast->value.mal_list)->data; - char* symbol = first->value.mal_symbol; - - if (is_symbol(first)) { - - /* handle special symbols first */ - if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { - return eval_defbang(ast, &env); - } - else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - eval_letstar(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_DO) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - ast = eval_do(ast, env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_IF) == 0) { - - /* TCE - modify ast directly and jump back to eval */ - eval_if(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { - return eval_fnstar(ast, env); - } - } - /* first element is not a special symbol */ - MalType* evaluated_list = eval_ast(ast, env); - - if (is_error(evaluated_list)) { return evaluated_list; } - - /* apply the first element of the list to the arguments */ - list evlst = evaluated_list->value.mal_list; - MalType* func = evlst->data; - - if (is_function(func)) { - return (*func->value.mal_function)(evlst->next); - } - else if (is_closure(func)) { - - MalClosure* closure = func->value.mal_closure; - list params = (closure->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(evlst->next); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !closure->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - - /* TCE - modify ast and env directly and jump back to eval */ - env = env_make(closure->env, params, evlst->next, closure->more_symbol); - ast = func->value.mal_closure->definition; - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - } - else { - return make_error_fmt("first item in list is not callable: '%s'", \ - pr_str(func, UNREADABLY)); - } -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str, Env* env) { - - PRINT(EVAL(READ(str), env)); -} - -/* declare as global so it can be accessed by mal_eval */ -Env* global_env; - -MalType* mal_eval(list args) { - - MalType* ast = args->data; - return EVAL(ast, global_env); -} - -int main(int argc, char** argv) { - - Env* repl_env = env_make(NULL, NULL, NULL, NULL); - global_env = repl_env; - - ns* core = ns_make_core(); - hashmap mappings = core->mappings; - - while (mappings) { - char* symbol = mappings->data; - MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; - - env_set_C_fn(repl_env, symbol, function); - - /* pop symbol and function from hashmap/list */ - mappings = mappings->next->next; - } - - env_set_C_fn(repl_env, "eval", mal_eval); - - /* add functions written in mal - not using rep as it prints the result */ - EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); - EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); - - - /* make command line arguments available in the environment */ - list lst = NULL; - for (int i = 2; i < argc; i++) { - lst = list_push(lst, make_string(argv[i])); - } - env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); - - /* run in script mode if a filename is given */ - if (argc > 1) { - - /* first argument on command line is filename */ - char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); - EVAL(READ(load_command), repl_env); - } - /* run in repl mode when no cmd line args */ - else { - - /* Greeting message */ - puts("Make-a-lisp version 0.0.6\n"); - puts("Press Ctrl+d to exit\n"); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input, repl_env); - - /* have to release the memory used by readline */ - free(input); - } - } - return 0; -} - -MalType* eval_ast(MalType* ast, Env* env) { - - /* forward references */ - list evaluate_list(list lst, Env* env); - list evaluate_vector(list lst, Env* env); - list evaluate_hashmap(list lst, Env* env); - - if (is_symbol(ast)) { - - MalType* symbol_value = env_get(env, ast); - - if (symbol_value) { - return symbol_value; - } else { - return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); - } - } - else if (is_list(ast)) { - - list result = evaluate_list(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_list(result); - } else { - return result->data; - } - } - else if (is_vector(ast)) { - - list result = evaluate_vector(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_vector(result); - } else { - return result->data; - } - } - else if (is_hashmap(ast)) { - - list result = evaluate_hashmap(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_hashmap(result); - } else { - return result->data; - } - } - else { - return ast; - } -} - -MalType* eval_defbang(MalType* ast, Env** env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'def!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'def!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, *env); - - if (!is_error(result)){ - *env = env_set(*env, defbang_symbol, result); - } - return result; -} - -void eval_letstar(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next) { - *ast = make_error("'let*': missing bindings list"); - return; - } - - MalType* bindings = lst->next->data; - MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); - - if (!is_sequential(bindings)) { - *ast = make_error("'let*': first argument is not list or vector"); - return; - } - - list bindings_list = bindings->value.mal_list; - if (list_count(bindings_list) % 2 == 1) { - *ast = make_error("'let*': expected an even number of binding pairs"); - return; - } - - Env* letstar_env = env_make(*env, NULL, NULL, NULL); - - /* evaluate the bindings */ - while(bindings_list) { - - MalType* symbol = bindings_list->data; - MalType* value = EVAL(bindings_list->next->data, letstar_env); - - /* early return from error */ - if (is_error(value)) { - *ast = value; - return; - } - - env_set(letstar_env, symbol, value); - bindings_list = bindings_list->next->next; - } - - *env = letstar_env; - *ast = forms; - return; -} - -void eval_if(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next || !lst->next->next) { - *ast = make_error("'if': too few arguments"); - return; - } - - if (lst->next->next->next && lst->next->next->next->next) { - *ast = make_error("'if': too many arguments"); - return; - } - - MalType* condition = EVAL(lst->next->data, *env); - - if (is_error(condition)) { - *ast = condition; - return; - } - - if (is_false(condition) || is_nil(condition)) { - - /* check whether false branch is present */ - if (lst->next->next->next) { - *ast = lst->next->next->next->data; - return; - } - else { - *ast = make_nil(); - return; - } - - } else { - *ast = lst->next->next->data; - return; - } -} - -MalType* eval_fnstar(MalType* ast, Env* env) { - - /* forward reference */ - MalType* regularise_parameters(list* params, MalType** more); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_error("'fn*': missing argument list"); - } - else if (!lst->next->next) { - return make_error("'fn*': missing function body"); - } - - MalType* params = lst->next->data; - list params_list = params->value.mal_list; - - MalType* more_symbol = NULL; - - MalType* result = regularise_parameters(¶ms_list, &more_symbol); - if (is_error(result)) { return result; } - - MalType* definition = lst->next->next->data; - MalType* regular_params = make_list(params_list); - - return make_closure(env, regular_params, definition, more_symbol); -} - -MalType* eval_do(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - - /* handle empty 'do' */ - if (!lst->next) { - return make_nil(); - } - - /* evaluate all but the last form */ - lst = lst->next; - while (lst->next) { - - MalType* val = EVAL(lst->data, env); - - /* return error early */ - if (is_error(val)) { - return val; - } - lst = lst->next; - } - /* return the last form for TCE evaluation */ - return lst->data; -} - -list evaluate_list(list lst, Env* env) { - - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_vector(list lst, Env* env) { - /* TODO: implement a real vector */ - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_hashmap(list lst, Env* env) { - /* TODO: implement a real hashmap */ - list evlst = NULL; - while (lst) { - - /* keys are unevaluated */ - evlst = list_push(evlst, lst->data); - lst = lst->next; - - /* values are evaluated */ - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -MalType* regularise_parameters(list* args, MalType** more_symbol) { - - /* forward reference */ - char* symbol_fn(gptr data); - - list regular_args = NULL; - while (*args) { - - MalType* val = (*args)->data; - - if (!is_symbol(val)) { - return make_error_fmt("non-symbol found in fn argument list '%s'", \ - pr_str(val, UNREADABLY)); - } - - if (val->value.mal_symbol[0] == '&') { - - /* & is found but there is no symbol */ - if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { - return make_error("missing symbol after '&' in argument list"); - } - /* & is found and there is a single symbol after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && - is_symbol((*args)->next->data) && !(*args)->next->next)) { - - /* TODO: check symbol is no a duplicate of one already on the list */ - *more_symbol = (*args)->next->data; - break; - } - /* & is found and there extra symbols after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { - return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ - pr_str((*args)->next->data, UNREADABLY), \ - pr_str((*args)->next->next->data, UNREADABLY)); - } - /* & is found as part of the symbol and no other symbols */ - else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { - *more_symbol = make_symbol((val->value.mal_symbol + 1)); - break; - } - /* & is found as part of the symbol but there are other symbols after */ - else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { - return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ - pr_str(val, UNREADABLY), \ - pr_str((*args)->next->data, UNREADABLY)); - } - } - - /* & is not found - add the symbol to the regular argument list */ - else { - - if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { - return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); - } - else { - regular_args = list_push(regular_args, val); - } - } - *args = (*args)->next; - } - - *args = list_reverse(regular_args); - return make_nil(); -} - -char* symbol_fn(gptr data) { - return (((MalType*)data)->value.mal_symbol); -} - -/* used by core functions but not EVAL as doesn't do TCE */ -MalType* apply(MalType* fn, list args) { - - if (is_function(fn)) { - - MalType* (*fun_ptr)(list) = fn->value.mal_function; - return (*fun_ptr)(args); - } - else { /* is_closure(fn) */ - - MalClosure* c = fn->value.mal_closure; - list params = (c->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(args); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !c->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - Env* env = env_make(c->env, params, args, c->more_symbol); - return EVAL(fn->value.mal_closure->definition, env); - } - } -} +#include +#include +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" +#include "env.h" +#include "core.h" + +#define SYMBOL_DEFBANG "def!" +#define SYMBOL_LETSTAR "let*" +#define SYMBOL_IF "if" +#define SYMBOL_FNSTAR "fn*" +#define SYMBOL_DO "do" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* ast, Env* env) { + + /* forward references */ + MalType* eval_ast(MalType* ast, Env* env); + MalType* eval_defbang(MalType* ast, Env** env); + void eval_letstar(MalType** ast, Env** env); + void eval_if(MalType** ast, Env** env); + MalType* eval_fnstar(MalType* ast, Env* env); + MalType* eval_do(MalType* ast, Env* env); + + /* Use goto to jump here rather than calling eval for tail-call elimination */ + TCE_entry_point: + + /* NULL */ + if (!ast) { return make_nil(); } + + /* not a list */ + if (!is_list(ast)) { return eval_ast(ast, env); } + + /* empty list */ + if (ast->value.mal_list == NULL) { return ast; } + + /* list */ + MalType* first = (ast->value.mal_list)->data; + char* symbol = first->value.mal_symbol; + + if (is_symbol(first)) { + + /* handle special symbols first */ + if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { + return eval_defbang(ast, &env); + } + else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + eval_letstar(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_DO) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + ast = eval_do(ast, env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_IF) == 0) { + + /* TCE - modify ast directly and jump back to eval */ + eval_if(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { + return eval_fnstar(ast, env); + } + } + /* first element is not a special symbol */ + MalType* evaluated_list = eval_ast(ast, env); + + if (is_error(evaluated_list)) { return evaluated_list; } + + /* apply the first element of the list to the arguments */ + list evlst = evaluated_list->value.mal_list; + MalType* func = evlst->data; + + if (is_function(func)) { + return (*func->value.mal_function)(evlst->next); + } + else if (is_closure(func)) { + + MalClosure* closure = func->value.mal_closure; + list params = (closure->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(evlst->next); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !closure->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + + /* TCE - modify ast and env directly and jump back to eval */ + env = env_make(closure->env, params, evlst->next, closure->more_symbol); + ast = func->value.mal_closure->definition; + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + } + else { + return make_error_fmt("first item in list is not callable: '%s'", \ + pr_str(func, UNREADABLY)); + } +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str, Env* env) { + + PRINT(EVAL(READ(str), env)); +} + +/* declare as global so it can be accessed by mal_eval */ +Env* global_env; + +MalType* mal_eval(list args) { + + MalType* ast = args->data; + return EVAL(ast, global_env); +} + +int main(int argc, char** argv) { + + Env* repl_env = env_make(NULL, NULL, NULL, NULL); + global_env = repl_env; + + ns* core = ns_make_core(); + hashmap mappings = core->mappings; + + while (mappings) { + char* symbol = mappings->data; + MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; + + env_set_C_fn(repl_env, symbol, function); + + /* pop symbol and function from hashmap/list */ + mappings = mappings->next->next; + } + + env_set_C_fn(repl_env, "eval", mal_eval); + + /* add functions written in mal - not using rep as it prints the result */ + EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); + EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); + + + /* make command line arguments available in the environment */ + list lst = NULL; + for (int i = 2; i < argc; i++) { + lst = list_push(lst, make_string(argv[i])); + } + env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); + + /* run in script mode if a filename is given */ + if (argc > 1) { + + /* first argument on command line is filename */ + char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); + EVAL(READ(load_command), repl_env); + } + /* run in repl mode when no cmd line args */ + else { + + /* Greeting message */ + puts("Make-a-lisp version 0.0.6\n"); + puts("Press Ctrl+d to exit\n"); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input, repl_env); + + /* have to release the memory used by readline */ + free(input); + } + } + return 0; +} + +MalType* eval_ast(MalType* ast, Env* env) { + + /* forward references */ + list evaluate_list(list lst, Env* env); + list evaluate_vector(list lst, Env* env); + list evaluate_hashmap(list lst, Env* env); + + if (is_symbol(ast)) { + + MalType* symbol_value = env_get(env, ast); + + if (symbol_value) { + return symbol_value; + } else { + return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); + } + } + else if (is_list(ast)) { + + list result = evaluate_list(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_list(result); + } else { + return result->data; + } + } + else if (is_vector(ast)) { + + list result = evaluate_vector(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_vector(result); + } else { + return result->data; + } + } + else if (is_hashmap(ast)) { + + list result = evaluate_hashmap(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_hashmap(result); + } else { + return result->data; + } + } + else { + return ast; + } +} + +MalType* eval_defbang(MalType* ast, Env** env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'def!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'def!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, *env); + + if (!is_error(result)){ + *env = env_set(*env, defbang_symbol, result); + } + return result; +} + +void eval_letstar(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next) { + *ast = make_error("'let*': missing bindings list"); + return; + } + + MalType* bindings = lst->next->data; + MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); + + if (!is_sequential(bindings)) { + *ast = make_error("'let*': first argument is not list or vector"); + return; + } + + list bindings_list = bindings->value.mal_list; + if (list_count(bindings_list) % 2 == 1) { + *ast = make_error("'let*': expected an even number of binding pairs"); + return; + } + + Env* letstar_env = env_make(*env, NULL, NULL, NULL); + + /* evaluate the bindings */ + while(bindings_list) { + + MalType* symbol = bindings_list->data; + MalType* value = EVAL(bindings_list->next->data, letstar_env); + + /* early return from error */ + if (is_error(value)) { + *ast = value; + return; + } + + env_set(letstar_env, symbol, value); + bindings_list = bindings_list->next->next; + } + + *env = letstar_env; + *ast = forms; + return; +} + +void eval_if(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next || !lst->next->next) { + *ast = make_error("'if': too few arguments"); + return; + } + + if (lst->next->next->next && lst->next->next->next->next) { + *ast = make_error("'if': too many arguments"); + return; + } + + MalType* condition = EVAL(lst->next->data, *env); + + if (is_error(condition)) { + *ast = condition; + return; + } + + if (is_false(condition) || is_nil(condition)) { + + /* check whether false branch is present */ + if (lst->next->next->next) { + *ast = lst->next->next->next->data; + return; + } + else { + *ast = make_nil(); + return; + } + + } else { + *ast = lst->next->next->data; + return; + } +} + +MalType* eval_fnstar(MalType* ast, Env* env) { + + /* forward reference */ + MalType* regularise_parameters(list* params, MalType** more); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_error("'fn*': missing argument list"); + } + else if (!lst->next->next) { + return make_error("'fn*': missing function body"); + } + + MalType* params = lst->next->data; + list params_list = params->value.mal_list; + + MalType* more_symbol = NULL; + + MalType* result = regularise_parameters(¶ms_list, &more_symbol); + if (is_error(result)) { return result; } + + MalType* definition = lst->next->next->data; + MalType* regular_params = make_list(params_list); + + return make_closure(env, regular_params, definition, more_symbol); +} + +MalType* eval_do(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + + /* handle empty 'do' */ + if (!lst->next) { + return make_nil(); + } + + /* evaluate all but the last form */ + lst = lst->next; + while (lst->next) { + + MalType* val = EVAL(lst->data, env); + + /* return error early */ + if (is_error(val)) { + return val; + } + lst = lst->next; + } + /* return the last form for TCE evaluation */ + return lst->data; +} + +list evaluate_list(list lst, Env* env) { + + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_vector(list lst, Env* env) { + /* TODO: implement a real vector */ + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_hashmap(list lst, Env* env) { + /* TODO: implement a real hashmap */ + list evlst = NULL; + while (lst) { + + /* keys are unevaluated */ + evlst = list_push(evlst, lst->data); + lst = lst->next; + + /* values are evaluated */ + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +MalType* regularise_parameters(list* args, MalType** more_symbol) { + + /* forward reference */ + char* symbol_fn(gptr data); + + list regular_args = NULL; + while (*args) { + + MalType* val = (*args)->data; + + if (!is_symbol(val)) { + return make_error_fmt("non-symbol found in fn argument list '%s'", \ + pr_str(val, UNREADABLY)); + } + + if (val->value.mal_symbol[0] == '&') { + + /* & is found but there is no symbol */ + if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { + return make_error("missing symbol after '&' in argument list"); + } + /* & is found and there is a single symbol after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && + is_symbol((*args)->next->data) && !(*args)->next->next)) { + + /* TODO: check symbol is no a duplicate of one already on the list */ + *more_symbol = (*args)->next->data; + break; + } + /* & is found and there extra symbols after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { + return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ + pr_str((*args)->next->data, UNREADABLY), \ + pr_str((*args)->next->next->data, UNREADABLY)); + } + /* & is found as part of the symbol and no other symbols */ + else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { + *more_symbol = make_symbol((val->value.mal_symbol + 1)); + break; + } + /* & is found as part of the symbol but there are other symbols after */ + else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { + return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ + pr_str(val, UNREADABLY), \ + pr_str((*args)->next->data, UNREADABLY)); + } + } + + /* & is not found - add the symbol to the regular argument list */ + else { + + if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { + return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); + } + else { + regular_args = list_push(regular_args, val); + } + } + *args = (*args)->next; + } + + *args = list_reverse(regular_args); + return make_nil(); +} + +char* symbol_fn(gptr data) { + return (((MalType*)data)->value.mal_symbol); +} + +/* used by core functions but not EVAL as doesn't do TCE */ +MalType* apply(MalType* fn, list args) { + + if (is_function(fn)) { + + MalType* (*fun_ptr)(list) = fn->value.mal_function; + return (*fun_ptr)(args); + } + else { /* is_closure(fn) */ + + MalClosure* c = fn->value.mal_closure; + list params = (c->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(args); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !c->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + Env* env = env_make(c->env, params, args, c->more_symbol); + return EVAL(fn->value.mal_closure->definition, env); + } + } +} diff --git a/impls/c.2/step7_quote.c b/impls/c.2/step7_quote.c index 27cbd53721..2c2f8fc142 100644 --- a/impls/c.2/step7_quote.c +++ b/impls/c.2/step7_quote.c @@ -1,788 +1,788 @@ -#include -#include -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" -#include "env.h" -#include "core.h" - -#define SYMBOL_DEFBANG "def!" -#define SYMBOL_LETSTAR "let*" -#define SYMBOL_DO "do" -#define SYMBOL_IF "if" -#define SYMBOL_FNSTAR "fn*" -#define SYMBOL_QUOTE "quote" -#define SYMBOL_QUASIQUOTE "quasiquote" -#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand" -#define SYMBOL_UNQUOTE "unquote" -#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* ast, Env* env) { - - /* forward references */ - MalType* eval_ast(MalType* ast, Env* env); - MalType* eval_defbang(MalType* ast, Env** env); - void eval_letstar(MalType** ast, Env** env); - void eval_if(MalType** ast, Env** env); - MalType* eval_fnstar(MalType* ast, Env* env); - MalType* eval_do(MalType* ast, Env* env); - MalType* eval_quote(MalType* ast); - MalType* eval_quasiquote(MalType* ast); - MalType* eval_quasiquoteexpand(MalType* ast); - - /* Use goto to jump here rather than calling eval for tail-call elimination */ - TCE_entry_point: - - /* NULL */ - if (!ast) { return make_nil(); } - - /* not a list */ - if (!is_list(ast)) { return eval_ast(ast, env); } - - /* empty list */ - if (ast->value.mal_list == NULL) { return ast; } - - /* list */ - MalType* first = (ast->value.mal_list)->data; - char* symbol = first->value.mal_symbol; - - if (is_symbol(first)) { - - /* handle special symbols first */ - if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { - return eval_defbang(ast, &env); - } - else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - eval_letstar(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_IF) == 0) { - - /* TCE - modify ast directly and jump back to eval */ - eval_if(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { - return eval_fnstar(ast, env); - } - else if (strcmp(symbol, SYMBOL_DO) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - ast = eval_do(ast, env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_QUOTE) == 0) { - return eval_quote(ast); - } - else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) { - - ast = eval_quasiquote(ast); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) { - - list lst = ast->value.mal_list; - return eval_quasiquote(make_list(lst)); - } - } - - /* first element is not a special symbol */ - MalType* evaluated_list = eval_ast(ast, env); - - if (is_error(evaluated_list)) { return evaluated_list; } - - /* apply the first element of the list to the arguments */ - list evlst = evaluated_list->value.mal_list; - MalType* func = evlst->data; - - if (is_function(func)) { - return (*func->value.mal_function)(evlst->next); - } - else if (is_closure(func)) { - - MalClosure* closure = func->value.mal_closure; - list params = (closure->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(evlst->next); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !closure->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - - /* TCE - modify ast and env directly and jump back to eval */ - env = env_make(closure->env, params, evlst->next, closure->more_symbol); - ast = func->value.mal_closure->definition; - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - } - else { - return make_error_fmt("first item in list is not callable: '%s'", \ - pr_str(func, UNREADABLY)); - } -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str, Env* env) { - - PRINT(EVAL(READ(str), env)); -} - -/* declare as global so it can be accessed by mal_eval */ -Env* global_env; - -MalType* mal_eval(list args) { - - MalType* ast = args->data; - return EVAL(ast, global_env); -} - -int main(int argc, char** argv) { - - Env* repl_env = env_make(NULL, NULL, NULL, NULL); - global_env = repl_env; - - ns* core = ns_make_core(); - hashmap mappings = core->mappings; - - while (mappings) { - char* symbol = mappings->data; - MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; - - env_set_C_fn(repl_env, symbol, function); - - /* pop symbol and function from hashmap/list */ - mappings = mappings->next->next; - } - - env_set_C_fn(repl_env, "eval", mal_eval); - - /* add functions written in mal - not using rep as it prints the result */ - EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); - EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); - - - /* make command line arguments available in the environment */ - list lst = NULL; - for (long i = 2; i < argc; i++) { - lst = list_push(lst, make_string(argv[i])); - } - env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); - - /* run in script mode if a filename is given */ - if (argc > 1) { - - /* first argument on command line is filename */ - char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); - EVAL(READ(load_command), repl_env); - } - /* run in repl mode when no cmd line args */ - else { - - /* Greeting message */ - puts("Make-a-lisp version 0.0.7\n"); - puts("Press Ctrl+d to exit\n"); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input, repl_env); - - /* have to release the memory used by readline */ - free(input); - } - } - return 0; -} - -MalType* eval_ast(MalType* ast, Env* env) { - - /* forward references */ - list evaluate_list(list lst, Env* env); - list evaluate_vector(list lst, Env* env); - list evaluate_hashmap(list lst, Env* env); - - if (is_symbol(ast)) { - - MalType* symbol_value = env_get(env, ast); - - if (symbol_value) { - return symbol_value; - } else { - return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); - } - } - else if (is_list(ast)) { - - list result = evaluate_list(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_list(result); - } else { - return result->data; - } - } - else if (is_vector(ast)) { - - list result = evaluate_vector(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_vector(result); - } else { - return result->data; - } - } - else if (is_hashmap(ast)) { - - list result = evaluate_hashmap(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_hashmap(result); - } else { - return result->data; - } - } - else { - return ast; - } -} - -MalType* eval_defbang(MalType* ast, Env** env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'def!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'def!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, *env); - - if (!is_error(result)){ - *env = env_set(*env, defbang_symbol, result); - } - return result; -} - -void eval_letstar(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next) { - *ast = make_error("'let*': missing bindings list"); - return; - } - - MalType* bindings = lst->next->data; - MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); - - if (!is_sequential(bindings)) { - *ast = make_error("'let*': first argument is not list or vector"); - return; - } - - list bindings_list = bindings->value.mal_list; - if (list_count(bindings_list) % 2 == 1) { - *ast = make_error("'let*': expected an even number of binding pairs"); - return; - } - - Env* letstar_env = env_make(*env, NULL, NULL, NULL); - - /* evaluate the bindings */ - while(bindings_list) { - - MalType* symbol = bindings_list->data; - MalType* value = EVAL(bindings_list->next->data, letstar_env); - - /* early return from error */ - if (is_error(value)) { - *ast = value; - return; - } - - env_set(letstar_env, symbol, value); - bindings_list = bindings_list->next->next; - } - - *env = letstar_env; - *ast = forms; - return; -} - -void eval_if(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next || !lst->next->next) { - *ast = make_error("'if': too few arguments"); - return; - } - - if (lst->next->next->next && lst->next->next->next->next) { - *ast = make_error("'if': too many arguments"); - return; - } - - MalType* condition = EVAL(lst->next->data, *env); - - if (is_error(condition)) { - *ast = condition; - return; - } - - if (is_false(condition) || is_nil(condition)) { - - /* check whether false branch is present */ - if (lst->next->next->next) { - *ast = lst->next->next->next->data; - return; - } - else { - *ast = make_nil(); - return; - } - - } else { - *ast = lst->next->next->data; - return; - } -} - -MalType* eval_fnstar(MalType* ast, Env* env) { - - /* forward reference */ - MalType* regularise_parameters(list* params, MalType** more); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_error("'fn*': missing argument list"); - } - else if (!lst->next->next) { - return make_error("'fn*': missing function body"); - } - - MalType* params = lst->next->data; - list params_list = params->value.mal_list; - - MalType* more_symbol = NULL; - - MalType* result = regularise_parameters(¶ms_list, &more_symbol); - if (is_error(result)) { return result; } - - MalType* definition = lst->next->next->data; - MalType* regular_params = make_list(params_list); - - return make_closure(env, regular_params, definition, more_symbol); -} - -MalType* eval_do(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - - /* handle empty 'do' */ - if (!lst->next) { - return make_nil(); - } - - /* evaluate all but the last form */ - lst = lst->next; - while (lst->next) { - - MalType* val = EVAL(lst->data, env); - - /* return error early */ - if (is_error(val)) { - return val; - } - lst = lst->next; - } - /* return the last form for TCE evaluation */ - return lst->data; -} - -MalType* eval_quote(MalType* ast) { - - list lst = (ast->value.mal_list)->next; - - if (!lst) { - return make_nil(); - } - else if (lst->next) { - return make_error("'quote': expected exactly one argument"); - } - else { - return lst->data; - } -} - -MalType* eval_quasiquote(MalType* ast) { - - /* forward reference */ - MalType* quasiquote(MalType* ast); - - list lst = ast->value.mal_list; - - /* no arguments (quasiquote) */ - if (!lst->next) { - return make_nil(); - } - - /* too many arguments */ - else if (lst->next->next) { - return make_error("'quasiquote': expected exactly one argument"); - } - return quasiquote(lst->next->data); -} - -MalType* quasiquote(MalType* ast) { - - /* forward references */ - MalType* quasiquote_list(MalType* ast); - MalType* quasiquote_vector(MalType* ast); - - /* argument to quasiquote is self-evaluating: (quasiquote val) - => val */ - if (is_self_evaluating(ast)) { - return ast; - } - - /* argument to quasiquote is a vector: (quasiquote [first rest]) */ - else if (is_vector(ast)) { - - return quasiquote_vector(ast); - } - - /* argument to quasiquote is a list: (quasiquote (first rest)) */ - else if (is_list(ast)){ - - return quasiquote_list(ast); - } - /* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val) - => (quote val) */ - else { - - list lst = list_make(ast); - lst = list_push(lst, make_symbol("quote")); - return make_list(lst); - } -} - -MalType* quasiquote_vector(MalType* ast) { - - /* forward references */ - MalType* quasiquote_list(MalType* ast); - - list args = ast->value.mal_list; - - if (args) { - - MalType* first = args->data; - - /* if first element is unquote return quoted */ - if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) { - - list lst = list_make(ast); - lst = list_push(lst, make_symbol("quote")); - - return make_list(lst); - } - } - - /* otherwise process like a list */ - - list lst = list_make(make_symbol("vec")); - - MalType* result = quasiquote_list(ast); - - if (is_error(result)) { - return result; - } else { - lst = list_push(lst, result); - } - - lst = list_reverse(lst); - return make_list(lst); -} - -MalType* quasiquote_list(MalType* ast) { - - list args = ast->value.mal_list; - - /* handle empty list: (quasiquote ()) - => () */ - if (!args) { - return make_list(NULL); - } - - MalType* first = args->data; - - /* handle unquote: (quasiquote (unquote second)) - => second */ - if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) { - - if (args->next->next) { - return make_error("'quasiquote': unquote expected exactly one argument"); - } - else { - return args->next->data; - } - } - - /* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest)) - => (concat first-second (quasiquote rest)) */ - else if (is_list(first) && - first->value.mal_list != NULL && - is_symbol(first->value.mal_list->data) && - strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) { - - if (!first->value.mal_list->next) { - return make_error("'quasiquote': splice-unquote expected exactly one argument"); - } - - MalType* first_second = first->value.mal_list->next->data; - list lst = list_make(make_symbol("concat")); - lst = list_push(lst, first_second); - - MalType* rest = quasiquote(make_list(args->next)); - if (is_error(rest)) { - return rest; - } - - lst = list_push(lst, rest); - lst = list_reverse(lst); - - return make_list(lst); - } - /* handle all other lists recursively: (quasiquote (first rest)) - => (cons (quasiquote first) (quasiquote rest)) */ - else { - - list lst = list_make(make_symbol("cons")); - - MalType* first = quasiquote(args->data); - if (is_error(first)) { - return first; - } else { - lst = list_push(lst, first); - } - - MalType* rest = quasiquote(make_list(args->next)); - if (is_error(rest)) { - return rest; - } else { - lst = list_push(lst, rest); - } - - lst = list_reverse(lst); - return make_list(lst); - } -} - -list evaluate_list(list lst, Env* env) { - - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_vector(list lst, Env* env) { - /* TODO: implement a real vector */ - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_hashmap(list lst, Env* env) { - /* TODO: implement a real hashmap */ - list evlst = NULL; - while (lst) { - - /* keys are unevaluated */ - evlst = list_push(evlst, lst->data); - lst = lst->next; - - /* values are evaluated */ - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -MalType* regularise_parameters(list* args, MalType** more_symbol) { - - /* forward reference */ - char* symbol_fn(gptr data); - - list regular_args = NULL; - while (*args) { - - MalType* val = (*args)->data; - - if (!is_symbol(val)) { - return make_error_fmt("non-symbol found in fn argument list '%s'", \ - pr_str(val, UNREADABLY)); - } - - if (val->value.mal_symbol[0] == '&') { - - /* & is found but there is no symbol */ - if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { - return make_error("missing symbol after '&' in argument list"); - } - /* & is found and there is a single symbol after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && - is_symbol((*args)->next->data) && !(*args)->next->next)) { - - /* TODO: check symbol is no a duplicate of one already on the list */ - *more_symbol = (*args)->next->data; - break; - } - /* & is found and there extra symbols after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { - return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ - pr_str((*args)->next->data, UNREADABLY), \ - pr_str((*args)->next->next->data, UNREADABLY)); - } - /* & is found as part of the symbol and no other symbols */ - else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { - *more_symbol = make_symbol((val->value.mal_symbol + 1)); - break; - } - /* & is found as part of the symbol but there are other symbols after */ - else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { - return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ - pr_str(val, UNREADABLY), \ - pr_str((*args)->next->data, UNREADABLY)); - } - } - - /* & is not found - add the symbol to the regular argument list */ - else { - - if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { - return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); - } - else { - regular_args = list_push(regular_args, val); - } - } - *args = (*args)->next; - } - - *args = list_reverse(regular_args); - return make_nil(); -} - -char* symbol_fn(gptr data) { - return (((MalType*)data)->value.mal_symbol); -} - -/* used by core functions but not EVAL as doesn't do TCE */ -MalType* apply(MalType* fn, list args) { - - if (is_function(fn)) { - - MalType* (*fun_ptr)(list) = fn->value.mal_function; - return (*fun_ptr)(args); - } - else { /* is_closure(fn) */ - - MalClosure* c = fn->value.mal_closure; - list params = (c->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(args); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !c->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - Env* env = env_make(c->env, params, args, c->more_symbol); - return EVAL(fn->value.mal_closure->definition, env); - } - } -} +#include +#include +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" +#include "env.h" +#include "core.h" + +#define SYMBOL_DEFBANG "def!" +#define SYMBOL_LETSTAR "let*" +#define SYMBOL_DO "do" +#define SYMBOL_IF "if" +#define SYMBOL_FNSTAR "fn*" +#define SYMBOL_QUOTE "quote" +#define SYMBOL_QUASIQUOTE "quasiquote" +#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand" +#define SYMBOL_UNQUOTE "unquote" +#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* ast, Env* env) { + + /* forward references */ + MalType* eval_ast(MalType* ast, Env* env); + MalType* eval_defbang(MalType* ast, Env** env); + void eval_letstar(MalType** ast, Env** env); + void eval_if(MalType** ast, Env** env); + MalType* eval_fnstar(MalType* ast, Env* env); + MalType* eval_do(MalType* ast, Env* env); + MalType* eval_quote(MalType* ast); + MalType* eval_quasiquote(MalType* ast); + MalType* eval_quasiquoteexpand(MalType* ast); + + /* Use goto to jump here rather than calling eval for tail-call elimination */ + TCE_entry_point: + + /* NULL */ + if (!ast) { return make_nil(); } + + /* not a list */ + if (!is_list(ast)) { return eval_ast(ast, env); } + + /* empty list */ + if (ast->value.mal_list == NULL) { return ast; } + + /* list */ + MalType* first = (ast->value.mal_list)->data; + char* symbol = first->value.mal_symbol; + + if (is_symbol(first)) { + + /* handle special symbols first */ + if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { + return eval_defbang(ast, &env); + } + else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + eval_letstar(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_IF) == 0) { + + /* TCE - modify ast directly and jump back to eval */ + eval_if(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { + return eval_fnstar(ast, env); + } + else if (strcmp(symbol, SYMBOL_DO) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + ast = eval_do(ast, env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_QUOTE) == 0) { + return eval_quote(ast); + } + else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) { + + ast = eval_quasiquote(ast); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) { + + list lst = ast->value.mal_list; + return eval_quasiquote(make_list(lst)); + } + } + + /* first element is not a special symbol */ + MalType* evaluated_list = eval_ast(ast, env); + + if (is_error(evaluated_list)) { return evaluated_list; } + + /* apply the first element of the list to the arguments */ + list evlst = evaluated_list->value.mal_list; + MalType* func = evlst->data; + + if (is_function(func)) { + return (*func->value.mal_function)(evlst->next); + } + else if (is_closure(func)) { + + MalClosure* closure = func->value.mal_closure; + list params = (closure->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(evlst->next); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !closure->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + + /* TCE - modify ast and env directly and jump back to eval */ + env = env_make(closure->env, params, evlst->next, closure->more_symbol); + ast = func->value.mal_closure->definition; + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + } + else { + return make_error_fmt("first item in list is not callable: '%s'", \ + pr_str(func, UNREADABLY)); + } +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str, Env* env) { + + PRINT(EVAL(READ(str), env)); +} + +/* declare as global so it can be accessed by mal_eval */ +Env* global_env; + +MalType* mal_eval(list args) { + + MalType* ast = args->data; + return EVAL(ast, global_env); +} + +int main(int argc, char** argv) { + + Env* repl_env = env_make(NULL, NULL, NULL, NULL); + global_env = repl_env; + + ns* core = ns_make_core(); + hashmap mappings = core->mappings; + + while (mappings) { + char* symbol = mappings->data; + MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; + + env_set_C_fn(repl_env, symbol, function); + + /* pop symbol and function from hashmap/list */ + mappings = mappings->next->next; + } + + env_set_C_fn(repl_env, "eval", mal_eval); + + /* add functions written in mal - not using rep as it prints the result */ + EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); + EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); + + + /* make command line arguments available in the environment */ + list lst = NULL; + for (long i = 2; i < argc; i++) { + lst = list_push(lst, make_string(argv[i])); + } + env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); + + /* run in script mode if a filename is given */ + if (argc > 1) { + + /* first argument on command line is filename */ + char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); + EVAL(READ(load_command), repl_env); + } + /* run in repl mode when no cmd line args */ + else { + + /* Greeting message */ + puts("Make-a-lisp version 0.0.7\n"); + puts("Press Ctrl+d to exit\n"); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input, repl_env); + + /* have to release the memory used by readline */ + free(input); + } + } + return 0; +} + +MalType* eval_ast(MalType* ast, Env* env) { + + /* forward references */ + list evaluate_list(list lst, Env* env); + list evaluate_vector(list lst, Env* env); + list evaluate_hashmap(list lst, Env* env); + + if (is_symbol(ast)) { + + MalType* symbol_value = env_get(env, ast); + + if (symbol_value) { + return symbol_value; + } else { + return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); + } + } + else if (is_list(ast)) { + + list result = evaluate_list(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_list(result); + } else { + return result->data; + } + } + else if (is_vector(ast)) { + + list result = evaluate_vector(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_vector(result); + } else { + return result->data; + } + } + else if (is_hashmap(ast)) { + + list result = evaluate_hashmap(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_hashmap(result); + } else { + return result->data; + } + } + else { + return ast; + } +} + +MalType* eval_defbang(MalType* ast, Env** env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'def!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'def!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, *env); + + if (!is_error(result)){ + *env = env_set(*env, defbang_symbol, result); + } + return result; +} + +void eval_letstar(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next) { + *ast = make_error("'let*': missing bindings list"); + return; + } + + MalType* bindings = lst->next->data; + MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); + + if (!is_sequential(bindings)) { + *ast = make_error("'let*': first argument is not list or vector"); + return; + } + + list bindings_list = bindings->value.mal_list; + if (list_count(bindings_list) % 2 == 1) { + *ast = make_error("'let*': expected an even number of binding pairs"); + return; + } + + Env* letstar_env = env_make(*env, NULL, NULL, NULL); + + /* evaluate the bindings */ + while(bindings_list) { + + MalType* symbol = bindings_list->data; + MalType* value = EVAL(bindings_list->next->data, letstar_env); + + /* early return from error */ + if (is_error(value)) { + *ast = value; + return; + } + + env_set(letstar_env, symbol, value); + bindings_list = bindings_list->next->next; + } + + *env = letstar_env; + *ast = forms; + return; +} + +void eval_if(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next || !lst->next->next) { + *ast = make_error("'if': too few arguments"); + return; + } + + if (lst->next->next->next && lst->next->next->next->next) { + *ast = make_error("'if': too many arguments"); + return; + } + + MalType* condition = EVAL(lst->next->data, *env); + + if (is_error(condition)) { + *ast = condition; + return; + } + + if (is_false(condition) || is_nil(condition)) { + + /* check whether false branch is present */ + if (lst->next->next->next) { + *ast = lst->next->next->next->data; + return; + } + else { + *ast = make_nil(); + return; + } + + } else { + *ast = lst->next->next->data; + return; + } +} + +MalType* eval_fnstar(MalType* ast, Env* env) { + + /* forward reference */ + MalType* regularise_parameters(list* params, MalType** more); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_error("'fn*': missing argument list"); + } + else if (!lst->next->next) { + return make_error("'fn*': missing function body"); + } + + MalType* params = lst->next->data; + list params_list = params->value.mal_list; + + MalType* more_symbol = NULL; + + MalType* result = regularise_parameters(¶ms_list, &more_symbol); + if (is_error(result)) { return result; } + + MalType* definition = lst->next->next->data; + MalType* regular_params = make_list(params_list); + + return make_closure(env, regular_params, definition, more_symbol); +} + +MalType* eval_do(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + + /* handle empty 'do' */ + if (!lst->next) { + return make_nil(); + } + + /* evaluate all but the last form */ + lst = lst->next; + while (lst->next) { + + MalType* val = EVAL(lst->data, env); + + /* return error early */ + if (is_error(val)) { + return val; + } + lst = lst->next; + } + /* return the last form for TCE evaluation */ + return lst->data; +} + +MalType* eval_quote(MalType* ast) { + + list lst = (ast->value.mal_list)->next; + + if (!lst) { + return make_nil(); + } + else if (lst->next) { + return make_error("'quote': expected exactly one argument"); + } + else { + return lst->data; + } +} + +MalType* eval_quasiquote(MalType* ast) { + + /* forward reference */ + MalType* quasiquote(MalType* ast); + + list lst = ast->value.mal_list; + + /* no arguments (quasiquote) */ + if (!lst->next) { + return make_nil(); + } + + /* too many arguments */ + else if (lst->next->next) { + return make_error("'quasiquote': expected exactly one argument"); + } + return quasiquote(lst->next->data); +} + +MalType* quasiquote(MalType* ast) { + + /* forward references */ + MalType* quasiquote_list(MalType* ast); + MalType* quasiquote_vector(MalType* ast); + + /* argument to quasiquote is self-evaluating: (quasiquote val) + => val */ + if (is_self_evaluating(ast)) { + return ast; + } + + /* argument to quasiquote is a vector: (quasiquote [first rest]) */ + else if (is_vector(ast)) { + + return quasiquote_vector(ast); + } + + /* argument to quasiquote is a list: (quasiquote (first rest)) */ + else if (is_list(ast)){ + + return quasiquote_list(ast); + } + /* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val) + => (quote val) */ + else { + + list lst = list_make(ast); + lst = list_push(lst, make_symbol("quote")); + return make_list(lst); + } +} + +MalType* quasiquote_vector(MalType* ast) { + + /* forward references */ + MalType* quasiquote_list(MalType* ast); + + list args = ast->value.mal_list; + + if (args) { + + MalType* first = args->data; + + /* if first element is unquote return quoted */ + if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) { + + list lst = list_make(ast); + lst = list_push(lst, make_symbol("quote")); + + return make_list(lst); + } + } + + /* otherwise process like a list */ + + list lst = list_make(make_symbol("vec")); + + MalType* result = quasiquote_list(ast); + + if (is_error(result)) { + return result; + } else { + lst = list_push(lst, result); + } + + lst = list_reverse(lst); + return make_list(lst); +} + +MalType* quasiquote_list(MalType* ast) { + + list args = ast->value.mal_list; + + /* handle empty list: (quasiquote ()) + => () */ + if (!args) { + return make_list(NULL); + } + + MalType* first = args->data; + + /* handle unquote: (quasiquote (unquote second)) + => second */ + if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) { + + if (args->next->next) { + return make_error("'quasiquote': unquote expected exactly one argument"); + } + else { + return args->next->data; + } + } + + /* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest)) + => (concat first-second (quasiquote rest)) */ + else if (is_list(first) && + first->value.mal_list != NULL && + is_symbol(first->value.mal_list->data) && + strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) { + + if (!first->value.mal_list->next) { + return make_error("'quasiquote': splice-unquote expected exactly one argument"); + } + + MalType* first_second = first->value.mal_list->next->data; + list lst = list_make(make_symbol("concat")); + lst = list_push(lst, first_second); + + MalType* rest = quasiquote(make_list(args->next)); + if (is_error(rest)) { + return rest; + } + + lst = list_push(lst, rest); + lst = list_reverse(lst); + + return make_list(lst); + } + /* handle all other lists recursively: (quasiquote (first rest)) + => (cons (quasiquote first) (quasiquote rest)) */ + else { + + list lst = list_make(make_symbol("cons")); + + MalType* first = quasiquote(args->data); + if (is_error(first)) { + return first; + } else { + lst = list_push(lst, first); + } + + MalType* rest = quasiquote(make_list(args->next)); + if (is_error(rest)) { + return rest; + } else { + lst = list_push(lst, rest); + } + + lst = list_reverse(lst); + return make_list(lst); + } +} + +list evaluate_list(list lst, Env* env) { + + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_vector(list lst, Env* env) { + /* TODO: implement a real vector */ + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_hashmap(list lst, Env* env) { + /* TODO: implement a real hashmap */ + list evlst = NULL; + while (lst) { + + /* keys are unevaluated */ + evlst = list_push(evlst, lst->data); + lst = lst->next; + + /* values are evaluated */ + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +MalType* regularise_parameters(list* args, MalType** more_symbol) { + + /* forward reference */ + char* symbol_fn(gptr data); + + list regular_args = NULL; + while (*args) { + + MalType* val = (*args)->data; + + if (!is_symbol(val)) { + return make_error_fmt("non-symbol found in fn argument list '%s'", \ + pr_str(val, UNREADABLY)); + } + + if (val->value.mal_symbol[0] == '&') { + + /* & is found but there is no symbol */ + if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { + return make_error("missing symbol after '&' in argument list"); + } + /* & is found and there is a single symbol after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && + is_symbol((*args)->next->data) && !(*args)->next->next)) { + + /* TODO: check symbol is no a duplicate of one already on the list */ + *more_symbol = (*args)->next->data; + break; + } + /* & is found and there extra symbols after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { + return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ + pr_str((*args)->next->data, UNREADABLY), \ + pr_str((*args)->next->next->data, UNREADABLY)); + } + /* & is found as part of the symbol and no other symbols */ + else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { + *more_symbol = make_symbol((val->value.mal_symbol + 1)); + break; + } + /* & is found as part of the symbol but there are other symbols after */ + else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { + return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ + pr_str(val, UNREADABLY), \ + pr_str((*args)->next->data, UNREADABLY)); + } + } + + /* & is not found - add the symbol to the regular argument list */ + else { + + if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { + return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); + } + else { + regular_args = list_push(regular_args, val); + } + } + *args = (*args)->next; + } + + *args = list_reverse(regular_args); + return make_nil(); +} + +char* symbol_fn(gptr data) { + return (((MalType*)data)->value.mal_symbol); +} + +/* used by core functions but not EVAL as doesn't do TCE */ +MalType* apply(MalType* fn, list args) { + + if (is_function(fn)) { + + MalType* (*fun_ptr)(list) = fn->value.mal_function; + return (*fun_ptr)(args); + } + else { /* is_closure(fn) */ + + MalClosure* c = fn->value.mal_closure; + list params = (c->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(args); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !c->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + Env* env = env_make(c->env, params, args, c->more_symbol); + return EVAL(fn->value.mal_closure->definition, env); + } + } +} diff --git a/impls/c.2/step8_macros.c b/impls/c.2/step8_macros.c index 06c8097f91..fa505d6f0d 100644 --- a/impls/c.2/step8_macros.c +++ b/impls/c.2/step8_macros.c @@ -1,897 +1,897 @@ -#include -#include -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" -#include "env.h" -#include "core.h" - -#define SYMBOL_DEFBANG "def!" -#define SYMBOL_LETSTAR "let*" -#define SYMBOL_DO "do" -#define SYMBOL_IF "if" -#define SYMBOL_FNSTAR "fn*" -#define SYMBOL_QUOTE "quote" -#define SYMBOL_QUASIQUOTE "quasiquote" -#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand" -#define SYMBOL_UNQUOTE "unquote" -#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" -#define SYMBOL_DEFMACROBANG "defmacro!" -#define SYMBOL_MACROEXPAND "macroexpand" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* ast, Env* env) { - - /* forward references */ - MalType* eval_ast(MalType* ast, Env* env); - MalType* eval_defbang(MalType* ast, Env** env); - void eval_letstar(MalType** ast, Env** env); - void eval_if(MalType** ast, Env** env); - MalType* eval_fnstar(MalType* ast, Env* env); - MalType* eval_do(MalType* ast, Env* env); - MalType* eval_quote(MalType* ast); - MalType* eval_quasiquote(MalType* ast); - MalType* eval_quasiquoteexpand(MalType* ast); - MalType* eval_defmacrobang(MalType*, Env** env); - MalType* eval_macroexpand(MalType* ast, Env* env); - MalType* macroexpand(MalType* ast, Env* env); - - /* Use goto to jump here rather than calling eval for tail-call elimination */ - TCE_entry_point: - - /* NULL */ - if (!ast) { return make_nil(); } - - /* macroexpansion */ - ast = macroexpand(ast, env); - if (is_error(ast)) { return ast; } - - /* not a list */ - if (!is_list(ast)) { return eval_ast(ast, env); } - - /* empty list */ - if (ast->value.mal_list == NULL) { return ast; } - - /* list */ - MalType* first = (ast->value.mal_list)->data; - char* symbol = first->value.mal_symbol; - - if (is_symbol(first)) { - - /* handle special symbols first */ - if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { - return eval_defbang(ast, &env); - } - else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - eval_letstar(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_IF) == 0) { - - /* TCE - modify ast directly and jump back to eval */ - eval_if(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { - return eval_fnstar(ast, env); - } - else if (strcmp(symbol, SYMBOL_DO) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - ast = eval_do(ast, env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_QUOTE) == 0) { - return eval_quote(ast); - } - else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) { - - ast = eval_quasiquote(ast); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) { - - list lst = ast->value.mal_list; - return eval_quasiquote(make_list(lst)); - } - else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) { - return eval_defmacrobang(ast, &env); - } - else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) { - return eval_macroexpand(ast, env); - } - } - - /* first element is not a special symbol */ - MalType* evaluated_list = eval_ast(ast, env); - - if (is_error(evaluated_list)) { return evaluated_list; } - - /* apply the first element of the list to the arguments */ - list evlst = evaluated_list->value.mal_list; - MalType* func = evlst->data; - - if (is_function(func)) { - return (*func->value.mal_function)(evlst->next); - } - else if (is_closure(func)) { - - MalClosure* closure = func->value.mal_closure; - list params = (closure->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(evlst->next); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !closure->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - - /* TCE - modify ast and env directly and jump back to eval */ - env = env_make(closure->env, params, evlst->next, closure->more_symbol); - ast = func->value.mal_closure->definition; - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - } - else { - return make_error_fmt("first item in list is not callable: '%s'", \ - pr_str(func, UNREADABLY)); - } -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str, Env* env) { - - PRINT(EVAL(READ(str), env)); -} - -/* declare as global so it can be accessed by mal_eval */ -Env* global_env; - -MalType* mal_eval(list args) { - - MalType* ast = args->data; - return EVAL(ast, global_env); -} - -int main(int argc, char** argv) { - - Env* repl_env = env_make(NULL, NULL, NULL, NULL); - global_env = repl_env; - - ns* core = ns_make_core(); - hashmap mappings = core->mappings; - - while (mappings) { - char* symbol = mappings->data; - MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; - - env_set_C_fn(repl_env, symbol, function); - - /* pop symbol and function from hashmap/list */ - mappings = mappings->next->next; - } - - env_set_C_fn(repl_env, "eval", mal_eval); - - /* add functions written in mal - not using rep as it prints the result */ - EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); - EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); - EVAL(READ("(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)))))))"), repl_env); - - /* make command line arguments available in the environment */ - list lst = NULL; - for (long i = 2; i < argc; i++) { - lst = list_push(lst, make_string(argv[i])); - } - env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); - - /* run in script mode if a filename is given */ - if (argc > 1) { - - /* first argument on command line is filename */ - char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); - EVAL(READ(load_command), repl_env); - } - /* run in repl mode when no cmd line args */ - else { - - /* Greeting message */ - puts("Make-a-lisp version 0.0.8\n"); - puts("Press Ctrl+d to exit\n"); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input, repl_env); - - /* have to release the memory used by readline */ - free(input); - } - } - return 0; -} - -MalType* eval_ast(MalType* ast, Env* env) { - - /* forward references */ - list evaluate_list(list lst, Env* env); - list evaluate_vector(list lst, Env* env); - list evaluate_hashmap(list lst, Env* env); - - if (is_symbol(ast)) { - - MalType* symbol_value = env_get(env, ast); - - if (symbol_value) { - return symbol_value; - } else { - return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); - } - } - else if (is_list(ast)) { - - list result = evaluate_list(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_list(result); - } else { - return result->data; - } - } - else if (is_vector(ast)) { - - list result = evaluate_vector(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_vector(result); - } else { - return result->data; - } - } - else if (is_hashmap(ast)) { - - list result = evaluate_hashmap(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_hashmap(result); - } else { - return result->data; - } - } - else { - return ast; - } -} - -MalType* eval_defbang(MalType* ast, Env** env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'def!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'def!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, *env); - - if (!is_error(result)){ - *env = env_set(*env, defbang_symbol, result); - } - return result; -} - -void eval_letstar(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next) { - *ast = make_error("'let*': missing bindings list"); - return; - } - - MalType* bindings = lst->next->data; - MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); - - if (!is_sequential(bindings)) { - *ast = make_error("'let*': first argument is not list or vector"); - return; - } - - list bindings_list = bindings->value.mal_list; - if (list_count(bindings_list) % 2 == 1) { - *ast = make_error("'let*': expected an even number of binding pairs"); - return; - } - - Env* letstar_env = env_make(*env, NULL, NULL, NULL); - - /* evaluate the bindings */ - while(bindings_list) { - - MalType* symbol = bindings_list->data; - MalType* value = EVAL(bindings_list->next->data, letstar_env); - - /* early return from error */ - if (is_error(value)) { - *ast = value; - return; - } - - env_set(letstar_env, symbol, value); - bindings_list = bindings_list->next->next; - } - - *env = letstar_env; - *ast = forms; - return; -} - -void eval_if(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next || !lst->next->next) { - *ast = make_error("'if': too few arguments"); - return; - } - - if (lst->next->next->next && lst->next->next->next->next) { - *ast = make_error("'if': too many arguments"); - return; - } - - MalType* condition = EVAL(lst->next->data, *env); - - if (is_error(condition)) { - *ast = condition; - return; - } - - if (is_false(condition) || is_nil(condition)) { - - /* check whether false branch is present */ - if (lst->next->next->next) { - *ast = lst->next->next->next->data; - return; - } - else { - *ast = make_nil(); - return; - } - - } else { - *ast = lst->next->next->data; - return; - } -} - -MalType* eval_fnstar(MalType* ast, Env* env) { - - /* forward reference */ - MalType* regularise_parameters(list* params, MalType** more); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_error("'fn*': missing argument list"); - } - else if (!lst->next->next) { - return make_error("'fn*': missing function body"); - } - - MalType* params = lst->next->data; - list params_list = params->value.mal_list; - - MalType* more_symbol = NULL; - - MalType* result = regularise_parameters(¶ms_list, &more_symbol); - if (is_error(result)) { return result; } - - MalType* definition = lst->next->next->data; - MalType* regular_params = make_list(params_list); - - return make_closure(env, regular_params, definition, more_symbol); -} - -MalType* eval_do(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - - /* handle empty 'do' */ - if (!lst->next) { - return make_nil(); - } - - /* evaluate all but the last form */ - lst = lst->next; - while (lst->next) { - - MalType* val = EVAL(lst->data, env); - - /* return error early */ - if (is_error(val)) { - return val; - } - lst = lst->next; - } - /* return the last form for TCE evaluation */ - return lst->data; -} - -MalType* eval_quote(MalType* ast) { - - list lst = (ast->value.mal_list)->next; - - if (!lst) { - return make_nil(); - } - else if (lst->next) { - return make_error("'quote': expected exactly one argument"); - } - else { - return lst->data; - } -} - -MalType* eval_quasiquote(MalType* ast) { - - /* forward reference */ - MalType* quasiquote(MalType* ast); - - list lst = ast->value.mal_list; - - /* no arguments (quasiquote) */ - if (!lst->next) { - return make_nil(); - } - - /* too many arguments */ - else if (lst->next->next) { - return make_error("'quasiquote': expected exactly one argument"); - } - return quasiquote(lst->next->data); -} - -MalType* quasiquote(MalType* ast) { - - /* forward references */ - MalType* quasiquote_list(MalType* ast); - MalType* quasiquote_vector(MalType* ast); - - /* argument to quasiquote is self-evaluating: (quasiquote val) - => val */ - if (is_self_evaluating(ast)) { - return ast; - } - - /* argument to quasiquote is a vector: (quasiquote [first rest]) */ - else if (is_vector(ast)) { - - return quasiquote_vector(ast); - } - - /* argument to quasiquote is a list: (quasiquote (first rest)) */ - else if (is_list(ast)){ - - return quasiquote_list(ast); - } - /* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val) - => (quote val) */ - else { - - list lst = list_make(ast); - lst = list_push(lst, make_symbol("quote")); - return make_list(lst); - } -} - -MalType* quasiquote_vector(MalType* ast) { - - /* forward references */ - MalType* quasiquote_list(MalType* ast); - - list args = ast->value.mal_list; - - if (args) { - - MalType* first = args->data; - - /* if first element is unquote return quoted */ - if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) { - - list lst = list_make(ast); - lst = list_push(lst, make_symbol("quote")); - - return make_list(lst); - } - } - - /* otherwise process like a list */ - - list lst = list_make(make_symbol("vec")); - - MalType* result = quasiquote_list(ast); - - if (is_error(result)) { - return result; - } else { - lst = list_push(lst, result); - } - - lst = list_reverse(lst); - return make_list(lst); -} - -MalType* quasiquote_list(MalType* ast) { - - list args = ast->value.mal_list; - - /* handle empty list: (quasiquote ()) - => () */ - if (!args) { - return make_list(NULL); - } - - MalType* first = args->data; - - /* handle unquote: (quasiquote (unquote second)) - => second */ - if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) { - - if (args->next->next) { - return make_error("'quasiquote': unquote expected exactly one argument"); - } - else { - return args->next->data; - } - } - - /* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest)) - => (concat first-second (quasiquote rest)) */ - else if (is_list(first) && - first->value.mal_list != NULL && - is_symbol(first->value.mal_list->data) && - strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) { - - if (!first->value.mal_list->next) { - return make_error("'quasiquote': splice-unquote expected exactly one argument"); - } - - MalType* first_second = first->value.mal_list->next->data; - list lst = list_make(make_symbol("concat")); - lst = list_push(lst, first_second); - - MalType* rest = quasiquote(make_list(args->next)); - if (is_error(rest)) { - return rest; - } - - lst = list_push(lst, rest); - lst = list_reverse(lst); - - return make_list(lst); - } - /* handle all other lists recursively: (quasiquote (first rest)) - => (cons (quasiquote first) (quasiquote rest)) */ - else { - - list lst = list_make(make_symbol("cons")); - - MalType* first = quasiquote(args->data); - if (is_error(first)) { - return first; - } else { - lst = list_push(lst, first); - } - - MalType* rest = quasiquote(make_list(args->next)); - if (is_error(rest)) { - return rest; - } else { - lst = list_push(lst, rest); - } - - lst = list_reverse(lst); - return make_list(lst); - } -} - -MalType* eval_defmacrobang(MalType* ast, Env** env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'defmacro!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'defmacro!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, *env); - - if (!is_error(result)) { - result = copy_type(result); - result->is_macro = 1; - *env = env_set(*env, defbang_symbol, result); - } - return result; -} - -MalType* eval_macroexpand(MalType* ast, Env* env) { - - /* forward reference */ - MalType* macroexpand(MalType* ast, Env* env); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_nil(); - } - else if (lst->next->next) { - return make_error("'macroexpand': expected exactly one argument"); - } - else { - return macroexpand(lst->next->data, env); - } -} - -MalType* macroexpand(MalType* ast, Env* env) { - - /* forward reference */ - int is_macro_call(MalType* ast, Env* env); - - while(is_macro_call(ast, env)) { - - list lst = ast->value.mal_list; - - MalType* macro_fn = env_get(env, lst->data); - MalClosure* cls = macro_fn->value.mal_closure; - MalType* more_symbol = cls->more_symbol; - - list params_list = (cls->parameters)->value.mal_list; - list args_list = lst->next; - - env = env_make(cls->env, params_list, args_list, more_symbol); - ast = EVAL(cls->definition, env); - } - return ast; -} - -list evaluate_list(list lst, Env* env) { - - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_vector(list lst, Env* env) { - /* TODO: implement a real vector */ - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_hashmap(list lst, Env* env) { - /* TODO: implement a real hashmap */ - list evlst = NULL; - while (lst) { - - /* keys are unevaluated */ - evlst = list_push(evlst, lst->data); - lst = lst->next; - - /* values are evaluated */ - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -MalType* regularise_parameters(list* args, MalType** more_symbol) { - - /* forward reference */ - char* symbol_fn(gptr data); - - list regular_args = NULL; - while (*args) { - - MalType* val = (*args)->data; - - if (!is_symbol(val)) { - return make_error_fmt("non-symbol found in fn argument list '%s'", \ - pr_str(val, UNREADABLY)); - } - - if (val->value.mal_symbol[0] == '&') { - - /* & is found but there is no symbol */ - if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { - return make_error("missing symbol after '&' in argument list"); - } - /* & is found and there is a single symbol after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && - is_symbol((*args)->next->data) && !(*args)->next->next)) { - - /* TODO: check symbol is no a duplicate of one already on the list */ - *more_symbol = (*args)->next->data; - break; - } - /* & is found and there extra symbols after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { - return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ - pr_str((*args)->next->data, UNREADABLY), \ - pr_str((*args)->next->next->data, UNREADABLY)); - } - /* & is found as part of the symbol and no other symbols */ - else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { - *more_symbol = make_symbol((val->value.mal_symbol + 1)); - break; - } - /* & is found as part of the symbol but there are other symbols after */ - else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { - return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ - pr_str(val, UNREADABLY), \ - pr_str((*args)->next->data, UNREADABLY)); - } - } - - /* & is not found - add the symbol to the regular argument list */ - else { - - if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { - return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); - } - else { - regular_args = list_push(regular_args, val); - } - } - *args = (*args)->next; - } - - *args = list_reverse(regular_args); - return make_nil(); -} - -char* symbol_fn(gptr data) { - return (((MalType*)data)->value.mal_symbol); -} - -/* used by core functions but not EVAL as doesn't do TCE */ -MalType* apply(MalType* fn, list args) { - - if (is_function(fn)) { - - MalType* (*fun_ptr)(list) = fn->value.mal_function; - return (*fun_ptr)(args); - } - else { /* is_closure(fn) */ - - MalClosure* c = fn->value.mal_closure; - list params = (c->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(args); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !c->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - Env* env = env_make(c->env, params, args, c->more_symbol); - return EVAL(fn->value.mal_closure->definition, env); - } - } -} - -int is_macro_call(MalType* ast, Env* env) { - - /* not a list */ - if (!is_list(ast)) { - return 0; - } - - /* empty list */ - list lst = ast->value.mal_list; - if (!lst) { - return 0; - } - - /* first item not a symbol */ - MalType* first = lst->data; - if (!is_symbol(first)) { - return 0; - } - - /* lookup symbol */ - MalType* val = env_get(env, first); - if (is_error(val)) { - return 0; - } - else { - return (val->is_macro); - } -} +#include +#include +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" +#include "env.h" +#include "core.h" + +#define SYMBOL_DEFBANG "def!" +#define SYMBOL_LETSTAR "let*" +#define SYMBOL_DO "do" +#define SYMBOL_IF "if" +#define SYMBOL_FNSTAR "fn*" +#define SYMBOL_QUOTE "quote" +#define SYMBOL_QUASIQUOTE "quasiquote" +#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand" +#define SYMBOL_UNQUOTE "unquote" +#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" +#define SYMBOL_DEFMACROBANG "defmacro!" +#define SYMBOL_MACROEXPAND "macroexpand" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* ast, Env* env) { + + /* forward references */ + MalType* eval_ast(MalType* ast, Env* env); + MalType* eval_defbang(MalType* ast, Env** env); + void eval_letstar(MalType** ast, Env** env); + void eval_if(MalType** ast, Env** env); + MalType* eval_fnstar(MalType* ast, Env* env); + MalType* eval_do(MalType* ast, Env* env); + MalType* eval_quote(MalType* ast); + MalType* eval_quasiquote(MalType* ast); + MalType* eval_quasiquoteexpand(MalType* ast); + MalType* eval_defmacrobang(MalType*, Env** env); + MalType* eval_macroexpand(MalType* ast, Env* env); + MalType* macroexpand(MalType* ast, Env* env); + + /* Use goto to jump here rather than calling eval for tail-call elimination */ + TCE_entry_point: + + /* NULL */ + if (!ast) { return make_nil(); } + + /* macroexpansion */ + ast = macroexpand(ast, env); + if (is_error(ast)) { return ast; } + + /* not a list */ + if (!is_list(ast)) { return eval_ast(ast, env); } + + /* empty list */ + if (ast->value.mal_list == NULL) { return ast; } + + /* list */ + MalType* first = (ast->value.mal_list)->data; + char* symbol = first->value.mal_symbol; + + if (is_symbol(first)) { + + /* handle special symbols first */ + if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { + return eval_defbang(ast, &env); + } + else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + eval_letstar(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_IF) == 0) { + + /* TCE - modify ast directly and jump back to eval */ + eval_if(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { + return eval_fnstar(ast, env); + } + else if (strcmp(symbol, SYMBOL_DO) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + ast = eval_do(ast, env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_QUOTE) == 0) { + return eval_quote(ast); + } + else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) { + + ast = eval_quasiquote(ast); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) { + + list lst = ast->value.mal_list; + return eval_quasiquote(make_list(lst)); + } + else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) { + return eval_defmacrobang(ast, &env); + } + else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) { + return eval_macroexpand(ast, env); + } + } + + /* first element is not a special symbol */ + MalType* evaluated_list = eval_ast(ast, env); + + if (is_error(evaluated_list)) { return evaluated_list; } + + /* apply the first element of the list to the arguments */ + list evlst = evaluated_list->value.mal_list; + MalType* func = evlst->data; + + if (is_function(func)) { + return (*func->value.mal_function)(evlst->next); + } + else if (is_closure(func)) { + + MalClosure* closure = func->value.mal_closure; + list params = (closure->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(evlst->next); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !closure->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + + /* TCE - modify ast and env directly and jump back to eval */ + env = env_make(closure->env, params, evlst->next, closure->more_symbol); + ast = func->value.mal_closure->definition; + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + } + else { + return make_error_fmt("first item in list is not callable: '%s'", \ + pr_str(func, UNREADABLY)); + } +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str, Env* env) { + + PRINT(EVAL(READ(str), env)); +} + +/* declare as global so it can be accessed by mal_eval */ +Env* global_env; + +MalType* mal_eval(list args) { + + MalType* ast = args->data; + return EVAL(ast, global_env); +} + +int main(int argc, char** argv) { + + Env* repl_env = env_make(NULL, NULL, NULL, NULL); + global_env = repl_env; + + ns* core = ns_make_core(); + hashmap mappings = core->mappings; + + while (mappings) { + char* symbol = mappings->data; + MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; + + env_set_C_fn(repl_env, symbol, function); + + /* pop symbol and function from hashmap/list */ + mappings = mappings->next->next; + } + + env_set_C_fn(repl_env, "eval", mal_eval); + + /* add functions written in mal - not using rep as it prints the result */ + EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); + EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); + EVAL(READ("(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)))))))"), repl_env); + + /* make command line arguments available in the environment */ + list lst = NULL; + for (long i = 2; i < argc; i++) { + lst = list_push(lst, make_string(argv[i])); + } + env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); + + /* run in script mode if a filename is given */ + if (argc > 1) { + + /* first argument on command line is filename */ + char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); + EVAL(READ(load_command), repl_env); + } + /* run in repl mode when no cmd line args */ + else { + + /* Greeting message */ + puts("Make-a-lisp version 0.0.8\n"); + puts("Press Ctrl+d to exit\n"); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input, repl_env); + + /* have to release the memory used by readline */ + free(input); + } + } + return 0; +} + +MalType* eval_ast(MalType* ast, Env* env) { + + /* forward references */ + list evaluate_list(list lst, Env* env); + list evaluate_vector(list lst, Env* env); + list evaluate_hashmap(list lst, Env* env); + + if (is_symbol(ast)) { + + MalType* symbol_value = env_get(env, ast); + + if (symbol_value) { + return symbol_value; + } else { + return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); + } + } + else if (is_list(ast)) { + + list result = evaluate_list(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_list(result); + } else { + return result->data; + } + } + else if (is_vector(ast)) { + + list result = evaluate_vector(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_vector(result); + } else { + return result->data; + } + } + else if (is_hashmap(ast)) { + + list result = evaluate_hashmap(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_hashmap(result); + } else { + return result->data; + } + } + else { + return ast; + } +} + +MalType* eval_defbang(MalType* ast, Env** env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'def!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'def!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, *env); + + if (!is_error(result)){ + *env = env_set(*env, defbang_symbol, result); + } + return result; +} + +void eval_letstar(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next) { + *ast = make_error("'let*': missing bindings list"); + return; + } + + MalType* bindings = lst->next->data; + MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); + + if (!is_sequential(bindings)) { + *ast = make_error("'let*': first argument is not list or vector"); + return; + } + + list bindings_list = bindings->value.mal_list; + if (list_count(bindings_list) % 2 == 1) { + *ast = make_error("'let*': expected an even number of binding pairs"); + return; + } + + Env* letstar_env = env_make(*env, NULL, NULL, NULL); + + /* evaluate the bindings */ + while(bindings_list) { + + MalType* symbol = bindings_list->data; + MalType* value = EVAL(bindings_list->next->data, letstar_env); + + /* early return from error */ + if (is_error(value)) { + *ast = value; + return; + } + + env_set(letstar_env, symbol, value); + bindings_list = bindings_list->next->next; + } + + *env = letstar_env; + *ast = forms; + return; +} + +void eval_if(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next || !lst->next->next) { + *ast = make_error("'if': too few arguments"); + return; + } + + if (lst->next->next->next && lst->next->next->next->next) { + *ast = make_error("'if': too many arguments"); + return; + } + + MalType* condition = EVAL(lst->next->data, *env); + + if (is_error(condition)) { + *ast = condition; + return; + } + + if (is_false(condition) || is_nil(condition)) { + + /* check whether false branch is present */ + if (lst->next->next->next) { + *ast = lst->next->next->next->data; + return; + } + else { + *ast = make_nil(); + return; + } + + } else { + *ast = lst->next->next->data; + return; + } +} + +MalType* eval_fnstar(MalType* ast, Env* env) { + + /* forward reference */ + MalType* regularise_parameters(list* params, MalType** more); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_error("'fn*': missing argument list"); + } + else if (!lst->next->next) { + return make_error("'fn*': missing function body"); + } + + MalType* params = lst->next->data; + list params_list = params->value.mal_list; + + MalType* more_symbol = NULL; + + MalType* result = regularise_parameters(¶ms_list, &more_symbol); + if (is_error(result)) { return result; } + + MalType* definition = lst->next->next->data; + MalType* regular_params = make_list(params_list); + + return make_closure(env, regular_params, definition, more_symbol); +} + +MalType* eval_do(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + + /* handle empty 'do' */ + if (!lst->next) { + return make_nil(); + } + + /* evaluate all but the last form */ + lst = lst->next; + while (lst->next) { + + MalType* val = EVAL(lst->data, env); + + /* return error early */ + if (is_error(val)) { + return val; + } + lst = lst->next; + } + /* return the last form for TCE evaluation */ + return lst->data; +} + +MalType* eval_quote(MalType* ast) { + + list lst = (ast->value.mal_list)->next; + + if (!lst) { + return make_nil(); + } + else if (lst->next) { + return make_error("'quote': expected exactly one argument"); + } + else { + return lst->data; + } +} + +MalType* eval_quasiquote(MalType* ast) { + + /* forward reference */ + MalType* quasiquote(MalType* ast); + + list lst = ast->value.mal_list; + + /* no arguments (quasiquote) */ + if (!lst->next) { + return make_nil(); + } + + /* too many arguments */ + else if (lst->next->next) { + return make_error("'quasiquote': expected exactly one argument"); + } + return quasiquote(lst->next->data); +} + +MalType* quasiquote(MalType* ast) { + + /* forward references */ + MalType* quasiquote_list(MalType* ast); + MalType* quasiquote_vector(MalType* ast); + + /* argument to quasiquote is self-evaluating: (quasiquote val) + => val */ + if (is_self_evaluating(ast)) { + return ast; + } + + /* argument to quasiquote is a vector: (quasiquote [first rest]) */ + else if (is_vector(ast)) { + + return quasiquote_vector(ast); + } + + /* argument to quasiquote is a list: (quasiquote (first rest)) */ + else if (is_list(ast)){ + + return quasiquote_list(ast); + } + /* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val) + => (quote val) */ + else { + + list lst = list_make(ast); + lst = list_push(lst, make_symbol("quote")); + return make_list(lst); + } +} + +MalType* quasiquote_vector(MalType* ast) { + + /* forward references */ + MalType* quasiquote_list(MalType* ast); + + list args = ast->value.mal_list; + + if (args) { + + MalType* first = args->data; + + /* if first element is unquote return quoted */ + if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) { + + list lst = list_make(ast); + lst = list_push(lst, make_symbol("quote")); + + return make_list(lst); + } + } + + /* otherwise process like a list */ + + list lst = list_make(make_symbol("vec")); + + MalType* result = quasiquote_list(ast); + + if (is_error(result)) { + return result; + } else { + lst = list_push(lst, result); + } + + lst = list_reverse(lst); + return make_list(lst); +} + +MalType* quasiquote_list(MalType* ast) { + + list args = ast->value.mal_list; + + /* handle empty list: (quasiquote ()) + => () */ + if (!args) { + return make_list(NULL); + } + + MalType* first = args->data; + + /* handle unquote: (quasiquote (unquote second)) + => second */ + if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) { + + if (args->next->next) { + return make_error("'quasiquote': unquote expected exactly one argument"); + } + else { + return args->next->data; + } + } + + /* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest)) + => (concat first-second (quasiquote rest)) */ + else if (is_list(first) && + first->value.mal_list != NULL && + is_symbol(first->value.mal_list->data) && + strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) { + + if (!first->value.mal_list->next) { + return make_error("'quasiquote': splice-unquote expected exactly one argument"); + } + + MalType* first_second = first->value.mal_list->next->data; + list lst = list_make(make_symbol("concat")); + lst = list_push(lst, first_second); + + MalType* rest = quasiquote(make_list(args->next)); + if (is_error(rest)) { + return rest; + } + + lst = list_push(lst, rest); + lst = list_reverse(lst); + + return make_list(lst); + } + /* handle all other lists recursively: (quasiquote (first rest)) + => (cons (quasiquote first) (quasiquote rest)) */ + else { + + list lst = list_make(make_symbol("cons")); + + MalType* first = quasiquote(args->data); + if (is_error(first)) { + return first; + } else { + lst = list_push(lst, first); + } + + MalType* rest = quasiquote(make_list(args->next)); + if (is_error(rest)) { + return rest; + } else { + lst = list_push(lst, rest); + } + + lst = list_reverse(lst); + return make_list(lst); + } +} + +MalType* eval_defmacrobang(MalType* ast, Env** env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'defmacro!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'defmacro!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, *env); + + if (!is_error(result)) { + result = copy_type(result); + result->is_macro = 1; + *env = env_set(*env, defbang_symbol, result); + } + return result; +} + +MalType* eval_macroexpand(MalType* ast, Env* env) { + + /* forward reference */ + MalType* macroexpand(MalType* ast, Env* env); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_nil(); + } + else if (lst->next->next) { + return make_error("'macroexpand': expected exactly one argument"); + } + else { + return macroexpand(lst->next->data, env); + } +} + +MalType* macroexpand(MalType* ast, Env* env) { + + /* forward reference */ + int is_macro_call(MalType* ast, Env* env); + + while(is_macro_call(ast, env)) { + + list lst = ast->value.mal_list; + + MalType* macro_fn = env_get(env, lst->data); + MalClosure* cls = macro_fn->value.mal_closure; + MalType* more_symbol = cls->more_symbol; + + list params_list = (cls->parameters)->value.mal_list; + list args_list = lst->next; + + env = env_make(cls->env, params_list, args_list, more_symbol); + ast = EVAL(cls->definition, env); + } + return ast; +} + +list evaluate_list(list lst, Env* env) { + + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_vector(list lst, Env* env) { + /* TODO: implement a real vector */ + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_hashmap(list lst, Env* env) { + /* TODO: implement a real hashmap */ + list evlst = NULL; + while (lst) { + + /* keys are unevaluated */ + evlst = list_push(evlst, lst->data); + lst = lst->next; + + /* values are evaluated */ + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +MalType* regularise_parameters(list* args, MalType** more_symbol) { + + /* forward reference */ + char* symbol_fn(gptr data); + + list regular_args = NULL; + while (*args) { + + MalType* val = (*args)->data; + + if (!is_symbol(val)) { + return make_error_fmt("non-symbol found in fn argument list '%s'", \ + pr_str(val, UNREADABLY)); + } + + if (val->value.mal_symbol[0] == '&') { + + /* & is found but there is no symbol */ + if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { + return make_error("missing symbol after '&' in argument list"); + } + /* & is found and there is a single symbol after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && + is_symbol((*args)->next->data) && !(*args)->next->next)) { + + /* TODO: check symbol is no a duplicate of one already on the list */ + *more_symbol = (*args)->next->data; + break; + } + /* & is found and there extra symbols after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { + return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ + pr_str((*args)->next->data, UNREADABLY), \ + pr_str((*args)->next->next->data, UNREADABLY)); + } + /* & is found as part of the symbol and no other symbols */ + else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { + *more_symbol = make_symbol((val->value.mal_symbol + 1)); + break; + } + /* & is found as part of the symbol but there are other symbols after */ + else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { + return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ + pr_str(val, UNREADABLY), \ + pr_str((*args)->next->data, UNREADABLY)); + } + } + + /* & is not found - add the symbol to the regular argument list */ + else { + + if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { + return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); + } + else { + regular_args = list_push(regular_args, val); + } + } + *args = (*args)->next; + } + + *args = list_reverse(regular_args); + return make_nil(); +} + +char* symbol_fn(gptr data) { + return (((MalType*)data)->value.mal_symbol); +} + +/* used by core functions but not EVAL as doesn't do TCE */ +MalType* apply(MalType* fn, list args) { + + if (is_function(fn)) { + + MalType* (*fun_ptr)(list) = fn->value.mal_function; + return (*fun_ptr)(args); + } + else { /* is_closure(fn) */ + + MalClosure* c = fn->value.mal_closure; + list params = (c->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(args); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !c->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + Env* env = env_make(c->env, params, args, c->more_symbol); + return EVAL(fn->value.mal_closure->definition, env); + } + } +} + +int is_macro_call(MalType* ast, Env* env) { + + /* not a list */ + if (!is_list(ast)) { + return 0; + } + + /* empty list */ + list lst = ast->value.mal_list; + if (!lst) { + return 0; + } + + /* first item not a symbol */ + MalType* first = lst->data; + if (!is_symbol(first)) { + return 0; + } + + /* lookup symbol */ + MalType* val = env_get(env, first); + if (is_error(val)) { + return 0; + } + else { + return (val->is_macro); + } +} diff --git a/impls/c.2/step9_try.c b/impls/c.2/step9_try.c index 5bcf328973..8ba82380a8 100644 --- a/impls/c.2/step9_try.c +++ b/impls/c.2/step9_try.c @@ -1,968 +1,968 @@ -#include -#include -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" -#include "env.h" -#include "core.h" - -#define SYMBOL_DEFBANG "def!" -#define SYMBOL_LETSTAR "let*" -#define SYMBOL_DO "do" -#define SYMBOL_IF "if" -#define SYMBOL_FNSTAR "fn*" -#define SYMBOL_QUOTE "quote" -#define SYMBOL_QUASIQUOTE "quasiquote" -#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand" -#define SYMBOL_UNQUOTE "unquote" -#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" -#define SYMBOL_DEFMACROBANG "defmacro!" -#define SYMBOL_MACROEXPAND "macroexpand" -#define SYMBOL_TRYSTAR "try*" -#define SYMBOL_CATCHSTAR "catch*" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* ast, Env* env) { - - /* forward references */ - MalType* eval_ast(MalType* ast, Env* env); - MalType* eval_defbang(MalType* ast, Env** env); - void eval_letstar(MalType** ast, Env** env); - void eval_if(MalType** ast, Env** env); - MalType* eval_fnstar(MalType* ast, Env* env); - MalType* eval_do(MalType* ast, Env* env); - MalType* eval_quote(MalType* ast); - MalType* eval_quasiquote(MalType* ast); - MalType* eval_quasiquoteexpand(MalType* ast); - MalType* eval_defmacrobang(MalType*, Env** env); - MalType* eval_macroexpand(MalType* ast, Env* env); - MalType* macroexpand(MalType* ast, Env* env); - void eval_try(MalType** ast, Env** env); - - /* Use goto to jump here rather than calling eval for tail-call elimination */ - TCE_entry_point: - - /* NULL */ - if (!ast) { return make_nil(); } - - /* macroexpansion */ - ast = macroexpand(ast, env); - if (is_error(ast)) { return ast; } - - /* not a list */ - if (!is_list(ast)) { return eval_ast(ast, env); } - - /* empty list */ - if (ast->value.mal_list == NULL) { return ast; } - - /* list */ - MalType* first = (ast->value.mal_list)->data; - char* symbol = first->value.mal_symbol; - - if (is_symbol(first)) { - - /* handle special symbols first */ - if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { - return eval_defbang(ast, &env); - } - else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - eval_letstar(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_IF) == 0) { - - /* TCE - modify ast directly and jump back to eval */ - eval_if(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { - return eval_fnstar(ast, env); - } - else if (strcmp(symbol, SYMBOL_DO) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - ast = eval_do(ast, env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_QUOTE) == 0) { - return eval_quote(ast); - } - else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) { - - ast = eval_quasiquote(ast); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) { - - list lst = ast->value.mal_list; - return eval_quasiquote(make_list(lst)); - } - else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) { - return eval_defmacrobang(ast, &env); - } - else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) { - return eval_macroexpand(ast, env); - } - else if (strcmp(symbol, SYMBOL_TRYSTAR) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - eval_try(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - } - /* first element is not a special symbol */ - MalType* evaluated_list = eval_ast(ast, env); - - if (is_error(evaluated_list)) { return evaluated_list; } - - /* apply the first element of the list to the arguments */ - list evlst = evaluated_list->value.mal_list; - MalType* func = evlst->data; - - if (is_function(func)) { - return (*func->value.mal_function)(evlst->next); - } - else if (is_closure(func)) { - - MalClosure* closure = func->value.mal_closure; - list params = (closure->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(evlst->next); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !closure->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - - /* TCE - modify ast and env directly and jump back to eval */ - env = env_make(closure->env, params, evlst->next, closure->more_symbol); - ast = func->value.mal_closure->definition; - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - } - else { - return make_error_fmt("first item in list is not callable: '%s'", \ - pr_str(func, UNREADABLY)); - } -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str, Env* env) { - - PRINT(EVAL(READ(str), env)); -} - -/* declare as global so it can be accessed by mal_eval */ -Env* global_env; - -MalType* mal_eval(list args) { - - MalType* ast = args->data; - return EVAL(ast, global_env); -} - - -int main(int argc, char** argv) { - - Env* repl_env = env_make(NULL, NULL, NULL, NULL); - global_env = repl_env; - - ns* core = ns_make_core(); - hashmap mappings = core->mappings; - - while (mappings) { - char* symbol = mappings->data; - MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; - - env_set_C_fn(repl_env, symbol, function); - - /* pop symbol and function from hashmap/list */ - mappings = mappings->next->next; - } - - env_set_C_fn(repl_env, "eval", mal_eval); - - /* add functions written in mal - not using rep as it prints the result */ - EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); - EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); - EVAL(READ("(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)))))))"), repl_env); - - /* make command line arguments available in the environment */ - list lst = NULL; - for (long i = 2; i < argc; i++) { - lst = list_push(lst, make_string(argv[i])); - } - env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); - - /* run in script mode if a filename is given */ - if (argc > 1) { - - /* first argument on command line is filename */ - char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); - EVAL(READ(load_command), repl_env); - } - /* run in repl mode when no cmd line args */ - else { - - /* Greeting message */ - puts("Make-a-lisp version 0.0.9\n"); - puts("Press Ctrl+d to exit\n"); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input, repl_env); - - /* have to release the memory used by readline */ - free(input); - } - } - return 0; -} - -MalType* eval_ast(MalType* ast, Env* env) { - - /* forward references */ - list evaluate_list(list lst, Env* env); - list evaluate_vector(list lst, Env* env); - list evaluate_hashmap(list lst, Env* env); - - if (is_symbol(ast)) { - - MalType* symbol_value = env_get(env, ast); - - if (symbol_value) { - return symbol_value; - } else { - return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); - } - } - else if (is_list(ast)) { - - list result = evaluate_list(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_list(result); - } else { - return result->data; - } - } - else if (is_vector(ast)) { - - list result = evaluate_vector(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_vector(result); - } else { - return result->data; - } - } - else if (is_hashmap(ast)) { - - list result = evaluate_hashmap(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_hashmap(result); - } else { - return result->data; - } - } - else { - return ast; - } -} - -MalType* eval_defbang(MalType* ast, Env** env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'def!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'def!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, *env); - - if (!is_error(result)){ - *env = env_set(*env, defbang_symbol, result); - } - return result; -} - -void eval_letstar(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next) { - *ast = make_error("'let*': missing bindings list"); - return; - } - - MalType* bindings = lst->next->data; - MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); - - if (!is_sequential(bindings)) { - *ast = make_error("'let*': first argument is not list or vector"); - return; - } - - list bindings_list = bindings->value.mal_list; - if (list_count(bindings_list) % 2 == 1) { - *ast = make_error("'let*': expected an even number of binding pairs"); - return; - } - - Env* letstar_env = env_make(*env, NULL, NULL, NULL); - - /* evaluate the bindings */ - while(bindings_list) { - - MalType* symbol = bindings_list->data; - MalType* value = EVAL(bindings_list->next->data, letstar_env); - - /* early return from error */ - if (is_error(value)) { - *ast = value; - return; - } - - env_set(letstar_env, symbol, value); - bindings_list = bindings_list->next->next; - } - - *env = letstar_env; - *ast = forms; - return; -} - -void eval_if(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next || !lst->next->next) { - *ast = make_error("'if': too few arguments"); - return; - } - - if (lst->next->next->next && lst->next->next->next->next) { - *ast = make_error("'if': too many arguments"); - return; - } - - MalType* condition = EVAL(lst->next->data, *env); - - if (is_error(condition)) { - *ast = condition; - return; - } - - if (is_false(condition) || is_nil(condition)) { - - /* check whether false branch is present */ - if (lst->next->next->next) { - *ast = lst->next->next->next->data; - return; - } - else { - *ast = make_nil(); - return; - } - - } else { - *ast = lst->next->next->data; - return; - } -} - -MalType* eval_fnstar(MalType* ast, Env* env) { - - /* forward reference */ - MalType* regularise_parameters(list* params, MalType** more); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_error("'fn*': missing argument list"); - } - else if (!lst->next->next) { - return make_error("'fn*': missing function body"); - } - - MalType* params = lst->next->data; - list params_list = params->value.mal_list; - - MalType* more_symbol = NULL; - - MalType* result = regularise_parameters(¶ms_list, &more_symbol); - if (is_error(result)) { return result; } - - MalType* definition = lst->next->next->data; - MalType* regular_params = make_list(params_list); - - return make_closure(env, regular_params, definition, more_symbol); -} - -MalType* eval_do(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - - /* handle empty 'do' */ - if (!lst->next) { - return make_nil(); - } - - /* evaluate all but the last form */ - lst = lst->next; - while (lst->next) { - - MalType* val = EVAL(lst->data, env); - - /* return error early */ - if (is_error(val)) { - return val; - } - lst = lst->next; - } - /* return the last form for TCE evaluation */ - return lst->data; -} - -MalType* eval_quote(MalType* ast) { - - list lst = (ast->value.mal_list)->next; - - if (!lst) { - return make_nil(); - } - else if (lst->next) { - return make_error("'quote': expected exactly one argument"); - } - else { - return lst->data; - } -} - -MalType* eval_quasiquote(MalType* ast) { - - /* forward reference */ - MalType* quasiquote(MalType* ast); - - list lst = ast->value.mal_list; - - /* no arguments (quasiquote) */ - if (!lst->next) { - return make_nil(); - } - - /* too many arguments */ - else if (lst->next->next) { - return make_error("'quasiquote': expected exactly one argument"); - } - return quasiquote(lst->next->data); -} - -MalType* quasiquote(MalType* ast) { - - /* forward references */ - MalType* quasiquote_list(MalType* ast); - MalType* quasiquote_vector(MalType* ast); - - /* argument to quasiquote is self-evaluating: (quasiquote val) - => val */ - if (is_self_evaluating(ast)) { - return ast; - } - - /* argument to quasiquote is a vector: (quasiquote [first rest]) */ - else if (is_vector(ast)) { - - return quasiquote_vector(ast); - } - - /* argument to quasiquote is a list: (quasiquote (first rest)) */ - else if (is_list(ast)){ - - return quasiquote_list(ast); - } - /* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val) - => (quote val) */ - else { - - list lst = list_make(ast); - lst = list_push(lst, make_symbol("quote")); - return make_list(lst); - } -} - -MalType* quasiquote_vector(MalType* ast) { - - /* forward references */ - MalType* quasiquote_list(MalType* ast); - - list args = ast->value.mal_list; - - if (args) { - - MalType* first = args->data; - - /* if first element is unquote return quoted */ - if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) { - - list lst = list_make(ast); - lst = list_push(lst, make_symbol("quote")); - - return make_list(lst); - } - } - - /* otherwise process like a list */ - - list lst = list_make(make_symbol("vec")); - - MalType* result = quasiquote_list(ast); - - if (is_error(result)) { - return result; - } else { - lst = list_push(lst, result); - } - - lst = list_reverse(lst); - return make_list(lst); -} - -MalType* quasiquote_list(MalType* ast) { - - list args = ast->value.mal_list; - - /* handle empty list: (quasiquote ()) - => () */ - if (!args) { - return make_list(NULL); - } - - MalType* first = args->data; - - /* handle unquote: (quasiquote (unquote second)) - => second */ - if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) { - - if (args->next->next) { - return make_error("'quasiquote': unquote expected exactly one argument"); - } - else { - return args->next->data; - } - } - - /* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest)) - => (concat first-second (quasiquote rest)) */ - else if (is_list(first) && - first->value.mal_list != NULL && - is_symbol(first->value.mal_list->data) && - strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) { - - if (!first->value.mal_list->next) { - return make_error("'quasiquote': splice-unquote expected exactly one argument"); - } - - MalType* first_second = first->value.mal_list->next->data; - list lst = list_make(make_symbol("concat")); - lst = list_push(lst, first_second); - - MalType* rest = quasiquote(make_list(args->next)); - if (is_error(rest)) { - return rest; - } - - lst = list_push(lst, rest); - lst = list_reverse(lst); - - return make_list(lst); - } - /* handle all other lists recursively: (quasiquote (first rest)) - => (cons (quasiquote first) (quasiquote rest)) */ - else { - - list lst = list_make(make_symbol("cons")); - - MalType* first = quasiquote(args->data); - if (is_error(first)) { - return first; - } else { - lst = list_push(lst, first); - } - - MalType* rest = quasiquote(make_list(args->next)); - if (is_error(rest)) { - return rest; - } else { - lst = list_push(lst, rest); - } - - lst = list_reverse(lst); - return make_list(lst); - } -} - -MalType* eval_defmacrobang(MalType* ast, Env** env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'defmacro!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'defmacro!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, *env); - - if (!is_error(result)) { - result = copy_type(result); - result->is_macro = 1; - *env = env_set(*env, defbang_symbol, result); - } - return result; -} - -MalType* eval_macroexpand(MalType* ast, Env* env) { - - /* forward reference */ - MalType* macroexpand(MalType* ast, Env* env); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_nil(); - } - else if (lst->next->next) { - return make_error("'macroexpand': expected exactly one argument"); - } - else { - return macroexpand(lst->next->data, env); - } -} - -MalType* macroexpand(MalType* ast, Env* env) { - - /* forward reference */ - int is_macro_call(MalType* ast, Env* env); - - while(is_macro_call(ast, env)) { - - list lst = ast->value.mal_list; - - MalType* macro_fn = env_get(env, lst->data); - MalClosure* cls = macro_fn->value.mal_closure; - MalType* more_symbol = cls->more_symbol; - - list params_list = (cls->parameters)->value.mal_list; - list args_list = lst->next; - - env = env_make(cls->env, params_list, args_list, more_symbol); - ast = EVAL(cls->definition, env); - } - return ast; -} - -void eval_try(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next) { - *ast = make_nil(); - return; - } - - if (lst->next->next && lst->next->next->next) { - *ast = make_error("'try*': expected maximum of two arguments"); - return; - } - - MalType* try_clause = lst->next->data; - MalType* try_result = EVAL(try_clause, *env); - - /* no catch* clause */ - if (!is_error(try_result) || !lst->next->next) { - *ast = try_result; - return; - } - - /* process catch* clause */ - MalType* catch_clause = lst->next->next->data; - list catch_list = catch_clause->value.mal_list; - - if (!catch_list) { - *ast = make_error("'try*': catch* clause is empty"); - return; - } - - MalType* catch_symbol = catch_list->data; - if (strcmp(catch_symbol->value.mal_symbol, SYMBOL_CATCHSTAR) != 0) { - *ast = make_error("Error: catch clause is missing catch* symbol"); - return; - } - - if (!catch_list->next || !catch_list->next->next) { - *ast = make_error("Error: catch* clause expected two arguments"); - return; - } - - if (!is_symbol(catch_list->next->data)) { - *ast = make_error("Error: catch* clause expected a symbol"); - return; - } - - /* bind the symbol to the exception */ - list symbol_list = list_make(catch_list->next->data); - list expr_list = list_make(try_result->value.mal_error); - - /* TODO: validate symbols and exprs match before calling env_make */ - Env* catch_env = env_make(*env, symbol_list, expr_list, NULL); - *ast = catch_list->next->next->data; - *env = catch_env; - - return; -} - -list evaluate_list(list lst, Env* env) { - - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_vector(list lst, Env* env) { - /* TODO: implement a real vector */ - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_hashmap(list lst, Env* env) { - /* TODO: implement a real hashmap */ - list evlst = NULL; - while (lst) { - - /* keys are unevaluated */ - evlst = list_push(evlst, lst->data); - lst = lst->next; - - /* values are evaluated */ - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -MalType* regularise_parameters(list* args, MalType** more_symbol) { - - /* forward reference */ - char* symbol_fn(gptr data); - - list regular_args = NULL; - while (*args) { - - MalType* val = (*args)->data; - - if (!is_symbol(val)) { - return make_error_fmt("non-symbol found in fn argument list '%s'", \ - pr_str(val, UNREADABLY)); - } - - if (val->value.mal_symbol[0] == '&') { - - /* & is found but there is no symbol */ - if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { - return make_error("missing symbol after '&' in argument list"); - } - /* & is found and there is a single symbol after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && - is_symbol((*args)->next->data) && !(*args)->next->next)) { - - /* TODO: check symbol is no a duplicate of one already on the list */ - *more_symbol = (*args)->next->data; - break; - } - /* & is found and there extra symbols after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { - return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ - pr_str((*args)->next->data, UNREADABLY), \ - pr_str((*args)->next->next->data, UNREADABLY)); - } - /* & is found as part of the symbol and no other symbols */ - else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { - *more_symbol = make_symbol((val->value.mal_symbol + 1)); - break; - } - /* & is found as part of the symbol but there are other symbols after */ - else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { - return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ - pr_str(val, UNREADABLY), \ - pr_str((*args)->next->data, UNREADABLY)); - } - } - - /* & is not found - add the symbol to the regular argument list */ - else { - - if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { - return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); - } - else { - regular_args = list_push(regular_args, val); - } - } - *args = (*args)->next; - } - - *args = list_reverse(regular_args); - return make_nil(); -} - -char* symbol_fn(gptr data) { - return (((MalType*)data)->value.mal_symbol); -} - -/* used by core functions but not EVAL as doesn't do TCE */ -MalType* apply(MalType* fn, list args) { - - if (is_function(fn)) { - - MalType* (*fun_ptr)(list) = fn->value.mal_function; - return (*fun_ptr)(args); - } - else { /* is_closure(fn) */ - - MalClosure* c = fn->value.mal_closure; - list params = (c->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(args); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !c->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - Env* env = env_make(c->env, params, args, c->more_symbol); - return EVAL(fn->value.mal_closure->definition, env); - } - } -} - -int is_macro_call(MalType* ast, Env* env) { - - /* not a list */ - if (!is_list(ast)) { - return 0; - } - - /* empty list */ - list lst = ast->value.mal_list; - if (!lst) { - return 0; - } - - /* first item not a symbol */ - MalType* first = lst->data; - if (!is_symbol(first)) { - return 0; - } - - /* lookup symbol */ - MalType* val = env_get(env, first); - if (is_error(val)) { - return 0; - } - else { - return (val->is_macro); - } -} +#include +#include +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" +#include "env.h" +#include "core.h" + +#define SYMBOL_DEFBANG "def!" +#define SYMBOL_LETSTAR "let*" +#define SYMBOL_DO "do" +#define SYMBOL_IF "if" +#define SYMBOL_FNSTAR "fn*" +#define SYMBOL_QUOTE "quote" +#define SYMBOL_QUASIQUOTE "quasiquote" +#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand" +#define SYMBOL_UNQUOTE "unquote" +#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" +#define SYMBOL_DEFMACROBANG "defmacro!" +#define SYMBOL_MACROEXPAND "macroexpand" +#define SYMBOL_TRYSTAR "try*" +#define SYMBOL_CATCHSTAR "catch*" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* ast, Env* env) { + + /* forward references */ + MalType* eval_ast(MalType* ast, Env* env); + MalType* eval_defbang(MalType* ast, Env** env); + void eval_letstar(MalType** ast, Env** env); + void eval_if(MalType** ast, Env** env); + MalType* eval_fnstar(MalType* ast, Env* env); + MalType* eval_do(MalType* ast, Env* env); + MalType* eval_quote(MalType* ast); + MalType* eval_quasiquote(MalType* ast); + MalType* eval_quasiquoteexpand(MalType* ast); + MalType* eval_defmacrobang(MalType*, Env** env); + MalType* eval_macroexpand(MalType* ast, Env* env); + MalType* macroexpand(MalType* ast, Env* env); + void eval_try(MalType** ast, Env** env); + + /* Use goto to jump here rather than calling eval for tail-call elimination */ + TCE_entry_point: + + /* NULL */ + if (!ast) { return make_nil(); } + + /* macroexpansion */ + ast = macroexpand(ast, env); + if (is_error(ast)) { return ast; } + + /* not a list */ + if (!is_list(ast)) { return eval_ast(ast, env); } + + /* empty list */ + if (ast->value.mal_list == NULL) { return ast; } + + /* list */ + MalType* first = (ast->value.mal_list)->data; + char* symbol = first->value.mal_symbol; + + if (is_symbol(first)) { + + /* handle special symbols first */ + if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { + return eval_defbang(ast, &env); + } + else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + eval_letstar(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_IF) == 0) { + + /* TCE - modify ast directly and jump back to eval */ + eval_if(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { + return eval_fnstar(ast, env); + } + else if (strcmp(symbol, SYMBOL_DO) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + ast = eval_do(ast, env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_QUOTE) == 0) { + return eval_quote(ast); + } + else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) { + + ast = eval_quasiquote(ast); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) { + + list lst = ast->value.mal_list; + return eval_quasiquote(make_list(lst)); + } + else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) { + return eval_defmacrobang(ast, &env); + } + else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) { + return eval_macroexpand(ast, env); + } + else if (strcmp(symbol, SYMBOL_TRYSTAR) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + eval_try(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + } + /* first element is not a special symbol */ + MalType* evaluated_list = eval_ast(ast, env); + + if (is_error(evaluated_list)) { return evaluated_list; } + + /* apply the first element of the list to the arguments */ + list evlst = evaluated_list->value.mal_list; + MalType* func = evlst->data; + + if (is_function(func)) { + return (*func->value.mal_function)(evlst->next); + } + else if (is_closure(func)) { + + MalClosure* closure = func->value.mal_closure; + list params = (closure->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(evlst->next); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !closure->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + + /* TCE - modify ast and env directly and jump back to eval */ + env = env_make(closure->env, params, evlst->next, closure->more_symbol); + ast = func->value.mal_closure->definition; + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + } + else { + return make_error_fmt("first item in list is not callable: '%s'", \ + pr_str(func, UNREADABLY)); + } +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str, Env* env) { + + PRINT(EVAL(READ(str), env)); +} + +/* declare as global so it can be accessed by mal_eval */ +Env* global_env; + +MalType* mal_eval(list args) { + + MalType* ast = args->data; + return EVAL(ast, global_env); +} + + +int main(int argc, char** argv) { + + Env* repl_env = env_make(NULL, NULL, NULL, NULL); + global_env = repl_env; + + ns* core = ns_make_core(); + hashmap mappings = core->mappings; + + while (mappings) { + char* symbol = mappings->data; + MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data; + + env_set_C_fn(repl_env, symbol, function); + + /* pop symbol and function from hashmap/list */ + mappings = mappings->next->next; + } + + env_set_C_fn(repl_env, "eval", mal_eval); + + /* add functions written in mal - not using rep as it prints the result */ + EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); + EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); + EVAL(READ("(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)))))))"), repl_env); + + /* make command line arguments available in the environment */ + list lst = NULL; + for (long i = 2; i < argc; i++) { + lst = list_push(lst, make_string(argv[i])); + } + env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); + + /* run in script mode if a filename is given */ + if (argc > 1) { + + /* first argument on command line is filename */ + char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); + EVAL(READ(load_command), repl_env); + } + /* run in repl mode when no cmd line args */ + else { + + /* Greeting message */ + puts("Make-a-lisp version 0.0.9\n"); + puts("Press Ctrl+d to exit\n"); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input, repl_env); + + /* have to release the memory used by readline */ + free(input); + } + } + return 0; +} + +MalType* eval_ast(MalType* ast, Env* env) { + + /* forward references */ + list evaluate_list(list lst, Env* env); + list evaluate_vector(list lst, Env* env); + list evaluate_hashmap(list lst, Env* env); + + if (is_symbol(ast)) { + + MalType* symbol_value = env_get(env, ast); + + if (symbol_value) { + return symbol_value; + } else { + return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); + } + } + else if (is_list(ast)) { + + list result = evaluate_list(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_list(result); + } else { + return result->data; + } + } + else if (is_vector(ast)) { + + list result = evaluate_vector(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_vector(result); + } else { + return result->data; + } + } + else if (is_hashmap(ast)) { + + list result = evaluate_hashmap(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_hashmap(result); + } else { + return result->data; + } + } + else { + return ast; + } +} + +MalType* eval_defbang(MalType* ast, Env** env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'def!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'def!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, *env); + + if (!is_error(result)){ + *env = env_set(*env, defbang_symbol, result); + } + return result; +} + +void eval_letstar(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next) { + *ast = make_error("'let*': missing bindings list"); + return; + } + + MalType* bindings = lst->next->data; + MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); + + if (!is_sequential(bindings)) { + *ast = make_error("'let*': first argument is not list or vector"); + return; + } + + list bindings_list = bindings->value.mal_list; + if (list_count(bindings_list) % 2 == 1) { + *ast = make_error("'let*': expected an even number of binding pairs"); + return; + } + + Env* letstar_env = env_make(*env, NULL, NULL, NULL); + + /* evaluate the bindings */ + while(bindings_list) { + + MalType* symbol = bindings_list->data; + MalType* value = EVAL(bindings_list->next->data, letstar_env); + + /* early return from error */ + if (is_error(value)) { + *ast = value; + return; + } + + env_set(letstar_env, symbol, value); + bindings_list = bindings_list->next->next; + } + + *env = letstar_env; + *ast = forms; + return; +} + +void eval_if(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next || !lst->next->next) { + *ast = make_error("'if': too few arguments"); + return; + } + + if (lst->next->next->next && lst->next->next->next->next) { + *ast = make_error("'if': too many arguments"); + return; + } + + MalType* condition = EVAL(lst->next->data, *env); + + if (is_error(condition)) { + *ast = condition; + return; + } + + if (is_false(condition) || is_nil(condition)) { + + /* check whether false branch is present */ + if (lst->next->next->next) { + *ast = lst->next->next->next->data; + return; + } + else { + *ast = make_nil(); + return; + } + + } else { + *ast = lst->next->next->data; + return; + } +} + +MalType* eval_fnstar(MalType* ast, Env* env) { + + /* forward reference */ + MalType* regularise_parameters(list* params, MalType** more); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_error("'fn*': missing argument list"); + } + else if (!lst->next->next) { + return make_error("'fn*': missing function body"); + } + + MalType* params = lst->next->data; + list params_list = params->value.mal_list; + + MalType* more_symbol = NULL; + + MalType* result = regularise_parameters(¶ms_list, &more_symbol); + if (is_error(result)) { return result; } + + MalType* definition = lst->next->next->data; + MalType* regular_params = make_list(params_list); + + return make_closure(env, regular_params, definition, more_symbol); +} + +MalType* eval_do(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + + /* handle empty 'do' */ + if (!lst->next) { + return make_nil(); + } + + /* evaluate all but the last form */ + lst = lst->next; + while (lst->next) { + + MalType* val = EVAL(lst->data, env); + + /* return error early */ + if (is_error(val)) { + return val; + } + lst = lst->next; + } + /* return the last form for TCE evaluation */ + return lst->data; +} + +MalType* eval_quote(MalType* ast) { + + list lst = (ast->value.mal_list)->next; + + if (!lst) { + return make_nil(); + } + else if (lst->next) { + return make_error("'quote': expected exactly one argument"); + } + else { + return lst->data; + } +} + +MalType* eval_quasiquote(MalType* ast) { + + /* forward reference */ + MalType* quasiquote(MalType* ast); + + list lst = ast->value.mal_list; + + /* no arguments (quasiquote) */ + if (!lst->next) { + return make_nil(); + } + + /* too many arguments */ + else if (lst->next->next) { + return make_error("'quasiquote': expected exactly one argument"); + } + return quasiquote(lst->next->data); +} + +MalType* quasiquote(MalType* ast) { + + /* forward references */ + MalType* quasiquote_list(MalType* ast); + MalType* quasiquote_vector(MalType* ast); + + /* argument to quasiquote is self-evaluating: (quasiquote val) + => val */ + if (is_self_evaluating(ast)) { + return ast; + } + + /* argument to quasiquote is a vector: (quasiquote [first rest]) */ + else if (is_vector(ast)) { + + return quasiquote_vector(ast); + } + + /* argument to quasiquote is a list: (quasiquote (first rest)) */ + else if (is_list(ast)){ + + return quasiquote_list(ast); + } + /* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val) + => (quote val) */ + else { + + list lst = list_make(ast); + lst = list_push(lst, make_symbol("quote")); + return make_list(lst); + } +} + +MalType* quasiquote_vector(MalType* ast) { + + /* forward references */ + MalType* quasiquote_list(MalType* ast); + + list args = ast->value.mal_list; + + if (args) { + + MalType* first = args->data; + + /* if first element is unquote return quoted */ + if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) { + + list lst = list_make(ast); + lst = list_push(lst, make_symbol("quote")); + + return make_list(lst); + } + } + + /* otherwise process like a list */ + + list lst = list_make(make_symbol("vec")); + + MalType* result = quasiquote_list(ast); + + if (is_error(result)) { + return result; + } else { + lst = list_push(lst, result); + } + + lst = list_reverse(lst); + return make_list(lst); +} + +MalType* quasiquote_list(MalType* ast) { + + list args = ast->value.mal_list; + + /* handle empty list: (quasiquote ()) + => () */ + if (!args) { + return make_list(NULL); + } + + MalType* first = args->data; + + /* handle unquote: (quasiquote (unquote second)) + => second */ + if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) { + + if (args->next->next) { + return make_error("'quasiquote': unquote expected exactly one argument"); + } + else { + return args->next->data; + } + } + + /* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest)) + => (concat first-second (quasiquote rest)) */ + else if (is_list(first) && + first->value.mal_list != NULL && + is_symbol(first->value.mal_list->data) && + strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) { + + if (!first->value.mal_list->next) { + return make_error("'quasiquote': splice-unquote expected exactly one argument"); + } + + MalType* first_second = first->value.mal_list->next->data; + list lst = list_make(make_symbol("concat")); + lst = list_push(lst, first_second); + + MalType* rest = quasiquote(make_list(args->next)); + if (is_error(rest)) { + return rest; + } + + lst = list_push(lst, rest); + lst = list_reverse(lst); + + return make_list(lst); + } + /* handle all other lists recursively: (quasiquote (first rest)) + => (cons (quasiquote first) (quasiquote rest)) */ + else { + + list lst = list_make(make_symbol("cons")); + + MalType* first = quasiquote(args->data); + if (is_error(first)) { + return first; + } else { + lst = list_push(lst, first); + } + + MalType* rest = quasiquote(make_list(args->next)); + if (is_error(rest)) { + return rest; + } else { + lst = list_push(lst, rest); + } + + lst = list_reverse(lst); + return make_list(lst); + } +} + +MalType* eval_defmacrobang(MalType* ast, Env** env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'defmacro!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'defmacro!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, *env); + + if (!is_error(result)) { + result = copy_type(result); + result->is_macro = 1; + *env = env_set(*env, defbang_symbol, result); + } + return result; +} + +MalType* eval_macroexpand(MalType* ast, Env* env) { + + /* forward reference */ + MalType* macroexpand(MalType* ast, Env* env); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_nil(); + } + else if (lst->next->next) { + return make_error("'macroexpand': expected exactly one argument"); + } + else { + return macroexpand(lst->next->data, env); + } +} + +MalType* macroexpand(MalType* ast, Env* env) { + + /* forward reference */ + int is_macro_call(MalType* ast, Env* env); + + while(is_macro_call(ast, env)) { + + list lst = ast->value.mal_list; + + MalType* macro_fn = env_get(env, lst->data); + MalClosure* cls = macro_fn->value.mal_closure; + MalType* more_symbol = cls->more_symbol; + + list params_list = (cls->parameters)->value.mal_list; + list args_list = lst->next; + + env = env_make(cls->env, params_list, args_list, more_symbol); + ast = EVAL(cls->definition, env); + } + return ast; +} + +void eval_try(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next) { + *ast = make_nil(); + return; + } + + if (lst->next->next && lst->next->next->next) { + *ast = make_error("'try*': expected maximum of two arguments"); + return; + } + + MalType* try_clause = lst->next->data; + MalType* try_result = EVAL(try_clause, *env); + + /* no catch* clause */ + if (!is_error(try_result) || !lst->next->next) { + *ast = try_result; + return; + } + + /* process catch* clause */ + MalType* catch_clause = lst->next->next->data; + list catch_list = catch_clause->value.mal_list; + + if (!catch_list) { + *ast = make_error("'try*': catch* clause is empty"); + return; + } + + MalType* catch_symbol = catch_list->data; + if (strcmp(catch_symbol->value.mal_symbol, SYMBOL_CATCHSTAR) != 0) { + *ast = make_error("Error: catch clause is missing catch* symbol"); + return; + } + + if (!catch_list->next || !catch_list->next->next) { + *ast = make_error("Error: catch* clause expected two arguments"); + return; + } + + if (!is_symbol(catch_list->next->data)) { + *ast = make_error("Error: catch* clause expected a symbol"); + return; + } + + /* bind the symbol to the exception */ + list symbol_list = list_make(catch_list->next->data); + list expr_list = list_make(try_result->value.mal_error); + + /* TODO: validate symbols and exprs match before calling env_make */ + Env* catch_env = env_make(*env, symbol_list, expr_list, NULL); + *ast = catch_list->next->next->data; + *env = catch_env; + + return; +} + +list evaluate_list(list lst, Env* env) { + + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_vector(list lst, Env* env) { + /* TODO: implement a real vector */ + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_hashmap(list lst, Env* env) { + /* TODO: implement a real hashmap */ + list evlst = NULL; + while (lst) { + + /* keys are unevaluated */ + evlst = list_push(evlst, lst->data); + lst = lst->next; + + /* values are evaluated */ + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +MalType* regularise_parameters(list* args, MalType** more_symbol) { + + /* forward reference */ + char* symbol_fn(gptr data); + + list regular_args = NULL; + while (*args) { + + MalType* val = (*args)->data; + + if (!is_symbol(val)) { + return make_error_fmt("non-symbol found in fn argument list '%s'", \ + pr_str(val, UNREADABLY)); + } + + if (val->value.mal_symbol[0] == '&') { + + /* & is found but there is no symbol */ + if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { + return make_error("missing symbol after '&' in argument list"); + } + /* & is found and there is a single symbol after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && + is_symbol((*args)->next->data) && !(*args)->next->next)) { + + /* TODO: check symbol is no a duplicate of one already on the list */ + *more_symbol = (*args)->next->data; + break; + } + /* & is found and there extra symbols after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { + return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ + pr_str((*args)->next->data, UNREADABLY), \ + pr_str((*args)->next->next->data, UNREADABLY)); + } + /* & is found as part of the symbol and no other symbols */ + else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { + *more_symbol = make_symbol((val->value.mal_symbol + 1)); + break; + } + /* & is found as part of the symbol but there are other symbols after */ + else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { + return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ + pr_str(val, UNREADABLY), \ + pr_str((*args)->next->data, UNREADABLY)); + } + } + + /* & is not found - add the symbol to the regular argument list */ + else { + + if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { + return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY)); + } + else { + regular_args = list_push(regular_args, val); + } + } + *args = (*args)->next; + } + + *args = list_reverse(regular_args); + return make_nil(); +} + +char* symbol_fn(gptr data) { + return (((MalType*)data)->value.mal_symbol); +} + +/* used by core functions but not EVAL as doesn't do TCE */ +MalType* apply(MalType* fn, list args) { + + if (is_function(fn)) { + + MalType* (*fun_ptr)(list) = fn->value.mal_function; + return (*fun_ptr)(args); + } + else { /* is_closure(fn) */ + + MalClosure* c = fn->value.mal_closure; + list params = (c->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(args); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !c->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + Env* env = env_make(c->env, params, args, c->more_symbol); + return EVAL(fn->value.mal_closure->definition, env); + } + } +} + +int is_macro_call(MalType* ast, Env* env) { + + /* not a list */ + if (!is_list(ast)) { + return 0; + } + + /* empty list */ + list lst = ast->value.mal_list; + if (!lst) { + return 0; + } + + /* first item not a symbol */ + MalType* first = lst->data; + if (!is_symbol(first)) { + return 0; + } + + /* lookup symbol */ + MalType* val = env_get(env, first); + if (is_error(val)) { + return 0; + } + else { + return (val->is_macro); + } +} diff --git a/impls/c.2/stepA_mal.c b/impls/c.2/stepA_mal.c index 8cd1a51d3d..68c19ec4f7 100644 --- a/impls/c.2/stepA_mal.c +++ b/impls/c.2/stepA_mal.c @@ -1,992 +1,992 @@ -#include -#include -#include -#include -#include - -#include -#include - -#include "types.h" -#include "reader.h" -#include "printer.h" -#include "env.h" -#include "core.h" - -#define SYMBOL_DEFBANG "def!" -#define SYMBOL_LETSTAR "let*" -#define SYMBOL_DO "do" -#define SYMBOL_IF "if" -#define SYMBOL_FNSTAR "fn*" -#define SYMBOL_QUOTE "quote" -#define SYMBOL_QUASIQUOTE "quasiquote" -#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand" -#define SYMBOL_UNQUOTE "unquote" -#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" -#define SYMBOL_DEFMACROBANG "defmacro!" -#define SYMBOL_MACROEXPAND "macroexpand" -#define SYMBOL_TRYSTAR "try*" -#define SYMBOL_CATCHSTAR "catch*" - -#define PROMPT_STRING "user> " - -MalType* READ(char* str) { - - return read_str(str); -} - -MalType* EVAL(MalType* ast, Env* env) { - - /* forward references */ - MalType* eval_ast(MalType* ast, Env* env); - MalType* eval_defbang(MalType* ast, Env** env); - void eval_letstar(MalType** ast, Env** env); - void eval_if(MalType** ast, Env** env); - MalType* eval_fnstar(MalType* ast, Env* env); - MalType* eval_do(MalType* ast, Env* env); - MalType* eval_quote(MalType* ast); - MalType* eval_quasiquote(MalType* ast); - MalType* eval_quasiquoteexpand(MalType* ast); - MalType* eval_defmacrobang(MalType*, Env** env); - MalType* eval_macroexpand(MalType* ast, Env* env); - MalType* macroexpand(MalType* ast, Env* env); - void eval_try(MalType** ast, Env** env); - - /* Use goto to jump here rather than calling eval for tail-call elimination */ - TCE_entry_point: - - /* NULL */ - if (!ast) { return make_nil(); } - - /* macroexpansion */ - ast = macroexpand(ast, env); - if (is_error(ast)) { return ast; } - - /* not a list */ - if (!is_list(ast)) { return eval_ast(ast, env); } - - /* empty list */ - if (ast->value.mal_list == NULL) { return ast; } - - /* list */ - MalType* first = (ast->value.mal_list)->data; - char* symbol = first->value.mal_symbol; - - if (is_symbol(first)) { - - /* handle special symbols first */ - if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { - return eval_defbang(ast, &env); - } - else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - eval_letstar(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_IF) == 0) { - - /* TCE - modify ast directly and jump back to eval */ - eval_if(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { - return eval_fnstar(ast, env); - } - else if (strcmp(symbol, SYMBOL_DO) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - ast = eval_do(ast, env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_QUOTE) == 0) { - return eval_quote(ast); - } - else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) { - - ast = eval_quasiquote(ast); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) { - - list lst = ast->value.mal_list; - return eval_quasiquote(make_list(lst)); - } - else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) { - return eval_defmacrobang(ast, &env); - } - else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) { - return eval_macroexpand(ast, env); - } - else if (strcmp(symbol, SYMBOL_TRYSTAR) == 0) { - - /* TCE - modify ast and env directly and jump back to eval */ - eval_try(&ast, &env); - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - } - /* first element is not a special symbol */ - MalType* evaluated_list = eval_ast(ast, env); - - if (is_error(evaluated_list)) { return evaluated_list; } - - /* apply the first element of the list to the arguments */ - list evlst = evaluated_list->value.mal_list; - MalType* func = evlst->data; - - if (is_function(func)) { - return (*func->value.mal_function)(evlst->next); - } - else if (is_closure(func)) { - - MalClosure* closure = func->value.mal_closure; - list params = (closure->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(evlst->next); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !closure->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - - /* TCE - modify ast and env directly and jump back to eval */ - env = env_make(closure->env, params, evlst->next, closure->more_symbol); - ast = func->value.mal_closure->definition; - - if (is_error(ast)) { return ast; } - goto TCE_entry_point; - } - } - else { - return make_error_fmt("first item in list is not callable: '%s'", \ - pr_str(func, UNREADABLY)); - } -} - -void PRINT(MalType* val) { - - char* output = pr_str(val, READABLY); - printf("%s\n", output); -} - -void rep(char* str, Env* env) { - - PRINT(EVAL(READ(str), env)); -} - -/* declare as global so it can be accessed by mal_eval */ -Env* global_env; - -MalType* mal_eval(list args) { - - MalType* ast = args->data; - return EVAL(ast, global_env); -} - -MalType* mal_readline(list args) { - - if (!args || args->next) { - return make_error("'readline': expected exactly one argument"); - } - - MalType* prompt = args->data; - - if (!is_string(prompt)) { - return make_error_fmt("'readline': argument is not a string '%s'", \ - pr_str(prompt, UNREADABLY)); - } - - char* str = readline(prompt->value.mal_string); - - if (str) { - add_history(str); - return make_string(str); - } - else { - return make_nil(); - } -} - -int main(int argc, char** argv) { - - Env* repl_env = env_make(NULL, NULL, NULL, NULL); - global_env = repl_env; - - ns* core = ns_make_core(); - hashmap mappings = core->mappings; - - while (mappings) { - char* symbol = mappings->data; - MalType*(*function)(list) = mappings->next->data; - - env_set_C_fn(repl_env, symbol, function); - - /* pop symbol and function from hashmap/list */ - mappings = mappings->next->next; - } - - env_set_C_fn(repl_env, "eval", mal_eval); - env_set_C_fn(repl_env, "readline", mal_readline); - - /* add functions written in mal - not using rep as it prints the result */ - EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); - EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); - EVAL(READ("(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)))))))"), repl_env); - - /* make command line arguments available in the environment */ - list lst = NULL; - for (long i = 2; i < argc; i++) { - lst = list_push(lst, make_string(argv[i])); - } - env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); - env_set(repl_env, make_symbol("*host-language*"), make_string("c.2")); - - /* run in script mode if a filename is given */ - if (argc > 1) { - - /* first argument on command line is filename */ - char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); - EVAL(READ(load_command), repl_env); - } - /* run in repl mode when no cmd line args */ - else { - - /* Greeting message */ - EVAL(READ("(println (str \"Mal [\" *host-language* \"]\"))"), repl_env); - - while (1) { - - /* print prompt and get input*/ - /* readline allocates memory for input */ - char* input = readline(PROMPT_STRING); - - /* Check for EOF (Ctrl-D) */ - if (!input) { - printf("\n"); - return 0; - } - - /* add input to history */ - add_history(input); - - /* call Read-Eval-Print */ - rep(input, repl_env); - - /* have to release the memory used by readline */ - free(input); - } - } - return 0; -} - -MalType* eval_ast(MalType* ast, Env* env) { - - /* forward references */ - list evaluate_list(list lst, Env* env); - list evaluate_vector(list lst, Env* env); - list evaluate_hashmap(list lst, Env* env); - - if (is_symbol(ast)) { - - MalType* symbol_value = env_get(env, ast); - - if (symbol_value) { - return symbol_value; - } else { - return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); - } - } - else if (is_list(ast)) { - - list result = evaluate_list(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_list(result); - } else { - return result->data; - } - } - else if (is_vector(ast)) { - - list result = evaluate_vector(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_vector(result); - } else { - return result->data; - } - } - else if (is_hashmap(ast)) { - - list result = evaluate_hashmap(ast->value.mal_list, env); - - if (!result || !is_error(result->data)) { - return make_hashmap(result); - } else { - return result->data; - } - } - else { - return ast; - } -} - -MalType* eval_defbang(MalType* ast, Env** env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'def!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'def!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, *env); - - if (!is_error(result)){ - *env = env_set(*env, defbang_symbol, result); - } - return result; -} - -void eval_letstar(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next) { - *ast = make_error("'let*': missing bindings list"); - return; - } - - MalType* bindings = lst->next->data; - MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); - - if (!is_sequential(bindings)) { - *ast = make_error("'let*': first argument is not list or vector"); - return; - } - - list bindings_list = bindings->value.mal_list; - if (list_count(bindings_list) % 2 == 1) { - *ast = make_error("'let*': expected an even number of binding pairs"); - return; - } - - Env* letstar_env = env_make(*env, NULL, NULL, NULL); - - /* evaluate the bindings */ - while(bindings_list) { - - MalType* symbol = bindings_list->data; - MalType* value = EVAL(bindings_list->next->data, letstar_env); - - /* early return from error */ - if (is_error(value)) { - *ast = value; - return; - } - - env_set(letstar_env, symbol, value); - bindings_list = bindings_list->next->next; - } - - *env = letstar_env; - *ast = forms; - return; -} - -void eval_if(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next || !lst->next->next) { - *ast = make_error("'if': too few arguments"); - return; - } - - if (lst->next->next->next && lst->next->next->next->next) { - *ast = make_error("'if': too many arguments"); - return; - } - - MalType* condition = EVAL(lst->next->data, *env); - - if (is_error(condition)) { - *ast = condition; - return; - } - - if (is_false(condition) || is_nil(condition)) { - - /* check whether false branch is present */ - if (lst->next->next->next) { - *ast = lst->next->next->next->data; - return; - } - else { - *ast = make_nil(); - return; - } - - } else { - *ast = lst->next->next->data; - return; - } -} - -MalType* eval_fnstar(MalType* ast, Env* env) { - - /* forward reference */ - MalType* regularise_parameters(list* params, MalType** more); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_error("'fn*': missing argument list"); - } - else if (!lst->next->next) { - return make_error("'fn*': missing function body"); - } - - MalType* params = lst->next->data; - list params_list = params->value.mal_list; - - MalType* more_symbol = NULL; - - MalType* result = regularise_parameters(¶ms_list, &more_symbol); - if (is_error(result)) { return result; } - - MalType* definition = lst->next->next->data; - MalType* regular_params = make_list(params_list); - - return make_closure(env, regular_params, definition, more_symbol); -} - -MalType* eval_do(MalType* ast, Env* env) { - - list lst = ast->value.mal_list; - - /* handle empty 'do' */ - if (!lst->next) { - return make_nil(); - } - - /* evaluate all but the last form */ - lst = lst->next; - while (lst->next) { - - MalType* val = EVAL(lst->data, env); - - /* return error early */ - if (is_error(val)) { - return val; - } - lst = lst->next; - } - /* return the last form for TCE evaluation */ - return lst->data; -} - -MalType* eval_quote(MalType* ast) { - - list lst = (ast->value.mal_list)->next; - - if (!lst) { - return make_nil(); - } - else if (lst->next) { - return make_error("'quote': expected exactly one argument"); - } - else { - return lst->data; - } -} - -MalType* eval_quasiquote(MalType* ast) { - - /* forward reference */ - MalType* quasiquote(MalType* ast); - - list lst = ast->value.mal_list; - - /* no arguments (quasiquote) */ - if (!lst->next) { - return make_nil(); - } - - /* too many arguments */ - else if (lst->next->next) { - return make_error("'quasiquote': expected exactly one argument"); - } - return quasiquote(lst->next->data); -} - -MalType* quasiquote(MalType* ast) { - - /* forward references */ - MalType* quasiquote_list(MalType* ast); - MalType* quasiquote_vector(MalType* ast); - - /* argument to quasiquote is self-evaluating: (quasiquote val) - => val */ - if (is_self_evaluating(ast)) { - return ast; - } - - /* argument to quasiquote is a vector: (quasiquote [first rest]) */ - else if (is_vector(ast)) { - - return quasiquote_vector(ast); - } - - /* argument to quasiquote is a list: (quasiquote (first rest)) */ - else if (is_list(ast)){ - - return quasiquote_list(ast); - } - /* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val) - => (quote val) */ - else { - - list lst = list_make(ast); - lst = list_push(lst, make_symbol("quote")); - return make_list(lst); - } -} - -MalType* quasiquote_vector(MalType* ast) { - - /* forward references */ - MalType* quasiquote_list(MalType* ast); - - list args = ast->value.mal_list; - - if (args) { - - MalType* first = args->data; - - /* if first element is unquote return quoted */ - if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) { - - list lst = list_make(ast); - lst = list_push(lst, make_symbol("quote")); - - return make_list(lst); - } - } - - /* otherwise process like a list */ - - list lst = list_make(make_symbol("vec")); - - MalType* result = quasiquote_list(ast); - - if (is_error(result)) { - return result; - } else { - lst = list_push(lst, result); - } - - lst = list_reverse(lst); - return make_list(lst); -} - -MalType* quasiquote_list(MalType* ast) { - - list args = ast->value.mal_list; - - /* handle empty list: (quasiquote ()) - => () */ - if (!args) { - return make_list(NULL); - } - - MalType* first = args->data; - - /* handle unquote: (quasiquote (unquote second)) - => second */ - if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) { - - if (args->next->next) { - return make_error("'quasiquote': unquote expected exactly one argument"); - } - else { - return args->next->data; - } - } - - /* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest)) - => (concat first-second (quasiquote rest)) */ - else if (is_list(first) && - first->value.mal_list != NULL && - is_symbol(first->value.mal_list->data) && - strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) { - - if (!first->value.mal_list->next) { - return make_error("'quasiquote': splice-unquote expected exactly one argument"); - } - - MalType* first_second = first->value.mal_list->next->data; - list lst = list_make(make_symbol("concat")); - lst = list_push(lst, first_second); - - MalType* rest = quasiquote(make_list(args->next)); - if (is_error(rest)) { - return rest; - } - - lst = list_push(lst, rest); - lst = list_reverse(lst); - - return make_list(lst); - } - /* handle all other lists recursively: (quasiquote (first rest)) - => (cons (quasiquote first) (quasiquote rest)) */ - else { - - list lst = list_make(make_symbol("cons")); - - MalType* first = quasiquote(args->data); - if (is_error(first)) { - return first; - } else { - lst = list_push(lst, first); - } - - MalType* rest = quasiquote(make_list(args->next)); - if (is_error(rest)) { - return rest; - } else { - lst = list_push(lst, rest); - } - - lst = list_reverse(lst); - return make_list(lst); - } -} - -MalType* eval_defmacrobang(MalType* ast, Env** env) { - - list lst = (ast->value.mal_list)->next; - - if (!lst || !lst->next || lst->next->next) { - return make_error_fmt("'defmacro!': expected exactly two arguments"); - } - - MalType* defbang_symbol = lst->data; - - if (!is_symbol(defbang_symbol)) { - return make_error_fmt("'defmacro!': expected symbol for first argument"); - } - - MalType* defbang_value = lst->next->data; - MalType* result = EVAL(defbang_value, *env); - - if (!is_error(result)) { - result = copy_type(result); - result->is_macro = 1; - *env = env_set(*env, defbang_symbol, result); - } - return result; -} - -MalType* eval_macroexpand(MalType* ast, Env* env) { - - /* forward reference */ - MalType* macroexpand(MalType* ast, Env* env); - - list lst = ast->value.mal_list; - - if (!lst->next) { - return make_nil(); - } - else if (lst->next->next) { - return make_error("'macroexpand': expected exactly one argument"); - } - else { - return macroexpand(lst->next->data, env); - } -} - -MalType* macroexpand(MalType* ast, Env* env) { - - /* forward reference */ - int is_macro_call(MalType* ast, Env* env); - - while(is_macro_call(ast, env)) { - - list lst = ast->value.mal_list; - - MalType* macro_fn = env_get(env, lst->data); - MalClosure* cls = macro_fn->value.mal_closure; - MalType* more_symbol = cls->more_symbol; - - list params_list = (cls->parameters)->value.mal_list; - list args_list = lst->next; - - env = env_make(cls->env, params_list, args_list, more_symbol); - ast = EVAL(cls->definition, env); - } - return ast; -} - -void eval_try(MalType** ast, Env** env) { - - list lst = (*ast)->value.mal_list; - - if (!lst->next) { - *ast = make_nil(); - return; - } - - if (lst->next->next && lst->next->next->next) { - *ast = make_error("'try*': expected maximum of two arguments"); - return; - } - - MalType* try_clause = lst->next->data; - MalType* try_result = EVAL(try_clause, *env); - - /* no catch* clause */ - if (!is_error(try_result) || !lst->next->next) { - *ast = try_result; - return; - } - - /* process catch* clause */ - MalType* catch_clause = lst->next->next->data; - list catch_list = catch_clause->value.mal_list; - - if (!catch_list) { - *ast = make_error("'try*': catch* clause is empty"); - return; - } - - MalType* catch_symbol = catch_list->data; - if (strcmp(catch_symbol->value.mal_symbol, SYMBOL_CATCHSTAR) != 0) { - *ast = make_error("Error: catch clause is missing catch* symbol"); - return; - } - - if (!catch_list->next || !catch_list->next->next) { - *ast = make_error("Error: catch* clause expected two arguments"); - return; - } - - if (!is_symbol(catch_list->next->data)) { - *ast = make_error("Error: catch* clause expected a symbol"); - return; - } - - /* bind the symbol to the exception */ - list symbol_list = list_make(catch_list->next->data); - list expr_list = list_make(try_result->value.mal_error); - - Env* catch_env = env_make(*env, symbol_list, expr_list, NULL); - *ast = catch_list->next->next->data; - *env = catch_env; - - return; -} - -list evaluate_list(list lst, Env* env) { - - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_vector(list lst, Env* env) { - /* TODO: implement a real vector */ - list evlst = NULL; - while (lst) { - - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -list evaluate_hashmap(list lst, Env* env) { - /* TODO: implement a real hashmap */ - list evlst = NULL; - while (lst) { - - /* keys are unevaluated */ - evlst = list_push(evlst, lst->data); - lst = lst->next; - - /* values are evaluated */ - MalType* val = EVAL(lst->data, env); - - if (is_error(val)) { - return list_make(val); - } - - evlst = list_push(evlst, val); - lst = lst->next; - } - return list_reverse(evlst); -} - -MalType* regularise_parameters(list* args, MalType** more_symbol) { - - /* forward reference */ - char* symbol_fn(gptr data); - - list regular_args = NULL; - while (*args) { - - MalType* val = (*args)->data; - - if (!is_symbol(val)) { - return make_error_fmt("non-symbol found in fn argument list '%s'", \ - pr_str(val, UNREADABLY)); - } - - if (val->value.mal_symbol[0] == '&') { - - /* & is found but there is no symbol */ - if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { - return make_error("missing symbol after '&' in argument list"); - } - /* & is found and there is a single symbol after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && - is_symbol((*args)->next->data) && !(*args)->next->next)) { - - *more_symbol = (*args)->next->data; - break; - } - /* & is found and there extra symbols after */ - else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { - return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ - pr_str((*args)->next->data, UNREADABLY), \ - pr_str((*args)->next->next->data, UNREADABLY)); - } - /* & is found as part of the symbol and no other symbols */ - else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { - *more_symbol = make_symbol((val->value.mal_symbol + 1)); - break; - } - /* & is found as part of the symbol but there are other symbols after */ - else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { - return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ - pr_str(val, UNREADABLY), \ - pr_str((*args)->next->data, UNREADABLY)); - } - } - - /* & is not found - add the symbol to the regular argument list */ - else { - - if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { - return make_error_fmt("duplicate symbol in argument list: '%s'", \ - pr_str(val, UNREADABLY)); - } - else { - regular_args = list_push(regular_args, val); - } - } - *args = (*args)->next; - } - - *args = list_reverse(regular_args); - return make_nil(); -} - -char* symbol_fn(gptr data) { - return (((MalType*)data)->value.mal_symbol); -} - -/* used by core functions but not EVAL as doesn't do TCE */ -MalType* apply(MalType* fn, list args) { - - if (is_function(fn)) { - - MalType* (*fun_ptr)(list) = fn->value.mal_function; - return (*fun_ptr)(args); - } - else { /* is_closure(fn) */ - - MalClosure* c = fn->value.mal_closure; - list params = (c->parameters)->value.mal_list; - - long param_count = list_count(params); - long arg_count = list_count(args); - - if (param_count > arg_count) { - return make_error("too few arguments supplied to function"); - } - else if ((param_count < arg_count) && !c->more_symbol) { - return make_error("too many arguments supplied to function"); - } - else { - Env* env = env_make(c->env, params, args, c->more_symbol); - return EVAL(fn->value.mal_closure->definition, env); - } - } -} - -int is_macro_call(MalType* ast, Env* env) { - - /* not a list */ - if (!is_list(ast)) { - return 0; - } - - /* empty list */ - list lst = ast->value.mal_list; - if (!lst) { - return 0; - } - - /* first item not a symbol */ - MalType* first = lst->data; - if (!is_symbol(first)) { - return 0; - } - - /* lookup symbol */ - MalType* val = env_get(env, first); - if (is_error(val)) { - return 0; - } - else { - return (val->is_macro); - } -} +#include +#include +#include +#include +#include + +#include +#include + +#include "types.h" +#include "reader.h" +#include "printer.h" +#include "env.h" +#include "core.h" + +#define SYMBOL_DEFBANG "def!" +#define SYMBOL_LETSTAR "let*" +#define SYMBOL_DO "do" +#define SYMBOL_IF "if" +#define SYMBOL_FNSTAR "fn*" +#define SYMBOL_QUOTE "quote" +#define SYMBOL_QUASIQUOTE "quasiquote" +#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand" +#define SYMBOL_UNQUOTE "unquote" +#define SYMBOL_SPLICE_UNQUOTE "splice-unquote" +#define SYMBOL_DEFMACROBANG "defmacro!" +#define SYMBOL_MACROEXPAND "macroexpand" +#define SYMBOL_TRYSTAR "try*" +#define SYMBOL_CATCHSTAR "catch*" + +#define PROMPT_STRING "user> " + +MalType* READ(char* str) { + + return read_str(str); +} + +MalType* EVAL(MalType* ast, Env* env) { + + /* forward references */ + MalType* eval_ast(MalType* ast, Env* env); + MalType* eval_defbang(MalType* ast, Env** env); + void eval_letstar(MalType** ast, Env** env); + void eval_if(MalType** ast, Env** env); + MalType* eval_fnstar(MalType* ast, Env* env); + MalType* eval_do(MalType* ast, Env* env); + MalType* eval_quote(MalType* ast); + MalType* eval_quasiquote(MalType* ast); + MalType* eval_quasiquoteexpand(MalType* ast); + MalType* eval_defmacrobang(MalType*, Env** env); + MalType* eval_macroexpand(MalType* ast, Env* env); + MalType* macroexpand(MalType* ast, Env* env); + void eval_try(MalType** ast, Env** env); + + /* Use goto to jump here rather than calling eval for tail-call elimination */ + TCE_entry_point: + + /* NULL */ + if (!ast) { return make_nil(); } + + /* macroexpansion */ + ast = macroexpand(ast, env); + if (is_error(ast)) { return ast; } + + /* not a list */ + if (!is_list(ast)) { return eval_ast(ast, env); } + + /* empty list */ + if (ast->value.mal_list == NULL) { return ast; } + + /* list */ + MalType* first = (ast->value.mal_list)->data; + char* symbol = first->value.mal_symbol; + + if (is_symbol(first)) { + + /* handle special symbols first */ + if (strcmp(symbol, SYMBOL_DEFBANG) == 0) { + return eval_defbang(ast, &env); + } + else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + eval_letstar(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_IF) == 0) { + + /* TCE - modify ast directly and jump back to eval */ + eval_if(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) { + return eval_fnstar(ast, env); + } + else if (strcmp(symbol, SYMBOL_DO) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + ast = eval_do(ast, env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_QUOTE) == 0) { + return eval_quote(ast); + } + else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) { + + ast = eval_quasiquote(ast); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) { + + list lst = ast->value.mal_list; + return eval_quasiquote(make_list(lst)); + } + else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) { + return eval_defmacrobang(ast, &env); + } + else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) { + return eval_macroexpand(ast, env); + } + else if (strcmp(symbol, SYMBOL_TRYSTAR) == 0) { + + /* TCE - modify ast and env directly and jump back to eval */ + eval_try(&ast, &env); + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + } + /* first element is not a special symbol */ + MalType* evaluated_list = eval_ast(ast, env); + + if (is_error(evaluated_list)) { return evaluated_list; } + + /* apply the first element of the list to the arguments */ + list evlst = evaluated_list->value.mal_list; + MalType* func = evlst->data; + + if (is_function(func)) { + return (*func->value.mal_function)(evlst->next); + } + else if (is_closure(func)) { + + MalClosure* closure = func->value.mal_closure; + list params = (closure->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(evlst->next); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !closure->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + + /* TCE - modify ast and env directly and jump back to eval */ + env = env_make(closure->env, params, evlst->next, closure->more_symbol); + ast = func->value.mal_closure->definition; + + if (is_error(ast)) { return ast; } + goto TCE_entry_point; + } + } + else { + return make_error_fmt("first item in list is not callable: '%s'", \ + pr_str(func, UNREADABLY)); + } +} + +void PRINT(MalType* val) { + + char* output = pr_str(val, READABLY); + printf("%s\n", output); +} + +void rep(char* str, Env* env) { + + PRINT(EVAL(READ(str), env)); +} + +/* declare as global so it can be accessed by mal_eval */ +Env* global_env; + +MalType* mal_eval(list args) { + + MalType* ast = args->data; + return EVAL(ast, global_env); +} + +MalType* mal_readline(list args) { + + if (!args || args->next) { + return make_error("'readline': expected exactly one argument"); + } + + MalType* prompt = args->data; + + if (!is_string(prompt)) { + return make_error_fmt("'readline': argument is not a string '%s'", \ + pr_str(prompt, UNREADABLY)); + } + + char* str = readline(prompt->value.mal_string); + + if (str) { + add_history(str); + return make_string(str); + } + else { + return make_nil(); + } +} + +int main(int argc, char** argv) { + + Env* repl_env = env_make(NULL, NULL, NULL, NULL); + global_env = repl_env; + + ns* core = ns_make_core(); + hashmap mappings = core->mappings; + + while (mappings) { + char* symbol = mappings->data; + MalType*(*function)(list) = mappings->next->data; + + env_set_C_fn(repl_env, symbol, function); + + /* pop symbol and function from hashmap/list */ + mappings = mappings->next->next; + } + + env_set_C_fn(repl_env, "eval", mal_eval); + env_set_C_fn(repl_env, "readline", mal_readline); + + /* add functions written in mal - not using rep as it prints the result */ + EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env); + EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env); + EVAL(READ("(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)))))))"), repl_env); + + /* make command line arguments available in the environment */ + list lst = NULL; + for (long i = 2; i < argc; i++) { + lst = list_push(lst, make_string(argv[i])); + } + env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst))); + env_set(repl_env, make_symbol("*host-language*"), make_string("c.2")); + + /* run in script mode if a filename is given */ + if (argc > 1) { + + /* first argument on command line is filename */ + char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]); + EVAL(READ(load_command), repl_env); + } + /* run in repl mode when no cmd line args */ + else { + + /* Greeting message */ + EVAL(READ("(println (str \"Mal [\" *host-language* \"]\"))"), repl_env); + + while (1) { + + /* print prompt and get input*/ + /* readline allocates memory for input */ + char* input = readline(PROMPT_STRING); + + /* Check for EOF (Ctrl-D) */ + if (!input) { + printf("\n"); + return 0; + } + + /* add input to history */ + add_history(input); + + /* call Read-Eval-Print */ + rep(input, repl_env); + + /* have to release the memory used by readline */ + free(input); + } + } + return 0; +} + +MalType* eval_ast(MalType* ast, Env* env) { + + /* forward references */ + list evaluate_list(list lst, Env* env); + list evaluate_vector(list lst, Env* env); + list evaluate_hashmap(list lst, Env* env); + + if (is_symbol(ast)) { + + MalType* symbol_value = env_get(env, ast); + + if (symbol_value) { + return symbol_value; + } else { + return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY)); + } + } + else if (is_list(ast)) { + + list result = evaluate_list(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_list(result); + } else { + return result->data; + } + } + else if (is_vector(ast)) { + + list result = evaluate_vector(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_vector(result); + } else { + return result->data; + } + } + else if (is_hashmap(ast)) { + + list result = evaluate_hashmap(ast->value.mal_list, env); + + if (!result || !is_error(result->data)) { + return make_hashmap(result); + } else { + return result->data; + } + } + else { + return ast; + } +} + +MalType* eval_defbang(MalType* ast, Env** env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'def!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'def!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, *env); + + if (!is_error(result)){ + *env = env_set(*env, defbang_symbol, result); + } + return result; +} + +void eval_letstar(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next) { + *ast = make_error("'let*': missing bindings list"); + return; + } + + MalType* bindings = lst->next->data; + MalType* forms = lst->next->next ? lst->next->next->data : make_nil(); + + if (!is_sequential(bindings)) { + *ast = make_error("'let*': first argument is not list or vector"); + return; + } + + list bindings_list = bindings->value.mal_list; + if (list_count(bindings_list) % 2 == 1) { + *ast = make_error("'let*': expected an even number of binding pairs"); + return; + } + + Env* letstar_env = env_make(*env, NULL, NULL, NULL); + + /* evaluate the bindings */ + while(bindings_list) { + + MalType* symbol = bindings_list->data; + MalType* value = EVAL(bindings_list->next->data, letstar_env); + + /* early return from error */ + if (is_error(value)) { + *ast = value; + return; + } + + env_set(letstar_env, symbol, value); + bindings_list = bindings_list->next->next; + } + + *env = letstar_env; + *ast = forms; + return; +} + +void eval_if(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next || !lst->next->next) { + *ast = make_error("'if': too few arguments"); + return; + } + + if (lst->next->next->next && lst->next->next->next->next) { + *ast = make_error("'if': too many arguments"); + return; + } + + MalType* condition = EVAL(lst->next->data, *env); + + if (is_error(condition)) { + *ast = condition; + return; + } + + if (is_false(condition) || is_nil(condition)) { + + /* check whether false branch is present */ + if (lst->next->next->next) { + *ast = lst->next->next->next->data; + return; + } + else { + *ast = make_nil(); + return; + } + + } else { + *ast = lst->next->next->data; + return; + } +} + +MalType* eval_fnstar(MalType* ast, Env* env) { + + /* forward reference */ + MalType* regularise_parameters(list* params, MalType** more); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_error("'fn*': missing argument list"); + } + else if (!lst->next->next) { + return make_error("'fn*': missing function body"); + } + + MalType* params = lst->next->data; + list params_list = params->value.mal_list; + + MalType* more_symbol = NULL; + + MalType* result = regularise_parameters(¶ms_list, &more_symbol); + if (is_error(result)) { return result; } + + MalType* definition = lst->next->next->data; + MalType* regular_params = make_list(params_list); + + return make_closure(env, regular_params, definition, more_symbol); +} + +MalType* eval_do(MalType* ast, Env* env) { + + list lst = ast->value.mal_list; + + /* handle empty 'do' */ + if (!lst->next) { + return make_nil(); + } + + /* evaluate all but the last form */ + lst = lst->next; + while (lst->next) { + + MalType* val = EVAL(lst->data, env); + + /* return error early */ + if (is_error(val)) { + return val; + } + lst = lst->next; + } + /* return the last form for TCE evaluation */ + return lst->data; +} + +MalType* eval_quote(MalType* ast) { + + list lst = (ast->value.mal_list)->next; + + if (!lst) { + return make_nil(); + } + else if (lst->next) { + return make_error("'quote': expected exactly one argument"); + } + else { + return lst->data; + } +} + +MalType* eval_quasiquote(MalType* ast) { + + /* forward reference */ + MalType* quasiquote(MalType* ast); + + list lst = ast->value.mal_list; + + /* no arguments (quasiquote) */ + if (!lst->next) { + return make_nil(); + } + + /* too many arguments */ + else if (lst->next->next) { + return make_error("'quasiquote': expected exactly one argument"); + } + return quasiquote(lst->next->data); +} + +MalType* quasiquote(MalType* ast) { + + /* forward references */ + MalType* quasiquote_list(MalType* ast); + MalType* quasiquote_vector(MalType* ast); + + /* argument to quasiquote is self-evaluating: (quasiquote val) + => val */ + if (is_self_evaluating(ast)) { + return ast; + } + + /* argument to quasiquote is a vector: (quasiquote [first rest]) */ + else if (is_vector(ast)) { + + return quasiquote_vector(ast); + } + + /* argument to quasiquote is a list: (quasiquote (first rest)) */ + else if (is_list(ast)){ + + return quasiquote_list(ast); + } + /* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val) + => (quote val) */ + else { + + list lst = list_make(ast); + lst = list_push(lst, make_symbol("quote")); + return make_list(lst); + } +} + +MalType* quasiquote_vector(MalType* ast) { + + /* forward references */ + MalType* quasiquote_list(MalType* ast); + + list args = ast->value.mal_list; + + if (args) { + + MalType* first = args->data; + + /* if first element is unquote return quoted */ + if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) { + + list lst = list_make(ast); + lst = list_push(lst, make_symbol("quote")); + + return make_list(lst); + } + } + + /* otherwise process like a list */ + + list lst = list_make(make_symbol("vec")); + + MalType* result = quasiquote_list(ast); + + if (is_error(result)) { + return result; + } else { + lst = list_push(lst, result); + } + + lst = list_reverse(lst); + return make_list(lst); +} + +MalType* quasiquote_list(MalType* ast) { + + list args = ast->value.mal_list; + + /* handle empty list: (quasiquote ()) + => () */ + if (!args) { + return make_list(NULL); + } + + MalType* first = args->data; + + /* handle unquote: (quasiquote (unquote second)) + => second */ + if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) { + + if (args->next->next) { + return make_error("'quasiquote': unquote expected exactly one argument"); + } + else { + return args->next->data; + } + } + + /* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest)) + => (concat first-second (quasiquote rest)) */ + else if (is_list(first) && + first->value.mal_list != NULL && + is_symbol(first->value.mal_list->data) && + strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) { + + if (!first->value.mal_list->next) { + return make_error("'quasiquote': splice-unquote expected exactly one argument"); + } + + MalType* first_second = first->value.mal_list->next->data; + list lst = list_make(make_symbol("concat")); + lst = list_push(lst, first_second); + + MalType* rest = quasiquote(make_list(args->next)); + if (is_error(rest)) { + return rest; + } + + lst = list_push(lst, rest); + lst = list_reverse(lst); + + return make_list(lst); + } + /* handle all other lists recursively: (quasiquote (first rest)) + => (cons (quasiquote first) (quasiquote rest)) */ + else { + + list lst = list_make(make_symbol("cons")); + + MalType* first = quasiquote(args->data); + if (is_error(first)) { + return first; + } else { + lst = list_push(lst, first); + } + + MalType* rest = quasiquote(make_list(args->next)); + if (is_error(rest)) { + return rest; + } else { + lst = list_push(lst, rest); + } + + lst = list_reverse(lst); + return make_list(lst); + } +} + +MalType* eval_defmacrobang(MalType* ast, Env** env) { + + list lst = (ast->value.mal_list)->next; + + if (!lst || !lst->next || lst->next->next) { + return make_error_fmt("'defmacro!': expected exactly two arguments"); + } + + MalType* defbang_symbol = lst->data; + + if (!is_symbol(defbang_symbol)) { + return make_error_fmt("'defmacro!': expected symbol for first argument"); + } + + MalType* defbang_value = lst->next->data; + MalType* result = EVAL(defbang_value, *env); + + if (!is_error(result)) { + result = copy_type(result); + result->is_macro = 1; + *env = env_set(*env, defbang_symbol, result); + } + return result; +} + +MalType* eval_macroexpand(MalType* ast, Env* env) { + + /* forward reference */ + MalType* macroexpand(MalType* ast, Env* env); + + list lst = ast->value.mal_list; + + if (!lst->next) { + return make_nil(); + } + else if (lst->next->next) { + return make_error("'macroexpand': expected exactly one argument"); + } + else { + return macroexpand(lst->next->data, env); + } +} + +MalType* macroexpand(MalType* ast, Env* env) { + + /* forward reference */ + int is_macro_call(MalType* ast, Env* env); + + while(is_macro_call(ast, env)) { + + list lst = ast->value.mal_list; + + MalType* macro_fn = env_get(env, lst->data); + MalClosure* cls = macro_fn->value.mal_closure; + MalType* more_symbol = cls->more_symbol; + + list params_list = (cls->parameters)->value.mal_list; + list args_list = lst->next; + + env = env_make(cls->env, params_list, args_list, more_symbol); + ast = EVAL(cls->definition, env); + } + return ast; +} + +void eval_try(MalType** ast, Env** env) { + + list lst = (*ast)->value.mal_list; + + if (!lst->next) { + *ast = make_nil(); + return; + } + + if (lst->next->next && lst->next->next->next) { + *ast = make_error("'try*': expected maximum of two arguments"); + return; + } + + MalType* try_clause = lst->next->data; + MalType* try_result = EVAL(try_clause, *env); + + /* no catch* clause */ + if (!is_error(try_result) || !lst->next->next) { + *ast = try_result; + return; + } + + /* process catch* clause */ + MalType* catch_clause = lst->next->next->data; + list catch_list = catch_clause->value.mal_list; + + if (!catch_list) { + *ast = make_error("'try*': catch* clause is empty"); + return; + } + + MalType* catch_symbol = catch_list->data; + if (strcmp(catch_symbol->value.mal_symbol, SYMBOL_CATCHSTAR) != 0) { + *ast = make_error("Error: catch clause is missing catch* symbol"); + return; + } + + if (!catch_list->next || !catch_list->next->next) { + *ast = make_error("Error: catch* clause expected two arguments"); + return; + } + + if (!is_symbol(catch_list->next->data)) { + *ast = make_error("Error: catch* clause expected a symbol"); + return; + } + + /* bind the symbol to the exception */ + list symbol_list = list_make(catch_list->next->data); + list expr_list = list_make(try_result->value.mal_error); + + Env* catch_env = env_make(*env, symbol_list, expr_list, NULL); + *ast = catch_list->next->next->data; + *env = catch_env; + + return; +} + +list evaluate_list(list lst, Env* env) { + + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_vector(list lst, Env* env) { + /* TODO: implement a real vector */ + list evlst = NULL; + while (lst) { + + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +list evaluate_hashmap(list lst, Env* env) { + /* TODO: implement a real hashmap */ + list evlst = NULL; + while (lst) { + + /* keys are unevaluated */ + evlst = list_push(evlst, lst->data); + lst = lst->next; + + /* values are evaluated */ + MalType* val = EVAL(lst->data, env); + + if (is_error(val)) { + return list_make(val); + } + + evlst = list_push(evlst, val); + lst = lst->next; + } + return list_reverse(evlst); +} + +MalType* regularise_parameters(list* args, MalType** more_symbol) { + + /* forward reference */ + char* symbol_fn(gptr data); + + list regular_args = NULL; + while (*args) { + + MalType* val = (*args)->data; + + if (!is_symbol(val)) { + return make_error_fmt("non-symbol found in fn argument list '%s'", \ + pr_str(val, UNREADABLY)); + } + + if (val->value.mal_symbol[0] == '&') { + + /* & is found but there is no symbol */ + if (val->value.mal_symbol[1] == '\0' && !(*args)->next) { + return make_error("missing symbol after '&' in argument list"); + } + /* & is found and there is a single symbol after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && + is_symbol((*args)->next->data) && !(*args)->next->next)) { + + *more_symbol = (*args)->next->data; + break; + } + /* & is found and there extra symbols after */ + else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) { + return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \ + pr_str((*args)->next->data, UNREADABLY), \ + pr_str((*args)->next->next->data, UNREADABLY)); + } + /* & is found as part of the symbol and no other symbols */ + else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) { + *more_symbol = make_symbol((val->value.mal_symbol + 1)); + break; + } + /* & is found as part of the symbol but there are other symbols after */ + else if (val->value.mal_symbol[1] != '\0' && (*args)->next) { + return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \ + pr_str(val, UNREADABLY), \ + pr_str((*args)->next->data, UNREADABLY)); + } + } + + /* & is not found - add the symbol to the regular argument list */ + else { + + if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) { + return make_error_fmt("duplicate symbol in argument list: '%s'", \ + pr_str(val, UNREADABLY)); + } + else { + regular_args = list_push(regular_args, val); + } + } + *args = (*args)->next; + } + + *args = list_reverse(regular_args); + return make_nil(); +} + +char* symbol_fn(gptr data) { + return (((MalType*)data)->value.mal_symbol); +} + +/* used by core functions but not EVAL as doesn't do TCE */ +MalType* apply(MalType* fn, list args) { + + if (is_function(fn)) { + + MalType* (*fun_ptr)(list) = fn->value.mal_function; + return (*fun_ptr)(args); + } + else { /* is_closure(fn) */ + + MalClosure* c = fn->value.mal_closure; + list params = (c->parameters)->value.mal_list; + + long param_count = list_count(params); + long arg_count = list_count(args); + + if (param_count > arg_count) { + return make_error("too few arguments supplied to function"); + } + else if ((param_count < arg_count) && !c->more_symbol) { + return make_error("too many arguments supplied to function"); + } + else { + Env* env = env_make(c->env, params, args, c->more_symbol); + return EVAL(fn->value.mal_closure->definition, env); + } + } +} + +int is_macro_call(MalType* ast, Env* env) { + + /* not a list */ + if (!is_list(ast)) { + return 0; + } + + /* empty list */ + list lst = ast->value.mal_list; + if (!lst) { + return 0; + } + + /* first item not a symbol */ + MalType* first = lst->data; + if (!is_symbol(first)) { + return 0; + } + + /* lookup symbol */ + MalType* val = env_get(env, first); + if (is_error(val)) { + return 0; + } + else { + return (val->is_macro); + } +} diff --git a/impls/c.2/tests/stepA_mal.mal b/impls/c.2/tests/stepA_mal.mal index d9294e7e52..0193269d04 100644 --- a/impls/c.2/tests/stepA_mal.mal +++ b/impls/c.2/tests/stepA_mal.mal @@ -1,22 +1,22 @@ -;; Testing FFI of "strlen" -(. nil "int32" "strlen" "string" "abcde") -;=>5 -(. nil "int32" "strlen" "string" "") -;=>0 - -;; Testing FFI of "strcmp" - -(. nil "int32" "strcmp" "string" "abc" "string" "abcA") -;=>-65 -(. nil "int32" "strcmp" "string" "abcA" "string" "abc") -;=>65 -(. nil "int32" "strcmp" "string" "abc" "string" "abc") -;=>0 - - -;; Testing FFI of "pow" (libm.so) - -(. "libm.so.6" "double" "pow" "double" 2.0 "double" 3.0) -;=>8.000000 -(. "libm.so.6" "double" "pow" "double" 3.0 "double" 2.0) -;=>9.000000 +;; Testing FFI of "strlen" +(. nil "int32" "strlen" "string" "abcde") +;=>5 +(. nil "int32" "strlen" "string" "") +;=>0 + +;; Testing FFI of "strcmp" + +(. nil "int32" "strcmp" "string" "abc" "string" "abcA") +;=>-65 +(. nil "int32" "strcmp" "string" "abcA" "string" "abc") +;=>65 +(. nil "int32" "strcmp" "string" "abc" "string" "abc") +;=>0 + + +;; Testing FFI of "pow" (libm.so) + +(. "libm.so.6" "double" "pow" "double" 2.0 "double" 3.0) +;=>8.000000 +(. "libm.so.6" "double" "pow" "double" 3.0 "double" 2.0) +;=>9.000000 diff --git a/impls/c.2/types.c b/impls/c.2/types.c index 47001d304c..6d05fbad66 100644 --- a/impls/c.2/types.c +++ b/impls/c.2/types.c @@ -1,283 +1,283 @@ -#include -#include -#include -#include "types.h" - -#define ERROR_BUFFER_SIZE 128 - -MalType THE_TRUE = {MALTYPE_TRUE, 0, 0, {0}}; -MalType THE_FALSE = {MALTYPE_FALSE, 0, 0, {0}}; -MalType THE_NIL = {MALTYPE_NIL, 0, 0, {0}}; - - -inline int is_sequential(MalType* val) { - return (val->type == MALTYPE_LIST || val->type == MALTYPE_VECTOR); -} - -inline int is_self_evaluating(MalType* val) { - return (val->type == MALTYPE_KEYWORD || val->type == MALTYPE_INTEGER || - val->type == MALTYPE_FLOAT || val->type == MALTYPE_STRING || - val->type == MALTYPE_TRUE || val->type == MALTYPE_FALSE || - val->type == MALTYPE_NIL); -} - -inline int is_list(MalType* val) { - return (val->type == MALTYPE_LIST); -} - -inline int is_vector(MalType* val) { - return (val->type == MALTYPE_VECTOR); -} - -inline int is_hashmap(MalType* val) { - return (val->type == MALTYPE_HASHMAP); -} - -inline int is_nil(MalType* val) { - return (val->type == MALTYPE_NIL); -} - -inline int is_string(MalType* val) { - return (val->type == MALTYPE_STRING); -} - -inline int is_integer(MalType* val) { - return (val->type == MALTYPE_INTEGER); -} - -inline int is_float(MalType* val) { - return (val->type == MALTYPE_FLOAT); -} - -inline int is_number(MalType* val) { - return (val->type == MALTYPE_INTEGER || val->type == MALTYPE_FLOAT); -} - -inline int is_true(MalType* val) { - return (val->type == MALTYPE_TRUE); -} - -inline int is_false(MalType* val) { - return (val->type == MALTYPE_FALSE); -} - -inline int is_symbol(MalType* val) { - return (val->type == MALTYPE_SYMBOL); -} - -inline int is_keyword(MalType* val) { - return (val->type == MALTYPE_KEYWORD); -} - -inline int is_atom(MalType* val) { - return (val->type == MALTYPE_ATOM); -} - -inline int is_error(MalType* val) { - return (val->type == MALTYPE_ERROR); -} - -inline int is_callable(MalType* val) { - return (val->type == MALTYPE_FUNCTION || val->type == MALTYPE_CLOSURE); -} - -inline int is_function(MalType* val) { - return (val->type == MALTYPE_FUNCTION); -} - -inline int is_closure(MalType* val) { - return (val->type == MALTYPE_CLOSURE); -} - -inline int is_macro(MalType* val) { - return (val->is_macro); -} - - -MalType* make_symbol(char* value) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_SYMBOL; - mal_val->value.mal_symbol = value; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_integer(long value) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_INTEGER; - mal_val->value.mal_integer = value; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_float(double value) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_FLOAT; - mal_val->value.mal_float = value; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_keyword(char* value) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_KEYWORD; - mal_val->value.mal_keyword = value; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_string(char* value) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_STRING; - mal_val->value.mal_string = value; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_list(list value) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_LIST; - mal_val->value.mal_list = value; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_vector(list value) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_VECTOR; - mal_val->value.mal_list = value; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_hashmap(list value) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_HASHMAP; - mal_val->value.mal_list = value; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_atom(MalType* value) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_ATOM; - mal_val->value.mal_atom = value; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_function(MalType*(*fn)(list args)) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_FUNCTION; - mal_val->value.mal_function = fn; - mal_val->is_macro = 0; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_closure(Env* env, MalType* parameters, MalType* definition, MalType* more_symbol) { - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_CLOSURE; - mal_val->metadata = NULL; - - /* Allocate memory for embedded struct */ - MalClosure* mc = GC_MALLOC(sizeof(*mc)); - mc->env = env; - mc->parameters = parameters; - mc->definition = definition; - mc->more_symbol = more_symbol; - - mal_val->is_macro = 0; - mal_val->value.mal_closure = mc; - return mal_val; -} - -inline MalType* make_true() { - return &THE_TRUE; -} - -inline MalType* make_false() { - return &THE_FALSE; -} - -inline MalType* make_nil() { - return &THE_NIL; -} - -MalType* make_error(char* msg) { - - MalType* mal_string = GC_MALLOC(sizeof(*mal_string)); - mal_string->type = MALTYPE_STRING; - mal_string->value.mal_string = msg; - - MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); - mal_val->type = MALTYPE_ERROR; - mal_val->value.mal_error = mal_string; - mal_val->metadata = NULL; - - return mal_val; -} - -MalType* make_error_fmt(char* fmt, ...) { - - va_list argptr; - va_start(argptr, fmt); - - char* buffer = GC_MALLOC(sizeof(*buffer) * ERROR_BUFFER_SIZE); - - long n = vsnprintf(buffer, ERROR_BUFFER_SIZE, fmt, argptr); - va_end(argptr); - - if (n > ERROR_BUFFER_SIZE) { - va_start(argptr, fmt); - - buffer = GC_REALLOC(buffer, sizeof(*buffer) * n); - vsnprintf(buffer, n, fmt, argptr); - - va_end(argptr); - } - return make_error(buffer); -} - -MalType* wrap_error(MalType* value) { - - MalType* mal_error = GC_MALLOC(sizeof(*mal_error)); - mal_error->type = MALTYPE_ERROR; - mal_error->metadata = NULL; - mal_error->value.mal_error = value; - - return mal_error; -} - -MalType* copy_type(MalType* value) { - - MalType* new_val = GC_MALLOC(sizeof(*new_val)); - - new_val->type = value->type; - new_val->is_macro = value->is_macro; - new_val->value = value->value; - new_val->metadata = value->metadata; - - return new_val; -} +#include +#include +#include +#include "types.h" + +#define ERROR_BUFFER_SIZE 128 + +MalType THE_TRUE = {MALTYPE_TRUE, 0, 0, {0}}; +MalType THE_FALSE = {MALTYPE_FALSE, 0, 0, {0}}; +MalType THE_NIL = {MALTYPE_NIL, 0, 0, {0}}; + + +inline int is_sequential(MalType* val) { + return (val->type == MALTYPE_LIST || val->type == MALTYPE_VECTOR); +} + +inline int is_self_evaluating(MalType* val) { + return (val->type == MALTYPE_KEYWORD || val->type == MALTYPE_INTEGER || + val->type == MALTYPE_FLOAT || val->type == MALTYPE_STRING || + val->type == MALTYPE_TRUE || val->type == MALTYPE_FALSE || + val->type == MALTYPE_NIL); +} + +inline int is_list(MalType* val) { + return (val->type == MALTYPE_LIST); +} + +inline int is_vector(MalType* val) { + return (val->type == MALTYPE_VECTOR); +} + +inline int is_hashmap(MalType* val) { + return (val->type == MALTYPE_HASHMAP); +} + +inline int is_nil(MalType* val) { + return (val->type == MALTYPE_NIL); +} + +inline int is_string(MalType* val) { + return (val->type == MALTYPE_STRING); +} + +inline int is_integer(MalType* val) { + return (val->type == MALTYPE_INTEGER); +} + +inline int is_float(MalType* val) { + return (val->type == MALTYPE_FLOAT); +} + +inline int is_number(MalType* val) { + return (val->type == MALTYPE_INTEGER || val->type == MALTYPE_FLOAT); +} + +inline int is_true(MalType* val) { + return (val->type == MALTYPE_TRUE); +} + +inline int is_false(MalType* val) { + return (val->type == MALTYPE_FALSE); +} + +inline int is_symbol(MalType* val) { + return (val->type == MALTYPE_SYMBOL); +} + +inline int is_keyword(MalType* val) { + return (val->type == MALTYPE_KEYWORD); +} + +inline int is_atom(MalType* val) { + return (val->type == MALTYPE_ATOM); +} + +inline int is_error(MalType* val) { + return (val->type == MALTYPE_ERROR); +} + +inline int is_callable(MalType* val) { + return (val->type == MALTYPE_FUNCTION || val->type == MALTYPE_CLOSURE); +} + +inline int is_function(MalType* val) { + return (val->type == MALTYPE_FUNCTION); +} + +inline int is_closure(MalType* val) { + return (val->type == MALTYPE_CLOSURE); +} + +inline int is_macro(MalType* val) { + return (val->is_macro); +} + + +MalType* make_symbol(char* value) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_SYMBOL; + mal_val->value.mal_symbol = value; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_integer(long value) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_INTEGER; + mal_val->value.mal_integer = value; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_float(double value) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_FLOAT; + mal_val->value.mal_float = value; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_keyword(char* value) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_KEYWORD; + mal_val->value.mal_keyword = value; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_string(char* value) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_STRING; + mal_val->value.mal_string = value; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_list(list value) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_LIST; + mal_val->value.mal_list = value; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_vector(list value) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_VECTOR; + mal_val->value.mal_list = value; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_hashmap(list value) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_HASHMAP; + mal_val->value.mal_list = value; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_atom(MalType* value) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_ATOM; + mal_val->value.mal_atom = value; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_function(MalType*(*fn)(list args)) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_FUNCTION; + mal_val->value.mal_function = fn; + mal_val->is_macro = 0; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_closure(Env* env, MalType* parameters, MalType* definition, MalType* more_symbol) { + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_CLOSURE; + mal_val->metadata = NULL; + + /* Allocate memory for embedded struct */ + MalClosure* mc = GC_MALLOC(sizeof(*mc)); + mc->env = env; + mc->parameters = parameters; + mc->definition = definition; + mc->more_symbol = more_symbol; + + mal_val->is_macro = 0; + mal_val->value.mal_closure = mc; + return mal_val; +} + +inline MalType* make_true() { + return &THE_TRUE; +} + +inline MalType* make_false() { + return &THE_FALSE; +} + +inline MalType* make_nil() { + return &THE_NIL; +} + +MalType* make_error(char* msg) { + + MalType* mal_string = GC_MALLOC(sizeof(*mal_string)); + mal_string->type = MALTYPE_STRING; + mal_string->value.mal_string = msg; + + MalType* mal_val = GC_MALLOC(sizeof(*mal_val)); + mal_val->type = MALTYPE_ERROR; + mal_val->value.mal_error = mal_string; + mal_val->metadata = NULL; + + return mal_val; +} + +MalType* make_error_fmt(char* fmt, ...) { + + va_list argptr; + va_start(argptr, fmt); + + char* buffer = GC_MALLOC(sizeof(*buffer) * ERROR_BUFFER_SIZE); + + long n = vsnprintf(buffer, ERROR_BUFFER_SIZE, fmt, argptr); + va_end(argptr); + + if (n > ERROR_BUFFER_SIZE) { + va_start(argptr, fmt); + + buffer = GC_REALLOC(buffer, sizeof(*buffer) * n); + vsnprintf(buffer, n, fmt, argptr); + + va_end(argptr); + } + return make_error(buffer); +} + +MalType* wrap_error(MalType* value) { + + MalType* mal_error = GC_MALLOC(sizeof(*mal_error)); + mal_error->type = MALTYPE_ERROR; + mal_error->metadata = NULL; + mal_error->value.mal_error = value; + + return mal_error; +} + +MalType* copy_type(MalType* value) { + + MalType* new_val = GC_MALLOC(sizeof(*new_val)); + + new_val->type = value->type; + new_val->is_macro = value->is_macro; + new_val->value = value->value; + new_val->metadata = value->metadata; + + return new_val; +} diff --git a/impls/c.2/types.h b/impls/c.2/types.h index c0bafd23ad..af7d8f8eae 100644 --- a/impls/c.2/types.h +++ b/impls/c.2/types.h @@ -1,100 +1,100 @@ -#ifndef _MAL_TYPES_H -#define _MAL_TYPES_H - -#include "libs/linked_list/linked_list.h" -#include "libs/hashmap/hashmap.h" - -#define MALTYPE_SYMBOL 1 -#define MALTYPE_KEYWORD 2 -#define MALTYPE_INTEGER 3 -#define MALTYPE_FLOAT 4 -#define MALTYPE_STRING 5 -#define MALTYPE_TRUE 6 -#define MALTYPE_FALSE 7 -#define MALTYPE_NIL 8 -#define MALTYPE_LIST 9 -#define MALTYPE_VECTOR 10 -#define MALTYPE_HASHMAP 11 -#define MALTYPE_FUNCTION 12 -#define MALTYPE_CLOSURE 13 -#define MALTYPE_ERROR 14 -#define MALTYPE_ATOM 15 - -typedef struct MalType_s MalType; -typedef struct MalClosure_s MalClosure; -typedef struct Env_s Env; - -struct MalType_s { - - int type; - int is_macro; - MalType* metadata; - - union MalValue { - - long mal_integer; - double mal_float; - char* mal_symbol; - char* mal_string; - char* mal_keyword; - list mal_list; - /* vector mal_vector; TODO: implement a real vector */ - /* hashmap mal_hashmap; TODO: implement a real hashmap */ - MalType* (*mal_function)(list); - MalClosure* mal_closure; - MalType* mal_atom; - MalType* mal_error; - - } value; -}; - -struct MalClosure_s { - - Env* env; - MalType* parameters; - MalType* more_symbol; - MalType* definition; - -}; - -MalType* make_symbol(char* value); -MalType* make_integer(long value); -MalType* make_float(double value); -MalType* make_keyword(char* value); -MalType* make_string(char* value); -MalType* make_list(list value); -MalType* make_vector(list value); -MalType* make_hashmap(list value); -MalType* make_true(); -MalType* make_false(); -MalType* make_nil(); -MalType* make_atom(MalType* value); -MalType* make_error(char* msg); -MalType* make_error_fmt(char* fmt, ...); -MalType* wrap_error(MalType* value); -MalType* make_function(MalType*(*fn)(list args)); -MalType* make_closure(Env* env, MalType* parameters, MalType* definition, MalType* more_symbol); -MalType* copy_type(MalType* value); - -int is_sequential(MalType* val); -int is_self_evaluating(MalType* val); -int is_list(MalType* val); -int is_vector(MalType* val); -int is_hashmap(MalType* val); -int is_nil(MalType* val); -int is_string(MalType* val); -int is_integer(MalType* val); -int is_float(MalType* val); -int is_number(MalType* val); -int is_true(MalType* val); -int is_false(MalType* val); -int is_symbol(MalType* val); -int is_keyword(MalType* val); -int is_atom(MalType* val); -int is_error(MalType* val); -int is_callable(MalType* val); -int is_function(MalType* val); -int is_closure(MalType* val); -int is_macro(MalType* val); - -#endif +#ifndef _MAL_TYPES_H +#define _MAL_TYPES_H + +#include "libs/linked_list/linked_list.h" +#include "libs/hashmap/hashmap.h" + +#define MALTYPE_SYMBOL 1 +#define MALTYPE_KEYWORD 2 +#define MALTYPE_INTEGER 3 +#define MALTYPE_FLOAT 4 +#define MALTYPE_STRING 5 +#define MALTYPE_TRUE 6 +#define MALTYPE_FALSE 7 +#define MALTYPE_NIL 8 +#define MALTYPE_LIST 9 +#define MALTYPE_VECTOR 10 +#define MALTYPE_HASHMAP 11 +#define MALTYPE_FUNCTION 12 +#define MALTYPE_CLOSURE 13 +#define MALTYPE_ERROR 14 +#define MALTYPE_ATOM 15 + +typedef struct MalType_s MalType; +typedef struct MalClosure_s MalClosure; +typedef struct Env_s Env; + +struct MalType_s { + + int type; + int is_macro; + MalType* metadata; + + union MalValue { + + long mal_integer; + double mal_float; + char* mal_symbol; + char* mal_string; + char* mal_keyword; + list mal_list; + /* vector mal_vector; TODO: implement a real vector */ + /* hashmap mal_hashmap; TODO: implement a real hashmap */ + MalType* (*mal_function)(list); + MalClosure* mal_closure; + MalType* mal_atom; + MalType* mal_error; + + } value; +}; + +struct MalClosure_s { + + Env* env; + MalType* parameters; + MalType* more_symbol; + MalType* definition; + +}; + +MalType* make_symbol(char* value); +MalType* make_integer(long value); +MalType* make_float(double value); +MalType* make_keyword(char* value); +MalType* make_string(char* value); +MalType* make_list(list value); +MalType* make_vector(list value); +MalType* make_hashmap(list value); +MalType* make_true(); +MalType* make_false(); +MalType* make_nil(); +MalType* make_atom(MalType* value); +MalType* make_error(char* msg); +MalType* make_error_fmt(char* fmt, ...); +MalType* wrap_error(MalType* value); +MalType* make_function(MalType*(*fn)(list args)); +MalType* make_closure(Env* env, MalType* parameters, MalType* definition, MalType* more_symbol); +MalType* copy_type(MalType* value); + +int is_sequential(MalType* val); +int is_self_evaluating(MalType* val); +int is_list(MalType* val); +int is_vector(MalType* val); +int is_hashmap(MalType* val); +int is_nil(MalType* val); +int is_string(MalType* val); +int is_integer(MalType* val); +int is_float(MalType* val); +int is_number(MalType* val); +int is_true(MalType* val); +int is_false(MalType* val); +int is_symbol(MalType* val); +int is_keyword(MalType* val); +int is_atom(MalType* val); +int is_error(MalType* val); +int is_callable(MalType* val); +int is_function(MalType* val); +int is_closure(MalType* val); +int is_macro(MalType* val); + +#endif diff --git a/impls/c/Dockerfile b/impls/c/Dockerfile index 39ddd95eda..05dbf35f00 100644 --- a/impls/c/Dockerfile +++ b/impls/c/Dockerfile @@ -1,28 +1,28 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install g++ for any C/C++ based implementations -RUN apt-get -y install g++ - -# Libraries needed for the C impl -RUN apt-get -y install libglib2.0 libglib2.0-dev libffi-dev libgc-dev +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install g++ for any C/C++ based implementations +RUN apt-get -y install g++ + +# Libraries needed for the C impl +RUN apt-get -y install libglib2.0 libglib2.0-dev libffi-dev libgc-dev diff --git a/impls/c/Makefile b/impls/c/Makefile index 56c2e5934c..549ec36a40 100644 --- a/impls/c/Makefile +++ b/impls/c/Makefile @@ -1,61 +1,61 @@ -USE_READLINE ?= -USE_GC ?= 1 -CFLAGS ?= -g -O2 -LDFLAGS ?= -g - -##################### - -SRCS = step0_repl.c step1_read_print.c step2_eval.c step3_env.c \ - step4_if_fn_do.c step5_tco.c step6_file.c step7_quote.c \ - step8_macros.c step9_try.c stepA_mal.c -OBJS = $(SRCS:%.c=%.o) -BINS = $(OBJS:%.o=%) -OTHER_OBJS = types.o readline.o reader.o printer.o env.o core.o interop.o -OTHER_HDRS = types.h readline.h reader.h printer.h core.h interop.h - -GLIB_CFLAGS ?= $(shell pkg-config --cflags glib-2.0) -GLIB_LDFLAGS ?= $(shell pkg-config --libs glib-2.0) - -FFI_CFLAGS ?= $(shell pkg-config libffi --cflags) -FFI_LDFLAGS ?= $(shell pkg-config libffi --libs) - -ifeq ($(shell uname -s),Darwin) - darwin_CPPFLAGS ?= -DOSX=1 -endif - -ifeq (,$(USE_READLINE)) -RL_LIBRARY ?= edit -else -RL_LIBRARY ?= readline - rl_CFLAGS ?= -DUSE_READLINE=1 -endif - -ifneq (,$(USE_GC)) - gc_CFLAGS ?= -DUSE_GC=1 - gc_LIBS ?= -lgc -endif - -# Rewrite CPPFLAGS for the Make recipes, but let existing user options -# take precedence. -override CPPFLAGS := \ - ${darwin_CPPFLAGS} ${rl_CFLAGS} ${gc_CFLAGS} ${GLIB_CFLAGS} ${FFI_CFLAGS} \ - ${CPPFLAGS} -override LDLIBS += \ - ${gc_LIBS} -l${RL_LIBRARY} ${GLIB_LDFLAGS} ${FFI_LDFLAGS} -ldl - -##################### - -all: $(BINS) - -dist: mal - -mal: $(word $(words $(BINS)),$(BINS)) - cp $< $@ - -$(OBJS) $(OTHER_OBJS): %.o: %.c $(OTHER_HDRS) - -$(patsubst %.o,%,$(filter step%,$(OBJS))): $(OTHER_OBJS) -$(BINS): %: %.o - -clean: - rm -f $(OBJS) $(BINS) $(OTHER_OBJS) mal +USE_READLINE ?= +USE_GC ?= 1 +CFLAGS ?= -g -O2 +LDFLAGS ?= -g + +##################### + +SRCS = step0_repl.c step1_read_print.c step2_eval.c step3_env.c \ + step4_if_fn_do.c step5_tco.c step6_file.c step7_quote.c \ + step8_macros.c step9_try.c stepA_mal.c +OBJS = $(SRCS:%.c=%.o) +BINS = $(OBJS:%.o=%) +OTHER_OBJS = types.o readline.o reader.o printer.o env.o core.o interop.o +OTHER_HDRS = types.h readline.h reader.h printer.h core.h interop.h + +GLIB_CFLAGS ?= $(shell pkg-config --cflags glib-2.0) +GLIB_LDFLAGS ?= $(shell pkg-config --libs glib-2.0) + +FFI_CFLAGS ?= $(shell pkg-config libffi --cflags) +FFI_LDFLAGS ?= $(shell pkg-config libffi --libs) + +ifeq ($(shell uname -s),Darwin) + darwin_CPPFLAGS ?= -DOSX=1 +endif + +ifeq (,$(USE_READLINE)) +RL_LIBRARY ?= edit +else +RL_LIBRARY ?= readline + rl_CFLAGS ?= -DUSE_READLINE=1 +endif + +ifneq (,$(USE_GC)) + gc_CFLAGS ?= -DUSE_GC=1 + gc_LIBS ?= -lgc +endif + +# Rewrite CPPFLAGS for the Make recipes, but let existing user options +# take precedence. +override CPPFLAGS := \ + ${darwin_CPPFLAGS} ${rl_CFLAGS} ${gc_CFLAGS} ${GLIB_CFLAGS} ${FFI_CFLAGS} \ + ${CPPFLAGS} +override LDLIBS += \ + ${gc_LIBS} -l${RL_LIBRARY} ${GLIB_LDFLAGS} ${FFI_LDFLAGS} -ldl + +##################### + +all: $(BINS) + +dist: mal + +mal: $(word $(words $(BINS)),$(BINS)) + cp $< $@ + +$(OBJS) $(OTHER_OBJS): %.o: %.c $(OTHER_HDRS) + +$(patsubst %.o,%,$(filter step%,$(OBJS))): $(OTHER_OBJS) +$(BINS): %: %.o + +clean: + rm -f $(OBJS) $(BINS) $(OTHER_OBJS) mal diff --git a/impls/c/core.c b/impls/c/core.c index 72a4a59393..f618bd2012 100644 --- a/impls/c/core.c +++ b/impls/c/core.c @@ -1,594 +1,594 @@ -#include -#include -#include -#include -#include -#include -#include -#include - -#include "types.h" -#include "core.h" -#include "reader.h" -#include "printer.h" - -// Errors/Exceptions -void throw(MalVal *obj) { - mal_error = obj; -} - - -// General functions - -MalVal *equal_Q(MalVal *a, MalVal *b) { - if (_equal_Q(a, b)) { return &mal_true; } - else { return &mal_false; } -} - - -// Misc predicates - -MalVal *nil_Q(MalVal *seq) { return seq->type & MAL_NIL ? &mal_true : &mal_false; } -MalVal *true_Q(MalVal *seq) { return seq->type & MAL_TRUE ? &mal_true : &mal_false; } -MalVal *false_Q(MalVal *seq) { return seq->type & MAL_FALSE ? &mal_true : &mal_false; } -MalVal *string_Q(MalVal *seq) { - if ((seq->type & MAL_STRING) && (seq->val.string[0] != '\x7f')) { - return &mal_true; - } else { - return &mal_false; - } -} -MalVal *number_Q(MalVal *obj) { - return obj->type & MAL_INTEGER || obj->type & MAL_FLOAT - ? &mal_true - : &mal_false; -} -MalVal *fn_Q(MalVal *obj) { - return (obj->type & MAL_FUNCTION_C || obj->type & MAL_FUNCTION_MAL) && - !obj->ismacro - ? &mal_true - : &mal_false; -} -MalVal *macro_Q(MalVal *obj) { return obj->ismacro ? &mal_true : &mal_false; } - - - -// Symbol functions - -MalVal *symbol(MalVal *args) { - assert_type(args, MAL_STRING, - "symbol called with non-string value"); - args->type = MAL_SYMBOL; // change string to symbol - return args; -} - -MalVal *symbol_Q(MalVal *seq) { - return seq->type & MAL_SYMBOL ? &mal_true : &mal_false; } - - -// Keyword functions - -MalVal *keyword(MalVal *args) { - assert_type(args, MAL_STRING, - "keyword called with non-string value"); - if (args->val.string[0] == '\x7f') { - return args; - } else { - return malval_new_keyword(args->val.string); - } -} - -MalVal *keyword_Q(MalVal *seq) { - return seq->type & MAL_STRING && seq->val.string[0] == '\x7f' - ? &mal_true - : &mal_false; -} - - -// String functions - -// Return a string representation of a MalVal sequence (in a format that can -// be read by the reader). Returned string must be freed by caller. -MalVal *pr_str(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "pr_str called with non-sequential args"); - return malval_new_string(_pr_str_args(args, " ", 1)); -} - -// Return a string representation of a MalVal sequence with every item -// concatenated together. Returned string must be freed by caller. -MalVal *str(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "str called with non-sequential args"); - return malval_new_string(_pr_str_args(args, "", 0)); -} - -// Print a string representation of a MalVal sequence (in a format that can -// be read by the reader) followed by a newline. Returns nil. -MalVal *prn(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "prn called with non-sequential args"); - char *repr = _pr_str_args(args, " ", 1); - puts(repr); - MAL_GC_FREE(repr); - return &mal_nil; -} - -// Print a string representation of a MalVal sequence (for human consumption) -// followed by a newline. Returns nil. -MalVal *println(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "println called with non-sequential args"); - char *repr = _pr_str_args(args, " ", 0); - puts(repr); - MAL_GC_FREE(repr); - return &mal_nil; -} - -MalVal *mal_readline(MalVal *str) { - assert_type(str, MAL_STRING, "readline of non-string"); - char * line = _readline(str->val.string); - if (line) { return malval_new_string(line); } - else { return &mal_nil; } -} - -MalVal *read_string(MalVal *str) { - assert_type(str, MAL_STRING, "read_string of non-string"); - return read_str(str->val.string); -} - -char *slurp_raw(char *path) { - char *data; - struct stat fst; - int fd = open(path, O_RDONLY), - sz; - if (fd < 0) { - abort("slurp failed to open '%s'", path); - } - if (fstat(fd, &fst) < 0) { - abort("slurp failed to stat '%s'", path); - } - data = MAL_GC_MALLOC(fst.st_size+1); - sz = read(fd, data, fst.st_size); - if (sz < fst.st_size) { - abort("slurp failed to read '%s'", path); - } - data[sz] = '\0'; - return data; -} -MalVal *slurp(MalVal *path) { - assert_type(path, MAL_STRING, "slurp of non-string"); - char *data = slurp_raw(path->val.string); - if (!data || mal_error) { return NULL; } - return malval_new_string(data); -} - - - - -// Number functions - -WRAP_INTEGER_OP(plus,+) -WRAP_INTEGER_OP(minus,-) -WRAP_INTEGER_OP(multiply,*) -WRAP_INTEGER_OP(divide,/) -WRAP_INTEGER_CMP_OP(gt,>) -WRAP_INTEGER_CMP_OP(gte,>=) -WRAP_INTEGER_CMP_OP(lt,<) -WRAP_INTEGER_CMP_OP(lte,<=) - -MalVal *time_ms(MalVal *_) { - struct timeval tv; - long msecs; - gettimeofday(&tv, NULL); - msecs = tv.tv_sec * 1000 + tv.tv_usec/1000.0 + 0.5; - - return malval_new_integer(msecs); -} - - -// List functions - -MalVal *list(MalVal *args) { return _list(args); } -MalVal *list_Q(MalVal *seq) { return _list_Q(seq) ? &mal_true : &mal_false; } - - -// Vector functions - -MalVal *vector(MalVal *args) { return _vector(args); } -MalVal *vector_Q(MalVal *seq) { return _vector_Q(seq) ? &mal_true : &mal_false; } - - -// Hash map functions - -MalVal *hash_map_Q(MalVal *seq) { return _hash_map_Q(seq) ? &mal_true : &mal_false; } - -MalVal *assoc(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "assoc called with non-sequential arguments"); - assert(_count(args) >= 2, - "assoc needs at least 2 arguments"); - GHashTable *htable = g_hash_table_copy(_first(args)->val.hash_table); - MalVal *hm = malval_new_hash_map(htable); - return _assoc_BANG(hm, _rest(args)); -} - -MalVal *dissoc(MalVal* args) { - GHashTable *htable = g_hash_table_copy(_first(args)->val.hash_table); - MalVal *hm = malval_new_hash_map(htable); - return _dissoc_BANG(hm, _rest(args)); -} - -MalVal *keys(MalVal *obj) { - assert_type(obj, MAL_HASH_MAP, - "keys called on non-hash-map"); - - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(obj))); - g_hash_table_iter_init (&iter, obj->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - } - return seq; -} - -MalVal *vals(MalVal *obj) { - assert_type(obj, MAL_HASH_MAP, - "vals called on non-hash-map"); - - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(obj))); - g_hash_table_iter_init (&iter, obj->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - g_array_append_val(seq->val.array, value); - } - return seq; -} - - -// hash map and vector functions -MalVal *get(MalVal *obj, MalVal *key) { - MalVal *val; - switch (obj->type) { - case MAL_VECTOR: - return _nth(obj, key->val.intnum); - case MAL_HASH_MAP: - if (g_hash_table_lookup_extended(obj->val.hash_table, - key->val.string, - NULL, (gpointer*)&val)) { - return val; - } else { - return &mal_nil; - } - case MAL_NIL: - return &mal_nil; - default: - abort("get called on unsupported type %d", obj->type); - } -} - -MalVal *contains_Q(MalVal *obj, MalVal *key) { - switch (obj->type) { - case MAL_VECTOR: - if (key->val.intnum < obj->val.array->len) { - return &mal_true; - } else { - return &mal_false; - } - case MAL_HASH_MAP: - if (g_hash_table_contains(obj->val.hash_table, key->val.string)) { - return &mal_true; - } else { - return &mal_false; - } - default: - abort("contains? called on unsupported type %d", obj->type); - } -} - - -// Sequence functions - -MalVal *sequential_Q(MalVal *seq) { - return _sequential_Q(seq) ? &mal_true : &mal_false; -} - -MalVal *cons(MalVal *x, MalVal *seq) { - assert_type(seq, MAL_LIST|MAL_VECTOR, - "second argument to cons is non-sequential"); - int i, len = _count(seq); - GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - len+1); - g_array_append_val(new_arr, x); - for (i=0; ival.array, MalVal*, i)); - } - return malval_new_list(MAL_LIST, new_arr); -} - -MalVal *concat(MalVal *args) { - MalVal *arg, *e, *lst; - int i, j, arg_cnt = _count(args); - lst = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), arg_cnt)); - for (i=0; ival.array, MalVal*, i); - assert_type(arg, MAL_LIST|MAL_VECTOR, - "concat called with non-sequential"); - for (j=0; j<_count(arg); j++) { - e = g_array_index(arg->val.array, MalVal*, j); - g_array_append_val(lst->val.array, e); - } - } - return lst; -} - -MalVal *vec(MalVal *seq) { - switch(seq->type) { - case MAL_VECTOR: - return seq; - case MAL_LIST: { - const GArray * const src = seq->val.array; - const int len = src->len; - GArray * const dst = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), len); - int i; - for (i=0; ival.array, MalVal*, i)); - return malval_new_list(MAL_VECTOR, dst); - } - default: - _error("vec called with non-sequential"); - } -} - -MalVal *nth(MalVal *seq, MalVal *idx) { - return _nth(seq, idx->val.intnum); -} - -MalVal *empty_Q(MalVal *seq) { - assert_type(seq, MAL_LIST|MAL_VECTOR, - "empty? called with non-sequential"); - return (seq->val.array->len == 0) ? &mal_true : &mal_false; -} - -MalVal *count(MalVal *seq) { - return malval_new_integer(_count(seq)); -} - -MalVal *apply(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "apply called with non-sequential"); - MalVal *f = _nth(args, 0); - MalVal *last_arg = _last(args); - assert_type(last_arg, MAL_LIST|MAL_VECTOR, - "last argument to apply is non-sequential"); - int i, len = _count(args) - 2 + _count(last_arg); - GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - len); - // Initial arguments - for (i=1; i<_count(args)-1; i++) { - g_array_append_val(new_arr, g_array_index(args->val.array, MalVal*, i)); - } - // Add arguments from last_arg - for (i=0; i<_count(last_arg); i++) { - g_array_append_val(new_arr, g_array_index(last_arg->val.array, MalVal*, i)); - } - return _apply(f, malval_new_list(MAL_LIST, new_arr)); -} - -MalVal *map(MalVal *mvf, MalVal *lst) { - MalVal *res, *el; - assert_type(mvf, MAL_FUNCTION_C|MAL_FUNCTION_MAL, - "map called with non-function"); - assert_type(lst, MAL_LIST|MAL_VECTOR, - "map called with non-sequential"); - int i, len = _count(lst); - el = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), len)); - for (i=0; itype & MAL_FUNCTION_MAL) { - Env *fn_env = new_env(mvf->val.func.env, - mvf->val.func.args, - _slice(lst, i, i+1)); - res = mvf->val.func.evaluator(mvf->val.func.body, fn_env); - } else { - res = mvf->val.f1(g_array_index(lst->val.array, MalVal*, i)); - } - if (!res || mal_error) return NULL; - g_array_append_val(el->val.array, res); - } - return el; -} - -MalVal *sconj(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "conj called with non-sequential"); - MalVal *src_lst = _nth(args, 0); - assert_type(args, MAL_LIST|MAL_VECTOR, - "first argument to conj is non-sequential"); - int i, len = _count(src_lst) + _count(args) - 1; - GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - len); - // Copy in src_lst - for (i=0; i<_count(src_lst); i++) { - g_array_append_val(new_arr, g_array_index(src_lst->val.array, MalVal*, i)); - } - // Conj extra args - for (i=1; i<_count(args); i++) { - if (src_lst->type & MAL_LIST) { - g_array_prepend_val(new_arr, g_array_index(args->val.array, MalVal*, i)); - } else { - g_array_append_val(new_arr, g_array_index(args->val.array, MalVal*, i)); - } - } - return malval_new_list(src_lst->type, new_arr); -} - -MalVal *seq(MalVal *obj) { - assert_type(obj, MAL_LIST|MAL_VECTOR|MAL_STRING|MAL_NIL, - "seq: called with non-sequential"); - int cnt, i; - MalVal *lst, *mstr; - switch (obj->type) { - case MAL_LIST: - cnt = _count(obj); - if (cnt == 0) { return &mal_nil; } - return obj; - case MAL_VECTOR: - cnt = _count(obj); - if (cnt == 0) { return &mal_nil; } - lst = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), cnt)); - lst->val.array = obj->val.array; - return lst; - case MAL_STRING: - cnt = strlen(obj->val.string); - if (cnt == 0) { return &mal_nil; } - lst = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), cnt)); - for (i=0; ival.string[i])); - g_array_append_val(lst->val.array, mstr); - } - return lst; - case MAL_NIL: - return &mal_nil; - } -} - - -// Metadata functions - -MalVal *with_meta(MalVal *obj, MalVal *meta) { - MalVal *new_obj = malval_new(obj->type, meta); - new_obj->val = obj->val; - return new_obj; -} - -MalVal *meta(MalVal *obj) { - assert_type(obj, MAL_LIST|MAL_VECTOR|MAL_HASH_MAP| - MAL_FUNCTION_C|MAL_FUNCTION_MAL|MAL_ATOM, - "attempt to get metadata from non-collection type"); - if (obj->metadata == NULL) { - return &mal_nil; - } else { - return obj->metadata; - } -} - - -// Atoms - -MalVal *atom(MalVal *val) { - return malval_new_atom(val); -} - -MalVal *atom_Q(MalVal *exp) { return _atom_Q(exp) ? &mal_true : &mal_false; } - -MalVal *deref(MalVal *atm) { - assert_type(atm, MAL_ATOM, - "deref called on non-atom"); - return atm->val.atom_val; -} - -MalVal *reset_BANG(MalVal *atm, MalVal *val) { - assert_type(atm, MAL_ATOM, - "reset! called with non-atom"); - atm->val.atom_val = val; - return val; -} - -MalVal *swap_BANG(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "swap! called with invalid arguments"); - assert(_count(args) >= 2, - "swap! called with %d args, needs at least 2", _count(args)); - MalVal *atm = _nth(args, 0), - *f = _nth(args, 1), - *sargs = _slice(args, 2, _count(args)), - *fargs = cons(atm->val.atom_val, sargs), - *new_val = _apply(f, fargs); - if (mal_error) { return NULL; } - atm->val.atom_val = new_val; - return new_val; -} - - - -core_ns_entry core_ns[] = { - {"=", (void*(*)(void*))equal_Q, 2}, - {"throw", (void*(*)(void*))throw, 1}, - {"nil?", (void*(*)(void*))nil_Q, 1}, - {"true?", (void*(*)(void*))true_Q, 1}, - {"false?", (void*(*)(void*))false_Q, 1}, - {"string?", (void*(*)(void*))string_Q, 1}, - {"symbol", (void*(*)(void*))symbol, 1}, - {"symbol?", (void*(*)(void*))symbol_Q, 1}, - {"keyword", (void*(*)(void*))keyword, 1}, - {"keyword?", (void*(*)(void*))keyword_Q, 1}, - {"number?", (void*(*)(void*))number_Q, 1}, - {"fn?", (void*(*)(void*))fn_Q, 1}, - {"macro?", (void*(*)(void*))macro_Q, 1}, - - {"pr-str", (void*(*)(void*))pr_str, -1}, - {"str", (void*(*)(void*))str, -1}, - {"prn", (void*(*)(void*))prn, -1}, - {"println", (void*(*)(void*))println, -1}, - {"readline", (void*(*)(void*))mal_readline, 1}, - {"read-string", (void*(*)(void*))read_string, 1}, - {"slurp", (void*(*)(void*))slurp, 1}, - {"<", (void*(*)(void*))int_lt, 2}, - {"<=", (void*(*)(void*))int_lte, 2}, - {">", (void*(*)(void*))int_gt, 2}, - {">=", (void*(*)(void*))int_gte, 2}, - {"+", (void*(*)(void*))int_plus, 2}, - {"-", (void*(*)(void*))int_minus, 2}, - {"*", (void*(*)(void*))int_multiply, 2}, - {"/", (void*(*)(void*))int_divide, 2}, - {"time-ms", (void*(*)(void*))time_ms, 0}, - - {"list", (void*(*)(void*))list, -1}, - {"list?", (void*(*)(void*))list_Q, 1}, - {"vector", (void*(*)(void*))vector, -1}, - {"vector?", (void*(*)(void*))vector_Q, 1}, - {"hash-map", (void*(*)(void*))_hash_map, -1}, - {"map?", (void*(*)(void*))hash_map_Q, 1}, - {"assoc", (void*(*)(void*))assoc, -1}, - {"dissoc", (void*(*)(void*))dissoc, -1}, - {"get", (void*(*)(void*))get, 2}, - {"contains?", (void*(*)(void*))contains_Q, 2}, - {"keys", (void*(*)(void*))keys, 1}, - {"vals", (void*(*)(void*))vals, 1}, - - {"sequential?", (void*(*)(void*))sequential_Q, 1}, - {"cons", (void*(*)(void*))cons, 2}, - {"concat", (void*(*)(void*))concat, -1}, - {"vec", (void*(*)(void*))vec, 1}, - {"nth", (void*(*)(void*))nth, 2}, - {"first", (void*(*)(void*))_first, 1}, - {"rest", (void*(*)(void*))_rest, 1}, - {"last", (void*(*)(void*))_last, 1}, - {"empty?", (void*(*)(void*))empty_Q, 1}, - {"count", (void*(*)(void*))count, 1}, - {"apply", (void*(*)(void*))apply, -1}, - {"map", (void*(*)(void*))map, 2}, - - {"conj", (void*(*)(void*))sconj, -1}, - {"seq", (void*(*)(void*))seq, 1}, - - {"with-meta", (void*(*)(void*))with_meta, 2}, - {"meta", (void*(*)(void*))meta, 1}, - {"atom", (void*(*)(void*))atom, 1}, - {"atom?", (void*(*)(void*))atom_Q, 1}, - {"deref", (void*(*)(void*))deref, 1}, - {"reset!", (void*(*)(void*))reset_BANG, 2}, - {"swap!", (void*(*)(void*))swap_BANG, -1}, - }; +#include +#include +#include +#include +#include +#include +#include +#include + +#include "types.h" +#include "core.h" +#include "reader.h" +#include "printer.h" + +// Errors/Exceptions +void throw(MalVal *obj) { + mal_error = obj; +} + + +// General functions + +MalVal *equal_Q(MalVal *a, MalVal *b) { + if (_equal_Q(a, b)) { return &mal_true; } + else { return &mal_false; } +} + + +// Misc predicates + +MalVal *nil_Q(MalVal *seq) { return seq->type & MAL_NIL ? &mal_true : &mal_false; } +MalVal *true_Q(MalVal *seq) { return seq->type & MAL_TRUE ? &mal_true : &mal_false; } +MalVal *false_Q(MalVal *seq) { return seq->type & MAL_FALSE ? &mal_true : &mal_false; } +MalVal *string_Q(MalVal *seq) { + if ((seq->type & MAL_STRING) && (seq->val.string[0] != '\x7f')) { + return &mal_true; + } else { + return &mal_false; + } +} +MalVal *number_Q(MalVal *obj) { + return obj->type & MAL_INTEGER || obj->type & MAL_FLOAT + ? &mal_true + : &mal_false; +} +MalVal *fn_Q(MalVal *obj) { + return (obj->type & MAL_FUNCTION_C || obj->type & MAL_FUNCTION_MAL) && + !obj->ismacro + ? &mal_true + : &mal_false; +} +MalVal *macro_Q(MalVal *obj) { return obj->ismacro ? &mal_true : &mal_false; } + + + +// Symbol functions + +MalVal *symbol(MalVal *args) { + assert_type(args, MAL_STRING, + "symbol called with non-string value"); + args->type = MAL_SYMBOL; // change string to symbol + return args; +} + +MalVal *symbol_Q(MalVal *seq) { + return seq->type & MAL_SYMBOL ? &mal_true : &mal_false; } + + +// Keyword functions + +MalVal *keyword(MalVal *args) { + assert_type(args, MAL_STRING, + "keyword called with non-string value"); + if (args->val.string[0] == '\x7f') { + return args; + } else { + return malval_new_keyword(args->val.string); + } +} + +MalVal *keyword_Q(MalVal *seq) { + return seq->type & MAL_STRING && seq->val.string[0] == '\x7f' + ? &mal_true + : &mal_false; +} + + +// String functions + +// Return a string representation of a MalVal sequence (in a format that can +// be read by the reader). Returned string must be freed by caller. +MalVal *pr_str(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "pr_str called with non-sequential args"); + return malval_new_string(_pr_str_args(args, " ", 1)); +} + +// Return a string representation of a MalVal sequence with every item +// concatenated together. Returned string must be freed by caller. +MalVal *str(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "str called with non-sequential args"); + return malval_new_string(_pr_str_args(args, "", 0)); +} + +// Print a string representation of a MalVal sequence (in a format that can +// be read by the reader) followed by a newline. Returns nil. +MalVal *prn(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "prn called with non-sequential args"); + char *repr = _pr_str_args(args, " ", 1); + puts(repr); + MAL_GC_FREE(repr); + return &mal_nil; +} + +// Print a string representation of a MalVal sequence (for human consumption) +// followed by a newline. Returns nil. +MalVal *println(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "println called with non-sequential args"); + char *repr = _pr_str_args(args, " ", 0); + puts(repr); + MAL_GC_FREE(repr); + return &mal_nil; +} + +MalVal *mal_readline(MalVal *str) { + assert_type(str, MAL_STRING, "readline of non-string"); + char * line = _readline(str->val.string); + if (line) { return malval_new_string(line); } + else { return &mal_nil; } +} + +MalVal *read_string(MalVal *str) { + assert_type(str, MAL_STRING, "read_string of non-string"); + return read_str(str->val.string); +} + +char *slurp_raw(char *path) { + char *data; + struct stat fst; + int fd = open(path, O_RDONLY), + sz; + if (fd < 0) { + abort("slurp failed to open '%s'", path); + } + if (fstat(fd, &fst) < 0) { + abort("slurp failed to stat '%s'", path); + } + data = MAL_GC_MALLOC(fst.st_size+1); + sz = read(fd, data, fst.st_size); + if (sz < fst.st_size) { + abort("slurp failed to read '%s'", path); + } + data[sz] = '\0'; + return data; +} +MalVal *slurp(MalVal *path) { + assert_type(path, MAL_STRING, "slurp of non-string"); + char *data = slurp_raw(path->val.string); + if (!data || mal_error) { return NULL; } + return malval_new_string(data); +} + + + + +// Number functions + +WRAP_INTEGER_OP(plus,+) +WRAP_INTEGER_OP(minus,-) +WRAP_INTEGER_OP(multiply,*) +WRAP_INTEGER_OP(divide,/) +WRAP_INTEGER_CMP_OP(gt,>) +WRAP_INTEGER_CMP_OP(gte,>=) +WRAP_INTEGER_CMP_OP(lt,<) +WRAP_INTEGER_CMP_OP(lte,<=) + +MalVal *time_ms(MalVal *_) { + struct timeval tv; + long msecs; + gettimeofday(&tv, NULL); + msecs = tv.tv_sec * 1000 + tv.tv_usec/1000.0 + 0.5; + + return malval_new_integer(msecs); +} + + +// List functions + +MalVal *list(MalVal *args) { return _list(args); } +MalVal *list_Q(MalVal *seq) { return _list_Q(seq) ? &mal_true : &mal_false; } + + +// Vector functions + +MalVal *vector(MalVal *args) { return _vector(args); } +MalVal *vector_Q(MalVal *seq) { return _vector_Q(seq) ? &mal_true : &mal_false; } + + +// Hash map functions + +MalVal *hash_map_Q(MalVal *seq) { return _hash_map_Q(seq) ? &mal_true : &mal_false; } + +MalVal *assoc(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "assoc called with non-sequential arguments"); + assert(_count(args) >= 2, + "assoc needs at least 2 arguments"); + GHashTable *htable = g_hash_table_copy(_first(args)->val.hash_table); + MalVal *hm = malval_new_hash_map(htable); + return _assoc_BANG(hm, _rest(args)); +} + +MalVal *dissoc(MalVal* args) { + GHashTable *htable = g_hash_table_copy(_first(args)->val.hash_table); + MalVal *hm = malval_new_hash_map(htable); + return _dissoc_BANG(hm, _rest(args)); +} + +MalVal *keys(MalVal *obj) { + assert_type(obj, MAL_HASH_MAP, + "keys called on non-hash-map"); + + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(obj))); + g_hash_table_iter_init (&iter, obj->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + } + return seq; +} + +MalVal *vals(MalVal *obj) { + assert_type(obj, MAL_HASH_MAP, + "vals called on non-hash-map"); + + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(obj))); + g_hash_table_iter_init (&iter, obj->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + g_array_append_val(seq->val.array, value); + } + return seq; +} + + +// hash map and vector functions +MalVal *get(MalVal *obj, MalVal *key) { + MalVal *val; + switch (obj->type) { + case MAL_VECTOR: + return _nth(obj, key->val.intnum); + case MAL_HASH_MAP: + if (g_hash_table_lookup_extended(obj->val.hash_table, + key->val.string, + NULL, (gpointer*)&val)) { + return val; + } else { + return &mal_nil; + } + case MAL_NIL: + return &mal_nil; + default: + abort("get called on unsupported type %d", obj->type); + } +} + +MalVal *contains_Q(MalVal *obj, MalVal *key) { + switch (obj->type) { + case MAL_VECTOR: + if (key->val.intnum < obj->val.array->len) { + return &mal_true; + } else { + return &mal_false; + } + case MAL_HASH_MAP: + if (g_hash_table_contains(obj->val.hash_table, key->val.string)) { + return &mal_true; + } else { + return &mal_false; + } + default: + abort("contains? called on unsupported type %d", obj->type); + } +} + + +// Sequence functions + +MalVal *sequential_Q(MalVal *seq) { + return _sequential_Q(seq) ? &mal_true : &mal_false; +} + +MalVal *cons(MalVal *x, MalVal *seq) { + assert_type(seq, MAL_LIST|MAL_VECTOR, + "second argument to cons is non-sequential"); + int i, len = _count(seq); + GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + len+1); + g_array_append_val(new_arr, x); + for (i=0; ival.array, MalVal*, i)); + } + return malval_new_list(MAL_LIST, new_arr); +} + +MalVal *concat(MalVal *args) { + MalVal *arg, *e, *lst; + int i, j, arg_cnt = _count(args); + lst = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), arg_cnt)); + for (i=0; ival.array, MalVal*, i); + assert_type(arg, MAL_LIST|MAL_VECTOR, + "concat called with non-sequential"); + for (j=0; j<_count(arg); j++) { + e = g_array_index(arg->val.array, MalVal*, j); + g_array_append_val(lst->val.array, e); + } + } + return lst; +} + +MalVal *vec(MalVal *seq) { + switch(seq->type) { + case MAL_VECTOR: + return seq; + case MAL_LIST: { + const GArray * const src = seq->val.array; + const int len = src->len; + GArray * const dst = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), len); + int i; + for (i=0; ival.array, MalVal*, i)); + return malval_new_list(MAL_VECTOR, dst); + } + default: + _error("vec called with non-sequential"); + } +} + +MalVal *nth(MalVal *seq, MalVal *idx) { + return _nth(seq, idx->val.intnum); +} + +MalVal *empty_Q(MalVal *seq) { + assert_type(seq, MAL_LIST|MAL_VECTOR, + "empty? called with non-sequential"); + return (seq->val.array->len == 0) ? &mal_true : &mal_false; +} + +MalVal *count(MalVal *seq) { + return malval_new_integer(_count(seq)); +} + +MalVal *apply(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "apply called with non-sequential"); + MalVal *f = _nth(args, 0); + MalVal *last_arg = _last(args); + assert_type(last_arg, MAL_LIST|MAL_VECTOR, + "last argument to apply is non-sequential"); + int i, len = _count(args) - 2 + _count(last_arg); + GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + len); + // Initial arguments + for (i=1; i<_count(args)-1; i++) { + g_array_append_val(new_arr, g_array_index(args->val.array, MalVal*, i)); + } + // Add arguments from last_arg + for (i=0; i<_count(last_arg); i++) { + g_array_append_val(new_arr, g_array_index(last_arg->val.array, MalVal*, i)); + } + return _apply(f, malval_new_list(MAL_LIST, new_arr)); +} + +MalVal *map(MalVal *mvf, MalVal *lst) { + MalVal *res, *el; + assert_type(mvf, MAL_FUNCTION_C|MAL_FUNCTION_MAL, + "map called with non-function"); + assert_type(lst, MAL_LIST|MAL_VECTOR, + "map called with non-sequential"); + int i, len = _count(lst); + el = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), len)); + for (i=0; itype & MAL_FUNCTION_MAL) { + Env *fn_env = new_env(mvf->val.func.env, + mvf->val.func.args, + _slice(lst, i, i+1)); + res = mvf->val.func.evaluator(mvf->val.func.body, fn_env); + } else { + res = mvf->val.f1(g_array_index(lst->val.array, MalVal*, i)); + } + if (!res || mal_error) return NULL; + g_array_append_val(el->val.array, res); + } + return el; +} + +MalVal *sconj(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "conj called with non-sequential"); + MalVal *src_lst = _nth(args, 0); + assert_type(args, MAL_LIST|MAL_VECTOR, + "first argument to conj is non-sequential"); + int i, len = _count(src_lst) + _count(args) - 1; + GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + len); + // Copy in src_lst + for (i=0; i<_count(src_lst); i++) { + g_array_append_val(new_arr, g_array_index(src_lst->val.array, MalVal*, i)); + } + // Conj extra args + for (i=1; i<_count(args); i++) { + if (src_lst->type & MAL_LIST) { + g_array_prepend_val(new_arr, g_array_index(args->val.array, MalVal*, i)); + } else { + g_array_append_val(new_arr, g_array_index(args->val.array, MalVal*, i)); + } + } + return malval_new_list(src_lst->type, new_arr); +} + +MalVal *seq(MalVal *obj) { + assert_type(obj, MAL_LIST|MAL_VECTOR|MAL_STRING|MAL_NIL, + "seq: called with non-sequential"); + int cnt, i; + MalVal *lst, *mstr; + switch (obj->type) { + case MAL_LIST: + cnt = _count(obj); + if (cnt == 0) { return &mal_nil; } + return obj; + case MAL_VECTOR: + cnt = _count(obj); + if (cnt == 0) { return &mal_nil; } + lst = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), cnt)); + lst->val.array = obj->val.array; + return lst; + case MAL_STRING: + cnt = strlen(obj->val.string); + if (cnt == 0) { return &mal_nil; } + lst = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), cnt)); + for (i=0; ival.string[i])); + g_array_append_val(lst->val.array, mstr); + } + return lst; + case MAL_NIL: + return &mal_nil; + } +} + + +// Metadata functions + +MalVal *with_meta(MalVal *obj, MalVal *meta) { + MalVal *new_obj = malval_new(obj->type, meta); + new_obj->val = obj->val; + return new_obj; +} + +MalVal *meta(MalVal *obj) { + assert_type(obj, MAL_LIST|MAL_VECTOR|MAL_HASH_MAP| + MAL_FUNCTION_C|MAL_FUNCTION_MAL|MAL_ATOM, + "attempt to get metadata from non-collection type"); + if (obj->metadata == NULL) { + return &mal_nil; + } else { + return obj->metadata; + } +} + + +// Atoms + +MalVal *atom(MalVal *val) { + return malval_new_atom(val); +} + +MalVal *atom_Q(MalVal *exp) { return _atom_Q(exp) ? &mal_true : &mal_false; } + +MalVal *deref(MalVal *atm) { + assert_type(atm, MAL_ATOM, + "deref called on non-atom"); + return atm->val.atom_val; +} + +MalVal *reset_BANG(MalVal *atm, MalVal *val) { + assert_type(atm, MAL_ATOM, + "reset! called with non-atom"); + atm->val.atom_val = val; + return val; +} + +MalVal *swap_BANG(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "swap! called with invalid arguments"); + assert(_count(args) >= 2, + "swap! called with %d args, needs at least 2", _count(args)); + MalVal *atm = _nth(args, 0), + *f = _nth(args, 1), + *sargs = _slice(args, 2, _count(args)), + *fargs = cons(atm->val.atom_val, sargs), + *new_val = _apply(f, fargs); + if (mal_error) { return NULL; } + atm->val.atom_val = new_val; + return new_val; +} + + + +core_ns_entry core_ns[] = { + {"=", (void*(*)(void*))equal_Q, 2}, + {"throw", (void*(*)(void*))throw, 1}, + {"nil?", (void*(*)(void*))nil_Q, 1}, + {"true?", (void*(*)(void*))true_Q, 1}, + {"false?", (void*(*)(void*))false_Q, 1}, + {"string?", (void*(*)(void*))string_Q, 1}, + {"symbol", (void*(*)(void*))symbol, 1}, + {"symbol?", (void*(*)(void*))symbol_Q, 1}, + {"keyword", (void*(*)(void*))keyword, 1}, + {"keyword?", (void*(*)(void*))keyword_Q, 1}, + {"number?", (void*(*)(void*))number_Q, 1}, + {"fn?", (void*(*)(void*))fn_Q, 1}, + {"macro?", (void*(*)(void*))macro_Q, 1}, + + {"pr-str", (void*(*)(void*))pr_str, -1}, + {"str", (void*(*)(void*))str, -1}, + {"prn", (void*(*)(void*))prn, -1}, + {"println", (void*(*)(void*))println, -1}, + {"readline", (void*(*)(void*))mal_readline, 1}, + {"read-string", (void*(*)(void*))read_string, 1}, + {"slurp", (void*(*)(void*))slurp, 1}, + {"<", (void*(*)(void*))int_lt, 2}, + {"<=", (void*(*)(void*))int_lte, 2}, + {">", (void*(*)(void*))int_gt, 2}, + {">=", (void*(*)(void*))int_gte, 2}, + {"+", (void*(*)(void*))int_plus, 2}, + {"-", (void*(*)(void*))int_minus, 2}, + {"*", (void*(*)(void*))int_multiply, 2}, + {"/", (void*(*)(void*))int_divide, 2}, + {"time-ms", (void*(*)(void*))time_ms, 0}, + + {"list", (void*(*)(void*))list, -1}, + {"list?", (void*(*)(void*))list_Q, 1}, + {"vector", (void*(*)(void*))vector, -1}, + {"vector?", (void*(*)(void*))vector_Q, 1}, + {"hash-map", (void*(*)(void*))_hash_map, -1}, + {"map?", (void*(*)(void*))hash_map_Q, 1}, + {"assoc", (void*(*)(void*))assoc, -1}, + {"dissoc", (void*(*)(void*))dissoc, -1}, + {"get", (void*(*)(void*))get, 2}, + {"contains?", (void*(*)(void*))contains_Q, 2}, + {"keys", (void*(*)(void*))keys, 1}, + {"vals", (void*(*)(void*))vals, 1}, + + {"sequential?", (void*(*)(void*))sequential_Q, 1}, + {"cons", (void*(*)(void*))cons, 2}, + {"concat", (void*(*)(void*))concat, -1}, + {"vec", (void*(*)(void*))vec, 1}, + {"nth", (void*(*)(void*))nth, 2}, + {"first", (void*(*)(void*))_first, 1}, + {"rest", (void*(*)(void*))_rest, 1}, + {"last", (void*(*)(void*))_last, 1}, + {"empty?", (void*(*)(void*))empty_Q, 1}, + {"count", (void*(*)(void*))count, 1}, + {"apply", (void*(*)(void*))apply, -1}, + {"map", (void*(*)(void*))map, 2}, + + {"conj", (void*(*)(void*))sconj, -1}, + {"seq", (void*(*)(void*))seq, 1}, + + {"with-meta", (void*(*)(void*))with_meta, 2}, + {"meta", (void*(*)(void*))meta, 1}, + {"atom", (void*(*)(void*))atom, 1}, + {"atom?", (void*(*)(void*))atom_Q, 1}, + {"deref", (void*(*)(void*))deref, 1}, + {"reset!", (void*(*)(void*))reset_BANG, 2}, + {"swap!", (void*(*)(void*))swap_BANG, -1}, + }; diff --git a/impls/c/core.h b/impls/c/core.h index 2e871d6eb5..35408c2e52 100644 --- a/impls/c/core.h +++ b/impls/c/core.h @@ -1,15 +1,15 @@ -#ifndef __MAL_CORE__ -#define __MAL_CORE__ - -#include - -// namespace of type functions -typedef struct { - char *name; - void *(*func)(void*); - int arg_cnt; -} core_ns_entry; - -extern core_ns_entry core_ns[62]; - -#endif +#ifndef __MAL_CORE__ +#define __MAL_CORE__ + +#include + +// namespace of type functions +typedef struct { + char *name; + void *(*func)(void*); + int arg_cnt; +} core_ns_entry; + +extern core_ns_entry core_ns[62]; + +#endif diff --git a/impls/c/env.c b/impls/c/env.c index c3128f97af..132588ca0f 100644 --- a/impls/c/env.c +++ b/impls/c/env.c @@ -1,57 +1,57 @@ -#include -#include "types.h" - -// Env - -Env *new_env(Env *outer, MalVal* binds, MalVal *exprs) { - Env *e = MAL_GC_MALLOC(sizeof(Env)); - e->table = g_hash_table_new(g_str_hash, g_str_equal); - e->outer = outer; - - if (binds && exprs) { - assert_type(binds, MAL_LIST|MAL_VECTOR, - "new_env called with non-sequential bindings"); - assert_type(exprs, MAL_LIST|MAL_VECTOR, - "new_env called with non-sequential expressions"); - int binds_len = _count(binds), - exprs_len = _count(exprs), - varargs = 0, i; - for (i=0; i exprs_len) { break; } - if (_nth(binds, i)->val.string[0] == '&') { - varargs = 1; - env_set(e, _nth(binds, i+1), _slice(exprs, i, _count(exprs))); - break; - } else { - env_set(e, _nth(binds, i), _nth(exprs, i)); - } - } - assert(varargs || (binds_len == exprs_len), - "Arity mismatch: %d formal params vs %d actual params", - binds_len, exprs_len); - - } - return e; -} - -Env *env_find(Env *env, MalVal *key) { - void *val = g_hash_table_lookup(env->table, key->val.string); - if (val) { - return env; - } else if (env->outer) { - return env_find(env->outer, key); - } else { - return NULL; - } -} - -MalVal *env_get(Env *env, MalVal *key) { - Env *e = env_find(env, key); - assert(e, "'%s' not found", key->val.string); - return g_hash_table_lookup(e->table, key->val.string); -} - -Env *env_set(Env *env, MalVal *key, MalVal *val) { - g_hash_table_insert(env->table, key->val.string, val); - return env; -} +#include +#include "types.h" + +// Env + +Env *new_env(Env *outer, MalVal* binds, MalVal *exprs) { + Env *e = MAL_GC_MALLOC(sizeof(Env)); + e->table = g_hash_table_new(g_str_hash, g_str_equal); + e->outer = outer; + + if (binds && exprs) { + assert_type(binds, MAL_LIST|MAL_VECTOR, + "new_env called with non-sequential bindings"); + assert_type(exprs, MAL_LIST|MAL_VECTOR, + "new_env called with non-sequential expressions"); + int binds_len = _count(binds), + exprs_len = _count(exprs), + varargs = 0, i; + for (i=0; i exprs_len) { break; } + if (_nth(binds, i)->val.string[0] == '&') { + varargs = 1; + env_set(e, _nth(binds, i+1), _slice(exprs, i, _count(exprs))); + break; + } else { + env_set(e, _nth(binds, i), _nth(exprs, i)); + } + } + assert(varargs || (binds_len == exprs_len), + "Arity mismatch: %d formal params vs %d actual params", + binds_len, exprs_len); + + } + return e; +} + +Env *env_find(Env *env, MalVal *key) { + void *val = g_hash_table_lookup(env->table, key->val.string); + if (val) { + return env; + } else if (env->outer) { + return env_find(env->outer, key); + } else { + return NULL; + } +} + +MalVal *env_get(Env *env, MalVal *key) { + Env *e = env_find(env, key); + assert(e, "'%s' not found", key->val.string); + return g_hash_table_lookup(e->table, key->val.string); +} + +Env *env_set(Env *env, MalVal *key, MalVal *val) { + g_hash_table_insert(env->table, key->val.string, val); + return env; +} diff --git a/impls/c/interop.c b/impls/c/interop.c index a1f6b00fc3..604519cde1 100644 --- a/impls/c/interop.c +++ b/impls/c/interop.c @@ -1,172 +1,172 @@ -#include -#include -#if OSX - #include -#else - #include -#endif - -#include "types.h" - - -GHashTable *loaded_dls = NULL; - -int get_byte_size(char *type) { - return 0; -} - -typedef struct Raw64 { - union { - gdouble floatnum; - gint64 integernum; - char *string; - } v; -} Raw64; - - -// obj must be a pointer to the object to store -ffi_type *_get_ffi_type(char *type) { - if ((strcmp("void", type) == 0)) { - return &ffi_type_void; - } else if ((strcmp("string", type) == 0) || - (strcmp("char*", type) == 0) || - (strcmp("char *", type) == 0)) { - return &ffi_type_pointer; - } else if ((strcmp("integer", type) == 0) || - (strcmp("int64", type) == 0)) { - return &ffi_type_sint64; - } else if ((strcmp("int32", type) == 0)) { - return &ffi_type_sint32; - } else if (strcmp("double", type) == 0) { - return &ffi_type_double; - } else if (strcmp("float", type) == 0) { - return &ffi_type_float; - } else { - abort("_get_ffi_type of unknown type '%s'", type); - } -} - -MalVal *_malval_new_by_type(char *type) { - if ((strcmp("void", type) == 0)) { - return NULL; - } else if ((strcmp("string", type) == 0) || - (strcmp("char*", type) == 0) || - (strcmp("char *", type) == 0)) { - return malval_new(MAL_STRING, NULL); - } else if ((strcmp("integer", type) == 0) || - (strcmp("int64", type) == 0)) { - return malval_new(MAL_INTEGER, NULL); - } else if ((strcmp("int32", type) == 0)) { - return malval_new(MAL_INTEGER, NULL); - } else if (strcmp("double", type) == 0) { - return malval_new(MAL_FLOAT, NULL); - } else if (strcmp("float", type) == 0) { - return malval_new(MAL_FLOAT, NULL); - } else { - abort("_malval_new_by_type of unknown type '%s'", type); - } -} - - - -// Mal syntax: -// (. {DYN_LIB_FILE|nil} RETURN_TYPE FUNC_NAME [ARG_TYPE ARG]...) -MalVal *invoke_native(MalVal *call_data) { - //g_print("invoke_native %s\n", pr_str(call_data)); - int cd_len = call_data->val.array->len; - int arg_len = (cd_len - 3)/2; - char *error; - void *dl_handle; - - assert_type(call_data, MAL_LIST, - "invoke_native called with non-list call_data: %s", - _pr_str(call_data,1)); - assert(cd_len >= 3, - "invoke_native called with %d args, needs at least 3", - cd_len); - assert((cd_len % 2) == 1, - "invoke_native called with an even number of args (%d)", - cd_len); - assert(arg_len <= 3, - "invoke_native called with more than 3 native args (%d)", - arg_len); - MalVal *dl_file = _nth(call_data, 0), - *ftype = _nth(call_data, 1), - *fname = _nth(call_data, 2); - assert_type(dl_file, MAL_STRING|MAL_NIL, - "invoke_native arg 1 (DYN_LIB_NAME) must be a string or nil"); - assert_type(ftype, MAL_STRING, - "invoke_native arg 2 (RETURN_TYPE) must be a string"); - assert_type(fname, MAL_STRING, - "invoke_native arg 3 (FUNC_NAME) must be a string"); - - // Cached load of the dynamic library handle - if (dl_file->type == MAL_NIL) { - dl_handle = dlopen(NULL, RTLD_LAZY); - } else { - // Load the library - if (loaded_dls == NULL) { - loaded_dls = g_hash_table_new(g_str_hash, g_str_equal); - } - dl_handle = g_hash_table_lookup(loaded_dls, dl_file->val.string); - dlerror(); // clear any existing error - if (!dl_handle) { - dl_handle = dlopen(dl_file->val.string, RTLD_LAZY); - } - if ((error = dlerror()) != NULL) { - abort("Could not dlopen '%s': %s", dl_file->val.string, error); - } - g_hash_table_insert(loaded_dls, dl_file->val.string, dl_handle); - } - - void * func = dlsym(dl_handle, fname->val.string); - if ((error = dlerror()) != NULL) { - abort("Could not dlsym '%s': %s", fname->val.string, error); - } - - - // - // Use FFI library to make a dynamic call - // - - // Based on: - // http://eli.thegreenplace.net/2013/03/04/flexible-runtime-interface-to-shared-libraries-with-libffi/ - ffi_cif cif; - ffi_type *ret_type; - ffi_type *arg_types[20]; - void *arg_vals[20]; - ffi_status status; - MalVal *ret_mv; - - // Set return type - ret_type = _get_ffi_type(ftype->val.string); - ret_mv = _malval_new_by_type(ftype->val.string); - if (mal_error) { return NULL; } - - // Set the argument types and values - int i; - for (i=0; i < arg_len; i++) { - arg_types[i] = _get_ffi_type(_nth(call_data, 3+i*2)->val.string); - if (arg_types[i] == NULL) { - return NULL; - } - arg_vals[i] = &_nth(call_data, 4+i*2)->val; - } - - status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, arg_len, - ret_type, arg_types); - if (status != FFI_OK) { - abort("ffi_prep_cif failed: %d\n", status); - } - - // Perform the call - //g_print("Calling %s[%p](%d)\n", fname->val.string, func, arg_len); - ffi_call(&cif, FFI_FN(func), &ret_mv->val, arg_vals); - - if (ret_type == &ffi_type_void) { - return &mal_nil; - } else { - return ret_mv; - } -} - +#include +#include +#if OSX + #include +#else + #include +#endif + +#include "types.h" + + +GHashTable *loaded_dls = NULL; + +int get_byte_size(char *type) { + return 0; +} + +typedef struct Raw64 { + union { + gdouble floatnum; + gint64 integernum; + char *string; + } v; +} Raw64; + + +// obj must be a pointer to the object to store +ffi_type *_get_ffi_type(char *type) { + if ((strcmp("void", type) == 0)) { + return &ffi_type_void; + } else if ((strcmp("string", type) == 0) || + (strcmp("char*", type) == 0) || + (strcmp("char *", type) == 0)) { + return &ffi_type_pointer; + } else if ((strcmp("integer", type) == 0) || + (strcmp("int64", type) == 0)) { + return &ffi_type_sint64; + } else if ((strcmp("int32", type) == 0)) { + return &ffi_type_sint32; + } else if (strcmp("double", type) == 0) { + return &ffi_type_double; + } else if (strcmp("float", type) == 0) { + return &ffi_type_float; + } else { + abort("_get_ffi_type of unknown type '%s'", type); + } +} + +MalVal *_malval_new_by_type(char *type) { + if ((strcmp("void", type) == 0)) { + return NULL; + } else if ((strcmp("string", type) == 0) || + (strcmp("char*", type) == 0) || + (strcmp("char *", type) == 0)) { + return malval_new(MAL_STRING, NULL); + } else if ((strcmp("integer", type) == 0) || + (strcmp("int64", type) == 0)) { + return malval_new(MAL_INTEGER, NULL); + } else if ((strcmp("int32", type) == 0)) { + return malval_new(MAL_INTEGER, NULL); + } else if (strcmp("double", type) == 0) { + return malval_new(MAL_FLOAT, NULL); + } else if (strcmp("float", type) == 0) { + return malval_new(MAL_FLOAT, NULL); + } else { + abort("_malval_new_by_type of unknown type '%s'", type); + } +} + + + +// Mal syntax: +// (. {DYN_LIB_FILE|nil} RETURN_TYPE FUNC_NAME [ARG_TYPE ARG]...) +MalVal *invoke_native(MalVal *call_data) { + //g_print("invoke_native %s\n", pr_str(call_data)); + int cd_len = call_data->val.array->len; + int arg_len = (cd_len - 3)/2; + char *error; + void *dl_handle; + + assert_type(call_data, MAL_LIST, + "invoke_native called with non-list call_data: %s", + _pr_str(call_data,1)); + assert(cd_len >= 3, + "invoke_native called with %d args, needs at least 3", + cd_len); + assert((cd_len % 2) == 1, + "invoke_native called with an even number of args (%d)", + cd_len); + assert(arg_len <= 3, + "invoke_native called with more than 3 native args (%d)", + arg_len); + MalVal *dl_file = _nth(call_data, 0), + *ftype = _nth(call_data, 1), + *fname = _nth(call_data, 2); + assert_type(dl_file, MAL_STRING|MAL_NIL, + "invoke_native arg 1 (DYN_LIB_NAME) must be a string or nil"); + assert_type(ftype, MAL_STRING, + "invoke_native arg 2 (RETURN_TYPE) must be a string"); + assert_type(fname, MAL_STRING, + "invoke_native arg 3 (FUNC_NAME) must be a string"); + + // Cached load of the dynamic library handle + if (dl_file->type == MAL_NIL) { + dl_handle = dlopen(NULL, RTLD_LAZY); + } else { + // Load the library + if (loaded_dls == NULL) { + loaded_dls = g_hash_table_new(g_str_hash, g_str_equal); + } + dl_handle = g_hash_table_lookup(loaded_dls, dl_file->val.string); + dlerror(); // clear any existing error + if (!dl_handle) { + dl_handle = dlopen(dl_file->val.string, RTLD_LAZY); + } + if ((error = dlerror()) != NULL) { + abort("Could not dlopen '%s': %s", dl_file->val.string, error); + } + g_hash_table_insert(loaded_dls, dl_file->val.string, dl_handle); + } + + void * func = dlsym(dl_handle, fname->val.string); + if ((error = dlerror()) != NULL) { + abort("Could not dlsym '%s': %s", fname->val.string, error); + } + + + // + // Use FFI library to make a dynamic call + // + + // Based on: + // http://eli.thegreenplace.net/2013/03/04/flexible-runtime-interface-to-shared-libraries-with-libffi/ + ffi_cif cif; + ffi_type *ret_type; + ffi_type *arg_types[20]; + void *arg_vals[20]; + ffi_status status; + MalVal *ret_mv; + + // Set return type + ret_type = _get_ffi_type(ftype->val.string); + ret_mv = _malval_new_by_type(ftype->val.string); + if (mal_error) { return NULL; } + + // Set the argument types and values + int i; + for (i=0; i < arg_len; i++) { + arg_types[i] = _get_ffi_type(_nth(call_data, 3+i*2)->val.string); + if (arg_types[i] == NULL) { + return NULL; + } + arg_vals[i] = &_nth(call_data, 4+i*2)->val; + } + + status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, arg_len, + ret_type, arg_types); + if (status != FFI_OK) { + abort("ffi_prep_cif failed: %d\n", status); + } + + // Perform the call + //g_print("Calling %s[%p](%d)\n", fname->val.string, func, arg_len); + ffi_call(&cif, FFI_FN(func), &ret_mv->val, arg_vals); + + if (ret_type == &ffi_type_void) { + return &mal_nil; + } else { + return ret_mv; + } +} + diff --git a/impls/c/interop.h b/impls/c/interop.h index bcb2350b26..e862c926d6 100644 --- a/impls/c/interop.h +++ b/impls/c/interop.h @@ -1,6 +1,6 @@ -#ifndef __MAL_INTEROP__ -#define __MAL_INTEROP__ - -MalVal *invoke_native(MalVal *call_data); - -#endif +#ifndef __MAL_INTEROP__ +#define __MAL_INTEROP__ + +MalVal *invoke_native(MalVal *call_data); + +#endif diff --git a/impls/c/printer.c b/impls/c/printer.c index 339eff450a..3aa205cc81 100644 --- a/impls/c/printer.c +++ b/impls/c/printer.c @@ -1,154 +1,154 @@ -#include -#include -#include "types.h" -#include "printer.h" - -char *_pr_str_hash_map(MalVal *obj, int print_readably) { - int start = 1; - char *repr = NULL, *repr_tmp1 = NULL, *repr_tmp2 = NULL, - *key2 = NULL; - GHashTableIter iter; - gpointer key, value; - - repr = g_strdup_printf("{"); - - g_hash_table_iter_init (&iter, obj->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - //g_print ("%s/%p ", (const char *) key, (void *) value); - if (((char*)key)[0] == '\x7f') { - key2 = g_strdup_printf("%s", (char*)key); - key2[0] = ':'; - } else { - key2 = g_strdup_printf("\"%s\"", (char*)key); - } - - repr_tmp1 = _pr_str((MalVal*)value, print_readably); - if (start) { - start = 0; - repr = g_strdup_printf("{%s %s", (char*)key2, repr_tmp1); - } else { - repr_tmp2 = repr; - repr = g_strdup_printf("%s %s %s", repr_tmp2, (char*)key2, repr_tmp1); - MAL_GC_FREE(repr_tmp2); - } - MAL_GC_FREE(repr_tmp1); - } - repr_tmp2 = repr; - repr = g_strdup_printf("%s}", repr_tmp2); - MAL_GC_FREE(repr_tmp2); - return repr; -} - -char *_pr_str_list(MalVal *obj, int print_readably, char start, char end) { - int i; - char *repr = NULL, *repr_tmp1 = NULL, *repr_tmp2 = NULL; - repr = g_strdup_printf("%c", start); - for (i=0; i<_count(obj); i++) { - repr_tmp1 = _pr_str(g_array_index(obj->val.array, MalVal*, i), - print_readably); - if (i == 0) { - repr = g_strdup_printf("%c%s", start, repr_tmp1); - } else { - repr_tmp2 = repr; - repr = g_strdup_printf("%s %s", repr_tmp2, repr_tmp1); - MAL_GC_FREE(repr_tmp2); - } - MAL_GC_FREE(repr_tmp1); - } - repr_tmp2 = repr; - repr = g_strdup_printf("%s%c", repr_tmp2, end); - MAL_GC_FREE(repr_tmp2); - return repr; -} - -// Return a string representation of the MalVal object. Returned string must -// be freed by caller. -char *_pr_str(MalVal *obj, int print_readably) { - char *repr = NULL; - if (obj == NULL) { return NULL; } - switch (obj->type) { - case MAL_NIL: - repr = g_strdup_printf("nil"); - break; - case MAL_TRUE: - repr = g_strdup_printf("true"); - break; - case MAL_FALSE: - repr = g_strdup_printf("false"); - break; - case MAL_STRING: - if (obj->val.string[0] == '\x7f') { - // Keyword - repr = g_strdup_printf("%s", obj->val.string); - repr[0] = ':'; - } else if (print_readably) { - char *repr_tmp = g_strescape(obj->val.string, ""); - repr = g_strdup_printf("\"%s\"", repr_tmp); - MAL_GC_FREE(repr_tmp); - } else { - repr = g_strdup_printf("%s", obj->val.string); - } - break; - case MAL_SYMBOL: - repr = g_strdup_printf("%s", obj->val.string); - break; - case MAL_INTEGER: - repr = g_strdup_printf("%" G_GINT64_FORMAT, obj->val.intnum); - break; - case MAL_FLOAT: - repr = g_strdup_printf("%f", obj->val.floatnum); - break; - case MAL_HASH_MAP: - repr = _pr_str_hash_map(obj, print_readably); - break; - case MAL_LIST: - repr = _pr_str_list(obj, print_readably, '(', ')'); - break; - case MAL_VECTOR: - repr = _pr_str_list(obj, print_readably, '[', ']'); - break; - case MAL_ATOM: - repr = g_strdup_printf("(atom %s)", - _pr_str(obj->val.atom_val, print_readably)); - break; - case MAL_FUNCTION_C: - repr = g_strdup_printf("#", obj->val.f0); - break; - case MAL_FUNCTION_MAL: - repr = g_strdup_printf("#", - _pr_str(obj->val.func.args, print_readably), - _pr_str(obj->val.func.body, print_readably)); - break; - default: - printf("pr_str unknown type %d\n", obj->type); - repr = g_strdup_printf(""); - } - return repr; -} - -// Return a string representation of the MalVal arguments. Returned string must -// be freed by caller. -char *_pr_str_args(MalVal *args, char *sep, int print_readably) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "_pr_str called with non-sequential args"); - int i; - char *repr = g_strdup_printf("%s", ""), - *repr2 = NULL; - for (i=0; i<_count(args); i++) { - MalVal *obj = g_array_index(args->val.array, MalVal*, i); - if (i != 0) { - repr2 = repr; - repr = g_strdup_printf("%s%s", repr2, sep); - MAL_GC_FREE(repr2); - } - repr2 = repr; - repr = g_strdup_printf("%s%s", - repr2, _pr_str(obj, print_readably)); - MAL_GC_FREE(repr2); - } - char* res = MAL_GC_STRDUP(repr); - MAL_GC_FREE(repr); - // TODO - check why STRDUP was needed here - return res; -} - +#include +#include +#include "types.h" +#include "printer.h" + +char *_pr_str_hash_map(MalVal *obj, int print_readably) { + int start = 1; + char *repr = NULL, *repr_tmp1 = NULL, *repr_tmp2 = NULL, + *key2 = NULL; + GHashTableIter iter; + gpointer key, value; + + repr = g_strdup_printf("{"); + + g_hash_table_iter_init (&iter, obj->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + //g_print ("%s/%p ", (const char *) key, (void *) value); + if (((char*)key)[0] == '\x7f') { + key2 = g_strdup_printf("%s", (char*)key); + key2[0] = ':'; + } else { + key2 = g_strdup_printf("\"%s\"", (char*)key); + } + + repr_tmp1 = _pr_str((MalVal*)value, print_readably); + if (start) { + start = 0; + repr = g_strdup_printf("{%s %s", (char*)key2, repr_tmp1); + } else { + repr_tmp2 = repr; + repr = g_strdup_printf("%s %s %s", repr_tmp2, (char*)key2, repr_tmp1); + MAL_GC_FREE(repr_tmp2); + } + MAL_GC_FREE(repr_tmp1); + } + repr_tmp2 = repr; + repr = g_strdup_printf("%s}", repr_tmp2); + MAL_GC_FREE(repr_tmp2); + return repr; +} + +char *_pr_str_list(MalVal *obj, int print_readably, char start, char end) { + int i; + char *repr = NULL, *repr_tmp1 = NULL, *repr_tmp2 = NULL; + repr = g_strdup_printf("%c", start); + for (i=0; i<_count(obj); i++) { + repr_tmp1 = _pr_str(g_array_index(obj->val.array, MalVal*, i), + print_readably); + if (i == 0) { + repr = g_strdup_printf("%c%s", start, repr_tmp1); + } else { + repr_tmp2 = repr; + repr = g_strdup_printf("%s %s", repr_tmp2, repr_tmp1); + MAL_GC_FREE(repr_tmp2); + } + MAL_GC_FREE(repr_tmp1); + } + repr_tmp2 = repr; + repr = g_strdup_printf("%s%c", repr_tmp2, end); + MAL_GC_FREE(repr_tmp2); + return repr; +} + +// Return a string representation of the MalVal object. Returned string must +// be freed by caller. +char *_pr_str(MalVal *obj, int print_readably) { + char *repr = NULL; + if (obj == NULL) { return NULL; } + switch (obj->type) { + case MAL_NIL: + repr = g_strdup_printf("nil"); + break; + case MAL_TRUE: + repr = g_strdup_printf("true"); + break; + case MAL_FALSE: + repr = g_strdup_printf("false"); + break; + case MAL_STRING: + if (obj->val.string[0] == '\x7f') { + // Keyword + repr = g_strdup_printf("%s", obj->val.string); + repr[0] = ':'; + } else if (print_readably) { + char *repr_tmp = g_strescape(obj->val.string, ""); + repr = g_strdup_printf("\"%s\"", repr_tmp); + MAL_GC_FREE(repr_tmp); + } else { + repr = g_strdup_printf("%s", obj->val.string); + } + break; + case MAL_SYMBOL: + repr = g_strdup_printf("%s", obj->val.string); + break; + case MAL_INTEGER: + repr = g_strdup_printf("%" G_GINT64_FORMAT, obj->val.intnum); + break; + case MAL_FLOAT: + repr = g_strdup_printf("%f", obj->val.floatnum); + break; + case MAL_HASH_MAP: + repr = _pr_str_hash_map(obj, print_readably); + break; + case MAL_LIST: + repr = _pr_str_list(obj, print_readably, '(', ')'); + break; + case MAL_VECTOR: + repr = _pr_str_list(obj, print_readably, '[', ']'); + break; + case MAL_ATOM: + repr = g_strdup_printf("(atom %s)", + _pr_str(obj->val.atom_val, print_readably)); + break; + case MAL_FUNCTION_C: + repr = g_strdup_printf("#", obj->val.f0); + break; + case MAL_FUNCTION_MAL: + repr = g_strdup_printf("#", + _pr_str(obj->val.func.args, print_readably), + _pr_str(obj->val.func.body, print_readably)); + break; + default: + printf("pr_str unknown type %d\n", obj->type); + repr = g_strdup_printf(""); + } + return repr; +} + +// Return a string representation of the MalVal arguments. Returned string must +// be freed by caller. +char *_pr_str_args(MalVal *args, char *sep, int print_readably) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "_pr_str called with non-sequential args"); + int i; + char *repr = g_strdup_printf("%s", ""), + *repr2 = NULL; + for (i=0; i<_count(args); i++) { + MalVal *obj = g_array_index(args->val.array, MalVal*, i); + if (i != 0) { + repr2 = repr; + repr = g_strdup_printf("%s%s", repr2, sep); + MAL_GC_FREE(repr2); + } + repr2 = repr; + repr = g_strdup_printf("%s%s", + repr2, _pr_str(obj, print_readably)); + MAL_GC_FREE(repr2); + } + char* res = MAL_GC_STRDUP(repr); + MAL_GC_FREE(repr); + // TODO - check why STRDUP was needed here + return res; +} + diff --git a/impls/c/printer.h b/impls/c/printer.h index b3f389a11c..0fba46cf35 100644 --- a/impls/c/printer.h +++ b/impls/c/printer.h @@ -1,9 +1,9 @@ -#ifndef __MAL_PRINTER__ -#define __MAL_PRINTER__ - -#include "types.h" - -char *_pr_str_args(MalVal *args, char *sep, int print_readably); -char *_pr_str(MalVal *obj, int print_readably); - -#endif +#ifndef __MAL_PRINTER__ +#define __MAL_PRINTER__ + +#include "types.h" + +char *_pr_str_args(MalVal *args, char *sep, int print_readably); +char *_pr_str(MalVal *obj, int print_readably); + +#endif diff --git a/impls/c/reader.c b/impls/c/reader.c index 81ce2bc124..86c434d5c3 100644 --- a/impls/c/reader.c +++ b/impls/c/reader.c @@ -1,260 +1,260 @@ -#include -#include -#include - -//#include -//#include -#include - -#include "types.h" -#include "reader.h" - -// Declare -MalVal *read_form(Reader *reader); - -Reader *reader_new() { - Reader *reader = (Reader*)MAL_GC_MALLOC(sizeof(Reader)); - reader->array = g_array_sized_new(TRUE, FALSE, sizeof(char *), 8); - reader->position = 0; - return reader; -} - -int reader_append(Reader *reader, char* token) { - g_array_append_val(reader->array, token); - return TRUE; -} - -char *reader_peek(Reader *reader) { - return g_array_index(reader->array, char*, reader->position); -} - -char *reader_next(Reader *reader) { - if (reader->position >= reader->array->len) { - return NULL; - } else { - return g_array_index(reader->array, char*, reader->position++); - } -} - -void reader_free(Reader *reader) { - int i; - for(i=0; i < reader->array->len; i++) { - MAL_GC_FREE(g_array_index(reader->array, char*, i)); - } - g_array_free(reader->array, TRUE); - MAL_GC_FREE(reader); -} - -Reader *tokenize(char *line) { - GRegex *regex; - GMatchInfo *matchInfo; - GError *err = NULL; - - Reader *reader = reader_new(); - - regex = g_regex_new ("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)", 0, 0, &err); - g_regex_match (regex, line, 0, &matchInfo); - - if (err != NULL) { - fprintf(stderr, "Tokenize error: %s\n", err->message); - return NULL; - } - - while (g_match_info_matches(matchInfo)) { - gchar *result = g_match_info_fetch(matchInfo, 1); - if (result[0] != '\0' && result[0] != ';') { - reader_append(reader, result); - } - g_match_info_next(matchInfo, &err); - } - g_match_info_free(matchInfo); - g_regex_unref(regex); - if (reader->array->len == 0) { - reader_free(reader); - return NULL; - } else { - return reader; - } -} - - -MalVal *read_atom(Reader *reader) { - char *token; - GRegex *regex; - GMatchInfo *matchInfo; - GError *err = NULL; - gint pos; - MalVal *atom; - - token = reader_next(reader); - //g_print("read_atom token: %s\n", token); - - regex = g_regex_new ("(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"((?:[\\\\].|[^\\\\\"])*)\"$|^\"(.*)\"?$|:(.*)|(^[^\"]*$)", 0, 0, &err); - g_regex_match (regex, token, 0, &matchInfo); - - if (g_match_info_fetch_pos(matchInfo, 1, &pos, NULL) && pos != -1) { - //g_print("read_atom integer\n"); - atom = malval_new_integer(g_ascii_strtoll(token, NULL, 10)); - } else if (g_match_info_fetch_pos(matchInfo, 2, &pos, NULL) && pos != -1) { - //g_print("read_atom float\n"); - atom = malval_new_float(g_ascii_strtod(token, NULL)); - } else if (g_match_info_fetch_pos(matchInfo, 3, &pos, NULL) && pos != -1) { - //g_print("read_atom nil\n"); - atom = &mal_nil; - } else if (g_match_info_fetch_pos(matchInfo, 4, &pos, NULL) && pos != -1) { - //g_print("read_atom true\n"); - atom = &mal_true; - } else if (g_match_info_fetch_pos(matchInfo, 5, &pos, NULL) && pos != -1) { - //g_print("read_atom false\n"); - atom = &mal_false; - } else if (g_match_info_fetch_pos(matchInfo, 6, &pos, NULL) && pos != -1) { - //g_print("read_atom string: %s\n", token); - int end = strlen(token)-1; - token[end] = '\0'; - atom = malval_new_string(g_strcompress(g_match_info_fetch(matchInfo, 6))); - } else if (g_match_info_fetch_pos(matchInfo, 7, &pos, NULL) && pos != -1) { - abort("expected '\"', got EOF"); - } else if (g_match_info_fetch_pos(matchInfo, 8, &pos, NULL) && pos != -1) { - //g_print("read_atom keyword\n"); - atom = malval_new_keyword(MAL_GC_STRDUP(g_match_info_fetch(matchInfo, 8))); - } else if (g_match_info_fetch_pos(matchInfo, 9, &pos, NULL) && pos != -1) { - //g_print("read_atom symbol\n"); - atom = malval_new_symbol(MAL_GC_STRDUP(g_match_info_fetch(matchInfo, 9))); - } else { - malval_free(atom); - atom = NULL; - } - - return atom; -} - -MalVal *read_list(Reader *reader, MalType type, char start, char end) { - MalVal *ast, *form; - char *token = reader_next(reader); - //g_print("read_list start token: %s\n", token); - if (token[0] != start) { abort("expected '(' or '['"); } - - ast = malval_new_list(type, g_array_new(TRUE, TRUE, sizeof(MalVal*))); - - while ((token = reader_peek(reader)) && - token[0] != end) { - //g_print("read_list internal token %s\n", token); - form = read_form(reader); - if (!form) { - if (!mal_error) { abort("unknown read_list failure"); } - g_array_free(ast->val.array, TRUE); - malval_free(ast); - return NULL; - } - g_array_append_val(ast->val.array, form); - } - if (!token) { abort("expected ')' or ']', got EOF"); } - reader_next(reader); - //g_print("read_list end token: %s\n", token); - return ast; -} - -MalVal *read_hash_map(Reader *reader) { - MalVal *lst = read_list(reader, MAL_LIST, '{', '}'); - MalVal *hm = _hash_map(lst); - malval_free(lst); - return hm; -} - - -MalVal *read_form(Reader *reader) { - char *token; - MalVal *form = NULL, *tmp; - -// while(token = reader_next(reader)) { -// printf("token: %s\n", token); -// } -// return NULL; - - token = reader_peek(reader); - - if (!token) { return NULL; } - //g_print("read_form token: %s\n", token); - - switch (token[0]) { - case ';': - abort("comments not yet implemented"); - break; - case '\'': - reader_next(reader); - form = _listX(2, malval_new_symbol("quote"), - read_form(reader)); - break; - case '`': - reader_next(reader); - form = _listX(2, malval_new_symbol("quasiquote"), - read_form(reader)); - break; - case '~': - reader_next(reader); - if (token[1] == '@') { - form = _listX(2, malval_new_symbol("splice-unquote"), - read_form(reader)); - } else { - form = _listX(2, malval_new_symbol("unquote"), - read_form(reader)); - }; - break; - case '^': - reader_next(reader); - MalVal *meta = read_form(reader); - form = _listX(3, malval_new_symbol("with-meta"), - read_form(reader), meta); - break; - case '@': - reader_next(reader); - form = _listX(2, malval_new_symbol("deref"), - read_form(reader)); - break; - - - // list - case ')': - abort("unexpected ')'"); - break; - case '(': - form = read_list(reader, MAL_LIST, '(', ')'); - break; - - // vector - case ']': - abort("unexpected ']'"); - break; - case '[': - form = read_list(reader, MAL_VECTOR, '[', ']'); - break; - - // hash-map - case '}': - abort("unexpected '}'"); - break; - case '{': - form = read_hash_map(reader); - break; - - default: - form = read_atom(reader); - break; - } - return form; - -} - -MalVal *read_str (char *str) { - Reader *reader; - char *token; - MalVal *ast = NULL; - - reader = tokenize(str); - if (reader) { - ast = read_form(reader); - reader_free(reader); - } - - return ast; -} +#include +#include +#include + +//#include +//#include +#include + +#include "types.h" +#include "reader.h" + +// Declare +MalVal *read_form(Reader *reader); + +Reader *reader_new() { + Reader *reader = (Reader*)MAL_GC_MALLOC(sizeof(Reader)); + reader->array = g_array_sized_new(TRUE, FALSE, sizeof(char *), 8); + reader->position = 0; + return reader; +} + +int reader_append(Reader *reader, char* token) { + g_array_append_val(reader->array, token); + return TRUE; +} + +char *reader_peek(Reader *reader) { + return g_array_index(reader->array, char*, reader->position); +} + +char *reader_next(Reader *reader) { + if (reader->position >= reader->array->len) { + return NULL; + } else { + return g_array_index(reader->array, char*, reader->position++); + } +} + +void reader_free(Reader *reader) { + int i; + for(i=0; i < reader->array->len; i++) { + MAL_GC_FREE(g_array_index(reader->array, char*, i)); + } + g_array_free(reader->array, TRUE); + MAL_GC_FREE(reader); +} + +Reader *tokenize(char *line) { + GRegex *regex; + GMatchInfo *matchInfo; + GError *err = NULL; + + Reader *reader = reader_new(); + + regex = g_regex_new ("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)", 0, 0, &err); + g_regex_match (regex, line, 0, &matchInfo); + + if (err != NULL) { + fprintf(stderr, "Tokenize error: %s\n", err->message); + return NULL; + } + + while (g_match_info_matches(matchInfo)) { + gchar *result = g_match_info_fetch(matchInfo, 1); + if (result[0] != '\0' && result[0] != ';') { + reader_append(reader, result); + } + g_match_info_next(matchInfo, &err); + } + g_match_info_free(matchInfo); + g_regex_unref(regex); + if (reader->array->len == 0) { + reader_free(reader); + return NULL; + } else { + return reader; + } +} + + +MalVal *read_atom(Reader *reader) { + char *token; + GRegex *regex; + GMatchInfo *matchInfo; + GError *err = NULL; + gint pos; + MalVal *atom; + + token = reader_next(reader); + //g_print("read_atom token: %s\n", token); + + regex = g_regex_new ("(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"((?:[\\\\].|[^\\\\\"])*)\"$|^\"(.*)\"?$|:(.*)|(^[^\"]*$)", 0, 0, &err); + g_regex_match (regex, token, 0, &matchInfo); + + if (g_match_info_fetch_pos(matchInfo, 1, &pos, NULL) && pos != -1) { + //g_print("read_atom integer\n"); + atom = malval_new_integer(g_ascii_strtoll(token, NULL, 10)); + } else if (g_match_info_fetch_pos(matchInfo, 2, &pos, NULL) && pos != -1) { + //g_print("read_atom float\n"); + atom = malval_new_float(g_ascii_strtod(token, NULL)); + } else if (g_match_info_fetch_pos(matchInfo, 3, &pos, NULL) && pos != -1) { + //g_print("read_atom nil\n"); + atom = &mal_nil; + } else if (g_match_info_fetch_pos(matchInfo, 4, &pos, NULL) && pos != -1) { + //g_print("read_atom true\n"); + atom = &mal_true; + } else if (g_match_info_fetch_pos(matchInfo, 5, &pos, NULL) && pos != -1) { + //g_print("read_atom false\n"); + atom = &mal_false; + } else if (g_match_info_fetch_pos(matchInfo, 6, &pos, NULL) && pos != -1) { + //g_print("read_atom string: %s\n", token); + int end = strlen(token)-1; + token[end] = '\0'; + atom = malval_new_string(g_strcompress(g_match_info_fetch(matchInfo, 6))); + } else if (g_match_info_fetch_pos(matchInfo, 7, &pos, NULL) && pos != -1) { + abort("expected '\"', got EOF"); + } else if (g_match_info_fetch_pos(matchInfo, 8, &pos, NULL) && pos != -1) { + //g_print("read_atom keyword\n"); + atom = malval_new_keyword(MAL_GC_STRDUP(g_match_info_fetch(matchInfo, 8))); + } else if (g_match_info_fetch_pos(matchInfo, 9, &pos, NULL) && pos != -1) { + //g_print("read_atom symbol\n"); + atom = malval_new_symbol(MAL_GC_STRDUP(g_match_info_fetch(matchInfo, 9))); + } else { + malval_free(atom); + atom = NULL; + } + + return atom; +} + +MalVal *read_list(Reader *reader, MalType type, char start, char end) { + MalVal *ast, *form; + char *token = reader_next(reader); + //g_print("read_list start token: %s\n", token); + if (token[0] != start) { abort("expected '(' or '['"); } + + ast = malval_new_list(type, g_array_new(TRUE, TRUE, sizeof(MalVal*))); + + while ((token = reader_peek(reader)) && + token[0] != end) { + //g_print("read_list internal token %s\n", token); + form = read_form(reader); + if (!form) { + if (!mal_error) { abort("unknown read_list failure"); } + g_array_free(ast->val.array, TRUE); + malval_free(ast); + return NULL; + } + g_array_append_val(ast->val.array, form); + } + if (!token) { abort("expected ')' or ']', got EOF"); } + reader_next(reader); + //g_print("read_list end token: %s\n", token); + return ast; +} + +MalVal *read_hash_map(Reader *reader) { + MalVal *lst = read_list(reader, MAL_LIST, '{', '}'); + MalVal *hm = _hash_map(lst); + malval_free(lst); + return hm; +} + + +MalVal *read_form(Reader *reader) { + char *token; + MalVal *form = NULL, *tmp; + +// while(token = reader_next(reader)) { +// printf("token: %s\n", token); +// } +// return NULL; + + token = reader_peek(reader); + + if (!token) { return NULL; } + //g_print("read_form token: %s\n", token); + + switch (token[0]) { + case ';': + abort("comments not yet implemented"); + break; + case '\'': + reader_next(reader); + form = _listX(2, malval_new_symbol("quote"), + read_form(reader)); + break; + case '`': + reader_next(reader); + form = _listX(2, malval_new_symbol("quasiquote"), + read_form(reader)); + break; + case '~': + reader_next(reader); + if (token[1] == '@') { + form = _listX(2, malval_new_symbol("splice-unquote"), + read_form(reader)); + } else { + form = _listX(2, malval_new_symbol("unquote"), + read_form(reader)); + }; + break; + case '^': + reader_next(reader); + MalVal *meta = read_form(reader); + form = _listX(3, malval_new_symbol("with-meta"), + read_form(reader), meta); + break; + case '@': + reader_next(reader); + form = _listX(2, malval_new_symbol("deref"), + read_form(reader)); + break; + + + // list + case ')': + abort("unexpected ')'"); + break; + case '(': + form = read_list(reader, MAL_LIST, '(', ')'); + break; + + // vector + case ']': + abort("unexpected ']'"); + break; + case '[': + form = read_list(reader, MAL_VECTOR, '[', ']'); + break; + + // hash-map + case '}': + abort("unexpected '}'"); + break; + case '{': + form = read_hash_map(reader); + break; + + default: + form = read_atom(reader); + break; + } + return form; + +} + +MalVal *read_str (char *str) { + Reader *reader; + char *token; + MalVal *ast = NULL; + + reader = tokenize(str); + if (reader) { + ast = read_form(reader); + reader_free(reader); + } + + return ast; +} diff --git a/impls/c/reader.h b/impls/c/reader.h index 90f07ed08c..ee0060ce55 100644 --- a/impls/c/reader.h +++ b/impls/c/reader.h @@ -1,23 +1,23 @@ -#ifndef __MAL_READER__ -#define __MAL_READER__ - -#include -#include - -#include "types.h" - -typedef struct { - GArray *array; - int position; -} Reader; - -Reader *reader_new(); -int reader_append(Reader *reader, char* token); -char *reader_peek(Reader *reader); -char *reader_next(Reader *reader); -void reader_free(Reader *reader); - -char *_readline (char prompt[]); -MalVal *read_str (); - -#endif +#ifndef __MAL_READER__ +#define __MAL_READER__ + +#include +#include + +#include "types.h" + +typedef struct { + GArray *array; + int position; +} Reader; + +Reader *reader_new(); +int reader_append(Reader *reader, char* token); +char *reader_peek(Reader *reader); +char *reader_next(Reader *reader); +void reader_free(Reader *reader); + +char *_readline (char prompt[]); +MalVal *read_str (); + +#endif diff --git a/impls/c/readline.c b/impls/c/readline.c index 3594a1a0db..162ca7ec20 100644 --- a/impls/c/readline.c +++ b/impls/c/readline.c @@ -1,75 +1,75 @@ -#include -#include -#include - -#if USE_READLINE - #include - #include - #include -#else - #include -#endif - -int history_loaded = 0; - -char HISTORY_FILE[] = "~/.mal-history"; - -void load_history() { - if (history_loaded) { return; } - int ret; - char *hf = tilde_expand(HISTORY_FILE); - if (access(hf, F_OK) != -1) { - // TODO: check if file exists first, use non-static path -#if USE_READLINE - ret = read_history(hf); -#else - FILE *fp = fopen(hf, "r"); - char *line = malloc(80); // getline reallocs as necessary - size_t sz = 80; - while ((ret = getline(&line, &sz, fp)) > 0) { - add_history(line); // Add line to in-memory history - } - free(line); - fclose(fp); -#endif - history_loaded = 1; - } - free(hf); -} - -void append_to_history() { - char *hf = tilde_expand(HISTORY_FILE); -#ifdef USE_READLINE - append_history(1, hf); -#else -#if defined(RL_READLINE_VERSION) - HIST_ENTRY *he = history_get(history_base+history_length-1); -#else - // libedit-2 segfaults if we add history_base - HIST_ENTRY *he = history_get(history_length-1); -#endif - FILE *fp = fopen(hf, "a"); - if (fp) { - fprintf(fp, "%s\n", he->line); - fclose(fp); - } -#endif - free(hf); -} - - -// line must be freed by caller -char *_readline (char prompt[]) { - char *line; - - load_history(); - - line = readline(prompt); - if (!line) return NULL; // EOF - add_history(line); // Add input to in-memory history - - append_to_history(); // Flush new line of history to disk - - return line; -} - +#include +#include +#include + +#if USE_READLINE + #include + #include + #include +#else + #include +#endif + +int history_loaded = 0; + +char HISTORY_FILE[] = "~/.mal-history"; + +void load_history() { + if (history_loaded) { return; } + int ret; + char *hf = tilde_expand(HISTORY_FILE); + if (access(hf, F_OK) != -1) { + // TODO: check if file exists first, use non-static path +#if USE_READLINE + ret = read_history(hf); +#else + FILE *fp = fopen(hf, "r"); + char *line = malloc(80); // getline reallocs as necessary + size_t sz = 80; + while ((ret = getline(&line, &sz, fp)) > 0) { + add_history(line); // Add line to in-memory history + } + free(line); + fclose(fp); +#endif + history_loaded = 1; + } + free(hf); +} + +void append_to_history() { + char *hf = tilde_expand(HISTORY_FILE); +#ifdef USE_READLINE + append_history(1, hf); +#else +#if defined(RL_READLINE_VERSION) + HIST_ENTRY *he = history_get(history_base+history_length-1); +#else + // libedit-2 segfaults if we add history_base + HIST_ENTRY *he = history_get(history_length-1); +#endif + FILE *fp = fopen(hf, "a"); + if (fp) { + fprintf(fp, "%s\n", he->line); + fclose(fp); + } +#endif + free(hf); +} + + +// line must be freed by caller +char *_readline (char prompt[]) { + char *line; + + load_history(); + + line = readline(prompt); + if (!line) return NULL; // EOF + add_history(line); // Add input to in-memory history + + append_to_history(); // Flush new line of history to disk + + return line; +} + diff --git a/impls/c/readline.h b/impls/c/readline.h index d524f4a0f0..aec67c24ca 100644 --- a/impls/c/readline.h +++ b/impls/c/readline.h @@ -1,6 +1,6 @@ -#ifndef __MAL_READLINE__ -#define __MAL_READLINE__ - -char *_readline (char prompt[]); - -#endif +#ifndef __MAL_READLINE__ +#define __MAL_READLINE__ + +char *_readline (char prompt[]); + +#endif diff --git a/impls/c/run b/impls/c/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/c/run +++ b/impls/c/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/c/step0_repl.c b/impls/c/step0_repl.c index ddb7f6e2b7..5fdd05cd8d 100644 --- a/impls/c/step0_repl.c +++ b/impls/c/step0_repl.c @@ -1,44 +1,44 @@ -#include -#include -#include - -#ifdef USE_READLINE - #include - #include -#else - #include -#endif - -char *READ(char prompt[]) { - char *line; - line = readline(prompt); - if (!line) return NULL; // EOF - add_history(line); // Add input to history. - return line; -} - -char *EVAL(char *ast, void *env) { - return ast; -} - -char *PRINT(char *exp) { - return exp; -} - -int main() -{ - char *ast, *exp; - char prompt[100]; - - // Set the initial prompt - snprintf(prompt, sizeof(prompt), "user> "); - - for(;;) { - ast = READ(prompt); - if (!ast) return 0; - exp = EVAL(ast, NULL); - puts(PRINT(exp)); - - free(ast); // Free input string - } -} +#include +#include +#include + +#ifdef USE_READLINE + #include + #include +#else + #include +#endif + +char *READ(char prompt[]) { + char *line; + line = readline(prompt); + if (!line) return NULL; // EOF + add_history(line); // Add input to history. + return line; +} + +char *EVAL(char *ast, void *env) { + return ast; +} + +char *PRINT(char *exp) { + return exp; +} + +int main() +{ + char *ast, *exp; + char prompt[100]; + + // Set the initial prompt + snprintf(prompt, sizeof(prompt), "user> "); + + for(;;) { + ast = READ(prompt); + if (!ast) return 0; + exp = EVAL(ast, NULL); + puts(PRINT(exp)); + + free(ast); // Free input string + } +} diff --git a/impls/c/step1_read_print.c b/impls/c/step1_read_print.c index cdc45cd441..a4ea944bba 100644 --- a/impls/c/step1_read_print.c +++ b/impls/c/step1_read_print.c @@ -1,86 +1,86 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -MalVal *EVAL(MalVal *ast, GHashTable *env) { - if (!ast || mal_error) return NULL; - return ast; -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(GHashTable *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -int main() -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt - snprintf(prompt, sizeof(prompt), "user> "); - - // repl loop - for(;;) { - exp = RE(NULL, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +MalVal *EVAL(MalVal *ast, GHashTable *env) { + if (!ast || mal_error) return NULL; + return ast; +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(GHashTable *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +int main() +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt + snprintf(prompt, sizeof(prompt), "user> "); + + // repl loop + for(;;) { + exp = RE(NULL, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/step2_eval.c b/impls/c/step2_eval.c index 8c54184c05..4396df86f3 100644 --- a/impls/c/step2_eval.c +++ b/impls/c/step2_eval.c @@ -1,157 +1,157 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" - -// Declarations -MalVal *EVAL(MalVal *ast, GHashTable *env); - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -MalVal *eval_ast(MalVal *ast, GHashTable *env) { - if (!ast || mal_error) return NULL; - if (ast->type == MAL_SYMBOL) { - //g_print("EVAL symbol: %s\n", ast->val.string); - // TODO: check if not found - MalVal *res = g_hash_table_lookup(env, ast->val.string); - assert(res, "'%s' not found", ast->val.string); - return res; - } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { - //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); - MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); - if (!el || mal_error) return NULL; - el->type = ast->type; - return el; - } else if (ast->type == MAL_HASH_MAP) { - //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(ast))); - g_hash_table_iter_init (&iter, ast->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - MalVal *new_val = EVAL((MalVal *)value, env); - g_array_append_val(seq->val.array, new_val); - } - return _hash_map(seq); - } else { - //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); - return ast; - } -} - -MalVal *EVAL(MalVal *ast, GHashTable *env) { - if (!ast || mal_error) return NULL; - //g_print("EVAL: %s\n", _pr_str(ast,1)); - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (!ast || mal_error) return NULL; - - // apply list - //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); - if (_count(ast) == 0) { return ast; } - MalVal *a0 = _nth(ast, 0); - assert_type(a0, MAL_SYMBOL, "Cannot invoke %s", _pr_str(a0,1)); - MalVal *el = eval_ast(ast, env); - if (!el || mal_error) { return NULL; } - MalVal *(*f)(void *, void*) = (MalVal *(*)(void*, void*))_first(el); - //g_print("eval_invoke el: %s\n", _pr_str(el,1)); - return f(_nth(el, 1), _nth(el, 2)); -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(GHashTable *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -// Setup the initial REPL environment -GHashTable *repl_env; - -WRAP_INTEGER_OP(plus,+) -WRAP_INTEGER_OP(minus,-) -WRAP_INTEGER_OP(multiply,*) -WRAP_INTEGER_OP(divide,/) - -void init_repl_env() { - repl_env = g_hash_table_new(g_str_hash, g_str_equal); - - g_hash_table_insert(repl_env, "+", int_plus); - g_hash_table_insert(repl_env, "-", int_minus); - g_hash_table_insert(repl_env, "*", int_multiply); - g_hash_table_insert(repl_env, "/", int_divide); -} - -int main() -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt and environment - snprintf(prompt, sizeof(prompt), "user> "); - init_repl_env(); - - // repl loop - for(;;) { - exp = RE(repl_env, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" + +// Declarations +MalVal *EVAL(MalVal *ast, GHashTable *env); + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +MalVal *eval_ast(MalVal *ast, GHashTable *env) { + if (!ast || mal_error) return NULL; + if (ast->type == MAL_SYMBOL) { + //g_print("EVAL symbol: %s\n", ast->val.string); + // TODO: check if not found + MalVal *res = g_hash_table_lookup(env, ast->val.string); + assert(res, "'%s' not found", ast->val.string); + return res; + } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { + //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); + MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); + if (!el || mal_error) return NULL; + el->type = ast->type; + return el; + } else if (ast->type == MAL_HASH_MAP) { + //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(ast))); + g_hash_table_iter_init (&iter, ast->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + MalVal *new_val = EVAL((MalVal *)value, env); + g_array_append_val(seq->val.array, new_val); + } + return _hash_map(seq); + } else { + //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); + return ast; + } +} + +MalVal *EVAL(MalVal *ast, GHashTable *env) { + if (!ast || mal_error) return NULL; + //g_print("EVAL: %s\n", _pr_str(ast,1)); + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (!ast || mal_error) return NULL; + + // apply list + //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); + if (_count(ast) == 0) { return ast; } + MalVal *a0 = _nth(ast, 0); + assert_type(a0, MAL_SYMBOL, "Cannot invoke %s", _pr_str(a0,1)); + MalVal *el = eval_ast(ast, env); + if (!el || mal_error) { return NULL; } + MalVal *(*f)(void *, void*) = (MalVal *(*)(void*, void*))_first(el); + //g_print("eval_invoke el: %s\n", _pr_str(el,1)); + return f(_nth(el, 1), _nth(el, 2)); +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(GHashTable *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +// Setup the initial REPL environment +GHashTable *repl_env; + +WRAP_INTEGER_OP(plus,+) +WRAP_INTEGER_OP(minus,-) +WRAP_INTEGER_OP(multiply,*) +WRAP_INTEGER_OP(divide,/) + +void init_repl_env() { + repl_env = g_hash_table_new(g_str_hash, g_str_equal); + + g_hash_table_insert(repl_env, "+", int_plus); + g_hash_table_insert(repl_env, "-", int_minus); + g_hash_table_insert(repl_env, "*", int_multiply); + g_hash_table_insert(repl_env, "/", int_divide); +} + +int main() +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt and environment + snprintf(prompt, sizeof(prompt), "user> "); + init_repl_env(); + + // repl loop + for(;;) { + exp = RE(repl_env, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/step3_env.c b/impls/c/step3_env.c index d51704e053..bf14902825 100644 --- a/impls/c/step3_env.c +++ b/impls/c/step3_env.c @@ -1,182 +1,182 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" - -// Declarations -MalVal *EVAL(MalVal *ast, Env *env); - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -MalVal *eval_ast(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - if (ast->type == MAL_SYMBOL) { - //g_print("EVAL symbol: %s\n", ast->val.string); - return env_get(env, ast); - } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { - //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); - MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); - if (!el || mal_error) return NULL; - el->type = ast->type; - return el; - } else if (ast->type == MAL_HASH_MAP) { - //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(ast))); - g_hash_table_iter_init (&iter, ast->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - MalVal *new_val = EVAL((MalVal *)value, env); - g_array_append_val(seq->val.array, new_val); - } - return _hash_map(seq); - } else { - //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); - return ast; - } -} - -MalVal *EVAL(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - //g_print("EVAL: %s\n", _pr_str(ast,1)); - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (!ast || mal_error) return NULL; - - // apply list - //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); - int i, len; - if (_count(ast) == 0) { return ast; } - MalVal *a0 = _nth(ast, 0); - assert_type(a0, MAL_SYMBOL, "Cannot apply %s", _pr_str(a0,1)); - if (strcmp("def!", a0->val.string) == 0) { - //g_print("eval apply def!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - env_set(env, a1, res); - return res; - } else if (strcmp("let*", a0->val.string) == 0) { - //g_print("eval apply let*\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2), - *key, *val; - assert_type(a1, MAL_LIST|MAL_VECTOR, - "let* bindings must be list or vector"); - len = _count(a1); - assert((len % 2) == 0, "odd number of let* bindings forms"); - Env *let_env = new_env(env, NULL, NULL); - for(i=0; ival.array, MalVal*, i); - val = g_array_index(a1->val.array, MalVal*, i+1); - assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); - env_set(let_env, key, EVAL(val, let_env)); - } - return EVAL(a2, let_env); - } else { - //g_print("eval apply\n"); - MalVal *el = eval_ast(ast, env); - if (!el || mal_error) { return NULL; } - MalVal *(*f)(void *, void*) = (MalVal *(*)(void*, void*))_first(el); - return f(_nth(el, 1), _nth(el, 2)); - } -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(Env *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -// Setup the initial REPL environment -Env *repl_env; - -WRAP_INTEGER_OP(plus,+) -WRAP_INTEGER_OP(minus,-) -WRAP_INTEGER_OP(multiply,*) -WRAP_INTEGER_OP(divide,/) - -void init_repl_env() { - repl_env = new_env(NULL, NULL, NULL); - - env_set(repl_env, malval_new_symbol("+"), (MalVal *)int_plus); - env_set(repl_env, malval_new_symbol("-"), (MalVal *)int_minus); - env_set(repl_env, malval_new_symbol("*"), (MalVal *)int_multiply); - env_set(repl_env, malval_new_symbol("/"), (MalVal *)int_divide); -} - -int main() -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt and environment - snprintf(prompt, sizeof(prompt), "user> "); - init_repl_env(); - - // repl loop - for(;;) { - exp = RE(repl_env, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" + +// Declarations +MalVal *EVAL(MalVal *ast, Env *env); + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +MalVal *eval_ast(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + if (ast->type == MAL_SYMBOL) { + //g_print("EVAL symbol: %s\n", ast->val.string); + return env_get(env, ast); + } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { + //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); + MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); + if (!el || mal_error) return NULL; + el->type = ast->type; + return el; + } else if (ast->type == MAL_HASH_MAP) { + //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(ast))); + g_hash_table_iter_init (&iter, ast->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + MalVal *new_val = EVAL((MalVal *)value, env); + g_array_append_val(seq->val.array, new_val); + } + return _hash_map(seq); + } else { + //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); + return ast; + } +} + +MalVal *EVAL(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + //g_print("EVAL: %s\n", _pr_str(ast,1)); + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (!ast || mal_error) return NULL; + + // apply list + //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); + int i, len; + if (_count(ast) == 0) { return ast; } + MalVal *a0 = _nth(ast, 0); + assert_type(a0, MAL_SYMBOL, "Cannot apply %s", _pr_str(a0,1)); + if (strcmp("def!", a0->val.string) == 0) { + //g_print("eval apply def!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + env_set(env, a1, res); + return res; + } else if (strcmp("let*", a0->val.string) == 0) { + //g_print("eval apply let*\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2), + *key, *val; + assert_type(a1, MAL_LIST|MAL_VECTOR, + "let* bindings must be list or vector"); + len = _count(a1); + assert((len % 2) == 0, "odd number of let* bindings forms"); + Env *let_env = new_env(env, NULL, NULL); + for(i=0; ival.array, MalVal*, i); + val = g_array_index(a1->val.array, MalVal*, i+1); + assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); + env_set(let_env, key, EVAL(val, let_env)); + } + return EVAL(a2, let_env); + } else { + //g_print("eval apply\n"); + MalVal *el = eval_ast(ast, env); + if (!el || mal_error) { return NULL; } + MalVal *(*f)(void *, void*) = (MalVal *(*)(void*, void*))_first(el); + return f(_nth(el, 1), _nth(el, 2)); + } +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(Env *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +// Setup the initial REPL environment +Env *repl_env; + +WRAP_INTEGER_OP(plus,+) +WRAP_INTEGER_OP(minus,-) +WRAP_INTEGER_OP(multiply,*) +WRAP_INTEGER_OP(divide,/) + +void init_repl_env() { + repl_env = new_env(NULL, NULL, NULL); + + env_set(repl_env, malval_new_symbol("+"), (MalVal *)int_plus); + env_set(repl_env, malval_new_symbol("-"), (MalVal *)int_minus); + env_set(repl_env, malval_new_symbol("*"), (MalVal *)int_multiply); + env_set(repl_env, malval_new_symbol("/"), (MalVal *)int_divide); +} + +int main() +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt and environment + snprintf(prompt, sizeof(prompt), "user> "); + init_repl_env(); + + // repl loop + for(;;) { + exp = RE(repl_env, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/step4_if_fn_do.c b/impls/c/step4_if_fn_do.c index c6628c16c2..6884daea64 100644 --- a/impls/c/step4_if_fn_do.c +++ b/impls/c/step4_if_fn_do.c @@ -1,220 +1,220 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" -#include "core.h" - -// Declarations -MalVal *EVAL(MalVal *ast, Env *env); - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -MalVal *eval_ast(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - if (ast->type == MAL_SYMBOL) { - //g_print("EVAL symbol: %s\n", ast->val.string); - return env_get(env, ast); - } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { - //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); - MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); - if (!el || mal_error) return NULL; - el->type = ast->type; - return el; - } else if (ast->type == MAL_HASH_MAP) { - //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(ast))); - g_hash_table_iter_init (&iter, ast->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - MalVal *new_val = EVAL((MalVal *)value, env); - g_array_append_val(seq->val.array, new_val); - } - return _hash_map(seq); - } else { - //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); - return ast; - } -} - -MalVal *EVAL(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - //g_print("EVAL: %s\n", _pr_str(ast,1)); - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (!ast || mal_error) return NULL; - - // apply list - //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); - int i, len; - if (_count(ast) == 0) { return ast; } - MalVal *a0 = _nth(ast, 0); - if ((a0->type & MAL_SYMBOL) && - strcmp("def!", a0->val.string) == 0) { - //g_print("eval apply def!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("let*", a0->val.string) == 0) { - //g_print("eval apply let*\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2), - *key, *val; - assert_type(a1, MAL_LIST|MAL_VECTOR, - "let* bindings must be list or vector"); - len = _count(a1); - assert((len % 2) == 0, "odd number of let* bindings forms"); - Env *let_env = new_env(env, NULL, NULL); - for(i=0; ival.array, MalVal*, i); - val = g_array_index(a1->val.array, MalVal*, i+1); - assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); - env_set(let_env, key, EVAL(val, let_env)); - } - return EVAL(a2, let_env); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("do", a0->val.string) == 0) { - //g_print("eval apply do\n"); - MalVal *el = eval_ast(_rest(ast), env); - return _last(el); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("if", a0->val.string) == 0) { - //g_print("eval apply if\n"); - MalVal *a1 = _nth(ast, 1); - MalVal *cond = EVAL(a1, env); - if (!cond || mal_error) return NULL; - if (cond->type & (MAL_FALSE|MAL_NIL)) { - // eval false slot form - if (ast->val.array->len > 3) { - return EVAL(_nth(ast, 3), env); - } else { - return &mal_nil; - } - } else { - // eval true slot form - MalVal *a2 = _nth(ast, 2); - return EVAL(a2, env); - } - } else if ((a0->type & MAL_SYMBOL) && - strcmp("fn*", a0->val.string) == 0) { - //g_print("eval apply fn*\n"); - MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); - mf->val.func.evaluator = EVAL; - mf->val.func.args = _nth(ast, 1); - mf->val.func.body = _nth(ast, 2); - mf->val.func.env = env; - return mf; - } else { - //g_print("eval apply\n"); - MalVal *el = eval_ast(ast, env); - if (!el || mal_error) { return NULL; } - MalVal *f = _first(el), - *args = _rest(el); - assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, - "cannot apply '%s'", _pr_str(f,1)); - return _apply(f, args); - } -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(Env *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -// Setup the initial REPL environment -Env *repl_env; - -void init_repl_env() { - repl_env = new_env(NULL, NULL, NULL); - - // core.c: defined using C - int i; - for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { - env_set(repl_env, - malval_new_symbol(core_ns[i].name), - malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); - } - - // core.mal: defined using the language itself - RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); -} - -int main() -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt and environment - snprintf(prompt, sizeof(prompt), "user> "); - init_repl_env(); - - // repl loop - for(;;) { - exp = RE(repl_env, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" +#include "core.h" + +// Declarations +MalVal *EVAL(MalVal *ast, Env *env); + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +MalVal *eval_ast(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + if (ast->type == MAL_SYMBOL) { + //g_print("EVAL symbol: %s\n", ast->val.string); + return env_get(env, ast); + } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { + //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); + MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); + if (!el || mal_error) return NULL; + el->type = ast->type; + return el; + } else if (ast->type == MAL_HASH_MAP) { + //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(ast))); + g_hash_table_iter_init (&iter, ast->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + MalVal *new_val = EVAL((MalVal *)value, env); + g_array_append_val(seq->val.array, new_val); + } + return _hash_map(seq); + } else { + //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); + return ast; + } +} + +MalVal *EVAL(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + //g_print("EVAL: %s\n", _pr_str(ast,1)); + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (!ast || mal_error) return NULL; + + // apply list + //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); + int i, len; + if (_count(ast) == 0) { return ast; } + MalVal *a0 = _nth(ast, 0); + if ((a0->type & MAL_SYMBOL) && + strcmp("def!", a0->val.string) == 0) { + //g_print("eval apply def!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("let*", a0->val.string) == 0) { + //g_print("eval apply let*\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2), + *key, *val; + assert_type(a1, MAL_LIST|MAL_VECTOR, + "let* bindings must be list or vector"); + len = _count(a1); + assert((len % 2) == 0, "odd number of let* bindings forms"); + Env *let_env = new_env(env, NULL, NULL); + for(i=0; ival.array, MalVal*, i); + val = g_array_index(a1->val.array, MalVal*, i+1); + assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); + env_set(let_env, key, EVAL(val, let_env)); + } + return EVAL(a2, let_env); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("do", a0->val.string) == 0) { + //g_print("eval apply do\n"); + MalVal *el = eval_ast(_rest(ast), env); + return _last(el); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("if", a0->val.string) == 0) { + //g_print("eval apply if\n"); + MalVal *a1 = _nth(ast, 1); + MalVal *cond = EVAL(a1, env); + if (!cond || mal_error) return NULL; + if (cond->type & (MAL_FALSE|MAL_NIL)) { + // eval false slot form + if (ast->val.array->len > 3) { + return EVAL(_nth(ast, 3), env); + } else { + return &mal_nil; + } + } else { + // eval true slot form + MalVal *a2 = _nth(ast, 2); + return EVAL(a2, env); + } + } else if ((a0->type & MAL_SYMBOL) && + strcmp("fn*", a0->val.string) == 0) { + //g_print("eval apply fn*\n"); + MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); + mf->val.func.evaluator = EVAL; + mf->val.func.args = _nth(ast, 1); + mf->val.func.body = _nth(ast, 2); + mf->val.func.env = env; + return mf; + } else { + //g_print("eval apply\n"); + MalVal *el = eval_ast(ast, env); + if (!el || mal_error) { return NULL; } + MalVal *f = _first(el), + *args = _rest(el); + assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, + "cannot apply '%s'", _pr_str(f,1)); + return _apply(f, args); + } +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(Env *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +// Setup the initial REPL environment +Env *repl_env; + +void init_repl_env() { + repl_env = new_env(NULL, NULL, NULL); + + // core.c: defined using C + int i; + for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { + env_set(repl_env, + malval_new_symbol(core_ns[i].name), + malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); + } + + // core.mal: defined using the language itself + RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); +} + +int main() +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt and environment + snprintf(prompt, sizeof(prompt), "user> "); + init_repl_env(); + + // repl loop + for(;;) { + exp = RE(repl_env, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/step5_tco.c b/impls/c/step5_tco.c index 917e3e3807..490312eb89 100644 --- a/impls/c/step5_tco.c +++ b/impls/c/step5_tco.c @@ -1,233 +1,233 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" -#include "core.h" - -// Declarations -MalVal *EVAL(MalVal *ast, Env *env); - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -MalVal *eval_ast(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - if (ast->type == MAL_SYMBOL) { - //g_print("EVAL symbol: %s\n", ast->val.string); - return env_get(env, ast); - } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { - //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); - MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); - if (!el || mal_error) return NULL; - el->type = ast->type; - return el; - } else if (ast->type == MAL_HASH_MAP) { - //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(ast))); - g_hash_table_iter_init (&iter, ast->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - MalVal *new_val = EVAL((MalVal *)value, env); - g_array_append_val(seq->val.array, new_val); - } - return _hash_map(seq); - } else { - //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); - return ast; - } -} - -MalVal *EVAL(MalVal *ast, Env *env) { - while (TRUE) { - - if (!ast || mal_error) return NULL; - //g_print("EVAL: %s\n", _pr_str(ast,1)); - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (!ast || mal_error) return NULL; - - // apply list - //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); - int i, len; - if (_count(ast) == 0) { return ast; } - MalVal *a0 = _nth(ast, 0); - if ((a0->type & MAL_SYMBOL) && - strcmp("def!", a0->val.string) == 0) { - //g_print("eval apply def!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("let*", a0->val.string) == 0) { - //g_print("eval apply let*\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2), - *key, *val; - assert_type(a1, MAL_LIST|MAL_VECTOR, - "let* bindings must be list or vector"); - len = _count(a1); - assert((len % 2) == 0, "odd number of let* bindings forms"); - Env *let_env = new_env(env, NULL, NULL); - for(i=0; ival.array, MalVal*, i); - val = g_array_index(a1->val.array, MalVal*, i+1); - assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); - env_set(let_env, key, EVAL(val, let_env)); - } - ast = a2; - env = let_env; - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("do", a0->val.string) == 0) { - //g_print("eval apply do\n"); - eval_ast(_slice(ast, 1, _count(ast)-1), env); - ast = _last(ast); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("if", a0->val.string) == 0) { - //g_print("eval apply if\n"); - MalVal *a1 = _nth(ast, 1); - MalVal *cond = EVAL(a1, env); - if (!cond || mal_error) return NULL; - if (cond->type & (MAL_FALSE|MAL_NIL)) { - // eval false slot form - if (ast->val.array->len > 3) { - ast = _nth(ast, 3); - } else { - return &mal_nil; - } - } else { - // eval true slot form - ast = _nth(ast, 2); - } - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("fn*", a0->val.string) == 0) { - //g_print("eval apply fn*\n"); - MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); - mf->val.func.evaluator = EVAL; - mf->val.func.args = _nth(ast, 1); - mf->val.func.body = _nth(ast, 2); - mf->val.func.env = env; - return mf; - } else { - //g_print("eval apply\n"); - MalVal *el = eval_ast(ast, env); - if (!el || mal_error) { return NULL; } - MalVal *f = _first(el), - *args = _rest(el); - assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, - "cannot apply '%s'", _pr_str(f,1)); - if (f->type & MAL_FUNCTION_MAL) { - ast = f->val.func.body; - env = new_env(f->val.func.env, f->val.func.args, args); - // Continue loop - } else { - return _apply(f, args); - } - } - - } // TCO while loop -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(Env *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -// Setup the initial REPL environment -Env *repl_env; - -void init_repl_env() { - repl_env = new_env(NULL, NULL, NULL); - - // core.c: defined using C - int i; - for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { - env_set(repl_env, - malval_new_symbol(core_ns[i].name), - malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); - } - - // core.mal: defined using the language itself - RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); -} - -int main() -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt and environment - snprintf(prompt, sizeof(prompt), "user> "); - init_repl_env(); - - // repl loop - for(;;) { - exp = RE(repl_env, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" +#include "core.h" + +// Declarations +MalVal *EVAL(MalVal *ast, Env *env); + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +MalVal *eval_ast(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + if (ast->type == MAL_SYMBOL) { + //g_print("EVAL symbol: %s\n", ast->val.string); + return env_get(env, ast); + } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { + //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); + MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); + if (!el || mal_error) return NULL; + el->type = ast->type; + return el; + } else if (ast->type == MAL_HASH_MAP) { + //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(ast))); + g_hash_table_iter_init (&iter, ast->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + MalVal *new_val = EVAL((MalVal *)value, env); + g_array_append_val(seq->val.array, new_val); + } + return _hash_map(seq); + } else { + //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); + return ast; + } +} + +MalVal *EVAL(MalVal *ast, Env *env) { + while (TRUE) { + + if (!ast || mal_error) return NULL; + //g_print("EVAL: %s\n", _pr_str(ast,1)); + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (!ast || mal_error) return NULL; + + // apply list + //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); + int i, len; + if (_count(ast) == 0) { return ast; } + MalVal *a0 = _nth(ast, 0); + if ((a0->type & MAL_SYMBOL) && + strcmp("def!", a0->val.string) == 0) { + //g_print("eval apply def!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("let*", a0->val.string) == 0) { + //g_print("eval apply let*\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2), + *key, *val; + assert_type(a1, MAL_LIST|MAL_VECTOR, + "let* bindings must be list or vector"); + len = _count(a1); + assert((len % 2) == 0, "odd number of let* bindings forms"); + Env *let_env = new_env(env, NULL, NULL); + for(i=0; ival.array, MalVal*, i); + val = g_array_index(a1->val.array, MalVal*, i+1); + assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); + env_set(let_env, key, EVAL(val, let_env)); + } + ast = a2; + env = let_env; + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("do", a0->val.string) == 0) { + //g_print("eval apply do\n"); + eval_ast(_slice(ast, 1, _count(ast)-1), env); + ast = _last(ast); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("if", a0->val.string) == 0) { + //g_print("eval apply if\n"); + MalVal *a1 = _nth(ast, 1); + MalVal *cond = EVAL(a1, env); + if (!cond || mal_error) return NULL; + if (cond->type & (MAL_FALSE|MAL_NIL)) { + // eval false slot form + if (ast->val.array->len > 3) { + ast = _nth(ast, 3); + } else { + return &mal_nil; + } + } else { + // eval true slot form + ast = _nth(ast, 2); + } + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("fn*", a0->val.string) == 0) { + //g_print("eval apply fn*\n"); + MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); + mf->val.func.evaluator = EVAL; + mf->val.func.args = _nth(ast, 1); + mf->val.func.body = _nth(ast, 2); + mf->val.func.env = env; + return mf; + } else { + //g_print("eval apply\n"); + MalVal *el = eval_ast(ast, env); + if (!el || mal_error) { return NULL; } + MalVal *f = _first(el), + *args = _rest(el); + assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, + "cannot apply '%s'", _pr_str(f,1)); + if (f->type & MAL_FUNCTION_MAL) { + ast = f->val.func.body; + env = new_env(f->val.func.env, f->val.func.args, args); + // Continue loop + } else { + return _apply(f, args); + } + } + + } // TCO while loop +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(Env *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +// Setup the initial REPL environment +Env *repl_env; + +void init_repl_env() { + repl_env = new_env(NULL, NULL, NULL); + + // core.c: defined using C + int i; + for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { + env_set(repl_env, + malval_new_symbol(core_ns[i].name), + malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); + } + + // core.mal: defined using the language itself + RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); +} + +int main() +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt and environment + snprintf(prompt, sizeof(prompt), "user> "); + init_repl_env(); + + // repl loop + for(;;) { + exp = RE(repl_env, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/step6_file.c b/impls/c/step6_file.c index e7388c878b..3cbcd6b865 100644 --- a/impls/c/step6_file.c +++ b/impls/c/step6_file.c @@ -1,253 +1,253 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" -#include "core.h" - -// Declarations -MalVal *EVAL(MalVal *ast, Env *env); - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -MalVal *eval_ast(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - if (ast->type == MAL_SYMBOL) { - //g_print("EVAL symbol: %s\n", ast->val.string); - return env_get(env, ast); - } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { - //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); - MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); - if (!el || mal_error) return NULL; - el->type = ast->type; - return el; - } else if (ast->type == MAL_HASH_MAP) { - //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(ast))); - g_hash_table_iter_init (&iter, ast->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - MalVal *new_val = EVAL((MalVal *)value, env); - g_array_append_val(seq->val.array, new_val); - } - return _hash_map(seq); - } else { - //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); - return ast; - } -} - -MalVal *EVAL(MalVal *ast, Env *env) { - while (TRUE) { - - if (!ast || mal_error) return NULL; - //g_print("EVAL: %s\n", _pr_str(ast,1)); - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (!ast || mal_error) return NULL; - - // apply list - //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); - int i, len; - if (_count(ast) == 0) { return ast; } - MalVal *a0 = _nth(ast, 0); - if ((a0->type & MAL_SYMBOL) && - strcmp("def!", a0->val.string) == 0) { - //g_print("eval apply def!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("let*", a0->val.string) == 0) { - //g_print("eval apply let*\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2), - *key, *val; - assert_type(a1, MAL_LIST|MAL_VECTOR, - "let* bindings must be list or vector"); - len = _count(a1); - assert((len % 2) == 0, "odd number of let* bindings forms"); - Env *let_env = new_env(env, NULL, NULL); - for(i=0; ival.array, MalVal*, i); - val = g_array_index(a1->val.array, MalVal*, i+1); - assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); - env_set(let_env, key, EVAL(val, let_env)); - } - ast = a2; - env = let_env; - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("do", a0->val.string) == 0) { - //g_print("eval apply do\n"); - eval_ast(_slice(ast, 1, _count(ast)-1), env); - ast = _last(ast); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("if", a0->val.string) == 0) { - //g_print("eval apply if\n"); - MalVal *a1 = _nth(ast, 1); - MalVal *cond = EVAL(a1, env); - if (!cond || mal_error) return NULL; - if (cond->type & (MAL_FALSE|MAL_NIL)) { - // eval false slot form - if (ast->val.array->len > 3) { - ast = _nth(ast, 3); - } else { - return &mal_nil; - } - } else { - // eval true slot form - ast = _nth(ast, 2); - } - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("fn*", a0->val.string) == 0) { - //g_print("eval apply fn*\n"); - MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); - mf->val.func.evaluator = EVAL; - mf->val.func.args = _nth(ast, 1); - mf->val.func.body = _nth(ast, 2); - mf->val.func.env = env; - return mf; - } else { - //g_print("eval apply\n"); - MalVal *el = eval_ast(ast, env); - if (!el || mal_error) { return NULL; } - MalVal *f = _first(el), - *args = _rest(el); - assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, - "cannot apply '%s'", _pr_str(f,1)); - if (f->type & MAL_FUNCTION_MAL) { - ast = f->val.func.body; - env = new_env(f->val.func.env, f->val.func.args, args); - // Continue loop - } else { - return _apply(f, args); - } - } - - } // TCO while loop -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(Env *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -// Setup the initial REPL environment -Env *repl_env; - -MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } - -void init_repl_env(int argc, char *argv[]) { - repl_env = new_env(NULL, NULL, NULL); - - // core.c: defined using C - int i; - for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { - env_set(repl_env, - malval_new_symbol(core_ns[i].name), - malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); - } - env_set(repl_env, - malval_new_symbol("eval"), - malval_new_function((void*(*)(void *))do_eval, 1)); - - MalVal *_argv = _listX(0); - for (i=2; i < argc; i++) { - MalVal *arg = malval_new_string(argv[i]); - g_array_append_val(_argv->val.array, arg); - } - env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "", - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -} - -int main(int argc, char *argv[]) -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt and environment - snprintf(prompt, sizeof(prompt), "user> "); - init_repl_env(argc, argv); - - if (argc > 1) { - char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); - RE(repl_env, "", cmd); - return 0; - } - - // repl loop - for(;;) { - exp = RE(repl_env, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" +#include "core.h" + +// Declarations +MalVal *EVAL(MalVal *ast, Env *env); + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +MalVal *eval_ast(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + if (ast->type == MAL_SYMBOL) { + //g_print("EVAL symbol: %s\n", ast->val.string); + return env_get(env, ast); + } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { + //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); + MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); + if (!el || mal_error) return NULL; + el->type = ast->type; + return el; + } else if (ast->type == MAL_HASH_MAP) { + //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(ast))); + g_hash_table_iter_init (&iter, ast->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + MalVal *new_val = EVAL((MalVal *)value, env); + g_array_append_val(seq->val.array, new_val); + } + return _hash_map(seq); + } else { + //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); + return ast; + } +} + +MalVal *EVAL(MalVal *ast, Env *env) { + while (TRUE) { + + if (!ast || mal_error) return NULL; + //g_print("EVAL: %s\n", _pr_str(ast,1)); + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (!ast || mal_error) return NULL; + + // apply list + //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); + int i, len; + if (_count(ast) == 0) { return ast; } + MalVal *a0 = _nth(ast, 0); + if ((a0->type & MAL_SYMBOL) && + strcmp("def!", a0->val.string) == 0) { + //g_print("eval apply def!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("let*", a0->val.string) == 0) { + //g_print("eval apply let*\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2), + *key, *val; + assert_type(a1, MAL_LIST|MAL_VECTOR, + "let* bindings must be list or vector"); + len = _count(a1); + assert((len % 2) == 0, "odd number of let* bindings forms"); + Env *let_env = new_env(env, NULL, NULL); + for(i=0; ival.array, MalVal*, i); + val = g_array_index(a1->val.array, MalVal*, i+1); + assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); + env_set(let_env, key, EVAL(val, let_env)); + } + ast = a2; + env = let_env; + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("do", a0->val.string) == 0) { + //g_print("eval apply do\n"); + eval_ast(_slice(ast, 1, _count(ast)-1), env); + ast = _last(ast); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("if", a0->val.string) == 0) { + //g_print("eval apply if\n"); + MalVal *a1 = _nth(ast, 1); + MalVal *cond = EVAL(a1, env); + if (!cond || mal_error) return NULL; + if (cond->type & (MAL_FALSE|MAL_NIL)) { + // eval false slot form + if (ast->val.array->len > 3) { + ast = _nth(ast, 3); + } else { + return &mal_nil; + } + } else { + // eval true slot form + ast = _nth(ast, 2); + } + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("fn*", a0->val.string) == 0) { + //g_print("eval apply fn*\n"); + MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); + mf->val.func.evaluator = EVAL; + mf->val.func.args = _nth(ast, 1); + mf->val.func.body = _nth(ast, 2); + mf->val.func.env = env; + return mf; + } else { + //g_print("eval apply\n"); + MalVal *el = eval_ast(ast, env); + if (!el || mal_error) { return NULL; } + MalVal *f = _first(el), + *args = _rest(el); + assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, + "cannot apply '%s'", _pr_str(f,1)); + if (f->type & MAL_FUNCTION_MAL) { + ast = f->val.func.body; + env = new_env(f->val.func.env, f->val.func.args, args); + // Continue loop + } else { + return _apply(f, args); + } + } + + } // TCO while loop +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(Env *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +// Setup the initial REPL environment +Env *repl_env; + +MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } + +void init_repl_env(int argc, char *argv[]) { + repl_env = new_env(NULL, NULL, NULL); + + // core.c: defined using C + int i; + for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { + env_set(repl_env, + malval_new_symbol(core_ns[i].name), + malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); + } + env_set(repl_env, + malval_new_symbol("eval"), + malval_new_function((void*(*)(void *))do_eval, 1)); + + MalVal *_argv = _listX(0); + for (i=2; i < argc; i++) { + MalVal *arg = malval_new_string(argv[i]); + g_array_append_val(_argv->val.array, arg); + } + env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "", + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +} + +int main(int argc, char *argv[]) +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt and environment + snprintf(prompt, sizeof(prompt), "user> "); + init_repl_env(argc, argv); + + if (argc > 1) { + char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); + RE(repl_env, "", cmd); + return 0; + } + + // repl loop + for(;;) { + exp = RE(repl_env, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/step7_quote.c b/impls/c/step7_quote.c index a42f978041..d8f2081b0d 100644 --- a/impls/c/step7_quote.c +++ b/impls/c/step7_quote.c @@ -1,304 +1,304 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" -#include "core.h" - -// Declarations -MalVal *EVAL(MalVal *ast, Env *env); -MalVal *quasiquote(MalVal *ast); - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -int starts_with(MalVal *ast, const char *sym) { - if (ast->type != MAL_LIST) - return 0; - const MalVal * const a0 = _first(ast); - return (a0->type & MAL_SYMBOL) && ! strcmp(sym, a0->val.string); -} - -MalVal *qq_iter(GArray *xs) { - MalVal *acc = _listX(0); - int i; - for (i=xs->len-1; 0<=i; i--) { - MalVal * const elt = g_array_index(xs, MalVal*, i); - if (starts_with(elt, "splice-unquote")) - acc = _listX(3, malval_new_symbol("concat"), _nth(elt, 1), acc); - else - acc = _listX(3, malval_new_symbol("cons"), quasiquote(elt), acc); - } - return acc; -} - -MalVal *quasiquote(MalVal *ast) { - switch (ast->type) { - case MAL_LIST: - if (starts_with(ast, "unquote")) - return _nth(ast, 1); - else - return qq_iter(ast->val.array); - case MAL_VECTOR: - return _listX(2, malval_new_symbol("vec"), qq_iter(ast->val.array)); - case MAL_HASH_MAP: - case MAL_SYMBOL: - return _listX(2, malval_new_symbol("quote"), ast); - default: - return ast; - } -} - -MalVal *eval_ast(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - if (ast->type == MAL_SYMBOL) { - //g_print("EVAL symbol: %s\n", ast->val.string); - return env_get(env, ast); - } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { - //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); - MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); - if (!el || mal_error) return NULL; - el->type = ast->type; - return el; - } else if (ast->type == MAL_HASH_MAP) { - //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(ast))); - g_hash_table_iter_init (&iter, ast->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - MalVal *new_val = EVAL((MalVal *)value, env); - g_array_append_val(seq->val.array, new_val); - } - return _hash_map(seq); - } else { - //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); - return ast; - } -} - -MalVal *EVAL(MalVal *ast, Env *env) { - while (TRUE) { - - if (!ast || mal_error) return NULL; - //g_print("EVAL: %s\n", _pr_str(ast,1)); - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (!ast || mal_error) return NULL; - - // apply list - //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); - int i, len; - if (_count(ast) == 0) { return ast; } - MalVal *a0 = _nth(ast, 0); - if ((a0->type & MAL_SYMBOL) && - strcmp("def!", a0->val.string) == 0) { - //g_print("eval apply def!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("let*", a0->val.string) == 0) { - //g_print("eval apply let*\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2), - *key, *val; - assert_type(a1, MAL_LIST|MAL_VECTOR, - "let* bindings must be list or vector"); - len = _count(a1); - assert((len % 2) == 0, "odd number of let* bindings forms"); - Env *let_env = new_env(env, NULL, NULL); - for(i=0; ival.array, MalVal*, i); - val = g_array_index(a1->val.array, MalVal*, i+1); - assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); - env_set(let_env, key, EVAL(val, let_env)); - } - ast = a2; - env = let_env; - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quote", a0->val.string) == 0) { - //g_print("eval apply quote\n"); - return _nth(ast, 1); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quasiquoteexpand", a0->val.string) == 0) { - return quasiquote(_nth(ast, 1)); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quasiquote", a0->val.string) == 0) { - //g_print("eval apply quasiquote\n"); - MalVal *a1 = _nth(ast, 1); - ast = quasiquote(a1); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("do", a0->val.string) == 0) { - //g_print("eval apply do\n"); - eval_ast(_slice(ast, 1, _count(ast)-1), env); - ast = _last(ast); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("if", a0->val.string) == 0) { - //g_print("eval apply if\n"); - MalVal *a1 = _nth(ast, 1); - MalVal *cond = EVAL(a1, env); - if (!cond || mal_error) return NULL; - if (cond->type & (MAL_FALSE|MAL_NIL)) { - // eval false slot form - if (ast->val.array->len > 3) { - ast = _nth(ast, 3); - } else { - return &mal_nil; - } - } else { - // eval true slot form - ast = _nth(ast, 2); - } - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("fn*", a0->val.string) == 0) { - //g_print("eval apply fn*\n"); - MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); - mf->val.func.evaluator = EVAL; - mf->val.func.args = _nth(ast, 1); - mf->val.func.body = _nth(ast, 2); - mf->val.func.env = env; - return mf; - } else { - //g_print("eval apply\n"); - MalVal *el = eval_ast(ast, env); - if (!el || mal_error) { return NULL; } - MalVal *f = _first(el), - *args = _rest(el); - assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, - "cannot apply '%s'", _pr_str(f,1)); - if (f->type & MAL_FUNCTION_MAL) { - ast = f->val.func.body; - env = new_env(f->val.func.env, f->val.func.args, args); - // Continue loop - } else { - return _apply(f, args); - } - } - - } // TCO while loop -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(Env *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -// Setup the initial REPL environment -Env *repl_env; - -MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } - -void init_repl_env(int argc, char *argv[]) { - repl_env = new_env(NULL, NULL, NULL); - - // core.c: defined using C - int i; - for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { - env_set(repl_env, - malval_new_symbol(core_ns[i].name), - malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); - } - env_set(repl_env, - malval_new_symbol("eval"), - malval_new_function((void*(*)(void *))do_eval, 1)); - - MalVal *_argv = _listX(0); - for (i=2; i < argc; i++) { - MalVal *arg = malval_new_string(argv[i]); - g_array_append_val(_argv->val.array, arg); - } - env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "", - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -} - -int main(int argc, char *argv[]) -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt and environment - snprintf(prompt, sizeof(prompt), "user> "); - init_repl_env(argc, argv); - - if (argc > 1) { - char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); - RE(repl_env, "", cmd); - return 0; - } - - // repl loop - for(;;) { - exp = RE(repl_env, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" +#include "core.h" + +// Declarations +MalVal *EVAL(MalVal *ast, Env *env); +MalVal *quasiquote(MalVal *ast); + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +int starts_with(MalVal *ast, const char *sym) { + if (ast->type != MAL_LIST) + return 0; + const MalVal * const a0 = _first(ast); + return (a0->type & MAL_SYMBOL) && ! strcmp(sym, a0->val.string); +} + +MalVal *qq_iter(GArray *xs) { + MalVal *acc = _listX(0); + int i; + for (i=xs->len-1; 0<=i; i--) { + MalVal * const elt = g_array_index(xs, MalVal*, i); + if (starts_with(elt, "splice-unquote")) + acc = _listX(3, malval_new_symbol("concat"), _nth(elt, 1), acc); + else + acc = _listX(3, malval_new_symbol("cons"), quasiquote(elt), acc); + } + return acc; +} + +MalVal *quasiquote(MalVal *ast) { + switch (ast->type) { + case MAL_LIST: + if (starts_with(ast, "unquote")) + return _nth(ast, 1); + else + return qq_iter(ast->val.array); + case MAL_VECTOR: + return _listX(2, malval_new_symbol("vec"), qq_iter(ast->val.array)); + case MAL_HASH_MAP: + case MAL_SYMBOL: + return _listX(2, malval_new_symbol("quote"), ast); + default: + return ast; + } +} + +MalVal *eval_ast(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + if (ast->type == MAL_SYMBOL) { + //g_print("EVAL symbol: %s\n", ast->val.string); + return env_get(env, ast); + } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { + //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); + MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); + if (!el || mal_error) return NULL; + el->type = ast->type; + return el; + } else if (ast->type == MAL_HASH_MAP) { + //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(ast))); + g_hash_table_iter_init (&iter, ast->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + MalVal *new_val = EVAL((MalVal *)value, env); + g_array_append_val(seq->val.array, new_val); + } + return _hash_map(seq); + } else { + //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); + return ast; + } +} + +MalVal *EVAL(MalVal *ast, Env *env) { + while (TRUE) { + + if (!ast || mal_error) return NULL; + //g_print("EVAL: %s\n", _pr_str(ast,1)); + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (!ast || mal_error) return NULL; + + // apply list + //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); + int i, len; + if (_count(ast) == 0) { return ast; } + MalVal *a0 = _nth(ast, 0); + if ((a0->type & MAL_SYMBOL) && + strcmp("def!", a0->val.string) == 0) { + //g_print("eval apply def!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("let*", a0->val.string) == 0) { + //g_print("eval apply let*\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2), + *key, *val; + assert_type(a1, MAL_LIST|MAL_VECTOR, + "let* bindings must be list or vector"); + len = _count(a1); + assert((len % 2) == 0, "odd number of let* bindings forms"); + Env *let_env = new_env(env, NULL, NULL); + for(i=0; ival.array, MalVal*, i); + val = g_array_index(a1->val.array, MalVal*, i+1); + assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); + env_set(let_env, key, EVAL(val, let_env)); + } + ast = a2; + env = let_env; + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quote", a0->val.string) == 0) { + //g_print("eval apply quote\n"); + return _nth(ast, 1); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quasiquoteexpand", a0->val.string) == 0) { + return quasiquote(_nth(ast, 1)); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quasiquote", a0->val.string) == 0) { + //g_print("eval apply quasiquote\n"); + MalVal *a1 = _nth(ast, 1); + ast = quasiquote(a1); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("do", a0->val.string) == 0) { + //g_print("eval apply do\n"); + eval_ast(_slice(ast, 1, _count(ast)-1), env); + ast = _last(ast); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("if", a0->val.string) == 0) { + //g_print("eval apply if\n"); + MalVal *a1 = _nth(ast, 1); + MalVal *cond = EVAL(a1, env); + if (!cond || mal_error) return NULL; + if (cond->type & (MAL_FALSE|MAL_NIL)) { + // eval false slot form + if (ast->val.array->len > 3) { + ast = _nth(ast, 3); + } else { + return &mal_nil; + } + } else { + // eval true slot form + ast = _nth(ast, 2); + } + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("fn*", a0->val.string) == 0) { + //g_print("eval apply fn*\n"); + MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); + mf->val.func.evaluator = EVAL; + mf->val.func.args = _nth(ast, 1); + mf->val.func.body = _nth(ast, 2); + mf->val.func.env = env; + return mf; + } else { + //g_print("eval apply\n"); + MalVal *el = eval_ast(ast, env); + if (!el || mal_error) { return NULL; } + MalVal *f = _first(el), + *args = _rest(el); + assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, + "cannot apply '%s'", _pr_str(f,1)); + if (f->type & MAL_FUNCTION_MAL) { + ast = f->val.func.body; + env = new_env(f->val.func.env, f->val.func.args, args); + // Continue loop + } else { + return _apply(f, args); + } + } + + } // TCO while loop +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(Env *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +// Setup the initial REPL environment +Env *repl_env; + +MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } + +void init_repl_env(int argc, char *argv[]) { + repl_env = new_env(NULL, NULL, NULL); + + // core.c: defined using C + int i; + for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { + env_set(repl_env, + malval_new_symbol(core_ns[i].name), + malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); + } + env_set(repl_env, + malval_new_symbol("eval"), + malval_new_function((void*(*)(void *))do_eval, 1)); + + MalVal *_argv = _listX(0); + for (i=2; i < argc; i++) { + MalVal *arg = malval_new_string(argv[i]); + g_array_append_val(_argv->val.array, arg); + } + env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "", + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +} + +int main(int argc, char *argv[]) +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt and environment + snprintf(prompt, sizeof(prompt), "user> "); + init_repl_env(argc, argv); + + if (argc > 1) { + char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); + RE(repl_env, "", cmd); + return 0; + } + + // repl loop + for(;;) { + exp = RE(repl_env, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/step8_macros.c b/impls/c/step8_macros.c index ac5a3b0f02..873766f907 100644 --- a/impls/c/step8_macros.c +++ b/impls/c/step8_macros.c @@ -1,347 +1,347 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" -#include "core.h" - -// Declarations -MalVal *EVAL(MalVal *ast, Env *env); -MalVal *quasiquote(MalVal *ast); -MalVal *macroexpand(MalVal *ast, Env *env); - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -int starts_with(MalVal *ast, const char *sym) { - if (ast->type != MAL_LIST) - return 0; - const MalVal * const a0 = _first(ast); - return (a0->type & MAL_SYMBOL) && ! strcmp(sym, a0->val.string); -} - -MalVal *qq_iter(GArray *xs) { - MalVal *acc = _listX(0); - int i; - for (i=xs->len-1; 0<=i; i--) { - MalVal * const elt = g_array_index(xs, MalVal*, i); - if (starts_with(elt, "splice-unquote")) - acc = _listX(3, malval_new_symbol("concat"), _nth(elt, 1), acc); - else - acc = _listX(3, malval_new_symbol("cons"), quasiquote(elt), acc); - } - return acc; -} - -MalVal *quasiquote(MalVal *ast) { - switch (ast->type) { - case MAL_LIST: - if (starts_with(ast, "unquote")) - return _nth(ast, 1); - else - return qq_iter(ast->val.array); - case MAL_VECTOR: - return _listX(2, malval_new_symbol("vec"), qq_iter(ast->val.array)); - case MAL_HASH_MAP: - case MAL_SYMBOL: - return _listX(2, malval_new_symbol("quote"), ast); - default: - return ast; - } -} - -int is_macro_call(MalVal *ast, Env *env) { - if (!ast || ast->type != MAL_LIST || _count(ast) == 0) { return 0; } - MalVal *a0 = _nth(ast, 0); - return (a0->type & MAL_SYMBOL) && - env_find(env, a0) && - env_get(env, a0)->ismacro; -} - -MalVal *macroexpand(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - while (is_macro_call(ast, env)) { - MalVal *a0 = _nth(ast, 0); - MalVal *mac = env_get(env, a0); - // TODO: this is weird and limits it to 20. FIXME - ast = _apply(mac, _rest(ast)); - } - return ast; -} - -MalVal *eval_ast(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - if (ast->type == MAL_SYMBOL) { - //g_print("EVAL symbol: %s\n", ast->val.string); - return env_get(env, ast); - } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { - //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); - MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); - if (!el || mal_error) return NULL; - el->type = ast->type; - return el; - } else if (ast->type == MAL_HASH_MAP) { - //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(ast))); - g_hash_table_iter_init (&iter, ast->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - MalVal *new_val = EVAL((MalVal *)value, env); - g_array_append_val(seq->val.array, new_val); - } - return _hash_map(seq); - } else { - //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); - return ast; - } -} - -MalVal *EVAL(MalVal *ast, Env *env) { - while (TRUE) { - - if (!ast || mal_error) return NULL; - //g_print("EVAL: %s\n", _pr_str(ast,1)); - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (!ast || mal_error) return NULL; - - // apply list - //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); - ast = macroexpand(ast, env); - if (!ast || mal_error) return NULL; - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (_count(ast) == 0) { return ast; } - - int i, len; - MalVal *a0 = _nth(ast, 0); - if ((a0->type & MAL_SYMBOL) && - strcmp("def!", a0->val.string) == 0) { - //g_print("eval apply def!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("let*", a0->val.string) == 0) { - //g_print("eval apply let*\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2), - *key, *val; - assert_type(a1, MAL_LIST|MAL_VECTOR, - "let* bindings must be list or vector"); - len = _count(a1); - assert((len % 2) == 0, "odd number of let* bindings forms"); - Env *let_env = new_env(env, NULL, NULL); - for(i=0; ival.array, MalVal*, i); - val = g_array_index(a1->val.array, MalVal*, i+1); - assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); - env_set(let_env, key, EVAL(val, let_env)); - } - ast = a2; - env = let_env; - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quote", a0->val.string) == 0) { - //g_print("eval apply quote\n"); - return _nth(ast, 1); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quasiquoteexpand", a0->val.string) == 0) { - return quasiquote(_nth(ast, 1)); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quasiquote", a0->val.string) == 0) { - //g_print("eval apply quasiquote\n"); - MalVal *a1 = _nth(ast, 1); - ast = quasiquote(a1); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("defmacro!", a0->val.string) == 0) { - //g_print("eval apply defmacro!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - res->ismacro = TRUE; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("macroexpand", a0->val.string) == 0) { - //g_print("eval apply macroexpand\n"); - MalVal *a1 = _nth(ast, 1); - return macroexpand(a1, env); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("do", a0->val.string) == 0) { - //g_print("eval apply do\n"); - eval_ast(_slice(ast, 1, _count(ast)-1), env); - ast = _last(ast); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("if", a0->val.string) == 0) { - //g_print("eval apply if\n"); - MalVal *a1 = _nth(ast, 1); - MalVal *cond = EVAL(a1, env); - if (!cond || mal_error) return NULL; - if (cond->type & (MAL_FALSE|MAL_NIL)) { - // eval false slot form - if (ast->val.array->len > 3) { - ast = _nth(ast, 3); - } else { - return &mal_nil; - } - } else { - // eval true slot form - ast = _nth(ast, 2); - } - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("fn*", a0->val.string) == 0) { - //g_print("eval apply fn*\n"); - MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); - mf->ismacro = FALSE; - mf->val.func.evaluator = EVAL; - mf->val.func.args = _nth(ast, 1); - mf->val.func.body = _nth(ast, 2); - mf->val.func.env = env; - return mf; - } else { - //g_print("eval apply\n"); - MalVal *el = eval_ast(ast, env); - if (!el || mal_error) { return NULL; } - MalVal *f = _first(el), - *args = _rest(el); - assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, - "cannot apply '%s'", _pr_str(f,1)); - if (f->type & MAL_FUNCTION_MAL) { - ast = f->val.func.body; - env = new_env(f->val.func.env, f->val.func.args, args); - // Continue loop - } else { - return _apply(f, args); - } - } - - } // TCO while loop -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(Env *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -// Setup the initial REPL environment -Env *repl_env; - -MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } - -void init_repl_env(int argc, char *argv[]) { - repl_env = new_env(NULL, NULL, NULL); - - // core.c: defined using C - int i; - for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { - env_set(repl_env, - malval_new_symbol(core_ns[i].name), - malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); - } - env_set(repl_env, - malval_new_symbol("eval"), - malval_new_function((void*(*)(void *))do_eval, 1)); - - MalVal *_argv = _listX(0); - for (i=2; i < argc; i++) { - MalVal *arg = malval_new_string(argv[i]); - g_array_append_val(_argv->val.array, arg); - } - env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "", - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - RE(repl_env, "", "(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)))))))"); -} - -int main(int argc, char *argv[]) -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt and environment - snprintf(prompt, sizeof(prompt), "user> "); - init_repl_env(argc, argv); - - if (argc > 1) { - char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); - RE(repl_env, "", cmd); - return 0; - } - - // repl loop - for(;;) { - exp = RE(repl_env, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" +#include "core.h" + +// Declarations +MalVal *EVAL(MalVal *ast, Env *env); +MalVal *quasiquote(MalVal *ast); +MalVal *macroexpand(MalVal *ast, Env *env); + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +int starts_with(MalVal *ast, const char *sym) { + if (ast->type != MAL_LIST) + return 0; + const MalVal * const a0 = _first(ast); + return (a0->type & MAL_SYMBOL) && ! strcmp(sym, a0->val.string); +} + +MalVal *qq_iter(GArray *xs) { + MalVal *acc = _listX(0); + int i; + for (i=xs->len-1; 0<=i; i--) { + MalVal * const elt = g_array_index(xs, MalVal*, i); + if (starts_with(elt, "splice-unquote")) + acc = _listX(3, malval_new_symbol("concat"), _nth(elt, 1), acc); + else + acc = _listX(3, malval_new_symbol("cons"), quasiquote(elt), acc); + } + return acc; +} + +MalVal *quasiquote(MalVal *ast) { + switch (ast->type) { + case MAL_LIST: + if (starts_with(ast, "unquote")) + return _nth(ast, 1); + else + return qq_iter(ast->val.array); + case MAL_VECTOR: + return _listX(2, malval_new_symbol("vec"), qq_iter(ast->val.array)); + case MAL_HASH_MAP: + case MAL_SYMBOL: + return _listX(2, malval_new_symbol("quote"), ast); + default: + return ast; + } +} + +int is_macro_call(MalVal *ast, Env *env) { + if (!ast || ast->type != MAL_LIST || _count(ast) == 0) { return 0; } + MalVal *a0 = _nth(ast, 0); + return (a0->type & MAL_SYMBOL) && + env_find(env, a0) && + env_get(env, a0)->ismacro; +} + +MalVal *macroexpand(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + while (is_macro_call(ast, env)) { + MalVal *a0 = _nth(ast, 0); + MalVal *mac = env_get(env, a0); + // TODO: this is weird and limits it to 20. FIXME + ast = _apply(mac, _rest(ast)); + } + return ast; +} + +MalVal *eval_ast(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + if (ast->type == MAL_SYMBOL) { + //g_print("EVAL symbol: %s\n", ast->val.string); + return env_get(env, ast); + } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { + //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); + MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); + if (!el || mal_error) return NULL; + el->type = ast->type; + return el; + } else if (ast->type == MAL_HASH_MAP) { + //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(ast))); + g_hash_table_iter_init (&iter, ast->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + MalVal *new_val = EVAL((MalVal *)value, env); + g_array_append_val(seq->val.array, new_val); + } + return _hash_map(seq); + } else { + //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); + return ast; + } +} + +MalVal *EVAL(MalVal *ast, Env *env) { + while (TRUE) { + + if (!ast || mal_error) return NULL; + //g_print("EVAL: %s\n", _pr_str(ast,1)); + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (!ast || mal_error) return NULL; + + // apply list + //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); + ast = macroexpand(ast, env); + if (!ast || mal_error) return NULL; + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (_count(ast) == 0) { return ast; } + + int i, len; + MalVal *a0 = _nth(ast, 0); + if ((a0->type & MAL_SYMBOL) && + strcmp("def!", a0->val.string) == 0) { + //g_print("eval apply def!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("let*", a0->val.string) == 0) { + //g_print("eval apply let*\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2), + *key, *val; + assert_type(a1, MAL_LIST|MAL_VECTOR, + "let* bindings must be list or vector"); + len = _count(a1); + assert((len % 2) == 0, "odd number of let* bindings forms"); + Env *let_env = new_env(env, NULL, NULL); + for(i=0; ival.array, MalVal*, i); + val = g_array_index(a1->val.array, MalVal*, i+1); + assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); + env_set(let_env, key, EVAL(val, let_env)); + } + ast = a2; + env = let_env; + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quote", a0->val.string) == 0) { + //g_print("eval apply quote\n"); + return _nth(ast, 1); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quasiquoteexpand", a0->val.string) == 0) { + return quasiquote(_nth(ast, 1)); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quasiquote", a0->val.string) == 0) { + //g_print("eval apply quasiquote\n"); + MalVal *a1 = _nth(ast, 1); + ast = quasiquote(a1); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("defmacro!", a0->val.string) == 0) { + //g_print("eval apply defmacro!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + res->ismacro = TRUE; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("macroexpand", a0->val.string) == 0) { + //g_print("eval apply macroexpand\n"); + MalVal *a1 = _nth(ast, 1); + return macroexpand(a1, env); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("do", a0->val.string) == 0) { + //g_print("eval apply do\n"); + eval_ast(_slice(ast, 1, _count(ast)-1), env); + ast = _last(ast); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("if", a0->val.string) == 0) { + //g_print("eval apply if\n"); + MalVal *a1 = _nth(ast, 1); + MalVal *cond = EVAL(a1, env); + if (!cond || mal_error) return NULL; + if (cond->type & (MAL_FALSE|MAL_NIL)) { + // eval false slot form + if (ast->val.array->len > 3) { + ast = _nth(ast, 3); + } else { + return &mal_nil; + } + } else { + // eval true slot form + ast = _nth(ast, 2); + } + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("fn*", a0->val.string) == 0) { + //g_print("eval apply fn*\n"); + MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); + mf->ismacro = FALSE; + mf->val.func.evaluator = EVAL; + mf->val.func.args = _nth(ast, 1); + mf->val.func.body = _nth(ast, 2); + mf->val.func.env = env; + return mf; + } else { + //g_print("eval apply\n"); + MalVal *el = eval_ast(ast, env); + if (!el || mal_error) { return NULL; } + MalVal *f = _first(el), + *args = _rest(el); + assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, + "cannot apply '%s'", _pr_str(f,1)); + if (f->type & MAL_FUNCTION_MAL) { + ast = f->val.func.body; + env = new_env(f->val.func.env, f->val.func.args, args); + // Continue loop + } else { + return _apply(f, args); + } + } + + } // TCO while loop +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(Env *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +// Setup the initial REPL environment +Env *repl_env; + +MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } + +void init_repl_env(int argc, char *argv[]) { + repl_env = new_env(NULL, NULL, NULL); + + // core.c: defined using C + int i; + for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { + env_set(repl_env, + malval_new_symbol(core_ns[i].name), + malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); + } + env_set(repl_env, + malval_new_symbol("eval"), + malval_new_function((void*(*)(void *))do_eval, 1)); + + MalVal *_argv = _listX(0); + for (i=2; i < argc; i++) { + MalVal *arg = malval_new_string(argv[i]); + g_array_append_val(_argv->val.array, arg); + } + env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "", + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + RE(repl_env, "", "(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)))))))"); +} + +int main(int argc, char *argv[]) +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt and environment + snprintf(prompt, sizeof(prompt), "user> "); + init_repl_env(argc, argv); + + if (argc > 1) { + char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); + RE(repl_env, "", cmd); + return 0; + } + + // repl loop + for(;;) { + exp = RE(repl_env, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/step9_try.c b/impls/c/step9_try.c index 61ac91f784..7de0ab8e83 100644 --- a/impls/c/step9_try.c +++ b/impls/c/step9_try.c @@ -1,372 +1,372 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" -#include "core.h" -#include "interop.h" - -// Declarations -MalVal *EVAL(MalVal *ast, Env *env); -MalVal *quasiquote(MalVal *ast); -MalVal *macroexpand(MalVal *ast, Env *env); - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -int starts_with(MalVal *ast, const char *sym) { - if (ast->type != MAL_LIST) - return 0; - const MalVal * const a0 = _first(ast); - return (a0->type & MAL_SYMBOL) && ! strcmp(sym, a0->val.string); -} - -MalVal *qq_iter(GArray *xs) { - MalVal *acc = _listX(0); - int i; - for (i=xs->len-1; 0<=i; i--) { - MalVal * const elt = g_array_index(xs, MalVal*, i); - if (starts_with(elt, "splice-unquote")) - acc = _listX(3, malval_new_symbol("concat"), _nth(elt, 1), acc); - else - acc = _listX(3, malval_new_symbol("cons"), quasiquote(elt), acc); - } - return acc; -} - -MalVal *quasiquote(MalVal *ast) { - switch (ast->type) { - case MAL_LIST: - if (starts_with(ast, "unquote")) - return _nth(ast, 1); - else - return qq_iter(ast->val.array); - case MAL_VECTOR: - return _listX(2, malval_new_symbol("vec"), qq_iter(ast->val.array)); - case MAL_HASH_MAP: - case MAL_SYMBOL: - return _listX(2, malval_new_symbol("quote"), ast); - default: - return ast; - } -} - -int is_macro_call(MalVal *ast, Env *env) { - if (!ast || ast->type != MAL_LIST || _count(ast) == 0) { return 0; } - MalVal *a0 = _nth(ast, 0); - return (a0->type & MAL_SYMBOL) && - env_find(env, a0) && - env_get(env, a0)->ismacro; -} - -MalVal *macroexpand(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - while (is_macro_call(ast, env)) { - MalVal *a0 = _nth(ast, 0); - MalVal *mac = env_get(env, a0); - // TODO: this is weird and limits it to 20. FIXME - ast = _apply(mac, _rest(ast)); - } - return ast; -} - -MalVal *eval_ast(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - if (ast->type == MAL_SYMBOL) { - //g_print("EVAL symbol: %s\n", ast->val.string); - return env_get(env, ast); - } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { - //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); - MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); - if (!el || mal_error) return NULL; - el->type = ast->type; - return el; - } else if (ast->type == MAL_HASH_MAP) { - //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(ast))); - g_hash_table_iter_init (&iter, ast->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - MalVal *new_val = EVAL((MalVal *)value, env); - g_array_append_val(seq->val.array, new_val); - } - return _hash_map(seq); - } else { - //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); - return ast; - } -} - -MalVal *EVAL(MalVal *ast, Env *env) { - while (TRUE) { - - if (!ast || mal_error) return NULL; - //g_print("EVAL: %s\n", _pr_str(ast,1)); - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (!ast || mal_error) return NULL; - - // apply list - //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); - ast = macroexpand(ast, env); - if (!ast || mal_error) return NULL; - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (_count(ast) == 0) { return ast; } - - int i, len; - MalVal *a0 = _nth(ast, 0); - if ((a0->type & MAL_SYMBOL) && - strcmp("def!", a0->val.string) == 0) { - //g_print("eval apply def!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("let*", a0->val.string) == 0) { - //g_print("eval apply let*\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2), - *key, *val; - assert_type(a1, MAL_LIST|MAL_VECTOR, - "let* bindings must be list or vector"); - len = _count(a1); - assert((len % 2) == 0, "odd number of let* bindings forms"); - Env *let_env = new_env(env, NULL, NULL); - for(i=0; ival.array, MalVal*, i); - val = g_array_index(a1->val.array, MalVal*, i+1); - assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); - env_set(let_env, key, EVAL(val, let_env)); - } - ast = a2; - env = let_env; - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quote", a0->val.string) == 0) { - //g_print("eval apply quote\n"); - return _nth(ast, 1); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quasiquoteexpand", a0->val.string) == 0) { - return quasiquote(_nth(ast, 1)); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quasiquote", a0->val.string) == 0) { - //g_print("eval apply quasiquote\n"); - MalVal *a1 = _nth(ast, 1); - ast = quasiquote(a1); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("defmacro!", a0->val.string) == 0) { - //g_print("eval apply defmacro!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - res->ismacro = TRUE; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("macroexpand", a0->val.string) == 0) { - //g_print("eval apply macroexpand\n"); - MalVal *a1 = _nth(ast, 1); - return macroexpand(a1, env); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("try*", a0->val.string) == 0) { - //g_print("eval apply try*\n"); - MalVal *a1 = _nth(ast, 1); - MalVal *res = EVAL(a1, env); - if (ast->val.array->len < 3) { - return &mal_nil; - } - MalVal *a2 = _nth(ast, 2); - if (!mal_error) { return res; } - MalVal *a20 = _nth(a2, 0); - if (strcmp("catch*", a20->val.string) == 0) { - MalVal *a21 = _nth(a2, 1); - MalVal *a22 = _nth(a2, 2); - Env *catch_env = new_env(env, - _listX(1, a21), - _listX(1, mal_error)); - //malval_free(mal_error); - mal_error = NULL; - res = EVAL(a22, catch_env); - return res; - } else { - return &mal_nil; - } - } else if ((a0->type & MAL_SYMBOL) && - strcmp("do", a0->val.string) == 0) { - //g_print("eval apply do\n"); - eval_ast(_slice(ast, 1, _count(ast)-1), env); - ast = _last(ast); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("if", a0->val.string) == 0) { - //g_print("eval apply if\n"); - MalVal *a1 = _nth(ast, 1); - MalVal *cond = EVAL(a1, env); - if (!cond || mal_error) return NULL; - if (cond->type & (MAL_FALSE|MAL_NIL)) { - // eval false slot form - if (ast->val.array->len > 3) { - ast = _nth(ast, 3); - } else { - return &mal_nil; - } - } else { - // eval true slot form - ast = _nth(ast, 2); - } - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("fn*", a0->val.string) == 0) { - //g_print("eval apply fn*\n"); - MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); - mf->ismacro = FALSE; - mf->val.func.evaluator = EVAL; - mf->val.func.args = _nth(ast, 1); - mf->val.func.body = _nth(ast, 2); - mf->val.func.env = env; - return mf; - } else { - //g_print("eval apply\n"); - MalVal *el = eval_ast(ast, env); - if (!el || mal_error) { return NULL; } - MalVal *f = _first(el), - *args = _rest(el); - assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, - "cannot apply '%s'", _pr_str(f,1)); - if (f->type & MAL_FUNCTION_MAL) { - ast = f->val.func.body; - env = new_env(f->val.func.env, f->val.func.args, args); - // Continue loop - } else { - return _apply(f, args); - } - } - - } // TCO while loop -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(Env *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -// Setup the initial REPL environment -Env *repl_env; - -MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } - -void init_repl_env(int argc, char *argv[]) { - repl_env = new_env(NULL, NULL, NULL); - - // core.c: defined using C - int i; - for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { - env_set(repl_env, - malval_new_symbol(core_ns[i].name), - malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); - } - env_set(repl_env, - malval_new_symbol("eval"), - malval_new_function((void*(*)(void *))do_eval, 1)); - - MalVal *_argv = _listX(0); - for (i=2; i < argc; i++) { - MalVal *arg = malval_new_string(argv[i]); - g_array_append_val(_argv->val.array, arg); - } - env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "", - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - RE(repl_env, "", "(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)))))))"); -} - -int main(int argc, char *argv[]) -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt and environment - snprintf(prompt, sizeof(prompt), "user> "); - init_repl_env(argc, argv); - - if (argc > 1) { - char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); - RE(repl_env, "", cmd); - return 0; - } - - // repl loop - for(;;) { - exp = RE(repl_env, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" +#include "core.h" +#include "interop.h" + +// Declarations +MalVal *EVAL(MalVal *ast, Env *env); +MalVal *quasiquote(MalVal *ast); +MalVal *macroexpand(MalVal *ast, Env *env); + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +int starts_with(MalVal *ast, const char *sym) { + if (ast->type != MAL_LIST) + return 0; + const MalVal * const a0 = _first(ast); + return (a0->type & MAL_SYMBOL) && ! strcmp(sym, a0->val.string); +} + +MalVal *qq_iter(GArray *xs) { + MalVal *acc = _listX(0); + int i; + for (i=xs->len-1; 0<=i; i--) { + MalVal * const elt = g_array_index(xs, MalVal*, i); + if (starts_with(elt, "splice-unquote")) + acc = _listX(3, malval_new_symbol("concat"), _nth(elt, 1), acc); + else + acc = _listX(3, malval_new_symbol("cons"), quasiquote(elt), acc); + } + return acc; +} + +MalVal *quasiquote(MalVal *ast) { + switch (ast->type) { + case MAL_LIST: + if (starts_with(ast, "unquote")) + return _nth(ast, 1); + else + return qq_iter(ast->val.array); + case MAL_VECTOR: + return _listX(2, malval_new_symbol("vec"), qq_iter(ast->val.array)); + case MAL_HASH_MAP: + case MAL_SYMBOL: + return _listX(2, malval_new_symbol("quote"), ast); + default: + return ast; + } +} + +int is_macro_call(MalVal *ast, Env *env) { + if (!ast || ast->type != MAL_LIST || _count(ast) == 0) { return 0; } + MalVal *a0 = _nth(ast, 0); + return (a0->type & MAL_SYMBOL) && + env_find(env, a0) && + env_get(env, a0)->ismacro; +} + +MalVal *macroexpand(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + while (is_macro_call(ast, env)) { + MalVal *a0 = _nth(ast, 0); + MalVal *mac = env_get(env, a0); + // TODO: this is weird and limits it to 20. FIXME + ast = _apply(mac, _rest(ast)); + } + return ast; +} + +MalVal *eval_ast(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + if (ast->type == MAL_SYMBOL) { + //g_print("EVAL symbol: %s\n", ast->val.string); + return env_get(env, ast); + } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { + //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); + MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); + if (!el || mal_error) return NULL; + el->type = ast->type; + return el; + } else if (ast->type == MAL_HASH_MAP) { + //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(ast))); + g_hash_table_iter_init (&iter, ast->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + MalVal *new_val = EVAL((MalVal *)value, env); + g_array_append_val(seq->val.array, new_val); + } + return _hash_map(seq); + } else { + //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); + return ast; + } +} + +MalVal *EVAL(MalVal *ast, Env *env) { + while (TRUE) { + + if (!ast || mal_error) return NULL; + //g_print("EVAL: %s\n", _pr_str(ast,1)); + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (!ast || mal_error) return NULL; + + // apply list + //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); + ast = macroexpand(ast, env); + if (!ast || mal_error) return NULL; + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (_count(ast) == 0) { return ast; } + + int i, len; + MalVal *a0 = _nth(ast, 0); + if ((a0->type & MAL_SYMBOL) && + strcmp("def!", a0->val.string) == 0) { + //g_print("eval apply def!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("let*", a0->val.string) == 0) { + //g_print("eval apply let*\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2), + *key, *val; + assert_type(a1, MAL_LIST|MAL_VECTOR, + "let* bindings must be list or vector"); + len = _count(a1); + assert((len % 2) == 0, "odd number of let* bindings forms"); + Env *let_env = new_env(env, NULL, NULL); + for(i=0; ival.array, MalVal*, i); + val = g_array_index(a1->val.array, MalVal*, i+1); + assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); + env_set(let_env, key, EVAL(val, let_env)); + } + ast = a2; + env = let_env; + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quote", a0->val.string) == 0) { + //g_print("eval apply quote\n"); + return _nth(ast, 1); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quasiquoteexpand", a0->val.string) == 0) { + return quasiquote(_nth(ast, 1)); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quasiquote", a0->val.string) == 0) { + //g_print("eval apply quasiquote\n"); + MalVal *a1 = _nth(ast, 1); + ast = quasiquote(a1); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("defmacro!", a0->val.string) == 0) { + //g_print("eval apply defmacro!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + res->ismacro = TRUE; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("macroexpand", a0->val.string) == 0) { + //g_print("eval apply macroexpand\n"); + MalVal *a1 = _nth(ast, 1); + return macroexpand(a1, env); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("try*", a0->val.string) == 0) { + //g_print("eval apply try*\n"); + MalVal *a1 = _nth(ast, 1); + MalVal *res = EVAL(a1, env); + if (ast->val.array->len < 3) { + return &mal_nil; + } + MalVal *a2 = _nth(ast, 2); + if (!mal_error) { return res; } + MalVal *a20 = _nth(a2, 0); + if (strcmp("catch*", a20->val.string) == 0) { + MalVal *a21 = _nth(a2, 1); + MalVal *a22 = _nth(a2, 2); + Env *catch_env = new_env(env, + _listX(1, a21), + _listX(1, mal_error)); + //malval_free(mal_error); + mal_error = NULL; + res = EVAL(a22, catch_env); + return res; + } else { + return &mal_nil; + } + } else if ((a0->type & MAL_SYMBOL) && + strcmp("do", a0->val.string) == 0) { + //g_print("eval apply do\n"); + eval_ast(_slice(ast, 1, _count(ast)-1), env); + ast = _last(ast); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("if", a0->val.string) == 0) { + //g_print("eval apply if\n"); + MalVal *a1 = _nth(ast, 1); + MalVal *cond = EVAL(a1, env); + if (!cond || mal_error) return NULL; + if (cond->type & (MAL_FALSE|MAL_NIL)) { + // eval false slot form + if (ast->val.array->len > 3) { + ast = _nth(ast, 3); + } else { + return &mal_nil; + } + } else { + // eval true slot form + ast = _nth(ast, 2); + } + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("fn*", a0->val.string) == 0) { + //g_print("eval apply fn*\n"); + MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); + mf->ismacro = FALSE; + mf->val.func.evaluator = EVAL; + mf->val.func.args = _nth(ast, 1); + mf->val.func.body = _nth(ast, 2); + mf->val.func.env = env; + return mf; + } else { + //g_print("eval apply\n"); + MalVal *el = eval_ast(ast, env); + if (!el || mal_error) { return NULL; } + MalVal *f = _first(el), + *args = _rest(el); + assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, + "cannot apply '%s'", _pr_str(f,1)); + if (f->type & MAL_FUNCTION_MAL) { + ast = f->val.func.body; + env = new_env(f->val.func.env, f->val.func.args, args); + // Continue loop + } else { + return _apply(f, args); + } + } + + } // TCO while loop +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(Env *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +// Setup the initial REPL environment +Env *repl_env; + +MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } + +void init_repl_env(int argc, char *argv[]) { + repl_env = new_env(NULL, NULL, NULL); + + // core.c: defined using C + int i; + for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { + env_set(repl_env, + malval_new_symbol(core_ns[i].name), + malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); + } + env_set(repl_env, + malval_new_symbol("eval"), + malval_new_function((void*(*)(void *))do_eval, 1)); + + MalVal *_argv = _listX(0); + for (i=2; i < argc; i++) { + MalVal *arg = malval_new_string(argv[i]); + g_array_append_val(_argv->val.array, arg); + } + env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "", + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + RE(repl_env, "", "(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)))))))"); +} + +int main(int argc, char *argv[]) +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt and environment + snprintf(prompt, sizeof(prompt), "user> "); + init_repl_env(argc, argv); + + if (argc > 1) { + char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); + RE(repl_env, "", cmd); + return 0; + } + + // repl loop + for(;;) { + exp = RE(repl_env, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/stepA_mal.c b/impls/c/stepA_mal.c index 75051170f3..e977670719 100644 --- a/impls/c/stepA_mal.c +++ b/impls/c/stepA_mal.c @@ -1,379 +1,379 @@ -#include -#include -#include -#include - -#include "types.h" -#include "readline.h" -#include "reader.h" -#include "core.h" -#include "interop.h" - -// Declarations -MalVal *EVAL(MalVal *ast, Env *env); -MalVal *quasiquote(MalVal *ast); -MalVal *macroexpand(MalVal *ast, Env *env); - -// read -MalVal *READ(char prompt[], char *str) { - char *line; - MalVal *ast; - if (str) { - line = str; - } else { - line = _readline(prompt); - if (!line) { - _error("EOF"); - return NULL; - } - } - ast = read_str(line); - if (!str) { MAL_GC_FREE(line); } - return ast; -} - -// eval -int starts_with(MalVal *ast, const char *sym) { - if (ast->type != MAL_LIST) - return 0; - const MalVal * const a0 = _first(ast); - return (a0->type & MAL_SYMBOL) && ! strcmp(sym, a0->val.string); -} - -MalVal *qq_iter(GArray *xs) { - MalVal *acc = _listX(0); - int i; - for (i=xs->len-1; 0<=i; i--) { - MalVal * const elt = g_array_index(xs, MalVal*, i); - if (starts_with(elt, "splice-unquote")) - acc = _listX(3, malval_new_symbol("concat"), _nth(elt, 1), acc); - else - acc = _listX(3, malval_new_symbol("cons"), quasiquote(elt), acc); - } - return acc; -} - -MalVal *quasiquote(MalVal *ast) { - switch (ast->type) { - case MAL_LIST: - if (starts_with(ast, "unquote")) - return _nth(ast, 1); - else - return qq_iter(ast->val.array); - case MAL_VECTOR: - return _listX(2, malval_new_symbol("vec"), qq_iter(ast->val.array)); - case MAL_HASH_MAP: - case MAL_SYMBOL: - return _listX(2, malval_new_symbol("quote"), ast); - default: - return ast; - } -} - -int is_macro_call(MalVal *ast, Env *env) { - if (!ast || ast->type != MAL_LIST || _count(ast) == 0) { return 0; } - MalVal *a0 = _nth(ast, 0); - return (a0->type & MAL_SYMBOL) && - env_find(env, a0) && - env_get(env, a0)->ismacro; -} - -MalVal *macroexpand(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - while (is_macro_call(ast, env)) { - MalVal *a0 = _nth(ast, 0); - MalVal *mac = env_get(env, a0); - // TODO: this is weird and limits it to 20. FIXME - ast = _apply(mac, _rest(ast)); - } - return ast; -} - -MalVal *eval_ast(MalVal *ast, Env *env) { - if (!ast || mal_error) return NULL; - if (ast->type == MAL_SYMBOL) { - //g_print("EVAL symbol: %s\n", ast->val.string); - return env_get(env, ast); - } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { - //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); - MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); - if (!el || mal_error) return NULL; - el->type = ast->type; - return el; - } else if (ast->type == MAL_HASH_MAP) { - //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); - GHashTableIter iter; - gpointer key, value; - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - _count(ast))); - g_hash_table_iter_init (&iter, ast->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - MalVal *kname = malval_new_string((char *)key); - g_array_append_val(seq->val.array, kname); - MalVal *new_val = EVAL((MalVal *)value, env); - g_array_append_val(seq->val.array, new_val); - } - return _hash_map(seq); - } else { - //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); - return ast; - } -} - -MalVal *EVAL(MalVal *ast, Env *env) { - while (TRUE) { - - if (!ast || mal_error) return NULL; - //g_print("EVAL: %s\n", _pr_str(ast,1)); - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (!ast || mal_error) return NULL; - - // apply list - //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); - ast = macroexpand(ast, env); - if (!ast || mal_error) return NULL; - if (ast->type != MAL_LIST) { - return eval_ast(ast, env); - } - if (_count(ast) == 0) { return ast; } - - int i, len; - MalVal *a0 = _nth(ast, 0); - if ((a0->type & MAL_SYMBOL) && - strcmp("def!", a0->val.string) == 0) { - //g_print("eval apply def!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("let*", a0->val.string) == 0) { - //g_print("eval apply let*\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2), - *key, *val; - assert_type(a1, MAL_LIST|MAL_VECTOR, - "let* bindings must be list or vector"); - len = _count(a1); - assert((len % 2) == 0, "odd number of let* bindings forms"); - Env *let_env = new_env(env, NULL, NULL); - for(i=0; ival.array, MalVal*, i); - val = g_array_index(a1->val.array, MalVal*, i+1); - assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); - env_set(let_env, key, EVAL(val, let_env)); - } - ast = a2; - env = let_env; - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quote", a0->val.string) == 0) { - //g_print("eval apply quote\n"); - return _nth(ast, 1); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quasiquoteexpand", a0->val.string) == 0) { - return quasiquote(_nth(ast, 1)); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("quasiquote", a0->val.string) == 0) { - //g_print("eval apply quasiquote\n"); - MalVal *a1 = _nth(ast, 1); - ast = quasiquote(a1); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("defmacro!", a0->val.string) == 0) { - //g_print("eval apply defmacro!\n"); - MalVal *a1 = _nth(ast, 1), - *a2 = _nth(ast, 2); - MalVal *res = EVAL(a2, env); - if (mal_error) return NULL; - res->ismacro = TRUE; - env_set(env, a1, res); - return res; - } else if ((a0->type & MAL_SYMBOL) && - strcmp("macroexpand", a0->val.string) == 0) { - //g_print("eval apply macroexpand\n"); - MalVal *a1 = _nth(ast, 1); - return macroexpand(a1, env); - } else if ((a0->type & MAL_SYMBOL) && - strcmp(".", a0->val.string) == 0) { - //g_print("eval apply .\n"); - MalVal *el = eval_ast(_slice(ast, 1, _count(ast)), env); - return invoke_native(el); - } else if ((a0->type & MAL_SYMBOL) && - strcmp("try*", a0->val.string) == 0) { - //g_print("eval apply try*\n"); - MalVal *a1 = _nth(ast, 1); - MalVal *res = EVAL(a1, env); - if (ast->val.array->len < 3) { - return &mal_nil; - } - MalVal *a2 = _nth(ast, 2); - if (!mal_error) { return res; } - MalVal *a20 = _nth(a2, 0); - if (strcmp("catch*", a20->val.string) == 0) { - MalVal *a21 = _nth(a2, 1); - MalVal *a22 = _nth(a2, 2); - Env *catch_env = new_env(env, - _listX(1, a21), - _listX(1, mal_error)); - //malval_free(mal_error); - mal_error = NULL; - res = EVAL(a22, catch_env); - return res; - } else { - return &mal_nil; - } - } else if ((a0->type & MAL_SYMBOL) && - strcmp("do", a0->val.string) == 0) { - //g_print("eval apply do\n"); - eval_ast(_slice(ast, 1, _count(ast)-1), env); - ast = _last(ast); - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("if", a0->val.string) == 0) { - //g_print("eval apply if\n"); - MalVal *a1 = _nth(ast, 1); - MalVal *cond = EVAL(a1, env); - if (!cond || mal_error) return NULL; - if (cond->type & (MAL_FALSE|MAL_NIL)) { - // eval false slot form - if (ast->val.array->len > 3) { - ast = _nth(ast, 3); - } else { - return &mal_nil; - } - } else { - // eval true slot form - ast = _nth(ast, 2); - } - // Continue loop - } else if ((a0->type & MAL_SYMBOL) && - strcmp("fn*", a0->val.string) == 0) { - //g_print("eval apply fn*\n"); - MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); - mf->ismacro = FALSE; - mf->val.func.evaluator = EVAL; - mf->val.func.args = _nth(ast, 1); - mf->val.func.body = _nth(ast, 2); - mf->val.func.env = env; - return mf; - } else { - //g_print("eval apply\n"); - MalVal *el = eval_ast(ast, env); - if (!el || mal_error) { return NULL; } - MalVal *f = _first(el), - *args = _rest(el); - assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, - "cannot apply '%s'", _pr_str(f,1)); - if (f->type & MAL_FUNCTION_MAL) { - ast = f->val.func.body; - env = new_env(f->val.func.env, f->val.func.args, args); - // Continue loop - } else { - return _apply(f, args); - } - } - - } // TCO while loop -} - -// print -char *PRINT(MalVal *exp) { - if (mal_error) { - return NULL; - } - return _pr_str(exp,1); -} - -// repl - -// read and eval -MalVal *RE(Env *env, char *prompt, char *str) { - MalVal *ast, *exp; - ast = READ(prompt, str); - if (!ast || mal_error) return NULL; - exp = EVAL(ast, env); - if (ast != exp) { - malval_free(ast); // Free input structure - } - return exp; -} - -// Setup the initial REPL environment -Env *repl_env; - -MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } - -void init_repl_env(int argc, char *argv[]) { - repl_env = new_env(NULL, NULL, NULL); - - // core.c: defined using C - int i; - for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { - env_set(repl_env, - malval_new_symbol(core_ns[i].name), - malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); - } - env_set(repl_env, - malval_new_symbol("eval"), - malval_new_function((void*(*)(void *))do_eval, 1)); - - MalVal *_argv = _listX(0); - for (i=2; i < argc; i++) { - MalVal *arg = malval_new_string(argv[i]); - g_array_append_val(_argv->val.array, arg); - } - env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE(repl_env, "", "(def! *host-language* \"c\")"); - RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "", - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - RE(repl_env, "", "(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)))))))"); -} - -int main(int argc, char *argv[]) -{ - MalVal *exp; - char *output; - char prompt[100]; - - MAL_GC_SETUP(); - - // Set the initial prompt and environment - snprintf(prompt, sizeof(prompt), "user> "); - init_repl_env(argc, argv); - - if (argc > 1) { - char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); - RE(repl_env, "", cmd); - return 0; - } - - // repl loop - RE(repl_env, "", "(println (str \"Mal [\" *host-language* \"]\"))"); - for(;;) { - exp = RE(repl_env, prompt, NULL); - if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { - return 0; - } - output = PRINT(exp); - - if (mal_error) { - fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); - malval_free(mal_error); - mal_error = NULL; - } else if (output) { - puts(output); - MAL_GC_FREE(output); // Free output string - } - - //malval_free(exp); // Free evaluated expression - } -} +#include +#include +#include +#include + +#include "types.h" +#include "readline.h" +#include "reader.h" +#include "core.h" +#include "interop.h" + +// Declarations +MalVal *EVAL(MalVal *ast, Env *env); +MalVal *quasiquote(MalVal *ast); +MalVal *macroexpand(MalVal *ast, Env *env); + +// read +MalVal *READ(char prompt[], char *str) { + char *line; + MalVal *ast; + if (str) { + line = str; + } else { + line = _readline(prompt); + if (!line) { + _error("EOF"); + return NULL; + } + } + ast = read_str(line); + if (!str) { MAL_GC_FREE(line); } + return ast; +} + +// eval +int starts_with(MalVal *ast, const char *sym) { + if (ast->type != MAL_LIST) + return 0; + const MalVal * const a0 = _first(ast); + return (a0->type & MAL_SYMBOL) && ! strcmp(sym, a0->val.string); +} + +MalVal *qq_iter(GArray *xs) { + MalVal *acc = _listX(0); + int i; + for (i=xs->len-1; 0<=i; i--) { + MalVal * const elt = g_array_index(xs, MalVal*, i); + if (starts_with(elt, "splice-unquote")) + acc = _listX(3, malval_new_symbol("concat"), _nth(elt, 1), acc); + else + acc = _listX(3, malval_new_symbol("cons"), quasiquote(elt), acc); + } + return acc; +} + +MalVal *quasiquote(MalVal *ast) { + switch (ast->type) { + case MAL_LIST: + if (starts_with(ast, "unquote")) + return _nth(ast, 1); + else + return qq_iter(ast->val.array); + case MAL_VECTOR: + return _listX(2, malval_new_symbol("vec"), qq_iter(ast->val.array)); + case MAL_HASH_MAP: + case MAL_SYMBOL: + return _listX(2, malval_new_symbol("quote"), ast); + default: + return ast; + } +} + +int is_macro_call(MalVal *ast, Env *env) { + if (!ast || ast->type != MAL_LIST || _count(ast) == 0) { return 0; } + MalVal *a0 = _nth(ast, 0); + return (a0->type & MAL_SYMBOL) && + env_find(env, a0) && + env_get(env, a0)->ismacro; +} + +MalVal *macroexpand(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + while (is_macro_call(ast, env)) { + MalVal *a0 = _nth(ast, 0); + MalVal *mac = env_get(env, a0); + // TODO: this is weird and limits it to 20. FIXME + ast = _apply(mac, _rest(ast)); + } + return ast; +} + +MalVal *eval_ast(MalVal *ast, Env *env) { + if (!ast || mal_error) return NULL; + if (ast->type == MAL_SYMBOL) { + //g_print("EVAL symbol: %s\n", ast->val.string); + return env_get(env, ast); + } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) { + //g_print("EVAL sequential: %s\n", _pr_str(ast,1)); + MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env); + if (!el || mal_error) return NULL; + el->type = ast->type; + return el; + } else if (ast->type == MAL_HASH_MAP) { + //g_print("EVAL hash_map: %s\n", _pr_str(ast,1)); + GHashTableIter iter; + gpointer key, value; + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + _count(ast))); + g_hash_table_iter_init (&iter, ast->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + MalVal *kname = malval_new_string((char *)key); + g_array_append_val(seq->val.array, kname); + MalVal *new_val = EVAL((MalVal *)value, env); + g_array_append_val(seq->val.array, new_val); + } + return _hash_map(seq); + } else { + //g_print("EVAL scalar: %s\n", _pr_str(ast,1)); + return ast; + } +} + +MalVal *EVAL(MalVal *ast, Env *env) { + while (TRUE) { + + if (!ast || mal_error) return NULL; + //g_print("EVAL: %s\n", _pr_str(ast,1)); + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (!ast || mal_error) return NULL; + + // apply list + //g_print("EVAL apply list: %s\n", _pr_str(ast,1)); + ast = macroexpand(ast, env); + if (!ast || mal_error) return NULL; + if (ast->type != MAL_LIST) { + return eval_ast(ast, env); + } + if (_count(ast) == 0) { return ast; } + + int i, len; + MalVal *a0 = _nth(ast, 0); + if ((a0->type & MAL_SYMBOL) && + strcmp("def!", a0->val.string) == 0) { + //g_print("eval apply def!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("let*", a0->val.string) == 0) { + //g_print("eval apply let*\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2), + *key, *val; + assert_type(a1, MAL_LIST|MAL_VECTOR, + "let* bindings must be list or vector"); + len = _count(a1); + assert((len % 2) == 0, "odd number of let* bindings forms"); + Env *let_env = new_env(env, NULL, NULL); + for(i=0; ival.array, MalVal*, i); + val = g_array_index(a1->val.array, MalVal*, i+1); + assert_type(key, MAL_SYMBOL, "let* bind to non-symbol"); + env_set(let_env, key, EVAL(val, let_env)); + } + ast = a2; + env = let_env; + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quote", a0->val.string) == 0) { + //g_print("eval apply quote\n"); + return _nth(ast, 1); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quasiquoteexpand", a0->val.string) == 0) { + return quasiquote(_nth(ast, 1)); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("quasiquote", a0->val.string) == 0) { + //g_print("eval apply quasiquote\n"); + MalVal *a1 = _nth(ast, 1); + ast = quasiquote(a1); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("defmacro!", a0->val.string) == 0) { + //g_print("eval apply defmacro!\n"); + MalVal *a1 = _nth(ast, 1), + *a2 = _nth(ast, 2); + MalVal *res = EVAL(a2, env); + if (mal_error) return NULL; + res->ismacro = TRUE; + env_set(env, a1, res); + return res; + } else if ((a0->type & MAL_SYMBOL) && + strcmp("macroexpand", a0->val.string) == 0) { + //g_print("eval apply macroexpand\n"); + MalVal *a1 = _nth(ast, 1); + return macroexpand(a1, env); + } else if ((a0->type & MAL_SYMBOL) && + strcmp(".", a0->val.string) == 0) { + //g_print("eval apply .\n"); + MalVal *el = eval_ast(_slice(ast, 1, _count(ast)), env); + return invoke_native(el); + } else if ((a0->type & MAL_SYMBOL) && + strcmp("try*", a0->val.string) == 0) { + //g_print("eval apply try*\n"); + MalVal *a1 = _nth(ast, 1); + MalVal *res = EVAL(a1, env); + if (ast->val.array->len < 3) { + return &mal_nil; + } + MalVal *a2 = _nth(ast, 2); + if (!mal_error) { return res; } + MalVal *a20 = _nth(a2, 0); + if (strcmp("catch*", a20->val.string) == 0) { + MalVal *a21 = _nth(a2, 1); + MalVal *a22 = _nth(a2, 2); + Env *catch_env = new_env(env, + _listX(1, a21), + _listX(1, mal_error)); + //malval_free(mal_error); + mal_error = NULL; + res = EVAL(a22, catch_env); + return res; + } else { + return &mal_nil; + } + } else if ((a0->type & MAL_SYMBOL) && + strcmp("do", a0->val.string) == 0) { + //g_print("eval apply do\n"); + eval_ast(_slice(ast, 1, _count(ast)-1), env); + ast = _last(ast); + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("if", a0->val.string) == 0) { + //g_print("eval apply if\n"); + MalVal *a1 = _nth(ast, 1); + MalVal *cond = EVAL(a1, env); + if (!cond || mal_error) return NULL; + if (cond->type & (MAL_FALSE|MAL_NIL)) { + // eval false slot form + if (ast->val.array->len > 3) { + ast = _nth(ast, 3); + } else { + return &mal_nil; + } + } else { + // eval true slot form + ast = _nth(ast, 2); + } + // Continue loop + } else if ((a0->type & MAL_SYMBOL) && + strcmp("fn*", a0->val.string) == 0) { + //g_print("eval apply fn*\n"); + MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL); + mf->ismacro = FALSE; + mf->val.func.evaluator = EVAL; + mf->val.func.args = _nth(ast, 1); + mf->val.func.body = _nth(ast, 2); + mf->val.func.env = env; + return mf; + } else { + //g_print("eval apply\n"); + MalVal *el = eval_ast(ast, env); + if (!el || mal_error) { return NULL; } + MalVal *f = _first(el), + *args = _rest(el); + assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, + "cannot apply '%s'", _pr_str(f,1)); + if (f->type & MAL_FUNCTION_MAL) { + ast = f->val.func.body; + env = new_env(f->val.func.env, f->val.func.args, args); + // Continue loop + } else { + return _apply(f, args); + } + } + + } // TCO while loop +} + +// print +char *PRINT(MalVal *exp) { + if (mal_error) { + return NULL; + } + return _pr_str(exp,1); +} + +// repl + +// read and eval +MalVal *RE(Env *env, char *prompt, char *str) { + MalVal *ast, *exp; + ast = READ(prompt, str); + if (!ast || mal_error) return NULL; + exp = EVAL(ast, env); + if (ast != exp) { + malval_free(ast); // Free input structure + } + return exp; +} + +// Setup the initial REPL environment +Env *repl_env; + +MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); } + +void init_repl_env(int argc, char *argv[]) { + repl_env = new_env(NULL, NULL, NULL); + + // core.c: defined using C + int i; + for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) { + env_set(repl_env, + malval_new_symbol(core_ns[i].name), + malval_new_function(core_ns[i].func, core_ns[i].arg_cnt)); + } + env_set(repl_env, + malval_new_symbol("eval"), + malval_new_function((void*(*)(void *))do_eval, 1)); + + MalVal *_argv = _listX(0); + for (i=2; i < argc; i++) { + MalVal *arg = malval_new_string(argv[i]); + g_array_append_val(_argv->val.array, arg); + } + env_set(repl_env, malval_new_symbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE(repl_env, "", "(def! *host-language* \"c\")"); + RE(repl_env, "", "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "", + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + RE(repl_env, "", "(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)))))))"); +} + +int main(int argc, char *argv[]) +{ + MalVal *exp; + char *output; + char prompt[100]; + + MAL_GC_SETUP(); + + // Set the initial prompt and environment + snprintf(prompt, sizeof(prompt), "user> "); + init_repl_env(argc, argv); + + if (argc > 1) { + char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]); + RE(repl_env, "", cmd); + return 0; + } + + // repl loop + RE(repl_env, "", "(println (str \"Mal [\" *host-language* \"]\"))"); + for(;;) { + exp = RE(repl_env, prompt, NULL); + if (mal_error && strcmp("EOF", mal_error->val.string) == 0) { + return 0; + } + output = PRINT(exp); + + if (mal_error) { + fprintf(stderr, "Error: %s\n", _pr_str(mal_error,1)); + malval_free(mal_error); + mal_error = NULL; + } else if (output) { + puts(output); + MAL_GC_FREE(output); // Free output string + } + + //malval_free(exp); // Free evaluated expression + } +} diff --git a/impls/c/tests/step5_tco.mal b/impls/c/tests/step5_tco.mal index be6a117a62..67bc88917e 100644 --- a/impls/c/tests/step5_tco.mal +++ b/impls/c/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; C: skipping non-TCO recursion -;; Reason: segfaults (unrecoverable) +;; C: skipping non-TCO recursion +;; Reason: segfaults (unrecoverable) diff --git a/impls/c/tests/stepA_mal.mal b/impls/c/tests/stepA_mal.mal index 657e3e73e2..20169f53fc 100644 --- a/impls/c/tests/stepA_mal.mal +++ b/impls/c/tests/stepA_mal.mal @@ -1,23 +1,23 @@ - -;; Testing FFI of "strlen" -(. nil "int32" "strlen" "string" "abcde") -;=>5 -(. nil "int32" "strlen" "string" "") -;=>0 - -;; Testing FFI of "strcmp" - -(. nil "int32" "strcmp" "string" "abc" "string" "abcA") -;=>-65 -(. nil "int32" "strcmp" "string" "abcA" "string" "abc") -;=>65 -(. nil "int32" "strcmp" "string" "abc" "string" "abc") -;=>0 - - -;; Testing FFI of "pow" (libm.so) - -(. "libm.so" "double" "pow" "double" 2.0 "double" 3.0) -;=>8.000000 -(. "libm.so" "double" "pow" "double" 3.0 "double" 2.0) -;=>9.000000 + +;; Testing FFI of "strlen" +(. nil "int32" "strlen" "string" "abcde") +;=>5 +(. nil "int32" "strlen" "string" "") +;=>0 + +;; Testing FFI of "strcmp" + +(. nil "int32" "strcmp" "string" "abc" "string" "abcA") +;=>-65 +(. nil "int32" "strcmp" "string" "abcA" "string" "abc") +;=>65 +(. nil "int32" "strcmp" "string" "abc" "string" "abc") +;=>0 + + +;; Testing FFI of "pow" (libm.so) + +(. "libm.so" "double" "pow" "double" 2.0 "double" 3.0) +;=>8.000000 +(. "libm.so" "double" "pow" "double" 3.0 "double" 2.0) +;=>9.000000 diff --git a/impls/c/types.c b/impls/c/types.c index 2798a1f4e4..cf84dc40af 100644 --- a/impls/c/types.c +++ b/impls/c/types.c @@ -1,520 +1,520 @@ -#include -#include -#include -#include -#include "types.h" -#include "printer.h" - -#ifdef USE_GC -void nop_free(void* ptr) { - (void)ptr; // Unused argument -} - -static GMemVTable gc_gmem_vtable = { - .malloc = GC_malloc, - .realloc = GC_realloc, - .free = nop_free, - .calloc = NULL, - .try_malloc = NULL, - .try_realloc = NULL -}; - -void GC_setup() { - GC_INIT(); - setenv("G_SLICE", "always-malloc", 1); - g_mem_gc_friendly = TRUE; - g_mem_set_vtable(&gc_gmem_vtable); -} - -char* GC_strdup(const char *src) { - if (!src) { - return NULL; - } - char* dst = (char*)MAL_GC_MALLOC(strlen(src) + 1); - strcpy(dst, src); - return dst; -} -#endif - - -// Errors/Exceptions - -MalVal *mal_error = NULL; // WARNGIN: global state -void _error(const char *fmt, ...) { - va_list args; - va_start(args, fmt); - mal_error = malval_new_string(g_strdup_vprintf(fmt, args)); -} - -// Constant atomic values - -MalVal mal_nil = {MAL_NIL, NULL, {0}, 0}; -MalVal mal_true = {MAL_TRUE, NULL, {0}, 0}; -MalVal mal_false = {MAL_FALSE, NULL, {0}, 0}; - - -// General Functions - -// Print a hash table -#include -void g_hash_table_print(GHashTable *hash_table) { - GHashTableIter iter; - gpointer key, value; - - g_hash_table_iter_init (&iter, hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - g_print ("%s/%p ", (const char *) key, (void *) value); - //g_print ("%s ", (const char *) key); - } -} - -GHashTable *g_hash_table_copy(GHashTable *src_table) { - GHashTable *new_table = g_hash_table_new(g_str_hash, g_str_equal); - GHashTableIter iter; - gpointer key, value; - - g_hash_table_iter_init (&iter, src_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - g_hash_table_insert(new_table, key, value); - } - return new_table; -} - -int min(int a, int b) { return a < b ? a : b; } -int max(int a, int b) { return a > b ? a : b; } - -int _count(MalVal *obj) { - switch (obj->type) { - case MAL_NIL: return 0; - case MAL_LIST: return obj->val.array->len; - case MAL_VECTOR: return obj->val.array->len; - case MAL_HASH_MAP: return g_hash_table_size(obj->val.hash_table); - case MAL_STRING: return strlen(obj->val.string); - default: - _error("count unsupported for type %d\n", obj->type); - return 0; - } -} - -// Allocate a malval and set its type and value -MalVal *malval_new(MalType type, MalVal *metadata) { - MalVal *mv = (MalVal*)MAL_GC_MALLOC(sizeof(MalVal)); - mv->type = type; - mv->metadata = metadata; - return mv; -} - -void malval_free(MalVal *mv) { - // TODO: free collection items - if (!(mv->type & (MAL_NIL|MAL_TRUE|MAL_FALSE))) { - MAL_GC_FREE(mv); - } -} - -MalVal *malval_new_integer(gint64 val) { - MalVal *mv = malval_new(MAL_INTEGER, NULL); - mv->val.intnum = val; - return mv; -} - -MalVal *malval_new_float(gdouble val) { - MalVal *mv = malval_new(MAL_FLOAT, NULL); - mv->val.floatnum = val; - return mv; -} - -MalVal *malval_new_string(char *val) { - MalVal *mv = malval_new(MAL_STRING, NULL); - mv->val.string = val; - return mv; -} - -MalVal *malval_new_symbol(char *val) { - MalVal *mv = malval_new(MAL_SYMBOL, NULL); - mv->val.string = val; - return mv; -} - -MalVal *malval_new_keyword(char *val) { - MalVal *mv = malval_new(MAL_STRING, NULL); - mv->val.string = g_strdup_printf("\x7f%s", val); - return mv; -} - -MalVal *malval_new_list(MalType type, GArray *val) { - MalVal *mv = malval_new(type, NULL); - mv->val.array = val; - return mv; -} - -MalVal *malval_new_hash_map(GHashTable *val) { - MalVal *mv = malval_new(MAL_HASH_MAP, NULL); - mv->val.hash_table = val; - return mv; -} - -MalVal *malval_new_atom(MalVal *val) { - MalVal *mv = malval_new(MAL_ATOM, NULL); - mv->val.atom_val = val; - return mv; -} - - -MalVal *malval_new_function(void *(*func)(void *), int arg_cnt) { - MalVal *mv = malval_new(MAL_FUNCTION_C, NULL); - mv->func_arg_cnt = arg_cnt; - assert(mv->func_arg_cnt <= 20, - "native function restricted to 20 args (%d given)", - mv->func_arg_cnt); - mv->ismacro = FALSE; - switch (arg_cnt) { - case -1: mv->val.f1 = (void *(*)(void*))func; break; - case 0: mv->val.f0 = (void *(*)())func; break; - case 1: mv->val.f1 = (void *(*)(void*))func; break; - case 2: mv->val.f2 = (void *(*)(void*,void*))func; break; - case 3: mv->val.f3 = (void *(*)(void*,void*,void*))func; break; - case 4: mv->val.f4 = (void *(*)(void*,void*,void*,void*))func; break; - case 5: mv->val.f5 = (void *(*)(void*,void*,void*,void*,void*))func; break; - case 6: mv->val.f6 = (void *(*)(void*,void*,void*,void*,void*, - void*))func; break; - case 7: mv->val.f7 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*))func; break; - case 8: mv->val.f8 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*))func; break; - case 9: mv->val.f9 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*))func; break; - case 10: mv->val.f10 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*))func; break; - case 11: mv->val.f11 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*))func; break; - case 12: mv->val.f12 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*))func; break; - case 13: mv->val.f13 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*))func; break; - case 14: mv->val.f14 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*,void*))func; break; - case 15: mv->val.f15 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*))func; break; - case 16: mv->val.f16 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*))func; break; - case 17: mv->val.f17 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*))func; break; - case 18: mv->val.f18 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*))func; break; - case 19: mv->val.f19 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*,void*))func; break; - case 20: mv->val.f20 = (void *(*)(void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*))func; break; - } - return mv; -} - -MalVal *_apply(MalVal *f, MalVal *args) { - MalVal *res; - assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, - "Cannot invoke %s", _pr_str(f,1)); - if (f->type & MAL_FUNCTION_MAL) { - Env *fn_env = new_env(f->val.func.env, f->val.func.args, args); - res = f->val.func.evaluator(f->val.func.body, fn_env); - return res; - } else { - MalVal *a = args; - assert((f->func_arg_cnt == -1) || - (f->func_arg_cnt == _count(args)), - "Length of formal params (%d) does not match actual parameters (%d)", - f->func_arg_cnt, _count(args)); - switch (f->func_arg_cnt) { - case -1: res=f->val.f1 (a); break; - case 0: res=f->val.f0 (); break; - case 1: res=f->val.f1 (_nth(a,0)); break; - case 2: res=f->val.f2 (_nth(a,0),_nth(a,1)); break; - case 3: res=f->val.f3 (_nth(a,0),_nth(a,1),_nth(a,2)); break; - case 4: res=f->val.f4 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3)); break; - case 5: res=f->val.f5 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4)); break; - case 6: res=f->val.f6 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5)); break; - case 7: res=f->val.f7 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6)); break; - case 8: res=f->val.f8 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7)); break; - case 9: res=f->val.f9 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8)); break; - case 10: res=f->val.f10(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9)); break; - case 11: res=f->val.f11(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10)); break; - case 12: res=f->val.f12(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10),_nth(a,11)); break; - case 13: res=f->val.f13(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10),_nth(a,11),_nth(a,12)); break; - case 14: res=f->val.f14(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13)); break; - case 15: res=f->val.f15(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14)); break; - case 16: res=f->val.f16(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), - _nth(a,15)); break; - case 17: res=f->val.f17(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), - _nth(a,15),_nth(a,16)); break; - case 18: res=f->val.f18(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), - _nth(a,15),_nth(a,16),_nth(a,17)); break; - case 19: res=f->val.f19(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), - _nth(a,15),_nth(a,16),_nth(a,17),_nth(a,18)); break; - case 20: res=f->val.f20(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), - _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), - _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), - _nth(a,15),_nth(a,16),_nth(a,17),_nth(a,18),_nth(a,19)); break; - } - return res; - } -} - - -int _equal_Q(MalVal *a, MalVal *b) { - GHashTableIter iter; - gpointer key, value; - - if (a == NULL || b == NULL) { return FALSE; } - - // If types are the same or both are sequential then they might be equal - if (!((a->type == b->type) || - (_sequential_Q(a) && _sequential_Q(b)))) { - return FALSE; - } - switch (a->type) { - case MAL_NIL: - case MAL_TRUE: - case MAL_FALSE: - return a->type == b->type; - case MAL_INTEGER: - return a->val.intnum == b->val.intnum; - case MAL_FLOAT: - return a->val.floatnum == b->val.floatnum; - case MAL_SYMBOL: - case MAL_STRING: - if (strcmp(a->val.string, b->val.string) == 0) { - return TRUE; - } else { - return FALSE; - } - case MAL_LIST: - case MAL_VECTOR: - if (a->val.array->len != b->val.array->len) { - return FALSE; - } - int i; - for (i=0; ival.array->len; i++) { - if (! _equal_Q(g_array_index(a->val.array, MalVal*, i), - g_array_index(b->val.array, MalVal*, i))) { - return FALSE; - } - } - return TRUE; - case MAL_HASH_MAP: - if (g_hash_table_size(a->val.hash_table) != - g_hash_table_size(b->val.hash_table)) { - return FALSE; - } - g_hash_table_iter_init (&iter, a->val.hash_table); - while (g_hash_table_iter_next (&iter, &key, &value)) { - if (!g_hash_table_contains(b->val.hash_table, key)) { - return FALSE; - } - MalVal *aval = (MalVal *) g_hash_table_lookup(a->val.hash_table, key); - MalVal *bval = (MalVal *) g_hash_table_lookup(b->val.hash_table, key); - if (!_equal_Q(aval, bval)) { - return FALSE; - } - } - return TRUE; - case MAL_FUNCTION_C: - case MAL_FUNCTION_MAL: - return a->val.f0 == b->val.f0; - default: - _error("_equal_Q unsupported comparison type %d\n", a->type); - return FALSE; - } -} - - -// Lists -MalVal *_listX(int count, ...) { - MalVal *seq = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - count)); - MalVal *v; - va_list ap; - va_start(ap, count); - while (count-- > 0) { - v = va_arg(ap, MalVal*); - g_array_append_val(seq->val.array, v); - } - va_end(ap); - return seq; -} - -MalVal *_list(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "list called with invalid arguments"); - args->type = MAL_LIST; - return args; -} - -int _list_Q(MalVal *seq) { - return seq->type & MAL_LIST; -} - - -// Vectors -MalVal *_vector(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "vector called with invalid arguments"); - args->type = MAL_VECTOR; - return args; -} - -int _vector_Q(MalVal *seq) { - return seq->type & MAL_VECTOR; -} - - -// Hash maps -MalVal *_hash_map(MalVal *args) { - assert_type(args, MAL_LIST|MAL_VECTOR, - "hash-map called with non-sequential arguments"); - GHashTable *htable = g_hash_table_new(g_str_hash, g_str_equal); - MalVal *hm = malval_new_hash_map(htable); - return _assoc_BANG(hm, args); -} - -int _hash_map_Q(MalVal *seq) { - return seq->type & MAL_HASH_MAP; -} - -MalVal *_assoc_BANG(MalVal* hm, MalVal *args) { - assert((_count(args) % 2) == 0, - "odd number of parameters to assoc!"); - GHashTable *htable = hm->val.hash_table; - int i; - MalVal *k, *v; - for (i=0; i<_count(args); i+=2) { - k = g_array_index(args->val.array, MalVal*, i); - assert_type(k, MAL_STRING, - "assoc! called with non-string key"); - v = g_array_index(args->val.array, MalVal*, i+1); - g_hash_table_insert(htable, k->val.string, v); - } - return hm; -} - -MalVal *_dissoc_BANG(MalVal* hm, MalVal *args) { - GHashTable *htable = hm->val.hash_table; - int i; - MalVal *k, *v; - for (i=0; i<_count(args); i++) { - k = g_array_index(args->val.array, MalVal*, i); - assert_type(k, MAL_STRING, - "dissoc! called with non-string key"); - g_hash_table_remove(htable, k->val.string); - } - return hm; -} - - -// Atoms -int _atom_Q(MalVal *exp) { - return exp->type & MAL_ATOM; -} - - -// Sequence functions -MalVal *_slice(MalVal *seq, int start, int end) { - int i, new_len = max(0, min(end-start, - _count(seq)-start)); - GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), - new_len); - for (i=start; ival.array, MalVal*, i)); - } - return malval_new_list(MAL_LIST, new_arr); -} - - -int _sequential_Q(MalVal *seq) { - return seq->type & (MAL_LIST|MAL_VECTOR); -} - -MalVal *_nth(MalVal *seq, int idx) { - assert_type(seq, MAL_LIST|MAL_VECTOR, - "_nth called with non-sequential"); - if (idx >= _count(seq)) { - abort("nth: index out of range"); - } - return g_array_index(seq->val.array, MalVal*, idx); -} - -MalVal *_first(MalVal *seq) { - assert_type(seq, MAL_NIL|MAL_LIST|MAL_VECTOR, - "_first called with non-sequential"); - if (_count(seq) == 0) { - return &mal_nil; - } - return g_array_index(seq->val.array, MalVal*, 0); -} - -MalVal *_last(MalVal *seq) { - assert_type(seq, MAL_LIST|MAL_VECTOR, - "_last called with non-sequential"); - if (_count(seq) == 0) { - return &mal_nil; - } - return g_array_index(seq->val.array, MalVal*, _count(seq)-1); -} - - -MalVal *_rest(MalVal *seq) { - return _slice(seq, 1, _count(seq)); -} - - -MalVal *_map2(MalVal *(*func)(void*, void*), MalVal *lst, void *arg2) { - MalVal *e, *el; - assert_type(lst, MAL_LIST|MAL_VECTOR, - "_map called with non-sequential"); - int i, len = _count(lst); - el = malval_new_list(MAL_LIST, - g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), len)); - for (i=0; ival.array, MalVal*, i), arg2); - if (!e || mal_error) return NULL; - g_array_append_val(el->val.array, e); - } - return el; -} +#include +#include +#include +#include +#include "types.h" +#include "printer.h" + +#ifdef USE_GC +void nop_free(void* ptr) { + (void)ptr; // Unused argument +} + +static GMemVTable gc_gmem_vtable = { + .malloc = GC_malloc, + .realloc = GC_realloc, + .free = nop_free, + .calloc = NULL, + .try_malloc = NULL, + .try_realloc = NULL +}; + +void GC_setup() { + GC_INIT(); + setenv("G_SLICE", "always-malloc", 1); + g_mem_gc_friendly = TRUE; + g_mem_set_vtable(&gc_gmem_vtable); +} + +char* GC_strdup(const char *src) { + if (!src) { + return NULL; + } + char* dst = (char*)MAL_GC_MALLOC(strlen(src) + 1); + strcpy(dst, src); + return dst; +} +#endif + + +// Errors/Exceptions + +MalVal *mal_error = NULL; // WARNGIN: global state +void _error(const char *fmt, ...) { + va_list args; + va_start(args, fmt); + mal_error = malval_new_string(g_strdup_vprintf(fmt, args)); +} + +// Constant atomic values + +MalVal mal_nil = {MAL_NIL, NULL, {0}, 0}; +MalVal mal_true = {MAL_TRUE, NULL, {0}, 0}; +MalVal mal_false = {MAL_FALSE, NULL, {0}, 0}; + + +// General Functions + +// Print a hash table +#include +void g_hash_table_print(GHashTable *hash_table) { + GHashTableIter iter; + gpointer key, value; + + g_hash_table_iter_init (&iter, hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + g_print ("%s/%p ", (const char *) key, (void *) value); + //g_print ("%s ", (const char *) key); + } +} + +GHashTable *g_hash_table_copy(GHashTable *src_table) { + GHashTable *new_table = g_hash_table_new(g_str_hash, g_str_equal); + GHashTableIter iter; + gpointer key, value; + + g_hash_table_iter_init (&iter, src_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + g_hash_table_insert(new_table, key, value); + } + return new_table; +} + +int min(int a, int b) { return a < b ? a : b; } +int max(int a, int b) { return a > b ? a : b; } + +int _count(MalVal *obj) { + switch (obj->type) { + case MAL_NIL: return 0; + case MAL_LIST: return obj->val.array->len; + case MAL_VECTOR: return obj->val.array->len; + case MAL_HASH_MAP: return g_hash_table_size(obj->val.hash_table); + case MAL_STRING: return strlen(obj->val.string); + default: + _error("count unsupported for type %d\n", obj->type); + return 0; + } +} + +// Allocate a malval and set its type and value +MalVal *malval_new(MalType type, MalVal *metadata) { + MalVal *mv = (MalVal*)MAL_GC_MALLOC(sizeof(MalVal)); + mv->type = type; + mv->metadata = metadata; + return mv; +} + +void malval_free(MalVal *mv) { + // TODO: free collection items + if (!(mv->type & (MAL_NIL|MAL_TRUE|MAL_FALSE))) { + MAL_GC_FREE(mv); + } +} + +MalVal *malval_new_integer(gint64 val) { + MalVal *mv = malval_new(MAL_INTEGER, NULL); + mv->val.intnum = val; + return mv; +} + +MalVal *malval_new_float(gdouble val) { + MalVal *mv = malval_new(MAL_FLOAT, NULL); + mv->val.floatnum = val; + return mv; +} + +MalVal *malval_new_string(char *val) { + MalVal *mv = malval_new(MAL_STRING, NULL); + mv->val.string = val; + return mv; +} + +MalVal *malval_new_symbol(char *val) { + MalVal *mv = malval_new(MAL_SYMBOL, NULL); + mv->val.string = val; + return mv; +} + +MalVal *malval_new_keyword(char *val) { + MalVal *mv = malval_new(MAL_STRING, NULL); + mv->val.string = g_strdup_printf("\x7f%s", val); + return mv; +} + +MalVal *malval_new_list(MalType type, GArray *val) { + MalVal *mv = malval_new(type, NULL); + mv->val.array = val; + return mv; +} + +MalVal *malval_new_hash_map(GHashTable *val) { + MalVal *mv = malval_new(MAL_HASH_MAP, NULL); + mv->val.hash_table = val; + return mv; +} + +MalVal *malval_new_atom(MalVal *val) { + MalVal *mv = malval_new(MAL_ATOM, NULL); + mv->val.atom_val = val; + return mv; +} + + +MalVal *malval_new_function(void *(*func)(void *), int arg_cnt) { + MalVal *mv = malval_new(MAL_FUNCTION_C, NULL); + mv->func_arg_cnt = arg_cnt; + assert(mv->func_arg_cnt <= 20, + "native function restricted to 20 args (%d given)", + mv->func_arg_cnt); + mv->ismacro = FALSE; + switch (arg_cnt) { + case -1: mv->val.f1 = (void *(*)(void*))func; break; + case 0: mv->val.f0 = (void *(*)())func; break; + case 1: mv->val.f1 = (void *(*)(void*))func; break; + case 2: mv->val.f2 = (void *(*)(void*,void*))func; break; + case 3: mv->val.f3 = (void *(*)(void*,void*,void*))func; break; + case 4: mv->val.f4 = (void *(*)(void*,void*,void*,void*))func; break; + case 5: mv->val.f5 = (void *(*)(void*,void*,void*,void*,void*))func; break; + case 6: mv->val.f6 = (void *(*)(void*,void*,void*,void*,void*, + void*))func; break; + case 7: mv->val.f7 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*))func; break; + case 8: mv->val.f8 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*))func; break; + case 9: mv->val.f9 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*))func; break; + case 10: mv->val.f10 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*))func; break; + case 11: mv->val.f11 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*))func; break; + case 12: mv->val.f12 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*))func; break; + case 13: mv->val.f13 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*))func; break; + case 14: mv->val.f14 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*,void*))func; break; + case 15: mv->val.f15 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*))func; break; + case 16: mv->val.f16 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*))func; break; + case 17: mv->val.f17 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*))func; break; + case 18: mv->val.f18 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*))func; break; + case 19: mv->val.f19 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*,void*))func; break; + case 20: mv->val.f20 = (void *(*)(void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*))func; break; + } + return mv; +} + +MalVal *_apply(MalVal *f, MalVal *args) { + MalVal *res; + assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL, + "Cannot invoke %s", _pr_str(f,1)); + if (f->type & MAL_FUNCTION_MAL) { + Env *fn_env = new_env(f->val.func.env, f->val.func.args, args); + res = f->val.func.evaluator(f->val.func.body, fn_env); + return res; + } else { + MalVal *a = args; + assert((f->func_arg_cnt == -1) || + (f->func_arg_cnt == _count(args)), + "Length of formal params (%d) does not match actual parameters (%d)", + f->func_arg_cnt, _count(args)); + switch (f->func_arg_cnt) { + case -1: res=f->val.f1 (a); break; + case 0: res=f->val.f0 (); break; + case 1: res=f->val.f1 (_nth(a,0)); break; + case 2: res=f->val.f2 (_nth(a,0),_nth(a,1)); break; + case 3: res=f->val.f3 (_nth(a,0),_nth(a,1),_nth(a,2)); break; + case 4: res=f->val.f4 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3)); break; + case 5: res=f->val.f5 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4)); break; + case 6: res=f->val.f6 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5)); break; + case 7: res=f->val.f7 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6)); break; + case 8: res=f->val.f8 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7)); break; + case 9: res=f->val.f9 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8)); break; + case 10: res=f->val.f10(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9)); break; + case 11: res=f->val.f11(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10)); break; + case 12: res=f->val.f12(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10),_nth(a,11)); break; + case 13: res=f->val.f13(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10),_nth(a,11),_nth(a,12)); break; + case 14: res=f->val.f14(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13)); break; + case 15: res=f->val.f15(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14)); break; + case 16: res=f->val.f16(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), + _nth(a,15)); break; + case 17: res=f->val.f17(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), + _nth(a,15),_nth(a,16)); break; + case 18: res=f->val.f18(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), + _nth(a,15),_nth(a,16),_nth(a,17)); break; + case 19: res=f->val.f19(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), + _nth(a,15),_nth(a,16),_nth(a,17),_nth(a,18)); break; + case 20: res=f->val.f20(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4), + _nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9), + _nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14), + _nth(a,15),_nth(a,16),_nth(a,17),_nth(a,18),_nth(a,19)); break; + } + return res; + } +} + + +int _equal_Q(MalVal *a, MalVal *b) { + GHashTableIter iter; + gpointer key, value; + + if (a == NULL || b == NULL) { return FALSE; } + + // If types are the same or both are sequential then they might be equal + if (!((a->type == b->type) || + (_sequential_Q(a) && _sequential_Q(b)))) { + return FALSE; + } + switch (a->type) { + case MAL_NIL: + case MAL_TRUE: + case MAL_FALSE: + return a->type == b->type; + case MAL_INTEGER: + return a->val.intnum == b->val.intnum; + case MAL_FLOAT: + return a->val.floatnum == b->val.floatnum; + case MAL_SYMBOL: + case MAL_STRING: + if (strcmp(a->val.string, b->val.string) == 0) { + return TRUE; + } else { + return FALSE; + } + case MAL_LIST: + case MAL_VECTOR: + if (a->val.array->len != b->val.array->len) { + return FALSE; + } + int i; + for (i=0; ival.array->len; i++) { + if (! _equal_Q(g_array_index(a->val.array, MalVal*, i), + g_array_index(b->val.array, MalVal*, i))) { + return FALSE; + } + } + return TRUE; + case MAL_HASH_MAP: + if (g_hash_table_size(a->val.hash_table) != + g_hash_table_size(b->val.hash_table)) { + return FALSE; + } + g_hash_table_iter_init (&iter, a->val.hash_table); + while (g_hash_table_iter_next (&iter, &key, &value)) { + if (!g_hash_table_contains(b->val.hash_table, key)) { + return FALSE; + } + MalVal *aval = (MalVal *) g_hash_table_lookup(a->val.hash_table, key); + MalVal *bval = (MalVal *) g_hash_table_lookup(b->val.hash_table, key); + if (!_equal_Q(aval, bval)) { + return FALSE; + } + } + return TRUE; + case MAL_FUNCTION_C: + case MAL_FUNCTION_MAL: + return a->val.f0 == b->val.f0; + default: + _error("_equal_Q unsupported comparison type %d\n", a->type); + return FALSE; + } +} + + +// Lists +MalVal *_listX(int count, ...) { + MalVal *seq = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + count)); + MalVal *v; + va_list ap; + va_start(ap, count); + while (count-- > 0) { + v = va_arg(ap, MalVal*); + g_array_append_val(seq->val.array, v); + } + va_end(ap); + return seq; +} + +MalVal *_list(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "list called with invalid arguments"); + args->type = MAL_LIST; + return args; +} + +int _list_Q(MalVal *seq) { + return seq->type & MAL_LIST; +} + + +// Vectors +MalVal *_vector(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "vector called with invalid arguments"); + args->type = MAL_VECTOR; + return args; +} + +int _vector_Q(MalVal *seq) { + return seq->type & MAL_VECTOR; +} + + +// Hash maps +MalVal *_hash_map(MalVal *args) { + assert_type(args, MAL_LIST|MAL_VECTOR, + "hash-map called with non-sequential arguments"); + GHashTable *htable = g_hash_table_new(g_str_hash, g_str_equal); + MalVal *hm = malval_new_hash_map(htable); + return _assoc_BANG(hm, args); +} + +int _hash_map_Q(MalVal *seq) { + return seq->type & MAL_HASH_MAP; +} + +MalVal *_assoc_BANG(MalVal* hm, MalVal *args) { + assert((_count(args) % 2) == 0, + "odd number of parameters to assoc!"); + GHashTable *htable = hm->val.hash_table; + int i; + MalVal *k, *v; + for (i=0; i<_count(args); i+=2) { + k = g_array_index(args->val.array, MalVal*, i); + assert_type(k, MAL_STRING, + "assoc! called with non-string key"); + v = g_array_index(args->val.array, MalVal*, i+1); + g_hash_table_insert(htable, k->val.string, v); + } + return hm; +} + +MalVal *_dissoc_BANG(MalVal* hm, MalVal *args) { + GHashTable *htable = hm->val.hash_table; + int i; + MalVal *k, *v; + for (i=0; i<_count(args); i++) { + k = g_array_index(args->val.array, MalVal*, i); + assert_type(k, MAL_STRING, + "dissoc! called with non-string key"); + g_hash_table_remove(htable, k->val.string); + } + return hm; +} + + +// Atoms +int _atom_Q(MalVal *exp) { + return exp->type & MAL_ATOM; +} + + +// Sequence functions +MalVal *_slice(MalVal *seq, int start, int end) { + int i, new_len = max(0, min(end-start, + _count(seq)-start)); + GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), + new_len); + for (i=start; ival.array, MalVal*, i)); + } + return malval_new_list(MAL_LIST, new_arr); +} + + +int _sequential_Q(MalVal *seq) { + return seq->type & (MAL_LIST|MAL_VECTOR); +} + +MalVal *_nth(MalVal *seq, int idx) { + assert_type(seq, MAL_LIST|MAL_VECTOR, + "_nth called with non-sequential"); + if (idx >= _count(seq)) { + abort("nth: index out of range"); + } + return g_array_index(seq->val.array, MalVal*, idx); +} + +MalVal *_first(MalVal *seq) { + assert_type(seq, MAL_NIL|MAL_LIST|MAL_VECTOR, + "_first called with non-sequential"); + if (_count(seq) == 0) { + return &mal_nil; + } + return g_array_index(seq->val.array, MalVal*, 0); +} + +MalVal *_last(MalVal *seq) { + assert_type(seq, MAL_LIST|MAL_VECTOR, + "_last called with non-sequential"); + if (_count(seq) == 0) { + return &mal_nil; + } + return g_array_index(seq->val.array, MalVal*, _count(seq)-1); +} + + +MalVal *_rest(MalVal *seq) { + return _slice(seq, 1, _count(seq)); +} + + +MalVal *_map2(MalVal *(*func)(void*, void*), MalVal *lst, void *arg2) { + MalVal *e, *el; + assert_type(lst, MAL_LIST|MAL_VECTOR, + "_map called with non-sequential"); + int i, len = _count(lst); + el = malval_new_list(MAL_LIST, + g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), len)); + for (i=0; ival.array, MalVal*, i), arg2); + if (!e || mal_error) return NULL; + g_array_append_val(el->val.array, e); + } + return el; +} diff --git a/impls/c/types.h b/impls/c/types.h index 7f327b8e7c..b5d5590d96 100644 --- a/impls/c/types.h +++ b/impls/c/types.h @@ -1,197 +1,197 @@ -#ifndef __MAL_TYPES__ -#define __MAL_TYPES__ - -#include - -#ifdef USE_GC - -#include -void nop_free(void* ptr); -void GC_setup(); -char* GC_strdup(const char *src); -#define MAL_GC_SETUP() GC_setup() -#define MAL_GC_MALLOC GC_MALLOC -#define MAL_GC_FREE nop_free -#define MAL_GC_STRDUP GC_strdup - -#else - -#include -#define MAL_GC_SETUP() -#define MAL_GC_MALLOC malloc -#define MAL_GC_FREE free -#define MAL_GC_STRDUP strdup - -#endif - -struct MalVal; // pre-declare - - -// Env (implentation in env.c) - -typedef struct Env { - struct Env *outer; - GHashTable *table; -} Env; - -Env *new_env(Env *outer, struct MalVal* binds, struct MalVal *exprs); -Env *env_find(Env *env, struct MalVal *key); -struct MalVal *env_get(Env *env, struct MalVal *key); -Env *env_set(Env *env, struct MalVal *key, struct MalVal *val); - - -// Utility functiosn -void g_hash_table_print(GHashTable *hash_table); -GHashTable *g_hash_table_copy(GHashTable *src_table); - - -// Errors/exceptions - -extern struct MalVal *mal_error; -void _error(const char *fmt, ...); - -#define abort(format, ...) \ - { _error(format, ##__VA_ARGS__); return NULL; } - -#define assert(test, format, ...) \ - if (!(test)) { \ - _error(format, ##__VA_ARGS__); \ - return NULL; \ - } - -#define assert_type(mv, typ, format, ...) \ - if (!(mv->type & (typ))) { \ - _error(format, ##__VA_ARGS__); \ - return NULL; \ - } - - -typedef enum { - MAL_NIL = 1, - MAL_TRUE = 2, - MAL_FALSE = 4, - MAL_INTEGER = 8, - MAL_FLOAT = 16, - MAL_SYMBOL = 32, - MAL_STRING = 64, - MAL_LIST = 128, - MAL_VECTOR = 256, - MAL_HASH_MAP = 512, - MAL_ATOM = 1024, - MAL_FUNCTION_C = 2048, - MAL_FUNCTION_MAL = 4096, -} MalType; - -typedef struct MalVal { - MalType type; - struct MalVal *metadata; - union { - gint64 intnum; - gdouble floatnum; - char *string; - GArray *array; - GHashTable *hash_table; - struct MalVal *atom_val; - void *(*f0) (); - void *(*f1) (void*); - void *(*f2) (void*,void*); - void *(*f3) (void*,void*,void*); - void *(*f4) (void*,void*,void*,void*); - void *(*f5) (void*,void*,void*,void*,void*); - void *(*f6) (void*,void*,void*,void*,void*,void*); - void *(*f7) (void*,void*,void*,void*,void*,void*,void*); - void *(*f8) (void*,void*,void*,void*,void*,void*,void*,void*); - void *(*f9) (void*,void*,void*,void*,void*,void*,void*,void*,void*); - void *(*f10)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*); - void *(*f11)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*); - void *(*f12)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*,void*); - void *(*f13)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*,void*,void*); - void *(*f14)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*,void*,void*,void*); - void *(*f15)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*); - void *(*f16)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*,void*); - void *(*f17)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*,void*,void*); - void *(*f18)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*,void*,void*,void*); - void *(*f19)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*,void*,void*,void*,void*); - void *(*f20)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, - void*,void*,void*,void*,void*,void*,void*,void*,void*,void*); - struct { - struct MalVal *(*evaluator)(struct MalVal *, Env *); - struct MalVal *args; - struct MalVal *body; - struct Env *env; - } func; - } val; - int func_arg_cnt; - int ismacro; -} MalVal; - -// Constants - -extern MalVal mal_nil; -extern MalVal mal_true; -extern MalVal mal_false; - - -// Declare functions used internally (by other C code). -// Mal visible functions are "exported" in types_ns - -MalVal *malval_new(MalType type, MalVal *metadata); -void malval_free(MalVal *mv); -MalVal *malval_new_integer(gint64 val); -MalVal *malval_new_float(gdouble val); -MalVal *malval_new_string(char *val); -MalVal *malval_new_symbol(char *val); -MalVal *malval_new_keyword(char *val); -MalVal *malval_new_list(MalType type, GArray *val); -MalVal *malval_new_hash_map(GHashTable *val); -MalVal *malval_new_atom(MalVal *val); -MalVal *malval_new_function(void *(*func)(void *), int arg_cnt); - -// Numbers -#define WRAP_INTEGER_OP(name, op) \ - static MalVal *int_ ## name(MalVal *a, MalVal *b) { \ - return malval_new_integer(a->val.intnum op b->val.intnum); \ - } -#define WRAP_INTEGER_CMP_OP(name, op) \ - static MalVal *int_ ## name(MalVal *a, MalVal *b) { \ - return a->val.intnum op b->val.intnum ? &mal_true : &mal_false; \ - } - -// Collections -MalVal *_listX(int count, ...); -MalVal *_list(MalVal *args); -MalVal *_vector(MalVal *args); -MalVal *_hash_map(MalVal *args); -MalVal *_assoc_BANG(MalVal* hm, MalVal *args); -MalVal *_dissoc_BANG(MalVal* hm, MalVal *args); - -MalVal *_apply(MalVal *f, MalVal *el); - -char *_pr_str(MalVal *args, int print_readably); - -MalVal *_slice(MalVal *seq, int start, int end); -MalVal *_nth(MalVal *seq, int idx); -MalVal *_first(MalVal *seq); -MalVal *_rest(MalVal *seq); -MalVal *_last(MalVal *seq); -int _count(MalVal *obj); - -int _atom_Q(MalVal *exp); -int _sequential_Q(MalVal *seq); -int _list_Q(MalVal *seq); -int _vector_Q(MalVal *seq); -int _hash_map_Q(MalVal *seq); -int _equal_Q(MalVal *a, MalVal *b); - -MalVal *_map2(MalVal *(*func)(void*, void*), MalVal *lst, void *arg2); - -#endif +#ifndef __MAL_TYPES__ +#define __MAL_TYPES__ + +#include + +#ifdef USE_GC + +#include +void nop_free(void* ptr); +void GC_setup(); +char* GC_strdup(const char *src); +#define MAL_GC_SETUP() GC_setup() +#define MAL_GC_MALLOC GC_MALLOC +#define MAL_GC_FREE nop_free +#define MAL_GC_STRDUP GC_strdup + +#else + +#include +#define MAL_GC_SETUP() +#define MAL_GC_MALLOC malloc +#define MAL_GC_FREE free +#define MAL_GC_STRDUP strdup + +#endif + +struct MalVal; // pre-declare + + +// Env (implentation in env.c) + +typedef struct Env { + struct Env *outer; + GHashTable *table; +} Env; + +Env *new_env(Env *outer, struct MalVal* binds, struct MalVal *exprs); +Env *env_find(Env *env, struct MalVal *key); +struct MalVal *env_get(Env *env, struct MalVal *key); +Env *env_set(Env *env, struct MalVal *key, struct MalVal *val); + + +// Utility functiosn +void g_hash_table_print(GHashTable *hash_table); +GHashTable *g_hash_table_copy(GHashTable *src_table); + + +// Errors/exceptions + +extern struct MalVal *mal_error; +void _error(const char *fmt, ...); + +#define abort(format, ...) \ + { _error(format, ##__VA_ARGS__); return NULL; } + +#define assert(test, format, ...) \ + if (!(test)) { \ + _error(format, ##__VA_ARGS__); \ + return NULL; \ + } + +#define assert_type(mv, typ, format, ...) \ + if (!(mv->type & (typ))) { \ + _error(format, ##__VA_ARGS__); \ + return NULL; \ + } + + +typedef enum { + MAL_NIL = 1, + MAL_TRUE = 2, + MAL_FALSE = 4, + MAL_INTEGER = 8, + MAL_FLOAT = 16, + MAL_SYMBOL = 32, + MAL_STRING = 64, + MAL_LIST = 128, + MAL_VECTOR = 256, + MAL_HASH_MAP = 512, + MAL_ATOM = 1024, + MAL_FUNCTION_C = 2048, + MAL_FUNCTION_MAL = 4096, +} MalType; + +typedef struct MalVal { + MalType type; + struct MalVal *metadata; + union { + gint64 intnum; + gdouble floatnum; + char *string; + GArray *array; + GHashTable *hash_table; + struct MalVal *atom_val; + void *(*f0) (); + void *(*f1) (void*); + void *(*f2) (void*,void*); + void *(*f3) (void*,void*,void*); + void *(*f4) (void*,void*,void*,void*); + void *(*f5) (void*,void*,void*,void*,void*); + void *(*f6) (void*,void*,void*,void*,void*,void*); + void *(*f7) (void*,void*,void*,void*,void*,void*,void*); + void *(*f8) (void*,void*,void*,void*,void*,void*,void*,void*); + void *(*f9) (void*,void*,void*,void*,void*,void*,void*,void*,void*); + void *(*f10)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*); + void *(*f11)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*); + void *(*f12)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*,void*); + void *(*f13)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*,void*,void*); + void *(*f14)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*,void*,void*,void*); + void *(*f15)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*); + void *(*f16)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*,void*); + void *(*f17)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*,void*,void*); + void *(*f18)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*,void*,void*,void*); + void *(*f19)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*,void*,void*,void*,void*); + void *(*f20)(void*,void*,void*,void*,void*,void*,void*,void*,void*,void*, + void*,void*,void*,void*,void*,void*,void*,void*,void*,void*); + struct { + struct MalVal *(*evaluator)(struct MalVal *, Env *); + struct MalVal *args; + struct MalVal *body; + struct Env *env; + } func; + } val; + int func_arg_cnt; + int ismacro; +} MalVal; + +// Constants + +extern MalVal mal_nil; +extern MalVal mal_true; +extern MalVal mal_false; + + +// Declare functions used internally (by other C code). +// Mal visible functions are "exported" in types_ns + +MalVal *malval_new(MalType type, MalVal *metadata); +void malval_free(MalVal *mv); +MalVal *malval_new_integer(gint64 val); +MalVal *malval_new_float(gdouble val); +MalVal *malval_new_string(char *val); +MalVal *malval_new_symbol(char *val); +MalVal *malval_new_keyword(char *val); +MalVal *malval_new_list(MalType type, GArray *val); +MalVal *malval_new_hash_map(GHashTable *val); +MalVal *malval_new_atom(MalVal *val); +MalVal *malval_new_function(void *(*func)(void *), int arg_cnt); + +// Numbers +#define WRAP_INTEGER_OP(name, op) \ + static MalVal *int_ ## name(MalVal *a, MalVal *b) { \ + return malval_new_integer(a->val.intnum op b->val.intnum); \ + } +#define WRAP_INTEGER_CMP_OP(name, op) \ + static MalVal *int_ ## name(MalVal *a, MalVal *b) { \ + return a->val.intnum op b->val.intnum ? &mal_true : &mal_false; \ + } + +// Collections +MalVal *_listX(int count, ...); +MalVal *_list(MalVal *args); +MalVal *_vector(MalVal *args); +MalVal *_hash_map(MalVal *args); +MalVal *_assoc_BANG(MalVal* hm, MalVal *args); +MalVal *_dissoc_BANG(MalVal* hm, MalVal *args); + +MalVal *_apply(MalVal *f, MalVal *el); + +char *_pr_str(MalVal *args, int print_readably); + +MalVal *_slice(MalVal *seq, int start, int end); +MalVal *_nth(MalVal *seq, int idx); +MalVal *_first(MalVal *seq); +MalVal *_rest(MalVal *seq); +MalVal *_last(MalVal *seq); +int _count(MalVal *obj); + +int _atom_Q(MalVal *exp); +int _sequential_Q(MalVal *seq); +int _list_Q(MalVal *seq); +int _vector_Q(MalVal *seq); +int _hash_map_Q(MalVal *seq); +int _equal_Q(MalVal *a, MalVal *b); + +MalVal *_map2(MalVal *(*func)(void*, void*), MalVal *lst, void *arg2); + +#endif diff --git a/impls/chuck/Dockerfile b/impls/chuck/Dockerfile index b7dc62385c..97e7b0fc40 100644 --- a/impls/chuck/Dockerfile +++ b/impls/chuck/Dockerfile @@ -1,32 +1,32 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Chuck -RUN apt-get -y install bison gcc g++ flex -RUN apt-get -y install libasound2-dev libsndfile1-dev -RUN cd /tmp && curl -O http://chuck.cs.princeton.edu/release/files/chuck-1.3.5.2.tgz \ - && tar xvzf /tmp/chuck-1.3.5.2.tgz && cd chuck-1.3.5.2/src \ - && make linux-alsa && make install \ - && rm -r /tmp/chuck-1.3.5.2* - -ENV HOME /mal +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Chuck +RUN apt-get -y install bison gcc g++ flex +RUN apt-get -y install libasound2-dev libsndfile1-dev +RUN cd /tmp && curl -O http://chuck.cs.princeton.edu/release/files/chuck-1.3.5.2.tgz \ + && tar xvzf /tmp/chuck-1.3.5.2.tgz && cd chuck-1.3.5.2/src \ + && make linux-alsa && make install \ + && rm -r /tmp/chuck-1.3.5.2* + +ENV HOME /mal diff --git a/impls/chuck/Makefile b/impls/chuck/Makefile index bee2d7baae..5e879885f4 100644 --- a/impls/chuck/Makefile +++ b/impls/chuck/Makefile @@ -1,5 +1,5 @@ -all: - -clean: - -.PHONY: all clean +all: + +clean: + +.PHONY: all clean diff --git a/impls/chuck/chuck.md b/impls/chuck/chuck.md index e87f384258..bb0ab7e344 100644 --- a/impls/chuck/chuck.md +++ b/impls/chuck/chuck.md @@ -1,117 +1,117 @@ -- I've found a potential bug in their substring function: - https://github.com/ccrma/chuck/issues/55 -- later I've found one in their regex replace function, too: - https://github.com/ccrma/chuck/issues/60 -- this suggests there hasn't been much testing done on things - unrelated to audio which is not that unexpected in an audio - programming language, but still... -- the manual isn't up to date, so you need to look at `VERSIONS` and - the examples instead, sometimes the sources, too -- the manual only speaks of the debug syntax for printing - (`<<>>;` which goes to stderr), I've found a `chout` object you - can send strings to for outputting to stdout -- quitting is done via `C-c` only -- you'll want to use `--silent` to disable audio errors/processing, - but then the process will use 100% CPU and ignore any waiting -- stdin handling is terrible: - - the manual shows a keyboard example with HID devices, but it - doesn't work on linux - - there's a "hacked" `ConsoleInput` class with only an example file - for it, it works for most of the part, but doesn't accept `C-d` - - the obvious alternative is printing a prompt manually, then - waiting for `KBHit` events and printing them, but that's rather - tedious as you'd have to convert the ascii numbers into chars - yourself and make a buffer-like thing - - I've also considered writing a thing sending OSC events per - keyboard hit and processing these in ChucK as they come in, but - that would most likely not work with the test harness ._. -- the OOP system is seriously weird - - influenced by C++ *and* java - - one public class per file - - to export functionality, you must use a public class (and static - functions/variables) - - if you use static variables, you can't assign values to them - directly, you'll have to do that after the class has been defined - - worse, you can't even declare anything that's not a primitive, so - if you want to declare a reference type, use the reference - operator instead... - - no interfaces - - no generics (copy/paste code for all types you need!) - - no unions (use Object, then cast to the correct type) - - there is no obvious way of casting to arrays of types - - no private (things are public by default, public keyword is used - to export code) - - no self-references in classes (so no trees, static "constructors" - work though) - - no meaningful way of working with null for primitive types (mutate - a reference and look at the return code instead) - - no boxed versions of primitive types - - no automatic boxing/unboxing - - no upcasting/downcasting -- No module system - - `Machine.add(file)` is the only mechanism available from code (no - read all file contents and eval), but if you use it, it defers - loading the files until the file it's used in, rendering it - useless - - Therefore the only way to make use of it is writing a file that - only consists of these instructions - - The only practical alternative is specifying all files you need - loaded in the right order when starting chuck - - That's why I wrote a runner script extracting `// @import file.ck` - lines (hello JS!) and running chuck with them -- No real exception system - - The VM is able to throw exceptions (out of bounds, nullpointer), - but you can't do anything about them and only get a hint what kind - of operation caused it (no stacktrace or anything) - - No user-definable exceptions, no mechanism to catch or throw them - (other than intentionally doing something illegal) - - This means that you should use C-style error checking by - converting the potentially erroneous functions into returning a - status code and mutating a reference passed to them as argument - which is highly weird in a otherwise Java-like language - - An alternative is defining an error object (which belongs to the - same supertype as the other legal return values) and checking its - type by inspecting the user-tracked type field -- No function pointers/functors/closures - - This is a bit unexpected as if you leave away the parentheses - holding the argument list and debug print a function, you'll see - it being recognized as a function, yet you can't store it anywhere - for passing it around - - This is not quite right as you can store it in an `Object`, just - not call it in any way or cast it to a function type - - So you get to implement functors and closures yourself... - - A functor is a class with a call method taking an argument list - and executing the code of the function you intend to pass around - - To use it, store an instance of its class somewhere, then use its - call method with an argument list - - Closures can be implemented with a data structure holding a - snapshot of the current environment, the parameter list and AST, - the last two being a way of representing an anonymous function. -- Other oddities - - strict distinction between assigning values and references with - two separate operators for them (`<<` for array append doesn't - seem to care though) - - strings are supposedly reference types, yet you can assign them - with the regular operator... - - `<<` on an `type[]` gives you a weird error as you need to use an - `type[0]` (and a `type[]` is merely a reference...) - - The compiler will find lots of mistakes for you, but cannot figure - out code branches not returning anything which means that return - type violations will blow up in your face unless there's a - reasonable default value (null for `Object` isn't, 0 for `int` and - "" for `string` is) - - If you abuse the type system too much, chances are you get a - segfault or assert instead of an exception... - - Debug print shows the object and its type if you pass one - argument, if you pass more than one, it prints the concatenation - of their representations instead, so it's a bit hard to make out - what is a debug print and what isn't - - there are no hash maps, just the possibility to use a string key - on an array for storing and fetching contents (like in PHP, eww) - and no way of retrieving keys/values or even iterating over these - - I think I've spotted a weird scoping bug that prefers a member - variable over a local variable after nesting scopes, therefore I - consider the language to not implement proper lexical scoping - - another proof of it is declaring variables in consequent if-blocks - as that gives you an error instead of being permitted as they - should be in different local scopes... +- I've found a potential bug in their substring function: + https://github.com/ccrma/chuck/issues/55 +- later I've found one in their regex replace function, too: + https://github.com/ccrma/chuck/issues/60 +- this suggests there hasn't been much testing done on things + unrelated to audio which is not that unexpected in an audio + programming language, but still... +- the manual isn't up to date, so you need to look at `VERSIONS` and + the examples instead, sometimes the sources, too +- the manual only speaks of the debug syntax for printing + (`<<>>;` which goes to stderr), I've found a `chout` object you + can send strings to for outputting to stdout +- quitting is done via `C-c` only +- you'll want to use `--silent` to disable audio errors/processing, + but then the process will use 100% CPU and ignore any waiting +- stdin handling is terrible: + - the manual shows a keyboard example with HID devices, but it + doesn't work on linux + - there's a "hacked" `ConsoleInput` class with only an example file + for it, it works for most of the part, but doesn't accept `C-d` + - the obvious alternative is printing a prompt manually, then + waiting for `KBHit` events and printing them, but that's rather + tedious as you'd have to convert the ascii numbers into chars + yourself and make a buffer-like thing + - I've also considered writing a thing sending OSC events per + keyboard hit and processing these in ChucK as they come in, but + that would most likely not work with the test harness ._. +- the OOP system is seriously weird + - influenced by C++ *and* java + - one public class per file + - to export functionality, you must use a public class (and static + functions/variables) + - if you use static variables, you can't assign values to them + directly, you'll have to do that after the class has been defined + - worse, you can't even declare anything that's not a primitive, so + if you want to declare a reference type, use the reference + operator instead... + - no interfaces + - no generics (copy/paste code for all types you need!) + - no unions (use Object, then cast to the correct type) + - there is no obvious way of casting to arrays of types + - no private (things are public by default, public keyword is used + to export code) + - no self-references in classes (so no trees, static "constructors" + work though) + - no meaningful way of working with null for primitive types (mutate + a reference and look at the return code instead) + - no boxed versions of primitive types + - no automatic boxing/unboxing + - no upcasting/downcasting +- No module system + - `Machine.add(file)` is the only mechanism available from code (no + read all file contents and eval), but if you use it, it defers + loading the files until the file it's used in, rendering it + useless + - Therefore the only way to make use of it is writing a file that + only consists of these instructions + - The only practical alternative is specifying all files you need + loaded in the right order when starting chuck + - That's why I wrote a runner script extracting `// @import file.ck` + lines (hello JS!) and running chuck with them +- No real exception system + - The VM is able to throw exceptions (out of bounds, nullpointer), + but you can't do anything about them and only get a hint what kind + of operation caused it (no stacktrace or anything) + - No user-definable exceptions, no mechanism to catch or throw them + (other than intentionally doing something illegal) + - This means that you should use C-style error checking by + converting the potentially erroneous functions into returning a + status code and mutating a reference passed to them as argument + which is highly weird in a otherwise Java-like language + - An alternative is defining an error object (which belongs to the + same supertype as the other legal return values) and checking its + type by inspecting the user-tracked type field +- No function pointers/functors/closures + - This is a bit unexpected as if you leave away the parentheses + holding the argument list and debug print a function, you'll see + it being recognized as a function, yet you can't store it anywhere + for passing it around + - This is not quite right as you can store it in an `Object`, just + not call it in any way or cast it to a function type + - So you get to implement functors and closures yourself... + - A functor is a class with a call method taking an argument list + and executing the code of the function you intend to pass around + - To use it, store an instance of its class somewhere, then use its + call method with an argument list + - Closures can be implemented with a data structure holding a + snapshot of the current environment, the parameter list and AST, + the last two being a way of representing an anonymous function. +- Other oddities + - strict distinction between assigning values and references with + two separate operators for them (`<<` for array append doesn't + seem to care though) + - strings are supposedly reference types, yet you can assign them + with the regular operator... + - `<<` on an `type[]` gives you a weird error as you need to use an + `type[0]` (and a `type[]` is merely a reference...) + - The compiler will find lots of mistakes for you, but cannot figure + out code branches not returning anything which means that return + type violations will blow up in your face unless there's a + reasonable default value (null for `Object` isn't, 0 for `int` and + "" for `string` is) + - If you abuse the type system too much, chances are you get a + segfault or assert instead of an exception... + - Debug print shows the object and its type if you pass one + argument, if you pass more than one, it prints the concatenation + of their representations instead, so it's a bit hard to make out + what is a debug print and what isn't + - there are no hash maps, just the possibility to use a string key + on an array for storing and fetching contents (like in PHP, eww) + and no way of retrieving keys/values or even iterating over these + - I think I've spotted a weird scoping bug that prefers a member + variable over a local variable after nesting scopes, therefore I + consider the language to not implement proper lexical scoping + - another proof of it is declaring variables in consequent if-blocks + as that gives you an error instead of being permitted as they + should be in different local scopes... diff --git a/impls/chuck/core.ck b/impls/chuck/core.ck index b7c7636875..6c2453b412 100644 --- a/impls/chuck/core.ck +++ b/impls/chuck/core.ck @@ -1,100 +1,100 @@ -public class Core -{ - static string names[]; - static MalSubr ns[]; -} - -["+", "-", "*", "/", - "list", "list?", "empty?", "count", - "=", "<", "<=", ">", ">=", - "pr-str", "str", "prn", "println", - "read-string", "slurp", - "atom", "atom?", "deref", "reset!", "swap!", - "vec", "cons", "concat", - "nth", "first", "rest", - "throw", - "apply", "map", - "nil?", "true?", "false?", "number?", "symbol?", "keyword?", "vector?", "map?", - "symbol", "keyword", "vector", "hash-map", - "assoc", "dissoc", "get", "contains?", "keys", "vals", - "sequential?", "fn?", "macro?", - "readline", "meta", "with-meta", - "time-ms", "conj", "string?", "seq"] @=> Core.names; -MalSubr ns[0] @=> Core.ns; - -new MalAdd @=> Core.ns["+"]; -new MalSub @=> Core.ns["-"]; -new MalMul @=> Core.ns["*"]; -new MalDiv @=> Core.ns["/"]; - -new MalListify @=> Core.ns["list"]; -new MalIsList @=> Core.ns["list?"]; -new MalIsEmpty @=> Core.ns["empty?"]; -new MalCount @=> Core.ns["count"]; - -new MalEqual @=> Core.ns["="]; -new MalLess @=> Core.ns["<"]; -new MalLessEqual @=> Core.ns["<="]; -new MalGreater @=> Core.ns[">"]; -new MalGreaterEqual @=> Core.ns[">="]; - -new MalPrStr @=> Core.ns["pr-str"]; -new MalStr @=> Core.ns["str"]; -new MalPrn @=> Core.ns["prn"]; -new MalPrintln @=> Core.ns["println"]; - -new MalReadStr @=> Core.ns["read-string"]; -new MalSlurp @=> Core.ns["slurp"]; - -new MalAtomify @=> Core.ns["atom"]; -new MalIsAtom @=> Core.ns["atom?"]; -new MalDeref @=> Core.ns["deref"]; -new MalDoReset @=> Core.ns["reset!"]; -new MalDoSwap @=> Core.ns["swap!"]; - -new MalVec @=> Core.ns["vec"]; -new MalCons @=> Core.ns["cons"]; -new MalConcat @=> Core.ns["concat"]; - -new MalNth @=> Core.ns["nth"]; -new MalFirst @=> Core.ns["first"]; -new MalRest @=> Core.ns["rest"]; - -new MalThrow @=> Core.ns["throw"]; - -new MalApply @=> Core.ns["apply"]; -new MalMap @=> Core.ns["map"]; - -new MalIsNil @=> Core.ns["nil?"]; -new MalIsTrue @=> Core.ns["true?"]; -new MalIsFalse @=> Core.ns["false?"]; -new MalIsNumber @=> Core.ns["number?"]; -new MalIsSymbol @=> Core.ns["symbol?"]; -new MalIsKeyword @=> Core.ns["keyword?"]; -new MalIsVector @=> Core.ns["vector?"]; -new MalIsHashMap @=> Core.ns["map?"]; - -new MalSymbolify @=> Core.ns["symbol"]; -new MalKeywordify @=> Core.ns["keyword"]; -new MalVectorify @=> Core.ns["vector"]; -new MalHashMapify @=> Core.ns["hash-map"]; - -new MalAssoc @=> Core.ns["assoc"]; -new MalDissoc @=> Core.ns["dissoc"]; -new MalGet @=> Core.ns["get"]; -new MalIsContains @=> Core.ns["contains?"]; -new MalKeys @=> Core.ns["keys"]; -new MalVals @=> Core.ns["vals"]; - -new MalSequential @=> Core.ns["sequential?"]; -new MalIsFn @=> Core.ns["fn?"]; -new MalIsMacro @=> Core.ns["macro?"]; - -new MalReadline @=> Core.ns["readline"]; -new MalMeta @=> Core.ns["meta"]; -new MalWithMeta @=> Core.ns["with-meta"]; - -new MalTimeMs @=> Core.ns["time-ms"]; -new MalConj @=> Core.ns["conj"]; -new MalIsString @=> Core.ns["string?"]; -new MalSeq @=> Core.ns["seq"]; +public class Core +{ + static string names[]; + static MalSubr ns[]; +} + +["+", "-", "*", "/", + "list", "list?", "empty?", "count", + "=", "<", "<=", ">", ">=", + "pr-str", "str", "prn", "println", + "read-string", "slurp", + "atom", "atom?", "deref", "reset!", "swap!", + "vec", "cons", "concat", + "nth", "first", "rest", + "throw", + "apply", "map", + "nil?", "true?", "false?", "number?", "symbol?", "keyword?", "vector?", "map?", + "symbol", "keyword", "vector", "hash-map", + "assoc", "dissoc", "get", "contains?", "keys", "vals", + "sequential?", "fn?", "macro?", + "readline", "meta", "with-meta", + "time-ms", "conj", "string?", "seq"] @=> Core.names; +MalSubr ns[0] @=> Core.ns; + +new MalAdd @=> Core.ns["+"]; +new MalSub @=> Core.ns["-"]; +new MalMul @=> Core.ns["*"]; +new MalDiv @=> Core.ns["/"]; + +new MalListify @=> Core.ns["list"]; +new MalIsList @=> Core.ns["list?"]; +new MalIsEmpty @=> Core.ns["empty?"]; +new MalCount @=> Core.ns["count"]; + +new MalEqual @=> Core.ns["="]; +new MalLess @=> Core.ns["<"]; +new MalLessEqual @=> Core.ns["<="]; +new MalGreater @=> Core.ns[">"]; +new MalGreaterEqual @=> Core.ns[">="]; + +new MalPrStr @=> Core.ns["pr-str"]; +new MalStr @=> Core.ns["str"]; +new MalPrn @=> Core.ns["prn"]; +new MalPrintln @=> Core.ns["println"]; + +new MalReadStr @=> Core.ns["read-string"]; +new MalSlurp @=> Core.ns["slurp"]; + +new MalAtomify @=> Core.ns["atom"]; +new MalIsAtom @=> Core.ns["atom?"]; +new MalDeref @=> Core.ns["deref"]; +new MalDoReset @=> Core.ns["reset!"]; +new MalDoSwap @=> Core.ns["swap!"]; + +new MalVec @=> Core.ns["vec"]; +new MalCons @=> Core.ns["cons"]; +new MalConcat @=> Core.ns["concat"]; + +new MalNth @=> Core.ns["nth"]; +new MalFirst @=> Core.ns["first"]; +new MalRest @=> Core.ns["rest"]; + +new MalThrow @=> Core.ns["throw"]; + +new MalApply @=> Core.ns["apply"]; +new MalMap @=> Core.ns["map"]; + +new MalIsNil @=> Core.ns["nil?"]; +new MalIsTrue @=> Core.ns["true?"]; +new MalIsFalse @=> Core.ns["false?"]; +new MalIsNumber @=> Core.ns["number?"]; +new MalIsSymbol @=> Core.ns["symbol?"]; +new MalIsKeyword @=> Core.ns["keyword?"]; +new MalIsVector @=> Core.ns["vector?"]; +new MalIsHashMap @=> Core.ns["map?"]; + +new MalSymbolify @=> Core.ns["symbol"]; +new MalKeywordify @=> Core.ns["keyword"]; +new MalVectorify @=> Core.ns["vector"]; +new MalHashMapify @=> Core.ns["hash-map"]; + +new MalAssoc @=> Core.ns["assoc"]; +new MalDissoc @=> Core.ns["dissoc"]; +new MalGet @=> Core.ns["get"]; +new MalIsContains @=> Core.ns["contains?"]; +new MalKeys @=> Core.ns["keys"]; +new MalVals @=> Core.ns["vals"]; + +new MalSequential @=> Core.ns["sequential?"]; +new MalIsFn @=> Core.ns["fn?"]; +new MalIsMacro @=> Core.ns["macro?"]; + +new MalReadline @=> Core.ns["readline"]; +new MalMeta @=> Core.ns["meta"]; +new MalWithMeta @=> Core.ns["with-meta"]; + +new MalTimeMs @=> Core.ns["time-ms"]; +new MalConj @=> Core.ns["conj"]; +new MalIsString @=> Core.ns["string?"]; +new MalSeq @=> Core.ns["seq"]; diff --git a/impls/chuck/env.ck b/impls/chuck/env.ck index e03ccf2b8e..4666e0152c 100644 --- a/impls/chuck/env.ck +++ b/impls/chuck/env.ck @@ -1,92 +1,92 @@ -public class Env extends MalObject -{ - MalObject outer; // this would ideally be Env, but isn't supported - MalObject data[0]; - - fun void init(MalObject env) - { - env @=> outer; - } - - fun void init(MalObject env, string binds[], MalObject exprs[]) - { - env @=> outer; - - for( 0 => int i; i < binds.size(); i++ ) - { - binds[i] => string bind; - - if( bind == "&" ) - { - MalObject.slice(exprs, i) @=> MalObject rest_binds[]; - MalList.create(rest_binds) @=> data[binds[i+1]]; - break; - } - else - { - exprs[i] @=> data[bind]; - } - } - } - - fun static Env create(MalObject env) - { - Env e; - e.init(env); - return e; - } - - fun static Env create(MalObject env, string binds[], MalObject exprs[]) - { - Env e; - e.init(env, binds, exprs); - return e; - } - - fun MalObject clone() - { - Env value; - - this.outer @=> value.outer; - this.data @=> value.data; - - return value; - } - - fun void set(string key, MalObject value) - { - value @=> data[key]; - } - - fun MalObject find(string key) - { - data[key] @=> MalObject value; - - if( value != null ) - { - return value; - } - else if( outer != null ) - { - return (outer$Env).find(key); - } - else - { - return null; - } - } - - fun MalObject get(string key) - { - find(key) @=> MalObject value; - - if( value != null ) - { - return value; - } - else - { - return MalError.create(MalString.create("'" + key + "' not found")); - } - } -} +public class Env extends MalObject +{ + MalObject outer; // this would ideally be Env, but isn't supported + MalObject data[0]; + + fun void init(MalObject env) + { + env @=> outer; + } + + fun void init(MalObject env, string binds[], MalObject exprs[]) + { + env @=> outer; + + for( 0 => int i; i < binds.size(); i++ ) + { + binds[i] => string bind; + + if( bind == "&" ) + { + MalObject.slice(exprs, i) @=> MalObject rest_binds[]; + MalList.create(rest_binds) @=> data[binds[i+1]]; + break; + } + else + { + exprs[i] @=> data[bind]; + } + } + } + + fun static Env create(MalObject env) + { + Env e; + e.init(env); + return e; + } + + fun static Env create(MalObject env, string binds[], MalObject exprs[]) + { + Env e; + e.init(env, binds, exprs); + return e; + } + + fun MalObject clone() + { + Env value; + + this.outer @=> value.outer; + this.data @=> value.data; + + return value; + } + + fun void set(string key, MalObject value) + { + value @=> data[key]; + } + + fun MalObject find(string key) + { + data[key] @=> MalObject value; + + if( value != null ) + { + return value; + } + else if( outer != null ) + { + return (outer$Env).find(key); + } + else + { + return null; + } + } + + fun MalObject get(string key) + { + find(key) @=> MalObject value; + + if( value != null ) + { + return value; + } + else + { + return MalError.create(MalString.create("'" + key + "' not found")); + } + } +} diff --git a/impls/chuck/func.ck b/impls/chuck/func.ck index 15d4bd9df3..e0b72e8e08 100644 --- a/impls/chuck/func.ck +++ b/impls/chuck/func.ck @@ -1,35 +1,35 @@ -public class Func extends MalObject -{ - "func" => type; - Env env; - string args[]; - MalObject ast; - int isMacro; - - fun void init(Env env, string args[], MalObject ast) - { - env @=> this.env; - args @=> this.args; - ast @=> this.ast; - } - - fun static Func create(Env env, string args[], MalObject ast) - { - Func func; - func.init(env, args, ast); - return func; - } - - fun MalObject clone() - { - Func value; - - this.type => value.type; - this.env @=> value.env; - this.args @=> value.args; - this.ast @=> value.ast; - this.isMacro @=> value.isMacro; - - return value; - } -} +public class Func extends MalObject +{ + "func" => type; + Env env; + string args[]; + MalObject ast; + int isMacro; + + fun void init(Env env, string args[], MalObject ast) + { + env @=> this.env; + args @=> this.args; + ast @=> this.ast; + } + + fun static Func create(Env env, string args[], MalObject ast) + { + Func func; + func.init(env, args, ast); + return func; + } + + fun MalObject clone() + { + Func value; + + this.type => value.type; + this.env @=> value.env; + this.args @=> value.args; + this.ast @=> value.ast; + this.isMacro @=> value.isMacro; + + return value; + } +} diff --git a/impls/chuck/notes.md b/impls/chuck/notes.md index c467d15bc9..d68fd849f3 100644 --- a/impls/chuck/notes.md +++ b/impls/chuck/notes.md @@ -1,155 +1,155 @@ -# Step 1 - -- What if I don't have an OOP language? -- types.qx could be more prominently mentioned... -- A table with all types and suggested object names would be hugely - useful -- Same for a list of all errors and their messages -- Mention return types and argument types consistently -- More on int/float and their grammar (int is mentioned implicitly in - the ASCII art, nothing on signs or bases or their lack of) -- Note that a string must be parsed for the `print_readably` thing to - work and mention how one could do that (like, by using a `read` or - `eval`-like thing or alternatively, chopping off the surrounding - quotes and doing the inverse transformation of the printing) -- How is an atom printed? - -# Step 2 - -- What if my language doesn't support lambdas, let alone passing - around named functions? Ideally write something about - implementing/using functors/delegates or replacing that namespace - with a big switch as with VHDL. Another problem is that if you - choose a different solution in step 4, step 2 could end up no longer - functional... -- What kind of error (read: what message?) is raised when no value can - be looked up for the symbol? Is it arbitrary? Do I need to extend - my error handling to allow for format strings? -- It would be worth a mention that you should extend the printer to - handle "native" functions (or in oldtimey terms, subrs) - -# Step 3 - -- You should modify both eval_ast *and* EVAL -- Suggest the trick with destructuring the AST into `a0`, `a1`, - etc. variables for easier access. Perhaps this can be used to clear - up the general language used with AST manipulation (like, first - parameter and second list element)? -- What does def! return? Emacs Lisp for instance returns the symbol - whereas the tests suggest the value should be returned instead... - -# Step 4 - -- "Implement the strings functions" -- The "no closures" paragraph isn't quite clear. Asides from that, do - native functions don't really need to be wrapped the same way as the - `fn*` objects, just introduce another type (like, a Subr and a Func - type) and do a check before applying the arguments to it -- Why does the guide say that the first argument of `count` can be - treated as list, yet there's a test performing `(count nil)` and - expecting zero as result? -- Does it make sense to compare, say, atoms in `=`? - -# Step 5 - -- "This is especially important in Lisp languages because they tend to - prefer using recursion instead of iteration for control structures." - <- I'd argue it's less of a lisp thing (see everything else related - to CL) and more a thing functional programming proponents have - considered more elegant than introducing iteration constructs (see - haskell, ocaml, erlang) -- It's not really clear that the TCO change for `let*` involves the - form you'd normally pass to `EVAL` to become the new `ast`. I had to - reread this a few more times to understand that the "second `ast`" - is actually its third argument... -- Where did the check for `do` not being broken by TCO go? -- What's the deal with the `quux/tests/step5_tco.qx` file? - -# Step 6 - -- "The closure calls the your EVAL function […]." -- I still don't have any closures. How the heck do I implement - `eval`? What about `swap!`? -- It would be useful to mention that `swap!` sort of requires - implementing `apply` first... - -# Step 7 - -- Why the scare quotes for splicing? -- "Before implementing the quoting forms, you will need to implement - some supporting functions in the core namespace:" should be one list - item -- "this function takes a list as its second parameter and returns a - new list that has the first argument prepended to it." reads backwards -- The quasiquote paragraph is hard to read -- It's rather confusing to refer to the argument of `ast` and to an - `ast` parameter, perhaps name the latter a form? -- What could also help would be a visualization of the four - conditionals: - - \`42, \`() - - \`~foo - - \`(~@foo) and more - - \`(42 ~@foo) and everything else -- Mal/mal is inconsistently capitalized -- "Expand the conditional with reader `read_form` function to add the - following four cases" is again weird, better refer to the - `read_form` function in reader.qx -- "concat should support concatenation of lists, vectors, or a mix or - both." <- "or a mix or both" is redundant - -# Step 8 - -- "In the previous step, quoting enabled some simple manipulation [of] - data structures" -- The macroexpand function step refers to call/apply, it's unclear how - to proceed if you don't have such a thing -- How should the exception for invalid `nth` access look like? Also, - why is it an exception and not an error like with the reader? -- How can `first` take a list (or vector), but work on `nil`? -- The description of `rest` is inconsistent with the tests -- "In the main program, use the rep function to define two new control - structures macros." -- Why does the definition of `cond` use `throw` although it's only - introduced in the next chapter? - -# Step 9 - -- It's not really clear that you really just have a `try*` special - form, with `catch*` merely existing inside it... -- Another thing to clarify is that the exception value is a string - containing the message you'd see (unless you're using `throw`) -- Generally, it would be better to explain the general exception - handling mechanism (with some examples), then showing how one - implements it for both languages with and without exceptions -- Another way than using a global variable is introducing an error - type next to the other MAL types and checking whether something a - function returned is one, although the hint about returning one at - each use of `EVAL` still stands... -- Shouldn't either trick be mentioned at the beginning, simply because - you'll need it in a language without exceptions to do error handling? -- Why this bizarre treatment for `keyword`? Why is there no test for - it? -- Is there a test for whether hash maps deduplicate identical keys - when using `hash-map` or `assoc`? -- What exactly are keys the specification for `dissoc`, `get` and - `contains?` are speaking of? Can I assume these are either strings - or keywords? -- Why is it not documented that `get` may take `nil` instead of a map? -- Perhaps it's worth adding more tests involving symbols to ensure - that functions using apply internally don't evaluate their args? - -# Step A - -- "Add meta-data support to mal functions." <- Shouldn't you mention - that this involves implementing `with-meta` and `meta`? -- "TODO. Should be separate from the function macro flag." <- Why is - this even related? -- It would be worth to mention that `with-meta` shall clone its - argument to avoid one of the more sneaky test failure reasons -- "The value of this entry should be a mal string containing the name - of the current implementation." -- "When the REPL starts up (as opposed to when it is called with a - script and/or arguments), call the rep function with this string to - print a startup header: `"(println (str \"Mal - [\" *host-language* \"]\"))".`" <- proof that you better quote these - because the asterisks just disappear... +# Step 1 + +- What if I don't have an OOP language? +- types.qx could be more prominently mentioned... +- A table with all types and suggested object names would be hugely + useful +- Same for a list of all errors and their messages +- Mention return types and argument types consistently +- More on int/float and their grammar (int is mentioned implicitly in + the ASCII art, nothing on signs or bases or their lack of) +- Note that a string must be parsed for the `print_readably` thing to + work and mention how one could do that (like, by using a `read` or + `eval`-like thing or alternatively, chopping off the surrounding + quotes and doing the inverse transformation of the printing) +- How is an atom printed? + +# Step 2 + +- What if my language doesn't support lambdas, let alone passing + around named functions? Ideally write something about + implementing/using functors/delegates or replacing that namespace + with a big switch as with VHDL. Another problem is that if you + choose a different solution in step 4, step 2 could end up no longer + functional... +- What kind of error (read: what message?) is raised when no value can + be looked up for the symbol? Is it arbitrary? Do I need to extend + my error handling to allow for format strings? +- It would be worth a mention that you should extend the printer to + handle "native" functions (or in oldtimey terms, subrs) + +# Step 3 + +- You should modify both eval_ast *and* EVAL +- Suggest the trick with destructuring the AST into `a0`, `a1`, + etc. variables for easier access. Perhaps this can be used to clear + up the general language used with AST manipulation (like, first + parameter and second list element)? +- What does def! return? Emacs Lisp for instance returns the symbol + whereas the tests suggest the value should be returned instead... + +# Step 4 + +- "Implement the strings functions" +- The "no closures" paragraph isn't quite clear. Asides from that, do + native functions don't really need to be wrapped the same way as the + `fn*` objects, just introduce another type (like, a Subr and a Func + type) and do a check before applying the arguments to it +- Why does the guide say that the first argument of `count` can be + treated as list, yet there's a test performing `(count nil)` and + expecting zero as result? +- Does it make sense to compare, say, atoms in `=`? + +# Step 5 + +- "This is especially important in Lisp languages because they tend to + prefer using recursion instead of iteration for control structures." + <- I'd argue it's less of a lisp thing (see everything else related + to CL) and more a thing functional programming proponents have + considered more elegant than introducing iteration constructs (see + haskell, ocaml, erlang) +- It's not really clear that the TCO change for `let*` involves the + form you'd normally pass to `EVAL` to become the new `ast`. I had to + reread this a few more times to understand that the "second `ast`" + is actually its third argument... +- Where did the check for `do` not being broken by TCO go? +- What's the deal with the `quux/tests/step5_tco.qx` file? + +# Step 6 + +- "The closure calls the your EVAL function […]." +- I still don't have any closures. How the heck do I implement + `eval`? What about `swap!`? +- It would be useful to mention that `swap!` sort of requires + implementing `apply` first... + +# Step 7 + +- Why the scare quotes for splicing? +- "Before implementing the quoting forms, you will need to implement + some supporting functions in the core namespace:" should be one list + item +- "this function takes a list as its second parameter and returns a + new list that has the first argument prepended to it." reads backwards +- The quasiquote paragraph is hard to read +- It's rather confusing to refer to the argument of `ast` and to an + `ast` parameter, perhaps name the latter a form? +- What could also help would be a visualization of the four + conditionals: + - \`42, \`() + - \`~foo + - \`(~@foo) and more + - \`(42 ~@foo) and everything else +- Mal/mal is inconsistently capitalized +- "Expand the conditional with reader `read_form` function to add the + following four cases" is again weird, better refer to the + `read_form` function in reader.qx +- "concat should support concatenation of lists, vectors, or a mix or + both." <- "or a mix or both" is redundant + +# Step 8 + +- "In the previous step, quoting enabled some simple manipulation [of] + data structures" +- The macroexpand function step refers to call/apply, it's unclear how + to proceed if you don't have such a thing +- How should the exception for invalid `nth` access look like? Also, + why is it an exception and not an error like with the reader? +- How can `first` take a list (or vector), but work on `nil`? +- The description of `rest` is inconsistent with the tests +- "In the main program, use the rep function to define two new control + structures macros." +- Why does the definition of `cond` use `throw` although it's only + introduced in the next chapter? + +# Step 9 + +- It's not really clear that you really just have a `try*` special + form, with `catch*` merely existing inside it... +- Another thing to clarify is that the exception value is a string + containing the message you'd see (unless you're using `throw`) +- Generally, it would be better to explain the general exception + handling mechanism (with some examples), then showing how one + implements it for both languages with and without exceptions +- Another way than using a global variable is introducing an error + type next to the other MAL types and checking whether something a + function returned is one, although the hint about returning one at + each use of `EVAL` still stands... +- Shouldn't either trick be mentioned at the beginning, simply because + you'll need it in a language without exceptions to do error handling? +- Why this bizarre treatment for `keyword`? Why is there no test for + it? +- Is there a test for whether hash maps deduplicate identical keys + when using `hash-map` or `assoc`? +- What exactly are keys the specification for `dissoc`, `get` and + `contains?` are speaking of? Can I assume these are either strings + or keywords? +- Why is it not documented that `get` may take `nil` instead of a map? +- Perhaps it's worth adding more tests involving symbols to ensure + that functions using apply internally don't evaluate their args? + +# Step A + +- "Add meta-data support to mal functions." <- Shouldn't you mention + that this involves implementing `with-meta` and `meta`? +- "TODO. Should be separate from the function macro flag." <- Why is + this even related? +- It would be worth to mention that `with-meta` shall clone its + argument to avoid one of the more sneaky test failure reasons +- "The value of this entry should be a mal string containing the name + of the current implementation." +- "When the REPL starts up (as opposed to when it is called with a + script and/or arguments), call the rep function with this string to + print a startup header: `"(println (str \"Mal + [\" *host-language* \"]\"))".`" <- proof that you better quote these + because the asterisks just disappear... diff --git a/impls/chuck/printer.ck b/impls/chuck/printer.ck index 6895609cb0..9a9033d6fc 100644 --- a/impls/chuck/printer.ck +++ b/impls/chuck/printer.ck @@ -1,76 +1,76 @@ -public class Printer -{ - fun static string pr_str(MalObject m, int print_readably) - { - m.type => string type; - - if( type == "true" || type == "false" || type == "nil" ) - { - return type; - } - else if( type == "int" ) - { - return Std.itoa((m$MalInt).value()); - } - else if( type == "string" ) - { - (m$MalString).value() => string value; - if( print_readably ) - { - return String.repr(value); - } - else - { - return value; - } - } - else if( type == "symbol" ) - { - return (m$MalSymbol).value(); - } - else if( type == "keyword" ) - { - return ":" + (m$MalKeyword).value(); - } - else if( type == "atom" ) - { - return "(atom " + pr_str((m$MalAtom).value(), print_readably) + ")"; - } - else if( type == "subr" ) - { - return "#"; - } - else if( type == "func" ) - { - return "#"; - } - else if( type == "list" ) - { - return pr_list((m$MalList).value(), print_readably, "(", ")"); - } - else if( type == "vector" ) - { - return pr_list((m$MalVector).value(), print_readably, "[", "]"); - } - else if( type == "hashmap" ) - { - return pr_list((m$MalHashMap).value(), print_readably, "{", "}"); - } - else - { - return "Unknown type"; - } - } - - fun static string pr_list(MalObject m[], int print_readably, string start, string end) - { - string parts[m.size()]; - - for( 0 => int i; i < m.size(); i++ ) - { - pr_str(m[i], print_readably) => parts[i]; - } - - return start + String.join(parts, " ") + end; - } -} +public class Printer +{ + fun static string pr_str(MalObject m, int print_readably) + { + m.type => string type; + + if( type == "true" || type == "false" || type == "nil" ) + { + return type; + } + else if( type == "int" ) + { + return Std.itoa((m$MalInt).value()); + } + else if( type == "string" ) + { + (m$MalString).value() => string value; + if( print_readably ) + { + return String.repr(value); + } + else + { + return value; + } + } + else if( type == "symbol" ) + { + return (m$MalSymbol).value(); + } + else if( type == "keyword" ) + { + return ":" + (m$MalKeyword).value(); + } + else if( type == "atom" ) + { + return "(atom " + pr_str((m$MalAtom).value(), print_readably) + ")"; + } + else if( type == "subr" ) + { + return "#"; + } + else if( type == "func" ) + { + return "#"; + } + else if( type == "list" ) + { + return pr_list((m$MalList).value(), print_readably, "(", ")"); + } + else if( type == "vector" ) + { + return pr_list((m$MalVector).value(), print_readably, "[", "]"); + } + else if( type == "hashmap" ) + { + return pr_list((m$MalHashMap).value(), print_readably, "{", "}"); + } + else + { + return "Unknown type"; + } + } + + fun static string pr_list(MalObject m[], int print_readably, string start, string end) + { + string parts[m.size()]; + + for( 0 => int i; i < m.size(); i++ ) + { + pr_str(m[i], print_readably) => parts[i]; + } + + return start + String.join(parts, " ") + end; + } +} diff --git a/impls/chuck/reader.ck b/impls/chuck/reader.ck index 529a0acd62..b4e17793bc 100644 --- a/impls/chuck/reader.ck +++ b/impls/chuck/reader.ck @@ -1,240 +1,240 @@ -public class Reader -{ - 0 => int position; - string tokens[]; - - fun string peek() - { - return tokens[position]; - } - - fun string next() - { - return tokens[position++]; - } - - fun static string[] tokenizer(string input) - { - "^[ \n,]*(~@|[][{}()'`~^@]|\"(\\\\.|[^\\\"])*\"|;[^\n]*|[^][ \n{}()'`~@,;\"]*)" => string tokenRe; - "^([ \n,]*|;[^\n]*)$" => string blankRe; - - string tokens[0]; - - while( true ) - { - string matches[1]; - RegEx.match(tokenRe, input, matches); - matches[1] => string token; - - if( token.length() == 0 && !RegEx.match(blankRe, input) ) - { - tokens << input; - break; - } - - if( !RegEx.match(blankRe, token) ) - { - tokens << token; - } - - matches[0].length() => int tokenStart; - String.slice(input, tokenStart) => input; - - if( input.length() == 0 ) - { - break; - } - } - - return tokens; - } - - fun static MalObject read_str(string input) - { - Reader reader; - tokenizer(input) @=> reader.tokens; - - if( reader.tokens.size() == 0 ) - { - return MalError.create(MalString.create("empty input")); - } - else - { - return read_form(reader); - } - } - - fun static MalObject read_form(Reader reader) - { - reader.peek() => string token; - if( token == "(" ) - { - return read_list(reader, "(", ")"); - } - else if( token == "[" ) - { - return read_list(reader, "[", "]"); - } - else if( token == "{" ) - { - return read_list(reader, "{", "}"); - } - else if( token == ")" || token == "]" || token == "}" ) - { - return MalError.create(MalString.create("unexpected '" + token + "'")); - } - else if( token == "'" ) - { - return read_simple_reader_macro(reader, "quote"); - } - else if( token == "`" ) - { - return read_simple_reader_macro(reader, "quasiquote"); - } - else if( token == "~" ) - { - return read_simple_reader_macro(reader, "unquote"); - } - else if( token == "~@" ) - { - return read_simple_reader_macro(reader, "splice-unquote"); - } - else if( token == "@" ) - { - return read_simple_reader_macro(reader, "deref"); - } - else if( token == "^" ) - { - return read_meta_reader_macro(reader); - } - else - { - return read_atom(reader); - } - } - - fun static MalObject read_list(Reader reader, string start, string end) - { - MalObject items[0]; - - reader.next(); // discard list start token - - while( true ) - { - // HACK: avoid checking for reader.peek() returning null - // (as doing that directly isn't possible and too - // bothersome to do indirectly) - if( reader.position == reader.tokens.size() ) - { - return MalError.create(MalString.create("expected '" + end + "', got EOF")); - } - - if( reader.peek() == end ) - { - break; - } - - read_form(reader) @=> MalObject item; - - if( item.type == "error" ) - { - return item; - } - else - { - items << item; - } - } - - reader.next(); // discard list end token - - if( start == "(" ) - { - return MalList.create(items); - } - else if( start == "[" ) - { - return MalVector.create(items); - } - else if( start == "{" ) - { - return MalHashMap.create(items); - } - } - - fun static MalObject read_atom(Reader reader) - { - "^[+-]?[0-9]+$" => string intRe; - "^\"(\\\\.|[^\\\"])*\"$" => string stringRe; - - reader.next() => string token; - - if( token == "true" ) - { - return Constants.TRUE; - } - else if( token == "false" ) - { - return Constants.FALSE; - } - else if( token == "nil" ) - { - return Constants.NIL; - } - else if( RegEx.match(intRe, token) ) - { - return MalInt.create(Std.atoi(token)); - } - else if( token.substring(0, 1) == "\"" ) - { - if( RegEx.match(stringRe, token) ) - { - return MalString.create(String.parse(token)); - } - else - { - return MalError.create(MalString.create("expected '\"', got EOF")); - } - } - else if( token.substring(0, 1) == ":" ) - { - return MalKeyword.create(String.slice(token, 1)); - } - else - { - return MalSymbol.create(token); - } - } - - fun static MalObject read_simple_reader_macro(Reader reader, string symbol) - { - reader.next(); // discard reader macro token - - read_form(reader) @=> MalObject form; - if( form.type == "error" ) - { - return form; - } - - return MalList.create([MalSymbol.create(symbol), form]); - } - - fun static MalObject read_meta_reader_macro(Reader reader) - { - reader.next(); // discard reader macro token - - read_form(reader) @=> MalObject meta; - if( meta.type == "error" ) - { - return meta; - } - - read_form(reader) @=> MalObject form; - if( form.type == "error" ) - { - return meta; - } - - return MalList.create([MalSymbol.create("with-meta"), form, meta]); - } -} +public class Reader +{ + 0 => int position; + string tokens[]; + + fun string peek() + { + return tokens[position]; + } + + fun string next() + { + return tokens[position++]; + } + + fun static string[] tokenizer(string input) + { + "^[ \n,]*(~@|[][{}()'`~^@]|\"(\\\\.|[^\\\"])*\"|;[^\n]*|[^][ \n{}()'`~@,;\"]*)" => string tokenRe; + "^([ \n,]*|;[^\n]*)$" => string blankRe; + + string tokens[0]; + + while( true ) + { + string matches[1]; + RegEx.match(tokenRe, input, matches); + matches[1] => string token; + + if( token.length() == 0 && !RegEx.match(blankRe, input) ) + { + tokens << input; + break; + } + + if( !RegEx.match(blankRe, token) ) + { + tokens << token; + } + + matches[0].length() => int tokenStart; + String.slice(input, tokenStart) => input; + + if( input.length() == 0 ) + { + break; + } + } + + return tokens; + } + + fun static MalObject read_str(string input) + { + Reader reader; + tokenizer(input) @=> reader.tokens; + + if( reader.tokens.size() == 0 ) + { + return MalError.create(MalString.create("empty input")); + } + else + { + return read_form(reader); + } + } + + fun static MalObject read_form(Reader reader) + { + reader.peek() => string token; + if( token == "(" ) + { + return read_list(reader, "(", ")"); + } + else if( token == "[" ) + { + return read_list(reader, "[", "]"); + } + else if( token == "{" ) + { + return read_list(reader, "{", "}"); + } + else if( token == ")" || token == "]" || token == "}" ) + { + return MalError.create(MalString.create("unexpected '" + token + "'")); + } + else if( token == "'" ) + { + return read_simple_reader_macro(reader, "quote"); + } + else if( token == "`" ) + { + return read_simple_reader_macro(reader, "quasiquote"); + } + else if( token == "~" ) + { + return read_simple_reader_macro(reader, "unquote"); + } + else if( token == "~@" ) + { + return read_simple_reader_macro(reader, "splice-unquote"); + } + else if( token == "@" ) + { + return read_simple_reader_macro(reader, "deref"); + } + else if( token == "^" ) + { + return read_meta_reader_macro(reader); + } + else + { + return read_atom(reader); + } + } + + fun static MalObject read_list(Reader reader, string start, string end) + { + MalObject items[0]; + + reader.next(); // discard list start token + + while( true ) + { + // HACK: avoid checking for reader.peek() returning null + // (as doing that directly isn't possible and too + // bothersome to do indirectly) + if( reader.position == reader.tokens.size() ) + { + return MalError.create(MalString.create("expected '" + end + "', got EOF")); + } + + if( reader.peek() == end ) + { + break; + } + + read_form(reader) @=> MalObject item; + + if( item.type == "error" ) + { + return item; + } + else + { + items << item; + } + } + + reader.next(); // discard list end token + + if( start == "(" ) + { + return MalList.create(items); + } + else if( start == "[" ) + { + return MalVector.create(items); + } + else if( start == "{" ) + { + return MalHashMap.create(items); + } + } + + fun static MalObject read_atom(Reader reader) + { + "^[+-]?[0-9]+$" => string intRe; + "^\"(\\\\.|[^\\\"])*\"$" => string stringRe; + + reader.next() => string token; + + if( token == "true" ) + { + return Constants.TRUE; + } + else if( token == "false" ) + { + return Constants.FALSE; + } + else if( token == "nil" ) + { + return Constants.NIL; + } + else if( RegEx.match(intRe, token) ) + { + return MalInt.create(Std.atoi(token)); + } + else if( token.substring(0, 1) == "\"" ) + { + if( RegEx.match(stringRe, token) ) + { + return MalString.create(String.parse(token)); + } + else + { + return MalError.create(MalString.create("expected '\"', got EOF")); + } + } + else if( token.substring(0, 1) == ":" ) + { + return MalKeyword.create(String.slice(token, 1)); + } + else + { + return MalSymbol.create(token); + } + } + + fun static MalObject read_simple_reader_macro(Reader reader, string symbol) + { + reader.next(); // discard reader macro token + + read_form(reader) @=> MalObject form; + if( form.type == "error" ) + { + return form; + } + + return MalList.create([MalSymbol.create(symbol), form]); + } + + fun static MalObject read_meta_reader_macro(Reader reader) + { + reader.next(); // discard reader macro token + + read_form(reader) @=> MalObject meta; + if( meta.type == "error" ) + { + return meta; + } + + read_form(reader) @=> MalObject form; + if( form.type == "error" ) + { + return meta; + } + + return MalList.create([MalSymbol.create("with-meta"), form, meta]); + } +} diff --git a/impls/chuck/readline.ck b/impls/chuck/readline.ck index 7f3881ac14..075eb56b85 100644 --- a/impls/chuck/readline.ck +++ b/impls/chuck/readline.ck @@ -1,72 +1,72 @@ -public class Readline -{ - fun static string readline(string prompt) - { - int done; - string input; - KBHit kb; - int char; - string repr; - - ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", - "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", - "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", - "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", - " ", "!", "\"", "#", "$", "%", "&", "'", - "(", ")", "*", "+", ",", "-", ".", "/", - "0", "1", "2", "3", "4", "5", "6", "7", - "8", "9", ":", ";", "<", "=", ">", "?", - "@", "A", "B", "C", "D", "E", "F", "G", - "H", "I", "J", "K", "L", "M", "N", "O", - "P", "Q", "R", "S", "T", "U", "V", "W", - "X", "Y", "Z", "[", "\\", "]", "^", "_", - "`", "a", "b", "c", "d", "e", "f", "g", - "h", "i", "j", "k", "l", "m", "n", "o", - "p", "q", "r", "s", "t", "u", "v", "w", - "x", "y", "z", "{", "|", "}", "~", "DEL"] @=> string asciiTable[]; - - chout <= prompt; - chout.flush(); - - while( !done ) - { - kb => now; - - while( kb.more() && !done ) - { - kb.getchar() => char; - asciiTable[char] => repr; - - if( repr == "EOT" || repr == "LF" || repr == "CR" ) - { - true => done; - } - else if( repr == "DEL" && Std.getenv("TERM") != "dumb") - { - if( input.length() > 0) - { - chout <= "\033[1D\033[0K"; - chout.flush(); - input.substring(0, input.length()-1) => input; - } - } - else - { - chout <= repr; - chout.flush(); - repr +=> input; - } - } - } - - chout <= "\n"; - - if( repr == "EOT" ) - { - return null; - } - - return input; - } -} - +public class Readline +{ + fun static string readline(string prompt) + { + int done; + string input; + KBHit kb; + int char; + string repr; + + ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", + "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", + "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", + "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", + " ", "!", "\"", "#", "$", "%", "&", "'", + "(", ")", "*", "+", ",", "-", ".", "/", + "0", "1", "2", "3", "4", "5", "6", "7", + "8", "9", ":", ";", "<", "=", ">", "?", + "@", "A", "B", "C", "D", "E", "F", "G", + "H", "I", "J", "K", "L", "M", "N", "O", + "P", "Q", "R", "S", "T", "U", "V", "W", + "X", "Y", "Z", "[", "\\", "]", "^", "_", + "`", "a", "b", "c", "d", "e", "f", "g", + "h", "i", "j", "k", "l", "m", "n", "o", + "p", "q", "r", "s", "t", "u", "v", "w", + "x", "y", "z", "{", "|", "}", "~", "DEL"] @=> string asciiTable[]; + + chout <= prompt; + chout.flush(); + + while( !done ) + { + kb => now; + + while( kb.more() && !done ) + { + kb.getchar() => char; + asciiTable[char] => repr; + + if( repr == "EOT" || repr == "LF" || repr == "CR" ) + { + true => done; + } + else if( repr == "DEL" && Std.getenv("TERM") != "dumb") + { + if( input.length() > 0) + { + chout <= "\033[1D\033[0K"; + chout.flush(); + input.substring(0, input.length()-1) => input; + } + } + else + { + chout <= repr; + chout.flush(); + repr +=> input; + } + } + } + + chout <= "\n"; + + if( repr == "EOT" ) + { + return null; + } + + return input; + } +} + diff --git a/impls/chuck/run b/impls/chuck/run index 51d120c416..d5d61975ed 100755 --- a/impls/chuck/run +++ b/impls/chuck/run @@ -1,5 +1,5 @@ -#!/bin/bash -imports=$(grep "^ *// *@import" "$(dirname $0)/${STEP:-stepA_mal}.ck" | awk '{print $3}') -imports=$(for i in ${imports}; do ls $(dirname $0)/${i}; done) -old_IFS="${IFS}"; IFS=$'\a'; export CHUCK_ARGS="${*}"; IFS="${old_IFS}" -exec chuck --caution-to-the-wind --silent ${imports} $(dirname $0)/${STEP:-stepA_mal}.ck +#!/bin/bash +imports=$(grep "^ *// *@import" "$(dirname $0)/${STEP:-stepA_mal}.ck" | awk '{print $3}') +imports=$(for i in ${imports}; do ls $(dirname $0)/${i}; done) +old_IFS="${IFS}"; IFS=$'\a'; export CHUCK_ARGS="${*}"; IFS="${old_IFS}" +exec chuck --caution-to-the-wind --silent ${imports} $(dirname $0)/${STEP:-stepA_mal}.ck diff --git a/impls/chuck/step0_repl.ck b/impls/chuck/step0_repl.ck index 7591170706..38edba403d 100644 --- a/impls/chuck/step0_repl.ck +++ b/impls/chuck/step0_repl.ck @@ -1,42 +1,42 @@ -// @import readline.ck - -fun string READ(string input) -{ - return input; -} - -fun string EVAL(string input) -{ - return input; -} - -fun string PRINT(string input) -{ - return input; -} - -fun string rep(string input) -{ - return input => READ => EVAL => PRINT; -} - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - chout <= rep(input) + "\n"; - } - else - { - true => done; - } - } -} - -main(); +// @import readline.ck + +fun string READ(string input) +{ + return input; +} + +fun string EVAL(string input) +{ + return input; +} + +fun string PRINT(string input) +{ + return input; +} + +fun string rep(string input) +{ + return input => READ => EVAL => PRINT; +} + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + chout <= rep(input) + "\n"; + } + else + { + true => done; + } + } +} + +main(); diff --git a/impls/chuck/step1_read_print.ck b/impls/chuck/step1_read_print.ck index 103d03ba9b..5239ad521e 100644 --- a/impls/chuck/step1_read_print.ck +++ b/impls/chuck/step1_read_print.ck @@ -1,83 +1,83 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun MalObject EVAL(MalObject m) -{ - return m; -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - else - { - return PRINT(EVAL(m)); - } -} - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -main(); +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun MalObject EVAL(MalObject m) +{ + return m; +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + else + { + return PRINT(EVAL(m)); + } +} + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +main(); diff --git a/impls/chuck/step2_eval.ck b/impls/chuck/step2_eval.ck index 2d740a7467..b1fca9338d 100644 --- a/impls/chuck/step2_eval.ck +++ b/impls/chuck/step2_eval.ck @@ -1,190 +1,190 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck -// @import env.ck -// @import func.ck -// @import types/MalSubr.ck -// @import types/subr/*.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun MalObject EVAL(MalObject m, MalSubr env[]) -{ - if( m.type == "list" ) - { - if( (m$MalList).value().size() == 0 ) - { - return m; - } - - eval_ast(m, env) @=> MalObject result; - if( result.type == "error" ) - { - return result; - } - - (result$MalList).value() @=> MalObject values[]; - values[0]$MalSubr @=> MalSubr subr; - MalObject.slice(values, 1) @=> MalObject args[]; - - return subr.call(args); - } - else - { - return eval_ast(m, env); - } -} - -fun MalObject eval_ast(MalObject m, MalSubr env[]) -{ - m.type => string type; - - if( type == "symbol" ) - { - (m$MalSymbol).value() => string symbol; - env[symbol] @=> MalSubr subr; - - if( subr == null ) - { - return MalError.create(MalString.create("'" + symbol + "' not found")); - } - else - { - return subr; - } - } - else if( type == "list" || type == "vector" || type == "hashmap" ) - { - (m$MalList).value() @=> MalObject values[]; - MalObject results[values.size()]; - - if( type != "hashmap" ) - { - for( 0 => int i; i < values.size(); i++ ) - { - EVAL(values[i], env) @=> MalObject result; - - if( result.type == "error" ) - { - return result; - } - - result @=> results[i]; - } - } - else - { - for( 0 => int i; i < values.size(); i++ ) - { - if( i % 2 == 0 ) - { - values[i] @=> results[i]; - } - else - { - EVAL(values[i], env) @=> results[i]; - } - } - } - - if( type == "list" ) - { - return MalList.create(results); - } - else if( type == "vector" ) - { - return MalVector.create(results); - } - else if( type == "hashmap" ) - { - return MalHashMap.create(results); - } - } - else - { - return m; - } -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -MalSubr repl_env[0]; -new MalAdd @=> repl_env["+"]; -new MalSub @=> repl_env["-"]; -new MalMul @=> repl_env["*"]; -new MalDiv @=> repl_env["/"]; - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - - EVAL(m, repl_env) @=> MalObject result; - if( result.type == "error" ) - { - return errorMessage(result); - } - - return PRINT(result); -} - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -main(); +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck +// @import env.ck +// @import func.ck +// @import types/MalSubr.ck +// @import types/subr/*.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun MalObject EVAL(MalObject m, MalSubr env[]) +{ + if( m.type == "list" ) + { + if( (m$MalList).value().size() == 0 ) + { + return m; + } + + eval_ast(m, env) @=> MalObject result; + if( result.type == "error" ) + { + return result; + } + + (result$MalList).value() @=> MalObject values[]; + values[0]$MalSubr @=> MalSubr subr; + MalObject.slice(values, 1) @=> MalObject args[]; + + return subr.call(args); + } + else + { + return eval_ast(m, env); + } +} + +fun MalObject eval_ast(MalObject m, MalSubr env[]) +{ + m.type => string type; + + if( type == "symbol" ) + { + (m$MalSymbol).value() => string symbol; + env[symbol] @=> MalSubr subr; + + if( subr == null ) + { + return MalError.create(MalString.create("'" + symbol + "' not found")); + } + else + { + return subr; + } + } + else if( type == "list" || type == "vector" || type == "hashmap" ) + { + (m$MalList).value() @=> MalObject values[]; + MalObject results[values.size()]; + + if( type != "hashmap" ) + { + for( 0 => int i; i < values.size(); i++ ) + { + EVAL(values[i], env) @=> MalObject result; + + if( result.type == "error" ) + { + return result; + } + + result @=> results[i]; + } + } + else + { + for( 0 => int i; i < values.size(); i++ ) + { + if( i % 2 == 0 ) + { + values[i] @=> results[i]; + } + else + { + EVAL(values[i], env) @=> results[i]; + } + } + } + + if( type == "list" ) + { + return MalList.create(results); + } + else if( type == "vector" ) + { + return MalVector.create(results); + } + else if( type == "hashmap" ) + { + return MalHashMap.create(results); + } + } + else + { + return m; + } +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +MalSubr repl_env[0]; +new MalAdd @=> repl_env["+"]; +new MalSub @=> repl_env["-"]; +new MalMul @=> repl_env["*"]; +new MalDiv @=> repl_env["/"]; + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + + EVAL(m, repl_env) @=> MalObject result; + if( result.type == "error" ) + { + return errorMessage(result); + } + + return PRINT(result); +} + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +main(); diff --git a/impls/chuck/step3_env.ck b/impls/chuck/step3_env.ck index ad8de3c7bd..42eff71113 100644 --- a/impls/chuck/step3_env.ck +++ b/impls/chuck/step3_env.ck @@ -1,219 +1,219 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck -// @import env.ck -// @import func.ck -// @import types/MalSubr.ck -// @import types/subr/*.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun MalObject EVAL(MalObject m, Env env) -{ - if( m.type == "list" ) - { - if( (m$MalList).value().size() == 0 ) - { - return m; - } - - (m$MalList).value() @=> MalObject ast[]; - (ast[0]$MalSymbol).value() => string a0; - - if( a0 == "def!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - env.set(a1, value); - return value; - } - else if( a0 == "let*" ) - { - Env.create(env) @=> Env let_env; - Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; - - for( 0 => int i; i < bindings.size(); 2 +=> i) - { - (bindings[i]$MalSymbol).value() => string symbol; - EVAL(bindings[i+1], let_env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - let_env.set(symbol, value); - } - - return EVAL(ast[2], let_env); - } - - eval_ast(m, env) @=> MalObject result; - if( result.type == "error" ) - { - return result; - } - - (result$MalList).value() @=> MalObject values[]; - values[0]$MalSubr @=> MalSubr subr; - MalObject.slice(values, 1) @=> MalObject args[]; - - return subr.call(args); - } - else - { - eval_ast(m, env) @=> MalObject result; - return result; - } -} - -fun MalObject eval_ast(MalObject m, Env env) -{ - m.type => string type; - - if( type == "symbol" ) - { - (m$MalSymbol).value() => string symbol; - return env.get(symbol); - } - else if( type == "list" || type == "vector" || type == "hashmap" ) - { - (m$MalList).value() @=> MalObject values[]; - MalObject results[values.size()]; - - if( type != "hashmap" ) - { - for( 0 => int i; i < values.size(); i++ ) - { - EVAL(values[i], env) @=> MalObject result; - - if( result.type == "error" ) - { - return result; - } - - result @=> results[i]; - } - } - else - { - for( 0 => int i; i < values.size(); i++ ) - { - if( i % 2 == 0 ) - { - values[i] @=> results[i]; - } - else - { - EVAL(values[i], env) @=> results[i]; - } - } - } - - if( type == "list" ) - { - return MalList.create(results); - } - else if( type == "vector" ) - { - return MalVector.create(results); - } - else if( type == "hashmap" ) - { - return MalHashMap.create(results); - } - } - else - { - return m; - } -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -Env.create(null) @=> Env repl_env; -repl_env.set("+", new MalAdd); -repl_env.set("-", new MalSub); -repl_env.set("*", new MalMul); -repl_env.set("/", new MalDiv); - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - - EVAL(m, repl_env) @=> MalObject result; - if( result.type == "error" ) - { - return errorMessage(result); - } - - return PRINT(result); -} - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -main(); +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck +// @import env.ck +// @import func.ck +// @import types/MalSubr.ck +// @import types/subr/*.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun MalObject EVAL(MalObject m, Env env) +{ + if( m.type == "list" ) + { + if( (m$MalList).value().size() == 0 ) + { + return m; + } + + (m$MalList).value() @=> MalObject ast[]; + (ast[0]$MalSymbol).value() => string a0; + + if( a0 == "def!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + env.set(a1, value); + return value; + } + else if( a0 == "let*" ) + { + Env.create(env) @=> Env let_env; + Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; + + for( 0 => int i; i < bindings.size(); 2 +=> i) + { + (bindings[i]$MalSymbol).value() => string symbol; + EVAL(bindings[i+1], let_env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + let_env.set(symbol, value); + } + + return EVAL(ast[2], let_env); + } + + eval_ast(m, env) @=> MalObject result; + if( result.type == "error" ) + { + return result; + } + + (result$MalList).value() @=> MalObject values[]; + values[0]$MalSubr @=> MalSubr subr; + MalObject.slice(values, 1) @=> MalObject args[]; + + return subr.call(args); + } + else + { + eval_ast(m, env) @=> MalObject result; + return result; + } +} + +fun MalObject eval_ast(MalObject m, Env env) +{ + m.type => string type; + + if( type == "symbol" ) + { + (m$MalSymbol).value() => string symbol; + return env.get(symbol); + } + else if( type == "list" || type == "vector" || type == "hashmap" ) + { + (m$MalList).value() @=> MalObject values[]; + MalObject results[values.size()]; + + if( type != "hashmap" ) + { + for( 0 => int i; i < values.size(); i++ ) + { + EVAL(values[i], env) @=> MalObject result; + + if( result.type == "error" ) + { + return result; + } + + result @=> results[i]; + } + } + else + { + for( 0 => int i; i < values.size(); i++ ) + { + if( i % 2 == 0 ) + { + values[i] @=> results[i]; + } + else + { + EVAL(values[i], env) @=> results[i]; + } + } + } + + if( type == "list" ) + { + return MalList.create(results); + } + else if( type == "vector" ) + { + return MalVector.create(results); + } + else if( type == "hashmap" ) + { + return MalHashMap.create(results); + } + } + else + { + return m; + } +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +Env.create(null) @=> Env repl_env; +repl_env.set("+", new MalAdd); +repl_env.set("-", new MalSub); +repl_env.set("*", new MalMul); +repl_env.set("/", new MalDiv); + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + + EVAL(m, repl_env) @=> MalObject result; + if( result.type == "error" ) + { + return errorMessage(result); + } + + return PRINT(result); +} + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +main(); diff --git a/impls/chuck/step4_if_fn_do.ck b/impls/chuck/step4_if_fn_do.ck index dd6c92507e..f1c42ecfdc 100644 --- a/impls/chuck/step4_if_fn_do.ck +++ b/impls/chuck/step4_if_fn_do.ck @@ -1,290 +1,290 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck -// @import env.ck -// @import func.ck -// @import types/MalSubr.ck -// @import types/subr/*.ck -// @import core.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun MalObject EVAL(MalObject m, Env env) -{ - if( m.type == "list" ) - { - if( (m$MalList).value().size() == 0 ) - { - return m; - } - - (m$MalList).value() @=> MalObject ast[]; - - if( ast[0].type == "symbol" ) - { - (ast[0]$MalSymbol).value() => string a0; - - if( a0 == "def!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - env.set(a1, value); - return value; - } - else if( a0 == "let*" ) - { - Env.create(env) @=> Env let_env; - Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; - - for( 0 => int i; i < bindings.size(); 2 +=> i) - { - (bindings[i]$MalSymbol).value() => string symbol; - EVAL(bindings[i+1], let_env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - let_env.set(symbol, value); - } - - return EVAL(ast[2], let_env); - } - else if( a0 == "do" ) - { - MalObject.slice(ast, 1) @=> MalObject forms[]; - eval_ast(MalList.create(forms), env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - (value$MalList).value() @=> MalObject values[]; - - return values[values.size()-1]; - } - else if( a0 == "if" ) - { - EVAL(ast[1], env) @=> MalObject condition; - - if( condition.type == "error" ) - { - return condition; - } - - if( !(condition.type == "nil") && !(condition.type == "false") ) - { - return EVAL(ast[2], env); - } - else - { - if( ast.size() < 4 ) - { - return Constants.NIL; - } - else - { - return EVAL(ast[3], env); - } - } - } - else if( a0 == "fn*" ) - { - (ast[1]$MalList).value() @=> MalObject arg_values[]; - string args[arg_values.size()]; - - for( 0 => int i; i < arg_values.size(); i++ ) - { - (arg_values[i]$MalSymbol).value() => args[i]; - } - - ast[2] @=> MalObject _ast; - - return Func.create(env, args, _ast); - } - } - - eval_ast(m, env) @=> MalObject result; - if( result.type == "error" ) - { - return result; - } - - (result$MalList).value() @=> MalObject values[]; - values[0].type => string type; - MalObject.slice(values, 1) @=> MalObject args[]; - - if( type == "subr" ) - { - values[0]$MalSubr @=> MalSubr subr; - return subr.call(args); - } - else // type == "func" - { - values[0]$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - return EVAL(func.ast, eval_env); - } - } - else - { - eval_ast(m, env) @=> MalObject result; - return result; - } -} - -fun MalObject eval_ast(MalObject m, Env env) -{ - m.type => string type; - - if( type == "symbol" ) - { - (m$MalSymbol).value() => string symbol; - return env.get(symbol); - } - else if( type == "list" || type == "vector" || type == "hashmap" ) - { - (m$MalList).value() @=> MalObject values[]; - MalObject results[values.size()]; - - if( type != "hashmap" ) - { - for( 0 => int i; i < values.size(); i++ ) - { - EVAL(values[i], env) @=> MalObject result; - - if( result.type == "error" ) - { - return result; - } - - result @=> results[i]; - } - } - else - { - for( 0 => int i; i < values.size(); i++ ) - { - if( i % 2 == 0 ) - { - values[i] @=> results[i]; - } - else - { - EVAL(values[i], env) @=> results[i]; - } - } - } - - if( type == "list" ) - { - return MalList.create(results); - } - else if( type == "vector" ) - { - return MalVector.create(results); - } - else if( type == "hashmap" ) - { - return MalHashMap.create(results); - } - } - else - { - return m; - } -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -Env.create(null) @=> Env repl_env; -for( 0 => int i; i < Core.names.size(); i++ ) -{ - Core.names[i] => string name; - repl_env.set(name, Core.ns[name]); -} - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - - EVAL(m, repl_env) @=> MalObject result; - if( result.type == "error" ) - { - return errorMessage(result); - } - - return PRINT(result); -} - -rep("(def! not (fn* (a) (if a false true)))"); - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -main(); +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck +// @import env.ck +// @import func.ck +// @import types/MalSubr.ck +// @import types/subr/*.ck +// @import core.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun MalObject EVAL(MalObject m, Env env) +{ + if( m.type == "list" ) + { + if( (m$MalList).value().size() == 0 ) + { + return m; + } + + (m$MalList).value() @=> MalObject ast[]; + + if( ast[0].type == "symbol" ) + { + (ast[0]$MalSymbol).value() => string a0; + + if( a0 == "def!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + env.set(a1, value); + return value; + } + else if( a0 == "let*" ) + { + Env.create(env) @=> Env let_env; + Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; + + for( 0 => int i; i < bindings.size(); 2 +=> i) + { + (bindings[i]$MalSymbol).value() => string symbol; + EVAL(bindings[i+1], let_env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + let_env.set(symbol, value); + } + + return EVAL(ast[2], let_env); + } + else if( a0 == "do" ) + { + MalObject.slice(ast, 1) @=> MalObject forms[]; + eval_ast(MalList.create(forms), env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + (value$MalList).value() @=> MalObject values[]; + + return values[values.size()-1]; + } + else if( a0 == "if" ) + { + EVAL(ast[1], env) @=> MalObject condition; + + if( condition.type == "error" ) + { + return condition; + } + + if( !(condition.type == "nil") && !(condition.type == "false") ) + { + return EVAL(ast[2], env); + } + else + { + if( ast.size() < 4 ) + { + return Constants.NIL; + } + else + { + return EVAL(ast[3], env); + } + } + } + else if( a0 == "fn*" ) + { + (ast[1]$MalList).value() @=> MalObject arg_values[]; + string args[arg_values.size()]; + + for( 0 => int i; i < arg_values.size(); i++ ) + { + (arg_values[i]$MalSymbol).value() => args[i]; + } + + ast[2] @=> MalObject _ast; + + return Func.create(env, args, _ast); + } + } + + eval_ast(m, env) @=> MalObject result; + if( result.type == "error" ) + { + return result; + } + + (result$MalList).value() @=> MalObject values[]; + values[0].type => string type; + MalObject.slice(values, 1) @=> MalObject args[]; + + if( type == "subr" ) + { + values[0]$MalSubr @=> MalSubr subr; + return subr.call(args); + } + else // type == "func" + { + values[0]$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + return EVAL(func.ast, eval_env); + } + } + else + { + eval_ast(m, env) @=> MalObject result; + return result; + } +} + +fun MalObject eval_ast(MalObject m, Env env) +{ + m.type => string type; + + if( type == "symbol" ) + { + (m$MalSymbol).value() => string symbol; + return env.get(symbol); + } + else if( type == "list" || type == "vector" || type == "hashmap" ) + { + (m$MalList).value() @=> MalObject values[]; + MalObject results[values.size()]; + + if( type != "hashmap" ) + { + for( 0 => int i; i < values.size(); i++ ) + { + EVAL(values[i], env) @=> MalObject result; + + if( result.type == "error" ) + { + return result; + } + + result @=> results[i]; + } + } + else + { + for( 0 => int i; i < values.size(); i++ ) + { + if( i % 2 == 0 ) + { + values[i] @=> results[i]; + } + else + { + EVAL(values[i], env) @=> results[i]; + } + } + } + + if( type == "list" ) + { + return MalList.create(results); + } + else if( type == "vector" ) + { + return MalVector.create(results); + } + else if( type == "hashmap" ) + { + return MalHashMap.create(results); + } + } + else + { + return m; + } +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +Env.create(null) @=> Env repl_env; +for( 0 => int i; i < Core.names.size(); i++ ) +{ + Core.names[i] => string name; + repl_env.set(name, Core.ns[name]); +} + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + + EVAL(m, repl_env) @=> MalObject result; + if( result.type == "error" ) + { + return errorMessage(result); + } + + return PRINT(result); +} + +rep("(def! not (fn* (a) (if a false true)))"); + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +main(); diff --git a/impls/chuck/step5_tco.ck b/impls/chuck/step5_tco.ck index 33be7e9c18..e64f851f8e 100644 --- a/impls/chuck/step5_tco.ck +++ b/impls/chuck/step5_tco.ck @@ -1,296 +1,296 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck -// @import env.ck -// @import func.ck -// @import types/MalSubr.ck -// @import types/subr/*.ck -// @import core.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun MalObject EVAL(MalObject m, Env env) -{ - while( true ) - { - if( m.type != "list" ) - { - return eval_ast(m, env); - } - - if( (m$MalList).value().size() == 0 ) - { - return m; - } - - (m$MalList).value() @=> MalObject ast[]; - - if( ast[0].type == "symbol" ) - { - (ast[0]$MalSymbol).value() => string a0; - - if( a0 == "def!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - env.set(a1, value); - return value; - } - else if( a0 == "let*" ) - { - Env.create(env) @=> Env let_env; - Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; - - for( 0 => int i; i < bindings.size(); 2 +=> i) - { - (bindings[i]$MalSymbol).value() => string symbol; - EVAL(bindings[i+1], let_env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - let_env.set(symbol, value); - } - - let_env @=> env; - ast[2] @=> m; - continue; // TCO - } - else if( a0 == "do" ) - { - MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; - eval_ast(MalList.create(forms), env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - // HACK: this assumes do gets at least one argument... - ast[ast.size()-1] @=> m; - continue; // TCO - } - else if( a0 == "if" ) - { - EVAL(ast[1], env) @=> MalObject condition; - - if( condition.type == "error" ) - { - return condition; - } - - if( !(condition.type == "nil") && !(condition.type == "false") ) - { - ast[2] @=> m; - continue; // TCO - } - else - { - if( ast.size() < 4 ) - { - return Constants.NIL; - } - else - { - ast[3] @=> m; - continue; // TCO - } - } - } - else if( a0 == "fn*" ) - { - (ast[1]$MalList).value() @=> MalObject arg_values[]; - string args[arg_values.size()]; - - for( 0 => int i; i < arg_values.size(); i++ ) - { - (arg_values[i]$MalSymbol).value() => args[i]; - } - - ast[2] @=> MalObject _ast; - - return Func.create(env, args, _ast); - } - } - - eval_ast(m, env) @=> MalObject result; - if( result.type == "error" ) - { - return result; - } - - (result$MalList).value() @=> MalObject values[]; - values[0].type => string type; - MalObject.slice(values, 1) @=> MalObject args[]; - - if( type == "subr" ) - { - values[0]$MalSubr @=> MalSubr subr; - return subr.call(args); - } - else // type == "func" - { - values[0]$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - eval_env @=> env; - func.ast @=> m; - continue; // TCO - } - } -} - -fun MalObject eval_ast(MalObject m, Env env) -{ - m.type => string type; - - if( type == "symbol" ) - { - (m$MalSymbol).value() => string symbol; - return env.get(symbol); - } - else if( type == "list" || type == "vector" || type == "hashmap" ) - { - (m$MalList).value() @=> MalObject values[]; - MalObject results[values.size()]; - - if( type != "hashmap" ) - { - for( 0 => int i; i < values.size(); i++ ) - { - EVAL(values[i], env) @=> MalObject result; - - if( result.type == "error" ) - { - return result; - } - - result @=> results[i]; - } - } - else - { - for( 0 => int i; i < values.size(); i++ ) - { - if( i % 2 == 0 ) - { - values[i] @=> results[i]; - } - else - { - EVAL(values[i], env) @=> results[i]; - } - } - } - - if( type == "list" ) - { - return MalList.create(results); - } - else if( type == "vector" ) - { - return MalVector.create(results); - } - else if( type == "hashmap" ) - { - return MalHashMap.create(results); - } - } - else - { - return m; - } -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -Env.create(null) @=> Env repl_env; -for( 0 => int i; i < Core.names.size(); i++ ) -{ - Core.names[i] => string name; - repl_env.set(name, Core.ns[name]); -} - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - - EVAL(m, repl_env) @=> MalObject result; - if( result.type == "error" ) - { - return errorMessage(result); - } - - return PRINT(result); -} - -rep("(def! not (fn* (a) (if a false true)))"); - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -main(); +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck +// @import env.ck +// @import func.ck +// @import types/MalSubr.ck +// @import types/subr/*.ck +// @import core.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun MalObject EVAL(MalObject m, Env env) +{ + while( true ) + { + if( m.type != "list" ) + { + return eval_ast(m, env); + } + + if( (m$MalList).value().size() == 0 ) + { + return m; + } + + (m$MalList).value() @=> MalObject ast[]; + + if( ast[0].type == "symbol" ) + { + (ast[0]$MalSymbol).value() => string a0; + + if( a0 == "def!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + env.set(a1, value); + return value; + } + else if( a0 == "let*" ) + { + Env.create(env) @=> Env let_env; + Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; + + for( 0 => int i; i < bindings.size(); 2 +=> i) + { + (bindings[i]$MalSymbol).value() => string symbol; + EVAL(bindings[i+1], let_env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + let_env.set(symbol, value); + } + + let_env @=> env; + ast[2] @=> m; + continue; // TCO + } + else if( a0 == "do" ) + { + MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; + eval_ast(MalList.create(forms), env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + // HACK: this assumes do gets at least one argument... + ast[ast.size()-1] @=> m; + continue; // TCO + } + else if( a0 == "if" ) + { + EVAL(ast[1], env) @=> MalObject condition; + + if( condition.type == "error" ) + { + return condition; + } + + if( !(condition.type == "nil") && !(condition.type == "false") ) + { + ast[2] @=> m; + continue; // TCO + } + else + { + if( ast.size() < 4 ) + { + return Constants.NIL; + } + else + { + ast[3] @=> m; + continue; // TCO + } + } + } + else if( a0 == "fn*" ) + { + (ast[1]$MalList).value() @=> MalObject arg_values[]; + string args[arg_values.size()]; + + for( 0 => int i; i < arg_values.size(); i++ ) + { + (arg_values[i]$MalSymbol).value() => args[i]; + } + + ast[2] @=> MalObject _ast; + + return Func.create(env, args, _ast); + } + } + + eval_ast(m, env) @=> MalObject result; + if( result.type == "error" ) + { + return result; + } + + (result$MalList).value() @=> MalObject values[]; + values[0].type => string type; + MalObject.slice(values, 1) @=> MalObject args[]; + + if( type == "subr" ) + { + values[0]$MalSubr @=> MalSubr subr; + return subr.call(args); + } + else // type == "func" + { + values[0]$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + eval_env @=> env; + func.ast @=> m; + continue; // TCO + } + } +} + +fun MalObject eval_ast(MalObject m, Env env) +{ + m.type => string type; + + if( type == "symbol" ) + { + (m$MalSymbol).value() => string symbol; + return env.get(symbol); + } + else if( type == "list" || type == "vector" || type == "hashmap" ) + { + (m$MalList).value() @=> MalObject values[]; + MalObject results[values.size()]; + + if( type != "hashmap" ) + { + for( 0 => int i; i < values.size(); i++ ) + { + EVAL(values[i], env) @=> MalObject result; + + if( result.type == "error" ) + { + return result; + } + + result @=> results[i]; + } + } + else + { + for( 0 => int i; i < values.size(); i++ ) + { + if( i % 2 == 0 ) + { + values[i] @=> results[i]; + } + else + { + EVAL(values[i], env) @=> results[i]; + } + } + } + + if( type == "list" ) + { + return MalList.create(results); + } + else if( type == "vector" ) + { + return MalVector.create(results); + } + else if( type == "hashmap" ) + { + return MalHashMap.create(results); + } + } + else + { + return m; + } +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +Env.create(null) @=> Env repl_env; +for( 0 => int i; i < Core.names.size(); i++ ) +{ + Core.names[i] => string name; + repl_env.set(name, Core.ns[name]); +} + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + + EVAL(m, repl_env) @=> MalObject result; + if( result.type == "error" ) + { + return errorMessage(result); + } + + return PRINT(result); +} + +rep("(def! not (fn* (a) (if a false true)))"); + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +main(); diff --git a/impls/chuck/step6_file.ck b/impls/chuck/step6_file.ck index fdfe701b23..24716c449e 100644 --- a/impls/chuck/step6_file.ck +++ b/impls/chuck/step6_file.ck @@ -1,349 +1,349 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck -// @import env.ck -// @import func.ck -// @import types/MalSubr.ck -// @import types/subr/*.ck -// @import core.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun MalObject EVAL(MalObject m, Env env) -{ - while( true ) - { - if( m.type != "list" ) - { - return eval_ast(m, env); - } - - if( (m$MalList).value().size() == 0 ) - { - return m; - } - - (m$MalList).value() @=> MalObject ast[]; - - if( ast[0].type == "symbol" ) - { - (ast[0]$MalSymbol).value() => string a0; - - if( a0 == "def!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - env.set(a1, value); - return value; - } - else if( a0 == "let*" ) - { - Env.create(env) @=> Env let_env; - Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; - - for( 0 => int i; i < bindings.size(); 2 +=> i) - { - (bindings[i]$MalSymbol).value() => string symbol; - EVAL(bindings[i+1], let_env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - let_env.set(symbol, value); - } - - let_env @=> env; - ast[2] @=> m; - continue; // TCO - } - else if( a0 == "do" ) - { - MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; - eval_ast(MalList.create(forms), env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - // HACK: this assumes do gets at least one argument... - ast[ast.size()-1] @=> m; - continue; // TCO - } - else if( a0 == "if" ) - { - EVAL(ast[1], env) @=> MalObject condition; - - if( condition.type == "error" ) - { - return condition; - } - - if( !(condition.type == "nil") && !(condition.type == "false") ) - { - ast[2] @=> m; - continue; // TCO - } - else - { - if( ast.size() < 4 ) - { - return Constants.NIL; - } - else - { - ast[3] @=> m; - continue; // TCO - } - } - } - else if( a0 == "fn*" ) - { - (ast[1]$MalList).value() @=> MalObject arg_values[]; - string args[arg_values.size()]; - - for( 0 => int i; i < arg_values.size(); i++ ) - { - (arg_values[i]$MalSymbol).value() => args[i]; - } - - ast[2] @=> MalObject _ast; - - return Func.create(env, args, _ast); - } - } - - eval_ast(m, env) @=> MalObject result; - if( result.type == "error" ) - { - return result; - } - - (result$MalList).value() @=> MalObject values[]; - values[0].type => string type; - MalObject.slice(values, 1) @=> MalObject args[]; - - if( type == "subr" ) - { - values[0]$MalSubr @=> MalSubr subr; - return subr.call(args); - } - else // type == "func" - { - values[0]$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - eval_env @=> env; - func.ast @=> m; - continue; // TCO - } - } -} - -fun MalObject eval_ast(MalObject m, Env env) -{ - m.type => string type; - - if( type == "symbol" ) - { - (m$MalSymbol).value() => string symbol; - return env.get(symbol); - } - else if( type == "list" || type == "vector" || type == "hashmap" ) - { - (m$MalList).value() @=> MalObject values[]; - MalObject results[values.size()]; - - if( type != "hashmap" ) - { - for( 0 => int i; i < values.size(); i++ ) - { - EVAL(values[i], env) @=> MalObject result; - - if( result.type == "error" ) - { - return result; - } - - result @=> results[i]; - } - } - else - { - for( 0 => int i; i < values.size(); i++ ) - { - if( i % 2 == 0 ) - { - values[i] @=> results[i]; - } - else - { - EVAL(values[i], env) @=> results[i]; - } - } - } - - if( type == "list" ) - { - return MalList.create(results); - } - else if( type == "vector" ) - { - return MalVector.create(results); - } - else if( type == "hashmap" ) - { - return MalHashMap.create(results); - } - } - else - { - return m; - } -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -Env.create(null) @=> Env repl_env; -for( 0 => int i; i < Core.names.size(); i++ ) -{ - Core.names[i] => string name; - repl_env.set(name, Core.ns[name]); -} - -// HACK, HACK, HACK -class MalEval extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject m; - return EVAL(args[0], repl_env); - } - - fun MalObject apply(MalObject f, MalObject args[]) - { - if( f.type == "subr" ) - { - return (f$MalSubr).call(args); - } - else // f.type == "func" - { - f$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - return EVAL(func.ast, eval_env); - } - } -} - -new MalEval @=> MalEval eval; -repl_env.set("eval", new MalEval); -eval @=> (repl_env.get("swap!")$MalSubr).eval; - -fun MalObject[] MalArgv(string args[]) -{ - MalObject values[0]; - - for( 1 => int i; i < args.size(); i++ ) - { - values << MalString.create(args[i]); - } - - return values; -} - -// NOTE: normally I'd use \0, but strings are null-terminated... -String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; -repl_env.set("*ARGV*", MalList.create(MalArgv(args))); - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - - EVAL(m, repl_env) @=> MalObject result; - if( result.type == "error" ) - { - return errorMessage(result); - } - - return PRINT(result); -} - -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -if( args.size() > 0 ) -{ - args[0] => string filename; - rep("(load-file \"" + filename + "\")"); -} -else -{ - main(); -} +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck +// @import env.ck +// @import func.ck +// @import types/MalSubr.ck +// @import types/subr/*.ck +// @import core.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun MalObject EVAL(MalObject m, Env env) +{ + while( true ) + { + if( m.type != "list" ) + { + return eval_ast(m, env); + } + + if( (m$MalList).value().size() == 0 ) + { + return m; + } + + (m$MalList).value() @=> MalObject ast[]; + + if( ast[0].type == "symbol" ) + { + (ast[0]$MalSymbol).value() => string a0; + + if( a0 == "def!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + env.set(a1, value); + return value; + } + else if( a0 == "let*" ) + { + Env.create(env) @=> Env let_env; + Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; + + for( 0 => int i; i < bindings.size(); 2 +=> i) + { + (bindings[i]$MalSymbol).value() => string symbol; + EVAL(bindings[i+1], let_env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + let_env.set(symbol, value); + } + + let_env @=> env; + ast[2] @=> m; + continue; // TCO + } + else if( a0 == "do" ) + { + MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; + eval_ast(MalList.create(forms), env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + // HACK: this assumes do gets at least one argument... + ast[ast.size()-1] @=> m; + continue; // TCO + } + else if( a0 == "if" ) + { + EVAL(ast[1], env) @=> MalObject condition; + + if( condition.type == "error" ) + { + return condition; + } + + if( !(condition.type == "nil") && !(condition.type == "false") ) + { + ast[2] @=> m; + continue; // TCO + } + else + { + if( ast.size() < 4 ) + { + return Constants.NIL; + } + else + { + ast[3] @=> m; + continue; // TCO + } + } + } + else if( a0 == "fn*" ) + { + (ast[1]$MalList).value() @=> MalObject arg_values[]; + string args[arg_values.size()]; + + for( 0 => int i; i < arg_values.size(); i++ ) + { + (arg_values[i]$MalSymbol).value() => args[i]; + } + + ast[2] @=> MalObject _ast; + + return Func.create(env, args, _ast); + } + } + + eval_ast(m, env) @=> MalObject result; + if( result.type == "error" ) + { + return result; + } + + (result$MalList).value() @=> MalObject values[]; + values[0].type => string type; + MalObject.slice(values, 1) @=> MalObject args[]; + + if( type == "subr" ) + { + values[0]$MalSubr @=> MalSubr subr; + return subr.call(args); + } + else // type == "func" + { + values[0]$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + eval_env @=> env; + func.ast @=> m; + continue; // TCO + } + } +} + +fun MalObject eval_ast(MalObject m, Env env) +{ + m.type => string type; + + if( type == "symbol" ) + { + (m$MalSymbol).value() => string symbol; + return env.get(symbol); + } + else if( type == "list" || type == "vector" || type == "hashmap" ) + { + (m$MalList).value() @=> MalObject values[]; + MalObject results[values.size()]; + + if( type != "hashmap" ) + { + for( 0 => int i; i < values.size(); i++ ) + { + EVAL(values[i], env) @=> MalObject result; + + if( result.type == "error" ) + { + return result; + } + + result @=> results[i]; + } + } + else + { + for( 0 => int i; i < values.size(); i++ ) + { + if( i % 2 == 0 ) + { + values[i] @=> results[i]; + } + else + { + EVAL(values[i], env) @=> results[i]; + } + } + } + + if( type == "list" ) + { + return MalList.create(results); + } + else if( type == "vector" ) + { + return MalVector.create(results); + } + else if( type == "hashmap" ) + { + return MalHashMap.create(results); + } + } + else + { + return m; + } +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +Env.create(null) @=> Env repl_env; +for( 0 => int i; i < Core.names.size(); i++ ) +{ + Core.names[i] => string name; + repl_env.set(name, Core.ns[name]); +} + +// HACK, HACK, HACK +class MalEval extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject m; + return EVAL(args[0], repl_env); + } + + fun MalObject apply(MalObject f, MalObject args[]) + { + if( f.type == "subr" ) + { + return (f$MalSubr).call(args); + } + else // f.type == "func" + { + f$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + return EVAL(func.ast, eval_env); + } + } +} + +new MalEval @=> MalEval eval; +repl_env.set("eval", new MalEval); +eval @=> (repl_env.get("swap!")$MalSubr).eval; + +fun MalObject[] MalArgv(string args[]) +{ + MalObject values[0]; + + for( 1 => int i; i < args.size(); i++ ) + { + values << MalString.create(args[i]); + } + + return values; +} + +// NOTE: normally I'd use \0, but strings are null-terminated... +String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; +repl_env.set("*ARGV*", MalList.create(MalArgv(args))); + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + + EVAL(m, repl_env) @=> MalObject result; + if( result.type == "error" ) + { + return errorMessage(result); + } + + return PRINT(result); +} + +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +if( args.size() > 0 ) +{ + args[0] => string filename; + rep("(load-file \"" + filename + "\")"); +} +else +{ + main(); +} diff --git a/impls/chuck/step7_quote.ck b/impls/chuck/step7_quote.ck index e187006c90..6ebcd4996c 100644 --- a/impls/chuck/step7_quote.ck +++ b/impls/chuck/step7_quote.ck @@ -1,410 +1,410 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck -// @import env.ck -// @import func.ck -// @import types/MalSubr.ck -// @import types/subr/*.ck -// @import core.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun int starts_with(MalObject a[], string sym) -{ - if (a.size() != 2) - { - return false; - } - a[0] @=> MalObject a0; - return a0.type == "symbol" && (a0$MalSymbol).value() == sym; -} -fun MalList qq_loop(MalObject elt, MalList acc) -{ - if( elt.type == "list" && starts_with ((elt$MalList).value(), "splice-unquote") ) - { - return MalList.create([MalSymbol.create("concat"), (elt$MalList).value()[1], acc]); - } - return MalList.create([MalSymbol.create("cons"), quasiquote(elt), acc]); -} -fun MalList qq_foldr(MalObject a[]) -{ - MalObject empty[0]; // empty, but typed - MalList.create(empty) @=> MalList acc; - for( a.size() - 1 => int i; 0 <= i; i-- ) - { - qq_loop(a[i], acc) @=> acc; - } - return acc; -} -fun MalObject quasiquote(MalObject ast) -{ - ast.type => string type; - if (type == "list") { - if (starts_with((ast$MalList).value(), "unquote")) - { - return (ast$MalList).value()[1]; - } - return qq_foldr((ast$MalList).value()); - } - if (type == "vector") - { - return MalList.create([MalSymbol.create("vec"), qq_foldr((ast$MalVector).value())]); - } - if (type == "symbol" || type == "hashmap") - { - return MalList.create([MalSymbol.create("quote"), ast]); - } - return ast; -} - -fun MalObject EVAL(MalObject m, Env env) -{ - while( true ) - { - if( m.type != "list" ) - { - return eval_ast(m, env); - } - - if( (m$MalList).value().size() == 0 ) - { - return m; - } - - (m$MalList).value() @=> MalObject ast[]; - - if( ast[0].type == "symbol" ) - { - (ast[0]$MalSymbol).value() => string a0; - - if( a0 == "def!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - env.set(a1, value); - return value; - } - else if( a0 == "let*" ) - { - Env.create(env) @=> Env let_env; - Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; - - for( 0 => int i; i < bindings.size(); 2 +=> i) - { - (bindings[i]$MalSymbol).value() => string symbol; - EVAL(bindings[i+1], let_env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - let_env.set(symbol, value); - } - - let_env @=> env; - ast[2] @=> m; - continue; // TCO - } - else if( a0 == "quote" ) - { - return ast[1]; - } - else if( a0 == "quasiquoteexpand" ) - { - return quasiquote(ast[1]); - } - else if( a0 == "quasiquote" ) - { - quasiquote(ast[1]) @=> m; - continue; // TCO - } - else if( a0 == "do" ) - { - MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; - eval_ast(MalList.create(forms), env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - // HACK: this assumes do gets at least one argument... - ast[ast.size()-1] @=> m; - continue; // TCO - } - else if( a0 == "if" ) - { - EVAL(ast[1], env) @=> MalObject condition; - - if( condition.type == "error" ) - { - return condition; - } - - if( !(condition.type == "nil") && !(condition.type == "false") ) - { - ast[2] @=> m; - continue; // TCO - } - else - { - if( ast.size() < 4 ) - { - return Constants.NIL; - } - else - { - ast[3] @=> m; - continue; // TCO - } - } - } - else if( a0 == "fn*" ) - { - (ast[1]$MalList).value() @=> MalObject arg_values[]; - string args[arg_values.size()]; - - for( 0 => int i; i < arg_values.size(); i++ ) - { - (arg_values[i]$MalSymbol).value() => args[i]; - } - - ast[2] @=> MalObject _ast; - - return Func.create(env, args, _ast); - } - } - - eval_ast(m, env) @=> MalObject result; - if( result.type == "error" ) - { - return result; - } - - (result$MalList).value() @=> MalObject values[]; - values[0].type => string type; - MalObject.slice(values, 1) @=> MalObject args[]; - - if( type == "subr" ) - { - values[0]$MalSubr @=> MalSubr subr; - return subr.call(args); - } - else // type == "func" - { - values[0]$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - eval_env @=> env; - func.ast @=> m; - continue; // TCO - } - } -} - -fun MalObject eval_ast(MalObject m, Env env) -{ - m.type => string type; - - if( type == "symbol" ) - { - (m$MalSymbol).value() => string symbol; - return env.get(symbol); - } - else if( type == "list" || type == "vector" || type == "hashmap" ) - { - (m$MalList).value() @=> MalObject values[]; - MalObject results[values.size()]; - - if( type != "hashmap" ) - { - for( 0 => int i; i < values.size(); i++ ) - { - EVAL(values[i], env) @=> MalObject result; - - if( result.type == "error" ) - { - return result; - } - - result @=> results[i]; - } - } - else - { - for( 0 => int i; i < values.size(); i++ ) - { - if( i % 2 == 0 ) - { - values[i] @=> results[i]; - } - else - { - EVAL(values[i], env) @=> results[i]; - } - } - } - - if( type == "list" ) - { - return MalList.create(results); - } - else if( type == "vector" ) - { - return MalVector.create(results); - } - else if( type == "hashmap" ) - { - return MalHashMap.create(results); - } - } - else - { - return m; - } -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -Env.create(null) @=> Env repl_env; -for( 0 => int i; i < Core.names.size(); i++ ) -{ - Core.names[i] => string name; - repl_env.set(name, Core.ns[name]); -} - -// HACK, HACK, HACK -class MalEval extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject m; - return EVAL(args[0], repl_env); - } - - fun MalObject apply(MalObject f, MalObject args[]) - { - if( f.type == "subr" ) - { - return (f$MalSubr).call(args); - } - else // f.type == "func" - { - f$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - return EVAL(func.ast, eval_env); - } - } -} - -new MalEval @=> MalEval eval; -repl_env.set("eval", new MalEval); -eval @=> (repl_env.get("swap!")$MalSubr).eval; - -fun MalObject[] MalArgv(string args[]) -{ - MalObject values[0]; - - for( 1 => int i; i < args.size(); i++ ) - { - values << MalString.create(args[i]); - } - - return values; -} - -// NOTE: normally I'd use \0, but strings are null-terminated... -String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; -repl_env.set("*ARGV*", MalList.create(MalArgv(args))); - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - - EVAL(m, repl_env) @=> MalObject result; - if( result.type == "error" ) - { - return errorMessage(result); - } - - return PRINT(result); -} - -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -if( args.size() > 0 ) -{ - args[0] => string filename; - rep("(load-file \"" + filename + "\")"); -} -else -{ - main(); -} +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck +// @import env.ck +// @import func.ck +// @import types/MalSubr.ck +// @import types/subr/*.ck +// @import core.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun int starts_with(MalObject a[], string sym) +{ + if (a.size() != 2) + { + return false; + } + a[0] @=> MalObject a0; + return a0.type == "symbol" && (a0$MalSymbol).value() == sym; +} +fun MalList qq_loop(MalObject elt, MalList acc) +{ + if( elt.type == "list" && starts_with ((elt$MalList).value(), "splice-unquote") ) + { + return MalList.create([MalSymbol.create("concat"), (elt$MalList).value()[1], acc]); + } + return MalList.create([MalSymbol.create("cons"), quasiquote(elt), acc]); +} +fun MalList qq_foldr(MalObject a[]) +{ + MalObject empty[0]; // empty, but typed + MalList.create(empty) @=> MalList acc; + for( a.size() - 1 => int i; 0 <= i; i-- ) + { + qq_loop(a[i], acc) @=> acc; + } + return acc; +} +fun MalObject quasiquote(MalObject ast) +{ + ast.type => string type; + if (type == "list") { + if (starts_with((ast$MalList).value(), "unquote")) + { + return (ast$MalList).value()[1]; + } + return qq_foldr((ast$MalList).value()); + } + if (type == "vector") + { + return MalList.create([MalSymbol.create("vec"), qq_foldr((ast$MalVector).value())]); + } + if (type == "symbol" || type == "hashmap") + { + return MalList.create([MalSymbol.create("quote"), ast]); + } + return ast; +} + +fun MalObject EVAL(MalObject m, Env env) +{ + while( true ) + { + if( m.type != "list" ) + { + return eval_ast(m, env); + } + + if( (m$MalList).value().size() == 0 ) + { + return m; + } + + (m$MalList).value() @=> MalObject ast[]; + + if( ast[0].type == "symbol" ) + { + (ast[0]$MalSymbol).value() => string a0; + + if( a0 == "def!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + env.set(a1, value); + return value; + } + else if( a0 == "let*" ) + { + Env.create(env) @=> Env let_env; + Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; + + for( 0 => int i; i < bindings.size(); 2 +=> i) + { + (bindings[i]$MalSymbol).value() => string symbol; + EVAL(bindings[i+1], let_env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + let_env.set(symbol, value); + } + + let_env @=> env; + ast[2] @=> m; + continue; // TCO + } + else if( a0 == "quote" ) + { + return ast[1]; + } + else if( a0 == "quasiquoteexpand" ) + { + return quasiquote(ast[1]); + } + else if( a0 == "quasiquote" ) + { + quasiquote(ast[1]) @=> m; + continue; // TCO + } + else if( a0 == "do" ) + { + MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; + eval_ast(MalList.create(forms), env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + // HACK: this assumes do gets at least one argument... + ast[ast.size()-1] @=> m; + continue; // TCO + } + else if( a0 == "if" ) + { + EVAL(ast[1], env) @=> MalObject condition; + + if( condition.type == "error" ) + { + return condition; + } + + if( !(condition.type == "nil") && !(condition.type == "false") ) + { + ast[2] @=> m; + continue; // TCO + } + else + { + if( ast.size() < 4 ) + { + return Constants.NIL; + } + else + { + ast[3] @=> m; + continue; // TCO + } + } + } + else if( a0 == "fn*" ) + { + (ast[1]$MalList).value() @=> MalObject arg_values[]; + string args[arg_values.size()]; + + for( 0 => int i; i < arg_values.size(); i++ ) + { + (arg_values[i]$MalSymbol).value() => args[i]; + } + + ast[2] @=> MalObject _ast; + + return Func.create(env, args, _ast); + } + } + + eval_ast(m, env) @=> MalObject result; + if( result.type == "error" ) + { + return result; + } + + (result$MalList).value() @=> MalObject values[]; + values[0].type => string type; + MalObject.slice(values, 1) @=> MalObject args[]; + + if( type == "subr" ) + { + values[0]$MalSubr @=> MalSubr subr; + return subr.call(args); + } + else // type == "func" + { + values[0]$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + eval_env @=> env; + func.ast @=> m; + continue; // TCO + } + } +} + +fun MalObject eval_ast(MalObject m, Env env) +{ + m.type => string type; + + if( type == "symbol" ) + { + (m$MalSymbol).value() => string symbol; + return env.get(symbol); + } + else if( type == "list" || type == "vector" || type == "hashmap" ) + { + (m$MalList).value() @=> MalObject values[]; + MalObject results[values.size()]; + + if( type != "hashmap" ) + { + for( 0 => int i; i < values.size(); i++ ) + { + EVAL(values[i], env) @=> MalObject result; + + if( result.type == "error" ) + { + return result; + } + + result @=> results[i]; + } + } + else + { + for( 0 => int i; i < values.size(); i++ ) + { + if( i % 2 == 0 ) + { + values[i] @=> results[i]; + } + else + { + EVAL(values[i], env) @=> results[i]; + } + } + } + + if( type == "list" ) + { + return MalList.create(results); + } + else if( type == "vector" ) + { + return MalVector.create(results); + } + else if( type == "hashmap" ) + { + return MalHashMap.create(results); + } + } + else + { + return m; + } +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +Env.create(null) @=> Env repl_env; +for( 0 => int i; i < Core.names.size(); i++ ) +{ + Core.names[i] => string name; + repl_env.set(name, Core.ns[name]); +} + +// HACK, HACK, HACK +class MalEval extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject m; + return EVAL(args[0], repl_env); + } + + fun MalObject apply(MalObject f, MalObject args[]) + { + if( f.type == "subr" ) + { + return (f$MalSubr).call(args); + } + else // f.type == "func" + { + f$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + return EVAL(func.ast, eval_env); + } + } +} + +new MalEval @=> MalEval eval; +repl_env.set("eval", new MalEval); +eval @=> (repl_env.get("swap!")$MalSubr).eval; + +fun MalObject[] MalArgv(string args[]) +{ + MalObject values[0]; + + for( 1 => int i; i < args.size(); i++ ) + { + values << MalString.create(args[i]); + } + + return values; +} + +// NOTE: normally I'd use \0, but strings are null-terminated... +String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; +repl_env.set("*ARGV*", MalList.create(MalArgv(args))); + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + + EVAL(m, repl_env) @=> MalObject result; + if( result.type == "error" ) + { + return errorMessage(result); + } + + return PRINT(result); +} + +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +if( args.size() > 0 ) +{ + args[0] => string filename; + rep("(load-file \"" + filename + "\")"); +} +else +{ + main(); +} diff --git a/impls/chuck/step8_macros.ck b/impls/chuck/step8_macros.ck index 7925c7b0d8..30617fdbbb 100644 --- a/impls/chuck/step8_macros.ck +++ b/impls/chuck/step8_macros.ck @@ -1,482 +1,482 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck -// @import env.ck -// @import func.ck -// @import types/MalSubr.ck -// @import types/subr/*.ck -// @import core.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun int starts_with(MalObject a[], string sym) -{ - if (a.size() != 2) - { - return false; - } - a[0] @=> MalObject a0; - return a0.type == "symbol" && (a0$MalSymbol).value() == sym; -} -fun MalList qq_loop(MalObject elt, MalList acc) -{ - if( elt.type == "list" && starts_with ((elt$MalList).value(), "splice-unquote") ) - { - return MalList.create([MalSymbol.create("concat"), (elt$MalList).value()[1], acc]); - } - return MalList.create([MalSymbol.create("cons"), quasiquote(elt), acc]); -} -fun MalList qq_foldr(MalObject a[]) -{ - MalObject empty[0]; // empty, but typed - MalList.create(empty) @=> MalList acc; - for( a.size() - 1 => int i; 0 <= i; i-- ) - { - qq_loop(a[i], acc) @=> acc; - } - return acc; -} -fun MalObject quasiquote(MalObject ast) -{ - ast.type => string type; - if (type == "list") { - if (starts_with((ast$MalList).value(), "unquote")) - { - return (ast$MalList).value()[1]; - } - return qq_foldr((ast$MalList).value()); - } - if (type == "vector") - { - return MalList.create([MalSymbol.create("vec"), qq_foldr((ast$MalVector).value())]); - } - if (type == "symbol" || type == "hashmap") - { - return MalList.create([MalSymbol.create("quote"), ast]); - } - return ast; -} - -fun int isMacroCall(MalObject ast, Env env) -{ - if( ast.type == "list" ) - { - (ast$MalList).value() @=> MalObject a[]; - - if( a[0].type == "symbol" ) - { - (a[0]$MalSymbol).value() => string name; - env.find(name) @=> MalObject value; - - if( value != null && value.type == "func" && (value$Func).isMacro ) - { - return true; - } - } - } - - return false; -} - -fun MalObject macroexpand(MalObject ast, Env env) -{ - while( isMacroCall(ast, env) ) - { - Util.sequenceToMalObjectArray(ast) @=> MalObject list[]; - (list[0]$MalSymbol).value() => string name; - env.get(name) @=> MalObject macro; - MalObject.slice(list, 1) @=> MalObject args[]; - - if( macro.type == "subr" ) - { - (macro$MalSubr).call(args) @=> ast; - } - else // macro.type == "func" - { - macro$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - EVAL(func.ast, eval_env) @=> ast;; - } - } - - return ast; -} - -fun MalObject EVAL(MalObject m, Env env) -{ - while( true ) - { - if( m.type != "list" ) - { - return eval_ast(m, env); - } - - if( (m$MalList).value().size() == 0 ) - { - return m; - } - - macroexpand(m, env) @=> m; - - if( m.type != "list" ) - { - return eval_ast(m, env); - } - - (m$MalList).value() @=> MalObject ast[]; - - if( ast[0].type == "symbol" ) - { - (ast[0]$MalSymbol).value() => string a0; - - if( a0 == "def!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - env.set(a1, value); - return value; - } - else if( a0 == "let*" ) - { - Env.create(env) @=> Env let_env; - Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; - - for( 0 => int i; i < bindings.size(); 2 +=> i) - { - (bindings[i]$MalSymbol).value() => string symbol; - EVAL(bindings[i+1], let_env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - let_env.set(symbol, value); - } - - let_env @=> env; - ast[2] @=> m; - continue; // TCO - } - else if( a0 == "quote" ) - { - return ast[1]; - } - else if( a0 == "quasiquoteexpand" ) - { - return quasiquote(ast[1]); - } - else if( a0 == "quasiquote" ) - { - quasiquote(ast[1]) @=> m; - continue; // TCO - } - else if( a0 == "defmacro!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - true => (value$Func).isMacro; - - env.set(a1, value); - return value; - } - else if( a0 == "macroexpand" ) - { - return macroexpand(ast[1], env); - } - else if( a0 == "do" ) - { - MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; - eval_ast(MalList.create(forms), env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - // HACK: this assumes do gets at least one argument... - ast[ast.size()-1] @=> m; - continue; // TCO - } - else if( a0 == "if" ) - { - EVAL(ast[1], env) @=> MalObject condition; - - if( condition.type == "error" ) - { - return condition; - } - - if( !(condition.type == "nil") && !(condition.type == "false") ) - { - ast[2] @=> m; - continue; // TCO - } - else - { - if( ast.size() < 4 ) - { - return Constants.NIL; - } - else - { - ast[3] @=> m; - continue; // TCO - } - } - } - else if( a0 == "fn*" ) - { - (ast[1]$MalList).value() @=> MalObject arg_values[]; - string args[arg_values.size()]; - - for( 0 => int i; i < arg_values.size(); i++ ) - { - (arg_values[i]$MalSymbol).value() => args[i]; - } - - ast[2] @=> MalObject _ast; - - return Func.create(env, args, _ast); - } - } - - eval_ast(m, env) @=> MalObject result; - if( result.type == "error" ) - { - return result; - } - - (result$MalList).value() @=> MalObject values[]; - values[0].type => string type; - MalObject.slice(values, 1) @=> MalObject args[]; - - if( type == "subr" ) - { - values[0]$MalSubr @=> MalSubr subr; - return subr.call(args); - } - else // type == "func" - { - values[0]$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - eval_env @=> env; - func.ast @=> m; - continue; // TCO - } - } -} - -fun MalObject eval_ast(MalObject m, Env env) -{ - m.type => string type; - - if( type == "symbol" ) - { - (m$MalSymbol).value() => string symbol; - return env.get(symbol); - } - else if( type == "list" || type == "vector" || type == "hashmap" ) - { - (m$MalList).value() @=> MalObject values[]; - MalObject results[values.size()]; - - if( type != "hashmap" ) - { - for( 0 => int i; i < values.size(); i++ ) - { - EVAL(values[i], env) @=> MalObject result; - - if( result.type == "error" ) - { - return result; - } - - result @=> results[i]; - } - } - else - { - for( 0 => int i; i < values.size(); i++ ) - { - if( i % 2 == 0 ) - { - values[i] @=> results[i]; - } - else - { - EVAL(values[i], env) @=> results[i]; - } - } - } - - if( type == "list" ) - { - return MalList.create(results); - } - else if( type == "vector" ) - { - return MalVector.create(results); - } - else if( type == "hashmap" ) - { - return MalHashMap.create(results); - } - } - else - { - return m; - } -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -Env.create(null) @=> Env repl_env; -for( 0 => int i; i < Core.names.size(); i++ ) -{ - Core.names[i] => string name; - repl_env.set(name, Core.ns[name]); -} - -// HACK, HACK, HACK -class MalEval extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject m; - return EVAL(args[0], repl_env); - } - - fun MalObject apply(MalObject f, MalObject args[]) - { - if( f.type == "subr" ) - { - return (f$MalSubr).call(args); - } - else // f.type == "func" - { - f$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - return EVAL(func.ast, eval_env); - } - } -} - -new MalEval @=> MalEval eval; -repl_env.set("eval", new MalEval); -eval @=> (repl_env.get("swap!")$MalSubr).eval; - -fun MalObject[] MalArgv(string args[]) -{ - MalObject values[0]; - - for( 1 => int i; i < args.size(); i++ ) - { - values << MalString.create(args[i]); - } - - return values; -} - -// NOTE: normally I'd use \0, but strings are null-terminated... -String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; -repl_env.set("*ARGV*", MalList.create(MalArgv(args))); - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - - EVAL(m, repl_env) @=> MalObject result; - if( result.type == "error" ) - { - return errorMessage(result); - } - - return PRINT(result); -} - -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -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)))))))"); - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -if( args.size() > 0 ) -{ - args[0] => string filename; - rep("(load-file \"" + filename + "\")"); -} -else -{ - main(); -} +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck +// @import env.ck +// @import func.ck +// @import types/MalSubr.ck +// @import types/subr/*.ck +// @import core.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun int starts_with(MalObject a[], string sym) +{ + if (a.size() != 2) + { + return false; + } + a[0] @=> MalObject a0; + return a0.type == "symbol" && (a0$MalSymbol).value() == sym; +} +fun MalList qq_loop(MalObject elt, MalList acc) +{ + if( elt.type == "list" && starts_with ((elt$MalList).value(), "splice-unquote") ) + { + return MalList.create([MalSymbol.create("concat"), (elt$MalList).value()[1], acc]); + } + return MalList.create([MalSymbol.create("cons"), quasiquote(elt), acc]); +} +fun MalList qq_foldr(MalObject a[]) +{ + MalObject empty[0]; // empty, but typed + MalList.create(empty) @=> MalList acc; + for( a.size() - 1 => int i; 0 <= i; i-- ) + { + qq_loop(a[i], acc) @=> acc; + } + return acc; +} +fun MalObject quasiquote(MalObject ast) +{ + ast.type => string type; + if (type == "list") { + if (starts_with((ast$MalList).value(), "unquote")) + { + return (ast$MalList).value()[1]; + } + return qq_foldr((ast$MalList).value()); + } + if (type == "vector") + { + return MalList.create([MalSymbol.create("vec"), qq_foldr((ast$MalVector).value())]); + } + if (type == "symbol" || type == "hashmap") + { + return MalList.create([MalSymbol.create("quote"), ast]); + } + return ast; +} + +fun int isMacroCall(MalObject ast, Env env) +{ + if( ast.type == "list" ) + { + (ast$MalList).value() @=> MalObject a[]; + + if( a[0].type == "symbol" ) + { + (a[0]$MalSymbol).value() => string name; + env.find(name) @=> MalObject value; + + if( value != null && value.type == "func" && (value$Func).isMacro ) + { + return true; + } + } + } + + return false; +} + +fun MalObject macroexpand(MalObject ast, Env env) +{ + while( isMacroCall(ast, env) ) + { + Util.sequenceToMalObjectArray(ast) @=> MalObject list[]; + (list[0]$MalSymbol).value() => string name; + env.get(name) @=> MalObject macro; + MalObject.slice(list, 1) @=> MalObject args[]; + + if( macro.type == "subr" ) + { + (macro$MalSubr).call(args) @=> ast; + } + else // macro.type == "func" + { + macro$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + EVAL(func.ast, eval_env) @=> ast;; + } + } + + return ast; +} + +fun MalObject EVAL(MalObject m, Env env) +{ + while( true ) + { + if( m.type != "list" ) + { + return eval_ast(m, env); + } + + if( (m$MalList).value().size() == 0 ) + { + return m; + } + + macroexpand(m, env) @=> m; + + if( m.type != "list" ) + { + return eval_ast(m, env); + } + + (m$MalList).value() @=> MalObject ast[]; + + if( ast[0].type == "symbol" ) + { + (ast[0]$MalSymbol).value() => string a0; + + if( a0 == "def!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + env.set(a1, value); + return value; + } + else if( a0 == "let*" ) + { + Env.create(env) @=> Env let_env; + Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; + + for( 0 => int i; i < bindings.size(); 2 +=> i) + { + (bindings[i]$MalSymbol).value() => string symbol; + EVAL(bindings[i+1], let_env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + let_env.set(symbol, value); + } + + let_env @=> env; + ast[2] @=> m; + continue; // TCO + } + else if( a0 == "quote" ) + { + return ast[1]; + } + else if( a0 == "quasiquoteexpand" ) + { + return quasiquote(ast[1]); + } + else if( a0 == "quasiquote" ) + { + quasiquote(ast[1]) @=> m; + continue; // TCO + } + else if( a0 == "defmacro!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + true => (value$Func).isMacro; + + env.set(a1, value); + return value; + } + else if( a0 == "macroexpand" ) + { + return macroexpand(ast[1], env); + } + else if( a0 == "do" ) + { + MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; + eval_ast(MalList.create(forms), env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + // HACK: this assumes do gets at least one argument... + ast[ast.size()-1] @=> m; + continue; // TCO + } + else if( a0 == "if" ) + { + EVAL(ast[1], env) @=> MalObject condition; + + if( condition.type == "error" ) + { + return condition; + } + + if( !(condition.type == "nil") && !(condition.type == "false") ) + { + ast[2] @=> m; + continue; // TCO + } + else + { + if( ast.size() < 4 ) + { + return Constants.NIL; + } + else + { + ast[3] @=> m; + continue; // TCO + } + } + } + else if( a0 == "fn*" ) + { + (ast[1]$MalList).value() @=> MalObject arg_values[]; + string args[arg_values.size()]; + + for( 0 => int i; i < arg_values.size(); i++ ) + { + (arg_values[i]$MalSymbol).value() => args[i]; + } + + ast[2] @=> MalObject _ast; + + return Func.create(env, args, _ast); + } + } + + eval_ast(m, env) @=> MalObject result; + if( result.type == "error" ) + { + return result; + } + + (result$MalList).value() @=> MalObject values[]; + values[0].type => string type; + MalObject.slice(values, 1) @=> MalObject args[]; + + if( type == "subr" ) + { + values[0]$MalSubr @=> MalSubr subr; + return subr.call(args); + } + else // type == "func" + { + values[0]$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + eval_env @=> env; + func.ast @=> m; + continue; // TCO + } + } +} + +fun MalObject eval_ast(MalObject m, Env env) +{ + m.type => string type; + + if( type == "symbol" ) + { + (m$MalSymbol).value() => string symbol; + return env.get(symbol); + } + else if( type == "list" || type == "vector" || type == "hashmap" ) + { + (m$MalList).value() @=> MalObject values[]; + MalObject results[values.size()]; + + if( type != "hashmap" ) + { + for( 0 => int i; i < values.size(); i++ ) + { + EVAL(values[i], env) @=> MalObject result; + + if( result.type == "error" ) + { + return result; + } + + result @=> results[i]; + } + } + else + { + for( 0 => int i; i < values.size(); i++ ) + { + if( i % 2 == 0 ) + { + values[i] @=> results[i]; + } + else + { + EVAL(values[i], env) @=> results[i]; + } + } + } + + if( type == "list" ) + { + return MalList.create(results); + } + else if( type == "vector" ) + { + return MalVector.create(results); + } + else if( type == "hashmap" ) + { + return MalHashMap.create(results); + } + } + else + { + return m; + } +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +Env.create(null) @=> Env repl_env; +for( 0 => int i; i < Core.names.size(); i++ ) +{ + Core.names[i] => string name; + repl_env.set(name, Core.ns[name]); +} + +// HACK, HACK, HACK +class MalEval extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject m; + return EVAL(args[0], repl_env); + } + + fun MalObject apply(MalObject f, MalObject args[]) + { + if( f.type == "subr" ) + { + return (f$MalSubr).call(args); + } + else // f.type == "func" + { + f$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + return EVAL(func.ast, eval_env); + } + } +} + +new MalEval @=> MalEval eval; +repl_env.set("eval", new MalEval); +eval @=> (repl_env.get("swap!")$MalSubr).eval; + +fun MalObject[] MalArgv(string args[]) +{ + MalObject values[0]; + + for( 1 => int i; i < args.size(); i++ ) + { + values << MalString.create(args[i]); + } + + return values; +} + +// NOTE: normally I'd use \0, but strings are null-terminated... +String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; +repl_env.set("*ARGV*", MalList.create(MalArgv(args))); + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + + EVAL(m, repl_env) @=> MalObject result; + if( result.type == "error" ) + { + return errorMessage(result); + } + + return PRINT(result); +} + +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +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)))))))"); + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +if( args.size() > 0 ) +{ + args[0] => string filename; + rep("(load-file \"" + filename + "\")"); +} +else +{ + main(); +} diff --git a/impls/chuck/step9_try.ck b/impls/chuck/step9_try.ck index c46c6e9480..839566906b 100644 --- a/impls/chuck/step9_try.ck +++ b/impls/chuck/step9_try.ck @@ -1,499 +1,499 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck -// @import env.ck -// @import func.ck -// @import types/MalSubr.ck -// @import types/subr/*.ck -// @import core.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun int starts_with(MalObject a[], string sym) -{ - if (a.size() != 2) - { - return false; - } - a[0] @=> MalObject a0; - return a0.type == "symbol" && (a0$MalSymbol).value() == sym; -} -fun MalList qq_loop(MalObject elt, MalList acc) -{ - if( elt.type == "list" && starts_with ((elt$MalList).value(), "splice-unquote") ) - { - return MalList.create([MalSymbol.create("concat"), (elt$MalList).value()[1], acc]); - } - return MalList.create([MalSymbol.create("cons"), quasiquote(elt), acc]); -} -fun MalList qq_foldr(MalObject a[]) -{ - MalObject empty[0]; // empty, but typed - MalList.create(empty) @=> MalList acc; - for( a.size() - 1 => int i; 0 <= i; i-- ) - { - qq_loop(a[i], acc) @=> acc; - } - return acc; -} -fun MalObject quasiquote(MalObject ast) -{ - ast.type => string type; - if (type == "list") { - if (starts_with((ast$MalList).value(), "unquote")) - { - return (ast$MalList).value()[1]; - } - return qq_foldr((ast$MalList).value()); - } - if (type == "vector") - { - return MalList.create([MalSymbol.create("vec"), qq_foldr((ast$MalVector).value())]); - } - if (type == "symbol" || type == "hashmap") - { - return MalList.create([MalSymbol.create("quote"), ast]); - } - return ast; -} - -fun int isMacroCall(MalObject ast, Env env) -{ - if( ast.type == "list" ) - { - (ast$MalList).value() @=> MalObject a[]; - - if( a[0].type == "symbol" ) - { - (a[0]$MalSymbol).value() => string name; - env.find(name) @=> MalObject value; - - if( value != null && value.type == "func" && (value$Func).isMacro ) - { - return true; - } - } - } - - return false; -} - -fun MalObject macroexpand(MalObject ast, Env env) -{ - while( isMacroCall(ast, env) ) - { - Util.sequenceToMalObjectArray(ast) @=> MalObject list[]; - (list[0]$MalSymbol).value() => string name; - env.get(name) @=> MalObject macro; - MalObject.slice(list, 1) @=> MalObject args[]; - - if( macro.type == "subr" ) - { - (macro$MalSubr).call(args) @=> ast; - } - else // macro.type == "func" - { - macro$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - EVAL(func.ast, eval_env) @=> ast; - } - } - - return ast; -} - -fun MalObject EVAL(MalObject m, Env env) -{ - while( true ) - { - if( m.type != "list" ) - { - return eval_ast(m, env); - } - - if( (m$MalList).value().size() == 0 ) - { - return m; - } - - macroexpand(m, env) @=> m; - - if( m.type != "list" ) - { - return eval_ast(m, env); - } - - (m$MalList).value() @=> MalObject ast[]; - - if( ast[0].type == "symbol" ) - { - (ast[0]$MalSymbol).value() => string a0; - - if( a0 == "def!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - env.set(a1, value); - return value; - } - else if( a0 == "let*" ) - { - Env.create(env) @=> Env let_env; - Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; - - for( 0 => int i; i < bindings.size(); 2 +=> i) - { - (bindings[i]$MalSymbol).value() => string symbol; - EVAL(bindings[i+1], let_env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - let_env.set(symbol, value); - } - - let_env @=> env; - ast[2] @=> m; - continue; // TCO - } - else if( a0 == "quote" ) - { - return ast[1]; - } - else if( a0 == "quasiquoteexpand" ) - { - return quasiquote(ast[1]); - } - else if( a0 == "quasiquote" ) - { - quasiquote(ast[1]) @=> m; - continue; // TCO - } - else if( a0 == "defmacro!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - true => (value$Func).isMacro; - - env.set(a1, value); - return value; - } - else if( a0 == "macroexpand" ) - { - return macroexpand(ast[1], env); - } - else if( a0 == "try*" ) - { - EVAL(ast[1], env) @=> MalObject value; - - if( (value.type != "error") || (ast.size() < 3) ) - { - return value; - } - - (ast[2]$MalList).value() @=> MalObject form[]; - (form[1]$MalSymbol).value() => string name; - - Env.create(env, [name], [(value$MalError).value()]) @=> Env error_env; - return EVAL(form[2], error_env); - } - else if( a0 == "do" ) - { - MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; - eval_ast(MalList.create(forms), env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - // HACK: this assumes do gets at least one argument... - ast[ast.size()-1] @=> m; - continue; // TCO - } - else if( a0 == "if" ) - { - EVAL(ast[1], env) @=> MalObject condition; - - if( condition.type == "error" ) - { - return condition; - } - - if( !(condition.type == "nil") && !(condition.type == "false") ) - { - ast[2] @=> m; - continue; // TCO - } - else - { - if( ast.size() < 4 ) - { - return Constants.NIL; - } - else - { - ast[3] @=> m; - continue; // TCO - } - } - } - else if( a0 == "fn*" ) - { - (ast[1]$MalList).value() @=> MalObject arg_values[]; - string args[arg_values.size()]; - - for( 0 => int i; i < arg_values.size(); i++ ) - { - (arg_values[i]$MalSymbol).value() => args[i]; - } - - ast[2] @=> MalObject _ast; - - return Func.create(env, args, _ast); - } - } - - eval_ast(m, env) @=> MalObject result; - if( result.type == "error" ) - { - return result; - } - - (result$MalList).value() @=> MalObject values[]; - values[0].type => string type; - MalObject.slice(values, 1) @=> MalObject args[]; - - if( type == "subr" ) - { - values[0]$MalSubr @=> MalSubr subr; - return subr.call(args); - } - else // type == "func" - { - values[0]$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - eval_env @=> env; - func.ast @=> m; - continue; // TCO - } - } -} - -fun MalObject eval_ast(MalObject m, Env env) -{ - m.type => string type; - - if( type == "symbol" ) - { - (m$MalSymbol).value() => string symbol; - return env.get(symbol); - } - else if( type == "list" || type == "vector" || type == "hashmap" ) - { - (m$MalList).value() @=> MalObject values[]; - MalObject results[values.size()]; - - if( type != "hashmap" ) - { - for( 0 => int i; i < values.size(); i++ ) - { - EVAL(values[i], env) @=> MalObject result; - - if( result.type == "error" ) - { - return result; - } - - result @=> results[i]; - } - } - else - { - for( 0 => int i; i < values.size(); i++ ) - { - if( i % 2 == 0 ) - { - values[i] @=> results[i]; - } - else - { - EVAL(values[i], env) @=> results[i]; - } - } - } - - if( type == "list" ) - { - return MalList.create(results); - } - else if( type == "vector" ) - { - return MalVector.create(results); - } - else if( type == "hashmap" ) - { - return MalHashMap.create(results); - } - } - else - { - return m; - } -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -Env.create(null) @=> Env repl_env; -for( 0 => int i; i < Core.names.size(); i++ ) -{ - Core.names[i] => string name; - repl_env.set(name, Core.ns[name]); -} - -// HACK, HACK, HACK -class MalEval extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject m; - return EVAL(args[0], repl_env); - } - - fun MalObject apply(MalObject f, MalObject args[]) - { - if( f.type == "subr" ) - { - return (f$MalSubr).call(args); - } - else // f.type == "func" - { - f$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - return EVAL(func.ast, eval_env); - } - } -} - -new MalEval @=> MalEval eval; -repl_env.set("eval", new MalEval); -eval @=> (repl_env.get("swap!")$MalSubr).eval; -eval @=> (repl_env.get("apply")$MalSubr).eval; -eval @=> (repl_env.get("map")$MalSubr).eval; - -fun MalObject[] MalArgv(string args[]) -{ - MalObject values[0]; - - for( 1 => int i; i < args.size(); i++ ) - { - values << MalString.create(args[i]); - } - - return values; -} - -// NOTE: normally I'd use \0, but strings are null-terminated... -String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; -repl_env.set("*ARGV*", MalList.create(MalArgv(args))); - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - - EVAL(m, repl_env) @=> MalObject result; - if( result.type == "error" ) - { - return errorMessage(result); - } - - return PRINT(result); -} - -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -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)))))))"); - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -if( args.size() > 0 ) -{ - args[0] => string filename; - rep("(load-file \"" + filename + "\")"); -} -else -{ - main(); -} +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck +// @import env.ck +// @import func.ck +// @import types/MalSubr.ck +// @import types/subr/*.ck +// @import core.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun int starts_with(MalObject a[], string sym) +{ + if (a.size() != 2) + { + return false; + } + a[0] @=> MalObject a0; + return a0.type == "symbol" && (a0$MalSymbol).value() == sym; +} +fun MalList qq_loop(MalObject elt, MalList acc) +{ + if( elt.type == "list" && starts_with ((elt$MalList).value(), "splice-unquote") ) + { + return MalList.create([MalSymbol.create("concat"), (elt$MalList).value()[1], acc]); + } + return MalList.create([MalSymbol.create("cons"), quasiquote(elt), acc]); +} +fun MalList qq_foldr(MalObject a[]) +{ + MalObject empty[0]; // empty, but typed + MalList.create(empty) @=> MalList acc; + for( a.size() - 1 => int i; 0 <= i; i-- ) + { + qq_loop(a[i], acc) @=> acc; + } + return acc; +} +fun MalObject quasiquote(MalObject ast) +{ + ast.type => string type; + if (type == "list") { + if (starts_with((ast$MalList).value(), "unquote")) + { + return (ast$MalList).value()[1]; + } + return qq_foldr((ast$MalList).value()); + } + if (type == "vector") + { + return MalList.create([MalSymbol.create("vec"), qq_foldr((ast$MalVector).value())]); + } + if (type == "symbol" || type == "hashmap") + { + return MalList.create([MalSymbol.create("quote"), ast]); + } + return ast; +} + +fun int isMacroCall(MalObject ast, Env env) +{ + if( ast.type == "list" ) + { + (ast$MalList).value() @=> MalObject a[]; + + if( a[0].type == "symbol" ) + { + (a[0]$MalSymbol).value() => string name; + env.find(name) @=> MalObject value; + + if( value != null && value.type == "func" && (value$Func).isMacro ) + { + return true; + } + } + } + + return false; +} + +fun MalObject macroexpand(MalObject ast, Env env) +{ + while( isMacroCall(ast, env) ) + { + Util.sequenceToMalObjectArray(ast) @=> MalObject list[]; + (list[0]$MalSymbol).value() => string name; + env.get(name) @=> MalObject macro; + MalObject.slice(list, 1) @=> MalObject args[]; + + if( macro.type == "subr" ) + { + (macro$MalSubr).call(args) @=> ast; + } + else // macro.type == "func" + { + macro$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + EVAL(func.ast, eval_env) @=> ast; + } + } + + return ast; +} + +fun MalObject EVAL(MalObject m, Env env) +{ + while( true ) + { + if( m.type != "list" ) + { + return eval_ast(m, env); + } + + if( (m$MalList).value().size() == 0 ) + { + return m; + } + + macroexpand(m, env) @=> m; + + if( m.type != "list" ) + { + return eval_ast(m, env); + } + + (m$MalList).value() @=> MalObject ast[]; + + if( ast[0].type == "symbol" ) + { + (ast[0]$MalSymbol).value() => string a0; + + if( a0 == "def!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + env.set(a1, value); + return value; + } + else if( a0 == "let*" ) + { + Env.create(env) @=> Env let_env; + Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; + + for( 0 => int i; i < bindings.size(); 2 +=> i) + { + (bindings[i]$MalSymbol).value() => string symbol; + EVAL(bindings[i+1], let_env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + let_env.set(symbol, value); + } + + let_env @=> env; + ast[2] @=> m; + continue; // TCO + } + else if( a0 == "quote" ) + { + return ast[1]; + } + else if( a0 == "quasiquoteexpand" ) + { + return quasiquote(ast[1]); + } + else if( a0 == "quasiquote" ) + { + quasiquote(ast[1]) @=> m; + continue; // TCO + } + else if( a0 == "defmacro!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + true => (value$Func).isMacro; + + env.set(a1, value); + return value; + } + else if( a0 == "macroexpand" ) + { + return macroexpand(ast[1], env); + } + else if( a0 == "try*" ) + { + EVAL(ast[1], env) @=> MalObject value; + + if( (value.type != "error") || (ast.size() < 3) ) + { + return value; + } + + (ast[2]$MalList).value() @=> MalObject form[]; + (form[1]$MalSymbol).value() => string name; + + Env.create(env, [name], [(value$MalError).value()]) @=> Env error_env; + return EVAL(form[2], error_env); + } + else if( a0 == "do" ) + { + MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; + eval_ast(MalList.create(forms), env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + // HACK: this assumes do gets at least one argument... + ast[ast.size()-1] @=> m; + continue; // TCO + } + else if( a0 == "if" ) + { + EVAL(ast[1], env) @=> MalObject condition; + + if( condition.type == "error" ) + { + return condition; + } + + if( !(condition.type == "nil") && !(condition.type == "false") ) + { + ast[2] @=> m; + continue; // TCO + } + else + { + if( ast.size() < 4 ) + { + return Constants.NIL; + } + else + { + ast[3] @=> m; + continue; // TCO + } + } + } + else if( a0 == "fn*" ) + { + (ast[1]$MalList).value() @=> MalObject arg_values[]; + string args[arg_values.size()]; + + for( 0 => int i; i < arg_values.size(); i++ ) + { + (arg_values[i]$MalSymbol).value() => args[i]; + } + + ast[2] @=> MalObject _ast; + + return Func.create(env, args, _ast); + } + } + + eval_ast(m, env) @=> MalObject result; + if( result.type == "error" ) + { + return result; + } + + (result$MalList).value() @=> MalObject values[]; + values[0].type => string type; + MalObject.slice(values, 1) @=> MalObject args[]; + + if( type == "subr" ) + { + values[0]$MalSubr @=> MalSubr subr; + return subr.call(args); + } + else // type == "func" + { + values[0]$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + eval_env @=> env; + func.ast @=> m; + continue; // TCO + } + } +} + +fun MalObject eval_ast(MalObject m, Env env) +{ + m.type => string type; + + if( type == "symbol" ) + { + (m$MalSymbol).value() => string symbol; + return env.get(symbol); + } + else if( type == "list" || type == "vector" || type == "hashmap" ) + { + (m$MalList).value() @=> MalObject values[]; + MalObject results[values.size()]; + + if( type != "hashmap" ) + { + for( 0 => int i; i < values.size(); i++ ) + { + EVAL(values[i], env) @=> MalObject result; + + if( result.type == "error" ) + { + return result; + } + + result @=> results[i]; + } + } + else + { + for( 0 => int i; i < values.size(); i++ ) + { + if( i % 2 == 0 ) + { + values[i] @=> results[i]; + } + else + { + EVAL(values[i], env) @=> results[i]; + } + } + } + + if( type == "list" ) + { + return MalList.create(results); + } + else if( type == "vector" ) + { + return MalVector.create(results); + } + else if( type == "hashmap" ) + { + return MalHashMap.create(results); + } + } + else + { + return m; + } +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +Env.create(null) @=> Env repl_env; +for( 0 => int i; i < Core.names.size(); i++ ) +{ + Core.names[i] => string name; + repl_env.set(name, Core.ns[name]); +} + +// HACK, HACK, HACK +class MalEval extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject m; + return EVAL(args[0], repl_env); + } + + fun MalObject apply(MalObject f, MalObject args[]) + { + if( f.type == "subr" ) + { + return (f$MalSubr).call(args); + } + else // f.type == "func" + { + f$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + return EVAL(func.ast, eval_env); + } + } +} + +new MalEval @=> MalEval eval; +repl_env.set("eval", new MalEval); +eval @=> (repl_env.get("swap!")$MalSubr).eval; +eval @=> (repl_env.get("apply")$MalSubr).eval; +eval @=> (repl_env.get("map")$MalSubr).eval; + +fun MalObject[] MalArgv(string args[]) +{ + MalObject values[0]; + + for( 1 => int i; i < args.size(); i++ ) + { + values << MalString.create(args[i]); + } + + return values; +} + +// NOTE: normally I'd use \0, but strings are null-terminated... +String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; +repl_env.set("*ARGV*", MalList.create(MalArgv(args))); + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + + EVAL(m, repl_env) @=> MalObject result; + if( result.type == "error" ) + { + return errorMessage(result); + } + + return PRINT(result); +} + +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +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)))))))"); + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +if( args.size() > 0 ) +{ + args[0] => string filename; + rep("(load-file \"" + filename + "\")"); +} +else +{ + main(); +} diff --git a/impls/chuck/stepA_mal.ck b/impls/chuck/stepA_mal.ck index 303a166912..75c957f5fe 100644 --- a/impls/chuck/stepA_mal.ck +++ b/impls/chuck/stepA_mal.ck @@ -1,502 +1,502 @@ -// @import readline.ck -// @import types/boxed/*.ck -// @import types/MalObject.ck -// @import types/mal/MalAtom.ck -// @import types/mal/MalError.ck -// @import types/mal/MalNil.ck -// @import types/mal/MalFalse.ck -// @import types/mal/MalTrue.ck -// @import types/mal/MalInt.ck -// @import types/mal/MalString.ck -// @import types/mal/MalSymbol.ck -// @import types/mal/MalKeyword.ck -// @import types/mal/MalList.ck -// @import types/mal/MalVector.ck -// @import types/mal/MalHashMap.ck -// @import util/*.ck -// @import reader.ck -// @import printer.ck -// @import env.ck -// @import func.ck -// @import types/MalSubr.ck -// @import types/subr/*.ck -// @import core.ck - -fun MalObject READ(string input) -{ - return Reader.read_str(input); -} - -fun int starts_with(MalObject a[], string sym) -{ - if (a.size() != 2) - { - return false; - } - a[0] @=> MalObject a0; - return a0.type == "symbol" && (a0$MalSymbol).value() == sym; -} -fun MalList qq_loop(MalObject elt, MalList acc) -{ - if( elt.type == "list" && starts_with ((elt$MalList).value(), "splice-unquote") ) - { - return MalList.create([MalSymbol.create("concat"), (elt$MalList).value()[1], acc]); - } - return MalList.create([MalSymbol.create("cons"), quasiquote(elt), acc]); -} -fun MalList qq_foldr(MalObject a[]) -{ - MalObject empty[0]; // empty, but typed - MalList.create(empty) @=> MalList acc; - for( a.size() - 1 => int i; 0 <= i; i-- ) - { - qq_loop(a[i], acc) @=> acc; - } - return acc; -} -fun MalObject quasiquote(MalObject ast) -{ - ast.type => string type; - if (type == "list") { - if (starts_with((ast$MalList).value(), "unquote")) - { - return (ast$MalList).value()[1]; - } - return qq_foldr((ast$MalList).value()); - } - if (type == "vector") - { - return MalList.create([MalSymbol.create("vec"), qq_foldr((ast$MalVector).value())]); - } - if (type == "symbol" || type == "hashmap") - { - return MalList.create([MalSymbol.create("quote"), ast]); - } - return ast; -} - -fun int isMacroCall(MalObject ast, Env env) -{ - if( ast.type == "list" ) - { - (ast$MalList).value() @=> MalObject a[]; - - if( a[0].type == "symbol" ) - { - (a[0]$MalSymbol).value() => string name; - env.find(name) @=> MalObject value; - - if( value != null && value.type == "func" && (value$Func).isMacro ) - { - return true; - } - } - } - - return false; -} - -fun MalObject macroexpand(MalObject ast, Env env) -{ - while( isMacroCall(ast, env) ) - { - Util.sequenceToMalObjectArray(ast) @=> MalObject list[]; - (list[0]$MalSymbol).value() => string name; - env.get(name) @=> MalObject macro; - MalObject.slice(list, 1) @=> MalObject args[]; - - if( macro.type == "subr" ) - { - (macro$MalSubr).call(args) @=> ast; - } - else // macro.type == "func" - { - macro$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - EVAL(func.ast, eval_env) @=> ast; - } - } - - return ast; -} - -fun MalObject EVAL(MalObject m, Env env) -{ - while( true ) - { - if( m.type != "list" ) - { - return eval_ast(m, env); - } - - if( (m$MalList).value().size() == 0 ) - { - return m; - } - - macroexpand(m, env) @=> m; - - if( m.type != "list" ) - { - return eval_ast(m, env); - } - - (m$MalList).value() @=> MalObject ast[]; - - if( ast[0].type == "symbol" ) - { - (ast[0]$MalSymbol).value() => string a0; - - if( a0 == "def!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - env.set(a1, value); - return value; - } - else if( a0 == "let*" ) - { - Env.create(env) @=> Env let_env; - Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; - - for( 0 => int i; i < bindings.size(); 2 +=> i) - { - (bindings[i]$MalSymbol).value() => string symbol; - EVAL(bindings[i+1], let_env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - let_env.set(symbol, value); - } - - let_env @=> env; - ast[2] @=> m; - continue; // TCO - } - else if( a0 == "quote" ) - { - return ast[1]; - } - else if( a0 == "quasiquoteexpand" ) - { - return quasiquote(ast[1]); - } - else if( a0 == "quasiquote" ) - { - quasiquote(ast[1]) @=> m; - continue; // TCO - } - else if( a0 == "defmacro!" ) - { - (ast[1]$MalSymbol).value() => string a1; - - EVAL(ast[2], env) @=> MalObject value; - if( value.type == "error" ) - { - return value; - } - - true => (value$Func).isMacro; - - env.set(a1, value); - return value; - } - else if( a0 == "macroexpand" ) - { - return macroexpand(ast[1], env); - } - else if( a0 == "try*" ) - { - EVAL(ast[1], env) @=> MalObject value; - - if( (value.type != "error") || (ast.size() < 3) ) - { - return value; - } - - (ast[2]$MalList).value() @=> MalObject form[]; - (form[1]$MalSymbol).value() => string name; - - Env.create(env, [name], [(value$MalError).value()]) @=> Env error_env; - return EVAL(form[2], error_env); - } - else if( a0 == "do" ) - { - MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; - eval_ast(MalList.create(forms), env) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - // HACK: this assumes do gets at least one argument... - ast[ast.size()-1] @=> m; - continue; // TCO - } - else if( a0 == "if" ) - { - EVAL(ast[1], env) @=> MalObject condition; - - if( condition.type == "error" ) - { - return condition; - } - - if( !(condition.type == "nil") && !(condition.type == "false") ) - { - ast[2] @=> m; - continue; // TCO - } - else - { - if( ast.size() < 4 ) - { - return Constants.NIL; - } - else - { - ast[3] @=> m; - continue; // TCO - } - } - } - else if( a0 == "fn*" ) - { - (ast[1]$MalList).value() @=> MalObject arg_values[]; - string args[arg_values.size()]; - - for( 0 => int i; i < arg_values.size(); i++ ) - { - (arg_values[i]$MalSymbol).value() => args[i]; - } - - ast[2] @=> MalObject _ast; - - return Func.create(env, args, _ast); - } - } - - eval_ast(m, env) @=> MalObject result; - if( result.type == "error" ) - { - return result; - } - - (result$MalList).value() @=> MalObject values[]; - values[0].type => string type; - MalObject.slice(values, 1) @=> MalObject args[]; - - if( type == "subr" ) - { - values[0]$MalSubr @=> MalSubr subr; - return subr.call(args); - } - else // type == "func" - { - values[0]$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - eval_env @=> env; - func.ast @=> m; - continue; // TCO - } - } -} - -fun MalObject eval_ast(MalObject m, Env env) -{ - m.type => string type; - - if( type == "symbol" ) - { - (m$MalSymbol).value() => string symbol; - return env.get(symbol); - } - else if( type == "list" || type == "vector" || type == "hashmap" ) - { - (m$MalList).value() @=> MalObject values[]; - MalObject results[values.size()]; - - if( type != "hashmap" ) - { - for( 0 => int i; i < values.size(); i++ ) - { - EVAL(values[i], env) @=> MalObject result; - - if( result.type == "error" ) - { - return result; - } - - result @=> results[i]; - } - } - else - { - for( 0 => int i; i < values.size(); i++ ) - { - if( i % 2 == 0 ) - { - values[i] @=> results[i]; - } - else - { - EVAL(values[i], env) @=> results[i]; - } - } - } - - if( type == "list" ) - { - return MalList.create(results); - } - else if( type == "vector" ) - { - return MalVector.create(results); - } - else if( type == "hashmap" ) - { - return MalHashMap.create(results); - } - } - else - { - return m; - } -} - -fun string PRINT(MalObject m) -{ - return Printer.pr_str(m, true); -} - -Env.create(null) @=> Env repl_env; -for( 0 => int i; i < Core.names.size(); i++ ) -{ - Core.names[i] => string name; - repl_env.set(name, Core.ns[name]); -} - -// HACK, HACK, HACK -class MalEval extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject m; - return EVAL(args[0], repl_env); - } - - fun MalObject apply(MalObject f, MalObject args[]) - { - if( f.type == "subr" ) - { - return (f$MalSubr).call(args); - } - else // f.type == "func" - { - f$Func @=> Func func; - Env.create(func.env, func.args, args) @=> Env eval_env; - return EVAL(func.ast, eval_env); - } - } -} - -new MalEval @=> MalEval eval; -repl_env.set("eval", new MalEval); -eval @=> (repl_env.get("swap!")$MalSubr).eval; -eval @=> (repl_env.get("apply")$MalSubr).eval; -eval @=> (repl_env.get("map")$MalSubr).eval; - -fun MalObject[] MalArgv(string args[]) -{ - MalObject values[0]; - - for( 1 => int i; i < args.size(); i++ ) - { - values << MalString.create(args[i]); - } - - return values; -} - -// NOTE: normally I'd use \0, but strings are null-terminated... -String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; -repl_env.set("*ARGV*", MalList.create(MalArgv(args))); - -repl_env.set("*host-language*", MalString.create("chuck")); - -fun string errorMessage(MalObject m) -{ - (m$MalError).value() @=> MalObject value; - return "exception: " + Printer.pr_str(value, true); -} - -fun string rep(string input) -{ - READ(input) @=> MalObject m; - - if( m.type == "error" ) - { - return errorMessage(m); - } - - EVAL(m, repl_env) @=> MalObject result; - if( result.type == "error" ) - { - return errorMessage(result); - } - - return PRINT(result); -} - -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -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)))))))"); - -fun void main() -{ - int done; - - while( !done ) - { - Readline.readline("user> ") => string input; - - if( input != null ) - { - rep(input) => string output; - - if( output == "empty input" ) - { - // proceed immediately with prompt - } - else - { - Util.println(output); - } - } - else - { - true => done; - } - } -} - -if( args.size() > 0 ) -{ - args[0] => string filename; - rep("(load-file \"" + filename + "\")"); -} -else -{ - rep("(println (str \"Mal [\" *host-language* \"]\"))"); - main(); -} +// @import readline.ck +// @import types/boxed/*.ck +// @import types/MalObject.ck +// @import types/mal/MalAtom.ck +// @import types/mal/MalError.ck +// @import types/mal/MalNil.ck +// @import types/mal/MalFalse.ck +// @import types/mal/MalTrue.ck +// @import types/mal/MalInt.ck +// @import types/mal/MalString.ck +// @import types/mal/MalSymbol.ck +// @import types/mal/MalKeyword.ck +// @import types/mal/MalList.ck +// @import types/mal/MalVector.ck +// @import types/mal/MalHashMap.ck +// @import util/*.ck +// @import reader.ck +// @import printer.ck +// @import env.ck +// @import func.ck +// @import types/MalSubr.ck +// @import types/subr/*.ck +// @import core.ck + +fun MalObject READ(string input) +{ + return Reader.read_str(input); +} + +fun int starts_with(MalObject a[], string sym) +{ + if (a.size() != 2) + { + return false; + } + a[0] @=> MalObject a0; + return a0.type == "symbol" && (a0$MalSymbol).value() == sym; +} +fun MalList qq_loop(MalObject elt, MalList acc) +{ + if( elt.type == "list" && starts_with ((elt$MalList).value(), "splice-unquote") ) + { + return MalList.create([MalSymbol.create("concat"), (elt$MalList).value()[1], acc]); + } + return MalList.create([MalSymbol.create("cons"), quasiquote(elt), acc]); +} +fun MalList qq_foldr(MalObject a[]) +{ + MalObject empty[0]; // empty, but typed + MalList.create(empty) @=> MalList acc; + for( a.size() - 1 => int i; 0 <= i; i-- ) + { + qq_loop(a[i], acc) @=> acc; + } + return acc; +} +fun MalObject quasiquote(MalObject ast) +{ + ast.type => string type; + if (type == "list") { + if (starts_with((ast$MalList).value(), "unquote")) + { + return (ast$MalList).value()[1]; + } + return qq_foldr((ast$MalList).value()); + } + if (type == "vector") + { + return MalList.create([MalSymbol.create("vec"), qq_foldr((ast$MalVector).value())]); + } + if (type == "symbol" || type == "hashmap") + { + return MalList.create([MalSymbol.create("quote"), ast]); + } + return ast; +} + +fun int isMacroCall(MalObject ast, Env env) +{ + if( ast.type == "list" ) + { + (ast$MalList).value() @=> MalObject a[]; + + if( a[0].type == "symbol" ) + { + (a[0]$MalSymbol).value() => string name; + env.find(name) @=> MalObject value; + + if( value != null && value.type == "func" && (value$Func).isMacro ) + { + return true; + } + } + } + + return false; +} + +fun MalObject macroexpand(MalObject ast, Env env) +{ + while( isMacroCall(ast, env) ) + { + Util.sequenceToMalObjectArray(ast) @=> MalObject list[]; + (list[0]$MalSymbol).value() => string name; + env.get(name) @=> MalObject macro; + MalObject.slice(list, 1) @=> MalObject args[]; + + if( macro.type == "subr" ) + { + (macro$MalSubr).call(args) @=> ast; + } + else // macro.type == "func" + { + macro$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + EVAL(func.ast, eval_env) @=> ast; + } + } + + return ast; +} + +fun MalObject EVAL(MalObject m, Env env) +{ + while( true ) + { + if( m.type != "list" ) + { + return eval_ast(m, env); + } + + if( (m$MalList).value().size() == 0 ) + { + return m; + } + + macroexpand(m, env) @=> m; + + if( m.type != "list" ) + { + return eval_ast(m, env); + } + + (m$MalList).value() @=> MalObject ast[]; + + if( ast[0].type == "symbol" ) + { + (ast[0]$MalSymbol).value() => string a0; + + if( a0 == "def!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + env.set(a1, value); + return value; + } + else if( a0 == "let*" ) + { + Env.create(env) @=> Env let_env; + Util.sequenceToMalObjectArray(ast[1]) @=> MalObject bindings[]; + + for( 0 => int i; i < bindings.size(); 2 +=> i) + { + (bindings[i]$MalSymbol).value() => string symbol; + EVAL(bindings[i+1], let_env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + let_env.set(symbol, value); + } + + let_env @=> env; + ast[2] @=> m; + continue; // TCO + } + else if( a0 == "quote" ) + { + return ast[1]; + } + else if( a0 == "quasiquoteexpand" ) + { + return quasiquote(ast[1]); + } + else if( a0 == "quasiquote" ) + { + quasiquote(ast[1]) @=> m; + continue; // TCO + } + else if( a0 == "defmacro!" ) + { + (ast[1]$MalSymbol).value() => string a1; + + EVAL(ast[2], env) @=> MalObject value; + if( value.type == "error" ) + { + return value; + } + + true => (value$Func).isMacro; + + env.set(a1, value); + return value; + } + else if( a0 == "macroexpand" ) + { + return macroexpand(ast[1], env); + } + else if( a0 == "try*" ) + { + EVAL(ast[1], env) @=> MalObject value; + + if( (value.type != "error") || (ast.size() < 3) ) + { + return value; + } + + (ast[2]$MalList).value() @=> MalObject form[]; + (form[1]$MalSymbol).value() => string name; + + Env.create(env, [name], [(value$MalError).value()]) @=> Env error_env; + return EVAL(form[2], error_env); + } + else if( a0 == "do" ) + { + MalObject.slice(ast, 1, ast.size()-1) @=> MalObject forms[]; + eval_ast(MalList.create(forms), env) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + // HACK: this assumes do gets at least one argument... + ast[ast.size()-1] @=> m; + continue; // TCO + } + else if( a0 == "if" ) + { + EVAL(ast[1], env) @=> MalObject condition; + + if( condition.type == "error" ) + { + return condition; + } + + if( !(condition.type == "nil") && !(condition.type == "false") ) + { + ast[2] @=> m; + continue; // TCO + } + else + { + if( ast.size() < 4 ) + { + return Constants.NIL; + } + else + { + ast[3] @=> m; + continue; // TCO + } + } + } + else if( a0 == "fn*" ) + { + (ast[1]$MalList).value() @=> MalObject arg_values[]; + string args[arg_values.size()]; + + for( 0 => int i; i < arg_values.size(); i++ ) + { + (arg_values[i]$MalSymbol).value() => args[i]; + } + + ast[2] @=> MalObject _ast; + + return Func.create(env, args, _ast); + } + } + + eval_ast(m, env) @=> MalObject result; + if( result.type == "error" ) + { + return result; + } + + (result$MalList).value() @=> MalObject values[]; + values[0].type => string type; + MalObject.slice(values, 1) @=> MalObject args[]; + + if( type == "subr" ) + { + values[0]$MalSubr @=> MalSubr subr; + return subr.call(args); + } + else // type == "func" + { + values[0]$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + eval_env @=> env; + func.ast @=> m; + continue; // TCO + } + } +} + +fun MalObject eval_ast(MalObject m, Env env) +{ + m.type => string type; + + if( type == "symbol" ) + { + (m$MalSymbol).value() => string symbol; + return env.get(symbol); + } + else if( type == "list" || type == "vector" || type == "hashmap" ) + { + (m$MalList).value() @=> MalObject values[]; + MalObject results[values.size()]; + + if( type != "hashmap" ) + { + for( 0 => int i; i < values.size(); i++ ) + { + EVAL(values[i], env) @=> MalObject result; + + if( result.type == "error" ) + { + return result; + } + + result @=> results[i]; + } + } + else + { + for( 0 => int i; i < values.size(); i++ ) + { + if( i % 2 == 0 ) + { + values[i] @=> results[i]; + } + else + { + EVAL(values[i], env) @=> results[i]; + } + } + } + + if( type == "list" ) + { + return MalList.create(results); + } + else if( type == "vector" ) + { + return MalVector.create(results); + } + else if( type == "hashmap" ) + { + return MalHashMap.create(results); + } + } + else + { + return m; + } +} + +fun string PRINT(MalObject m) +{ + return Printer.pr_str(m, true); +} + +Env.create(null) @=> Env repl_env; +for( 0 => int i; i < Core.names.size(); i++ ) +{ + Core.names[i] => string name; + repl_env.set(name, Core.ns[name]); +} + +// HACK, HACK, HACK +class MalEval extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject m; + return EVAL(args[0], repl_env); + } + + fun MalObject apply(MalObject f, MalObject args[]) + { + if( f.type == "subr" ) + { + return (f$MalSubr).call(args); + } + else // f.type == "func" + { + f$Func @=> Func func; + Env.create(func.env, func.args, args) @=> Env eval_env; + return EVAL(func.ast, eval_env); + } + } +} + +new MalEval @=> MalEval eval; +repl_env.set("eval", new MalEval); +eval @=> (repl_env.get("swap!")$MalSubr).eval; +eval @=> (repl_env.get("apply")$MalSubr).eval; +eval @=> (repl_env.get("map")$MalSubr).eval; + +fun MalObject[] MalArgv(string args[]) +{ + MalObject values[0]; + + for( 1 => int i; i < args.size(); i++ ) + { + values << MalString.create(args[i]); + } + + return values; +} + +// NOTE: normally I'd use \0, but strings are null-terminated... +String.split(Std.getenv("CHUCK_ARGS"), "\a") @=> string args[]; +repl_env.set("*ARGV*", MalList.create(MalArgv(args))); + +repl_env.set("*host-language*", MalString.create("chuck")); + +fun string errorMessage(MalObject m) +{ + (m$MalError).value() @=> MalObject value; + return "exception: " + Printer.pr_str(value, true); +} + +fun string rep(string input) +{ + READ(input) @=> MalObject m; + + if( m.type == "error" ) + { + return errorMessage(m); + } + + EVAL(m, repl_env) @=> MalObject result; + if( result.type == "error" ) + { + return errorMessage(result); + } + + return PRINT(result); +} + +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +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)))))))"); + +fun void main() +{ + int done; + + while( !done ) + { + Readline.readline("user> ") => string input; + + if( input != null ) + { + rep(input) => string output; + + if( output == "empty input" ) + { + // proceed immediately with prompt + } + else + { + Util.println(output); + } + } + else + { + true => done; + } + } +} + +if( args.size() > 0 ) +{ + args[0] => string filename; + rep("(load-file \"" + filename + "\")"); +} +else +{ + rep("(println (str \"Mal [\" *host-language* \"]\"))"); + main(); +} diff --git a/impls/chuck/tests/step5_tco.mal b/impls/chuck/tests/step5_tco.mal index c4a73cc207..3af69a2f8a 100644 --- a/impls/chuck/tests/step5_tco.mal +++ b/impls/chuck/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; ChucK: skipping non-TCO recursion -;; Reason: stackoverflow (non-recoverable) +;; ChucK: skipping non-TCO recursion +;; Reason: stackoverflow (non-recoverable) diff --git a/impls/chuck/types/MalObject.ck b/impls/chuck/types/MalObject.ck index 9d200f4d0b..a9457c6023 100644 --- a/impls/chuck/types/MalObject.ck +++ b/impls/chuck/types/MalObject.ck @@ -1,100 +1,100 @@ -public class MalObject -{ - string type; - Object object; - Object objects[]; - // HACK: data types can't be self-referential - // NOTE: an object member does *not* default to null... - null => Object meta; - - fun MalObject clone() - { - MalObject value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } - - // helpers for sequence types - - fun static MalObject[] toMalObjectArray(Object objects[]) - { - MalObject values[objects.size()]; - - for( 0 => int i; i < objects.size(); i++ ) - { - objects[i]$MalObject @=> values[i]; - } - - return values; - } - - fun static Object[] toObjectArray(MalObject objects[]) - { - Object values[objects.size()]; - - for( 0 => int i; i < objects.size(); i++ ) - { - objects[i]$Object @=> values[i]; - } - - return values; - } - - fun static MalObject[] slice(MalObject objects[], int index) - { - MalObject values[objects.size() - index]; - - for( index => int i; i < objects.size(); i++ ) - { - objects[i] @=> values[i - index]; - } - - return values; - } - - fun static MalObject[] slice(MalObject objects[], int from, int to) - { - MalObject values[0]; - - for( from => int i; i < to; i++ ) - { - values << objects[i]; - } - - return values; - } - - fun static MalObject[] append(MalObject as[], MalObject bs[]) - { - MalObject output[as.size()+bs.size()]; - - for( 0 => int i; i < as.size(); i++ ) - { - as[i] @=> output[i]; - } - - for( 0 => int i; i < bs.size(); i++ ) - { - bs[i] @=> output[as.size()+i]; - } - - return output; - } - - fun static MalObject[] reverse(MalObject objects[]) - { - MalObject output[objects.size()]; - - for( 0 => int i; i < output.size(); i++ ) - { - objects[i] @=> output[output.size()-i-1]; - } - - return output; - } -} +public class MalObject +{ + string type; + Object object; + Object objects[]; + // HACK: data types can't be self-referential + // NOTE: an object member does *not* default to null... + null => Object meta; + + fun MalObject clone() + { + MalObject value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } + + // helpers for sequence types + + fun static MalObject[] toMalObjectArray(Object objects[]) + { + MalObject values[objects.size()]; + + for( 0 => int i; i < objects.size(); i++ ) + { + objects[i]$MalObject @=> values[i]; + } + + return values; + } + + fun static Object[] toObjectArray(MalObject objects[]) + { + Object values[objects.size()]; + + for( 0 => int i; i < objects.size(); i++ ) + { + objects[i]$Object @=> values[i]; + } + + return values; + } + + fun static MalObject[] slice(MalObject objects[], int index) + { + MalObject values[objects.size() - index]; + + for( index => int i; i < objects.size(); i++ ) + { + objects[i] @=> values[i - index]; + } + + return values; + } + + fun static MalObject[] slice(MalObject objects[], int from, int to) + { + MalObject values[0]; + + for( from => int i; i < to; i++ ) + { + values << objects[i]; + } + + return values; + } + + fun static MalObject[] append(MalObject as[], MalObject bs[]) + { + MalObject output[as.size()+bs.size()]; + + for( 0 => int i; i < as.size(); i++ ) + { + as[i] @=> output[i]; + } + + for( 0 => int i; i < bs.size(); i++ ) + { + bs[i] @=> output[as.size()+i]; + } + + return output; + } + + fun static MalObject[] reverse(MalObject objects[]) + { + MalObject output[objects.size()]; + + for( 0 => int i; i < output.size(); i++ ) + { + objects[i] @=> output[output.size()-i-1]; + } + + return output; + } +} diff --git a/impls/chuck/types/MalSubr.ck b/impls/chuck/types/MalSubr.ck index 0dc99a3762..713c6ec7ab 100644 --- a/impls/chuck/types/MalSubr.ck +++ b/impls/chuck/types/MalSubr.ck @@ -1,17 +1,17 @@ -public class MalSubr extends MalObject -{ - "subr" => type; - string name; - // HACK - MalObject eval; - - fun MalObject call(MalObject args[]) - { - return new MalObject; - } - - fun MalObject apply(MalObject f, MalObject args[]) - { - return new MalObject; - } -} +public class MalSubr extends MalObject +{ + "subr" => type; + string name; + // HACK + MalObject eval; + + fun MalObject call(MalObject args[]) + { + return new MalObject; + } + + fun MalObject apply(MalObject f, MalObject args[]) + { + return new MalObject; + } +} diff --git a/impls/chuck/types/boxed/Int.ck b/impls/chuck/types/boxed/Int.ck index d2c3b81f42..8eb64c5e04 100644 --- a/impls/chuck/types/boxed/Int.ck +++ b/impls/chuck/types/boxed/Int.ck @@ -1,11 +1,11 @@ -public class Int -{ - int value; - - fun static Int create(int value) - { - Int i; - value => i.value; - return i; - } -} +public class Int +{ + int value; + + fun static Int create(int value) + { + Int i; + value => i.value; + return i; + } +} diff --git a/impls/chuck/types/boxed/String.ck b/impls/chuck/types/boxed/String.ck index 4c7390a8b3..a8b13fcffa 100644 --- a/impls/chuck/types/boxed/String.ck +++ b/impls/chuck/types/boxed/String.ck @@ -1,130 +1,130 @@ -public class String -{ - string value; - - fun static String create(string value) - { - String s; - value => s.value; - return s; - } - - // helpers - - // "x".substring(1) errors out (bug?), this doesn't - fun static string slice(string input, int index) - { - if( index == input.length() ) - { - return ""; - } - else - { - return input.substring(index); - } - } - - fun static string slice(string input, int start, int end) - { - if( start == input.length() ) - { - return ""; - } - else - { - return input.substring(start, end - start); - } - } - - fun static string join(string parts[], string separator) - { - if( parts.size() == 0 ) - { - return ""; - } - - parts[0] => string output; - - for( 1 => int i; i < parts.size(); i++ ) - { - output + separator + parts[i] => output; - } - - return output; - } - - fun static string[] split(string input, string separator) - { - string output[0]; - - if( input == "" ) - { - return output; - } - - 0 => int offset; - int index; - - while( true ) - { - input.find(separator, offset) => index; - - if( index == -1 ) - { - output << input.substring(offset); - break; - } - - output << input.substring(offset, index - offset); - index + separator.length() => offset; - } - - return output; - } - - fun static string replaceAll(string input, string pat, string rep) - { - 0 => int offset; - input => string output; - int index; - - while( true ) - { - if( offset >= output.length() ) - { - break; - } - - output.find(pat, offset) => index; - - if( index == -1 ) - { - break; - } - - output.replace(index, pat.length(), rep); - index + rep.length() => offset; - } - - return output; - } - - fun static string parse(string input) - { - slice(input, 1, input.length() - 1) => string output; - replaceAll(output, "\\\\", "\177") => output; - replaceAll(output, "\\\"", "\"") => output; - replaceAll(output, "\\n", "\n") => output; - replaceAll(output, "\177", "\\") => output; - return output; - } - - fun static string repr(string input) - { - input => string output; - replaceAll(output, "\\", "\\\\") => output; - replaceAll(output, "\n", "\\n") => output; - replaceAll(output, "\"", "\\\"") => output; - return "\"" + output + "\""; - } -} +public class String +{ + string value; + + fun static String create(string value) + { + String s; + value => s.value; + return s; + } + + // helpers + + // "x".substring(1) errors out (bug?), this doesn't + fun static string slice(string input, int index) + { + if( index == input.length() ) + { + return ""; + } + else + { + return input.substring(index); + } + } + + fun static string slice(string input, int start, int end) + { + if( start == input.length() ) + { + return ""; + } + else + { + return input.substring(start, end - start); + } + } + + fun static string join(string parts[], string separator) + { + if( parts.size() == 0 ) + { + return ""; + } + + parts[0] => string output; + + for( 1 => int i; i < parts.size(); i++ ) + { + output + separator + parts[i] => output; + } + + return output; + } + + fun static string[] split(string input, string separator) + { + string output[0]; + + if( input == "" ) + { + return output; + } + + 0 => int offset; + int index; + + while( true ) + { + input.find(separator, offset) => index; + + if( index == -1 ) + { + output << input.substring(offset); + break; + } + + output << input.substring(offset, index - offset); + index + separator.length() => offset; + } + + return output; + } + + fun static string replaceAll(string input, string pat, string rep) + { + 0 => int offset; + input => string output; + int index; + + while( true ) + { + if( offset >= output.length() ) + { + break; + } + + output.find(pat, offset) => index; + + if( index == -1 ) + { + break; + } + + output.replace(index, pat.length(), rep); + index + rep.length() => offset; + } + + return output; + } + + fun static string parse(string input) + { + slice(input, 1, input.length() - 1) => string output; + replaceAll(output, "\\\\", "\177") => output; + replaceAll(output, "\\\"", "\"") => output; + replaceAll(output, "\\n", "\n") => output; + replaceAll(output, "\177", "\\") => output; + return output; + } + + fun static string repr(string input) + { + input => string output; + replaceAll(output, "\\", "\\\\") => output; + replaceAll(output, "\n", "\\n") => output; + replaceAll(output, "\"", "\\\"") => output; + return "\"" + output + "\""; + } +} diff --git a/impls/chuck/types/mal/MalAtom.ck b/impls/chuck/types/mal/MalAtom.ck index d6b3a84df7..e3852c23df 100644 --- a/impls/chuck/types/mal/MalAtom.ck +++ b/impls/chuck/types/mal/MalAtom.ck @@ -1,33 +1,33 @@ -public class MalAtom extends MalObject -{ - "atom" => type; - - fun MalObject value() - { - return object$MalObject; - } - - fun void init(MalObject value) - { - value @=> object; - } - - fun static MalObject create(MalObject value) - { - MalAtom m; - m.init(value); - return m; - } - - fun MalObject clone() - { - MalAtom value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalAtom extends MalObject +{ + "atom" => type; + + fun MalObject value() + { + return object$MalObject; + } + + fun void init(MalObject value) + { + value @=> object; + } + + fun static MalObject create(MalObject value) + { + MalAtom m; + m.init(value); + return m; + } + + fun MalObject clone() + { + MalAtom value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalError.ck b/impls/chuck/types/mal/MalError.ck index 7b22f9c707..6ebf25c268 100644 --- a/impls/chuck/types/mal/MalError.ck +++ b/impls/chuck/types/mal/MalError.ck @@ -1,21 +1,21 @@ -public class MalError extends MalObject -{ - "error" => type; - - fun MalObject value() - { - return object$MalObject; - } - - fun void init(MalObject value) - { - value @=> object; - } - - fun static MalError create(MalObject value) - { - MalError m; - m.init(value); - return m; - } -} +public class MalError extends MalObject +{ + "error" => type; + + fun MalObject value() + { + return object$MalObject; + } + + fun void init(MalObject value) + { + value @=> object; + } + + fun static MalError create(MalObject value) + { + MalError m; + m.init(value); + return m; + } +} diff --git a/impls/chuck/types/mal/MalFalse.ck b/impls/chuck/types/mal/MalFalse.ck index a07e078bae..364fc091b1 100644 --- a/impls/chuck/types/mal/MalFalse.ck +++ b/impls/chuck/types/mal/MalFalse.ck @@ -1,28 +1,28 @@ -public class MalFalse extends MalObject -{ - "false" => type; - - fun void init() - { - Int.create(0) @=> object; - } - - fun static MalFalse create() - { - MalFalse m; - m.init(); - return m; - } - - fun MalObject clone() - { - MalFalse value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalFalse extends MalObject +{ + "false" => type; + + fun void init() + { + Int.create(0) @=> object; + } + + fun static MalFalse create() + { + MalFalse m; + m.init(); + return m; + } + + fun MalObject clone() + { + MalFalse value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalHashMap.ck b/impls/chuck/types/mal/MalHashMap.ck index 94ede0e5e2..2ef1ce045f 100644 --- a/impls/chuck/types/mal/MalHashMap.ck +++ b/impls/chuck/types/mal/MalHashMap.ck @@ -1,71 +1,71 @@ -// HACK: it's hard to pull in util before data types -fun string keyName(MalObject m) -{ - if( m.type == "string" ) - { - return (m$MalString).value(); - } - else if (m.type == "keyword" ) - { - return (m$MalKeyword).value(); - } -} - -public class MalHashMap extends MalObject -{ - "hashmap" => type; - - fun MalObject[] value() - { - return MalObject.toMalObjectArray(objects); - } - - fun void init(MalObject values[]) - { - MalObject result[0]; - MalObject cachedKeys[0]; - MalObject cachedValues[0]; - string keys[0]; - - for( 0 => int i; i < values.size(); 2 +=> i ) - { - keyName(values[i]) => string key; - - if( cachedValues[key] == null ) - { - keys << key; - } - - values[i] @=> cachedKeys[key]; - values[i+1] @=> cachedValues[key]; - } - - for( 0 => int i; i < keys.size(); i++ ) - { - keys[i] => string key; - result << cachedKeys[key]; - result << cachedValues[key]; - } - - MalObject.toObjectArray(result) @=> objects; - } - - fun static MalHashMap create(MalObject values[]) - { - MalHashMap m; - m.init(values); - return m; - } - - fun MalObject clone() - { - MalHashMap value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +// HACK: it's hard to pull in util before data types +fun string keyName(MalObject m) +{ + if( m.type == "string" ) + { + return (m$MalString).value(); + } + else if (m.type == "keyword" ) + { + return (m$MalKeyword).value(); + } +} + +public class MalHashMap extends MalObject +{ + "hashmap" => type; + + fun MalObject[] value() + { + return MalObject.toMalObjectArray(objects); + } + + fun void init(MalObject values[]) + { + MalObject result[0]; + MalObject cachedKeys[0]; + MalObject cachedValues[0]; + string keys[0]; + + for( 0 => int i; i < values.size(); 2 +=> i ) + { + keyName(values[i]) => string key; + + if( cachedValues[key] == null ) + { + keys << key; + } + + values[i] @=> cachedKeys[key]; + values[i+1] @=> cachedValues[key]; + } + + for( 0 => int i; i < keys.size(); i++ ) + { + keys[i] => string key; + result << cachedKeys[key]; + result << cachedValues[key]; + } + + MalObject.toObjectArray(result) @=> objects; + } + + fun static MalHashMap create(MalObject values[]) + { + MalHashMap m; + m.init(values); + return m; + } + + fun MalObject clone() + { + MalHashMap value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalInt.ck b/impls/chuck/types/mal/MalInt.ck index 1e00a02d82..235b3333ab 100644 --- a/impls/chuck/types/mal/MalInt.ck +++ b/impls/chuck/types/mal/MalInt.ck @@ -1,33 +1,33 @@ -public class MalInt extends MalObject -{ - "int" => type; - - fun int value() - { - return (object$Int).value; - } - - fun void init(int value) - { - Int.create(value) @=> object; - } - - fun static MalInt create(int value) - { - MalInt m; - m.init(value); - return m; - } - - fun MalObject clone() - { - MalInt value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalInt extends MalObject +{ + "int" => type; + + fun int value() + { + return (object$Int).value; + } + + fun void init(int value) + { + Int.create(value) @=> object; + } + + fun static MalInt create(int value) + { + MalInt m; + m.init(value); + return m; + } + + fun MalObject clone() + { + MalInt value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalKeyword.ck b/impls/chuck/types/mal/MalKeyword.ck index 398540ffa2..71abf0954c 100644 --- a/impls/chuck/types/mal/MalKeyword.ck +++ b/impls/chuck/types/mal/MalKeyword.ck @@ -1,33 +1,33 @@ -public class MalKeyword extends MalObject -{ - "keyword" => type; - - fun string value() - { - return (object$String).value; - } - - fun void init(string value) - { - String.create(value) @=> object; - } - - fun static MalKeyword create(string value) - { - MalKeyword m; - m.init(value); - return m; - } - - fun MalObject clone() - { - MalKeyword value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalKeyword extends MalObject +{ + "keyword" => type; + + fun string value() + { + return (object$String).value; + } + + fun void init(string value) + { + String.create(value) @=> object; + } + + fun static MalKeyword create(string value) + { + MalKeyword m; + m.init(value); + return m; + } + + fun MalObject clone() + { + MalKeyword value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalList.ck b/impls/chuck/types/mal/MalList.ck index 9e6c323bce..95dde7b96a 100644 --- a/impls/chuck/types/mal/MalList.ck +++ b/impls/chuck/types/mal/MalList.ck @@ -1,33 +1,33 @@ -public class MalList extends MalObject -{ - "list" => type; - - fun MalObject[] value() - { - return MalObject.toMalObjectArray(objects); - } - - fun void init(MalObject values[]) - { - MalObject.toObjectArray(values) @=> objects; - } - - fun static MalList create(MalObject values[]) - { - MalList m; - m.init(values); - return m; - } - - fun MalObject clone() - { - MalList value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalList extends MalObject +{ + "list" => type; + + fun MalObject[] value() + { + return MalObject.toMalObjectArray(objects); + } + + fun void init(MalObject values[]) + { + MalObject.toObjectArray(values) @=> objects; + } + + fun static MalList create(MalObject values[]) + { + MalList m; + m.init(values); + return m; + } + + fun MalObject clone() + { + MalList value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalNil.ck b/impls/chuck/types/mal/MalNil.ck index 49e125ee12..ca80addd51 100644 --- a/impls/chuck/types/mal/MalNil.ck +++ b/impls/chuck/types/mal/MalNil.ck @@ -1,28 +1,28 @@ -public class MalNil extends MalObject -{ - "nil" => type; - - fun void init() - { - Int.create(-1) @=> object; - } - - fun static MalNil create() - { - MalNil m; - m.init(); - return m; - } - - fun MalObject clone() - { - MalNil value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalNil extends MalObject +{ + "nil" => type; + + fun void init() + { + Int.create(-1) @=> object; + } + + fun static MalNil create() + { + MalNil m; + m.init(); + return m; + } + + fun MalObject clone() + { + MalNil value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalString.ck b/impls/chuck/types/mal/MalString.ck index 03da4dd369..69cf860b36 100644 --- a/impls/chuck/types/mal/MalString.ck +++ b/impls/chuck/types/mal/MalString.ck @@ -1,33 +1,33 @@ -public class MalString extends MalObject -{ - "string" => type; - - fun string value() - { - return (object$String).value; - } - - fun void init(string value) - { - String.create(value) @=> object; - } - - fun static MalString create(string value) - { - MalString m; - m.init(value); - return m; - } - - fun MalObject clone() - { - MalString value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalString extends MalObject +{ + "string" => type; + + fun string value() + { + return (object$String).value; + } + + fun void init(string value) + { + String.create(value) @=> object; + } + + fun static MalString create(string value) + { + MalString m; + m.init(value); + return m; + } + + fun MalObject clone() + { + MalString value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalSymbol.ck b/impls/chuck/types/mal/MalSymbol.ck index 9a306c43ff..31ec50bc73 100644 --- a/impls/chuck/types/mal/MalSymbol.ck +++ b/impls/chuck/types/mal/MalSymbol.ck @@ -1,33 +1,33 @@ -public class MalSymbol extends MalObject -{ - "symbol" => type; - - fun string value() - { - return (object$String).value; - } - - fun void init(string value) - { - String.create(value) @=> object; - } - - fun static MalSymbol create(string value) - { - MalSymbol m; - m.init(value); - return m; - } - - fun MalObject clone() - { - MalSymbol value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalSymbol extends MalObject +{ + "symbol" => type; + + fun string value() + { + return (object$String).value; + } + + fun void init(string value) + { + String.create(value) @=> object; + } + + fun static MalSymbol create(string value) + { + MalSymbol m; + m.init(value); + return m; + } + + fun MalObject clone() + { + MalSymbol value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalTrue.ck b/impls/chuck/types/mal/MalTrue.ck index 2675929afc..ab184e8e08 100644 --- a/impls/chuck/types/mal/MalTrue.ck +++ b/impls/chuck/types/mal/MalTrue.ck @@ -1,28 +1,28 @@ -public class MalTrue extends MalObject -{ - "true" => type; - - fun void init() - { - Int.create(1) @=> object; - } - - fun static MalTrue create() - { - MalTrue m; - m.init(); - return m; - } - - fun MalObject clone() - { - MalTrue value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalTrue extends MalObject +{ + "true" => type; + + fun void init() + { + Int.create(1) @=> object; + } + + fun static MalTrue create() + { + MalTrue m; + m.init(); + return m; + } + + fun MalObject clone() + { + MalTrue value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/mal/MalVector.ck b/impls/chuck/types/mal/MalVector.ck index 521658c9a9..0d3a21b8b8 100644 --- a/impls/chuck/types/mal/MalVector.ck +++ b/impls/chuck/types/mal/MalVector.ck @@ -1,33 +1,33 @@ -public class MalVector extends MalObject -{ - "vector" => type; - - fun MalObject[] value() - { - return MalObject.toMalObjectArray(objects); - } - - fun void init(MalObject values[]) - { - MalObject.toObjectArray(values) @=> objects; - } - - fun static MalVector create(MalObject values[]) - { - MalVector m; - m.init(values); - return m; - } - - fun MalObject clone() - { - MalVector value; - - this.type => value.type; - this.object @=> value.object; - this.objects @=> value.objects; - this.meta @=> value.meta; - - return value; - } -} +public class MalVector extends MalObject +{ + "vector" => type; + + fun MalObject[] value() + { + return MalObject.toMalObjectArray(objects); + } + + fun void init(MalObject values[]) + { + MalObject.toObjectArray(values) @=> objects; + } + + fun static MalVector create(MalObject values[]) + { + MalVector m; + m.init(values); + return m; + } + + fun MalObject clone() + { + MalVector value; + + this.type => value.type; + this.object @=> value.object; + this.objects @=> value.objects; + this.meta @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/types/subr/MalAdd.ck b/impls/chuck/types/subr/MalAdd.ck index 7caf80f8fa..6668902b9e 100644 --- a/impls/chuck/types/subr/MalAdd.ck +++ b/impls/chuck/types/subr/MalAdd.ck @@ -1,10 +1,10 @@ -public class MalAdd extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalInt @=> MalInt a; - args[1]$MalInt @=> MalInt b; - - return MalInt.create(a.value() + b.value()); - } -} +public class MalAdd extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalInt @=> MalInt a; + args[1]$MalInt @=> MalInt b; + + return MalInt.create(a.value() + b.value()); + } +} diff --git a/impls/chuck/types/subr/MalApply.ck b/impls/chuck/types/subr/MalApply.ck index 62f0b807a4..08b5018720 100644 --- a/impls/chuck/types/subr/MalApply.ck +++ b/impls/chuck/types/subr/MalApply.ck @@ -1,12 +1,12 @@ -public class MalApply extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject f; - MalObject.slice(args, 1, args.size()-1) @=> MalObject _args[]; - (args[args.size()-1]$MalList).value() @=> MalObject rest[]; - - MalObject.append(_args, rest) @=> _args; - return (eval$MalSubr).apply(f, _args); - } -} +public class MalApply extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject f; + MalObject.slice(args, 1, args.size()-1) @=> MalObject _args[]; + (args[args.size()-1]$MalList).value() @=> MalObject rest[]; + + MalObject.append(_args, rest) @=> _args; + return (eval$MalSubr).apply(f, _args); + } +} diff --git a/impls/chuck/types/subr/MalAssoc.ck b/impls/chuck/types/subr/MalAssoc.ck index 1b0142e14f..7218243a77 100644 --- a/impls/chuck/types/subr/MalAssoc.ck +++ b/impls/chuck/types/subr/MalAssoc.ck @@ -1,45 +1,45 @@ -public class MalAssoc extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalHashMap).value() @=> MalObject map[]; - MalObject.slice(args, 1) @=> MalObject kvs[]; - - MalObject result[0]; - MalObject cachedKeys[0]; - MalObject cachedValues[0]; - string keys[0]; - - for( 0 => int i; i < map.size(); 2 +=> i ) - { - Util.keyName(map[i]) => string key; - - keys << key; - - map[i] @=> cachedKeys[key]; - map[i+1] @=> cachedValues[key]; - } - - for( 0 => int i; i < kvs.size(); 2 +=> i ) - { - Util.keyName(kvs[i]) => string key; - - if( cachedValues[key] == null ) - { - keys << key; - } - - kvs[i] @=> cachedKeys[key]; - kvs[i+1] @=> cachedValues[key]; - } - - for( 0 => int i; i < keys.size(); i++ ) - { - keys[i] => string key; - result << cachedKeys[key]; - result << cachedValues[key]; - } - - return MalHashMap.create(result); - } -} +public class MalAssoc extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalHashMap).value() @=> MalObject map[]; + MalObject.slice(args, 1) @=> MalObject kvs[]; + + MalObject result[0]; + MalObject cachedKeys[0]; + MalObject cachedValues[0]; + string keys[0]; + + for( 0 => int i; i < map.size(); 2 +=> i ) + { + Util.keyName(map[i]) => string key; + + keys << key; + + map[i] @=> cachedKeys[key]; + map[i+1] @=> cachedValues[key]; + } + + for( 0 => int i; i < kvs.size(); 2 +=> i ) + { + Util.keyName(kvs[i]) => string key; + + if( cachedValues[key] == null ) + { + keys << key; + } + + kvs[i] @=> cachedKeys[key]; + kvs[i+1] @=> cachedValues[key]; + } + + for( 0 => int i; i < keys.size(); i++ ) + { + keys[i] => string key; + result << cachedKeys[key]; + result << cachedValues[key]; + } + + return MalHashMap.create(result); + } +} diff --git a/impls/chuck/types/subr/MalAtomify.ck b/impls/chuck/types/subr/MalAtomify.ck index 3ec8b21733..75d18dc6e9 100644 --- a/impls/chuck/types/subr/MalAtomify.ck +++ b/impls/chuck/types/subr/MalAtomify.ck @@ -1,8 +1,8 @@ -public class MalAtomify extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject m; - return MalAtom.create(m); - } -} +public class MalAtomify extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject m; + return MalAtom.create(m); + } +} diff --git a/impls/chuck/types/subr/MalConcat.ck b/impls/chuck/types/subr/MalConcat.ck index 8ea97778ac..bd1ab0d4bf 100644 --- a/impls/chuck/types/subr/MalConcat.ck +++ b/impls/chuck/types/subr/MalConcat.ck @@ -1,15 +1,15 @@ -public class MalConcat extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - MalObject value[0]; - - for( 0 => int i; i < args.size(); i++ ) - { - Util.sequenceToMalObjectArray(args[i]) @=> MalObject list[]; - MalObject.append(value, list) @=> value; - } - - return MalList.create(value); - } -} +public class MalConcat extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + MalObject value[0]; + + for( 0 => int i; i < args.size(); i++ ) + { + Util.sequenceToMalObjectArray(args[i]) @=> MalObject list[]; + MalObject.append(value, list) @=> value; + } + + return MalList.create(value); + } +} diff --git a/impls/chuck/types/subr/MalConj.ck b/impls/chuck/types/subr/MalConj.ck index 436fda6063..4a7542c4ea 100644 --- a/impls/chuck/types/subr/MalConj.ck +++ b/impls/chuck/types/subr/MalConj.ck @@ -1,17 +1,17 @@ -public class MalConj extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - Util.sequenceToMalObjectArray(args[0]) @=> MalObject list[]; - MalObject.slice(args, 1) @=> MalObject rest[]; - - if( args[0].type == "list" ) - { - return MalList.create(MalObject.append(MalObject.reverse(rest), list)); - } - else // args[0].type == "vector" - { - return MalVector.create(MalObject.append(list, rest)); - } - } -} +public class MalConj extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + Util.sequenceToMalObjectArray(args[0]) @=> MalObject list[]; + MalObject.slice(args, 1) @=> MalObject rest[]; + + if( args[0].type == "list" ) + { + return MalList.create(MalObject.append(MalObject.reverse(rest), list)); + } + else // args[0].type == "vector" + { + return MalVector.create(MalObject.append(list, rest)); + } + } +} diff --git a/impls/chuck/types/subr/MalCons.ck b/impls/chuck/types/subr/MalCons.ck index 500c37c7b7..f35e7ee027 100644 --- a/impls/chuck/types/subr/MalCons.ck +++ b/impls/chuck/types/subr/MalCons.ck @@ -1,9 +1,9 @@ -public class MalCons extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - Util.sequenceToMalObjectArray(args[1]) @=> MalObject list[]; - return MalList.create(MalObject.append([arg], list)); - } -} +public class MalCons extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + Util.sequenceToMalObjectArray(args[1]) @=> MalObject list[]; + return MalList.create(MalObject.append([arg], list)); + } +} diff --git a/impls/chuck/types/subr/MalCount.ck b/impls/chuck/types/subr/MalCount.ck index eda90751a3..f52ec2723b 100644 --- a/impls/chuck/types/subr/MalCount.ck +++ b/impls/chuck/types/subr/MalCount.ck @@ -1,16 +1,16 @@ -public class MalCount extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0].type => string kind; - if( kind == "list" || kind == "vector" ) - { - Util.sequenceToMalObjectArray(args[0]) @=> MalObject values[]; - return MalInt.create(values.size()); - } - else - { - return MalInt.create(0); - } - } -} +public class MalCount extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0].type => string kind; + if( kind == "list" || kind == "vector" ) + { + Util.sequenceToMalObjectArray(args[0]) @=> MalObject values[]; + return MalInt.create(values.size()); + } + else + { + return MalInt.create(0); + } + } +} diff --git a/impls/chuck/types/subr/MalDeref.ck b/impls/chuck/types/subr/MalDeref.ck index 325c62c824..67ce76bcac 100644 --- a/impls/chuck/types/subr/MalDeref.ck +++ b/impls/chuck/types/subr/MalDeref.ck @@ -1,7 +1,7 @@ -public class MalDeref extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - return (args[0]$MalAtom).value(); - } -} +public class MalDeref extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + return (args[0]$MalAtom).value(); + } +} diff --git a/impls/chuck/types/subr/MalDissoc.ck b/impls/chuck/types/subr/MalDissoc.ck index 7f993981ea..83811665c1 100644 --- a/impls/chuck/types/subr/MalDissoc.ck +++ b/impls/chuck/types/subr/MalDissoc.ck @@ -1,33 +1,33 @@ -public class MalDissoc extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalHashMap).value() @=> MalObject map[]; - MalObject.slice(args, 1) @=> MalObject ks[]; - - MalObject result[0]; - int cachedKeys[0]; - - for( 0 => int i; i < ks.size(); i++ ) - { - Util.keyName(ks[i]) => string key; - true => cachedKeys[key]; - } - - for( 0 => int i; i < map.size(); 2 +=> i ) - { - map[i] @=> MalObject key; - map[i+1] @=> MalObject value; - // HACK: using name doesn't work in a nested scope - Util.keyName(key) => string keyName; - - if( !cachedKeys[keyName] ) - { - result << key; - result << value; - } - } - - return MalHashMap.create(result); - } -} +public class MalDissoc extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalHashMap).value() @=> MalObject map[]; + MalObject.slice(args, 1) @=> MalObject ks[]; + + MalObject result[0]; + int cachedKeys[0]; + + for( 0 => int i; i < ks.size(); i++ ) + { + Util.keyName(ks[i]) => string key; + true => cachedKeys[key]; + } + + for( 0 => int i; i < map.size(); 2 +=> i ) + { + map[i] @=> MalObject key; + map[i+1] @=> MalObject value; + // HACK: using name doesn't work in a nested scope + Util.keyName(key) => string keyName; + + if( !cachedKeys[keyName] ) + { + result << key; + result << value; + } + } + + return MalHashMap.create(result); + } +} diff --git a/impls/chuck/types/subr/MalDiv.ck b/impls/chuck/types/subr/MalDiv.ck index 50b5603cb4..3e6352139b 100644 --- a/impls/chuck/types/subr/MalDiv.ck +++ b/impls/chuck/types/subr/MalDiv.ck @@ -1,10 +1,10 @@ -public class MalDiv extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalInt @=> MalInt a; - args[1]$MalInt @=> MalInt b; - - return MalInt.create(a.value() / b.value()); - } -} +public class MalDiv extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalInt @=> MalInt a; + args[1]$MalInt @=> MalInt b; + + return MalInt.create(a.value() / b.value()); + } +} diff --git a/impls/chuck/types/subr/MalDoReset.ck b/impls/chuck/types/subr/MalDoReset.ck index 74838e3b4a..5aa519c1bd 100644 --- a/impls/chuck/types/subr/MalDoReset.ck +++ b/impls/chuck/types/subr/MalDoReset.ck @@ -1,12 +1,12 @@ -public class MalDoReset extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalAtom @=> MalAtom atom; - args[1]$MalObject @=> MalObject value; - - value @=> atom.object; - - return value; - } -} +public class MalDoReset extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalAtom @=> MalAtom atom; + args[1]$MalObject @=> MalObject value; + + value @=> atom.object; + + return value; + } +} diff --git a/impls/chuck/types/subr/MalDoSwap.ck b/impls/chuck/types/subr/MalDoSwap.ck index 586db80be6..bf8c72a098 100644 --- a/impls/chuck/types/subr/MalDoSwap.ck +++ b/impls/chuck/types/subr/MalDoSwap.ck @@ -1,15 +1,15 @@ -public class MalDoSwap extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalAtom @=> MalAtom atom; - atom.value() @=> MalObject value; - args[1] @=> MalObject f; - MalObject.slice(args, 2) @=> MalObject _args[]; - MalObject.append([value], _args) @=> _args; - - (eval$MalSubr).apply(f, _args) @=> value; - value @=> atom.object; - return value; - } -} +public class MalDoSwap extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalAtom @=> MalAtom atom; + atom.value() @=> MalObject value; + args[1] @=> MalObject f; + MalObject.slice(args, 2) @=> MalObject _args[]; + MalObject.append([value], _args) @=> _args; + + (eval$MalSubr).apply(f, _args) @=> value; + value @=> atom.object; + return value; + } +} diff --git a/impls/chuck/types/subr/MalEqual.ck b/impls/chuck/types/subr/MalEqual.ck index 33412842ce..7fc034d3da 100644 --- a/impls/chuck/types/subr/MalEqual.ck +++ b/impls/chuck/types/subr/MalEqual.ck @@ -1,126 +1,126 @@ -public class MalEqual extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject a; - args[1] @=> MalObject b; - - if( ( a.type == "list" || a.type == "vector" ) && - ( b.type == "list" || b.type == "vector" ) ) - { - Util.sequenceToMalObjectArray(a) @=> MalObject as[]; - Util.sequenceToMalObjectArray(b) @=> MalObject bs[]; - - if( as.size() != bs.size() ) - { - return Constants.FALSE; - } - - for( 0 => int i; i < as.size(); i++ ) - { - call([as[i], bs[i]]) @=> MalObject value; - if( value.type != "true" ) - { - return Constants.FALSE; - } - } - - return Constants.TRUE; - } - - if( a.type == "hashmap" && b.type == "hashmap" ) - { - (a$MalHashMap).value() @=> MalObject akvs[]; - (b$MalHashMap).value() @=> MalObject bkvs[]; - - if( akvs.size() != bkvs.size() ) - { - return Constants.FALSE; - } - - MalObject bmap[0]; - - for( 0 => int i; i < bkvs.size(); 2 +=> i ) - { - Util.keyName(bkvs[i]) => string keyName; - bkvs[i+1] @=> bmap[keyName]; - } - - - for( 0 => int i; i < akvs.size(); 2 +=> i ) - { - akvs[i] @=> MalObject key; - akvs[i+1] @=> MalObject value; - Util.keyName(key) => string keyName; - - if( bmap[keyName] == null || - call([value, bmap[keyName]]).type != "true" ) - { - return Constants.FALSE; - } - } - - return Constants.TRUE; - } - - if( a.type != b.type ) - { - return Constants.FALSE; - } - - // NOTE: normally I'd go for a type variable, but its scope - // isn't handled properly in the presence of a member variable - a.type => string kind; - if( kind == "true" || kind == "false" || kind == "nil" ) - { - return Constants.TRUE; - } - else if( kind == "int" ) - { - if( (a$MalInt).value() == (b$MalInt).value() ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } - else if( kind == "string" ) - { - if( (a$MalString).value() == (b$MalString).value() ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } - else if( kind == "symbol" ) - { - if( (a$MalSymbol).value() == (b$MalSymbol).value() ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } - else if( kind == "keyword" ) - { - if( (a$MalKeyword).value() == (b$MalKeyword).value() ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } - - // HACK: return false for everything unknown for now - return Constants.FALSE; - } -} +public class MalEqual extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject a; + args[1] @=> MalObject b; + + if( ( a.type == "list" || a.type == "vector" ) && + ( b.type == "list" || b.type == "vector" ) ) + { + Util.sequenceToMalObjectArray(a) @=> MalObject as[]; + Util.sequenceToMalObjectArray(b) @=> MalObject bs[]; + + if( as.size() != bs.size() ) + { + return Constants.FALSE; + } + + for( 0 => int i; i < as.size(); i++ ) + { + call([as[i], bs[i]]) @=> MalObject value; + if( value.type != "true" ) + { + return Constants.FALSE; + } + } + + return Constants.TRUE; + } + + if( a.type == "hashmap" && b.type == "hashmap" ) + { + (a$MalHashMap).value() @=> MalObject akvs[]; + (b$MalHashMap).value() @=> MalObject bkvs[]; + + if( akvs.size() != bkvs.size() ) + { + return Constants.FALSE; + } + + MalObject bmap[0]; + + for( 0 => int i; i < bkvs.size(); 2 +=> i ) + { + Util.keyName(bkvs[i]) => string keyName; + bkvs[i+1] @=> bmap[keyName]; + } + + + for( 0 => int i; i < akvs.size(); 2 +=> i ) + { + akvs[i] @=> MalObject key; + akvs[i+1] @=> MalObject value; + Util.keyName(key) => string keyName; + + if( bmap[keyName] == null || + call([value, bmap[keyName]]).type != "true" ) + { + return Constants.FALSE; + } + } + + return Constants.TRUE; + } + + if( a.type != b.type ) + { + return Constants.FALSE; + } + + // NOTE: normally I'd go for a type variable, but its scope + // isn't handled properly in the presence of a member variable + a.type => string kind; + if( kind == "true" || kind == "false" || kind == "nil" ) + { + return Constants.TRUE; + } + else if( kind == "int" ) + { + if( (a$MalInt).value() == (b$MalInt).value() ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } + else if( kind == "string" ) + { + if( (a$MalString).value() == (b$MalString).value() ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } + else if( kind == "symbol" ) + { + if( (a$MalSymbol).value() == (b$MalSymbol).value() ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } + else if( kind == "keyword" ) + { + if( (a$MalKeyword).value() == (b$MalKeyword).value() ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } + + // HACK: return false for everything unknown for now + return Constants.FALSE; + } +} diff --git a/impls/chuck/types/subr/MalFirst.ck b/impls/chuck/types/subr/MalFirst.ck index 1958d68331..df6ed3d393 100644 --- a/impls/chuck/types/subr/MalFirst.ck +++ b/impls/chuck/types/subr/MalFirst.ck @@ -1,23 +1,23 @@ -public class MalFirst extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "nil" ) - { - return Constants.NIL; - } - - Util.sequenceToMalObjectArray(arg) @=> MalObject list[]; - - if( list.size() > 0 ) - { - return list[0]; - } - else - { - return Constants.NIL; - } - } -} +public class MalFirst extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "nil" ) + { + return Constants.NIL; + } + + Util.sequenceToMalObjectArray(arg) @=> MalObject list[]; + + if( list.size() > 0 ) + { + return list[0]; + } + else + { + return Constants.NIL; + } + } +} diff --git a/impls/chuck/types/subr/MalGet.ck b/impls/chuck/types/subr/MalGet.ck index 67aa0a88fb..06e36059b9 100644 --- a/impls/chuck/types/subr/MalGet.ck +++ b/impls/chuck/types/subr/MalGet.ck @@ -1,41 +1,41 @@ -public class MalGet extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - if( args[0].type == "nil" ) - { - return Constants.NIL; - } - - (args[0]$MalHashMap).value() @=> MalObject map[]; - Util.keyName(args[1]) => string keyName; - - MalObject mapKey; - MalObject mapValue; - false => int isKeyPresent; - 0 => int i; - - while( !isKeyPresent && i < map.size() ) - { - map[i] @=> mapKey; - map[i+1] @=> mapValue; - Util.keyName(mapKey) => string mapKeyName; - - if( keyName == mapKeyName ) - { - true => isKeyPresent; - } - - 2 +=> i; - } - - if( isKeyPresent ) - { - return mapValue; - } - else - { - return Constants.NIL; - } - } -} +public class MalGet extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "nil" ) + { + return Constants.NIL; + } + + (args[0]$MalHashMap).value() @=> MalObject map[]; + Util.keyName(args[1]) => string keyName; + + MalObject mapKey; + MalObject mapValue; + false => int isKeyPresent; + 0 => int i; + + while( !isKeyPresent && i < map.size() ) + { + map[i] @=> mapKey; + map[i+1] @=> mapValue; + Util.keyName(mapKey) => string mapKeyName; + + if( keyName == mapKeyName ) + { + true => isKeyPresent; + } + + 2 +=> i; + } + + if( isKeyPresent ) + { + return mapValue; + } + else + { + return Constants.NIL; + } + } +} diff --git a/impls/chuck/types/subr/MalGreater.ck b/impls/chuck/types/subr/MalGreater.ck index 31a43b0eb5..8115d6421e 100644 --- a/impls/chuck/types/subr/MalGreater.ck +++ b/impls/chuck/types/subr/MalGreater.ck @@ -1,17 +1,17 @@ -public class MalGreater extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalInt @=> MalInt a; - args[1]$MalInt @=> MalInt b; - - if( a.value() > b.value() ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalGreater extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalInt @=> MalInt a; + args[1]$MalInt @=> MalInt b; + + if( a.value() > b.value() ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalGreaterEqual.ck b/impls/chuck/types/subr/MalGreaterEqual.ck index 27df8a9ab4..4b08111a93 100644 --- a/impls/chuck/types/subr/MalGreaterEqual.ck +++ b/impls/chuck/types/subr/MalGreaterEqual.ck @@ -1,17 +1,17 @@ -public class MalGreaterEqual extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalInt @=> MalInt a; - args[1]$MalInt @=> MalInt b; - - if( a.value() >= b.value() ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalGreaterEqual extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalInt @=> MalInt a; + args[1]$MalInt @=> MalInt b; + + if( a.value() >= b.value() ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalHashMapify.ck b/impls/chuck/types/subr/MalHashMapify.ck index 0c4b4adc7e..81cb1e2d25 100644 --- a/impls/chuck/types/subr/MalHashMapify.ck +++ b/impls/chuck/types/subr/MalHashMapify.ck @@ -1,7 +1,7 @@ -public class MalHashMapify extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - return MalHashMap.create(args); - } -} +public class MalHashMapify extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + return MalHashMap.create(args); + } +} diff --git a/impls/chuck/types/subr/MalIsAtom.ck b/impls/chuck/types/subr/MalIsAtom.ck index 3377edb782..d27140bb69 100644 --- a/impls/chuck/types/subr/MalIsAtom.ck +++ b/impls/chuck/types/subr/MalIsAtom.ck @@ -1,14 +1,14 @@ -public class MalIsAtom extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - if( args[0].type == "atom" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsAtom extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "atom" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsContains.ck b/impls/chuck/types/subr/MalIsContains.ck index ed0e852a3a..d063d213bd 100644 --- a/impls/chuck/types/subr/MalIsContains.ck +++ b/impls/chuck/types/subr/MalIsContains.ck @@ -1,35 +1,35 @@ -public class MalIsContains extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalHashMap).value() @=> MalObject map[]; - Util.keyName(args[1]) => string keyName; - - MalObject mapKey; - MalObject mapValue; - false => int isKeyPresent; - 0 => int i; - - while( !isKeyPresent && i < map.size() ) - { - map[i] @=> mapKey; - Util.keyName(mapKey) => string mapKeyName; - - if( keyName == mapKeyName ) - { - true => isKeyPresent; - } - - 2 +=> i; - } - - if( isKeyPresent ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsContains extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalHashMap).value() @=> MalObject map[]; + Util.keyName(args[1]) => string keyName; + + MalObject mapKey; + MalObject mapValue; + false => int isKeyPresent; + 0 => int i; + + while( !isKeyPresent && i < map.size() ) + { + map[i] @=> mapKey; + Util.keyName(mapKey) => string mapKeyName; + + if( keyName == mapKeyName ) + { + true => isKeyPresent; + } + + 2 +=> i; + } + + if( isKeyPresent ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsEmpty.ck b/impls/chuck/types/subr/MalIsEmpty.ck index 0e5ba43a97..f2c8946dac 100644 --- a/impls/chuck/types/subr/MalIsEmpty.ck +++ b/impls/chuck/types/subr/MalIsEmpty.ck @@ -1,15 +1,15 @@ -public class MalIsEmpty extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalList).value() @=> MalObject values[]; - if( values.size() == 0 ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsEmpty extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalList).value() @=> MalObject values[]; + if( values.size() == 0 ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsFalse.ck b/impls/chuck/types/subr/MalIsFalse.ck index b4866d1d21..b0480fe7b3 100644 --- a/impls/chuck/types/subr/MalIsFalse.ck +++ b/impls/chuck/types/subr/MalIsFalse.ck @@ -1,16 +1,16 @@ -public class MalIsFalse extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "false" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsFalse extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "false" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsFn.ck b/impls/chuck/types/subr/MalIsFn.ck index a3df6131f7..7bfc027778 100644 --- a/impls/chuck/types/subr/MalIsFn.ck +++ b/impls/chuck/types/subr/MalIsFn.ck @@ -1,15 +1,15 @@ -public class MalIsFn extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - if( args[0].type == "subr" || ( args[0].type == "func" && - !(args[0]$Func).isMacro ) ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsFn extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "subr" || ( args[0].type == "func" && + !(args[0]$Func).isMacro ) ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsHashMap.ck b/impls/chuck/types/subr/MalIsHashMap.ck index 00dfe7e7df..74f7f5fb49 100644 --- a/impls/chuck/types/subr/MalIsHashMap.ck +++ b/impls/chuck/types/subr/MalIsHashMap.ck @@ -1,16 +1,16 @@ -public class MalIsHashMap extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "hashmap" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsHashMap extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "hashmap" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsKeyword.ck b/impls/chuck/types/subr/MalIsKeyword.ck index 4e76dc4de8..50267fb3b3 100644 --- a/impls/chuck/types/subr/MalIsKeyword.ck +++ b/impls/chuck/types/subr/MalIsKeyword.ck @@ -1,16 +1,16 @@ -public class MalIsKeyword extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "keyword" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsKeyword extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "keyword" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsList.ck b/impls/chuck/types/subr/MalIsList.ck index 63dd165c22..818bc1e374 100644 --- a/impls/chuck/types/subr/MalIsList.ck +++ b/impls/chuck/types/subr/MalIsList.ck @@ -1,14 +1,14 @@ -public class MalIsList extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - if( args[0].type == "list" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsList extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "list" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsMacro.ck b/impls/chuck/types/subr/MalIsMacro.ck index 1ed2fc73a2..98fde80c7f 100644 --- a/impls/chuck/types/subr/MalIsMacro.ck +++ b/impls/chuck/types/subr/MalIsMacro.ck @@ -1,14 +1,14 @@ -public class MalIsMacro extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - if( args[0].type == "func" && (args[0]$Func).isMacro ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsMacro extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "func" && (args[0]$Func).isMacro ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsNil.ck b/impls/chuck/types/subr/MalIsNil.ck index 32940d3b3b..dbae6579b7 100644 --- a/impls/chuck/types/subr/MalIsNil.ck +++ b/impls/chuck/types/subr/MalIsNil.ck @@ -1,16 +1,16 @@ -public class MalIsNil extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "nil" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsNil extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "nil" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsNumber.ck b/impls/chuck/types/subr/MalIsNumber.ck index 09231ceff8..035c26041d 100644 --- a/impls/chuck/types/subr/MalIsNumber.ck +++ b/impls/chuck/types/subr/MalIsNumber.ck @@ -1,14 +1,14 @@ -public class MalIsNumber extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - if( args[0].type == "int" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsNumber extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "int" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsString.ck b/impls/chuck/types/subr/MalIsString.ck index d85d58c3ce..2123d1cf00 100644 --- a/impls/chuck/types/subr/MalIsString.ck +++ b/impls/chuck/types/subr/MalIsString.ck @@ -1,14 +1,14 @@ -public class MalIsString extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - if( args[0].type == "string" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsString extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if( args[0].type == "string" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsSymbol.ck b/impls/chuck/types/subr/MalIsSymbol.ck index 3ebb65698c..30ece9a5f0 100644 --- a/impls/chuck/types/subr/MalIsSymbol.ck +++ b/impls/chuck/types/subr/MalIsSymbol.ck @@ -1,16 +1,16 @@ -public class MalIsSymbol extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "symbol" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsSymbol extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "symbol" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsTrue.ck b/impls/chuck/types/subr/MalIsTrue.ck index 913e4b61b9..b555a4e911 100644 --- a/impls/chuck/types/subr/MalIsTrue.ck +++ b/impls/chuck/types/subr/MalIsTrue.ck @@ -1,16 +1,16 @@ -public class MalIsTrue extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "true" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsTrue extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "true" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalIsVector.ck b/impls/chuck/types/subr/MalIsVector.ck index e74ffc08ea..3bd6a08d93 100644 --- a/impls/chuck/types/subr/MalIsVector.ck +++ b/impls/chuck/types/subr/MalIsVector.ck @@ -1,16 +1,16 @@ -public class MalIsVector extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "vector" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalIsVector extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "vector" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalKeys.ck b/impls/chuck/types/subr/MalKeys.ck index e5ee6776fa..0c7319a924 100644 --- a/impls/chuck/types/subr/MalKeys.ck +++ b/impls/chuck/types/subr/MalKeys.ck @@ -1,15 +1,15 @@ -public class MalKeys extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalHashMap).value() @=> MalObject map[]; - MalObject results[0]; - - for( 0 => int i; i < map.size(); 2 +=> i ) - { - results << map[i]; - } - - return MalList.create(results); - } -} +public class MalKeys extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalHashMap).value() @=> MalObject map[]; + MalObject results[0]; + + for( 0 => int i; i < map.size(); 2 +=> i ) + { + results << map[i]; + } + + return MalList.create(results); + } +} diff --git a/impls/chuck/types/subr/MalKeywordify.ck b/impls/chuck/types/subr/MalKeywordify.ck index bc70e5340d..5020663053 100644 --- a/impls/chuck/types/subr/MalKeywordify.ck +++ b/impls/chuck/types/subr/MalKeywordify.ck @@ -1,8 +1,8 @@ -public class MalKeywordify extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalString).value() => string name; - return MalKeyword.create(name); - } -} +public class MalKeywordify extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalString).value() => string name; + return MalKeyword.create(name); + } +} diff --git a/impls/chuck/types/subr/MalLess.ck b/impls/chuck/types/subr/MalLess.ck index 076bcee892..2af8e839d3 100644 --- a/impls/chuck/types/subr/MalLess.ck +++ b/impls/chuck/types/subr/MalLess.ck @@ -1,17 +1,17 @@ -public class MalLess extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalInt @=> MalInt a; - args[1]$MalInt @=> MalInt b; - - if( a.value() < b.value() ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalLess extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalInt @=> MalInt a; + args[1]$MalInt @=> MalInt b; + + if( a.value() < b.value() ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalLessEqual.ck b/impls/chuck/types/subr/MalLessEqual.ck index b3aad19996..013608c709 100644 --- a/impls/chuck/types/subr/MalLessEqual.ck +++ b/impls/chuck/types/subr/MalLessEqual.ck @@ -1,17 +1,17 @@ -public class MalLessEqual extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalInt @=> MalInt a; - args[1]$MalInt @=> MalInt b; - - if( a.value() <= b.value() ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalLessEqual extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalInt @=> MalInt a; + args[1]$MalInt @=> MalInt b; + + if( a.value() <= b.value() ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalListify.ck b/impls/chuck/types/subr/MalListify.ck index 81a5cde1eb..64b561a917 100644 --- a/impls/chuck/types/subr/MalListify.ck +++ b/impls/chuck/types/subr/MalListify.ck @@ -1,7 +1,7 @@ -public class MalListify extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - return MalList.create(args); - } -} +public class MalListify extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + return MalList.create(args); + } +} diff --git a/impls/chuck/types/subr/MalMap.ck b/impls/chuck/types/subr/MalMap.ck index f25f686797..0e13dff2c5 100644 --- a/impls/chuck/types/subr/MalMap.ck +++ b/impls/chuck/types/subr/MalMap.ck @@ -1,22 +1,22 @@ -public class MalMap extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject f; - Util.sequenceToMalObjectArray(args[1]) @=> MalObject list[]; - - for( 0 => int i; i < list.size(); i++ ) - { - (eval$MalSubr).apply(f, [list[i]]) @=> MalObject value; - - if( value.type == "error" ) - { - return value; - } - - value @=> list[i]; - } - - return MalList.create(list); - } -} +public class MalMap extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject f; + Util.sequenceToMalObjectArray(args[1]) @=> MalObject list[]; + + for( 0 => int i; i < list.size(); i++ ) + { + (eval$MalSubr).apply(f, [list[i]]) @=> MalObject value; + + if( value.type == "error" ) + { + return value; + } + + value @=> list[i]; + } + + return MalList.create(list); + } +} diff --git a/impls/chuck/types/subr/MalMeta.ck b/impls/chuck/types/subr/MalMeta.ck index 05689629d2..4e9891175a 100644 --- a/impls/chuck/types/subr/MalMeta.ck +++ b/impls/chuck/types/subr/MalMeta.ck @@ -1,16 +1,16 @@ -public class MalMeta extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.meta == null ) - { - return Constants.NIL; - } - else - { - return (arg.meta)$MalObject; - } - } -} +public class MalMeta extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.meta == null ) + { + return Constants.NIL; + } + else + { + return (arg.meta)$MalObject; + } + } +} diff --git a/impls/chuck/types/subr/MalMul.ck b/impls/chuck/types/subr/MalMul.ck index 42a3d86234..5e384eb4dd 100644 --- a/impls/chuck/types/subr/MalMul.ck +++ b/impls/chuck/types/subr/MalMul.ck @@ -1,10 +1,10 @@ -public class MalMul extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalInt @=> MalInt a; - args[1]$MalInt @=> MalInt b; - - return MalInt.create(a.value() * b.value()); - } -} +public class MalMul extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalInt @=> MalInt a; + args[1]$MalInt @=> MalInt b; + + return MalInt.create(a.value() * b.value()); + } +} diff --git a/impls/chuck/types/subr/MalNth.ck b/impls/chuck/types/subr/MalNth.ck index f013875eca..106f4b87b9 100644 --- a/impls/chuck/types/subr/MalNth.ck +++ b/impls/chuck/types/subr/MalNth.ck @@ -1,17 +1,17 @@ -public class MalNth extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - Util.sequenceToMalObjectArray(args[0]) @=> MalObject list[]; - (args[1]$MalInt).value() @=> int n; - - if( n < list.size() ) - { - return list[n]; - } - else - { - return MalError.create(MalString.create("out of bounds")); - } - } -} +public class MalNth extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + Util.sequenceToMalObjectArray(args[0]) @=> MalObject list[]; + (args[1]$MalInt).value() @=> int n; + + if( n < list.size() ) + { + return list[n]; + } + else + { + return MalError.create(MalString.create("out of bounds")); + } + } +} diff --git a/impls/chuck/types/subr/MalPrStr.ck b/impls/chuck/types/subr/MalPrStr.ck index 22376c28a4..44edfaa399 100644 --- a/impls/chuck/types/subr/MalPrStr.ck +++ b/impls/chuck/types/subr/MalPrStr.ck @@ -1,14 +1,14 @@ -public class MalPrStr extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - string values[args.size()]; - - for( 0 => int i; i < values.size(); i++ ) - { - Printer.pr_str(args[i], true) => values[i]; - } - - return MalString.create(String.join(values, " ")); - } -} +public class MalPrStr extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + string values[args.size()]; + + for( 0 => int i; i < values.size(); i++ ) + { + Printer.pr_str(args[i], true) => values[i]; + } + + return MalString.create(String.join(values, " ")); + } +} diff --git a/impls/chuck/types/subr/MalPrintln.ck b/impls/chuck/types/subr/MalPrintln.ck index 30d56a15f1..92136fb17a 100644 --- a/impls/chuck/types/subr/MalPrintln.ck +++ b/impls/chuck/types/subr/MalPrintln.ck @@ -1,15 +1,15 @@ -public class MalPrintln extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - string values[args.size()]; - - for( 0 => int i; i < values.size(); i++ ) - { - Printer.pr_str(args[i], false) => values[i]; - } - - Util.println(String.join(values, " ")); - return Constants.NIL; - } -} +public class MalPrintln extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + string values[args.size()]; + + for( 0 => int i; i < values.size(); i++ ) + { + Printer.pr_str(args[i], false) => values[i]; + } + + Util.println(String.join(values, " ")); + return Constants.NIL; + } +} diff --git a/impls/chuck/types/subr/MalPrn.ck b/impls/chuck/types/subr/MalPrn.ck index f2137fcb22..02f974f851 100644 --- a/impls/chuck/types/subr/MalPrn.ck +++ b/impls/chuck/types/subr/MalPrn.ck @@ -1,15 +1,15 @@ -public class MalPrn extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - string values[args.size()]; - - for( 0 => int i; i < values.size(); i++ ) - { - Printer.pr_str(args[i], true) => values[i]; - } - - Util.println(String.join(values, " ")); - return Constants.NIL; - } -} +public class MalPrn extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + string values[args.size()]; + + for( 0 => int i; i < values.size(); i++ ) + { + Printer.pr_str(args[i], true) => values[i]; + } + + Util.println(String.join(values, " ")); + return Constants.NIL; + } +} diff --git a/impls/chuck/types/subr/MalReadStr.ck b/impls/chuck/types/subr/MalReadStr.ck index 6d3fa71f84..c5f4e6be75 100644 --- a/impls/chuck/types/subr/MalReadStr.ck +++ b/impls/chuck/types/subr/MalReadStr.ck @@ -1,8 +1,8 @@ -public class MalReadStr extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalString).value() => string input; - return Reader.read_str(input); - } -} +public class MalReadStr extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalString).value() => string input; + return Reader.read_str(input); + } +} diff --git a/impls/chuck/types/subr/MalReadline.ck b/impls/chuck/types/subr/MalReadline.ck index 2e817ac4da..3ecb40c21a 100644 --- a/impls/chuck/types/subr/MalReadline.ck +++ b/impls/chuck/types/subr/MalReadline.ck @@ -1,17 +1,17 @@ -public class MalReadline extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalString).value() => string prompt; - Readline.readline(prompt) => string input; - - if( input == null ) - { - return Constants.NIL; - } - else - { - return MalString.create(input); - } - } -} +public class MalReadline extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalString).value() => string prompt; + Readline.readline(prompt) => string input; + + if( input == null ) + { + return Constants.NIL; + } + else + { + return MalString.create(input); + } + } +} diff --git a/impls/chuck/types/subr/MalRest.ck b/impls/chuck/types/subr/MalRest.ck index 0c51fd4cbd..0b26a481be 100644 --- a/impls/chuck/types/subr/MalRest.ck +++ b/impls/chuck/types/subr/MalRest.ck @@ -1,22 +1,22 @@ -public class MalRest extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - MalObject result[0]; - - if( arg.type == "nil" ) - { - return MalList.create(result); - } - - Util.sequenceToMalObjectArray(args[0]) @=> MalObject list[]; - - if( list.size() > 0 ) - { - MalObject.slice(list, 1) @=> result; - } - - return MalList.create(result); - } -} +public class MalRest extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + MalObject result[0]; + + if( arg.type == "nil" ) + { + return MalList.create(result); + } + + Util.sequenceToMalObjectArray(args[0]) @=> MalObject list[]; + + if( list.size() > 0 ) + { + MalObject.slice(list, 1) @=> result; + } + + return MalList.create(result); + } +} diff --git a/impls/chuck/types/subr/MalSeq.ck b/impls/chuck/types/subr/MalSeq.ck index 37748c944c..ec24fae766 100644 --- a/impls/chuck/types/subr/MalSeq.ck +++ b/impls/chuck/types/subr/MalSeq.ck @@ -1,45 +1,45 @@ -public class MalSeq extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "nil" ) - { - return Constants.NIL; - } - else if( arg.type == "list" || arg.type == "vector" ) - { - Util.sequenceToMalObjectArray(args[0]) @=> MalObject list[]; - - if( list.size() > 0 ) - { - return MalList.create(list); - } - else - { - return Constants.NIL; - } - } - else if( arg.type == "string" ) - { - (args[0]$MalString).value() => string value; - - if( value.length() > 0 ) - { - MalObject chars[value.length()]; - - for( 0 => int i; i < value.length(); i++ ) - { - MalString.create(value.substring(i, 1)) @=> chars[i]; - } - - return MalList.create(chars); - } - else - { - return Constants.NIL; - } - } - } -} +public class MalSeq extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "nil" ) + { + return Constants.NIL; + } + else if( arg.type == "list" || arg.type == "vector" ) + { + Util.sequenceToMalObjectArray(args[0]) @=> MalObject list[]; + + if( list.size() > 0 ) + { + return MalList.create(list); + } + else + { + return Constants.NIL; + } + } + else if( arg.type == "string" ) + { + (args[0]$MalString).value() => string value; + + if( value.length() > 0 ) + { + MalObject chars[value.length()]; + + for( 0 => int i; i < value.length(); i++ ) + { + MalString.create(value.substring(i, 1)) @=> chars[i]; + } + + return MalList.create(chars); + } + else + { + return Constants.NIL; + } + } + } +} diff --git a/impls/chuck/types/subr/MalSequential.ck b/impls/chuck/types/subr/MalSequential.ck index 7587499841..ea16bd4fe0 100644 --- a/impls/chuck/types/subr/MalSequential.ck +++ b/impls/chuck/types/subr/MalSequential.ck @@ -1,16 +1,16 @@ -public class MalSequential extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - - if( arg.type == "list" || arg.type == "vector" ) - { - return Constants.TRUE; - } - else - { - return Constants.FALSE; - } - } -} +public class MalSequential extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + + if( arg.type == "list" || arg.type == "vector" ) + { + return Constants.TRUE; + } + else + { + return Constants.FALSE; + } + } +} diff --git a/impls/chuck/types/subr/MalSlurp.ck b/impls/chuck/types/subr/MalSlurp.ck index 228fe2912e..0b0cdd8249 100644 --- a/impls/chuck/types/subr/MalSlurp.ck +++ b/impls/chuck/types/subr/MalSlurp.ck @@ -1,20 +1,20 @@ -public class MalSlurp extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalString).value() => string filename; - FileIO f; - string output[0]; - - f.open(filename, FileIO.READ); - - while( f.more() ) - { - output << f.readLine(); - } - - f.close(); - - return MalString.create(String.join(output, "\n")); - } -} +public class MalSlurp extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalString).value() => string filename; + FileIO f; + string output[0]; + + f.open(filename, FileIO.READ); + + while( f.more() ) + { + output << f.readLine(); + } + + f.close(); + + return MalString.create(String.join(output, "\n")); + } +} diff --git a/impls/chuck/types/subr/MalStr.ck b/impls/chuck/types/subr/MalStr.ck index c6477dd254..b260d6bfa2 100644 --- a/impls/chuck/types/subr/MalStr.ck +++ b/impls/chuck/types/subr/MalStr.ck @@ -1,14 +1,14 @@ -public class MalStr extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - string values[args.size()]; - - for( 0 => int i; i < values.size(); i++ ) - { - Printer.pr_str(args[i], false) => values[i]; - } - - return MalString.create(String.join(values, "")); - } -} +public class MalStr extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + string values[args.size()]; + + for( 0 => int i; i < values.size(); i++ ) + { + Printer.pr_str(args[i], false) => values[i]; + } + + return MalString.create(String.join(values, "")); + } +} diff --git a/impls/chuck/types/subr/MalSub.ck b/impls/chuck/types/subr/MalSub.ck index e0045a09c9..606ca91a37 100644 --- a/impls/chuck/types/subr/MalSub.ck +++ b/impls/chuck/types/subr/MalSub.ck @@ -1,10 +1,10 @@ -public class MalSub extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0]$MalInt @=> MalInt a; - args[1]$MalInt @=> MalInt b; - - return MalInt.create(a.value() - b.value()); - } -} +public class MalSub extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0]$MalInt @=> MalInt a; + args[1]$MalInt @=> MalInt b; + + return MalInt.create(a.value() - b.value()); + } +} diff --git a/impls/chuck/types/subr/MalSymbolify.ck b/impls/chuck/types/subr/MalSymbolify.ck index f61ea250cd..616a532b55 100644 --- a/impls/chuck/types/subr/MalSymbolify.ck +++ b/impls/chuck/types/subr/MalSymbolify.ck @@ -1,8 +1,8 @@ -public class MalSymbolify extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalString).value() => string name; - return MalSymbol.create(name); - } -} +public class MalSymbolify extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalString).value() => string name; + return MalSymbol.create(name); + } +} diff --git a/impls/chuck/types/subr/MalThrow.ck b/impls/chuck/types/subr/MalThrow.ck index 3d1dcee147..1b81eb3964 100644 --- a/impls/chuck/types/subr/MalThrow.ck +++ b/impls/chuck/types/subr/MalThrow.ck @@ -1,7 +1,7 @@ -public class MalThrow extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - return MalError.create(args[0]); - } -} +public class MalThrow extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + return MalError.create(args[0]); + } +} diff --git a/impls/chuck/types/subr/MalTimeMs.ck b/impls/chuck/types/subr/MalTimeMs.ck index 3a2b91afc1..b9e2fe56f5 100644 --- a/impls/chuck/types/subr/MalTimeMs.ck +++ b/impls/chuck/types/subr/MalTimeMs.ck @@ -1,18 +1,18 @@ -public class MalTimeMs extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - // HACK: Std.system returns the status code only... - "/tmp/chuck-date." + Std.rand2(1000,9999) => string temp_file; - Std.system("date +%s%3N > " + temp_file); - - FileIO f; - f.open(temp_file, FileIO.READ); - f => int timestamp; - f.close(); - - Std.system("rm " + temp_file); - - return MalInt.create(timestamp); - } -} +public class MalTimeMs extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + // HACK: Std.system returns the status code only... + "/tmp/chuck-date." + Std.rand2(1000,9999) => string temp_file; + Std.system("date +%s%3N > " + temp_file); + + FileIO f; + f.open(temp_file, FileIO.READ); + f => int timestamp; + f.close(); + + Std.system("rm " + temp_file); + + return MalInt.create(timestamp); + } +} diff --git a/impls/chuck/types/subr/MalVals.ck b/impls/chuck/types/subr/MalVals.ck index ca5d35cb05..69fbca923b 100644 --- a/impls/chuck/types/subr/MalVals.ck +++ b/impls/chuck/types/subr/MalVals.ck @@ -1,15 +1,15 @@ -public class MalVals extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - (args[0]$MalHashMap).value() @=> MalObject map[]; - MalObject results[0]; - - for( 1 => int i; i < map.size(); 2 +=> i ) - { - results << map[i]; - } - - return MalList.create(results); - } -} +public class MalVals extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + (args[0]$MalHashMap).value() @=> MalObject map[]; + MalObject results[0]; + + for( 1 => int i; i < map.size(); 2 +=> i ) + { + results << map[i]; + } + + return MalList.create(results); + } +} diff --git a/impls/chuck/types/subr/MalVec.ck b/impls/chuck/types/subr/MalVec.ck index 0a53564330..9a5f013ce6 100644 --- a/impls/chuck/types/subr/MalVec.ck +++ b/impls/chuck/types/subr/MalVec.ck @@ -1,15 +1,15 @@ -public class MalVec extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - if (args.size() == 1) { - args[0] @=> MalObject a0; - if (a0.type == "vector") { - return a0; - } else if (a0.type == "list") { - return MalVector.create((a0$MalList).value()); - } - } - return MalError.create(MalString.create("vec: wrong arguments")); - } -} +public class MalVec extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + if (args.size() == 1) { + args[0] @=> MalObject a0; + if (a0.type == "vector") { + return a0; + } else if (a0.type == "list") { + return MalVector.create((a0$MalList).value()); + } + } + return MalError.create(MalString.create("vec: wrong arguments")); + } +} diff --git a/impls/chuck/types/subr/MalVectorify.ck b/impls/chuck/types/subr/MalVectorify.ck index 97c8439d33..36b62a9eaf 100644 --- a/impls/chuck/types/subr/MalVectorify.ck +++ b/impls/chuck/types/subr/MalVectorify.ck @@ -1,7 +1,7 @@ -public class MalVectorify extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - return MalVector.create(args); - } -} +public class MalVectorify extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + return MalVector.create(args); + } +} diff --git a/impls/chuck/types/subr/MalWithMeta.ck b/impls/chuck/types/subr/MalWithMeta.ck index 7e8fba1cec..af1c8eb530 100644 --- a/impls/chuck/types/subr/MalWithMeta.ck +++ b/impls/chuck/types/subr/MalWithMeta.ck @@ -1,15 +1,15 @@ -public class MalWithMeta extends MalSubr -{ - fun MalObject call(MalObject args[]) - { - args[0] @=> MalObject arg; - args[1] @=> MalObject meta; - - MalObject value; - arg.clone() @=> value; - - meta$Object @=> value.meta; - - return value; - } -} +public class MalWithMeta extends MalSubr +{ + fun MalObject call(MalObject args[]) + { + args[0] @=> MalObject arg; + args[1] @=> MalObject meta; + + MalObject value; + arg.clone() @=> value; + + meta$Object @=> value.meta; + + return value; + } +} diff --git a/impls/chuck/util/Constants.ck b/impls/chuck/util/Constants.ck index 9e89854d44..5e839c798b 100644 --- a/impls/chuck/util/Constants.ck +++ b/impls/chuck/util/Constants.ck @@ -1,10 +1,10 @@ -public class Constants -{ - static MalTrue @ TRUE; - static MalFalse @ FALSE; - static MalNil @ NIL; -} - -MalTrue.create() @=> Constants.TRUE; -MalFalse.create() @=> Constants.FALSE; -MalNil.create() @=> Constants.NIL; +public class Constants +{ + static MalTrue @ TRUE; + static MalFalse @ FALSE; + static MalNil @ NIL; +} + +MalTrue.create() @=> Constants.TRUE; +MalFalse.create() @=> Constants.FALSE; +MalNil.create() @=> Constants.NIL; diff --git a/impls/chuck/util/Util.ck b/impls/chuck/util/Util.ck index 46892e85c2..3822b81ae2 100644 --- a/impls/chuck/util/Util.ck +++ b/impls/chuck/util/Util.ck @@ -1,31 +1,31 @@ -public class Util -{ - fun static MalObject[] sequenceToMalObjectArray(MalObject m) - { - if( m.type == "list" ) - { - return (m$MalList).value(); - } - else if( m.type == "vector" ) - { - return (m$MalVector).value(); - } - } - - fun static string keyName(MalObject m) - { - if( m.type == "string" ) - { - return (m$MalString).value(); - } - else if (m.type == "keyword" ) - { - return (m$MalKeyword).value(); - } - } - - fun static void println(string message) - { - chout <= message + "\n"; - } -} +public class Util +{ + fun static MalObject[] sequenceToMalObjectArray(MalObject m) + { + if( m.type == "list" ) + { + return (m$MalList).value(); + } + else if( m.type == "vector" ) + { + return (m$MalVector).value(); + } + } + + fun static string keyName(MalObject m) + { + if( m.type == "string" ) + { + return (m$MalString).value(); + } + else if (m.type == "keyword" ) + { + return (m$MalKeyword).value(); + } + } + + fun static void println(string message) + { + chout <= message + "\n"; + } +} diff --git a/impls/clojure/Dockerfile b/impls/clojure/Dockerfile index 2d1dea49a3..33b45cfd6e 100644 --- a/impls/clojure/Dockerfile +++ b/impls/clojure/Dockerfile @@ -1,56 +1,56 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# -# Clojure (Java and lein) -# - -RUN apt-get -y install openjdk-8-jdk - -ADD https://raw.githubusercontent.com/technomancy/leiningen/stable/bin/lein \ - /usr/local/bin/lein -RUN chmod 0755 /usr/local/bin/lein -ENV LEIN_HOME /mal/.lein -ENV LEIN_JVM_OPTS -Duser.home=/mal - -# -# ClojureScript (Node and Lumo) -# - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm - -## Install ffi and lumo-cljs modules globally -#RUN npm install -g ffi lumo-cljs - -ENV HOME=/mal - +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# +# Clojure (Java and lein) +# + +RUN apt-get -y install openjdk-8-jdk + +ADD https://raw.githubusercontent.com/technomancy/leiningen/stable/bin/lein \ + /usr/local/bin/lein +RUN chmod 0755 /usr/local/bin/lein +ENV LEIN_HOME /mal/.lein +ENV LEIN_JVM_OPTS -Duser.home=/mal + +# +# ClojureScript (Node and Lumo) +# + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm + +## Install ffi and lumo-cljs modules globally +#RUN npm install -g ffi lumo-cljs + +ENV HOME=/mal + diff --git a/impls/clojure/Makefile b/impls/clojure/Makefile index 120dd20b65..bbbaa280a6 100644 --- a/impls/clojure/Makefile +++ b/impls/clojure/Makefile @@ -1,36 +1,36 @@ -clojure_MODE ?= clj -SOURCES_UTIL = src/mal/readline.$(clojure_MODE) -SOURCES_BASE = $(SOURCES_UTIL) src/mal/reader.cljc src/mal/printer.cljc -SOURCES_LISP = src/mal/env.cljc src/mal/core.cljc src/mal/stepA_mal.cljc -SRCS = $(SOURCES_BASE) src/mal/env.cljc src/mal/core.cljc -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -DEPS = $(if $(filter cljs,$(clojure_MODE)),node_modules,deps) - -dist: $(if $(filter cljs,$(clojure_MODE)),node_modules,mal.jar mal) - -deps: - lein deps - -mal.jar: $(SOURCES) - lein with-profile stepA uberjar - cp target/stepA_mal.jar $@ - -SHELL := bash -mal: mal.jar - cat <(echo -e '#!/bin/sh\nexec java -jar "$$0" "$$@"') mal.jar > $@ - chmod +x mal - -src/mal/%.cljc: $(DEPS) - @true - -#src/mal/stepA_mal.cljc: $(DEPS) - -target/%.jar: src/mal/%.cljc $(SRCS) - lein with-profile $(word 1,$(subst _, ,$*)) uberjar - -node_modules: - npm install - -clean: - rm -rf target/ mal.jar mal +clojure_MODE ?= clj +SOURCES_UTIL = src/mal/readline.$(clojure_MODE) +SOURCES_BASE = $(SOURCES_UTIL) src/mal/reader.cljc src/mal/printer.cljc +SOURCES_LISP = src/mal/env.cljc src/mal/core.cljc src/mal/stepA_mal.cljc +SRCS = $(SOURCES_BASE) src/mal/env.cljc src/mal/core.cljc +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +DEPS = $(if $(filter cljs,$(clojure_MODE)),node_modules,deps) + +dist: $(if $(filter cljs,$(clojure_MODE)),node_modules,mal.jar mal) + +deps: + lein deps + +mal.jar: $(SOURCES) + lein with-profile stepA uberjar + cp target/stepA_mal.jar $@ + +SHELL := bash +mal: mal.jar + cat <(echo -e '#!/bin/sh\nexec java -jar "$$0" "$$@"') mal.jar > $@ + chmod +x mal + +src/mal/%.cljc: $(DEPS) + @true + +#src/mal/stepA_mal.cljc: $(DEPS) + +target/%.jar: src/mal/%.cljc $(SRCS) + lein with-profile $(word 1,$(subst _, ,$*)) uberjar + +node_modules: + npm install + +clean: + rm -rf target/ mal.jar mal diff --git a/impls/clojure/package.json b/impls/clojure/package.json index 79599be076..5d174fdd3a 100644 --- a/impls/clojure/package.json +++ b/impls/clojure/package.json @@ -1,9 +1,9 @@ -{ - "name": "mal", - "version": "0.0.1", - "description": "Make a Lisp (mal) language implemented in ClojureScript", - "dependencies": { - "ffi-napi": "2.4.x", - "lumo-cljs": "1.10.1" - } -} +{ + "name": "mal", + "version": "0.0.1", + "description": "Make a Lisp (mal) language implemented in ClojureScript", + "dependencies": { + "ffi-napi": "2.4.x", + "lumo-cljs": "1.10.1" + } +} diff --git a/impls/clojure/project.clj b/impls/clojure/project.clj index 8f5c61b5a8..52b49ee2c9 100644 --- a/impls/clojure/project.clj +++ b/impls/clojure/project.clj @@ -1,44 +1,44 @@ -(defproject mal "0.0.1-SNAPSHOT" - :description "Make-A-Lisp" - - :dependencies [[org.clojure/clojure "1.10.0"] - [net.n01se/clojure-jna "1.0.0"]] - - ;; To run a step with correct readline behavior: - ;; lein trampoline with-profile stepX run - ;; To generate a executable uberjar (in target/) for a step: - ;; lein with-profile stepX repl - :profiles {:step0 {:main mal.step0-repl - :uberjar-name "step0_repl.jar" - :aot [mal.step0-repl]} - :step1 {:main mal.step1-read-print - :uberjar-name "step1_read_print.jar" - :aot [mal.step1-read-print]} - :step2 {:main mal.step2-eval - :uberjar-name "step2_eval.jar" - :aot [mal.step2-eval]} - :step3 {:main mal.step3-env - :uberjar-name "step3_env.jar" - :aot [mal.step3-env]} - :step4 {:main mal.step4-if-fn-do - :uberjar-name "step4_if_fn_do.jar" - :aot [mal.step4-if-fn-do]} - :step5 {:main mal.step5-tco - :uberjar-name "step5_tco.jar" - :aot [mal.step5-tco]} - :step6 {:main mal.step6-file - :uberjar-name "step6_file.jar" - :aot [mal.step6-file]} - :step7 {:main mal.step7-quote - :uberjar-name "step7_quote.jar" - :aot [mal.step7-quote]} - :step8 {:main mal.step8-macros - :uberjar-name "step8_macros.jar" - :aot [mal.step8-macros]} - :step9 {:main mal.step9-try - :uberjar-name "step9_try.jar" - :aot [mal.step9-try]} - :stepA {:main mal.stepA-mal - :uberjar-name "stepA_mal.jar" - :aot [mal.stepA-mal]}}) - +(defproject mal "0.0.1-SNAPSHOT" + :description "Make-A-Lisp" + + :dependencies [[org.clojure/clojure "1.10.0"] + [net.n01se/clojure-jna "1.0.0"]] + + ;; To run a step with correct readline behavior: + ;; lein trampoline with-profile stepX run + ;; To generate a executable uberjar (in target/) for a step: + ;; lein with-profile stepX repl + :profiles {:step0 {:main mal.step0-repl + :uberjar-name "step0_repl.jar" + :aot [mal.step0-repl]} + :step1 {:main mal.step1-read-print + :uberjar-name "step1_read_print.jar" + :aot [mal.step1-read-print]} + :step2 {:main mal.step2-eval + :uberjar-name "step2_eval.jar" + :aot [mal.step2-eval]} + :step3 {:main mal.step3-env + :uberjar-name "step3_env.jar" + :aot [mal.step3-env]} + :step4 {:main mal.step4-if-fn-do + :uberjar-name "step4_if_fn_do.jar" + :aot [mal.step4-if-fn-do]} + :step5 {:main mal.step5-tco + :uberjar-name "step5_tco.jar" + :aot [mal.step5-tco]} + :step6 {:main mal.step6-file + :uberjar-name "step6_file.jar" + :aot [mal.step6-file]} + :step7 {:main mal.step7-quote + :uberjar-name "step7_quote.jar" + :aot [mal.step7-quote]} + :step8 {:main mal.step8-macros + :uberjar-name "step8_macros.jar" + :aot [mal.step8-macros]} + :step9 {:main mal.step9-try + :uberjar-name "step9_try.jar" + :aot [mal.step9-try]} + :stepA {:main mal.stepA-mal + :uberjar-name "stepA_mal.jar" + :aot [mal.stepA-mal]}}) + diff --git a/impls/clojure/run b/impls/clojure/run index f74eba6f25..503ea0c0f3 100755 --- a/impls/clojure/run +++ b/impls/clojure/run @@ -1,8 +1,8 @@ -#!/bin/bash -export PATH=$PATH:$(dirname $0)/node_modules/.bin -STEP=${STEP:-stepA_mal} -if [ "${clojure_MODE}" = "cljs" ]; then - exec lumo -c $(dirname $0)/src -m mal.${STEP//_/-} "${@}" -else - exec java -jar $(dirname $0)/target/${STEP}.jar "${@}" -fi +#!/bin/bash +export PATH=$PATH:$(dirname $0)/node_modules/.bin +STEP=${STEP:-stepA_mal} +if [ "${clojure_MODE}" = "cljs" ]; then + exec lumo -c $(dirname $0)/src -m mal.${STEP//_/-} "${@}" +else + exec java -jar $(dirname $0)/target/${STEP}.jar "${@}" +fi diff --git a/impls/clojure/src/mal/core.cljc b/impls/clojure/src/mal/core.cljc index e1df93261d..21f0a1ddbd 100644 --- a/impls/clojure/src/mal/core.cljc +++ b/impls/clojure/src/mal/core.cljc @@ -1,95 +1,95 @@ -(ns mal.core - (:refer-clojure :exclude [pr-str]) - (:require [clojure.string :refer [join]] - [mal.readline :as readline] - [mal.reader :as reader] - [mal.printer :refer [pr-str atom?]])) - -;; Errors/exceptions -(defn mal_throw [obj] - (throw (ex-info "mal exception" {:data obj}))) - -;; String functions -#?(:cljs (defn slurp [f] (.readFileSync (js/require "fs") f "utf-8"))) - -;; Numeric functions -#?(:clj (defn time-ms [] (System/currentTimeMillis)) - :cljs (defn time-ms [] (.getTime (js/Date.)))) - -;; Metadata functions -;; - store metadata at :meta key of the real metadata -(defn mal_with_meta [obj m] - (let [new-meta (assoc (meta obj) :meta m)] - (with-meta obj new-meta))) - -(defn mal_meta [obj] - (:meta (meta obj))) - -;; core_ns is core namespaces functions -(def core_ns - [['= =] - ['throw mal_throw] - ['nil? nil?] - ['true? true?] - ['false? false?] - ['string? string?] - ['symbol symbol] - ['symbol? symbol?] - ['keyword keyword] - ['keyword? keyword?] - ['number? number?] - ['fn? (fn [o] (if (and (fn? o) (not (:ismacro (meta o)))) true false))] - ['macro? (fn [o] (if (and (fn? o) (:ismacro (meta o))) true false))] - - ['pr-str (fn [& xs] (join " " (map #(pr-str % true) xs)))] - ['str (fn [& xs] (join "" (map #(pr-str % false) xs)))] - ['prn (fn [& xs] (println (join " " (map #(pr-str % true) xs))))] - ['println (fn [& xs] (println (join " " (map #(pr-str % false) xs))))] - ['readline readline/readline] - ['read-string reader/read-string] - ['slurp slurp] - ['< <] - ['<= <=] - ['> >] - ['>= >=] - ['+ +] - ['- -] - ['* *] - ['/ /] - ['time-ms time-ms] - - ['list list] - ['list? seq?] - ['vector vector] - ['vector? vector?] - ['hash-map hash-map] - ['map? map?] - ['assoc assoc] - ['dissoc dissoc] - ['get get] - ['contains? contains?] - ['keys (fn [hm] (let [ks (keys hm)] (if (nil? ks) '() ks)))] - ['vals (fn [hm] (let [vs (vals hm)] (if (nil? vs) '() vs)))] - - ['sequential? sequential?] - ['vec vec] - ['cons cons] - ['concat #(apply list (apply concat %&))] - ['nth nth] - ['first first] - ['rest rest] - ['empty? empty?] - ['count count] - ['apply apply] - ['map #(apply list (map %1 %2))] - - ['conj conj] - ['seq (fn [obj] (seq (if (string? obj) (map str obj) obj)))] - - ['with-meta mal_with_meta] - ['meta mal_meta] - ['atom atom] - ['atom? atom?] - ['deref deref] - ['reset! reset!] - ['swap! swap!]]) +(ns mal.core + (:refer-clojure :exclude [pr-str]) + (:require [clojure.string :refer [join]] + [mal.readline :as readline] + [mal.reader :as reader] + [mal.printer :refer [pr-str atom?]])) + +;; Errors/exceptions +(defn mal_throw [obj] + (throw (ex-info "mal exception" {:data obj}))) + +;; String functions +#?(:cljs (defn slurp [f] (.readFileSync (js/require "fs") f "utf-8"))) + +;; Numeric functions +#?(:clj (defn time-ms [] (System/currentTimeMillis)) + :cljs (defn time-ms [] (.getTime (js/Date.)))) + +;; Metadata functions +;; - store metadata at :meta key of the real metadata +(defn mal_with_meta [obj m] + (let [new-meta (assoc (meta obj) :meta m)] + (with-meta obj new-meta))) + +(defn mal_meta [obj] + (:meta (meta obj))) + +;; core_ns is core namespaces functions +(def core_ns + [['= =] + ['throw mal_throw] + ['nil? nil?] + ['true? true?] + ['false? false?] + ['string? string?] + ['symbol symbol] + ['symbol? symbol?] + ['keyword keyword] + ['keyword? keyword?] + ['number? number?] + ['fn? (fn [o] (if (and (fn? o) (not (:ismacro (meta o)))) true false))] + ['macro? (fn [o] (if (and (fn? o) (:ismacro (meta o))) true false))] + + ['pr-str (fn [& xs] (join " " (map #(pr-str % true) xs)))] + ['str (fn [& xs] (join "" (map #(pr-str % false) xs)))] + ['prn (fn [& xs] (println (join " " (map #(pr-str % true) xs))))] + ['println (fn [& xs] (println (join " " (map #(pr-str % false) xs))))] + ['readline readline/readline] + ['read-string reader/read-string] + ['slurp slurp] + ['< <] + ['<= <=] + ['> >] + ['>= >=] + ['+ +] + ['- -] + ['* *] + ['/ /] + ['time-ms time-ms] + + ['list list] + ['list? seq?] + ['vector vector] + ['vector? vector?] + ['hash-map hash-map] + ['map? map?] + ['assoc assoc] + ['dissoc dissoc] + ['get get] + ['contains? contains?] + ['keys (fn [hm] (let [ks (keys hm)] (if (nil? ks) '() ks)))] + ['vals (fn [hm] (let [vs (vals hm)] (if (nil? vs) '() vs)))] + + ['sequential? sequential?] + ['vec vec] + ['cons cons] + ['concat #(apply list (apply concat %&))] + ['nth nth] + ['first first] + ['rest rest] + ['empty? empty?] + ['count count] + ['apply apply] + ['map #(apply list (map %1 %2))] + + ['conj conj] + ['seq (fn [obj] (seq (if (string? obj) (map str obj) obj)))] + + ['with-meta mal_with_meta] + ['meta mal_meta] + ['atom atom] + ['atom? atom?] + ['deref deref] + ['reset! reset!] + ['swap! swap!]]) diff --git a/impls/clojure/src/mal/env.cljc b/impls/clojure/src/mal/env.cljc index 9595a1c560..dbce333fab 100644 --- a/impls/clojure/src/mal/env.cljc +++ b/impls/clojure/src/mal/env.cljc @@ -1,36 +1,36 @@ -(ns mal.env) - -(defn env [& [outer binds exprs]] - ;;(prn "env" binds exprs) - ;; (when (not= (count binds) (count exprs)) - ;; (throw (Exception. "Arity mistmatch in env call"))) - (atom - (loop [env {:outer outer} - b binds - e exprs] - (cond - (= nil b) - env - - (= '& (first b)) - (assoc env (nth b 1) e) - - :else - (recur (assoc env (first b) (first e)) (next b) (rest e)))))) - -(defn env-find [env k] - (cond - (contains? @env k) env - (:outer @env) (env-find (:outer @env) k) - :else nil)) - -(defn env-get [env k] - (let [e (env-find env k)] - (when-not e - (throw (#?(:clj Exception. - :cljs js/Error.) (str "'" k "' not found")))) - (get @e k))) - -(defn env-set [env k v] - (swap! env assoc k v) - v) +(ns mal.env) + +(defn env [& [outer binds exprs]] + ;;(prn "env" binds exprs) + ;; (when (not= (count binds) (count exprs)) + ;; (throw (Exception. "Arity mistmatch in env call"))) + (atom + (loop [env {:outer outer} + b binds + e exprs] + (cond + (= nil b) + env + + (= '& (first b)) + (assoc env (nth b 1) e) + + :else + (recur (assoc env (first b) (first e)) (next b) (rest e)))))) + +(defn env-find [env k] + (cond + (contains? @env k) env + (:outer @env) (env-find (:outer @env) k) + :else nil)) + +(defn env-get [env k] + (let [e (env-find env k)] + (when-not e + (throw (#?(:clj Exception. + :cljs js/Error.) (str "'" k "' not found")))) + (get @e k))) + +(defn env-set [env k v] + (swap! env assoc k v) + v) diff --git a/impls/clojure/src/mal/node_readline.js b/impls/clojure/src/mal/node_readline.js index 6042eaa0af..9bfa296bb2 100644 --- a/impls/clojure/src/mal/node_readline.js +++ b/impls/clojure/src/mal/node_readline.js @@ -1,46 +1,46 @@ -// IMPORTANT: choose one -var RL_LIB = "libreadline"; // NOTE: libreadline is GPL -//var RL_LIB = "libedit"; - -var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); - -var rlwrap = {}; // namespace for this module in web context - -var ffi = require('ffi-napi'), - fs = require('fs'); - -var rllib = ffi.Library(RL_LIB, { - 'readline': [ 'string', [ 'string' ] ], - 'add_history': [ 'int', [ 'string' ] ]}); - -var rl_history_loaded = false; - -exports.readline = rlwrap.readline = function(prompt) { - prompt = typeof prompt !== 'undefined' ? prompt : "user> "; - - if (!rl_history_loaded) { - rl_history_loaded = true; - var lines = []; - if (fs.existsSync(HISTORY_FILE)) { - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - } - // Max of 2000 lines - lines = lines.slice(Math.max(lines.length - 2000, 0)); - for (var i=0; i "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i s (S/replace "\\" "\\\\") - (S/replace "\"" "\\\"") - (S/replace "\n" "\\n"))) - -(defn pr-str - ([obj] (pr-str obj true)) - ([obj print-readably] - (let [_r print-readably] - (cond - (= nil obj) "nil" - (string? obj) (if _r (str "\"" (escape obj) "\"") obj) - - (list? obj) (str "(" (S/join " " (map #(pr-str % _r) obj)) ")") - (vector? obj) (str "[" (S/join " " (map #(pr-str % _r) obj)) "]") - (map? obj) (str "{" (S/join " " (map (fn [[k v]] - (str (pr-str k _r) " " - (pr-str v _r))) obj)) "}") - (atom? obj) (str "(atom " (pr-str @obj _r) ")") - :else (str obj))))) - +(ns mal.printer + (:refer-clojure :exclude [pr-str]) + (:require [clojure.string :as S])) + +;; atom? +#?(:clj (defn atom? [atm] (= (type atm) clojure.lang.Atom)) + :cljs (defn atom? [atm] (satisfies? IAtom atm))) + +(defn escape [s] + (-> s (S/replace "\\" "\\\\") + (S/replace "\"" "\\\"") + (S/replace "\n" "\\n"))) + +(defn pr-str + ([obj] (pr-str obj true)) + ([obj print-readably] + (let [_r print-readably] + (cond + (= nil obj) "nil" + (string? obj) (if _r (str "\"" (escape obj) "\"") obj) + + (list? obj) (str "(" (S/join " " (map #(pr-str % _r) obj)) ")") + (vector? obj) (str "[" (S/join " " (map #(pr-str % _r) obj)) "]") + (map? obj) (str "{" (S/join " " (map (fn [[k v]] + (str (pr-str k _r) " " + (pr-str v _r))) obj)) "}") + (atom? obj) (str "(atom " (pr-str @obj _r) ")") + :else (str obj))))) + diff --git a/impls/clojure/src/mal/reader.cljc b/impls/clojure/src/mal/reader.cljc index 76ecf49652..deb000c313 100644 --- a/impls/clojure/src/mal/reader.cljc +++ b/impls/clojure/src/mal/reader.cljc @@ -1,81 +1,81 @@ -(ns mal.reader - (:refer-clojure :exclude [read-string]) - (:require [clojure.string :as S])) - -(defn throw-str [s] - (throw #?(:cljs (js/Error. s) - :clj (Exception. s)))) - -(defn rdr [tokens] - {:tokens (vec tokens) :position (atom 0)}) - -(defn rdr-peek [rdr] - (get (vec (:tokens rdr)) @(:position rdr))) - -(defn rdr-next [rdr] - (get (vec (:tokens rdr)) (dec (swap! (:position rdr) inc)))) - -(def tok-re #"[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:[\\].|[^\\\"])*\"?|;.*|[^\s\[\]{}()'\"`@,;]+)") -(def int-re #"^-?[0-9]+$") -(def str-re #"^\"((?:[\\].|[^\\\"])*)\"$") -(def badstr-re #"^\"") - -(defn tokenize [s] - (filter #(not= \; (first %)) - (map second (re-seq tok-re s)))) - -(defn unescape [s] - (-> s (S/replace "\\\\" "\u029e") - (S/replace "\\\"" "\"") - (S/replace "\\n" "\n") - (S/replace "\u029e" "\\"))) - -(defn read-atom [rdr] - (let [token (rdr-next rdr)] - (cond - (re-seq int-re token) #?(:cljs (js/parseInt token) - :clj (Integer/parseInt token)) - (re-seq str-re token) (unescape (second (re-find str-re token))) - (re-seq badstr-re token) (throw-str (str "expected '\"', got EOF")) - (= \: (get token 0)) (keyword (subs token 1)) - (= "nil" token) nil - (= "true" token) true - (= "false" token) false - :else (symbol token)))) - -(declare read-form) - -(defn read-seq [rdr start end] - (assert (= start (rdr-next rdr))) ;; pull off start - (loop [lst []] - (let [token (rdr-peek rdr)] - (cond - (= token end) (do (rdr-next rdr) lst) - (not token) (throw-str (str "expected '" end "', got EOF")) - :else (recur (conj lst (read-form rdr))))))) - -(defn read-form [rdr] - (let [tok (rdr-peek rdr)] - (cond - (= "'" tok) (do (rdr-next rdr) (list 'quote (read-form rdr))) - (= "`" tok) (do (rdr-next rdr) (list 'quasiquote (read-form rdr))) - (= "~" tok) (do (rdr-next rdr) (list 'unquote (read-form rdr))) - (= "~@" tok) (do (rdr-next rdr) (list 'splice-unquote (read-form rdr))) - - (= "^" tok) (do (rdr-next rdr) (let [m (read-form rdr)] - (list 'with-meta (read-form rdr) m))) - (= "@" tok) (do (rdr-next rdr) (list 'deref (read-form rdr))) - - (= ")" tok) (throw-str "unexpected ')'") - (= "(" tok) (apply list (read-seq rdr "(" ")")) - - (= "]" tok) (throw-str "unexpected ']'") - (= "[" tok) (vec (read-seq rdr "[" "]")) - - (= "}" tok) (throw-str "unexpected '}'") - (= "{" tok) (apply hash-map (read-seq rdr "{" "}")) - - :else (read-atom rdr)))) - -(defn read-string [s] - (read-form (rdr (tokenize s)))) +(ns mal.reader + (:refer-clojure :exclude [read-string]) + (:require [clojure.string :as S])) + +(defn throw-str [s] + (throw #?(:cljs (js/Error. s) + :clj (Exception. s)))) + +(defn rdr [tokens] + {:tokens (vec tokens) :position (atom 0)}) + +(defn rdr-peek [rdr] + (get (vec (:tokens rdr)) @(:position rdr))) + +(defn rdr-next [rdr] + (get (vec (:tokens rdr)) (dec (swap! (:position rdr) inc)))) + +(def tok-re #"[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:[\\].|[^\\\"])*\"?|;.*|[^\s\[\]{}()'\"`@,;]+)") +(def int-re #"^-?[0-9]+$") +(def str-re #"^\"((?:[\\].|[^\\\"])*)\"$") +(def badstr-re #"^\"") + +(defn tokenize [s] + (filter #(not= \; (first %)) + (map second (re-seq tok-re s)))) + +(defn unescape [s] + (-> s (S/replace "\\\\" "\u029e") + (S/replace "\\\"" "\"") + (S/replace "\\n" "\n") + (S/replace "\u029e" "\\"))) + +(defn read-atom [rdr] + (let [token (rdr-next rdr)] + (cond + (re-seq int-re token) #?(:cljs (js/parseInt token) + :clj (Integer/parseInt token)) + (re-seq str-re token) (unescape (second (re-find str-re token))) + (re-seq badstr-re token) (throw-str (str "expected '\"', got EOF")) + (= \: (get token 0)) (keyword (subs token 1)) + (= "nil" token) nil + (= "true" token) true + (= "false" token) false + :else (symbol token)))) + +(declare read-form) + +(defn read-seq [rdr start end] + (assert (= start (rdr-next rdr))) ;; pull off start + (loop [lst []] + (let [token (rdr-peek rdr)] + (cond + (= token end) (do (rdr-next rdr) lst) + (not token) (throw-str (str "expected '" end "', got EOF")) + :else (recur (conj lst (read-form rdr))))))) + +(defn read-form [rdr] + (let [tok (rdr-peek rdr)] + (cond + (= "'" tok) (do (rdr-next rdr) (list 'quote (read-form rdr))) + (= "`" tok) (do (rdr-next rdr) (list 'quasiquote (read-form rdr))) + (= "~" tok) (do (rdr-next rdr) (list 'unquote (read-form rdr))) + (= "~@" tok) (do (rdr-next rdr) (list 'splice-unquote (read-form rdr))) + + (= "^" tok) (do (rdr-next rdr) (let [m (read-form rdr)] + (list 'with-meta (read-form rdr) m))) + (= "@" tok) (do (rdr-next rdr) (list 'deref (read-form rdr))) + + (= ")" tok) (throw-str "unexpected ')'") + (= "(" tok) (apply list (read-seq rdr "(" ")")) + + (= "]" tok) (throw-str "unexpected ']'") + (= "[" tok) (vec (read-seq rdr "[" "]")) + + (= "}" tok) (throw-str "unexpected '}'") + (= "{" tok) (apply hash-map (read-seq rdr "{" "}")) + + :else (read-atom rdr)))) + +(defn read-string [s] + (read-form (rdr (tokenize s)))) diff --git a/impls/clojure/src/mal/readline.clj b/impls/clojure/src/mal/readline.clj index c5a4cab8ae..8978e02728 100644 --- a/impls/clojure/src/mal/readline.clj +++ b/impls/clojure/src/mal/readline.clj @@ -1,40 +1,40 @@ -(ns mal.readline - (:require [clojure.string :refer [split]] - [clojure.java.io :refer [file]] - [net.n01se.clojure-jna :as jna])) - -(defonce history-loaded (atom nil)) -(def HISTORY-FILE (str (System/getProperty "user.home") "/.mal-history")) - -;; -;; Uncomment one of the following readline libraries -;; - -;; editline (BSD) -#_ -(do - (def readline-call (jna/to-fn String edit/readline)) - (def add-history (jna/to-fn Void edit/add_history)) - (def load-history #(doseq [line (split (slurp %) #"\n")] - (jna/invoke Void edit/add_history line)))) - -;; GNU Readline (GPL) -;; WARNING: distributing your code with GNU readline enabled means you -;; must release your program as GPL -;#_ -(do - (def readline-call (jna/to-fn String readline/readline)) - (def add-history (jna/to-fn Void readline/add_history)) - (def load-history (jna/to-fn Integer readline/read_history))) - -(defn readline [prompt & [lib]] - (when (not @history-loaded) - (reset! history-loaded true) - (when (.canRead (file HISTORY-FILE)) - (load-history HISTORY-FILE))) - (let [line (readline-call prompt)] - (when line - (add-history line) - (when (.canWrite (file HISTORY-FILE)) - (spit HISTORY-FILE (str line "\n") :append true))) - line)) +(ns mal.readline + (:require [clojure.string :refer [split]] + [clojure.java.io :refer [file]] + [net.n01se.clojure-jna :as jna])) + +(defonce history-loaded (atom nil)) +(def HISTORY-FILE (str (System/getProperty "user.home") "/.mal-history")) + +;; +;; Uncomment one of the following readline libraries +;; + +;; editline (BSD) +#_ +(do + (def readline-call (jna/to-fn String edit/readline)) + (def add-history (jna/to-fn Void edit/add_history)) + (def load-history #(doseq [line (split (slurp %) #"\n")] + (jna/invoke Void edit/add_history line)))) + +;; GNU Readline (GPL) +;; WARNING: distributing your code with GNU readline enabled means you +;; must release your program as GPL +;#_ +(do + (def readline-call (jna/to-fn String readline/readline)) + (def add-history (jna/to-fn Void readline/add_history)) + (def load-history (jna/to-fn Integer readline/read_history))) + +(defn readline [prompt & [lib]] + (when (not @history-loaded) + (reset! history-loaded true) + (when (.canRead (file HISTORY-FILE)) + (load-history HISTORY-FILE))) + (let [line (readline-call prompt)] + (when line + (add-history line) + (when (.canWrite (file HISTORY-FILE)) + (spit HISTORY-FILE (str line "\n") :append true))) + line)) diff --git a/impls/clojure/src/mal/readline.cljs b/impls/clojure/src/mal/readline.cljs index ea21874541..603d3e0315 100644 --- a/impls/clojure/src/mal/readline.cljs +++ b/impls/clojure/src/mal/readline.cljs @@ -1,3 +1,3 @@ -(ns mal.readline) - -(def readline (.-readline (js/require "../src/mal/node_readline.js"))) +(ns mal.readline) + +(def readline (.-readline (js/require "../src/mal/node_readline.js"))) diff --git a/impls/clojure/src/mal/step0_repl.cljc b/impls/clojure/src/mal/step0_repl.cljc index 94c9b26187..7cb9af1ed1 100644 --- a/impls/clojure/src/mal/step0_repl.cljc +++ b/impls/clojure/src/mal/step0_repl.cljc @@ -1,28 +1,28 @@ -(ns mal.step0-repl - (:require [mal.readline :as readline]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - strng) - -;; eval -(defn EVAL [ast env] - ast) - -;; print -(defn PRINT [exp] - exp) - -;; repl -(defn rep [strng] (PRINT (EVAL (READ strng), {}))) -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (println (rep line))) - (recur)))) - -(defn -main [& args] - (repl-loop)) +(ns mal.step0-repl + (:require [mal.readline :as readline]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + strng) + +;; eval +(defn EVAL [ast env] + ast) + +;; print +(defn PRINT [exp] + exp) + +;; repl +(defn rep [strng] (PRINT (EVAL (READ strng), {}))) +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (println (rep line))) + (recur)))) + +(defn -main [& args] + (repl-loop)) diff --git a/impls/clojure/src/mal/step1_read_print.cljc b/impls/clojure/src/mal/step1_read_print.cljc index 2b95bffbdb..b2dc3faff7 100644 --- a/impls/clojure/src/mal/step1_read_print.cljc +++ b/impls/clojure/src/mal/step1_read_print.cljc @@ -1,36 +1,36 @@ -(ns mal.step1-read-print - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(defn EVAL [ast env] - ast) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(defn rep - [strng] - (PRINT (EVAL (READ strng) {}))) - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (repl-loop)) +(ns mal.step1-read-print + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(defn EVAL [ast env] + ast) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(defn rep + [strng] + (PRINT (EVAL (READ strng) {}))) + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (repl-loop)) diff --git a/impls/clojure/src/mal/step2_eval.cljc b/impls/clojure/src/mal/step2_eval.cljc index 2727f0585c..582f361ee0 100644 --- a/impls/clojure/src/mal/step2_eval.cljc +++ b/impls/clojure/src/mal/step2_eval.cljc @@ -1,68 +1,68 @@ -(ns mal.step2-eval - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(declare EVAL) -(defn eval-ast [ast env] - (cond - (symbol? ast) (or (get env ast) - (throw (#?(:clj Error. - :cljs js/Error.) (str ast " not found")))) - - (seq? ast) (doall (map #(EVAL % env) ast)) - - (vector? ast) (vec (doall (map #(EVAL % env) ast))) - - (map? ast) (apply hash-map (doall (map #(EVAL % env) - (mapcat identity ast)))) - - :else ast)) - -(defn EVAL [ast env] - ;; indented to match later steps - ;;(prn "EVAL" ast (keys @env)) (flush) - (if (not (seq? ast)) - (eval-ast ast env) - - ;; apply list - ;; indented to match later steps - (if (empty? ast) - ast - (let [el (eval-ast ast env) - f (first el) - args (rest el)] - (apply f args))))) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(def repl-env {'+ + - '- - - '* * - '/ /}) -(defn rep - [strng] - (PRINT (EVAL (READ strng) repl-env))) - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (repl-loop)) +(ns mal.step2-eval + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(declare EVAL) +(defn eval-ast [ast env] + (cond + (symbol? ast) (or (get env ast) + (throw (#?(:clj Error. + :cljs js/Error.) (str ast " not found")))) + + (seq? ast) (doall (map #(EVAL % env) ast)) + + (vector? ast) (vec (doall (map #(EVAL % env) ast))) + + (map? ast) (apply hash-map (doall (map #(EVAL % env) + (mapcat identity ast)))) + + :else ast)) + +(defn EVAL [ast env] + ;; indented to match later steps + ;;(prn "EVAL" ast (keys @env)) (flush) + (if (not (seq? ast)) + (eval-ast ast env) + + ;; apply list + ;; indented to match later steps + (if (empty? ast) + ast + (let [el (eval-ast ast env) + f (first el) + args (rest el)] + (apply f args))))) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(def repl-env {'+ + + '- - + '* * + '/ /}) +(defn rep + [strng] + (PRINT (EVAL (READ strng) repl-env))) + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (repl-loop)) diff --git a/impls/clojure/src/mal/step3_env.cljc b/impls/clojure/src/mal/step3_env.cljc index 6a2c8da5a3..e9330bdebc 100644 --- a/impls/clojure/src/mal/step3_env.cljc +++ b/impls/clojure/src/mal/step3_env.cljc @@ -1,82 +1,82 @@ -(ns mal.step3-env - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer] - [mal.env :as env]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(declare EVAL) -(defn eval-ast [ast env] - (cond - (symbol? ast) (env/env-get env ast) - - (seq? ast) (doall (map #(EVAL % env) ast)) - - (vector? ast) (vec (doall (map #(EVAL % env) ast))) - - (map? ast) (apply hash-map (doall (map #(EVAL % env) - (mapcat identity ast)))) - - :else ast)) - -(defn EVAL [ast env] - ;; indented to match later steps - ;;(prn "EVAL" ast (keys @env)) (flush) - (if (not (seq? ast)) - (eval-ast ast env) - - ;; apply list - ;; indented to match later steps - (let [[a0 a1 a2 a3] ast] - (condp = a0 - nil - ast - - 'def! - (env/env-set env a1 (EVAL a2 env)) - - 'let* - (let [let-env (env/env env)] - (doseq [[b e] (partition 2 a1)] - (env/env-set let-env b (EVAL e let-env))) - (EVAL a2 let-env)) - - ;; apply - (let [el (eval-ast ast env) - f (first el) - args (rest el)] - (apply f args)))))) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(def repl-env (env/env)) -(defn rep - [strng] - (PRINT (EVAL (READ strng) repl-env))) - -(env/env-set repl-env '+ +) -(env/env-set repl-env '- -) -(env/env-set repl-env '* *) -(env/env-set repl-env '/ /) - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (repl-loop)) +(ns mal.step3-env + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer] + [mal.env :as env]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(declare EVAL) +(defn eval-ast [ast env] + (cond + (symbol? ast) (env/env-get env ast) + + (seq? ast) (doall (map #(EVAL % env) ast)) + + (vector? ast) (vec (doall (map #(EVAL % env) ast))) + + (map? ast) (apply hash-map (doall (map #(EVAL % env) + (mapcat identity ast)))) + + :else ast)) + +(defn EVAL [ast env] + ;; indented to match later steps + ;;(prn "EVAL" ast (keys @env)) (flush) + (if (not (seq? ast)) + (eval-ast ast env) + + ;; apply list + ;; indented to match later steps + (let [[a0 a1 a2 a3] ast] + (condp = a0 + nil + ast + + 'def! + (env/env-set env a1 (EVAL a2 env)) + + 'let* + (let [let-env (env/env env)] + (doseq [[b e] (partition 2 a1)] + (env/env-set let-env b (EVAL e let-env))) + (EVAL a2 let-env)) + + ;; apply + (let [el (eval-ast ast env) + f (first el) + args (rest el)] + (apply f args)))))) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(def repl-env (env/env)) +(defn rep + [strng] + (PRINT (EVAL (READ strng) repl-env))) + +(env/env-set repl-env '+ +) +(env/env-set repl-env '- -) +(env/env-set repl-env '* *) +(env/env-set repl-env '/ /) + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (repl-loop)) diff --git a/impls/clojure/src/mal/step4_if_fn_do.cljc b/impls/clojure/src/mal/step4_if_fn_do.cljc index fe3e4c9b02..5a02eb8bd6 100644 --- a/impls/clojure/src/mal/step4_if_fn_do.cljc +++ b/impls/clojure/src/mal/step4_if_fn_do.cljc @@ -1,99 +1,99 @@ -(ns mal.step4-if-fn-do - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer] - [mal.env :as env] - [mal.core :as core]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(declare EVAL) -(defn eval-ast [ast env] - (cond - (symbol? ast) (env/env-get env ast) - - (seq? ast) (doall (map #(EVAL % env) ast)) - - (vector? ast) (vec (doall (map #(EVAL % env) ast))) - - (map? ast) (apply hash-map (doall (map #(EVAL % env) - (mapcat identity ast)))) - - :else ast)) - -(defn EVAL [ast env] - ;; indented to match later steps - ;;(prn "EVAL" ast (keys @env)) (flush) - (if (not (seq? ast)) - (eval-ast ast env) - - ;; apply list - ;; indented to match later steps - (let [[a0 a1 a2 a3] ast] - (condp = a0 - nil - ast - - 'def! - (env/env-set env a1 (EVAL a2 env)) - - 'let* - (let [let-env (env/env env)] - (doseq [[b e] (partition 2 a1)] - (env/env-set let-env b (EVAL e let-env))) - (EVAL a2 let-env)) - - 'do - (last (eval-ast (rest ast) env)) - - 'if - (let [cond (EVAL a1 env)] - (if (or (= cond nil) (= cond false)) - (if (> (count ast) 2) - (EVAL a3 env) - nil) - (EVAL a2 env))) - - 'fn* - (fn [& args] - (EVAL a2 (env/env env a1 (or args '())))) - - ;; apply - (let [el (eval-ast ast env) - f (first el) - args (rest el)] - (apply f args)))))) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(def repl-env (env/env)) -(defn rep - [strng] - (PRINT (EVAL (READ strng) repl-env))) - -;; core.clj: defined using Clojure -(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* [a] (if a false true)))") - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (repl-loop)) +(ns mal.step4-if-fn-do + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer] + [mal.env :as env] + [mal.core :as core]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(declare EVAL) +(defn eval-ast [ast env] + (cond + (symbol? ast) (env/env-get env ast) + + (seq? ast) (doall (map #(EVAL % env) ast)) + + (vector? ast) (vec (doall (map #(EVAL % env) ast))) + + (map? ast) (apply hash-map (doall (map #(EVAL % env) + (mapcat identity ast)))) + + :else ast)) + +(defn EVAL [ast env] + ;; indented to match later steps + ;;(prn "EVAL" ast (keys @env)) (flush) + (if (not (seq? ast)) + (eval-ast ast env) + + ;; apply list + ;; indented to match later steps + (let [[a0 a1 a2 a3] ast] + (condp = a0 + nil + ast + + 'def! + (env/env-set env a1 (EVAL a2 env)) + + 'let* + (let [let-env (env/env env)] + (doseq [[b e] (partition 2 a1)] + (env/env-set let-env b (EVAL e let-env))) + (EVAL a2 let-env)) + + 'do + (last (eval-ast (rest ast) env)) + + 'if + (let [cond (EVAL a1 env)] + (if (or (= cond nil) (= cond false)) + (if (> (count ast) 2) + (EVAL a3 env) + nil) + (EVAL a2 env))) + + 'fn* + (fn [& args] + (EVAL a2 (env/env env a1 (or args '())))) + + ;; apply + (let [el (eval-ast ast env) + f (first el) + args (rest el)] + (apply f args)))))) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(def repl-env (env/env)) +(defn rep + [strng] + (PRINT (EVAL (READ strng) repl-env))) + +;; core.clj: defined using Clojure +(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* [a] (if a false true)))") + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (repl-loop)) diff --git a/impls/clojure/src/mal/step5_tco.cljc b/impls/clojure/src/mal/step5_tco.cljc index dc1209e1e6..79923d59a0 100644 --- a/impls/clojure/src/mal/step5_tco.cljc +++ b/impls/clojure/src/mal/step5_tco.cljc @@ -1,108 +1,108 @@ -(ns mal.step5-tco - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer] - [mal.env :as env] - [mal.core :as core]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(declare EVAL) -(defn eval-ast [ast env] - (cond - (symbol? ast) (env/env-get env ast) - - (seq? ast) (doall (map #(EVAL % env) ast)) - - (vector? ast) (vec (doall (map #(EVAL % env) ast))) - - (map? ast) (apply hash-map (doall (map #(EVAL % env) - (mapcat identity ast)))) - - :else ast)) - -(defn EVAL [ast env] - (loop [ast ast - env env] - ;;(prn "EVAL" ast (keys @env)) (flush) - (if (not (seq? ast)) - (eval-ast ast env) - - ;; apply list - ;; indented to match later steps - (let [[a0 a1 a2 a3] ast] - (condp = a0 - nil - ast - - 'def! - (env/env-set env a1 (EVAL a2 env)) - - 'let* - (let [let-env (env/env env)] - (doseq [[b e] (partition 2 a1)] - (env/env-set let-env b (EVAL e let-env))) - (recur a2 let-env)) - - 'do - (do (eval-ast (->> ast (drop-last) (drop 1)) env) - (recur (last ast) env)) - - 'if - (let [cond (EVAL a1 env)] - (if (or (= cond nil) (= cond false)) - (if (> (count ast) 2) - (recur a3 env) - nil) - (recur a2 env))) - - 'fn* - (with-meta - (fn [& args] - (EVAL a2 (env/env env a1 (or args '())))) - {:expression a2 - :environment env - :parameters a1}) - - ;; apply - (let [el (eval-ast ast env) - f (first el) - args (rest el) - {:keys [expression environment parameters]} (meta f)] - (if expression - (recur expression (env/env environment parameters args)) - (apply f args)))))))) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(def repl-env (env/env)) -(defn rep - [strng] - (PRINT (EVAL (READ strng) repl-env))) - -;; core.clj: defined using Clojure -(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* [a] (if a false true)))") - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (repl-loop)) +(ns mal.step5-tco + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer] + [mal.env :as env] + [mal.core :as core]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(declare EVAL) +(defn eval-ast [ast env] + (cond + (symbol? ast) (env/env-get env ast) + + (seq? ast) (doall (map #(EVAL % env) ast)) + + (vector? ast) (vec (doall (map #(EVAL % env) ast))) + + (map? ast) (apply hash-map (doall (map #(EVAL % env) + (mapcat identity ast)))) + + :else ast)) + +(defn EVAL [ast env] + (loop [ast ast + env env] + ;;(prn "EVAL" ast (keys @env)) (flush) + (if (not (seq? ast)) + (eval-ast ast env) + + ;; apply list + ;; indented to match later steps + (let [[a0 a1 a2 a3] ast] + (condp = a0 + nil + ast + + 'def! + (env/env-set env a1 (EVAL a2 env)) + + 'let* + (let [let-env (env/env env)] + (doseq [[b e] (partition 2 a1)] + (env/env-set let-env b (EVAL e let-env))) + (recur a2 let-env)) + + 'do + (do (eval-ast (->> ast (drop-last) (drop 1)) env) + (recur (last ast) env)) + + 'if + (let [cond (EVAL a1 env)] + (if (or (= cond nil) (= cond false)) + (if (> (count ast) 2) + (recur a3 env) + nil) + (recur a2 env))) + + 'fn* + (with-meta + (fn [& args] + (EVAL a2 (env/env env a1 (or args '())))) + {:expression a2 + :environment env + :parameters a1}) + + ;; apply + (let [el (eval-ast ast env) + f (first el) + args (rest el) + {:keys [expression environment parameters]} (meta f)] + (if expression + (recur expression (env/env environment parameters args)) + (apply f args)))))))) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(def repl-env (env/env)) +(defn rep + [strng] + (PRINT (EVAL (READ strng) repl-env))) + +;; core.clj: defined using Clojure +(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* [a] (if a false true)))") + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (repl-loop)) diff --git a/impls/clojure/src/mal/step6_file.cljc b/impls/clojure/src/mal/step6_file.cljc index d81a291a02..deb778d69b 100644 --- a/impls/clojure/src/mal/step6_file.cljc +++ b/impls/clojure/src/mal/step6_file.cljc @@ -1,114 +1,114 @@ -(ns mal.step6-file - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer] - [mal.env :as env] - [mal.core :as core]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(declare EVAL) -(defn eval-ast [ast env] - (cond - (symbol? ast) (env/env-get env ast) - - (seq? ast) (doall (map #(EVAL % env) ast)) - - (vector? ast) (vec (doall (map #(EVAL % env) ast))) - - (map? ast) (apply hash-map (doall (map #(EVAL % env) - (mapcat identity ast)))) - - :else ast)) - -(defn EVAL [ast env] - (loop [ast ast - env env] - ;;(prn "EVAL" ast (keys @env)) (flush) - (if (not (seq? ast)) - (eval-ast ast env) - - ;; apply list - ;; indented to match later steps - (let [[a0 a1 a2 a3] ast] - (condp = a0 - nil - ast - - 'def! - (env/env-set env a1 (EVAL a2 env)) - - 'let* - (let [let-env (env/env env)] - (doseq [[b e] (partition 2 a1)] - (env/env-set let-env b (EVAL e let-env))) - (recur a2 let-env)) - - 'do - (do (eval-ast (->> ast (drop-last) (drop 1)) env) - (recur (last ast) env)) - - 'if - (let [cond (EVAL a1 env)] - (if (or (= cond nil) (= cond false)) - (if (> (count ast) 2) - (recur a3 env) - nil) - (recur a2 env))) - - 'fn* - (with-meta - (fn [& args] - (EVAL a2 (env/env env a1 (or args '())))) - {:expression a2 - :environment env - :parameters a1}) - - ;; apply - (let [el (eval-ast ast env) - f (first el) - args (rest el) - {:keys [expression environment parameters]} (meta f)] - (if expression - (recur expression (env/env environment parameters args)) - (apply f args)))))))) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(def repl-env (env/env)) -(defn rep - [strng] - (PRINT (EVAL (READ strng) repl-env))) - -;; core.clj: defined using Clojure -(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) -(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) -(env/env-set repl-env '*ARGV* ()) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (env/env-set repl-env '*ARGV* (rest args)) - (if args - (rep (str "(load-file \"" (first args) "\")")) - (repl-loop))) +(ns mal.step6-file + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer] + [mal.env :as env] + [mal.core :as core]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(declare EVAL) +(defn eval-ast [ast env] + (cond + (symbol? ast) (env/env-get env ast) + + (seq? ast) (doall (map #(EVAL % env) ast)) + + (vector? ast) (vec (doall (map #(EVAL % env) ast))) + + (map? ast) (apply hash-map (doall (map #(EVAL % env) + (mapcat identity ast)))) + + :else ast)) + +(defn EVAL [ast env] + (loop [ast ast + env env] + ;;(prn "EVAL" ast (keys @env)) (flush) + (if (not (seq? ast)) + (eval-ast ast env) + + ;; apply list + ;; indented to match later steps + (let [[a0 a1 a2 a3] ast] + (condp = a0 + nil + ast + + 'def! + (env/env-set env a1 (EVAL a2 env)) + + 'let* + (let [let-env (env/env env)] + (doseq [[b e] (partition 2 a1)] + (env/env-set let-env b (EVAL e let-env))) + (recur a2 let-env)) + + 'do + (do (eval-ast (->> ast (drop-last) (drop 1)) env) + (recur (last ast) env)) + + 'if + (let [cond (EVAL a1 env)] + (if (or (= cond nil) (= cond false)) + (if (> (count ast) 2) + (recur a3 env) + nil) + (recur a2 env))) + + 'fn* + (with-meta + (fn [& args] + (EVAL a2 (env/env env a1 (or args '())))) + {:expression a2 + :environment env + :parameters a1}) + + ;; apply + (let [el (eval-ast ast env) + f (first el) + args (rest el) + {:keys [expression environment parameters]} (meta f)] + (if expression + (recur expression (env/env environment parameters args)) + (apply f args)))))))) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(def repl-env (env/env)) +(defn rep + [strng] + (PRINT (EVAL (READ strng) repl-env))) + +;; core.clj: defined using Clojure +(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) +(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) +(env/env-set repl-env '*ARGV* ()) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (env/env-set repl-env '*ARGV* (rest args)) + (if args + (rep (str "(load-file \"" (first args) "\")")) + (repl-loop))) diff --git a/impls/clojure/src/mal/step7_quote.cljc b/impls/clojure/src/mal/step7_quote.cljc index 5b2284158f..009ad82a06 100644 --- a/impls/clojure/src/mal/step7_quote.cljc +++ b/impls/clojure/src/mal/step7_quote.cljc @@ -1,143 +1,143 @@ -(ns mal.step7-quote - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer] - [mal.env :as env] - [mal.core :as core]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(declare EVAL) - -(declare quasiquote) -(defn starts_with [ast sym] - (and (seq? ast) - (= (first ast) sym))) -(defn qq-iter [seq] - (if (empty? seq) - () - (let [elt (first seq) - acc (qq-iter (rest seq))] - (if (starts_with elt 'splice-unquote) - (list 'concat (second elt) acc) - (list 'cons (quasiquote elt) acc))))) -(defn quasiquote [ast] - (cond (starts_with ast 'unquote) (second ast) - (seq? ast) (qq-iter ast) - (vector? ast) (list 'vec (qq-iter ast)) - (or (symbol? ast) (map? ast)) (list 'quote ast) - :else ast)) - -(defn eval-ast [ast env] - (cond - (symbol? ast) (env/env-get env ast) - - (seq? ast) (doall (map #(EVAL % env) ast)) - - (vector? ast) (vec (doall (map #(EVAL % env) ast))) - - (map? ast) (apply hash-map (doall (map #(EVAL % env) - (mapcat identity ast)))) - - :else ast)) - -(defn EVAL [ast env] - (loop [ast ast - env env] - ;;(prn "EVAL" ast (keys @env)) (flush) - (if (not (seq? ast)) - (eval-ast ast env) - - ;; apply list - ;; indented to match later steps - (let [[a0 a1 a2 a3] ast] - (condp = a0 - nil - ast - - 'def! - (env/env-set env a1 (EVAL a2 env)) - - 'let* - (let [let-env (env/env env)] - (doseq [[b e] (partition 2 a1)] - (env/env-set let-env b (EVAL e let-env))) - (recur a2 let-env)) - - 'quote - a1 - - 'quasiquoteexpand - (quasiquote a1) - - 'quasiquote - (recur (quasiquote a1) env) - - 'do - (do (eval-ast (->> ast (drop-last) (drop 1)) env) - (recur (last ast) env)) - - 'if - (let [cond (EVAL a1 env)] - (if (or (= cond nil) (= cond false)) - (if (> (count ast) 2) - (recur a3 env) - nil) - (recur a2 env))) - - 'fn* - (with-meta - (fn [& args] - (EVAL a2 (env/env env a1 (or args '())))) - {:expression a2 - :environment env - :parameters a1}) - - ;; apply - (let [el (eval-ast ast env) - f (first el) - args (rest el) - {:keys [expression environment parameters]} (meta f)] - (if expression - (recur expression (env/env environment parameters args)) - (apply f args)))))))) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(def repl-env (env/env)) -(defn rep - [strng] - (PRINT (EVAL (READ strng) repl-env))) - -;; core.clj: defined using Clojure -(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) -(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) -(env/env-set repl-env '*ARGV* ()) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (env/env-set repl-env '*ARGV* (rest args)) - (if args - (rep (str "(load-file \"" (first args) "\")")) - (repl-loop))) +(ns mal.step7-quote + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer] + [mal.env :as env] + [mal.core :as core]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(declare EVAL) + +(declare quasiquote) +(defn starts_with [ast sym] + (and (seq? ast) + (= (first ast) sym))) +(defn qq-iter [seq] + (if (empty? seq) + () + (let [elt (first seq) + acc (qq-iter (rest seq))] + (if (starts_with elt 'splice-unquote) + (list 'concat (second elt) acc) + (list 'cons (quasiquote elt) acc))))) +(defn quasiquote [ast] + (cond (starts_with ast 'unquote) (second ast) + (seq? ast) (qq-iter ast) + (vector? ast) (list 'vec (qq-iter ast)) + (or (symbol? ast) (map? ast)) (list 'quote ast) + :else ast)) + +(defn eval-ast [ast env] + (cond + (symbol? ast) (env/env-get env ast) + + (seq? ast) (doall (map #(EVAL % env) ast)) + + (vector? ast) (vec (doall (map #(EVAL % env) ast))) + + (map? ast) (apply hash-map (doall (map #(EVAL % env) + (mapcat identity ast)))) + + :else ast)) + +(defn EVAL [ast env] + (loop [ast ast + env env] + ;;(prn "EVAL" ast (keys @env)) (flush) + (if (not (seq? ast)) + (eval-ast ast env) + + ;; apply list + ;; indented to match later steps + (let [[a0 a1 a2 a3] ast] + (condp = a0 + nil + ast + + 'def! + (env/env-set env a1 (EVAL a2 env)) + + 'let* + (let [let-env (env/env env)] + (doseq [[b e] (partition 2 a1)] + (env/env-set let-env b (EVAL e let-env))) + (recur a2 let-env)) + + 'quote + a1 + + 'quasiquoteexpand + (quasiquote a1) + + 'quasiquote + (recur (quasiquote a1) env) + + 'do + (do (eval-ast (->> ast (drop-last) (drop 1)) env) + (recur (last ast) env)) + + 'if + (let [cond (EVAL a1 env)] + (if (or (= cond nil) (= cond false)) + (if (> (count ast) 2) + (recur a3 env) + nil) + (recur a2 env))) + + 'fn* + (with-meta + (fn [& args] + (EVAL a2 (env/env env a1 (or args '())))) + {:expression a2 + :environment env + :parameters a1}) + + ;; apply + (let [el (eval-ast ast env) + f (first el) + args (rest el) + {:keys [expression environment parameters]} (meta f)] + (if expression + (recur expression (env/env environment parameters args)) + (apply f args)))))))) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(def repl-env (env/env)) +(defn rep + [strng] + (PRINT (EVAL (READ strng) repl-env))) + +;; core.clj: defined using Clojure +(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) +(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) +(env/env-set repl-env '*ARGV* ()) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (env/env-set repl-env '*ARGV* (rest args)) + (if args + (rep (str "(load-file \"" (first args) "\")")) + (repl-loop))) diff --git a/impls/clojure/src/mal/step8_macros.cljc b/impls/clojure/src/mal/step8_macros.cljc index fea4a39519..1e3285632d 100644 --- a/impls/clojure/src/mal/step8_macros.cljc +++ b/impls/clojure/src/mal/step8_macros.cljc @@ -1,178 +1,178 @@ -(ns mal.step8-macros - (:refer-clojure :exclude [macroexpand]) - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer] - [mal.env :as env] - [mal.core :as core]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(declare EVAL) - -(declare quasiquote) -(defn starts_with [ast sym] - (and (seq? ast) - (= (first ast) sym))) -(defn qq-iter [seq] - (if (empty? seq) - () - (let [elt (first seq) - acc (qq-iter (rest seq))] - (if (starts_with elt 'splice-unquote) - (list 'concat (second elt) acc) - (list 'cons (quasiquote elt) acc))))) -(defn quasiquote [ast] - (cond (starts_with ast 'unquote) (second ast) - (seq? ast) (qq-iter ast) - (vector? ast) (list 'vec (qq-iter ast)) - (or (symbol? ast) (map? ast)) (list 'quote ast) - :else ast)) - -(defn is-macro-call [ast env] - (and (seq? ast) - (symbol? (first ast)) - (env/env-find env (first ast)) - (:ismacro (meta (env/env-get env (first ast)))))) - -(defn macroexpand [ast env] - (loop [ast ast] - (if (is-macro-call ast env) - ;; Get original unadorned function because ClojureScript (1.10) - ;; limits functions with meta on them to arity 20 - (let [mac (:orig (meta (env/env-get env (first ast))))] - (recur (apply mac (rest ast)))) - ast))) - -(defn eval-ast [ast env] - (cond - (symbol? ast) (env/env-get env ast) - - (seq? ast) (doall (map #(EVAL % env) ast)) - - (vector? ast) (vec (doall (map #(EVAL % env) ast))) - - (map? ast) (apply hash-map (doall (map #(EVAL % env) - (mapcat identity ast)))) - - :else ast)) - -(defn EVAL [ast env] - (loop [ast ast - env env] - ;;(prn "EVAL" ast (keys @env)) (flush) - (if (not (seq? ast)) - (eval-ast ast env) - - ;; apply list - (let [ast (macroexpand ast env)] - (if (not (seq? ast)) - (eval-ast ast env) - - (let [[a0 a1 a2 a3] ast] - (condp = a0 - nil - ast - - 'def! - (env/env-set env a1 (EVAL a2 env)) - - 'let* - (let [let-env (env/env env)] - (doseq [[b e] (partition 2 a1)] - (env/env-set let-env b (EVAL e let-env))) - (recur a2 let-env)) - - 'quote - a1 - - 'quasiquoteexpand - (quasiquote a1) - - 'quasiquote - (recur (quasiquote a1) env) - - 'defmacro! - (let [func (EVAL a2 env) - ;; Preserve unadorned function to workaround - ;; ClojureScript function-with-meta arity limit - mac (with-meta func {:orig (:orig (meta func)) - :ismacro true})] - (env/env-set env a1 mac)) - - 'macroexpand - (macroexpand a1 env) - - 'do - (do (eval-ast (->> ast (drop-last) (drop 1)) env) - (recur (last ast) env)) - - 'if - (let [cond (EVAL a1 env)] - (if (or (= cond nil) (= cond false)) - (if (> (count ast) 2) - (recur a3 env) - nil) - (recur a2 env))) - - 'fn* - (let [func (fn [& args] - (EVAL a2 (env/env env a1 (or args '()))))] - (with-meta - func - ;; Preserve unadorned function to workaround - ;; ClojureScript function-with-meta arity limit - {:orig func - :expression a2 - :environment env - :parameters a1})) - - ;; apply - (let [el (eval-ast ast env) - f (first el) - args (rest el) - {:keys [expression environment parameters]} (meta f)] - (if expression - (recur expression (env/env environment parameters args)) - (apply f args)))))))))) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(def repl-env (env/env)) -(defn rep - [strng] - (PRINT (EVAL (READ strng) repl-env))) - -;; core.clj: defined using Clojure -(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) -(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) -(env/env-set repl-env '*ARGV* ()) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (env/env-set repl-env '*ARGV* (rest args)) - (if args - (rep (str "(load-file \"" (first args) "\")")) - (repl-loop))) +(ns mal.step8-macros + (:refer-clojure :exclude [macroexpand]) + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer] + [mal.env :as env] + [mal.core :as core]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(declare EVAL) + +(declare quasiquote) +(defn starts_with [ast sym] + (and (seq? ast) + (= (first ast) sym))) +(defn qq-iter [seq] + (if (empty? seq) + () + (let [elt (first seq) + acc (qq-iter (rest seq))] + (if (starts_with elt 'splice-unquote) + (list 'concat (second elt) acc) + (list 'cons (quasiquote elt) acc))))) +(defn quasiquote [ast] + (cond (starts_with ast 'unquote) (second ast) + (seq? ast) (qq-iter ast) + (vector? ast) (list 'vec (qq-iter ast)) + (or (symbol? ast) (map? ast)) (list 'quote ast) + :else ast)) + +(defn is-macro-call [ast env] + (and (seq? ast) + (symbol? (first ast)) + (env/env-find env (first ast)) + (:ismacro (meta (env/env-get env (first ast)))))) + +(defn macroexpand [ast env] + (loop [ast ast] + (if (is-macro-call ast env) + ;; Get original unadorned function because ClojureScript (1.10) + ;; limits functions with meta on them to arity 20 + (let [mac (:orig (meta (env/env-get env (first ast))))] + (recur (apply mac (rest ast)))) + ast))) + +(defn eval-ast [ast env] + (cond + (symbol? ast) (env/env-get env ast) + + (seq? ast) (doall (map #(EVAL % env) ast)) + + (vector? ast) (vec (doall (map #(EVAL % env) ast))) + + (map? ast) (apply hash-map (doall (map #(EVAL % env) + (mapcat identity ast)))) + + :else ast)) + +(defn EVAL [ast env] + (loop [ast ast + env env] + ;;(prn "EVAL" ast (keys @env)) (flush) + (if (not (seq? ast)) + (eval-ast ast env) + + ;; apply list + (let [ast (macroexpand ast env)] + (if (not (seq? ast)) + (eval-ast ast env) + + (let [[a0 a1 a2 a3] ast] + (condp = a0 + nil + ast + + 'def! + (env/env-set env a1 (EVAL a2 env)) + + 'let* + (let [let-env (env/env env)] + (doseq [[b e] (partition 2 a1)] + (env/env-set let-env b (EVAL e let-env))) + (recur a2 let-env)) + + 'quote + a1 + + 'quasiquoteexpand + (quasiquote a1) + + 'quasiquote + (recur (quasiquote a1) env) + + 'defmacro! + (let [func (EVAL a2 env) + ;; Preserve unadorned function to workaround + ;; ClojureScript function-with-meta arity limit + mac (with-meta func {:orig (:orig (meta func)) + :ismacro true})] + (env/env-set env a1 mac)) + + 'macroexpand + (macroexpand a1 env) + + 'do + (do (eval-ast (->> ast (drop-last) (drop 1)) env) + (recur (last ast) env)) + + 'if + (let [cond (EVAL a1 env)] + (if (or (= cond nil) (= cond false)) + (if (> (count ast) 2) + (recur a3 env) + nil) + (recur a2 env))) + + 'fn* + (let [func (fn [& args] + (EVAL a2 (env/env env a1 (or args '()))))] + (with-meta + func + ;; Preserve unadorned function to workaround + ;; ClojureScript function-with-meta arity limit + {:orig func + :expression a2 + :environment env + :parameters a1})) + + ;; apply + (let [el (eval-ast ast env) + f (first el) + args (rest el) + {:keys [expression environment parameters]} (meta f)] + (if expression + (recur expression (env/env environment parameters args)) + (apply f args)))))))))) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(def repl-env (env/env)) +(defn rep + [strng] + (PRINT (EVAL (READ strng) repl-env))) + +;; core.clj: defined using Clojure +(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) +(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) +(env/env-set repl-env '*ARGV* ()) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (env/env-set repl-env '*ARGV* (rest args)) + (if args + (rep (str "(load-file \"" (first args) "\")")) + (repl-loop))) diff --git a/impls/clojure/src/mal/step9_try.cljc b/impls/clojure/src/mal/step9_try.cljc index 47a430c818..dd7cbf3df8 100644 --- a/impls/clojure/src/mal/step9_try.cljc +++ b/impls/clojure/src/mal/step9_try.cljc @@ -1,198 +1,198 @@ -(ns mal.step9-try - (:refer-clojure :exclude [macroexpand]) - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer] - [mal.env :as env] - [mal.core :as core]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(declare EVAL) - -(declare quasiquote) -(defn starts_with [ast sym] - (and (seq? ast) - (= (first ast) sym))) -(defn qq-iter [seq] - (if (empty? seq) - () - (let [elt (first seq) - acc (qq-iter (rest seq))] - (if (starts_with elt 'splice-unquote) - (list 'concat (second elt) acc) - (list 'cons (quasiquote elt) acc))))) -(defn quasiquote [ast] - (cond (starts_with ast 'unquote) (second ast) - (seq? ast) (qq-iter ast) - (vector? ast) (list 'vec (qq-iter ast)) - (or (symbol? ast) (map? ast)) (list 'quote ast) - :else ast)) - -(defn is-macro-call [ast env] - (and (seq? ast) - (symbol? (first ast)) - (env/env-find env (first ast)) - (:ismacro (meta (env/env-get env (first ast)))))) - -(defn macroexpand [ast env] - (loop [ast ast] - (if (is-macro-call ast env) - ;; Get original unadorned function because ClojureScript (1.10) - ;; limits functions with meta on them to arity 20 - (let [mac (:orig (meta (env/env-get env (first ast))))] - (recur (apply mac (rest ast)))) - ast))) - -(defn eval-ast [ast env] - (cond - (symbol? ast) (env/env-get env ast) - - (seq? ast) (doall (map #(EVAL % env) ast)) - - (vector? ast) (vec (doall (map #(EVAL % env) ast))) - - (map? ast) (apply hash-map (doall (map #(EVAL % env) - (mapcat identity ast)))) - - :else ast)) - -(defn EVAL [ast env] - (loop [ast ast - env env] - ;;(prn "EVAL" ast (keys @env)) (flush) - (if (not (seq? ast)) - (eval-ast ast env) - - ;; apply list - (let [ast (macroexpand ast env)] - (if (not (seq? ast)) - (eval-ast ast env) - - (let [[a0 a1 a2 a3] ast] - (condp = a0 - nil - ast - - 'def! - (env/env-set env a1 (EVAL a2 env)) - - 'let* - (let [let-env (env/env env)] - (doseq [[b e] (partition 2 a1)] - (env/env-set let-env b (EVAL e let-env))) - (recur a2 let-env)) - - 'quote - a1 - - 'quasiquoteexpand - (quasiquote a1) - - 'quasiquote - (recur (quasiquote a1) env) - - 'defmacro! - (let [func (EVAL a2 env) - ;; Preserve unadorned function to workaround - ;; ClojureScript function-with-meta arity limit - mac (with-meta func {:orig (:orig (meta func)) - :ismacro true})] - (env/env-set env a1 mac)) - - 'macroexpand - (macroexpand a1 env) - - 'try* - (if (= 'catch* (nth a2 0)) - (try - (EVAL a1 env) - (catch #?(:clj clojure.lang.ExceptionInfo - :cljs ExceptionInfo) ei - (EVAL (nth a2 2) (env/env env - [(nth a2 1)] - [(:data (ex-data ei))]))) - (catch #?(:clj Throwable :cljs :default) t - (EVAL (nth a2 2) (env/env env - [(nth a2 1)] - [#?(:clj (or (.getMessage t) - (.toString t)) - :cljs (.-message t))])))) - (EVAL a1 env)) - - 'do - (do (eval-ast (->> ast (drop-last) (drop 1)) env) - (recur (last ast) env)) - - 'if - (let [cond (EVAL a1 env)] - (if (or (= cond nil) (= cond false)) - (if (> (count ast) 2) - (recur a3 env) - nil) - (recur a2 env))) - - 'fn* - (let [func (fn [& args] - (EVAL a2 (env/env env a1 (or args '()))))] - (with-meta - func - ;; Preserve unadorned function to workaround - ;; ClojureScript function-with-meta arity limit - {:orig func - :expression a2 - :environment env - :parameters a1})) - - ;; apply - (let [el (eval-ast ast env) - f (first el) - args (rest el) - {:keys [expression environment parameters]} (meta f)] - (if expression - (recur expression (env/env environment parameters args)) - (apply f args)))))))))) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(def repl-env (env/env)) -(defn rep - [strng] - (PRINT (EVAL (READ strng) repl-env))) - -;; core.clj: defined using Clojure -(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) -(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) -(env/env-set repl-env '*ARGV* ()) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:cljs (catch ExceptionInfo e - (println "Error:" (or (:data (ex-data e)) - (.-stack e))))) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (env/env-set repl-env '*ARGV* (rest args)) - (if args - (rep (str "(load-file \"" (first args) "\")")) - (repl-loop))) +(ns mal.step9-try + (:refer-clojure :exclude [macroexpand]) + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer] + [mal.env :as env] + [mal.core :as core]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(declare EVAL) + +(declare quasiquote) +(defn starts_with [ast sym] + (and (seq? ast) + (= (first ast) sym))) +(defn qq-iter [seq] + (if (empty? seq) + () + (let [elt (first seq) + acc (qq-iter (rest seq))] + (if (starts_with elt 'splice-unquote) + (list 'concat (second elt) acc) + (list 'cons (quasiquote elt) acc))))) +(defn quasiquote [ast] + (cond (starts_with ast 'unquote) (second ast) + (seq? ast) (qq-iter ast) + (vector? ast) (list 'vec (qq-iter ast)) + (or (symbol? ast) (map? ast)) (list 'quote ast) + :else ast)) + +(defn is-macro-call [ast env] + (and (seq? ast) + (symbol? (first ast)) + (env/env-find env (first ast)) + (:ismacro (meta (env/env-get env (first ast)))))) + +(defn macroexpand [ast env] + (loop [ast ast] + (if (is-macro-call ast env) + ;; Get original unadorned function because ClojureScript (1.10) + ;; limits functions with meta on them to arity 20 + (let [mac (:orig (meta (env/env-get env (first ast))))] + (recur (apply mac (rest ast)))) + ast))) + +(defn eval-ast [ast env] + (cond + (symbol? ast) (env/env-get env ast) + + (seq? ast) (doall (map #(EVAL % env) ast)) + + (vector? ast) (vec (doall (map #(EVAL % env) ast))) + + (map? ast) (apply hash-map (doall (map #(EVAL % env) + (mapcat identity ast)))) + + :else ast)) + +(defn EVAL [ast env] + (loop [ast ast + env env] + ;;(prn "EVAL" ast (keys @env)) (flush) + (if (not (seq? ast)) + (eval-ast ast env) + + ;; apply list + (let [ast (macroexpand ast env)] + (if (not (seq? ast)) + (eval-ast ast env) + + (let [[a0 a1 a2 a3] ast] + (condp = a0 + nil + ast + + 'def! + (env/env-set env a1 (EVAL a2 env)) + + 'let* + (let [let-env (env/env env)] + (doseq [[b e] (partition 2 a1)] + (env/env-set let-env b (EVAL e let-env))) + (recur a2 let-env)) + + 'quote + a1 + + 'quasiquoteexpand + (quasiquote a1) + + 'quasiquote + (recur (quasiquote a1) env) + + 'defmacro! + (let [func (EVAL a2 env) + ;; Preserve unadorned function to workaround + ;; ClojureScript function-with-meta arity limit + mac (with-meta func {:orig (:orig (meta func)) + :ismacro true})] + (env/env-set env a1 mac)) + + 'macroexpand + (macroexpand a1 env) + + 'try* + (if (= 'catch* (nth a2 0)) + (try + (EVAL a1 env) + (catch #?(:clj clojure.lang.ExceptionInfo + :cljs ExceptionInfo) ei + (EVAL (nth a2 2) (env/env env + [(nth a2 1)] + [(:data (ex-data ei))]))) + (catch #?(:clj Throwable :cljs :default) t + (EVAL (nth a2 2) (env/env env + [(nth a2 1)] + [#?(:clj (or (.getMessage t) + (.toString t)) + :cljs (.-message t))])))) + (EVAL a1 env)) + + 'do + (do (eval-ast (->> ast (drop-last) (drop 1)) env) + (recur (last ast) env)) + + 'if + (let [cond (EVAL a1 env)] + (if (or (= cond nil) (= cond false)) + (if (> (count ast) 2) + (recur a3 env) + nil) + (recur a2 env))) + + 'fn* + (let [func (fn [& args] + (EVAL a2 (env/env env a1 (or args '()))))] + (with-meta + func + ;; Preserve unadorned function to workaround + ;; ClojureScript function-with-meta arity limit + {:orig func + :expression a2 + :environment env + :parameters a1})) + + ;; apply + (let [el (eval-ast ast env) + f (first el) + args (rest el) + {:keys [expression environment parameters]} (meta f)] + (if expression + (recur expression (env/env environment parameters args)) + (apply f args)))))))))) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(def repl-env (env/env)) +(defn rep + [strng] + (PRINT (EVAL (READ strng) repl-env))) + +;; core.clj: defined using Clojure +(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) +(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) +(env/env-set repl-env '*ARGV* ()) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:cljs (catch ExceptionInfo e + (println "Error:" (or (:data (ex-data e)) + (.-stack e))))) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (env/env-set repl-env '*ARGV* (rest args)) + (if args + (rep (str "(load-file \"" (first args) "\")")) + (repl-loop))) diff --git a/impls/clojure/src/mal/stepA_mal.cljc b/impls/clojure/src/mal/stepA_mal.cljc index d6203ef4e8..4be3368a1f 100644 --- a/impls/clojure/src/mal/stepA_mal.cljc +++ b/impls/clojure/src/mal/stepA_mal.cljc @@ -1,210 +1,210 @@ -(ns mal.stepA-mal - (:refer-clojure :exclude [macroexpand]) - (:require [mal.readline :as readline] - #?(:clj [clojure.repl]) - [mal.reader :as reader] - [mal.printer :as printer] - [mal.env :as env] - [mal.core :as core]) - #?(:clj (:gen-class))) - -;; read -(defn READ [& [strng]] - (reader/read-string strng)) - -;; eval -(declare EVAL) - -(declare quasiquote) -(defn starts_with [ast sym] - (and (seq? ast) - (= (first ast) sym))) -(defn qq-iter [seq] - (if (empty? seq) - () - (let [elt (first seq) - acc (qq-iter (rest seq))] - (if (starts_with elt 'splice-unquote) - (list 'concat (second elt) acc) - (list 'cons (quasiquote elt) acc))))) -(defn quasiquote [ast] - (cond (starts_with ast 'unquote) (second ast) - (seq? ast) (qq-iter ast) - (vector? ast) (list 'vec (qq-iter ast)) - (or (symbol? ast) (map? ast)) (list 'quote ast) - :else ast)) - -(defn is-macro-call [ast env] - (and (seq? ast) - (symbol? (first ast)) - (env/env-find env (first ast)) - (:ismacro (meta (env/env-get env (first ast)))))) - -(defn macroexpand [ast env] - (loop [ast ast] - (if (is-macro-call ast env) - ;; Get original unadorned function because ClojureScript (1.10) - ;; limits functions with meta on them to arity 20 - (let [mac (:orig (meta (env/env-get env (first ast))))] - (recur (apply mac (rest ast)))) - ast))) - -(defn eval-ast [ast env] - (cond - (symbol? ast) (env/env-get env ast) - - (seq? ast) (doall (map #(EVAL % env) ast)) - - (vector? ast) (vec (doall (map #(EVAL % env) ast))) - - (map? ast) (apply hash-map (doall (map #(EVAL % env) - (mapcat identity ast)))) - - :else ast)) - -(defn EVAL [ast env] - (loop [ast ast - env env] - ;;(prn "EVAL" ast (keys @env)) (flush) - (if (not (seq? ast)) - (eval-ast ast env) - - ;; apply list - (let [ast (macroexpand ast env)] - (if (not (seq? ast)) - (eval-ast ast env) - - (let [[a0 a1 a2 a3] ast] - (condp = a0 - nil - ast - - 'def! - (env/env-set env a1 (EVAL a2 env)) - - 'let* - (let [let-env (env/env env)] - (doseq [[b e] (partition 2 a1)] - (env/env-set let-env b (EVAL e let-env))) - (recur a2 let-env)) - - 'quote - a1 - - 'quasiquoteexpand - (quasiquote a1) - - 'quasiquote - (recur (quasiquote a1) env) - - 'defmacro! - (let [func (EVAL a2 env) - ;; Preserve unadorned function to workaround - ;; ClojureScript function-with-meta arity limit - mac (with-meta func {:orig (:orig (meta func)) - :ismacro true})] - (env/env-set env a1 mac)) - - 'macroexpand - (macroexpand a1 env) - - 'clj* - #?(:clj (eval (reader/read-string a1)) - :cljs (throw (ex-info "clj* unsupported in ClojureScript mode" {}))) - - 'js* - #?(:clj (throw (ex-info "js* unsupported in Clojure mode" {})) - :cljs (js->clj (js/eval a1))) - - 'try* - (if (= 'catch* (nth a2 0)) - (try - (EVAL a1 env) - (catch #?(:clj clojure.lang.ExceptionInfo - :cljs ExceptionInfo) ei - (EVAL (nth a2 2) (env/env env - [(nth a2 1)] - [(:data (ex-data ei))]))) - (catch #?(:clj Throwable :cljs :default) t - (EVAL (nth a2 2) (env/env env - [(nth a2 1)] - [#?(:clj (or (.getMessage t) - (.toString t)) - :cljs (.-message t))])))) - (EVAL a1 env)) - - 'do - (do (eval-ast (->> ast (drop-last) (drop 1)) env) - (recur (last ast) env)) - - 'if - (let [cond (EVAL a1 env)] - (if (or (= cond nil) (= cond false)) - (if (> (count ast) 2) - (recur a3 env) - nil) - (recur a2 env))) - - 'fn* - (let [func (fn [& args] - (EVAL a2 (env/env env a1 (or args '()))))] - (with-meta - func - ;; Preserve unadorned function to workaround - ;; ClojureScript function-with-meta arity limit - {:orig func - :expression a2 - :environment env - :parameters a1})) - - ;; apply - (let [el (eval-ast ast env) - f (first el) - args (rest el) - {:keys [expression environment parameters]} (meta f)] - (if expression - (recur expression (env/env environment parameters args)) - (apply f args)))))))))) - -;; print -(defn PRINT [exp] (printer/pr-str exp)) - -;; repl -(def repl-env (env/env)) -(defn rep - [strng] - (PRINT (EVAL (READ strng) repl-env))) - -;; core.clj: defined using Clojure -(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) -(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) -(env/env-set repl-env '*ARGV* ()) - -;; core.mal: defined using the language itself -#?(:clj (rep "(def! *host-language* \"clojure\")") - :cljs (rep "(def! *host-language* \"clojurescript\")")) -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -;; repl loop -(defn repl-loop [] - (let [line (readline/readline "user> ")] - (when line - (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment - (try - (println (rep line)) - #?(:cljs (catch ExceptionInfo e - (println "Error:" (or (:data (ex-data e)) - (.-stack e))))) - #?(:clj (catch Throwable e (clojure.repl/pst e)) - :cljs (catch js/Error e (println (.-stack e)))))) - (recur)))) - -(defn -main [& args] - (env/env-set repl-env '*ARGV* (rest args)) - (if args - (rep (str "(load-file \"" (first args) "\")")) - (do - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (repl-loop)))) +(ns mal.stepA-mal + (:refer-clojure :exclude [macroexpand]) + (:require [mal.readline :as readline] + #?(:clj [clojure.repl]) + [mal.reader :as reader] + [mal.printer :as printer] + [mal.env :as env] + [mal.core :as core]) + #?(:clj (:gen-class))) + +;; read +(defn READ [& [strng]] + (reader/read-string strng)) + +;; eval +(declare EVAL) + +(declare quasiquote) +(defn starts_with [ast sym] + (and (seq? ast) + (= (first ast) sym))) +(defn qq-iter [seq] + (if (empty? seq) + () + (let [elt (first seq) + acc (qq-iter (rest seq))] + (if (starts_with elt 'splice-unquote) + (list 'concat (second elt) acc) + (list 'cons (quasiquote elt) acc))))) +(defn quasiquote [ast] + (cond (starts_with ast 'unquote) (second ast) + (seq? ast) (qq-iter ast) + (vector? ast) (list 'vec (qq-iter ast)) + (or (symbol? ast) (map? ast)) (list 'quote ast) + :else ast)) + +(defn is-macro-call [ast env] + (and (seq? ast) + (symbol? (first ast)) + (env/env-find env (first ast)) + (:ismacro (meta (env/env-get env (first ast)))))) + +(defn macroexpand [ast env] + (loop [ast ast] + (if (is-macro-call ast env) + ;; Get original unadorned function because ClojureScript (1.10) + ;; limits functions with meta on them to arity 20 + (let [mac (:orig (meta (env/env-get env (first ast))))] + (recur (apply mac (rest ast)))) + ast))) + +(defn eval-ast [ast env] + (cond + (symbol? ast) (env/env-get env ast) + + (seq? ast) (doall (map #(EVAL % env) ast)) + + (vector? ast) (vec (doall (map #(EVAL % env) ast))) + + (map? ast) (apply hash-map (doall (map #(EVAL % env) + (mapcat identity ast)))) + + :else ast)) + +(defn EVAL [ast env] + (loop [ast ast + env env] + ;;(prn "EVAL" ast (keys @env)) (flush) + (if (not (seq? ast)) + (eval-ast ast env) + + ;; apply list + (let [ast (macroexpand ast env)] + (if (not (seq? ast)) + (eval-ast ast env) + + (let [[a0 a1 a2 a3] ast] + (condp = a0 + nil + ast + + 'def! + (env/env-set env a1 (EVAL a2 env)) + + 'let* + (let [let-env (env/env env)] + (doseq [[b e] (partition 2 a1)] + (env/env-set let-env b (EVAL e let-env))) + (recur a2 let-env)) + + 'quote + a1 + + 'quasiquoteexpand + (quasiquote a1) + + 'quasiquote + (recur (quasiquote a1) env) + + 'defmacro! + (let [func (EVAL a2 env) + ;; Preserve unadorned function to workaround + ;; ClojureScript function-with-meta arity limit + mac (with-meta func {:orig (:orig (meta func)) + :ismacro true})] + (env/env-set env a1 mac)) + + 'macroexpand + (macroexpand a1 env) + + 'clj* + #?(:clj (eval (reader/read-string a1)) + :cljs (throw (ex-info "clj* unsupported in ClojureScript mode" {}))) + + 'js* + #?(:clj (throw (ex-info "js* unsupported in Clojure mode" {})) + :cljs (js->clj (js/eval a1))) + + 'try* + (if (= 'catch* (nth a2 0)) + (try + (EVAL a1 env) + (catch #?(:clj clojure.lang.ExceptionInfo + :cljs ExceptionInfo) ei + (EVAL (nth a2 2) (env/env env + [(nth a2 1)] + [(:data (ex-data ei))]))) + (catch #?(:clj Throwable :cljs :default) t + (EVAL (nth a2 2) (env/env env + [(nth a2 1)] + [#?(:clj (or (.getMessage t) + (.toString t)) + :cljs (.-message t))])))) + (EVAL a1 env)) + + 'do + (do (eval-ast (->> ast (drop-last) (drop 1)) env) + (recur (last ast) env)) + + 'if + (let [cond (EVAL a1 env)] + (if (or (= cond nil) (= cond false)) + (if (> (count ast) 2) + (recur a3 env) + nil) + (recur a2 env))) + + 'fn* + (let [func (fn [& args] + (EVAL a2 (env/env env a1 (or args '()))))] + (with-meta + func + ;; Preserve unadorned function to workaround + ;; ClojureScript function-with-meta arity limit + {:orig func + :expression a2 + :environment env + :parameters a1})) + + ;; apply + (let [el (eval-ast ast env) + f (first el) + args (rest el) + {:keys [expression environment parameters]} (meta f)] + (if expression + (recur expression (env/env environment parameters args)) + (apply f args)))))))))) + +;; print +(defn PRINT [exp] (printer/pr-str exp)) + +;; repl +(def repl-env (env/env)) +(defn rep + [strng] + (PRINT (EVAL (READ strng) repl-env))) + +;; core.clj: defined using Clojure +(doseq [[k v] core/core_ns] (env/env-set repl-env k v)) +(env/env-set repl-env 'eval (fn [ast] (EVAL ast repl-env))) +(env/env-set repl-env '*ARGV* ()) + +;; core.mal: defined using the language itself +#?(:clj (rep "(def! *host-language* \"clojure\")") + :cljs (rep "(def! *host-language* \"clojurescript\")")) +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* [f] (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +;; repl loop +(defn repl-loop [] + (let [line (readline/readline "user> ")] + (when line + (when-not (re-seq #"^\s*$|^\s*;.*$" line) ; blank/comment + (try + (println (rep line)) + #?(:cljs (catch ExceptionInfo e + (println "Error:" (or (:data (ex-data e)) + (.-stack e))))) + #?(:clj (catch Throwable e (clojure.repl/pst e)) + :cljs (catch js/Error e (println (.-stack e)))))) + (recur)))) + +(defn -main [& args] + (env/env-set repl-env '*ARGV* (rest args)) + (if args + (rep (str "(load-file \"" (first args) "\")")) + (do + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (repl-loop)))) diff --git a/impls/clojure/tests/step5_tco.mal b/impls/clojure/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/clojure/tests/step5_tco.mal +++ b/impls/clojure/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/clojure/tests/stepA_mal.mal b/impls/clojure/tests/stepA_mal.mal index d77c8a24d3..5935e18918 100644 --- a/impls/clojure/tests/stepA_mal.mal +++ b/impls/clojure/tests/stepA_mal.mal @@ -1,22 +1,22 @@ -;; Testing basic clojure/clojurescript interop - -(def! clj (= *host-language* "clojure")) -(def! cljs (= *host-language* "clojurescript")) - -(if clj (clj* "7") (js* "7")) -;=>7 - -(if clj (clj* "\"abc\"") (js* "\"abc\"")) -;=>"abc" - -(if clj (clj* "{\"abc\" 123}") {"abc" 123}) -;=>{"abc" 123} - -(if clj (clj* "(prn \"foo\")") (js* "console.log('\"foo\"')")) -;/"foo" -;=>nil - -(if clj (clj* "(apply list (for [x [1 2 3]] (+ 1 x)))") '(2 3 4)) -;=>(2 3 4) -(if cljs (js* "[1,2,3].map(function(x) {return 1+x})") [2 3 4]) -;=>[2 3 4] +;; Testing basic clojure/clojurescript interop + +(def! clj (= *host-language* "clojure")) +(def! cljs (= *host-language* "clojurescript")) + +(if clj (clj* "7") (js* "7")) +;=>7 + +(if clj (clj* "\"abc\"") (js* "\"abc\"")) +;=>"abc" + +(if clj (clj* "{\"abc\" 123}") {"abc" 123}) +;=>{"abc" 123} + +(if clj (clj* "(prn \"foo\")") (js* "console.log('\"foo\"')")) +;/"foo" +;=>nil + +(if clj (clj* "(apply list (for [x [1 2 3]] (+ 1 x)))") '(2 3 4)) +;=>(2 3 4) +(if cljs (js* "[1,2,3].map(function(x) {return 1+x})") [2 3 4]) +;=>[2 3 4] diff --git a/impls/coffee/Dockerfile b/impls/coffee/Dockerfile index 075c304e7f..ac00f170c2 100644 --- a/impls/coffee/Dockerfile +++ b/impls/coffee/Dockerfile @@ -1,39 +1,39 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm - -# CoffeeScript specific -RUN npm install -g coffeescript -RUN touch /.coffee_history && chmod go+w /.coffee_history - +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm + +# CoffeeScript specific +RUN npm install -g coffeescript +RUN touch /.coffee_history && chmod go+w /.coffee_history + diff --git a/impls/coffee/Makefile b/impls/coffee/Makefile index 4036473196..e6e0966780 100644 --- a/impls/coffee/Makefile +++ b/impls/coffee/Makefile @@ -1,30 +1,30 @@ -SOURCES_BASE = node_readline.coffee types.coffee \ - reader.coffee printer.coffee -SOURCES_LISP = env.coffee core.coffee stepA_mal.coffee -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -STEPS = step0_repl.coffee step1_read_print.coffee \ - step2_eval.coffee step3_env.coffee step4_if_fn_do.coffee \ - step5_tco.coffee step6_file.coffee step7_quote.coffee \ - step8_macros.coffee step9_try.coffee stepA_mal.coffee - -all: node_modules dist - -node_modules: - npm install - -$(STEPS): node_modules - -dist: mal.coffee mal - -mal.coffee: $(SOURCES) - cat $+ | grep -v "= *require('./" > $@ - -mal: mal.coffee - echo "#!/usr/bin/env coffee" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.coffee mal - +SOURCES_BASE = node_readline.coffee types.coffee \ + reader.coffee printer.coffee +SOURCES_LISP = env.coffee core.coffee stepA_mal.coffee +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +STEPS = step0_repl.coffee step1_read_print.coffee \ + step2_eval.coffee step3_env.coffee step4_if_fn_do.coffee \ + step5_tco.coffee step6_file.coffee step7_quote.coffee \ + step8_macros.coffee step9_try.coffee stepA_mal.coffee + +all: node_modules dist + +node_modules: + npm install + +$(STEPS): node_modules + +dist: mal.coffee mal + +mal.coffee: $(SOURCES) + cat $+ | grep -v "= *require('./" > $@ + +mal: mal.coffee + echo "#!/usr/bin/env coffee" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.coffee mal + diff --git a/impls/coffee/core.coffee b/impls/coffee/core.coffee index 555efbaf03..92ed0df976 100644 --- a/impls/coffee/core.coffee +++ b/impls/coffee/core.coffee @@ -1,108 +1,108 @@ -readline = require "./node_readline" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" -[_pr_str, println] = [printer._pr_str, printer.println] - -# Sequence functions -conj = (seq, args...) -> - switch types._obj_type(seq) - when 'list' - lst = types._clone(seq) - lst.unshift(x) for x in args - lst - when 'vector' - lst = types._clone(seq) - lst.push(args...) - types._vector(lst...) - else throw new Error "conj called on " + types._obj_type(seq) - -seq = (obj) -> - switch types._obj_type(obj) - when 'list' - if obj.length == 0 then null else obj - when 'vector' - if obj.length == 0 then null else obj[0..-1] - when 'string' - if obj.length == 0 then null else obj.split('') - when 'nil' - null - else throw new Error "seq: called on non-sequential " + types._obj_type(seq) - -# Metadata functions -with_meta = (obj,m) -> - new_obj = types._clone(obj) - new_obj.__meta__ = m - new_obj - - -exports.ns = { - '=': (a,b) -> types._equal_Q(a,b), - 'throw': (a) -> throw {"object": a}, - 'nil?': types._nil_Q, - 'true?': types._true_Q, - 'false?': types._false_Q, - 'string?': types._string_Q, - 'symbol': types._symbol, - 'symbol?': types._symbol_Q, - 'keyword': types._keyword, - 'keyword?': types._keyword_Q, - 'number?': (a) -> typeof a == 'number', - 'fn?': (a) -> typeof a == 'function' and not types._macro_Q(a), - 'macro?': types._macro_Q, - - 'pr-str': (a...) -> a.map((exp) -> _pr_str(exp,true)).join(" "), - 'str': (a...) -> a.map((exp) -> _pr_str(exp,false)).join(""), - 'prn': (a...) -> println(a.map((exp) -> _pr_str(exp,true))...), - 'println': (a...) -> println(a.map((exp) -> _pr_str(exp,false))...), - 'readline': readline.readline, - 'read-string': reader.read_str, - 'slurp': (a) -> require('fs').readFileSync(a, 'utf-8'), - '<': (a,b) -> a': (a,b) -> a>b, - '>=': (a,b) -> a>=b, - '+': (a,b) -> a+b, - '-': (a,b) -> a-b, - '*': (a,b) -> a*b, - '/': (a,b) -> a/b, - 'time-ms': () -> new Date().getTime(), - - 'list': (a...) -> a, - 'list?': types._list_Q, - 'vector': (a...) -> types._vector(a...), - 'vector?': types._vector_Q, - 'hash-map': (a...) -> types._hash_map(a...), - 'map?': types._hash_map_Q, - 'assoc': (a,b...) -> types._assoc_BANG(types._clone(a), b...), - 'dissoc': (a,b...) -> types._dissoc_BANG(types._clone(a), b...), - 'get': (a,b) -> if a != null and b of a then a[b] else null, - 'contains?': (a,b) -> b of a, - 'keys': (a) -> k for k of a, - 'vals': (a) -> v for k,v of a, - - 'sequential?': types._sequential_Q, - 'cons': (a,b) -> [a].concat(b), - 'concat': (a=[],b...) -> a.concat(b...), - 'vec': (a) -> types._vector a..., - 'nth': (a,b) -> if a.length > b then a[b] else - throw new Error "nth: index out of bounds", - 'first': (a) -> if a != null and a.length > 0 then a[0] else null, - 'rest': (a) -> if a == null then [] else a[1..], - 'empty?': (a) -> a.length == 0, - 'count': (a) -> if a == null then 0 else a.length, - 'apply': (a,b...) -> a(b[0..-2].concat(b[b.length-1])...), - 'map': (a,b) -> b.map((x) -> a(x)), - - 'conj': conj, - 'seq': seq, - - 'with-meta': with_meta, - 'meta': (a) -> a.__meta__ or null, - 'atom': types._atom, - 'atom?': types._atom_Q, - 'deref': (a) -> a.val, - 'reset!': (a,b) -> a.val = b, - 'swap!': (a,b,c...) -> a.val = b([a.val].concat(c)...), } - -# vim: ts=2:sw=2 +readline = require "./node_readline" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" +[_pr_str, println] = [printer._pr_str, printer.println] + +# Sequence functions +conj = (seq, args...) -> + switch types._obj_type(seq) + when 'list' + lst = types._clone(seq) + lst.unshift(x) for x in args + lst + when 'vector' + lst = types._clone(seq) + lst.push(args...) + types._vector(lst...) + else throw new Error "conj called on " + types._obj_type(seq) + +seq = (obj) -> + switch types._obj_type(obj) + when 'list' + if obj.length == 0 then null else obj + when 'vector' + if obj.length == 0 then null else obj[0..-1] + when 'string' + if obj.length == 0 then null else obj.split('') + when 'nil' + null + else throw new Error "seq: called on non-sequential " + types._obj_type(seq) + +# Metadata functions +with_meta = (obj,m) -> + new_obj = types._clone(obj) + new_obj.__meta__ = m + new_obj + + +exports.ns = { + '=': (a,b) -> types._equal_Q(a,b), + 'throw': (a) -> throw {"object": a}, + 'nil?': types._nil_Q, + 'true?': types._true_Q, + 'false?': types._false_Q, + 'string?': types._string_Q, + 'symbol': types._symbol, + 'symbol?': types._symbol_Q, + 'keyword': types._keyword, + 'keyword?': types._keyword_Q, + 'number?': (a) -> typeof a == 'number', + 'fn?': (a) -> typeof a == 'function' and not types._macro_Q(a), + 'macro?': types._macro_Q, + + 'pr-str': (a...) -> a.map((exp) -> _pr_str(exp,true)).join(" "), + 'str': (a...) -> a.map((exp) -> _pr_str(exp,false)).join(""), + 'prn': (a...) -> println(a.map((exp) -> _pr_str(exp,true))...), + 'println': (a...) -> println(a.map((exp) -> _pr_str(exp,false))...), + 'readline': readline.readline, + 'read-string': reader.read_str, + 'slurp': (a) -> require('fs').readFileSync(a, 'utf-8'), + '<': (a,b) -> a': (a,b) -> a>b, + '>=': (a,b) -> a>=b, + '+': (a,b) -> a+b, + '-': (a,b) -> a-b, + '*': (a,b) -> a*b, + '/': (a,b) -> a/b, + 'time-ms': () -> new Date().getTime(), + + 'list': (a...) -> a, + 'list?': types._list_Q, + 'vector': (a...) -> types._vector(a...), + 'vector?': types._vector_Q, + 'hash-map': (a...) -> types._hash_map(a...), + 'map?': types._hash_map_Q, + 'assoc': (a,b...) -> types._assoc_BANG(types._clone(a), b...), + 'dissoc': (a,b...) -> types._dissoc_BANG(types._clone(a), b...), + 'get': (a,b) -> if a != null and b of a then a[b] else null, + 'contains?': (a,b) -> b of a, + 'keys': (a) -> k for k of a, + 'vals': (a) -> v for k,v of a, + + 'sequential?': types._sequential_Q, + 'cons': (a,b) -> [a].concat(b), + 'concat': (a=[],b...) -> a.concat(b...), + 'vec': (a) -> types._vector a..., + 'nth': (a,b) -> if a.length > b then a[b] else + throw new Error "nth: index out of bounds", + 'first': (a) -> if a != null and a.length > 0 then a[0] else null, + 'rest': (a) -> if a == null then [] else a[1..], + 'empty?': (a) -> a.length == 0, + 'count': (a) -> if a == null then 0 else a.length, + 'apply': (a,b...) -> a(b[0..-2].concat(b[b.length-1])...), + 'map': (a,b) -> b.map((x) -> a(x)), + + 'conj': conj, + 'seq': seq, + + 'with-meta': with_meta, + 'meta': (a) -> a.__meta__ or null, + 'atom': types._atom, + 'atom?': types._atom_Q, + 'deref': (a) -> a.val, + 'reset!': (a,b) -> a.val = b, + 'swap!': (a,b,c...) -> a.val = b([a.val].concat(c)...), } + +# vim: ts=2:sw=2 diff --git a/impls/coffee/env.coffee b/impls/coffee/env.coffee index 097933a3ad..96b1e6565b 100644 --- a/impls/coffee/env.coffee +++ b/impls/coffee/env.coffee @@ -1,31 +1,31 @@ -types = require "./types.coffee" - -# Env -exports.Env = class Env - constructor: (@outer=null, @binds=[], @exprs=[]) -> - @data = {} - if @binds.length > 0 - for b,i in @binds - if types._symbol_Q(b) && b.name == "&" - @data[@binds[i+1].name] = @exprs[i..] - break - else - @data[b.name] = @exprs[i] - find: (key) -> - if not types._symbol_Q(key) - throw new Error("env.find key must be symbol") - if key.name of @data then @ - else if @outer then @outer.find(key) - else null - set: (key, value) -> - if not types._symbol_Q(key) - throw new Error("env.set key must be symbol") - @data[key.name] = value - get: (key) -> - if not types._symbol_Q(key) - throw new Error("env.get key must be symbol") - env = @find(key) - throw new Error("'" + key.name + "' not found") if !env - env.data[key.name] - -# vim: ts=2:sw=2 +types = require "./types.coffee" + +# Env +exports.Env = class Env + constructor: (@outer=null, @binds=[], @exprs=[]) -> + @data = {} + if @binds.length > 0 + for b,i in @binds + if types._symbol_Q(b) && b.name == "&" + @data[@binds[i+1].name] = @exprs[i..] + break + else + @data[b.name] = @exprs[i] + find: (key) -> + if not types._symbol_Q(key) + throw new Error("env.find key must be symbol") + if key.name of @data then @ + else if @outer then @outer.find(key) + else null + set: (key, value) -> + if not types._symbol_Q(key) + throw new Error("env.set key must be symbol") + @data[key.name] = value + get: (key) -> + if not types._symbol_Q(key) + throw new Error("env.get key must be symbol") + env = @find(key) + throw new Error("'" + key.name + "' not found") if !env + env.data[key.name] + +# vim: ts=2:sw=2 diff --git a/impls/coffee/node_readline.coffee b/impls/coffee/node_readline.coffee index fecddc80f2..266ede03a0 100644 --- a/impls/coffee/node_readline.coffee +++ b/impls/coffee/node_readline.coffee @@ -1,39 +1,39 @@ -# IMPORTANT: choose one -RL_LIB = "libreadline" # NOTE: libreadline is GPL -#RL_LIB = "libedit" - -HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history') - -rlwrap = {} # namespace for this module in web context - -ffi = require('ffi-napi') -fs = require('fs') - -rllib = ffi.Library(RL_LIB, { - 'readline': ['string', ['string']], - 'add_history': ['int', ['string']]}) - -rl_history_loaded = false - -exports.readline = rlwrap.readline = (prompt = 'user> ') -> - if !rl_history_loaded - rl_history_loaded = true - lines = [] - if fs.existsSync(HISTORY_FILE) - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - - # Max of 2000 lines - lines = lines[Math.max(lines.length - 2000, 0)..] - rllib.add_history(line) for line in lines when line != "" - - line = rllib.readline prompt - if line - rllib.add_history line - try - fs.appendFileSync HISTORY_FILE, line + "\n" - catch exc - true - - line - -# vim: ts=2:sw=2 +# IMPORTANT: choose one +RL_LIB = "libreadline" # NOTE: libreadline is GPL +#RL_LIB = "libedit" + +HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history') + +rlwrap = {} # namespace for this module in web context + +ffi = require('ffi-napi') +fs = require('fs') + +rllib = ffi.Library(RL_LIB, { + 'readline': ['string', ['string']], + 'add_history': ['int', ['string']]}) + +rl_history_loaded = false + +exports.readline = rlwrap.readline = (prompt = 'user> ') -> + if !rl_history_loaded + rl_history_loaded = true + lines = [] + if fs.existsSync(HISTORY_FILE) + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + + # Max of 2000 lines + lines = lines[Math.max(lines.length - 2000, 0)..] + rllib.add_history(line) for line in lines when line != "" + + line = rllib.readline prompt + if line + rllib.add_history line + try + fs.appendFileSync HISTORY_FILE, line + "\n" + catch exc + true + + line + +# vim: ts=2:sw=2 diff --git a/impls/coffee/package.json b/impls/coffee/package.json index 9850858436..c3e1be036c 100644 --- a/impls/coffee/package.json +++ b/impls/coffee/package.json @@ -1,9 +1,9 @@ -{ - "name": "mal", - "version": "0.0.1", - "description": "Make a Lisp (mal) language implemented in CoffeeScript", - "dependencies": { - "ffi-napi": "2.4.x", - "coffeescript": "~1.8" - } -} +{ + "name": "mal", + "version": "0.0.1", + "description": "Make a Lisp (mal) language implemented in CoffeeScript", + "dependencies": { + "ffi-napi": "2.4.x", + "coffeescript": "~1.8" + } +} diff --git a/impls/coffee/printer.coffee b/impls/coffee/printer.coffee index 9f56e2e3b1..8fa0b6d8f0 100644 --- a/impls/coffee/printer.coffee +++ b/impls/coffee/printer.coffee @@ -1,25 +1,25 @@ -types = require "./types.coffee" - -exports.println = (args...) -> console.log(args.join(" ")) || null - -exports._pr_str = _pr_str = (obj, print_readably=true) -> - _r = print_readably - switch types._obj_type obj - when 'list' then '(' + obj.map((e) -> _pr_str(e,_r)).join(' ') + ')' - when 'vector' then '[' + obj.map((e) -> _pr_str(e,_r)).join(' ') + ']' - when 'hash-map' - ret = [] - ret.push(_pr_str(k,_r), _pr_str(v,_r)) for k,v of obj - '{' + ret.join(' ') + '}' - when 'string' - if _r then '"' + (obj.replace(/\\/g, '\\\\') - .replace(/"/g, '\\"') - .replace(/\n/g, '\\n')) + '"' - else obj - when 'keyword' then ":" + obj.slice(1) - when 'symbol' then obj.name - when 'nil' then 'nil' - when 'atom' then "(atom " + _pr_str(obj.val,_r) + ")" - else obj.toString() - -# vim: ts=2:sw=2 +types = require "./types.coffee" + +exports.println = (args...) -> console.log(args.join(" ")) || null + +exports._pr_str = _pr_str = (obj, print_readably=true) -> + _r = print_readably + switch types._obj_type obj + when 'list' then '(' + obj.map((e) -> _pr_str(e,_r)).join(' ') + ')' + when 'vector' then '[' + obj.map((e) -> _pr_str(e,_r)).join(' ') + ']' + when 'hash-map' + ret = [] + ret.push(_pr_str(k,_r), _pr_str(v,_r)) for k,v of obj + '{' + ret.join(' ') + '}' + when 'string' + if _r then '"' + (obj.replace(/\\/g, '\\\\') + .replace(/"/g, '\\"') + .replace(/\n/g, '\\n')) + '"' + else obj + when 'keyword' then ":" + obj.slice(1) + when 'symbol' then obj.name + when 'nil' then 'nil' + when 'atom' then "(atom " + _pr_str(obj.val,_r) + ")" + else obj.toString() + +# vim: ts=2:sw=2 diff --git a/impls/coffee/reader.coffee b/impls/coffee/reader.coffee index e551bec651..35c05aac83 100644 --- a/impls/coffee/reader.coffee +++ b/impls/coffee/reader.coffee @@ -1,88 +1,88 @@ -types = require "./types.coffee" -_symbol = types._symbol - - -class Reader - constructor: (@tokens) -> @position = 0 - next: -> @tokens[@position++] - peek: -> @tokens[@position] - skip: -> - @position++ - @ - -tokenize = (str) -> - re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g - results = [] - while (match = re.exec(str)[1]) != "" - continue if match[0] == ';' - results.push(match) - results - -read_atom = (rdr) -> - token = rdr.next() - if token.match /^-?[0-9]+$/ then parseInt token,10 - else if token.match /^-?[0-9][0-9.]*$/ then parseFloat token,10 - else if token.match /^"(?:\\.|[^\\"])*"$/ - token.slice(1, token.length-1) - .replace(/\\(.)/g, (_, c) -> if c == 'n' then '\n' else c) - else if token[0] == '"' - throw new Error "expected '\"', got EOF" - else if token[0] == ':' then types._keyword(token[1..]) - else if token == "nil" then null - else if token == "true" then true - else if token == "false" then false - else _symbol(token) - -read_list = (rdr, start='(', end=')') -> - ast = [] - token = rdr.next() - throw new Error "expected '" + start + "'" if token != start - while (token = rdr.peek()) != end - throw new Error "expected '" + end + "', got EOF" if !token - ast.push read_form rdr - rdr.next() - ast - -read_vector = (rdr) -> - types._vector(read_list(rdr, '[', ']')...) - -read_hash_map = (rdr) -> - types._hash_map(read_list(rdr, '{', '}')...) - -read_form = (rdr) -> - token = rdr.peek() - switch token - when '\'' then [_symbol('quote'), read_form(rdr.skip())] - when '`' then [_symbol('quasiquote'), read_form(rdr.skip())] - when '~' then [_symbol('unquote'), read_form(rdr.skip())] - when '~@' then [_symbol('splice-unquote'), read_form(rdr.skip())] - when '^' - meta = read_form(rdr.skip()) - [_symbol('with-meta'), read_form(rdr), meta] - when '@' then [_symbol('deref'), read_form(rdr.skip())] - - # list - when ')' then throw new Error "unexpected ')'" - when '(' then read_list(rdr) - # vector - when ']' then throw new Error "unexpected ']'" - when '[' then read_vector(rdr) - # hash-map - when '}' then throw new Error "unexpected '}'" - when '{' then read_hash_map(rdr) - # atom - else read_atom(rdr) - - -exports.BlankException = BlankException = (msg) -> null - -exports.read_str = read_str = (str) -> - tokens = tokenize(str) - throw new BlankException() if tokens.length == 0 - read_form(new Reader(tokens)) - -#console.log read_str "(1 \"two\" three)" -#console.log read_str "[1 2 3]" -#console.log read_str '{"abc" 123 "def" 456}' - -# vim: ts=2:sw=2 +types = require "./types.coffee" +_symbol = types._symbol + + +class Reader + constructor: (@tokens) -> @position = 0 + next: -> @tokens[@position++] + peek: -> @tokens[@position] + skip: -> + @position++ + @ + +tokenize = (str) -> + re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g + results = [] + while (match = re.exec(str)[1]) != "" + continue if match[0] == ';' + results.push(match) + results + +read_atom = (rdr) -> + token = rdr.next() + if token.match /^-?[0-9]+$/ then parseInt token,10 + else if token.match /^-?[0-9][0-9.]*$/ then parseFloat token,10 + else if token.match /^"(?:\\.|[^\\"])*"$/ + token.slice(1, token.length-1) + .replace(/\\(.)/g, (_, c) -> if c == 'n' then '\n' else c) + else if token[0] == '"' + throw new Error "expected '\"', got EOF" + else if token[0] == ':' then types._keyword(token[1..]) + else if token == "nil" then null + else if token == "true" then true + else if token == "false" then false + else _symbol(token) + +read_list = (rdr, start='(', end=')') -> + ast = [] + token = rdr.next() + throw new Error "expected '" + start + "'" if token != start + while (token = rdr.peek()) != end + throw new Error "expected '" + end + "', got EOF" if !token + ast.push read_form rdr + rdr.next() + ast + +read_vector = (rdr) -> + types._vector(read_list(rdr, '[', ']')...) + +read_hash_map = (rdr) -> + types._hash_map(read_list(rdr, '{', '}')...) + +read_form = (rdr) -> + token = rdr.peek() + switch token + when '\'' then [_symbol('quote'), read_form(rdr.skip())] + when '`' then [_symbol('quasiquote'), read_form(rdr.skip())] + when '~' then [_symbol('unquote'), read_form(rdr.skip())] + when '~@' then [_symbol('splice-unquote'), read_form(rdr.skip())] + when '^' + meta = read_form(rdr.skip()) + [_symbol('with-meta'), read_form(rdr), meta] + when '@' then [_symbol('deref'), read_form(rdr.skip())] + + # list + when ')' then throw new Error "unexpected ')'" + when '(' then read_list(rdr) + # vector + when ']' then throw new Error "unexpected ']'" + when '[' then read_vector(rdr) + # hash-map + when '}' then throw new Error "unexpected '}'" + when '{' then read_hash_map(rdr) + # atom + else read_atom(rdr) + + +exports.BlankException = BlankException = (msg) -> null + +exports.read_str = read_str = (str) -> + tokens = tokenize(str) + throw new BlankException() if tokens.length == 0 + read_form(new Reader(tokens)) + +#console.log read_str "(1 \"two\" three)" +#console.log read_str "[1 2 3]" +#console.log read_str '{"abc" 123 "def" 456}' + +# vim: ts=2:sw=2 diff --git a/impls/coffee/run b/impls/coffee/run index b7841f7779..faba6f19b4 100755 --- a/impls/coffee/run +++ b/impls/coffee/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec coffee $(dirname $0)/${STEP:-stepA_mal}.coffee "${@}" +#!/bin/bash +exec coffee $(dirname $0)/${STEP:-stepA_mal}.coffee "${@}" diff --git a/impls/coffee/step0_repl.coffee b/impls/coffee/step0_repl.coffee index 4fa9e40284..56a8a5270b 100644 --- a/impls/coffee/step0_repl.coffee +++ b/impls/coffee/step0_repl.coffee @@ -1,20 +1,20 @@ -readline = require "./node_readline.coffee" - -# read -READ = (str) -> str - -# eval -EVAL = (ast, env) -> ast - -# print -PRINT = (exp) -> exp - -# repl -rep = (str) -> PRINT(EVAL(READ(str), {})) - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - console.log rep line - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" + +# read +READ = (str) -> str + +# eval +EVAL = (ast, env) -> ast + +# print +PRINT = (exp) -> exp + +# repl +rep = (str) -> PRINT(EVAL(READ(str), {})) + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + console.log rep line + +# vim: ts=2:sw=2 diff --git a/impls/coffee/step1_read_print.coffee b/impls/coffee/step1_read_print.coffee index df5cf74855..f2c62c998b 100644 --- a/impls/coffee/step1_read_print.coffee +++ b/impls/coffee/step1_read_print.coffee @@ -1,29 +1,29 @@ -readline = require "./node_readline.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" - -# read -READ = (str) -> reader.read_str str - -# eval -EVAL = (ast, env) -> ast - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -rep = (str) -> PRINT(EVAL(READ(str), {})) - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? then console.log exc.stack - else console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" + +# read +READ = (str) -> reader.read_str str + +# eval +EVAL = (ast, env) -> ast + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +rep = (str) -> PRINT(EVAL(READ(str), {})) + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? then console.log exc.stack + else console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/step2_eval.coffee b/impls/coffee/step2_eval.coffee index 56df8e1550..ef2120e667 100644 --- a/impls/coffee/step2_eval.coffee +++ b/impls/coffee/step2_eval.coffee @@ -1,55 +1,55 @@ -readline = require "./node_readline.coffee" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" - -# read -READ = (str) -> reader.read_str str - -# eval -eval_ast = (ast, env) -> - if types._symbol_Q(ast) then env[ast.name] - else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) - else if types._vector_Q(ast) - types._vector(ast.map((a) -> EVAL(a, env))...) - else if types._hash_map_Q(ast) - new_hm = {} - new_hm[k] = EVAL(v, env) for k,v of ast - new_hm - else ast - -EVAL = (ast, env) -> - #console.log "EVAL:", printer._pr_str ast - if !types._list_Q ast then return eval_ast ast, env - if ast.length == 0 then return ast - - # apply list - [f, args...] = eval_ast ast, env - f(args...) - - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -repl_env = {} -rep = (str) -> PRINT(EVAL(READ(str), repl_env)) - -repl_env["+"] = (a,b) -> a+b -repl_env["-"] = (a,b) -> a-b -repl_env["*"] = (a,b) -> a*b -repl_env["/"] = (a,b) -> a/b - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? then console.log exc.stack - else console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" + +# read +READ = (str) -> reader.read_str str + +# eval +eval_ast = (ast, env) -> + if types._symbol_Q(ast) then env[ast.name] + else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) + else if types._vector_Q(ast) + types._vector(ast.map((a) -> EVAL(a, env))...) + else if types._hash_map_Q(ast) + new_hm = {} + new_hm[k] = EVAL(v, env) for k,v of ast + new_hm + else ast + +EVAL = (ast, env) -> + #console.log "EVAL:", printer._pr_str ast + if !types._list_Q ast then return eval_ast ast, env + if ast.length == 0 then return ast + + # apply list + [f, args...] = eval_ast ast, env + f(args...) + + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +repl_env = {} +rep = (str) -> PRINT(EVAL(READ(str), repl_env)) + +repl_env["+"] = (a,b) -> a+b +repl_env["-"] = (a,b) -> a-b +repl_env["*"] = (a,b) -> a*b +repl_env["/"] = (a,b) -> a/b + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? then console.log exc.stack + else console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/step3_env.coffee b/impls/coffee/step3_env.coffee index c8a17f45db..917f291873 100644 --- a/impls/coffee/step3_env.coffee +++ b/impls/coffee/step3_env.coffee @@ -1,66 +1,66 @@ -readline = require "./node_readline.coffee" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" -Env = require("./env.coffee").Env - -# read -READ = (str) -> reader.read_str str - -# eval -eval_ast = (ast, env) -> - if types._symbol_Q(ast) then env.get ast - else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) - else if types._vector_Q(ast) - types._vector(ast.map((a) -> EVAL(a, env))...) - else if types._hash_map_Q(ast) - new_hm = {} - new_hm[k] = EVAL(v, env) for k,v of ast - new_hm - else ast - -EVAL = (ast, env) -> - #console.log "EVAL:", printer._pr_str ast - if !types._list_Q ast then return eval_ast ast, env - if ast.length == 0 then return ast - - # apply list - [a0, a1, a2, a3] = ast - switch a0.name - when "def!" - env.set(a1, EVAL(a2, env)) - when "let*" - let_env = new Env(env) - for k,i in a1 when i %% 2 == 0 - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - EVAL(a2, let_env) - else - [f, args...] = eval_ast ast, env - f(args...) - - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -repl_env = new Env() -rep = (str) -> PRINT(EVAL(READ(str), repl_env)) - -repl_env.set types._symbol("+"), (a,b) -> a+b -repl_env.set types._symbol("-"), (a,b) -> a-b -repl_env.set types._symbol("*"), (a,b) -> a*b -repl_env.set types._symbol("/"), (a,b) -> a/b - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? then console.log exc.stack - else console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" +Env = require("./env.coffee").Env + +# read +READ = (str) -> reader.read_str str + +# eval +eval_ast = (ast, env) -> + if types._symbol_Q(ast) then env.get ast + else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) + else if types._vector_Q(ast) + types._vector(ast.map((a) -> EVAL(a, env))...) + else if types._hash_map_Q(ast) + new_hm = {} + new_hm[k] = EVAL(v, env) for k,v of ast + new_hm + else ast + +EVAL = (ast, env) -> + #console.log "EVAL:", printer._pr_str ast + if !types._list_Q ast then return eval_ast ast, env + if ast.length == 0 then return ast + + # apply list + [a0, a1, a2, a3] = ast + switch a0.name + when "def!" + env.set(a1, EVAL(a2, env)) + when "let*" + let_env = new Env(env) + for k,i in a1 when i %% 2 == 0 + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + EVAL(a2, let_env) + else + [f, args...] = eval_ast ast, env + f(args...) + + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +repl_env = new Env() +rep = (str) -> PRINT(EVAL(READ(str), repl_env)) + +repl_env.set types._symbol("+"), (a,b) -> a+b +repl_env.set types._symbol("-"), (a,b) -> a-b +repl_env.set types._symbol("*"), (a,b) -> a*b +repl_env.set types._symbol("/"), (a,b) -> a/b + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? then console.log exc.stack + else console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/step4_if_fn_do.coffee b/impls/coffee/step4_if_fn_do.coffee index 69c54cb8dc..ea76f6c5c5 100644 --- a/impls/coffee/step4_if_fn_do.coffee +++ b/impls/coffee/step4_if_fn_do.coffee @@ -1,79 +1,79 @@ -readline = require "./node_readline.coffee" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" -Env = require("./env.coffee").Env -core = require("./core.coffee") - -# read -READ = (str) -> reader.read_str str - -# eval -eval_ast = (ast, env) -> - if types._symbol_Q(ast) then env.get ast - else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) - else if types._vector_Q(ast) - types._vector(ast.map((a) -> EVAL(a, env))...) - else if types._hash_map_Q(ast) - new_hm = {} - new_hm[k] = EVAL(v, env) for k,v of ast - new_hm - else ast - -EVAL = (ast, env) -> - #console.log "EVAL:", printer._pr_str ast - if !types._list_Q ast then return eval_ast ast, env - if ast.length == 0 then return ast - - # apply list - [a0, a1, a2, a3] = ast - switch a0.name - when "def!" - env.set(a1, EVAL(a2, env)) - when "let*" - let_env = new Env(env) - for k,i in a1 when i %% 2 == 0 - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - EVAL(a2, let_env) - when "do" - el = eval_ast(ast[1..], env) - el[el.length-1] - when "if" - cond = EVAL(a1, env) - if cond == null or cond == false - if a3? then EVAL(a3, env) else null - else - EVAL(a2, env) - when "fn*" - (args...) -> EVAL(a2, new Env(env, a1, args)) - else - [f, args...] = eval_ast ast, env - f(args...) - - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -repl_env = new Env() -rep = (str) -> PRINT(EVAL(READ(str), repl_env)) - -# core.coffee: defined using CoffeeScript -repl_env.set types._symbol(k), v for k,v of core.ns - -# core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? then console.log exc.stack - else console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" +Env = require("./env.coffee").Env +core = require("./core.coffee") + +# read +READ = (str) -> reader.read_str str + +# eval +eval_ast = (ast, env) -> + if types._symbol_Q(ast) then env.get ast + else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) + else if types._vector_Q(ast) + types._vector(ast.map((a) -> EVAL(a, env))...) + else if types._hash_map_Q(ast) + new_hm = {} + new_hm[k] = EVAL(v, env) for k,v of ast + new_hm + else ast + +EVAL = (ast, env) -> + #console.log "EVAL:", printer._pr_str ast + if !types._list_Q ast then return eval_ast ast, env + if ast.length == 0 then return ast + + # apply list + [a0, a1, a2, a3] = ast + switch a0.name + when "def!" + env.set(a1, EVAL(a2, env)) + when "let*" + let_env = new Env(env) + for k,i in a1 when i %% 2 == 0 + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + EVAL(a2, let_env) + when "do" + el = eval_ast(ast[1..], env) + el[el.length-1] + when "if" + cond = EVAL(a1, env) + if cond == null or cond == false + if a3? then EVAL(a3, env) else null + else + EVAL(a2, env) + when "fn*" + (args...) -> EVAL(a2, new Env(env, a1, args)) + else + [f, args...] = eval_ast ast, env + f(args...) + + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +repl_env = new Env() +rep = (str) -> PRINT(EVAL(READ(str), repl_env)) + +# core.coffee: defined using CoffeeScript +repl_env.set types._symbol(k), v for k,v of core.ns + +# core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? then console.log exc.stack + else console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/step5_tco.coffee b/impls/coffee/step5_tco.coffee index dececcf185..eddeda4593 100644 --- a/impls/coffee/step5_tco.coffee +++ b/impls/coffee/step5_tco.coffee @@ -1,85 +1,85 @@ -readline = require "./node_readline.coffee" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" -Env = require("./env.coffee").Env -core = require("./core.coffee") - -# read -READ = (str) -> reader.read_str str - -# eval -eval_ast = (ast, env) -> - if types._symbol_Q(ast) then env.get ast - else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) - else if types._vector_Q(ast) - types._vector(ast.map((a) -> EVAL(a, env))...) - else if types._hash_map_Q(ast) - new_hm = {} - new_hm[k] = EVAL(v, env) for k,v of ast - new_hm - else ast - -EVAL = (ast, env) -> - loop - #console.log "EVAL:", printer._pr_str ast - if !types._list_Q ast then return eval_ast ast, env - if ast.length == 0 then return ast - - # apply list - [a0, a1, a2, a3] = ast - switch a0.name - when "def!" - return env.set(a1, EVAL(a2, env)) - when "let*" - let_env = new Env(env) - for k,i in a1 when i %% 2 == 0 - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - when "do" - eval_ast(ast[1..-2], env) - ast = ast[ast.length-1] - when "if" - cond = EVAL(a1, env) - if cond == null or cond == false - if a3? then ast = a3 else return null - else - ast = a2 - when "fn*" - return types._function(EVAL, a2, env, a1) - else - [f, args...] = eval_ast ast, env - if types._function_Q(f) - ast = f.__ast__ - env = f.__gen_env__(args) - else - return f(args...) - - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -repl_env = new Env() -rep = (str) -> PRINT(EVAL(READ(str), repl_env)) - -# core.coffee: defined using CoffeeScript -repl_env.set types._symbol(k), v for k,v of core.ns - -# core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? then console.log exc.stack - else console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" +Env = require("./env.coffee").Env +core = require("./core.coffee") + +# read +READ = (str) -> reader.read_str str + +# eval +eval_ast = (ast, env) -> + if types._symbol_Q(ast) then env.get ast + else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) + else if types._vector_Q(ast) + types._vector(ast.map((a) -> EVAL(a, env))...) + else if types._hash_map_Q(ast) + new_hm = {} + new_hm[k] = EVAL(v, env) for k,v of ast + new_hm + else ast + +EVAL = (ast, env) -> + loop + #console.log "EVAL:", printer._pr_str ast + if !types._list_Q ast then return eval_ast ast, env + if ast.length == 0 then return ast + + # apply list + [a0, a1, a2, a3] = ast + switch a0.name + when "def!" + return env.set(a1, EVAL(a2, env)) + when "let*" + let_env = new Env(env) + for k,i in a1 when i %% 2 == 0 + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + when "do" + eval_ast(ast[1..-2], env) + ast = ast[ast.length-1] + when "if" + cond = EVAL(a1, env) + if cond == null or cond == false + if a3? then ast = a3 else return null + else + ast = a2 + when "fn*" + return types._function(EVAL, a2, env, a1) + else + [f, args...] = eval_ast ast, env + if types._function_Q(f) + ast = f.__ast__ + env = f.__gen_env__(args) + else + return f(args...) + + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +repl_env = new Env() +rep = (str) -> PRINT(EVAL(READ(str), repl_env)) + +# core.coffee: defined using CoffeeScript +repl_env.set types._symbol(k), v for k,v of core.ns + +# core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? then console.log exc.stack + else console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/step6_file.coffee b/impls/coffee/step6_file.coffee index 23d764c4bb..1d606e28e3 100644 --- a/impls/coffee/step6_file.coffee +++ b/impls/coffee/step6_file.coffee @@ -1,93 +1,93 @@ -readline = require "./node_readline.coffee" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" -Env = require("./env.coffee").Env -core = require("./core.coffee") - -# read -READ = (str) -> reader.read_str str - -# eval -eval_ast = (ast, env) -> - if types._symbol_Q(ast) then env.get ast - else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) - else if types._vector_Q(ast) - types._vector(ast.map((a) -> EVAL(a, env))...) - else if types._hash_map_Q(ast) - new_hm = {} - new_hm[k] = EVAL(v, env) for k,v of ast - new_hm - else ast - -EVAL = (ast, env) -> - loop - #console.log "EVAL:", printer._pr_str ast - if !types._list_Q ast then return eval_ast ast, env - if ast.length == 0 then return ast - - # apply list - [a0, a1, a2, a3] = ast - switch a0.name - when "def!" - return env.set(a1, EVAL(a2, env)) - when "let*" - let_env = new Env(env) - for k,i in a1 when i %% 2 == 0 - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - when "do" - eval_ast(ast[1..-2], env) - ast = ast[ast.length-1] - when "if" - cond = EVAL(a1, env) - if cond == null or cond == false - if a3? then ast = a3 else return null - else - ast = a2 - when "fn*" - return types._function(EVAL, a2, env, a1) - else - [f, args...] = eval_ast ast, env - if types._function_Q(f) - ast = f.__ast__ - env = f.__gen_env__(args) - else - return f(args...) - - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -repl_env = new Env() -rep = (str) -> PRINT(EVAL(READ(str), repl_env)) - -# core.coffee: defined using CoffeeScript -repl_env.set types._symbol(k), v for k,v of core.ns -repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) -repl_env.set types._symbol('*ARGV*'), [] - -# core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - -if process? && process.argv.length > 2 - repl_env.set types._symbol('*ARGV*'), process.argv[3..] - rep('(load-file "' + process.argv[2] + '")') - process.exit 0 - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? then console.log exc.stack - else console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" +Env = require("./env.coffee").Env +core = require("./core.coffee") + +# read +READ = (str) -> reader.read_str str + +# eval +eval_ast = (ast, env) -> + if types._symbol_Q(ast) then env.get ast + else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) + else if types._vector_Q(ast) + types._vector(ast.map((a) -> EVAL(a, env))...) + else if types._hash_map_Q(ast) + new_hm = {} + new_hm[k] = EVAL(v, env) for k,v of ast + new_hm + else ast + +EVAL = (ast, env) -> + loop + #console.log "EVAL:", printer._pr_str ast + if !types._list_Q ast then return eval_ast ast, env + if ast.length == 0 then return ast + + # apply list + [a0, a1, a2, a3] = ast + switch a0.name + when "def!" + return env.set(a1, EVAL(a2, env)) + when "let*" + let_env = new Env(env) + for k,i in a1 when i %% 2 == 0 + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + when "do" + eval_ast(ast[1..-2], env) + ast = ast[ast.length-1] + when "if" + cond = EVAL(a1, env) + if cond == null or cond == false + if a3? then ast = a3 else return null + else + ast = a2 + when "fn*" + return types._function(EVAL, a2, env, a1) + else + [f, args...] = eval_ast ast, env + if types._function_Q(f) + ast = f.__ast__ + env = f.__gen_env__(args) + else + return f(args...) + + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +repl_env = new Env() +rep = (str) -> PRINT(EVAL(READ(str), repl_env)) + +# core.coffee: defined using CoffeeScript +repl_env.set types._symbol(k), v for k,v of core.ns +repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) +repl_env.set types._symbol('*ARGV*'), [] + +# core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + +if process? && process.argv.length > 2 + repl_env.set types._symbol('*ARGV*'), process.argv[3..] + rep('(load-file "' + process.argv[2] + '")') + process.exit 0 + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? then console.log exc.stack + else console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/step7_quote.coffee b/impls/coffee/step7_quote.coffee index 3cc8c2d788..256d027a49 100644 --- a/impls/coffee/step7_quote.coffee +++ b/impls/coffee/step7_quote.coffee @@ -1,115 +1,115 @@ -readline = require "./node_readline.coffee" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" -Env = require("./env.coffee").Env -core = require("./core.coffee") - -# read -READ = (str) -> reader.read_str str - -# eval -starts_with = (ast, sym) -> - types._list_Q(ast) && 0 - if starts_with(elt, 'splice-unquote') then [types._symbol('concat'), elt[1], accumulator] - else [types._symbol('cons'), quasiquote(elt), accumulator] - -quasiquote = (ast) -> - if starts_with(ast, 'unquote') then ast[1] - else if types._list_Q(ast) then ast.reduceRight(qq_iter, []) - else if types._vector_Q(ast) then [types._symbol('vec'), ast.reduceRight(qq_iter, [])] - else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast] - else ast - - - -eval_ast = (ast, env) -> - if types._symbol_Q(ast) then env.get ast - else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) - else if types._vector_Q(ast) - types._vector(ast.map((a) -> EVAL(a, env))...) - else if types._hash_map_Q(ast) - new_hm = {} - new_hm[k] = EVAL(v, env) for k,v of ast - new_hm - else ast - -EVAL = (ast, env) -> - loop - #console.log "EVAL:", printer._pr_str ast - if !types._list_Q ast then return eval_ast ast, env - if ast.length == 0 then return ast - - # apply list - [a0, a1, a2, a3] = ast - switch a0.name - when "def!" - return env.set(a1, EVAL(a2, env)) - when "let*" - let_env = new Env(env) - for k,i in a1 when i %% 2 == 0 - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - when "quote" - return a1 - when "quasiquoteexpand" - return quasiquote(a1) - when "quasiquote" - ast = quasiquote(a1) - when "do" - eval_ast(ast[1..-2], env) - ast = ast[ast.length-1] - when "if" - cond = EVAL(a1, env) - if cond == null or cond == false - if a3? then ast = a3 else return null - else - ast = a2 - when "fn*" - return types._function(EVAL, a2, env, a1) - else - [f, args...] = eval_ast ast, env - if types._function_Q(f) - ast = f.__ast__ - env = f.__gen_env__(args) - else - return f(args...) - - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -repl_env = new Env() -rep = (str) -> PRINT(EVAL(READ(str), repl_env)) - -# core.coffee: defined using CoffeeScript -repl_env.set types._symbol(k), v for k,v of core.ns -repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) -repl_env.set types._symbol('*ARGV*'), [] - -# core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - -if process? && process.argv.length > 2 - repl_env.set types._symbol('*ARGV*'), process.argv[3..] - rep('(load-file "' + process.argv[2] + '")') - process.exit 0 - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? then console.log exc.stack - else console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" +Env = require("./env.coffee").Env +core = require("./core.coffee") + +# read +READ = (str) -> reader.read_str str + +# eval +starts_with = (ast, sym) -> + types._list_Q(ast) && 0 + if starts_with(elt, 'splice-unquote') then [types._symbol('concat'), elt[1], accumulator] + else [types._symbol('cons'), quasiquote(elt), accumulator] + +quasiquote = (ast) -> + if starts_with(ast, 'unquote') then ast[1] + else if types._list_Q(ast) then ast.reduceRight(qq_iter, []) + else if types._vector_Q(ast) then [types._symbol('vec'), ast.reduceRight(qq_iter, [])] + else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast] + else ast + + + +eval_ast = (ast, env) -> + if types._symbol_Q(ast) then env.get ast + else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) + else if types._vector_Q(ast) + types._vector(ast.map((a) -> EVAL(a, env))...) + else if types._hash_map_Q(ast) + new_hm = {} + new_hm[k] = EVAL(v, env) for k,v of ast + new_hm + else ast + +EVAL = (ast, env) -> + loop + #console.log "EVAL:", printer._pr_str ast + if !types._list_Q ast then return eval_ast ast, env + if ast.length == 0 then return ast + + # apply list + [a0, a1, a2, a3] = ast + switch a0.name + when "def!" + return env.set(a1, EVAL(a2, env)) + when "let*" + let_env = new Env(env) + for k,i in a1 when i %% 2 == 0 + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + when "quote" + return a1 + when "quasiquoteexpand" + return quasiquote(a1) + when "quasiquote" + ast = quasiquote(a1) + when "do" + eval_ast(ast[1..-2], env) + ast = ast[ast.length-1] + when "if" + cond = EVAL(a1, env) + if cond == null or cond == false + if a3? then ast = a3 else return null + else + ast = a2 + when "fn*" + return types._function(EVAL, a2, env, a1) + else + [f, args...] = eval_ast ast, env + if types._function_Q(f) + ast = f.__ast__ + env = f.__gen_env__(args) + else + return f(args...) + + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +repl_env = new Env() +rep = (str) -> PRINT(EVAL(READ(str), repl_env)) + +# core.coffee: defined using CoffeeScript +repl_env.set types._symbol(k), v for k,v of core.ns +repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) +repl_env.set types._symbol('*ARGV*'), [] + +# core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + +if process? && process.argv.length > 2 + repl_env.set types._symbol('*ARGV*'), process.argv[3..] + rep('(load-file "' + process.argv[2] + '")') + process.exit 0 + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? then console.log exc.stack + else console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/step8_macros.coffee b/impls/coffee/step8_macros.coffee index 20d914623a..21668c60c5 100644 --- a/impls/coffee/step8_macros.coffee +++ b/impls/coffee/step8_macros.coffee @@ -1,135 +1,135 @@ -readline = require "./node_readline.coffee" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" -Env = require("./env.coffee").Env -core = require("./core.coffee") - -# read -READ = (str) -> reader.read_str str - -# eval -starts_with = (ast, sym) -> - types._list_Q(ast) && 0 - if starts_with(elt, 'splice-unquote') then [types._symbol('concat'), elt[1], accumulator] - else [types._symbol('cons'), quasiquote(elt), accumulator] - -quasiquote = (ast) -> - if starts_with(ast, 'unquote') then ast[1] - else if types._list_Q(ast) then ast.reduceRight(qq_iter, []) - else if types._vector_Q(ast) then [types._symbol('vec'), ast.reduceRight(qq_iter, [])] - else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast] - else ast - -is_macro_call = (ast, env) -> - return types._list_Q(ast) && types._symbol_Q(ast[0]) && - env.find(ast[0]) && env.get(ast[0]).__ismacro__ - -macroexpand = (ast, env) -> - while is_macro_call(ast, env) - ast = env.get(ast[0])(ast[1..]...) - ast - - - -eval_ast = (ast, env) -> - if types._symbol_Q(ast) then env.get ast - else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) - else if types._vector_Q(ast) - types._vector(ast.map((a) -> EVAL(a, env))...) - else if types._hash_map_Q(ast) - new_hm = {} - new_hm[k] = EVAL(v, env) for k,v of ast - new_hm - else ast - -EVAL = (ast, env) -> - loop - #console.log "EVAL:", printer._pr_str ast - if !types._list_Q ast then return eval_ast ast, env - - # apply list - ast = macroexpand ast, env - if !types._list_Q ast then return eval_ast ast, env - if ast.length == 0 then return ast - - [a0, a1, a2, a3] = ast - switch a0.name - when "def!" - return env.set(a1, EVAL(a2, env)) - when "let*" - let_env = new Env(env) - for k,i in a1 when i %% 2 == 0 - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - when "quote" - return a1 - when "quasiquoteexpand" - return quasiquote(a1) - when "quasiquote" - ast = quasiquote(a1) - when "defmacro!" - f = EVAL(a2, env) - f = types._clone(f) - f.__ismacro__ = true - return env.set(a1, f) - when "macroexpand" - return macroexpand(a1, env) - when "do" - eval_ast(ast[1..-2], env) - ast = ast[ast.length-1] - when "if" - cond = EVAL(a1, env) - if cond == null or cond == false - if a3? then ast = a3 else return null - else - ast = a2 - when "fn*" - return types._function(EVAL, a2, env, a1) - else - [f, args...] = eval_ast ast, env - if types._function_Q(f) - ast = f.__ast__ - env = f.__gen_env__(args) - else - return f(args...) - - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -repl_env = new Env() -rep = (str) -> PRINT(EVAL(READ(str), repl_env)) - -# core.coffee: defined using CoffeeScript -repl_env.set types._symbol(k), v for k,v of core.ns -repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) -repl_env.set types._symbol('*ARGV*'), [] - -# core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -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)))))))") - -if process? && process.argv.length > 2 - repl_env.set types._symbol('*ARGV*'), process.argv[3..] - rep('(load-file "' + process.argv[2] + '")') - process.exit 0 - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? then console.log exc.stack - else console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" +Env = require("./env.coffee").Env +core = require("./core.coffee") + +# read +READ = (str) -> reader.read_str str + +# eval +starts_with = (ast, sym) -> + types._list_Q(ast) && 0 + if starts_with(elt, 'splice-unquote') then [types._symbol('concat'), elt[1], accumulator] + else [types._symbol('cons'), quasiquote(elt), accumulator] + +quasiquote = (ast) -> + if starts_with(ast, 'unquote') then ast[1] + else if types._list_Q(ast) then ast.reduceRight(qq_iter, []) + else if types._vector_Q(ast) then [types._symbol('vec'), ast.reduceRight(qq_iter, [])] + else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast] + else ast + +is_macro_call = (ast, env) -> + return types._list_Q(ast) && types._symbol_Q(ast[0]) && + env.find(ast[0]) && env.get(ast[0]).__ismacro__ + +macroexpand = (ast, env) -> + while is_macro_call(ast, env) + ast = env.get(ast[0])(ast[1..]...) + ast + + + +eval_ast = (ast, env) -> + if types._symbol_Q(ast) then env.get ast + else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) + else if types._vector_Q(ast) + types._vector(ast.map((a) -> EVAL(a, env))...) + else if types._hash_map_Q(ast) + new_hm = {} + new_hm[k] = EVAL(v, env) for k,v of ast + new_hm + else ast + +EVAL = (ast, env) -> + loop + #console.log "EVAL:", printer._pr_str ast + if !types._list_Q ast then return eval_ast ast, env + + # apply list + ast = macroexpand ast, env + if !types._list_Q ast then return eval_ast ast, env + if ast.length == 0 then return ast + + [a0, a1, a2, a3] = ast + switch a0.name + when "def!" + return env.set(a1, EVAL(a2, env)) + when "let*" + let_env = new Env(env) + for k,i in a1 when i %% 2 == 0 + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + when "quote" + return a1 + when "quasiquoteexpand" + return quasiquote(a1) + when "quasiquote" + ast = quasiquote(a1) + when "defmacro!" + f = EVAL(a2, env) + f = types._clone(f) + f.__ismacro__ = true + return env.set(a1, f) + when "macroexpand" + return macroexpand(a1, env) + when "do" + eval_ast(ast[1..-2], env) + ast = ast[ast.length-1] + when "if" + cond = EVAL(a1, env) + if cond == null or cond == false + if a3? then ast = a3 else return null + else + ast = a2 + when "fn*" + return types._function(EVAL, a2, env, a1) + else + [f, args...] = eval_ast ast, env + if types._function_Q(f) + ast = f.__ast__ + env = f.__gen_env__(args) + else + return f(args...) + + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +repl_env = new Env() +rep = (str) -> PRINT(EVAL(READ(str), repl_env)) + +# core.coffee: defined using CoffeeScript +repl_env.set types._symbol(k), v for k,v of core.ns +repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) +repl_env.set types._symbol('*ARGV*'), [] + +# core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +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)))))))") + +if process? && process.argv.length > 2 + repl_env.set types._symbol('*ARGV*'), process.argv[3..] + rep('(load-file "' + process.argv[2] + '")') + process.exit 0 + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? then console.log exc.stack + else console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/step9_try.coffee b/impls/coffee/step9_try.coffee index e885bd9fda..87a2fb29bd 100644 --- a/impls/coffee/step9_try.coffee +++ b/impls/coffee/step9_try.coffee @@ -1,148 +1,148 @@ -readline = require "./node_readline.coffee" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" -Env = require("./env.coffee").Env -core = require("./core.coffee") - -# read -READ = (str) -> reader.read_str str - -# eval -starts_with = (ast, sym) -> - types._list_Q(ast) && 0 - if starts_with(elt, 'splice-unquote') then [types._symbol('concat'), elt[1], accumulator] - else [types._symbol('cons'), quasiquote(elt), accumulator] - -quasiquote = (ast) -> - if starts_with(ast, 'unquote') then ast[1] - else if types._list_Q(ast) then ast.reduceRight(qq_iter, []) - else if types._vector_Q(ast) then [types._symbol('vec'), ast.reduceRight(qq_iter, [])] - else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast] - else ast - -is_macro_call = (ast, env) -> - return types._list_Q(ast) && types._symbol_Q(ast[0]) && - env.find(ast[0]) && env.get(ast[0]).__ismacro__ - -macroexpand = (ast, env) -> - while is_macro_call(ast, env) - ast = env.get(ast[0])(ast[1..]...) - ast - - - -eval_ast = (ast, env) -> - if types._symbol_Q(ast) then env.get ast - else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) - else if types._vector_Q(ast) - types._vector(ast.map((a) -> EVAL(a, env))...) - else if types._hash_map_Q(ast) - new_hm = {} - new_hm[k] = EVAL(v, env) for k,v of ast - new_hm - else ast - -EVAL = (ast, env) -> - loop - #console.log "EVAL:", printer._pr_str ast - if !types._list_Q ast then return eval_ast ast, env - - # apply list - ast = macroexpand ast, env - if !types._list_Q ast then return eval_ast ast, env - if ast.length == 0 then return ast - - [a0, a1, a2, a3] = ast - switch a0.name - when "def!" - return env.set(a1, EVAL(a2, env)) - when "let*" - let_env = new Env(env) - for k,i in a1 when i %% 2 == 0 - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - when "quote" - return a1 - when "quasiquoteexpand" - return quasiquote(a1) - when "quasiquote" - ast = quasiquote(a1) - when "defmacro!" - f = EVAL(a2, env) - f = types._clone(f) - f.__ismacro__ = true - return env.set(a1, f) - when "macroexpand" - return macroexpand(a1, env) - when "try*" - try return EVAL(a1, env) - catch exc - if a2 && a2[0].name == "catch*" - if exc.object? then exc = exc.object - else exc = exc.message - return EVAL a2[2], new Env(env, [a2[1]], [exc]) - else - throw exc - when "do" - eval_ast(ast[1..-2], env) - ast = ast[ast.length-1] - when "if" - cond = EVAL(a1, env) - if cond == null or cond == false - if a3? then ast = a3 else return null - else - ast = a2 - when "fn*" - return types._function(EVAL, a2, env, a1) - else - [f, args...] = eval_ast ast, env - if types._function_Q(f) - ast = f.__ast__ - env = f.__gen_env__(args) - else - return f(args...) - - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -repl_env = new Env() -rep = (str) -> PRINT(EVAL(READ(str), repl_env)) - -# core.coffee: defined using CoffeeScript -repl_env.set types._symbol(k), v for k,v of core.ns -repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) -repl_env.set types._symbol('*ARGV*'), [] - -# core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -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)))))))") - -if process? && process.argv.length > 2 - repl_env.set types._symbol('*ARGV*'), process.argv[3..] - rep('(load-file "' + process.argv[2] + '")') - process.exit 0 - -# repl loop -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? - console.log exc.stack - else if exc.object? - console.log "Error:", printer._pr_str exc.object, true - else - console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" +Env = require("./env.coffee").Env +core = require("./core.coffee") + +# read +READ = (str) -> reader.read_str str + +# eval +starts_with = (ast, sym) -> + types._list_Q(ast) && 0 + if starts_with(elt, 'splice-unquote') then [types._symbol('concat'), elt[1], accumulator] + else [types._symbol('cons'), quasiquote(elt), accumulator] + +quasiquote = (ast) -> + if starts_with(ast, 'unquote') then ast[1] + else if types._list_Q(ast) then ast.reduceRight(qq_iter, []) + else if types._vector_Q(ast) then [types._symbol('vec'), ast.reduceRight(qq_iter, [])] + else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast] + else ast + +is_macro_call = (ast, env) -> + return types._list_Q(ast) && types._symbol_Q(ast[0]) && + env.find(ast[0]) && env.get(ast[0]).__ismacro__ + +macroexpand = (ast, env) -> + while is_macro_call(ast, env) + ast = env.get(ast[0])(ast[1..]...) + ast + + + +eval_ast = (ast, env) -> + if types._symbol_Q(ast) then env.get ast + else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) + else if types._vector_Q(ast) + types._vector(ast.map((a) -> EVAL(a, env))...) + else if types._hash_map_Q(ast) + new_hm = {} + new_hm[k] = EVAL(v, env) for k,v of ast + new_hm + else ast + +EVAL = (ast, env) -> + loop + #console.log "EVAL:", printer._pr_str ast + if !types._list_Q ast then return eval_ast ast, env + + # apply list + ast = macroexpand ast, env + if !types._list_Q ast then return eval_ast ast, env + if ast.length == 0 then return ast + + [a0, a1, a2, a3] = ast + switch a0.name + when "def!" + return env.set(a1, EVAL(a2, env)) + when "let*" + let_env = new Env(env) + for k,i in a1 when i %% 2 == 0 + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + when "quote" + return a1 + when "quasiquoteexpand" + return quasiquote(a1) + when "quasiquote" + ast = quasiquote(a1) + when "defmacro!" + f = EVAL(a2, env) + f = types._clone(f) + f.__ismacro__ = true + return env.set(a1, f) + when "macroexpand" + return macroexpand(a1, env) + when "try*" + try return EVAL(a1, env) + catch exc + if a2 && a2[0].name == "catch*" + if exc.object? then exc = exc.object + else exc = exc.message + return EVAL a2[2], new Env(env, [a2[1]], [exc]) + else + throw exc + when "do" + eval_ast(ast[1..-2], env) + ast = ast[ast.length-1] + when "if" + cond = EVAL(a1, env) + if cond == null or cond == false + if a3? then ast = a3 else return null + else + ast = a2 + when "fn*" + return types._function(EVAL, a2, env, a1) + else + [f, args...] = eval_ast ast, env + if types._function_Q(f) + ast = f.__ast__ + env = f.__gen_env__(args) + else + return f(args...) + + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +repl_env = new Env() +rep = (str) -> PRINT(EVAL(READ(str), repl_env)) + +# core.coffee: defined using CoffeeScript +repl_env.set types._symbol(k), v for k,v of core.ns +repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) +repl_env.set types._symbol('*ARGV*'), [] + +# core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +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)))))))") + +if process? && process.argv.length > 2 + repl_env.set types._symbol('*ARGV*'), process.argv[3..] + rep('(load-file "' + process.argv[2] + '")') + process.exit 0 + +# repl loop +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? + console.log exc.stack + else if exc.object? + console.log "Error:", printer._pr_str exc.object, true + else + console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/stepA_mal.coffee b/impls/coffee/stepA_mal.coffee index 504c81eaaf..00a482df4e 100644 --- a/impls/coffee/stepA_mal.coffee +++ b/impls/coffee/stepA_mal.coffee @@ -1,156 +1,156 @@ -readline = require "./node_readline.coffee" -types = require "./types.coffee" -reader = require "./reader.coffee" -printer = require "./printer.coffee" -Env = require("./env.coffee").Env -core = require("./core.coffee") - -# read -READ = (str) -> reader.read_str str - -# eval -starts_with = (ast, sym) -> - types._list_Q(ast) && 0 - if starts_with(elt, 'splice-unquote') then [types._symbol('concat'), elt[1], accumulator] - else [types._symbol('cons'), quasiquote(elt), accumulator] - -quasiquote = (ast) -> - if starts_with(ast, 'unquote') then ast[1] - else if types._list_Q(ast) then ast.reduceRight(qq_iter, []) - else if types._vector_Q(ast) then [types._symbol('vec'), ast.reduceRight(qq_iter, [])] - else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast] - else ast - -is_macro_call = (ast, env) -> - return types._list_Q(ast) && types._symbol_Q(ast[0]) && - env.find(ast[0]) && env.get(ast[0]).__ismacro__ - -macroexpand = (ast, env) -> - while is_macro_call(ast, env) - ast = env.get(ast[0])(ast[1..]...) - ast - - - -eval_ast = (ast, env) -> - if types._symbol_Q(ast) then env.get ast - else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) - else if types._vector_Q(ast) - types._vector(ast.map((a) -> EVAL(a, env))...) - else if types._hash_map_Q(ast) - new_hm = {} - new_hm[k] = EVAL(v, env) for k,v of ast - new_hm - else ast - -EVAL = (ast, env) -> - loop - #console.log "EVAL:", printer._pr_str ast - if !types._list_Q ast then return eval_ast ast, env - - # apply list - ast = macroexpand ast, env - if !types._list_Q ast then return eval_ast ast, env - if ast.length == 0 then return ast - - [a0, a1, a2, a3] = ast - switch a0.name - when "def!" - return env.set(a1, EVAL(a2, env)) - when "let*" - let_env = new Env(env) - for k,i in a1 when i %% 2 == 0 - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - when "quote" - return a1 - when "quasiquoteexpand" - return quasiquote(a1) - when "quasiquote" - ast = quasiquote(a1) - when "defmacro!" - f = EVAL(a2, env) - f = types._clone(f) - f.__ismacro__ = true - return env.set(a1, f) - when "macroexpand" - return macroexpand(a1, env) - when "try*" - try return EVAL(a1, env) - catch exc - if a2 && a2[0].name == "catch*" - if exc.object? then exc = exc.object - else exc = exc.message || exc.toString() - return EVAL a2[2], new Env(env, [a2[1]], [exc]) - else - throw exc - when "js*" - res = eval(a1.toString()) - return if typeof(res) == 'undefined' then null else res - when "." - el = eval_ast(ast[2..], env) - return eval(a1.toString())(el...) - when "do" - eval_ast(ast[1..-2], env) - ast = ast[ast.length-1] - when "if" - cond = EVAL(a1, env) - if cond == null or cond == false - if a3? then ast = a3 else return null - else - ast = a2 - when "fn*" - return types._function(EVAL, a2, env, a1) - else - [f, args...] = eval_ast ast, env - if types._function_Q(f) - ast = f.__ast__ - env = f.__gen_env__(args) - else - return f(args...) - - -# print -PRINT = (exp) -> printer._pr_str exp, true - -# repl -repl_env = new Env() -rep = (str) -> PRINT(EVAL(READ(str), repl_env)) - -# core.coffee: defined using CoffeeScript -repl_env.set types._symbol(k), v for k,v of core.ns -repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) -repl_env.set types._symbol('*ARGV*'), [] - -# core.mal: defined using the language itself -rep("(def! *host-language* \"CoffeeScript\")") -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -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)))))))") - -if process? && process.argv.length > 2 - repl_env.set types._symbol('*ARGV*'), process.argv[3..] - rep('(load-file "' + process.argv[2] + '")') - process.exit 0 - -# repl loop -rep("(println (str \"Mal [\" *host-language* \"]\"))") -while (line = readline.readline("user> ")) != null - continue if line == "" - try - console.log rep line - catch exc - continue if exc instanceof reader.BlankException - if exc.stack? and exc.stack.length > 2000 - console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) - else if exc.stack? - console.log exc.stack - else if exc.object? - console.log "Error:", printer._pr_str exc.object, true - else - console.log exc - -# vim: ts=2:sw=2 +readline = require "./node_readline.coffee" +types = require "./types.coffee" +reader = require "./reader.coffee" +printer = require "./printer.coffee" +Env = require("./env.coffee").Env +core = require("./core.coffee") + +# read +READ = (str) -> reader.read_str str + +# eval +starts_with = (ast, sym) -> + types._list_Q(ast) && 0 + if starts_with(elt, 'splice-unquote') then [types._symbol('concat'), elt[1], accumulator] + else [types._symbol('cons'), quasiquote(elt), accumulator] + +quasiquote = (ast) -> + if starts_with(ast, 'unquote') then ast[1] + else if types._list_Q(ast) then ast.reduceRight(qq_iter, []) + else if types._vector_Q(ast) then [types._symbol('vec'), ast.reduceRight(qq_iter, [])] + else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast] + else ast + +is_macro_call = (ast, env) -> + return types._list_Q(ast) && types._symbol_Q(ast[0]) && + env.find(ast[0]) && env.get(ast[0]).__ismacro__ + +macroexpand = (ast, env) -> + while is_macro_call(ast, env) + ast = env.get(ast[0])(ast[1..]...) + ast + + + +eval_ast = (ast, env) -> + if types._symbol_Q(ast) then env.get ast + else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env)) + else if types._vector_Q(ast) + types._vector(ast.map((a) -> EVAL(a, env))...) + else if types._hash_map_Q(ast) + new_hm = {} + new_hm[k] = EVAL(v, env) for k,v of ast + new_hm + else ast + +EVAL = (ast, env) -> + loop + #console.log "EVAL:", printer._pr_str ast + if !types._list_Q ast then return eval_ast ast, env + + # apply list + ast = macroexpand ast, env + if !types._list_Q ast then return eval_ast ast, env + if ast.length == 0 then return ast + + [a0, a1, a2, a3] = ast + switch a0.name + when "def!" + return env.set(a1, EVAL(a2, env)) + when "let*" + let_env = new Env(env) + for k,i in a1 when i %% 2 == 0 + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + when "quote" + return a1 + when "quasiquoteexpand" + return quasiquote(a1) + when "quasiquote" + ast = quasiquote(a1) + when "defmacro!" + f = EVAL(a2, env) + f = types._clone(f) + f.__ismacro__ = true + return env.set(a1, f) + when "macroexpand" + return macroexpand(a1, env) + when "try*" + try return EVAL(a1, env) + catch exc + if a2 && a2[0].name == "catch*" + if exc.object? then exc = exc.object + else exc = exc.message || exc.toString() + return EVAL a2[2], new Env(env, [a2[1]], [exc]) + else + throw exc + when "js*" + res = eval(a1.toString()) + return if typeof(res) == 'undefined' then null else res + when "." + el = eval_ast(ast[2..], env) + return eval(a1.toString())(el...) + when "do" + eval_ast(ast[1..-2], env) + ast = ast[ast.length-1] + when "if" + cond = EVAL(a1, env) + if cond == null or cond == false + if a3? then ast = a3 else return null + else + ast = a2 + when "fn*" + return types._function(EVAL, a2, env, a1) + else + [f, args...] = eval_ast ast, env + if types._function_Q(f) + ast = f.__ast__ + env = f.__gen_env__(args) + else + return f(args...) + + +# print +PRINT = (exp) -> printer._pr_str exp, true + +# repl +repl_env = new Env() +rep = (str) -> PRINT(EVAL(READ(str), repl_env)) + +# core.coffee: defined using CoffeeScript +repl_env.set types._symbol(k), v for k,v of core.ns +repl_env.set types._symbol('eval'), (ast) -> EVAL(ast, repl_env) +repl_env.set types._symbol('*ARGV*'), [] + +# core.mal: defined using the language itself +rep("(def! *host-language* \"CoffeeScript\")") +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +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)))))))") + +if process? && process.argv.length > 2 + repl_env.set types._symbol('*ARGV*'), process.argv[3..] + rep('(load-file "' + process.argv[2] + '")') + process.exit 0 + +# repl loop +rep("(println (str \"Mal [\" *host-language* \"]\"))") +while (line = readline.readline("user> ")) != null + continue if line == "" + try + console.log rep line + catch exc + continue if exc instanceof reader.BlankException + if exc.stack? and exc.stack.length > 2000 + console.log exc.stack.slice(0,1000) + "\n ..." + exc.stack.slice(-1000) + else if exc.stack? + console.log exc.stack + else if exc.object? + console.log "Error:", printer._pr_str exc.object, true + else + console.log exc + +# vim: ts=2:sw=2 diff --git a/impls/coffee/tests/step5_tco.mal b/impls/coffee/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/coffee/tests/step5_tco.mal +++ b/impls/coffee/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/coffee/tests/stepA_mal.mal b/impls/coffee/tests/stepA_mal.mal index 86699978dd..33ce24ca00 100644 --- a/impls/coffee/tests/stepA_mal.mal +++ b/impls/coffee/tests/stepA_mal.mal @@ -1,24 +1,24 @@ -;; Testing basic bash interop - -(js* "7") -;=>7 - -(js* "'7'") -;=>"7" - -(js* "[7,8,9]") -;=>(7 8 9) - -(js* "console.log('hello');") -;/hello -;=>nil - -(js* "foo=8;") -(js* "foo;") -;=>8 - -(js* "['a','b','c'].map(function(x){return 'X'+x+'Y'}).join(' ')") -;=>"XaY XbY XcY" - -(js* "[1,2,3].map(function(x){return 1+x})") -;=>(2 3 4) +;; Testing basic bash interop + +(js* "7") +;=>7 + +(js* "'7'") +;=>"7" + +(js* "[7,8,9]") +;=>(7 8 9) + +(js* "console.log('hello');") +;/hello +;=>nil + +(js* "foo=8;") +(js* "foo;") +;=>8 + +(js* "['a','b','c'].map(function(x){return 'X'+x+'Y'}).join(' ')") +;=>"XaY XbY XcY" + +(js* "[1,2,3].map(function(x){return 1+x})") +;=>(2 3 4) diff --git a/impls/coffee/types.coffee b/impls/coffee/types.coffee index 5252281762..042f9d8cf4 100644 --- a/impls/coffee/types.coffee +++ b/impls/coffee/types.coffee @@ -1,123 +1,123 @@ -Env = require("./env.coffee").Env - -E = exports - -# General functions -E._obj_type = _obj_type = (obj) -> - if _symbol_Q(obj) then 'symbol' - else if _list_Q(obj) then 'list' - else if _vector_Q(obj) then 'vector' - else if _hash_map_Q(obj) then 'hash-map' - else if _nil_Q(obj) then 'nil' - else if _true_Q(obj) then 'true' - else if _false_Q(obj) then 'false' - else if _atom_Q(obj) then 'atom' - else - switch typeof obj - when 'number' then 'number' - when 'function' then 'function' - when 'string' - if obj[0] == '\u029e' then 'keyword' else 'string' - else throw new Error "Unknown type '" + typeof(obj) + "'" - -E._sequential_Q = _sequential_Q = (o) -> _list_Q(o) or _vector_Q(o) - -E._equal_Q = _equal_Q = (a,b) -> - [ota, otb] = [_obj_type(a), _obj_type(b)] - if !(ota == otb or (_sequential_Q(a) && _sequential_Q(b))) - return false - switch (ota) - when 'symbol' then a.name == b.name - when 'list', 'vector' - return false if a.length != b.length - for av,i in a - return false if !_equal_Q(av, b[i]) - true - when 'hash-map' - akeys = (key for key of a) - bkeys = (key for key of b) - return false if akeys.length != bkeys.length - for akey,i in akeys - return false if !_equal_Q(a[akey], b[akey]) - true - else a == b - -E._clone = _clone = (obj) -> - switch _obj_type(obj) - when 'list' then obj[0..-1] - when 'vector' then _vector(obj[0..-1]...) - when 'hash-map' - new_obj = {} - new_obj[k] = v for k,v of obj - new_obj - when 'function' - new_obj = (args...) -> obj(args...) - new_obj[k] = v for k,v of obj - new_obj - else throw new Error "clone called on non-collection" + _obj_type(obj) - - -# Scalars -E._nil_Q = _nil_Q = (o) -> o == null -E._true_Q = _true_Q = (o) -> o == true -E._false_Q = _false_Q = (o) -> o == false -E._string_Q = _string_Q = (o) -> _obj_type(o) == 'string' - -# Symbols -class Symbol - constructor: (@name) -> -E._symbol = (str) -> new Symbol str -E._symbol_Q = _symbol_Q = (o) -> o instanceof Symbol - -# Keywords -E._keyword = _keyword = (o) -> - _keyword_Q(o) && o || ("\u029e" + o) -E._keyword_Q = _keyword_Q = (o) -> - typeof o == 'string' && o[0] == "\u029e" - -# Functions -E._function = (evalfn, ast, env, params) -> - fn = (args...) -> evalfn(ast, new Env(env, params, args)) - fn.__ast__ = ast - fn.__gen_env__ = (args) -> new Env(env, params, args) - fn.__ismacro__ = false - fn -E._function_Q = _function_Q = (o) -> !!o.__ast__ -E._macro_Q = _macro_Q = (o) -> _function_Q(o) and o.__ismacro__ - -# Lists -E._list_Q = _list_Q = (o) -> Array.isArray(o) && !o.__isvector__ - -# Vectors -E._vector = _vector = (args...) -> - v = args - v.__isvector__ = true - v -E._vector_Q = _vector_Q = (o) -> Array.isArray(o) && !!o.__isvector__ - -# Hash Maps -E._hash_map = (args...) -> - args = [{}].concat args - _assoc_BANG(args...) -E._assoc_BANG = _assoc_BANG = (hm, args...) -> - if args.length %% 2 == 1 - throw new Error "Odd number of hash map arguments" - hm[k] = args[i+1] for k, i in args when i %% 2 == 0 - hm -E._dissoc_BANG = (hm, args...) -> - delete hm[k] for k, i in args - hm -E._hash_map_Q = _hash_map_Q = (o) -> - typeof o == "object" && !Array.isArray(o) && - !(o == null) && - !(o instanceof Symbol) && - !(o instanceof Atom) - - -# Atoms -class Atom - constructor: (@val) -> -E._atom = (val) -> new Atom val -E._atom_Q = _atom_Q = (o) -> o instanceof Atom - -# vim: ts=2:sw=2 +Env = require("./env.coffee").Env + +E = exports + +# General functions +E._obj_type = _obj_type = (obj) -> + if _symbol_Q(obj) then 'symbol' + else if _list_Q(obj) then 'list' + else if _vector_Q(obj) then 'vector' + else if _hash_map_Q(obj) then 'hash-map' + else if _nil_Q(obj) then 'nil' + else if _true_Q(obj) then 'true' + else if _false_Q(obj) then 'false' + else if _atom_Q(obj) then 'atom' + else + switch typeof obj + when 'number' then 'number' + when 'function' then 'function' + when 'string' + if obj[0] == '\u029e' then 'keyword' else 'string' + else throw new Error "Unknown type '" + typeof(obj) + "'" + +E._sequential_Q = _sequential_Q = (o) -> _list_Q(o) or _vector_Q(o) + +E._equal_Q = _equal_Q = (a,b) -> + [ota, otb] = [_obj_type(a), _obj_type(b)] + if !(ota == otb or (_sequential_Q(a) && _sequential_Q(b))) + return false + switch (ota) + when 'symbol' then a.name == b.name + when 'list', 'vector' + return false if a.length != b.length + for av,i in a + return false if !_equal_Q(av, b[i]) + true + when 'hash-map' + akeys = (key for key of a) + bkeys = (key for key of b) + return false if akeys.length != bkeys.length + for akey,i in akeys + return false if !_equal_Q(a[akey], b[akey]) + true + else a == b + +E._clone = _clone = (obj) -> + switch _obj_type(obj) + when 'list' then obj[0..-1] + when 'vector' then _vector(obj[0..-1]...) + when 'hash-map' + new_obj = {} + new_obj[k] = v for k,v of obj + new_obj + when 'function' + new_obj = (args...) -> obj(args...) + new_obj[k] = v for k,v of obj + new_obj + else throw new Error "clone called on non-collection" + _obj_type(obj) + + +# Scalars +E._nil_Q = _nil_Q = (o) -> o == null +E._true_Q = _true_Q = (o) -> o == true +E._false_Q = _false_Q = (o) -> o == false +E._string_Q = _string_Q = (o) -> _obj_type(o) == 'string' + +# Symbols +class Symbol + constructor: (@name) -> +E._symbol = (str) -> new Symbol str +E._symbol_Q = _symbol_Q = (o) -> o instanceof Symbol + +# Keywords +E._keyword = _keyword = (o) -> + _keyword_Q(o) && o || ("\u029e" + o) +E._keyword_Q = _keyword_Q = (o) -> + typeof o == 'string' && o[0] == "\u029e" + +# Functions +E._function = (evalfn, ast, env, params) -> + fn = (args...) -> evalfn(ast, new Env(env, params, args)) + fn.__ast__ = ast + fn.__gen_env__ = (args) -> new Env(env, params, args) + fn.__ismacro__ = false + fn +E._function_Q = _function_Q = (o) -> !!o.__ast__ +E._macro_Q = _macro_Q = (o) -> _function_Q(o) and o.__ismacro__ + +# Lists +E._list_Q = _list_Q = (o) -> Array.isArray(o) && !o.__isvector__ + +# Vectors +E._vector = _vector = (args...) -> + v = args + v.__isvector__ = true + v +E._vector_Q = _vector_Q = (o) -> Array.isArray(o) && !!o.__isvector__ + +# Hash Maps +E._hash_map = (args...) -> + args = [{}].concat args + _assoc_BANG(args...) +E._assoc_BANG = _assoc_BANG = (hm, args...) -> + if args.length %% 2 == 1 + throw new Error "Odd number of hash map arguments" + hm[k] = args[i+1] for k, i in args when i %% 2 == 0 + hm +E._dissoc_BANG = (hm, args...) -> + delete hm[k] for k, i in args + hm +E._hash_map_Q = _hash_map_Q = (o) -> + typeof o == "object" && !Array.isArray(o) && + !(o == null) && + !(o instanceof Symbol) && + !(o instanceof Atom) + + +# Atoms +class Atom + constructor: (@val) -> +E._atom = (val) -> new Atom val +E._atom_Q = _atom_Q = (o) -> o instanceof Atom + +# vim: ts=2:sw=2 diff --git a/impls/common-lisp/Dockerfile b/impls/common-lisp/Dockerfile index 447f413bbb..5458d07863 100644 --- a/impls/common-lisp/Dockerfile +++ b/impls/common-lisp/Dockerfile @@ -1,51 +1,51 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install git, make -RUN apt-get -y install git make - -# Install sbcl -RUN apt-get -y install sbcl - -# Install cl-asdf (CLISP does not seem to come with it) -RUN apt-get -y install cl-launch cl-asdf - -RUN cd /tmp && \ - git clone https://gitlab.common-lisp.net/xcvb/cl-launch.git && \ - cd cl-launch && \ - make install - -# Install wget needed to install quicklisp -RUN apt-get -y install wget - -# Install quicklisp -RUN HOME=/ && \ - cd /tmp && \ - wget https://beta.quicklisp.org/quicklisp.lisp && \ - sbcl --load quicklisp.lisp --quit --eval '(quicklisp-quickstart:install)' --eval '(ql-util:without-prompting (ql:add-to-init-file))' - -RUN chmod -R a+rwx /quicklisp -RUN chmod a+rwx /.sbclrc - -RUN mkdir -p /.cache -RUN chmod -R a+rwx /.cache +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install git, make +RUN apt-get -y install git make + +# Install sbcl +RUN apt-get -y install sbcl + +# Install cl-asdf (CLISP does not seem to come with it) +RUN apt-get -y install cl-launch cl-asdf + +RUN cd /tmp && \ + git clone https://gitlab.common-lisp.net/xcvb/cl-launch.git && \ + cd cl-launch && \ + make install + +# Install wget needed to install quicklisp +RUN apt-get -y install wget + +# Install quicklisp +RUN HOME=/ && \ + cd /tmp && \ + wget https://beta.quicklisp.org/quicklisp.lisp && \ + sbcl --load quicklisp.lisp --quit --eval '(quicklisp-quickstart:install)' --eval '(ql-util:without-prompting (ql:add-to-init-file))' + +RUN chmod -R a+rwx /quicklisp +RUN chmod a+rwx /.sbclrc + +RUN mkdir -p /.cache +RUN chmod -R a+rwx /.cache diff --git a/impls/common-lisp/Makefile b/impls/common-lisp/Makefile index 7572f4f878..df6283b402 100644 --- a/impls/common-lisp/Makefile +++ b/impls/common-lisp/Makefile @@ -1,67 +1,67 @@ -# Helper functions -define record_lisp - $(shell (test -f "hist/$(1)_impl" && grep -q $(2) "hist/$(1)_impl") || echo $(2) > "hist/$(1)_impl") -endef - -define steps - $(if $(MAKECMDGOALS),\ - $(if $(findstring all,$(MAKECMDGOALS)),\ - stepA_mal,\ - $(filter step%, $(MAKECMDGOALS))),\ - stepA_mal) -endef - -LISP ?= sbcl -ABCL ?= abcl -MKCL ?= mkcl - -# TODO: In theory cl-launch should be able to build standalone executable using -# MKCL unfortunately the executable crashes on startup -STANDALONE_EXE = sbcl clisp ccl ecl cmucl - -ROOT_DIR := $(shell dirname $(realpath $(lastword $(MAKEFILE_LIST)))) - -# Record the Common Lisp implementation used for all steps built in this -# invocation This is used in the targets to rebuild the step if the -# implementation changes -$(foreach step, $(call steps), $(call record_lisp,$(patsubst step%,%,$(step)),$(LISP))) - -.PRECIOUS: hist/%_impl - -all : stepA_mal - -hist/%_impl: ; - -# CL_LAUNCH_VERSION is only defined while building it. We change to the -# directory of the CL_LAUNCH_FILE in --wrap script so that the script can find the dumped -# image even if invoked from some directory different from where it -# currently resides -step% : src/step%.lisp src/utils.lisp src/types.lisp src/env.lisp src/printer.lisp src/reader.lisp src/core.lisp hist/%_impl - -ifeq ($(LISP),clisp) - @echo "==============================================================" - @echo "WARNING: This build might fail since GNU Clisp does not have bundled version of asdf (yet)" - @echo "Please do something like below to make it work" - @echo "(mkdir -p ~/common-lisp/ && cd ~/common-lisp && git clone -b release https://gitlab.common-lisp.net/asdf/asdf.git && cd asdf && make)" - @echo "==============================================================" -endif - -ifneq ($(filter $(LISP),$(STANDALONE_EXE)),) - cl-launch --wrap 'if [ -z "$$CL_LAUNCH_VERSION" ] ; then cd "$$(dirname $$CL_LAUNCH_FILE)" ; fi' --verbose --lisp $(LISP) --source-registry $(ROOT_DIR) --system $@ --dump '!' -o $@ --entry 'mal:main' -else ifeq ($(LISP),abcl) - echo -n '#!/bin/sh\ncd `dirname $$0` ; $(ABCL) --noinform --noinit --nosystem --load run-abcl.lisp -- $@ $$@' > $@ - chmod +x $@ -else ifeq ($(LISP),mkcl) - $(MKCL) -eval '(progn (require "asdf") (push *default-pathname-defaults* asdf:*central-registry*) (asdf:load-system "$@") (quit))' - echo -n '#!/bin/sh\ncd `dirname $$0` ; $(MKCL) -q -load run-mkcl.lisp -- $@ $$@' > $@ - chmod +x $@ -else ifeq ($(LISP),allegro) - cl-launch --wrap 'if [ -z "$$CL_LAUNCH_VERSION" ] ; then cd "$$(dirname $$CL_LAUNCH_FILE)" ; fi' --verbose --lisp $(LISP) --source-registry $(ROOT_DIR) --system $@ --dump images/$@.$(LISP).image -o $@ --entry 'mal:main' -else - @echo "Unsupported Lisp implementation $(LISP)" - @exit 1 -endif - -clean: - find . -maxdepth 1 -name 'step*' -executable -delete - rm -f *.lib *.fas[l] images/* hist/*_impl +# Helper functions +define record_lisp + $(shell (test -f "hist/$(1)_impl" && grep -q $(2) "hist/$(1)_impl") || echo $(2) > "hist/$(1)_impl") +endef + +define steps + $(if $(MAKECMDGOALS),\ + $(if $(findstring all,$(MAKECMDGOALS)),\ + stepA_mal,\ + $(filter step%, $(MAKECMDGOALS))),\ + stepA_mal) +endef + +LISP ?= sbcl +ABCL ?= abcl +MKCL ?= mkcl + +# TODO: In theory cl-launch should be able to build standalone executable using +# MKCL unfortunately the executable crashes on startup +STANDALONE_EXE = sbcl clisp ccl ecl cmucl + +ROOT_DIR := $(shell dirname $(realpath $(lastword $(MAKEFILE_LIST)))) + +# Record the Common Lisp implementation used for all steps built in this +# invocation This is used in the targets to rebuild the step if the +# implementation changes +$(foreach step, $(call steps), $(call record_lisp,$(patsubst step%,%,$(step)),$(LISP))) + +.PRECIOUS: hist/%_impl + +all : stepA_mal + +hist/%_impl: ; + +# CL_LAUNCH_VERSION is only defined while building it. We change to the +# directory of the CL_LAUNCH_FILE in --wrap script so that the script can find the dumped +# image even if invoked from some directory different from where it +# currently resides +step% : src/step%.lisp src/utils.lisp src/types.lisp src/env.lisp src/printer.lisp src/reader.lisp src/core.lisp hist/%_impl + +ifeq ($(LISP),clisp) + @echo "==============================================================" + @echo "WARNING: This build might fail since GNU Clisp does not have bundled version of asdf (yet)" + @echo "Please do something like below to make it work" + @echo "(mkdir -p ~/common-lisp/ && cd ~/common-lisp && git clone -b release https://gitlab.common-lisp.net/asdf/asdf.git && cd asdf && make)" + @echo "==============================================================" +endif + +ifneq ($(filter $(LISP),$(STANDALONE_EXE)),) + cl-launch --wrap 'if [ -z "$$CL_LAUNCH_VERSION" ] ; then cd "$$(dirname $$CL_LAUNCH_FILE)" ; fi' --verbose --lisp $(LISP) --source-registry $(ROOT_DIR) --system $@ --dump '!' -o $@ --entry 'mal:main' +else ifeq ($(LISP),abcl) + echo -n '#!/bin/sh\ncd `dirname $$0` ; $(ABCL) --noinform --noinit --nosystem --load run-abcl.lisp -- $@ $$@' > $@ + chmod +x $@ +else ifeq ($(LISP),mkcl) + $(MKCL) -eval '(progn (require "asdf") (push *default-pathname-defaults* asdf:*central-registry*) (asdf:load-system "$@") (quit))' + echo -n '#!/bin/sh\ncd `dirname $$0` ; $(MKCL) -q -load run-mkcl.lisp -- $@ $$@' > $@ + chmod +x $@ +else ifeq ($(LISP),allegro) + cl-launch --wrap 'if [ -z "$$CL_LAUNCH_VERSION" ] ; then cd "$$(dirname $$CL_LAUNCH_FILE)" ; fi' --verbose --lisp $(LISP) --source-registry $(ROOT_DIR) --system $@ --dump images/$@.$(LISP).image -o $@ --entry 'mal:main' +else + @echo "Unsupported Lisp implementation $(LISP)" + @exit 1 +endif + +clean: + find . -maxdepth 1 -name 'step*' -executable -delete + rm -f *.lib *.fas[l] images/* hist/*_impl diff --git a/impls/common-lisp/README.org b/impls/common-lisp/README.org index b29f73a7fa..7ba7631474 100644 --- a/impls/common-lisp/README.org +++ b/impls/common-lisp/README.org @@ -1,100 +1,100 @@ -* Implementation of MAL in Common Lisp - -** Introduction - -This is a portable implementation of MAL in Common Lisp. It has been tested to -work with following Common Lisp implementations - -- Steel Bank Common Lisp [[http://sbcl.org/]] -- Clozure Common Lisp [[http://ccl.clozure.com/]] -- CMU Common Lisp [[https://www.cons.org/cmucl/]] -- GNU CLISP [[http://www.clisp.org/]] -- Embeddable Common Lisp [[https://common-lisp.net/project/ecl/]] -- ManKai Common Lisp https://common-lisp.net/project/mkcl/ -- Allegro CL [[http://franz.com/products/allegro-common-lisp/]] -- Armed Bear Common Lisp [[http://abcl.org/]] - -[[http://www.cliki.net/cl-launch][cl-launch]] to build executable/wrapper scripts for most of the above implementations. - -** Dependencies - -- cl-launch - For building command line executable scripts. See [[http://www.cliki.net/cl-launch][cl-launch]] - -- quicklisp - For installing dependencies. See [[https://www.quicklisp.org/beta/][quicklisp]] - -- readline - For readline integration. You can install it on Ubuntu using apt the package - is ~libreadline-dev~. If you wish to run the implementation using Allegro CL, - you will also have to install the 32 bit version of readline - (~lib32readline-dev~ on Ubuntu) - -- (Optional) asdf - This is needed if you want to run the implementation using GNU CLISP, since - GNU CLISP does not ship with ~asdf~ and ~cl-launch~ depends on it. You can - install it on Ubuntu using apt the package is ~cl-asdf~ - -** Running using different implementations - -By default the MAL is built using ~sbcl~, you can control this using ~LISP~ -environment variable. The variable should be set to the cl-launch "nickname" for -implementation. The nicknames that work currently are - -|------------------------+----------| -| Implementation | Nickname | -|------------------------+----------| -| Steel Bank Common Lisp | sbcl | -| Clozure Common Lisp | ccl | -| CMU Common Lisp | cmucl | -| GNU CLISP | clisp | -| Embeddable Common Lisp | ecl | -| ManKai Common Lisp | mkcl | -| Allegro CL | allegro | -| Armed Bear Common Lisp | abcl | -|------------------------+----------| - -For example to build with GNU CLISP, you need to do the following - -#+BEGIN_SRC sh - cd common-lisp ; LISP=clisp make -#+END_SRC - -You can control the implementation binary used for the build using environment -variables. For a given implementation nickname, the environment variable will -be the capitalization of the given nickname. - -|------------------------+-------------| -| Implementation | Binary Path | -|------------------------+-------------| -| Steel Bank Common Lisp | SBCL | -| Clozure Common Lisp | CCL | -| CMU Common Lisp | CMUCL | -| GNU CLISP | CLISP | -| Embeddable Common Lisp | ECL | -| ManKai Common Lisp | MKCL | -| Allegro CL | ALLEGRO | -| Armed Bear Common Lisp | ABCL | -|------------------------+-------------| - -For example to build MAL with Clozure CL installed in -~\~/.roswell/impls/x86-64/linux/ccl-bin/1.11/lx86cl64~, you need to do the -following - -#+BEGIN_SRC sh - cd common-lisp ; LISP=ccl CCL=~/.roswell/impls/x86-64/linux/ccl-bin/1.11/lx86cl64 make -#+END_SRC - -You can use the variables ~*cl-implementation*~ and ~*cl-version*~ can be used -to in MAL REPL to check the Common Lisp implementation and the version used for -building it. - -** Interop - -There is some basic interop in the form ~cl-eval~ which takes a string and -evaluates it as Common Lisp code, the result is returned in form of a MAL value, -as such you are limited to code that produces values that have MAL counterparts. - -** Known Issues - ABCL takes a long to boot as such it needs to be run with ~TEST_OPTS~ set to - ~--start-timeout 120~ +* Implementation of MAL in Common Lisp + +** Introduction + +This is a portable implementation of MAL in Common Lisp. It has been tested to +work with following Common Lisp implementations + +- Steel Bank Common Lisp [[http://sbcl.org/]] +- Clozure Common Lisp [[http://ccl.clozure.com/]] +- CMU Common Lisp [[https://www.cons.org/cmucl/]] +- GNU CLISP [[http://www.clisp.org/]] +- Embeddable Common Lisp [[https://common-lisp.net/project/ecl/]] +- ManKai Common Lisp https://common-lisp.net/project/mkcl/ +- Allegro CL [[http://franz.com/products/allegro-common-lisp/]] +- Armed Bear Common Lisp [[http://abcl.org/]] + +[[http://www.cliki.net/cl-launch][cl-launch]] to build executable/wrapper scripts for most of the above implementations. + +** Dependencies + +- cl-launch + For building command line executable scripts. See [[http://www.cliki.net/cl-launch][cl-launch]] + +- quicklisp + For installing dependencies. See [[https://www.quicklisp.org/beta/][quicklisp]] + +- readline + For readline integration. You can install it on Ubuntu using apt the package + is ~libreadline-dev~. If you wish to run the implementation using Allegro CL, + you will also have to install the 32 bit version of readline + (~lib32readline-dev~ on Ubuntu) + +- (Optional) asdf + This is needed if you want to run the implementation using GNU CLISP, since + GNU CLISP does not ship with ~asdf~ and ~cl-launch~ depends on it. You can + install it on Ubuntu using apt the package is ~cl-asdf~ + +** Running using different implementations + +By default the MAL is built using ~sbcl~, you can control this using ~LISP~ +environment variable. The variable should be set to the cl-launch "nickname" for +implementation. The nicknames that work currently are + +|------------------------+----------| +| Implementation | Nickname | +|------------------------+----------| +| Steel Bank Common Lisp | sbcl | +| Clozure Common Lisp | ccl | +| CMU Common Lisp | cmucl | +| GNU CLISP | clisp | +| Embeddable Common Lisp | ecl | +| ManKai Common Lisp | mkcl | +| Allegro CL | allegro | +| Armed Bear Common Lisp | abcl | +|------------------------+----------| + +For example to build with GNU CLISP, you need to do the following + +#+BEGIN_SRC sh + cd common-lisp ; LISP=clisp make +#+END_SRC + +You can control the implementation binary used for the build using environment +variables. For a given implementation nickname, the environment variable will +be the capitalization of the given nickname. + +|------------------------+-------------| +| Implementation | Binary Path | +|------------------------+-------------| +| Steel Bank Common Lisp | SBCL | +| Clozure Common Lisp | CCL | +| CMU Common Lisp | CMUCL | +| GNU CLISP | CLISP | +| Embeddable Common Lisp | ECL | +| ManKai Common Lisp | MKCL | +| Allegro CL | ALLEGRO | +| Armed Bear Common Lisp | ABCL | +|------------------------+-------------| + +For example to build MAL with Clozure CL installed in +~\~/.roswell/impls/x86-64/linux/ccl-bin/1.11/lx86cl64~, you need to do the +following + +#+BEGIN_SRC sh + cd common-lisp ; LISP=ccl CCL=~/.roswell/impls/x86-64/linux/ccl-bin/1.11/lx86cl64 make +#+END_SRC + +You can use the variables ~*cl-implementation*~ and ~*cl-version*~ can be used +to in MAL REPL to check the Common Lisp implementation and the version used for +building it. + +** Interop + +There is some basic interop in the form ~cl-eval~ which takes a string and +evaluates it as Common Lisp code, the result is returned in form of a MAL value, +as such you are limited to code that produces values that have MAL counterparts. + +** Known Issues + ABCL takes a long to boot as such it needs to be run with ~TEST_OPTS~ set to + ~--start-timeout 120~ diff --git a/impls/common-lisp/fake-readline.lisp b/impls/common-lisp/fake-readline.lisp index 9895c6ed5b..5961767084 100644 --- a/impls/common-lisp/fake-readline.lisp +++ b/impls/common-lisp/fake-readline.lisp @@ -1,18 +1,18 @@ -;; For some reason MKCL fails to find libreadline.so as a result cl-readline -;; fails. To avoid conditionals in the code we fake the cl-readline interface -;; and use it in asdf definitions when running under MKCL -(defpackage :cl-readline - (:nicknames :rl) - (:use :common-lisp)) - -(in-package :cl-readline) - -(defun readline (&keys prompt already-prompted num-chars - erase-empty-line add-history novelty-check) - (declare (ignorable ignored)) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun register-function (&rest ignored) - (declare (ignorable ignored))) +;; For some reason MKCL fails to find libreadline.so as a result cl-readline +;; fails. To avoid conditionals in the code we fake the cl-readline interface +;; and use it in asdf definitions when running under MKCL +(defpackage :cl-readline + (:nicknames :rl) + (:use :common-lisp)) + +(in-package :cl-readline) + +(defun readline (&keys prompt already-prompted num-chars + erase-empty-line add-history novelty-check) + (declare (ignorable ignored)) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun register-function (&rest ignored) + (declare (ignorable ignored))) diff --git a/impls/common-lisp/run b/impls/common-lisp/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/common-lisp/run +++ b/impls/common-lisp/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/common-lisp/run-abcl.lisp b/impls/common-lisp/run-abcl.lisp index 73b869a420..6e1d691d20 100644 --- a/impls/common-lisp/run-abcl.lisp +++ b/impls/common-lisp/run-abcl.lisp @@ -1,10 +1,10 @@ -(require 'asdf) -(push *default-pathname-defaults* asdf:*central-registry*) - -;; Suppress compilation output -(let ((*error-output* (make-broadcast-stream)) - (*standard-output* (make-broadcast-stream))) - (asdf:load-system (car ext:*command-line-argument-list*) :verbose nil)) - -(mal:main (cdr ext:*command-line-argument-list*)) -(cl-user::quit) +(require 'asdf) +(push *default-pathname-defaults* asdf:*central-registry*) + +;; Suppress compilation output +(let ((*error-output* (make-broadcast-stream)) + (*standard-output* (make-broadcast-stream))) + (asdf:load-system (car ext:*command-line-argument-list*) :verbose nil)) + +(mal:main (cdr ext:*command-line-argument-list*)) +(cl-user::quit) diff --git a/impls/common-lisp/run-mkcl.lisp b/impls/common-lisp/run-mkcl.lisp index 8d751a0814..3293813d61 100644 --- a/impls/common-lisp/run-mkcl.lisp +++ b/impls/common-lisp/run-mkcl.lisp @@ -1,21 +1,21 @@ -(require 'asdf) -(push *default-pathname-defaults* asdf:*central-registry*) - -(defvar *raw-command-line-args* (loop - :for index - :from 1 - :below (mkcl:argc) - :collect (mkcl:argv index))) - -(defvar *command-line-args* (subseq *raw-command-line-args* - (min (1+ (position "--" *raw-command-line-args* :test #'string=)) - (length *raw-command-line-args*)))) - -;; Suppress compilation output -(let ((*error-output* (make-broadcast-stream)) - (*standard-output* (make-broadcast-stream))) - (format *standard-output* "~a" *command-line-args*) - (asdf:load-system (car *command-line-args*) :verbose nil)) - -(mal:main (cdr *command-line-args*)) -(quit) +(require 'asdf) +(push *default-pathname-defaults* asdf:*central-registry*) + +(defvar *raw-command-line-args* (loop + :for index + :from 1 + :below (mkcl:argc) + :collect (mkcl:argv index))) + +(defvar *command-line-args* (subseq *raw-command-line-args* + (min (1+ (position "--" *raw-command-line-args* :test #'string=)) + (length *raw-command-line-args*)))) + +;; Suppress compilation output +(let ((*error-output* (make-broadcast-stream)) + (*standard-output* (make-broadcast-stream))) + (format *standard-output* "~a" *command-line-args*) + (asdf:load-system (car *command-line-args*) :verbose nil)) + +(mal:main (cdr *command-line-args*)) +(quit) diff --git a/impls/common-lisp/src/core.lisp b/impls/common-lisp/src/core.lisp index 74d24fe5bd..035e828ab6 100644 --- a/impls/common-lisp/src/core.lisp +++ b/impls/common-lisp/src/core.lisp @@ -1,360 +1,360 @@ -(defpackage :core - (:use :common-lisp - :utils - :types - :reader - :printer - :genhash - :alexandria) - (:export :ns)) - -(in-package :core) - -(define-condition index-error (mal-error) - ((size :initarg :size :reader index-error-size) - (index :initarg :index :reader index-error-index) - (sequence :initarg :sequence :reader index-error-sequence)) - (:report (lambda (condition stream) - (format stream - "Index out of range (~a), length is ~a but index given was ~a" - (printer:pr-str (index-error-sequence condition)) - (index-error-size condition) - (index-error-index condition))))) - -(defmacro wrap-boolean (form) - `(if ,form mal-true mal-false)) - -(defvar ns nil) - -(defmacro defmal (name arglist &rest body) - (let* ((symbol-name (if (stringp name) - name - ;; Since common lisp intern all the symbols in - ;; uppercase (by default) we need to convert the - ;; symbol to lowercase while introducing it in MAL - ;; environment - (string-downcase (symbol-name name)))) - (internal-name (format nil "MAL-~a" (string-upcase symbol-name)))) - `(push (cons (make-mal-symbol ,symbol-name) - (make-mal-builtin-fn (defun ,(intern internal-name) ,arglist ,@body))) - ns))) - -(defmal + (value1 value2) - (make-mal-number (+ (mal-data-value value1) (mal-data-value value2)))) - -(defmal - (value1 value2) - (make-mal-number (- (mal-data-value value1) (mal-data-value value2)))) - -(defmal * (value1 value2) - (make-mal-number (* (mal-data-value value1) (mal-data-value value2)))) - -(defmal / (value1 value2) - (make-mal-number (round (/ (mal-data-value value1) (mal-data-value value2))))) - -(defmal prn (&rest strings) - ;; Using write-line instead of (format *standard-output* ... ) since the later prints - ;; and extra newline at start in GNU CLISP, if environment variable PERL_RL is true - ;; or terminal is dumb - (write-line (format nil - "~{~a~^ ~}" - (mapcar (lambda (string) (printer:pr-str string t)) - strings))) - mal-nil) - -(defmal println (&rest strings) - ;; Using write-line instead of (format *standard-output* ... ) since the later prints - ;; and extra newline at start in GNU CLISP, if environment variable PERL_RL is true - ;; or terminal is dumb - (write-line (format nil - "~{~a~^ ~}" - (mapcar (lambda (string) (printer:pr-str string nil)) - strings))) - mal-nil) - -(defmal pr-str (&rest strings) - (make-mal-string (format nil - "~{~a~^ ~}" - (mapcar (lambda (string) (printer:pr-str string t)) - strings)))) - -(defmal str (&rest strings) - (make-mal-string (format nil - "~{~a~}" - (mapcar (lambda (string) (printer:pr-str string nil)) - strings)))) - -(defmal list (&rest values) - (make-mal-list values)) - -(defmal list? (value) - (wrap-boolean (or (mal-nil-p value) (mal-list-p value)))) - -(defmal empty? (value) - (wrap-boolean (zerop (length (mal-data-value value))))) - -(defmal count (value) - (make-mal-number (length (mal-data-value value)))) - -(defmal = (value1 value2) - (wrap-boolean (mal-data-value= value1 value2))) - -(defmal < (value1 value2) - (wrap-boolean (< (mal-data-value value1) (mal-data-value value2)))) - -(defmal > (value1 value2) - (wrap-boolean (> (mal-data-value value1) (mal-data-value value2)))) - -(defmal <= (value1 value2) - (wrap-boolean (<= (mal-data-value value1) (mal-data-value value2)))) - -(defmal >= (value1 value2) - (wrap-boolean (>= (mal-data-value value1) (mal-data-value value2)))) - -(defmal read-string (value) - (reader:read-str (mal-data-value value))) - -(defmal slurp (filename) - (make-mal-string (read-file-string (mal-data-value filename)))) - -(defmal atom (value) - (make-mal-atom value)) - -(defmal atom? (value) - (wrap-boolean (mal-atom-p value))) - -(defmal deref (atom) - (mal-data-value atom)) - -(defmal reset! (atom value) - (setf (mal-data-value atom) value)) - -(defmal swap! (atom fn &rest args) - (setf (mal-data-value atom) - (apply (mal-data-value fn) - (append (list (mal-data-value atom)) args)))) - -(defmal vec (list) - (make-mal-vector (listify (mal-data-value list)))) - -(defmal cons (element list) - (make-mal-list (cons element (listify (mal-data-value list))))) - -(defmal concat (&rest lists) - (make-mal-list (apply #'concatenate 'list (mapcar #'mal-data-value lists)))) - -(defmal nth (sequence index) - (or (nth (mal-data-value index) - (listify (mal-data-value sequence))) - (error 'index-error - :size (length (mal-data-value sequence)) - :index (mal-data-value index) - :sequence sequence))) - -(defmal first (sequence) - (or (first (listify (mal-data-value sequence))) mal-nil)) - -(defmal rest (sequence) - (make-mal-list (rest (listify (mal-data-value sequence))))) - -(defmal throw (value) - (error 'mal-user-exception :data value)) - -(defmal apply (fn &rest values) - (let ((last (listify (mal-data-value (car (last values))))) - (butlast (butlast values))) - (apply (mal-data-value fn) (append butlast last)))) - -(defmal map (fn sequence) - (let ((applicants (listify (mal-data-value sequence)))) - (make-mal-list (mapcar (mal-data-value fn) applicants)))) - -(defmal nil? (value) - (wrap-boolean (mal-nil-p value))) - -(defmal true? (value) - (wrap-boolean (and (mal-boolean-p value) (mal-data-value value)))) - -(defmal false? (value) - (wrap-boolean (and (mal-boolean-p value) (not (mal-data-value value))))) - -(defmal number? (value) - (wrap-boolean (mal-number-p value))) - -(defmal symbol (string) - (make-mal-symbol (mal-data-value string))) - -(defmal symbol? (value) - (wrap-boolean (mal-symbol-p value))) - -(defmal keyword (keyword) - (if (mal-keyword-p keyword) - keyword - (make-mal-keyword (format nil ":~a" (mal-data-value keyword))))) - -(defmal keyword? (value) - (wrap-boolean (mal-keyword-p value))) - -(defmal vector (&rest elements) - (make-mal-vector (map 'vector #'identity elements))) - -(defmal vector? (value) - (wrap-boolean (mal-vector-p value))) - -(defmal fn? (value) - (wrap-boolean (or (mal-builtin-fn-p value) - (and (mal-fn-p value) - (not (cdr (assoc :is-macro (mal-data-attrs value)))))))) - -(defmal macro? (value) - (wrap-boolean (and (mal-fn-p value) - (cdr (assoc :is-macro (mal-data-attrs value)))))) - -(defmal hash-map (&rest elements) - (let ((hash-map (make-mal-value-hash-table))) - (loop for (key value) on elements - by #'cddr - do (setf (hashref key hash-map) value)) - (make-mal-hash-map hash-map))) - -(defmal map? (value) - (wrap-boolean (mal-hash-map-p value))) - -(defmal assoc (hash-map &rest elements) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-map (make-mal-value-hash-table))) - - (hashmap (lambda (key value) - (declare (ignorable value)) - (setf (hashref key new-hash-map) - (hashref key hash-map-value))) - hash-map-value) - - (loop for (key value) on elements - by #'cddr - do (setf (hashref key new-hash-map) value)) - - (make-mal-hash-map new-hash-map))) - -(defmal dissoc (hash-map &rest elements) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-map (make-mal-value-hash-table))) - - (hashmap (lambda (key value) - (declare (ignorable value)) - (when (not (member key elements :test #'mal-data-value=)) - (setf (hashref key new-hash-map) - (hashref key hash-map-value)))) - hash-map-value) - - (make-mal-hash-map new-hash-map))) - -(defmal get (hash-map key) - (or (and (mal-hash-map-p hash-map) (hashref key (mal-data-value hash-map))) - types:mal-nil)) - -(defmal contains? (hash-map key) - (if (genhash:hashref key (types:mal-data-value hash-map)) types:mal-true types:mal-false)) - -(defmal keys (hash-map) - (let ((hash-map-value (mal-data-value hash-map)) - keys) - - (hashmap (lambda (key value) - (declare (ignorable value)) - (push key keys)) - hash-map-value) - - (make-mal-list (nreverse keys)))) - -(defmal vals (hash-map) - (let ((hash-map-value (mal-data-value hash-map)) - values) - - (hashmap (lambda (key value) - (declare (ignorable key)) - (push value values)) - hash-map-value) - - (make-mal-list (nreverse values)))) - -(defmal sequential? (value) - (wrap-boolean (or (mal-vector-p value) (mal-list-p value)))) - -(defmal readline (prompt) - (format *standard-output* (mal-data-value prompt)) - (force-output *standard-output*) - (make-mal-string (read-line *standard-input* nil))) - -(defmal string? (value) - (wrap-boolean (mal-string-p value))) - -(defmal time-ms () - (make-mal-number (round (/ (get-internal-real-time) - (/ internal-time-units-per-second - 1000))))) - -(defmal conj (value &rest elements) - (cond ((mal-list-p value) - (make-mal-list (append (nreverse elements) - (mal-data-value value)))) - ((mal-vector-p value) - (make-mal-vector (concatenate 'vector - (mal-data-value value) - elements))) - (t (error 'mal-user-exception)))) - -(defmal seq (value) - (if (zerop (length (mal-data-value value))) - mal-nil - (cond ((mal-list-p value) value) - ((mal-vector-p value) - (make-mal-list (listify (mal-data-value value)))) - ((mal-string-p value) - (make-mal-list (mapcar (alexandria:compose #'make-mal-string #'string) - (coerce (mal-data-value value) 'list)))) - (t (error 'mal-user-exception))))) - -(defmal with-meta (value meta) - (funcall (switch-mal-type value - (types:string #'make-mal-string) - (types:symbol #'make-mal-symbol) - (types:list #'make-mal-list) - (types:vector #'make-mal-vector) - (types:hash-map #'make-mal-hash-map) - (types:fn #'make-mal-fn) - (types:builtin-fn #'make-mal-builtin-fn)) - (mal-data-value value) - :meta meta - :attrs (mal-data-attrs value))) - -(defmal meta (value) - (or (types:mal-data-meta value) types:mal-nil)) - -(defun wrap-value (value &optional booleanp listp) - (typecase value - (number (make-mal-number value)) - ;; This needs to be before symbol since nil is a symbol - (null (cond (booleanp mal-false) - (listp (make-mal-list value)) - (t mal-nil))) - ;; This needs to before symbol since t, nil are symbols - (boolean (if value mal-true mal-nil)) - (keyword (make-mal-keyword value)) - (symbol (make-mal-symbol (symbol-name value))) - (string (make-mal-string value)) - (list (make-mal-list (map 'list #'wrap-value value))) - (vector (make-mal-vector (map 'vector #'wrap-value value))) - (hash-table (make-mal-hash-map (let ((new-hash-table (make-mal-value-hash-table))) - (hashmap (lambda (key value) - (setf (hashref (wrap-value key) new-hash-table) - (wrap-value value))) - value) - new-hash-table))))) - -;; Since a nil in Common LISP may mean an empty list or boolean false or -;; simply nil, the caller can specify the preferred type while evaluating an -;; expression -(defmal cl-eval (code &optional booleanp listp) - (wrap-value (eval (read-from-string (mal-data-value code))) - (and booleanp (mal-data-value booleanp)) - (and listp (mal-data-value listp)))) +(defpackage :core + (:use :common-lisp + :utils + :types + :reader + :printer + :genhash + :alexandria) + (:export :ns)) + +(in-package :core) + +(define-condition index-error (mal-error) + ((size :initarg :size :reader index-error-size) + (index :initarg :index :reader index-error-index) + (sequence :initarg :sequence :reader index-error-sequence)) + (:report (lambda (condition stream) + (format stream + "Index out of range (~a), length is ~a but index given was ~a" + (printer:pr-str (index-error-sequence condition)) + (index-error-size condition) + (index-error-index condition))))) + +(defmacro wrap-boolean (form) + `(if ,form mal-true mal-false)) + +(defvar ns nil) + +(defmacro defmal (name arglist &rest body) + (let* ((symbol-name (if (stringp name) + name + ;; Since common lisp intern all the symbols in + ;; uppercase (by default) we need to convert the + ;; symbol to lowercase while introducing it in MAL + ;; environment + (string-downcase (symbol-name name)))) + (internal-name (format nil "MAL-~a" (string-upcase symbol-name)))) + `(push (cons (make-mal-symbol ,symbol-name) + (make-mal-builtin-fn (defun ,(intern internal-name) ,arglist ,@body))) + ns))) + +(defmal + (value1 value2) + (make-mal-number (+ (mal-data-value value1) (mal-data-value value2)))) + +(defmal - (value1 value2) + (make-mal-number (- (mal-data-value value1) (mal-data-value value2)))) + +(defmal * (value1 value2) + (make-mal-number (* (mal-data-value value1) (mal-data-value value2)))) + +(defmal / (value1 value2) + (make-mal-number (round (/ (mal-data-value value1) (mal-data-value value2))))) + +(defmal prn (&rest strings) + ;; Using write-line instead of (format *standard-output* ... ) since the later prints + ;; and extra newline at start in GNU CLISP, if environment variable PERL_RL is true + ;; or terminal is dumb + (write-line (format nil + "~{~a~^ ~}" + (mapcar (lambda (string) (printer:pr-str string t)) + strings))) + mal-nil) + +(defmal println (&rest strings) + ;; Using write-line instead of (format *standard-output* ... ) since the later prints + ;; and extra newline at start in GNU CLISP, if environment variable PERL_RL is true + ;; or terminal is dumb + (write-line (format nil + "~{~a~^ ~}" + (mapcar (lambda (string) (printer:pr-str string nil)) + strings))) + mal-nil) + +(defmal pr-str (&rest strings) + (make-mal-string (format nil + "~{~a~^ ~}" + (mapcar (lambda (string) (printer:pr-str string t)) + strings)))) + +(defmal str (&rest strings) + (make-mal-string (format nil + "~{~a~}" + (mapcar (lambda (string) (printer:pr-str string nil)) + strings)))) + +(defmal list (&rest values) + (make-mal-list values)) + +(defmal list? (value) + (wrap-boolean (or (mal-nil-p value) (mal-list-p value)))) + +(defmal empty? (value) + (wrap-boolean (zerop (length (mal-data-value value))))) + +(defmal count (value) + (make-mal-number (length (mal-data-value value)))) + +(defmal = (value1 value2) + (wrap-boolean (mal-data-value= value1 value2))) + +(defmal < (value1 value2) + (wrap-boolean (< (mal-data-value value1) (mal-data-value value2)))) + +(defmal > (value1 value2) + (wrap-boolean (> (mal-data-value value1) (mal-data-value value2)))) + +(defmal <= (value1 value2) + (wrap-boolean (<= (mal-data-value value1) (mal-data-value value2)))) + +(defmal >= (value1 value2) + (wrap-boolean (>= (mal-data-value value1) (mal-data-value value2)))) + +(defmal read-string (value) + (reader:read-str (mal-data-value value))) + +(defmal slurp (filename) + (make-mal-string (read-file-string (mal-data-value filename)))) + +(defmal atom (value) + (make-mal-atom value)) + +(defmal atom? (value) + (wrap-boolean (mal-atom-p value))) + +(defmal deref (atom) + (mal-data-value atom)) + +(defmal reset! (atom value) + (setf (mal-data-value atom) value)) + +(defmal swap! (atom fn &rest args) + (setf (mal-data-value atom) + (apply (mal-data-value fn) + (append (list (mal-data-value atom)) args)))) + +(defmal vec (list) + (make-mal-vector (listify (mal-data-value list)))) + +(defmal cons (element list) + (make-mal-list (cons element (listify (mal-data-value list))))) + +(defmal concat (&rest lists) + (make-mal-list (apply #'concatenate 'list (mapcar #'mal-data-value lists)))) + +(defmal nth (sequence index) + (or (nth (mal-data-value index) + (listify (mal-data-value sequence))) + (error 'index-error + :size (length (mal-data-value sequence)) + :index (mal-data-value index) + :sequence sequence))) + +(defmal first (sequence) + (or (first (listify (mal-data-value sequence))) mal-nil)) + +(defmal rest (sequence) + (make-mal-list (rest (listify (mal-data-value sequence))))) + +(defmal throw (value) + (error 'mal-user-exception :data value)) + +(defmal apply (fn &rest values) + (let ((last (listify (mal-data-value (car (last values))))) + (butlast (butlast values))) + (apply (mal-data-value fn) (append butlast last)))) + +(defmal map (fn sequence) + (let ((applicants (listify (mal-data-value sequence)))) + (make-mal-list (mapcar (mal-data-value fn) applicants)))) + +(defmal nil? (value) + (wrap-boolean (mal-nil-p value))) + +(defmal true? (value) + (wrap-boolean (and (mal-boolean-p value) (mal-data-value value)))) + +(defmal false? (value) + (wrap-boolean (and (mal-boolean-p value) (not (mal-data-value value))))) + +(defmal number? (value) + (wrap-boolean (mal-number-p value))) + +(defmal symbol (string) + (make-mal-symbol (mal-data-value string))) + +(defmal symbol? (value) + (wrap-boolean (mal-symbol-p value))) + +(defmal keyword (keyword) + (if (mal-keyword-p keyword) + keyword + (make-mal-keyword (format nil ":~a" (mal-data-value keyword))))) + +(defmal keyword? (value) + (wrap-boolean (mal-keyword-p value))) + +(defmal vector (&rest elements) + (make-mal-vector (map 'vector #'identity elements))) + +(defmal vector? (value) + (wrap-boolean (mal-vector-p value))) + +(defmal fn? (value) + (wrap-boolean (or (mal-builtin-fn-p value) + (and (mal-fn-p value) + (not (cdr (assoc :is-macro (mal-data-attrs value)))))))) + +(defmal macro? (value) + (wrap-boolean (and (mal-fn-p value) + (cdr (assoc :is-macro (mal-data-attrs value)))))) + +(defmal hash-map (&rest elements) + (let ((hash-map (make-mal-value-hash-table))) + (loop for (key value) on elements + by #'cddr + do (setf (hashref key hash-map) value)) + (make-mal-hash-map hash-map))) + +(defmal map? (value) + (wrap-boolean (mal-hash-map-p value))) + +(defmal assoc (hash-map &rest elements) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-map (make-mal-value-hash-table))) + + (hashmap (lambda (key value) + (declare (ignorable value)) + (setf (hashref key new-hash-map) + (hashref key hash-map-value))) + hash-map-value) + + (loop for (key value) on elements + by #'cddr + do (setf (hashref key new-hash-map) value)) + + (make-mal-hash-map new-hash-map))) + +(defmal dissoc (hash-map &rest elements) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-map (make-mal-value-hash-table))) + + (hashmap (lambda (key value) + (declare (ignorable value)) + (when (not (member key elements :test #'mal-data-value=)) + (setf (hashref key new-hash-map) + (hashref key hash-map-value)))) + hash-map-value) + + (make-mal-hash-map new-hash-map))) + +(defmal get (hash-map key) + (or (and (mal-hash-map-p hash-map) (hashref key (mal-data-value hash-map))) + types:mal-nil)) + +(defmal contains? (hash-map key) + (if (genhash:hashref key (types:mal-data-value hash-map)) types:mal-true types:mal-false)) + +(defmal keys (hash-map) + (let ((hash-map-value (mal-data-value hash-map)) + keys) + + (hashmap (lambda (key value) + (declare (ignorable value)) + (push key keys)) + hash-map-value) + + (make-mal-list (nreverse keys)))) + +(defmal vals (hash-map) + (let ((hash-map-value (mal-data-value hash-map)) + values) + + (hashmap (lambda (key value) + (declare (ignorable key)) + (push value values)) + hash-map-value) + + (make-mal-list (nreverse values)))) + +(defmal sequential? (value) + (wrap-boolean (or (mal-vector-p value) (mal-list-p value)))) + +(defmal readline (prompt) + (format *standard-output* (mal-data-value prompt)) + (force-output *standard-output*) + (make-mal-string (read-line *standard-input* nil))) + +(defmal string? (value) + (wrap-boolean (mal-string-p value))) + +(defmal time-ms () + (make-mal-number (round (/ (get-internal-real-time) + (/ internal-time-units-per-second + 1000))))) + +(defmal conj (value &rest elements) + (cond ((mal-list-p value) + (make-mal-list (append (nreverse elements) + (mal-data-value value)))) + ((mal-vector-p value) + (make-mal-vector (concatenate 'vector + (mal-data-value value) + elements))) + (t (error 'mal-user-exception)))) + +(defmal seq (value) + (if (zerop (length (mal-data-value value))) + mal-nil + (cond ((mal-list-p value) value) + ((mal-vector-p value) + (make-mal-list (listify (mal-data-value value)))) + ((mal-string-p value) + (make-mal-list (mapcar (alexandria:compose #'make-mal-string #'string) + (coerce (mal-data-value value) 'list)))) + (t (error 'mal-user-exception))))) + +(defmal with-meta (value meta) + (funcall (switch-mal-type value + (types:string #'make-mal-string) + (types:symbol #'make-mal-symbol) + (types:list #'make-mal-list) + (types:vector #'make-mal-vector) + (types:hash-map #'make-mal-hash-map) + (types:fn #'make-mal-fn) + (types:builtin-fn #'make-mal-builtin-fn)) + (mal-data-value value) + :meta meta + :attrs (mal-data-attrs value))) + +(defmal meta (value) + (or (types:mal-data-meta value) types:mal-nil)) + +(defun wrap-value (value &optional booleanp listp) + (typecase value + (number (make-mal-number value)) + ;; This needs to be before symbol since nil is a symbol + (null (cond (booleanp mal-false) + (listp (make-mal-list value)) + (t mal-nil))) + ;; This needs to before symbol since t, nil are symbols + (boolean (if value mal-true mal-nil)) + (keyword (make-mal-keyword value)) + (symbol (make-mal-symbol (symbol-name value))) + (string (make-mal-string value)) + (list (make-mal-list (map 'list #'wrap-value value))) + (vector (make-mal-vector (map 'vector #'wrap-value value))) + (hash-table (make-mal-hash-map (let ((new-hash-table (make-mal-value-hash-table))) + (hashmap (lambda (key value) + (setf (hashref (wrap-value key) new-hash-table) + (wrap-value value))) + value) + new-hash-table))))) + +;; Since a nil in Common LISP may mean an empty list or boolean false or +;; simply nil, the caller can specify the preferred type while evaluating an +;; expression +(defmal cl-eval (code &optional booleanp listp) + (wrap-value (eval (read-from-string (mal-data-value code))) + (and booleanp (mal-data-value booleanp)) + (and listp (mal-data-value listp)))) diff --git a/impls/common-lisp/src/env.lisp b/impls/common-lisp/src/env.lisp index 771b72cf53..bae27d3f4f 100644 --- a/impls/common-lisp/src/env.lisp +++ b/impls/common-lisp/src/env.lisp @@ -1,66 +1,66 @@ -(defpackage :env - (:use :common-lisp :types) - (:shadow :symbol) - (:export :undefined-symbol - :create-mal-env - :get-env - :find-env - :set-env - :mal-env-bindings)) - -(in-package :env) - -(define-condition undefined-symbol (mal-runtime-exception) - ((symbol :initarg :symbol :reader symbol)) - (:report (lambda (condition stream) - (format stream - "'~a' not found" - (symbol condition))))) - -(define-condition arity-mismatch (mal-runtime-exception) - ((required :initarg :required :reader required) - (provided :initarg :provided :reader provided)) - (:report (lambda (condition stream) - (format stream - "Unexpected number of arguments provided, expected ~a, got ~a" - (required condition) - (provided condition))))) - -(defstruct mal-env - (bindings (make-hash-table :test 'equal) :read-only t) - (parent nil :read-only t)) - -(defun find-env (env symbol) - (when env - (or (gethash (mal-data-value symbol) - (mal-env-bindings env)) - (find-env (mal-env-parent env) symbol)))) - -(defun get-env (env symbol) - (or (find-env env symbol) - (error 'undefined-symbol - :symbol (format nil "~a" (mal-data-value symbol))))) - -(defun set-env (env symbol value) - (setf (gethash (mal-data-value symbol) (mal-env-bindings env)) value)) - -(defun create-mal-env (&key parent binds exprs) - (let ((env (make-mal-env :parent parent)) - (params-length (length binds)) - (arg-length (length exprs))) - - (flet ((arity-mismatch () - (error 'arity-mismatch - :required params-length - :provided arg-length))) - (loop - for key = (pop binds) - while key - do (if (string/= (mal-data-value key) "&") - (set-env env key (or (pop exprs) - (arity-mismatch))) - (progn (set-env env - (or (pop binds) (arity-mismatch)) - (make-mal-list exprs)) - (setq binds nil)))) - env))) +(defpackage :env + (:use :common-lisp :types) + (:shadow :symbol) + (:export :undefined-symbol + :create-mal-env + :get-env + :find-env + :set-env + :mal-env-bindings)) + +(in-package :env) + +(define-condition undefined-symbol (mal-runtime-exception) + ((symbol :initarg :symbol :reader symbol)) + (:report (lambda (condition stream) + (format stream + "'~a' not found" + (symbol condition))))) + +(define-condition arity-mismatch (mal-runtime-exception) + ((required :initarg :required :reader required) + (provided :initarg :provided :reader provided)) + (:report (lambda (condition stream) + (format stream + "Unexpected number of arguments provided, expected ~a, got ~a" + (required condition) + (provided condition))))) + +(defstruct mal-env + (bindings (make-hash-table :test 'equal) :read-only t) + (parent nil :read-only t)) + +(defun find-env (env symbol) + (when env + (or (gethash (mal-data-value symbol) + (mal-env-bindings env)) + (find-env (mal-env-parent env) symbol)))) + +(defun get-env (env symbol) + (or (find-env env symbol) + (error 'undefined-symbol + :symbol (format nil "~a" (mal-data-value symbol))))) + +(defun set-env (env symbol value) + (setf (gethash (mal-data-value symbol) (mal-env-bindings env)) value)) + +(defun create-mal-env (&key parent binds exprs) + (let ((env (make-mal-env :parent parent)) + (params-length (length binds)) + (arg-length (length exprs))) + + (flet ((arity-mismatch () + (error 'arity-mismatch + :required params-length + :provided arg-length))) + (loop + for key = (pop binds) + while key + do (if (string/= (mal-data-value key) "&") + (set-env env key (or (pop exprs) + (arity-mismatch))) + (progn (set-env env + (or (pop binds) (arity-mismatch)) + (make-mal-list exprs)) + (setq binds nil)))) + env))) diff --git a/impls/common-lisp/src/printer.lisp b/impls/common-lisp/src/printer.lisp index 2187bca7a0..30ebb7c3db 100644 --- a/impls/common-lisp/src/printer.lisp +++ b/impls/common-lisp/src/printer.lisp @@ -1,53 +1,53 @@ -(defpackage :printer - (:use :common-lisp - :types) - (:import-from :genhash - :hashmap) - (:import-from :cl-ppcre - :regex-replace) - (:import-from :utils - :replace-all - :listify) - (:export :pr-str)) - -(in-package :printer) - -(defun pr-mal-sequence (start-delimiter sequence end-delimiter &optional (print-readably t)) - (format nil - "~a~{~a~^ ~}~a" - start-delimiter - (mapcar (lambda (value) - (pr-str value print-readably)) - (listify (mal-data-value sequence))) - end-delimiter)) - -(defun pr-mal-hash-map (hash-map &optional (print-readably t) &aux repr) - (hashmap (lambda (key value) - (push (pr-str value print-readably) repr) - (push (pr-str key print-readably) repr)) - (mal-data-value hash-map)) - (format nil "{~{~a ~a~^ ~}}" repr)) - -(defun pr-string (ast &optional (print-readably t)) - (if print-readably - (replace-all (prin1-to-string (mal-data-value ast)) - " -" - "\\n") - (mal-data-value ast))) - -(defun pr-str (ast &optional (print-readably t)) - (when ast - (switch-mal-type ast - (types:number (format nil "~d" (mal-data-value ast))) - (types:boolean (if (mal-data-value ast) "true" "false")) - (types:nil "nil") - (types:string (pr-string ast print-readably)) - (types:symbol (format nil "~a" (mal-data-value ast))) - (types:keyword (format nil "~a" (mal-data-value ast))) - (types:list (pr-mal-sequence "(" ast ")" print-readably)) - (types:vector (pr-mal-sequence "[" ast "]" print-readably)) - (types:hash-map (pr-mal-hash-map ast print-readably)) - (types:atom (format nil "(atom ~a)" (pr-str (mal-data-value ast)))) - (types:fn "#") - (types:builtin-fn "#")))) +(defpackage :printer + (:use :common-lisp + :types) + (:import-from :genhash + :hashmap) + (:import-from :cl-ppcre + :regex-replace) + (:import-from :utils + :replace-all + :listify) + (:export :pr-str)) + +(in-package :printer) + +(defun pr-mal-sequence (start-delimiter sequence end-delimiter &optional (print-readably t)) + (format nil + "~a~{~a~^ ~}~a" + start-delimiter + (mapcar (lambda (value) + (pr-str value print-readably)) + (listify (mal-data-value sequence))) + end-delimiter)) + +(defun pr-mal-hash-map (hash-map &optional (print-readably t) &aux repr) + (hashmap (lambda (key value) + (push (pr-str value print-readably) repr) + (push (pr-str key print-readably) repr)) + (mal-data-value hash-map)) + (format nil "{~{~a ~a~^ ~}}" repr)) + +(defun pr-string (ast &optional (print-readably t)) + (if print-readably + (replace-all (prin1-to-string (mal-data-value ast)) + " +" + "\\n") + (mal-data-value ast))) + +(defun pr-str (ast &optional (print-readably t)) + (when ast + (switch-mal-type ast + (types:number (format nil "~d" (mal-data-value ast))) + (types:boolean (if (mal-data-value ast) "true" "false")) + (types:nil "nil") + (types:string (pr-string ast print-readably)) + (types:symbol (format nil "~a" (mal-data-value ast))) + (types:keyword (format nil "~a" (mal-data-value ast))) + (types:list (pr-mal-sequence "(" ast ")" print-readably)) + (types:vector (pr-mal-sequence "[" ast "]" print-readably)) + (types:hash-map (pr-mal-hash-map ast print-readably)) + (types:atom (format nil "(atom ~a)" (pr-str (mal-data-value ast)))) + (types:fn "#") + (types:builtin-fn "#")))) diff --git a/impls/common-lisp/src/reader.lisp b/impls/common-lisp/src/reader.lisp index cfcb5ae8dd..078d2795ae 100644 --- a/impls/common-lisp/src/reader.lisp +++ b/impls/common-lisp/src/reader.lisp @@ -1,187 +1,187 @@ -(defpackage :reader - (:use :common-lisp - :types - :alexandria) - (:import-from :genhash - :hashref) - (:import-from :cl-ppcre - :create-scanner - :do-matches-as-strings - :scan) - (:import-from :utils - :replace-all) - (:export :read-str - :eof - :unexpected-token)) - -(in-package :reader) - -;; Possible errors that can be raised while reading a string -(define-condition unexpected-token (error) - ((expected :initarg :expected :reader expected-token) - (actual :initarg :actual :reader actual-token)) - (:report (lambda (condition stream) - (format stream - "Unexpected token (~a) encountered while reading, expected ~a" - (actual-token condition) - (expected-token condition)))) - (:documentation "Error raised when an unexpected token is encountered while reading.")) - -(define-condition eof (error) - ((context :initarg :context :reader context)) - (:report (lambda (condition stream) - (format stream - "EOF encountered while reading '~a'" - (context condition)))) - (:documentation "Error raised when EOF is encountered while reading.")) - -(defvar *tokenizer-re* (create-scanner "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)") - "Regular expression to tokenize Lisp code") - -(defvar *number-re* (create-scanner "^(-|\\+)?[\\d]+$") - "Regular expression to match a number") - -(defvar *string-re* (create-scanner "^\"(?:\\\\.|[^\\\\\"])*\"$") - "Regular expression to match a string") - -(defvar *whitespace-chars* - '(#\Space #\Newline #\Backspace #\Tab - #\Linefeed #\Page #\Return #\Rubout #\,) - "Characters to treat as whitespace, these are trimmed in `tokenize'") - -(defun tokenize (string) - "Tokenize given string. - -This function extracts all tokens from the string using *tokenizer-re* -comments are ignored. - -Implementation notes: The regex scan generates some empty tokens, not really -sure why." - (let (tokens) - (do-matches-as-strings (match *tokenizer-re* string) - (let ((token (string-trim *whitespace-chars* match))) - (unless (or (zerop (length token)) - (char= (char token 0) #\;)) - (push token tokens)))) - (nreverse tokens))) - -;; Reader -(defstruct (token-reader) - (tokens nil)) - -(defun peek (reader) - "Returns the next token in the reader without advancing the token stream." - (car (token-reader-tokens reader))) - -(defun next (reader) - "Returns the next token and advances the token stream." - (pop (token-reader-tokens reader))) - -(defun consume (reader &optional (token nil token-provided-p)) - "Consume the next token and advance the token stream. - -If the optional argument token is provided the token stream is advanced only -if token being consumes matches it otherwise and unexpected token error is -raised" - (let ((actual-token (pop (token-reader-tokens reader)))) - (when (and token-provided-p - (not (equal actual-token token))) - (error 'unexpected-token :expected token :actual actual-token))) - reader) - -(defun parse-string (token) - ;; read-from-string doesn't handle \n - (if (and (> (length token) 1) - (scan *string-re* token)) - (let ((input (subseq token 1 (1- (length token))))) - (with-output-to-string (out) - (with-input-from-string (in input) - (loop while (peek-char nil in nil) - do (let ((char (read-char in))) - (if (eql char #\\ ) - (let ((char (read-char in))) - (if (eql char #\n) - (terpri out) - (princ char out))) - (princ char out))))))) - (error 'eof :context "string"))) - -(defun expand-quote (reader) - (let ((quote-sym (make-mal-symbol (switch ((next reader) :test #'string=) - ("'" "quote") - ("`" "quasiquote") - ("~" "unquote") - ("~@" "splice-unquote") - ("@" "deref"))))) - (make-mal-list (list quote-sym (read-form reader))))) - -(defun read-mal-sequence (reader &optional (type 'list) &aux forms) - (let ((context (string-downcase (symbol-name type))) - (delimiter (if (equal type 'list) ")" "]"))) - - ;; Consume the opening brace - (consume reader) - - (setf forms (loop - until (string= (peek reader) delimiter) - collect (read-form-or-eof reader context))) - - ;; Consume the closing brace - (consume reader) - - (apply type forms))) - -(defun read-hash-map (reader) - (let ((map (make-mal-value-hash-table)) - (context "hash-map")) - - ;; Consume the open brace - (consume reader) - - (loop - until (string= (peek reader) "}") - do (setf (hashref (read-form-or-eof reader context) map) - (read-form-or-eof reader context))) - - ;; Consume the closing brace - (consume reader) - - map)) - -(defun read-atom (reader) - (let ((token (next reader))) - (cond ((string= token "false") mal-false) - ((string= token "true") mal-true) - ((string= token "nil") mal-nil) - ((char= (char token 0) #\") (make-mal-string (parse-string token))) - ((char= (char token 0) #\:) (make-mal-keyword token)) - ((scan *number-re* token) (make-mal-number (read-from-string token))) - (t (make-mal-symbol token))))) - -(defun read-form-with-meta (reader) - (consume reader) - - (let ((meta (read-form-or-eof reader "object meta")) - (value (read-form-or-eof reader "object meta"))) - (make-mal-list (list (make-mal-symbol "with-meta") value meta)))) - -(defun read-form (reader) - (switch ((peek reader) :test #'equal) - (nil nil) - ("(" (make-mal-list (read-mal-sequence reader 'list))) - ("[" (make-mal-vector (read-mal-sequence reader 'vector))) - ("{" (make-mal-hash-map (read-hash-map reader))) - ("^" (read-form-with-meta reader)) - ("'" (expand-quote reader)) - ("`" (expand-quote reader)) - ("~" (expand-quote reader)) - ("~@" (expand-quote reader)) - ("@" (expand-quote reader)) - (t (read-atom reader)))) - -(defun read-form-or-eof (reader context) - (or (read-form reader) - (error 'eof :context context))) - -(defun read-str (string) - (read-form (make-token-reader :tokens (tokenize string)))) +(defpackage :reader + (:use :common-lisp + :types + :alexandria) + (:import-from :genhash + :hashref) + (:import-from :cl-ppcre + :create-scanner + :do-matches-as-strings + :scan) + (:import-from :utils + :replace-all) + (:export :read-str + :eof + :unexpected-token)) + +(in-package :reader) + +;; Possible errors that can be raised while reading a string +(define-condition unexpected-token (error) + ((expected :initarg :expected :reader expected-token) + (actual :initarg :actual :reader actual-token)) + (:report (lambda (condition stream) + (format stream + "Unexpected token (~a) encountered while reading, expected ~a" + (actual-token condition) + (expected-token condition)))) + (:documentation "Error raised when an unexpected token is encountered while reading.")) + +(define-condition eof (error) + ((context :initarg :context :reader context)) + (:report (lambda (condition stream) + (format stream + "EOF encountered while reading '~a'" + (context condition)))) + (:documentation "Error raised when EOF is encountered while reading.")) + +(defvar *tokenizer-re* (create-scanner "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)") + "Regular expression to tokenize Lisp code") + +(defvar *number-re* (create-scanner "^(-|\\+)?[\\d]+$") + "Regular expression to match a number") + +(defvar *string-re* (create-scanner "^\"(?:\\\\.|[^\\\\\"])*\"$") + "Regular expression to match a string") + +(defvar *whitespace-chars* + '(#\Space #\Newline #\Backspace #\Tab + #\Linefeed #\Page #\Return #\Rubout #\,) + "Characters to treat as whitespace, these are trimmed in `tokenize'") + +(defun tokenize (string) + "Tokenize given string. + +This function extracts all tokens from the string using *tokenizer-re* +comments are ignored. + +Implementation notes: The regex scan generates some empty tokens, not really +sure why." + (let (tokens) + (do-matches-as-strings (match *tokenizer-re* string) + (let ((token (string-trim *whitespace-chars* match))) + (unless (or (zerop (length token)) + (char= (char token 0) #\;)) + (push token tokens)))) + (nreverse tokens))) + +;; Reader +(defstruct (token-reader) + (tokens nil)) + +(defun peek (reader) + "Returns the next token in the reader without advancing the token stream." + (car (token-reader-tokens reader))) + +(defun next (reader) + "Returns the next token and advances the token stream." + (pop (token-reader-tokens reader))) + +(defun consume (reader &optional (token nil token-provided-p)) + "Consume the next token and advance the token stream. + +If the optional argument token is provided the token stream is advanced only +if token being consumes matches it otherwise and unexpected token error is +raised" + (let ((actual-token (pop (token-reader-tokens reader)))) + (when (and token-provided-p + (not (equal actual-token token))) + (error 'unexpected-token :expected token :actual actual-token))) + reader) + +(defun parse-string (token) + ;; read-from-string doesn't handle \n + (if (and (> (length token) 1) + (scan *string-re* token)) + (let ((input (subseq token 1 (1- (length token))))) + (with-output-to-string (out) + (with-input-from-string (in input) + (loop while (peek-char nil in nil) + do (let ((char (read-char in))) + (if (eql char #\\ ) + (let ((char (read-char in))) + (if (eql char #\n) + (terpri out) + (princ char out))) + (princ char out))))))) + (error 'eof :context "string"))) + +(defun expand-quote (reader) + (let ((quote-sym (make-mal-symbol (switch ((next reader) :test #'string=) + ("'" "quote") + ("`" "quasiquote") + ("~" "unquote") + ("~@" "splice-unquote") + ("@" "deref"))))) + (make-mal-list (list quote-sym (read-form reader))))) + +(defun read-mal-sequence (reader &optional (type 'list) &aux forms) + (let ((context (string-downcase (symbol-name type))) + (delimiter (if (equal type 'list) ")" "]"))) + + ;; Consume the opening brace + (consume reader) + + (setf forms (loop + until (string= (peek reader) delimiter) + collect (read-form-or-eof reader context))) + + ;; Consume the closing brace + (consume reader) + + (apply type forms))) + +(defun read-hash-map (reader) + (let ((map (make-mal-value-hash-table)) + (context "hash-map")) + + ;; Consume the open brace + (consume reader) + + (loop + until (string= (peek reader) "}") + do (setf (hashref (read-form-or-eof reader context) map) + (read-form-or-eof reader context))) + + ;; Consume the closing brace + (consume reader) + + map)) + +(defun read-atom (reader) + (let ((token (next reader))) + (cond ((string= token "false") mal-false) + ((string= token "true") mal-true) + ((string= token "nil") mal-nil) + ((char= (char token 0) #\") (make-mal-string (parse-string token))) + ((char= (char token 0) #\:) (make-mal-keyword token)) + ((scan *number-re* token) (make-mal-number (read-from-string token))) + (t (make-mal-symbol token))))) + +(defun read-form-with-meta (reader) + (consume reader) + + (let ((meta (read-form-or-eof reader "object meta")) + (value (read-form-or-eof reader "object meta"))) + (make-mal-list (list (make-mal-symbol "with-meta") value meta)))) + +(defun read-form (reader) + (switch ((peek reader) :test #'equal) + (nil nil) + ("(" (make-mal-list (read-mal-sequence reader 'list))) + ("[" (make-mal-vector (read-mal-sequence reader 'vector))) + ("{" (make-mal-hash-map (read-hash-map reader))) + ("^" (read-form-with-meta reader)) + ("'" (expand-quote reader)) + ("`" (expand-quote reader)) + ("~" (expand-quote reader)) + ("~@" (expand-quote reader)) + ("@" (expand-quote reader)) + (t (read-atom reader)))) + +(defun read-form-or-eof (reader context) + (or (read-form reader) + (error 'eof :context context))) + +(defun read-str (string) + (read-form (make-token-reader :tokens (tokenize string)))) diff --git a/impls/common-lisp/src/step0_repl.lisp b/impls/common-lisp/src/step0_repl.lisp index 17ba1619c7..85bacb03aa 100644 --- a/impls/common-lisp/src/step0_repl.lisp +++ b/impls/common-lisp/src/step0_repl.lisp @@ -1,76 +1,76 @@ -(defpackage :mal - (:use :common-lisp) - (:import-from :uiop - :getenv) - (:import-from :cl-readline - :readline) - (:export :main)) - -(in-package :mal) - -(defun mal-read (string) - string) - -(defun mal-eval (ast) - ast) - -(defun mal-print (expression) - expression) - -(defun rep (string) - (mal-print (mal-eval (mal-read string)))) - -(defvar *use-readline-p* nil) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun main (&optional (argv nil argv-provided-p)) - (declare (ignorable argv argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - (loop do (let ((line (mal-readline "user> "))) - (if line (mal-writeline (rep line)) (return))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp) + (:import-from :uiop + :getenv) + (:import-from :cl-readline + :readline) + (:export :main)) + +(in-package :mal) + +(defun mal-read (string) + string) + +(defun mal-eval (ast) + ast) + +(defun mal-print (expression) + expression) + +(defun rep (string) + (mal-print (mal-eval (mal-read string)))) + +(defvar *use-readline-p* nil) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun main (&optional (argv nil argv-provided-p)) + (declare (ignorable argv argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") + (string= (uiop:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + (loop do (let ((line (mal-readline "user> "))) + (if line (mal-writeline (rep line)) (return))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/step1_read_print.lisp b/impls/common-lisp/src/step1_read_print.lisp index 871ffbdb02..0c87ca700e 100644 --- a/impls/common-lisp/src/step1_read_print.lisp +++ b/impls/common-lisp/src/step1_read_print.lisp @@ -1,82 +1,82 @@ -(defpackage :mal - (:use :common-lisp - :reader - :printer) - (:import-from :utils - :getenv) - (:import-from :cl-readline - :readline) - (:export :main)) - -(in-package :mal) - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (declare (ignorable env)) - ast) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) (make-hash-table :test #'equal))) - (reader:eof (condition) - (format nil "~a" condition)))) - -(defvar *use-readline-p* nil) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun main (&optional (argv nil argv-provided-p)) - (declare (ignorable argv argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") - (string= (utils:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - (loop do (let ((line (mal-readline "user> "))) - (if line (mal-writeline (rep line)) (return))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :reader + :printer) + (:import-from :utils + :getenv) + (:import-from :cl-readline + :readline) + (:export :main)) + +(in-package :mal) + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (declare (ignorable env)) + ast) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) (make-hash-table :test #'equal))) + (reader:eof (condition) + (format nil "~a" condition)))) + +(defvar *use-readline-p* nil) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun main (&optional (argv nil argv-provided-p)) + (declare (ignorable argv argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + (loop do (let ((line (mal-readline "user> "))) + (if line (mal-writeline (rep line)) (return))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/step2_eval.lisp b/impls/common-lisp/src/step2_eval.lisp index 611d1dced9..ab014a9d6c 100644 --- a/impls/common-lisp/src/step2_eval.lisp +++ b/impls/common-lisp/src/step2_eval.lisp @@ -1,161 +1,161 @@ -(defpackage :mal - (:use :common-lisp - :types - :env - :reader - :printer) - (:import-from :cl-readline - :readline - :register-function) - (:import-from :genhash - :hashref - :hashmap) - (:import-from :utils - :getenv - :common-prefix) - (:export :main)) - -(in-package :mal) - -(defvar *repl-env* (make-mal-value-hash-table)) - -(setf (genhash:hashref (make-mal-symbol "+") *repl-env*) - (make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (+ (mal-data-value value1) - (mal-data-value value2)))))) - -(setf (genhash:hashref (make-mal-symbol "-") *repl-env*) - (make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (- (mal-data-value value1) - (mal-data-value value2)))))) - -(setf (genhash:hashref (make-mal-symbol "*") *repl-env*) - (make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (* (mal-data-value value1) - (mal-data-value value2)))))) - -(setf (genhash:hashref (make-mal-symbol "/") *repl-env*) - (make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (/ (mal-data-value value1) - (mal-data-value value2)))))) - -(defun lookup-env (symbol env) - (let ((value (genhash:hashref symbol env))) - (if value - value - (error 'env:undefined-symbol - :symbol (format nil "~a" (mal-data-value symbol)))))) - -(defun eval-sequence (sequence env) - (map 'list - (lambda (ast) (mal-eval ast env)) - (mal-data-value sequence))) - -(defun eval-hash-map (hash-map env) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref key new-hash-table) - (mal-eval value env))) - hash-map-value) - (make-mal-hash-map new-hash-table))) - -(defun eval-ast (ast env) - (switch-mal-type ast - (types:symbol (lookup-env ast env)) - (types:list (eval-sequence ast env)) - (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) - (types:hash-map (eval-hash-map ast env )) - (types:any ast))) - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (cond - ((not (mal-list-p ast)) (eval-ast ast env)) - ((zerop (length (mal-data-value ast))) ast) - (t (progn - (let ((evaluated-list (eval-ast ast env))) - (apply (mal-data-value (car evaluated-list)) - (cdr evaluated-list))))))) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) *repl-env*)) - (error (condition) - (format nil "~a" condition)))) - -(defvar *use-readline-p* nil) - -(defun complete-toplevel-symbols (input &rest ignored) - (declare (ignorable ignored)) - - (let (candidates) - (loop for key being the hash-keys of *repl-env* - when (let ((pos (search input key))) (and pos (zerop pos))) - do (push key candidates)) - - (if (= 1 (length candidates)) - (cons (car candidates) candidates) - (cons (apply #'utils:common-prefix candidates) candidates)))) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun main (&optional (argv nil argv-provided-p)) - (declare (ignorable argv argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") - (string= (utils:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - ;; CCL fails with a error while registering completion function - ;; See also https://github.com/mrkkrp/cl-readline/issues/5 - #-ccl (rl:register-function :complete #'complete-toplevel-symbols) - - (loop do (let ((line (mal-readline "user> "))) - (if line (mal-writeline (rep line)) (return))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :types + :env + :reader + :printer) + (:import-from :cl-readline + :readline + :register-function) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :getenv + :common-prefix) + (:export :main)) + +(in-package :mal) + +(defvar *repl-env* (make-mal-value-hash-table)) + +(setf (genhash:hashref (make-mal-symbol "+") *repl-env*) + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (+ (mal-data-value value1) + (mal-data-value value2)))))) + +(setf (genhash:hashref (make-mal-symbol "-") *repl-env*) + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (- (mal-data-value value1) + (mal-data-value value2)))))) + +(setf (genhash:hashref (make-mal-symbol "*") *repl-env*) + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (* (mal-data-value value1) + (mal-data-value value2)))))) + +(setf (genhash:hashref (make-mal-symbol "/") *repl-env*) + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (/ (mal-data-value value1) + (mal-data-value value2)))))) + +(defun lookup-env (symbol env) + (let ((value (genhash:hashref symbol env))) + (if value + value + (error 'env:undefined-symbol + :symbol (format nil "~a" (mal-data-value symbol)))))) + +(defun eval-sequence (sequence env) + (map 'list + (lambda (ast) (mal-eval ast env)) + (mal-data-value sequence))) + +(defun eval-hash-map (hash-map env) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref key new-hash-table) + (mal-eval value env))) + hash-map-value) + (make-mal-hash-map new-hash-table))) + +(defun eval-ast (ast env) + (switch-mal-type ast + (types:symbol (lookup-env ast env)) + (types:list (eval-sequence ast env)) + (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) + (types:hash-map (eval-hash-map ast env )) + (types:any ast))) + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (cond + ((not (mal-list-p ast)) (eval-ast ast env)) + ((zerop (length (mal-data-value ast))) ast) + (t (progn + (let ((evaluated-list (eval-ast ast env))) + (apply (mal-data-value (car evaluated-list)) + (cdr evaluated-list))))))) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) *repl-env*)) + (error (condition) + (format nil "~a" condition)))) + +(defvar *use-readline-p* nil) + +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of *repl-env* + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun main (&optional (argv nil argv-provided-p)) + (declare (ignorable argv argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + (loop do (let ((line (mal-readline "user> "))) + (if line (mal-writeline (rep line)) (return))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/step3_env.lisp b/impls/common-lisp/src/step3_env.lisp index 069dc35331..4d603f7a6e 100644 --- a/impls/common-lisp/src/step3_env.lisp +++ b/impls/common-lisp/src/step3_env.lisp @@ -1,188 +1,188 @@ -(defpackage :mal - (:use :common-lisp - :types - :env - :reader - :printer - :genhash) - (:import-from :cl-readline - :readline - :register-function) - (:import-from :genhash - :hashref - :hashmap) - (:import-from :utils - :getenv - :common-prefix) - (:export :main)) - -(in-package :mal) - -(defvar *repl-env* (env:create-mal-env)) - -(env:set-env *repl-env* - (make-mal-symbol "+") - (make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (+ (mal-data-value value1) - (mal-data-value value2)))))) - -(env:set-env *repl-env* - (make-mal-symbol "-") - (make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (- (mal-data-value value1) - (mal-data-value value2)))))) - -(env:set-env *repl-env* - (make-mal-symbol "*") - (make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (* (mal-data-value value1) - (mal-data-value value2)))))) - -(env:set-env *repl-env* - (make-mal-symbol "/") - (make-mal-builtin-fn (lambda (value1 value2) - (make-mal-number (/ (mal-data-value value1) - (mal-data-value value2)))))) - -(defvar mal-def! (make-mal-symbol "def!")) -(defvar mal-let* (make-mal-symbol "let*")) - -(defun eval-sequence (sequence env) - (map 'list - (lambda (ast) (mal-eval ast env)) - (mal-data-value sequence))) - -(defun eval-hash-map (hash-map env) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref key new-hash-table) - (mal-eval value env))) - hash-map-value) - (make-mal-hash-map new-hash-table))) - -(defun eval-ast (ast env) - (switch-mal-type ast - (types:symbol (env:get-env env ast)) - (types:list (eval-sequence ast env)) - (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) - (types:hash-map (eval-hash-map ast env )) - (types:any ast))) - -(defun eval-let* (forms env) - (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (mal-data-value (second forms))))) - - (mapcar (lambda (binding) - (env:set-env new-env - (car binding) - (mal-eval (or (cdr binding) - mal-nil) - new-env))) - (loop - for (symbol value) on bindings - by #'cddr - collect (cons symbol value))) - - (mal-eval (third forms) new-env))) - -(defun eval-list (ast env) - (let ((forms (mal-data-value ast))) - (cond - ((mal-data-value= mal-def! (first forms)) - (env:set-env env (second forms) (mal-eval (third forms) env))) - ((mal-data-value= mal-let* (first forms)) - (eval-let* forms env)) - (t (let ((evaluated-list (eval-ast ast env))) - (apply (mal-data-value (car evaluated-list)) - (cdr evaluated-list))))))) - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (cond - ((null ast) mal-nil) - ((not (mal-list-p ast)) (eval-ast ast env)) - ((zerop (length (mal-data-value ast))) ast) - (t (eval-list ast env)))) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) *repl-env*)) - (error (condition) - (format nil "~a" condition)))) - -(defvar *use-readline-p* nil) - -(defun complete-toplevel-symbols (input &rest ignored) - (declare (ignorable ignored)) - - (let (candidates) - (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) - when (let ((pos (search input key))) (and pos (zerop pos))) - do (push key candidates)) - - (if (= 1 (length candidates)) - (cons (car candidates) candidates) - (cons (apply #'utils:common-prefix candidates) candidates)))) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun main (&optional (argv nil argv-provided-p)) - (declare (ignorable argv argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") - (string= (utils:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - ;; CCL fails with a error while registering completion function - ;; See also https://github.com/mrkkrp/cl-readline/issues/5 - #-ccl (rl:register-function :complete #'complete-toplevel-symbols) - - (loop do (let ((line (mal-readline "user> "))) - (if line (mal-writeline (rep line)) (return))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :types + :env + :reader + :printer + :genhash) + (:import-from :cl-readline + :readline + :register-function) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :getenv + :common-prefix) + (:export :main)) + +(in-package :mal) + +(defvar *repl-env* (env:create-mal-env)) + +(env:set-env *repl-env* + (make-mal-symbol "+") + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (+ (mal-data-value value1) + (mal-data-value value2)))))) + +(env:set-env *repl-env* + (make-mal-symbol "-") + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (- (mal-data-value value1) + (mal-data-value value2)))))) + +(env:set-env *repl-env* + (make-mal-symbol "*") + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (* (mal-data-value value1) + (mal-data-value value2)))))) + +(env:set-env *repl-env* + (make-mal-symbol "/") + (make-mal-builtin-fn (lambda (value1 value2) + (make-mal-number (/ (mal-data-value value1) + (mal-data-value value2)))))) + +(defvar mal-def! (make-mal-symbol "def!")) +(defvar mal-let* (make-mal-symbol "let*")) + +(defun eval-sequence (sequence env) + (map 'list + (lambda (ast) (mal-eval ast env)) + (mal-data-value sequence))) + +(defun eval-hash-map (hash-map env) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref key new-hash-table) + (mal-eval value env))) + hash-map-value) + (make-mal-hash-map new-hash-table))) + +(defun eval-ast (ast env) + (switch-mal-type ast + (types:symbol (env:get-env env ast)) + (types:list (eval-sequence ast env)) + (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) + (types:hash-map (eval-hash-map ast env )) + (types:any ast))) + +(defun eval-let* (forms env) + (let ((new-env (env:create-mal-env :parent env)) + (bindings (utils:listify (mal-data-value (second forms))))) + + (mapcar (lambda (binding) + (env:set-env new-env + (car binding) + (mal-eval (or (cdr binding) + mal-nil) + new-env))) + (loop + for (symbol value) on bindings + by #'cddr + collect (cons symbol value))) + + (mal-eval (third forms) new-env))) + +(defun eval-list (ast env) + (let ((forms (mal-data-value ast))) + (cond + ((mal-data-value= mal-def! (first forms)) + (env:set-env env (second forms) (mal-eval (third forms) env))) + ((mal-data-value= mal-let* (first forms)) + (eval-let* forms env)) + (t (let ((evaluated-list (eval-ast ast env))) + (apply (mal-data-value (car evaluated-list)) + (cdr evaluated-list))))))) + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (cond + ((null ast) mal-nil) + ((not (mal-list-p ast)) (eval-ast ast env)) + ((zerop (length (mal-data-value ast))) ast) + (t (eval-list ast env)))) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) *repl-env*)) + (error (condition) + (format nil "~a" condition)))) + +(defvar *use-readline-p* nil) + +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun main (&optional (argv nil argv-provided-p)) + (declare (ignorable argv argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + (loop do (let ((line (mal-readline "user> "))) + (if line (mal-writeline (rep line)) (return))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/step4_if_fn_do.lisp b/impls/common-lisp/src/step4_if_fn_do.lisp index db3070da51..7a0c771709 100644 --- a/impls/common-lisp/src/step4_if_fn_do.lisp +++ b/impls/common-lisp/src/step4_if_fn_do.lisp @@ -1,192 +1,192 @@ -(defpackage :mal - (:use :common-lisp - :types - :env - :reader - :printer - :core) - (:import-from :cl-readline - :readline - :register-function) - (:import-from :genhash - :hashref - :hashmap) - (:import-from :utils - :listify - :getenv - :common-prefix) - (:export :main)) - -(in-package :mal) - -(defvar *repl-env* (env:create-mal-env)) - -(dolist (binding core:ns) - (env:set-env *repl-env* (car binding) (cdr binding))) - -(defvar mal-def! (make-mal-symbol "def!")) -(defvar mal-let* (make-mal-symbol "let*")) -(defvar mal-do (make-mal-symbol "do")) -(defvar mal-if (make-mal-symbol "if")) -(defvar mal-fn* (make-mal-symbol "fn*")) - -(defun eval-sequence (sequence env) - (map 'list - (lambda (ast) (mal-eval ast env)) - (mal-data-value sequence))) - -(defun eval-hash-map (hash-map env) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref key new-hash-table) - (mal-eval value env))) - hash-map-value) - (make-mal-hash-map new-hash-table))) - -(defun eval-ast (ast env) - (switch-mal-type ast - (types:symbol (env:get-env env ast)) - (types:list (eval-sequence ast env)) - (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) - (types:hash-map (eval-hash-map ast env)) - (types:any ast))) - -(defun eval-let* (forms env) - (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (mal-data-value (second forms))))) - - (mapcar (lambda (binding) - (env:set-env new-env - (car binding) - (mal-eval (or (cdr binding) - mal-nil) - new-env))) - (loop - for (symbol value) on bindings - by #'cddr - collect (cons symbol value))) - - (mal-eval (third forms) new-env))) - -(defun eval-list (ast env) - (let ((forms (mal-data-value ast))) - (cond - ((mal-data-value= mal-def! (first forms)) - (env:set-env env (second forms) (mal-eval (third forms) env))) - ((mal-data-value= mal-let* (first forms)) - (eval-let* forms env)) - ((mal-data-value= mal-do (first forms)) - (car (last (mapcar (lambda (form) (mal-eval form env)) - (cdr forms))))) - ((mal-data-value= mal-if (first forms)) - (let ((predicate (mal-eval (second forms) env))) - (mal-eval (if (or (mal-data-value= predicate mal-nil) - (mal-data-value= predicate mal-false)) - (fourth forms) - (third forms)) - env))) - ((mal-data-value= mal-fn* (first forms)) - (make-mal-fn (let ((arglist (second forms)) - (body (third forms))) - (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (listify (mal-data-value arglist)) - :exprs args)))))) - (t (let* ((evaluated-list (eval-ast ast env)) - (function (car evaluated-list))) - ;; If first element is a mal function unwrap it - (apply (mal-data-value function) - (cdr evaluated-list))))))) - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (cond - ((null ast) mal-nil) - ((not (mal-list-p ast)) (eval-ast ast env)) - ((zerop (length (mal-data-value ast))) ast) - (t (eval-list ast env)))) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) *repl-env*)) - (error (condition) - (format nil "~a" condition)))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(defvar *use-readline-p* nil) - -(defun complete-toplevel-symbols (input &rest ignored) - (declare (ignorable ignored)) - - (let (candidates) - (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) - when (let ((pos (search input key))) (and pos (zerop pos))) - do (push key candidates)) - - (if (= 1 (length candidates)) - (cons (car candidates) candidates) - (cons (apply #'utils:common-prefix candidates) candidates)))) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun main (&optional (argv nil argv-provided-p)) - (declare (ignorable argv argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") - (string= (utils:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - ;; CCL fails with a error while registering completion function - ;; See also https://github.com/mrkkrp/cl-readline/issues/5 - #-ccl (rl:register-function :complete #'complete-toplevel-symbols) - - (loop do (let ((line (mal-readline "user> "))) - (if line (mal-writeline (rep line)) (return))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :types + :env + :reader + :printer + :core) + (:import-from :cl-readline + :readline + :register-function) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv + :common-prefix) + (:export :main)) + +(in-package :mal) + +(defvar *repl-env* (env:create-mal-env)) + +(dolist (binding core:ns) + (env:set-env *repl-env* (car binding) (cdr binding))) + +(defvar mal-def! (make-mal-symbol "def!")) +(defvar mal-let* (make-mal-symbol "let*")) +(defvar mal-do (make-mal-symbol "do")) +(defvar mal-if (make-mal-symbol "if")) +(defvar mal-fn* (make-mal-symbol "fn*")) + +(defun eval-sequence (sequence env) + (map 'list + (lambda (ast) (mal-eval ast env)) + (mal-data-value sequence))) + +(defun eval-hash-map (hash-map env) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref key new-hash-table) + (mal-eval value env))) + hash-map-value) + (make-mal-hash-map new-hash-table))) + +(defun eval-ast (ast env) + (switch-mal-type ast + (types:symbol (env:get-env env ast)) + (types:list (eval-sequence ast env)) + (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) + (types:hash-map (eval-hash-map ast env)) + (types:any ast))) + +(defun eval-let* (forms env) + (let ((new-env (env:create-mal-env :parent env)) + (bindings (utils:listify (mal-data-value (second forms))))) + + (mapcar (lambda (binding) + (env:set-env new-env + (car binding) + (mal-eval (or (cdr binding) + mal-nil) + new-env))) + (loop + for (symbol value) on bindings + by #'cddr + collect (cons symbol value))) + + (mal-eval (third forms) new-env))) + +(defun eval-list (ast env) + (let ((forms (mal-data-value ast))) + (cond + ((mal-data-value= mal-def! (first forms)) + (env:set-env env (second forms) (mal-eval (third forms) env))) + ((mal-data-value= mal-let* (first forms)) + (eval-let* forms env)) + ((mal-data-value= mal-do (first forms)) + (car (last (mapcar (lambda (form) (mal-eval form env)) + (cdr forms))))) + ((mal-data-value= mal-if (first forms)) + (let ((predicate (mal-eval (second forms) env))) + (mal-eval (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) + (fourth forms) + (third forms)) + env))) + ((mal-data-value= mal-fn* (first forms)) + (make-mal-fn (let ((arglist (second forms)) + (body (third forms))) + (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args)))))) + (t (let* ((evaluated-list (eval-ast ast env)) + (function (car evaluated-list))) + ;; If first element is a mal function unwrap it + (apply (mal-data-value function) + (cdr evaluated-list))))))) + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (cond + ((null ast) mal-nil) + ((not (mal-list-p ast)) (eval-ast ast env)) + ((zerop (length (mal-data-value ast))) ast) + (t (eval-list ast env)))) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) *repl-env*)) + (error (condition) + (format nil "~a" condition)))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(defvar *use-readline-p* nil) + +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun main (&optional (argv nil argv-provided-p)) + (declare (ignorable argv argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + (loop do (let ((line (mal-readline "user> "))) + (if line (mal-writeline (rep line)) (return))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/step5_tco.lisp b/impls/common-lisp/src/step5_tco.lisp index 2a162f5700..3e3d332f53 100644 --- a/impls/common-lisp/src/step5_tco.lisp +++ b/impls/common-lisp/src/step5_tco.lisp @@ -1,203 +1,203 @@ -(defpackage :mal - (:use :common-lisp - :types - :env - :reader - :printer - :core) - (:import-from :cl-readline - :readline - :register-function) - (:import-from :genhash - :hashref - :hashmap) - (:import-from :utils - :listify - :getenv - :common-prefix) - (:export :main)) - -(in-package :mal) - -(defvar *repl-env* (env:create-mal-env)) - -(dolist (binding core:ns) - (env:set-env *repl-env* (car binding) (cdr binding))) - -(defvar mal-def! (make-mal-symbol "def!")) -(defvar mal-let* (make-mal-symbol "let*")) -(defvar mal-do (make-mal-symbol "do")) -(defvar mal-if (make-mal-symbol "if")) -(defvar mal-fn* (make-mal-symbol "fn*")) - -(defun eval-sequence (sequence env) - (map 'list - (lambda (ast) (mal-eval ast env)) - (mal-data-value sequence))) - -(defun eval-hash-map (hash-map env) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref key new-hash-table) - (mal-eval value env))) - hash-map-value) - (make-mal-hash-map new-hash-table))) - -(defun eval-ast (ast env) - (switch-mal-type ast - (types:symbol (env:get-env env ast)) - (types:list (eval-sequence ast env)) - (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) - (types:hash-map (eval-hash-map ast env)) - (types:any ast))) - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (loop - do (cond - ((null ast) (return mal-nil)) - ((not (mal-list-p ast)) (return (eval-ast ast env))) - ((zerop (length (mal-data-value ast))) (return ast)) - (t (let ((forms (mal-data-value ast))) - (cond - ((mal-data-value= mal-def! (first forms)) - (return (env:set-env env (second forms) (mal-eval (third forms) env)))) - - ((mal-data-value= mal-let* (first forms)) - (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (mal-data-value (second forms))))) - - (mapcar (lambda (binding) - (env:set-env new-env - (car binding) - (mal-eval (or (cdr binding) - mal-nil) - new-env))) - (loop - for (symbol value) on bindings - by #'cddr - collect (cons symbol value))) - (setf ast (third forms) - env new-env))) - - ((mal-data-value= mal-do (first forms)) - (mapc (lambda (form) (mal-eval form env)) - (butlast (cdr forms))) - (setf ast (car (last forms)))) - - ((mal-data-value= mal-if (first forms)) - (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (mal-data-value= predicate mal-nil) - (mal-data-value= predicate mal-false)) - (fourth forms) - (third forms))))) - - ((mal-data-value= mal-fn* (first forms)) - (return (let ((arglist (second forms)) - (body (third forms))) - (make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (listify (mal-data-value arglist)) - :exprs args))) - :attrs (list (cons :params arglist) - (cons :ast body) - (cons :env env)))))) - - (t (let* ((evaluated-list (eval-ast ast env)) - (function (car evaluated-list))) - ;; If first element is a mal function unwrap it - (if (not (mal-fn-p function)) - (return (apply (mal-data-value function) - (cdr evaluated-list))) - (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc :ast attrs)) - env (env:create-mal-env :parent (cdr (assoc :env attrs)) - :binds (map 'list - #'identity - (mal-data-value (cdr (assoc :params attrs)))) - :exprs (cdr evaluated-list))))))))))))) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) *repl-env*)) - (error (condition) - (format nil "~a" condition)))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(defvar *use-readline-p* nil) - -(defun complete-toplevel-symbols (input &rest ignored) - (declare (ignorable ignored)) - - (let (candidates) - (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) - when (let ((pos (search input key))) (and pos (zerop pos))) - do (push key candidates)) - - (if (= 1 (length candidates)) - (cons (car candidates) candidates) - (cons (apply #'utils:common-prefix candidates) candidates)))) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun main (&optional (argv nil argv-provided-p)) - (declare (ignorable argv argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") - (string= (utils:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - ;; CCL fails with a error while registering completion function - ;; See also https://github.com/mrkkrp/cl-readline/issues/5 - #-ccl (rl:register-function :complete #'complete-toplevel-symbols) - - (loop do (let ((line (mal-readline "user> "))) - (if line (mal-writeline (rep line)) (return))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :types + :env + :reader + :printer + :core) + (:import-from :cl-readline + :readline + :register-function) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv + :common-prefix) + (:export :main)) + +(in-package :mal) + +(defvar *repl-env* (env:create-mal-env)) + +(dolist (binding core:ns) + (env:set-env *repl-env* (car binding) (cdr binding))) + +(defvar mal-def! (make-mal-symbol "def!")) +(defvar mal-let* (make-mal-symbol "let*")) +(defvar mal-do (make-mal-symbol "do")) +(defvar mal-if (make-mal-symbol "if")) +(defvar mal-fn* (make-mal-symbol "fn*")) + +(defun eval-sequence (sequence env) + (map 'list + (lambda (ast) (mal-eval ast env)) + (mal-data-value sequence))) + +(defun eval-hash-map (hash-map env) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref key new-hash-table) + (mal-eval value env))) + hash-map-value) + (make-mal-hash-map new-hash-table))) + +(defun eval-ast (ast env) + (switch-mal-type ast + (types:symbol (env:get-env env ast)) + (types:list (eval-sequence ast env)) + (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) + (types:hash-map (eval-hash-map ast env)) + (types:any ast))) + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (loop + do (cond + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) + ((zerop (length (mal-data-value ast))) (return ast)) + (t (let ((forms (mal-data-value ast))) + (cond + ((mal-data-value= mal-def! (first forms)) + (return (env:set-env env (second forms) (mal-eval (third forms) env)))) + + ((mal-data-value= mal-let* (first forms)) + (let ((new-env (env:create-mal-env :parent env)) + (bindings (utils:listify (mal-data-value (second forms))))) + + (mapcar (lambda (binding) + (env:set-env new-env + (car binding) + (mal-eval (or (cdr binding) + mal-nil) + new-env))) + (loop + for (symbol value) on bindings + by #'cddr + collect (cons symbol value))) + (setf ast (third forms) + env new-env))) + + ((mal-data-value= mal-do (first forms)) + (mapc (lambda (form) (mal-eval form env)) + (butlast (cdr forms))) + (setf ast (car (last forms)))) + + ((mal-data-value= mal-if (first forms)) + (let ((predicate (mal-eval (second forms) env))) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) + (fourth forms) + (third forms))))) + + ((mal-data-value= mal-fn* (first forms)) + (return (let ((arglist (second forms)) + (body (third forms))) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env)))))) + + (t (let* ((evaluated-list (eval-ast ast env)) + (function (car evaluated-list))) + ;; If first element is a mal function unwrap it + (if (not (mal-fn-p function)) + (return (apply (mal-data-value function) + (cdr evaluated-list))) + (let* ((attrs (mal-data-attrs function))) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) + :binds (map 'list + #'identity + (mal-data-value (cdr (assoc :params attrs)))) + :exprs (cdr evaluated-list))))))))))))) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) *repl-env*)) + (error (condition) + (format nil "~a" condition)))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(defvar *use-readline-p* nil) + +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun main (&optional (argv nil argv-provided-p)) + (declare (ignorable argv argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + (loop do (let ((line (mal-readline "user> "))) + (if line (mal-writeline (rep line)) (return))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/step6_file.lisp b/impls/common-lisp/src/step6_file.lisp index 0b299b92fe..90f4961188 100644 --- a/impls/common-lisp/src/step6_file.lisp +++ b/impls/common-lisp/src/step6_file.lisp @@ -1,224 +1,224 @@ -(defpackage :mal - (:use :common-lisp - :types - :env - :reader - :printer - :core) - (:import-from :cl-readline - :readline - :register-function) - (:import-from :genhash - :hashref - :hashmap) - (:import-from :utils - :listify - :getenv - :common-prefix) - (:export :main)) - -(in-package :mal) - -(defvar *repl-env* (env:create-mal-env)) - -(dolist (binding core:ns) - (env:set-env *repl-env* (car binding) (cdr binding))) - -(defvar mal-def! (make-mal-symbol "def!")) -(defvar mal-let* (make-mal-symbol "let*")) -(defvar mal-do (make-mal-symbol "do")) -(defvar mal-if (make-mal-symbol "if")) -(defvar mal-fn* (make-mal-symbol "fn*")) - -(defun eval-sequence (sequence env) - (map 'list - (lambda (ast) (mal-eval ast env)) - (mal-data-value sequence))) - -(defun eval-hash-map (hash-map env) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref key new-hash-table) - (mal-eval value env))) - hash-map-value) - (make-mal-hash-map new-hash-table))) - -(defun eval-ast (ast env) - (switch-mal-type ast - (types:symbol (env:get-env env ast)) - (types:list (eval-sequence ast env)) - (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) - (types:hash-map (eval-hash-map ast env)) - (types:any ast))) - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (loop - do (cond - ((null ast) (return mal-nil)) - ((not (mal-list-p ast)) (return (eval-ast ast env))) - ((zerop (length (mal-data-value ast))) (return ast)) - (t (let ((forms (mal-data-value ast))) - (cond - ((mal-data-value= mal-def! (first forms)) - (return (env:set-env env (second forms) (mal-eval (third forms) env)))) - - ((mal-data-value= mal-let* (first forms)) - (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (mal-data-value (second forms))))) - - (mapcar (lambda (binding) - (env:set-env new-env - (car binding) - (mal-eval (or (cdr binding) - mal-nil) - new-env))) - (loop - for (symbol value) on bindings - by #'cddr - collect (cons symbol value))) - (setf ast (third forms) - env new-env))) - - ((mal-data-value= mal-do (first forms)) - (mapc (lambda (form) (mal-eval form env)) - (butlast (cdr forms))) - (setf ast (car (last forms)))) - - ((mal-data-value= mal-if (first forms)) - (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (mal-data-value= predicate mal-nil) - (mal-data-value= predicate mal-false)) - (fourth forms) - (third forms))))) - - ((mal-data-value= mal-fn* (first forms)) - (return (let ((arglist (second forms)) - (body (third forms))) - (make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (listify (mal-data-value arglist)) - :exprs args))) - :attrs (list (cons :params arglist) - (cons :ast body) - (cons :env env)))))) - - (t (let* ((evaluated-list (eval-ast ast env)) - (function (car evaluated-list))) - ;; If first element is a mal function unwrap it - (if (not (mal-fn-p function)) - (return (apply (mal-data-value function) - (cdr evaluated-list))) - (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc :ast attrs)) - env (env:create-mal-env :parent (cdr (assoc :env attrs)) - :binds (map 'list - #'identity - (mal-data-value (cdr (assoc :params attrs)))) - :exprs (cdr evaluated-list))))))))))))) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) *repl-env*)) - (error (condition) - (format nil "~a" condition)))) - -(env:set-env *repl-env* - (make-mal-symbol "eval") - (make-mal-builtin-fn (lambda (ast) - (mal-eval ast *repl-env*)))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") - -(defvar *use-readline-p* nil) - -(defun complete-toplevel-symbols (input &rest ignored) - (declare (ignorable ignored)) - - (let (candidates) - (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) - when (let ((pos (search input key))) (and pos (zerop pos))) - do (push key candidates)) - - (if (= 1 (length candidates)) - (cons (car candidates) candidates) - (cons (apply #'utils:common-prefix candidates) candidates)))) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun repl () - (loop do (let ((line (mal-readline "user> "))) - (if line - (mal-writeline (rep line)) - (return))))) - -(defun run-file (file) - (rep (format nil "(load-file \"~a\")" file))) - -(defun main (&optional (argv nil argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") - (string= (utils:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - ;; CCL fails with a error while registering completion function - ;; See also https://github.com/mrkkrp/cl-readline/issues/5 - #-ccl (rl:register-function :complete #'complete-toplevel-symbols) - - (let ((args (if argv-provided-p - argv - (cdr (utils:raw-command-line-arguments))))) - (env:set-env *repl-env* - (make-mal-symbol "*ARGV*") - (make-mal-list (mapcar #'make-mal-string (cdr args)))) - (if (null args) - (repl) - (run-file (car args))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :types + :env + :reader + :printer + :core) + (:import-from :cl-readline + :readline + :register-function) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv + :common-prefix) + (:export :main)) + +(in-package :mal) + +(defvar *repl-env* (env:create-mal-env)) + +(dolist (binding core:ns) + (env:set-env *repl-env* (car binding) (cdr binding))) + +(defvar mal-def! (make-mal-symbol "def!")) +(defvar mal-let* (make-mal-symbol "let*")) +(defvar mal-do (make-mal-symbol "do")) +(defvar mal-if (make-mal-symbol "if")) +(defvar mal-fn* (make-mal-symbol "fn*")) + +(defun eval-sequence (sequence env) + (map 'list + (lambda (ast) (mal-eval ast env)) + (mal-data-value sequence))) + +(defun eval-hash-map (hash-map env) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref key new-hash-table) + (mal-eval value env))) + hash-map-value) + (make-mal-hash-map new-hash-table))) + +(defun eval-ast (ast env) + (switch-mal-type ast + (types:symbol (env:get-env env ast)) + (types:list (eval-sequence ast env)) + (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) + (types:hash-map (eval-hash-map ast env)) + (types:any ast))) + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (loop + do (cond + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) + ((zerop (length (mal-data-value ast))) (return ast)) + (t (let ((forms (mal-data-value ast))) + (cond + ((mal-data-value= mal-def! (first forms)) + (return (env:set-env env (second forms) (mal-eval (third forms) env)))) + + ((mal-data-value= mal-let* (first forms)) + (let ((new-env (env:create-mal-env :parent env)) + (bindings (utils:listify (mal-data-value (second forms))))) + + (mapcar (lambda (binding) + (env:set-env new-env + (car binding) + (mal-eval (or (cdr binding) + mal-nil) + new-env))) + (loop + for (symbol value) on bindings + by #'cddr + collect (cons symbol value))) + (setf ast (third forms) + env new-env))) + + ((mal-data-value= mal-do (first forms)) + (mapc (lambda (form) (mal-eval form env)) + (butlast (cdr forms))) + (setf ast (car (last forms)))) + + ((mal-data-value= mal-if (first forms)) + (let ((predicate (mal-eval (second forms) env))) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) + (fourth forms) + (third forms))))) + + ((mal-data-value= mal-fn* (first forms)) + (return (let ((arglist (second forms)) + (body (third forms))) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env)))))) + + (t (let* ((evaluated-list (eval-ast ast env)) + (function (car evaluated-list))) + ;; If first element is a mal function unwrap it + (if (not (mal-fn-p function)) + (return (apply (mal-data-value function) + (cdr evaluated-list))) + (let* ((attrs (mal-data-attrs function))) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) + :binds (map 'list + #'identity + (mal-data-value (cdr (assoc :params attrs)))) + :exprs (cdr evaluated-list))))))))))))) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) *repl-env*)) + (error (condition) + (format nil "~a" condition)))) + +(env:set-env *repl-env* + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) + (mal-eval ast *repl-env*)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") + +(defvar *use-readline-p* nil) + +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun repl () + (loop do (let ((line (mal-readline "user> "))) + (if line + (mal-writeline (rep line)) + (return))))) + +(defun run-file (file) + (rep (format nil "(load-file \"~a\")" file))) + +(defun main (&optional (argv nil argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + (let ((args (if argv-provided-p + argv + (cdr (utils:raw-command-line-arguments))))) + (env:set-env *repl-env* + (make-mal-symbol "*ARGV*") + (make-mal-list (mapcar #'make-mal-string (cdr args)))) + (if (null args) + (repl) + (run-file (car args))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/step7_quote.lisp b/impls/common-lisp/src/step7_quote.lisp index 14b0167c5f..e56a83d75f 100644 --- a/impls/common-lisp/src/step7_quote.lisp +++ b/impls/common-lisp/src/step7_quote.lisp @@ -1,260 +1,260 @@ -(defpackage :mal - (:use :common-lisp - :types - :env - :reader - :printer - :core) - (:import-from :cl-readline - :readline - :register-function) - (:import-from :genhash - :hashref - :hashmap) - (:import-from :utils - :listify - :getenv - :common-prefix) - (:export :main)) - -(in-package :mal) - -(defvar *repl-env* (env:create-mal-env)) - -(dolist (binding core:ns) - (env:set-env *repl-env* (car binding) (cdr binding))) - -(defvar mal-def! (make-mal-symbol "def!")) -(defvar mal-let* (make-mal-symbol "let*")) -(defvar mal-do (make-mal-symbol "do")) -(defvar mal-if (make-mal-symbol "if")) -(defvar mal-fn* (make-mal-symbol "fn*")) -(defvar mal-quote (make-mal-symbol "quote")) -(defvar mal-quasiquote (make-mal-symbol "quasiquote")) -(defvar mal-quasiquoteexpand (make-mal-symbol "quasiquoteexpand")) -(defvar mal-unquote (make-mal-symbol "unquote")) -(defvar mal-splice-unquote (make-mal-symbol "splice-unquote")) -(defvar mal-vec (make-mal-symbol "vec")) -(defvar mal-cons (make-mal-symbol "cons")) -(defvar mal-concat (make-mal-symbol "concat")) - -(defun eval-sequence (sequence env) - (map 'list - (lambda (ast) (mal-eval ast env)) - (mal-data-value sequence))) - -(defun eval-hash-map (hash-map env) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref key new-hash-table) - (mal-eval value env))) - hash-map-value) - (make-mal-hash-map new-hash-table))) - -(defun eval-ast (ast env) - (switch-mal-type ast - (types:symbol (env:get-env env ast)) - (types:list (eval-sequence ast env)) - (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) - (types:hash-map (eval-hash-map ast env)) - (types:any ast))) - -(defun qq-reducer (elt acc) - (make-mal-list - (if (and (mal-list-p elt) - (mal-data-value= (first (mal-data-value elt)) mal-splice-unquote)) - (list mal-concat (second (mal-data-value elt)) acc) - (list mal-cons (quasiquote elt) acc)))) -(defun qq-iter (elts) - (reduce #'qq-reducer elts :from-end t :initial-value (make-mal-list ()))) -(defun quasiquote (ast) - (switch-mal-type ast - (types:list (if (mal-data-value= (first (mal-data-value ast)) mal-unquote) - (second (mal-data-value ast)) - (qq-iter (mal-data-value ast)))) - (types:vector (make-mal-list (list mal-vec (qq-iter (listify (mal-data-value ast)))))) - (types:hash-map (make-mal-list (list mal-quote ast))) - (types:symbol (make-mal-list (list mal-quote ast))) - (types:any ast))) - - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (loop - do (cond - ((null ast) (return mal-nil)) - ((not (mal-list-p ast)) (return (eval-ast ast env))) - ((zerop (length (mal-data-value ast))) (return ast)) - (t (let ((forms (mal-data-value ast))) - (cond - ((mal-data-value= mal-quote (first forms)) - (return (second forms))) - - ((mal-data-value= mal-quasiquoteexpand (first forms)) - (return (quasiquote (second forms)))) - - ((mal-data-value= mal-quasiquote (first forms)) - (setf ast (quasiquote (second forms)))) - - ((mal-data-value= mal-def! (first forms)) - (return (env:set-env env (second forms) (mal-eval (third forms) env)))) - - ((mal-data-value= mal-let* (first forms)) - (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (mal-data-value (second forms))))) - - (mapcar (lambda (binding) - (env:set-env new-env - (car binding) - (mal-eval (or (cdr binding) - mal-nil) - new-env))) - (loop - for (symbol value) on bindings - by #'cddr - collect (cons symbol value))) - (setf ast (third forms) - env new-env))) - - ((mal-data-value= mal-do (first forms)) - (mapc (lambda (form) (mal-eval form env)) - (butlast (cdr forms))) - (setf ast (car (last forms)))) - - ((mal-data-value= mal-if (first forms)) - (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (mal-data-value= predicate mal-nil) - (mal-data-value= predicate mal-false)) - (fourth forms) - (third forms))))) - - ((mal-data-value= mal-fn* (first forms)) - (return (let ((arglist (second forms)) - (body (third forms))) - (make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (listify (mal-data-value arglist)) - :exprs args))) - :attrs (list (cons :params arglist) - (cons :ast body) - (cons :env env)))))) - - (t (let* ((evaluated-list (eval-ast ast env)) - (function (car evaluated-list))) - ;; If first element is a mal function unwrap it - (if (not (mal-fn-p function)) - (return (apply (mal-data-value function) - (cdr evaluated-list))) - (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc :ast attrs)) - env (env:create-mal-env :parent (cdr (assoc :env attrs)) - :binds (map 'list - #'identity - (mal-data-value (cdr (assoc :params attrs)))) - :exprs (cdr evaluated-list))))))))))))) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) *repl-env*)) - (error (condition) - (format nil "~a" condition)))) - -(env:set-env *repl-env* - (make-mal-symbol "eval") - (make-mal-builtin-fn (lambda (ast) - (mal-eval ast *repl-env*)))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") - -(defvar *use-readline-p* nil) - -(defun complete-toplevel-symbols (input &rest ignored) - (declare (ignorable ignored)) - - (let (candidates) - (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) - when (let ((pos (search input key))) (and pos (zerop pos))) - do (push key candidates)) - - (if (= 1 (length candidates)) - (cons (car candidates) candidates) - (cons (apply #'utils:common-prefix candidates) candidates)))) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun repl () - (loop do (let ((line (mal-readline "user> "))) - (if line - (mal-writeline (rep line)) - (return))))) - -(defun run-file (file) - (rep (format nil "(load-file \"~a\")" file))) - -(defun main (&optional (argv nil argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") - (string= (utils:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - ;; CCL fails with a error while registering completion function - ;; See also https://github.com/mrkkrp/cl-readline/issues/5 - #-ccl (rl:register-function :complete #'complete-toplevel-symbols) - - (let ((args (if argv-provided-p - argv - (cdr (utils:raw-command-line-arguments))))) - (env:set-env *repl-env* - (make-mal-symbol "*ARGV*") - (make-mal-list (mapcar #'make-mal-string (cdr args)))) - (if (null args) - (repl) - (run-file (car args))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :types + :env + :reader + :printer + :core) + (:import-from :cl-readline + :readline + :register-function) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv + :common-prefix) + (:export :main)) + +(in-package :mal) + +(defvar *repl-env* (env:create-mal-env)) + +(dolist (binding core:ns) + (env:set-env *repl-env* (car binding) (cdr binding))) + +(defvar mal-def! (make-mal-symbol "def!")) +(defvar mal-let* (make-mal-symbol "let*")) +(defvar mal-do (make-mal-symbol "do")) +(defvar mal-if (make-mal-symbol "if")) +(defvar mal-fn* (make-mal-symbol "fn*")) +(defvar mal-quote (make-mal-symbol "quote")) +(defvar mal-quasiquote (make-mal-symbol "quasiquote")) +(defvar mal-quasiquoteexpand (make-mal-symbol "quasiquoteexpand")) +(defvar mal-unquote (make-mal-symbol "unquote")) +(defvar mal-splice-unquote (make-mal-symbol "splice-unquote")) +(defvar mal-vec (make-mal-symbol "vec")) +(defvar mal-cons (make-mal-symbol "cons")) +(defvar mal-concat (make-mal-symbol "concat")) + +(defun eval-sequence (sequence env) + (map 'list + (lambda (ast) (mal-eval ast env)) + (mal-data-value sequence))) + +(defun eval-hash-map (hash-map env) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref key new-hash-table) + (mal-eval value env))) + hash-map-value) + (make-mal-hash-map new-hash-table))) + +(defun eval-ast (ast env) + (switch-mal-type ast + (types:symbol (env:get-env env ast)) + (types:list (eval-sequence ast env)) + (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) + (types:hash-map (eval-hash-map ast env)) + (types:any ast))) + +(defun qq-reducer (elt acc) + (make-mal-list + (if (and (mal-list-p elt) + (mal-data-value= (first (mal-data-value elt)) mal-splice-unquote)) + (list mal-concat (second (mal-data-value elt)) acc) + (list mal-cons (quasiquote elt) acc)))) +(defun qq-iter (elts) + (reduce #'qq-reducer elts :from-end t :initial-value (make-mal-list ()))) +(defun quasiquote (ast) + (switch-mal-type ast + (types:list (if (mal-data-value= (first (mal-data-value ast)) mal-unquote) + (second (mal-data-value ast)) + (qq-iter (mal-data-value ast)))) + (types:vector (make-mal-list (list mal-vec (qq-iter (listify (mal-data-value ast)))))) + (types:hash-map (make-mal-list (list mal-quote ast))) + (types:symbol (make-mal-list (list mal-quote ast))) + (types:any ast))) + + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (loop + do (cond + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) + ((zerop (length (mal-data-value ast))) (return ast)) + (t (let ((forms (mal-data-value ast))) + (cond + ((mal-data-value= mal-quote (first forms)) + (return (second forms))) + + ((mal-data-value= mal-quasiquoteexpand (first forms)) + (return (quasiquote (second forms)))) + + ((mal-data-value= mal-quasiquote (first forms)) + (setf ast (quasiquote (second forms)))) + + ((mal-data-value= mal-def! (first forms)) + (return (env:set-env env (second forms) (mal-eval (third forms) env)))) + + ((mal-data-value= mal-let* (first forms)) + (let ((new-env (env:create-mal-env :parent env)) + (bindings (utils:listify (mal-data-value (second forms))))) + + (mapcar (lambda (binding) + (env:set-env new-env + (car binding) + (mal-eval (or (cdr binding) + mal-nil) + new-env))) + (loop + for (symbol value) on bindings + by #'cddr + collect (cons symbol value))) + (setf ast (third forms) + env new-env))) + + ((mal-data-value= mal-do (first forms)) + (mapc (lambda (form) (mal-eval form env)) + (butlast (cdr forms))) + (setf ast (car (last forms)))) + + ((mal-data-value= mal-if (first forms)) + (let ((predicate (mal-eval (second forms) env))) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) + (fourth forms) + (third forms))))) + + ((mal-data-value= mal-fn* (first forms)) + (return (let ((arglist (second forms)) + (body (third forms))) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env)))))) + + (t (let* ((evaluated-list (eval-ast ast env)) + (function (car evaluated-list))) + ;; If first element is a mal function unwrap it + (if (not (mal-fn-p function)) + (return (apply (mal-data-value function) + (cdr evaluated-list))) + (let* ((attrs (mal-data-attrs function))) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) + :binds (map 'list + #'identity + (mal-data-value (cdr (assoc :params attrs)))) + :exprs (cdr evaluated-list))))))))))))) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) *repl-env*)) + (error (condition) + (format nil "~a" condition)))) + +(env:set-env *repl-env* + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) + (mal-eval ast *repl-env*)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") + +(defvar *use-readline-p* nil) + +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun repl () + (loop do (let ((line (mal-readline "user> "))) + (if line + (mal-writeline (rep line)) + (return))))) + +(defun run-file (file) + (rep (format nil "(load-file \"~a\")" file))) + +(defun main (&optional (argv nil argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + (let ((args (if argv-provided-p + argv + (cdr (utils:raw-command-line-arguments))))) + (env:set-env *repl-env* + (make-mal-symbol "*ARGV*") + (make-mal-list (mapcar #'make-mal-string (cdr args)))) + (if (null args) + (repl) + (run-file (car args))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/step8_macros.lisp b/impls/common-lisp/src/step8_macros.lisp index 3f5e5dd663..50ca085d80 100644 --- a/impls/common-lisp/src/step8_macros.lisp +++ b/impls/common-lisp/src/step8_macros.lisp @@ -1,315 +1,315 @@ -(defpackage :mal - (:use :common-lisp - :types - :env - :reader - :printer - :core) - (:import-from :cl-readline - :readline - :register-function) - (:import-from :genhash - :hashref - :hashmap) - (:import-from :utils - :listify - :getenv - :common-prefix) - (:export :main)) - -(in-package :mal) - -(define-condition invalid-function (mal-runtime-exception) - ((form :initarg :form :reader form) - (context :initarg :context :reader context)) - (:report (lambda (condition stream) - (format stream - "Invalid function '~a' provided while ~a" - (printer:pr-str (form condition)) - (if (string= (context condition) "apply") - "applying" - "defining macro"))))) - - -(defvar *repl-env* (env:create-mal-env)) - -(dolist (binding core:ns) - (env:set-env *repl-env* (car binding) (cdr binding))) - -(defvar mal-def! (make-mal-symbol "def!")) -(defvar mal-let* (make-mal-symbol "let*")) -(defvar mal-do (make-mal-symbol "do")) -(defvar mal-if (make-mal-symbol "if")) -(defvar mal-fn* (make-mal-symbol "fn*")) -(defvar mal-quote (make-mal-symbol "quote")) -(defvar mal-quasiquote (make-mal-symbol "quasiquote")) -(defvar mal-quasiquoteexpand (make-mal-symbol "quasiquoteexpand")) -(defvar mal-unquote (make-mal-symbol "unquote")) -(defvar mal-splice-unquote (make-mal-symbol "splice-unquote")) -(defvar mal-vec (make-mal-symbol "vec")) -(defvar mal-cons (make-mal-symbol "cons")) -(defvar mal-concat (make-mal-symbol "concat")) -(defvar mal-defmacro! (make-mal-symbol "defmacro!")) -(defvar mal-macroexpand (make-mal-symbol "macroexpand")) - -(defun eval-sequence (sequence env) - (map 'list - (lambda (ast) (mal-eval ast env)) - (mal-data-value sequence))) - -(defun eval-hash-map (hash-map env) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref key new-hash-table) - (mal-eval value env))) - hash-map-value) - (make-mal-hash-map new-hash-table))) - -(defun eval-ast (ast env) - (switch-mal-type ast - (types:symbol (env:get-env env ast)) - (types:list (eval-sequence ast env)) - (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) - (types:hash-map (eval-hash-map ast env)) - (types:any ast))) - -(defun qq-reducer (elt acc) - (make-mal-list - (if (and (mal-list-p elt) - (mal-data-value= (first (mal-data-value elt)) mal-splice-unquote)) - (list mal-concat (second (mal-data-value elt)) acc) - (list mal-cons (quasiquote elt) acc)))) -(defun qq-iter (elts) - (reduce #'qq-reducer elts :from-end t :initial-value (make-mal-list ()))) -(defun quasiquote (ast) - (switch-mal-type ast - (types:list (if (mal-data-value= (first (mal-data-value ast)) mal-unquote) - (second (mal-data-value ast)) - (qq-iter (mal-data-value ast)))) - (types:vector (make-mal-list (list mal-vec (qq-iter (listify (mal-data-value ast)))))) - (types:hash-map (make-mal-list (list mal-quote ast))) - (types:symbol (make-mal-list (list mal-quote ast))) - (types:any ast))) - -(defun is-macro-call (ast env) - (when (mal-list-p ast) - (let* ((func-symbol (first (mal-data-value ast))) - (func (when (mal-symbol-p func-symbol) - (env:find-env env func-symbol)))) - (and func - (mal-fn-p func) - (cdr (assoc :is-macro (mal-data-attrs func))))))) - -(defun mal-macroexpand (ast env) - (loop - while (is-macro-call ast env) - do (let* ((forms (mal-data-value ast)) - (func (env:get-env env (first forms)))) - (setf ast (apply (mal-data-value func) - (cdr forms))))) - ast) - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (loop - do (setf ast (mal-macroexpand ast env)) - do (cond - ((null ast) (return mal-nil)) - ((not (mal-list-p ast)) (return (eval-ast ast env))) - ((zerop (length (mal-data-value ast))) (return ast)) - (t (let ((forms (mal-data-value ast))) - (cond - ((mal-data-value= mal-quote (first forms)) - (return (second forms))) - - ((mal-data-value= mal-quasiquoteexpand (first forms)) - (return (quasiquote (second forms)))) - - ((mal-data-value= mal-quasiquote (first forms)) - (setf ast (quasiquote (second forms)))) - - ((mal-data-value= mal-macroexpand (first forms)) - (return (mal-macroexpand (second forms) env))) - - ((mal-data-value= mal-def! (first forms)) - (return (env:set-env env (second forms) (mal-eval (third forms) env)))) - - ((mal-data-value= mal-defmacro! (first forms)) - (let ((value (mal-eval (third forms) env))) - (return (if (mal-fn-p value) - (env:set-env env - (second forms) - (progn - (setf (cdr (assoc :is-macro (mal-data-attrs value))) t) - value)) - (error 'invalid-function - :form value - :context "macro"))))) - - ((mal-data-value= mal-let* (first forms)) - (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (mal-data-value (second forms))))) - - (mapcar (lambda (binding) - (env:set-env new-env - (car binding) - (mal-eval (or (cdr binding) - mal-nil) - new-env))) - (loop - for (symbol value) on bindings - by #'cddr - collect (cons symbol value))) - (setf ast (third forms) - env new-env))) - - ((mal-data-value= mal-do (first forms)) - (mapc (lambda (form) (mal-eval form env)) - (butlast (cdr forms))) - (setf ast (car (last forms)))) - - ((mal-data-value= mal-if (first forms)) - (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (mal-data-value= predicate mal-nil) - (mal-data-value= predicate mal-false)) - (fourth forms) - (third forms))))) - - ((mal-data-value= mal-fn* (first forms)) - (return (let ((arglist (second forms)) - (body (third forms))) - (make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (listify (mal-data-value arglist)) - :exprs args))) - :attrs (list (cons :params arglist) - (cons :ast body) - (cons :env env) - (cons :is-macro nil)))))) - - (t (let* ((evaluated-list (eval-ast ast env)) - (function (car evaluated-list))) - ;; If first element is a mal function unwrap it - (cond ((mal-fn-p function) - (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc :ast attrs)) - env (env:create-mal-env :parent (cdr (assoc :env attrs)) - :binds (map 'list - #'identity - (mal-data-value (cdr (assoc :params attrs)))) - :exprs (cdr evaluated-list))))) - ((mal-builtin-fn-p function) - (return (apply (mal-data-value function) - (cdr evaluated-list)))) - (t (error 'invalid-function - :form function - :context "apply"))))))))))) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) *repl-env*)) - (mal-error (condition) - (format nil "~a" condition)) - (error (condition) - (format nil "Internal error: ~a" condition)))) - -(env:set-env *repl-env* - (make-mal-symbol "eval") - (make-mal-builtin-fn (lambda (ast) - (mal-eval ast *repl-env*)))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") -(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)))))))") - -(defvar *use-readline-p* nil) - -(defun complete-toplevel-symbols (input &rest ignored) - (declare (ignorable ignored)) - - (let (candidates) - (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) - when (let ((pos (search input key))) (and pos (zerop pos))) - do (push key candidates)) - - (if (= 1 (length candidates)) - (cons (car candidates) candidates) - (cons (apply #'utils:common-prefix candidates) candidates)))) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun repl () - (loop do (let ((line (mal-readline "user> "))) - (if line - (mal-writeline (rep line)) - (return))))) - -(defun run-file (file) - (rep (format nil "(load-file \"~a\")" file))) - -(defun main (&optional (argv nil argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") - (string= (utils:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - ;; CCL fails with a error while registering completion function - ;; See also https://github.com/mrkkrp/cl-readline/issues/5 - #-ccl (rl:register-function :complete #'complete-toplevel-symbols) - - (let ((args (if argv-provided-p - argv - (cdr (utils:raw-command-line-arguments))))) - (env:set-env *repl-env* - (make-mal-symbol "*ARGV*") - (make-mal-list (mapcar #'make-mal-string (cdr args)))) - (if (null args) - (repl) - (run-file (car args))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :types + :env + :reader + :printer + :core) + (:import-from :cl-readline + :readline + :register-function) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv + :common-prefix) + (:export :main)) + +(in-package :mal) + +(define-condition invalid-function (mal-runtime-exception) + ((form :initarg :form :reader form) + (context :initarg :context :reader context)) + (:report (lambda (condition stream) + (format stream + "Invalid function '~a' provided while ~a" + (printer:pr-str (form condition)) + (if (string= (context condition) "apply") + "applying" + "defining macro"))))) + + +(defvar *repl-env* (env:create-mal-env)) + +(dolist (binding core:ns) + (env:set-env *repl-env* (car binding) (cdr binding))) + +(defvar mal-def! (make-mal-symbol "def!")) +(defvar mal-let* (make-mal-symbol "let*")) +(defvar mal-do (make-mal-symbol "do")) +(defvar mal-if (make-mal-symbol "if")) +(defvar mal-fn* (make-mal-symbol "fn*")) +(defvar mal-quote (make-mal-symbol "quote")) +(defvar mal-quasiquote (make-mal-symbol "quasiquote")) +(defvar mal-quasiquoteexpand (make-mal-symbol "quasiquoteexpand")) +(defvar mal-unquote (make-mal-symbol "unquote")) +(defvar mal-splice-unquote (make-mal-symbol "splice-unquote")) +(defvar mal-vec (make-mal-symbol "vec")) +(defvar mal-cons (make-mal-symbol "cons")) +(defvar mal-concat (make-mal-symbol "concat")) +(defvar mal-defmacro! (make-mal-symbol "defmacro!")) +(defvar mal-macroexpand (make-mal-symbol "macroexpand")) + +(defun eval-sequence (sequence env) + (map 'list + (lambda (ast) (mal-eval ast env)) + (mal-data-value sequence))) + +(defun eval-hash-map (hash-map env) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref key new-hash-table) + (mal-eval value env))) + hash-map-value) + (make-mal-hash-map new-hash-table))) + +(defun eval-ast (ast env) + (switch-mal-type ast + (types:symbol (env:get-env env ast)) + (types:list (eval-sequence ast env)) + (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) + (types:hash-map (eval-hash-map ast env)) + (types:any ast))) + +(defun qq-reducer (elt acc) + (make-mal-list + (if (and (mal-list-p elt) + (mal-data-value= (first (mal-data-value elt)) mal-splice-unquote)) + (list mal-concat (second (mal-data-value elt)) acc) + (list mal-cons (quasiquote elt) acc)))) +(defun qq-iter (elts) + (reduce #'qq-reducer elts :from-end t :initial-value (make-mal-list ()))) +(defun quasiquote (ast) + (switch-mal-type ast + (types:list (if (mal-data-value= (first (mal-data-value ast)) mal-unquote) + (second (mal-data-value ast)) + (qq-iter (mal-data-value ast)))) + (types:vector (make-mal-list (list mal-vec (qq-iter (listify (mal-data-value ast)))))) + (types:hash-map (make-mal-list (list mal-quote ast))) + (types:symbol (make-mal-list (list mal-quote ast))) + (types:any ast))) + +(defun is-macro-call (ast env) + (when (mal-list-p ast) + (let* ((func-symbol (first (mal-data-value ast))) + (func (when (mal-symbol-p func-symbol) + (env:find-env env func-symbol)))) + (and func + (mal-fn-p func) + (cdr (assoc :is-macro (mal-data-attrs func))))))) + +(defun mal-macroexpand (ast env) + (loop + while (is-macro-call ast env) + do (let* ((forms (mal-data-value ast)) + (func (env:get-env env (first forms)))) + (setf ast (apply (mal-data-value func) + (cdr forms))))) + ast) + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (loop + do (setf ast (mal-macroexpand ast env)) + do (cond + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) + ((zerop (length (mal-data-value ast))) (return ast)) + (t (let ((forms (mal-data-value ast))) + (cond + ((mal-data-value= mal-quote (first forms)) + (return (second forms))) + + ((mal-data-value= mal-quasiquoteexpand (first forms)) + (return (quasiquote (second forms)))) + + ((mal-data-value= mal-quasiquote (first forms)) + (setf ast (quasiquote (second forms)))) + + ((mal-data-value= mal-macroexpand (first forms)) + (return (mal-macroexpand (second forms) env))) + + ((mal-data-value= mal-def! (first forms)) + (return (env:set-env env (second forms) (mal-eval (third forms) env)))) + + ((mal-data-value= mal-defmacro! (first forms)) + (let ((value (mal-eval (third forms) env))) + (return (if (mal-fn-p value) + (env:set-env env + (second forms) + (progn + (setf (cdr (assoc :is-macro (mal-data-attrs value))) t) + value)) + (error 'invalid-function + :form value + :context "macro"))))) + + ((mal-data-value= mal-let* (first forms)) + (let ((new-env (env:create-mal-env :parent env)) + (bindings (utils:listify (mal-data-value (second forms))))) + + (mapcar (lambda (binding) + (env:set-env new-env + (car binding) + (mal-eval (or (cdr binding) + mal-nil) + new-env))) + (loop + for (symbol value) on bindings + by #'cddr + collect (cons symbol value))) + (setf ast (third forms) + env new-env))) + + ((mal-data-value= mal-do (first forms)) + (mapc (lambda (form) (mal-eval form env)) + (butlast (cdr forms))) + (setf ast (car (last forms)))) + + ((mal-data-value= mal-if (first forms)) + (let ((predicate (mal-eval (second forms) env))) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) + (fourth forms) + (third forms))))) + + ((mal-data-value= mal-fn* (first forms)) + (return (let ((arglist (second forms)) + (body (third forms))) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env) + (cons :is-macro nil)))))) + + (t (let* ((evaluated-list (eval-ast ast env)) + (function (car evaluated-list))) + ;; If first element is a mal function unwrap it + (cond ((mal-fn-p function) + (let* ((attrs (mal-data-attrs function))) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) + :binds (map 'list + #'identity + (mal-data-value (cdr (assoc :params attrs)))) + :exprs (cdr evaluated-list))))) + ((mal-builtin-fn-p function) + (return (apply (mal-data-value function) + (cdr evaluated-list)))) + (t (error 'invalid-function + :form function + :context "apply"))))))))))) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) *repl-env*)) + (mal-error (condition) + (format nil "~a" condition)) + (error (condition) + (format nil "Internal error: ~a" condition)))) + +(env:set-env *repl-env* + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) + (mal-eval ast *repl-env*)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") +(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)))))))") + +(defvar *use-readline-p* nil) + +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun repl () + (loop do (let ((line (mal-readline "user> "))) + (if line + (mal-writeline (rep line)) + (return))))) + +(defun run-file (file) + (rep (format nil "(load-file \"~a\")" file))) + +(defun main (&optional (argv nil argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + (let ((args (if argv-provided-p + argv + (cdr (utils:raw-command-line-arguments))))) + (env:set-env *repl-env* + (make-mal-symbol "*ARGV*") + (make-mal-list (mapcar #'make-mal-string (cdr args)))) + (if (null args) + (repl) + (run-file (car args))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/step9_try.lisp b/impls/common-lisp/src/step9_try.lisp index a696115196..964b785eba 100644 --- a/impls/common-lisp/src/step9_try.lisp +++ b/impls/common-lisp/src/step9_try.lisp @@ -1,339 +1,339 @@ -(defpackage :mal - (:use :common-lisp - :types - :env - :reader - :printer - :core) - (:import-from :cl-readline - :readline - :register-function) - (:import-from :genhash - :hashref - :hashmap) - (:import-from :utils - :listify - :getenv - :common-prefix) - (:export :main)) - -(in-package :mal) - -(define-condition invalid-function (mal-runtime-exception) - ((form :initarg :form :reader form) - (context :initarg :context :reader context)) - (:report (lambda (condition stream) - (format stream - "Invalid function '~a' provided while ~a" - (printer:pr-str (form condition)) - (if (string= (context condition) "apply") - "applying" - "defining macro"))))) - - -(defvar *repl-env* (env:create-mal-env)) - -(dolist (binding core:ns) - (env:set-env *repl-env* (car binding) (cdr binding))) - -(defvar mal-def! (make-mal-symbol "def!")) -(defvar mal-let* (make-mal-symbol "let*")) -(defvar mal-do (make-mal-symbol "do")) -(defvar mal-if (make-mal-symbol "if")) -(defvar mal-fn* (make-mal-symbol "fn*")) -(defvar mal-quote (make-mal-symbol "quote")) -(defvar mal-quasiquote (make-mal-symbol "quasiquote")) -(defvar mal-quasiquoteexpand (make-mal-symbol "quasiquoteexpand")) -(defvar mal-unquote (make-mal-symbol "unquote")) -(defvar mal-splice-unquote (make-mal-symbol "splice-unquote")) -(defvar mal-vec (make-mal-symbol "vec")) -(defvar mal-cons (make-mal-symbol "cons")) -(defvar mal-concat (make-mal-symbol "concat")) -(defvar mal-defmacro! (make-mal-symbol "defmacro!")) -(defvar mal-macroexpand (make-mal-symbol "macroexpand")) -(defvar mal-try* (make-mal-symbol "try*")) -(defvar mal-catch* (make-mal-symbol "catch*")) -(defvar mal-throw (make-mal-symbol "throw")) - -(defun eval-sequence (sequence env) - (map 'list - (lambda (ast) (mal-eval ast env)) - (mal-data-value sequence))) - -(defun eval-hash-map (hash-map env) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref key new-hash-table) - (mal-eval value env))) - hash-map-value) - (make-mal-hash-map new-hash-table))) - -(defun eval-ast (ast env) - (switch-mal-type ast - (types:symbol (env:get-env env ast)) - (types:list (eval-sequence ast env)) - (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) - (types:hash-map (eval-hash-map ast env)) - (types:any ast))) - -(defun qq-reducer (elt acc) - (make-mal-list - (if (and (mal-list-p elt) - (mal-data-value= (first (mal-data-value elt)) mal-splice-unquote)) - (list mal-concat (second (mal-data-value elt)) acc) - (list mal-cons (quasiquote elt) acc)))) -(defun qq-iter (elts) - (reduce #'qq-reducer elts :from-end t :initial-value (make-mal-list ()))) -(defun quasiquote (ast) - (switch-mal-type ast - (types:list (if (mal-data-value= (first (mal-data-value ast)) mal-unquote) - (second (mal-data-value ast)) - (qq-iter (mal-data-value ast)))) - (types:vector (make-mal-list (list mal-vec (qq-iter (listify (mal-data-value ast)))))) - (types:hash-map (make-mal-list (list mal-quote ast))) - (types:symbol (make-mal-list (list mal-quote ast))) - (types:any ast))) - -(defun is-macro-call (ast env) - (when (mal-list-p ast) - (let* ((func-symbol (first (mal-data-value ast))) - (func (when (mal-symbol-p func-symbol) - (env:find-env env func-symbol)))) - (and func - (mal-fn-p func) - (cdr (assoc :is-macro (mal-data-attrs func))))))) - -(defun mal-macroexpand (ast env) - (loop - while (is-macro-call ast env) - do (let* ((forms (mal-data-value ast)) - (func (env:get-env env (first forms)))) - (setf ast (apply (mal-data-value func) - (cdr forms))))) - ast) - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (loop - do (setf ast (mal-macroexpand ast env)) - do (cond - ((null ast) (return mal-nil)) - ((not (mal-list-p ast)) (return (eval-ast ast env))) - ((zerop (length (mal-data-value ast))) (return ast)) - (t (let ((forms (mal-data-value ast))) - (cond - ((mal-data-value= mal-quote (first forms)) - (return (second forms))) - - ((mal-data-value= mal-quasiquoteexpand (first forms)) - (return (quasiquote (second forms)))) - - ((mal-data-value= mal-quasiquote (first forms)) - (setf ast (quasiquote (second forms)))) - - ((mal-data-value= mal-macroexpand (first forms)) - (return (mal-macroexpand (second forms) env))) - - ((mal-data-value= mal-def! (first forms)) - (return (env:set-env env (second forms) (mal-eval (third forms) env)))) - - ((mal-data-value= mal-defmacro! (first forms)) - (let ((value (mal-eval (third forms) env))) - (return (if (mal-fn-p value) - (env:set-env env - (second forms) - (progn - (setf (cdr (assoc :is-macro (mal-data-attrs value))) t) - value)) - (error 'invalid-function - :form value - :context "macro"))))) - - ((mal-data-value= mal-let* (first forms)) - (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (mal-data-value (second forms))))) - - (mapcar (lambda (binding) - (env:set-env new-env - (car binding) - (mal-eval (or (cdr binding) - mal-nil) - new-env))) - (loop - for (symbol value) on bindings - by #'cddr - collect (cons symbol value))) - (setf ast (third forms) - env new-env))) - - ((mal-data-value= mal-do (first forms)) - (mapc (lambda (form) (mal-eval form env)) - (butlast (cdr forms))) - (setf ast (car (last forms)))) - - ((mal-data-value= mal-if (first forms)) - (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (mal-data-value= predicate mal-nil) - (mal-data-value= predicate mal-false)) - (fourth forms) - (third forms))))) - - ((mal-data-value= mal-fn* (first forms)) - (return (let ((arglist (second forms)) - (body (third forms))) - (make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (listify (mal-data-value arglist)) - :exprs args))) - :attrs (list (cons :params arglist) - (cons :ast body) - (cons :env env) - (cons :is-macro nil)))))) - - ((mal-data-value= mal-try* (first forms)) - (if (not (third forms)) - (return (mal-eval (second forms) env)) - (handler-case - (return (mal-eval (second forms) env)) - (error (condition) - (let ((catch-forms (mal-data-value (third forms)))) - (when (mal-data-value= mal-catch* - (first catch-forms)) - (return (mal-eval (third catch-forms) - (env:create-mal-env :parent env - :binds (list (second catch-forms)) - :exprs (list (if (typep condition 'mal-user-exception) - (mal-exception-data condition) - (make-mal-string (format nil "~a" condition))))))))))))) - - (t (let* ((evaluated-list (eval-ast ast env)) - (function (car evaluated-list))) - ;; If first element is a mal function unwrap it - (cond ((mal-fn-p function) - (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc :ast attrs)) - env (env:create-mal-env :parent (cdr (assoc :env attrs)) - :binds (map 'list - #'identity - (mal-data-value (cdr (assoc :params attrs)))) - :exprs (cdr evaluated-list))))) - ((mal-builtin-fn-p function) - (return (apply (mal-data-value function) - (cdr evaluated-list)))) - (t (error 'invalid-function - :form function - :context "apply"))))))))))) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) *repl-env*)) - (mal-error (condition) - (format nil "Error: ~a" condition)) - (mal-runtime-exception (condition) - (format nil "Exception: ~a" condition)) - (mal-user-exception (condition) - (format nil "Exception: ~a" (pr-str (mal-exception-data condition)))) - (error (condition) - (format nil "Internal error: ~a" condition)))) - -(env:set-env *repl-env* - (make-mal-symbol "eval") - (make-mal-builtin-fn (lambda (ast) - (mal-eval ast *repl-env*)))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") -(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)))))))") - -(defvar *use-readline-p* nil) - -(defun complete-toplevel-symbols (input &rest ignored) - (declare (ignorable ignored)) - - (let (candidates) - (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) - when (let ((pos (search input key))) (and pos (zerop pos))) - do (push key candidates)) - - (if (= 1 (length candidates)) - (cons (car candidates) candidates) - (cons (apply #'utils:common-prefix candidates) candidates)))) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun repl () - (loop do (let ((line (mal-readline "user> "))) - (if line - (mal-writeline (rep line)) - (return))))) - -(defun run-file (file) - (rep (format nil "(load-file \"~a\")" file))) - -(defun main (&optional (argv nil argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") - (string= (uiop:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - ;; CCL fails with a error while registering completion function - ;; See also https://github.com/mrkkrp/cl-readline/issues/5 - #-ccl (rl:register-function :complete #'complete-toplevel-symbols) - - - (let ((args (if argv-provided-p - argv - (cdr (utils:raw-command-line-arguments))))) - (env:set-env *repl-env* - (make-mal-symbol "*ARGV*") - (make-mal-list (mapcar #'make-mal-string (cdr args)))) - (if (null args) - (repl) - (run-file (car args))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail. - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :types + :env + :reader + :printer + :core) + (:import-from :cl-readline + :readline + :register-function) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv + :common-prefix) + (:export :main)) + +(in-package :mal) + +(define-condition invalid-function (mal-runtime-exception) + ((form :initarg :form :reader form) + (context :initarg :context :reader context)) + (:report (lambda (condition stream) + (format stream + "Invalid function '~a' provided while ~a" + (printer:pr-str (form condition)) + (if (string= (context condition) "apply") + "applying" + "defining macro"))))) + + +(defvar *repl-env* (env:create-mal-env)) + +(dolist (binding core:ns) + (env:set-env *repl-env* (car binding) (cdr binding))) + +(defvar mal-def! (make-mal-symbol "def!")) +(defvar mal-let* (make-mal-symbol "let*")) +(defvar mal-do (make-mal-symbol "do")) +(defvar mal-if (make-mal-symbol "if")) +(defvar mal-fn* (make-mal-symbol "fn*")) +(defvar mal-quote (make-mal-symbol "quote")) +(defvar mal-quasiquote (make-mal-symbol "quasiquote")) +(defvar mal-quasiquoteexpand (make-mal-symbol "quasiquoteexpand")) +(defvar mal-unquote (make-mal-symbol "unquote")) +(defvar mal-splice-unquote (make-mal-symbol "splice-unquote")) +(defvar mal-vec (make-mal-symbol "vec")) +(defvar mal-cons (make-mal-symbol "cons")) +(defvar mal-concat (make-mal-symbol "concat")) +(defvar mal-defmacro! (make-mal-symbol "defmacro!")) +(defvar mal-macroexpand (make-mal-symbol "macroexpand")) +(defvar mal-try* (make-mal-symbol "try*")) +(defvar mal-catch* (make-mal-symbol "catch*")) +(defvar mal-throw (make-mal-symbol "throw")) + +(defun eval-sequence (sequence env) + (map 'list + (lambda (ast) (mal-eval ast env)) + (mal-data-value sequence))) + +(defun eval-hash-map (hash-map env) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref key new-hash-table) + (mal-eval value env))) + hash-map-value) + (make-mal-hash-map new-hash-table))) + +(defun eval-ast (ast env) + (switch-mal-type ast + (types:symbol (env:get-env env ast)) + (types:list (eval-sequence ast env)) + (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) + (types:hash-map (eval-hash-map ast env)) + (types:any ast))) + +(defun qq-reducer (elt acc) + (make-mal-list + (if (and (mal-list-p elt) + (mal-data-value= (first (mal-data-value elt)) mal-splice-unquote)) + (list mal-concat (second (mal-data-value elt)) acc) + (list mal-cons (quasiquote elt) acc)))) +(defun qq-iter (elts) + (reduce #'qq-reducer elts :from-end t :initial-value (make-mal-list ()))) +(defun quasiquote (ast) + (switch-mal-type ast + (types:list (if (mal-data-value= (first (mal-data-value ast)) mal-unquote) + (second (mal-data-value ast)) + (qq-iter (mal-data-value ast)))) + (types:vector (make-mal-list (list mal-vec (qq-iter (listify (mal-data-value ast)))))) + (types:hash-map (make-mal-list (list mal-quote ast))) + (types:symbol (make-mal-list (list mal-quote ast))) + (types:any ast))) + +(defun is-macro-call (ast env) + (when (mal-list-p ast) + (let* ((func-symbol (first (mal-data-value ast))) + (func (when (mal-symbol-p func-symbol) + (env:find-env env func-symbol)))) + (and func + (mal-fn-p func) + (cdr (assoc :is-macro (mal-data-attrs func))))))) + +(defun mal-macroexpand (ast env) + (loop + while (is-macro-call ast env) + do (let* ((forms (mal-data-value ast)) + (func (env:get-env env (first forms)))) + (setf ast (apply (mal-data-value func) + (cdr forms))))) + ast) + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (loop + do (setf ast (mal-macroexpand ast env)) + do (cond + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) + ((zerop (length (mal-data-value ast))) (return ast)) + (t (let ((forms (mal-data-value ast))) + (cond + ((mal-data-value= mal-quote (first forms)) + (return (second forms))) + + ((mal-data-value= mal-quasiquoteexpand (first forms)) + (return (quasiquote (second forms)))) + + ((mal-data-value= mal-quasiquote (first forms)) + (setf ast (quasiquote (second forms)))) + + ((mal-data-value= mal-macroexpand (first forms)) + (return (mal-macroexpand (second forms) env))) + + ((mal-data-value= mal-def! (first forms)) + (return (env:set-env env (second forms) (mal-eval (third forms) env)))) + + ((mal-data-value= mal-defmacro! (first forms)) + (let ((value (mal-eval (third forms) env))) + (return (if (mal-fn-p value) + (env:set-env env + (second forms) + (progn + (setf (cdr (assoc :is-macro (mal-data-attrs value))) t) + value)) + (error 'invalid-function + :form value + :context "macro"))))) + + ((mal-data-value= mal-let* (first forms)) + (let ((new-env (env:create-mal-env :parent env)) + (bindings (utils:listify (mal-data-value (second forms))))) + + (mapcar (lambda (binding) + (env:set-env new-env + (car binding) + (mal-eval (or (cdr binding) + mal-nil) + new-env))) + (loop + for (symbol value) on bindings + by #'cddr + collect (cons symbol value))) + (setf ast (third forms) + env new-env))) + + ((mal-data-value= mal-do (first forms)) + (mapc (lambda (form) (mal-eval form env)) + (butlast (cdr forms))) + (setf ast (car (last forms)))) + + ((mal-data-value= mal-if (first forms)) + (let ((predicate (mal-eval (second forms) env))) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) + (fourth forms) + (third forms))))) + + ((mal-data-value= mal-fn* (first forms)) + (return (let ((arglist (second forms)) + (body (third forms))) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env) + (cons :is-macro nil)))))) + + ((mal-data-value= mal-try* (first forms)) + (if (not (third forms)) + (return (mal-eval (second forms) env)) + (handler-case + (return (mal-eval (second forms) env)) + (error (condition) + (let ((catch-forms (mal-data-value (third forms)))) + (when (mal-data-value= mal-catch* + (first catch-forms)) + (return (mal-eval (third catch-forms) + (env:create-mal-env :parent env + :binds (list (second catch-forms)) + :exprs (list (if (typep condition 'mal-user-exception) + (mal-exception-data condition) + (make-mal-string (format nil "~a" condition))))))))))))) + + (t (let* ((evaluated-list (eval-ast ast env)) + (function (car evaluated-list))) + ;; If first element is a mal function unwrap it + (cond ((mal-fn-p function) + (let* ((attrs (mal-data-attrs function))) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) + :binds (map 'list + #'identity + (mal-data-value (cdr (assoc :params attrs)))) + :exprs (cdr evaluated-list))))) + ((mal-builtin-fn-p function) + (return (apply (mal-data-value function) + (cdr evaluated-list)))) + (t (error 'invalid-function + :form function + :context "apply"))))))))))) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) *repl-env*)) + (mal-error (condition) + (format nil "Error: ~a" condition)) + (mal-runtime-exception (condition) + (format nil "Exception: ~a" condition)) + (mal-user-exception (condition) + (format nil "Exception: ~a" (pr-str (mal-exception-data condition)))) + (error (condition) + (format nil "Internal error: ~a" condition)))) + +(env:set-env *repl-env* + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) + (mal-eval ast *repl-env*)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") +(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)))))))") + +(defvar *use-readline-p* nil) + +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun repl () + (loop do (let ((line (mal-readline "user> "))) + (if line + (mal-writeline (rep line)) + (return))))) + +(defun run-file (file) + (rep (format nil "(load-file \"~a\")" file))) + +(defun main (&optional (argv nil argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false") + (string= (uiop:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + + (let ((args (if argv-provided-p + argv + (cdr (utils:raw-command-line-arguments))))) + (env:set-env *repl-env* + (make-mal-symbol "*ARGV*") + (make-mal-list (mapcar #'make-mal-string (cdr args)))) + (if (null args) + (repl) + (run-file (car args))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail. + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/stepA_mal.lisp b/impls/common-lisp/src/stepA_mal.lisp index 6e360faa3e..064290f749 100644 --- a/impls/common-lisp/src/stepA_mal.lisp +++ b/impls/common-lisp/src/stepA_mal.lisp @@ -1,347 +1,347 @@ -(defpackage :mal - (:use :common-lisp - :types - :env - :reader - :printer - :core) - (:import-from :cl-readline - :readline - :register-function) - (:import-from :genhash - :hashref - :hashmap) - (:import-from :utils - :listify - :getenv - :common-prefix) - (:export :main)) - -(in-package :mal) - -(define-condition invalid-function (mal-runtime-exception) - ((form :initarg :form :reader form) - (context :initarg :context :reader context)) - (:report (lambda (condition stream) - (format stream - "Invalid function '~a' provided while ~a" - (printer:pr-str (form condition)) - (if (string= (context condition) "apply") - "applying" - "defining macro"))))) - -(defvar *repl-env* (env:create-mal-env)) - -(dolist (binding core:ns) - (env:set-env *repl-env* (car binding) (cdr binding))) - -(defvar mal-def! (make-mal-symbol "def!")) -(defvar mal-let* (make-mal-symbol "let*")) -(defvar mal-do (make-mal-symbol "do")) -(defvar mal-if (make-mal-symbol "if")) -(defvar mal-fn* (make-mal-symbol "fn*")) -(defvar mal-quote (make-mal-symbol "quote")) -(defvar mal-quasiquote (make-mal-symbol "quasiquote")) -(defvar mal-quasiquoteexpand (make-mal-symbol "quasiquoteexpand")) -(defvar mal-unquote (make-mal-symbol "unquote")) -(defvar mal-splice-unquote (make-mal-symbol "splice-unquote")) -(defvar mal-vec (make-mal-symbol "vec")) -(defvar mal-cons (make-mal-symbol "cons")) -(defvar mal-concat (make-mal-symbol "concat")) -(defvar mal-defmacro! (make-mal-symbol "defmacro!")) -(defvar mal-macroexpand (make-mal-symbol "macroexpand")) -(defvar mal-try* (make-mal-symbol "try*")) -(defvar mal-catch* (make-mal-symbol "catch*")) -(defvar mal-throw (make-mal-symbol "throw")) - -(defun eval-sequence (sequence env) - (map 'list - (lambda (ast) (mal-eval ast env)) - (mal-data-value sequence))) - -(defun eval-hash-map (hash-map env) - (let ((hash-map-value (mal-data-value hash-map)) - (new-hash-table (make-mal-value-hash-table))) - (genhash:hashmap (lambda (key value) - (setf (genhash:hashref key new-hash-table) - (mal-eval value env))) - hash-map-value) - (make-mal-hash-map new-hash-table))) - -(defun eval-ast (ast env) - (switch-mal-type ast - (types:symbol (env:get-env env ast)) - (types:list (eval-sequence ast env)) - (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) - (types:hash-map (eval-hash-map ast env)) - (types:any ast))) - -(defun qq-reducer (elt acc) - (make-mal-list - (if (and (mal-list-p elt) - (mal-data-value= (first (mal-data-value elt)) mal-splice-unquote)) - (list mal-concat (second (mal-data-value elt)) acc) - (list mal-cons (quasiquote elt) acc)))) -(defun qq-iter (elts) - (reduce #'qq-reducer elts :from-end t :initial-value (make-mal-list ()))) -(defun quasiquote (ast) - (switch-mal-type ast - (types:list (if (mal-data-value= (first (mal-data-value ast)) mal-unquote) - (second (mal-data-value ast)) - (qq-iter (mal-data-value ast)))) - (types:vector (make-mal-list (list mal-vec (qq-iter (listify (mal-data-value ast)))))) - (types:hash-map (make-mal-list (list mal-quote ast))) - (types:symbol (make-mal-list (list mal-quote ast))) - (types:any ast))) - -(defun is-macro-call (ast env) - (when (mal-list-p ast) - (let* ((func-symbol (first (mal-data-value ast))) - (func (when (mal-symbol-p func-symbol) - (env:find-env env func-symbol)))) - (and func - (mal-fn-p func) - (cdr (assoc :is-macro (mal-data-attrs func))))))) - -(defun mal-macroexpand (ast env) - (loop - while (is-macro-call ast env) - do (let* ((forms (mal-data-value ast)) - (func (env:get-env env (first forms)))) - (setf ast (apply (mal-data-value func) - (cdr forms))))) - ast) - -(defun mal-read (string) - (reader:read-str string)) - -(defun mal-eval (ast env) - (loop - do (setf ast (mal-macroexpand ast env)) - do (cond - ((null ast) (return mal-nil)) - ((not (mal-list-p ast)) (return (eval-ast ast env))) - ((zerop (length (mal-data-value ast))) (return ast)) - (t (let ((forms (mal-data-value ast))) - (cond - ((mal-data-value= mal-quote (first forms)) - (return (second forms))) - - ((mal-data-value= mal-quasiquoteexpand (first forms)) - (return (quasiquote (second forms)))) - - ((mal-data-value= mal-quasiquote (first forms)) - (setf ast (quasiquote (second forms)))) - - ((mal-data-value= mal-macroexpand (first forms)) - (return (mal-macroexpand (second forms) env))) - - ((mal-data-value= mal-def! (first forms)) - (return (env:set-env env (second forms) (mal-eval (third forms) env)))) - - ((mal-data-value= mal-defmacro! (first forms)) - (let ((value (mal-eval (third forms) env))) - (return (if (mal-fn-p value) - (env:set-env env - (second forms) - (progn - (setf (cdr (assoc :is-macro (mal-data-attrs value))) t) - value)) - (error 'invalid-function - :form value - :context "macro"))))) - - ((mal-data-value= mal-let* (first forms)) - (let ((new-env (env:create-mal-env :parent env)) - (bindings (utils:listify (mal-data-value (second forms))))) - - (mapcar (lambda (binding) - (env:set-env new-env - (car binding) - (mal-eval (or (cdr binding) - mal-nil) - new-env))) - (loop - for (symbol value) on bindings - by #'cddr - collect (cons symbol value))) - (setf ast (third forms) - env new-env))) - - ((mal-data-value= mal-do (first forms)) - (mapc (lambda (form) (mal-eval form env)) - (butlast (cdr forms))) - (setf ast (car (last forms)))) - - ((mal-data-value= mal-if (first forms)) - (let ((predicate (mal-eval (second forms) env))) - (setf ast (if (or (mal-data-value= predicate mal-nil) - (mal-data-value= predicate mal-false)) - (fourth forms) - (third forms))))) - - ((mal-data-value= mal-fn* (first forms)) - (return (let ((arglist (second forms)) - (body (third forms))) - (make-mal-fn (lambda (&rest args) - (mal-eval body (env:create-mal-env :parent env - :binds (listify (mal-data-value arglist)) - :exprs args))) - :attrs (list (cons :params arglist) - (cons :ast body) - (cons :env env) - (cons :is-macro nil)))))) - - ((mal-data-value= mal-try* (first forms)) - (if (not (third forms)) - (return (mal-eval (second forms) env)) - (handler-case - (return (mal-eval (second forms) env)) - (error (condition) - (let ((catch-forms (mal-data-value (third forms)))) - (when (mal-data-value= mal-catch* - (first catch-forms)) - (return (mal-eval (third catch-forms) - (env:create-mal-env :parent env - :binds (list (second catch-forms)) - :exprs (list (if (typep condition 'mal-user-exception) - (mal-exception-data condition) - (make-mal-string (format nil "~a" condition))))))))))))) - - (t (let* ((evaluated-list (eval-ast ast env)) - (function (car evaluated-list))) - ;; If first element is a mal function unwrap it - (cond ((mal-fn-p function) - (let* ((attrs (mal-data-attrs function))) - (setf ast (cdr (assoc :ast attrs)) - env (env:create-mal-env :parent (cdr (assoc :env attrs)) - :binds (map 'list - #'identity - (mal-data-value (cdr (assoc :params attrs)))) - :exprs (cdr evaluated-list))))) - ((mal-builtin-fn-p function) - (return (apply (mal-data-value function) - (cdr evaluated-list)))) - (t (error 'invalid-function - :form function - :context "apply"))))))))))) - -(defun mal-print (expression) - (printer:pr-str expression)) - -(defun rep (string) - (handler-case - (mal-print (mal-eval (mal-read string) *repl-env*)) - (mal-error (condition) - (format nil "Error: ~a" condition)) - (mal-runtime-exception (condition) - (format nil "Exception: ~a" condition)) - (mal-user-exception (condition) - (format nil "Exception: ~a" (pr-str (mal-exception-data condition)))) - (error (condition) - (format nil "Internal error: ~a" condition)))) - -(env:set-env *repl-env* - (make-mal-symbol "eval") - (make-mal-builtin-fn (lambda (ast) - (mal-eval ast *repl-env*)))) - -(env:set-env *repl-env* - (make-mal-symbol "*cl-implementation*") - (make-mal-string (lisp-implementation-type))) - -(env:set-env *repl-env* - (make-mal-symbol "*cl-version*") - (make-mal-string (lisp-implementation-version))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") -(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 "(def! *host-language* \"common-lisp\")") - -(defvar *use-readline-p* nil) - -(defun complete-toplevel-symbols (input &rest ignored) - (declare (ignorable ignored)) - - (let (candidates) - (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) - when (let ((pos (search input key))) (and pos (zerop pos))) - do (push key candidates)) - - (if (= 1 (length candidates)) - (cons (car candidates) candidates) - (cons (apply #'utils:common-prefix candidates) candidates)))) - -(defun raw-input (prompt) - (format *standard-output* prompt) - (force-output *standard-output*) - (read-line *standard-input* nil)) - -(defun mal-readline (prompt) - (if *use-readline-p* - (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) - (raw-input prompt))) - -(defun mal-writeline (string) - (when string - (write-line string) - (force-output *standard-output*))) - -(defun repl () - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (loop do (let ((line (mal-readline "user> "))) - (if line - (mal-writeline (rep line)) - (return))))) - -(defun run-file (file) - (rep (format nil "(load-file \"~a\")" file))) - -(defun main (&optional (argv nil argv-provided-p)) - - (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") - (string= (utils:getenv "TERM") "dumb")))) - - ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort - ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment - ;; variable which the test runner sets causing `read-line' on *standard-input* - ;; to fail with an empty stream error. The following reinitializes the - ;; standard streams - ;; - ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html - #+clisp (setf *standard-input* (ext:make-stream :input) - *standard-output* (ext:make-stream :output :buffered t) - *error-output* (ext:make-stream :error :buffered t)) - - ;; CCL fails with a error while registering completion function - ;; See also https://github.com/mrkkrp/cl-readline/issues/5 - #-ccl (rl:register-function :complete #'complete-toplevel-symbols) - - (let ((args (if argv-provided-p - argv - (cdr (utils:raw-command-line-arguments))))) - (env:set-env *repl-env* - (make-mal-symbol "*ARGV*") - (make-mal-list (mapcar #'make-mal-string (cdr args)))) - (if (null args) - (repl) - (run-file (car args))))) - -;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an -;;; image containing foreign libraries is restored. The extra messages cause the -;;; MAL testcases to fail - -#+cmucl (progn - (defvar *old-standard-output* *standard-output* - "Keep track of current value standard output, this is restored after image restore completes") - - (defun muffle-output () - (setf *standard-output* (make-broadcast-stream))) - - (defun restore-output () - (setf *standard-output* *old-standard-output*)) - - (pushnew #'muffle-output ext:*after-save-initializations*) - (setf ext:*after-save-initializations* - (append ext:*after-save-initializations* (list #'restore-output)))) +(defpackage :mal + (:use :common-lisp + :types + :env + :reader + :printer + :core) + (:import-from :cl-readline + :readline + :register-function) + (:import-from :genhash + :hashref + :hashmap) + (:import-from :utils + :listify + :getenv + :common-prefix) + (:export :main)) + +(in-package :mal) + +(define-condition invalid-function (mal-runtime-exception) + ((form :initarg :form :reader form) + (context :initarg :context :reader context)) + (:report (lambda (condition stream) + (format stream + "Invalid function '~a' provided while ~a" + (printer:pr-str (form condition)) + (if (string= (context condition) "apply") + "applying" + "defining macro"))))) + +(defvar *repl-env* (env:create-mal-env)) + +(dolist (binding core:ns) + (env:set-env *repl-env* (car binding) (cdr binding))) + +(defvar mal-def! (make-mal-symbol "def!")) +(defvar mal-let* (make-mal-symbol "let*")) +(defvar mal-do (make-mal-symbol "do")) +(defvar mal-if (make-mal-symbol "if")) +(defvar mal-fn* (make-mal-symbol "fn*")) +(defvar mal-quote (make-mal-symbol "quote")) +(defvar mal-quasiquote (make-mal-symbol "quasiquote")) +(defvar mal-quasiquoteexpand (make-mal-symbol "quasiquoteexpand")) +(defvar mal-unquote (make-mal-symbol "unquote")) +(defvar mal-splice-unquote (make-mal-symbol "splice-unquote")) +(defvar mal-vec (make-mal-symbol "vec")) +(defvar mal-cons (make-mal-symbol "cons")) +(defvar mal-concat (make-mal-symbol "concat")) +(defvar mal-defmacro! (make-mal-symbol "defmacro!")) +(defvar mal-macroexpand (make-mal-symbol "macroexpand")) +(defvar mal-try* (make-mal-symbol "try*")) +(defvar mal-catch* (make-mal-symbol "catch*")) +(defvar mal-throw (make-mal-symbol "throw")) + +(defun eval-sequence (sequence env) + (map 'list + (lambda (ast) (mal-eval ast env)) + (mal-data-value sequence))) + +(defun eval-hash-map (hash-map env) + (let ((hash-map-value (mal-data-value hash-map)) + (new-hash-table (make-mal-value-hash-table))) + (genhash:hashmap (lambda (key value) + (setf (genhash:hashref key new-hash-table) + (mal-eval value env))) + hash-map-value) + (make-mal-hash-map new-hash-table))) + +(defun eval-ast (ast env) + (switch-mal-type ast + (types:symbol (env:get-env env ast)) + (types:list (eval-sequence ast env)) + (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env)))) + (types:hash-map (eval-hash-map ast env)) + (types:any ast))) + +(defun qq-reducer (elt acc) + (make-mal-list + (if (and (mal-list-p elt) + (mal-data-value= (first (mal-data-value elt)) mal-splice-unquote)) + (list mal-concat (second (mal-data-value elt)) acc) + (list mal-cons (quasiquote elt) acc)))) +(defun qq-iter (elts) + (reduce #'qq-reducer elts :from-end t :initial-value (make-mal-list ()))) +(defun quasiquote (ast) + (switch-mal-type ast + (types:list (if (mal-data-value= (first (mal-data-value ast)) mal-unquote) + (second (mal-data-value ast)) + (qq-iter (mal-data-value ast)))) + (types:vector (make-mal-list (list mal-vec (qq-iter (listify (mal-data-value ast)))))) + (types:hash-map (make-mal-list (list mal-quote ast))) + (types:symbol (make-mal-list (list mal-quote ast))) + (types:any ast))) + +(defun is-macro-call (ast env) + (when (mal-list-p ast) + (let* ((func-symbol (first (mal-data-value ast))) + (func (when (mal-symbol-p func-symbol) + (env:find-env env func-symbol)))) + (and func + (mal-fn-p func) + (cdr (assoc :is-macro (mal-data-attrs func))))))) + +(defun mal-macroexpand (ast env) + (loop + while (is-macro-call ast env) + do (let* ((forms (mal-data-value ast)) + (func (env:get-env env (first forms)))) + (setf ast (apply (mal-data-value func) + (cdr forms))))) + ast) + +(defun mal-read (string) + (reader:read-str string)) + +(defun mal-eval (ast env) + (loop + do (setf ast (mal-macroexpand ast env)) + do (cond + ((null ast) (return mal-nil)) + ((not (mal-list-p ast)) (return (eval-ast ast env))) + ((zerop (length (mal-data-value ast))) (return ast)) + (t (let ((forms (mal-data-value ast))) + (cond + ((mal-data-value= mal-quote (first forms)) + (return (second forms))) + + ((mal-data-value= mal-quasiquoteexpand (first forms)) + (return (quasiquote (second forms)))) + + ((mal-data-value= mal-quasiquote (first forms)) + (setf ast (quasiquote (second forms)))) + + ((mal-data-value= mal-macroexpand (first forms)) + (return (mal-macroexpand (second forms) env))) + + ((mal-data-value= mal-def! (first forms)) + (return (env:set-env env (second forms) (mal-eval (third forms) env)))) + + ((mal-data-value= mal-defmacro! (first forms)) + (let ((value (mal-eval (third forms) env))) + (return (if (mal-fn-p value) + (env:set-env env + (second forms) + (progn + (setf (cdr (assoc :is-macro (mal-data-attrs value))) t) + value)) + (error 'invalid-function + :form value + :context "macro"))))) + + ((mal-data-value= mal-let* (first forms)) + (let ((new-env (env:create-mal-env :parent env)) + (bindings (utils:listify (mal-data-value (second forms))))) + + (mapcar (lambda (binding) + (env:set-env new-env + (car binding) + (mal-eval (or (cdr binding) + mal-nil) + new-env))) + (loop + for (symbol value) on bindings + by #'cddr + collect (cons symbol value))) + (setf ast (third forms) + env new-env))) + + ((mal-data-value= mal-do (first forms)) + (mapc (lambda (form) (mal-eval form env)) + (butlast (cdr forms))) + (setf ast (car (last forms)))) + + ((mal-data-value= mal-if (first forms)) + (let ((predicate (mal-eval (second forms) env))) + (setf ast (if (or (mal-data-value= predicate mal-nil) + (mal-data-value= predicate mal-false)) + (fourth forms) + (third forms))))) + + ((mal-data-value= mal-fn* (first forms)) + (return (let ((arglist (second forms)) + (body (third forms))) + (make-mal-fn (lambda (&rest args) + (mal-eval body (env:create-mal-env :parent env + :binds (listify (mal-data-value arglist)) + :exprs args))) + :attrs (list (cons :params arglist) + (cons :ast body) + (cons :env env) + (cons :is-macro nil)))))) + + ((mal-data-value= mal-try* (first forms)) + (if (not (third forms)) + (return (mal-eval (second forms) env)) + (handler-case + (return (mal-eval (second forms) env)) + (error (condition) + (let ((catch-forms (mal-data-value (third forms)))) + (when (mal-data-value= mal-catch* + (first catch-forms)) + (return (mal-eval (third catch-forms) + (env:create-mal-env :parent env + :binds (list (second catch-forms)) + :exprs (list (if (typep condition 'mal-user-exception) + (mal-exception-data condition) + (make-mal-string (format nil "~a" condition))))))))))))) + + (t (let* ((evaluated-list (eval-ast ast env)) + (function (car evaluated-list))) + ;; If first element is a mal function unwrap it + (cond ((mal-fn-p function) + (let* ((attrs (mal-data-attrs function))) + (setf ast (cdr (assoc :ast attrs)) + env (env:create-mal-env :parent (cdr (assoc :env attrs)) + :binds (map 'list + #'identity + (mal-data-value (cdr (assoc :params attrs)))) + :exprs (cdr evaluated-list))))) + ((mal-builtin-fn-p function) + (return (apply (mal-data-value function) + (cdr evaluated-list)))) + (t (error 'invalid-function + :form function + :context "apply"))))))))))) + +(defun mal-print (expression) + (printer:pr-str expression)) + +(defun rep (string) + (handler-case + (mal-print (mal-eval (mal-read string) *repl-env*)) + (mal-error (condition) + (format nil "Error: ~a" condition)) + (mal-runtime-exception (condition) + (format nil "Exception: ~a" condition)) + (mal-user-exception (condition) + (format nil "Exception: ~a" (pr-str (mal-exception-data condition)))) + (error (condition) + (format nil "Internal error: ~a" condition)))) + +(env:set-env *repl-env* + (make-mal-symbol "eval") + (make-mal-builtin-fn (lambda (ast) + (mal-eval ast *repl-env*)))) + +(env:set-env *repl-env* + (make-mal-symbol "*cl-implementation*") + (make-mal-string (lisp-implementation-type))) + +(env:set-env *repl-env* + (make-mal-symbol "*cl-version*") + (make-mal-string (lisp-implementation-version))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") +(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 "(def! *host-language* \"common-lisp\")") + +(defvar *use-readline-p* nil) + +(defun complete-toplevel-symbols (input &rest ignored) + (declare (ignorable ignored)) + + (let (candidates) + (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*) + when (let ((pos (search input key))) (and pos (zerop pos))) + do (push key candidates)) + + (if (= 1 (length candidates)) + (cons (car candidates) candidates) + (cons (apply #'utils:common-prefix candidates) candidates)))) + +(defun raw-input (prompt) + (format *standard-output* prompt) + (force-output *standard-output*) + (read-line *standard-input* nil)) + +(defun mal-readline (prompt) + (if *use-readline-p* + (rl:readline :prompt prompt :add-history t :novelty-check #'string/=) + (raw-input prompt))) + +(defun mal-writeline (string) + (when string + (write-line string) + (force-output *standard-output*))) + +(defun repl () + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (loop do (let ((line (mal-readline "user> "))) + (if line + (mal-writeline (rep line)) + (return))))) + +(defun run-file (file) + (rep (format nil "(load-file \"~a\")" file))) + +(defun main (&optional (argv nil argv-provided-p)) + + (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false") + (string= (utils:getenv "TERM") "dumb")))) + + ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort + ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment + ;; variable which the test runner sets causing `read-line' on *standard-input* + ;; to fail with an empty stream error. The following reinitializes the + ;; standard streams + ;; + ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html + #+clisp (setf *standard-input* (ext:make-stream :input) + *standard-output* (ext:make-stream :output :buffered t) + *error-output* (ext:make-stream :error :buffered t)) + + ;; CCL fails with a error while registering completion function + ;; See also https://github.com/mrkkrp/cl-readline/issues/5 + #-ccl (rl:register-function :complete #'complete-toplevel-symbols) + + (let ((args (if argv-provided-p + argv + (cdr (utils:raw-command-line-arguments))))) + (env:set-env *repl-env* + (make-mal-symbol "*ARGV*") + (make-mal-list (mapcar #'make-mal-string (cdr args)))) + (if (null args) + (repl) + (run-file (car args))))) + +;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an +;;; image containing foreign libraries is restored. The extra messages cause the +;;; MAL testcases to fail + +#+cmucl (progn + (defvar *old-standard-output* *standard-output* + "Keep track of current value standard output, this is restored after image restore completes") + + (defun muffle-output () + (setf *standard-output* (make-broadcast-stream))) + + (defun restore-output () + (setf *standard-output* *old-standard-output*)) + + (pushnew #'muffle-output ext:*after-save-initializations*) + (setf ext:*after-save-initializations* + (append ext:*after-save-initializations* (list #'restore-output)))) diff --git a/impls/common-lisp/src/types.lisp b/impls/common-lisp/src/types.lisp index f9f05a232d..715f9f8122 100644 --- a/impls/common-lisp/src/types.lisp +++ b/impls/common-lisp/src/types.lisp @@ -1,193 +1,193 @@ -(defpackage :types - (:use :common-lisp - :genhash) - (:import-from :utils - :listify) - (:export :mal-data-value= - ;; Accessors - :mal-data-value - :mal-data-type - :mal-data-meta - :mal-data-attrs - ;; Mal values - :number - :make-mal-number - :mal-number-p - - :boolean - :mal-boolean-p - - :nil - :mal-nil-p - - :string - :make-mal-string - :mal-string-p - - :symbol - :make-mal-symbol - :mal-symbol-p - - :keyword - :make-mal-keyword - :mal-keyword-p - - :list - :make-mal-list - :mal-list-p - - :vector - :make-mal-vector - :mal-vector-p - - :hash-map - :make-mal-hash-map - :mal-hash-map-p - - :atom - :make-mal-atom - :mal-atom-p - - :builtin-fn - :make-mal-builtin-fn - :mal-builtin-fn-p - - :fn - :make-mal-fn - :mal-fn-p - - :any - :switch-mal-type - - ;; Singleton values - :mal-nil - :mal-true - :mal-false - - ;; Hashing mal values - :make-mal-value-hash-table - ;; Error types - :mal-exception - :mal-exception-data - ;; Exceptions raised by the runtime - :mal-runtime-exception - ;; Exception raised by user code - :mal-user-exception - ;; Error - :mal-error)) - -(in-package :types) - -(define-condition mal-error (error) nil) - -(define-condition mal-exception (error) nil) - -(define-condition mal-runtime-exception (mal-exception) nil) - -(define-condition mal-user-exception (mal-exception) - ((data :accessor mal-exception-data :initarg :data))) - -(defstruct mal-data - (value nil) - (type nil :read-only t) - meta - attrs) - -;; Create a constructor and predicate for given type -(defmacro define-mal-type (type) - (let ((constructor (intern (format nil "MAKE-MAL-~a" (symbol-name type)))) - (predicate (intern (format nil "MAL-~a-P" (symbol-name type))))) - `(progn (defun ,constructor (value &key meta attrs) - (make-mal-data :type ',type - :value value - :meta meta - :attrs attrs)) - - (defun ,predicate (value) - (when (typep value 'mal-data) - (eq (mal-data-type value) ',type)))))) - -(define-mal-type number) -(define-mal-type symbol) -(define-mal-type keyword) -(define-mal-type string) -(define-mal-type boolean) -(define-mal-type nil) - -(define-mal-type list) -(define-mal-type vector) -(define-mal-type hash-map) - -(define-mal-type atom) - -(define-mal-type fn) -(define-mal-type builtin-fn) - -(defvar mal-nil (make-mal-nil nil)) -(defvar mal-true (make-mal-boolean t)) -(defvar mal-false (make-mal-boolean nil)) - -;; Generic type -(defvar any) - -(defmacro switch-mal-type (ast &body forms) - `(let ((type (mal-data-type ,ast))) - (cond - ,@(mapcar (lambda (form) - (list (or (equal (car form) t) - (equal (car form) 'any) - (list 'equal (list 'quote (car form)) 'type)) - (cadr form))) - forms)))) - -(defun mal-sequence= (value1 value2) - (let ((sequence1 (listify (mal-data-value value1))) - (sequence2 (listify (mal-data-value value2)))) - - (when (= (length sequence1) (length sequence2)) - (every #'identity (loop for x in sequence1 - for y in sequence2 - collect (mal-data-value= x y)))))) - -(defun mal-hash-map= (value1 value2) - (let ((map1 (mal-data-value value1)) - (map2 (mal-data-value value2)) - (identical t)) - (when (= (generic-hash-table-count map1) - (generic-hash-table-count map2)) - (hashmap (lambda (key value) - (declare (ignorable value)) - (setf identical - (and identical (mal-data-value= (hashref key map1) - (hashref key map2))))) - map1) - identical))) - -(defun mal-data-value= (value1 value2) - (when (and (typep value1 'mal-data) - (typep value2 'mal-data)) - - (if (equal (mal-data-type value1) (mal-data-type value2)) - (switch-mal-type value1 - (list (mal-sequence= value1 value2)) - (vector (mal-sequence= value1 value2)) - (hash-map (mal-hash-map= value1 value2)) - (any (equal (mal-data-value value1) (mal-data-value value2)))) - (when (or (and (mal-list-p value1) (mal-vector-p value2)) - (and (mal-list-p value2) (mal-vector-p value1))) - (mal-sequence= value1 value2))))) - -(defun mal-sxhash (value) - (sxhash (mal-data-value value))) - -(defun make-mal-value-hash-table () - (unless (gethash 'mal-data-value-hash genhash::*hash-test-designator-map*) - ;; ECL, ABCL and MKCL's implementations of sxhash do not work well with - ;; compound types, use a custom hash function which hashes the underlying - ;; value instead - (let ((hash-function #+(or ecl abcl mkcl) #'mal-sxhash - #-(or ecl abcl mkcl) #'sxhash)) - (register-test-designator 'mal-data-value-hash - hash-function - #'mal-data-value=))) - (make-generic-hash-table :test 'mal-data-value-hash)) +(defpackage :types + (:use :common-lisp + :genhash) + (:import-from :utils + :listify) + (:export :mal-data-value= + ;; Accessors + :mal-data-value + :mal-data-type + :mal-data-meta + :mal-data-attrs + ;; Mal values + :number + :make-mal-number + :mal-number-p + + :boolean + :mal-boolean-p + + :nil + :mal-nil-p + + :string + :make-mal-string + :mal-string-p + + :symbol + :make-mal-symbol + :mal-symbol-p + + :keyword + :make-mal-keyword + :mal-keyword-p + + :list + :make-mal-list + :mal-list-p + + :vector + :make-mal-vector + :mal-vector-p + + :hash-map + :make-mal-hash-map + :mal-hash-map-p + + :atom + :make-mal-atom + :mal-atom-p + + :builtin-fn + :make-mal-builtin-fn + :mal-builtin-fn-p + + :fn + :make-mal-fn + :mal-fn-p + + :any + :switch-mal-type + + ;; Singleton values + :mal-nil + :mal-true + :mal-false + + ;; Hashing mal values + :make-mal-value-hash-table + ;; Error types + :mal-exception + :mal-exception-data + ;; Exceptions raised by the runtime + :mal-runtime-exception + ;; Exception raised by user code + :mal-user-exception + ;; Error + :mal-error)) + +(in-package :types) + +(define-condition mal-error (error) nil) + +(define-condition mal-exception (error) nil) + +(define-condition mal-runtime-exception (mal-exception) nil) + +(define-condition mal-user-exception (mal-exception) + ((data :accessor mal-exception-data :initarg :data))) + +(defstruct mal-data + (value nil) + (type nil :read-only t) + meta + attrs) + +;; Create a constructor and predicate for given type +(defmacro define-mal-type (type) + (let ((constructor (intern (format nil "MAKE-MAL-~a" (symbol-name type)))) + (predicate (intern (format nil "MAL-~a-P" (symbol-name type))))) + `(progn (defun ,constructor (value &key meta attrs) + (make-mal-data :type ',type + :value value + :meta meta + :attrs attrs)) + + (defun ,predicate (value) + (when (typep value 'mal-data) + (eq (mal-data-type value) ',type)))))) + +(define-mal-type number) +(define-mal-type symbol) +(define-mal-type keyword) +(define-mal-type string) +(define-mal-type boolean) +(define-mal-type nil) + +(define-mal-type list) +(define-mal-type vector) +(define-mal-type hash-map) + +(define-mal-type atom) + +(define-mal-type fn) +(define-mal-type builtin-fn) + +(defvar mal-nil (make-mal-nil nil)) +(defvar mal-true (make-mal-boolean t)) +(defvar mal-false (make-mal-boolean nil)) + +;; Generic type +(defvar any) + +(defmacro switch-mal-type (ast &body forms) + `(let ((type (mal-data-type ,ast))) + (cond + ,@(mapcar (lambda (form) + (list (or (equal (car form) t) + (equal (car form) 'any) + (list 'equal (list 'quote (car form)) 'type)) + (cadr form))) + forms)))) + +(defun mal-sequence= (value1 value2) + (let ((sequence1 (listify (mal-data-value value1))) + (sequence2 (listify (mal-data-value value2)))) + + (when (= (length sequence1) (length sequence2)) + (every #'identity (loop for x in sequence1 + for y in sequence2 + collect (mal-data-value= x y)))))) + +(defun mal-hash-map= (value1 value2) + (let ((map1 (mal-data-value value1)) + (map2 (mal-data-value value2)) + (identical t)) + (when (= (generic-hash-table-count map1) + (generic-hash-table-count map2)) + (hashmap (lambda (key value) + (declare (ignorable value)) + (setf identical + (and identical (mal-data-value= (hashref key map1) + (hashref key map2))))) + map1) + identical))) + +(defun mal-data-value= (value1 value2) + (when (and (typep value1 'mal-data) + (typep value2 'mal-data)) + + (if (equal (mal-data-type value1) (mal-data-type value2)) + (switch-mal-type value1 + (list (mal-sequence= value1 value2)) + (vector (mal-sequence= value1 value2)) + (hash-map (mal-hash-map= value1 value2)) + (any (equal (mal-data-value value1) (mal-data-value value2)))) + (when (or (and (mal-list-p value1) (mal-vector-p value2)) + (and (mal-list-p value2) (mal-vector-p value1))) + (mal-sequence= value1 value2))))) + +(defun mal-sxhash (value) + (sxhash (mal-data-value value))) + +(defun make-mal-value-hash-table () + (unless (gethash 'mal-data-value-hash genhash::*hash-test-designator-map*) + ;; ECL, ABCL and MKCL's implementations of sxhash do not work well with + ;; compound types, use a custom hash function which hashes the underlying + ;; value instead + (let ((hash-function #+(or ecl abcl mkcl) #'mal-sxhash + #-(or ecl abcl mkcl) #'sxhash)) + (register-test-designator 'mal-data-value-hash + hash-function + #'mal-data-value=))) + (make-generic-hash-table :test 'mal-data-value-hash)) diff --git a/impls/common-lisp/src/utils.lisp b/impls/common-lisp/src/utils.lisp index 95eadf5dab..530565ceb0 100644 --- a/impls/common-lisp/src/utils.lisp +++ b/impls/common-lisp/src/utils.lisp @@ -1,42 +1,42 @@ -(defpackage :utils - (:use :common-lisp - :uiop) - (:export :replace-all - :getenv - :read-file-string - :raw-command-line-arguments - :listify - :common-prefix)) - -(in-package :utils) - -(defun replace-all (string part replacement &key (test #'char=)) - "Returns a new string in which all the occurences of the part -is replaced with replacement." - (with-output-to-string (out) - (loop with part-length = (length part) - for old-pos = 0 then (+ pos part-length) - for pos = (search part string - :start2 old-pos - :test test) - do (write-string string out - :start old-pos - :end (or pos (length string))) - when pos do (write-string replacement out) - while pos))) - -(defun listify (sequence) - "Convert a sequence to a list" - (map 'list #'identity sequence)) - -(defun common-prefix (&rest strings) - (if (not strings) - "" - (let* ((char-lists (mapcar (lambda (string) (coerce string 'list)) strings)) - (char-tuples (apply #'mapcar #'list char-lists)) - (count 0)) - (loop for char-tuple in char-tuples - while (every (lambda (char) (equal char (car char-tuple))) char-tuple) - do (incf count)) - - (subseq (car strings) 0 count)))) +(defpackage :utils + (:use :common-lisp + :uiop) + (:export :replace-all + :getenv + :read-file-string + :raw-command-line-arguments + :listify + :common-prefix)) + +(in-package :utils) + +(defun replace-all (string part replacement &key (test #'char=)) + "Returns a new string in which all the occurences of the part +is replaced with replacement." + (with-output-to-string (out) + (loop with part-length = (length part) + for old-pos = 0 then (+ pos part-length) + for pos = (search part string + :start2 old-pos + :test test) + do (write-string string out + :start old-pos + :end (or pos (length string))) + when pos do (write-string replacement out) + while pos))) + +(defun listify (sequence) + "Convert a sequence to a list" + (map 'list #'identity sequence)) + +(defun common-prefix (&rest strings) + (if (not strings) + "" + (let* ((char-lists (mapcar (lambda (string) (coerce string 'list)) strings)) + (char-tuples (apply #'mapcar #'list char-lists)) + (count 0)) + (loop for char-tuple in char-tuples + while (every (lambda (char) (equal char (car char-tuple))) char-tuple) + do (incf count)) + + (subseq (car strings) 0 count)))) diff --git a/impls/common-lisp/step0_repl.asd b/impls/common-lisp/step0_repl.asd index 57f978b66a..2e75ef06e0 100644 --- a/impls/common-lisp/step0_repl.asd +++ b/impls/common-lisp/step0_repl.asd @@ -1,24 +1,24 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step0_repl" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 0 of MAL in Common Lisp" - :serial t - :components ((:file "step0_repl")) - :depends-on (:uiop :cl-readline) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step0_repl" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 0 of MAL in Common Lisp" + :serial t + :components ((:file "step0_repl")) + :depends-on (:uiop :cl-readline) + :pathname "src/") diff --git a/impls/common-lisp/step1_read_print.asd b/impls/common-lisp/step1_read_print.asd index 814538c6db..24adf1481f 100644 --- a/impls/common-lisp/step1_read_print.asd +++ b/impls/common-lisp/step1_read_print.asd @@ -1,32 +1,32 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step1_read_print" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 1 of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "reader") - (:file "printer") - (:file "step1_read_print")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step1_read_print" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 1 of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "reader") + (:file "printer") + (:file "step1_read_print")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/step2_eval.asd b/impls/common-lisp/step2_eval.asd index f83e21e5fe..4515bd21ba 100644 --- a/impls/common-lisp/step2_eval.asd +++ b/impls/common-lisp/step2_eval.asd @@ -1,33 +1,33 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step2_eval" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 2 of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "env") - (:file "reader") - (:file "printer") - (:file "step2_eval")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step2_eval" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 2 of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "env") + (:file "reader") + (:file "printer") + (:file "step2_eval")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/step3_env.asd b/impls/common-lisp/step3_env.asd index 804921a499..c96853968e 100644 --- a/impls/common-lisp/step3_env.asd +++ b/impls/common-lisp/step3_env.asd @@ -1,33 +1,33 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step3_env" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 3 of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "env") - (:file "reader") - (:file "printer") - (:file "step3_env")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step3_env" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 3 of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "env") + (:file "reader") + (:file "printer") + (:file "step3_env")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/step4_if_fn_do.asd b/impls/common-lisp/step4_if_fn_do.asd index a2a7f44c08..3fae3379c7 100644 --- a/impls/common-lisp/step4_if_fn_do.asd +++ b/impls/common-lisp/step4_if_fn_do.asd @@ -1,34 +1,34 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step4_if_fn_do" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 4 of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "env") - (:file "reader") - (:file "printer") - (:file "core") - (:file "step4_if_fn_do")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step4_if_fn_do" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 4 of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "env") + (:file "reader") + (:file "printer") + (:file "core") + (:file "step4_if_fn_do")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/step5_tco.asd b/impls/common-lisp/step5_tco.asd index aa684ab52f..3878e6bd84 100644 --- a/impls/common-lisp/step5_tco.asd +++ b/impls/common-lisp/step5_tco.asd @@ -1,34 +1,34 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step5_tco" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 5 of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "env") - (:file "reader") - (:file "printer") - (:file "core") - (:file "step5_tco")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step5_tco" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 5 of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "env") + (:file "reader") + (:file "printer") + (:file "core") + (:file "step5_tco")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/step6_file.asd b/impls/common-lisp/step6_file.asd index 594ad8969b..42c0b18149 100644 --- a/impls/common-lisp/step6_file.asd +++ b/impls/common-lisp/step6_file.asd @@ -1,34 +1,34 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step6_file" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 6 of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "env") - (:file "reader") - (:file "printer") - (:file "core") - (:file "step6_file")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step6_file" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 6 of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "env") + (:file "reader") + (:file "printer") + (:file "core") + (:file "step6_file")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/step7_quote.asd b/impls/common-lisp/step7_quote.asd index cf0ca7bff5..c8ab97c222 100644 --- a/impls/common-lisp/step7_quote.asd +++ b/impls/common-lisp/step7_quote.asd @@ -1,34 +1,34 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step7_quote" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 7 of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "env") - (:file "reader") - (:file "printer") - (:file "core") - (:file "step7_quote")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step7_quote" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 7 of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "env") + (:file "reader") + (:file "printer") + (:file "core") + (:file "step7_quote")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/step8_macros.asd b/impls/common-lisp/step8_macros.asd index 5d6fdc7912..e87e8d849c 100644 --- a/impls/common-lisp/step8_macros.asd +++ b/impls/common-lisp/step8_macros.asd @@ -1,34 +1,34 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step8_macros" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 8 of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "env") - (:file "reader") - (:file "printer") - (:file "core") - (:file "step8_macros")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step8_macros" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 8 of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "env") + (:file "reader") + (:file "printer") + (:file "core") + (:file "step8_macros")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/step9_try.asd b/impls/common-lisp/step9_try.asd index 2a07db6cf4..0538aafdd2 100644 --- a/impls/common-lisp/step9_try.asd +++ b/impls/common-lisp/step9_try.asd @@ -1,34 +1,34 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "step9_try" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of step 9 of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "env") - (:file "reader") - (:file "printer") - (:file "core") - (:file "step9_try")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "step9_try" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of step 9 of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "env") + (:file "reader") + (:file "printer") + (:file "core") + (:file "step9_try")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/stepA_mal.asd b/impls/common-lisp/stepA_mal.asd index d8dc2774b4..1e9500970e 100644 --- a/impls/common-lisp/stepA_mal.asd +++ b/impls/common-lisp/stepA_mal.asd @@ -1,34 +1,34 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -(ql:quickload :uiop :silent t :verbose nil) -(ql:quickload :cl-ppcre :silent t) -(ql:quickload :genhash :silent t) -(ql:quickload :alexandria :silent t) - -#-mkcl (ql:quickload :cl-readline :silent t) -#+mkcl (load "fake-readline.lisp") - -(defpackage #:mal-asd - (:use :cl :asdf)) - -(in-package :mal-asd) - -(defsystem "stepA_mal" - :name "MAL" - :version "1.0" - :author "Iqbal Ansari" - :description "Implementation of MAL in Common Lisp" - :serial t - :components ((:file "utils") - (:file "types") - (:file "env") - (:file "reader") - (:file "printer") - (:file "core") - (:file "stepA_mal")) - :depends-on (:uiop :cl-readline :cl-ppcre :genhash) - :pathname "src/") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + +(ql:quickload :uiop :silent t :verbose nil) +(ql:quickload :cl-ppcre :silent t) +(ql:quickload :genhash :silent t) +(ql:quickload :alexandria :silent t) + +#-mkcl (ql:quickload :cl-readline :silent t) +#+mkcl (load "fake-readline.lisp") + +(defpackage #:mal-asd + (:use :cl :asdf)) + +(in-package :mal-asd) + +(defsystem "stepA_mal" + :name "MAL" + :version "1.0" + :author "Iqbal Ansari" + :description "Implementation of MAL in Common Lisp" + :serial t + :components ((:file "utils") + (:file "types") + (:file "env") + (:file "reader") + (:file "printer") + (:file "core") + (:file "stepA_mal")) + :depends-on (:uiop :cl-readline :cl-ppcre :genhash) + :pathname "src/") diff --git a/impls/common-lisp/tests/stepA_mal.mal b/impls/common-lisp/tests/stepA_mal.mal index 69fe1351a9..5be7514c84 100644 --- a/impls/common-lisp/tests/stepA_mal.mal +++ b/impls/common-lisp/tests/stepA_mal.mal @@ -1,61 +1,61 @@ -;; Testing clisp interop - -(cl-eval "42") -;=>42 - -(cl-eval "(+ 1 1)") -;=>2 - -(cl-eval "(setq foo 1 bar 2 baz 3)") - -(cl-eval "(list foo bar baz)") -;=>(1 2 3) - -(cl-eval "7") -;=>7 - -;; -;; Testing boolean flag -(cl-eval "(= 123 123)" true) -;=>true - -(cl-eval "(= 123 456)") -;=>nil - -(cl-eval "(= 123 456)" true) -;=>false - -;; -;; Testing list flag -(cl-eval "(last nil)" false true) -;=>() - -(cl-eval "nil" false true) -;=>() - -(cl-eval "nil") -;=>nil - -;; -;; Testing creation of Common Lisp Objects -(cl-eval "#(1 2)") -;=>[1 2] - -;;; Not testing with elements since order in hashtable cannot be guaranteed -(cl-eval "(make-hash-table)") -;=>{} - -(cl-eval "(defun redundant-identity (x) x)")) -;=>REDUNDANT-IDENTITY - -(cl-eval "(redundant-identity 2)")) -;=>2 - -(cl-eval "(defun range (max &key (min 0) (step 1)) (loop for n from min below max by step collect n))") -;=>RANGE - -(cl-eval "(range 10 :min 0 :step 1)") -;=>(0 1 2 3 4 5 6 7 8 9) - -(cl-eval "(mapcar #'1+ (range 10 :min 0 :step 1))") -;=>(1 2 3 4 5 6 7 8 9 10) +;; Testing clisp interop + +(cl-eval "42") +;=>42 + +(cl-eval "(+ 1 1)") +;=>2 + +(cl-eval "(setq foo 1 bar 2 baz 3)") + +(cl-eval "(list foo bar baz)") +;=>(1 2 3) + +(cl-eval "7") +;=>7 + +;; +;; Testing boolean flag +(cl-eval "(= 123 123)" true) +;=>true + +(cl-eval "(= 123 456)") +;=>nil + +(cl-eval "(= 123 456)" true) +;=>false + +;; +;; Testing list flag +(cl-eval "(last nil)" false true) +;=>() + +(cl-eval "nil" false true) +;=>() + +(cl-eval "nil") +;=>nil + +;; +;; Testing creation of Common Lisp Objects +(cl-eval "#(1 2)") +;=>[1 2] + +;;; Not testing with elements since order in hashtable cannot be guaranteed +(cl-eval "(make-hash-table)") +;=>{} + +(cl-eval "(defun redundant-identity (x) x)")) +;=>REDUNDANT-IDENTITY + +(cl-eval "(redundant-identity 2)")) +;=>2 + +(cl-eval "(defun range (max &key (min 0) (step 1)) (loop for n from min below max by step collect n))") +;=>RANGE + +(cl-eval "(range 10 :min 0 :step 1)") +;=>(0 1 2 3 4 5 6 7 8 9) + +(cl-eval "(mapcar #'1+ (range 10 :min 0 :step 1))") +;=>(1 2 3 4 5 6 7 8 9 10) diff --git a/impls/cpp/.gitignore b/impls/cpp/.gitignore index fd01e16664..37024a818c 100644 --- a/impls/cpp/.gitignore +++ b/impls/cpp/.gitignore @@ -1,5 +1,5 @@ -.deps -*.o -*.a -step0_repl -step1_read_print +.deps +*.o +*.a +step0_repl +step1_read_print diff --git a/impls/cpp/Core.cpp b/impls/cpp/Core.cpp index 9e91edcec1..4402e26e15 100644 --- a/impls/cpp/Core.cpp +++ b/impls/cpp/Core.cpp @@ -1,559 +1,559 @@ -#include "MAL.h" -#include "Environment.h" -#include "StaticList.h" -#include "Types.h" - -#include -#include -#include - -#define CHECK_ARGS_IS(expected) \ - checkArgsIs(name.c_str(), expected, \ - std::distance(argsBegin, argsEnd)) - -#define CHECK_ARGS_BETWEEN(min, max) \ - checkArgsBetween(name.c_str(), min, max, \ - std::distance(argsBegin, argsEnd)) - -#define CHECK_ARGS_AT_LEAST(expected) \ - checkArgsAtLeast(name.c_str(), expected, \ - std::distance(argsBegin, argsEnd)) - -static String printValues(malValueIter begin, malValueIter end, - const String& sep, bool readably); - -static StaticList handlers; - -#define ARG(type, name) type* name = VALUE_CAST(type, *argsBegin++) - -#define FUNCNAME(uniq) builtIn ## uniq -#define HRECNAME(uniq) handler ## uniq -#define BUILTIN_DEF(uniq, symbol) \ - static malBuiltIn::ApplyFunc FUNCNAME(uniq); \ - static StaticList::Node HRECNAME(uniq) \ - (handlers, new malBuiltIn(symbol, FUNCNAME(uniq))); \ - malValuePtr FUNCNAME(uniq)(const String& name, \ - malValueIter argsBegin, malValueIter argsEnd) - -#define BUILTIN(symbol) BUILTIN_DEF(__LINE__, symbol) - -#define BUILTIN_ISA(symbol, type) \ - BUILTIN(symbol) { \ - CHECK_ARGS_IS(1); \ - return mal::boolean(DYNAMIC_CAST(type, *argsBegin)); \ - } - -#define BUILTIN_IS(op, constant) \ - BUILTIN(op) { \ - CHECK_ARGS_IS(1); \ - return mal::boolean(*argsBegin == mal::constant()); \ - } - -#define BUILTIN_INTOP(op, checkDivByZero) \ - BUILTIN(#op) { \ - CHECK_ARGS_IS(2); \ - ARG(malInteger, lhs); \ - ARG(malInteger, rhs); \ - if (checkDivByZero) { \ - MAL_CHECK(rhs->value() != 0, "Division by zero"); \ - } \ - return mal::integer(lhs->value() op rhs->value()); \ - } - -BUILTIN_ISA("atom?", malAtom); -BUILTIN_ISA("keyword?", malKeyword); -BUILTIN_ISA("list?", malList); -BUILTIN_ISA("map?", malHash); -BUILTIN_ISA("number?", malInteger); -BUILTIN_ISA("sequential?", malSequence); -BUILTIN_ISA("string?", malString); -BUILTIN_ISA("symbol?", malSymbol); -BUILTIN_ISA("vector?", malVector); - -BUILTIN_INTOP(+, false); -BUILTIN_INTOP(/, true); -BUILTIN_INTOP(*, false); -BUILTIN_INTOP(%, true); - -BUILTIN_IS("true?", trueValue); -BUILTIN_IS("false?", falseValue); -BUILTIN_IS("nil?", nilValue); - -BUILTIN("-") -{ - int argCount = CHECK_ARGS_BETWEEN(1, 2); - ARG(malInteger, lhs); - if (argCount == 1) { - return mal::integer(- lhs->value()); - } - - ARG(malInteger, rhs); - return mal::integer(lhs->value() - rhs->value()); -} - -BUILTIN("<=") -{ - CHECK_ARGS_IS(2); - ARG(malInteger, lhs); - ARG(malInteger, rhs); - - return mal::boolean(lhs->value() <= rhs->value()); -} - -BUILTIN(">=") -{ - CHECK_ARGS_IS(2); - ARG(malInteger, lhs); - ARG(malInteger, rhs); - - return mal::boolean(lhs->value() >= rhs->value()); -} - -BUILTIN("<") -{ - CHECK_ARGS_IS(2); - ARG(malInteger, lhs); - ARG(malInteger, rhs); - - return mal::boolean(lhs->value() < rhs->value()); -} - -BUILTIN(">") -{ - CHECK_ARGS_IS(2); - ARG(malInteger, lhs); - ARG(malInteger, rhs); - - return mal::boolean(lhs->value() > rhs->value()); -} - -BUILTIN("=") -{ - CHECK_ARGS_IS(2); - const malValue* lhs = (*argsBegin++).ptr(); - const malValue* rhs = (*argsBegin++).ptr(); - - return mal::boolean(lhs->isEqualTo(rhs)); -} - -BUILTIN("apply") -{ - CHECK_ARGS_AT_LEAST(2); - malValuePtr op = *argsBegin++; // this gets checked in APPLY - - // Copy the first N-1 arguments in. - malValueVec args(argsBegin, argsEnd-1); - - // Then append the argument as a list. - const malSequence* lastArg = VALUE_CAST(malSequence, *(argsEnd-1)); - for (int i = 0; i < lastArg->count(); i++) { - args.push_back(lastArg->item(i)); - } - - return APPLY(op, args.begin(), args.end()); -} - -BUILTIN("assoc") -{ - CHECK_ARGS_AT_LEAST(1); - ARG(malHash, hash); - - return hash->assoc(argsBegin, argsEnd); -} - -BUILTIN("atom") -{ - CHECK_ARGS_IS(1); - - return mal::atom(*argsBegin); -} - -BUILTIN("concat") -{ - int count = 0; - for (auto it = argsBegin; it != argsEnd; ++it) { - const malSequence* seq = VALUE_CAST(malSequence, *it); - count += seq->count(); - } - - malValueVec* items = new malValueVec(count); - int offset = 0; - for (auto it = argsBegin; it != argsEnd; ++it) { - const malSequence* seq = STATIC_CAST(malSequence, *it); - std::copy(seq->begin(), seq->end(), items->begin() + offset); - offset += seq->count(); - } - - return mal::list(items); -} - -BUILTIN("conj") -{ - CHECK_ARGS_AT_LEAST(1); - ARG(malSequence, seq); - - return seq->conj(argsBegin, argsEnd); -} - -BUILTIN("cons") -{ - CHECK_ARGS_IS(2); - malValuePtr first = *argsBegin++; - ARG(malSequence, rest); - - malValueVec* items = new malValueVec(1 + rest->count()); - items->at(0) = first; - std::copy(rest->begin(), rest->end(), items->begin() + 1); - - return mal::list(items); -} - -BUILTIN("contains?") -{ - CHECK_ARGS_IS(2); - if (*argsBegin == mal::nilValue()) { - return *argsBegin; - } - ARG(malHash, hash); - return mal::boolean(hash->contains(*argsBegin)); -} - -BUILTIN("count") -{ - CHECK_ARGS_IS(1); - if (*argsBegin == mal::nilValue()) { - return mal::integer(0); - } - - ARG(malSequence, seq); - return mal::integer(seq->count()); -} - -BUILTIN("deref") -{ - CHECK_ARGS_IS(1); - ARG(malAtom, atom); - - return atom->deref(); -} - -BUILTIN("dissoc") -{ - CHECK_ARGS_AT_LEAST(1); - ARG(malHash, hash); - - return hash->dissoc(argsBegin, argsEnd); -} - -BUILTIN("empty?") -{ - CHECK_ARGS_IS(1); - ARG(malSequence, seq); - - return mal::boolean(seq->isEmpty()); -} - -BUILTIN("eval") -{ - CHECK_ARGS_IS(1); - return EVAL(*argsBegin, NULL); -} - -BUILTIN("first") -{ - CHECK_ARGS_IS(1); - if (*argsBegin == mal::nilValue()) { - return mal::nilValue(); - } - ARG(malSequence, seq); - return seq->first(); -} - -BUILTIN("fn?") -{ - CHECK_ARGS_IS(1); - malValuePtr arg = *argsBegin++; - - // Lambdas are functions, unless they're macros. - if (const malLambda* lambda = DYNAMIC_CAST(malLambda, arg)) { - return mal::boolean(!lambda->isMacro()); - } - // Builtins are functions. - return mal::boolean(DYNAMIC_CAST(malBuiltIn, arg)); -} - -BUILTIN("get") -{ - CHECK_ARGS_IS(2); - if (*argsBegin == mal::nilValue()) { - return *argsBegin; - } - ARG(malHash, hash); - return hash->get(*argsBegin); -} - -BUILTIN("hash-map") -{ - return mal::hash(argsBegin, argsEnd, true); -} - -BUILTIN("keys") -{ - CHECK_ARGS_IS(1); - ARG(malHash, hash); - return hash->keys(); -} - -BUILTIN("keyword") -{ - CHECK_ARGS_IS(1); - const malValuePtr arg = *argsBegin++; - if (malKeyword* s = DYNAMIC_CAST(malKeyword, arg)) - return s; - if (const malString* s = DYNAMIC_CAST(malString, arg)) - return mal::keyword(":" + s->value()); - MAL_FAIL("keyword expects a keyword or string"); -} - -BUILTIN("list") -{ - return mal::list(argsBegin, argsEnd); -} - -BUILTIN("macro?") -{ - CHECK_ARGS_IS(1); - - // Macros are implemented as lambdas, with a special flag. - const malLambda* lambda = DYNAMIC_CAST(malLambda, *argsBegin); - return mal::boolean((lambda != NULL) && lambda->isMacro()); -} - -BUILTIN("map") -{ - CHECK_ARGS_IS(2); - malValuePtr op = *argsBegin++; // this gets checked in APPLY - ARG(malSequence, source); - - const int length = source->count(); - malValueVec* items = new malValueVec(length); - auto it = source->begin(); - for (int i = 0; i < length; i++) { - items->at(i) = APPLY(op, it+i, it+i+1); - } - - return mal::list(items); -} - -BUILTIN("meta") -{ - CHECK_ARGS_IS(1); - malValuePtr obj = *argsBegin++; - - return obj->meta(); -} - -BUILTIN("nth") -{ - CHECK_ARGS_IS(2); - ARG(malSequence, seq); - ARG(malInteger, index); - - int i = index->value(); - MAL_CHECK(i >= 0 && i < seq->count(), "Index out of range"); - - return seq->item(i); -} - -BUILTIN("pr-str") -{ - return mal::string(printValues(argsBegin, argsEnd, " ", true)); -} - -BUILTIN("println") -{ - std::cout << printValues(argsBegin, argsEnd, " ", false) << "\n"; - return mal::nilValue(); -} - -BUILTIN("prn") -{ - std::cout << printValues(argsBegin, argsEnd, " ", true) << "\n"; - return mal::nilValue(); -} - -BUILTIN("read-string") -{ - CHECK_ARGS_IS(1); - ARG(malString, str); - - return readStr(str->value()); -} - -BUILTIN("readline") -{ - CHECK_ARGS_IS(1); - ARG(malString, str); - - return readline(str->value()); -} - -BUILTIN("reset!") -{ - CHECK_ARGS_IS(2); - ARG(malAtom, atom); - return atom->reset(*argsBegin); -} - -BUILTIN("rest") -{ - CHECK_ARGS_IS(1); - if (*argsBegin == mal::nilValue()) { - return mal::list(new malValueVec(0)); - } - ARG(malSequence, seq); - return seq->rest(); -} - -BUILTIN("seq") -{ - CHECK_ARGS_IS(1); - malValuePtr arg = *argsBegin++; - if (arg == mal::nilValue()) { - return mal::nilValue(); - } - if (const malSequence* seq = DYNAMIC_CAST(malSequence, arg)) { - return seq->isEmpty() ? mal::nilValue() - : mal::list(seq->begin(), seq->end()); - } - if (const malString* strVal = DYNAMIC_CAST(malString, arg)) { - const String str = strVal->value(); - int length = str.length(); - if (length == 0) - return mal::nilValue(); - - malValueVec* items = new malValueVec(length); - for (int i = 0; i < length; i++) { - (*items)[i] = mal::string(str.substr(i, 1)); - } - return mal::list(items); - } - MAL_FAIL("%s is not a string or sequence", arg->print(true).c_str()); -} - - -BUILTIN("slurp") -{ - CHECK_ARGS_IS(1); - ARG(malString, filename); - - std::ios_base::openmode openmode = - std::ios::ate | std::ios::in | std::ios::binary; - std::ifstream file(filename->value().c_str(), openmode); - MAL_CHECK(!file.fail(), "Cannot open %s", filename->value().c_str()); - - String data; - data.reserve(file.tellg()); - file.seekg(0, std::ios::beg); - data.append(std::istreambuf_iterator(file.rdbuf()), - std::istreambuf_iterator()); - - return mal::string(data); -} - -BUILTIN("str") -{ - return mal::string(printValues(argsBegin, argsEnd, "", false)); -} - -BUILTIN("swap!") -{ - CHECK_ARGS_AT_LEAST(2); - ARG(malAtom, atom); - - malValuePtr op = *argsBegin++; // this gets checked in APPLY - - malValueVec args(1 + argsEnd - argsBegin); - args[0] = atom->deref(); - std::copy(argsBegin, argsEnd, args.begin() + 1); - - malValuePtr value = APPLY(op, args.begin(), args.end()); - return atom->reset(value); -} - -BUILTIN("symbol") -{ - CHECK_ARGS_IS(1); - ARG(malString, token); - return mal::symbol(token->value()); -} - -BUILTIN("throw") -{ - CHECK_ARGS_IS(1); - throw *argsBegin; -} - -BUILTIN("time-ms") -{ - CHECK_ARGS_IS(0); - - using namespace std::chrono; - milliseconds ms = duration_cast( - high_resolution_clock::now().time_since_epoch() - ); - - return mal::integer(ms.count()); -} - -BUILTIN("vals") -{ - CHECK_ARGS_IS(1); - ARG(malHash, hash); - return hash->values(); -} - -BUILTIN("vec") -{ - CHECK_ARGS_IS(1); - ARG(malSequence, s); - return mal::vector(s->begin(), s->end()); -} - -BUILTIN("vector") -{ - return mal::vector(argsBegin, argsEnd); -} - -BUILTIN("with-meta") -{ - CHECK_ARGS_IS(2); - malValuePtr obj = *argsBegin++; - malValuePtr meta = *argsBegin++; - return obj->withMeta(meta); -} - -void installCore(malEnvPtr env) { - for (auto it = handlers.begin(), end = handlers.end(); it != end; ++it) { - malBuiltIn* handler = *it; - env->set(handler->name(), handler); - } -} - -static String printValues(malValueIter begin, malValueIter end, - const String& sep, bool readably) -{ - String out; - - if (begin != end) { - out += (*begin)->print(readably); - ++begin; - } - - for ( ; begin != end; ++begin) { - out += sep; - out += (*begin)->print(readably); - } - - return out; -} +#include "MAL.h" +#include "Environment.h" +#include "StaticList.h" +#include "Types.h" + +#include +#include +#include + +#define CHECK_ARGS_IS(expected) \ + checkArgsIs(name.c_str(), expected, \ + std::distance(argsBegin, argsEnd)) + +#define CHECK_ARGS_BETWEEN(min, max) \ + checkArgsBetween(name.c_str(), min, max, \ + std::distance(argsBegin, argsEnd)) + +#define CHECK_ARGS_AT_LEAST(expected) \ + checkArgsAtLeast(name.c_str(), expected, \ + std::distance(argsBegin, argsEnd)) + +static String printValues(malValueIter begin, malValueIter end, + const String& sep, bool readably); + +static StaticList handlers; + +#define ARG(type, name) type* name = VALUE_CAST(type, *argsBegin++) + +#define FUNCNAME(uniq) builtIn ## uniq +#define HRECNAME(uniq) handler ## uniq +#define BUILTIN_DEF(uniq, symbol) \ + static malBuiltIn::ApplyFunc FUNCNAME(uniq); \ + static StaticList::Node HRECNAME(uniq) \ + (handlers, new malBuiltIn(symbol, FUNCNAME(uniq))); \ + malValuePtr FUNCNAME(uniq)(const String& name, \ + malValueIter argsBegin, malValueIter argsEnd) + +#define BUILTIN(symbol) BUILTIN_DEF(__LINE__, symbol) + +#define BUILTIN_ISA(symbol, type) \ + BUILTIN(symbol) { \ + CHECK_ARGS_IS(1); \ + return mal::boolean(DYNAMIC_CAST(type, *argsBegin)); \ + } + +#define BUILTIN_IS(op, constant) \ + BUILTIN(op) { \ + CHECK_ARGS_IS(1); \ + return mal::boolean(*argsBegin == mal::constant()); \ + } + +#define BUILTIN_INTOP(op, checkDivByZero) \ + BUILTIN(#op) { \ + CHECK_ARGS_IS(2); \ + ARG(malInteger, lhs); \ + ARG(malInteger, rhs); \ + if (checkDivByZero) { \ + MAL_CHECK(rhs->value() != 0, "Division by zero"); \ + } \ + return mal::integer(lhs->value() op rhs->value()); \ + } + +BUILTIN_ISA("atom?", malAtom); +BUILTIN_ISA("keyword?", malKeyword); +BUILTIN_ISA("list?", malList); +BUILTIN_ISA("map?", malHash); +BUILTIN_ISA("number?", malInteger); +BUILTIN_ISA("sequential?", malSequence); +BUILTIN_ISA("string?", malString); +BUILTIN_ISA("symbol?", malSymbol); +BUILTIN_ISA("vector?", malVector); + +BUILTIN_INTOP(+, false); +BUILTIN_INTOP(/, true); +BUILTIN_INTOP(*, false); +BUILTIN_INTOP(%, true); + +BUILTIN_IS("true?", trueValue); +BUILTIN_IS("false?", falseValue); +BUILTIN_IS("nil?", nilValue); + +BUILTIN("-") +{ + int argCount = CHECK_ARGS_BETWEEN(1, 2); + ARG(malInteger, lhs); + if (argCount == 1) { + return mal::integer(- lhs->value()); + } + + ARG(malInteger, rhs); + return mal::integer(lhs->value() - rhs->value()); +} + +BUILTIN("<=") +{ + CHECK_ARGS_IS(2); + ARG(malInteger, lhs); + ARG(malInteger, rhs); + + return mal::boolean(lhs->value() <= rhs->value()); +} + +BUILTIN(">=") +{ + CHECK_ARGS_IS(2); + ARG(malInteger, lhs); + ARG(malInteger, rhs); + + return mal::boolean(lhs->value() >= rhs->value()); +} + +BUILTIN("<") +{ + CHECK_ARGS_IS(2); + ARG(malInteger, lhs); + ARG(malInteger, rhs); + + return mal::boolean(lhs->value() < rhs->value()); +} + +BUILTIN(">") +{ + CHECK_ARGS_IS(2); + ARG(malInteger, lhs); + ARG(malInteger, rhs); + + return mal::boolean(lhs->value() > rhs->value()); +} + +BUILTIN("=") +{ + CHECK_ARGS_IS(2); + const malValue* lhs = (*argsBegin++).ptr(); + const malValue* rhs = (*argsBegin++).ptr(); + + return mal::boolean(lhs->isEqualTo(rhs)); +} + +BUILTIN("apply") +{ + CHECK_ARGS_AT_LEAST(2); + malValuePtr op = *argsBegin++; // this gets checked in APPLY + + // Copy the first N-1 arguments in. + malValueVec args(argsBegin, argsEnd-1); + + // Then append the argument as a list. + const malSequence* lastArg = VALUE_CAST(malSequence, *(argsEnd-1)); + for (int i = 0; i < lastArg->count(); i++) { + args.push_back(lastArg->item(i)); + } + + return APPLY(op, args.begin(), args.end()); +} + +BUILTIN("assoc") +{ + CHECK_ARGS_AT_LEAST(1); + ARG(malHash, hash); + + return hash->assoc(argsBegin, argsEnd); +} + +BUILTIN("atom") +{ + CHECK_ARGS_IS(1); + + return mal::atom(*argsBegin); +} + +BUILTIN("concat") +{ + int count = 0; + for (auto it = argsBegin; it != argsEnd; ++it) { + const malSequence* seq = VALUE_CAST(malSequence, *it); + count += seq->count(); + } + + malValueVec* items = new malValueVec(count); + int offset = 0; + for (auto it = argsBegin; it != argsEnd; ++it) { + const malSequence* seq = STATIC_CAST(malSequence, *it); + std::copy(seq->begin(), seq->end(), items->begin() + offset); + offset += seq->count(); + } + + return mal::list(items); +} + +BUILTIN("conj") +{ + CHECK_ARGS_AT_LEAST(1); + ARG(malSequence, seq); + + return seq->conj(argsBegin, argsEnd); +} + +BUILTIN("cons") +{ + CHECK_ARGS_IS(2); + malValuePtr first = *argsBegin++; + ARG(malSequence, rest); + + malValueVec* items = new malValueVec(1 + rest->count()); + items->at(0) = first; + std::copy(rest->begin(), rest->end(), items->begin() + 1); + + return mal::list(items); +} + +BUILTIN("contains?") +{ + CHECK_ARGS_IS(2); + if (*argsBegin == mal::nilValue()) { + return *argsBegin; + } + ARG(malHash, hash); + return mal::boolean(hash->contains(*argsBegin)); +} + +BUILTIN("count") +{ + CHECK_ARGS_IS(1); + if (*argsBegin == mal::nilValue()) { + return mal::integer(0); + } + + ARG(malSequence, seq); + return mal::integer(seq->count()); +} + +BUILTIN("deref") +{ + CHECK_ARGS_IS(1); + ARG(malAtom, atom); + + return atom->deref(); +} + +BUILTIN("dissoc") +{ + CHECK_ARGS_AT_LEAST(1); + ARG(malHash, hash); + + return hash->dissoc(argsBegin, argsEnd); +} + +BUILTIN("empty?") +{ + CHECK_ARGS_IS(1); + ARG(malSequence, seq); + + return mal::boolean(seq->isEmpty()); +} + +BUILTIN("eval") +{ + CHECK_ARGS_IS(1); + return EVAL(*argsBegin, NULL); +} + +BUILTIN("first") +{ + CHECK_ARGS_IS(1); + if (*argsBegin == mal::nilValue()) { + return mal::nilValue(); + } + ARG(malSequence, seq); + return seq->first(); +} + +BUILTIN("fn?") +{ + CHECK_ARGS_IS(1); + malValuePtr arg = *argsBegin++; + + // Lambdas are functions, unless they're macros. + if (const malLambda* lambda = DYNAMIC_CAST(malLambda, arg)) { + return mal::boolean(!lambda->isMacro()); + } + // Builtins are functions. + return mal::boolean(DYNAMIC_CAST(malBuiltIn, arg)); +} + +BUILTIN("get") +{ + CHECK_ARGS_IS(2); + if (*argsBegin == mal::nilValue()) { + return *argsBegin; + } + ARG(malHash, hash); + return hash->get(*argsBegin); +} + +BUILTIN("hash-map") +{ + return mal::hash(argsBegin, argsEnd, true); +} + +BUILTIN("keys") +{ + CHECK_ARGS_IS(1); + ARG(malHash, hash); + return hash->keys(); +} + +BUILTIN("keyword") +{ + CHECK_ARGS_IS(1); + const malValuePtr arg = *argsBegin++; + if (malKeyword* s = DYNAMIC_CAST(malKeyword, arg)) + return s; + if (const malString* s = DYNAMIC_CAST(malString, arg)) + return mal::keyword(":" + s->value()); + MAL_FAIL("keyword expects a keyword or string"); +} + +BUILTIN("list") +{ + return mal::list(argsBegin, argsEnd); +} + +BUILTIN("macro?") +{ + CHECK_ARGS_IS(1); + + // Macros are implemented as lambdas, with a special flag. + const malLambda* lambda = DYNAMIC_CAST(malLambda, *argsBegin); + return mal::boolean((lambda != NULL) && lambda->isMacro()); +} + +BUILTIN("map") +{ + CHECK_ARGS_IS(2); + malValuePtr op = *argsBegin++; // this gets checked in APPLY + ARG(malSequence, source); + + const int length = source->count(); + malValueVec* items = new malValueVec(length); + auto it = source->begin(); + for (int i = 0; i < length; i++) { + items->at(i) = APPLY(op, it+i, it+i+1); + } + + return mal::list(items); +} + +BUILTIN("meta") +{ + CHECK_ARGS_IS(1); + malValuePtr obj = *argsBegin++; + + return obj->meta(); +} + +BUILTIN("nth") +{ + CHECK_ARGS_IS(2); + ARG(malSequence, seq); + ARG(malInteger, index); + + int i = index->value(); + MAL_CHECK(i >= 0 && i < seq->count(), "Index out of range"); + + return seq->item(i); +} + +BUILTIN("pr-str") +{ + return mal::string(printValues(argsBegin, argsEnd, " ", true)); +} + +BUILTIN("println") +{ + std::cout << printValues(argsBegin, argsEnd, " ", false) << "\n"; + return mal::nilValue(); +} + +BUILTIN("prn") +{ + std::cout << printValues(argsBegin, argsEnd, " ", true) << "\n"; + return mal::nilValue(); +} + +BUILTIN("read-string") +{ + CHECK_ARGS_IS(1); + ARG(malString, str); + + return readStr(str->value()); +} + +BUILTIN("readline") +{ + CHECK_ARGS_IS(1); + ARG(malString, str); + + return readline(str->value()); +} + +BUILTIN("reset!") +{ + CHECK_ARGS_IS(2); + ARG(malAtom, atom); + return atom->reset(*argsBegin); +} + +BUILTIN("rest") +{ + CHECK_ARGS_IS(1); + if (*argsBegin == mal::nilValue()) { + return mal::list(new malValueVec(0)); + } + ARG(malSequence, seq); + return seq->rest(); +} + +BUILTIN("seq") +{ + CHECK_ARGS_IS(1); + malValuePtr arg = *argsBegin++; + if (arg == mal::nilValue()) { + return mal::nilValue(); + } + if (const malSequence* seq = DYNAMIC_CAST(malSequence, arg)) { + return seq->isEmpty() ? mal::nilValue() + : mal::list(seq->begin(), seq->end()); + } + if (const malString* strVal = DYNAMIC_CAST(malString, arg)) { + const String str = strVal->value(); + int length = str.length(); + if (length == 0) + return mal::nilValue(); + + malValueVec* items = new malValueVec(length); + for (int i = 0; i < length; i++) { + (*items)[i] = mal::string(str.substr(i, 1)); + } + return mal::list(items); + } + MAL_FAIL("%s is not a string or sequence", arg->print(true).c_str()); +} + + +BUILTIN("slurp") +{ + CHECK_ARGS_IS(1); + ARG(malString, filename); + + std::ios_base::openmode openmode = + std::ios::ate | std::ios::in | std::ios::binary; + std::ifstream file(filename->value().c_str(), openmode); + MAL_CHECK(!file.fail(), "Cannot open %s", filename->value().c_str()); + + String data; + data.reserve(file.tellg()); + file.seekg(0, std::ios::beg); + data.append(std::istreambuf_iterator(file.rdbuf()), + std::istreambuf_iterator()); + + return mal::string(data); +} + +BUILTIN("str") +{ + return mal::string(printValues(argsBegin, argsEnd, "", false)); +} + +BUILTIN("swap!") +{ + CHECK_ARGS_AT_LEAST(2); + ARG(malAtom, atom); + + malValuePtr op = *argsBegin++; // this gets checked in APPLY + + malValueVec args(1 + argsEnd - argsBegin); + args[0] = atom->deref(); + std::copy(argsBegin, argsEnd, args.begin() + 1); + + malValuePtr value = APPLY(op, args.begin(), args.end()); + return atom->reset(value); +} + +BUILTIN("symbol") +{ + CHECK_ARGS_IS(1); + ARG(malString, token); + return mal::symbol(token->value()); +} + +BUILTIN("throw") +{ + CHECK_ARGS_IS(1); + throw *argsBegin; +} + +BUILTIN("time-ms") +{ + CHECK_ARGS_IS(0); + + using namespace std::chrono; + milliseconds ms = duration_cast( + high_resolution_clock::now().time_since_epoch() + ); + + return mal::integer(ms.count()); +} + +BUILTIN("vals") +{ + CHECK_ARGS_IS(1); + ARG(malHash, hash); + return hash->values(); +} + +BUILTIN("vec") +{ + CHECK_ARGS_IS(1); + ARG(malSequence, s); + return mal::vector(s->begin(), s->end()); +} + +BUILTIN("vector") +{ + return mal::vector(argsBegin, argsEnd); +} + +BUILTIN("with-meta") +{ + CHECK_ARGS_IS(2); + malValuePtr obj = *argsBegin++; + malValuePtr meta = *argsBegin++; + return obj->withMeta(meta); +} + +void installCore(malEnvPtr env) { + for (auto it = handlers.begin(), end = handlers.end(); it != end; ++it) { + malBuiltIn* handler = *it; + env->set(handler->name(), handler); + } +} + +static String printValues(malValueIter begin, malValueIter end, + const String& sep, bool readably) +{ + String out; + + if (begin != end) { + out += (*begin)->print(readably); + ++begin; + } + + for ( ; begin != end; ++begin) { + out += sep; + out += (*begin)->print(readably); + } + + return out; +} diff --git a/impls/cpp/Debug.h b/impls/cpp/Debug.h index c2ee75c78c..5f2fec1c61 100644 --- a/impls/cpp/Debug.h +++ b/impls/cpp/Debug.h @@ -1,45 +1,45 @@ -#ifndef INCLUDE_DEBUG_H -#define INCLUDE_DEBUG_H - -#include -#include - -#define DEBUG_TRACE 1 -//#define DEBUG_OBJECT_LIFETIMES 1 -//#define DEBUG_ENV_LIFETIMES 1 - -#define DEBUG_TRACE_FILE stderr - -#define NOOP do { } while (false) -#define NOTRACE(...) NOOP - -#if DEBUG_TRACE - #define TRACE(...) fprintf(DEBUG_TRACE_FILE, __VA_ARGS__) -#else - #define TRACE NOTRACE -#endif - -#if DEBUG_OBJECT_LIFETIMES - #define TRACE_OBJECT TRACE -#else - #define TRACE_OBJECT NOTRACE -#endif - -#if DEBUG_ENV_LIFETIMES - #define TRACE_ENV TRACE -#else - #define TRACE_ENV NOTRACE -#endif - -#define _ASSERT(file, line, condition, ...) \ - if (!(condition)) { \ - printf("Assertion failed at %s(%d): ", file, line); \ - printf(__VA_ARGS__); \ - exit(1); \ - } else { } - - -#define ASSERT(condition, ...) \ - _ASSERT(__FILE__, __LINE__, condition, __VA_ARGS__) - -#endif // INCLUDE_DEBUG_H +#ifndef INCLUDE_DEBUG_H +#define INCLUDE_DEBUG_H + +#include +#include + +#define DEBUG_TRACE 1 +//#define DEBUG_OBJECT_LIFETIMES 1 +//#define DEBUG_ENV_LIFETIMES 1 + +#define DEBUG_TRACE_FILE stderr + +#define NOOP do { } while (false) +#define NOTRACE(...) NOOP + +#if DEBUG_TRACE + #define TRACE(...) fprintf(DEBUG_TRACE_FILE, __VA_ARGS__) +#else + #define TRACE NOTRACE +#endif + +#if DEBUG_OBJECT_LIFETIMES + #define TRACE_OBJECT TRACE +#else + #define TRACE_OBJECT NOTRACE +#endif + +#if DEBUG_ENV_LIFETIMES + #define TRACE_ENV TRACE +#else + #define TRACE_ENV NOTRACE +#endif + +#define _ASSERT(file, line, condition, ...) \ + if (!(condition)) { \ + printf("Assertion failed at %s(%d): ", file, line); \ + printf(__VA_ARGS__); \ + exit(1); \ + } else { } + + +#define ASSERT(condition, ...) \ + _ASSERT(__FILE__, __LINE__, condition, __VA_ARGS__) + +#endif // INCLUDE_DEBUG_H diff --git a/impls/cpp/Dockerfile b/impls/cpp/Dockerfile index 8d01389900..48513fda65 100644 --- a/impls/cpp/Dockerfile +++ b/impls/cpp/Dockerfile @@ -1,25 +1,25 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install g++ for any C/C++ based implementations -RUN apt-get -y install g++ +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install g++ for any C/C++ based implementations +RUN apt-get -y install g++ diff --git a/impls/cpp/Environment.cpp b/impls/cpp/Environment.cpp index 1ae8f3e562..52baa5031f 100644 --- a/impls/cpp/Environment.cpp +++ b/impls/cpp/Environment.cpp @@ -1,73 +1,73 @@ -#include "Environment.h" -#include "Types.h" - -#include - -malEnv::malEnv(malEnvPtr outer) -: m_outer(outer) -{ - TRACE_ENV("Creating malEnv %p, outer=%p\n", this, m_outer.ptr()); -} - -malEnv::malEnv(malEnvPtr outer, const StringVec& bindings, - malValueIter argsBegin, malValueIter argsEnd) -: m_outer(outer) -{ - TRACE_ENV("Creating malEnv %p, outer=%p\n", this, m_outer.ptr()); - int n = bindings.size(); - auto it = argsBegin; - for (int i = 0; i < n; i++) { - if (bindings[i] == "&") { - MAL_CHECK(i == n - 2, "There must be one parameter after the &"); - - set(bindings[n-1], mal::list(it, argsEnd)); - return; - } - MAL_CHECK(it != argsEnd, "Not enough parameters"); - set(bindings[i], *it); - ++it; - } - MAL_CHECK(it == argsEnd, "Too many parameters"); -} - -malEnv::~malEnv() -{ - TRACE_ENV("Destroying malEnv %p, outer=%p\n", this, m_outer.ptr()); -} - -malEnvPtr malEnv::find(const String& symbol) -{ - for (malEnvPtr env = this; env; env = env->m_outer) { - if (env->m_map.find(symbol) != env->m_map.end()) { - return env; - } - } - return NULL; -} - -malValuePtr malEnv::get(const String& symbol) -{ - for (malEnvPtr env = this; env; env = env->m_outer) { - auto it = env->m_map.find(symbol); - if (it != env->m_map.end()) { - return it->second; - } - } - MAL_FAIL("'%s' not found", symbol.c_str()); -} - -malValuePtr malEnv::set(const String& symbol, malValuePtr value) -{ - m_map[symbol] = value; - return value; -} - -malEnvPtr malEnv::getRoot() -{ - // Work our way down the the global environment. - for (malEnvPtr env = this; ; env = env->m_outer) { - if (!env->m_outer) { - return env; - } - } -} +#include "Environment.h" +#include "Types.h" + +#include + +malEnv::malEnv(malEnvPtr outer) +: m_outer(outer) +{ + TRACE_ENV("Creating malEnv %p, outer=%p\n", this, m_outer.ptr()); +} + +malEnv::malEnv(malEnvPtr outer, const StringVec& bindings, + malValueIter argsBegin, malValueIter argsEnd) +: m_outer(outer) +{ + TRACE_ENV("Creating malEnv %p, outer=%p\n", this, m_outer.ptr()); + int n = bindings.size(); + auto it = argsBegin; + for (int i = 0; i < n; i++) { + if (bindings[i] == "&") { + MAL_CHECK(i == n - 2, "There must be one parameter after the &"); + + set(bindings[n-1], mal::list(it, argsEnd)); + return; + } + MAL_CHECK(it != argsEnd, "Not enough parameters"); + set(bindings[i], *it); + ++it; + } + MAL_CHECK(it == argsEnd, "Too many parameters"); +} + +malEnv::~malEnv() +{ + TRACE_ENV("Destroying malEnv %p, outer=%p\n", this, m_outer.ptr()); +} + +malEnvPtr malEnv::find(const String& symbol) +{ + for (malEnvPtr env = this; env; env = env->m_outer) { + if (env->m_map.find(symbol) != env->m_map.end()) { + return env; + } + } + return NULL; +} + +malValuePtr malEnv::get(const String& symbol) +{ + for (malEnvPtr env = this; env; env = env->m_outer) { + auto it = env->m_map.find(symbol); + if (it != env->m_map.end()) { + return it->second; + } + } + MAL_FAIL("'%s' not found", symbol.c_str()); +} + +malValuePtr malEnv::set(const String& symbol, malValuePtr value) +{ + m_map[symbol] = value; + return value; +} + +malEnvPtr malEnv::getRoot() +{ + // Work our way down the the global environment. + for (malEnvPtr env = this; ; env = env->m_outer) { + if (!env->m_outer) { + return env; + } + } +} diff --git a/impls/cpp/Environment.h b/impls/cpp/Environment.h index 9753a22ead..85407d2c39 100644 --- a/impls/cpp/Environment.h +++ b/impls/cpp/Environment.h @@ -1,29 +1,29 @@ -#ifndef INCLUDE_ENVIRONMENT_H -#define INCLUDE_ENVIRONMENT_H - -#include "MAL.h" - -#include - -class malEnv : public RefCounted { -public: - malEnv(malEnvPtr outer = NULL); - malEnv(malEnvPtr outer, - const StringVec& bindings, - malValueIter argsBegin, - malValueIter argsEnd); - - ~malEnv(); - - malValuePtr get(const String& symbol); - malEnvPtr find(const String& symbol); - malValuePtr set(const String& symbol, malValuePtr value); - malEnvPtr getRoot(); - -private: - typedef std::map Map; - Map m_map; - malEnvPtr m_outer; -}; - -#endif // INCLUDE_ENVIRONMENT_H +#ifndef INCLUDE_ENVIRONMENT_H +#define INCLUDE_ENVIRONMENT_H + +#include "MAL.h" + +#include + +class malEnv : public RefCounted { +public: + malEnv(malEnvPtr outer = NULL); + malEnv(malEnvPtr outer, + const StringVec& bindings, + malValueIter argsBegin, + malValueIter argsEnd); + + ~malEnv(); + + malValuePtr get(const String& symbol); + malEnvPtr find(const String& symbol); + malValuePtr set(const String& symbol, malValuePtr value); + malEnvPtr getRoot(); + +private: + typedef std::map Map; + Map m_map; + malEnvPtr m_outer; +}; + +#endif // INCLUDE_ENVIRONMENT_H diff --git a/impls/cpp/MAL.h b/impls/cpp/MAL.h index c82b50cc09..59eaf39e82 100644 --- a/impls/cpp/MAL.h +++ b/impls/cpp/MAL.h @@ -1,32 +1,32 @@ -#ifndef INCLUDE_MAL_H -#define INCLUDE_MAL_H - -#include "Debug.h" -#include "RefCountedPtr.h" -#include "String.h" -#include "Validation.h" - -#include - -class malValue; -typedef RefCountedPtr malValuePtr; -typedef std::vector malValueVec; -typedef malValueVec::iterator malValueIter; - -class malEnv; -typedef RefCountedPtr malEnvPtr; - -// step*.cpp -extern malValuePtr APPLY(malValuePtr op, - malValueIter argsBegin, malValueIter argsEnd); -extern malValuePtr EVAL(malValuePtr ast, malEnvPtr env); -extern malValuePtr readline(const String& prompt); -extern String rep(const String& input, malEnvPtr env); - -// Core.cpp -extern void installCore(malEnvPtr env); - -// Reader.cpp -extern malValuePtr readStr(const String& input); - -#endif // INCLUDE_MAL_H +#ifndef INCLUDE_MAL_H +#define INCLUDE_MAL_H + +#include "Debug.h" +#include "RefCountedPtr.h" +#include "String.h" +#include "Validation.h" + +#include + +class malValue; +typedef RefCountedPtr malValuePtr; +typedef std::vector malValueVec; +typedef malValueVec::iterator malValueIter; + +class malEnv; +typedef RefCountedPtr malEnvPtr; + +// step*.cpp +extern malValuePtr APPLY(malValuePtr op, + malValueIter argsBegin, malValueIter argsEnd); +extern malValuePtr EVAL(malValuePtr ast, malEnvPtr env); +extern malValuePtr readline(const String& prompt); +extern String rep(const String& input, malEnvPtr env); + +// Core.cpp +extern void installCore(malEnvPtr env); + +// Reader.cpp +extern malValuePtr readStr(const String& input); + +#endif // INCLUDE_MAL_H diff --git a/impls/cpp/Makefile b/impls/cpp/Makefile index 2377031883..1dcffdeefa 100644 --- a/impls/cpp/Makefile +++ b/impls/cpp/Makefile @@ -1,54 +1,54 @@ -uname_S := $(shell sh -c 'uname -s 2>/dev/null || echo not') - -ifeq ($(uname_S),Darwin) - # Native build on yosemite. Requires: brew install readline - CXX=g++ - READLINE=/usr/local/opt/readline - INCPATHS=-I$(READLINE)/include - LIBPATHS=-L$(READLINE)/lib -else - # Ubuntu 14.10 / docker - CXX=g++-4.9 -endif - -LD=$(CXX) -AR=ar - -DEBUG=-ggdb -CXXFLAGS=-O3 -Wall $(DEBUG) $(INCPATHS) -std=c++11 -LDFLAGS=-O3 $(DEBUG) $(LIBPATHS) -L. -lreadline -lhistory - -LIBSOURCES=Core.cpp Environment.cpp Reader.cpp ReadLine.cpp String.cpp \ - Types.cpp Validation.cpp -LIBOBJS=$(LIBSOURCES:%.cpp=%.o) - -MAINS=$(wildcard step*.cpp) -TARGETS=$(MAINS:%.cpp=%) - -.PHONY: all clean - -.SUFFIXES: .cpp .o - -all: $(TARGETS) - -dist: mal - -mal: stepA_mal - cp $< $@ - -.deps: *.cpp *.h - $(CXX) $(CXXFLAGS) -MM *.cpp > .deps - -$(TARGETS): %: %.o libmal.a - $(LD) $^ -o $@ $(LDFLAGS) - -libmal.a: $(LIBOBJS) - $(AR) rcs $@ $^ - -.cpp.o: - $(CXX) $(CXXFLAGS) -c $< -o $@ - -clean: - rm -rf *.o $(TARGETS) libmal.a .deps mal - --include .deps +uname_S := $(shell sh -c 'uname -s 2>/dev/null || echo not') + +ifeq ($(uname_S),Darwin) + # Native build on yosemite. Requires: brew install readline + CXX=g++ + READLINE=/usr/local/opt/readline + INCPATHS=-I$(READLINE)/include + LIBPATHS=-L$(READLINE)/lib +else + # Ubuntu 14.10 / docker + CXX=g++-4.9 +endif + +LD=$(CXX) +AR=ar + +DEBUG=-ggdb +CXXFLAGS=-O3 -Wall $(DEBUG) $(INCPATHS) -std=c++11 +LDFLAGS=-O3 $(DEBUG) $(LIBPATHS) -L. -lreadline -lhistory + +LIBSOURCES=Core.cpp Environment.cpp Reader.cpp ReadLine.cpp String.cpp \ + Types.cpp Validation.cpp +LIBOBJS=$(LIBSOURCES:%.cpp=%.o) + +MAINS=$(wildcard step*.cpp) +TARGETS=$(MAINS:%.cpp=%) + +.PHONY: all clean + +.SUFFIXES: .cpp .o + +all: $(TARGETS) + +dist: mal + +mal: stepA_mal + cp $< $@ + +.deps: *.cpp *.h + $(CXX) $(CXXFLAGS) -MM *.cpp > .deps + +$(TARGETS): %: %.o libmal.a + $(LD) $^ -o $@ $(LDFLAGS) + +libmal.a: $(LIBOBJS) + $(AR) rcs $@ $^ + +.cpp.o: + $(CXX) $(CXXFLAGS) -c $< -o $@ + +clean: + rm -rf *.o $(TARGETS) libmal.a .deps mal + +-include .deps diff --git a/impls/cpp/README.md b/impls/cpp/README.md index 5d0ddd37d7..405429e39a 100644 --- a/impls/cpp/README.md +++ b/impls/cpp/README.md @@ -1,40 +1,40 @@ -# Compilation notes - -## Mac OSX - -This C++ implementation was developed on Mac OS X Yosemite, and uses the -stock g++ compiler. - -The only other requirement is GNU Readline, which I got from homebrew. - - brew install readline - -You may need to edit the READLINE path in the Makefile. - -## Ubuntu 14.10/15.04 - -This should compile on Ubuntu 14.10 and 15.04 with the following packages - - apt-get install clang-3.5 libreadline-dev make - -## Docker - -For everyone else, there is a Dockerfile and associated docker.sh script which -can be used to make and run this implementation. - - * build the docker image - - ./docker build - - * make the MAL binaries: - - ./docker make - - * run one of the implementations: - - ./docker run ./stepA_mal - - * open a shell inside the docker container: - - ./docker run - +# Compilation notes + +## Mac OSX + +This C++ implementation was developed on Mac OS X Yosemite, and uses the +stock g++ compiler. + +The only other requirement is GNU Readline, which I got from homebrew. + + brew install readline + +You may need to edit the READLINE path in the Makefile. + +## Ubuntu 14.10/15.04 + +This should compile on Ubuntu 14.10 and 15.04 with the following packages + + apt-get install clang-3.5 libreadline-dev make + +## Docker + +For everyone else, there is a Dockerfile and associated docker.sh script which +can be used to make and run this implementation. + + * build the docker image + + ./docker build + + * make the MAL binaries: + + ./docker make + + * run one of the implementations: + + ./docker run ./stepA_mal + + * open a shell inside the docker container: + + ./docker run + diff --git a/impls/cpp/ReadLine.cpp b/impls/cpp/ReadLine.cpp index f4b76609b2..54ecc7fce1 100644 --- a/impls/cpp/ReadLine.cpp +++ b/impls/cpp/ReadLine.cpp @@ -1,35 +1,35 @@ -#include "ReadLine.h" -#include "String.h" - -#include -#include -#include - -#include -#include -#include - -ReadLine::ReadLine(const String& historyFile) -: m_historyPath(copyAndFree(tilde_expand(historyFile.c_str()))) -{ - read_history(m_historyPath.c_str()); -} - -ReadLine::~ReadLine() -{ -} - -bool ReadLine::get(const String& prompt, String& out) -{ - char *line = readline(prompt.c_str()); - if (line == NULL) { - return false; - } - add_history(line); // Add input to in-memory history - append_history(1, m_historyPath.c_str()); - - out = line; - free(line); - - return true; -} +#include "ReadLine.h" +#include "String.h" + +#include +#include +#include + +#include +#include +#include + +ReadLine::ReadLine(const String& historyFile) +: m_historyPath(copyAndFree(tilde_expand(historyFile.c_str()))) +{ + read_history(m_historyPath.c_str()); +} + +ReadLine::~ReadLine() +{ +} + +bool ReadLine::get(const String& prompt, String& out) +{ + char *line = readline(prompt.c_str()); + if (line == NULL) { + return false; + } + add_history(line); // Add input to in-memory history + append_history(1, m_historyPath.c_str()); + + out = line; + free(line); + + return true; +} diff --git a/impls/cpp/ReadLine.h b/impls/cpp/ReadLine.h index 94327aad97..feb413902b 100644 --- a/impls/cpp/ReadLine.h +++ b/impls/cpp/ReadLine.h @@ -1,17 +1,17 @@ -#ifndef INCLUDE_READLINE_H -#define INCLUDE_READLINE_H - -#include "String.h" - -class ReadLine { -public: - ReadLine(const String& historyFile); - ~ReadLine(); - - bool get(const String& prompt, String& line); - -private: - String m_historyPath; -}; - -#endif // INCLUDE_READLINE_H +#ifndef INCLUDE_READLINE_H +#define INCLUDE_READLINE_H + +#include "String.h" + +class ReadLine { +public: + ReadLine(const String& historyFile); + ~ReadLine(); + + bool get(const String& prompt, String& line); + +private: + String m_historyPath; +}; + +#endif // INCLUDE_READLINE_H diff --git a/impls/cpp/Reader.cpp b/impls/cpp/Reader.cpp index dbcb6c9c83..1cd7dbcf69 100644 --- a/impls/cpp/Reader.cpp +++ b/impls/cpp/Reader.cpp @@ -1,228 +1,228 @@ -#include "MAL.h" -#include "Types.h" - -#include - -typedef std::regex Regex; - -static const Regex intRegex("^[-+]?\\d+$"); -static const Regex closeRegex("[\\)\\]}]"); - -static const Regex whitespaceRegex("[\\s,]+|;.*"); -static const Regex tokenRegexes[] = { - Regex("~@"), - Regex("[\\[\\]{}()'`~^@]"), - Regex("\"(?:\\\\.|[^\\\\\"])*\""), - Regex("[^\\s\\[\\]{}('\"`,;)]+"), -}; - -class Tokeniser -{ -public: - Tokeniser(const String& input); - - String peek() const { - ASSERT(!eof(), "Tokeniser reading past EOF in peek\n"); - return m_token; - } - - String next() { - ASSERT(!eof(), "Tokeniser reading past EOF in next\n"); - String ret = peek(); - nextToken(); - return ret; - } - - bool eof() const { - return m_iter == m_end; - } - -private: - void skipWhitespace(); - void nextToken(); - - bool matchRegex(const Regex& regex); - - typedef String::const_iterator StringIter; - - String m_token; - StringIter m_iter; - StringIter m_end; -}; - -Tokeniser::Tokeniser(const String& input) -: m_iter(input.begin()) -, m_end(input.end()) -{ - nextToken(); -} - -bool Tokeniser::matchRegex(const Regex& regex) -{ - if (eof()) { - return false; - } - - std::smatch match; - auto flags = std::regex_constants::match_continuous; - if (!std::regex_search(m_iter, m_end, match, regex, flags)) { - return false; - } - - ASSERT(match.size() == 1, "Should only have one submatch, not %lu\n", - match.size()); - ASSERT(match.position(0) == 0, "Need to match first character\n"); - ASSERT(match.length(0) > 0, "Need to match a non-empty string\n"); - - // Don't advance m_iter now, do it after we've consumed the token in - // next(). If we do it now, we hit eof() when there's still one token left. - m_token = match.str(0); - - return true; -} - -void Tokeniser::nextToken() -{ - m_iter += m_token.size(); - - skipWhitespace(); - if (eof()) { - return; - } - - for (auto &it : tokenRegexes) { - if (matchRegex(it)) { - return; - } - } - - String mismatch(m_iter, m_end); - if (mismatch[0] == '"') { - MAL_CHECK(false, "expected '\"', got EOF"); - } - else { - MAL_CHECK(false, "unexpected '%s'", mismatch.c_str()); - } -} - -void Tokeniser::skipWhitespace() -{ - while (matchRegex(whitespaceRegex)) { - m_iter += m_token.size(); - } -} - -static malValuePtr readAtom(Tokeniser& tokeniser); -static malValuePtr readForm(Tokeniser& tokeniser); -static void readList(Tokeniser& tokeniser, malValueVec* items, - const String& end); -static malValuePtr processMacro(Tokeniser& tokeniser, const String& symbol); - -malValuePtr readStr(const String& input) -{ - Tokeniser tokeniser(input); - if (tokeniser.eof()) { - throw malEmptyInputException(); - } - return readForm(tokeniser); -} - -static malValuePtr readForm(Tokeniser& tokeniser) -{ - MAL_CHECK(!tokeniser.eof(), "expected form, got EOF"); - String token = tokeniser.peek(); - - MAL_CHECK(!std::regex_match(token, closeRegex), - "unexpected '%s'", token.c_str()); - - if (token == "(") { - tokeniser.next(); - std::unique_ptr items(new malValueVec); - readList(tokeniser, items.get(), ")"); - return mal::list(items.release()); - } - if (token == "[") { - tokeniser.next(); - std::unique_ptr items(new malValueVec); - readList(tokeniser, items.get(), "]"); - return mal::vector(items.release()); - } - if (token == "{") { - tokeniser.next(); - malValueVec items; - readList(tokeniser, &items, "}"); - return mal::hash(items.begin(), items.end(), false); - } - return readAtom(tokeniser); -} - -static malValuePtr readAtom(Tokeniser& tokeniser) -{ - struct ReaderMacro { - const char* token; - const char* symbol; - }; - ReaderMacro macroTable[] = { - { "@", "deref" }, - { "`", "quasiquote" }, - { "'", "quote" }, - { "~@", "splice-unquote" }, - { "~", "unquote" }, - }; - - struct Constant { - const char* token; - malValuePtr value; - }; - Constant constantTable[] = { - { "false", mal::falseValue() }, - { "nil", mal::nilValue() }, - { "true", mal::trueValue() }, - }; - - String token = tokeniser.next(); - if (token[0] == '"') { - return mal::string(unescape(token)); - } - if (token[0] == ':') { - return mal::keyword(token); - } - if (token == "^") { - malValuePtr meta = readForm(tokeniser); - malValuePtr value = readForm(tokeniser); - // Note that meta and value switch places - return mal::list(mal::symbol("with-meta"), value, meta); - } - for (auto &constant : constantTable) { - if (token == constant.token) { - return constant.value; - } - } - for (auto ¯o : macroTable) { - if (token == macro.token) { - return processMacro(tokeniser, macro.symbol); - } - } - if (std::regex_match(token, intRegex)) { - return mal::integer(token); - } - return mal::symbol(token); -} - -static void readList(Tokeniser& tokeniser, malValueVec* items, - const String& end) -{ - while (1) { - MAL_CHECK(!tokeniser.eof(), "expected '%s', got EOF", end.c_str()); - if (tokeniser.peek() == end) { - tokeniser.next(); - return; - } - items->push_back(readForm(tokeniser)); - } -} - -static malValuePtr processMacro(Tokeniser& tokeniser, const String& symbol) -{ - return mal::list(mal::symbol(symbol), readForm(tokeniser)); -} +#include "MAL.h" +#include "Types.h" + +#include + +typedef std::regex Regex; + +static const Regex intRegex("^[-+]?\\d+$"); +static const Regex closeRegex("[\\)\\]}]"); + +static const Regex whitespaceRegex("[\\s,]+|;.*"); +static const Regex tokenRegexes[] = { + Regex("~@"), + Regex("[\\[\\]{}()'`~^@]"), + Regex("\"(?:\\\\.|[^\\\\\"])*\""), + Regex("[^\\s\\[\\]{}('\"`,;)]+"), +}; + +class Tokeniser +{ +public: + Tokeniser(const String& input); + + String peek() const { + ASSERT(!eof(), "Tokeniser reading past EOF in peek\n"); + return m_token; + } + + String next() { + ASSERT(!eof(), "Tokeniser reading past EOF in next\n"); + String ret = peek(); + nextToken(); + return ret; + } + + bool eof() const { + return m_iter == m_end; + } + +private: + void skipWhitespace(); + void nextToken(); + + bool matchRegex(const Regex& regex); + + typedef String::const_iterator StringIter; + + String m_token; + StringIter m_iter; + StringIter m_end; +}; + +Tokeniser::Tokeniser(const String& input) +: m_iter(input.begin()) +, m_end(input.end()) +{ + nextToken(); +} + +bool Tokeniser::matchRegex(const Regex& regex) +{ + if (eof()) { + return false; + } + + std::smatch match; + auto flags = std::regex_constants::match_continuous; + if (!std::regex_search(m_iter, m_end, match, regex, flags)) { + return false; + } + + ASSERT(match.size() == 1, "Should only have one submatch, not %lu\n", + match.size()); + ASSERT(match.position(0) == 0, "Need to match first character\n"); + ASSERT(match.length(0) > 0, "Need to match a non-empty string\n"); + + // Don't advance m_iter now, do it after we've consumed the token in + // next(). If we do it now, we hit eof() when there's still one token left. + m_token = match.str(0); + + return true; +} + +void Tokeniser::nextToken() +{ + m_iter += m_token.size(); + + skipWhitespace(); + if (eof()) { + return; + } + + for (auto &it : tokenRegexes) { + if (matchRegex(it)) { + return; + } + } + + String mismatch(m_iter, m_end); + if (mismatch[0] == '"') { + MAL_CHECK(false, "expected '\"', got EOF"); + } + else { + MAL_CHECK(false, "unexpected '%s'", mismatch.c_str()); + } +} + +void Tokeniser::skipWhitespace() +{ + while (matchRegex(whitespaceRegex)) { + m_iter += m_token.size(); + } +} + +static malValuePtr readAtom(Tokeniser& tokeniser); +static malValuePtr readForm(Tokeniser& tokeniser); +static void readList(Tokeniser& tokeniser, malValueVec* items, + const String& end); +static malValuePtr processMacro(Tokeniser& tokeniser, const String& symbol); + +malValuePtr readStr(const String& input) +{ + Tokeniser tokeniser(input); + if (tokeniser.eof()) { + throw malEmptyInputException(); + } + return readForm(tokeniser); +} + +static malValuePtr readForm(Tokeniser& tokeniser) +{ + MAL_CHECK(!tokeniser.eof(), "expected form, got EOF"); + String token = tokeniser.peek(); + + MAL_CHECK(!std::regex_match(token, closeRegex), + "unexpected '%s'", token.c_str()); + + if (token == "(") { + tokeniser.next(); + std::unique_ptr items(new malValueVec); + readList(tokeniser, items.get(), ")"); + return mal::list(items.release()); + } + if (token == "[") { + tokeniser.next(); + std::unique_ptr items(new malValueVec); + readList(tokeniser, items.get(), "]"); + return mal::vector(items.release()); + } + if (token == "{") { + tokeniser.next(); + malValueVec items; + readList(tokeniser, &items, "}"); + return mal::hash(items.begin(), items.end(), false); + } + return readAtom(tokeniser); +} + +static malValuePtr readAtom(Tokeniser& tokeniser) +{ + struct ReaderMacro { + const char* token; + const char* symbol; + }; + ReaderMacro macroTable[] = { + { "@", "deref" }, + { "`", "quasiquote" }, + { "'", "quote" }, + { "~@", "splice-unquote" }, + { "~", "unquote" }, + }; + + struct Constant { + const char* token; + malValuePtr value; + }; + Constant constantTable[] = { + { "false", mal::falseValue() }, + { "nil", mal::nilValue() }, + { "true", mal::trueValue() }, + }; + + String token = tokeniser.next(); + if (token[0] == '"') { + return mal::string(unescape(token)); + } + if (token[0] == ':') { + return mal::keyword(token); + } + if (token == "^") { + malValuePtr meta = readForm(tokeniser); + malValuePtr value = readForm(tokeniser); + // Note that meta and value switch places + return mal::list(mal::symbol("with-meta"), value, meta); + } + for (auto &constant : constantTable) { + if (token == constant.token) { + return constant.value; + } + } + for (auto ¯o : macroTable) { + if (token == macro.token) { + return processMacro(tokeniser, macro.symbol); + } + } + if (std::regex_match(token, intRegex)) { + return mal::integer(token); + } + return mal::symbol(token); +} + +static void readList(Tokeniser& tokeniser, malValueVec* items, + const String& end) +{ + while (1) { + MAL_CHECK(!tokeniser.eof(), "expected '%s', got EOF", end.c_str()); + if (tokeniser.peek() == end) { + tokeniser.next(); + return; + } + items->push_back(readForm(tokeniser)); + } +} + +static malValuePtr processMacro(Tokeniser& tokeniser, const String& symbol) +{ + return mal::list(mal::symbol(symbol), readForm(tokeniser)); +} diff --git a/impls/cpp/RefCountedPtr.h b/impls/cpp/RefCountedPtr.h index 04cb952dc1..a5b89b566a 100644 --- a/impls/cpp/RefCountedPtr.h +++ b/impls/cpp/RefCountedPtr.h @@ -1,77 +1,77 @@ -#ifndef INCLUDE_REFCOUNTEDPTR_H -#define INCLUDE_REFCOUNTEDPTR_H - -#include "Debug.h" - -#include - -class RefCounted { -public: - RefCounted() : m_refCount(0) { } - virtual ~RefCounted() { } - - const RefCounted* acquire() const { m_refCount++; return this; } - int release() const { return --m_refCount; } - int refCount() const { return m_refCount; } - -private: - RefCounted(const RefCounted&); // no copy ctor - RefCounted& operator = (const RefCounted&); // no assignments - - mutable int m_refCount; -}; - -template -class RefCountedPtr { -public: - RefCountedPtr() : m_object(0) { } - - RefCountedPtr(T* object) : m_object(0) - { acquire(object); } - - RefCountedPtr(const RefCountedPtr& rhs) : m_object(0) - { acquire(rhs.m_object); } - - const RefCountedPtr& operator = (const RefCountedPtr& rhs) { - acquire(rhs.m_object); - return *this; - } - - bool operator == (const RefCountedPtr& rhs) const { - return m_object == rhs.m_object; - } - - bool operator != (const RefCountedPtr& rhs) const { - return m_object != rhs.m_object; - } - - operator bool () const { - return m_object != NULL; - } - - ~RefCountedPtr() { - release(); - } - - T* operator -> () const { return m_object; } - T* ptr() const { return m_object; } - -private: - void acquire(T* object) { - if (object != NULL) { - object->acquire(); - } - release(); - m_object = object; - } - - void release() { - if ((m_object != NULL) && (m_object->release() == 0)) { - delete m_object; - } - } - - T* m_object; -}; - -#endif // INCLUDE_REFCOUNTEDPTR_H +#ifndef INCLUDE_REFCOUNTEDPTR_H +#define INCLUDE_REFCOUNTEDPTR_H + +#include "Debug.h" + +#include + +class RefCounted { +public: + RefCounted() : m_refCount(0) { } + virtual ~RefCounted() { } + + const RefCounted* acquire() const { m_refCount++; return this; } + int release() const { return --m_refCount; } + int refCount() const { return m_refCount; } + +private: + RefCounted(const RefCounted&); // no copy ctor + RefCounted& operator = (const RefCounted&); // no assignments + + mutable int m_refCount; +}; + +template +class RefCountedPtr { +public: + RefCountedPtr() : m_object(0) { } + + RefCountedPtr(T* object) : m_object(0) + { acquire(object); } + + RefCountedPtr(const RefCountedPtr& rhs) : m_object(0) + { acquire(rhs.m_object); } + + const RefCountedPtr& operator = (const RefCountedPtr& rhs) { + acquire(rhs.m_object); + return *this; + } + + bool operator == (const RefCountedPtr& rhs) const { + return m_object == rhs.m_object; + } + + bool operator != (const RefCountedPtr& rhs) const { + return m_object != rhs.m_object; + } + + operator bool () const { + return m_object != NULL; + } + + ~RefCountedPtr() { + release(); + } + + T* operator -> () const { return m_object; } + T* ptr() const { return m_object; } + +private: + void acquire(T* object) { + if (object != NULL) { + object->acquire(); + } + release(); + m_object = object; + } + + void release() { + if ((m_object != NULL) && (m_object->release() == 0)) { + delete m_object; + } + } + + T* m_object; +}; + +#endif // INCLUDE_REFCOUNTEDPTR_H diff --git a/impls/cpp/StaticList.h b/impls/cpp/StaticList.h index a02a51c3a8..feee60ed90 100644 --- a/impls/cpp/StaticList.h +++ b/impls/cpp/StaticList.h @@ -1,50 +1,50 @@ -#ifndef INCLUDE_STATICLIST_H -#define INCLUDE_STATICLIST_H - -template -class StaticList -{ -public: - StaticList() : m_head(NULL) { } - - class Iterator; - Iterator begin() { return Iterator(m_head); } - Iterator end() { return Iterator(NULL); } - - class Node { - public: - Node(StaticList& list, T item) - : m_item(item), m_next(list.m_head) { - list.m_head = this; - } - - private: - friend class Iterator; - T m_item; - Node* m_next; - }; - - class Iterator { - public: - Iterator& operator ++ () { - m_node = m_node->m_next; - return *this; - } - - T& operator * () { return m_node->m_item; } - bool operator != (const Iterator& that) { - return m_node != that.m_node; - } - - private: - friend class StaticList; - Iterator(Node* node) : m_node(node) { } - Node* m_node; - }; - -private: - friend class Node; - Node* m_head; -}; - -#endif // INCLUDE_STATICLIST_H +#ifndef INCLUDE_STATICLIST_H +#define INCLUDE_STATICLIST_H + +template +class StaticList +{ +public: + StaticList() : m_head(NULL) { } + + class Iterator; + Iterator begin() { return Iterator(m_head); } + Iterator end() { return Iterator(NULL); } + + class Node { + public: + Node(StaticList& list, T item) + : m_item(item), m_next(list.m_head) { + list.m_head = this; + } + + private: + friend class Iterator; + T m_item; + Node* m_next; + }; + + class Iterator { + public: + Iterator& operator ++ () { + m_node = m_node->m_next; + return *this; + } + + T& operator * () { return m_node->m_item; } + bool operator != (const Iterator& that) { + return m_node != that.m_node; + } + + private: + friend class StaticList; + Iterator(Node* node) : m_node(node) { } + Node* m_node; + }; + +private: + friend class Node; + Node* m_head; +}; + +#endif // INCLUDE_STATICLIST_H diff --git a/impls/cpp/String.cpp b/impls/cpp/String.cpp index dcdce2b0c1..d92bdd4f5a 100644 --- a/impls/cpp/String.cpp +++ b/impls/cpp/String.cpp @@ -1,88 +1,88 @@ -#include "Debug.h" -#include "String.h" - -#include -#include -#include -#include - -// Adapted from: http://stackoverflow.com/questions/2342162 -String stringPrintf(const char* fmt, ...) { - int size = strlen(fmt); // make a guess - String str; - va_list ap; - while (1) { - str.resize(size); - va_start(ap, fmt); - int n = vsnprintf((char *)str.data(), size, fmt, ap); - va_end(ap); - if (n > -1 && n < size) { // Everything worked - str.resize(n); - return str; - } - if (n > -1) // Needed size returned - size = n + 1; // For null char - else - size *= 2; // Guess at a larger size (OS specific) - } - return str; -} - -String copyAndFree(char* mallocedString) -{ - String ret(mallocedString); - free(mallocedString); - return ret; -} - -String escape(const String& in) -{ - String out; - out.reserve(in.size() * 2 + 2); // each char may get escaped + two "'s - out += '"'; - for (auto it = in.begin(), end = in.end(); it != end; ++it) { - char c = *it; - switch (c) { - case '\\': out += "\\\\"; break; - case '\n': out += "\\n"; break; - case '"': out += "\\\""; break; - default: out += c; break; - }; - } - out += '"'; - out.shrink_to_fit(); - return out; -} - -static char unescape(char c) -{ - switch (c) { - case '\\': return '\\'; - case 'n': return '\n'; - case '"': return '"'; - default: return c; - } -} - -String unescape(const String& in) -{ - String out; - out.reserve(in.size()); // unescaped string will always be shorter - - // in will have double-quotes at either end, so move the iterators in - for (auto it = in.begin()+1, end = in.end()-1; it != end; ++it) { - char c = *it; - if (c == '\\') { - ++it; - if (it != end) { - out += unescape(*it); - } - } - else { - out += c; - } - } - out.shrink_to_fit(); - return out; -} - +#include "Debug.h" +#include "String.h" + +#include +#include +#include +#include + +// Adapted from: http://stackoverflow.com/questions/2342162 +String stringPrintf(const char* fmt, ...) { + int size = strlen(fmt); // make a guess + String str; + va_list ap; + while (1) { + str.resize(size); + va_start(ap, fmt); + int n = vsnprintf((char *)str.data(), size, fmt, ap); + va_end(ap); + if (n > -1 && n < size) { // Everything worked + str.resize(n); + return str; + } + if (n > -1) // Needed size returned + size = n + 1; // For null char + else + size *= 2; // Guess at a larger size (OS specific) + } + return str; +} + +String copyAndFree(char* mallocedString) +{ + String ret(mallocedString); + free(mallocedString); + return ret; +} + +String escape(const String& in) +{ + String out; + out.reserve(in.size() * 2 + 2); // each char may get escaped + two "'s + out += '"'; + for (auto it = in.begin(), end = in.end(); it != end; ++it) { + char c = *it; + switch (c) { + case '\\': out += "\\\\"; break; + case '\n': out += "\\n"; break; + case '"': out += "\\\""; break; + default: out += c; break; + }; + } + out += '"'; + out.shrink_to_fit(); + return out; +} + +static char unescape(char c) +{ + switch (c) { + case '\\': return '\\'; + case 'n': return '\n'; + case '"': return '"'; + default: return c; + } +} + +String unescape(const String& in) +{ + String out; + out.reserve(in.size()); // unescaped string will always be shorter + + // in will have double-quotes at either end, so move the iterators in + for (auto it = in.begin()+1, end = in.end()-1; it != end; ++it) { + char c = *it; + if (c == '\\') { + ++it; + if (it != end) { + out += unescape(*it); + } + } + else { + out += c; + } + } + out.shrink_to_fit(); + return out; +} + diff --git a/impls/cpp/String.h b/impls/cpp/String.h index bbedf9b33d..7ab1cf2156 100644 --- a/impls/cpp/String.h +++ b/impls/cpp/String.h @@ -1,18 +1,18 @@ -#ifndef INCLUDE_STRING_H -#define INCLUDE_STRING_H - -#include -#include - -typedef std::string String; -typedef std::vector StringVec; - -#define STRF stringPrintf -#define PLURAL(n) &("s"[(n)==1]) - -extern String stringPrintf(const char* fmt, ...); -extern String copyAndFree(char* mallocedString); -extern String escape(const String& s); -extern String unescape(const String& s); - -#endif // INCLUDE_STRING_H +#ifndef INCLUDE_STRING_H +#define INCLUDE_STRING_H + +#include +#include + +typedef std::string String; +typedef std::vector StringVec; + +#define STRF stringPrintf +#define PLURAL(n) &("s"[(n)==1]) + +extern String stringPrintf(const char* fmt, ...); +extern String copyAndFree(char* mallocedString); +extern String escape(const String& s); +extern String unescape(const String& s); + +#endif // INCLUDE_STRING_H diff --git a/impls/cpp/Types.cpp b/impls/cpp/Types.cpp index daf47cf748..507816964a 100644 --- a/impls/cpp/Types.cpp +++ b/impls/cpp/Types.cpp @@ -1,498 +1,498 @@ -#include "Debug.h" -#include "Environment.h" -#include "Types.h" - -#include -#include -#include - -namespace mal { - malValuePtr atom(malValuePtr value) { - return malValuePtr(new malAtom(value)); - }; - - malValuePtr boolean(bool value) { - return value ? trueValue() : falseValue(); - } - - malValuePtr builtin(const String& name, malBuiltIn::ApplyFunc handler) { - return malValuePtr(new malBuiltIn(name, handler)); - }; - - malValuePtr falseValue() { - static malValuePtr c(new malConstant("false")); - return malValuePtr(c); - }; - - - malValuePtr hash(const malHash::Map& map) { - return malValuePtr(new malHash(map)); - } - - malValuePtr hash(malValueIter argsBegin, malValueIter argsEnd, - bool isEvaluated) { - return malValuePtr(new malHash(argsBegin, argsEnd, isEvaluated)); - } - - malValuePtr integer(int64_t value) { - return malValuePtr(new malInteger(value)); - }; - - malValuePtr integer(const String& token) { - return integer(std::stoi(token)); - }; - - malValuePtr keyword(const String& token) { - return malValuePtr(new malKeyword(token)); - }; - - malValuePtr lambda(const StringVec& bindings, - malValuePtr body, malEnvPtr env) { - return malValuePtr(new malLambda(bindings, body, env)); - } - - malValuePtr list(malValueVec* items) { - return malValuePtr(new malList(items)); - }; - - malValuePtr list(malValueIter begin, malValueIter end) { - return malValuePtr(new malList(begin, end)); - }; - - malValuePtr list(malValuePtr a) { - malValueVec* items = new malValueVec(1); - items->at(0) = a; - return malValuePtr(new malList(items)); - } - - malValuePtr list(malValuePtr a, malValuePtr b) { - malValueVec* items = new malValueVec(2); - items->at(0) = a; - items->at(1) = b; - return malValuePtr(new malList(items)); - } - - malValuePtr list(malValuePtr a, malValuePtr b, malValuePtr c) { - malValueVec* items = new malValueVec(3); - items->at(0) = a; - items->at(1) = b; - items->at(2) = c; - return malValuePtr(new malList(items)); - } - - malValuePtr macro(const malLambda& lambda) { - return malValuePtr(new malLambda(lambda, true)); - }; - - malValuePtr nilValue() { - static malValuePtr c(new malConstant("nil")); - return malValuePtr(c); - }; - - malValuePtr string(const String& token) { - return malValuePtr(new malString(token)); - } - - malValuePtr symbol(const String& token) { - return malValuePtr(new malSymbol(token)); - }; - - malValuePtr trueValue() { - static malValuePtr c(new malConstant("true")); - return malValuePtr(c); - }; - - malValuePtr vector(malValueVec* items) { - return malValuePtr(new malVector(items)); - }; - - malValuePtr vector(malValueIter begin, malValueIter end) { - return malValuePtr(new malVector(begin, end)); - }; -}; - -malValuePtr malBuiltIn::apply(malValueIter argsBegin, - malValueIter argsEnd) const -{ - return m_handler(m_name, argsBegin, argsEnd); -} - -static String makeHashKey(malValuePtr key) -{ - if (const malString* skey = DYNAMIC_CAST(malString, key)) { - return skey->print(true); - } - else if (const malKeyword* kkey = DYNAMIC_CAST(malKeyword, key)) { - return kkey->print(true); - } - MAL_FAIL("%s is not a string or keyword", key->print(true).c_str()); -} - -static malHash::Map addToMap(malHash::Map& map, - malValueIter argsBegin, malValueIter argsEnd) -{ - // This is intended to be called with pre-evaluated arguments. - for (auto it = argsBegin; it != argsEnd; ++it) { - String key = makeHashKey(*it++); - map[key] = *it; - } - - return map; -} - -static malHash::Map createMap(malValueIter argsBegin, malValueIter argsEnd) -{ - MAL_CHECK(std::distance(argsBegin, argsEnd) % 2 == 0, - "hash-map requires an even-sized list"); - - malHash::Map map; - return addToMap(map, argsBegin, argsEnd); -} - -malHash::malHash(malValueIter argsBegin, malValueIter argsEnd, bool isEvaluated) -: m_map(createMap(argsBegin, argsEnd)) -, m_isEvaluated(isEvaluated) -{ - -} - -malHash::malHash(const malHash::Map& map) -: m_map(map) -, m_isEvaluated(true) -{ - -} - -malValuePtr -malHash::assoc(malValueIter argsBegin, malValueIter argsEnd) const -{ - MAL_CHECK(std::distance(argsBegin, argsEnd) % 2 == 0, - "assoc requires an even-sized list"); - - malHash::Map map(m_map); - return mal::hash(addToMap(map, argsBegin, argsEnd)); -} - -bool malHash::contains(malValuePtr key) const -{ - auto it = m_map.find(makeHashKey(key)); - return it != m_map.end(); -} - -malValuePtr -malHash::dissoc(malValueIter argsBegin, malValueIter argsEnd) const -{ - malHash::Map map(m_map); - for (auto it = argsBegin; it != argsEnd; ++it) { - String key = makeHashKey(*it); - map.erase(key); - } - return mal::hash(map); -} - -malValuePtr malHash::eval(malEnvPtr env) -{ - if (m_isEvaluated) { - return malValuePtr(this); - } - - malHash::Map map; - for (auto it = m_map.begin(), end = m_map.end(); it != end; ++it) { - map[it->first] = EVAL(it->second, env); - } - return mal::hash(map); -} - -malValuePtr malHash::get(malValuePtr key) const -{ - auto it = m_map.find(makeHashKey(key)); - return it == m_map.end() ? mal::nilValue() : it->second; -} - -malValuePtr malHash::keys() const -{ - malValueVec* keys = new malValueVec(); - keys->reserve(m_map.size()); - for (auto it = m_map.begin(), end = m_map.end(); it != end; ++it) { - if (it->first[0] == '"') { - keys->push_back(mal::string(unescape(it->first))); - } - else { - keys->push_back(mal::keyword(it->first)); - } - } - return mal::list(keys); -} - -malValuePtr malHash::values() const -{ - malValueVec* keys = new malValueVec(); - keys->reserve(m_map.size()); - for (auto it = m_map.begin(), end = m_map.end(); it != end; ++it) { - keys->push_back(it->second); - } - return mal::list(keys); -} - -String malHash::print(bool readably) const -{ - String s = "{"; - - auto it = m_map.begin(), end = m_map.end(); - if (it != end) { - s += it->first + " " + it->second->print(readably); - ++it; - } - for ( ; it != end; ++it) { - s += " " + it->first + " " + it->second->print(readably); - } - - return s + "}"; -} - -bool malHash::doIsEqualTo(const malValue* rhs) const -{ - const malHash::Map& r_map = static_cast(rhs)->m_map; - if (m_map.size() != r_map.size()) { - return false; - } - - for (auto it0 = m_map.begin(), end0 = m_map.end(), it1 = r_map.begin(); - it0 != end0; ++it0, ++it1) { - - if (it0->first != it1->first) { - return false; - } - if (!it0->second->isEqualTo(it1->second.ptr())) { - return false; - } - } - return true; -} - -malLambda::malLambda(const StringVec& bindings, - malValuePtr body, malEnvPtr env) -: m_bindings(bindings) -, m_body(body) -, m_env(env) -, m_isMacro(false) -{ - -} - -malLambda::malLambda(const malLambda& that, malValuePtr meta) -: malApplicable(meta) -, m_bindings(that.m_bindings) -, m_body(that.m_body) -, m_env(that.m_env) -, m_isMacro(that.m_isMacro) -{ - -} - -malLambda::malLambda(const malLambda& that, bool isMacro) -: malApplicable(that.m_meta) -, m_bindings(that.m_bindings) -, m_body(that.m_body) -, m_env(that.m_env) -, m_isMacro(isMacro) -{ - -} - -malValuePtr malLambda::apply(malValueIter argsBegin, - malValueIter argsEnd) const -{ - return EVAL(m_body, makeEnv(argsBegin, argsEnd)); -} - -malValuePtr malLambda::doWithMeta(malValuePtr meta) const -{ - return new malLambda(*this, meta); -} - -malEnvPtr malLambda::makeEnv(malValueIter argsBegin, malValueIter argsEnd) const -{ - return malEnvPtr(new malEnv(m_env, m_bindings, argsBegin, argsEnd)); -} - -malValuePtr malList::conj(malValueIter argsBegin, - malValueIter argsEnd) const -{ - int oldItemCount = std::distance(begin(), end()); - int newItemCount = std::distance(argsBegin, argsEnd); - - malValueVec* items = new malValueVec(oldItemCount + newItemCount); - std::reverse_copy(argsBegin, argsEnd, items->begin()); - std::copy(begin(), end(), items->begin() + newItemCount); - - return mal::list(items); -} - -malValuePtr malList::eval(malEnvPtr env) -{ - // Note, this isn't actually called since the TCO updates, but - // is required for the earlier steps, so don't get rid of it. - if (count() == 0) { - return malValuePtr(this); - } - - std::unique_ptr items(evalItems(env)); - auto it = items->begin(); - malValuePtr op = *it; - return APPLY(op, ++it, items->end()); -} - -String malList::print(bool readably) const -{ - return '(' + malSequence::print(readably) + ')'; -} - -malValuePtr malValue::eval(malEnvPtr env) -{ - // Default case of eval is just to return the object itself. - return malValuePtr(this); -} - -bool malValue::isEqualTo(const malValue* rhs) const -{ - // Special-case. Vectors and Lists can be compared. - bool matchingTypes = (typeid(*this) == typeid(*rhs)) || - (dynamic_cast(this) && - dynamic_cast(rhs)); - - return matchingTypes && doIsEqualTo(rhs); -} - -bool malValue::isTrue() const -{ - return (this != mal::falseValue().ptr()) - && (this != mal::nilValue().ptr()); -} - -malValuePtr malValue::meta() const -{ - return m_meta.ptr() == NULL ? mal::nilValue() : m_meta; -} - -malValuePtr malValue::withMeta(malValuePtr meta) const -{ - return doWithMeta(meta); -} - -malSequence::malSequence(malValueVec* items) -: m_items(items) -{ - -} - -malSequence::malSequence(malValueIter begin, malValueIter end) -: m_items(new malValueVec(begin, end)) -{ - -} - -malSequence::malSequence(const malSequence& that, malValuePtr meta) -: malValue(meta) -, m_items(new malValueVec(*(that.m_items))) -{ - -} - -malSequence::~malSequence() -{ - delete m_items; -} - -bool malSequence::doIsEqualTo(const malValue* rhs) const -{ - const malSequence* rhsSeq = static_cast(rhs); - if (count() != rhsSeq->count()) { - return false; - } - - for (malValueIter it0 = m_items->begin(), - it1 = rhsSeq->begin(), - end = m_items->end(); it0 != end; ++it0, ++it1) { - - if (! (*it0)->isEqualTo((*it1).ptr())) { - return false; - } - } - return true; -} - -malValueVec* malSequence::evalItems(malEnvPtr env) const -{ - malValueVec* items = new malValueVec;; - items->reserve(count()); - for (auto it = m_items->begin(), end = m_items->end(); it != end; ++it) { - items->push_back(EVAL(*it, env)); - } - return items; -} - -malValuePtr malSequence::first() const -{ - return count() == 0 ? mal::nilValue() : item(0); -} - -String malSequence::print(bool readably) const -{ - String str; - auto end = m_items->cend(); - auto it = m_items->cbegin(); - if (it != end) { - str += (*it)->print(readably); - ++it; - } - for ( ; it != end; ++it) { - str += " "; - str += (*it)->print(readably); - } - return str; -} - -malValuePtr malSequence::rest() const -{ - malValueIter start = (count() > 0) ? begin() + 1 : end(); - return mal::list(start, end()); -} - -String malString::escapedValue() const -{ - return escape(value()); -} - -String malString::print(bool readably) const -{ - return readably ? escapedValue() : value(); -} - -malValuePtr malSymbol::eval(malEnvPtr env) -{ - return env->get(value()); -} - -malValuePtr malVector::conj(malValueIter argsBegin, - malValueIter argsEnd) const -{ - int oldItemCount = std::distance(begin(), end()); - int newItemCount = std::distance(argsBegin, argsEnd); - - malValueVec* items = new malValueVec(oldItemCount + newItemCount); - std::copy(begin(), end(), items->begin()); - std::copy(argsBegin, argsEnd, items->begin() + oldItemCount); - - return mal::vector(items); -} - -malValuePtr malVector::eval(malEnvPtr env) -{ - return mal::vector(evalItems(env)); -} - -String malVector::print(bool readably) const -{ - return '[' + malSequence::print(readably) + ']'; -} +#include "Debug.h" +#include "Environment.h" +#include "Types.h" + +#include +#include +#include + +namespace mal { + malValuePtr atom(malValuePtr value) { + return malValuePtr(new malAtom(value)); + }; + + malValuePtr boolean(bool value) { + return value ? trueValue() : falseValue(); + } + + malValuePtr builtin(const String& name, malBuiltIn::ApplyFunc handler) { + return malValuePtr(new malBuiltIn(name, handler)); + }; + + malValuePtr falseValue() { + static malValuePtr c(new malConstant("false")); + return malValuePtr(c); + }; + + + malValuePtr hash(const malHash::Map& map) { + return malValuePtr(new malHash(map)); + } + + malValuePtr hash(malValueIter argsBegin, malValueIter argsEnd, + bool isEvaluated) { + return malValuePtr(new malHash(argsBegin, argsEnd, isEvaluated)); + } + + malValuePtr integer(int64_t value) { + return malValuePtr(new malInteger(value)); + }; + + malValuePtr integer(const String& token) { + return integer(std::stoi(token)); + }; + + malValuePtr keyword(const String& token) { + return malValuePtr(new malKeyword(token)); + }; + + malValuePtr lambda(const StringVec& bindings, + malValuePtr body, malEnvPtr env) { + return malValuePtr(new malLambda(bindings, body, env)); + } + + malValuePtr list(malValueVec* items) { + return malValuePtr(new malList(items)); + }; + + malValuePtr list(malValueIter begin, malValueIter end) { + return malValuePtr(new malList(begin, end)); + }; + + malValuePtr list(malValuePtr a) { + malValueVec* items = new malValueVec(1); + items->at(0) = a; + return malValuePtr(new malList(items)); + } + + malValuePtr list(malValuePtr a, malValuePtr b) { + malValueVec* items = new malValueVec(2); + items->at(0) = a; + items->at(1) = b; + return malValuePtr(new malList(items)); + } + + malValuePtr list(malValuePtr a, malValuePtr b, malValuePtr c) { + malValueVec* items = new malValueVec(3); + items->at(0) = a; + items->at(1) = b; + items->at(2) = c; + return malValuePtr(new malList(items)); + } + + malValuePtr macro(const malLambda& lambda) { + return malValuePtr(new malLambda(lambda, true)); + }; + + malValuePtr nilValue() { + static malValuePtr c(new malConstant("nil")); + return malValuePtr(c); + }; + + malValuePtr string(const String& token) { + return malValuePtr(new malString(token)); + } + + malValuePtr symbol(const String& token) { + return malValuePtr(new malSymbol(token)); + }; + + malValuePtr trueValue() { + static malValuePtr c(new malConstant("true")); + return malValuePtr(c); + }; + + malValuePtr vector(malValueVec* items) { + return malValuePtr(new malVector(items)); + }; + + malValuePtr vector(malValueIter begin, malValueIter end) { + return malValuePtr(new malVector(begin, end)); + }; +}; + +malValuePtr malBuiltIn::apply(malValueIter argsBegin, + malValueIter argsEnd) const +{ + return m_handler(m_name, argsBegin, argsEnd); +} + +static String makeHashKey(malValuePtr key) +{ + if (const malString* skey = DYNAMIC_CAST(malString, key)) { + return skey->print(true); + } + else if (const malKeyword* kkey = DYNAMIC_CAST(malKeyword, key)) { + return kkey->print(true); + } + MAL_FAIL("%s is not a string or keyword", key->print(true).c_str()); +} + +static malHash::Map addToMap(malHash::Map& map, + malValueIter argsBegin, malValueIter argsEnd) +{ + // This is intended to be called with pre-evaluated arguments. + for (auto it = argsBegin; it != argsEnd; ++it) { + String key = makeHashKey(*it++); + map[key] = *it; + } + + return map; +} + +static malHash::Map createMap(malValueIter argsBegin, malValueIter argsEnd) +{ + MAL_CHECK(std::distance(argsBegin, argsEnd) % 2 == 0, + "hash-map requires an even-sized list"); + + malHash::Map map; + return addToMap(map, argsBegin, argsEnd); +} + +malHash::malHash(malValueIter argsBegin, malValueIter argsEnd, bool isEvaluated) +: m_map(createMap(argsBegin, argsEnd)) +, m_isEvaluated(isEvaluated) +{ + +} + +malHash::malHash(const malHash::Map& map) +: m_map(map) +, m_isEvaluated(true) +{ + +} + +malValuePtr +malHash::assoc(malValueIter argsBegin, malValueIter argsEnd) const +{ + MAL_CHECK(std::distance(argsBegin, argsEnd) % 2 == 0, + "assoc requires an even-sized list"); + + malHash::Map map(m_map); + return mal::hash(addToMap(map, argsBegin, argsEnd)); +} + +bool malHash::contains(malValuePtr key) const +{ + auto it = m_map.find(makeHashKey(key)); + return it != m_map.end(); +} + +malValuePtr +malHash::dissoc(malValueIter argsBegin, malValueIter argsEnd) const +{ + malHash::Map map(m_map); + for (auto it = argsBegin; it != argsEnd; ++it) { + String key = makeHashKey(*it); + map.erase(key); + } + return mal::hash(map); +} + +malValuePtr malHash::eval(malEnvPtr env) +{ + if (m_isEvaluated) { + return malValuePtr(this); + } + + malHash::Map map; + for (auto it = m_map.begin(), end = m_map.end(); it != end; ++it) { + map[it->first] = EVAL(it->second, env); + } + return mal::hash(map); +} + +malValuePtr malHash::get(malValuePtr key) const +{ + auto it = m_map.find(makeHashKey(key)); + return it == m_map.end() ? mal::nilValue() : it->second; +} + +malValuePtr malHash::keys() const +{ + malValueVec* keys = new malValueVec(); + keys->reserve(m_map.size()); + for (auto it = m_map.begin(), end = m_map.end(); it != end; ++it) { + if (it->first[0] == '"') { + keys->push_back(mal::string(unescape(it->first))); + } + else { + keys->push_back(mal::keyword(it->first)); + } + } + return mal::list(keys); +} + +malValuePtr malHash::values() const +{ + malValueVec* keys = new malValueVec(); + keys->reserve(m_map.size()); + for (auto it = m_map.begin(), end = m_map.end(); it != end; ++it) { + keys->push_back(it->second); + } + return mal::list(keys); +} + +String malHash::print(bool readably) const +{ + String s = "{"; + + auto it = m_map.begin(), end = m_map.end(); + if (it != end) { + s += it->first + " " + it->second->print(readably); + ++it; + } + for ( ; it != end; ++it) { + s += " " + it->first + " " + it->second->print(readably); + } + + return s + "}"; +} + +bool malHash::doIsEqualTo(const malValue* rhs) const +{ + const malHash::Map& r_map = static_cast(rhs)->m_map; + if (m_map.size() != r_map.size()) { + return false; + } + + for (auto it0 = m_map.begin(), end0 = m_map.end(), it1 = r_map.begin(); + it0 != end0; ++it0, ++it1) { + + if (it0->first != it1->first) { + return false; + } + if (!it0->second->isEqualTo(it1->second.ptr())) { + return false; + } + } + return true; +} + +malLambda::malLambda(const StringVec& bindings, + malValuePtr body, malEnvPtr env) +: m_bindings(bindings) +, m_body(body) +, m_env(env) +, m_isMacro(false) +{ + +} + +malLambda::malLambda(const malLambda& that, malValuePtr meta) +: malApplicable(meta) +, m_bindings(that.m_bindings) +, m_body(that.m_body) +, m_env(that.m_env) +, m_isMacro(that.m_isMacro) +{ + +} + +malLambda::malLambda(const malLambda& that, bool isMacro) +: malApplicable(that.m_meta) +, m_bindings(that.m_bindings) +, m_body(that.m_body) +, m_env(that.m_env) +, m_isMacro(isMacro) +{ + +} + +malValuePtr malLambda::apply(malValueIter argsBegin, + malValueIter argsEnd) const +{ + return EVAL(m_body, makeEnv(argsBegin, argsEnd)); +} + +malValuePtr malLambda::doWithMeta(malValuePtr meta) const +{ + return new malLambda(*this, meta); +} + +malEnvPtr malLambda::makeEnv(malValueIter argsBegin, malValueIter argsEnd) const +{ + return malEnvPtr(new malEnv(m_env, m_bindings, argsBegin, argsEnd)); +} + +malValuePtr malList::conj(malValueIter argsBegin, + malValueIter argsEnd) const +{ + int oldItemCount = std::distance(begin(), end()); + int newItemCount = std::distance(argsBegin, argsEnd); + + malValueVec* items = new malValueVec(oldItemCount + newItemCount); + std::reverse_copy(argsBegin, argsEnd, items->begin()); + std::copy(begin(), end(), items->begin() + newItemCount); + + return mal::list(items); +} + +malValuePtr malList::eval(malEnvPtr env) +{ + // Note, this isn't actually called since the TCO updates, but + // is required for the earlier steps, so don't get rid of it. + if (count() == 0) { + return malValuePtr(this); + } + + std::unique_ptr items(evalItems(env)); + auto it = items->begin(); + malValuePtr op = *it; + return APPLY(op, ++it, items->end()); +} + +String malList::print(bool readably) const +{ + return '(' + malSequence::print(readably) + ')'; +} + +malValuePtr malValue::eval(malEnvPtr env) +{ + // Default case of eval is just to return the object itself. + return malValuePtr(this); +} + +bool malValue::isEqualTo(const malValue* rhs) const +{ + // Special-case. Vectors and Lists can be compared. + bool matchingTypes = (typeid(*this) == typeid(*rhs)) || + (dynamic_cast(this) && + dynamic_cast(rhs)); + + return matchingTypes && doIsEqualTo(rhs); +} + +bool malValue::isTrue() const +{ + return (this != mal::falseValue().ptr()) + && (this != mal::nilValue().ptr()); +} + +malValuePtr malValue::meta() const +{ + return m_meta.ptr() == NULL ? mal::nilValue() : m_meta; +} + +malValuePtr malValue::withMeta(malValuePtr meta) const +{ + return doWithMeta(meta); +} + +malSequence::malSequence(malValueVec* items) +: m_items(items) +{ + +} + +malSequence::malSequence(malValueIter begin, malValueIter end) +: m_items(new malValueVec(begin, end)) +{ + +} + +malSequence::malSequence(const malSequence& that, malValuePtr meta) +: malValue(meta) +, m_items(new malValueVec(*(that.m_items))) +{ + +} + +malSequence::~malSequence() +{ + delete m_items; +} + +bool malSequence::doIsEqualTo(const malValue* rhs) const +{ + const malSequence* rhsSeq = static_cast(rhs); + if (count() != rhsSeq->count()) { + return false; + } + + for (malValueIter it0 = m_items->begin(), + it1 = rhsSeq->begin(), + end = m_items->end(); it0 != end; ++it0, ++it1) { + + if (! (*it0)->isEqualTo((*it1).ptr())) { + return false; + } + } + return true; +} + +malValueVec* malSequence::evalItems(malEnvPtr env) const +{ + malValueVec* items = new malValueVec;; + items->reserve(count()); + for (auto it = m_items->begin(), end = m_items->end(); it != end; ++it) { + items->push_back(EVAL(*it, env)); + } + return items; +} + +malValuePtr malSequence::first() const +{ + return count() == 0 ? mal::nilValue() : item(0); +} + +String malSequence::print(bool readably) const +{ + String str; + auto end = m_items->cend(); + auto it = m_items->cbegin(); + if (it != end) { + str += (*it)->print(readably); + ++it; + } + for ( ; it != end; ++it) { + str += " "; + str += (*it)->print(readably); + } + return str; +} + +malValuePtr malSequence::rest() const +{ + malValueIter start = (count() > 0) ? begin() + 1 : end(); + return mal::list(start, end()); +} + +String malString::escapedValue() const +{ + return escape(value()); +} + +String malString::print(bool readably) const +{ + return readably ? escapedValue() : value(); +} + +malValuePtr malSymbol::eval(malEnvPtr env) +{ + return env->get(value()); +} + +malValuePtr malVector::conj(malValueIter argsBegin, + malValueIter argsEnd) const +{ + int oldItemCount = std::distance(begin(), end()); + int newItemCount = std::distance(argsBegin, argsEnd); + + malValueVec* items = new malValueVec(oldItemCount + newItemCount); + std::copy(begin(), end(), items->begin()); + std::copy(argsBegin, argsEnd, items->begin() + oldItemCount); + + return mal::vector(items); +} + +malValuePtr malVector::eval(malEnvPtr env) +{ + return mal::vector(evalItems(env)); +} + +String malVector::print(bool readably) const +{ + return '[' + malSequence::print(readably) + ']'; +} diff --git a/impls/cpp/Types.h b/impls/cpp/Types.h index f92887c0fa..6dcd7f991b 100644 --- a/impls/cpp/Types.h +++ b/impls/cpp/Types.h @@ -1,374 +1,374 @@ -#ifndef INCLUDE_TYPES_H -#define INCLUDE_TYPES_H - -#include "MAL.h" - -#include -#include - -class malEmptyInputException : public std::exception { }; - -class malValue : public RefCounted { -public: - malValue() { - TRACE_OBJECT("Creating malValue %p\n", this); - } - malValue(malValuePtr meta) : m_meta(meta) { - TRACE_OBJECT("Creating malValue %p\n", this); - } - virtual ~malValue() { - TRACE_OBJECT("Destroying malValue %p\n", this); - } - - malValuePtr withMeta(malValuePtr meta) const; - virtual malValuePtr doWithMeta(malValuePtr meta) const = 0; - malValuePtr meta() const; - - bool isTrue() const; - - bool isEqualTo(const malValue* rhs) const; - - virtual malValuePtr eval(malEnvPtr env); - - virtual String print(bool readably) const = 0; - -protected: - virtual bool doIsEqualTo(const malValue* rhs) const = 0; - - malValuePtr m_meta; -}; - -template -T* value_cast(malValuePtr obj, const char* typeName) { - T* dest = dynamic_cast(obj.ptr()); - MAL_CHECK(dest != NULL, "%s is not a %s", - obj->print(true).c_str(), typeName); - return dest; -} - -#define VALUE_CAST(Type, Value) value_cast(Value, #Type) -#define DYNAMIC_CAST(Type, Value) (dynamic_cast((Value).ptr())) -#define STATIC_CAST(Type, Value) (static_cast((Value).ptr())) - -#define WITH_META(Type) \ - virtual malValuePtr doWithMeta(malValuePtr meta) const { \ - return new Type(*this, meta); \ - } \ - -class malConstant : public malValue { -public: - malConstant(String name) : m_name(name) { } - malConstant(const malConstant& that, malValuePtr meta) - : malValue(meta), m_name(that.m_name) { } - - virtual String print(bool readably) const { return m_name; } - - virtual bool doIsEqualTo(const malValue* rhs) const { - return this == rhs; // these are singletons - } - - WITH_META(malConstant); - -private: - const String m_name; -}; - -class malInteger : public malValue { -public: - malInteger(int64_t value) : m_value(value) { } - malInteger(const malInteger& that, malValuePtr meta) - : malValue(meta), m_value(that.m_value) { } - - virtual String print(bool readably) const { - return std::to_string(m_value); - } - - int64_t value() const { return m_value; } - - virtual bool doIsEqualTo(const malValue* rhs) const { - return m_value == static_cast(rhs)->m_value; - } - - WITH_META(malInteger); - -private: - const int64_t m_value; -}; - -class malStringBase : public malValue { -public: - malStringBase(const String& token) - : m_value(token) { } - malStringBase(const malStringBase& that, malValuePtr meta) - : malValue(meta), m_value(that.value()) { } - - virtual String print(bool readably) const { return m_value; } - - String value() const { return m_value; } - -private: - const String m_value; -}; - -class malString : public malStringBase { -public: - malString(const String& token) - : malStringBase(token) { } - malString(const malString& that, malValuePtr meta) - : malStringBase(that, meta) { } - - virtual String print(bool readably) const; - - String escapedValue() const; - - virtual bool doIsEqualTo(const malValue* rhs) const { - return value() == static_cast(rhs)->value(); - } - - WITH_META(malString); -}; - -class malKeyword : public malStringBase { -public: - malKeyword(const String& token) - : malStringBase(token) { } - malKeyword(const malKeyword& that, malValuePtr meta) - : malStringBase(that, meta) { } - - virtual bool doIsEqualTo(const malValue* rhs) const { - return value() == static_cast(rhs)->value(); - } - - WITH_META(malKeyword); -}; - -class malSymbol : public malStringBase { -public: - malSymbol(const String& token) - : malStringBase(token) { } - malSymbol(const malSymbol& that, malValuePtr meta) - : malStringBase(that, meta) { } - - virtual malValuePtr eval(malEnvPtr env); - - virtual bool doIsEqualTo(const malValue* rhs) const { - return value() == static_cast(rhs)->value(); - } - - WITH_META(malSymbol); -}; - -class malSequence : public malValue { -public: - malSequence(malValueVec* items); - malSequence(malValueIter begin, malValueIter end); - malSequence(const malSequence& that, malValuePtr meta); - virtual ~malSequence(); - - virtual String print(bool readably) const; - - malValueVec* evalItems(malEnvPtr env) const; - int count() const { return m_items->size(); } - bool isEmpty() const { return m_items->empty(); } - malValuePtr item(int index) const { return (*m_items)[index]; } - - malValueIter begin() const { return m_items->begin(); } - malValueIter end() const { return m_items->end(); } - - virtual bool doIsEqualTo(const malValue* rhs) const; - - virtual malValuePtr conj(malValueIter argsBegin, - malValueIter argsEnd) const = 0; - - malValuePtr first() const; - virtual malValuePtr rest() const; - -private: - malValueVec* const m_items; -}; - -class malList : public malSequence { -public: - malList(malValueVec* items) : malSequence(items) { } - malList(malValueIter begin, malValueIter end) - : malSequence(begin, end) { } - malList(const malList& that, malValuePtr meta) - : malSequence(that, meta) { } - - virtual String print(bool readably) const; - virtual malValuePtr eval(malEnvPtr env); - - virtual malValuePtr conj(malValueIter argsBegin, - malValueIter argsEnd) const; - - WITH_META(malList); -}; - -class malVector : public malSequence { -public: - malVector(malValueVec* items) : malSequence(items) { } - malVector(malValueIter begin, malValueIter end) - : malSequence(begin, end) { } - malVector(const malVector& that, malValuePtr meta) - : malSequence(that, meta) { } - - virtual malValuePtr eval(malEnvPtr env); - virtual String print(bool readably) const; - - virtual malValuePtr conj(malValueIter argsBegin, - malValueIter argsEnd) const; - - WITH_META(malVector); -}; - -class malApplicable : public malValue { -public: - malApplicable() { } - malApplicable(malValuePtr meta) : malValue(meta) { } - - virtual malValuePtr apply(malValueIter argsBegin, - malValueIter argsEnd) const = 0; -}; - -class malHash : public malValue { -public: - typedef std::map Map; - - malHash(malValueIter argsBegin, malValueIter argsEnd, bool isEvaluated); - malHash(const malHash::Map& map); - malHash(const malHash& that, malValuePtr meta) - : malValue(meta), m_map(that.m_map), m_isEvaluated(that.m_isEvaluated) { } - - malValuePtr assoc(malValueIter argsBegin, malValueIter argsEnd) const; - malValuePtr dissoc(malValueIter argsBegin, malValueIter argsEnd) const; - bool contains(malValuePtr key) const; - malValuePtr eval(malEnvPtr env); - malValuePtr get(malValuePtr key) const; - malValuePtr keys() const; - malValuePtr values() const; - - virtual String print(bool readably) const; - - virtual bool doIsEqualTo(const malValue* rhs) const; - - WITH_META(malHash); - -private: - const Map m_map; - const bool m_isEvaluated; -}; - -class malBuiltIn : public malApplicable { -public: - typedef malValuePtr (ApplyFunc)(const String& name, - malValueIter argsBegin, - malValueIter argsEnd); - - malBuiltIn(const String& name, ApplyFunc* handler) - : m_name(name), m_handler(handler) { } - - malBuiltIn(const malBuiltIn& that, malValuePtr meta) - : malApplicable(meta), m_name(that.m_name), m_handler(that.m_handler) { } - - virtual malValuePtr apply(malValueIter argsBegin, - malValueIter argsEnd) const; - - virtual String print(bool readably) const { - return STRF("#builtin-function(%s)", m_name.c_str()); - } - - virtual bool doIsEqualTo(const malValue* rhs) const { - return this == rhs; // these are singletons - } - - String name() const { return m_name; } - - WITH_META(malBuiltIn); - -private: - const String m_name; - ApplyFunc* m_handler; -}; - -class malLambda : public malApplicable { -public: - malLambda(const StringVec& bindings, malValuePtr body, malEnvPtr env); - malLambda(const malLambda& that, malValuePtr meta); - malLambda(const malLambda& that, bool isMacro); - - virtual malValuePtr apply(malValueIter argsBegin, - malValueIter argsEnd) const; - - malValuePtr getBody() const { return m_body; } - malEnvPtr makeEnv(malValueIter argsBegin, malValueIter argsEnd) const; - - virtual bool doIsEqualTo(const malValue* rhs) const { - return this == rhs; // do we need to do a deep inspection? - } - - virtual String print(bool readably) const { - return STRF("#user-%s(%p)", m_isMacro ? "macro" : "function", this); - } - - bool isMacro() const { return m_isMacro; } - - virtual malValuePtr doWithMeta(malValuePtr meta) const; - -private: - const StringVec m_bindings; - const malValuePtr m_body; - const malEnvPtr m_env; - const bool m_isMacro; -}; - -class malAtom : public malValue { -public: - malAtom(malValuePtr value) : m_value(value) { } - malAtom(const malAtom& that, malValuePtr meta) - : malValue(meta), m_value(that.m_value) { } - - virtual bool doIsEqualTo(const malValue* rhs) const { - return this->m_value->isEqualTo(rhs); - } - - virtual String print(bool readably) const { - return "(atom " + m_value->print(readably) + ")"; - }; - - malValuePtr deref() const { return m_value; } - - malValuePtr reset(malValuePtr value) { return m_value = value; } - - WITH_META(malAtom); - -private: - malValuePtr m_value; -}; - -namespace mal { - malValuePtr atom(malValuePtr value); - malValuePtr boolean(bool value); - malValuePtr builtin(const String& name, malBuiltIn::ApplyFunc handler); - malValuePtr falseValue(); - malValuePtr hash(malValueIter argsBegin, malValueIter argsEnd, - bool isEvaluated); - malValuePtr hash(const malHash::Map& map); - malValuePtr integer(int64_t value); - malValuePtr integer(const String& token); - malValuePtr keyword(const String& token); - malValuePtr lambda(const StringVec&, malValuePtr, malEnvPtr); - malValuePtr list(malValueVec* items); - malValuePtr list(malValueIter begin, malValueIter end); - malValuePtr list(malValuePtr a); - malValuePtr list(malValuePtr a, malValuePtr b); - malValuePtr list(malValuePtr a, malValuePtr b, malValuePtr c); - malValuePtr macro(const malLambda& lambda); - malValuePtr nilValue(); - malValuePtr string(const String& token); - malValuePtr symbol(const String& token); - malValuePtr trueValue(); - malValuePtr vector(malValueVec* items); - malValuePtr vector(malValueIter begin, malValueIter end); -}; - -#endif // INCLUDE_TYPES_H +#ifndef INCLUDE_TYPES_H +#define INCLUDE_TYPES_H + +#include "MAL.h" + +#include +#include + +class malEmptyInputException : public std::exception { }; + +class malValue : public RefCounted { +public: + malValue() { + TRACE_OBJECT("Creating malValue %p\n", this); + } + malValue(malValuePtr meta) : m_meta(meta) { + TRACE_OBJECT("Creating malValue %p\n", this); + } + virtual ~malValue() { + TRACE_OBJECT("Destroying malValue %p\n", this); + } + + malValuePtr withMeta(malValuePtr meta) const; + virtual malValuePtr doWithMeta(malValuePtr meta) const = 0; + malValuePtr meta() const; + + bool isTrue() const; + + bool isEqualTo(const malValue* rhs) const; + + virtual malValuePtr eval(malEnvPtr env); + + virtual String print(bool readably) const = 0; + +protected: + virtual bool doIsEqualTo(const malValue* rhs) const = 0; + + malValuePtr m_meta; +}; + +template +T* value_cast(malValuePtr obj, const char* typeName) { + T* dest = dynamic_cast(obj.ptr()); + MAL_CHECK(dest != NULL, "%s is not a %s", + obj->print(true).c_str(), typeName); + return dest; +} + +#define VALUE_CAST(Type, Value) value_cast(Value, #Type) +#define DYNAMIC_CAST(Type, Value) (dynamic_cast((Value).ptr())) +#define STATIC_CAST(Type, Value) (static_cast((Value).ptr())) + +#define WITH_META(Type) \ + virtual malValuePtr doWithMeta(malValuePtr meta) const { \ + return new Type(*this, meta); \ + } \ + +class malConstant : public malValue { +public: + malConstant(String name) : m_name(name) { } + malConstant(const malConstant& that, malValuePtr meta) + : malValue(meta), m_name(that.m_name) { } + + virtual String print(bool readably) const { return m_name; } + + virtual bool doIsEqualTo(const malValue* rhs) const { + return this == rhs; // these are singletons + } + + WITH_META(malConstant); + +private: + const String m_name; +}; + +class malInteger : public malValue { +public: + malInteger(int64_t value) : m_value(value) { } + malInteger(const malInteger& that, malValuePtr meta) + : malValue(meta), m_value(that.m_value) { } + + virtual String print(bool readably) const { + return std::to_string(m_value); + } + + int64_t value() const { return m_value; } + + virtual bool doIsEqualTo(const malValue* rhs) const { + return m_value == static_cast(rhs)->m_value; + } + + WITH_META(malInteger); + +private: + const int64_t m_value; +}; + +class malStringBase : public malValue { +public: + malStringBase(const String& token) + : m_value(token) { } + malStringBase(const malStringBase& that, malValuePtr meta) + : malValue(meta), m_value(that.value()) { } + + virtual String print(bool readably) const { return m_value; } + + String value() const { return m_value; } + +private: + const String m_value; +}; + +class malString : public malStringBase { +public: + malString(const String& token) + : malStringBase(token) { } + malString(const malString& that, malValuePtr meta) + : malStringBase(that, meta) { } + + virtual String print(bool readably) const; + + String escapedValue() const; + + virtual bool doIsEqualTo(const malValue* rhs) const { + return value() == static_cast(rhs)->value(); + } + + WITH_META(malString); +}; + +class malKeyword : public malStringBase { +public: + malKeyword(const String& token) + : malStringBase(token) { } + malKeyword(const malKeyword& that, malValuePtr meta) + : malStringBase(that, meta) { } + + virtual bool doIsEqualTo(const malValue* rhs) const { + return value() == static_cast(rhs)->value(); + } + + WITH_META(malKeyword); +}; + +class malSymbol : public malStringBase { +public: + malSymbol(const String& token) + : malStringBase(token) { } + malSymbol(const malSymbol& that, malValuePtr meta) + : malStringBase(that, meta) { } + + virtual malValuePtr eval(malEnvPtr env); + + virtual bool doIsEqualTo(const malValue* rhs) const { + return value() == static_cast(rhs)->value(); + } + + WITH_META(malSymbol); +}; + +class malSequence : public malValue { +public: + malSequence(malValueVec* items); + malSequence(malValueIter begin, malValueIter end); + malSequence(const malSequence& that, malValuePtr meta); + virtual ~malSequence(); + + virtual String print(bool readably) const; + + malValueVec* evalItems(malEnvPtr env) const; + int count() const { return m_items->size(); } + bool isEmpty() const { return m_items->empty(); } + malValuePtr item(int index) const { return (*m_items)[index]; } + + malValueIter begin() const { return m_items->begin(); } + malValueIter end() const { return m_items->end(); } + + virtual bool doIsEqualTo(const malValue* rhs) const; + + virtual malValuePtr conj(malValueIter argsBegin, + malValueIter argsEnd) const = 0; + + malValuePtr first() const; + virtual malValuePtr rest() const; + +private: + malValueVec* const m_items; +}; + +class malList : public malSequence { +public: + malList(malValueVec* items) : malSequence(items) { } + malList(malValueIter begin, malValueIter end) + : malSequence(begin, end) { } + malList(const malList& that, malValuePtr meta) + : malSequence(that, meta) { } + + virtual String print(bool readably) const; + virtual malValuePtr eval(malEnvPtr env); + + virtual malValuePtr conj(malValueIter argsBegin, + malValueIter argsEnd) const; + + WITH_META(malList); +}; + +class malVector : public malSequence { +public: + malVector(malValueVec* items) : malSequence(items) { } + malVector(malValueIter begin, malValueIter end) + : malSequence(begin, end) { } + malVector(const malVector& that, malValuePtr meta) + : malSequence(that, meta) { } + + virtual malValuePtr eval(malEnvPtr env); + virtual String print(bool readably) const; + + virtual malValuePtr conj(malValueIter argsBegin, + malValueIter argsEnd) const; + + WITH_META(malVector); +}; + +class malApplicable : public malValue { +public: + malApplicable() { } + malApplicable(malValuePtr meta) : malValue(meta) { } + + virtual malValuePtr apply(malValueIter argsBegin, + malValueIter argsEnd) const = 0; +}; + +class malHash : public malValue { +public: + typedef std::map Map; + + malHash(malValueIter argsBegin, malValueIter argsEnd, bool isEvaluated); + malHash(const malHash::Map& map); + malHash(const malHash& that, malValuePtr meta) + : malValue(meta), m_map(that.m_map), m_isEvaluated(that.m_isEvaluated) { } + + malValuePtr assoc(malValueIter argsBegin, malValueIter argsEnd) const; + malValuePtr dissoc(malValueIter argsBegin, malValueIter argsEnd) const; + bool contains(malValuePtr key) const; + malValuePtr eval(malEnvPtr env); + malValuePtr get(malValuePtr key) const; + malValuePtr keys() const; + malValuePtr values() const; + + virtual String print(bool readably) const; + + virtual bool doIsEqualTo(const malValue* rhs) const; + + WITH_META(malHash); + +private: + const Map m_map; + const bool m_isEvaluated; +}; + +class malBuiltIn : public malApplicable { +public: + typedef malValuePtr (ApplyFunc)(const String& name, + malValueIter argsBegin, + malValueIter argsEnd); + + malBuiltIn(const String& name, ApplyFunc* handler) + : m_name(name), m_handler(handler) { } + + malBuiltIn(const malBuiltIn& that, malValuePtr meta) + : malApplicable(meta), m_name(that.m_name), m_handler(that.m_handler) { } + + virtual malValuePtr apply(malValueIter argsBegin, + malValueIter argsEnd) const; + + virtual String print(bool readably) const { + return STRF("#builtin-function(%s)", m_name.c_str()); + } + + virtual bool doIsEqualTo(const malValue* rhs) const { + return this == rhs; // these are singletons + } + + String name() const { return m_name; } + + WITH_META(malBuiltIn); + +private: + const String m_name; + ApplyFunc* m_handler; +}; + +class malLambda : public malApplicable { +public: + malLambda(const StringVec& bindings, malValuePtr body, malEnvPtr env); + malLambda(const malLambda& that, malValuePtr meta); + malLambda(const malLambda& that, bool isMacro); + + virtual malValuePtr apply(malValueIter argsBegin, + malValueIter argsEnd) const; + + malValuePtr getBody() const { return m_body; } + malEnvPtr makeEnv(malValueIter argsBegin, malValueIter argsEnd) const; + + virtual bool doIsEqualTo(const malValue* rhs) const { + return this == rhs; // do we need to do a deep inspection? + } + + virtual String print(bool readably) const { + return STRF("#user-%s(%p)", m_isMacro ? "macro" : "function", this); + } + + bool isMacro() const { return m_isMacro; } + + virtual malValuePtr doWithMeta(malValuePtr meta) const; + +private: + const StringVec m_bindings; + const malValuePtr m_body; + const malEnvPtr m_env; + const bool m_isMacro; +}; + +class malAtom : public malValue { +public: + malAtom(malValuePtr value) : m_value(value) { } + malAtom(const malAtom& that, malValuePtr meta) + : malValue(meta), m_value(that.m_value) { } + + virtual bool doIsEqualTo(const malValue* rhs) const { + return this->m_value->isEqualTo(rhs); + } + + virtual String print(bool readably) const { + return "(atom " + m_value->print(readably) + ")"; + }; + + malValuePtr deref() const { return m_value; } + + malValuePtr reset(malValuePtr value) { return m_value = value; } + + WITH_META(malAtom); + +private: + malValuePtr m_value; +}; + +namespace mal { + malValuePtr atom(malValuePtr value); + malValuePtr boolean(bool value); + malValuePtr builtin(const String& name, malBuiltIn::ApplyFunc handler); + malValuePtr falseValue(); + malValuePtr hash(malValueIter argsBegin, malValueIter argsEnd, + bool isEvaluated); + malValuePtr hash(const malHash::Map& map); + malValuePtr integer(int64_t value); + malValuePtr integer(const String& token); + malValuePtr keyword(const String& token); + malValuePtr lambda(const StringVec&, malValuePtr, malEnvPtr); + malValuePtr list(malValueVec* items); + malValuePtr list(malValueIter begin, malValueIter end); + malValuePtr list(malValuePtr a); + malValuePtr list(malValuePtr a, malValuePtr b); + malValuePtr list(malValuePtr a, malValuePtr b, malValuePtr c); + malValuePtr macro(const malLambda& lambda); + malValuePtr nilValue(); + malValuePtr string(const String& token); + malValuePtr symbol(const String& token); + malValuePtr trueValue(); + malValuePtr vector(malValueVec* items); + malValuePtr vector(malValueIter begin, malValueIter end); +}; + +#endif // INCLUDE_TYPES_H diff --git a/impls/cpp/Validation.cpp b/impls/cpp/Validation.cpp index 5b03b0f8ae..b8ff9068cb 100644 --- a/impls/cpp/Validation.cpp +++ b/impls/cpp/Validation.cpp @@ -1,33 +1,33 @@ -#include "Validation.h" - -int checkArgsIs(const char* name, int expected, int got) -{ - MAL_CHECK(got == expected, - "\"%s\" expects %d arg%s, %d supplied", - name, expected, PLURAL(expected), got); - return got; -} - -int checkArgsBetween(const char* name, int min, int max, int got) -{ - MAL_CHECK((got >= min) && (got <= max), - "\"%s\" expects between %d and %d arg%s, %d supplied", - name, min, max, PLURAL(max), got); - return got; -} - -int checkArgsAtLeast(const char* name, int min, int got) -{ - MAL_CHECK(got >= min, - "\"%s\" expects at least %d arg%s, %d supplied", - name, min, PLURAL(min), got); - return got; -} - -int checkArgsEven(const char* name, int got) -{ - MAL_CHECK(got % 2 == 0, - "\"%s\" expects an even number of args, %d supplied", - name, got); - return got; -} +#include "Validation.h" + +int checkArgsIs(const char* name, int expected, int got) +{ + MAL_CHECK(got == expected, + "\"%s\" expects %d arg%s, %d supplied", + name, expected, PLURAL(expected), got); + return got; +} + +int checkArgsBetween(const char* name, int min, int max, int got) +{ + MAL_CHECK((got >= min) && (got <= max), + "\"%s\" expects between %d and %d arg%s, %d supplied", + name, min, max, PLURAL(max), got); + return got; +} + +int checkArgsAtLeast(const char* name, int min, int got) +{ + MAL_CHECK(got >= min, + "\"%s\" expects at least %d arg%s, %d supplied", + name, min, PLURAL(min), got); + return got; +} + +int checkArgsEven(const char* name, int got) +{ + MAL_CHECK(got % 2 == 0, + "\"%s\" expects an even number of args, %d supplied", + name, got); + return got; +} diff --git a/impls/cpp/Validation.h b/impls/cpp/Validation.h index d65e0fb64d..fe072920ea 100644 --- a/impls/cpp/Validation.h +++ b/impls/cpp/Validation.h @@ -1,16 +1,16 @@ -#ifndef INCLUDE_VALIDATION_H -#define INCLUDE_VALIDATION_H - -#include "String.h" - -#define MAL_CHECK(condition, ...) \ - if (!(condition)) { throw STRF(__VA_ARGS__); } else { } - -#define MAL_FAIL(...) MAL_CHECK(false, __VA_ARGS__) - -extern int checkArgsIs(const char* name, int expected, int got); -extern int checkArgsBetween(const char* name, int min, int max, int got); -extern int checkArgsAtLeast(const char* name, int min, int got); -extern int checkArgsEven(const char* name, int got); - -#endif // INCLUDE_VALIDATION_H +#ifndef INCLUDE_VALIDATION_H +#define INCLUDE_VALIDATION_H + +#include "String.h" + +#define MAL_CHECK(condition, ...) \ + if (!(condition)) { throw STRF(__VA_ARGS__); } else { } + +#define MAL_FAIL(...) MAL_CHECK(false, __VA_ARGS__) + +extern int checkArgsIs(const char* name, int expected, int got); +extern int checkArgsBetween(const char* name, int min, int max, int got); +extern int checkArgsAtLeast(const char* name, int min, int got); +extern int checkArgsEven(const char* name, int got); + +#endif // INCLUDE_VALIDATION_H diff --git a/impls/cpp/docker.sh b/impls/cpp/docker.sh index 4fb261dcf6..930d8750c6 100755 --- a/impls/cpp/docker.sh +++ b/impls/cpp/docker.sh @@ -1,34 +1,34 @@ -#!/bin/bash - -IMAGE_NAME=mal-cpp -CONTAINER_NAME=mal-cpp-running - -run() { - docker rm -f $CONTAINER_NAME > /dev/null 2>/dev/null - docker run -v $PWD:/mal -ti --name $CONTAINER_NAME $IMAGE_NAME "$@" -} - -case $1 in - - build) - docker build -t $IMAGE_NAME . - ;; - - run) - shift - run "$@" - ;; - - make) - shift - run make "$@" - ;; - - *) - echo "usage: $0 [build|run|make]" - exit 1 - - ;; - -esac - +#!/bin/bash + +IMAGE_NAME=mal-cpp +CONTAINER_NAME=mal-cpp-running + +run() { + docker rm -f $CONTAINER_NAME > /dev/null 2>/dev/null + docker run -v $PWD:/mal -ti --name $CONTAINER_NAME $IMAGE_NAME "$@" +} + +case $1 in + + build) + docker build -t $IMAGE_NAME . + ;; + + run) + shift + run "$@" + ;; + + make) + shift + run make "$@" + ;; + + *) + echo "usage: $0 [build|run|make]" + exit 1 + + ;; + +esac + diff --git a/impls/cpp/run b/impls/cpp/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/cpp/run +++ b/impls/cpp/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/cpp/step0_repl.cpp b/impls/cpp/step0_repl.cpp index 6b9b29c8d6..72b27774f8 100644 --- a/impls/cpp/step0_repl.cpp +++ b/impls/cpp/step0_repl.cpp @@ -1,42 +1,42 @@ -#include "String.h" -#include "ReadLine.h" - -#include -#include - -String READ(const String& input); -String EVAL(const String& ast); -String PRINT(const String& ast); -String rep(const String& input); - -static ReadLine s_readLine("~/.mal-history"); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - while (s_readLine.get(prompt, input)) { - std::cout << rep(input) << "\n"; - } - return 0; -} - -String rep(const String& input) -{ - return PRINT(EVAL(READ(input))); -} - -String READ(const String& input) -{ - return input; -} - -String EVAL(const String& ast) -{ - return ast; -} - -String PRINT(const String& ast) -{ - return ast; -} +#include "String.h" +#include "ReadLine.h" + +#include +#include + +String READ(const String& input); +String EVAL(const String& ast); +String PRINT(const String& ast); +String rep(const String& input); + +static ReadLine s_readLine("~/.mal-history"); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + while (s_readLine.get(prompt, input)) { + std::cout << rep(input) << "\n"; + } + return 0; +} + +String rep(const String& input) +{ + return PRINT(EVAL(READ(input))); +} + +String READ(const String& input) +{ + return input; +} + +String EVAL(const String& ast) +{ + return ast; +} + +String PRINT(const String& ast) +{ + return ast; +} diff --git a/impls/cpp/step1_read_print.cpp b/impls/cpp/step1_read_print.cpp index 9075c45295..365e9ecfa4 100644 --- a/impls/cpp/step1_read_print.cpp +++ b/impls/cpp/step1_read_print.cpp @@ -1,66 +1,66 @@ -#include "MAL.h" - -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); - -static ReadLine s_readLine("~/.mal-history"); - -static String rep(const String& input); -static malValuePtr EVAL(malValuePtr ast); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - while (s_readLine.get(prompt, input)) { - String out; - try { - out = rep(input); - } - catch (malEmptyInputException&) { - continue; // no output - } - catch (String& s) { - out = s; - }; - std::cout << out << "\n"; - } - return 0; -} - -static String rep(const String& input) -{ - return PRINT(EVAL(READ(input))); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -static malValuePtr EVAL(malValuePtr ast) -{ - return ast; -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -// These have been added after step 1 to keep the linker happy. -malValuePtr EVAL(malValuePtr ast, malEnvPtr) -{ - return ast; -} - -malValuePtr APPLY(malValuePtr ast, malValueIter, malValueIter) -{ - return ast; -} +#include "MAL.h" + +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); + +static ReadLine s_readLine("~/.mal-history"); + +static String rep(const String& input); +static malValuePtr EVAL(malValuePtr ast); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + while (s_readLine.get(prompt, input)) { + String out; + try { + out = rep(input); + } + catch (malEmptyInputException&) { + continue; // no output + } + catch (String& s) { + out = s; + }; + std::cout << out << "\n"; + } + return 0; +} + +static String rep(const String& input) +{ + return PRINT(EVAL(READ(input))); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +static malValuePtr EVAL(malValuePtr ast) +{ + return ast; +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +// These have been added after step 1 to keep the linker happy. +malValuePtr EVAL(malValuePtr ast, malEnvPtr) +{ + return ast; +} + +malValuePtr APPLY(malValuePtr ast, malValueIter, malValueIter) +{ + return ast; +} diff --git a/impls/cpp/step2_eval.cpp b/impls/cpp/step2_eval.cpp index dcd9461174..588ca5c69f 100644 --- a/impls/cpp/step2_eval.cpp +++ b/impls/cpp/step2_eval.cpp @@ -1,118 +1,118 @@ -#include "MAL.h" - -#include "Environment.h" -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); - -static ReadLine s_readLine("~/.mal-history"); -static malBuiltIn::ApplyFunc - builtIn_add, builtIn_sub, builtIn_mul, builtIn_div; - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - malEnvPtr replEnv(new malEnv); - replEnv->set("+", mal::builtin("+", &builtIn_add)); - replEnv->set("-", mal::builtin("-", &builtIn_sub)); - replEnv->set("*", mal::builtin("+", &builtIn_mul)); - replEnv->set("/", mal::builtin("/", &builtIn_div)); - while (s_readLine.get(prompt, input)) { - String out; - try { - out = rep(input, replEnv); - } - catch (malEmptyInputException&) { - continue; // no output - } - catch (String& s) { - out = s; - }; - std::cout << out << "\n"; - } - return 0; -} - -String rep(const String& input, malEnvPtr env) -{ - return PRINT(EVAL(READ(input), env)); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -malValuePtr EVAL(malValuePtr ast, malEnvPtr env) -{ - return ast->eval(env); -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) -{ - const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); - MAL_CHECK(handler != NULL, - "\"%s\" is not applicable", op->print(true).c_str()); - - return handler->apply(argsBegin, argsEnd); -} - -#define ARG(type, name) type* name = VALUE_CAST(type, *argsBegin++) - -#define CHECK_ARGS_IS(expected) \ - checkArgsIs(name.c_str(), expected, std::distance(argsBegin, argsEnd)) - -#define CHECK_ARGS_BETWEEN(min, max) \ - checkArgsBetween(name.c_str(), min, max, std::distance(argsBegin, argsEnd)) - - -static malValuePtr builtIn_add(const String& name, - malValueIter argsBegin, malValueIter argsEnd) -{ - CHECK_ARGS_IS(2); - ARG(malInteger, lhs); - ARG(malInteger, rhs); - return mal::integer(lhs->value() + rhs->value()); -} - -static malValuePtr builtIn_sub(const String& name, - malValueIter argsBegin, malValueIter argsEnd) -{ - int argCount = CHECK_ARGS_BETWEEN(1, 2); - ARG(malInteger, lhs); - if (argCount == 1) { - return mal::integer(- lhs->value()); - } - ARG(malInteger, rhs); - return mal::integer(lhs->value() - rhs->value()); -} - -static malValuePtr builtIn_mul(const String& name, - malValueIter argsBegin, malValueIter argsEnd) -{ - CHECK_ARGS_IS(2); - ARG(malInteger, lhs); - ARG(malInteger, rhs); - return mal::integer(lhs->value() * rhs->value()); -} - -static malValuePtr builtIn_div(const String& name, - malValueIter argsBegin, malValueIter argsEnd) -{ - CHECK_ARGS_IS(2); - ARG(malInteger, lhs); - ARG(malInteger, rhs); - MAL_CHECK(rhs->value() != 0, "Division by zero"); \ - return mal::integer(lhs->value() / rhs->value()); -} +#include "MAL.h" + +#include "Environment.h" +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); + +static ReadLine s_readLine("~/.mal-history"); +static malBuiltIn::ApplyFunc + builtIn_add, builtIn_sub, builtIn_mul, builtIn_div; + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + malEnvPtr replEnv(new malEnv); + replEnv->set("+", mal::builtin("+", &builtIn_add)); + replEnv->set("-", mal::builtin("-", &builtIn_sub)); + replEnv->set("*", mal::builtin("+", &builtIn_mul)); + replEnv->set("/", mal::builtin("/", &builtIn_div)); + while (s_readLine.get(prompt, input)) { + String out; + try { + out = rep(input, replEnv); + } + catch (malEmptyInputException&) { + continue; // no output + } + catch (String& s) { + out = s; + }; + std::cout << out << "\n"; + } + return 0; +} + +String rep(const String& input, malEnvPtr env) +{ + return PRINT(EVAL(READ(input), env)); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +malValuePtr EVAL(malValuePtr ast, malEnvPtr env) +{ + return ast->eval(env); +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) +{ + const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); + MAL_CHECK(handler != NULL, + "\"%s\" is not applicable", op->print(true).c_str()); + + return handler->apply(argsBegin, argsEnd); +} + +#define ARG(type, name) type* name = VALUE_CAST(type, *argsBegin++) + +#define CHECK_ARGS_IS(expected) \ + checkArgsIs(name.c_str(), expected, std::distance(argsBegin, argsEnd)) + +#define CHECK_ARGS_BETWEEN(min, max) \ + checkArgsBetween(name.c_str(), min, max, std::distance(argsBegin, argsEnd)) + + +static malValuePtr builtIn_add(const String& name, + malValueIter argsBegin, malValueIter argsEnd) +{ + CHECK_ARGS_IS(2); + ARG(malInteger, lhs); + ARG(malInteger, rhs); + return mal::integer(lhs->value() + rhs->value()); +} + +static malValuePtr builtIn_sub(const String& name, + malValueIter argsBegin, malValueIter argsEnd) +{ + int argCount = CHECK_ARGS_BETWEEN(1, 2); + ARG(malInteger, lhs); + if (argCount == 1) { + return mal::integer(- lhs->value()); + } + ARG(malInteger, rhs); + return mal::integer(lhs->value() - rhs->value()); +} + +static malValuePtr builtIn_mul(const String& name, + malValueIter argsBegin, malValueIter argsEnd) +{ + CHECK_ARGS_IS(2); + ARG(malInteger, lhs); + ARG(malInteger, rhs); + return mal::integer(lhs->value() * rhs->value()); +} + +static malValuePtr builtIn_div(const String& name, + malValueIter argsBegin, malValueIter argsEnd) +{ + CHECK_ARGS_IS(2); + ARG(malInteger, lhs); + ARG(malInteger, rhs); + MAL_CHECK(rhs->value() != 0, "Division by zero"); \ + return mal::integer(lhs->value() / rhs->value()); +} diff --git a/impls/cpp/step3_env.cpp b/impls/cpp/step3_env.cpp index 26b2bc4b85..d0285140b6 100644 --- a/impls/cpp/step3_env.cpp +++ b/impls/cpp/step3_env.cpp @@ -1,114 +1,114 @@ -#include "MAL.h" - -#include "Environment.h" -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); - -static ReadLine s_readLine("~/.mal-history"); - -static malEnvPtr replEnv(new malEnv); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - installCore(replEnv); - while (s_readLine.get(prompt, input)) { - String out; - try { - out = rep(input, replEnv); - } - catch (malEmptyInputException&) { - continue; // no output - } - catch (String& s) { - out = s; - }; - std::cout << out << "\n"; - } - return 0; -} - -String rep(const String& input, malEnvPtr env) -{ - return PRINT(EVAL(READ(input), env)); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -malValuePtr EVAL(malValuePtr ast, malEnvPtr env) -{ - if (!env) { - env = replEnv; - } - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - // From here on down we are evaluating a non-empty list. - // First handle the special forms. - if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { - String special = symbol->value(); - int argCount = list->count() - 1; - - if (special == "def!") { - checkArgsIs("def!", 2, argCount); - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - return env->set(id->value(), EVAL(list->item(2), env)); - } - - if (special == "let*") { - checkArgsIs("let*", 2, argCount); - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - int count = checkArgsEven("let*", bindings->count()); - malEnvPtr inner(new malEnv(env)); - for (int i = 0; i < count; i += 2) { - const malSymbol* var = - VALUE_CAST(malSymbol, bindings->item(i)); - inner->set(var->value(), EVAL(bindings->item(i+1), inner)); - } - return EVAL(list->item(2), inner); - } - } - - // Now we're left with the case of a regular list to be evaluated. - std::unique_ptr items(list->evalItems(env)); - malValuePtr op = items->at(0); - return APPLY(op, items->begin()+1, items->end()); -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) -{ - const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); - MAL_CHECK(handler != NULL, - "\"%s\" is not applicable", op->print(true).c_str()); - - return handler->apply(argsBegin, argsEnd); -} - -// Added to keep the linker happy at step A -malValuePtr readline(const String& prompt) -{ - String input; - if (s_readLine.get(prompt, input)) { - return mal::string(input); - } - return mal::nilValue(); -} - +#include "MAL.h" + +#include "Environment.h" +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); + +static ReadLine s_readLine("~/.mal-history"); + +static malEnvPtr replEnv(new malEnv); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + installCore(replEnv); + while (s_readLine.get(prompt, input)) { + String out; + try { + out = rep(input, replEnv); + } + catch (malEmptyInputException&) { + continue; // no output + } + catch (String& s) { + out = s; + }; + std::cout << out << "\n"; + } + return 0; +} + +String rep(const String& input, malEnvPtr env) +{ + return PRINT(EVAL(READ(input), env)); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +malValuePtr EVAL(malValuePtr ast, malEnvPtr env) +{ + if (!env) { + env = replEnv; + } + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + // From here on down we are evaluating a non-empty list. + // First handle the special forms. + if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { + String special = symbol->value(); + int argCount = list->count() - 1; + + if (special == "def!") { + checkArgsIs("def!", 2, argCount); + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + return env->set(id->value(), EVAL(list->item(2), env)); + } + + if (special == "let*") { + checkArgsIs("let*", 2, argCount); + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + int count = checkArgsEven("let*", bindings->count()); + malEnvPtr inner(new malEnv(env)); + for (int i = 0; i < count; i += 2) { + const malSymbol* var = + VALUE_CAST(malSymbol, bindings->item(i)); + inner->set(var->value(), EVAL(bindings->item(i+1), inner)); + } + return EVAL(list->item(2), inner); + } + } + + // Now we're left with the case of a regular list to be evaluated. + std::unique_ptr items(list->evalItems(env)); + malValuePtr op = items->at(0); + return APPLY(op, items->begin()+1, items->end()); +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) +{ + const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); + MAL_CHECK(handler != NULL, + "\"%s\" is not applicable", op->print(true).c_str()); + + return handler->apply(argsBegin, argsEnd); +} + +// Added to keep the linker happy at step A +malValuePtr readline(const String& prompt) +{ + String input; + if (s_readLine.get(prompt, input)) { + return mal::string(input); + } + return mal::nilValue(); +} + diff --git a/impls/cpp/step4_if_fn_do.cpp b/impls/cpp/step4_if_fn_do.cpp index 2369cb3a40..b527d387d8 100644 --- a/impls/cpp/step4_if_fn_do.cpp +++ b/impls/cpp/step4_if_fn_do.cpp @@ -1,166 +1,166 @@ -#include "MAL.h" - -#include "Environment.h" -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); -static void installFunctions(malEnvPtr env); - -static ReadLine s_readLine("~/.mal-history"); - -static malEnvPtr replEnv(new malEnv); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - installCore(replEnv); - installFunctions(replEnv); - while (s_readLine.get(prompt, input)) { - String out; - try { - out = rep(input, replEnv); - } - catch (malEmptyInputException&) { - continue; // no output - } - catch (String& s) { - out = s; - }; - std::cout << out << "\n"; - } - return 0; -} - -String rep(const String& input, malEnvPtr env) -{ - return PRINT(EVAL(READ(input), env)); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -malValuePtr EVAL(malValuePtr ast, malEnvPtr env) -{ - if (!env) { - env = replEnv; - } - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - // From here on down we are evaluating a non-empty list. - // First handle the special forms. - if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { - String special = symbol->value(); - int argCount = list->count() - 1; - - if (special == "def!") { - checkArgsIs("def!", 2, argCount); - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - return env->set(id->value(), EVAL(list->item(2), env)); - } - - if (special == "do") { - checkArgsAtLeast("do", 1, argCount); - - for (int i = 1; i < argCount; i++) { - EVAL(list->item(i), env); - } - return EVAL(list->item(argCount), env); - } - - if (special == "fn*") { - checkArgsIs("fn*", 2, argCount); - - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - StringVec params; - for (int i = 0; i < bindings->count(); i++) { - const malSymbol* sym = - VALUE_CAST(malSymbol, bindings->item(i)); - params.push_back(sym->value()); - } - - return mal::lambda(params, list->item(2), env); - } - - if (special == "if") { - checkArgsBetween("if", 2, 3, argCount); - - bool isTrue = EVAL(list->item(1), env)->isTrue(); - if (!isTrue && (argCount == 2)) { - return mal::nilValue(); - } - return EVAL(list->item(isTrue ? 2 : 3), env); - } - - if (special == "let*") { - checkArgsIs("let*", 2, argCount); - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - int count = checkArgsEven("let*", bindings->count()); - malEnvPtr inner(new malEnv(env)); - for (int i = 0; i < count; i += 2) { - const malSymbol* var = - VALUE_CAST(malSymbol, bindings->item(i)); - inner->set(var->value(), EVAL(bindings->item(i+1), inner)); - } - return EVAL(list->item(2), inner); - } - } - - // Now we're left with the case of a regular list to be evaluated. - std::unique_ptr items(list->evalItems(env)); - malValuePtr op = items->at(0); - if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { - return EVAL(lambda->getBody(), - lambda->makeEnv(items->begin()+1, items->end())); - } - else { - return APPLY(op, items->begin()+1, items->end()); - } -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) -{ - const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); - MAL_CHECK(handler != NULL, - "\"%s\" is not applicable", op->print(true).c_str()); - - return handler->apply(argsBegin, argsEnd); -} - -static const char* malFunctionTable[] = { - "(def! not (fn* (cond) (if cond false true)))", -}; - -static void installFunctions(malEnvPtr env) { - for (auto &function : malFunctionTable) { - rep(function, env); - } -} - -// Added to keep the linker happy at step A -malValuePtr readline(const String& prompt) -{ - String input; - if (s_readLine.get(prompt, input)) { - return mal::string(input); - } - return mal::nilValue(); -} - +#include "MAL.h" + +#include "Environment.h" +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); +static void installFunctions(malEnvPtr env); + +static ReadLine s_readLine("~/.mal-history"); + +static malEnvPtr replEnv(new malEnv); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + installCore(replEnv); + installFunctions(replEnv); + while (s_readLine.get(prompt, input)) { + String out; + try { + out = rep(input, replEnv); + } + catch (malEmptyInputException&) { + continue; // no output + } + catch (String& s) { + out = s; + }; + std::cout << out << "\n"; + } + return 0; +} + +String rep(const String& input, malEnvPtr env) +{ + return PRINT(EVAL(READ(input), env)); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +malValuePtr EVAL(malValuePtr ast, malEnvPtr env) +{ + if (!env) { + env = replEnv; + } + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + // From here on down we are evaluating a non-empty list. + // First handle the special forms. + if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { + String special = symbol->value(); + int argCount = list->count() - 1; + + if (special == "def!") { + checkArgsIs("def!", 2, argCount); + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + return env->set(id->value(), EVAL(list->item(2), env)); + } + + if (special == "do") { + checkArgsAtLeast("do", 1, argCount); + + for (int i = 1; i < argCount; i++) { + EVAL(list->item(i), env); + } + return EVAL(list->item(argCount), env); + } + + if (special == "fn*") { + checkArgsIs("fn*", 2, argCount); + + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + StringVec params; + for (int i = 0; i < bindings->count(); i++) { + const malSymbol* sym = + VALUE_CAST(malSymbol, bindings->item(i)); + params.push_back(sym->value()); + } + + return mal::lambda(params, list->item(2), env); + } + + if (special == "if") { + checkArgsBetween("if", 2, 3, argCount); + + bool isTrue = EVAL(list->item(1), env)->isTrue(); + if (!isTrue && (argCount == 2)) { + return mal::nilValue(); + } + return EVAL(list->item(isTrue ? 2 : 3), env); + } + + if (special == "let*") { + checkArgsIs("let*", 2, argCount); + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + int count = checkArgsEven("let*", bindings->count()); + malEnvPtr inner(new malEnv(env)); + for (int i = 0; i < count; i += 2) { + const malSymbol* var = + VALUE_CAST(malSymbol, bindings->item(i)); + inner->set(var->value(), EVAL(bindings->item(i+1), inner)); + } + return EVAL(list->item(2), inner); + } + } + + // Now we're left with the case of a regular list to be evaluated. + std::unique_ptr items(list->evalItems(env)); + malValuePtr op = items->at(0); + if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { + return EVAL(lambda->getBody(), + lambda->makeEnv(items->begin()+1, items->end())); + } + else { + return APPLY(op, items->begin()+1, items->end()); + } +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) +{ + const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); + MAL_CHECK(handler != NULL, + "\"%s\" is not applicable", op->print(true).c_str()); + + return handler->apply(argsBegin, argsEnd); +} + +static const char* malFunctionTable[] = { + "(def! not (fn* (cond) (if cond false true)))", +}; + +static void installFunctions(malEnvPtr env) { + for (auto &function : malFunctionTable) { + rep(function, env); + } +} + +// Added to keep the linker happy at step A +malValuePtr readline(const String& prompt) +{ + String input; + if (s_readLine.get(prompt, input)) { + return mal::string(input); + } + return mal::nilValue(); +} + diff --git a/impls/cpp/step5_tco.cpp b/impls/cpp/step5_tco.cpp index 3aa9d4a866..4cfa3151e4 100644 --- a/impls/cpp/step5_tco.cpp +++ b/impls/cpp/step5_tco.cpp @@ -1,173 +1,173 @@ -#include "MAL.h" - -#include "Environment.h" -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); -static void installFunctions(malEnvPtr env); - -static ReadLine s_readLine("~/.mal-history"); - -static malEnvPtr replEnv(new malEnv); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - installCore(replEnv); - installFunctions(replEnv); - while (s_readLine.get(prompt, input)) { - String out; - try { - out = rep(input, replEnv); - } - catch (malEmptyInputException&) { - continue; // no output - } - catch (String& s) { - out = s; - }; - std::cout << out << "\n"; - } - return 0; -} - -String rep(const String& input, malEnvPtr env) -{ - return PRINT(EVAL(READ(input), env)); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -malValuePtr EVAL(malValuePtr ast, malEnvPtr env) -{ - if (!env) { - env = replEnv; - } - while (1) { - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - // From here on down we are evaluating a non-empty list. - // First handle the special forms. - if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { - String special = symbol->value(); - int argCount = list->count() - 1; - - if (special == "def!") { - checkArgsIs("def!", 2, argCount); - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - return env->set(id->value(), EVAL(list->item(2), env)); - } - - if (special == "do") { - checkArgsAtLeast("do", 1, argCount); - - for (int i = 1; i < argCount; i++) { - EVAL(list->item(i), env); - } - ast = list->item(argCount); - continue; // TCO - } - - if (special == "fn*") { - checkArgsIs("fn*", 2, argCount); - - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - StringVec params; - for (int i = 0; i < bindings->count(); i++) { - const malSymbol* sym = - VALUE_CAST(malSymbol, bindings->item(i)); - params.push_back(sym->value()); - } - - return mal::lambda(params, list->item(2), env); - } - - if (special == "if") { - checkArgsBetween("if", 2, 3, argCount); - - bool isTrue = EVAL(list->item(1), env)->isTrue(); - if (!isTrue && (argCount == 2)) { - return mal::nilValue(); - } - ast = list->item(isTrue ? 2 : 3); - continue; // TCO - } - - if (special == "let*") { - checkArgsIs("let*", 2, argCount); - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - int count = checkArgsEven("let*", bindings->count()); - malEnvPtr inner(new malEnv(env)); - for (int i = 0; i < count; i += 2) { - const malSymbol* var = - VALUE_CAST(malSymbol, bindings->item(i)); - inner->set(var->value(), EVAL(bindings->item(i+1), inner)); - } - ast = list->item(2); - env = inner; - continue; // TCO - } - } - - // Now we're left with the case of a regular list to be evaluated. - std::unique_ptr items(list->evalItems(env)); - malValuePtr op = items->at(0); - if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { - ast = lambda->getBody(); - env = lambda->makeEnv(items->begin()+1, items->end()); - continue; // TCO - } - else { - return APPLY(op, items->begin()+1, items->end()); - } - } -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) -{ - const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); - MAL_CHECK(handler != NULL, - "\"%s\" is not applicable", op->print(true).c_str()); - - return handler->apply(argsBegin, argsEnd); -} - -static const char* malFunctionTable[] = { - "(def! not (fn* (cond) (if cond false true)))", -}; - -static void installFunctions(malEnvPtr env) { - for (auto &function : malFunctionTable) { - rep(function, env); - } -} - -// Added to keep the linker happy at step A -malValuePtr readline(const String& prompt) -{ - String input; - if (s_readLine.get(prompt, input)) { - return mal::string(input); - } - return mal::nilValue(); -} - +#include "MAL.h" + +#include "Environment.h" +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); +static void installFunctions(malEnvPtr env); + +static ReadLine s_readLine("~/.mal-history"); + +static malEnvPtr replEnv(new malEnv); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + installCore(replEnv); + installFunctions(replEnv); + while (s_readLine.get(prompt, input)) { + String out; + try { + out = rep(input, replEnv); + } + catch (malEmptyInputException&) { + continue; // no output + } + catch (String& s) { + out = s; + }; + std::cout << out << "\n"; + } + return 0; +} + +String rep(const String& input, malEnvPtr env) +{ + return PRINT(EVAL(READ(input), env)); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +malValuePtr EVAL(malValuePtr ast, malEnvPtr env) +{ + if (!env) { + env = replEnv; + } + while (1) { + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + // From here on down we are evaluating a non-empty list. + // First handle the special forms. + if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { + String special = symbol->value(); + int argCount = list->count() - 1; + + if (special == "def!") { + checkArgsIs("def!", 2, argCount); + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + return env->set(id->value(), EVAL(list->item(2), env)); + } + + if (special == "do") { + checkArgsAtLeast("do", 1, argCount); + + for (int i = 1; i < argCount; i++) { + EVAL(list->item(i), env); + } + ast = list->item(argCount); + continue; // TCO + } + + if (special == "fn*") { + checkArgsIs("fn*", 2, argCount); + + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + StringVec params; + for (int i = 0; i < bindings->count(); i++) { + const malSymbol* sym = + VALUE_CAST(malSymbol, bindings->item(i)); + params.push_back(sym->value()); + } + + return mal::lambda(params, list->item(2), env); + } + + if (special == "if") { + checkArgsBetween("if", 2, 3, argCount); + + bool isTrue = EVAL(list->item(1), env)->isTrue(); + if (!isTrue && (argCount == 2)) { + return mal::nilValue(); + } + ast = list->item(isTrue ? 2 : 3); + continue; // TCO + } + + if (special == "let*") { + checkArgsIs("let*", 2, argCount); + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + int count = checkArgsEven("let*", bindings->count()); + malEnvPtr inner(new malEnv(env)); + for (int i = 0; i < count; i += 2) { + const malSymbol* var = + VALUE_CAST(malSymbol, bindings->item(i)); + inner->set(var->value(), EVAL(bindings->item(i+1), inner)); + } + ast = list->item(2); + env = inner; + continue; // TCO + } + } + + // Now we're left with the case of a regular list to be evaluated. + std::unique_ptr items(list->evalItems(env)); + malValuePtr op = items->at(0); + if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { + ast = lambda->getBody(); + env = lambda->makeEnv(items->begin()+1, items->end()); + continue; // TCO + } + else { + return APPLY(op, items->begin()+1, items->end()); + } + } +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) +{ + const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); + MAL_CHECK(handler != NULL, + "\"%s\" is not applicable", op->print(true).c_str()); + + return handler->apply(argsBegin, argsEnd); +} + +static const char* malFunctionTable[] = { + "(def! not (fn* (cond) (if cond false true)))", +}; + +static void installFunctions(malEnvPtr env) { + for (auto &function : malFunctionTable) { + rep(function, env); + } +} + +// Added to keep the linker happy at step A +malValuePtr readline(const String& prompt) +{ + String input; + if (s_readLine.get(prompt, input)) { + return mal::string(input); + } + return mal::nilValue(); +} + diff --git a/impls/cpp/step6_file.cpp b/impls/cpp/step6_file.cpp index ad16f6db9e..679e8bd1aa 100644 --- a/impls/cpp/step6_file.cpp +++ b/impls/cpp/step6_file.cpp @@ -1,198 +1,198 @@ -#include "MAL.h" - -#include "Environment.h" -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); -static void installFunctions(malEnvPtr env); - -static void makeArgv(malEnvPtr env, int argc, char* argv[]); -static String safeRep(const String& input, malEnvPtr env); - -static ReadLine s_readLine("~/.mal-history"); - -static malEnvPtr replEnv(new malEnv); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - installCore(replEnv); - installFunctions(replEnv); - makeArgv(replEnv, argc - 2, argv + 2); - if (argc > 1) { - String filename = escape(argv[1]); - safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); - return 0; - } - while (s_readLine.get(prompt, input)) { - String out = safeRep(input, replEnv); - if (out.length() > 0) - std::cout << out << "\n"; - } - return 0; -} - -static String safeRep(const String& input, malEnvPtr env) -{ - try { - return rep(input, env); - } - catch (malEmptyInputException&) { - return String(); - } - catch (String& s) { - return s; - }; -} - -static void makeArgv(malEnvPtr env, int argc, char* argv[]) -{ - malValueVec* args = new malValueVec(); - for (int i = 0; i < argc; i++) { - args->push_back(mal::string(argv[i])); - } - env->set("*ARGV*", mal::list(args)); -} - -String rep(const String& input, malEnvPtr env) -{ - return PRINT(EVAL(READ(input), env)); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -malValuePtr EVAL(malValuePtr ast, malEnvPtr env) -{ - if (!env) { - env = replEnv; - } - while (1) { - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - // From here on down we are evaluating a non-empty list. - // First handle the special forms. - if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { - String special = symbol->value(); - int argCount = list->count() - 1; - - if (special == "def!") { - checkArgsIs("def!", 2, argCount); - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - return env->set(id->value(), EVAL(list->item(2), env)); - } - - if (special == "do") { - checkArgsAtLeast("do", 1, argCount); - - for (int i = 1; i < argCount; i++) { - EVAL(list->item(i), env); - } - ast = list->item(argCount); - continue; // TCO - } - - if (special == "fn*") { - checkArgsIs("fn*", 2, argCount); - - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - StringVec params; - for (int i = 0; i < bindings->count(); i++) { - const malSymbol* sym = - VALUE_CAST(malSymbol, bindings->item(i)); - params.push_back(sym->value()); - } - - return mal::lambda(params, list->item(2), env); - } - - if (special == "if") { - checkArgsBetween("if", 2, 3, argCount); - - bool isTrue = EVAL(list->item(1), env)->isTrue(); - if (!isTrue && (argCount == 2)) { - return mal::nilValue(); - } - ast = list->item(isTrue ? 2 : 3); - continue; // TCO - } - - if (special == "let*") { - checkArgsIs("let*", 2, argCount); - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - int count = checkArgsEven("let*", bindings->count()); - malEnvPtr inner(new malEnv(env)); - for (int i = 0; i < count; i += 2) { - const malSymbol* var = - VALUE_CAST(malSymbol, bindings->item(i)); - inner->set(var->value(), EVAL(bindings->item(i+1), inner)); - } - ast = list->item(2); - env = inner; - continue; // TCO - } - } - - // Now we're left with the case of a regular list to be evaluated. - std::unique_ptr items(list->evalItems(env)); - malValuePtr op = items->at(0); - if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { - ast = lambda->getBody(); - env = lambda->makeEnv(items->begin()+1, items->end()); - continue; // TCO - } - else { - return APPLY(op, items->begin()+1, items->end()); - } - } -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) -{ - const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); - MAL_CHECK(handler != NULL, - "\"%s\" is not applicable", op->print(true).c_str()); - - return handler->apply(argsBegin, argsEnd); -} - -static const char* malFunctionTable[] = { - "(def! not (fn* (cond) (if cond false true)))", - "(def! load-file (fn* (filename) \ - (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", -}; - -static void installFunctions(malEnvPtr env) { - for (auto &function : malFunctionTable) { - rep(function, env); - } -} - -// Added to keep the linker happy at step A -malValuePtr readline(const String& prompt) -{ - String input; - if (s_readLine.get(prompt, input)) { - return mal::string(input); - } - return mal::nilValue(); -} - +#include "MAL.h" + +#include "Environment.h" +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); +static void installFunctions(malEnvPtr env); + +static void makeArgv(malEnvPtr env, int argc, char* argv[]); +static String safeRep(const String& input, malEnvPtr env); + +static ReadLine s_readLine("~/.mal-history"); + +static malEnvPtr replEnv(new malEnv); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + installCore(replEnv); + installFunctions(replEnv); + makeArgv(replEnv, argc - 2, argv + 2); + if (argc > 1) { + String filename = escape(argv[1]); + safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); + return 0; + } + while (s_readLine.get(prompt, input)) { + String out = safeRep(input, replEnv); + if (out.length() > 0) + std::cout << out << "\n"; + } + return 0; +} + +static String safeRep(const String& input, malEnvPtr env) +{ + try { + return rep(input, env); + } + catch (malEmptyInputException&) { + return String(); + } + catch (String& s) { + return s; + }; +} + +static void makeArgv(malEnvPtr env, int argc, char* argv[]) +{ + malValueVec* args = new malValueVec(); + for (int i = 0; i < argc; i++) { + args->push_back(mal::string(argv[i])); + } + env->set("*ARGV*", mal::list(args)); +} + +String rep(const String& input, malEnvPtr env) +{ + return PRINT(EVAL(READ(input), env)); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +malValuePtr EVAL(malValuePtr ast, malEnvPtr env) +{ + if (!env) { + env = replEnv; + } + while (1) { + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + // From here on down we are evaluating a non-empty list. + // First handle the special forms. + if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { + String special = symbol->value(); + int argCount = list->count() - 1; + + if (special == "def!") { + checkArgsIs("def!", 2, argCount); + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + return env->set(id->value(), EVAL(list->item(2), env)); + } + + if (special == "do") { + checkArgsAtLeast("do", 1, argCount); + + for (int i = 1; i < argCount; i++) { + EVAL(list->item(i), env); + } + ast = list->item(argCount); + continue; // TCO + } + + if (special == "fn*") { + checkArgsIs("fn*", 2, argCount); + + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + StringVec params; + for (int i = 0; i < bindings->count(); i++) { + const malSymbol* sym = + VALUE_CAST(malSymbol, bindings->item(i)); + params.push_back(sym->value()); + } + + return mal::lambda(params, list->item(2), env); + } + + if (special == "if") { + checkArgsBetween("if", 2, 3, argCount); + + bool isTrue = EVAL(list->item(1), env)->isTrue(); + if (!isTrue && (argCount == 2)) { + return mal::nilValue(); + } + ast = list->item(isTrue ? 2 : 3); + continue; // TCO + } + + if (special == "let*") { + checkArgsIs("let*", 2, argCount); + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + int count = checkArgsEven("let*", bindings->count()); + malEnvPtr inner(new malEnv(env)); + for (int i = 0; i < count; i += 2) { + const malSymbol* var = + VALUE_CAST(malSymbol, bindings->item(i)); + inner->set(var->value(), EVAL(bindings->item(i+1), inner)); + } + ast = list->item(2); + env = inner; + continue; // TCO + } + } + + // Now we're left with the case of a regular list to be evaluated. + std::unique_ptr items(list->evalItems(env)); + malValuePtr op = items->at(0); + if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { + ast = lambda->getBody(); + env = lambda->makeEnv(items->begin()+1, items->end()); + continue; // TCO + } + else { + return APPLY(op, items->begin()+1, items->end()); + } + } +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) +{ + const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); + MAL_CHECK(handler != NULL, + "\"%s\" is not applicable", op->print(true).c_str()); + + return handler->apply(argsBegin, argsEnd); +} + +static const char* malFunctionTable[] = { + "(def! not (fn* (cond) (if cond false true)))", + "(def! load-file (fn* (filename) \ + (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", +}; + +static void installFunctions(malEnvPtr env) { + for (auto &function : malFunctionTable) { + rep(function, env); + } +} + +// Added to keep the linker happy at step A +malValuePtr readline(const String& prompt) +{ + String input; + if (s_readLine.get(prompt, input)) { + return mal::string(input); + } + return mal::nilValue(); +} + diff --git a/impls/cpp/step7_quote.cpp b/impls/cpp/step7_quote.cpp index 337353dd13..1cd34dc407 100644 --- a/impls/cpp/step7_quote.cpp +++ b/impls/cpp/step7_quote.cpp @@ -1,258 +1,258 @@ -#include "MAL.h" - -#include "Environment.h" -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); -static void installFunctions(malEnvPtr env); - -static void makeArgv(malEnvPtr env, int argc, char* argv[]); -static String safeRep(const String& input, malEnvPtr env); -static malValuePtr quasiquote(malValuePtr obj); - -static ReadLine s_readLine("~/.mal-history"); - -static malEnvPtr replEnv(new malEnv); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - installCore(replEnv); - installFunctions(replEnv); - makeArgv(replEnv, argc - 2, argv + 2); - if (argc > 1) { - String filename = escape(argv[1]); - safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); - return 0; - } - while (s_readLine.get(prompt, input)) { - String out = safeRep(input, replEnv); - if (out.length() > 0) - std::cout << out << "\n"; - } - return 0; -} - -static String safeRep(const String& input, malEnvPtr env) -{ - try { - return rep(input, env); - } - catch (malEmptyInputException&) { - return String(); - } - catch (String& s) { - return s; - }; -} - -static void makeArgv(malEnvPtr env, int argc, char* argv[]) -{ - malValueVec* args = new malValueVec(); - for (int i = 0; i < argc; i++) { - args->push_back(mal::string(argv[i])); - } - env->set("*ARGV*", mal::list(args)); -} - -String rep(const String& input, malEnvPtr env) -{ - return PRINT(EVAL(READ(input), env)); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -malValuePtr EVAL(malValuePtr ast, malEnvPtr env) -{ - if (!env) { - env = replEnv; - } - while (1) { - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - // From here on down we are evaluating a non-empty list. - // First handle the special forms. - if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { - String special = symbol->value(); - int argCount = list->count() - 1; - - if (special == "def!") { - checkArgsIs("def!", 2, argCount); - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - return env->set(id->value(), EVAL(list->item(2), env)); - } - - if (special == "do") { - checkArgsAtLeast("do", 1, argCount); - - for (int i = 1; i < argCount; i++) { - EVAL(list->item(i), env); - } - ast = list->item(argCount); - continue; // TCO - } - - if (special == "fn*") { - checkArgsIs("fn*", 2, argCount); - - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - StringVec params; - for (int i = 0; i < bindings->count(); i++) { - const malSymbol* sym = - VALUE_CAST(malSymbol, bindings->item(i)); - params.push_back(sym->value()); - } - - return mal::lambda(params, list->item(2), env); - } - - if (special == "if") { - checkArgsBetween("if", 2, 3, argCount); - - bool isTrue = EVAL(list->item(1), env)->isTrue(); - if (!isTrue && (argCount == 2)) { - return mal::nilValue(); - } - ast = list->item(isTrue ? 2 : 3); - continue; // TCO - } - - if (special == "let*") { - checkArgsIs("let*", 2, argCount); - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - int count = checkArgsEven("let*", bindings->count()); - malEnvPtr inner(new malEnv(env)); - for (int i = 0; i < count; i += 2) { - const malSymbol* var = - VALUE_CAST(malSymbol, bindings->item(i)); - inner->set(var->value(), EVAL(bindings->item(i+1), inner)); - } - ast = list->item(2); - env = inner; - continue; // TCO - } - - if (special == "quasiquoteexpand") { - checkArgsIs("quasiquote", 1, argCount); - return quasiquote(list->item(1)); - } - - if (special == "quasiquote") { - checkArgsIs("quasiquote", 1, argCount); - ast = quasiquote(list->item(1)); - continue; // TCO - } - - if (special == "quote") { - checkArgsIs("quote", 1, argCount); - return list->item(1); - } - } - - // Now we're left with the case of a regular list to be evaluated. - std::unique_ptr items(list->evalItems(env)); - malValuePtr op = items->at(0); - if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { - ast = lambda->getBody(); - env = lambda->makeEnv(items->begin()+1, items->end()); - continue; // TCO - } - else { - return APPLY(op, items->begin()+1, items->end()); - } - } -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) -{ - const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); - MAL_CHECK(handler != NULL, - "\"%s\" is not applicable", op->print(true).c_str()); - - return handler->apply(argsBegin, argsEnd); -} - -static bool isSymbol(malValuePtr obj, const String& text) -{ - const malSymbol* sym = DYNAMIC_CAST(malSymbol, obj); - return sym && (sym->value() == text); -} - -// Return arg when ast matches ('sym, arg), else NULL. -static malValuePtr starts_with(const malValuePtr ast, const char* sym) -{ - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || list->isEmpty() || !isSymbol(list->item(0), sym)) - return NULL; - checkArgsIs(sym, 1, list->count() - 1); - return list->item(1); -} - -static malValuePtr quasiquote(malValuePtr obj) -{ - if (DYNAMIC_CAST(malSymbol, obj) || DYNAMIC_CAST(malHash, obj)) - return mal::list(mal::symbol("quote"), obj); - - const malSequence* seq = DYNAMIC_CAST(malSequence, obj); - if (!seq) - return obj; - - const malValuePtr unquoted = starts_with(obj, "unquote"); - if (unquoted) - return unquoted; - - malValuePtr res = mal::list(new malValueVec(0)); - for (int i=seq->count()-1; 0<=i; i--) { - const malValuePtr elt = seq->item(i); - const malValuePtr spl_unq = starts_with(elt, "splice-unquote"); - if (spl_unq) - res = mal::list(mal::symbol("concat"), spl_unq, res); - else - res = mal::list(mal::symbol("cons"), quasiquote(elt), res); - } - if (DYNAMIC_CAST(malVector, obj)) - res = mal::list(mal::symbol("vec"), res); - return res; -} - -static const char* malFunctionTable[] = { - "(def! not (fn* (cond) (if cond false true)))", - "(def! load-file (fn* (filename) \ - (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", -}; - -static void installFunctions(malEnvPtr env) { - for (auto &function : malFunctionTable) { - rep(function, env); - } -} - -// Added to keep the linker happy at step A -malValuePtr readline(const String& prompt) -{ - String input; - if (s_readLine.get(prompt, input)) { - return mal::string(input); - } - return mal::nilValue(); -} - +#include "MAL.h" + +#include "Environment.h" +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); +static void installFunctions(malEnvPtr env); + +static void makeArgv(malEnvPtr env, int argc, char* argv[]); +static String safeRep(const String& input, malEnvPtr env); +static malValuePtr quasiquote(malValuePtr obj); + +static ReadLine s_readLine("~/.mal-history"); + +static malEnvPtr replEnv(new malEnv); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + installCore(replEnv); + installFunctions(replEnv); + makeArgv(replEnv, argc - 2, argv + 2); + if (argc > 1) { + String filename = escape(argv[1]); + safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); + return 0; + } + while (s_readLine.get(prompt, input)) { + String out = safeRep(input, replEnv); + if (out.length() > 0) + std::cout << out << "\n"; + } + return 0; +} + +static String safeRep(const String& input, malEnvPtr env) +{ + try { + return rep(input, env); + } + catch (malEmptyInputException&) { + return String(); + } + catch (String& s) { + return s; + }; +} + +static void makeArgv(malEnvPtr env, int argc, char* argv[]) +{ + malValueVec* args = new malValueVec(); + for (int i = 0; i < argc; i++) { + args->push_back(mal::string(argv[i])); + } + env->set("*ARGV*", mal::list(args)); +} + +String rep(const String& input, malEnvPtr env) +{ + return PRINT(EVAL(READ(input), env)); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +malValuePtr EVAL(malValuePtr ast, malEnvPtr env) +{ + if (!env) { + env = replEnv; + } + while (1) { + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + // From here on down we are evaluating a non-empty list. + // First handle the special forms. + if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { + String special = symbol->value(); + int argCount = list->count() - 1; + + if (special == "def!") { + checkArgsIs("def!", 2, argCount); + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + return env->set(id->value(), EVAL(list->item(2), env)); + } + + if (special == "do") { + checkArgsAtLeast("do", 1, argCount); + + for (int i = 1; i < argCount; i++) { + EVAL(list->item(i), env); + } + ast = list->item(argCount); + continue; // TCO + } + + if (special == "fn*") { + checkArgsIs("fn*", 2, argCount); + + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + StringVec params; + for (int i = 0; i < bindings->count(); i++) { + const malSymbol* sym = + VALUE_CAST(malSymbol, bindings->item(i)); + params.push_back(sym->value()); + } + + return mal::lambda(params, list->item(2), env); + } + + if (special == "if") { + checkArgsBetween("if", 2, 3, argCount); + + bool isTrue = EVAL(list->item(1), env)->isTrue(); + if (!isTrue && (argCount == 2)) { + return mal::nilValue(); + } + ast = list->item(isTrue ? 2 : 3); + continue; // TCO + } + + if (special == "let*") { + checkArgsIs("let*", 2, argCount); + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + int count = checkArgsEven("let*", bindings->count()); + malEnvPtr inner(new malEnv(env)); + for (int i = 0; i < count; i += 2) { + const malSymbol* var = + VALUE_CAST(malSymbol, bindings->item(i)); + inner->set(var->value(), EVAL(bindings->item(i+1), inner)); + } + ast = list->item(2); + env = inner; + continue; // TCO + } + + if (special == "quasiquoteexpand") { + checkArgsIs("quasiquote", 1, argCount); + return quasiquote(list->item(1)); + } + + if (special == "quasiquote") { + checkArgsIs("quasiquote", 1, argCount); + ast = quasiquote(list->item(1)); + continue; // TCO + } + + if (special == "quote") { + checkArgsIs("quote", 1, argCount); + return list->item(1); + } + } + + // Now we're left with the case of a regular list to be evaluated. + std::unique_ptr items(list->evalItems(env)); + malValuePtr op = items->at(0); + if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { + ast = lambda->getBody(); + env = lambda->makeEnv(items->begin()+1, items->end()); + continue; // TCO + } + else { + return APPLY(op, items->begin()+1, items->end()); + } + } +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) +{ + const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); + MAL_CHECK(handler != NULL, + "\"%s\" is not applicable", op->print(true).c_str()); + + return handler->apply(argsBegin, argsEnd); +} + +static bool isSymbol(malValuePtr obj, const String& text) +{ + const malSymbol* sym = DYNAMIC_CAST(malSymbol, obj); + return sym && (sym->value() == text); +} + +// Return arg when ast matches ('sym, arg), else NULL. +static malValuePtr starts_with(const malValuePtr ast, const char* sym) +{ + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || list->isEmpty() || !isSymbol(list->item(0), sym)) + return NULL; + checkArgsIs(sym, 1, list->count() - 1); + return list->item(1); +} + +static malValuePtr quasiquote(malValuePtr obj) +{ + if (DYNAMIC_CAST(malSymbol, obj) || DYNAMIC_CAST(malHash, obj)) + return mal::list(mal::symbol("quote"), obj); + + const malSequence* seq = DYNAMIC_CAST(malSequence, obj); + if (!seq) + return obj; + + const malValuePtr unquoted = starts_with(obj, "unquote"); + if (unquoted) + return unquoted; + + malValuePtr res = mal::list(new malValueVec(0)); + for (int i=seq->count()-1; 0<=i; i--) { + const malValuePtr elt = seq->item(i); + const malValuePtr spl_unq = starts_with(elt, "splice-unquote"); + if (spl_unq) + res = mal::list(mal::symbol("concat"), spl_unq, res); + else + res = mal::list(mal::symbol("cons"), quasiquote(elt), res); + } + if (DYNAMIC_CAST(malVector, obj)) + res = mal::list(mal::symbol("vec"), res); + return res; +} + +static const char* malFunctionTable[] = { + "(def! not (fn* (cond) (if cond false true)))", + "(def! load-file (fn* (filename) \ + (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", +}; + +static void installFunctions(malEnvPtr env) { + for (auto &function : malFunctionTable) { + rep(function, env); + } +} + +// Added to keep the linker happy at step A +malValuePtr readline(const String& prompt) +{ + String input; + if (s_readLine.get(prompt, input)) { + return mal::string(input); + } + return mal::nilValue(); +} + diff --git a/impls/cpp/step8_macros.cpp b/impls/cpp/step8_macros.cpp index a425fdd2a8..6fc24477f2 100644 --- a/impls/cpp/step8_macros.cpp +++ b/impls/cpp/step8_macros.cpp @@ -1,306 +1,306 @@ -#include "MAL.h" - -#include "Environment.h" -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); -static void installFunctions(malEnvPtr env); -// Installs functions and macros implemented in MAL. - -static void makeArgv(malEnvPtr env, int argc, char* argv[]); -static String safeRep(const String& input, malEnvPtr env); -static malValuePtr quasiquote(malValuePtr obj); -static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env); - -static ReadLine s_readLine("~/.mal-history"); - -static malEnvPtr replEnv(new malEnv); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - installCore(replEnv); - installFunctions(replEnv); - makeArgv(replEnv, argc - 2, argv + 2); - if (argc > 1) { - String filename = escape(argv[1]); - safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); - return 0; - } - while (s_readLine.get(prompt, input)) { - String out = safeRep(input, replEnv); - if (out.length() > 0) - std::cout << out << "\n"; - } - return 0; -} - -static String safeRep(const String& input, malEnvPtr env) -{ - try { - return rep(input, env); - } - catch (malEmptyInputException&) { - return String(); - } - catch (String& s) { - return s; - }; -} - -static void makeArgv(malEnvPtr env, int argc, char* argv[]) -{ - malValueVec* args = new malValueVec(); - for (int i = 0; i < argc; i++) { - args->push_back(mal::string(argv[i])); - } - env->set("*ARGV*", mal::list(args)); -} - -String rep(const String& input, malEnvPtr env) -{ - return PRINT(EVAL(READ(input), env)); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -malValuePtr EVAL(malValuePtr ast, malEnvPtr env) -{ - if (!env) { - env = replEnv; - } - while (1) { - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - ast = macroExpand(ast, env); - list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - // From here on down we are evaluating a non-empty list. - // First handle the special forms. - if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { - String special = symbol->value(); - int argCount = list->count() - 1; - - if (special == "def!") { - checkArgsIs("def!", 2, argCount); - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - return env->set(id->value(), EVAL(list->item(2), env)); - } - - if (special == "defmacro!") { - checkArgsIs("defmacro!", 2, argCount); - - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - malValuePtr body = EVAL(list->item(2), env); - const malLambda* lambda = VALUE_CAST(malLambda, body); - return env->set(id->value(), mal::macro(*lambda)); - } - - if (special == "do") { - checkArgsAtLeast("do", 1, argCount); - - for (int i = 1; i < argCount; i++) { - EVAL(list->item(i), env); - } - ast = list->item(argCount); - continue; // TCO - } - - if (special == "fn*") { - checkArgsIs("fn*", 2, argCount); - - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - StringVec params; - for (int i = 0; i < bindings->count(); i++) { - const malSymbol* sym = - VALUE_CAST(malSymbol, bindings->item(i)); - params.push_back(sym->value()); - } - - return mal::lambda(params, list->item(2), env); - } - - if (special == "if") { - checkArgsBetween("if", 2, 3, argCount); - - bool isTrue = EVAL(list->item(1), env)->isTrue(); - if (!isTrue && (argCount == 2)) { - return mal::nilValue(); - } - ast = list->item(isTrue ? 2 : 3); - continue; // TCO - } - - if (special == "let*") { - checkArgsIs("let*", 2, argCount); - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - int count = checkArgsEven("let*", bindings->count()); - malEnvPtr inner(new malEnv(env)); - for (int i = 0; i < count; i += 2) { - const malSymbol* var = - VALUE_CAST(malSymbol, bindings->item(i)); - inner->set(var->value(), EVAL(bindings->item(i+1), inner)); - } - ast = list->item(2); - env = inner; - continue; // TCO - } - - if (special == "macroexpand") { - checkArgsIs("macroexpand", 1, argCount); - return macroExpand(list->item(1), env); - } - - if (special == "quasiquoteexpand") { - checkArgsIs("quasiquote", 1, argCount); - return quasiquote(list->item(1)); - } - - if (special == "quasiquote") { - checkArgsIs("quasiquote", 1, argCount); - ast = quasiquote(list->item(1)); - continue; // TCO - } - - if (special == "quote") { - checkArgsIs("quote", 1, argCount); - return list->item(1); - } - } - - // Now we're left with the case of a regular list to be evaluated. - std::unique_ptr items(list->evalItems(env)); - malValuePtr op = items->at(0); - if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { - ast = lambda->getBody(); - env = lambda->makeEnv(items->begin()+1, items->end()); - continue; // TCO - } - else { - return APPLY(op, items->begin()+1, items->end()); - } - } -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) -{ - const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); - MAL_CHECK(handler != NULL, - "\"%s\" is not applicable", op->print(true).c_str()); - - return handler->apply(argsBegin, argsEnd); -} - -static bool isSymbol(malValuePtr obj, const String& text) -{ - const malSymbol* sym = DYNAMIC_CAST(malSymbol, obj); - return sym && (sym->value() == text); -} - -// Return arg when ast matches ('sym, arg), else NULL. -static malValuePtr starts_with(const malValuePtr ast, const char* sym) -{ - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || list->isEmpty() || !isSymbol(list->item(0), sym)) - return NULL; - checkArgsIs(sym, 1, list->count() - 1); - return list->item(1); -} - -static malValuePtr quasiquote(malValuePtr obj) -{ - if (DYNAMIC_CAST(malSymbol, obj) || DYNAMIC_CAST(malHash, obj)) - return mal::list(mal::symbol("quote"), obj); - - const malSequence* seq = DYNAMIC_CAST(malSequence, obj); - if (!seq) - return obj; - - const malValuePtr unquoted = starts_with(obj, "unquote"); - if (unquoted) - return unquoted; - - malValuePtr res = mal::list(new malValueVec(0)); - for (int i=seq->count()-1; 0<=i; i--) { - const malValuePtr elt = seq->item(i); - const malValuePtr spl_unq = starts_with(elt, "splice-unquote"); - if (spl_unq) - res = mal::list(mal::symbol("concat"), spl_unq, res); - else - res = mal::list(mal::symbol("cons"), quasiquote(elt), res); - } - if (DYNAMIC_CAST(malVector, obj)) - res = mal::list(mal::symbol("vec"), res); - return res; -} - -static const malLambda* isMacroApplication(malValuePtr obj, malEnvPtr env) -{ - const malList* seq = DYNAMIC_CAST(malList, obj); - if (seq && !seq->isEmpty()) { - if (malSymbol* sym = DYNAMIC_CAST(malSymbol, seq->item(0))) { - if (malEnvPtr symEnv = env->find(sym->value())) { - malValuePtr value = sym->eval(symEnv); - if (malLambda* lambda = DYNAMIC_CAST(malLambda, value)) { - return lambda->isMacro() ? lambda : NULL; - } - } - } - } - return NULL; -} - -static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env) -{ - while (const malLambda* macro = isMacroApplication(obj, env)) { - const malSequence* seq = STATIC_CAST(malSequence, obj); - obj = macro->apply(seq->begin() + 1, seq->end()); - } - return obj; -} - -static const char* malFunctionTable[] = { - "(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)))))))", - "(def! not (fn* (cond) (if cond false true)))", - "(def! load-file (fn* (filename) \ - (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", -}; - -static void installFunctions(malEnvPtr env) { - for (auto &function : malFunctionTable) { - rep(function, env); - } -} - -// Added to keep the linker happy at step A -malValuePtr readline(const String& prompt) -{ - String input; - if (s_readLine.get(prompt, input)) { - return mal::string(input); - } - return mal::nilValue(); -} - +#include "MAL.h" + +#include "Environment.h" +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); +static void installFunctions(malEnvPtr env); +// Installs functions and macros implemented in MAL. + +static void makeArgv(malEnvPtr env, int argc, char* argv[]); +static String safeRep(const String& input, malEnvPtr env); +static malValuePtr quasiquote(malValuePtr obj); +static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env); + +static ReadLine s_readLine("~/.mal-history"); + +static malEnvPtr replEnv(new malEnv); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + installCore(replEnv); + installFunctions(replEnv); + makeArgv(replEnv, argc - 2, argv + 2); + if (argc > 1) { + String filename = escape(argv[1]); + safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); + return 0; + } + while (s_readLine.get(prompt, input)) { + String out = safeRep(input, replEnv); + if (out.length() > 0) + std::cout << out << "\n"; + } + return 0; +} + +static String safeRep(const String& input, malEnvPtr env) +{ + try { + return rep(input, env); + } + catch (malEmptyInputException&) { + return String(); + } + catch (String& s) { + return s; + }; +} + +static void makeArgv(malEnvPtr env, int argc, char* argv[]) +{ + malValueVec* args = new malValueVec(); + for (int i = 0; i < argc; i++) { + args->push_back(mal::string(argv[i])); + } + env->set("*ARGV*", mal::list(args)); +} + +String rep(const String& input, malEnvPtr env) +{ + return PRINT(EVAL(READ(input), env)); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +malValuePtr EVAL(malValuePtr ast, malEnvPtr env) +{ + if (!env) { + env = replEnv; + } + while (1) { + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + ast = macroExpand(ast, env); + list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + // From here on down we are evaluating a non-empty list. + // First handle the special forms. + if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { + String special = symbol->value(); + int argCount = list->count() - 1; + + if (special == "def!") { + checkArgsIs("def!", 2, argCount); + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + return env->set(id->value(), EVAL(list->item(2), env)); + } + + if (special == "defmacro!") { + checkArgsIs("defmacro!", 2, argCount); + + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + malValuePtr body = EVAL(list->item(2), env); + const malLambda* lambda = VALUE_CAST(malLambda, body); + return env->set(id->value(), mal::macro(*lambda)); + } + + if (special == "do") { + checkArgsAtLeast("do", 1, argCount); + + for (int i = 1; i < argCount; i++) { + EVAL(list->item(i), env); + } + ast = list->item(argCount); + continue; // TCO + } + + if (special == "fn*") { + checkArgsIs("fn*", 2, argCount); + + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + StringVec params; + for (int i = 0; i < bindings->count(); i++) { + const malSymbol* sym = + VALUE_CAST(malSymbol, bindings->item(i)); + params.push_back(sym->value()); + } + + return mal::lambda(params, list->item(2), env); + } + + if (special == "if") { + checkArgsBetween("if", 2, 3, argCount); + + bool isTrue = EVAL(list->item(1), env)->isTrue(); + if (!isTrue && (argCount == 2)) { + return mal::nilValue(); + } + ast = list->item(isTrue ? 2 : 3); + continue; // TCO + } + + if (special == "let*") { + checkArgsIs("let*", 2, argCount); + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + int count = checkArgsEven("let*", bindings->count()); + malEnvPtr inner(new malEnv(env)); + for (int i = 0; i < count; i += 2) { + const malSymbol* var = + VALUE_CAST(malSymbol, bindings->item(i)); + inner->set(var->value(), EVAL(bindings->item(i+1), inner)); + } + ast = list->item(2); + env = inner; + continue; // TCO + } + + if (special == "macroexpand") { + checkArgsIs("macroexpand", 1, argCount); + return macroExpand(list->item(1), env); + } + + if (special == "quasiquoteexpand") { + checkArgsIs("quasiquote", 1, argCount); + return quasiquote(list->item(1)); + } + + if (special == "quasiquote") { + checkArgsIs("quasiquote", 1, argCount); + ast = quasiquote(list->item(1)); + continue; // TCO + } + + if (special == "quote") { + checkArgsIs("quote", 1, argCount); + return list->item(1); + } + } + + // Now we're left with the case of a regular list to be evaluated. + std::unique_ptr items(list->evalItems(env)); + malValuePtr op = items->at(0); + if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { + ast = lambda->getBody(); + env = lambda->makeEnv(items->begin()+1, items->end()); + continue; // TCO + } + else { + return APPLY(op, items->begin()+1, items->end()); + } + } +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) +{ + const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); + MAL_CHECK(handler != NULL, + "\"%s\" is not applicable", op->print(true).c_str()); + + return handler->apply(argsBegin, argsEnd); +} + +static bool isSymbol(malValuePtr obj, const String& text) +{ + const malSymbol* sym = DYNAMIC_CAST(malSymbol, obj); + return sym && (sym->value() == text); +} + +// Return arg when ast matches ('sym, arg), else NULL. +static malValuePtr starts_with(const malValuePtr ast, const char* sym) +{ + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || list->isEmpty() || !isSymbol(list->item(0), sym)) + return NULL; + checkArgsIs(sym, 1, list->count() - 1); + return list->item(1); +} + +static malValuePtr quasiquote(malValuePtr obj) +{ + if (DYNAMIC_CAST(malSymbol, obj) || DYNAMIC_CAST(malHash, obj)) + return mal::list(mal::symbol("quote"), obj); + + const malSequence* seq = DYNAMIC_CAST(malSequence, obj); + if (!seq) + return obj; + + const malValuePtr unquoted = starts_with(obj, "unquote"); + if (unquoted) + return unquoted; + + malValuePtr res = mal::list(new malValueVec(0)); + for (int i=seq->count()-1; 0<=i; i--) { + const malValuePtr elt = seq->item(i); + const malValuePtr spl_unq = starts_with(elt, "splice-unquote"); + if (spl_unq) + res = mal::list(mal::symbol("concat"), spl_unq, res); + else + res = mal::list(mal::symbol("cons"), quasiquote(elt), res); + } + if (DYNAMIC_CAST(malVector, obj)) + res = mal::list(mal::symbol("vec"), res); + return res; +} + +static const malLambda* isMacroApplication(malValuePtr obj, malEnvPtr env) +{ + const malList* seq = DYNAMIC_CAST(malList, obj); + if (seq && !seq->isEmpty()) { + if (malSymbol* sym = DYNAMIC_CAST(malSymbol, seq->item(0))) { + if (malEnvPtr symEnv = env->find(sym->value())) { + malValuePtr value = sym->eval(symEnv); + if (malLambda* lambda = DYNAMIC_CAST(malLambda, value)) { + return lambda->isMacro() ? lambda : NULL; + } + } + } + } + return NULL; +} + +static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env) +{ + while (const malLambda* macro = isMacroApplication(obj, env)) { + const malSequence* seq = STATIC_CAST(malSequence, obj); + obj = macro->apply(seq->begin() + 1, seq->end()); + } + return obj; +} + +static const char* malFunctionTable[] = { + "(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)))))))", + "(def! not (fn* (cond) (if cond false true)))", + "(def! load-file (fn* (filename) \ + (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", +}; + +static void installFunctions(malEnvPtr env) { + for (auto &function : malFunctionTable) { + rep(function, env); + } +} + +// Added to keep the linker happy at step A +malValuePtr readline(const String& prompt) +{ + String input; + if (s_readLine.get(prompt, input)) { + return mal::string(input); + } + return mal::nilValue(); +} + diff --git a/impls/cpp/step9_try.cpp b/impls/cpp/step9_try.cpp index 5b38a8469a..74c430ad64 100644 --- a/impls/cpp/step9_try.cpp +++ b/impls/cpp/step9_try.cpp @@ -1,355 +1,355 @@ -#include "MAL.h" - -#include "Environment.h" -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); -static void installFunctions(malEnvPtr env); -// Installs functions and macros implemented in MAL. - -static void makeArgv(malEnvPtr env, int argc, char* argv[]); -static String safeRep(const String& input, malEnvPtr env); -static malValuePtr quasiquote(malValuePtr obj); -static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env); - -static ReadLine s_readLine("~/.mal-history"); - -static malEnvPtr replEnv(new malEnv); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - installCore(replEnv); - installFunctions(replEnv); - makeArgv(replEnv, argc - 2, argv + 2); - if (argc > 1) { - String filename = escape(argv[1]); - safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); - return 0; - } - while (s_readLine.get(prompt, input)) { - String out = safeRep(input, replEnv); - if (out.length() > 0) - std::cout << out << "\n"; - } - return 0; -} - -static String safeRep(const String& input, malEnvPtr env) -{ - try { - return rep(input, env); - } - catch (malEmptyInputException&) { - return String(); - } - catch (malValuePtr& mv) { - return "Error: " + mv->print(true); - } - catch (String& s) { - return "Error: " + s; - }; -} - -static void makeArgv(malEnvPtr env, int argc, char* argv[]) -{ - malValueVec* args = new malValueVec(); - for (int i = 0; i < argc; i++) { - args->push_back(mal::string(argv[i])); - } - env->set("*ARGV*", mal::list(args)); -} - -String rep(const String& input, malEnvPtr env) -{ - return PRINT(EVAL(READ(input), env)); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -malValuePtr EVAL(malValuePtr ast, malEnvPtr env) -{ - if (!env) { - env = replEnv; - } - while (1) { - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - ast = macroExpand(ast, env); - list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - // From here on down we are evaluating a non-empty list. - // First handle the special forms. - if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { - String special = symbol->value(); - int argCount = list->count() - 1; - - if (special == "def!") { - checkArgsIs("def!", 2, argCount); - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - return env->set(id->value(), EVAL(list->item(2), env)); - } - - if (special == "defmacro!") { - checkArgsIs("defmacro!", 2, argCount); - - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - malValuePtr body = EVAL(list->item(2), env); - const malLambda* lambda = VALUE_CAST(malLambda, body); - return env->set(id->value(), mal::macro(*lambda)); - } - - if (special == "do") { - checkArgsAtLeast("do", 1, argCount); - - for (int i = 1; i < argCount; i++) { - EVAL(list->item(i), env); - } - ast = list->item(argCount); - continue; // TCO - } - - if (special == "fn*") { - checkArgsIs("fn*", 2, argCount); - - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - StringVec params; - for (int i = 0; i < bindings->count(); i++) { - const malSymbol* sym = - VALUE_CAST(malSymbol, bindings->item(i)); - params.push_back(sym->value()); - } - - return mal::lambda(params, list->item(2), env); - } - - if (special == "if") { - checkArgsBetween("if", 2, 3, argCount); - - bool isTrue = EVAL(list->item(1), env)->isTrue(); - if (!isTrue && (argCount == 2)) { - return mal::nilValue(); - } - ast = list->item(isTrue ? 2 : 3); - continue; // TCO - } - - if (special == "let*") { - checkArgsIs("let*", 2, argCount); - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - int count = checkArgsEven("let*", bindings->count()); - malEnvPtr inner(new malEnv(env)); - for (int i = 0; i < count; i += 2) { - const malSymbol* var = - VALUE_CAST(malSymbol, bindings->item(i)); - inner->set(var->value(), EVAL(bindings->item(i+1), inner)); - } - ast = list->item(2); - env = inner; - continue; // TCO - } - - if (special == "macroexpand") { - checkArgsIs("macroexpand", 1, argCount); - return macroExpand(list->item(1), env); - } - - if (special == "quasiquoteexpand") { - checkArgsIs("quasiquote", 1, argCount); - return quasiquote(list->item(1)); - } - - if (special == "quasiquote") { - checkArgsIs("quasiquote", 1, argCount); - ast = quasiquote(list->item(1)); - continue; // TCO - } - - if (special == "quote") { - checkArgsIs("quote", 1, argCount); - return list->item(1); - } - - if (special == "try*") { - malValuePtr tryBody = list->item(1); - - if (argCount == 1) { - ast = EVAL(tryBody, env); - continue; // TCO - } - checkArgsIs("try*", 2, argCount); - const malList* catchBlock = VALUE_CAST(malList, list->item(2)); - - checkArgsIs("catch*", 2, catchBlock->count() - 1); - MAL_CHECK(VALUE_CAST(malSymbol, - catchBlock->item(0))->value() == "catch*", - "catch block must begin with catch*"); - - // We don't need excSym at this scope, but we want to check - // that the catch block is valid always, not just in case of - // an exception. - const malSymbol* excSym = - VALUE_CAST(malSymbol, catchBlock->item(1)); - - malValuePtr excVal; - - try { - ast = EVAL(tryBody, env); - } - catch(String& s) { - excVal = mal::string(s); - } - catch (malEmptyInputException&) { - // Not an error, continue as if we got nil - ast = mal::nilValue(); - } - catch(malValuePtr& o) { - excVal = o; - }; - - if (excVal) { - // we got some exception - env = malEnvPtr(new malEnv(env)); - env->set(excSym->value(), excVal); - ast = catchBlock->item(2); - } - continue; // TCO - } - } - - // Now we're left with the case of a regular list to be evaluated. - std::unique_ptr items(list->evalItems(env)); - malValuePtr op = items->at(0); - if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { - ast = lambda->getBody(); - env = lambda->makeEnv(items->begin()+1, items->end()); - continue; // TCO - } - else { - return APPLY(op, items->begin()+1, items->end()); - } - } -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) -{ - const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); - MAL_CHECK(handler != NULL, - "\"%s\" is not applicable", op->print(true).c_str()); - - return handler->apply(argsBegin, argsEnd); -} - -static bool isSymbol(malValuePtr obj, const String& text) -{ - const malSymbol* sym = DYNAMIC_CAST(malSymbol, obj); - return sym && (sym->value() == text); -} - -// Return arg when ast matches ('sym, arg), else NULL. -static malValuePtr starts_with(const malValuePtr ast, const char* sym) -{ - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || list->isEmpty() || !isSymbol(list->item(0), sym)) - return NULL; - checkArgsIs(sym, 1, list->count() - 1); - return list->item(1); -} - -static malValuePtr quasiquote(malValuePtr obj) -{ - if (DYNAMIC_CAST(malSymbol, obj) || DYNAMIC_CAST(malHash, obj)) - return mal::list(mal::symbol("quote"), obj); - - const malSequence* seq = DYNAMIC_CAST(malSequence, obj); - if (!seq) - return obj; - - const malValuePtr unquoted = starts_with(obj, "unquote"); - if (unquoted) - return unquoted; - - malValuePtr res = mal::list(new malValueVec(0)); - for (int i=seq->count()-1; 0<=i; i--) { - const malValuePtr elt = seq->item(i); - const malValuePtr spl_unq = starts_with(elt, "splice-unquote"); - if (spl_unq) - res = mal::list(mal::symbol("concat"), spl_unq, res); - else - res = mal::list(mal::symbol("cons"), quasiquote(elt), res); - } - if (DYNAMIC_CAST(malVector, obj)) - res = mal::list(mal::symbol("vec"), res); - return res; -} - -static const malLambda* isMacroApplication(malValuePtr obj, malEnvPtr env) -{ - const malList* seq = DYNAMIC_CAST(malList, obj); - if (seq && !seq->isEmpty()) { - if (malSymbol* sym = DYNAMIC_CAST(malSymbol, seq->item(0))) { - if (malEnvPtr symEnv = env->find(sym->value())) { - malValuePtr value = sym->eval(symEnv); - if (malLambda* lambda = DYNAMIC_CAST(malLambda, value)) { - return lambda->isMacro() ? lambda : NULL; - } - } - } - } - return NULL; -} - -static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env) -{ - while (const malLambda* macro = isMacroApplication(obj, env)) { - const malSequence* seq = STATIC_CAST(malSequence, obj); - obj = macro->apply(seq->begin() + 1, seq->end()); - } - return obj; -} - -static const char* malFunctionTable[] = { - "(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)))))))", - "(def! not (fn* (cond) (if cond false true)))", - "(def! load-file (fn* (filename) \ - (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", -}; - -static void installFunctions(malEnvPtr env) { - for (auto &function : malFunctionTable) { - rep(function, env); - } -} - -// Added to keep the linker happy at step A -malValuePtr readline(const String& prompt) -{ - String input; - if (s_readLine.get(prompt, input)) { - return mal::string(input); - } - return mal::nilValue(); -} - +#include "MAL.h" + +#include "Environment.h" +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); +static void installFunctions(malEnvPtr env); +// Installs functions and macros implemented in MAL. + +static void makeArgv(malEnvPtr env, int argc, char* argv[]); +static String safeRep(const String& input, malEnvPtr env); +static malValuePtr quasiquote(malValuePtr obj); +static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env); + +static ReadLine s_readLine("~/.mal-history"); + +static malEnvPtr replEnv(new malEnv); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + installCore(replEnv); + installFunctions(replEnv); + makeArgv(replEnv, argc - 2, argv + 2); + if (argc > 1) { + String filename = escape(argv[1]); + safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); + return 0; + } + while (s_readLine.get(prompt, input)) { + String out = safeRep(input, replEnv); + if (out.length() > 0) + std::cout << out << "\n"; + } + return 0; +} + +static String safeRep(const String& input, malEnvPtr env) +{ + try { + return rep(input, env); + } + catch (malEmptyInputException&) { + return String(); + } + catch (malValuePtr& mv) { + return "Error: " + mv->print(true); + } + catch (String& s) { + return "Error: " + s; + }; +} + +static void makeArgv(malEnvPtr env, int argc, char* argv[]) +{ + malValueVec* args = new malValueVec(); + for (int i = 0; i < argc; i++) { + args->push_back(mal::string(argv[i])); + } + env->set("*ARGV*", mal::list(args)); +} + +String rep(const String& input, malEnvPtr env) +{ + return PRINT(EVAL(READ(input), env)); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +malValuePtr EVAL(malValuePtr ast, malEnvPtr env) +{ + if (!env) { + env = replEnv; + } + while (1) { + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + ast = macroExpand(ast, env); + list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + // From here on down we are evaluating a non-empty list. + // First handle the special forms. + if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { + String special = symbol->value(); + int argCount = list->count() - 1; + + if (special == "def!") { + checkArgsIs("def!", 2, argCount); + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + return env->set(id->value(), EVAL(list->item(2), env)); + } + + if (special == "defmacro!") { + checkArgsIs("defmacro!", 2, argCount); + + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + malValuePtr body = EVAL(list->item(2), env); + const malLambda* lambda = VALUE_CAST(malLambda, body); + return env->set(id->value(), mal::macro(*lambda)); + } + + if (special == "do") { + checkArgsAtLeast("do", 1, argCount); + + for (int i = 1; i < argCount; i++) { + EVAL(list->item(i), env); + } + ast = list->item(argCount); + continue; // TCO + } + + if (special == "fn*") { + checkArgsIs("fn*", 2, argCount); + + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + StringVec params; + for (int i = 0; i < bindings->count(); i++) { + const malSymbol* sym = + VALUE_CAST(malSymbol, bindings->item(i)); + params.push_back(sym->value()); + } + + return mal::lambda(params, list->item(2), env); + } + + if (special == "if") { + checkArgsBetween("if", 2, 3, argCount); + + bool isTrue = EVAL(list->item(1), env)->isTrue(); + if (!isTrue && (argCount == 2)) { + return mal::nilValue(); + } + ast = list->item(isTrue ? 2 : 3); + continue; // TCO + } + + if (special == "let*") { + checkArgsIs("let*", 2, argCount); + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + int count = checkArgsEven("let*", bindings->count()); + malEnvPtr inner(new malEnv(env)); + for (int i = 0; i < count; i += 2) { + const malSymbol* var = + VALUE_CAST(malSymbol, bindings->item(i)); + inner->set(var->value(), EVAL(bindings->item(i+1), inner)); + } + ast = list->item(2); + env = inner; + continue; // TCO + } + + if (special == "macroexpand") { + checkArgsIs("macroexpand", 1, argCount); + return macroExpand(list->item(1), env); + } + + if (special == "quasiquoteexpand") { + checkArgsIs("quasiquote", 1, argCount); + return quasiquote(list->item(1)); + } + + if (special == "quasiquote") { + checkArgsIs("quasiquote", 1, argCount); + ast = quasiquote(list->item(1)); + continue; // TCO + } + + if (special == "quote") { + checkArgsIs("quote", 1, argCount); + return list->item(1); + } + + if (special == "try*") { + malValuePtr tryBody = list->item(1); + + if (argCount == 1) { + ast = EVAL(tryBody, env); + continue; // TCO + } + checkArgsIs("try*", 2, argCount); + const malList* catchBlock = VALUE_CAST(malList, list->item(2)); + + checkArgsIs("catch*", 2, catchBlock->count() - 1); + MAL_CHECK(VALUE_CAST(malSymbol, + catchBlock->item(0))->value() == "catch*", + "catch block must begin with catch*"); + + // We don't need excSym at this scope, but we want to check + // that the catch block is valid always, not just in case of + // an exception. + const malSymbol* excSym = + VALUE_CAST(malSymbol, catchBlock->item(1)); + + malValuePtr excVal; + + try { + ast = EVAL(tryBody, env); + } + catch(String& s) { + excVal = mal::string(s); + } + catch (malEmptyInputException&) { + // Not an error, continue as if we got nil + ast = mal::nilValue(); + } + catch(malValuePtr& o) { + excVal = o; + }; + + if (excVal) { + // we got some exception + env = malEnvPtr(new malEnv(env)); + env->set(excSym->value(), excVal); + ast = catchBlock->item(2); + } + continue; // TCO + } + } + + // Now we're left with the case of a regular list to be evaluated. + std::unique_ptr items(list->evalItems(env)); + malValuePtr op = items->at(0); + if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { + ast = lambda->getBody(); + env = lambda->makeEnv(items->begin()+1, items->end()); + continue; // TCO + } + else { + return APPLY(op, items->begin()+1, items->end()); + } + } +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) +{ + const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); + MAL_CHECK(handler != NULL, + "\"%s\" is not applicable", op->print(true).c_str()); + + return handler->apply(argsBegin, argsEnd); +} + +static bool isSymbol(malValuePtr obj, const String& text) +{ + const malSymbol* sym = DYNAMIC_CAST(malSymbol, obj); + return sym && (sym->value() == text); +} + +// Return arg when ast matches ('sym, arg), else NULL. +static malValuePtr starts_with(const malValuePtr ast, const char* sym) +{ + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || list->isEmpty() || !isSymbol(list->item(0), sym)) + return NULL; + checkArgsIs(sym, 1, list->count() - 1); + return list->item(1); +} + +static malValuePtr quasiquote(malValuePtr obj) +{ + if (DYNAMIC_CAST(malSymbol, obj) || DYNAMIC_CAST(malHash, obj)) + return mal::list(mal::symbol("quote"), obj); + + const malSequence* seq = DYNAMIC_CAST(malSequence, obj); + if (!seq) + return obj; + + const malValuePtr unquoted = starts_with(obj, "unquote"); + if (unquoted) + return unquoted; + + malValuePtr res = mal::list(new malValueVec(0)); + for (int i=seq->count()-1; 0<=i; i--) { + const malValuePtr elt = seq->item(i); + const malValuePtr spl_unq = starts_with(elt, "splice-unquote"); + if (spl_unq) + res = mal::list(mal::symbol("concat"), spl_unq, res); + else + res = mal::list(mal::symbol("cons"), quasiquote(elt), res); + } + if (DYNAMIC_CAST(malVector, obj)) + res = mal::list(mal::symbol("vec"), res); + return res; +} + +static const malLambda* isMacroApplication(malValuePtr obj, malEnvPtr env) +{ + const malList* seq = DYNAMIC_CAST(malList, obj); + if (seq && !seq->isEmpty()) { + if (malSymbol* sym = DYNAMIC_CAST(malSymbol, seq->item(0))) { + if (malEnvPtr symEnv = env->find(sym->value())) { + malValuePtr value = sym->eval(symEnv); + if (malLambda* lambda = DYNAMIC_CAST(malLambda, value)) { + return lambda->isMacro() ? lambda : NULL; + } + } + } + } + return NULL; +} + +static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env) +{ + while (const malLambda* macro = isMacroApplication(obj, env)) { + const malSequence* seq = STATIC_CAST(malSequence, obj); + obj = macro->apply(seq->begin() + 1, seq->end()); + } + return obj; +} + +static const char* malFunctionTable[] = { + "(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)))))))", + "(def! not (fn* (cond) (if cond false true)))", + "(def! load-file (fn* (filename) \ + (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", +}; + +static void installFunctions(malEnvPtr env) { + for (auto &function : malFunctionTable) { + rep(function, env); + } +} + +// Added to keep the linker happy at step A +malValuePtr readline(const String& prompt) +{ + String input; + if (s_readLine.get(prompt, input)) { + return mal::string(input); + } + return mal::nilValue(); +} + diff --git a/impls/cpp/stepA_mal.cpp b/impls/cpp/stepA_mal.cpp index 34c940ba81..6f59238ae9 100644 --- a/impls/cpp/stepA_mal.cpp +++ b/impls/cpp/stepA_mal.cpp @@ -1,357 +1,357 @@ -#include "MAL.h" - -#include "Environment.h" -#include "ReadLine.h" -#include "Types.h" - -#include -#include - -malValuePtr READ(const String& input); -String PRINT(malValuePtr ast); -static void installFunctions(malEnvPtr env); -// Installs functions, macros and constants implemented in MAL. - -static void makeArgv(malEnvPtr env, int argc, char* argv[]); -static String safeRep(const String& input, malEnvPtr env); -static malValuePtr quasiquote(malValuePtr obj); -static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env); - -static ReadLine s_readLine("~/.mal-history"); - -static malEnvPtr replEnv(new malEnv); - -int main(int argc, char* argv[]) -{ - String prompt = "user> "; - String input; - installCore(replEnv); - installFunctions(replEnv); - makeArgv(replEnv, argc - 2, argv + 2); - if (argc > 1) { - String filename = escape(argv[1]); - safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); - return 0; - } - rep("(println (str \"Mal [\" *host-language* \"]\"))", replEnv); - while (s_readLine.get(prompt, input)) { - String out = safeRep(input, replEnv); - if (out.length() > 0) - std::cout << out << "\n"; - } - return 0; -} - -static String safeRep(const String& input, malEnvPtr env) -{ - try { - return rep(input, env); - } - catch (malEmptyInputException&) { - return String(); - } - catch (malValuePtr& mv) { - return "Error: " + mv->print(true); - } - catch (String& s) { - return "Error: " + s; - }; -} - -static void makeArgv(malEnvPtr env, int argc, char* argv[]) -{ - malValueVec* args = new malValueVec(); - for (int i = 0; i < argc; i++) { - args->push_back(mal::string(argv[i])); - } - env->set("*ARGV*", mal::list(args)); -} - -String rep(const String& input, malEnvPtr env) -{ - return PRINT(EVAL(READ(input), env)); -} - -malValuePtr READ(const String& input) -{ - return readStr(input); -} - -malValuePtr EVAL(malValuePtr ast, malEnvPtr env) -{ - if (!env) { - env = replEnv; - } - while (1) { - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - ast = macroExpand(ast, env); - list = DYNAMIC_CAST(malList, ast); - if (!list || (list->count() == 0)) { - return ast->eval(env); - } - - // From here on down we are evaluating a non-empty list. - // First handle the special forms. - if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { - String special = symbol->value(); - int argCount = list->count() - 1; - - if (special == "def!") { - checkArgsIs("def!", 2, argCount); - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - return env->set(id->value(), EVAL(list->item(2), env)); - } - - if (special == "defmacro!") { - checkArgsIs("defmacro!", 2, argCount); - - const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); - malValuePtr body = EVAL(list->item(2), env); - const malLambda* lambda = VALUE_CAST(malLambda, body); - return env->set(id->value(), mal::macro(*lambda)); - } - - if (special == "do") { - checkArgsAtLeast("do", 1, argCount); - - for (int i = 1; i < argCount; i++) { - EVAL(list->item(i), env); - } - ast = list->item(argCount); - continue; // TCO - } - - if (special == "fn*") { - checkArgsIs("fn*", 2, argCount); - - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - StringVec params; - for (int i = 0; i < bindings->count(); i++) { - const malSymbol* sym = - VALUE_CAST(malSymbol, bindings->item(i)); - params.push_back(sym->value()); - } - - return mal::lambda(params, list->item(2), env); - } - - if (special == "if") { - checkArgsBetween("if", 2, 3, argCount); - - bool isTrue = EVAL(list->item(1), env)->isTrue(); - if (!isTrue && (argCount == 2)) { - return mal::nilValue(); - } - ast = list->item(isTrue ? 2 : 3); - continue; // TCO - } - - if (special == "let*") { - checkArgsIs("let*", 2, argCount); - const malSequence* bindings = - VALUE_CAST(malSequence, list->item(1)); - int count = checkArgsEven("let*", bindings->count()); - malEnvPtr inner(new malEnv(env)); - for (int i = 0; i < count; i += 2) { - const malSymbol* var = - VALUE_CAST(malSymbol, bindings->item(i)); - inner->set(var->value(), EVAL(bindings->item(i+1), inner)); - } - ast = list->item(2); - env = inner; - continue; // TCO - } - - if (special == "macroexpand") { - checkArgsIs("macroexpand", 1, argCount); - return macroExpand(list->item(1), env); - } - - if (special == "quasiquoteexpand") { - checkArgsIs("quasiquote", 1, argCount); - return quasiquote(list->item(1)); - } - - if (special == "quasiquote") { - checkArgsIs("quasiquote", 1, argCount); - ast = quasiquote(list->item(1)); - continue; // TCO - } - - if (special == "quote") { - checkArgsIs("quote", 1, argCount); - return list->item(1); - } - - if (special == "try*") { - malValuePtr tryBody = list->item(1); - - if (argCount == 1) { - ast = EVAL(tryBody, env); - continue; // TCO - } - checkArgsIs("try*", 2, argCount); - const malList* catchBlock = VALUE_CAST(malList, list->item(2)); - - checkArgsIs("catch*", 2, catchBlock->count() - 1); - MAL_CHECK(VALUE_CAST(malSymbol, - catchBlock->item(0))->value() == "catch*", - "catch block must begin with catch*"); - - // We don't need excSym at this scope, but we want to check - // that the catch block is valid always, not just in case of - // an exception. - const malSymbol* excSym = - VALUE_CAST(malSymbol, catchBlock->item(1)); - - malValuePtr excVal; - - try { - ast = EVAL(tryBody, env); - } - catch(String& s) { - excVal = mal::string(s); - } - catch (malEmptyInputException&) { - // Not an error, continue as if we got nil - ast = mal::nilValue(); - } - catch(malValuePtr& o) { - excVal = o; - }; - - if (excVal) { - // we got some exception - env = malEnvPtr(new malEnv(env)); - env->set(excSym->value(), excVal); - ast = catchBlock->item(2); - } - continue; // TCO - } - } - - // Now we're left with the case of a regular list to be evaluated. - std::unique_ptr items(list->evalItems(env)); - malValuePtr op = items->at(0); - if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { - ast = lambda->getBody(); - env = lambda->makeEnv(items->begin()+1, items->end()); - continue; // TCO - } - else { - return APPLY(op, items->begin()+1, items->end()); - } - } -} - -String PRINT(malValuePtr ast) -{ - return ast->print(true); -} - -malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) -{ - const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); - MAL_CHECK(handler != NULL, - "\"%s\" is not applicable", op->print(true).c_str()); - - return handler->apply(argsBegin, argsEnd); -} - -static bool isSymbol(malValuePtr obj, const String& text) -{ - const malSymbol* sym = DYNAMIC_CAST(malSymbol, obj); - return sym && (sym->value() == text); -} - -// Return arg when ast matches ('sym, arg), else NULL. -static malValuePtr starts_with(const malValuePtr ast, const char* sym) -{ - const malList* list = DYNAMIC_CAST(malList, ast); - if (!list || list->isEmpty() || !isSymbol(list->item(0), sym)) - return NULL; - checkArgsIs(sym, 1, list->count() - 1); - return list->item(1); -} - -static malValuePtr quasiquote(malValuePtr obj) -{ - if (DYNAMIC_CAST(malSymbol, obj) || DYNAMIC_CAST(malHash, obj)) - return mal::list(mal::symbol("quote"), obj); - - const malSequence* seq = DYNAMIC_CAST(malSequence, obj); - if (!seq) - return obj; - - const malValuePtr unquoted = starts_with(obj, "unquote"); - if (unquoted) - return unquoted; - - malValuePtr res = mal::list(new malValueVec(0)); - for (int i=seq->count()-1; 0<=i; i--) { - const malValuePtr elt = seq->item(i); - const malValuePtr spl_unq = starts_with(elt, "splice-unquote"); - if (spl_unq) - res = mal::list(mal::symbol("concat"), spl_unq, res); - else - res = mal::list(mal::symbol("cons"), quasiquote(elt), res); - } - if (DYNAMIC_CAST(malVector, obj)) - res = mal::list(mal::symbol("vec"), res); - return res; -} - -static const malLambda* isMacroApplication(malValuePtr obj, malEnvPtr env) -{ - const malList* seq = DYNAMIC_CAST(malList, obj); - if (seq && !seq->isEmpty()) { - if (malSymbol* sym = DYNAMIC_CAST(malSymbol, seq->item(0))) { - if (malEnvPtr symEnv = env->find(sym->value())) { - malValuePtr value = sym->eval(symEnv); - if (malLambda* lambda = DYNAMIC_CAST(malLambda, value)) { - return lambda->isMacro() ? lambda : NULL; - } - } - } - } - return NULL; -} - -static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env) -{ - while (const malLambda* macro = isMacroApplication(obj, env)) { - const malSequence* seq = STATIC_CAST(malSequence, obj); - obj = macro->apply(seq->begin() + 1, seq->end()); - } - return obj; -} - -static const char* malFunctionTable[] = { - "(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)))))))", - "(def! not (fn* (cond) (if cond false true)))", - "(def! load-file (fn* (filename) \ - (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", - "(def! *host-language* \"C++\")", -}; - -static void installFunctions(malEnvPtr env) { - for (auto &function : malFunctionTable) { - rep(function, env); - } -} - -// Added to keep the linker happy at step A -malValuePtr readline(const String& prompt) -{ - String input; - if (s_readLine.get(prompt, input)) { - return mal::string(input); - } - return mal::nilValue(); -} - +#include "MAL.h" + +#include "Environment.h" +#include "ReadLine.h" +#include "Types.h" + +#include +#include + +malValuePtr READ(const String& input); +String PRINT(malValuePtr ast); +static void installFunctions(malEnvPtr env); +// Installs functions, macros and constants implemented in MAL. + +static void makeArgv(malEnvPtr env, int argc, char* argv[]); +static String safeRep(const String& input, malEnvPtr env); +static malValuePtr quasiquote(malValuePtr obj); +static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env); + +static ReadLine s_readLine("~/.mal-history"); + +static malEnvPtr replEnv(new malEnv); + +int main(int argc, char* argv[]) +{ + String prompt = "user> "; + String input; + installCore(replEnv); + installFunctions(replEnv); + makeArgv(replEnv, argc - 2, argv + 2); + if (argc > 1) { + String filename = escape(argv[1]); + safeRep(STRF("(load-file %s)", filename.c_str()), replEnv); + return 0; + } + rep("(println (str \"Mal [\" *host-language* \"]\"))", replEnv); + while (s_readLine.get(prompt, input)) { + String out = safeRep(input, replEnv); + if (out.length() > 0) + std::cout << out << "\n"; + } + return 0; +} + +static String safeRep(const String& input, malEnvPtr env) +{ + try { + return rep(input, env); + } + catch (malEmptyInputException&) { + return String(); + } + catch (malValuePtr& mv) { + return "Error: " + mv->print(true); + } + catch (String& s) { + return "Error: " + s; + }; +} + +static void makeArgv(malEnvPtr env, int argc, char* argv[]) +{ + malValueVec* args = new malValueVec(); + for (int i = 0; i < argc; i++) { + args->push_back(mal::string(argv[i])); + } + env->set("*ARGV*", mal::list(args)); +} + +String rep(const String& input, malEnvPtr env) +{ + return PRINT(EVAL(READ(input), env)); +} + +malValuePtr READ(const String& input) +{ + return readStr(input); +} + +malValuePtr EVAL(malValuePtr ast, malEnvPtr env) +{ + if (!env) { + env = replEnv; + } + while (1) { + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + ast = macroExpand(ast, env); + list = DYNAMIC_CAST(malList, ast); + if (!list || (list->count() == 0)) { + return ast->eval(env); + } + + // From here on down we are evaluating a non-empty list. + // First handle the special forms. + if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) { + String special = symbol->value(); + int argCount = list->count() - 1; + + if (special == "def!") { + checkArgsIs("def!", 2, argCount); + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + return env->set(id->value(), EVAL(list->item(2), env)); + } + + if (special == "defmacro!") { + checkArgsIs("defmacro!", 2, argCount); + + const malSymbol* id = VALUE_CAST(malSymbol, list->item(1)); + malValuePtr body = EVAL(list->item(2), env); + const malLambda* lambda = VALUE_CAST(malLambda, body); + return env->set(id->value(), mal::macro(*lambda)); + } + + if (special == "do") { + checkArgsAtLeast("do", 1, argCount); + + for (int i = 1; i < argCount; i++) { + EVAL(list->item(i), env); + } + ast = list->item(argCount); + continue; // TCO + } + + if (special == "fn*") { + checkArgsIs("fn*", 2, argCount); + + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + StringVec params; + for (int i = 0; i < bindings->count(); i++) { + const malSymbol* sym = + VALUE_CAST(malSymbol, bindings->item(i)); + params.push_back(sym->value()); + } + + return mal::lambda(params, list->item(2), env); + } + + if (special == "if") { + checkArgsBetween("if", 2, 3, argCount); + + bool isTrue = EVAL(list->item(1), env)->isTrue(); + if (!isTrue && (argCount == 2)) { + return mal::nilValue(); + } + ast = list->item(isTrue ? 2 : 3); + continue; // TCO + } + + if (special == "let*") { + checkArgsIs("let*", 2, argCount); + const malSequence* bindings = + VALUE_CAST(malSequence, list->item(1)); + int count = checkArgsEven("let*", bindings->count()); + malEnvPtr inner(new malEnv(env)); + for (int i = 0; i < count; i += 2) { + const malSymbol* var = + VALUE_CAST(malSymbol, bindings->item(i)); + inner->set(var->value(), EVAL(bindings->item(i+1), inner)); + } + ast = list->item(2); + env = inner; + continue; // TCO + } + + if (special == "macroexpand") { + checkArgsIs("macroexpand", 1, argCount); + return macroExpand(list->item(1), env); + } + + if (special == "quasiquoteexpand") { + checkArgsIs("quasiquote", 1, argCount); + return quasiquote(list->item(1)); + } + + if (special == "quasiquote") { + checkArgsIs("quasiquote", 1, argCount); + ast = quasiquote(list->item(1)); + continue; // TCO + } + + if (special == "quote") { + checkArgsIs("quote", 1, argCount); + return list->item(1); + } + + if (special == "try*") { + malValuePtr tryBody = list->item(1); + + if (argCount == 1) { + ast = EVAL(tryBody, env); + continue; // TCO + } + checkArgsIs("try*", 2, argCount); + const malList* catchBlock = VALUE_CAST(malList, list->item(2)); + + checkArgsIs("catch*", 2, catchBlock->count() - 1); + MAL_CHECK(VALUE_CAST(malSymbol, + catchBlock->item(0))->value() == "catch*", + "catch block must begin with catch*"); + + // We don't need excSym at this scope, but we want to check + // that the catch block is valid always, not just in case of + // an exception. + const malSymbol* excSym = + VALUE_CAST(malSymbol, catchBlock->item(1)); + + malValuePtr excVal; + + try { + ast = EVAL(tryBody, env); + } + catch(String& s) { + excVal = mal::string(s); + } + catch (malEmptyInputException&) { + // Not an error, continue as if we got nil + ast = mal::nilValue(); + } + catch(malValuePtr& o) { + excVal = o; + }; + + if (excVal) { + // we got some exception + env = malEnvPtr(new malEnv(env)); + env->set(excSym->value(), excVal); + ast = catchBlock->item(2); + } + continue; // TCO + } + } + + // Now we're left with the case of a regular list to be evaluated. + std::unique_ptr items(list->evalItems(env)); + malValuePtr op = items->at(0); + if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) { + ast = lambda->getBody(); + env = lambda->makeEnv(items->begin()+1, items->end()); + continue; // TCO + } + else { + return APPLY(op, items->begin()+1, items->end()); + } + } +} + +String PRINT(malValuePtr ast) +{ + return ast->print(true); +} + +malValuePtr APPLY(malValuePtr op, malValueIter argsBegin, malValueIter argsEnd) +{ + const malApplicable* handler = DYNAMIC_CAST(malApplicable, op); + MAL_CHECK(handler != NULL, + "\"%s\" is not applicable", op->print(true).c_str()); + + return handler->apply(argsBegin, argsEnd); +} + +static bool isSymbol(malValuePtr obj, const String& text) +{ + const malSymbol* sym = DYNAMIC_CAST(malSymbol, obj); + return sym && (sym->value() == text); +} + +// Return arg when ast matches ('sym, arg), else NULL. +static malValuePtr starts_with(const malValuePtr ast, const char* sym) +{ + const malList* list = DYNAMIC_CAST(malList, ast); + if (!list || list->isEmpty() || !isSymbol(list->item(0), sym)) + return NULL; + checkArgsIs(sym, 1, list->count() - 1); + return list->item(1); +} + +static malValuePtr quasiquote(malValuePtr obj) +{ + if (DYNAMIC_CAST(malSymbol, obj) || DYNAMIC_CAST(malHash, obj)) + return mal::list(mal::symbol("quote"), obj); + + const malSequence* seq = DYNAMIC_CAST(malSequence, obj); + if (!seq) + return obj; + + const malValuePtr unquoted = starts_with(obj, "unquote"); + if (unquoted) + return unquoted; + + malValuePtr res = mal::list(new malValueVec(0)); + for (int i=seq->count()-1; 0<=i; i--) { + const malValuePtr elt = seq->item(i); + const malValuePtr spl_unq = starts_with(elt, "splice-unquote"); + if (spl_unq) + res = mal::list(mal::symbol("concat"), spl_unq, res); + else + res = mal::list(mal::symbol("cons"), quasiquote(elt), res); + } + if (DYNAMIC_CAST(malVector, obj)) + res = mal::list(mal::symbol("vec"), res); + return res; +} + +static const malLambda* isMacroApplication(malValuePtr obj, malEnvPtr env) +{ + const malList* seq = DYNAMIC_CAST(malList, obj); + if (seq && !seq->isEmpty()) { + if (malSymbol* sym = DYNAMIC_CAST(malSymbol, seq->item(0))) { + if (malEnvPtr symEnv = env->find(sym->value())) { + malValuePtr value = sym->eval(symEnv); + if (malLambda* lambda = DYNAMIC_CAST(malLambda, value)) { + return lambda->isMacro() ? lambda : NULL; + } + } + } + } + return NULL; +} + +static malValuePtr macroExpand(malValuePtr obj, malEnvPtr env) +{ + while (const malLambda* macro = isMacroApplication(obj, env)) { + const malSequence* seq = STATIC_CAST(malSequence, obj); + obj = macro->apply(seq->begin() + 1, seq->end()); + } + return obj; +} + +static const char* malFunctionTable[] = { + "(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)))))))", + "(def! not (fn* (cond) (if cond false true)))", + "(def! load-file (fn* (filename) \ + (eval (read-string (str \"(do \" (slurp filename) \"\nnil)\")))))", + "(def! *host-language* \"C++\")", +}; + +static void installFunctions(malEnvPtr env) { + for (auto &function : malFunctionTable) { + rep(function, env); + } +} + +// Added to keep the linker happy at step A +malValuePtr readline(const String& prompt) +{ + String input; + if (s_readLine.get(prompt, input)) { + return mal::string(input); + } + return mal::nilValue(); +} + diff --git a/impls/cpp/tests/step5_tco.mal b/impls/cpp/tests/step5_tco.mal index f48fa336da..ba87380880 100644 --- a/impls/cpp/tests/step5_tco.mal +++ b/impls/cpp/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; C++: skipping non-TCO recursion -;; Reason: completes at 10,000, segfaults at 20,000 +;; C++: skipping non-TCO recursion +;; Reason: completes at 10,000, segfaults at 20,000 diff --git a/impls/crystal/Dockerfile b/impls/crystal/Dockerfile index 0d023752f4..29d19b9fb3 100644 --- a/impls/crystal/Dockerfile +++ b/impls/crystal/Dockerfile @@ -1,30 +1,30 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install g++ for any C/C++ based implementations -RUN apt-get -y install g++ - -# Crystal -RUN apt-get -y install apt-transport-https gnupg -RUN curl http://dist.crystal-lang.org/apt/setup.sh | bash -RUN apt-get -y install crystal +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install g++ for any C/C++ based implementations +RUN apt-get -y install g++ + +# Crystal +RUN apt-get -y install apt-transport-https gnupg +RUN curl http://dist.crystal-lang.org/apt/setup.sh | bash +RUN apt-get -y install crystal diff --git a/impls/crystal/Makefile b/impls/crystal/Makefile index 42739be52c..cf3f89c9c2 100644 --- a/impls/crystal/Makefile +++ b/impls/crystal/Makefile @@ -1,33 +1,33 @@ -STEPS = step0_repl.cr step1_read_print.cr step2_eval.cr step3_env.cr \ - step4_if_fn_do.cr step5_tco.cr step6_file.cr step7_quote.cr \ - step8_macros.cr step9_try.cr stepA_mal.cr - -STEP1_DEPS = $(STEP0_DEPS) reader.cr printer.cr -STEP2_DEPS = $(STEP1_DEPS) types.cr -STEP3_DEPS = $(STEP2_DEPS) env.cr -STEP4_DEPS = $(STEP3_DEPS) core.cr error.cr - -STEP_BINS = $(STEPS:%.cr=%) -LAST_STEP_BIN = $(word $(words $(STEP_BINS)),$(STEP_BINS)) - -all: $(STEP_BINS) - -dist: mal - -mal: $(LAST_STEP_BIN) - cp $< $@ - -$(STEP_BINS): %: %.cr - crystal build --release $< - -step0_repl: $(STEP0_DEPS) -step1_read_print: $(STEP1_DEPS) -step2_eval: $(STEP2_DEPS) -step3_env: $(STEP3_DEPS) -step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) - -clean: - rm -rf $(STEP_BINS) mal .crystal - -.PHONY: all clean - +STEPS = step0_repl.cr step1_read_print.cr step2_eval.cr step3_env.cr \ + step4_if_fn_do.cr step5_tco.cr step6_file.cr step7_quote.cr \ + step8_macros.cr step9_try.cr stepA_mal.cr + +STEP1_DEPS = $(STEP0_DEPS) reader.cr printer.cr +STEP2_DEPS = $(STEP1_DEPS) types.cr +STEP3_DEPS = $(STEP2_DEPS) env.cr +STEP4_DEPS = $(STEP3_DEPS) core.cr error.cr + +STEP_BINS = $(STEPS:%.cr=%) +LAST_STEP_BIN = $(word $(words $(STEP_BINS)),$(STEP_BINS)) + +all: $(STEP_BINS) + +dist: mal + +mal: $(LAST_STEP_BIN) + cp $< $@ + +$(STEP_BINS): %: %.cr + crystal build --release $< + +step0_repl: $(STEP0_DEPS) +step1_read_print: $(STEP1_DEPS) +step2_eval: $(STEP2_DEPS) +step3_env: $(STEP3_DEPS) +step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) + +clean: + rm -rf $(STEP_BINS) mal .crystal + +.PHONY: all clean + diff --git a/impls/crystal/core.cr b/impls/crystal/core.cr index 05c1fadee3..5537b3ccce 100644 --- a/impls/crystal/core.cr +++ b/impls/crystal/core.cr @@ -1,461 +1,461 @@ -require "time" - -require "readline" -require "./types" -require "./error" -require "./printer" -require "./reader" - -module Mal - macro calc_op(op) - -> (args : Array(Mal::Type)) { - x, y = args[0].unwrap, args[1].unwrap - eval_error "invalid arguments for binary operator {{op.id}}" unless x.is_a?(Int64) && y.is_a?(Int64) - Mal::Type.new(x {{op.id}} y) - } - end - - def self.list(args) - args.to_mal - end - - def self.list?(args) - args.first.unwrap.is_a? Mal::List - end - - def self.empty?(args) - a = args.first.unwrap - a.is_a?(Array) ? a.empty? : false - end - - def self.count(args) - a = args.first.unwrap - case a - when Array - a.size.to_i64 - when Nil - 0i64 - else - eval_error "invalid argument for function 'count'" - end - end - - def self.pr_str_(args) - args.map { |a| pr_str(a) }.join(" ") - end - - def self.str(args) - args.map { |a| pr_str(a, false) }.join - end - - def self.prn(args) - puts self.pr_str_(args) - nil - end - - def self.println(args) - puts args.map { |a| pr_str(a, false) }.join(" ") - nil - end - - def self.read_string(args) - head = args.first.unwrap - eval_error "argument of read-str must be string" unless head.is_a? String - read_str head - end - - def self.slurp(args) - head = args.first.unwrap - eval_error "argument of slurp must be string" unless head.is_a? String - begin - File.read head - rescue e : Errno - eval_error "no such file" - end - end - - def self.cons(args) - head, tail = args[0].as(Mal::Type), args[1].unwrap - eval_error "2nd arg of cons must be list" unless tail.is_a? Array - ([head] + tail).to_mal - end - - def self.concat(args) - args.each_with_object(Mal::List.new) do |arg, list| - a = arg.unwrap - eval_error "arguments of concat must be list" unless a.is_a?(Array) - a.each { |e| list << e } - end - end - - def self.vec(args) - arg = args.first.unwrap - arg.is_a? Array || eval_error "argument of vec must be a sequence" - arg.to_mal(Mal::Vector) - end - - def self.nth(args) - a0, a1 = args[0].unwrap, args[1].unwrap - eval_error "1st argument of nth must be list or vector" unless a0.is_a? Array - eval_error "2nd argument of nth must be integer" unless a1.is_a? Int64 - a0[a1] - end - - def self.first(args) - a0 = args[0].unwrap - - return nil if a0.nil? - eval_error "1st argument of first must be list or vector or nil" unless a0.is_a? Array - a0.empty? ? nil : a0.first - end - - def self.rest(args) - a0 = args[0].unwrap - - return Mal::List.new if a0.nil? - eval_error "1st argument of first must be list or vector or nil" unless a0.is_a? Array - return Mal::List.new if a0.empty? - a0[1..-1].to_mal - end - - def self.apply(args) - eval_error "apply must take at least 2 arguments" unless args.size >= 2 - - head = args.first.unwrap - last = args.last.unwrap - - eval_error "last argument of apply must be list or vector" unless last.is_a? Array - - case head - when Mal::Closure - head.fn.call(args[1..-2] + last) - when Mal::Func - head.call(args[1..-2] + last) - else - eval_error "1st argument of apply must be function or closure" - end - end - - def self.map(args) - func = args.first.unwrap - list = args[1].unwrap - - eval_error "2nd argument of map must be list or vector" unless list.is_a? Array - - f = case func - when Mal::Closure then func.fn - when Mal::Func then func - else eval_error "1st argument of map must be function" - end - - list.each_with_object(Mal::List.new) do |elem, mapped| - mapped << f.call([elem]) - end - end - - def self.nil_value?(args) - args.first.unwrap.nil? - end - - def self.true?(args) - a = args.first.unwrap - a.is_a?(Bool) && a - end - - def self.false?(args) - a = args.first.unwrap - a.is_a?(Bool) && !a - end - - def self.symbol?(args) - args.first.unwrap.is_a?(Mal::Symbol) - end - - def self.symbol(args) - head = args.first.unwrap - eval_error "1st argument of symbol function must be string" unless head.is_a? String - Mal::Symbol.new head - end - - def self.string?(args) - head = args.first.unwrap - head.is_a?(String) && (head.empty? || head[0] != '\u029e') - end - - def self.keyword(args) - head = args.first.unwrap - eval_error "1st argument of symbol function must be string" unless head.is_a? String - "\u029e" + head - end - - def self.keyword?(args) - head = args.first.unwrap - head.is_a?(String) && !head.empty? && head[0] == '\u029e' - end - - def self.number?(args) - args.first.unwrap.is_a?(Int64) - end - - def self.fn?(args) - return false if args.first.macro? - head = args.first.unwrap - head.is_a?(Mal::Func) || head.is_a?(Mal::Closure) - end - - def self.macro?(args) - args.first.macro? - end - - def self.vector(args) - args.to_mal(Mal::Vector) - end - - def self.vector?(args) - args.first.unwrap.is_a? Mal::Vector - end - - def self.hash_map(args) - eval_error "hash-map must take even number of arguments" unless args.size.even? - map = Mal::HashMap.new - args.each_slice(2) do |kv| - k = kv[0].unwrap - eval_error "key must be string" unless k.is_a? String - map[k] = kv[1] - end - map - end - - def self.map?(args) - args.first.unwrap.is_a? Mal::HashMap - end - - def self.assoc(args) - head = args.first.unwrap - eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap - eval_error "assoc must take a list and even number of arguments" unless (args.size - 1).even? - - map = Mal::HashMap.new - head.each { |k, v| map[k] = v } - - args[1..-1].each_slice(2) do |kv| - k = kv[0].unwrap - eval_error "key must be string" unless k.is_a? String - map[k] = kv[1] - end - - map - end - - def self.dissoc(args) - head = args.first.unwrap - eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap - - map = Mal::HashMap.new - head.each { |k, v| map[k] = v } - - args[1..-1].each do |arg| - key = arg.unwrap - eval_error "key must be string" unless key.is_a? String - map.delete key - end - - map - end - - def self.get(args) - a0, a1 = args[0].unwrap, args[1].unwrap - return nil unless a0.is_a? Mal::HashMap - eval_error "2nd argument of get must be string" unless a1.is_a? String - - # a0[a1]? isn't available because type ofa0[a1] is infered NoReturn - a0.has_key?(a1) ? a0[a1] : nil - end - - def self.contains?(args) - a0, a1 = args[0].unwrap, args[1].unwrap - eval_error "1st argument of get must be hashmap" unless a0.is_a? Mal::HashMap - eval_error "2nd argument of get must be string" unless a1.is_a? String - a0.has_key? a1 - end - - def self.keys(args) - head = args.first.unwrap - eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap - head.keys.each_with_object(Mal::List.new) { |e, l| l << Mal::Type.new(e) } - end - - def self.vals(args) - head = args.first.unwrap - eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap - head.values.to_mal - end - - def self.sequential?(args) - args.first.unwrap.is_a? Array - end - - def self.readline(args) - head = args.first.unwrap - eval_error "1st argument of readline must be string" unless head.is_a? String - Readline.readline(head, true) - end - - def self.meta(args) - m = args.first.meta - m.nil? ? nil : m - end - - def self.with_meta(args) - t = args.first.dup - t.meta = args[1] - t - end - - def self.atom(args) - Mal::Atom.new args.first - end - - def self.atom?(args) - args.first.unwrap.is_a? Mal::Atom - end - - def self.deref(args) - head = args.first.unwrap - eval_error "1st argument of deref must be atom" unless head.is_a? Mal::Atom - head.val - end - - def self.reset!(args) - head = args.first.unwrap - eval_error "1st argument of reset! must be atom" unless head.is_a? Mal::Atom - head.val = args[1] - end - - def self.swap!(args) - atom = args.first.unwrap - eval_error "1st argument of swap! must be atom" unless atom.is_a? Mal::Atom - - a = [atom.val] + args[2..-1] - - func = args[1].unwrap - case func - when Mal::Func - atom.val = func.call a - when Mal::Closure - atom.val = func.fn.call a - else - eval_error "2nd argumetn of swap! must be function" - end - end - - def self.conj(args) - seq = args.first.unwrap - case seq - when Mal::List - (args[1..-1].reverse + seq).to_mal - when Mal::Vector - (seq + args[1..-1]).to_mal(Mal::Vector) - else - eval_error "1st argument of conj must be list or vector" - end - end - - def self.seq(args) - obj = args.first.unwrap - case obj - when nil - nil - when Mal::List - return nil if obj.empty? - obj - when Mal::Vector - return nil if obj.empty? - obj.to_mal - when String - return nil if obj.empty? - obj.split("").each_with_object(Mal::List.new) { |e, l| l << Mal::Type.new(e) } - else - eval_error "argument of seq must be list or vector or string or nil" - end - end - - def self.time_ms(args) - Time.now.epoch_ms.to_i64 - end - - # Note: - # Simply using ->self.some_func doesn't work - macro func(name) - -> (args : Array(Mal::Type)) { Mal::Type.new self.{{name.id}}(args) } - end - - macro rel_op(op) - -> (args : Array(Mal::Type)) { Mal::Type.new (args[0] {{op.id}} args[1]) } - end - - NS = { - "+" => calc_op(:+), - "-" => calc_op(:-), - "*" => calc_op(:*), - "/" => calc_op(:/), - "list" => func(:list), - "list?" => func(:list?), - "empty?" => func(:empty?), - "count" => func(:count), - "=" => rel_op(:==), - "<" => rel_op(:<), - ">" => rel_op(:>), - "<=" => rel_op(:<=), - ">=" => rel_op(:>=), - "pr-str" => func(:pr_str_), - "str" => func(:str), - "prn" => func(:prn), - "println" => func(:println), - "read-string" => func(:read_string), - "slurp" => func(:slurp), - "cons" => func(:cons), - "concat" => func(:concat), - "vec" => func(:vec), - "nth" => func(:nth), - "first" => func(:first), - "rest" => func(:rest), - "throw" => ->(args : Array(Mal::Type)) { raise Mal::RuntimeException.new args[0] }, - "apply" => func(:apply), - "map" => func(:map), - "nil?" => func(:nil_value?), - "true?" => func(:true?), - "false?" => func(:false?), - "symbol?" => func(:symbol?), - "symbol" => func(:symbol), - "string?" => func(:string?), - "keyword" => func(:keyword), - "keyword?" => func(:keyword?), - "number?" => func(:number?), - "fn?" => func(:fn?), - "macro?" => func(:macro?), - "vector" => func(:vector), - "vector?" => func(:vector?), - "hash-map" => func(:hash_map), - "map?" => func(:map?), - "assoc" => func(:assoc), - "dissoc" => func(:dissoc), - "get" => func(:get), - "contains?" => func(:contains?), - "keys" => func(:keys), - "vals" => func(:vals), - "sequential?" => func(:sequential?), - "readline" => func(:readline), - "meta" => func(:meta), - "with-meta" => func(:with_meta), - "atom" => func(:atom), - "atom?" => func(:atom?), - "deref" => func(:deref), - "deref" => func(:deref), - "reset!" => func(:reset!), - "swap!" => func(:swap!), - "conj" => func(:conj), - "seq" => func(:seq), - "time-ms" => func(:time_ms), - } of String => Mal::Func -end +require "time" + +require "readline" +require "./types" +require "./error" +require "./printer" +require "./reader" + +module Mal + macro calc_op(op) + -> (args : Array(Mal::Type)) { + x, y = args[0].unwrap, args[1].unwrap + eval_error "invalid arguments for binary operator {{op.id}}" unless x.is_a?(Int64) && y.is_a?(Int64) + Mal::Type.new(x {{op.id}} y) + } + end + + def self.list(args) + args.to_mal + end + + def self.list?(args) + args.first.unwrap.is_a? Mal::List + end + + def self.empty?(args) + a = args.first.unwrap + a.is_a?(Array) ? a.empty? : false + end + + def self.count(args) + a = args.first.unwrap + case a + when Array + a.size.to_i64 + when Nil + 0i64 + else + eval_error "invalid argument for function 'count'" + end + end + + def self.pr_str_(args) + args.map { |a| pr_str(a) }.join(" ") + end + + def self.str(args) + args.map { |a| pr_str(a, false) }.join + end + + def self.prn(args) + puts self.pr_str_(args) + nil + end + + def self.println(args) + puts args.map { |a| pr_str(a, false) }.join(" ") + nil + end + + def self.read_string(args) + head = args.first.unwrap + eval_error "argument of read-str must be string" unless head.is_a? String + read_str head + end + + def self.slurp(args) + head = args.first.unwrap + eval_error "argument of slurp must be string" unless head.is_a? String + begin + File.read head + rescue e : Errno + eval_error "no such file" + end + end + + def self.cons(args) + head, tail = args[0].as(Mal::Type), args[1].unwrap + eval_error "2nd arg of cons must be list" unless tail.is_a? Array + ([head] + tail).to_mal + end + + def self.concat(args) + args.each_with_object(Mal::List.new) do |arg, list| + a = arg.unwrap + eval_error "arguments of concat must be list" unless a.is_a?(Array) + a.each { |e| list << e } + end + end + + def self.vec(args) + arg = args.first.unwrap + arg.is_a? Array || eval_error "argument of vec must be a sequence" + arg.to_mal(Mal::Vector) + end + + def self.nth(args) + a0, a1 = args[0].unwrap, args[1].unwrap + eval_error "1st argument of nth must be list or vector" unless a0.is_a? Array + eval_error "2nd argument of nth must be integer" unless a1.is_a? Int64 + a0[a1] + end + + def self.first(args) + a0 = args[0].unwrap + + return nil if a0.nil? + eval_error "1st argument of first must be list or vector or nil" unless a0.is_a? Array + a0.empty? ? nil : a0.first + end + + def self.rest(args) + a0 = args[0].unwrap + + return Mal::List.new if a0.nil? + eval_error "1st argument of first must be list or vector or nil" unless a0.is_a? Array + return Mal::List.new if a0.empty? + a0[1..-1].to_mal + end + + def self.apply(args) + eval_error "apply must take at least 2 arguments" unless args.size >= 2 + + head = args.first.unwrap + last = args.last.unwrap + + eval_error "last argument of apply must be list or vector" unless last.is_a? Array + + case head + when Mal::Closure + head.fn.call(args[1..-2] + last) + when Mal::Func + head.call(args[1..-2] + last) + else + eval_error "1st argument of apply must be function or closure" + end + end + + def self.map(args) + func = args.first.unwrap + list = args[1].unwrap + + eval_error "2nd argument of map must be list or vector" unless list.is_a? Array + + f = case func + when Mal::Closure then func.fn + when Mal::Func then func + else eval_error "1st argument of map must be function" + end + + list.each_with_object(Mal::List.new) do |elem, mapped| + mapped << f.call([elem]) + end + end + + def self.nil_value?(args) + args.first.unwrap.nil? + end + + def self.true?(args) + a = args.first.unwrap + a.is_a?(Bool) && a + end + + def self.false?(args) + a = args.first.unwrap + a.is_a?(Bool) && !a + end + + def self.symbol?(args) + args.first.unwrap.is_a?(Mal::Symbol) + end + + def self.symbol(args) + head = args.first.unwrap + eval_error "1st argument of symbol function must be string" unless head.is_a? String + Mal::Symbol.new head + end + + def self.string?(args) + head = args.first.unwrap + head.is_a?(String) && (head.empty? || head[0] != '\u029e') + end + + def self.keyword(args) + head = args.first.unwrap + eval_error "1st argument of symbol function must be string" unless head.is_a? String + "\u029e" + head + end + + def self.keyword?(args) + head = args.first.unwrap + head.is_a?(String) && !head.empty? && head[0] == '\u029e' + end + + def self.number?(args) + args.first.unwrap.is_a?(Int64) + end + + def self.fn?(args) + return false if args.first.macro? + head = args.first.unwrap + head.is_a?(Mal::Func) || head.is_a?(Mal::Closure) + end + + def self.macro?(args) + args.first.macro? + end + + def self.vector(args) + args.to_mal(Mal::Vector) + end + + def self.vector?(args) + args.first.unwrap.is_a? Mal::Vector + end + + def self.hash_map(args) + eval_error "hash-map must take even number of arguments" unless args.size.even? + map = Mal::HashMap.new + args.each_slice(2) do |kv| + k = kv[0].unwrap + eval_error "key must be string" unless k.is_a? String + map[k] = kv[1] + end + map + end + + def self.map?(args) + args.first.unwrap.is_a? Mal::HashMap + end + + def self.assoc(args) + head = args.first.unwrap + eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap + eval_error "assoc must take a list and even number of arguments" unless (args.size - 1).even? + + map = Mal::HashMap.new + head.each { |k, v| map[k] = v } + + args[1..-1].each_slice(2) do |kv| + k = kv[0].unwrap + eval_error "key must be string" unless k.is_a? String + map[k] = kv[1] + end + + map + end + + def self.dissoc(args) + head = args.first.unwrap + eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap + + map = Mal::HashMap.new + head.each { |k, v| map[k] = v } + + args[1..-1].each do |arg| + key = arg.unwrap + eval_error "key must be string" unless key.is_a? String + map.delete key + end + + map + end + + def self.get(args) + a0, a1 = args[0].unwrap, args[1].unwrap + return nil unless a0.is_a? Mal::HashMap + eval_error "2nd argument of get must be string" unless a1.is_a? String + + # a0[a1]? isn't available because type ofa0[a1] is infered NoReturn + a0.has_key?(a1) ? a0[a1] : nil + end + + def self.contains?(args) + a0, a1 = args[0].unwrap, args[1].unwrap + eval_error "1st argument of get must be hashmap" unless a0.is_a? Mal::HashMap + eval_error "2nd argument of get must be string" unless a1.is_a? String + a0.has_key? a1 + end + + def self.keys(args) + head = args.first.unwrap + eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap + head.keys.each_with_object(Mal::List.new) { |e, l| l << Mal::Type.new(e) } + end + + def self.vals(args) + head = args.first.unwrap + eval_error "1st argument of assoc must be hashmap" unless head.is_a? Mal::HashMap + head.values.to_mal + end + + def self.sequential?(args) + args.first.unwrap.is_a? Array + end + + def self.readline(args) + head = args.first.unwrap + eval_error "1st argument of readline must be string" unless head.is_a? String + Readline.readline(head, true) + end + + def self.meta(args) + m = args.first.meta + m.nil? ? nil : m + end + + def self.with_meta(args) + t = args.first.dup + t.meta = args[1] + t + end + + def self.atom(args) + Mal::Atom.new args.first + end + + def self.atom?(args) + args.first.unwrap.is_a? Mal::Atom + end + + def self.deref(args) + head = args.first.unwrap + eval_error "1st argument of deref must be atom" unless head.is_a? Mal::Atom + head.val + end + + def self.reset!(args) + head = args.first.unwrap + eval_error "1st argument of reset! must be atom" unless head.is_a? Mal::Atom + head.val = args[1] + end + + def self.swap!(args) + atom = args.first.unwrap + eval_error "1st argument of swap! must be atom" unless atom.is_a? Mal::Atom + + a = [atom.val] + args[2..-1] + + func = args[1].unwrap + case func + when Mal::Func + atom.val = func.call a + when Mal::Closure + atom.val = func.fn.call a + else + eval_error "2nd argumetn of swap! must be function" + end + end + + def self.conj(args) + seq = args.first.unwrap + case seq + when Mal::List + (args[1..-1].reverse + seq).to_mal + when Mal::Vector + (seq + args[1..-1]).to_mal(Mal::Vector) + else + eval_error "1st argument of conj must be list or vector" + end + end + + def self.seq(args) + obj = args.first.unwrap + case obj + when nil + nil + when Mal::List + return nil if obj.empty? + obj + when Mal::Vector + return nil if obj.empty? + obj.to_mal + when String + return nil if obj.empty? + obj.split("").each_with_object(Mal::List.new) { |e, l| l << Mal::Type.new(e) } + else + eval_error "argument of seq must be list or vector or string or nil" + end + end + + def self.time_ms(args) + Time.now.epoch_ms.to_i64 + end + + # Note: + # Simply using ->self.some_func doesn't work + macro func(name) + -> (args : Array(Mal::Type)) { Mal::Type.new self.{{name.id}}(args) } + end + + macro rel_op(op) + -> (args : Array(Mal::Type)) { Mal::Type.new (args[0] {{op.id}} args[1]) } + end + + NS = { + "+" => calc_op(:+), + "-" => calc_op(:-), + "*" => calc_op(:*), + "/" => calc_op(:/), + "list" => func(:list), + "list?" => func(:list?), + "empty?" => func(:empty?), + "count" => func(:count), + "=" => rel_op(:==), + "<" => rel_op(:<), + ">" => rel_op(:>), + "<=" => rel_op(:<=), + ">=" => rel_op(:>=), + "pr-str" => func(:pr_str_), + "str" => func(:str), + "prn" => func(:prn), + "println" => func(:println), + "read-string" => func(:read_string), + "slurp" => func(:slurp), + "cons" => func(:cons), + "concat" => func(:concat), + "vec" => func(:vec), + "nth" => func(:nth), + "first" => func(:first), + "rest" => func(:rest), + "throw" => ->(args : Array(Mal::Type)) { raise Mal::RuntimeException.new args[0] }, + "apply" => func(:apply), + "map" => func(:map), + "nil?" => func(:nil_value?), + "true?" => func(:true?), + "false?" => func(:false?), + "symbol?" => func(:symbol?), + "symbol" => func(:symbol), + "string?" => func(:string?), + "keyword" => func(:keyword), + "keyword?" => func(:keyword?), + "number?" => func(:number?), + "fn?" => func(:fn?), + "macro?" => func(:macro?), + "vector" => func(:vector), + "vector?" => func(:vector?), + "hash-map" => func(:hash_map), + "map?" => func(:map?), + "assoc" => func(:assoc), + "dissoc" => func(:dissoc), + "get" => func(:get), + "contains?" => func(:contains?), + "keys" => func(:keys), + "vals" => func(:vals), + "sequential?" => func(:sequential?), + "readline" => func(:readline), + "meta" => func(:meta), + "with-meta" => func(:with_meta), + "atom" => func(:atom), + "atom?" => func(:atom?), + "deref" => func(:deref), + "deref" => func(:deref), + "reset!" => func(:reset!), + "swap!" => func(:swap!), + "conj" => func(:conj), + "seq" => func(:seq), + "time-ms" => func(:time_ms), + } of String => Mal::Func +end diff --git a/impls/crystal/env.cr b/impls/crystal/env.cr index 9c7a46253a..5c763dc5dd 100644 --- a/impls/crystal/env.cr +++ b/impls/crystal/env.cr @@ -1,66 +1,66 @@ -require "./types" -require "./error" - -module Mal - class Env - property data - - def initialize(@outer : Env?) - @data = {} of String => Mal::Type - end - - def initialize(@outer : Env, binds, exprs : Array(Mal::Type)) - @data = {} of String => Mal::Type - - eval_error "binds must be list or vector" unless binds.is_a? Array - - # Note: - # Array#zip() can't be used because overload resolution failed - (0...binds.size).each do |idx| - sym = binds[idx].unwrap - eval_error "bind name must be symbol" unless sym.is_a? Mal::Symbol - - if sym.str == "&" - eval_error "missing variable parameter name" if binds.size == idx - next_param = binds[idx + 1].unwrap - eval_error "bind name must be symbol" unless next_param.is_a? Mal::Symbol - var_args = Mal::List.new - exprs[idx..-1].each { |e| var_args << e } if idx < exprs.size - @data[next_param.str] = Mal::Type.new var_args - break - end - - @data[sym.str] = exprs[idx] - end - end - - def dump - puts "ENV BEGIN".colorize.red - @data.each do |k, v| - puts " #{k} -> #{print(v)}".colorize.red - end - puts "ENV END".colorize.red - end - - def set(key, value) - @data[key] = value - end - - def find(key) - return self if @data.has_key? key - - o = @outer - if o - o.find key - else - nil - end - end - - def get(key) - e = find key - eval_error "'#{key}' not found" unless e - e.data[key] - end - end -end +require "./types" +require "./error" + +module Mal + class Env + property data + + def initialize(@outer : Env?) + @data = {} of String => Mal::Type + end + + def initialize(@outer : Env, binds, exprs : Array(Mal::Type)) + @data = {} of String => Mal::Type + + eval_error "binds must be list or vector" unless binds.is_a? Array + + # Note: + # Array#zip() can't be used because overload resolution failed + (0...binds.size).each do |idx| + sym = binds[idx].unwrap + eval_error "bind name must be symbol" unless sym.is_a? Mal::Symbol + + if sym.str == "&" + eval_error "missing variable parameter name" if binds.size == idx + next_param = binds[idx + 1].unwrap + eval_error "bind name must be symbol" unless next_param.is_a? Mal::Symbol + var_args = Mal::List.new + exprs[idx..-1].each { |e| var_args << e } if idx < exprs.size + @data[next_param.str] = Mal::Type.new var_args + break + end + + @data[sym.str] = exprs[idx] + end + end + + def dump + puts "ENV BEGIN".colorize.red + @data.each do |k, v| + puts " #{k} -> #{print(v)}".colorize.red + end + puts "ENV END".colorize.red + end + + def set(key, value) + @data[key] = value + end + + def find(key) + return self if @data.has_key? key + + o = @outer + if o + o.find key + else + nil + end + end + + def get(key) + e = find key + eval_error "'#{key}' not found" unless e + e.data[key] + end + end +end diff --git a/impls/crystal/error.cr b/impls/crystal/error.cr index fb8f56c623..4958b6a25a 100644 --- a/impls/crystal/error.cr +++ b/impls/crystal/error.cr @@ -1,25 +1,25 @@ -require "./types" - -module Mal - class ParseException < Exception - end - - class EvalException < Exception - end - - class RuntimeException < Exception - getter :thrown - - def initialize(@thrown : Type) - super() - end - end -end - -def eval_error(msg) - raise Mal::EvalException.new msg -end - -def parse_error(msg) - raise Mal::ParseException.new msg -end +require "./types" + +module Mal + class ParseException < Exception + end + + class EvalException < Exception + end + + class RuntimeException < Exception + getter :thrown + + def initialize(@thrown : Type) + super() + end + end +end + +def eval_error(msg) + raise Mal::EvalException.new msg +end + +def parse_error(msg) + raise Mal::ParseException.new msg +end diff --git a/impls/crystal/printer.cr b/impls/crystal/printer.cr index b6aeaab4fd..1883f52f0a 100644 --- a/impls/crystal/printer.cr +++ b/impls/crystal/printer.cr @@ -1,34 +1,34 @@ -require "./types" - -def pr_str(value, print_readably = true) - case value - when Nil then "nil" - when Bool then value.to_s - when Int64 then value.to_s - when Mal::List then "(#{value.map { |v| pr_str(v, print_readably).as(String) }.join(" ")})" - when Mal::Vector then "[#{value.map { |v| pr_str(v, print_readably).as(String) }.join(" ")}]" - when Mal::Symbol then value.str.to_s - when Mal::Func then "" - when Mal::Closure then "" - when Mal::HashMap - # step1_read_print.cr requires specifying type - "{#{value.map { |k, v| "#{pr_str(k, print_readably)} #{pr_str(v, print_readably)}".as(String) }.join(" ")}}" - when String - case - when value.empty? - print_readably ? value.inspect : value - when value[0] == '\u029e' - ":#{value[1..-1]}" - else - print_readably ? value.inspect : value - end - when Mal::Atom - "(atom #{pr_str(value.val, print_readably)})" - else - raise "invalid MalType: #{value.to_s}" - end -end - -def pr_str(t : Mal::Type, print_readably = true) - pr_str(t.unwrap, print_readably) + (t.macro? ? " (macro)" : "") -end +require "./types" + +def pr_str(value, print_readably = true) + case value + when Nil then "nil" + when Bool then value.to_s + when Int64 then value.to_s + when Mal::List then "(#{value.map { |v| pr_str(v, print_readably).as(String) }.join(" ")})" + when Mal::Vector then "[#{value.map { |v| pr_str(v, print_readably).as(String) }.join(" ")}]" + when Mal::Symbol then value.str.to_s + when Mal::Func then "" + when Mal::Closure then "" + when Mal::HashMap + # step1_read_print.cr requires specifying type + "{#{value.map { |k, v| "#{pr_str(k, print_readably)} #{pr_str(v, print_readably)}".as(String) }.join(" ")}}" + when String + case + when value.empty? + print_readably ? value.inspect : value + when value[0] == '\u029e' + ":#{value[1..-1]}" + else + print_readably ? value.inspect : value + end + when Mal::Atom + "(atom #{pr_str(value.val, print_readably)})" + else + raise "invalid MalType: #{value.to_s}" + end +end + +def pr_str(t : Mal::Type, print_readably = true) + pr_str(t.unwrap, print_readably) + (t.macro? ? " (macro)" : "") +end diff --git a/impls/crystal/reader.cr b/impls/crystal/reader.cr index dd7d62f56e..f7f2e6c3eb 100644 --- a/impls/crystal/reader.cr +++ b/impls/crystal/reader.cr @@ -1,139 +1,139 @@ -require "./types" -require "./error" - -class Reader - def initialize(@tokens : Array(String)) - @pos = 0 - end - - def current_token - @tokens[@pos] rescue nil - end - - def peek - t = current_token - - if t && t[0] == ';' - @pos += 1 - peek - else - t - end - end - - def next - peek - ensure - @pos += 1 - end - - def read_sequence(init, open, close) - token = self.next - parse_error "expected '#{open}', got EOF" unless token - parse_error "expected '#{open}', got #{token}" unless token[0] == open - - loop do - token = peek - parse_error "expected '#{close}', got EOF" unless token - break if token[0] == close - - init << read_form - peek - end - - self.next - init - end - - def read_list - Mal::Type.new read_sequence(Mal::List.new, '(', ')') - end - - def read_vector - Mal::Type.new read_sequence(Mal::Vector.new, '[', ']') - end - - def read_hashmap - types = read_sequence([] of Mal::Type, '{', '}') - - parse_error "odd number of elements for hash-map: #{types.size}" if types.size.odd? - map = Mal::HashMap.new - - types.each_slice(2) do |kv| - k, v = kv[0].unwrap, kv[1] - case k - when String - map[k] = v - else - parse_error("key of hash-map must be string or keyword") - end - end - - Mal::Type.new map - end - - def read_atom - token = self.next - parse_error "expected Atom but got EOF" unless token - - Mal::Type.new case - when token =~ /^-?\d+$/ then token.to_i64 - when token == "true" then true - when token == "false" then false - when token == "nil" then nil - when token =~ /^"(?:\\.|[^\\"])*"$/ - token[1..-2].gsub(/\\(.)/, {"\\\"" => "\"", - "\\n" => "\n", - "\\\\" => "\\"}) - when token[0] == '"' then parse_error "expected '\"', got EOF" - when token[0] == ':' then "\u029e#{token[1..-1]}" - else Mal::Symbol.new token - end - end - - def list_of(symname) - Mal::List.new << gen_type(Mal::Symbol, symname) << read_form - end - - def read_form - token = peek - - parse_error "unexpected EOF" unless token - parse_error "unexpected comment" if token[0] == ';' - - Mal::Type.new case token - when "(" then read_list - when ")" then parse_error "unexpected ')'" - when "[" then read_vector - when "]" then parse_error "unexpected ']'" - when "{" then read_hashmap - when "}" then parse_error "unexpected '}'" - when "'" then self.next; list_of("quote") - when "`" then self.next; list_of("quasiquote") - when "~" then self.next; list_of("unquote") - when "~@" then self.next; list_of("splice-unquote") - when "@" then self.next; list_of("deref") - when "^" - self.next - meta = read_form - list_of("with-meta") << meta - else read_atom - end - end -end - -def tokenize(str) - regex = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ - str.scan(regex).map { |m| m[1] }.reject(&.empty?) -end - -def read_str(str) - r = Reader.new(tokenize(str)) - begin - r.read_form - ensure - unless r.peek.nil? - raise Mal::ParseException.new "expected EOF, got #{r.peek.to_s}" - end - end -end +require "./types" +require "./error" + +class Reader + def initialize(@tokens : Array(String)) + @pos = 0 + end + + def current_token + @tokens[@pos] rescue nil + end + + def peek + t = current_token + + if t && t[0] == ';' + @pos += 1 + peek + else + t + end + end + + def next + peek + ensure + @pos += 1 + end + + def read_sequence(init, open, close) + token = self.next + parse_error "expected '#{open}', got EOF" unless token + parse_error "expected '#{open}', got #{token}" unless token[0] == open + + loop do + token = peek + parse_error "expected '#{close}', got EOF" unless token + break if token[0] == close + + init << read_form + peek + end + + self.next + init + end + + def read_list + Mal::Type.new read_sequence(Mal::List.new, '(', ')') + end + + def read_vector + Mal::Type.new read_sequence(Mal::Vector.new, '[', ']') + end + + def read_hashmap + types = read_sequence([] of Mal::Type, '{', '}') + + parse_error "odd number of elements for hash-map: #{types.size}" if types.size.odd? + map = Mal::HashMap.new + + types.each_slice(2) do |kv| + k, v = kv[0].unwrap, kv[1] + case k + when String + map[k] = v + else + parse_error("key of hash-map must be string or keyword") + end + end + + Mal::Type.new map + end + + def read_atom + token = self.next + parse_error "expected Atom but got EOF" unless token + + Mal::Type.new case + when token =~ /^-?\d+$/ then token.to_i64 + when token == "true" then true + when token == "false" then false + when token == "nil" then nil + when token =~ /^"(?:\\.|[^\\"])*"$/ + token[1..-2].gsub(/\\(.)/, {"\\\"" => "\"", + "\\n" => "\n", + "\\\\" => "\\"}) + when token[0] == '"' then parse_error "expected '\"', got EOF" + when token[0] == ':' then "\u029e#{token[1..-1]}" + else Mal::Symbol.new token + end + end + + def list_of(symname) + Mal::List.new << gen_type(Mal::Symbol, symname) << read_form + end + + def read_form + token = peek + + parse_error "unexpected EOF" unless token + parse_error "unexpected comment" if token[0] == ';' + + Mal::Type.new case token + when "(" then read_list + when ")" then parse_error "unexpected ')'" + when "[" then read_vector + when "]" then parse_error "unexpected ']'" + when "{" then read_hashmap + when "}" then parse_error "unexpected '}'" + when "'" then self.next; list_of("quote") + when "`" then self.next; list_of("quasiquote") + when "~" then self.next; list_of("unquote") + when "~@" then self.next; list_of("splice-unquote") + when "@" then self.next; list_of("deref") + when "^" + self.next + meta = read_form + list_of("with-meta") << meta + else read_atom + end + end +end + +def tokenize(str) + regex = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ + str.scan(regex).map { |m| m[1] }.reject(&.empty?) +end + +def read_str(str) + r = Reader.new(tokenize(str)) + begin + r.read_form + ensure + unless r.peek.nil? + raise Mal::ParseException.new "expected EOF, got #{r.peek.to_s}" + end + end +end diff --git a/impls/crystal/run b/impls/crystal/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/crystal/run +++ b/impls/crystal/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/crystal/step0_repl.cr b/impls/crystal/step0_repl.cr index a9c67d68f2..24332c4f9b 100755 --- a/impls/crystal/step0_repl.cr +++ b/impls/crystal/step0_repl.cr @@ -1,26 +1,26 @@ -#! /usr/bin/env crystal run - -require "readline" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -def read(x) - x -end - -def eval(x) - x -end - -def print(x) - x -end - -def rep(x) - read(eval(print(x))) -end - -while line = Readline.readline("user> ") - puts rep(line) -end +#! /usr/bin/env crystal run + +require "readline" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +def read(x) + x +end + +def eval(x) + x +end + +def print(x) + x +end + +def rep(x) + read(eval(print(x))) +end + +while line = Readline.readline("user> ") + puts rep(line) +end diff --git a/impls/crystal/step1_read_print.cr b/impls/crystal/step1_read_print.cr index 4d7195895e..018564b695 100755 --- a/impls/crystal/step1_read_print.cr +++ b/impls/crystal/step1_read_print.cr @@ -1,38 +1,38 @@ -#! /usr/bin/env crystal run - -require "readline" -require "./reader" -require "./printer" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -module Mal - extend self - - def read(str) - read_str str - end - - def eval(x) - x - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str))) - end -end - -while line = Readline.readline("user> ", true) - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "readline" +require "./reader" +require "./printer" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +module Mal + extend self + + def read(str) + read_str str + end + + def eval(x) + x + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str))) + end +end + +while line = Readline.readline("user> ", true) + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/step2_eval.cr b/impls/crystal/step2_eval.cr index fd441d33a6..ee500ce0ba 100755 --- a/impls/crystal/step2_eval.cr +++ b/impls/crystal/step2_eval.cr @@ -1,97 +1,97 @@ -#! /usr/bin/env crystal run - -require "readline" -require "./reader" -require "./printer" -require "./types" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -module Mal - extend self - - def eval_error(msg) - raise Mal::EvalException.new msg - end - - def num_func(func) - ->(args : Array(Mal::Type)) { - x, y = args[0].unwrap, args[1].unwrap - eval_error "invalid arguments" unless x.is_a?(Int64) && y.is_a?(Int64) - Mal::Type.new func.call(x, y) - } - end - - def eval_ast(a, env) - return a.map { |n| eval(n, env).as(Mal::Type) } if a.is_a? Mal::List - return a unless a - - ast = a.unwrap - case ast - when Mal::Symbol - if env.has_key? ast.str - env[ast.str] - else - eval_error "'#{ast.str}' not found" - end - when Mal::List - ast.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } - when Mal::Vector - ast.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } - when Mal::HashMap - ast.each { |k, v| ast[k] = eval(v, env) } - ast - else - ast - end - end - - def read(str) - read_str str - end - - def eval(t, env) - Mal::Type.new case ast = t.unwrap - when Mal::List - return gen_type Mal::List if ast.empty? - - f = eval_ast(ast.first, env) - ast.shift(1) - args = eval_ast(ast, env) - - if f.is_a?(Mal::Func) - f.call(args) - else - eval_error "expected function symbol as the first symbol of list" - end - else - eval_ast(t, env) - end - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str), REPL_ENV)) - end -end - -REPL_ENV = { - "+" => Mal.num_func(->(x : Int64, y : Int64) { x + y }), - "-" => Mal.num_func(->(x : Int64, y : Int64) { x - y }), - "*" => Mal.num_func(->(x : Int64, y : Int64) { x * y }), - "/" => Mal.num_func(->(x : Int64, y : Int64) { x / y }), -} of String => Mal::Func - -while line = Readline.readline("user> ", true) - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "readline" +require "./reader" +require "./printer" +require "./types" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +module Mal + extend self + + def eval_error(msg) + raise Mal::EvalException.new msg + end + + def num_func(func) + ->(args : Array(Mal::Type)) { + x, y = args[0].unwrap, args[1].unwrap + eval_error "invalid arguments" unless x.is_a?(Int64) && y.is_a?(Int64) + Mal::Type.new func.call(x, y) + } + end + + def eval_ast(a, env) + return a.map { |n| eval(n, env).as(Mal::Type) } if a.is_a? Mal::List + return a unless a + + ast = a.unwrap + case ast + when Mal::Symbol + if env.has_key? ast.str + env[ast.str] + else + eval_error "'#{ast.str}' not found" + end + when Mal::List + ast.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } + when Mal::Vector + ast.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } + when Mal::HashMap + ast.each { |k, v| ast[k] = eval(v, env) } + ast + else + ast + end + end + + def read(str) + read_str str + end + + def eval(t, env) + Mal::Type.new case ast = t.unwrap + when Mal::List + return gen_type Mal::List if ast.empty? + + f = eval_ast(ast.first, env) + ast.shift(1) + args = eval_ast(ast, env) + + if f.is_a?(Mal::Func) + f.call(args) + else + eval_error "expected function symbol as the first symbol of list" + end + else + eval_ast(t, env) + end + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str), REPL_ENV)) + end +end + +REPL_ENV = { + "+" => Mal.num_func(->(x : Int64, y : Int64) { x + y }), + "-" => Mal.num_func(->(x : Int64, y : Int64) { x - y }), + "*" => Mal.num_func(->(x : Int64, y : Int64) { x * y }), + "/" => Mal.num_func(->(x : Int64, y : Int64) { x / y }), +} of String => Mal::Func + +while line = Readline.readline("user> ", true) + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/step3_env.cr b/impls/crystal/step3_env.cr index a740080439..e28610af12 100755 --- a/impls/crystal/step3_env.cr +++ b/impls/crystal/step3_env.cr @@ -1,120 +1,120 @@ -#! /usr/bin/env crystal run - -require "readline" -require "./reader" -require "./printer" -require "./types" -require "./env" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -def eval_error(msg) - raise Mal::EvalException.new msg -end - -def num_func(func) - ->(args : Array(Mal::Type)) { - x, y = args[0].unwrap, args[1].unwrap - eval_error "invalid arguments" unless x.is_a?(Int64) && y.is_a?(Int64) - Mal::Type.new func.call(x, y) - } -end - -REPL_ENV = Mal::Env.new nil -REPL_ENV.set("+", Mal::Type.new num_func(->(x : Int64, y : Int64) { x + y })) -REPL_ENV.set("-", Mal::Type.new num_func(->(x : Int64, y : Int64) { x - y })) -REPL_ENV.set("*", Mal::Type.new num_func(->(x : Int64, y : Int64) { x * y })) -REPL_ENV.set("/", Mal::Type.new num_func(->(x : Int64, y : Int64) { x / y })) - -module Mal - extend self - - def eval_ast(a, env) - return a.map { |n| eval(n, env) } if a.is_a? Array - - Mal::Type.new case ast = a.unwrap - when Mal::Symbol - if e = env.get(ast.str) - e - else - eval_error "'#{ast.str}' not found" - end - when Mal::List - ast.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } - when Mal::Vector - ast.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } - when Mal::HashMap - new_map = Mal::HashMap.new - ast.each { |k, v| new_map[k] = eval(v, env) } - new_map - else - ast - end - end - - def read(str) - read_str str - end - - def eval(t, env) - ast = t.unwrap - - return eval_ast(t, env) unless ast.is_a?(Mal::List) - return gen_type Mal::List if ast.empty? - - sym = ast.first.unwrap - eval_error "first element of list must be a symbol" unless sym.is_a?(Mal::Symbol) - - Mal::Type.new case sym.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless ast.size == 3 - a1 = ast[1].unwrap - eval_error "1st argument of 'def!' must be symbol" unless a1.is_a?(Mal::Symbol) - env.set(a1.str, eval(ast[2], env).as(Mal::Type)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless ast.size == 3 - - bindings = ast[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a?(Array) - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - name, value = binding[0].unwrap, binding[1] - eval_error "name of binding must be specified as symbol" unless name.is_a?(Mal::Symbol) - new_env.set(name.str, eval(value, new_env)) - end - - eval(ast[2], new_env) - else - f = eval_ast(ast.first, env) - ast.shift(1) - args = eval_ast(ast, env) - - if f.is_a?(Mal::Type) && (f2 = f.unwrap).is_a?(Mal::Func) - f2.call(args.as(Array(Mal::Type))) - else - eval_error "expected function symbol as the first symbol of list" - end - end - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str), REPL_ENV)) - end -end - -while line = Readline.readline("user> ", true) - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "readline" +require "./reader" +require "./printer" +require "./types" +require "./env" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +def eval_error(msg) + raise Mal::EvalException.new msg +end + +def num_func(func) + ->(args : Array(Mal::Type)) { + x, y = args[0].unwrap, args[1].unwrap + eval_error "invalid arguments" unless x.is_a?(Int64) && y.is_a?(Int64) + Mal::Type.new func.call(x, y) + } +end + +REPL_ENV = Mal::Env.new nil +REPL_ENV.set("+", Mal::Type.new num_func(->(x : Int64, y : Int64) { x + y })) +REPL_ENV.set("-", Mal::Type.new num_func(->(x : Int64, y : Int64) { x - y })) +REPL_ENV.set("*", Mal::Type.new num_func(->(x : Int64, y : Int64) { x * y })) +REPL_ENV.set("/", Mal::Type.new num_func(->(x : Int64, y : Int64) { x / y })) + +module Mal + extend self + + def eval_ast(a, env) + return a.map { |n| eval(n, env) } if a.is_a? Array + + Mal::Type.new case ast = a.unwrap + when Mal::Symbol + if e = env.get(ast.str) + e + else + eval_error "'#{ast.str}' not found" + end + when Mal::List + ast.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } + when Mal::Vector + ast.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } + when Mal::HashMap + new_map = Mal::HashMap.new + ast.each { |k, v| new_map[k] = eval(v, env) } + new_map + else + ast + end + end + + def read(str) + read_str str + end + + def eval(t, env) + ast = t.unwrap + + return eval_ast(t, env) unless ast.is_a?(Mal::List) + return gen_type Mal::List if ast.empty? + + sym = ast.first.unwrap + eval_error "first element of list must be a symbol" unless sym.is_a?(Mal::Symbol) + + Mal::Type.new case sym.str + when "def!" + eval_error "wrong number of argument for 'def!'" unless ast.size == 3 + a1 = ast[1].unwrap + eval_error "1st argument of 'def!' must be symbol" unless a1.is_a?(Mal::Symbol) + env.set(a1.str, eval(ast[2], env).as(Mal::Type)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless ast.size == 3 + + bindings = ast[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a?(Array) + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + name, value = binding[0].unwrap, binding[1] + eval_error "name of binding must be specified as symbol" unless name.is_a?(Mal::Symbol) + new_env.set(name.str, eval(value, new_env)) + end + + eval(ast[2], new_env) + else + f = eval_ast(ast.first, env) + ast.shift(1) + args = eval_ast(ast, env) + + if f.is_a?(Mal::Type) && (f2 = f.unwrap).is_a?(Mal::Func) + f2.call(args.as(Array(Mal::Type))) + else + eval_error "expected function symbol as the first symbol of list" + end + end + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str), REPL_ENV)) + end +end + +while line = Readline.readline("user> ", true) + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/step4_if_fn_do.cr b/impls/crystal/step4_if_fn_do.cr index f4a41da132..240de6cd31 100755 --- a/impls/crystal/step4_if_fn_do.cr +++ b/impls/crystal/step4_if_fn_do.cr @@ -1,136 +1,136 @@ -#! /usr/bin/env crystal run - -require "readline" -require "./reader" -require "./printer" -require "./types" -require "./env" -require "./core" -require "./error" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -module Mal - extend self - - def func_of(env, binds, body) - ->(args : Array(Mal::Type)) { - new_env = Mal::Env.new(env, binds, args) - eval(body, new_env) - }.as(Mal::Func) - end - - def eval_ast(ast, env) - return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List - - val = ast.unwrap - - Mal::Type.new case val - when Mal::Symbol - if e = env.get(val.str) - e - else - eval_error "'#{val.str}' not found" - end - when Mal::List - val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } - when Mal::Vector - val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } - when Mal::HashMap - val.each { |k, v| val[k] = eval(v, env) } - val - else - val - end - end - - def eval_invocation(list, env) - f = eval(list.first, env).unwrap - eval_error "expected function symbol as the first symbol of list" unless f.is_a? Mal::Func - f.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) - end - - def read(str) - read_str str - end - - def eval(ast, env) - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return gen_type Mal::List if list.empty? - - head = list.first.unwrap - - Mal::Type.new case head - when Mal::Symbol - case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - eval(list[2], new_env) - when "do" - list.shift 1 - eval_ast(list, env).last - when "if" - cond = eval(list[1], env).unwrap - case cond - when Nil - list.size >= 4 ? eval(list[3], env) : nil - when false - list.size >= 4 ? eval(list[3], env) : nil - else - eval(list[2], env) - end - when "fn*" - # Note: - # If writing lambda expression here directly, compiler will fail to infer type of 'list'. (Error 'Nil for empty?') - func_of(env, list[1].unwrap, list[2]) - else - eval_invocation(list, env) - end - else - eval_invocation(list, env) - end - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str), REPL_ENV)) - end -end - -REPL_ENV = Mal::Env.new nil -Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } -Mal.rep "(def! not (fn* (a) (if a false true)))" - -while line = Readline.readline("user> ") - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "readline" +require "./reader" +require "./printer" +require "./types" +require "./env" +require "./core" +require "./error" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +module Mal + extend self + + def func_of(env, binds, body) + ->(args : Array(Mal::Type)) { + new_env = Mal::Env.new(env, binds, args) + eval(body, new_env) + }.as(Mal::Func) + end + + def eval_ast(ast, env) + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List + + val = ast.unwrap + + Mal::Type.new case val + when Mal::Symbol + if e = env.get(val.str) + e + else + eval_error "'#{val.str}' not found" + end + when Mal::List + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } + when Mal::Vector + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } + when Mal::HashMap + val.each { |k, v| val[k] = eval(v, env) } + val + else + val + end + end + + def eval_invocation(list, env) + f = eval(list.first, env).unwrap + eval_error "expected function symbol as the first symbol of list" unless f.is_a? Mal::Func + f.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) + end + + def read(str) + read_str str + end + + def eval(ast, env) + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return gen_type Mal::List if list.empty? + + head = list.first.unwrap + + Mal::Type.new case head + when Mal::Symbol + case head.str + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + eval(list[2], new_env) + when "do" + list.shift 1 + eval_ast(list, env).last + when "if" + cond = eval(list[1], env).unwrap + case cond + when Nil + list.size >= 4 ? eval(list[3], env) : nil + when false + list.size >= 4 ? eval(list[3], env) : nil + else + eval(list[2], env) + end + when "fn*" + # Note: + # If writing lambda expression here directly, compiler will fail to infer type of 'list'. (Error 'Nil for empty?') + func_of(env, list[1].unwrap, list[2]) + else + eval_invocation(list, env) + end + else + eval_invocation(list, env) + end + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str), REPL_ENV)) + end +end + +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +Mal.rep "(def! not (fn* (a) (if a false true)))" + +while line = Readline.readline("user> ") + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/step5_tco.cr b/impls/crystal/step5_tco.cr index 66f144bfe1..a37b9201e1 100755 --- a/impls/crystal/step5_tco.cr +++ b/impls/crystal/step5_tco.cr @@ -1,170 +1,170 @@ -#! /usr/bin/env crystal run - -require "readline" -require "./reader" -require "./printer" -require "./types" -require "./env" -require "./core" -require "./error" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -module Mal - extend self - - def func_of(env, binds, body) - ->(args : Array(Mal::Type)) { - new_env = Mal::Env.new(env, binds, args) - eval(body, new_env) - }.as(Mal::Func) - end - - def eval_ast(ast, env) - return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List - - val = ast.unwrap - - Mal::Type.new case val - when Mal::Symbol - if e = env.get(val.str) - e - else - eval_error "'#{val.str}' not found" - end - when Mal::List - val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } - when Mal::Vector - val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } - when Array(Mal::Type) - val.map { |n| eval(n, env).as(Mal::Type) } - when Mal::HashMap - val.each { |k, v| val[k] = eval(v, env) } - val - else - val - end - end - - def eval_invocation(list, env) - f = eval(list.first, env).unwrap - case f - when Mal::Closure - f.fn.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) - when Mal::Func - f.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) - else - eval_error "expected function as the first argument" - end - end - - def read(str) - read_str str - end - - macro invoke_list(l) - f = eval({{l}}.first, env).unwrap - args = eval_ast({{l}}[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, env) - case f - when Mal::Closure - ast = f.ast - env = Mal::Env.new(f.env, f.params, args) - next # TCO - when Mal::Func - return f.call args - else - eval_error "expected function as the first argument" - end - end - - def eval(ast, env) - # 'next' in 'do...end' has a bug in crystal 0.7.1 - # https://github.com/manastech/crystal/issues/659 - while true - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return gen_type Mal::List if list.empty? - - head = list.first.unwrap - - unless head.is_a? Mal::Symbol - invoke_list list - end - - return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - # Note: - # If writing lambda expression here directly, compiler will fail to infer type of 'list'. (Error 'Nil for empty?') - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list" - end - Mal::Closure.new(list[2], params, env, func_of(env, list[1].unwrap, list[2])) - else - invoke_list list - end - end - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str), REPL_ENV)) - end -end - -REPL_ENV = Mal::Env.new nil -Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } -Mal.rep "(def! not (fn* (a) (if a false true)))" - -while line = Readline.readline("user> ", true) - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "readline" +require "./reader" +require "./printer" +require "./types" +require "./env" +require "./core" +require "./error" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +module Mal + extend self + + def func_of(env, binds, body) + ->(args : Array(Mal::Type)) { + new_env = Mal::Env.new(env, binds, args) + eval(body, new_env) + }.as(Mal::Func) + end + + def eval_ast(ast, env) + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List + + val = ast.unwrap + + Mal::Type.new case val + when Mal::Symbol + if e = env.get(val.str) + e + else + eval_error "'#{val.str}' not found" + end + when Mal::List + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } + when Mal::Vector + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } + when Array(Mal::Type) + val.map { |n| eval(n, env).as(Mal::Type) } + when Mal::HashMap + val.each { |k, v| val[k] = eval(v, env) } + val + else + val + end + end + + def eval_invocation(list, env) + f = eval(list.first, env).unwrap + case f + when Mal::Closure + f.fn.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) + when Mal::Func + f.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) + else + eval_error "expected function as the first argument" + end + end + + def read(str) + read_str str + end + + macro invoke_list(l) + f = eval({{l}}.first, env).unwrap + args = eval_ast({{l}}[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, env) + case f + when Mal::Closure + ast = f.ast + env = Mal::Env.new(f.env, f.params, args) + next # TCO + when Mal::Func + return f.call args + else + eval_error "expected function as the first argument" + end + end + + def eval(ast, env) + # 'next' in 'do...end' has a bug in crystal 0.7.1 + # https://github.com/manastech/crystal/issues/659 + while true + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return gen_type Mal::List if list.empty? + + head = list.first.unwrap + + unless head.is_a? Mal::Symbol + invoke_list list + end + + return Mal::Type.new case head.str + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) + else + list[2] + end + next # TCO + when "fn*" + # Note: + # If writing lambda expression here directly, compiler will fail to infer type of 'list'. (Error 'Nil for empty?') + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list" + end + Mal::Closure.new(list[2], params, env, func_of(env, list[1].unwrap, list[2])) + else + invoke_list list + end + end + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str), REPL_ENV)) + end +end + +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +Mal.rep "(def! not (fn* (a) (if a false true)))" + +while line = Readline.readline("user> ", true) + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/step6_file.cr b/impls/crystal/step6_file.cr index 37788e6ac5..3611cd6fe8 100755 --- a/impls/crystal/step6_file.cr +++ b/impls/crystal/step6_file.cr @@ -1,183 +1,183 @@ -#! /usr/bin/env crystal run - -require "readline" -require "./reader" -require "./printer" -require "./types" -require "./env" -require "./core" -require "./error" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -module Mal - extend self - - def func_of(env, binds, body) - ->(args : Array(Mal::Type)) { - new_env = Mal::Env.new(env, binds, args) - eval(body, new_env) - }.as(Mal::Func) - end - - def eval_ast(ast, env) - return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List - - val = ast.unwrap - - Mal::Type.new case val - when Mal::Symbol - if e = env.get(val.str) - e - else - eval_error "'#{val.str}' not found" - end - when Mal::List - val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } - when Mal::Vector - val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } - when Array(Mal::Type) - val.map { |n| eval(n, env).as(Mal::Type) } - when Mal::HashMap - val.each { |k, v| val[k] = eval(v, env) } - val - else - val - end - end - - def eval_invocation(list, env) - f = eval(list.first, env).unwrap - case f - when Mal::Closure - f.fn.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) - when Mal::Func - f.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) - else - eval_error "expected function as the first argument" - end - end - - def read(str) - read_str str - end - - macro invoke_list(l, env) - f = eval({{l}}.first, {{env}}).unwrap - args = eval_ast({{l}}[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, {{env}}) - case f - when Mal::Closure - ast = f.ast - {{env}} = Mal::Env.new(f.env, f.params, args) - next # TCO - when Mal::Func - return f.call args - else - eval_error "expected function as the first argument" - end - end - - def eval(ast, env) - # 'next' in 'do...end' has a bug in crystal 0.7.1 - # https://github.com/manastech/crystal/issues/659 - while true - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return gen_type Mal::List if list.empty? - - head = list.first.unwrap - - unless head.is_a? Mal::Symbol - invoke_list(list, env) - end - - return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) - else - invoke_list(list, env) - end - end - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str), REPL_ENV)) - end -end - -REPL_ENV = Mal::Env.new nil -Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } -REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) -Mal.rep "(def! not (fn* (a) (if a false true)))" -Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -argv = Mal::List.new -REPL_ENV.set("*ARGV*", Mal::Type.new argv) - -unless ARGV.empty? - if ARGV.size > 1 - ARGV[1..-1].each do |a| - argv << Mal::Type.new(a) - end - end - - Mal.rep "(load-file \"#{ARGV[0]}\")" - exit -end - -while line = Readline.readline("user> ", true) - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "readline" +require "./reader" +require "./printer" +require "./types" +require "./env" +require "./core" +require "./error" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +module Mal + extend self + + def func_of(env, binds, body) + ->(args : Array(Mal::Type)) { + new_env = Mal::Env.new(env, binds, args) + eval(body, new_env) + }.as(Mal::Func) + end + + def eval_ast(ast, env) + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List + + val = ast.unwrap + + Mal::Type.new case val + when Mal::Symbol + if e = env.get(val.str) + e + else + eval_error "'#{val.str}' not found" + end + when Mal::List + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } + when Mal::Vector + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } + when Array(Mal::Type) + val.map { |n| eval(n, env).as(Mal::Type) } + when Mal::HashMap + val.each { |k, v| val[k] = eval(v, env) } + val + else + val + end + end + + def eval_invocation(list, env) + f = eval(list.first, env).unwrap + case f + when Mal::Closure + f.fn.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) + when Mal::Func + f.call eval_ast(list[1..-1].each_with_object(Mal::List.new) { |i, l| l << i }, env) + else + eval_error "expected function as the first argument" + end + end + + def read(str) + read_str str + end + + macro invoke_list(l, env) + f = eval({{l}}.first, {{env}}).unwrap + args = eval_ast({{l}}[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, {{env}}) + case f + when Mal::Closure + ast = f.ast + {{env}} = Mal::Env.new(f.env, f.params, args) + next # TCO + when Mal::Func + return f.call args + else + eval_error "expected function as the first argument" + end + end + + def eval(ast, env) + # 'next' in 'do...end' has a bug in crystal 0.7.1 + # https://github.com/manastech/crystal/issues/659 + while true + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return gen_type Mal::List if list.empty? + + head = list.first.unwrap + + unless head.is_a? Mal::Symbol + invoke_list(list, env) + end + + return Mal::Type.new case head.str + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) + else + list[2] + end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list" + end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + else + invoke_list(list, env) + end + end + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str), REPL_ENV)) + end +end + +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) +Mal.rep "(def! not (fn* (a) (if a false true)))" +Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) + +unless ARGV.empty? + if ARGV.size > 1 + ARGV[1..-1].each do |a| + argv << Mal::Type.new(a) + end + end + + Mal.rep "(load-file \"#{ARGV[0]}\")" + exit +end + +while line = Readline.readline("user> ", true) + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/step7_quote.cr b/impls/crystal/step7_quote.cr index d29f453eda..3e7c32bd23 100755 --- a/impls/crystal/step7_quote.cr +++ b/impls/crystal/step7_quote.cr @@ -1,228 +1,228 @@ -#! /usr/bin/env crystal run - -require "readline" -require "./reader" -require "./printer" -require "./types" -require "./env" -require "./core" -require "./error" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -module Mal - extend self - - def func_of(env, binds, body) - ->(args : Array(Mal::Type)) { - new_env = Mal::Env.new(env, binds, args) - eval(body, new_env) - }.as(Mal::Func) - end - - def eval_ast(ast, env) - return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List - - val = ast.unwrap - - Mal::Type.new case val - when Mal::Symbol - if e = env.get(val.str) - e - else - eval_error "'#{val.str}' not found" - end - when Mal::List - val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } - when Mal::Vector - val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } - when Array(Mal::Type) - val.map { |n| eval(n, env).as(Mal::Type) } - when Mal::HashMap - val.each { |k, v| val[k] = eval(v, env) } - val - else - val - end - end - - def read(str) - read_str str - end - - def starts_with(list, symbol) - if list.size == 2 - head = list.first.unwrap - head.is_a? Mal::Symbol && head.str == symbol - end - end - - def quasiquote_elts(list) - acc = Mal::Type.new(Mal::List.new) - list.reverse.each do |elt| - elt_val = elt.unwrap - if elt_val.is_a? Mal::List && starts_with(elt_val, "splice-unquote") - acc = Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "concat") << elt_val[1] << acc - ) - else - acc = Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(elt) << acc - ) - end - end - acc - end - - def quasiquote(ast) - ast_val = ast.unwrap - case ast_val - when Mal::List - if starts_with(ast_val,"unquote") - ast_val[1] - else - quasiquote_elts(ast_val) - end - when Mal::Vector - Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "vec") << quasiquote_elts(ast_val) - ) - when Mal::HashMap, Mal::Symbol - Mal::Type.new ( - Mal::List.new << gen_type(Mal::Symbol, "quote") << ast - ) - else - ast - end - end - - macro invoke_list(l, env) - f = eval({{l}}.first, {{env}}).unwrap - args = eval_ast({{l}}[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, {{env}}) - case f - when Mal::Closure - ast = f.ast - {{env}} = Mal::Env.new(f.env, f.params, args) - next # TCO - when Mal::Func - return f.call args - else - eval_error "expected function as the first argument" - end - end - - def eval(ast, env) - # 'next' in 'do...end' has a bug in crystal 0.7.1 - # https://github.com/manastech/crystal/issues/659 - while true - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return gen_type Mal::List if list.empty? - - head = list.first.unwrap - - unless head.is_a? Mal::Symbol - return invoke_list(list, env) - end - - return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) - when "quote" - list[1] - when "quasiquoteexpand" - quasiquote list[1] - when "quasiquote" - ast = quasiquote list[1] - next # TCO - else - invoke_list(list, env) - end - end - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str), REPL_ENV)) - end -end - -REPL_ENV = Mal::Env.new nil -Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } -REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) -Mal.rep "(def! not (fn* (a) (if a false true)))" -Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -argv = Mal::List.new -REPL_ENV.set("*ARGV*", Mal::Type.new argv) - -unless ARGV.empty? - if ARGV.size > 1 - ARGV[1..-1].each do |a| - argv << Mal::Type.new(a) - end - end - - begin - Mal.rep "(load-file \"#{ARGV[0]}\")" - rescue e - STDERR.puts e - end - exit -end - -while line = Readline.readline("user> ", true) - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "readline" +require "./reader" +require "./printer" +require "./types" +require "./env" +require "./core" +require "./error" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +module Mal + extend self + + def func_of(env, binds, body) + ->(args : Array(Mal::Type)) { + new_env = Mal::Env.new(env, binds, args) + eval(body, new_env) + }.as(Mal::Func) + end + + def eval_ast(ast, env) + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List + + val = ast.unwrap + + Mal::Type.new case val + when Mal::Symbol + if e = env.get(val.str) + e + else + eval_error "'#{val.str}' not found" + end + when Mal::List + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } + when Mal::Vector + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } + when Array(Mal::Type) + val.map { |n| eval(n, env).as(Mal::Type) } + when Mal::HashMap + val.each { |k, v| val[k] = eval(v, env) } + val + else + val + end + end + + def read(str) + read_str str + end + + def starts_with(list, symbol) + if list.size == 2 + head = list.first.unwrap + head.is_a? Mal::Symbol && head.str == symbol + end + end + + def quasiquote_elts(list) + acc = Mal::Type.new(Mal::List.new) + list.reverse.each do |elt| + elt_val = elt.unwrap + if elt_val.is_a? Mal::List && starts_with(elt_val, "splice-unquote") + acc = Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "concat") << elt_val[1] << acc + ) + else + acc = Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(elt) << acc + ) + end + end + acc + end + + def quasiquote(ast) + ast_val = ast.unwrap + case ast_val + when Mal::List + if starts_with(ast_val,"unquote") + ast_val[1] + else + quasiquote_elts(ast_val) + end + when Mal::Vector + Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "vec") << quasiquote_elts(ast_val) + ) + when Mal::HashMap, Mal::Symbol + Mal::Type.new ( + Mal::List.new << gen_type(Mal::Symbol, "quote") << ast + ) + else + ast + end + end + + macro invoke_list(l, env) + f = eval({{l}}.first, {{env}}).unwrap + args = eval_ast({{l}}[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, {{env}}) + case f + when Mal::Closure + ast = f.ast + {{env}} = Mal::Env.new(f.env, f.params, args) + next # TCO + when Mal::Func + return f.call args + else + eval_error "expected function as the first argument" + end + end + + def eval(ast, env) + # 'next' in 'do...end' has a bug in crystal 0.7.1 + # https://github.com/manastech/crystal/issues/659 + while true + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return gen_type Mal::List if list.empty? + + head = list.first.unwrap + + unless head.is_a? Mal::Symbol + return invoke_list(list, env) + end + + return Mal::Type.new case head.str + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) + else + list[2] + end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list" + end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + when "quote" + list[1] + when "quasiquoteexpand" + quasiquote list[1] + when "quasiquote" + ast = quasiquote list[1] + next # TCO + else + invoke_list(list, env) + end + end + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str), REPL_ENV)) + end +end + +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) +Mal.rep "(def! not (fn* (a) (if a false true)))" +Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) + +unless ARGV.empty? + if ARGV.size > 1 + ARGV[1..-1].each do |a| + argv << Mal::Type.new(a) + end + end + + begin + Mal.rep "(load-file \"#{ARGV[0]}\")" + rescue e + STDERR.puts e + end + exit +end + +while line = Readline.readline("user> ", true) + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/step8_macros.cr b/impls/crystal/step8_macros.cr index 0b10285725..18409d9e36 100755 --- a/impls/crystal/step8_macros.cr +++ b/impls/crystal/step8_macros.cr @@ -1,276 +1,276 @@ -#! /usr/bin/env crystal run - -require "readline" -require "./reader" -require "./printer" -require "./types" -require "./env" -require "./core" -require "./error" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -module Mal - extend self - - def func_of(env, binds, body) - ->(args : Array(Mal::Type)) { - new_env = Mal::Env.new(env, binds, args) - eval(body, new_env) - }.as(Mal::Func) - end - - def eval_ast(ast, env) - return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List - - val = ast.unwrap - - Mal::Type.new case val - when Mal::Symbol - if e = env.get(val.str) - e - else - eval_error "'#{val.str}' not found" - end - when Mal::List - val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } - when Mal::Vector - val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } - when Array(Mal::Type) - val.map { |n| eval(n, env).as(Mal::Type) } - when Mal::HashMap - val.each { |k, v| val[k] = eval(v, env) } - val - else - val - end - end - - def read(str) - read_str str - end - - def starts_with(list, symbol) - if list.size == 2 - head = list.first.unwrap - head.is_a? Mal::Symbol && head.str == symbol - end - end - - def quasiquote_elts(list) - acc = Mal::Type.new(Mal::List.new) - list.reverse.each do |elt| - elt_val = elt.unwrap - if elt_val.is_a? Mal::List && starts_with(elt_val, "splice-unquote") - acc = Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "concat") << elt_val[1] << acc - ) - else - acc = Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(elt) << acc - ) - end - end - acc - end - - def quasiquote(ast) - ast_val = ast.unwrap - case ast_val - when Mal::List - if starts_with(ast_val,"unquote") - ast_val[1] - else - quasiquote_elts(ast_val) - end - when Mal::Vector - Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "vec") << quasiquote_elts(ast_val) - ) - when Mal::HashMap, Mal::Symbol - Mal::Type.new ( - Mal::List.new << gen_type(Mal::Symbol, "quote") << ast - ) - else - ast - end - end - - def macro_call?(ast, env) - list = ast.unwrap - return false unless list.is_a? Mal::List - return false if list.empty? - - sym = list.first.unwrap - return false unless sym.is_a? Mal::Symbol - - func = env.find(sym.str).try(&.data[sym.str]) - return false unless func && func.macro? - - true - end - - def macroexpand(ast, env) - while macro_call?(ast, env) - # Already checked in macro_call? - list = ast.unwrap.as(Mal::List) - func_sym = list[0].unwrap.as(Mal::Symbol) - func = env.get(func_sym.str).unwrap - - case func - when Mal::Func - ast = func.call(list[1..-1]) - when Mal::Closure - ast = func.fn.call(list[1..-1]) - else - eval_error "macro '#{func_sym.str}' must be function: #{ast}" - end - end - - ast - end - - macro invoke_list(l, env) - f = eval({{l}}.first, {{env}}).unwrap - args = eval_ast({{l}}[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, {{env}}) - case f - when Mal::Closure - ast = f.ast - {{env}} = Mal::Env.new(f.env, f.params, args) - next # TCO - when Mal::Func - return f.call args - else - eval_error "expected function as the first argument: #{f}" - end - end - - def eval(ast, env) - # 'next' in 'do...end' has a bug in crystal 0.7.1 - # https://github.com/manastech/crystal/issues/659 - while true - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return ast if list.empty? - - ast = macroexpand(ast, env) - - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return ast if list.empty? - - head = list.first.unwrap - - return invoke_list(list, env) unless head.is_a? Mal::Symbol - - return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list or vector: #{params}" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) - when "quote" - list[1] - when "quasiquoteexpand" - quasiquote list[1] - when "quasiquote" - ast = quasiquote list[1] - next # TCO - when "defmacro!" - eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env).tap { |n| n.is_macro = true }) - when "macroexpand" - macroexpand(list[1], env) - else - invoke_list(list, env) - end - end - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str), REPL_ENV)) - end -end - -REPL_ENV = Mal::Env.new nil -Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } -REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) -Mal.rep "(def! not (fn* (a) (if a false true)))" -Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -Mal.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)))))))" - -argv = Mal::List.new -REPL_ENV.set("*ARGV*", Mal::Type.new argv) - -unless ARGV.empty? - if ARGV.size > 1 - ARGV[1..-1].each do |a| - argv << Mal::Type.new(a) - end - end - - begin - Mal.rep "(load-file \"#{ARGV[0]}\")" - rescue e - STDERR.puts e - end - exit -end - -while line = Readline.readline("user> ", true) - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "readline" +require "./reader" +require "./printer" +require "./types" +require "./env" +require "./core" +require "./error" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +module Mal + extend self + + def func_of(env, binds, body) + ->(args : Array(Mal::Type)) { + new_env = Mal::Env.new(env, binds, args) + eval(body, new_env) + }.as(Mal::Func) + end + + def eval_ast(ast, env) + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List + + val = ast.unwrap + + Mal::Type.new case val + when Mal::Symbol + if e = env.get(val.str) + e + else + eval_error "'#{val.str}' not found" + end + when Mal::List + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } + when Mal::Vector + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } + when Array(Mal::Type) + val.map { |n| eval(n, env).as(Mal::Type) } + when Mal::HashMap + val.each { |k, v| val[k] = eval(v, env) } + val + else + val + end + end + + def read(str) + read_str str + end + + def starts_with(list, symbol) + if list.size == 2 + head = list.first.unwrap + head.is_a? Mal::Symbol && head.str == symbol + end + end + + def quasiquote_elts(list) + acc = Mal::Type.new(Mal::List.new) + list.reverse.each do |elt| + elt_val = elt.unwrap + if elt_val.is_a? Mal::List && starts_with(elt_val, "splice-unquote") + acc = Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "concat") << elt_val[1] << acc + ) + else + acc = Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(elt) << acc + ) + end + end + acc + end + + def quasiquote(ast) + ast_val = ast.unwrap + case ast_val + when Mal::List + if starts_with(ast_val,"unquote") + ast_val[1] + else + quasiquote_elts(ast_val) + end + when Mal::Vector + Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "vec") << quasiquote_elts(ast_val) + ) + when Mal::HashMap, Mal::Symbol + Mal::Type.new ( + Mal::List.new << gen_type(Mal::Symbol, "quote") << ast + ) + else + ast + end + end + + def macro_call?(ast, env) + list = ast.unwrap + return false unless list.is_a? Mal::List + return false if list.empty? + + sym = list.first.unwrap + return false unless sym.is_a? Mal::Symbol + + func = env.find(sym.str).try(&.data[sym.str]) + return false unless func && func.macro? + + true + end + + def macroexpand(ast, env) + while macro_call?(ast, env) + # Already checked in macro_call? + list = ast.unwrap.as(Mal::List) + func_sym = list[0].unwrap.as(Mal::Symbol) + func = env.get(func_sym.str).unwrap + + case func + when Mal::Func + ast = func.call(list[1..-1]) + when Mal::Closure + ast = func.fn.call(list[1..-1]) + else + eval_error "macro '#{func_sym.str}' must be function: #{ast}" + end + end + + ast + end + + macro invoke_list(l, env) + f = eval({{l}}.first, {{env}}).unwrap + args = eval_ast({{l}}[1..-1].each_with_object(Mal::List.new){|i, l| l << i}, {{env}}) + case f + when Mal::Closure + ast = f.ast + {{env}} = Mal::Env.new(f.env, f.params, args) + next # TCO + when Mal::Func + return f.call args + else + eval_error "expected function as the first argument: #{f}" + end + end + + def eval(ast, env) + # 'next' in 'do...end' has a bug in crystal 0.7.1 + # https://github.com/manastech/crystal/issues/659 + while true + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return ast if list.empty? + + ast = macroexpand(ast, env) + + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return ast if list.empty? + + head = list.first.unwrap + + return invoke_list(list, env) unless head.is_a? Mal::Symbol + + return Mal::Type.new case head.str + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].each_with_object(Mal::List.new) { |i, l| l << i }, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) + else + list[2] + end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list or vector: #{params}" + end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + when "quote" + list[1] + when "quasiquoteexpand" + quasiquote list[1] + when "quasiquote" + ast = quasiquote list[1] + next # TCO + when "defmacro!" + eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env).tap { |n| n.is_macro = true }) + when "macroexpand" + macroexpand(list[1], env) + else + invoke_list(list, env) + end + end + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str), REPL_ENV)) + end +end + +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) +Mal.rep "(def! not (fn* (a) (if a false true)))" +Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +Mal.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)))))))" + +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) + +unless ARGV.empty? + if ARGV.size > 1 + ARGV[1..-1].each do |a| + argv << Mal::Type.new(a) + end + end + + begin + Mal.rep "(load-file \"#{ARGV[0]}\")" + rescue e + STDERR.puts e + end + exit +end + +while line = Readline.readline("user> ", true) + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/step9_try.cr b/impls/crystal/step9_try.cr index 1720e162c8..b2fabb48af 100755 --- a/impls/crystal/step9_try.cr +++ b/impls/crystal/step9_try.cr @@ -1,293 +1,293 @@ -#! /usr/bin/env crystal run - -require "readline" -require "./reader" -require "./printer" -require "./types" -require "./env" -require "./core" -require "./error" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -module Mal - extend self - - def func_of(env, binds, body) - ->(args : Array(Mal::Type)) { - new_env = Mal::Env.new(env, binds, args) - eval(body, new_env) - }.as(Mal::Func) - end - - def eval_ast(ast, env) - return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List - - val = ast.unwrap - - Mal::Type.new case val - when Mal::Symbol - if e = env.get(val.str) - e - else - eval_error "'#{val.str}' not found" - end - when Mal::List - val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } - when Mal::Vector - val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } - when Array(Mal::Type) - val.map { |n| eval(n, env).as(Mal::Type) } - when Mal::HashMap - val.each { |k, v| val[k] = eval(v, env) } - val - else - val - end - end - - def read(str) - read_str str - end - - def starts_with(list, symbol) - if list.size == 2 - head = list.first.unwrap - head.is_a? Mal::Symbol && head.str == symbol - end - end - - def quasiquote_elts(list) - acc = Mal::Type.new(Mal::List.new) - list.reverse.each do |elt| - elt_val = elt.unwrap - if elt_val.is_a? Mal::List && starts_with(elt_val, "splice-unquote") - acc = Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "concat") << elt_val[1] << acc - ) - else - acc = Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(elt) << acc - ) - end - end - acc - end - - def quasiquote(ast) - ast_val = ast.unwrap - case ast_val - when Mal::List - if starts_with(ast_val,"unquote") - ast_val[1] - else - quasiquote_elts(ast_val) - end - when Mal::Vector - Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "vec") << quasiquote_elts(ast_val) - ) - when Mal::HashMap, Mal::Symbol - Mal::Type.new ( - Mal::List.new << gen_type(Mal::Symbol, "quote") << ast - ) - else - ast - end - end - - def macro_call?(ast, env) - list = ast.unwrap - return false unless list.is_a? Mal::List - return false if list.empty? - - sym = list.first.unwrap - return false unless sym.is_a? Mal::Symbol - - func = env.find(sym.str).try(&.data[sym.str]) - return false unless func && func.macro? - - true - end - - def macroexpand(ast, env) - while macro_call?(ast, env) - # Already checked in macro_call? - list = ast.unwrap.as(Mal::List) - func_sym = list[0].unwrap.as(Mal::Symbol) - func = env.get(func_sym.str).unwrap - - case func - when Mal::Func - ast = func.call(list[1..-1]) - when Mal::Closure - ast = func.fn.call(list[1..-1]) - else - eval_error "macro '#{func_sym.str}' must be function: #{ast}" - end - end - - ast - end - - macro invoke_list(l, env) - f = eval({{l}}.first, {{env}}).unwrap - args = eval_ast({{l}}[1..-1].to_mal, {{env}}) - case f - when Mal::Closure - ast = f.ast - {{env}} = Mal::Env.new(f.env, f.params, args) - next # TCO - when Mal::Func - return f.call args - else - eval_error "expected function as the first argument: #{f}" - end - end - - def eval(ast, env) - # 'next' in 'do...end' has a bug in crystal 0.7.1 - # https://github.com/manastech/crystal/issues/659 - while true - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return ast if list.empty? - - ast = macroexpand(ast, env) - - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return ast if list.empty? - - head = list.first.unwrap - - return invoke_list(list, env) unless head.is_a? Mal::Symbol - - return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].to_mal, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list or vector: #{params}" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) - when "quote" - list[1] - when "quasiquoteexpand" - quasiquote list[1] - when "quasiquote" - ast = quasiquote list[1] - next # TCO - when "defmacro!" - eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env).tap { |n| n.is_macro = true }) - when "macroexpand" - macroexpand(list[1], env) - when "try*" - catch_list = list.size >= 3 ? list[2].unwrap : Mal::Type.new(nil) - return eval(list[1], env) unless catch_list.is_a? Mal::List - - catch_head = catch_list.first.unwrap - return eval(list[1], env) unless catch_head.is_a? Mal::Symbol - return eval(list[1], env) unless catch_head.str == "catch*" - - begin - eval(list[1], env) - rescue e : Mal::RuntimeException - new_env = Mal::Env.new(env, [catch_list[1]], [e.thrown]) - eval(catch_list[2], new_env) - rescue e - new_env = Mal::Env.new(env, [catch_list[1]], [Mal::Type.new e.message]) - eval(catch_list[2], new_env) - end - else - invoke_list(list, env) - end - end - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str), REPL_ENV)) - end -end - -REPL_ENV = Mal::Env.new nil -Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } -REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) -Mal.rep "(def! not (fn* (a) (if a false true)))" -Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -Mal.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)))))))" - -argv = Mal::List.new -REPL_ENV.set("*ARGV*", Mal::Type.new argv) - -unless ARGV.empty? - if ARGV.size > 1 - ARGV[1..-1].each do |a| - argv << Mal::Type.new(a) - end - end - - begin - Mal.rep "(load-file \"#{ARGV[0]}\")" - rescue e - STDERR.puts e - end - exit -end - -while line = Readline.readline("user> ", true) - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "readline" +require "./reader" +require "./printer" +require "./types" +require "./env" +require "./core" +require "./error" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +module Mal + extend self + + def func_of(env, binds, body) + ->(args : Array(Mal::Type)) { + new_env = Mal::Env.new(env, binds, args) + eval(body, new_env) + }.as(Mal::Func) + end + + def eval_ast(ast, env) + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Mal::List + + val = ast.unwrap + + Mal::Type.new case val + when Mal::Symbol + if e = env.get(val.str) + e + else + eval_error "'#{val.str}' not found" + end + when Mal::List + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } + when Mal::Vector + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } + when Array(Mal::Type) + val.map { |n| eval(n, env).as(Mal::Type) } + when Mal::HashMap + val.each { |k, v| val[k] = eval(v, env) } + val + else + val + end + end + + def read(str) + read_str str + end + + def starts_with(list, symbol) + if list.size == 2 + head = list.first.unwrap + head.is_a? Mal::Symbol && head.str == symbol + end + end + + def quasiquote_elts(list) + acc = Mal::Type.new(Mal::List.new) + list.reverse.each do |elt| + elt_val = elt.unwrap + if elt_val.is_a? Mal::List && starts_with(elt_val, "splice-unquote") + acc = Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "concat") << elt_val[1] << acc + ) + else + acc = Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(elt) << acc + ) + end + end + acc + end + + def quasiquote(ast) + ast_val = ast.unwrap + case ast_val + when Mal::List + if starts_with(ast_val,"unquote") + ast_val[1] + else + quasiquote_elts(ast_val) + end + when Mal::Vector + Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "vec") << quasiquote_elts(ast_val) + ) + when Mal::HashMap, Mal::Symbol + Mal::Type.new ( + Mal::List.new << gen_type(Mal::Symbol, "quote") << ast + ) + else + ast + end + end + + def macro_call?(ast, env) + list = ast.unwrap + return false unless list.is_a? Mal::List + return false if list.empty? + + sym = list.first.unwrap + return false unless sym.is_a? Mal::Symbol + + func = env.find(sym.str).try(&.data[sym.str]) + return false unless func && func.macro? + + true + end + + def macroexpand(ast, env) + while macro_call?(ast, env) + # Already checked in macro_call? + list = ast.unwrap.as(Mal::List) + func_sym = list[0].unwrap.as(Mal::Symbol) + func = env.get(func_sym.str).unwrap + + case func + when Mal::Func + ast = func.call(list[1..-1]) + when Mal::Closure + ast = func.fn.call(list[1..-1]) + else + eval_error "macro '#{func_sym.str}' must be function: #{ast}" + end + end + + ast + end + + macro invoke_list(l, env) + f = eval({{l}}.first, {{env}}).unwrap + args = eval_ast({{l}}[1..-1].to_mal, {{env}}) + case f + when Mal::Closure + ast = f.ast + {{env}} = Mal::Env.new(f.env, f.params, args) + next # TCO + when Mal::Func + return f.call args + else + eval_error "expected function as the first argument: #{f}" + end + end + + def eval(ast, env) + # 'next' in 'do...end' has a bug in crystal 0.7.1 + # https://github.com/manastech/crystal/issues/659 + while true + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return ast if list.empty? + + ast = macroexpand(ast, env) + + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return ast if list.empty? + + head = list.first.unwrap + + return invoke_list(list, env) unless head.is_a? Mal::Symbol + + return Mal::Type.new case head.str + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].to_mal, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) + else + list[2] + end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list or vector: #{params}" + end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + when "quote" + list[1] + when "quasiquoteexpand" + quasiquote list[1] + when "quasiquote" + ast = quasiquote list[1] + next # TCO + when "defmacro!" + eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env).tap { |n| n.is_macro = true }) + when "macroexpand" + macroexpand(list[1], env) + when "try*" + catch_list = list.size >= 3 ? list[2].unwrap : Mal::Type.new(nil) + return eval(list[1], env) unless catch_list.is_a? Mal::List + + catch_head = catch_list.first.unwrap + return eval(list[1], env) unless catch_head.is_a? Mal::Symbol + return eval(list[1], env) unless catch_head.str == "catch*" + + begin + eval(list[1], env) + rescue e : Mal::RuntimeException + new_env = Mal::Env.new(env, [catch_list[1]], [e.thrown]) + eval(catch_list[2], new_env) + rescue e + new_env = Mal::Env.new(env, [catch_list[1]], [Mal::Type.new e.message]) + eval(catch_list[2], new_env) + end + else + invoke_list(list, env) + end + end + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str), REPL_ENV)) + end +end + +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) +Mal.rep "(def! not (fn* (a) (if a false true)))" +Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +Mal.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)))))))" + +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) + +unless ARGV.empty? + if ARGV.size > 1 + ARGV[1..-1].each do |a| + argv << Mal::Type.new(a) + end + end + + begin + Mal.rep "(load-file \"#{ARGV[0]}\")" + rescue e + STDERR.puts e + end + exit +end + +while line = Readline.readline("user> ", true) + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/stepA_mal.cr b/impls/crystal/stepA_mal.cr index 3f662f5354..72d10b1823 100755 --- a/impls/crystal/stepA_mal.cr +++ b/impls/crystal/stepA_mal.cr @@ -1,302 +1,302 @@ -#! /usr/bin/env crystal run - -require "colorize" - -require "readline" -require "./reader" -require "./printer" -require "./types" -require "./env" -require "./core" -require "./error" - -# Note: -# Employed downcase names because Crystal prohibits uppercase names for methods - -module Mal - extend self - - def func_of(env, binds, body) - ->(args : Array(Mal::Type)) { - new_env = Mal::Env.new(env, binds, args) - eval(body, new_env) - }.as(Mal::Func) - end - - def eval_ast(ast, env) - return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Array - - val = ast.unwrap - - Mal::Type.new case val - when Mal::Symbol - if e = env.get(val.str) - e - else - eval_error "'#{val.str}' not found" - end - when Mal::List - val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } - when Mal::Vector - val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } - when Mal::HashMap - new_map = Mal::HashMap.new - val.each { |k, v| new_map[k] = eval(v, env) } - new_map - else - val - end - end - - def read(str) - read_str str - end - - def starts_with(list, symbol) - if list.size == 2 - head = list.first.unwrap - head.is_a? Mal::Symbol && head.str == symbol - end - end - - def quasiquote_elts(list) - acc = Mal::Type.new(Mal::List.new) - list.reverse.each do |elt| - elt_val = elt.unwrap - if elt_val.is_a? Mal::List && starts_with(elt_val, "splice-unquote") - acc = Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "concat") << elt_val[1] << acc - ) - else - acc = Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(elt) << acc - ) - end - end - acc - end - - def quasiquote(ast) - ast_val = ast.unwrap - case ast_val - when Mal::List - if starts_with(ast_val,"unquote") - ast_val[1] - else - quasiquote_elts(ast_val) - end - when Mal::Vector - Mal::Type.new( - Mal::List.new << gen_type(Mal::Symbol, "vec") << quasiquote_elts(ast_val) - ) - when Mal::HashMap, Mal::Symbol - Mal::Type.new ( - Mal::List.new << gen_type(Mal::Symbol, "quote") << ast - ) - else - ast - end - end - - def macro_call?(ast, env) - list = ast.unwrap - return false unless list.is_a? Mal::List - return false if list.empty? - - sym = list.first.unwrap - return false unless sym.is_a? Mal::Symbol - - func = env.find(sym.str).try(&.data[sym.str]) - return false unless func && func.macro? - - true - end - - def macroexpand(ast, env) - while macro_call?(ast, env) - # Already checked in macro_call? - list = ast.unwrap.as(Mal::List) - func_sym = list[0].unwrap.as(Mal::Symbol) - func = env.get(func_sym.str).unwrap - - case func - when Mal::Func - ast = func.call(list[1..-1]) - when Mal::Closure - ast = func.fn.call(list[1..-1]) - else - eval_error "macro '#{func_sym.str}' must be function: #{ast}" - end - end - - ast - end - - macro invoke_list(l, env) - f = eval({{l}}.first, {{env}}).unwrap - args = eval_ast({{l}}[1..-1], {{env}}).as(Array) - - case f - when Mal::Closure - ast = f.ast - {{env}} = Mal::Env.new(f.env, f.params, args) - next # TCO - when Mal::Func - return f.call args - else - eval_error "expected function as the first argument: #{f}" - end - end - - def debug(ast) - puts print(ast).colorize.red - end - - def eval(ast, env) - # 'next' in 'do...end' has a bug in crystal 0.7.1 - # https://github.com/manastech/crystal/issues/659 - while true - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return ast if list.empty? - - ast = macroexpand(ast, env) - - list = ast.unwrap - - return eval_ast(ast, env) unless list.is_a? Mal::List - return ast if list.empty? - - head = list.first.unwrap - - return invoke_list(list, env) unless head.is_a? Mal::Symbol - - return Mal::Type.new case head.str - when "def!" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env)) - when "let*" - eval_error "wrong number of argument for 'def!'" unless list.size == 3 - - bindings = list[1].unwrap - eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array - eval_error "size of binding list must be even" unless bindings.size.even? - - new_env = Mal::Env.new env - bindings.each_slice(2) do |binding| - key, value = binding - name = key.unwrap - eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol - new_env.set(name.str, eval(value, new_env)) - end - - ast, env = list[2], new_env - next # TCO - when "do" - if list.empty? - ast = Mal::Type.new nil - next - end - - eval_ast(list[1..-2].to_mal, env) - ast = list.last - next # TCO - when "if" - ast = unless eval(list[1], env).unwrap - list.size >= 4 ? list[3] : Mal::Type.new(nil) - else - list[2] - end - next # TCO - when "fn*" - params = list[1].unwrap - unless params.is_a? Array - eval_error "'fn*' parameters must be list or vector: #{params}" - end - Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) - when "quote" - list[1] - when "quasiquoteexpand" - quasiquote list[1] - when "quasiquote" - ast = quasiquote list[1] - next # TCO - when "defmacro!" - eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 - a1 = list[1].unwrap - eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol - env.set(a1.str, eval(list[2], env).tap { |n| n.is_macro = true }) - when "macroexpand" - macroexpand(list[1], env) - when "try*" - catch_list = list.size >= 3 ? list[2].unwrap : Mal::Type.new(nil) - return eval(list[1], env) unless catch_list.is_a? Mal::List - - catch_head = catch_list.first.unwrap - return eval(list[1], env) unless catch_head.is_a? Mal::Symbol - return eval(list[1], env) unless catch_head.str == "catch*" - - begin - eval(list[1], env) - rescue e : Mal::RuntimeException - new_env = Mal::Env.new(env, [catch_list[1]], [e.thrown]) - eval(catch_list[2], new_env) - rescue e - new_env = Mal::Env.new(env, [catch_list[1]], [Mal::Type.new e.message]) - eval(catch_list[2], new_env) - end - else - invoke_list(list, env) - end - end - end - - def print(result) - pr_str(result, true) - end - - def rep(str) - print(eval(read(str), REPL_ENV)) - end -end - -REPL_ENV = Mal::Env.new nil -Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } -REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) -Mal.rep "(def! not (fn* (a) (if a false true)))" -Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -Mal.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)))))))" -Mal.rep("(def! *host-language* \"crystal\")") - -argv = Mal::List.new -REPL_ENV.set("*ARGV*", Mal::Type.new argv) - -unless ARGV.empty? - if ARGV.size > 1 - ARGV[1..-1].each do |a| - argv << Mal::Type.new(a) - end - end - - begin - Mal.rep "(load-file \"#{ARGV[0]}\")" - rescue e - STDERR.puts e - end - exit -end - -Mal.rep("(println (str \"Mal [\" *host-language* \"]\"))") - -while line = Readline.readline("user> ", true) - begin - puts Mal.rep(line) - rescue e : Mal::RuntimeException - STDERR.puts "Error: #{pr_str(e.thrown, true)}" - rescue e - STDERR.puts "Error: #{e}" - end -end +#! /usr/bin/env crystal run + +require "colorize" + +require "readline" +require "./reader" +require "./printer" +require "./types" +require "./env" +require "./core" +require "./error" + +# Note: +# Employed downcase names because Crystal prohibits uppercase names for methods + +module Mal + extend self + + def func_of(env, binds, body) + ->(args : Array(Mal::Type)) { + new_env = Mal::Env.new(env, binds, args) + eval(body, new_env) + }.as(Mal::Func) + end + + def eval_ast(ast, env) + return ast.map { |n| eval(n, env).as(Mal::Type) } if ast.is_a? Array + + val = ast.unwrap + + Mal::Type.new case val + when Mal::Symbol + if e = env.get(val.str) + e + else + eval_error "'#{val.str}' not found" + end + when Mal::List + val.each_with_object(Mal::List.new) { |n, l| l << eval(n, env) } + when Mal::Vector + val.each_with_object(Mal::Vector.new) { |n, l| l << eval(n, env) } + when Mal::HashMap + new_map = Mal::HashMap.new + val.each { |k, v| new_map[k] = eval(v, env) } + new_map + else + val + end + end + + def read(str) + read_str str + end + + def starts_with(list, symbol) + if list.size == 2 + head = list.first.unwrap + head.is_a? Mal::Symbol && head.str == symbol + end + end + + def quasiquote_elts(list) + acc = Mal::Type.new(Mal::List.new) + list.reverse.each do |elt| + elt_val = elt.unwrap + if elt_val.is_a? Mal::List && starts_with(elt_val, "splice-unquote") + acc = Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "concat") << elt_val[1] << acc + ) + else + acc = Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "cons") << quasiquote(elt) << acc + ) + end + end + acc + end + + def quasiquote(ast) + ast_val = ast.unwrap + case ast_val + when Mal::List + if starts_with(ast_val,"unquote") + ast_val[1] + else + quasiquote_elts(ast_val) + end + when Mal::Vector + Mal::Type.new( + Mal::List.new << gen_type(Mal::Symbol, "vec") << quasiquote_elts(ast_val) + ) + when Mal::HashMap, Mal::Symbol + Mal::Type.new ( + Mal::List.new << gen_type(Mal::Symbol, "quote") << ast + ) + else + ast + end + end + + def macro_call?(ast, env) + list = ast.unwrap + return false unless list.is_a? Mal::List + return false if list.empty? + + sym = list.first.unwrap + return false unless sym.is_a? Mal::Symbol + + func = env.find(sym.str).try(&.data[sym.str]) + return false unless func && func.macro? + + true + end + + def macroexpand(ast, env) + while macro_call?(ast, env) + # Already checked in macro_call? + list = ast.unwrap.as(Mal::List) + func_sym = list[0].unwrap.as(Mal::Symbol) + func = env.get(func_sym.str).unwrap + + case func + when Mal::Func + ast = func.call(list[1..-1]) + when Mal::Closure + ast = func.fn.call(list[1..-1]) + else + eval_error "macro '#{func_sym.str}' must be function: #{ast}" + end + end + + ast + end + + macro invoke_list(l, env) + f = eval({{l}}.first, {{env}}).unwrap + args = eval_ast({{l}}[1..-1], {{env}}).as(Array) + + case f + when Mal::Closure + ast = f.ast + {{env}} = Mal::Env.new(f.env, f.params, args) + next # TCO + when Mal::Func + return f.call args + else + eval_error "expected function as the first argument: #{f}" + end + end + + def debug(ast) + puts print(ast).colorize.red + end + + def eval(ast, env) + # 'next' in 'do...end' has a bug in crystal 0.7.1 + # https://github.com/manastech/crystal/issues/659 + while true + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return ast if list.empty? + + ast = macroexpand(ast, env) + + list = ast.unwrap + + return eval_ast(ast, env) unless list.is_a? Mal::List + return ast if list.empty? + + head = list.first.unwrap + + return invoke_list(list, env) unless head.is_a? Mal::Symbol + + return Mal::Type.new case head.str + when "def!" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'def!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env)) + when "let*" + eval_error "wrong number of argument for 'def!'" unless list.size == 3 + + bindings = list[1].unwrap + eval_error "1st argument of 'let*' must be list or vector" unless bindings.is_a? Array + eval_error "size of binding list must be even" unless bindings.size.even? + + new_env = Mal::Env.new env + bindings.each_slice(2) do |binding| + key, value = binding + name = key.unwrap + eval_error "name of binding must be specified as symbol #{name}" unless name.is_a? Mal::Symbol + new_env.set(name.str, eval(value, new_env)) + end + + ast, env = list[2], new_env + next # TCO + when "do" + if list.empty? + ast = Mal::Type.new nil + next + end + + eval_ast(list[1..-2].to_mal, env) + ast = list.last + next # TCO + when "if" + ast = unless eval(list[1], env).unwrap + list.size >= 4 ? list[3] : Mal::Type.new(nil) + else + list[2] + end + next # TCO + when "fn*" + params = list[1].unwrap + unless params.is_a? Array + eval_error "'fn*' parameters must be list or vector: #{params}" + end + Mal::Closure.new(list[2], params, env, func_of(env, params, list[2])) + when "quote" + list[1] + when "quasiquoteexpand" + quasiquote list[1] + when "quasiquote" + ast = quasiquote list[1] + next # TCO + when "defmacro!" + eval_error "wrong number of argument for 'defmacro!'" unless list.size == 3 + a1 = list[1].unwrap + eval_error "1st argument of 'defmacro!' must be symbol: #{a1}" unless a1.is_a? Mal::Symbol + env.set(a1.str, eval(list[2], env).tap { |n| n.is_macro = true }) + when "macroexpand" + macroexpand(list[1], env) + when "try*" + catch_list = list.size >= 3 ? list[2].unwrap : Mal::Type.new(nil) + return eval(list[1], env) unless catch_list.is_a? Mal::List + + catch_head = catch_list.first.unwrap + return eval(list[1], env) unless catch_head.is_a? Mal::Symbol + return eval(list[1], env) unless catch_head.str == "catch*" + + begin + eval(list[1], env) + rescue e : Mal::RuntimeException + new_env = Mal::Env.new(env, [catch_list[1]], [e.thrown]) + eval(catch_list[2], new_env) + rescue e + new_env = Mal::Env.new(env, [catch_list[1]], [Mal::Type.new e.message]) + eval(catch_list[2], new_env) + end + else + invoke_list(list, env) + end + end + end + + def print(result) + pr_str(result, true) + end + + def rep(str) + print(eval(read(str), REPL_ENV)) + end +end + +REPL_ENV = Mal::Env.new nil +Mal::NS.each { |k, v| REPL_ENV.set(k, Mal::Type.new(v)) } +REPL_ENV.set("eval", Mal::Type.new ->(args : Array(Mal::Type)) { Mal.eval(args[0], REPL_ENV) }) +Mal.rep "(def! not (fn* (a) (if a false true)))" +Mal.rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +Mal.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)))))))" +Mal.rep("(def! *host-language* \"crystal\")") + +argv = Mal::List.new +REPL_ENV.set("*ARGV*", Mal::Type.new argv) + +unless ARGV.empty? + if ARGV.size > 1 + ARGV[1..-1].each do |a| + argv << Mal::Type.new(a) + end + end + + begin + Mal.rep "(load-file \"#{ARGV[0]}\")" + rescue e + STDERR.puts e + end + exit +end + +Mal.rep("(println (str \"Mal [\" *host-language* \"]\"))") + +while line = Readline.readline("user> ", true) + begin + puts Mal.rep(line) + rescue e : Mal::RuntimeException + STDERR.puts "Error: #{pr_str(e.thrown, true)}" + rescue e + STDERR.puts "Error: #{e}" + end +end diff --git a/impls/crystal/tests/step5_tco.mal b/impls/crystal/tests/step5_tco.mal index 1fd025b6a0..3f03f25593 100644 --- a/impls/crystal/tests/step5_tco.mal +++ b/impls/crystal/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Crystal: skipping non-TCO recursion -;; Reason: completes at 1,000,000 +;; Crystal: skipping non-TCO recursion +;; Reason: completes at 1,000,000 diff --git a/impls/crystal/types.cr b/impls/crystal/types.cr index 10c36da5fa..d03ec6031f 100644 --- a/impls/crystal/types.cr +++ b/impls/crystal/types.cr @@ -1,113 +1,113 @@ -require "./printer" - -module Mal - class Type - alias Func = (Array(Type) -> Type) - - property :is_macro, :meta - - def initialize(@val : ValueType) - @is_macro = false - @meta = nil.as(Type | Nil) - end - - def initialize(other : Type) - @val = other.unwrap - @is_macro = other.is_macro - @meta = other.meta - end - - def unwrap - @val - end - - def macro? - @is_macro - end - - def to_s - pr_str(self) - end - - def dup - Type.new(@val).tap do |t| - t.is_macro = @is_macro - t.meta = @meta - end - end - - def ==(other : Type) - @val == other.unwrap - end - - macro rel_op(*ops) - {% for op in ops %} - def {{op.id}}(other : Mal::Type) - l, r = @val, other.unwrap - {% for t in [Int64, String] %} - if l.is_a?({{t}}) && r.is_a?({{t}}) - return (l) {{op.id}} (r) - end - {% end %} - if l.is_a?(Symbol) && r.is_a?(Symbol) - return l.str {{op.id}} r.str - end - false - end - {% end %} - end - - rel_op :<, :>, :<=, :>= - end - - class Symbol - property :str - - def initialize(@str : String) - end - - def ==(other : Symbol) - @str == other.str - end - end - - class List < Array(Type) - end - - class Vector < Array(Type) - end - - class HashMap < Hash(String, Type) - end - - class Atom - property :val - - def initialize(@val : Type) - end - - def ==(rhs : Atom) - @val == rhs.val - end - end - - class Closure - property :ast, :params, :env, :fn - - def initialize(@ast : Type, @params : Array(Mal::Type) | List | Vector, @env : Env, @fn : Func) - end - end - - alias Type::ValueType = Nil | Bool | Int64 | String | Symbol | List | Vector | HashMap | Func | Closure | Atom - alias Func = Type::Func -end - -macro gen_type(t, *args) - Mal::Type.new {{t.id}}.new({{*args}}) -end - -class Array - def to_mal(t = Mal::List) - each_with_object(t.new) { |e, l| l << e } - end -end +require "./printer" + +module Mal + class Type + alias Func = (Array(Type) -> Type) + + property :is_macro, :meta + + def initialize(@val : ValueType) + @is_macro = false + @meta = nil.as(Type | Nil) + end + + def initialize(other : Type) + @val = other.unwrap + @is_macro = other.is_macro + @meta = other.meta + end + + def unwrap + @val + end + + def macro? + @is_macro + end + + def to_s + pr_str(self) + end + + def dup + Type.new(@val).tap do |t| + t.is_macro = @is_macro + t.meta = @meta + end + end + + def ==(other : Type) + @val == other.unwrap + end + + macro rel_op(*ops) + {% for op in ops %} + def {{op.id}}(other : Mal::Type) + l, r = @val, other.unwrap + {% for t in [Int64, String] %} + if l.is_a?({{t}}) && r.is_a?({{t}}) + return (l) {{op.id}} (r) + end + {% end %} + if l.is_a?(Symbol) && r.is_a?(Symbol) + return l.str {{op.id}} r.str + end + false + end + {% end %} + end + + rel_op :<, :>, :<=, :>= + end + + class Symbol + property :str + + def initialize(@str : String) + end + + def ==(other : Symbol) + @str == other.str + end + end + + class List < Array(Type) + end + + class Vector < Array(Type) + end + + class HashMap < Hash(String, Type) + end + + class Atom + property :val + + def initialize(@val : Type) + end + + def ==(rhs : Atom) + @val == rhs.val + end + end + + class Closure + property :ast, :params, :env, :fn + + def initialize(@ast : Type, @params : Array(Mal::Type) | List | Vector, @env : Env, @fn : Func) + end + end + + alias Type::ValueType = Nil | Bool | Int64 | String | Symbol | List | Vector | HashMap | Func | Closure | Atom + alias Func = Type::Func +end + +macro gen_type(t, *args) + Mal::Type.new {{t.id}}.new({{*args}}) +end + +class Array + def to_mal(t = Mal::List) + each_with_object(t.new) { |e, l| l << e } + end +end diff --git a/impls/cs/Dockerfile b/impls/cs/Dockerfile index f5f133484d..e8180bc9fd 100644 --- a/impls/cs/Dockerfile +++ b/impls/cs/Dockerfile @@ -1,25 +1,25 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Deps for Mono-based languages (C#, VB.Net) -RUN apt-get -y install mono-runtime mono-mcs mono-vbnc mono-devel +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Deps for Mono-based languages (C#, VB.Net) +RUN apt-get -y install mono-runtime mono-mcs mono-vbnc mono-devel diff --git a/impls/cs/Makefile b/impls/cs/Makefile index 52529a915b..961b1650ae 100644 --- a/impls/cs/Makefile +++ b/impls/cs/Makefile @@ -1,43 +1,43 @@ -##################### - -DEBUG = - -SOURCES_BASE = readline.cs types.cs reader.cs printer.cs -SOURCES_LISP = env.cs core.cs stepA_mal.cs -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -OTHER_SOURCES = getline.cs - -##################### - -SRCS = step0_repl.cs step1_read_print.cs step2_eval.cs step3_env.cs \ - step4_if_fn_do.cs step5_tco.cs step6_file.cs step7_quote.cs \ - step8_macros.cs step9_try.cs stepA_mal.cs - -LIB_SRCS = $(filter-out step%,$(OTHER_SOURCES) $(SOURCES)) - -FLAGS = $(if $(strip $(DEBUG)),-debug+,) - -##################### - -all: $(patsubst %.cs,%.exe,$(SRCS)) - -dist: mal.exe mal - -mal.exe: $(patsubst %.cs,%.exe,$(word $(words $(SOURCES)),$(SOURCES))) - cp $< $@ - -# NOTE/WARNING: static linking triggers mono libraries LGPL -# distribution requirements. -# http://www.mono-project.com/archived/guiderunning_mono_applications/ -mal: $(patsubst %.cs,%.exe,$(word $(words $(SOURCES)),$(SOURCES))) mal.dll - mkbundle --static -o $@ $+ --deps - -mal.dll: $(LIB_SRCS) - mcs $(FLAGS) -target:library $+ -out:$@ - -%.exe: %.cs mal.dll - mcs $(FLAGS) -r:mal.dll $< - -clean: - rm -f mal *.dll *.exe *.mdb +##################### + +DEBUG = + +SOURCES_BASE = readline.cs types.cs reader.cs printer.cs +SOURCES_LISP = env.cs core.cs stepA_mal.cs +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +OTHER_SOURCES = getline.cs + +##################### + +SRCS = step0_repl.cs step1_read_print.cs step2_eval.cs step3_env.cs \ + step4_if_fn_do.cs step5_tco.cs step6_file.cs step7_quote.cs \ + step8_macros.cs step9_try.cs stepA_mal.cs + +LIB_SRCS = $(filter-out step%,$(OTHER_SOURCES) $(SOURCES)) + +FLAGS = $(if $(strip $(DEBUG)),-debug+,) + +##################### + +all: $(patsubst %.cs,%.exe,$(SRCS)) + +dist: mal.exe mal + +mal.exe: $(patsubst %.cs,%.exe,$(word $(words $(SOURCES)),$(SOURCES))) + cp $< $@ + +# NOTE/WARNING: static linking triggers mono libraries LGPL +# distribution requirements. +# http://www.mono-project.com/archived/guiderunning_mono_applications/ +mal: $(patsubst %.cs,%.exe,$(word $(words $(SOURCES)),$(SOURCES))) mal.dll + mkbundle --static -o $@ $+ --deps + +mal.dll: $(LIB_SRCS) + mcs $(FLAGS) -target:library $+ -out:$@ + +%.exe: %.cs mal.dll + mcs $(FLAGS) -r:mal.dll $< + +clean: + rm -f mal *.dll *.exe *.mdb diff --git a/impls/cs/core.cs b/impls/cs/core.cs index 16eb0564c2..9d61cbfbd6 100644 --- a/impls/cs/core.cs +++ b/impls/cs/core.cs @@ -1,394 +1,394 @@ -using System; -using System.IO; -using System.Collections.Generic; -using MalVal = Mal.types.MalVal; -using MalConstant = Mal.types.MalConstant; -using MalInt = Mal.types.MalInt; -using MalSymbol = Mal.types.MalSymbol; -using MalString = Mal.types.MalString; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalAtom = Mal.types.MalAtom; -using MalFunc = Mal.types.MalFunc; - -namespace Mal { - public class core { - static MalConstant Nil = Mal.types.Nil; - static MalConstant True = Mal.types.True; - static MalConstant False = Mal.types.False; - - // Errors/Exceptions - static public MalFunc mal_throw = new MalFunc( - a => { throw new Mal.types.MalException(a[0]); }); - - // Scalar functions - static MalFunc nil_Q = new MalFunc( - a => a[0] == Nil ? True : False); - - static MalFunc true_Q = new MalFunc( - a => a[0] == True ? True : False); - - static MalFunc false_Q = new MalFunc( - a => a[0] == False ? True : False); - - static MalFunc symbol_Q = new MalFunc( - a => a[0] is MalSymbol ? True : False); - - static MalFunc string_Q = new MalFunc( - a => { - if (a[0] is MalString) { - var s = ((MalString)a[0]).getValue(); - return (s.Length == 0 || s[0] != '\u029e') ? True : False; - } else { - return False; - } - } ); - - static MalFunc keyword = new MalFunc( - a => { - if (a[0] is MalString && - ((MalString)a[0]).getValue()[0] == '\u029e') { - return a[0]; - } else { - return new MalString("\u029e" + ((MalString)a[0]).getValue()); - } - } ); - - static MalFunc keyword_Q = new MalFunc( - a => { - if (a[0] is MalString) { - var s = ((MalString)a[0]).getValue(); - return (s.Length > 0 && s[0] == '\u029e') ? True : False; - } else { - return False; - } - } ); - - static MalFunc number_Q = new MalFunc( - a => a[0] is MalInt ? True : False); - - static MalFunc function_Q = new MalFunc( - a => a[0] is MalFunc && !((MalFunc)a[0]).isMacro() ? True : False); - - static MalFunc macro_Q = new MalFunc( - a => a[0] is MalFunc && ((MalFunc)a[0]).isMacro() ? True : False); - - - // Number functions - static MalFunc time_ms = new MalFunc( - a => new MalInt(DateTime.Now.Ticks / TimeSpan.TicksPerMillisecond)); - - // String functions - static public MalFunc pr_str = new MalFunc( - a => new MalString(printer._pr_str_args(a, " ", true)) ); - - static public MalFunc str = new MalFunc( - a => new MalString(printer._pr_str_args(a, "", false)) ); - - static public MalFunc prn = new MalFunc( - a => { - Console.WriteLine(printer._pr_str_args(a, " ", true)); - return Nil; - } ); - - static public MalFunc println = new MalFunc( - a => { - Console.WriteLine(printer._pr_str_args(a, " ", false)); - return Nil; - } ); - - static public MalFunc mal_readline = new MalFunc( - a => { - var line = readline.Readline(((MalString)a[0]).getValue()); - if (line == null) { return types.Nil; } - else { return new MalString(line); } - } ); - - static public MalFunc read_string = new MalFunc( - a => reader.read_str(((MalString)a[0]).getValue())); - - static public MalFunc slurp = new MalFunc( - a => new MalString(File.ReadAllText( - ((MalString)a[0]).getValue()))); - - - // List/Vector functions - static public MalFunc list_Q = new MalFunc( - a => a[0].GetType() == typeof(MalList) ? True : False); - - static public MalFunc vector_Q = new MalFunc( - a => a[0].GetType() == typeof(MalVector) ? True : False); - - // HashMap functions - static public MalFunc hash_map_Q = new MalFunc( - a => a[0].GetType() == typeof(MalHashMap) ? True : False); - - static MalFunc contains_Q = new MalFunc( - a => { - string key = ((MalString)a[1]).getValue(); - var dict = ((MalHashMap)a[0]).getValue(); - return dict.ContainsKey(key) ? True : False; - }); - - static MalFunc assoc = new MalFunc( - a => { - var new_hm = ((MalHashMap)a[0]).copy(); - return new_hm.assoc_BANG((MalList)a.slice(1)); - }); - - static MalFunc dissoc = new MalFunc( - a => { - var new_hm = ((MalHashMap)a[0]).copy(); - return new_hm.dissoc_BANG((MalList)a.slice(1)); - }); - - static MalFunc get = new MalFunc( - a => { - string key = ((MalString)a[1]).getValue(); - if (a[0] == Nil) { - return Nil; - } else { - var dict = ((MalHashMap)a[0]).getValue(); - return dict.ContainsKey(key) ? dict[key] : Nil; - } - }); - - static MalFunc keys = new MalFunc( - a => { - var dict = ((MalHashMap)a[0]).getValue(); - MalList key_lst = new MalList(); - foreach (var key in dict.Keys) { - key_lst.conj_BANG(new MalString(key)); - } - return key_lst; - }); - - static MalFunc vals = new MalFunc( - a => { - var dict = ((MalHashMap)a[0]).getValue(); - MalList val_lst = new MalList(); - foreach (var val in dict.Values) { - val_lst.conj_BANG(val); - } - return val_lst; - }); - - // Sequence functions - static public MalFunc sequential_Q = new MalFunc( - a => a[0] is MalList ? True : False); - - static MalFunc cons = new MalFunc( - a => { - var lst = new List(); - lst.Add(a[0]); - lst.AddRange(((MalList)a[1]).getValue()); - return (MalVal)new MalList(lst); - }); - - static MalFunc concat = new MalFunc( - a => { - if (a.size() == 0) { return new MalList(); } - var lst = new List(); - lst.AddRange(((MalList)a[0]).getValue()); - for(int i=1; i { - var idx = (int)((MalInt)a[1]).getValue(); - if (idx < ((MalList)a[0]).size()) { - return ((MalList)a[0])[idx]; - } else { - throw new Mal.types.MalException( - "nth: index out of range"); - } - }); - - static MalFunc first = new MalFunc( - a => a[0] == Nil ? Nil : ((MalList)a[0])[0]); - - static MalFunc rest = new MalFunc( - a => a[0] == Nil ? new MalList() : ((MalList)a[0]).rest()); - - static MalFunc empty_Q = new MalFunc( - a => ((MalList)a[0]).size() == 0 ? True : False); - - static MalFunc count = new MalFunc( - a => { - return (a[0] == Nil) - ? new MalInt(0) - :new MalInt(((MalList)a[0]).size()); - }); - - static MalFunc conj = new MalFunc( - a => { - var src_lst = ((MalList)a[0]).getValue(); - var new_lst = new List(); - new_lst.AddRange(src_lst); - if (a[0] is MalVector) { - for(int i=1; i { - if (a[0] == Nil) { - return Nil; - } else if (a[0] is MalVector) { - return (((MalVector)a[0]).size() == 0) - ? (MalVal)Nil - : new MalList(((MalVector)a[0]).getValue()); - } else if (a[0] is MalList) { - return (((MalList)a[0]).size() == 0) - ? Nil - : a[0]; - } else if (a[0] is MalString) { - var s = ((MalString)a[0]).getValue(); - if (s.Length == 0) { - return Nil; - } - var chars_list = new List(); - foreach (var c in s) { - chars_list.Add(new MalString(c.ToString())); - } - return new MalList(chars_list); - } - return Nil; - }); - - // General list related functions - static MalFunc apply = new MalFunc( - a => { - var f = (MalFunc)a[0]; - var lst = new List(); - lst.AddRange(a.slice(1,a.size()-1).getValue()); - lst.AddRange(((MalList)a[a.size()-1]).getValue()); - return f.apply(new MalList(lst)); - }); - - static MalFunc map = new MalFunc( - a => { - MalFunc f = (MalFunc) a[0]; - var src_lst = ((MalList)a[1]).getValue(); - var new_lst = new List(); - for(int i=0; i a[0].getMeta()); - - static MalFunc with_meta = new MalFunc( - a => ((MalVal)a[0]).copy().setMeta(a[1])); - - - // Atom functions - static MalFunc atom_Q = new MalFunc( - a => a[0] is MalAtom ? True : False); - - static MalFunc deref = new MalFunc( - a => ((MalAtom)a[0]).getValue()); - - static MalFunc reset_BANG = new MalFunc( - a => ((MalAtom)a[0]).setValue(a[1])); - - static MalFunc swap_BANG = new MalFunc( - a => { - MalAtom atm = (MalAtom)a[0]; - MalFunc f = (MalFunc)a[1]; - var new_lst = new List(); - new_lst.Add(atm.getValue()); - new_lst.AddRange(((MalList)a.slice(2)).getValue()); - return atm.setValue(f.apply(new MalList(new_lst))); - }); - - - - static public Dictionary ns = - new Dictionary { - {"=", new MalFunc( - a => Mal.types._equal_Q(a[0], a[1]) ? True : False)}, - {"throw", mal_throw}, - {"nil?", nil_Q}, - {"true?", true_Q}, - {"false?", false_Q}, - {"symbol", new MalFunc(a => new MalSymbol((MalString)a[0]))}, - {"symbol?", symbol_Q}, - {"string?", string_Q}, - {"keyword", keyword}, - {"keyword?", keyword_Q}, - {"number?", number_Q}, - {"fn?", function_Q}, - {"macro?", macro_Q}, - - {"pr-str", pr_str}, - {"str", str}, - {"prn", prn}, - {"println", println}, - {"readline", mal_readline}, - {"read-string", read_string}, - {"slurp", slurp}, - {"<", new MalFunc(a => (MalInt)a[0] < (MalInt)a[1])}, - {"<=", new MalFunc(a => (MalInt)a[0] <= (MalInt)a[1])}, - {">", new MalFunc(a => (MalInt)a[0] > (MalInt)a[1])}, - {">=", new MalFunc(a => (MalInt)a[0] >= (MalInt)a[1])}, - {"+", new MalFunc(a => (MalInt)a[0] + (MalInt)a[1])}, - {"-", new MalFunc(a => (MalInt)a[0] - (MalInt)a[1])}, - {"*", new MalFunc(a => (MalInt)a[0] * (MalInt)a[1])}, - {"/", new MalFunc(a => (MalInt)a[0] / (MalInt)a[1])}, - {"time-ms", time_ms}, - - {"list", new MalFunc(a => new MalList(a.getValue()))}, - {"list?", list_Q}, - {"vector", new MalFunc(a => new MalVector(a.getValue()))}, - {"vector?", vector_Q}, - {"hash-map", new MalFunc(a => new MalHashMap(a))}, - {"map?", hash_map_Q}, - {"contains?", contains_Q}, - {"assoc", assoc}, - {"dissoc", dissoc}, - {"get", get}, - {"keys", keys}, - {"vals", vals}, - - {"sequential?", sequential_Q}, - {"cons", cons}, - {"concat", concat}, - {"vec", new MalFunc(a => new MalVector(((MalList)a[0]).getValue()))}, - {"nth", nth}, - {"first", first}, - {"rest", rest}, - {"empty?", empty_Q}, - {"count", count}, - {"conj", conj}, - {"seq", seq}, - {"apply", apply}, - {"map", map}, - - {"with-meta", with_meta}, - {"meta", meta}, - {"atom", new MalFunc(a => new MalAtom(a[0]))}, - {"atom?", atom_Q}, - {"deref", deref}, - {"reset!", reset_BANG}, - {"swap!", swap_BANG}, - }; - } -} +using System; +using System.IO; +using System.Collections.Generic; +using MalVal = Mal.types.MalVal; +using MalConstant = Mal.types.MalConstant; +using MalInt = Mal.types.MalInt; +using MalSymbol = Mal.types.MalSymbol; +using MalString = Mal.types.MalString; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalAtom = Mal.types.MalAtom; +using MalFunc = Mal.types.MalFunc; + +namespace Mal { + public class core { + static MalConstant Nil = Mal.types.Nil; + static MalConstant True = Mal.types.True; + static MalConstant False = Mal.types.False; + + // Errors/Exceptions + static public MalFunc mal_throw = new MalFunc( + a => { throw new Mal.types.MalException(a[0]); }); + + // Scalar functions + static MalFunc nil_Q = new MalFunc( + a => a[0] == Nil ? True : False); + + static MalFunc true_Q = new MalFunc( + a => a[0] == True ? True : False); + + static MalFunc false_Q = new MalFunc( + a => a[0] == False ? True : False); + + static MalFunc symbol_Q = new MalFunc( + a => a[0] is MalSymbol ? True : False); + + static MalFunc string_Q = new MalFunc( + a => { + if (a[0] is MalString) { + var s = ((MalString)a[0]).getValue(); + return (s.Length == 0 || s[0] != '\u029e') ? True : False; + } else { + return False; + } + } ); + + static MalFunc keyword = new MalFunc( + a => { + if (a[0] is MalString && + ((MalString)a[0]).getValue()[0] == '\u029e') { + return a[0]; + } else { + return new MalString("\u029e" + ((MalString)a[0]).getValue()); + } + } ); + + static MalFunc keyword_Q = new MalFunc( + a => { + if (a[0] is MalString) { + var s = ((MalString)a[0]).getValue(); + return (s.Length > 0 && s[0] == '\u029e') ? True : False; + } else { + return False; + } + } ); + + static MalFunc number_Q = new MalFunc( + a => a[0] is MalInt ? True : False); + + static MalFunc function_Q = new MalFunc( + a => a[0] is MalFunc && !((MalFunc)a[0]).isMacro() ? True : False); + + static MalFunc macro_Q = new MalFunc( + a => a[0] is MalFunc && ((MalFunc)a[0]).isMacro() ? True : False); + + + // Number functions + static MalFunc time_ms = new MalFunc( + a => new MalInt(DateTime.Now.Ticks / TimeSpan.TicksPerMillisecond)); + + // String functions + static public MalFunc pr_str = new MalFunc( + a => new MalString(printer._pr_str_args(a, " ", true)) ); + + static public MalFunc str = new MalFunc( + a => new MalString(printer._pr_str_args(a, "", false)) ); + + static public MalFunc prn = new MalFunc( + a => { + Console.WriteLine(printer._pr_str_args(a, " ", true)); + return Nil; + } ); + + static public MalFunc println = new MalFunc( + a => { + Console.WriteLine(printer._pr_str_args(a, " ", false)); + return Nil; + } ); + + static public MalFunc mal_readline = new MalFunc( + a => { + var line = readline.Readline(((MalString)a[0]).getValue()); + if (line == null) { return types.Nil; } + else { return new MalString(line); } + } ); + + static public MalFunc read_string = new MalFunc( + a => reader.read_str(((MalString)a[0]).getValue())); + + static public MalFunc slurp = new MalFunc( + a => new MalString(File.ReadAllText( + ((MalString)a[0]).getValue()))); + + + // List/Vector functions + static public MalFunc list_Q = new MalFunc( + a => a[0].GetType() == typeof(MalList) ? True : False); + + static public MalFunc vector_Q = new MalFunc( + a => a[0].GetType() == typeof(MalVector) ? True : False); + + // HashMap functions + static public MalFunc hash_map_Q = new MalFunc( + a => a[0].GetType() == typeof(MalHashMap) ? True : False); + + static MalFunc contains_Q = new MalFunc( + a => { + string key = ((MalString)a[1]).getValue(); + var dict = ((MalHashMap)a[0]).getValue(); + return dict.ContainsKey(key) ? True : False; + }); + + static MalFunc assoc = new MalFunc( + a => { + var new_hm = ((MalHashMap)a[0]).copy(); + return new_hm.assoc_BANG((MalList)a.slice(1)); + }); + + static MalFunc dissoc = new MalFunc( + a => { + var new_hm = ((MalHashMap)a[0]).copy(); + return new_hm.dissoc_BANG((MalList)a.slice(1)); + }); + + static MalFunc get = new MalFunc( + a => { + string key = ((MalString)a[1]).getValue(); + if (a[0] == Nil) { + return Nil; + } else { + var dict = ((MalHashMap)a[0]).getValue(); + return dict.ContainsKey(key) ? dict[key] : Nil; + } + }); + + static MalFunc keys = new MalFunc( + a => { + var dict = ((MalHashMap)a[0]).getValue(); + MalList key_lst = new MalList(); + foreach (var key in dict.Keys) { + key_lst.conj_BANG(new MalString(key)); + } + return key_lst; + }); + + static MalFunc vals = new MalFunc( + a => { + var dict = ((MalHashMap)a[0]).getValue(); + MalList val_lst = new MalList(); + foreach (var val in dict.Values) { + val_lst.conj_BANG(val); + } + return val_lst; + }); + + // Sequence functions + static public MalFunc sequential_Q = new MalFunc( + a => a[0] is MalList ? True : False); + + static MalFunc cons = new MalFunc( + a => { + var lst = new List(); + lst.Add(a[0]); + lst.AddRange(((MalList)a[1]).getValue()); + return (MalVal)new MalList(lst); + }); + + static MalFunc concat = new MalFunc( + a => { + if (a.size() == 0) { return new MalList(); } + var lst = new List(); + lst.AddRange(((MalList)a[0]).getValue()); + for(int i=1; i { + var idx = (int)((MalInt)a[1]).getValue(); + if (idx < ((MalList)a[0]).size()) { + return ((MalList)a[0])[idx]; + } else { + throw new Mal.types.MalException( + "nth: index out of range"); + } + }); + + static MalFunc first = new MalFunc( + a => a[0] == Nil ? Nil : ((MalList)a[0])[0]); + + static MalFunc rest = new MalFunc( + a => a[0] == Nil ? new MalList() : ((MalList)a[0]).rest()); + + static MalFunc empty_Q = new MalFunc( + a => ((MalList)a[0]).size() == 0 ? True : False); + + static MalFunc count = new MalFunc( + a => { + return (a[0] == Nil) + ? new MalInt(0) + :new MalInt(((MalList)a[0]).size()); + }); + + static MalFunc conj = new MalFunc( + a => { + var src_lst = ((MalList)a[0]).getValue(); + var new_lst = new List(); + new_lst.AddRange(src_lst); + if (a[0] is MalVector) { + for(int i=1; i { + if (a[0] == Nil) { + return Nil; + } else if (a[0] is MalVector) { + return (((MalVector)a[0]).size() == 0) + ? (MalVal)Nil + : new MalList(((MalVector)a[0]).getValue()); + } else if (a[0] is MalList) { + return (((MalList)a[0]).size() == 0) + ? Nil + : a[0]; + } else if (a[0] is MalString) { + var s = ((MalString)a[0]).getValue(); + if (s.Length == 0) { + return Nil; + } + var chars_list = new List(); + foreach (var c in s) { + chars_list.Add(new MalString(c.ToString())); + } + return new MalList(chars_list); + } + return Nil; + }); + + // General list related functions + static MalFunc apply = new MalFunc( + a => { + var f = (MalFunc)a[0]; + var lst = new List(); + lst.AddRange(a.slice(1,a.size()-1).getValue()); + lst.AddRange(((MalList)a[a.size()-1]).getValue()); + return f.apply(new MalList(lst)); + }); + + static MalFunc map = new MalFunc( + a => { + MalFunc f = (MalFunc) a[0]; + var src_lst = ((MalList)a[1]).getValue(); + var new_lst = new List(); + for(int i=0; i a[0].getMeta()); + + static MalFunc with_meta = new MalFunc( + a => ((MalVal)a[0]).copy().setMeta(a[1])); + + + // Atom functions + static MalFunc atom_Q = new MalFunc( + a => a[0] is MalAtom ? True : False); + + static MalFunc deref = new MalFunc( + a => ((MalAtom)a[0]).getValue()); + + static MalFunc reset_BANG = new MalFunc( + a => ((MalAtom)a[0]).setValue(a[1])); + + static MalFunc swap_BANG = new MalFunc( + a => { + MalAtom atm = (MalAtom)a[0]; + MalFunc f = (MalFunc)a[1]; + var new_lst = new List(); + new_lst.Add(atm.getValue()); + new_lst.AddRange(((MalList)a.slice(2)).getValue()); + return atm.setValue(f.apply(new MalList(new_lst))); + }); + + + + static public Dictionary ns = + new Dictionary { + {"=", new MalFunc( + a => Mal.types._equal_Q(a[0], a[1]) ? True : False)}, + {"throw", mal_throw}, + {"nil?", nil_Q}, + {"true?", true_Q}, + {"false?", false_Q}, + {"symbol", new MalFunc(a => new MalSymbol((MalString)a[0]))}, + {"symbol?", symbol_Q}, + {"string?", string_Q}, + {"keyword", keyword}, + {"keyword?", keyword_Q}, + {"number?", number_Q}, + {"fn?", function_Q}, + {"macro?", macro_Q}, + + {"pr-str", pr_str}, + {"str", str}, + {"prn", prn}, + {"println", println}, + {"readline", mal_readline}, + {"read-string", read_string}, + {"slurp", slurp}, + {"<", new MalFunc(a => (MalInt)a[0] < (MalInt)a[1])}, + {"<=", new MalFunc(a => (MalInt)a[0] <= (MalInt)a[1])}, + {">", new MalFunc(a => (MalInt)a[0] > (MalInt)a[1])}, + {">=", new MalFunc(a => (MalInt)a[0] >= (MalInt)a[1])}, + {"+", new MalFunc(a => (MalInt)a[0] + (MalInt)a[1])}, + {"-", new MalFunc(a => (MalInt)a[0] - (MalInt)a[1])}, + {"*", new MalFunc(a => (MalInt)a[0] * (MalInt)a[1])}, + {"/", new MalFunc(a => (MalInt)a[0] / (MalInt)a[1])}, + {"time-ms", time_ms}, + + {"list", new MalFunc(a => new MalList(a.getValue()))}, + {"list?", list_Q}, + {"vector", new MalFunc(a => new MalVector(a.getValue()))}, + {"vector?", vector_Q}, + {"hash-map", new MalFunc(a => new MalHashMap(a))}, + {"map?", hash_map_Q}, + {"contains?", contains_Q}, + {"assoc", assoc}, + {"dissoc", dissoc}, + {"get", get}, + {"keys", keys}, + {"vals", vals}, + + {"sequential?", sequential_Q}, + {"cons", cons}, + {"concat", concat}, + {"vec", new MalFunc(a => new MalVector(((MalList)a[0]).getValue()))}, + {"nth", nth}, + {"first", first}, + {"rest", rest}, + {"empty?", empty_Q}, + {"count", count}, + {"conj", conj}, + {"seq", seq}, + {"apply", apply}, + {"map", map}, + + {"with-meta", with_meta}, + {"meta", meta}, + {"atom", new MalFunc(a => new MalAtom(a[0]))}, + {"atom?", atom_Q}, + {"deref", deref}, + {"reset!", reset_BANG}, + {"swap!", swap_BANG}, + }; + } +} diff --git a/impls/cs/env.cs b/impls/cs/env.cs index 39ab100e0f..dc226ffb38 100644 --- a/impls/cs/env.cs +++ b/impls/cs/env.cs @@ -1,55 +1,55 @@ -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalSymbol = Mal.types.MalSymbol; -using MalList = Mal.types.MalList; - -namespace Mal { - public class env { - public class Env { - Env outer = null; - Dictionary data = new Dictionary(); - - public Env(Env outer) { - this.outer = outer; - } - public Env(Env outer, MalList binds, MalList exprs) { - this.outer = outer; - for (int i=0; i data = new Dictionary(); + + public Env(Env outer) { + this.outer = outer; + } + public Env(Env outer, MalList binds, MalList exprs) { + this.outer = outer; + for (int i=0; i - /// Invoked when the user requests auto-completion using the tab character - /// - /// - /// The result is null for no values found, an array with a single - /// string, in that case the string should be the text to be inserted - /// for example if the word at pos is "T", the result for a completion - /// of "ToString" should be "oString", not "ToString". - /// - /// When there are multiple results, the result should be the full - /// text - /// - public AutoCompleteHandler AutoCompleteEvent; - - static Handler [] handlers; - - public LineEditor (string name) : this (name, 10) { } - - public LineEditor (string name, int histsize) - { - handlers = new Handler [] { - new Handler (ConsoleKey.Home, CmdHome), - new Handler (ConsoleKey.End, CmdEnd), - new Handler (ConsoleKey.LeftArrow, CmdLeft), - new Handler (ConsoleKey.RightArrow, CmdRight), - new Handler (ConsoleKey.UpArrow, CmdHistoryPrev), - new Handler (ConsoleKey.DownArrow, CmdHistoryNext), - new Handler (ConsoleKey.Enter, CmdDone), - new Handler (ConsoleKey.Backspace, CmdBackspace), - new Handler (ConsoleKey.Delete, CmdDeleteChar), - new Handler (ConsoleKey.Tab, CmdTabOrComplete), - - // Emacs keys - Handler.Control ('A', CmdHome), - Handler.Control ('E', CmdEnd), - Handler.Control ('B', CmdLeft), - Handler.Control ('F', CmdRight), - Handler.Control ('P', CmdHistoryPrev), - Handler.Control ('N', CmdHistoryNext), - Handler.Control ('K', CmdKillToEOF), - Handler.Control ('Y', CmdYank), - Handler.Control ('D', CmdDeleteChar), - Handler.Control ('L', CmdRefresh), - Handler.Control ('R', CmdReverseSearch), - Handler.Control ('G', delegate {} ), - Handler.Alt ('B', ConsoleKey.B, CmdBackwardWord), - Handler.Alt ('F', ConsoleKey.F, CmdForwardWord), - - Handler.Alt ('D', ConsoleKey.D, CmdDeleteWord), - Handler.Alt ((char) 8, ConsoleKey.Backspace, CmdDeleteBackword), - - // DEBUG - //Handler.Control ('T', CmdDebug), - - // quote - Handler.Control ('Q', delegate { HandleChar (Console.ReadKey (true).KeyChar); }) - }; - - rendered_text = new StringBuilder (); - text = new StringBuilder (); - - history = new History (name, histsize); - - //if (File.Exists ("log"))File.Delete ("log"); - //log = File.CreateText ("log"); - } - - void CmdDebug () - { - history.Dump (); - Console.WriteLine (); - Render (); - } - - void Render () - { - Console.Write (shown_prompt); - Console.Write (rendered_text); - - int max = System.Math.Max (rendered_text.Length + shown_prompt.Length, max_rendered); - - for (int i = rendered_text.Length + shown_prompt.Length; i < max_rendered; i++) - Console.Write (' '); - max_rendered = shown_prompt.Length + rendered_text.Length; - - // Write one more to ensure that we always wrap around properly if we are at the - // end of a line. - Console.Write (' '); - - UpdateHomeRow (max); - } - - void UpdateHomeRow (int screenpos) - { - int lines = 1 + (screenpos / Console.WindowWidth); - - home_row = Console.CursorTop - (lines - 1); - if (home_row < 0) - home_row = 0; - } - - - void RenderFrom (int pos) - { - int rpos = TextToRenderPos (pos); - int i; - - for (i = rpos; i < rendered_text.Length; i++) - Console.Write (rendered_text [i]); - - if ((shown_prompt.Length + rendered_text.Length) > max_rendered) - max_rendered = shown_prompt.Length + rendered_text.Length; - else { - int max_extra = max_rendered - shown_prompt.Length; - for (; i < max_extra; i++) - Console.Write (' '); - } - } - - void ComputeRendered () - { - rendered_text.Length = 0; - - for (int i = 0; i < text.Length; i++){ - int c = (int) text [i]; - if (c < 26){ - if (c == '\t') - rendered_text.Append (" "); - else { - rendered_text.Append ('^'); - rendered_text.Append ((char) (c + (int) 'A' - 1)); - } - } else - rendered_text.Append ((char)c); - } - } - - int TextToRenderPos (int pos) - { - int p = 0; - - for (int i = 0; i < pos; i++){ - int c; - - c = (int) text [i]; - - if (c < 26){ - if (c == 9) - p += 4; - else - p += 2; - } else - p++; - } - - return p; - } - - int TextToScreenPos (int pos) - { - return shown_prompt.Length + TextToRenderPos (pos); - } - - string Prompt { - get { return prompt; } - set { prompt = value; } - } - - int LineCount { - get { - return (shown_prompt.Length + rendered_text.Length)/Console.WindowWidth; - } - } - - void ForceCursor (int newpos) - { - cursor = newpos; - - int actual_pos = shown_prompt.Length + TextToRenderPos (cursor); - int row = home_row + (actual_pos/Console.WindowWidth); - int col = actual_pos % Console.WindowWidth; - - if (row >= Console.BufferHeight) - row = Console.BufferHeight-1; - Console.SetCursorPosition (col, row); - - //log.WriteLine ("Going to cursor={0} row={1} col={2} actual={3} prompt={4} ttr={5} old={6}", newpos, row, col, actual_pos, prompt.Length, TextToRenderPos (cursor), cursor); - //log.Flush (); - } - - void UpdateCursor (int newpos) - { - if (cursor == newpos) - return; - - ForceCursor (newpos); - } - - void InsertChar (char c) - { - int prev_lines = LineCount; - text = text.Insert (cursor, c); - ComputeRendered (); - if (prev_lines != LineCount){ - - Console.SetCursorPosition (0, home_row); - Render (); - ForceCursor (++cursor); - } else { - RenderFrom (cursor); - ForceCursor (++cursor); - UpdateHomeRow (TextToScreenPos (cursor)); - } - } - - // - // Commands - // - void CmdDone () - { - done = true; - } - - void CmdTabOrComplete () - { - bool complete = false; - - if (AutoCompleteEvent != null){ - if (TabAtStartCompletes) - complete = true; - else { - for (int i = 0; i < cursor; i++){ - if (!Char.IsWhiteSpace (text [i])){ - complete = true; - break; - } - } - } - - if (complete){ - Completion completion = AutoCompleteEvent (text.ToString (), cursor); - string [] completions = completion.Result; - if (completions == null) - return; - - int ncompletions = completions.Length; - if (ncompletions == 0) - return; - - if (completions.Length == 1){ - InsertTextAtCursor (completions [0]); - } else { - int last = -1; - - for (int p = 0; p < completions [0].Length; p++){ - char c = completions [0][p]; - - - for (int i = 1; i < ncompletions; i++){ - if (completions [i].Length < p) - goto mismatch; - - if (completions [i][p] != c){ - goto mismatch; - } - } - last = p; - } - mismatch: - if (last != -1){ - InsertTextAtCursor (completions [0].Substring (0, last+1)); - } - Console.WriteLine (); - foreach (string s in completions){ - Console.Write (completion.Prefix); - Console.Write (s); - Console.Write (' '); - } - Console.WriteLine (); - Render (); - ForceCursor (cursor); - } - } else - HandleChar ('\t'); - } else - HandleChar ('t'); - } - - void CmdHome () - { - UpdateCursor (0); - } - - void CmdEnd () - { - UpdateCursor (text.Length); - } - - void CmdLeft () - { - if (cursor == 0) - return; - - UpdateCursor (cursor-1); - } - - void CmdBackwardWord () - { - int p = WordBackward (cursor); - if (p == -1) - return; - UpdateCursor (p); - } - - void CmdForwardWord () - { - int p = WordForward (cursor); - if (p == -1) - return; - UpdateCursor (p); - } - - void CmdRight () - { - if (cursor == text.Length) - return; - - UpdateCursor (cursor+1); - } - - void RenderAfter (int p) - { - ForceCursor (p); - RenderFrom (p); - ForceCursor (cursor); - } - - void CmdBackspace () - { - if (cursor == 0) - return; - - text.Remove (--cursor, 1); - ComputeRendered (); - RenderAfter (cursor); - } - - void CmdDeleteChar () - { - // If there is no input, this behaves like EOF - if (text.Length == 0){ - done = true; - text = null; - Console.WriteLine (); - return; - } - - if (cursor == text.Length) - return; - text.Remove (cursor, 1); - ComputeRendered (); - RenderAfter (cursor); - } - - int WordForward (int p) - { - if (p >= text.Length) - return -1; - - int i = p; - if (Char.IsPunctuation (text [p]) || Char.IsSymbol (text [p]) || Char.IsWhiteSpace (text[p])){ - for (; i < text.Length; i++){ - if (Char.IsLetterOrDigit (text [i])) - break; - } - for (; i < text.Length; i++){ - if (!Char.IsLetterOrDigit (text [i])) - break; - } - } else { - for (; i < text.Length; i++){ - if (!Char.IsLetterOrDigit (text [i])) - break; - } - } - if (i != p) - return i; - return -1; - } - - int WordBackward (int p) - { - if (p == 0) - return -1; - - int i = p-1; - if (i == 0) - return 0; - - if (Char.IsPunctuation (text [i]) || Char.IsSymbol (text [i]) || Char.IsWhiteSpace (text[i])){ - for (; i >= 0; i--){ - if (Char.IsLetterOrDigit (text [i])) - break; - } - for (; i >= 0; i--){ - if (!Char.IsLetterOrDigit (text[i])) - break; - } - } else { - for (; i >= 0; i--){ - if (!Char.IsLetterOrDigit (text [i])) - break; - } - } - i++; - - if (i != p) - return i; - - return -1; - } - - void CmdDeleteWord () - { - int pos = WordForward (cursor); - - if (pos == -1) - return; - - string k = text.ToString (cursor, pos-cursor); - - if (last_handler == CmdDeleteWord) - kill_buffer = kill_buffer + k; - else - kill_buffer = k; - - text.Remove (cursor, pos-cursor); - ComputeRendered (); - RenderAfter (cursor); - } - - void CmdDeleteBackword () - { - int pos = WordBackward (cursor); - if (pos == -1) - return; - - string k = text.ToString (pos, cursor-pos); - - if (last_handler == CmdDeleteBackword) - kill_buffer = k + kill_buffer; - else - kill_buffer = k; - - text.Remove (pos, cursor-pos); - ComputeRendered (); - RenderAfter (pos); - } - - // - // Adds the current line to the history if needed - // - void HistoryUpdateLine () - { - history.Update (text.ToString ()); - } - - void CmdHistoryPrev () - { - if (!history.PreviousAvailable ()) - return; - - HistoryUpdateLine (); - - SetText (history.Previous ()); - } - - void CmdHistoryNext () - { - if (!history.NextAvailable()) - return; - - history.Update (text.ToString ()); - SetText (history.Next ()); - - } - - void CmdKillToEOF () - { - kill_buffer = text.ToString (cursor, text.Length-cursor); - text.Length = cursor; - ComputeRendered (); - RenderAfter (cursor); - } - - void CmdYank () - { - InsertTextAtCursor (kill_buffer); - } - - void InsertTextAtCursor (string str) - { - int prev_lines = LineCount; - text.Insert (cursor, str); - ComputeRendered (); - if (prev_lines != LineCount){ - Console.SetCursorPosition (0, home_row); - Render (); - cursor += str.Length; - ForceCursor (cursor); - } else { - RenderFrom (cursor); - cursor += str.Length; - ForceCursor (cursor); - UpdateHomeRow (TextToScreenPos (cursor)); - } - } - - void SetSearchPrompt (string s) - { - SetPrompt ("(reverse-i-search)`" + s + "': "); - } - - void ReverseSearch () - { - int p; - - if (cursor == text.Length){ - // The cursor is at the end of the string - - p = text.ToString ().LastIndexOf (search); - if (p != -1){ - match_at = p; - cursor = p; - ForceCursor (cursor); - return; - } - } else { - // The cursor is somewhere in the middle of the string - int start = (cursor == match_at) ? cursor - 1 : cursor; - if (start != -1){ - p = text.ToString ().LastIndexOf (search, start); - if (p != -1){ - match_at = p; - cursor = p; - ForceCursor (cursor); - return; - } - } - } - - // Need to search backwards in history - HistoryUpdateLine (); - string s = history.SearchBackward (search); - if (s != null){ - match_at = -1; - SetText (s); - ReverseSearch (); - } - } - - void CmdReverseSearch () - { - if (searching == 0){ - match_at = -1; - last_search = search; - searching = -1; - search = ""; - SetSearchPrompt (""); - } else { - if (search == ""){ - if (last_search != "" && last_search != null){ - search = last_search; - SetSearchPrompt (search); - - ReverseSearch (); - } - return; - } - ReverseSearch (); - } - } - - void SearchAppend (char c) - { - search = search + c; - SetSearchPrompt (search); - - // - // If the new typed data still matches the current text, stay here - // - if (cursor < text.Length){ - string r = text.ToString (cursor, text.Length - cursor); - if (r.StartsWith (search)) - return; - } - - ReverseSearch (); - } - - void CmdRefresh () - { - Console.Clear (); - max_rendered = 0; - Render (); - ForceCursor (cursor); - } - - void InterruptEdit (object sender, ConsoleCancelEventArgs a) - { - // Do not abort our program: - a.Cancel = true; - - // Interrupt the editor - edit_thread.Abort(); - } - - void HandleChar (char c) - { - if (searching != 0) - SearchAppend (c); - else - InsertChar (c); - } - - void EditLoop () - { - ConsoleKeyInfo cki; - - while (!done){ - ConsoleModifiers mod; - - cki = Console.ReadKey (true); - if (cki.Key == ConsoleKey.Escape){ - cki = Console.ReadKey (true); - - mod = ConsoleModifiers.Alt; - } else - mod = cki.Modifiers; - - bool handled = false; - - foreach (Handler handler in handlers){ - ConsoleKeyInfo t = handler.CKI; - - if (t.Key == cki.Key && t.Modifiers == mod){ - handled = true; - handler.KeyHandler (); - last_handler = handler.KeyHandler; - break; - } else if (t.KeyChar == cki.KeyChar && t.Key == ConsoleKey.Zoom){ - handled = true; - handler.KeyHandler (); - last_handler = handler.KeyHandler; - break; - } - } - if (handled){ - if (searching != 0){ - if (last_handler != CmdReverseSearch){ - searching = 0; - SetPrompt (prompt); - } - } - continue; - } - - if (cki.KeyChar != (char) 0) - HandleChar (cki.KeyChar); - } - } - - void InitText (string initial) - { - text = new StringBuilder (initial); - ComputeRendered (); - cursor = text.Length; - Render (); - ForceCursor (cursor); - } - - void SetText (string newtext) - { - Console.SetCursorPosition (0, home_row); - InitText (newtext); - } - - void SetPrompt (string newprompt) - { - shown_prompt = newprompt; - Console.SetCursorPosition (0, home_row); - Render (); - ForceCursor (cursor); - } - - public string Edit (string prompt, string initial) - { - edit_thread = Thread.CurrentThread; - searching = 0; - Console.CancelKeyPress += InterruptEdit; - - done = false; - history.CursorToEnd (); - max_rendered = 0; - - Prompt = prompt; - shown_prompt = prompt; - InitText (initial); - history.Append (initial); - - do { - try { - EditLoop (); - } catch (ThreadAbortException){ - searching = 0; - Thread.ResetAbort (); - Console.WriteLine (); - SetPrompt (prompt); - SetText (""); - } - } while (!done); - Console.WriteLine (); - - Console.CancelKeyPress -= InterruptEdit; - - if (text == null){ - history.Close (); - return null; - } - - string result = text.ToString (); - if (result != "") - history.Accept (result); - else - history.RemoveLast (); - - return result; - } - - public void SaveHistory () - { - if (history != null) { - history.Close (); - } - } - - public bool TabAtStartCompletes { get; set; } - - // - // Emulates the bash-like behavior, where edits done to the - // history are recorded - // - class History { - string [] history; - int head, tail; - int cursor, count; - string histfile; - - public History (string app, int size) - { - if (size < 1) - throw new ArgumentException ("size"); - - if (app != null){ - string dir = Environment.GetFolderPath (Environment.SpecialFolder.Personal); - //Console.WriteLine (dir); -// if (!Directory.Exists (dir)){ -// try { -// Directory.CreateDirectory (dir); -// } catch { -// app = null; -// } -// } -// if (app != null) -// histfile = Path.Combine (dir, app) + ".history"; - histfile = Path.Combine (dir, ".mal-history"); - } - - history = new string [size]; - head = tail = cursor = 0; - - if (File.Exists (histfile)){ - using (StreamReader sr = File.OpenText (histfile)){ - string line; - - while ((line = sr.ReadLine ()) != null){ - if (line != "") - Append (line); - } - } - } - } - - public void Close () - { - if (histfile == null) - return; - - try { - using (StreamWriter sw = File.CreateText (histfile)){ - int start = (count == history.Length) ? head : tail; - for (int i = start; i < start+count; i++){ - int p = i % history.Length; - sw.WriteLine (history [p]); - } - } - } catch { - // ignore - } - } - - // - // Appends a value to the history - // - public void Append (string s) - { - //Console.WriteLine ("APPENDING {0} head={1} tail={2}", s, head, tail); - history [head] = s; - head = (head+1) % history.Length; - if (head == tail) - tail = (tail+1 % history.Length); - if (count != history.Length) - count++; - //Console.WriteLine ("DONE: head={1} tail={2}", s, head, tail); - } - - // - // Updates the current cursor location with the string, - // to support editing of history items. For the current - // line to participate, an Append must be done before. - // - public void Update (string s) - { - history [cursor] = s; - } - - public void RemoveLast () - { - head = head-1; - if (head < 0) - head = history.Length-1; - } - - public void Accept (string s) - { - int t = head-1; - if (t < 0) - t = history.Length-1; - - history [t] = s; - } - - public bool PreviousAvailable () - { - //Console.WriteLine ("h={0} t={1} cursor={2}", head, tail, cursor); - if (count == 0) - return false; - int next = cursor-1; - if (next < 0) - next = count-1; - - if (next == head) - return false; - - return true; - } - - public bool NextAvailable () - { - if (count == 0) - return false; - int next = (cursor + 1) % history.Length; - if (next == head) - return false; - return true; - } - - - // - // Returns: a string with the previous line contents, or - // nul if there is no data in the history to move to. - // - public string Previous () - { - if (!PreviousAvailable ()) - return null; - - cursor--; - if (cursor < 0) - cursor = history.Length - 1; - - return history [cursor]; - } - - public string Next () - { - if (!NextAvailable ()) - return null; - - cursor = (cursor + 1) % history.Length; - return history [cursor]; - } - - public void CursorToEnd () - { - if (head == tail) - return; - - cursor = head; - } - - public void Dump () - { - Console.WriteLine ("Head={0} Tail={1} Cursor={2} count={3}", head, tail, cursor, count); - for (int i = 0; i < history.Length;i++){ - Console.WriteLine (" {0} {1}: {2}", i == cursor ? "==>" : " ", i, history[i]); - } - //log.Flush (); - } - - public string SearchBackward (string term) - { - for (int i = 0; i < count; i++){ - int slot = cursor-i-1; - if (slot < 0) - slot = history.Length+slot; - if (slot >= history.Length) - slot = 0; - if (history [slot] != null && history [slot].IndexOf (term) != -1){ - cursor = slot; - return history [slot]; - } - } - - return null; - } - - } - } - -#if DEMO - class Demo { - static void Main () - { - LineEditor le = new LineEditor ("foo"); - string s; - - while ((s = le.Edit ("shell> ", "")) != null){ - Console.WriteLine ("----> [{0}]", s); - } - } - } -#endif -} +// +// getline.cs: A command line editor +// +// Authors: +// Miguel de Icaza (miguel@novell.com) +// +// Copyright 2008 Novell, Inc. +// +// Dual-licensed under the terms of the MIT X11 license or the +// Apache License 2.0 +// +// USE -define:DEMO to build this as a standalone file and test it +// +// TODO: +// Enter an error (a = 1); Notice how the prompt is in the wrong line +// This is caused by Stderr not being tracked by System.Console. +// Completion support +// Why is Thread.Interrupt not working? Currently I resort to Abort which is too much. +// +// Limitations in System.Console: +// Console needs SIGWINCH support of some sort +// Console needs a way of updating its position after things have been written +// behind its back (P/Invoke puts for example). +// System.Console needs to get the DELETE character, and report accordingly. +// + +using System; +using System.Text; +using System.IO; +using System.Threading; +using System.Reflection; + +namespace Mono.Terminal { + + public class LineEditor { + + public class Completion { + public string [] Result; + public string Prefix; + + public Completion (string prefix, string [] result) + { + Prefix = prefix; + Result = result; + } + } + + public delegate Completion AutoCompleteHandler (string text, int pos); + + //static StreamWriter log; + + // The text being edited. + StringBuilder text; + + // The text as it is rendered (replaces (char)1 with ^A on display for example). + StringBuilder rendered_text; + + // The prompt specified, and the prompt shown to the user. + string prompt; + string shown_prompt; + + // The current cursor position, indexes into "text", for an index + // into rendered_text, use TextToRenderPos + int cursor; + + // The row where we started displaying data. + int home_row; + + // The maximum length that has been displayed on the screen + int max_rendered; + + // If we are done editing, this breaks the interactive loop + bool done = false; + + // The thread where the Editing started taking place + Thread edit_thread; + + // Our object that tracks history + History history; + + // The contents of the kill buffer (cut/paste in Emacs parlance) + string kill_buffer = ""; + + // The string being searched for + string search; + string last_search; + + // whether we are searching (-1= reverse; 0 = no; 1 = forward) + int searching; + + // The position where we found the match. + int match_at; + + // Used to implement the Kill semantics (multiple Alt-Ds accumulate) + KeyHandler last_handler; + + delegate void KeyHandler (); + + struct Handler { + public ConsoleKeyInfo CKI; + public KeyHandler KeyHandler; + + public Handler (ConsoleKey key, KeyHandler h) + { + CKI = new ConsoleKeyInfo ((char) 0, key, false, false, false); + KeyHandler = h; + } + + public Handler (char c, KeyHandler h) + { + KeyHandler = h; + // Use the "Zoom" as a flag that we only have a character. + CKI = new ConsoleKeyInfo (c, ConsoleKey.Zoom, false, false, false); + } + + public Handler (ConsoleKeyInfo cki, KeyHandler h) + { + CKI = cki; + KeyHandler = h; + } + + public static Handler Control (char c, KeyHandler h) + { + return new Handler ((char) (c - 'A' + 1), h); + } + + public static Handler Alt (char c, ConsoleKey k, KeyHandler h) + { + ConsoleKeyInfo cki = new ConsoleKeyInfo ((char) c, k, false, true, false); + return new Handler (cki, h); + } + } + + /// + /// Invoked when the user requests auto-completion using the tab character + /// + /// + /// The result is null for no values found, an array with a single + /// string, in that case the string should be the text to be inserted + /// for example if the word at pos is "T", the result for a completion + /// of "ToString" should be "oString", not "ToString". + /// + /// When there are multiple results, the result should be the full + /// text + /// + public AutoCompleteHandler AutoCompleteEvent; + + static Handler [] handlers; + + public LineEditor (string name) : this (name, 10) { } + + public LineEditor (string name, int histsize) + { + handlers = new Handler [] { + new Handler (ConsoleKey.Home, CmdHome), + new Handler (ConsoleKey.End, CmdEnd), + new Handler (ConsoleKey.LeftArrow, CmdLeft), + new Handler (ConsoleKey.RightArrow, CmdRight), + new Handler (ConsoleKey.UpArrow, CmdHistoryPrev), + new Handler (ConsoleKey.DownArrow, CmdHistoryNext), + new Handler (ConsoleKey.Enter, CmdDone), + new Handler (ConsoleKey.Backspace, CmdBackspace), + new Handler (ConsoleKey.Delete, CmdDeleteChar), + new Handler (ConsoleKey.Tab, CmdTabOrComplete), + + // Emacs keys + Handler.Control ('A', CmdHome), + Handler.Control ('E', CmdEnd), + Handler.Control ('B', CmdLeft), + Handler.Control ('F', CmdRight), + Handler.Control ('P', CmdHistoryPrev), + Handler.Control ('N', CmdHistoryNext), + Handler.Control ('K', CmdKillToEOF), + Handler.Control ('Y', CmdYank), + Handler.Control ('D', CmdDeleteChar), + Handler.Control ('L', CmdRefresh), + Handler.Control ('R', CmdReverseSearch), + Handler.Control ('G', delegate {} ), + Handler.Alt ('B', ConsoleKey.B, CmdBackwardWord), + Handler.Alt ('F', ConsoleKey.F, CmdForwardWord), + + Handler.Alt ('D', ConsoleKey.D, CmdDeleteWord), + Handler.Alt ((char) 8, ConsoleKey.Backspace, CmdDeleteBackword), + + // DEBUG + //Handler.Control ('T', CmdDebug), + + // quote + Handler.Control ('Q', delegate { HandleChar (Console.ReadKey (true).KeyChar); }) + }; + + rendered_text = new StringBuilder (); + text = new StringBuilder (); + + history = new History (name, histsize); + + //if (File.Exists ("log"))File.Delete ("log"); + //log = File.CreateText ("log"); + } + + void CmdDebug () + { + history.Dump (); + Console.WriteLine (); + Render (); + } + + void Render () + { + Console.Write (shown_prompt); + Console.Write (rendered_text); + + int max = System.Math.Max (rendered_text.Length + shown_prompt.Length, max_rendered); + + for (int i = rendered_text.Length + shown_prompt.Length; i < max_rendered; i++) + Console.Write (' '); + max_rendered = shown_prompt.Length + rendered_text.Length; + + // Write one more to ensure that we always wrap around properly if we are at the + // end of a line. + Console.Write (' '); + + UpdateHomeRow (max); + } + + void UpdateHomeRow (int screenpos) + { + int lines = 1 + (screenpos / Console.WindowWidth); + + home_row = Console.CursorTop - (lines - 1); + if (home_row < 0) + home_row = 0; + } + + + void RenderFrom (int pos) + { + int rpos = TextToRenderPos (pos); + int i; + + for (i = rpos; i < rendered_text.Length; i++) + Console.Write (rendered_text [i]); + + if ((shown_prompt.Length + rendered_text.Length) > max_rendered) + max_rendered = shown_prompt.Length + rendered_text.Length; + else { + int max_extra = max_rendered - shown_prompt.Length; + for (; i < max_extra; i++) + Console.Write (' '); + } + } + + void ComputeRendered () + { + rendered_text.Length = 0; + + for (int i = 0; i < text.Length; i++){ + int c = (int) text [i]; + if (c < 26){ + if (c == '\t') + rendered_text.Append (" "); + else { + rendered_text.Append ('^'); + rendered_text.Append ((char) (c + (int) 'A' - 1)); + } + } else + rendered_text.Append ((char)c); + } + } + + int TextToRenderPos (int pos) + { + int p = 0; + + for (int i = 0; i < pos; i++){ + int c; + + c = (int) text [i]; + + if (c < 26){ + if (c == 9) + p += 4; + else + p += 2; + } else + p++; + } + + return p; + } + + int TextToScreenPos (int pos) + { + return shown_prompt.Length + TextToRenderPos (pos); + } + + string Prompt { + get { return prompt; } + set { prompt = value; } + } + + int LineCount { + get { + return (shown_prompt.Length + rendered_text.Length)/Console.WindowWidth; + } + } + + void ForceCursor (int newpos) + { + cursor = newpos; + + int actual_pos = shown_prompt.Length + TextToRenderPos (cursor); + int row = home_row + (actual_pos/Console.WindowWidth); + int col = actual_pos % Console.WindowWidth; + + if (row >= Console.BufferHeight) + row = Console.BufferHeight-1; + Console.SetCursorPosition (col, row); + + //log.WriteLine ("Going to cursor={0} row={1} col={2} actual={3} prompt={4} ttr={5} old={6}", newpos, row, col, actual_pos, prompt.Length, TextToRenderPos (cursor), cursor); + //log.Flush (); + } + + void UpdateCursor (int newpos) + { + if (cursor == newpos) + return; + + ForceCursor (newpos); + } + + void InsertChar (char c) + { + int prev_lines = LineCount; + text = text.Insert (cursor, c); + ComputeRendered (); + if (prev_lines != LineCount){ + + Console.SetCursorPosition (0, home_row); + Render (); + ForceCursor (++cursor); + } else { + RenderFrom (cursor); + ForceCursor (++cursor); + UpdateHomeRow (TextToScreenPos (cursor)); + } + } + + // + // Commands + // + void CmdDone () + { + done = true; + } + + void CmdTabOrComplete () + { + bool complete = false; + + if (AutoCompleteEvent != null){ + if (TabAtStartCompletes) + complete = true; + else { + for (int i = 0; i < cursor; i++){ + if (!Char.IsWhiteSpace (text [i])){ + complete = true; + break; + } + } + } + + if (complete){ + Completion completion = AutoCompleteEvent (text.ToString (), cursor); + string [] completions = completion.Result; + if (completions == null) + return; + + int ncompletions = completions.Length; + if (ncompletions == 0) + return; + + if (completions.Length == 1){ + InsertTextAtCursor (completions [0]); + } else { + int last = -1; + + for (int p = 0; p < completions [0].Length; p++){ + char c = completions [0][p]; + + + for (int i = 1; i < ncompletions; i++){ + if (completions [i].Length < p) + goto mismatch; + + if (completions [i][p] != c){ + goto mismatch; + } + } + last = p; + } + mismatch: + if (last != -1){ + InsertTextAtCursor (completions [0].Substring (0, last+1)); + } + Console.WriteLine (); + foreach (string s in completions){ + Console.Write (completion.Prefix); + Console.Write (s); + Console.Write (' '); + } + Console.WriteLine (); + Render (); + ForceCursor (cursor); + } + } else + HandleChar ('\t'); + } else + HandleChar ('t'); + } + + void CmdHome () + { + UpdateCursor (0); + } + + void CmdEnd () + { + UpdateCursor (text.Length); + } + + void CmdLeft () + { + if (cursor == 0) + return; + + UpdateCursor (cursor-1); + } + + void CmdBackwardWord () + { + int p = WordBackward (cursor); + if (p == -1) + return; + UpdateCursor (p); + } + + void CmdForwardWord () + { + int p = WordForward (cursor); + if (p == -1) + return; + UpdateCursor (p); + } + + void CmdRight () + { + if (cursor == text.Length) + return; + + UpdateCursor (cursor+1); + } + + void RenderAfter (int p) + { + ForceCursor (p); + RenderFrom (p); + ForceCursor (cursor); + } + + void CmdBackspace () + { + if (cursor == 0) + return; + + text.Remove (--cursor, 1); + ComputeRendered (); + RenderAfter (cursor); + } + + void CmdDeleteChar () + { + // If there is no input, this behaves like EOF + if (text.Length == 0){ + done = true; + text = null; + Console.WriteLine (); + return; + } + + if (cursor == text.Length) + return; + text.Remove (cursor, 1); + ComputeRendered (); + RenderAfter (cursor); + } + + int WordForward (int p) + { + if (p >= text.Length) + return -1; + + int i = p; + if (Char.IsPunctuation (text [p]) || Char.IsSymbol (text [p]) || Char.IsWhiteSpace (text[p])){ + for (; i < text.Length; i++){ + if (Char.IsLetterOrDigit (text [i])) + break; + } + for (; i < text.Length; i++){ + if (!Char.IsLetterOrDigit (text [i])) + break; + } + } else { + for (; i < text.Length; i++){ + if (!Char.IsLetterOrDigit (text [i])) + break; + } + } + if (i != p) + return i; + return -1; + } + + int WordBackward (int p) + { + if (p == 0) + return -1; + + int i = p-1; + if (i == 0) + return 0; + + if (Char.IsPunctuation (text [i]) || Char.IsSymbol (text [i]) || Char.IsWhiteSpace (text[i])){ + for (; i >= 0; i--){ + if (Char.IsLetterOrDigit (text [i])) + break; + } + for (; i >= 0; i--){ + if (!Char.IsLetterOrDigit (text[i])) + break; + } + } else { + for (; i >= 0; i--){ + if (!Char.IsLetterOrDigit (text [i])) + break; + } + } + i++; + + if (i != p) + return i; + + return -1; + } + + void CmdDeleteWord () + { + int pos = WordForward (cursor); + + if (pos == -1) + return; + + string k = text.ToString (cursor, pos-cursor); + + if (last_handler == CmdDeleteWord) + kill_buffer = kill_buffer + k; + else + kill_buffer = k; + + text.Remove (cursor, pos-cursor); + ComputeRendered (); + RenderAfter (cursor); + } + + void CmdDeleteBackword () + { + int pos = WordBackward (cursor); + if (pos == -1) + return; + + string k = text.ToString (pos, cursor-pos); + + if (last_handler == CmdDeleteBackword) + kill_buffer = k + kill_buffer; + else + kill_buffer = k; + + text.Remove (pos, cursor-pos); + ComputeRendered (); + RenderAfter (pos); + } + + // + // Adds the current line to the history if needed + // + void HistoryUpdateLine () + { + history.Update (text.ToString ()); + } + + void CmdHistoryPrev () + { + if (!history.PreviousAvailable ()) + return; + + HistoryUpdateLine (); + + SetText (history.Previous ()); + } + + void CmdHistoryNext () + { + if (!history.NextAvailable()) + return; + + history.Update (text.ToString ()); + SetText (history.Next ()); + + } + + void CmdKillToEOF () + { + kill_buffer = text.ToString (cursor, text.Length-cursor); + text.Length = cursor; + ComputeRendered (); + RenderAfter (cursor); + } + + void CmdYank () + { + InsertTextAtCursor (kill_buffer); + } + + void InsertTextAtCursor (string str) + { + int prev_lines = LineCount; + text.Insert (cursor, str); + ComputeRendered (); + if (prev_lines != LineCount){ + Console.SetCursorPosition (0, home_row); + Render (); + cursor += str.Length; + ForceCursor (cursor); + } else { + RenderFrom (cursor); + cursor += str.Length; + ForceCursor (cursor); + UpdateHomeRow (TextToScreenPos (cursor)); + } + } + + void SetSearchPrompt (string s) + { + SetPrompt ("(reverse-i-search)`" + s + "': "); + } + + void ReverseSearch () + { + int p; + + if (cursor == text.Length){ + // The cursor is at the end of the string + + p = text.ToString ().LastIndexOf (search); + if (p != -1){ + match_at = p; + cursor = p; + ForceCursor (cursor); + return; + } + } else { + // The cursor is somewhere in the middle of the string + int start = (cursor == match_at) ? cursor - 1 : cursor; + if (start != -1){ + p = text.ToString ().LastIndexOf (search, start); + if (p != -1){ + match_at = p; + cursor = p; + ForceCursor (cursor); + return; + } + } + } + + // Need to search backwards in history + HistoryUpdateLine (); + string s = history.SearchBackward (search); + if (s != null){ + match_at = -1; + SetText (s); + ReverseSearch (); + } + } + + void CmdReverseSearch () + { + if (searching == 0){ + match_at = -1; + last_search = search; + searching = -1; + search = ""; + SetSearchPrompt (""); + } else { + if (search == ""){ + if (last_search != "" && last_search != null){ + search = last_search; + SetSearchPrompt (search); + + ReverseSearch (); + } + return; + } + ReverseSearch (); + } + } + + void SearchAppend (char c) + { + search = search + c; + SetSearchPrompt (search); + + // + // If the new typed data still matches the current text, stay here + // + if (cursor < text.Length){ + string r = text.ToString (cursor, text.Length - cursor); + if (r.StartsWith (search)) + return; + } + + ReverseSearch (); + } + + void CmdRefresh () + { + Console.Clear (); + max_rendered = 0; + Render (); + ForceCursor (cursor); + } + + void InterruptEdit (object sender, ConsoleCancelEventArgs a) + { + // Do not abort our program: + a.Cancel = true; + + // Interrupt the editor + edit_thread.Abort(); + } + + void HandleChar (char c) + { + if (searching != 0) + SearchAppend (c); + else + InsertChar (c); + } + + void EditLoop () + { + ConsoleKeyInfo cki; + + while (!done){ + ConsoleModifiers mod; + + cki = Console.ReadKey (true); + if (cki.Key == ConsoleKey.Escape){ + cki = Console.ReadKey (true); + + mod = ConsoleModifiers.Alt; + } else + mod = cki.Modifiers; + + bool handled = false; + + foreach (Handler handler in handlers){ + ConsoleKeyInfo t = handler.CKI; + + if (t.Key == cki.Key && t.Modifiers == mod){ + handled = true; + handler.KeyHandler (); + last_handler = handler.KeyHandler; + break; + } else if (t.KeyChar == cki.KeyChar && t.Key == ConsoleKey.Zoom){ + handled = true; + handler.KeyHandler (); + last_handler = handler.KeyHandler; + break; + } + } + if (handled){ + if (searching != 0){ + if (last_handler != CmdReverseSearch){ + searching = 0; + SetPrompt (prompt); + } + } + continue; + } + + if (cki.KeyChar != (char) 0) + HandleChar (cki.KeyChar); + } + } + + void InitText (string initial) + { + text = new StringBuilder (initial); + ComputeRendered (); + cursor = text.Length; + Render (); + ForceCursor (cursor); + } + + void SetText (string newtext) + { + Console.SetCursorPosition (0, home_row); + InitText (newtext); + } + + void SetPrompt (string newprompt) + { + shown_prompt = newprompt; + Console.SetCursorPosition (0, home_row); + Render (); + ForceCursor (cursor); + } + + public string Edit (string prompt, string initial) + { + edit_thread = Thread.CurrentThread; + searching = 0; + Console.CancelKeyPress += InterruptEdit; + + done = false; + history.CursorToEnd (); + max_rendered = 0; + + Prompt = prompt; + shown_prompt = prompt; + InitText (initial); + history.Append (initial); + + do { + try { + EditLoop (); + } catch (ThreadAbortException){ + searching = 0; + Thread.ResetAbort (); + Console.WriteLine (); + SetPrompt (prompt); + SetText (""); + } + } while (!done); + Console.WriteLine (); + + Console.CancelKeyPress -= InterruptEdit; + + if (text == null){ + history.Close (); + return null; + } + + string result = text.ToString (); + if (result != "") + history.Accept (result); + else + history.RemoveLast (); + + return result; + } + + public void SaveHistory () + { + if (history != null) { + history.Close (); + } + } + + public bool TabAtStartCompletes { get; set; } + + // + // Emulates the bash-like behavior, where edits done to the + // history are recorded + // + class History { + string [] history; + int head, tail; + int cursor, count; + string histfile; + + public History (string app, int size) + { + if (size < 1) + throw new ArgumentException ("size"); + + if (app != null){ + string dir = Environment.GetFolderPath (Environment.SpecialFolder.Personal); + //Console.WriteLine (dir); +// if (!Directory.Exists (dir)){ +// try { +// Directory.CreateDirectory (dir); +// } catch { +// app = null; +// } +// } +// if (app != null) +// histfile = Path.Combine (dir, app) + ".history"; + histfile = Path.Combine (dir, ".mal-history"); + } + + history = new string [size]; + head = tail = cursor = 0; + + if (File.Exists (histfile)){ + using (StreamReader sr = File.OpenText (histfile)){ + string line; + + while ((line = sr.ReadLine ()) != null){ + if (line != "") + Append (line); + } + } + } + } + + public void Close () + { + if (histfile == null) + return; + + try { + using (StreamWriter sw = File.CreateText (histfile)){ + int start = (count == history.Length) ? head : tail; + for (int i = start; i < start+count; i++){ + int p = i % history.Length; + sw.WriteLine (history [p]); + } + } + } catch { + // ignore + } + } + + // + // Appends a value to the history + // + public void Append (string s) + { + //Console.WriteLine ("APPENDING {0} head={1} tail={2}", s, head, tail); + history [head] = s; + head = (head+1) % history.Length; + if (head == tail) + tail = (tail+1 % history.Length); + if (count != history.Length) + count++; + //Console.WriteLine ("DONE: head={1} tail={2}", s, head, tail); + } + + // + // Updates the current cursor location with the string, + // to support editing of history items. For the current + // line to participate, an Append must be done before. + // + public void Update (string s) + { + history [cursor] = s; + } + + public void RemoveLast () + { + head = head-1; + if (head < 0) + head = history.Length-1; + } + + public void Accept (string s) + { + int t = head-1; + if (t < 0) + t = history.Length-1; + + history [t] = s; + } + + public bool PreviousAvailable () + { + //Console.WriteLine ("h={0} t={1} cursor={2}", head, tail, cursor); + if (count == 0) + return false; + int next = cursor-1; + if (next < 0) + next = count-1; + + if (next == head) + return false; + + return true; + } + + public bool NextAvailable () + { + if (count == 0) + return false; + int next = (cursor + 1) % history.Length; + if (next == head) + return false; + return true; + } + + + // + // Returns: a string with the previous line contents, or + // nul if there is no data in the history to move to. + // + public string Previous () + { + if (!PreviousAvailable ()) + return null; + + cursor--; + if (cursor < 0) + cursor = history.Length - 1; + + return history [cursor]; + } + + public string Next () + { + if (!NextAvailable ()) + return null; + + cursor = (cursor + 1) % history.Length; + return history [cursor]; + } + + public void CursorToEnd () + { + if (head == tail) + return; + + cursor = head; + } + + public void Dump () + { + Console.WriteLine ("Head={0} Tail={1} Cursor={2} count={3}", head, tail, cursor, count); + for (int i = 0; i < history.Length;i++){ + Console.WriteLine (" {0} {1}: {2}", i == cursor ? "==>" : " ", i, history[i]); + } + //log.Flush (); + } + + public string SearchBackward (string term) + { + for (int i = 0; i < count; i++){ + int slot = cursor-i-1; + if (slot < 0) + slot = history.Length+slot; + if (slot >= history.Length) + slot = 0; + if (history [slot] != null && history [slot].IndexOf (term) != -1){ + cursor = slot; + return history [slot]; + } + } + + return null; + } + + } + } + +#if DEMO + class Demo { + static void Main () + { + LineEditor le = new LineEditor ("foo"); + string s; + + while ((s = le.Edit ("shell> ", "")) != null){ + Console.WriteLine ("----> [{0}]", s); + } + } + } +#endif +} diff --git a/impls/cs/interop.cs b/impls/cs/interop.cs index e383280279..a4c10668ed 100644 --- a/impls/cs/interop.cs +++ b/impls/cs/interop.cs @@ -1,66 +1,66 @@ -using System; -using System.CodeDom.Compiler; -using System.Collections.Generic; -using System.Linq; -using System.Text; -using Microsoft.CSharp; - -public static class EvalProvider -{ - public static Func CreateEvalMethod(string code, string[] usingStatements = null, string[] assemblies = null) - { - Type returnType = typeof(TResult); - Type inputType = typeof(T); - - var includeUsings = new HashSet(new[] { "System" }); - includeUsings.Add(returnType.Namespace); - includeUsings.Add(inputType.Namespace); - if (usingStatements != null) - foreach (var usingStatement in usingStatements) - includeUsings.Add(usingStatement); - - using (CSharpCodeProvider compiler = new CSharpCodeProvider()) - { - var name = "F" + Guid.NewGuid().ToString().Replace("-", string.Empty); - var includeAssemblies = new HashSet(new[] { "system.dll" }); - if (assemblies != null) - foreach (var assembly in assemblies) - includeAssemblies.Add(assembly); - - var parameters = new CompilerParameters(includeAssemblies.ToArray()) - { - GenerateInMemory = true - }; - - string source = string.Format(@" -{0} -namespace {1} -{{ - public static class EvalClass - {{ - public static {2} Eval({3} arg) - {{ - {4} - }} - }} -}}", GetUsing(includeUsings), name, returnType.Name, inputType.Name, code); - - var compilerResult = compiler.CompileAssemblyFromSource(parameters, source); - var compiledAssembly = compilerResult.CompiledAssembly; - var type = compiledAssembly.GetType(string.Format("{0}.EvalClass", name)); - var method = type.GetMethod("Eval"); - return (Func)Delegate.CreateDelegate(typeof(Func), method); - } - } - - private static string GetUsing(HashSet usingStatements) - { - StringBuilder result = new StringBuilder(); - foreach (string usingStatement in usingStatements) - { - result.AppendLine(string.Format("using {0};", usingStatement)); - } - return result.ToString(); - } -} - +using System; +using System.CodeDom.Compiler; +using System.Collections.Generic; +using System.Linq; +using System.Text; +using Microsoft.CSharp; + +public static class EvalProvider +{ + public static Func CreateEvalMethod(string code, string[] usingStatements = null, string[] assemblies = null) + { + Type returnType = typeof(TResult); + Type inputType = typeof(T); + + var includeUsings = new HashSet(new[] { "System" }); + includeUsings.Add(returnType.Namespace); + includeUsings.Add(inputType.Namespace); + if (usingStatements != null) + foreach (var usingStatement in usingStatements) + includeUsings.Add(usingStatement); + + using (CSharpCodeProvider compiler = new CSharpCodeProvider()) + { + var name = "F" + Guid.NewGuid().ToString().Replace("-", string.Empty); + var includeAssemblies = new HashSet(new[] { "system.dll" }); + if (assemblies != null) + foreach (var assembly in assemblies) + includeAssemblies.Add(assembly); + + var parameters = new CompilerParameters(includeAssemblies.ToArray()) + { + GenerateInMemory = true + }; + + string source = string.Format(@" +{0} +namespace {1} +{{ + public static class EvalClass + {{ + public static {2} Eval({3} arg) + {{ + {4} + }} + }} +}}", GetUsing(includeUsings), name, returnType.Name, inputType.Name, code); + + var compilerResult = compiler.CompileAssemblyFromSource(parameters, source); + var compiledAssembly = compilerResult.CompiledAssembly; + var type = compiledAssembly.GetType(string.Format("{0}.EvalClass", name)); + var method = type.GetMethod("Eval"); + return (Func)Delegate.CreateDelegate(typeof(Func), method); + } + } + + private static string GetUsing(HashSet usingStatements) + { + StringBuilder result = new StringBuilder(); + foreach (string usingStatement in usingStatements) + { + result.AppendLine(string.Format("using {0};", usingStatement)); + } + return result.ToString(); + } +} + diff --git a/impls/cs/printer.cs b/impls/cs/printer.cs index 8b10dd17a8..767e07b486 100644 --- a/impls/cs/printer.cs +++ b/impls/cs/printer.cs @@ -1,49 +1,49 @@ -using System; -using System.Collections.Generic; -using System.Text.RegularExpressions; -using Mal; -using MalVal = Mal.types.MalVal; -using MalList = Mal.types.MalList; - -namespace Mal { - public class printer { - public static string join(List value, - string delim, bool print_readably) { - List strs = new List(); - foreach (MalVal mv in value) { - strs.Add(mv.ToString(print_readably)); - } - return String.Join(delim, strs.ToArray()); - } - - public static string join(Dictionary value, - string delim, bool print_readably) { - List strs = new List(); - foreach (KeyValuePair entry in value) { - if (entry.Key.Length > 0 && entry.Key[0] == '\u029e') { - strs.Add(":" + entry.Key.Substring(1)); - } else if (print_readably) { - strs.Add("\"" + entry.Key.ToString() + "\""); - } else { - strs.Add(entry.Key.ToString()); - } - strs.Add(entry.Value.ToString(print_readably)); - } - return String.Join(delim, strs.ToArray()); - } - - public static string _pr_str(MalVal mv, bool print_readably) { - return mv.ToString(print_readably); - } - - public static string _pr_str_args(MalList args, String sep, - bool print_readably) { - return join(args.getValue(), sep, print_readably); - } - - public static string escapeString(string str) { - return Regex.Escape(str); - } - - } -} +using System; +using System.Collections.Generic; +using System.Text.RegularExpressions; +using Mal; +using MalVal = Mal.types.MalVal; +using MalList = Mal.types.MalList; + +namespace Mal { + public class printer { + public static string join(List value, + string delim, bool print_readably) { + List strs = new List(); + foreach (MalVal mv in value) { + strs.Add(mv.ToString(print_readably)); + } + return String.Join(delim, strs.ToArray()); + } + + public static string join(Dictionary value, + string delim, bool print_readably) { + List strs = new List(); + foreach (KeyValuePair entry in value) { + if (entry.Key.Length > 0 && entry.Key[0] == '\u029e') { + strs.Add(":" + entry.Key.Substring(1)); + } else if (print_readably) { + strs.Add("\"" + entry.Key.ToString() + "\""); + } else { + strs.Add(entry.Key.ToString()); + } + strs.Add(entry.Value.ToString(print_readably)); + } + return String.Join(delim, strs.ToArray()); + } + + public static string _pr_str(MalVal mv, bool print_readably) { + return mv.ToString(print_readably); + } + + public static string _pr_str_args(MalList args, String sep, + bool print_readably) { + return join(args.getValue(), sep, print_readably); + } + + public static string escapeString(string str) { + return Regex.Escape(str); + } + + } +} diff --git a/impls/cs/reader.cs b/impls/cs/reader.cs index 7e0d6b5c35..ec75fd5f06 100644 --- a/impls/cs/reader.cs +++ b/impls/cs/reader.cs @@ -1,159 +1,159 @@ -using System; -using System.Collections; -using System.Collections.Generic; -using System.Text.RegularExpressions; -using Mal; -using MalVal = Mal.types.MalVal; -using MalSymbol = Mal.types.MalSymbol; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalThrowable = Mal.types.MalThrowable; -using MalContinue = Mal.types.MalContinue; - -namespace Mal { - public class reader { - public class ParseError : MalThrowable { - public ParseError(string msg) : base(msg) { } - } - - public class Reader { - List tokens; - int position; - public Reader(List t) { - tokens = t; - position = 0; - } - - public string peek() { - if (position >= tokens.Count) { - return null; - } else { - return tokens[position]; - } - } - public string next() { - return tokens[position++]; - } - } - - public static List tokenize(string str) { - List tokens = new List(); - string pattern = @"[\s ,]*(~@|[\[\]{}()'`~@]|""(?:[\\].|[^\\""])*""?|;.*|[^\s \[\]{}()'""`~@,;]*)"; - Regex regex = new Regex(pattern); - foreach (Match match in regex.Matches(str)) { - string token = match.Groups[1].Value; - if ((token != null) && !(token == "") && !(token[0] == ';')) { - //Console.WriteLine("match: ^" + match.Groups[1] + "$"); - tokens.Add(token); - } - } - return tokens; - } - - public static MalVal read_atom(Reader rdr) { - string token = rdr.next(); - string pattern = @"(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|(^""(?:[\\].|[^\\""])*""$)|(^"".*$)|:(.*)|(^[^""]*$)"; - Regex regex = new Regex(pattern); - Match match = regex.Match(token); - //Console.WriteLine("token: ^" + token + "$"); - if (!match.Success) { - throw new ParseError("unrecognized token '" + token + "'"); - } - if (match.Groups[1].Value != String.Empty) { - return new Mal.types.MalInt(int.Parse(match.Groups[1].Value)); - } else if (match.Groups[3].Value != String.Empty) { - return Mal.types.Nil; - } else if (match.Groups[4].Value != String.Empty) { - return Mal.types.True; - } else if (match.Groups[5].Value != String.Empty) { - return Mal.types.False; - } else if (match.Groups[6].Value != String.Empty) { - string str = match.Groups[6].Value; - str = str.Substring(1, str.Length-2) - .Replace("\\\\", "\u029e") - .Replace("\\\"", "\"") - .Replace("\\n", "\n") - .Replace("\u029e", "\\"); - return new Mal.types.MalString(str); - } else if (match.Groups[7].Value != String.Empty) { - throw new ParseError("expected '\"', got EOF"); - } else if (match.Groups[8].Value != String.Empty) { - return new Mal.types.MalString("\u029e" + match.Groups[8].Value); - } else if (match.Groups[9].Value != String.Empty) { - return new Mal.types.MalSymbol(match.Groups[9].Value); - } else { - throw new ParseError("unrecognized '" + match.Groups[0] + "'"); - } - } - - public static MalVal read_list(Reader rdr, MalList lst, char start, char end) { - string token = rdr.next(); - if (token[0] != start) { - throw new ParseError("expected '" + start + "'"); - } - - while ((token = rdr.peek()) != null && token[0] != end) { - lst.conj_BANG(read_form(rdr)); - } - - if (token == null) { - throw new ParseError("expected '" + end + "', got EOF"); - } - rdr.next(); - - return lst; - } - - public static MalVal read_hash_map(Reader rdr) { - MalList lst = (MalList)read_list(rdr, new MalList(), '{', '}'); - return new MalHashMap(lst); - } - - - public static MalVal read_form(Reader rdr) { - string token = rdr.peek(); - if (token == null) { throw new MalContinue(); } - MalVal form = null; - - switch (token) { - case "'": rdr.next(); - return new MalList(new MalSymbol("quote"), - read_form(rdr)); - case "`": rdr.next(); - return new MalList(new MalSymbol("quasiquote"), - read_form(rdr)); - case "~": - rdr.next(); - return new MalList(new MalSymbol("unquote"), - read_form(rdr)); - case "~@": - rdr.next(); - return new MalList(new MalSymbol("splice-unquote"), - read_form(rdr)); - case "^": rdr.next(); - MalVal meta = read_form(rdr); - return new MalList(new MalSymbol("with-meta"), - read_form(rdr), - meta); - case "@": rdr.next(); - return new MalList(new MalSymbol("deref"), - read_form(rdr)); - - case "(": form = read_list(rdr, new MalList(), '(' , ')'); break; - case ")": throw new ParseError("unexpected ')'"); - case "[": form = read_list(rdr, new MalVector(), '[' , ']'); break; - case "]": throw new ParseError("unexpected ']'"); - case "{": form = read_hash_map(rdr); break; - case "}": throw new ParseError("unexpected '}'"); - default: form = read_atom(rdr); break; - } - return form; - } - - - public static MalVal read_str(string str) { - return read_form(new Reader(tokenize(str))); - } - } -} +using System; +using System.Collections; +using System.Collections.Generic; +using System.Text.RegularExpressions; +using Mal; +using MalVal = Mal.types.MalVal; +using MalSymbol = Mal.types.MalSymbol; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalThrowable = Mal.types.MalThrowable; +using MalContinue = Mal.types.MalContinue; + +namespace Mal { + public class reader { + public class ParseError : MalThrowable { + public ParseError(string msg) : base(msg) { } + } + + public class Reader { + List tokens; + int position; + public Reader(List t) { + tokens = t; + position = 0; + } + + public string peek() { + if (position >= tokens.Count) { + return null; + } else { + return tokens[position]; + } + } + public string next() { + return tokens[position++]; + } + } + + public static List tokenize(string str) { + List tokens = new List(); + string pattern = @"[\s ,]*(~@|[\[\]{}()'`~@]|""(?:[\\].|[^\\""])*""?|;.*|[^\s \[\]{}()'""`~@,;]*)"; + Regex regex = new Regex(pattern); + foreach (Match match in regex.Matches(str)) { + string token = match.Groups[1].Value; + if ((token != null) && !(token == "") && !(token[0] == ';')) { + //Console.WriteLine("match: ^" + match.Groups[1] + "$"); + tokens.Add(token); + } + } + return tokens; + } + + public static MalVal read_atom(Reader rdr) { + string token = rdr.next(); + string pattern = @"(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|(^""(?:[\\].|[^\\""])*""$)|(^"".*$)|:(.*)|(^[^""]*$)"; + Regex regex = new Regex(pattern); + Match match = regex.Match(token); + //Console.WriteLine("token: ^" + token + "$"); + if (!match.Success) { + throw new ParseError("unrecognized token '" + token + "'"); + } + if (match.Groups[1].Value != String.Empty) { + return new Mal.types.MalInt(int.Parse(match.Groups[1].Value)); + } else if (match.Groups[3].Value != String.Empty) { + return Mal.types.Nil; + } else if (match.Groups[4].Value != String.Empty) { + return Mal.types.True; + } else if (match.Groups[5].Value != String.Empty) { + return Mal.types.False; + } else if (match.Groups[6].Value != String.Empty) { + string str = match.Groups[6].Value; + str = str.Substring(1, str.Length-2) + .Replace("\\\\", "\u029e") + .Replace("\\\"", "\"") + .Replace("\\n", "\n") + .Replace("\u029e", "\\"); + return new Mal.types.MalString(str); + } else if (match.Groups[7].Value != String.Empty) { + throw new ParseError("expected '\"', got EOF"); + } else if (match.Groups[8].Value != String.Empty) { + return new Mal.types.MalString("\u029e" + match.Groups[8].Value); + } else if (match.Groups[9].Value != String.Empty) { + return new Mal.types.MalSymbol(match.Groups[9].Value); + } else { + throw new ParseError("unrecognized '" + match.Groups[0] + "'"); + } + } + + public static MalVal read_list(Reader rdr, MalList lst, char start, char end) { + string token = rdr.next(); + if (token[0] != start) { + throw new ParseError("expected '" + start + "'"); + } + + while ((token = rdr.peek()) != null && token[0] != end) { + lst.conj_BANG(read_form(rdr)); + } + + if (token == null) { + throw new ParseError("expected '" + end + "', got EOF"); + } + rdr.next(); + + return lst; + } + + public static MalVal read_hash_map(Reader rdr) { + MalList lst = (MalList)read_list(rdr, new MalList(), '{', '}'); + return new MalHashMap(lst); + } + + + public static MalVal read_form(Reader rdr) { + string token = rdr.peek(); + if (token == null) { throw new MalContinue(); } + MalVal form = null; + + switch (token) { + case "'": rdr.next(); + return new MalList(new MalSymbol("quote"), + read_form(rdr)); + case "`": rdr.next(); + return new MalList(new MalSymbol("quasiquote"), + read_form(rdr)); + case "~": + rdr.next(); + return new MalList(new MalSymbol("unquote"), + read_form(rdr)); + case "~@": + rdr.next(); + return new MalList(new MalSymbol("splice-unquote"), + read_form(rdr)); + case "^": rdr.next(); + MalVal meta = read_form(rdr); + return new MalList(new MalSymbol("with-meta"), + read_form(rdr), + meta); + case "@": rdr.next(); + return new MalList(new MalSymbol("deref"), + read_form(rdr)); + + case "(": form = read_list(rdr, new MalList(), '(' , ')'); break; + case ")": throw new ParseError("unexpected ')'"); + case "[": form = read_list(rdr, new MalVector(), '[' , ']'); break; + case "]": throw new ParseError("unexpected ']'"); + case "{": form = read_hash_map(rdr); break; + case "}": throw new ParseError("unexpected '}'"); + default: form = read_atom(rdr); break; + } + return form; + } + + + public static MalVal read_str(string str) { + return read_form(new Reader(tokenize(str))); + } + } +} diff --git a/impls/cs/readline.cs b/impls/cs/readline.cs index 968e6f8e99..dc14cc8a90 100644 --- a/impls/cs/readline.cs +++ b/impls/cs/readline.cs @@ -1,24 +1,24 @@ -using System; -using Mono.Terminal; // LineEditor (getline.cs) - -namespace Mal { - public class readline { - public enum Mode { Terminal, Raw }; - public static Mode mode = Mode.Terminal; - - static LineEditor lineedit = null; - - public static string Readline(string prompt) { - if (mode == Mode.Terminal) { - if (lineedit == null) { - lineedit = new LineEditor("Mal"); - } - return lineedit.Edit(prompt, ""); - } else { - Console.Write(prompt); - Console.Out.Flush(); - return Console.ReadLine(); - } - } - } -} +using System; +using Mono.Terminal; // LineEditor (getline.cs) + +namespace Mal { + public class readline { + public enum Mode { Terminal, Raw }; + public static Mode mode = Mode.Terminal; + + static LineEditor lineedit = null; + + public static string Readline(string prompt) { + if (mode == Mode.Terminal) { + if (lineedit == null) { + lineedit = new LineEditor("Mal"); + } + return lineedit.Edit(prompt, ""); + } else { + Console.Write(prompt); + Console.Out.Flush(); + return Console.ReadLine(); + } + } + } +} diff --git a/impls/cs/run b/impls/cs/run index fa517a6ec7..6292af1203 100755 --- a/impls/cs/run +++ b/impls/cs/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec mono $(dirname $0)/${STEP:-stepA_mal}.exe ${RAW:+--raw} "${@}" +#!/bin/bash +exec mono $(dirname $0)/${STEP:-stepA_mal}.exe ${RAW:+--raw} "${@}" diff --git a/impls/cs/step0_repl.cs b/impls/cs/step0_repl.cs index 68cac94482..f29280bc57 100644 --- a/impls/cs/step0_repl.cs +++ b/impls/cs/step0_repl.cs @@ -1,47 +1,47 @@ -using System; -using System.IO; -using Mal; - -namespace Mal { - class step0_repl { - // read - static string READ(string str) { - return str; - } - - // eval - static string EVAL(string ast, string env) { - return ast; - } - - // print - static string PRINT(string exp) { - return exp; - } - - // repl - static string RE(string env, string str) { - return EVAL(READ(str), env); - } - - static void Main(string[] args) { - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - Console.WriteLine(PRINT(RE(null, line))); - } - } - } -} +using System; +using System.IO; +using Mal; + +namespace Mal { + class step0_repl { + // read + static string READ(string str) { + return str; + } + + // eval + static string EVAL(string ast, string env) { + return ast; + } + + // print + static string PRINT(string exp) { + return exp; + } + + // repl + static string RE(string env, string str) { + return EVAL(READ(str), env); + } + + static void Main(string[] args) { + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + Console.WriteLine(PRINT(RE(null, line))); + } + } + } +} diff --git a/impls/cs/step1_read_print.cs b/impls/cs/step1_read_print.cs index 43bf3c4582..02917036c8 100644 --- a/impls/cs/step1_read_print.cs +++ b/impls/cs/step1_read_print.cs @@ -1,54 +1,54 @@ -using System; -using System.IO; -using Mal; -using MalVal = Mal.types.MalVal; - -namespace Mal { - class step1_read_print { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - static MalVal EVAL(MalVal ast, string env) { - return ast; - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - Func RE = (string str) => EVAL(READ(str), ""); - - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using Mal; +using MalVal = Mal.types.MalVal; + +namespace Mal { + class step1_read_print { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + static MalVal EVAL(MalVal ast, string env) { + return ast; + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + Func RE = (string str) => EVAL(READ(str), ""); + + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/step2_eval.cs b/impls/cs/step2_eval.cs index 8c68336482..3591594f16 100644 --- a/impls/cs/step2_eval.cs +++ b/impls/cs/step2_eval.cs @@ -1,109 +1,109 @@ -using System; -using System.IO; -using System.Collections; -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalSymbol = Mal.types.MalSymbol; -using MalInt = Mal.types.MalInt; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalFunc = Mal.types.MalFunc; - -namespace Mal { - class step2_eval { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - static MalVal eval_ast(MalVal ast, Dictionary env) { - if (ast is MalSymbol) { - MalSymbol sym = (MalSymbol)ast; - return (MalVal)env[sym.getName()]; - } else if (ast is MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - foreach (MalVal mv in old_lst.getValue()) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast is MalHashMap) { - var new_dict = new Dictionary(); - foreach (var entry in ((MalHashMap)ast).getValue()) { - new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); - } - return new MalHashMap(new_dict); - } else { - return ast; - } - } - - - static MalVal EVAL(MalVal orig_ast, Dictionary env) { - MalVal a0; - //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast[0]; - if (!(a0 is MalSymbol)) { - throw new Mal.types.MalError("attempt to apply on non-symbol '" - + Mal.printer._pr_str(a0,true) + "'"); - } - var el = (MalList)eval_ast(ast, env); - var f = (MalFunc)el[0]; - return f.apply(el.rest()); - - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - var repl_env = new Dictionary { - {"+", new MalFunc(a => (MalInt)a[0] + (MalInt)a[1]) }, - {"-", new MalFunc(a => (MalInt)a[0] - (MalInt)a[1]) }, - {"*", new MalFunc(a => (MalInt)a[0] * (MalInt)a[1]) }, - {"/", new MalFunc(a => (MalInt)a[0] / (MalInt)a[1]) }, - }; - Func RE = (string str) => EVAL(READ(str), repl_env); - - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using System.Collections; +using System.Collections.Generic; +using Mal; +using MalVal = Mal.types.MalVal; +using MalSymbol = Mal.types.MalSymbol; +using MalInt = Mal.types.MalInt; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalFunc = Mal.types.MalFunc; + +namespace Mal { + class step2_eval { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + static MalVal eval_ast(MalVal ast, Dictionary env) { + if (ast is MalSymbol) { + MalSymbol sym = (MalSymbol)ast; + return (MalVal)env[sym.getName()]; + } else if (ast is MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + foreach (MalVal mv in old_lst.getValue()) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast is MalHashMap) { + var new_dict = new Dictionary(); + foreach (var entry in ((MalHashMap)ast).getValue()) { + new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); + } + return new MalHashMap(new_dict); + } else { + return ast; + } + } + + + static MalVal EVAL(MalVal orig_ast, Dictionary env) { + MalVal a0; + //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast[0]; + if (!(a0 is MalSymbol)) { + throw new Mal.types.MalError("attempt to apply on non-symbol '" + + Mal.printer._pr_str(a0,true) + "'"); + } + var el = (MalList)eval_ast(ast, env); + var f = (MalFunc)el[0]; + return f.apply(el.rest()); + + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + var repl_env = new Dictionary { + {"+", new MalFunc(a => (MalInt)a[0] + (MalInt)a[1]) }, + {"-", new MalFunc(a => (MalInt)a[0] - (MalInt)a[1]) }, + {"*", new MalFunc(a => (MalInt)a[0] * (MalInt)a[1]) }, + {"/", new MalFunc(a => (MalInt)a[0] / (MalInt)a[1]) }, + }; + Func RE = (string str) => EVAL(READ(str), repl_env); + + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/step3_env.cs b/impls/cs/step3_env.cs index 6c4f2fe193..d979d0a3df 100644 --- a/impls/cs/step3_env.cs +++ b/impls/cs/step3_env.cs @@ -1,134 +1,134 @@ -using System; -using System.IO; -using System.Collections; -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalSymbol = Mal.types.MalSymbol; -using MalInt = Mal.types.MalInt; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalFunc = Mal.types.MalFunc; -using Env = Mal.env.Env; - -namespace Mal { - class step3_env { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - static MalVal eval_ast(MalVal ast, Env env) { - if (ast is MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast is MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - foreach (MalVal mv in old_lst.getValue()) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast is MalHashMap) { - var new_dict = new Dictionary(); - foreach (var entry in ((MalHashMap)ast).getValue()) { - new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); - } - return new MalHashMap(new_dict); - } else { - return ast; - } - } - - - static MalVal EVAL(MalVal orig_ast, Env env) { - MalVal a0, a1, a2, res; - MalList el; - //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast[0]; - if (!(a0 is MalSymbol)) { - throw new Mal.types.MalError("attempt to apply on non-symbol '" - + Mal.printer._pr_str(a0,true) + "'"); - } - - switch (((MalSymbol)a0).getName()) { - case "def!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - env.set((MalSymbol)a1, res); - return res; - case "let*": - a1 = ast[1]; - a2 = ast[2]; - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1)[i]; - val = ((MalList)a1)[i+1]; - let_env.set(key, EVAL(val, let_env)); - } - return EVAL(a2, let_env); - default: - el = (MalList)eval_ast(ast, env); - var f = (MalFunc)el[0]; - return f.apply(el.rest()); - } - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - var repl_env = new Mal.env.Env(null); - Func RE = (string str) => EVAL(READ(str), repl_env); - repl_env.set(new MalSymbol("+"), new MalFunc( - a => (MalInt)a[0] + (MalInt)a[1]) ); - repl_env.set(new MalSymbol("-"), new MalFunc( - a => (MalInt)a[0] - (MalInt)a[1]) ); - repl_env.set(new MalSymbol("*"), new MalFunc( - a => (MalInt)a[0] * (MalInt)a[1]) ); - repl_env.set(new MalSymbol("/"), new MalFunc( - a => (MalInt)a[0] / (MalInt)a[1]) ); - - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using System.Collections; +using System.Collections.Generic; +using Mal; +using MalVal = Mal.types.MalVal; +using MalSymbol = Mal.types.MalSymbol; +using MalInt = Mal.types.MalInt; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalFunc = Mal.types.MalFunc; +using Env = Mal.env.Env; + +namespace Mal { + class step3_env { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + static MalVal eval_ast(MalVal ast, Env env) { + if (ast is MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast is MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + foreach (MalVal mv in old_lst.getValue()) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast is MalHashMap) { + var new_dict = new Dictionary(); + foreach (var entry in ((MalHashMap)ast).getValue()) { + new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); + } + return new MalHashMap(new_dict); + } else { + return ast; + } + } + + + static MalVal EVAL(MalVal orig_ast, Env env) { + MalVal a0, a1, a2, res; + MalList el; + //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast[0]; + if (!(a0 is MalSymbol)) { + throw new Mal.types.MalError("attempt to apply on non-symbol '" + + Mal.printer._pr_str(a0,true) + "'"); + } + + switch (((MalSymbol)a0).getName()) { + case "def!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + env.set((MalSymbol)a1, res); + return res; + case "let*": + a1 = ast[1]; + a2 = ast[2]; + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1)[i]; + val = ((MalList)a1)[i+1]; + let_env.set(key, EVAL(val, let_env)); + } + return EVAL(a2, let_env); + default: + el = (MalList)eval_ast(ast, env); + var f = (MalFunc)el[0]; + return f.apply(el.rest()); + } + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + var repl_env = new Mal.env.Env(null); + Func RE = (string str) => EVAL(READ(str), repl_env); + repl_env.set(new MalSymbol("+"), new MalFunc( + a => (MalInt)a[0] + (MalInt)a[1]) ); + repl_env.set(new MalSymbol("-"), new MalFunc( + a => (MalInt)a[0] - (MalInt)a[1]) ); + repl_env.set(new MalSymbol("*"), new MalFunc( + a => (MalInt)a[0] * (MalInt)a[1]) ); + repl_env.set(new MalSymbol("/"), new MalFunc( + a => (MalInt)a[0] / (MalInt)a[1]) ); + + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/step4_if_fn_do.cs b/impls/cs/step4_if_fn_do.cs index aefe22652a..1066a3764b 100644 --- a/impls/cs/step4_if_fn_do.cs +++ b/impls/cs/step4_if_fn_do.cs @@ -1,158 +1,158 @@ -using System; -using System.IO; -using System.Collections; -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalSymbol = Mal.types.MalSymbol; -using MalInt = Mal.types.MalInt; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalFunc = Mal.types.MalFunc; -using Env = Mal.env.Env; - -namespace Mal { - class step4_if_fn_do { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - static MalVal eval_ast(MalVal ast, Env env) { - if (ast is MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast is MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - foreach (MalVal mv in old_lst.getValue()) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast is MalHashMap) { - var new_dict = new Dictionary(); - foreach (var entry in ((MalHashMap)ast).getValue()) { - new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); - } - return new MalHashMap(new_dict); - } else { - return ast; - } - } - - - static MalVal EVAL(MalVal orig_ast, Env env) { - MalVal a0, a1, a2, a3, res; - MalList el; - //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast[0]; - - String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - - switch (a0sym) { - case "def!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - env.set((MalSymbol)a1, res); - return res; - case "let*": - a1 = ast[1]; - a2 = ast[2]; - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1)[i]; - val = ((MalList)a1)[i+1]; - let_env.set(key, EVAL(val, let_env)); - } - return EVAL(a2, let_env); - case "do": - el = (MalList)eval_ast(ast.rest(), env); - return el[el.size()-1]; - case "if": - a1 = ast[1]; - MalVal cond = EVAL(a1, env); - if (cond == Mal.types.Nil || cond == Mal.types.False) { - // eval false slot form - if (ast.size() > 3) { - a3 = ast[3]; - return EVAL(a3, env); - } else { - return Mal.types.Nil; - } - } else { - // eval true slot form - a2 = ast[2]; - return EVAL(a2, env); - } - case "fn*": - MalList a1f = (MalList)ast[1]; - MalVal a2f = ast[2]; - Env cur_env = env; - return new MalFunc( - args => EVAL(a2f, new Env(cur_env, a1f, args)) ); - default: - el = (MalList)eval_ast(ast, env); - var f = (MalFunc)el[0]; - return f.apply(el.rest()); - } - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - var repl_env = new Mal.env.Env(null); - Func RE = (string str) => EVAL(READ(str), repl_env); - - // core.cs: defined using C# - foreach (var entry in core.ns) { - repl_env.set(new MalSymbol(entry.Key), entry.Value); - } - - // core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))"); - - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using System.Collections; +using System.Collections.Generic; +using Mal; +using MalVal = Mal.types.MalVal; +using MalSymbol = Mal.types.MalSymbol; +using MalInt = Mal.types.MalInt; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalFunc = Mal.types.MalFunc; +using Env = Mal.env.Env; + +namespace Mal { + class step4_if_fn_do { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + static MalVal eval_ast(MalVal ast, Env env) { + if (ast is MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast is MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + foreach (MalVal mv in old_lst.getValue()) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast is MalHashMap) { + var new_dict = new Dictionary(); + foreach (var entry in ((MalHashMap)ast).getValue()) { + new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); + } + return new MalHashMap(new_dict); + } else { + return ast; + } + } + + + static MalVal EVAL(MalVal orig_ast, Env env) { + MalVal a0, a1, a2, a3, res; + MalList el; + //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast[0]; + + String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + + switch (a0sym) { + case "def!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + env.set((MalSymbol)a1, res); + return res; + case "let*": + a1 = ast[1]; + a2 = ast[2]; + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1)[i]; + val = ((MalList)a1)[i+1]; + let_env.set(key, EVAL(val, let_env)); + } + return EVAL(a2, let_env); + case "do": + el = (MalList)eval_ast(ast.rest(), env); + return el[el.size()-1]; + case "if": + a1 = ast[1]; + MalVal cond = EVAL(a1, env); + if (cond == Mal.types.Nil || cond == Mal.types.False) { + // eval false slot form + if (ast.size() > 3) { + a3 = ast[3]; + return EVAL(a3, env); + } else { + return Mal.types.Nil; + } + } else { + // eval true slot form + a2 = ast[2]; + return EVAL(a2, env); + } + case "fn*": + MalList a1f = (MalList)ast[1]; + MalVal a2f = ast[2]; + Env cur_env = env; + return new MalFunc( + args => EVAL(a2f, new Env(cur_env, a1f, args)) ); + default: + el = (MalList)eval_ast(ast, env); + var f = (MalFunc)el[0]; + return f.apply(el.rest()); + } + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + var repl_env = new Mal.env.Env(null); + Func RE = (string str) => EVAL(READ(str), repl_env); + + // core.cs: defined using C# + foreach (var entry in core.ns) { + repl_env.set(new MalSymbol(entry.Key), entry.Value); + } + + // core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))"); + + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/step5_tco.cs b/impls/cs/step5_tco.cs index 55d414aaa8..b754bfec9f 100644 --- a/impls/cs/step5_tco.cs +++ b/impls/cs/step5_tco.cs @@ -1,172 +1,172 @@ -using System; -using System.IO; -using System.Collections; -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalSymbol = Mal.types.MalSymbol; -using MalInt = Mal.types.MalInt; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalFunc = Mal.types.MalFunc; -using Env = Mal.env.Env; - -namespace Mal { - class step5_tco { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - static MalVal eval_ast(MalVal ast, Env env) { - if (ast is MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast is MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - foreach (MalVal mv in old_lst.getValue()) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast is MalHashMap) { - var new_dict = new Dictionary(); - foreach (var entry in ((MalHashMap)ast).getValue()) { - new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); - } - return new MalHashMap(new_dict); - } else { - return ast; - } - } - - - static MalVal EVAL(MalVal orig_ast, Env env) { - MalVal a0, a1, a2, res; - MalList el; - - while (true) { - - //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast[0]; - - String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - - switch (a0sym) { - case "def!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - env.set((MalSymbol)a1, res); - return res; - case "let*": - a1 = ast[1]; - a2 = ast[2]; - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1)[i]; - val = ((MalList)a1)[i+1]; - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast[ast.size()-1]; - break; - case "if": - a1 = ast[1]; - MalVal cond = EVAL(a1, env); - if (cond == Mal.types.Nil || cond == Mal.types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast[3]; - } else { - return Mal.types.Nil; - } - } else { - // eval true slot form - orig_ast = ast[2]; - } - break; - case "fn*": - MalList a1f = (MalList)ast[1]; - MalVal a2f = ast[2]; - Env cur_env = env; - return new MalFunc(a2f, env, a1f, - args => EVAL(a2f, new Env(cur_env, a1f, args)) ); - default: - el = (MalList)eval_ast(ast, env); - var f = (MalFunc)el[0]; - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.rest()); - } else { - return f.apply(el.rest()); - } - break; - } - - } - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - var repl_env = new Mal.env.Env(null); - Func RE = (string str) => EVAL(READ(str), repl_env); - - // core.cs: defined using C# - foreach (var entry in core.ns) { - repl_env.set(new MalSymbol(entry.Key), entry.Value); - } - - // core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))"); - - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using System.Collections; +using System.Collections.Generic; +using Mal; +using MalVal = Mal.types.MalVal; +using MalSymbol = Mal.types.MalSymbol; +using MalInt = Mal.types.MalInt; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalFunc = Mal.types.MalFunc; +using Env = Mal.env.Env; + +namespace Mal { + class step5_tco { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + static MalVal eval_ast(MalVal ast, Env env) { + if (ast is MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast is MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + foreach (MalVal mv in old_lst.getValue()) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast is MalHashMap) { + var new_dict = new Dictionary(); + foreach (var entry in ((MalHashMap)ast).getValue()) { + new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); + } + return new MalHashMap(new_dict); + } else { + return ast; + } + } + + + static MalVal EVAL(MalVal orig_ast, Env env) { + MalVal a0, a1, a2, res; + MalList el; + + while (true) { + + //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast[0]; + + String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + + switch (a0sym) { + case "def!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + env.set((MalSymbol)a1, res); + return res; + case "let*": + a1 = ast[1]; + a2 = ast[2]; + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1)[i]; + val = ((MalList)a1)[i+1]; + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast[ast.size()-1]; + break; + case "if": + a1 = ast[1]; + MalVal cond = EVAL(a1, env); + if (cond == Mal.types.Nil || cond == Mal.types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast[3]; + } else { + return Mal.types.Nil; + } + } else { + // eval true slot form + orig_ast = ast[2]; + } + break; + case "fn*": + MalList a1f = (MalList)ast[1]; + MalVal a2f = ast[2]; + Env cur_env = env; + return new MalFunc(a2f, env, a1f, + args => EVAL(a2f, new Env(cur_env, a1f, args)) ); + default: + el = (MalList)eval_ast(ast, env); + var f = (MalFunc)el[0]; + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.rest()); + } else { + return f.apply(el.rest()); + } + break; + } + + } + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + var repl_env = new Mal.env.Env(null); + Func RE = (string str) => EVAL(READ(str), repl_env); + + // core.cs: defined using C# + foreach (var entry in core.ns) { + repl_env.set(new MalSymbol(entry.Key), entry.Value); + } + + // core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))"); + + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/step6_file.cs b/impls/cs/step6_file.cs index 2569b0f4f2..ac3fdcf1a0 100644 --- a/impls/cs/step6_file.cs +++ b/impls/cs/step6_file.cs @@ -1,187 +1,187 @@ -using System; -using System.IO; -using System.Collections; -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalString = Mal.types.MalString; -using MalSymbol = Mal.types.MalSymbol; -using MalInt = Mal.types.MalInt; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalFunc = Mal.types.MalFunc; -using Env = Mal.env.Env; - -namespace Mal { - class step6_file { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - static MalVal eval_ast(MalVal ast, Env env) { - if (ast is MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast is MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - foreach (MalVal mv in old_lst.getValue()) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast is MalHashMap) { - var new_dict = new Dictionary(); - foreach (var entry in ((MalHashMap)ast).getValue()) { - new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); - } - return new MalHashMap(new_dict); - } else { - return ast; - } - } - - - static MalVal EVAL(MalVal orig_ast, Env env) { - MalVal a0, a1, a2, res; - MalList el; - - while (true) { - - //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast[0]; - - String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - - switch (a0sym) { - case "def!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - env.set((MalSymbol)a1, res); - return res; - case "let*": - a1 = ast[1]; - a2 = ast[2]; - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1)[i]; - val = ((MalList)a1)[i+1]; - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast[ast.size()-1]; - break; - case "if": - a1 = ast[1]; - MalVal cond = EVAL(a1, env); - if (cond == Mal.types.Nil || cond == Mal.types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast[3]; - } else { - return Mal.types.Nil; - } - } else { - // eval true slot form - orig_ast = ast[2]; - } - break; - case "fn*": - MalList a1f = (MalList)ast[1]; - MalVal a2f = ast[2]; - Env cur_env = env; - return new MalFunc(a2f, env, a1f, - args => EVAL(a2f, new Env(cur_env, a1f, args)) ); - default: - el = (MalList)eval_ast(ast, env); - var f = (MalFunc)el[0]; - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.rest()); - } else { - return f.apply(el.rest()); - } - break; - } - - } - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - var repl_env = new Mal.env.Env(null); - Func RE = (string str) => EVAL(READ(str), repl_env); - - // core.cs: defined using C# - foreach (var entry in core.ns) { - repl_env.set(new MalSymbol(entry.Key), entry.Value); - } - repl_env.set(new MalSymbol("eval"), new MalFunc( - a => EVAL(a[0], repl_env))); - int fileIdx = 0; - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - fileIdx = 1; - } - MalList _argv = new MalList(); - for (int i=fileIdx+1; i < args.Length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))"); - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - - if (args.Length > fileIdx) { - RE("(load-file \"" + args[fileIdx] + "\")"); - return; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using System.Collections; +using System.Collections.Generic; +using Mal; +using MalVal = Mal.types.MalVal; +using MalString = Mal.types.MalString; +using MalSymbol = Mal.types.MalSymbol; +using MalInt = Mal.types.MalInt; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalFunc = Mal.types.MalFunc; +using Env = Mal.env.Env; + +namespace Mal { + class step6_file { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + static MalVal eval_ast(MalVal ast, Env env) { + if (ast is MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast is MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + foreach (MalVal mv in old_lst.getValue()) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast is MalHashMap) { + var new_dict = new Dictionary(); + foreach (var entry in ((MalHashMap)ast).getValue()) { + new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); + } + return new MalHashMap(new_dict); + } else { + return ast; + } + } + + + static MalVal EVAL(MalVal orig_ast, Env env) { + MalVal a0, a1, a2, res; + MalList el; + + while (true) { + + //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast[0]; + + String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + + switch (a0sym) { + case "def!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + env.set((MalSymbol)a1, res); + return res; + case "let*": + a1 = ast[1]; + a2 = ast[2]; + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1)[i]; + val = ((MalList)a1)[i+1]; + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast[ast.size()-1]; + break; + case "if": + a1 = ast[1]; + MalVal cond = EVAL(a1, env); + if (cond == Mal.types.Nil || cond == Mal.types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast[3]; + } else { + return Mal.types.Nil; + } + } else { + // eval true slot form + orig_ast = ast[2]; + } + break; + case "fn*": + MalList a1f = (MalList)ast[1]; + MalVal a2f = ast[2]; + Env cur_env = env; + return new MalFunc(a2f, env, a1f, + args => EVAL(a2f, new Env(cur_env, a1f, args)) ); + default: + el = (MalList)eval_ast(ast, env); + var f = (MalFunc)el[0]; + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.rest()); + } else { + return f.apply(el.rest()); + } + break; + } + + } + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + var repl_env = new Mal.env.Env(null); + Func RE = (string str) => EVAL(READ(str), repl_env); + + // core.cs: defined using C# + foreach (var entry in core.ns) { + repl_env.set(new MalSymbol(entry.Key), entry.Value); + } + repl_env.set(new MalSymbol("eval"), new MalFunc( + a => EVAL(a[0], repl_env))); + int fileIdx = 0; + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + fileIdx = 1; + } + MalList _argv = new MalList(); + for (int i=fileIdx+1; i < args.Length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))"); + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + + if (args.Length > fileIdx) { + RE("(load-file \"" + args[fileIdx] + "\")"); + return; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/step7_quote.cs b/impls/cs/step7_quote.cs index 6ed7b23399..83485828e3 100644 --- a/impls/cs/step7_quote.cs +++ b/impls/cs/step7_quote.cs @@ -1,232 +1,232 @@ -using System; -using System.IO; -using System.Collections; -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalString = Mal.types.MalString; -using MalSymbol = Mal.types.MalSymbol; -using MalInt = Mal.types.MalInt; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalFunc = Mal.types.MalFunc; -using Env = Mal.env.Env; - -namespace Mal { - class step7_quote { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - public static bool starts_with(MalVal ast, string sym) { - if (ast is MalList && !(ast is MalVector)) { - MalList list = (MalList)ast; - if (list.size() == 2 && list[0] is MalSymbol) { - MalSymbol a0 = (MalSymbol)list[0]; - return a0.getName() == sym; - } - } - return false; - } - - public static MalVal qq_loop(MalList ast) { - MalVal acc = new MalList(); - for(int i=ast.size()-1; 0<=i; i-=1) { - MalVal elt = ast[i]; - if (starts_with(elt, "splice-unquote")) { - acc = new MalList(new MalSymbol("concat"), ((MalList)elt)[1], acc); - } else { - acc = new MalList(new MalSymbol("cons"), quasiquote(elt), acc); - } - } - return acc; - } - public static MalVal quasiquote(MalVal ast) { - // Check Vector subclass before List. - if (ast is MalVector) { - return new MalList(new MalSymbol("vec"), qq_loop(((MalList)ast))); - } else if (starts_with(ast, "unquote")) { - return ((MalList)ast)[1]; - } else if (ast is MalList) { - return qq_loop((MalList)ast); - } else if (ast is MalSymbol || ast is MalHashMap) { - return new MalList(new MalSymbol("quote"), ast); - } else { - return ast; - } - } - - static MalVal eval_ast(MalVal ast, Env env) { - if (ast is MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast is MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - foreach (MalVal mv in old_lst.getValue()) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast is MalHashMap) { - var new_dict = new Dictionary(); - foreach (var entry in ((MalHashMap)ast).getValue()) { - new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); - } - return new MalHashMap(new_dict); - } else { - return ast; - } - } - - - static MalVal EVAL(MalVal orig_ast, Env env) { - MalVal a0, a1, a2, res; - MalList el; - - while (true) { - - //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast[0]; - - String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - - switch (a0sym) { - case "def!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - env.set((MalSymbol)a1, res); - return res; - case "let*": - a1 = ast[1]; - a2 = ast[2]; - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1)[i]; - val = ((MalList)a1)[i+1]; - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "quote": - return ast[1]; - case "quasiquoteexpand": - return quasiquote(ast[1]); - case "quasiquote": - orig_ast = quasiquote(ast[1]); - break; - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast[ast.size()-1]; - break; - case "if": - a1 = ast[1]; - MalVal cond = EVAL(a1, env); - if (cond == Mal.types.Nil || cond == Mal.types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast[3]; - } else { - return Mal.types.Nil; - } - } else { - // eval true slot form - orig_ast = ast[2]; - } - break; - case "fn*": - MalList a1f = (MalList)ast[1]; - MalVal a2f = ast[2]; - Env cur_env = env; - return new MalFunc(a2f, env, a1f, - args => EVAL(a2f, new Env(cur_env, a1f, args)) ); - default: - el = (MalList)eval_ast(ast, env); - var f = (MalFunc)el[0]; - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.rest()); - } else { - return f.apply(el.rest()); - } - break; - } - - } - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - var repl_env = new Mal.env.Env(null); - Func RE = (string str) => EVAL(READ(str), repl_env); - - // core.cs: defined using C# - foreach (var entry in core.ns) { - repl_env.set(new MalSymbol(entry.Key), entry.Value); - } - repl_env.set(new MalSymbol("eval"), new MalFunc( - a => EVAL(a[0], repl_env))); - int fileIdx = 0; - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - fileIdx = 1; - } - MalList _argv = new MalList(); - for (int i=fileIdx+1; i < args.Length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))"); - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - - if (args.Length > fileIdx) { - RE("(load-file \"" + args[fileIdx] + "\")"); - return; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using System.Collections; +using System.Collections.Generic; +using Mal; +using MalVal = Mal.types.MalVal; +using MalString = Mal.types.MalString; +using MalSymbol = Mal.types.MalSymbol; +using MalInt = Mal.types.MalInt; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalFunc = Mal.types.MalFunc; +using Env = Mal.env.Env; + +namespace Mal { + class step7_quote { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + public static bool starts_with(MalVal ast, string sym) { + if (ast is MalList && !(ast is MalVector)) { + MalList list = (MalList)ast; + if (list.size() == 2 && list[0] is MalSymbol) { + MalSymbol a0 = (MalSymbol)list[0]; + return a0.getName() == sym; + } + } + return false; + } + + public static MalVal qq_loop(MalList ast) { + MalVal acc = new MalList(); + for(int i=ast.size()-1; 0<=i; i-=1) { + MalVal elt = ast[i]; + if (starts_with(elt, "splice-unquote")) { + acc = new MalList(new MalSymbol("concat"), ((MalList)elt)[1], acc); + } else { + acc = new MalList(new MalSymbol("cons"), quasiquote(elt), acc); + } + } + return acc; + } + public static MalVal quasiquote(MalVal ast) { + // Check Vector subclass before List. + if (ast is MalVector) { + return new MalList(new MalSymbol("vec"), qq_loop(((MalList)ast))); + } else if (starts_with(ast, "unquote")) { + return ((MalList)ast)[1]; + } else if (ast is MalList) { + return qq_loop((MalList)ast); + } else if (ast is MalSymbol || ast is MalHashMap) { + return new MalList(new MalSymbol("quote"), ast); + } else { + return ast; + } + } + + static MalVal eval_ast(MalVal ast, Env env) { + if (ast is MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast is MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + foreach (MalVal mv in old_lst.getValue()) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast is MalHashMap) { + var new_dict = new Dictionary(); + foreach (var entry in ((MalHashMap)ast).getValue()) { + new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); + } + return new MalHashMap(new_dict); + } else { + return ast; + } + } + + + static MalVal EVAL(MalVal orig_ast, Env env) { + MalVal a0, a1, a2, res; + MalList el; + + while (true) { + + //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast[0]; + + String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + + switch (a0sym) { + case "def!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + env.set((MalSymbol)a1, res); + return res; + case "let*": + a1 = ast[1]; + a2 = ast[2]; + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1)[i]; + val = ((MalList)a1)[i+1]; + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "quote": + return ast[1]; + case "quasiquoteexpand": + return quasiquote(ast[1]); + case "quasiquote": + orig_ast = quasiquote(ast[1]); + break; + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast[ast.size()-1]; + break; + case "if": + a1 = ast[1]; + MalVal cond = EVAL(a1, env); + if (cond == Mal.types.Nil || cond == Mal.types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast[3]; + } else { + return Mal.types.Nil; + } + } else { + // eval true slot form + orig_ast = ast[2]; + } + break; + case "fn*": + MalList a1f = (MalList)ast[1]; + MalVal a2f = ast[2]; + Env cur_env = env; + return new MalFunc(a2f, env, a1f, + args => EVAL(a2f, new Env(cur_env, a1f, args)) ); + default: + el = (MalList)eval_ast(ast, env); + var f = (MalFunc)el[0]; + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.rest()); + } else { + return f.apply(el.rest()); + } + break; + } + + } + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + var repl_env = new Mal.env.Env(null); + Func RE = (string str) => EVAL(READ(str), repl_env); + + // core.cs: defined using C# + foreach (var entry in core.ns) { + repl_env.set(new MalSymbol(entry.Key), entry.Value); + } + repl_env.set(new MalSymbol("eval"), new MalFunc( + a => EVAL(a[0], repl_env))); + int fileIdx = 0; + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + fileIdx = 1; + } + MalList _argv = new MalList(); + for (int i=fileIdx+1; i < args.Length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))"); + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + + if (args.Length > fileIdx) { + RE("(load-file \"" + args[fileIdx] + "\")"); + return; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/step8_macros.cs b/impls/cs/step8_macros.cs index 30e040be25..c9c1eef2a8 100644 --- a/impls/cs/step8_macros.cs +++ b/impls/cs/step8_macros.cs @@ -1,273 +1,273 @@ -using System; -using System.IO; -using System.Collections; -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalString = Mal.types.MalString; -using MalSymbol = Mal.types.MalSymbol; -using MalInt = Mal.types.MalInt; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalFunc = Mal.types.MalFunc; -using Env = Mal.env.Env; - -namespace Mal { - class step8_macros { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - public static bool starts_with(MalVal ast, string sym) { - if (ast is MalList && !(ast is MalVector)) { - MalList list = (MalList)ast; - if (list.size() == 2 && list[0] is MalSymbol) { - MalSymbol a0 = (MalSymbol)list[0]; - return a0.getName() == sym; - } - } - return false; - } - - public static MalVal qq_loop(MalList ast) { - MalVal acc = new MalList(); - for(int i=ast.size()-1; 0<=i; i-=1) { - MalVal elt = ast[i]; - if (starts_with(elt, "splice-unquote")) { - acc = new MalList(new MalSymbol("concat"), ((MalList)elt)[1], acc); - } else { - acc = new MalList(new MalSymbol("cons"), quasiquote(elt), acc); - } - } - return acc; - } - public static MalVal quasiquote(MalVal ast) { - // Check Vector subclass before List. - if (ast is MalVector) { - return new MalList(new MalSymbol("vec"), qq_loop(((MalList)ast))); - } else if (starts_with(ast, "unquote")) { - return ((MalList)ast)[1]; - } else if (ast is MalList) { - return qq_loop((MalList)ast); - } else if (ast is MalSymbol || ast is MalHashMap) { - return new MalList(new MalSymbol("quote"), ast); - } else { - return ast; - } - } - - public static bool is_macro_call(MalVal ast, Env env) { - if (ast is MalList) { - MalVal a0 = ((MalList)ast)[0]; - if (a0 is MalSymbol && - env.find((MalSymbol)a0) != null) { - MalVal mac = env.get((MalSymbol)a0); - if (mac is MalFunc && - ((MalFunc)mac).isMacro()) { - return true; - } - } - } - return false; - } - - public static MalVal macroexpand(MalVal ast, Env env) { - while (is_macro_call(ast, env)) { - MalSymbol a0 = (MalSymbol)((MalList)ast)[0]; - MalFunc mac = (MalFunc) env.get(a0); - ast = mac.apply(((MalList)ast).rest()); - } - return ast; - } - - static MalVal eval_ast(MalVal ast, Env env) { - if (ast is MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast is MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - foreach (MalVal mv in old_lst.getValue()) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast is MalHashMap) { - var new_dict = new Dictionary(); - foreach (var entry in ((MalHashMap)ast).getValue()) { - new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); - } - return new MalHashMap(new_dict); - } else { - return ast; - } - } - - - static MalVal EVAL(MalVal orig_ast, Env env) { - MalVal a0, a1, a2, res; - MalList el; - - while (true) { - - //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalVal expanded = macroexpand(orig_ast, env); - if (!expanded.list_Q()) { - return eval_ast(expanded, env); - } - MalList ast = (MalList) expanded; - - if (ast.size() == 0) { return ast; } - a0 = ast[0]; - - String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - - switch (a0sym) { - case "def!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - env.set((MalSymbol)a1, res); - return res; - case "let*": - a1 = ast[1]; - a2 = ast[2]; - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1)[i]; - val = ((MalList)a1)[i+1]; - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "quote": - return ast[1]; - case "quasiquoteexpand": - return quasiquote(ast[1]); - case "quasiquote": - orig_ast = quasiquote(ast[1]); - break; - case "defmacro!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - res = res.copy(); - ((MalFunc)res).setMacro(); - env.set(((MalSymbol)a1), res); - return res; - case "macroexpand": - a1 = ast[1]; - return macroexpand(a1, env); - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast[ast.size()-1]; - break; - case "if": - a1 = ast[1]; - MalVal cond = EVAL(a1, env); - if (cond == Mal.types.Nil || cond == Mal.types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast[3]; - } else { - return Mal.types.Nil; - } - } else { - // eval true slot form - orig_ast = ast[2]; - } - break; - case "fn*": - MalList a1f = (MalList)ast[1]; - MalVal a2f = ast[2]; - Env cur_env = env; - return new MalFunc(a2f, env, a1f, - args => EVAL(a2f, new Env(cur_env, a1f, args)) ); - default: - el = (MalList)eval_ast(ast, env); - var f = (MalFunc)el[0]; - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.rest()); - } else { - return f.apply(el.rest()); - } - break; - } - - } - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - var repl_env = new Mal.env.Env(null); - Func RE = (string str) => EVAL(READ(str), repl_env); - - // core.cs: defined using C# - foreach (var entry in core.ns) { - repl_env.set(new MalSymbol(entry.Key), entry.Value); - } - repl_env.set(new MalSymbol("eval"), new MalFunc( - a => EVAL(a[0], repl_env))); - int fileIdx = 0; - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - fileIdx = 1; - } - MalList _argv = new MalList(); - for (int i=fileIdx+1; i < args.Length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))"); - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - RE("(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)))))))"); - - if (args.Length > fileIdx) { - RE("(load-file \"" + args[fileIdx] + "\")"); - return; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using System.Collections; +using System.Collections.Generic; +using Mal; +using MalVal = Mal.types.MalVal; +using MalString = Mal.types.MalString; +using MalSymbol = Mal.types.MalSymbol; +using MalInt = Mal.types.MalInt; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalFunc = Mal.types.MalFunc; +using Env = Mal.env.Env; + +namespace Mal { + class step8_macros { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + public static bool starts_with(MalVal ast, string sym) { + if (ast is MalList && !(ast is MalVector)) { + MalList list = (MalList)ast; + if (list.size() == 2 && list[0] is MalSymbol) { + MalSymbol a0 = (MalSymbol)list[0]; + return a0.getName() == sym; + } + } + return false; + } + + public static MalVal qq_loop(MalList ast) { + MalVal acc = new MalList(); + for(int i=ast.size()-1; 0<=i; i-=1) { + MalVal elt = ast[i]; + if (starts_with(elt, "splice-unquote")) { + acc = new MalList(new MalSymbol("concat"), ((MalList)elt)[1], acc); + } else { + acc = new MalList(new MalSymbol("cons"), quasiquote(elt), acc); + } + } + return acc; + } + public static MalVal quasiquote(MalVal ast) { + // Check Vector subclass before List. + if (ast is MalVector) { + return new MalList(new MalSymbol("vec"), qq_loop(((MalList)ast))); + } else if (starts_with(ast, "unquote")) { + return ((MalList)ast)[1]; + } else if (ast is MalList) { + return qq_loop((MalList)ast); + } else if (ast is MalSymbol || ast is MalHashMap) { + return new MalList(new MalSymbol("quote"), ast); + } else { + return ast; + } + } + + public static bool is_macro_call(MalVal ast, Env env) { + if (ast is MalList) { + MalVal a0 = ((MalList)ast)[0]; + if (a0 is MalSymbol && + env.find((MalSymbol)a0) != null) { + MalVal mac = env.get((MalSymbol)a0); + if (mac is MalFunc && + ((MalFunc)mac).isMacro()) { + return true; + } + } + } + return false; + } + + public static MalVal macroexpand(MalVal ast, Env env) { + while (is_macro_call(ast, env)) { + MalSymbol a0 = (MalSymbol)((MalList)ast)[0]; + MalFunc mac = (MalFunc) env.get(a0); + ast = mac.apply(((MalList)ast).rest()); + } + return ast; + } + + static MalVal eval_ast(MalVal ast, Env env) { + if (ast is MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast is MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + foreach (MalVal mv in old_lst.getValue()) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast is MalHashMap) { + var new_dict = new Dictionary(); + foreach (var entry in ((MalHashMap)ast).getValue()) { + new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); + } + return new MalHashMap(new_dict); + } else { + return ast; + } + } + + + static MalVal EVAL(MalVal orig_ast, Env env) { + MalVal a0, a1, a2, res; + MalList el; + + while (true) { + + //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalVal expanded = macroexpand(orig_ast, env); + if (!expanded.list_Q()) { + return eval_ast(expanded, env); + } + MalList ast = (MalList) expanded; + + if (ast.size() == 0) { return ast; } + a0 = ast[0]; + + String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + + switch (a0sym) { + case "def!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + env.set((MalSymbol)a1, res); + return res; + case "let*": + a1 = ast[1]; + a2 = ast[2]; + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1)[i]; + val = ((MalList)a1)[i+1]; + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "quote": + return ast[1]; + case "quasiquoteexpand": + return quasiquote(ast[1]); + case "quasiquote": + orig_ast = quasiquote(ast[1]); + break; + case "defmacro!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + res = res.copy(); + ((MalFunc)res).setMacro(); + env.set(((MalSymbol)a1), res); + return res; + case "macroexpand": + a1 = ast[1]; + return macroexpand(a1, env); + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast[ast.size()-1]; + break; + case "if": + a1 = ast[1]; + MalVal cond = EVAL(a1, env); + if (cond == Mal.types.Nil || cond == Mal.types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast[3]; + } else { + return Mal.types.Nil; + } + } else { + // eval true slot form + orig_ast = ast[2]; + } + break; + case "fn*": + MalList a1f = (MalList)ast[1]; + MalVal a2f = ast[2]; + Env cur_env = env; + return new MalFunc(a2f, env, a1f, + args => EVAL(a2f, new Env(cur_env, a1f, args)) ); + default: + el = (MalList)eval_ast(ast, env); + var f = (MalFunc)el[0]; + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.rest()); + } else { + return f.apply(el.rest()); + } + break; + } + + } + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + var repl_env = new Mal.env.Env(null); + Func RE = (string str) => EVAL(READ(str), repl_env); + + // core.cs: defined using C# + foreach (var entry in core.ns) { + repl_env.set(new MalSymbol(entry.Key), entry.Value); + } + repl_env.set(new MalSymbol("eval"), new MalFunc( + a => EVAL(a[0], repl_env))); + int fileIdx = 0; + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + fileIdx = 1; + } + MalList _argv = new MalList(); + for (int i=fileIdx+1; i < args.Length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))"); + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + RE("(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)))))))"); + + if (args.Length > fileIdx) { + RE("(load-file \"" + args[fileIdx] + "\")"); + return; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/step9_try.cs b/impls/cs/step9_try.cs index 31dab06cb7..30a68790a0 100644 --- a/impls/cs/step9_try.cs +++ b/impls/cs/step9_try.cs @@ -1,298 +1,298 @@ -using System; -using System.IO; -using System.Collections; -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalString = Mal.types.MalString; -using MalSymbol = Mal.types.MalSymbol; -using MalInt = Mal.types.MalInt; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalFunc = Mal.types.MalFunc; -using Env = Mal.env.Env; - -namespace Mal { - class step9_try { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - public static bool starts_with(MalVal ast, string sym) { - if (ast is MalList && !(ast is MalVector)) { - MalList list = (MalList)ast; - if (list.size() == 2 && list[0] is MalSymbol) { - MalSymbol a0 = (MalSymbol)list[0]; - return a0.getName() == sym; - } - } - return false; - } - - public static MalVal qq_loop(MalList ast) { - MalVal acc = new MalList(); - for(int i=ast.size()-1; 0<=i; i-=1) { - MalVal elt = ast[i]; - if (starts_with(elt, "splice-unquote")) { - acc = new MalList(new MalSymbol("concat"), ((MalList)elt)[1], acc); - } else { - acc = new MalList(new MalSymbol("cons"), quasiquote(elt), acc); - } - } - return acc; - } - public static MalVal quasiquote(MalVal ast) { - // Check Vector subclass before List. - if (ast is MalVector) { - return new MalList(new MalSymbol("vec"), qq_loop(((MalList)ast))); - } else if (starts_with(ast, "unquote")) { - return ((MalList)ast)[1]; - } else if (ast is MalList) { - return qq_loop((MalList)ast); - } else if (ast is MalSymbol || ast is MalHashMap) { - return new MalList(new MalSymbol("quote"), ast); - } else { - return ast; - } - } - - public static bool is_macro_call(MalVal ast, Env env) { - if (ast is MalList) { - MalVal a0 = ((MalList)ast)[0]; - if (a0 is MalSymbol && - env.find((MalSymbol)a0) != null) { - MalVal mac = env.get((MalSymbol)a0); - if (mac is MalFunc && - ((MalFunc)mac).isMacro()) { - return true; - } - } - } - return false; - } - - public static MalVal macroexpand(MalVal ast, Env env) { - while (is_macro_call(ast, env)) { - MalSymbol a0 = (MalSymbol)((MalList)ast)[0]; - MalFunc mac = (MalFunc) env.get(a0); - ast = mac.apply(((MalList)ast).rest()); - } - return ast; - } - - static MalVal eval_ast(MalVal ast, Env env) { - if (ast is MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast is MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - foreach (MalVal mv in old_lst.getValue()) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast is MalHashMap) { - var new_dict = new Dictionary(); - foreach (var entry in ((MalHashMap)ast).getValue()) { - new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); - } - return new MalHashMap(new_dict); - } else { - return ast; - } - } - - - static MalVal EVAL(MalVal orig_ast, Env env) { - MalVal a0, a1, a2, res; - MalList el; - - while (true) { - - //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalVal expanded = macroexpand(orig_ast, env); - if (!expanded.list_Q()) { - return eval_ast(expanded, env); - } - MalList ast = (MalList) expanded; - - if (ast.size() == 0) { return ast; } - a0 = ast[0]; - - String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - - switch (a0sym) { - case "def!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - env.set((MalSymbol)a1, res); - return res; - case "let*": - a1 = ast[1]; - a2 = ast[2]; - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1)[i]; - val = ((MalList)a1)[i+1]; - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "quote": - return ast[1]; - case "quasiquoteexpand": - return quasiquote(ast[1]); - case "quasiquote": - orig_ast = quasiquote(ast[1]); - break; - case "defmacro!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - res = res.copy(); - ((MalFunc)res).setMacro(); - env.set(((MalSymbol)a1), res); - return res; - case "macroexpand": - a1 = ast[1]; - return macroexpand(a1, env); - case "try*": - try { - return EVAL(ast[1], env); - } catch (Exception e) { - if (ast.size() > 2) { - MalVal exc; - a2 = ast[2]; - MalVal a20 = ((MalList)a2)[0]; - if (((MalSymbol)a20).getName() == "catch*") { - if (e is Mal.types.MalException) { - exc = ((Mal.types.MalException)e).getValue(); - } else { - exc = new MalString(e.Message); - } - return EVAL(((MalList)a2)[2], - new Env(env, ((MalList)a2).slice(1,2), - new MalList(exc))); - } - } - throw e; - } - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast[ast.size()-1]; - break; - case "if": - a1 = ast[1]; - MalVal cond = EVAL(a1, env); - if (cond == Mal.types.Nil || cond == Mal.types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast[3]; - } else { - return Mal.types.Nil; - } - } else { - // eval true slot form - orig_ast = ast[2]; - } - break; - case "fn*": - MalList a1f = (MalList)ast[1]; - MalVal a2f = ast[2]; - Env cur_env = env; - return new MalFunc(a2f, env, a1f, - args => EVAL(a2f, new Env(cur_env, a1f, args)) ); - default: - el = (MalList)eval_ast(ast, env); - var f = (MalFunc)el[0]; - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.rest()); - } else { - return f.apply(el.rest()); - } - break; - } - - } - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - var repl_env = new Mal.env.Env(null); - Func RE = (string str) => EVAL(READ(str), repl_env); - - // core.cs: defined using C# - foreach (var entry in core.ns) { - repl_env.set(new MalSymbol(entry.Key), entry.Value); - } - repl_env.set(new MalSymbol("eval"), new MalFunc( - a => EVAL(a[0], repl_env))); - int fileIdx = 0; - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - fileIdx = 1; - } - MalList _argv = new MalList(); - for (int i=fileIdx+1; i < args.Length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))"); - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - RE("(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)))))))"); - - if (args.Length > fileIdx) { - RE("(load-file \"" + args[fileIdx] + "\")"); - return; - } - - // repl loop - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Mal.types.MalException e) { - Console.WriteLine("Error: " + - printer._pr_str(e.getValue(), false)); - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using System.Collections; +using System.Collections.Generic; +using Mal; +using MalVal = Mal.types.MalVal; +using MalString = Mal.types.MalString; +using MalSymbol = Mal.types.MalSymbol; +using MalInt = Mal.types.MalInt; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalFunc = Mal.types.MalFunc; +using Env = Mal.env.Env; + +namespace Mal { + class step9_try { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + public static bool starts_with(MalVal ast, string sym) { + if (ast is MalList && !(ast is MalVector)) { + MalList list = (MalList)ast; + if (list.size() == 2 && list[0] is MalSymbol) { + MalSymbol a0 = (MalSymbol)list[0]; + return a0.getName() == sym; + } + } + return false; + } + + public static MalVal qq_loop(MalList ast) { + MalVal acc = new MalList(); + for(int i=ast.size()-1; 0<=i; i-=1) { + MalVal elt = ast[i]; + if (starts_with(elt, "splice-unquote")) { + acc = new MalList(new MalSymbol("concat"), ((MalList)elt)[1], acc); + } else { + acc = new MalList(new MalSymbol("cons"), quasiquote(elt), acc); + } + } + return acc; + } + public static MalVal quasiquote(MalVal ast) { + // Check Vector subclass before List. + if (ast is MalVector) { + return new MalList(new MalSymbol("vec"), qq_loop(((MalList)ast))); + } else if (starts_with(ast, "unquote")) { + return ((MalList)ast)[1]; + } else if (ast is MalList) { + return qq_loop((MalList)ast); + } else if (ast is MalSymbol || ast is MalHashMap) { + return new MalList(new MalSymbol("quote"), ast); + } else { + return ast; + } + } + + public static bool is_macro_call(MalVal ast, Env env) { + if (ast is MalList) { + MalVal a0 = ((MalList)ast)[0]; + if (a0 is MalSymbol && + env.find((MalSymbol)a0) != null) { + MalVal mac = env.get((MalSymbol)a0); + if (mac is MalFunc && + ((MalFunc)mac).isMacro()) { + return true; + } + } + } + return false; + } + + public static MalVal macroexpand(MalVal ast, Env env) { + while (is_macro_call(ast, env)) { + MalSymbol a0 = (MalSymbol)((MalList)ast)[0]; + MalFunc mac = (MalFunc) env.get(a0); + ast = mac.apply(((MalList)ast).rest()); + } + return ast; + } + + static MalVal eval_ast(MalVal ast, Env env) { + if (ast is MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast is MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + foreach (MalVal mv in old_lst.getValue()) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast is MalHashMap) { + var new_dict = new Dictionary(); + foreach (var entry in ((MalHashMap)ast).getValue()) { + new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); + } + return new MalHashMap(new_dict); + } else { + return ast; + } + } + + + static MalVal EVAL(MalVal orig_ast, Env env) { + MalVal a0, a1, a2, res; + MalList el; + + while (true) { + + //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalVal expanded = macroexpand(orig_ast, env); + if (!expanded.list_Q()) { + return eval_ast(expanded, env); + } + MalList ast = (MalList) expanded; + + if (ast.size() == 0) { return ast; } + a0 = ast[0]; + + String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + + switch (a0sym) { + case "def!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + env.set((MalSymbol)a1, res); + return res; + case "let*": + a1 = ast[1]; + a2 = ast[2]; + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1)[i]; + val = ((MalList)a1)[i+1]; + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "quote": + return ast[1]; + case "quasiquoteexpand": + return quasiquote(ast[1]); + case "quasiquote": + orig_ast = quasiquote(ast[1]); + break; + case "defmacro!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + res = res.copy(); + ((MalFunc)res).setMacro(); + env.set(((MalSymbol)a1), res); + return res; + case "macroexpand": + a1 = ast[1]; + return macroexpand(a1, env); + case "try*": + try { + return EVAL(ast[1], env); + } catch (Exception e) { + if (ast.size() > 2) { + MalVal exc; + a2 = ast[2]; + MalVal a20 = ((MalList)a2)[0]; + if (((MalSymbol)a20).getName() == "catch*") { + if (e is Mal.types.MalException) { + exc = ((Mal.types.MalException)e).getValue(); + } else { + exc = new MalString(e.Message); + } + return EVAL(((MalList)a2)[2], + new Env(env, ((MalList)a2).slice(1,2), + new MalList(exc))); + } + } + throw e; + } + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast[ast.size()-1]; + break; + case "if": + a1 = ast[1]; + MalVal cond = EVAL(a1, env); + if (cond == Mal.types.Nil || cond == Mal.types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast[3]; + } else { + return Mal.types.Nil; + } + } else { + // eval true slot form + orig_ast = ast[2]; + } + break; + case "fn*": + MalList a1f = (MalList)ast[1]; + MalVal a2f = ast[2]; + Env cur_env = env; + return new MalFunc(a2f, env, a1f, + args => EVAL(a2f, new Env(cur_env, a1f, args)) ); + default: + el = (MalList)eval_ast(ast, env); + var f = (MalFunc)el[0]; + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.rest()); + } else { + return f.apply(el.rest()); + } + break; + } + + } + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + var repl_env = new Mal.env.Env(null); + Func RE = (string str) => EVAL(READ(str), repl_env); + + // core.cs: defined using C# + foreach (var entry in core.ns) { + repl_env.set(new MalSymbol(entry.Key), entry.Value); + } + repl_env.set(new MalSymbol("eval"), new MalFunc( + a => EVAL(a[0], repl_env))); + int fileIdx = 0; + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + fileIdx = 1; + } + MalList _argv = new MalList(); + for (int i=fileIdx+1; i < args.Length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))"); + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + RE("(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)))))))"); + + if (args.Length > fileIdx) { + RE("(load-file \"" + args[fileIdx] + "\")"); + return; + } + + // repl loop + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Mal.types.MalException e) { + Console.WriteLine("Error: " + + printer._pr_str(e.getValue(), false)); + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/stepA_mal.cs b/impls/cs/stepA_mal.cs index cdc1490187..d72e1acc57 100644 --- a/impls/cs/stepA_mal.cs +++ b/impls/cs/stepA_mal.cs @@ -1,300 +1,300 @@ -using System; -using System.IO; -using System.Collections; -using System.Collections.Generic; -using Mal; -using MalVal = Mal.types.MalVal; -using MalString = Mal.types.MalString; -using MalSymbol = Mal.types.MalSymbol; -using MalInt = Mal.types.MalInt; -using MalList = Mal.types.MalList; -using MalVector = Mal.types.MalVector; -using MalHashMap = Mal.types.MalHashMap; -using MalFunc = Mal.types.MalFunc; -using Env = Mal.env.Env; - -namespace Mal { - class stepA_mal { - // read - static MalVal READ(string str) { - return reader.read_str(str); - } - - // eval - public static bool starts_with(MalVal ast, string sym) { - if (ast is MalList && !(ast is MalVector)) { - MalList list = (MalList)ast; - if (list.size() == 2 && list[0] is MalSymbol) { - MalSymbol a0 = (MalSymbol)list[0]; - return a0.getName() == sym; - } - } - return false; - } - - public static MalVal qq_loop(MalList ast) { - MalVal acc = new MalList(); - for(int i=ast.size()-1; 0<=i; i-=1) { - MalVal elt = ast[i]; - if (starts_with(elt, "splice-unquote")) { - acc = new MalList(new MalSymbol("concat"), ((MalList)elt)[1], acc); - } else { - acc = new MalList(new MalSymbol("cons"), quasiquote(elt), acc); - } - } - return acc; - } - public static MalVal quasiquote(MalVal ast) { - // Check Vector subclass before List. - if (ast is MalVector) { - return new MalList(new MalSymbol("vec"), qq_loop(((MalList)ast))); - } else if (starts_with(ast, "unquote")) { - return ((MalList)ast)[1]; - } else if (ast is MalList) { - return qq_loop((MalList)ast); - } else if (ast is MalSymbol || ast is MalHashMap) { - return new MalList(new MalSymbol("quote"), ast); - } else { - return ast; - } - } - - public static bool is_macro_call(MalVal ast, Env env) { - if (ast is MalList) { - MalVal a0 = ((MalList)ast)[0]; - if (a0 is MalSymbol && - env.find((MalSymbol)a0) != null) { - MalVal mac = env.get((MalSymbol)a0); - if (mac is MalFunc && - ((MalFunc)mac).isMacro()) { - return true; - } - } - } - return false; - } - - public static MalVal macroexpand(MalVal ast, Env env) { - while (is_macro_call(ast, env)) { - MalSymbol a0 = (MalSymbol)((MalList)ast)[0]; - MalFunc mac = (MalFunc) env.get(a0); - ast = mac.apply(((MalList)ast).rest()); - } - return ast; - } - - static MalVal eval_ast(MalVal ast, Env env) { - if (ast is MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast is MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - foreach (MalVal mv in old_lst.getValue()) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast is MalHashMap) { - var new_dict = new Dictionary(); - foreach (var entry in ((MalHashMap)ast).getValue()) { - new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); - } - return new MalHashMap(new_dict); - } else { - return ast; - } - } - - - static MalVal EVAL(MalVal orig_ast, Env env) { - MalVal a0, a1, a2, res; - MalList el; - - while (true) { - - //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalVal expanded = macroexpand(orig_ast, env); - if (!expanded.list_Q()) { - return eval_ast(expanded, env); - } - MalList ast = (MalList) expanded; - - if (ast.size() == 0) { return ast; } - a0 = ast[0]; - - String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - - switch (a0sym) { - case "def!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - env.set((MalSymbol)a1, res); - return res; - case "let*": - a1 = ast[1]; - a2 = ast[2]; - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1)[i]; - val = ((MalList)a1)[i+1]; - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "quote": - return ast[1]; - case "quasiquoteexpand": - return quasiquote(ast[1]); - case "quasiquote": - orig_ast = quasiquote(ast[1]); - break; - case "defmacro!": - a1 = ast[1]; - a2 = ast[2]; - res = EVAL(a2, env); - res = res.copy(); - ((MalFunc)res).setMacro(); - env.set(((MalSymbol)a1), res); - return res; - case "macroexpand": - a1 = ast[1]; - return macroexpand(a1, env); - case "try*": - try { - return EVAL(ast[1], env); - } catch (Exception e) { - if (ast.size() > 2) { - MalVal exc; - a2 = ast[2]; - MalVal a20 = ((MalList)a2)[0]; - if (((MalSymbol)a20).getName() == "catch*") { - if (e is Mal.types.MalException) { - exc = ((Mal.types.MalException)e).getValue(); - } else { - exc = new MalString(e.Message); - } - return EVAL(((MalList)a2)[2], - new Env(env, ((MalList)a2).slice(1,2), - new MalList(exc))); - } - } - throw e; - } - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast[ast.size()-1]; - break; - case "if": - a1 = ast[1]; - MalVal cond = EVAL(a1, env); - if (cond == Mal.types.Nil || cond == Mal.types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast[3]; - } else { - return Mal.types.Nil; - } - } else { - // eval true slot form - orig_ast = ast[2]; - } - break; - case "fn*": - MalList a1f = (MalList)ast[1]; - MalVal a2f = ast[2]; - Env cur_env = env; - return new MalFunc(a2f, env, a1f, - args => EVAL(a2f, new Env(cur_env, a1f, args)) ); - default: - el = (MalList)eval_ast(ast, env); - var f = (MalFunc)el[0]; - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.rest()); - } else { - return f.apply(el.rest()); - } - break; - } - - } - } - - // print - static string PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - static void Main(string[] args) { - var repl_env = new Mal.env.Env(null); - Func RE = (string str) => EVAL(READ(str), repl_env); - - // core.cs: defined using C# - foreach (var entry in core.ns) { - repl_env.set(new MalSymbol(entry.Key), entry.Value); - } - repl_env.set(new MalSymbol("eval"), new MalFunc( - a => EVAL(a[0], repl_env))); - int fileIdx = 0; - if (args.Length > 0 && args[0] == "--raw") { - Mal.readline.mode = Mal.readline.Mode.Raw; - fileIdx = 1; - } - MalList _argv = new MalList(); - for (int i=fileIdx+1; i < args.Length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - // core.mal: defined using the language itself - RE("(def! *host-language* \"c#\")"); - RE("(def! not (fn* (a) (if a false true)))"); - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - RE("(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)))))))"); - - if (args.Length > fileIdx) { - RE("(load-file \"" + args[fileIdx] + "\")"); - return; - } - - // repl loop - RE("(println (str \"Mal [\" *host-language* \"]\"))"); - while (true) { - string line; - try { - line = Mal.readline.Readline("user> "); - if (line == null) { break; } - if (line == "") { continue; } - } catch (IOException e) { - Console.WriteLine("IOException: " + e.Message); - break; - } - try { - Console.WriteLine(PRINT(RE(line))); - } catch (Mal.types.MalContinue) { - continue; - } catch (Mal.types.MalException e) { - Console.WriteLine("Error: " + - printer._pr_str(e.getValue(), false)); - continue; - } catch (Exception e) { - Console.WriteLine("Error: " + e.Message); - Console.WriteLine(e.StackTrace); - continue; - } - } - } - } -} +using System; +using System.IO; +using System.Collections; +using System.Collections.Generic; +using Mal; +using MalVal = Mal.types.MalVal; +using MalString = Mal.types.MalString; +using MalSymbol = Mal.types.MalSymbol; +using MalInt = Mal.types.MalInt; +using MalList = Mal.types.MalList; +using MalVector = Mal.types.MalVector; +using MalHashMap = Mal.types.MalHashMap; +using MalFunc = Mal.types.MalFunc; +using Env = Mal.env.Env; + +namespace Mal { + class stepA_mal { + // read + static MalVal READ(string str) { + return reader.read_str(str); + } + + // eval + public static bool starts_with(MalVal ast, string sym) { + if (ast is MalList && !(ast is MalVector)) { + MalList list = (MalList)ast; + if (list.size() == 2 && list[0] is MalSymbol) { + MalSymbol a0 = (MalSymbol)list[0]; + return a0.getName() == sym; + } + } + return false; + } + + public static MalVal qq_loop(MalList ast) { + MalVal acc = new MalList(); + for(int i=ast.size()-1; 0<=i; i-=1) { + MalVal elt = ast[i]; + if (starts_with(elt, "splice-unquote")) { + acc = new MalList(new MalSymbol("concat"), ((MalList)elt)[1], acc); + } else { + acc = new MalList(new MalSymbol("cons"), quasiquote(elt), acc); + } + } + return acc; + } + public static MalVal quasiquote(MalVal ast) { + // Check Vector subclass before List. + if (ast is MalVector) { + return new MalList(new MalSymbol("vec"), qq_loop(((MalList)ast))); + } else if (starts_with(ast, "unquote")) { + return ((MalList)ast)[1]; + } else if (ast is MalList) { + return qq_loop((MalList)ast); + } else if (ast is MalSymbol || ast is MalHashMap) { + return new MalList(new MalSymbol("quote"), ast); + } else { + return ast; + } + } + + public static bool is_macro_call(MalVal ast, Env env) { + if (ast is MalList) { + MalVal a0 = ((MalList)ast)[0]; + if (a0 is MalSymbol && + env.find((MalSymbol)a0) != null) { + MalVal mac = env.get((MalSymbol)a0); + if (mac is MalFunc && + ((MalFunc)mac).isMacro()) { + return true; + } + } + } + return false; + } + + public static MalVal macroexpand(MalVal ast, Env env) { + while (is_macro_call(ast, env)) { + MalSymbol a0 = (MalSymbol)((MalList)ast)[0]; + MalFunc mac = (MalFunc) env.get(a0); + ast = mac.apply(((MalList)ast).rest()); + } + return ast; + } + + static MalVal eval_ast(MalVal ast, Env env) { + if (ast is MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast is MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + foreach (MalVal mv in old_lst.getValue()) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast is MalHashMap) { + var new_dict = new Dictionary(); + foreach (var entry in ((MalHashMap)ast).getValue()) { + new_dict.Add(entry.Key, EVAL((MalVal)entry.Value, env)); + } + return new MalHashMap(new_dict); + } else { + return ast; + } + } + + + static MalVal EVAL(MalVal orig_ast, Env env) { + MalVal a0, a1, a2, res; + MalList el; + + while (true) { + + //Console.WriteLine("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalVal expanded = macroexpand(orig_ast, env); + if (!expanded.list_Q()) { + return eval_ast(expanded, env); + } + MalList ast = (MalList) expanded; + + if (ast.size() == 0) { return ast; } + a0 = ast[0]; + + String a0sym = a0 is MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + + switch (a0sym) { + case "def!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + env.set((MalSymbol)a1, res); + return res; + case "let*": + a1 = ast[1]; + a2 = ast[2]; + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1)[i]; + val = ((MalList)a1)[i+1]; + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "quote": + return ast[1]; + case "quasiquoteexpand": + return quasiquote(ast[1]); + case "quasiquote": + orig_ast = quasiquote(ast[1]); + break; + case "defmacro!": + a1 = ast[1]; + a2 = ast[2]; + res = EVAL(a2, env); + res = res.copy(); + ((MalFunc)res).setMacro(); + env.set(((MalSymbol)a1), res); + return res; + case "macroexpand": + a1 = ast[1]; + return macroexpand(a1, env); + case "try*": + try { + return EVAL(ast[1], env); + } catch (Exception e) { + if (ast.size() > 2) { + MalVal exc; + a2 = ast[2]; + MalVal a20 = ((MalList)a2)[0]; + if (((MalSymbol)a20).getName() == "catch*") { + if (e is Mal.types.MalException) { + exc = ((Mal.types.MalException)e).getValue(); + } else { + exc = new MalString(e.Message); + } + return EVAL(((MalList)a2)[2], + new Env(env, ((MalList)a2).slice(1,2), + new MalList(exc))); + } + } + throw e; + } + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast[ast.size()-1]; + break; + case "if": + a1 = ast[1]; + MalVal cond = EVAL(a1, env); + if (cond == Mal.types.Nil || cond == Mal.types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast[3]; + } else { + return Mal.types.Nil; + } + } else { + // eval true slot form + orig_ast = ast[2]; + } + break; + case "fn*": + MalList a1f = (MalList)ast[1]; + MalVal a2f = ast[2]; + Env cur_env = env; + return new MalFunc(a2f, env, a1f, + args => EVAL(a2f, new Env(cur_env, a1f, args)) ); + default: + el = (MalList)eval_ast(ast, env); + var f = (MalFunc)el[0]; + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.rest()); + } else { + return f.apply(el.rest()); + } + break; + } + + } + } + + // print + static string PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + static void Main(string[] args) { + var repl_env = new Mal.env.Env(null); + Func RE = (string str) => EVAL(READ(str), repl_env); + + // core.cs: defined using C# + foreach (var entry in core.ns) { + repl_env.set(new MalSymbol(entry.Key), entry.Value); + } + repl_env.set(new MalSymbol("eval"), new MalFunc( + a => EVAL(a[0], repl_env))); + int fileIdx = 0; + if (args.Length > 0 && args[0] == "--raw") { + Mal.readline.mode = Mal.readline.Mode.Raw; + fileIdx = 1; + } + MalList _argv = new MalList(); + for (int i=fileIdx+1; i < args.Length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + // core.mal: defined using the language itself + RE("(def! *host-language* \"c#\")"); + RE("(def! not (fn* (a) (if a false true)))"); + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + RE("(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)))))))"); + + if (args.Length > fileIdx) { + RE("(load-file \"" + args[fileIdx] + "\")"); + return; + } + + // repl loop + RE("(println (str \"Mal [\" *host-language* \"]\"))"); + while (true) { + string line; + try { + line = Mal.readline.Readline("user> "); + if (line == null) { break; } + if (line == "") { continue; } + } catch (IOException e) { + Console.WriteLine("IOException: " + e.Message); + break; + } + try { + Console.WriteLine(PRINT(RE(line))); + } catch (Mal.types.MalContinue) { + continue; + } catch (Mal.types.MalException e) { + Console.WriteLine("Error: " + + printer._pr_str(e.getValue(), false)); + continue; + } catch (Exception e) { + Console.WriteLine("Error: " + e.Message); + Console.WriteLine(e.StackTrace); + continue; + } + } + } + } +} diff --git a/impls/cs/tests/step5_tco.mal b/impls/cs/tests/step5_tco.mal index 4fec62e2fc..55925906cc 100644 --- a/impls/cs/tests/step5_tco.mal +++ b/impls/cs/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; C#: skipping non-TCO recursion -;; Reason: unrecoverable stack overflow at 10,000 +;; C#: skipping non-TCO recursion +;; Reason: unrecoverable stack overflow at 10,000 diff --git a/impls/cs/types.cs b/impls/cs/types.cs index 21088fd08e..03227ec9c5 100644 --- a/impls/cs/types.cs +++ b/impls/cs/types.cs @@ -1,358 +1,358 @@ -using System; -using System.Collections.Generic; -using Mal; - -namespace Mal { - public class types { - // - // Exceptions/Errors - // - public class MalThrowable : Exception { - public MalThrowable() : base() { } - public MalThrowable(string msg) : base(msg) { } - } - public class MalError : MalThrowable { - public MalError(string msg) :base(msg) { } - } - public class MalContinue : MalThrowable { } - - // Thrown by throw function - public class MalException : MalThrowable { - MalVal value; - //string Message; - public MalException(MalVal value) { - this.value = value; - } - public MalException(string value) :base(value) { - this.value = new MalString(value); - } - public MalVal getValue() { return value; } - } - - // - // General functions - // - - public static bool _equal_Q(MalVal a, MalVal b) { - Type ota = a.GetType(), otb = b.GetType(); - if (!((ota == otb) || - (a is MalList && b is MalList))) { - return false; - } else { - if (a is MalInt) { - return ((MalInt)a).getValue() == - ((MalInt)b).getValue(); - } else if (a is MalSymbol) { - return ((MalSymbol)a).getName() == - ((MalSymbol)b).getName(); - } else if (a is MalString) { - return ((MalString)a).getValue() == - ((MalString)b).getValue(); - } else if (a is MalList) { - if (((MalList)a).size() != ((MalList)b).size()) { - return false; - } - for (int i=0; i<((MalList)a).size(); i++) { - if (! _equal_Q(((MalList)a)[i], ((MalList)b)[i])) { - return false; - } - } - return true; - } else if (a is MalHashMap) { - var akeys = ((MalHashMap)a).getValue().Keys; - var bkeys = ((MalHashMap)b).getValue().Keys; - if (akeys.Count != bkeys.Count) { - return false; - } - foreach (var k in akeys) { - if (!_equal_Q(((MalHashMap)a).getValue()[k], - ((MalHashMap)b).getValue()[k])) { - return false; - } - } - return true; - } else { - return a == b; - } - } - } - - - public abstract class MalVal { - MalVal meta = Nil; - public virtual MalVal copy() { - return (MalVal)this.MemberwiseClone(); - } - - // Default is just to call regular toString() - public virtual string ToString(bool print_readably) { - return this.ToString(); - } - public MalVal getMeta() { return meta; } - public MalVal setMeta(MalVal m) { meta = m; return this; } - public virtual bool list_Q() { return false; } - } - - public class MalConstant : MalVal { - string value; - public MalConstant(string name) { value = name; } - public new MalConstant copy() { return this; } - - public override string ToString() { - return value; - } - public override string ToString(bool print_readably) { - return value; - } - } - - static public MalConstant Nil = new MalConstant("nil"); - static public MalConstant True = new MalConstant("true"); - static public MalConstant False = new MalConstant("false"); - - public class MalInt : MalVal { - Int64 value; - public MalInt(Int64 v) { value = v; } - public new MalInt copy() { return this; } - - public Int64 getValue() { return value; } - public override string ToString() { - return value.ToString(); - } - public override string ToString(bool print_readably) { - return value.ToString(); - } - public static MalConstant operator <(MalInt a, MalInt b) { - return a.getValue() < b.getValue() ? True : False; - } - public static MalConstant operator <=(MalInt a, MalInt b) { - return a.getValue() <= b.getValue() ? True : False; - } - public static MalConstant operator >(MalInt a, MalInt b) { - return a.getValue() > b.getValue() ? True : False; - } - public static MalConstant operator >=(MalInt a, MalInt b) { - return a.getValue() >= b.getValue() ? True : False; - } - public static MalInt operator +(MalInt a, MalInt b) { - return new MalInt(a.getValue() + b.getValue()); - } - public static MalInt operator -(MalInt a, MalInt b) { - return new MalInt(a.getValue() - b.getValue()); - } - public static MalInt operator *(MalInt a, MalInt b) { - return new MalInt(a.getValue() * b.getValue()); - } - public static MalInt operator /(MalInt a, MalInt b) { - return new MalInt(a.getValue() / b.getValue()); - } - } - - public class MalSymbol : MalVal { - string value; - public MalSymbol(string v) { value = v; } - public MalSymbol(MalString v) { value = v.getValue(); } - public new MalSymbol copy() { return this; } - - public string getName() { return value; } - public override string ToString() { - return value; - } - public override string ToString(bool print_readably) { - return value; - } - } - - public class MalString : MalVal { - string value; - public MalString(string v) { value = v; } - public new MalString copy() { return this; } - - public string getValue() { return value; } - public override string ToString() { - return "\"" + value + "\""; - } - public override string ToString(bool print_readably) { - if (value.Length > 0 && value[0] == '\u029e') { - return ":" + value.Substring(1); - } else if (print_readably) { - return "\"" + value.Replace("\\", "\\\\") - .Replace("\"", "\\\"") - .Replace("\n", "\\n") + "\""; - } else { - return value; - } - } - } - - - - public class MalList : MalVal { - public string start = "(", end = ")"; - List value; - public MalList() { - value = new List(); - } - public MalList(List val) { - value = val; - } - public MalList(params MalVal[] mvs) { - value = new List(); - conj_BANG(mvs); - } - - public List getValue() { return value; } - public override bool list_Q() { return true; } - - public override string ToString() { - return start + printer.join(value, " ", true) + end; - } - public override string ToString(bool print_readably) { - return start + printer.join(value, " ", print_readably) + end; - } - - public MalList conj_BANG(params MalVal[] mvs) { - for (int i = 0; i < mvs.Length; i++) { - value.Add(mvs[i]); - } - return this; - } - - public int size() { return value.Count; } - public MalVal nth(int idx) { - return value.Count > idx ? value[idx] : Nil; - } - public MalVal this[int idx] { - get { return value.Count > idx ? value[idx] : Nil; } - } - public MalList rest() { - if (size() > 0) { - return new MalList(value.GetRange(1, value.Count-1)); - } else { - return new MalList(); - } - } - public virtual MalList slice(int start) { - return new MalList(value.GetRange(start, value.Count-start)); - } - public virtual MalList slice(int start, int end) { - return new MalList(value.GetRange(start, end-start)); - } - - } - - public class MalVector : MalList { - // Same implementation except for instantiation methods - public MalVector() :base() { - start = "["; - end = "]"; - } - public MalVector(List val) - :base(val) { - start = "["; - end = "]"; - } - - public override bool list_Q() { return false; } - - public override MalList slice(int start, int end) { - var val = this.getValue(); - return new MalVector(val.GetRange(start, val.Count-start)); - } - } - - public class MalHashMap : MalVal { - Dictionary value; - public MalHashMap(Dictionary val) { - value = val; - } - public MalHashMap(MalList lst) { - value = new Dictionary(); - assoc_BANG(lst); - } - public new MalHashMap copy() { - var new_self = (MalHashMap)this.MemberwiseClone(); - new_self.value = new Dictionary(value); - return new_self; - } - - public Dictionary getValue() { return value; } - - public override string ToString() { - return "{" + printer.join(value, " ", true) + "}"; - } - public override string ToString(bool print_readably) { - return "{" + printer.join(value, " ", print_readably) + "}"; - } - - public MalHashMap assoc_BANG(MalList lst) { - for (int i=0; i fn = null; - MalVal ast = null; - Mal.env.Env env = null; - MalList fparams; - bool macro = false; - public MalFunc(Func fn) { - this.fn = fn; - } - public MalFunc(MalVal ast, Mal.env.Env env, MalList fparams, - Func fn) { - this.fn = fn; - this.ast = ast; - this.env = env; - this.fparams = fparams; - } - - public override string ToString() { - if (ast != null) { - return ""; - } else { - return ""; - } - } - - public MalVal apply(MalList args) { - return fn(args); - } - - public MalVal getAst() { return ast; } - public Mal.env.Env getEnv() { return env; } - public MalList getFParams() { return fparams; } - public Mal.env.Env genEnv(MalList args) { - return new Mal.env.Env(env, fparams, args); - } - public bool isMacro() { return macro; } - public void setMacro() { macro = true; } - - } - } -} +using System; +using System.Collections.Generic; +using Mal; + +namespace Mal { + public class types { + // + // Exceptions/Errors + // + public class MalThrowable : Exception { + public MalThrowable() : base() { } + public MalThrowable(string msg) : base(msg) { } + } + public class MalError : MalThrowable { + public MalError(string msg) :base(msg) { } + } + public class MalContinue : MalThrowable { } + + // Thrown by throw function + public class MalException : MalThrowable { + MalVal value; + //string Message; + public MalException(MalVal value) { + this.value = value; + } + public MalException(string value) :base(value) { + this.value = new MalString(value); + } + public MalVal getValue() { return value; } + } + + // + // General functions + // + + public static bool _equal_Q(MalVal a, MalVal b) { + Type ota = a.GetType(), otb = b.GetType(); + if (!((ota == otb) || + (a is MalList && b is MalList))) { + return false; + } else { + if (a is MalInt) { + return ((MalInt)a).getValue() == + ((MalInt)b).getValue(); + } else if (a is MalSymbol) { + return ((MalSymbol)a).getName() == + ((MalSymbol)b).getName(); + } else if (a is MalString) { + return ((MalString)a).getValue() == + ((MalString)b).getValue(); + } else if (a is MalList) { + if (((MalList)a).size() != ((MalList)b).size()) { + return false; + } + for (int i=0; i<((MalList)a).size(); i++) { + if (! _equal_Q(((MalList)a)[i], ((MalList)b)[i])) { + return false; + } + } + return true; + } else if (a is MalHashMap) { + var akeys = ((MalHashMap)a).getValue().Keys; + var bkeys = ((MalHashMap)b).getValue().Keys; + if (akeys.Count != bkeys.Count) { + return false; + } + foreach (var k in akeys) { + if (!_equal_Q(((MalHashMap)a).getValue()[k], + ((MalHashMap)b).getValue()[k])) { + return false; + } + } + return true; + } else { + return a == b; + } + } + } + + + public abstract class MalVal { + MalVal meta = Nil; + public virtual MalVal copy() { + return (MalVal)this.MemberwiseClone(); + } + + // Default is just to call regular toString() + public virtual string ToString(bool print_readably) { + return this.ToString(); + } + public MalVal getMeta() { return meta; } + public MalVal setMeta(MalVal m) { meta = m; return this; } + public virtual bool list_Q() { return false; } + } + + public class MalConstant : MalVal { + string value; + public MalConstant(string name) { value = name; } + public new MalConstant copy() { return this; } + + public override string ToString() { + return value; + } + public override string ToString(bool print_readably) { + return value; + } + } + + static public MalConstant Nil = new MalConstant("nil"); + static public MalConstant True = new MalConstant("true"); + static public MalConstant False = new MalConstant("false"); + + public class MalInt : MalVal { + Int64 value; + public MalInt(Int64 v) { value = v; } + public new MalInt copy() { return this; } + + public Int64 getValue() { return value; } + public override string ToString() { + return value.ToString(); + } + public override string ToString(bool print_readably) { + return value.ToString(); + } + public static MalConstant operator <(MalInt a, MalInt b) { + return a.getValue() < b.getValue() ? True : False; + } + public static MalConstant operator <=(MalInt a, MalInt b) { + return a.getValue() <= b.getValue() ? True : False; + } + public static MalConstant operator >(MalInt a, MalInt b) { + return a.getValue() > b.getValue() ? True : False; + } + public static MalConstant operator >=(MalInt a, MalInt b) { + return a.getValue() >= b.getValue() ? True : False; + } + public static MalInt operator +(MalInt a, MalInt b) { + return new MalInt(a.getValue() + b.getValue()); + } + public static MalInt operator -(MalInt a, MalInt b) { + return new MalInt(a.getValue() - b.getValue()); + } + public static MalInt operator *(MalInt a, MalInt b) { + return new MalInt(a.getValue() * b.getValue()); + } + public static MalInt operator /(MalInt a, MalInt b) { + return new MalInt(a.getValue() / b.getValue()); + } + } + + public class MalSymbol : MalVal { + string value; + public MalSymbol(string v) { value = v; } + public MalSymbol(MalString v) { value = v.getValue(); } + public new MalSymbol copy() { return this; } + + public string getName() { return value; } + public override string ToString() { + return value; + } + public override string ToString(bool print_readably) { + return value; + } + } + + public class MalString : MalVal { + string value; + public MalString(string v) { value = v; } + public new MalString copy() { return this; } + + public string getValue() { return value; } + public override string ToString() { + return "\"" + value + "\""; + } + public override string ToString(bool print_readably) { + if (value.Length > 0 && value[0] == '\u029e') { + return ":" + value.Substring(1); + } else if (print_readably) { + return "\"" + value.Replace("\\", "\\\\") + .Replace("\"", "\\\"") + .Replace("\n", "\\n") + "\""; + } else { + return value; + } + } + } + + + + public class MalList : MalVal { + public string start = "(", end = ")"; + List value; + public MalList() { + value = new List(); + } + public MalList(List val) { + value = val; + } + public MalList(params MalVal[] mvs) { + value = new List(); + conj_BANG(mvs); + } + + public List getValue() { return value; } + public override bool list_Q() { return true; } + + public override string ToString() { + return start + printer.join(value, " ", true) + end; + } + public override string ToString(bool print_readably) { + return start + printer.join(value, " ", print_readably) + end; + } + + public MalList conj_BANG(params MalVal[] mvs) { + for (int i = 0; i < mvs.Length; i++) { + value.Add(mvs[i]); + } + return this; + } + + public int size() { return value.Count; } + public MalVal nth(int idx) { + return value.Count > idx ? value[idx] : Nil; + } + public MalVal this[int idx] { + get { return value.Count > idx ? value[idx] : Nil; } + } + public MalList rest() { + if (size() > 0) { + return new MalList(value.GetRange(1, value.Count-1)); + } else { + return new MalList(); + } + } + public virtual MalList slice(int start) { + return new MalList(value.GetRange(start, value.Count-start)); + } + public virtual MalList slice(int start, int end) { + return new MalList(value.GetRange(start, end-start)); + } + + } + + public class MalVector : MalList { + // Same implementation except for instantiation methods + public MalVector() :base() { + start = "["; + end = "]"; + } + public MalVector(List val) + :base(val) { + start = "["; + end = "]"; + } + + public override bool list_Q() { return false; } + + public override MalList slice(int start, int end) { + var val = this.getValue(); + return new MalVector(val.GetRange(start, val.Count-start)); + } + } + + public class MalHashMap : MalVal { + Dictionary value; + public MalHashMap(Dictionary val) { + value = val; + } + public MalHashMap(MalList lst) { + value = new Dictionary(); + assoc_BANG(lst); + } + public new MalHashMap copy() { + var new_self = (MalHashMap)this.MemberwiseClone(); + new_self.value = new Dictionary(value); + return new_self; + } + + public Dictionary getValue() { return value; } + + public override string ToString() { + return "{" + printer.join(value, " ", true) + "}"; + } + public override string ToString(bool print_readably) { + return "{" + printer.join(value, " ", print_readably) + "}"; + } + + public MalHashMap assoc_BANG(MalList lst) { + for (int i=0; i fn = null; + MalVal ast = null; + Mal.env.Env env = null; + MalList fparams; + bool macro = false; + public MalFunc(Func fn) { + this.fn = fn; + } + public MalFunc(MalVal ast, Mal.env.Env env, MalList fparams, + Func fn) { + this.fn = fn; + this.ast = ast; + this.env = env; + this.fparams = fparams; + } + + public override string ToString() { + if (ast != null) { + return ""; + } else { + return ""; + } + } + + public MalVal apply(MalList args) { + return fn(args); + } + + public MalVal getAst() { return ast; } + public Mal.env.Env getEnv() { return env; } + public MalList getFParams() { return fparams; } + public Mal.env.Env genEnv(MalList args) { + return new Mal.env.Env(env, fparams, args); + } + public bool isMacro() { return macro; } + public void setMacro() { macro = true; } + + } + } +} diff --git a/impls/d/Dockerfile b/impls/d/Dockerfile index a7b7113b4c..37126ae4e2 100644 --- a/impls/d/Dockerfile +++ b/impls/d/Dockerfile @@ -1,31 +1,31 @@ -FROM ubuntu:bionic -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install gcc gdc ldc gpg wget - -RUN wget https://dlang.org/install.sh -q -O install.sh && \ - bash install.sh -p /usr/local/dlang && \ - chmod 755 /usr/local/dlang/dmd* && \ - ln -sf /usr/local/dlang/dmd-*/linux/bin64/dmd /usr/bin/dmd - -ENV HOME /mal +FROM ubuntu:bionic +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install gcc gdc ldc gpg wget + +RUN wget https://dlang.org/install.sh -q -O install.sh && \ + bash install.sh -p /usr/local/dlang && \ + chmod 755 /usr/local/dlang/dmd* && \ + ln -sf /usr/local/dlang/dmd-*/linux/bin64/dmd /usr/bin/dmd + +ENV HOME /mal diff --git a/impls/d/Makefile b/impls/d/Makefile index 7872d8920e..5f17d9babc 100644 --- a/impls/d/Makefile +++ b/impls/d/Makefile @@ -1,54 +1,54 @@ -d_MODE ?= gdc - -D ?= $(d_MODE) - -ifeq ($(D),gdc) -CFLAGS += -g -O2 -Wall -LDFLAGS += -lreadline -OF = -o $@ -else ifeq ($(D),ldc2) -CFLAGS += -g -O2 -LDFLAGS += -L-lreadline -OF = -of $@ -else ifeq ($(D),dmd) -CFLAGS += -g -O -LDFLAGS += -L-lreadline -OF = -of=$@ -else - @echo "Unsupported D implementation $(D)" - @exit 1 -endif - -##################### - -EARLY_SRCS = step0_repl.d step1_read_print.d step2_eval.d -LATE_SRCS = step3_env.d step4_if_fn_do.d step5_tco.d step6_file.d \ - step7_quote.d step8_macros.d step9_try.d stepA_mal.d -SRCS = $(EARLY_SRCS) $(LATE_SRCS) -OBJS = $(SRCS:%.d=%.o) -BINS = $(OBJS:%.o=%) -EARLY_OBJS = types.o readline.o reader.o printer.o env.o -OTHER_OBJS = $(EARLY_OBJS) mal_core.o -EARLY_STEPS_BINS = $(EARLY_SRCS:%.d=%) -LATE_STEPS_BINS = $(LATE_SRCS:%.d=%) - -##################### - -all: $(BINS) - -dist: mal - -mal: $(word $(words $(BINS)),$(BINS)) - cp $< $@ - -$(OBJS) $(OTHER_OBJS): %.o: %.d - $(D) $(CFLAGS) -c $(@:%.o=%.d) $(OF) - -$(EARLY_STEPS_BINS): $(EARLY_OBJS) -$(LATE_STEPS_BINS): $(OTHER_OBJS) - -$(BINS): %: %.o - $(D) $+ $(OF) $(LDFLAGS) - -clean: - rm -f $(OBJS) $(BINS) $(OTHER_OBJS) mal +d_MODE ?= gdc + +D ?= $(d_MODE) + +ifeq ($(D),gdc) +CFLAGS += -g -O2 -Wall +LDFLAGS += -lreadline +OF = -o $@ +else ifeq ($(D),ldc2) +CFLAGS += -g -O2 +LDFLAGS += -L-lreadline +OF = -of $@ +else ifeq ($(D),dmd) +CFLAGS += -g -O +LDFLAGS += -L-lreadline +OF = -of=$@ +else + @echo "Unsupported D implementation $(D)" + @exit 1 +endif + +##################### + +EARLY_SRCS = step0_repl.d step1_read_print.d step2_eval.d +LATE_SRCS = step3_env.d step4_if_fn_do.d step5_tco.d step6_file.d \ + step7_quote.d step8_macros.d step9_try.d stepA_mal.d +SRCS = $(EARLY_SRCS) $(LATE_SRCS) +OBJS = $(SRCS:%.d=%.o) +BINS = $(OBJS:%.o=%) +EARLY_OBJS = types.o readline.o reader.o printer.o env.o +OTHER_OBJS = $(EARLY_OBJS) mal_core.o +EARLY_STEPS_BINS = $(EARLY_SRCS:%.d=%) +LATE_STEPS_BINS = $(LATE_SRCS:%.d=%) + +##################### + +all: $(BINS) + +dist: mal + +mal: $(word $(words $(BINS)),$(BINS)) + cp $< $@ + +$(OBJS) $(OTHER_OBJS): %.o: %.d + $(D) $(CFLAGS) -c $(@:%.o=%.d) $(OF) + +$(EARLY_STEPS_BINS): $(EARLY_OBJS) +$(LATE_STEPS_BINS): $(OTHER_OBJS) + +$(BINS): %: %.o + $(D) $+ $(OF) $(LDFLAGS) + +clean: + rm -f $(OBJS) $(BINS) $(OTHER_OBJS) mal diff --git a/impls/d/env.d b/impls/d/env.d index 200a864bf5..110d8d7211 100644 --- a/impls/d/env.d +++ b/impls/d/env.d @@ -1,53 +1,53 @@ -import types; - -class Env { - Env outer; - MalType[MalSymbol] data; - - this(Env outer_v, MalType[] binds = [], MalType[] exprs = []) - { - outer = outer_v; - foreach (i, MalType b; binds) - { - auto arg_name = verify_cast!MalSymbol(b); - if (arg_name.name == "&") - { - auto rest_arg_name = verify_cast!MalSymbol(binds[i + 1]); - auto rest_exprs = new MalList(exprs[i..$]); - set(rest_arg_name, rest_exprs); - break; - } - else - { - set(arg_name, exprs[i]); - } - } - } - - MalType set(MalSymbol key, MalType val) - { - data[key] = val; - return val; - } - - Env find(MalSymbol key) - { - auto val = (key in data); - if (val !is null) { - return this; - } else if (outer is null) { - return null; - } else { - return outer.find(key); - } - } - - MalType get(MalSymbol key) - { - auto found = find(key); - if (found is null) { - throw new Exception("'" ~ key.print(true) ~ "' not found"); - } - return found.data[key]; - } -} +import types; + +class Env { + Env outer; + MalType[MalSymbol] data; + + this(Env outer_v, MalType[] binds = [], MalType[] exprs = []) + { + outer = outer_v; + foreach (i, MalType b; binds) + { + auto arg_name = verify_cast!MalSymbol(b); + if (arg_name.name == "&") + { + auto rest_arg_name = verify_cast!MalSymbol(binds[i + 1]); + auto rest_exprs = new MalList(exprs[i..$]); + set(rest_arg_name, rest_exprs); + break; + } + else + { + set(arg_name, exprs[i]); + } + } + } + + MalType set(MalSymbol key, MalType val) + { + data[key] = val; + return val; + } + + Env find(MalSymbol key) + { + auto val = (key in data); + if (val !is null) { + return this; + } else if (outer is null) { + return null; + } else { + return outer.find(key); + } + } + + MalType get(MalSymbol key) + { + auto found = find(key); + if (found is null) { + throw new Exception("'" ~ key.print(true) ~ "' not found"); + } + return found.data[key]; + } +} diff --git a/impls/d/main.di b/impls/d/main.di index 15aac77083..a512d884df 100644 --- a/impls/d/main.di +++ b/impls/d/main.di @@ -1,4 +1,4 @@ -import types : MalType; -import env : Env; - -MalType EVAL(MalType ast, Env env); +import types : MalType; +import env : Env; + +MalType EVAL(MalType ast, Env env); diff --git a/impls/d/mal_core.d b/impls/d/mal_core.d index 86d681b33c..d9ccb0ea8e 100644 --- a/impls/d/mal_core.d +++ b/impls/d/mal_core.d @@ -1,427 +1,427 @@ -import core.time; -import std.algorithm; -import std.array; -import std.datetime; -import std.file; -import std.stdio; -import env; -import main; -import reader; -import readline; -import types; -import printer; - -static MalType mal_equal(MalType[] a ...) -{ - verify_args_count(a, 2); - return bool_to_mal(a[0] == a[1]); -} - -static MalType mal_throw(MalType[] a ...) -{ - verify_args_count(a, 1); - throw new MalException(a[0]); -} - -static MalType mal_symbol(MalType[] a ...) -{ - verify_args_count(a, 1); - auto s = verify_cast!MalString(a[0]); - return new MalSymbol(s.val); -} - -static MalType mal_string_q(MalType[] a ...) -{ - verify_args_count(a, 1); - auto s = cast(MalString) a[0]; - if (s is null) return mal_false; - return bool_to_mal(!s.is_keyword()); -} - -static MalType mal_keyword(MalType[] a ...) -{ - verify_args_count(a, 1); - auto s = verify_cast!MalString(a[0]); - if (s.is_keyword()) return s; - return new MalString("\u029e" ~ s.val); -} - -static MalType mal_keyword_q(MalType[] a ...) -{ - verify_args_count(a, 1); - auto s = cast(MalString) a[0]; - if (s is null) return mal_false; - return bool_to_mal(s.is_keyword()); -} - -static MalType mal_fn_q(MalType[] a ...) -{ - verify_args_count(a, 1); - auto builtinfn = cast(MalBuiltinFunc) a[0]; - if (builtinfn !is null) return mal_true; - auto malfunc = cast(MalFunc) a[0]; - if (malfunc !is null) return bool_to_mal(!malfunc.is_macro); - return mal_false; -} - -static MalType mal_macro_q(MalType[] a ...) -{ - verify_args_count(a, 1); - auto malfunc = cast(MalFunc) a[0]; - if (malfunc !is null) return bool_to_mal(malfunc.is_macro); - return mal_false; -} - -static MalType mal_pr_str(MalType[] a ...) -{ - auto items_strs = a.map!(e => pr_str(e, true)); - return new MalString(array(items_strs).join(" ")); -} - -static MalType mal_str(MalType[] a ...) -{ - auto items_strs = a.map!(e => pr_str(e, false)); - return new MalString(array(items_strs).join("")); -} - -static MalType mal_prn(MalType[] a ...) -{ - auto items_strs = a.map!(e => pr_str(e, true)); - writeln(array(items_strs).join(" ")); - return mal_nil; -} - -static MalType mal_println(MalType[] a ...) -{ - auto items_strs = a.map!(e => pr_str(e, false)); - writeln(array(items_strs).join(" ")); - return mal_nil; -} - -static MalType mal_read_string(MalType[] a ...) -{ - verify_args_count(a, 1); - auto s = verify_cast!MalString(a[0]); - return read_str(s.val); -} - -static MalType mal_readline(MalType[] a ...) -{ - verify_args_count(a, 1); - auto s = verify_cast!MalString(a[0]); - auto line = _readline(s.val); - return line is null ? mal_nil : new MalString(line); -} - -static MalType mal_slurp(MalType[] a ...) -{ - verify_args_count(a, 1); - auto filename = verify_cast!MalString(a[0]).val; - auto content = cast(string) std.file.read(filename); - return new MalString(content); -} - -alias TwoIntFunc = MalType function(long x, long y); - -MalType binary_int_op(TwoIntFunc f, MalType[] a ...) -{ - verify_args_count(a, 2); - MalInteger i0 = verify_cast!MalInteger(a[0]); - MalInteger i1 = verify_cast!MalInteger(a[1]); - return f(i0.val, i1.val); -} - -static MalType mal_time_ms(MalType[] a ...) -{ - immutable epoch = SysTime(unixTimeToStdTime(0)); - immutable hnsecs_since_epoch = Clock.currTime(UTC()) - epoch; - immutable ms = hnsecs_since_epoch.total!"msecs"(); - return new MalInteger(ms); -} - -static bool is_nil(MalType v) -{ - return cast(MalNil)(v) !is null; -} - -static MalType mal_assoc(MalType[] a ...) -{ - verify_min_args_count(a, 1); - auto hm = verify_cast!MalHashmap(a[0]); - auto new_hm = new MalHashmap(hm.data.dup); - new_hm.put_kv_list(a[1..$]); - return new_hm; -} - -static MalType mal_dissoc(MalType[] a ...) -{ - verify_min_args_count(a, 1); - auto hm = verify_cast!MalHashmap(a[0]); - auto new_hm = new MalHashmap(hm.data.dup); - foreach (k; a[1..$]) - { - new_hm.remove(k); - } - return new_hm; -} - -static MalType mal_get(MalType[] a ...) -{ - verify_args_count(a, 2); - if (is_nil(a[0])) return mal_nil; - auto hm = verify_cast!MalHashmap(a[0]); - return hm.get(a[1]); -} - -static MalType mal_contains_q(MalType[] a ...) -{ - verify_args_count(a, 2); - if (is_nil(a[0])) return mal_false; - auto hm = verify_cast!MalHashmap(a[0]); - return bool_to_mal(hm.contains(a[1])); -} - -static MalType mal_keys(MalType[] a ...) -{ - verify_args_count(a, 1); - auto hm = verify_cast!MalHashmap(a[0]); - auto keys = hm.data.keys.map!(s => cast(MalType)(new MalString(s))); - return new MalList(array(keys)); -} - -static MalType mal_vals(MalType[] a ...) -{ - verify_args_count(a, 1); - auto hm = verify_cast!MalHashmap(a[0]); - return new MalList(hm.data.values); -} - -static MalType mal_cons(MalType[] a ...) -{ - verify_args_count(a, 2); - auto lst = verify_cast!MalSequential(a[1]); - return new MalList([a[0]] ~ lst.elements); -} - -static MalType mal_concat(MalType[] a ...) -{ - MalType[] res; - foreach (e; a) - { - auto lst = verify_cast!MalSequential(e); - res ~= lst.elements; - } - return new MalList(res); -} - -static MalType mal_vec(MalType[] a ...) -{ - verify_args_count(a, 1); - return new MalVector(verify_cast!MalSequential(a[0]).elements); -} - -static MalType mal_nth(MalType[] a ...) -{ - verify_args_count(a, 2); - if (is_nil(a[0])) - { - throw new Exception("nth: index out of range"); - } - auto seq = verify_cast!MalSequential(a[0]); - auto index = verify_cast!MalInteger(a[1]).val; - if (index >= seq.elements.length) - { - throw new Exception("nth: index out of range"); - } - return seq.elements[index]; -} - -static MalType mal_first(MalType[] a ...) -{ - verify_args_count(a, 1); - if (is_nil(a[0])) return mal_nil; - auto seq = verify_cast!MalSequential(a[0]); - if (seq.elements.length == 0) return mal_nil; - return seq.elements[0]; -} - -static MalType mal_rest(MalType[] a ...) -{ - verify_args_count(a, 1); - if (is_nil(a[0])) return new MalList([]); - auto seq = verify_cast!MalSequential(a[0]); - if (seq.elements.length == 0) return new MalList([]); - return new MalList(seq.elements[1..$]); -} - - -static MalType mal_empty_q(MalType[] a ...) -{ - verify_args_count(a, 1); - if (is_nil(a[0])) - { - return mal_true; - } - auto s = verify_cast!MalSequential(a[0]); - return bool_to_mal(s.elements.length == 0); -} - -static MalType mal_count(MalType[] a ...) -{ - verify_args_count(a, 1); - if (is_nil(a[0])) - { - return new MalInteger(0); - } - auto s = verify_cast!MalSequential(a[0]); - return new MalInteger(cast(int)(s.elements.length)); -} - -static MalType mal_apply(MalType[] a ...) -{ - verify_min_args_count(a, 2); - auto last_seq_elems = verify_cast!MalSequential(a[$-1]).elements; - auto funcargs = a.length == 2 ? last_seq_elems : (a[1..$-1] ~ last_seq_elems); - - auto builtinfn = cast(MalBuiltinFunc) a[0]; - if (builtinfn !is null) - { - return builtinfn.fn(funcargs); - } - - auto malfunc = verify_cast!MalFunc(a[0]); - auto callenv = new Env(malfunc.def_env, malfunc.arg_names, funcargs); - - return EVAL(malfunc.func_body, callenv); -} - -static MalType mal_map(MalType[] a ...) -{ - verify_args_count(a, 2); - auto seq = verify_cast!MalSequential(a[1]); - auto mapped_items = seq.elements.map!(e => mal_apply(a[0], new MalList([e]))); - return new MalList(array(mapped_items)); -} - -static MalType mal_conj(MalType[] a ...) -{ - verify_min_args_count(a, 1); - auto seq = verify_cast!MalSequential(a[0]); - return reduce!((s,e) => s.conj(e))(seq, a[1..$]); -} - -static MalType mal_seq(MalType[] a ...) -{ - verify_args_count(a, 1); - auto seqobj = cast(HasSeq) a[0]; - if (seqobj is null) return mal_nil; - return seqobj.seq(); -} - -static MalType mal_meta(MalType[] a ...) -{ - verify_args_count(a, 1); - auto metaobj = cast(MalMeta) a[0]; - if (metaobj is null) return mal_nil; - return metaobj.meta(); -} - -static MalType mal_with_meta(return MalType[] a ...) -{ - verify_args_count(a, 2); - if (auto metaobj = cast(MalMeta) a[0]) - return metaobj.with_meta(a[1]); - return a[0]; -} - -static MalType mal_reset_bang(return MalType[] a ...) -{ - verify_args_count(a, 2); - verify_cast!MalAtom(a[0]).val = a[1]; - return a[1]; -} - -static MalType mal_swap_bang(MalType[] a ...) -{ - verify_min_args_count(a, 2); - auto atom = verify_cast!MalAtom(a[0]); - auto args = [atom.val] ~ a[2..$]; - auto newval = mal_apply([a[1], new MalList(args)]); - return mal_reset_bang([atom, newval]); -} - -BuiltinStaticFuncType[string] core_ns; - -static this() -{ - core_ns = [ - "=": &mal_equal, - "throw": &mal_throw, - - "nil?": (a ...) => mal_type_q!MalNil(a), - "true?": (a ...) => mal_type_q!MalTrue(a), - "false?": (a ...) => mal_type_q!MalFalse(a), - "symbol": &mal_symbol, - "symbol?": (a ...) => mal_type_q!MalSymbol(a), - "string?": &mal_string_q, - "keyword": &mal_keyword, - "keyword?": &mal_keyword_q, - "number?": (a ...) => mal_type_q!MalInteger(a), - "fn?": &mal_fn_q, - "macro?": &mal_macro_q, - - "pr-str": &mal_pr_str, - "str": &mal_str, - "prn": &mal_prn, - "println": &mal_println, - "read-string": &mal_read_string, - "readline": &mal_readline, - "slurp": &mal_slurp, - - "<": (a ...) => binary_int_op((x,y) => bool_to_mal(x < y), a), - "<=": (a ...) => binary_int_op((x,y) => bool_to_mal(x <= y), a), - ">": (a ...) => binary_int_op((x,y) => bool_to_mal(x > y), a), - ">=": (a ...) => binary_int_op((x,y) => bool_to_mal(x >= y), a), - "+": (a ...) => binary_int_op((x,y) => new MalInteger(x + y), a), - "-": (a ...) => binary_int_op((x,y) => new MalInteger(x - y), a), - "*": (a ...) => binary_int_op((x,y) => new MalInteger(x * y), a), - "/": (a ...) => binary_int_op((x,y) => new MalInteger(x / y), a), - "time-ms": &mal_time_ms, - - "list": (a ...) => new MalList(a), - "list?": (a ...) => mal_type_q!MalList(a), - "vector": (a ...) => new MalVector(a), - "vector?": (a ...) => mal_type_q!MalVector(a), - "hash-map": (a ...) => new MalHashmap(a), - "map?": (a ...) => mal_type_q!MalHashmap(a), - "assoc": &mal_assoc, - "dissoc": &mal_dissoc, - "get": &mal_get, - "contains?": &mal_contains_q, - "keys": &mal_keys, - "vals": &mal_vals, - - "sequential?": (a ...) => mal_type_q!MalSequential(a), - "cons": &mal_cons, - "concat": &mal_concat, - "vec": &mal_vec, - "nth": &mal_nth, - "first": &mal_first, - "rest": &mal_rest, - "empty?": &mal_empty_q, - "count": &mal_count, - "apply": &mal_apply, - "map": &mal_map, - - "conj": &mal_conj, - "seq": &mal_seq, - - "meta": &mal_meta, - "with-meta": &mal_with_meta, - "atom": (a ...) => new MalAtom(verify_args_count(a, 1)[0]), - "atom?": (a ...) => mal_type_q!MalAtom(a), - "deref": (a ...) => verify_cast!MalAtom(verify_args_count(a, 1)[0]).val, - "reset!": &mal_reset_bang, - "swap!": &mal_swap_bang - ]; -} +import core.time; +import std.algorithm; +import std.array; +import std.datetime; +import std.file; +import std.stdio; +import env; +import main; +import reader; +import readline; +import types; +import printer; + +static MalType mal_equal(MalType[] a ...) +{ + verify_args_count(a, 2); + return bool_to_mal(a[0] == a[1]); +} + +static MalType mal_throw(MalType[] a ...) +{ + verify_args_count(a, 1); + throw new MalException(a[0]); +} + +static MalType mal_symbol(MalType[] a ...) +{ + verify_args_count(a, 1); + auto s = verify_cast!MalString(a[0]); + return new MalSymbol(s.val); +} + +static MalType mal_string_q(MalType[] a ...) +{ + verify_args_count(a, 1); + auto s = cast(MalString) a[0]; + if (s is null) return mal_false; + return bool_to_mal(!s.is_keyword()); +} + +static MalType mal_keyword(MalType[] a ...) +{ + verify_args_count(a, 1); + auto s = verify_cast!MalString(a[0]); + if (s.is_keyword()) return s; + return new MalString("\u029e" ~ s.val); +} + +static MalType mal_keyword_q(MalType[] a ...) +{ + verify_args_count(a, 1); + auto s = cast(MalString) a[0]; + if (s is null) return mal_false; + return bool_to_mal(s.is_keyword()); +} + +static MalType mal_fn_q(MalType[] a ...) +{ + verify_args_count(a, 1); + auto builtinfn = cast(MalBuiltinFunc) a[0]; + if (builtinfn !is null) return mal_true; + auto malfunc = cast(MalFunc) a[0]; + if (malfunc !is null) return bool_to_mal(!malfunc.is_macro); + return mal_false; +} + +static MalType mal_macro_q(MalType[] a ...) +{ + verify_args_count(a, 1); + auto malfunc = cast(MalFunc) a[0]; + if (malfunc !is null) return bool_to_mal(malfunc.is_macro); + return mal_false; +} + +static MalType mal_pr_str(MalType[] a ...) +{ + auto items_strs = a.map!(e => pr_str(e, true)); + return new MalString(array(items_strs).join(" ")); +} + +static MalType mal_str(MalType[] a ...) +{ + auto items_strs = a.map!(e => pr_str(e, false)); + return new MalString(array(items_strs).join("")); +} + +static MalType mal_prn(MalType[] a ...) +{ + auto items_strs = a.map!(e => pr_str(e, true)); + writeln(array(items_strs).join(" ")); + return mal_nil; +} + +static MalType mal_println(MalType[] a ...) +{ + auto items_strs = a.map!(e => pr_str(e, false)); + writeln(array(items_strs).join(" ")); + return mal_nil; +} + +static MalType mal_read_string(MalType[] a ...) +{ + verify_args_count(a, 1); + auto s = verify_cast!MalString(a[0]); + return read_str(s.val); +} + +static MalType mal_readline(MalType[] a ...) +{ + verify_args_count(a, 1); + auto s = verify_cast!MalString(a[0]); + auto line = _readline(s.val); + return line is null ? mal_nil : new MalString(line); +} + +static MalType mal_slurp(MalType[] a ...) +{ + verify_args_count(a, 1); + auto filename = verify_cast!MalString(a[0]).val; + auto content = cast(string) std.file.read(filename); + return new MalString(content); +} + +alias TwoIntFunc = MalType function(long x, long y); + +MalType binary_int_op(TwoIntFunc f, MalType[] a ...) +{ + verify_args_count(a, 2); + MalInteger i0 = verify_cast!MalInteger(a[0]); + MalInteger i1 = verify_cast!MalInteger(a[1]); + return f(i0.val, i1.val); +} + +static MalType mal_time_ms(MalType[] a ...) +{ + immutable epoch = SysTime(unixTimeToStdTime(0)); + immutable hnsecs_since_epoch = Clock.currTime(UTC()) - epoch; + immutable ms = hnsecs_since_epoch.total!"msecs"(); + return new MalInteger(ms); +} + +static bool is_nil(MalType v) +{ + return cast(MalNil)(v) !is null; +} + +static MalType mal_assoc(MalType[] a ...) +{ + verify_min_args_count(a, 1); + auto hm = verify_cast!MalHashmap(a[0]); + auto new_hm = new MalHashmap(hm.data.dup); + new_hm.put_kv_list(a[1..$]); + return new_hm; +} + +static MalType mal_dissoc(MalType[] a ...) +{ + verify_min_args_count(a, 1); + auto hm = verify_cast!MalHashmap(a[0]); + auto new_hm = new MalHashmap(hm.data.dup); + foreach (k; a[1..$]) + { + new_hm.remove(k); + } + return new_hm; +} + +static MalType mal_get(MalType[] a ...) +{ + verify_args_count(a, 2); + if (is_nil(a[0])) return mal_nil; + auto hm = verify_cast!MalHashmap(a[0]); + return hm.get(a[1]); +} + +static MalType mal_contains_q(MalType[] a ...) +{ + verify_args_count(a, 2); + if (is_nil(a[0])) return mal_false; + auto hm = verify_cast!MalHashmap(a[0]); + return bool_to_mal(hm.contains(a[1])); +} + +static MalType mal_keys(MalType[] a ...) +{ + verify_args_count(a, 1); + auto hm = verify_cast!MalHashmap(a[0]); + auto keys = hm.data.keys.map!(s => cast(MalType)(new MalString(s))); + return new MalList(array(keys)); +} + +static MalType mal_vals(MalType[] a ...) +{ + verify_args_count(a, 1); + auto hm = verify_cast!MalHashmap(a[0]); + return new MalList(hm.data.values); +} + +static MalType mal_cons(MalType[] a ...) +{ + verify_args_count(a, 2); + auto lst = verify_cast!MalSequential(a[1]); + return new MalList([a[0]] ~ lst.elements); +} + +static MalType mal_concat(MalType[] a ...) +{ + MalType[] res; + foreach (e; a) + { + auto lst = verify_cast!MalSequential(e); + res ~= lst.elements; + } + return new MalList(res); +} + +static MalType mal_vec(MalType[] a ...) +{ + verify_args_count(a, 1); + return new MalVector(verify_cast!MalSequential(a[0]).elements); +} + +static MalType mal_nth(MalType[] a ...) +{ + verify_args_count(a, 2); + if (is_nil(a[0])) + { + throw new Exception("nth: index out of range"); + } + auto seq = verify_cast!MalSequential(a[0]); + auto index = verify_cast!MalInteger(a[1]).val; + if (index >= seq.elements.length) + { + throw new Exception("nth: index out of range"); + } + return seq.elements[index]; +} + +static MalType mal_first(MalType[] a ...) +{ + verify_args_count(a, 1); + if (is_nil(a[0])) return mal_nil; + auto seq = verify_cast!MalSequential(a[0]); + if (seq.elements.length == 0) return mal_nil; + return seq.elements[0]; +} + +static MalType mal_rest(MalType[] a ...) +{ + verify_args_count(a, 1); + if (is_nil(a[0])) return new MalList([]); + auto seq = verify_cast!MalSequential(a[0]); + if (seq.elements.length == 0) return new MalList([]); + return new MalList(seq.elements[1..$]); +} + + +static MalType mal_empty_q(MalType[] a ...) +{ + verify_args_count(a, 1); + if (is_nil(a[0])) + { + return mal_true; + } + auto s = verify_cast!MalSequential(a[0]); + return bool_to_mal(s.elements.length == 0); +} + +static MalType mal_count(MalType[] a ...) +{ + verify_args_count(a, 1); + if (is_nil(a[0])) + { + return new MalInteger(0); + } + auto s = verify_cast!MalSequential(a[0]); + return new MalInteger(cast(int)(s.elements.length)); +} + +static MalType mal_apply(MalType[] a ...) +{ + verify_min_args_count(a, 2); + auto last_seq_elems = verify_cast!MalSequential(a[$-1]).elements; + auto funcargs = a.length == 2 ? last_seq_elems : (a[1..$-1] ~ last_seq_elems); + + auto builtinfn = cast(MalBuiltinFunc) a[0]; + if (builtinfn !is null) + { + return builtinfn.fn(funcargs); + } + + auto malfunc = verify_cast!MalFunc(a[0]); + auto callenv = new Env(malfunc.def_env, malfunc.arg_names, funcargs); + + return EVAL(malfunc.func_body, callenv); +} + +static MalType mal_map(MalType[] a ...) +{ + verify_args_count(a, 2); + auto seq = verify_cast!MalSequential(a[1]); + auto mapped_items = seq.elements.map!(e => mal_apply(a[0], new MalList([e]))); + return new MalList(array(mapped_items)); +} + +static MalType mal_conj(MalType[] a ...) +{ + verify_min_args_count(a, 1); + auto seq = verify_cast!MalSequential(a[0]); + return reduce!((s,e) => s.conj(e))(seq, a[1..$]); +} + +static MalType mal_seq(MalType[] a ...) +{ + verify_args_count(a, 1); + auto seqobj = cast(HasSeq) a[0]; + if (seqobj is null) return mal_nil; + return seqobj.seq(); +} + +static MalType mal_meta(MalType[] a ...) +{ + verify_args_count(a, 1); + auto metaobj = cast(MalMeta) a[0]; + if (metaobj is null) return mal_nil; + return metaobj.meta(); +} + +static MalType mal_with_meta(return MalType[] a ...) +{ + verify_args_count(a, 2); + if (auto metaobj = cast(MalMeta) a[0]) + return metaobj.with_meta(a[1]); + return a[0]; +} + +static MalType mal_reset_bang(return MalType[] a ...) +{ + verify_args_count(a, 2); + verify_cast!MalAtom(a[0]).val = a[1]; + return a[1]; +} + +static MalType mal_swap_bang(MalType[] a ...) +{ + verify_min_args_count(a, 2); + auto atom = verify_cast!MalAtom(a[0]); + auto args = [atom.val] ~ a[2..$]; + auto newval = mal_apply([a[1], new MalList(args)]); + return mal_reset_bang([atom, newval]); +} + +BuiltinStaticFuncType[string] core_ns; + +static this() +{ + core_ns = [ + "=": &mal_equal, + "throw": &mal_throw, + + "nil?": (a ...) => mal_type_q!MalNil(a), + "true?": (a ...) => mal_type_q!MalTrue(a), + "false?": (a ...) => mal_type_q!MalFalse(a), + "symbol": &mal_symbol, + "symbol?": (a ...) => mal_type_q!MalSymbol(a), + "string?": &mal_string_q, + "keyword": &mal_keyword, + "keyword?": &mal_keyword_q, + "number?": (a ...) => mal_type_q!MalInteger(a), + "fn?": &mal_fn_q, + "macro?": &mal_macro_q, + + "pr-str": &mal_pr_str, + "str": &mal_str, + "prn": &mal_prn, + "println": &mal_println, + "read-string": &mal_read_string, + "readline": &mal_readline, + "slurp": &mal_slurp, + + "<": (a ...) => binary_int_op((x,y) => bool_to_mal(x < y), a), + "<=": (a ...) => binary_int_op((x,y) => bool_to_mal(x <= y), a), + ">": (a ...) => binary_int_op((x,y) => bool_to_mal(x > y), a), + ">=": (a ...) => binary_int_op((x,y) => bool_to_mal(x >= y), a), + "+": (a ...) => binary_int_op((x,y) => new MalInteger(x + y), a), + "-": (a ...) => binary_int_op((x,y) => new MalInteger(x - y), a), + "*": (a ...) => binary_int_op((x,y) => new MalInteger(x * y), a), + "/": (a ...) => binary_int_op((x,y) => new MalInteger(x / y), a), + "time-ms": &mal_time_ms, + + "list": (a ...) => new MalList(a), + "list?": (a ...) => mal_type_q!MalList(a), + "vector": (a ...) => new MalVector(a), + "vector?": (a ...) => mal_type_q!MalVector(a), + "hash-map": (a ...) => new MalHashmap(a), + "map?": (a ...) => mal_type_q!MalHashmap(a), + "assoc": &mal_assoc, + "dissoc": &mal_dissoc, + "get": &mal_get, + "contains?": &mal_contains_q, + "keys": &mal_keys, + "vals": &mal_vals, + + "sequential?": (a ...) => mal_type_q!MalSequential(a), + "cons": &mal_cons, + "concat": &mal_concat, + "vec": &mal_vec, + "nth": &mal_nth, + "first": &mal_first, + "rest": &mal_rest, + "empty?": &mal_empty_q, + "count": &mal_count, + "apply": &mal_apply, + "map": &mal_map, + + "conj": &mal_conj, + "seq": &mal_seq, + + "meta": &mal_meta, + "with-meta": &mal_with_meta, + "atom": (a ...) => new MalAtom(verify_args_count(a, 1)[0]), + "atom?": (a ...) => mal_type_q!MalAtom(a), + "deref": (a ...) => verify_cast!MalAtom(verify_args_count(a, 1)[0]).val, + "reset!": &mal_reset_bang, + "swap!": &mal_swap_bang + ]; +} diff --git a/impls/d/printer.d b/impls/d/printer.d index ed2da24b7d..c790802f65 100644 --- a/impls/d/printer.d +++ b/impls/d/printer.d @@ -1,6 +1,6 @@ -import types; - -string pr_str(MalType obj, bool readable = true) -{ - return obj.print(readable); -} +import types; + +string pr_str(MalType obj, bool readable = true) +{ + return obj.print(readable); +} diff --git a/impls/d/reader.d b/impls/d/reader.d index c2ffe2c69a..7a95e543cc 100644 --- a/impls/d/reader.d +++ b/impls/d/reader.d @@ -1,191 +1,191 @@ -import std.array; -import std.regex; -import std.stdio; -import types; - -MalSymbol sym_quote; -MalSymbol sym_quasiquote; -MalSymbol sym_unquote; -MalSymbol sym_splice_unquote; -MalSymbol sym_deref; -MalSymbol sym_with_meta; - -static this() -{ - sym_quote = new MalSymbol("quote"); - sym_quasiquote = new MalSymbol("quasiquote"); - sym_unquote = new MalSymbol("unquote"); - sym_splice_unquote = new MalSymbol("splice-unquote"); - sym_deref = new MalSymbol("deref"); - sym_with_meta = new MalSymbol("with-meta"); -} - -class Reader -{ - int pos = 0; - const string[] tokens; - - this(string[] the_tokens) - { - tokens = the_tokens.dup; - } - - string peek() - { - if (pos >= tokens.length) return null; - return tokens[pos]; - } - - string next() - { - auto token = peek(); - pos++; - return token; - } -} - -auto tokenize_ctr = ctRegex!(r"[\s,]*(~@|[\[\]{}()'`~^@]|" ~ `"` ~ `(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"` ~ r"`,;)]*)"); - -string[] tokenize(string str) -{ - string[] tokens; - foreach(c; matchAll(str, tokenize_ctr)) - { - auto token = c[1]; - if (token.length == 0) continue; - if (token[0] == ';') continue; - tokens ~= token; - } - return tokens; -} - -MalString parse_string(string token) -{ - // TODO: this could be done with replaceAll - // https://dlang.org/library/std/regex/replace_all.html - string unescaped = - token[1..$-1] // Remove surrounding quotes - .replace("\\\\", "\u029e") - .replace("\\n", "\n") - .replace("\\\"", "\"") - .replace("\u029e", "\\"); - return new MalString(unescaped); -} - -auto integer_ctr = ctRegex!(r"^-?[0-9]+$"); -auto string_ctr = ctRegex!(`^"(?:\\.|[^\\"])*"$`); - -MalType read_atom(Reader reader) -{ - auto token = reader.next(); - switch (token) - { - case "nil": return mal_nil; - case "false": return mal_false; - case "true": return mal_true; - default: - switch (token[0]) { - case ':': - return new MalString("\u029e" ~ token[1..$]); - case '"': - auto captures = matchFirst(token, string_ctr); - if (captures.empty()) - { - throw new Exception("expected '\"', got EOF"); - } - return parse_string(token); - default: - auto captures = matchFirst(token, integer_ctr); - if (!captures.empty()) - { - return new MalInteger(token); - } - - return new MalSymbol(token); - } - } -} - -MalType[] read_items(Reader reader, string start, string end) -{ - auto open_paren = reader.next(); - if (open_paren != start) throw new Exception("expected '" ~ start ~ "', got EOF"); - - string token; - MalType[] res; - while ((token = reader.peek()) != end) - { - if (token is null) - { - throw new Exception("expected '" ~ end ~ "', got EOF"); - } - res ~= read_form(reader); - } - reader.next(); // consume the ')' - return res; -} - -MalList read_list(Reader reader) -{ - return new MalList(read_items(reader, "(", ")")); -} - -MalVector read_vector(Reader reader) -{ - return new MalVector(read_items(reader, "[", "]")); -} - -MalHashmap read_hashmap(Reader reader) -{ - return new MalHashmap(read_items(reader, "{", "}")); -} - -MalList read_quote_shortcut(Reader reader, MalSymbol sym) -{ - reader.next(); // consume the special quote char - return new MalList([sym, read_form(reader)]); -} - -MalType read_form(Reader reader) -{ - auto token = reader.peek(); - if (token is null) return new MalNil(); - switch(token) - { - case "'": - return read_quote_shortcut(reader, sym_quote); - case "`": - return read_quote_shortcut(reader, sym_quasiquote); - case "~": - return read_quote_shortcut(reader, sym_unquote); - case "~@": - return read_quote_shortcut(reader, sym_splice_unquote); - case "@": - return read_quote_shortcut(reader, sym_deref); - case "^": - reader.next(); // consume the caret char - auto meta = read_form(reader); - return new MalList([sym_with_meta, read_form(reader), meta]); - case "(": - return read_list(reader); - case ")": - throw new Exception("unexpected ')'"); - case "[": - return read_vector(reader); - case "]": - throw new Exception("unexpected ']'"); - case "{": - return read_hashmap(reader); - case "}": - throw new Exception("unexpected '}'"); - default: - return read_atom(reader); - } -} - -MalType read_str(string str) -{ - auto tokens = tokenize(str); - auto reader = new Reader(tokens); - return read_form(reader); -} +import std.array; +import std.regex; +import std.stdio; +import types; + +MalSymbol sym_quote; +MalSymbol sym_quasiquote; +MalSymbol sym_unquote; +MalSymbol sym_splice_unquote; +MalSymbol sym_deref; +MalSymbol sym_with_meta; + +static this() +{ + sym_quote = new MalSymbol("quote"); + sym_quasiquote = new MalSymbol("quasiquote"); + sym_unquote = new MalSymbol("unquote"); + sym_splice_unquote = new MalSymbol("splice-unquote"); + sym_deref = new MalSymbol("deref"); + sym_with_meta = new MalSymbol("with-meta"); +} + +class Reader +{ + int pos = 0; + const string[] tokens; + + this(string[] the_tokens) + { + tokens = the_tokens.dup; + } + + string peek() + { + if (pos >= tokens.length) return null; + return tokens[pos]; + } + + string next() + { + auto token = peek(); + pos++; + return token; + } +} + +auto tokenize_ctr = ctRegex!(r"[\s,]*(~@|[\[\]{}()'`~^@]|" ~ `"` ~ `(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"` ~ r"`,;)]*)"); + +string[] tokenize(string str) +{ + string[] tokens; + foreach(c; matchAll(str, tokenize_ctr)) + { + auto token = c[1]; + if (token.length == 0) continue; + if (token[0] == ';') continue; + tokens ~= token; + } + return tokens; +} + +MalString parse_string(string token) +{ + // TODO: this could be done with replaceAll + // https://dlang.org/library/std/regex/replace_all.html + string unescaped = + token[1..$-1] // Remove surrounding quotes + .replace("\\\\", "\u029e") + .replace("\\n", "\n") + .replace("\\\"", "\"") + .replace("\u029e", "\\"); + return new MalString(unescaped); +} + +auto integer_ctr = ctRegex!(r"^-?[0-9]+$"); +auto string_ctr = ctRegex!(`^"(?:\\.|[^\\"])*"$`); + +MalType read_atom(Reader reader) +{ + auto token = reader.next(); + switch (token) + { + case "nil": return mal_nil; + case "false": return mal_false; + case "true": return mal_true; + default: + switch (token[0]) { + case ':': + return new MalString("\u029e" ~ token[1..$]); + case '"': + auto captures = matchFirst(token, string_ctr); + if (captures.empty()) + { + throw new Exception("expected '\"', got EOF"); + } + return parse_string(token); + default: + auto captures = matchFirst(token, integer_ctr); + if (!captures.empty()) + { + return new MalInteger(token); + } + + return new MalSymbol(token); + } + } +} + +MalType[] read_items(Reader reader, string start, string end) +{ + auto open_paren = reader.next(); + if (open_paren != start) throw new Exception("expected '" ~ start ~ "', got EOF"); + + string token; + MalType[] res; + while ((token = reader.peek()) != end) + { + if (token is null) + { + throw new Exception("expected '" ~ end ~ "', got EOF"); + } + res ~= read_form(reader); + } + reader.next(); // consume the ')' + return res; +} + +MalList read_list(Reader reader) +{ + return new MalList(read_items(reader, "(", ")")); +} + +MalVector read_vector(Reader reader) +{ + return new MalVector(read_items(reader, "[", "]")); +} + +MalHashmap read_hashmap(Reader reader) +{ + return new MalHashmap(read_items(reader, "{", "}")); +} + +MalList read_quote_shortcut(Reader reader, MalSymbol sym) +{ + reader.next(); // consume the special quote char + return new MalList([sym, read_form(reader)]); +} + +MalType read_form(Reader reader) +{ + auto token = reader.peek(); + if (token is null) return new MalNil(); + switch(token) + { + case "'": + return read_quote_shortcut(reader, sym_quote); + case "`": + return read_quote_shortcut(reader, sym_quasiquote); + case "~": + return read_quote_shortcut(reader, sym_unquote); + case "~@": + return read_quote_shortcut(reader, sym_splice_unquote); + case "@": + return read_quote_shortcut(reader, sym_deref); + case "^": + reader.next(); // consume the caret char + auto meta = read_form(reader); + return new MalList([sym_with_meta, read_form(reader), meta]); + case "(": + return read_list(reader); + case ")": + throw new Exception("unexpected ')'"); + case "[": + return read_vector(reader); + case "]": + throw new Exception("unexpected ']'"); + case "{": + return read_hashmap(reader); + case "}": + throw new Exception("unexpected '}'"); + default: + return read_atom(reader); + } +} + +MalType read_str(string str) +{ + auto tokens = tokenize(str); + auto reader = new Reader(tokens); + return read_form(reader); +} diff --git a/impls/d/readline.d b/impls/d/readline.d index 37a5e73321..f903225f0b 100644 --- a/impls/d/readline.d +++ b/impls/d/readline.d @@ -1,60 +1,60 @@ -import std.string; -import std.path; -import std.file; - -import core.stdc.string; -import core.stdc.stdlib; - -// readline/readline.h -extern (C) char* readline(const char* prompt); - -// readline/history.h -extern (C) void using_history(); -extern (C) void add_history(const char *line); -extern (C) int read_history(const char *filename); -extern (C) int append_history(int nelement, const char *filename); - -bool history_loaded = false; -const string history_file = "~/.mal-history"; - -void load_history() -{ - if (history_loaded) return; - using_history(); - string hf = expandTilde(history_file); - std.file.append(hf, ""); // Create the file if needed - read_history(toStringz(hf)); - history_loaded = true; -} - -void append_to_history() -{ - string hf = expandTilde(history_file); - append_history(1, toStringz(hf)); -} - -// Convert from C-string to D-string (making a copy) -pure string fromCstr(char* cstr) -{ - auto len = core.stdc.string.strlen(cstr); - if (len == 0) return ""; - string line = cstr[0..len].dup; - return line; -} - -string _readline(in string prompt) -{ - load_history(); - - auto cstr = readline(toStringz(prompt)); - if (cstr is null) return null; - scope(exit) { core.stdc.stdlib.free(cstr); } - - if (cstr[0] != '\0') - { - add_history(cstr); // Add input to in-memory history - append_to_history(); // Flush new line of history to disk - } - - return fromCstr(cstr); -} +import std.string; +import std.path; +import std.file; + +import core.stdc.string; +import core.stdc.stdlib; + +// readline/readline.h +extern (C) char* readline(const char* prompt); + +// readline/history.h +extern (C) void using_history(); +extern (C) void add_history(const char *line); +extern (C) int read_history(const char *filename); +extern (C) int append_history(int nelement, const char *filename); + +bool history_loaded = false; +const string history_file = "~/.mal-history"; + +void load_history() +{ + if (history_loaded) return; + using_history(); + string hf = expandTilde(history_file); + std.file.append(hf, ""); // Create the file if needed + read_history(toStringz(hf)); + history_loaded = true; +} + +void append_to_history() +{ + string hf = expandTilde(history_file); + append_history(1, toStringz(hf)); +} + +// Convert from C-string to D-string (making a copy) +pure string fromCstr(char* cstr) +{ + auto len = core.stdc.string.strlen(cstr); + if (len == 0) return ""; + string line = cstr[0..len].dup; + return line; +} + +string _readline(in string prompt) +{ + load_history(); + + auto cstr = readline(toStringz(prompt)); + if (cstr is null) return null; + scope(exit) { core.stdc.stdlib.free(cstr); } + + if (cstr[0] != '\0') + { + add_history(cstr); // Add input to in-memory history + append_to_history(); // Flush new line of history to disk + } + + return fromCstr(cstr); +} diff --git a/impls/d/run b/impls/d/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/d/run +++ b/impls/d/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/d/step0_repl.d b/impls/d/step0_repl.d index 475dcca2a1..ee31ac461d 100644 --- a/impls/d/step0_repl.d +++ b/impls/d/step0_repl.d @@ -1,35 +1,35 @@ -import std.stdio; -import std.string; -import readline; - -string READ(string str) -{ - return str; -} - -string EVAL(string ast) -{ - return ast; -} - -string PRINT(string ast) -{ - return ast; -} - -string rep(string str) -{ - return PRINT(EVAL(READ(str))); -} - -void main() -{ - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - writeln(rep(line)); - } - writeln(""); -} +import std.stdio; +import std.string; +import readline; + +string READ(string str) +{ + return str; +} + +string EVAL(string ast) +{ + return ast; +} + +string PRINT(string ast) +{ + return ast; +} + +string rep(string str) +{ + return PRINT(EVAL(READ(str))); +} + +void main() +{ + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + writeln(rep(line)); + } + writeln(""); +} diff --git a/impls/d/step1_read_print.d b/impls/d/step1_read_print.d index 1f73ec9399..a07ee2a7c0 100644 --- a/impls/d/step1_read_print.d +++ b/impls/d/step1_read_print.d @@ -1,45 +1,45 @@ -import std.stdio; -import std.string; -import readline; -import reader; -import printer; -import types; - -MalType READ(string str) -{ - return read_str(str); -} - -MalType EVAL(MalType ast) -{ - return ast; -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -string rep(string str) -{ - return PRINT(EVAL(READ(str))); -} - -void main() -{ - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +import std.stdio; +import std.string; +import readline; +import reader; +import printer; +import types; + +MalType READ(string str) +{ + return read_str(str); +} + +MalType EVAL(MalType ast) +{ + return ast; +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +string rep(string str) +{ + return PRINT(EVAL(READ(str))); +} + +void main() +{ + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/step2_eval.d b/impls/d/step2_eval.d index aec2a100cc..65e193aa15 100644 --- a/impls/d/step2_eval.d +++ b/impls/d/step2_eval.d @@ -1,132 +1,132 @@ -import std.algorithm; -import std.array; -import std.stdio; -import std.string; -import readline; -import reader; -import printer; -import types; - -alias Env = MalType[string]; - -MalType READ(string str) -{ - return read_str(str); -} - -MalType eval_ast(MalType ast, Env env) -{ - if (auto sym = cast(MalSymbol)ast) - { - auto v = (sym.name in env); - if (v is null) throw new Exception("'" ~ sym.name ~ "' not found"); - return *v; - } - else if (auto lst = cast(MalList)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalList(el); - } - else if (auto lst = cast(MalVector)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalVector(el); - } - else if (auto hm = cast(MalHashmap)ast) - { - typeof(hm.data) new_data; - foreach (string k, MalType v; hm.data) - { - new_data[k] = EVAL(v, env); - } - return new MalHashmap(new_data); - } - else - { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) -{ - if (typeid(ast) != typeid(MalList)) - { - return eval_ast(ast, env); - } - if ((cast(MalList) ast).elements.length == 0) - { - return ast; - } - - auto el = verify_cast!MalList(eval_ast(ast, env)); - auto fobj = verify_cast!MalBuiltinFunc(el.elements[0]); - auto args = el.elements[1..$]; - return fobj.fn(args); -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -static MalType mal_add(MalType[] a ...) -{ - verify_args_count(a, 2); - MalInteger i0 = verify_cast!MalInteger(a[0]); - MalInteger i1 = verify_cast!MalInteger(a[1]); - return new MalInteger(i0.val + i1.val); -} - -static MalType mal_sub(MalType[] a ...) -{ - verify_args_count(a, 2); - MalInteger i0 = verify_cast!MalInteger(a[0]); - MalInteger i1 = verify_cast!MalInteger(a[1]); - return new MalInteger(i0.val - i1.val); -} - -static MalType mal_mul(MalType[] a ...) -{ - verify_args_count(a, 2); - MalInteger i0 = verify_cast!MalInteger(a[0]); - MalInteger i1 = verify_cast!MalInteger(a[1]); - return new MalInteger(i0.val * i1.val); -} - -static MalType mal_div(MalType[] a ...) -{ - verify_args_count(a, 2); - MalInteger i0 = verify_cast!MalInteger(a[0]); - MalInteger i1 = verify_cast!MalInteger(a[1]); - return new MalInteger(i0.val / i1.val); -} - -void main() -{ - Env repl_env; - repl_env["+"] = new MalBuiltinFunc(&mal_add, "+"); - repl_env["-"] = new MalBuiltinFunc(&mal_sub, "-"); - repl_env["*"] = new MalBuiltinFunc(&mal_mul, "*"); - repl_env["/"] = new MalBuiltinFunc(&mal_div, "/"); - - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line, repl_env)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +import std.algorithm; +import std.array; +import std.stdio; +import std.string; +import readline; +import reader; +import printer; +import types; + +alias Env = MalType[string]; + +MalType READ(string str) +{ + return read_str(str); +} + +MalType eval_ast(MalType ast, Env env) +{ + if (auto sym = cast(MalSymbol)ast) + { + auto v = (sym.name in env); + if (v is null) throw new Exception("'" ~ sym.name ~ "' not found"); + return *v; + } + else if (auto lst = cast(MalList)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalList(el); + } + else if (auto lst = cast(MalVector)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalVector(el); + } + else if (auto hm = cast(MalHashmap)ast) + { + typeof(hm.data) new_data; + foreach (string k, MalType v; hm.data) + { + new_data[k] = EVAL(v, env); + } + return new MalHashmap(new_data); + } + else + { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) +{ + if (typeid(ast) != typeid(MalList)) + { + return eval_ast(ast, env); + } + if ((cast(MalList) ast).elements.length == 0) + { + return ast; + } + + auto el = verify_cast!MalList(eval_ast(ast, env)); + auto fobj = verify_cast!MalBuiltinFunc(el.elements[0]); + auto args = el.elements[1..$]; + return fobj.fn(args); +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +static MalType mal_add(MalType[] a ...) +{ + verify_args_count(a, 2); + MalInteger i0 = verify_cast!MalInteger(a[0]); + MalInteger i1 = verify_cast!MalInteger(a[1]); + return new MalInteger(i0.val + i1.val); +} + +static MalType mal_sub(MalType[] a ...) +{ + verify_args_count(a, 2); + MalInteger i0 = verify_cast!MalInteger(a[0]); + MalInteger i1 = verify_cast!MalInteger(a[1]); + return new MalInteger(i0.val - i1.val); +} + +static MalType mal_mul(MalType[] a ...) +{ + verify_args_count(a, 2); + MalInteger i0 = verify_cast!MalInteger(a[0]); + MalInteger i1 = verify_cast!MalInteger(a[1]); + return new MalInteger(i0.val * i1.val); +} + +static MalType mal_div(MalType[] a ...) +{ + verify_args_count(a, 2); + MalInteger i0 = verify_cast!MalInteger(a[0]); + MalInteger i1 = verify_cast!MalInteger(a[1]); + return new MalInteger(i0.val / i1.val); +} + +void main() +{ + Env repl_env; + repl_env["+"] = new MalBuiltinFunc(&mal_add, "+"); + repl_env["-"] = new MalBuiltinFunc(&mal_sub, "-"); + repl_env["*"] = new MalBuiltinFunc(&mal_mul, "*"); + repl_env["/"] = new MalBuiltinFunc(&mal_div, "/"); + + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line, repl_env)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/step3_env.d b/impls/d/step3_env.d index e733379ca4..454b4b24ca 100644 --- a/impls/d/step3_env.d +++ b/impls/d/step3_env.d @@ -1,153 +1,153 @@ -module main; - -import std.algorithm; -import std.array; -import std.range; -import std.stdio; -import std.string; -import env; -import readline; -import reader; -import printer; -import types; - -MalType READ(string str) -{ - return read_str(str); -} - -MalType eval_ast(MalType ast, Env env) -{ - if (auto sym = cast(MalSymbol)ast) - { - return env.get(sym); - } - else if (auto lst = cast(MalList)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalList(el); - } - else if (auto lst = cast(MalVector)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalVector(el); - } - else if (auto hm = cast(MalHashmap)ast) - { - typeof(hm.data) new_data; - foreach (string k, MalType v; hm.data) - { - new_data[k] = EVAL(v, env); - } - return new MalHashmap(new_data); - } - else - { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) -{ - MalList ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - if (ast_list.elements.length == 0) - { - return ast; - } - - auto a0_sym = verify_cast!MalSymbol(ast_list.elements[0]); - switch (a0_sym.name) - { - case "def!": - auto a1 = verify_cast!MalSymbol(ast_list.elements[1]); - return env.set(a1, EVAL(ast_list.elements[2], env)); - - case "let*": - auto a1 = verify_cast!MalSequential(ast_list.elements[1]); - auto let_env = new Env(env); - foreach (kv; chunks(a1.elements, 2)) - { - if (kv.length < 2) throw new Exception("let* requires even number of elements"); - auto var_name = verify_cast!MalSymbol(kv[0]); - let_env.set(var_name, EVAL(kv[1], let_env)); - } - return EVAL(ast_list.elements[2], let_env); - - default: - auto el = verify_cast!MalList(eval_ast(ast_list, env)); - auto fobj = verify_cast!MalBuiltinFunc(el.elements[0]); - auto args = el.elements[1..$]; - return fobj.fn(args); - } -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -static MalType mal_add(MalType[] a ...) -{ - verify_args_count(a, 2); - MalInteger i0 = verify_cast!MalInteger(a[0]); - MalInteger i1 = verify_cast!MalInteger(a[1]); - return new MalInteger(i0.val + i1.val); -} - -static MalType mal_sub(MalType[] a ...) -{ - verify_args_count(a, 2); - MalInteger i0 = verify_cast!MalInteger(a[0]); - MalInteger i1 = verify_cast!MalInteger(a[1]); - return new MalInteger(i0.val - i1.val); -} - -static MalType mal_mul(MalType[] a ...) -{ - verify_args_count(a, 2); - MalInteger i0 = verify_cast!MalInteger(a[0]); - MalInteger i1 = verify_cast!MalInteger(a[1]); - return new MalInteger(i0.val * i1.val); -} - -static MalType mal_div(MalType[] a ...) -{ - verify_args_count(a, 2); - MalInteger i0 = verify_cast!MalInteger(a[0]); - MalInteger i1 = verify_cast!MalInteger(a[1]); - return new MalInteger(i0.val / i1.val); -} - -void main() -{ - auto repl_env = new Env(null); - repl_env.set(new MalSymbol("+"), new MalBuiltinFunc(&mal_add, "+")); - repl_env.set(new MalSymbol("-"), new MalBuiltinFunc(&mal_sub, "-")); - repl_env.set(new MalSymbol("*"), new MalBuiltinFunc(&mal_mul, "*")); - repl_env.set(new MalSymbol("/"), new MalBuiltinFunc(&mal_div, "/")); - - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line, repl_env)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +module main; + +import std.algorithm; +import std.array; +import std.range; +import std.stdio; +import std.string; +import env; +import readline; +import reader; +import printer; +import types; + +MalType READ(string str) +{ + return read_str(str); +} + +MalType eval_ast(MalType ast, Env env) +{ + if (auto sym = cast(MalSymbol)ast) + { + return env.get(sym); + } + else if (auto lst = cast(MalList)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalList(el); + } + else if (auto lst = cast(MalVector)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalVector(el); + } + else if (auto hm = cast(MalHashmap)ast) + { + typeof(hm.data) new_data; + foreach (string k, MalType v; hm.data) + { + new_data[k] = EVAL(v, env); + } + return new MalHashmap(new_data); + } + else + { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) +{ + MalList ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + if (ast_list.elements.length == 0) + { + return ast; + } + + auto a0_sym = verify_cast!MalSymbol(ast_list.elements[0]); + switch (a0_sym.name) + { + case "def!": + auto a1 = verify_cast!MalSymbol(ast_list.elements[1]); + return env.set(a1, EVAL(ast_list.elements[2], env)); + + case "let*": + auto a1 = verify_cast!MalSequential(ast_list.elements[1]); + auto let_env = new Env(env); + foreach (kv; chunks(a1.elements, 2)) + { + if (kv.length < 2) throw new Exception("let* requires even number of elements"); + auto var_name = verify_cast!MalSymbol(kv[0]); + let_env.set(var_name, EVAL(kv[1], let_env)); + } + return EVAL(ast_list.elements[2], let_env); + + default: + auto el = verify_cast!MalList(eval_ast(ast_list, env)); + auto fobj = verify_cast!MalBuiltinFunc(el.elements[0]); + auto args = el.elements[1..$]; + return fobj.fn(args); + } +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +static MalType mal_add(MalType[] a ...) +{ + verify_args_count(a, 2); + MalInteger i0 = verify_cast!MalInteger(a[0]); + MalInteger i1 = verify_cast!MalInteger(a[1]); + return new MalInteger(i0.val + i1.val); +} + +static MalType mal_sub(MalType[] a ...) +{ + verify_args_count(a, 2); + MalInteger i0 = verify_cast!MalInteger(a[0]); + MalInteger i1 = verify_cast!MalInteger(a[1]); + return new MalInteger(i0.val - i1.val); +} + +static MalType mal_mul(MalType[] a ...) +{ + verify_args_count(a, 2); + MalInteger i0 = verify_cast!MalInteger(a[0]); + MalInteger i1 = verify_cast!MalInteger(a[1]); + return new MalInteger(i0.val * i1.val); +} + +static MalType mal_div(MalType[] a ...) +{ + verify_args_count(a, 2); + MalInteger i0 = verify_cast!MalInteger(a[0]); + MalInteger i1 = verify_cast!MalInteger(a[1]); + return new MalInteger(i0.val / i1.val); +} + +void main() +{ + auto repl_env = new Env(null); + repl_env.set(new MalSymbol("+"), new MalBuiltinFunc(&mal_add, "+")); + repl_env.set(new MalSymbol("-"), new MalBuiltinFunc(&mal_sub, "-")); + repl_env.set(new MalSymbol("*"), new MalBuiltinFunc(&mal_mul, "*")); + repl_env.set(new MalSymbol("/"), new MalBuiltinFunc(&mal_div, "/")); + + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line, repl_env)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/step4_if_fn_do.d b/impls/d/step4_if_fn_do.d index aac2d1e874..6f8141489e 100644 --- a/impls/d/step4_if_fn_do.d +++ b/impls/d/step4_if_fn_do.d @@ -1,167 +1,167 @@ -module main; - -import std.algorithm; -import std.array; -import std.range; -import std.stdio; -import std.string; -import env; -import mal_core; -import readline; -import reader; -import printer; -import types; - -MalType READ(string str) -{ - return read_str(str); -} - -MalType eval_ast(MalType ast, Env env) -{ - if (auto sym = cast(MalSymbol)ast) - { - return env.get(sym); - } - else if (auto lst = cast(MalList)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalList(el); - } - else if (auto lst = cast(MalVector)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalVector(el); - } - else if (auto hm = cast(MalHashmap)ast) - { - typeof(hm.data) new_data; - foreach (string k, MalType v; hm.data) - { - new_data[k] = EVAL(v, env); - } - return new MalHashmap(new_data); - } - else - { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) -{ - MalList ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - auto aste = ast_list.elements; - if (aste.length == 0) - { - return ast; - } - auto a0_sym = cast(MalSymbol) aste[0]; - auto sym_name = a0_sym is null ? "" : a0_sym.name; - switch (sym_name) - { - case "def!": - auto a1 = verify_cast!MalSymbol(aste[1]); - return env.set(a1, EVAL(aste[2], env)); - - case "let*": - auto a1 = verify_cast!MalSequential(aste[1]); - auto let_env = new Env(env); - foreach (kv; chunks(a1.elements, 2)) - { - if (kv.length < 2) throw new Exception("let* requires even number of elements"); - auto var_name = verify_cast!MalSymbol(kv[0]); - let_env.set(var_name, EVAL(kv[1], let_env)); - } - return EVAL(aste[2], let_env); - - case "do": - auto rest = new MalList(aste[1..$]); - auto el = verify_cast!MalList(eval_ast(rest, env)); - return el.elements[$-1]; - - case "if": - auto cond = EVAL(aste[1], env); - if (cond.is_truthy()) - return EVAL(aste[2], env); - else - if (aste.length > 3) - return EVAL(aste[3], env); - else - return mal_nil; - - case "fn*": - auto args_list = verify_cast!MalSequential(aste[1]); - return new MalFunc(args_list.elements, aste[2], env); - - default: - auto el = verify_cast!MalList(eval_ast(ast, env)); - if (el.elements.length == 0) - { - throw new Exception("Expected a non-empty list"); - } - auto first = el.elements[0]; - auto rest = el.elements[1..$]; - if (auto funcobj = cast(MalFunc)first) - { - auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); - return EVAL(funcobj.func_body, callenv); - } - else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) - { - return builtinfuncobj.fn(rest); - } - else - { - throw new Exception("Expected a function"); - } - } -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -MalType re(string str, Env env) -{ - return EVAL(READ(str), env); -} - -string rep(string str, Env env) -{ - return PRINT(re(str, env)); -} - -void main() -{ - auto repl_env = new Env(null); - foreach (string sym_name, BuiltinStaticFuncType f; core_ns) - { - repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); - } - - // core.mal: defined using the language itself - re("(def! not (fn* (a) (if a false true)))", repl_env); - - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line, repl_env)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +module main; + +import std.algorithm; +import std.array; +import std.range; +import std.stdio; +import std.string; +import env; +import mal_core; +import readline; +import reader; +import printer; +import types; + +MalType READ(string str) +{ + return read_str(str); +} + +MalType eval_ast(MalType ast, Env env) +{ + if (auto sym = cast(MalSymbol)ast) + { + return env.get(sym); + } + else if (auto lst = cast(MalList)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalList(el); + } + else if (auto lst = cast(MalVector)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalVector(el); + } + else if (auto hm = cast(MalHashmap)ast) + { + typeof(hm.data) new_data; + foreach (string k, MalType v; hm.data) + { + new_data[k] = EVAL(v, env); + } + return new MalHashmap(new_data); + } + else + { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) +{ + MalList ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + auto aste = ast_list.elements; + if (aste.length == 0) + { + return ast; + } + auto a0_sym = cast(MalSymbol) aste[0]; + auto sym_name = a0_sym is null ? "" : a0_sym.name; + switch (sym_name) + { + case "def!": + auto a1 = verify_cast!MalSymbol(aste[1]); + return env.set(a1, EVAL(aste[2], env)); + + case "let*": + auto a1 = verify_cast!MalSequential(aste[1]); + auto let_env = new Env(env); + foreach (kv; chunks(a1.elements, 2)) + { + if (kv.length < 2) throw new Exception("let* requires even number of elements"); + auto var_name = verify_cast!MalSymbol(kv[0]); + let_env.set(var_name, EVAL(kv[1], let_env)); + } + return EVAL(aste[2], let_env); + + case "do": + auto rest = new MalList(aste[1..$]); + auto el = verify_cast!MalList(eval_ast(rest, env)); + return el.elements[$-1]; + + case "if": + auto cond = EVAL(aste[1], env); + if (cond.is_truthy()) + return EVAL(aste[2], env); + else + if (aste.length > 3) + return EVAL(aste[3], env); + else + return mal_nil; + + case "fn*": + auto args_list = verify_cast!MalSequential(aste[1]); + return new MalFunc(args_list.elements, aste[2], env); + + default: + auto el = verify_cast!MalList(eval_ast(ast, env)); + if (el.elements.length == 0) + { + throw new Exception("Expected a non-empty list"); + } + auto first = el.elements[0]; + auto rest = el.elements[1..$]; + if (auto funcobj = cast(MalFunc)first) + { + auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); + return EVAL(funcobj.func_body, callenv); + } + else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) + { + return builtinfuncobj.fn(rest); + } + else + { + throw new Exception("Expected a function"); + } + } +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +MalType re(string str, Env env) +{ + return EVAL(READ(str), env); +} + +string rep(string str, Env env) +{ + return PRINT(re(str, env)); +} + +void main() +{ + auto repl_env = new Env(null); + foreach (string sym_name, BuiltinStaticFuncType f; core_ns) + { + repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); + } + + // core.mal: defined using the language itself + re("(def! not (fn* (a) (if a false true)))", repl_env); + + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line, repl_env)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/step5_tco.d b/impls/d/step5_tco.d index 120d95139a..69e1e7a37f 100644 --- a/impls/d/step5_tco.d +++ b/impls/d/step5_tco.d @@ -1,183 +1,183 @@ -module main; - -import std.algorithm; -import std.array; -import std.range; -import std.stdio; -import std.string; -import env; -import mal_core; -import readline; -import reader; -import printer; -import types; - -MalType READ(string str) -{ - return read_str(str); -} - -MalType eval_ast(MalType ast, Env env) -{ - if (auto sym = cast(MalSymbol)ast) - { - return env.get(sym); - } - else if (auto lst = cast(MalList)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalList(el); - } - else if (auto lst = cast(MalVector)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalVector(el); - } - else if (auto hm = cast(MalHashmap)ast) - { - typeof(hm.data) new_data; - foreach (string k, MalType v; hm.data) - { - new_data[k] = EVAL(v, env); - } - return new MalHashmap(new_data); - } - else - { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) -{ - for (;;) - { - MalList ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - auto aste = ast_list.elements; - if (aste.length == 0) - { - return ast; - } - auto a0_sym = cast(MalSymbol) aste[0]; - auto sym_name = a0_sym is null ? "" : a0_sym.name; - switch (sym_name) - { - case "def!": - auto a1 = verify_cast!MalSymbol(aste[1]); - return env.set(a1, EVAL(aste[2], env)); - - case "let*": - auto a1 = verify_cast!MalSequential(aste[1]); - auto let_env = new Env(env); - foreach (kv; chunks(a1.elements, 2)) - { - if (kv.length < 2) throw new Exception("let* requires even number of elements"); - auto var_name = verify_cast!MalSymbol(kv[0]); - let_env.set(var_name, EVAL(kv[1], let_env)); - } - ast = aste[2]; - env = let_env; - continue; // TCO - - case "do": - auto all_but_last = new MalList(aste[1..$-1]); - eval_ast(all_but_last, env); - ast = aste[$-1]; - continue; // TCO - - case "if": - auto cond = EVAL(aste[1], env); - if (cond.is_truthy()) - { - ast = aste[2]; - continue; // TCO - } - else - if (aste.length > 3) - { - ast = aste[3]; - continue; // TCO - } - else - { - return mal_nil; - } - - case "fn*": - auto args_list = verify_cast!MalSequential(aste[1]); - return new MalFunc(args_list.elements, aste[2], env); - - default: - auto el = verify_cast!MalList(eval_ast(ast, env)); - if (el.elements.length == 0) - { - throw new Exception("Expected a non-empty list"); - } - auto first = el.elements[0]; - auto rest = el.elements[1..$]; - if (auto funcobj = cast(MalFunc)first) - { - auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); - ast = funcobj.func_body; - env = callenv; - continue; // TCO - } - else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) - { - return builtinfuncobj.fn(rest); - } - else - { - throw new Exception("Expected a function"); - } - } - } -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -MalType re(string str, Env env) -{ - return EVAL(READ(str), env); -} - -string rep(string str, Env env) -{ - return PRINT(re(str, env)); -} - -void main() -{ - auto repl_env = new Env(null); - foreach (string sym_name, BuiltinStaticFuncType f; core_ns) - { - repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); - } - - // core.mal: defined using the language itself - re("(def! not (fn* (a) (if a false true)))", repl_env); - - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line, repl_env)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +module main; + +import std.algorithm; +import std.array; +import std.range; +import std.stdio; +import std.string; +import env; +import mal_core; +import readline; +import reader; +import printer; +import types; + +MalType READ(string str) +{ + return read_str(str); +} + +MalType eval_ast(MalType ast, Env env) +{ + if (auto sym = cast(MalSymbol)ast) + { + return env.get(sym); + } + else if (auto lst = cast(MalList)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalList(el); + } + else if (auto lst = cast(MalVector)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalVector(el); + } + else if (auto hm = cast(MalHashmap)ast) + { + typeof(hm.data) new_data; + foreach (string k, MalType v; hm.data) + { + new_data[k] = EVAL(v, env); + } + return new MalHashmap(new_data); + } + else + { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) +{ + for (;;) + { + MalList ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + auto aste = ast_list.elements; + if (aste.length == 0) + { + return ast; + } + auto a0_sym = cast(MalSymbol) aste[0]; + auto sym_name = a0_sym is null ? "" : a0_sym.name; + switch (sym_name) + { + case "def!": + auto a1 = verify_cast!MalSymbol(aste[1]); + return env.set(a1, EVAL(aste[2], env)); + + case "let*": + auto a1 = verify_cast!MalSequential(aste[1]); + auto let_env = new Env(env); + foreach (kv; chunks(a1.elements, 2)) + { + if (kv.length < 2) throw new Exception("let* requires even number of elements"); + auto var_name = verify_cast!MalSymbol(kv[0]); + let_env.set(var_name, EVAL(kv[1], let_env)); + } + ast = aste[2]; + env = let_env; + continue; // TCO + + case "do": + auto all_but_last = new MalList(aste[1..$-1]); + eval_ast(all_but_last, env); + ast = aste[$-1]; + continue; // TCO + + case "if": + auto cond = EVAL(aste[1], env); + if (cond.is_truthy()) + { + ast = aste[2]; + continue; // TCO + } + else + if (aste.length > 3) + { + ast = aste[3]; + continue; // TCO + } + else + { + return mal_nil; + } + + case "fn*": + auto args_list = verify_cast!MalSequential(aste[1]); + return new MalFunc(args_list.elements, aste[2], env); + + default: + auto el = verify_cast!MalList(eval_ast(ast, env)); + if (el.elements.length == 0) + { + throw new Exception("Expected a non-empty list"); + } + auto first = el.elements[0]; + auto rest = el.elements[1..$]; + if (auto funcobj = cast(MalFunc)first) + { + auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); + ast = funcobj.func_body; + env = callenv; + continue; // TCO + } + else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) + { + return builtinfuncobj.fn(rest); + } + else + { + throw new Exception("Expected a function"); + } + } + } +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +MalType re(string str, Env env) +{ + return EVAL(READ(str), env); +} + +string rep(string str, Env env) +{ + return PRINT(re(str, env)); +} + +void main() +{ + auto repl_env = new Env(null); + foreach (string sym_name, BuiltinStaticFuncType f; core_ns) + { + repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); + } + + // core.mal: defined using the language itself + re("(def! not (fn* (a) (if a false true)))", repl_env); + + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line, repl_env)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/step6_file.d b/impls/d/step6_file.d index 321b90b042..a32bf60a1d 100644 --- a/impls/d/step6_file.d +++ b/impls/d/step6_file.d @@ -1,212 +1,212 @@ -module main; - -import std.algorithm; -import std.array; -import std.range; -import std.stdio; -import std.string; -import core.stdc.stdlib; -import env; -import mal_core; -import readline; -import reader; -import printer; -import types; - -MalType READ(string str) -{ - return read_str(str); -} - -MalType eval_ast(MalType ast, Env env) -{ - if (auto sym = cast(MalSymbol)ast) - { - return env.get(sym); - } - else if (auto lst = cast(MalList)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalList(el); - } - else if (auto lst = cast(MalVector)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalVector(el); - } - else if (auto hm = cast(MalHashmap)ast) - { - typeof(hm.data) new_data; - foreach (string k, MalType v; hm.data) - { - new_data[k] = EVAL(v, env); - } - return new MalHashmap(new_data); - } - else - { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) -{ - for (;;) - { - MalList ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - auto aste = ast_list.elements; - if (aste.length == 0) - { - return ast; - } - auto a0_sym = cast(MalSymbol) aste[0]; - auto sym_name = a0_sym is null ? "" : a0_sym.name; - switch (sym_name) - { - case "def!": - auto a1 = verify_cast!MalSymbol(aste[1]); - return env.set(a1, EVAL(aste[2], env)); - - case "let*": - auto a1 = verify_cast!MalSequential(aste[1]); - auto let_env = new Env(env); - foreach (kv; chunks(a1.elements, 2)) - { - if (kv.length < 2) throw new Exception("let* requires even number of elements"); - auto var_name = verify_cast!MalSymbol(kv[0]); - let_env.set(var_name, EVAL(kv[1], let_env)); - } - ast = aste[2]; - env = let_env; - continue; // TCO - - case "do": - auto all_but_last = new MalList(aste[1..$-1]); - eval_ast(all_but_last, env); - ast = aste[$-1]; - continue; // TCO - - case "if": - auto cond = EVAL(aste[1], env); - if (cond.is_truthy()) - { - ast = aste[2]; - continue; // TCO - } - else - if (aste.length > 3) - { - ast = aste[3]; - continue; // TCO - } - else - { - return mal_nil; - } - - case "fn*": - auto args_list = verify_cast!MalSequential(aste[1]); - return new MalFunc(args_list.elements, aste[2], env); - - default: - auto el = verify_cast!MalList(eval_ast(ast, env)); - if (el.elements.length == 0) - { - throw new Exception("Expected a non-empty list"); - } - auto first = el.elements[0]; - auto rest = el.elements[1..$]; - if (auto funcobj = cast(MalFunc)first) - { - auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); - ast = funcobj.func_body; - env = callenv; - continue; // TCO - } - else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) - { - return builtinfuncobj.fn(rest); - } - else - { - throw new Exception("Expected a function"); - } - } - } -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -MalType re(string str, Env env) -{ - return EVAL(READ(str), env); -} - -string rep(string str, Env env) -{ - return PRINT(re(str, env)); -} - -static MalList create_argv_list(string[] args) -{ - if (args.length <= 2) return new MalList([]); - return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); -} - -void main(string[] args) -{ - Env repl_env = new Env(null); - foreach (string sym_name, BuiltinStaticFuncType f; core_ns) - { - repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); - } - - BuiltinFuncType eval_func = (a ...) { - verify_args_count(a, 1); - return EVAL(a[0], repl_env); - }; - repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); - repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); - - // core.mal: defined using the language itself - re("(def! not (fn* (a) (if a false true)))", repl_env); - re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - - if (args.length > 1) - { - try - { - rep("(load-file \"" ~ args[1] ~ "\")", repl_env); - return; - } - catch (Exception e) - { - writeln("Error: ", e.msg); - exit(1); - } - } - - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line, repl_env)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +module main; + +import std.algorithm; +import std.array; +import std.range; +import std.stdio; +import std.string; +import core.stdc.stdlib; +import env; +import mal_core; +import readline; +import reader; +import printer; +import types; + +MalType READ(string str) +{ + return read_str(str); +} + +MalType eval_ast(MalType ast, Env env) +{ + if (auto sym = cast(MalSymbol)ast) + { + return env.get(sym); + } + else if (auto lst = cast(MalList)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalList(el); + } + else if (auto lst = cast(MalVector)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalVector(el); + } + else if (auto hm = cast(MalHashmap)ast) + { + typeof(hm.data) new_data; + foreach (string k, MalType v; hm.data) + { + new_data[k] = EVAL(v, env); + } + return new MalHashmap(new_data); + } + else + { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) +{ + for (;;) + { + MalList ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + auto aste = ast_list.elements; + if (aste.length == 0) + { + return ast; + } + auto a0_sym = cast(MalSymbol) aste[0]; + auto sym_name = a0_sym is null ? "" : a0_sym.name; + switch (sym_name) + { + case "def!": + auto a1 = verify_cast!MalSymbol(aste[1]); + return env.set(a1, EVAL(aste[2], env)); + + case "let*": + auto a1 = verify_cast!MalSequential(aste[1]); + auto let_env = new Env(env); + foreach (kv; chunks(a1.elements, 2)) + { + if (kv.length < 2) throw new Exception("let* requires even number of elements"); + auto var_name = verify_cast!MalSymbol(kv[0]); + let_env.set(var_name, EVAL(kv[1], let_env)); + } + ast = aste[2]; + env = let_env; + continue; // TCO + + case "do": + auto all_but_last = new MalList(aste[1..$-1]); + eval_ast(all_but_last, env); + ast = aste[$-1]; + continue; // TCO + + case "if": + auto cond = EVAL(aste[1], env); + if (cond.is_truthy()) + { + ast = aste[2]; + continue; // TCO + } + else + if (aste.length > 3) + { + ast = aste[3]; + continue; // TCO + } + else + { + return mal_nil; + } + + case "fn*": + auto args_list = verify_cast!MalSequential(aste[1]); + return new MalFunc(args_list.elements, aste[2], env); + + default: + auto el = verify_cast!MalList(eval_ast(ast, env)); + if (el.elements.length == 0) + { + throw new Exception("Expected a non-empty list"); + } + auto first = el.elements[0]; + auto rest = el.elements[1..$]; + if (auto funcobj = cast(MalFunc)first) + { + auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); + ast = funcobj.func_body; + env = callenv; + continue; // TCO + } + else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) + { + return builtinfuncobj.fn(rest); + } + else + { + throw new Exception("Expected a function"); + } + } + } +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +MalType re(string str, Env env) +{ + return EVAL(READ(str), env); +} + +string rep(string str, Env env) +{ + return PRINT(re(str, env)); +} + +static MalList create_argv_list(string[] args) +{ + if (args.length <= 2) return new MalList([]); + return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); +} + +void main(string[] args) +{ + Env repl_env = new Env(null); + foreach (string sym_name, BuiltinStaticFuncType f; core_ns) + { + repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); + } + + BuiltinFuncType eval_func = (a ...) { + verify_args_count(a, 1); + return EVAL(a[0], repl_env); + }; + repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); + repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); + + // core.mal: defined using the language itself + re("(def! not (fn* (a) (if a false true)))", repl_env); + re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + + if (args.length > 1) + { + try + { + rep("(load-file \"" ~ args[1] ~ "\")", repl_env); + return; + } + catch (Exception e) + { + writeln("Error: ", e.msg); + exit(1); + } + } + + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line, repl_env)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/step7_quote.d b/impls/d/step7_quote.d index 5b3e13afbe..cea9845fda 100644 --- a/impls/d/step7_quote.d +++ b/impls/d/step7_quote.d @@ -1,254 +1,254 @@ -module main; - -import std.algorithm; -import std.array; -import std.range; -import std.stdio; -import std.string; -import core.stdc.stdlib; -import env; -import mal_core; -import readline; -import reader; -import printer; -import types; - -bool starts_with(MalType ast, MalSymbol sym) -{ - auto lst = cast(MalList) ast; - if (lst is null) return false; - auto lste = lst.elements; - return lste.length > 0 && lste[0] == sym; -} - -MalType quasiquote(MalType ast) -{ - if (cast(MalSymbol)ast || cast(MalHashmap)ast) - return new MalList([sym_quote, ast]); - - auto ast_seq = cast(MalSequential) ast; - if (ast_seq is null) - return ast; - - auto aste = ast_seq.elements; - if (starts_with(ast, sym_unquote)) - return aste[1]; - - MalType res = new MalList([]);; - foreach_reverse (elt; ast_seq.elements) - if (starts_with(elt, sym_splice_unquote)) - res = new MalList([new MalSymbol("concat"), (cast(MalList) elt).elements[1], res]); - else - res = new MalList([new MalSymbol("cons"), quasiquote(elt), res]); - if (cast(MalVector) ast) - res = new MalList([new MalSymbol("vec"), res]); - return res; -} - -MalType READ(string str) -{ - return read_str(str); -} - -MalType eval_ast(MalType ast, Env env) -{ - if (auto sym = cast(MalSymbol)ast) - { - return env.get(sym); - } - else if (auto lst = cast(MalList)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalList(el); - } - else if (auto lst = cast(MalVector)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalVector(el); - } - else if (auto hm = cast(MalHashmap)ast) - { - typeof(hm.data) new_data; - foreach (string k, MalType v; hm.data) - { - new_data[k] = EVAL(v, env); - } - return new MalHashmap(new_data); - } - else - { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) -{ - for (;;) - { - MalList ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - auto aste = ast_list.elements; - if (aste.length == 0) - { - return ast; - } - auto a0_sym = cast(MalSymbol) aste[0]; - auto sym_name = a0_sym is null ? "" : a0_sym.name; - switch (sym_name) - { - case "def!": - auto a1 = verify_cast!MalSymbol(aste[1]); - return env.set(a1, EVAL(aste[2], env)); - - case "let*": - auto a1 = verify_cast!MalSequential(aste[1]); - auto let_env = new Env(env); - foreach (kv; chunks(a1.elements, 2)) - { - if (kv.length < 2) throw new Exception("let* requires even number of elements"); - auto var_name = verify_cast!MalSymbol(kv[0]); - let_env.set(var_name, EVAL(kv[1], let_env)); - } - ast = aste[2]; - env = let_env; - continue; // TCO - - case "quote": - return aste[1]; - - case "quasiquoteexpand": - return quasiquote(aste[1]); - - case "quasiquote": - ast = quasiquote(aste[1]); - continue; // TCO - - case "do": - auto all_but_last = new MalList(aste[1..$-1]); - eval_ast(all_but_last, env); - ast = aste[$-1]; - continue; // TCO - - case "if": - auto cond = EVAL(aste[1], env); - if (cond.is_truthy()) - { - ast = aste[2]; - continue; // TCO - } - else - if (aste.length > 3) - { - ast = aste[3]; - continue; // TCO - } - else - { - return mal_nil; - } - - case "fn*": - auto args_list = verify_cast!MalSequential(aste[1]); - return new MalFunc(args_list.elements, aste[2], env); - - default: - auto el = verify_cast!MalList(eval_ast(ast, env)); - if (el.elements.length == 0) - { - throw new Exception("Expected a non-empty list"); - } - auto first = el.elements[0]; - auto rest = el.elements[1..$]; - if (auto funcobj = cast(MalFunc)first) - { - auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); - ast = funcobj.func_body; - env = callenv; - continue; // TCO - } - else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) - { - return builtinfuncobj.fn(rest); - } - else - { - throw new Exception("Expected a function"); - } - } - } -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -MalType re(string str, Env env) -{ - return EVAL(READ(str), env); -} - -string rep(string str, Env env) -{ - return PRINT(re(str, env)); -} - -static MalList create_argv_list(string[] args) -{ - if (args.length <= 2) return new MalList([]); - return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); -} - -void main(string[] args) -{ - Env repl_env = new Env(null); - foreach (string sym_name, BuiltinStaticFuncType f; core_ns) - { - repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); - } - - BuiltinFuncType eval_func = (a ...) { - verify_args_count(a, 1); - return EVAL(a[0], repl_env); - }; - repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); - repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); - - // core.mal: defined using the language itself - re("(def! not (fn* (a) (if a false true)))", repl_env); - re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - - if (args.length > 1) - { - try - { - rep("(load-file \"" ~ args[1] ~ "\")", repl_env); - return; - } - catch (Exception e) - { - writeln("Error: ", e.msg); - exit(1); - } - } - - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line, repl_env)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +module main; + +import std.algorithm; +import std.array; +import std.range; +import std.stdio; +import std.string; +import core.stdc.stdlib; +import env; +import mal_core; +import readline; +import reader; +import printer; +import types; + +bool starts_with(MalType ast, MalSymbol sym) +{ + auto lst = cast(MalList) ast; + if (lst is null) return false; + auto lste = lst.elements; + return lste.length > 0 && lste[0] == sym; +} + +MalType quasiquote(MalType ast) +{ + if (cast(MalSymbol)ast || cast(MalHashmap)ast) + return new MalList([sym_quote, ast]); + + auto ast_seq = cast(MalSequential) ast; + if (ast_seq is null) + return ast; + + auto aste = ast_seq.elements; + if (starts_with(ast, sym_unquote)) + return aste[1]; + + MalType res = new MalList([]);; + foreach_reverse (elt; ast_seq.elements) + if (starts_with(elt, sym_splice_unquote)) + res = new MalList([new MalSymbol("concat"), (cast(MalList) elt).elements[1], res]); + else + res = new MalList([new MalSymbol("cons"), quasiquote(elt), res]); + if (cast(MalVector) ast) + res = new MalList([new MalSymbol("vec"), res]); + return res; +} + +MalType READ(string str) +{ + return read_str(str); +} + +MalType eval_ast(MalType ast, Env env) +{ + if (auto sym = cast(MalSymbol)ast) + { + return env.get(sym); + } + else if (auto lst = cast(MalList)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalList(el); + } + else if (auto lst = cast(MalVector)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalVector(el); + } + else if (auto hm = cast(MalHashmap)ast) + { + typeof(hm.data) new_data; + foreach (string k, MalType v; hm.data) + { + new_data[k] = EVAL(v, env); + } + return new MalHashmap(new_data); + } + else + { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) +{ + for (;;) + { + MalList ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + auto aste = ast_list.elements; + if (aste.length == 0) + { + return ast; + } + auto a0_sym = cast(MalSymbol) aste[0]; + auto sym_name = a0_sym is null ? "" : a0_sym.name; + switch (sym_name) + { + case "def!": + auto a1 = verify_cast!MalSymbol(aste[1]); + return env.set(a1, EVAL(aste[2], env)); + + case "let*": + auto a1 = verify_cast!MalSequential(aste[1]); + auto let_env = new Env(env); + foreach (kv; chunks(a1.elements, 2)) + { + if (kv.length < 2) throw new Exception("let* requires even number of elements"); + auto var_name = verify_cast!MalSymbol(kv[0]); + let_env.set(var_name, EVAL(kv[1], let_env)); + } + ast = aste[2]; + env = let_env; + continue; // TCO + + case "quote": + return aste[1]; + + case "quasiquoteexpand": + return quasiquote(aste[1]); + + case "quasiquote": + ast = quasiquote(aste[1]); + continue; // TCO + + case "do": + auto all_but_last = new MalList(aste[1..$-1]); + eval_ast(all_but_last, env); + ast = aste[$-1]; + continue; // TCO + + case "if": + auto cond = EVAL(aste[1], env); + if (cond.is_truthy()) + { + ast = aste[2]; + continue; // TCO + } + else + if (aste.length > 3) + { + ast = aste[3]; + continue; // TCO + } + else + { + return mal_nil; + } + + case "fn*": + auto args_list = verify_cast!MalSequential(aste[1]); + return new MalFunc(args_list.elements, aste[2], env); + + default: + auto el = verify_cast!MalList(eval_ast(ast, env)); + if (el.elements.length == 0) + { + throw new Exception("Expected a non-empty list"); + } + auto first = el.elements[0]; + auto rest = el.elements[1..$]; + if (auto funcobj = cast(MalFunc)first) + { + auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); + ast = funcobj.func_body; + env = callenv; + continue; // TCO + } + else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) + { + return builtinfuncobj.fn(rest); + } + else + { + throw new Exception("Expected a function"); + } + } + } +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +MalType re(string str, Env env) +{ + return EVAL(READ(str), env); +} + +string rep(string str, Env env) +{ + return PRINT(re(str, env)); +} + +static MalList create_argv_list(string[] args) +{ + if (args.length <= 2) return new MalList([]); + return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); +} + +void main(string[] args) +{ + Env repl_env = new Env(null); + foreach (string sym_name, BuiltinStaticFuncType f; core_ns) + { + repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); + } + + BuiltinFuncType eval_func = (a ...) { + verify_args_count(a, 1); + return EVAL(a[0], repl_env); + }; + repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); + repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); + + // core.mal: defined using the language itself + re("(def! not (fn* (a) (if a false true)))", repl_env); + re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + + if (args.length > 1) + { + try + { + rep("(load-file \"" ~ args[1] ~ "\")", repl_env); + return; + } + catch (Exception e) + { + writeln("Error: ", e.msg); + exit(1); + } + } + + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line, repl_env)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/step8_macros.d b/impls/d/step8_macros.d index a186e79579..8b14c52028 100644 --- a/impls/d/step8_macros.d +++ b/impls/d/step8_macros.d @@ -1,300 +1,300 @@ -module main; - -import std.algorithm; -import std.array; -import std.range; -import std.stdio; -import std.string; -import core.stdc.stdlib; -import env; -import mal_core; -import readline; -import reader; -import printer; -import types; - -bool starts_with(MalType ast, MalSymbol sym) -{ - auto lst = cast(MalList) ast; - if (lst is null) return false; - auto lste = lst.elements; - return lste.length > 0 && lste[0] == sym; -} - -MalType quasiquote(MalType ast) -{ - if (cast(MalSymbol)ast || cast(MalHashmap)ast) - return new MalList([sym_quote, ast]); - - auto ast_seq = cast(MalSequential) ast; - if (ast_seq is null) - return ast; - - auto aste = ast_seq.elements; - if (starts_with(ast, sym_unquote)) - return aste[1]; - - MalType res = new MalList([]);; - foreach_reverse (elt; ast_seq.elements) - if (starts_with(elt, sym_splice_unquote)) - res = new MalList([new MalSymbol("concat"), (cast(MalList) elt).elements[1], res]); - else - res = new MalList([new MalSymbol("cons"), quasiquote(elt), res]); - if (cast(MalVector) ast) - res = new MalList([new MalSymbol("vec"), res]); - return res; -} - -bool is_macro_call(MalType ast, Env env) -{ - auto lst = cast(MalList) ast; - if (lst is null) return false; - if (lst.elements.length == 0) return false; - auto sym0 = cast(MalSymbol) lst.elements[0]; - if (sym0 is null) return false; - if (env.find(sym0) is null) return false; - auto val = env.get(sym0); - auto val_func = cast(MalFunc) val; - if (val_func is null) return false; - return val_func.is_macro; -} - -MalType macroexpand(MalType ast, Env env) -{ - while (is_macro_call(ast, env)) - { - auto ast_list = verify_cast!MalList(ast); - auto sym0 = verify_cast!MalSymbol(ast_list.elements[0]); - auto macrofunc = verify_cast!MalFunc(env.get(sym0)); - auto rest = ast_list.elements[1..$]; - auto callenv = new Env(macrofunc.def_env, macrofunc.arg_names, rest); - ast = EVAL(macrofunc.func_body, callenv); - } - return ast; -} - -MalType READ(string str) -{ - return read_str(str); -} - -MalType eval_ast(MalType ast, Env env) -{ - if (auto sym = cast(MalSymbol)ast) - { - return env.get(sym); - } - else if (auto lst = cast(MalList)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalList(el); - } - else if (auto lst = cast(MalVector)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalVector(el); - } - else if (auto hm = cast(MalHashmap)ast) - { - typeof(hm.data) new_data; - foreach (string k, MalType v; hm.data) - { - new_data[k] = EVAL(v, env); - } - return new MalHashmap(new_data); - } - else - { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) -{ - for (;;) - { - MalList ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - ast = macroexpand(ast, env); - ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - auto aste = ast_list.elements; - if (aste.length == 0) - { - return ast; - } - auto a0_sym = cast(MalSymbol) aste[0]; - auto sym_name = a0_sym is null ? "" : a0_sym.name; - switch (sym_name) - { - case "def!": - auto a1 = verify_cast!MalSymbol(aste[1]); - return env.set(a1, EVAL(aste[2], env)); - - case "let*": - auto a1 = verify_cast!MalSequential(aste[1]); - auto let_env = new Env(env); - foreach (kv; chunks(a1.elements, 2)) - { - if (kv.length < 2) throw new Exception("let* requires even number of elements"); - auto var_name = verify_cast!MalSymbol(kv[0]); - let_env.set(var_name, EVAL(kv[1], let_env)); - } - ast = aste[2]; - env = let_env; - continue; // TCO - - case "quote": - return aste[1]; - - case "quasiquoteexpand": - return quasiquote(aste[1]); - - case "quasiquote": - ast = quasiquote(aste[1]); - continue; // TCO - - case "defmacro!": - auto a1 = verify_cast!MalSymbol(aste[1]); - auto mac = verify_cast!MalFunc(EVAL(aste[2], env)); - mac = new MalFunc(mac.arg_names, mac.func_body, mac.def_env); - mac.is_macro = true; - return env.set(a1, mac); - - case "macroexpand": - return macroexpand(aste[1], env); - - case "do": - auto all_but_last = new MalList(aste[1..$-1]); - eval_ast(all_but_last, env); - ast = aste[$-1]; - continue; // TCO - - case "if": - auto cond = EVAL(aste[1], env); - if (cond.is_truthy()) - { - ast = aste[2]; - continue; // TCO - } - else - if (aste.length > 3) - { - ast = aste[3]; - continue; // TCO - } - else - { - return mal_nil; - } - - case "fn*": - auto args_list = verify_cast!MalSequential(aste[1]); - return new MalFunc(args_list.elements, aste[2], env); - - default: - auto el = verify_cast!MalList(eval_ast(ast, env)); - if (el.elements.length == 0) - { - throw new Exception("Expected a non-empty list"); - } - auto first = el.elements[0]; - auto rest = el.elements[1..$]; - if (auto funcobj = cast(MalFunc)first) - { - auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); - ast = funcobj.func_body; - env = callenv; - continue; // TCO - } - else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) - { - return builtinfuncobj.fn(rest); - } - else - { - throw new Exception("Expected a function"); - } - } - } -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -MalType re(string str, Env env) -{ - return EVAL(READ(str), env); -} - -string rep(string str, Env env) -{ - return PRINT(re(str, env)); -} - -static MalList create_argv_list(string[] args) -{ - if (args.length <= 2) return new MalList([]); - return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); -} - -void main(string[] args) -{ - Env repl_env = new Env(null); - foreach (string sym_name, BuiltinStaticFuncType f; core_ns) - { - repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); - } - - BuiltinFuncType eval_func = (a ...) { - verify_args_count(a, 1); - return EVAL(a[0], repl_env); - }; - repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); - repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); - - // core.mal: defined using the language itself - re("(def! not (fn* (a) (if a false true)))", repl_env); - re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - re("(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)))))))", repl_env); - - if (args.length > 1) - { - try - { - rep("(load-file \"" ~ args[1] ~ "\")", repl_env); - return; - } - catch (Exception e) - { - writeln("Error: ", e.msg); - exit(1); - } - } - - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line, repl_env)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +module main; + +import std.algorithm; +import std.array; +import std.range; +import std.stdio; +import std.string; +import core.stdc.stdlib; +import env; +import mal_core; +import readline; +import reader; +import printer; +import types; + +bool starts_with(MalType ast, MalSymbol sym) +{ + auto lst = cast(MalList) ast; + if (lst is null) return false; + auto lste = lst.elements; + return lste.length > 0 && lste[0] == sym; +} + +MalType quasiquote(MalType ast) +{ + if (cast(MalSymbol)ast || cast(MalHashmap)ast) + return new MalList([sym_quote, ast]); + + auto ast_seq = cast(MalSequential) ast; + if (ast_seq is null) + return ast; + + auto aste = ast_seq.elements; + if (starts_with(ast, sym_unquote)) + return aste[1]; + + MalType res = new MalList([]);; + foreach_reverse (elt; ast_seq.elements) + if (starts_with(elt, sym_splice_unquote)) + res = new MalList([new MalSymbol("concat"), (cast(MalList) elt).elements[1], res]); + else + res = new MalList([new MalSymbol("cons"), quasiquote(elt), res]); + if (cast(MalVector) ast) + res = new MalList([new MalSymbol("vec"), res]); + return res; +} + +bool is_macro_call(MalType ast, Env env) +{ + auto lst = cast(MalList) ast; + if (lst is null) return false; + if (lst.elements.length == 0) return false; + auto sym0 = cast(MalSymbol) lst.elements[0]; + if (sym0 is null) return false; + if (env.find(sym0) is null) return false; + auto val = env.get(sym0); + auto val_func = cast(MalFunc) val; + if (val_func is null) return false; + return val_func.is_macro; +} + +MalType macroexpand(MalType ast, Env env) +{ + while (is_macro_call(ast, env)) + { + auto ast_list = verify_cast!MalList(ast); + auto sym0 = verify_cast!MalSymbol(ast_list.elements[0]); + auto macrofunc = verify_cast!MalFunc(env.get(sym0)); + auto rest = ast_list.elements[1..$]; + auto callenv = new Env(macrofunc.def_env, macrofunc.arg_names, rest); + ast = EVAL(macrofunc.func_body, callenv); + } + return ast; +} + +MalType READ(string str) +{ + return read_str(str); +} + +MalType eval_ast(MalType ast, Env env) +{ + if (auto sym = cast(MalSymbol)ast) + { + return env.get(sym); + } + else if (auto lst = cast(MalList)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalList(el); + } + else if (auto lst = cast(MalVector)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalVector(el); + } + else if (auto hm = cast(MalHashmap)ast) + { + typeof(hm.data) new_data; + foreach (string k, MalType v; hm.data) + { + new_data[k] = EVAL(v, env); + } + return new MalHashmap(new_data); + } + else + { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) +{ + for (;;) + { + MalList ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + ast = macroexpand(ast, env); + ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + auto aste = ast_list.elements; + if (aste.length == 0) + { + return ast; + } + auto a0_sym = cast(MalSymbol) aste[0]; + auto sym_name = a0_sym is null ? "" : a0_sym.name; + switch (sym_name) + { + case "def!": + auto a1 = verify_cast!MalSymbol(aste[1]); + return env.set(a1, EVAL(aste[2], env)); + + case "let*": + auto a1 = verify_cast!MalSequential(aste[1]); + auto let_env = new Env(env); + foreach (kv; chunks(a1.elements, 2)) + { + if (kv.length < 2) throw new Exception("let* requires even number of elements"); + auto var_name = verify_cast!MalSymbol(kv[0]); + let_env.set(var_name, EVAL(kv[1], let_env)); + } + ast = aste[2]; + env = let_env; + continue; // TCO + + case "quote": + return aste[1]; + + case "quasiquoteexpand": + return quasiquote(aste[1]); + + case "quasiquote": + ast = quasiquote(aste[1]); + continue; // TCO + + case "defmacro!": + auto a1 = verify_cast!MalSymbol(aste[1]); + auto mac = verify_cast!MalFunc(EVAL(aste[2], env)); + mac = new MalFunc(mac.arg_names, mac.func_body, mac.def_env); + mac.is_macro = true; + return env.set(a1, mac); + + case "macroexpand": + return macroexpand(aste[1], env); + + case "do": + auto all_but_last = new MalList(aste[1..$-1]); + eval_ast(all_but_last, env); + ast = aste[$-1]; + continue; // TCO + + case "if": + auto cond = EVAL(aste[1], env); + if (cond.is_truthy()) + { + ast = aste[2]; + continue; // TCO + } + else + if (aste.length > 3) + { + ast = aste[3]; + continue; // TCO + } + else + { + return mal_nil; + } + + case "fn*": + auto args_list = verify_cast!MalSequential(aste[1]); + return new MalFunc(args_list.elements, aste[2], env); + + default: + auto el = verify_cast!MalList(eval_ast(ast, env)); + if (el.elements.length == 0) + { + throw new Exception("Expected a non-empty list"); + } + auto first = el.elements[0]; + auto rest = el.elements[1..$]; + if (auto funcobj = cast(MalFunc)first) + { + auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); + ast = funcobj.func_body; + env = callenv; + continue; // TCO + } + else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) + { + return builtinfuncobj.fn(rest); + } + else + { + throw new Exception("Expected a function"); + } + } + } +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +MalType re(string str, Env env) +{ + return EVAL(READ(str), env); +} + +string rep(string str, Env env) +{ + return PRINT(re(str, env)); +} + +static MalList create_argv_list(string[] args) +{ + if (args.length <= 2) return new MalList([]); + return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); +} + +void main(string[] args) +{ + Env repl_env = new Env(null); + foreach (string sym_name, BuiltinStaticFuncType f; core_ns) + { + repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); + } + + BuiltinFuncType eval_func = (a ...) { + verify_args_count(a, 1); + return EVAL(a[0], repl_env); + }; + repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); + repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); + + // core.mal: defined using the language itself + re("(def! not (fn* (a) (if a false true)))", repl_env); + re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + re("(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)))))))", repl_env); + + if (args.length > 1) + { + try + { + rep("(load-file \"" ~ args[1] ~ "\")", repl_env); + return; + } + catch (Exception e) + { + writeln("Error: ", e.msg); + exit(1); + } + } + + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line, repl_env)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/step9_try.d b/impls/d/step9_try.d index 77da44b405..90b98005a4 100644 --- a/impls/d/step9_try.d +++ b/impls/d/step9_try.d @@ -1,333 +1,333 @@ -module main; - -import std.algorithm; -import std.array; -import std.range; -import std.stdio; -import std.string; -import core.stdc.stdlib; -import env; -import mal_core; -import readline; -import reader; -import printer; -import types; - -bool starts_with(MalType ast, MalSymbol sym) -{ - auto lst = cast(MalList) ast; - if (lst is null) return false; - auto lste = lst.elements; - return lste.length > 0 && lste[0] == sym; -} - -MalType quasiquote(MalType ast) -{ - if (cast(MalSymbol)ast || cast(MalHashmap)ast) - return new MalList([sym_quote, ast]); - - auto ast_seq = cast(MalSequential) ast; - if (ast_seq is null) - return ast; - - auto aste = ast_seq.elements; - if (starts_with(ast, sym_unquote)) - return aste[1]; - - MalType res = new MalList([]);; - foreach_reverse (elt; ast_seq.elements) - if (starts_with(elt, sym_splice_unquote)) - res = new MalList([new MalSymbol("concat"), (cast(MalList) elt).elements[1], res]); - else - res = new MalList([new MalSymbol("cons"), quasiquote(elt), res]); - if (cast(MalVector) ast) - res = new MalList([new MalSymbol("vec"), res]); - return res; -} - -bool is_macro_call(MalType ast, Env env) -{ - auto lst = cast(MalList) ast; - if (lst is null) return false; - if (lst.elements.length == 0) return false; - auto sym0 = cast(MalSymbol) lst.elements[0]; - if (sym0 is null) return false; - if (env.find(sym0) is null) return false; - auto val = env.get(sym0); - auto val_func = cast(MalFunc) val; - if (val_func is null) return false; - return val_func.is_macro; -} - -MalType macroexpand(MalType ast, Env env) -{ - while (is_macro_call(ast, env)) - { - auto ast_list = verify_cast!MalList(ast); - auto sym0 = verify_cast!MalSymbol(ast_list.elements[0]); - auto macrofunc = verify_cast!MalFunc(env.get(sym0)); - auto rest = ast_list.elements[1..$]; - auto callenv = new Env(macrofunc.def_env, macrofunc.arg_names, rest); - ast = EVAL(macrofunc.func_body, callenv); - } - return ast; -} - -MalType READ(string str) -{ - return read_str(str); -} - -MalType eval_ast(MalType ast, Env env) -{ - if (auto sym = cast(MalSymbol)ast) - { - return env.get(sym); - } - else if (auto lst = cast(MalList)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalList(el); - } - else if (auto lst = cast(MalVector)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalVector(el); - } - else if (auto hm = cast(MalHashmap)ast) - { - typeof(hm.data) new_data; - foreach (string k, MalType v; hm.data) - { - new_data[k] = EVAL(v, env); - } - return new MalHashmap(new_data); - } - else - { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) -{ - for (;;) - { - MalList ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - ast = macroexpand(ast, env); - ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - auto aste = ast_list.elements; - if (aste.length == 0) - { - return ast; - } - auto a0_sym = cast(MalSymbol) aste[0]; - auto sym_name = a0_sym is null ? "" : a0_sym.name; - switch (sym_name) - { - case "def!": - auto a1 = verify_cast!MalSymbol(aste[1]); - return env.set(a1, EVAL(aste[2], env)); - - case "let*": - auto a1 = verify_cast!MalSequential(aste[1]); - auto let_env = new Env(env); - foreach (kv; chunks(a1.elements, 2)) - { - if (kv.length < 2) throw new Exception("let* requires even number of elements"); - auto var_name = verify_cast!MalSymbol(kv[0]); - let_env.set(var_name, EVAL(kv[1], let_env)); - } - ast = aste[2]; - env = let_env; - continue; // TCO - - case "quote": - return aste[1]; - - case "quasiquoteexpand": - return quasiquote(aste[1]); - - case "quasiquote": - ast = quasiquote(aste[1]); - continue; // TCO - - case "defmacro!": - auto a1 = verify_cast!MalSymbol(aste[1]); - auto mac = verify_cast!MalFunc(EVAL(aste[2], env)); - mac = new MalFunc(mac.arg_names, mac.func_body, mac.def_env); - mac.is_macro = true; - return env.set(a1, mac); - - case "macroexpand": - return macroexpand(aste[1], env); - - case "try*": - if (aste.length < 2) return mal_nil; - if (aste.length < 3) - { - ast = aste[1]; - continue; // TCO - } - MalType exc; - try - { - // d seems to do erroneous tco all by itself without this - // little distraction - pr_str(aste[1]); - return EVAL(aste[1], env); - } - catch (MalException e) - { - exc = e.data; - } - catch (Exception e) - { - exc = new MalString(e.msg); - } - auto catch_clause = verify_cast!MalList(aste[2]); - auto catch_env = new Env(env, [catch_clause.elements[1]], [exc]); - ast = catch_clause.elements[2]; - env = catch_env; - continue; // TCO - - case "do": - auto all_but_last = new MalList(aste[1..$-1]); - eval_ast(all_but_last, env); - ast = aste[$-1]; - continue; // TCO - - case "if": - auto cond = EVAL(aste[1], env); - if (cond.is_truthy()) - { - ast = aste[2]; - continue; // TCO - } - else - if (aste.length > 3) - { - ast = aste[3]; - continue; // TCO - } - else - { - return mal_nil; - } - - case "fn*": - auto args_list = verify_cast!MalSequential(aste[1]); - return new MalFunc(args_list.elements, aste[2], env); - - default: - auto el = verify_cast!MalList(eval_ast(ast, env)); - if (el.elements.length == 0) - { - throw new Exception("Expected a non-empty list"); - } - auto first = el.elements[0]; - auto rest = el.elements[1..$]; - if (auto funcobj = cast(MalFunc)first) - { - auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); - ast = funcobj.func_body; - env = callenv; - continue; // TCO - } - else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) - { - return builtinfuncobj.fn(rest); - } - else - { - throw new Exception("Expected a function"); - } - } - } -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -MalType re(string str, Env env) -{ - return EVAL(READ(str), env); -} - -string rep(string str, Env env) -{ - return PRINT(re(str, env)); -} - -static MalList create_argv_list(string[] args) -{ - if (args.length <= 2) return new MalList([]); - return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); -} - -void main(string[] args) -{ - Env repl_env = new Env(null); - foreach (string sym_name, BuiltinStaticFuncType f; core_ns) - { - repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); - } - - BuiltinFuncType eval_func = (a ...) { - verify_args_count(a, 1); - return EVAL(a[0], repl_env); - }; - repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); - repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); - - // core.mal: defined using the language itself - re("(def! not (fn* (a) (if a false true)))", repl_env); - re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - re("(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)))))))", repl_env); - - if (args.length > 1) - { - try - { - rep("(load-file \"" ~ args[1] ~ "\")", repl_env); - return; - } - catch (Exception e) - { - writeln("Error: ", e.msg); - exit(1); - } - } - - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line, repl_env)); - } - catch (MalException e) - { - writeln("Error: ", pr_str(e.data)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +module main; + +import std.algorithm; +import std.array; +import std.range; +import std.stdio; +import std.string; +import core.stdc.stdlib; +import env; +import mal_core; +import readline; +import reader; +import printer; +import types; + +bool starts_with(MalType ast, MalSymbol sym) +{ + auto lst = cast(MalList) ast; + if (lst is null) return false; + auto lste = lst.elements; + return lste.length > 0 && lste[0] == sym; +} + +MalType quasiquote(MalType ast) +{ + if (cast(MalSymbol)ast || cast(MalHashmap)ast) + return new MalList([sym_quote, ast]); + + auto ast_seq = cast(MalSequential) ast; + if (ast_seq is null) + return ast; + + auto aste = ast_seq.elements; + if (starts_with(ast, sym_unquote)) + return aste[1]; + + MalType res = new MalList([]);; + foreach_reverse (elt; ast_seq.elements) + if (starts_with(elt, sym_splice_unquote)) + res = new MalList([new MalSymbol("concat"), (cast(MalList) elt).elements[1], res]); + else + res = new MalList([new MalSymbol("cons"), quasiquote(elt), res]); + if (cast(MalVector) ast) + res = new MalList([new MalSymbol("vec"), res]); + return res; +} + +bool is_macro_call(MalType ast, Env env) +{ + auto lst = cast(MalList) ast; + if (lst is null) return false; + if (lst.elements.length == 0) return false; + auto sym0 = cast(MalSymbol) lst.elements[0]; + if (sym0 is null) return false; + if (env.find(sym0) is null) return false; + auto val = env.get(sym0); + auto val_func = cast(MalFunc) val; + if (val_func is null) return false; + return val_func.is_macro; +} + +MalType macroexpand(MalType ast, Env env) +{ + while (is_macro_call(ast, env)) + { + auto ast_list = verify_cast!MalList(ast); + auto sym0 = verify_cast!MalSymbol(ast_list.elements[0]); + auto macrofunc = verify_cast!MalFunc(env.get(sym0)); + auto rest = ast_list.elements[1..$]; + auto callenv = new Env(macrofunc.def_env, macrofunc.arg_names, rest); + ast = EVAL(macrofunc.func_body, callenv); + } + return ast; +} + +MalType READ(string str) +{ + return read_str(str); +} + +MalType eval_ast(MalType ast, Env env) +{ + if (auto sym = cast(MalSymbol)ast) + { + return env.get(sym); + } + else if (auto lst = cast(MalList)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalList(el); + } + else if (auto lst = cast(MalVector)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalVector(el); + } + else if (auto hm = cast(MalHashmap)ast) + { + typeof(hm.data) new_data; + foreach (string k, MalType v; hm.data) + { + new_data[k] = EVAL(v, env); + } + return new MalHashmap(new_data); + } + else + { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) +{ + for (;;) + { + MalList ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + ast = macroexpand(ast, env); + ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + auto aste = ast_list.elements; + if (aste.length == 0) + { + return ast; + } + auto a0_sym = cast(MalSymbol) aste[0]; + auto sym_name = a0_sym is null ? "" : a0_sym.name; + switch (sym_name) + { + case "def!": + auto a1 = verify_cast!MalSymbol(aste[1]); + return env.set(a1, EVAL(aste[2], env)); + + case "let*": + auto a1 = verify_cast!MalSequential(aste[1]); + auto let_env = new Env(env); + foreach (kv; chunks(a1.elements, 2)) + { + if (kv.length < 2) throw new Exception("let* requires even number of elements"); + auto var_name = verify_cast!MalSymbol(kv[0]); + let_env.set(var_name, EVAL(kv[1], let_env)); + } + ast = aste[2]; + env = let_env; + continue; // TCO + + case "quote": + return aste[1]; + + case "quasiquoteexpand": + return quasiquote(aste[1]); + + case "quasiquote": + ast = quasiquote(aste[1]); + continue; // TCO + + case "defmacro!": + auto a1 = verify_cast!MalSymbol(aste[1]); + auto mac = verify_cast!MalFunc(EVAL(aste[2], env)); + mac = new MalFunc(mac.arg_names, mac.func_body, mac.def_env); + mac.is_macro = true; + return env.set(a1, mac); + + case "macroexpand": + return macroexpand(aste[1], env); + + case "try*": + if (aste.length < 2) return mal_nil; + if (aste.length < 3) + { + ast = aste[1]; + continue; // TCO + } + MalType exc; + try + { + // d seems to do erroneous tco all by itself without this + // little distraction + pr_str(aste[1]); + return EVAL(aste[1], env); + } + catch (MalException e) + { + exc = e.data; + } + catch (Exception e) + { + exc = new MalString(e.msg); + } + auto catch_clause = verify_cast!MalList(aste[2]); + auto catch_env = new Env(env, [catch_clause.elements[1]], [exc]); + ast = catch_clause.elements[2]; + env = catch_env; + continue; // TCO + + case "do": + auto all_but_last = new MalList(aste[1..$-1]); + eval_ast(all_but_last, env); + ast = aste[$-1]; + continue; // TCO + + case "if": + auto cond = EVAL(aste[1], env); + if (cond.is_truthy()) + { + ast = aste[2]; + continue; // TCO + } + else + if (aste.length > 3) + { + ast = aste[3]; + continue; // TCO + } + else + { + return mal_nil; + } + + case "fn*": + auto args_list = verify_cast!MalSequential(aste[1]); + return new MalFunc(args_list.elements, aste[2], env); + + default: + auto el = verify_cast!MalList(eval_ast(ast, env)); + if (el.elements.length == 0) + { + throw new Exception("Expected a non-empty list"); + } + auto first = el.elements[0]; + auto rest = el.elements[1..$]; + if (auto funcobj = cast(MalFunc)first) + { + auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); + ast = funcobj.func_body; + env = callenv; + continue; // TCO + } + else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) + { + return builtinfuncobj.fn(rest); + } + else + { + throw new Exception("Expected a function"); + } + } + } +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +MalType re(string str, Env env) +{ + return EVAL(READ(str), env); +} + +string rep(string str, Env env) +{ + return PRINT(re(str, env)); +} + +static MalList create_argv_list(string[] args) +{ + if (args.length <= 2) return new MalList([]); + return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); +} + +void main(string[] args) +{ + Env repl_env = new Env(null); + foreach (string sym_name, BuiltinStaticFuncType f; core_ns) + { + repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); + } + + BuiltinFuncType eval_func = (a ...) { + verify_args_count(a, 1); + return EVAL(a[0], repl_env); + }; + repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); + repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); + + // core.mal: defined using the language itself + re("(def! not (fn* (a) (if a false true)))", repl_env); + re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + re("(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)))))))", repl_env); + + if (args.length > 1) + { + try + { + rep("(load-file \"" ~ args[1] ~ "\")", repl_env); + return; + } + catch (Exception e) + { + writeln("Error: ", e.msg); + exit(1); + } + } + + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line, repl_env)); + } + catch (MalException e) + { + writeln("Error: ", pr_str(e.data)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/stepA_mal.d b/impls/d/stepA_mal.d index 1b6e490853..17be6611fb 100644 --- a/impls/d/stepA_mal.d +++ b/impls/d/stepA_mal.d @@ -1,336 +1,336 @@ -module main; - -import std.algorithm; -import std.compiler; -import std.array; -import std.range; -import std.stdio; -import std.string; -import core.stdc.stdlib; -import env; -import mal_core; -import readline; -import reader; -import printer; -import types; - -bool starts_with(MalType ast, MalSymbol sym) -{ - auto lst = cast(MalList) ast; - if (lst is null) return false; - auto lste = lst.elements; - return lste.length > 0 && lste[0] == sym; -} - -MalType quasiquote(MalType ast) -{ - if (cast(MalSymbol)ast || cast(MalHashmap)ast) - return new MalList([sym_quote, ast]); - - auto ast_seq = cast(MalSequential) ast; - if (ast_seq is null) - return ast; - - auto aste = ast_seq.elements; - if (starts_with(ast, sym_unquote)) - return aste[1]; - - MalType res = new MalList([]);; - foreach_reverse (elt; ast_seq.elements) - if (starts_with(elt, sym_splice_unquote)) - res = new MalList([new MalSymbol("concat"), (cast(MalList) elt).elements[1], res]); - else - res = new MalList([new MalSymbol("cons"), quasiquote(elt), res]); - if (cast(MalVector) ast) - res = new MalList([new MalSymbol("vec"), res]); - return res; -} - -bool is_macro_call(MalType ast, Env env) -{ - auto lst = cast(MalList) ast; - if (lst is null) return false; - if (lst.elements.length == 0) return false; - auto sym0 = cast(MalSymbol) lst.elements[0]; - if (sym0 is null) return false; - if (env.find(sym0) is null) return false; - auto val = env.get(sym0); - auto val_func = cast(MalFunc) val; - if (val_func is null) return false; - return val_func.is_macro; -} - -MalType macroexpand(MalType ast, Env env) -{ - while (is_macro_call(ast, env)) - { - auto ast_list = verify_cast!MalList(ast); - auto sym0 = verify_cast!MalSymbol(ast_list.elements[0]); - auto macrofunc = verify_cast!MalFunc(env.get(sym0)); - auto rest = ast_list.elements[1..$]; - auto callenv = new Env(macrofunc.def_env, macrofunc.arg_names, rest); - ast = EVAL(macrofunc.func_body, callenv); - } - return ast; -} - -MalType READ(string str) -{ - return read_str(str); -} - -MalType eval_ast(MalType ast, Env env) -{ - if (auto sym = cast(MalSymbol)ast) - { - return env.get(sym); - } - else if (auto lst = cast(MalList)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalList(el); - } - else if (auto lst = cast(MalVector)ast) - { - auto el = array(lst.elements.map!(e => EVAL(e, env))); - return new MalVector(el); - } - else if (auto hm = cast(MalHashmap)ast) - { - typeof(hm.data) new_data; - foreach (string k, MalType v; hm.data) - { - new_data[k] = EVAL(v, env); - } - return new MalHashmap(new_data); - } - else - { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) -{ - for (;;) - { - MalList ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - ast = macroexpand(ast, env); - ast_list = cast(MalList) ast; - if (ast_list is null) - { - return eval_ast(ast, env); - } - - auto aste = ast_list.elements; - if (aste.length == 0) - { - return ast; - } - auto a0_sym = cast(MalSymbol) aste[0]; - auto sym_name = a0_sym is null ? "" : a0_sym.name; - switch (sym_name) - { - case "def!": - auto a1 = verify_cast!MalSymbol(aste[1]); - return env.set(a1, EVAL(aste[2], env)); - - case "let*": - auto a1 = verify_cast!MalSequential(aste[1]); - auto let_env = new Env(env); - foreach (kv; chunks(a1.elements, 2)) - { - if (kv.length < 2) throw new Exception("let* requires even number of elements"); - auto var_name = verify_cast!MalSymbol(kv[0]); - let_env.set(var_name, EVAL(kv[1], let_env)); - } - ast = aste[2]; - env = let_env; - continue; // TCO - - case "quote": - return aste[1]; - - case "quasiquoteexpand": - return quasiquote(aste[1]); - - case "quasiquote": - ast = quasiquote(aste[1]); - continue; // TCO - - case "defmacro!": - auto a1 = verify_cast!MalSymbol(aste[1]); - auto mac = verify_cast!MalFunc(EVAL(aste[2], env)); - mac = new MalFunc(mac.arg_names, mac.func_body, mac.def_env); - mac.is_macro = true; - return env.set(a1, mac); - - case "macroexpand": - return macroexpand(aste[1], env); - - case "try*": - if (aste.length < 2) return mal_nil; - if (aste.length < 3) - { - ast = aste[1]; - continue; // TCO - } - MalType exc; - try - { - // d seems to do erroneous tco all by itself without this - // little distraction - pr_str(aste[1]); - return EVAL(aste[1], env); - } - catch (MalException e) - { - exc = e.data; - } - catch (Exception e) - { - exc = new MalString(e.msg); - } - auto catch_clause = verify_cast!MalList(aste[2]); - auto catch_env = new Env(env, [catch_clause.elements[1]], [exc]); - ast = catch_clause.elements[2]; - env = catch_env; - continue; // TCO - - case "do": - auto all_but_last = new MalList(aste[1..$-1]); - eval_ast(all_but_last, env); - ast = aste[$-1]; - continue; // TCO - - case "if": - auto cond = EVAL(aste[1], env); - if (cond.is_truthy()) - { - ast = aste[2]; - continue; // TCO - } - else - if (aste.length > 3) - { - ast = aste[3]; - continue; // TCO - } - else - { - return mal_nil; - } - - case "fn*": - auto args_list = verify_cast!MalSequential(aste[1]); - return new MalFunc(args_list.elements, aste[2], env); - - default: - auto el = verify_cast!MalList(eval_ast(ast, env)); - if (el.elements.length == 0) - { - throw new Exception("Expected a non-empty list"); - } - auto first = el.elements[0]; - auto rest = el.elements[1..$]; - if (auto funcobj = cast(MalFunc)first) - { - auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); - ast = funcobj.func_body; - env = callenv; - continue; // TCO - } - else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) - { - return builtinfuncobj.fn(rest); - } - else - { - throw new Exception("Expected a function"); - } - } - } -} - -string PRINT(MalType ast) -{ - return pr_str(ast); -} - -MalType re(string str, Env env) -{ - return EVAL(READ(str), env); -} - -string rep(string str, Env env) -{ - return PRINT(re(str, env)); -} - -static MalList create_argv_list(string[] args) -{ - if (args.length <= 2) return new MalList([]); - return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); -} - -void main(string[] args) -{ - Env repl_env = new Env(null); - foreach (string sym_name, BuiltinStaticFuncType f; core_ns) - { - repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); - } - - BuiltinFuncType eval_func = (a ...) { - verify_args_count(a, 1); - return EVAL(a[0], repl_env); - }; - repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); - repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); - - // core.mal: defined using the language itself - re("(def! *host-language* \"" ~ std.compiler.name ~ "\")", repl_env); - re("(def! not (fn* (a) (if a false true)))", repl_env); - re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - re("(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)))))))", repl_env); - - if (args.length > 1) - { - try - { - rep("(load-file \"" ~ args[1] ~ "\")", repl_env); - return; - } - catch (Exception e) - { - writeln("Error: ", e.msg); - exit(1); - } - } - - re("(println (str \"Mal [\" *host-language* \"]\"))", repl_env); - for (;;) - { - string line = _readline("user> "); - if (line is null) break; - if (line.length == 0) continue; - try - { - writeln(rep(line, repl_env)); - } - catch (MalException e) - { - writeln("Error: ", pr_str(e.data)); - } - catch (Exception e) - { - writeln("Error: ", e.msg); - } - } - writeln(""); -} +module main; + +import std.algorithm; +import std.compiler; +import std.array; +import std.range; +import std.stdio; +import std.string; +import core.stdc.stdlib; +import env; +import mal_core; +import readline; +import reader; +import printer; +import types; + +bool starts_with(MalType ast, MalSymbol sym) +{ + auto lst = cast(MalList) ast; + if (lst is null) return false; + auto lste = lst.elements; + return lste.length > 0 && lste[0] == sym; +} + +MalType quasiquote(MalType ast) +{ + if (cast(MalSymbol)ast || cast(MalHashmap)ast) + return new MalList([sym_quote, ast]); + + auto ast_seq = cast(MalSequential) ast; + if (ast_seq is null) + return ast; + + auto aste = ast_seq.elements; + if (starts_with(ast, sym_unquote)) + return aste[1]; + + MalType res = new MalList([]);; + foreach_reverse (elt; ast_seq.elements) + if (starts_with(elt, sym_splice_unquote)) + res = new MalList([new MalSymbol("concat"), (cast(MalList) elt).elements[1], res]); + else + res = new MalList([new MalSymbol("cons"), quasiquote(elt), res]); + if (cast(MalVector) ast) + res = new MalList([new MalSymbol("vec"), res]); + return res; +} + +bool is_macro_call(MalType ast, Env env) +{ + auto lst = cast(MalList) ast; + if (lst is null) return false; + if (lst.elements.length == 0) return false; + auto sym0 = cast(MalSymbol) lst.elements[0]; + if (sym0 is null) return false; + if (env.find(sym0) is null) return false; + auto val = env.get(sym0); + auto val_func = cast(MalFunc) val; + if (val_func is null) return false; + return val_func.is_macro; +} + +MalType macroexpand(MalType ast, Env env) +{ + while (is_macro_call(ast, env)) + { + auto ast_list = verify_cast!MalList(ast); + auto sym0 = verify_cast!MalSymbol(ast_list.elements[0]); + auto macrofunc = verify_cast!MalFunc(env.get(sym0)); + auto rest = ast_list.elements[1..$]; + auto callenv = new Env(macrofunc.def_env, macrofunc.arg_names, rest); + ast = EVAL(macrofunc.func_body, callenv); + } + return ast; +} + +MalType READ(string str) +{ + return read_str(str); +} + +MalType eval_ast(MalType ast, Env env) +{ + if (auto sym = cast(MalSymbol)ast) + { + return env.get(sym); + } + else if (auto lst = cast(MalList)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalList(el); + } + else if (auto lst = cast(MalVector)ast) + { + auto el = array(lst.elements.map!(e => EVAL(e, env))); + return new MalVector(el); + } + else if (auto hm = cast(MalHashmap)ast) + { + typeof(hm.data) new_data; + foreach (string k, MalType v; hm.data) + { + new_data[k] = EVAL(v, env); + } + return new MalHashmap(new_data); + } + else + { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) +{ + for (;;) + { + MalList ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + ast = macroexpand(ast, env); + ast_list = cast(MalList) ast; + if (ast_list is null) + { + return eval_ast(ast, env); + } + + auto aste = ast_list.elements; + if (aste.length == 0) + { + return ast; + } + auto a0_sym = cast(MalSymbol) aste[0]; + auto sym_name = a0_sym is null ? "" : a0_sym.name; + switch (sym_name) + { + case "def!": + auto a1 = verify_cast!MalSymbol(aste[1]); + return env.set(a1, EVAL(aste[2], env)); + + case "let*": + auto a1 = verify_cast!MalSequential(aste[1]); + auto let_env = new Env(env); + foreach (kv; chunks(a1.elements, 2)) + { + if (kv.length < 2) throw new Exception("let* requires even number of elements"); + auto var_name = verify_cast!MalSymbol(kv[0]); + let_env.set(var_name, EVAL(kv[1], let_env)); + } + ast = aste[2]; + env = let_env; + continue; // TCO + + case "quote": + return aste[1]; + + case "quasiquoteexpand": + return quasiquote(aste[1]); + + case "quasiquote": + ast = quasiquote(aste[1]); + continue; // TCO + + case "defmacro!": + auto a1 = verify_cast!MalSymbol(aste[1]); + auto mac = verify_cast!MalFunc(EVAL(aste[2], env)); + mac = new MalFunc(mac.arg_names, mac.func_body, mac.def_env); + mac.is_macro = true; + return env.set(a1, mac); + + case "macroexpand": + return macroexpand(aste[1], env); + + case "try*": + if (aste.length < 2) return mal_nil; + if (aste.length < 3) + { + ast = aste[1]; + continue; // TCO + } + MalType exc; + try + { + // d seems to do erroneous tco all by itself without this + // little distraction + pr_str(aste[1]); + return EVAL(aste[1], env); + } + catch (MalException e) + { + exc = e.data; + } + catch (Exception e) + { + exc = new MalString(e.msg); + } + auto catch_clause = verify_cast!MalList(aste[2]); + auto catch_env = new Env(env, [catch_clause.elements[1]], [exc]); + ast = catch_clause.elements[2]; + env = catch_env; + continue; // TCO + + case "do": + auto all_but_last = new MalList(aste[1..$-1]); + eval_ast(all_but_last, env); + ast = aste[$-1]; + continue; // TCO + + case "if": + auto cond = EVAL(aste[1], env); + if (cond.is_truthy()) + { + ast = aste[2]; + continue; // TCO + } + else + if (aste.length > 3) + { + ast = aste[3]; + continue; // TCO + } + else + { + return mal_nil; + } + + case "fn*": + auto args_list = verify_cast!MalSequential(aste[1]); + return new MalFunc(args_list.elements, aste[2], env); + + default: + auto el = verify_cast!MalList(eval_ast(ast, env)); + if (el.elements.length == 0) + { + throw new Exception("Expected a non-empty list"); + } + auto first = el.elements[0]; + auto rest = el.elements[1..$]; + if (auto funcobj = cast(MalFunc)first) + { + auto callenv = new Env(funcobj.def_env, funcobj.arg_names, rest); + ast = funcobj.func_body; + env = callenv; + continue; // TCO + } + else if (auto builtinfuncobj = cast(MalBuiltinFunc)first) + { + return builtinfuncobj.fn(rest); + } + else + { + throw new Exception("Expected a function"); + } + } + } +} + +string PRINT(MalType ast) +{ + return pr_str(ast); +} + +MalType re(string str, Env env) +{ + return EVAL(READ(str), env); +} + +string rep(string str, Env env) +{ + return PRINT(re(str, env)); +} + +static MalList create_argv_list(string[] args) +{ + if (args.length <= 2) return new MalList([]); + return new MalList(array(args[2..$].map!(s => cast(MalType)(new MalString(s))))); +} + +void main(string[] args) +{ + Env repl_env = new Env(null); + foreach (string sym_name, BuiltinStaticFuncType f; core_ns) + { + repl_env.set(new MalSymbol(sym_name), new MalBuiltinFunc(f, sym_name)); + } + + BuiltinFuncType eval_func = (a ...) { + verify_args_count(a, 1); + return EVAL(a[0], repl_env); + }; + repl_env.set(new MalSymbol("eval"), new MalBuiltinFunc(eval_func, "eval")); + repl_env.set(new MalSymbol("*ARGV*"), create_argv_list(args)); + + // core.mal: defined using the language itself + re("(def! *host-language* \"" ~ std.compiler.name ~ "\")", repl_env); + re("(def! not (fn* (a) (if a false true)))", repl_env); + re("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + re("(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)))))))", repl_env); + + if (args.length > 1) + { + try + { + rep("(load-file \"" ~ args[1] ~ "\")", repl_env); + return; + } + catch (Exception e) + { + writeln("Error: ", e.msg); + exit(1); + } + } + + re("(println (str \"Mal [\" *host-language* \"]\"))", repl_env); + for (;;) + { + string line = _readline("user> "); + if (line is null) break; + if (line.length == 0) continue; + try + { + writeln(rep(line, repl_env)); + } + catch (MalException e) + { + writeln("Error: ", pr_str(e.data)); + } + catch (Exception e) + { + writeln("Error: ", e.msg); + } + } + writeln(""); +} diff --git a/impls/d/tests/step5_tco.mal b/impls/d/tests/step5_tco.mal index de8bbcb6b9..20dd743524 100644 --- a/impls/d/tests/step5_tco.mal +++ b/impls/d/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; D: skipping non-TCO recursion -;; Reason: completes at 10,000, segfaults at 40,000 +;; D: skipping non-TCO recursion +;; Reason: completes at 10,000, segfaults at 40,000 diff --git a/impls/d/types.d b/impls/d/types.d index b140eb7fe3..586f1ca364 100644 --- a/impls/d/types.d +++ b/impls/d/types.d @@ -1,454 +1,454 @@ -import std.algorithm; -import std.array; -import std.conv; -import std.functional; -import std.range; -import env; - -abstract class MalType -{ - string print(bool readable) const; - bool is_truthy() const { return true; } -} - -interface MalMeta -{ - MalType meta(); - MalType with_meta(MalType new_meta); -} - -interface HasSeq -{ - MalType seq(); -} - -class MalNil : MalType, HasSeq -{ - override string print(bool readable) const { return "nil"; } - override bool is_truthy() const { return false; } - override bool opEquals(Object o) { return (cast(MalNil)(o) !is null); } - override MalType seq() { return this; } -} - -class MalFalse : MalType -{ - override string print(bool readable) const { return "false"; } - override bool is_truthy() const { return false; } - override bool opEquals(Object o) { return (cast(MalFalse)(o) !is null); } -} - -class MalTrue : MalType -{ - override string print(bool readable) const { return "true"; } - override bool opEquals(Object o) { return (cast(MalTrue)(o) !is null); } -} - -MalNil mal_nil; -MalFalse mal_false; -MalTrue mal_true; - -static this() -{ - mal_nil = new MalNil; - mal_false = new MalFalse; - mal_true = new MalTrue; -} - -MalType bool_to_mal(in bool b) -{ - return b ? mal_true : mal_false; -} - -class MalSymbol : MalType -{ - const string name; - this(in string token) { name = token; } - override string print(bool readable) const { return name; } - - override size_t toHash() - { - return typeid(name).getHash(&name); - } - - override int opCmp(Object other) - { - MalSymbol o = cast(MalSymbol) other; - return cmp(name, o.name); - } - - override bool opEquals(Object other) - { - auto o = cast(MalSymbol) other; - return (o !is null && name == o.name); - } -} - -class MalInteger : MalType -{ - const long val; - this(string token) { val = to!long(token); } - this(long v) { val = v; } - override string print(bool readable) const { return to!string(val); } - - override bool opEquals(Object o) - { - auto oint = cast(MalInteger)(o); - return (oint !is null && val == oint.val); - } -} - -class MalString : MalType, HasSeq -{ - const string val; - this(in string token) { val = token; } - override string print(bool readable) const - { - if (is_keyword()) return ":" ~ val[2..$]; - if (readable) - { - string escaped = val.replace("\\", "\\\\") - .replace("\"", "\\\"") - .replace("\n", "\\n"); - return "\"" ~ escaped ~ "\""; - } - else - { - return val; - } - } - - bool is_keyword() const - { - return val.length > 1 && val[0..2] == "\u029e"; - } - - override bool opEquals(Object o) - { - auto ostr = cast(MalString)(o); - return (ostr !is null && val == ostr.val); - } - - override MalType seq() { - if (is_keyword() || val.length == 0) return mal_nil; - auto chars = val.map!(c => cast(MalType)(new MalString(to!string(c)))); - return new MalList(array(chars)); - } -} - -abstract class MalSequential : MalType, HasSeq, MalMeta -{ - MalType[] elements; - MalType meta_val; - - this(MalType[] lst) { - elements = lst; - meta_val = mal_nil; - } - - override bool opEquals(Object o) - { - auto oseq = cast(MalSequential)(o); - return (oseq !is null && elements == oseq.elements); - } - - MalSequential conj(MalType element); - - MalType seq() { - if (elements.length == 0) return mal_nil; - return new MalList(elements); - } -} - -class MalList : MalSequential, MalMeta -{ - this(MalType[] lst) { super(lst); } - this(MalList that, MalType new_meta) - { - super(that.elements); - meta_val = new_meta; - } - - override string print(bool readable) const - { - auto items_strs = elements.map!(e => e.print(readable)); - return "(" ~ array(items_strs).join(" ") ~ ")"; - } - - override MalSequential conj(MalType element) - { - return new MalList([element] ~ elements); - } - - override MalType meta() { return meta_val; } - override MalType with_meta(MalType new_meta) - { - return new MalList(this, new_meta); - } -} - -class MalVector : MalSequential, MalMeta -{ - this(MalType[] lst) { super(lst); } - this(MalVector that, MalType new_meta) - { - super(that.elements); - meta_val = new_meta; - } - - override string print(bool readable) const - { - auto items_strs = elements.map!(e => e.print(readable)); - return "[" ~ array(items_strs).join(" ") ~ "]"; - } - - override MalSequential conj(MalType element) - { - return new MalVector(elements ~ [element]); - } - - override MalType meta() { return meta_val; } - override MalType with_meta(MalType new_meta) - { - return new MalVector(this, new_meta); - } -} - -class MalHashmap : MalType, MalMeta -{ - MalType[string] data; - MalType meta_val; - - this(MalType[string] map) - { - data = map; - meta_val = mal_nil; - } - this(MalType[] lst) - { - put_kv_list(lst); - meta_val = mal_nil; - } - this(MalHashmap that, MalType new_meta) - { - data = that.data; - meta_val = new_meta; - } - - bool contains(in MalType key) - { - auto valp = (make_hash_key(key) in data); - return valp !is null; - } - - MalType get(in MalType key) - { - auto valp = (make_hash_key(key) in data); - return valp is null ? mal_nil : *valp; - } - - void remove(in MalType key) - { - data.remove(make_hash_key(key)); - } - - void put(in MalType key, MalType val) - { - data[make_hash_key(key)] = val; - } - - void put_kv_list(MalType[] lst) - { - foreach (kv; chunks(lst, 2)) - { - if (kv.length < 2) throw new Exception("requires even number of elements"); - put(kv[0], kv[1]); - } - } - - private string make_hash_key(in MalType key) - { - return verify_cast!MalString(key).val; - } - - override string print(bool readable) const - { - string[] parts; - foreach (k, v; data) - { - parts ~= (new MalString(k)).print(readable); - parts ~= v.print(readable); - } - return "{" ~ parts.join(" ") ~ "}"; - } - - override bool opEquals(Object o) - { - auto ohm = cast(MalHashmap)(o); - return (ohm !is null && data == ohm.data); - } - - override MalType meta() { return meta_val; } - override MalType with_meta(MalType new_meta) - { - return new MalHashmap(this, new_meta); - } -} - -alias BuiltinStaticFuncType = MalType function(MalType[] a ...); -alias BuiltinFuncType = MalType delegate(MalType[] a ...); - -class MalBuiltinFunc : MalType, MalMeta -{ - const BuiltinFuncType fn; - const string name; - MalType meta_val; - - this(in BuiltinFuncType fn_v, in string name_v) - { - fn = fn_v; - name = name_v; - meta_val = mal_nil; - } - - this(in BuiltinStaticFuncType static_fn_v, in string name_v) - { - fn = toDelegate(static_fn_v); - name = name_v; - meta_val = mal_nil; - } - - this(MalBuiltinFunc that, MalType new_meta) - { - fn = that.fn; - name = that.name; - meta_val = new_meta; - } - - override string print(bool readable) const - { - return ""; - } - - override MalType meta() { return meta_val; } - - override MalType with_meta(MalType new_meta) - { - return new MalBuiltinFunc(this, new_meta); - } -} - -class MalFunc : MalType, MalMeta -{ - MalType[] arg_names; - MalType func_body; - Env def_env; - bool is_macro; - MalType meta_val; - - this(MalType[] arg_names_v, MalType func_body_v, Env def_env_v) - { - arg_names = arg_names_v; - func_body = func_body_v; - def_env = def_env_v; - is_macro = false; - meta_val = mal_nil; - } - - this(MalFunc that, MalType new_meta) - { - arg_names = that.arg_names; - func_body = that.func_body; - def_env = that.def_env; - is_macro = that.is_macro; - meta_val = new_meta; - } - - override string print(bool readable) const - { - return " e.print(true))).join(",") ~ ">"; - } - - override MalType meta() { return meta_val; } - - override MalType with_meta(MalType new_meta) - { - return new MalFunc(this, new_meta); - } -} - -class MalAtom : MalType, MalMeta -{ - MalType val; - MalType meta_val; - - this(MalType v) - { - val = v; - meta_val = mal_nil; - } - - this(MalAtom that, MalType new_meta) - { - val = that.val; - meta_val = new_meta; - } - - override string print(bool readable) const - { - return "(atom " ~ val.print(readable) ~ ")"; - } - - override bool opEquals(Object other) - { - auto o = cast(MalAtom) other; - return (o !is null && val == o.val); - } - - override MalType meta() { return meta_val; } - - override MalType with_meta(MalType new_meta) - { - return new MalAtom(this, new_meta); - } -} - -class MalException : Exception -{ - MalType data; - - this(MalType val) - { - super("MalException"); - data = val; - } -} - -T verify_cast(T)(in MalType v) -{ - if (T res = cast(T) v) return res; - throw new Exception("Expected " ~ typeid(T).name); -} - -MalType mal_type_q(T)(in MalType[] a) -{ - verify_args_count(a, 1); - T res = cast(T) a[0]; - return bool_to_mal(res !is null); -} - -inout(MalType[]) verify_args_count(inout MalType[] args, in int expected_length) -{ - if (args.length != expected_length) - { - throw new Exception("Expected " ~ to!string(expected_length) ~ " arguments"); - } - return args; -} - -void verify_min_args_count(in MalType[] args, in int min_expected_length) -{ - if (args.length < min_expected_length) - { - throw new Exception("Expected at least " ~ to!string(min_expected_length) ~ " arguments"); - } -} +import std.algorithm; +import std.array; +import std.conv; +import std.functional; +import std.range; +import env; + +abstract class MalType +{ + string print(bool readable) const; + bool is_truthy() const { return true; } +} + +interface MalMeta +{ + MalType meta(); + MalType with_meta(MalType new_meta); +} + +interface HasSeq +{ + MalType seq(); +} + +class MalNil : MalType, HasSeq +{ + override string print(bool readable) const { return "nil"; } + override bool is_truthy() const { return false; } + override bool opEquals(Object o) { return (cast(MalNil)(o) !is null); } + override MalType seq() { return this; } +} + +class MalFalse : MalType +{ + override string print(bool readable) const { return "false"; } + override bool is_truthy() const { return false; } + override bool opEquals(Object o) { return (cast(MalFalse)(o) !is null); } +} + +class MalTrue : MalType +{ + override string print(bool readable) const { return "true"; } + override bool opEquals(Object o) { return (cast(MalTrue)(o) !is null); } +} + +MalNil mal_nil; +MalFalse mal_false; +MalTrue mal_true; + +static this() +{ + mal_nil = new MalNil; + mal_false = new MalFalse; + mal_true = new MalTrue; +} + +MalType bool_to_mal(in bool b) +{ + return b ? mal_true : mal_false; +} + +class MalSymbol : MalType +{ + const string name; + this(in string token) { name = token; } + override string print(bool readable) const { return name; } + + override size_t toHash() + { + return typeid(name).getHash(&name); + } + + override int opCmp(Object other) + { + MalSymbol o = cast(MalSymbol) other; + return cmp(name, o.name); + } + + override bool opEquals(Object other) + { + auto o = cast(MalSymbol) other; + return (o !is null && name == o.name); + } +} + +class MalInteger : MalType +{ + const long val; + this(string token) { val = to!long(token); } + this(long v) { val = v; } + override string print(bool readable) const { return to!string(val); } + + override bool opEquals(Object o) + { + auto oint = cast(MalInteger)(o); + return (oint !is null && val == oint.val); + } +} + +class MalString : MalType, HasSeq +{ + const string val; + this(in string token) { val = token; } + override string print(bool readable) const + { + if (is_keyword()) return ":" ~ val[2..$]; + if (readable) + { + string escaped = val.replace("\\", "\\\\") + .replace("\"", "\\\"") + .replace("\n", "\\n"); + return "\"" ~ escaped ~ "\""; + } + else + { + return val; + } + } + + bool is_keyword() const + { + return val.length > 1 && val[0..2] == "\u029e"; + } + + override bool opEquals(Object o) + { + auto ostr = cast(MalString)(o); + return (ostr !is null && val == ostr.val); + } + + override MalType seq() { + if (is_keyword() || val.length == 0) return mal_nil; + auto chars = val.map!(c => cast(MalType)(new MalString(to!string(c)))); + return new MalList(array(chars)); + } +} + +abstract class MalSequential : MalType, HasSeq, MalMeta +{ + MalType[] elements; + MalType meta_val; + + this(MalType[] lst) { + elements = lst; + meta_val = mal_nil; + } + + override bool opEquals(Object o) + { + auto oseq = cast(MalSequential)(o); + return (oseq !is null && elements == oseq.elements); + } + + MalSequential conj(MalType element); + + MalType seq() { + if (elements.length == 0) return mal_nil; + return new MalList(elements); + } +} + +class MalList : MalSequential, MalMeta +{ + this(MalType[] lst) { super(lst); } + this(MalList that, MalType new_meta) + { + super(that.elements); + meta_val = new_meta; + } + + override string print(bool readable) const + { + auto items_strs = elements.map!(e => e.print(readable)); + return "(" ~ array(items_strs).join(" ") ~ ")"; + } + + override MalSequential conj(MalType element) + { + return new MalList([element] ~ elements); + } + + override MalType meta() { return meta_val; } + override MalType with_meta(MalType new_meta) + { + return new MalList(this, new_meta); + } +} + +class MalVector : MalSequential, MalMeta +{ + this(MalType[] lst) { super(lst); } + this(MalVector that, MalType new_meta) + { + super(that.elements); + meta_val = new_meta; + } + + override string print(bool readable) const + { + auto items_strs = elements.map!(e => e.print(readable)); + return "[" ~ array(items_strs).join(" ") ~ "]"; + } + + override MalSequential conj(MalType element) + { + return new MalVector(elements ~ [element]); + } + + override MalType meta() { return meta_val; } + override MalType with_meta(MalType new_meta) + { + return new MalVector(this, new_meta); + } +} + +class MalHashmap : MalType, MalMeta +{ + MalType[string] data; + MalType meta_val; + + this(MalType[string] map) + { + data = map; + meta_val = mal_nil; + } + this(MalType[] lst) + { + put_kv_list(lst); + meta_val = mal_nil; + } + this(MalHashmap that, MalType new_meta) + { + data = that.data; + meta_val = new_meta; + } + + bool contains(in MalType key) + { + auto valp = (make_hash_key(key) in data); + return valp !is null; + } + + MalType get(in MalType key) + { + auto valp = (make_hash_key(key) in data); + return valp is null ? mal_nil : *valp; + } + + void remove(in MalType key) + { + data.remove(make_hash_key(key)); + } + + void put(in MalType key, MalType val) + { + data[make_hash_key(key)] = val; + } + + void put_kv_list(MalType[] lst) + { + foreach (kv; chunks(lst, 2)) + { + if (kv.length < 2) throw new Exception("requires even number of elements"); + put(kv[0], kv[1]); + } + } + + private string make_hash_key(in MalType key) + { + return verify_cast!MalString(key).val; + } + + override string print(bool readable) const + { + string[] parts; + foreach (k, v; data) + { + parts ~= (new MalString(k)).print(readable); + parts ~= v.print(readable); + } + return "{" ~ parts.join(" ") ~ "}"; + } + + override bool opEquals(Object o) + { + auto ohm = cast(MalHashmap)(o); + return (ohm !is null && data == ohm.data); + } + + override MalType meta() { return meta_val; } + override MalType with_meta(MalType new_meta) + { + return new MalHashmap(this, new_meta); + } +} + +alias BuiltinStaticFuncType = MalType function(MalType[] a ...); +alias BuiltinFuncType = MalType delegate(MalType[] a ...); + +class MalBuiltinFunc : MalType, MalMeta +{ + const BuiltinFuncType fn; + const string name; + MalType meta_val; + + this(in BuiltinFuncType fn_v, in string name_v) + { + fn = fn_v; + name = name_v; + meta_val = mal_nil; + } + + this(in BuiltinStaticFuncType static_fn_v, in string name_v) + { + fn = toDelegate(static_fn_v); + name = name_v; + meta_val = mal_nil; + } + + this(MalBuiltinFunc that, MalType new_meta) + { + fn = that.fn; + name = that.name; + meta_val = new_meta; + } + + override string print(bool readable) const + { + return ""; + } + + override MalType meta() { return meta_val; } + + override MalType with_meta(MalType new_meta) + { + return new MalBuiltinFunc(this, new_meta); + } +} + +class MalFunc : MalType, MalMeta +{ + MalType[] arg_names; + MalType func_body; + Env def_env; + bool is_macro; + MalType meta_val; + + this(MalType[] arg_names_v, MalType func_body_v, Env def_env_v) + { + arg_names = arg_names_v; + func_body = func_body_v; + def_env = def_env_v; + is_macro = false; + meta_val = mal_nil; + } + + this(MalFunc that, MalType new_meta) + { + arg_names = that.arg_names; + func_body = that.func_body; + def_env = that.def_env; + is_macro = that.is_macro; + meta_val = new_meta; + } + + override string print(bool readable) const + { + return " e.print(true))).join(",") ~ ">"; + } + + override MalType meta() { return meta_val; } + + override MalType with_meta(MalType new_meta) + { + return new MalFunc(this, new_meta); + } +} + +class MalAtom : MalType, MalMeta +{ + MalType val; + MalType meta_val; + + this(MalType v) + { + val = v; + meta_val = mal_nil; + } + + this(MalAtom that, MalType new_meta) + { + val = that.val; + meta_val = new_meta; + } + + override string print(bool readable) const + { + return "(atom " ~ val.print(readable) ~ ")"; + } + + override bool opEquals(Object other) + { + auto o = cast(MalAtom) other; + return (o !is null && val == o.val); + } + + override MalType meta() { return meta_val; } + + override MalType with_meta(MalType new_meta) + { + return new MalAtom(this, new_meta); + } +} + +class MalException : Exception +{ + MalType data; + + this(MalType val) + { + super("MalException"); + data = val; + } +} + +T verify_cast(T)(in MalType v) +{ + if (T res = cast(T) v) return res; + throw new Exception("Expected " ~ typeid(T).name); +} + +MalType mal_type_q(T)(in MalType[] a) +{ + verify_args_count(a, 1); + T res = cast(T) a[0]; + return bool_to_mal(res !is null); +} + +inout(MalType[]) verify_args_count(inout MalType[] args, in int expected_length) +{ + if (args.length != expected_length) + { + throw new Exception("Expected " ~ to!string(expected_length) ~ " arguments"); + } + return args; +} + +void verify_min_args_count(in MalType[] args, in int min_expected_length) +{ + if (args.length < min_expected_length) + { + throw new Exception("Expected at least " ~ to!string(min_expected_length) ~ " arguments"); + } +} diff --git a/impls/dart/.analysis_options b/impls/dart/.analysis_options index 4a23f8bf57..3b17ee273f 100644 --- a/impls/dart/.analysis_options +++ b/impls/dart/.analysis_options @@ -1,7 +1,7 @@ -analyzer: - strong-mode: true - exclude: - - step2_eval.dart - - step3_env.dart - - step4_if_fn_do.dart - - step5_tco.dart +analyzer: + strong-mode: true + exclude: + - step2_eval.dart + - step3_env.dart + - step4_if_fn_do.dart + - step5_tco.dart diff --git a/impls/dart/.packages b/impls/dart/.packages index 92024203bd..e8344c31ab 100644 --- a/impls/dart/.packages +++ b/impls/dart/.packages @@ -1,2 +1,2 @@ -# Generated by pub on 2016-08-20 13:39:08.695546. -mal:lib/ +# Generated by pub on 2016-08-20 13:39:08.695546. +mal:lib/ diff --git a/impls/dart/Dockerfile b/impls/dart/Dockerfile index 0b3602f377..b21e2d4993 100644 --- a/impls/dart/Dockerfile +++ b/impls/dart/Dockerfile @@ -1,29 +1,29 @@ -FROM ubuntu:vivid -MAINTAINER Harry Terkelsen - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install apt-transport-https -RUN curl https://dl-ssl.google.com/linux/linux_signing_key.pub | apt-key add - -RUN curl https://storage.googleapis.com/download.dartlang.org/linux/debian/dart_stable.list > /etc/apt/sources.list.d/dart_stable.list -RUN apt-get -y update - -RUN apt-get -y install dart +FROM ubuntu:vivid +MAINTAINER Harry Terkelsen + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install apt-transport-https +RUN curl https://dl-ssl.google.com/linux/linux_signing_key.pub | apt-key add - +RUN curl https://storage.googleapis.com/download.dartlang.org/linux/debian/dart_stable.list > /etc/apt/sources.list.d/dart_stable.list +RUN apt-get -y update + +RUN apt-get -y install dart diff --git a/impls/dart/Makefile b/impls/dart/Makefile index b3c660f49d..494fc839ca 100644 --- a/impls/dart/Makefile +++ b/impls/dart/Makefile @@ -1,5 +1,5 @@ -all: - @true - - -clean: +all: + @true + + +clean: diff --git a/impls/dart/core.dart b/impls/dart/core.dart index a8ac4b897d..36b6a5d9fa 100644 --- a/impls/dart/core.dart +++ b/impls/dart/core.dart @@ -1,303 +1,303 @@ -import 'dart:io'; - -import 'printer.dart'; -import 'reader.dart' as reader; -import 'types.dart'; - -Map ns = { - new MalSymbol('+'): new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalInt(a.value + b.value); - }), - new MalSymbol('-'): new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalInt(a.value - b.value); - }), - new MalSymbol('*'): new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalInt(a.value * b.value); - }), - new MalSymbol('/'): new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalInt(a.value ~/ b.value); - }), - new MalSymbol('list'): - new MalBuiltin((List args) => new MalList(args.toList())), - new MalSymbol('list?'): new MalBuiltin( - (List args) => new MalBool(args.single is MalList)), - new MalSymbol('empty?'): new MalBuiltin((List args) { - var a = args.single as MalIterable; - return new MalBool(a.elements.isEmpty); - }), - new MalSymbol('count'): new MalBuiltin((List args) { - var a = args.first as MalIterable; - return new MalInt(a.elements.length); - }), - new MalSymbol('='): new MalBuiltin((List args) { - var a = args[0]; - var b = args[1]; - return new MalBool(a == b); - }), - new MalSymbol('<'): new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalBool(a.value < b.value); - }), - new MalSymbol('<='): new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalBool(a.value <= b.value); - }), - new MalSymbol('>'): new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalBool(a.value > b.value); - }), - new MalSymbol('>='): new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalBool(a.value >= b.value); - }), - new MalSymbol('pr-str'): new MalBuiltin((List args) { - return new MalString( - args.map((a) => pr_str(a, print_readably: true)).join(' ')); - }), - new MalSymbol('str'): new MalBuiltin((List args) { - return new MalString( - args.map((a) => pr_str(a, print_readably: false)).join()); - }), - new MalSymbol('prn'): new MalBuiltin((List args) { - print(args.map((a) => pr_str(a, print_readably: true)).join(' ')); - return new MalNil(); - }), - new MalSymbol('println'): new MalBuiltin((List args) { - print(args.map((a) => pr_str(a, print_readably: false)).join(' ')); - return new MalNil(); - }), - new MalSymbol('read-string'): new MalBuiltin((List args) { - var code = args.single as MalString; - return reader.read_str(code.value); - }), - new MalSymbol('slurp'): new MalBuiltin((List args) { - var fileName = args.single as MalString; - var file = new File(fileName.value); - return new MalString(file.readAsStringSync()); - }), - new MalSymbol('atom'): new MalBuiltin((List args) { - var value = args.single; - return new MalAtom(value); - }), - new MalSymbol('atom?'): new MalBuiltin((List args) { - var value = args.single; - return new MalBool(value is MalAtom); - }), - new MalSymbol('deref'): new MalBuiltin((List args) { - var atom = args.single as MalAtom; - return atom.value; - }), - new MalSymbol('reset!'): new MalBuiltin((List args) { - var atom = args[0] as MalAtom; - var newValue = args[1]; - atom.value = newValue; - return newValue; - }), - new MalSymbol('swap!'): new MalBuiltin((List args) { - var atom = args[0] as MalAtom; - var func = args[1] as MalCallable; - var fnArgs = [atom.value]..addAll(args.sublist(2)); - var result = func.call(fnArgs); - atom.value = result; - return result; - }), - new MalSymbol('cons'): new MalBuiltin((List args) { - var x = args[0]; - var xs = args[1] as MalIterable; - return new MalList([x]..addAll(xs)); - }), - new MalSymbol('concat'): new MalBuiltin((List args) { - var results = []; - for (MalIterable element in args) { - results.addAll(element); - } - return new MalList(results); - }), - new MalSymbol('vec'): new MalBuiltin((List args) { - if (args.length == 1) { - if (args[0] is MalVector) return args[0]; - if (args[0] is MalList) return new MalVector(args[0].elements); - } - throw new MalException(new MalString("vec: wrong arguments")); - }), - new MalSymbol('nth'): new MalBuiltin((List args) { - var indexable = args[0] as MalIterable; - var index = args[1] as MalInt; - try { - return indexable[index.value]; - } on RangeError catch (e) { - throw new MalException(new MalString(e.toString())); - } - }), - new MalSymbol('first'): new MalBuiltin((List args) { - var list = args.first as MalIterable; - if (list.isEmpty) return new MalNil(); - return list.first; - }), - new MalSymbol('rest'): new MalBuiltin((List args) { - var list = args.first as MalIterable; - if (list.isEmpty) return new MalList([]); - return new MalList(list.sublist(1)); - }), - new MalSymbol('throw'): new MalBuiltin((List args) { - throw new MalException(args.first); - }), - new MalSymbol('nil?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalNil); - }), - new MalSymbol('true?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalBool && (args.first as MalBool).value); - }), - new MalSymbol('false?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalBool && !(args.first as MalBool).value); - }), - new MalSymbol('symbol'): new MalBuiltin((List args) { - return new MalSymbol((args.first as MalString).value); - }), - new MalSymbol('symbol?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalSymbol); - }), - new MalSymbol('keyword'): new MalBuiltin((List args) { - if (args.first is MalKeyword) return args.first; - return new MalKeyword((args.first as MalString).value); - }), - new MalSymbol('keyword?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalKeyword); - }), - new MalSymbol('number?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalInt); - }), - new MalSymbol('fn?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalCallable && !(args.first.isMacro)); - }), - new MalSymbol('macro?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalCallable && args.first.isMacro); - }), - new MalSymbol('vector'): new MalBuiltin((List args) { - return new MalVector(args); - }), - new MalSymbol('vector?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalVector); - }), - new MalSymbol('hash-map'): new MalBuiltin((List args) { - return new MalHashMap.fromSequence(args); - }), - new MalSymbol('map?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalHashMap); - }), - new MalSymbol('assoc'): new MalBuiltin((List args) { - var map = args.first as MalHashMap; - var assoc = new MalHashMap.fromSequence(args.skip(1).toList()); - var newMap = new Map.from(map.value); - newMap.addAll(assoc.value); - return new MalHashMap(newMap); - }), - new MalSymbol('dissoc'): new MalBuiltin((List args) { - var map = args.first as MalHashMap; - var newMap = new Map.from(map.value); - for (var key in args.skip(1)) { - newMap.remove(key); - } - return new MalHashMap(newMap); - }), - new MalSymbol('get'): new MalBuiltin((List args) { - if (args[0] is MalNil) return new MalNil(); - var map = args[0] as MalHashMap; - var key = args[1]; - return map.value[key] ?? new MalNil(); - }), - new MalSymbol('contains?'): new MalBuiltin((List args) { - var map = args[0] as MalHashMap; - var key = args[1]; - return new MalBool(map.value.containsKey(key)); - }), - new MalSymbol('keys'): new MalBuiltin((List args) { - return new MalList((args.first as MalHashMap).value.keys.toList()); - }), - new MalSymbol('vals'): new MalBuiltin((List args) { - return new MalList((args.first as MalHashMap).value.values.toList()); - }), - new MalSymbol('sequential?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalList || args.first is MalVector); - }), - new MalSymbol('readline'): new MalBuiltin((List args) { - var message = args.first as MalString; - stdout.write(message.value); - var input = stdin.readLineSync(); - if (input == null) return new MalNil(); - return new MalString(input); - }), - new MalSymbol('time-ms'): new MalBuiltin((List args) { - assert(args.isEmpty); - return new MalInt(new DateTime.now().millisecondsSinceEpoch); - }), - new MalSymbol('conj'): new MalBuiltin((List args) { - var collection = args.first; - var elements = args.sublist(1); - if (collection is MalList) { - return new MalList( - elements.reversed.toList()..addAll(collection.elements)); - } - if (collection is MalVector) { - return new MalVector(collection.elements.toList()..addAll(elements)); - } - throw new MalException(new MalString('"conj" takes a list or vector')); - }), - new MalSymbol('string?'): new MalBuiltin((List args) { - return new MalBool(args.first is MalString); - }), - new MalSymbol('seq'): new MalBuiltin((List args) { - var arg = args.first; - if (arg is MalIterable && arg.isEmpty) return new MalNil(); - if (arg is MalString && arg.value.isEmpty) return new MalNil(); - - if (arg is MalNil || arg is MalList) return arg; - if (arg is MalVector) return new MalList(arg.elements.toList()); - if (arg is MalString) { - var chars = []; - for (var i = 0; i < arg.value.length; i++) { - chars.add(new MalString(arg.value[i])); - } - return new MalList(chars); - } - throw new MalException(new MalString('bad argument to "seq"')); - }), - new MalSymbol('map'): new MalBuiltin((List args) { - var fn = args[0] as MalCallable; - var list = args[1] as MalIterable; - var newList = []; - for (var element in list) { - newList.add(fn.call([element])); - } - return new MalList(newList); - }), - new MalSymbol('apply'): new MalBuiltin((List args) { - var func = args.first as MalCallable; - var argList = args.last as MalIterable; - var newArgs = args.sublist(1, args.length - 1); - newArgs.addAll(argList); - return func.call(newArgs); - }), - new MalSymbol('meta'): new MalBuiltin((List args) { - var arg = args.first; - return arg.meta ?? new MalNil(); - }), - new MalSymbol('with-meta'): new MalBuiltin((List args) { - var evaled = args.first; - var evaledWithMeta = evaled.clone(); - evaledWithMeta.meta = args[1]; - return evaledWithMeta; - }), -}; +import 'dart:io'; + +import 'printer.dart'; +import 'reader.dart' as reader; +import 'types.dart'; + +Map ns = { + new MalSymbol('+'): new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalInt(a.value + b.value); + }), + new MalSymbol('-'): new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalInt(a.value - b.value); + }), + new MalSymbol('*'): new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalInt(a.value * b.value); + }), + new MalSymbol('/'): new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalInt(a.value ~/ b.value); + }), + new MalSymbol('list'): + new MalBuiltin((List args) => new MalList(args.toList())), + new MalSymbol('list?'): new MalBuiltin( + (List args) => new MalBool(args.single is MalList)), + new MalSymbol('empty?'): new MalBuiltin((List args) { + var a = args.single as MalIterable; + return new MalBool(a.elements.isEmpty); + }), + new MalSymbol('count'): new MalBuiltin((List args) { + var a = args.first as MalIterable; + return new MalInt(a.elements.length); + }), + new MalSymbol('='): new MalBuiltin((List args) { + var a = args[0]; + var b = args[1]; + return new MalBool(a == b); + }), + new MalSymbol('<'): new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalBool(a.value < b.value); + }), + new MalSymbol('<='): new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalBool(a.value <= b.value); + }), + new MalSymbol('>'): new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalBool(a.value > b.value); + }), + new MalSymbol('>='): new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalBool(a.value >= b.value); + }), + new MalSymbol('pr-str'): new MalBuiltin((List args) { + return new MalString( + args.map((a) => pr_str(a, print_readably: true)).join(' ')); + }), + new MalSymbol('str'): new MalBuiltin((List args) { + return new MalString( + args.map((a) => pr_str(a, print_readably: false)).join()); + }), + new MalSymbol('prn'): new MalBuiltin((List args) { + print(args.map((a) => pr_str(a, print_readably: true)).join(' ')); + return new MalNil(); + }), + new MalSymbol('println'): new MalBuiltin((List args) { + print(args.map((a) => pr_str(a, print_readably: false)).join(' ')); + return new MalNil(); + }), + new MalSymbol('read-string'): new MalBuiltin((List args) { + var code = args.single as MalString; + return reader.read_str(code.value); + }), + new MalSymbol('slurp'): new MalBuiltin((List args) { + var fileName = args.single as MalString; + var file = new File(fileName.value); + return new MalString(file.readAsStringSync()); + }), + new MalSymbol('atom'): new MalBuiltin((List args) { + var value = args.single; + return new MalAtom(value); + }), + new MalSymbol('atom?'): new MalBuiltin((List args) { + var value = args.single; + return new MalBool(value is MalAtom); + }), + new MalSymbol('deref'): new MalBuiltin((List args) { + var atom = args.single as MalAtom; + return atom.value; + }), + new MalSymbol('reset!'): new MalBuiltin((List args) { + var atom = args[0] as MalAtom; + var newValue = args[1]; + atom.value = newValue; + return newValue; + }), + new MalSymbol('swap!'): new MalBuiltin((List args) { + var atom = args[0] as MalAtom; + var func = args[1] as MalCallable; + var fnArgs = [atom.value]..addAll(args.sublist(2)); + var result = func.call(fnArgs); + atom.value = result; + return result; + }), + new MalSymbol('cons'): new MalBuiltin((List args) { + var x = args[0]; + var xs = args[1] as MalIterable; + return new MalList([x]..addAll(xs)); + }), + new MalSymbol('concat'): new MalBuiltin((List args) { + var results = []; + for (MalIterable element in args) { + results.addAll(element); + } + return new MalList(results); + }), + new MalSymbol('vec'): new MalBuiltin((List args) { + if (args.length == 1) { + if (args[0] is MalVector) return args[0]; + if (args[0] is MalList) return new MalVector(args[0].elements); + } + throw new MalException(new MalString("vec: wrong arguments")); + }), + new MalSymbol('nth'): new MalBuiltin((List args) { + var indexable = args[0] as MalIterable; + var index = args[1] as MalInt; + try { + return indexable[index.value]; + } on RangeError catch (e) { + throw new MalException(new MalString(e.toString())); + } + }), + new MalSymbol('first'): new MalBuiltin((List args) { + var list = args.first as MalIterable; + if (list.isEmpty) return new MalNil(); + return list.first; + }), + new MalSymbol('rest'): new MalBuiltin((List args) { + var list = args.first as MalIterable; + if (list.isEmpty) return new MalList([]); + return new MalList(list.sublist(1)); + }), + new MalSymbol('throw'): new MalBuiltin((List args) { + throw new MalException(args.first); + }), + new MalSymbol('nil?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalNil); + }), + new MalSymbol('true?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalBool && (args.first as MalBool).value); + }), + new MalSymbol('false?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalBool && !(args.first as MalBool).value); + }), + new MalSymbol('symbol'): new MalBuiltin((List args) { + return new MalSymbol((args.first as MalString).value); + }), + new MalSymbol('symbol?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalSymbol); + }), + new MalSymbol('keyword'): new MalBuiltin((List args) { + if (args.first is MalKeyword) return args.first; + return new MalKeyword((args.first as MalString).value); + }), + new MalSymbol('keyword?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalKeyword); + }), + new MalSymbol('number?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalInt); + }), + new MalSymbol('fn?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalCallable && !(args.first.isMacro)); + }), + new MalSymbol('macro?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalCallable && args.first.isMacro); + }), + new MalSymbol('vector'): new MalBuiltin((List args) { + return new MalVector(args); + }), + new MalSymbol('vector?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalVector); + }), + new MalSymbol('hash-map'): new MalBuiltin((List args) { + return new MalHashMap.fromSequence(args); + }), + new MalSymbol('map?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalHashMap); + }), + new MalSymbol('assoc'): new MalBuiltin((List args) { + var map = args.first as MalHashMap; + var assoc = new MalHashMap.fromSequence(args.skip(1).toList()); + var newMap = new Map.from(map.value); + newMap.addAll(assoc.value); + return new MalHashMap(newMap); + }), + new MalSymbol('dissoc'): new MalBuiltin((List args) { + var map = args.first as MalHashMap; + var newMap = new Map.from(map.value); + for (var key in args.skip(1)) { + newMap.remove(key); + } + return new MalHashMap(newMap); + }), + new MalSymbol('get'): new MalBuiltin((List args) { + if (args[0] is MalNil) return new MalNil(); + var map = args[0] as MalHashMap; + var key = args[1]; + return map.value[key] ?? new MalNil(); + }), + new MalSymbol('contains?'): new MalBuiltin((List args) { + var map = args[0] as MalHashMap; + var key = args[1]; + return new MalBool(map.value.containsKey(key)); + }), + new MalSymbol('keys'): new MalBuiltin((List args) { + return new MalList((args.first as MalHashMap).value.keys.toList()); + }), + new MalSymbol('vals'): new MalBuiltin((List args) { + return new MalList((args.first as MalHashMap).value.values.toList()); + }), + new MalSymbol('sequential?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalList || args.first is MalVector); + }), + new MalSymbol('readline'): new MalBuiltin((List args) { + var message = args.first as MalString; + stdout.write(message.value); + var input = stdin.readLineSync(); + if (input == null) return new MalNil(); + return new MalString(input); + }), + new MalSymbol('time-ms'): new MalBuiltin((List args) { + assert(args.isEmpty); + return new MalInt(new DateTime.now().millisecondsSinceEpoch); + }), + new MalSymbol('conj'): new MalBuiltin((List args) { + var collection = args.first; + var elements = args.sublist(1); + if (collection is MalList) { + return new MalList( + elements.reversed.toList()..addAll(collection.elements)); + } + if (collection is MalVector) { + return new MalVector(collection.elements.toList()..addAll(elements)); + } + throw new MalException(new MalString('"conj" takes a list or vector')); + }), + new MalSymbol('string?'): new MalBuiltin((List args) { + return new MalBool(args.first is MalString); + }), + new MalSymbol('seq'): new MalBuiltin((List args) { + var arg = args.first; + if (arg is MalIterable && arg.isEmpty) return new MalNil(); + if (arg is MalString && arg.value.isEmpty) return new MalNil(); + + if (arg is MalNil || arg is MalList) return arg; + if (arg is MalVector) return new MalList(arg.elements.toList()); + if (arg is MalString) { + var chars = []; + for (var i = 0; i < arg.value.length; i++) { + chars.add(new MalString(arg.value[i])); + } + return new MalList(chars); + } + throw new MalException(new MalString('bad argument to "seq"')); + }), + new MalSymbol('map'): new MalBuiltin((List args) { + var fn = args[0] as MalCallable; + var list = args[1] as MalIterable; + var newList = []; + for (var element in list) { + newList.add(fn.call([element])); + } + return new MalList(newList); + }), + new MalSymbol('apply'): new MalBuiltin((List args) { + var func = args.first as MalCallable; + var argList = args.last as MalIterable; + var newArgs = args.sublist(1, args.length - 1); + newArgs.addAll(argList); + return func.call(newArgs); + }), + new MalSymbol('meta'): new MalBuiltin((List args) { + var arg = args.first; + return arg.meta ?? new MalNil(); + }), + new MalSymbol('with-meta'): new MalBuiltin((List args) { + var evaled = args.first; + var evaledWithMeta = evaled.clone(); + evaledWithMeta.meta = args[1]; + return evaledWithMeta; + }), +}; diff --git a/impls/dart/env.dart b/impls/dart/env.dart index 122d377838..ed5098a3ef 100644 --- a/impls/dart/env.dart +++ b/impls/dart/env.dart @@ -1,54 +1,54 @@ -import 'types.dart'; - -class Env { - final Env outer; - - final data = {}; - - Env([this.outer, List binds, List exprs]) { - if (binds == null) { - assert(exprs == null); - } else { - assert(exprs != null && - (binds.length == exprs.length || binds.contains(new MalSymbol('&')))); - for (var i = 0; i < binds.length; i++) { - if (binds[i] == new MalSymbol('&')) { - set(binds[i + 1], new MalList(exprs.sublist(i))); - break; - } - set(binds[i], exprs[i]); - } - } - } - - void set(MalSymbol key, MalType value) { - data[key] = value; - } - - Env find(MalSymbol key) { - if (data[key] != null) { - return this; - } - if (outer != null) { - return outer.find(key); - } - return null; - } - - MalType get(MalSymbol key) { - var env = find(key); - if (env != null) { - return env.data[key]; - } - throw new NotFoundException(key.value); - } -} - -class NotFoundException implements Exception { - /// The name of the symbol that was not found. - final String value; - - NotFoundException(this.value); - - String toString() => "'$value' not found"; -} +import 'types.dart'; + +class Env { + final Env outer; + + final data = {}; + + Env([this.outer, List binds, List exprs]) { + if (binds == null) { + assert(exprs == null); + } else { + assert(exprs != null && + (binds.length == exprs.length || binds.contains(new MalSymbol('&')))); + for (var i = 0; i < binds.length; i++) { + if (binds[i] == new MalSymbol('&')) { + set(binds[i + 1], new MalList(exprs.sublist(i))); + break; + } + set(binds[i], exprs[i]); + } + } + } + + void set(MalSymbol key, MalType value) { + data[key] = value; + } + + Env find(MalSymbol key) { + if (data[key] != null) { + return this; + } + if (outer != null) { + return outer.find(key); + } + return null; + } + + MalType get(MalSymbol key) { + var env = find(key); + if (env != null) { + return env.data[key]; + } + throw new NotFoundException(key.value); + } +} + +class NotFoundException implements Exception { + /// The name of the symbol that was not found. + final String value; + + NotFoundException(this.value); + + String toString() => "'$value' not found"; +} diff --git a/impls/dart/printer.dart b/impls/dart/printer.dart index 472d9b7f0b..5b505998d2 100644 --- a/impls/dart/printer.dart +++ b/impls/dart/printer.dart @@ -1,47 +1,47 @@ -import 'types.dart'; - -String pr_str(MalType data, {bool print_readably: true}) { - if (data is MalSymbol) { - return data.value; - } else if (data is MalInt) { - return '${data.value}'; - } else if (data is MalList) { - var printedElements = - data.elements.map((e) => pr_str(e, print_readably: print_readably)); - return '(${printedElements.join(" ")})'; - } else if (data is MalVector) { - var printedElements = - data.elements.map((e) => pr_str(e, print_readably: print_readably)); - return '[${printedElements.join(" ")}]'; - } else if (data is MalHashMap) { - var printedElements = []; - data.value.forEach((key, value) { - printedElements.add(pr_str(key, print_readably: print_readably)); - printedElements.add(pr_str(value, print_readably: print_readably)); - }); - return '{${printedElements.join(" ")}}'; - } else if (data is MalString) { - if (print_readably) { - var readableValue = data.value - .replaceAll('\\', r'\\') - .replaceAll('\n', r'\n') - .replaceAll('\"', r'\"'); - return '"$readableValue"'; - } else { - return '${data.value}'; - } - } else if (data is MalKeyword) { - return ':${data.value}'; - } else if (data is MalBool) { - return '${data.value}'; - } else if (data is MalNil) { - return 'nil'; - } else if (data is MalBuiltin) { - return '#'; - } else if (data is MalClosure) { - return '#'; - } else if (data is MalAtom) { - return "(atom ${pr_str(data.value, print_readably: print_readably)})"; - } - throw new ArgumentError("Unrecognized type: ${data.runtimeType}"); -} +import 'types.dart'; + +String pr_str(MalType data, {bool print_readably: true}) { + if (data is MalSymbol) { + return data.value; + } else if (data is MalInt) { + return '${data.value}'; + } else if (data is MalList) { + var printedElements = + data.elements.map((e) => pr_str(e, print_readably: print_readably)); + return '(${printedElements.join(" ")})'; + } else if (data is MalVector) { + var printedElements = + data.elements.map((e) => pr_str(e, print_readably: print_readably)); + return '[${printedElements.join(" ")}]'; + } else if (data is MalHashMap) { + var printedElements = []; + data.value.forEach((key, value) { + printedElements.add(pr_str(key, print_readably: print_readably)); + printedElements.add(pr_str(value, print_readably: print_readably)); + }); + return '{${printedElements.join(" ")}}'; + } else if (data is MalString) { + if (print_readably) { + var readableValue = data.value + .replaceAll('\\', r'\\') + .replaceAll('\n', r'\n') + .replaceAll('\"', r'\"'); + return '"$readableValue"'; + } else { + return '${data.value}'; + } + } else if (data is MalKeyword) { + return ':${data.value}'; + } else if (data is MalBool) { + return '${data.value}'; + } else if (data is MalNil) { + return 'nil'; + } else if (data is MalBuiltin) { + return '#'; + } else if (data is MalClosure) { + return '#'; + } else if (data is MalAtom) { + return "(atom ${pr_str(data.value, print_readably: print_readably)})"; + } + throw new ArgumentError("Unrecognized type: ${data.runtimeType}"); +} diff --git a/impls/dart/pubspec.lock b/impls/dart/pubspec.lock index 655fcfbf0a..3668549ce3 100644 --- a/impls/dart/pubspec.lock +++ b/impls/dart/pubspec.lock @@ -1,4 +1,4 @@ -# Generated by pub -# See http://pub.dartlang.org/doc/glossary.html#lockfile -packages: {} -sdk: any +# Generated by pub +# See http://pub.dartlang.org/doc/glossary.html#lockfile +packages: {} +sdk: any diff --git a/impls/dart/pubspec.yaml b/impls/dart/pubspec.yaml index 4b09f91b79..ca48772876 100644 --- a/impls/dart/pubspec.yaml +++ b/impls/dart/pubspec.yaml @@ -1,3 +1,3 @@ -name: mal -author: Harry Terkelsen -version: 0.0.1 +name: mal +author: Harry Terkelsen +version: 0.0.1 diff --git a/impls/dart/reader.dart b/impls/dart/reader.dart index b746f70d28..7b6b785f60 100644 --- a/impls/dart/reader.dart +++ b/impls/dart/reader.dart @@ -1,149 +1,149 @@ -import 'types.dart'; - -final malRegExp = new RegExp( - r"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)"""); -final strRegExp = new RegExp( - r"""^"(?:\\.|[^\\"])*"$"""); - -class Reader { - final List tokens; - int _position = 0; - - Reader(this.tokens); - - String next() { - var token = peek(); - _position++; - return token; - } - - String peek() { - if (_position >= tokens.length) return null; - return tokens[_position]; - } -} - -class ParseException implements Exception { - final String message; - - ParseException(this.message); -} - -class NoInputException implements Exception {} - -MalType read_str(String code) { - var tokens = tokenizer(code); - if (tokens.isEmpty) { - throw new NoInputException(); - } - var reader = new Reader(tokens); - return read_form(reader); -} - -List tokenizer(String code) { - var matches = malRegExp.allMatches(code); - return matches - .map((m) => m.group(1)) - .where((token) => token.isNotEmpty && !token.startsWith(';')) - .toList(); -} - -MalType read_form(Reader reader) { - const macros = const { - "'": 'quote', - '`': 'quasiquote', - '~': 'unquote', - '~@': 'splice-unquote', - '@': 'deref', - '^': 'with-meta', - }; - const sequenceStarters = const {'(': ')', '[': ']', '{': '}'}; - var token = reader.peek(); - if (sequenceStarters.containsKey(token)) { - var elements = read_sequence(reader, token, sequenceStarters[token]); - if (token == '(') { - return new MalList(elements); - } - if (token == '[') { - return new MalVector(elements); - } - - if (token == '{') { - return new MalHashMap.fromSequence(elements); - } - - throw new StateError("Impossible!"); - } else if (macros.containsKey(token)) { - var macro = new MalSymbol(macros[token]); - reader.next(); - var form = read_form(reader); - if (token == '^') { - var meta = read_form(reader); - return new MalList([macro, meta, form]); - } else { - return new MalList([macro, form]); - } - } else { - return read_atom(reader); - } -} - -List read_sequence(Reader reader, String open, String close) { - // Consume opening token - var actualOpen = reader.next(); - assert(actualOpen == open); - - var elements = []; - for (var token = reader.peek();; token = reader.peek()) { - if (token == null) { - throw new ParseException("expected '$close', got EOF"); - } - if (token == close) break; - elements.add(read_form(reader)); - } - - var actualClose = reader.next(); - assert(actualClose == close); - - return elements; -} - -MalType read_atom(Reader reader) { - var token = reader.next(); - - var intAtom = int.parse(token, onError: (_) => null); - if (intAtom != null) { - return new MalInt(intAtom); - } - - if (strRegExp.matchAsPrefix(token) != null) { - var sanitizedToken = token - // remove surrounding quotes - .substring(1, token.length - 1) - .replaceAllMapped(new RegExp("\\\\(.)"), - (Match m) => m[1] == 'n' ? '\n' : m[1]); - return new MalString(sanitizedToken); - } - - if (token[0] == '"') { - throw new ParseException("expected '\"', got EOF"); - } - - if (token[0] == ':') { - return new MalKeyword(token.substring(1)); - } - - if (token == 'nil') { - return new MalNil(); - } - - if (token == 'true') { - return new MalBool(true); - } - - if (token == 'false') { - return new MalBool(false); - } - - return new MalSymbol(token); -} +import 'types.dart'; + +final malRegExp = new RegExp( + r"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)"""); +final strRegExp = new RegExp( + r"""^"(?:\\.|[^\\"])*"$"""); + +class Reader { + final List tokens; + int _position = 0; + + Reader(this.tokens); + + String next() { + var token = peek(); + _position++; + return token; + } + + String peek() { + if (_position >= tokens.length) return null; + return tokens[_position]; + } +} + +class ParseException implements Exception { + final String message; + + ParseException(this.message); +} + +class NoInputException implements Exception {} + +MalType read_str(String code) { + var tokens = tokenizer(code); + if (tokens.isEmpty) { + throw new NoInputException(); + } + var reader = new Reader(tokens); + return read_form(reader); +} + +List tokenizer(String code) { + var matches = malRegExp.allMatches(code); + return matches + .map((m) => m.group(1)) + .where((token) => token.isNotEmpty && !token.startsWith(';')) + .toList(); +} + +MalType read_form(Reader reader) { + const macros = const { + "'": 'quote', + '`': 'quasiquote', + '~': 'unquote', + '~@': 'splice-unquote', + '@': 'deref', + '^': 'with-meta', + }; + const sequenceStarters = const {'(': ')', '[': ']', '{': '}'}; + var token = reader.peek(); + if (sequenceStarters.containsKey(token)) { + var elements = read_sequence(reader, token, sequenceStarters[token]); + if (token == '(') { + return new MalList(elements); + } + if (token == '[') { + return new MalVector(elements); + } + + if (token == '{') { + return new MalHashMap.fromSequence(elements); + } + + throw new StateError("Impossible!"); + } else if (macros.containsKey(token)) { + var macro = new MalSymbol(macros[token]); + reader.next(); + var form = read_form(reader); + if (token == '^') { + var meta = read_form(reader); + return new MalList([macro, meta, form]); + } else { + return new MalList([macro, form]); + } + } else { + return read_atom(reader); + } +} + +List read_sequence(Reader reader, String open, String close) { + // Consume opening token + var actualOpen = reader.next(); + assert(actualOpen == open); + + var elements = []; + for (var token = reader.peek();; token = reader.peek()) { + if (token == null) { + throw new ParseException("expected '$close', got EOF"); + } + if (token == close) break; + elements.add(read_form(reader)); + } + + var actualClose = reader.next(); + assert(actualClose == close); + + return elements; +} + +MalType read_atom(Reader reader) { + var token = reader.next(); + + var intAtom = int.parse(token, onError: (_) => null); + if (intAtom != null) { + return new MalInt(intAtom); + } + + if (strRegExp.matchAsPrefix(token) != null) { + var sanitizedToken = token + // remove surrounding quotes + .substring(1, token.length - 1) + .replaceAllMapped(new RegExp("\\\\(.)"), + (Match m) => m[1] == 'n' ? '\n' : m[1]); + return new MalString(sanitizedToken); + } + + if (token[0] == '"') { + throw new ParseException("expected '\"', got EOF"); + } + + if (token[0] == ':') { + return new MalKeyword(token.substring(1)); + } + + if (token == 'nil') { + return new MalNil(); + } + + if (token == 'true') { + return new MalBool(true); + } + + if (token == 'false') { + return new MalBool(false); + } + + return new MalSymbol(token); +} diff --git a/impls/dart/run b/impls/dart/run index fefdb5875d..81c2705c0b 100755 --- a/impls/dart/run +++ b/impls/dart/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec dart --checked $(dirname $0)/${STEP:-stepA_mal}.dart "${@}" +#!/bin/bash +exec dart --checked $(dirname $0)/${STEP:-stepA_mal}.dart "${@}" diff --git a/impls/dart/step0_repl.dart b/impls/dart/step0_repl.dart index 3eb3414a71..7a7ae38c22 100644 --- a/impls/dart/step0_repl.dart +++ b/impls/dart/step0_repl.dart @@ -1,20 +1,20 @@ -import 'dart:io'; - -String READ(String x) => x; - -String EVAL(String x) => x; - -String PRINT(String x) => x; - -String rep(String x) => PRINT(EVAL(READ(x))); - -const prompt = 'user> '; -main() { - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output = rep(input); - stdout.writeln(output); - } -} +import 'dart:io'; + +String READ(String x) => x; + +String EVAL(String x) => x; + +String PRINT(String x) => x; + +String rep(String x) => PRINT(EVAL(READ(x))); + +const prompt = 'user> '; +main() { + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output = rep(input); + stdout.writeln(output); + } +} diff --git a/impls/dart/step1_read_print.dart b/impls/dart/step1_read_print.dart index 5269bf2295..059468f1be 100644 --- a/impls/dart/step1_read_print.dart +++ b/impls/dart/step1_read_print.dart @@ -1,34 +1,34 @@ -import 'dart:io'; - -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -MalType READ(String x) => reader.read_str(x); - -MalType EVAL(MalType x) => x; - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x))); -} - -const prompt = 'user> '; -main() { - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +MalType READ(String x) => reader.read_str(x); + +MalType EVAL(MalType x) => x; + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x))); +} + +const prompt = 'user> '; +main() { + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/step2_eval.dart b/impls/dart/step2_eval.dart index 820c8d769f..9cad873586 100644 --- a/impls/dart/step2_eval.dart +++ b/impls/dart/step2_eval.dart @@ -1,86 +1,86 @@ -import 'dart:io'; - -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -final Map replEnv = { - new MalSymbol('+'): (MalInt a, MalInt b) => new MalInt(a.value + b.value), - new MalSymbol('-'): (MalInt a, MalInt b) => new MalInt(a.value - b.value), - new MalSymbol('*'): (MalInt a, MalInt b) => new MalInt(a.value * b.value), - new MalSymbol('/'): (MalInt a, MalInt b) => new MalInt(a.value ~/ b.value), -}; - -MalType READ(String x) => reader.read_str(x); - -class NotFoundException implements Exception { - /// The name of the symbol that was not found. - final String value; - - NotFoundException(this.value); -} - -eval_ast(MalType ast, Map env) { - if (ast is MalSymbol) { - var result = env[ast]; - if (result == null) { - throw new NotFoundException(ast.value); - } - return result; - } else if (ast is MalList) { - return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalVector) { - return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalHashMap) { - var newMap = new Map.from(ast.value); - for (var key in newMap.keys) { - newMap[key] = EVAL(newMap[key], env); - } - return new MalHashMap(newMap); - } else { - return ast; - } -} - -EVAL(MalType ast, Map env) { - if (ast is! MalList) { - return eval_ast(ast, env); - } else { - if ((ast as MalList).elements.isEmpty) { - return ast; - } else { - var newAst = eval_ast(ast, env) as MalList; - Function f = newAst.elements.first; - var args = newAst.elements.sublist(1); - return Function.apply(f, args); - } - } -} - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x), replEnv)); -} - -const prompt = 'user> '; -main() { - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on NotFoundException catch (e) { - stdout.writeln("Error: '${e.value}' not found"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +final Map replEnv = { + new MalSymbol('+'): (MalInt a, MalInt b) => new MalInt(a.value + b.value), + new MalSymbol('-'): (MalInt a, MalInt b) => new MalInt(a.value - b.value), + new MalSymbol('*'): (MalInt a, MalInt b) => new MalInt(a.value * b.value), + new MalSymbol('/'): (MalInt a, MalInt b) => new MalInt(a.value ~/ b.value), +}; + +MalType READ(String x) => reader.read_str(x); + +class NotFoundException implements Exception { + /// The name of the symbol that was not found. + final String value; + + NotFoundException(this.value); +} + +eval_ast(MalType ast, Map env) { + if (ast is MalSymbol) { + var result = env[ast]; + if (result == null) { + throw new NotFoundException(ast.value); + } + return result; + } else if (ast is MalList) { + return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalVector) { + return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalHashMap) { + var newMap = new Map.from(ast.value); + for (var key in newMap.keys) { + newMap[key] = EVAL(newMap[key], env); + } + return new MalHashMap(newMap); + } else { + return ast; + } +} + +EVAL(MalType ast, Map env) { + if (ast is! MalList) { + return eval_ast(ast, env); + } else { + if ((ast as MalList).elements.isEmpty) { + return ast; + } else { + var newAst = eval_ast(ast, env) as MalList; + Function f = newAst.elements.first; + var args = newAst.elements.sublist(1); + return Function.apply(f, args); + } + } +} + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x), replEnv)); +} + +const prompt = 'user> '; +main() { + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/step3_env.dart b/impls/dart/step3_env.dart index 0c1a0af963..b6c2276434 100644 --- a/impls/dart/step3_env.dart +++ b/impls/dart/step3_env.dart @@ -1,126 +1,126 @@ -import 'dart:io'; - -import 'env.dart'; -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -final Env replEnv = new Env(); - -void setupEnv() { - replEnv.set(new MalSymbol('+'), new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalInt(a.value + b.value); - })); - replEnv.set(new MalSymbol('-'), new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalInt(a.value - b.value); - })); - replEnv.set(new MalSymbol('*'), new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalInt(a.value * b.value); - })); - replEnv.set(new MalSymbol('/'), new MalBuiltin((List args) { - var a = args[0] as MalInt; - var b = args[1] as MalInt; - return new MalInt(a.value ~/ b.value); - })); -} - -MalType READ(String x) => reader.read_str(x); - -MalType eval_ast(MalType ast, Env env) { - if (ast is MalSymbol) { - var result = env.get(ast); - if (result == null) { - throw new NotFoundException(ast.value); - } - return result; - } else if (ast is MalList) { - return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalVector) { - return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalHashMap) { - var newMap = new Map.from(ast.value); - for (var key in newMap.keys) { - newMap[key] = EVAL(newMap[key], env); - } - return new MalHashMap(newMap); - } else { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) { - if (ast is! MalList) { - return eval_ast(ast, env); - } else { - if ((ast as MalList).elements.isEmpty) { - return ast; - } else { - var list = ast as MalList; - if (list.elements.first is MalSymbol) { - var symbol = list.elements.first as MalSymbol; - var args = list.elements.sublist(1); - if (symbol.value == "def!") { - MalSymbol key = args.first; - MalType value = EVAL(args[1], env); - env.set(key, value); - return value; - } else if (symbol.value == "let*") { - // TODO(het): If elements.length is not even, give helpful error - Iterable> pairs(List elements) sync* { - for (var i = 0; i < elements.length; i += 2) { - yield [elements[i], elements[i + 1]]; - } - } - - var newEnv = new Env(env); - MalIterable bindings = args.first; - for (var pair in pairs(bindings.elements)) { - MalSymbol key = pair[0]; - MalType value = EVAL(pair[1], newEnv); - newEnv.set(key, value); - } - return EVAL(args[1], newEnv); - } - } - var newAst = eval_ast(ast, env) as MalList; - MalBuiltin f = newAst.elements.first; - var args = newAst.elements.sublist(1); - return f.call(args); - } - } -} - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x), replEnv)); -} - -const prompt = 'user> '; -main() { - setupEnv(); - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on NotFoundException catch (e) { - stdout.writeln("Error: '${e.value}' not found"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'env.dart'; +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +final Env replEnv = new Env(); + +void setupEnv() { + replEnv.set(new MalSymbol('+'), new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalInt(a.value + b.value); + })); + replEnv.set(new MalSymbol('-'), new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalInt(a.value - b.value); + })); + replEnv.set(new MalSymbol('*'), new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalInt(a.value * b.value); + })); + replEnv.set(new MalSymbol('/'), new MalBuiltin((List args) { + var a = args[0] as MalInt; + var b = args[1] as MalInt; + return new MalInt(a.value ~/ b.value); + })); +} + +MalType READ(String x) => reader.read_str(x); + +MalType eval_ast(MalType ast, Env env) { + if (ast is MalSymbol) { + var result = env.get(ast); + if (result == null) { + throw new NotFoundException(ast.value); + } + return result; + } else if (ast is MalList) { + return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalVector) { + return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalHashMap) { + var newMap = new Map.from(ast.value); + for (var key in newMap.keys) { + newMap[key] = EVAL(newMap[key], env); + } + return new MalHashMap(newMap); + } else { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) { + if (ast is! MalList) { + return eval_ast(ast, env); + } else { + if ((ast as MalList).elements.isEmpty) { + return ast; + } else { + var list = ast as MalList; + if (list.elements.first is MalSymbol) { + var symbol = list.elements.first as MalSymbol; + var args = list.elements.sublist(1); + if (symbol.value == "def!") { + MalSymbol key = args.first; + MalType value = EVAL(args[1], env); + env.set(key, value); + return value; + } else if (symbol.value == "let*") { + // TODO(het): If elements.length is not even, give helpful error + Iterable> pairs(List elements) sync* { + for (var i = 0; i < elements.length; i += 2) { + yield [elements[i], elements[i + 1]]; + } + } + + var newEnv = new Env(env); + MalIterable bindings = args.first; + for (var pair in pairs(bindings.elements)) { + MalSymbol key = pair[0]; + MalType value = EVAL(pair[1], newEnv); + newEnv.set(key, value); + } + return EVAL(args[1], newEnv); + } + } + var newAst = eval_ast(ast, env) as MalList; + MalBuiltin f = newAst.elements.first; + var args = newAst.elements.sublist(1); + return f.call(args); + } + } +} + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x), replEnv)); +} + +const prompt = 'user> '; +main() { + setupEnv(); + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/step4_if_fn_do.dart b/impls/dart/step4_if_fn_do.dart index 7559da64d2..4942cba8e3 100644 --- a/impls/dart/step4_if_fn_do.dart +++ b/impls/dart/step4_if_fn_do.dart @@ -1,142 +1,142 @@ -import 'dart:io'; - -import 'core.dart'; -import 'env.dart'; -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -final Env replEnv = new Env(); - -void setupEnv() { - ns.forEach((sym, fun) => replEnv.set(sym, fun)); - - rep('(def! not (fn* (a) (if a false true)))'); -} - -MalType READ(String x) => reader.read_str(x); - -MalType eval_ast(MalType ast, Env env) { - if (ast is MalSymbol) { - var result = env.get(ast); - if (result == null) { - throw new NotFoundException(ast.value); - } - return result; - } else if (ast is MalList) { - return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalVector) { - return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalHashMap) { - var newMap = new Map.from(ast.value); - for (var key in newMap.keys) { - newMap[key] = EVAL(newMap[key], env); - } - return new MalHashMap(newMap); - } else { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) { - if (ast is! MalList) { - return eval_ast(ast, env); - } else { - if ((ast as MalList).elements.isEmpty) { - return ast; - } else { - var list = ast as MalList; - if (list.elements.first is MalSymbol) { - var symbol = list.elements.first as MalSymbol; - var args = list.elements.sublist(1); - if (symbol.value == "def!") { - MalSymbol key = args.first; - MalType value = EVAL(args[1], env); - env.set(key, value); - return value; - } else if (symbol.value == "let*") { - // TODO(het): If elements.length is not even, give helpful error - Iterable> pairs(List elements) sync* { - for (var i = 0; i < elements.length; i += 2) { - yield [elements[i], elements[i + 1]]; - } - } - - var newEnv = new Env(env); - MalIterable bindings = args.first; - for (var pair in pairs(bindings.elements)) { - MalSymbol key = pair[0]; - MalType value = EVAL(pair[1], newEnv); - newEnv.set(key, value); - } - return EVAL(args[1], newEnv); - } else if (symbol.value == "do") { - return args.map((e) => EVAL(e, env)).toList().last; - } else if (symbol.value == "if") { - var condition = EVAL(args[0], env); - if (condition is MalNil || - condition is MalBool && condition.value == false) { - // False side of branch - if (args.length < 3) { - return new MalNil(); - } - return EVAL(args[2], env); - } else { - // True side of branch - return EVAL(args[1], env); - } - } else if (symbol.value == "fn*") { - var params = (args[0] as MalIterable) - .elements - .map((e) => e as MalSymbol) - .toList(); - return new MalClosure( - params, - args[1], - env, - (List funcArgs) => - EVAL(args[1], new Env(env, params, funcArgs))); - } - } - var newAst = eval_ast(ast, env) as MalList; - var f = newAst.elements.first; - if (f is MalCallable) { - return f.call(newAst.elements.sublist(1)); - } else { - throw 'bad!'; - } - } - } -} - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x), replEnv)); -} - -const prompt = 'user> '; -main() { - setupEnv(); - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on NotFoundException catch (e) { - stdout.writeln("Error: '${e.value}' not found"); - continue; - } on MalException catch (e) { - stdout.writeln("Error: ${printer.pr_str(e.value)}"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'core.dart'; +import 'env.dart'; +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +final Env replEnv = new Env(); + +void setupEnv() { + ns.forEach((sym, fun) => replEnv.set(sym, fun)); + + rep('(def! not (fn* (a) (if a false true)))'); +} + +MalType READ(String x) => reader.read_str(x); + +MalType eval_ast(MalType ast, Env env) { + if (ast is MalSymbol) { + var result = env.get(ast); + if (result == null) { + throw new NotFoundException(ast.value); + } + return result; + } else if (ast is MalList) { + return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalVector) { + return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalHashMap) { + var newMap = new Map.from(ast.value); + for (var key in newMap.keys) { + newMap[key] = EVAL(newMap[key], env); + } + return new MalHashMap(newMap); + } else { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) { + if (ast is! MalList) { + return eval_ast(ast, env); + } else { + if ((ast as MalList).elements.isEmpty) { + return ast; + } else { + var list = ast as MalList; + if (list.elements.first is MalSymbol) { + var symbol = list.elements.first as MalSymbol; + var args = list.elements.sublist(1); + if (symbol.value == "def!") { + MalSymbol key = args.first; + MalType value = EVAL(args[1], env); + env.set(key, value); + return value; + } else if (symbol.value == "let*") { + // TODO(het): If elements.length is not even, give helpful error + Iterable> pairs(List elements) sync* { + for (var i = 0; i < elements.length; i += 2) { + yield [elements[i], elements[i + 1]]; + } + } + + var newEnv = new Env(env); + MalIterable bindings = args.first; + for (var pair in pairs(bindings.elements)) { + MalSymbol key = pair[0]; + MalType value = EVAL(pair[1], newEnv); + newEnv.set(key, value); + } + return EVAL(args[1], newEnv); + } else if (symbol.value == "do") { + return args.map((e) => EVAL(e, env)).toList().last; + } else if (symbol.value == "if") { + var condition = EVAL(args[0], env); + if (condition is MalNil || + condition is MalBool && condition.value == false) { + // False side of branch + if (args.length < 3) { + return new MalNil(); + } + return EVAL(args[2], env); + } else { + // True side of branch + return EVAL(args[1], env); + } + } else if (symbol.value == "fn*") { + var params = (args[0] as MalIterable) + .elements + .map((e) => e as MalSymbol) + .toList(); + return new MalClosure( + params, + args[1], + env, + (List funcArgs) => + EVAL(args[1], new Env(env, params, funcArgs))); + } + } + var newAst = eval_ast(ast, env) as MalList; + var f = newAst.elements.first; + if (f is MalCallable) { + return f.call(newAst.elements.sublist(1)); + } else { + throw 'bad!'; + } + } + } +} + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x), replEnv)); +} + +const prompt = 'user> '; +main() { + setupEnv(); + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/step5_tco.dart b/impls/dart/step5_tco.dart index b2733a028e..a13c791843 100644 --- a/impls/dart/step5_tco.dart +++ b/impls/dart/step5_tco.dart @@ -1,157 +1,157 @@ -import 'dart:io'; - -import 'core.dart'; -import 'env.dart'; -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -final Env replEnv = new Env(); - -void setupEnv() { - ns.forEach((sym, fun) => replEnv.set(sym, fun)); - - rep('(def! not (fn* (a) (if a false true)))'); -} - -MalType READ(String x) => reader.read_str(x); - -MalType eval_ast(MalType ast, Env env) { - if (ast is MalSymbol) { - var result = env.get(ast); - if (result == null) { - throw new NotFoundException(ast.value); - } - return result; - } else if (ast is MalList) { - return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalVector) { - return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalHashMap) { - var newMap = new Map.from(ast.value); - for (var key in newMap.keys) { - newMap[key] = EVAL(newMap[key], env); - } - return new MalHashMap(newMap); - } else { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) { - while (true) { - if (ast is! MalList) { - return eval_ast(ast, env); - } else { - if ((ast as MalList).elements.isEmpty) { - return ast; - } else { - var list = ast as MalList; - if (list.elements.first is MalSymbol) { - var symbol = list.elements.first as MalSymbol; - var args = list.elements.sublist(1); - if (symbol.value == "def!") { - MalSymbol key = args.first; - MalType value = EVAL(args[1], env); - env.set(key, value); - return value; - } else if (symbol.value == "let*") { - // TODO(het): If elements.length is not even, give helpful error - Iterable> pairs(List elements) sync* { - for (var i = 0; i < elements.length; i += 2) { - yield [elements[i], elements[i + 1]]; - } - } - - var newEnv = new Env(env); - MalIterable bindings = args.first; - for (var pair in pairs(bindings.elements)) { - MalSymbol key = pair[0]; - MalType value = EVAL(pair[1], newEnv); - newEnv.set(key, value); - } - ast = args[1]; - env = newEnv; - continue; - } else if (symbol.value == "do") { - for (var element in args.sublist(0, args.length - 1)) { - eval_ast(element, env); - } - ast = args.last; - continue; - } else if (symbol.value == "if") { - var condition = EVAL(args[0], env); - if (condition is MalNil || - condition is MalBool && condition.value == false) { - // False side of branch - if (args.length < 3) { - return new MalNil(); - } - ast = args[2]; - continue; - } else { - // True side of branch - ast = args[1]; - continue; - } - } else if (symbol.value == "fn*") { - var params = (args[0] as MalIterable) - .elements - .map((e) => e as MalSymbol) - .toList(); - return new MalClosure( - params, - args[1], - env, - (List funcArgs) => - EVAL(args[1], new Env(env, params, funcArgs))); - } - } - var newAst = eval_ast(ast, env) as MalList; - var f = newAst.elements.first; - var args = newAst.elements.sublist(1); - if (f is MalBuiltin) { - return f.call(args); - } else if (f is MalClosure) { - ast = f.ast; - env = new Env(f.env, f.params, args); - continue; - } else { - throw 'bad!'; - } - } - } - } -} - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x), replEnv)); -} - -const prompt = 'user> '; -main() { - setupEnv(); - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on NotFoundException catch (e) { - stdout.writeln("Error: '${e.value}' not found"); - continue; - } on MalException catch (e) { - stdout.writeln("Error: ${printer.pr_str(e.value)}"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'core.dart'; +import 'env.dart'; +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +final Env replEnv = new Env(); + +void setupEnv() { + ns.forEach((sym, fun) => replEnv.set(sym, fun)); + + rep('(def! not (fn* (a) (if a false true)))'); +} + +MalType READ(String x) => reader.read_str(x); + +MalType eval_ast(MalType ast, Env env) { + if (ast is MalSymbol) { + var result = env.get(ast); + if (result == null) { + throw new NotFoundException(ast.value); + } + return result; + } else if (ast is MalList) { + return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalVector) { + return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalHashMap) { + var newMap = new Map.from(ast.value); + for (var key in newMap.keys) { + newMap[key] = EVAL(newMap[key], env); + } + return new MalHashMap(newMap); + } else { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) { + while (true) { + if (ast is! MalList) { + return eval_ast(ast, env); + } else { + if ((ast as MalList).elements.isEmpty) { + return ast; + } else { + var list = ast as MalList; + if (list.elements.first is MalSymbol) { + var symbol = list.elements.first as MalSymbol; + var args = list.elements.sublist(1); + if (symbol.value == "def!") { + MalSymbol key = args.first; + MalType value = EVAL(args[1], env); + env.set(key, value); + return value; + } else if (symbol.value == "let*") { + // TODO(het): If elements.length is not even, give helpful error + Iterable> pairs(List elements) sync* { + for (var i = 0; i < elements.length; i += 2) { + yield [elements[i], elements[i + 1]]; + } + } + + var newEnv = new Env(env); + MalIterable bindings = args.first; + for (var pair in pairs(bindings.elements)) { + MalSymbol key = pair[0]; + MalType value = EVAL(pair[1], newEnv); + newEnv.set(key, value); + } + ast = args[1]; + env = newEnv; + continue; + } else if (symbol.value == "do") { + for (var element in args.sublist(0, args.length - 1)) { + eval_ast(element, env); + } + ast = args.last; + continue; + } else if (symbol.value == "if") { + var condition = EVAL(args[0], env); + if (condition is MalNil || + condition is MalBool && condition.value == false) { + // False side of branch + if (args.length < 3) { + return new MalNil(); + } + ast = args[2]; + continue; + } else { + // True side of branch + ast = args[1]; + continue; + } + } else if (symbol.value == "fn*") { + var params = (args[0] as MalIterable) + .elements + .map((e) => e as MalSymbol) + .toList(); + return new MalClosure( + params, + args[1], + env, + (List funcArgs) => + EVAL(args[1], new Env(env, params, funcArgs))); + } + } + var newAst = eval_ast(ast, env) as MalList; + var f = newAst.elements.first; + var args = newAst.elements.sublist(1); + if (f is MalBuiltin) { + return f.call(args); + } else if (f is MalClosure) { + ast = f.ast; + env = new Env(f.env, f.params, args); + continue; + } else { + throw 'bad!'; + } + } + } + } +} + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x), replEnv)); +} + +const prompt = 'user> '; +main() { + setupEnv(); + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/step6_file.dart b/impls/dart/step6_file.dart index 3fee92d31d..0393ed8b91 100644 --- a/impls/dart/step6_file.dart +++ b/impls/dart/step6_file.dart @@ -1,168 +1,168 @@ -import 'dart:io'; - -import 'core.dart'; -import 'env.dart'; -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -final Env replEnv = new Env(); - -void setupEnv(List argv) { - // TODO(het): use replEnv#set once generalized tearoffs are implemented - ns.forEach((sym, fun) => replEnv.set(sym, fun)); - - replEnv.set(new MalSymbol('eval'), - new MalBuiltin((List args) => EVAL(args.single, replEnv))); - - replEnv.set(new MalSymbol('*ARGV*'), - new MalList(argv.map((s) => new MalString(s)).toList())); - - rep('(def! not (fn* (a) (if a false true)))'); - rep("(def! load-file " - "(fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -} - -MalType READ(String x) => reader.read_str(x); - -MalType eval_ast(MalType ast, Env env) { - if (ast is MalSymbol) { - var result = env.get(ast); - if (result == null) { - throw new NotFoundException(ast.value); - } - return result; - } else if (ast is MalList) { - return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalVector) { - return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalHashMap) { - var newMap = new Map.from(ast.value); - for (var key in newMap.keys) { - newMap[key] = EVAL(newMap[key], env); - } - return new MalHashMap(newMap); - } else { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) { - while (true) { - if (ast is! MalList) { - return eval_ast(ast, env); - } else { - if ((ast as MalList).elements.isEmpty) { - return ast; - } else { - var list = ast as MalList; - if (list.elements.first is MalSymbol) { - var symbol = list.elements.first as MalSymbol; - var args = list.elements.sublist(1); - if (symbol.value == "def!") { - MalSymbol key = args.first; - MalType value = EVAL(args[1], env); - env.set(key, value); - return value; - } else if (symbol.value == "let*") { - // TODO(het): If elements.length is not even, give helpful error - Iterable> pairs(List elements) sync* { - for (var i = 0; i < elements.length; i += 2) { - yield [elements[i], elements[i + 1]]; - } - } - - var newEnv = new Env(env); - MalIterable bindings = args.first; - for (var pair in pairs(bindings.elements)) { - MalSymbol key = pair[0]; - MalType value = EVAL(pair[1], newEnv); - newEnv.set(key, value); - } - ast = args[1]; - env = newEnv; - continue; - } else if (symbol.value == "do") { - eval_ast(new MalList(args.sublist(0, args.length - 1)), env); - ast = args.last; - continue; - } else if (symbol.value == "if") { - var condition = EVAL(args[0], env); - if (condition is MalNil || - condition is MalBool && condition.value == false) { - // False side of branch - if (args.length < 3) { - return new MalNil(); - } - ast = args[2]; - continue; - } else { - // True side of branch - ast = args[1]; - continue; - } - } else if (symbol.value == "fn*") { - var params = (args[0] as MalIterable) - .elements - .map((e) => e as MalSymbol) - .toList(); - return new MalClosure( - params, - args[1], - env, - (List funcArgs) => - EVAL(args[1], new Env(env, params, funcArgs))); - } - } - var newAst = eval_ast(ast, env) as MalList; - var f = newAst.elements.first; - var args = newAst.elements.sublist(1); - if (f is MalBuiltin) { - return f.call(args); - } else if (f is MalClosure) { - ast = f.ast; - env = new Env(f.env, f.params, args); - continue; - } else { - throw 'bad!'; - } - } - } - } -} - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x), replEnv)); -} - -const prompt = 'user> '; -main(List args) { - setupEnv(args.isEmpty ? const [] : args.sublist(1)); - if (args.isNotEmpty) { - rep("(load-file \"${args.first}\")"); - return; - } - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on NotFoundException catch (e) { - stdout.writeln("Error: '${e.value}' not found"); - continue; - } on MalException catch (e) { - stdout.writeln("Error: ${printer.pr_str(e.value)}"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'core.dart'; +import 'env.dart'; +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +final Env replEnv = new Env(); + +void setupEnv(List argv) { + // TODO(het): use replEnv#set once generalized tearoffs are implemented + ns.forEach((sym, fun) => replEnv.set(sym, fun)); + + replEnv.set(new MalSymbol('eval'), + new MalBuiltin((List args) => EVAL(args.single, replEnv))); + + replEnv.set(new MalSymbol('*ARGV*'), + new MalList(argv.map((s) => new MalString(s)).toList())); + + rep('(def! not (fn* (a) (if a false true)))'); + rep("(def! load-file " + "(fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +} + +MalType READ(String x) => reader.read_str(x); + +MalType eval_ast(MalType ast, Env env) { + if (ast is MalSymbol) { + var result = env.get(ast); + if (result == null) { + throw new NotFoundException(ast.value); + } + return result; + } else if (ast is MalList) { + return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalVector) { + return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalHashMap) { + var newMap = new Map.from(ast.value); + for (var key in newMap.keys) { + newMap[key] = EVAL(newMap[key], env); + } + return new MalHashMap(newMap); + } else { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) { + while (true) { + if (ast is! MalList) { + return eval_ast(ast, env); + } else { + if ((ast as MalList).elements.isEmpty) { + return ast; + } else { + var list = ast as MalList; + if (list.elements.first is MalSymbol) { + var symbol = list.elements.first as MalSymbol; + var args = list.elements.sublist(1); + if (symbol.value == "def!") { + MalSymbol key = args.first; + MalType value = EVAL(args[1], env); + env.set(key, value); + return value; + } else if (symbol.value == "let*") { + // TODO(het): If elements.length is not even, give helpful error + Iterable> pairs(List elements) sync* { + for (var i = 0; i < elements.length; i += 2) { + yield [elements[i], elements[i + 1]]; + } + } + + var newEnv = new Env(env); + MalIterable bindings = args.first; + for (var pair in pairs(bindings.elements)) { + MalSymbol key = pair[0]; + MalType value = EVAL(pair[1], newEnv); + newEnv.set(key, value); + } + ast = args[1]; + env = newEnv; + continue; + } else if (symbol.value == "do") { + eval_ast(new MalList(args.sublist(0, args.length - 1)), env); + ast = args.last; + continue; + } else if (symbol.value == "if") { + var condition = EVAL(args[0], env); + if (condition is MalNil || + condition is MalBool && condition.value == false) { + // False side of branch + if (args.length < 3) { + return new MalNil(); + } + ast = args[2]; + continue; + } else { + // True side of branch + ast = args[1]; + continue; + } + } else if (symbol.value == "fn*") { + var params = (args[0] as MalIterable) + .elements + .map((e) => e as MalSymbol) + .toList(); + return new MalClosure( + params, + args[1], + env, + (List funcArgs) => + EVAL(args[1], new Env(env, params, funcArgs))); + } + } + var newAst = eval_ast(ast, env) as MalList; + var f = newAst.elements.first; + var args = newAst.elements.sublist(1); + if (f is MalBuiltin) { + return f.call(args); + } else if (f is MalClosure) { + ast = f.ast; + env = new Env(f.env, f.params, args); + continue; + } else { + throw 'bad!'; + } + } + } + } +} + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x), replEnv)); +} + +const prompt = 'user> '; +main(List args) { + setupEnv(args.isEmpty ? const [] : args.sublist(1)); + if (args.isNotEmpty) { + rep("(load-file \"${args.first}\")"); + return; + } + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/step7_quote.dart b/impls/dart/step7_quote.dart index c8fd399ce6..9fc1fc3e4f 100644 --- a/impls/dart/step7_quote.dart +++ b/impls/dart/step7_quote.dart @@ -1,205 +1,205 @@ -import 'dart:io'; - -import 'core.dart'; -import 'env.dart'; -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -final Env replEnv = new Env(); - -void setupEnv(List argv) { - // TODO(het): use replEnv#set once generalized tearoffs are implemented - ns.forEach((sym, fun) => replEnv.set(sym, fun)); - - replEnv.set(new MalSymbol('eval'), - new MalBuiltin((List args) => EVAL(args.single, replEnv))); - - replEnv.set(new MalSymbol('*ARGV*'), - new MalList(argv.map((s) => new MalString(s)).toList())); - - rep('(def! not (fn* (a) (if a false true)))'); - rep("(def! load-file " - "(fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -} - -bool starts_with(MalType ast, String sym) { - return ast is MalList && ast.length == 2 && ast.first == new MalSymbol(sym); -} - -MalType qq_loop(List xs) { - var acc = new MalList([]); - for (var i=xs.length-1; 0<=i; i-=1) { - if (starts_with(xs[i], "splice-unquote")) { - acc = new MalList([new MalSymbol("concat"), (xs[i] as MalList)[1], acc]); - } else { - acc = new MalList([new MalSymbol("cons"), quasiquote(xs[i]), acc]); - } - } - return acc; -} - -MalType quasiquote(MalType ast) { - if (starts_with(ast, "unquote")) { - return (ast as MalList).elements[1]; - } else if (ast is MalList) { - return qq_loop(ast.elements); - } else if (ast is MalVector) { - return new MalList([new MalSymbol("vec"), qq_loop(ast.elements)]); - } else if (ast is MalSymbol || ast is MalHashMap) { - return new MalList([new MalSymbol("quote"), ast]); - } else { - return ast; - } -} - -MalType READ(String x) => reader.read_str(x); - -MalType eval_ast(MalType ast, Env env) { - if (ast is MalSymbol) { - var result = env.get(ast); - if (result == null) { - throw new NotFoundException(ast.value); - } - return result; - } else if (ast is MalList) { - return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalVector) { - return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalHashMap) { - var newMap = new Map.from(ast.value); - for (var key in newMap.keys) { - newMap[key] = EVAL(newMap[key], env); - } - return new MalHashMap(newMap); - } else { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) { - while (true) { - if (ast is! MalList) { - return eval_ast(ast, env); - } else { - if ((ast as MalList).elements.isEmpty) { - return ast; - } else { - var list = ast as MalList; - if (list.elements.first is MalSymbol) { - var symbol = list.elements.first as MalSymbol; - var args = list.elements.sublist(1); - if (symbol.value == "def!") { - MalSymbol key = args.first; - MalType value = EVAL(args[1], env); - env.set(key, value); - return value; - } else if (symbol.value == "let*") { - // TODO(het): If elements.length is not even, give helpful error - Iterable> pairs(List elements) sync* { - for (var i = 0; i < elements.length; i += 2) { - yield [elements[i], elements[i + 1]]; - } - } - - var newEnv = new Env(env); - MalIterable bindings = args.first; - for (var pair in pairs(bindings.elements)) { - MalSymbol key = pair[0]; - MalType value = EVAL(pair[1], newEnv); - newEnv.set(key, value); - } - ast = args[1]; - env = newEnv; - continue; - } else if (symbol.value == "do") { - eval_ast(new MalList(args.sublist(0, args.length - 1)), env); - ast = args.last; - continue; - } else if (symbol.value == "if") { - var condition = EVAL(args[0], env); - if (condition is MalNil || - condition is MalBool && condition.value == false) { - // False side of branch - if (args.length < 3) { - return new MalNil(); - } - ast = args[2]; - continue; - } else { - // True side of branch - ast = args[1]; - continue; - } - } else if (symbol.value == "fn*") { - var params = (args[0] as MalIterable) - .elements - .map((e) => e as MalSymbol) - .toList(); - return new MalClosure( - params, - args[1], - env, - (List funcArgs) => - EVAL(args[1], new Env(env, params, funcArgs))); - } else if (symbol.value == "quote") { - return args.single; - } else if (symbol.value == "quasiquoteexpand") { - return quasiquote(args.first); - } else if (symbol.value == "quasiquote") { - ast = quasiquote(args.first); - continue; - } - } - var newAst = eval_ast(ast, env) as MalList; - var f = newAst.elements.first; - var args = newAst.elements.sublist(1); - if (f is MalBuiltin) { - return f.call(args); - } else if (f is MalClosure) { - ast = f.ast; - env = new Env(f.env, f.params, args); - continue; - } else { - throw 'bad!'; - } - } - } - } -} - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x), replEnv)); -} - -const prompt = 'user> '; -main(List args) { - setupEnv(args.isEmpty ? const [] : args.sublist(1)); - if (args.isNotEmpty) { - rep("(load-file \"${args.first}\")"); - return; - } - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on NotFoundException catch (e) { - stdout.writeln("Error: '${e.value}' not found"); - continue; - } on MalException catch (e) { - stdout.writeln("Error: ${printer.pr_str(e.value)}"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'core.dart'; +import 'env.dart'; +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +final Env replEnv = new Env(); + +void setupEnv(List argv) { + // TODO(het): use replEnv#set once generalized tearoffs are implemented + ns.forEach((sym, fun) => replEnv.set(sym, fun)); + + replEnv.set(new MalSymbol('eval'), + new MalBuiltin((List args) => EVAL(args.single, replEnv))); + + replEnv.set(new MalSymbol('*ARGV*'), + new MalList(argv.map((s) => new MalString(s)).toList())); + + rep('(def! not (fn* (a) (if a false true)))'); + rep("(def! load-file " + "(fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +} + +bool starts_with(MalType ast, String sym) { + return ast is MalList && ast.length == 2 && ast.first == new MalSymbol(sym); +} + +MalType qq_loop(List xs) { + var acc = new MalList([]); + for (var i=xs.length-1; 0<=i; i-=1) { + if (starts_with(xs[i], "splice-unquote")) { + acc = new MalList([new MalSymbol("concat"), (xs[i] as MalList)[1], acc]); + } else { + acc = new MalList([new MalSymbol("cons"), quasiquote(xs[i]), acc]); + } + } + return acc; +} + +MalType quasiquote(MalType ast) { + if (starts_with(ast, "unquote")) { + return (ast as MalList).elements[1]; + } else if (ast is MalList) { + return qq_loop(ast.elements); + } else if (ast is MalVector) { + return new MalList([new MalSymbol("vec"), qq_loop(ast.elements)]); + } else if (ast is MalSymbol || ast is MalHashMap) { + return new MalList([new MalSymbol("quote"), ast]); + } else { + return ast; + } +} + +MalType READ(String x) => reader.read_str(x); + +MalType eval_ast(MalType ast, Env env) { + if (ast is MalSymbol) { + var result = env.get(ast); + if (result == null) { + throw new NotFoundException(ast.value); + } + return result; + } else if (ast is MalList) { + return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalVector) { + return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalHashMap) { + var newMap = new Map.from(ast.value); + for (var key in newMap.keys) { + newMap[key] = EVAL(newMap[key], env); + } + return new MalHashMap(newMap); + } else { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) { + while (true) { + if (ast is! MalList) { + return eval_ast(ast, env); + } else { + if ((ast as MalList).elements.isEmpty) { + return ast; + } else { + var list = ast as MalList; + if (list.elements.first is MalSymbol) { + var symbol = list.elements.first as MalSymbol; + var args = list.elements.sublist(1); + if (symbol.value == "def!") { + MalSymbol key = args.first; + MalType value = EVAL(args[1], env); + env.set(key, value); + return value; + } else if (symbol.value == "let*") { + // TODO(het): If elements.length is not even, give helpful error + Iterable> pairs(List elements) sync* { + for (var i = 0; i < elements.length; i += 2) { + yield [elements[i], elements[i + 1]]; + } + } + + var newEnv = new Env(env); + MalIterable bindings = args.first; + for (var pair in pairs(bindings.elements)) { + MalSymbol key = pair[0]; + MalType value = EVAL(pair[1], newEnv); + newEnv.set(key, value); + } + ast = args[1]; + env = newEnv; + continue; + } else if (symbol.value == "do") { + eval_ast(new MalList(args.sublist(0, args.length - 1)), env); + ast = args.last; + continue; + } else if (symbol.value == "if") { + var condition = EVAL(args[0], env); + if (condition is MalNil || + condition is MalBool && condition.value == false) { + // False side of branch + if (args.length < 3) { + return new MalNil(); + } + ast = args[2]; + continue; + } else { + // True side of branch + ast = args[1]; + continue; + } + } else if (symbol.value == "fn*") { + var params = (args[0] as MalIterable) + .elements + .map((e) => e as MalSymbol) + .toList(); + return new MalClosure( + params, + args[1], + env, + (List funcArgs) => + EVAL(args[1], new Env(env, params, funcArgs))); + } else if (symbol.value == "quote") { + return args.single; + } else if (symbol.value == "quasiquoteexpand") { + return quasiquote(args.first); + } else if (symbol.value == "quasiquote") { + ast = quasiquote(args.first); + continue; + } + } + var newAst = eval_ast(ast, env) as MalList; + var f = newAst.elements.first; + var args = newAst.elements.sublist(1); + if (f is MalBuiltin) { + return f.call(args); + } else if (f is MalClosure) { + ast = f.ast; + env = new Env(f.env, f.params, args); + continue; + } else { + throw 'bad!'; + } + } + } + } +} + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x), replEnv)); +} + +const prompt = 'user> '; +main(List args) { + setupEnv(args.isEmpty ? const [] : args.sublist(1)); + if (args.isNotEmpty) { + rep("(load-file \"${args.first}\")"); + return; + } + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/step8_macros.dart b/impls/dart/step8_macros.dart index 20a564a10f..a5e0d3e1b5 100644 --- a/impls/dart/step8_macros.dart +++ b/impls/dart/step8_macros.dart @@ -1,249 +1,249 @@ -import 'dart:io'; - -import 'core.dart'; -import 'env.dart'; -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -final Env replEnv = new Env(); - -void setupEnv(List argv) { - ns.forEach((sym, fun) => replEnv.set(sym, fun)); - - replEnv.set(new MalSymbol('eval'), - new MalBuiltin((List args) => EVAL(args.single, replEnv))); - - replEnv.set(new MalSymbol('*ARGV*'), - new MalList(argv.map((s) => new MalString(s)).toList())); - - rep('(def! not (fn* (a) (if a false true)))'); - rep("(def! load-file " - " (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - 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)))))))"); -} - -/// Returns `true` if [ast] is a macro call. -/// -/// This checks that [ast] is a list whose first element is a symbol that refers -/// to a function in the current [env] that is a macro. -bool isMacroCall(MalType ast, Env env) { - if (ast is MalList) { - if (ast.isNotEmpty && ast.first is MalSymbol) { - try { - var value = env.get(ast.first); - if (value is MalCallable) { - return value.isMacro; - } - } on NotFoundException { - return false; - } - } - } - return false; -} - -MalType macroexpand(MalType ast, Env env) { - while (isMacroCall(ast, env)) { - var macroSymbol = (ast as MalList).first; - var macro = env.get(macroSymbol) as MalCallable; - ast = macro((ast as MalList).sublist(1)); - } - return ast; -} - -bool starts_with(MalType ast, String sym) { - return ast is MalList && ast.length == 2 && ast.first == new MalSymbol(sym); -} - -MalType qq_loop(List xs) { - var acc = new MalList([]); - for (var i=xs.length-1; 0<=i; i-=1) { - if (starts_with(xs[i], "splice-unquote")) { - acc = new MalList([new MalSymbol("concat"), (xs[i] as MalList)[1], acc]); - } else { - acc = new MalList([new MalSymbol("cons"), quasiquote(xs[i]), acc]); - } - } - return acc; -} - -MalType quasiquote(MalType ast) { - if (starts_with(ast, "unquote")) { - return (ast as MalList).elements[1]; - } else if (ast is MalList) { - return qq_loop(ast.elements); - } else if (ast is MalVector) { - return new MalList([new MalSymbol("vec"), qq_loop(ast.elements)]); - } else if (ast is MalSymbol || ast is MalHashMap) { - return new MalList([new MalSymbol("quote"), ast]); - } else { - return ast; - } -} - -MalType READ(String x) => reader.read_str(x); - -MalType eval_ast(MalType ast, Env env) { - if (ast is MalSymbol) { - return env.get(ast); - } else if (ast is MalList) { - return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalVector) { - return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalHashMap) { - var newMap = new Map.from(ast.value); - for (var key in newMap.keys) { - newMap[key] = EVAL(newMap[key], env); - } - return new MalHashMap(newMap); - } else { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) { - while (true) { - if (ast is! MalList) { - return eval_ast(ast, env); - } else { - if ((ast as MalList).elements.isEmpty) { - return ast; - } else { - ast = macroexpand(ast, env); - if (ast is! MalList) return eval_ast(ast, env); - if ((ast as MalList).isEmpty) return ast; - - var list = ast as MalList; - - if (list.elements.first is MalSymbol) { - var symbol = list.elements.first as MalSymbol; - var args = list.elements.sublist(1); - if (symbol.value == "def!") { - MalSymbol key = args.first; - MalType value = EVAL(args[1], env); - env.set(key, value); - return value; - } else if (symbol.value == "defmacro!") { - MalSymbol key = args.first; - MalClosure macro = EVAL(args[1], env) as MalClosure; - macro.isMacro = true; - env.set(key, macro); - return macro; - } else if (symbol.value == "let*") { - // TODO(het): If elements.length is not even, give helpful error - Iterable> pairs(List elements) sync* { - for (var i = 0; i < elements.length; i += 2) { - yield [elements[i], elements[i + 1]]; - } - } - - var newEnv = new Env(env); - MalIterable bindings = args.first; - for (var pair in pairs(bindings.elements)) { - MalSymbol key = pair[0]; - MalType value = EVAL(pair[1], newEnv); - newEnv.set(key, value); - } - ast = args[1]; - env = newEnv; - continue; - } else if (symbol.value == "do") { - eval_ast(new MalList(args.sublist(0, args.length - 1)), env); - ast = args.last; - continue; - } else if (symbol.value == "if") { - var condition = EVAL(args[0], env); - if (condition is MalNil || - condition is MalBool && condition.value == false) { - // False side of branch - if (args.length < 3) { - return new MalNil(); - } - ast = args[2]; - continue; - } else { - // True side of branch - ast = args[1]; - continue; - } - } else if (symbol.value == "fn*") { - var params = (args[0] as MalIterable) - .elements - .map((e) => e as MalSymbol) - .toList(); - return new MalClosure( - params, - args[1], - env, - (List funcArgs) => - EVAL(args[1], new Env(env, params, funcArgs))); - } else if (symbol.value == "quote") { - return args.single; - } else if (symbol.value == "quasiquoteexpand") { - return quasiquote(args.first); - } else if (symbol.value == "quasiquote") { - ast = quasiquote(args.first); - continue; - } else if (symbol.value == 'macroexpand') { - return macroexpand(args.first, env); - } - } - var newAst = eval_ast(ast, env) as MalList; - var f = newAst.elements.first; - var args = newAst.elements.sublist(1); - if (f is MalBuiltin) { - return f.call(args); - } else if (f is MalClosure) { - ast = f.ast; - env = new Env(f.env, f.params, args); - continue; - } else { - throw 'bad!'; - } - } - } - } -} - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x), replEnv)); -} - -const prompt = 'user> '; -main(List args) { - setupEnv(args.isEmpty ? const [] : args.sublist(1)); - if (args.isNotEmpty) { - rep("(load-file \"${args.first}\")"); - return; - } - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on NotFoundException catch (e) { - stdout.writeln("Error: '${e.value}' not found"); - continue; - } on MalException catch (e) { - stdout.writeln("Error: ${printer.pr_str(e.value)}"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'core.dart'; +import 'env.dart'; +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +final Env replEnv = new Env(); + +void setupEnv(List argv) { + ns.forEach((sym, fun) => replEnv.set(sym, fun)); + + replEnv.set(new MalSymbol('eval'), + new MalBuiltin((List args) => EVAL(args.single, replEnv))); + + replEnv.set(new MalSymbol('*ARGV*'), + new MalList(argv.map((s) => new MalString(s)).toList())); + + rep('(def! not (fn* (a) (if a false true)))'); + rep("(def! load-file " + " (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + 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)))))))"); +} + +/// Returns `true` if [ast] is a macro call. +/// +/// This checks that [ast] is a list whose first element is a symbol that refers +/// to a function in the current [env] that is a macro. +bool isMacroCall(MalType ast, Env env) { + if (ast is MalList) { + if (ast.isNotEmpty && ast.first is MalSymbol) { + try { + var value = env.get(ast.first); + if (value is MalCallable) { + return value.isMacro; + } + } on NotFoundException { + return false; + } + } + } + return false; +} + +MalType macroexpand(MalType ast, Env env) { + while (isMacroCall(ast, env)) { + var macroSymbol = (ast as MalList).first; + var macro = env.get(macroSymbol) as MalCallable; + ast = macro((ast as MalList).sublist(1)); + } + return ast; +} + +bool starts_with(MalType ast, String sym) { + return ast is MalList && ast.length == 2 && ast.first == new MalSymbol(sym); +} + +MalType qq_loop(List xs) { + var acc = new MalList([]); + for (var i=xs.length-1; 0<=i; i-=1) { + if (starts_with(xs[i], "splice-unquote")) { + acc = new MalList([new MalSymbol("concat"), (xs[i] as MalList)[1], acc]); + } else { + acc = new MalList([new MalSymbol("cons"), quasiquote(xs[i]), acc]); + } + } + return acc; +} + +MalType quasiquote(MalType ast) { + if (starts_with(ast, "unquote")) { + return (ast as MalList).elements[1]; + } else if (ast is MalList) { + return qq_loop(ast.elements); + } else if (ast is MalVector) { + return new MalList([new MalSymbol("vec"), qq_loop(ast.elements)]); + } else if (ast is MalSymbol || ast is MalHashMap) { + return new MalList([new MalSymbol("quote"), ast]); + } else { + return ast; + } +} + +MalType READ(String x) => reader.read_str(x); + +MalType eval_ast(MalType ast, Env env) { + if (ast is MalSymbol) { + return env.get(ast); + } else if (ast is MalList) { + return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalVector) { + return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalHashMap) { + var newMap = new Map.from(ast.value); + for (var key in newMap.keys) { + newMap[key] = EVAL(newMap[key], env); + } + return new MalHashMap(newMap); + } else { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) { + while (true) { + if (ast is! MalList) { + return eval_ast(ast, env); + } else { + if ((ast as MalList).elements.isEmpty) { + return ast; + } else { + ast = macroexpand(ast, env); + if (ast is! MalList) return eval_ast(ast, env); + if ((ast as MalList).isEmpty) return ast; + + var list = ast as MalList; + + if (list.elements.first is MalSymbol) { + var symbol = list.elements.first as MalSymbol; + var args = list.elements.sublist(1); + if (symbol.value == "def!") { + MalSymbol key = args.first; + MalType value = EVAL(args[1], env); + env.set(key, value); + return value; + } else if (symbol.value == "defmacro!") { + MalSymbol key = args.first; + MalClosure macro = EVAL(args[1], env) as MalClosure; + macro.isMacro = true; + env.set(key, macro); + return macro; + } else if (symbol.value == "let*") { + // TODO(het): If elements.length is not even, give helpful error + Iterable> pairs(List elements) sync* { + for (var i = 0; i < elements.length; i += 2) { + yield [elements[i], elements[i + 1]]; + } + } + + var newEnv = new Env(env); + MalIterable bindings = args.first; + for (var pair in pairs(bindings.elements)) { + MalSymbol key = pair[0]; + MalType value = EVAL(pair[1], newEnv); + newEnv.set(key, value); + } + ast = args[1]; + env = newEnv; + continue; + } else if (symbol.value == "do") { + eval_ast(new MalList(args.sublist(0, args.length - 1)), env); + ast = args.last; + continue; + } else if (symbol.value == "if") { + var condition = EVAL(args[0], env); + if (condition is MalNil || + condition is MalBool && condition.value == false) { + // False side of branch + if (args.length < 3) { + return new MalNil(); + } + ast = args[2]; + continue; + } else { + // True side of branch + ast = args[1]; + continue; + } + } else if (symbol.value == "fn*") { + var params = (args[0] as MalIterable) + .elements + .map((e) => e as MalSymbol) + .toList(); + return new MalClosure( + params, + args[1], + env, + (List funcArgs) => + EVAL(args[1], new Env(env, params, funcArgs))); + } else if (symbol.value == "quote") { + return args.single; + } else if (symbol.value == "quasiquoteexpand") { + return quasiquote(args.first); + } else if (symbol.value == "quasiquote") { + ast = quasiquote(args.first); + continue; + } else if (symbol.value == 'macroexpand') { + return macroexpand(args.first, env); + } + } + var newAst = eval_ast(ast, env) as MalList; + var f = newAst.elements.first; + var args = newAst.elements.sublist(1); + if (f is MalBuiltin) { + return f.call(args); + } else if (f is MalClosure) { + ast = f.ast; + env = new Env(f.env, f.params, args); + continue; + } else { + throw 'bad!'; + } + } + } + } +} + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x), replEnv)); +} + +const prompt = 'user> '; +main(List args) { + setupEnv(args.isEmpty ? const [] : args.sublist(1)); + if (args.isNotEmpty) { + rep("(load-file \"${args.first}\")"); + return; + } + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/step9_try.dart b/impls/dart/step9_try.dart index 5bd894bc86..112672436a 100644 --- a/impls/dart/step9_try.dart +++ b/impls/dart/step9_try.dart @@ -1,274 +1,274 @@ -import 'dart:io'; - -import 'core.dart'; -import 'env.dart'; -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -final Env replEnv = new Env(); - -void setupEnv(List argv) { - ns.forEach((sym, fun) => replEnv.set(sym, fun)); - - replEnv.set(new MalSymbol('eval'), - new MalBuiltin((List args) => EVAL(args.single, replEnv))); - - replEnv.set(new MalSymbol('*ARGV*'), - new MalList(argv.map((s) => new MalString(s)).toList())); - - rep('(def! not (fn* (a) (if a false true)))'); - rep("(def! load-file " - " (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - 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)))))))"); -} - -/// Returns `true` if [ast] is a macro call. -/// -/// This checks that [ast] is a list whose first element is a symbol that refers -/// to a function in the current [env] that is a macro. -bool isMacroCall(MalType ast, Env env) { - if (ast is MalList) { - if (ast.isNotEmpty && ast.first is MalSymbol) { - try { - var value = env.get(ast.first); - if (value is MalCallable) { - return value.isMacro; - } - } on NotFoundException { - return false; - } - } - } - return false; -} - -MalType macroexpand(MalType ast, Env env) { - while (isMacroCall(ast, env)) { - var macroSymbol = (ast as MalList).first; - var macro = env.get(macroSymbol) as MalCallable; - ast = macro((ast as MalList).sublist(1)); - } - return ast; -} - -bool starts_with(MalType ast, String sym) { - return ast is MalList && ast.length == 2 && ast.first == new MalSymbol(sym); -} - -MalType qq_loop(List xs) { - var acc = new MalList([]); - for (var i=xs.length-1; 0<=i; i-=1) { - if (starts_with(xs[i], "splice-unquote")) { - acc = new MalList([new MalSymbol("concat"), (xs[i] as MalList)[1], acc]); - } else { - acc = new MalList([new MalSymbol("cons"), quasiquote(xs[i]), acc]); - } - } - return acc; -} - -MalType quasiquote(MalType ast) { - if (starts_with(ast, "unquote")) { - return (ast as MalList).elements[1]; - } else if (ast is MalList) { - return qq_loop(ast.elements); - } else if (ast is MalVector) { - return new MalList([new MalSymbol("vec"), qq_loop(ast.elements)]); - } else if (ast is MalSymbol || ast is MalHashMap) { - return new MalList([new MalSymbol("quote"), ast]); - } else { - return ast; - } -} - -MalType READ(String x) => reader.read_str(x); - -MalType eval_ast(MalType ast, Env env) { - if (ast is MalSymbol) { - return env.get(ast); - } else if (ast is MalList) { - return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalVector) { - return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalHashMap) { - var newMap = new Map.from(ast.value); - for (var key in newMap.keys) { - newMap[key] = EVAL(newMap[key], env); - } - return new MalHashMap(newMap); - } else { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) { - while (true) { - if (ast is! MalList) { - return eval_ast(ast, env); - } else { - if ((ast as MalList).elements.isEmpty) { - return ast; - } else { - ast = macroexpand(ast, env); - if (ast is! MalList) return eval_ast(ast, env); - if ((ast as MalList).isEmpty) return ast; - - var list = ast as MalList; - - if (list.elements.first is MalSymbol) { - var symbol = list.elements.first as MalSymbol; - var args = list.elements.sublist(1); - if (symbol.value == "def!") { - MalSymbol key = args.first; - MalType value = EVAL(args[1], env); - env.set(key, value); - return value; - } else if (symbol.value == "defmacro!") { - MalSymbol key = args.first; - MalClosure macro = EVAL(args[1], env) as MalClosure; - macro.isMacro = true; - env.set(key, macro); - return macro; - } else if (symbol.value == "let*") { - // TODO(het): If elements.length is not even, give helpful error - Iterable> pairs(List elements) sync* { - for (var i = 0; i < elements.length; i += 2) { - yield [elements[i], elements[i + 1]]; - } - } - - var newEnv = new Env(env); - MalIterable bindings = args.first; - for (var pair in pairs(bindings.elements)) { - MalSymbol key = pair[0]; - MalType value = EVAL(pair[1], newEnv); - newEnv.set(key, value); - } - ast = args[1]; - env = newEnv; - continue; - } else if (symbol.value == "do") { - eval_ast(new MalList(args.sublist(0, args.length - 1)), env); - ast = args.last; - continue; - } else if (symbol.value == "if") { - var condition = EVAL(args[0], env); - if (condition is MalNil || - condition is MalBool && condition.value == false) { - // False side of branch - if (args.length < 3) { - return new MalNil(); - } - ast = args[2]; - continue; - } else { - // True side of branch - ast = args[1]; - continue; - } - } else if (symbol.value == "fn*") { - var params = (args[0] as MalIterable) - .elements - .map((e) => e as MalSymbol) - .toList(); - return new MalClosure( - params, - args[1], - env, - (List funcArgs) => - EVAL(args[1], new Env(env, params, funcArgs))); - } else if (symbol.value == "quote") { - return args.single; - } else if (symbol.value == "quasiquoteexpand") { - return quasiquote(args.first); - } else if (symbol.value == "quasiquote") { - ast = quasiquote(args.first); - continue; - } else if (symbol.value == 'macroexpand') { - return macroexpand(args.first, env); - } else if (symbol.value == 'try*') { - var body = args.first; - if (args.length < 2) { - ast = EVAL(body, env); - continue; - } - var catchClause = args[1] as MalList; - try { - ast = EVAL(body, env); - } catch (e) { - assert((catchClause.first as MalSymbol).value == 'catch*'); - var exceptionSymbol = catchClause[1] as MalSymbol; - var catchBody = catchClause[2]; - MalType exceptionValue; - if (e is MalException) { - exceptionValue = e.value; - } else if (e is reader.ParseException) { - exceptionValue = new MalString(e.message); - } else { - exceptionValue = new MalString(e.toString()); - } - var newEnv = new Env(env, [exceptionSymbol], [exceptionValue]); - ast = EVAL(catchBody, newEnv); - } - continue; - } - } - var newAst = eval_ast(ast, env) as MalList; - var f = newAst.elements.first; - var args = newAst.elements.sublist(1); - if (f is MalBuiltin) { - return f.call(args); - } else if (f is MalClosure) { - ast = f.ast; - env = new Env(f.env, f.params, args); - continue; - } else { - throw 'bad!'; - } - } - } - } -} - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x), replEnv)); -} - -const prompt = 'user> '; -main(List args) { - setupEnv(args.isEmpty ? const [] : args.sublist(1)); - if (args.isNotEmpty) { - rep("(load-file \"${args.first}\")"); - return; - } - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on NotFoundException catch (e) { - stdout.writeln("Error: '${e.value}' not found"); - continue; - } on MalException catch (e) { - stdout.writeln("Error: ${printer.pr_str(e.value)}"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'core.dart'; +import 'env.dart'; +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +final Env replEnv = new Env(); + +void setupEnv(List argv) { + ns.forEach((sym, fun) => replEnv.set(sym, fun)); + + replEnv.set(new MalSymbol('eval'), + new MalBuiltin((List args) => EVAL(args.single, replEnv))); + + replEnv.set(new MalSymbol('*ARGV*'), + new MalList(argv.map((s) => new MalString(s)).toList())); + + rep('(def! not (fn* (a) (if a false true)))'); + rep("(def! load-file " + " (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + 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)))))))"); +} + +/// Returns `true` if [ast] is a macro call. +/// +/// This checks that [ast] is a list whose first element is a symbol that refers +/// to a function in the current [env] that is a macro. +bool isMacroCall(MalType ast, Env env) { + if (ast is MalList) { + if (ast.isNotEmpty && ast.first is MalSymbol) { + try { + var value = env.get(ast.first); + if (value is MalCallable) { + return value.isMacro; + } + } on NotFoundException { + return false; + } + } + } + return false; +} + +MalType macroexpand(MalType ast, Env env) { + while (isMacroCall(ast, env)) { + var macroSymbol = (ast as MalList).first; + var macro = env.get(macroSymbol) as MalCallable; + ast = macro((ast as MalList).sublist(1)); + } + return ast; +} + +bool starts_with(MalType ast, String sym) { + return ast is MalList && ast.length == 2 && ast.first == new MalSymbol(sym); +} + +MalType qq_loop(List xs) { + var acc = new MalList([]); + for (var i=xs.length-1; 0<=i; i-=1) { + if (starts_with(xs[i], "splice-unquote")) { + acc = new MalList([new MalSymbol("concat"), (xs[i] as MalList)[1], acc]); + } else { + acc = new MalList([new MalSymbol("cons"), quasiquote(xs[i]), acc]); + } + } + return acc; +} + +MalType quasiquote(MalType ast) { + if (starts_with(ast, "unquote")) { + return (ast as MalList).elements[1]; + } else if (ast is MalList) { + return qq_loop(ast.elements); + } else if (ast is MalVector) { + return new MalList([new MalSymbol("vec"), qq_loop(ast.elements)]); + } else if (ast is MalSymbol || ast is MalHashMap) { + return new MalList([new MalSymbol("quote"), ast]); + } else { + return ast; + } +} + +MalType READ(String x) => reader.read_str(x); + +MalType eval_ast(MalType ast, Env env) { + if (ast is MalSymbol) { + return env.get(ast); + } else if (ast is MalList) { + return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalVector) { + return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalHashMap) { + var newMap = new Map.from(ast.value); + for (var key in newMap.keys) { + newMap[key] = EVAL(newMap[key], env); + } + return new MalHashMap(newMap); + } else { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) { + while (true) { + if (ast is! MalList) { + return eval_ast(ast, env); + } else { + if ((ast as MalList).elements.isEmpty) { + return ast; + } else { + ast = macroexpand(ast, env); + if (ast is! MalList) return eval_ast(ast, env); + if ((ast as MalList).isEmpty) return ast; + + var list = ast as MalList; + + if (list.elements.first is MalSymbol) { + var symbol = list.elements.first as MalSymbol; + var args = list.elements.sublist(1); + if (symbol.value == "def!") { + MalSymbol key = args.first; + MalType value = EVAL(args[1], env); + env.set(key, value); + return value; + } else if (symbol.value == "defmacro!") { + MalSymbol key = args.first; + MalClosure macro = EVAL(args[1], env) as MalClosure; + macro.isMacro = true; + env.set(key, macro); + return macro; + } else if (symbol.value == "let*") { + // TODO(het): If elements.length is not even, give helpful error + Iterable> pairs(List elements) sync* { + for (var i = 0; i < elements.length; i += 2) { + yield [elements[i], elements[i + 1]]; + } + } + + var newEnv = new Env(env); + MalIterable bindings = args.first; + for (var pair in pairs(bindings.elements)) { + MalSymbol key = pair[0]; + MalType value = EVAL(pair[1], newEnv); + newEnv.set(key, value); + } + ast = args[1]; + env = newEnv; + continue; + } else if (symbol.value == "do") { + eval_ast(new MalList(args.sublist(0, args.length - 1)), env); + ast = args.last; + continue; + } else if (symbol.value == "if") { + var condition = EVAL(args[0], env); + if (condition is MalNil || + condition is MalBool && condition.value == false) { + // False side of branch + if (args.length < 3) { + return new MalNil(); + } + ast = args[2]; + continue; + } else { + // True side of branch + ast = args[1]; + continue; + } + } else if (symbol.value == "fn*") { + var params = (args[0] as MalIterable) + .elements + .map((e) => e as MalSymbol) + .toList(); + return new MalClosure( + params, + args[1], + env, + (List funcArgs) => + EVAL(args[1], new Env(env, params, funcArgs))); + } else if (symbol.value == "quote") { + return args.single; + } else if (symbol.value == "quasiquoteexpand") { + return quasiquote(args.first); + } else if (symbol.value == "quasiquote") { + ast = quasiquote(args.first); + continue; + } else if (symbol.value == 'macroexpand') { + return macroexpand(args.first, env); + } else if (symbol.value == 'try*') { + var body = args.first; + if (args.length < 2) { + ast = EVAL(body, env); + continue; + } + var catchClause = args[1] as MalList; + try { + ast = EVAL(body, env); + } catch (e) { + assert((catchClause.first as MalSymbol).value == 'catch*'); + var exceptionSymbol = catchClause[1] as MalSymbol; + var catchBody = catchClause[2]; + MalType exceptionValue; + if (e is MalException) { + exceptionValue = e.value; + } else if (e is reader.ParseException) { + exceptionValue = new MalString(e.message); + } else { + exceptionValue = new MalString(e.toString()); + } + var newEnv = new Env(env, [exceptionSymbol], [exceptionValue]); + ast = EVAL(catchBody, newEnv); + } + continue; + } + } + var newAst = eval_ast(ast, env) as MalList; + var f = newAst.elements.first; + var args = newAst.elements.sublist(1); + if (f is MalBuiltin) { + return f.call(args); + } else if (f is MalClosure) { + ast = f.ast; + env = new Env(f.env, f.params, args); + continue; + } else { + throw 'bad!'; + } + } + } + } +} + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x), replEnv)); +} + +const prompt = 'user> '; +main(List args) { + setupEnv(args.isEmpty ? const [] : args.sublist(1)); + if (args.isNotEmpty) { + rep("(load-file \"${args.first}\")"); + return; + } + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/stepA_mal.dart b/impls/dart/stepA_mal.dart index 72bc20159c..f5e90d19ed 100644 --- a/impls/dart/stepA_mal.dart +++ b/impls/dart/stepA_mal.dart @@ -1,277 +1,277 @@ -import 'dart:io'; - -import 'core.dart'; -import 'env.dart'; -import 'printer.dart' as printer; -import 'reader.dart' as reader; -import 'types.dart'; - -final Env replEnv = new Env(); - -void setupEnv(List argv) { - ns.forEach((sym, fun) => replEnv.set(sym, fun)); - - replEnv.set(new MalSymbol('eval'), - new MalBuiltin((List args) => EVAL(args.single, replEnv))); - - replEnv.set(new MalSymbol('*ARGV*'), - new MalList(argv.map((s) => new MalString(s)).toList())); - - replEnv.set(new MalSymbol('*host-language*'), new MalString('dart')); - - rep('(def! not (fn* (a) (if a false true)))'); - rep("(def! load-file " - " (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - 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)))))))"); -} - -/// Returns `true` if [ast] is a macro call. -/// -/// This checks that [ast] is a list whose first element is a symbol that refers -/// to a function in the current [env] that is a macro. -bool isMacroCall(MalType ast, Env env) { - if (ast is MalList) { - if (ast.isNotEmpty && ast.first is MalSymbol) { - try { - var value = env.get(ast.first); - if (value is MalCallable) { - return value.isMacro; - } - } on NotFoundException { - return false; - } - } - } - return false; -} - -MalType macroexpand(MalType ast, Env env) { - while (isMacroCall(ast, env)) { - var macroSymbol = (ast as MalList).first; - var macro = env.get(macroSymbol) as MalCallable; - ast = macro((ast as MalList).sublist(1)); - } - return ast; -} - -bool starts_with(MalType ast, String sym) { - return ast is MalList && ast.length == 2 && ast.first == new MalSymbol(sym); -} - -MalType qq_loop(List xs) { - var acc = new MalList([]); - for (var i=xs.length-1; 0<=i; i-=1) { - if (starts_with(xs[i], "splice-unquote")) { - acc = new MalList([new MalSymbol("concat"), (xs[i] as MalList)[1], acc]); - } else { - acc = new MalList([new MalSymbol("cons"), quasiquote(xs[i]), acc]); - } - } - return acc; -} - -MalType quasiquote(MalType ast) { - if (starts_with(ast, "unquote")) { - return (ast as MalList).elements[1]; - } else if (ast is MalList) { - return qq_loop(ast.elements); - } else if (ast is MalVector) { - return new MalList([new MalSymbol("vec"), qq_loop(ast.elements)]); - } else if (ast is MalSymbol || ast is MalHashMap) { - return new MalList([new MalSymbol("quote"), ast]); - } else { - return ast; - } -} - -MalType READ(String x) => reader.read_str(x); - -MalType eval_ast(MalType ast, Env env) { - if (ast is MalSymbol) { - return env.get(ast); - } else if (ast is MalList) { - return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalVector) { - return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); - } else if (ast is MalHashMap) { - var newMap = new Map.from(ast.value); - for (var key in newMap.keys) { - newMap[key] = EVAL(newMap[key], env); - } - return new MalHashMap(newMap); - } else { - return ast; - } -} - -MalType EVAL(MalType ast, Env env) { - while (true) { - if (ast is! MalList) { - return eval_ast(ast, env); - } else { - if ((ast as MalList).elements.isEmpty) { - return ast; - } else { - ast = macroexpand(ast, env); - if (ast is! MalList) return eval_ast(ast, env); - if ((ast as MalList).isEmpty) return ast; - - var list = ast as MalList; - - if (list.elements.first is MalSymbol) { - var symbol = list.elements.first as MalSymbol; - var args = list.elements.sublist(1); - if (symbol.value == "def!") { - MalSymbol key = args.first; - MalType value = EVAL(args[1], env); - env.set(key, value); - return value; - } else if (symbol.value == "defmacro!") { - MalSymbol key = args.first; - MalClosure macro = EVAL(args[1], env) as MalClosure; - macro.isMacro = true; - env.set(key, macro); - return macro; - } else if (symbol.value == "let*") { - // TODO(het): If elements.length is not even, give helpful error - Iterable> pairs(List elements) sync* { - for (var i = 0; i < elements.length; i += 2) { - yield [elements[i], elements[i + 1]]; - } - } - - var newEnv = new Env(env); - MalIterable bindings = args.first; - for (var pair in pairs(bindings.elements)) { - MalSymbol key = pair[0]; - MalType value = EVAL(pair[1], newEnv); - newEnv.set(key, value); - } - ast = args[1]; - env = newEnv; - continue; - } else if (symbol.value == "do") { - eval_ast(new MalList(args.sublist(0, args.length - 1)), env); - ast = args.last; - continue; - } else if (symbol.value == "if") { - var condition = EVAL(args[0], env); - if (condition is MalNil || - condition is MalBool && condition.value == false) { - // False side of branch - if (args.length < 3) { - return new MalNil(); - } - ast = args[2]; - continue; - } else { - // True side of branch - ast = args[1]; - continue; - } - } else if (symbol.value == "fn*") { - var params = (args[0] as MalIterable) - .elements - .map((e) => e as MalSymbol) - .toList(); - return new MalClosure( - params, - args[1], - env, - (List funcArgs) => - EVAL(args[1], new Env(env, params, funcArgs))); - } else if (symbol.value == "quote") { - return args.single; - } else if (symbol.value == "quasiquoteexpand") { - return quasiquote(args.first); - } else if (symbol.value == "quasiquote") { - ast = quasiquote(args.first); - continue; - } else if (symbol.value == 'macroexpand') { - return macroexpand(args.first, env); - } else if (symbol.value == 'try*') { - var body = args.first; - if (args.length < 2) { - ast = EVAL(body, env); - continue; - } - var catchClause = args[1] as MalList; - try { - ast = EVAL(body, env); - } catch (e) { - assert((catchClause.first as MalSymbol).value == 'catch*'); - var exceptionSymbol = catchClause[1] as MalSymbol; - var catchBody = catchClause[2]; - MalType exceptionValue; - if (e is MalException) { - exceptionValue = e.value; - } else if (e is reader.ParseException) { - exceptionValue = new MalString(e.message); - } else { - exceptionValue = new MalString(e.toString()); - } - var newEnv = new Env(env, [exceptionSymbol], [exceptionValue]); - ast = EVAL(catchBody, newEnv); - } - continue; - } - } - var newAst = eval_ast(ast, env) as MalList; - var f = newAst.elements.first; - var args = newAst.elements.sublist(1); - if (f is MalBuiltin) { - return f.call(args); - } else if (f is MalClosure) { - ast = f.ast; - env = new Env(f.env, f.params, args); - continue; - } else { - throw 'bad!'; - } - } - } - } -} - -String PRINT(MalType x) => printer.pr_str(x); - -String rep(String x) { - return PRINT(EVAL(READ(x), replEnv)); -} - -const prompt = 'user> '; -main(List args) { - setupEnv(args.isEmpty ? const [] : args.sublist(1)); - if (args.isNotEmpty) { - rep("(load-file \"${args.first}\")"); - return; - } - rep("(println (str \"Mal [\" *host-language* \"]\"))"); - while (true) { - stdout.write(prompt); - var input = stdin.readLineSync(); - if (input == null) return; - var output; - try { - output = rep(input); - } on reader.ParseException catch (e) { - stdout.writeln("Error: '${e.message}'"); - continue; - } on NotFoundException catch (e) { - stdout.writeln("Error: '${e.value}' not found"); - continue; - } on MalException catch (e) { - stdout.writeln("Error: ${printer.pr_str(e.value)}"); - continue; - } on reader.NoInputException { - continue; - } - stdout.writeln(output); - } -} +import 'dart:io'; + +import 'core.dart'; +import 'env.dart'; +import 'printer.dart' as printer; +import 'reader.dart' as reader; +import 'types.dart'; + +final Env replEnv = new Env(); + +void setupEnv(List argv) { + ns.forEach((sym, fun) => replEnv.set(sym, fun)); + + replEnv.set(new MalSymbol('eval'), + new MalBuiltin((List args) => EVAL(args.single, replEnv))); + + replEnv.set(new MalSymbol('*ARGV*'), + new MalList(argv.map((s) => new MalString(s)).toList())); + + replEnv.set(new MalSymbol('*host-language*'), new MalString('dart')); + + rep('(def! not (fn* (a) (if a false true)))'); + rep("(def! load-file " + " (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + 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)))))))"); +} + +/// Returns `true` if [ast] is a macro call. +/// +/// This checks that [ast] is a list whose first element is a symbol that refers +/// to a function in the current [env] that is a macro. +bool isMacroCall(MalType ast, Env env) { + if (ast is MalList) { + if (ast.isNotEmpty && ast.first is MalSymbol) { + try { + var value = env.get(ast.first); + if (value is MalCallable) { + return value.isMacro; + } + } on NotFoundException { + return false; + } + } + } + return false; +} + +MalType macroexpand(MalType ast, Env env) { + while (isMacroCall(ast, env)) { + var macroSymbol = (ast as MalList).first; + var macro = env.get(macroSymbol) as MalCallable; + ast = macro((ast as MalList).sublist(1)); + } + return ast; +} + +bool starts_with(MalType ast, String sym) { + return ast is MalList && ast.length == 2 && ast.first == new MalSymbol(sym); +} + +MalType qq_loop(List xs) { + var acc = new MalList([]); + for (var i=xs.length-1; 0<=i; i-=1) { + if (starts_with(xs[i], "splice-unquote")) { + acc = new MalList([new MalSymbol("concat"), (xs[i] as MalList)[1], acc]); + } else { + acc = new MalList([new MalSymbol("cons"), quasiquote(xs[i]), acc]); + } + } + return acc; +} + +MalType quasiquote(MalType ast) { + if (starts_with(ast, "unquote")) { + return (ast as MalList).elements[1]; + } else if (ast is MalList) { + return qq_loop(ast.elements); + } else if (ast is MalVector) { + return new MalList([new MalSymbol("vec"), qq_loop(ast.elements)]); + } else if (ast is MalSymbol || ast is MalHashMap) { + return new MalList([new MalSymbol("quote"), ast]); + } else { + return ast; + } +} + +MalType READ(String x) => reader.read_str(x); + +MalType eval_ast(MalType ast, Env env) { + if (ast is MalSymbol) { + return env.get(ast); + } else if (ast is MalList) { + return new MalList(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalVector) { + return new MalVector(ast.elements.map((x) => EVAL(x, env)).toList()); + } else if (ast is MalHashMap) { + var newMap = new Map.from(ast.value); + for (var key in newMap.keys) { + newMap[key] = EVAL(newMap[key], env); + } + return new MalHashMap(newMap); + } else { + return ast; + } +} + +MalType EVAL(MalType ast, Env env) { + while (true) { + if (ast is! MalList) { + return eval_ast(ast, env); + } else { + if ((ast as MalList).elements.isEmpty) { + return ast; + } else { + ast = macroexpand(ast, env); + if (ast is! MalList) return eval_ast(ast, env); + if ((ast as MalList).isEmpty) return ast; + + var list = ast as MalList; + + if (list.elements.first is MalSymbol) { + var symbol = list.elements.first as MalSymbol; + var args = list.elements.sublist(1); + if (symbol.value == "def!") { + MalSymbol key = args.first; + MalType value = EVAL(args[1], env); + env.set(key, value); + return value; + } else if (symbol.value == "defmacro!") { + MalSymbol key = args.first; + MalClosure macro = EVAL(args[1], env) as MalClosure; + macro.isMacro = true; + env.set(key, macro); + return macro; + } else if (symbol.value == "let*") { + // TODO(het): If elements.length is not even, give helpful error + Iterable> pairs(List elements) sync* { + for (var i = 0; i < elements.length; i += 2) { + yield [elements[i], elements[i + 1]]; + } + } + + var newEnv = new Env(env); + MalIterable bindings = args.first; + for (var pair in pairs(bindings.elements)) { + MalSymbol key = pair[0]; + MalType value = EVAL(pair[1], newEnv); + newEnv.set(key, value); + } + ast = args[1]; + env = newEnv; + continue; + } else if (symbol.value == "do") { + eval_ast(new MalList(args.sublist(0, args.length - 1)), env); + ast = args.last; + continue; + } else if (symbol.value == "if") { + var condition = EVAL(args[0], env); + if (condition is MalNil || + condition is MalBool && condition.value == false) { + // False side of branch + if (args.length < 3) { + return new MalNil(); + } + ast = args[2]; + continue; + } else { + // True side of branch + ast = args[1]; + continue; + } + } else if (symbol.value == "fn*") { + var params = (args[0] as MalIterable) + .elements + .map((e) => e as MalSymbol) + .toList(); + return new MalClosure( + params, + args[1], + env, + (List funcArgs) => + EVAL(args[1], new Env(env, params, funcArgs))); + } else if (symbol.value == "quote") { + return args.single; + } else if (symbol.value == "quasiquoteexpand") { + return quasiquote(args.first); + } else if (symbol.value == "quasiquote") { + ast = quasiquote(args.first); + continue; + } else if (symbol.value == 'macroexpand') { + return macroexpand(args.first, env); + } else if (symbol.value == 'try*') { + var body = args.first; + if (args.length < 2) { + ast = EVAL(body, env); + continue; + } + var catchClause = args[1] as MalList; + try { + ast = EVAL(body, env); + } catch (e) { + assert((catchClause.first as MalSymbol).value == 'catch*'); + var exceptionSymbol = catchClause[1] as MalSymbol; + var catchBody = catchClause[2]; + MalType exceptionValue; + if (e is MalException) { + exceptionValue = e.value; + } else if (e is reader.ParseException) { + exceptionValue = new MalString(e.message); + } else { + exceptionValue = new MalString(e.toString()); + } + var newEnv = new Env(env, [exceptionSymbol], [exceptionValue]); + ast = EVAL(catchBody, newEnv); + } + continue; + } + } + var newAst = eval_ast(ast, env) as MalList; + var f = newAst.elements.first; + var args = newAst.elements.sublist(1); + if (f is MalBuiltin) { + return f.call(args); + } else if (f is MalClosure) { + ast = f.ast; + env = new Env(f.env, f.params, args); + continue; + } else { + throw 'bad!'; + } + } + } + } +} + +String PRINT(MalType x) => printer.pr_str(x); + +String rep(String x) { + return PRINT(EVAL(READ(x), replEnv)); +} + +const prompt = 'user> '; +main(List args) { + setupEnv(args.isEmpty ? const [] : args.sublist(1)); + if (args.isNotEmpty) { + rep("(load-file \"${args.first}\")"); + return; + } + rep("(println (str \"Mal [\" *host-language* \"]\"))"); + while (true) { + stdout.write(prompt); + var input = stdin.readLineSync(); + if (input == null) return; + var output; + try { + output = rep(input); + } on reader.ParseException catch (e) { + stdout.writeln("Error: '${e.message}'"); + continue; + } on NotFoundException catch (e) { + stdout.writeln("Error: '${e.value}' not found"); + continue; + } on MalException catch (e) { + stdout.writeln("Error: ${printer.pr_str(e.value)}"); + continue; + } on reader.NoInputException { + continue; + } + stdout.writeln(output); + } +} diff --git a/impls/dart/types.dart b/impls/dart/types.dart index 5d757b0acb..d71b6cc227 100644 --- a/impls/dart/types.dart +++ b/impls/dart/types.dart @@ -1,270 +1,270 @@ -import 'dart:collection'; -import 'env.dart'; - -abstract class MalType { - bool get isMacro => false; - MalType meta; - - MalType clone(); -} - -abstract class MalIterable extends MalType - with ListMixin - implements List { - final List elements; - - MalIterable(this.elements); - - MalType operator [](int index) => elements[index]; - void operator []=(int index, MalType value) { - elements[index] = value; - } - - int get length => elements.length; - void set length(int newLength) { - elements.length = newLength; - } - - bool operator ==(other) { - if (other is! MalIterable) return false; - - // apparently (= (list) nil) should be false... - if (other is MalNil) return false; - - if (elements.length != other.elements.length) return false; - for (var i = 0; i < elements.length; i++) { - if (elements[i] != other.elements[i]) return false; - } - return true; - } - - @override - MalIterable clone(); -} - -class MalList extends MalIterable { - MalList(List elements) : super(elements); - - @override - MalList clone() { - return new MalList(elements.toList()); - } -} - -class MalVector extends MalIterable { - MalVector(List elements) : super(elements); - - @override - MalVector clone() { - return new MalVector(elements.toList()); - } -} - -class MalHashMap extends MalType { - final Map value; - - MalHashMap(this.value); - - MalHashMap.fromSequence(List elements) - : value = _mapFromSequence(elements); - - static Map _mapFromSequence(List elements) { - var result = {}; - - var readingKey = true; - MalType pendingKey; - for (var malType in elements) { - if (readingKey) { - if (malType is MalString || malType is MalKeyword) { - pendingKey = malType; - } else { - throw new ArgumentError('hash-map keys must be strings or keywords'); - } - } else { - result[pendingKey] = malType; - } - readingKey = !readingKey; - } - - return result; - } - - bool operator ==(other) { - if (other is! MalHashMap) return false; - var otherMap = (other as MalHashMap).value; - if (otherMap.length != value.length) return false; - for (var key in value.keys) { - if (!otherMap.containsKey(key)) return false; - if (value[key] != otherMap[key]) return false; - } - return true; - } - - @override - MalHashMap clone() { - return new MalHashMap(new Map.from(value)); - } -} - -class MalInt extends MalType { - final int value; - - MalInt(this.value); - - bool operator ==(other) { - if (other is! MalInt) return false; - return other.value == value; - } - - @override - MalInt clone() { - return new MalInt(value); - } -} - -class MalSymbol extends MalType { - final String value; - - MalSymbol(this.value); - - int get hashCode => value.hashCode; - - bool operator ==(other) { - if (other is! MalSymbol) return false; - return value == other.value; - } - - @override - MalSymbol clone() { - return new MalSymbol(value); - } -} - -class MalKeyword extends MalType { - final String value; - - MalKeyword(this.value); - - int get hashCode => value.hashCode; - - bool operator ==(other) { - if (other is! MalKeyword) return false; - return value == other.value; - } - - @override - MalKeyword clone() { - return new MalKeyword(value); - } -} - -class MalString extends MalType { - final String value; - - MalString(this.value); - - int get hashCode => value.hashCode; - - bool operator ==(other) { - if (other is! MalString) return false; - return other.value == value; - } - - @override - MalString clone() { - return new MalString(value); - } -} - -class MalBool extends MalType { - final bool value; - - MalBool(this.value); - - bool operator ==(other) { - if (other is! MalBool) return false; - return other.value == value; - } - - @override - MalBool clone() { - return new MalBool(value); - } -} - -class MalNil extends MalIterable { - MalNil() : super(const []); - - bool operator ==(other) => other is MalNil; - - @override - MalNil clone() { - return new MalNil(); - } -} - -class MalAtom extends MalType { - MalType value; - - MalAtom(this.value); - - @override - MalAtom clone() { - return new MalAtom(value); - } -} - -abstract class MalCallable extends MalType { - MalType call(List args); - - bool get isMacro => false; -} - -typedef MalType BuiltinFunc(List args); - -class MalBuiltin extends MalCallable { - final BuiltinFunc func; - - MalBuiltin(this.func); - - MalType call(List args) { - return func(args); - } - - @override - MalBuiltin clone() { - return new MalBuiltin(func); - } -} - -typedef MalType EvalFun(MalType ast, Env env); - -class MalClosure extends MalCallable { - final List params; - final MalType ast; - final Env env; - final Function func; - - @override - bool isMacro = false; - - MalClosure(this.params, this.ast, this.env, this.func); - - MalType call(List args) { - return func(args); - } - - @override - MalClosure clone() { - var closure = - new MalClosure(this.params.toList(), this.ast, this.env, this.func); - closure.isMacro = this.isMacro; - return closure; - } -} - -class MalException implements Exception { - final MalType value; - - MalException(this.value); -} +import 'dart:collection'; +import 'env.dart'; + +abstract class MalType { + bool get isMacro => false; + MalType meta; + + MalType clone(); +} + +abstract class MalIterable extends MalType + with ListMixin + implements List { + final List elements; + + MalIterable(this.elements); + + MalType operator [](int index) => elements[index]; + void operator []=(int index, MalType value) { + elements[index] = value; + } + + int get length => elements.length; + void set length(int newLength) { + elements.length = newLength; + } + + bool operator ==(other) { + if (other is! MalIterable) return false; + + // apparently (= (list) nil) should be false... + if (other is MalNil) return false; + + if (elements.length != other.elements.length) return false; + for (var i = 0; i < elements.length; i++) { + if (elements[i] != other.elements[i]) return false; + } + return true; + } + + @override + MalIterable clone(); +} + +class MalList extends MalIterable { + MalList(List elements) : super(elements); + + @override + MalList clone() { + return new MalList(elements.toList()); + } +} + +class MalVector extends MalIterable { + MalVector(List elements) : super(elements); + + @override + MalVector clone() { + return new MalVector(elements.toList()); + } +} + +class MalHashMap extends MalType { + final Map value; + + MalHashMap(this.value); + + MalHashMap.fromSequence(List elements) + : value = _mapFromSequence(elements); + + static Map _mapFromSequence(List elements) { + var result = {}; + + var readingKey = true; + MalType pendingKey; + for (var malType in elements) { + if (readingKey) { + if (malType is MalString || malType is MalKeyword) { + pendingKey = malType; + } else { + throw new ArgumentError('hash-map keys must be strings or keywords'); + } + } else { + result[pendingKey] = malType; + } + readingKey = !readingKey; + } + + return result; + } + + bool operator ==(other) { + if (other is! MalHashMap) return false; + var otherMap = (other as MalHashMap).value; + if (otherMap.length != value.length) return false; + for (var key in value.keys) { + if (!otherMap.containsKey(key)) return false; + if (value[key] != otherMap[key]) return false; + } + return true; + } + + @override + MalHashMap clone() { + return new MalHashMap(new Map.from(value)); + } +} + +class MalInt extends MalType { + final int value; + + MalInt(this.value); + + bool operator ==(other) { + if (other is! MalInt) return false; + return other.value == value; + } + + @override + MalInt clone() { + return new MalInt(value); + } +} + +class MalSymbol extends MalType { + final String value; + + MalSymbol(this.value); + + int get hashCode => value.hashCode; + + bool operator ==(other) { + if (other is! MalSymbol) return false; + return value == other.value; + } + + @override + MalSymbol clone() { + return new MalSymbol(value); + } +} + +class MalKeyword extends MalType { + final String value; + + MalKeyword(this.value); + + int get hashCode => value.hashCode; + + bool operator ==(other) { + if (other is! MalKeyword) return false; + return value == other.value; + } + + @override + MalKeyword clone() { + return new MalKeyword(value); + } +} + +class MalString extends MalType { + final String value; + + MalString(this.value); + + int get hashCode => value.hashCode; + + bool operator ==(other) { + if (other is! MalString) return false; + return other.value == value; + } + + @override + MalString clone() { + return new MalString(value); + } +} + +class MalBool extends MalType { + final bool value; + + MalBool(this.value); + + bool operator ==(other) { + if (other is! MalBool) return false; + return other.value == value; + } + + @override + MalBool clone() { + return new MalBool(value); + } +} + +class MalNil extends MalIterable { + MalNil() : super(const []); + + bool operator ==(other) => other is MalNil; + + @override + MalNil clone() { + return new MalNil(); + } +} + +class MalAtom extends MalType { + MalType value; + + MalAtom(this.value); + + @override + MalAtom clone() { + return new MalAtom(value); + } +} + +abstract class MalCallable extends MalType { + MalType call(List args); + + bool get isMacro => false; +} + +typedef MalType BuiltinFunc(List args); + +class MalBuiltin extends MalCallable { + final BuiltinFunc func; + + MalBuiltin(this.func); + + MalType call(List args) { + return func(args); + } + + @override + MalBuiltin clone() { + return new MalBuiltin(func); + } +} + +typedef MalType EvalFun(MalType ast, Env env); + +class MalClosure extends MalCallable { + final List params; + final MalType ast; + final Env env; + final Function func; + + @override + bool isMacro = false; + + MalClosure(this.params, this.ast, this.env, this.func); + + MalType call(List args) { + return func(args); + } + + @override + MalClosure clone() { + var closure = + new MalClosure(this.params.toList(), this.ast, this.env, this.func); + closure.isMacro = this.isMacro; + return closure; + } +} + +class MalException implements Exception { + final MalType value; + + MalException(this.value); +} diff --git a/impls/elisp/Dockerfile b/impls/elisp/Dockerfile index 1eefd6c0c8..231c8a4907 100644 --- a/impls/elisp/Dockerfile +++ b/impls/elisp/Dockerfile @@ -1,26 +1,26 @@ -FROM ubuntu:wily -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Emacs 24 -RUN apt-get -y install emacs24-nox - +FROM ubuntu:wily +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Emacs 24 +RUN apt-get -y install emacs24-nox + diff --git a/impls/elisp/Makefile b/impls/elisp/Makefile index 7af3113c71..14414a8c2b 100644 --- a/impls/elisp/Makefile +++ b/impls/elisp/Makefile @@ -1,3 +1,3 @@ -all: - -clean: +all: + +clean: diff --git a/impls/elisp/mal/core.el b/impls/elisp/mal/core.el index f079bc4009..4acae72398 100644 --- a/impls/elisp/mal/core.el +++ b/impls/elisp/mal/core.el @@ -1,234 +1,234 @@ -(require 'cl-lib) - -(defun mal-seq-p (mal-object) - (memq (mal-type mal-object) '(list vector))) - -(defun mal-listify (mal-object) - (cl-ecase (mal-type mal-object) - (list (mal-value mal-object)) - (vector (append (mal-value mal-object) nil)))) - -(defun mal-= (a b) - (cl-case (mal-type a) - ((list vector) (and (mal-seq-p b) - (mal-seq-= (mal-listify a) (mal-listify b)))) - (map (and (mal-map-p b) - (mal-map-= (mal-value a) (mal-value b)))) - (t (equal (mal-value a) (mal-value b))))) - -(defun mal-seq-= (a b) - (if a - (and b - (mal-= (car a) (car b)) - (mal-seq-= (cdr a) (cdr b))) - (null b))) - -(defun mal-map-= (a b) - (when (= (hash-table-count a) - (hash-table-count b)) - (catch 'return - (maphash (lambda (key a-value) - (let ((b-value (gethash key b))) - (unless (and b-value - (mal-= a-value b-value)) - (throw 'return nil)))) - a) - ;; if we made it this far, the maps are equal - t))) - -(define-hash-table-test 'mal-= 'mal-= 'sxhash) - -(defun mal-conj (seq &rest args) - (let ((value (mal-value seq))) - (cl-ecase (mal-type seq) - (vector - (mal-vector (vconcat (append (append value nil) args)))) - (list - (while args - (push (pop args) value)) - (mal-list value))))) - -(defun elisp-to-mal (arg) - (cond - ((not arg) - mal-nil) - ((eq arg t) - mal-true) - ((numberp arg) - (mal-number arg)) - ((stringp arg) - (mal-string arg)) - ((keywordp arg) - (mal-keyword arg)) - ((symbolp arg) - (mal-symbol arg)) - ((consp arg) - (mal-list (mapcar 'elisp-to-mal arg))) - ((vectorp arg) - (mal-vector (vconcat (mapcar 'elisp-to-mal arg)))) - ((hash-table-p arg) - (let ((output (make-hash-table :test 'mal-=))) - (maphash - (lambda (key value) - (puthash (elisp-to-mal key) (elisp-to-mal value) output)) - arg) - (mal-map output))) - (t - ;; represent anything else as printed arg - (mal-string (format "%S" arg))))) - -(defvar core-ns - `((+ . ,(mal-fn (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))) - (- . ,(mal-fn (lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))) - (* . ,(mal-fn (lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))) - (/ . ,(mal-fn (lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))) - - (< . ,(mal-fn (lambda (a b) (if (< (mal-value a) (mal-value b)) mal-true mal-false)))) - (<= . ,(mal-fn (lambda (a b) (if (<= (mal-value a) (mal-value b)) mal-true mal-false)))) - (> . ,(mal-fn (lambda (a b) (if (> (mal-value a) (mal-value b)) mal-true mal-false)))) - (>= . ,(mal-fn (lambda (a b) (if (>= (mal-value a) (mal-value b)) mal-true mal-false)))) - - (= . ,(mal-fn (lambda (a b) (if (mal-= a b) mal-true mal-false)))) - - (list . ,(mal-fn (lambda (&rest args) (mal-list args)))) - (list? . ,(mal-fn (lambda (mal-object) (if (mal-list-p mal-object) mal-true mal-false)))) - (empty? . ,(mal-fn (lambda (seq) (if (zerop (length (mal-value seq))) mal-true mal-false)))) - (count . ,(mal-fn (lambda (seq) (mal-number (if (mal-seq-p seq) (length (mal-value seq)) 0))))) - - (pr-str . ,(mal-fn (lambda (&rest args) (mal-string (mapconcat (lambda (item) (pr-str item t)) args " "))))) - (str . ,(mal-fn (lambda (&rest args) (mal-string (mapconcat 'pr-str args ""))))) - (prn . ,(mal-fn (lambda (&rest args) (println (mapconcat (lambda (item) (pr-str item t)) args " ")) mal-nil))) - (println . ,(mal-fn (lambda (&rest args) (println (mapconcat 'pr-str args " ")) mal-nil))) - - (read-string . ,(mal-fn (lambda (input) (read-str (mal-value input))))) - (slurp . ,(mal-fn (lambda (file) - (with-temp-buffer - (insert-file-contents-literally (mal-value file)) - (mal-string (buffer-string)))))) - - (atom . ,(mal-fn (lambda (arg) (mal-atom arg)))) - (atom? . ,(mal-fn (lambda (mal-object) (if (mal-atom-p mal-object) mal-true mal-false)))) - (deref . ,(mal-fn (lambda (atom) (mal-value atom)))) - (reset! . ,(mal-fn (lambda (atom value) (setf (aref atom 1) value)))) - (swap! . ,(mal-fn (lambda (atom fn &rest args) - (let* ((fn* (if (mal-func-p fn) (mal-func-fn fn) fn)) - (args* (cons (mal-value atom) args)) - (value (apply (mal-value fn*) args*))) - (setf (aref atom 1) value))))) - - (vec . ,(mal-fn (lambda (seq) (if (mal-vector-p seq) seq (mal-vector (mal-value seq)))))) - (cons . ,(mal-fn (lambda (arg list) (mal-list (cons arg (mal-listify list)))))) - (concat . ,(mal-fn (lambda (&rest lists) - (let ((lists* (mapcar (lambda (item) (mal-listify item)) lists))) - (mal-list (apply 'append lists*)))))) - - (nth . ,(mal-fn (lambda (seq index) - (let ((i (mal-value index)) - (list (mal-listify seq))) - (or (nth i list) - (error "Args out of range: %s, %d" (pr-str seq) i)))))) - (first . ,(mal-fn (lambda (seq) - (if (mal-nil-p seq) - mal-nil - (or (car (mal-listify seq)) mal-nil))))) - (rest . ,(mal-fn (lambda (seq) (mal-list (unless (mal-nil-p seq) (cdr (mal-listify seq))))))) - - (throw . ,(mal-fn (lambda (mal-object) (signal 'mal-custom (list mal-object))))) - - (apply . ,(mal-fn (lambda (fn &rest args) - (let* ((butlast (butlast args)) - (last (mal-listify (car (last args)))) - (fn* (if (mal-func-p fn) (mal-func-fn fn) fn)) - (args* (append butlast last))) - (apply (mal-value fn*) args*))))) - (map . ,(mal-fn (lambda (fn seq) - (let ((fn* (if (mal-func-p fn) (mal-func-fn fn) fn))) - (mal-list (mapcar (mal-value fn*) (mal-value seq))))))) - - (nil? . ,(mal-fn (lambda (arg) (if (mal-nil-p arg) mal-true mal-false)))) - (true? . ,(mal-fn (lambda (arg) (if (mal-true-p arg) mal-true mal-false)))) - (false? . ,(mal-fn (lambda (arg) (if (mal-false-p arg) mal-true mal-false)))) - - (number? . ,(mal-fn (lambda (arg) (if (mal-number-p arg) mal-true mal-false)))) - (symbol? . ,(mal-fn (lambda (arg) (if (mal-symbol-p arg) mal-true mal-false)))) - (keyword? . ,(mal-fn (lambda (arg) (if (mal-keyword-p arg) mal-true mal-false)))) - (string? . ,(mal-fn (lambda (arg) (if (mal-string-p arg) mal-true mal-false)))) - (vector? . ,(mal-fn (lambda (arg) (if (mal-vector-p arg) mal-true mal-false)))) - (map? . ,(mal-fn (lambda (arg) (if (mal-map-p arg) mal-true mal-false)))) - - (symbol . ,(mal-fn (lambda (string) (mal-symbol (intern (mal-value string)))))) - (keyword . ,(mal-fn (lambda (x) (if (mal-keyword-p x) x (mal-keyword (intern (concat ":" (mal-value x)))))))) - (vector . ,(mal-fn (lambda (&rest args) (mal-vector (vconcat args))))) - (hash-map . ,(mal-fn (lambda (&rest args) - (let ((map (make-hash-table :test 'mal-=))) - (while args - (puthash (pop args) (pop args) map)) - (mal-map map))))) - - (sequential? . ,(mal-fn (lambda (mal-object) (if (mal-seq-p mal-object) mal-true mal-false)))) - (fn? . ,(mal-fn (lambda (arg) (if (or (mal-fn-p arg) - (and (mal-func-p arg) - (not (mal-func-macro-p arg)))) - mal-true - mal-false)))) - (macro? . ,(mal-fn (lambda (arg) (if (and (mal-func-p arg) - (mal-func-macro-p arg)) - mal-true - mal-false)))) - - (get . ,(mal-fn (lambda (map key) (if (mal-map-p map) (or (gethash key (mal-value map)) mal-nil) mal-nil)))) - (contains? . ,(mal-fn (lambda (map key) (if (gethash key (mal-value map)) mal-true mal-false)))) - (assoc . ,(mal-fn (lambda (map &rest args) - (let ((map* (copy-hash-table (mal-value map)))) - (while args - (puthash (pop args) (pop args) map*)) - (mal-map map*))))) - (dissoc . ,(mal-fn (lambda (map &rest args) - (let ((map* (copy-hash-table (mal-value map)))) - (while args - (remhash (pop args) map*)) - (mal-map map*))))) - (keys . ,(mal-fn (lambda (map) (let (keys) - (maphash (lambda (key value) (push key keys)) - (mal-value map)) - (mal-list keys))))) - (vals . ,(mal-fn (lambda (map) (let (vals) - (maphash (lambda (key value) (push value vals)) - (mal-value map)) - (mal-list vals))))) - - (readline . ,(mal-fn (lambda (prompt) - (let ((ret (readln (mal-value prompt)))) - (if ret - (mal-string ret) - mal-nil))))) - - (meta . ,(mal-fn (lambda (mal-object) (or (mal-meta mal-object) mal-nil)))) - (with-meta . ,(mal-fn (lambda (mal-object meta) - (let ((mal-object* (copy-sequence mal-object))) - (setf (aref mal-object* 2) meta) - mal-object*)))) - - (time-ms . ,(mal-fn (lambda () (mal-number (floor (* (float-time) 1000)))))) - - (conj . ,(mal-fn 'mal-conj)) - (seq . ,(mal-fn (lambda (mal-object) - (let ((type (mal-type mal-object)) - (value (mal-value mal-object))) - (cond - ((or (eq type 'list) (eq type 'vector)) - (if (and value (not (zerop (length value)))) - (mal-list (mal-listify mal-object)) - mal-nil)) - ((eq type 'string) - (if (not (zerop (length value))) - (mal-list (mapcar (lambda (item) (mal-string (char-to-string item))) - (append value nil))) - mal-nil)) - (t - mal-nil)))))) - - (elisp-eval . ,(mal-fn (lambda (string) (elisp-to-mal (eval (read (mal-value string))))))) - )) - -(provide 'mal/core) +(require 'cl-lib) + +(defun mal-seq-p (mal-object) + (memq (mal-type mal-object) '(list vector))) + +(defun mal-listify (mal-object) + (cl-ecase (mal-type mal-object) + (list (mal-value mal-object)) + (vector (append (mal-value mal-object) nil)))) + +(defun mal-= (a b) + (cl-case (mal-type a) + ((list vector) (and (mal-seq-p b) + (mal-seq-= (mal-listify a) (mal-listify b)))) + (map (and (mal-map-p b) + (mal-map-= (mal-value a) (mal-value b)))) + (t (equal (mal-value a) (mal-value b))))) + +(defun mal-seq-= (a b) + (if a + (and b + (mal-= (car a) (car b)) + (mal-seq-= (cdr a) (cdr b))) + (null b))) + +(defun mal-map-= (a b) + (when (= (hash-table-count a) + (hash-table-count b)) + (catch 'return + (maphash (lambda (key a-value) + (let ((b-value (gethash key b))) + (unless (and b-value + (mal-= a-value b-value)) + (throw 'return nil)))) + a) + ;; if we made it this far, the maps are equal + t))) + +(define-hash-table-test 'mal-= 'mal-= 'sxhash) + +(defun mal-conj (seq &rest args) + (let ((value (mal-value seq))) + (cl-ecase (mal-type seq) + (vector + (mal-vector (vconcat (append (append value nil) args)))) + (list + (while args + (push (pop args) value)) + (mal-list value))))) + +(defun elisp-to-mal (arg) + (cond + ((not arg) + mal-nil) + ((eq arg t) + mal-true) + ((numberp arg) + (mal-number arg)) + ((stringp arg) + (mal-string arg)) + ((keywordp arg) + (mal-keyword arg)) + ((symbolp arg) + (mal-symbol arg)) + ((consp arg) + (mal-list (mapcar 'elisp-to-mal arg))) + ((vectorp arg) + (mal-vector (vconcat (mapcar 'elisp-to-mal arg)))) + ((hash-table-p arg) + (let ((output (make-hash-table :test 'mal-=))) + (maphash + (lambda (key value) + (puthash (elisp-to-mal key) (elisp-to-mal value) output)) + arg) + (mal-map output))) + (t + ;; represent anything else as printed arg + (mal-string (format "%S" arg))))) + +(defvar core-ns + `((+ . ,(mal-fn (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))) + (- . ,(mal-fn (lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))) + (* . ,(mal-fn (lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))) + (/ . ,(mal-fn (lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))) + + (< . ,(mal-fn (lambda (a b) (if (< (mal-value a) (mal-value b)) mal-true mal-false)))) + (<= . ,(mal-fn (lambda (a b) (if (<= (mal-value a) (mal-value b)) mal-true mal-false)))) + (> . ,(mal-fn (lambda (a b) (if (> (mal-value a) (mal-value b)) mal-true mal-false)))) + (>= . ,(mal-fn (lambda (a b) (if (>= (mal-value a) (mal-value b)) mal-true mal-false)))) + + (= . ,(mal-fn (lambda (a b) (if (mal-= a b) mal-true mal-false)))) + + (list . ,(mal-fn (lambda (&rest args) (mal-list args)))) + (list? . ,(mal-fn (lambda (mal-object) (if (mal-list-p mal-object) mal-true mal-false)))) + (empty? . ,(mal-fn (lambda (seq) (if (zerop (length (mal-value seq))) mal-true mal-false)))) + (count . ,(mal-fn (lambda (seq) (mal-number (if (mal-seq-p seq) (length (mal-value seq)) 0))))) + + (pr-str . ,(mal-fn (lambda (&rest args) (mal-string (mapconcat (lambda (item) (pr-str item t)) args " "))))) + (str . ,(mal-fn (lambda (&rest args) (mal-string (mapconcat 'pr-str args ""))))) + (prn . ,(mal-fn (lambda (&rest args) (println (mapconcat (lambda (item) (pr-str item t)) args " ")) mal-nil))) + (println . ,(mal-fn (lambda (&rest args) (println (mapconcat 'pr-str args " ")) mal-nil))) + + (read-string . ,(mal-fn (lambda (input) (read-str (mal-value input))))) + (slurp . ,(mal-fn (lambda (file) + (with-temp-buffer + (insert-file-contents-literally (mal-value file)) + (mal-string (buffer-string)))))) + + (atom . ,(mal-fn (lambda (arg) (mal-atom arg)))) + (atom? . ,(mal-fn (lambda (mal-object) (if (mal-atom-p mal-object) mal-true mal-false)))) + (deref . ,(mal-fn (lambda (atom) (mal-value atom)))) + (reset! . ,(mal-fn (lambda (atom value) (setf (aref atom 1) value)))) + (swap! . ,(mal-fn (lambda (atom fn &rest args) + (let* ((fn* (if (mal-func-p fn) (mal-func-fn fn) fn)) + (args* (cons (mal-value atom) args)) + (value (apply (mal-value fn*) args*))) + (setf (aref atom 1) value))))) + + (vec . ,(mal-fn (lambda (seq) (if (mal-vector-p seq) seq (mal-vector (mal-value seq)))))) + (cons . ,(mal-fn (lambda (arg list) (mal-list (cons arg (mal-listify list)))))) + (concat . ,(mal-fn (lambda (&rest lists) + (let ((lists* (mapcar (lambda (item) (mal-listify item)) lists))) + (mal-list (apply 'append lists*)))))) + + (nth . ,(mal-fn (lambda (seq index) + (let ((i (mal-value index)) + (list (mal-listify seq))) + (or (nth i list) + (error "Args out of range: %s, %d" (pr-str seq) i)))))) + (first . ,(mal-fn (lambda (seq) + (if (mal-nil-p seq) + mal-nil + (or (car (mal-listify seq)) mal-nil))))) + (rest . ,(mal-fn (lambda (seq) (mal-list (unless (mal-nil-p seq) (cdr (mal-listify seq))))))) + + (throw . ,(mal-fn (lambda (mal-object) (signal 'mal-custom (list mal-object))))) + + (apply . ,(mal-fn (lambda (fn &rest args) + (let* ((butlast (butlast args)) + (last (mal-listify (car (last args)))) + (fn* (if (mal-func-p fn) (mal-func-fn fn) fn)) + (args* (append butlast last))) + (apply (mal-value fn*) args*))))) + (map . ,(mal-fn (lambda (fn seq) + (let ((fn* (if (mal-func-p fn) (mal-func-fn fn) fn))) + (mal-list (mapcar (mal-value fn*) (mal-value seq))))))) + + (nil? . ,(mal-fn (lambda (arg) (if (mal-nil-p arg) mal-true mal-false)))) + (true? . ,(mal-fn (lambda (arg) (if (mal-true-p arg) mal-true mal-false)))) + (false? . ,(mal-fn (lambda (arg) (if (mal-false-p arg) mal-true mal-false)))) + + (number? . ,(mal-fn (lambda (arg) (if (mal-number-p arg) mal-true mal-false)))) + (symbol? . ,(mal-fn (lambda (arg) (if (mal-symbol-p arg) mal-true mal-false)))) + (keyword? . ,(mal-fn (lambda (arg) (if (mal-keyword-p arg) mal-true mal-false)))) + (string? . ,(mal-fn (lambda (arg) (if (mal-string-p arg) mal-true mal-false)))) + (vector? . ,(mal-fn (lambda (arg) (if (mal-vector-p arg) mal-true mal-false)))) + (map? . ,(mal-fn (lambda (arg) (if (mal-map-p arg) mal-true mal-false)))) + + (symbol . ,(mal-fn (lambda (string) (mal-symbol (intern (mal-value string)))))) + (keyword . ,(mal-fn (lambda (x) (if (mal-keyword-p x) x (mal-keyword (intern (concat ":" (mal-value x)))))))) + (vector . ,(mal-fn (lambda (&rest args) (mal-vector (vconcat args))))) + (hash-map . ,(mal-fn (lambda (&rest args) + (let ((map (make-hash-table :test 'mal-=))) + (while args + (puthash (pop args) (pop args) map)) + (mal-map map))))) + + (sequential? . ,(mal-fn (lambda (mal-object) (if (mal-seq-p mal-object) mal-true mal-false)))) + (fn? . ,(mal-fn (lambda (arg) (if (or (mal-fn-p arg) + (and (mal-func-p arg) + (not (mal-func-macro-p arg)))) + mal-true + mal-false)))) + (macro? . ,(mal-fn (lambda (arg) (if (and (mal-func-p arg) + (mal-func-macro-p arg)) + mal-true + mal-false)))) + + (get . ,(mal-fn (lambda (map key) (if (mal-map-p map) (or (gethash key (mal-value map)) mal-nil) mal-nil)))) + (contains? . ,(mal-fn (lambda (map key) (if (gethash key (mal-value map)) mal-true mal-false)))) + (assoc . ,(mal-fn (lambda (map &rest args) + (let ((map* (copy-hash-table (mal-value map)))) + (while args + (puthash (pop args) (pop args) map*)) + (mal-map map*))))) + (dissoc . ,(mal-fn (lambda (map &rest args) + (let ((map* (copy-hash-table (mal-value map)))) + (while args + (remhash (pop args) map*)) + (mal-map map*))))) + (keys . ,(mal-fn (lambda (map) (let (keys) + (maphash (lambda (key value) (push key keys)) + (mal-value map)) + (mal-list keys))))) + (vals . ,(mal-fn (lambda (map) (let (vals) + (maphash (lambda (key value) (push value vals)) + (mal-value map)) + (mal-list vals))))) + + (readline . ,(mal-fn (lambda (prompt) + (let ((ret (readln (mal-value prompt)))) + (if ret + (mal-string ret) + mal-nil))))) + + (meta . ,(mal-fn (lambda (mal-object) (or (mal-meta mal-object) mal-nil)))) + (with-meta . ,(mal-fn (lambda (mal-object meta) + (let ((mal-object* (copy-sequence mal-object))) + (setf (aref mal-object* 2) meta) + mal-object*)))) + + (time-ms . ,(mal-fn (lambda () (mal-number (floor (* (float-time) 1000)))))) + + (conj . ,(mal-fn 'mal-conj)) + (seq . ,(mal-fn (lambda (mal-object) + (let ((type (mal-type mal-object)) + (value (mal-value mal-object))) + (cond + ((or (eq type 'list) (eq type 'vector)) + (if (and value (not (zerop (length value)))) + (mal-list (mal-listify mal-object)) + mal-nil)) + ((eq type 'string) + (if (not (zerop (length value))) + (mal-list (mapcar (lambda (item) (mal-string (char-to-string item))) + (append value nil))) + mal-nil)) + (t + mal-nil)))))) + + (elisp-eval . ,(mal-fn (lambda (string) (elisp-to-mal (eval (read (mal-value string))))))) + )) + +(provide 'mal/core) diff --git a/impls/elisp/mal/env.el b/impls/elisp/mal/env.el index f03902976c..06ef15f2b5 100644 --- a/impls/elisp/mal/env.el +++ b/impls/elisp/mal/env.el @@ -1,34 +1,34 @@ -(defun mal-env (&optional outer binds exprs) - (let ((env (vector 'env (vector (make-hash-table :test 'eq) outer)))) - (while binds - (let ((key (pop binds))) - (if (eq key '&) - (let ((key (pop binds)) - (value (mal-list exprs))) - (mal-env-set env key value) - (setq binds nil - exprs nil)) - (let ((value (pop exprs))) - (mal-env-set env key value))))) - env)) - -(defun mal-env-set (env key value) - (let ((data (aref (aref env 1) 0))) - (puthash key value data))) - -(defun mal-env-find (env key) - (let* ((data (aref (aref env 1) 0)) - (value (gethash key data))) - (if (not value) - (let ((outer (aref (aref env 1) 1))) - (when outer - (mal-env-find outer key))) - value))) - -(defun mal-env-get (env key) - (let ((value (mal-env-find env key))) - (if (not value) - (error "'%s' not found" key) - value))) - -(provide 'mal/env) +(defun mal-env (&optional outer binds exprs) + (let ((env (vector 'env (vector (make-hash-table :test 'eq) outer)))) + (while binds + (let ((key (pop binds))) + (if (eq key '&) + (let ((key (pop binds)) + (value (mal-list exprs))) + (mal-env-set env key value) + (setq binds nil + exprs nil)) + (let ((value (pop exprs))) + (mal-env-set env key value))))) + env)) + +(defun mal-env-set (env key value) + (let ((data (aref (aref env 1) 0))) + (puthash key value data))) + +(defun mal-env-find (env key) + (let* ((data (aref (aref env 1) 0)) + (value (gethash key data))) + (if (not value) + (let ((outer (aref (aref env 1) 1))) + (when outer + (mal-env-find outer key))) + value))) + +(defun mal-env-get (env key) + (let ((value (mal-env-find env key))) + (if (not value) + (error "'%s' not found" key) + value))) + +(provide 'mal/env) diff --git a/impls/elisp/mal/func.el b/impls/elisp/mal/func.el index 8e4547ffda..309fb64c20 100644 --- a/impls/elisp/mal/func.el +++ b/impls/elisp/mal/func.el @@ -1,25 +1,25 @@ -(defun mal-func (ast params env fn) - (vector 'func (vector ast params env fn nil) nil)) - -(defun mal-macro (mal-func) - (let ((v (aref mal-func 1))) - (vector 'func - (vector (aref v 0) (aref v 1) (aref v 2) (aref v 3) t) - nil))) - -(defun mal-func-ast (mal-func) - (aref (aref mal-func 1) 0)) - -(defun mal-func-params (mal-func) - (aref (aref mal-func 1) 1)) - -(defun mal-func-env (mal-func) - (aref (aref mal-func 1) 2)) - -(defun mal-func-fn (mal-func) - (aref (aref mal-func 1) 3)) - -(defun mal-func-macro-p (mal-func) - (aref (aref mal-func 1) 4)) - -(provide 'mal/func) +(defun mal-func (ast params env fn) + (vector 'func (vector ast params env fn nil) nil)) + +(defun mal-macro (mal-func) + (let ((v (aref mal-func 1))) + (vector 'func + (vector (aref v 0) (aref v 1) (aref v 2) (aref v 3) t) + nil))) + +(defun mal-func-ast (mal-func) + (aref (aref mal-func 1) 0)) + +(defun mal-func-params (mal-func) + (aref (aref mal-func 1) 1)) + +(defun mal-func-env (mal-func) + (aref (aref mal-func 1) 2)) + +(defun mal-func-fn (mal-func) + (aref (aref mal-func 1) 3)) + +(defun mal-func-macro-p (mal-func) + (aref (aref mal-func 1) 4)) + +(provide 'mal/func) diff --git a/impls/elisp/mal/printer.el b/impls/elisp/mal/printer.el index 6e09f23cef..5567515c0b 100644 --- a/impls/elisp/mal/printer.el +++ b/impls/elisp/mal/printer.el @@ -1,59 +1,59 @@ -(require 'cl-lib) - -(defun pr-str (form &optional print-readably) - (let ((value (mal-value form))) - (cl-ecase (mal-type form) - ('nil - "nil") - (true - "true") - (false - "false") - (number - (number-to-string value)) - (string - (if print-readably - (let ((print-escape-newlines t)) - (prin1-to-string value)) - value)) - ((symbol keyword) - (symbol-name value)) - (list - (pr-list value print-readably)) - (vector - (pr-vector value print-readably)) - (map - (pr-map value print-readably)) - (fn - "#") - (func - "#") - (atom - (format "(atom %s)" (pr-str value print-readably)))))) - -(defun pr-list (form print-readably) - (let ((items (mapconcat - (lambda (item) (pr-str item print-readably)) - form " "))) - (concat "(" items ")"))) - -(defun pr-vector (form print-readably) - (let ((items (mapconcat - (lambda (item) (pr-str item print-readably)) - (append form nil) " "))) - (concat "[" items "]"))) - -(defun pr-map (form print-readably) - (let (pairs) - (maphash - (lambda (key value) - (push (cons (pr-str key print-readably) - (pr-str value print-readably)) - pairs)) - form) - (let ((items (mapconcat - (lambda (item) (concat (car item) " " (cdr item))) - (nreverse pairs) " "))) - (concat "{" items "}")))) - -(provide 'mal/printer) +(require 'cl-lib) + +(defun pr-str (form &optional print-readably) + (let ((value (mal-value form))) + (cl-ecase (mal-type form) + ('nil + "nil") + (true + "true") + (false + "false") + (number + (number-to-string value)) + (string + (if print-readably + (let ((print-escape-newlines t)) + (prin1-to-string value)) + value)) + ((symbol keyword) + (symbol-name value)) + (list + (pr-list value print-readably)) + (vector + (pr-vector value print-readably)) + (map + (pr-map value print-readably)) + (fn + "#") + (func + "#") + (atom + (format "(atom %s)" (pr-str value print-readably)))))) + +(defun pr-list (form print-readably) + (let ((items (mapconcat + (lambda (item) (pr-str item print-readably)) + form " "))) + (concat "(" items ")"))) + +(defun pr-vector (form print-readably) + (let ((items (mapconcat + (lambda (item) (pr-str item print-readably)) + (append form nil) " "))) + (concat "[" items "]"))) + +(defun pr-map (form print-readably) + (let (pairs) + (maphash + (lambda (key value) + (push (cons (pr-str key print-readably) + (pr-str value print-readably)) + pairs)) + form) + (let ((items (mapconcat + (lambda (item) (concat (car item) " " (cdr item))) + (nreverse pairs) " "))) + (concat "{" items "}")))) + +(provide 'mal/printer) diff --git a/impls/elisp/mal/reader.el b/impls/elisp/mal/reader.el index c8b92835fc..f170958e12 100644 --- a/impls/elisp/mal/reader.el +++ b/impls/elisp/mal/reader.el @@ -1,158 +1,158 @@ -(require 'cl-lib) - -;; HACK: `text-quoting-style' prettifies quotes in error messages on -;; Emacs 25, but no longer does from 26 upwards... -(when (= emacs-major-version 25) - (setq text-quoting-style 'grave)) - -(defvar tokens nil) - -(defun peek () - (car tokens)) - -(defun next () - (pop tokens)) - -(defun read-str (input) - (setq tokens (tokenizer input)) - (read-form)) - -(defun tokenizer (input) - (let (output) - (with-temp-buffer - (insert input) - (goto-char (point-min)) - (while (not (eobp)) - (when (looking-at token-re) - (let ((token (match-string 1))) - (if (= (length token) 0) - (let ((remainder (buffer-substring (point) (point-max)))) - (push remainder output) - (goto-char (point-max))) - (when (not (string-match-p comment-re token)) - (push token output)) - (goto-char (match-end 1)))))) - (nreverse output)))) - -(defun read-form () - (pcase (peek) - ("'" - (read-quote)) - ("`" - (read-quasiquote)) - ("~" - (read-unquote)) - ("~@" - (read-splice-unquote)) - ("@" - (read-deref)) - ("^" - (read-with-meta)) - ("(" - (read-list)) - ("[" - (read-vector)) - ("{" - (read-map)) - (_ - ;; assume anything else is an atom - (read-atom)))) - -(defun read-simple-reader-macro (symbol) - (next) ; pop reader macro token - ;; turn form into (symbol form) - (mal-list (list (mal-symbol symbol) (read-form)))) - -(defun read-quote () - (read-simple-reader-macro 'quote)) - -(defun read-quasiquote () - (read-simple-reader-macro 'quasiquote)) - -(defun read-unquote () - (read-simple-reader-macro 'unquote)) - -(defun read-splice-unquote () - (read-simple-reader-macro 'splice-unquote)) - -(defun read-deref () - (read-simple-reader-macro 'deref)) - -(defun read-with-meta () - (next) ; pop with-meta token - (let ((meta (read-form))) - (mal-list (list (mal-symbol 'with-meta) (read-form) meta)))) - -(defun read-list () - (next) ; pop list start - (let (output end-of-list) - (while (not end-of-list) - (let ((token (peek))) - (cond - ((string= token ")") - (next) ; pop list end - (setq end-of-list t)) - ((not token) - (signal 'unterminated-sequence '(list))) - (t - (push (read-form) output))))) - (mal-list (nreverse output)))) - -(defun read-vector () - (next) ; pop vector start - (let (output end-of-vector) - (while (not end-of-vector) - (let ((token (peek))) - (cond - ((string= token "]") - (next) ; pop vector end - (setq end-of-vector t)) - ((not token) - (signal 'unterminated-sequence '(vector))) - (t - (push (read-form) output))))) - (mal-vector (vconcat (nreverse output))))) - -;; HACK overriden by core.el in later steps -(define-hash-table-test 'mal-= 'equal 'sxhash) - -(defun read-map () - (next) ; pop map start - (let ((output (make-hash-table :test 'mal-=)) - end-of-map) - (while (not end-of-map) - (let ((token (peek))) - (cond - ((string= token "}") - (next) ; pop map end - (setq end-of-map t)) - ((not token) - (signal 'unterminated-sequence '(map))) - (t - (puthash (read-form) (read-form) output))))) - (mal-map output))) - -(defun read-atom () - (let ((token (next))) - (if token - (cond - ((string= token "nil") - mal-nil) - ((string= token "true") - mal-true) - ((string= token "false") - mal-false) - ((string-match number-re token) - (mal-number (string-to-number token))) - ((= (aref token 0) ?\") - (if (string-match string-re token) - (mal-string (read token)) - (signal 'unterminated-sequence '(string)))) - ((= (aref token 0) ?:) - (mal-keyword (intern token))) - (t - ;; assume anything else is a symbol - (mal-symbol (intern token)))) - (signal 'end-of-token-stream nil)))) - -(provide 'mal/reader) +(require 'cl-lib) + +;; HACK: `text-quoting-style' prettifies quotes in error messages on +;; Emacs 25, but no longer does from 26 upwards... +(when (= emacs-major-version 25) + (setq text-quoting-style 'grave)) + +(defvar tokens nil) + +(defun peek () + (car tokens)) + +(defun next () + (pop tokens)) + +(defun read-str (input) + (setq tokens (tokenizer input)) + (read-form)) + +(defun tokenizer (input) + (let (output) + (with-temp-buffer + (insert input) + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at token-re) + (let ((token (match-string 1))) + (if (= (length token) 0) + (let ((remainder (buffer-substring (point) (point-max)))) + (push remainder output) + (goto-char (point-max))) + (when (not (string-match-p comment-re token)) + (push token output)) + (goto-char (match-end 1)))))) + (nreverse output)))) + +(defun read-form () + (pcase (peek) + ("'" + (read-quote)) + ("`" + (read-quasiquote)) + ("~" + (read-unquote)) + ("~@" + (read-splice-unquote)) + ("@" + (read-deref)) + ("^" + (read-with-meta)) + ("(" + (read-list)) + ("[" + (read-vector)) + ("{" + (read-map)) + (_ + ;; assume anything else is an atom + (read-atom)))) + +(defun read-simple-reader-macro (symbol) + (next) ; pop reader macro token + ;; turn form into (symbol form) + (mal-list (list (mal-symbol symbol) (read-form)))) + +(defun read-quote () + (read-simple-reader-macro 'quote)) + +(defun read-quasiquote () + (read-simple-reader-macro 'quasiquote)) + +(defun read-unquote () + (read-simple-reader-macro 'unquote)) + +(defun read-splice-unquote () + (read-simple-reader-macro 'splice-unquote)) + +(defun read-deref () + (read-simple-reader-macro 'deref)) + +(defun read-with-meta () + (next) ; pop with-meta token + (let ((meta (read-form))) + (mal-list (list (mal-symbol 'with-meta) (read-form) meta)))) + +(defun read-list () + (next) ; pop list start + (let (output end-of-list) + (while (not end-of-list) + (let ((token (peek))) + (cond + ((string= token ")") + (next) ; pop list end + (setq end-of-list t)) + ((not token) + (signal 'unterminated-sequence '(list))) + (t + (push (read-form) output))))) + (mal-list (nreverse output)))) + +(defun read-vector () + (next) ; pop vector start + (let (output end-of-vector) + (while (not end-of-vector) + (let ((token (peek))) + (cond + ((string= token "]") + (next) ; pop vector end + (setq end-of-vector t)) + ((not token) + (signal 'unterminated-sequence '(vector))) + (t + (push (read-form) output))))) + (mal-vector (vconcat (nreverse output))))) + +;; HACK overriden by core.el in later steps +(define-hash-table-test 'mal-= 'equal 'sxhash) + +(defun read-map () + (next) ; pop map start + (let ((output (make-hash-table :test 'mal-=)) + end-of-map) + (while (not end-of-map) + (let ((token (peek))) + (cond + ((string= token "}") + (next) ; pop map end + (setq end-of-map t)) + ((not token) + (signal 'unterminated-sequence '(map))) + (t + (puthash (read-form) (read-form) output))))) + (mal-map output))) + +(defun read-atom () + (let ((token (next))) + (if token + (cond + ((string= token "nil") + mal-nil) + ((string= token "true") + mal-true) + ((string= token "false") + mal-false) + ((string-match number-re token) + (mal-number (string-to-number token))) + ((= (aref token 0) ?\") + (if (string-match string-re token) + (mal-string (read token)) + (signal 'unterminated-sequence '(string)))) + ((= (aref token 0) ?:) + (mal-keyword (intern token))) + (t + ;; assume anything else is a symbol + (mal-symbol (intern token)))) + (signal 'end-of-token-stream nil)))) + +(provide 'mal/reader) diff --git a/impls/elisp/mal/types.el b/impls/elisp/mal/types.el index e87e41c8d6..42c16d05f0 100644 --- a/impls/elisp/mal/types.el +++ b/impls/elisp/mal/types.el @@ -1,104 +1,104 @@ -;;; general accessors - -(defun mal-type (mal-object) - (aref mal-object 0)) - -(defun mal-value (mal-object) - (aref mal-object 1)) - -(defun mal-meta (mal-object) - (aref mal-object 2)) - -;;; objects - -(defmacro mal-object (name) - (let ((constructor (intern (format "mal-%s" name))) - (predicate (intern (format "mal-%s-p" name)))) - `(progn - (defun ,constructor (&optional value meta) - (vector ',name value meta)) - (defun ,predicate (arg) - (and (vectorp arg) (eq (aref arg 0) ',name)))))) - -(mal-object nil) -(mal-object true) -(mal-object false) - -(defvar mal-nil (mal-nil)) -(defvar mal-true (mal-true 'true)) -(defvar mal-false (mal-false 'false)) - -(mal-object number) -(mal-object string) -(mal-object symbol) -(mal-object keyword) - -(mal-object list) -(mal-object vector) -(mal-object map) - -(mal-object atom) -(mal-object fn) -(mal-object func) - -;;; regex - -(defvar token-re - (rx (* (any white ?,)) ;; leading whitespace - (group - (or - "~@" ;; special 2-char token - (any "[]{}()'`~^@") ;; special 1-char tokens - (and ?\" (* (or (and ?\\ anything) - (not (any "\\\"")))) - ?\") ;; string with escapes - (and ?\; (* not-newline)) ;; comment - (* (not (any white "[]{}()'\"`,;"))) ;; catch-all - )))) - -(defvar whitespace-re - (rx bos (* (any white ?,)) eos)) - -(defvar comment-re - (rx bos ?\; (* anything))) - -(defvar sequence-end-re - (rx bos (any ")]}") eos)) - -(defvar number-re - (rx bos (? (any "+-")) (+ (char digit)) eos)) - -(defvar string-re - (rx bos ?\" (* (or (and ?\\ anything) - (not (any "\\\"")))) - ?\" eos)) - -;;; errors - -(when (not (fboundp 'define-error)) - (defun define-error (name message &optional parent) - "Define NAME as a new error signal. -MESSAGE is a string that will be output to the echo area if such an error -is signaled without being caught by a `condition-case'. -PARENT is either a signal or a list of signals from which it inherits. -Defaults to `error'." - (unless parent (setq parent 'error)) - (let ((conditions - (if (consp parent) - (apply #'nconc - (mapcar (lambda (parent) - (cons parent - (or (get parent 'error-conditions) - (error "Unknown signal `%s'" parent)))) - parent)) - (cons parent (get parent 'error-conditions))))) - (put name 'error-conditions - (delete-dups (copy-sequence (cons name conditions)))) - (when message (put name 'error-message message))))) - -(define-error 'mal "MAL error") -(define-error 'unterminated-sequence "Unexpected end of input during token sequence" 'mal) -(define-error 'end-of-token-stream "End of token stream" 'mal) -(define-error 'mal-custom "Custom error" 'mal) - -(provide 'mal/types) +;;; general accessors + +(defun mal-type (mal-object) + (aref mal-object 0)) + +(defun mal-value (mal-object) + (aref mal-object 1)) + +(defun mal-meta (mal-object) + (aref mal-object 2)) + +;;; objects + +(defmacro mal-object (name) + (let ((constructor (intern (format "mal-%s" name))) + (predicate (intern (format "mal-%s-p" name)))) + `(progn + (defun ,constructor (&optional value meta) + (vector ',name value meta)) + (defun ,predicate (arg) + (and (vectorp arg) (eq (aref arg 0) ',name)))))) + +(mal-object nil) +(mal-object true) +(mal-object false) + +(defvar mal-nil (mal-nil)) +(defvar mal-true (mal-true 'true)) +(defvar mal-false (mal-false 'false)) + +(mal-object number) +(mal-object string) +(mal-object symbol) +(mal-object keyword) + +(mal-object list) +(mal-object vector) +(mal-object map) + +(mal-object atom) +(mal-object fn) +(mal-object func) + +;;; regex + +(defvar token-re + (rx (* (any white ?,)) ;; leading whitespace + (group + (or + "~@" ;; special 2-char token + (any "[]{}()'`~^@") ;; special 1-char tokens + (and ?\" (* (or (and ?\\ anything) + (not (any "\\\"")))) + ?\") ;; string with escapes + (and ?\; (* not-newline)) ;; comment + (* (not (any white "[]{}()'\"`,;"))) ;; catch-all + )))) + +(defvar whitespace-re + (rx bos (* (any white ?,)) eos)) + +(defvar comment-re + (rx bos ?\; (* anything))) + +(defvar sequence-end-re + (rx bos (any ")]}") eos)) + +(defvar number-re + (rx bos (? (any "+-")) (+ (char digit)) eos)) + +(defvar string-re + (rx bos ?\" (* (or (and ?\\ anything) + (not (any "\\\"")))) + ?\" eos)) + +;;; errors + +(when (not (fboundp 'define-error)) + (defun define-error (name message &optional parent) + "Define NAME as a new error signal. +MESSAGE is a string that will be output to the echo area if such an error +is signaled without being caught by a `condition-case'. +PARENT is either a signal or a list of signals from which it inherits. +Defaults to `error'." + (unless parent (setq parent 'error)) + (let ((conditions + (if (consp parent) + (apply #'nconc + (mapcar (lambda (parent) + (cons parent + (or (get parent 'error-conditions) + (error "Unknown signal `%s'" parent)))) + parent)) + (cons parent (get parent 'error-conditions))))) + (put name 'error-conditions + (delete-dups (copy-sequence (cons name conditions)))) + (when message (put name 'error-message message))))) + +(define-error 'mal "MAL error") +(define-error 'unterminated-sequence "Unexpected end of input during token sequence" 'mal) +(define-error 'end-of-token-stream "End of token stream" 'mal) +(define-error 'mal-custom "Custom error" 'mal) + +(provide 'mal/types) diff --git a/impls/elisp/run b/impls/elisp/run index c68e97bf93..6468c2fa10 100755 --- a/impls/elisp/run +++ b/impls/elisp/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec emacs -Q --batch -L $(dirname $0) --eval "(setq text-quoting-style 'straight)" --load $(dirname $0)/${STEP:-stepA_mal}.el "${@}" +#!/bin/bash +exec emacs -Q --batch -L $(dirname $0) --eval "(setq text-quoting-style 'straight)" --load $(dirname $0)/${STEP:-stepA_mal}.el "${@}" diff --git a/impls/elisp/step0_repl.el b/impls/elisp/step0_repl.el index 49bc0a78d9..2390f86faa 100644 --- a/impls/elisp/step0_repl.el +++ b/impls/elisp/step0_repl.el @@ -1,30 +1,30 @@ -(defun READ (input) - input) - -(defun EVAL (input) - input) - -(defun PRINT (input) - input) - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (println input) - (setq eof t) - ;; print final newline - (terpri)))))) - -(main) +(defun READ (input) + input) + +(defun EVAL (input) + input) + +(defun PRINT (input) + input) + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defun main () + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (println input) + (setq eof t) + ;; print final newline + (terpri)))))) + +(main) diff --git a/impls/elisp/step1_read_print.el b/impls/elisp/step1_read_print.el index 2e109a00da..f4153299e0 100644 --- a/impls/elisp/step1_read_print.el +++ b/impls/elisp/step1_read_print.el @@ -1,51 +1,51 @@ -(require 'mal/types) -(require 'mal/reader) -(require 'mal/printer) - -(defun READ (input) - (read-str input)) - -(defun EVAL (input) - input) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input)))) - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)) - (backtrace))) - (setq eof t) - ;; print final newline - (terpri)))))) - -(main) +(require 'mal/types) +(require 'mal/reader) +(require 'mal/printer) + +(defun READ (input) + (read-str input)) + +(defun EVAL (input) + input) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input)))) + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defun main () + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (condition-case err + (println (rep input)) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err)) + (backtrace))) + (setq eof t) + ;; print final newline + (terpri)))))) + +(main) diff --git a/impls/elisp/step2_eval.el b/impls/elisp/step2_eval.el index a27cbd6c4d..51c935b912 100644 --- a/impls/elisp/step2_eval.el +++ b/impls/elisp/step2_eval.el @@ -1,82 +1,82 @@ -(require 'mal/types) -(require 'mal/reader) -(require 'mal/printer) - -(defvar repl-env (make-hash-table :test 'eq)) -(puthash '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))) repl-env) -(puthash '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b)))) repl-env) -(puthash '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b)))) repl-env) -(puthash '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))) repl-env) - -(defun READ (input) - (read-str input)) - -(defun EVAL (ast env) - (if (and (mal-list-p ast) (mal-value ast)) - (let* ((ast* (mal-value (eval-ast ast env))) - (fn (car ast*)) - (args (cdr ast*))) - (apply fn args)) - (eval-ast ast env))) - -(defun eval-ast (ast env) - (let ((value (mal-value ast))) - (cl-case (mal-type ast) - (symbol - (let ((definition (gethash value env))) - (or definition (error "Definition not found")))) - (list - (mal-list (mapcar (lambda (item) (EVAL item env)) value))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) - (map - (let ((map (copy-hash-table value))) - (maphash (lambda (key val) - (puthash key (EVAL val env) map)) - map) - (mal-map map))) - (t - ;; return as is - ast)))) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input) repl-env))) - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)) - (backtrace))) - (setq eof t) - ;; print final newline - (terpri)))))) - -(main) +(require 'mal/types) +(require 'mal/reader) +(require 'mal/printer) + +(defvar repl-env (make-hash-table :test 'eq)) +(puthash '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))) repl-env) +(puthash '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b)))) repl-env) +(puthash '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b)))) repl-env) +(puthash '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))) repl-env) + +(defun READ (input) + (read-str input)) + +(defun EVAL (ast env) + (if (and (mal-list-p ast) (mal-value ast)) + (let* ((ast* (mal-value (eval-ast ast env))) + (fn (car ast*)) + (args (cdr ast*))) + (apply fn args)) + (eval-ast ast env))) + +(defun eval-ast (ast env) + (let ((value (mal-value ast))) + (cl-case (mal-type ast) + (symbol + (let ((definition (gethash value env))) + (or definition (error "Definition not found")))) + (list + (mal-list (mapcar (lambda (item) (EVAL item env)) value))) + (vector + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) + (map + (let ((map (copy-hash-table value))) + (maphash (lambda (key val) + (puthash key (EVAL val env) map)) + map) + (mal-map map))) + (t + ;; return as is + ast)))) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input) repl-env))) + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defun main () + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (condition-case err + (println (rep input)) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err)) + (backtrace))) + (setq eof t) + ;; print final newline + (terpri)))))) + +(main) diff --git a/impls/elisp/step3_env.el b/impls/elisp/step3_env.el index f05c178b21..2f89f2829c 100644 --- a/impls/elisp/step3_env.el +++ b/impls/elisp/step3_env.el @@ -1,102 +1,102 @@ -(require 'mal/types) -(require 'mal/env) -(require 'mal/reader) -(require 'mal/printer) - -(defvar repl-env (mal-env)) -(mal-env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) -(mal-env-set repl-env '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) -(mal-env-set repl-env '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) -(mal-env-set repl-env '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) - -(defun READ (input) - (read-str input)) - -(defun EVAL (ast env) - (if (and (mal-list-p ast) (mal-value ast)) - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a1* (mal-value a1)) - (a2 (nth 2 a))) - (cl-case (mal-value (car a)) - (def! - (let ((identifier a1*) - (value (EVAL a2 env))) - (mal-env-set env identifier value))) - (let* - (let ((env* (mal-env env)) - (bindings (if (vectorp a1*) (append a1* nil) a1*)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (EVAL form env*))) - (t - ;; not a special form - (let* ((ast* (mal-value (eval-ast ast env))) - (fn (car ast*)) - (args (cdr ast*))) - (apply fn args))))) - (eval-ast ast env))) - -(defun eval-ast (ast env) - (let ((value (mal-value ast))) - (cl-case (mal-type ast) - (symbol - (let ((definition (mal-env-get env value))) - (or definition (error "Definition not found")))) - (list - (mal-list (mapcar (lambda (item) (EVAL item env)) value))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) - (map - (let ((map (copy-hash-table value))) - (maphash (lambda (key val) - (puthash key (EVAL val env) map)) - map) - (mal-map map))) - (t - ;; return as is - ast)))) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input) repl-env))) - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)))) - (setq eof t) - ;; print final newline - (terpri)))))) - -(main) +(require 'mal/types) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) + +(defvar repl-env (mal-env)) +(mal-env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) +(mal-env-set repl-env '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) +(mal-env-set repl-env '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) +(mal-env-set repl-env '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) + +(defun READ (input) + (read-str input)) + +(defun EVAL (ast env) + (if (and (mal-list-p ast) (mal-value ast)) + (let* ((a (mal-value ast)) + (a1 (cadr a)) + (a1* (mal-value a1)) + (a2 (nth 2 a))) + (cl-case (mal-value (car a)) + (def! + (let ((identifier a1*) + (value (EVAL a2 env))) + (mal-env-set env identifier value))) + (let* + (let ((env* (mal-env env)) + (bindings (if (vectorp a1*) (append a1* nil) a1*)) + (form a2)) + (while bindings + (let ((key (mal-value (pop bindings))) + (value (EVAL (pop bindings) env*))) + (mal-env-set env* key value))) + (EVAL form env*))) + (t + ;; not a special form + (let* ((ast* (mal-value (eval-ast ast env))) + (fn (car ast*)) + (args (cdr ast*))) + (apply fn args))))) + (eval-ast ast env))) + +(defun eval-ast (ast env) + (let ((value (mal-value ast))) + (cl-case (mal-type ast) + (symbol + (let ((definition (mal-env-get env value))) + (or definition (error "Definition not found")))) + (list + (mal-list (mapcar (lambda (item) (EVAL item env)) value))) + (vector + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) + (map + (let ((map (copy-hash-table value))) + (maphash (lambda (key val) + (puthash key (EVAL val env) map)) + map) + (mal-map map))) + (t + ;; return as is + ast)))) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input) repl-env))) + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defun main () + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (condition-case err + (println (rep input)) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err)))) + (setq eof t) + ;; print final newline + (terpri)))))) + +(main) diff --git a/impls/elisp/step4_if_fn_do.el b/impls/elisp/step4_if_fn_do.el index f4f2142e3f..5f065a8513 100644 --- a/impls/elisp/step4_if_fn_do.el +++ b/impls/elisp/step4_if_fn_do.el @@ -1,128 +1,128 @@ -;; -*- lexical-binding: t; -*- - -(require 'mal/types) -(require 'mal/env) -(require 'mal/reader) -(require 'mal/printer) -(require 'mal/core) - -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun READ (input) - (read-str input)) - -(defun EVAL (ast env) - (if (and (mal-list-p ast) (mal-value ast)) - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (mal-env-set env identifier value))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (EVAL form env*))) - (do - (car (last (mal-value (eval-ast (mal-list (cdr a)) env))))) - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (EVAL then env) - (if else - (EVAL else env) - mal-nil)))) - (fn* - (let ((binds (mapcar 'mal-value (mal-value a1))) - (body a2)) - (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (t - ;; not a special form - (let* ((ast* (mal-value (eval-ast ast env))) - (fn* (mal-value (car ast*))) - (args (cdr ast*))) - (apply fn* args))))) - (eval-ast ast env))) - -(defun eval-ast (ast env) - (let ((value (mal-value ast))) - (cl-case (mal-type ast) - (symbol - (let ((definition (mal-env-get env value))) - (or definition (error "Definition not found")))) - (list - (mal-list (mapcar (lambda (item) (EVAL item env)) value))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) - (map - (let ((map (copy-hash-table value))) - (maphash (lambda (key val) - (puthash key (EVAL val env) map)) - map) - (mal-map map))) - (t - ;; return as is - ast)))) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input) repl-env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)))) - (setq eof t) - ;; print final newline - (terpri)))))) - -(main) +;; -*- lexical-binding: t; -*- + +(require 'mal/types) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) + +(defvar repl-env (mal-env)) + +(dolist (binding core-ns) + (let ((symbol (car binding)) + (fn (cdr binding))) + (mal-env-set repl-env symbol fn))) + +(defun READ (input) + (read-str input)) + +(defun EVAL (ast env) + (if (and (mal-list-p ast) (mal-value ast)) + (let* ((a (mal-value ast)) + (a1 (cadr a)) + (a2 (nth 2 a)) + (a3 (nth 3 a))) + (cl-case (mal-value (car a)) + (def! + (let ((identifier (mal-value a1)) + (value (EVAL a2 env))) + (mal-env-set env identifier value))) + (let* + (let ((env* (mal-env env)) + (bindings (mal-listify a1)) + (form a2)) + (while bindings + (let ((key (mal-value (pop bindings))) + (value (EVAL (pop bindings) env*))) + (mal-env-set env* key value))) + (EVAL form env*))) + (do + (car (last (mal-value (eval-ast (mal-list (cdr a)) env))))) + (if + (let* ((condition (EVAL a1 env)) + (condition-type (mal-type condition)) + (then a2) + (else a3)) + (if (and (not (eq condition-type 'false)) + (not (eq condition-type 'nil))) + (EVAL then env) + (if else + (EVAL else env) + mal-nil)))) + (fn* + (let ((binds (mapcar 'mal-value (mal-value a1))) + (body a2)) + (mal-fn + (lambda (&rest args) + (let ((env* (mal-env env binds args))) + (EVAL body env*)))))) + (t + ;; not a special form + (let* ((ast* (mal-value (eval-ast ast env))) + (fn* (mal-value (car ast*))) + (args (cdr ast*))) + (apply fn* args))))) + (eval-ast ast env))) + +(defun eval-ast (ast env) + (let ((value (mal-value ast))) + (cl-case (mal-type ast) + (symbol + (let ((definition (mal-env-get env value))) + (or definition (error "Definition not found")))) + (list + (mal-list (mapcar (lambda (item) (EVAL item env)) value))) + (vector + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) + (map + (let ((map (copy-hash-table value))) + (maphash (lambda (key val) + (puthash key (EVAL val env) map)) + map) + (mal-map map))) + (t + ;; return as is + ast)))) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defun main () + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (condition-case err + (println (rep input)) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err)))) + (setq eof t) + ;; print final newline + (terpri)))))) + +(main) diff --git a/impls/elisp/step5_tco.el b/impls/elisp/step5_tco.el index 315cfa4605..6d84ea46a0 100644 --- a/impls/elisp/step5_tco.el +++ b/impls/elisp/step5_tco.el @@ -1,146 +1,146 @@ -;; -*- lexical-binding: t; -*- - -(setq debug-on-error t) -(require 'mal/types) -(require 'mal/func) -(require 'mal/env) -(require 'mal/reader) -(require 'mal/printer) -(require 'mal/core) - -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun READ (input) - (read-str input)) - -(defun EVAL (ast env) - (catch 'return - (while t - (if (and (mal-list-p ast) (mal-value ast)) - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (setq env env* - ast form))) ; TCO - (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (when butlast - (eval-ast (mal-list butlast) env)) - (setq ast last))) ; TCO - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) - (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) - (t - ;; not a special form - (let* ((ast* (mal-value (eval-ast ast env))) - (fn (car ast*)) - (args (cdr ast*))) - (if (mal-func-p fn) - (let ((env* (mal-env (mal-func-env fn) - (mal-func-params fn) - args))) - (setq env env* - ast (mal-func-ast fn))) ; TCO - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* args)))))))) - (throw 'return (eval-ast ast env)))))) - -(defun eval-ast (ast env) - (let ((value (mal-value ast))) - (cl-case (mal-type ast) - (symbol - (let ((definition (mal-env-get env value))) - (or definition (error "Definition not found")))) - (list - (mal-list (mapcar (lambda (item) (EVAL item env)) value))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) - (map - (let ((map (copy-hash-table value))) - (maphash (lambda (key val) - (puthash key (EVAL val env) map)) - map) - (mal-map map))) - (t - ;; return as is - ast)))) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input) repl-env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defun main () - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (condition-case err - (println (rep input)) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err)))) - (setq eof t) - ;; print final newline - (terpri)))))) - -(main) +;; -*- lexical-binding: t; -*- + +(setq debug-on-error t) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) + +(defvar repl-env (mal-env)) + +(dolist (binding core-ns) + (let ((symbol (car binding)) + (fn (cdr binding))) + (mal-env-set repl-env symbol fn))) + +(defun READ (input) + (read-str input)) + +(defun EVAL (ast env) + (catch 'return + (while t + (if (and (mal-list-p ast) (mal-value ast)) + (let* ((a (mal-value ast)) + (a1 (cadr a)) + (a2 (nth 2 a)) + (a3 (nth 3 a))) + (cl-case (mal-value (car a)) + (def! + (let ((identifier (mal-value a1)) + (value (EVAL a2 env))) + (throw 'return (mal-env-set env identifier value)))) + (let* + (let ((env* (mal-env env)) + (bindings (mal-listify a1)) + (form a2)) + (while bindings + (let ((key (mal-value (pop bindings))) + (value (EVAL (pop bindings) env*))) + (mal-env-set env* key value))) + (setq env env* + ast form))) ; TCO + (do + (let* ((a0... (cdr a)) + (butlast (butlast a0...)) + (last (car (last a0...)))) + (when butlast + (eval-ast (mal-list butlast) env)) + (setq ast last))) ; TCO + (if + (let* ((condition (EVAL a1 env)) + (condition-type (mal-type condition)) + (then a2) + (else a3)) + (if (and (not (eq condition-type 'false)) + (not (eq condition-type 'nil))) + (setq ast then) ; TCO + (if else + (setq ast else) ; TCO + (throw 'return mal-nil))))) + (fn* + (let* ((binds (mapcar 'mal-value (mal-value a1))) + (body a2) + (fn (mal-fn + (lambda (&rest args) + (let ((env* (mal-env env binds args))) + (EVAL body env*)))))) + (throw 'return (mal-func body binds env fn)))) + (t + ;; not a special form + (let* ((ast* (mal-value (eval-ast ast env))) + (fn (car ast*)) + (args (cdr ast*))) + (if (mal-func-p fn) + (let ((env* (mal-env (mal-func-env fn) + (mal-func-params fn) + args))) + (setq env env* + ast (mal-func-ast fn))) ; TCO + (let ((fn* (mal-value fn))) + (throw 'return (apply fn* args)))))))) + (throw 'return (eval-ast ast env)))))) + +(defun eval-ast (ast env) + (let ((value (mal-value ast))) + (cl-case (mal-type ast) + (symbol + (let ((definition (mal-env-get env value))) + (or definition (error "Definition not found")))) + (list + (mal-list (mapcar (lambda (item) (EVAL item env)) value))) + (vector + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) + (map + (let ((map (copy-hash-table value))) + (maphash (lambda (key val) + (puthash key (EVAL val env) map)) + map) + (mal-map map))) + (t + ;; return as is + ast)))) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defun main () + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (condition-case err + (println (rep input)) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err)))) + (setq eof t) + ;; print final newline + (terpri)))))) + +(main) diff --git a/impls/elisp/step6_file.el b/impls/elisp/step6_file.el index 88d09d0e12..3228b35488 100644 --- a/impls/elisp/step6_file.el +++ b/impls/elisp/step6_file.el @@ -1,157 +1,157 @@ -;; -*- lexical-binding: t; -*- - -(require 'mal/types) -(require 'mal/func) -(require 'mal/env) -(require 'mal/reader) -(require 'mal/printer) -(require 'mal/core) - -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun READ (input) - (read-str input)) - -(defun EVAL (ast env) - (catch 'return - (while t - (if (and (mal-list-p ast) (mal-value ast)) - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (setq env env* - ast form))) ; TCO - (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (when butlast - (eval-ast (mal-list butlast) env)) - (setq ast last))) ; TCO - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) - (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) - (t - ;; not a special form - (let* ((ast* (mal-value (eval-ast ast env))) - (fn (car ast*)) - (args (cdr ast*))) - (if (mal-func-p fn) - (let ((env* (mal-env (mal-func-env fn) - (mal-func-params fn) - args))) - (setq env env* - ast (mal-func-ast fn))) ; TCO - ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* args)))))))) - (throw 'return (eval-ast ast env)))))) - -(defun eval-ast (ast env) - (let ((value (mal-value ast))) - (cl-case (mal-type ast) - (symbol - (let ((definition (mal-env-get env value))) - (or definition (error "Definition not found")))) - (list - (mal-list (mapcar (lambda (item) (EVAL item env)) value))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) - (map - (let ((map (copy-hash-table value))) - (maphash (lambda (key val) - (puthash key (EVAL val env) map)) - map) - (mal-map map))) - (t - ;; return as is - ast)))) - -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input) repl-env))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defmacro with-error-handling (&rest body) - `(condition-case err - (progn ,@body) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err))))) - -(defun main () - (if argv - (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) - -(main) +;; -*- lexical-binding: t; -*- + +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) + +(defvar repl-env (mal-env)) + +(dolist (binding core-ns) + (let ((symbol (car binding)) + (fn (cdr binding))) + (mal-env-set repl-env symbol fn))) + +(defun READ (input) + (read-str input)) + +(defun EVAL (ast env) + (catch 'return + (while t + (if (and (mal-list-p ast) (mal-value ast)) + (let* ((a (mal-value ast)) + (a1 (cadr a)) + (a2 (nth 2 a)) + (a3 (nth 3 a))) + (cl-case (mal-value (car a)) + (def! + (let ((identifier (mal-value a1)) + (value (EVAL a2 env))) + (throw 'return (mal-env-set env identifier value)))) + (let* + (let ((env* (mal-env env)) + (bindings (mal-listify a1)) + (form a2)) + (while bindings + (let ((key (mal-value (pop bindings))) + (value (EVAL (pop bindings) env*))) + (mal-env-set env* key value))) + (setq env env* + ast form))) ; TCO + (do + (let* ((a0... (cdr a)) + (butlast (butlast a0...)) + (last (car (last a0...)))) + (when butlast + (eval-ast (mal-list butlast) env)) + (setq ast last))) ; TCO + (if + (let* ((condition (EVAL a1 env)) + (condition-type (mal-type condition)) + (then a2) + (else a3)) + (if (and (not (eq condition-type 'false)) + (not (eq condition-type 'nil))) + (setq ast then) ; TCO + (if else + (setq ast else) ; TCO + (throw 'return mal-nil))))) + (fn* + (let* ((binds (mapcar 'mal-value (mal-value a1))) + (body a2) + (fn (mal-fn + (lambda (&rest args) + (let ((env* (mal-env env binds args))) + (EVAL body env*)))))) + (throw 'return (mal-func body binds env fn)))) + (t + ;; not a special form + (let* ((ast* (mal-value (eval-ast ast env))) + (fn (car ast*)) + (args (cdr ast*))) + (if (mal-func-p fn) + (let ((env* (mal-env (mal-func-env fn) + (mal-func-params fn) + args))) + (setq env env* + ast (mal-func-ast fn))) ; TCO + ;; built-in function + (let ((fn* (mal-value fn))) + (throw 'return (apply fn* args)))))))) + (throw 'return (eval-ast ast env)))))) + +(defun eval-ast (ast env) + (let ((value (mal-value ast))) + (cl-case (mal-type ast) + (symbol + (let ((definition (mal-env-get env value))) + (or definition (error "Definition not found")))) + (list + (mal-list (mapcar (lambda (item) (EVAL item env)) value))) + (vector + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) + (map + (let ((map (copy-hash-table value))) + (maphash (lambda (key val) + (puthash key (EVAL val env) map)) + map) + (mal-map map))) + (t + ;; return as is + ast)))) + +(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) +(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + +(defun main () + (if argv + (with-error-handling + (rep (format "(load-file \"%s\")" (car argv)))) + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (with-error-handling + (println (rep input))) + (setq eof t) + ;; print final newline + (terpri))))))) + +(main) diff --git a/impls/elisp/step7_quote.el b/impls/elisp/step7_quote.el index 726fbee90f..1d36c006fb 100644 --- a/impls/elisp/step7_quote.el +++ b/impls/elisp/step7_quote.el @@ -1,189 +1,189 @@ -;; -*- lexical-binding: t; -*- - -(require 'cl-lib) -(require 'mal/types) -(require 'mal/func) -(require 'mal/env) -(require 'mal/reader) -(require 'mal/printer) -(require 'mal/core) - -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun starts-with-p (ast sym) - (let ((l (mal-value ast))) - (and l - (let ((s (car l))) - (and (mal-symbol-p s) - (eq (mal-value s) sym)))))) - -(defun qq-reducer (elt acc) - (mal-list (if (and (mal-list-p elt) - (starts-with-p elt 'splice-unquote)) - (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) - (list (mal-symbol 'cons) (quasiquote elt) acc)))) - -(defun qq-iter (elts) - (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) - -(defun quasiquote (ast) - (cl-case (mal-type ast) - (list (if (starts-with-p ast 'unquote) - (cadr (mal-value ast)) - (qq-iter (mal-value ast)))) - (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (t ast))) - -(defun READ (input) - (read-str input)) - -(defun EVAL (ast env) - (catch 'return - (while t - (if (and (mal-list-p ast) (mal-value ast)) - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (setq env env* - ast form))) ; TCO - (quote - (throw 'return a1)) - (quasiquoteexpand - (throw 'return (quasiquote a1))) - (quasiquote - (setq ast (quasiquote a1))) ; TCO - (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (when butlast - (eval-ast (mal-list butlast) env)) - (setq ast last))) ; TCO - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) - (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) - (t - ;; not a special form - (let* ((ast* (mal-value (eval-ast ast env))) - (fn (car ast*)) - (args (cdr ast*))) - (if (mal-func-p fn) - (let ((env* (mal-env (mal-func-env fn) - (mal-func-params fn) - args))) - (setq env env* - ast (mal-func-ast fn))) ; TCO - ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* args)))))))) - (throw 'return (eval-ast ast env)))))) - -(defun eval-ast (ast env) - (let ((value (mal-value ast))) - (cl-case (mal-type ast) - (symbol - (let ((definition (mal-env-get env value))) - (or definition (error "Definition not found")))) - (list - (mal-list (mapcar (lambda (item) (EVAL item env)) value))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) - (map - (let ((map (copy-hash-table value))) - (maphash (lambda (key val) - (puthash key (EVAL val env) map)) - map) - (mal-map map))) - (t - ;; return as is - ast)))) - -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input) repl-env))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defmacro with-error-handling (&rest body) - `(condition-case err - (progn ,@body) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err))))) - -(defun main () - (if argv - (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) - -(main) +;; -*- lexical-binding: t; -*- + +(require 'cl-lib) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) + +(defvar repl-env (mal-env)) + +(dolist (binding core-ns) + (let ((symbol (car binding)) + (fn (cdr binding))) + (mal-env-set repl-env symbol fn))) + +(defun starts-with-p (ast sym) + (let ((l (mal-value ast))) + (and l + (let ((s (car l))) + (and (mal-symbol-p s) + (eq (mal-value s) sym)))))) + +(defun qq-reducer (elt acc) + (mal-list (if (and (mal-list-p elt) + (starts-with-p elt 'splice-unquote)) + (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) + (list (mal-symbol 'cons) (quasiquote elt) acc)))) + +(defun qq-iter (elts) + (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) + +(defun quasiquote (ast) + (cl-case (mal-type ast) + (list (if (starts-with-p ast 'unquote) + (cadr (mal-value ast)) + (qq-iter (mal-value ast)))) + (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) + ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) + (t ast))) + +(defun READ (input) + (read-str input)) + +(defun EVAL (ast env) + (catch 'return + (while t + (if (and (mal-list-p ast) (mal-value ast)) + (let* ((a (mal-value ast)) + (a1 (cadr a)) + (a2 (nth 2 a)) + (a3 (nth 3 a))) + (cl-case (mal-value (car a)) + (def! + (let ((identifier (mal-value a1)) + (value (EVAL a2 env))) + (throw 'return (mal-env-set env identifier value)))) + (let* + (let ((env* (mal-env env)) + (bindings (mal-listify a1)) + (form a2)) + (while bindings + (let ((key (mal-value (pop bindings))) + (value (EVAL (pop bindings) env*))) + (mal-env-set env* key value))) + (setq env env* + ast form))) ; TCO + (quote + (throw 'return a1)) + (quasiquoteexpand + (throw 'return (quasiquote a1))) + (quasiquote + (setq ast (quasiquote a1))) ; TCO + (do + (let* ((a0... (cdr a)) + (butlast (butlast a0...)) + (last (car (last a0...)))) + (when butlast + (eval-ast (mal-list butlast) env)) + (setq ast last))) ; TCO + (if + (let* ((condition (EVAL a1 env)) + (condition-type (mal-type condition)) + (then a2) + (else a3)) + (if (and (not (eq condition-type 'false)) + (not (eq condition-type 'nil))) + (setq ast then) ; TCO + (if else + (setq ast else) ; TCO + (throw 'return mal-nil))))) + (fn* + (let* ((binds (mapcar 'mal-value (mal-value a1))) + (body a2) + (fn (mal-fn + (lambda (&rest args) + (let ((env* (mal-env env binds args))) + (EVAL body env*)))))) + (throw 'return (mal-func body binds env fn)))) + (t + ;; not a special form + (let* ((ast* (mal-value (eval-ast ast env))) + (fn (car ast*)) + (args (cdr ast*))) + (if (mal-func-p fn) + (let ((env* (mal-env (mal-func-env fn) + (mal-func-params fn) + args))) + (setq env env* + ast (mal-func-ast fn))) ; TCO + ;; built-in function + (let ((fn* (mal-value fn))) + (throw 'return (apply fn* args)))))))) + (throw 'return (eval-ast ast env)))))) + +(defun eval-ast (ast env) + (let ((value (mal-value ast))) + (cl-case (mal-type ast) + (symbol + (let ((definition (mal-env-get env value))) + (or definition (error "Definition not found")))) + (list + (mal-list (mapcar (lambda (item) (EVAL item env)) value))) + (vector + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) + (map + (let ((map (copy-hash-table value))) + (maphash (lambda (key val) + (puthash key (EVAL val env) map)) + map) + (mal-map map))) + (t + ;; return as is + ast)))) + +(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) +(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + +(defun main () + (if argv + (with-error-handling + (rep (format "(load-file \"%s\")" (car argv)))) + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (with-error-handling + (println (rep input))) + (setq eof t) + ;; print final newline + (terpri))))))) + +(main) diff --git a/impls/elisp/step8_macros.el b/impls/elisp/step8_macros.el index 5462d87ca1..c5c79c3cdd 100644 --- a/impls/elisp/step8_macros.el +++ b/impls/elisp/step8_macros.el @@ -1,211 +1,211 @@ -;; -*- lexical-binding: t; -*- - -(require 'cl-lib) -(require 'mal/types) -(require 'mal/func) -(require 'mal/env) -(require 'mal/reader) -(require 'mal/printer) -(require 'mal/core) - -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun starts-with-p (ast sym) - (let ((s (car (mal-value ast)))) - (and (mal-symbol-p s) - (eq (mal-value s) sym)))) - -(defun qq-reducer (elt acc) - (mal-list (if (and (mal-list-p elt) - (starts-with-p elt 'splice-unquote)) - (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) - (list (mal-symbol 'cons) (quasiquote elt) acc)))) - -(defun qq-iter (elts) - (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) - -(defun quasiquote (ast) - (cl-case (mal-type ast) - (list (if (starts-with-p ast 'unquote) - (cadr (mal-value ast)) - (qq-iter (mal-value ast)))) - (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (t ast))) - -(defun MACROEXPAND (ast env) - (let (a a0 macro) - (while (and (mal-list-p ast) - (setq a (mal-value ast)) - (setq a0 (car a)) - (mal-symbol-p a0) - (setq macro (mal-env-find env (mal-value a0))) - (mal-func-p macro) - (mal-func-macro-p macro)) - (setq ast (apply (mal-value (mal-func-fn macro)) (cdr a))))) - ast) - -(defun READ (input) - (read-str input)) - -(defun EVAL (ast env) - (catch 'return - (while t - (when (not (mal-list-p ast)) - (throw 'return (eval-ast ast env))) - - (setq ast (MACROEXPAND ast env)) - (when (or (not (mal-list-p ast)) (not (mal-value ast))) - (throw 'return (eval-ast ast env))) - - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (setq env env* - ast form))) ; TCO - (quote - (throw 'return a1)) - (quasiquoteexpand - (throw 'return (quasiquote a1))) - (quasiquote - (setq ast (quasiquote a1))) ; TCO - (defmacro! - (let ((identifier (mal-value a1)) - (value (mal-macro (EVAL a2 env)))) - (throw 'return (mal-env-set env identifier value)))) - (macroexpand - (throw 'return (MACROEXPAND a1 env))) - (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (when butlast - (eval-ast (mal-list butlast) env)) - (setq ast last))) ; TCO - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) - (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) - (t - ;; not a special form - (let* ((ast* (mal-value (eval-ast ast env))) - (fn (car ast*)) - (args (cdr ast*))) - (if (mal-func-p fn) - (let ((env* (mal-env (mal-func-env fn) - (mal-func-params fn) - args))) - (setq env env* - ast (mal-func-ast fn))) ; TCO - ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* args))))))))))) - -(defun eval-ast (ast env) - (let ((value (mal-value ast))) - (cl-case (mal-type ast) - (symbol - (let ((definition (mal-env-get env value))) - (or definition (error "Definition not found")))) - (list - (mal-list (mapcar (lambda (item) (EVAL item env)) value))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) - (map - (let ((map (copy-hash-table value))) - (maphash (lambda (key val) - (puthash key (EVAL val env) map)) - map) - (mal-map map))) - (t - ;; return as is - ast)))) - -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input) repl-env))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defmacro with-error-handling (&rest body) - `(condition-case err - (progn ,@body) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err))))) - -(defun main () - (if argv - (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) - -(main) +;; -*- lexical-binding: t; -*- + +(require 'cl-lib) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) + +(defvar repl-env (mal-env)) + +(dolist (binding core-ns) + (let ((symbol (car binding)) + (fn (cdr binding))) + (mal-env-set repl-env symbol fn))) + +(defun starts-with-p (ast sym) + (let ((s (car (mal-value ast)))) + (and (mal-symbol-p s) + (eq (mal-value s) sym)))) + +(defun qq-reducer (elt acc) + (mal-list (if (and (mal-list-p elt) + (starts-with-p elt 'splice-unquote)) + (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) + (list (mal-symbol 'cons) (quasiquote elt) acc)))) + +(defun qq-iter (elts) + (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) + +(defun quasiquote (ast) + (cl-case (mal-type ast) + (list (if (starts-with-p ast 'unquote) + (cadr (mal-value ast)) + (qq-iter (mal-value ast)))) + (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) + ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) + (t ast))) + +(defun MACROEXPAND (ast env) + (let (a a0 macro) + (while (and (mal-list-p ast) + (setq a (mal-value ast)) + (setq a0 (car a)) + (mal-symbol-p a0) + (setq macro (mal-env-find env (mal-value a0))) + (mal-func-p macro) + (mal-func-macro-p macro)) + (setq ast (apply (mal-value (mal-func-fn macro)) (cdr a))))) + ast) + +(defun READ (input) + (read-str input)) + +(defun EVAL (ast env) + (catch 'return + (while t + (when (not (mal-list-p ast)) + (throw 'return (eval-ast ast env))) + + (setq ast (MACROEXPAND ast env)) + (when (or (not (mal-list-p ast)) (not (mal-value ast))) + (throw 'return (eval-ast ast env))) + + (let* ((a (mal-value ast)) + (a1 (cadr a)) + (a2 (nth 2 a)) + (a3 (nth 3 a))) + (cl-case (mal-value (car a)) + (def! + (let ((identifier (mal-value a1)) + (value (EVAL a2 env))) + (throw 'return (mal-env-set env identifier value)))) + (let* + (let ((env* (mal-env env)) + (bindings (mal-listify a1)) + (form a2)) + (while bindings + (let ((key (mal-value (pop bindings))) + (value (EVAL (pop bindings) env*))) + (mal-env-set env* key value))) + (setq env env* + ast form))) ; TCO + (quote + (throw 'return a1)) + (quasiquoteexpand + (throw 'return (quasiquote a1))) + (quasiquote + (setq ast (quasiquote a1))) ; TCO + (defmacro! + (let ((identifier (mal-value a1)) + (value (mal-macro (EVAL a2 env)))) + (throw 'return (mal-env-set env identifier value)))) + (macroexpand + (throw 'return (MACROEXPAND a1 env))) + (do + (let* ((a0... (cdr a)) + (butlast (butlast a0...)) + (last (car (last a0...)))) + (when butlast + (eval-ast (mal-list butlast) env)) + (setq ast last))) ; TCO + (if + (let* ((condition (EVAL a1 env)) + (condition-type (mal-type condition)) + (then a2) + (else a3)) + (if (and (not (eq condition-type 'false)) + (not (eq condition-type 'nil))) + (setq ast then) ; TCO + (if else + (setq ast else) ; TCO + (throw 'return mal-nil))))) + (fn* + (let* ((binds (mapcar 'mal-value (mal-value a1))) + (body a2) + (fn (mal-fn + (lambda (&rest args) + (let ((env* (mal-env env binds args))) + (EVAL body env*)))))) + (throw 'return (mal-func body binds env fn)))) + (t + ;; not a special form + (let* ((ast* (mal-value (eval-ast ast env))) + (fn (car ast*)) + (args (cdr ast*))) + (if (mal-func-p fn) + (let ((env* (mal-env (mal-func-env fn) + (mal-func-params fn) + args))) + (setq env env* + ast (mal-func-ast fn))) ; TCO + ;; built-in function + (let ((fn* (mal-value fn))) + (throw 'return (apply fn* args))))))))))) + +(defun eval-ast (ast env) + (let ((value (mal-value ast))) + (cl-case (mal-type ast) + (symbol + (let ((definition (mal-env-get env value))) + (or definition (error "Definition not found")))) + (list + (mal-list (mapcar (lambda (item) (EVAL item env)) value))) + (vector + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) + (map + (let ((map (copy-hash-table value))) + (maphash (lambda (key val) + (puthash key (EVAL val env) map)) + map) + (mal-map map))) + (t + ;; return as is + ast)))) + +(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) +(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + +(defun main () + (if argv + (with-error-handling + (rep (format "(load-file \"%s\")" (car argv)))) + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (with-error-handling + (println (rep input))) + (setq eof t) + ;; print final newline + (terpri))))))) + +(main) diff --git a/impls/elisp/step9_try.el b/impls/elisp/step9_try.el index 84fbc6038d..3f4821e221 100644 --- a/impls/elisp/step9_try.el +++ b/impls/elisp/step9_try.el @@ -1,227 +1,227 @@ -;; -*- lexical-binding: t; -*- - -(require 'cl-lib) -(require 'mal/types) -(require 'mal/func) -(require 'mal/env) -(require 'mal/reader) -(require 'mal/printer) -(require 'mal/core) - -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun starts-with-p (ast sym) - (let ((s (car (mal-value ast)))) - (and (mal-symbol-p s) - (eq (mal-value s) sym)))) - -(defun qq-reducer (elt acc) - (mal-list (if (and (mal-list-p elt) - (starts-with-p elt 'splice-unquote)) - (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) - (list (mal-symbol 'cons) (quasiquote elt) acc)))) - -(defun qq-iter (elts) - (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) - -(defun quasiquote (ast) - (cl-case (mal-type ast) - (list (if (starts-with-p ast 'unquote) - (cadr (mal-value ast)) - (qq-iter (mal-value ast)))) - (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (t ast))) - -(defun MACROEXPAND (ast env) - (let (a a0 macro) - (while (and (mal-list-p ast) - (setq a (mal-value ast)) - (setq a0 (car a)) - (mal-symbol-p a0) - (setq macro (mal-env-find env (mal-value a0))) - (mal-func-p macro) - (mal-func-macro-p macro)) - (setq ast (apply (mal-value (mal-func-fn macro)) (cdr a))))) - ast) - -(defun READ (input) - (read-str input)) - -(defun EVAL (ast env) - (catch 'return - (while t - (when (not (mal-list-p ast)) - (throw 'return (eval-ast ast env))) - - (setq ast (MACROEXPAND ast env)) - (when (or (not (mal-list-p ast)) (not (mal-value ast))) - (throw 'return (eval-ast ast env))) - - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (setq env env* - ast form))) ; TCO - (quote - (throw 'return a1)) - (quasiquoteexpand - (throw 'return (quasiquote a1))) - (quasiquote - (setq ast (quasiquote a1))) ; TCO - (defmacro! - (let ((identifier (mal-value a1)) - (value (mal-macro (EVAL a2 env)))) - (throw 'return (mal-env-set env identifier value)))) - (macroexpand - (throw 'return (MACROEXPAND a1 env))) - (try* - (condition-case err - (throw 'return (EVAL a1 env)) - (error - (if (and a2 (eq (mal-value (car (mal-value a2))) 'catch*)) - (let* ((a2* (mal-value a2)) - (identifier (mal-value (cadr a2*))) - (form (nth 2 a2*)) - (err* (if (eq (car err) 'mal-custom) - ;; throw - (cadr err) - ;; normal error - (mal-string (error-message-string err)))) - (env* (mal-env env (list identifier) (list err*)))) - (throw 'return (EVAL form env*))) - (signal (car err) (cdr err)))))) - (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (when butlast - (eval-ast (mal-list butlast) env)) - (setq ast last))) ; TCO - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) - (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) - (t - ;; not a special form - (let* ((ast* (mal-value (eval-ast ast env))) - (fn (car ast*)) - (args (cdr ast*))) - (if (mal-func-p fn) - (let ((env* (mal-env (mal-func-env fn) - (mal-func-params fn) - args))) - (setq env env* - ast (mal-func-ast fn))) ; TCO - ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* args))))))))))) - -(defun eval-ast (ast env) - (let ((value (mal-value ast))) - (cl-case (mal-type ast) - (symbol - (let ((definition (mal-env-get env value))) - (or definition (error "Definition not found")))) - (list - (mal-list (mapcar (lambda (item) (EVAL item env)) value))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) - (map - (let ((map (copy-hash-table value))) - (maphash (lambda (key val) - (puthash key (EVAL val env) map)) - map) - (mal-map map))) - (t - ;; return as is - ast)))) - -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input) repl-env))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defmacro with-error-handling (&rest body) - `(condition-case err - (progn ,@body) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err))))) - -(defun main () - (if argv - (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (while (not eof) - (let ((input (readln "user> "))) - (if input - (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) - -(main) +;; -*- lexical-binding: t; -*- + +(require 'cl-lib) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) + +(defvar repl-env (mal-env)) + +(dolist (binding core-ns) + (let ((symbol (car binding)) + (fn (cdr binding))) + (mal-env-set repl-env symbol fn))) + +(defun starts-with-p (ast sym) + (let ((s (car (mal-value ast)))) + (and (mal-symbol-p s) + (eq (mal-value s) sym)))) + +(defun qq-reducer (elt acc) + (mal-list (if (and (mal-list-p elt) + (starts-with-p elt 'splice-unquote)) + (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) + (list (mal-symbol 'cons) (quasiquote elt) acc)))) + +(defun qq-iter (elts) + (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) + +(defun quasiquote (ast) + (cl-case (mal-type ast) + (list (if (starts-with-p ast 'unquote) + (cadr (mal-value ast)) + (qq-iter (mal-value ast)))) + (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) + ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) + (t ast))) + +(defun MACROEXPAND (ast env) + (let (a a0 macro) + (while (and (mal-list-p ast) + (setq a (mal-value ast)) + (setq a0 (car a)) + (mal-symbol-p a0) + (setq macro (mal-env-find env (mal-value a0))) + (mal-func-p macro) + (mal-func-macro-p macro)) + (setq ast (apply (mal-value (mal-func-fn macro)) (cdr a))))) + ast) + +(defun READ (input) + (read-str input)) + +(defun EVAL (ast env) + (catch 'return + (while t + (when (not (mal-list-p ast)) + (throw 'return (eval-ast ast env))) + + (setq ast (MACROEXPAND ast env)) + (when (or (not (mal-list-p ast)) (not (mal-value ast))) + (throw 'return (eval-ast ast env))) + + (let* ((a (mal-value ast)) + (a1 (cadr a)) + (a2 (nth 2 a)) + (a3 (nth 3 a))) + (cl-case (mal-value (car a)) + (def! + (let ((identifier (mal-value a1)) + (value (EVAL a2 env))) + (throw 'return (mal-env-set env identifier value)))) + (let* + (let ((env* (mal-env env)) + (bindings (mal-listify a1)) + (form a2)) + (while bindings + (let ((key (mal-value (pop bindings))) + (value (EVAL (pop bindings) env*))) + (mal-env-set env* key value))) + (setq env env* + ast form))) ; TCO + (quote + (throw 'return a1)) + (quasiquoteexpand + (throw 'return (quasiquote a1))) + (quasiquote + (setq ast (quasiquote a1))) ; TCO + (defmacro! + (let ((identifier (mal-value a1)) + (value (mal-macro (EVAL a2 env)))) + (throw 'return (mal-env-set env identifier value)))) + (macroexpand + (throw 'return (MACROEXPAND a1 env))) + (try* + (condition-case err + (throw 'return (EVAL a1 env)) + (error + (if (and a2 (eq (mal-value (car (mal-value a2))) 'catch*)) + (let* ((a2* (mal-value a2)) + (identifier (mal-value (cadr a2*))) + (form (nth 2 a2*)) + (err* (if (eq (car err) 'mal-custom) + ;; throw + (cadr err) + ;; normal error + (mal-string (error-message-string err)))) + (env* (mal-env env (list identifier) (list err*)))) + (throw 'return (EVAL form env*))) + (signal (car err) (cdr err)))))) + (do + (let* ((a0... (cdr a)) + (butlast (butlast a0...)) + (last (car (last a0...)))) + (when butlast + (eval-ast (mal-list butlast) env)) + (setq ast last))) ; TCO + (if + (let* ((condition (EVAL a1 env)) + (condition-type (mal-type condition)) + (then a2) + (else a3)) + (if (and (not (eq condition-type 'false)) + (not (eq condition-type 'nil))) + (setq ast then) ; TCO + (if else + (setq ast else) ; TCO + (throw 'return mal-nil))))) + (fn* + (let* ((binds (mapcar 'mal-value (mal-value a1))) + (body a2) + (fn (mal-fn + (lambda (&rest args) + (let ((env* (mal-env env binds args))) + (EVAL body env*)))))) + (throw 'return (mal-func body binds env fn)))) + (t + ;; not a special form + (let* ((ast* (mal-value (eval-ast ast env))) + (fn (car ast*)) + (args (cdr ast*))) + (if (mal-func-p fn) + (let ((env* (mal-env (mal-func-env fn) + (mal-func-params fn) + args))) + (setq env env* + ast (mal-func-ast fn))) ; TCO + ;; built-in function + (let ((fn* (mal-value fn))) + (throw 'return (apply fn* args))))))))))) + +(defun eval-ast (ast env) + (let ((value (mal-value ast))) + (cl-case (mal-type ast) + (symbol + (let ((definition (mal-env-get env value))) + (or definition (error "Definition not found")))) + (list + (mal-list (mapcar (lambda (item) (EVAL item env)) value))) + (vector + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) + (map + (let ((map (copy-hash-table value))) + (maphash (lambda (key val) + (puthash key (EVAL val env) map)) + map) + (mal-map map))) + (t + ;; return as is + ast)))) + +(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) +(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + +(defun main () + (if argv + (with-error-handling + (rep (format "(load-file \"%s\")" (car argv)))) + (let (eof) + (while (not eof) + (let ((input (readln "user> "))) + (if input + (with-error-handling + (println (rep input))) + (setq eof t) + ;; print final newline + (terpri))))))) + +(main) diff --git a/impls/elisp/stepA_mal.el b/impls/elisp/stepA_mal.el index 34c53c683d..384f31afe1 100644 --- a/impls/elisp/stepA_mal.el +++ b/impls/elisp/stepA_mal.el @@ -1,229 +1,229 @@ -;; -*- lexical-binding: t; -*- - -(require 'cl-lib) -(require 'mal/types) -(require 'mal/func) -(require 'mal/env) -(require 'mal/reader) -(require 'mal/printer) -(require 'mal/core) - -(defvar repl-env (mal-env)) - -(dolist (binding core-ns) - (let ((symbol (car binding)) - (fn (cdr binding))) - (mal-env-set repl-env symbol fn))) - -(defun starts-with-p (ast sym) - (let ((s (car (mal-value ast)))) - (and (mal-symbol-p s) - (eq (mal-value s) sym)))) - -(defun qq-reducer (elt acc) - (mal-list (if (and (mal-list-p elt) - (starts-with-p elt 'splice-unquote)) - (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) - (list (mal-symbol 'cons) (quasiquote elt) acc)))) - -(defun qq-iter (elts) - (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) - -(defun quasiquote (ast) - (cl-case (mal-type ast) - (list (if (starts-with-p ast 'unquote) - (cadr (mal-value ast)) - (qq-iter (mal-value ast)))) - (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (t ast))) - -(defun MACROEXPAND (ast env) - (let (a a0 macro) - (while (and (mal-list-p ast) - (setq a (mal-value ast)) - (setq a0 (car a)) - (mal-symbol-p a0) - (setq macro (mal-env-find env (mal-value a0))) - (mal-func-p macro) - (mal-func-macro-p macro)) - (setq ast (apply (mal-value (mal-func-fn macro)) (cdr a))))) - ast) - -(defun READ (input) - (read-str input)) - -(defun EVAL (ast env) - (catch 'return - (while t - (when (not (mal-list-p ast)) - (throw 'return (eval-ast ast env))) - - (setq ast (MACROEXPAND ast env)) - (when (or (not (mal-list-p ast)) (not (mal-value ast))) - (throw 'return (eval-ast ast env))) - - (let* ((a (mal-value ast)) - (a1 (cadr a)) - (a2 (nth 2 a)) - (a3 (nth 3 a))) - (cl-case (mal-value (car a)) - (def! - (let ((identifier (mal-value a1)) - (value (EVAL a2 env))) - (throw 'return (mal-env-set env identifier value)))) - (let* - (let ((env* (mal-env env)) - (bindings (mal-listify a1)) - (form a2)) - (while bindings - (let ((key (mal-value (pop bindings))) - (value (EVAL (pop bindings) env*))) - (mal-env-set env* key value))) - (setq env env* - ast form))) ; TCO - (quote - (throw 'return a1)) - (quasiquoteexpand - (throw 'return (quasiquote a1))) - (quasiquote - (setq ast (quasiquote a1))) ; TCO - (defmacro! - (let ((identifier (mal-value a1)) - (value (mal-macro (EVAL a2 env)))) - (throw 'return (mal-env-set env identifier value)))) - (macroexpand - (throw 'return (MACROEXPAND a1 env))) - (try* - (condition-case err - (throw 'return (EVAL a1 env)) - (error - (if (and a2 (eq (mal-value (car (mal-value a2))) 'catch*)) - (let* ((a2* (mal-value a2)) - (identifier (mal-value (cadr a2*))) - (form (nth 2 a2*)) - (err* (if (eq (car err) 'mal-custom) - ;; throw - (cadr err) - ;; normal error - (mal-string (error-message-string err)))) - (env* (mal-env env (list identifier) (list err*)))) - (throw 'return (EVAL form env*))) - (signal (car err) (cdr err)))))) - (do - (let* ((a0... (cdr a)) - (butlast (butlast a0...)) - (last (car (last a0...)))) - (when butlast - (eval-ast (mal-list butlast) env)) - (setq ast last))) ; TCO - (if - (let* ((condition (EVAL a1 env)) - (condition-type (mal-type condition)) - (then a2) - (else a3)) - (if (and (not (eq condition-type 'false)) - (not (eq condition-type 'nil))) - (setq ast then) ; TCO - (if else - (setq ast else) ; TCO - (throw 'return mal-nil))))) - (fn* - (let* ((binds (mapcar 'mal-value (mal-value a1))) - (body a2) - (fn (mal-fn - (lambda (&rest args) - (let ((env* (mal-env env binds args))) - (EVAL body env*)))))) - (throw 'return (mal-func body binds env fn)))) - (t - ;; not a special form - (let* ((ast* (mal-value (eval-ast ast env))) - (fn (car ast*)) - (args (cdr ast*))) - (if (mal-func-p fn) - (let ((env* (mal-env (mal-func-env fn) - (mal-func-params fn) - args))) - (setq env env* - ast (mal-func-ast fn))) ; TCO - ;; built-in function - (let ((fn* (mal-value fn))) - (throw 'return (apply fn* args))))))))))) - -(defun eval-ast (ast env) - (let ((value (mal-value ast))) - (cl-case (mal-type ast) - (symbol - (let ((definition (mal-env-get env value))) - (or definition (error "Definition not found")))) - (list - (mal-list (mapcar (lambda (item) (EVAL item env)) value))) - (vector - (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) - (map - (let ((map (copy-hash-table value))) - (maphash (lambda (key val) - (puthash key (EVAL val env) map)) - map) - (mal-map map))) - (t - ;; return as is - ast)))) - -(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) -(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) -(mal-env-set repl-env '*host-language* (mal-string "elisp")) - -(defun PRINT (input) - (pr-str input t)) - -(defun rep (input) - (PRINT (EVAL (READ input) repl-env))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(defun readln (prompt) - ;; C-d throws an error - (ignore-errors (read-from-minibuffer prompt))) - -(defun println (format-string &rest args) - (if (not args) - (princ format-string) - (princ (apply 'format format-string args))) - (terpri)) - -(defmacro with-error-handling (&rest body) - `(condition-case err - (progn ,@body) - (end-of-token-stream - ;; empty input, carry on - ) - (unterminated-sequence - (princ (format "Expected '%c', got EOF\n" - (cl-case (cadr err) - (string ?\") - (list ?\)) - (vector ?\]) - (map ?}))))) - (error ; catch-all - (println (error-message-string err))))) - -(defun main () - (if argv - (with-error-handling - (rep (format "(load-file \"%s\")" (car argv)))) - (let (eof) - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (while (not eof) - (let ((input (readln "user> "))) - (if input - (with-error-handling - (println (rep input))) - (setq eof t) - ;; print final newline - (terpri))))))) - -(main) +;; -*- lexical-binding: t; -*- + +(require 'cl-lib) +(require 'mal/types) +(require 'mal/func) +(require 'mal/env) +(require 'mal/reader) +(require 'mal/printer) +(require 'mal/core) + +(defvar repl-env (mal-env)) + +(dolist (binding core-ns) + (let ((symbol (car binding)) + (fn (cdr binding))) + (mal-env-set repl-env symbol fn))) + +(defun starts-with-p (ast sym) + (let ((s (car (mal-value ast)))) + (and (mal-symbol-p s) + (eq (mal-value s) sym)))) + +(defun qq-reducer (elt acc) + (mal-list (if (and (mal-list-p elt) + (starts-with-p elt 'splice-unquote)) + (list (mal-symbol 'concat) (cadr (mal-value elt)) acc) + (list (mal-symbol 'cons) (quasiquote elt) acc)))) + +(defun qq-iter (elts) + (cl-reduce 'qq-reducer elts :from-end t :initial-value (mal-list nil))) + +(defun quasiquote (ast) + (cl-case (mal-type ast) + (list (if (starts-with-p ast 'unquote) + (cadr (mal-value ast)) + (qq-iter (mal-value ast)))) + (vector (mal-list (list (mal-symbol 'vec) (qq-iter (mal-value ast))))) + ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) + (t ast))) + +(defun MACROEXPAND (ast env) + (let (a a0 macro) + (while (and (mal-list-p ast) + (setq a (mal-value ast)) + (setq a0 (car a)) + (mal-symbol-p a0) + (setq macro (mal-env-find env (mal-value a0))) + (mal-func-p macro) + (mal-func-macro-p macro)) + (setq ast (apply (mal-value (mal-func-fn macro)) (cdr a))))) + ast) + +(defun READ (input) + (read-str input)) + +(defun EVAL (ast env) + (catch 'return + (while t + (when (not (mal-list-p ast)) + (throw 'return (eval-ast ast env))) + + (setq ast (MACROEXPAND ast env)) + (when (or (not (mal-list-p ast)) (not (mal-value ast))) + (throw 'return (eval-ast ast env))) + + (let* ((a (mal-value ast)) + (a1 (cadr a)) + (a2 (nth 2 a)) + (a3 (nth 3 a))) + (cl-case (mal-value (car a)) + (def! + (let ((identifier (mal-value a1)) + (value (EVAL a2 env))) + (throw 'return (mal-env-set env identifier value)))) + (let* + (let ((env* (mal-env env)) + (bindings (mal-listify a1)) + (form a2)) + (while bindings + (let ((key (mal-value (pop bindings))) + (value (EVAL (pop bindings) env*))) + (mal-env-set env* key value))) + (setq env env* + ast form))) ; TCO + (quote + (throw 'return a1)) + (quasiquoteexpand + (throw 'return (quasiquote a1))) + (quasiquote + (setq ast (quasiquote a1))) ; TCO + (defmacro! + (let ((identifier (mal-value a1)) + (value (mal-macro (EVAL a2 env)))) + (throw 'return (mal-env-set env identifier value)))) + (macroexpand + (throw 'return (MACROEXPAND a1 env))) + (try* + (condition-case err + (throw 'return (EVAL a1 env)) + (error + (if (and a2 (eq (mal-value (car (mal-value a2))) 'catch*)) + (let* ((a2* (mal-value a2)) + (identifier (mal-value (cadr a2*))) + (form (nth 2 a2*)) + (err* (if (eq (car err) 'mal-custom) + ;; throw + (cadr err) + ;; normal error + (mal-string (error-message-string err)))) + (env* (mal-env env (list identifier) (list err*)))) + (throw 'return (EVAL form env*))) + (signal (car err) (cdr err)))))) + (do + (let* ((a0... (cdr a)) + (butlast (butlast a0...)) + (last (car (last a0...)))) + (when butlast + (eval-ast (mal-list butlast) env)) + (setq ast last))) ; TCO + (if + (let* ((condition (EVAL a1 env)) + (condition-type (mal-type condition)) + (then a2) + (else a3)) + (if (and (not (eq condition-type 'false)) + (not (eq condition-type 'nil))) + (setq ast then) ; TCO + (if else + (setq ast else) ; TCO + (throw 'return mal-nil))))) + (fn* + (let* ((binds (mapcar 'mal-value (mal-value a1))) + (body a2) + (fn (mal-fn + (lambda (&rest args) + (let ((env* (mal-env env binds args))) + (EVAL body env*)))))) + (throw 'return (mal-func body binds env fn)))) + (t + ;; not a special form + (let* ((ast* (mal-value (eval-ast ast env))) + (fn (car ast*)) + (args (cdr ast*))) + (if (mal-func-p fn) + (let ((env* (mal-env (mal-func-env fn) + (mal-func-params fn) + args))) + (setq env env* + ast (mal-func-ast fn))) ; TCO + ;; built-in function + (let ((fn* (mal-value fn))) + (throw 'return (apply fn* args))))))))))) + +(defun eval-ast (ast env) + (let ((value (mal-value ast))) + (cl-case (mal-type ast) + (symbol + (let ((definition (mal-env-get env value))) + (or definition (error "Definition not found")))) + (list + (mal-list (mapcar (lambda (item) (EVAL item env)) value))) + (vector + (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) + (map + (let ((map (copy-hash-table value))) + (maphash (lambda (key val) + (puthash key (EVAL val env) map)) + map) + (mal-map map))) + (t + ;; return as is + ast)))) + +(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env))))) +(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv)))) +(mal-env-set repl-env '*host-language* (mal-string "elisp")) + +(defun PRINT (input) + (pr-str input t)) + +(defun rep (input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(defun readln (prompt) + ;; C-d throws an error + (ignore-errors (read-from-minibuffer prompt))) + +(defun println (format-string &rest args) + (if (not args) + (princ format-string) + (princ (apply 'format format-string args))) + (terpri)) + +(defmacro with-error-handling (&rest body) + `(condition-case err + (progn ,@body) + (end-of-token-stream + ;; empty input, carry on + ) + (unterminated-sequence + (princ (format "Expected '%c', got EOF\n" + (cl-case (cadr err) + (string ?\") + (list ?\)) + (vector ?\]) + (map ?}))))) + (error ; catch-all + (println (error-message-string err))))) + +(defun main () + (if argv + (with-error-handling + (rep (format "(load-file \"%s\")" (car argv)))) + (let (eof) + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (while (not eof) + (let ((input (readln "user> "))) + (if input + (with-error-handling + (println (rep input))) + (setq eof t) + ;; print final newline + (terpri))))))) + +(main) diff --git a/impls/elisp/tests/step5_tco.mal b/impls/elisp/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/elisp/tests/step5_tco.mal +++ b/impls/elisp/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/elisp/tests/stepA_mal.mal b/impls/elisp/tests/stepA_mal.mal index ec8c701f3c..d977969fa4 100644 --- a/impls/elisp/tests/stepA_mal.mal +++ b/impls/elisp/tests/stepA_mal.mal @@ -1,21 +1,21 @@ -;; Testing basic elisp interop - -(elisp-eval "42") -;=>42 - -(elisp-eval "(+ 1 1)") -;=>2 - -(elisp-eval "[foo bar baz]") -;=>[foo bar baz] - -(elisp-eval "(mapcar '1+ (number-sequence 0 2))") -;=>(1 2 3) - -(elisp-eval "(progn (princ \"Hello World!\n\") nil)") -;/Hello World! -;=>nil - -(elisp-eval "(setq emacs-version-re (rx (+ digit) \".\" digit))") -(elisp-eval "(and (string-match-p emacs-version-re emacs-version) t)") -;=>true +;; Testing basic elisp interop + +(elisp-eval "42") +;=>42 + +(elisp-eval "(+ 1 1)") +;=>2 + +(elisp-eval "[foo bar baz]") +;=>[foo bar baz] + +(elisp-eval "(mapcar '1+ (number-sequence 0 2))") +;=>(1 2 3) + +(elisp-eval "(progn (princ \"Hello World!\n\") nil)") +;/Hello World! +;=>nil + +(elisp-eval "(setq emacs-version-re (rx (+ digit) \".\" digit))") +(elisp-eval "(and (string-match-p emacs-version-re emacs-version) t)") +;=>true diff --git a/impls/elixir/Dockerfile b/impls/elixir/Dockerfile index 758c9036a6..bb6a923a77 100644 --- a/impls/elixir/Dockerfile +++ b/impls/elixir/Dockerfile @@ -1,30 +1,30 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Elixir -RUN apt-get install -y wget -RUN wget https://packages.erlang-solutions.com/erlang-solutions_1.0_all.deb -RUN dpkg -i erlang-solutions_1.0_all.deb -RUN apt-get update -y -RUN apt-get install -y esl-erlang -RUN apt-get install -y elixir +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Elixir +RUN apt-get install -y wget +RUN wget https://packages.erlang-solutions.com/erlang-solutions_1.0_all.deb +RUN dpkg -i erlang-solutions_1.0_all.deb +RUN apt-get update -y +RUN apt-get install -y esl-erlang +RUN apt-get install -y elixir diff --git a/impls/elixir/Makefile b/impls/elixir/Makefile index 7bae647688..6f6bdffb04 100644 --- a/impls/elixir/Makefile +++ b/impls/elixir/Makefile @@ -1,17 +1,17 @@ -SOURCES_BASE = lib/mal/types.ex lib/mal/reader.ex lib/mal/printer.ex -SOURCES_LISP = lib/mal/env.ex lib/mal/core.ex lib/mix/tasks/stepA_mal.ex -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - mix compile - -dist: mal - -mal: $(SOURCES) - mix escript.build - -clean: - mix clean - rm -f mal - -.PHONY: clean +SOURCES_BASE = lib/mal/types.ex lib/mal/reader.ex lib/mal/printer.ex +SOURCES_LISP = lib/mal/env.ex lib/mal/core.ex lib/mix/tasks/stepA_mal.ex +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + mix compile + +dist: mal + +mal: $(SOURCES) + mix escript.build + +clean: + mix clean + rm -f mal + +.PHONY: clean diff --git a/impls/elixir/lib/mal.ex b/impls/elixir/lib/mal.ex index 5ad079b2ed..c37fe0a205 100644 --- a/impls/elixir/lib/mal.ex +++ b/impls/elixir/lib/mal.ex @@ -1,2 +1,2 @@ -defmodule Mal do -end +defmodule Mal do +end diff --git a/impls/elixir/lib/mal/atom.ex b/impls/elixir/lib/mal/atom.ex index c8a7e2bcf3..0dd12547e7 100644 --- a/impls/elixir/lib/mal/atom.ex +++ b/impls/elixir/lib/mal/atom.ex @@ -1,25 +1,25 @@ -defmodule Mal.Atom do - alias Mal.Function - - def new(value) do - {:ok, pid} = Agent.start_link(fn -> value end) - pid - end - - def deref({:atom, pid}) do - Agent.get(pid, fn value -> value end) - end - - def reset!({:atom, pid}, new_value) do - Agent.update(pid, fn _ -> new_value end) - new_value - end - - def swap!({:atom, pid}, %Function{value: func}, args) do - Agent.get_and_update(pid, fn state -> - func_args = [state | args] - new = func.(func_args) - {new, new} - end) - end -end +defmodule Mal.Atom do + alias Mal.Function + + def new(value) do + {:ok, pid} = Agent.start_link(fn -> value end) + pid + end + + def deref({:atom, pid}) do + Agent.get(pid, fn value -> value end) + end + + def reset!({:atom, pid}, new_value) do + Agent.update(pid, fn _ -> new_value end) + new_value + end + + def swap!({:atom, pid}, %Function{value: func}, args) do + Agent.get_and_update(pid, fn state -> + func_args = [state | args] + new = func.(func_args) + {new, new} + end) + end +end diff --git a/impls/elixir/lib/mal/core.ex b/impls/elixir/lib/mal/core.ex index f8074c6de0..dc055c6cba 100644 --- a/impls/elixir/lib/mal/core.ex +++ b/impls/elixir/lib/mal/core.ex @@ -1,249 +1,249 @@ -defmodule Mal.Core do - import Mal.Types - alias Mal.Function - - def namespace do - raw = %{ - "+" => fn [a, b] -> a + b end, - "-" => fn [a, b] -> a - b end, - "*" => fn [a, b] -> a * b end, - "/" => fn [a, b] -> div(a, b) end, - ">" => fn [a, b] -> a > b end, - "<" => fn [a, b] -> a < b end, - "<=" => fn [a, b] -> a <= b end, - ">=" => fn [a, b] -> a >= b end, - "concat" => &concat/1, - "=" => &equal/1, - "list?" => &list?/1, - "empty?" => &empty?/1, - "count" => &count/1, - "pr-str" => &pr_str/1, - "str" => &str/1, - "prn" => &prn/1, - "println" => &println/1, - "slurp" => &slurp/1, - "nth" => &nth/1, - "first" => &first/1, - "rest" => &rest/1, - "map" => &map/1, - "apply" => &apply/1, - "keyword" => &keyword/1, - "symbol?" => &symbol?/1, - "cons" => &cons/1, - "vec" => &vec/1, - "vector?" => &vector?/1, - "assoc" => &assoc/1, - "dissoc" => &dissoc/1, - "get" => &get/1, - "map?" => &map?/1, - "list" => &list/1, - "vector" => &vector/1, - "hash-map" => &hash_map/1, - "meta" => &meta/1, - "with-meta" => &with_meta/1, - "atom" => &atom/1, - "atom?" => &atom?/1, - "deref" => &deref/1, - "reset!" => &reset!/1, - "swap!" => &swap!/1, - "conj" => &conj/1, - "seq" => &seq/1, - "fn?" => &fn?/1, - "macro?" => ¯o?/1, - "time-ms" => fn _ -> :erlang.system_time(:milli_seconds) end, - "readline" => fn [prompt] -> readline(prompt) end, - "sequential?" => fn arg -> vector?(arg) or list?(arg) end, - "keyword?" => fn [type] -> is_atom(type) end, - "nil?" => fn [type] -> type == nil end, - "true?" => fn [type] -> type == true end, - "false?" => fn [type] -> type == false end, - "string?" => fn [obj] -> String.valid?(obj) end, - "number?" => fn [obj] -> is_number(obj) end, - "symbol" => fn [name] -> {:symbol, name} end, - "read-string" => fn [input] -> Mal.Reader.read_str(input) end, - "throw" => fn [arg] -> throw({:error, arg}) end, - "contains?" => fn [{:map, map, _}, key] -> Map.has_key?(map, key) end, - "keys" => fn [{:map, map, _}] -> Map.keys(map) |> list end, - "vals" => fn [{:map, map, _}] -> Map.values(map) |> list end - } - - convert(raw) - end - - defp convert(map) do - for {name, func} <- map, into: %{} do - {name, %Function{value: func}} - end - end - - def readline(prompt) do - IO.write(:stdio, prompt) - IO.read(:stdio, :line) - |> String.trim("\n") - end - - defp convert_vector({type, ast, meta}) when type == :map do - new_ast = Enum.map(ast, fn {key, value} -> - {key, convert_vector(value)} - end) - {:map, new_ast, meta} - end - defp convert_vector({type, ast, meta}) when type in [:list, :vector] do - new_ast = Enum.map(ast, &convert_vector/1) - {:list, new_ast, meta} - end - defp convert_vector(other), do: other - - defp equal([a, b]) do - convert_vector(a) == convert_vector(b) - end - - defp empty?([{_type, [], _meta}]), do: true - defp empty?(_), do: false - - defp count([{_type, ast, _meta}]), do: length(ast) - defp count(_), do: 0 - - defp pr_str(args) do - args - |> Enum.map(&Mal.Printer.print_str/1) - |> Enum.join(" ") - end - - defp str(args) do - args - |> Enum.map(&(Mal.Printer.print_str(&1, false))) - |> Enum.join("") - end - - defp prn(args) do - args - |> pr_str - |> IO.puts - nil - end - - defp println(args) do - args - |> Enum.map(&(Mal.Printer.print_str(&1, false))) - |> Enum.join(" ") - |> IO.puts - nil - end - - defp slurp([file_name]) do - case File.read(file_name) do - {:ok, content} -> content - {:error, :enoent} -> throw({:error, "can't find file #{file_name}"}) - {:error, :eisdir} -> throw({:error, "can't read directory #{file_name}"}) - {:error, :eaccess} -> throw({:error, "missing permissions #{file_name}"}) - {:error, reason} -> throw({:error, "can't read file #{file_name}, #{reason}"}) - end - end - - defp nth([{_type, ast, _meta}, index]) do - case Enum.at(ast, index, :error) do - :error -> throw({:error, "index out of bounds"}) - any -> any - end - end - - defp first([{_type, [head | _tail], _}]), do: head - defp first(_), do: nil - - defp rest([{_type, [_head | tail], _}]), do: list(tail) - defp rest([{_type, [], _}]), do: list([]) - defp rest([nil]), do: list([]) - - defp map([%Function{value: function}, ast]), do: do_map(function, ast) - defp map([function, ast]), do: do_map(function, ast) - - defp do_map(function, {_type, ast, _meta}) do - ast - |> Enum.map(fn arg -> function.([arg]) end) - |> list - end - - defp apply([%Function{value: function} | tail]), do: do_apply(function, tail) - defp apply([function | tail]), do: do_apply(function, tail) - - defp do_apply(function, tail) do - [{_type, ast, _meta} | reversed_args] = Enum.reverse(tail) - args = Enum.reverse(reversed_args) - func_args = Enum.concat(args, ast) - function.(func_args) - end - - defp keyword([atom]) when is_atom(atom), do: atom - defp keyword([atom]), do: String.to_atom(atom) - - defp cons([prepend, {_type, ast, meta}]), do: {:list, [prepend | ast], meta} - - defp concat(args) do - args - |> Enum.map(fn tuple -> elem(tuple, 1) end) - |> Enum.concat - |> list - end - - defp vec([{:list, xs, _}]), do: vector(xs) - defp vec([{:vector, xs, _}]), do: vector(xs) - defp vec([_]), do: throw({:error, "vec: arg type"}) - defp vec(_), do: throw({:error, "vec: arg count"}) - - defp assoc([{:map, hash_map, meta} | pairs]) do - {:map, merge, _} = hash_map(pairs) - {:map, Map.merge(hash_map, merge), meta} - end - - defp dissoc([{:map, hash_map, meta} | keys]) do - {:map, Map.drop(hash_map, keys), meta} - end - - defp get([{:map, map, _}, key]), do: Map.get(map, key, nil) - defp get(_), do: nil - - defp meta([{_type, _ast, meta}]), do: meta - defp meta([%Function{meta: meta}]), do: meta - defp meta(_), do: nil - - defp with_meta([{type, ast, _old_meta}, meta]), do: {type, ast, meta} - defp with_meta([%Function{} = func, meta]), do: %{func | meta: meta} - defp with_meta(_), do: nil - - defp deref(args) do - apply(&Mal.Atom.deref/1, args) - end - - defp reset!(args) do - apply(&Mal.Atom.reset!/2, args) - end - - defp swap!([atom, function | args]) do - Mal.Atom.swap!(atom, function, args) - end - - defp conj([{:list, ast, meta} | args]) do - new_list = Enum.reverse(args) ++ ast - {:list, new_list, meta} - end - - defp conj([{:vector, ast, meta} | args]) do - {:vector, ast ++ args, meta} - end - - defp seq([nil]), do: nil - defp seq([{:list, [], _meta}]), do: nil - defp seq([{:list, ast, meta}]), do: {:list, ast, meta} - defp seq([{:vector, [], _meta}]), do: nil - defp seq([{:vector, ast, meta}]), do: {:list, ast, meta} - defp seq([""]), do: nil - defp seq([s]), do: {:list, String.split(s, "", trim: true), nil} - defp seq(_), do: nil - - defp fn?([%Function{macro: false}]), do: true - defp fn?(_), do: false - - defp macro?([%Function{macro: true}]), do: true - defp macro?(_), do: false -end +defmodule Mal.Core do + import Mal.Types + alias Mal.Function + + def namespace do + raw = %{ + "+" => fn [a, b] -> a + b end, + "-" => fn [a, b] -> a - b end, + "*" => fn [a, b] -> a * b end, + "/" => fn [a, b] -> div(a, b) end, + ">" => fn [a, b] -> a > b end, + "<" => fn [a, b] -> a < b end, + "<=" => fn [a, b] -> a <= b end, + ">=" => fn [a, b] -> a >= b end, + "concat" => &concat/1, + "=" => &equal/1, + "list?" => &list?/1, + "empty?" => &empty?/1, + "count" => &count/1, + "pr-str" => &pr_str/1, + "str" => &str/1, + "prn" => &prn/1, + "println" => &println/1, + "slurp" => &slurp/1, + "nth" => &nth/1, + "first" => &first/1, + "rest" => &rest/1, + "map" => &map/1, + "apply" => &apply/1, + "keyword" => &keyword/1, + "symbol?" => &symbol?/1, + "cons" => &cons/1, + "vec" => &vec/1, + "vector?" => &vector?/1, + "assoc" => &assoc/1, + "dissoc" => &dissoc/1, + "get" => &get/1, + "map?" => &map?/1, + "list" => &list/1, + "vector" => &vector/1, + "hash-map" => &hash_map/1, + "meta" => &meta/1, + "with-meta" => &with_meta/1, + "atom" => &atom/1, + "atom?" => &atom?/1, + "deref" => &deref/1, + "reset!" => &reset!/1, + "swap!" => &swap!/1, + "conj" => &conj/1, + "seq" => &seq/1, + "fn?" => &fn?/1, + "macro?" => ¯o?/1, + "time-ms" => fn _ -> :erlang.system_time(:milli_seconds) end, + "readline" => fn [prompt] -> readline(prompt) end, + "sequential?" => fn arg -> vector?(arg) or list?(arg) end, + "keyword?" => fn [type] -> is_atom(type) end, + "nil?" => fn [type] -> type == nil end, + "true?" => fn [type] -> type == true end, + "false?" => fn [type] -> type == false end, + "string?" => fn [obj] -> String.valid?(obj) end, + "number?" => fn [obj] -> is_number(obj) end, + "symbol" => fn [name] -> {:symbol, name} end, + "read-string" => fn [input] -> Mal.Reader.read_str(input) end, + "throw" => fn [arg] -> throw({:error, arg}) end, + "contains?" => fn [{:map, map, _}, key] -> Map.has_key?(map, key) end, + "keys" => fn [{:map, map, _}] -> Map.keys(map) |> list end, + "vals" => fn [{:map, map, _}] -> Map.values(map) |> list end + } + + convert(raw) + end + + defp convert(map) do + for {name, func} <- map, into: %{} do + {name, %Function{value: func}} + end + end + + def readline(prompt) do + IO.write(:stdio, prompt) + IO.read(:stdio, :line) + |> String.trim("\n") + end + + defp convert_vector({type, ast, meta}) when type == :map do + new_ast = Enum.map(ast, fn {key, value} -> + {key, convert_vector(value)} + end) + {:map, new_ast, meta} + end + defp convert_vector({type, ast, meta}) when type in [:list, :vector] do + new_ast = Enum.map(ast, &convert_vector/1) + {:list, new_ast, meta} + end + defp convert_vector(other), do: other + + defp equal([a, b]) do + convert_vector(a) == convert_vector(b) + end + + defp empty?([{_type, [], _meta}]), do: true + defp empty?(_), do: false + + defp count([{_type, ast, _meta}]), do: length(ast) + defp count(_), do: 0 + + defp pr_str(args) do + args + |> Enum.map(&Mal.Printer.print_str/1) + |> Enum.join(" ") + end + + defp str(args) do + args + |> Enum.map(&(Mal.Printer.print_str(&1, false))) + |> Enum.join("") + end + + defp prn(args) do + args + |> pr_str + |> IO.puts + nil + end + + defp println(args) do + args + |> Enum.map(&(Mal.Printer.print_str(&1, false))) + |> Enum.join(" ") + |> IO.puts + nil + end + + defp slurp([file_name]) do + case File.read(file_name) do + {:ok, content} -> content + {:error, :enoent} -> throw({:error, "can't find file #{file_name}"}) + {:error, :eisdir} -> throw({:error, "can't read directory #{file_name}"}) + {:error, :eaccess} -> throw({:error, "missing permissions #{file_name}"}) + {:error, reason} -> throw({:error, "can't read file #{file_name}, #{reason}"}) + end + end + + defp nth([{_type, ast, _meta}, index]) do + case Enum.at(ast, index, :error) do + :error -> throw({:error, "index out of bounds"}) + any -> any + end + end + + defp first([{_type, [head | _tail], _}]), do: head + defp first(_), do: nil + + defp rest([{_type, [_head | tail], _}]), do: list(tail) + defp rest([{_type, [], _}]), do: list([]) + defp rest([nil]), do: list([]) + + defp map([%Function{value: function}, ast]), do: do_map(function, ast) + defp map([function, ast]), do: do_map(function, ast) + + defp do_map(function, {_type, ast, _meta}) do + ast + |> Enum.map(fn arg -> function.([arg]) end) + |> list + end + + defp apply([%Function{value: function} | tail]), do: do_apply(function, tail) + defp apply([function | tail]), do: do_apply(function, tail) + + defp do_apply(function, tail) do + [{_type, ast, _meta} | reversed_args] = Enum.reverse(tail) + args = Enum.reverse(reversed_args) + func_args = Enum.concat(args, ast) + function.(func_args) + end + + defp keyword([atom]) when is_atom(atom), do: atom + defp keyword([atom]), do: String.to_atom(atom) + + defp cons([prepend, {_type, ast, meta}]), do: {:list, [prepend | ast], meta} + + defp concat(args) do + args + |> Enum.map(fn tuple -> elem(tuple, 1) end) + |> Enum.concat + |> list + end + + defp vec([{:list, xs, _}]), do: vector(xs) + defp vec([{:vector, xs, _}]), do: vector(xs) + defp vec([_]), do: throw({:error, "vec: arg type"}) + defp vec(_), do: throw({:error, "vec: arg count"}) + + defp assoc([{:map, hash_map, meta} | pairs]) do + {:map, merge, _} = hash_map(pairs) + {:map, Map.merge(hash_map, merge), meta} + end + + defp dissoc([{:map, hash_map, meta} | keys]) do + {:map, Map.drop(hash_map, keys), meta} + end + + defp get([{:map, map, _}, key]), do: Map.get(map, key, nil) + defp get(_), do: nil + + defp meta([{_type, _ast, meta}]), do: meta + defp meta([%Function{meta: meta}]), do: meta + defp meta(_), do: nil + + defp with_meta([{type, ast, _old_meta}, meta]), do: {type, ast, meta} + defp with_meta([%Function{} = func, meta]), do: %{func | meta: meta} + defp with_meta(_), do: nil + + defp deref(args) do + apply(&Mal.Atom.deref/1, args) + end + + defp reset!(args) do + apply(&Mal.Atom.reset!/2, args) + end + + defp swap!([atom, function | args]) do + Mal.Atom.swap!(atom, function, args) + end + + defp conj([{:list, ast, meta} | args]) do + new_list = Enum.reverse(args) ++ ast + {:list, new_list, meta} + end + + defp conj([{:vector, ast, meta} | args]) do + {:vector, ast ++ args, meta} + end + + defp seq([nil]), do: nil + defp seq([{:list, [], _meta}]), do: nil + defp seq([{:list, ast, meta}]), do: {:list, ast, meta} + defp seq([{:vector, [], _meta}]), do: nil + defp seq([{:vector, ast, meta}]), do: {:list, ast, meta} + defp seq([""]), do: nil + defp seq([s]), do: {:list, String.split(s, "", trim: true), nil} + defp seq(_), do: nil + + defp fn?([%Function{macro: false}]), do: true + defp fn?(_), do: false + + defp macro?([%Function{macro: true}]), do: true + defp macro?(_), do: false +end diff --git a/impls/elixir/lib/mal/env.ex b/impls/elixir/lib/mal/env.ex index c7ccc4a1a0..c35e9262fd 100644 --- a/impls/elixir/lib/mal/env.ex +++ b/impls/elixir/lib/mal/env.ex @@ -1,60 +1,60 @@ -defmodule Mal.Env do - import Mal.Types - - def new(outer \\ nil, binds \\ [], exprs \\ []) - def new(outer, binds, exprs) do - {:ok, pid} = Agent.start_link(fn -> - %{outer: outer, env: %{}} - end) - - set_bindings(pid, binds, exprs) - end - - defp set_bindings(pid, [], []), do: pid - defp set_bindings(pid, ["&", key], exprs) do - set(pid, key, list(exprs)) - pid - end - - defp set_bindings(pid, [key | binds], [value | exprs]) do - set(pid, key, value) - set_bindings(pid, binds, exprs) - end - - def set(pid, key, value) do - Agent.update(pid, fn map -> - %{map | :env => Map.put(map.env, key, value)} - end) - end - - def merge(pid, env_values) do - Agent.update(pid, fn map -> - %{map | :env => Map.merge(map.env, env_values)} - end) - end - - def find(pid, key) do - Agent.get(pid, fn map -> - case Map.has_key?(map.env, key) do - true -> pid - false -> map.outer && find(map.outer, key) - end - end) - end - - def retrieve_key(pid, key) do - Agent.get(pid, fn map -> - case Map.fetch(map.env, key) do - {:ok, value} -> {:ok, value} - :error -> :not_found - end - end) - end - - def get(pid, key) do - case find(pid, key) do - nil -> :not_found - env -> retrieve_key(env, key) - end - end -end +defmodule Mal.Env do + import Mal.Types + + def new(outer \\ nil, binds \\ [], exprs \\ []) + def new(outer, binds, exprs) do + {:ok, pid} = Agent.start_link(fn -> + %{outer: outer, env: %{}} + end) + + set_bindings(pid, binds, exprs) + end + + defp set_bindings(pid, [], []), do: pid + defp set_bindings(pid, ["&", key], exprs) do + set(pid, key, list(exprs)) + pid + end + + defp set_bindings(pid, [key | binds], [value | exprs]) do + set(pid, key, value) + set_bindings(pid, binds, exprs) + end + + def set(pid, key, value) do + Agent.update(pid, fn map -> + %{map | :env => Map.put(map.env, key, value)} + end) + end + + def merge(pid, env_values) do + Agent.update(pid, fn map -> + %{map | :env => Map.merge(map.env, env_values)} + end) + end + + def find(pid, key) do + Agent.get(pid, fn map -> + case Map.has_key?(map.env, key) do + true -> pid + false -> map.outer && find(map.outer, key) + end + end) + end + + def retrieve_key(pid, key) do + Agent.get(pid, fn map -> + case Map.fetch(map.env, key) do + {:ok, value} -> {:ok, value} + :error -> :not_found + end + end) + end + + def get(pid, key) do + case find(pid, key) do + nil -> :not_found + env -> retrieve_key(env, key) + end + end +end diff --git a/impls/elixir/lib/mal/printer.ex b/impls/elixir/lib/mal/printer.ex index 8651b3232a..d81d59cd56 100644 --- a/impls/elixir/lib/mal/printer.ex +++ b/impls/elixir/lib/mal/printer.ex @@ -1,50 +1,50 @@ -defmodule Mal.Printer do - alias Mal.Function - - def print_str(mal, print_readably \\ true) - def print_str(mal, _) when is_atom(mal), do: inspect(mal) - def print_str(mal, _) when is_integer(mal), do: Integer.to_string(mal) - def print_str(mal, _) when is_function(mal), do: inspect(mal) - def print_str(%Function{value: mal, macro: true}, _), do: "#Macro<#{inspect(mal)}" - def print_str(%Function{value: mal}, _), do: inspect(mal) - def print_str({:symbol, value}, _), do: value - def print_str({:exception, exception}, print_readably) do - print_str(exception, print_readably) - end - def print_str(mal, false) when is_bitstring(mal), do: mal - def print_str(mal, true) when is_bitstring(mal), do: inspect(mal) - - def print_str({:atom, _pid} = atom, print_readably) do - output = atom - |> Mal.Atom.deref - |> print_str(print_readably) - - "(atom #{output})" - end - - def print_str({:map, mal, _}, print_readably) do - evaluate_pair = fn {key, value} -> - "#{print_str(key, print_readably)} #{print_str(value, print_readably)}" - end - - output = mal - |> Enum.map(evaluate_pair) - |> Enum.join(" ") - - "{#{output}}" - end - - def print_str({:vector, vector, _}, print_readably) do - "[#{print_list(vector, print_readably)}]" - end - - def print_str({:list, mal, _}, print_readably) do - "(#{print_list(mal, print_readably)})" - end - - defp print_list(list, print_readably) do - list - |> Enum.map(fn(x) -> print_str(x, print_readably) end) - |> Enum.join(" ") - end -end +defmodule Mal.Printer do + alias Mal.Function + + def print_str(mal, print_readably \\ true) + def print_str(mal, _) when is_atom(mal), do: inspect(mal) + def print_str(mal, _) when is_integer(mal), do: Integer.to_string(mal) + def print_str(mal, _) when is_function(mal), do: inspect(mal) + def print_str(%Function{value: mal, macro: true}, _), do: "#Macro<#{inspect(mal)}" + def print_str(%Function{value: mal}, _), do: inspect(mal) + def print_str({:symbol, value}, _), do: value + def print_str({:exception, exception}, print_readably) do + print_str(exception, print_readably) + end + def print_str(mal, false) when is_bitstring(mal), do: mal + def print_str(mal, true) when is_bitstring(mal), do: inspect(mal) + + def print_str({:atom, _pid} = atom, print_readably) do + output = atom + |> Mal.Atom.deref + |> print_str(print_readably) + + "(atom #{output})" + end + + def print_str({:map, mal, _}, print_readably) do + evaluate_pair = fn {key, value} -> + "#{print_str(key, print_readably)} #{print_str(value, print_readably)}" + end + + output = mal + |> Enum.map(evaluate_pair) + |> Enum.join(" ") + + "{#{output}}" + end + + def print_str({:vector, vector, _}, print_readably) do + "[#{print_list(vector, print_readably)}]" + end + + def print_str({:list, mal, _}, print_readably) do + "(#{print_list(mal, print_readably)})" + end + + defp print_list(list, print_readably) do + list + |> Enum.map(fn(x) -> print_str(x, print_readably) end) + |> Enum.join(" ") + end +end diff --git a/impls/elixir/lib/mal/reader.ex b/impls/elixir/lib/mal/reader.ex index 07f3719c9a..655b6e44c1 100644 --- a/impls/elixir/lib/mal/reader.ex +++ b/impls/elixir/lib/mal/reader.ex @@ -1,101 +1,101 @@ -defmodule Mal.Reader do - import Mal.Types - - def read_str(input) do - case tokenize(input) do - [] -> nil - tokens -> tokens - |> read_form - |> elem(0) - end - end - - def tokenize(input) do - regex = ~r/[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ - Regex.scan(regex, input, capture: :all_but_first) - |> List.flatten - |> List.delete_at(-1) # Remove the last match, which is an empty string - |> Enum.filter(fn token -> not String.starts_with?(token, ";") end) - end - - defp read_form([next | rest] = tokens) do - case next do - "(" -> read_list(tokens) - "[" -> read_vector(tokens) - "{" -> read_hash_map(tokens) - "'" -> create_quote("quote", rest) - "`" -> create_quote("quasiquote", rest) - "~" -> create_quote("unquote", rest) - "~@" -> create_quote("splice-unquote", rest) - "@" -> create_quote("deref", rest) - "^" -> create_meta(rest) - ")" -> throw({:error, "unexpected )"}) - "]" -> throw({:error, "unexpected ]"}) - "}" -> throw({:error, "unexpected }"}) - _ -> - token = read_atom(next) - {token, rest} - end - end - - defp create_meta(tokens) do - {meta, meta_rest} = read_form(tokens) - {token, rest_tokens} = read_form(meta_rest) - new_token = list([{:symbol, "with-meta"}, token, meta]) - {new_token, rest_tokens} - end - - defp create_quote(quote_type, tokens) do - {token, rest_tokens} = read_form(tokens) - new_token = list([{:symbol, quote_type}, token]) - {new_token, rest_tokens} - end - - defp read_list([_ | tokens]) do - {ast, rest} = do_read_sequence(tokens, [], "(", ")") - {list(ast), rest} - end - - defp read_vector([_ | tokens]) do - {ast, rest} = do_read_sequence(tokens, [], "[", "]") - {vector(ast), rest} - end - - defp read_hash_map([_ | tokens]) do - {map, rest} = do_read_sequence(tokens, [], "{", "}") - {hash_map(map), rest} - end - - defp do_read_sequence([], _acc, _start_sep, end_sep), do: throw({:error, "expected #{end_sep}, got EOF"}) - defp do_read_sequence([head | tail] = tokens, acc, start_sep, end_sep) do - cond do - String.starts_with?(head, end_sep) -> - {Enum.reverse(acc), tail} - true -> - {token, rest} = read_form(tokens) - do_read_sequence(rest, [token | acc], start_sep, end_sep) - end - end - - defp read_atom("nil"), do: nil - defp read_atom("true"), do: true - defp read_atom("false"), do: false - defp read_atom(":" <> rest), do: String.to_atom(rest) - defp read_atom(token) do - cond do - String.match?(token, ~r/^"(?:\\.|[^\\"])*"$/) -> - token - |> Code.string_to_quoted - |> elem(1) - - String.starts_with?(token, "\"") -> - throw({:error, "expected '\"', got EOF"}) - - integer?(token) -> - Integer.parse(token) - |> elem(0) - - true -> {:symbol, token} - end - end -end +defmodule Mal.Reader do + import Mal.Types + + def read_str(input) do + case tokenize(input) do + [] -> nil + tokens -> tokens + |> read_form + |> elem(0) + end + end + + def tokenize(input) do + regex = ~r/[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ + Regex.scan(regex, input, capture: :all_but_first) + |> List.flatten + |> List.delete_at(-1) # Remove the last match, which is an empty string + |> Enum.filter(fn token -> not String.starts_with?(token, ";") end) + end + + defp read_form([next | rest] = tokens) do + case next do + "(" -> read_list(tokens) + "[" -> read_vector(tokens) + "{" -> read_hash_map(tokens) + "'" -> create_quote("quote", rest) + "`" -> create_quote("quasiquote", rest) + "~" -> create_quote("unquote", rest) + "~@" -> create_quote("splice-unquote", rest) + "@" -> create_quote("deref", rest) + "^" -> create_meta(rest) + ")" -> throw({:error, "unexpected )"}) + "]" -> throw({:error, "unexpected ]"}) + "}" -> throw({:error, "unexpected }"}) + _ -> + token = read_atom(next) + {token, rest} + end + end + + defp create_meta(tokens) do + {meta, meta_rest} = read_form(tokens) + {token, rest_tokens} = read_form(meta_rest) + new_token = list([{:symbol, "with-meta"}, token, meta]) + {new_token, rest_tokens} + end + + defp create_quote(quote_type, tokens) do + {token, rest_tokens} = read_form(tokens) + new_token = list([{:symbol, quote_type}, token]) + {new_token, rest_tokens} + end + + defp read_list([_ | tokens]) do + {ast, rest} = do_read_sequence(tokens, [], "(", ")") + {list(ast), rest} + end + + defp read_vector([_ | tokens]) do + {ast, rest} = do_read_sequence(tokens, [], "[", "]") + {vector(ast), rest} + end + + defp read_hash_map([_ | tokens]) do + {map, rest} = do_read_sequence(tokens, [], "{", "}") + {hash_map(map), rest} + end + + defp do_read_sequence([], _acc, _start_sep, end_sep), do: throw({:error, "expected #{end_sep}, got EOF"}) + defp do_read_sequence([head | tail] = tokens, acc, start_sep, end_sep) do + cond do + String.starts_with?(head, end_sep) -> + {Enum.reverse(acc), tail} + true -> + {token, rest} = read_form(tokens) + do_read_sequence(rest, [token | acc], start_sep, end_sep) + end + end + + defp read_atom("nil"), do: nil + defp read_atom("true"), do: true + defp read_atom("false"), do: false + defp read_atom(":" <> rest), do: String.to_atom(rest) + defp read_atom(token) do + cond do + String.match?(token, ~r/^"(?:\\.|[^\\"])*"$/) -> + token + |> Code.string_to_quoted + |> elem(1) + + String.starts_with?(token, "\"") -> + throw({:error, "expected '\"', got EOF"}) + + integer?(token) -> + Integer.parse(token) + |> elem(0) + + true -> {:symbol, token} + end + end +end diff --git a/impls/elixir/lib/mal/types.ex b/impls/elixir/lib/mal/types.ex index 6443c0b613..96ebc16bc3 100644 --- a/impls/elixir/lib/mal/types.ex +++ b/impls/elixir/lib/mal/types.ex @@ -1,42 +1,42 @@ -defmodule Mal.Types do - def integer?(input) do - Regex.match?(~r/^-?[0-9]+$/, input) - end - - def hash_map(ast) do - map = ast - |> Enum.chunk(2) - |> Enum.map(&List.to_tuple/1) - |> Enum.into(%{}) - - {:map, map, nil} - end - - def map?([{:map, _ast, _meta}]), do: true - def map?(_), do: false - - def list(ast), do: {:list, ast, nil} - - def list?([{:list, _, _}]), do: true - def list?(_), do: false - - def vector(ast), do: {:vector, ast, nil} - - def vector?([{:vector, _ast, _meta}]), do: true - def vector?(_), do: false - - def symbol?([{:symbol, _}]), do: true - def symbol?(_), do: false - - def atom([value]) do - pid = Mal.Atom.new(value) - {:atom, pid} - end - - def atom?([{:atom, _}]), do: true - def atom?(_), do: false -end - -defmodule Mal.Function do - defstruct value: nil, macro: false, meta: nil -end +defmodule Mal.Types do + def integer?(input) do + Regex.match?(~r/^-?[0-9]+$/, input) + end + + def hash_map(ast) do + map = ast + |> Enum.chunk(2) + |> Enum.map(&List.to_tuple/1) + |> Enum.into(%{}) + + {:map, map, nil} + end + + def map?([{:map, _ast, _meta}]), do: true + def map?(_), do: false + + def list(ast), do: {:list, ast, nil} + + def list?([{:list, _, _}]), do: true + def list?(_), do: false + + def vector(ast), do: {:vector, ast, nil} + + def vector?([{:vector, _ast, _meta}]), do: true + def vector?(_), do: false + + def symbol?([{:symbol, _}]), do: true + def symbol?(_), do: false + + def atom([value]) do + pid = Mal.Atom.new(value) + {:atom, pid} + end + + def atom?([{:atom, _}]), do: true + def atom?(_), do: false +end + +defmodule Mal.Function do + defstruct value: nil, macro: false, meta: nil +end diff --git a/impls/elixir/lib/mix/tasks/step0_repl.ex b/impls/elixir/lib/mix/tasks/step0_repl.ex index 4cd3efec2a..875beed599 100644 --- a/impls/elixir/lib/mix/tasks/step0_repl.ex +++ b/impls/elixir/lib/mix/tasks/step0_repl.ex @@ -1,30 +1,30 @@ -defmodule Mix.Tasks.Step0Repl do - def run(_), do: loop() - - defp loop do - Mal.Core.readline("user> ") - |> read_eval_print - |> IO.puts - - loop() - end - - defp read(input) do - input - end - - defp eval(input) do - input - end - - defp print(input) do - input - end - - defp read_eval_print(:eof), do: exit(:normal) - defp read_eval_print(line) do - read(line) - |> eval - |> print - end -end +defmodule Mix.Tasks.Step0Repl do + def run(_), do: loop() + + defp loop do + Mal.Core.readline("user> ") + |> read_eval_print + |> IO.puts + + loop() + end + + defp read(input) do + input + end + + defp eval(input) do + input + end + + defp print(input) do + input + end + + defp read_eval_print(:eof), do: exit(:normal) + defp read_eval_print(line) do + read(line) + |> eval + |> print + end +end diff --git a/impls/elixir/lib/mix/tasks/step1_read_print.ex b/impls/elixir/lib/mix/tasks/step1_read_print.ex index 9569e68fb6..3a522d8b98 100644 --- a/impls/elixir/lib/mix/tasks/step1_read_print.ex +++ b/impls/elixir/lib/mix/tasks/step1_read_print.ex @@ -1,30 +1,30 @@ -defmodule Mix.Tasks.Step1ReadPrint do - def run(_), do: loop() - - defp loop do - Mal.Core.readline("user> ") - |> read_eval_print - |> IO.puts - - loop() - end - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval(ast), do: ast - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof), do: exit(:normal) - defp read_eval_print(line) do - read(line) - |> eval - |> print - catch - {:error, message} -> IO.puts("Error: #{message}") - end -end +defmodule Mix.Tasks.Step1ReadPrint do + def run(_), do: loop() + + defp loop do + Mal.Core.readline("user> ") + |> read_eval_print + |> IO.puts + + loop() + end + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval(ast), do: ast + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof), do: exit(:normal) + defp read_eval_print(line) do + read(line) + |> eval + |> print + catch + {:error, message} -> IO.puts("Error: #{message}") + end +end diff --git a/impls/elixir/lib/mix/tasks/step2_eval.ex b/impls/elixir/lib/mix/tasks/step2_eval.ex index 8a1d68ac26..2848ae2fea 100644 --- a/impls/elixir/lib/mix/tasks/step2_eval.ex +++ b/impls/elixir/lib/mix/tasks/step2_eval.ex @@ -1,70 +1,70 @@ -defmodule Mix.Tasks.Step2Eval do - @repl_env %{ - "+" => &+/2, - "-" => &-/2, - "*" => &*/2, - "/" => &div/2 - } - - def run(_), do: loop() - - defp loop do - IO.write(:stdio, "user> ") - IO.read(:stdio, :line) - |> read_eval_print - |> IO.puts - - loop() - end - - defp eval_ast({:list, ast, meta}, env) when is_list(ast) do - {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:map, ast, meta}, env) do - map = for {key, value} <- ast, into: %{} do - {key, eval(value, env)} - end - - {:map, map, meta} - end - - defp eval_ast({:vector, ast, meta}, env) do - {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:symbol, symbol}, env) do - case Map.fetch(env, symbol) do - {:ok, value} -> value - :error -> throw({:error, "'#{symbol}' not found"}) - end - end - - defp eval_ast(ast, _env), do: ast - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval({:list, [], _} = empty_ast, _env), do: empty_ast - defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) - defp eval(ast, env), do: eval_ast(ast, env) - - defp eval_list(ast, env, meta) do - {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) - apply(func, args) - end - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof), do: exit(:normal) - defp read_eval_print(line) do - read(line) - |> eval(@repl_env) - |> print - catch - {:error, message} -> IO.puts("Error: #{message}") - end -end +defmodule Mix.Tasks.Step2Eval do + @repl_env %{ + "+" => &+/2, + "-" => &-/2, + "*" => &*/2, + "/" => &div/2 + } + + def run(_), do: loop() + + defp loop do + IO.write(:stdio, "user> ") + IO.read(:stdio, :line) + |> read_eval_print + |> IO.puts + + loop() + end + + defp eval_ast({:list, ast, meta}, env) when is_list(ast) do + {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:map, ast, meta}, env) do + map = for {key, value} <- ast, into: %{} do + {key, eval(value, env)} + end + + {:map, map, meta} + end + + defp eval_ast({:vector, ast, meta}, env) do + {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:symbol, symbol}, env) do + case Map.fetch(env, symbol) do + {:ok, value} -> value + :error -> throw({:error, "'#{symbol}' not found"}) + end + end + + defp eval_ast(ast, _env), do: ast + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast + defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) + defp eval(ast, env), do: eval_ast(ast, env) + + defp eval_list(ast, env, meta) do + {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) + apply(func, args) + end + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof), do: exit(:normal) + defp read_eval_print(line) do + read(line) + |> eval(@repl_env) + |> print + catch + {:error, message} -> IO.puts("Error: #{message}") + end +end diff --git a/impls/elixir/lib/mix/tasks/step3_env.ex b/impls/elixir/lib/mix/tasks/step3_env.ex index 1f13424176..c9d9400b8f 100644 --- a/impls/elixir/lib/mix/tasks/step3_env.ex +++ b/impls/elixir/lib/mix/tasks/step3_env.ex @@ -1,95 +1,95 @@ -defmodule Mix.Tasks.Step3Env do - @initial_env %{ - "+" => &+/2, - "-" => &-/2, - "*" => &*/2, - "/" => &div/2 - } - - def run(_) do - env = Mal.Env.new() - Mal.Env.merge(env, @initial_env) - loop(env) - end - - defp loop(env) do - IO.write(:stdio, "user> ") - IO.read(:stdio, :line) - |> read_eval_print(env) - |> IO.puts - - loop(env) - end - - defp eval_ast({:list, ast, meta}, env) when is_list(ast) do - {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:map, ast, meta}, env) do - map = for {key, value} <- ast, into: %{} do - {key, eval(value, env)} - end - - {:map, map, meta} - end - - defp eval_ast({:vector, ast, meta}, env) do - {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:symbol, symbol}, env) do - case Mal.Env.get(env, symbol) do - {:ok, value} -> value - :not_found -> throw({:error, "'#{symbol}' not found"}) - end - end - - defp eval_ast(ast, _env), do: ast - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval_bindings([], env), do: env - defp eval_bindings([{:symbol, key}, binding | tail], env) do - evaluated = eval(binding, env) - Mal.Env.set(env, key, evaluated) - eval_bindings(tail, env) - end - defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - - defp eval({:list, [], _} = empty_ast, _env), do: empty_ast - defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) - defp eval(ast, env), do: eval_ast(ast, env) - - defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do - evaluated = eval(value, env) - Mal.Env.set(env, key, evaluated) - evaluated - end - - defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) - when list_type == :list or list_type == :vector do - let_env = Mal.Env.new(env) - eval_bindings(bindings, let_env) - eval(body, let_env) - end - - defp eval_list(ast, env, meta) do - {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) - apply(func, args) - end - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof, _env), do: exit(:normal) - defp read_eval_print(line, env) do - read(line) - |> eval(env) - |> print - catch - {:error, message} -> IO.puts("Error: #{message}") - end -end +defmodule Mix.Tasks.Step3Env do + @initial_env %{ + "+" => &+/2, + "-" => &-/2, + "*" => &*/2, + "/" => &div/2 + } + + def run(_) do + env = Mal.Env.new() + Mal.Env.merge(env, @initial_env) + loop(env) + end + + defp loop(env) do + IO.write(:stdio, "user> ") + IO.read(:stdio, :line) + |> read_eval_print(env) + |> IO.puts + + loop(env) + end + + defp eval_ast({:list, ast, meta}, env) when is_list(ast) do + {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:map, ast, meta}, env) do + map = for {key, value} <- ast, into: %{} do + {key, eval(value, env)} + end + + {:map, map, meta} + end + + defp eval_ast({:vector, ast, meta}, env) do + {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:symbol, symbol}, env) do + case Mal.Env.get(env, symbol) do + {:ok, value} -> value + :not_found -> throw({:error, "'#{symbol}' not found"}) + end + end + + defp eval_ast(ast, _env), do: ast + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval_bindings([], env), do: env + defp eval_bindings([{:symbol, key}, binding | tail], env) do + evaluated = eval(binding, env) + Mal.Env.set(env, key, evaluated) + eval_bindings(tail, env) + end + defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) + + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast + defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) + defp eval(ast, env), do: eval_ast(ast, env) + + defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do + evaluated = eval(value, env) + Mal.Env.set(env, key, evaluated) + evaluated + end + + defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) + when list_type == :list or list_type == :vector do + let_env = Mal.Env.new(env) + eval_bindings(bindings, let_env) + eval(body, let_env) + end + + defp eval_list(ast, env, meta) do + {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) + apply(func, args) + end + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof, _env), do: exit(:normal) + defp read_eval_print(line, env) do + read(line) + |> eval(env) + |> print + catch + {:error, message} -> IO.puts("Error: #{message}") + end +end diff --git a/impls/elixir/lib/mix/tasks/step4_if_fn_do.ex b/impls/elixir/lib/mix/tasks/step4_if_fn_do.ex index ece1f0b858..e2baa8cbab 100644 --- a/impls/elixir/lib/mix/tasks/step4_if_fn_do.ex +++ b/impls/elixir/lib/mix/tasks/step4_if_fn_do.ex @@ -1,136 +1,136 @@ -defmodule Mix.Tasks.Step4IfFnDo do - import Mal.Types - alias Mal.Function - - def run(_) do - env = Mal.Env.new() - Mal.Env.merge(env, Mal.Core.namespace) - bootstrap(env) - loop(env) - end - - defp bootstrap(env) do - # not: - read_eval_print(""" - (def! not - (fn* (a) (if a false true))) - """, env) - - Mal.Env.set(env, "eval", %Function{value: fn [ast] -> - eval(ast, env) - end}) - end - - defp loop(env) do - IO.write(:stdio, "user> ") - IO.read(:stdio, :line) - |> read_eval_print(env) - |> IO.puts - - loop(env) - end - - defp eval_ast({:list, ast, meta}, env) when is_list(ast) do - {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:map, ast, meta}, env) do - map = for {key, value} <- ast, into: %{} do - {key, eval(value, env)} - end - - {:map, map, meta} - end - - defp eval_ast({:vector, ast, meta}, env) do - {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:symbol, symbol}, env) do - case Mal.Env.get(env, symbol) do - {:ok, value} -> value - :not_found -> throw({:error, "'#{symbol}' not found"}) - end - end - - defp eval_ast(ast, _env), do: ast - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval_bindings([], env), do: env - defp eval_bindings([{:symbol, key}, binding | tail], env) do - evaluated = eval(binding, env) - Mal.Env.set(env, key, evaluated) - eval_bindings(tail, env) - end - defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - - defp eval({:list, [], _} = empty_ast, _env), do: empty_ast - defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) - defp eval(ast, env), do: eval_ast(ast, env) - - defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do - result = eval(condition, env) - if result == nil or result == false do - case if_false do - [] -> nil - [body] -> eval(body, env) - end - else - eval(if_true, env) - end - end - - defp eval_list([{:symbol, "do"} | ast], env, _) do - ast - |> List.delete_at(-1) - |> list - |> eval_ast(env) - eval(List.last(ast), env) - end - - defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do - evaluated = eval(value, env) - Mal.Env.set(env, key, evaluated) - evaluated - end - - defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) - when list_type == :list or list_type == :vector do - let_env = Mal.Env.new(env) - eval_bindings(bindings, let_env) - eval(body, let_env) - end - - defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) - when list_type == :list or list_type == :vector do - param_symbols = for {:symbol, symbol} <- params, do: symbol - - closure = fn args -> - inner = Mal.Env.new(env, param_symbols, args) - eval(body, inner) - end - - %Function{value: closure} - end - - defp eval_list(ast, env, meta) do - {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) - func.value.(args) - end - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof, _env), do: exit(:normal) - defp read_eval_print(line, env) do - read(line) - |> eval(env) - |> print - catch - {:error, message} -> IO.puts("Error: #{message}") - end -end +defmodule Mix.Tasks.Step4IfFnDo do + import Mal.Types + alias Mal.Function + + def run(_) do + env = Mal.Env.new() + Mal.Env.merge(env, Mal.Core.namespace) + bootstrap(env) + loop(env) + end + + defp bootstrap(env) do + # not: + read_eval_print(""" + (def! not + (fn* (a) (if a false true))) + """, env) + + Mal.Env.set(env, "eval", %Function{value: fn [ast] -> + eval(ast, env) + end}) + end + + defp loop(env) do + IO.write(:stdio, "user> ") + IO.read(:stdio, :line) + |> read_eval_print(env) + |> IO.puts + + loop(env) + end + + defp eval_ast({:list, ast, meta}, env) when is_list(ast) do + {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:map, ast, meta}, env) do + map = for {key, value} <- ast, into: %{} do + {key, eval(value, env)} + end + + {:map, map, meta} + end + + defp eval_ast({:vector, ast, meta}, env) do + {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:symbol, symbol}, env) do + case Mal.Env.get(env, symbol) do + {:ok, value} -> value + :not_found -> throw({:error, "'#{symbol}' not found"}) + end + end + + defp eval_ast(ast, _env), do: ast + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval_bindings([], env), do: env + defp eval_bindings([{:symbol, key}, binding | tail], env) do + evaluated = eval(binding, env) + Mal.Env.set(env, key, evaluated) + eval_bindings(tail, env) + end + defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) + + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast + defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) + defp eval(ast, env), do: eval_ast(ast, env) + + defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do + result = eval(condition, env) + if result == nil or result == false do + case if_false do + [] -> nil + [body] -> eval(body, env) + end + else + eval(if_true, env) + end + end + + defp eval_list([{:symbol, "do"} | ast], env, _) do + ast + |> List.delete_at(-1) + |> list + |> eval_ast(env) + eval(List.last(ast), env) + end + + defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do + evaluated = eval(value, env) + Mal.Env.set(env, key, evaluated) + evaluated + end + + defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) + when list_type == :list or list_type == :vector do + let_env = Mal.Env.new(env) + eval_bindings(bindings, let_env) + eval(body, let_env) + end + + defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) + when list_type == :list or list_type == :vector do + param_symbols = for {:symbol, symbol} <- params, do: symbol + + closure = fn args -> + inner = Mal.Env.new(env, param_symbols, args) + eval(body, inner) + end + + %Function{value: closure} + end + + defp eval_list(ast, env, meta) do + {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) + func.value.(args) + end + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof, _env), do: exit(:normal) + defp read_eval_print(line, env) do + read(line) + |> eval(env) + |> print + catch + {:error, message} -> IO.puts("Error: #{message}") + end +end diff --git a/impls/elixir/lib/mix/tasks/step5_tco.ex b/impls/elixir/lib/mix/tasks/step5_tco.ex index eaf69d2554..92226119bb 100644 --- a/impls/elixir/lib/mix/tasks/step5_tco.ex +++ b/impls/elixir/lib/mix/tasks/step5_tco.ex @@ -1,139 +1,139 @@ -defmodule Mix.Tasks.Step5Tco do - import Mal.Types - alias Mal.Function - - def run(_) do - env = Mal.Env.new() - Mal.Env.merge(env, Mal.Core.namespace) - bootstrap(env) - loop(env) - end - - defp bootstrap(env) do - # not: - read_eval_print(""" - (def! not - (fn* (a) (if a false true))) - """, env) - - Mal.Env.set(env, "eval", %Function{value: fn [ast] -> - eval(ast, env) - end}) - end - - defp loop(env) do - IO.write(:stdio, "user> ") - IO.read(:stdio, :line) - |> read_eval_print(env) - |> IO.puts - - loop(env) - end - - defp eval_ast({:list, ast, meta}, env) when is_list(ast) do - {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:map, ast, meta}, env) do - map = for {key, value} <- ast, into: %{} do - {key, eval(value, env)} - end - - {:map, map, meta} - end - - defp eval_ast({:vector, ast, meta}, env) do - {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:symbol, symbol}, env) do - case Mal.Env.get(env, symbol) do - {:ok, value} -> value - :not_found -> throw({:error, "'#{symbol}' not found"}) - end - end - - defp eval_ast(ast, _env), do: ast - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval_bindings([], env), do: env - defp eval_bindings([{:symbol, key}, binding | tail], env) do - evaluated = eval(binding, env) - Mal.Env.set(env, key, evaluated) - eval_bindings(tail, env) - end - defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - - defp eval({:list, [], _} = empty_ast, _env), do: empty_ast - defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) - defp eval(ast, env), do: eval_ast(ast, env) - - defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do - result = eval(condition, env) - if result == nil or result == false do - case if_false do - [] -> nil - [body] -> eval(body, env) - end - else - eval(if_true, env) - end - end - - defp eval_list([{:symbol, "do"} | ast], env, _) do - ast - |> List.delete_at(-1) - |> list - |> eval_ast(env) - eval(List.last(ast), env) - end - - defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do - evaluated = eval(value, env) - Mal.Env.set(env, key, evaluated) - evaluated - end - - defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) - when list_type == :list or list_type == :vector do - let_env = Mal.Env.new(env) - eval_bindings(bindings, let_env) - eval(body, let_env) - end - - defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) - when list_type == :list or list_type == :vector do - param_symbols = for {:symbol, symbol} <- params, do: symbol - - closure = fn args -> - inner = Mal.Env.new(env, param_symbols, args) - eval(body, inner) - end - - %Function{value: closure} - end - - defp eval_list(ast, env, meta) do - {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) - case func do - %Function{value: closure} -> closure.(args) - _ -> func.(args) - end - end - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof, _env), do: exit(:normal) - defp read_eval_print(line, env) do - read(line) - |> eval(env) - |> print - catch - {:error, message} -> IO.puts("Error: #{message}") - end -end +defmodule Mix.Tasks.Step5Tco do + import Mal.Types + alias Mal.Function + + def run(_) do + env = Mal.Env.new() + Mal.Env.merge(env, Mal.Core.namespace) + bootstrap(env) + loop(env) + end + + defp bootstrap(env) do + # not: + read_eval_print(""" + (def! not + (fn* (a) (if a false true))) + """, env) + + Mal.Env.set(env, "eval", %Function{value: fn [ast] -> + eval(ast, env) + end}) + end + + defp loop(env) do + IO.write(:stdio, "user> ") + IO.read(:stdio, :line) + |> read_eval_print(env) + |> IO.puts + + loop(env) + end + + defp eval_ast({:list, ast, meta}, env) when is_list(ast) do + {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:map, ast, meta}, env) do + map = for {key, value} <- ast, into: %{} do + {key, eval(value, env)} + end + + {:map, map, meta} + end + + defp eval_ast({:vector, ast, meta}, env) do + {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:symbol, symbol}, env) do + case Mal.Env.get(env, symbol) do + {:ok, value} -> value + :not_found -> throw({:error, "'#{symbol}' not found"}) + end + end + + defp eval_ast(ast, _env), do: ast + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval_bindings([], env), do: env + defp eval_bindings([{:symbol, key}, binding | tail], env) do + evaluated = eval(binding, env) + Mal.Env.set(env, key, evaluated) + eval_bindings(tail, env) + end + defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) + + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast + defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) + defp eval(ast, env), do: eval_ast(ast, env) + + defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do + result = eval(condition, env) + if result == nil or result == false do + case if_false do + [] -> nil + [body] -> eval(body, env) + end + else + eval(if_true, env) + end + end + + defp eval_list([{:symbol, "do"} | ast], env, _) do + ast + |> List.delete_at(-1) + |> list + |> eval_ast(env) + eval(List.last(ast), env) + end + + defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do + evaluated = eval(value, env) + Mal.Env.set(env, key, evaluated) + evaluated + end + + defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) + when list_type == :list or list_type == :vector do + let_env = Mal.Env.new(env) + eval_bindings(bindings, let_env) + eval(body, let_env) + end + + defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) + when list_type == :list or list_type == :vector do + param_symbols = for {:symbol, symbol} <- params, do: symbol + + closure = fn args -> + inner = Mal.Env.new(env, param_symbols, args) + eval(body, inner) + end + + %Function{value: closure} + end + + defp eval_list(ast, env, meta) do + {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) + case func do + %Function{value: closure} -> closure.(args) + _ -> func.(args) + end + end + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof, _env), do: exit(:normal) + defp read_eval_print(line, env) do + read(line) + |> eval(env) + |> print + catch + {:error, message} -> IO.puts("Error: #{message}") + end +end diff --git a/impls/elixir/lib/mix/tasks/step6_file.ex b/impls/elixir/lib/mix/tasks/step6_file.ex index f0bdc5de59..478c36b7bf 100644 --- a/impls/elixir/lib/mix/tasks/step6_file.ex +++ b/impls/elixir/lib/mix/tasks/step6_file.ex @@ -1,159 +1,159 @@ -defmodule Mix.Tasks.Step6File do - import Mal.Types - alias Mal.Function - - def run(args) do - env = Mal.Env.new() - Mal.Env.merge(env, Mal.Core.namespace) - bootstrap(args, env) - loop(env) - end - - defp load_file(file_name, env) do - read_eval_print(""" - (load-file "#{file_name}") - """, env) - exit(:normal) - end - - defp bootstrap(args, env) do - # not: - read_eval_print(""" - (def! not - (fn* (a) (if a false true))) - """, env) - - # load-file: - read_eval_print(""" - (def! load-file - (fn* (f) - (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - """, env) - - Mal.Env.set(env, "eval", %Function{value: fn [ast] -> - eval(ast, env) - end}) - - case args do - [file_name | rest] -> - Mal.Env.set(env, "*ARGV*", list(rest)) - load_file(file_name, env) - - [] -> - Mal.Env.set(env, "*ARGV*", list([])) - end - end - - defp loop(env) do - IO.write(:stdio, "user> ") - IO.read(:stdio, :line) - |> read_eval_print(env) - |> IO.puts - - loop(env) - end - - defp eval_ast({:list, ast, meta}, env) when is_list(ast) do - {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:map, ast, meta}, env) do - map = for {key, value} <- ast, into: %{} do - {key, eval(value, env)} - end - - {:map, map, meta} - end - - defp eval_ast({:vector, ast, meta}, env) do - {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:symbol, symbol}, env) do - case Mal.Env.get(env, symbol) do - {:ok, value} -> value - :not_found -> throw({:error, "'#{symbol}' not found"}) - end - end - - defp eval_ast(ast, _env), do: ast - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval_bindings([], env), do: env - defp eval_bindings([{:symbol, key}, binding | tail], env) do - evaluated = eval(binding, env) - Mal.Env.set(env, key, evaluated) - eval_bindings(tail, env) - end - defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - - defp eval({:list, [], _} = empty_ast, _env), do: empty_ast - defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) - defp eval(ast, env), do: eval_ast(ast, env) - - defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do - result = eval(condition, env) - if result == nil or result == false do - case if_false do - [] -> nil - [body] -> eval(body, env) - end - else - eval(if_true, env) - end - end - - defp eval_list([{:symbol, "do"} | ast], env, _) do - ast - |> List.delete_at(-1) - |> list - |> eval_ast(env) - eval(List.last(ast), env) - end - - defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do - evaluated = eval(value, env) - Mal.Env.set(env, key, evaluated) - evaluated - end - - defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) - when list_type == :list or list_type == :vector do - let_env = Mal.Env.new(env) - eval_bindings(bindings, let_env) - eval(body, let_env) - end - - defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) - when list_type == :list or list_type == :vector do - param_symbols = for {:symbol, symbol} <- params, do: symbol - - closure = fn args -> - inner = Mal.Env.new(env, param_symbols, args) - eval(body, inner) - end - - %Function{value: closure} - end - - defp eval_list(ast, env, meta) do - {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) - func.value.(args) - end - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof, _env), do: exit(:normal) - defp read_eval_print(line, env) do - read(line) - |> eval(env) - |> print - catch - {:error, message} -> IO.puts("Error: #{message}") - end -end +defmodule Mix.Tasks.Step6File do + import Mal.Types + alias Mal.Function + + def run(args) do + env = Mal.Env.new() + Mal.Env.merge(env, Mal.Core.namespace) + bootstrap(args, env) + loop(env) + end + + defp load_file(file_name, env) do + read_eval_print(""" + (load-file "#{file_name}") + """, env) + exit(:normal) + end + + defp bootstrap(args, env) do + # not: + read_eval_print(""" + (def! not + (fn* (a) (if a false true))) + """, env) + + # load-file: + read_eval_print(""" + (def! load-file + (fn* (f) + (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + """, env) + + Mal.Env.set(env, "eval", %Function{value: fn [ast] -> + eval(ast, env) + end}) + + case args do + [file_name | rest] -> + Mal.Env.set(env, "*ARGV*", list(rest)) + load_file(file_name, env) + + [] -> + Mal.Env.set(env, "*ARGV*", list([])) + end + end + + defp loop(env) do + IO.write(:stdio, "user> ") + IO.read(:stdio, :line) + |> read_eval_print(env) + |> IO.puts + + loop(env) + end + + defp eval_ast({:list, ast, meta}, env) when is_list(ast) do + {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:map, ast, meta}, env) do + map = for {key, value} <- ast, into: %{} do + {key, eval(value, env)} + end + + {:map, map, meta} + end + + defp eval_ast({:vector, ast, meta}, env) do + {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:symbol, symbol}, env) do + case Mal.Env.get(env, symbol) do + {:ok, value} -> value + :not_found -> throw({:error, "'#{symbol}' not found"}) + end + end + + defp eval_ast(ast, _env), do: ast + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval_bindings([], env), do: env + defp eval_bindings([{:symbol, key}, binding | tail], env) do + evaluated = eval(binding, env) + Mal.Env.set(env, key, evaluated) + eval_bindings(tail, env) + end + defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) + + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast + defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) + defp eval(ast, env), do: eval_ast(ast, env) + + defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do + result = eval(condition, env) + if result == nil or result == false do + case if_false do + [] -> nil + [body] -> eval(body, env) + end + else + eval(if_true, env) + end + end + + defp eval_list([{:symbol, "do"} | ast], env, _) do + ast + |> List.delete_at(-1) + |> list + |> eval_ast(env) + eval(List.last(ast), env) + end + + defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do + evaluated = eval(value, env) + Mal.Env.set(env, key, evaluated) + evaluated + end + + defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) + when list_type == :list or list_type == :vector do + let_env = Mal.Env.new(env) + eval_bindings(bindings, let_env) + eval(body, let_env) + end + + defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) + when list_type == :list or list_type == :vector do + param_symbols = for {:symbol, symbol} <- params, do: symbol + + closure = fn args -> + inner = Mal.Env.new(env, param_symbols, args) + eval(body, inner) + end + + %Function{value: closure} + end + + defp eval_list(ast, env, meta) do + {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) + func.value.(args) + end + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof, _env), do: exit(:normal) + defp read_eval_print(line, env) do + read(line) + |> eval(env) + |> print + catch + {:error, message} -> IO.puts("Error: #{message}") + end +end diff --git a/impls/elixir/lib/mix/tasks/step7_quote.ex b/impls/elixir/lib/mix/tasks/step7_quote.ex index bffad9e465..53961a85dc 100644 --- a/impls/elixir/lib/mix/tasks/step7_quote.ex +++ b/impls/elixir/lib/mix/tasks/step7_quote.ex @@ -1,185 +1,185 @@ -defmodule Mix.Tasks.Step7Quote do - import Mal.Types - alias Mal.Function - - def run(args) do - env = Mal.Env.new() - Mal.Env.merge(env, Mal.Core.namespace) - bootstrap(args, env) - loop(env) - end - - defp load_file(file_name, env) do - read_eval_print(""" - (load-file "#{file_name}") - """, env) - exit(:normal) - end - - defp bootstrap(args, env) do - # not: - read_eval_print(""" - (def! not - (fn* (a) (if a false true))) - """, env) - - # load-file: - read_eval_print(""" - (def! load-file - (fn* (f) - (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - """, env) - - Mal.Env.set(env, "eval", %Function{value: fn [ast] -> - eval(ast, env) - end}) - - case args do - [file_name | rest] -> - Mal.Env.set(env, "*ARGV*", list(rest)) - load_file(file_name, env) - - [] -> - Mal.Env.set(env, "*ARGV*", list([])) - end - end - - defp loop(env) do - IO.write(:stdio, "user> ") - IO.read(:stdio, :line) - |> read_eval_print(env) - |> IO.puts - - loop(env) - end - - defp eval_ast({:list, ast, meta}, env) when is_list(ast) do - {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:map, ast, meta}, env) do - map = for {key, value} <- ast, into: %{} do - {key, eval(value, env)} - end - - {:map, map, meta} - end - - defp eval_ast({:vector, ast, meta}, env) do - {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:symbol, symbol}, env) do - case Mal.Env.get(env, symbol) do - {:ok, value} -> value - :not_found -> throw({:error, "'#{symbol}' not found"}) - end - end - - defp eval_ast(ast, _env), do: ast - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval_bindings([], env), do: env - defp eval_bindings([{:symbol, key}, binding | tail], env) do - evaluated = eval(binding, env) - Mal.Env.set(env, key, evaluated) - eval_bindings(tail, env) - end - defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - - defp quasiquote({:list, [{:symbol, "unquote"}, arg], _}), do: arg - defp quasiquote({:list, [{:symbol, "unquote"}| _], _}), do: throw({:error, "unquote: arg count"}) - defp quasiquote({:list, xs, _}), do: qq_foldr(xs) - defp quasiquote({:vector, xs, _}), do: list([{:symbol, "vec"}, qq_foldr(xs)]) - defp quasiquote({:symbol, sym}), do: list([{:symbol, "quote"}, {:symbol, sym}]) - defp quasiquote({:map, ast, meta}), do: list([{:symbol, "quote"}, {:map, ast, meta}]) - defp quasiquote(ast), do: ast - - defp qq_foldr([]), do: list([]) - defp qq_foldr([x|xs]), do: qq_loop(x, qq_foldr xs) - - defp qq_loop({:list, [{:symbol, "splice-unquote"}, arg], _}, acc), do: list([{:symbol, "concat"}, arg, acc]) - defp qq_loop({:list, [{:symbol, "splice-unquote"}| _], _}, _), do: throw({:error, "splice-unquote: arg count"}) - defp qq_loop(elt, acc), do: list([{:symbol, "cons"}, quasiquote(elt), acc]) - - defp eval({:list, [], _} = empty_ast, _env), do: empty_ast - defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) - defp eval(ast, env), do: eval_ast(ast, env) - - defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do - result = eval(condition, env) - if result == nil or result == false do - case if_false do - [] -> nil - [body] -> eval(body, env) - end - else - eval(if_true, env) - end - end - - defp eval_list([{:symbol, "do"} | ast], env, _) do - ast - |> List.delete_at(-1) - |> list - |> eval_ast(env) - eval(List.last(ast), env) - end - - defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do - evaluated = eval(value, env) - Mal.Env.set(env, key, evaluated) - evaluated - end - - defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) - when list_type == :list or list_type == :vector do - let_env = Mal.Env.new(env) - eval_bindings(bindings, let_env) - eval(body, let_env) - end - - defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) - when list_type == :list or list_type == :vector do - param_symbols = for {:symbol, symbol} <- params, do: symbol - - closure = fn args -> - inner = Mal.Env.new(env, param_symbols, args) - eval(body, inner) - end - - %Function{value: closure} - end - - defp eval_list([{:symbol, "quote"}, arg], _env, _), do: arg - - defp eval_list([{:symbol, "quasiquoteexpand"}, ast], _, _) do - quasiquote(ast) - end - - defp eval_list([{:symbol, "quasiquote"}, ast], env, _) do - ast |> quasiquote - |> eval(env) - end - - defp eval_list(ast, env, meta) do - {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) - func.value.(args) - end - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof, _env), do: exit(:normal) - defp read_eval_print(line, env) do - read(line) - |> eval(env) - |> print - catch - {:error, message} -> IO.puts("Error: #{message}") - end -end +defmodule Mix.Tasks.Step7Quote do + import Mal.Types + alias Mal.Function + + def run(args) do + env = Mal.Env.new() + Mal.Env.merge(env, Mal.Core.namespace) + bootstrap(args, env) + loop(env) + end + + defp load_file(file_name, env) do + read_eval_print(""" + (load-file "#{file_name}") + """, env) + exit(:normal) + end + + defp bootstrap(args, env) do + # not: + read_eval_print(""" + (def! not + (fn* (a) (if a false true))) + """, env) + + # load-file: + read_eval_print(""" + (def! load-file + (fn* (f) + (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + """, env) + + Mal.Env.set(env, "eval", %Function{value: fn [ast] -> + eval(ast, env) + end}) + + case args do + [file_name | rest] -> + Mal.Env.set(env, "*ARGV*", list(rest)) + load_file(file_name, env) + + [] -> + Mal.Env.set(env, "*ARGV*", list([])) + end + end + + defp loop(env) do + IO.write(:stdio, "user> ") + IO.read(:stdio, :line) + |> read_eval_print(env) + |> IO.puts + + loop(env) + end + + defp eval_ast({:list, ast, meta}, env) when is_list(ast) do + {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:map, ast, meta}, env) do + map = for {key, value} <- ast, into: %{} do + {key, eval(value, env)} + end + + {:map, map, meta} + end + + defp eval_ast({:vector, ast, meta}, env) do + {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:symbol, symbol}, env) do + case Mal.Env.get(env, symbol) do + {:ok, value} -> value + :not_found -> throw({:error, "'#{symbol}' not found"}) + end + end + + defp eval_ast(ast, _env), do: ast + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval_bindings([], env), do: env + defp eval_bindings([{:symbol, key}, binding | tail], env) do + evaluated = eval(binding, env) + Mal.Env.set(env, key, evaluated) + eval_bindings(tail, env) + end + defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) + + defp quasiquote({:list, [{:symbol, "unquote"}, arg], _}), do: arg + defp quasiquote({:list, [{:symbol, "unquote"}| _], _}), do: throw({:error, "unquote: arg count"}) + defp quasiquote({:list, xs, _}), do: qq_foldr(xs) + defp quasiquote({:vector, xs, _}), do: list([{:symbol, "vec"}, qq_foldr(xs)]) + defp quasiquote({:symbol, sym}), do: list([{:symbol, "quote"}, {:symbol, sym}]) + defp quasiquote({:map, ast, meta}), do: list([{:symbol, "quote"}, {:map, ast, meta}]) + defp quasiquote(ast), do: ast + + defp qq_foldr([]), do: list([]) + defp qq_foldr([x|xs]), do: qq_loop(x, qq_foldr xs) + + defp qq_loop({:list, [{:symbol, "splice-unquote"}, arg], _}, acc), do: list([{:symbol, "concat"}, arg, acc]) + defp qq_loop({:list, [{:symbol, "splice-unquote"}| _], _}, _), do: throw({:error, "splice-unquote: arg count"}) + defp qq_loop(elt, acc), do: list([{:symbol, "cons"}, quasiquote(elt), acc]) + + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast + defp eval({:list, ast, meta}, env), do: eval_list(ast, env, meta) + defp eval(ast, env), do: eval_ast(ast, env) + + defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do + result = eval(condition, env) + if result == nil or result == false do + case if_false do + [] -> nil + [body] -> eval(body, env) + end + else + eval(if_true, env) + end + end + + defp eval_list([{:symbol, "do"} | ast], env, _) do + ast + |> List.delete_at(-1) + |> list + |> eval_ast(env) + eval(List.last(ast), env) + end + + defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do + evaluated = eval(value, env) + Mal.Env.set(env, key, evaluated) + evaluated + end + + defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) + when list_type == :list or list_type == :vector do + let_env = Mal.Env.new(env) + eval_bindings(bindings, let_env) + eval(body, let_env) + end + + defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) + when list_type == :list or list_type == :vector do + param_symbols = for {:symbol, symbol} <- params, do: symbol + + closure = fn args -> + inner = Mal.Env.new(env, param_symbols, args) + eval(body, inner) + end + + %Function{value: closure} + end + + defp eval_list([{:symbol, "quote"}, arg], _env, _), do: arg + + defp eval_list([{:symbol, "quasiquoteexpand"}, ast], _, _) do + quasiquote(ast) + end + + defp eval_list([{:symbol, "quasiquote"}, ast], env, _) do + ast |> quasiquote + |> eval(env) + end + + defp eval_list(ast, env, meta) do + {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) + func.value.(args) + end + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof, _env), do: exit(:normal) + defp read_eval_print(line, env) do + read(line) + |> eval(env) + |> print + catch + {:error, message} -> IO.puts("Error: #{message}") + end +end diff --git a/impls/elixir/lib/mix/tasks/step8_macros.ex b/impls/elixir/lib/mix/tasks/step8_macros.ex index 4152deb1bf..c7658e569b 100644 --- a/impls/elixir/lib/mix/tasks/step8_macros.ex +++ b/impls/elixir/lib/mix/tasks/step8_macros.ex @@ -1,232 +1,232 @@ -defmodule Mix.Tasks.Step8Macros do - import Mal.Types - alias Mal.Function - - def run(args) do - env = Mal.Env.new() - Mal.Env.merge(env, Mal.Core.namespace) - bootstrap(args, env) - loop(env) - end - - defp load_file(file_name, env) do - read_eval_print(""" - (load-file "#{file_name}") - """, env) - exit(:normal) - end - - defp bootstrap(args, env) do - # not: - read_eval_print(""" - (def! not - (fn* (a) (if a false true))) - """, env) - - # load-file: - read_eval_print(""" - (def! load-file - (fn* (f) - (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - """, env) - - # cond - read_eval_print(""" - (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)))))))" - """, env) - - Mal.Env.set(env, "eval", %Function{value: fn [ast] -> - eval(ast, env) - end}) - - case args do - [file_name | rest] -> - Mal.Env.set(env, "*ARGV*", list(rest)) - load_file(file_name, env) - - [] -> - Mal.Env.set(env, "*ARGV*", list([])) - end - end - - defp loop(env) do - IO.write(:stdio, "user> ") - IO.read(:stdio, :line) - |> read_eval_print(env) - |> IO.puts - - loop(env) - end - - defp eval_ast({:list, ast, meta}, env) when is_list(ast) do - {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:map, ast, meta}, env) do - map = for {key, value} <- ast, into: %{} do - {key, eval(value, env)} - end - - {:map, map, meta} - end - - defp eval_ast({:vector, ast, meta}, env) do - {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:symbol, symbol}, env) do - case Mal.Env.get(env, symbol) do - {:ok, value} -> value - :not_found -> throw({:error, "'#{symbol}' not found"}) - end - end - - defp eval_ast(ast, _env), do: ast - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval_bindings([], env), do: env - defp eval_bindings([{:symbol, key}, binding | tail], env) do - evaluated = eval(binding, env) - Mal.Env.set(env, key, evaluated) - eval_bindings(tail, env) - end - defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - - defp quasiquote({:list, [{:symbol, "unquote"}, arg], _}), do: arg - defp quasiquote({:list, [{:symbol, "unquote"}| _], _}), do: throw({:error, "unquote: arg count"}) - defp quasiquote({:list, xs, _}), do: qq_foldr(xs) - defp quasiquote({:vector, xs, _}), do: list([{:symbol, "vec"}, qq_foldr(xs)]) - defp quasiquote({:symbol, sym}), do: list([{:symbol, "quote"}, {:symbol, sym}]) - defp quasiquote({:map, ast, meta}), do: list([{:symbol, "quote"}, {:map, ast, meta}]) - defp quasiquote(ast), do: ast - - defp qq_foldr([]), do: list([]) - defp qq_foldr([x|xs]), do: qq_loop(x, qq_foldr xs) - - defp qq_loop({:list, [{:symbol, "splice-unquote"}, arg], _}, acc), do: list([{:symbol, "concat"}, arg, acc]) - defp qq_loop({:list, [{:symbol, "splice-unquote"}| _], _}, _), do: throw({:error, "splice-unquote: arg count"}) - defp qq_loop(elt, acc), do: list([{:symbol, "cons"}, quasiquote(elt), acc]) - - defp macro_call?({:list, [{:symbol, key} | _tail], _}, env) do - case Mal.Env.get(env, key) do - {:ok, %Function{macro: true}} -> true - _ -> false - end - end - defp macro_call?(_ast, _env), do: false - - defp do_macro_call({:list, [{:symbol, key} | tail], _}, env) do - {:ok, %Function{value: macro, macro: true}} = Mal.Env.get(env, key) - macro.(tail) - |> macroexpand(env) - end - - defp macroexpand(ast, env) do - if macro_call?(ast, env) do - do_macro_call(ast, env) - else - ast - end - end - - defp eval({:list, [], _} = empty_ast, _env), do: empty_ast - defp eval({:list, _list, _meta} = ast, env) do - case macroexpand(ast, env) do - {:list, list, meta} -> eval_list(list, env, meta) - result -> eval_ast(result, env) - end - end - defp eval(ast, env), do: eval_ast(ast, env) - - defp eval_list([{:symbol, "macroexpand"}, ast], env, _), do: macroexpand(ast, env) - - defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do - result = eval(condition, env) - if result == nil or result == false do - case if_false do - [] -> nil - [body] -> eval(body, env) - end - else - eval(if_true, env) - end - end - - defp eval_list([{:symbol, "do"} | ast], env, _) do - ast - |> List.delete_at(-1) - |> list - |> eval_ast(env) - eval(List.last(ast), env) - end - - defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do - evaluated = eval(value, env) - Mal.Env.set(env, key, evaluated) - evaluated - end - - defp eval_list([{:symbol, "defmacro!"}, {:symbol, key}, function], env, _) do - macro = %{eval(function, env) | macro: true} - Mal.Env.set(env, key, macro) - macro - end - - defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) - when list_type == :list or list_type == :vector do - let_env = Mal.Env.new(env) - eval_bindings(bindings, let_env) - eval(body, let_env) - end - - defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) - when list_type == :list or list_type == :vector do - param_symbols = for {:symbol, symbol} <- params, do: symbol - - closure = fn args -> - inner = Mal.Env.new(env, param_symbols, args) - eval(body, inner) - end - - %Function{value: closure} - end - - defp eval_list([{:symbol, "quote"}, arg], _env, _), do: arg - - defp eval_list([{:symbol, "quasiquoteexpand"}, ast], _, _) do - quasiquote(ast) - end - - defp eval_list([{:symbol, "quasiquote"}, ast], env, _) do - ast |> quasiquote - |> eval(env) - end - - defp eval_list(ast, env, meta) do - {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) - func.value.(args) - end - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof, _env), do: exit(:normal) - defp read_eval_print(line, env) do - read(line) - |> eval(env) - |> print - catch - {:error, message} -> IO.puts("Error: #{message}") - end -end +defmodule Mix.Tasks.Step8Macros do + import Mal.Types + alias Mal.Function + + def run(args) do + env = Mal.Env.new() + Mal.Env.merge(env, Mal.Core.namespace) + bootstrap(args, env) + loop(env) + end + + defp load_file(file_name, env) do + read_eval_print(""" + (load-file "#{file_name}") + """, env) + exit(:normal) + end + + defp bootstrap(args, env) do + # not: + read_eval_print(""" + (def! not + (fn* (a) (if a false true))) + """, env) + + # load-file: + read_eval_print(""" + (def! load-file + (fn* (f) + (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + """, env) + + # cond + read_eval_print(""" + (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)))))))" + """, env) + + Mal.Env.set(env, "eval", %Function{value: fn [ast] -> + eval(ast, env) + end}) + + case args do + [file_name | rest] -> + Mal.Env.set(env, "*ARGV*", list(rest)) + load_file(file_name, env) + + [] -> + Mal.Env.set(env, "*ARGV*", list([])) + end + end + + defp loop(env) do + IO.write(:stdio, "user> ") + IO.read(:stdio, :line) + |> read_eval_print(env) + |> IO.puts + + loop(env) + end + + defp eval_ast({:list, ast, meta}, env) when is_list(ast) do + {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:map, ast, meta}, env) do + map = for {key, value} <- ast, into: %{} do + {key, eval(value, env)} + end + + {:map, map, meta} + end + + defp eval_ast({:vector, ast, meta}, env) do + {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:symbol, symbol}, env) do + case Mal.Env.get(env, symbol) do + {:ok, value} -> value + :not_found -> throw({:error, "'#{symbol}' not found"}) + end + end + + defp eval_ast(ast, _env), do: ast + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval_bindings([], env), do: env + defp eval_bindings([{:symbol, key}, binding | tail], env) do + evaluated = eval(binding, env) + Mal.Env.set(env, key, evaluated) + eval_bindings(tail, env) + end + defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) + + defp quasiquote({:list, [{:symbol, "unquote"}, arg], _}), do: arg + defp quasiquote({:list, [{:symbol, "unquote"}| _], _}), do: throw({:error, "unquote: arg count"}) + defp quasiquote({:list, xs, _}), do: qq_foldr(xs) + defp quasiquote({:vector, xs, _}), do: list([{:symbol, "vec"}, qq_foldr(xs)]) + defp quasiquote({:symbol, sym}), do: list([{:symbol, "quote"}, {:symbol, sym}]) + defp quasiquote({:map, ast, meta}), do: list([{:symbol, "quote"}, {:map, ast, meta}]) + defp quasiquote(ast), do: ast + + defp qq_foldr([]), do: list([]) + defp qq_foldr([x|xs]), do: qq_loop(x, qq_foldr xs) + + defp qq_loop({:list, [{:symbol, "splice-unquote"}, arg], _}, acc), do: list([{:symbol, "concat"}, arg, acc]) + defp qq_loop({:list, [{:symbol, "splice-unquote"}| _], _}, _), do: throw({:error, "splice-unquote: arg count"}) + defp qq_loop(elt, acc), do: list([{:symbol, "cons"}, quasiquote(elt), acc]) + + defp macro_call?({:list, [{:symbol, key} | _tail], _}, env) do + case Mal.Env.get(env, key) do + {:ok, %Function{macro: true}} -> true + _ -> false + end + end + defp macro_call?(_ast, _env), do: false + + defp do_macro_call({:list, [{:symbol, key} | tail], _}, env) do + {:ok, %Function{value: macro, macro: true}} = Mal.Env.get(env, key) + macro.(tail) + |> macroexpand(env) + end + + defp macroexpand(ast, env) do + if macro_call?(ast, env) do + do_macro_call(ast, env) + else + ast + end + end + + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast + defp eval({:list, _list, _meta} = ast, env) do + case macroexpand(ast, env) do + {:list, list, meta} -> eval_list(list, env, meta) + result -> eval_ast(result, env) + end + end + defp eval(ast, env), do: eval_ast(ast, env) + + defp eval_list([{:symbol, "macroexpand"}, ast], env, _), do: macroexpand(ast, env) + + defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do + result = eval(condition, env) + if result == nil or result == false do + case if_false do + [] -> nil + [body] -> eval(body, env) + end + else + eval(if_true, env) + end + end + + defp eval_list([{:symbol, "do"} | ast], env, _) do + ast + |> List.delete_at(-1) + |> list + |> eval_ast(env) + eval(List.last(ast), env) + end + + defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do + evaluated = eval(value, env) + Mal.Env.set(env, key, evaluated) + evaluated + end + + defp eval_list([{:symbol, "defmacro!"}, {:symbol, key}, function], env, _) do + macro = %{eval(function, env) | macro: true} + Mal.Env.set(env, key, macro) + macro + end + + defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) + when list_type == :list or list_type == :vector do + let_env = Mal.Env.new(env) + eval_bindings(bindings, let_env) + eval(body, let_env) + end + + defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) + when list_type == :list or list_type == :vector do + param_symbols = for {:symbol, symbol} <- params, do: symbol + + closure = fn args -> + inner = Mal.Env.new(env, param_symbols, args) + eval(body, inner) + end + + %Function{value: closure} + end + + defp eval_list([{:symbol, "quote"}, arg], _env, _), do: arg + + defp eval_list([{:symbol, "quasiquoteexpand"}, ast], _, _) do + quasiquote(ast) + end + + defp eval_list([{:symbol, "quasiquote"}, ast], env, _) do + ast |> quasiquote + |> eval(env) + end + + defp eval_list(ast, env, meta) do + {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) + func.value.(args) + end + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof, _env), do: exit(:normal) + defp read_eval_print(line, env) do + read(line) + |> eval(env) + |> print + catch + {:error, message} -> IO.puts("Error: #{message}") + end +end diff --git a/impls/elixir/lib/mix/tasks/step9_try.ex b/impls/elixir/lib/mix/tasks/step9_try.ex index 366b06d8f1..9d4904a86d 100644 --- a/impls/elixir/lib/mix/tasks/step9_try.ex +++ b/impls/elixir/lib/mix/tasks/step9_try.ex @@ -1,259 +1,259 @@ -defmodule Mix.Tasks.Step9Try do - import Mal.Types - alias Mal.Function - - def run(args) do - env = Mal.Env.new() - Mal.Env.merge(env, Mal.Core.namespace) - bootstrap(args, env) - loop(env) - end - - defp load_file(file_name, env) do - read_eval_print(""" - (load-file "#{file_name}") - """, env) - exit(:normal) - end - - defp bootstrap(args, env) do - # not: - read_eval_print(""" - (def! not - (fn* (a) (if a false true))) - """, env) - - # load-file: - read_eval_print(""" - (def! load-file - (fn* (f) - (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - """, env) - - # cond - read_eval_print(""" - (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)))))))" - """, env) - - Mal.Env.set(env, "eval", %Function{value: fn [ast] -> - eval(ast, env) - end}) - - case args do - [file_name | rest] -> - Mal.Env.set(env, "*ARGV*", list(rest)) - load_file(file_name, env) - - [] -> - Mal.Env.set(env, "*ARGV*", list([])) - end - end - - defp loop(env) do - IO.write(:stdio, "user> ") - IO.read(:stdio, :line) - |> read_eval_print(env) - |> IO.puts - - loop(env) - end - - defp eval_ast({:list, ast, meta}, env) when is_list(ast) do - {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:map, ast, meta}, env) do - map = for {key, value} <- ast, into: %{} do - {key, eval(value, env)} - end - - {:map, map, meta} - end - - defp eval_ast({:vector, ast, meta}, env) do - {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:symbol, symbol}, env) do - case Mal.Env.get(env, symbol) do - {:ok, value} -> value - :not_found -> throw({:error, "'#{symbol}' not found"}) - end - end - - defp eval_ast(ast, _env), do: ast - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval_bindings([], env), do: env - defp eval_bindings([{:symbol, key}, binding | tail], env) do - evaluated = eval(binding, env) - Mal.Env.set(env, key, evaluated) - eval_bindings(tail, env) - end - defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - - defp quasiquote({:list, [{:symbol, "unquote"}, arg], _}), do: arg - defp quasiquote({:list, [{:symbol, "unquote"}| _], _}), do: throw({:error, "unquote: arg count"}) - defp quasiquote({:list, xs, _}), do: qq_foldr(xs) - defp quasiquote({:vector, xs, _}), do: list([{:symbol, "vec"}, qq_foldr(xs)]) - defp quasiquote({:symbol, sym}), do: list([{:symbol, "quote"}, {:symbol, sym}]) - defp quasiquote({:map, ast, meta}), do: list([{:symbol, "quote"}, {:map, ast, meta}]) - defp quasiquote(ast), do: ast - - defp qq_foldr([]), do: list([]) - defp qq_foldr([x|xs]), do: qq_loop(x, qq_foldr xs) - - defp qq_loop({:list, [{:symbol, "splice-unquote"}, arg], _}, acc), do: list([{:symbol, "concat"}, arg, acc]) - defp qq_loop({:list, [{:symbol, "splice-unquote"}| _], _}, _), do: throw({:error, "splice-unquote: arg count"}) - defp qq_loop(elt, acc), do: list([{:symbol, "cons"}, quasiquote(elt), acc]) - - defp macro_call?({:list, [{:symbol, key} | _tail], _}, env) do - case Mal.Env.get(env, key) do - {:ok, %Function{macro: true}} -> true - _ -> false - end - end - defp macro_call?(_ast, _env), do: false - - defp do_macro_call({:list, [{:symbol, key} | tail], _}, env) do - {:ok, %Function{value: macro, macro: true}} = Mal.Env.get(env, key) - macro.(tail) - |> macroexpand(env) - end - - defp macroexpand(ast, env) do - if macro_call?(ast, env) do - do_macro_call(ast, env) - else - ast - end - end - - defp eval({:list, [], _} = empty_ast, _env), do: empty_ast - defp eval({:list, _list, _meta} = ast, env) do - case macroexpand(ast, env) do - {:list, list, meta} -> eval_list(list, env, meta) - result -> eval_ast(result, env) - end - end - defp eval(ast, env), do: eval_ast(ast, env) - - defp eval_list([{:symbol, "macroexpand"}, ast], env, _), do: macroexpand(ast, env) - - defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do - result = eval(condition, env) - if result == nil or result == false do - case if_false do - [] -> nil - [body] -> eval(body, env) - end - else - eval(if_true, env) - end - end - - defp eval_list([{:symbol, "do"} | ast], env, _) do - ast - |> List.delete_at(-1) - |> list - |> eval_ast(env) - eval(List.last(ast), env) - end - - defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do - evaluated = eval(value, env) - Mal.Env.set(env, key, evaluated) - evaluated - end - - defp eval_list([{:symbol, "defmacro!"}, {:symbol, key}, function], env, _) do - macro = %{eval(function, env) | macro: true} - Mal.Env.set(env, key, macro) - macro - end - - defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) - when list_type == :list or list_type == :vector do - let_env = Mal.Env.new(env) - eval_bindings(bindings, let_env) - eval(body, let_env) - end - - defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) - when list_type == :list or list_type == :vector do - param_symbols = for {:symbol, symbol} <- params, do: symbol - - closure = fn args -> - inner = Mal.Env.new(env, param_symbols, args) - eval(body, inner) - end - - %Function{value: closure} - end - - defp eval_list([{:symbol, "quote"}, arg], _env, _), do: arg - - defp eval_list([{:symbol, "quasiquoteexpand"}, ast], _, _) do - quasiquote(ast) - end - - defp eval_list([{:symbol, "quasiquote"}, ast], env, _) do - ast |> quasiquote - |> eval(env) - end - - # (try* A (catch* B C)) - defp eval_list([{:symbol, "try*"}, try_form, {:list, catch_list, _meta}], env, _) do - eval_try(try_form, catch_list, env) - end - defp eval_list([{:symbol, "try*"}, try_form], env, _) do - eval(try_form, env) - end - defp eval_list([{:symbol, "try*"}, _try_form, _], _env, _) do - throw({:error, "try* requires a list as the second parameter"}) - end - - defp eval_list(ast, env, meta) do - {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) - func.value.(args) - end - - defp eval_try(try_form, - [{:symbol, "catch*"}, {:symbol, exception}, catch_form], env) do - try do - eval(try_form, env) - catch - {:error, message}-> - catch_env = Mal.Env.new(env) - Mal.Env.set(catch_env, exception, {:exception, message}) - eval(catch_form, catch_env) - end - end - defp eval_try(_try_form, _catch_list, _env) do - throw({:error, "catch* requires two arguments"}) - end - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof, _env), do: exit(:normal) - defp read_eval_print(line, env) do - read(line) - |> eval(env) - |> print - catch - {:error, exception} -> - IO.puts("Error: #{Mal.Printer.print_str(exception)}") - end -end +defmodule Mix.Tasks.Step9Try do + import Mal.Types + alias Mal.Function + + def run(args) do + env = Mal.Env.new() + Mal.Env.merge(env, Mal.Core.namespace) + bootstrap(args, env) + loop(env) + end + + defp load_file(file_name, env) do + read_eval_print(""" + (load-file "#{file_name}") + """, env) + exit(:normal) + end + + defp bootstrap(args, env) do + # not: + read_eval_print(""" + (def! not + (fn* (a) (if a false true))) + """, env) + + # load-file: + read_eval_print(""" + (def! load-file + (fn* (f) + (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + """, env) + + # cond + read_eval_print(""" + (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)))))))" + """, env) + + Mal.Env.set(env, "eval", %Function{value: fn [ast] -> + eval(ast, env) + end}) + + case args do + [file_name | rest] -> + Mal.Env.set(env, "*ARGV*", list(rest)) + load_file(file_name, env) + + [] -> + Mal.Env.set(env, "*ARGV*", list([])) + end + end + + defp loop(env) do + IO.write(:stdio, "user> ") + IO.read(:stdio, :line) + |> read_eval_print(env) + |> IO.puts + + loop(env) + end + + defp eval_ast({:list, ast, meta}, env) when is_list(ast) do + {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:map, ast, meta}, env) do + map = for {key, value} <- ast, into: %{} do + {key, eval(value, env)} + end + + {:map, map, meta} + end + + defp eval_ast({:vector, ast, meta}, env) do + {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:symbol, symbol}, env) do + case Mal.Env.get(env, symbol) do + {:ok, value} -> value + :not_found -> throw({:error, "'#{symbol}' not found"}) + end + end + + defp eval_ast(ast, _env), do: ast + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval_bindings([], env), do: env + defp eval_bindings([{:symbol, key}, binding | tail], env) do + evaluated = eval(binding, env) + Mal.Env.set(env, key, evaluated) + eval_bindings(tail, env) + end + defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) + + defp quasiquote({:list, [{:symbol, "unquote"}, arg], _}), do: arg + defp quasiquote({:list, [{:symbol, "unquote"}| _], _}), do: throw({:error, "unquote: arg count"}) + defp quasiquote({:list, xs, _}), do: qq_foldr(xs) + defp quasiquote({:vector, xs, _}), do: list([{:symbol, "vec"}, qq_foldr(xs)]) + defp quasiquote({:symbol, sym}), do: list([{:symbol, "quote"}, {:symbol, sym}]) + defp quasiquote({:map, ast, meta}), do: list([{:symbol, "quote"}, {:map, ast, meta}]) + defp quasiquote(ast), do: ast + + defp qq_foldr([]), do: list([]) + defp qq_foldr([x|xs]), do: qq_loop(x, qq_foldr xs) + + defp qq_loop({:list, [{:symbol, "splice-unquote"}, arg], _}, acc), do: list([{:symbol, "concat"}, arg, acc]) + defp qq_loop({:list, [{:symbol, "splice-unquote"}| _], _}, _), do: throw({:error, "splice-unquote: arg count"}) + defp qq_loop(elt, acc), do: list([{:symbol, "cons"}, quasiquote(elt), acc]) + + defp macro_call?({:list, [{:symbol, key} | _tail], _}, env) do + case Mal.Env.get(env, key) do + {:ok, %Function{macro: true}} -> true + _ -> false + end + end + defp macro_call?(_ast, _env), do: false + + defp do_macro_call({:list, [{:symbol, key} | tail], _}, env) do + {:ok, %Function{value: macro, macro: true}} = Mal.Env.get(env, key) + macro.(tail) + |> macroexpand(env) + end + + defp macroexpand(ast, env) do + if macro_call?(ast, env) do + do_macro_call(ast, env) + else + ast + end + end + + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast + defp eval({:list, _list, _meta} = ast, env) do + case macroexpand(ast, env) do + {:list, list, meta} -> eval_list(list, env, meta) + result -> eval_ast(result, env) + end + end + defp eval(ast, env), do: eval_ast(ast, env) + + defp eval_list([{:symbol, "macroexpand"}, ast], env, _), do: macroexpand(ast, env) + + defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do + result = eval(condition, env) + if result == nil or result == false do + case if_false do + [] -> nil + [body] -> eval(body, env) + end + else + eval(if_true, env) + end + end + + defp eval_list([{:symbol, "do"} | ast], env, _) do + ast + |> List.delete_at(-1) + |> list + |> eval_ast(env) + eval(List.last(ast), env) + end + + defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do + evaluated = eval(value, env) + Mal.Env.set(env, key, evaluated) + evaluated + end + + defp eval_list([{:symbol, "defmacro!"}, {:symbol, key}, function], env, _) do + macro = %{eval(function, env) | macro: true} + Mal.Env.set(env, key, macro) + macro + end + + defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) + when list_type == :list or list_type == :vector do + let_env = Mal.Env.new(env) + eval_bindings(bindings, let_env) + eval(body, let_env) + end + + defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) + when list_type == :list or list_type == :vector do + param_symbols = for {:symbol, symbol} <- params, do: symbol + + closure = fn args -> + inner = Mal.Env.new(env, param_symbols, args) + eval(body, inner) + end + + %Function{value: closure} + end + + defp eval_list([{:symbol, "quote"}, arg], _env, _), do: arg + + defp eval_list([{:symbol, "quasiquoteexpand"}, ast], _, _) do + quasiquote(ast) + end + + defp eval_list([{:symbol, "quasiquote"}, ast], env, _) do + ast |> quasiquote + |> eval(env) + end + + # (try* A (catch* B C)) + defp eval_list([{:symbol, "try*"}, try_form, {:list, catch_list, _meta}], env, _) do + eval_try(try_form, catch_list, env) + end + defp eval_list([{:symbol, "try*"}, try_form], env, _) do + eval(try_form, env) + end + defp eval_list([{:symbol, "try*"}, _try_form, _], _env, _) do + throw({:error, "try* requires a list as the second parameter"}) + end + + defp eval_list(ast, env, meta) do + {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) + func.value.(args) + end + + defp eval_try(try_form, + [{:symbol, "catch*"}, {:symbol, exception}, catch_form], env) do + try do + eval(try_form, env) + catch + {:error, message}-> + catch_env = Mal.Env.new(env) + Mal.Env.set(catch_env, exception, {:exception, message}) + eval(catch_form, catch_env) + end + end + defp eval_try(_try_form, _catch_list, _env) do + throw({:error, "catch* requires two arguments"}) + end + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof, _env), do: exit(:normal) + defp read_eval_print(line, env) do + read(line) + |> eval(env) + |> print + catch + {:error, exception} -> + IO.puts("Error: #{Mal.Printer.print_str(exception)}") + end +end diff --git a/impls/elixir/lib/mix/tasks/stepA_mal.ex b/impls/elixir/lib/mix/tasks/stepA_mal.ex index 3df0e41899..1584a63783 100644 --- a/impls/elixir/lib/mix/tasks/stepA_mal.ex +++ b/impls/elixir/lib/mix/tasks/stepA_mal.ex @@ -1,268 +1,268 @@ -defmodule Mix.Tasks.StepAMal do - import Mal.Types - alias Mal.Function - - # for escript execution - def main(args) do - run(args) - end - - def run(args) do - env = Mal.Env.new() - Mal.Env.merge(env, Mal.Core.namespace) - bootstrap(args, env) - loop(env) - end - - defp load_file(file_name, env) do - read_eval_print(""" - (load-file "#{file_name}") - """, env) - exit(:normal) - end - - defp bootstrap(args, env) do - # *host-language* - read_eval_print("(def! *host-language* \"Elixir\")", env) - - # not: - read_eval_print(""" - (def! not - (fn* (a) (if a false true))) - """, env) - - # load-file: - read_eval_print(""" - (def! load-file - (fn* (f) - (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - """, env) - - # cond - read_eval_print(""" - (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)))))))" - """, env) - - Mal.Env.set(env, "eval", %Function{value: fn [ast] -> - eval(ast, env) - end}) - - case args do - [file_name | rest] -> - Mal.Env.set(env, "*ARGV*", list(rest)) - load_file(file_name, env) - - [] -> - Mal.Env.set(env, "*ARGV*", list([])) - read_eval_print("(println (str \"Mal [\" *host-language* \"]\"))", env) - end - end - - defp loop(env) do - IO.write(:stdio, "user> ") - IO.read(:stdio, :line) - |> read_eval_print(env) - |> IO.puts - - loop(env) - end - - defp eval_ast({:list, ast, meta}, env) when is_list(ast) do - {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:map, ast, meta}, env) do - map = for {key, value} <- ast, into: %{} do - {key, eval(value, env)} - end - - {:map, map, meta} - end - - defp eval_ast({:vector, ast, meta}, env) do - {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} - end - - defp eval_ast({:symbol, symbol}, env) do - case Mal.Env.get(env, symbol) do - {:ok, value} -> value - :not_found -> throw({:error, "'#{symbol}' not found"}) - end - end - - defp eval_ast(ast, _env), do: ast - - defp read(input) do - Mal.Reader.read_str(input) - end - - defp eval_bindings([], env), do: env - defp eval_bindings([{:symbol, key}, binding | tail], env) do - evaluated = eval(binding, env) - Mal.Env.set(env, key, evaluated) - eval_bindings(tail, env) - end - defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) - - defp quasiquote({:list, [{:symbol, "unquote"}, arg], _}), do: arg - defp quasiquote({:list, [{:symbol, "unquote"}| _], _}), do: throw({:error, "unquote: arg count"}) - defp quasiquote({:list, xs, _}), do: qq_foldr(xs) - defp quasiquote({:vector, xs, _}), do: list([{:symbol, "vec"}, qq_foldr(xs)]) - defp quasiquote({:symbol, sym}), do: list([{:symbol, "quote"}, {:symbol, sym}]) - defp quasiquote({:map, ast, meta}), do: list([{:symbol, "quote"}, {:map, ast, meta}]) - defp quasiquote(ast), do: ast - - defp qq_foldr([]), do: list([]) - defp qq_foldr([x|xs]), do: qq_loop(x, qq_foldr xs) - - defp qq_loop({:list, [{:symbol, "splice-unquote"}, arg], _}, acc), do: list([{:symbol, "concat"}, arg, acc]) - defp qq_loop({:list, [{:symbol, "splice-unquote"}| _], _}, _), do: throw({:error, "splice-unquote: arg count"}) - defp qq_loop(elt, acc), do: list([{:symbol, "cons"}, quasiquote(elt), acc]) - - defp macro_call?({:list, [{:symbol, key} | _tail], _}, env) do - case Mal.Env.get(env, key) do - {:ok, %Function{macro: true}} -> true - _ -> false - end - end - defp macro_call?(_ast, _env), do: false - - defp do_macro_call({:list, [{:symbol, key} | tail], _}, env) do - {:ok, %Function{value: macro, macro: true}} = Mal.Env.get(env, key) - macro.(tail) - |> macroexpand(env) - end - - defp macroexpand(ast, env) do - if macro_call?(ast, env) do - do_macro_call(ast, env) - else - ast - end - end - - defp eval({:list, [], _} = empty_ast, _env), do: empty_ast - defp eval({:list, _list, _meta} = ast, env) do - case macroexpand(ast, env) do - {:list, list, meta} -> eval_list(list, env, meta) - result -> eval_ast(result, env) - end - end - defp eval(ast, env), do: eval_ast(ast, env) - - defp eval_list([{:symbol, "macroexpand"}, ast], env, _), do: macroexpand(ast, env) - - defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do - result = eval(condition, env) - if result == nil or result == false do - case if_false do - [] -> nil - [body] -> eval(body, env) - end - else - eval(if_true, env) - end - end - - defp eval_list([{:symbol, "do"} | ast], env, _) do - ast - |> List.delete_at(-1) - |> list - |> eval_ast(env) - eval(List.last(ast), env) - end - - defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do - evaluated = eval(value, env) - Mal.Env.set(env, key, evaluated) - evaluated - end - - defp eval_list([{:symbol, "defmacro!"}, {:symbol, key}, function], env, _) do - macro = %{eval(function, env) | macro: true} - Mal.Env.set(env, key, macro) - macro - end - - defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) - when list_type == :list or list_type == :vector do - let_env = Mal.Env.new(env) - eval_bindings(bindings, let_env) - eval(body, let_env) - end - - defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) - when list_type == :list or list_type == :vector do - param_symbols = for {:symbol, symbol} <- params, do: symbol - - closure = fn args -> - inner = Mal.Env.new(env, param_symbols, args) - eval(body, inner) - end - - %Function{value: closure} - end - - defp eval_list([{:symbol, "quote"}, arg], _env, _), do: arg - - defp eval_list([{:symbol, "quasiquoteexpand"}, ast], _, _) do - quasiquote(ast) - end - - defp eval_list([{:symbol, "quasiquote"}, ast], env, _) do - ast |> quasiquote - |> eval(env) - end - - # (try* A (catch* B C)) - defp eval_list([{:symbol, "try*"}, try_form, {:list, catch_list, _meta}], env, _) do - eval_try(try_form, catch_list, env) - end - defp eval_list([{:symbol, "try*"}, try_form], env, _) do - eval(try_form, env) - end - defp eval_list([{:symbol, "try*"}, _try_form, _], _env, _) do - throw({:error, "try* requires a list as the second parameter"}) - end - - defp eval_list(ast, env, meta) do - {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) - func.value.(args) - end - - defp eval_try(try_form, - [{:symbol, "catch*"}, {:symbol, exception}, catch_form], env) do - try do - eval(try_form, env) - catch - {:error, message}-> - catch_env = Mal.Env.new(env) - Mal.Env.set(catch_env, exception, {:exception, message}) - eval(catch_form, catch_env) - end - end - defp eval_try(_try_form, _catch_list, _env) do - throw({:error, "catch* requires two arguments"}) - end - - defp print(value) do - Mal.Printer.print_str(value) - end - - defp read_eval_print(:eof, _env), do: exit(:normal) - defp read_eval_print(line, env) do - read(line) - |> eval(env) - |> print - catch - {:error, exception} -> - IO.puts("Error: #{Mal.Printer.print_str(exception)}") - end -end +defmodule Mix.Tasks.StepAMal do + import Mal.Types + alias Mal.Function + + # for escript execution + def main(args) do + run(args) + end + + def run(args) do + env = Mal.Env.new() + Mal.Env.merge(env, Mal.Core.namespace) + bootstrap(args, env) + loop(env) + end + + defp load_file(file_name, env) do + read_eval_print(""" + (load-file "#{file_name}") + """, env) + exit(:normal) + end + + defp bootstrap(args, env) do + # *host-language* + read_eval_print("(def! *host-language* \"Elixir\")", env) + + # not: + read_eval_print(""" + (def! not + (fn* (a) (if a false true))) + """, env) + + # load-file: + read_eval_print(""" + (def! load-file + (fn* (f) + (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + """, env) + + # cond + read_eval_print(""" + (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)))))))" + """, env) + + Mal.Env.set(env, "eval", %Function{value: fn [ast] -> + eval(ast, env) + end}) + + case args do + [file_name | rest] -> + Mal.Env.set(env, "*ARGV*", list(rest)) + load_file(file_name, env) + + [] -> + Mal.Env.set(env, "*ARGV*", list([])) + read_eval_print("(println (str \"Mal [\" *host-language* \"]\"))", env) + end + end + + defp loop(env) do + IO.write(:stdio, "user> ") + IO.read(:stdio, :line) + |> read_eval_print(env) + |> IO.puts + + loop(env) + end + + defp eval_ast({:list, ast, meta}, env) when is_list(ast) do + {:list, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:map, ast, meta}, env) do + map = for {key, value} <- ast, into: %{} do + {key, eval(value, env)} + end + + {:map, map, meta} + end + + defp eval_ast({:vector, ast, meta}, env) do + {:vector, Enum.map(ast, fn elem -> eval(elem, env) end), meta} + end + + defp eval_ast({:symbol, symbol}, env) do + case Mal.Env.get(env, symbol) do + {:ok, value} -> value + :not_found -> throw({:error, "'#{symbol}' not found"}) + end + end + + defp eval_ast(ast, _env), do: ast + + defp read(input) do + Mal.Reader.read_str(input) + end + + defp eval_bindings([], env), do: env + defp eval_bindings([{:symbol, key}, binding | tail], env) do + evaluated = eval(binding, env) + Mal.Env.set(env, key, evaluated) + eval_bindings(tail, env) + end + defp eval_bindings(_bindings, _env), do: throw({:error, "Unbalanced let* bindings"}) + + defp quasiquote({:list, [{:symbol, "unquote"}, arg], _}), do: arg + defp quasiquote({:list, [{:symbol, "unquote"}| _], _}), do: throw({:error, "unquote: arg count"}) + defp quasiquote({:list, xs, _}), do: qq_foldr(xs) + defp quasiquote({:vector, xs, _}), do: list([{:symbol, "vec"}, qq_foldr(xs)]) + defp quasiquote({:symbol, sym}), do: list([{:symbol, "quote"}, {:symbol, sym}]) + defp quasiquote({:map, ast, meta}), do: list([{:symbol, "quote"}, {:map, ast, meta}]) + defp quasiquote(ast), do: ast + + defp qq_foldr([]), do: list([]) + defp qq_foldr([x|xs]), do: qq_loop(x, qq_foldr xs) + + defp qq_loop({:list, [{:symbol, "splice-unquote"}, arg], _}, acc), do: list([{:symbol, "concat"}, arg, acc]) + defp qq_loop({:list, [{:symbol, "splice-unquote"}| _], _}, _), do: throw({:error, "splice-unquote: arg count"}) + defp qq_loop(elt, acc), do: list([{:symbol, "cons"}, quasiquote(elt), acc]) + + defp macro_call?({:list, [{:symbol, key} | _tail], _}, env) do + case Mal.Env.get(env, key) do + {:ok, %Function{macro: true}} -> true + _ -> false + end + end + defp macro_call?(_ast, _env), do: false + + defp do_macro_call({:list, [{:symbol, key} | tail], _}, env) do + {:ok, %Function{value: macro, macro: true}} = Mal.Env.get(env, key) + macro.(tail) + |> macroexpand(env) + end + + defp macroexpand(ast, env) do + if macro_call?(ast, env) do + do_macro_call(ast, env) + else + ast + end + end + + defp eval({:list, [], _} = empty_ast, _env), do: empty_ast + defp eval({:list, _list, _meta} = ast, env) do + case macroexpand(ast, env) do + {:list, list, meta} -> eval_list(list, env, meta) + result -> eval_ast(result, env) + end + end + defp eval(ast, env), do: eval_ast(ast, env) + + defp eval_list([{:symbol, "macroexpand"}, ast], env, _), do: macroexpand(ast, env) + + defp eval_list([{:symbol, "if"}, condition, if_true | if_false], env, _) do + result = eval(condition, env) + if result == nil or result == false do + case if_false do + [] -> nil + [body] -> eval(body, env) + end + else + eval(if_true, env) + end + end + + defp eval_list([{:symbol, "do"} | ast], env, _) do + ast + |> List.delete_at(-1) + |> list + |> eval_ast(env) + eval(List.last(ast), env) + end + + defp eval_list([{:symbol, "def!"}, {:symbol, key}, value], env, _) do + evaluated = eval(value, env) + Mal.Env.set(env, key, evaluated) + evaluated + end + + defp eval_list([{:symbol, "defmacro!"}, {:symbol, key}, function], env, _) do + macro = %{eval(function, env) | macro: true} + Mal.Env.set(env, key, macro) + macro + end + + defp eval_list([{:symbol, "let*"}, {list_type, bindings, _}, body], env, _) + when list_type == :list or list_type == :vector do + let_env = Mal.Env.new(env) + eval_bindings(bindings, let_env) + eval(body, let_env) + end + + defp eval_list([{:symbol, "fn*"}, {list_type, params, _}, body], env, _) + when list_type == :list or list_type == :vector do + param_symbols = for {:symbol, symbol} <- params, do: symbol + + closure = fn args -> + inner = Mal.Env.new(env, param_symbols, args) + eval(body, inner) + end + + %Function{value: closure} + end + + defp eval_list([{:symbol, "quote"}, arg], _env, _), do: arg + + defp eval_list([{:symbol, "quasiquoteexpand"}, ast], _, _) do + quasiquote(ast) + end + + defp eval_list([{:symbol, "quasiquote"}, ast], env, _) do + ast |> quasiquote + |> eval(env) + end + + # (try* A (catch* B C)) + defp eval_list([{:symbol, "try*"}, try_form, {:list, catch_list, _meta}], env, _) do + eval_try(try_form, catch_list, env) + end + defp eval_list([{:symbol, "try*"}, try_form], env, _) do + eval(try_form, env) + end + defp eval_list([{:symbol, "try*"}, _try_form, _], _env, _) do + throw({:error, "try* requires a list as the second parameter"}) + end + + defp eval_list(ast, env, meta) do + {:list, [func | args], _} = eval_ast({:list, ast, meta}, env) + func.value.(args) + end + + defp eval_try(try_form, + [{:symbol, "catch*"}, {:symbol, exception}, catch_form], env) do + try do + eval(try_form, env) + catch + {:error, message}-> + catch_env = Mal.Env.new(env) + Mal.Env.set(catch_env, exception, {:exception, message}) + eval(catch_form, catch_env) + end + end + defp eval_try(_try_form, _catch_list, _env) do + throw({:error, "catch* requires two arguments"}) + end + + defp print(value) do + Mal.Printer.print_str(value) + end + + defp read_eval_print(:eof, _env), do: exit(:normal) + defp read_eval_print(line, env) do + read(line) + |> eval(env) + |> print + catch + {:error, exception} -> + IO.puts("Error: #{Mal.Printer.print_str(exception)}") + end +end diff --git a/impls/elixir/mix.exs b/impls/elixir/mix.exs index 5d768f6e0a..ac97b1cb25 100644 --- a/impls/elixir/mix.exs +++ b/impls/elixir/mix.exs @@ -1,38 +1,38 @@ -defmodule Mal.Mixfile do - use Mix.Project - - def project do - [app: :mal, - version: "0.0.1", - elixir: "~> 1.5", - build_embedded: Mix.env == :prod, - start_permanent: Mix.env == :prod, - deps: deps(), - default_task: "stepA_mal", - escript: escript()] - end - - def escript do - [main_module: Mix.Tasks.StepAMal] - end - - # Configuration for the OTP application - # - # Type `mix help compile.app` for more information - def application do - [applications: [:logger]] - end - - # Dependencies can be Hex packages: - # - # {:mydep, "~> 0.3.0"} - # - # Or git/path repositories: - # - # {:mydep, git: "https://github.com/elixir-lang/mydep.git", tag: "0.1.0"} - # - # Type `mix help deps` for more examples and options - defp deps do - [] - end -end +defmodule Mal.Mixfile do + use Mix.Project + + def project do + [app: :mal, + version: "0.0.1", + elixir: "~> 1.5", + build_embedded: Mix.env == :prod, + start_permanent: Mix.env == :prod, + deps: deps(), + default_task: "stepA_mal", + escript: escript()] + end + + def escript do + [main_module: Mix.Tasks.StepAMal] + end + + # Configuration for the OTP application + # + # Type `mix help compile.app` for more information + def application do + [applications: [:logger]] + end + + # Dependencies can be Hex packages: + # + # {:mydep, "~> 0.3.0"} + # + # Or git/path repositories: + # + # {:mydep, git: "https://github.com/elixir-lang/mydep.git", tag: "0.1.0"} + # + # Type `mix help deps` for more examples and options + defp deps do + [] + end +end diff --git a/impls/elixir/run b/impls/elixir/run index db29600d6f..61e192a515 100755 --- a/impls/elixir/run +++ b/impls/elixir/run @@ -1,3 +1,3 @@ -#!/bin/bash -cd $(dirname $0) -exec mix ${STEP:-stepA_mal} "${@}" +#!/bin/bash +cd $(dirname $0) +exec mix ${STEP:-stepA_mal} "${@}" diff --git a/impls/elixir/tests/step5_tco.mal b/impls/elixir/tests/step5_tco.mal index 6b1ba58860..2087f3aea2 100644 --- a/impls/elixir/tests/step5_tco.mal +++ b/impls/elixir/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Elixir: skipping non-TCO recursion -;; Reason: Elixir has TCO, test always completes. +;; Elixir: skipping non-TCO recursion +;; Reason: Elixir has TCO, test always completes. diff --git a/impls/elm/.dockerignore b/impls/elm/.dockerignore index 3c3629e647..08b25532d6 100644 --- a/impls/elm/.dockerignore +++ b/impls/elm/.dockerignore @@ -1 +1 @@ -node_modules +node_modules diff --git a/impls/elm/Core.elm b/impls/elm/Core.elm index 5dca34bc6c..59dfc137b9 100644 --- a/impls/elm/Core.elm +++ b/impls/elm/Core.elm @@ -1,965 +1,965 @@ -module Core exposing (..) - -import Types exposing (..) -import Env -import Eval -import Printer exposing (printString) -import Array -import Dict -import IO exposing (IO(..)) -import Reader -import Utils exposing (zip) -import Time -import Task - - -ns : Env -ns = - let - makeFn = - CoreFunc >> MalFunction - - binaryOp fn retType args = - case args of - [ MalInt x, MalInt y ] -> - Eval.succeed (retType (fn x y)) - - _ -> - Eval.fail "unsupported arguments" - - {- list -} - list = - Eval.succeed << MalList - - {- list? -} - isList args = - case args of - [ MalList _ ] -> - Eval.succeed (MalBool True) - - _ -> - Eval.succeed (MalBool False) - - {- empty? -} - isEmpty args = - case args of - [ MalList list ] -> - Eval.succeed <| MalBool (List.isEmpty list) - - [ MalVector vec ] -> - Eval.succeed <| MalBool (Array.isEmpty vec) - - _ -> - Eval.fail "unsupported arguments" - - {- count -} - count args = - case args of - [ MalNil ] -> - Eval.succeed (MalInt 0) - - [ MalList list ] -> - Eval.succeed <| MalInt (List.length list) - - [ MalVector vec ] -> - Eval.succeed <| MalInt (Array.length vec) - - _ -> - Eval.fail "unsupported arguments" - - equalLists a b = - case ( a, b ) of - ( [], [] ) -> - True - - ( x :: xs, y :: ys ) -> - if deepEquals x y then - equalLists xs ys - else - False - - _ -> - False - - compareListTo list other = - case other of - MalList otherList -> - equalLists list otherList - - MalVector vec -> - equalLists list (Array.toList vec) - - _ -> - False - - equalMaps a b = - if Dict.keys a /= Dict.keys b then - False - else - zip (Dict.values a) (Dict.values b) - |> List.map (uncurry deepEquals) - |> List.all identity - - deepEquals a b = - case ( a, b ) of - ( MalList list, MalList otherList ) -> - equalLists list otherList - - ( MalList list, MalVector vec ) -> - equalLists list (Array.toList vec) - - ( MalList _, _ ) -> - False - - ( MalVector vec, MalList list ) -> - equalLists (Array.toList vec) list - - ( MalVector vec, MalVector otherVec ) -> - equalLists (Array.toList vec) (Array.toList otherVec) - - ( MalVector _, _ ) -> - False - - ( MalMap map, MalMap otherMap ) -> - equalMaps map otherMap - - ( MalMap _, _ ) -> - False - - ( _, MalMap _ ) -> - False - - _ -> - a == b - - {- = -} - equals args = - case args of - [ a, b ] -> - Eval.succeed <| MalBool (deepEquals a b) - - _ -> - Eval.fail "unsupported arguments" - - {- pr-str -} - prStr args = - Eval.withEnv - (\env -> - args - |> List.map (printString env True) - |> String.join " " - |> MalString - |> Eval.succeed - ) - - {- str -} - str args = - Eval.withEnv - (\env -> - args - |> List.map (printString env False) - |> String.join "" - |> MalString - |> Eval.succeed - ) - - {- helper function to write a string to stdout -} - writeLine str = - Eval.io (IO.writeLine str) - (\msg -> - case msg of - LineWritten -> - Eval.succeed MalNil - - _ -> - Eval.fail "wrong IO, expected LineWritten" - ) - - prn args = - Eval.withEnv - (\env -> - args - |> List.map (printString env True) - |> String.join " " - |> writeLine - ) - - println args = - Eval.withEnv - (\env -> - args - |> List.map (printString env False) - |> String.join " " - |> writeLine - ) - - printEnv args = - case args of - [] -> - Eval.withEnv (Printer.printEnv >> writeLine) - - _ -> - Eval.fail "unsupported arguments" - - readString args = - case args of - [ MalString str ] -> - case Reader.readString str of - Ok Nothing -> - Eval.succeed MalNil - - Ok (Just ast) -> - Eval.succeed ast - - Err msg -> - Eval.fail msg - - _ -> - Eval.fail "unsupported arguments" - - slurp args = - case args of - [ MalString filename ] -> - Eval.io (IO.readFile filename) - (\msg -> - case msg of - FileRead contents -> - Eval.succeed <| MalString contents - - Exception msg -> - Eval.fail msg - - _ -> - Eval.fail "wrong IO, expected FileRead" - ) - - _ -> - Eval.fail "unsupported arguments" - - atom args = - case args of - [ value ] -> - Eval.withEnv - (\env -> - case Env.newAtom value env of - ( newEnv, atomId ) -> - Eval.setEnv newEnv - |> Eval.map (\_ -> MalAtom atomId) - ) - - _ -> - Eval.fail "unsupported arguments" - - isAtom args = - case args of - [ MalAtom _ ] -> - Eval.succeed <| MalBool True - - _ -> - Eval.succeed <| MalBool False - - deref args = - case args of - [ MalAtom atomId ] -> - Eval.withEnv (Env.getAtom atomId >> Eval.succeed) - - _ -> - Eval.fail "unsupported arguments" - - reset args = - case args of - [ MalAtom atomId, value ] -> - Eval.modifyEnv (Env.setAtom atomId value) - |> Eval.map (always value) - - _ -> - Eval.fail "unsupported arguments" - - {- helper function for calling a core or user function -} - callFn func args = - case func of - CoreFunc fn -> - fn args - - UserFunc { eagerFn } -> - eagerFn args - - swap args = - case args of - (MalAtom atomId) :: (MalFunction func) :: args -> - Eval.withEnv - (\env -> - let - value = - Env.getAtom atomId env - in - callFn func (value :: args) - ) - |> Eval.andThen - (\res -> - Eval.modifyEnv (Env.setAtom atomId res) - |> Eval.map (always res) - ) - - _ -> - Eval.fail "unsupported arguments" - - gc args = - Eval.withEnv (Env.gc MalNil >> Printer.printEnv >> writeLine) - - setDebug enabled = - Eval.modifyEnv - (\env -> - { env | debug = enabled } - ) - |> Eval.andThen (\_ -> Eval.succeed MalNil) - - debug args = - case args of - [ MalBool value ] -> - setDebug value - - _ -> - Eval.withEnv - (\env -> - Eval.succeed (MalBool env.debug) - ) - - typeof args = - case args of - [ MalInt _ ] -> - Eval.succeed <| MalSymbol "int" - - [ MalBool _ ] -> - Eval.succeed <| MalSymbol "bool" - - [ MalString _ ] -> - Eval.succeed <| MalSymbol "string" - - [ MalKeyword _ ] -> - Eval.succeed <| MalSymbol "keyword" - - [ MalSymbol _ ] -> - Eval.succeed <| MalSymbol "symbol" - - [ MalNil ] -> - Eval.succeed <| MalSymbol "nil" - - [ MalList _ ] -> - Eval.succeed <| MalSymbol "vector" - - [ MalVector _ ] -> - Eval.succeed <| MalSymbol "vector" - - [ MalMap _ ] -> - Eval.succeed <| MalSymbol "vector" - - [ MalFunction _ ] -> - Eval.succeed <| MalSymbol "function" - - [ MalAtom _ ] -> - Eval.succeed <| MalSymbol "atom" - - _ -> - Eval.fail "unsupported arguments" - - cons args = - case args of - [ e, MalList list ] -> - Eval.succeed <| MalList (e :: list) - - [ e, MalVector vec ] -> - Eval.succeed <| MalList (e :: (Array.toList vec)) - - _ -> - Eval.fail "unsupported arguments" - - concat args = - let - go arg acc = - case arg of - MalList list -> - Eval.succeed (acc ++ list) - - MalVector vec -> - Eval.succeed (acc ++ Array.toList vec) - - _ -> - Eval.fail "unsupported arguments" - in - List.foldl (go >> Eval.andThen) (Eval.succeed []) args - |> Eval.map MalList - - vec args = - case args of - [MalVector xs] -> Eval.succeed <| MalVector xs - [MalList xs] -> Eval.succeed <| MalVector <| Array.fromList xs - [_] -> Eval.fail "vec: arg type" - _ -> Eval.fail "vec: arg count" - - nth args = - let - get list index = - if index < 0 then - Nothing - else if index == 0 then - List.head list - else - case list of - [] -> - Nothing - - _ :: rest -> - get rest (index - 1) - - make res = - case res of - Just value -> - Eval.succeed value - - Nothing -> - Eval.fail "index out of bounds" - in - case args of - [ MalList list, MalInt index ] -> - make <| get list index - - [ MalVector vec, MalInt index ] -> - make <| Array.get index vec - - _ -> - Eval.fail "unsupported arguments" - - first args = - let - make = - Eval.succeed << Maybe.withDefault MalNil - in - case args of - [ MalNil ] -> - Eval.succeed MalNil - - [ MalList list ] -> - make <| List.head list - - [ MalVector vec ] -> - make <| Array.get 0 vec - - _ -> - Eval.fail "unsupported arguments" - - rest args = - case args of - [ MalNil ] -> - Eval.succeed <| MalList [] - - [ MalList [] ] -> - Eval.succeed <| MalList [] - - [ MalList (head :: tail) ] -> - Eval.succeed <| MalList tail - - [ MalVector vec ] -> - Array.toList vec - |> List.tail - |> Maybe.withDefault [] - |> MalList - |> Eval.succeed - - _ -> - Eval.fail "unsupported arguments" - - throw args = - case args of - ex :: _ -> - Eval.throw ex - - _ -> - Eval.fail "undefined exception" - - apply args = - case args of - (MalFunction func) :: rest -> - case List.reverse rest of - (MalList last) :: middle -> - callFn func ((List.reverse middle) ++ last) - - (MalVector last) :: middle -> - callFn func - ((List.reverse middle) - ++ (Array.toList last) - ) - - _ -> - Eval.fail "apply expected the last argument to be a list or vector" - - _ -> - Eval.fail "unsupported arguments" - - map args = - let - go func list acc = - case list of - [] -> - Eval.succeed <| MalList <| List.reverse acc - - inv :: rest -> - callFn func [ inv ] - |> Eval.andThen - (\outv -> - Eval.pushRef outv (go func rest (outv :: acc)) - ) - in - case args of - [ MalFunction func, MalList list ] -> - Eval.withStack (go func list []) - - [ MalFunction func, MalVector vec ] -> - go func (Array.toList vec) [] - - _ -> - Eval.fail "unsupported arguments" - - isNil args = - Eval.succeed <| - MalBool <| - case args of - MalNil :: _ -> - True - - _ -> - False - - isTrue args = - Eval.succeed <| - MalBool <| - case args of - (MalBool True) :: _ -> - True - - _ -> - False - - isFalse args = - Eval.succeed <| - MalBool <| - case args of - (MalBool False) :: _ -> - True - - _ -> - False - - isNumber args = - Eval.succeed <| - MalBool <| - case args of - (MalInt _) :: _ -> - True - - _ -> - False - - isSymbol args = - Eval.succeed <| - MalBool <| - case args of - (MalSymbol _) :: _ -> - True - - _ -> - False - - isKeyword args = - Eval.succeed <| - MalBool <| - case args of - (MalKeyword _) :: _ -> - True - - _ -> - False - - isVector args = - Eval.succeed <| - MalBool <| - case args of - (MalVector _) :: _ -> - True - - _ -> - False - - isMap args = - Eval.succeed <| - MalBool <| - case args of - (MalMap _) :: _ -> - True - - _ -> - False - - isString args = - Eval.succeed <| - MalBool <| - case args of - (MalString _) :: _ -> - True - - _ -> - False - - isSequential args = - Eval.succeed <| - MalBool <| - case args of - (MalList _) :: _ -> - True - - (MalVector _) :: _ -> - True - - _ -> - False - - isFn args = - Eval.succeed <| - MalBool <| - case args of - (MalFunction (CoreFunc _)) :: _ -> - True - (MalFunction (UserFunc fn)) :: _ -> - if fn.isMacro then - False - else - True - - _ -> - False - - isMacro args = - Eval.succeed <| - MalBool <| - case args of - (MalFunction (UserFunc fn)) :: _ -> - if fn.isMacro then - True - else - False - - _ -> - False - - symbol args = - case args of - [ MalString str ] -> - Eval.succeed <| MalSymbol str - - _ -> - Eval.fail "unsupported arguments" - - keyword args = - case args of - [ MalString str ] -> - Eval.succeed <| MalKeyword (String.cons ':' str) - - _ -> - Eval.fail "unsupported arguments" - - vector args = - Eval.succeed <| MalVector <| Array.fromList args - - parseKey key = - case key of - MalString str -> - Ok str - - MalKeyword keyword -> - Ok <| String.cons keywordPrefix keyword - - _ -> - Err "map key must be a symbol or keyword" - - buildMap list acc = - case list of - [] -> - Eval.succeed <| MalMap acc - - key :: value :: rest -> - parseKey key - |> Eval.fromResult - |> Eval.andThen - (\key -> - buildMap rest (Dict.insert key value acc) - ) - - _ -> - Eval.fail "expected an even number of key-value pairs" - - hashMap args = - buildMap args Dict.empty - - assoc args = - case args of - (MalMap dict) :: rest -> - buildMap rest dict - - _ -> - Eval.fail "unsupported arguments" - - dissoc args = - let - go keys acc = - case keys of - [] -> - Eval.succeed <| MalMap acc - - key :: rest -> - parseKey key - |> Eval.fromResult - |> Eval.andThen - (\key -> - go rest (Dict.remove key acc) - ) - in - case args of - (MalMap dict) :: keys -> - go keys dict - - _ -> - Eval.fail "unsupported arguments" - - get args = - case args of - [ MalNil, key ] -> - Eval.succeed MalNil - - [ MalMap dict, key ] -> - parseKey key - |> Eval.fromResult - |> Eval.map - (\key -> - Dict.get key dict - |> Maybe.withDefault MalNil - ) - - _ -> - Eval.fail "unsupported arguments" - - contains args = - case args of - [ MalMap dict, key ] -> - parseKey key - |> Eval.fromResult - |> Eval.map (\key -> Dict.member key dict) - |> Eval.map MalBool - - _ -> - Eval.fail "unsupported arguments" - - unparseKey key = - case String.uncons key of - Just ( prefix, rest ) -> - if prefix == keywordPrefix then - MalKeyword rest - else - MalString key - - _ -> - MalString key - - keys args = - case args of - [ MalMap dict ] -> - Dict.keys dict - |> List.map unparseKey - |> MalList - |> Eval.succeed - - _ -> - Eval.fail "unsupported arguments" - - vals args = - case args of - [ MalMap dict ] -> - Dict.values dict - |> MalList - |> Eval.succeed - - _ -> - Eval.fail "unsupported arguments" - - readLine args = - case args of - [ MalString prompt ] -> - Eval.io (IO.readLine prompt) - (\msg -> - case msg of - LineRead (Just line) -> - Eval.succeed (MalString line) - - LineRead Nothing -> - Eval.succeed MalNil - - _ -> - Eval.fail "wrong IO, expected LineRead" - ) - - _ -> - Eval.fail "unsupported arguments" - - withMeta args = - case args of - [ MalFunction (UserFunc func), meta ] -> - Eval.succeed <| MalFunction <| UserFunc { func | meta = Just meta } - - _ -> - Eval.fail "with-meta expected a user function and a map" - - meta args = - case args of - [ MalFunction (UserFunc { meta }) ] -> - Eval.succeed (Maybe.withDefault MalNil meta) - - _ -> - Eval.succeed MalNil - - conj args = - case args of - (MalList list) :: rest -> - Eval.succeed <| - MalList <| - (List.reverse rest) - ++ list - - (MalVector vec) :: rest -> - Eval.succeed <| - MalVector <| - Array.append - vec - (Array.fromList rest) - - _ -> - Eval.fail "unsupported arguments" - - seq args = - case args of - [ MalNil ] -> - Eval.succeed MalNil - - [ MalList [] ] -> - Eval.succeed MalNil - - [ MalString "" ] -> - Eval.succeed MalNil - - [ (MalList _) as list ] -> - Eval.succeed list - - [ MalVector vec ] -> - Eval.succeed <| - if Array.isEmpty vec then - MalNil - else - MalList <| Array.toList vec - - [ MalString str ] -> - Eval.succeed <| - MalList <| - (String.toList str - |> List.map String.fromChar - |> List.map MalString - ) - - _ -> - Eval.fail "unsupported arguments" - - requestTime = - Task.perform (GotTime >> Ok >> Input) Time.now - - timeMs args = - case args of - [] -> - Eval.io requestTime - (\msg -> - case msg of - GotTime time -> - Time.inMilliseconds time - |> floor - |> MalInt - |> Eval.succeed - - _ -> - Eval.fail "wrong IO, expected GotTime" - ) - - _ -> - Eval.fail "time-ms takes no arguments" - in - Env.global - |> Env.set "+" (makeFn <| binaryOp (+) MalInt) - |> Env.set "-" (makeFn <| binaryOp (-) MalInt) - |> Env.set "*" (makeFn <| binaryOp (*) MalInt) - |> Env.set "/" (makeFn <| binaryOp (//) MalInt) - |> Env.set "<" (makeFn <| binaryOp (<) MalBool) - |> Env.set ">" (makeFn <| binaryOp (>) MalBool) - |> Env.set "<=" (makeFn <| binaryOp (<=) MalBool) - |> Env.set ">=" (makeFn <| binaryOp (>=) MalBool) - |> Env.set "list" (makeFn list) - |> Env.set "list?" (makeFn isList) - |> Env.set "empty?" (makeFn isEmpty) - |> Env.set "count" (makeFn count) - |> Env.set "=" (makeFn equals) - |> Env.set "pr-str" (makeFn prStr) - |> Env.set "str" (makeFn str) - |> Env.set "prn" (makeFn prn) - |> Env.set "println" (makeFn println) - |> Env.set "pr-env" (makeFn printEnv) - |> Env.set "read-string" (makeFn readString) - |> Env.set "slurp" (makeFn slurp) - |> Env.set "atom" (makeFn atom) - |> Env.set "atom?" (makeFn isAtom) - |> Env.set "deref" (makeFn deref) - |> Env.set "reset!" (makeFn reset) - |> Env.set "swap!" (makeFn swap) - |> Env.set "gc" (makeFn gc) - |> Env.set "debug!" (makeFn debug) - |> Env.set "typeof" (makeFn typeof) - |> Env.set "cons" (makeFn cons) - |> Env.set "concat" (makeFn concat) - |> Env.set "vec" (makeFn vec) - |> Env.set "nth" (makeFn nth) - |> Env.set "first" (makeFn first) - |> Env.set "rest" (makeFn rest) - |> Env.set "throw" (makeFn throw) - |> Env.set "apply" (makeFn apply) - |> Env.set "map" (makeFn map) - |> Env.set "nil?" (makeFn isNil) - |> Env.set "true?" (makeFn isTrue) - |> Env.set "false?" (makeFn isFalse) - |> Env.set "number?" (makeFn isNumber) - |> Env.set "symbol?" (makeFn isSymbol) - |> Env.set "keyword?" (makeFn isKeyword) - |> Env.set "vector?" (makeFn isVector) - |> Env.set "map?" (makeFn isMap) - |> Env.set "string?" (makeFn isString) - |> Env.set "sequential?" (makeFn isSequential) - |> Env.set "fn?" (makeFn isFn) - |> Env.set "macro?" (makeFn isMacro) - |> Env.set "symbol" (makeFn symbol) - |> Env.set "keyword" (makeFn keyword) - |> Env.set "vector" (makeFn vector) - |> Env.set "hash-map" (makeFn hashMap) - |> Env.set "assoc" (makeFn assoc) - |> Env.set "dissoc" (makeFn dissoc) - |> Env.set "get" (makeFn get) - |> Env.set "contains?" (makeFn contains) - |> Env.set "keys" (makeFn keys) - |> Env.set "vals" (makeFn vals) - |> Env.set "readline" (makeFn readLine) - |> Env.set "with-meta" (makeFn withMeta) - |> Env.set "meta" (makeFn meta) - |> Env.set "conj" (makeFn conj) - |> Env.set "seq" (makeFn seq) - |> Env.set "time-ms" (makeFn timeMs) +module Core exposing (..) + +import Types exposing (..) +import Env +import Eval +import Printer exposing (printString) +import Array +import Dict +import IO exposing (IO(..)) +import Reader +import Utils exposing (zip) +import Time +import Task + + +ns : Env +ns = + let + makeFn = + CoreFunc >> MalFunction + + binaryOp fn retType args = + case args of + [ MalInt x, MalInt y ] -> + Eval.succeed (retType (fn x y)) + + _ -> + Eval.fail "unsupported arguments" + + {- list -} + list = + Eval.succeed << MalList + + {- list? -} + isList args = + case args of + [ MalList _ ] -> + Eval.succeed (MalBool True) + + _ -> + Eval.succeed (MalBool False) + + {- empty? -} + isEmpty args = + case args of + [ MalList list ] -> + Eval.succeed <| MalBool (List.isEmpty list) + + [ MalVector vec ] -> + Eval.succeed <| MalBool (Array.isEmpty vec) + + _ -> + Eval.fail "unsupported arguments" + + {- count -} + count args = + case args of + [ MalNil ] -> + Eval.succeed (MalInt 0) + + [ MalList list ] -> + Eval.succeed <| MalInt (List.length list) + + [ MalVector vec ] -> + Eval.succeed <| MalInt (Array.length vec) + + _ -> + Eval.fail "unsupported arguments" + + equalLists a b = + case ( a, b ) of + ( [], [] ) -> + True + + ( x :: xs, y :: ys ) -> + if deepEquals x y then + equalLists xs ys + else + False + + _ -> + False + + compareListTo list other = + case other of + MalList otherList -> + equalLists list otherList + + MalVector vec -> + equalLists list (Array.toList vec) + + _ -> + False + + equalMaps a b = + if Dict.keys a /= Dict.keys b then + False + else + zip (Dict.values a) (Dict.values b) + |> List.map (uncurry deepEquals) + |> List.all identity + + deepEquals a b = + case ( a, b ) of + ( MalList list, MalList otherList ) -> + equalLists list otherList + + ( MalList list, MalVector vec ) -> + equalLists list (Array.toList vec) + + ( MalList _, _ ) -> + False + + ( MalVector vec, MalList list ) -> + equalLists (Array.toList vec) list + + ( MalVector vec, MalVector otherVec ) -> + equalLists (Array.toList vec) (Array.toList otherVec) + + ( MalVector _, _ ) -> + False + + ( MalMap map, MalMap otherMap ) -> + equalMaps map otherMap + + ( MalMap _, _ ) -> + False + + ( _, MalMap _ ) -> + False + + _ -> + a == b + + {- = -} + equals args = + case args of + [ a, b ] -> + Eval.succeed <| MalBool (deepEquals a b) + + _ -> + Eval.fail "unsupported arguments" + + {- pr-str -} + prStr args = + Eval.withEnv + (\env -> + args + |> List.map (printString env True) + |> String.join " " + |> MalString + |> Eval.succeed + ) + + {- str -} + str args = + Eval.withEnv + (\env -> + args + |> List.map (printString env False) + |> String.join "" + |> MalString + |> Eval.succeed + ) + + {- helper function to write a string to stdout -} + writeLine str = + Eval.io (IO.writeLine str) + (\msg -> + case msg of + LineWritten -> + Eval.succeed MalNil + + _ -> + Eval.fail "wrong IO, expected LineWritten" + ) + + prn args = + Eval.withEnv + (\env -> + args + |> List.map (printString env True) + |> String.join " " + |> writeLine + ) + + println args = + Eval.withEnv + (\env -> + args + |> List.map (printString env False) + |> String.join " " + |> writeLine + ) + + printEnv args = + case args of + [] -> + Eval.withEnv (Printer.printEnv >> writeLine) + + _ -> + Eval.fail "unsupported arguments" + + readString args = + case args of + [ MalString str ] -> + case Reader.readString str of + Ok Nothing -> + Eval.succeed MalNil + + Ok (Just ast) -> + Eval.succeed ast + + Err msg -> + Eval.fail msg + + _ -> + Eval.fail "unsupported arguments" + + slurp args = + case args of + [ MalString filename ] -> + Eval.io (IO.readFile filename) + (\msg -> + case msg of + FileRead contents -> + Eval.succeed <| MalString contents + + Exception msg -> + Eval.fail msg + + _ -> + Eval.fail "wrong IO, expected FileRead" + ) + + _ -> + Eval.fail "unsupported arguments" + + atom args = + case args of + [ value ] -> + Eval.withEnv + (\env -> + case Env.newAtom value env of + ( newEnv, atomId ) -> + Eval.setEnv newEnv + |> Eval.map (\_ -> MalAtom atomId) + ) + + _ -> + Eval.fail "unsupported arguments" + + isAtom args = + case args of + [ MalAtom _ ] -> + Eval.succeed <| MalBool True + + _ -> + Eval.succeed <| MalBool False + + deref args = + case args of + [ MalAtom atomId ] -> + Eval.withEnv (Env.getAtom atomId >> Eval.succeed) + + _ -> + Eval.fail "unsupported arguments" + + reset args = + case args of + [ MalAtom atomId, value ] -> + Eval.modifyEnv (Env.setAtom atomId value) + |> Eval.map (always value) + + _ -> + Eval.fail "unsupported arguments" + + {- helper function for calling a core or user function -} + callFn func args = + case func of + CoreFunc fn -> + fn args + + UserFunc { eagerFn } -> + eagerFn args + + swap args = + case args of + (MalAtom atomId) :: (MalFunction func) :: args -> + Eval.withEnv + (\env -> + let + value = + Env.getAtom atomId env + in + callFn func (value :: args) + ) + |> Eval.andThen + (\res -> + Eval.modifyEnv (Env.setAtom atomId res) + |> Eval.map (always res) + ) + + _ -> + Eval.fail "unsupported arguments" + + gc args = + Eval.withEnv (Env.gc MalNil >> Printer.printEnv >> writeLine) + + setDebug enabled = + Eval.modifyEnv + (\env -> + { env | debug = enabled } + ) + |> Eval.andThen (\_ -> Eval.succeed MalNil) + + debug args = + case args of + [ MalBool value ] -> + setDebug value + + _ -> + Eval.withEnv + (\env -> + Eval.succeed (MalBool env.debug) + ) + + typeof args = + case args of + [ MalInt _ ] -> + Eval.succeed <| MalSymbol "int" + + [ MalBool _ ] -> + Eval.succeed <| MalSymbol "bool" + + [ MalString _ ] -> + Eval.succeed <| MalSymbol "string" + + [ MalKeyword _ ] -> + Eval.succeed <| MalSymbol "keyword" + + [ MalSymbol _ ] -> + Eval.succeed <| MalSymbol "symbol" + + [ MalNil ] -> + Eval.succeed <| MalSymbol "nil" + + [ MalList _ ] -> + Eval.succeed <| MalSymbol "vector" + + [ MalVector _ ] -> + Eval.succeed <| MalSymbol "vector" + + [ MalMap _ ] -> + Eval.succeed <| MalSymbol "vector" + + [ MalFunction _ ] -> + Eval.succeed <| MalSymbol "function" + + [ MalAtom _ ] -> + Eval.succeed <| MalSymbol "atom" + + _ -> + Eval.fail "unsupported arguments" + + cons args = + case args of + [ e, MalList list ] -> + Eval.succeed <| MalList (e :: list) + + [ e, MalVector vec ] -> + Eval.succeed <| MalList (e :: (Array.toList vec)) + + _ -> + Eval.fail "unsupported arguments" + + concat args = + let + go arg acc = + case arg of + MalList list -> + Eval.succeed (acc ++ list) + + MalVector vec -> + Eval.succeed (acc ++ Array.toList vec) + + _ -> + Eval.fail "unsupported arguments" + in + List.foldl (go >> Eval.andThen) (Eval.succeed []) args + |> Eval.map MalList + + vec args = + case args of + [MalVector xs] -> Eval.succeed <| MalVector xs + [MalList xs] -> Eval.succeed <| MalVector <| Array.fromList xs + [_] -> Eval.fail "vec: arg type" + _ -> Eval.fail "vec: arg count" + + nth args = + let + get list index = + if index < 0 then + Nothing + else if index == 0 then + List.head list + else + case list of + [] -> + Nothing + + _ :: rest -> + get rest (index - 1) + + make res = + case res of + Just value -> + Eval.succeed value + + Nothing -> + Eval.fail "index out of bounds" + in + case args of + [ MalList list, MalInt index ] -> + make <| get list index + + [ MalVector vec, MalInt index ] -> + make <| Array.get index vec + + _ -> + Eval.fail "unsupported arguments" + + first args = + let + make = + Eval.succeed << Maybe.withDefault MalNil + in + case args of + [ MalNil ] -> + Eval.succeed MalNil + + [ MalList list ] -> + make <| List.head list + + [ MalVector vec ] -> + make <| Array.get 0 vec + + _ -> + Eval.fail "unsupported arguments" + + rest args = + case args of + [ MalNil ] -> + Eval.succeed <| MalList [] + + [ MalList [] ] -> + Eval.succeed <| MalList [] + + [ MalList (head :: tail) ] -> + Eval.succeed <| MalList tail + + [ MalVector vec ] -> + Array.toList vec + |> List.tail + |> Maybe.withDefault [] + |> MalList + |> Eval.succeed + + _ -> + Eval.fail "unsupported arguments" + + throw args = + case args of + ex :: _ -> + Eval.throw ex + + _ -> + Eval.fail "undefined exception" + + apply args = + case args of + (MalFunction func) :: rest -> + case List.reverse rest of + (MalList last) :: middle -> + callFn func ((List.reverse middle) ++ last) + + (MalVector last) :: middle -> + callFn func + ((List.reverse middle) + ++ (Array.toList last) + ) + + _ -> + Eval.fail "apply expected the last argument to be a list or vector" + + _ -> + Eval.fail "unsupported arguments" + + map args = + let + go func list acc = + case list of + [] -> + Eval.succeed <| MalList <| List.reverse acc + + inv :: rest -> + callFn func [ inv ] + |> Eval.andThen + (\outv -> + Eval.pushRef outv (go func rest (outv :: acc)) + ) + in + case args of + [ MalFunction func, MalList list ] -> + Eval.withStack (go func list []) + + [ MalFunction func, MalVector vec ] -> + go func (Array.toList vec) [] + + _ -> + Eval.fail "unsupported arguments" + + isNil args = + Eval.succeed <| + MalBool <| + case args of + MalNil :: _ -> + True + + _ -> + False + + isTrue args = + Eval.succeed <| + MalBool <| + case args of + (MalBool True) :: _ -> + True + + _ -> + False + + isFalse args = + Eval.succeed <| + MalBool <| + case args of + (MalBool False) :: _ -> + True + + _ -> + False + + isNumber args = + Eval.succeed <| + MalBool <| + case args of + (MalInt _) :: _ -> + True + + _ -> + False + + isSymbol args = + Eval.succeed <| + MalBool <| + case args of + (MalSymbol _) :: _ -> + True + + _ -> + False + + isKeyword args = + Eval.succeed <| + MalBool <| + case args of + (MalKeyword _) :: _ -> + True + + _ -> + False + + isVector args = + Eval.succeed <| + MalBool <| + case args of + (MalVector _) :: _ -> + True + + _ -> + False + + isMap args = + Eval.succeed <| + MalBool <| + case args of + (MalMap _) :: _ -> + True + + _ -> + False + + isString args = + Eval.succeed <| + MalBool <| + case args of + (MalString _) :: _ -> + True + + _ -> + False + + isSequential args = + Eval.succeed <| + MalBool <| + case args of + (MalList _) :: _ -> + True + + (MalVector _) :: _ -> + True + + _ -> + False + + isFn args = + Eval.succeed <| + MalBool <| + case args of + (MalFunction (CoreFunc _)) :: _ -> + True + (MalFunction (UserFunc fn)) :: _ -> + if fn.isMacro then + False + else + True + + _ -> + False + + isMacro args = + Eval.succeed <| + MalBool <| + case args of + (MalFunction (UserFunc fn)) :: _ -> + if fn.isMacro then + True + else + False + + _ -> + False + + symbol args = + case args of + [ MalString str ] -> + Eval.succeed <| MalSymbol str + + _ -> + Eval.fail "unsupported arguments" + + keyword args = + case args of + [ MalString str ] -> + Eval.succeed <| MalKeyword (String.cons ':' str) + + _ -> + Eval.fail "unsupported arguments" + + vector args = + Eval.succeed <| MalVector <| Array.fromList args + + parseKey key = + case key of + MalString str -> + Ok str + + MalKeyword keyword -> + Ok <| String.cons keywordPrefix keyword + + _ -> + Err "map key must be a symbol or keyword" + + buildMap list acc = + case list of + [] -> + Eval.succeed <| MalMap acc + + key :: value :: rest -> + parseKey key + |> Eval.fromResult + |> Eval.andThen + (\key -> + buildMap rest (Dict.insert key value acc) + ) + + _ -> + Eval.fail "expected an even number of key-value pairs" + + hashMap args = + buildMap args Dict.empty + + assoc args = + case args of + (MalMap dict) :: rest -> + buildMap rest dict + + _ -> + Eval.fail "unsupported arguments" + + dissoc args = + let + go keys acc = + case keys of + [] -> + Eval.succeed <| MalMap acc + + key :: rest -> + parseKey key + |> Eval.fromResult + |> Eval.andThen + (\key -> + go rest (Dict.remove key acc) + ) + in + case args of + (MalMap dict) :: keys -> + go keys dict + + _ -> + Eval.fail "unsupported arguments" + + get args = + case args of + [ MalNil, key ] -> + Eval.succeed MalNil + + [ MalMap dict, key ] -> + parseKey key + |> Eval.fromResult + |> Eval.map + (\key -> + Dict.get key dict + |> Maybe.withDefault MalNil + ) + + _ -> + Eval.fail "unsupported arguments" + + contains args = + case args of + [ MalMap dict, key ] -> + parseKey key + |> Eval.fromResult + |> Eval.map (\key -> Dict.member key dict) + |> Eval.map MalBool + + _ -> + Eval.fail "unsupported arguments" + + unparseKey key = + case String.uncons key of + Just ( prefix, rest ) -> + if prefix == keywordPrefix then + MalKeyword rest + else + MalString key + + _ -> + MalString key + + keys args = + case args of + [ MalMap dict ] -> + Dict.keys dict + |> List.map unparseKey + |> MalList + |> Eval.succeed + + _ -> + Eval.fail "unsupported arguments" + + vals args = + case args of + [ MalMap dict ] -> + Dict.values dict + |> MalList + |> Eval.succeed + + _ -> + Eval.fail "unsupported arguments" + + readLine args = + case args of + [ MalString prompt ] -> + Eval.io (IO.readLine prompt) + (\msg -> + case msg of + LineRead (Just line) -> + Eval.succeed (MalString line) + + LineRead Nothing -> + Eval.succeed MalNil + + _ -> + Eval.fail "wrong IO, expected LineRead" + ) + + _ -> + Eval.fail "unsupported arguments" + + withMeta args = + case args of + [ MalFunction (UserFunc func), meta ] -> + Eval.succeed <| MalFunction <| UserFunc { func | meta = Just meta } + + _ -> + Eval.fail "with-meta expected a user function and a map" + + meta args = + case args of + [ MalFunction (UserFunc { meta }) ] -> + Eval.succeed (Maybe.withDefault MalNil meta) + + _ -> + Eval.succeed MalNil + + conj args = + case args of + (MalList list) :: rest -> + Eval.succeed <| + MalList <| + (List.reverse rest) + ++ list + + (MalVector vec) :: rest -> + Eval.succeed <| + MalVector <| + Array.append + vec + (Array.fromList rest) + + _ -> + Eval.fail "unsupported arguments" + + seq args = + case args of + [ MalNil ] -> + Eval.succeed MalNil + + [ MalList [] ] -> + Eval.succeed MalNil + + [ MalString "" ] -> + Eval.succeed MalNil + + [ (MalList _) as list ] -> + Eval.succeed list + + [ MalVector vec ] -> + Eval.succeed <| + if Array.isEmpty vec then + MalNil + else + MalList <| Array.toList vec + + [ MalString str ] -> + Eval.succeed <| + MalList <| + (String.toList str + |> List.map String.fromChar + |> List.map MalString + ) + + _ -> + Eval.fail "unsupported arguments" + + requestTime = + Task.perform (GotTime >> Ok >> Input) Time.now + + timeMs args = + case args of + [] -> + Eval.io requestTime + (\msg -> + case msg of + GotTime time -> + Time.inMilliseconds time + |> floor + |> MalInt + |> Eval.succeed + + _ -> + Eval.fail "wrong IO, expected GotTime" + ) + + _ -> + Eval.fail "time-ms takes no arguments" + in + Env.global + |> Env.set "+" (makeFn <| binaryOp (+) MalInt) + |> Env.set "-" (makeFn <| binaryOp (-) MalInt) + |> Env.set "*" (makeFn <| binaryOp (*) MalInt) + |> Env.set "/" (makeFn <| binaryOp (//) MalInt) + |> Env.set "<" (makeFn <| binaryOp (<) MalBool) + |> Env.set ">" (makeFn <| binaryOp (>) MalBool) + |> Env.set "<=" (makeFn <| binaryOp (<=) MalBool) + |> Env.set ">=" (makeFn <| binaryOp (>=) MalBool) + |> Env.set "list" (makeFn list) + |> Env.set "list?" (makeFn isList) + |> Env.set "empty?" (makeFn isEmpty) + |> Env.set "count" (makeFn count) + |> Env.set "=" (makeFn equals) + |> Env.set "pr-str" (makeFn prStr) + |> Env.set "str" (makeFn str) + |> Env.set "prn" (makeFn prn) + |> Env.set "println" (makeFn println) + |> Env.set "pr-env" (makeFn printEnv) + |> Env.set "read-string" (makeFn readString) + |> Env.set "slurp" (makeFn slurp) + |> Env.set "atom" (makeFn atom) + |> Env.set "atom?" (makeFn isAtom) + |> Env.set "deref" (makeFn deref) + |> Env.set "reset!" (makeFn reset) + |> Env.set "swap!" (makeFn swap) + |> Env.set "gc" (makeFn gc) + |> Env.set "debug!" (makeFn debug) + |> Env.set "typeof" (makeFn typeof) + |> Env.set "cons" (makeFn cons) + |> Env.set "concat" (makeFn concat) + |> Env.set "vec" (makeFn vec) + |> Env.set "nth" (makeFn nth) + |> Env.set "first" (makeFn first) + |> Env.set "rest" (makeFn rest) + |> Env.set "throw" (makeFn throw) + |> Env.set "apply" (makeFn apply) + |> Env.set "map" (makeFn map) + |> Env.set "nil?" (makeFn isNil) + |> Env.set "true?" (makeFn isTrue) + |> Env.set "false?" (makeFn isFalse) + |> Env.set "number?" (makeFn isNumber) + |> Env.set "symbol?" (makeFn isSymbol) + |> Env.set "keyword?" (makeFn isKeyword) + |> Env.set "vector?" (makeFn isVector) + |> Env.set "map?" (makeFn isMap) + |> Env.set "string?" (makeFn isString) + |> Env.set "sequential?" (makeFn isSequential) + |> Env.set "fn?" (makeFn isFn) + |> Env.set "macro?" (makeFn isMacro) + |> Env.set "symbol" (makeFn symbol) + |> Env.set "keyword" (makeFn keyword) + |> Env.set "vector" (makeFn vector) + |> Env.set "hash-map" (makeFn hashMap) + |> Env.set "assoc" (makeFn assoc) + |> Env.set "dissoc" (makeFn dissoc) + |> Env.set "get" (makeFn get) + |> Env.set "contains?" (makeFn contains) + |> Env.set "keys" (makeFn keys) + |> Env.set "vals" (makeFn vals) + |> Env.set "readline" (makeFn readLine) + |> Env.set "with-meta" (makeFn withMeta) + |> Env.set "meta" (makeFn meta) + |> Env.set "conj" (makeFn conj) + |> Env.set "seq" (makeFn seq) + |> Env.set "time-ms" (makeFn timeMs) diff --git a/impls/elm/Dockerfile b/impls/elm/Dockerfile index b0553bd56b..8845822301 100644 --- a/impls/elm/Dockerfile +++ b/impls/elm/Dockerfile @@ -1,38 +1,38 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -# For pulling elm packages -RUN apt-get -y install netbase - -ENV HOME /mal -ENV NPM_CONFIG_CACHE /mal/.npm +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +# For pulling elm packages +RUN apt-get -y install netbase + +ENV HOME /mal +ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/impls/elm/Env.elm b/impls/elm/Env.elm index 7aaff29da8..4e0f4f701f 100644 --- a/impls/elm/Env.elm +++ b/impls/elm/Env.elm @@ -1,424 +1,424 @@ -module Env - exposing - ( debug - , globalFrameId - , global - , get - , set - , newAtom - , getAtom - , setAtom - , push - , pop - , enter - , leave - , ref - , pushRef - , restoreRefs - , gc - ) - -import Types exposing (MalExpr(..), MalFunction(..), Frame, Env) -import Dict -import Array -import Set - - -debug : Env -> String -> a -> a -debug env msg value = - if env.debug then - Debug.log msg value - else - value - - -globalFrameId : Int -globalFrameId = - 0 - - -defaultGcInterval : Int -defaultGcInterval = - 10 - - -global : Env -global = - { frames = Dict.singleton globalFrameId (emptyFrame Nothing Nothing) - , nextFrameId = globalFrameId + 1 - , currentFrameId = globalFrameId - , atoms = Dict.empty - , nextAtomId = 0 - , debug = False - , gcInterval = defaultGcInterval - , gcCounter = 0 - , stack = [] - , keepFrames = [] - } - - -getFrame : Env -> Int -> Frame -getFrame env frameId = - case Dict.get frameId env.frames of - Just frame -> - frame - - Nothing -> - Debug.crash <| "frame #" ++ (toString frameId) ++ " not found" - - -emptyFrame : Maybe Int -> Maybe Int -> Frame -emptyFrame outerId exitId = - { outerId = outerId - , exitId = exitId - , data = Dict.empty - , refCnt = 1 - } - - -set : String -> MalExpr -> Env -> Env -set name expr env = - let - frameId = - env.currentFrameId - - updateFrame = - Maybe.map - (\frame -> - { frame | data = Dict.insert name expr frame.data } - ) - - newFrames = - Dict.update frameId updateFrame env.frames - in - { env | frames = newFrames } - - -get : String -> Env -> Result String MalExpr -get name env = - let - go frameId = - let - frame = - getFrame env frameId - in - case Dict.get name frame.data of - Just value -> - Ok value - - Nothing -> - frame.outerId - |> Maybe.map go - |> Maybe.withDefault (Err <| "'" ++ name ++ "' not found") - in - go env.currentFrameId - - -newAtom : MalExpr -> Env -> ( Env, Int ) -newAtom value env = - let - atomId = - env.nextAtomId - - newEnv = - { env - | atoms = Dict.insert atomId value env.atoms - , nextAtomId = atomId + 1 - } - in - ( newEnv, atomId ) - - -getAtom : Int -> Env -> MalExpr -getAtom atomId env = - case Dict.get atomId env.atoms of - Just value -> - value - - Nothing -> - Debug.crash <| "atom " ++ (toString atomId) ++ " not found" - - -setAtom : Int -> MalExpr -> Env -> Env -setAtom atomId value env = - { env - | atoms = Dict.insert atomId value env.atoms - } - - -push : Env -> Env -push env = - let - frameId = - env.nextFrameId - - newFrame = - emptyFrame (Just env.currentFrameId) Nothing - - bogus = - debug env "push" frameId - in - { env - | currentFrameId = frameId - , frames = Dict.insert frameId newFrame env.frames - , nextFrameId = env.nextFrameId + 1 - } - - -pop : Env -> Env -pop env = - let - frameId = - env.currentFrameId - - frame = - getFrame env frameId - - bogus = - debug env "pop" frameId - in - case frame.outerId of - Just outerId -> - { env - | currentFrameId = outerId - , frames = Dict.update frameId free env.frames - } - - _ -> - Debug.crash "tried to pop global frame" - - -setBinds : List ( String, MalExpr ) -> Frame -> Frame -setBinds binds frame = - case binds of - [] -> - frame - - ( name, expr ) :: rest -> - setBinds rest - { frame | data = Dict.insert name expr frame.data } - - -{-| Enter a new frame with a set of binds --} -enter : Int -> List ( String, MalExpr ) -> Env -> Env -enter outerId binds env = - let - frameId = - debug env "enter #" env.nextFrameId - - exitId = - env.currentFrameId - - newFrame = - setBinds binds (emptyFrame (Just outerId) (Just exitId)) - in - { env - | currentFrameId = frameId - , frames = Dict.insert frameId newFrame env.frames - , nextFrameId = env.nextFrameId + 1 - } - - -leave : Env -> Env -leave env = - let - frameId = - debug env "leave #" env.currentFrameId - - frame = - getFrame env frameId - - exitId = - case frame.exitId of - Just exitId -> - exitId - - Nothing -> - Debug.crash <| - "frame #" - ++ (toString frameId) - ++ " doesn't have an exitId" - in - { env - | currentFrameId = exitId - , frames = - env.frames - |> Dict.insert frameId { frame | exitId = Nothing } - |> Dict.update frameId free - } - - -{-| Increase refCnt for the current frame, -and all it's parent frames. --} -ref : Env -> Env -ref env = - let - go frameId env = - let - frame = - getFrame env frameId - - newFrame = - { frame | refCnt = frame.refCnt + 1 } - - newEnv = - { env | frames = Dict.insert frameId newFrame env.frames } - in - case frame.outerId of - Just outerId -> - go outerId newEnv - - Nothing -> - newEnv - - newEnv = - go env.currentFrameId env - in - { newEnv | gcCounter = newEnv.gcCounter + 1 } - - -free : Maybe Frame -> Maybe Frame -free = - Maybe.andThen - (\frame -> - if frame.refCnt == 1 then - Nothing - else - Just { frame | refCnt = frame.refCnt - 1 } - ) - - -pushRef : MalExpr -> Env -> Env -pushRef ref env = - { env | stack = ref :: env.stack } - - -restoreRefs : List MalExpr -> Env -> Env -restoreRefs refs env = - { env | stack = refs } - - -{-| Given an Env see which frames are not reachable from the -global frame, or from the current expression. - -Return a new Env with the unreachable frames removed. - --} -gc : MalExpr -> Env -> Env -gc expr env = - let - countList acc = - List.foldl countExpr acc - - countFrame { data } acc = - data |> Dict.values |> countList acc - - recur frameId acc = - if not (Set.member frameId acc) then - let - frame = - getFrame env frameId - - newAcc = - Set.insert frameId acc - in - countFrame frame newAcc - else - acc - - countBound bound acc = - bound - |> List.map Tuple.second - |> countList acc - - countExpr expr acc = - case expr of - MalFunction (UserFunc { frameId }) -> - recur frameId acc - - MalApply { frameId, bound } -> - recur frameId acc - |> countBound bound - - MalList list -> - countList acc list - - MalVector vec -> - countList acc (Array.toList vec) - - MalMap map -> - countList acc (Dict.values map) - - MalAtom atomId -> - let - value = - getAtom atomId env - in - countExpr value acc - - _ -> - acc - - initSet = - Set.fromList - ([ globalFrameId, env.currentFrameId ] - ++ env.keepFrames - ) - - countFrames frames acc = - Set.toList frames - |> List.map (getFrame env) - |> List.foldl countFrame acc - - expand frameId frame fn acc = - case fn frame of - Nothing -> - acc - - Just parentId -> - Set.insert parentId acc - - expandBoth frameId = - let - frame = - getFrame env frameId - in - expand frameId frame .outerId - >> expand frameId frame .exitId - - expandParents frames = - Set.foldl expandBoth frames frames - - loop acc = - let - newAcc = - expandParents acc - - newParents = - Set.diff newAcc acc - in - if Set.isEmpty newParents then - newAcc - else - loop <| countFrames newParents newAcc - - makeNewEnv newFrames = - { env - | frames = newFrames - , gcCounter = 0 - } - - keepFilter keep frameId _ = - Set.member frameId keep - - filterFrames frames keep = - Dict.filter (keepFilter keep) frames - in - countFrames initSet initSet - |> countExpr expr - |> (flip countList) env.stack - |> loop - |> filterFrames env.frames - |> makeNewEnv +module Env + exposing + ( debug + , globalFrameId + , global + , get + , set + , newAtom + , getAtom + , setAtom + , push + , pop + , enter + , leave + , ref + , pushRef + , restoreRefs + , gc + ) + +import Types exposing (MalExpr(..), MalFunction(..), Frame, Env) +import Dict +import Array +import Set + + +debug : Env -> String -> a -> a +debug env msg value = + if env.debug then + Debug.log msg value + else + value + + +globalFrameId : Int +globalFrameId = + 0 + + +defaultGcInterval : Int +defaultGcInterval = + 10 + + +global : Env +global = + { frames = Dict.singleton globalFrameId (emptyFrame Nothing Nothing) + , nextFrameId = globalFrameId + 1 + , currentFrameId = globalFrameId + , atoms = Dict.empty + , nextAtomId = 0 + , debug = False + , gcInterval = defaultGcInterval + , gcCounter = 0 + , stack = [] + , keepFrames = [] + } + + +getFrame : Env -> Int -> Frame +getFrame env frameId = + case Dict.get frameId env.frames of + Just frame -> + frame + + Nothing -> + Debug.crash <| "frame #" ++ (toString frameId) ++ " not found" + + +emptyFrame : Maybe Int -> Maybe Int -> Frame +emptyFrame outerId exitId = + { outerId = outerId + , exitId = exitId + , data = Dict.empty + , refCnt = 1 + } + + +set : String -> MalExpr -> Env -> Env +set name expr env = + let + frameId = + env.currentFrameId + + updateFrame = + Maybe.map + (\frame -> + { frame | data = Dict.insert name expr frame.data } + ) + + newFrames = + Dict.update frameId updateFrame env.frames + in + { env | frames = newFrames } + + +get : String -> Env -> Result String MalExpr +get name env = + let + go frameId = + let + frame = + getFrame env frameId + in + case Dict.get name frame.data of + Just value -> + Ok value + + Nothing -> + frame.outerId + |> Maybe.map go + |> Maybe.withDefault (Err <| "'" ++ name ++ "' not found") + in + go env.currentFrameId + + +newAtom : MalExpr -> Env -> ( Env, Int ) +newAtom value env = + let + atomId = + env.nextAtomId + + newEnv = + { env + | atoms = Dict.insert atomId value env.atoms + , nextAtomId = atomId + 1 + } + in + ( newEnv, atomId ) + + +getAtom : Int -> Env -> MalExpr +getAtom atomId env = + case Dict.get atomId env.atoms of + Just value -> + value + + Nothing -> + Debug.crash <| "atom " ++ (toString atomId) ++ " not found" + + +setAtom : Int -> MalExpr -> Env -> Env +setAtom atomId value env = + { env + | atoms = Dict.insert atomId value env.atoms + } + + +push : Env -> Env +push env = + let + frameId = + env.nextFrameId + + newFrame = + emptyFrame (Just env.currentFrameId) Nothing + + bogus = + debug env "push" frameId + in + { env + | currentFrameId = frameId + , frames = Dict.insert frameId newFrame env.frames + , nextFrameId = env.nextFrameId + 1 + } + + +pop : Env -> Env +pop env = + let + frameId = + env.currentFrameId + + frame = + getFrame env frameId + + bogus = + debug env "pop" frameId + in + case frame.outerId of + Just outerId -> + { env + | currentFrameId = outerId + , frames = Dict.update frameId free env.frames + } + + _ -> + Debug.crash "tried to pop global frame" + + +setBinds : List ( String, MalExpr ) -> Frame -> Frame +setBinds binds frame = + case binds of + [] -> + frame + + ( name, expr ) :: rest -> + setBinds rest + { frame | data = Dict.insert name expr frame.data } + + +{-| Enter a new frame with a set of binds +-} +enter : Int -> List ( String, MalExpr ) -> Env -> Env +enter outerId binds env = + let + frameId = + debug env "enter #" env.nextFrameId + + exitId = + env.currentFrameId + + newFrame = + setBinds binds (emptyFrame (Just outerId) (Just exitId)) + in + { env + | currentFrameId = frameId + , frames = Dict.insert frameId newFrame env.frames + , nextFrameId = env.nextFrameId + 1 + } + + +leave : Env -> Env +leave env = + let + frameId = + debug env "leave #" env.currentFrameId + + frame = + getFrame env frameId + + exitId = + case frame.exitId of + Just exitId -> + exitId + + Nothing -> + Debug.crash <| + "frame #" + ++ (toString frameId) + ++ " doesn't have an exitId" + in + { env + | currentFrameId = exitId + , frames = + env.frames + |> Dict.insert frameId { frame | exitId = Nothing } + |> Dict.update frameId free + } + + +{-| Increase refCnt for the current frame, +and all it's parent frames. +-} +ref : Env -> Env +ref env = + let + go frameId env = + let + frame = + getFrame env frameId + + newFrame = + { frame | refCnt = frame.refCnt + 1 } + + newEnv = + { env | frames = Dict.insert frameId newFrame env.frames } + in + case frame.outerId of + Just outerId -> + go outerId newEnv + + Nothing -> + newEnv + + newEnv = + go env.currentFrameId env + in + { newEnv | gcCounter = newEnv.gcCounter + 1 } + + +free : Maybe Frame -> Maybe Frame +free = + Maybe.andThen + (\frame -> + if frame.refCnt == 1 then + Nothing + else + Just { frame | refCnt = frame.refCnt - 1 } + ) + + +pushRef : MalExpr -> Env -> Env +pushRef ref env = + { env | stack = ref :: env.stack } + + +restoreRefs : List MalExpr -> Env -> Env +restoreRefs refs env = + { env | stack = refs } + + +{-| Given an Env see which frames are not reachable from the +global frame, or from the current expression. + +Return a new Env with the unreachable frames removed. + +-} +gc : MalExpr -> Env -> Env +gc expr env = + let + countList acc = + List.foldl countExpr acc + + countFrame { data } acc = + data |> Dict.values |> countList acc + + recur frameId acc = + if not (Set.member frameId acc) then + let + frame = + getFrame env frameId + + newAcc = + Set.insert frameId acc + in + countFrame frame newAcc + else + acc + + countBound bound acc = + bound + |> List.map Tuple.second + |> countList acc + + countExpr expr acc = + case expr of + MalFunction (UserFunc { frameId }) -> + recur frameId acc + + MalApply { frameId, bound } -> + recur frameId acc + |> countBound bound + + MalList list -> + countList acc list + + MalVector vec -> + countList acc (Array.toList vec) + + MalMap map -> + countList acc (Dict.values map) + + MalAtom atomId -> + let + value = + getAtom atomId env + in + countExpr value acc + + _ -> + acc + + initSet = + Set.fromList + ([ globalFrameId, env.currentFrameId ] + ++ env.keepFrames + ) + + countFrames frames acc = + Set.toList frames + |> List.map (getFrame env) + |> List.foldl countFrame acc + + expand frameId frame fn acc = + case fn frame of + Nothing -> + acc + + Just parentId -> + Set.insert parentId acc + + expandBoth frameId = + let + frame = + getFrame env frameId + in + expand frameId frame .outerId + >> expand frameId frame .exitId + + expandParents frames = + Set.foldl expandBoth frames frames + + loop acc = + let + newAcc = + expandParents acc + + newParents = + Set.diff newAcc acc + in + if Set.isEmpty newParents then + newAcc + else + loop <| countFrames newParents newAcc + + makeNewEnv newFrames = + { env + | frames = newFrames + , gcCounter = 0 + } + + keepFilter keep frameId _ = + Set.member frameId keep + + filterFrames frames keep = + Dict.filter (keepFilter keep) frames + in + countFrames initSet initSet + |> countExpr expr + |> (flip countList) env.stack + |> loop + |> filterFrames env.frames + |> makeNewEnv diff --git a/impls/elm/Eval.elm b/impls/elm/Eval.elm index d05888f947..780954f56f 100644 --- a/impls/elm/Eval.elm +++ b/impls/elm/Eval.elm @@ -1,238 +1,238 @@ -module Eval exposing (..) - -import Types exposing (..) -import IO exposing (IO) -import Env - - -apply : Eval a -> Env -> EvalContext a -apply f env = - f env - - -run : Env -> Eval a -> EvalContext a -run env e = - apply e env - - -withEnv : (Env -> Eval a) -> Eval a -withEnv f env = - apply (f env) env - - -setEnv : Env -> Eval () -setEnv env _ = - apply (succeed ()) env - - -modifyEnv : (Env -> Env) -> Eval () -modifyEnv f env = - apply (succeed ()) (f env) - - -succeed : a -> Eval a -succeed res env = - ( env, EvalOk res ) - - -io : Cmd Msg -> (IO -> Eval a) -> Eval a -io cmd cont env = - ( env, EvalIO cmd cont ) - - -map : (a -> b) -> Eval a -> Eval b -map f e env = - case apply e env of - ( env, EvalOk res ) -> - ( env, EvalOk (f res) ) - - ( env, EvalErr msg ) -> - ( env, EvalErr msg ) - - ( env, EvalIO cmd cont ) -> - ( env, EvalIO cmd (cont >> map f) ) - - -{-| Chain two Eval's together. The function f takes the result from -the left eval and generates a new Eval. --} -andThen : (a -> Eval b) -> Eval a -> Eval b -andThen f e env = - case apply e env of - ( env, EvalOk res ) -> - apply (f res) env - - ( env, EvalErr msg ) -> - ( env, EvalErr msg ) - - ( env, EvalIO cmd cont ) -> - ( env, EvalIO cmd (cont >> andThen f) ) - - -{-| Apply a transformation to the Env, for a Ok and a Err. --} -finally : (Env -> Env) -> Eval a -> Eval a -finally f e env = - case apply e env of - ( env, EvalOk res ) -> - ( f env, EvalOk res ) - - ( env, EvalErr msg ) -> - ( f env, EvalErr msg ) - - ( env, EvalIO cmd cont ) -> - ( env, EvalIO cmd (cont >> finally f) ) - - -gcPass : Eval MalExpr -> Eval MalExpr -gcPass e env = - let - go env t expr = - if env.gcCounter >= env.gcInterval then - --Debug.log - -- ("before GC: " - -- ++ (printEnv env) - -- ) - -- "" - -- |> always ( Env.gc env, t expr ) - ( Env.gc expr env, t expr ) - else - ( env, t expr ) - in - case apply e env of - ( env, EvalOk res ) -> - go env EvalOk res - - ( env, EvalErr msg ) -> - go env EvalErr msg - - ( env, EvalIO cmd cont ) -> - ( env, EvalIO cmd (cont >> gcPass) ) - - -catchError : (MalExpr -> Eval a) -> Eval a -> Eval a -catchError f e env = - case apply e env of - ( env, EvalOk res ) -> - ( env, EvalOk res ) - - ( env, EvalErr msg ) -> - apply (f msg) env - - ( env, EvalIO cmd cont ) -> - ( env, EvalIO cmd (cont >> catchError f) ) - - -fail : String -> Eval a -fail msg env = - ( env, EvalErr <| MalString msg ) - - -throw : MalExpr -> Eval a -throw ex env = - ( env, EvalErr ex ) - - -{-| Apply f to expr repeatedly. -Continues iterating if f returns (Left eval). -Stops if f returns (Right expr). - -Tail call optimized. - --} -runLoop : (MalExpr -> Env -> Either (Eval MalExpr) MalExpr) -> MalExpr -> Eval MalExpr -runLoop f expr env = - case f expr env of - Left e -> - case apply e env of - ( env, EvalOk expr ) -> - runLoop f expr env - - ( env, EvalErr msg ) -> - ( env, EvalErr msg ) - - ( env, EvalIO cmd cont ) -> - ( env, EvalIO cmd (cont >> andThen (runLoop f)) ) - - Right expr -> - ( env, EvalOk expr ) - - -fromResult : Result String a -> Eval a -fromResult res = - case res of - Ok val -> - succeed val - - Err msg -> - fail msg - - -{-| Chain the left and right Eval but ignore the right's result. --} -ignore : Eval b -> Eval a -> Eval a -ignore right left = - left - |> andThen - (\res -> - right - |> andThen (\_ -> succeed res) - ) - - -withStack : Eval a -> Eval a -withStack e = - withEnv - (\env -> - e - |> ignore - (modifyEnv - (Env.restoreRefs env.stack) - ) - ) - - -pushRef : MalExpr -> Eval a -> Eval a -pushRef ref e = - modifyEnv (Env.pushRef ref) - |> andThen (always e) - - -inGlobal : Eval a -> Eval a -inGlobal body = - let - enter env = - setEnv - { env - | keepFrames = env.currentFrameId :: env.keepFrames - , currentFrameId = Env.globalFrameId - } - - leave oldEnv newEnv = - { newEnv - | keepFrames = oldEnv.keepFrames - , currentFrameId = oldEnv.currentFrameId - } - in - withEnv - (\env -> - if env.currentFrameId /= Env.globalFrameId then - enter env - |> andThen (always body) - |> finally (leave env) - else - body - ) - - -runSimple : Eval a -> Result MalExpr a -runSimple e = - case run Env.global e of - ( _, EvalOk res ) -> - Ok res - - ( _, EvalErr msg ) -> - Err msg - - _ -> - Debug.crash "can't happen" +module Eval exposing (..) + +import Types exposing (..) +import IO exposing (IO) +import Env + + +apply : Eval a -> Env -> EvalContext a +apply f env = + f env + + +run : Env -> Eval a -> EvalContext a +run env e = + apply e env + + +withEnv : (Env -> Eval a) -> Eval a +withEnv f env = + apply (f env) env + + +setEnv : Env -> Eval () +setEnv env _ = + apply (succeed ()) env + + +modifyEnv : (Env -> Env) -> Eval () +modifyEnv f env = + apply (succeed ()) (f env) + + +succeed : a -> Eval a +succeed res env = + ( env, EvalOk res ) + + +io : Cmd Msg -> (IO -> Eval a) -> Eval a +io cmd cont env = + ( env, EvalIO cmd cont ) + + +map : (a -> b) -> Eval a -> Eval b +map f e env = + case apply e env of + ( env, EvalOk res ) -> + ( env, EvalOk (f res) ) + + ( env, EvalErr msg ) -> + ( env, EvalErr msg ) + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> map f) ) + + +{-| Chain two Eval's together. The function f takes the result from +the left eval and generates a new Eval. +-} +andThen : (a -> Eval b) -> Eval a -> Eval b +andThen f e env = + case apply e env of + ( env, EvalOk res ) -> + apply (f res) env + + ( env, EvalErr msg ) -> + ( env, EvalErr msg ) + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> andThen f) ) + + +{-| Apply a transformation to the Env, for a Ok and a Err. +-} +finally : (Env -> Env) -> Eval a -> Eval a +finally f e env = + case apply e env of + ( env, EvalOk res ) -> + ( f env, EvalOk res ) + + ( env, EvalErr msg ) -> + ( f env, EvalErr msg ) + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> finally f) ) + + +gcPass : Eval MalExpr -> Eval MalExpr +gcPass e env = + let + go env t expr = + if env.gcCounter >= env.gcInterval then + --Debug.log + -- ("before GC: " + -- ++ (printEnv env) + -- ) + -- "" + -- |> always ( Env.gc env, t expr ) + ( Env.gc expr env, t expr ) + else + ( env, t expr ) + in + case apply e env of + ( env, EvalOk res ) -> + go env EvalOk res + + ( env, EvalErr msg ) -> + go env EvalErr msg + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> gcPass) ) + + +catchError : (MalExpr -> Eval a) -> Eval a -> Eval a +catchError f e env = + case apply e env of + ( env, EvalOk res ) -> + ( env, EvalOk res ) + + ( env, EvalErr msg ) -> + apply (f msg) env + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> catchError f) ) + + +fail : String -> Eval a +fail msg env = + ( env, EvalErr <| MalString msg ) + + +throw : MalExpr -> Eval a +throw ex env = + ( env, EvalErr ex ) + + +{-| Apply f to expr repeatedly. +Continues iterating if f returns (Left eval). +Stops if f returns (Right expr). + +Tail call optimized. + +-} +runLoop : (MalExpr -> Env -> Either (Eval MalExpr) MalExpr) -> MalExpr -> Eval MalExpr +runLoop f expr env = + case f expr env of + Left e -> + case apply e env of + ( env, EvalOk expr ) -> + runLoop f expr env + + ( env, EvalErr msg ) -> + ( env, EvalErr msg ) + + ( env, EvalIO cmd cont ) -> + ( env, EvalIO cmd (cont >> andThen (runLoop f)) ) + + Right expr -> + ( env, EvalOk expr ) + + +fromResult : Result String a -> Eval a +fromResult res = + case res of + Ok val -> + succeed val + + Err msg -> + fail msg + + +{-| Chain the left and right Eval but ignore the right's result. +-} +ignore : Eval b -> Eval a -> Eval a +ignore right left = + left + |> andThen + (\res -> + right + |> andThen (\_ -> succeed res) + ) + + +withStack : Eval a -> Eval a +withStack e = + withEnv + (\env -> + e + |> ignore + (modifyEnv + (Env.restoreRefs env.stack) + ) + ) + + +pushRef : MalExpr -> Eval a -> Eval a +pushRef ref e = + modifyEnv (Env.pushRef ref) + |> andThen (always e) + + +inGlobal : Eval a -> Eval a +inGlobal body = + let + enter env = + setEnv + { env + | keepFrames = env.currentFrameId :: env.keepFrames + , currentFrameId = Env.globalFrameId + } + + leave oldEnv newEnv = + { newEnv + | keepFrames = oldEnv.keepFrames + , currentFrameId = oldEnv.currentFrameId + } + in + withEnv + (\env -> + if env.currentFrameId /= Env.globalFrameId then + enter env + |> andThen (always body) + |> finally (leave env) + else + body + ) + + +runSimple : Eval a -> Result MalExpr a +runSimple e = + case run Env.global e of + ( _, EvalOk res ) -> + Ok res + + ( _, EvalErr msg ) -> + Err msg + + _ -> + Debug.crash "can't happen" diff --git a/impls/elm/IO.elm b/impls/elm/IO.elm index a67f151984..534a369498 100644 --- a/impls/elm/IO.elm +++ b/impls/elm/IO.elm @@ -1,71 +1,71 @@ -port module IO - exposing - ( IO(..) - , writeLine - , readLine - , readFile - , input - , decodeIO - ) - -import Json.Decode exposing (..) -import Time exposing (Time) - - -{-| Output a string to stdout --} -port writeLine : String -> Cmd msg - - -{-| Read a line from the stdin --} -port readLine : String -> Cmd msg - - -{-| Read the contents of a file --} -port readFile : String -> Cmd msg - - -{-| Received a response for a command. --} -port input : (Value -> msg) -> Sub msg - - -type IO - = LineRead (Maybe String) - | LineWritten - | FileRead String - | Exception String - | GotTime Time - - -decodeIO : Decoder IO -decodeIO = - field "tag" string - |> andThen decodeTag - - -decodeTag : String -> Decoder IO -decodeTag tag = - case tag of - "lineRead" -> - field "line" (nullable string) - |> map LineRead - - "lineWritten" -> - succeed LineWritten - - "fileRead" -> - field "contents" string - |> map FileRead - - "exception" -> - field "message" string - |> map Exception - - _ -> - fail <| - "Trying to decode IO, but tag " - ++ tag - ++ " is not supported." +port module IO + exposing + ( IO(..) + , writeLine + , readLine + , readFile + , input + , decodeIO + ) + +import Json.Decode exposing (..) +import Time exposing (Time) + + +{-| Output a string to stdout +-} +port writeLine : String -> Cmd msg + + +{-| Read a line from the stdin +-} +port readLine : String -> Cmd msg + + +{-| Read the contents of a file +-} +port readFile : String -> Cmd msg + + +{-| Received a response for a command. +-} +port input : (Value -> msg) -> Sub msg + + +type IO + = LineRead (Maybe String) + | LineWritten + | FileRead String + | Exception String + | GotTime Time + + +decodeIO : Decoder IO +decodeIO = + field "tag" string + |> andThen decodeTag + + +decodeTag : String -> Decoder IO +decodeTag tag = + case tag of + "lineRead" -> + field "line" (nullable string) + |> map LineRead + + "lineWritten" -> + succeed LineWritten + + "fileRead" -> + field "contents" string + |> map FileRead + + "exception" -> + field "message" string + |> map Exception + + _ -> + fail <| + "Trying to decode IO, but tag " + ++ tag + ++ " is not supported." diff --git a/impls/elm/Makefile b/impls/elm/Makefile index 0850dce973..4c08b5d0cf 100644 --- a/impls/elm/Makefile +++ b/impls/elm/Makefile @@ -1,40 +1,40 @@ -SOURCES = step0_repl.elm step1_read_print.elm step2_eval.elm \ - step3_env.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm \ - step7_quote.elm step8_macros.elm step9_try.elm stepA_mal.elm - -BINS = $(SOURCES:%.elm=%.js) - -ELM_MAKE = node_modules/.bin/elm-make -ELM_PACKAGE = node_modules/.bin/elm-package - -all: node_modules elm_packages $(BINS) - -node_modules: - npm install - -elm_packages: - $(ELM_PACKAGE) install -y - -%.js: %.elm node_modules elm_packages - $(ELM_MAKE) $(@:%.js=%.elm) --output $@ - -STEP0_SOURCES = IO.elm -STEP1_SOURCES = $(STEP0_SOURCES) Reader.elm Printer.elm Utils.elm Types.elm Env.elm -STEP2_SOURCES = $(STEP1_SOURCES) -STEP3_SOURCES = $(STEP2_SOURCES) -STEP4_SOURCES = $(STEP3_SOURCES) Core.elm Eval.elm - -step0_repl.js: $(STEP0_SOURCES) -step1_read_print.js: $(STEP1_SOURCES) -step2_eval.js: $(STEP2_SOURCES) -step3_env.js: $(STEP3_SOURCES) -step4_if_fn_do.js: $(STEP4_SOURCES) -step5_tco.js: $(STEP4_SOURCES) -step6_file.js: $(STEP4_SOURCES) -step7_quote.js: $(STEP4_SOURCES) -step8_macros.js: $(STEP4_SOURCES) -step9_try.js: $(STEP4_SOURCES) -stepA_mal.js: $(STEP4_SOURCES) - -clean: - rm -f $(BINS) +SOURCES = step0_repl.elm step1_read_print.elm step2_eval.elm \ + step3_env.elm step4_if_fn_do.elm step5_tco.elm step6_file.elm \ + step7_quote.elm step8_macros.elm step9_try.elm stepA_mal.elm + +BINS = $(SOURCES:%.elm=%.js) + +ELM_MAKE = node_modules/.bin/elm-make +ELM_PACKAGE = node_modules/.bin/elm-package + +all: node_modules elm_packages $(BINS) + +node_modules: + npm install + +elm_packages: + $(ELM_PACKAGE) install -y + +%.js: %.elm node_modules elm_packages + $(ELM_MAKE) $(@:%.js=%.elm) --output $@ + +STEP0_SOURCES = IO.elm +STEP1_SOURCES = $(STEP0_SOURCES) Reader.elm Printer.elm Utils.elm Types.elm Env.elm +STEP2_SOURCES = $(STEP1_SOURCES) +STEP3_SOURCES = $(STEP2_SOURCES) +STEP4_SOURCES = $(STEP3_SOURCES) Core.elm Eval.elm + +step0_repl.js: $(STEP0_SOURCES) +step1_read_print.js: $(STEP1_SOURCES) +step2_eval.js: $(STEP2_SOURCES) +step3_env.js: $(STEP3_SOURCES) +step4_if_fn_do.js: $(STEP4_SOURCES) +step5_tco.js: $(STEP4_SOURCES) +step6_file.js: $(STEP4_SOURCES) +step7_quote.js: $(STEP4_SOURCES) +step8_macros.js: $(STEP4_SOURCES) +step9_try.js: $(STEP4_SOURCES) +stepA_mal.js: $(STEP4_SOURCES) + +clean: + rm -f $(BINS) diff --git a/impls/elm/Printer.elm b/impls/elm/Printer.elm index 2c4402a027..fef4f72714 100644 --- a/impls/elm/Printer.elm +++ b/impls/elm/Printer.elm @@ -1,152 +1,152 @@ -module Printer exposing (..) - -import Array exposing (Array) -import Dict exposing (Dict) -import Types exposing (Env, MalExpr(..), keywordPrefix, MalFunction(..)) -import Utils exposing (encodeString, wrap) -import Env - - -printStr : Bool -> MalExpr -> String -printStr = - printString Env.global - - -printString : Env -> Bool -> MalExpr -> String -printString env readably ast = - case ast of - MalNil -> - "nil" - - MalBool True -> - "true" - - MalBool False -> - "false" - - MalInt int -> - toString int - - MalString str -> - printRawString env readably str - - MalSymbol sym -> - sym - - MalKeyword kw -> - kw - - MalList list -> - printList env readably list - - MalVector vec -> - printVector env readably vec - - MalMap map -> - printMap env readably map - - MalFunction _ -> - "#" - - MalAtom atomId -> - let - value = - Env.getAtom atomId env - in - "(atom " ++ (printString env True value) ++ ")" - - MalApply _ -> - "#" - - -printBound : Env -> Bool -> List ( String, MalExpr ) -> String -printBound env readably = - let - printEntry name value = - name ++ "=" ++ (printString env readably value) - in - List.map (uncurry printEntry) - >> String.join " " - >> wrap "(" ")" - - -printRawString : Env -> Bool -> String -> String -printRawString env readably str = - if readably then - encodeString str - else - str - - -printList : Env -> Bool -> List MalExpr -> String -printList env readably = - List.map (printString env readably) - >> String.join " " - >> wrap "(" ")" - - -printVector : Env -> Bool -> Array MalExpr -> String -printVector env readably = - Array.map (printString env readably) - >> Array.toList - >> String.join " " - >> wrap "[" "]" - - -printMap : Env -> Bool -> Dict String MalExpr -> String -printMap env readably = - let - -- Strip off the keyword prefix if it is there. - printKey k = - case String.uncons k of - Just ( prefix, rest ) -> - if prefix == keywordPrefix then - rest - else - printRawString env readably k - - _ -> - printRawString env readably k - - printEntry ( k, v ) = - (printKey k) ++ " " ++ (printString env readably v) - in - Dict.toList - >> List.map printEntry - >> String.join " " - >> wrap "{" "}" - - -printEnv : Env -> String -printEnv env = - let - printOuterId = - Maybe.map toString >> Maybe.withDefault "nil" - - printHeader frameId { outerId, exitId, refCnt } = - "#" - ++ (toString frameId) - ++ " outer=" - ++ printOuterId outerId - ++ " exit=" - ++ printOuterId exitId - ++ " refCnt=" - ++ (toString refCnt) - - printFrame frameId frame = - String.join "\n" - ((printHeader frameId frame) - :: (Dict.foldr printDatum [] frame.data) - ) - - printFrameAcc k v acc = - printFrame k v :: acc - - printDatum k v acc = - (k ++ " = " ++ (printString env False v)) :: acc - in - "--- Environment ---\n" - ++ "Current frame: #" - ++ (toString env.currentFrameId) - ++ "\n\n" - ++ String.join "\n\n" (Dict.foldr printFrameAcc [] env.frames) +module Printer exposing (..) + +import Array exposing (Array) +import Dict exposing (Dict) +import Types exposing (Env, MalExpr(..), keywordPrefix, MalFunction(..)) +import Utils exposing (encodeString, wrap) +import Env + + +printStr : Bool -> MalExpr -> String +printStr = + printString Env.global + + +printString : Env -> Bool -> MalExpr -> String +printString env readably ast = + case ast of + MalNil -> + "nil" + + MalBool True -> + "true" + + MalBool False -> + "false" + + MalInt int -> + toString int + + MalString str -> + printRawString env readably str + + MalSymbol sym -> + sym + + MalKeyword kw -> + kw + + MalList list -> + printList env readably list + + MalVector vec -> + printVector env readably vec + + MalMap map -> + printMap env readably map + + MalFunction _ -> + "#" + + MalAtom atomId -> + let + value = + Env.getAtom atomId env + in + "(atom " ++ (printString env True value) ++ ")" + + MalApply _ -> + "#" + + +printBound : Env -> Bool -> List ( String, MalExpr ) -> String +printBound env readably = + let + printEntry name value = + name ++ "=" ++ (printString env readably value) + in + List.map (uncurry printEntry) + >> String.join " " + >> wrap "(" ")" + + +printRawString : Env -> Bool -> String -> String +printRawString env readably str = + if readably then + encodeString str + else + str + + +printList : Env -> Bool -> List MalExpr -> String +printList env readably = + List.map (printString env readably) + >> String.join " " + >> wrap "(" ")" + + +printVector : Env -> Bool -> Array MalExpr -> String +printVector env readably = + Array.map (printString env readably) + >> Array.toList + >> String.join " " + >> wrap "[" "]" + + +printMap : Env -> Bool -> Dict String MalExpr -> String +printMap env readably = + let + -- Strip off the keyword prefix if it is there. + printKey k = + case String.uncons k of + Just ( prefix, rest ) -> + if prefix == keywordPrefix then + rest + else + printRawString env readably k + + _ -> + printRawString env readably k + + printEntry ( k, v ) = + (printKey k) ++ " " ++ (printString env readably v) + in + Dict.toList + >> List.map printEntry + >> String.join " " + >> wrap "{" "}" + + +printEnv : Env -> String +printEnv env = + let + printOuterId = + Maybe.map toString >> Maybe.withDefault "nil" + + printHeader frameId { outerId, exitId, refCnt } = + "#" + ++ (toString frameId) + ++ " outer=" + ++ printOuterId outerId + ++ " exit=" + ++ printOuterId exitId + ++ " refCnt=" + ++ (toString refCnt) + + printFrame frameId frame = + String.join "\n" + ((printHeader frameId frame) + :: (Dict.foldr printDatum [] frame.data) + ) + + printFrameAcc k v acc = + printFrame k v :: acc + + printDatum k v acc = + (k ++ " = " ++ (printString env False v)) :: acc + in + "--- Environment ---\n" + ++ "Current frame: #" + ++ (toString env.currentFrameId) + ++ "\n\n" + ++ String.join "\n\n" (Dict.foldr printFrameAcc [] env.frames) diff --git a/impls/elm/Reader.elm b/impls/elm/Reader.elm index 2016e8ab9c..4fbda344cd 100644 --- a/impls/elm/Reader.elm +++ b/impls/elm/Reader.elm @@ -1,201 +1,201 @@ -module Reader exposing (..) - -import Array -import Dict -import Combine exposing (..) -import Combine.Num -import Types exposing (MalExpr(..), keywordPrefix) -import Utils exposing (decodeString, makeCall) - - -comment : Parser s String -comment = - regex ";.*" - - -ws : Parser s (List String) -ws = - many (comment <|> string "," <|> whitespace) - - -int : Parser s MalExpr -int = - MalInt <$> Combine.Num.int "int" - - -symbolString : Parser s String -symbolString = - regex "[^\\s\\[\\]{}('\"`,;)]+" - - -symbolOrConst : Parser s MalExpr -symbolOrConst = - let - make sym = - case sym of - "nil" -> - MalNil - - "true" -> - MalBool True - - "false" -> - MalBool False - - _ -> - MalSymbol sym - in - make - <$> symbolString - "symbol" - - -keywordString : Parser s String -keywordString = - (++) - <$> string ":" - <*> symbolString - - -keyword : Parser s MalExpr -keyword = - MalKeyword <$> keywordString - - -list : Parser s MalExpr -list = - MalList - <$> parens (many form <* ws) - "list" - - -vector : Parser s MalExpr -vector = - MalVector - << Array.fromList - <$> (string "[" - *> many form - <* ws - <* string "]" - ) - "vector" - - -mapKey : Parser s String -mapKey = - choice - [ String.cons keywordPrefix <$> keywordString - , decodeString <$> strString - ] - - -mapEntry : Parser s ( String, MalExpr ) -mapEntry = - (,) <$> mapKey <*> form "map entry" - - -map : Parser s MalExpr -map = - lazy <| - \() -> - MalMap - << Dict.fromList - <$> (string "{" - *> many (ws *> mapEntry) - <* ws - <* string "}" - ) - "map" - - -atom : Parser s MalExpr -atom = - choice - [ int - , keyword - , symbolOrConst - , str - ] - "atom" - - -form : Parser s MalExpr -form = - lazy <| - \() -> - let - parsers = - [ list - , vector - , map - , simpleMacro "'" "quote" - , simpleMacro "`" "quasiquote" - , simpleMacro "~@" "splice-unquote" - , simpleMacro "~" "unquote" - , simpleMacro "@" "deref" - , withMeta - , atom - ] - in - ws *> choice parsers "form" - - -simpleMacro : String -> String -> Parser s MalExpr -simpleMacro token symbol = - makeCall symbol - << List.singleton - <$> (string token *> form) - symbol - - -withMeta : Parser s MalExpr -withMeta = - lazy <| - \() -> - let - make meta expr = - makeCall "with-meta" [ expr, meta ] - in - make - <$> (string "^" *> form) - <*> form - "with-meta" - - -readString : String -> Result String (Maybe MalExpr) -readString str = - case parse ((maybe form) <* ws <* end) str of - Ok ( _, _, ast ) -> - Ok ast - - Err ( _, stream, ms ) -> - Err <| formatError ms stream - - -formatError : List String -> InputStream -> String -formatError ms stream = - let - location = - currentLocation stream - in - "Parse error: " - ++ String.join ", " ms - ++ " " - ++ "(at " - ++ toString location.line - ++ ":" - ++ toString location.column - ++ ")" - - -str : Parser s MalExpr -str = - MalString << decodeString <$> strString - - -{-| Syntax highlighter in VS code is messed up by this regex, -that's why it's down below. :) --} -strString : Parser s String -strString = - regex "\"(\\\\.|[^\\\\\"])*\"" "string" +module Reader exposing (..) + +import Array +import Dict +import Combine exposing (..) +import Combine.Num +import Types exposing (MalExpr(..), keywordPrefix) +import Utils exposing (decodeString, makeCall) + + +comment : Parser s String +comment = + regex ";.*" + + +ws : Parser s (List String) +ws = + many (comment <|> string "," <|> whitespace) + + +int : Parser s MalExpr +int = + MalInt <$> Combine.Num.int "int" + + +symbolString : Parser s String +symbolString = + regex "[^\\s\\[\\]{}('\"`,;)]+" + + +symbolOrConst : Parser s MalExpr +symbolOrConst = + let + make sym = + case sym of + "nil" -> + MalNil + + "true" -> + MalBool True + + "false" -> + MalBool False + + _ -> + MalSymbol sym + in + make + <$> symbolString + "symbol" + + +keywordString : Parser s String +keywordString = + (++) + <$> string ":" + <*> symbolString + + +keyword : Parser s MalExpr +keyword = + MalKeyword <$> keywordString + + +list : Parser s MalExpr +list = + MalList + <$> parens (many form <* ws) + "list" + + +vector : Parser s MalExpr +vector = + MalVector + << Array.fromList + <$> (string "[" + *> many form + <* ws + <* string "]" + ) + "vector" + + +mapKey : Parser s String +mapKey = + choice + [ String.cons keywordPrefix <$> keywordString + , decodeString <$> strString + ] + + +mapEntry : Parser s ( String, MalExpr ) +mapEntry = + (,) <$> mapKey <*> form "map entry" + + +map : Parser s MalExpr +map = + lazy <| + \() -> + MalMap + << Dict.fromList + <$> (string "{" + *> many (ws *> mapEntry) + <* ws + <* string "}" + ) + "map" + + +atom : Parser s MalExpr +atom = + choice + [ int + , keyword + , symbolOrConst + , str + ] + "atom" + + +form : Parser s MalExpr +form = + lazy <| + \() -> + let + parsers = + [ list + , vector + , map + , simpleMacro "'" "quote" + , simpleMacro "`" "quasiquote" + , simpleMacro "~@" "splice-unquote" + , simpleMacro "~" "unquote" + , simpleMacro "@" "deref" + , withMeta + , atom + ] + in + ws *> choice parsers "form" + + +simpleMacro : String -> String -> Parser s MalExpr +simpleMacro token symbol = + makeCall symbol + << List.singleton + <$> (string token *> form) + symbol + + +withMeta : Parser s MalExpr +withMeta = + lazy <| + \() -> + let + make meta expr = + makeCall "with-meta" [ expr, meta ] + in + make + <$> (string "^" *> form) + <*> form + "with-meta" + + +readString : String -> Result String (Maybe MalExpr) +readString str = + case parse ((maybe form) <* ws <* end) str of + Ok ( _, _, ast ) -> + Ok ast + + Err ( _, stream, ms ) -> + Err <| formatError ms stream + + +formatError : List String -> InputStream -> String +formatError ms stream = + let + location = + currentLocation stream + in + "Parse error: " + ++ String.join ", " ms + ++ " " + ++ "(at " + ++ toString location.line + ++ ":" + ++ toString location.column + ++ ")" + + +str : Parser s MalExpr +str = + MalString << decodeString <$> strString + + +{-| Syntax highlighter in VS code is messed up by this regex, +that's why it's down below. :) +-} +strString : Parser s String +strString = + regex "\"(\\\\.|[^\\\\\"])*\"" "string" diff --git a/impls/elm/Types.elm b/impls/elm/Types.elm index 9960c55362..6f5e89ff98 100644 --- a/impls/elm/Types.elm +++ b/impls/elm/Types.elm @@ -1,107 +1,107 @@ -module Types exposing (..) - -import Array exposing (Array) -import Dict exposing (Dict) -import IO exposing (IO) - - -type Either a b - = Left a - | Right b - - -type Msg - = Input (Result String IO) - - -type alias Frame = - { outerId : Maybe Int - , exitId : Maybe Int - , data : Dict String MalExpr - , refCnt : Int - } - - -type alias Env = - { frames : Dict Int Frame - , nextFrameId : Int - , currentFrameId : Int - , atoms : Dict Int MalExpr - , nextAtomId : Int - , debug : Bool - , gcInterval : Int - , gcCounter : Int - , stack : List MalExpr - , keepFrames : List Int - } - - -type alias EvalCont a = - IO -> Eval a - - -type EvalResult res - = EvalErr MalExpr - | EvalOk res - | EvalIO (Cmd Msg) (EvalCont res) - - -type alias EvalContext res = - ( Env, EvalResult res ) - - -type alias Eval res = - Env -> EvalContext res - - -type alias MalFn = - List MalExpr -> Eval MalExpr - - -type MalFunction - = CoreFunc MalFn - | UserFunc - { frameId : Int - , lazyFn : MalFn - , eagerFn : MalFn - , isMacro : Bool - , meta : Maybe MalExpr - } - - -type alias ApplyRec = - { frameId : Int, bound : Bound, body : MalExpr } - - -type alias TcoFn = - () -> Eval MalExpr - - -type alias Bound = - List ( String, MalExpr ) - - -type MalExpr - = MalNil - | MalBool Bool - | MalInt Int - | MalString String - | MalKeyword String - | MalSymbol String - | MalList (List MalExpr) - | MalVector (Array MalExpr) - | MalMap (Dict String MalExpr) - | MalFunction MalFunction - | MalApply ApplyRec - | MalAtom Int - - -{-| Keywords are prefixed by this char for usage in a MalMap. -Elm doesn't support user defined types as keys in a Dict. - -The unicode char is: '\x029e' - --} -keywordPrefix : Char -keywordPrefix = - 'ʞ' +module Types exposing (..) + +import Array exposing (Array) +import Dict exposing (Dict) +import IO exposing (IO) + + +type Either a b + = Left a + | Right b + + +type Msg + = Input (Result String IO) + + +type alias Frame = + { outerId : Maybe Int + , exitId : Maybe Int + , data : Dict String MalExpr + , refCnt : Int + } + + +type alias Env = + { frames : Dict Int Frame + , nextFrameId : Int + , currentFrameId : Int + , atoms : Dict Int MalExpr + , nextAtomId : Int + , debug : Bool + , gcInterval : Int + , gcCounter : Int + , stack : List MalExpr + , keepFrames : List Int + } + + +type alias EvalCont a = + IO -> Eval a + + +type EvalResult res + = EvalErr MalExpr + | EvalOk res + | EvalIO (Cmd Msg) (EvalCont res) + + +type alias EvalContext res = + ( Env, EvalResult res ) + + +type alias Eval res = + Env -> EvalContext res + + +type alias MalFn = + List MalExpr -> Eval MalExpr + + +type MalFunction + = CoreFunc MalFn + | UserFunc + { frameId : Int + , lazyFn : MalFn + , eagerFn : MalFn + , isMacro : Bool + , meta : Maybe MalExpr + } + + +type alias ApplyRec = + { frameId : Int, bound : Bound, body : MalExpr } + + +type alias TcoFn = + () -> Eval MalExpr + + +type alias Bound = + List ( String, MalExpr ) + + +type MalExpr + = MalNil + | MalBool Bool + | MalInt Int + | MalString String + | MalKeyword String + | MalSymbol String + | MalList (List MalExpr) + | MalVector (Array MalExpr) + | MalMap (Dict String MalExpr) + | MalFunction MalFunction + | MalApply ApplyRec + | MalAtom Int + + +{-| Keywords are prefixed by this char for usage in a MalMap. +Elm doesn't support user defined types as keys in a Dict. + +The unicode char is: '\x029e' + +-} +keywordPrefix : Char +keywordPrefix = + 'ʞ' diff --git a/impls/elm/Utils.elm b/impls/elm/Utils.elm index bd226d4dc6..1cd4f5e7c1 100644 --- a/impls/elm/Utils.elm +++ b/impls/elm/Utils.elm @@ -1,115 +1,115 @@ -module Utils - exposing - ( decodeString - , encodeString - , makeCall - , wrap - , maybeToList - , zip - , last - , justValues - ) - -import Regex exposing (replace, regex, HowMany(All)) -import Types exposing (MalExpr(..)) - - -decodeString : String -> String -decodeString = - let - unescape { match } = - case match of - "\\n" -> - "\n" - - "\\\"" -> - "\"" - - "\\\\" -> - "\\" - - other -> - other - in - String.slice 1 -1 - >> replace All (regex "\\\\[\\\"\\\\n]") unescape - - -encodeString : String -> String -encodeString = - let - escape { match } = - case match of - "\n" -> - "\\n" - - "\"" -> - "\\\"" - - "\\" -> - "\\\\" - - other -> - other - in - wrap "\"" "\"" - << replace All (regex "[\\n\\\"\\\\]") escape - - -makeCall : String -> List MalExpr -> MalExpr -makeCall symbol args = - MalList <| (MalSymbol symbol) :: args - - -wrap : String -> String -> String -> String -wrap prefix suffix str = - prefix ++ str ++ suffix - - -maybeToList : Maybe a -> List a -maybeToList m = - case m of - Just x -> - [ x ] - - Nothing -> - [] - - -zip : List a -> List b -> List ( a, b ) -zip a b = - case ( a, b ) of - ( [], _ ) -> - [] - - ( _, [] ) -> - [] - - ( x :: xs, y :: ys ) -> - ( x, y ) :: zip xs ys - - -last : List a -> Maybe a -last list = - case list of - [] -> - Nothing - - [ x ] -> - Just x - - x :: xs -> - last xs - - -justValues : List (Maybe a) -> List a -justValues list = - case list of - [] -> - [] - - (Just x) :: rest -> - x :: (justValues rest) - - Nothing :: rest -> - justValues rest +module Utils + exposing + ( decodeString + , encodeString + , makeCall + , wrap + , maybeToList + , zip + , last + , justValues + ) + +import Regex exposing (replace, regex, HowMany(All)) +import Types exposing (MalExpr(..)) + + +decodeString : String -> String +decodeString = + let + unescape { match } = + case match of + "\\n" -> + "\n" + + "\\\"" -> + "\"" + + "\\\\" -> + "\\" + + other -> + other + in + String.slice 1 -1 + >> replace All (regex "\\\\[\\\"\\\\n]") unescape + + +encodeString : String -> String +encodeString = + let + escape { match } = + case match of + "\n" -> + "\\n" + + "\"" -> + "\\\"" + + "\\" -> + "\\\\" + + other -> + other + in + wrap "\"" "\"" + << replace All (regex "[\\n\\\"\\\\]") escape + + +makeCall : String -> List MalExpr -> MalExpr +makeCall symbol args = + MalList <| (MalSymbol symbol) :: args + + +wrap : String -> String -> String -> String +wrap prefix suffix str = + prefix ++ str ++ suffix + + +maybeToList : Maybe a -> List a +maybeToList m = + case m of + Just x -> + [ x ] + + Nothing -> + [] + + +zip : List a -> List b -> List ( a, b ) +zip a b = + case ( a, b ) of + ( [], _ ) -> + [] + + ( _, [] ) -> + [] + + ( x :: xs, y :: ys ) -> + ( x, y ) :: zip xs ys + + +last : List a -> Maybe a +last list = + case list of + [] -> + Nothing + + [ x ] -> + Just x + + x :: xs -> + last xs + + +justValues : List (Maybe a) -> List a +justValues list = + case list of + [] -> + [] + + (Just x) :: rest -> + x :: (justValues rest) + + Nothing :: rest -> + justValues rest diff --git a/impls/elm/bootstrap.js b/impls/elm/bootstrap.js index 59d3230105..2fb302fce4 100644 --- a/impls/elm/bootstrap.js +++ b/impls/elm/bootstrap.js @@ -1,32 +1,32 @@ -var readline = require('./node_readline'); -var fs = require('fs'); - -// The first two arguments are: 'node' and 'bootstrap.js' -// The third argument is the name of the Elm module to load. -var args = process.argv.slice(2); -var mod = require('./' + args[0]); - -var app = mod.Main.worker({ - args: args.slice(1) -}); - -// Hook up the writeLine and readLine ports of the app. -app.ports.writeLine.subscribe(function(line) { - console.log(line); - app.ports.input.send({"tag": "lineWritten"}); -}); - -app.ports.readLine.subscribe(function(prompt) { - var line = readline.readline(prompt); - app.ports.input.send({"tag": "lineRead", "line": line}); -}); - -// Read the contents of a file. -app.ports.readFile.subscribe(function(filename) { - try { - var contents = fs.readFileSync(filename, 'utf8'); - app.ports.input.send({"tag": "fileRead", "contents": contents}); - } catch (e) { - app.ports.input.send({"tag": "exception", "message": e.message}); - } +var readline = require('./node_readline'); +var fs = require('fs'); + +// The first two arguments are: 'node' and 'bootstrap.js' +// The third argument is the name of the Elm module to load. +var args = process.argv.slice(2); +var mod = require('./' + args[0]); + +var app = mod.Main.worker({ + args: args.slice(1) +}); + +// Hook up the writeLine and readLine ports of the app. +app.ports.writeLine.subscribe(function(line) { + console.log(line); + app.ports.input.send({"tag": "lineWritten"}); +}); + +app.ports.readLine.subscribe(function(prompt) { + var line = readline.readline(prompt); + app.ports.input.send({"tag": "lineRead", "line": line}); +}); + +// Read the contents of a file. +app.ports.readFile.subscribe(function(filename) { + try { + var contents = fs.readFileSync(filename, 'utf8'); + app.ports.input.send({"tag": "fileRead", "contents": contents}); + } catch (e) { + app.ports.input.send({"tag": "exception", "message": e.message}); + } }); \ No newline at end of file diff --git a/impls/elm/elm-package.json b/impls/elm/elm-package.json index 5ba0b8cd82..f82c62939b 100644 --- a/impls/elm/elm-package.json +++ b/impls/elm/elm-package.json @@ -1,15 +1,15 @@ -{ - "version": "1.0.0", - "summary": "Make-A-Lisp implementation in Elm", - "repository": "https://github.com/kanaka/mal.git", - "license": "BSD3", - "source-directories": [ - "." - ], - "exposed-modules": [], - "dependencies": { - "Bogdanp/elm-combine": "3.1.1 <= v < 4.0.0", - "elm-lang/core": "5.1.1 <= v < 6.0.0" - }, - "elm-version": "0.18.0 <= v < 0.19.0" -} +{ + "version": "1.0.0", + "summary": "Make-A-Lisp implementation in Elm", + "repository": "https://github.com/kanaka/mal.git", + "license": "BSD3", + "source-directories": [ + "." + ], + "exposed-modules": [], + "dependencies": { + "Bogdanp/elm-combine": "3.1.1 <= v < 4.0.0", + "elm-lang/core": "5.1.1 <= v < 6.0.0" + }, + "elm-version": "0.18.0 <= v < 0.19.0" +} diff --git a/impls/elm/node_readline.js b/impls/elm/node_readline.js index 0a50f91f36..2e0de41a25 100644 --- a/impls/elm/node_readline.js +++ b/impls/elm/node_readline.js @@ -1,47 +1,47 @@ -// IMPORTANT: choose one -var RL_LIB = "libreadline"; // NOTE: libreadline is GPL -//var RL_LIB = "libedit"; - -var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); - -var rlwrap = {}; // namespace for this module in web context - -var ffi = require('ffi-napi'), - fs = require('fs'); - -var rllib = ffi.Library(RL_LIB, { - 'readline': [ 'string', [ 'string' ] ], - 'add_history': [ 'int', [ 'string' ] ]}); - -var rl_history_loaded = false; - -exports.readline = rlwrap.readline = function(prompt) { - prompt = typeof prompt !== 'undefined' ? prompt : "user> "; - - if (!rl_history_loaded) { - rl_history_loaded = true; - var lines = []; - if (fs.existsSync(HISTORY_FILE)) { - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - } - // Max of 2000 lines - lines = lines.slice(Math.max(lines.length - 2000, 0)); - for (var i=0; i "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i input (decodeValue decodeIO >> Input) - } - - -type alias Flags = - { args : List String - } - - -type alias Model = - { args : List String - } - - -type Msg - = Input (Result String IO) - - -init : Flags -> ( Model, Cmd Msg ) -init flags = - ( flags, readLine prompt ) - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case msg of - Input (Ok (LineRead (Just line))) -> - ( model, writeLine (rep line) ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - ( model, Cmd.none ) - - Input (Ok _) -> - ( model, Cmd.none ) - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -prompt : String -prompt = - "user> " - - -read : String -> String -read ast = - ast - - -eval : String -> String -eval ast = - ast - - -print : String -> String -print ast = - ast - - -rep : String -> String -rep = - read >> eval >> print +port module Main exposing (..) + +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Flags = + { args : List String + } + + +type alias Model = + { args : List String + } + + +type Msg + = Input (Result String IO) + + +init : Flags -> ( Model, Cmd Msg ) +init flags = + ( flags, readLine prompt ) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Input (Ok (LineRead (Just line))) -> + ( model, writeLine (rep line) ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + ( model, Cmd.none ) + + Input (Ok _) -> + ( model, Cmd.none ) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +prompt : String +prompt = + "user> " + + +read : String -> String +read ast = + ast + + +eval : String -> String +eval ast = + ast + + +print : String -> String +print ast = + ast + + +rep : String -> String +rep = + read >> eval >> print diff --git a/impls/elm/step1_read_print.elm b/impls/elm/step1_read_print.elm index 46476bf583..12e5b9099c 100644 --- a/impls/elm/step1_read_print.elm +++ b/impls/elm/step1_read_print.elm @@ -1,106 +1,106 @@ -port module Main exposing (..) - -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (MalExpr(..)) -import Reader exposing (readString) -import Printer exposing (printStr) - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = - \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Flags = - { args : List String - } - - -type alias Model = - { args : List String - } - - -type Msg - = Input (Result String IO) - - -init : Flags -> ( Model, Cmd Msg ) -init flags = - ( flags, readLine prompt ) - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case msg of - Input (Ok (LineRead (Just line))) -> - case rep line of - Just out -> - ( model, writeLine out ) - - Nothing -> - ( model, readLine prompt ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -eval : MalExpr -> MalExpr -eval ast = - ast - - -print : MalExpr -> String -print = - printStr True - - -{-| Read-Eval-Print --} -rep : String -> Maybe String -rep = - let - formatResult result = - case result of - Ok optStr -> - optStr - - Err msg -> - Just msg - in - readString - >> Result.map (Maybe.map (eval >> print)) - >> formatResult +port module Main exposing (..) + +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (MalExpr(..)) +import Reader exposing (readString) +import Printer exposing (printStr) + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Flags = + { args : List String + } + + +type alias Model = + { args : List String + } + + +type Msg + = Input (Result String IO) + + +init : Flags -> ( Model, Cmd Msg ) +init flags = + ( flags, readLine prompt ) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just out -> + ( model, writeLine out ) + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +eval : MalExpr -> MalExpr +eval ast = + ast + + +print : MalExpr -> String +print = + printStr True + + +{-| Read-Eval-Print +-} +rep : String -> Maybe String +rep = + let + formatResult result = + case result of + Ok optStr -> + optStr + + Err msg -> + Just msg + in + readString + >> Result.map (Maybe.map (eval >> print)) + >> formatResult diff --git a/impls/elm/step2_eval.elm b/impls/elm/step2_eval.elm index 25b6d43e83..a923e74c82 100644 --- a/impls/elm/step2_eval.elm +++ b/impls/elm/step2_eval.elm @@ -1,255 +1,255 @@ -port module Main exposing (..) - -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (..) -import Reader exposing (readString) -import Printer exposing (printStr) -import Utils exposing (maybeToList, zip) -import Dict exposing (Dict) -import Tuple exposing (mapFirst, second) -import Array -import Eval - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = - \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Flags = - { args : List String - } - - -type alias ReplEnv = - Dict String MalExpr - - -type alias Model = - { args : List String - , env : ReplEnv - } - - -type Msg - = Input (Result String IO) - - -init : Flags -> ( Model, Cmd Msg ) -init { args } = - ( { args = args, env = initReplEnv }, readLine prompt ) - - -initReplEnv : ReplEnv -initReplEnv = - let - makeFn = - CoreFunc >> MalFunction - - binaryOp fn args = - case args of - [ MalInt x, MalInt y ] -> - Eval.succeed <| MalInt (fn x y) - - _ -> - Eval.fail "unsupported arguments" - in - Dict.fromList - [ ( "+", makeFn <| binaryOp (+) ) - , ( "-", makeFn <| binaryOp (-) ) - , ( "*", makeFn <| binaryOp (*) ) - , ( "/", makeFn <| binaryOp (//) ) - ] - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case msg of - Input (Ok (LineRead (Just line))) -> - case rep model.env line of - Nothing -> - ( model, readLine prompt ) - - Just ( result, newEnv ) -> - ( { model | env = newEnv }, writeLine (makeOutput result) ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -makeOutput : Result String String -> String -makeOutput result = - case result of - Ok str -> - str - - Err msg -> - "Error: " ++ msg - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -eval : ReplEnv -> MalExpr -> ( Result String MalExpr, ReplEnv ) -eval env ast = - case ast of - MalList [] -> - ( Ok ast, env ) - - MalList list -> - case evalList env list [] of - ( Ok newList, newEnv ) -> - case newList of - [] -> - ( Err "can't happen", newEnv ) - - (MalFunction (CoreFunc fn)) :: args -> - case Eval.runSimple (fn args) of - Ok res -> - ( Ok res, newEnv ) - - Err msg -> - ( Err (print msg), newEnv ) - - fn :: _ -> - ( Err ((print fn) ++ " is not a function"), newEnv ) - - ( Err msg, newEnv ) -> - ( Err msg, newEnv ) - - _ -> - evalAst env ast - - -evalAst : ReplEnv -> MalExpr -> ( Result String MalExpr, ReplEnv ) -evalAst env ast = - case ast of - MalSymbol sym -> - -- Lookup symbol in env and return value or raise error if not found. - case Dict.get sym env of - Just val -> - ( Ok val, env ) - - Nothing -> - ( Err "symbol not found", env ) - - MalList list -> - -- Return new list that is result of calling eval on each element of list. - evalList env list [] - |> mapFirst (Result.map MalList) - - MalVector vec -> - evalList env (Array.toList vec) [] - |> mapFirst (Result.map (Array.fromList >> MalVector)) - - MalMap map -> - evalList env (Dict.values map) [] - |> mapFirst - (Result.map - (zip (Dict.keys map) - >> Dict.fromList - >> MalMap - ) - ) - - _ -> - ( Ok ast, env ) - - -evalList : ReplEnv -> List MalExpr -> List MalExpr -> ( Result String (List MalExpr), ReplEnv ) -evalList env list acc = - case list of - [] -> - ( Ok (List.reverse acc), env ) - - x :: rest -> - case eval env x of - ( Ok val, newEnv ) -> - evalList newEnv rest (val :: acc) - - ( Err msg, newEnv ) -> - ( Err msg, newEnv ) - - -{-| Try to map a list with a fn that can return a Err. - -Maps the list from left to right. As soon as a error -occurs it will not process any more elements and return -the error. - --} -tryMapList : (a -> Result e b) -> List a -> Result e (List b) -tryMapList fn list = - let - go x = - Result.andThen - (\acc -> - case fn x of - Ok val -> - Ok (val :: acc) - - Err msg -> - Err msg - ) - in - List.foldl go (Ok []) list - |> Result.map List.reverse - - -print : MalExpr -> String -print = - printStr True - - -{-| Read-Eval-Print. rep returns: - -Nothing -> if an empty string is read (ws/comments) -Just ((Ok out), newEnv) -> input has been evaluated. -Just ((Err msg), env) -> error parsing or evaluating. - --} -rep : ReplEnv -> String -> Maybe ( Result String String, ReplEnv ) -rep env input = - let - evalPrint = - eval env >> mapFirst (Result.map print) - in - case readString input of - Ok Nothing -> - Nothing - - Err msg -> - Just ( Err msg, env ) - - Ok (Just ast) -> - Just (evalPrint ast) +port module Main exposing (..) + +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printStr) +import Utils exposing (maybeToList, zip) +import Dict exposing (Dict) +import Tuple exposing (mapFirst, second) +import Array +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Flags = + { args : List String + } + + +type alias ReplEnv = + Dict String MalExpr + + +type alias Model = + { args : List String + , env : ReplEnv + } + + +type Msg + = Input (Result String IO) + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + ( { args = args, env = initReplEnv }, readLine prompt ) + + +initReplEnv : ReplEnv +initReplEnv = + let + makeFn = + CoreFunc >> MalFunction + + binaryOp fn args = + case args of + [ MalInt x, MalInt y ] -> + Eval.succeed <| MalInt (fn x y) + + _ -> + Eval.fail "unsupported arguments" + in + Dict.fromList + [ ( "+", makeFn <| binaryOp (+) ) + , ( "-", makeFn <| binaryOp (-) ) + , ( "*", makeFn <| binaryOp (*) ) + , ( "/", makeFn <| binaryOp (//) ) + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Input (Ok (LineRead (Just line))) -> + case rep model.env line of + Nothing -> + ( model, readLine prompt ) + + Just ( result, newEnv ) -> + ( { model | env = newEnv }, writeLine (makeOutput result) ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +makeOutput : Result String String -> String +makeOutput result = + case result of + Ok str -> + str + + Err msg -> + "Error: " ++ msg + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +eval : ReplEnv -> MalExpr -> ( Result String MalExpr, ReplEnv ) +eval env ast = + case ast of + MalList [] -> + ( Ok ast, env ) + + MalList list -> + case evalList env list [] of + ( Ok newList, newEnv ) -> + case newList of + [] -> + ( Err "can't happen", newEnv ) + + (MalFunction (CoreFunc fn)) :: args -> + case Eval.runSimple (fn args) of + Ok res -> + ( Ok res, newEnv ) + + Err msg -> + ( Err (print msg), newEnv ) + + fn :: _ -> + ( Err ((print fn) ++ " is not a function"), newEnv ) + + ( Err msg, newEnv ) -> + ( Err msg, newEnv ) + + _ -> + evalAst env ast + + +evalAst : ReplEnv -> MalExpr -> ( Result String MalExpr, ReplEnv ) +evalAst env ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + case Dict.get sym env of + Just val -> + ( Ok val, env ) + + Nothing -> + ( Err "symbol not found", env ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList env list [] + |> mapFirst (Result.map MalList) + + MalVector vec -> + evalList env (Array.toList vec) [] + |> mapFirst (Result.map (Array.fromList >> MalVector)) + + MalMap map -> + evalList env (Dict.values map) [] + |> mapFirst + (Result.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + ) + + _ -> + ( Ok ast, env ) + + +evalList : ReplEnv -> List MalExpr -> List MalExpr -> ( Result String (List MalExpr), ReplEnv ) +evalList env list acc = + case list of + [] -> + ( Ok (List.reverse acc), env ) + + x :: rest -> + case eval env x of + ( Ok val, newEnv ) -> + evalList newEnv rest (val :: acc) + + ( Err msg, newEnv ) -> + ( Err msg, newEnv ) + + +{-| Try to map a list with a fn that can return a Err. + +Maps the list from left to right. As soon as a error +occurs it will not process any more elements and return +the error. + +-} +tryMapList : (a -> Result e b) -> List a -> Result e (List b) +tryMapList fn list = + let + go x = + Result.andThen + (\acc -> + case fn x of + Ok val -> + Ok (val :: acc) + + Err msg -> + Err msg + ) + in + List.foldl go (Ok []) list + |> Result.map List.reverse + + +print : MalExpr -> String +print = + printStr True + + +{-| Read-Eval-Print. rep returns: + +Nothing -> if an empty string is read (ws/comments) +Just ((Ok out), newEnv) -> input has been evaluated. +Just ((Err msg), env) -> error parsing or evaluating. + +-} +rep : ReplEnv -> String -> Maybe ( Result String String, ReplEnv ) +rep env input = + let + evalPrint = + eval env >> mapFirst (Result.map print) + in + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just ( Err msg, env ) + + Ok (Just ast) -> + Just (evalPrint ast) diff --git a/impls/elm/step3_env.elm b/impls/elm/step3_env.elm index 40404ddbd0..cbac62611a 100644 --- a/impls/elm/step3_env.elm +++ b/impls/elm/step3_env.elm @@ -1,314 +1,314 @@ -port module Main exposing (..) - -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (..) -import Reader exposing (readString) -import Printer exposing (printString) -import Utils exposing (maybeToList, zip) -import Dict exposing (Dict) -import Tuple exposing (mapFirst, mapSecond, second) -import Array -import Env -import Eval - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Flags = - { args : List String - } - - -type alias Model = - { args : List String - , env : Env - } - - -type Msg - = Input (Result String IO) - - -init : Flags -> ( Model, Cmd Msg ) -init { args } = - ( { args = args, env = initReplEnv }, readLine prompt ) - - -initReplEnv : Env -initReplEnv = - let - makeFn = - CoreFunc >> MalFunction - - binaryOp fn args = - case args of - [ MalInt x, MalInt y ] -> - Eval.succeed <| MalInt (fn x y) - - _ -> - Eval.fail "unsupported arguments" - in - Env.global - |> Env.set "+" (makeFn <| binaryOp (+)) - |> Env.set "-" (makeFn <| binaryOp (-)) - |> Env.set "*" (makeFn <| binaryOp (*)) - |> Env.set "/" (makeFn <| binaryOp (//)) - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case msg of - Input (Ok (LineRead (Just line))) -> - case rep model.env line of - Nothing -> - ( model, readLine prompt ) - - Just ( result, newEnv ) -> - ( { model | env = newEnv }, writeLine (makeOutput result) ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -makeOutput : Result String String -> String -makeOutput result = - case result of - Ok str -> - str - - Err msg -> - "Error: " ++ msg - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -eval : Env -> MalExpr -> ( Result String MalExpr, Env ) -eval env ast = - case ast of - MalList [] -> - ( Ok ast, env ) - - MalList ((MalSymbol "def!") :: args) -> - evalDef env args - - MalList ((MalSymbol "let*") :: args) -> - evalLet env args - - MalList list -> - case evalList env list [] of - ( Ok newList, newEnv ) -> - case newList of - [] -> - ( Err "can't happen", newEnv ) - - (MalFunction (CoreFunc fn)) :: args -> - case Eval.runSimple (fn args) of - Ok res -> - ( Ok res, newEnv ) - - Err msg -> - ( Err (print msg), newEnv ) - - fn :: _ -> - ( Err ((print fn) ++ " is not a function"), newEnv ) - - ( Err msg, newEnv ) -> - ( Err msg, newEnv ) - - _ -> - evalAst env ast - - -evalAst : Env -> MalExpr -> ( Result String MalExpr, Env ) -evalAst env ast = - case ast of - MalSymbol sym -> - -- Lookup symbol in env and return value or raise error if not found. - case Env.get sym env of - Ok val -> - ( Ok val, env ) - - Err msg -> - ( Err msg, env ) - - MalList list -> - -- Return new list that is result of calling eval on each element of list. - evalList env list [] - |> mapFirst (Result.map MalList) - - MalVector vec -> - evalList env (Array.toList vec) [] - |> mapFirst (Result.map (Array.fromList >> MalVector)) - - MalMap map -> - evalList env (Dict.values map) [] - |> mapFirst - (Result.map - (zip (Dict.keys map) - >> Dict.fromList - >> MalMap - ) - ) - - _ -> - ( Ok ast, env ) - - -evalList : Env -> List MalExpr -> List MalExpr -> ( Result String (List MalExpr), Env ) -evalList env list acc = - case list of - [] -> - ( Ok (List.reverse acc), env ) - - x :: rest -> - case eval env x of - ( Ok val, newEnv ) -> - evalList newEnv rest (val :: acc) - - ( Err msg, newEnv ) -> - ( Err msg, newEnv ) - - -evalDef : Env -> List MalExpr -> ( Result String MalExpr, Env ) -evalDef env args = - case args of - [ MalSymbol name, uneValue ] -> - case eval env uneValue of - ( Ok value, newEnv ) -> - ( Ok value, Env.set name value newEnv ) - - err -> - err - - _ -> - ( Err "def! expected two args: name and value", env ) - - -evalLet : Env -> List MalExpr -> ( Result String MalExpr, Env ) -evalLet env args = - let - evalBinds env binds = - case binds of - (MalSymbol name) :: expr :: rest -> - case eval env expr of - ( Ok value, newEnv ) -> - let - newEnv = - Env.set name value env - in - if List.isEmpty rest then - Ok newEnv - else - evalBinds newEnv rest - - ( Err msg, _ ) -> - Err msg - - _ -> - Err "let* expected an even number of binds (symbol expr ..)" - - go binds body = - case evalBinds (Env.push env) binds of - Ok newEnv -> - eval newEnv body - |> mapSecond (\_ -> Env.pop newEnv) - - Err msg -> - ( Err msg, env ) - in - case args of - [ MalList binds, body ] -> - go binds body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - ( Err "let* expected two args: binds and a body", env ) - - -{-| Try to map a list with a fn that can return a Err. - -Maps the list from left to right. As soon as a error -occurs it will not process any more elements and return -the error. - --} -tryMapList : (a -> Result e b) -> List a -> Result e (List b) -tryMapList fn list = - let - go x = - Result.andThen - (\acc -> - case fn x of - Ok val -> - Ok (val :: acc) - - Err msg -> - Err msg - ) - in - List.foldl go (Ok []) list - |> Result.map List.reverse - - -print : MalExpr -> String -print = - printString Env.global True - - -{-| Read-Eval-Print. rep returns: - -Nothing -> if an empty string is read (ws/comments) -Just ((Ok out), newEnv) -> input has been evaluated. -Just ((Err msg), env) -> error parsing or evaluating. - --} -rep : Env -> String -> Maybe ( Result String String, Env ) -rep env input = - let - evalPrint = - eval env >> mapFirst (Result.map print) - in - case readString input of - Ok Nothing -> - Nothing - - Err msg -> - Just ( Err msg, env ) - - Ok (Just ast) -> - Just (evalPrint ast) +port module Main exposing (..) + +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip) +import Dict exposing (Dict) +import Tuple exposing (mapFirst, mapSecond, second) +import Array +import Env +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Flags = + { args : List String + } + + +type alias Model = + { args : List String + , env : Env + } + + +type Msg + = Input (Result String IO) + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + ( { args = args, env = initReplEnv }, readLine prompt ) + + +initReplEnv : Env +initReplEnv = + let + makeFn = + CoreFunc >> MalFunction + + binaryOp fn args = + case args of + [ MalInt x, MalInt y ] -> + Eval.succeed <| MalInt (fn x y) + + _ -> + Eval.fail "unsupported arguments" + in + Env.global + |> Env.set "+" (makeFn <| binaryOp (+)) + |> Env.set "-" (makeFn <| binaryOp (-)) + |> Env.set "*" (makeFn <| binaryOp (*)) + |> Env.set "/" (makeFn <| binaryOp (//)) + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + Input (Ok (LineRead (Just line))) -> + case rep model.env line of + Nothing -> + ( model, readLine prompt ) + + Just ( result, newEnv ) -> + ( { model | env = newEnv }, writeLine (makeOutput result) ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +makeOutput : Result String String -> String +makeOutput result = + case result of + Ok str -> + str + + Err msg -> + "Error: " ++ msg + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +eval : Env -> MalExpr -> ( Result String MalExpr, Env ) +eval env ast = + case ast of + MalList [] -> + ( Ok ast, env ) + + MalList ((MalSymbol "def!") :: args) -> + evalDef env args + + MalList ((MalSymbol "let*") :: args) -> + evalLet env args + + MalList list -> + case evalList env list [] of + ( Ok newList, newEnv ) -> + case newList of + [] -> + ( Err "can't happen", newEnv ) + + (MalFunction (CoreFunc fn)) :: args -> + case Eval.runSimple (fn args) of + Ok res -> + ( Ok res, newEnv ) + + Err msg -> + ( Err (print msg), newEnv ) + + fn :: _ -> + ( Err ((print fn) ++ " is not a function"), newEnv ) + + ( Err msg, newEnv ) -> + ( Err msg, newEnv ) + + _ -> + evalAst env ast + + +evalAst : Env -> MalExpr -> ( Result String MalExpr, Env ) +evalAst env ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + case Env.get sym env of + Ok val -> + ( Ok val, env ) + + Err msg -> + ( Err msg, env ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList env list [] + |> mapFirst (Result.map MalList) + + MalVector vec -> + evalList env (Array.toList vec) [] + |> mapFirst (Result.map (Array.fromList >> MalVector)) + + MalMap map -> + evalList env (Dict.values map) [] + |> mapFirst + (Result.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + ) + + _ -> + ( Ok ast, env ) + + +evalList : Env -> List MalExpr -> List MalExpr -> ( Result String (List MalExpr), Env ) +evalList env list acc = + case list of + [] -> + ( Ok (List.reverse acc), env ) + + x :: rest -> + case eval env x of + ( Ok val, newEnv ) -> + evalList newEnv rest (val :: acc) + + ( Err msg, newEnv ) -> + ( Err msg, newEnv ) + + +evalDef : Env -> List MalExpr -> ( Result String MalExpr, Env ) +evalDef env args = + case args of + [ MalSymbol name, uneValue ] -> + case eval env uneValue of + ( Ok value, newEnv ) -> + ( Ok value, Env.set name value newEnv ) + + err -> + err + + _ -> + ( Err "def! expected two args: name and value", env ) + + +evalLet : Env -> List MalExpr -> ( Result String MalExpr, Env ) +evalLet env args = + let + evalBinds env binds = + case binds of + (MalSymbol name) :: expr :: rest -> + case eval env expr of + ( Ok value, newEnv ) -> + let + newEnv = + Env.set name value env + in + if List.isEmpty rest then + Ok newEnv + else + evalBinds newEnv rest + + ( Err msg, _ ) -> + Err msg + + _ -> + Err "let* expected an even number of binds (symbol expr ..)" + + go binds body = + case evalBinds (Env.push env) binds of + Ok newEnv -> + eval newEnv body + |> mapSecond (\_ -> Env.pop newEnv) + + Err msg -> + ( Err msg, env ) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + ( Err "let* expected two args: binds and a body", env ) + + +{-| Try to map a list with a fn that can return a Err. + +Maps the list from left to right. As soon as a error +occurs it will not process any more elements and return +the error. + +-} +tryMapList : (a -> Result e b) -> List a -> Result e (List b) +tryMapList fn list = + let + go x = + Result.andThen + (\acc -> + case fn x of + Ok val -> + Ok (val :: acc) + + Err msg -> + Err msg + ) + in + List.foldl go (Ok []) list + |> Result.map List.reverse + + +print : MalExpr -> String +print = + printString Env.global True + + +{-| Read-Eval-Print. rep returns: + +Nothing -> if an empty string is read (ws/comments) +Just ((Ok out), newEnv) -> input has been evaluated. +Just ((Err msg), env) -> error parsing or evaluating. + +-} +rep : Env -> String -> Maybe ( Result String String, Env ) +rep env input = + let + evalPrint = + eval env >> mapFirst (Result.map print) + in + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just ( Err msg, env ) + + Ok (Just ast) -> + Just (evalPrint ast) diff --git a/impls/elm/step4_if_fn_do.elm b/impls/elm/step4_if_fn_do.elm index a988b54d59..19c055c6aa 100644 --- a/impls/elm/step4_if_fn_do.elm +++ b/impls/elm/step4_if_fn_do.elm @@ -1,498 +1,498 @@ -port module Main exposing (..) - -import Array -import Dict exposing (Dict) -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (..) -import Reader exposing (readString) -import Printer exposing (printString) -import Utils exposing (maybeToList, zip, last, justValues) -import Env -import Core -import Eval - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = - \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Flags = - { args : List String - } - - -type Model - = InitIO Env (IO -> Eval MalExpr) - | InitError - | ReplActive Env - | ReplIO Env (IO -> Eval MalExpr) - - -init : Flags -> ( Model, Cmd Msg ) -init { args } = - let - initEnv = - Core.ns - - evalMalInit = - malInit - |> List.map rep - |> justValues - |> List.foldl - (\b a -> a |> Eval.andThen (\_ -> b)) - (Eval.succeed MalNil) - in - runInit initEnv evalMalInit - - -malInit : List String -malInit = - [ """(def! not - (fn* (a) - (if a false true)))""" - ] - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case model of - InitError -> - -- ignore all - ( model, Cmd.none ) - - InitIO env cont -> - case msg of - Input (Ok io) -> - runInit env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ReplActive env -> - case msg of - Input (Ok (LineRead (Just line))) -> - case rep line of - Just expr -> - run env expr - - Nothing -> - ( model, readLine prompt ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - -- Ctrl+D = The End. - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg - - ReplIO env cont -> - case msg of - Input (Ok io) -> - run env (cont io) - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runInit env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - -- Init went okay, start REPL. - ( ReplActive env, readLine prompt ) - - ( env, EvalErr msg ) -> - -- Init failed, don't start REPL. - ( InitError, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - -- IO in init. - ( InitIO env cont, cmd ) - - -run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -run env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print env expr) ) - - ( env, EvalErr msg ) -> - ( ReplActive env, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ReplIO env cont, cmd ) - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -eval : MalExpr -> Eval MalExpr -eval ast = - case ast of - MalList [] -> - Eval.succeed ast - - MalList ((MalSymbol "def!") :: args) -> - evalDef args - - MalList ((MalSymbol "let*") :: args) -> - evalLet args - - MalList ((MalSymbol "do") :: args) -> - evalDo args - - MalList ((MalSymbol "if") :: args) -> - evalIf args - - MalList ((MalSymbol "fn*") :: args) -> - evalFn args - - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" - - (MalFunction (CoreFunc fn)) :: args -> - fn args - - (MalFunction (UserFunc { eagerFn })) :: args -> - eagerFn args - - fn :: _ -> - Eval.withEnv - (\env -> - Eval.fail ((printString env True fn) ++ " is not a function") - ) - ) - - _ -> - evalAst ast - - -evalAst : MalExpr -> Eval MalExpr -evalAst ast = - case ast of - MalSymbol sym -> - -- Lookup symbol in env and return value or raise error if not found. - Eval.withEnv - (\env -> - case Env.get sym env of - Ok val -> - Eval.succeed val - - Err msg -> - Eval.fail msg - ) - - MalList list -> - -- Return new list that is result of calling eval on each element of list. - evalList list - |> Eval.map MalList - - MalVector vec -> - evalList (Array.toList vec) - |> Eval.map (Array.fromList >> MalVector) - - MalMap map -> - evalList (Dict.values map) - |> Eval.map - (zip (Dict.keys map) - >> Dict.fromList - >> MalMap - ) - - _ -> - Eval.succeed ast - - -evalList : List MalExpr -> Eval (List MalExpr) -evalList list = - let - go list acc = - case list of - [] -> - Eval.succeed (List.reverse acc) - - x :: rest -> - eval x - |> Eval.andThen - (\val -> - go rest (val :: acc) - ) - in - go list [] - - -evalDef : List MalExpr -> Eval MalExpr -evalDef args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen (\_ -> Eval.succeed value) - ) - - _ -> - Eval.fail "def! expected two args: name and value" - - -evalLet : List MalExpr -> Eval MalExpr -evalLet args = - let - evalBinds binds = - case binds of - (MalSymbol name) :: expr :: rest -> - eval expr - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen - (\_ -> - if List.isEmpty rest then - Eval.succeed () - else - evalBinds rest - ) - ) - - _ -> - Eval.fail "let* expected an even number of binds (symbol expr ..)" - - go binds body = - Eval.modifyEnv Env.push - |> Eval.andThen (\_ -> evalBinds binds) - |> Eval.andThen (\_ -> eval body) - |> Eval.andThen - (\res -> - Eval.modifyEnv Env.pop - |> Eval.map (\_ -> res) - ) - in - case args of - [ MalList binds, body ] -> - go binds body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "let* expected two args: binds and a body" - - -evalDo : List MalExpr -> Eval MalExpr -evalDo args = - let - returnLast list = - case last list of - Just value -> - Eval.succeed value - - Nothing -> - Eval.fail "do expected at least one arg" - in - evalList args - |> Eval.andThen returnLast - - -evalIf : List MalExpr -> Eval MalExpr -evalIf args = - let - isThruthy expr = - expr /= MalNil && expr /= (MalBool False) - - go condition trueExpr falseExpr = - eval condition - |> Eval.map isThruthy - |> Eval.andThen - (\cond -> - eval - (if cond then - trueExpr - else - falseExpr - ) - ) - in - case args of - [ condition, trueExpr ] -> - go condition trueExpr MalNil - - [ condition, trueExpr, falseExpr ] -> - go condition trueExpr falseExpr - - _ -> - Eval.fail "if expected at least two args" - - -evalFn : List MalExpr -> Eval MalExpr -evalFn args = - let - {- Extract symbols from the binds list and verify their uniqueness -} - extractSymbols acc list = - case list of - [] -> - Ok (List.reverse acc) - - (MalSymbol name) :: rest -> - if List.member name acc then - Err "all binds must have unique names" - else - extractSymbols (name :: acc) rest - - _ -> - Err "all binds in fn* must be a symbol" - - parseBinds list = - case List.reverse list of - var :: "&" :: rest -> - Ok <| bindVarArgs (List.reverse rest) var - - _ -> - if List.member "&" list then - Err "varargs separator '&' is used incorrectly" - else - Ok <| bindArgs list - - extractAndParse = - extractSymbols [] >> Result.andThen parseBinds - - bindArgs binds args = - let - numBinds = - List.length binds - in - if List.length args /= numBinds then - Err <| - "function expected " - ++ (toString numBinds) - ++ " arguments" - else - Ok <| zip binds args - - bindVarArgs binds var args = - let - minArgs = - List.length binds - - varArgs = - MalList (List.drop minArgs args) - in - if List.length args < minArgs then - Err <| - "function expected at least " - ++ (toString minArgs) - ++ " arguments" - else - Ok <| zip binds args ++ [ ( var, varArgs ) ] - - makeFn frameId binder body = - let - fn args = - case binder args of - Ok bound -> - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.enter frameId bound) - |> Eval.andThen (always (eval body)) - |> Eval.finally Env.leave - ) - - Err msg -> - Eval.fail msg - in - MalFunction <| - UserFunc - { frameId = frameId - , lazyFn = fn - , eagerFn = fn - , isMacro = False - , meta = Nothing - } - - go bindsList body = - case extractAndParse bindsList of - Ok binder -> - Eval.modifyEnv Env.ref - -- reference the current frame. - |> Eval.andThen - (\_ -> - Eval.withEnv - (\env -> - Eval.succeed - (makeFn env.currentFrameId binder body) - ) - ) - - Err msg -> - Eval.fail msg - in - case args of - [ MalList bindsList, body ] -> - go bindsList body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "fn* expected two args: binds list and body" - - -print : Env -> MalExpr -> String -print env = - printString env True - - -printError : Env -> MalExpr -> String -printError env expr = - "Error: " ++ (printString env False expr) - - -{-| Read-Eval-Print. - -Doesn't actually run the Eval but returns the monad. - --} -rep : String -> Maybe (Eval MalExpr) -rep input = - case readString input of - Ok Nothing -> - Nothing - - Err msg -> - Just (Eval.fail msg) - - Ok (Just ast) -> - eval ast |> Just +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Flags = + { args : List String + } + + +type Model + = InitIO Env (IO -> Eval MalExpr) + | InitError + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + initEnv = + Core.ns + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + InitError -> + -- ignore all + ( model, Cmd.none ) + + InitIO env cont -> + case msg of + Input (Ok io) -> + runInit env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay, start REPL. + ( ReplActive env, readLine prompt ) + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( InitError, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +eval : MalExpr -> Eval MalExpr +eval ast = + case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { eagerFn })) :: args -> + eagerFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv + (\env -> + case Env.get sym env of + Ok val -> + Eval.succeed val + + Err msg -> + Eval.fail msg + ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> eval body) + |> Eval.andThen + (\res -> + Eval.modifyEnv Env.pop + |> Eval.map (\_ -> res) + ) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + let + returnLast list = + case last list of + Just value -> + Eval.succeed value + + Nothing -> + Eval.fail "do expected at least one arg" + in + evalList args + |> Eval.andThen returnLast + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + eval + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + let + fn args = + case binder args of + Ok bound -> + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (always (eval body)) + |> Eval.finally Env.leave + ) + + Err msg -> + Eval.fail msg + in + MalFunction <| + UserFunc + { frameId = frameId + , lazyFn = fn + , eagerFn = fn + , isMacro = False + , meta = Nothing + } + + go bindsList body = + case extractAndParse bindsList of + Ok binder -> + Eval.modifyEnv Env.ref + -- reference the current frame. + |> Eval.andThen + (\_ -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + + Err msg -> + Eval.fail msg + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +print : Env -> MalExpr -> String +print env = + printString env True + + +printError : Env -> MalExpr -> String +printError env expr = + "Error: " ++ (printString env False expr) + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just diff --git a/impls/elm/step5_tco.elm b/impls/elm/step5_tco.elm index d9fb3c0332..12dfba5792 100644 --- a/impls/elm/step5_tco.elm +++ b/impls/elm/step5_tco.elm @@ -1,536 +1,536 @@ -port module Main exposing (..) - -import Array -import Dict exposing (Dict) -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (..) -import Reader exposing (readString) -import Printer exposing (printString) -import Utils exposing (maybeToList, zip, last, justValues) -import Env -import Core -import Eval - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = - \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Flags = - { args : List String - } - - -type Model - = InitIO Env (IO -> Eval MalExpr) - | InitError - | ReplActive Env - | ReplIO Env (IO -> Eval MalExpr) - - -init : Flags -> ( Model, Cmd Msg ) -init { args } = - let - initEnv = - Core.ns - - evalMalInit = - malInit - |> List.map rep - |> justValues - |> List.foldl - (\b a -> a |> Eval.andThen (\_ -> b)) - (Eval.succeed MalNil) - in - runInit initEnv evalMalInit - - -malInit : List String -malInit = - [ """(def! not - (fn* (a) - (if a false true)))""" - ] - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case model of - InitError -> - -- ignore all - ( model, Cmd.none ) - - InitIO env cont -> - case msg of - Input (Ok io) -> - runInit env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ReplActive env -> - case msg of - Input (Ok (LineRead (Just line))) -> - case rep line of - Just expr -> - run env expr - - Nothing -> - ( model, readLine prompt ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - -- Ctrl+D = The End. - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg - - ReplIO env cont -> - case msg of - Input (Ok io) -> - run env (cont io) - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runInit env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - -- Init went okay, start REPL. - ( ReplActive env, readLine prompt ) - - ( env, EvalErr msg ) -> - -- Init failed, don't start REPL. - ( InitError, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - -- IO in init. - ( InitIO env cont, cmd ) - - -run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -run env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print env expr) ) - - ( env, EvalErr msg ) -> - ( ReplActive env, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ReplIO env cont, cmd ) - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -debug : String -> (Env -> a) -> Eval b -> Eval b -debug msg f e = - Eval.withEnv - (\env -> - Env.debug env msg (f env) - |> always e - ) - - -eval : MalExpr -> Eval MalExpr -eval ast = - let - apply expr env = - case expr of - MalApply app -> - Left - (debug "evalApply" - (\env -> printString env True expr) - (evalApply app) - ) - - _ -> - Right expr - in - evalNoApply ast - |> Eval.andThen (Eval.runLoop apply) - - -evalApply : ApplyRec -> Eval MalExpr -evalApply { frameId, bound, body } = - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.enter frameId bound) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.leave - |> Eval.gcPass - ) - - -evalNoApply : MalExpr -> Eval MalExpr -evalNoApply ast = - debug "evalNoApply" - (\env -> printString env True ast) - (case ast of - MalList [] -> - Eval.succeed ast - - MalList ((MalSymbol "def!") :: args) -> - evalDef args - - MalList ((MalSymbol "let*") :: args) -> - evalLet args - - MalList ((MalSymbol "do") :: args) -> - evalDo args - - MalList ((MalSymbol "if") :: args) -> - evalIf args - - MalList ((MalSymbol "fn*") :: args) -> - evalFn args - - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" - - (MalFunction (CoreFunc fn)) :: args -> - fn args - - (MalFunction (UserFunc { lazyFn })) :: args -> - lazyFn args - - fn :: _ -> - Eval.withEnv - (\env -> - Eval.fail ((printString env True fn) ++ " is not a function") - ) - ) - - _ -> - evalAst ast - ) - - -evalAst : MalExpr -> Eval MalExpr -evalAst ast = - case ast of - MalSymbol sym -> - -- Lookup symbol in env and return value or raise error if not found. - Eval.withEnv - (\env -> - case Env.get sym env of - Ok val -> - Eval.succeed val - - Err msg -> - Eval.fail msg - ) - - MalList list -> - -- Return new list that is result of calling eval on each element of list. - evalList list - |> Eval.map MalList - - MalVector vec -> - evalList (Array.toList vec) - |> Eval.map (Array.fromList >> MalVector) - - MalMap map -> - evalList (Dict.values map) - |> Eval.map - (zip (Dict.keys map) - >> Dict.fromList - >> MalMap - ) - - _ -> - Eval.succeed ast - - -evalList : List MalExpr -> Eval (List MalExpr) -evalList list = - let - go list acc = - case list of - [] -> - Eval.succeed (List.reverse acc) - - x :: rest -> - eval x - |> Eval.andThen - (\val -> - go rest (val :: acc) - ) - in - go list [] - - -evalDef : List MalExpr -> Eval MalExpr -evalDef args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen (\_ -> Eval.succeed value) - ) - - _ -> - Eval.fail "def! expected two args: name and value" - - -evalLet : List MalExpr -> Eval MalExpr -evalLet args = - let - evalBinds binds = - case binds of - (MalSymbol name) :: expr :: rest -> - eval expr - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen - (\_ -> - if List.isEmpty rest then - Eval.succeed () - else - evalBinds rest - ) - ) - - _ -> - Eval.fail "let* expected an even number of binds (symbol expr ..)" - - go binds body = - Eval.modifyEnv Env.push - |> Eval.andThen (\_ -> evalBinds binds) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.andThen - (\res -> - Eval.modifyEnv Env.pop - |> Eval.map (\_ -> res) - ) - in - case args of - [ MalList binds, body ] -> - go binds body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "let* expected two args: binds and a body" - - -evalDo : List MalExpr -> Eval MalExpr -evalDo args = - case List.reverse args of - last :: rest -> - evalList (List.reverse rest) - |> Eval.andThen (\_ -> evalNoApply last) - - [] -> - Eval.fail "do expected at least one arg" - - -evalIf : List MalExpr -> Eval MalExpr -evalIf args = - let - isThruthy expr = - expr /= MalNil && expr /= (MalBool False) - - go condition trueExpr falseExpr = - eval condition - |> Eval.map isThruthy - |> Eval.andThen - (\cond -> - evalNoApply - (if cond then - trueExpr - else - falseExpr - ) - ) - in - case args of - [ condition, trueExpr ] -> - go condition trueExpr MalNil - - [ condition, trueExpr, falseExpr ] -> - go condition trueExpr falseExpr - - _ -> - Eval.fail "if expected at least two args" - - -evalFn : List MalExpr -> Eval MalExpr -evalFn args = - let - {- Extract symbols from the binds list and verify their uniqueness -} - extractSymbols acc list = - case list of - [] -> - Ok (List.reverse acc) - - (MalSymbol name) :: rest -> - if List.member name acc then - Err "all binds must have unique names" - else - extractSymbols (name :: acc) rest - - _ -> - Err "all binds in fn* must be a symbol" - - parseBinds list = - case List.reverse list of - var :: "&" :: rest -> - Ok <| bindVarArgs (List.reverse rest) var - - _ -> - if List.member "&" list then - Err "varargs separator '&' is used incorrectly" - else - Ok <| bindArgs list - - extractAndParse = - extractSymbols [] >> Result.andThen parseBinds - - bindArgs binds args = - let - numBinds = - List.length binds - in - if List.length args /= numBinds then - Err <| - "function expected " - ++ (toString numBinds) - ++ " arguments" - else - Ok <| zip binds args - - bindVarArgs binds var args = - let - minArgs = - List.length binds - - varArgs = - MalList (List.drop minArgs args) - in - if List.length args < minArgs then - Err <| - "function expected at least " - ++ (toString minArgs) - ++ " arguments" - else - Ok <| zip binds args ++ [ ( var, varArgs ) ] - - makeFn frameId binder body = - MalFunction <| - let - lazyFn args = - case binder args of - Ok bound -> - Eval.succeed <| - MalApply - { frameId = frameId - , bound = bound - , body = body - } - - Err msg -> - Eval.fail msg - in - UserFunc - { frameId = frameId - , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval - , isMacro = False - , meta = Nothing - } - - go bindsList body = - case extractAndParse bindsList of - Ok binder -> - Eval.modifyEnv Env.ref - -- reference the current frame. - |> Eval.andThen - (\_ -> - Eval.withEnv - (\env -> - Eval.succeed - (makeFn env.currentFrameId binder body) - ) - ) - - Err msg -> - Eval.fail msg - in - case args of - [ MalList bindsList, body ] -> - go bindsList body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "fn* expected two args: binds list and body" - - -print : Env -> MalExpr -> String -print env = - printString env True - - -printError : Env -> MalExpr -> String -printError env expr = - "Error: " ++ (printString env False expr) - - -{-| Read-Eval-Print. - -Doesn't actually run the Eval but returns the monad. - --} -rep : String -> Maybe (Eval MalExpr) -rep input = - case readString input of - Ok Nothing -> - Nothing - - Err msg -> - Just (Eval.fail msg) - - Ok (Just ast) -> - eval ast |> Just +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Flags = + { args : List String + } + + +type Model + = InitIO Env (IO -> Eval MalExpr) + | InitError + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + initEnv = + Core.ns + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + InitError -> + -- ignore all + ( model, Cmd.none ) + + InitIO env cont -> + case msg of + Input (Ok io) -> + runInit env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay, start REPL. + ( ReplActive env, readLine prompt ) + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( InitError, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr env = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.leave + |> Eval.gcPass + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + debug "evalNoApply" + (\env -> printString env True ast) + (case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + ) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv + (\env -> + case Env.get sym env of + Ok val -> + Eval.succeed val + + Err msg -> + Eval.fail msg + ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.andThen + (\res -> + Eval.modifyEnv Env.pop + |> Eval.map (\_ -> res) + ) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn args = + case binder args of + Ok bound -> + Eval.succeed <| + MalApply + { frameId = frameId + , bound = bound + , body = body + } + + Err msg -> + Eval.fail msg + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False + , meta = Nothing + } + + go bindsList body = + case extractAndParse bindsList of + Ok binder -> + Eval.modifyEnv Env.ref + -- reference the current frame. + |> Eval.andThen + (\_ -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + + Err msg -> + Eval.fail msg + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +print : Env -> MalExpr -> String +print env = + printString env True + + +printError : Env -> MalExpr -> String +printError env expr = + "Error: " ++ (printString env False expr) + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just diff --git a/impls/elm/step6_file.elm b/impls/elm/step6_file.elm index d1b3e8420d..5f6f153bb2 100644 --- a/impls/elm/step6_file.elm +++ b/impls/elm/step6_file.elm @@ -1,606 +1,606 @@ -port module Main exposing (..) - -import Array -import Dict exposing (Dict) -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (..) -import Reader exposing (readString) -import Printer exposing (printString) -import Utils exposing (maybeToList, zip, last, justValues) -import Env -import Core -import Eval - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = - \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Args = - List String - - -type alias Flags = - { args : Args - } - - -type Model - = InitIO Args Env (IO -> Eval MalExpr) - | ScriptIO Env (IO -> Eval MalExpr) - | ReplActive Env - | ReplIO Env (IO -> Eval MalExpr) - | Stopped - - -init : Flags -> ( Model, Cmd Msg ) -init { args } = - let - makeFn = - CoreFunc >> MalFunction - - initEnv = - Core.ns - |> Env.set "eval" (makeFn malEval) - |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) - - evalMalInit = - malInit - |> List.map rep - |> justValues - |> List.foldl - (\b a -> a |> Eval.andThen (\_ -> b)) - (Eval.succeed MalNil) - in - runInit args initEnv evalMalInit - - -malInit : List String -malInit = - [ """(def! not - (fn* (a) - (if a false true)))""" - , """(def! load-file - (fn* (f) - (eval (read-string - (str "(do " (slurp f) "\nnil)")))))""" - ] - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case model of - Stopped -> - ( model, Cmd.none ) - - InitIO args env cont -> - case msg of - Input (Ok io) -> - runInit args env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ScriptIO env cont -> - case msg of - Input (Ok io) -> - runScriptLoop env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ReplActive env -> - case msg of - Input (Ok (LineRead (Just line))) -> - case rep line of - Just expr -> - run env expr - - Nothing -> - ( model, readLine prompt ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - -- Ctrl+D = The End. - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg - - ReplIO env cont -> - case msg of - Input (Ok io) -> - run env (cont io) - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runInit args env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - -- Init went okay. - case args of - -- If we got no args: start REPL. - [] -> - ( ReplActive env, readLine prompt ) - - -- Run the script in the first argument. - -- Put the rest of the arguments as *ARGV*. - filename :: argv -> - runScript filename argv env - - ( env, EvalErr msg ) -> - -- Init failed, don't start REPL. - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - -- IO in init. - ( InitIO args env cont, cmd ) - - -runScript : String -> List String -> Env -> ( Model, Cmd Msg ) -runScript filename argv env = - let - malArgv = - MalList (List.map MalString argv) - - newEnv = - env |> Env.set "*ARGV*" malArgv - - program = - MalList - [ MalSymbol "load-file" - , MalString filename - ] - in - runScriptLoop newEnv (eval program) - - -runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runScriptLoop env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( Stopped, Cmd.none ) - - ( env, EvalErr msg ) -> - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ScriptIO env cont, cmd ) - - -run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -run env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print env expr) ) - - ( env, EvalErr msg ) -> - ( ReplActive env, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ReplIO env cont, cmd ) - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -debug : String -> (Env -> a) -> Eval b -> Eval b -debug msg f e = - Eval.withEnv - (\env -> - Env.debug env msg (f env) - |> always e - ) - - -eval : MalExpr -> Eval MalExpr -eval ast = - let - apply expr env = - case expr of - MalApply app -> - Left - (debug "evalApply" - (\env -> printString env True expr) - (evalApply app) - ) - - _ -> - Right expr - in - evalNoApply ast - |> Eval.andThen (Eval.runLoop apply) - - -malEval : List MalExpr -> Eval MalExpr -malEval args = - case args of - [ expr ] -> - Eval.inGlobal (eval expr) - - _ -> - Eval.fail "unsupported arguments" - - -evalApply : ApplyRec -> Eval MalExpr -evalApply { frameId, bound, body } = - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.enter frameId bound) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.leave - |> Eval.gcPass - ) - - -evalNoApply : MalExpr -> Eval MalExpr -evalNoApply ast = - debug "evalNoApply" - (\env -> printString env True ast) - (case ast of - MalList [] -> - Eval.succeed ast - - MalList ((MalSymbol "def!") :: args) -> - evalDef args - - MalList ((MalSymbol "let*") :: args) -> - evalLet args - - MalList ((MalSymbol "do") :: args) -> - evalDo args - - MalList ((MalSymbol "if") :: args) -> - evalIf args - - MalList ((MalSymbol "fn*") :: args) -> - evalFn args - - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" - - (MalFunction (CoreFunc fn)) :: args -> - fn args - - (MalFunction (UserFunc { lazyFn })) :: args -> - lazyFn args - - fn :: _ -> - Eval.withEnv - (\env -> - Eval.fail ((printString env True fn) ++ " is not a function") - ) - ) - - _ -> - evalAst ast - ) - - -evalAst : MalExpr -> Eval MalExpr -evalAst ast = - case ast of - MalSymbol sym -> - -- Lookup symbol in env and return value or raise error if not found. - Eval.withEnv - (\env -> - case Env.get sym env of - Ok val -> - Eval.succeed val - - Err msg -> - Eval.fail msg - ) - - MalList list -> - -- Return new list that is result of calling eval on each element of list. - evalList list - |> Eval.map MalList - - MalVector vec -> - evalList (Array.toList vec) - |> Eval.map (Array.fromList >> MalVector) - - MalMap map -> - evalList (Dict.values map) - |> Eval.map - (zip (Dict.keys map) - >> Dict.fromList - >> MalMap - ) - - _ -> - Eval.succeed ast - - -evalList : List MalExpr -> Eval (List MalExpr) -evalList list = - let - go list acc = - case list of - [] -> - Eval.succeed (List.reverse acc) - - x :: rest -> - eval x - |> Eval.andThen - (\val -> - go rest (val :: acc) - ) - in - go list [] - - -evalDef : List MalExpr -> Eval MalExpr -evalDef args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen (\_ -> Eval.succeed value) - ) - - _ -> - Eval.fail "def! expected two args: name and value" - - -evalLet : List MalExpr -> Eval MalExpr -evalLet args = - let - evalBinds binds = - case binds of - (MalSymbol name) :: expr :: rest -> - eval expr - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen - (\_ -> - if List.isEmpty rest then - Eval.succeed () - else - evalBinds rest - ) - ) - - _ -> - Eval.fail "let* expected an even number of binds (symbol expr ..)" - - go binds body = - Eval.modifyEnv Env.push - |> Eval.andThen (\_ -> evalBinds binds) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.andThen - (\res -> - Eval.modifyEnv Env.pop - |> Eval.map (\_ -> res) - ) - in - case args of - [ MalList binds, body ] -> - go binds body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "let* expected two args: binds and a body" - - -evalDo : List MalExpr -> Eval MalExpr -evalDo args = - case List.reverse args of - last :: rest -> - evalList (List.reverse rest) - |> Eval.andThen (\_ -> evalNoApply last) - - [] -> - Eval.fail "do expected at least one arg" - - -evalIf : List MalExpr -> Eval MalExpr -evalIf args = - let - isThruthy expr = - expr /= MalNil && expr /= (MalBool False) - - go condition trueExpr falseExpr = - eval condition - |> Eval.map isThruthy - |> Eval.andThen - (\cond -> - evalNoApply - (if cond then - trueExpr - else - falseExpr - ) - ) - in - case args of - [ condition, trueExpr ] -> - go condition trueExpr MalNil - - [ condition, trueExpr, falseExpr ] -> - go condition trueExpr falseExpr - - _ -> - Eval.fail "if expected at least two args" - - -evalFn : List MalExpr -> Eval MalExpr -evalFn args = - let - {- Extract symbols from the binds list and verify their uniqueness -} - extractSymbols acc list = - case list of - [] -> - Ok (List.reverse acc) - - (MalSymbol name) :: rest -> - if List.member name acc then - Err "all binds must have unique names" - else - extractSymbols (name :: acc) rest - - _ -> - Err "all binds in fn* must be a symbol" - - parseBinds list = - case List.reverse list of - var :: "&" :: rest -> - Ok <| bindVarArgs (List.reverse rest) var - - _ -> - if List.member "&" list then - Err "varargs separator '&' is used incorrectly" - else - Ok <| bindArgs list - - extractAndParse = - extractSymbols [] >> Result.andThen parseBinds - - bindArgs binds args = - let - numBinds = - List.length binds - in - if List.length args /= numBinds then - Err <| - "function expected " - ++ (toString numBinds) - ++ " arguments" - else - Ok <| zip binds args - - bindVarArgs binds var args = - let - minArgs = - List.length binds - - varArgs = - MalList (List.drop minArgs args) - in - if List.length args < minArgs then - Err <| - "function expected at least " - ++ (toString minArgs) - ++ " arguments" - else - Ok <| zip binds args ++ [ ( var, varArgs ) ] - - makeFn frameId binder body = - MalFunction <| - let - lazyFn args = - case binder args of - Ok bound -> - Eval.succeed <| - MalApply - { frameId = frameId - , bound = bound - , body = body - } - - Err msg -> - Eval.fail msg - in - UserFunc - { frameId = frameId - , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval - , isMacro = False - , meta = Nothing - } - - go bindsList body = - case extractAndParse bindsList of - Ok binder -> - Eval.modifyEnv Env.ref - -- reference the current frame. - |> Eval.andThen - (\_ -> - Eval.withEnv - (\env -> - Eval.succeed - (makeFn env.currentFrameId binder body) - ) - ) - - Err msg -> - Eval.fail msg - in - case args of - [ MalList bindsList, body ] -> - go bindsList body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "fn* expected two args: binds list and body" - - -print : Env -> MalExpr -> String -print env = - printString env True - - -printError : Env -> MalExpr -> String -printError env expr = - "Error: " ++ (printString env False expr) - - -{-| Read-Eval-Print. - -Doesn't actually run the Eval but returns the monad. - --} -rep : String -> Maybe (Eval MalExpr) -rep input = - case readString input of - Ok Nothing -> - Nothing - - Err msg -> - Just (Eval.fail msg) - - Ok (Just ast) -> - eval ast |> Just +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Args = + List String + + +type alias Flags = + { args : Args + } + + +type Model + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + | Stopped + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit args initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) "\nnil)")))))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + Stopped -> + ( model, Cmd.none ) + + InitIO args env cont -> + case msg of + Input (Ok io) -> + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr env = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + Eval.inGlobal (eval expr) + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.leave + |> Eval.gcPass + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + debug "evalNoApply" + (\env -> printString env True ast) + (case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + ) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv + (\env -> + case Env.get sym env of + Ok val -> + Eval.succeed val + + Err msg -> + Eval.fail msg + ) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.andThen + (\res -> + Eval.modifyEnv Env.pop + |> Eval.map (\_ -> res) + ) + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn args = + case binder args of + Ok bound -> + Eval.succeed <| + MalApply + { frameId = frameId + , bound = bound + , body = body + } + + Err msg -> + Eval.fail msg + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False + , meta = Nothing + } + + go bindsList body = + case extractAndParse bindsList of + Ok binder -> + Eval.modifyEnv Env.ref + -- reference the current frame. + |> Eval.andThen + (\_ -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + + Err msg -> + Eval.fail msg + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +print : Env -> MalExpr -> String +print env = + printString env True + + +printError : Env -> MalExpr -> String +printError env expr = + "Error: " ++ (printString env False expr) + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just diff --git a/impls/elm/step7_quote.elm b/impls/elm/step7_quote.elm index 2341f94e83..fba0b5db07 100644 --- a/impls/elm/step7_quote.elm +++ b/impls/elm/step7_quote.elm @@ -1,643 +1,643 @@ -port module Main exposing (..) - -import Array -import Dict exposing (Dict) -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (..) -import Reader exposing (readString) -import Printer exposing (printString) -import Utils exposing (maybeToList, zip, last, justValues, makeCall) -import Env -import Core -import Eval - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = - \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Args = - List String - - -type alias Flags = - { args : Args - } - - -type Model - = InitIO Args Env (IO -> Eval MalExpr) - | ScriptIO Env (IO -> Eval MalExpr) - | ReplActive Env - | ReplIO Env (IO -> Eval MalExpr) - | Stopped - - -init : Flags -> ( Model, Cmd Msg ) -init { args } = - let - makeFn = - CoreFunc >> MalFunction - - initEnv = - Core.ns - |> Env.set "eval" (makeFn malEval) - |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) - - evalMalInit = - malInit - |> List.map rep - |> justValues - |> List.foldl - (\b a -> a |> Eval.andThen (\_ -> b)) - (Eval.succeed MalNil) - in - runInit args initEnv evalMalInit - - -malInit : List String -malInit = - [ """(def! not - (fn* (a) - (if a false true)))""" - , """(def! load-file - (fn* (f) - (eval (read-string - (str "(do " (slurp f) "\nnil)")))))""" - ] - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case model of - Stopped -> - ( model, Cmd.none ) - - InitIO args env cont -> - case msg of - Input (Ok io) -> - runInit args env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ScriptIO env cont -> - case msg of - Input (Ok io) -> - runScriptLoop env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ReplActive env -> - case msg of - Input (Ok (LineRead (Just line))) -> - case rep line of - Just expr -> - run env expr - - Nothing -> - ( model, readLine prompt ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - -- Ctrl+D = The End. - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg - - ReplIO env cont -> - case msg of - Input (Ok io) -> - run env (cont io) - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runInit args env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - -- Init went okay. - case args of - -- If we got no args: start REPL. - [] -> - ( ReplActive env, readLine prompt ) - - -- Run the script in the first argument. - -- Put the rest of the arguments as *ARGV*. - filename :: argv -> - runScript filename argv env - - ( env, EvalErr msg ) -> - -- Init failed, don't start REPL. - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - -- IO in init. - ( InitIO args env cont, cmd ) - - -runScript : String -> List String -> Env -> ( Model, Cmd Msg ) -runScript filename argv env = - let - malArgv = - MalList (List.map MalString argv) - - newEnv = - env |> Env.set "*ARGV*" malArgv - - program = - MalList - [ MalSymbol "load-file" - , MalString filename - ] - in - runScriptLoop newEnv (eval program) - - -runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runScriptLoop env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( Stopped, Cmd.none ) - - ( env, EvalErr msg ) -> - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ScriptIO env cont, cmd ) - - -run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -run env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print env expr) ) - - ( env, EvalErr msg ) -> - ( ReplActive env, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ReplIO env cont, cmd ) - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -debug : String -> (Env -> a) -> Eval b -> Eval b -debug msg f e = - Eval.withEnv - (\env -> - Env.debug env msg (f env) - |> always e - ) - - -eval : MalExpr -> Eval MalExpr -eval ast = - let - apply expr env = - case expr of - MalApply app -> - Left - (debug "evalApply" - (\env -> printString env True expr) - (evalApply app) - ) - - _ -> - Right expr - in - evalNoApply ast - |> Eval.andThen (Eval.runLoop apply) - - -malEval : List MalExpr -> Eval MalExpr -malEval args = - case args of - [ expr ] -> - Eval.inGlobal (eval expr) - - _ -> - Eval.fail "unsupported arguments" - - -evalApply : ApplyRec -> Eval MalExpr -evalApply { frameId, bound, body } = - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.enter frameId bound) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.leave - |> Eval.gcPass - ) - - -evalNoApply : MalExpr -> Eval MalExpr -evalNoApply ast = - debug "evalNoApply" - (\env -> printString env True ast) - (case ast of - MalList [] -> - Eval.succeed ast - - MalList ((MalSymbol "def!") :: args) -> - evalDef args - - MalList ((MalSymbol "let*") :: args) -> - evalLet args - - MalList ((MalSymbol "do") :: args) -> - evalDo args - - MalList ((MalSymbol "if") :: args) -> - evalIf args - - MalList ((MalSymbol "fn*") :: args) -> - evalFn args - - MalList ((MalSymbol "quote") :: args) -> - evalQuote args - - MalList [MalSymbol "quasiquoteexpand", expr] -> - Eval.succeed <| evalQuasiQuote expr - MalList (MalSymbol "quasiquoteexpand" :: _) -> - Eval.fail "quasiquoteexpand: arg count" - - MalList ((MalSymbol "quasiquote") :: args) -> - case args of - [ expr ] -> - -- TCO. - evalNoApply (evalQuasiQuote expr) - - _ -> - Eval.fail "unsupported arguments" - - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" - - (MalFunction (CoreFunc fn)) :: args -> - fn args - - (MalFunction (UserFunc { lazyFn })) :: args -> - lazyFn args - - fn :: _ -> - Eval.withEnv - (\env -> - Eval.fail ((printString env True fn) ++ " is not a function") - ) - ) - - _ -> - evalAst ast - ) - - -evalAst : MalExpr -> Eval MalExpr -evalAst ast = - case ast of - MalSymbol sym -> - -- Lookup symbol in env and return value or raise error if not found. - Eval.withEnv (Env.get sym >> Eval.fromResult) - - MalList list -> - -- Return new list that is result of calling eval on each element of list. - evalList list - |> Eval.map MalList - - MalVector vec -> - evalList (Array.toList vec) - |> Eval.map (Array.fromList >> MalVector) - - MalMap map -> - evalList (Dict.values map) - |> Eval.map - (zip (Dict.keys map) - >> Dict.fromList - >> MalMap - ) - - _ -> - Eval.succeed ast - - -evalList : List MalExpr -> Eval (List MalExpr) -evalList list = - let - go list acc = - case list of - [] -> - Eval.succeed (List.reverse acc) - - x :: rest -> - eval x - |> Eval.andThen - (\val -> - go rest (val :: acc) - ) - in - go list [] - - -evalDef : List MalExpr -> Eval MalExpr -evalDef args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen (\_ -> Eval.succeed value) - ) - - _ -> - Eval.fail "def! expected two args: name and value" - - -evalLet : List MalExpr -> Eval MalExpr -evalLet args = - let - evalBinds binds = - case binds of - (MalSymbol name) :: expr :: rest -> - eval expr - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen - (\_ -> - if List.isEmpty rest then - Eval.succeed () - else - evalBinds rest - ) - ) - - _ -> - Eval.fail "let* expected an even number of binds (symbol expr ..)" - - go binds body = - Eval.modifyEnv Env.push - |> Eval.andThen (\_ -> evalBinds binds) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.pop - in - case args of - [ MalList binds, body ] -> - go binds body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "let* expected two args: binds and a body" - - -evalDo : List MalExpr -> Eval MalExpr -evalDo args = - case List.reverse args of - last :: rest -> - evalList (List.reverse rest) - |> Eval.andThen (\_ -> evalNoApply last) - - [] -> - Eval.fail "do expected at least one arg" - - -evalIf : List MalExpr -> Eval MalExpr -evalIf args = - let - isThruthy expr = - expr /= MalNil && expr /= (MalBool False) - - go condition trueExpr falseExpr = - eval condition - |> Eval.map isThruthy - |> Eval.andThen - (\cond -> - evalNoApply - (if cond then - trueExpr - else - falseExpr - ) - ) - in - case args of - [ condition, trueExpr ] -> - go condition trueExpr MalNil - - [ condition, trueExpr, falseExpr ] -> - go condition trueExpr falseExpr - - _ -> - Eval.fail "if expected at least two args" - - -evalFn : List MalExpr -> Eval MalExpr -evalFn args = - let - {- Extract symbols from the binds list and verify their uniqueness -} - extractSymbols acc list = - case list of - [] -> - Ok (List.reverse acc) - - (MalSymbol name) :: rest -> - if List.member name acc then - Err "all binds must have unique names" - else - extractSymbols (name :: acc) rest - - _ -> - Err "all binds in fn* must be a symbol" - - parseBinds list = - case List.reverse list of - var :: "&" :: rest -> - Ok <| bindVarArgs (List.reverse rest) var - - _ -> - if List.member "&" list then - Err "varargs separator '&' is used incorrectly" - else - Ok <| bindArgs list - - extractAndParse = - extractSymbols [] >> Result.andThen parseBinds - - bindArgs binds args = - let - numBinds = - List.length binds - in - if List.length args /= numBinds then - Err <| - "function expected " - ++ (toString numBinds) - ++ " arguments" - else - Ok <| zip binds args - - bindVarArgs binds var args = - let - minArgs = - List.length binds - - varArgs = - MalList (List.drop minArgs args) - in - if List.length args < minArgs then - Err <| - "function expected at least " - ++ (toString minArgs) - ++ " arguments" - else - Ok <| zip binds args ++ [ ( var, varArgs ) ] - - makeFn frameId binder body = - MalFunction <| - let - lazyFn = - binder - >> Eval.fromResult - >> Eval.map - (\bound -> - MalApply - { frameId = frameId - , bound = bound - , body = body - } - ) - in - UserFunc - { frameId = frameId - , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval - , isMacro = False - , meta = Nothing - } - - go bindsList body = - extractAndParse bindsList - |> Eval.fromResult - -- reference the current frame. - |> Eval.ignore (Eval.modifyEnv Env.ref) - |> Eval.andThen - (\binder -> - Eval.withEnv - (\env -> - Eval.succeed - (makeFn env.currentFrameId binder body) - ) - ) - in - case args of - [ MalList bindsList, body ] -> - go bindsList body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "fn* expected two args: binds list and body" - - -evalQuote : List MalExpr -> Eval MalExpr -evalQuote args = - case args of - [ expr ] -> - Eval.succeed expr - - _ -> - Eval.fail "unsupported arguments" - - -evalQuasiQuote : MalExpr -> MalExpr -evalQuasiQuote expr = - let - qq_loop : MalExpr -> MalExpr -> MalExpr - qq_loop elt acc = - case elt of - (MalList [MalSymbol "splice-unquote", form]) -> - MalList <| [MalSymbol "concat", form, acc ] - _ -> - MalList <| [MalSymbol "cons", evalQuasiQuote elt, acc ] - in - case expr of - (MalList [MalSymbol "unquote", form]) -> - form - (MalList xs) -> - List.foldr qq_loop (MalList []) xs - (MalVector xs) -> - MalList <| (\x -> [MalSymbol "vec", x]) <| Array.foldr qq_loop (MalList []) xs - (MalSymbol _) -> - MalList <| [MalSymbol "quote", expr] - (MalMap _) -> - MalList <| [MalSymbol "quote", expr] - _ -> - expr - - -print : Env -> MalExpr -> String -print env = - printString env True - - -printError : Env -> MalExpr -> String -printError env expr = - "Error: " ++ (printString env False expr) - - -{-| Read-Eval-Print. - -Doesn't actually run the Eval but returns the monad. - --} -rep : String -> Maybe (Eval MalExpr) -rep input = - case readString input of - Ok Nothing -> - Nothing - - Err msg -> - Just (Eval.fail msg) - - Ok (Just ast) -> - eval ast |> Just +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues, makeCall) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Args = + List String + + +type alias Flags = + { args : Args + } + + +type Model + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + | Stopped + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit args initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) "\nnil)")))))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + Stopped -> + ( model, Cmd.none ) + + InitIO args env cont -> + case msg of + Input (Ok io) -> + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr env = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + Eval.inGlobal (eval expr) + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.leave + |> Eval.gcPass + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + debug "evalNoApply" + (\env -> printString env True ast) + (case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList ((MalSymbol "quote") :: args) -> + evalQuote args + + MalList [MalSymbol "quasiquoteexpand", expr] -> + Eval.succeed <| evalQuasiQuote expr + MalList (MalSymbol "quasiquoteexpand" :: _) -> + Eval.fail "quasiquoteexpand: arg count" + + MalList ((MalSymbol "quasiquote") :: args) -> + case args of + [ expr ] -> + -- TCO. + evalNoApply (evalQuasiQuote expr) + + _ -> + Eval.fail "unsupported arguments" + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + ) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv (Env.get sym >> Eval.fromResult) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.pop + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn = + binder + >> Eval.fromResult + >> Eval.map + (\bound -> + MalApply + { frameId = frameId + , bound = bound + , body = body + } + ) + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False + , meta = Nothing + } + + go bindsList body = + extractAndParse bindsList + |> Eval.fromResult + -- reference the current frame. + |> Eval.ignore (Eval.modifyEnv Env.ref) + |> Eval.andThen + (\binder -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +evalQuote : List MalExpr -> Eval MalExpr +evalQuote args = + case args of + [ expr ] -> + Eval.succeed expr + + _ -> + Eval.fail "unsupported arguments" + + +evalQuasiQuote : MalExpr -> MalExpr +evalQuasiQuote expr = + let + qq_loop : MalExpr -> MalExpr -> MalExpr + qq_loop elt acc = + case elt of + (MalList [MalSymbol "splice-unquote", form]) -> + MalList <| [MalSymbol "concat", form, acc ] + _ -> + MalList <| [MalSymbol "cons", evalQuasiQuote elt, acc ] + in + case expr of + (MalList [MalSymbol "unquote", form]) -> + form + (MalList xs) -> + List.foldr qq_loop (MalList []) xs + (MalVector xs) -> + MalList <| (\x -> [MalSymbol "vec", x]) <| Array.foldr qq_loop (MalList []) xs + (MalSymbol _) -> + MalList <| [MalSymbol "quote", expr] + (MalMap _) -> + MalList <| [MalSymbol "quote", expr] + _ -> + expr + + +print : Env -> MalExpr -> String +print env = + printString env True + + +printError : Env -> MalExpr -> String +printError env expr = + "Error: " ++ (printString env False expr) + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just diff --git a/impls/elm/step8_macros.elm b/impls/elm/step8_macros.elm index 5167642bb4..0703d6d94e 100644 --- a/impls/elm/step8_macros.elm +++ b/impls/elm/step8_macros.elm @@ -1,712 +1,712 @@ -port module Main exposing (..) - -import Array -import Dict exposing (Dict) -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (..) -import Reader exposing (readString) -import Printer exposing (printString) -import Utils exposing (maybeToList, zip, last, justValues, makeCall) -import Env -import Core -import Eval - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = - \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Args = - List String - - -type alias Flags = - { args : Args - } - - -type Model - = InitIO Args Env (IO -> Eval MalExpr) - | ScriptIO Env (IO -> Eval MalExpr) - | ReplActive Env - | ReplIO Env (IO -> Eval MalExpr) - | Stopped - - -init : Flags -> ( Model, Cmd Msg ) -init { args } = - let - makeFn = - CoreFunc >> MalFunction - - initEnv = - Core.ns - |> Env.set "eval" (makeFn malEval) - |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) - - evalMalInit = - malInit - |> List.map rep - |> justValues - |> List.foldl - (\b a -> a |> Eval.andThen (\_ -> b)) - (Eval.succeed MalNil) - in - runInit args initEnv evalMalInit - - -malInit : List String -malInit = - [ """(def! not - (fn* (a) - (if a false true)))""" - , """(def! load-file - (fn* (f) - (eval (read-string - (str "(do " (slurp f) "\nnil)")))))""" - , """(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)))))))""" - ] - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case model of - Stopped -> - ( model, Cmd.none ) - - InitIO args env cont -> - case msg of - Input (Ok io) -> - runInit args env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ScriptIO env cont -> - case msg of - Input (Ok io) -> - runScriptLoop env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ReplActive env -> - case msg of - Input (Ok (LineRead (Just line))) -> - case rep line of - Just expr -> - run env expr - - Nothing -> - ( model, readLine prompt ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - -- Ctrl+D = The End. - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg - - ReplIO env cont -> - case msg of - Input (Ok io) -> - run env (cont io) - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runInit args env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - -- Init went okay. - case args of - -- If we got no args: start REPL. - [] -> - ( ReplActive env, readLine prompt ) - - -- Run the script in the first argument. - -- Put the rest of the arguments as *ARGV*. - filename :: argv -> - runScript filename argv env - - ( env, EvalErr msg ) -> - -- Init failed, don't start REPL. - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - -- IO in init. - ( InitIO args env cont, cmd ) - - -runScript : String -> List String -> Env -> ( Model, Cmd Msg ) -runScript filename argv env = - let - malArgv = - MalList (List.map MalString argv) - - newEnv = - env |> Env.set "*ARGV*" malArgv - - program = - MalList - [ MalSymbol "load-file" - , MalString filename - ] - in - runScriptLoop newEnv (eval program) - - -runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runScriptLoop env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( Stopped, Cmd.none ) - - ( env, EvalErr msg ) -> - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ScriptIO env cont, cmd ) - - -run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -run env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print env expr) ) - - ( env, EvalErr msg ) -> - ( ReplActive env, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ReplIO env cont, cmd ) - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -debug : String -> (Env -> a) -> Eval b -> Eval b -debug msg f e = - Eval.withEnv - (\env -> - Env.debug env msg (f env) - |> always e - ) - - -eval : MalExpr -> Eval MalExpr -eval ast = - let - apply expr env = - case expr of - MalApply app -> - Left - (debug "evalApply" - (\env -> printString env True expr) - (evalApply app) - ) - - _ -> - Right expr - in - evalNoApply ast - |> Eval.andThen (Eval.runLoop apply) - - -malEval : List MalExpr -> Eval MalExpr -malEval args = - case args of - [ expr ] -> - Eval.inGlobal (eval expr) - - _ -> - Eval.fail "unsupported arguments" - - -evalApply : ApplyRec -> Eval MalExpr -evalApply { frameId, bound, body } = - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.enter frameId bound) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.leave - |> Eval.gcPass - ) - - -evalNoApply : MalExpr -> Eval MalExpr -evalNoApply ast = - debug "evalNoApply" - (\env -> printString env True ast) - (macroexpand ast - |> Eval.andThen - (\ast -> - case ast of - MalList [] -> - Eval.succeed ast - - MalList ((MalSymbol "def!") :: args) -> - evalDef args - - MalList ((MalSymbol "let*") :: args) -> - evalLet args - - MalList ((MalSymbol "do") :: args) -> - evalDo args - - MalList ((MalSymbol "if") :: args) -> - evalIf args - - MalList ((MalSymbol "fn*") :: args) -> - evalFn args - - MalList ((MalSymbol "quote") :: args) -> - evalQuote args - - MalList [MalSymbol "quasiquoteexpand", expr] -> - Eval.succeed <| evalQuasiQuote expr - MalList (MalSymbol "quasiquoteexpand" :: _) -> - Eval.fail "quasiquoteexpand: arg count" - - MalList ((MalSymbol "quasiquote") :: args) -> - case args of - [ expr ] -> - -- TCO. - evalNoApply (evalQuasiQuote expr) - - _ -> - Eval.fail "unsupported arguments" - - MalList ((MalSymbol "defmacro!") :: args) -> - evalDefMacro args - - MalList ((MalSymbol "macroexpand") :: args) -> - case args of - [ expr ] -> - macroexpand expr - - _ -> - Eval.fail "unsupported arguments" - - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" - - (MalFunction (CoreFunc fn)) :: args -> - fn args - - (MalFunction (UserFunc { lazyFn })) :: args -> - lazyFn args - - fn :: _ -> - Eval.withEnv - (\env -> - Eval.fail ((printString env True fn) ++ " is not a function") - ) - ) - - _ -> - evalAst ast - ) - ) - - -evalAst : MalExpr -> Eval MalExpr -evalAst ast = - case ast of - MalSymbol sym -> - -- Lookup symbol in env and return value or raise error if not found. - Eval.withEnv (Env.get sym >> Eval.fromResult) - - MalList list -> - -- Return new list that is result of calling eval on each element of list. - evalList list - |> Eval.map MalList - - MalVector vec -> - evalList (Array.toList vec) - |> Eval.map (Array.fromList >> MalVector) - - MalMap map -> - evalList (Dict.values map) - |> Eval.map - (zip (Dict.keys map) - >> Dict.fromList - >> MalMap - ) - - _ -> - Eval.succeed ast - - -evalList : List MalExpr -> Eval (List MalExpr) -evalList list = - let - go list acc = - case list of - [] -> - Eval.succeed (List.reverse acc) - - x :: rest -> - eval x - |> Eval.andThen - (\val -> - go rest (val :: acc) - ) - in - go list [] - - -evalDef : List MalExpr -> Eval MalExpr -evalDef args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen (\_ -> Eval.succeed value) - ) - - _ -> - Eval.fail "def! expected two args: name and value" - - -evalDefMacro : List MalExpr -> Eval MalExpr -evalDefMacro args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - case value of - MalFunction (UserFunc fn) -> - let - macroFn = - MalFunction (UserFunc { fn | isMacro = True }) - in - Eval.modifyEnv (Env.set name macroFn) - |> Eval.andThen (\_ -> Eval.succeed macroFn) - - _ -> - Eval.fail "defmacro! is only supported on a user function" - ) - - _ -> - Eval.fail "defmacro! expected two args: name and value" - - -evalLet : List MalExpr -> Eval MalExpr -evalLet args = - let - evalBinds binds = - case binds of - (MalSymbol name) :: expr :: rest -> - eval expr - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen - (\_ -> - if List.isEmpty rest then - Eval.succeed () - else - evalBinds rest - ) - ) - - _ -> - Eval.fail "let* expected an even number of binds (symbol expr ..)" - - go binds body = - Eval.modifyEnv Env.push - |> Eval.andThen (\_ -> evalBinds binds) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.pop - in - case args of - [ MalList binds, body ] -> - go binds body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "let* expected two args: binds and a body" - - -evalDo : List MalExpr -> Eval MalExpr -evalDo args = - case List.reverse args of - last :: rest -> - evalList (List.reverse rest) - |> Eval.andThen (\_ -> evalNoApply last) - - [] -> - Eval.fail "do expected at least one arg" - - -evalIf : List MalExpr -> Eval MalExpr -evalIf args = - let - isThruthy expr = - expr /= MalNil && expr /= (MalBool False) - - go condition trueExpr falseExpr = - eval condition - |> Eval.map isThruthy - |> Eval.andThen - (\cond -> - evalNoApply - (if cond then - trueExpr - else - falseExpr - ) - ) - in - case args of - [ condition, trueExpr ] -> - go condition trueExpr MalNil - - [ condition, trueExpr, falseExpr ] -> - go condition trueExpr falseExpr - - _ -> - Eval.fail "if expected at least two args" - - -evalFn : List MalExpr -> Eval MalExpr -evalFn args = - let - {- Extract symbols from the binds list and verify their uniqueness -} - extractSymbols acc list = - case list of - [] -> - Ok (List.reverse acc) - - (MalSymbol name) :: rest -> - if List.member name acc then - Err "all binds must have unique names" - else - extractSymbols (name :: acc) rest - - _ -> - Err "all binds in fn* must be a symbol" - - parseBinds list = - case List.reverse list of - var :: "&" :: rest -> - Ok <| bindVarArgs (List.reverse rest) var - - _ -> - if List.member "&" list then - Err "varargs separator '&' is used incorrectly" - else - Ok <| bindArgs list - - extractAndParse = - extractSymbols [] >> Result.andThen parseBinds - - bindArgs binds args = - let - numBinds = - List.length binds - in - if List.length args /= numBinds then - Err <| - "function expected " - ++ (toString numBinds) - ++ " arguments" - else - Ok <| zip binds args - - bindVarArgs binds var args = - let - minArgs = - List.length binds - - varArgs = - MalList (List.drop minArgs args) - in - if List.length args < minArgs then - Err <| - "function expected at least " - ++ (toString minArgs) - ++ " arguments" - else - Ok <| zip binds args ++ [ ( var, varArgs ) ] - - makeFn frameId binder body = - MalFunction <| - let - lazyFn = - binder - >> Eval.fromResult - >> Eval.map - (\bound -> - MalApply - { frameId = frameId - , bound = bound - , body = body - } - ) - in - UserFunc - { frameId = frameId - , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval - , isMacro = False - , meta = Nothing - } - - go bindsList body = - extractAndParse bindsList - |> Eval.fromResult - -- reference the current frame. - |> Eval.ignore (Eval.modifyEnv Env.ref) - |> Eval.andThen - (\binder -> - Eval.withEnv - (\env -> - Eval.succeed - (makeFn env.currentFrameId binder body) - ) - ) - in - case args of - [ MalList bindsList, body ] -> - go bindsList body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "fn* expected two args: binds list and body" - - -evalQuote : List MalExpr -> Eval MalExpr -evalQuote args = - case args of - [ expr ] -> - Eval.succeed expr - - _ -> - Eval.fail "unsupported arguments" - - -evalQuasiQuote : MalExpr -> MalExpr -evalQuasiQuote expr = - let - qq_loop : MalExpr -> MalExpr -> MalExpr - qq_loop elt acc = - case elt of - (MalList [MalSymbol "splice-unquote", form]) -> - MalList <| [MalSymbol "concat", form, acc ] - _ -> - MalList <| [MalSymbol "cons", evalQuasiQuote elt, acc ] - in - case expr of - (MalList [MalSymbol "unquote", form]) -> - form - (MalList xs) -> - List.foldr qq_loop (MalList []) xs - (MalVector xs) -> - MalList <| (\x -> [MalSymbol "vec", x]) <| Array.foldr qq_loop (MalList []) xs - (MalSymbol _) -> - MalList <| [MalSymbol "quote", expr] - (MalMap _) -> - MalList <| [MalSymbol "quote", expr] - _ -> - expr - - -macroexpand : MalExpr -> Eval MalExpr -macroexpand expr = - let - expand expr env = - case expr of - MalList ((MalSymbol name) :: args) -> - case Env.get name env of - Ok (MalFunction (UserFunc fn)) -> - if fn.isMacro then - Left <| fn.eagerFn args - else - Right expr - - _ -> - Right expr - - _ -> - Right expr - in - Eval.runLoop expand expr - - -print : Env -> MalExpr -> String -print env = - printString env True - - -printError : Env -> MalExpr -> String -printError env expr = - "Error: " ++ (printString env False expr) - - -{-| Read-Eval-Print. - -Doesn't actually run the Eval but returns the monad. - --} -rep : String -> Maybe (Eval MalExpr) -rep input = - case readString input of - Ok Nothing -> - Nothing - - Err msg -> - Just (Eval.fail msg) - - Ok (Just ast) -> - eval ast |> Just +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues, makeCall) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Args = + List String + + +type alias Flags = + { args : Args + } + + +type Model + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + | Stopped + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit args initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) "\nnil)")))))""" + , """(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)))))))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + Stopped -> + ( model, Cmd.none ) + + InitIO args env cont -> + case msg of + Input (Ok io) -> + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr env = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + Eval.inGlobal (eval expr) + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.leave + |> Eval.gcPass + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + debug "evalNoApply" + (\env -> printString env True ast) + (macroexpand ast + |> Eval.andThen + (\ast -> + case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList ((MalSymbol "quote") :: args) -> + evalQuote args + + MalList [MalSymbol "quasiquoteexpand", expr] -> + Eval.succeed <| evalQuasiQuote expr + MalList (MalSymbol "quasiquoteexpand" :: _) -> + Eval.fail "quasiquoteexpand: arg count" + + MalList ((MalSymbol "quasiquote") :: args) -> + case args of + [ expr ] -> + -- TCO. + evalNoApply (evalQuasiQuote expr) + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "defmacro!") :: args) -> + evalDefMacro args + + MalList ((MalSymbol "macroexpand") :: args) -> + case args of + [ expr ] -> + macroexpand expr + + _ -> + Eval.fail "unsupported arguments" + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + ) + ) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv (Env.get sym >> Eval.fromResult) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalDefMacro : List MalExpr -> Eval MalExpr +evalDefMacro args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + case value of + MalFunction (UserFunc fn) -> + let + macroFn = + MalFunction (UserFunc { fn | isMacro = True }) + in + Eval.modifyEnv (Env.set name macroFn) + |> Eval.andThen (\_ -> Eval.succeed macroFn) + + _ -> + Eval.fail "defmacro! is only supported on a user function" + ) + + _ -> + Eval.fail "defmacro! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.pop + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn = + binder + >> Eval.fromResult + >> Eval.map + (\bound -> + MalApply + { frameId = frameId + , bound = bound + , body = body + } + ) + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False + , meta = Nothing + } + + go bindsList body = + extractAndParse bindsList + |> Eval.fromResult + -- reference the current frame. + |> Eval.ignore (Eval.modifyEnv Env.ref) + |> Eval.andThen + (\binder -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +evalQuote : List MalExpr -> Eval MalExpr +evalQuote args = + case args of + [ expr ] -> + Eval.succeed expr + + _ -> + Eval.fail "unsupported arguments" + + +evalQuasiQuote : MalExpr -> MalExpr +evalQuasiQuote expr = + let + qq_loop : MalExpr -> MalExpr -> MalExpr + qq_loop elt acc = + case elt of + (MalList [MalSymbol "splice-unquote", form]) -> + MalList <| [MalSymbol "concat", form, acc ] + _ -> + MalList <| [MalSymbol "cons", evalQuasiQuote elt, acc ] + in + case expr of + (MalList [MalSymbol "unquote", form]) -> + form + (MalList xs) -> + List.foldr qq_loop (MalList []) xs + (MalVector xs) -> + MalList <| (\x -> [MalSymbol "vec", x]) <| Array.foldr qq_loop (MalList []) xs + (MalSymbol _) -> + MalList <| [MalSymbol "quote", expr] + (MalMap _) -> + MalList <| [MalSymbol "quote", expr] + _ -> + expr + + +macroexpand : MalExpr -> Eval MalExpr +macroexpand expr = + let + expand expr env = + case expr of + MalList ((MalSymbol name) :: args) -> + case Env.get name env of + Ok (MalFunction (UserFunc fn)) -> + if fn.isMacro then + Left <| fn.eagerFn args + else + Right expr + + _ -> + Right expr + + _ -> + Right expr + in + Eval.runLoop expand expr + + +print : Env -> MalExpr -> String +print env = + printString env True + + +printError : Env -> MalExpr -> String +printError env expr = + "Error: " ++ (printString env False expr) + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just diff --git a/impls/elm/step9_try.elm b/impls/elm/step9_try.elm index 88fe0e7b39..bdbcca6702 100644 --- a/impls/elm/step9_try.elm +++ b/impls/elm/step9_try.elm @@ -1,736 +1,736 @@ -port module Main exposing (..) - -import Array -import Dict exposing (Dict) -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (..) -import Reader exposing (readString) -import Printer exposing (printString) -import Utils exposing (maybeToList, zip, last, justValues, makeCall) -import Env -import Core -import Eval - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = - \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Args = - List String - - -type alias Flags = - { args : Args - } - - -type Model - = InitIO Args Env (IO -> Eval MalExpr) - | ScriptIO Env (IO -> Eval MalExpr) - | ReplActive Env - | ReplIO Env (IO -> Eval MalExpr) - | Stopped - - -init : Flags -> ( Model, Cmd Msg ) -init { args } = - let - makeFn = - CoreFunc >> MalFunction - - initEnv = - Core.ns - |> Env.set "eval" (makeFn malEval) - |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) - - evalMalInit = - malInit - |> List.map rep - |> justValues - |> List.foldl - (\b a -> a |> Eval.andThen (\_ -> b)) - (Eval.succeed MalNil) - in - runInit args initEnv evalMalInit - - -malInit : List String -malInit = - [ """(def! not - (fn* (a) - (if a false true)))""" - , """(def! load-file - (fn* (f) - (eval (read-string - (str "(do " (slurp f) "\nnil)")))))""" - , """(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)))))))""" - ] - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case model of - Stopped -> - ( model, Cmd.none ) - - InitIO args env cont -> - case msg of - Input (Ok io) -> - runInit args env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ScriptIO env cont -> - case msg of - Input (Ok io) -> - runScriptLoop env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ReplActive env -> - case msg of - Input (Ok (LineRead (Just line))) -> - case rep line of - Just expr -> - run env expr - - Nothing -> - ( model, readLine prompt ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - -- Ctrl+D = The End. - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg - - ReplIO env cont -> - case msg of - Input (Ok io) -> - run env (cont io) - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runInit args env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - -- Init went okay. - case args of - -- If we got no args: start REPL. - [] -> - ( ReplActive env, readLine prompt ) - - -- Run the script in the first argument. - -- Put the rest of the arguments as *ARGV*. - filename :: argv -> - runScript filename argv env - - ( env, EvalErr msg ) -> - -- Init failed, don't start REPL. - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - -- IO in init. - ( InitIO args env cont, cmd ) - - -runScript : String -> List String -> Env -> ( Model, Cmd Msg ) -runScript filename argv env = - let - malArgv = - MalList (List.map MalString argv) - - newEnv = - env |> Env.set "*ARGV*" malArgv - - program = - MalList - [ MalSymbol "load-file" - , MalString filename - ] - in - runScriptLoop newEnv (eval program) - - -runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runScriptLoop env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( Stopped, Cmd.none ) - - ( env, EvalErr msg ) -> - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ScriptIO env cont, cmd ) - - -run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -run env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print env expr) ) - - ( env, EvalErr msg ) -> - ( ReplActive env, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ReplIO env cont, cmd ) - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -debug : String -> (Env -> a) -> Eval b -> Eval b -debug msg f e = - Eval.withEnv - (\env -> - Env.debug env msg (f env) - |> always e - ) - - -eval : MalExpr -> Eval MalExpr -eval ast = - let - apply expr env = - case expr of - MalApply app -> - Left - (debug "evalApply" - (\env -> printString env True expr) - (evalApply app) - ) - - _ -> - Right expr - in - evalNoApply ast - |> Eval.andThen (Eval.runLoop apply) - - -malEval : List MalExpr -> Eval MalExpr -malEval args = - case args of - [ expr ] -> - Eval.inGlobal (eval expr) - - _ -> - Eval.fail "unsupported arguments" - - -evalApply : ApplyRec -> Eval MalExpr -evalApply { frameId, bound, body } = - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.enter frameId bound) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.leave - |> Eval.gcPass - ) - - -evalNoApply : MalExpr -> Eval MalExpr -evalNoApply ast = - let - go ast = - case ast of - MalList [] -> - Eval.succeed ast - - MalList ((MalSymbol "def!") :: args) -> - evalDef args - - MalList ((MalSymbol "let*") :: args) -> - evalLet args - - MalList ((MalSymbol "do") :: args) -> - evalDo args - - MalList ((MalSymbol "if") :: args) -> - evalIf args - - MalList ((MalSymbol "fn*") :: args) -> - evalFn args - - MalList ((MalSymbol "quote") :: args) -> - evalQuote args - - MalList [MalSymbol "quasiquoteexpand", expr] -> - Eval.succeed <| evalQuasiQuote expr - MalList (MalSymbol "quasiquoteexpand" :: _) -> - Eval.fail "quasiquoteexpand: arg count" - - MalList ((MalSymbol "quasiquote") :: args) -> - case args of - [ expr ] -> - -- TCO. - evalNoApply (evalQuasiQuote expr) - - _ -> - Eval.fail "unsupported arguments" - - MalList ((MalSymbol "defmacro!") :: args) -> - evalDefMacro args - - MalList ((MalSymbol "macroexpand") :: args) -> - case args of - [ expr ] -> - macroexpand expr - - _ -> - Eval.fail "unsupported arguments" - - MalList ((MalSymbol "try*") :: args) -> - evalTry args - - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" - - (MalFunction (CoreFunc fn)) :: args -> - fn args - - (MalFunction (UserFunc { lazyFn })) :: args -> - lazyFn args - - fn :: _ -> - Eval.withEnv - (\env -> - Eval.fail ((printString env True fn) ++ " is not a function") - ) - ) - - _ -> - evalAst ast - in - debug "evalNoApply" - (\env -> printString env True ast) - (macroexpand ast |> Eval.andThen go) - - -evalAst : MalExpr -> Eval MalExpr -evalAst ast = - case ast of - MalSymbol sym -> - -- Lookup symbol in env and return value or raise error if not found. - Eval.withEnv (Env.get sym >> Eval.fromResult) - - MalList list -> - -- Return new list that is result of calling eval on each element of list. - evalList list - |> Eval.map MalList - - MalVector vec -> - evalList (Array.toList vec) - |> Eval.map (Array.fromList >> MalVector) - - MalMap map -> - evalList (Dict.values map) - |> Eval.map - (zip (Dict.keys map) - >> Dict.fromList - >> MalMap - ) - - _ -> - Eval.succeed ast - - -evalList : List MalExpr -> Eval (List MalExpr) -evalList list = - let - go list acc = - case list of - [] -> - Eval.succeed (List.reverse acc) - - x :: rest -> - eval x - |> Eval.andThen - (\val -> - go rest (val :: acc) - ) - in - go list [] - - -evalDef : List MalExpr -> Eval MalExpr -evalDef args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen (\_ -> Eval.succeed value) - ) - - _ -> - Eval.fail "def! expected two args: name and value" - - -evalDefMacro : List MalExpr -> Eval MalExpr -evalDefMacro args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - case value of - MalFunction (UserFunc fn) -> - let - macroFn = - MalFunction (UserFunc { fn | isMacro = True }) - in - Eval.modifyEnv (Env.set name macroFn) - |> Eval.andThen (\_ -> Eval.succeed macroFn) - - _ -> - Eval.fail "defmacro! is only supported on a user function" - ) - - _ -> - Eval.fail "defmacro! expected two args: name and value" - - -evalLet : List MalExpr -> Eval MalExpr -evalLet args = - let - evalBinds binds = - case binds of - (MalSymbol name) :: expr :: rest -> - eval expr - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen - (\_ -> - if List.isEmpty rest then - Eval.succeed () - else - evalBinds rest - ) - ) - - _ -> - Eval.fail "let* expected an even number of binds (symbol expr ..)" - - go binds body = - Eval.modifyEnv Env.push - |> Eval.andThen (\_ -> evalBinds binds) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.pop - in - case args of - [ MalList binds, body ] -> - go binds body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "let* expected two args: binds and a body" - - -evalDo : List MalExpr -> Eval MalExpr -evalDo args = - case List.reverse args of - last :: rest -> - evalList (List.reverse rest) - |> Eval.andThen (\_ -> evalNoApply last) - - [] -> - Eval.fail "do expected at least one arg" - - -evalIf : List MalExpr -> Eval MalExpr -evalIf args = - let - isThruthy expr = - expr /= MalNil && expr /= (MalBool False) - - go condition trueExpr falseExpr = - eval condition - |> Eval.map isThruthy - |> Eval.andThen - (\cond -> - evalNoApply - (if cond then - trueExpr - else - falseExpr - ) - ) - in - case args of - [ condition, trueExpr ] -> - go condition trueExpr MalNil - - [ condition, trueExpr, falseExpr ] -> - go condition trueExpr falseExpr - - _ -> - Eval.fail "if expected at least two args" - - -evalFn : List MalExpr -> Eval MalExpr -evalFn args = - let - {- Extract symbols from the binds list and verify their uniqueness -} - extractSymbols acc list = - case list of - [] -> - Ok (List.reverse acc) - - (MalSymbol name) :: rest -> - if List.member name acc then - Err "all binds must have unique names" - else - extractSymbols (name :: acc) rest - - _ -> - Err "all binds in fn* must be a symbol" - - parseBinds list = - case List.reverse list of - var :: "&" :: rest -> - Ok <| bindVarArgs (List.reverse rest) var - - _ -> - if List.member "&" list then - Err "varargs separator '&' is used incorrectly" - else - Ok <| bindArgs list - - extractAndParse = - extractSymbols [] >> Result.andThen parseBinds - - bindArgs binds args = - let - numBinds = - List.length binds - in - if List.length args /= numBinds then - Err <| - "function expected " - ++ (toString numBinds) - ++ " arguments" - else - Ok <| zip binds args - - bindVarArgs binds var args = - let - minArgs = - List.length binds - - varArgs = - MalList (List.drop minArgs args) - in - if List.length args < minArgs then - Err <| - "function expected at least " - ++ (toString minArgs) - ++ " arguments" - else - Ok <| zip binds args ++ [ ( var, varArgs ) ] - - makeFn frameId binder body = - MalFunction <| - let - lazyFn = - binder - >> Eval.fromResult - >> Eval.map - (\bound -> - MalApply - { frameId = frameId - , bound = bound - , body = body - } - ) - in - UserFunc - { frameId = frameId - , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval - , isMacro = False - , meta = Nothing - } - - go bindsList body = - extractAndParse bindsList - |> Eval.fromResult - -- reference the current frame. - |> Eval.ignore (Eval.modifyEnv Env.ref) - |> Eval.andThen - (\binder -> - Eval.withEnv - (\env -> - Eval.succeed - (makeFn env.currentFrameId binder body) - ) - ) - in - case args of - [ MalList bindsList, body ] -> - go bindsList body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "fn* expected two args: binds list and body" - - -evalQuote : List MalExpr -> Eval MalExpr -evalQuote args = - case args of - [ expr ] -> - Eval.succeed expr - - _ -> - Eval.fail "unsupported arguments" - - -evalQuasiQuote : MalExpr -> MalExpr -evalQuasiQuote expr = - let - qq_loop : MalExpr -> MalExpr -> MalExpr - qq_loop elt acc = - case elt of - (MalList [MalSymbol "splice-unquote", form]) -> - MalList <| [MalSymbol "concat", form, acc ] - _ -> - MalList <| [MalSymbol "cons", evalQuasiQuote elt, acc ] - in - case expr of - (MalList [MalSymbol "unquote", form]) -> - form - (MalList xs) -> - List.foldr qq_loop (MalList []) xs - (MalVector xs) -> - MalList <| (\x -> [MalSymbol "vec", x]) <| Array.foldr qq_loop (MalList []) xs - (MalSymbol _) -> - MalList <| [MalSymbol "quote", expr] - (MalMap _) -> - MalList <| [MalSymbol "quote", expr] - _ -> - expr - - -macroexpand : MalExpr -> Eval MalExpr -macroexpand expr = - let - expand expr env = - case expr of - MalList ((MalSymbol name) :: args) -> - case Env.get name env of - Ok (MalFunction (UserFunc fn)) -> - if fn.isMacro then - Left <| fn.eagerFn args - else - Right expr - - _ -> - Right expr - - _ -> - Right expr - in - Eval.runLoop expand expr - - -evalTry : List MalExpr -> Eval MalExpr -evalTry args = - case args of - [ body ] -> - eval body - [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] -> - eval body - |> Eval.catchError - (\ex -> - Eval.modifyEnv Env.push - |> Eval.andThen - (\_ -> - Eval.modifyEnv (Env.set sym ex) - ) - |> Eval.andThen (\_ -> eval handler) - |> Eval.finally Env.pop - ) - - _ -> - Eval.fail "try* expected a body a catch block" - - -print : Env -> MalExpr -> String -print env = - printString env True - - -printError : Env -> MalExpr -> String -printError env expr = - "Error: " ++ (printString env False expr) - - -{-| Read-Eval-Print. - -Doesn't actually run the Eval but returns the monad. - --} -rep : String -> Maybe (Eval MalExpr) -rep input = - case readString input of - Ok Nothing -> - Nothing - - Err msg -> - Just (Eval.fail msg) - - Ok (Just ast) -> - eval ast |> Just +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues, makeCall) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Args = + List String + + +type alias Flags = + { args : Args + } + + +type Model + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + | Stopped + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit args initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) "\nnil)")))))""" + , """(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)))))))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + Stopped -> + ( model, Cmd.none ) + + InitIO args env cont -> + case msg of + Input (Ok io) -> + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr env = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + Eval.inGlobal (eval expr) + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.leave + |> Eval.gcPass + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + let + go ast = + case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList ((MalSymbol "quote") :: args) -> + evalQuote args + + MalList [MalSymbol "quasiquoteexpand", expr] -> + Eval.succeed <| evalQuasiQuote expr + MalList (MalSymbol "quasiquoteexpand" :: _) -> + Eval.fail "quasiquoteexpand: arg count" + + MalList ((MalSymbol "quasiquote") :: args) -> + case args of + [ expr ] -> + -- TCO. + evalNoApply (evalQuasiQuote expr) + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "defmacro!") :: args) -> + evalDefMacro args + + MalList ((MalSymbol "macroexpand") :: args) -> + case args of + [ expr ] -> + macroexpand expr + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "try*") :: args) -> + evalTry args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + in + debug "evalNoApply" + (\env -> printString env True ast) + (macroexpand ast |> Eval.andThen go) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv (Env.get sym >> Eval.fromResult) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + go rest (val :: acc) + ) + in + go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalDefMacro : List MalExpr -> Eval MalExpr +evalDefMacro args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + case value of + MalFunction (UserFunc fn) -> + let + macroFn = + MalFunction (UserFunc { fn | isMacro = True }) + in + Eval.modifyEnv (Env.set name macroFn) + |> Eval.andThen (\_ -> Eval.succeed macroFn) + + _ -> + Eval.fail "defmacro! is only supported on a user function" + ) + + _ -> + Eval.fail "defmacro! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.pop + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn = + binder + >> Eval.fromResult + >> Eval.map + (\bound -> + MalApply + { frameId = frameId + , bound = bound + , body = body + } + ) + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False + , meta = Nothing + } + + go bindsList body = + extractAndParse bindsList + |> Eval.fromResult + -- reference the current frame. + |> Eval.ignore (Eval.modifyEnv Env.ref) + |> Eval.andThen + (\binder -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +evalQuote : List MalExpr -> Eval MalExpr +evalQuote args = + case args of + [ expr ] -> + Eval.succeed expr + + _ -> + Eval.fail "unsupported arguments" + + +evalQuasiQuote : MalExpr -> MalExpr +evalQuasiQuote expr = + let + qq_loop : MalExpr -> MalExpr -> MalExpr + qq_loop elt acc = + case elt of + (MalList [MalSymbol "splice-unquote", form]) -> + MalList <| [MalSymbol "concat", form, acc ] + _ -> + MalList <| [MalSymbol "cons", evalQuasiQuote elt, acc ] + in + case expr of + (MalList [MalSymbol "unquote", form]) -> + form + (MalList xs) -> + List.foldr qq_loop (MalList []) xs + (MalVector xs) -> + MalList <| (\x -> [MalSymbol "vec", x]) <| Array.foldr qq_loop (MalList []) xs + (MalSymbol _) -> + MalList <| [MalSymbol "quote", expr] + (MalMap _) -> + MalList <| [MalSymbol "quote", expr] + _ -> + expr + + +macroexpand : MalExpr -> Eval MalExpr +macroexpand expr = + let + expand expr env = + case expr of + MalList ((MalSymbol name) :: args) -> + case Env.get name env of + Ok (MalFunction (UserFunc fn)) -> + if fn.isMacro then + Left <| fn.eagerFn args + else + Right expr + + _ -> + Right expr + + _ -> + Right expr + in + Eval.runLoop expand expr + + +evalTry : List MalExpr -> Eval MalExpr +evalTry args = + case args of + [ body ] -> + eval body + [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] -> + eval body + |> Eval.catchError + (\ex -> + Eval.modifyEnv Env.push + |> Eval.andThen + (\_ -> + Eval.modifyEnv (Env.set sym ex) + ) + |> Eval.andThen (\_ -> eval handler) + |> Eval.finally Env.pop + ) + + _ -> + Eval.fail "try* expected a body a catch block" + + +print : Env -> MalExpr -> String +print env = + printString env True + + +printError : Env -> MalExpr -> String +printError env expr = + "Error: " ++ (printString env False expr) + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just diff --git a/impls/elm/stepA_mal.elm b/impls/elm/stepA_mal.elm index 7a436eed63..5a0514e923 100644 --- a/impls/elm/stepA_mal.elm +++ b/impls/elm/stepA_mal.elm @@ -1,743 +1,743 @@ -port module Main exposing (..) - -import Array -import Dict exposing (Dict) -import IO exposing (..) -import Json.Decode exposing (decodeValue) -import Platform exposing (programWithFlags) -import Types exposing (..) -import Reader exposing (readString) -import Printer exposing (printString) -import Utils exposing (maybeToList, zip, last, justValues, makeCall) -import Env -import Core -import Eval - - -main : Program Flags Model Msg -main = - programWithFlags - { init = init - , update = update - , subscriptions = - \model -> input (decodeValue decodeIO >> Input) - } - - -type alias Args = - List String - - -type alias Flags = - { args : Args - } - - -type Model - = InitIO Args Env (IO -> Eval MalExpr) - | ScriptIO Env (IO -> Eval MalExpr) - | ReplActive Env - | ReplIO Env (IO -> Eval MalExpr) - | Stopped - - -init : Flags -> ( Model, Cmd Msg ) -init { args } = - let - makeFn = - CoreFunc >> MalFunction - - initEnv = - Core.ns - |> Env.set "eval" (makeFn malEval) - |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) - |> Env.set "*host-language*" (MalString "elm") - - evalMalInit = - malInit - |> List.map rep - |> justValues - |> List.foldl - (\b a -> a |> Eval.andThen (\_ -> b)) - (Eval.succeed MalNil) - in - runInit args initEnv evalMalInit - - -malInit : List String -malInit = - [ """(def! not - (fn* (a) - (if a false true)))""" - , """(def! load-file - (fn* (f) - (eval (read-string - (str "(do " (slurp f) "\nnil)")))))""" - , """(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)))))))""" - ] - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case model of - Stopped -> - ( model, Cmd.none ) - - InitIO args env cont -> - case msg of - Input (Ok io) -> - runInit args env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ScriptIO env cont -> - case msg of - Input (Ok io) -> - runScriptLoop env (cont io) - - Input (Err msg) -> - Debug.crash msg - - ReplActive env -> - case msg of - Input (Ok (LineRead (Just line))) -> - case rep line of - Just expr -> - run env expr - - Nothing -> - ( model, readLine prompt ) - - Input (Ok LineWritten) -> - ( model, readLine prompt ) - - Input (Ok (LineRead Nothing)) -> - -- Ctrl+D = The End. - ( model, Cmd.none ) - - Input (Ok io) -> - Debug.crash "unexpected IO received: " io - - Input (Err msg) -> - Debug.crash msg - - ReplIO env cont -> - case msg of - Input (Ok io) -> - run env (cont io) - - Input (Err msg) -> - Debug.crash msg ( model, Cmd.none ) - - -runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runInit args env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - -- Init went okay. - case args of - -- If we got no args: start REPL. - [] -> - ( ReplActive env, readLine prompt ) - - -- Run the script in the first argument. - -- Put the rest of the arguments as *ARGV*. - filename :: argv -> - runScript filename argv env - - ( env, EvalErr msg ) -> - -- Init failed, don't start REPL. - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - -- IO in init. - ( InitIO args env cont, cmd ) - - -runScript : String -> List String -> Env -> ( Model, Cmd Msg ) -runScript filename argv env = - let - malArgv = - MalList (List.map MalString argv) - - newEnv = - env |> Env.set "*ARGV*" malArgv - - program = - MalList - [ MalSymbol "load-file" - , MalString filename - ] - in - runScriptLoop newEnv (eval program) - - -runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -runScriptLoop env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( Stopped, Cmd.none ) - - ( env, EvalErr msg ) -> - ( Stopped, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ScriptIO env cont, cmd ) - - -run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) -run env expr = - case Eval.run env expr of - ( env, EvalOk expr ) -> - ( ReplActive env, writeLine (print env expr) ) - - ( env, EvalErr msg ) -> - ( ReplActive env, writeLine (printError env msg) ) - - ( env, EvalIO cmd cont ) -> - ( ReplIO env cont, cmd ) - - -prompt : String -prompt = - "user> " - - -{-| read can return three things: - -Ok (Just expr) -> parsed okay -Ok Nothing -> empty string (only whitespace and/or comments) -Err msg -> parse error - --} -read : String -> Result String (Maybe MalExpr) -read = - readString - - -debug : String -> (Env -> a) -> Eval b -> Eval b -debug msg f e = - Eval.withEnv - (\env -> - Env.debug env msg (f env) - |> always e - ) - - -eval : MalExpr -> Eval MalExpr -eval ast = - let - apply expr env = - case expr of - MalApply app -> - Left - (debug "evalApply" - (\env -> printString env True expr) - (evalApply app) - ) - - _ -> - Right expr - in - evalNoApply ast - |> Eval.andThen (Eval.runLoop apply) - |> Eval.gcPass - - -malEval : List MalExpr -> Eval MalExpr -malEval args = - case args of - [ expr ] -> - Eval.inGlobal (eval expr) - - _ -> - Eval.fail "unsupported arguments" - - -evalApply : ApplyRec -> Eval MalExpr -evalApply { frameId, bound, body } = - Eval.withEnv - (\env -> - Eval.modifyEnv (Env.enter frameId bound) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.leave - |> Eval.gcPass - ) - - -evalNoApply : MalExpr -> Eval MalExpr -evalNoApply ast = - let - go ast = - case ast of - MalList [] -> - Eval.succeed ast - - MalList ((MalSymbol "def!") :: args) -> - evalDef args - - MalList ((MalSymbol "let*") :: args) -> - evalLet args - - MalList ((MalSymbol "do") :: args) -> - evalDo args - - MalList ((MalSymbol "if") :: args) -> - evalIf args - - MalList ((MalSymbol "fn*") :: args) -> - evalFn args - - MalList ((MalSymbol "quote") :: args) -> - evalQuote args - - MalList [MalSymbol "quasiquoteexpand", expr] -> - Eval.succeed <| evalQuasiQuote expr - MalList (MalSymbol "quasiquoteexpand" :: _) -> - Eval.fail "quasiquoteexpand: arg count" - - MalList ((MalSymbol "quasiquote") :: args) -> - case args of - [ expr ] -> - -- TCO. - evalNoApply (evalQuasiQuote expr) - - _ -> - Eval.fail "unsupported arguments" - - MalList ((MalSymbol "defmacro!") :: args) -> - evalDefMacro args - - MalList ((MalSymbol "macroexpand") :: args) -> - case args of - [ expr ] -> - macroexpand expr - - _ -> - Eval.fail "unsupported arguments" - - MalList ((MalSymbol "try*") :: args) -> - evalTry args - - MalList list -> - evalList list - |> Eval.andThen - (\newList -> - case newList of - [] -> - Eval.fail "can't happen" - - (MalFunction (CoreFunc fn)) :: args -> - fn args - - (MalFunction (UserFunc { lazyFn })) :: args -> - lazyFn args - - fn :: _ -> - Eval.withEnv - (\env -> - Eval.fail ((printString env True fn) ++ " is not a function") - ) - ) - - _ -> - evalAst ast - in - macroexpand ast - |> Eval.andThen go - |> Eval.andThen - (\res -> - debug "evalNoApply" - (\env -> (printString env True ast) ++ " = " ++ (printString env True res)) - (Eval.succeed res) - ) - - -evalAst : MalExpr -> Eval MalExpr -evalAst ast = - case ast of - MalSymbol sym -> - -- Lookup symbol in env and return value or raise error if not found. - Eval.withEnv (Env.get sym >> Eval.fromResult) - - MalList list -> - -- Return new list that is result of calling eval on each element of list. - evalList list - |> Eval.map MalList - - MalVector vec -> - evalList (Array.toList vec) - |> Eval.map (Array.fromList >> MalVector) - - MalMap map -> - evalList (Dict.values map) - |> Eval.map - (zip (Dict.keys map) - >> Dict.fromList - >> MalMap - ) - - _ -> - Eval.succeed ast - - -evalList : List MalExpr -> Eval (List MalExpr) -evalList list = - let - go list acc = - case list of - [] -> - Eval.succeed (List.reverse acc) - - x :: rest -> - eval x - |> Eval.andThen - (\val -> - Eval.pushRef val <| go rest (val :: acc) - ) - in - Eval.withStack <| go list [] - - -evalDef : List MalExpr -> Eval MalExpr -evalDef args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen (\_ -> Eval.succeed value) - ) - - _ -> - Eval.fail "def! expected two args: name and value" - - -evalDefMacro : List MalExpr -> Eval MalExpr -evalDefMacro args = - case args of - [ MalSymbol name, uneValue ] -> - eval uneValue - |> Eval.andThen - (\value -> - case value of - MalFunction (UserFunc fn) -> - let - macroFn = - MalFunction (UserFunc { fn | isMacro = True }) - in - Eval.modifyEnv (Env.set name macroFn) - |> Eval.andThen (\_ -> Eval.succeed macroFn) - - _ -> - Eval.fail "defmacro! is only supported on a user function" - ) - - _ -> - Eval.fail "defmacro! expected two args: name and value" - - -evalLet : List MalExpr -> Eval MalExpr -evalLet args = - let - evalBinds binds = - case binds of - (MalSymbol name) :: expr :: rest -> - eval expr - |> Eval.andThen - (\value -> - Eval.modifyEnv (Env.set name value) - |> Eval.andThen - (\_ -> - if List.isEmpty rest then - Eval.succeed () - else - evalBinds rest - ) - ) - - _ -> - Eval.fail "let* expected an even number of binds (symbol expr ..)" - - go binds body = - Eval.modifyEnv Env.push - |> Eval.andThen (\_ -> evalBinds binds) - |> Eval.andThen (\_ -> evalNoApply body) - |> Eval.finally Env.pop - in - case args of - [ MalList binds, body ] -> - go binds body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "let* expected two args: binds and a body" - - -evalDo : List MalExpr -> Eval MalExpr -evalDo args = - case List.reverse args of - last :: rest -> - evalList (List.reverse rest) - |> Eval.andThen (\_ -> evalNoApply last) - - [] -> - Eval.fail "do expected at least one arg" - - -evalIf : List MalExpr -> Eval MalExpr -evalIf args = - let - isThruthy expr = - expr /= MalNil && expr /= (MalBool False) - - go condition trueExpr falseExpr = - eval condition - |> Eval.map isThruthy - |> Eval.andThen - (\cond -> - evalNoApply - (if cond then - trueExpr - else - falseExpr - ) - ) - in - case args of - [ condition, trueExpr ] -> - go condition trueExpr MalNil - - [ condition, trueExpr, falseExpr ] -> - go condition trueExpr falseExpr - - _ -> - Eval.fail "if expected at least two args" - - -evalFn : List MalExpr -> Eval MalExpr -evalFn args = - let - {- Extract symbols from the binds list and verify their uniqueness -} - extractSymbols acc list = - case list of - [] -> - Ok (List.reverse acc) - - (MalSymbol name) :: rest -> - if List.member name acc then - Err "all binds must have unique names" - else - extractSymbols (name :: acc) rest - - _ -> - Err "all binds in fn* must be a symbol" - - parseBinds list = - case List.reverse list of - var :: "&" :: rest -> - Ok <| bindVarArgs (List.reverse rest) var - - _ -> - if List.member "&" list then - Err "varargs separator '&' is used incorrectly" - else - Ok <| bindArgs list - - extractAndParse = - extractSymbols [] >> Result.andThen parseBinds - - bindArgs binds args = - let - numBinds = - List.length binds - in - if List.length args /= numBinds then - Err <| - "function expected " - ++ (toString numBinds) - ++ " arguments" - else - Ok <| zip binds args - - bindVarArgs binds var args = - let - minArgs = - List.length binds - - varArgs = - MalList (List.drop minArgs args) - in - if List.length args < minArgs then - Err <| - "function expected at least " - ++ (toString minArgs) - ++ " arguments" - else - Ok <| zip binds args ++ [ ( var, varArgs ) ] - - makeFn frameId binder body = - MalFunction <| - let - lazyFn = - binder - >> Eval.fromResult - >> Eval.map - (\bound -> - MalApply - { frameId = frameId - , bound = bound - , body = body - } - ) - in - UserFunc - { frameId = frameId - , lazyFn = lazyFn - , eagerFn = lazyFn >> Eval.andThen eval - , isMacro = False - , meta = Nothing - } - - go bindsList body = - extractAndParse bindsList - |> Eval.fromResult - -- reference the current frame. - |> Eval.ignore (Eval.modifyEnv Env.ref) - |> Eval.andThen - (\binder -> - Eval.withEnv - (\env -> - Eval.succeed - (makeFn env.currentFrameId binder body) - ) - ) - in - case args of - [ MalList bindsList, body ] -> - go bindsList body - - [ MalVector bindsVec, body ] -> - go (Array.toList bindsVec) body - - _ -> - Eval.fail "fn* expected two args: binds list and body" - - -evalQuote : List MalExpr -> Eval MalExpr -evalQuote args = - case args of - [ expr ] -> - Eval.succeed expr - - _ -> - Eval.fail "unsupported arguments" - - -evalQuasiQuote : MalExpr -> MalExpr -evalQuasiQuote expr = - let - qq_loop : MalExpr -> MalExpr -> MalExpr - qq_loop elt acc = - case elt of - (MalList [MalSymbol "splice-unquote", form]) -> - MalList <| [MalSymbol "concat", form, acc ] - _ -> - MalList <| [MalSymbol "cons", evalQuasiQuote elt, acc ] - in - case expr of - (MalList [MalSymbol "unquote", form]) -> - form - (MalList xs) -> - List.foldr qq_loop (MalList []) xs - (MalVector xs) -> - MalList <| (\x -> [MalSymbol "vec", x]) <| Array.foldr qq_loop (MalList []) xs - (MalSymbol _) -> - MalList <| [MalSymbol "quote", expr] - (MalMap _) -> - MalList <| [MalSymbol "quote", expr] - _ -> - expr - - -macroexpand : MalExpr -> Eval MalExpr -macroexpand expr = - let - expand expr env = - case expr of - MalList ((MalSymbol name) :: args) -> - case Env.get name env of - Ok (MalFunction (UserFunc fn)) -> - if fn.isMacro then - Left <| fn.eagerFn args - else - Right expr - - _ -> - Right expr - - _ -> - Right expr - in - Eval.runLoop expand expr - - -evalTry : List MalExpr -> Eval MalExpr -evalTry args = - case args of - [ body ] -> - eval body - [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] -> - eval body - |> Eval.catchError - (\ex -> - Eval.modifyEnv Env.push - |> Eval.andThen - (\_ -> - Eval.modifyEnv (Env.set sym ex) - ) - |> Eval.andThen (\_ -> eval handler) - |> Eval.finally Env.pop - ) - - _ -> - Eval.fail "try* expected a body a catch block" - - -print : Env -> MalExpr -> String -print env = - printString env True - - -printError : Env -> MalExpr -> String -printError env expr = - "Error: " ++ (printString env False expr) - - -{-| Read-Eval-Print. - -Doesn't actually run the Eval but returns the monad. - --} -rep : String -> Maybe (Eval MalExpr) -rep input = - case readString input of - Ok Nothing -> - Nothing - - Err msg -> - Just (Eval.fail msg) - - Ok (Just ast) -> - eval ast |> Just +port module Main exposing (..) + +import Array +import Dict exposing (Dict) +import IO exposing (..) +import Json.Decode exposing (decodeValue) +import Platform exposing (programWithFlags) +import Types exposing (..) +import Reader exposing (readString) +import Printer exposing (printString) +import Utils exposing (maybeToList, zip, last, justValues, makeCall) +import Env +import Core +import Eval + + +main : Program Flags Model Msg +main = + programWithFlags + { init = init + , update = update + , subscriptions = + \model -> input (decodeValue decodeIO >> Input) + } + + +type alias Args = + List String + + +type alias Flags = + { args : Args + } + + +type Model + = InitIO Args Env (IO -> Eval MalExpr) + | ScriptIO Env (IO -> Eval MalExpr) + | ReplActive Env + | ReplIO Env (IO -> Eval MalExpr) + | Stopped + + +init : Flags -> ( Model, Cmd Msg ) +init { args } = + let + makeFn = + CoreFunc >> MalFunction + + initEnv = + Core.ns + |> Env.set "eval" (makeFn malEval) + |> Env.set "*ARGV*" (MalList (args |> List.map MalString)) + |> Env.set "*host-language*" (MalString "elm") + + evalMalInit = + malInit + |> List.map rep + |> justValues + |> List.foldl + (\b a -> a |> Eval.andThen (\_ -> b)) + (Eval.succeed MalNil) + in + runInit args initEnv evalMalInit + + +malInit : List String +malInit = + [ """(def! not + (fn* (a) + (if a false true)))""" + , """(def! load-file + (fn* (f) + (eval (read-string + (str "(do " (slurp f) "\nnil)")))))""" + , """(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)))))))""" + ] + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case model of + Stopped -> + ( model, Cmd.none ) + + InitIO args env cont -> + case msg of + Input (Ok io) -> + runInit args env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ScriptIO env cont -> + case msg of + Input (Ok io) -> + runScriptLoop env (cont io) + + Input (Err msg) -> + Debug.crash msg + + ReplActive env -> + case msg of + Input (Ok (LineRead (Just line))) -> + case rep line of + Just expr -> + run env expr + + Nothing -> + ( model, readLine prompt ) + + Input (Ok LineWritten) -> + ( model, readLine prompt ) + + Input (Ok (LineRead Nothing)) -> + -- Ctrl+D = The End. + ( model, Cmd.none ) + + Input (Ok io) -> + Debug.crash "unexpected IO received: " io + + Input (Err msg) -> + Debug.crash msg + + ReplIO env cont -> + case msg of + Input (Ok io) -> + run env (cont io) + + Input (Err msg) -> + Debug.crash msg ( model, Cmd.none ) + + +runInit : Args -> Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runInit args env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + -- Init went okay. + case args of + -- If we got no args: start REPL. + [] -> + ( ReplActive env, readLine prompt ) + + -- Run the script in the first argument. + -- Put the rest of the arguments as *ARGV*. + filename :: argv -> + runScript filename argv env + + ( env, EvalErr msg ) -> + -- Init failed, don't start REPL. + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + -- IO in init. + ( InitIO args env cont, cmd ) + + +runScript : String -> List String -> Env -> ( Model, Cmd Msg ) +runScript filename argv env = + let + malArgv = + MalList (List.map MalString argv) + + newEnv = + env |> Env.set "*ARGV*" malArgv + + program = + MalList + [ MalSymbol "load-file" + , MalString filename + ] + in + runScriptLoop newEnv (eval program) + + +runScriptLoop : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +runScriptLoop env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( Stopped, Cmd.none ) + + ( env, EvalErr msg ) -> + ( Stopped, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ScriptIO env cont, cmd ) + + +run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) +run env expr = + case Eval.run env expr of + ( env, EvalOk expr ) -> + ( ReplActive env, writeLine (print env expr) ) + + ( env, EvalErr msg ) -> + ( ReplActive env, writeLine (printError env msg) ) + + ( env, EvalIO cmd cont ) -> + ( ReplIO env cont, cmd ) + + +prompt : String +prompt = + "user> " + + +{-| read can return three things: + +Ok (Just expr) -> parsed okay +Ok Nothing -> empty string (only whitespace and/or comments) +Err msg -> parse error + +-} +read : String -> Result String (Maybe MalExpr) +read = + readString + + +debug : String -> (Env -> a) -> Eval b -> Eval b +debug msg f e = + Eval.withEnv + (\env -> + Env.debug env msg (f env) + |> always e + ) + + +eval : MalExpr -> Eval MalExpr +eval ast = + let + apply expr env = + case expr of + MalApply app -> + Left + (debug "evalApply" + (\env -> printString env True expr) + (evalApply app) + ) + + _ -> + Right expr + in + evalNoApply ast + |> Eval.andThen (Eval.runLoop apply) + |> Eval.gcPass + + +malEval : List MalExpr -> Eval MalExpr +malEval args = + case args of + [ expr ] -> + Eval.inGlobal (eval expr) + + _ -> + Eval.fail "unsupported arguments" + + +evalApply : ApplyRec -> Eval MalExpr +evalApply { frameId, bound, body } = + Eval.withEnv + (\env -> + Eval.modifyEnv (Env.enter frameId bound) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.leave + |> Eval.gcPass + ) + + +evalNoApply : MalExpr -> Eval MalExpr +evalNoApply ast = + let + go ast = + case ast of + MalList [] -> + Eval.succeed ast + + MalList ((MalSymbol "def!") :: args) -> + evalDef args + + MalList ((MalSymbol "let*") :: args) -> + evalLet args + + MalList ((MalSymbol "do") :: args) -> + evalDo args + + MalList ((MalSymbol "if") :: args) -> + evalIf args + + MalList ((MalSymbol "fn*") :: args) -> + evalFn args + + MalList ((MalSymbol "quote") :: args) -> + evalQuote args + + MalList [MalSymbol "quasiquoteexpand", expr] -> + Eval.succeed <| evalQuasiQuote expr + MalList (MalSymbol "quasiquoteexpand" :: _) -> + Eval.fail "quasiquoteexpand: arg count" + + MalList ((MalSymbol "quasiquote") :: args) -> + case args of + [ expr ] -> + -- TCO. + evalNoApply (evalQuasiQuote expr) + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "defmacro!") :: args) -> + evalDefMacro args + + MalList ((MalSymbol "macroexpand") :: args) -> + case args of + [ expr ] -> + macroexpand expr + + _ -> + Eval.fail "unsupported arguments" + + MalList ((MalSymbol "try*") :: args) -> + evalTry args + + MalList list -> + evalList list + |> Eval.andThen + (\newList -> + case newList of + [] -> + Eval.fail "can't happen" + + (MalFunction (CoreFunc fn)) :: args -> + fn args + + (MalFunction (UserFunc { lazyFn })) :: args -> + lazyFn args + + fn :: _ -> + Eval.withEnv + (\env -> + Eval.fail ((printString env True fn) ++ " is not a function") + ) + ) + + _ -> + evalAst ast + in + macroexpand ast + |> Eval.andThen go + |> Eval.andThen + (\res -> + debug "evalNoApply" + (\env -> (printString env True ast) ++ " = " ++ (printString env True res)) + (Eval.succeed res) + ) + + +evalAst : MalExpr -> Eval MalExpr +evalAst ast = + case ast of + MalSymbol sym -> + -- Lookup symbol in env and return value or raise error if not found. + Eval.withEnv (Env.get sym >> Eval.fromResult) + + MalList list -> + -- Return new list that is result of calling eval on each element of list. + evalList list + |> Eval.map MalList + + MalVector vec -> + evalList (Array.toList vec) + |> Eval.map (Array.fromList >> MalVector) + + MalMap map -> + evalList (Dict.values map) + |> Eval.map + (zip (Dict.keys map) + >> Dict.fromList + >> MalMap + ) + + _ -> + Eval.succeed ast + + +evalList : List MalExpr -> Eval (List MalExpr) +evalList list = + let + go list acc = + case list of + [] -> + Eval.succeed (List.reverse acc) + + x :: rest -> + eval x + |> Eval.andThen + (\val -> + Eval.pushRef val <| go rest (val :: acc) + ) + in + Eval.withStack <| go list [] + + +evalDef : List MalExpr -> Eval MalExpr +evalDef args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen (\_ -> Eval.succeed value) + ) + + _ -> + Eval.fail "def! expected two args: name and value" + + +evalDefMacro : List MalExpr -> Eval MalExpr +evalDefMacro args = + case args of + [ MalSymbol name, uneValue ] -> + eval uneValue + |> Eval.andThen + (\value -> + case value of + MalFunction (UserFunc fn) -> + let + macroFn = + MalFunction (UserFunc { fn | isMacro = True }) + in + Eval.modifyEnv (Env.set name macroFn) + |> Eval.andThen (\_ -> Eval.succeed macroFn) + + _ -> + Eval.fail "defmacro! is only supported on a user function" + ) + + _ -> + Eval.fail "defmacro! expected two args: name and value" + + +evalLet : List MalExpr -> Eval MalExpr +evalLet args = + let + evalBinds binds = + case binds of + (MalSymbol name) :: expr :: rest -> + eval expr + |> Eval.andThen + (\value -> + Eval.modifyEnv (Env.set name value) + |> Eval.andThen + (\_ -> + if List.isEmpty rest then + Eval.succeed () + else + evalBinds rest + ) + ) + + _ -> + Eval.fail "let* expected an even number of binds (symbol expr ..)" + + go binds body = + Eval.modifyEnv Env.push + |> Eval.andThen (\_ -> evalBinds binds) + |> Eval.andThen (\_ -> evalNoApply body) + |> Eval.finally Env.pop + in + case args of + [ MalList binds, body ] -> + go binds body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "let* expected two args: binds and a body" + + +evalDo : List MalExpr -> Eval MalExpr +evalDo args = + case List.reverse args of + last :: rest -> + evalList (List.reverse rest) + |> Eval.andThen (\_ -> evalNoApply last) + + [] -> + Eval.fail "do expected at least one arg" + + +evalIf : List MalExpr -> Eval MalExpr +evalIf args = + let + isThruthy expr = + expr /= MalNil && expr /= (MalBool False) + + go condition trueExpr falseExpr = + eval condition + |> Eval.map isThruthy + |> Eval.andThen + (\cond -> + evalNoApply + (if cond then + trueExpr + else + falseExpr + ) + ) + in + case args of + [ condition, trueExpr ] -> + go condition trueExpr MalNil + + [ condition, trueExpr, falseExpr ] -> + go condition trueExpr falseExpr + + _ -> + Eval.fail "if expected at least two args" + + +evalFn : List MalExpr -> Eval MalExpr +evalFn args = + let + {- Extract symbols from the binds list and verify their uniqueness -} + extractSymbols acc list = + case list of + [] -> + Ok (List.reverse acc) + + (MalSymbol name) :: rest -> + if List.member name acc then + Err "all binds must have unique names" + else + extractSymbols (name :: acc) rest + + _ -> + Err "all binds in fn* must be a symbol" + + parseBinds list = + case List.reverse list of + var :: "&" :: rest -> + Ok <| bindVarArgs (List.reverse rest) var + + _ -> + if List.member "&" list then + Err "varargs separator '&' is used incorrectly" + else + Ok <| bindArgs list + + extractAndParse = + extractSymbols [] >> Result.andThen parseBinds + + bindArgs binds args = + let + numBinds = + List.length binds + in + if List.length args /= numBinds then + Err <| + "function expected " + ++ (toString numBinds) + ++ " arguments" + else + Ok <| zip binds args + + bindVarArgs binds var args = + let + minArgs = + List.length binds + + varArgs = + MalList (List.drop minArgs args) + in + if List.length args < minArgs then + Err <| + "function expected at least " + ++ (toString minArgs) + ++ " arguments" + else + Ok <| zip binds args ++ [ ( var, varArgs ) ] + + makeFn frameId binder body = + MalFunction <| + let + lazyFn = + binder + >> Eval.fromResult + >> Eval.map + (\bound -> + MalApply + { frameId = frameId + , bound = bound + , body = body + } + ) + in + UserFunc + { frameId = frameId + , lazyFn = lazyFn + , eagerFn = lazyFn >> Eval.andThen eval + , isMacro = False + , meta = Nothing + } + + go bindsList body = + extractAndParse bindsList + |> Eval.fromResult + -- reference the current frame. + |> Eval.ignore (Eval.modifyEnv Env.ref) + |> Eval.andThen + (\binder -> + Eval.withEnv + (\env -> + Eval.succeed + (makeFn env.currentFrameId binder body) + ) + ) + in + case args of + [ MalList bindsList, body ] -> + go bindsList body + + [ MalVector bindsVec, body ] -> + go (Array.toList bindsVec) body + + _ -> + Eval.fail "fn* expected two args: binds list and body" + + +evalQuote : List MalExpr -> Eval MalExpr +evalQuote args = + case args of + [ expr ] -> + Eval.succeed expr + + _ -> + Eval.fail "unsupported arguments" + + +evalQuasiQuote : MalExpr -> MalExpr +evalQuasiQuote expr = + let + qq_loop : MalExpr -> MalExpr -> MalExpr + qq_loop elt acc = + case elt of + (MalList [MalSymbol "splice-unquote", form]) -> + MalList <| [MalSymbol "concat", form, acc ] + _ -> + MalList <| [MalSymbol "cons", evalQuasiQuote elt, acc ] + in + case expr of + (MalList [MalSymbol "unquote", form]) -> + form + (MalList xs) -> + List.foldr qq_loop (MalList []) xs + (MalVector xs) -> + MalList <| (\x -> [MalSymbol "vec", x]) <| Array.foldr qq_loop (MalList []) xs + (MalSymbol _) -> + MalList <| [MalSymbol "quote", expr] + (MalMap _) -> + MalList <| [MalSymbol "quote", expr] + _ -> + expr + + +macroexpand : MalExpr -> Eval MalExpr +macroexpand expr = + let + expand expr env = + case expr of + MalList ((MalSymbol name) :: args) -> + case Env.get name env of + Ok (MalFunction (UserFunc fn)) -> + if fn.isMacro then + Left <| fn.eagerFn args + else + Right expr + + _ -> + Right expr + + _ -> + Right expr + in + Eval.runLoop expand expr + + +evalTry : List MalExpr -> Eval MalExpr +evalTry args = + case args of + [ body ] -> + eval body + [ body, MalList [ MalSymbol "catch*", MalSymbol sym, handler ] ] -> + eval body + |> Eval.catchError + (\ex -> + Eval.modifyEnv Env.push + |> Eval.andThen + (\_ -> + Eval.modifyEnv (Env.set sym ex) + ) + |> Eval.andThen (\_ -> eval handler) + |> Eval.finally Env.pop + ) + + _ -> + Eval.fail "try* expected a body a catch block" + + +print : Env -> MalExpr -> String +print env = + printString env True + + +printError : Env -> MalExpr -> String +printError env expr = + "Error: " ++ (printString env False expr) + + +{-| Read-Eval-Print. + +Doesn't actually run the Eval but returns the monad. + +-} +rep : String -> Maybe (Eval MalExpr) +rep input = + case readString input of + Ok Nothing -> + Nothing + + Err msg -> + Just (Eval.fail msg) + + Ok (Just ast) -> + eval ast |> Just diff --git a/impls/erlang/Dockerfile b/impls/erlang/Dockerfile index f2b907627c..eebd9febee 100644 --- a/impls/erlang/Dockerfile +++ b/impls/erlang/Dockerfile @@ -1,35 +1,35 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Erlang R17 (so I can use maps) -RUN apt-get -y install build-essential libncurses5-dev libssl-dev -RUN cd /tmp && curl -O http://www.erlang.org/download/otp_src_17.5.tar.gz \ - && tar -C /tmp -zxf /tmp/otp_src_17.5.tar.gz \ - && cd /tmp/otp_src_17.5 && ./configure && make && make install \ - && rm -rf /tmp/otp_src_17.5 /tmp/otp_src_17.5.tar.gz -# Rebar for building the Erlang implementation -RUN apt-get -y install git sudo -RUN cd /tmp/ && git clone -q https://github.com/rebar/rebar.git \ - && cd /tmp/rebar && ./bootstrap && cp rebar /usr/local/bin \ - && rm -rf /tmp/rebar - +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Erlang R17 (so I can use maps) +RUN apt-get -y install build-essential libncurses5-dev libssl-dev +RUN cd /tmp && curl -O http://www.erlang.org/download/otp_src_17.5.tar.gz \ + && tar -C /tmp -zxf /tmp/otp_src_17.5.tar.gz \ + && cd /tmp/otp_src_17.5 && ./configure && make && make install \ + && rm -rf /tmp/otp_src_17.5 /tmp/otp_src_17.5.tar.gz +# Rebar for building the Erlang implementation +RUN apt-get -y install git sudo +RUN cd /tmp/ && git clone -q https://github.com/rebar/rebar.git \ + && cd /tmp/rebar && ./bootstrap && cp rebar /usr/local/bin \ + && rm -rf /tmp/rebar + diff --git a/impls/erlang/Makefile b/impls/erlang/Makefile index 5ad84cca76..1350c42a92 100644 --- a/impls/erlang/Makefile +++ b/impls/erlang/Makefile @@ -1,37 +1,37 @@ -##################### - -SOURCES_BASE = src/atom.erl src/printer.erl src/reader.erl -SOURCES_LISP = src/core.erl src/env.erl src/types.erl src/stepA_mal.erl -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -##################### - -SRCS = step0_repl.erl step1_read_print.erl step2_eval.erl step3_env.erl step4_if_fn_do.erl \ - step5_tco.erl step6_file.erl step7_quote.erl step8_macros.erl step9_try.erl stepA_mal.erl -BINS = $(SRCS:%.erl=%) - -##################### - -.PHONY: all dist clean - -all: $(BINS) - -dist: mal - -mal: $(SOURCES) - sed 's/stepA_mal/mal/' src/stepA_mal.erl > src/mal.erl - MAL_STEP=mal rebar compile escriptize - rm src/mal.erl - - -define dep_template -.PHONY: $(1) -$(1): src/$(1).erl - MAL_STEP=$(1) rebar compile escriptize -endef - -$(foreach b,$(BINS),$(eval $(call dep_template,$(b)))) - -clean: - rebar clean - rm -f mal +##################### + +SOURCES_BASE = src/atom.erl src/printer.erl src/reader.erl +SOURCES_LISP = src/core.erl src/env.erl src/types.erl src/stepA_mal.erl +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +##################### + +SRCS = step0_repl.erl step1_read_print.erl step2_eval.erl step3_env.erl step4_if_fn_do.erl \ + step5_tco.erl step6_file.erl step7_quote.erl step8_macros.erl step9_try.erl stepA_mal.erl +BINS = $(SRCS:%.erl=%) + +##################### + +.PHONY: all dist clean + +all: $(BINS) + +dist: mal + +mal: $(SOURCES) + sed 's/stepA_mal/mal/' src/stepA_mal.erl > src/mal.erl + MAL_STEP=mal rebar compile escriptize + rm src/mal.erl + + +define dep_template +.PHONY: $(1) +$(1): src/$(1).erl + MAL_STEP=$(1) rebar compile escriptize +endef + +$(foreach b,$(BINS),$(eval $(call dep_template,$(b)))) + +clean: + rebar clean + rm -f mal diff --git a/impls/erlang/rebar.config b/impls/erlang/rebar.config index f18253f3d9..c8be004190 100644 --- a/impls/erlang/rebar.config +++ b/impls/erlang/rebar.config @@ -1,24 +1,24 @@ -%% -%% rebar configuration file (https://github.com/rebar/rebar) -%% - -{require_otp_vsn, "17|18"}. - -{erl_opts, [debug_info, fail_on_warning]}. - -{clean_files, [ - "ebin", - "src/*.beam", - "mal", - "step0_repl", - "step1_read_print", - "step2_eval", - "step3_env", - "step4_if_fn_do", - "step5_tco", - "step6_file", - "step7_quote", - "step8_macros", - "step9_try", - "stepA_mal" -]}. +%% +%% rebar configuration file (https://github.com/rebar/rebar) +%% + +{require_otp_vsn, "17|18"}. + +{erl_opts, [debug_info, fail_on_warning]}. + +{clean_files, [ + "ebin", + "src/*.beam", + "mal", + "step0_repl", + "step1_read_print", + "step2_eval", + "step3_env", + "step4_if_fn_do", + "step5_tco", + "step6_file", + "step7_quote", + "step8_macros", + "step9_try", + "stepA_mal" +]}. diff --git a/impls/erlang/rebar.config.script b/impls/erlang/rebar.config.script index 9ad75efe05..afbad0db8d 100644 --- a/impls/erlang/rebar.config.script +++ b/impls/erlang/rebar.config.script @@ -1,11 +1,11 @@ -%% -%% rebar dynamic configuration file -%% (https://github.com/rebar/rebar/wiki/Dynamic-configuration) -%% - -case os:getenv("MAL_STEP") of - false -> CONFIG; % env var not defined - [] -> CONFIG; % env var set to empty string - Step -> CONFIG ++ [{escript_name, Step}]; - mal -> CONFIG ++ [{escript_name, mal}] -end. +%% +%% rebar dynamic configuration file +%% (https://github.com/rebar/rebar/wiki/Dynamic-configuration) +%% + +case os:getenv("MAL_STEP") of + false -> CONFIG; % env var not defined + [] -> CONFIG; % env var set to empty string + Step -> CONFIG ++ [{escript_name, Step}]; + mal -> CONFIG ++ [{escript_name, mal}] +end. diff --git a/impls/erlang/run b/impls/erlang/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/erlang/run +++ b/impls/erlang/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/erlang/src/atom.erl b/impls/erlang/src/atom.erl index f322eeae31..706776db1c 100644 --- a/impls/erlang/src/atom.erl +++ b/impls/erlang/src/atom.erl @@ -1,69 +1,69 @@ -%%% -%%% Atom -%%% -%%% Atoms in MAL represent mutable data, which is not native to Erlang. The -%%% lightweight technique for representing mutable data in Erlang is with a -%%% lightweight process. -%%% - --module(atom). --behavior(gen_server). - --export([new/1, deref/1, reset/2]). --export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3]). - --record(state, {atom}). - -%% -%% Public API -%% - --spec new(Atom) -> Pid - when Atom :: term(), - Pid :: pid(). -new(Atom) -> - case gen_server:start(?MODULE, [Atom], []) of - {ok, Pid} -> Pid; - {error, Reason} -> error(Reason) - end. - --spec deref(Pid) -> Value - when Pid :: pid(), - Value :: term(). -deref(Pid) -> - gen_server:call(Pid, deref). - --spec reset(Pid, Value) -> ok - when Pid :: pid(), - Value :: term(). -reset(Pid, Value) -> - gen_server:call(Pid, {reset, Value}). - -%% -%% gen_server callbacks -%% - -init([]) -> - init([nil]); -init([Value]) -> - {ok, #state{atom=Value}}. - -handle_call(deref, _From, State) -> - {reply, State#state.atom, State}; -handle_call({reset, Value}, _From, _State) -> - {reply, Value, #state{atom=Value}}; -handle_call(terminate, _From, State) -> - {stop, normal, ok, State}. - -handle_cast(_Msg, State) -> - {noreply, State}. - -handle_info(Msg, State) -> - error_logger:info_msg("unexpected message: ~p~n", [Msg]), - {noreply, State}. - -terminate(_Reason, _State) -> - ok. - -code_change(_OldVsn, State, _Extra) -> - {ok, State}. +%%% +%%% Atom +%%% +%%% Atoms in MAL represent mutable data, which is not native to Erlang. The +%%% lightweight technique for representing mutable data in Erlang is with a +%%% lightweight process. +%%% + +-module(atom). +-behavior(gen_server). + +-export([new/1, deref/1, reset/2]). +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3]). + +-record(state, {atom}). + +%% +%% Public API +%% + +-spec new(Atom) -> Pid + when Atom :: term(), + Pid :: pid(). +new(Atom) -> + case gen_server:start(?MODULE, [Atom], []) of + {ok, Pid} -> Pid; + {error, Reason} -> error(Reason) + end. + +-spec deref(Pid) -> Value + when Pid :: pid(), + Value :: term(). +deref(Pid) -> + gen_server:call(Pid, deref). + +-spec reset(Pid, Value) -> ok + when Pid :: pid(), + Value :: term(). +reset(Pid, Value) -> + gen_server:call(Pid, {reset, Value}). + +%% +%% gen_server callbacks +%% + +init([]) -> + init([nil]); +init([Value]) -> + {ok, #state{atom=Value}}. + +handle_call(deref, _From, State) -> + {reply, State#state.atom, State}; +handle_call({reset, Value}, _From, _State) -> + {reply, Value, #state{atom=Value}}; +handle_call(terminate, _From, State) -> + {stop, normal, ok, State}. + +handle_cast(_Msg, State) -> + {noreply, State}. + +handle_info(Msg, State) -> + error_logger:info_msg("unexpected message: ~p~n", [Msg]), + {noreply, State}. + +terminate(_Reason, _State) -> + ok. + +code_change(_OldVsn, State, _Extra) -> + {ok, State}. diff --git a/impls/erlang/src/core.erl b/impls/erlang/src/core.erl index 2566a965f0..08e1b01e56 100644 --- a/impls/erlang/src/core.erl +++ b/impls/erlang/src/core.erl @@ -1,399 +1,399 @@ -%%% -%%% Core functions -%%% - --module(core). --compile(export_all). - -nil_p([Arg]) -> - Arg == nil; -nil_p(_) -> - {error, "nil? takes a single argument"}. - -true_p([Arg]) -> - Arg == true; -true_p(_) -> - {error, "true? takes a single argument"}. - -false_p([Arg]) -> - Arg == false; -false_p(_) -> - {error, "false? takes a single argument"}. - -number_p([{integer, _}]) -> - true; -number_p([_]) -> - false; -number_p(_) -> - {error, "number? takes a single argument"}. - -fn_p([{function, _, _}]) -> - true; -fn_p([{closure, _, _, _, _, _}]) -> - true; -fn_p([_]) -> - false; -fn_p(_) -> - {error, "fn? takes a single argument"}. - -macro_p([{macro, _, _, _}]) -> - true; -macro_p([_]) -> - false; -macro_p(_) -> - {error, "macro? takes a single argument"}. - -count([{Type, List, _Meta}]) when Type == list orelse Type == vector -> - {integer, length(List)}; -count([nil]) -> - {integer, 0}; -count([_]) -> - {error, "count called on non-sequence"}; -count([]) -> - {error, "count called with no arguments"}; -count(_) -> - {error, "count expects one list argument"}. - -empty_q([{Type, List, _Meta}]) when Type == list orelse Type == vector -> - length(List) == 0; -empty_q([_]) -> - {error, "empty? called on non-sequence"}; -empty_q([]) -> - {error, "empty? called with no arguments"}; -empty_q(_) -> - {error, "empty? expects one list argument"}. - -nth([{Type, List, _Meta}, {integer, Index}]) when Type == list orelse Type == vector -> - try lists:nth(Index+1, List) of - Result -> Result - catch - error:_Error -> - % raise rather than returning an {error} - error("nth: index out of range") - end; -nth([_]) -> - {error, "nth expects two arguments"}. - -first([{Type, [First|_Rest], _Meta}]) when Type == list orelse Type == vector -> - First; -first([{Type, [], _Meta}]) when Type == list orelse Type == vector -> - nil; -first([nil]) -> - nil; -first([_]) -> - {error, "first called on non-sequence"}; -first([]) -> - {error, "first called with no arguments"}; -first(_) -> - {error, "first expects one list argument"}. - -rest([{Type, [_First|Rest], _Meta}]) when Type == list orelse Type == vector -> - {list, Rest, nil}; -rest([{Type, [], _Meta}]) when Type == list orelse Type == vector -> - {list, [], nil}; -rest([nil]) -> - {list, [], nil}; -rest([_]) -> - {error, "rest called on non-sequence"}; -rest([]) -> - {error, "rest called with no arguments"}; -rest(_) -> - {error, "rest expects one list argument"}. - -seq([{list, [], _Meta}]) -> - nil; -seq([{list, List, _Meta}]) -> - {list, List, nil}; -seq([{vector, [], _Meta}]) -> - nil; -seq([{vector, List, _Meta}]) -> - {list, List, nil}; -seq([{string, []}]) -> - nil; -seq([{string, S}]) -> - {list, lists:map(fun(C) -> {string, [C]} end, S), nil}; -seq([nil]) -> - nil; -seq(_) -> - {error, "seq expects one list/vector/string/nil argument"}. - -equal_q(Args) -> - case Args of - [nil, nil] -> true; - [true, true] -> true; - [false, false] -> true; - [{integer, I}, {integer, J}] -> I == J; - [{string, S}, {string, T}] -> S == T; - [{keyword, K}, {keyword, J}] -> K == J; - [{symbol, S}, {symbol, T}] -> S == T; - [{list, L1, _M1}, {list, L2, _M2}] -> equal_seqs(L1, L2); - [{vector, L1, _M1}, {vector, L2, _M2}] -> equal_seqs(L1, L2); - [{list, L1, _M1}, {vector, L2, _M2}] -> equal_seqs(L1, L2); - [{vector, L1, _M1}, {list, L2, _M2}] -> equal_seqs(L1, L2); - [{map, M1, _M1}, {map, M2, _M2}] -> equal_maps(M1, M2); - [_A, _B] -> false; - _ -> {error, "equal? expects two arguments"} - end. - -equal_seqs([], []) -> - true; -equal_seqs([X|Xs], [Y|Ys]) -> - equal_q([X, Y]) andalso equal_seqs(Xs, Ys); -equal_seqs(_, _) -> - false. - -equal_maps(M1, M2) -> - maps:size(M1) == maps:size(M2) andalso equal_maps_for_keys(maps:keys(M1), M1, M2). - -equal_maps_for_keys([], _M1, _M2) -> - true; -equal_maps_for_keys([K|Ks], M1, M2) -> - equal_values_for_key(K, M1, M2) andalso equal_maps_for_keys(Ks, M1, M2). - -equal_values_for_key(K, M1, M2) -> - case [maps:find(K, M1), maps:find(K, M2)] of - [{ok, V1}, {ok, V2}] -> equal_q([V1, V2]); - _ -> false - end. - -int_op(F, [A0,A1]) -> - case A0 of - {integer, I0} -> - case A1 of - {integer, I1} -> - {integer, F(I0, I1)}; - _ -> {error, "second argument must be an integer"} - end; - _ -> {error, "first argument must be an integer"} - end; -int_op(_F, _L) -> - {error, "must have two arguments"}. - -int_add(Args) -> - int_op(fun(I, J) -> I + J end, Args). - -int_sub(Args) -> - int_op(fun(I, J) -> I - J end, Args). - -int_mul(Args) -> - int_op(fun(I, J) -> I * J end, Args). - -int_div(Args) -> - int_op(fun(I, J) -> I div J end, Args). - -bool_op(F, [A0,A1]) -> - case A0 of - {integer, I0} -> - case A1 of - {integer, I1} -> - % the true or false is our return value - F(I0, I1); - _ -> {error, "second argument must be an integer"} - end; - _ -> {error, "first argument must be an integer"} - end; -bool_op(_F, _L) -> - {error, "must have two arguments"}. - -bool_lt(Args) -> - bool_op(fun(I, J) -> I < J end, Args). - -bool_lte(Args) -> - bool_op(fun(I, J) -> I =< J end, Args). - -bool_gt(Args) -> - bool_op(fun(I, J) -> I > J end, Args). - -bool_gte(Args) -> - bool_op(fun(I, J) -> I >= J end, Args). - -pr_str(Args) -> - {string, printer:pr_list(Args, "", "", " ", true)}. - -str(Args) -> - {string, printer:pr_list(Args, "", "", "", false)}. - -prn(Args) -> - io:format("~s~n", [printer:pr_list(Args, "", "", " ", true)]), - nil. - -println(Args) -> - io:format("~s~n", [printer:pr_list(Args, "", "", " ", false)]), - nil. - -read_string([{string, Input}]) -> - case reader:read_str(Input) of - {ok, none} -> nil; - {ok, AST} -> AST; - {error, Reason} -> {error, Reason} - end; -read_string(_) -> - {error, "read-string expects a single string argument"}. - -slurp([{string, Filepath}]) -> - case file:read_file(Filepath) of - {ok, Binary} -> {string, binary_to_list(Binary)}; - {error, Reason} -> {error, Reason} - end; -slurp(_) -> - {error, "slurp called with non-string"}. - -cons([Elem, {Type, List, _Meta}]) when Type == list orelse Type == vector -> - {list, [Elem|List], nil}; -cons([_,_]) -> - {error, "second argument to cons must be a sequence"}; -cons(_) -> - {error, "cons expects two arguments"}. - -conj([{Type, _List, _Meta}]) when Type == list orelse Type == vector -> - {error, "conj expects additional arguments"}; -conj([{list, List, _Meta}|Args]) -> - {list, lists:foldl(fun(Elem, AccIn) -> [Elem|AccIn] end, List, Args), nil}; -conj([{vector, List, _Meta}|Args]) -> - % why is vector backward from list? - {vector, List ++ Args, nil}; -conj(_) -> - {error, "conj expects a list and one or more arguments"}. - -concat(Args) -> - PushAll = fun(Elem, AccIn) -> - case Elem of - {Type, List, _Meta} when Type == list orelse Type == vector -> - AccIn ++ List; - _ -> error("concat called with non-sequence") - end - end, - try lists:foldl(PushAll, [], Args) of - Result -> {list, Result, nil} - catch - error:Reason -> {error, Reason} - end. - -vec([{list, List, _Meta}]) -> {vector, List, nil}; -vec([{vector, List, _Meta}]) -> {vector, List, nil}; -vec([_]) -> {error, "vec: arg type"}; -vec(_) -> {error, "vec: arg count"}. - -mal_throw([Reason]) -> - throw(Reason); -mal_throw(_) -> - {error, "throw expects a list with one argument"}. - -map_f([{closure, Eval, Binds, Body, CE, _M1}, {Type, Args, _M2}]) when Type == list orelse Type == vector -> - Apply = fun(Arg) -> - NewEnv = env:new(CE), - env:bind(NewEnv, Binds, [Arg]), - Eval(Body, NewEnv) - end, - {list, lists:map(Apply, Args), nil}; -map_f([{function, F, _M}, {Type, Args, _Meta}]) when Type == list orelse Type == vector -> - {list, [erlang:apply(F, [[Arg]]) || Arg <- Args], nil}; -map_f(_) -> - {error, "map expects a function and list argument"}. - -flatten_args(Args) -> - % Convert the apply arguments into a flat list, such that no element - % consists of {list,...} or {vector,...} (i.e. just [A, B, C, ...]). - Delist = fun(Elem) -> - case Elem of - {T, L, _M} when T == list orelse T == vector -> L; - _ -> Elem - end - end, - lists:flatten(lists:map(Delist, lists:flatten(Args))). - -apply_f([{closure, Eval, Binds, Body, CE, _M1}|Args]) -> - NewEnv = env:new(CE), - env:bind(NewEnv, Binds, flatten_args(Args)), - Eval(Body, NewEnv); -apply_f([{function, F, _M}|Args]) -> - erlang:apply(F, [flatten_args(Args)]); -apply_f(_) -> - {error, "apply expects a function followed by arguments"}. - -readline([{string, Prompt}]) -> - case io:get_line(standard_io, Prompt) of - % When user presses Ctrl-d it seems like io:get_line/2 cannot be - % called again, and we seem unable to signal to MAL to terminate, - % so just error out. - eof -> exit(goodbye); - {error, Reason} -> {error, Reason}; - Line -> {string, string:strip(Line, both, $\n)} - end; -readline(_) -> - {error, "readline expects a string argument"}. - -time_ms(_) -> - {Mega, Sec, Micro} = os:timestamp(), - {integer, Mega * 1000000000 + Sec * 1000 + Micro div 1000}. - -ns() -> - Builtins = #{ - "*" => fun int_mul/1, - "+" => fun int_add/1, - "-" => fun int_sub/1, - "/" => fun int_div/1, - "<" => fun bool_lt/1, - "<=" => fun bool_lte/1, - "=" => fun equal_q/1, - ">" => fun bool_gt/1, - ">=" => fun bool_gte/1, - "apply" => fun apply_f/1, - "assoc" => fun types:assoc/1, - "atom" => fun types:atom/1, - "atom?" => fun types:atom_p/1, - "concat" => fun concat/1, - "conj" => fun conj/1, - "cons" => fun cons/1, - "contains?" => fun types:contains_p/1, - "count" => fun count/1, - "deref" => fun types:deref/1, - "dissoc" => fun types:dissoc/1, - "empty?" => fun empty_q/1, - "false?" => fun false_p/1, - "first" => fun first/1, - "fn?" => fun fn_p/1, - "get" => fun types:map_get/1, - "hash-map" => fun types:hash_map/1, - "keys" => fun types:map_keys/1, - "keyword" => fun types:keyword/1, - "keyword?" => fun types:keyword_p/1, - "list" => fun types:list/1, - "list?" => fun types:list_p/1, - "macro?" => fun macro_p/1, - "map" => fun map_f/1, - "map?" => fun types:map_p/1, - "meta" => fun types:meta/1, - "nil?" => fun nil_p/1, - "nth" => fun nth/1, - "number?" => fun number_p/1, - "pr-str" => fun pr_str/1, - "println" => fun println/1, - "prn" => fun prn/1, - "read-string" => fun read_string/1, - "readline" => fun readline/1, - "reset!" => fun types:reset/1, - "rest" => fun rest/1, - "seq" => fun seq/1, - "sequential?" => fun types:sequential_p/1, - "slurp" => fun slurp/1, - "str" => fun str/1, - "string?" => fun types:string_p/1, - "swap!" => fun types:swap/1, - "symbol" => fun types:symbol/1, - "symbol?" => fun types:symbol_p/1, - "throw" => fun mal_throw/1, - "time-ms" => fun time_ms/1, - "true?" => fun true_p/1, - "vals" => fun types:map_values/1, - "vec" => fun vec/1, - "vector" => fun types:vector/1, - "vector?" => fun types:vector_p/1, - "with-meta" => fun types:with_meta/1 - }, - Env = env:new(undefined), - SetEnv = fun(K, V) -> - env:set(Env, {symbol, K}, types:func(V)) - end, - maps:map(SetEnv, Builtins), - Env. +%%% +%%% Core functions +%%% + +-module(core). +-compile(export_all). + +nil_p([Arg]) -> + Arg == nil; +nil_p(_) -> + {error, "nil? takes a single argument"}. + +true_p([Arg]) -> + Arg == true; +true_p(_) -> + {error, "true? takes a single argument"}. + +false_p([Arg]) -> + Arg == false; +false_p(_) -> + {error, "false? takes a single argument"}. + +number_p([{integer, _}]) -> + true; +number_p([_]) -> + false; +number_p(_) -> + {error, "number? takes a single argument"}. + +fn_p([{function, _, _}]) -> + true; +fn_p([{closure, _, _, _, _, _}]) -> + true; +fn_p([_]) -> + false; +fn_p(_) -> + {error, "fn? takes a single argument"}. + +macro_p([{macro, _, _, _}]) -> + true; +macro_p([_]) -> + false; +macro_p(_) -> + {error, "macro? takes a single argument"}. + +count([{Type, List, _Meta}]) when Type == list orelse Type == vector -> + {integer, length(List)}; +count([nil]) -> + {integer, 0}; +count([_]) -> + {error, "count called on non-sequence"}; +count([]) -> + {error, "count called with no arguments"}; +count(_) -> + {error, "count expects one list argument"}. + +empty_q([{Type, List, _Meta}]) when Type == list orelse Type == vector -> + length(List) == 0; +empty_q([_]) -> + {error, "empty? called on non-sequence"}; +empty_q([]) -> + {error, "empty? called with no arguments"}; +empty_q(_) -> + {error, "empty? expects one list argument"}. + +nth([{Type, List, _Meta}, {integer, Index}]) when Type == list orelse Type == vector -> + try lists:nth(Index+1, List) of + Result -> Result + catch + error:_Error -> + % raise rather than returning an {error} + error("nth: index out of range") + end; +nth([_]) -> + {error, "nth expects two arguments"}. + +first([{Type, [First|_Rest], _Meta}]) when Type == list orelse Type == vector -> + First; +first([{Type, [], _Meta}]) when Type == list orelse Type == vector -> + nil; +first([nil]) -> + nil; +first([_]) -> + {error, "first called on non-sequence"}; +first([]) -> + {error, "first called with no arguments"}; +first(_) -> + {error, "first expects one list argument"}. + +rest([{Type, [_First|Rest], _Meta}]) when Type == list orelse Type == vector -> + {list, Rest, nil}; +rest([{Type, [], _Meta}]) when Type == list orelse Type == vector -> + {list, [], nil}; +rest([nil]) -> + {list, [], nil}; +rest([_]) -> + {error, "rest called on non-sequence"}; +rest([]) -> + {error, "rest called with no arguments"}; +rest(_) -> + {error, "rest expects one list argument"}. + +seq([{list, [], _Meta}]) -> + nil; +seq([{list, List, _Meta}]) -> + {list, List, nil}; +seq([{vector, [], _Meta}]) -> + nil; +seq([{vector, List, _Meta}]) -> + {list, List, nil}; +seq([{string, []}]) -> + nil; +seq([{string, S}]) -> + {list, lists:map(fun(C) -> {string, [C]} end, S), nil}; +seq([nil]) -> + nil; +seq(_) -> + {error, "seq expects one list/vector/string/nil argument"}. + +equal_q(Args) -> + case Args of + [nil, nil] -> true; + [true, true] -> true; + [false, false] -> true; + [{integer, I}, {integer, J}] -> I == J; + [{string, S}, {string, T}] -> S == T; + [{keyword, K}, {keyword, J}] -> K == J; + [{symbol, S}, {symbol, T}] -> S == T; + [{list, L1, _M1}, {list, L2, _M2}] -> equal_seqs(L1, L2); + [{vector, L1, _M1}, {vector, L2, _M2}] -> equal_seqs(L1, L2); + [{list, L1, _M1}, {vector, L2, _M2}] -> equal_seqs(L1, L2); + [{vector, L1, _M1}, {list, L2, _M2}] -> equal_seqs(L1, L2); + [{map, M1, _M1}, {map, M2, _M2}] -> equal_maps(M1, M2); + [_A, _B] -> false; + _ -> {error, "equal? expects two arguments"} + end. + +equal_seqs([], []) -> + true; +equal_seqs([X|Xs], [Y|Ys]) -> + equal_q([X, Y]) andalso equal_seqs(Xs, Ys); +equal_seqs(_, _) -> + false. + +equal_maps(M1, M2) -> + maps:size(M1) == maps:size(M2) andalso equal_maps_for_keys(maps:keys(M1), M1, M2). + +equal_maps_for_keys([], _M1, _M2) -> + true; +equal_maps_for_keys([K|Ks], M1, M2) -> + equal_values_for_key(K, M1, M2) andalso equal_maps_for_keys(Ks, M1, M2). + +equal_values_for_key(K, M1, M2) -> + case [maps:find(K, M1), maps:find(K, M2)] of + [{ok, V1}, {ok, V2}] -> equal_q([V1, V2]); + _ -> false + end. + +int_op(F, [A0,A1]) -> + case A0 of + {integer, I0} -> + case A1 of + {integer, I1} -> + {integer, F(I0, I1)}; + _ -> {error, "second argument must be an integer"} + end; + _ -> {error, "first argument must be an integer"} + end; +int_op(_F, _L) -> + {error, "must have two arguments"}. + +int_add(Args) -> + int_op(fun(I, J) -> I + J end, Args). + +int_sub(Args) -> + int_op(fun(I, J) -> I - J end, Args). + +int_mul(Args) -> + int_op(fun(I, J) -> I * J end, Args). + +int_div(Args) -> + int_op(fun(I, J) -> I div J end, Args). + +bool_op(F, [A0,A1]) -> + case A0 of + {integer, I0} -> + case A1 of + {integer, I1} -> + % the true or false is our return value + F(I0, I1); + _ -> {error, "second argument must be an integer"} + end; + _ -> {error, "first argument must be an integer"} + end; +bool_op(_F, _L) -> + {error, "must have two arguments"}. + +bool_lt(Args) -> + bool_op(fun(I, J) -> I < J end, Args). + +bool_lte(Args) -> + bool_op(fun(I, J) -> I =< J end, Args). + +bool_gt(Args) -> + bool_op(fun(I, J) -> I > J end, Args). + +bool_gte(Args) -> + bool_op(fun(I, J) -> I >= J end, Args). + +pr_str(Args) -> + {string, printer:pr_list(Args, "", "", " ", true)}. + +str(Args) -> + {string, printer:pr_list(Args, "", "", "", false)}. + +prn(Args) -> + io:format("~s~n", [printer:pr_list(Args, "", "", " ", true)]), + nil. + +println(Args) -> + io:format("~s~n", [printer:pr_list(Args, "", "", " ", false)]), + nil. + +read_string([{string, Input}]) -> + case reader:read_str(Input) of + {ok, none} -> nil; + {ok, AST} -> AST; + {error, Reason} -> {error, Reason} + end; +read_string(_) -> + {error, "read-string expects a single string argument"}. + +slurp([{string, Filepath}]) -> + case file:read_file(Filepath) of + {ok, Binary} -> {string, binary_to_list(Binary)}; + {error, Reason} -> {error, Reason} + end; +slurp(_) -> + {error, "slurp called with non-string"}. + +cons([Elem, {Type, List, _Meta}]) when Type == list orelse Type == vector -> + {list, [Elem|List], nil}; +cons([_,_]) -> + {error, "second argument to cons must be a sequence"}; +cons(_) -> + {error, "cons expects two arguments"}. + +conj([{Type, _List, _Meta}]) when Type == list orelse Type == vector -> + {error, "conj expects additional arguments"}; +conj([{list, List, _Meta}|Args]) -> + {list, lists:foldl(fun(Elem, AccIn) -> [Elem|AccIn] end, List, Args), nil}; +conj([{vector, List, _Meta}|Args]) -> + % why is vector backward from list? + {vector, List ++ Args, nil}; +conj(_) -> + {error, "conj expects a list and one or more arguments"}. + +concat(Args) -> + PushAll = fun(Elem, AccIn) -> + case Elem of + {Type, List, _Meta} when Type == list orelse Type == vector -> + AccIn ++ List; + _ -> error("concat called with non-sequence") + end + end, + try lists:foldl(PushAll, [], Args) of + Result -> {list, Result, nil} + catch + error:Reason -> {error, Reason} + end. + +vec([{list, List, _Meta}]) -> {vector, List, nil}; +vec([{vector, List, _Meta}]) -> {vector, List, nil}; +vec([_]) -> {error, "vec: arg type"}; +vec(_) -> {error, "vec: arg count"}. + +mal_throw([Reason]) -> + throw(Reason); +mal_throw(_) -> + {error, "throw expects a list with one argument"}. + +map_f([{closure, Eval, Binds, Body, CE, _M1}, {Type, Args, _M2}]) when Type == list orelse Type == vector -> + Apply = fun(Arg) -> + NewEnv = env:new(CE), + env:bind(NewEnv, Binds, [Arg]), + Eval(Body, NewEnv) + end, + {list, lists:map(Apply, Args), nil}; +map_f([{function, F, _M}, {Type, Args, _Meta}]) when Type == list orelse Type == vector -> + {list, [erlang:apply(F, [[Arg]]) || Arg <- Args], nil}; +map_f(_) -> + {error, "map expects a function and list argument"}. + +flatten_args(Args) -> + % Convert the apply arguments into a flat list, such that no element + % consists of {list,...} or {vector,...} (i.e. just [A, B, C, ...]). + Delist = fun(Elem) -> + case Elem of + {T, L, _M} when T == list orelse T == vector -> L; + _ -> Elem + end + end, + lists:flatten(lists:map(Delist, lists:flatten(Args))). + +apply_f([{closure, Eval, Binds, Body, CE, _M1}|Args]) -> + NewEnv = env:new(CE), + env:bind(NewEnv, Binds, flatten_args(Args)), + Eval(Body, NewEnv); +apply_f([{function, F, _M}|Args]) -> + erlang:apply(F, [flatten_args(Args)]); +apply_f(_) -> + {error, "apply expects a function followed by arguments"}. + +readline([{string, Prompt}]) -> + case io:get_line(standard_io, Prompt) of + % When user presses Ctrl-d it seems like io:get_line/2 cannot be + % called again, and we seem unable to signal to MAL to terminate, + % so just error out. + eof -> exit(goodbye); + {error, Reason} -> {error, Reason}; + Line -> {string, string:strip(Line, both, $\n)} + end; +readline(_) -> + {error, "readline expects a string argument"}. + +time_ms(_) -> + {Mega, Sec, Micro} = os:timestamp(), + {integer, Mega * 1000000000 + Sec * 1000 + Micro div 1000}. + +ns() -> + Builtins = #{ + "*" => fun int_mul/1, + "+" => fun int_add/1, + "-" => fun int_sub/1, + "/" => fun int_div/1, + "<" => fun bool_lt/1, + "<=" => fun bool_lte/1, + "=" => fun equal_q/1, + ">" => fun bool_gt/1, + ">=" => fun bool_gte/1, + "apply" => fun apply_f/1, + "assoc" => fun types:assoc/1, + "atom" => fun types:atom/1, + "atom?" => fun types:atom_p/1, + "concat" => fun concat/1, + "conj" => fun conj/1, + "cons" => fun cons/1, + "contains?" => fun types:contains_p/1, + "count" => fun count/1, + "deref" => fun types:deref/1, + "dissoc" => fun types:dissoc/1, + "empty?" => fun empty_q/1, + "false?" => fun false_p/1, + "first" => fun first/1, + "fn?" => fun fn_p/1, + "get" => fun types:map_get/1, + "hash-map" => fun types:hash_map/1, + "keys" => fun types:map_keys/1, + "keyword" => fun types:keyword/1, + "keyword?" => fun types:keyword_p/1, + "list" => fun types:list/1, + "list?" => fun types:list_p/1, + "macro?" => fun macro_p/1, + "map" => fun map_f/1, + "map?" => fun types:map_p/1, + "meta" => fun types:meta/1, + "nil?" => fun nil_p/1, + "nth" => fun nth/1, + "number?" => fun number_p/1, + "pr-str" => fun pr_str/1, + "println" => fun println/1, + "prn" => fun prn/1, + "read-string" => fun read_string/1, + "readline" => fun readline/1, + "reset!" => fun types:reset/1, + "rest" => fun rest/1, + "seq" => fun seq/1, + "sequential?" => fun types:sequential_p/1, + "slurp" => fun slurp/1, + "str" => fun str/1, + "string?" => fun types:string_p/1, + "swap!" => fun types:swap/1, + "symbol" => fun types:symbol/1, + "symbol?" => fun types:symbol_p/1, + "throw" => fun mal_throw/1, + "time-ms" => fun time_ms/1, + "true?" => fun true_p/1, + "vals" => fun types:map_values/1, + "vec" => fun vec/1, + "vector" => fun types:vector/1, + "vector?" => fun types:vector_p/1, + "with-meta" => fun types:with_meta/1 + }, + Env = env:new(undefined), + SetEnv = fun(K, V) -> + env:set(Env, {symbol, K}, types:func(V)) + end, + maps:map(SetEnv, Builtins), + Env. diff --git a/impls/erlang/src/env.erl b/impls/erlang/src/env.erl index 3f4c4d23e4..3e9e15138d 100644 --- a/impls/erlang/src/env.erl +++ b/impls/erlang/src/env.erl @@ -1,173 +1,173 @@ -%%% -%%% Environment -%%% -%%% We need an "object" to represent the environment: something whose state can -%%% change over time, while keeping a single, unchanging reference to that -%%% object. This is done in Erlang using lightweight processes. Fortunately, OTP -%%% makes this easy. -%%% - --module(env). --behavior(gen_server). - --export([new/1, bind/3, find/2, get/2, set/3, root/1]). --export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3]). - --record(state, {outer, data}). - -%% -%% Public API -%% - --spec new(Outer) -> Pid - when Outer :: #state{}, - Pid :: pid(). -% @doc Pass 'undefined' for Outer if no parent environment. -new(Outer) -> - case gen_server:start(?MODULE, [Outer], []) of - {ok, Pid} -> Pid; - {error, Reason} -> error(Reason) - end. - --spec bind(Pid, Names, Values) -> ok - when Pid :: pid(), - Names :: [term()], - Values :: [term()]. -bind(Pid, Names, Values) -> - gen_server:call(Pid, {bind, Names, Values}). - --spec find(Pid1, Key) -> Pid2 - when Pid1 :: pid(), - Key :: {symbol, string()}, - Pid2 :: pid() | nil. -find(Pid, {symbol, Name}) -> - gen_server:call(Pid, {find_pid, Name}). - --spec get(Pid, Key) -> Value - when Pid :: pid(), - Key :: {symbol, string()}, - Value :: term(). -get(Pid, {symbol, Name}) -> - case gen_server:call(Pid, {get, Name}) of - {ok, Value} -> Value; - {error, Reason} -> error(Reason) - end; -get(_Pid, _Key) -> - error("env:get/2 called with non-symbol key"). - --spec set(Pid, Key, Value) -> ok - when Pid :: pid(), - Key :: {symbol, string()}, - Value :: term(). -set(Pid, {symbol, Name}, Value) -> - gen_server:call(Pid, {set, Name, Value}); -set(_Env, _Key, _Value) -> - error("env:set/3 called with non-symbol key"). - --spec root(Pid1) -> Pid2 - when Pid1 :: pid(), - Pid2 :: pid(). -root(Pid) -> - gen_server:call(Pid, root). - -%% -%% gen_server callbacks -%% - -init([]) -> - init([undefined]); -init([Outer]) -> - {ok, #state{outer=Outer, data=#{}}}. - -handle_call({bind, Names, Values}, _From, State) -> - NewEnv = env_bind(State, Names, Values), - {reply, ok, NewEnv}; -handle_call({find_env, Name}, _From, State) -> - {reply, env_find(State, Name), State}; -handle_call({find_pid, Name}, _From, State) -> - {reply, pid_find(State, Name), State}; -handle_call({get, Name}, _From, State) -> - {reply, env_get(State, Name), State}; -handle_call({set, Name, Value}, _From, State) -> - {reply, ok, env_set(State, Name, Value)}; -handle_call(root, _From, State) -> - {reply, env_root(State), State}; -handle_call(terminate, _From, State) -> - {stop, normal, ok, State}. - -handle_cast(_Msg, State) -> - {noreply, State}. - -handle_info(Msg, State) -> - error_logger:info_msg("unexpected message: ~p~n", [Msg]), - {noreply, State}. - -terminate(_Reason, _State) -> - ok. - -code_change(_OldVsn, State, _Extra) -> - {ok, State}. - -%% -%% Internal functions -%% - -pid_find(Env, Name) -> - case maps:is_key(Name, Env#state.data) of - true -> self(); - false -> - case Env#state.outer of - undefined -> nil; - Outer -> gen_server:call(Outer, {find_pid, Name}) - end - end. - -env_find(Env, Name) -> - case maps:is_key(Name, Env#state.data) of - true -> Env; - false -> - case Env#state.outer of - undefined -> nil; - Outer -> gen_server:call(Outer, {find_env, Name}) - end - end. - --spec env_bind(Env1, Names, Values) -> Env2 - when Env1 :: #state{}, - Names :: [term()], - Values :: [term()], - Env2 :: #state{}. -env_bind(Env, [], []) -> - Env; -env_bind(Env, [{symbol, "&"}, {symbol, Name}], Values) -> - env_set(Env, Name, {list, Values, nil}); -env_bind(Env, [{symbol, Name}|Ntail], [Value|Vtail]) -> - env_bind(env_set(Env, Name, Value), Ntail, Vtail). - --spec env_get(Env, Key) -> {ok, Value} | {error, string()} - when Env :: #state{}, - Key :: {symbol, string()}, - Value :: term(). -env_get(Env, Name) -> - case env_find(Env, Name) of - nil -> {error, io_lib:format("'~s' not found", [Name])}; - E -> {ok, maps:get(Name, E#state.data)} - end. - --spec env_set(Env1, Key, Value) -> Env2 - when Env1 :: #state{}, - Key :: {symbol, string()}, - Value :: term(), - Env2 :: #state{}. -env_set(Env, Name, Value) -> - Map = maps:put(Name, Value, Env#state.data), - #state{outer=Env#state.outer, data=Map}. - --spec env_root(Env1) -> Env2 - when Env1 :: #state{}, - Env2 :: #state{}. -env_root(Env) -> - case Env#state.outer of - undefined -> self(); - Outer -> gen_server:call(Outer, root) - end. +%%% +%%% Environment +%%% +%%% We need an "object" to represent the environment: something whose state can +%%% change over time, while keeping a single, unchanging reference to that +%%% object. This is done in Erlang using lightweight processes. Fortunately, OTP +%%% makes this easy. +%%% + +-module(env). +-behavior(gen_server). + +-export([new/1, bind/3, find/2, get/2, set/3, root/1]). +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3]). + +-record(state, {outer, data}). + +%% +%% Public API +%% + +-spec new(Outer) -> Pid + when Outer :: #state{}, + Pid :: pid(). +% @doc Pass 'undefined' for Outer if no parent environment. +new(Outer) -> + case gen_server:start(?MODULE, [Outer], []) of + {ok, Pid} -> Pid; + {error, Reason} -> error(Reason) + end. + +-spec bind(Pid, Names, Values) -> ok + when Pid :: pid(), + Names :: [term()], + Values :: [term()]. +bind(Pid, Names, Values) -> + gen_server:call(Pid, {bind, Names, Values}). + +-spec find(Pid1, Key) -> Pid2 + when Pid1 :: pid(), + Key :: {symbol, string()}, + Pid2 :: pid() | nil. +find(Pid, {symbol, Name}) -> + gen_server:call(Pid, {find_pid, Name}). + +-spec get(Pid, Key) -> Value + when Pid :: pid(), + Key :: {symbol, string()}, + Value :: term(). +get(Pid, {symbol, Name}) -> + case gen_server:call(Pid, {get, Name}) of + {ok, Value} -> Value; + {error, Reason} -> error(Reason) + end; +get(_Pid, _Key) -> + error("env:get/2 called with non-symbol key"). + +-spec set(Pid, Key, Value) -> ok + when Pid :: pid(), + Key :: {symbol, string()}, + Value :: term(). +set(Pid, {symbol, Name}, Value) -> + gen_server:call(Pid, {set, Name, Value}); +set(_Env, _Key, _Value) -> + error("env:set/3 called with non-symbol key"). + +-spec root(Pid1) -> Pid2 + when Pid1 :: pid(), + Pid2 :: pid(). +root(Pid) -> + gen_server:call(Pid, root). + +%% +%% gen_server callbacks +%% + +init([]) -> + init([undefined]); +init([Outer]) -> + {ok, #state{outer=Outer, data=#{}}}. + +handle_call({bind, Names, Values}, _From, State) -> + NewEnv = env_bind(State, Names, Values), + {reply, ok, NewEnv}; +handle_call({find_env, Name}, _From, State) -> + {reply, env_find(State, Name), State}; +handle_call({find_pid, Name}, _From, State) -> + {reply, pid_find(State, Name), State}; +handle_call({get, Name}, _From, State) -> + {reply, env_get(State, Name), State}; +handle_call({set, Name, Value}, _From, State) -> + {reply, ok, env_set(State, Name, Value)}; +handle_call(root, _From, State) -> + {reply, env_root(State), State}; +handle_call(terminate, _From, State) -> + {stop, normal, ok, State}. + +handle_cast(_Msg, State) -> + {noreply, State}. + +handle_info(Msg, State) -> + error_logger:info_msg("unexpected message: ~p~n", [Msg]), + {noreply, State}. + +terminate(_Reason, _State) -> + ok. + +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%% +%% Internal functions +%% + +pid_find(Env, Name) -> + case maps:is_key(Name, Env#state.data) of + true -> self(); + false -> + case Env#state.outer of + undefined -> nil; + Outer -> gen_server:call(Outer, {find_pid, Name}) + end + end. + +env_find(Env, Name) -> + case maps:is_key(Name, Env#state.data) of + true -> Env; + false -> + case Env#state.outer of + undefined -> nil; + Outer -> gen_server:call(Outer, {find_env, Name}) + end + end. + +-spec env_bind(Env1, Names, Values) -> Env2 + when Env1 :: #state{}, + Names :: [term()], + Values :: [term()], + Env2 :: #state{}. +env_bind(Env, [], []) -> + Env; +env_bind(Env, [{symbol, "&"}, {symbol, Name}], Values) -> + env_set(Env, Name, {list, Values, nil}); +env_bind(Env, [{symbol, Name}|Ntail], [Value|Vtail]) -> + env_bind(env_set(Env, Name, Value), Ntail, Vtail). + +-spec env_get(Env, Key) -> {ok, Value} | {error, string()} + when Env :: #state{}, + Key :: {symbol, string()}, + Value :: term(). +env_get(Env, Name) -> + case env_find(Env, Name) of + nil -> {error, io_lib:format("'~s' not found", [Name])}; + E -> {ok, maps:get(Name, E#state.data)} + end. + +-spec env_set(Env1, Key, Value) -> Env2 + when Env1 :: #state{}, + Key :: {symbol, string()}, + Value :: term(), + Env2 :: #state{}. +env_set(Env, Name, Value) -> + Map = maps:put(Name, Value, Env#state.data), + #state{outer=Env#state.outer, data=Map}. + +-spec env_root(Env1) -> Env2 + when Env1 :: #state{}, + Env2 :: #state{}. +env_root(Env) -> + case Env#state.outer of + undefined -> self(); + Outer -> gen_server:call(Outer, root) + end. diff --git a/impls/erlang/src/mal.app.src b/impls/erlang/src/mal.app.src index 11d54c1878..f42dcaef02 100644 --- a/impls/erlang/src/mal.app.src +++ b/impls/erlang/src/mal.app.src @@ -1,11 +1,11 @@ -{application, mal, [ - {description, "Make-a-Lisp Erlang"}, - {vsn, "1"}, - {registered, []}, - {applications, [ - kernel, - stdlib - ]}, - {mod, {mal_app, []}}, - {env, []} -]}. +{application, mal, [ + {description, "Make-a-Lisp Erlang"}, + {vsn, "1"}, + {registered, []}, + {applications, [ + kernel, + stdlib + ]}, + {mod, {mal_app, []}}, + {env, []} +]}. diff --git a/impls/erlang/src/printer.erl b/impls/erlang/src/printer.erl index 9c008d4964..48af1da6eb 100644 --- a/impls/erlang/src/printer.erl +++ b/impls/erlang/src/printer.erl @@ -1,59 +1,59 @@ -%%% -%%% Printer -%%% - --module(printer). - --export([pr_str/2, pr_list/5]). - --spec pr_str(term(), true|false) -> string(). -pr_str(Value, Readably) -> - case Value of - nil -> "nil"; - true -> "true"; - false -> "false"; - {atom, Atom} -> - AtomStr = pr_str(atom:deref(Atom), Readably), - io_lib:format("(atom ~s)", [AtomStr]); - {integer, Num} -> integer_to_list(Num); - {string, String} when Readably == true -> escape_str(String); - {string, String} when Readably == false -> String; - {keyword, Keyword} -> [$:|Keyword]; - {symbol, Symbol} -> Symbol; - {list, List, _Meta} -> pr_list(List, "(", ")", " ", Readably); - {vector, Vector, _Meta} -> pr_list(Vector, "[", "]", " ", Readably); - {map, Map, _Meta} -> pr_map(Map, Readably); - {closure, _Eval, Binds, Body, _Env, _Meta} -> - BindsStr = pr_str({list, Binds, nil}, Readably), - BodyStr = pr_str(Body, Readably), - io_lib:format("(fn* ~s ~s)", [BindsStr, BodyStr]); - {function, _Func, _Meta} -> "#"; - {macro, _Binds, _Body, _Env} -> "#"; - {error, Reason} -> io_lib:format("error: ~s", [Reason]) - end. - --spec pr_list([term()], string(), string(), string(), boolean()) -> string(). -pr_list(Seq, Start, End, Join, Readably) -> - Print = fun(Elem) -> - pr_str(Elem, Readably) - end, - L = string:join(lists:map(Print, Seq), Join), - Start ++ L ++ End. - -pr_map(Map, Readably) -> - AppendKV = fun({Key, Value}, AccIn) -> - AccIn ++ [Key, Value] - end, - Elements = lists:foldl(AppendKV, [], maps:to_list(Map)), - pr_list(Elements, "{", "}", " ", Readably). - -escape_str(String) -> - Escape = fun(C, AccIn) -> - case C of - $" -> [C, $\\|AccIn]; - $\\ -> [C, $\\|AccIn]; - $\n -> [$n, $\\|AccIn]; - _ -> [C|AccIn] - end - end, - "\"" ++ lists:reverse(lists:foldl(Escape, [], String)) ++ "\"". +%%% +%%% Printer +%%% + +-module(printer). + +-export([pr_str/2, pr_list/5]). + +-spec pr_str(term(), true|false) -> string(). +pr_str(Value, Readably) -> + case Value of + nil -> "nil"; + true -> "true"; + false -> "false"; + {atom, Atom} -> + AtomStr = pr_str(atom:deref(Atom), Readably), + io_lib:format("(atom ~s)", [AtomStr]); + {integer, Num} -> integer_to_list(Num); + {string, String} when Readably == true -> escape_str(String); + {string, String} when Readably == false -> String; + {keyword, Keyword} -> [$:|Keyword]; + {symbol, Symbol} -> Symbol; + {list, List, _Meta} -> pr_list(List, "(", ")", " ", Readably); + {vector, Vector, _Meta} -> pr_list(Vector, "[", "]", " ", Readably); + {map, Map, _Meta} -> pr_map(Map, Readably); + {closure, _Eval, Binds, Body, _Env, _Meta} -> + BindsStr = pr_str({list, Binds, nil}, Readably), + BodyStr = pr_str(Body, Readably), + io_lib:format("(fn* ~s ~s)", [BindsStr, BodyStr]); + {function, _Func, _Meta} -> "#"; + {macro, _Binds, _Body, _Env} -> "#"; + {error, Reason} -> io_lib:format("error: ~s", [Reason]) + end. + +-spec pr_list([term()], string(), string(), string(), boolean()) -> string(). +pr_list(Seq, Start, End, Join, Readably) -> + Print = fun(Elem) -> + pr_str(Elem, Readably) + end, + L = string:join(lists:map(Print, Seq), Join), + Start ++ L ++ End. + +pr_map(Map, Readably) -> + AppendKV = fun({Key, Value}, AccIn) -> + AccIn ++ [Key, Value] + end, + Elements = lists:foldl(AppendKV, [], maps:to_list(Map)), + pr_list(Elements, "{", "}", " ", Readably). + +escape_str(String) -> + Escape = fun(C, AccIn) -> + case C of + $" -> [C, $\\|AccIn]; + $\\ -> [C, $\\|AccIn]; + $\n -> [$n, $\\|AccIn]; + _ -> [C|AccIn] + end + end, + "\"" ++ lists:reverse(lists:foldl(Escape, [], String)) ++ "\"". diff --git a/impls/erlang/src/reader.erl b/impls/erlang/src/reader.erl index 97c7b41700..d6df2773f0 100644 --- a/impls/erlang/src/reader.erl +++ b/impls/erlang/src/reader.erl @@ -1,263 +1,263 @@ -%%% -%%% Reader -%%% - --module(reader). - --export([read_str/1, list_to_map/1]). - --record(reader, { - tokens=[], % the input tokens remaining - tree % the subtree parsed by a read_* function -}). - --spec read_str(string()) -> {ok, term()} | {error, term()}. -read_str(Input) -> - case tokenize(Input) of - {ok, []} -> {ok, none}; - {ok, Tokens} -> - case read_form(#reader{tokens=Tokens}) of - % extract the final result of parsing - {ok, Reader} -> {ok, Reader#reader.tree}; - {error, Reason} -> {error, Reason} - end; - {error, Reason} -> {error, Reason} - end. - --spec read_form(#reader{}) -> {ok, #reader{}} | {error, term()}. -read_form(Reader) -> - Token = peek(Reader), - case Token of - close_list -> {error, "unexected ')'"}; - close_vector -> {error, "unexected ']'"}; - close_map -> {error, "unexected '}'"}; - open_list -> read_list(Reader); - open_vector -> read_vector(Reader); - open_map -> read_map(Reader); - quote -> read_quoted(Reader, Token); - quasiquote -> read_quoted(Reader, Token); - unquote -> read_quoted(Reader, Token); - 'splice-unquote' -> read_quoted(Reader, Token); - deref -> read_quoted(Reader, Token); - 'with-meta' -> read_meta(Reader); - _ -> read_atom(Reader) - end. - -read_list(Reader) -> - read_seq(Reader, $), open_list, close_list, list). - -read_vector(Reader) -> - % Erlang has no array/vector type, so just use list - read_seq(Reader, $], open_vector, close_vector, vector). - -read_map(Reader) -> - case read_seq(Reader, $}, open_map, close_map, map) of - {ok, Reader1} -> - {map, Map, Meta} = Reader1#reader.tree, - case list_to_map(Map) of - {error, Reason} -> {error, Reason}; - NewMap -> - Tokens = Reader1#reader.tokens, - {ok, #reader{tokens=Tokens, tree={map, NewMap, Meta}}} - end; - {error, Reason} -> {error, Reason} - end. - -read_seq(Reader, CloseChar, OpenDelim, CloseDelim, Type) -> - {First, Reader1} = next(Reader), - case First of - OpenDelim -> - case read_seq_tail(Reader1, CloseChar, CloseDelim, []) of - {ok, Reader2} -> - % prepend our type tag to the result - Result = {Type, Reader2#reader.tree, nil}, - Reader3 = #reader{tokens=Reader2#reader.tokens, tree=Result}, - {ok, Reader3}; - {error, Reason} -> {error, Reason} - end; - Bogey -> {error, io_lib:format("error in read_seq, expected ~p but got ~p", - [OpenDelim, Bogey])} - end. - -read_seq_tail(Reader, CloseChar, CloseDelim, AccIn) -> - Token = peek(Reader), - case Token of - [] -> {error, io_lib:format("expected '~c', got EOF", [CloseChar])}; - CloseDelim -> - {_Token, Reader1} = next(Reader), - Reader2 = #reader{tokens=Reader1#reader.tokens, tree=lists:reverse(AccIn)}, - {ok, Reader2}; - _ -> - case read_form(Reader) of - {ok, Reader3} -> - read_seq_tail(Reader3, CloseChar, CloseDelim, [Reader3#reader.tree|AccIn]); - {error, Reason} -> {error, Reason} - end - end. - -% Convert a list of key/value pairs into a map. The elements are not -% tuples; the keys are the odd numbered members, and the values are the -% even numbered members. Fails if list has an odd number of members. -list_to_map(L) -> - list_to_map(L, #{}). - -list_to_map([], AccIn) -> - AccIn; -list_to_map([_H], _AccIn) -> - {error, "odd number of hash-map keys/values"}; -list_to_map([K,V|T], AccIn) -> - list_to_map(T, maps:put(K, V, AccIn)). - -% Convert syntactic sugar into normalized form (e.g. ` => (quasiquote)). -read_quoted(Reader, Token) -> - % discard the quoted token - {_T, Reader1} = next(Reader), - case read_form(Reader1) of - {ok, Reader2} -> - Result = {list, [{symbol, atom_to_list(Token)}, Reader2#reader.tree], nil}, - {ok, #reader{tokens=Reader2#reader.tokens, tree=Result}}; - {error, Reason} -> {error, Reason} - end. - -read_meta(Reader) -> - % discard the meta token - {_T, Reader1} = next(Reader), - case read_form(Reader1) of - {ok, Reader2} -> - M = Reader2#reader.tree, - case read_form(Reader2) of - {ok, Reader3} -> - X = Reader3#reader.tree, - Result = {list, [{symbol, "with-meta"}, X, M], nil}, - {ok, #reader{tokens=Reader3#reader.tokens, tree=Result}}; - {error, Reason} -> {error, Reason} - end; - {error, Reason} -> {error, Reason} - end. - -read_atom(Reader) -> - {Token, Reader1} = next(Reader), - Result = case Token of - {integer, Value} -> {integer, list_to_integer(Value)}; - {string, _String} -> Token; - {keyword, _Keyword} -> Token; - {symbol, Symbol} -> - case Symbol of - "true" -> true; - "false" -> false; - "nil" -> nil; - _ -> Token - end - end, - {ok, #reader{tokens=Reader1#reader.tokens, tree=Result}}. - -peek(Reader) -> - case Reader#reader.tokens of - [] -> []; - [H|_T] -> H - end. - -next(Reader) -> - [H|NewTokens] = Reader#reader.tokens, - {H, #reader{tokens=NewTokens}}. - --spec tokenize(string()) -> {ok, [term()]} | {error, term()}. -tokenize(Input) -> - tokenize(Input, []). - --spec tokenize(string(), [term()]) -> {ok, [term()]} | {error, term()}. -tokenize(Input, Tokens) -> - case lex_single(Input) of - eof -> {ok, lists:reverse(Tokens)}; - {error, Reason} -> {error, Reason}; - {ignored, Rest} -> tokenize(Rest, Tokens); - {Token, Rest} -> tokenize(Rest, [Token|Tokens]) - end. - -lex_single([]) -> - eof; -lex_single([Char|Rest]) -> - case Char of - $( -> {open_list, Rest}; - $) -> {close_list, Rest}; - $[ -> {open_vector, Rest}; - $] -> {close_vector, Rest}; - ${ -> {open_map, Rest}; - $} -> {close_map, Rest}; - $" -> lex_string(Rest, []); - $; -> lex_comment(Rest); - $: -> lex_symbol(Rest, keyword); - $' -> {quote, Rest}; - $` -> {quasiquote, Rest}; - $~ -> lex_unquote(Rest); - $@ -> {deref, Rest}; - $^ -> {'with-meta', Rest}; - N when N >= $0, N =< $9 -> lex_number(Rest, [Char]); - S when S == $- -> lex_minus_word(Char, Rest); - S when S == 32; S == $,; S == $\r; S == $\n; S == $\t -> lex_spaces(Rest); - $\\ -> {error, io_lib:format("bare escape literal ~c~c", [Char, hd(Rest)])}; - $. -> {error, "bare dot (.) not supported"}; - _ -> lex_symbol([Char|Rest], symbol) - end. - -lex_comment([]) -> - {ignored, []}; -lex_comment([C|Rest]) when C == $\r; C == $\n -> - {ignored, Rest}; -lex_comment([_C|Rest]) -> - lex_comment(Rest). - -lex_spaces([C|Rest]) when C == 32; C == $,; C == $\r; C == $\n; C == $\t -> - lex_spaces(Rest); -lex_spaces(Rest) -> - {ignored, Rest}. - -lex_string([], _String) -> - {error, "expected '\"', got EOF"}; -lex_string([$\\,Escaped|Rest], String) -> - % unescape the string while building it - case Escaped of - [] -> {error, "end of string reached in escape"}; - $n -> lex_string(Rest, [$\n|String]); - _ -> lex_string(Rest, [Escaped|String]) - end; -lex_string([$"|Rest], String) -> - {{string, lists:reverse(String)}, Rest}; -lex_string([C|Rest], String) -> - lex_string(Rest, [C|String]). - -lex_number([N|Rest], Number) when N >= $0, N =< $9 -> - lex_number(Rest, [N|Number]); -lex_number(Rest, Number) -> - {{integer, lists:reverse(Number)}, Rest}. - -lex_minus_word(Minus, [N|Rest]) when N >= $0, N =< $9 -> - lex_number([N|Rest], [Minus]); -lex_minus_word(Minus, Rest) -> - lex_symbol([Minus|Rest], symbol). - -% Lex the remainder of either a keyword or a symbol. The Type is used as -% the tag for the returned tuple (e.g. the atoms keyword or symbol). -lex_symbol(Input, Type) -> - IsSymbol = fun(C) -> - is_letter(C) orelse is_digit(C) orelse is_symbol(C) - end, - Symbol = lists:takewhile(IsSymbol, Input), - case Symbol of - [] -> {error, io_lib:format("invalid symbol: ~10s", [Input])}; - _ -> {{Type, Symbol}, lists:sublist(Input, length(Symbol) + 1, length(Input))} - end. - -is_digit(C) -> - C >= $0 andalso C =< $9. - -is_letter(C) -> - C >= $a andalso C =< $z orelse C >= $A andalso C =< $Z. - -is_symbol(C) -> - lists:member(C, "!#$%&*+-/:<=>?@^_|\~"). - -lex_unquote([$@|Rest]) -> - {'splice-unquote', Rest}; -lex_unquote(Rest) -> - {unquote, Rest}. +%%% +%%% Reader +%%% + +-module(reader). + +-export([read_str/1, list_to_map/1]). + +-record(reader, { + tokens=[], % the input tokens remaining + tree % the subtree parsed by a read_* function +}). + +-spec read_str(string()) -> {ok, term()} | {error, term()}. +read_str(Input) -> + case tokenize(Input) of + {ok, []} -> {ok, none}; + {ok, Tokens} -> + case read_form(#reader{tokens=Tokens}) of + % extract the final result of parsing + {ok, Reader} -> {ok, Reader#reader.tree}; + {error, Reason} -> {error, Reason} + end; + {error, Reason} -> {error, Reason} + end. + +-spec read_form(#reader{}) -> {ok, #reader{}} | {error, term()}. +read_form(Reader) -> + Token = peek(Reader), + case Token of + close_list -> {error, "unexected ')'"}; + close_vector -> {error, "unexected ']'"}; + close_map -> {error, "unexected '}'"}; + open_list -> read_list(Reader); + open_vector -> read_vector(Reader); + open_map -> read_map(Reader); + quote -> read_quoted(Reader, Token); + quasiquote -> read_quoted(Reader, Token); + unquote -> read_quoted(Reader, Token); + 'splice-unquote' -> read_quoted(Reader, Token); + deref -> read_quoted(Reader, Token); + 'with-meta' -> read_meta(Reader); + _ -> read_atom(Reader) + end. + +read_list(Reader) -> + read_seq(Reader, $), open_list, close_list, list). + +read_vector(Reader) -> + % Erlang has no array/vector type, so just use list + read_seq(Reader, $], open_vector, close_vector, vector). + +read_map(Reader) -> + case read_seq(Reader, $}, open_map, close_map, map) of + {ok, Reader1} -> + {map, Map, Meta} = Reader1#reader.tree, + case list_to_map(Map) of + {error, Reason} -> {error, Reason}; + NewMap -> + Tokens = Reader1#reader.tokens, + {ok, #reader{tokens=Tokens, tree={map, NewMap, Meta}}} + end; + {error, Reason} -> {error, Reason} + end. + +read_seq(Reader, CloseChar, OpenDelim, CloseDelim, Type) -> + {First, Reader1} = next(Reader), + case First of + OpenDelim -> + case read_seq_tail(Reader1, CloseChar, CloseDelim, []) of + {ok, Reader2} -> + % prepend our type tag to the result + Result = {Type, Reader2#reader.tree, nil}, + Reader3 = #reader{tokens=Reader2#reader.tokens, tree=Result}, + {ok, Reader3}; + {error, Reason} -> {error, Reason} + end; + Bogey -> {error, io_lib:format("error in read_seq, expected ~p but got ~p", + [OpenDelim, Bogey])} + end. + +read_seq_tail(Reader, CloseChar, CloseDelim, AccIn) -> + Token = peek(Reader), + case Token of + [] -> {error, io_lib:format("expected '~c', got EOF", [CloseChar])}; + CloseDelim -> + {_Token, Reader1} = next(Reader), + Reader2 = #reader{tokens=Reader1#reader.tokens, tree=lists:reverse(AccIn)}, + {ok, Reader2}; + _ -> + case read_form(Reader) of + {ok, Reader3} -> + read_seq_tail(Reader3, CloseChar, CloseDelim, [Reader3#reader.tree|AccIn]); + {error, Reason} -> {error, Reason} + end + end. + +% Convert a list of key/value pairs into a map. The elements are not +% tuples; the keys are the odd numbered members, and the values are the +% even numbered members. Fails if list has an odd number of members. +list_to_map(L) -> + list_to_map(L, #{}). + +list_to_map([], AccIn) -> + AccIn; +list_to_map([_H], _AccIn) -> + {error, "odd number of hash-map keys/values"}; +list_to_map([K,V|T], AccIn) -> + list_to_map(T, maps:put(K, V, AccIn)). + +% Convert syntactic sugar into normalized form (e.g. ` => (quasiquote)). +read_quoted(Reader, Token) -> + % discard the quoted token + {_T, Reader1} = next(Reader), + case read_form(Reader1) of + {ok, Reader2} -> + Result = {list, [{symbol, atom_to_list(Token)}, Reader2#reader.tree], nil}, + {ok, #reader{tokens=Reader2#reader.tokens, tree=Result}}; + {error, Reason} -> {error, Reason} + end. + +read_meta(Reader) -> + % discard the meta token + {_T, Reader1} = next(Reader), + case read_form(Reader1) of + {ok, Reader2} -> + M = Reader2#reader.tree, + case read_form(Reader2) of + {ok, Reader3} -> + X = Reader3#reader.tree, + Result = {list, [{symbol, "with-meta"}, X, M], nil}, + {ok, #reader{tokens=Reader3#reader.tokens, tree=Result}}; + {error, Reason} -> {error, Reason} + end; + {error, Reason} -> {error, Reason} + end. + +read_atom(Reader) -> + {Token, Reader1} = next(Reader), + Result = case Token of + {integer, Value} -> {integer, list_to_integer(Value)}; + {string, _String} -> Token; + {keyword, _Keyword} -> Token; + {symbol, Symbol} -> + case Symbol of + "true" -> true; + "false" -> false; + "nil" -> nil; + _ -> Token + end + end, + {ok, #reader{tokens=Reader1#reader.tokens, tree=Result}}. + +peek(Reader) -> + case Reader#reader.tokens of + [] -> []; + [H|_T] -> H + end. + +next(Reader) -> + [H|NewTokens] = Reader#reader.tokens, + {H, #reader{tokens=NewTokens}}. + +-spec tokenize(string()) -> {ok, [term()]} | {error, term()}. +tokenize(Input) -> + tokenize(Input, []). + +-spec tokenize(string(), [term()]) -> {ok, [term()]} | {error, term()}. +tokenize(Input, Tokens) -> + case lex_single(Input) of + eof -> {ok, lists:reverse(Tokens)}; + {error, Reason} -> {error, Reason}; + {ignored, Rest} -> tokenize(Rest, Tokens); + {Token, Rest} -> tokenize(Rest, [Token|Tokens]) + end. + +lex_single([]) -> + eof; +lex_single([Char|Rest]) -> + case Char of + $( -> {open_list, Rest}; + $) -> {close_list, Rest}; + $[ -> {open_vector, Rest}; + $] -> {close_vector, Rest}; + ${ -> {open_map, Rest}; + $} -> {close_map, Rest}; + $" -> lex_string(Rest, []); + $; -> lex_comment(Rest); + $: -> lex_symbol(Rest, keyword); + $' -> {quote, Rest}; + $` -> {quasiquote, Rest}; + $~ -> lex_unquote(Rest); + $@ -> {deref, Rest}; + $^ -> {'with-meta', Rest}; + N when N >= $0, N =< $9 -> lex_number(Rest, [Char]); + S when S == $- -> lex_minus_word(Char, Rest); + S when S == 32; S == $,; S == $\r; S == $\n; S == $\t -> lex_spaces(Rest); + $\\ -> {error, io_lib:format("bare escape literal ~c~c", [Char, hd(Rest)])}; + $. -> {error, "bare dot (.) not supported"}; + _ -> lex_symbol([Char|Rest], symbol) + end. + +lex_comment([]) -> + {ignored, []}; +lex_comment([C|Rest]) when C == $\r; C == $\n -> + {ignored, Rest}; +lex_comment([_C|Rest]) -> + lex_comment(Rest). + +lex_spaces([C|Rest]) when C == 32; C == $,; C == $\r; C == $\n; C == $\t -> + lex_spaces(Rest); +lex_spaces(Rest) -> + {ignored, Rest}. + +lex_string([], _String) -> + {error, "expected '\"', got EOF"}; +lex_string([$\\,Escaped|Rest], String) -> + % unescape the string while building it + case Escaped of + [] -> {error, "end of string reached in escape"}; + $n -> lex_string(Rest, [$\n|String]); + _ -> lex_string(Rest, [Escaped|String]) + end; +lex_string([$"|Rest], String) -> + {{string, lists:reverse(String)}, Rest}; +lex_string([C|Rest], String) -> + lex_string(Rest, [C|String]). + +lex_number([N|Rest], Number) when N >= $0, N =< $9 -> + lex_number(Rest, [N|Number]); +lex_number(Rest, Number) -> + {{integer, lists:reverse(Number)}, Rest}. + +lex_minus_word(Minus, [N|Rest]) when N >= $0, N =< $9 -> + lex_number([N|Rest], [Minus]); +lex_minus_word(Minus, Rest) -> + lex_symbol([Minus|Rest], symbol). + +% Lex the remainder of either a keyword or a symbol. The Type is used as +% the tag for the returned tuple (e.g. the atoms keyword or symbol). +lex_symbol(Input, Type) -> + IsSymbol = fun(C) -> + is_letter(C) orelse is_digit(C) orelse is_symbol(C) + end, + Symbol = lists:takewhile(IsSymbol, Input), + case Symbol of + [] -> {error, io_lib:format("invalid symbol: ~10s", [Input])}; + _ -> {{Type, Symbol}, lists:sublist(Input, length(Symbol) + 1, length(Input))} + end. + +is_digit(C) -> + C >= $0 andalso C =< $9. + +is_letter(C) -> + C >= $a andalso C =< $z orelse C >= $A andalso C =< $Z. + +is_symbol(C) -> + lists:member(C, "!#$%&*+-/:<=>?@^_|\~"). + +lex_unquote([$@|Rest]) -> + {'splice-unquote', Rest}; +lex_unquote(Rest) -> + {unquote, Rest}. diff --git a/impls/erlang/src/step0_repl.erl b/impls/erlang/src/step0_repl.erl index 54644cf924..715cb0ab20 100644 --- a/impls/erlang/src/step0_repl.erl +++ b/impls/erlang/src/step0_repl.erl @@ -1,30 +1,30 @@ -%%% -%%% Step 0: REPL -%%% - --module(step0_repl). - --export([main/1]). - -main(_) -> - case io:get_line(standard_io, "user> ") of - eof -> - % break out of the loop - io:format("~n"), - ok; - {error, Reason} -> - io:format("Error reading input: ~p~n", [Reason]), - exit(ioerr); - Line -> - io:format("~s~n", [print(eval(read(string:strip(Line, both, $\n))))]), - main("") - end. - -read(String) -> - String. - -eval(String) -> - String. - -print(String) -> - String. +%%% +%%% Step 0: REPL +%%% + +-module(step0_repl). + +-export([main/1]). + +main(_) -> + case io:get_line(standard_io, "user> ") of + eof -> + % break out of the loop + io:format("~n"), + ok; + {error, Reason} -> + io:format("Error reading input: ~p~n", [Reason]), + exit(ioerr); + Line -> + io:format("~s~n", [print(eval(read(string:strip(Line, both, $\n))))]), + main("") + end. + +read(String) -> + String. + +eval(String) -> + String. + +print(String) -> + String. diff --git a/impls/erlang/src/step1_read_print.erl b/impls/erlang/src/step1_read_print.erl index 4d8c398ae8..177592a2ac 100644 --- a/impls/erlang/src/step1_read_print.erl +++ b/impls/erlang/src/step1_read_print.erl @@ -1,36 +1,36 @@ -%%% -%%% Step 1: read/print -%%% - --module(step1_read_print). - --export([main/1]). - -main(_) -> - case io:get_line(standard_io, "user> ") of - eof -> - % break out of the loop - io:format("~n"), - ok; - {error, Reason} -> - io:format("Error reading input: ~s~n", [Reason]), - exit(ioerr); - Line -> - print(eval(read(string:strip(Line, both, $\n)))), - main("") - end. - -read(String) -> - case reader:read_str(String) of - {ok, Value} -> Value; - {error, Reason} -> io:format("error: ~s~n", [Reason]), nil - end. - -eval(Value) -> - Value. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [printer:pr_str(Value, true)]). +%%% +%%% Step 1: read/print +%%% + +-module(step1_read_print). + +-export([main/1]). + +main(_) -> + case io:get_line(standard_io, "user> ") of + eof -> + % break out of the loop + io:format("~n"), + ok; + {error, Reason} -> + io:format("Error reading input: ~s~n", [Reason]), + exit(ioerr); + Line -> + print(eval(read(string:strip(Line, both, $\n)))), + main("") + end. + +read(String) -> + case reader:read_str(String) of + {ok, Value} -> Value; + {error, Reason} -> io:format("error: ~s~n", [Reason]), nil + end. + +eval(Value) -> + Value. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [printer:pr_str(Value, true)]). diff --git a/impls/erlang/src/step2_eval.erl b/impls/erlang/src/step2_eval.erl index 39dfd6942c..ef1fd221eb 100644 --- a/impls/erlang/src/step2_eval.erl +++ b/impls/erlang/src/step2_eval.erl @@ -1,80 +1,80 @@ -%%% -%%% Step 2: eval -%%% - --module(step2_eval). - --export([main/1]). - -main(_) -> - Env = #{ - "+" => fun core:int_add/1, - "-" => fun core:int_sub/1, - "*" => fun core:int_mul/1, - "/" => fun core:int_div/1 - }, - loop(Env). - -loop(Env) -> - case io:get_line(standard_io, "user> ") of - eof -> - % break out of the loop - io:format("~n"), - ok; - {error, Reason} -> - io:format("Error reading input: ~s~n", [Reason]), - exit(ioerr); - Line -> - print(rep(string:strip(Line, both, $\n), Env)), - loop(Env) - end. - -rep(Input, Env) -> - AST = read(Input), - try eval(AST, Env) of - none -> none; - Result -> printer:pr_str(Result, true) - catch - error:Reason -> printer:pr_str({error, Reason}, true) - end. - -read(String) -> - case reader:read_str(String) of - {ok, Value} -> Value; - {error, Reason} -> io:format("error: ~s~n", [Reason]), nil - end. - -eval({list, [], _Meta}=AST, _Env) -> - AST; -eval({list, List, Meta}, Env) -> - case eval_ast({list, List, Meta}, Env) of - {list, [F|Args], _M} -> erlang:apply(F, [Args]); - _ -> {error, "expected a list"} - end; -eval(Value, Env) -> - eval_ast(Value, Env). - -eval_ast(Value, Env) -> - EvalList = fun(Elem) -> - eval(Elem, Env) - end, - EvalMap = fun(_Key, Val) -> - eval(Val, Env) - end, - case Value of - {symbol, Sym} -> - case maps:is_key(Sym, Env) of - true -> maps:get(Sym, Env); - false -> error(io_lib:format("'~s' not found", [Sym])) - end; - {list, L, Meta} -> {list, lists:map(EvalList, L), Meta}; - {vector, V, Meta} -> {vector, lists:map(EvalList, V), Meta}; - {map, M, Meta} -> {map, maps:map(EvalMap, M), Meta}; - _ -> Value - end. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [Value]). +%%% +%%% Step 2: eval +%%% + +-module(step2_eval). + +-export([main/1]). + +main(_) -> + Env = #{ + "+" => fun core:int_add/1, + "-" => fun core:int_sub/1, + "*" => fun core:int_mul/1, + "/" => fun core:int_div/1 + }, + loop(Env). + +loop(Env) -> + case io:get_line(standard_io, "user> ") of + eof -> + % break out of the loop + io:format("~n"), + ok; + {error, Reason} -> + io:format("Error reading input: ~s~n", [Reason]), + exit(ioerr); + Line -> + print(rep(string:strip(Line, both, $\n), Env)), + loop(Env) + end. + +rep(Input, Env) -> + AST = read(Input), + try eval(AST, Env) of + none -> none; + Result -> printer:pr_str(Result, true) + catch + error:Reason -> printer:pr_str({error, Reason}, true) + end. + +read(String) -> + case reader:read_str(String) of + {ok, Value} -> Value; + {error, Reason} -> io:format("error: ~s~n", [Reason]), nil + end. + +eval({list, [], _Meta}=AST, _Env) -> + AST; +eval({list, List, Meta}, Env) -> + case eval_ast({list, List, Meta}, Env) of + {list, [F|Args], _M} -> erlang:apply(F, [Args]); + _ -> {error, "expected a list"} + end; +eval(Value, Env) -> + eval_ast(Value, Env). + +eval_ast(Value, Env) -> + EvalList = fun(Elem) -> + eval(Elem, Env) + end, + EvalMap = fun(_Key, Val) -> + eval(Val, Env) + end, + case Value of + {symbol, Sym} -> + case maps:is_key(Sym, Env) of + true -> maps:get(Sym, Env); + false -> error(io_lib:format("'~s' not found", [Sym])) + end; + {list, L, Meta} -> {list, lists:map(EvalList, L), Meta}; + {vector, V, Meta} -> {vector, lists:map(EvalList, V), Meta}; + {map, M, Meta} -> {map, maps:map(EvalMap, M), Meta}; + _ -> Value + end. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [Value]). diff --git a/impls/erlang/src/step3_env.erl b/impls/erlang/src/step3_env.erl index 2abfbea88a..a64f7ea48b 100644 --- a/impls/erlang/src/step3_env.erl +++ b/impls/erlang/src/step3_env.erl @@ -1,100 +1,100 @@ -%%% -%%% Step 3: env -%%% - --module(step3_env). - --export([main/1]). - -main(_) -> - loop(core:ns()). - -loop(Env) -> - case io:get_line(standard_io, "user> ") of - eof -> io:format("~n"); - {error, Reason} -> exit(Reason); - Line -> - print(rep(string:strip(Line, both, $\n), Env)), - loop(Env) - end. - -rep(Input, Env) -> - try eval(read(Input), Env) of - none -> none; - Result -> printer:pr_str(Result, true) - catch - error:Reason -> printer:pr_str({error, Reason}, true) - end. - -read(Input) -> - case reader:read_str(Input) of - {ok, Value} -> Value; - {error, Reason} -> error(Reason) - end. - -eval({list, [], _Meta}=AST, _Env) -> - AST; -eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> - Result = eval(A2, Env), - env:set(Env, {symbol, A1}, Result), - Result; -eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> - error("def! called with non-symbol"); -eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> - error("def! requires exactly two arguments"); -eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> - NewEnv = env:new(Env), - let_star(NewEnv, A1), - eval(A2, NewEnv); -eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> - error("let* requires exactly two arguments"); -eval({list, List, Meta}, Env) -> - case eval_ast({list, List, Meta}, Env) of - {list, [{function, F, _MF}|A], _M1} -> erlang:apply(F, [A]); - _ -> error("expected a list with a function") - end; -eval(Value, Env) -> - eval_ast(Value, Env). - -eval_ast({symbol, _Sym}=Value, Env) -> - env:get(Env, Value); -eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> - {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; -eval_ast({map, M, _Meta}, Env) -> - {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; -eval_ast(Value, _Env) -> - Value. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [Value]). - -let_star(Env, Bindings) -> - % (let* (p (+ 2 3) q (+ 2 p)) (+ p q)) - % ;=>12 - Bind = fun({Name, Expr}) -> - case Name of - {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); - _ -> error("let* with non-symbol binding") - end - end, - case Bindings of - {Type, Binds, _Meta} when Type == list orelse Type == vector -> - case list_to_proplist(Binds) of - {error, Reason} -> error(Reason); - Props -> lists:foreach(Bind, Props) - end; - _ -> error("let* with non-list bindings") - end. - -list_to_proplist(L) -> - list_to_proplist(L, []). - -list_to_proplist([], AccIn) -> - lists:reverse(AccIn); -list_to_proplist([_H], _AccIn) -> - {error, "mismatch in let* name/value bindings"}; -list_to_proplist([K,V|T], AccIn) -> - list_to_proplist(T, [{K, V}|AccIn]). +%%% +%%% Step 3: env +%%% + +-module(step3_env). + +-export([main/1]). + +main(_) -> + loop(core:ns()). + +loop(Env) -> + case io:get_line(standard_io, "user> ") of + eof -> io:format("~n"); + {error, Reason} -> exit(Reason); + Line -> + print(rep(string:strip(Line, both, $\n), Env)), + loop(Env) + end. + +rep(Input, Env) -> + try eval(read(Input), Env) of + none -> none; + Result -> printer:pr_str(Result, true) + catch + error:Reason -> printer:pr_str({error, Reason}, true) + end. + +read(Input) -> + case reader:read_str(Input) of + {ok, Value} -> Value; + {error, Reason} -> error(Reason) + end. + +eval({list, [], _Meta}=AST, _Env) -> + AST; +eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> + Result = eval(A2, Env), + env:set(Env, {symbol, A1}, Result), + Result; +eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> + error("def! called with non-symbol"); +eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> + error("def! requires exactly two arguments"); +eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> + NewEnv = env:new(Env), + let_star(NewEnv, A1), + eval(A2, NewEnv); +eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> + error("let* requires exactly two arguments"); +eval({list, List, Meta}, Env) -> + case eval_ast({list, List, Meta}, Env) of + {list, [{function, F, _MF}|A], _M1} -> erlang:apply(F, [A]); + _ -> error("expected a list with a function") + end; +eval(Value, Env) -> + eval_ast(Value, Env). + +eval_ast({symbol, _Sym}=Value, Env) -> + env:get(Env, Value); +eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> + {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; +eval_ast({map, M, _Meta}, Env) -> + {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; +eval_ast(Value, _Env) -> + Value. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [Value]). + +let_star(Env, Bindings) -> + % (let* (p (+ 2 3) q (+ 2 p)) (+ p q)) + % ;=>12 + Bind = fun({Name, Expr}) -> + case Name of + {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); + _ -> error("let* with non-symbol binding") + end + end, + case Bindings of + {Type, Binds, _Meta} when Type == list orelse Type == vector -> + case list_to_proplist(Binds) of + {error, Reason} -> error(Reason); + Props -> lists:foreach(Bind, Props) + end; + _ -> error("let* with non-list bindings") + end. + +list_to_proplist(L) -> + list_to_proplist(L, []). + +list_to_proplist([], AccIn) -> + lists:reverse(AccIn); +list_to_proplist([_H], _AccIn) -> + {error, "mismatch in let* name/value bindings"}; +list_to_proplist([K,V|T], AccIn) -> + list_to_proplist(T, [{K, V}|AccIn]). diff --git a/impls/erlang/src/step4_if_fn_do.erl b/impls/erlang/src/step4_if_fn_do.erl index df8e82d3b7..bf673a9787 100644 --- a/impls/erlang/src/step4_if_fn_do.erl +++ b/impls/erlang/src/step4_if_fn_do.erl @@ -1,128 +1,128 @@ -%%% -%%% Step 4: if, fn, do -%%% - --module(step4_if_fn_do). - --export([main/1]). - -main(_) -> - Env = core:ns(), - % define the not function using mal itself - eval(read("(def! not (fn* (a) (if a false true)))"), Env), - loop(Env). - -loop(Env) -> - case io:get_line(standard_io, "user> ") of - eof -> io:format("~n"); - {error, Reason} -> exit(Reason); - Line -> - print(rep(string:strip(Line, both, $\n), Env)), - loop(Env) - end. - -rep(Input, Env) -> - try eval(read(Input), Env) of - none -> none; - Result -> printer:pr_str(Result, true) - catch - error:Reason -> printer:pr_str({error, Reason}, true) - end. - -read(Input) -> - case reader:read_str(Input) of - {ok, Value} -> Value; - {error, Reason} -> error(Reason) - end. - -eval({list, [], _Meta}=AST, _Env) -> - AST; -eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> - Result = eval(A2, Env), - env:set(Env, {symbol, A1}, Result), - Result; -eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> - error("def! called with non-symbol"); -eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> - error("def! requires exactly two arguments"); -eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> - NewEnv = env:new(Env), - let_star(NewEnv, A1), - eval(A2, NewEnv); -eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> - error("let* requires exactly two arguments"); -eval({list, [{symbol, "do"}|Args], _Meta}, Env) -> - {list, Results, _M2} = eval_ast({list, Args, nil}, Env), - lists:last(Results); -eval({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> - case eval(Test, Env) of - Cond when Cond == false orelse Cond == nil -> - case Alternate of - [] -> nil; - [A] -> eval(A, Env); - _ -> error("if takes 2 or 3 arguments") - end; - _ -> eval(Consequent, Env) - end; -eval({list, [{symbol, "if"}|_], _Meta}, _Env) -> - error("if requires test and consequent"); -eval({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> - error("fn* requires 2 arguments"); -eval({list, List, Meta}, Env) -> - case eval_ast({list, List, Meta}, Env) of - {list, [{closure, _Eval, Binds, Body, CE, _M1}|A], _M3} -> - % The args may be a single element or a list, so always make it - % a list and then flatten it so it becomes a list. - NewEnv = env:new(CE), - env:bind(NewEnv, Binds, lists:flatten([A])), - eval(Body, NewEnv); - {list, [{function, F, _MF}|A], _M4} -> erlang:apply(F, [A]); - _ -> error("expected a list") - end; -eval(Value, Env) -> - eval_ast(Value, Env). - -eval_ast({symbol, _Sym}=Value, Env) -> - env:get(Env, Value); -eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> - {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; -eval_ast({map, M, _Meta}, Env) -> - {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; -eval_ast(Value, _Env) -> - Value. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [Value]). - -let_star(Env, Bindings) -> - Bind = fun({Name, Expr}) -> - case Name of - {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); - _ -> error("let* with non-symbol binding") - end - end, - case Bindings of - {Type, Binds, _Meta} when Type == list orelse Type == vector -> - case list_to_proplist(Binds) of - {error, Reason} -> error(Reason); - Props -> lists:foreach(Bind, Props) - end; - _ -> error("let* with non-list bindings") - end. - -list_to_proplist(L) -> - list_to_proplist(L, []). - -list_to_proplist([], AccIn) -> - lists:reverse(AccIn); -list_to_proplist([_H], _AccIn) -> - {error, "mismatch in let* name/value bindings"}; -list_to_proplist([K,V|T], AccIn) -> - list_to_proplist(T, [{K, V}|AccIn]). +%%% +%%% Step 4: if, fn, do +%%% + +-module(step4_if_fn_do). + +-export([main/1]). + +main(_) -> + Env = core:ns(), + % define the not function using mal itself + eval(read("(def! not (fn* (a) (if a false true)))"), Env), + loop(Env). + +loop(Env) -> + case io:get_line(standard_io, "user> ") of + eof -> io:format("~n"); + {error, Reason} -> exit(Reason); + Line -> + print(rep(string:strip(Line, both, $\n), Env)), + loop(Env) + end. + +rep(Input, Env) -> + try eval(read(Input), Env) of + none -> none; + Result -> printer:pr_str(Result, true) + catch + error:Reason -> printer:pr_str({error, Reason}, true) + end. + +read(Input) -> + case reader:read_str(Input) of + {ok, Value} -> Value; + {error, Reason} -> error(Reason) + end. + +eval({list, [], _Meta}=AST, _Env) -> + AST; +eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> + Result = eval(A2, Env), + env:set(Env, {symbol, A1}, Result), + Result; +eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> + error("def! called with non-symbol"); +eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> + error("def! requires exactly two arguments"); +eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> + NewEnv = env:new(Env), + let_star(NewEnv, A1), + eval(A2, NewEnv); +eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> + error("let* requires exactly two arguments"); +eval({list, [{symbol, "do"}|Args], _Meta}, Env) -> + {list, Results, _M2} = eval_ast({list, Args, nil}, Env), + lists:last(Results); +eval({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> + case eval(Test, Env) of + Cond when Cond == false orelse Cond == nil -> + case Alternate of + [] -> nil; + [A] -> eval(A, Env); + _ -> error("if takes 2 or 3 arguments") + end; + _ -> eval(Consequent, Env) + end; +eval({list, [{symbol, "if"}|_], _Meta}, _Env) -> + error("if requires test and consequent"); +eval({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> + error("fn* requires 2 arguments"); +eval({list, List, Meta}, Env) -> + case eval_ast({list, List, Meta}, Env) of + {list, [{closure, _Eval, Binds, Body, CE, _M1}|A], _M3} -> + % The args may be a single element or a list, so always make it + % a list and then flatten it so it becomes a list. + NewEnv = env:new(CE), + env:bind(NewEnv, Binds, lists:flatten([A])), + eval(Body, NewEnv); + {list, [{function, F, _MF}|A], _M4} -> erlang:apply(F, [A]); + _ -> error("expected a list") + end; +eval(Value, Env) -> + eval_ast(Value, Env). + +eval_ast({symbol, _Sym}=Value, Env) -> + env:get(Env, Value); +eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> + {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; +eval_ast({map, M, _Meta}, Env) -> + {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; +eval_ast(Value, _Env) -> + Value. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [Value]). + +let_star(Env, Bindings) -> + Bind = fun({Name, Expr}) -> + case Name of + {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); + _ -> error("let* with non-symbol binding") + end + end, + case Bindings of + {Type, Binds, _Meta} when Type == list orelse Type == vector -> + case list_to_proplist(Binds) of + {error, Reason} -> error(Reason); + Props -> lists:foreach(Bind, Props) + end; + _ -> error("let* with non-list bindings") + end. + +list_to_proplist(L) -> + list_to_proplist(L, []). + +list_to_proplist([], AccIn) -> + lists:reverse(AccIn); +list_to_proplist([_H], _AccIn) -> + {error, "mismatch in let* name/value bindings"}; +list_to_proplist([K,V|T], AccIn) -> + list_to_proplist(T, [{K, V}|AccIn]). diff --git a/impls/erlang/src/step5_tco.erl b/impls/erlang/src/step5_tco.erl index 933d7450e6..ce74c2fc4b 100644 --- a/impls/erlang/src/step5_tco.erl +++ b/impls/erlang/src/step5_tco.erl @@ -1,128 +1,128 @@ -%%% -%%% Step 5: Tail call optimization -%%% - --module(step5_tco). - --export([main/1]). - -main(_) -> - Env = core:ns(), - % define the not function using mal itself - eval(read("(def! not (fn* (a) (if a false true)))"), Env), - loop(Env). - -loop(Env) -> - case io:get_line(standard_io, "user> ") of - eof -> io:format("~n"); - {error, Reason} -> exit(Reason); - Line -> - print(rep(string:strip(Line, both, $\n), Env)), - loop(Env) - end. - -rep(Input, Env) -> - try eval(read(Input), Env) of - none -> none; - Result -> printer:pr_str(Result, true) - catch - error:Reason -> printer:pr_str({error, Reason}, true) - end. - -read(Input) -> - case reader:read_str(Input) of - {ok, Value} -> Value; - {error, Reason} -> error(Reason) - end. - -eval({list, [], _Meta}=AST, _Env) -> - AST; -eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> - Result = eval(A2, Env), - env:set(Env, {symbol, A1}, Result), - Result; -eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> - error("def! called with non-symbol"); -eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> - error("def! requires exactly two arguments"); -eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> - NewEnv = env:new(Env), - let_star(NewEnv, A1), - eval(A2, NewEnv); -eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> - error("let* requires exactly two arguments"); -eval({list, [{symbol, "do"}|Args], _Meta}, Env) -> - eval_ast({list, lists:droplast(Args), nil}, Env), - eval(lists:last(Args), Env); -eval({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> - case eval(Test, Env) of - Cond when Cond == false orelse Cond == nil -> - case Alternate of - [] -> nil; - [A] -> eval(A, Env); - _ -> error("if takes 2 or 3 arguments") - end; - _ -> eval(Consequent, Env) - end; -eval({list, [{symbol, "if"}|_], _Meta}, _Env) -> - error("if requires test and consequent"); -eval({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> - error("fn* requires 2 arguments"); -eval({list, List, Meta}, Env) -> - case eval_ast({list, List, Meta}, Env) of - {list, [{closure, _Eval, Binds, Body, CE, _M2}|A], _M3} -> - % The args may be a single element or a list, so always make it - % a list and then flatten it so it becomes a list. - NewEnv = env:new(CE), - env:bind(NewEnv, Binds, lists:flatten([A])), - eval(Body, NewEnv); - {list, [{function, F, _MF}|A], _M4} -> erlang:apply(F, [A]); - _ -> error("expected a list") - end; -eval(Value, Env) -> - eval_ast(Value, Env). - -eval_ast({symbol, _Sym}=Value, Env) -> - env:get(Env, Value); -eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> - {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; -eval_ast({map, M, _Meta}, Env) -> - {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; -eval_ast(Value, _Env) -> - Value. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [Value]). - -let_star(Env, Bindings) -> - Bind = fun({Name, Expr}) -> - case Name of - {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); - _ -> error("let* with non-symbol binding") - end - end, - case Bindings of - {Type, Binds, _Meta} when Type == list orelse Type == vector -> - case list_to_proplist(Binds) of - {error, Reason} -> error(Reason); - Props -> lists:foreach(Bind, Props) - end; - _ -> error("let* with non-list bindings") - end. - -list_to_proplist(L) -> - list_to_proplist(L, []). - -list_to_proplist([], AccIn) -> - lists:reverse(AccIn); -list_to_proplist([_H], _AccIn) -> - {error, "mismatch in let* name/value bindings"}; -list_to_proplist([K,V|T], AccIn) -> - list_to_proplist(T, [{K, V}|AccIn]). +%%% +%%% Step 5: Tail call optimization +%%% + +-module(step5_tco). + +-export([main/1]). + +main(_) -> + Env = core:ns(), + % define the not function using mal itself + eval(read("(def! not (fn* (a) (if a false true)))"), Env), + loop(Env). + +loop(Env) -> + case io:get_line(standard_io, "user> ") of + eof -> io:format("~n"); + {error, Reason} -> exit(Reason); + Line -> + print(rep(string:strip(Line, both, $\n), Env)), + loop(Env) + end. + +rep(Input, Env) -> + try eval(read(Input), Env) of + none -> none; + Result -> printer:pr_str(Result, true) + catch + error:Reason -> printer:pr_str({error, Reason}, true) + end. + +read(Input) -> + case reader:read_str(Input) of + {ok, Value} -> Value; + {error, Reason} -> error(Reason) + end. + +eval({list, [], _Meta}=AST, _Env) -> + AST; +eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> + Result = eval(A2, Env), + env:set(Env, {symbol, A1}, Result), + Result; +eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> + error("def! called with non-symbol"); +eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> + error("def! requires exactly two arguments"); +eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> + NewEnv = env:new(Env), + let_star(NewEnv, A1), + eval(A2, NewEnv); +eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> + error("let* requires exactly two arguments"); +eval({list, [{symbol, "do"}|Args], _Meta}, Env) -> + eval_ast({list, lists:droplast(Args), nil}, Env), + eval(lists:last(Args), Env); +eval({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> + case eval(Test, Env) of + Cond when Cond == false orelse Cond == nil -> + case Alternate of + [] -> nil; + [A] -> eval(A, Env); + _ -> error("if takes 2 or 3 arguments") + end; + _ -> eval(Consequent, Env) + end; +eval({list, [{symbol, "if"}|_], _Meta}, _Env) -> + error("if requires test and consequent"); +eval({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> + error("fn* requires 2 arguments"); +eval({list, List, Meta}, Env) -> + case eval_ast({list, List, Meta}, Env) of + {list, [{closure, _Eval, Binds, Body, CE, _M2}|A], _M3} -> + % The args may be a single element or a list, so always make it + % a list and then flatten it so it becomes a list. + NewEnv = env:new(CE), + env:bind(NewEnv, Binds, lists:flatten([A])), + eval(Body, NewEnv); + {list, [{function, F, _MF}|A], _M4} -> erlang:apply(F, [A]); + _ -> error("expected a list") + end; +eval(Value, Env) -> + eval_ast(Value, Env). + +eval_ast({symbol, _Sym}=Value, Env) -> + env:get(Env, Value); +eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> + {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; +eval_ast({map, M, _Meta}, Env) -> + {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; +eval_ast(Value, _Env) -> + Value. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [Value]). + +let_star(Env, Bindings) -> + Bind = fun({Name, Expr}) -> + case Name of + {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); + _ -> error("let* with non-symbol binding") + end + end, + case Bindings of + {Type, Binds, _Meta} when Type == list orelse Type == vector -> + case list_to_proplist(Binds) of + {error, Reason} -> error(Reason); + Props -> lists:foreach(Bind, Props) + end; + _ -> error("let* with non-list bindings") + end. + +list_to_proplist(L) -> + list_to_proplist(L, []). + +list_to_proplist([], AccIn) -> + lists:reverse(AccIn); +list_to_proplist([_H], _AccIn) -> + {error, "mismatch in let* name/value bindings"}; +list_to_proplist([K,V|T], AccIn) -> + list_to_proplist(T, [{K, V}|AccIn]). diff --git a/impls/erlang/src/step6_file.erl b/impls/erlang/src/step6_file.erl index 0a37f26c69..8502f45abc 100644 --- a/impls/erlang/src/step6_file.erl +++ b/impls/erlang/src/step6_file.erl @@ -1,145 +1,145 @@ -%%% -%%% Step 6: File and evil -%%% - --module(step6_file). - --export([main/1]). - -main([File|Args]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), - rep("(load-file \"" ++ File ++ "\")", Env); -main([]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), - loop(Env). - -init() -> - Env = core:ns(), - % define the load-file and not functions using mal itself - eval(read("(def! not (fn* (a) (if a false true)))"), Env), - eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), - Env. - -loop(Env) -> - case io:get_line(standard_io, "user> ") of - eof -> io:format("~n"); - {error, Reason} -> exit(Reason); - Line -> - print(rep(string:strip(Line, both, $\n), Env)), - loop(Env) - end. - -rep(Input, Env) -> - try eval(read(Input), Env) of - none -> none; - Result -> printer:pr_str(Result, true) - catch - error:Reason -> printer:pr_str({error, Reason}, true) - end. - -read(Input) -> - case reader:read_str(Input) of - {ok, Value} -> Value; - {error, Reason} -> error(Reason) - end. - -eval({list, [], _Meta}=AST, _Env) -> - AST; -eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> - Result = eval(A2, Env), - env:set(Env, {symbol, A1}, Result), - Result; -eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> - error("def! called with non-symbol"); -eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> - error("def! requires exactly two arguments"); -eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> - NewEnv = env:new(Env), - let_star(NewEnv, A1), - eval(A2, NewEnv); -eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> - error("let* requires exactly two arguments"); -eval({list, [{symbol, "do"}|Args], _Meta}, Env) -> - eval_ast({list, lists:droplast(Args), nil}, Env), - eval(lists:last(Args), Env); -eval({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> - case eval(Test, Env) of - Cond when Cond == false orelse Cond == nil -> - case Alternate of - [] -> nil; - [A] -> eval(A, Env); - _ -> error("if takes 2 or 3 arguments") - end; - _ -> eval(Consequent, Env) - end; -eval({list, [{symbol, "if"}|_], _Meta}, _Env) -> - error("if requires test and consequent"); -eval({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> - error("fn* requires 2 arguments"); -eval({list, [{symbol, "eval"}, AST], _Meta}, Env) -> - % Must use the root environment so the variables set within the parsed - % expression will be visible within the repl. - eval(eval(AST, Env), env:root(Env)); -eval({list, [{symbol, "eval"}|_], _Meta}, _Env) -> - error("eval requires 1 argument"); -eval({list, List, Meta}, Env) -> - case eval_ast({list, List, Meta}, Env) of - {list, [{closure, _Eval, Binds, Body, CE, _M1}|A], _M2} -> - % The args may be a single element or a list, so always make it - % a list and then flatten it so it becomes a list. - NewEnv = env:new(CE), - env:bind(NewEnv, Binds, lists:flatten([A])), - eval(Body, NewEnv); - {list, [{function, F, _MF}|A], _M3} -> erlang:apply(F, [A]); - {list, [{error, Reason}], _M4} -> {error, Reason}; - _ -> error("expected a list") - end; -eval(Value, Env) -> - eval_ast(Value, Env). - -eval_ast({symbol, _Sym}=Value, Env) -> - env:get(Env, Value); -eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> - {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; -eval_ast({map, M, _Meta}, Env) -> - {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; -eval_ast(Value, _Env) -> - Value. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [Value]). - -let_star(Env, Bindings) -> - Bind = fun({Name, Expr}) -> - case Name of - {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); - _ -> error("let* with non-symbol binding") - end - end, - case Bindings of - {Type, Binds, _Meta} when Type == list orelse Type == vector -> - case list_to_proplist(Binds) of - {error, Reason} -> error(Reason); - Props -> lists:foreach(Bind, Props) - end; - _ -> error("let* with non-list bindings") - end. - -list_to_proplist(L) -> - list_to_proplist(L, []). - -list_to_proplist([], AccIn) -> - lists:reverse(AccIn); -list_to_proplist([_H], _AccIn) -> - {error, "mismatch in let* name/value bindings"}; -list_to_proplist([K,V|T], AccIn) -> - list_to_proplist(T, [{K, V}|AccIn]). +%%% +%%% Step 6: File and evil +%%% + +-module(step6_file). + +-export([main/1]). + +main([File|Args]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), + rep("(load-file \"" ++ File ++ "\")", Env); +main([]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), + loop(Env). + +init() -> + Env = core:ns(), + % define the load-file and not functions using mal itself + eval(read("(def! not (fn* (a) (if a false true)))"), Env), + eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), + Env. + +loop(Env) -> + case io:get_line(standard_io, "user> ") of + eof -> io:format("~n"); + {error, Reason} -> exit(Reason); + Line -> + print(rep(string:strip(Line, both, $\n), Env)), + loop(Env) + end. + +rep(Input, Env) -> + try eval(read(Input), Env) of + none -> none; + Result -> printer:pr_str(Result, true) + catch + error:Reason -> printer:pr_str({error, Reason}, true) + end. + +read(Input) -> + case reader:read_str(Input) of + {ok, Value} -> Value; + {error, Reason} -> error(Reason) + end. + +eval({list, [], _Meta}=AST, _Env) -> + AST; +eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> + Result = eval(A2, Env), + env:set(Env, {symbol, A1}, Result), + Result; +eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> + error("def! called with non-symbol"); +eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> + error("def! requires exactly two arguments"); +eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> + NewEnv = env:new(Env), + let_star(NewEnv, A1), + eval(A2, NewEnv); +eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> + error("let* requires exactly two arguments"); +eval({list, [{symbol, "do"}|Args], _Meta}, Env) -> + eval_ast({list, lists:droplast(Args), nil}, Env), + eval(lists:last(Args), Env); +eval({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> + case eval(Test, Env) of + Cond when Cond == false orelse Cond == nil -> + case Alternate of + [] -> nil; + [A] -> eval(A, Env); + _ -> error("if takes 2 or 3 arguments") + end; + _ -> eval(Consequent, Env) + end; +eval({list, [{symbol, "if"}|_], _Meta}, _Env) -> + error("if requires test and consequent"); +eval({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> + error("fn* requires 2 arguments"); +eval({list, [{symbol, "eval"}, AST], _Meta}, Env) -> + % Must use the root environment so the variables set within the parsed + % expression will be visible within the repl. + eval(eval(AST, Env), env:root(Env)); +eval({list, [{symbol, "eval"}|_], _Meta}, _Env) -> + error("eval requires 1 argument"); +eval({list, List, Meta}, Env) -> + case eval_ast({list, List, Meta}, Env) of + {list, [{closure, _Eval, Binds, Body, CE, _M1}|A], _M2} -> + % The args may be a single element or a list, so always make it + % a list and then flatten it so it becomes a list. + NewEnv = env:new(CE), + env:bind(NewEnv, Binds, lists:flatten([A])), + eval(Body, NewEnv); + {list, [{function, F, _MF}|A], _M3} -> erlang:apply(F, [A]); + {list, [{error, Reason}], _M4} -> {error, Reason}; + _ -> error("expected a list") + end; +eval(Value, Env) -> + eval_ast(Value, Env). + +eval_ast({symbol, _Sym}=Value, Env) -> + env:get(Env, Value); +eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> + {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; +eval_ast({map, M, _Meta}, Env) -> + {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; +eval_ast(Value, _Env) -> + Value. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [Value]). + +let_star(Env, Bindings) -> + Bind = fun({Name, Expr}) -> + case Name of + {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); + _ -> error("let* with non-symbol binding") + end + end, + case Bindings of + {Type, Binds, _Meta} when Type == list orelse Type == vector -> + case list_to_proplist(Binds) of + {error, Reason} -> error(Reason); + Props -> lists:foreach(Bind, Props) + end; + _ -> error("let* with non-list bindings") + end. + +list_to_proplist(L) -> + list_to_proplist(L, []). + +list_to_proplist([], AccIn) -> + lists:reverse(AccIn); +list_to_proplist([_H], _AccIn) -> + {error, "mismatch in let* name/value bindings"}; +list_to_proplist([K,V|T], AccIn) -> + list_to_proplist(T, [{K, V}|AccIn]). diff --git a/impls/erlang/src/step7_quote.erl b/impls/erlang/src/step7_quote.erl index 8588afbd0d..9e4e4a4743 100644 --- a/impls/erlang/src/step7_quote.erl +++ b/impls/erlang/src/step7_quote.erl @@ -1,179 +1,179 @@ -%%% -%%% Step 7: Quoting -%%% - --module(step7_quote). - --export([main/1]). - -main([File|Args]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), - rep("(load-file \"" ++ File ++ "\")", Env); -main([]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), - loop(Env). - -init() -> - Env = core:ns(), - % define the load-file and not functions using mal itself - eval(read("(def! not (fn* (a) (if a false true)))"), Env), - eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), - Env. - -loop(Env) -> - case io:get_line(standard_io, "user> ") of - eof -> io:format("~n"); - {error, Reason} -> exit(Reason); - Line -> - print(rep(string:strip(Line, both, $\n), Env)), - loop(Env) - end. - -rep(Input, Env) -> - try eval(read(Input), Env) of - none -> none; - Result -> printer:pr_str(Result, true) - catch - error:Reason -> printer:pr_str({error, Reason}, true) - end. - -read(Input) -> - case reader:read_str(Input) of - {ok, Value} -> Value; - {error, Reason} -> error(Reason) - end. - -eval({list, [], _Meta}=AST, _Env) -> - AST; -eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> - Result = eval(A2, Env), - env:set(Env, {symbol, A1}, Result), - Result; -eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> - error("def! called with non-symbol"); -eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> - error("def! requires exactly two arguments"); -eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> - NewEnv = env:new(Env), - let_star(NewEnv, A1), - eval(A2, NewEnv); -eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> - error("let* requires exactly two arguments"); -eval({list, [{symbol, "do"}|Args], _Meta}, Env) -> - eval_ast({list, lists:droplast(Args), nil}, Env), - eval(lists:last(Args), Env); -eval({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> - case eval(Test, Env) of - Cond when Cond == false orelse Cond == nil -> - case Alternate of - [] -> nil; - [A] -> eval(A, Env); - _ -> error("if takes 2 or 3 arguments") - end; - _ -> eval(Consequent, Env) - end; -eval({list, [{symbol, "if"}|_], _Meta}, _Env) -> - error("if requires test and consequent"); -eval({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> - error("fn* requires 2 arguments"); -eval({list, [{symbol, "eval"}, AST], _Meta}, Env) -> - % Must use the root environment so the variables set within the parsed - % expression will be visible within the repl. - eval(eval(AST, Env), env:root(Env)); -eval({list, [{symbol, "eval"}|_], _Meta}, _Env) -> - error("eval requires 1 argument"); -eval({list, [{symbol, "quote"}, AST], _Meta}, _Env) -> - AST; -eval({list, [{symbol, "quote"}|_], _Meta}, _Env) -> - error("quote requires 1 argument"); -eval({list, [{symbol, "quasiquoteexpand"}, AST], _Meta}, Env) -> - quasiquote(AST); -eval({list, [{symbol, "quasiquoteexpand"}|_], _Meta}, _Env) -> - error("quasiquoteexpand requires 1 argument"); -eval({list, [{symbol, "quasiquote"}, AST], _Meta}, Env) -> - eval(quasiquote(AST), Env); -eval({list, [{symbol, "quasiquote"}|_], _Meta}, _Env) -> - error("quasiquote requires 1 argument"); -eval({list, List, Meta}, Env) -> - case eval_ast({list, List, Meta}, Env) of - {list, [{closure, _Eval, Binds, Body, CE, _M1}|A], _M2} -> - % The args may be a single element or a list, so always make it - % a list and then flatten it so it becomes a list. - NewEnv = env:new(CE), - env:bind(NewEnv, Binds, lists:flatten([A])), - eval(Body, NewEnv); - {list, [{function, F, _MF}|A], _M3} -> erlang:apply(F, [A]); - {list, [{error, Reason}], _M4} -> {error, Reason}; - _ -> error("expected a list") - end; -eval(Value, Env) -> - eval_ast(Value, Env). - -eval_ast({symbol, _Sym}=Value, Env) -> - env:get(Env, Value); -eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> - {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; -eval_ast({map, M, _Meta}, Env) -> - {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; -eval_ast(Value, _Env) -> - Value. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [Value]). - -let_star(Env, Bindings) -> - Bind = fun({Name, Expr}) -> - case Name of - {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); - _ -> error("let* with non-symbol binding") - end - end, - case Bindings of - {Type, Binds, _Meta} when Type == list orelse Type == vector -> - case list_to_proplist(Binds) of - {error, Reason} -> error(Reason); - Props -> lists:foreach(Bind, Props) - end; - _ -> error("let* with non-list bindings") - end. - -list_to_proplist(L) -> - list_to_proplist(L, []). - -list_to_proplist([], AccIn) -> - lists:reverse(AccIn); -list_to_proplist([_H], _AccIn) -> - {error, "mismatch in let* name/value bindings"}; -list_to_proplist([K,V|T], AccIn) -> - list_to_proplist(T, [{K, V}|AccIn]). - -qqLoop ({list, [{symbol, "splice-unquote"}, Arg], _Meta}, Acc) -> - {list, [{symbol, "concat"}, Arg, Acc], nil}; -qqLoop({list, [{symbol, "splice-unquote"}|_], _Meta}, _Acc) -> - {error, "splice-unquote requires an argument"}; -qqLoop(Elt, Acc) -> - {list, [{symbol, "cons"}, quasiquote(Elt), Acc], nil}. - -quasiquote({list, [{symbol, "unquote"}, Arg], _Meta}) -> - Arg; -quasiquote({list, [{symbol, "unquote"}|_], _Meta}) -> - error("unquote requires 1 argument"); -quasiquote({list, List, _Meta}) -> - lists:foldr(fun qqLoop/2, {list, [], nil}, List); -quasiquote({vector, List, _Meta}) -> - {list, [{symbol, "vec"}, lists:foldr(fun qqLoop/2, {list, [], nil}, List)], nil}; -quasiquote({symbol, _Symbol} = Arg) -> - {list, [{symbol, "quote"}, Arg], nil}; -quasiquote({map, _Map, _Meta} = Arg) -> - {list, [{symbol, "quote"}, Arg], nil}; -quasiquote(Arg) -> - Arg. +%%% +%%% Step 7: Quoting +%%% + +-module(step7_quote). + +-export([main/1]). + +main([File|Args]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), + rep("(load-file \"" ++ File ++ "\")", Env); +main([]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), + loop(Env). + +init() -> + Env = core:ns(), + % define the load-file and not functions using mal itself + eval(read("(def! not (fn* (a) (if a false true)))"), Env), + eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), + Env. + +loop(Env) -> + case io:get_line(standard_io, "user> ") of + eof -> io:format("~n"); + {error, Reason} -> exit(Reason); + Line -> + print(rep(string:strip(Line, both, $\n), Env)), + loop(Env) + end. + +rep(Input, Env) -> + try eval(read(Input), Env) of + none -> none; + Result -> printer:pr_str(Result, true) + catch + error:Reason -> printer:pr_str({error, Reason}, true) + end. + +read(Input) -> + case reader:read_str(Input) of + {ok, Value} -> Value; + {error, Reason} -> error(Reason) + end. + +eval({list, [], _Meta}=AST, _Env) -> + AST; +eval({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> + Result = eval(A2, Env), + env:set(Env, {symbol, A1}, Result), + Result; +eval({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> + error("def! called with non-symbol"); +eval({list, [{symbol, "def!"}|_], _Meta}, _Env) -> + error("def! requires exactly two arguments"); +eval({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> + NewEnv = env:new(Env), + let_star(NewEnv, A1), + eval(A2, NewEnv); +eval({list, [{symbol, "let*"}|_], _Meta}, _Env) -> + error("let* requires exactly two arguments"); +eval({list, [{symbol, "do"}|Args], _Meta}, Env) -> + eval_ast({list, lists:droplast(Args), nil}, Env), + eval(lists:last(Args), Env); +eval({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> + case eval(Test, Env) of + Cond when Cond == false orelse Cond == nil -> + case Alternate of + [] -> nil; + [A] -> eval(A, Env); + _ -> error("if takes 2 or 3 arguments") + end; + _ -> eval(Consequent, Env) + end; +eval({list, [{symbol, "if"}|_], _Meta}, _Env) -> + error("if requires test and consequent"); +eval({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> + error("fn* requires 2 arguments"); +eval({list, [{symbol, "eval"}, AST], _Meta}, Env) -> + % Must use the root environment so the variables set within the parsed + % expression will be visible within the repl. + eval(eval(AST, Env), env:root(Env)); +eval({list, [{symbol, "eval"}|_], _Meta}, _Env) -> + error("eval requires 1 argument"); +eval({list, [{symbol, "quote"}, AST], _Meta}, _Env) -> + AST; +eval({list, [{symbol, "quote"}|_], _Meta}, _Env) -> + error("quote requires 1 argument"); +eval({list, [{symbol, "quasiquoteexpand"}, AST], _Meta}, Env) -> + quasiquote(AST); +eval({list, [{symbol, "quasiquoteexpand"}|_], _Meta}, _Env) -> + error("quasiquoteexpand requires 1 argument"); +eval({list, [{symbol, "quasiquote"}, AST], _Meta}, Env) -> + eval(quasiquote(AST), Env); +eval({list, [{symbol, "quasiquote"}|_], _Meta}, _Env) -> + error("quasiquote requires 1 argument"); +eval({list, List, Meta}, Env) -> + case eval_ast({list, List, Meta}, Env) of + {list, [{closure, _Eval, Binds, Body, CE, _M1}|A], _M2} -> + % The args may be a single element or a list, so always make it + % a list and then flatten it so it becomes a list. + NewEnv = env:new(CE), + env:bind(NewEnv, Binds, lists:flatten([A])), + eval(Body, NewEnv); + {list, [{function, F, _MF}|A], _M3} -> erlang:apply(F, [A]); + {list, [{error, Reason}], _M4} -> {error, Reason}; + _ -> error("expected a list") + end; +eval(Value, Env) -> + eval_ast(Value, Env). + +eval_ast({symbol, _Sym}=Value, Env) -> + env:get(Env, Value); +eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> + {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; +eval_ast({map, M, _Meta}, Env) -> + {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; +eval_ast(Value, _Env) -> + Value. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [Value]). + +let_star(Env, Bindings) -> + Bind = fun({Name, Expr}) -> + case Name of + {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); + _ -> error("let* with non-symbol binding") + end + end, + case Bindings of + {Type, Binds, _Meta} when Type == list orelse Type == vector -> + case list_to_proplist(Binds) of + {error, Reason} -> error(Reason); + Props -> lists:foreach(Bind, Props) + end; + _ -> error("let* with non-list bindings") + end. + +list_to_proplist(L) -> + list_to_proplist(L, []). + +list_to_proplist([], AccIn) -> + lists:reverse(AccIn); +list_to_proplist([_H], _AccIn) -> + {error, "mismatch in let* name/value bindings"}; +list_to_proplist([K,V|T], AccIn) -> + list_to_proplist(T, [{K, V}|AccIn]). + +qqLoop ({list, [{symbol, "splice-unquote"}, Arg], _Meta}, Acc) -> + {list, [{symbol, "concat"}, Arg, Acc], nil}; +qqLoop({list, [{symbol, "splice-unquote"}|_], _Meta}, _Acc) -> + {error, "splice-unquote requires an argument"}; +qqLoop(Elt, Acc) -> + {list, [{symbol, "cons"}, quasiquote(Elt), Acc], nil}. + +quasiquote({list, [{symbol, "unquote"}, Arg], _Meta}) -> + Arg; +quasiquote({list, [{symbol, "unquote"}|_], _Meta}) -> + error("unquote requires 1 argument"); +quasiquote({list, List, _Meta}) -> + lists:foldr(fun qqLoop/2, {list, [], nil}, List); +quasiquote({vector, List, _Meta}) -> + {list, [{symbol, "vec"}, lists:foldr(fun qqLoop/2, {list, [], nil}, List)], nil}; +quasiquote({symbol, _Symbol} = Arg) -> + {list, [{symbol, "quote"}, Arg], nil}; +quasiquote({map, _Map, _Meta} = Arg) -> + {list, [{symbol, "quote"}, Arg], nil}; +quasiquote(Arg) -> + Arg. diff --git a/impls/erlang/src/step8_macros.erl b/impls/erlang/src/step8_macros.erl index 1e024f73c3..bc2c8b27d9 100644 --- a/impls/erlang/src/step8_macros.erl +++ b/impls/erlang/src/step8_macros.erl @@ -1,232 +1,232 @@ -%%% -%%% Step 8: Macros -%%% - --module(step8_macros). - --export([main/1]). - -main([File|Args]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), - rep("(load-file \"" ++ File ++ "\")", Env); -main([]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), - loop(Env). - -init() -> - Env = core:ns(), - eval(read("(def! not (fn* (a) (if a false true)))"), Env), - eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), - eval(read("(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)))))))"), Env), - Env. - -loop(Env) -> - case io:get_line(standard_io, "user> ") of - eof -> io:format("~n"); - {error, Reason} -> exit(Reason); - Line -> - print(rep(string:strip(Line, both, $\n), Env)), - loop(Env) - end. - -rep(Input, Env) -> - try eval(read(Input), Env) of - none -> none; - Result -> printer:pr_str(Result, true) - catch - error:Reason -> printer:pr_str({error, Reason}, true) - end. - -read(Input) -> - case reader:read_str(Input) of - {ok, Value} -> Value; - {error, Reason} -> error(Reason) - end. - -eval(Value, Env) -> - case Value of - {list, _L1, _M1} -> - case macroexpand(Value, Env) of - {list, _L2, _M2} = List -> eval_list(List, Env); - AST -> eval_ast(AST, Env) - end; - _ -> eval_ast(Value, Env) - end. - -eval_list({list, [], _Meta}=AST, _Env) -> - AST; -eval_list({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> - Result = eval(A2, Env), - case Result of - {error, _R1} -> Result; - _ -> - env:set(Env, {symbol, A1}, Result), - Result - end; -eval_list({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> - error("def! called with non-symbol"); -eval_list({list, [{symbol, "def!"}|_], _Meta}, _Env) -> - error("def! requires exactly two arguments"); -eval_list({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> - NewEnv = env:new(Env), - let_star(NewEnv, A1), - eval(A2, NewEnv); -eval_list({list, [{symbol, "let*"}|_], _Meta}, _Env) -> - error("let* requires exactly two arguments"); -eval_list({list, [{symbol, "do"}|Args], _Meta}, Env) -> - eval_ast({list, lists:droplast(Args), nil}, Env), - eval(lists:last(Args), Env); -eval_list({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> - case eval(Test, Env) of - Cond when Cond == false orelse Cond == nil -> - case Alternate of - [] -> nil; - [A] -> eval(A, Env); - _ -> error("if takes 2 or 3 arguments") - end; - _ -> eval(Consequent, Env) - end; -eval_list({list, [{symbol, "if"}|_], _Meta}, _Env) -> - error("if requires test and consequent"); -eval_list({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval_list({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval_list({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> - error("fn* requires 2 arguments"); -eval_list({list, [{symbol, "eval"}, AST], _Meta}, Env) -> - % Must use the root environment so the variables set within the parsed - % expression will be visible within the repl. - eval(eval(AST, Env), env:root(Env)); -eval_list({list, [{symbol, "eval"}|_], _Meta}, _Env) -> - error("eval requires 1 argument"); -eval_list({list, [{symbol, "quote"}, AST], _Meta}, _Env) -> - AST; -eval_list({list, [{symbol, "quote"}|_], _Meta}, _Env) -> - error("quote requires 1 argument"); -eval_list({list, [{symbol, "quasiquoteexpand"}, AST], _Meta}, Env) -> - quasiquote(AST); -eval_list({list, [{symbol, "quasiquoteexpand"}|_], _Meta}, _Env) -> - error("quasiquoteexpand requires 1 argument"); -eval_list({list, [{symbol, "quasiquote"}, AST], _Meta}, Env) -> - eval(quasiquote(AST), Env); -eval_list({list, [{symbol, "quasiquote"}|_], _Meta}, _Env) -> - error("quasiquote requires 1 argument"); -eval_list({list, [{symbol, "defmacro!"}, {symbol, A1}, A2], _Meta}, Env) -> - case eval(A2, Env) of - {closure, _Eval, Binds, Body, CE, _M1} -> - Result = {macro, Binds, Body, CE}, - env:set(Env, {symbol, A1}, Result), - Result; - Result -> env:set(Env, {symbol, A1}, Result), Result - end, - Result; -eval_list({list, [{symbol, "defmacro!"}, _A1, _A2], _Meta}, _Env) -> - error("defmacro! called with non-symbol"); -eval_list({list, [{symbol, "defmacro!"}|_], _Meta}, _Env) -> - error("defmacro! requires exactly two arguments"); -eval_list({list, [{symbol, "macroexpand"}, Macro], _Meta}, Env) -> - macroexpand(Macro, Env); -eval_list({list, [{symbol, "macroexpand"}], _Meta}, _Env) -> - error("macroexpand requires 1 argument"); -eval_list({list, List, Meta}, Env) -> - case eval_ast({list, List, Meta}, Env) of - {list, [{closure, _Eval, Binds, Body, CE, _MC}|A], _M1} -> - % The args may be a single element or a list, so always make it - % a list and then flatten it so it becomes a list. - NewEnv = env:new(CE), - env:bind(NewEnv, Binds, lists:flatten([A])), - eval(Body, NewEnv); - {list, [{function, F, _MF}|A], _M2} -> erlang:apply(F, [A]); - {list, [{error, Reason}], _M3} -> {error, Reason}; - _ -> error("expected a list") - end. - -eval_ast({symbol, _Sym}=Value, Env) -> - env:get(Env, Value); -eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> - {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; -eval_ast({map, M, _Meta}, Env) -> - {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; -eval_ast(Value, _Env) -> - Value. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [Value]). - -let_star(Env, Bindings) -> - Bind = fun({Name, Expr}) -> - case Name of - {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); - _ -> error("let* with non-symbol binding") - end - end, - case Bindings of - {Type, Binds, _Meta} when Type == list orelse Type == vector -> - case list_to_proplist(Binds) of - {error, Reason} -> error(Reason); - Props -> lists:foreach(Bind, Props) - end; - _ -> error("let* with non-list bindings") - end. - -list_to_proplist(L) -> - list_to_proplist(L, []). - -list_to_proplist([], AccIn) -> - lists:reverse(AccIn); -list_to_proplist([_H], _AccIn) -> - {error, "mismatch in let* name/value bindings"}; -list_to_proplist([K,V|T], AccIn) -> - list_to_proplist(T, [{K, V}|AccIn]). - -qqLoop ({list, [{symbol, "splice-unquote"}, Arg], _Meta}, Acc) -> - {list, [{symbol, "concat"}, Arg, Acc], nil}; -qqLoop({list, [{symbol, "splice-unquote"}|_], _Meta}, _Acc) -> - {error, "splice-unquote requires an argument"}; -qqLoop(Elt, Acc) -> - {list, [{symbol, "cons"}, quasiquote(Elt), Acc], nil}. - -quasiquote({list, [{symbol, "unquote"}, Arg], _Meta}) -> - Arg; -quasiquote({list, [{symbol, "unquote"}|_], _Meta}) -> - error("unquote requires 1 argument"); -quasiquote({list, List, _Meta}) -> - lists:foldr(fun qqLoop/2, {list, [], nil}, List); -quasiquote({vector, List, _Meta}) -> - {list, [{symbol, "vec"}, lists:foldr(fun qqLoop/2, {list, [], nil}, List)], nil}; -quasiquote({symbol, _Symbol} = Arg) -> - {list, [{symbol, "quote"}, Arg], nil}; -quasiquote({map, _Map, _Meta} = Arg) -> - {list, [{symbol, "quote"}, Arg], nil}; -quasiquote(Arg) -> - Arg. - -is_macro_call({list, [{symbol, Name}|_], _Meta}, Env) -> - case env:find(Env, {symbol, Name}) of - nil -> false; - Env2 -> - case env:get(Env2, {symbol, Name}) of - {macro, _Binds, _Body, _ME} -> true; - _ -> false - end - end; -is_macro_call(_AST, _Env) -> - false. - -macroexpand(AST, Env) -> - case is_macro_call(AST, Env) of - true -> - {list, [Name|A], _Meta} = AST, - {macro, Binds, Body, ME} = env:get(Env, Name), - NewEnv = env:new(ME), - env:bind(NewEnv, Binds, lists:flatten([A])), - NewAST = eval(Body, NewEnv), - macroexpand(NewAST, Env); - false -> AST - end. +%%% +%%% Step 8: Macros +%%% + +-module(step8_macros). + +-export([main/1]). + +main([File|Args]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), + rep("(load-file \"" ++ File ++ "\")", Env); +main([]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), + loop(Env). + +init() -> + Env = core:ns(), + eval(read("(def! not (fn* (a) (if a false true)))"), Env), + eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), + eval(read("(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)))))))"), Env), + Env. + +loop(Env) -> + case io:get_line(standard_io, "user> ") of + eof -> io:format("~n"); + {error, Reason} -> exit(Reason); + Line -> + print(rep(string:strip(Line, both, $\n), Env)), + loop(Env) + end. + +rep(Input, Env) -> + try eval(read(Input), Env) of + none -> none; + Result -> printer:pr_str(Result, true) + catch + error:Reason -> printer:pr_str({error, Reason}, true) + end. + +read(Input) -> + case reader:read_str(Input) of + {ok, Value} -> Value; + {error, Reason} -> error(Reason) + end. + +eval(Value, Env) -> + case Value of + {list, _L1, _M1} -> + case macroexpand(Value, Env) of + {list, _L2, _M2} = List -> eval_list(List, Env); + AST -> eval_ast(AST, Env) + end; + _ -> eval_ast(Value, Env) + end. + +eval_list({list, [], _Meta}=AST, _Env) -> + AST; +eval_list({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> + Result = eval(A2, Env), + case Result of + {error, _R1} -> Result; + _ -> + env:set(Env, {symbol, A1}, Result), + Result + end; +eval_list({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> + error("def! called with non-symbol"); +eval_list({list, [{symbol, "def!"}|_], _Meta}, _Env) -> + error("def! requires exactly two arguments"); +eval_list({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> + NewEnv = env:new(Env), + let_star(NewEnv, A1), + eval(A2, NewEnv); +eval_list({list, [{symbol, "let*"}|_], _Meta}, _Env) -> + error("let* requires exactly two arguments"); +eval_list({list, [{symbol, "do"}|Args], _Meta}, Env) -> + eval_ast({list, lists:droplast(Args), nil}, Env), + eval(lists:last(Args), Env); +eval_list({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> + case eval(Test, Env) of + Cond when Cond == false orelse Cond == nil -> + case Alternate of + [] -> nil; + [A] -> eval(A, Env); + _ -> error("if takes 2 or 3 arguments") + end; + _ -> eval(Consequent, Env) + end; +eval_list({list, [{symbol, "if"}|_], _Meta}, _Env) -> + error("if requires test and consequent"); +eval_list({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval_list({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval_list({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> + error("fn* requires 2 arguments"); +eval_list({list, [{symbol, "eval"}, AST], _Meta}, Env) -> + % Must use the root environment so the variables set within the parsed + % expression will be visible within the repl. + eval(eval(AST, Env), env:root(Env)); +eval_list({list, [{symbol, "eval"}|_], _Meta}, _Env) -> + error("eval requires 1 argument"); +eval_list({list, [{symbol, "quote"}, AST], _Meta}, _Env) -> + AST; +eval_list({list, [{symbol, "quote"}|_], _Meta}, _Env) -> + error("quote requires 1 argument"); +eval_list({list, [{symbol, "quasiquoteexpand"}, AST], _Meta}, Env) -> + quasiquote(AST); +eval_list({list, [{symbol, "quasiquoteexpand"}|_], _Meta}, _Env) -> + error("quasiquoteexpand requires 1 argument"); +eval_list({list, [{symbol, "quasiquote"}, AST], _Meta}, Env) -> + eval(quasiquote(AST), Env); +eval_list({list, [{symbol, "quasiquote"}|_], _Meta}, _Env) -> + error("quasiquote requires 1 argument"); +eval_list({list, [{symbol, "defmacro!"}, {symbol, A1}, A2], _Meta}, Env) -> + case eval(A2, Env) of + {closure, _Eval, Binds, Body, CE, _M1} -> + Result = {macro, Binds, Body, CE}, + env:set(Env, {symbol, A1}, Result), + Result; + Result -> env:set(Env, {symbol, A1}, Result), Result + end, + Result; +eval_list({list, [{symbol, "defmacro!"}, _A1, _A2], _Meta}, _Env) -> + error("defmacro! called with non-symbol"); +eval_list({list, [{symbol, "defmacro!"}|_], _Meta}, _Env) -> + error("defmacro! requires exactly two arguments"); +eval_list({list, [{symbol, "macroexpand"}, Macro], _Meta}, Env) -> + macroexpand(Macro, Env); +eval_list({list, [{symbol, "macroexpand"}], _Meta}, _Env) -> + error("macroexpand requires 1 argument"); +eval_list({list, List, Meta}, Env) -> + case eval_ast({list, List, Meta}, Env) of + {list, [{closure, _Eval, Binds, Body, CE, _MC}|A], _M1} -> + % The args may be a single element or a list, so always make it + % a list and then flatten it so it becomes a list. + NewEnv = env:new(CE), + env:bind(NewEnv, Binds, lists:flatten([A])), + eval(Body, NewEnv); + {list, [{function, F, _MF}|A], _M2} -> erlang:apply(F, [A]); + {list, [{error, Reason}], _M3} -> {error, Reason}; + _ -> error("expected a list") + end. + +eval_ast({symbol, _Sym}=Value, Env) -> + env:get(Env, Value); +eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> + {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; +eval_ast({map, M, _Meta}, Env) -> + {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; +eval_ast(Value, _Env) -> + Value. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [Value]). + +let_star(Env, Bindings) -> + Bind = fun({Name, Expr}) -> + case Name of + {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); + _ -> error("let* with non-symbol binding") + end + end, + case Bindings of + {Type, Binds, _Meta} when Type == list orelse Type == vector -> + case list_to_proplist(Binds) of + {error, Reason} -> error(Reason); + Props -> lists:foreach(Bind, Props) + end; + _ -> error("let* with non-list bindings") + end. + +list_to_proplist(L) -> + list_to_proplist(L, []). + +list_to_proplist([], AccIn) -> + lists:reverse(AccIn); +list_to_proplist([_H], _AccIn) -> + {error, "mismatch in let* name/value bindings"}; +list_to_proplist([K,V|T], AccIn) -> + list_to_proplist(T, [{K, V}|AccIn]). + +qqLoop ({list, [{symbol, "splice-unquote"}, Arg], _Meta}, Acc) -> + {list, [{symbol, "concat"}, Arg, Acc], nil}; +qqLoop({list, [{symbol, "splice-unquote"}|_], _Meta}, _Acc) -> + {error, "splice-unquote requires an argument"}; +qqLoop(Elt, Acc) -> + {list, [{symbol, "cons"}, quasiquote(Elt), Acc], nil}. + +quasiquote({list, [{symbol, "unquote"}, Arg], _Meta}) -> + Arg; +quasiquote({list, [{symbol, "unquote"}|_], _Meta}) -> + error("unquote requires 1 argument"); +quasiquote({list, List, _Meta}) -> + lists:foldr(fun qqLoop/2, {list, [], nil}, List); +quasiquote({vector, List, _Meta}) -> + {list, [{symbol, "vec"}, lists:foldr(fun qqLoop/2, {list, [], nil}, List)], nil}; +quasiquote({symbol, _Symbol} = Arg) -> + {list, [{symbol, "quote"}, Arg], nil}; +quasiquote({map, _Map, _Meta} = Arg) -> + {list, [{symbol, "quote"}, Arg], nil}; +quasiquote(Arg) -> + Arg. + +is_macro_call({list, [{symbol, Name}|_], _Meta}, Env) -> + case env:find(Env, {symbol, Name}) of + nil -> false; + Env2 -> + case env:get(Env2, {symbol, Name}) of + {macro, _Binds, _Body, _ME} -> true; + _ -> false + end + end; +is_macro_call(_AST, _Env) -> + false. + +macroexpand(AST, Env) -> + case is_macro_call(AST, Env) of + true -> + {list, [Name|A], _Meta} = AST, + {macro, Binds, Body, ME} = env:get(Env, Name), + NewEnv = env:new(ME), + env:bind(NewEnv, Binds, lists:flatten([A])), + NewAST = eval(Body, NewEnv), + macroexpand(NewAST, Env); + false -> AST + end. diff --git a/impls/erlang/src/step9_try.erl b/impls/erlang/src/step9_try.erl index 7bf67834f0..8dc61afb70 100644 --- a/impls/erlang/src/step9_try.erl +++ b/impls/erlang/src/step9_try.erl @@ -1,250 +1,250 @@ -%%% -%%% Step 9: Try -%%% - --module(step9_try). - --export([main/1]). - -main([File|Args]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), - rep("(load-file \"" ++ File ++ "\")", Env); -main([]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), - loop(Env). - -init() -> - Env = core:ns(), - eval(read("(def! not (fn* (a) (if a false true)))"), Env), - eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), - eval(read("(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)))))))"), Env), - Env. - -loop(Env) -> - case io:get_line(standard_io, "user> ") of - eof -> io:format("~n"); - {error, Reason} -> exit(Reason); - Line -> - print(rep(string:strip(Line, both, $\n), Env)), - loop(Env) - end. - -rep(Input, Env) -> - try eval(read(Input), Env) of - none -> none; - Result -> printer:pr_str(Result, true) - catch - error:Reason -> printer:pr_str({error, Reason}, true); - throw:Reason -> printer:pr_str({error, printer:pr_str(Reason, true)}, true) - end. - -read(Input) -> - case reader:read_str(Input) of - {ok, Value} -> Value; - {error, Reason} -> error(Reason) - end. - -eval(Value, Env) -> - case Value of - {list, _L1, _M1} -> - case macroexpand(Value, Env) of - {list, _L2, _M2} = List -> eval_list(List, Env); - AST -> eval_ast(AST, Env) - end; - _ -> eval_ast(Value, Env) - end. - -eval_list({list, [], _Meta}=AST, _Env) -> - AST; -eval_list({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> - Result = eval(A2, Env), - case Result of - {error, _R1} -> Result; - _ -> - env:set(Env, {symbol, A1}, Result), - Result - end; -eval_list({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> - error("def! called with non-symbol"); -eval_list({list, [{symbol, "def!"}|_], _Meta}, _Env) -> - error("def! requires exactly two arguments"); -eval_list({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> - NewEnv = env:new(Env), - let_star(NewEnv, A1), - eval(A2, NewEnv); -eval_list({list, [{symbol, "let*"}|_], _Meta}, _Env) -> - error("let* requires exactly two arguments"); -eval_list({list, [{symbol, "do"}|Args], _Meta}, Env) -> - eval_ast({list, lists:droplast(Args), nil}, Env), - eval(lists:last(Args), Env); -eval_list({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> - case eval(Test, Env) of - Cond when Cond == false orelse Cond == nil -> - case Alternate of - [] -> nil; - [A] -> eval(A, Env); - _ -> error("if takes 2 or 3 arguments") - end; - _ -> eval(Consequent, Env) - end; -eval_list({list, [{symbol, "if"}|_], _Meta}, _Env) -> - error("if requires test and consequent"); -eval_list({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval_list({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval_list({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> - error("fn* requires 2 arguments"); -eval_list({list, [{symbol, "eval"}, AST], _Meta}, Env) -> - % Must use the root environment so the variables set within the parsed - % expression will be visible within the repl. - eval(eval(AST, Env), env:root(Env)); -eval_list({list, [{symbol, "eval"}|_], _Meta}, _Env) -> - error("eval requires 1 argument"); -eval_list({list, [{symbol, "quote"}, AST], _Meta}, _Env) -> - AST; -eval_list({list, [{symbol, "quote"}|_], _Meta}, _Env) -> - error("quote requires 1 argument"); -eval_list({list, [{symbol, "quasiquoteexpand"}, AST], _Meta}, Env) -> - quasiquote(AST); -eval_list({list, [{symbol, "quasiquoteexpand"}|_], _Meta}, _Env) -> - error("quasiquoteexpand requires 1 argument"); -eval_list({list, [{symbol, "quasiquote"}, AST], _Meta}, Env) -> - eval(quasiquote(AST), Env); -eval_list({list, [{symbol, "quasiquote"}|_], _Meta}, _Env) -> - error("quasiquote requires 1 argument"); -eval_list({list, [{symbol, "defmacro!"}, {symbol, A1}, A2], _Meta}, Env) -> - case eval(A2, Env) of - {closure, _Eval, Binds, Body, CE, _MC} -> - Result = {macro, Binds, Body, CE}, - env:set(Env, {symbol, A1}, Result), - Result; - Result -> env:set(Env, {symbol, A1}, Result), Result - end, - Result; -eval_list({list, [{symbol, "defmacro!"}, _A1, _A2], _Meta}, _Env) -> - error("defmacro! called with non-symbol"); -eval_list({list, [{symbol, "defmacro!"}|_], _Meta}, _Env) -> - error("defmacro! requires exactly two arguments"); -eval_list({list, [{symbol, "macroexpand"}, Macro], _Meta}, Env) -> - macroexpand(Macro, Env); -eval_list({list, [{symbol, "macroexpand"}], _Meta}, _Env) -> - error("macroexpand requires 1 argument"); -eval_list({list, [{symbol, "try*"}, A, {list, [{symbol, "catch*"}, B, C], _M1}], _M2}, Env) -> - try eval(A, Env) of - Result -> Result - catch - error:Reason -> - NewEnv = env:new(Env), - env:bind(NewEnv, [B], [{string, Reason}]), - eval(C, NewEnv); - throw:Reason -> - NewEnv = env:new(Env), - env:bind(NewEnv, [B], [Reason]), - eval(C, NewEnv) - end; -eval_list({list, [{symbol, "try*"}, AST], _Meta}, Env) -> - eval(AST, Env); -eval_list({list, [{symbol, "try*"}|_], _Meta}, _Env) -> - error("try*/catch* must be of the form (try* A (catch* B C))"); -eval_list({list, List, Meta}, Env) -> - case eval_ast({list, List, Meta}, Env) of - {list, [{closure, _Eval, Binds, Body, CE, _MC}|A], _M1} -> - % The args may be a single element or a list, so always make it - % a list and then flatten it so it becomes a list. - NewEnv = env:new(CE), - env:bind(NewEnv, Binds, lists:flatten([A])), - eval(Body, NewEnv); - {list, [{function, F, _MF}|A], _M2} -> erlang:apply(F, [A]); - {list, [{error, Reason}], _M3} -> {error, Reason}; - _ -> error("expected a list") - end. - -eval_ast({symbol, _Sym}=Value, Env) -> - env:get(Env, Value); -eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> - {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; -eval_ast({map, M, _Meta}, Env) -> - {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; -eval_ast(Value, _Env) -> - Value. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [Value]). - -let_star(Env, Bindings) -> - Bind = fun({Name, Expr}) -> - case Name of - {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); - _ -> error("let* with non-symbol binding") - end - end, - case Bindings of - {Type, Binds, _Meta} when Type == list orelse Type == vector -> - case list_to_proplist(Binds) of - {error, Reason} -> error(Reason); - Props -> lists:foreach(Bind, Props) - end; - _ -> error("let* with non-list bindings") - end. - -list_to_proplist(L) -> - list_to_proplist(L, []). - -list_to_proplist([], AccIn) -> - lists:reverse(AccIn); -list_to_proplist([_H], _AccIn) -> - {error, "mismatch in let* name/value bindings"}; -list_to_proplist([K,V|T], AccIn) -> - list_to_proplist(T, [{K, V}|AccIn]). - -qqLoop ({list, [{symbol, "splice-unquote"}, Arg], _Meta}, Acc) -> - {list, [{symbol, "concat"}, Arg, Acc], nil}; -qqLoop({list, [{symbol, "splice-unquote"}|_], _Meta}, _Acc) -> - {error, "splice-unquote requires an argument"}; -qqLoop(Elt, Acc) -> - {list, [{symbol, "cons"}, quasiquote(Elt), Acc], nil}. - -quasiquote({list, [{symbol, "unquote"}, Arg], _Meta}) -> - Arg; -quasiquote({list, [{symbol, "unquote"}|_], _Meta}) -> - error("unquote requires 1 argument"); -quasiquote({list, List, _Meta}) -> - lists:foldr(fun qqLoop/2, {list, [], nil}, List); -quasiquote({vector, List, _Meta}) -> - {list, [{symbol, "vec"}, lists:foldr(fun qqLoop/2, {list, [], nil}, List)], nil}; -quasiquote({symbol, _Symbol} = Arg) -> - {list, [{symbol, "quote"}, Arg], nil}; -quasiquote({map, _Map, _Meta} = Arg) -> - {list, [{symbol, "quote"}, Arg], nil}; -quasiquote(Arg) -> - Arg. - -is_macro_call({list, [{symbol, Name}|_], _Meta}, Env) -> - case env:find(Env, {symbol, Name}) of - nil -> false; - Env2 -> - case env:get(Env2, {symbol, Name}) of - {macro, _Binds, _Body, _ME} -> true; - _ -> false - end - end; -is_macro_call(_AST, _Env) -> - false. - -macroexpand(AST, Env) -> - case is_macro_call(AST, Env) of - true -> - {list, [Name|A], _M2} = AST, - {macro, Binds, Body, ME} = env:get(Env, Name), - NewEnv = env:new(ME), - env:bind(NewEnv, Binds, lists:flatten([A])), - NewAST = eval(Body, NewEnv), - macroexpand(NewAST, Env); - false -> AST - end. +%%% +%%% Step 9: Try +%%% + +-module(step9_try). + +-export([main/1]). + +main([File|Args]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), + rep("(load-file \"" ++ File ++ "\")", Env); +main([]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), + loop(Env). + +init() -> + Env = core:ns(), + eval(read("(def! not (fn* (a) (if a false true)))"), Env), + eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), + eval(read("(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)))))))"), Env), + Env. + +loop(Env) -> + case io:get_line(standard_io, "user> ") of + eof -> io:format("~n"); + {error, Reason} -> exit(Reason); + Line -> + print(rep(string:strip(Line, both, $\n), Env)), + loop(Env) + end. + +rep(Input, Env) -> + try eval(read(Input), Env) of + none -> none; + Result -> printer:pr_str(Result, true) + catch + error:Reason -> printer:pr_str({error, Reason}, true); + throw:Reason -> printer:pr_str({error, printer:pr_str(Reason, true)}, true) + end. + +read(Input) -> + case reader:read_str(Input) of + {ok, Value} -> Value; + {error, Reason} -> error(Reason) + end. + +eval(Value, Env) -> + case Value of + {list, _L1, _M1} -> + case macroexpand(Value, Env) of + {list, _L2, _M2} = List -> eval_list(List, Env); + AST -> eval_ast(AST, Env) + end; + _ -> eval_ast(Value, Env) + end. + +eval_list({list, [], _Meta}=AST, _Env) -> + AST; +eval_list({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> + Result = eval(A2, Env), + case Result of + {error, _R1} -> Result; + _ -> + env:set(Env, {symbol, A1}, Result), + Result + end; +eval_list({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> + error("def! called with non-symbol"); +eval_list({list, [{symbol, "def!"}|_], _Meta}, _Env) -> + error("def! requires exactly two arguments"); +eval_list({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> + NewEnv = env:new(Env), + let_star(NewEnv, A1), + eval(A2, NewEnv); +eval_list({list, [{symbol, "let*"}|_], _Meta}, _Env) -> + error("let* requires exactly two arguments"); +eval_list({list, [{symbol, "do"}|Args], _Meta}, Env) -> + eval_ast({list, lists:droplast(Args), nil}, Env), + eval(lists:last(Args), Env); +eval_list({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> + case eval(Test, Env) of + Cond when Cond == false orelse Cond == nil -> + case Alternate of + [] -> nil; + [A] -> eval(A, Env); + _ -> error("if takes 2 or 3 arguments") + end; + _ -> eval(Consequent, Env) + end; +eval_list({list, [{symbol, "if"}|_], _Meta}, _Env) -> + error("if requires test and consequent"); +eval_list({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval_list({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval_list({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> + error("fn* requires 2 arguments"); +eval_list({list, [{symbol, "eval"}, AST], _Meta}, Env) -> + % Must use the root environment so the variables set within the parsed + % expression will be visible within the repl. + eval(eval(AST, Env), env:root(Env)); +eval_list({list, [{symbol, "eval"}|_], _Meta}, _Env) -> + error("eval requires 1 argument"); +eval_list({list, [{symbol, "quote"}, AST], _Meta}, _Env) -> + AST; +eval_list({list, [{symbol, "quote"}|_], _Meta}, _Env) -> + error("quote requires 1 argument"); +eval_list({list, [{symbol, "quasiquoteexpand"}, AST], _Meta}, Env) -> + quasiquote(AST); +eval_list({list, [{symbol, "quasiquoteexpand"}|_], _Meta}, _Env) -> + error("quasiquoteexpand requires 1 argument"); +eval_list({list, [{symbol, "quasiquote"}, AST], _Meta}, Env) -> + eval(quasiquote(AST), Env); +eval_list({list, [{symbol, "quasiquote"}|_], _Meta}, _Env) -> + error("quasiquote requires 1 argument"); +eval_list({list, [{symbol, "defmacro!"}, {symbol, A1}, A2], _Meta}, Env) -> + case eval(A2, Env) of + {closure, _Eval, Binds, Body, CE, _MC} -> + Result = {macro, Binds, Body, CE}, + env:set(Env, {symbol, A1}, Result), + Result; + Result -> env:set(Env, {symbol, A1}, Result), Result + end, + Result; +eval_list({list, [{symbol, "defmacro!"}, _A1, _A2], _Meta}, _Env) -> + error("defmacro! called with non-symbol"); +eval_list({list, [{symbol, "defmacro!"}|_], _Meta}, _Env) -> + error("defmacro! requires exactly two arguments"); +eval_list({list, [{symbol, "macroexpand"}, Macro], _Meta}, Env) -> + macroexpand(Macro, Env); +eval_list({list, [{symbol, "macroexpand"}], _Meta}, _Env) -> + error("macroexpand requires 1 argument"); +eval_list({list, [{symbol, "try*"}, A, {list, [{symbol, "catch*"}, B, C], _M1}], _M2}, Env) -> + try eval(A, Env) of + Result -> Result + catch + error:Reason -> + NewEnv = env:new(Env), + env:bind(NewEnv, [B], [{string, Reason}]), + eval(C, NewEnv); + throw:Reason -> + NewEnv = env:new(Env), + env:bind(NewEnv, [B], [Reason]), + eval(C, NewEnv) + end; +eval_list({list, [{symbol, "try*"}, AST], _Meta}, Env) -> + eval(AST, Env); +eval_list({list, [{symbol, "try*"}|_], _Meta}, _Env) -> + error("try*/catch* must be of the form (try* A (catch* B C))"); +eval_list({list, List, Meta}, Env) -> + case eval_ast({list, List, Meta}, Env) of + {list, [{closure, _Eval, Binds, Body, CE, _MC}|A], _M1} -> + % The args may be a single element or a list, so always make it + % a list and then flatten it so it becomes a list. + NewEnv = env:new(CE), + env:bind(NewEnv, Binds, lists:flatten([A])), + eval(Body, NewEnv); + {list, [{function, F, _MF}|A], _M2} -> erlang:apply(F, [A]); + {list, [{error, Reason}], _M3} -> {error, Reason}; + _ -> error("expected a list") + end. + +eval_ast({symbol, _Sym}=Value, Env) -> + env:get(Env, Value); +eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> + {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; +eval_ast({map, M, _Meta}, Env) -> + {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; +eval_ast(Value, _Env) -> + Value. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [Value]). + +let_star(Env, Bindings) -> + Bind = fun({Name, Expr}) -> + case Name of + {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); + _ -> error("let* with non-symbol binding") + end + end, + case Bindings of + {Type, Binds, _Meta} when Type == list orelse Type == vector -> + case list_to_proplist(Binds) of + {error, Reason} -> error(Reason); + Props -> lists:foreach(Bind, Props) + end; + _ -> error("let* with non-list bindings") + end. + +list_to_proplist(L) -> + list_to_proplist(L, []). + +list_to_proplist([], AccIn) -> + lists:reverse(AccIn); +list_to_proplist([_H], _AccIn) -> + {error, "mismatch in let* name/value bindings"}; +list_to_proplist([K,V|T], AccIn) -> + list_to_proplist(T, [{K, V}|AccIn]). + +qqLoop ({list, [{symbol, "splice-unquote"}, Arg], _Meta}, Acc) -> + {list, [{symbol, "concat"}, Arg, Acc], nil}; +qqLoop({list, [{symbol, "splice-unquote"}|_], _Meta}, _Acc) -> + {error, "splice-unquote requires an argument"}; +qqLoop(Elt, Acc) -> + {list, [{symbol, "cons"}, quasiquote(Elt), Acc], nil}. + +quasiquote({list, [{symbol, "unquote"}, Arg], _Meta}) -> + Arg; +quasiquote({list, [{symbol, "unquote"}|_], _Meta}) -> + error("unquote requires 1 argument"); +quasiquote({list, List, _Meta}) -> + lists:foldr(fun qqLoop/2, {list, [], nil}, List); +quasiquote({vector, List, _Meta}) -> + {list, [{symbol, "vec"}, lists:foldr(fun qqLoop/2, {list, [], nil}, List)], nil}; +quasiquote({symbol, _Symbol} = Arg) -> + {list, [{symbol, "quote"}, Arg], nil}; +quasiquote({map, _Map, _Meta} = Arg) -> + {list, [{symbol, "quote"}, Arg], nil}; +quasiquote(Arg) -> + Arg. + +is_macro_call({list, [{symbol, Name}|_], _Meta}, Env) -> + case env:find(Env, {symbol, Name}) of + nil -> false; + Env2 -> + case env:get(Env2, {symbol, Name}) of + {macro, _Binds, _Body, _ME} -> true; + _ -> false + end + end; +is_macro_call(_AST, _Env) -> + false. + +macroexpand(AST, Env) -> + case is_macro_call(AST, Env) of + true -> + {list, [Name|A], _M2} = AST, + {macro, Binds, Body, ME} = env:get(Env, Name), + NewEnv = env:new(ME), + env:bind(NewEnv, Binds, lists:flatten([A])), + NewAST = eval(Body, NewEnv), + macroexpand(NewAST, Env); + false -> AST + end. diff --git a/impls/erlang/src/stepA_mal.erl b/impls/erlang/src/stepA_mal.erl index 4a32120ccb..471e71d0dd 100644 --- a/impls/erlang/src/stepA_mal.erl +++ b/impls/erlang/src/stepA_mal.erl @@ -1,252 +1,252 @@ -%%% -%%% Step A: Mutation, Self-hosting and Interop -%%% - --module(stepA_mal). - --export([main/1]). - -main([File|Args]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), - rep("(load-file \"" ++ File ++ "\")", Env); -main([]) -> - Env = init(), - env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), - eval(read("(println (str \"Mal [\" *host-language* \"]\"))"), Env), - loop(Env). - -init() -> - Env = core:ns(), - eval(read("(def! *host-language* \"Erlang\")"), Env), - eval(read("(def! not (fn* (a) (if a false true)))"), Env), - eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), - eval(read("(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)))))))"), Env), - Env. - -loop(Env) -> - case io:get_line(standard_io, "user> ") of - eof -> io:format("~n"); - {error, Reason} -> exit(Reason); - Line -> - print(rep(string:strip(Line, both, $\n), Env)), - loop(Env) - end. - -rep(Input, Env) -> - try eval(read(Input), Env) of - none -> none; - Result -> printer:pr_str(Result, true) - catch - error:Reason -> printer:pr_str({error, Reason}, true); - throw:Reason -> printer:pr_str({error, printer:pr_str(Reason, true)}, true) - end. - -read(Input) -> - case reader:read_str(Input) of - {ok, Value} -> Value; - {error, Reason} -> error(Reason) - end. - -eval(Value, Env) -> - case Value of - {list, _L1, _M1} -> - case macroexpand(Value, Env) of - {list, _L2, _M2} = List -> eval_list(List, Env); - AST -> eval_ast(AST, Env) - end; - _ -> eval_ast(Value, Env) - end. - -eval_list({list, [], _Meta}=AST, _Env) -> - AST; -eval_list({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> - Result = eval(A2, Env), - case Result of - {error, _R1} -> Result; - _ -> - env:set(Env, {symbol, A1}, Result), - Result - end; -eval_list({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> - error("def! called with non-symbol"); -eval_list({list, [{symbol, "def!"}|_], _Meta}, _Env) -> - error("def! requires exactly two arguments"); -eval_list({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> - NewEnv = env:new(Env), - let_star(NewEnv, A1), - eval(A2, NewEnv); -eval_list({list, [{symbol, "let*"}|_], _Meta}, _Env) -> - error("let* requires exactly two arguments"); -eval_list({list, [{symbol, "do"}|Args], _Meta}, Env) -> - eval_ast({list, lists:droplast(Args), nil}, Env), - eval(lists:last(Args), Env); -eval_list({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> - case eval(Test, Env) of - Cond when Cond == false orelse Cond == nil -> - case Alternate of - [] -> nil; - [A] -> eval(A, Env); - _ -> error("if takes 2 or 3 arguments") - end; - _ -> eval(Consequent, Env) - end; -eval_list({list, [{symbol, "if"}|_], _Meta}, _Env) -> - error("if requires test and consequent"); -eval_list({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval_list({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> - {closure, fun eval/2, Binds, Body, Env, nil}; -eval_list({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> - error("fn* requires 2 arguments"); -eval_list({list, [{symbol, "eval"}, AST], _Meta}, Env) -> - % Must use the root environment so the variables set within the parsed - % expression will be visible within the repl. - eval(eval(AST, Env), env:root(Env)); -eval_list({list, [{symbol, "eval"}|_], _Meta}, _Env) -> - error("eval requires 1 argument"); -eval_list({list, [{symbol, "quote"}, AST], _Meta}, _Env) -> - AST; -eval_list({list, [{symbol, "quote"}|_], _Meta}, _Env) -> - error("quote requires 1 argument"); -eval_list({list, [{symbol, "quasiquoteexpand"}, AST], _Meta}, Env) -> - quasiquote(AST); -eval_list({list, [{symbol, "quasiquoteexpand"}|_], _Meta}, _Env) -> - error("quasiquoteexpand requires 1 argument"); -eval_list({list, [{symbol, "quasiquote"}, AST], _Meta}, Env) -> - eval(quasiquote(AST), Env); -eval_list({list, [{symbol, "quasiquote"}|_], _Meta}, _Env) -> - error("quasiquote requires 1 argument"); -eval_list({list, [{symbol, "defmacro!"}, {symbol, A1}, A2], _Meta}, Env) -> - case eval(A2, Env) of - {closure, _Eval, Binds, Body, CE, _MC} -> - Result = {macro, Binds, Body, CE}, - env:set(Env, {symbol, A1}, Result), - Result; - Result -> env:set(Env, {symbol, A1}, Result), Result - end, - Result; -eval_list({list, [{symbol, "defmacro!"}, _A1, _A2], _Meta}, _Env) -> - error("defmacro! called with non-symbol"); -eval_list({list, [{symbol, "defmacro!"}|_], _Meta}, _Env) -> - error("defmacro! requires exactly two arguments"); -eval_list({list, [{symbol, "macroexpand"}, Macro], _Meta}, Env) -> - macroexpand(Macro, Env); -eval_list({list, [{symbol, "macroexpand"}], _Meta}, _Env) -> - error("macroexpand requires 1 argument"); -eval_list({list, [{symbol, "try*"}, A, {list, [{symbol, "catch*"}, B, C], _M1}], _M2}, Env) -> - try eval(A, Env) of - Result -> Result - catch - error:Reason -> - NewEnv = env:new(Env), - env:bind(NewEnv, [B], [{string, Reason}]), - eval(C, NewEnv); - throw:Reason -> - NewEnv = env:new(Env), - env:bind(NewEnv, [B], [Reason]), - eval(C, NewEnv) - end; -eval_list({list, [{symbol, "try*"}, AST], _Meta}, Env) -> - eval(AST, Env); -eval_list({list, [{symbol, "try*"}|_], _Meta}, _Env) -> - error("try*/catch* must be of the form (try* A (catch* B C))"); -eval_list({list, List, Meta}, Env) -> - case eval_ast({list, List, Meta}, Env) of - {list, [{closure, _Eval, Binds, Body, CE, _MC}|A], _M2} -> - % The args may be a single element or a list, so always make it - % a list and then flatten it so it becomes a list. - NewEnv = env:new(CE), - env:bind(NewEnv, Binds, lists:flatten([A])), - eval(Body, NewEnv); - {list, [{function, F, _MF}|A], _M3} -> erlang:apply(F, [A]); - {list, [{error, Reason}], _M4} -> {error, Reason}; - _ -> error("expected a list") - end. - -eval_ast({symbol, _Sym}=Value, Env) -> - env:get(Env, Value); -eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> - {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; -eval_ast({map, M, _Meta}, Env) -> - {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; -eval_ast(Value, _Env) -> - Value. - -print(none) -> - % if nothing meaningful was entered, print nothing at all - ok; -print(Value) -> - io:format("~s~n", [Value]). - -let_star(Env, Bindings) -> - Bind = fun({Name, Expr}) -> - case Name of - {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); - _ -> error("let* with non-symbol binding") - end - end, - case Bindings of - {Type, Binds, _Meta} when Type == list orelse Type == vector -> - case list_to_proplist(Binds) of - {error, Reason} -> error(Reason); - Props -> lists:foreach(Bind, Props) - end; - _ -> error("let* with non-list bindings") - end. - -list_to_proplist(L) -> - list_to_proplist(L, []). - -list_to_proplist([], AccIn) -> - lists:reverse(AccIn); -list_to_proplist([_H], _AccIn) -> - {error, "mismatch in let* name/value bindings"}; -list_to_proplist([K,V|T], AccIn) -> - list_to_proplist(T, [{K, V}|AccIn]). - -qqLoop ({list, [{symbol, "splice-unquote"}, Arg], _Meta}, Acc) -> - {list, [{symbol, "concat"}, Arg, Acc], nil}; -qqLoop({list, [{symbol, "splice-unquote"}|_], _Meta}, _Acc) -> - {error, "splice-unquote requires an argument"}; -qqLoop(Elt, Acc) -> - {list, [{symbol, "cons"}, quasiquote(Elt), Acc], nil}. - -quasiquote({list, [{symbol, "unquote"}, Arg], _Meta}) -> - Arg; -quasiquote({list, [{symbol, "unquote"}|_], _Meta}) -> - error("unquote requires 1 argument"); -quasiquote({list, List, _Meta}) -> - lists:foldr(fun qqLoop/2, {list, [], nil}, List); -quasiquote({vector, List, _Meta}) -> - {list, [{symbol, "vec"}, lists:foldr(fun qqLoop/2, {list, [], nil}, List)], nil}; -quasiquote({symbol, _Symbol} = Arg) -> - {list, [{symbol, "quote"}, Arg], nil}; -quasiquote({map, _Map, _Meta} = Arg) -> - {list, [{symbol, "quote"}, Arg], nil}; -quasiquote(Arg) -> - Arg. - -is_macro_call({list, [{symbol, Name}|_], _Meta}, Env) -> - case env:find(Env, {symbol, Name}) of - nil -> false; - Env2 -> - case env:get(Env2, {symbol, Name}) of - {macro, _Binds, _Body, _ME} -> true; - _ -> false - end - end; -is_macro_call(_AST, _Env) -> - false. - -macroexpand(AST, Env) -> - case is_macro_call(AST, Env) of - true -> - {list, [Name|A], _Meta} = AST, - {macro, Binds, Body, ME} = env:get(Env, Name), - NewEnv = env:new(ME), - env:bind(NewEnv, Binds, lists:flatten([A])), - NewAST = eval(Body, NewEnv), - macroexpand(NewAST, Env); - false -> AST - end. +%%% +%%% Step A: Mutation, Self-hosting and Interop +%%% + +-module(stepA_mal). + +-export([main/1]). + +main([File|Args]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [{string,Arg} || Arg <- Args], nil}), + rep("(load-file \"" ++ File ++ "\")", Env); +main([]) -> + Env = init(), + env:set(Env, {symbol, "*ARGV*"}, {list, [], nil}), + eval(read("(println (str \"Mal [\" *host-language* \"]\"))"), Env), + loop(Env). + +init() -> + Env = core:ns(), + eval(read("(def! *host-language* \"Erlang\")"), Env), + eval(read("(def! not (fn* (a) (if a false true)))"), Env), + eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), Env), + eval(read("(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)))))))"), Env), + Env. + +loop(Env) -> + case io:get_line(standard_io, "user> ") of + eof -> io:format("~n"); + {error, Reason} -> exit(Reason); + Line -> + print(rep(string:strip(Line, both, $\n), Env)), + loop(Env) + end. + +rep(Input, Env) -> + try eval(read(Input), Env) of + none -> none; + Result -> printer:pr_str(Result, true) + catch + error:Reason -> printer:pr_str({error, Reason}, true); + throw:Reason -> printer:pr_str({error, printer:pr_str(Reason, true)}, true) + end. + +read(Input) -> + case reader:read_str(Input) of + {ok, Value} -> Value; + {error, Reason} -> error(Reason) + end. + +eval(Value, Env) -> + case Value of + {list, _L1, _M1} -> + case macroexpand(Value, Env) of + {list, _L2, _M2} = List -> eval_list(List, Env); + AST -> eval_ast(AST, Env) + end; + _ -> eval_ast(Value, Env) + end. + +eval_list({list, [], _Meta}=AST, _Env) -> + AST; +eval_list({list, [{symbol, "def!"}, {symbol, A1}, A2], _Meta}, Env) -> + Result = eval(A2, Env), + case Result of + {error, _R1} -> Result; + _ -> + env:set(Env, {symbol, A1}, Result), + Result + end; +eval_list({list, [{symbol, "def!"}, _A1, _A2], _Meta}, _Env) -> + error("def! called with non-symbol"); +eval_list({list, [{symbol, "def!"}|_], _Meta}, _Env) -> + error("def! requires exactly two arguments"); +eval_list({list, [{symbol, "let*"}, A1, A2], _Meta}, Env) -> + NewEnv = env:new(Env), + let_star(NewEnv, A1), + eval(A2, NewEnv); +eval_list({list, [{symbol, "let*"}|_], _Meta}, _Env) -> + error("let* requires exactly two arguments"); +eval_list({list, [{symbol, "do"}|Args], _Meta}, Env) -> + eval_ast({list, lists:droplast(Args), nil}, Env), + eval(lists:last(Args), Env); +eval_list({list, [{symbol, "if"}, Test, Consequent|Alternate], _Meta}, Env) -> + case eval(Test, Env) of + Cond when Cond == false orelse Cond == nil -> + case Alternate of + [] -> nil; + [A] -> eval(A, Env); + _ -> error("if takes 2 or 3 arguments") + end; + _ -> eval(Consequent, Env) + end; +eval_list({list, [{symbol, "if"}|_], _Meta}, _Env) -> + error("if requires test and consequent"); +eval_list({list, [{symbol, "fn*"}, {vector, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval_list({list, [{symbol, "fn*"}, {list, Binds, _M1}, Body], _Meta}, Env) -> + {closure, fun eval/2, Binds, Body, Env, nil}; +eval_list({list, [{symbol, "fn*"}|_], _Meta}, _Env) -> + error("fn* requires 2 arguments"); +eval_list({list, [{symbol, "eval"}, AST], _Meta}, Env) -> + % Must use the root environment so the variables set within the parsed + % expression will be visible within the repl. + eval(eval(AST, Env), env:root(Env)); +eval_list({list, [{symbol, "eval"}|_], _Meta}, _Env) -> + error("eval requires 1 argument"); +eval_list({list, [{symbol, "quote"}, AST], _Meta}, _Env) -> + AST; +eval_list({list, [{symbol, "quote"}|_], _Meta}, _Env) -> + error("quote requires 1 argument"); +eval_list({list, [{symbol, "quasiquoteexpand"}, AST], _Meta}, Env) -> + quasiquote(AST); +eval_list({list, [{symbol, "quasiquoteexpand"}|_], _Meta}, _Env) -> + error("quasiquoteexpand requires 1 argument"); +eval_list({list, [{symbol, "quasiquote"}, AST], _Meta}, Env) -> + eval(quasiquote(AST), Env); +eval_list({list, [{symbol, "quasiquote"}|_], _Meta}, _Env) -> + error("quasiquote requires 1 argument"); +eval_list({list, [{symbol, "defmacro!"}, {symbol, A1}, A2], _Meta}, Env) -> + case eval(A2, Env) of + {closure, _Eval, Binds, Body, CE, _MC} -> + Result = {macro, Binds, Body, CE}, + env:set(Env, {symbol, A1}, Result), + Result; + Result -> env:set(Env, {symbol, A1}, Result), Result + end, + Result; +eval_list({list, [{symbol, "defmacro!"}, _A1, _A2], _Meta}, _Env) -> + error("defmacro! called with non-symbol"); +eval_list({list, [{symbol, "defmacro!"}|_], _Meta}, _Env) -> + error("defmacro! requires exactly two arguments"); +eval_list({list, [{symbol, "macroexpand"}, Macro], _Meta}, Env) -> + macroexpand(Macro, Env); +eval_list({list, [{symbol, "macroexpand"}], _Meta}, _Env) -> + error("macroexpand requires 1 argument"); +eval_list({list, [{symbol, "try*"}, A, {list, [{symbol, "catch*"}, B, C], _M1}], _M2}, Env) -> + try eval(A, Env) of + Result -> Result + catch + error:Reason -> + NewEnv = env:new(Env), + env:bind(NewEnv, [B], [{string, Reason}]), + eval(C, NewEnv); + throw:Reason -> + NewEnv = env:new(Env), + env:bind(NewEnv, [B], [Reason]), + eval(C, NewEnv) + end; +eval_list({list, [{symbol, "try*"}, AST], _Meta}, Env) -> + eval(AST, Env); +eval_list({list, [{symbol, "try*"}|_], _Meta}, _Env) -> + error("try*/catch* must be of the form (try* A (catch* B C))"); +eval_list({list, List, Meta}, Env) -> + case eval_ast({list, List, Meta}, Env) of + {list, [{closure, _Eval, Binds, Body, CE, _MC}|A], _M2} -> + % The args may be a single element or a list, so always make it + % a list and then flatten it so it becomes a list. + NewEnv = env:new(CE), + env:bind(NewEnv, Binds, lists:flatten([A])), + eval(Body, NewEnv); + {list, [{function, F, _MF}|A], _M3} -> erlang:apply(F, [A]); + {list, [{error, Reason}], _M4} -> {error, Reason}; + _ -> error("expected a list") + end. + +eval_ast({symbol, _Sym}=Value, Env) -> + env:get(Env, Value); +eval_ast({Type, Seq, _Meta}, Env) when Type == list orelse Type == vector -> + {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq), nil}; +eval_ast({map, M, _Meta}, Env) -> + {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M), nil}; +eval_ast(Value, _Env) -> + Value. + +print(none) -> + % if nothing meaningful was entered, print nothing at all + ok; +print(Value) -> + io:format("~s~n", [Value]). + +let_star(Env, Bindings) -> + Bind = fun({Name, Expr}) -> + case Name of + {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env)); + _ -> error("let* with non-symbol binding") + end + end, + case Bindings of + {Type, Binds, _Meta} when Type == list orelse Type == vector -> + case list_to_proplist(Binds) of + {error, Reason} -> error(Reason); + Props -> lists:foreach(Bind, Props) + end; + _ -> error("let* with non-list bindings") + end. + +list_to_proplist(L) -> + list_to_proplist(L, []). + +list_to_proplist([], AccIn) -> + lists:reverse(AccIn); +list_to_proplist([_H], _AccIn) -> + {error, "mismatch in let* name/value bindings"}; +list_to_proplist([K,V|T], AccIn) -> + list_to_proplist(T, [{K, V}|AccIn]). + +qqLoop ({list, [{symbol, "splice-unquote"}, Arg], _Meta}, Acc) -> + {list, [{symbol, "concat"}, Arg, Acc], nil}; +qqLoop({list, [{symbol, "splice-unquote"}|_], _Meta}, _Acc) -> + {error, "splice-unquote requires an argument"}; +qqLoop(Elt, Acc) -> + {list, [{symbol, "cons"}, quasiquote(Elt), Acc], nil}. + +quasiquote({list, [{symbol, "unquote"}, Arg], _Meta}) -> + Arg; +quasiquote({list, [{symbol, "unquote"}|_], _Meta}) -> + error("unquote requires 1 argument"); +quasiquote({list, List, _Meta}) -> + lists:foldr(fun qqLoop/2, {list, [], nil}, List); +quasiquote({vector, List, _Meta}) -> + {list, [{symbol, "vec"}, lists:foldr(fun qqLoop/2, {list, [], nil}, List)], nil}; +quasiquote({symbol, _Symbol} = Arg) -> + {list, [{symbol, "quote"}, Arg], nil}; +quasiquote({map, _Map, _Meta} = Arg) -> + {list, [{symbol, "quote"}, Arg], nil}; +quasiquote(Arg) -> + Arg. + +is_macro_call({list, [{symbol, Name}|_], _Meta}, Env) -> + case env:find(Env, {symbol, Name}) of + nil -> false; + Env2 -> + case env:get(Env2, {symbol, Name}) of + {macro, _Binds, _Body, _ME} -> true; + _ -> false + end + end; +is_macro_call(_AST, _Env) -> + false. + +macroexpand(AST, Env) -> + case is_macro_call(AST, Env) of + true -> + {list, [Name|A], _Meta} = AST, + {macro, Binds, Body, ME} = env:get(Env, Name), + NewEnv = env:new(ME), + env:bind(NewEnv, Binds, lists:flatten([A])), + NewAST = eval(Body, NewEnv), + macroexpand(NewAST, Env); + false -> AST + end. diff --git a/impls/erlang/src/types.erl b/impls/erlang/src/types.erl index 0dcc902076..9ee9e4be72 100644 --- a/impls/erlang/src/types.erl +++ b/impls/erlang/src/types.erl @@ -1,163 +1,163 @@ -%%% -%%% Types and their functions -%%% - --module(types). --compile(export_all). - -list(Args) -> - {list, Args, nil}. - -list_p([Args]) -> - case Args of - {list, _L, _M} -> true; - _ -> false - end; -list_p([]) -> - {error, "list? called with no arguments"}; -list_p(_) -> - {error, "list? expects one list argument"}. - -func(Func) -> - {function, Func, nil}. - -symbol_p([{symbol, _S}]) -> - true; -symbol_p([_A]) -> - false; -symbol_p(_) -> - {error, "symbol? takes a single argument"}. - -symbol([{string, Name}]) -> - {symbol, Name}; -symbol(_) -> - {error, "symbol expects a single string argument"}. - -string_p([{string, _S}]) -> - true; -string_p([_A]) -> - false; -string_p(_) -> - {error, "string? takes a single argument"}. - -keyword_p([{keyword, _K}]) -> - true; -keyword_p([_A]) -> - false; -keyword_p(_) -> - {error, "keyword? takes a single argument"}. - -keyword([{string, Name}]) -> {keyword, Name}; -keyword([{keyword, Name}]) -> {keyword, Name}; -keyword([_]) -> {error, "keyword: expectst a keyword or string."}; -keyword(_) -> {error, "keyword: takes a single argument."}. - -vector_p([{vector, _V, _Meta}]) -> - true; -vector_p([_]) -> - false; -vector_p(_) -> - {error, "vector? takes a single argument"}. - -vector(Args) -> - {vector, Args, nil}. - -hash_map(Args) -> - {map, reader:list_to_map(Args), nil}. - -map_p([{map, _M, _Meta}]) -> - true; -map_p([_]) -> - false; -map_p(_) -> - {error, "map? takes a single argument"}. - -assoc([{map, Map, Meta}|Args]) -> - case reader:list_to_map(Args) of - {error, Reason} -> {error, Reason}; - Addend -> {map, maps:merge(Map, Addend), Meta} - end; -assoc(_) -> - {error, "assoc expects a map argument followed by pairs"}. - -dissoc([{map, Map, Meta}|Keys]) -> - {map, lists:foldl(fun(Key, AccIn) -> maps:remove(Key, AccIn) end, Map, Keys), Meta}; -dissoc(_) -> - {error, "dissoc expects a map argument followed by keys"}. - -map_get([{map, Map, _Meta}, Key]) -> - maps:get(Key, Map, nil); -map_get([_Thing1, _Thing2]) -> - nil; -map_get(_) -> - {error, "get expects a map argument followed by key"}. - -contains_p([{map, Map, _Meta}, Key]) -> - maps:is_key(Key, Map); -contains_p(_) -> - {error, "contains? expects a map argument followed by key"}. - -map_keys([{map, Map, _Meta}]) -> - {list, maps:keys(Map), nil}; -map_keys(_) -> - {error, "keys expects a map argument"}. - -map_values([{map, Map, _Meta}]) -> - {list, maps:values(Map), nil}; -map_values(_) -> - {error, "vals expects a map argument"}. - -sequential_p([{Type, _L, _M}]) when Type == list orelse Type == vector -> - true; -sequential_p([_]) -> - false; -sequential_p(_) -> - {error, "sequential? expects a single argument"}. - -atom([Atom]) -> - {atom, atom:new(Atom)}; -atom(_) -> - {error, "atom expects a single argument"}. - -atom_p([{atom, _A}]) -> - true; -atom_p([_]) -> - false; -atom_p(_) -> - {error, "atom? expects a single argument"}. - -deref([{atom, Atom}]) -> - atom:deref(Atom); -deref(_) -> - {error, "deref expects a single atom argument"}. - -reset([{atom, Atom}, Value]) -> - atom:reset(Atom, Value); -reset(_) -> - {error, "reset expects an atom and a value"}. - -swap([{atom, Atom}, {closure, Eval, Binds, Body, Env, _MC}|Args]) -> - NewEnv = env:new(Env), - Values = [atom:deref(Atom) | Args], - env:bind(NewEnv, Binds, Values), - atom:reset(Atom, Eval(Body, NewEnv)); -swap([{atom, Atom}, {function, F, _MF}|Args]) -> - atom:reset(Atom, erlang:apply(F, [[atom:deref(Atom) | Args]])); -swap(_) -> - {error, "atom expects an atom, function, and optional arguments"}. - -meta([{T, _List, Meta}]) when T == list orelse T == vector orelse T == map -> - Meta; -meta([{closure, _Eval, _Binds, _Body, _Env, Meta}]) -> - Meta; -meta([{function, _Func, Meta}]) -> - Meta; -meta(_) -> - {error, "meta expects a single collection or function argument"}. - -with_meta([{T, Seq, _M}, Meta]) when T == list orelse T == vector orelse T == map -> - {T, Seq, Meta}; -with_meta([{closure, Eval, Binds, Body, Env, _M}, Meta]) -> - {closure, Eval, Binds, Body, Env, Meta}; -with_meta([{function, Func, _Meta}, Meta]) -> - {function, Func, Meta}. +%%% +%%% Types and their functions +%%% + +-module(types). +-compile(export_all). + +list(Args) -> + {list, Args, nil}. + +list_p([Args]) -> + case Args of + {list, _L, _M} -> true; + _ -> false + end; +list_p([]) -> + {error, "list? called with no arguments"}; +list_p(_) -> + {error, "list? expects one list argument"}. + +func(Func) -> + {function, Func, nil}. + +symbol_p([{symbol, _S}]) -> + true; +symbol_p([_A]) -> + false; +symbol_p(_) -> + {error, "symbol? takes a single argument"}. + +symbol([{string, Name}]) -> + {symbol, Name}; +symbol(_) -> + {error, "symbol expects a single string argument"}. + +string_p([{string, _S}]) -> + true; +string_p([_A]) -> + false; +string_p(_) -> + {error, "string? takes a single argument"}. + +keyword_p([{keyword, _K}]) -> + true; +keyword_p([_A]) -> + false; +keyword_p(_) -> + {error, "keyword? takes a single argument"}. + +keyword([{string, Name}]) -> {keyword, Name}; +keyword([{keyword, Name}]) -> {keyword, Name}; +keyword([_]) -> {error, "keyword: expectst a keyword or string."}; +keyword(_) -> {error, "keyword: takes a single argument."}. + +vector_p([{vector, _V, _Meta}]) -> + true; +vector_p([_]) -> + false; +vector_p(_) -> + {error, "vector? takes a single argument"}. + +vector(Args) -> + {vector, Args, nil}. + +hash_map(Args) -> + {map, reader:list_to_map(Args), nil}. + +map_p([{map, _M, _Meta}]) -> + true; +map_p([_]) -> + false; +map_p(_) -> + {error, "map? takes a single argument"}. + +assoc([{map, Map, Meta}|Args]) -> + case reader:list_to_map(Args) of + {error, Reason} -> {error, Reason}; + Addend -> {map, maps:merge(Map, Addend), Meta} + end; +assoc(_) -> + {error, "assoc expects a map argument followed by pairs"}. + +dissoc([{map, Map, Meta}|Keys]) -> + {map, lists:foldl(fun(Key, AccIn) -> maps:remove(Key, AccIn) end, Map, Keys), Meta}; +dissoc(_) -> + {error, "dissoc expects a map argument followed by keys"}. + +map_get([{map, Map, _Meta}, Key]) -> + maps:get(Key, Map, nil); +map_get([_Thing1, _Thing2]) -> + nil; +map_get(_) -> + {error, "get expects a map argument followed by key"}. + +contains_p([{map, Map, _Meta}, Key]) -> + maps:is_key(Key, Map); +contains_p(_) -> + {error, "contains? expects a map argument followed by key"}. + +map_keys([{map, Map, _Meta}]) -> + {list, maps:keys(Map), nil}; +map_keys(_) -> + {error, "keys expects a map argument"}. + +map_values([{map, Map, _Meta}]) -> + {list, maps:values(Map), nil}; +map_values(_) -> + {error, "vals expects a map argument"}. + +sequential_p([{Type, _L, _M}]) when Type == list orelse Type == vector -> + true; +sequential_p([_]) -> + false; +sequential_p(_) -> + {error, "sequential? expects a single argument"}. + +atom([Atom]) -> + {atom, atom:new(Atom)}; +atom(_) -> + {error, "atom expects a single argument"}. + +atom_p([{atom, _A}]) -> + true; +atom_p([_]) -> + false; +atom_p(_) -> + {error, "atom? expects a single argument"}. + +deref([{atom, Atom}]) -> + atom:deref(Atom); +deref(_) -> + {error, "deref expects a single atom argument"}. + +reset([{atom, Atom}, Value]) -> + atom:reset(Atom, Value); +reset(_) -> + {error, "reset expects an atom and a value"}. + +swap([{atom, Atom}, {closure, Eval, Binds, Body, Env, _MC}|Args]) -> + NewEnv = env:new(Env), + Values = [atom:deref(Atom) | Args], + env:bind(NewEnv, Binds, Values), + atom:reset(Atom, Eval(Body, NewEnv)); +swap([{atom, Atom}, {function, F, _MF}|Args]) -> + atom:reset(Atom, erlang:apply(F, [[atom:deref(Atom) | Args]])); +swap(_) -> + {error, "atom expects an atom, function, and optional arguments"}. + +meta([{T, _List, Meta}]) when T == list orelse T == vector orelse T == map -> + Meta; +meta([{closure, _Eval, _Binds, _Body, _Env, Meta}]) -> + Meta; +meta([{function, _Func, Meta}]) -> + Meta; +meta(_) -> + {error, "meta expects a single collection or function argument"}. + +with_meta([{T, Seq, _M}, Meta]) when T == list orelse T == vector orelse T == map -> + {T, Seq, Meta}; +with_meta([{closure, Eval, Binds, Body, Env, _M}, Meta]) -> + {closure, Eval, Binds, Body, Env, Meta}; +with_meta([{function, Func, _Meta}, Meta]) -> + {function, Func, Meta}. diff --git a/impls/erlang/tests/step5_tco.mal b/impls/erlang/tests/step5_tco.mal index 54b616b446..2539d03d1a 100644 --- a/impls/erlang/tests/step5_tco.mal +++ b/impls/erlang/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Erlang: skipping non-TCO recursion -;; Reason: Erlang has TCO, test always completes. +;; Erlang: skipping non-TCO recursion +;; Reason: Erlang has TCO, test always completes. diff --git a/impls/es6/Dockerfile b/impls/es6/Dockerfile index f7677e91c8..725fd2586b 100644 --- a/impls/es6/Dockerfile +++ b/impls/es6/Dockerfile @@ -1,34 +1,34 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/impls/es6/Makefile b/impls/es6/Makefile index 15ffe6aa49..bf159e6244 100644 --- a/impls/es6/Makefile +++ b/impls/es6/Makefile @@ -1,29 +1,29 @@ -SOURCES_BASE = node_readline.js types.mjs reader.mjs printer.mjs -SOURCES_LISP = env.mjs core.mjs stepA_mal.mjs -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -STEPS = step0_repl.mjs step1_read_print.mjs step2_eval.mjs step3_env.mjs \ - step4_if_fn_do.mjs step5_tco.mjs step6_file.mjs \ - step7_quote.mjs step8_macros.mjs step9_try.mjs stepA_mal.mjs - -all: node_modules - -dist: mal.js mal - -node_modules: - npm install - -$(STEPS): node_modules - -mal.js: $(SOURCES) - cat $+ | sed 's/^export //' | grep -v "^import " >> $@ - -mal: mal.js - echo "#!/usr/bin/env node" > $@ - cat $< >> $@ - chmod +x $@ - - -clean: - rm -f mal.js mal - rm -rf node_modules +SOURCES_BASE = node_readline.js types.mjs reader.mjs printer.mjs +SOURCES_LISP = env.mjs core.mjs stepA_mal.mjs +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +STEPS = step0_repl.mjs step1_read_print.mjs step2_eval.mjs step3_env.mjs \ + step4_if_fn_do.mjs step5_tco.mjs step6_file.mjs \ + step7_quote.mjs step8_macros.mjs step9_try.mjs stepA_mal.mjs + +all: node_modules + +dist: mal.js mal + +node_modules: + npm install + +$(STEPS): node_modules + +mal.js: $(SOURCES) + cat $+ | sed 's/^export //' | grep -v "^import " >> $@ + +mal: mal.js + echo "#!/usr/bin/env node" > $@ + cat $< >> $@ + chmod +x $@ + + +clean: + rm -f mal.js mal + rm -rf node_modules diff --git a/impls/es6/core.mjs b/impls/es6/core.mjs index 8a9af4a84d..fd3d6ffaa3 100644 --- a/impls/es6/core.mjs +++ b/impls/es6/core.mjs @@ -1,113 +1,113 @@ -import { _equal_Q, _clone, _keyword, _keyword_Q } from './types' -import { _list_Q, Vector, _assoc_BANG, Atom } from './types' -import { pr_str } from './printer' -import rl from './node_readline' -const readline = rl.readline -import { read_str } from './reader' -import { readFileSync } from 'fs' - -function _error(e) { throw new Error(e) } - -// String functions -function slurp(f) { - if (typeof process !== 'undefined') { - return readFileSync(f, 'utf-8') - } else { - var req = new XMLHttpRequest() - req.open('GET', f, false) - req.send() - if (req.status !== 200) { - _error(`Failed to slurp file: ${f}`) - } - return req.responseText - } -} - -// Sequence functions -function seq(obj) { - if (_list_Q(obj)) { - return obj.length > 0 ? obj : null - } else if (obj instanceof Vector) { - return obj.length > 0 ? Array.from(obj.slice(0)) : null - } else if (typeof obj === "string" && !_keyword_Q(obj)) { - return obj.length > 0 ? obj.split('') : null - } else if (obj === null) { - return null - } else { - _error('seq: called on non-sequence') - } -} - -// core_ns is namespace of type functions -export const core_ns = new Map([ - ['=', _equal_Q], - ['throw', a => { throw a }], - - ['nil?', a => a === null], - ['true?', a => a === true], - ['false?', a => a === false], - ['number?', a => typeof a === 'number'], - ['string?', a => typeof a === "string" && !_keyword_Q(a)], - ['symbol', a => Symbol.for(a)], - ['symbol?', a => typeof a === 'symbol'], - ['keyword', _keyword], - ['keyword?', _keyword_Q], - ['fn?', a => typeof a === 'function' && !a.ismacro ], - ['macro?', a => typeof a === 'function' && !!a.ismacro ], - - ['pr-str', (...a) => a.map(e => pr_str(e,1)).join(' ')], - ['str', (...a) => a.map(e => pr_str(e,0)).join('')], - ['prn', (...a) => console.log(...a.map(e => pr_str(e,1))) || null], - ['println', (...a) => console.log(...a.map(e => pr_str(e,0))) || null], - ['read-string', read_str], - ['readline', readline], - ['slurp', slurp], - - ['<' , (a,b) => a' , (a,b) => a>b], - ['>=', (a,b) => a>=b], - ['+' , (a,b) => a+b], - ['-' , (a,b) => a-b], - ['*' , (a,b) => a*b], - ['/' , (a,b) => a/b], - ["time-ms", () => new Date().getTime()], - - ['list', (...a) => a], - ['list?', _list_Q], - ['vector', (...a) => Vector.from(a)], - ['vector?', a => a instanceof Vector], - ['hash-map', (...a) => _assoc_BANG(new Map(), ...a)], - ['map?', a => a instanceof Map], - ['assoc', (m,...a) => _assoc_BANG(_clone(m), ...a)], - ['dissoc', (m,...a) => { let n = _clone(m); a.forEach(k => n.delete(k)); - return n}], - ['get', (m,a) => m === null ? null : m.has(a) ? m.get(a) : null], - ['contains?', (m,a) => m.has(a)], - ['keys', a => Array.from(a.keys())], - ['vals', a => Array.from(a.values())], - - ['sequential?', a => Array.isArray(a)], - ['cons', (a,b) => [a].concat(b)], - ['concat', (...a) => a.reduce((x,y) => x.concat(y), [])], - ['vec', (a) => Vector.from(a)], - ['nth', (a,b) => b < a.length ? a[b] : _error('nth: index out of range')], - ['first', a => a !== null && a.length > 0 ? a[0] : null], - ['rest', a => a === null ? [] : Array.from(a.slice(1))], - ['empty?', a => a.length === 0], - ['count', a => a === null ? 0 : a.length], - ['apply', (f,...a) => f(...a.slice(0, -1).concat(a[a.length-1]))], - ['map', (f,a) => Array.from(a.map(x => f(x)))], - - ['conj', (s,...a) => _list_Q(s) ? a.reverse().concat(s) - : Vector.from(s.concat(a))], - ['seq', seq], - - ['meta', a => 'meta' in a ? a['meta'] : null], - ['with-meta', (a,b) => { let c = _clone(a); c.meta = b; return c }], - ['atom', a => new Atom(a)], - ['atom?', a => a instanceof Atom], - ['deref', atm => atm.val], - ['reset!', (atm,a) => atm.val = a], - ['swap!', (atm,f,...args) => atm.val = f(...[atm.val].concat(args))] - ]) +import { _equal_Q, _clone, _keyword, _keyword_Q } from './types' +import { _list_Q, Vector, _assoc_BANG, Atom } from './types' +import { pr_str } from './printer' +import rl from './node_readline' +const readline = rl.readline +import { read_str } from './reader' +import { readFileSync } from 'fs' + +function _error(e) { throw new Error(e) } + +// String functions +function slurp(f) { + if (typeof process !== 'undefined') { + return readFileSync(f, 'utf-8') + } else { + var req = new XMLHttpRequest() + req.open('GET', f, false) + req.send() + if (req.status !== 200) { + _error(`Failed to slurp file: ${f}`) + } + return req.responseText + } +} + +// Sequence functions +function seq(obj) { + if (_list_Q(obj)) { + return obj.length > 0 ? obj : null + } else if (obj instanceof Vector) { + return obj.length > 0 ? Array.from(obj.slice(0)) : null + } else if (typeof obj === "string" && !_keyword_Q(obj)) { + return obj.length > 0 ? obj.split('') : null + } else if (obj === null) { + return null + } else { + _error('seq: called on non-sequence') + } +} + +// core_ns is namespace of type functions +export const core_ns = new Map([ + ['=', _equal_Q], + ['throw', a => { throw a }], + + ['nil?', a => a === null], + ['true?', a => a === true], + ['false?', a => a === false], + ['number?', a => typeof a === 'number'], + ['string?', a => typeof a === "string" && !_keyword_Q(a)], + ['symbol', a => Symbol.for(a)], + ['symbol?', a => typeof a === 'symbol'], + ['keyword', _keyword], + ['keyword?', _keyword_Q], + ['fn?', a => typeof a === 'function' && !a.ismacro ], + ['macro?', a => typeof a === 'function' && !!a.ismacro ], + + ['pr-str', (...a) => a.map(e => pr_str(e,1)).join(' ')], + ['str', (...a) => a.map(e => pr_str(e,0)).join('')], + ['prn', (...a) => console.log(...a.map(e => pr_str(e,1))) || null], + ['println', (...a) => console.log(...a.map(e => pr_str(e,0))) || null], + ['read-string', read_str], + ['readline', readline], + ['slurp', slurp], + + ['<' , (a,b) => a' , (a,b) => a>b], + ['>=', (a,b) => a>=b], + ['+' , (a,b) => a+b], + ['-' , (a,b) => a-b], + ['*' , (a,b) => a*b], + ['/' , (a,b) => a/b], + ["time-ms", () => new Date().getTime()], + + ['list', (...a) => a], + ['list?', _list_Q], + ['vector', (...a) => Vector.from(a)], + ['vector?', a => a instanceof Vector], + ['hash-map', (...a) => _assoc_BANG(new Map(), ...a)], + ['map?', a => a instanceof Map], + ['assoc', (m,...a) => _assoc_BANG(_clone(m), ...a)], + ['dissoc', (m,...a) => { let n = _clone(m); a.forEach(k => n.delete(k)); + return n}], + ['get', (m,a) => m === null ? null : m.has(a) ? m.get(a) : null], + ['contains?', (m,a) => m.has(a)], + ['keys', a => Array.from(a.keys())], + ['vals', a => Array.from(a.values())], + + ['sequential?', a => Array.isArray(a)], + ['cons', (a,b) => [a].concat(b)], + ['concat', (...a) => a.reduce((x,y) => x.concat(y), [])], + ['vec', (a) => Vector.from(a)], + ['nth', (a,b) => b < a.length ? a[b] : _error('nth: index out of range')], + ['first', a => a !== null && a.length > 0 ? a[0] : null], + ['rest', a => a === null ? [] : Array.from(a.slice(1))], + ['empty?', a => a.length === 0], + ['count', a => a === null ? 0 : a.length], + ['apply', (f,...a) => f(...a.slice(0, -1).concat(a[a.length-1]))], + ['map', (f,a) => Array.from(a.map(x => f(x)))], + + ['conj', (s,...a) => _list_Q(s) ? a.reverse().concat(s) + : Vector.from(s.concat(a))], + ['seq', seq], + + ['meta', a => 'meta' in a ? a['meta'] : null], + ['with-meta', (a,b) => { let c = _clone(a); c.meta = b; return c }], + ['atom', a => new Atom(a)], + ['atom?', a => a instanceof Atom], + ['deref', atm => atm.val], + ['reset!', (atm,a) => atm.val = a], + ['swap!', (atm,f,...args) => atm.val = f(...[atm.val].concat(args))] + ]) diff --git a/impls/es6/env.mjs b/impls/es6/env.mjs index f0321286be..020f470b2e 100644 --- a/impls/es6/env.mjs +++ b/impls/es6/env.mjs @@ -1,17 +1,17 @@ -export function new_env(outer={}, binds=[], exprs=[]) { - var e = Object.setPrototypeOf({}, outer) - // Bind symbols in binds to values in exprs - for (var i=0; i { - if (sym in env) { return env[sym] } - throw Error(`'${Symbol.keyFor(sym)}' not found`) -} -export const env_set = (env, sym, val) => env[sym] = val +export function new_env(outer={}, binds=[], exprs=[]) { + var e = Object.setPrototypeOf({}, outer) + // Bind symbols in binds to values in exprs + for (var i=0; i { + if (sym in env) { return env[sym] } + throw Error(`'${Symbol.keyFor(sym)}' not found`) +} +export const env_set = (env, sym, val) => env[sym] = val diff --git a/impls/es6/node_readline.js b/impls/es6/node_readline.js index 500f892211..9ffc05f442 100644 --- a/impls/es6/node_readline.js +++ b/impls/es6/node_readline.js @@ -1,46 +1,46 @@ -// IMPORTANT: choose one -var RL_LIB = "libreadline"; // NOTE: libreadline is GPL -//var RL_LIB = "libedit"; - -var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); - -var ffi = require('ffi-napi'), - fs = require('fs'); - -var rllib = ffi.Library(RL_LIB, { - 'readline': [ 'string', [ 'string' ] ], - 'add_history': [ 'int', [ 'string' ] ]}); - -var rl_history_loaded = false; - -function readline(prompt) { - prompt = prompt || "user> "; - - if (!rl_history_loaded) { - rl_history_loaded = true; - var lines = []; - if (fs.existsSync(HISTORY_FILE)) { - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - } - // Max of 2000 lines - lines = lines.slice(Math.max(lines.length - 2000, 0)); - for (var i=0; i "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i pr_str(e,_r)).join(' ') + ")" - } else if (obj instanceof Vector) { - return "[" + obj.map(e => pr_str(e,_r)).join(' ') + "]" - } else if (obj instanceof Map) { - var ret = [] - for (let [k,v] of obj) { - ret.push(pr_str(k,_r), pr_str(v,_r)) - } - return "{" + ret.join(' ') + "}" - } else if (typeof obj === "string") { - if (_keyword_Q(obj)) { - return ':' + obj.slice(1) - } else if (_r) { - return '"' + obj.replace(/\\/g, "\\\\") - .replace(/"/g, '\\"') - .replace(/\n/g, "\\n") + '"' - } else { - return obj - } - } else if (typeof obj === 'symbol') { - return Symbol.keyFor(obj) - } else if (obj === null) { - return "nil" - } else if (obj instanceof Atom) { - return "(atom " + pr_str(obj.val,_r) + ")" - } else { - return obj.toString() - } -} +import { _list_Q, _keyword_Q, Vector, Atom } from './types' + +export function pr_str(obj, print_readably) { + if (typeof print_readably === 'undefined') { print_readably = true } + var _r = print_readably + if (_list_Q(obj)) { + return "(" + obj.map(e => pr_str(e,_r)).join(' ') + ")" + } else if (obj instanceof Vector) { + return "[" + obj.map(e => pr_str(e,_r)).join(' ') + "]" + } else if (obj instanceof Map) { + var ret = [] + for (let [k,v] of obj) { + ret.push(pr_str(k,_r), pr_str(v,_r)) + } + return "{" + ret.join(' ') + "}" + } else if (typeof obj === "string") { + if (_keyword_Q(obj)) { + return ':' + obj.slice(1) + } else if (_r) { + return '"' + obj.replace(/\\/g, "\\\\") + .replace(/"/g, '\\"') + .replace(/\n/g, "\\n") + '"' + } else { + return obj + } + } else if (typeof obj === 'symbol') { + return Symbol.keyFor(obj) + } else if (obj === null) { + return "nil" + } else if (obj instanceof Atom) { + return "(atom " + pr_str(obj.val,_r) + ")" + } else { + return obj.toString() + } +} diff --git a/impls/es6/reader.mjs b/impls/es6/reader.mjs index 996a08be69..edcca55aea 100644 --- a/impls/es6/reader.mjs +++ b/impls/es6/reader.mjs @@ -1,120 +1,120 @@ -import { _keyword, _assoc_BANG, Vector } from './types'; - -export class BlankException extends Error {} - -class Reader { - constructor(tokens) { - this.tokens = tokens - this.position = 0 - } - next() { return this.tokens[this.position++] } - peek() { return this.tokens[this.position] } -} - -function tokenize(str) { - const re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g - let match = null - let results = [] - while ((match = re.exec(str)[1]) != '') { - if (match[0] === ';') { continue } - results.push(match) - } - return results -} - -function read_atom (reader) { - const token = reader.next() - //console.log("read_atom:", token) - if (token.match(/^-?[0-9]+$/)) { - return parseInt(token,10) // integer - } else if (token.match(/^-?[0-9][0-9.]*$/)) { - return parseFloat(token,10) // float - } else if (token.match(/^"(?:\\.|[^\\"])*"$/)) { - return token.slice(1,token.length-1) - .replace(/\\(.)/g, (_, c) => c === "n" ? "\n" : c) - } else if (token[0] === "\"") { - throw new Error("expected '\"', got EOF"); - } else if (token[0] === ":") { - return _keyword(token.slice(1)) - } else if (token === "nil") { - return null - } else if (token === "true") { - return true - } else if (token === "false") { - return false - } else { - return Symbol.for(token) // symbol - } -} - -// read list of tokens -function read_list(reader, start, end) { - start = start || '(' - end = end || ')' - var ast = [] - var token = reader.next() - if (token !== start) { - throw new Error("expected '" + start + "'") - } - while ((token = reader.peek()) !== end) { - if (!token) { - throw new Error("expected '" + end + "', got EOF") - } - ast.push(read_form(reader)) - } - reader.next() - return ast -} - -// read vector of tokens -function read_vector(reader) { - return Vector.from(read_list(reader, '[', ']')); -} - -// read hash-map key/value pairs -function read_hash_map(reader) { - return _assoc_BANG(new Map(), ...read_list(reader, '{', '}')) -} - -function read_form(reader) { - var token = reader.peek() - switch (token) { - // reader macros/transforms - case ';': return null // Ignore comments - case '\'': reader.next() - return [Symbol.for('quote'), read_form(reader)] - case '`': reader.next() - return [Symbol.for('quasiquote'), read_form(reader)] - case '~': reader.next() - return [Symbol.for('unquote'), read_form(reader)] - case '~@': reader.next() - return [Symbol.for('splice-unquote'), read_form(reader)] - case '^': reader.next() - var meta = read_form(reader) - return [Symbol.for('with-meta'), read_form(reader), meta] - case '@': reader.next() - return [Symbol.for('deref'), read_form(reader)] - - // list - case ')': throw new Error("unexpected ')'") - case '(': return read_list(reader) - - // vector - case ']': throw new Error("unexpected ']'") - case '[': return read_vector(reader) - - // hash-map - case '}': throw new Error("unexpected '}'") - case '{': return read_hash_map(reader) - - // atom - default: return read_atom(reader) - } -} - -export function read_str(str) { - var tokens = tokenize(str) - if (tokens.length === 0) { throw new BlankException() } - return read_form(new Reader(tokens)) -} - +import { _keyword, _assoc_BANG, Vector } from './types'; + +export class BlankException extends Error {} + +class Reader { + constructor(tokens) { + this.tokens = tokens + this.position = 0 + } + next() { return this.tokens[this.position++] } + peek() { return this.tokens[this.position] } +} + +function tokenize(str) { + const re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g + let match = null + let results = [] + while ((match = re.exec(str)[1]) != '') { + if (match[0] === ';') { continue } + results.push(match) + } + return results +} + +function read_atom (reader) { + const token = reader.next() + //console.log("read_atom:", token) + if (token.match(/^-?[0-9]+$/)) { + return parseInt(token,10) // integer + } else if (token.match(/^-?[0-9][0-9.]*$/)) { + return parseFloat(token,10) // float + } else if (token.match(/^"(?:\\.|[^\\"])*"$/)) { + return token.slice(1,token.length-1) + .replace(/\\(.)/g, (_, c) => c === "n" ? "\n" : c) + } else if (token[0] === "\"") { + throw new Error("expected '\"', got EOF"); + } else if (token[0] === ":") { + return _keyword(token.slice(1)) + } else if (token === "nil") { + return null + } else if (token === "true") { + return true + } else if (token === "false") { + return false + } else { + return Symbol.for(token) // symbol + } +} + +// read list of tokens +function read_list(reader, start, end) { + start = start || '(' + end = end || ')' + var ast = [] + var token = reader.next() + if (token !== start) { + throw new Error("expected '" + start + "'") + } + while ((token = reader.peek()) !== end) { + if (!token) { + throw new Error("expected '" + end + "', got EOF") + } + ast.push(read_form(reader)) + } + reader.next() + return ast +} + +// read vector of tokens +function read_vector(reader) { + return Vector.from(read_list(reader, '[', ']')); +} + +// read hash-map key/value pairs +function read_hash_map(reader) { + return _assoc_BANG(new Map(), ...read_list(reader, '{', '}')) +} + +function read_form(reader) { + var token = reader.peek() + switch (token) { + // reader macros/transforms + case ';': return null // Ignore comments + case '\'': reader.next() + return [Symbol.for('quote'), read_form(reader)] + case '`': reader.next() + return [Symbol.for('quasiquote'), read_form(reader)] + case '~': reader.next() + return [Symbol.for('unquote'), read_form(reader)] + case '~@': reader.next() + return [Symbol.for('splice-unquote'), read_form(reader)] + case '^': reader.next() + var meta = read_form(reader) + return [Symbol.for('with-meta'), read_form(reader), meta] + case '@': reader.next() + return [Symbol.for('deref'), read_form(reader)] + + // list + case ')': throw new Error("unexpected ')'") + case '(': return read_list(reader) + + // vector + case ']': throw new Error("unexpected ']'") + case '[': return read_vector(reader) + + // hash-map + case '}': throw new Error("unexpected '}'") + case '{': return read_hash_map(reader) + + // atom + default: return read_atom(reader) + } +} + +export function read_str(str) { + var tokens = tokenize(str) + if (tokens.length === 0) { throw new BlankException() } + return read_form(new Reader(tokens)) +} + diff --git a/impls/es6/run b/impls/es6/run index ad5a837b2a..c9268db4c1 100755 --- a/impls/es6/run +++ b/impls/es6/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec node -r esm $(dirname $0)/${STEP:-stepA_mal}.mjs "${@}" +#!/bin/bash +exec node -r esm $(dirname $0)/${STEP:-stepA_mal}.mjs "${@}" diff --git a/impls/es6/step0_repl.mjs b/impls/es6/step0_repl.mjs index 6eaca056fa..1a90a202fd 100644 --- a/impls/es6/step0_repl.mjs +++ b/impls/es6/step0_repl.mjs @@ -1,20 +1,20 @@ -import rl from './node_readline.js' -const readline = rl.readline - -// read -const READ = str => str - -// eval -const EVAL = (ast, env) => ast - -// print -const PRINT = exp => exp - -// repl -const REP = str => PRINT(EVAL(READ(str), {})) - -while (true) { - let line = readline('user> ') - if (line == null) break - if (line) { console.log(REP(line)) } -} +import rl from './node_readline.js' +const readline = rl.readline + +// read +const READ = str => str + +// eval +const EVAL = (ast, env) => ast + +// print +const PRINT = exp => exp + +// repl +const REP = str => PRINT(EVAL(READ(str), {})) + +while (true) { + let line = readline('user> ') + if (line == null) break + if (line) { console.log(REP(line)) } +} diff --git a/impls/es6/step1_read_print.mjs b/impls/es6/step1_read_print.mjs index 48932cad53..20024e90b0 100644 --- a/impls/es6/step1_read_print.mjs +++ b/impls/es6/step1_read_print.mjs @@ -1,28 +1,28 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' - -// read -const READ = str => read_str(str) - -// eval -const EVAL = (ast, env) => ast - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -const REP = str => PRINT(EVAL(READ(str), {})) - -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${exc}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' + +// read +const READ = str => read_str(str) + +// eval +const EVAL = (ast, env) => ast + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +const REP = str => PRINT(EVAL(READ(str), {})) + +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } + } +} diff --git a/impls/es6/step2_eval.mjs b/impls/es6/step2_eval.mjs index e4a7977e5a..12b8cc8f1d 100644 --- a/impls/es6/step2_eval.mjs +++ b/impls/es6/step2_eval.mjs @@ -1,57 +1,57 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { _list_Q } from './types' -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' - -// read -const READ = str => read_str(str) - -// eval -const eval_ast = (ast, env) => { - if (typeof ast === 'symbol') { - if (ast in env) { - return env[ast] - } else { - throw Error(`'${Symbol.keyFor(ast)}' not found`) - } - } else if (ast instanceof Array) { - return ast.map(x => EVAL(x, env)) - } else if (ast instanceof Map) { - let new_hm = new Map() - ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) - return new_hm - } else { - return ast - } -} - -const EVAL = (ast, env) => { - if (!_list_Q(ast)) { return eval_ast(ast, env) } - if (ast.length === 0) { return ast } - - const [f, ...args] = eval_ast(ast, env) - return f(...args) -} - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -var repl_env = {[Symbol.for('+')]: (a,b) => a+b, - [Symbol.for('-')]: (a,b) => a-b, - [Symbol.for('*')]: (a,b) => a*b, - [Symbol.for('/')]: (a,b) => a/b} -const REP = str => PRINT(EVAL(READ(str), repl_env)) - -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${exc}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { _list_Q } from './types' +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' + +// read +const READ = str => read_str(str) + +// eval +const eval_ast = (ast, env) => { + if (typeof ast === 'symbol') { + if (ast in env) { + return env[ast] + } else { + throw Error(`'${Symbol.keyFor(ast)}' not found`) + } + } else if (ast instanceof Array) { + return ast.map(x => EVAL(x, env)) + } else if (ast instanceof Map) { + let new_hm = new Map() + ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) + return new_hm + } else { + return ast + } +} + +const EVAL = (ast, env) => { + if (!_list_Q(ast)) { return eval_ast(ast, env) } + if (ast.length === 0) { return ast } + + const [f, ...args] = eval_ast(ast, env) + return f(...args) +} + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +var repl_env = {[Symbol.for('+')]: (a,b) => a+b, + [Symbol.for('-')]: (a,b) => a-b, + [Symbol.for('*')]: (a,b) => a*b, + [Symbol.for('/')]: (a,b) => a/b} +const REP = str => PRINT(EVAL(READ(str), repl_env)) + +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } + } +} diff --git a/impls/es6/step3_env.mjs b/impls/es6/step3_env.mjs index 9faa93d6d1..a9f0ba4024 100644 --- a/impls/es6/step3_env.mjs +++ b/impls/es6/step3_env.mjs @@ -1,68 +1,68 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { _list_Q } from './types' -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' -import { new_env, env_set, env_get } from './env' - -// read -const READ = str => read_str(str) - -// eval -const eval_ast = (ast, env) => { - if (typeof ast === 'symbol') { - return env_get(env, ast) - } else if (ast instanceof Array) { - return ast.map(x => EVAL(x, env)) - } else if (ast instanceof Map) { - let new_hm = new Map() - ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) - return new_hm - } else { - return ast - } -} - -const EVAL = (ast, env) => { - //console.log('EVAL:', pr_str(ast, true)) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - if (ast.length === 0) { return ast } - - const [a0, a1, a2, a3] = ast - switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { - case 'def!': - return env_set(env, a1, EVAL(a2, env)) - case 'let*': - let let_env = new_env(env) - for (let i=0; i < a1.length; i+=2) { - env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) - } - return EVAL(a2, let_env) - default: - let [f, ...args] = eval_ast(ast, env) - return f(...args) - } -} - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -let repl_env = new_env() -env_set(repl_env, Symbol.for('+'), (a,b) => a+b) -env_set(repl_env, Symbol.for('-'), (a,b) => a-b) -env_set(repl_env, Symbol.for('*'), (a,b) => a*b) -env_set(repl_env, Symbol.for('/'), (a,b) => a/b) -const REP = str => PRINT(EVAL(READ(str), repl_env)) - -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${exc}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { _list_Q } from './types' +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' +import { new_env, env_set, env_get } from './env' + +// read +const READ = str => read_str(str) + +// eval +const eval_ast = (ast, env) => { + if (typeof ast === 'symbol') { + return env_get(env, ast) + } else if (ast instanceof Array) { + return ast.map(x => EVAL(x, env)) + } else if (ast instanceof Map) { + let new_hm = new Map() + ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) + return new_hm + } else { + return ast + } +} + +const EVAL = (ast, env) => { + //console.log('EVAL:', pr_str(ast, true)) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + if (ast.length === 0) { return ast } + + const [a0, a1, a2, a3] = ast + switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { + case 'def!': + return env_set(env, a1, EVAL(a2, env)) + case 'let*': + let let_env = new_env(env) + for (let i=0; i < a1.length; i+=2) { + env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) + } + return EVAL(a2, let_env) + default: + let [f, ...args] = eval_ast(ast, env) + return f(...args) + } +} + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +let repl_env = new_env() +env_set(repl_env, Symbol.for('+'), (a,b) => a+b) +env_set(repl_env, Symbol.for('-'), (a,b) => a-b) +env_set(repl_env, Symbol.for('*'), (a,b) => a*b) +env_set(repl_env, Symbol.for('/'), (a,b) => a/b) +const REP = str => PRINT(EVAL(READ(str), repl_env)) + +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } + } +} diff --git a/impls/es6/step4_if_fn_do.mjs b/impls/es6/step4_if_fn_do.mjs index 5e64a93273..3ff87f9517 100644 --- a/impls/es6/step4_if_fn_do.mjs +++ b/impls/es6/step4_if_fn_do.mjs @@ -1,82 +1,82 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { _list_Q } from './types' -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' -import { new_env, env_set, env_get } from './env' -import { core_ns } from './core' - -// read -const READ = str => read_str(str) - -// eval -const eval_ast = (ast, env) => { - if (typeof ast === 'symbol') { - return env_get(env, ast) - } else if (ast instanceof Array) { - return ast.map(x => EVAL(x, env)) - } else if (ast instanceof Map) { - let new_hm = new Map() - ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) - return new_hm - } else { - return ast - } -} - -const EVAL = (ast, env) => { - //console.log('EVAL:', pr_str(ast, true)) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - if (ast.length === 0) { return ast } - - const [a0, a1, a2, a3] = ast - switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { - case 'def!': - return env_set(env, a1, EVAL(a2, env)) - case 'let*': - let let_env = new_env(env) - for (let i=0; i < a1.length; i+=2) { - env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) - } - return EVAL(a2, let_env) - case 'do': - return eval_ast(ast.slice(1), env)[ast.length-2] - case 'if': - let cond = EVAL(a1, env) - if (cond === null || cond === false) { - return typeof a3 !== 'undefined' ? EVAL(a3, env) : null - } else { - return EVAL(a2, env) - } - case 'fn*': - return (...args) => EVAL(a2, new_env(env, a1, args)) - default: - let [f, ...args] = eval_ast(ast, env) - return f(...args) - } -} - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -let repl_env = new_env() -const REP = str => PRINT(EVAL(READ(str), repl_env)) - -// core.EXT: defined using ES6 -for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } - -// core.mal: defined using language itself -REP('(def! not (fn* (a) (if a false true)))') - -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${exc}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { _list_Q } from './types' +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' +import { new_env, env_set, env_get } from './env' +import { core_ns } from './core' + +// read +const READ = str => read_str(str) + +// eval +const eval_ast = (ast, env) => { + if (typeof ast === 'symbol') { + return env_get(env, ast) + } else if (ast instanceof Array) { + return ast.map(x => EVAL(x, env)) + } else if (ast instanceof Map) { + let new_hm = new Map() + ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) + return new_hm + } else { + return ast + } +} + +const EVAL = (ast, env) => { + //console.log('EVAL:', pr_str(ast, true)) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + if (ast.length === 0) { return ast } + + const [a0, a1, a2, a3] = ast + switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { + case 'def!': + return env_set(env, a1, EVAL(a2, env)) + case 'let*': + let let_env = new_env(env) + for (let i=0; i < a1.length; i+=2) { + env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) + } + return EVAL(a2, let_env) + case 'do': + return eval_ast(ast.slice(1), env)[ast.length-2] + case 'if': + let cond = EVAL(a1, env) + if (cond === null || cond === false) { + return typeof a3 !== 'undefined' ? EVAL(a3, env) : null + } else { + return EVAL(a2, env) + } + case 'fn*': + return (...args) => EVAL(a2, new_env(env, a1, args)) + default: + let [f, ...args] = eval_ast(ast, env) + return f(...args) + } +} + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +let repl_env = new_env() +const REP = str => PRINT(EVAL(READ(str), repl_env)) + +// core.EXT: defined using ES6 +for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } + +// core.mal: defined using language itself +REP('(def! not (fn* (a) (if a false true)))') + +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } + } +} diff --git a/impls/es6/step5_tco.mjs b/impls/es6/step5_tco.mjs index cf78e77f37..2d883c2a33 100644 --- a/impls/es6/step5_tco.mjs +++ b/impls/es6/step5_tco.mjs @@ -1,96 +1,96 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { _list_Q, _malfunc, _malfunc_Q } from './types' -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' -import { new_env, env_set, env_get } from './env' -import { core_ns } from './core' - -// read -const READ = str => read_str(str) - -// eval -const eval_ast = (ast, env) => { - if (typeof ast === 'symbol') { - return env_get(env, ast) - } else if (ast instanceof Array) { - return ast.map(x => EVAL(x, env)) - } else if (ast instanceof Map) { - let new_hm = new Map() - ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) - return new_hm - } else { - return ast - } -} - -const EVAL = (ast, env) => { - while (true) { - //console.log('EVAL:', pr_str(ast, true)) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - if (ast.length === 0) { return ast } - - const [a0, a1, a2, a3] = ast - switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { - case 'def!': - return env_set(env, a1, EVAL(a2, env)) - case 'let*': - let let_env = new_env(env) - for (let i=0; i < a1.length; i+=2) { - env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) - } - env = let_env - ast = a2 - break // continue TCO loop - case 'do': - eval_ast(ast.slice(1,-1), env) - ast = ast[ast.length-1] - break // continue TCO loop - case 'if': - let cond = EVAL(a1, env) - if (cond === null || cond === false) { - ast = (typeof a3 !== 'undefined') ? a3 : null - } else { - ast = a2 - } - break // continue TCO loop - case 'fn*': - return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), - a2, env, a1) - default: - let [f, ...args] = eval_ast(ast, env) - if (_malfunc_Q(f)) { - env = new_env(f.env, f.params, args) - ast = f.ast - break // continue TCO loop - } else { - return f(...args) - } - } - } -} - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -let repl_env = new_env() -const REP = str => PRINT(EVAL(READ(str), repl_env)) - -// core.EXT: defined using ES6 -for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } - -// core.mal: defined using language itself -REP('(def! not (fn* (a) (if a false true)))') - -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${exc}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { _list_Q, _malfunc, _malfunc_Q } from './types' +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' +import { new_env, env_set, env_get } from './env' +import { core_ns } from './core' + +// read +const READ = str => read_str(str) + +// eval +const eval_ast = (ast, env) => { + if (typeof ast === 'symbol') { + return env_get(env, ast) + } else if (ast instanceof Array) { + return ast.map(x => EVAL(x, env)) + } else if (ast instanceof Map) { + let new_hm = new Map() + ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) + return new_hm + } else { + return ast + } +} + +const EVAL = (ast, env) => { + while (true) { + //console.log('EVAL:', pr_str(ast, true)) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + if (ast.length === 0) { return ast } + + const [a0, a1, a2, a3] = ast + switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { + case 'def!': + return env_set(env, a1, EVAL(a2, env)) + case 'let*': + let let_env = new_env(env) + for (let i=0; i < a1.length; i+=2) { + env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) + } + env = let_env + ast = a2 + break // continue TCO loop + case 'do': + eval_ast(ast.slice(1,-1), env) + ast = ast[ast.length-1] + break // continue TCO loop + case 'if': + let cond = EVAL(a1, env) + if (cond === null || cond === false) { + ast = (typeof a3 !== 'undefined') ? a3 : null + } else { + ast = a2 + } + break // continue TCO loop + case 'fn*': + return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), + a2, env, a1) + default: + let [f, ...args] = eval_ast(ast, env) + if (_malfunc_Q(f)) { + env = new_env(f.env, f.params, args) + ast = f.ast + break // continue TCO loop + } else { + return f(...args) + } + } + } +} + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +let repl_env = new_env() +const REP = str => PRINT(EVAL(READ(str), repl_env)) + +// core.EXT: defined using ES6 +for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } + +// core.mal: defined using language itself +REP('(def! not (fn* (a) (if a false true)))') + +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } + } +} diff --git a/impls/es6/step6_file.mjs b/impls/es6/step6_file.mjs index 0ae7da764e..ec138f0484 100644 --- a/impls/es6/step6_file.mjs +++ b/impls/es6/step6_file.mjs @@ -1,106 +1,106 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { _list_Q, _malfunc, _malfunc_Q } from './types' -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' -import { new_env, env_set, env_get } from './env' -import { core_ns } from './core' - -// read -const READ = str => read_str(str) - -// eval -const eval_ast = (ast, env) => { - if (typeof ast === 'symbol') { - return env_get(env, ast) - } else if (ast instanceof Array) { - return ast.map(x => EVAL(x, env)) - } else if (ast instanceof Map) { - let new_hm = new Map() - ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) - return new_hm - } else { - return ast - } -} - -const EVAL = (ast, env) => { - while (true) { - //console.log('EVAL:', pr_str(ast, true)) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - if (ast.length === 0) { return ast } - - const [a0, a1, a2, a3] = ast - switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { - case 'def!': - return env_set(env, a1, EVAL(a2, env)) - case 'let*': - let let_env = new_env(env) - for (let i=0; i < a1.length; i+=2) { - env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) - } - env = let_env - ast = a2 - break // continue TCO loop - case 'do': - eval_ast(ast.slice(1,-1), env) - ast = ast[ast.length-1] - break // continue TCO loop - case 'if': - let cond = EVAL(a1, env) - if (cond === null || cond === false) { - ast = (typeof a3 !== 'undefined') ? a3 : null - } else { - ast = a2 - } - break // continue TCO loop - case 'fn*': - return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), - a2, env, a1) - default: - let [f, ...args] = eval_ast(ast, env) - if (_malfunc_Q(f)) { - env = new_env(f.env, f.params, args) - ast = f.ast - break // continue TCO loop - } else { - return f(...args) - } - } - } -} - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -let repl_env = new_env() -const REP = str => PRINT(EVAL(READ(str), repl_env)) - -// core.EXT: defined using ES6 -for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } -env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) -env_set(repl_env, Symbol.for('*ARGV*'), []) - -// core.mal: defined using language itself -REP('(def! not (fn* (a) (if a false true)))') -REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') - -if (process.argv.length > 2) { - env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) - REP(`(load-file "${process.argv[2]}")`) - process.exit(0) -} - - -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${exc}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { _list_Q, _malfunc, _malfunc_Q } from './types' +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' +import { new_env, env_set, env_get } from './env' +import { core_ns } from './core' + +// read +const READ = str => read_str(str) + +// eval +const eval_ast = (ast, env) => { + if (typeof ast === 'symbol') { + return env_get(env, ast) + } else if (ast instanceof Array) { + return ast.map(x => EVAL(x, env)) + } else if (ast instanceof Map) { + let new_hm = new Map() + ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) + return new_hm + } else { + return ast + } +} + +const EVAL = (ast, env) => { + while (true) { + //console.log('EVAL:', pr_str(ast, true)) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + if (ast.length === 0) { return ast } + + const [a0, a1, a2, a3] = ast + switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { + case 'def!': + return env_set(env, a1, EVAL(a2, env)) + case 'let*': + let let_env = new_env(env) + for (let i=0; i < a1.length; i+=2) { + env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) + } + env = let_env + ast = a2 + break // continue TCO loop + case 'do': + eval_ast(ast.slice(1,-1), env) + ast = ast[ast.length-1] + break // continue TCO loop + case 'if': + let cond = EVAL(a1, env) + if (cond === null || cond === false) { + ast = (typeof a3 !== 'undefined') ? a3 : null + } else { + ast = a2 + } + break // continue TCO loop + case 'fn*': + return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), + a2, env, a1) + default: + let [f, ...args] = eval_ast(ast, env) + if (_malfunc_Q(f)) { + env = new_env(f.env, f.params, args) + ast = f.ast + break // continue TCO loop + } else { + return f(...args) + } + } + } +} + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +let repl_env = new_env() +const REP = str => PRINT(EVAL(READ(str), repl_env)) + +// core.EXT: defined using ES6 +for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } +env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) +env_set(repl_env, Symbol.for('*ARGV*'), []) + +// core.mal: defined using language itself +REP('(def! not (fn* (a) (if a false true)))') +REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') + +if (process.argv.length > 2) { + env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) + REP(`(load-file "${process.argv[2]}")`) + process.exit(0) +} + + +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } + } +} diff --git a/impls/es6/step7_quote.mjs b/impls/es6/step7_quote.mjs index 9a7e9c1d8f..5eb09e6c7c 100644 --- a/impls/es6/step7_quote.mjs +++ b/impls/es6/step7_quote.mjs @@ -1,136 +1,136 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { _list_Q, _malfunc, _malfunc_Q, Vector } from './types' -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' -import { new_env, env_set, env_get } from './env' -import { core_ns } from './core' - -// read -const READ = str => read_str(str) - -// eval -const qq_loop = (acc, elt) => { - if (_list_Q(elt) && elt.length == 2 - && elt[0] === Symbol.for('splice-unquote')) { - return [Symbol.for('concat'), elt[1], acc] - } else { - return [Symbol.for('cons'), quasiquote (elt), acc] - } -} -const quasiquote = ast => { - if (_list_Q(ast)) { - if (ast.length == 2 && ast[0] === Symbol.for('unquote')) { - return ast[1] - } else { - return ast.reduceRight(qq_loop, []) - } - } else if (ast instanceof Vector) { - return [Symbol.for('vec'), ast.reduceRight(qq_loop, [])] - } else if (typeof ast === 'symbol' || ast instanceof Map) { - return [Symbol.for('quote'), ast] - } else { - return ast - } -} -const eval_ast = (ast, env) => { - if (typeof ast === 'symbol') { - return env_get(env, ast) - } else if (ast instanceof Array) { - return ast.map(x => EVAL(x, env)) - } else if (ast instanceof Map) { - let new_hm = new Map() - ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) - return new_hm - } else { - return ast - } -} - -const EVAL = (ast, env) => { - while (true) { - //console.log('EVAL:', pr_str(ast, true)) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - if (ast.length === 0) { return ast } - - const [a0, a1, a2, a3] = ast - switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { - case 'def!': - return env_set(env, a1, EVAL(a2, env)) - case 'let*': - let let_env = new_env(env) - for (let i=0; i < a1.length; i+=2) { - env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) - } - env = let_env - ast = a2 - break // continue TCO loop - case 'quote': - return a1 - case 'quasiquoteexpand': - return quasiquote(a1) - case 'quasiquote': - ast = quasiquote(a1) - break // continue TCO loop - case 'do': - eval_ast(ast.slice(1,-1), env) - ast = ast[ast.length-1] - break // continue TCO loop - case 'if': - let cond = EVAL(a1, env) - if (cond === null || cond === false) { - ast = (typeof a3 !== 'undefined') ? a3 : null - } else { - ast = a2 - } - break // continue TCO loop - case 'fn*': - return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), - a2, env, a1) - default: - let [f, ...args] = eval_ast(ast, env) - if (_malfunc_Q(f)) { - env = new_env(f.env, f.params, args) - ast = f.ast - break // continue TCO loop - } else { - return f(...args) - } - } - } -} - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -let repl_env = new_env() -const REP = str => PRINT(EVAL(READ(str), repl_env)) - -// core.EXT: defined using ES6 -for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } -env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) -env_set(repl_env, Symbol.for('*ARGV*'), []) - -// core.mal: defined using language itself -REP('(def! not (fn* (a) (if a false true)))') -REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') - -if (process.argv.length > 2) { - env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) - REP(`(load-file "${process.argv[2]}")`) - process.exit(0) -} - - -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${exc}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { _list_Q, _malfunc, _malfunc_Q, Vector } from './types' +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' +import { new_env, env_set, env_get } from './env' +import { core_ns } from './core' + +// read +const READ = str => read_str(str) + +// eval +const qq_loop = (acc, elt) => { + if (_list_Q(elt) && elt.length == 2 + && elt[0] === Symbol.for('splice-unquote')) { + return [Symbol.for('concat'), elt[1], acc] + } else { + return [Symbol.for('cons'), quasiquote (elt), acc] + } +} +const quasiquote = ast => { + if (_list_Q(ast)) { + if (ast.length == 2 && ast[0] === Symbol.for('unquote')) { + return ast[1] + } else { + return ast.reduceRight(qq_loop, []) + } + } else if (ast instanceof Vector) { + return [Symbol.for('vec'), ast.reduceRight(qq_loop, [])] + } else if (typeof ast === 'symbol' || ast instanceof Map) { + return [Symbol.for('quote'), ast] + } else { + return ast + } +} +const eval_ast = (ast, env) => { + if (typeof ast === 'symbol') { + return env_get(env, ast) + } else if (ast instanceof Array) { + return ast.map(x => EVAL(x, env)) + } else if (ast instanceof Map) { + let new_hm = new Map() + ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) + return new_hm + } else { + return ast + } +} + +const EVAL = (ast, env) => { + while (true) { + //console.log('EVAL:', pr_str(ast, true)) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + if (ast.length === 0) { return ast } + + const [a0, a1, a2, a3] = ast + switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { + case 'def!': + return env_set(env, a1, EVAL(a2, env)) + case 'let*': + let let_env = new_env(env) + for (let i=0; i < a1.length; i+=2) { + env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) + } + env = let_env + ast = a2 + break // continue TCO loop + case 'quote': + return a1 + case 'quasiquoteexpand': + return quasiquote(a1) + case 'quasiquote': + ast = quasiquote(a1) + break // continue TCO loop + case 'do': + eval_ast(ast.slice(1,-1), env) + ast = ast[ast.length-1] + break // continue TCO loop + case 'if': + let cond = EVAL(a1, env) + if (cond === null || cond === false) { + ast = (typeof a3 !== 'undefined') ? a3 : null + } else { + ast = a2 + } + break // continue TCO loop + case 'fn*': + return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), + a2, env, a1) + default: + let [f, ...args] = eval_ast(ast, env) + if (_malfunc_Q(f)) { + env = new_env(f.env, f.params, args) + ast = f.ast + break // continue TCO loop + } else { + return f(...args) + } + } + } +} + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +let repl_env = new_env() +const REP = str => PRINT(EVAL(READ(str), repl_env)) + +// core.EXT: defined using ES6 +for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } +env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) +env_set(repl_env, Symbol.for('*ARGV*'), []) + +// core.mal: defined using language itself +REP('(def! not (fn* (a) (if a false true)))') +REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') + +if (process.argv.length > 2) { + env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) + REP(`(load-file "${process.argv[2]}")`) + process.exit(0) +} + + +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } + } +} diff --git a/impls/es6/step8_macros.mjs b/impls/es6/step8_macros.mjs index 2b22eb96a4..5a72a3c445 100644 --- a/impls/es6/step8_macros.mjs +++ b/impls/es6/step8_macros.mjs @@ -1,157 +1,157 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { _clone, _list_Q, _malfunc, _malfunc_Q, Vector } from './types' -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' -import { new_env, env_set, env_get } from './env' -import { core_ns } from './core' - -// read -const READ = str => read_str(str) - -// eval -const qq_loop = (acc, elt) => { - if (_list_Q(elt) && elt.length == 2 - && elt[0] === Symbol.for('splice-unquote')) { - return [Symbol.for('concat'), elt[1], acc] - } else { - return [Symbol.for('cons'), quasiquote (elt), acc] - } -} -const quasiquote = ast => { - if (_list_Q(ast)) { - if (ast.length == 2 && ast[0] === Symbol.for('unquote')) { - return ast[1] - } else { - return ast.reduceRight(qq_loop, []) - } - } else if (ast instanceof Vector) { - return [Symbol.for('vec'), ast.reduceRight(qq_loop, [])] - } else if (typeof ast === 'symbol' || ast instanceof Map) { - return [Symbol.for('quote'), ast] - } else { - return ast - } -} - -function macroexpand(ast, env) { - while (_list_Q(ast) && typeof ast[0] === 'symbol' && ast[0] in env) { - let f = env_get(env, ast[0]) - if (!f.ismacro) { break } - ast = f(...ast.slice(1)) - } - return ast -} - - -const eval_ast = (ast, env) => { - if (typeof ast === 'symbol') { - return env_get(env, ast) - } else if (ast instanceof Array) { - return ast.map(x => EVAL(x, env)) - } else if (ast instanceof Map) { - let new_hm = new Map() - ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) - return new_hm - } else { - return ast - } -} - -const EVAL = (ast, env) => { - while (true) { - //console.log('EVAL:', pr_str(ast, true)) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - - ast = macroexpand(ast, env) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - if (ast.length === 0) { return ast } - - const [a0, a1, a2, a3] = ast - switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { - case 'def!': - return env_set(env, a1, EVAL(a2, env)) - case 'let*': - let let_env = new_env(env) - for (let i=0; i < a1.length; i+=2) { - env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) - } - env = let_env - ast = a2 - break // continue TCO loop - case 'quote': - return a1 - case 'quasiquoteexpand': - return quasiquote(a1) - case 'quasiquote': - ast = quasiquote(a1) - break // continue TCO loop - case 'defmacro!': - let func = _clone(EVAL(a2, env)) - func.ismacro = true - return env_set(env, a1, func) - case 'macroexpand': - return macroexpand(a1, env) - case 'do': - eval_ast(ast.slice(1,-1), env) - ast = ast[ast.length-1] - break // continue TCO loop - case 'if': - let cond = EVAL(a1, env) - if (cond === null || cond === false) { - ast = (typeof a3 !== 'undefined') ? a3 : null - } else { - ast = a2 - } - break // continue TCO loop - case 'fn*': - return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), - a2, env, a1) - default: - let [f, ...args] = eval_ast(ast, env) - if (_malfunc_Q(f)) { - env = new_env(f.env, f.params, args) - ast = f.ast - break // continue TCO loop - } else { - return f(...args) - } - } - } -} - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -let repl_env = new_env() -const REP = str => PRINT(EVAL(READ(str), repl_env)) - -// core.EXT: defined using ES6 -for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } -env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) -env_set(repl_env, Symbol.for('*ARGV*'), []) - -// core.mal: defined using language itself -REP('(def! not (fn* (a) (if a false true)))') -REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') -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)))))))') - -if (process.argv.length > 2) { - env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) - REP(`(load-file "${process.argv[2]}")`) - process.exit(0) -} - - -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${exc}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { _clone, _list_Q, _malfunc, _malfunc_Q, Vector } from './types' +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' +import { new_env, env_set, env_get } from './env' +import { core_ns } from './core' + +// read +const READ = str => read_str(str) + +// eval +const qq_loop = (acc, elt) => { + if (_list_Q(elt) && elt.length == 2 + && elt[0] === Symbol.for('splice-unquote')) { + return [Symbol.for('concat'), elt[1], acc] + } else { + return [Symbol.for('cons'), quasiquote (elt), acc] + } +} +const quasiquote = ast => { + if (_list_Q(ast)) { + if (ast.length == 2 && ast[0] === Symbol.for('unquote')) { + return ast[1] + } else { + return ast.reduceRight(qq_loop, []) + } + } else if (ast instanceof Vector) { + return [Symbol.for('vec'), ast.reduceRight(qq_loop, [])] + } else if (typeof ast === 'symbol' || ast instanceof Map) { + return [Symbol.for('quote'), ast] + } else { + return ast + } +} + +function macroexpand(ast, env) { + while (_list_Q(ast) && typeof ast[0] === 'symbol' && ast[0] in env) { + let f = env_get(env, ast[0]) + if (!f.ismacro) { break } + ast = f(...ast.slice(1)) + } + return ast +} + + +const eval_ast = (ast, env) => { + if (typeof ast === 'symbol') { + return env_get(env, ast) + } else if (ast instanceof Array) { + return ast.map(x => EVAL(x, env)) + } else if (ast instanceof Map) { + let new_hm = new Map() + ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) + return new_hm + } else { + return ast + } +} + +const EVAL = (ast, env) => { + while (true) { + //console.log('EVAL:', pr_str(ast, true)) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + + ast = macroexpand(ast, env) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + if (ast.length === 0) { return ast } + + const [a0, a1, a2, a3] = ast + switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { + case 'def!': + return env_set(env, a1, EVAL(a2, env)) + case 'let*': + let let_env = new_env(env) + for (let i=0; i < a1.length; i+=2) { + env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) + } + env = let_env + ast = a2 + break // continue TCO loop + case 'quote': + return a1 + case 'quasiquoteexpand': + return quasiquote(a1) + case 'quasiquote': + ast = quasiquote(a1) + break // continue TCO loop + case 'defmacro!': + let func = _clone(EVAL(a2, env)) + func.ismacro = true + return env_set(env, a1, func) + case 'macroexpand': + return macroexpand(a1, env) + case 'do': + eval_ast(ast.slice(1,-1), env) + ast = ast[ast.length-1] + break // continue TCO loop + case 'if': + let cond = EVAL(a1, env) + if (cond === null || cond === false) { + ast = (typeof a3 !== 'undefined') ? a3 : null + } else { + ast = a2 + } + break // continue TCO loop + case 'fn*': + return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), + a2, env, a1) + default: + let [f, ...args] = eval_ast(ast, env) + if (_malfunc_Q(f)) { + env = new_env(f.env, f.params, args) + ast = f.ast + break // continue TCO loop + } else { + return f(...args) + } + } + } +} + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +let repl_env = new_env() +const REP = str => PRINT(EVAL(READ(str), repl_env)) + +// core.EXT: defined using ES6 +for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } +env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) +env_set(repl_env, Symbol.for('*ARGV*'), []) + +// core.mal: defined using language itself +REP('(def! not (fn* (a) (if a false true)))') +REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') +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)))))))') + +if (process.argv.length > 2) { + env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) + REP(`(load-file "${process.argv[2]}")`) + process.exit(0) +} + + +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${exc}`) } + } +} diff --git a/impls/es6/step9_try.mjs b/impls/es6/step9_try.mjs index ad35ac2bce..b288997800 100644 --- a/impls/es6/step9_try.mjs +++ b/impls/es6/step9_try.mjs @@ -1,168 +1,168 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { _clone, _list_Q, _malfunc, _malfunc_Q, Vector } from './types' -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' -import { new_env, env_set, env_get } from './env' -import { core_ns } from './core' - -// read -const READ = str => read_str(str) - -// eval -const qq_loop = (acc, elt) => { - if (_list_Q(elt) && elt.length == 2 - && elt[0] === Symbol.for('splice-unquote')) { - return [Symbol.for('concat'), elt[1], acc] - } else { - return [Symbol.for('cons'), quasiquote (elt), acc] - } -} -const quasiquote = ast => { - if (_list_Q(ast)) { - if (ast.length == 2 && ast[0] === Symbol.for('unquote')) { - return ast[1] - } else { - return ast.reduceRight(qq_loop, []) - } - } else if (ast instanceof Vector) { - return [Symbol.for('vec'), ast.reduceRight(qq_loop, [])] - } else if (typeof ast === 'symbol' || ast instanceof Map) { - return [Symbol.for('quote'), ast] - } else { - return ast - } -} - -function macroexpand(ast, env) { - while (_list_Q(ast) && typeof ast[0] === 'symbol' && ast[0] in env) { - let f = env_get(env, ast[0]) - if (!f.ismacro) { break } - ast = f(...ast.slice(1)) - } - return ast -} - - -const eval_ast = (ast, env) => { - if (typeof ast === 'symbol') { - return env_get(env, ast) - } else if (ast instanceof Array) { - return ast.map(x => EVAL(x, env)) - } else if (ast instanceof Map) { - let new_hm = new Map() - ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) - return new_hm - } else { - return ast - } -} - -const EVAL = (ast, env) => { - while (true) { - //console.log('EVAL:', pr_str(ast, true)) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - - ast = macroexpand(ast, env) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - if (ast.length === 0) { return ast } - - const [a0, a1, a2, a3] = ast - switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { - case 'def!': - return env_set(env, a1, EVAL(a2, env)) - case 'let*': - let let_env = new_env(env) - for (let i=0; i < a1.length; i+=2) { - env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) - } - env = let_env - ast = a2 - break // continue TCO loop - case 'quote': - return a1 - case 'quasiquoteexpand': - return quasiquote(a1) - case 'quasiquote': - ast = quasiquote(a1) - break // continue TCO loop - case 'defmacro!': - let func = _clone(EVAL(a2, env)) - func.ismacro = true - return env_set(env, a1, func) - case 'macroexpand': - return macroexpand(a1, env) - case 'try*': - try { - return EVAL(a1, env) - } catch (exc) { - if (a2 && a2[0] === Symbol.for('catch*')) { - if (exc instanceof Error) { exc = exc.message } - return EVAL(a2[2], new_env(env, [a2[1]], [exc])) - } else { - throw exc - } - } - case 'do': - eval_ast(ast.slice(1,-1), env) - ast = ast[ast.length-1] - break // continue TCO loop - case 'if': - let cond = EVAL(a1, env) - if (cond === null || cond === false) { - ast = (typeof a3 !== 'undefined') ? a3 : null - } else { - ast = a2 - } - break // continue TCO loop - case 'fn*': - return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), - a2, env, a1) - default: - let [f, ...args] = eval_ast(ast, env) - if (_malfunc_Q(f)) { - env = new_env(f.env, f.params, args) - ast = f.ast - break // continue TCO loop - } else { - return f(...args) - } - } - } -} - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -let repl_env = new_env() -const REP = str => PRINT(EVAL(READ(str), repl_env)) - -// core.EXT: defined using ES6 -for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } -env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) -env_set(repl_env, Symbol.for('*ARGV*'), []) - -// core.mal: defined using language itself -REP('(def! not (fn* (a) (if a false true)))') -REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') -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)))))))') - -if (process.argv.length > 2) { - env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) - REP(`(load-file "${process.argv[2]}")`) - process.exit(0) -} - - -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${pr_str(exc, true)}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { _clone, _list_Q, _malfunc, _malfunc_Q, Vector } from './types' +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' +import { new_env, env_set, env_get } from './env' +import { core_ns } from './core' + +// read +const READ = str => read_str(str) + +// eval +const qq_loop = (acc, elt) => { + if (_list_Q(elt) && elt.length == 2 + && elt[0] === Symbol.for('splice-unquote')) { + return [Symbol.for('concat'), elt[1], acc] + } else { + return [Symbol.for('cons'), quasiquote (elt), acc] + } +} +const quasiquote = ast => { + if (_list_Q(ast)) { + if (ast.length == 2 && ast[0] === Symbol.for('unquote')) { + return ast[1] + } else { + return ast.reduceRight(qq_loop, []) + } + } else if (ast instanceof Vector) { + return [Symbol.for('vec'), ast.reduceRight(qq_loop, [])] + } else if (typeof ast === 'symbol' || ast instanceof Map) { + return [Symbol.for('quote'), ast] + } else { + return ast + } +} + +function macroexpand(ast, env) { + while (_list_Q(ast) && typeof ast[0] === 'symbol' && ast[0] in env) { + let f = env_get(env, ast[0]) + if (!f.ismacro) { break } + ast = f(...ast.slice(1)) + } + return ast +} + + +const eval_ast = (ast, env) => { + if (typeof ast === 'symbol') { + return env_get(env, ast) + } else if (ast instanceof Array) { + return ast.map(x => EVAL(x, env)) + } else if (ast instanceof Map) { + let new_hm = new Map() + ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) + return new_hm + } else { + return ast + } +} + +const EVAL = (ast, env) => { + while (true) { + //console.log('EVAL:', pr_str(ast, true)) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + + ast = macroexpand(ast, env) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + if (ast.length === 0) { return ast } + + const [a0, a1, a2, a3] = ast + switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { + case 'def!': + return env_set(env, a1, EVAL(a2, env)) + case 'let*': + let let_env = new_env(env) + for (let i=0; i < a1.length; i+=2) { + env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) + } + env = let_env + ast = a2 + break // continue TCO loop + case 'quote': + return a1 + case 'quasiquoteexpand': + return quasiquote(a1) + case 'quasiquote': + ast = quasiquote(a1) + break // continue TCO loop + case 'defmacro!': + let func = _clone(EVAL(a2, env)) + func.ismacro = true + return env_set(env, a1, func) + case 'macroexpand': + return macroexpand(a1, env) + case 'try*': + try { + return EVAL(a1, env) + } catch (exc) { + if (a2 && a2[0] === Symbol.for('catch*')) { + if (exc instanceof Error) { exc = exc.message } + return EVAL(a2[2], new_env(env, [a2[1]], [exc])) + } else { + throw exc + } + } + case 'do': + eval_ast(ast.slice(1,-1), env) + ast = ast[ast.length-1] + break // continue TCO loop + case 'if': + let cond = EVAL(a1, env) + if (cond === null || cond === false) { + ast = (typeof a3 !== 'undefined') ? a3 : null + } else { + ast = a2 + } + break // continue TCO loop + case 'fn*': + return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), + a2, env, a1) + default: + let [f, ...args] = eval_ast(ast, env) + if (_malfunc_Q(f)) { + env = new_env(f.env, f.params, args) + ast = f.ast + break // continue TCO loop + } else { + return f(...args) + } + } + } +} + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +let repl_env = new_env() +const REP = str => PRINT(EVAL(READ(str), repl_env)) + +// core.EXT: defined using ES6 +for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } +env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) +env_set(repl_env, Symbol.for('*ARGV*'), []) + +// core.mal: defined using language itself +REP('(def! not (fn* (a) (if a false true)))') +REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') +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)))))))') + +if (process.argv.length > 2) { + env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) + REP(`(load-file "${process.argv[2]}")`) + process.exit(0) +} + + +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${pr_str(exc, true)}`) } + } +} diff --git a/impls/es6/stepA_mal.mjs b/impls/es6/stepA_mal.mjs index 80261fbdc5..be3eeacd84 100644 --- a/impls/es6/stepA_mal.mjs +++ b/impls/es6/stepA_mal.mjs @@ -1,169 +1,169 @@ -import rl from './node_readline.js' -const readline = rl.readline -import { _clone, _list_Q, _malfunc, _malfunc_Q, Vector } from './types' -import { BlankException, read_str } from './reader' -import { pr_str } from './printer' -import { new_env, env_set, env_get } from './env' -import { core_ns } from './core' - -// read -const READ = str => read_str(str) - -// eval -const qq_loop = (acc, elt) => { - if (_list_Q(elt) && elt.length == 2 - && elt[0] === Symbol.for('splice-unquote')) { - return [Symbol.for('concat'), elt[1], acc] - } else { - return [Symbol.for('cons'), quasiquote (elt), acc] - } -} -const quasiquote = ast => { - if (_list_Q(ast)) { - if (ast.length == 2 && ast[0] === Symbol.for('unquote')) { - return ast[1] - } else { - return ast.reduceRight(qq_loop, []) - } - } else if (ast instanceof Vector) { - return [Symbol.for('vec'), ast.reduceRight(qq_loop, [])] - } else if (typeof ast === 'symbol' || ast instanceof Map) { - return [Symbol.for('quote'), ast] - } else { - return ast - } -} - -function macroexpand(ast, env) { - while (_list_Q(ast) && typeof ast[0] === 'symbol' && ast[0] in env) { - let f = env_get(env, ast[0]) - if (!f.ismacro) { break } - ast = f(...ast.slice(1)) - } - return ast -} - - -const eval_ast = (ast, env) => { - if (typeof ast === 'symbol') { - return env_get(env, ast) - } else if (ast instanceof Array) { - return ast.map(x => EVAL(x, env)) - } else if (ast instanceof Map) { - let new_hm = new Map() - ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) - return new_hm - } else { - return ast - } -} - -const EVAL = (ast, env) => { - while (true) { - //console.log('EVAL:', pr_str(ast, true)) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - - ast = macroexpand(ast, env) - if (!_list_Q(ast)) { return eval_ast(ast, env) } - if (ast.length === 0) { return ast } - - const [a0, a1, a2, a3] = ast - switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { - case 'def!': - return env_set(env, a1, EVAL(a2, env)) - case 'let*': - let let_env = new_env(env) - for (let i=0; i < a1.length; i+=2) { - env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) - } - env = let_env - ast = a2 - break // continue TCO loop - case 'quote': - return a1 - case 'quasiquoteexpand': - return quasiquote(a1) - case 'quasiquote': - ast = quasiquote(a1) - break // continue TCO loop - case 'defmacro!': - let func = _clone(EVAL(a2, env)) - func.ismacro = true - return env_set(env, a1, func) - case 'macroexpand': - return macroexpand(a1, env) - case 'try*': - try { - return EVAL(a1, env) - } catch (exc) { - if (a2 && a2[0] === Symbol.for('catch*')) { - if (exc instanceof Error) { exc = exc.message } - return EVAL(a2[2], new_env(env, [a2[1]], [exc])) - } else { - throw exc - } - } - case 'do': - eval_ast(ast.slice(1,-1), env) - ast = ast[ast.length-1] - break // continue TCO loop - case 'if': - let cond = EVAL(a1, env) - if (cond === null || cond === false) { - ast = (typeof a3 !== 'undefined') ? a3 : null - } else { - ast = a2 - } - break // continue TCO loop - case 'fn*': - return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), - a2, env, a1) - default: - let [f, ...args] = eval_ast(ast, env) - if (_malfunc_Q(f)) { - env = new_env(f.env, f.params, args) - ast = f.ast - break // continue TCO loop - } else { - return f(...args) - } - } - } -} - -// print -const PRINT = exp => pr_str(exp, true) - -// repl -let repl_env = new_env() -const REP = str => PRINT(EVAL(READ(str), repl_env)) - -// core.EXT: defined using ES6 -for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } -env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) -env_set(repl_env, Symbol.for('*ARGV*'), []) - -// core.mal: defined using language itself -REP('(def! *host-language* "ecmascript6")') -REP('(def! not (fn* (a) (if a false true)))') -REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') -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)))))))') - -if (process.argv.length > 2) { - env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) - REP(`(load-file "${process.argv[2]}")`) - process.exit(0) -} - -REP('(println (str "Mal [" *host-language* "]"))') -while (true) { - let line = readline('user> ') - if (line == null) break - try { - if (line) { console.log(REP(line)) } - } catch (exc) { - if (exc instanceof BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn(`Error: ${pr_str(exc, true)}`) } - } -} +import rl from './node_readline.js' +const readline = rl.readline +import { _clone, _list_Q, _malfunc, _malfunc_Q, Vector } from './types' +import { BlankException, read_str } from './reader' +import { pr_str } from './printer' +import { new_env, env_set, env_get } from './env' +import { core_ns } from './core' + +// read +const READ = str => read_str(str) + +// eval +const qq_loop = (acc, elt) => { + if (_list_Q(elt) && elt.length == 2 + && elt[0] === Symbol.for('splice-unquote')) { + return [Symbol.for('concat'), elt[1], acc] + } else { + return [Symbol.for('cons'), quasiquote (elt), acc] + } +} +const quasiquote = ast => { + if (_list_Q(ast)) { + if (ast.length == 2 && ast[0] === Symbol.for('unquote')) { + return ast[1] + } else { + return ast.reduceRight(qq_loop, []) + } + } else if (ast instanceof Vector) { + return [Symbol.for('vec'), ast.reduceRight(qq_loop, [])] + } else if (typeof ast === 'symbol' || ast instanceof Map) { + return [Symbol.for('quote'), ast] + } else { + return ast + } +} + +function macroexpand(ast, env) { + while (_list_Q(ast) && typeof ast[0] === 'symbol' && ast[0] in env) { + let f = env_get(env, ast[0]) + if (!f.ismacro) { break } + ast = f(...ast.slice(1)) + } + return ast +} + + +const eval_ast = (ast, env) => { + if (typeof ast === 'symbol') { + return env_get(env, ast) + } else if (ast instanceof Array) { + return ast.map(x => EVAL(x, env)) + } else if (ast instanceof Map) { + let new_hm = new Map() + ast.forEach((v, k) => new_hm.set(k, EVAL(v, env))) + return new_hm + } else { + return ast + } +} + +const EVAL = (ast, env) => { + while (true) { + //console.log('EVAL:', pr_str(ast, true)) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + + ast = macroexpand(ast, env) + if (!_list_Q(ast)) { return eval_ast(ast, env) } + if (ast.length === 0) { return ast } + + const [a0, a1, a2, a3] = ast + switch (typeof a0 === 'symbol' ? Symbol.keyFor(a0) : Symbol(':default')) { + case 'def!': + return env_set(env, a1, EVAL(a2, env)) + case 'let*': + let let_env = new_env(env) + for (let i=0; i < a1.length; i+=2) { + env_set(let_env, a1[i], EVAL(a1[i+1], let_env)) + } + env = let_env + ast = a2 + break // continue TCO loop + case 'quote': + return a1 + case 'quasiquoteexpand': + return quasiquote(a1) + case 'quasiquote': + ast = quasiquote(a1) + break // continue TCO loop + case 'defmacro!': + let func = _clone(EVAL(a2, env)) + func.ismacro = true + return env_set(env, a1, func) + case 'macroexpand': + return macroexpand(a1, env) + case 'try*': + try { + return EVAL(a1, env) + } catch (exc) { + if (a2 && a2[0] === Symbol.for('catch*')) { + if (exc instanceof Error) { exc = exc.message } + return EVAL(a2[2], new_env(env, [a2[1]], [exc])) + } else { + throw exc + } + } + case 'do': + eval_ast(ast.slice(1,-1), env) + ast = ast[ast.length-1] + break // continue TCO loop + case 'if': + let cond = EVAL(a1, env) + if (cond === null || cond === false) { + ast = (typeof a3 !== 'undefined') ? a3 : null + } else { + ast = a2 + } + break // continue TCO loop + case 'fn*': + return _malfunc((...args) => EVAL(a2, new_env(env, a1, args)), + a2, env, a1) + default: + let [f, ...args] = eval_ast(ast, env) + if (_malfunc_Q(f)) { + env = new_env(f.env, f.params, args) + ast = f.ast + break // continue TCO loop + } else { + return f(...args) + } + } + } +} + +// print +const PRINT = exp => pr_str(exp, true) + +// repl +let repl_env = new_env() +const REP = str => PRINT(EVAL(READ(str), repl_env)) + +// core.EXT: defined using ES6 +for (let [k, v] of core_ns) { env_set(repl_env, Symbol.for(k), v) } +env_set(repl_env, Symbol.for('eval'), a => EVAL(a, repl_env)) +env_set(repl_env, Symbol.for('*ARGV*'), []) + +// core.mal: defined using language itself +REP('(def! *host-language* "ecmascript6")') +REP('(def! not (fn* (a) (if a false true)))') +REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') +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)))))))') + +if (process.argv.length > 2) { + env_set(repl_env, Symbol.for('*ARGV*'), process.argv.slice(3)) + REP(`(load-file "${process.argv[2]}")`) + process.exit(0) +} + +REP('(println (str "Mal [" *host-language* "]"))') +while (true) { + let line = readline('user> ') + if (line == null) break + try { + if (line) { console.log(REP(line)) } + } catch (exc) { + if (exc instanceof BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn(`Error: ${pr_str(exc, true)}`) } + } +} diff --git a/impls/es6/tests/step5_tco.mal b/impls/es6/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/es6/tests/step5_tco.mal +++ b/impls/es6/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/es6/types.mjs b/impls/es6/types.mjs index d6198b6dce..08db20bdef 100644 --- a/impls/es6/types.mjs +++ b/impls/es6/types.mjs @@ -1,68 +1,68 @@ -// General functions -export function _equal_Q (a, b) { - if (Array.isArray(a) && Array.isArray(b)) { - if (a.length !== b.length) { return false } - for (let i=0; i obj.apply(f, a) // new function instance - new_obj = Object.assign(f, obj) // copy original properties - } else { - throw Error('Unsupported type for clone') - } - if (typeof new_meta !== 'undefined') { new_obj.meta = new_meta } - return new_obj -} - -// Functions -export function _malfunc(f, ast, env, params, meta=null, ismacro=false) { - return Object.assign(f, {ast, env, params, meta, ismacro}) -} -export const _malfunc_Q = f => f.ast ? true : false - - -// Keywords -export const _keyword = obj => _keyword_Q(obj) ? obj : '\u029e' + obj -export const _keyword_Q = obj => typeof obj === 'string' && obj[0] === '\u029e' - -// Lists -export const _list_Q = obj => Array.isArray(obj) && !(obj instanceof Vector) - -// Vectors -export class Vector extends Array { } - -// Maps -export function _assoc_BANG(hm, ...args) { - if (args.length % 2 === 1) { - throw new Error('Odd number of assoc arguments') - } - for (let i=0; i obj.apply(f, a) // new function instance + new_obj = Object.assign(f, obj) // copy original properties + } else { + throw Error('Unsupported type for clone') + } + if (typeof new_meta !== 'undefined') { new_obj.meta = new_meta } + return new_obj +} + +// Functions +export function _malfunc(f, ast, env, params, meta=null, ismacro=false) { + return Object.assign(f, {ast, env, params, meta, ismacro}) +} +export const _malfunc_Q = f => f.ast ? true : false + + +// Keywords +export const _keyword = obj => _keyword_Q(obj) ? obj : '\u029e' + obj +export const _keyword_Q = obj => typeof obj === 'string' && obj[0] === '\u029e' + +// Lists +export const _list_Q = obj => Array.isArray(obj) && !(obj instanceof Vector) + +// Vectors +export class Vector extends Array { } + +// Maps +export function _assoc_BANG(hm, ...args) { + if (args.length % 2 === 1) { + throw new Error('Odd number of assoc arguments') + } + for (let i=0; i - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Factor -RUN apt-get -y install libgtkglext1 -RUN cd /usr/lib/x86_64-linux-gnu/ \ - && curl -O http://downloads.factorcode.org/releases/0.97/factor-linux-x86-64-0.97.tar.gz \ - && tar xvzf factor-linux-x86-64-0.97.tar.gz \ - && ln -sf /usr/lib/x86_64-linux-gnu/factor/factor /usr/bin/factor \ - && rm factor-linux-x86-64-0.97.tar.gz - +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Factor +RUN apt-get -y install libgtkglext1 +RUN cd /usr/lib/x86_64-linux-gnu/ \ + && curl -O http://downloads.factorcode.org/releases/0.97/factor-linux-x86-64-0.97.tar.gz \ + && tar xvzf factor-linux-x86-64-0.97.tar.gz \ + && ln -sf /usr/lib/x86_64-linux-gnu/factor/factor /usr/bin/factor \ + && rm factor-linux-x86-64-0.97.tar.gz + diff --git a/impls/factor/Makefile b/impls/factor/Makefile index e4cabeff1d..e09c4ae6a1 100644 --- a/impls/factor/Makefile +++ b/impls/factor/Makefile @@ -1,31 +1,31 @@ -SOURCES_BASE = lib/types/types.factor lib/reader/reader.factor lib/printer/printer.factor -SOURCES_LISP = lib/env/env.factor lib/core/core.factor stepA_mal/stepA_mal.factor -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.factor mal - -# dependency order (env must come before types) -ORDERED_SOURCES = $(filter %env.factor,$(SOURCES)) $(filter-out %env.factor,$(SOURCES)) -mal.factor: $(ORDERED_SOURCES) - cat $+ | sed '/^USING:/,/;/ s/ *lib.[a-z]*//g' > $@ - -mal: mal.factor - echo '#!/usr/bin/env factor' > $@ - cat $< >> $@ - chmod +x $@ - -# TODO: standalone compiled app -#mal.factor: $(SOURCES) -# mkdir -p dist_tmp; \ -# FDIR=$$(dirname $$(readlink -f $$(which factor))); \ -# for f in $${FDIR}/*; do ln -sf $$f dist_tmp/; done; \ -# rm dist_tmp/factor; \ -# cp $${FDIR}/factor dist_tmp/factor; \ -# HOME=/mal FACTOR_ROOTS=. dist_tmp/factor dist.factor -# #cat $+ | sed 's///' >> $@ - -clean: - rm -f mal.factor +SOURCES_BASE = lib/types/types.factor lib/reader/reader.factor lib/printer/printer.factor +SOURCES_LISP = lib/env/env.factor lib/core/core.factor stepA_mal/stepA_mal.factor +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.factor mal + +# dependency order (env must come before types) +ORDERED_SOURCES = $(filter %env.factor,$(SOURCES)) $(filter-out %env.factor,$(SOURCES)) +mal.factor: $(ORDERED_SOURCES) + cat $+ | sed '/^USING:/,/;/ s/ *lib.[a-z]*//g' > $@ + +mal: mal.factor + echo '#!/usr/bin/env factor' > $@ + cat $< >> $@ + chmod +x $@ + +# TODO: standalone compiled app +#mal.factor: $(SOURCES) +# mkdir -p dist_tmp; \ +# FDIR=$$(dirname $$(readlink -f $$(which factor))); \ +# for f in $${FDIR}/*; do ln -sf $$f dist_tmp/; done; \ +# rm dist_tmp/factor; \ +# cp $${FDIR}/factor dist_tmp/factor; \ +# HOME=/mal FACTOR_ROOTS=. dist_tmp/factor dist.factor +# #cat $+ | sed 's///' >> $@ + +clean: + rm -f mal.factor diff --git a/impls/factor/lib/core/core-tests.factor b/impls/factor/lib/core/core-tests.factor index 0e603c1faf..eae0107bbe 100644 --- a/impls/factor/lib/core/core-tests.factor +++ b/impls/factor/lib/core/core-tests.factor @@ -1,8 +1,8 @@ -USING: assocs effects kernel sequences stack-checker tools.test ; -IN: lib.core - -{ t } [ - ns values [ - infer ( x -- * ) ( x -- x ) [ effect= ] bi-curry@ bi or - ] all? -] unit-test +USING: assocs effects kernel sequences stack-checker tools.test ; +IN: lib.core + +{ t } [ + ns values [ + infer ( x -- * ) ( x -- x ) [ effect= ] bi-curry@ bi or + ] all? +] unit-test diff --git a/impls/factor/lib/core/core.factor b/impls/factor/lib/core/core.factor index 1c0cf6671a..c123930045 100644 --- a/impls/factor/lib/core/core.factor +++ b/impls/factor/lib/core/core.factor @@ -1,86 +1,86 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators -combinators.short-circuit fry grouping hash-sets hashtables io -io.encodings.utf8 io.files kernel lists lib.env lib.printer -lib.reader lib.types math namespaces quotations readline sequences sets -strings system vectors ; -IN: lib.core - -SYMBOL: mal-apply - -: pr-str-stack ( exprs readably? glue -- str ) - [ '[ _ (pr-str) ] map ] dip join ; - -CONSTANT: empty-env T{ malenv f f H{ } } - -CONSTANT: ns H{ - { "+" [ first2 + ] } - { "-" [ first2 - ] } - { "*" [ first2 * ] } - { "/" [ first2 / ] } - { "list" [ >array ] } - { "list?" [ first array? ] } - { "empty?" [ first empty? ] } - { "count" [ first dup nil? [ drop 0 ] [ length ] if ] } - { "=" [ first2 mal= ] } - { "<" [ first2 < ] } - { ">" [ first2 > ] } - { ">=" [ first2 >= ] } - { "<=" [ first2 <= ] } - { "pr-str" [ t " " pr-str-stack ] } - { "str" [ f "" pr-str-stack ] } - { "prn" [ t " " pr-str-stack print flush nil ] } - { "println" [ f " " pr-str-stack print flush nil ] } - { "read-string" [ first read-str ] } - { "slurp" [ first utf8 file-contents ] } - { "cons" [ first2 swap prefix { } like ] } - { "concat" [ concat { } like ] } - { "vec" [ first >vector ] } - { "nth" [ first2 swap nth ] } - { "first" [ first dup nil? [ drop nil ] [ [ nil ] [ first ] if-empty ] if ] } - { "rest" [ first dup nil? [ drop { } ] [ [ { } ] [ rest { } like ] if-empty ] if ] } - { "throw" [ first throw ] } - { "apply" [ unclip [ unclip-last append ] dip mal-apply get call( args fn -- maltype ) ] } - { "map" [ first2 swap '[ 1array _ mal-apply get call( args fn -- maltype ) ] map { } like ] } - { "nil?" [ first nil? ] } - { "true?" [ first t = ] } - { "false?" [ first f = ] } - { "symbol" [ first ] } - { "symbol?" [ first malsymbol? ] } - { "string?" [ first string? ] } - { "keyword" [ first dup string? [ ] when ] } - { "keyword?" [ first malkeyword? ] } - { "number?" [ first number? ] } - { "fn?" [ first { [ callable? ] [ { [ malfn? ] [ macro?>> not ] } 1&& ] } 1|| ] } - { "macro?" [ first { [ malfn? ] [ macro?>> ] } 1&& ] } - { "vector" [ >vector ] } - { "vector?" [ first vector? ] } - { "hash-map" [ 2 group parse-hashtable ] } - { "map?" [ first hashtable? ] } - { "assoc" [ unclip swap 2 group parse-hashtable assoc-union ] } - { "dissoc" [ unclip swap >hash-set '[ drop _ in? not ] assoc-filter ] } - { "get" [ first2 swap dup nil? [ nip ] [ ?at [ drop nil ] unless ] if ] } - { "contains?" [ first2 swap dup nil? [ nip ] [ at* nip ] if ] } - { "keys" [ first keys ] } - { "vals" [ first values ] } - { "sequential?" [ first { [ vector? ] [ array? ] } 1|| ] } - { "readline" [ first readline ] } - { "meta" [ first dup malfn? [ meta>> ] [ drop f ] if [ nil ] unless* ] } - { "with-meta" [ first2 over malfn? [ [ clone ] dip >>meta ] [ drop ] if ] } - { "atom" [ first ] } - { "atom?" [ first malatom? ] } - { "deref" [ first val>> ] } - { "reset!" [ first2 >>val val>> ] } - { "swap!" [ { [ first ] [ second ] [ 2 tail ] [ first val>> ] } cleave - prefix swap mal-apply get call( args fn -- maltype ) >>val val>> ] } - { "conj" [ unclip swap over array? [ reverse prepend ] [ append ] if ] } - { "seq" [ first { - { [ dup nil? ] [ drop nil ] } - { [ dup empty? ] [ drop nil ] } - { [ dup array? ] [ ] } - { [ dup vector? ] [ >array ] } - { [ dup string? ] [ [ 1string ] { } map-as ] } - } cond ] } - { "time-ms" [ drop nano-count 1,000,000 /i ] } -} +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators +combinators.short-circuit fry grouping hash-sets hashtables io +io.encodings.utf8 io.files kernel lists lib.env lib.printer +lib.reader lib.types math namespaces quotations readline sequences sets +strings system vectors ; +IN: lib.core + +SYMBOL: mal-apply + +: pr-str-stack ( exprs readably? glue -- str ) + [ '[ _ (pr-str) ] map ] dip join ; + +CONSTANT: empty-env T{ malenv f f H{ } } + +CONSTANT: ns H{ + { "+" [ first2 + ] } + { "-" [ first2 - ] } + { "*" [ first2 * ] } + { "/" [ first2 / ] } + { "list" [ >array ] } + { "list?" [ first array? ] } + { "empty?" [ first empty? ] } + { "count" [ first dup nil? [ drop 0 ] [ length ] if ] } + { "=" [ first2 mal= ] } + { "<" [ first2 < ] } + { ">" [ first2 > ] } + { ">=" [ first2 >= ] } + { "<=" [ first2 <= ] } + { "pr-str" [ t " " pr-str-stack ] } + { "str" [ f "" pr-str-stack ] } + { "prn" [ t " " pr-str-stack print flush nil ] } + { "println" [ f " " pr-str-stack print flush nil ] } + { "read-string" [ first read-str ] } + { "slurp" [ first utf8 file-contents ] } + { "cons" [ first2 swap prefix { } like ] } + { "concat" [ concat { } like ] } + { "vec" [ first >vector ] } + { "nth" [ first2 swap nth ] } + { "first" [ first dup nil? [ drop nil ] [ [ nil ] [ first ] if-empty ] if ] } + { "rest" [ first dup nil? [ drop { } ] [ [ { } ] [ rest { } like ] if-empty ] if ] } + { "throw" [ first throw ] } + { "apply" [ unclip [ unclip-last append ] dip mal-apply get call( args fn -- maltype ) ] } + { "map" [ first2 swap '[ 1array _ mal-apply get call( args fn -- maltype ) ] map { } like ] } + { "nil?" [ first nil? ] } + { "true?" [ first t = ] } + { "false?" [ first f = ] } + { "symbol" [ first ] } + { "symbol?" [ first malsymbol? ] } + { "string?" [ first string? ] } + { "keyword" [ first dup string? [ ] when ] } + { "keyword?" [ first malkeyword? ] } + { "number?" [ first number? ] } + { "fn?" [ first { [ callable? ] [ { [ malfn? ] [ macro?>> not ] } 1&& ] } 1|| ] } + { "macro?" [ first { [ malfn? ] [ macro?>> ] } 1&& ] } + { "vector" [ >vector ] } + { "vector?" [ first vector? ] } + { "hash-map" [ 2 group parse-hashtable ] } + { "map?" [ first hashtable? ] } + { "assoc" [ unclip swap 2 group parse-hashtable assoc-union ] } + { "dissoc" [ unclip swap >hash-set '[ drop _ in? not ] assoc-filter ] } + { "get" [ first2 swap dup nil? [ nip ] [ ?at [ drop nil ] unless ] if ] } + { "contains?" [ first2 swap dup nil? [ nip ] [ at* nip ] if ] } + { "keys" [ first keys ] } + { "vals" [ first values ] } + { "sequential?" [ first { [ vector? ] [ array? ] } 1|| ] } + { "readline" [ first readline ] } + { "meta" [ first dup malfn? [ meta>> ] [ drop f ] if [ nil ] unless* ] } + { "with-meta" [ first2 over malfn? [ [ clone ] dip >>meta ] [ drop ] if ] } + { "atom" [ first ] } + { "atom?" [ first malatom? ] } + { "deref" [ first val>> ] } + { "reset!" [ first2 >>val val>> ] } + { "swap!" [ { [ first ] [ second ] [ 2 tail ] [ first val>> ] } cleave + prefix swap mal-apply get call( args fn -- maltype ) >>val val>> ] } + { "conj" [ unclip swap over array? [ reverse prepend ] [ append ] if ] } + { "seq" [ first { + { [ dup nil? ] [ drop nil ] } + { [ dup empty? ] [ drop nil ] } + { [ dup array? ] [ ] } + { [ dup vector? ] [ >array ] } + { [ dup string? ] [ [ 1string ] { } map-as ] } + } cond ] } + { "time-ms" [ drop nano-count 1,000,000 /i ] } +} diff --git a/impls/factor/lib/env/env-tests.factor b/impls/factor/lib/env/env-tests.factor index 937c98ae82..6b65002478 100644 --- a/impls/factor/lib/env/env-tests.factor +++ b/impls/factor/lib/env/env-tests.factor @@ -1,32 +1,32 @@ -USING: assocs kernel lib.types tools.test ; -IN: lib.env - -{ "1" } [ - T{ malsymbol { name "foo" } } - T{ malenv - { outer T{ malenv f f H{ { "foo" "2" } } } } - { data H{ { "foo" "1" } } } - } env-get -] unit-test - -{ "2" } [ - T{ malsymbol { name "foo" } } - T{ malenv - { outer T{ malenv f f H{ { "foo" "2" } } } } - { data H{ { "bar" "1" } } } - } env-get -] unit-test - -{ "3" } [ - T{ malsymbol { name "foo" } } - T{ malenv { outer f } { data H{ } } } - [ [ "3" ] 2dip env-set ] [ env-get ] 2bi -] unit-test - -[ - T{ malsymbol { name "baz" } } - T{ malenv - { outer T{ malenv f f H{ { "foo" "2" } } } } - { data H{ { "bar" "1" } } } - } env-get -] must-fail +USING: assocs kernel lib.types tools.test ; +IN: lib.env + +{ "1" } [ + T{ malsymbol { name "foo" } } + T{ malenv + { outer T{ malenv f f H{ { "foo" "2" } } } } + { data H{ { "foo" "1" } } } + } env-get +] unit-test + +{ "2" } [ + T{ malsymbol { name "foo" } } + T{ malenv + { outer T{ malenv f f H{ { "foo" "2" } } } } + { data H{ { "bar" "1" } } } + } env-get +] unit-test + +{ "3" } [ + T{ malsymbol { name "foo" } } + T{ malenv { outer f } { data H{ } } } + [ [ "3" ] 2dip env-set ] [ env-get ] 2bi +] unit-test + +[ + T{ malsymbol { name "baz" } } + T{ malenv + { outer T{ malenv f f H{ { "foo" "2" } } } } + { data H{ { "bar" "1" } } } + } env-get +] must-fail diff --git a/impls/factor/lib/env/env.factor b/impls/factor/lib/env/env.factor index b1ca0e96c7..08dda3c935 100644 --- a/impls/factor/lib/env/env.factor +++ b/impls/factor/lib/env/env.factor @@ -1,32 +1,32 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs formatting hashtables kernel math -sequences typed ; -IN: lib.env - -TUPLE: malenv -{ outer read-only } -{ data hashtable read-only } ; - -! set outer to f if top level env - -C: malenv - -: new-env ( outer -- malenv ) H{ } clone malenv boa ; - -TYPED: env-find ( key malenv: malenv -- value/f ? ) - 2dup [ name>> ] [ data>> ] bi* at* [ - [ 2drop ] 2dip - ] [ - drop outer>> [ env-find ] [ drop f f ] if* - ] if* ; - -TYPED: env-set ( value key malenv: malenv -- ) - [ name>> ] [ data>> ] bi* set-at ; - -: env-get ( key assoc -- value ) - dupd env-find [ - nip - ] [ - drop name>> "'%s' not found" sprintf throw - ] if ; +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs formatting hashtables kernel math +sequences typed ; +IN: lib.env + +TUPLE: malenv +{ outer read-only } +{ data hashtable read-only } ; + +! set outer to f if top level env + +C: malenv + +: new-env ( outer -- malenv ) H{ } clone malenv boa ; + +TYPED: env-find ( key malenv: malenv -- value/f ? ) + 2dup [ name>> ] [ data>> ] bi* at* [ + [ 2drop ] 2dip + ] [ + drop outer>> [ env-find ] [ drop f f ] if* + ] if* ; + +TYPED: env-set ( value key malenv: malenv -- ) + [ name>> ] [ data>> ] bi* set-at ; + +: env-get ( key assoc -- value ) + dupd env-find [ + nip + ] [ + drop name>> "'%s' not found" sprintf throw + ] if ; diff --git a/impls/factor/lib/printer/printer-tests.factor b/impls/factor/lib/printer/printer-tests.factor index 3ab2ce1ce8..3371c3152a 100644 --- a/impls/factor/lib/printer/printer-tests.factor +++ b/impls/factor/lib/printer/printer-tests.factor @@ -1,15 +1,15 @@ -USING: lists lib.types tools.test ; -IN: lib.printer - -{ "(atom \"foo\")" } [ T{ malatom { val "foo" } } pr-str ] unit-test -{ "#" } [ T{ malfn } pr-str ] unit-test -{ ":foo" } [ T{ malkeyword { name "foo" } } pr-str ] unit-test -{ "foo" } [ T{ malsymbol { name "foo" } } pr-str ] unit-test -{ "14" } [ 14 pr-str ] unit-test -{ "\"\\\\foo\\\"\"" } [ "\\foo\"" pr-str ] unit-test -{ "(1 2 3 4)" } [ { 1 2 3 4 } pr-str ] unit-test -{ "[1 2 3 4]" } [ V{ 1 2 3 4 } pr-str ] unit-test -{ "{1 2}" } [ H{ { 1 2 } } pr-str ] unit-test -{ "true" } [ t pr-str ] unit-test -{ "false" } [ f pr-str ] unit-test -{ "nil" } [ +nil+ pr-str ] unit-test +USING: lists lib.types tools.test ; +IN: lib.printer + +{ "(atom \"foo\")" } [ T{ malatom { val "foo" } } pr-str ] unit-test +{ "#" } [ T{ malfn } pr-str ] unit-test +{ ":foo" } [ T{ malkeyword { name "foo" } } pr-str ] unit-test +{ "foo" } [ T{ malsymbol { name "foo" } } pr-str ] unit-test +{ "14" } [ 14 pr-str ] unit-test +{ "\"\\\\foo\\\"\"" } [ "\\foo\"" pr-str ] unit-test +{ "(1 2 3 4)" } [ { 1 2 3 4 } pr-str ] unit-test +{ "[1 2 3 4]" } [ V{ 1 2 3 4 } pr-str ] unit-test +{ "{1 2}" } [ H{ { 1 2 } } pr-str ] unit-test +{ "true" } [ t pr-str ] unit-test +{ "false" } [ f pr-str ] unit-test +{ "nil" } [ +nil+ pr-str ] unit-test diff --git a/impls/factor/lib/printer/printer.factor b/impls/factor/lib/printer/printer.factor index 8ff4266afe..5c2f6fa8bf 100644 --- a/impls/factor/lib/printer/printer.factor +++ b/impls/factor/lib/printer/printer.factor @@ -1,32 +1,32 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs fry hashtables kernel lists -lib.types math math.parser sequences splitting strings summary -vectors ; -IN: lib.printer - -GENERIC# (pr-str) 1 ( maltype readably? -- str ) -M: object (pr-str) drop summary ; -M: malatom (pr-str) [ val>> ] dip (pr-str) "(atom " ")" surround ; -M: malfn (pr-str) 2drop "#" ; -M: malkeyword (pr-str) drop name>> ":" prepend ; -M: malsymbol (pr-str) drop name>> ; -M: number (pr-str) drop number>string ; -M: string (pr-str) - [ - "\\" "\\\\" replace - "\"" "\\\"" replace - "\n" "\\n" replace - "\"" dup surround - ] when ; -M: array (pr-str) '[ _ (pr-str) ] map " " join "(" ")" surround ; -M: vector (pr-str) '[ _ (pr-str) ] map " " join "[" "]" surround ; -M: hashtable (pr-str) - [ unzip ] dip '[ [ _ (pr-str) ] bi@ " " glue ] 2map - " " join "{" "}" surround ; -M: t (pr-str) 2drop "true" ; -M: f (pr-str) 2drop "false" ; -M: +nil+ (pr-str) 2drop "nil" ; - -: pr-str ( maltype -- str ) - t (pr-str) ; +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs fry hashtables kernel lists +lib.types math math.parser sequences splitting strings summary +vectors ; +IN: lib.printer + +GENERIC# (pr-str) 1 ( maltype readably? -- str ) +M: object (pr-str) drop summary ; +M: malatom (pr-str) [ val>> ] dip (pr-str) "(atom " ")" surround ; +M: malfn (pr-str) 2drop "#" ; +M: malkeyword (pr-str) drop name>> ":" prepend ; +M: malsymbol (pr-str) drop name>> ; +M: number (pr-str) drop number>string ; +M: string (pr-str) + [ + "\\" "\\\\" replace + "\"" "\\\"" replace + "\n" "\\n" replace + "\"" dup surround + ] when ; +M: array (pr-str) '[ _ (pr-str) ] map " " join "(" ")" surround ; +M: vector (pr-str) '[ _ (pr-str) ] map " " join "[" "]" surround ; +M: hashtable (pr-str) + [ unzip ] dip '[ [ _ (pr-str) ] bi@ " " glue ] 2map + " " join "{" "}" surround ; +M: t (pr-str) 2drop "true" ; +M: f (pr-str) 2drop "false" ; +M: +nil+ (pr-str) 2drop "nil" ; + +: pr-str ( maltype -- str ) + t (pr-str) ; diff --git a/impls/factor/lib/reader/reader-tests.factor b/impls/factor/lib/reader/reader-tests.factor index 993a4c7789..bbcb7826c7 100644 --- a/impls/factor/lib/reader/reader-tests.factor +++ b/impls/factor/lib/reader/reader-tests.factor @@ -1,12 +1,12 @@ -USING: lists lib.types tools.test ; -IN: lib.reader - -{ "foo" } [ "\"foo\"" read-atom ] unit-test -{ T{ malkeyword { name "foo" } } } [ ":foo" read-atom ] unit-test -{ f } [ "false" read-atom ] unit-test -{ t } [ "true" read-atom ] unit-test -{ +nil+ } [ "nil" read-atom ] unit-test -{ T{ malsymbol { name "foo" } } } [ "foo" read-atom ] unit-test -{ 14 } [ "14" read-atom ] unit-test -{ 1.5 } [ "1.5" read-atom ] unit-test -{ 2/3 } [ "2/3" read-atom ] unit-test +USING: lists lib.types tools.test ; +IN: lib.reader + +{ "foo" } [ "\"foo\"" read-atom ] unit-test +{ T{ malkeyword { name "foo" } } } [ ":foo" read-atom ] unit-test +{ f } [ "false" read-atom ] unit-test +{ t } [ "true" read-atom ] unit-test +{ +nil+ } [ "nil" read-atom ] unit-test +{ T{ malsymbol { name "foo" } } } [ "foo" read-atom ] unit-test +{ 14 } [ "14" read-atom ] unit-test +{ 1.5 } [ "1.5" read-atom ] unit-test +{ 2/3 } [ "2/3" read-atom ] unit-test diff --git a/impls/factor/lib/reader/reader.factor b/impls/factor/lib/reader/reader.factor index ae228bd86f..f31733d58b 100644 --- a/impls/factor/lib/reader/reader.factor +++ b/impls/factor/lib/reader/reader.factor @@ -1,80 +1,80 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators grouping hashtables kernel lists locals -make lib.types math.parser regexp sequences splitting strings ; -IN: lib.reader - -CONSTANT: token-regex R/ (~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)~^@]+)/ - -DEFER: read-form - -: (read-string) ( str -- maltype ) -! dup last CHAR: " = [ - dup R/ ^"(?:\\.|[^\\"])*"$/ matches? [ - rest but-last R/ \\./ [ - { - { [ dup >string "\\\\" = ] [ drop "\\" ] } - { [ dup >string "\\n" = ] [ drop "\n" ] } - { [ dup >string "\\\"" = ] [ drop "\"" ] } - [ ] - } cond - ] re-replace-with - ] [ - "expected '\"', got EOF" throw - ] if ; - -: (read-atom) ( str -- maltype ) - { - { [ dup first CHAR: " = ] [ (read-string) ] } - { [ dup first CHAR: : = ] [ rest ] } - { [ dup "false" = ] [ drop f ] } - { [ dup "true" = ] [ drop t ] } - { [ dup "nil" = ] [ drop nil ] } - [ ] - } cond ; - -: read-atom ( str -- maltype ) - dup string>number [ nip ] [ (read-atom) ] if* ; - -:: read-sequence ( seq closer exemplar -- seq maltype ) - seq [ - [ - [ "expected '" closer "', got EOF" append append throw ] - [ dup first closer = ] if-empty - ] [ - read-form , - ] until rest - ] exemplar make ; - -: read-list ( seq -- seq maltype ) - ")" { } read-sequence ; - -: read-vector ( seq -- seq maltype ) - "]" V{ } read-sequence ; - -: read-hashmap ( seq -- seq maltype ) - "}" V{ } read-sequence 2 group parse-hashtable ; - -: consume-next-into-list ( seq symname -- seq maltype ) - [ read-form ] dip swap 2array ; - -: read-form ( seq -- seq maltype ) - unclip { - { "(" [ read-list ] } - { "[" [ read-vector ] } - { "{" [ read-hashmap ] } - { "'" [ "quote" consume-next-into-list ] } - { "`" [ "quasiquote" consume-next-into-list ] } - { "~" [ "unquote" consume-next-into-list ] } - { "~@" [ "splice-unquote" consume-next-into-list ] } - { "^" [ read-form [ read-form ] dip 2array "with-meta" prefix ] } - { "@" [ "deref" consume-next-into-list ] } - [ read-atom ] - } case ; - -: tokenize ( str -- seq ) - token-regex all-matching-subseqs - [ first CHAR: ; = not ] filter ; - -: read-str ( str -- maltype ) - tokenize [ " " throw ] [ read-form nip ] if-empty ; +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators grouping hashtables kernel lists locals +make lib.types math.parser regexp sequences splitting strings ; +IN: lib.reader + +CONSTANT: token-regex R/ (~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)~^@]+)/ + +DEFER: read-form + +: (read-string) ( str -- maltype ) +! dup last CHAR: " = [ + dup R/ ^"(?:\\.|[^\\"])*"$/ matches? [ + rest but-last R/ \\./ [ + { + { [ dup >string "\\\\" = ] [ drop "\\" ] } + { [ dup >string "\\n" = ] [ drop "\n" ] } + { [ dup >string "\\\"" = ] [ drop "\"" ] } + [ ] + } cond + ] re-replace-with + ] [ + "expected '\"', got EOF" throw + ] if ; + +: (read-atom) ( str -- maltype ) + { + { [ dup first CHAR: " = ] [ (read-string) ] } + { [ dup first CHAR: : = ] [ rest ] } + { [ dup "false" = ] [ drop f ] } + { [ dup "true" = ] [ drop t ] } + { [ dup "nil" = ] [ drop nil ] } + [ ] + } cond ; + +: read-atom ( str -- maltype ) + dup string>number [ nip ] [ (read-atom) ] if* ; + +:: read-sequence ( seq closer exemplar -- seq maltype ) + seq [ + [ + [ "expected '" closer "', got EOF" append append throw ] + [ dup first closer = ] if-empty + ] [ + read-form , + ] until rest + ] exemplar make ; + +: read-list ( seq -- seq maltype ) + ")" { } read-sequence ; + +: read-vector ( seq -- seq maltype ) + "]" V{ } read-sequence ; + +: read-hashmap ( seq -- seq maltype ) + "}" V{ } read-sequence 2 group parse-hashtable ; + +: consume-next-into-list ( seq symname -- seq maltype ) + [ read-form ] dip swap 2array ; + +: read-form ( seq -- seq maltype ) + unclip { + { "(" [ read-list ] } + { "[" [ read-vector ] } + { "{" [ read-hashmap ] } + { "'" [ "quote" consume-next-into-list ] } + { "`" [ "quasiquote" consume-next-into-list ] } + { "~" [ "unquote" consume-next-into-list ] } + { "~@" [ "splice-unquote" consume-next-into-list ] } + { "^" [ read-form [ read-form ] dip 2array "with-meta" prefix ] } + { "@" [ "deref" consume-next-into-list ] } + [ read-atom ] + } case ; + +: tokenize ( str -- seq ) + token-regex all-matching-subseqs + [ first CHAR: ; = not ] filter ; + +: read-str ( str -- maltype ) + tokenize [ " " throw ] [ read-form nip ] if-empty ; diff --git a/impls/factor/lib/types/types.factor b/impls/factor/lib/types/types.factor index da00d8ba9e..ed3623025d 100644 --- a/impls/factor/lib/types/types.factor +++ b/impls/factor/lib/types/types.factor @@ -1,51 +1,51 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators.short-circuit hashtables -kernel locals lib.env sequences strings ; -IN: lib.types - -TUPLE: malsymbol { name string read-only } ; - -C: malsymbol - -: symeq? ( string other -- ? ) - dup malsymbol? [ name>> = ] [ 2drop f ] if ; - -TUPLE: malfn - { env malenv read-only } - { binds sequence read-only } - { exprs read-only } - { macro? boolean read-only } - { meta assoc } ; - -: malmacro ( fn -- fn ) - [ env>> ] [ binds>> ] [ exprs>> ] tri t f malfn boa ; - -: ( env binds exprs -- fn ) - f f malfn boa ; - -TUPLE: malatom { val } ; - -C: malatom - -TUPLE: malkeyword { name string read-only } ; - -C: malkeyword - -DEFER: mal= - -: mal-sequence= ( seq1 seq2 -- ? ) - 2dup [ length ] bi@ = - [ [ mal= ] 2all? ] [ 2drop f ] if ; - -:: mal-hashtable= ( h1 h2 -- ? ) - h1 assoc-size h2 assoc-size = [ - h1 [| k1 v1 | k1 h2 at* drop v1 mal= ] assoc-all? - ] [ f ] if ; - -: mal= ( obj1 obj2 -- ? ) - 2dup [ hashtable? ] bi@ and - [ mal-hashtable= ] [ - 2dup [ { [ ] [ sequence? ] [ string? not ] } 1&& ] bi@ and - [ mal-sequence= ] [ = ] if - ] if ; +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators.short-circuit hashtables +kernel locals lib.env sequences strings ; +IN: lib.types + +TUPLE: malsymbol { name string read-only } ; + +C: malsymbol + +: symeq? ( string other -- ? ) + dup malsymbol? [ name>> = ] [ 2drop f ] if ; + +TUPLE: malfn + { env malenv read-only } + { binds sequence read-only } + { exprs read-only } + { macro? boolean read-only } + { meta assoc } ; + +: malmacro ( fn -- fn ) + [ env>> ] [ binds>> ] [ exprs>> ] tri t f malfn boa ; + +: ( env binds exprs -- fn ) + f f malfn boa ; + +TUPLE: malatom { val } ; + +C: malatom + +TUPLE: malkeyword { name string read-only } ; + +C: malkeyword + +DEFER: mal= + +: mal-sequence= ( seq1 seq2 -- ? ) + 2dup [ length ] bi@ = + [ [ mal= ] 2all? ] [ 2drop f ] if ; + +:: mal-hashtable= ( h1 h2 -- ? ) + h1 assoc-size h2 assoc-size = [ + h1 [| k1 v1 | k1 h2 at* drop v1 mal= ] assoc-all? + ] [ f ] if ; + +: mal= ( obj1 obj2 -- ? ) + 2dup [ hashtable? ] bi@ and + [ mal-hashtable= ] [ + 2dup [ { [ ] [ sequence? ] [ string? not ] } 1&& ] bi@ and + [ mal-sequence= ] [ = ] if + ] if ; diff --git a/impls/factor/run b/impls/factor/run index 4757514db8..278651da0a 100755 --- a/impls/factor/run +++ b/impls/factor/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec factor $(dirname $0)/${STEP:-stepA_mal}/${STEP:-stepA_mal}.factor "${@}" +#!/bin/bash +exec factor $(dirname $0)/${STEP:-stepA_mal}/${STEP:-stepA_mal}.factor "${@}" diff --git a/impls/factor/step0_repl/deploy.factor b/impls/factor/step0_repl/deploy.factor index f69d2e4a74..50dd844c55 100644 --- a/impls/factor/step0_repl/deploy.factor +++ b/impls/factor/step0_repl/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step0_repl" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step0_repl" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step0_repl/step0_repl.factor b/impls/factor/step0_repl/step0_repl.factor index 2eb4a1ddac..ea0041eeaf 100755 --- a/impls/factor/step0_repl/step0_repl.factor +++ b/impls/factor/step0_repl/step0_repl.factor @@ -1,21 +1,21 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: io kernel readline sequences ; -IN: step0_repl - -: READ ( x -- x ) ; - -: EVAL ( x -- x ) ; - -: PRINT ( x -- x ) ; - -: REP ( x -- x ) READ EVAL PRINT ; - -: REPL ( -- ) - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -MAIN: REPL +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: io kernel readline sequences ; +IN: step0_repl + +: READ ( x -- x ) ; + +: EVAL ( x -- x ) ; + +: PRINT ( x -- x ) ; + +: REP ( x -- x ) READ EVAL PRINT ; + +: REPL ( -- ) + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +MAIN: REPL diff --git a/impls/factor/step1_read_print/deploy.factor b/impls/factor/step1_read_print/deploy.factor index 37c763fa06..c478ccebf7 100644 --- a/impls/factor/step1_read_print/deploy.factor +++ b/impls/factor/step1_read_print/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step1_read_print" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step1_read_print" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step1_read_print/step1_read_print.factor b/impls/factor/step1_read_print/step1_read_print.factor index 3d23d9c31e..edaa567ac2 100755 --- a/impls/factor/step1_read_print/step1_read_print.factor +++ b/impls/factor/step1_read_print/step1_read_print.factor @@ -1,27 +1,27 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: continuations io kernel lib.printer lib.reader readline -sequences ; -IN: step1_read_print - -: READ ( str -- maltype ) read-str ; - -: EVAL ( maltype -- maltype ) ; - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -MAIN: REPL +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: continuations io kernel lib.printer lib.reader readline +sequences ; +IN: step1_read_print + +: READ ( str -- maltype ) read-str ; + +: EVAL ( maltype -- maltype ) ; + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +MAIN: REPL diff --git a/impls/factor/step2_eval/deploy.factor b/impls/factor/step2_eval/deploy.factor index 48cd2ad669..a5903dafb0 100644 --- a/impls/factor/step2_eval/deploy.factor +++ b/impls/factor/step2_eval/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step2_eval" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step2_eval" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step2_eval/step2_eval.factor b/impls/factor/step2_eval/step2_eval.factor index 8b73333126..47db7d96c2 100755 --- a/impls/factor/step2_eval/step2_eval.factor +++ b/impls/factor/step2_eval/step2_eval.factor @@ -1,49 +1,49 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators combinators.short-circuit -continuations fry io kernel math lib.printer lib.reader lib.types -quotations readline sequences ; -IN: step2_eval - -CONSTANT: repl-env H{ - { "+" [ + ] } - { "-" [ - ] } - { "*" [ * ] } - { "/" [ / ] } -} - -DEFER: EVAL - -GENERIC# eval-ast 1 ( ast env -- ast ) -M: malsymbol eval-ast - [ name>> ] dip ?at [ "no variable " prepend throw ] unless ; -M: sequence eval-ast '[ _ EVAL ] map ; -M: assoc eval-ast '[ _ EVAL ] assoc-map ; -M: object eval-ast drop ; - -: READ ( str -- maltype ) read-str ; - -: EVAL ( maltype env -- maltype ) - eval-ast dup { [ array? ] [ empty? not ] } 1&& [ - unclip - dup quotation? [ "not a fn" throw ] unless - with-datastack first - ] when ; - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ repl-env EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -MAIN: REPL +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators combinators.short-circuit +continuations fry io kernel math lib.printer lib.reader lib.types +quotations readline sequences ; +IN: step2_eval + +CONSTANT: repl-env H{ + { "+" [ + ] } + { "-" [ - ] } + { "*" [ * ] } + { "/" [ / ] } +} + +DEFER: EVAL + +GENERIC# eval-ast 1 ( ast env -- ast ) +M: malsymbol eval-ast + [ name>> ] dip ?at [ "no variable " prepend throw ] unless ; +M: sequence eval-ast '[ _ EVAL ] map ; +M: assoc eval-ast '[ _ EVAL ] assoc-map ; +M: object eval-ast drop ; + +: READ ( str -- maltype ) read-str ; + +: EVAL ( maltype env -- maltype ) + eval-ast dup { [ array? ] [ empty? not ] } 1&& [ + unclip + dup quotation? [ "not a fn" throw ] unless + with-datastack first + ] when ; + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ repl-env EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +MAIN: REPL diff --git a/impls/factor/step3_env/deploy.factor b/impls/factor/step3_env/deploy.factor index 557d7fd368..dda6f80900 100644 --- a/impls/factor/step3_env/deploy.factor +++ b/impls/factor/step3_env/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step3_env" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step3_env" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step3_env/step3_env.factor b/impls/factor/step3_env/step3_env.factor index 742c3f59f2..3d3b8c815c 100755 --- a/impls/factor/step3_env/step3_env.factor +++ b/impls/factor/step3_env/step3_env.factor @@ -1,69 +1,69 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators combinators.short-circuit -continuations fry grouping hashtables io kernel locals lib.env lib.printer -lib.reader lib.types math namespaces quotations readline sequences ; -IN: step3_env - -CONSTANT: repl-bindings H{ - { "+" [ + ] } - { "-" [ - ] } - { "*" [ * ] } - { "/" [ / ] } -} - -SYMBOL: repl-env - -DEFER: EVAL - -GENERIC# eval-ast 1 ( ast env -- ast ) -M: malsymbol eval-ast env-get ; -M: sequence eval-ast '[ _ EVAL ] map ; -M: assoc eval-ast '[ _ EVAL ] assoc-map ; -M: object eval-ast drop ; - -:: eval-def! ( key value env -- maltype ) - value env EVAL [ key env env-set ] keep ; - -: eval-let* ( bindings body env -- maltype ) - [ swap 2 group ] [ new-env ] bi* [ - dup '[ first2 _ EVAL swap _ env-set ] each - ] keep EVAL ; - -: READ ( str -- maltype ) read-str ; - -:: EVAL ( maltype env -- maltype ) - maltype dup { [ array? ] [ empty? not ] } 1&& [ - unclip dup dup malsymbol? [ name>> ] when { - { "def!" [ drop first2 env eval-def! ] } - { "let*" [ drop first2 env eval-let* ] } - [ - drop env eval-ast dup quotation? [ - [ env eval-ast ] dip with-datastack first - ] [ - drop "not a fn" throw - ] if - ] - } case - ] [ - env eval-ast - ] if ; - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ repl-env get EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - f repl-bindings repl-env set - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -MAIN: REPL +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators combinators.short-circuit +continuations fry grouping hashtables io kernel locals lib.env lib.printer +lib.reader lib.types math namespaces quotations readline sequences ; +IN: step3_env + +CONSTANT: repl-bindings H{ + { "+" [ + ] } + { "-" [ - ] } + { "*" [ * ] } + { "/" [ / ] } +} + +SYMBOL: repl-env + +DEFER: EVAL + +GENERIC# eval-ast 1 ( ast env -- ast ) +M: malsymbol eval-ast env-get ; +M: sequence eval-ast '[ _ EVAL ] map ; +M: assoc eval-ast '[ _ EVAL ] assoc-map ; +M: object eval-ast drop ; + +:: eval-def! ( key value env -- maltype ) + value env EVAL [ key env env-set ] keep ; + +: eval-let* ( bindings body env -- maltype ) + [ swap 2 group ] [ new-env ] bi* [ + dup '[ first2 _ EVAL swap _ env-set ] each + ] keep EVAL ; + +: READ ( str -- maltype ) read-str ; + +:: EVAL ( maltype env -- maltype ) + maltype dup { [ array? ] [ empty? not ] } 1&& [ + unclip dup dup malsymbol? [ name>> ] when { + { "def!" [ drop first2 env eval-def! ] } + { "let*" [ drop first2 env eval-let* ] } + [ + drop env eval-ast dup quotation? [ + [ env eval-ast ] dip with-datastack first + ] [ + drop "not a fn" throw + ] if + ] + } case + ] [ + env eval-ast + ] if ; + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + f repl-bindings repl-env set + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +MAIN: REPL diff --git a/impls/factor/step4_if_fn_do/deploy.factor b/impls/factor/step4_if_fn_do/deploy.factor index f687916c39..3320ac63c2 100644 --- a/impls/factor/step4_if_fn_do/deploy.factor +++ b/impls/factor/step4_if_fn_do/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step4_if_fn_do" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step4_if_fn_do" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step4_if_fn_do/step4_if_fn_do.factor b/impls/factor/step4_if_fn_do/step4_if_fn_do.factor index 37076e98f2..aeeb605905 100755 --- a/impls/factor/step4_if_fn_do/step4_if_fn_do.factor +++ b/impls/factor/step4_if_fn_do/step4_if_fn_do.factor @@ -1,88 +1,88 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators combinators.short-circuit -continuations fry grouping hashtables io kernel lists locals lib.core lib.env -lib.printer lib.reader lib.types math namespaces quotations readline sequences -splitting ; -IN: step4_if_fn_do - -SYMBOL: repl-env - -DEFER: EVAL - -GENERIC# eval-ast 1 ( ast env -- ast ) -M: malsymbol eval-ast env-get ; -M: sequence eval-ast '[ _ EVAL ] map ; -M: assoc eval-ast '[ _ EVAL ] assoc-map ; -M: object eval-ast drop ; - -:: eval-def! ( key value env -- maltype ) - value env EVAL [ key env env-set ] keep ; - -: eval-let* ( bindings body env -- maltype ) - [ swap 2 group ] [ new-env ] bi* [ - dup '[ first2 _ EVAL swap _ env-set ] each - ] keep EVAL ; - -:: eval-if ( params env -- maltype ) - params first env EVAL { f +nil+ } index not [ - params second env EVAL - ] [ - params length 2 > [ params third env EVAL ] [ nil ] if - ] if ; - -:: eval-fn* ( params env -- maltype ) - env params first [ name>> ] map params second ; - -: args-split ( bindlist -- bindlist restbinding/f ) - { "&" } split1 ?first ; - -: make-bindings ( args bindlist restbinding/f -- bindingshash ) - swapd [ over length cut [ zip ] dip ] dip - [ swap 2array suffix ] [ drop ] if* >hashtable ; - -GENERIC: apply ( args fn -- maltype ) - -M: malfn apply - [ exprs>> nip ] - [ env>> nip ] - [ binds>> args-split make-bindings ] 2tri EVAL ; - -M: callable apply call( x -- y ) ; - -: READ ( str -- maltype ) read-str ; - -:: EVAL ( maltype env -- maltype ) - maltype dup { [ array? ] [ empty? not ] } 1&& [ - dup first dup malsymbol? [ name>> ] when { - { "def!" [ rest first2 env eval-def! ] } - { "let*" [ rest first2 env eval-let* ] } - { "do" [ rest env eval-ast last ] } - { "if" [ rest env eval-if ] } - { "fn*" [ rest env eval-fn* ] } - [ drop [ env EVAL ] map unclip apply ] - } case - ] [ - env eval-ast - ] if ; - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ repl-env get EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -f ns repl-env set-global -"(def! not (fn* (a) (if a false true)))" REP drop - -MAIN: REPL +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators combinators.short-circuit +continuations fry grouping hashtables io kernel lists locals lib.core lib.env +lib.printer lib.reader lib.types math namespaces quotations readline sequences +splitting ; +IN: step4_if_fn_do + +SYMBOL: repl-env + +DEFER: EVAL + +GENERIC# eval-ast 1 ( ast env -- ast ) +M: malsymbol eval-ast env-get ; +M: sequence eval-ast '[ _ EVAL ] map ; +M: assoc eval-ast '[ _ EVAL ] assoc-map ; +M: object eval-ast drop ; + +:: eval-def! ( key value env -- maltype ) + value env EVAL [ key env env-set ] keep ; + +: eval-let* ( bindings body env -- maltype ) + [ swap 2 group ] [ new-env ] bi* [ + dup '[ first2 _ EVAL swap _ env-set ] each + ] keep EVAL ; + +:: eval-if ( params env -- maltype ) + params first env EVAL { f +nil+ } index not [ + params second env EVAL + ] [ + params length 2 > [ params third env EVAL ] [ nil ] if + ] if ; + +:: eval-fn* ( params env -- maltype ) + env params first [ name>> ] map params second ; + +: args-split ( bindlist -- bindlist restbinding/f ) + { "&" } split1 ?first ; + +: make-bindings ( args bindlist restbinding/f -- bindingshash ) + swapd [ over length cut [ zip ] dip ] dip + [ swap 2array suffix ] [ drop ] if* >hashtable ; + +GENERIC: apply ( args fn -- maltype ) + +M: malfn apply + [ exprs>> nip ] + [ env>> nip ] + [ binds>> args-split make-bindings ] 2tri EVAL ; + +M: callable apply call( x -- y ) ; + +: READ ( str -- maltype ) read-str ; + +:: EVAL ( maltype env -- maltype ) + maltype dup { [ array? ] [ empty? not ] } 1&& [ + dup first dup malsymbol? [ name>> ] when { + { "def!" [ rest first2 env eval-def! ] } + { "let*" [ rest first2 env eval-let* ] } + { "do" [ rest env eval-ast last ] } + { "if" [ rest env eval-if ] } + { "fn*" [ rest env eval-fn* ] } + [ drop [ env EVAL ] map unclip apply ] + } case + ] [ + env eval-ast + ] if ; + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +f ns repl-env set-global +"(def! not (fn* (a) (if a false true)))" REP drop + +MAIN: REPL diff --git a/impls/factor/step5_tco/deploy.factor b/impls/factor/step5_tco/deploy.factor index 350969d6f9..8a5c13aada 100644 --- a/impls/factor/step5_tco/deploy.factor +++ b/impls/factor/step5_tco/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step5_tco" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step5_tco" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step5_tco/step5_tco.factor b/impls/factor/step5_tco/step5_tco.factor index aff1b9cf37..d6e4f5c105 100755 --- a/impls/factor/step5_tco/step5_tco.factor +++ b/impls/factor/step5_tco/step5_tco.factor @@ -1,96 +1,96 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators combinators.short-circuit -continuations fry grouping hashtables io kernel lists locals lib.core lib.env -lib.printer lib.reader lib.types math namespaces quotations readline sequences -splitting ; -IN: step5_tco - -SYMBOL: repl-env - -DEFER: EVAL - -GENERIC# eval-ast 1 ( ast env -- ast ) -M: malsymbol eval-ast env-get ; -M: sequence eval-ast '[ _ EVAL ] map ; -M: assoc eval-ast '[ _ EVAL ] assoc-map ; -M: object eval-ast drop ; - -:: eval-def! ( key value env -- maltype ) - value env EVAL [ key env env-set ] keep ; - -: eval-let* ( bindings body env -- maltype env ) - [ swap 2 group ] [ new-env ] bi* [ - dup '[ first2 _ EVAL swap _ env-set ] each - ] keep ; - -:: eval-do ( exprs env -- lastform env/f ) - exprs [ - { } f - ] [ - unclip-last [ env eval-ast drop ] dip env - ] if-empty ; - -:: eval-if ( params env -- maltype env/f ) - params first env EVAL { f +nil+ } index not [ - params second env - ] [ - params length 2 > [ params third env ] [ nil f ] if - ] if ; - -:: eval-fn* ( params env -- maltype ) - env params first [ name>> ] map params second ; - -: args-split ( bindlist -- bindlist restbinding/f ) - { "&" } split1 ?first ; - -: make-bindings ( args bindlist restbinding/f -- bindingshash ) - swapd [ over length cut [ zip ] dip ] dip - [ swap 2array suffix ] [ drop ] if* >hashtable ; - -GENERIC: apply ( args fn -- maltype newenv/f ) - -M: malfn apply - [ exprs>> nip ] - [ env>> nip ] - [ binds>> args-split make-bindings ] 2tri ; - -M: callable apply call( x -- y ) f ; - -: READ ( str -- maltype ) read-str ; - -: EVAL ( maltype env -- maltype ) - over { [ array? ] [ empty? not ] } 1&& [ - over first dup malsymbol? [ name>> ] when { - { "def!" [ [ rest first2 ] dip eval-def! f ] } - { "let*" [ [ rest first2 ] dip eval-let* ] } - { "do" [ [ rest ] dip eval-do ] } - { "if" [ [ rest ] dip eval-if ] } - { "fn*" [ [ rest ] dip eval-fn* f ] } - [ drop '[ _ EVAL ] map unclip apply ] - } case - ] [ - eval-ast f - ] if [ EVAL ] when* ; - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ repl-env get EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -f ns repl-env set-global - -"(def! not (fn* (a) (if a false true)))" REP drop - -MAIN: REPL +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators combinators.short-circuit +continuations fry grouping hashtables io kernel lists locals lib.core lib.env +lib.printer lib.reader lib.types math namespaces quotations readline sequences +splitting ; +IN: step5_tco + +SYMBOL: repl-env + +DEFER: EVAL + +GENERIC# eval-ast 1 ( ast env -- ast ) +M: malsymbol eval-ast env-get ; +M: sequence eval-ast '[ _ EVAL ] map ; +M: assoc eval-ast '[ _ EVAL ] assoc-map ; +M: object eval-ast drop ; + +:: eval-def! ( key value env -- maltype ) + value env EVAL [ key env env-set ] keep ; + +: eval-let* ( bindings body env -- maltype env ) + [ swap 2 group ] [ new-env ] bi* [ + dup '[ first2 _ EVAL swap _ env-set ] each + ] keep ; + +:: eval-do ( exprs env -- lastform env/f ) + exprs [ + { } f + ] [ + unclip-last [ env eval-ast drop ] dip env + ] if-empty ; + +:: eval-if ( params env -- maltype env/f ) + params first env EVAL { f +nil+ } index not [ + params second env + ] [ + params length 2 > [ params third env ] [ nil f ] if + ] if ; + +:: eval-fn* ( params env -- maltype ) + env params first [ name>> ] map params second ; + +: args-split ( bindlist -- bindlist restbinding/f ) + { "&" } split1 ?first ; + +: make-bindings ( args bindlist restbinding/f -- bindingshash ) + swapd [ over length cut [ zip ] dip ] dip + [ swap 2array suffix ] [ drop ] if* >hashtable ; + +GENERIC: apply ( args fn -- maltype newenv/f ) + +M: malfn apply + [ exprs>> nip ] + [ env>> nip ] + [ binds>> args-split make-bindings ] 2tri ; + +M: callable apply call( x -- y ) f ; + +: READ ( str -- maltype ) read-str ; + +: EVAL ( maltype env -- maltype ) + over { [ array? ] [ empty? not ] } 1&& [ + over first dup malsymbol? [ name>> ] when { + { "def!" [ [ rest first2 ] dip eval-def! f ] } + { "let*" [ [ rest first2 ] dip eval-let* ] } + { "do" [ [ rest ] dip eval-do ] } + { "if" [ [ rest ] dip eval-if ] } + { "fn*" [ [ rest ] dip eval-fn* f ] } + [ drop '[ _ EVAL ] map unclip apply ] + } case + ] [ + eval-ast f + ] if [ EVAL ] when* ; + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +f ns repl-env set-global + +"(def! not (fn* (a) (if a false true)))" REP drop + +MAIN: REPL diff --git a/impls/factor/step6_file/deploy.factor b/impls/factor/step6_file/deploy.factor index db7f1e5138..95e28b6285 100644 --- a/impls/factor/step6_file/deploy.factor +++ b/impls/factor/step6_file/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step6_file" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step6_file" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step6_file/step6_file.factor b/impls/factor/step6_file/step6_file.factor index 290ee83333..709daa8b92 100755 --- a/impls/factor/step6_file/step6_file.factor +++ b/impls/factor/step6_file/step6_file.factor @@ -1,110 +1,110 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators combinators.short-circuit -command-line continuations fry grouping hashtables io kernel lists locals -lib.core lib.env lib.printer lib.reader lib.types math namespaces quotations -readline sequences splitting ; -IN: step6_file - -SYMBOL: repl-env - -DEFER: EVAL - -GENERIC# eval-ast 1 ( ast env -- ast ) -M: malsymbol eval-ast env-get ; -M: sequence eval-ast '[ _ EVAL ] map ; -M: assoc eval-ast '[ _ EVAL ] assoc-map ; -M: object eval-ast drop ; - -:: eval-def! ( key value env -- maltype ) - value env EVAL [ key env env-set ] keep ; - -: eval-let* ( bindings body env -- maltype env ) - [ swap 2 group ] [ new-env ] bi* [ - dup '[ first2 _ EVAL swap _ env-set ] each - ] keep ; - -:: eval-do ( exprs env -- lastform env/f ) - exprs [ - { } f - ] [ - unclip-last [ env eval-ast drop ] dip env - ] if-empty ; - -:: eval-if ( params env -- maltype env/f ) - params first env EVAL { f +nil+ } index not [ - params second env - ] [ - params length 2 > [ params third env ] [ nil f ] if - ] if ; - -:: eval-fn* ( params env -- maltype ) - env params first [ name>> ] map params second ; - -: args-split ( bindlist -- bindlist restbinding/f ) - { "&" } split1 ?first ; - -: make-bindings ( args bindlist restbinding/f -- bindingshash ) - swapd [ over length cut [ zip ] dip ] dip - [ swap 2array suffix ] [ drop ] if* >hashtable ; - -GENERIC: apply ( args fn -- maltype newenv/f ) - -M: malfn apply - [ exprs>> nip ] - [ env>> nip ] - [ binds>> args-split make-bindings ] 2tri ; - -M: callable apply call( x -- y ) f ; - -: READ ( str -- maltype ) read-str ; - -: EVAL ( maltype env -- maltype ) - over { [ array? ] [ empty? not ] } 1&& [ - over first dup malsymbol? [ name>> ] when { - { "def!" [ [ rest first2 ] dip eval-def! f ] } - { "let*" [ [ rest first2 ] dip eval-let* ] } - { "do" [ [ rest ] dip eval-do ] } - { "if" [ [ rest ] dip eval-if ] } - { "fn*" [ [ rest ] dip eval-fn* f ] } - [ drop '[ _ EVAL ] map unclip apply ] - } case [ EVAL ] when* - ] [ - eval-ast - ] if ; - -[ apply [ EVAL ] when* ] mal-apply set-global - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ repl-env get EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -: main ( -- ) - command-line get - [ REPL ] - [ first "(load-file \"" "\")" surround REP drop ] - if-empty ; - -f ns clone -[ first repl-env get EVAL ] "eval" pick set-at -command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at - repl-env set-global - -" -(def! not (fn* (a) (if a false true))) -(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) -" string-lines harvest [ REP drop ] each - -MAIN: main +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators combinators.short-circuit +command-line continuations fry grouping hashtables io kernel lists locals +lib.core lib.env lib.printer lib.reader lib.types math namespaces quotations +readline sequences splitting ; +IN: step6_file + +SYMBOL: repl-env + +DEFER: EVAL + +GENERIC# eval-ast 1 ( ast env -- ast ) +M: malsymbol eval-ast env-get ; +M: sequence eval-ast '[ _ EVAL ] map ; +M: assoc eval-ast '[ _ EVAL ] assoc-map ; +M: object eval-ast drop ; + +:: eval-def! ( key value env -- maltype ) + value env EVAL [ key env env-set ] keep ; + +: eval-let* ( bindings body env -- maltype env ) + [ swap 2 group ] [ new-env ] bi* [ + dup '[ first2 _ EVAL swap _ env-set ] each + ] keep ; + +:: eval-do ( exprs env -- lastform env/f ) + exprs [ + { } f + ] [ + unclip-last [ env eval-ast drop ] dip env + ] if-empty ; + +:: eval-if ( params env -- maltype env/f ) + params first env EVAL { f +nil+ } index not [ + params second env + ] [ + params length 2 > [ params third env ] [ nil f ] if + ] if ; + +:: eval-fn* ( params env -- maltype ) + env params first [ name>> ] map params second ; + +: args-split ( bindlist -- bindlist restbinding/f ) + { "&" } split1 ?first ; + +: make-bindings ( args bindlist restbinding/f -- bindingshash ) + swapd [ over length cut [ zip ] dip ] dip + [ swap 2array suffix ] [ drop ] if* >hashtable ; + +GENERIC: apply ( args fn -- maltype newenv/f ) + +M: malfn apply + [ exprs>> nip ] + [ env>> nip ] + [ binds>> args-split make-bindings ] 2tri ; + +M: callable apply call( x -- y ) f ; + +: READ ( str -- maltype ) read-str ; + +: EVAL ( maltype env -- maltype ) + over { [ array? ] [ empty? not ] } 1&& [ + over first dup malsymbol? [ name>> ] when { + { "def!" [ [ rest first2 ] dip eval-def! f ] } + { "let*" [ [ rest first2 ] dip eval-let* ] } + { "do" [ [ rest ] dip eval-do ] } + { "if" [ [ rest ] dip eval-if ] } + { "fn*" [ [ rest ] dip eval-fn* f ] } + [ drop '[ _ EVAL ] map unclip apply ] + } case [ EVAL ] when* + ] [ + eval-ast + ] if ; + +[ apply [ EVAL ] when* ] mal-apply set-global + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +: main ( -- ) + command-line get + [ REPL ] + [ first "(load-file \"" "\")" surround REP drop ] + if-empty ; + +f ns clone +[ first repl-env get EVAL ] "eval" pick set-at +command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at + repl-env set-global + +" +(def! not (fn* (a) (if a false true))) +(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) +" string-lines harvest [ REP drop ] each + +MAIN: main diff --git a/impls/factor/step7_quote/deploy.factor b/impls/factor/step7_quote/deploy.factor index e8af580f9e..ae316afec3 100644 --- a/impls/factor/step7_quote/deploy.factor +++ b/impls/factor/step7_quote/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step7_quote" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step7_quote" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step7_quote/step7_quote.factor b/impls/factor/step7_quote/step7_quote.factor index eae1cc5de1..8f14640608 100755 --- a/impls/factor/step7_quote/step7_quote.factor +++ b/impls/factor/step7_quote/step7_quote.factor @@ -1,145 +1,145 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators -combinators.short-circuit command-line continuations fry -grouping hashtables io kernel lists locals lib.core lib.env -lib.printer lib.reader lib.types math namespaces quotations -readline sequences splitting vectors ; -IN: step7_quote - -SYMBOL: repl-env - -DEFER: EVAL - -GENERIC# eval-ast 1 ( ast env -- ast ) -M: malsymbol eval-ast env-get ; -M: sequence eval-ast '[ _ EVAL ] map ; -M: assoc eval-ast '[ _ EVAL ] assoc-map ; -M: object eval-ast drop ; - -:: eval-def! ( key value env -- maltype ) - value env EVAL [ key env env-set ] keep ; - -: eval-let* ( bindings body env -- maltype env ) - [ swap 2 group ] [ new-env ] bi* [ - dup '[ first2 _ EVAL swap _ env-set ] each - ] keep ; - -:: eval-do ( exprs env -- lastform env/f ) - exprs [ - { } f - ] [ - unclip-last [ env eval-ast drop ] dip env - ] if-empty ; - -:: eval-if ( params env -- maltype env/f ) - params first env EVAL { f +nil+ } index not [ - params second env - ] [ - params length 2 > [ params third env ] [ nil f ] if - ] if ; - -:: eval-fn* ( params env -- maltype ) - env params first [ name>> ] map params second ; - -: args-split ( bindlist -- bindlist restbinding/f ) - { "&" } split1 ?first ; - -: make-bindings ( args bindlist restbinding/f -- bindingshash ) - swapd [ over length cut [ zip ] dip ] dip - [ swap 2array suffix ] [ drop ] if* >hashtable ; - -GENERIC# apply 0 ( args fn -- maltype newenv/f ) - -M: malfn apply - [ exprs>> nip ] - [ env>> nip ] - [ binds>> args-split make-bindings ] 2tri ; - -M: callable apply call( x -- y ) f ; - -DEFER: quasiquote - -: qq_loop ( elt acc -- maltype ) - [ - { [ dup array? ] - [ dup length 2 = ] - [ "splice-unquote" over first symeq? ] } 0&& [ - second "concat" - ] [ - quasiquote "cons" - ] if - swap - ] - dip 3array ; - -: qq_foldr ( xs -- maltype ) - dup length 0 = [ - drop { } - ] [ - unclip swap qq_foldr qq_loop - ] if ; - -GENERIC: quasiquote ( maltype -- maltype ) -M: array quasiquote - { [ dup length 2 = ] [ "unquote" over first symeq? ] } 0&& - [ second ] [ qq_foldr ] if ; -M: vector quasiquote qq_foldr "vec" swap 2array ; -M: malsymbol quasiquote "quote" swap 2array ; -M: assoc quasiquote "quote" swap 2array ; -M: object quasiquote ; - -: READ ( str -- maltype ) read-str ; - -: EVAL ( maltype env -- maltype ) - over { [ array? ] [ empty? not ] } 1&& [ - over first dup malsymbol? [ name>> ] when { - { "def!" [ [ rest first2 ] dip eval-def! f ] } - { "let*" [ [ rest first2 ] dip eval-let* ] } - { "do" [ [ rest ] dip eval-do ] } - { "if" [ [ rest ] dip eval-if ] } - { "fn*" [ [ rest ] dip eval-fn* f ] } - { "quote" [ drop second f ] } - { "quasiquoteexpand" [ drop second quasiquote f ] } - { "quasiquote" [ [ second quasiquote ] dip ] } - [ drop '[ _ EVAL ] map unclip apply ] - } case [ EVAL ] when* - ] [ - eval-ast - ] if ; - -[ apply [ EVAL ] when* ] mal-apply set-global - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ repl-env get EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -: main ( -- ) - command-line get - [ REPL ] - [ first "(load-file \"" "\")" surround REP drop ] - if-empty ; - -f ns clone -[ first repl-env get EVAL ] "eval" pick set-at -command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at - repl-env set-global - -" -(def! not (fn* (a) (if a false true))) -(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) -" string-lines harvest [ REP drop ] each - -MAIN: main +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators +combinators.short-circuit command-line continuations fry +grouping hashtables io kernel lists locals lib.core lib.env +lib.printer lib.reader lib.types math namespaces quotations +readline sequences splitting vectors ; +IN: step7_quote + +SYMBOL: repl-env + +DEFER: EVAL + +GENERIC# eval-ast 1 ( ast env -- ast ) +M: malsymbol eval-ast env-get ; +M: sequence eval-ast '[ _ EVAL ] map ; +M: assoc eval-ast '[ _ EVAL ] assoc-map ; +M: object eval-ast drop ; + +:: eval-def! ( key value env -- maltype ) + value env EVAL [ key env env-set ] keep ; + +: eval-let* ( bindings body env -- maltype env ) + [ swap 2 group ] [ new-env ] bi* [ + dup '[ first2 _ EVAL swap _ env-set ] each + ] keep ; + +:: eval-do ( exprs env -- lastform env/f ) + exprs [ + { } f + ] [ + unclip-last [ env eval-ast drop ] dip env + ] if-empty ; + +:: eval-if ( params env -- maltype env/f ) + params first env EVAL { f +nil+ } index not [ + params second env + ] [ + params length 2 > [ params third env ] [ nil f ] if + ] if ; + +:: eval-fn* ( params env -- maltype ) + env params first [ name>> ] map params second ; + +: args-split ( bindlist -- bindlist restbinding/f ) + { "&" } split1 ?first ; + +: make-bindings ( args bindlist restbinding/f -- bindingshash ) + swapd [ over length cut [ zip ] dip ] dip + [ swap 2array suffix ] [ drop ] if* >hashtable ; + +GENERIC# apply 0 ( args fn -- maltype newenv/f ) + +M: malfn apply + [ exprs>> nip ] + [ env>> nip ] + [ binds>> args-split make-bindings ] 2tri ; + +M: callable apply call( x -- y ) f ; + +DEFER: quasiquote + +: qq_loop ( elt acc -- maltype ) + [ + { [ dup array? ] + [ dup length 2 = ] + [ "splice-unquote" over first symeq? ] } 0&& [ + second "concat" + ] [ + quasiquote "cons" + ] if + swap + ] + dip 3array ; + +: qq_foldr ( xs -- maltype ) + dup length 0 = [ + drop { } + ] [ + unclip swap qq_foldr qq_loop + ] if ; + +GENERIC: quasiquote ( maltype -- maltype ) +M: array quasiquote + { [ dup length 2 = ] [ "unquote" over first symeq? ] } 0&& + [ second ] [ qq_foldr ] if ; +M: vector quasiquote qq_foldr "vec" swap 2array ; +M: malsymbol quasiquote "quote" swap 2array ; +M: assoc quasiquote "quote" swap 2array ; +M: object quasiquote ; + +: READ ( str -- maltype ) read-str ; + +: EVAL ( maltype env -- maltype ) + over { [ array? ] [ empty? not ] } 1&& [ + over first dup malsymbol? [ name>> ] when { + { "def!" [ [ rest first2 ] dip eval-def! f ] } + { "let*" [ [ rest first2 ] dip eval-let* ] } + { "do" [ [ rest ] dip eval-do ] } + { "if" [ [ rest ] dip eval-if ] } + { "fn*" [ [ rest ] dip eval-fn* f ] } + { "quote" [ drop second f ] } + { "quasiquoteexpand" [ drop second quasiquote f ] } + { "quasiquote" [ [ second quasiquote ] dip ] } + [ drop '[ _ EVAL ] map unclip apply ] + } case [ EVAL ] when* + ] [ + eval-ast + ] if ; + +[ apply [ EVAL ] when* ] mal-apply set-global + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +: main ( -- ) + command-line get + [ REPL ] + [ first "(load-file \"" "\")" surround REP drop ] + if-empty ; + +f ns clone +[ first repl-env get EVAL ] "eval" pick set-at +command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at + repl-env set-global + +" +(def! not (fn* (a) (if a false true))) +(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) +" string-lines harvest [ REP drop ] each + +MAIN: main diff --git a/impls/factor/step8_macros/deploy.factor b/impls/factor/step8_macros/deploy.factor index e50cebbf5b..e1784bca01 100644 --- a/impls/factor/step8_macros/deploy.factor +++ b/impls/factor/step8_macros/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step8_macros" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step8_macros" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step8_macros/step8_macros.factor b/impls/factor/step8_macros/step8_macros.factor index f6c7db7cdd..9bd75c4738 100755 --- a/impls/factor/step8_macros/step8_macros.factor +++ b/impls/factor/step8_macros/step8_macros.factor @@ -1,164 +1,164 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators -combinators.short-circuit command-line continuations fry -grouping hashtables io kernel lists locals lib.core lib.env -lib.printer lib.reader lib.types math namespaces quotations -readline sequences splitting vectors ; -IN: step8_macros - -SYMBOL: repl-env - -DEFER: EVAL - -GENERIC# eval-ast 1 ( ast env -- ast ) -M: malsymbol eval-ast env-get ; -M: sequence eval-ast '[ _ EVAL ] map ; -M: assoc eval-ast '[ _ EVAL ] assoc-map ; -M: object eval-ast drop ; - -:: eval-def! ( key value env -- maltype ) - value env EVAL [ key env env-set ] keep ; - -:: eval-defmacro! ( key value env -- maltype ) - value env EVAL malmacro [ key env env-set ] keep ; - -: eval-let* ( bindings body env -- maltype env ) - [ swap 2 group ] [ new-env ] bi* [ - dup '[ first2 _ EVAL swap _ env-set ] each - ] keep ; - -:: eval-do ( exprs env -- lastform env/f ) - exprs [ - { } f - ] [ - unclip-last [ env eval-ast drop ] dip env - ] if-empty ; - -:: eval-if ( params env -- maltype env/f ) - params first env EVAL { f +nil+ } index not [ - params second env - ] [ - params length 2 > [ params third env ] [ nil f ] if - ] if ; - -:: eval-fn* ( params env -- maltype ) - env params first [ name>> ] map params second ; - -: args-split ( bindlist -- bindlist restbinding/f ) - { "&" } split1 ?first ; - -: make-bindings ( args bindlist restbinding/f -- bindingshash ) - swapd [ over length cut [ zip ] dip ] dip - [ swap 2array suffix ] [ drop ] if* >hashtable ; - -GENERIC# apply 0 ( args fn -- maltype newenv/f ) - -M: malfn apply - [ exprs>> nip ] - [ env>> nip ] - [ binds>> args-split make-bindings ] 2tri ; - -M: callable apply call( x -- y ) f ; - -DEFER: quasiquote - -: qq_loop ( elt acc -- maltype ) - [ - { [ dup array? ] - [ dup length 2 = ] - [ "splice-unquote" over first symeq? ] } 0&& [ - second "concat" - ] [ - quasiquote "cons" - ] if - swap - ] - dip 3array ; - -: qq_foldr ( xs -- maltype ) - dup length 0 = [ - drop { } - ] [ - unclip swap qq_foldr qq_loop - ] if ; - -GENERIC: quasiquote ( maltype -- maltype ) -M: array quasiquote - { [ dup length 2 = ] [ "unquote" over first symeq? ] } 0&& - [ second ] [ qq_foldr ] if ; -M: vector quasiquote qq_foldr "vec" swap 2array ; -M: malsymbol quasiquote "quote" swap 2array ; -M: assoc quasiquote "quote" swap 2array ; -M: object quasiquote ; - -:: macro-expand ( maltype env -- maltype ) - maltype dup array? [ - dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [ - dup { [ malfn? ] [ macro?>> ] } 1&& [ - [ rest ] dip apply [ EVAL ] keep macro-expand - ] [ drop ] if - ] when* - ] when ; - -: READ ( str -- maltype ) read-str ; - -: EVAL ( maltype env -- maltype ) - over { [ array? ] [ empty? not ] } 1&& [ - [ macro-expand ] keep over array? [ - over first dup malsymbol? [ name>> ] when { - { "def!" [ [ rest first2 ] dip eval-def! f ] } - { "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] } - { "let*" [ [ rest first2 ] dip eval-let* ] } - { "do" [ [ rest ] dip eval-do ] } - { "if" [ [ rest ] dip eval-if ] } - { "fn*" [ [ rest ] dip eval-fn* f ] } - { "quote" [ drop second f ] } - { "quasiquoteexpand" [ drop second quasiquote f ] } - { "quasiquote" [ [ second quasiquote ] dip ] } - { "macroexpand" [ [ second ] dip macro-expand f ] } - [ drop '[ _ EVAL ] map unclip apply ] - } case [ EVAL ] when* - ] [ - eval-ast - ] if - ] [ - eval-ast - ] if ; - -[ apply [ EVAL ] when* ] mal-apply set-global - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ repl-env get EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -: main ( -- ) - command-line get - [ REPL ] - [ first "(load-file \"" "\")" surround REP drop ] - if-empty ; - -f ns clone -[ first repl-env get EVAL ] "eval" pick set-at -command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at - repl-env set-global - -" -(def! not (fn* (a) (if a false true))) -(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) -(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))))))) -" string-lines harvest [ REP drop ] each - -MAIN: main +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators +combinators.short-circuit command-line continuations fry +grouping hashtables io kernel lists locals lib.core lib.env +lib.printer lib.reader lib.types math namespaces quotations +readline sequences splitting vectors ; +IN: step8_macros + +SYMBOL: repl-env + +DEFER: EVAL + +GENERIC# eval-ast 1 ( ast env -- ast ) +M: malsymbol eval-ast env-get ; +M: sequence eval-ast '[ _ EVAL ] map ; +M: assoc eval-ast '[ _ EVAL ] assoc-map ; +M: object eval-ast drop ; + +:: eval-def! ( key value env -- maltype ) + value env EVAL [ key env env-set ] keep ; + +:: eval-defmacro! ( key value env -- maltype ) + value env EVAL malmacro [ key env env-set ] keep ; + +: eval-let* ( bindings body env -- maltype env ) + [ swap 2 group ] [ new-env ] bi* [ + dup '[ first2 _ EVAL swap _ env-set ] each + ] keep ; + +:: eval-do ( exprs env -- lastform env/f ) + exprs [ + { } f + ] [ + unclip-last [ env eval-ast drop ] dip env + ] if-empty ; + +:: eval-if ( params env -- maltype env/f ) + params first env EVAL { f +nil+ } index not [ + params second env + ] [ + params length 2 > [ params third env ] [ nil f ] if + ] if ; + +:: eval-fn* ( params env -- maltype ) + env params first [ name>> ] map params second ; + +: args-split ( bindlist -- bindlist restbinding/f ) + { "&" } split1 ?first ; + +: make-bindings ( args bindlist restbinding/f -- bindingshash ) + swapd [ over length cut [ zip ] dip ] dip + [ swap 2array suffix ] [ drop ] if* >hashtable ; + +GENERIC# apply 0 ( args fn -- maltype newenv/f ) + +M: malfn apply + [ exprs>> nip ] + [ env>> nip ] + [ binds>> args-split make-bindings ] 2tri ; + +M: callable apply call( x -- y ) f ; + +DEFER: quasiquote + +: qq_loop ( elt acc -- maltype ) + [ + { [ dup array? ] + [ dup length 2 = ] + [ "splice-unquote" over first symeq? ] } 0&& [ + second "concat" + ] [ + quasiquote "cons" + ] if + swap + ] + dip 3array ; + +: qq_foldr ( xs -- maltype ) + dup length 0 = [ + drop { } + ] [ + unclip swap qq_foldr qq_loop + ] if ; + +GENERIC: quasiquote ( maltype -- maltype ) +M: array quasiquote + { [ dup length 2 = ] [ "unquote" over first symeq? ] } 0&& + [ second ] [ qq_foldr ] if ; +M: vector quasiquote qq_foldr "vec" swap 2array ; +M: malsymbol quasiquote "quote" swap 2array ; +M: assoc quasiquote "quote" swap 2array ; +M: object quasiquote ; + +:: macro-expand ( maltype env -- maltype ) + maltype dup array? [ + dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [ + dup { [ malfn? ] [ macro?>> ] } 1&& [ + [ rest ] dip apply [ EVAL ] keep macro-expand + ] [ drop ] if + ] when* + ] when ; + +: READ ( str -- maltype ) read-str ; + +: EVAL ( maltype env -- maltype ) + over { [ array? ] [ empty? not ] } 1&& [ + [ macro-expand ] keep over array? [ + over first dup malsymbol? [ name>> ] when { + { "def!" [ [ rest first2 ] dip eval-def! f ] } + { "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] } + { "let*" [ [ rest first2 ] dip eval-let* ] } + { "do" [ [ rest ] dip eval-do ] } + { "if" [ [ rest ] dip eval-if ] } + { "fn*" [ [ rest ] dip eval-fn* f ] } + { "quote" [ drop second f ] } + { "quasiquoteexpand" [ drop second quasiquote f ] } + { "quasiquote" [ [ second quasiquote ] dip ] } + { "macroexpand" [ [ second ] dip macro-expand f ] } + [ drop '[ _ EVAL ] map unclip apply ] + } case [ EVAL ] when* + ] [ + eval-ast + ] if + ] [ + eval-ast + ] if ; + +[ apply [ EVAL ] when* ] mal-apply set-global + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +: main ( -- ) + command-line get + [ REPL ] + [ first "(load-file \"" "\")" surround REP drop ] + if-empty ; + +f ns clone +[ first repl-env get EVAL ] "eval" pick set-at +command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at + repl-env set-global + +" +(def! not (fn* (a) (if a false true))) +(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) +(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))))))) +" string-lines harvest [ REP drop ] each + +MAIN: main diff --git a/impls/factor/step9_try/deploy.factor b/impls/factor/step9_try/deploy.factor index 03f485b13b..f60e694606 100644 --- a/impls/factor/step9_try/deploy.factor +++ b/impls/factor/step9_try/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "step9_try" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "step9_try" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/step9_try/step9_try.factor b/impls/factor/step9_try/step9_try.factor index cf0119e813..be786b8d7d 100755 --- a/impls/factor/step9_try/step9_try.factor +++ b/impls/factor/step9_try/step9_try.factor @@ -1,176 +1,176 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators -combinators.short-circuit command-line continuations fry -grouping hashtables io kernel lists locals lib.core lib.env -lib.printer lib.reader lib.types math namespaces quotations -readline sequences splitting vectors ; -IN: step9_try - -SYMBOL: repl-env - -DEFER: EVAL - -GENERIC# eval-ast 1 ( ast env -- ast ) -M: malsymbol eval-ast env-get ; -M: sequence eval-ast '[ _ EVAL ] map ; -M: assoc eval-ast '[ _ EVAL ] assoc-map ; -M: object eval-ast drop ; - -:: eval-def! ( key value env -- maltype ) - value env EVAL [ key env env-set ] keep ; - -:: eval-defmacro! ( key value env -- maltype ) - value env EVAL malmacro [ key env env-set ] keep ; - -: eval-let* ( bindings body env -- maltype env ) - [ swap 2 group ] [ new-env ] bi* [ - dup '[ first2 _ EVAL swap _ env-set ] each - ] keep ; - -:: eval-do ( exprs env -- lastform env/f ) - exprs [ - { } f - ] [ - unclip-last [ env eval-ast drop ] dip env - ] if-empty ; - -:: eval-if ( params env -- maltype env/f ) - params first env EVAL { f +nil+ } index not [ - params second env - ] [ - params length 2 > [ params third env ] [ nil f ] if - ] if ; - -:: eval-fn* ( params env -- maltype ) - env params first [ name>> ] map params second ; - -:: eval-try* ( params env -- maltype ) - [ params first env EVAL ] - [ - params length 1 > [ - params second second env new-env [ env-set ] keep - params second third swap EVAL - ] [ - throw - ] if - ] recover ; - -: args-split ( bindlist -- bindlist restbinding/f ) - { "&" } split1 ?first ; - -: make-bindings ( args bindlist restbinding/f -- bindingshash ) - swapd [ over length cut [ zip ] dip ] dip - [ swap 2array suffix ] [ drop ] if* >hashtable ; - -GENERIC# apply 0 ( args fn -- maltype newenv/f ) - -M: malfn apply - [ exprs>> nip ] - [ env>> nip ] - [ binds>> args-split make-bindings ] 2tri ; - -M: callable apply call( x -- y ) f ; - -DEFER: quasiquote - -: qq_loop ( elt acc -- maltype ) - [ - { [ dup array? ] - [ dup length 2 = ] - [ "splice-unquote" over first symeq? ] } 0&& [ - second "concat" - ] [ - quasiquote "cons" - ] if - swap - ] - dip 3array ; - -: qq_foldr ( xs -- maltype ) - dup length 0 = [ - drop { } - ] [ - unclip swap qq_foldr qq_loop - ] if ; - -GENERIC: quasiquote ( maltype -- maltype ) -M: array quasiquote - { [ dup length 2 = ] [ "unquote" over first symeq? ] } 0&& - [ second ] [ qq_foldr ] if ; -M: vector quasiquote qq_foldr "vec" swap 2array ; -M: malsymbol quasiquote "quote" swap 2array ; -M: assoc quasiquote "quote" swap 2array ; -M: object quasiquote ; - -:: macro-expand ( maltype env -- maltype ) - maltype dup array? [ - dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [ - dup { [ malfn? ] [ macro?>> ] } 1&& [ - [ rest ] dip apply [ EVAL ] keep macro-expand - ] [ drop ] if - ] when* - ] when ; - -: READ ( str -- maltype ) read-str ; - -: EVAL ( maltype env -- maltype ) - over { [ array? ] [ empty? not ] } 1&& [ - [ macro-expand ] keep over array? [ - over first dup malsymbol? [ name>> ] when { - { "def!" [ [ rest first2 ] dip eval-def! f ] } - { "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] } - { "let*" [ [ rest first2 ] dip eval-let* ] } - { "do" [ [ rest ] dip eval-do ] } - { "if" [ [ rest ] dip eval-if ] } - { "fn*" [ [ rest ] dip eval-fn* f ] } - { "quote" [ drop second f ] } - { "quasiquoteexpand" [ drop second quasiquote f ] } - { "quasiquote" [ [ second quasiquote ] dip ] } - { "macroexpand" [ [ second ] dip macro-expand f ] } - { "try*" [ [ rest ] dip eval-try* f ] } - [ drop '[ _ EVAL ] map unclip apply ] - } case [ EVAL ] when* - ] [ - eval-ast - ] if - ] [ - eval-ast - ] if ; - -[ apply [ EVAL ] when* ] mal-apply set-global - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ repl-env get EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -: main ( -- ) - command-line get - [ REPL ] - [ first "(load-file \"" "\")" surround REP drop ] - if-empty ; - -f ns clone -[ first repl-env get EVAL ] "eval" pick set-at -command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at - repl-env set-global - -" -(def! not (fn* (a) (if a false true))) -(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) -(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))))))) -" string-lines harvest [ REP drop ] each - -MAIN: main +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators +combinators.short-circuit command-line continuations fry +grouping hashtables io kernel lists locals lib.core lib.env +lib.printer lib.reader lib.types math namespaces quotations +readline sequences splitting vectors ; +IN: step9_try + +SYMBOL: repl-env + +DEFER: EVAL + +GENERIC# eval-ast 1 ( ast env -- ast ) +M: malsymbol eval-ast env-get ; +M: sequence eval-ast '[ _ EVAL ] map ; +M: assoc eval-ast '[ _ EVAL ] assoc-map ; +M: object eval-ast drop ; + +:: eval-def! ( key value env -- maltype ) + value env EVAL [ key env env-set ] keep ; + +:: eval-defmacro! ( key value env -- maltype ) + value env EVAL malmacro [ key env env-set ] keep ; + +: eval-let* ( bindings body env -- maltype env ) + [ swap 2 group ] [ new-env ] bi* [ + dup '[ first2 _ EVAL swap _ env-set ] each + ] keep ; + +:: eval-do ( exprs env -- lastform env/f ) + exprs [ + { } f + ] [ + unclip-last [ env eval-ast drop ] dip env + ] if-empty ; + +:: eval-if ( params env -- maltype env/f ) + params first env EVAL { f +nil+ } index not [ + params second env + ] [ + params length 2 > [ params third env ] [ nil f ] if + ] if ; + +:: eval-fn* ( params env -- maltype ) + env params first [ name>> ] map params second ; + +:: eval-try* ( params env -- maltype ) + [ params first env EVAL ] + [ + params length 1 > [ + params second second env new-env [ env-set ] keep + params second third swap EVAL + ] [ + throw + ] if + ] recover ; + +: args-split ( bindlist -- bindlist restbinding/f ) + { "&" } split1 ?first ; + +: make-bindings ( args bindlist restbinding/f -- bindingshash ) + swapd [ over length cut [ zip ] dip ] dip + [ swap 2array suffix ] [ drop ] if* >hashtable ; + +GENERIC# apply 0 ( args fn -- maltype newenv/f ) + +M: malfn apply + [ exprs>> nip ] + [ env>> nip ] + [ binds>> args-split make-bindings ] 2tri ; + +M: callable apply call( x -- y ) f ; + +DEFER: quasiquote + +: qq_loop ( elt acc -- maltype ) + [ + { [ dup array? ] + [ dup length 2 = ] + [ "splice-unquote" over first symeq? ] } 0&& [ + second "concat" + ] [ + quasiquote "cons" + ] if + swap + ] + dip 3array ; + +: qq_foldr ( xs -- maltype ) + dup length 0 = [ + drop { } + ] [ + unclip swap qq_foldr qq_loop + ] if ; + +GENERIC: quasiquote ( maltype -- maltype ) +M: array quasiquote + { [ dup length 2 = ] [ "unquote" over first symeq? ] } 0&& + [ second ] [ qq_foldr ] if ; +M: vector quasiquote qq_foldr "vec" swap 2array ; +M: malsymbol quasiquote "quote" swap 2array ; +M: assoc quasiquote "quote" swap 2array ; +M: object quasiquote ; + +:: macro-expand ( maltype env -- maltype ) + maltype dup array? [ + dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [ + dup { [ malfn? ] [ macro?>> ] } 1&& [ + [ rest ] dip apply [ EVAL ] keep macro-expand + ] [ drop ] if + ] when* + ] when ; + +: READ ( str -- maltype ) read-str ; + +: EVAL ( maltype env -- maltype ) + over { [ array? ] [ empty? not ] } 1&& [ + [ macro-expand ] keep over array? [ + over first dup malsymbol? [ name>> ] when { + { "def!" [ [ rest first2 ] dip eval-def! f ] } + { "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] } + { "let*" [ [ rest first2 ] dip eval-let* ] } + { "do" [ [ rest ] dip eval-do ] } + { "if" [ [ rest ] dip eval-if ] } + { "fn*" [ [ rest ] dip eval-fn* f ] } + { "quote" [ drop second f ] } + { "quasiquoteexpand" [ drop second quasiquote f ] } + { "quasiquote" [ [ second quasiquote ] dip ] } + { "macroexpand" [ [ second ] dip macro-expand f ] } + { "try*" [ [ rest ] dip eval-try* f ] } + [ drop '[ _ EVAL ] map unclip apply ] + } case [ EVAL ] when* + ] [ + eval-ast + ] if + ] [ + eval-ast + ] if ; + +[ apply [ EVAL ] when* ] mal-apply set-global + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +: main ( -- ) + command-line get + [ REPL ] + [ first "(load-file \"" "\")" surround REP drop ] + if-empty ; + +f ns clone +[ first repl-env get EVAL ] "eval" pick set-at +command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at + repl-env set-global + +" +(def! not (fn* (a) (if a false true))) +(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) +(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))))))) +" string-lines harvest [ REP drop ] each + +MAIN: main diff --git a/impls/factor/stepA_mal/deploy.factor b/impls/factor/stepA_mal/deploy.factor index 4397858be3..b5a68cbb46 100644 --- a/impls/factor/stepA_mal/deploy.factor +++ b/impls/factor/stepA_mal/deploy.factor @@ -1,16 +1,16 @@ -USING: tools.deploy.config ; -H{ - { deploy-c-types? f } - { deploy-help? f } - { deploy-name "stepA_mal" } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-console? t } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-ui? f } - { deploy-word-defs? f } - { deploy-threads? t } - { deploy-math? t } - { deploy-word-props? f } -} +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "stepA_mal" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/impls/factor/stepA_mal/stepA_mal.factor b/impls/factor/stepA_mal/stepA_mal.factor index 0a2bb84694..7811fd571e 100755 --- a/impls/factor/stepA_mal/stepA_mal.factor +++ b/impls/factor/stepA_mal/stepA_mal.factor @@ -1,178 +1,178 @@ -! Copyright (C) 2015 Jordan Lewis. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators -combinators.short-circuit command-line continuations fry -grouping hashtables io kernel lists locals lib.core lib.env -lib.printer lib.reader lib.types math namespaces quotations -readline sequences splitting strings vectors ; -IN: stepA_mal - -SYMBOL: repl-env - -DEFER: EVAL - -GENERIC# eval-ast 1 ( ast env -- ast ) -M: malsymbol eval-ast env-get ; -M: sequence eval-ast '[ _ EVAL ] map ; -M: assoc eval-ast '[ _ EVAL ] assoc-map ; -M: object eval-ast drop ; - -:: eval-def! ( key value env -- maltype ) - value env EVAL [ key env env-set ] keep ; - -:: eval-defmacro! ( key value env -- maltype ) - value env EVAL malmacro [ key env env-set ] keep ; - -: eval-let* ( bindings body env -- maltype env ) - [ swap 2 group ] [ new-env ] bi* [ - dup '[ first2 _ EVAL swap _ env-set ] each - ] keep ; - -:: eval-do ( exprs env -- lastform env/f ) - exprs [ - { } f - ] [ - unclip-last [ env eval-ast drop ] dip env - ] if-empty ; - -:: eval-if ( params env -- maltype env/f ) - params first env EVAL { f +nil+ } index not [ - params second env - ] [ - params length 2 > [ params third env ] [ nil f ] if - ] if ; - -:: eval-fn* ( params env -- maltype ) - env params first [ name>> ] map params second ; - -:: eval-try* ( params env -- maltype ) - [ params first env EVAL ] - [ - params length 1 > [ - params second second env new-env [ env-set ] keep - params second third swap EVAL - ] [ - throw - ] if - ] recover ; - -: args-split ( bindlist -- bindlist restbinding/f ) - { "&" } split1 ?first ; - -: make-bindings ( args bindlist restbinding/f -- bindingshash ) - swapd [ over length cut [ zip ] dip ] dip - [ swap 2array suffix ] [ drop ] if* >hashtable ; - -GENERIC# apply 0 ( args fn -- maltype newenv/f ) - -M: malfn apply - [ exprs>> nip ] - [ env>> nip ] - [ binds>> args-split make-bindings ] 2tri ; - -M: callable apply call( x -- y ) f ; - -DEFER: quasiquote - -: qq_loop ( elt acc -- maltype ) - [ - { [ dup array? ] - [ dup length 2 = ] - [ "splice-unquote" over first symeq? ] } 0&& [ - second "concat" - ] [ - quasiquote "cons" - ] if - swap - ] - dip 3array ; - -: qq_foldr ( xs -- maltype ) - dup length 0 = [ - drop { } - ] [ - unclip swap qq_foldr qq_loop - ] if ; - -GENERIC: quasiquote ( maltype -- maltype ) -M: array quasiquote - { [ dup length 2 = ] [ "unquote" over first symeq? ] } 0&& - [ second ] [ qq_foldr ] if ; -M: vector quasiquote qq_foldr "vec" swap 2array ; -M: malsymbol quasiquote "quote" swap 2array ; -M: assoc quasiquote "quote" swap 2array ; -M: object quasiquote ; - -:: macro-expand ( maltype env -- maltype ) - maltype dup array? [ - dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [ - dup { [ malfn? ] [ macro?>> ] } 1&& [ - [ rest ] dip apply [ EVAL ] keep macro-expand - ] [ drop ] if - ] when* - ] when ; - -: READ ( str -- maltype ) read-str ; - -: EVAL ( maltype env -- maltype ) - over { [ array? ] [ empty? not ] } 1&& [ - [ macro-expand ] keep over array? [ - over first dup malsymbol? [ name>> ] when { - { "def!" [ [ rest first2 ] dip eval-def! f ] } - { "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] } - { "let*" [ [ rest first2 ] dip eval-let* ] } - { "do" [ [ rest ] dip eval-do ] } - { "if" [ [ rest ] dip eval-if ] } - { "fn*" [ [ rest ] dip eval-fn* f ] } - { "quote" [ drop second f ] } - { "quasiquoteexpand" [ drop second quasiquote f ] } - { "quasiquote" [ [ second quasiquote ] dip ] } - { "macroexpand" [ [ second ] dip macro-expand f ] } - { "try*" [ [ rest ] dip eval-try* f ] } - [ drop '[ _ EVAL ] map unclip apply ] - } case [ EVAL ] when* - ] [ - eval-ast - ] if - ] [ - eval-ast - ] if ; - -[ apply [ EVAL ] when* ] mal-apply set-global - -: PRINT ( maltype -- str ) pr-str ; - -: REP ( str -- str ) - [ - READ repl-env get EVAL PRINT - ] [ - nip pr-str "Error: " swap append - ] recover ; - -: REPL ( -- ) - "(println (str \"Mal [\" *host-language* \"]\"))" REP drop - [ - "user> " readline [ - [ REP print flush ] unless-empty - ] keep - ] loop ; - -: main ( -- ) - command-line get - [ REPL ] - [ first "(load-file \"" "\")" surround REP drop ] - if-empty ; - -f ns clone -[ first repl-env get EVAL ] "eval" pick set-at -command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at - repl-env set-global - -" -(def! *host-language* \"factor\") -(def! not (fn* (a) (if a false true))) -(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) -(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))))))) -" string-lines harvest [ READ repl-env get EVAL drop ] each - -MAIN: main +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators +combinators.short-circuit command-line continuations fry +grouping hashtables io kernel lists locals lib.core lib.env +lib.printer lib.reader lib.types math namespaces quotations +readline sequences splitting strings vectors ; +IN: stepA_mal + +SYMBOL: repl-env + +DEFER: EVAL + +GENERIC# eval-ast 1 ( ast env -- ast ) +M: malsymbol eval-ast env-get ; +M: sequence eval-ast '[ _ EVAL ] map ; +M: assoc eval-ast '[ _ EVAL ] assoc-map ; +M: object eval-ast drop ; + +:: eval-def! ( key value env -- maltype ) + value env EVAL [ key env env-set ] keep ; + +:: eval-defmacro! ( key value env -- maltype ) + value env EVAL malmacro [ key env env-set ] keep ; + +: eval-let* ( bindings body env -- maltype env ) + [ swap 2 group ] [ new-env ] bi* [ + dup '[ first2 _ EVAL swap _ env-set ] each + ] keep ; + +:: eval-do ( exprs env -- lastform env/f ) + exprs [ + { } f + ] [ + unclip-last [ env eval-ast drop ] dip env + ] if-empty ; + +:: eval-if ( params env -- maltype env/f ) + params first env EVAL { f +nil+ } index not [ + params second env + ] [ + params length 2 > [ params third env ] [ nil f ] if + ] if ; + +:: eval-fn* ( params env -- maltype ) + env params first [ name>> ] map params second ; + +:: eval-try* ( params env -- maltype ) + [ params first env EVAL ] + [ + params length 1 > [ + params second second env new-env [ env-set ] keep + params second third swap EVAL + ] [ + throw + ] if + ] recover ; + +: args-split ( bindlist -- bindlist restbinding/f ) + { "&" } split1 ?first ; + +: make-bindings ( args bindlist restbinding/f -- bindingshash ) + swapd [ over length cut [ zip ] dip ] dip + [ swap 2array suffix ] [ drop ] if* >hashtable ; + +GENERIC# apply 0 ( args fn -- maltype newenv/f ) + +M: malfn apply + [ exprs>> nip ] + [ env>> nip ] + [ binds>> args-split make-bindings ] 2tri ; + +M: callable apply call( x -- y ) f ; + +DEFER: quasiquote + +: qq_loop ( elt acc -- maltype ) + [ + { [ dup array? ] + [ dup length 2 = ] + [ "splice-unquote" over first symeq? ] } 0&& [ + second "concat" + ] [ + quasiquote "cons" + ] if + swap + ] + dip 3array ; + +: qq_foldr ( xs -- maltype ) + dup length 0 = [ + drop { } + ] [ + unclip swap qq_foldr qq_loop + ] if ; + +GENERIC: quasiquote ( maltype -- maltype ) +M: array quasiquote + { [ dup length 2 = ] [ "unquote" over first symeq? ] } 0&& + [ second ] [ qq_foldr ] if ; +M: vector quasiquote qq_foldr "vec" swap 2array ; +M: malsymbol quasiquote "quote" swap 2array ; +M: assoc quasiquote "quote" swap 2array ; +M: object quasiquote ; + +:: macro-expand ( maltype env -- maltype ) + maltype dup array? [ + dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [ + dup { [ malfn? ] [ macro?>> ] } 1&& [ + [ rest ] dip apply [ EVAL ] keep macro-expand + ] [ drop ] if + ] when* + ] when ; + +: READ ( str -- maltype ) read-str ; + +: EVAL ( maltype env -- maltype ) + over { [ array? ] [ empty? not ] } 1&& [ + [ macro-expand ] keep over array? [ + over first dup malsymbol? [ name>> ] when { + { "def!" [ [ rest first2 ] dip eval-def! f ] } + { "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] } + { "let*" [ [ rest first2 ] dip eval-let* ] } + { "do" [ [ rest ] dip eval-do ] } + { "if" [ [ rest ] dip eval-if ] } + { "fn*" [ [ rest ] dip eval-fn* f ] } + { "quote" [ drop second f ] } + { "quasiquoteexpand" [ drop second quasiquote f ] } + { "quasiquote" [ [ second quasiquote ] dip ] } + { "macroexpand" [ [ second ] dip macro-expand f ] } + { "try*" [ [ rest ] dip eval-try* f ] } + [ drop '[ _ EVAL ] map unclip apply ] + } case [ EVAL ] when* + ] [ + eval-ast + ] if + ] [ + eval-ast + ] if ; + +[ apply [ EVAL ] when* ] mal-apply set-global + +: PRINT ( maltype -- str ) pr-str ; + +: REP ( str -- str ) + [ + READ repl-env get EVAL PRINT + ] [ + nip pr-str "Error: " swap append + ] recover ; + +: REPL ( -- ) + "(println (str \"Mal [\" *host-language* \"]\"))" REP drop + [ + "user> " readline [ + [ REP print flush ] unless-empty + ] keep + ] loop ; + +: main ( -- ) + command-line get + [ REPL ] + [ first "(load-file \"" "\")" surround REP drop ] + if-empty ; + +f ns clone +[ first repl-env get EVAL ] "eval" pick set-at +command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at + repl-env set-global + +" +(def! *host-language* \"factor\") +(def! not (fn* (a) (if a false true))) +(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\"))))) +(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))))))) +" string-lines harvest [ READ repl-env get EVAL drop ] each + +MAIN: main diff --git a/impls/factor/tests/step5_tco.mal b/impls/factor/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/factor/tests/step5_tco.mal +++ b/impls/factor/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/fantom/Dockerfile b/impls/fantom/Dockerfile index 67e21b07d4..ea91029408 100644 --- a/impls/fantom/Dockerfile +++ b/impls/fantom/Dockerfile @@ -1,38 +1,38 @@ -FROM ubuntu:bionic -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Java and Unzip -RUN apt-get -y install openjdk-8-jdk unzip - -# Fantom and JLine -RUN cd /tmp && curl -sfLO https://github.com/fantom-lang/fantom/releases/download/v1.0.75/fantom-1.0.75.zip \ - && unzip -q fantom-1.0.75.zip \ - && rm fantom-1.0.75.zip \ - && mv fantom-1.0.75 /opt/fantom \ - && cd /opt/fantom \ - && bash adm/unixsetup \ - && curl -sfL -o /opt/fantom/lib/java/jline.jar https://repo1.maven.org/maven2/jline/jline/2.14.6/jline-2.14.6.jar \ - && sed -i '/java.options/ s/^\/\/ *\(.*\)$/\1 -Djline.expandevents=false/' /opt/fantom/etc/sys/config.props - -ENV PATH /opt/fantom/bin:$PATH -ENV HOME /mal +FROM ubuntu:bionic +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Java and Unzip +RUN apt-get -y install openjdk-8-jdk unzip + +# Fantom and JLine +RUN cd /tmp && curl -sfLO https://github.com/fantom-lang/fantom/releases/download/v1.0.75/fantom-1.0.75.zip \ + && unzip -q fantom-1.0.75.zip \ + && rm fantom-1.0.75.zip \ + && mv fantom-1.0.75 /opt/fantom \ + && cd /opt/fantom \ + && bash adm/unixsetup \ + && curl -sfL -o /opt/fantom/lib/java/jline.jar https://repo1.maven.org/maven2/jline/jline/2.14.6/jline-2.14.6.jar \ + && sed -i '/java.options/ s/^\/\/ *\(.*\)$/\1 -Djline.expandevents=false/' /opt/fantom/etc/sys/config.props + +ENV PATH /opt/fantom/bin:$PATH +ENV HOME /mal diff --git a/impls/fantom/Makefile b/impls/fantom/Makefile index 2b95720ab0..03d5351709 100644 --- a/impls/fantom/Makefile +++ b/impls/fantom/Makefile @@ -1,18 +1,18 @@ -all: dist - -dist: lib/fan/mal.pod - -lib/fan: - mkdir -p $@ - -lib/fan/mal.pod: lib/fan/stepA_mal.pod - cp -a $< $@ - -lib/fan/step%.pod: src/step%/build.fan src/step%/fan/*.fan lib/fan/mallib.pod - FAN_ENV=util::PathEnv FAN_ENV_PATH=. fan $< - -lib/fan/mallib.pod: src/mallib/build.fan src/mallib/fan/*.fan lib/fan - FAN_ENV=util::PathEnv FAN_ENV_PATH=. fan $< - -clean: - rm -rf lib +all: dist + +dist: lib/fan/mal.pod + +lib/fan: + mkdir -p $@ + +lib/fan/mal.pod: lib/fan/stepA_mal.pod + cp -a $< $@ + +lib/fan/step%.pod: src/step%/build.fan src/step%/fan/*.fan lib/fan/mallib.pod + FAN_ENV=util::PathEnv FAN_ENV_PATH=. fan $< + +lib/fan/mallib.pod: src/mallib/build.fan src/mallib/fan/*.fan lib/fan + FAN_ENV=util::PathEnv FAN_ENV_PATH=. fan $< + +clean: + rm -rf lib diff --git a/impls/fantom/run b/impls/fantom/run index 3d75d6e53a..934fedd353 100755 --- a/impls/fantom/run +++ b/impls/fantom/run @@ -1,4 +1,4 @@ -#!/bin/bash -export FAN_ENV=util::PathEnv -export FAN_ENV_PATH="$(dirname $0)" -exec fan ${STEP:-stepA_mal} "$@" +#!/bin/bash +export FAN_ENV=util::PathEnv +export FAN_ENV_PATH="$(dirname $0)" +exec fan ${STEP:-stepA_mal} "$@" diff --git a/impls/fantom/src/mallib/build.fan b/impls/fantom/src/mallib/build.fan index 275b9daf95..c1c2600b1d 100644 --- a/impls/fantom/src/mallib/build.fan +++ b/impls/fantom/src/mallib/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "mallib" - summary = "mal library pod" - depends = ["sys 1.0", "compiler 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "mallib" + summary = "mal library pod" + depends = ["sys 1.0", "compiler 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/mallib/fan/core.fan b/impls/fantom/src/mallib/fan/core.fan index 6ec77464f1..7fcb9d715f 100644 --- a/impls/fantom/src/mallib/fan/core.fan +++ b/impls/fantom/src/mallib/fan/core.fan @@ -1,118 +1,118 @@ -class Core -{ - static private MalVal prn(MalVal[] a) - { - echo(a.join(" ") { it.toString(true) }) - return MalNil.INSTANCE - } - - static private MalVal println(MalVal[] a) - { - echo(a.join(" ") { it.toString(false) }) - return MalNil.INSTANCE - } - - static private MalVal readline(MalVal[] a) - { - line := Env.cur.prompt((a[0] as MalString).value) - return line == null ? MalNil.INSTANCE : MalString.make(line) - } - - static private MalVal concat(MalVal[] a) - { - return MalList(a.reduce(MalVal[,]) |MalVal[] r, MalSeq v -> MalVal[]| { r.addAll(v.value) }) - } - - static private MalVal apply(MalVal[] a) - { - f := a[0] as MalFunc - args := a[1..-2] - args.addAll(((MalSeq)a[-1]).value) - return f.call(args) - } - - static private MalVal swap_bang(MalVal[] a) - { - atom := a[0] as MalAtom - MalVal[] args := [atom.value] - args.addAll(a[2..-1]) - f := a[1] as MalFunc - return atom.set(f.call(args)) - } - - static Str:MalFunc ns() - { - return [ - "=": MalFunc { MalTypes.toMalBool(it[0] == it[1]) }, - "throw": MalFunc { throw MalException(it[0]) }, - - "nil?": MalFunc { MalTypes.toMalBool(it[0] is MalNil) }, - "true?": MalFunc { MalTypes.toMalBool(it[0] is MalTrue) }, - "false?": MalFunc { MalTypes.toMalBool(it[0] is MalFalse) }, - "string?": MalFunc { MalTypes.toMalBool(it[0] is MalString && !((MalString)it[0]).isKeyword) }, - "symbol": MalFunc { MalSymbol.makeFromVal(it[0]) }, - "symbol?": MalFunc { MalTypes.toMalBool(it[0] is MalSymbol) }, - "keyword": MalFunc { MalString.makeKeyword((it[0] as MalString).value) }, - "keyword?": MalFunc { MalTypes.toMalBool(it[0] is MalString && ((MalString)it[0]).isKeyword) }, - "number?": MalFunc { MalTypes.toMalBool(it[0] is MalInteger) }, - "fn?": MalFunc { MalTypes.toMalBool(it[0] is MalFunc && !((it[0] as MalUserFunc)?->isMacro ?: false)) }, - "macro?": MalFunc { MalTypes.toMalBool(it[0] is MalUserFunc && ((MalUserFunc)it[0]).isMacro) }, - - "pr-str": MalFunc { MalString.make(it.join(" ") |MalVal e -> Str| { e.toString(true) }) }, - "str": MalFunc { MalString.make(it.join("") |MalVal e -> Str| { e.toString(false) }) }, - "prn": MalFunc(#prn.func), - "println": MalFunc(#println.func), - "read-string": MalFunc { Reader.read_str((it[0] as MalString).value) }, - "readline": MalFunc(#readline.func), - "slurp": MalFunc { MalString.make(File((it[0] as MalString).value.toUri).readAllStr) }, - - "<": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value < (it[1] as MalInteger).value) }, - "<=": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value <= (it[1] as MalInteger).value) }, - ">": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value > (it[1] as MalInteger).value) }, - ">=": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value >= (it[1] as MalInteger).value) }, - "+": MalFunc { MalInteger((it[0] as MalInteger).value + (it[1] as MalInteger).value) }, - "-": MalFunc { MalInteger((it[0] as MalInteger).value - (it[1] as MalInteger).value) }, - "*": MalFunc { MalInteger((it[0] as MalInteger).value * (it[1] as MalInteger).value) }, - "/": MalFunc { MalInteger((it[0] as MalInteger).value / (it[1] as MalInteger).value) }, - "time-ms": MalFunc { MalInteger(DateTime.nowTicks / 1000000) }, - - "list": MalFunc { MalList(it) }, - "list?": MalFunc { MalTypes.toMalBool(it[0] is MalList) }, - "vector": MalFunc { MalVector(it) }, - "vector?": MalFunc { MalTypes.toMalBool(it[0] is MalVector) }, - "hash-map": MalFunc { MalHashMap.fromList(it) }, - "map?": MalFunc { MalTypes.toMalBool(it[0] is MalHashMap) }, - "assoc": MalFunc { (it[0] as MalHashMap).assoc(it[1..-1]) }, - "dissoc": MalFunc { (it[0] as MalHashMap).dissoc(it[1..-1]) }, - "get": MalFunc { it[0] is MalNil ? MalNil.INSTANCE : (it[0] as MalHashMap).get2((MalString)it[1], MalNil.INSTANCE) }, - "contains?": MalFunc { MalTypes.toMalBool((it[0] as MalHashMap).containsKey((MalString)it[1])) }, - "keys": MalFunc { MalList((it[0] as MalHashMap).keys) }, - "vals": MalFunc { MalList((it[0] as MalHashMap).vals) }, - - "sequential?": MalFunc { MalTypes.toMalBool(it[0] is MalSeq) }, - "cons": MalFunc { MalList([it[0]].addAll((it[1] as MalSeq).value)) }, - "concat": MalFunc(#concat.func), - "vec": MalFunc { MalVector((it[0] as MalSeq).value) }, - "nth": MalFunc { (it[0] as MalSeq).nth((it[1] as MalInteger).value) }, - "first": MalFunc { (it[0] as MalSeq)?.first ?: MalNil.INSTANCE }, - "rest": MalFunc { (it[0] as MalSeq)?.rest ?: MalList([,]) }, - "empty?": MalFunc { MalTypes.toMalBool((it[0] as MalSeq).isEmpty) }, - "count": MalFunc { MalInteger(it[0].count) }, - "apply": MalFunc(#apply.func), - "map": MalFunc { (it[1] as MalSeq).map(it[0]) }, - - "conj": MalFunc { (it[0] as MalSeq).conj(it[1..-1]) }, - "seq": MalFunc { it[0].seq }, - - "meta": MalFunc { it[0].meta() }, - "with-meta": MalFunc { it[0].with_meta(it[1]) }, - "atom": MalFunc { MalAtom(it[0]) }, - "atom?": MalFunc { MalTypes.toMalBool(it[0] is MalAtom) }, - "deref": MalFunc { (it[0] as MalAtom).value }, - "reset!": MalFunc { (it[0] as MalAtom).set(it[1]) }, - "swap!": MalFunc(#swap_bang.func), - - "fantom-eval": MalFunc { Interop.fantomEvaluate((it[0] as MalString).value) } - ] - } -} +class Core +{ + static private MalVal prn(MalVal[] a) + { + echo(a.join(" ") { it.toString(true) }) + return MalNil.INSTANCE + } + + static private MalVal println(MalVal[] a) + { + echo(a.join(" ") { it.toString(false) }) + return MalNil.INSTANCE + } + + static private MalVal readline(MalVal[] a) + { + line := Env.cur.prompt((a[0] as MalString).value) + return line == null ? MalNil.INSTANCE : MalString.make(line) + } + + static private MalVal concat(MalVal[] a) + { + return MalList(a.reduce(MalVal[,]) |MalVal[] r, MalSeq v -> MalVal[]| { r.addAll(v.value) }) + } + + static private MalVal apply(MalVal[] a) + { + f := a[0] as MalFunc + args := a[1..-2] + args.addAll(((MalSeq)a[-1]).value) + return f.call(args) + } + + static private MalVal swap_bang(MalVal[] a) + { + atom := a[0] as MalAtom + MalVal[] args := [atom.value] + args.addAll(a[2..-1]) + f := a[1] as MalFunc + return atom.set(f.call(args)) + } + + static Str:MalFunc ns() + { + return [ + "=": MalFunc { MalTypes.toMalBool(it[0] == it[1]) }, + "throw": MalFunc { throw MalException(it[0]) }, + + "nil?": MalFunc { MalTypes.toMalBool(it[0] is MalNil) }, + "true?": MalFunc { MalTypes.toMalBool(it[0] is MalTrue) }, + "false?": MalFunc { MalTypes.toMalBool(it[0] is MalFalse) }, + "string?": MalFunc { MalTypes.toMalBool(it[0] is MalString && !((MalString)it[0]).isKeyword) }, + "symbol": MalFunc { MalSymbol.makeFromVal(it[0]) }, + "symbol?": MalFunc { MalTypes.toMalBool(it[0] is MalSymbol) }, + "keyword": MalFunc { MalString.makeKeyword((it[0] as MalString).value) }, + "keyword?": MalFunc { MalTypes.toMalBool(it[0] is MalString && ((MalString)it[0]).isKeyword) }, + "number?": MalFunc { MalTypes.toMalBool(it[0] is MalInteger) }, + "fn?": MalFunc { MalTypes.toMalBool(it[0] is MalFunc && !((it[0] as MalUserFunc)?->isMacro ?: false)) }, + "macro?": MalFunc { MalTypes.toMalBool(it[0] is MalUserFunc && ((MalUserFunc)it[0]).isMacro) }, + + "pr-str": MalFunc { MalString.make(it.join(" ") |MalVal e -> Str| { e.toString(true) }) }, + "str": MalFunc { MalString.make(it.join("") |MalVal e -> Str| { e.toString(false) }) }, + "prn": MalFunc(#prn.func), + "println": MalFunc(#println.func), + "read-string": MalFunc { Reader.read_str((it[0] as MalString).value) }, + "readline": MalFunc(#readline.func), + "slurp": MalFunc { MalString.make(File((it[0] as MalString).value.toUri).readAllStr) }, + + "<": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value < (it[1] as MalInteger).value) }, + "<=": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value <= (it[1] as MalInteger).value) }, + ">": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value > (it[1] as MalInteger).value) }, + ">=": MalFunc { MalTypes.toMalBool((it[0] as MalInteger).value >= (it[1] as MalInteger).value) }, + "+": MalFunc { MalInteger((it[0] as MalInteger).value + (it[1] as MalInteger).value) }, + "-": MalFunc { MalInteger((it[0] as MalInteger).value - (it[1] as MalInteger).value) }, + "*": MalFunc { MalInteger((it[0] as MalInteger).value * (it[1] as MalInteger).value) }, + "/": MalFunc { MalInteger((it[0] as MalInteger).value / (it[1] as MalInteger).value) }, + "time-ms": MalFunc { MalInteger(DateTime.nowTicks / 1000000) }, + + "list": MalFunc { MalList(it) }, + "list?": MalFunc { MalTypes.toMalBool(it[0] is MalList) }, + "vector": MalFunc { MalVector(it) }, + "vector?": MalFunc { MalTypes.toMalBool(it[0] is MalVector) }, + "hash-map": MalFunc { MalHashMap.fromList(it) }, + "map?": MalFunc { MalTypes.toMalBool(it[0] is MalHashMap) }, + "assoc": MalFunc { (it[0] as MalHashMap).assoc(it[1..-1]) }, + "dissoc": MalFunc { (it[0] as MalHashMap).dissoc(it[1..-1]) }, + "get": MalFunc { it[0] is MalNil ? MalNil.INSTANCE : (it[0] as MalHashMap).get2((MalString)it[1], MalNil.INSTANCE) }, + "contains?": MalFunc { MalTypes.toMalBool((it[0] as MalHashMap).containsKey((MalString)it[1])) }, + "keys": MalFunc { MalList((it[0] as MalHashMap).keys) }, + "vals": MalFunc { MalList((it[0] as MalHashMap).vals) }, + + "sequential?": MalFunc { MalTypes.toMalBool(it[0] is MalSeq) }, + "cons": MalFunc { MalList([it[0]].addAll((it[1] as MalSeq).value)) }, + "concat": MalFunc(#concat.func), + "vec": MalFunc { MalVector((it[0] as MalSeq).value) }, + "nth": MalFunc { (it[0] as MalSeq).nth((it[1] as MalInteger).value) }, + "first": MalFunc { (it[0] as MalSeq)?.first ?: MalNil.INSTANCE }, + "rest": MalFunc { (it[0] as MalSeq)?.rest ?: MalList([,]) }, + "empty?": MalFunc { MalTypes.toMalBool((it[0] as MalSeq).isEmpty) }, + "count": MalFunc { MalInteger(it[0].count) }, + "apply": MalFunc(#apply.func), + "map": MalFunc { (it[1] as MalSeq).map(it[0]) }, + + "conj": MalFunc { (it[0] as MalSeq).conj(it[1..-1]) }, + "seq": MalFunc { it[0].seq }, + + "meta": MalFunc { it[0].meta() }, + "with-meta": MalFunc { it[0].with_meta(it[1]) }, + "atom": MalFunc { MalAtom(it[0]) }, + "atom?": MalFunc { MalTypes.toMalBool(it[0] is MalAtom) }, + "deref": MalFunc { (it[0] as MalAtom).value }, + "reset!": MalFunc { (it[0] as MalAtom).set(it[1]) }, + "swap!": MalFunc(#swap_bang.func), + + "fantom-eval": MalFunc { Interop.fantomEvaluate((it[0] as MalString).value) } + ] + } +} diff --git a/impls/fantom/src/mallib/fan/env.fan b/impls/fantom/src/mallib/fan/env.fan index 644c181470..c2350d6498 100644 --- a/impls/fantom/src/mallib/fan/env.fan +++ b/impls/fantom/src/mallib/fan/env.fan @@ -1,40 +1,40 @@ -class MalEnv -{ - private Str:MalVal data := [:] - private MalEnv? outer - - new make(MalEnv? outer := null, MalSeq? binds := null, MalSeq? exprs := null) - { - this.outer = outer - if (binds != null && exprs != null) - { - for (i := 0; i < binds.count; i++) - { - if ((binds[i] as MalSymbol).value == "&") - { - set(binds[i + 1], MalList(exprs[i..-1])) - break - } - else - set(binds[i], exprs[i]) - } - } - } - - MalVal set(MalSymbol key, MalVal value) - { - data[key.value] = value - return value - } - - MalEnv? find(MalSymbol key) - { - return data.containsKey(key.value) ? this : outer?.find(key) - } - - MalVal get(MalSymbol key) - { - foundEnv := find(key) ?: throw Err("'$key.value' not found") - return (MalVal)foundEnv.data[key.value] - } -} +class MalEnv +{ + private Str:MalVal data := [:] + private MalEnv? outer + + new make(MalEnv? outer := null, MalSeq? binds := null, MalSeq? exprs := null) + { + this.outer = outer + if (binds != null && exprs != null) + { + for (i := 0; i < binds.count; i++) + { + if ((binds[i] as MalSymbol).value == "&") + { + set(binds[i + 1], MalList(exprs[i..-1])) + break + } + else + set(binds[i], exprs[i]) + } + } + } + + MalVal set(MalSymbol key, MalVal value) + { + data[key.value] = value + return value + } + + MalEnv? find(MalSymbol key) + { + return data.containsKey(key.value) ? this : outer?.find(key) + } + + MalVal get(MalSymbol key) + { + foundEnv := find(key) ?: throw Err("'$key.value' not found") + return (MalVal)foundEnv.data[key.value] + } +} diff --git a/impls/fantom/src/mallib/fan/interop.fan b/impls/fantom/src/mallib/fan/interop.fan index 3dd7ce5422..c1bc8123ae 100644 --- a/impls/fantom/src/mallib/fan/interop.fan +++ b/impls/fantom/src/mallib/fan/interop.fan @@ -1,65 +1,65 @@ -using compiler - -internal class Interop -{ - static Pod? compile(Str innerBody) - { - ci := CompilerInput - { - podName = "mal_fantom_interop_${DateTime.nowUnique}" - summary = "" - isScript = true - version = Version.defVal - log.level = LogLevel.silent - output = CompilerOutputMode.transientPod - mode = CompilerInputMode.str - srcStr = "class InteropDummyClass {\nstatic Obj? _evalfunc() {\n $innerBody \n}\n}" - srcStrLoc = Loc("mal_fantom_interop") - } - try - return Compiler(ci).compile.transientPod - catch (CompilerErr e) - return null - } - - static Obj? evaluate(Str line) - { - p := compile(line) - if (p == null) - p = compile("return $line") - if (p == null) - p = compile("$line\nreturn null") - if (p == null) - return null - method := p.types.first.method("_evalfunc") - try - return method.call() - catch (Err e) - return null - } - - static MalVal fantomToMal(Obj? obj) - { - if (obj == null) - return MalNil.INSTANCE - else if (obj is Bool) - return MalTypes.toMalBool((Bool)obj) - else if (obj is Int) - return MalInteger((Int)obj) - else if (obj is List) - return MalList((obj as List).map |Obj? e -> MalVal| { fantomToMal(e) }) - else if (obj is Map) - { - m := [Str:MalVal][:] - (obj as Map).each |v, k| { m.set(k.toStr, fantomToMal(v)) } - return MalHashMap.fromMap(m) - } - else - return MalString.make(obj.toStr) - } - - static MalVal fantomEvaluate(Str line) - { - return fantomToMal(evaluate(line)) - } -} +using compiler + +internal class Interop +{ + static Pod? compile(Str innerBody) + { + ci := CompilerInput + { + podName = "mal_fantom_interop_${DateTime.nowUnique}" + summary = "" + isScript = true + version = Version.defVal + log.level = LogLevel.silent + output = CompilerOutputMode.transientPod + mode = CompilerInputMode.str + srcStr = "class InteropDummyClass {\nstatic Obj? _evalfunc() {\n $innerBody \n}\n}" + srcStrLoc = Loc("mal_fantom_interop") + } + try + return Compiler(ci).compile.transientPod + catch (CompilerErr e) + return null + } + + static Obj? evaluate(Str line) + { + p := compile(line) + if (p == null) + p = compile("return $line") + if (p == null) + p = compile("$line\nreturn null") + if (p == null) + return null + method := p.types.first.method("_evalfunc") + try + return method.call() + catch (Err e) + return null + } + + static MalVal fantomToMal(Obj? obj) + { + if (obj == null) + return MalNil.INSTANCE + else if (obj is Bool) + return MalTypes.toMalBool((Bool)obj) + else if (obj is Int) + return MalInteger((Int)obj) + else if (obj is List) + return MalList((obj as List).map |Obj? e -> MalVal| { fantomToMal(e) }) + else if (obj is Map) + { + m := [Str:MalVal][:] + (obj as Map).each |v, k| { m.set(k.toStr, fantomToMal(v)) } + return MalHashMap.fromMap(m) + } + else + return MalString.make(obj.toStr) + } + + static MalVal fantomEvaluate(Str line) + { + return fantomToMal(evaluate(line)) + } +} diff --git a/impls/fantom/src/mallib/fan/reader.fan b/impls/fantom/src/mallib/fan/reader.fan index 98de61c55e..d57fee3c11 100644 --- a/impls/fantom/src/mallib/fan/reader.fan +++ b/impls/fantom/src/mallib/fan/reader.fan @@ -1,108 +1,108 @@ -internal class TokenReader -{ - const Str[] tokens - private Int position := 0 - - new make(Str[] new_tokens) { tokens = new_tokens } - - Str? peek() - { - if (position >= tokens.size) return null - return tokens[position] - } - - Str next() { return tokens[position++] } -} - -class Reader -{ - private static Str[] tokenize(Str s) - { - r := Regex <|[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)|> - m := r.matcher(s) - tokens := Str[,] - while (m.find()) - { - token := m.group(1) - if (token.isEmpty || token[0] == ';') continue - tokens.add(m.group(1)) - } - return tokens - } - - private static Str unescape_str(Str s) - { - return s.replace("\\\\", "\u029e").replace("\\\"", "\"").replace("\\n", "\n").replace("\u029e", "\\") - } - - private static MalVal read_atom(TokenReader reader) - { - token := reader.next - intRegex := Regex <|^-?\d+$|> - strRegex := Regex <|^"(?:\\.|[^\\"])*"|> - strBadRegex := Regex <|^".*|> - if (token == "nil") return MalNil.INSTANCE - if (token == "true") return MalTrue.INSTANCE - if (token == "false") return MalFalse.INSTANCE - if (intRegex.matches(token)) return MalInteger(token.toInt) - if (strRegex.matches(token)) return MalString.make(unescape_str(token[1..-2])) - if (strBadRegex.matches(token)) throw Err("expected '\"', got EOF") - if (token[0] == '"') return MalString.make(unescape_str(token[1..-2])) - if (token[0] == ':') return MalString.makeKeyword(token[1..-1]) - return MalSymbol(token) - } - - private static MalVal[] read_seq(TokenReader reader, Str open, Str close) - { - reader.next - values := MalVal[,] - token := reader.peek - while (token != close) - { - if (token == null) throw Err("expected '$close', got EOF") - values.add(read_form(reader)) - token = reader.peek - } - if (token != close) throw Err("Missing '$close'") - reader.next - return values - } - - private static MalVal read_form(TokenReader reader) - { - switch (reader.peek) - { - case "\'": - reader.next - return MalList([MalSymbol("quote"), read_form(reader)]) - case "`": - reader.next - return MalList([MalSymbol("quasiquote"), read_form(reader)]) - case "~": - reader.next - return MalList([MalSymbol("unquote"), read_form(reader)]) - case "~@": - reader.next - return MalList([MalSymbol("splice-unquote"), read_form(reader)]) - case "^": - reader.next - meta := read_form(reader) - return MalList([MalSymbol("with-meta"), read_form(reader), meta]) - case "@": - reader.next - return MalList([MalSymbol("deref"), read_form(reader)]) - case "(": return MalList(read_seq(reader, "(", ")")) - case ")": throw Err("unexpected ')'") - case "[": return MalVector(read_seq(reader, "[", "]")) - case "]": throw Err("unexpected ']'") - case "{": return MalHashMap.fromList(read_seq(reader, "{", "}")) - case "}": throw Err("unexpected '}'") - default: return read_atom(reader) - } - } - - static MalVal read_str(Str s) - { - return read_form(TokenReader(tokenize(s))); - } -} +internal class TokenReader +{ + const Str[] tokens + private Int position := 0 + + new make(Str[] new_tokens) { tokens = new_tokens } + + Str? peek() + { + if (position >= tokens.size) return null + return tokens[position] + } + + Str next() { return tokens[position++] } +} + +class Reader +{ + private static Str[] tokenize(Str s) + { + r := Regex <|[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)|> + m := r.matcher(s) + tokens := Str[,] + while (m.find()) + { + token := m.group(1) + if (token.isEmpty || token[0] == ';') continue + tokens.add(m.group(1)) + } + return tokens + } + + private static Str unescape_str(Str s) + { + return s.replace("\\\\", "\u029e").replace("\\\"", "\"").replace("\\n", "\n").replace("\u029e", "\\") + } + + private static MalVal read_atom(TokenReader reader) + { + token := reader.next + intRegex := Regex <|^-?\d+$|> + strRegex := Regex <|^"(?:\\.|[^\\"])*"|> + strBadRegex := Regex <|^".*|> + if (token == "nil") return MalNil.INSTANCE + if (token == "true") return MalTrue.INSTANCE + if (token == "false") return MalFalse.INSTANCE + if (intRegex.matches(token)) return MalInteger(token.toInt) + if (strRegex.matches(token)) return MalString.make(unescape_str(token[1..-2])) + if (strBadRegex.matches(token)) throw Err("expected '\"', got EOF") + if (token[0] == '"') return MalString.make(unescape_str(token[1..-2])) + if (token[0] == ':') return MalString.makeKeyword(token[1..-1]) + return MalSymbol(token) + } + + private static MalVal[] read_seq(TokenReader reader, Str open, Str close) + { + reader.next + values := MalVal[,] + token := reader.peek + while (token != close) + { + if (token == null) throw Err("expected '$close', got EOF") + values.add(read_form(reader)) + token = reader.peek + } + if (token != close) throw Err("Missing '$close'") + reader.next + return values + } + + private static MalVal read_form(TokenReader reader) + { + switch (reader.peek) + { + case "\'": + reader.next + return MalList([MalSymbol("quote"), read_form(reader)]) + case "`": + reader.next + return MalList([MalSymbol("quasiquote"), read_form(reader)]) + case "~": + reader.next + return MalList([MalSymbol("unquote"), read_form(reader)]) + case "~@": + reader.next + return MalList([MalSymbol("splice-unquote"), read_form(reader)]) + case "^": + reader.next + meta := read_form(reader) + return MalList([MalSymbol("with-meta"), read_form(reader), meta]) + case "@": + reader.next + return MalList([MalSymbol("deref"), read_form(reader)]) + case "(": return MalList(read_seq(reader, "(", ")")) + case ")": throw Err("unexpected ')'") + case "[": return MalVector(read_seq(reader, "[", "]")) + case "]": throw Err("unexpected ']'") + case "{": return MalHashMap.fromList(read_seq(reader, "{", "}")) + case "}": throw Err("unexpected '}'") + default: return read_atom(reader) + } + } + + static MalVal read_str(Str s) + { + return read_form(TokenReader(tokenize(s))); + } +} diff --git a/impls/fantom/src/mallib/fan/types.fan b/impls/fantom/src/mallib/fan/types.fan index 936070e99b..a066551bd1 100644 --- a/impls/fantom/src/mallib/fan/types.fan +++ b/impls/fantom/src/mallib/fan/types.fan @@ -1,234 +1,234 @@ -mixin MalVal -{ - virtual Str toString(Bool readable) { return toStr } - virtual Int count() { throw Err("count not implemented") } - virtual MalVal seq() { throw Err("seq not implemented") } - abstract MalVal meta() - abstract MalVal with_meta(MalVal newMeta) -} - -const mixin MalValNoMeta : MalVal -{ - override MalVal meta() { return MalNil.INSTANCE } - override MalVal with_meta(MalVal newMeta) { return this } -} - -const mixin MalFalseyVal -{ -} - -const class MalNil : MalValNoMeta, MalFalseyVal -{ - static const MalNil INSTANCE := MalNil() - override Bool equals(Obj? that) { return that is MalNil } - override Str toString(Bool readable) { return "nil" } - override Int count() { return 0 } - override MalVal seq() { return this } -} - -const class MalTrue : MalValNoMeta -{ - static const MalTrue INSTANCE := MalTrue() - override Bool equals(Obj? that) { return that is MalTrue } - override Str toString(Bool readable) { return "true" } -} - -const class MalFalse : MalValNoMeta, MalFalseyVal -{ - static const MalFalse INSTANCE := MalFalse() - override Bool equals(Obj? that) { return that is MalFalse } - override Str toString(Bool readable) { return "false" } -} - -const class MalInteger : MalValNoMeta -{ - const Int value - new make(Int v) { value = v } - override Bool equals(Obj? that) { return that is MalInteger && (that as MalInteger).value == value } - override Str toString(Bool readable) { return value.toStr } -} - -abstract class MalValBase : MalVal -{ - private MalVal? metaVal := null - override Str toString(Bool readable) { return toStr } - override Int count() { throw Err("count not implemented") } - override MalVal seq() { throw Err("seq not implemented") } - abstract This dup() - override MalVal meta() { return metaVal ?: MalNil.INSTANCE } - override MalVal with_meta(MalVal newMeta) - { - v := dup - v.metaVal = newMeta - return v - } -} - -class MalSymbol : MalValBase -{ - const Str value - new make(Str v) { value = v } - new makeFromVal(MalVal v) - { - if (v is MalSymbol) return v - value = (v as MalString).value - } - override Bool equals(Obj? that) { return that is MalSymbol && (that as MalSymbol).value == value } - override Str toString(Bool readable) { return value } - override This dup() { return make(value) } -} - -class MalString : MalValBase -{ - const Str value - new make(Str v) { value = v } - new makeKeyword(Str v) { value = v[0] == '\u029e' ? v : "\u029e$v" } - override Bool equals(Obj? that) { return that is MalString && (that as MalString).value == value } - override Str toString(Bool readable) - { - if (isKeyword) return ":${value[1..-1]}" - if (readable) - return "\"${escapeStr(value)}\"" - else - return value - } - Bool isKeyword() { return !value.isEmpty && value[0] == '\u029e' } - static Str escapeStr(Str s) - { - return s.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n") - } - override MalVal seq() - { - if (value.size == 0) return MalNil.INSTANCE - return MalList(value.chars.map |Int c -> MalString| { MalString.make(Str.fromChars([c])) }) - } - override This dup() { return make(value) } -} - -abstract class MalSeq : MalValBase -{ - MalVal[] value { protected set } - new make(MalVal[] v) { value = v.ro } - override Bool equals(Obj? that) { return that is MalSeq && (that as MalSeq).value == value } - Bool isEmpty() { return value.isEmpty } - override Int count() { return value.size } - @Operator MalVal get(Int index) { return value[index] } - @Operator MalVal[] getRange(Range range) { return value[range] } - protected Str serialize(Bool readable) { return value.join(" ") { it.toString(readable) } } - abstract MalSeq drop(Int n) - MalVal nth(Int index) { return index < count ? get(index) : throw Err("nth: index out of range") } - MalVal first() { return isEmpty ? MalNil.INSTANCE : value[0] } - MalList rest() { return MalList(isEmpty ? [,] : value[1..-1]) } - MalList map(MalFunc f) { return MalList(value.map |MalVal v -> MalVal| { f.call([v]) } ) } - abstract MalSeq conj(MalVal[] args) -} - -class MalList : MalSeq -{ - new make(MalVal[] v) : super.make(v) {} - override Str toString(Bool readable) { return "(${serialize(readable)})" } - override MalList drop(Int n) { return make(value[n..-1]) } - override MalVal seq() { return isEmpty ? MalNil.INSTANCE : this } - override MalList conj(MalVal[] args) { return MalList(value.rw.insertAll(0, args.reverse)) } - override This dup() { return make(value) } -} - -class MalVector : MalSeq -{ - new make(MalVal[] v) : super.make(v) {} - override Str toString(Bool readable) { return "[${serialize(readable)}]" } - override MalVector drop(Int n) { return make(value[n..-1]) } - override MalVal seq() { return isEmpty ? MalNil.INSTANCE : MalList(value) } - override MalVector conj(MalVal[] args) { return MalVector(value.rw.addAll(args)) } - override This dup() { return make(value) } -} - -class MalHashMap : MalValBase -{ - Str:MalVal value { private set } - new fromList(MalVal[] lst) { - m := [Str:MalVal][:] - for (i := 0; i < lst.size; i += 2) - m.add((lst[i] as MalString).value, (MalVal)lst[i + 1]) - value = m.ro - } - new fromMap(Str:MalVal m) { value = m.ro } - override Bool equals(Obj? that) { return that is MalHashMap && (that as MalHashMap).value == value } - override Str toString(Bool readable) - { - elements := Str[,] - value.each(|MalVal v, Str k| { elements.add(MalString.make(k).toString(readable)); elements.add(v.toString(readable)) }) - s := elements.join(" ") - return "{$s}" - } - override Int count() { return value.size } - @Operator MalVal get(Str key) { return value[key] } - MalVal get2(MalString key, MalVal? def := null) { return value.get(key.value, def) } - Bool containsKey(MalString key) { return value.containsKey(key.value) } - MalVal[] keys() { return value.keys.map |Str k -> MalVal| { MalString.make(k) } } - MalVal[] vals() { return value.vals } - MalHashMap assoc(MalVal[] args) - { - newValue := value.dup - for (i := 0; i < args.size; i += 2) - newValue.set((args[i] as MalString).value, args[i + 1]) - return fromMap(newValue) - } - MalHashMap dissoc(MalVal[] args) - { - newValue := value.dup - args.each { newValue.remove((it as MalString).value) } - return fromMap(newValue) - } - override This dup() { return fromMap(value) } -} - -class MalFunc : MalValBase -{ - protected |MalVal[] a -> MalVal| f - new make(|MalVal[] a -> MalVal| func) { f = func } - MalVal call(MalVal[] a) { return f(a) } - override Str toString(Bool readable) { return "" } - override This dup() { return make(f) } -} - -class MalUserFunc : MalFunc -{ - MalVal ast { private set } - private MalEnv env - private MalSeq params - Bool isMacro := false - new make(MalVal ast, MalEnv env, MalSeq params, |MalVal[] a -> MalVal| func, Bool isMacro := false) : super.make(func) - { - this.ast = ast - this.env = env - this.params = params - this.isMacro = isMacro - } - MalEnv genEnv(MalSeq args) { return MalEnv(env, params, args) } - override Str toString(Bool readable) { return "" } - override This dup() { return make(ast, env, params, f, isMacro) } -} - -class MalAtom : MalValBase -{ - MalVal value - new make(MalVal v) { value = v } - override Str toString(Bool readable) { return "(atom ${value.toString(readable)})" } - override Bool equals(Obj? that) { return that is MalAtom && (that as MalAtom).value == value } - MalVal set(MalVal v) { value = v; return value } - override This dup() { return make(value) } -} - -class MalTypes -{ - static MalVal toMalBool(Bool cond) { return cond ? MalTrue.INSTANCE : MalFalse.INSTANCE } - static Bool isPair(MalVal a) { return a is MalSeq && !(a as MalSeq).isEmpty } -} - -const class MalException : Err -{ - const Str serializedValue - new make(MalVal v) : super.make("Mal exception") { serializedValue = v.toString(true) } - MalVal getValue() { return Reader.read_str(serializedValue) } -} +mixin MalVal +{ + virtual Str toString(Bool readable) { return toStr } + virtual Int count() { throw Err("count not implemented") } + virtual MalVal seq() { throw Err("seq not implemented") } + abstract MalVal meta() + abstract MalVal with_meta(MalVal newMeta) +} + +const mixin MalValNoMeta : MalVal +{ + override MalVal meta() { return MalNil.INSTANCE } + override MalVal with_meta(MalVal newMeta) { return this } +} + +const mixin MalFalseyVal +{ +} + +const class MalNil : MalValNoMeta, MalFalseyVal +{ + static const MalNil INSTANCE := MalNil() + override Bool equals(Obj? that) { return that is MalNil } + override Str toString(Bool readable) { return "nil" } + override Int count() { return 0 } + override MalVal seq() { return this } +} + +const class MalTrue : MalValNoMeta +{ + static const MalTrue INSTANCE := MalTrue() + override Bool equals(Obj? that) { return that is MalTrue } + override Str toString(Bool readable) { return "true" } +} + +const class MalFalse : MalValNoMeta, MalFalseyVal +{ + static const MalFalse INSTANCE := MalFalse() + override Bool equals(Obj? that) { return that is MalFalse } + override Str toString(Bool readable) { return "false" } +} + +const class MalInteger : MalValNoMeta +{ + const Int value + new make(Int v) { value = v } + override Bool equals(Obj? that) { return that is MalInteger && (that as MalInteger).value == value } + override Str toString(Bool readable) { return value.toStr } +} + +abstract class MalValBase : MalVal +{ + private MalVal? metaVal := null + override Str toString(Bool readable) { return toStr } + override Int count() { throw Err("count not implemented") } + override MalVal seq() { throw Err("seq not implemented") } + abstract This dup() + override MalVal meta() { return metaVal ?: MalNil.INSTANCE } + override MalVal with_meta(MalVal newMeta) + { + v := dup + v.metaVal = newMeta + return v + } +} + +class MalSymbol : MalValBase +{ + const Str value + new make(Str v) { value = v } + new makeFromVal(MalVal v) + { + if (v is MalSymbol) return v + value = (v as MalString).value + } + override Bool equals(Obj? that) { return that is MalSymbol && (that as MalSymbol).value == value } + override Str toString(Bool readable) { return value } + override This dup() { return make(value) } +} + +class MalString : MalValBase +{ + const Str value + new make(Str v) { value = v } + new makeKeyword(Str v) { value = v[0] == '\u029e' ? v : "\u029e$v" } + override Bool equals(Obj? that) { return that is MalString && (that as MalString).value == value } + override Str toString(Bool readable) + { + if (isKeyword) return ":${value[1..-1]}" + if (readable) + return "\"${escapeStr(value)}\"" + else + return value + } + Bool isKeyword() { return !value.isEmpty && value[0] == '\u029e' } + static Str escapeStr(Str s) + { + return s.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n") + } + override MalVal seq() + { + if (value.size == 0) return MalNil.INSTANCE + return MalList(value.chars.map |Int c -> MalString| { MalString.make(Str.fromChars([c])) }) + } + override This dup() { return make(value) } +} + +abstract class MalSeq : MalValBase +{ + MalVal[] value { protected set } + new make(MalVal[] v) { value = v.ro } + override Bool equals(Obj? that) { return that is MalSeq && (that as MalSeq).value == value } + Bool isEmpty() { return value.isEmpty } + override Int count() { return value.size } + @Operator MalVal get(Int index) { return value[index] } + @Operator MalVal[] getRange(Range range) { return value[range] } + protected Str serialize(Bool readable) { return value.join(" ") { it.toString(readable) } } + abstract MalSeq drop(Int n) + MalVal nth(Int index) { return index < count ? get(index) : throw Err("nth: index out of range") } + MalVal first() { return isEmpty ? MalNil.INSTANCE : value[0] } + MalList rest() { return MalList(isEmpty ? [,] : value[1..-1]) } + MalList map(MalFunc f) { return MalList(value.map |MalVal v -> MalVal| { f.call([v]) } ) } + abstract MalSeq conj(MalVal[] args) +} + +class MalList : MalSeq +{ + new make(MalVal[] v) : super.make(v) {} + override Str toString(Bool readable) { return "(${serialize(readable)})" } + override MalList drop(Int n) { return make(value[n..-1]) } + override MalVal seq() { return isEmpty ? MalNil.INSTANCE : this } + override MalList conj(MalVal[] args) { return MalList(value.rw.insertAll(0, args.reverse)) } + override This dup() { return make(value) } +} + +class MalVector : MalSeq +{ + new make(MalVal[] v) : super.make(v) {} + override Str toString(Bool readable) { return "[${serialize(readable)}]" } + override MalVector drop(Int n) { return make(value[n..-1]) } + override MalVal seq() { return isEmpty ? MalNil.INSTANCE : MalList(value) } + override MalVector conj(MalVal[] args) { return MalVector(value.rw.addAll(args)) } + override This dup() { return make(value) } +} + +class MalHashMap : MalValBase +{ + Str:MalVal value { private set } + new fromList(MalVal[] lst) { + m := [Str:MalVal][:] + for (i := 0; i < lst.size; i += 2) + m.add((lst[i] as MalString).value, (MalVal)lst[i + 1]) + value = m.ro + } + new fromMap(Str:MalVal m) { value = m.ro } + override Bool equals(Obj? that) { return that is MalHashMap && (that as MalHashMap).value == value } + override Str toString(Bool readable) + { + elements := Str[,] + value.each(|MalVal v, Str k| { elements.add(MalString.make(k).toString(readable)); elements.add(v.toString(readable)) }) + s := elements.join(" ") + return "{$s}" + } + override Int count() { return value.size } + @Operator MalVal get(Str key) { return value[key] } + MalVal get2(MalString key, MalVal? def := null) { return value.get(key.value, def) } + Bool containsKey(MalString key) { return value.containsKey(key.value) } + MalVal[] keys() { return value.keys.map |Str k -> MalVal| { MalString.make(k) } } + MalVal[] vals() { return value.vals } + MalHashMap assoc(MalVal[] args) + { + newValue := value.dup + for (i := 0; i < args.size; i += 2) + newValue.set((args[i] as MalString).value, args[i + 1]) + return fromMap(newValue) + } + MalHashMap dissoc(MalVal[] args) + { + newValue := value.dup + args.each { newValue.remove((it as MalString).value) } + return fromMap(newValue) + } + override This dup() { return fromMap(value) } +} + +class MalFunc : MalValBase +{ + protected |MalVal[] a -> MalVal| f + new make(|MalVal[] a -> MalVal| func) { f = func } + MalVal call(MalVal[] a) { return f(a) } + override Str toString(Bool readable) { return "" } + override This dup() { return make(f) } +} + +class MalUserFunc : MalFunc +{ + MalVal ast { private set } + private MalEnv env + private MalSeq params + Bool isMacro := false + new make(MalVal ast, MalEnv env, MalSeq params, |MalVal[] a -> MalVal| func, Bool isMacro := false) : super.make(func) + { + this.ast = ast + this.env = env + this.params = params + this.isMacro = isMacro + } + MalEnv genEnv(MalSeq args) { return MalEnv(env, params, args) } + override Str toString(Bool readable) { return "" } + override This dup() { return make(ast, env, params, f, isMacro) } +} + +class MalAtom : MalValBase +{ + MalVal value + new make(MalVal v) { value = v } + override Str toString(Bool readable) { return "(atom ${value.toString(readable)})" } + override Bool equals(Obj? that) { return that is MalAtom && (that as MalAtom).value == value } + MalVal set(MalVal v) { value = v; return value } + override This dup() { return make(value) } +} + +class MalTypes +{ + static MalVal toMalBool(Bool cond) { return cond ? MalTrue.INSTANCE : MalFalse.INSTANCE } + static Bool isPair(MalVal a) { return a is MalSeq && !(a as MalSeq).isEmpty } +} + +const class MalException : Err +{ + const Str serializedValue + new make(MalVal v) : super.make("Mal exception") { serializedValue = v.toString(true) } + MalVal getValue() { return Reader.read_str(serializedValue) } +} diff --git a/impls/fantom/src/step0_repl/build.fan b/impls/fantom/src/step0_repl/build.fan index e16a2a3f8c..eb4b57cc21 100644 --- a/impls/fantom/src/step0_repl/build.fan +++ b/impls/fantom/src/step0_repl/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step0_repl" - summary = "mal step0_repl pod" - depends = ["sys 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step0_repl" + summary = "mal step0_repl pod" + depends = ["sys 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step0_repl/fan/main.fan b/impls/fantom/src/step0_repl/fan/main.fan index efccdebd02..f79d1ff621 100644 --- a/impls/fantom/src/step0_repl/fan/main.fan +++ b/impls/fantom/src/step0_repl/fan/main.fan @@ -1,32 +1,32 @@ -class Main -{ - static Str READ(Str s) - { - return s - } - - static Str EVAL(Str ast, Str env) - { - return ast - } - - static Str PRINT(Str exp) - { - return exp - } - - static Str REP(Str s, Str env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main() - { - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - echo(REP(line, "")) - } - } -} +class Main +{ + static Str READ(Str s) + { + return s + } + + static Str EVAL(Str ast, Str env) + { + return ast + } + + static Str PRINT(Str exp) + { + return exp + } + + static Str REP(Str s, Str env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + echo(REP(line, "")) + } + } +} diff --git a/impls/fantom/src/step1_read_print/build.fan b/impls/fantom/src/step1_read_print/build.fan index 3bb399898f..f83b505bf4 100644 --- a/impls/fantom/src/step1_read_print/build.fan +++ b/impls/fantom/src/step1_read_print/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step1_read_print" - summary = "mal step1_read_print pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step1_read_print" + summary = "mal step1_read_print pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step1_read_print/fan/main.fan b/impls/fantom/src/step1_read_print/fan/main.fan index 5e6f27d95a..581b272d84 100644 --- a/impls/fantom/src/step1_read_print/fan/main.fan +++ b/impls/fantom/src/step1_read_print/fan/main.fan @@ -1,37 +1,37 @@ -using mallib - -class Main -{ - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal EVAL(MalVal ast, Str env) - { - return ast - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, Str env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main() - { - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, "")) - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal EVAL(MalVal ast, Str env) + { + return ast + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, Str env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, "")) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/src/step2_eval/build.fan b/impls/fantom/src/step2_eval/build.fan index 792a7f722e..21ab46c697 100644 --- a/impls/fantom/src/step2_eval/build.fan +++ b/impls/fantom/src/step2_eval/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step2_eval" - summary = "mal step2_eval pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step2_eval" + summary = "mal step2_eval pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step2_eval/fan/main.fan b/impls/fantom/src/step2_eval/fan/main.fan index bf75f9c553..d7ef6c901b 100644 --- a/impls/fantom/src/step2_eval/fan/main.fan +++ b/impls/fantom/src/step2_eval/fan/main.fan @@ -1,70 +1,70 @@ -using mallib - -class Main -{ - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal eval_ast(MalVal ast, Str:MalFunc env) - { - switch (ast.typeof) - { - case MalSymbol#: - varName := (ast as MalSymbol).value - varVal := env[varName] ?: throw Err("'$varName' not found") - return (MalVal)varVal - case MalList#: - newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalList(newElements) - case MalVector#: - newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalVector(newElements) - case MalHashMap#: - newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalHashMap.fromMap(newElements) - default: - return ast - } - } - - static MalVal EVAL(MalVal ast, Str:MalFunc env) - { - if (!(ast is MalList)) return eval_ast(ast, env) - astList := ast as MalList - if (astList.isEmpty) return ast - evaled_ast := eval_ast(ast, env) as MalList - f := evaled_ast[0] as MalFunc - return f.call(evaled_ast[1..-1]) - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, Str:MalFunc env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main() - { - env := [ - "+": MalFunc { MalInteger((it[0] as MalInteger).value + (it[1] as MalInteger).value) }, - "-": MalFunc { MalInteger((it[0] as MalInteger).value - (it[1] as MalInteger).value) }, - "*": MalFunc { MalInteger((it[0] as MalInteger).value * (it[1] as MalInteger).value) }, - "/": MalFunc { MalInteger((it[0] as MalInteger).value / (it[1] as MalInteger).value) } - ] - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, env)) - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, Str:MalFunc env) + { + switch (ast.typeof) + { + case MalSymbol#: + varName := (ast as MalSymbol).value + varVal := env[varName] ?: throw Err("'$varName' not found") + return (MalVal)varVal + case MalList#: + newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, Str:MalFunc env) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + evaled_ast := eval_ast(ast, env) as MalList + f := evaled_ast[0] as MalFunc + return f.call(evaled_ast[1..-1]) + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, Str:MalFunc env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + env := [ + "+": MalFunc { MalInteger((it[0] as MalInteger).value + (it[1] as MalInteger).value) }, + "-": MalFunc { MalInteger((it[0] as MalInteger).value - (it[1] as MalInteger).value) }, + "*": MalFunc { MalInteger((it[0] as MalInteger).value * (it[1] as MalInteger).value) }, + "/": MalFunc { MalInteger((it[0] as MalInteger).value / (it[1] as MalInteger).value) } + ] + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/src/step3_env/build.fan b/impls/fantom/src/step3_env/build.fan index 598092fb24..27e8a0d023 100644 --- a/impls/fantom/src/step3_env/build.fan +++ b/impls/fantom/src/step3_env/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step3_env" - summary = "mal step3_env pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step3_env" + summary = "mal step3_env pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step3_env/fan/main.fan b/impls/fantom/src/step3_env/fan/main.fan index 331c9303f2..ef28dc318a 100644 --- a/impls/fantom/src/step3_env/fan/main.fan +++ b/impls/fantom/src/step3_env/fan/main.fan @@ -1,79 +1,79 @@ -using mallib - -class Main -{ - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal eval_ast(MalVal ast, MalEnv env) - { - switch (ast.typeof) - { - case MalSymbol#: - return env.get(ast) - case MalList#: - newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalList(newElements) - case MalVector#: - newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalVector(newElements) - case MalHashMap#: - newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalHashMap.fromMap(newElements) - default: - return ast - } - } - - static MalVal EVAL(MalVal ast, MalEnv env) - { - if (!(ast is MalList)) return eval_ast(ast, env) - astList := ast as MalList - if (astList.isEmpty) return ast - switch ((astList[0] as MalSymbol).value) - { - case "def!": - return env.set(astList[1], EVAL(astList[2], env)) - case "let*": - let_env := MalEnv(env) - varList := (astList[1] as MalSeq) - for (i := 0; i < varList.count; i += 2) - let_env.set(varList[i], EVAL(varList[i + 1], let_env)) - return EVAL(astList[2], let_env) - default: - evaled_ast := eval_ast(ast, env) as MalList - f := evaled_ast[0] as MalFunc - return f.call(evaled_ast[1..-1]) - } - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, MalEnv env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main() - { - repl_env := MalEnv() - repl_env.set(MalSymbol("+"), MalFunc { MalInteger((it[0] as MalInteger).value + (it[1] as MalInteger).value) }) - repl_env.set(MalSymbol("-"), MalFunc { MalInteger((it[0] as MalInteger).value - (it[1] as MalInteger).value) }) - repl_env.set(MalSymbol("*"), MalFunc { MalInteger((it[0] as MalInteger).value * (it[1] as MalInteger).value) }) - repl_env.set(MalSymbol("/"), MalFunc { MalInteger((it[0] as MalInteger).value / (it[1] as MalInteger).value) }) - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, repl_env)) - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol).value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := (astList[1] as MalSeq) + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + return EVAL(astList[2], let_env) + default: + evaled_ast := eval_ast(ast, env) as MalList + f := evaled_ast[0] as MalFunc + return f.call(evaled_ast[1..-1]) + } + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + repl_env := MalEnv() + repl_env.set(MalSymbol("+"), MalFunc { MalInteger((it[0] as MalInteger).value + (it[1] as MalInteger).value) }) + repl_env.set(MalSymbol("-"), MalFunc { MalInteger((it[0] as MalInteger).value - (it[1] as MalInteger).value) }) + repl_env.set(MalSymbol("*"), MalFunc { MalInteger((it[0] as MalInteger).value * (it[1] as MalInteger).value) }) + repl_env.set(MalSymbol("/"), MalFunc { MalInteger((it[0] as MalInteger).value / (it[1] as MalInteger).value) }) + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/src/step4_if_fn_do/build.fan b/impls/fantom/src/step4_if_fn_do/build.fan index 7cf25b342b..a3147555d9 100644 --- a/impls/fantom/src/step4_if_fn_do/build.fan +++ b/impls/fantom/src/step4_if_fn_do/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step4_if_fn_do" - summary = "mal step4_if_fn_do pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step4_if_fn_do" + summary = "mal step4_if_fn_do pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step4_if_fn_do/fan/main.fan b/impls/fantom/src/step4_if_fn_do/fan/main.fan index f1d7842b67..88a97abc38 100644 --- a/impls/fantom/src/step4_if_fn_do/fan/main.fan +++ b/impls/fantom/src/step4_if_fn_do/fan/main.fan @@ -1,91 +1,91 @@ -using mallib - -class Main -{ - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal eval_ast(MalVal ast, MalEnv env) - { - switch (ast.typeof) - { - case MalSymbol#: - return env.get(ast) - case MalList#: - newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalList(newElements) - case MalVector#: - newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalVector(newElements) - case MalHashMap#: - newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalHashMap.fromMap(newElements) - default: - return ast - } - } - - static MalVal EVAL(MalVal ast, MalEnv env) - { - if (!(ast is MalList)) return eval_ast(ast, env) - astList := ast as MalList - if (astList.isEmpty) return ast - switch ((astList[0] as MalSymbol)?.value) - { - case "def!": - return env.set(astList[1], EVAL(astList[2], env)) - case "let*": - let_env := MalEnv(env) - varList := astList[1] as MalSeq - for (i := 0; i < varList.count; i += 2) - let_env.set(varList[i], EVAL(varList[i + 1], let_env)) - return EVAL(astList[2], let_env) - case "do": - eval_ast(MalList(astList[1..-2]), env) - return EVAL(astList[-1], env) - case "if": - if (EVAL(astList[1], env) is MalFalseyVal) - return astList.count > 3 ? EVAL(astList[3], env) : MalNil.INSTANCE - else - return EVAL(astList[2], env) - case "fn*": - return MalFunc { EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(it))) } - default: - evaled_ast := eval_ast(ast, env) as MalList - f := evaled_ast[0] as MalFunc - return f.call(evaled_ast[1..-1]) - } - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, MalEnv env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main() - { - repl_env := MalEnv() - // core.fan: defined using Fantom - Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, repl_env)) - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + return EVAL(astList[2], let_env) + case "do": + eval_ast(MalList(astList[1..-2]), env) + return EVAL(astList[-1], env) + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + return astList.count > 3 ? EVAL(astList[3], env) : MalNil.INSTANCE + else + return EVAL(astList[2], env) + case "fn*": + return MalFunc { EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(it))) } + default: + evaled_ast := eval_ast(ast, env) as MalList + f := evaled_ast[0] as MalFunc + return f.call(evaled_ast[1..-1]) + } + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/src/step5_tco/build.fan b/impls/fantom/src/step5_tco/build.fan index d96402c8ba..673299ef4b 100644 --- a/impls/fantom/src/step5_tco/build.fan +++ b/impls/fantom/src/step5_tco/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step5_tco" - summary = "mal step5_tco pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step5_tco" + summary = "mal step5_tco pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step5_tco/fan/main.fan b/impls/fantom/src/step5_tco/fan/main.fan index 381c7e2c00..1d4609a173 100644 --- a/impls/fantom/src/step5_tco/fan/main.fan +++ b/impls/fantom/src/step5_tco/fan/main.fan @@ -1,113 +1,113 @@ -using mallib - -class Main -{ - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal eval_ast(MalVal ast, MalEnv env) - { - switch (ast.typeof) - { - case MalSymbol#: - return env.get(ast) - case MalList#: - newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalList(newElements) - case MalVector#: - newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalVector(newElements) - case MalHashMap#: - newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalHashMap.fromMap(newElements) - default: - return ast - } - } - - static MalVal EVAL(MalVal ast, MalEnv env) - { - while (true) - { - if (!(ast is MalList)) return eval_ast(ast, env) - astList := ast as MalList - if (astList.isEmpty) return ast - switch ((astList[0] as MalSymbol)?.value) - { - case "def!": - return env.set(astList[1], EVAL(astList[2], env)) - case "let*": - let_env := MalEnv(env) - varList := astList[1] as MalSeq - for (i := 0; i < varList.count; i += 2) - let_env.set(varList[i], EVAL(varList[i + 1], let_env)) - env = let_env - ast = astList[2] - // TCO - case "do": - eval_ast(MalList(astList[1..-2]), env) - ast = astList[-1] - // TCO - case "if": - if (EVAL(astList[1], env) is MalFalseyVal) - ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE - else - ast = astList[2] - // TCO - case "fn*": - f := |MalVal[] a -> MalVal| - { - return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) - } - return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) - default: - evaled_ast := eval_ast(ast, env) as MalList - switch (evaled_ast[0].typeof) - { - case MalUserFunc#: - user_fn := evaled_ast[0] as MalUserFunc - ast = user_fn.ast - env = user_fn.genEnv(evaled_ast.drop(1)) - // TCO - case MalFunc#: - return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) - default: - throw Err("Unknown type") - } - } - } - return MalNil.INSTANCE // never reached - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, MalEnv env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main() - { - repl_env := MalEnv() - // core.fan: defined using Fantom - Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, repl_env)) - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main() + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/src/step6_file/build.fan b/impls/fantom/src/step6_file/build.fan index 93e255f5f1..9d024b24d0 100644 --- a/impls/fantom/src/step6_file/build.fan +++ b/impls/fantom/src/step6_file/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step6_file" - summary = "mal step6_file pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step6_file" + summary = "mal step6_file pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step6_file/fan/main.fan b/impls/fantom/src/step6_file/fan/main.fan index 31fd25667b..2851aaa723 100644 --- a/impls/fantom/src/step6_file/fan/main.fan +++ b/impls/fantom/src/step6_file/fan/main.fan @@ -1,122 +1,122 @@ -using mallib - -class Main -{ - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal eval_ast(MalVal ast, MalEnv env) - { - switch (ast.typeof) - { - case MalSymbol#: - return env.get(ast) - case MalList#: - newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalList(newElements) - case MalVector#: - newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalVector(newElements) - case MalHashMap#: - newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalHashMap.fromMap(newElements) - default: - return ast - } - } - - static MalVal EVAL(MalVal ast, MalEnv env) - { - while (true) - { - if (!(ast is MalList)) return eval_ast(ast, env) - astList := ast as MalList - if (astList.isEmpty) return ast - switch ((astList[0] as MalSymbol)?.value) - { - case "def!": - return env.set(astList[1], EVAL(astList[2], env)) - case "let*": - let_env := MalEnv(env) - varList := astList[1] as MalSeq - for (i := 0; i < varList.count; i += 2) - let_env.set(varList[i], EVAL(varList[i + 1], let_env)) - env = let_env - ast = astList[2] - // TCO - case "do": - eval_ast(MalList(astList[1..-2]), env) - ast = astList[-1] - // TCO - case "if": - if (EVAL(astList[1], env) is MalFalseyVal) - ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE - else - ast = astList[2] - // TCO - case "fn*": - f := |MalVal[] a -> MalVal| - { - return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) - } - return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) - default: - evaled_ast := eval_ast(ast, env) as MalList - switch (evaled_ast[0].typeof) - { - case MalUserFunc#: - user_fn := evaled_ast[0] as MalUserFunc - ast = user_fn.ast - env = user_fn.genEnv(evaled_ast.drop(1)) - // TCO - case MalFunc#: - return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) - default: - throw Err("Unknown type") - } - } - } - return MalNil.INSTANCE // never reached - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, MalEnv env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main(Str[] args) - { - repl_env := MalEnv() - // core.fan: defined using Fantom - Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } - repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) - repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - - if (!args.isEmpty) - { - REP("(load-file \"${args[0]}\")", repl_env) - return - } - - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, repl_env)) - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/src/step7_quote/build.fan b/impls/fantom/src/step7_quote/build.fan index a32dfca1f9..b16b5c9554 100644 --- a/impls/fantom/src/step7_quote/build.fan +++ b/impls/fantom/src/step7_quote/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step7_quote" - summary = "mal step7_quote pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step7_quote" + summary = "mal step7_quote pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step7_quote/fan/main.fan b/impls/fantom/src/step7_quote/fan/main.fan index 986977e020..dd8e75647c 100644 --- a/impls/fantom/src/step7_quote/fan/main.fan +++ b/impls/fantom/src/step7_quote/fan/main.fan @@ -1,168 +1,168 @@ -using mallib - -class Main -{ - - static MalList qq_loop(MalVal elt, MalList acc) - { - lst := elt as MalList - if (lst?.count == 2 && (lst[0] as MalSymbol)?.value == "splice-unquote") - return MalList(MalVal[MalSymbol("concat"), lst[1], acc]) - else - return MalList(MalVal[MalSymbol("cons"), quasiquote(elt), acc]) - } - - static MalList qq_foldr(MalSeq xs) - { - acc := MalList([,]) - for (i:=xs.count-1; 0<=i; i-=1) - acc = qq_loop(xs[i], acc) - return acc - } - - static MalVal quasiquote(MalVal ast) - { - switch (ast.typeof) - { - case MalList#: - lst := ast as MalList - if (lst.count == 2 && (lst[0] as MalSymbol)?.value == "unquote") - return lst[1] - else - return qq_foldr((MalSeq)ast) - case MalVector#: - return MalList(MalVal[MalSymbol("vec"), qq_foldr((MalSeq)ast)]) - case MalSymbol#: - return MalList(MalVal[MalSymbol("quote"), ast]) - case MalHashMap#: - return MalList(MalVal[MalSymbol("quote"), ast]) - default: - return ast - } - } - - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal eval_ast(MalVal ast, MalEnv env) - { - switch (ast.typeof) - { - case MalSymbol#: - return env.get(ast) - case MalList#: - newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalList(newElements) - case MalVector#: - newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalVector(newElements) - case MalHashMap#: - newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalHashMap.fromMap(newElements) - default: - return ast - } - } - - static MalVal EVAL(MalVal ast, MalEnv env) - { - while (true) - { - if (!(ast is MalList)) return eval_ast(ast, env) - astList := ast as MalList - if (astList.isEmpty) return ast - switch ((astList[0] as MalSymbol)?.value) - { - case "def!": - return env.set(astList[1], EVAL(astList[2], env)) - case "let*": - let_env := MalEnv(env) - varList := astList[1] as MalSeq - for (i := 0; i < varList.count; i += 2) - let_env.set(varList[i], EVAL(varList[i + 1], let_env)) - env = let_env - ast = astList[2] - // TCO - case "quote": - return astList[1] - case "quasiquoteexpand": - return quasiquote(astList[1]) - case "quasiquote": - ast = quasiquote(astList[1]) - // TCO - case "do": - eval_ast(MalList(astList[1..-2]), env) - ast = astList[-1] - // TCO - case "if": - if (EVAL(astList[1], env) is MalFalseyVal) - ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE - else - ast = astList[2] - // TCO - case "fn*": - f := |MalVal[] a -> MalVal| - { - return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) - } - return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) - default: - evaled_ast := eval_ast(ast, env) as MalList - switch (evaled_ast[0].typeof) - { - case MalUserFunc#: - user_fn := evaled_ast[0] as MalUserFunc - ast = user_fn.ast - env = user_fn.genEnv(evaled_ast.drop(1)) - // TCO - case MalFunc#: - return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) - default: - throw Err("Unknown type") - } - } - } - return MalNil.INSTANCE // never reached - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, MalEnv env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main(Str[] args) - { - repl_env := MalEnv() - // core.fan: defined using Fantom - Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } - repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) - repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - - if (!args.isEmpty) - { - REP("(load-file \"${args[0]}\")", repl_env) - return - } - - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, repl_env)) - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + + static MalList qq_loop(MalVal elt, MalList acc) + { + lst := elt as MalList + if (lst?.count == 2 && (lst[0] as MalSymbol)?.value == "splice-unquote") + return MalList(MalVal[MalSymbol("concat"), lst[1], acc]) + else + return MalList(MalVal[MalSymbol("cons"), quasiquote(elt), acc]) + } + + static MalList qq_foldr(MalSeq xs) + { + acc := MalList([,]) + for (i:=xs.count-1; 0<=i; i-=1) + acc = qq_loop(xs[i], acc) + return acc + } + + static MalVal quasiquote(MalVal ast) + { + switch (ast.typeof) + { + case MalList#: + lst := ast as MalList + if (lst.count == 2 && (lst[0] as MalSymbol)?.value == "unquote") + return lst[1] + else + return qq_foldr((MalSeq)ast) + case MalVector#: + return MalList(MalVal[MalSymbol("vec"), qq_foldr((MalSeq)ast)]) + case MalSymbol#: + return MalList(MalVal[MalSymbol("quote"), ast]) + case MalHashMap#: + return MalList(MalVal[MalSymbol("quote"), ast]) + default: + return ast + } + } + + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "quote": + return astList[1] + case "quasiquoteexpand": + return quasiquote(astList[1]) + case "quasiquote": + ast = quasiquote(astList[1]) + // TCO + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/src/step8_macros/build.fan b/impls/fantom/src/step8_macros/build.fan index d6333c9854..96c6cac2c4 100644 --- a/impls/fantom/src/step8_macros/build.fan +++ b/impls/fantom/src/step8_macros/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step8_macros" - summary = "mal step8_macros pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step8_macros" + summary = "mal step8_macros pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step8_macros/fan/main.fan b/impls/fantom/src/step8_macros/fan/main.fan index 5365379990..a628115435 100644 --- a/impls/fantom/src/step8_macros/fan/main.fan +++ b/impls/fantom/src/step8_macros/fan/main.fan @@ -1,198 +1,198 @@ -using mallib - -class Main -{ - - static MalList qq_loop(MalVal elt, MalList acc) - { - lst := elt as MalList - if (lst?.count == 2 && (lst[0] as MalSymbol)?.value == "splice-unquote") - return MalList(MalVal[MalSymbol("concat"), lst[1], acc]) - else - return MalList(MalVal[MalSymbol("cons"), quasiquote(elt), acc]) - } - - static MalList qq_foldr(MalSeq xs) - { - acc := MalList([,]) - for (i:=xs.count-1; 0<=i; i-=1) - acc = qq_loop(xs[i], acc) - return acc - } - - static MalVal quasiquote(MalVal ast) - { - switch (ast.typeof) - { - case MalList#: - lst := ast as MalList - if (lst.count == 2 && (lst[0] as MalSymbol)?.value == "unquote") - return lst[1] - else - return qq_foldr((MalSeq)ast) - case MalVector#: - return MalList(MalVal[MalSymbol("vec"), qq_foldr((MalSeq)ast)]) - case MalSymbol#: - return MalList(MalVal[MalSymbol("quote"), ast]) - case MalHashMap#: - return MalList(MalVal[MalSymbol("quote"), ast]) - default: - return ast - } - } - - static Bool isMacroCall(MalVal ast, MalEnv env) - { - if (!(ast is MalList)) return false - astList := ast as MalList - if (astList.isEmpty) return false - if (!(astList[0] is MalSymbol)) return false - ast0 := astList[0] as MalSymbol - f := env.find(ast0)?.get(ast0) - return (f as MalUserFunc)?.isMacro ?: false - } - - static MalVal macroexpand(MalVal ast, MalEnv env) - { - while (isMacroCall(ast, env)) - { - mac := env.get((ast as MalList)[0]) as MalUserFunc - ast = mac.call((ast as MalSeq).drop(1).value) - } - return ast - } - - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal eval_ast(MalVal ast, MalEnv env) - { - switch (ast.typeof) - { - case MalSymbol#: - return env.get(ast) - case MalList#: - newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalList(newElements) - case MalVector#: - newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalVector(newElements) - case MalHashMap#: - newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalHashMap.fromMap(newElements) - default: - return ast - } - } - - static MalVal EVAL(MalVal ast, MalEnv env) - { - while (true) - { - if (!(ast is MalList)) return eval_ast(ast, env) - ast = macroexpand(ast, env) - if (!(ast is MalList)) return eval_ast(ast, env) - astList := ast as MalList - if (astList.isEmpty) return ast - switch ((astList[0] as MalSymbol)?.value) - { - case "def!": - return env.set(astList[1], EVAL(astList[2], env)) - case "let*": - let_env := MalEnv(env) - varList := astList[1] as MalSeq - for (i := 0; i < varList.count; i += 2) - let_env.set(varList[i], EVAL(varList[i + 1], let_env)) - env = let_env - ast = astList[2] - // TCO - case "quote": - return astList[1] - case "quasiquoteexpand": - return quasiquote(astList[1]) - case "quasiquote": - ast = quasiquote(astList[1]) - // TCO - case "defmacro!": - f := (EVAL(astList[2], env) as MalUserFunc).dup - f.isMacro = true - return env.set(astList[1], f) - case "macroexpand": - return macroexpand(astList[1], env) - case "do": - eval_ast(MalList(astList[1..-2]), env) - ast = astList[-1] - // TCO - case "if": - if (EVAL(astList[1], env) is MalFalseyVal) - ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE - else - ast = astList[2] - // TCO - case "fn*": - f := |MalVal[] a -> MalVal| - { - return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) - } - return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) - default: - evaled_ast := eval_ast(ast, env) as MalList - switch (evaled_ast[0].typeof) - { - case MalUserFunc#: - user_fn := evaled_ast[0] as MalUserFunc - ast = user_fn.ast - env = user_fn.genEnv(evaled_ast.drop(1)) - // TCO - case MalFunc#: - return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) - default: - throw Err("Unknown type") - } - } - } - return MalNil.INSTANCE // never reached - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, MalEnv env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main(Str[] args) - { - repl_env := MalEnv() - // core.fan: defined using Fantom - Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } - repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) - repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - 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)))))))", repl_env) - - if (!args.isEmpty) - { - REP("(load-file \"${args[0]}\")", repl_env) - return - } - - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, repl_env)) - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + + static MalList qq_loop(MalVal elt, MalList acc) + { + lst := elt as MalList + if (lst?.count == 2 && (lst[0] as MalSymbol)?.value == "splice-unquote") + return MalList(MalVal[MalSymbol("concat"), lst[1], acc]) + else + return MalList(MalVal[MalSymbol("cons"), quasiquote(elt), acc]) + } + + static MalList qq_foldr(MalSeq xs) + { + acc := MalList([,]) + for (i:=xs.count-1; 0<=i; i-=1) + acc = qq_loop(xs[i], acc) + return acc + } + + static MalVal quasiquote(MalVal ast) + { + switch (ast.typeof) + { + case MalList#: + lst := ast as MalList + if (lst.count == 2 && (lst[0] as MalSymbol)?.value == "unquote") + return lst[1] + else + return qq_foldr((MalSeq)ast) + case MalVector#: + return MalList(MalVal[MalSymbol("vec"), qq_foldr((MalSeq)ast)]) + case MalSymbol#: + return MalList(MalVal[MalSymbol("quote"), ast]) + case MalHashMap#: + return MalList(MalVal[MalSymbol("quote"), ast]) + default: + return ast + } + } + + static Bool isMacroCall(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return false + astList := ast as MalList + if (astList.isEmpty) return false + if (!(astList[0] is MalSymbol)) return false + ast0 := astList[0] as MalSymbol + f := env.find(ast0)?.get(ast0) + return (f as MalUserFunc)?.isMacro ?: false + } + + static MalVal macroexpand(MalVal ast, MalEnv env) + { + while (isMacroCall(ast, env)) + { + mac := env.get((ast as MalList)[0]) as MalUserFunc + ast = mac.call((ast as MalSeq).drop(1).value) + } + return ast + } + + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "quote": + return astList[1] + case "quasiquoteexpand": + return quasiquote(astList[1]) + case "quasiquote": + ast = quasiquote(astList[1]) + // TCO + case "defmacro!": + f := (EVAL(astList[2], env) as MalUserFunc).dup + f.isMacro = true + return env.set(astList[1], f) + case "macroexpand": + return macroexpand(astList[1], env) + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + 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)))))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/src/step9_try/build.fan b/impls/fantom/src/step9_try/build.fan index 8d3b048052..89aca457c9 100644 --- a/impls/fantom/src/step9_try/build.fan +++ b/impls/fantom/src/step9_try/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "step9_try" - summary = "mal step9_try pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "step9_try" + summary = "mal step9_try pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/step9_try/fan/main.fan b/impls/fantom/src/step9_try/fan/main.fan index 0efa7cdaee..238f403df9 100644 --- a/impls/fantom/src/step9_try/fan/main.fan +++ b/impls/fantom/src/step9_try/fan/main.fan @@ -1,212 +1,212 @@ -using mallib - -class Main -{ - - static MalList qq_loop(MalVal elt, MalList acc) - { - lst := elt as MalList - if (lst?.count == 2 && (lst[0] as MalSymbol)?.value == "splice-unquote") - return MalList(MalVal[MalSymbol("concat"), lst[1], acc]) - else - return MalList(MalVal[MalSymbol("cons"), quasiquote(elt), acc]) - } - - static MalList qq_foldr(MalSeq xs) - { - acc := MalList([,]) - for (i:=xs.count-1; 0<=i; i-=1) - acc = qq_loop(xs[i], acc) - return acc - } - - static MalVal quasiquote(MalVal ast) - { - switch (ast.typeof) - { - case MalList#: - lst := ast as MalList - if (lst.count == 2 && (lst[0] as MalSymbol)?.value == "unquote") - return lst[1] - else - return qq_foldr((MalSeq)ast) - case MalVector#: - return MalList(MalVal[MalSymbol("vec"), qq_foldr((MalSeq)ast)]) - case MalSymbol#: - return MalList(MalVal[MalSymbol("quote"), ast]) - case MalHashMap#: - return MalList(MalVal[MalSymbol("quote"), ast]) - default: - return ast - } - } - - static Bool isMacroCall(MalVal ast, MalEnv env) - { - if (!(ast is MalList)) return false - astList := ast as MalList - if (astList.isEmpty) return false - if (!(astList[0] is MalSymbol)) return false - ast0 := astList[0] as MalSymbol - f := env.find(ast0)?.get(ast0) - return (f as MalUserFunc)?.isMacro ?: false - } - - static MalVal macroexpand(MalVal ast, MalEnv env) - { - while (isMacroCall(ast, env)) - { - mac := env.get((ast as MalList)[0]) as MalUserFunc - ast = mac.call((ast as MalSeq).drop(1).value) - } - return ast - } - - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal eval_ast(MalVal ast, MalEnv env) - { - switch (ast.typeof) - { - case MalSymbol#: - return env.get(ast) - case MalList#: - newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalList(newElements) - case MalVector#: - newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalVector(newElements) - case MalHashMap#: - newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalHashMap.fromMap(newElements) - default: - return ast - } - } - - static MalVal EVAL(MalVal ast, MalEnv env) - { - while (true) - { - if (!(ast is MalList)) return eval_ast(ast, env) - ast = macroexpand(ast, env) - if (!(ast is MalList)) return eval_ast(ast, env) - astList := ast as MalList - if (astList.isEmpty) return ast - switch ((astList[0] as MalSymbol)?.value) - { - case "def!": - return env.set(astList[1], EVAL(astList[2], env)) - case "let*": - let_env := MalEnv(env) - varList := astList[1] as MalSeq - for (i := 0; i < varList.count; i += 2) - let_env.set(varList[i], EVAL(varList[i + 1], let_env)) - env = let_env - ast = astList[2] - // TCO - case "quote": - return astList[1] - case "quasiquoteexpand": - return quasiquote(astList[1]) - case "quasiquote": - ast = quasiquote(astList[1]) - // TCO - case "defmacro!": - f := (EVAL(astList[2], env) as MalUserFunc).dup - f.isMacro = true - return env.set(astList[1], f) - case "macroexpand": - return macroexpand(astList[1], env) - case "try*": - if (astList.count < 3) - return EVAL(astList[1], env) - MalVal exc := MalNil.INSTANCE - try - return EVAL(astList[1], env) - catch (MalException e) - exc = e.getValue - catch (Err e) - exc = MalString.make(e.msg) - catchClause := astList[2] as MalList - return EVAL(catchClause[2], MalEnv(env, MalList([catchClause[1]]), MalList([exc]))) - case "do": - eval_ast(MalList(astList[1..-2]), env) - ast = astList[-1] - // TCO - case "if": - if (EVAL(astList[1], env) is MalFalseyVal) - ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE - else - ast = astList[2] - // TCO - case "fn*": - f := |MalVal[] a -> MalVal| - { - return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) - } - return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) - default: - evaled_ast := eval_ast(ast, env) as MalList - switch (evaled_ast[0].typeof) - { - case MalUserFunc#: - user_fn := evaled_ast[0] as MalUserFunc - ast = user_fn.ast - env = user_fn.genEnv(evaled_ast.drop(1)) - // TCO - case MalFunc#: - return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) - default: - throw Err("Unknown type") - } - } - } - return MalNil.INSTANCE // never reached - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, MalEnv env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main(Str[] args) - { - repl_env := MalEnv() - // core.fan: defined using Fantom - Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } - repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) - repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - 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)))))))", repl_env) - - if (!args.isEmpty) - { - REP("(load-file \"${args[0]}\")", repl_env) - return - } - - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, repl_env)) - catch (MalException e) - echo("Error: ${e.serializedValue}") - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + + static MalList qq_loop(MalVal elt, MalList acc) + { + lst := elt as MalList + if (lst?.count == 2 && (lst[0] as MalSymbol)?.value == "splice-unquote") + return MalList(MalVal[MalSymbol("concat"), lst[1], acc]) + else + return MalList(MalVal[MalSymbol("cons"), quasiquote(elt), acc]) + } + + static MalList qq_foldr(MalSeq xs) + { + acc := MalList([,]) + for (i:=xs.count-1; 0<=i; i-=1) + acc = qq_loop(xs[i], acc) + return acc + } + + static MalVal quasiquote(MalVal ast) + { + switch (ast.typeof) + { + case MalList#: + lst := ast as MalList + if (lst.count == 2 && (lst[0] as MalSymbol)?.value == "unquote") + return lst[1] + else + return qq_foldr((MalSeq)ast) + case MalVector#: + return MalList(MalVal[MalSymbol("vec"), qq_foldr((MalSeq)ast)]) + case MalSymbol#: + return MalList(MalVal[MalSymbol("quote"), ast]) + case MalHashMap#: + return MalList(MalVal[MalSymbol("quote"), ast]) + default: + return ast + } + } + + static Bool isMacroCall(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return false + astList := ast as MalList + if (astList.isEmpty) return false + if (!(astList[0] is MalSymbol)) return false + ast0 := astList[0] as MalSymbol + f := env.find(ast0)?.get(ast0) + return (f as MalUserFunc)?.isMacro ?: false + } + + static MalVal macroexpand(MalVal ast, MalEnv env) + { + while (isMacroCall(ast, env)) + { + mac := env.get((ast as MalList)[0]) as MalUserFunc + ast = mac.call((ast as MalSeq).drop(1).value) + } + return ast + } + + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "quote": + return astList[1] + case "quasiquoteexpand": + return quasiquote(astList[1]) + case "quasiquote": + ast = quasiquote(astList[1]) + // TCO + case "defmacro!": + f := (EVAL(astList[2], env) as MalUserFunc).dup + f.isMacro = true + return env.set(astList[1], f) + case "macroexpand": + return macroexpand(astList[1], env) + case "try*": + if (astList.count < 3) + return EVAL(astList[1], env) + MalVal exc := MalNil.INSTANCE + try + return EVAL(astList[1], env) + catch (MalException e) + exc = e.getValue + catch (Err e) + exc = MalString.make(e.msg) + catchClause := astList[2] as MalList + return EVAL(catchClause[2], MalEnv(env, MalList([catchClause[1]]), MalList([exc]))) + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + 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)))))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (MalException e) + echo("Error: ${e.serializedValue}") + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/src/stepA_mal/build.fan b/impls/fantom/src/stepA_mal/build.fan index a4c40d7f57..44484e6c5f 100644 --- a/impls/fantom/src/stepA_mal/build.fan +++ b/impls/fantom/src/stepA_mal/build.fan @@ -1,11 +1,11 @@ -class Build : build::BuildPod -{ - new make() - { - podName = "stepA_mal" - summary = "mal stepA_mal pod" - depends = ["sys 1.0", "mallib 1.0"] - srcDirs = [`fan/`] - outPodDir = `lib/fan/` - } -} +class Build : build::BuildPod +{ + new make() + { + podName = "stepA_mal" + summary = "mal stepA_mal pod" + depends = ["sys 1.0", "mallib 1.0"] + srcDirs = [`fan/`] + outPodDir = `lib/fan/` + } +} diff --git a/impls/fantom/src/stepA_mal/fan/main.fan b/impls/fantom/src/stepA_mal/fan/main.fan index 9fe318fc5a..38f749ab17 100644 --- a/impls/fantom/src/stepA_mal/fan/main.fan +++ b/impls/fantom/src/stepA_mal/fan/main.fan @@ -1,214 +1,214 @@ -using mallib - -class Main -{ - - static MalList qq_loop(MalVal elt, MalList acc) - { - lst := elt as MalList - if (lst?.count == 2 && (lst[0] as MalSymbol)?.value == "splice-unquote") - return MalList(MalVal[MalSymbol("concat"), lst[1], acc]) - else - return MalList(MalVal[MalSymbol("cons"), quasiquote(elt), acc]) - } - - static MalList qq_foldr(MalSeq xs) - { - acc := MalList([,]) - for (i:=xs.count-1; 0<=i; i-=1) - acc = qq_loop(xs[i], acc) - return acc - } - - static MalVal quasiquote(MalVal ast) - { - switch (ast.typeof) - { - case MalList#: - lst := ast as MalList - if (lst.count == 2 && (lst[0] as MalSymbol)?.value == "unquote") - return lst[1] - else - return qq_foldr((MalSeq)ast) - case MalVector#: - return MalList(MalVal[MalSymbol("vec"), qq_foldr((MalSeq)ast)]) - case MalSymbol#: - return MalList(MalVal[MalSymbol("quote"), ast]) - case MalHashMap#: - return MalList(MalVal[MalSymbol("quote"), ast]) - default: - return ast - } - } - - static Bool isMacroCall(MalVal ast, MalEnv env) - { - if (!(ast is MalList)) return false - astList := ast as MalList - if (astList.isEmpty) return false - if (!(astList[0] is MalSymbol)) return false - ast0 := astList[0] as MalSymbol - f := env.find(ast0)?.get(ast0) - return (f as MalUserFunc)?.isMacro ?: false - } - - static MalVal macroexpand(MalVal ast, MalEnv env) - { - while (isMacroCall(ast, env)) - { - mac := env.get((ast as MalList)[0]) as MalUserFunc - ast = mac.call((ast as MalSeq).drop(1).value) - } - return ast - } - - static MalVal READ(Str s) - { - return Reader.read_str(s) - } - - static MalVal eval_ast(MalVal ast, MalEnv env) - { - switch (ast.typeof) - { - case MalSymbol#: - return env.get(ast) - case MalList#: - newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalList(newElements) - case MalVector#: - newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalVector(newElements) - case MalHashMap#: - newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } - return MalHashMap.fromMap(newElements) - default: - return ast - } - } - - static MalVal EVAL(MalVal ast, MalEnv env) - { - while (true) - { - if (!(ast is MalList)) return eval_ast(ast, env) - ast = macroexpand(ast, env) - if (!(ast is MalList)) return eval_ast(ast, env) - astList := ast as MalList - if (astList.isEmpty) return ast - switch ((astList[0] as MalSymbol)?.value) - { - case "def!": - return env.set(astList[1], EVAL(astList[2], env)) - case "let*": - let_env := MalEnv(env) - varList := astList[1] as MalSeq - for (i := 0; i < varList.count; i += 2) - let_env.set(varList[i], EVAL(varList[i + 1], let_env)) - env = let_env - ast = astList[2] - // TCO - case "quote": - return astList[1] - case "quasiquoteexpand": - return quasiquote(astList[1]) - case "quasiquote": - ast = quasiquote(astList[1]) - // TCO - case "defmacro!": - f := (EVAL(astList[2], env) as MalUserFunc).dup - f.isMacro = true - return env.set(astList[1], f) - case "macroexpand": - return macroexpand(astList[1], env) - case "try*": - if (astList.count < 3) - return EVAL(astList[1], env) - MalVal exc := MalNil.INSTANCE - try - return EVAL(astList[1], env) - catch (MalException e) - exc = e.getValue - catch (Err e) - exc = MalString.make(e.msg) - catchClause := astList[2] as MalList - return EVAL(catchClause[2], MalEnv(env, MalList([catchClause[1]]), MalList([exc]))) - case "do": - eval_ast(MalList(astList[1..-2]), env) - ast = astList[-1] - // TCO - case "if": - if (EVAL(astList[1], env) is MalFalseyVal) - ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE - else - ast = astList[2] - // TCO - case "fn*": - f := |MalVal[] a -> MalVal| - { - return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) - } - return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) - default: - evaled_ast := eval_ast(ast, env) as MalList - switch (evaled_ast[0].typeof) - { - case MalUserFunc#: - user_fn := evaled_ast[0] as MalUserFunc - ast = user_fn.ast - env = user_fn.genEnv(evaled_ast.drop(1)) - // TCO - case MalFunc#: - return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) - default: - throw Err("Unknown type") - } - } - } - return MalNil.INSTANCE // never reached - } - - static Str PRINT(MalVal exp) - { - return exp.toString(true) - } - - static Str REP(Str s, MalEnv env) - { - return PRINT(EVAL(READ(s), env)) - } - - static Void main(Str[] args) - { - repl_env := MalEnv() - // core.fan: defined using Fantom - Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } - repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) - repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) - - // core.mal: defined using the language itself - REP("(def! *host-language* \"fantom\")", repl_env) - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - 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)))))))", repl_env) - - if (!args.isEmpty) - { - REP("(load-file \"${args[0]}\")", repl_env) - return - } - - REP("(println (str \"Mal [\" *host-language* \"]\"))", repl_env) - while (true) { - line := Env.cur.prompt("user> ") - if (line == null) break - if (line.isSpace) continue - try - echo(REP(line, repl_env)) - catch (MalException e) - echo("Error: ${e.serializedValue}") - catch (Err e) - echo("Error: $e.msg") - } - } -} +using mallib + +class Main +{ + + static MalList qq_loop(MalVal elt, MalList acc) + { + lst := elt as MalList + if (lst?.count == 2 && (lst[0] as MalSymbol)?.value == "splice-unquote") + return MalList(MalVal[MalSymbol("concat"), lst[1], acc]) + else + return MalList(MalVal[MalSymbol("cons"), quasiquote(elt), acc]) + } + + static MalList qq_foldr(MalSeq xs) + { + acc := MalList([,]) + for (i:=xs.count-1; 0<=i; i-=1) + acc = qq_loop(xs[i], acc) + return acc + } + + static MalVal quasiquote(MalVal ast) + { + switch (ast.typeof) + { + case MalList#: + lst := ast as MalList + if (lst.count == 2 && (lst[0] as MalSymbol)?.value == "unquote") + return lst[1] + else + return qq_foldr((MalSeq)ast) + case MalVector#: + return MalList(MalVal[MalSymbol("vec"), qq_foldr((MalSeq)ast)]) + case MalSymbol#: + return MalList(MalVal[MalSymbol("quote"), ast]) + case MalHashMap#: + return MalList(MalVal[MalSymbol("quote"), ast]) + default: + return ast + } + } + + static Bool isMacroCall(MalVal ast, MalEnv env) + { + if (!(ast is MalList)) return false + astList := ast as MalList + if (astList.isEmpty) return false + if (!(astList[0] is MalSymbol)) return false + ast0 := astList[0] as MalSymbol + f := env.find(ast0)?.get(ast0) + return (f as MalUserFunc)?.isMacro ?: false + } + + static MalVal macroexpand(MalVal ast, MalEnv env) + { + while (isMacroCall(ast, env)) + { + mac := env.get((ast as MalList)[0]) as MalUserFunc + ast = mac.call((ast as MalSeq).drop(1).value) + } + return ast + } + + static MalVal READ(Str s) + { + return Reader.read_str(s) + } + + static MalVal eval_ast(MalVal ast, MalEnv env) + { + switch (ast.typeof) + { + case MalSymbol#: + return env.get(ast) + case MalList#: + newElements := (ast as MalList).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalList(newElements) + case MalVector#: + newElements := (ast as MalVector).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalVector(newElements) + case MalHashMap#: + newElements := (ast as MalHashMap).value.map |MalVal v -> MalVal| { EVAL(v, env) } + return MalHashMap.fromMap(newElements) + default: + return ast + } + } + + static MalVal EVAL(MalVal ast, MalEnv env) + { + while (true) + { + if (!(ast is MalList)) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (!(ast is MalList)) return eval_ast(ast, env) + astList := ast as MalList + if (astList.isEmpty) return ast + switch ((astList[0] as MalSymbol)?.value) + { + case "def!": + return env.set(astList[1], EVAL(astList[2], env)) + case "let*": + let_env := MalEnv(env) + varList := astList[1] as MalSeq + for (i := 0; i < varList.count; i += 2) + let_env.set(varList[i], EVAL(varList[i + 1], let_env)) + env = let_env + ast = astList[2] + // TCO + case "quote": + return astList[1] + case "quasiquoteexpand": + return quasiquote(astList[1]) + case "quasiquote": + ast = quasiquote(astList[1]) + // TCO + case "defmacro!": + f := (EVAL(astList[2], env) as MalUserFunc).dup + f.isMacro = true + return env.set(astList[1], f) + case "macroexpand": + return macroexpand(astList[1], env) + case "try*": + if (astList.count < 3) + return EVAL(astList[1], env) + MalVal exc := MalNil.INSTANCE + try + return EVAL(astList[1], env) + catch (MalException e) + exc = e.getValue + catch (Err e) + exc = MalString.make(e.msg) + catchClause := astList[2] as MalList + return EVAL(catchClause[2], MalEnv(env, MalList([catchClause[1]]), MalList([exc]))) + case "do": + eval_ast(MalList(astList[1..-2]), env) + ast = astList[-1] + // TCO + case "if": + if (EVAL(astList[1], env) is MalFalseyVal) + ast = astList.count > 3 ? astList[3] : MalNil.INSTANCE + else + ast = astList[2] + // TCO + case "fn*": + f := |MalVal[] a -> MalVal| + { + return EVAL(astList[2], MalEnv(env, (astList[1] as MalSeq), MalList(a))) + } + return MalUserFunc(astList[2], env, (MalSeq)astList[1], f) + default: + evaled_ast := eval_ast(ast, env) as MalList + switch (evaled_ast[0].typeof) + { + case MalUserFunc#: + user_fn := evaled_ast[0] as MalUserFunc + ast = user_fn.ast + env = user_fn.genEnv(evaled_ast.drop(1)) + // TCO + case MalFunc#: + return (evaled_ast[0] as MalFunc).call(evaled_ast[1..-1]) + default: + throw Err("Unknown type") + } + } + } + return MalNil.INSTANCE // never reached + } + + static Str PRINT(MalVal exp) + { + return exp.toString(true) + } + + static Str REP(Str s, MalEnv env) + { + return PRINT(EVAL(READ(s), env)) + } + + static Void main(Str[] args) + { + repl_env := MalEnv() + // core.fan: defined using Fantom + Core.ns.each |MalFunc V, Str K| { repl_env.set(MalSymbol(K), V) } + repl_env.set(MalSymbol("eval"), MalFunc { EVAL(it[0], repl_env) }) + repl_env.set(MalSymbol("*ARGV*"), MalList((args.isEmpty ? args : args[1..-1]).map { MalString.make(it) })) + + // core.mal: defined using the language itself + REP("(def! *host-language* \"fantom\")", repl_env) + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + 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)))))))", repl_env) + + if (!args.isEmpty) + { + REP("(load-file \"${args[0]}\")", repl_env) + return + } + + REP("(println (str \"Mal [\" *host-language* \"]\"))", repl_env) + while (true) { + line := Env.cur.prompt("user> ") + if (line == null) break + if (line.isSpace) continue + try + echo(REP(line, repl_env)) + catch (MalException e) + echo("Error: ${e.serializedValue}") + catch (Err e) + echo("Error: $e.msg") + } + } +} diff --git a/impls/fantom/tests/step5_tco.mal b/impls/fantom/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/fantom/tests/step5_tco.mal +++ b/impls/fantom/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/fantom/tests/stepA_mal.mal b/impls/fantom/tests/stepA_mal.mal index 6867ab0e4d..1179f7f899 100644 --- a/impls/fantom/tests/stepA_mal.mal +++ b/impls/fantom/tests/stepA_mal.mal @@ -1,38 +1,38 @@ -;; Testing basic fantom interop - -(fantom-eval "7") -;=>7 - -(fantom-eval "return 3 * 9") -;=>27 - -(fantom-eval "\"7\"") -;=>"7" - -(fantom-eval "\"abcd\".upper") -;=>"ABCD" - -(fantom-eval "[7,8,9]") -;=>(7 8 9) - -(= () (fantom-eval "[,]")) -;=>true - -(fantom-eval "[\"abc\": 789]") -;=>{"abc" 789} - -(= {} (fantom-eval "[:]")) -;=>true - -(fantom-eval "echo(\"hello\")") -;/hello -;=>nil - -(fantom-eval "[\"a\",\"b\",\"c\"].join(\" \") { \"X${it}Y\" }") -;=>"XaY XbY XcY" - -(fantom-eval "[1,2,3].map { 1 + it }") -;=>(2 3 4) - -(fantom-eval "Env.cur.runtime") -;=>"java" +;; Testing basic fantom interop + +(fantom-eval "7") +;=>7 + +(fantom-eval "return 3 * 9") +;=>27 + +(fantom-eval "\"7\"") +;=>"7" + +(fantom-eval "\"abcd\".upper") +;=>"ABCD" + +(fantom-eval "[7,8,9]") +;=>(7 8 9) + +(= () (fantom-eval "[,]")) +;=>true + +(fantom-eval "[\"abc\": 789]") +;=>{"abc" 789} + +(= {} (fantom-eval "[:]")) +;=>true + +(fantom-eval "echo(\"hello\")") +;/hello +;=>nil + +(fantom-eval "[\"a\",\"b\",\"c\"].join(\" \") { \"X${it}Y\" }") +;=>"XaY XbY XcY" + +(fantom-eval "[1,2,3].map { 1 + it }") +;=>(2 3 4) + +(fantom-eval "Env.cur.runtime") +;=>"java" diff --git a/impls/fennel/Dockerfile b/impls/fennel/Dockerfile index 7ad459e49f..26679f70d3 100644 --- a/impls/fennel/Dockerfile +++ b/impls/fennel/Dockerfile @@ -1,52 +1,52 @@ -FROM ubuntu:20.04 -MAINTAINER Joel Martin - -ENV DEBIAN_FRONTEND=noninteractive - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# fennel - -RUN apt-get -y install gcc wget unzip libpcre3-dev - -# lua -RUN \ -wget http://www.lua.org/ftp/lua-5.4.1.tar.gz && \ -tar -zxf lua-5.4.1.tar.gz && \ -cd lua-5.4.1 && \ -make linux test && \ -make install - -# luarocks -RUN \ -wget https://luarocks.org/releases/luarocks-3.3.1.tar.gz && \ -tar zxpf luarocks-3.3.1.tar.gz && \ -cd luarocks-3.3.1 && \ -./configure && \ -make && \ -make install - -# fennel, lpeg -RUN luarocks install fennel -RUN luarocks install lpeg - -# luarocks .cache directory is relative to HOME +FROM ubuntu:20.04 +MAINTAINER Joel Martin + +ENV DEBIAN_FRONTEND=noninteractive + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# fennel + +RUN apt-get -y install gcc wget unzip libpcre3-dev + +# lua +RUN \ +wget http://www.lua.org/ftp/lua-5.4.1.tar.gz && \ +tar -zxf lua-5.4.1.tar.gz && \ +cd lua-5.4.1 && \ +make linux test && \ +make install + +# luarocks +RUN \ +wget https://luarocks.org/releases/luarocks-3.3.1.tar.gz && \ +tar zxpf luarocks-3.3.1.tar.gz && \ +cd luarocks-3.3.1 && \ +./configure && \ +make && \ +make install + +# fennel, lpeg +RUN luarocks install fennel +RUN luarocks install lpeg + +# luarocks .cache directory is relative to HOME ENV HOME /mal \ No newline at end of file diff --git a/impls/fennel/Makefile b/impls/fennel/Makefile index 8a7cbb717e..b52aefe1d1 100644 --- a/impls/fennel/Makefile +++ b/impls/fennel/Makefile @@ -1,2 +1,2 @@ -all: - true +all: + true diff --git a/impls/fennel/core.fnl b/impls/fennel/core.fnl index c46b67865c..d071a5d269 100644 --- a/impls/fennel/core.fnl +++ b/impls/fennel/core.fnl @@ -1,815 +1,815 @@ -(local t (require :types)) -(local u (require :utils)) -(local printer (require :printer)) -(local reader (require :reader)) -(local fennel (require :fennel)) - -(local mal-list - (t.make-fn - (fn [asts] - (t.make-list asts)))) - -(local mal-list? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "list? takes 1 argument"))) - (t.make-boolean (t.list?* (. asts 1)))))) - -(local mal-empty? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "empty? takes 1 argument"))) - (let [arg-ast (. asts 1)] - (if (t.nil?* arg-ast) - t.mal-true - (t.make-boolean (t.empty?* arg-ast))))))) - -(local mal-count - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "count takes 1 argument"))) - (let [arg-ast (. asts 1)] - (if (t.nil?* arg-ast) - (t.make-number 0) - (t.make-number (length (t.get-value arg-ast)))))))) - -(local mal-= - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "= takes 2 arguments"))) - (let [ast-1 (. asts 1) - ast-2 (. asts 2)] - (if (t.equals?* ast-1 ast-2) - t.mal-true - t.mal-false))))) - -(local mal-pr-str - (t.make-fn - (fn [asts] - (local buf []) - (when (> (length asts) 0) - (each [i ast (ipairs asts)] - (table.insert buf (printer.pr_str ast true)) - (table.insert buf " ")) - ;; remove extra space at end - (table.remove buf)) - (t.make-string (table.concat buf))))) - -(local mal-str - (t.make-fn - (fn [asts] - (local buf []) - (when (> (length asts) 0) - (each [i ast (ipairs asts)] - (table.insert buf (printer.pr_str ast false)))) - (t.make-string (table.concat buf))))) - -(local mal-prn - (t.make-fn - (fn [asts] - (local buf []) - (when (> (length asts) 0) - (each [i ast (ipairs asts)] - (table.insert buf (printer.pr_str ast true)) - (table.insert buf " ")) - ;; remove extra space at end - (table.remove buf)) - (print (table.concat buf)) - t.mal-nil))) - -(local mal-println - (t.make-fn - (fn [asts] - (local buf []) - (when (> (length asts) 0) - (each [i ast (ipairs asts)] - (table.insert buf (printer.pr_str ast false)) - (table.insert buf " ")) - ;; remove extra space at end - (table.remove buf)) - (print (table.concat buf)) - t.mal-nil))) - -(local mal-read-string - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "read-string takes 1 argument"))) - (let [res (reader.read_str (t.get-value (. asts 1)))] - (if res - res - (u.throw* (t.make-string "No code content"))))))) - -(local mal-slurp - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "slurp takes 1 argument"))) - (let [a-str (t.get-value (. asts 1))] - ;; XXX: error handling? - (with-open [f (io.open a-str)] - ;; XXX: escaping? - (t.make-string (f:read "*a"))))))) - -(local mal-atom - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "atom takes 1 argument"))) - (t.make-atom (. asts 1))))) - -(local mal-atom? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "atom? takes 1 argument"))) - (if (t.atom?* (. asts 1)) - t.mal-true - t.mal-false)))) - -(local mal-deref - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "deref takes 1 argument"))) - (let [ast (. asts 1)] - (t.deref* ast))))) - -(local mal-reset! - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "reset! takes 2 arguments"))) - (let [atom-ast (. asts 1) - val-ast (. asts 2)] - (t.reset!* atom-ast val-ast))))) - -(local mal-swap! - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "swap! takes at least 2 arguments"))) - (let [atom-ast (. asts 1) - fn-ast (. asts 2) - args-asts (u.slice asts 3 -1) - args-tbl [(t.deref* atom-ast) (table.unpack args-asts)]] - (t.reset!* atom-ast - ((t.get-value fn-ast) args-tbl)))))) - -(local mal-cons - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "cons takes 2 arguments"))) - (let [head-ast (. asts 1) - tail-ast (. asts 2)] - (t.make-list [head-ast - (table.unpack (t.get-value tail-ast))]))))) - -(local mal-concat - (t.make-fn - (fn [asts] - (local acc []) - (for [i 1 (length asts)] - (each [j elt (ipairs (t.get-value (. asts i)))] - (table.insert acc elt))) - (t.make-list acc)))) - -(local mal-vec - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "vec takes 1 argument"))) - (let [ast (. asts 1)] - (if (t.vector?* ast) - ast - ;; - (t.list?* ast) - (t.make-vector (t.get-value ast)) - ;; - (t.nil?* ast) - (t.make-vector []) - ;; - (u.throw* (t.make-string "vec takes a vector, list, or nil"))))))) - -(local mal-nth - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "nth takes 2 arguments"))) - (let [elts (t.get-value (. asts 1)) - i (t.get-value (. asts 2))] - (if (< i (length elts)) - (. elts (+ i 1)) - (u.throw* (t.make-string (.. "Index out of range: " i)))))))) - -(local mal-first - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "first takes 1 argument"))) - (let [coll-or-nil-ast (. asts 1)] - (if (or (t.nil?* coll-or-nil-ast) - (t.empty?* coll-or-nil-ast)) - t.mal-nil - (. (t.get-value coll-or-nil-ast) 1)))))) - -(local mal-rest - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "rest takes 1 argument"))) - (let [coll-or-nil-ast (. asts 1)] - (if (or (t.nil?* coll-or-nil-ast) - (t.empty?* coll-or-nil-ast)) - (t.make-list []) - (t.make-list (u.slice (t.get-value coll-or-nil-ast) 2 -1))))))) - -(local mal-throw - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "throw takes 1 argument"))) - (u.throw* (. asts 1))))) - -;; (apply F A B [C D]) is equivalent to (F A B C D) -(local mal-apply - (t.make-fn - (fn [asts] - (let [n-asts (length asts)] - (when (< n-asts 1) - (u.throw* (t.make-string "apply takes at least 1 argument"))) - (let [the-fn (t.get-value (. asts 1))] ; e.g. F - (if (= n-asts 1) - (the-fn []) - (= n-asts 2) - (the-fn [(table.unpack (t.get-value (. asts 2)))]) - (let [args-asts (u.slice asts 2 -2) ; e.g. [A B] - last-asts (t.get-value (u.last asts)) ; e.g. [C D] - fn-args-tbl []] - (each [i elt (ipairs args-asts)] - (table.insert fn-args-tbl elt)) - (each [i elt (ipairs last-asts)] - (table.insert fn-args-tbl elt)) - (the-fn fn-args-tbl)))))))) - -(local mal-map - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "map takes at least 2 arguments"))) - (let [the-fn (t.get-value (. asts 1)) - coll (t.get-value (. asts 2))] - (t.make-list (u.map #(the-fn [$]) coll)))))) - -(local mal-nil? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "nil? takes 1 argument"))) - (if (t.nil?* (. asts 1)) - t.mal-true - t.mal-false)))) - -(local mal-true? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "true? takes 1 argument"))) - (if (t.true?* (. asts 1)) - t.mal-true - t.mal-false)))) - -(local mal-false? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "false? takes 1 argument"))) - (if (t.false?* (. asts 1)) - t.mal-true - t.mal-false)))) - -(local mal-symbol? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "symbol? takes 1 argument"))) - (if (t.symbol?* (. asts 1)) - t.mal-true - t.mal-false)))) - -(local mal-symbol - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "symbol takes 1 argument"))) - ;; XXX: check that type is string? - (t.make-symbol (t.get-value (. asts 1)))))) - -(local mal-keyword - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "keyword takes 1 argument"))) - (let [arg-ast (. asts 1)] - (if (t.keyword?* arg-ast) - arg-ast - ;; - (t.string?* arg-ast) - (t.make-keyword (.. ":" (t.get-value arg-ast))) - ;; - (u.throw* (t.make-string "Expected string"))))))) - -(local mal-keyword? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "keyword? takes 1 argument"))) - (if (t.keyword?* (. asts 1)) - t.mal-true - t.mal-false)))) - -(local mal-vector - (t.make-fn - (fn [asts] - (t.make-vector asts)))) - -(local mal-vector? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "vector? takes 1 argument"))) - (if (t.vector?* (. asts 1)) - t.mal-true - t.mal-false)))) - -(local mal-sequential? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "sequential? takes 1 argument"))) - (if (or (t.list?* (. asts 1)) - (t.vector?* (. asts 1))) - t.mal-true - t.mal-false)))) - -(local mal-map? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "map? takes 1 argument"))) - (if (t.hash-map?* (. asts 1)) - t.mal-true - t.mal-false)))) - -(local mal-hash-map - (t.make-fn - (fn [asts] - (when (= 1 (% (length asts) 2)) - (u.throw* (t.make-string - "hash-map takes an even number of arguments"))) - (t.make-hash-map asts)))) - -(local mal-assoc - (t.make-fn - (fn [asts] - (when (< (length asts) 3) - (u.throw* (t.make-string "assoc takes at least 3 arguments"))) - (let [head-ast (. asts 1)] - (when (not (or (t.hash-map?* head-ast) - (t.nil?* head-ast))) - (u.throw* (t.make-string - "assoc first argument should be a hash-map or nil"))) - (if (t.nil?* head-ast) - t.mal-nil - (let [item-tbl [] - kv-asts (u.slice asts 2 -1) - hash-items (t.get-value head-ast)] - (for [i 1 (/ (length hash-items) 2)] - (let [key (. hash-items (- (* 2 i) 1))] - (var idx 1) - (var found false) - (while (and (not found) - (<= idx (length kv-asts))) - (if (t.equals?* key (. kv-asts idx)) - (set found true) - (set idx (+ idx 2)))) - (if (not found) - (do - (table.insert item-tbl key) - (table.insert item-tbl (. hash-items (* 2 i)))) - (do - (table.insert item-tbl key) - (table.insert item-tbl (. kv-asts (+ idx 1))) - (table.remove kv-asts (+ idx 1)) - (table.remove kv-asts idx))))) - (each [i elt (ipairs kv-asts)] - (table.insert item-tbl elt)) - (t.make-hash-map item-tbl))))))) - -(local mal-dissoc - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "dissoc takes at least 2 arguments"))) - (let [head-ast (. asts 1)] - (when (not (or (t.hash-map?* head-ast) - (t.nil?* head-ast))) - (u.throw* (t.make-string - "dissoc first argument should be a hash-map or nil"))) - (if (t.nil?* head-ast) - t.mal-nil - (let [item-tbl [] - key-asts (u.slice asts 2 -1) - hash-items (t.get-value head-ast)] - (for [i 1 (/ (length hash-items) 2)] - (let [key (. hash-items (- (* 2 i) 1))] - (var idx 1) - (var found false) - (while (and (not found) - (<= idx (length key-asts))) - (if (t.equals?* key (. key-asts idx)) - (set found true) - (set idx (+ idx 1)))) - (when (not found) - (table.insert item-tbl key) - (table.insert item-tbl (. hash-items (* 2 i)))))) - (t.make-hash-map item-tbl))))))) - -(local mal-get - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "get takes 2 arguments"))) - (let [head-ast (. asts 1)] - (when (not (or (t.hash-map?* head-ast) - (t.nil?* head-ast))) - (u.throw* (t.make-string - "get first argument should be a hash-map or nil"))) - (if (t.nil?* head-ast) - t.mal-nil - (let [hash-items (t.get-value head-ast) - key-ast (. asts 2)] - (var idx 1) - (var found false) - (while (and (not found) - (<= idx (length hash-items))) - (if (t.equals?* key-ast (. hash-items idx)) - (set found true) - (set idx (+ idx 1)))) - (if found - (. hash-items (+ idx 1)) - t.mal-nil))))))) - -(local mal-contains? - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "contains? takes 2 arguments"))) - (let [head-ast (. asts 1)] - (when (not (or (t.hash-map?* head-ast) - (t.nil?* head-ast))) - (u.throw* (t.make-string - "contains? first argument should be a hash-map or nil"))) - (if (t.nil?* head-ast) - t.mal-nil - (let [hash-items (t.get-value head-ast) - key-ast (. asts 2)] - (var idx 1) - (var found false) - (while (and (not found) - (<= idx (length hash-items))) - (if (t.equals?* key-ast (. hash-items idx)) - (set found true) - (set idx (+ idx 1)))) - (if found - t.mal-true - t.mal-false))))))) - -(local mal-keys - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "keys takes 1 argument"))) - (let [head-ast (. asts 1)] - (when (not (or (t.hash-map?* head-ast) - (t.nil?* head-ast))) - (u.throw* (t.make-string - "keys first argument should be a hash-map or nil"))) - (if (t.nil?* head-ast) - t.mal-nil - (let [item-tbl [] - hash-items (t.get-value head-ast)] - (for [i 1 (/ (length hash-items) 2)] - (let [key (. hash-items (- (* 2 i) 1))] - (table.insert item-tbl key))) - (t.make-list item-tbl))))))) - -(local mal-vals - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "vals takes 1 argument"))) - (let [head-ast (. asts 1)] - (when (not (or (t.hash-map?* head-ast) - (t.nil?* head-ast))) - (u.throw* (t.make-string - "vals first argument should be a hash-map or nil"))) - (if (t.nil?* head-ast) - t.mal-nil - (let [item-tbl [] - hash-items (t.get-value head-ast)] - (for [i 1 (/ (length hash-items) 2)] - (let [value (. hash-items (* 2 i))] - (table.insert item-tbl value))) - (t.make-list item-tbl))))))) - -(local mal-readline - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "vals takes 1 argument"))) - (let [prompt (t.get-value (. asts 1))] - (io.write prompt) - (io.flush) - (let [input (io.read) - trimmed (string.match input "^%s*(.-)%s*$")] - (if (> (length trimmed) 0) - (t.make-string trimmed) - t.mal-nil)))))) - -(local mal-meta - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "meta takes 1 argument"))) - (let [head-ast (. asts 1)] - (if (or (t.list?* head-ast) - (t.vector?* head-ast) - (t.hash-map?* head-ast) - (t.fn?* head-ast)) - (t.get-md head-ast) - t.mal-nil))))) - -(local mal-with-meta - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "with-meta takes 2 arguments"))) - (let [target-ast (. asts 1) - meta-ast (. asts 2)] - (if (t.list?* target-ast) - (t.make-list (t.get-value target-ast) meta-ast) - ;; - (t.vector?* target-ast) - (t.make-vector (t.get-value target-ast) meta-ast) - ;; - (t.hash-map?* target-ast) - (t.make-hash-map (t.get-value target-ast) meta-ast) - ;; - (t.fn?* target-ast) - (t.clone-with-meta target-ast meta-ast) - ;; - (u.throw* - (t.make-string "Expected list, vector, hash-map, or fn"))))))) - -(local mal-string? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "string? takes 1 argument"))) - (t.make-boolean (t.string?* (. asts 1)))))) - -(local mal-number? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "number? takes 1 argument"))) - (t.make-boolean (t.number?* (. asts 1)))))) - -(local mal-fn? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "fn? takes 1 argument"))) - (let [target-ast (. asts 1)] - (if (and (t.fn?* target-ast) - (not (t.get-is-macro target-ast))) - t.mal-true - t.mal-false))))) - -(local mal-macro? - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "macro? requires 1 argument"))) - (let [the-ast (. asts 1)] - (if (t.macro?* the-ast) - t.mal-true - t.mal-false))))) - -(local mal-conj - (t.make-fn - (fn [asts] - (when (< (length asts) 2) - (u.throw* (t.make-string "conj takes at least 2 arguments"))) - (let [coll-ast (. asts 1) - item-asts (u.slice asts 2 -1)] - (if (t.nil?* coll-ast) - (t.make-list (u.reverse item-asts)) - ;; - (t.list?* coll-ast) - (t.make-list (u.concat-two (u.reverse item-asts) - (t.get-value coll-ast))) - ;; - (t.vector?* coll-ast) - (t.make-vector (u.concat-two (t.get-value coll-ast) - item-asts)) - ;; - (u.throw* (t.make-string "Expected list, vector, or nil"))))))) - -(local mal-seq - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "seq takes 1 argument"))) - (let [arg-ast (. asts 1)] - (if (t.list?* arg-ast) - (if (t.empty?* arg-ast) - t.mal-nil - arg-ast) - ;; - (t.vector?* arg-ast) - (if (t.empty?* arg-ast) - t.mal-nil - (t.make-list (t.get-value arg-ast))) - ;; - (t.string?* arg-ast) - (let [a-str (t.get-value arg-ast) - str-len (length a-str)] - (if (= str-len 0) - t.mal-nil - (do - (local str-tbl []) - (for [i 1 (length a-str)] - (table.insert str-tbl - (t.make-string (string.sub a-str i i)))) - (t.make-list str-tbl)))) - ;; - (t.nil?* arg-ast) - arg-ast - ;; - (u.throw* - (t.make-string "Expected list, vector, string, or nil"))))))) - -(local mal-time-ms - (t.make-fn - (fn [asts] - (t.make-number - (math.floor (* 1000000 (os.clock))))))) - -(fn fennel-eval* - [fennel-val] - (if (= "nil" (type fennel-val)) - t.mal-nil - (= "boolean" (type fennel-val)) - (t.make-boolean fennel-val) - (= "string" (type fennel-val)) - (t.make-string fennel-val) - (= "number" (type fennel-val)) - (t.make-number fennel-val) - (= "table" (type fennel-val)) - (t.make-list (u.map fennel-eval* fennel-val)) - (u.throw* - (t.make-string (.. "Unsupported type: " (type fennel-val)))))) - -(local mal-fennel-eval - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* (t.make-string "fennel-eval takes 1 argument"))) - (let [head-ast (. asts 1)] - (when (not (t.string?* head-ast)) - (u.throw* (t.make-string - "fennel-eval first argument should be a string"))) - (let [(ok? result) (pcall fennel.eval (t.get-value head-ast))] - (if ok? - (fennel-eval* result) - (u.throw* - (t.make-string (.. "Eval failed: " result))))))))) - -{"+" (t.make-fn (fn [asts] - (var total 0) - (each [i val (ipairs asts)] - (set total - (+ total (t.get-value val)))) - (t.make-number total))) - "-" (t.make-fn (fn [asts] - (var total 0) - (let [n-args (length asts)] - (if (= 0 n-args) - (t.make-number 0) - (= 1 n-args) - (t.make-number (- 0 (t.get-value (. asts 1)))) - (do - (set total (t.get-value (. asts 1))) - (for [idx 2 n-args] - (let [cur (t.get-value (. asts idx))] - (set total - (- total cur)))) - (t.make-number total)))))) - "*" (t.make-fn (fn [asts] - (var total 1) - (each [i val (ipairs asts)] - (set total - (* total (t.get-value val)))) - (t.make-number total))) - "/" (t.make-fn (fn [asts] - (var total 1) - (let [n-args (length asts)] - (if (= 0 n-args) - (t.make-number 1) - (= 1 n-args) - (t.make-number (/ 1 (t.get-value (. asts 1)))) - (do - (set total (t.get-value (. asts 1))) - (for [idx 2 n-args] - (let [cur (t.get-value (. asts idx))] - (set total - (/ total cur)))) - (t.make-number total)))))) - "list" mal-list - "list?" mal-list? - "empty?" mal-empty? - "count" mal-count - "=" mal-= - "<" (t.make-fn (fn [asts] - (let [val-1 (t.get-value (. asts 1)) - val-2 (t.get-value (. asts 2))] - (t.make-boolean (< val-1 val-2))))) - "<=" (t.make-fn (fn [asts] - (let [val-1 (t.get-value (. asts 1)) - val-2 (t.get-value (. asts 2))] - (t.make-boolean (<= val-1 val-2))))) - ">" (t.make-fn (fn [asts] - (let [val-1 (t.get-value (. asts 1)) - val-2 (t.get-value (. asts 2))] - (t.make-boolean (> val-1 val-2))))) - ">=" (t.make-fn (fn [asts] - (let [val-1 (t.get-value (. asts 1)) - val-2 (t.get-value (. asts 2))] - (t.make-boolean (>= val-1 val-2))))) - "pr-str" mal-pr-str - "str" mal-str - "prn" mal-prn - "println" mal-println - "read-string" mal-read-string - "slurp" mal-slurp - "atom" mal-atom - "atom?" mal-atom? - "deref" mal-deref - "reset!" mal-reset! - "swap!" mal-swap! - "cons" mal-cons - "concat" mal-concat - "vec" mal-vec - "nth" mal-nth - "first" mal-first - "rest" mal-rest - "throw" mal-throw - "apply" mal-apply - "map" mal-map - "nil?" mal-nil? - "true?" mal-true? - "false?" mal-false? - "symbol?" mal-symbol? - "symbol" mal-symbol - "keyword" mal-keyword - "keyword?" mal-keyword? - "vector" mal-vector - "vector?" mal-vector? - "sequential?" mal-sequential? - "map?" mal-map? - "hash-map" mal-hash-map - "assoc" mal-assoc - "dissoc" mal-dissoc - "get" mal-get - "contains?" mal-contains? - "keys" mal-keys - "vals" mal-vals - "readline" mal-readline - "meta" mal-meta - "with-meta" mal-with-meta - "string?" mal-string? - "number?" mal-number? - "fn?" mal-fn? - "macro?" mal-macro? - "conj" mal-conj - "seq" mal-seq - "time-ms" mal-time-ms - "fennel-eval" mal-fennel-eval -} +(local t (require :types)) +(local u (require :utils)) +(local printer (require :printer)) +(local reader (require :reader)) +(local fennel (require :fennel)) + +(local mal-list + (t.make-fn + (fn [asts] + (t.make-list asts)))) + +(local mal-list? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "list? takes 1 argument"))) + (t.make-boolean (t.list?* (. asts 1)))))) + +(local mal-empty? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "empty? takes 1 argument"))) + (let [arg-ast (. asts 1)] + (if (t.nil?* arg-ast) + t.mal-true + (t.make-boolean (t.empty?* arg-ast))))))) + +(local mal-count + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "count takes 1 argument"))) + (let [arg-ast (. asts 1)] + (if (t.nil?* arg-ast) + (t.make-number 0) + (t.make-number (length (t.get-value arg-ast)))))))) + +(local mal-= + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "= takes 2 arguments"))) + (let [ast-1 (. asts 1) + ast-2 (. asts 2)] + (if (t.equals?* ast-1 ast-2) + t.mal-true + t.mal-false))))) + +(local mal-pr-str + (t.make-fn + (fn [asts] + (local buf []) + (when (> (length asts) 0) + (each [i ast (ipairs asts)] + (table.insert buf (printer.pr_str ast true)) + (table.insert buf " ")) + ;; remove extra space at end + (table.remove buf)) + (t.make-string (table.concat buf))))) + +(local mal-str + (t.make-fn + (fn [asts] + (local buf []) + (when (> (length asts) 0) + (each [i ast (ipairs asts)] + (table.insert buf (printer.pr_str ast false)))) + (t.make-string (table.concat buf))))) + +(local mal-prn + (t.make-fn + (fn [asts] + (local buf []) + (when (> (length asts) 0) + (each [i ast (ipairs asts)] + (table.insert buf (printer.pr_str ast true)) + (table.insert buf " ")) + ;; remove extra space at end + (table.remove buf)) + (print (table.concat buf)) + t.mal-nil))) + +(local mal-println + (t.make-fn + (fn [asts] + (local buf []) + (when (> (length asts) 0) + (each [i ast (ipairs asts)] + (table.insert buf (printer.pr_str ast false)) + (table.insert buf " ")) + ;; remove extra space at end + (table.remove buf)) + (print (table.concat buf)) + t.mal-nil))) + +(local mal-read-string + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "read-string takes 1 argument"))) + (let [res (reader.read_str (t.get-value (. asts 1)))] + (if res + res + (u.throw* (t.make-string "No code content"))))))) + +(local mal-slurp + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "slurp takes 1 argument"))) + (let [a-str (t.get-value (. asts 1))] + ;; XXX: error handling? + (with-open [f (io.open a-str)] + ;; XXX: escaping? + (t.make-string (f:read "*a"))))))) + +(local mal-atom + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "atom takes 1 argument"))) + (t.make-atom (. asts 1))))) + +(local mal-atom? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "atom? takes 1 argument"))) + (if (t.atom?* (. asts 1)) + t.mal-true + t.mal-false)))) + +(local mal-deref + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "deref takes 1 argument"))) + (let [ast (. asts 1)] + (t.deref* ast))))) + +(local mal-reset! + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "reset! takes 2 arguments"))) + (let [atom-ast (. asts 1) + val-ast (. asts 2)] + (t.reset!* atom-ast val-ast))))) + +(local mal-swap! + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "swap! takes at least 2 arguments"))) + (let [atom-ast (. asts 1) + fn-ast (. asts 2) + args-asts (u.slice asts 3 -1) + args-tbl [(t.deref* atom-ast) (table.unpack args-asts)]] + (t.reset!* atom-ast + ((t.get-value fn-ast) args-tbl)))))) + +(local mal-cons + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "cons takes 2 arguments"))) + (let [head-ast (. asts 1) + tail-ast (. asts 2)] + (t.make-list [head-ast + (table.unpack (t.get-value tail-ast))]))))) + +(local mal-concat + (t.make-fn + (fn [asts] + (local acc []) + (for [i 1 (length asts)] + (each [j elt (ipairs (t.get-value (. asts i)))] + (table.insert acc elt))) + (t.make-list acc)))) + +(local mal-vec + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "vec takes 1 argument"))) + (let [ast (. asts 1)] + (if (t.vector?* ast) + ast + ;; + (t.list?* ast) + (t.make-vector (t.get-value ast)) + ;; + (t.nil?* ast) + (t.make-vector []) + ;; + (u.throw* (t.make-string "vec takes a vector, list, or nil"))))))) + +(local mal-nth + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "nth takes 2 arguments"))) + (let [elts (t.get-value (. asts 1)) + i (t.get-value (. asts 2))] + (if (< i (length elts)) + (. elts (+ i 1)) + (u.throw* (t.make-string (.. "Index out of range: " i)))))))) + +(local mal-first + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "first takes 1 argument"))) + (let [coll-or-nil-ast (. asts 1)] + (if (or (t.nil?* coll-or-nil-ast) + (t.empty?* coll-or-nil-ast)) + t.mal-nil + (. (t.get-value coll-or-nil-ast) 1)))))) + +(local mal-rest + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "rest takes 1 argument"))) + (let [coll-or-nil-ast (. asts 1)] + (if (or (t.nil?* coll-or-nil-ast) + (t.empty?* coll-or-nil-ast)) + (t.make-list []) + (t.make-list (u.slice (t.get-value coll-or-nil-ast) 2 -1))))))) + +(local mal-throw + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "throw takes 1 argument"))) + (u.throw* (. asts 1))))) + +;; (apply F A B [C D]) is equivalent to (F A B C D) +(local mal-apply + (t.make-fn + (fn [asts] + (let [n-asts (length asts)] + (when (< n-asts 1) + (u.throw* (t.make-string "apply takes at least 1 argument"))) + (let [the-fn (t.get-value (. asts 1))] ; e.g. F + (if (= n-asts 1) + (the-fn []) + (= n-asts 2) + (the-fn [(table.unpack (t.get-value (. asts 2)))]) + (let [args-asts (u.slice asts 2 -2) ; e.g. [A B] + last-asts (t.get-value (u.last asts)) ; e.g. [C D] + fn-args-tbl []] + (each [i elt (ipairs args-asts)] + (table.insert fn-args-tbl elt)) + (each [i elt (ipairs last-asts)] + (table.insert fn-args-tbl elt)) + (the-fn fn-args-tbl)))))))) + +(local mal-map + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "map takes at least 2 arguments"))) + (let [the-fn (t.get-value (. asts 1)) + coll (t.get-value (. asts 2))] + (t.make-list (u.map #(the-fn [$]) coll)))))) + +(local mal-nil? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "nil? takes 1 argument"))) + (if (t.nil?* (. asts 1)) + t.mal-true + t.mal-false)))) + +(local mal-true? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "true? takes 1 argument"))) + (if (t.true?* (. asts 1)) + t.mal-true + t.mal-false)))) + +(local mal-false? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "false? takes 1 argument"))) + (if (t.false?* (. asts 1)) + t.mal-true + t.mal-false)))) + +(local mal-symbol? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "symbol? takes 1 argument"))) + (if (t.symbol?* (. asts 1)) + t.mal-true + t.mal-false)))) + +(local mal-symbol + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "symbol takes 1 argument"))) + ;; XXX: check that type is string? + (t.make-symbol (t.get-value (. asts 1)))))) + +(local mal-keyword + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "keyword takes 1 argument"))) + (let [arg-ast (. asts 1)] + (if (t.keyword?* arg-ast) + arg-ast + ;; + (t.string?* arg-ast) + (t.make-keyword (.. ":" (t.get-value arg-ast))) + ;; + (u.throw* (t.make-string "Expected string"))))))) + +(local mal-keyword? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "keyword? takes 1 argument"))) + (if (t.keyword?* (. asts 1)) + t.mal-true + t.mal-false)))) + +(local mal-vector + (t.make-fn + (fn [asts] + (t.make-vector asts)))) + +(local mal-vector? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "vector? takes 1 argument"))) + (if (t.vector?* (. asts 1)) + t.mal-true + t.mal-false)))) + +(local mal-sequential? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "sequential? takes 1 argument"))) + (if (or (t.list?* (. asts 1)) + (t.vector?* (. asts 1))) + t.mal-true + t.mal-false)))) + +(local mal-map? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "map? takes 1 argument"))) + (if (t.hash-map?* (. asts 1)) + t.mal-true + t.mal-false)))) + +(local mal-hash-map + (t.make-fn + (fn [asts] + (when (= 1 (% (length asts) 2)) + (u.throw* (t.make-string + "hash-map takes an even number of arguments"))) + (t.make-hash-map asts)))) + +(local mal-assoc + (t.make-fn + (fn [asts] + (when (< (length asts) 3) + (u.throw* (t.make-string "assoc takes at least 3 arguments"))) + (let [head-ast (. asts 1)] + (when (not (or (t.hash-map?* head-ast) + (t.nil?* head-ast))) + (u.throw* (t.make-string + "assoc first argument should be a hash-map or nil"))) + (if (t.nil?* head-ast) + t.mal-nil + (let [item-tbl [] + kv-asts (u.slice asts 2 -1) + hash-items (t.get-value head-ast)] + (for [i 1 (/ (length hash-items) 2)] + (let [key (. hash-items (- (* 2 i) 1))] + (var idx 1) + (var found false) + (while (and (not found) + (<= idx (length kv-asts))) + (if (t.equals?* key (. kv-asts idx)) + (set found true) + (set idx (+ idx 2)))) + (if (not found) + (do + (table.insert item-tbl key) + (table.insert item-tbl (. hash-items (* 2 i)))) + (do + (table.insert item-tbl key) + (table.insert item-tbl (. kv-asts (+ idx 1))) + (table.remove kv-asts (+ idx 1)) + (table.remove kv-asts idx))))) + (each [i elt (ipairs kv-asts)] + (table.insert item-tbl elt)) + (t.make-hash-map item-tbl))))))) + +(local mal-dissoc + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "dissoc takes at least 2 arguments"))) + (let [head-ast (. asts 1)] + (when (not (or (t.hash-map?* head-ast) + (t.nil?* head-ast))) + (u.throw* (t.make-string + "dissoc first argument should be a hash-map or nil"))) + (if (t.nil?* head-ast) + t.mal-nil + (let [item-tbl [] + key-asts (u.slice asts 2 -1) + hash-items (t.get-value head-ast)] + (for [i 1 (/ (length hash-items) 2)] + (let [key (. hash-items (- (* 2 i) 1))] + (var idx 1) + (var found false) + (while (and (not found) + (<= idx (length key-asts))) + (if (t.equals?* key (. key-asts idx)) + (set found true) + (set idx (+ idx 1)))) + (when (not found) + (table.insert item-tbl key) + (table.insert item-tbl (. hash-items (* 2 i)))))) + (t.make-hash-map item-tbl))))))) + +(local mal-get + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "get takes 2 arguments"))) + (let [head-ast (. asts 1)] + (when (not (or (t.hash-map?* head-ast) + (t.nil?* head-ast))) + (u.throw* (t.make-string + "get first argument should be a hash-map or nil"))) + (if (t.nil?* head-ast) + t.mal-nil + (let [hash-items (t.get-value head-ast) + key-ast (. asts 2)] + (var idx 1) + (var found false) + (while (and (not found) + (<= idx (length hash-items))) + (if (t.equals?* key-ast (. hash-items idx)) + (set found true) + (set idx (+ idx 1)))) + (if found + (. hash-items (+ idx 1)) + t.mal-nil))))))) + +(local mal-contains? + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "contains? takes 2 arguments"))) + (let [head-ast (. asts 1)] + (when (not (or (t.hash-map?* head-ast) + (t.nil?* head-ast))) + (u.throw* (t.make-string + "contains? first argument should be a hash-map or nil"))) + (if (t.nil?* head-ast) + t.mal-nil + (let [hash-items (t.get-value head-ast) + key-ast (. asts 2)] + (var idx 1) + (var found false) + (while (and (not found) + (<= idx (length hash-items))) + (if (t.equals?* key-ast (. hash-items idx)) + (set found true) + (set idx (+ idx 1)))) + (if found + t.mal-true + t.mal-false))))))) + +(local mal-keys + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "keys takes 1 argument"))) + (let [head-ast (. asts 1)] + (when (not (or (t.hash-map?* head-ast) + (t.nil?* head-ast))) + (u.throw* (t.make-string + "keys first argument should be a hash-map or nil"))) + (if (t.nil?* head-ast) + t.mal-nil + (let [item-tbl [] + hash-items (t.get-value head-ast)] + (for [i 1 (/ (length hash-items) 2)] + (let [key (. hash-items (- (* 2 i) 1))] + (table.insert item-tbl key))) + (t.make-list item-tbl))))))) + +(local mal-vals + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "vals takes 1 argument"))) + (let [head-ast (. asts 1)] + (when (not (or (t.hash-map?* head-ast) + (t.nil?* head-ast))) + (u.throw* (t.make-string + "vals first argument should be a hash-map or nil"))) + (if (t.nil?* head-ast) + t.mal-nil + (let [item-tbl [] + hash-items (t.get-value head-ast)] + (for [i 1 (/ (length hash-items) 2)] + (let [value (. hash-items (* 2 i))] + (table.insert item-tbl value))) + (t.make-list item-tbl))))))) + +(local mal-readline + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "vals takes 1 argument"))) + (let [prompt (t.get-value (. asts 1))] + (io.write prompt) + (io.flush) + (let [input (io.read) + trimmed (string.match input "^%s*(.-)%s*$")] + (if (> (length trimmed) 0) + (t.make-string trimmed) + t.mal-nil)))))) + +(local mal-meta + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "meta takes 1 argument"))) + (let [head-ast (. asts 1)] + (if (or (t.list?* head-ast) + (t.vector?* head-ast) + (t.hash-map?* head-ast) + (t.fn?* head-ast)) + (t.get-md head-ast) + t.mal-nil))))) + +(local mal-with-meta + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "with-meta takes 2 arguments"))) + (let [target-ast (. asts 1) + meta-ast (. asts 2)] + (if (t.list?* target-ast) + (t.make-list (t.get-value target-ast) meta-ast) + ;; + (t.vector?* target-ast) + (t.make-vector (t.get-value target-ast) meta-ast) + ;; + (t.hash-map?* target-ast) + (t.make-hash-map (t.get-value target-ast) meta-ast) + ;; + (t.fn?* target-ast) + (t.clone-with-meta target-ast meta-ast) + ;; + (u.throw* + (t.make-string "Expected list, vector, hash-map, or fn"))))))) + +(local mal-string? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "string? takes 1 argument"))) + (t.make-boolean (t.string?* (. asts 1)))))) + +(local mal-number? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "number? takes 1 argument"))) + (t.make-boolean (t.number?* (. asts 1)))))) + +(local mal-fn? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "fn? takes 1 argument"))) + (let [target-ast (. asts 1)] + (if (and (t.fn?* target-ast) + (not (t.get-is-macro target-ast))) + t.mal-true + t.mal-false))))) + +(local mal-macro? + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "macro? requires 1 argument"))) + (let [the-ast (. asts 1)] + (if (t.macro?* the-ast) + t.mal-true + t.mal-false))))) + +(local mal-conj + (t.make-fn + (fn [asts] + (when (< (length asts) 2) + (u.throw* (t.make-string "conj takes at least 2 arguments"))) + (let [coll-ast (. asts 1) + item-asts (u.slice asts 2 -1)] + (if (t.nil?* coll-ast) + (t.make-list (u.reverse item-asts)) + ;; + (t.list?* coll-ast) + (t.make-list (u.concat-two (u.reverse item-asts) + (t.get-value coll-ast))) + ;; + (t.vector?* coll-ast) + (t.make-vector (u.concat-two (t.get-value coll-ast) + item-asts)) + ;; + (u.throw* (t.make-string "Expected list, vector, or nil"))))))) + +(local mal-seq + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "seq takes 1 argument"))) + (let [arg-ast (. asts 1)] + (if (t.list?* arg-ast) + (if (t.empty?* arg-ast) + t.mal-nil + arg-ast) + ;; + (t.vector?* arg-ast) + (if (t.empty?* arg-ast) + t.mal-nil + (t.make-list (t.get-value arg-ast))) + ;; + (t.string?* arg-ast) + (let [a-str (t.get-value arg-ast) + str-len (length a-str)] + (if (= str-len 0) + t.mal-nil + (do + (local str-tbl []) + (for [i 1 (length a-str)] + (table.insert str-tbl + (t.make-string (string.sub a-str i i)))) + (t.make-list str-tbl)))) + ;; + (t.nil?* arg-ast) + arg-ast + ;; + (u.throw* + (t.make-string "Expected list, vector, string, or nil"))))))) + +(local mal-time-ms + (t.make-fn + (fn [asts] + (t.make-number + (math.floor (* 1000000 (os.clock))))))) + +(fn fennel-eval* + [fennel-val] + (if (= "nil" (type fennel-val)) + t.mal-nil + (= "boolean" (type fennel-val)) + (t.make-boolean fennel-val) + (= "string" (type fennel-val)) + (t.make-string fennel-val) + (= "number" (type fennel-val)) + (t.make-number fennel-val) + (= "table" (type fennel-val)) + (t.make-list (u.map fennel-eval* fennel-val)) + (u.throw* + (t.make-string (.. "Unsupported type: " (type fennel-val)))))) + +(local mal-fennel-eval + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* (t.make-string "fennel-eval takes 1 argument"))) + (let [head-ast (. asts 1)] + (when (not (t.string?* head-ast)) + (u.throw* (t.make-string + "fennel-eval first argument should be a string"))) + (let [(ok? result) (pcall fennel.eval (t.get-value head-ast))] + (if ok? + (fennel-eval* result) + (u.throw* + (t.make-string (.. "Eval failed: " result))))))))) + +{"+" (t.make-fn (fn [asts] + (var total 0) + (each [i val (ipairs asts)] + (set total + (+ total (t.get-value val)))) + (t.make-number total))) + "-" (t.make-fn (fn [asts] + (var total 0) + (let [n-args (length asts)] + (if (= 0 n-args) + (t.make-number 0) + (= 1 n-args) + (t.make-number (- 0 (t.get-value (. asts 1)))) + (do + (set total (t.get-value (. asts 1))) + (for [idx 2 n-args] + (let [cur (t.get-value (. asts idx))] + (set total + (- total cur)))) + (t.make-number total)))))) + "*" (t.make-fn (fn [asts] + (var total 1) + (each [i val (ipairs asts)] + (set total + (* total (t.get-value val)))) + (t.make-number total))) + "/" (t.make-fn (fn [asts] + (var total 1) + (let [n-args (length asts)] + (if (= 0 n-args) + (t.make-number 1) + (= 1 n-args) + (t.make-number (/ 1 (t.get-value (. asts 1)))) + (do + (set total (t.get-value (. asts 1))) + (for [idx 2 n-args] + (let [cur (t.get-value (. asts idx))] + (set total + (/ total cur)))) + (t.make-number total)))))) + "list" mal-list + "list?" mal-list? + "empty?" mal-empty? + "count" mal-count + "=" mal-= + "<" (t.make-fn (fn [asts] + (let [val-1 (t.get-value (. asts 1)) + val-2 (t.get-value (. asts 2))] + (t.make-boolean (< val-1 val-2))))) + "<=" (t.make-fn (fn [asts] + (let [val-1 (t.get-value (. asts 1)) + val-2 (t.get-value (. asts 2))] + (t.make-boolean (<= val-1 val-2))))) + ">" (t.make-fn (fn [asts] + (let [val-1 (t.get-value (. asts 1)) + val-2 (t.get-value (. asts 2))] + (t.make-boolean (> val-1 val-2))))) + ">=" (t.make-fn (fn [asts] + (let [val-1 (t.get-value (. asts 1)) + val-2 (t.get-value (. asts 2))] + (t.make-boolean (>= val-1 val-2))))) + "pr-str" mal-pr-str + "str" mal-str + "prn" mal-prn + "println" mal-println + "read-string" mal-read-string + "slurp" mal-slurp + "atom" mal-atom + "atom?" mal-atom? + "deref" mal-deref + "reset!" mal-reset! + "swap!" mal-swap! + "cons" mal-cons + "concat" mal-concat + "vec" mal-vec + "nth" mal-nth + "first" mal-first + "rest" mal-rest + "throw" mal-throw + "apply" mal-apply + "map" mal-map + "nil?" mal-nil? + "true?" mal-true? + "false?" mal-false? + "symbol?" mal-symbol? + "symbol" mal-symbol + "keyword" mal-keyword + "keyword?" mal-keyword? + "vector" mal-vector + "vector?" mal-vector? + "sequential?" mal-sequential? + "map?" mal-map? + "hash-map" mal-hash-map + "assoc" mal-assoc + "dissoc" mal-dissoc + "get" mal-get + "contains?" mal-contains? + "keys" mal-keys + "vals" mal-vals + "readline" mal-readline + "meta" mal-meta + "with-meta" mal-with-meta + "string?" mal-string? + "number?" mal-number? + "fn?" mal-fn? + "macro?" mal-macro? + "conj" mal-conj + "seq" mal-seq + "time-ms" mal-time-ms + "fennel-eval" mal-fennel-eval +} diff --git a/impls/fennel/env.fnl b/impls/fennel/env.fnl index 995231bf5b..aa383ddb5a 100644 --- a/impls/fennel/env.fnl +++ b/impls/fennel/env.fnl @@ -1,99 +1,99 @@ -(local t (require :types)) -(local u (require :utils)) - -(fn make-env - [outer binds exprs] - (local tbl {}) - (when binds - (local n-binds (length binds)) - (var found-amp false) - (var i 1) - (while (and (not found-amp) - (<= i n-binds)) - (local c-bind (. binds i)) - (if (= (t.get-value c-bind) "&") - (set found-amp true) - (set i (+ i 1)))) - (if (not found-amp) - (for [j 1 n-binds] - (tset tbl - (t.get-value (. binds j)) - (. exprs j))) - (do ; houston, there was an ampersand - (for [j 1 (- i 1)] ; things before & - (tset tbl - (t.get-value (. binds j)) - (. exprs j))) - (tset tbl ; after &, put things in a list - (t.get-value (. binds (+ i 1))) - (t.make-list (u.slice exprs i -1)))))) - {:outer outer - :data tbl}) - -(fn env-set - [env sym-ast val-ast] - (tset (. env :data) - (t.get-value sym-ast) - val-ast) - env) - -(fn env-find - [env sym-ast] - (let [inner-env (. env :data) - val-ast (. inner-env (t.get-value sym-ast))] - (if val-ast - env - (let [outer (. env :outer)] - (when outer - (env-find outer sym-ast)))))) - -(fn env-get - [env sym-ast] - (let [target-env (env-find env sym-ast)] - (if target-env - (. (. target-env :data) - (t.get-value sym-ast)) - (u.throw* - (t.make-string (.. "'" (t.get-value sym-ast) "'" - " not found")))))) - -(comment - - (local test-env (make-env {})) - - (env-set test-env - (t.make-symbol "fun") - (t.make-number 1)) - - (env-find test-env (t.make-symbol "fun")) - - (env-get test-env (t.make-symbol "fun")) - - (local test-env-2 (make-env nil)) - - (env-set test-env-2 - (t.make-symbol "smile") - (t.make-keyword ":yay")) - - (env-find test-env-2 (t.make-symbol "smile")) - - (env-get test-env-2 (t.make-symbol "smile")) - - (local test-env-3 (make-env nil)) - - (env-set test-env-3 - (t.make-symbol "+") - (fn [ast-1 ast-2] - (t.make-number (+ (t.get-value ast-1) - (t.get-value ast-2))))) - - (env-find test-env-3 (t.make-symbol "+")) - - (env-get test-env-3 (t.make-symbol "+")) - - ) - -{:make-env make-env - :env-set env-set - :env-find env-find - :env-get env-get} +(local t (require :types)) +(local u (require :utils)) + +(fn make-env + [outer binds exprs] + (local tbl {}) + (when binds + (local n-binds (length binds)) + (var found-amp false) + (var i 1) + (while (and (not found-amp) + (<= i n-binds)) + (local c-bind (. binds i)) + (if (= (t.get-value c-bind) "&") + (set found-amp true) + (set i (+ i 1)))) + (if (not found-amp) + (for [j 1 n-binds] + (tset tbl + (t.get-value (. binds j)) + (. exprs j))) + (do ; houston, there was an ampersand + (for [j 1 (- i 1)] ; things before & + (tset tbl + (t.get-value (. binds j)) + (. exprs j))) + (tset tbl ; after &, put things in a list + (t.get-value (. binds (+ i 1))) + (t.make-list (u.slice exprs i -1)))))) + {:outer outer + :data tbl}) + +(fn env-set + [env sym-ast val-ast] + (tset (. env :data) + (t.get-value sym-ast) + val-ast) + env) + +(fn env-find + [env sym-ast] + (let [inner-env (. env :data) + val-ast (. inner-env (t.get-value sym-ast))] + (if val-ast + env + (let [outer (. env :outer)] + (when outer + (env-find outer sym-ast)))))) + +(fn env-get + [env sym-ast] + (let [target-env (env-find env sym-ast)] + (if target-env + (. (. target-env :data) + (t.get-value sym-ast)) + (u.throw* + (t.make-string (.. "'" (t.get-value sym-ast) "'" + " not found")))))) + +(comment + + (local test-env (make-env {})) + + (env-set test-env + (t.make-symbol "fun") + (t.make-number 1)) + + (env-find test-env (t.make-symbol "fun")) + + (env-get test-env (t.make-symbol "fun")) + + (local test-env-2 (make-env nil)) + + (env-set test-env-2 + (t.make-symbol "smile") + (t.make-keyword ":yay")) + + (env-find test-env-2 (t.make-symbol "smile")) + + (env-get test-env-2 (t.make-symbol "smile")) + + (local test-env-3 (make-env nil)) + + (env-set test-env-3 + (t.make-symbol "+") + (fn [ast-1 ast-2] + (t.make-number (+ (t.get-value ast-1) + (t.get-value ast-2))))) + + (env-find test-env-3 (t.make-symbol "+")) + + (env-get test-env-3 (t.make-symbol "+")) + + ) + +{:make-env make-env + :env-set env-set + :env-find env-find + :env-get env-get} diff --git a/impls/fennel/printer.fnl b/impls/fennel/printer.fnl index 604ab9eaa1..ea301ca268 100644 --- a/impls/fennel/printer.fnl +++ b/impls/fennel/printer.fnl @@ -1,92 +1,92 @@ -(local t (require :types)) - -(fn escape - [a-str] - (pick-values 1 - (-> a-str - (string.gsub "\\" "\\\\") - (string.gsub "\"" "\\\"") - (string.gsub "\n" "\\n")))) - -(fn code* - [ast buf print_readably] - (let [value (t.get-value ast)] - (if (t.nil?* ast) - (table.insert buf value) - ;; - (t.boolean?* ast) - (table.insert buf (if value "true" "false")) - ;; - (t.number?* ast) - (table.insert buf (tostring value)) - ;; - (t.keyword?* ast) - (table.insert buf value) - ;; - (t.symbol?* ast) - (table.insert buf value) - ;; - (t.string?* ast) - (if print_readably - (do - (table.insert buf "\"") - (table.insert buf (escape value)) - (table.insert buf "\"")) - (table.insert buf value)) - ;; - (t.list?* ast) - (do - (table.insert buf "(") - (var remove false) - (each [idx elt (ipairs value)] - (code* elt buf print_readably) - (table.insert buf " ") - (set remove true)) - (when remove - (table.remove buf)) - (table.insert buf ")")) - ;; - (t.vector?* ast) - (do - (table.insert buf "[") - (var remove false) - (each [idx elt (ipairs value)] - (code* elt buf print_readably) - (table.insert buf " ") - (set remove true)) - (when remove - (table.remove buf)) - (table.insert buf "]")) - ;; - (t.hash-map?* ast) - (do - (table.insert buf "{") - (var remove false) - (each [idx elt (ipairs value)] - (code* elt buf print_readably) - (table.insert buf " ") - (set remove true)) - (when remove - (table.remove buf)) - (table.insert buf "}")) - ;; - (t.atom?* ast) - (do - (table.insert buf "(atom ") - (code* (t.get-value ast) buf print_readably) - (table.insert buf ")"))) - buf)) - -(fn pr_str - [ast print_readably] - (let [buf []] - (code* ast buf print_readably) - (table.concat buf))) - -(comment - - (pr_str (t.make-number 1) false) - - ) - -{:pr_str pr_str} +(local t (require :types)) + +(fn escape + [a-str] + (pick-values 1 + (-> a-str + (string.gsub "\\" "\\\\") + (string.gsub "\"" "\\\"") + (string.gsub "\n" "\\n")))) + +(fn code* + [ast buf print_readably] + (let [value (t.get-value ast)] + (if (t.nil?* ast) + (table.insert buf value) + ;; + (t.boolean?* ast) + (table.insert buf (if value "true" "false")) + ;; + (t.number?* ast) + (table.insert buf (tostring value)) + ;; + (t.keyword?* ast) + (table.insert buf value) + ;; + (t.symbol?* ast) + (table.insert buf value) + ;; + (t.string?* ast) + (if print_readably + (do + (table.insert buf "\"") + (table.insert buf (escape value)) + (table.insert buf "\"")) + (table.insert buf value)) + ;; + (t.list?* ast) + (do + (table.insert buf "(") + (var remove false) + (each [idx elt (ipairs value)] + (code* elt buf print_readably) + (table.insert buf " ") + (set remove true)) + (when remove + (table.remove buf)) + (table.insert buf ")")) + ;; + (t.vector?* ast) + (do + (table.insert buf "[") + (var remove false) + (each [idx elt (ipairs value)] + (code* elt buf print_readably) + (table.insert buf " ") + (set remove true)) + (when remove + (table.remove buf)) + (table.insert buf "]")) + ;; + (t.hash-map?* ast) + (do + (table.insert buf "{") + (var remove false) + (each [idx elt (ipairs value)] + (code* elt buf print_readably) + (table.insert buf " ") + (set remove true)) + (when remove + (table.remove buf)) + (table.insert buf "}")) + ;; + (t.atom?* ast) + (do + (table.insert buf "(atom ") + (code* (t.get-value ast) buf print_readably) + (table.insert buf ")"))) + buf)) + +(fn pr_str + [ast print_readably] + (let [buf []] + (code* ast buf print_readably) + (table.concat buf))) + +(comment + + (pr_str (t.make-number 1) false) + + ) + +{:pr_str pr_str} diff --git a/impls/fennel/reader.fnl b/impls/fennel/reader.fnl index 07fdc03aba..391f690dec 100644 --- a/impls/fennel/reader.fnl +++ b/impls/fennel/reader.fnl @@ -1,200 +1,200 @@ -(local t (require :types)) -(local u (require :utils)) - -(local lpeg (require :lpeg)) - -(local P lpeg.P) - -(local S lpeg.S) - -(local C lpeg.C) - -(local V lpeg.V) - -(local Cmt lpeg.Cmt) - -(fn unescape - [a-str] - (pick-values 1 - (-> a-str - (string.gsub "\\\\" "\u{029e}") ;; temporarily hide - (string.gsub "\\\"" "\"") - (string.gsub "\\n" "\n") - (string.gsub "\u{029e}" "\\")))) ;; now replace - -(local grammar - {1 "main" - "main" (^ (V "input") 1) - "input" (+ (V "gap") (V "form")) - "gap" (+ (V "ws") (V "comment")) - "ws" (^ (S " \f\n\r\t,") 1) - "comment" (* ";" - (^ (- (P 1) (S "\r\n")) - 0)) - "form" (+ (V "boolean") (V "nil") - (V "number") (V "keyword") (V "symbol") (V "string") - (V "list") (V "vector") (V "hash-map") - (V "deref") (V "quasiquote") (V "quote") - (V "splice-unquote") - (V "unquote") - (V "with-meta")) - "name-char" (- (P 1) - (S " \f\n\r\t,[]{}()'`~^@\";")) - "nil" (Cmt (C (* (P "nil") - (- (V "name-char")))) - (fn [s i a] - (values i t.mal-nil))) - "boolean" (Cmt (C (* (+ (P "false") (P "true")) - (- (V "name-char")))) - (fn [s i a] - (values i (if (= a "true") - t.mal-true - t.mal-false)))) - "number" (Cmt (C (^ (- (P 1) - (S " \f\n\r\t,[]{}()'`~^@\";")) - 1)) - (fn [s i a] - (let [result (tonumber a)] - (if result - (values i (t.make-number result)) - nil)))) - "keyword" (Cmt (C (* ":" - (^ (V "name-char") 0))) - (fn [s i a] - (values i (t.make-keyword a)))) - "symbol" (Cmt (^ (V "name-char") 1) - (fn [s i a] - (values i (t.make-symbol a)))) - "string" (* (P "\"") - (Cmt (C (* (^ (- (P 1) - (S "\"\\")) - 0) - (^ (* (P "\\") - (P 1) - (^ (- (P 1) - (S "\"\\")) - 0)) - 0))) - (fn [s i a] - (values i (t.make-string (unescape a))))) - (+ (P "\"") - (P (fn [s i] - (error "unbalanced \""))))) - "list" (* (P "(") - (Cmt (C (^ (V "input") 0)) - (fn [s i a ...] - (values i (t.make-list [...])))) - (+ (P ")") - (P (fn [s i] - (error "unbalanced )"))))) - "vector" (* (P "[") - (Cmt (C (^ (V "input") 0)) - (fn [s i a ...] - (values i (t.make-vector [...])))) - (+ (P "]") - (P (fn [s i] - (error "unbalanced ]"))))) - "hash-map" (* (P "{") - (Cmt (C (^ (V "input") 0)) - (fn [s i a ...] - (values i (t.make-hash-map [...])))) - (+ (P "}") - (P (fn [s i] - (error "unbalanced }"))))) - "deref" (Cmt (C (* (P "@") - (V "form"))) - (fn [s i ...] - (let [content [(t.make-symbol "deref")]] - (table.insert content (. [...] 2)) - (values i (t.make-list content))))) - "quasiquote" (Cmt (C (* (P "`") - (V "form"))) - (fn [s i ...] - (let [content [(t.make-symbol "quasiquote")]] - (table.insert content (. [...] 2)) - (values i (t.make-list content))))) - "quote" (Cmt (C (* (P "'") - (V "form"))) - (fn [s i ...] - (let [content [(t.make-symbol "quote")]] - (table.insert content (. [...] 2)) - (values i (t.make-list content))))) - "splice-unquote" (Cmt (C (* (P "~@") - (V "form"))) - (fn [s i ...] - (let [content [(t.make-symbol "splice-unquote")]] - (table.insert content (. [...] 2)) - (values i (t.make-list content))))) - "unquote" (Cmt (C (* (P "~") - (V "form"))) - (fn [s i ...] - (let [content [(t.make-symbol "unquote")]] - (table.insert content (. [...] 2)) - (values i (t.make-list content))))) - "with-meta" (Cmt (C (* (P "^") - (V "form") - (^ (V "gap") 1) - (V "form"))) - (fn [s i ...] - (let [content [(t.make-symbol "with-meta")]] - (table.insert content (. [...] 3)) - (table.insert content (. [...] 2)) - (values i (t.make-list content))))) - }) - -(comment - - (lpeg.match grammar "; hello") - - (lpeg.match grammar "nil") - - (lpeg.match grammar "true") - - (lpeg.match grammar "false") - - (lpeg.match grammar "1.2") - - (lpeg.match grammar "(+ 1 1)") - - (lpeg.match grammar "[:a :b :c]") - - (lpeg.match grammar "\"hello there\"") - - (lpeg.match grammar "\"hello\" there\"") - -) - -(fn read_str - [a-str] - (let [(ok? result) (pcall lpeg.match grammar a-str)] - (if ok? - (let [res-type (type result)] - (if (= res-type "table") - result - (u.throw* t.mal-nil))) - (u.throw* - (t.make-string result))))) - -(comment - - (read_str "; hello") - - (read_str "nil") - - (read_str "true") - - (read_str "false") - - (read_str "1.2") - - (read_str "(+ 1 1)") - - (read_str "[:a :b :c]") - - (read_str "\"hello there\"") - - (read_str "\"hello\" there\"") - - ) - -{:read_str read_str} +(local t (require :types)) +(local u (require :utils)) + +(local lpeg (require :lpeg)) + +(local P lpeg.P) + +(local S lpeg.S) + +(local C lpeg.C) + +(local V lpeg.V) + +(local Cmt lpeg.Cmt) + +(fn unescape + [a-str] + (pick-values 1 + (-> a-str + (string.gsub "\\\\" "\u{029e}") ;; temporarily hide + (string.gsub "\\\"" "\"") + (string.gsub "\\n" "\n") + (string.gsub "\u{029e}" "\\")))) ;; now replace + +(local grammar + {1 "main" + "main" (^ (V "input") 1) + "input" (+ (V "gap") (V "form")) + "gap" (+ (V "ws") (V "comment")) + "ws" (^ (S " \f\n\r\t,") 1) + "comment" (* ";" + (^ (- (P 1) (S "\r\n")) + 0)) + "form" (+ (V "boolean") (V "nil") + (V "number") (V "keyword") (V "symbol") (V "string") + (V "list") (V "vector") (V "hash-map") + (V "deref") (V "quasiquote") (V "quote") + (V "splice-unquote") + (V "unquote") + (V "with-meta")) + "name-char" (- (P 1) + (S " \f\n\r\t,[]{}()'`~^@\";")) + "nil" (Cmt (C (* (P "nil") + (- (V "name-char")))) + (fn [s i a] + (values i t.mal-nil))) + "boolean" (Cmt (C (* (+ (P "false") (P "true")) + (- (V "name-char")))) + (fn [s i a] + (values i (if (= a "true") + t.mal-true + t.mal-false)))) + "number" (Cmt (C (^ (- (P 1) + (S " \f\n\r\t,[]{}()'`~^@\";")) + 1)) + (fn [s i a] + (let [result (tonumber a)] + (if result + (values i (t.make-number result)) + nil)))) + "keyword" (Cmt (C (* ":" + (^ (V "name-char") 0))) + (fn [s i a] + (values i (t.make-keyword a)))) + "symbol" (Cmt (^ (V "name-char") 1) + (fn [s i a] + (values i (t.make-symbol a)))) + "string" (* (P "\"") + (Cmt (C (* (^ (- (P 1) + (S "\"\\")) + 0) + (^ (* (P "\\") + (P 1) + (^ (- (P 1) + (S "\"\\")) + 0)) + 0))) + (fn [s i a] + (values i (t.make-string (unescape a))))) + (+ (P "\"") + (P (fn [s i] + (error "unbalanced \""))))) + "list" (* (P "(") + (Cmt (C (^ (V "input") 0)) + (fn [s i a ...] + (values i (t.make-list [...])))) + (+ (P ")") + (P (fn [s i] + (error "unbalanced )"))))) + "vector" (* (P "[") + (Cmt (C (^ (V "input") 0)) + (fn [s i a ...] + (values i (t.make-vector [...])))) + (+ (P "]") + (P (fn [s i] + (error "unbalanced ]"))))) + "hash-map" (* (P "{") + (Cmt (C (^ (V "input") 0)) + (fn [s i a ...] + (values i (t.make-hash-map [...])))) + (+ (P "}") + (P (fn [s i] + (error "unbalanced }"))))) + "deref" (Cmt (C (* (P "@") + (V "form"))) + (fn [s i ...] + (let [content [(t.make-symbol "deref")]] + (table.insert content (. [...] 2)) + (values i (t.make-list content))))) + "quasiquote" (Cmt (C (* (P "`") + (V "form"))) + (fn [s i ...] + (let [content [(t.make-symbol "quasiquote")]] + (table.insert content (. [...] 2)) + (values i (t.make-list content))))) + "quote" (Cmt (C (* (P "'") + (V "form"))) + (fn [s i ...] + (let [content [(t.make-symbol "quote")]] + (table.insert content (. [...] 2)) + (values i (t.make-list content))))) + "splice-unquote" (Cmt (C (* (P "~@") + (V "form"))) + (fn [s i ...] + (let [content [(t.make-symbol "splice-unquote")]] + (table.insert content (. [...] 2)) + (values i (t.make-list content))))) + "unquote" (Cmt (C (* (P "~") + (V "form"))) + (fn [s i ...] + (let [content [(t.make-symbol "unquote")]] + (table.insert content (. [...] 2)) + (values i (t.make-list content))))) + "with-meta" (Cmt (C (* (P "^") + (V "form") + (^ (V "gap") 1) + (V "form"))) + (fn [s i ...] + (let [content [(t.make-symbol "with-meta")]] + (table.insert content (. [...] 3)) + (table.insert content (. [...] 2)) + (values i (t.make-list content))))) + }) + +(comment + + (lpeg.match grammar "; hello") + + (lpeg.match grammar "nil") + + (lpeg.match grammar "true") + + (lpeg.match grammar "false") + + (lpeg.match grammar "1.2") + + (lpeg.match grammar "(+ 1 1)") + + (lpeg.match grammar "[:a :b :c]") + + (lpeg.match grammar "\"hello there\"") + + (lpeg.match grammar "\"hello\" there\"") + +) + +(fn read_str + [a-str] + (let [(ok? result) (pcall lpeg.match grammar a-str)] + (if ok? + (let [res-type (type result)] + (if (= res-type "table") + result + (u.throw* t.mal-nil))) + (u.throw* + (t.make-string result))))) + +(comment + + (read_str "; hello") + + (read_str "nil") + + (read_str "true") + + (read_str "false") + + (read_str "1.2") + + (read_str "(+ 1 1)") + + (read_str "[:a :b :c]") + + (read_str "\"hello there\"") + + (read_str "\"hello\" there\"") + + ) + +{:read_str read_str} diff --git a/impls/fennel/run b/impls/fennel/run index 2651be8607..d35b12e123 100755 --- a/impls/fennel/run +++ b/impls/fennel/run @@ -1,3 +1,3 @@ -#!/bin/bash - -exec fennel $(dirname $0)/${STEP:-stepA_mal}.fnl "${@}" +#!/bin/bash + +exec fennel $(dirname $0)/${STEP:-stepA_mal}.fnl "${@}" diff --git a/impls/fennel/step0_repl.fnl b/impls/fennel/step0_repl.fnl index 394c4f1c52..0d54d2fd36 100644 --- a/impls/fennel/step0_repl.fnl +++ b/impls/fennel/step0_repl.fnl @@ -1,21 +1,21 @@ -(fn READ [code-str] - code-str) - -(fn EVAL [ast] - ast) - -(fn PRINT [ast] - ast) - -(fn rep [code-str] - (PRINT (EVAL (READ code-str)))) - -(var done false) - -(while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (print (rep input))))) +(fn READ [code-str] + code-str) + +(fn EVAL [ast] + ast) + +(fn PRINT [ast] + ast) + +(fn rep [code-str] + (PRINT (EVAL (READ code-str)))) + +(var done false) + +(while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (print (rep input))))) diff --git a/impls/fennel/step1_read_print.fnl b/impls/fennel/step1_read_print.fnl index c2d531878c..fb9a209d2c 100644 --- a/impls/fennel/step1_read_print.fnl +++ b/impls/fennel/step1_read_print.fnl @@ -1,39 +1,39 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) - -(fn READ - [code-str] - (reader.read_str code-str)) - -(fn EVAL - [ast] - ast) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str)))) - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(var done false) - -(while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))) +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) + +(fn READ + [code-str] + (reader.read_str code-str)) + +(fn EVAL + [ast] + ast) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str)))) + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(var done false) + +(while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))) diff --git a/impls/fennel/step2_eval.fnl b/impls/fennel/step2_eval.fnl index 93d536eafe..7d97969d1d 100644 --- a/impls/fennel/step2_eval.fnl +++ b/impls/fennel/step2_eval.fnl @@ -1,89 +1,89 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) -(local u (require :utils)) - -(local repl_env - {"+" (fn [ast-1 ast-2] - (t.make-number (+ (t.get-value ast-1) - (t.get-value ast-2)))) - "-" (fn [ast-1 ast-2] - (t.make-number (- (t.get-value ast-1) - (t.get-value ast-2)))) - "*" (fn [ast-1 ast-2] - (t.make-number (* (t.get-value ast-1) - (t.get-value ast-2)))) - "/" (fn [ast-1 ast-2] - (t.make-number (/ (t.get-value ast-1) - (t.get-value ast-2))))}) - -(fn READ - [code-str] - (reader.read_str code-str)) - -;; forward declaration -(var EVAL 1) - -(fn eval_ast - [ast env] - (if (t.symbol?* ast) - (. env (t.get-value ast)) - ;; - (t.list?* ast) - (t.make-list (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.vector?* ast) - (t.make-vector (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.hash-map?* ast) - (t.make-hash-map (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - ast)) - -(set EVAL - (fn [ast env] - (if (not (t.list?* ast)) - (eval_ast ast env) - ;; - (t.empty?* ast) - ast - ;; - (let [eval-list (eval_ast ast env) - f (u.first (t.get-value eval-list)) - args (u.slice (t.get-value eval-list) 2 -1)] - (f (table.unpack args)))))) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(var done false) - -(while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))) - +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) +(local u (require :utils)) + +(local repl_env + {"+" (fn [ast-1 ast-2] + (t.make-number (+ (t.get-value ast-1) + (t.get-value ast-2)))) + "-" (fn [ast-1 ast-2] + (t.make-number (- (t.get-value ast-1) + (t.get-value ast-2)))) + "*" (fn [ast-1 ast-2] + (t.make-number (* (t.get-value ast-1) + (t.get-value ast-2)))) + "/" (fn [ast-1 ast-2] + (t.make-number (/ (t.get-value ast-1) + (t.get-value ast-2))))}) + +(fn READ + [code-str] + (reader.read_str code-str)) + +;; forward declaration +(var EVAL 1) + +(fn eval_ast + [ast env] + (if (t.symbol?* ast) + (. env (t.get-value ast)) + ;; + (t.list?* ast) + (t.make-list (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.vector?* ast) + (t.make-vector (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.hash-map?* ast) + (t.make-hash-map (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + ast)) + +(set EVAL + (fn [ast env] + (if (not (t.list?* ast)) + (eval_ast ast env) + ;; + (t.empty?* ast) + ast + ;; + (let [eval-list (eval_ast ast env) + f (u.first (t.get-value eval-list)) + args (u.slice (t.get-value eval-list) 2 -1)] + (f (table.unpack args)))))) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(var done false) + +(while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))) + diff --git a/impls/fennel/step3_env.fnl b/impls/fennel/step3_env.fnl index 8e07c440fe..0d754d9bf1 100644 --- a/impls/fennel/step3_env.fnl +++ b/impls/fennel/step3_env.fnl @@ -1,115 +1,115 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) -(local e (require :env)) -(local u (require :utils)) - -(local repl_env - (-> (e.make-env nil) - (e.env-set (t.make-symbol "+") - (fn [ast-1 ast-2] - (t.make-number (+ (t.get-value ast-1) - (t.get-value ast-2))))) - (e.env-set (t.make-symbol "-") - (fn [ast-1 ast-2] - (t.make-number (- (t.get-value ast-1) - (t.get-value ast-2))))) - (e.env-set (t.make-symbol "*") - (fn [ast-1 ast-2] - (t.make-number (* (t.get-value ast-1) - (t.get-value ast-2))))) - (e.env-set (t.make-symbol "/") - (fn [ast-1 ast-2] - (t.make-number (/ (t.get-value ast-1) - (t.get-value ast-2))))))) - -(fn READ - [arg] - (reader.read_str arg)) - -;; forward declaration -(var EVAL 1) - -(fn eval_ast - [ast env] - (if (t.symbol?* ast) - (e.env-get env ast) - ;; - (t.list?* ast) - (t.make-list (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.vector?* ast) - (t.make-vector (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.hash-map?* ast) - (t.make-hash-map (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - ast)) - -(set EVAL - (fn [ast env] - (if (not (t.list?* ast)) - (eval_ast ast env) - ;; - (t.empty?* ast) - ast - ;; - (let [ast-elts (t.get-value ast) - head-name (t.get-value (. ast-elts 1))] - ;; XXX: want to check for symbol, but that screws up logic below - (if (= "def!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env)] - (e.env-set env - def-name def-val) - def-val) - ;; - (= "let*" head-name) - (let [new-env (e.make-env env) - bindings (t.get-value (. ast-elts 2)) - stop (/ (length bindings) 2)] - (for [idx 1 stop] - (let [b-name (. bindings (- (* 2 idx) 1)) - b-val (EVAL (. bindings (* 2 idx)) new-env)] - (e.env-set new-env - b-name b-val))) - (EVAL (. ast-elts 3) new-env)) - ;; - (let [eval-list (t.get-value (eval_ast ast env)) - f (. eval-list 1) - args (u.slice eval-list 2 -1)] - (f (table.unpack args)))))))) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(var done false) - -(while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))) +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) +(local e (require :env)) +(local u (require :utils)) + +(local repl_env + (-> (e.make-env nil) + (e.env-set (t.make-symbol "+") + (fn [ast-1 ast-2] + (t.make-number (+ (t.get-value ast-1) + (t.get-value ast-2))))) + (e.env-set (t.make-symbol "-") + (fn [ast-1 ast-2] + (t.make-number (- (t.get-value ast-1) + (t.get-value ast-2))))) + (e.env-set (t.make-symbol "*") + (fn [ast-1 ast-2] + (t.make-number (* (t.get-value ast-1) + (t.get-value ast-2))))) + (e.env-set (t.make-symbol "/") + (fn [ast-1 ast-2] + (t.make-number (/ (t.get-value ast-1) + (t.get-value ast-2))))))) + +(fn READ + [arg] + (reader.read_str arg)) + +;; forward declaration +(var EVAL 1) + +(fn eval_ast + [ast env] + (if (t.symbol?* ast) + (e.env-get env ast) + ;; + (t.list?* ast) + (t.make-list (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.vector?* ast) + (t.make-vector (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.hash-map?* ast) + (t.make-hash-map (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + ast)) + +(set EVAL + (fn [ast env] + (if (not (t.list?* ast)) + (eval_ast ast env) + ;; + (t.empty?* ast) + ast + ;; + (let [ast-elts (t.get-value ast) + head-name (t.get-value (. ast-elts 1))] + ;; XXX: want to check for symbol, but that screws up logic below + (if (= "def!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env)] + (e.env-set env + def-name def-val) + def-val) + ;; + (= "let*" head-name) + (let [new-env (e.make-env env) + bindings (t.get-value (. ast-elts 2)) + stop (/ (length bindings) 2)] + (for [idx 1 stop] + (let [b-name (. bindings (- (* 2 idx) 1)) + b-val (EVAL (. bindings (* 2 idx)) new-env)] + (e.env-set new-env + b-name b-val))) + (EVAL (. ast-elts 3) new-env)) + ;; + (let [eval-list (t.get-value (eval_ast ast env)) + f (. eval-list 1) + args (u.slice eval-list 2 -1)] + (f (table.unpack args)))))))) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(var done false) + +(while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))) diff --git a/impls/fennel/step4_if_fn_do.fnl b/impls/fennel/step4_if_fn_do.fnl index 0e909f877d..0768be52d8 100644 --- a/impls/fennel/step4_if_fn_do.fnl +++ b/impls/fennel/step4_if_fn_do.fnl @@ -1,136 +1,136 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) -(local e (require :env)) -(local core (require :core)) -(local u (require :utils)) - -(local repl_env - (let [env (e.make-env)] - (each [name func (pairs core)] - (e.env-set env - (t.make-symbol name) - func)) - env)) - -(fn READ - [code-str] - (reader.read_str code-str)) - -;; forward declaration -(var EVAL 1) - -(fn eval_ast - [ast env] - (if (t.symbol?* ast) - (e.env-get env ast) - ;; - (t.list?* ast) - (t.make-list (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.vector?* ast) - (t.make-vector (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.hash-map?* ast) - (t.make-hash-map (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - ast)) - -(set EVAL - (fn [ast env] - (if (not (t.list?* ast)) - (eval_ast ast env) - ;; - (t.empty?* ast) - ast - ;; - (let [ast-elts (t.get-value ast) - head-name (t.get-value (. ast-elts 1))] - ;; XXX: want to check for symbol, but that screws up logic below - (if (= "def!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env)] - (e.env-set env - def-name def-val) - def-val) - ;; - (= "let*" head-name) - (let [new-env (e.make-env env) - bindings (t.get-value (. ast-elts 2)) - stop (/ (length bindings) 2)] - (for [idx 1 stop] - (let [b-name (. bindings (- (* 2 idx) 1)) - b-val (EVAL (. bindings (* 2 idx)) new-env)] - (e.env-set new-env - b-name b-val))) - (EVAL (. ast-elts 3) new-env)) - ;; - (= "do" head-name) - (let [do-body-evaled (eval_ast (t.make-list - (u.slice ast-elts 2 -1)) - env)] - (u.last (t.get-value do-body-evaled))) - ;; - (= "if" head-name) - (let [cond-res (EVAL (. ast-elts 2) env)] - (if (or (t.nil?* cond-res) - (t.false?* cond-res)) - (let [else-ast (. ast-elts 4)] - (if (not else-ast) - t.mal-nil - (EVAL else-ast env))) - (EVAL (. ast-elts 3) env))) - ;; - (= "fn*" head-name) - (let [args (t.get-value (. ast-elts 2)) - body (. ast-elts 3)] - (t.make-fn (fn [params] - (EVAL body - (e.make-env env args params))))) - ;; - (let [eval-list (t.get-value (eval_ast ast env)) - f (. eval-list 1) - args (u.slice eval-list 2 -1)] - ((t.get-value f) args))))))) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(var done false) - -(while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))) - ;; (fn [exc] - ;; (if (t.nil?* exc) - ;; (print) - ;; (= "string" (type exc)) - ;; (print exc) - ;; (print (PRINT exc)))))))) +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) +(local e (require :env)) +(local core (require :core)) +(local u (require :utils)) + +(local repl_env + (let [env (e.make-env)] + (each [name func (pairs core)] + (e.env-set env + (t.make-symbol name) + func)) + env)) + +(fn READ + [code-str] + (reader.read_str code-str)) + +;; forward declaration +(var EVAL 1) + +(fn eval_ast + [ast env] + (if (t.symbol?* ast) + (e.env-get env ast) + ;; + (t.list?* ast) + (t.make-list (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.vector?* ast) + (t.make-vector (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.hash-map?* ast) + (t.make-hash-map (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + ast)) + +(set EVAL + (fn [ast env] + (if (not (t.list?* ast)) + (eval_ast ast env) + ;; + (t.empty?* ast) + ast + ;; + (let [ast-elts (t.get-value ast) + head-name (t.get-value (. ast-elts 1))] + ;; XXX: want to check for symbol, but that screws up logic below + (if (= "def!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env)] + (e.env-set env + def-name def-val) + def-val) + ;; + (= "let*" head-name) + (let [new-env (e.make-env env) + bindings (t.get-value (. ast-elts 2)) + stop (/ (length bindings) 2)] + (for [idx 1 stop] + (let [b-name (. bindings (- (* 2 idx) 1)) + b-val (EVAL (. bindings (* 2 idx)) new-env)] + (e.env-set new-env + b-name b-val))) + (EVAL (. ast-elts 3) new-env)) + ;; + (= "do" head-name) + (let [do-body-evaled (eval_ast (t.make-list + (u.slice ast-elts 2 -1)) + env)] + (u.last (t.get-value do-body-evaled))) + ;; + (= "if" head-name) + (let [cond-res (EVAL (. ast-elts 2) env)] + (if (or (t.nil?* cond-res) + (t.false?* cond-res)) + (let [else-ast (. ast-elts 4)] + (if (not else-ast) + t.mal-nil + (EVAL else-ast env))) + (EVAL (. ast-elts 3) env))) + ;; + (= "fn*" head-name) + (let [args (t.get-value (. ast-elts 2)) + body (. ast-elts 3)] + (t.make-fn (fn [params] + (EVAL body + (e.make-env env args params))))) + ;; + (let [eval-list (t.get-value (eval_ast ast env)) + f (. eval-list 1) + args (u.slice eval-list 2 -1)] + ((t.get-value f) args))))))) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(var done false) + +(while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))) + ;; (fn [exc] + ;; (if (t.nil?* exc) + ;; (print) + ;; (= "string" (type exc)) + ;; (print exc) + ;; (print (PRINT exc)))))))) diff --git a/impls/fennel/step5_tco.fnl b/impls/fennel/step5_tco.fnl index c623375441..39e1834b59 100644 --- a/impls/fennel/step5_tco.fnl +++ b/impls/fennel/step5_tco.fnl @@ -1,150 +1,150 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) -(local e (require :env)) -(local core (require :core)) -(local u (require :utils)) - -(local repl_env - (let [env (e.make-env)] - (each [name func (pairs core)] - (e.env-set env - (t.make-symbol name) - func)) - env)) - -(fn READ - [code-str] - (reader.read_str code-str)) - -;; forward declaration -(var EVAL 1) - -(fn eval_ast - [ast env] - (if (t.symbol?* ast) - (e.env-get env ast) - ;; - (t.list?* ast) - (t.make-list (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.vector?* ast) - (t.make-vector (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.hash-map?* ast) - (t.make-hash-map (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - ast)) - -(set EVAL - (fn [ast-param env-param] - (var ast ast-param) - (var env env-param) - (var result nil) - (while (not result) - (if (not (t.list?* ast)) - (set result (eval_ast ast env)) - ;; - (t.empty?* ast) - (set result ast) - ;; - (let [ast-elts (t.get-value ast) - head-name (t.get-value (. ast-elts 1))] - ;; XXX: want to check for symbol, but that screws up logic below - (if (= "def!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env)] - (e.env-set env - def-name def-val) - (set result def-val)) - ;; - (= "let*" head-name) - (let [new-env (e.make-env env) - bindings (t.get-value (. ast-elts 2)) - stop (/ (length bindings) 2)] - (for [idx 1 stop] - (let [b-name (. bindings (- (* 2 idx) 1)) - b-val (EVAL (. bindings (* 2 idx)) new-env)] - (e.env-set new-env - b-name b-val))) - ;; tco - (set ast (. ast-elts 3)) - (set env new-env)) - ;; - (= "do" head-name) - (let [most-forms (u.slice ast-elts 2 -2) ;; XXX - last-body-form (u.last ast-elts) - res-ast (eval_ast (t.make-list most-forms) env)] - ;; tco - (set ast last-body-form)) - ;; - (= "if" head-name) - (let [cond-res (EVAL (. ast-elts 2) env)] - (if (or (t.nil?* cond-res) - (t.false?* cond-res)) - (let [else-ast (. ast-elts 4)] - (if (not else-ast) - ;; tco - (set result t.mal-nil) - (set ast else-ast))) - ;; tco - (set ast (. ast-elts 3)))) - ;; - (= "fn*" head-name) - (let [params (t.get-value (. ast-elts 2)) - body (. ast-elts 3)] - ;; tco - (set result - (t.make-fn (fn [args] - (EVAL body - (e.make-env env params args))) - body params env))) - ;; - (let [eval-list (t.get-value (eval_ast ast env)) - f (. eval-list 1) - args (u.slice eval-list 2 -1)] - (let [body (t.get-ast f)] ;; tco - (if body - (do - (set ast body) - (set env (e.make-env (t.get-env f) - (t.get-params f) args))) - (set result - ((t.get-value f) args))))))))) - result)) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(var done false) - -(while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))) +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) +(local e (require :env)) +(local core (require :core)) +(local u (require :utils)) + +(local repl_env + (let [env (e.make-env)] + (each [name func (pairs core)] + (e.env-set env + (t.make-symbol name) + func)) + env)) + +(fn READ + [code-str] + (reader.read_str code-str)) + +;; forward declaration +(var EVAL 1) + +(fn eval_ast + [ast env] + (if (t.symbol?* ast) + (e.env-get env ast) + ;; + (t.list?* ast) + (t.make-list (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.vector?* ast) + (t.make-vector (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.hash-map?* ast) + (t.make-hash-map (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + ast)) + +(set EVAL + (fn [ast-param env-param] + (var ast ast-param) + (var env env-param) + (var result nil) + (while (not result) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + ;; + (t.empty?* ast) + (set result ast) + ;; + (let [ast-elts (t.get-value ast) + head-name (t.get-value (. ast-elts 1))] + ;; XXX: want to check for symbol, but that screws up logic below + (if (= "def!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env)] + (e.env-set env + def-name def-val) + (set result def-val)) + ;; + (= "let*" head-name) + (let [new-env (e.make-env env) + bindings (t.get-value (. ast-elts 2)) + stop (/ (length bindings) 2)] + (for [idx 1 stop] + (let [b-name (. bindings (- (* 2 idx) 1)) + b-val (EVAL (. bindings (* 2 idx)) new-env)] + (e.env-set new-env + b-name b-val))) + ;; tco + (set ast (. ast-elts 3)) + (set env new-env)) + ;; + (= "do" head-name) + (let [most-forms (u.slice ast-elts 2 -2) ;; XXX + last-body-form (u.last ast-elts) + res-ast (eval_ast (t.make-list most-forms) env)] + ;; tco + (set ast last-body-form)) + ;; + (= "if" head-name) + (let [cond-res (EVAL (. ast-elts 2) env)] + (if (or (t.nil?* cond-res) + (t.false?* cond-res)) + (let [else-ast (. ast-elts 4)] + (if (not else-ast) + ;; tco + (set result t.mal-nil) + (set ast else-ast))) + ;; tco + (set ast (. ast-elts 3)))) + ;; + (= "fn*" head-name) + (let [params (t.get-value (. ast-elts 2)) + body (. ast-elts 3)] + ;; tco + (set result + (t.make-fn (fn [args] + (EVAL body + (e.make-env env params args))) + body params env))) + ;; + (let [eval-list (t.get-value (eval_ast ast env)) + f (. eval-list 1) + args (u.slice eval-list 2 -1)] + (let [body (t.get-ast f)] ;; tco + (if body + (do + (set ast body) + (set env (e.make-env (t.get-env f) + (t.get-params f) args))) + (set result + ((t.get-value f) args))))))))) + result)) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(var done false) + +(while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))) diff --git a/impls/fennel/step6_file.fnl b/impls/fennel/step6_file.fnl index ae3f964728..e8f58aa3ec 100644 --- a/impls/fennel/step6_file.fnl +++ b/impls/fennel/step6_file.fnl @@ -1,175 +1,175 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) -(local e (require :env)) -(local core (require :core)) -(local u (require :utils)) - -(local repl_env - (let [env (e.make-env)] - (each [name func (pairs core)] - (e.env-set env - (t.make-symbol name) - func)) - env)) - -(fn READ - [code-str] - (reader.read_str code-str)) - -;; forward declaration -(var EVAL 1) - -(fn eval_ast - [ast env] - (if (t.symbol?* ast) - (e.env-get env ast) - ;; - (t.list?* ast) - (t.make-list (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.vector?* ast) - (t.make-vector (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.hash-map?* ast) - (t.make-hash-map (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - ast)) - -(set EVAL - (fn [ast-param env-param] - (var ast ast-param) - (var env env-param) - (var result nil) - (while (not result) - (if (not (t.list?* ast)) - (set result (eval_ast ast env)) - ;; - (t.empty?* ast) - (set result ast) - ;; - (let [ast-elts (t.get-value ast) - head-name (t.get-value (. ast-elts 1))] - ;; XXX: want to check for symbol, but that screws up logic below - (if (= "def!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env)] - (e.env-set env - def-name def-val) - (set result def-val)) - ;; - (= "let*" head-name) - (let [new-env (e.make-env env) - bindings (t.get-value (. ast-elts 2)) - stop (/ (length bindings) 2)] - (for [idx 1 stop] - (let [b-name (. bindings (- (* 2 idx) 1)) - b-val (EVAL (. bindings (* 2 idx)) new-env)] - (e.env-set new-env - b-name b-val))) - ;; tco - (set ast (. ast-elts 3)) - (set env new-env)) - ;; - (= "do" head-name) - (let [most-forms (u.slice ast-elts 2 -2) ;; XXX - last-body-form (u.last ast-elts) - res-ast (eval_ast (t.make-list most-forms) env)] - ;; tco - (set ast last-body-form)) - ;; - (= "if" head-name) - (let [cond-res (EVAL (. ast-elts 2) env)] - (if (or (t.nil?* cond-res) - (t.false?* cond-res)) - (let [else-ast (. ast-elts 4)] - (if (not else-ast) - ;; tco - (set result t.mal-nil) - (set ast else-ast))) - ;; tco - (set ast (. ast-elts 3)))) - ;; - (= "fn*" head-name) - (let [params (t.get-value (. ast-elts 2)) - body (. ast-elts 3)] - ;; tco - (set result - (t.make-fn (fn [args] - (EVAL body - (e.make-env env params args))) - body params env))) - ;; - (let [eval-list (t.get-value (eval_ast ast env)) - f (. eval-list 1) - args (u.slice eval-list 2 -1)] - (let [body (t.get-ast f)] ;; tco - (if body - (do - (set ast body) - (set env (e.make-env (t.get-env f) - (t.get-params f) args))) - (set result - ((t.get-value f) args))))))))) - result)) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e.env-set repl_env - (t.make-symbol "eval") - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - ;; XXX - (error "eval takes 1 arguments")) - (EVAL (u.first asts) repl_env)))) - -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(e.env-set repl_env - (t.make-symbol "*ARGV*") - (t.make-list (u.map t.make-string (u.slice arg 2)))) - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(if (<= 1 (length arg)) - (xpcall (fn [] - (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? - handle-error) - (do - (var done false) - (while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))))) -; (fn [exc] - ;; (if (t.nil?* exc) - ;; (print) - ;; (= "string" (type exc)) - ;; (print exc) - ;; (print (PRINT exc)))))))))) +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) +(local e (require :env)) +(local core (require :core)) +(local u (require :utils)) + +(local repl_env + (let [env (e.make-env)] + (each [name func (pairs core)] + (e.env-set env + (t.make-symbol name) + func)) + env)) + +(fn READ + [code-str] + (reader.read_str code-str)) + +;; forward declaration +(var EVAL 1) + +(fn eval_ast + [ast env] + (if (t.symbol?* ast) + (e.env-get env ast) + ;; + (t.list?* ast) + (t.make-list (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.vector?* ast) + (t.make-vector (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.hash-map?* ast) + (t.make-hash-map (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + ast)) + +(set EVAL + (fn [ast-param env-param] + (var ast ast-param) + (var env env-param) + (var result nil) + (while (not result) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + ;; + (t.empty?* ast) + (set result ast) + ;; + (let [ast-elts (t.get-value ast) + head-name (t.get-value (. ast-elts 1))] + ;; XXX: want to check for symbol, but that screws up logic below + (if (= "def!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env)] + (e.env-set env + def-name def-val) + (set result def-val)) + ;; + (= "let*" head-name) + (let [new-env (e.make-env env) + bindings (t.get-value (. ast-elts 2)) + stop (/ (length bindings) 2)] + (for [idx 1 stop] + (let [b-name (. bindings (- (* 2 idx) 1)) + b-val (EVAL (. bindings (* 2 idx)) new-env)] + (e.env-set new-env + b-name b-val))) + ;; tco + (set ast (. ast-elts 3)) + (set env new-env)) + ;; + (= "do" head-name) + (let [most-forms (u.slice ast-elts 2 -2) ;; XXX + last-body-form (u.last ast-elts) + res-ast (eval_ast (t.make-list most-forms) env)] + ;; tco + (set ast last-body-form)) + ;; + (= "if" head-name) + (let [cond-res (EVAL (. ast-elts 2) env)] + (if (or (t.nil?* cond-res) + (t.false?* cond-res)) + (let [else-ast (. ast-elts 4)] + (if (not else-ast) + ;; tco + (set result t.mal-nil) + (set ast else-ast))) + ;; tco + (set ast (. ast-elts 3)))) + ;; + (= "fn*" head-name) + (let [params (t.get-value (. ast-elts 2)) + body (. ast-elts 3)] + ;; tco + (set result + (t.make-fn (fn [args] + (EVAL body + (e.make-env env params args))) + body params env))) + ;; + (let [eval-list (t.get-value (eval_ast ast env)) + f (. eval-list 1) + args (u.slice eval-list 2 -1)] + (let [body (t.get-ast f)] ;; tco + (if body + (do + (set ast body) + (set env (e.make-env (t.get-env f) + (t.get-params f) args))) + (set result + ((t.get-value f) args))))))))) + result)) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e.env-set repl_env + (t.make-symbol "eval") + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + ;; XXX + (error "eval takes 1 arguments")) + (EVAL (u.first asts) repl_env)))) + +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(e.env-set repl_env + (t.make-symbol "*ARGV*") + (t.make-list (u.map t.make-string (u.slice arg 2)))) + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(if (<= 1 (length arg)) + (xpcall (fn [] + (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? + handle-error) + (do + (var done false) + (while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))))) +; (fn [exc] + ;; (if (t.nil?* exc) + ;; (print) + ;; (= "string" (type exc)) + ;; (print exc) + ;; (print (PRINT exc)))))))))) diff --git a/impls/fennel/step7_quote.fnl b/impls/fennel/step7_quote.fnl index 32e424996d..193612623e 100644 --- a/impls/fennel/step7_quote.fnl +++ b/impls/fennel/step7_quote.fnl @@ -1,223 +1,223 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) -(local e (require :env)) -(local core (require :core)) -(local u (require :utils)) - -(local repl_env - (let [env (e.make-env)] - (each [name func (pairs core)] - (e.env-set env - (t.make-symbol name) - func)) - env)) - -(fn READ - [code-str] - (reader.read_str code-str)) - -;; forward declaration -(var EVAL 1) - -(fn eval_ast - [ast env] - (if (t.symbol?* ast) - (e.env-get env ast) - ;; - (t.list?* ast) - (t.make-list (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.vector?* ast) - (t.make-vector (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.hash-map?* ast) - (t.make-hash-map (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - ast)) - -(fn starts-with - [ast name] - (when (and (t.list?* ast) - (not (t.empty?* ast))) - (let [head-ast (. (t.get-value ast) 1)] - (and (t.symbol?* head-ast) - (= name (t.get-value head-ast)))))) - -(var quasiquote* nil) - -(fn qq-iter - [ast] - (if (t.empty?* ast) - (t.make-list []) - (let [ast-value (t.get-value ast) - elt (. ast-value 1) - acc (qq-iter (t.make-list (u.slice ast-value 2 -1)))] - (if (starts-with elt "splice-unquote") - (t.make-list [(t.make-symbol "concat") - (. (t.get-value elt) 2) - acc]) - (t.make-list [(t.make-symbol "cons") - (quasiquote* elt) - acc]))))) - -(set quasiquote* - (fn [ast] - (if (starts-with ast "unquote") - (. (t.get-value ast) 2) - ;; - (t.list?* ast) - (qq-iter ast) - ;; - (t.vector?* ast) - (t.make-list [(t.make-symbol "vec") (qq-iter ast)]) - ;; - (or (t.symbol?* ast) - (t.hash-map?* ast)) - (t.make-list [(t.make-symbol "quote") ast]) - ;; - ast))) - -(set EVAL - (fn [ast-param env-param] - (var ast ast-param) - (var env env-param) - (var result nil) - (while (not result) - (if (not (t.list?* ast)) - (set result (eval_ast ast env)) - ;; - (t.empty?* ast) - (set result ast) - ;; - (let [ast-elts (t.get-value ast) - head-name (t.get-value (. ast-elts 1))] - ;; XXX: want to check for symbol, but that screws up logic below - (if (= "def!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env)] - (e.env-set env - def-name def-val) - (set result def-val)) - ;; - (= "let*" head-name) - (let [new-env (e.make-env env) - bindings (t.get-value (. ast-elts 2)) - stop (/ (length bindings) 2)] - (for [idx 1 stop] - (let [b-name (. bindings (- (* 2 idx) 1)) - b-val (EVAL (. bindings (* 2 idx)) new-env)] - (e.env-set new-env - b-name b-val))) - ;; tco - (set ast (. ast-elts 3)) - (set env new-env)) - ;; - (= "quote" head-name) - ;; tco - (set result (. ast-elts 2)) - ;; - (= "quasiquoteexpand" head-name) - ;; tco - (set result (quasiquote* (. ast-elts 2))) - ;; - (= "quasiquote" head-name) - ;; tco - (set ast (quasiquote* (. ast-elts 2))) - ;; - (= "do" head-name) - (let [most-forms (u.slice ast-elts 2 -2) ;; XXX - last-body-form (u.last ast-elts) - res-ast (eval_ast (t.make-list most-forms) env)] - ;; tco - (set ast last-body-form)) - ;; - (= "if" head-name) - (let [cond-res (EVAL (. ast-elts 2) env)] - (if (or (t.nil?* cond-res) - (t.false?* cond-res)) - (let [else-ast (. ast-elts 4)] - (if (not else-ast) - ;; tco - (set result t.mal-nil) - (set ast else-ast))) - ;; tco - (set ast (. ast-elts 3)))) - ;; - (= "fn*" head-name) - (let [params (t.get-value (. ast-elts 2)) - body (. ast-elts 3)] - ;; tco - (set result - (t.make-fn (fn [args] - (EVAL body - (e.make-env env params args))) - body params env))) - ;; - (let [eval-list (t.get-value (eval_ast ast env)) - f (. eval-list 1) - args (u.slice eval-list 2 -1)] - (let [body (t.get-ast f)] ;; tco - (if body - (do - (set ast body) - (set env (e.make-env (t.get-env f) - (t.get-params f) args))) - (set result - ((t.get-value f) args))))))))) - result)) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e.env-set repl_env - (t.make-symbol "eval") - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - ;; XXX - (error "eval takes 1 arguments")) - (EVAL (u.first asts) repl_env)))) - -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(e.env-set repl_env - (t.make-symbol "*ARGV*") - (t.make-list (u.map t.make-string (u.slice arg 2 -1)))) - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(if (<= 1 (length arg)) - (xpcall (fn [] - (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? - handle-error) - (do - (var done false) - (while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))))) +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) +(local e (require :env)) +(local core (require :core)) +(local u (require :utils)) + +(local repl_env + (let [env (e.make-env)] + (each [name func (pairs core)] + (e.env-set env + (t.make-symbol name) + func)) + env)) + +(fn READ + [code-str] + (reader.read_str code-str)) + +;; forward declaration +(var EVAL 1) + +(fn eval_ast + [ast env] + (if (t.symbol?* ast) + (e.env-get env ast) + ;; + (t.list?* ast) + (t.make-list (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.vector?* ast) + (t.make-vector (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.hash-map?* ast) + (t.make-hash-map (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + ast)) + +(fn starts-with + [ast name] + (when (and (t.list?* ast) + (not (t.empty?* ast))) + (let [head-ast (. (t.get-value ast) 1)] + (and (t.symbol?* head-ast) + (= name (t.get-value head-ast)))))) + +(var quasiquote* nil) + +(fn qq-iter + [ast] + (if (t.empty?* ast) + (t.make-list []) + (let [ast-value (t.get-value ast) + elt (. ast-value 1) + acc (qq-iter (t.make-list (u.slice ast-value 2 -1)))] + (if (starts-with elt "splice-unquote") + (t.make-list [(t.make-symbol "concat") + (. (t.get-value elt) 2) + acc]) + (t.make-list [(t.make-symbol "cons") + (quasiquote* elt) + acc]))))) + +(set quasiquote* + (fn [ast] + (if (starts-with ast "unquote") + (. (t.get-value ast) 2) + ;; + (t.list?* ast) + (qq-iter ast) + ;; + (t.vector?* ast) + (t.make-list [(t.make-symbol "vec") (qq-iter ast)]) + ;; + (or (t.symbol?* ast) + (t.hash-map?* ast)) + (t.make-list [(t.make-symbol "quote") ast]) + ;; + ast))) + +(set EVAL + (fn [ast-param env-param] + (var ast ast-param) + (var env env-param) + (var result nil) + (while (not result) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + ;; + (t.empty?* ast) + (set result ast) + ;; + (let [ast-elts (t.get-value ast) + head-name (t.get-value (. ast-elts 1))] + ;; XXX: want to check for symbol, but that screws up logic below + (if (= "def!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env)] + (e.env-set env + def-name def-val) + (set result def-val)) + ;; + (= "let*" head-name) + (let [new-env (e.make-env env) + bindings (t.get-value (. ast-elts 2)) + stop (/ (length bindings) 2)] + (for [idx 1 stop] + (let [b-name (. bindings (- (* 2 idx) 1)) + b-val (EVAL (. bindings (* 2 idx)) new-env)] + (e.env-set new-env + b-name b-val))) + ;; tco + (set ast (. ast-elts 3)) + (set env new-env)) + ;; + (= "quote" head-name) + ;; tco + (set result (. ast-elts 2)) + ;; + (= "quasiquoteexpand" head-name) + ;; tco + (set result (quasiquote* (. ast-elts 2))) + ;; + (= "quasiquote" head-name) + ;; tco + (set ast (quasiquote* (. ast-elts 2))) + ;; + (= "do" head-name) + (let [most-forms (u.slice ast-elts 2 -2) ;; XXX + last-body-form (u.last ast-elts) + res-ast (eval_ast (t.make-list most-forms) env)] + ;; tco + (set ast last-body-form)) + ;; + (= "if" head-name) + (let [cond-res (EVAL (. ast-elts 2) env)] + (if (or (t.nil?* cond-res) + (t.false?* cond-res)) + (let [else-ast (. ast-elts 4)] + (if (not else-ast) + ;; tco + (set result t.mal-nil) + (set ast else-ast))) + ;; tco + (set ast (. ast-elts 3)))) + ;; + (= "fn*" head-name) + (let [params (t.get-value (. ast-elts 2)) + body (. ast-elts 3)] + ;; tco + (set result + (t.make-fn (fn [args] + (EVAL body + (e.make-env env params args))) + body params env))) + ;; + (let [eval-list (t.get-value (eval_ast ast env)) + f (. eval-list 1) + args (u.slice eval-list 2 -1)] + (let [body (t.get-ast f)] ;; tco + (if body + (do + (set ast body) + (set env (e.make-env (t.get-env f) + (t.get-params f) args))) + (set result + ((t.get-value f) args))))))))) + result)) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e.env-set repl_env + (t.make-symbol "eval") + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + ;; XXX + (error "eval takes 1 arguments")) + (EVAL (u.first asts) repl_env)))) + +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(e.env-set repl_env + (t.make-symbol "*ARGV*") + (t.make-list (u.map t.make-string (u.slice arg 2 -1)))) + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(if (<= 1 (length arg)) + (xpcall (fn [] + (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? + handle-error) + (do + (var done false) + (while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))))) diff --git a/impls/fennel/step8_macros.fnl b/impls/fennel/step8_macros.fnl index 98b24ef07e..fd1e39f488 100644 --- a/impls/fennel/step8_macros.fnl +++ b/impls/fennel/step8_macros.fnl @@ -1,278 +1,278 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) -(local e (require :env)) -(local core (require :core)) -(local u (require :utils)) - -(local repl_env - (let [env (e.make-env)] - (each [name func (pairs core)] - (e.env-set env - (t.make-symbol name) - func)) - env)) - -(fn READ - [code-str] - (reader.read_str code-str)) - -(fn is_macro_call - [ast env] - (when (and (t.list?* ast) - (not (t.empty?* ast))) - (let [head-ast (. (t.get-value ast) 1)] - (when (and (t.symbol?* head-ast) - (e.env-find env head-ast)) - (let [target-ast (e.env-get env head-ast)] - (t.macro?* target-ast)))))) - -(fn macroexpand - [ast env] - (var ast-var ast) - (while (is_macro_call ast-var env) - (let [inner-asts (t.get-value ast-var) - head-ast (. inner-asts 1) - macro-fn (t.get-value (e.env-get env head-ast)) - args (u.slice inner-asts 2 -1)] - (set ast-var (macro-fn args)))) - ast-var) - -;; forward declaration -(var EVAL 1) - -(fn eval_ast - [ast env] - (if (t.symbol?* ast) - (e.env-get env ast) - ;; - (t.list?* ast) - (t.make-list (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.vector?* ast) - (t.make-vector (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.hash-map?* ast) - (t.make-hash-map (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - ast)) - -(fn starts-with - [ast name] - (when (and (t.list?* ast) - (not (t.empty?* ast))) - (let [head-ast (. (t.get-value ast) 1)] - (and (t.symbol?* head-ast) - (= name (t.get-value head-ast)))))) - -(var quasiquote* nil) - -(fn qq-iter - [ast] - (if (t.empty?* ast) - (t.make-list []) - (let [ast-value (t.get-value ast) - elt (. ast-value 1) - acc (qq-iter (t.make-list (u.slice ast-value 2 -1)))] - (if (starts-with elt "splice-unquote") - (t.make-list [(t.make-symbol "concat") - (. (t.get-value elt) 2) - acc]) - (t.make-list [(t.make-symbol "cons") - (quasiquote* elt) - acc]))))) - -(set quasiquote* - (fn [ast] - (if (starts-with ast "unquote") - (. (t.get-value ast) 2) - ;; - (t.list?* ast) - (qq-iter ast) - ;; - (t.vector?* ast) - (t.make-list [(t.make-symbol "vec") (qq-iter ast)]) - ;; - (or (t.symbol?* ast) - (t.hash-map?* ast)) - (t.make-list [(t.make-symbol "quote") ast]) - ;; - ast))) - -(set EVAL - (fn [ast-param env-param] - (var ast ast-param) - (var env env-param) - (var result nil) - (while (not result) - (if (not (t.list?* ast)) - (set result (eval_ast ast env)) - (do - (set ast (macroexpand ast env)) - (if (not (t.list?* ast)) - (set result (eval_ast ast env)) - (if (t.empty?* ast) - (set result ast) - (let [ast-elts (t.get-value ast) - head-name (t.get-value (. ast-elts 1))] - ;; XXX: want to check for symbol, but... - (if (= "def!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env)] - (e.env-set env - def-name def-val) - (set result def-val)) - ;; - (= "defmacro!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env) - macro-ast (t.macrofy def-val)] - (e.env-set env - def-name macro-ast) - (set result macro-ast)) - ;; - (= "macroexpand" head-name) - (set result (macroexpand (. ast-elts 2) env)) - ;; - (= "let*" head-name) - (let [new-env (e.make-env env) - bindings (t.get-value (. ast-elts 2)) - stop (/ (length bindings) 2)] - (for [idx 1 stop] - (let [b-name - (. bindings (- (* 2 idx) 1)) - b-val - (EVAL (. bindings (* 2 idx)) new-env)] - (e.env-set new-env - b-name b-val))) - ;; tco - (set ast (. ast-elts 3)) - (set env new-env)) - ;; - (= "quote" head-name) - ;; tco - (set result (. ast-elts 2)) - ;; - (= "quasiquoteexpand" head-name) - ;; tco - (set result (quasiquote* (. ast-elts 2))) - ;; - (= "quasiquote" head-name) - ;; tco - (set ast (quasiquote* (. ast-elts 2))) - ;; - (= "do" head-name) - (let [most-forms (u.slice ast-elts 2 -2) ;; XXX - last-body-form (u.last ast-elts) - res-ast (eval_ast - (t.make-list most-forms) env)] - ;; tco - (set ast last-body-form)) - ;; - (= "if" head-name) - (let [cond-res (EVAL (. ast-elts 2) env)] - (if (or (t.nil?* cond-res) - (t.false?* cond-res)) - (let [else-ast (. ast-elts 4)] - (if (not else-ast) - ;; tco - (set result t.mal-nil) - (set ast else-ast))) - ;; tco - (set ast (. ast-elts 3)))) - ;; - (= "fn*" head-name) - (let [params (t.get-value (. ast-elts 2)) - body (. ast-elts 3)] - ;; tco - (set result - (t.make-fn - (fn [args] - (EVAL body - (e.make-env env params args))) - body params env false))) - ;; - (let [eval-list (t.get-value (eval_ast ast env)) - f (. eval-list 1) - args (u.slice eval-list 2 -1)] - (let [body (t.get-ast f)] ;; tco - (if body - (do - (set ast body) - (set env - (e.make-env (t.get-env f) - (t.get-params f) - args))) - (set result - ((t.get-value f) args)))))))))))) - result)) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e.env-set repl_env - (t.make-symbol "eval") - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - ;; XXX - (error "eval takes 1 arguments")) - (EVAL (u.first asts) repl_env)))) - -(rep - (.. "(def! load-file " - " (fn* (f) " - " (eval " - " (read-string " - " (str \"(do \" (slurp f) \"\nnil)\")))))")) - -(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)))))))")) - -(e.env-set repl_env - (t.make-symbol "*ARGV*") - (t.make-list (u.map t.make-string (u.slice arg 2 -1)))) - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(if (<= 1 (length arg)) - (xpcall (fn [] - (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? - handle-error) - (do - (var done false) - (while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))))) +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) +(local e (require :env)) +(local core (require :core)) +(local u (require :utils)) + +(local repl_env + (let [env (e.make-env)] + (each [name func (pairs core)] + (e.env-set env + (t.make-symbol name) + func)) + env)) + +(fn READ + [code-str] + (reader.read_str code-str)) + +(fn is_macro_call + [ast env] + (when (and (t.list?* ast) + (not (t.empty?* ast))) + (let [head-ast (. (t.get-value ast) 1)] + (when (and (t.symbol?* head-ast) + (e.env-find env head-ast)) + (let [target-ast (e.env-get env head-ast)] + (t.macro?* target-ast)))))) + +(fn macroexpand + [ast env] + (var ast-var ast) + (while (is_macro_call ast-var env) + (let [inner-asts (t.get-value ast-var) + head-ast (. inner-asts 1) + macro-fn (t.get-value (e.env-get env head-ast)) + args (u.slice inner-asts 2 -1)] + (set ast-var (macro-fn args)))) + ast-var) + +;; forward declaration +(var EVAL 1) + +(fn eval_ast + [ast env] + (if (t.symbol?* ast) + (e.env-get env ast) + ;; + (t.list?* ast) + (t.make-list (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.vector?* ast) + (t.make-vector (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.hash-map?* ast) + (t.make-hash-map (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + ast)) + +(fn starts-with + [ast name] + (when (and (t.list?* ast) + (not (t.empty?* ast))) + (let [head-ast (. (t.get-value ast) 1)] + (and (t.symbol?* head-ast) + (= name (t.get-value head-ast)))))) + +(var quasiquote* nil) + +(fn qq-iter + [ast] + (if (t.empty?* ast) + (t.make-list []) + (let [ast-value (t.get-value ast) + elt (. ast-value 1) + acc (qq-iter (t.make-list (u.slice ast-value 2 -1)))] + (if (starts-with elt "splice-unquote") + (t.make-list [(t.make-symbol "concat") + (. (t.get-value elt) 2) + acc]) + (t.make-list [(t.make-symbol "cons") + (quasiquote* elt) + acc]))))) + +(set quasiquote* + (fn [ast] + (if (starts-with ast "unquote") + (. (t.get-value ast) 2) + ;; + (t.list?* ast) + (qq-iter ast) + ;; + (t.vector?* ast) + (t.make-list [(t.make-symbol "vec") (qq-iter ast)]) + ;; + (or (t.symbol?* ast) + (t.hash-map?* ast)) + (t.make-list [(t.make-symbol "quote") ast]) + ;; + ast))) + +(set EVAL + (fn [ast-param env-param] + (var ast ast-param) + (var env env-param) + (var result nil) + (while (not result) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + (do + (set ast (macroexpand ast env)) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + (if (t.empty?* ast) + (set result ast) + (let [ast-elts (t.get-value ast) + head-name (t.get-value (. ast-elts 1))] + ;; XXX: want to check for symbol, but... + (if (= "def!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env)] + (e.env-set env + def-name def-val) + (set result def-val)) + ;; + (= "defmacro!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env) + macro-ast (t.macrofy def-val)] + (e.env-set env + def-name macro-ast) + (set result macro-ast)) + ;; + (= "macroexpand" head-name) + (set result (macroexpand (. ast-elts 2) env)) + ;; + (= "let*" head-name) + (let [new-env (e.make-env env) + bindings (t.get-value (. ast-elts 2)) + stop (/ (length bindings) 2)] + (for [idx 1 stop] + (let [b-name + (. bindings (- (* 2 idx) 1)) + b-val + (EVAL (. bindings (* 2 idx)) new-env)] + (e.env-set new-env + b-name b-val))) + ;; tco + (set ast (. ast-elts 3)) + (set env new-env)) + ;; + (= "quote" head-name) + ;; tco + (set result (. ast-elts 2)) + ;; + (= "quasiquoteexpand" head-name) + ;; tco + (set result (quasiquote* (. ast-elts 2))) + ;; + (= "quasiquote" head-name) + ;; tco + (set ast (quasiquote* (. ast-elts 2))) + ;; + (= "do" head-name) + (let [most-forms (u.slice ast-elts 2 -2) ;; XXX + last-body-form (u.last ast-elts) + res-ast (eval_ast + (t.make-list most-forms) env)] + ;; tco + (set ast last-body-form)) + ;; + (= "if" head-name) + (let [cond-res (EVAL (. ast-elts 2) env)] + (if (or (t.nil?* cond-res) + (t.false?* cond-res)) + (let [else-ast (. ast-elts 4)] + (if (not else-ast) + ;; tco + (set result t.mal-nil) + (set ast else-ast))) + ;; tco + (set ast (. ast-elts 3)))) + ;; + (= "fn*" head-name) + (let [params (t.get-value (. ast-elts 2)) + body (. ast-elts 3)] + ;; tco + (set result + (t.make-fn + (fn [args] + (EVAL body + (e.make-env env params args))) + body params env false))) + ;; + (let [eval-list (t.get-value (eval_ast ast env)) + f (. eval-list 1) + args (u.slice eval-list 2 -1)] + (let [body (t.get-ast f)] ;; tco + (if body + (do + (set ast body) + (set env + (e.make-env (t.get-env f) + (t.get-params f) + args))) + (set result + ((t.get-value f) args)))))))))))) + result)) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e.env-set repl_env + (t.make-symbol "eval") + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + ;; XXX + (error "eval takes 1 arguments")) + (EVAL (u.first asts) repl_env)))) + +(rep + (.. "(def! load-file " + " (fn* (f) " + " (eval " + " (read-string " + " (str \"(do \" (slurp f) \"\nnil)\")))))")) + +(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)))))))")) + +(e.env-set repl_env + (t.make-symbol "*ARGV*") + (t.make-list (u.map t.make-string (u.slice arg 2 -1)))) + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(if (<= 1 (length arg)) + (xpcall (fn [] + (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? + handle-error) + (do + (var done false) + (while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))))) diff --git a/impls/fennel/step9_try.fnl b/impls/fennel/step9_try.fnl index 601e9cc827..26e2ec8a1d 100644 --- a/impls/fennel/step9_try.fnl +++ b/impls/fennel/step9_try.fnl @@ -1,311 +1,311 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) -(local e (require :env)) -(local core (require :core)) -(local u (require :utils)) - -(local repl_env - (let [env (e.make-env)] - (each [name func (pairs core)] - (e.env-set env - (t.make-symbol name) - func)) - env)) - -(fn READ - [code-str] - (reader.read_str code-str)) - -(fn is_macro_call - [ast env] - (when (and (t.list?* ast) - (not (t.empty?* ast))) - (let [head-ast (. (t.get-value ast) 1)] - (when (and (t.symbol?* head-ast) - (e.env-find env head-ast)) - (let [target-ast (e.env-get env head-ast)] - (t.macro?* target-ast)))))) - -(fn macroexpand - [ast env] - (var ast-var ast) - (while (is_macro_call ast-var env) - (let [inner-asts (t.get-value ast-var) - head-ast (. inner-asts 1) - macro-fn (t.get-value (e.env-get env head-ast)) - args (u.slice inner-asts 2 -1)] - (set ast-var (macro-fn args)))) - ast-var) - -;; forward declaration -(var EVAL 1) - -(fn eval_ast - [ast env] - (if (t.symbol?* ast) - (e.env-get env ast) - ;; - (t.list?* ast) - (t.make-list (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.vector?* ast) - (t.make-vector (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.hash-map?* ast) - (t.make-hash-map (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - ast)) - -(fn starts-with - [ast name] - (when (and (t.list?* ast) - (not (t.empty?* ast))) - (let [head-ast (. (t.get-value ast) 1)] - (and (t.symbol?* head-ast) - (= name (t.get-value head-ast)))))) - -(var quasiquote* nil) - -(fn qq-iter - [ast] - (if (t.empty?* ast) - (t.make-list []) - (let [ast-value (t.get-value ast) - elt (. ast-value 1) - acc (qq-iter (t.make-list (u.slice ast-value 2 -1)))] - (if (starts-with elt "splice-unquote") - (t.make-list [(t.make-symbol "concat") - (. (t.get-value elt) 2) - acc]) - (t.make-list [(t.make-symbol "cons") - (quasiquote* elt) - acc]))))) - -(set quasiquote* - (fn [ast] - (if (starts-with ast "unquote") - (. (t.get-value ast) 2) - ;; - (t.list?* ast) - (qq-iter ast) - ;; - (t.vector?* ast) - (t.make-list [(t.make-symbol "vec") (qq-iter ast)]) - ;; - (or (t.symbol?* ast) - (t.hash-map?* ast)) - (t.make-list [(t.make-symbol "quote") ast]) - ;; - ast))) - -(set EVAL - (fn [ast-param env-param] - (var ast ast-param) - (var env env-param) - (var result nil) - (while (not result) - (if (not (t.list?* ast)) - (set result (eval_ast ast env)) - (do - (set ast (macroexpand ast env)) - (if (not (t.list?* ast)) - (set result (eval_ast ast env)) - (if (t.empty?* ast) - (set result ast) - (let [ast-elts (t.get-value ast) - head-name (t.get-value (. ast-elts 1))] - ;; XXX: want to check for symbol, but... - (if (= "def!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env)] - (e.env-set env - def-name def-val) - (set result def-val)) - ;; - (= "defmacro!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env) - macro-ast (t.macrofy def-val)] - (e.env-set env - def-name macro-ast) - (set result macro-ast)) - ;; - (= "macroexpand" head-name) - (set result (macroexpand (. ast-elts 2) env)) - ;; - (= "let*" head-name) - (let [new-env (e.make-env env) - bindings (t.get-value (. ast-elts 2)) - stop (/ (length bindings) 2)] - (for [idx 1 stop] - (let [b-name - (. bindings (- (* 2 idx) 1)) - b-val - (EVAL (. bindings (* 2 idx)) new-env)] - (e.env-set new-env - b-name b-val))) - ;; tco - (set ast (. ast-elts 3)) - (set env new-env)) - ;; - (= "quote" head-name) - ;; tco - (set result (. ast-elts 2)) - ;; - (= "quasiquoteexpand" head-name) - ;; tco - (set result (quasiquote* (. ast-elts 2))) - ;; - (= "quasiquote" head-name) - ;; tco - (set ast (quasiquote* (. ast-elts 2))) - ;; - (= "try*" head-name) - (set result - (let [(ok? res) - (pcall EVAL (. ast-elts 2) env)] - (if (not ok?) - (let [maybe-catch-ast (. ast-elts 3)] - (if (not maybe-catch-ast) - (u.throw* res) - (if (not (starts-with maybe-catch-ast - "catch*")) - (u.throw* - (t.make-string - "Expected catch* form")) - (let [catch-asts - (t.get-value - maybe-catch-ast)] - (if (< (length catch-asts) 2) - (u.throw* - (t.make-string - (.. "catch* requires at " - "least 2 " - "arguments"))) - (let [catch-sym-ast - (. catch-asts 2) - catch-body-ast - (. catch-asts 3)] - (EVAL catch-body-ast - (e.make-env - env - [catch-sym-ast] - [res])))))))) - res))) - ;; - (= "do" head-name) - (let [most-forms (u.slice ast-elts 2 -2) ;; XXX - last-body-form (u.last ast-elts) - res-ast (eval_ast - (t.make-list most-forms) env)] - ;; tco - (set ast last-body-form)) - ;; - (= "if" head-name) - (let [cond-res (EVAL (. ast-elts 2) env)] - (if (or (t.nil?* cond-res) - (t.false?* cond-res)) - (let [else-ast (. ast-elts 4)] - (if (not else-ast) - ;; tco - (set result t.mal-nil) - (set ast else-ast))) - ;; tco - (set ast (. ast-elts 3)))) - ;; - (= "fn*" head-name) - (let [params (t.get-value (. ast-elts 2)) - body (. ast-elts 3)] - ;; tco - (set result - (t.make-fn - (fn [args] - (EVAL body - (e.make-env env params args))) - body params env false))) - ;; - (let [eval-list (t.get-value (eval_ast ast env)) - f (. eval-list 1) - args (u.slice eval-list 2 -1)] - (let [body (t.get-ast f)] ;; tco - (if body - (do - (set ast body) - (set env - (e.make-env (t.get-env f) - (t.get-params f) - args))) - (set result - ((t.get-value f) args)))))))))))) - result)) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e.env-set repl_env - (t.make-symbol "eval") - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* - (t.make-string "eval takes 1 argument"))) - (EVAL (u.first asts) repl_env)))) - -(rep - (.. "(def! load-file " - " (fn* (f) " - " (eval " - " (read-string " - " (str \"(do \" (slurp f) \"\nnil)\")))))")) - -(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)))))))")) - -(e.env-set repl_env - (t.make-symbol "*ARGV*") - (t.make-list (u.map t.make-string (u.slice arg 2 -1)))) - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(if (<= 1 (length arg)) - (xpcall (fn [] - (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? - handle-error) - (do - (var done false) - (while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))))) +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) +(local e (require :env)) +(local core (require :core)) +(local u (require :utils)) + +(local repl_env + (let [env (e.make-env)] + (each [name func (pairs core)] + (e.env-set env + (t.make-symbol name) + func)) + env)) + +(fn READ + [code-str] + (reader.read_str code-str)) + +(fn is_macro_call + [ast env] + (when (and (t.list?* ast) + (not (t.empty?* ast))) + (let [head-ast (. (t.get-value ast) 1)] + (when (and (t.symbol?* head-ast) + (e.env-find env head-ast)) + (let [target-ast (e.env-get env head-ast)] + (t.macro?* target-ast)))))) + +(fn macroexpand + [ast env] + (var ast-var ast) + (while (is_macro_call ast-var env) + (let [inner-asts (t.get-value ast-var) + head-ast (. inner-asts 1) + macro-fn (t.get-value (e.env-get env head-ast)) + args (u.slice inner-asts 2 -1)] + (set ast-var (macro-fn args)))) + ast-var) + +;; forward declaration +(var EVAL 1) + +(fn eval_ast + [ast env] + (if (t.symbol?* ast) + (e.env-get env ast) + ;; + (t.list?* ast) + (t.make-list (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.vector?* ast) + (t.make-vector (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.hash-map?* ast) + (t.make-hash-map (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + ast)) + +(fn starts-with + [ast name] + (when (and (t.list?* ast) + (not (t.empty?* ast))) + (let [head-ast (. (t.get-value ast) 1)] + (and (t.symbol?* head-ast) + (= name (t.get-value head-ast)))))) + +(var quasiquote* nil) + +(fn qq-iter + [ast] + (if (t.empty?* ast) + (t.make-list []) + (let [ast-value (t.get-value ast) + elt (. ast-value 1) + acc (qq-iter (t.make-list (u.slice ast-value 2 -1)))] + (if (starts-with elt "splice-unquote") + (t.make-list [(t.make-symbol "concat") + (. (t.get-value elt) 2) + acc]) + (t.make-list [(t.make-symbol "cons") + (quasiquote* elt) + acc]))))) + +(set quasiquote* + (fn [ast] + (if (starts-with ast "unquote") + (. (t.get-value ast) 2) + ;; + (t.list?* ast) + (qq-iter ast) + ;; + (t.vector?* ast) + (t.make-list [(t.make-symbol "vec") (qq-iter ast)]) + ;; + (or (t.symbol?* ast) + (t.hash-map?* ast)) + (t.make-list [(t.make-symbol "quote") ast]) + ;; + ast))) + +(set EVAL + (fn [ast-param env-param] + (var ast ast-param) + (var env env-param) + (var result nil) + (while (not result) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + (do + (set ast (macroexpand ast env)) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + (if (t.empty?* ast) + (set result ast) + (let [ast-elts (t.get-value ast) + head-name (t.get-value (. ast-elts 1))] + ;; XXX: want to check for symbol, but... + (if (= "def!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env)] + (e.env-set env + def-name def-val) + (set result def-val)) + ;; + (= "defmacro!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env) + macro-ast (t.macrofy def-val)] + (e.env-set env + def-name macro-ast) + (set result macro-ast)) + ;; + (= "macroexpand" head-name) + (set result (macroexpand (. ast-elts 2) env)) + ;; + (= "let*" head-name) + (let [new-env (e.make-env env) + bindings (t.get-value (. ast-elts 2)) + stop (/ (length bindings) 2)] + (for [idx 1 stop] + (let [b-name + (. bindings (- (* 2 idx) 1)) + b-val + (EVAL (. bindings (* 2 idx)) new-env)] + (e.env-set new-env + b-name b-val))) + ;; tco + (set ast (. ast-elts 3)) + (set env new-env)) + ;; + (= "quote" head-name) + ;; tco + (set result (. ast-elts 2)) + ;; + (= "quasiquoteexpand" head-name) + ;; tco + (set result (quasiquote* (. ast-elts 2))) + ;; + (= "quasiquote" head-name) + ;; tco + (set ast (quasiquote* (. ast-elts 2))) + ;; + (= "try*" head-name) + (set result + (let [(ok? res) + (pcall EVAL (. ast-elts 2) env)] + (if (not ok?) + (let [maybe-catch-ast (. ast-elts 3)] + (if (not maybe-catch-ast) + (u.throw* res) + (if (not (starts-with maybe-catch-ast + "catch*")) + (u.throw* + (t.make-string + "Expected catch* form")) + (let [catch-asts + (t.get-value + maybe-catch-ast)] + (if (< (length catch-asts) 2) + (u.throw* + (t.make-string + (.. "catch* requires at " + "least 2 " + "arguments"))) + (let [catch-sym-ast + (. catch-asts 2) + catch-body-ast + (. catch-asts 3)] + (EVAL catch-body-ast + (e.make-env + env + [catch-sym-ast] + [res])))))))) + res))) + ;; + (= "do" head-name) + (let [most-forms (u.slice ast-elts 2 -2) ;; XXX + last-body-form (u.last ast-elts) + res-ast (eval_ast + (t.make-list most-forms) env)] + ;; tco + (set ast last-body-form)) + ;; + (= "if" head-name) + (let [cond-res (EVAL (. ast-elts 2) env)] + (if (or (t.nil?* cond-res) + (t.false?* cond-res)) + (let [else-ast (. ast-elts 4)] + (if (not else-ast) + ;; tco + (set result t.mal-nil) + (set ast else-ast))) + ;; tco + (set ast (. ast-elts 3)))) + ;; + (= "fn*" head-name) + (let [params (t.get-value (. ast-elts 2)) + body (. ast-elts 3)] + ;; tco + (set result + (t.make-fn + (fn [args] + (EVAL body + (e.make-env env params args))) + body params env false))) + ;; + (let [eval-list (t.get-value (eval_ast ast env)) + f (. eval-list 1) + args (u.slice eval-list 2 -1)] + (let [body (t.get-ast f)] ;; tco + (if body + (do + (set ast body) + (set env + (e.make-env (t.get-env f) + (t.get-params f) + args))) + (set result + ((t.get-value f) args)))))))))))) + result)) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e.env-set repl_env + (t.make-symbol "eval") + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* + (t.make-string "eval takes 1 argument"))) + (EVAL (u.first asts) repl_env)))) + +(rep + (.. "(def! load-file " + " (fn* (f) " + " (eval " + " (read-string " + " (str \"(do \" (slurp f) \"\nnil)\")))))")) + +(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)))))))")) + +(e.env-set repl_env + (t.make-symbol "*ARGV*") + (t.make-list (u.map t.make-string (u.slice arg 2 -1)))) + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(if (<= 1 (length arg)) + (xpcall (fn [] + (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? + handle-error) + (do + (var done false) + (while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))))) diff --git a/impls/fennel/stepA_mal.fnl b/impls/fennel/stepA_mal.fnl index 9623fa38bf..fd583476ab 100644 --- a/impls/fennel/stepA_mal.fnl +++ b/impls/fennel/stepA_mal.fnl @@ -1,316 +1,316 @@ -(local printer (require :printer)) -(local reader (require :reader)) -(local t (require :types)) -(local e (require :env)) -(local core (require :core)) -(local u (require :utils)) - -(local repl_env - (let [env (e.make-env)] - (each [name func (pairs core)] - (e.env-set env - (t.make-symbol name) - func)) - env)) - -(fn READ - [code-str] - (reader.read_str code-str)) - -(fn is_macro_call - [ast env] - (when (and (t.list?* ast) - (not (t.empty?* ast))) - (let [head-ast (. (t.get-value ast) 1)] - (when (and (t.symbol?* head-ast) - (e.env-find env head-ast)) - (let [target-ast (e.env-get env head-ast)] - (t.macro?* target-ast)))))) - -(fn macroexpand - [ast env] - (var ast-var ast) - (while (is_macro_call ast-var env) - (let [inner-asts (t.get-value ast-var) - head-ast (. inner-asts 1) - macro-fn (t.get-value (e.env-get env head-ast)) - args (u.slice inner-asts 2 -1)] - (set ast-var (macro-fn args)))) - ast-var) - -;; forward declaration -(var EVAL 1) - -(fn eval_ast - [ast env] - (if (t.symbol?* ast) - (e.env-get env ast) - ;; - (t.list?* ast) - (t.make-list (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.vector?* ast) - (t.make-vector (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - (t.hash-map?* ast) - (t.make-hash-map (u.map (fn [elt-ast] - (EVAL elt-ast env)) - (t.get-value ast))) - ;; - ast)) - -(fn starts-with - [ast name] - (when (and (t.list?* ast) - (not (t.empty?* ast))) - (let [head-ast (. (t.get-value ast) 1)] - (and (t.symbol?* head-ast) - (= name (t.get-value head-ast)))))) - -(var quasiquote* nil) - -(fn qq-iter - [ast] - (if (t.empty?* ast) - (t.make-list []) - (let [ast-value (t.get-value ast) - elt (. ast-value 1) - acc (qq-iter (t.make-list (u.slice ast-value 2 -1)))] - (if (starts-with elt "splice-unquote") - (t.make-list [(t.make-symbol "concat") - (. (t.get-value elt) 2) - acc]) - (t.make-list [(t.make-symbol "cons") - (quasiquote* elt) - acc]))))) - -(set quasiquote* - (fn [ast] - (if (starts-with ast "unquote") - (. (t.get-value ast) 2) - ;; - (t.list?* ast) - (qq-iter ast) - ;; - (t.vector?* ast) - (t.make-list [(t.make-symbol "vec") (qq-iter ast)]) - ;; - (or (t.symbol?* ast) - (t.hash-map?* ast)) - (t.make-list [(t.make-symbol "quote") ast]) - ;; - ast))) - -(set EVAL - (fn [ast-param env-param] - (var ast ast-param) - (var env env-param) - (var result nil) - (while (not result) - (if (not (t.list?* ast)) - (set result (eval_ast ast env)) - (do - (set ast (macroexpand ast env)) - (if (not (t.list?* ast)) - (set result (eval_ast ast env)) - (if (t.empty?* ast) - (set result ast) - (let [ast-elts (t.get-value ast) - head-name (t.get-value (. ast-elts 1))] - ;; XXX: want to check for symbol, but... - (if (= "def!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env)] - (e.env-set env - def-name def-val) - (set result def-val)) - ;; - (= "defmacro!" head-name) - (let [def-name (. ast-elts 2) - def-val (EVAL (. ast-elts 3) env) - macro-ast (t.macrofy def-val)] - (e.env-set env - def-name macro-ast) - (set result macro-ast)) - ;; - (= "macroexpand" head-name) - (set result (macroexpand (. ast-elts 2) env)) - ;; - (= "let*" head-name) - (let [new-env (e.make-env env) - bindings (t.get-value (. ast-elts 2)) - stop (/ (length bindings) 2)] - (for [idx 1 stop] - (let [b-name - (. bindings (- (* 2 idx) 1)) - b-val - (EVAL (. bindings (* 2 idx)) new-env)] - (e.env-set new-env - b-name b-val))) - ;; tco - (set ast (. ast-elts 3)) - (set env new-env)) - ;; - (= "quote" head-name) - ;; tco - (set result (. ast-elts 2)) - ;; - (= "quasiquoteexpand" head-name) - ;; tco - (set result (quasiquote* (. ast-elts 2))) - ;; - (= "quasiquote" head-name) - ;; tco - (set ast (quasiquote* (. ast-elts 2))) - ;; - (= "try*" head-name) - (set result - (let [(ok? res) - (pcall EVAL (. ast-elts 2) env)] - (if (not ok?) - (let [maybe-catch-ast (. ast-elts 3)] - (if (not maybe-catch-ast) - (u.throw* res) - (if (not (starts-with maybe-catch-ast - "catch*")) - (u.throw* - (t.make-string - "Expected catch* form")) - (let [catch-asts - (t.get-value - maybe-catch-ast)] - (if (< (length catch-asts) 2) - (u.throw* - (t.make-string - (.. "catch* requires at " - "least 2 " - "arguments"))) - (let [catch-sym-ast - (. catch-asts 2) - catch-body-ast - (. catch-asts 3)] - (EVAL catch-body-ast - (e.make-env - env - [catch-sym-ast] - [res])))))))) - res))) - ;; - (= "do" head-name) - (let [most-forms (u.slice ast-elts 2 -2) ;; XXX - last-body-form (u.last ast-elts) - res-ast (eval_ast - (t.make-list most-forms) env)] - ;; tco - (set ast last-body-form)) - ;; - (= "if" head-name) - (let [cond-res (EVAL (. ast-elts 2) env)] - (if (or (t.nil?* cond-res) - (t.false?* cond-res)) - (let [else-ast (. ast-elts 4)] - (if (not else-ast) - ;; tco - (set result t.mal-nil) - (set ast else-ast))) - ;; tco - (set ast (. ast-elts 3)))) - ;; - (= "fn*" head-name) - (let [params (t.get-value (. ast-elts 2)) - body (. ast-elts 3)] - ;; tco - (set result - (t.make-fn - (fn [args] - (EVAL body - (e.make-env env params args))) - body params env false nil))) - ;; - (let [eval-list (t.get-value (eval_ast ast env)) - f (. eval-list 1) - args (u.slice eval-list 2 -1)] - (let [body (t.get-ast f)] ;; tco - (if body - (do - (set ast body) - (set env - (e.make-env (t.get-env f) - (t.get-params f) - args))) - (set result - ((t.get-value f) args)))))))))))) - result)) - -(fn PRINT - [ast] - (printer.pr_str ast true)) - -(fn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e.env-set repl_env - (t.make-symbol "eval") - (t.make-fn - (fn [asts] - (when (< (length asts) 1) - (u.throw* - (t.make-string "eval takes 1 argument"))) - (EVAL (u.first asts) repl_env)))) - -(rep - (.. "(def! load-file " - " (fn* (f) " - " (eval " - " (read-string " - " (str \"(do \" (slurp f) \"\nnil)\")))))")) - -(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)))))))")) - -(e.env-set repl_env - (t.make-symbol "*host-language*") - (t.make-string "fennel")) - -(e.env-set repl_env - (t.make-symbol "*ARGV*") - (t.make-list (u.map t.make-string (u.slice arg 2 -1)))) - -(fn handle-error - [err] - (if (t.nil?* err) - (print) - (= "string" (type err)) - (print err) - (print (.. "Error: " (PRINT err))))) - -(if (<= 1 (length arg)) - (xpcall (fn [] - (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? - handle-error) - (do - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (var done false) - (while (not done) - (io.write "user> ") - (io.flush) - (let [input (io.read)] - (if (not input) - (set done true) - (xpcall (fn [] - (print (rep input))) - handle-error)))))) +(local printer (require :printer)) +(local reader (require :reader)) +(local t (require :types)) +(local e (require :env)) +(local core (require :core)) +(local u (require :utils)) + +(local repl_env + (let [env (e.make-env)] + (each [name func (pairs core)] + (e.env-set env + (t.make-symbol name) + func)) + env)) + +(fn READ + [code-str] + (reader.read_str code-str)) + +(fn is_macro_call + [ast env] + (when (and (t.list?* ast) + (not (t.empty?* ast))) + (let [head-ast (. (t.get-value ast) 1)] + (when (and (t.symbol?* head-ast) + (e.env-find env head-ast)) + (let [target-ast (e.env-get env head-ast)] + (t.macro?* target-ast)))))) + +(fn macroexpand + [ast env] + (var ast-var ast) + (while (is_macro_call ast-var env) + (let [inner-asts (t.get-value ast-var) + head-ast (. inner-asts 1) + macro-fn (t.get-value (e.env-get env head-ast)) + args (u.slice inner-asts 2 -1)] + (set ast-var (macro-fn args)))) + ast-var) + +;; forward declaration +(var EVAL 1) + +(fn eval_ast + [ast env] + (if (t.symbol?* ast) + (e.env-get env ast) + ;; + (t.list?* ast) + (t.make-list (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.vector?* ast) + (t.make-vector (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + (t.hash-map?* ast) + (t.make-hash-map (u.map (fn [elt-ast] + (EVAL elt-ast env)) + (t.get-value ast))) + ;; + ast)) + +(fn starts-with + [ast name] + (when (and (t.list?* ast) + (not (t.empty?* ast))) + (let [head-ast (. (t.get-value ast) 1)] + (and (t.symbol?* head-ast) + (= name (t.get-value head-ast)))))) + +(var quasiquote* nil) + +(fn qq-iter + [ast] + (if (t.empty?* ast) + (t.make-list []) + (let [ast-value (t.get-value ast) + elt (. ast-value 1) + acc (qq-iter (t.make-list (u.slice ast-value 2 -1)))] + (if (starts-with elt "splice-unquote") + (t.make-list [(t.make-symbol "concat") + (. (t.get-value elt) 2) + acc]) + (t.make-list [(t.make-symbol "cons") + (quasiquote* elt) + acc]))))) + +(set quasiquote* + (fn [ast] + (if (starts-with ast "unquote") + (. (t.get-value ast) 2) + ;; + (t.list?* ast) + (qq-iter ast) + ;; + (t.vector?* ast) + (t.make-list [(t.make-symbol "vec") (qq-iter ast)]) + ;; + (or (t.symbol?* ast) + (t.hash-map?* ast)) + (t.make-list [(t.make-symbol "quote") ast]) + ;; + ast))) + +(set EVAL + (fn [ast-param env-param] + (var ast ast-param) + (var env env-param) + (var result nil) + (while (not result) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + (do + (set ast (macroexpand ast env)) + (if (not (t.list?* ast)) + (set result (eval_ast ast env)) + (if (t.empty?* ast) + (set result ast) + (let [ast-elts (t.get-value ast) + head-name (t.get-value (. ast-elts 1))] + ;; XXX: want to check for symbol, but... + (if (= "def!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env)] + (e.env-set env + def-name def-val) + (set result def-val)) + ;; + (= "defmacro!" head-name) + (let [def-name (. ast-elts 2) + def-val (EVAL (. ast-elts 3) env) + macro-ast (t.macrofy def-val)] + (e.env-set env + def-name macro-ast) + (set result macro-ast)) + ;; + (= "macroexpand" head-name) + (set result (macroexpand (. ast-elts 2) env)) + ;; + (= "let*" head-name) + (let [new-env (e.make-env env) + bindings (t.get-value (. ast-elts 2)) + stop (/ (length bindings) 2)] + (for [idx 1 stop] + (let [b-name + (. bindings (- (* 2 idx) 1)) + b-val + (EVAL (. bindings (* 2 idx)) new-env)] + (e.env-set new-env + b-name b-val))) + ;; tco + (set ast (. ast-elts 3)) + (set env new-env)) + ;; + (= "quote" head-name) + ;; tco + (set result (. ast-elts 2)) + ;; + (= "quasiquoteexpand" head-name) + ;; tco + (set result (quasiquote* (. ast-elts 2))) + ;; + (= "quasiquote" head-name) + ;; tco + (set ast (quasiquote* (. ast-elts 2))) + ;; + (= "try*" head-name) + (set result + (let [(ok? res) + (pcall EVAL (. ast-elts 2) env)] + (if (not ok?) + (let [maybe-catch-ast (. ast-elts 3)] + (if (not maybe-catch-ast) + (u.throw* res) + (if (not (starts-with maybe-catch-ast + "catch*")) + (u.throw* + (t.make-string + "Expected catch* form")) + (let [catch-asts + (t.get-value + maybe-catch-ast)] + (if (< (length catch-asts) 2) + (u.throw* + (t.make-string + (.. "catch* requires at " + "least 2 " + "arguments"))) + (let [catch-sym-ast + (. catch-asts 2) + catch-body-ast + (. catch-asts 3)] + (EVAL catch-body-ast + (e.make-env + env + [catch-sym-ast] + [res])))))))) + res))) + ;; + (= "do" head-name) + (let [most-forms (u.slice ast-elts 2 -2) ;; XXX + last-body-form (u.last ast-elts) + res-ast (eval_ast + (t.make-list most-forms) env)] + ;; tco + (set ast last-body-form)) + ;; + (= "if" head-name) + (let [cond-res (EVAL (. ast-elts 2) env)] + (if (or (t.nil?* cond-res) + (t.false?* cond-res)) + (let [else-ast (. ast-elts 4)] + (if (not else-ast) + ;; tco + (set result t.mal-nil) + (set ast else-ast))) + ;; tco + (set ast (. ast-elts 3)))) + ;; + (= "fn*" head-name) + (let [params (t.get-value (. ast-elts 2)) + body (. ast-elts 3)] + ;; tco + (set result + (t.make-fn + (fn [args] + (EVAL body + (e.make-env env params args))) + body params env false nil))) + ;; + (let [eval-list (t.get-value (eval_ast ast env)) + f (. eval-list 1) + args (u.slice eval-list 2 -1)] + (let [body (t.get-ast f)] ;; tco + (if body + (do + (set ast body) + (set env + (e.make-env (t.get-env f) + (t.get-params f) + args))) + (set result + ((t.get-value f) args)))))))))))) + result)) + +(fn PRINT + [ast] + (printer.pr_str ast true)) + +(fn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e.env-set repl_env + (t.make-symbol "eval") + (t.make-fn + (fn [asts] + (when (< (length asts) 1) + (u.throw* + (t.make-string "eval takes 1 argument"))) + (EVAL (u.first asts) repl_env)))) + +(rep + (.. "(def! load-file " + " (fn* (f) " + " (eval " + " (read-string " + " (str \"(do \" (slurp f) \"\nnil)\")))))")) + +(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)))))))")) + +(e.env-set repl_env + (t.make-symbol "*host-language*") + (t.make-string "fennel")) + +(e.env-set repl_env + (t.make-symbol "*ARGV*") + (t.make-list (u.map t.make-string (u.slice arg 2 -1)))) + +(fn handle-error + [err] + (if (t.nil?* err) + (print) + (= "string" (type err)) + (print err) + (print (.. "Error: " (PRINT err))))) + +(if (<= 1 (length arg)) + (xpcall (fn [] + (rep (.. "(load-file \"" (. arg 1) "\")"))) ;; XXX: escaping? + handle-error) + (do + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (var done false) + (while (not done) + (io.write "user> ") + (io.flush) + (let [input (io.read)] + (if (not input) + (set done true) + (xpcall (fn [] + (print (rep input))) + handle-error)))))) diff --git a/impls/fennel/types.fnl b/impls/fennel/types.fnl index c2831300ab..d1263789ef 100644 --- a/impls/fennel/types.fnl +++ b/impls/fennel/types.fnl @@ -1,320 +1,320 @@ -(fn make-nil - [a-str] - {:tag :nil - :content "nil"}) - -(fn make-boolean - [a-bool] - {:tag :boolean - :content a-bool}) - -(fn make-number - [a-num] - {:tag :number - :content a-num}) - -(fn make-keyword - [a-str] - {:tag :keyword - :content a-str}) - -(fn make-symbol - [a-str] - {:tag :symbol - :content a-str}) - -(fn make-string - [a-str] - {:tag :string - :content a-str}) - -(local mal-nil (make-nil)) - -(fn make-list - [elts md] - (local md (if md md mal-nil)) - {:tag :list - :content elts - :md md}) - -(fn make-vector - [elts md] - (local md (if md md mal-nil)) - {:tag :vector - :content elts - :md md}) - -(fn make-hash-map - [elts md] - (local md (if md md mal-nil)) - {:tag :hash-map - :content elts - :md md}) - -(fn make-fn - [a-fn ast params env is-macro md] - (local is-macro (if is-macro is-macro false)) - (local md (if md md mal-nil)) - {:tag :fn - :content a-fn - :ast ast - :params params - :env env - :is-macro is-macro - :md md}) - -(fn make-atom - [ast] - {:tag :atom - :content ast}) - -(local mal-true (make-boolean true)) - -(local mal-false (make-boolean false)) - -;; - -(fn get-value - [ast] - (. ast :content)) - -(fn get-type - [ast] - (. ast :tag)) - -(fn get-md - [ast] - (. ast :md)) - -;; - -(fn get-is-macro - [ast] - (. ast :is-macro)) - -(fn get-ast - [ast] - (. ast :ast)) - -(fn get-params - [ast] - (. ast :params)) - -(fn get-env - [ast] - (. ast :env)) - -;; - -(fn nil?* - [ast] - (= :nil (. ast :tag))) - -(fn boolean?* - [ast] - (= :boolean (. ast :tag))) - -(fn number?* - [ast] - (= :number (. ast :tag))) - -(fn keyword?* - [ast] - (= :keyword (. ast :tag))) - -(fn symbol?* - [ast] - (= :symbol (. ast :tag))) - -(fn string?* - [ast] - (= :string (. ast :tag))) - -(fn list?* - [ast] - (= :list (. ast :tag))) - -(fn vector?* - [ast] - (= :vector (. ast :tag))) - -(fn hash-map?* - [ast] - (= :hash-map (. ast :tag))) - -(fn fn?* - [ast] - (= :fn (. ast :tag))) - -(fn atom?* - [ast] - (= :atom (. ast :tag))) - -(fn macro?* - [ast] - (and (fn?* ast) - (get-is-macro ast))) - -;; - -(fn macrofy - [fn-ast] - (local macro-ast {}) - (each [k v (pairs fn-ast)] - (tset macro-ast k v)) - (tset macro-ast - :is-macro true) - macro-ast) - -(fn clone-with-meta - [fn-ast meta-ast] - (local new-fn-ast {}) - (each [k v (pairs fn-ast)] - (tset new-fn-ast k v)) - (tset new-fn-ast - :md meta-ast) - new-fn-ast) - -;; - -(fn set-atom-value! - [atom-ast value-ast] - (tset atom-ast - :content value-ast)) - -(fn deref* - [ast] - (if (not (atom?* ast)) - ;; XXX - (error (.. "Expected atom, got: " (get-type ast))) - (get-value ast))) - -(fn reset!* - [atom-ast val-ast] - (set-atom-value! atom-ast val-ast) - val-ast) - -;; - -(fn empty?* - [ast] - (when (or (list?* ast) - (vector?* ast)) - (= (length (get-value ast)) 0))) - -(fn true?* - [ast] - (and (boolean?* ast) - (= true (get-value ast)))) - -(fn false?* - [ast] - (and (boolean?* ast) - (= false (get-value ast)))) - -(fn equals?* - [ast-1 ast-2] - (let [type-1 (get-type ast-1) - type-2 (get-type ast-2)] - (if (and (not= type-1 type-2) - ;; XXX: not elegant - (not (and (list?* ast-1) (vector?* ast-2))) - (not (and (list?* ast-2) (vector?* ast-1)))) - false - (let [val-1 (get-value ast-1) - val-2 (get-value ast-2)] - ;; XXX: when not a collection... - (if (and (not (list?* ast-1)) - (not (vector?* ast-1)) - (not (hash-map?* ast-1))) - (= val-1 val-2) - (if (not= (length val-1) (length val-2)) - false - (if (and (not (hash-map?* ast-1)) - (not (hash-map?* ast-2))) - (do - (var found-unequal false) - (var idx 1) - (while (and (not found-unequal) - (<= idx (length val-1))) - (let [v1 (. val-1 idx) - v2 (. val-2 idx)] - (when (not (equals?* v1 v2)) - (set found-unequal true)) - (set idx (+ idx 1)))) - (not found-unequal)) - (if (or (not (hash-map?* ast-1)) - (not (hash-map?* ast-2))) - false - (do - (var found-unequal false) - (var idx-in-1 1) - (while (and (not found-unequal) - (<= idx-in-1 (length val-1))) - (let [k1 (. val-1 idx-in-1)] - (var found-in-2 false) - (var idx-in-2 1) - (while (and (not found-in-2) - (<= idx-in-2 (length val-2))) - (let [k2 (. val-2 idx-in-2)] - (if (equals?* k1 k2) - (set found-in-2 true) - (set idx-in-2 (+ idx-in-2 2))))) - (if (not found-in-2) - (set found-unequal true) - (let [v1 (. val-1 (+ idx-in-1 1)) - v2 (. val-2 (+ idx-in-2 1))] - (if (not (equals?* v1 v2)) - (set found-unequal true) - (set idx-in-1 (+ idx-in-1 2))))))) - (not found-unequal)))))))))) - -{ - :make-nil make-nil - :make-boolean make-boolean - :make-number make-number - :make-keyword make-keyword - :make-symbol make-symbol - :make-string make-string - :make-list make-list - :make-vector make-vector - :make-hash-map make-hash-map - :make-fn make-fn - :make-atom make-atom - ;; - :mal-nil mal-nil - :mal-true mal-true - :mal-false mal-false - ;; - :get-value get-value - :get-md get-md - :get-is-macro get-is-macro - :get-ast get-ast - :get-params get-params - :get-env get-env - ;; - :nil?* nil?* - :boolean?* boolean?* - :number?* number?* - :keyword?* keyword?* - :symbol?* symbol?* - :string?* string?* - :list?* list?* - :vector?* vector?* - :hash-map?* hash-map?* - :fn?* fn?* - :atom?* atom?* - :macro?* macro?* - ;; - :macrofy macrofy - :clone-with-meta clone-with-meta - ;; - :set-atom-value! set-atom-value! - :deref* deref* - :reset!* reset!* - ;; - :empty?* empty?* - :true?* true?* - :false?* false?* - :equals?* equals?* -} +(fn make-nil + [a-str] + {:tag :nil + :content "nil"}) + +(fn make-boolean + [a-bool] + {:tag :boolean + :content a-bool}) + +(fn make-number + [a-num] + {:tag :number + :content a-num}) + +(fn make-keyword + [a-str] + {:tag :keyword + :content a-str}) + +(fn make-symbol + [a-str] + {:tag :symbol + :content a-str}) + +(fn make-string + [a-str] + {:tag :string + :content a-str}) + +(local mal-nil (make-nil)) + +(fn make-list + [elts md] + (local md (if md md mal-nil)) + {:tag :list + :content elts + :md md}) + +(fn make-vector + [elts md] + (local md (if md md mal-nil)) + {:tag :vector + :content elts + :md md}) + +(fn make-hash-map + [elts md] + (local md (if md md mal-nil)) + {:tag :hash-map + :content elts + :md md}) + +(fn make-fn + [a-fn ast params env is-macro md] + (local is-macro (if is-macro is-macro false)) + (local md (if md md mal-nil)) + {:tag :fn + :content a-fn + :ast ast + :params params + :env env + :is-macro is-macro + :md md}) + +(fn make-atom + [ast] + {:tag :atom + :content ast}) + +(local mal-true (make-boolean true)) + +(local mal-false (make-boolean false)) + +;; + +(fn get-value + [ast] + (. ast :content)) + +(fn get-type + [ast] + (. ast :tag)) + +(fn get-md + [ast] + (. ast :md)) + +;; + +(fn get-is-macro + [ast] + (. ast :is-macro)) + +(fn get-ast + [ast] + (. ast :ast)) + +(fn get-params + [ast] + (. ast :params)) + +(fn get-env + [ast] + (. ast :env)) + +;; + +(fn nil?* + [ast] + (= :nil (. ast :tag))) + +(fn boolean?* + [ast] + (= :boolean (. ast :tag))) + +(fn number?* + [ast] + (= :number (. ast :tag))) + +(fn keyword?* + [ast] + (= :keyword (. ast :tag))) + +(fn symbol?* + [ast] + (= :symbol (. ast :tag))) + +(fn string?* + [ast] + (= :string (. ast :tag))) + +(fn list?* + [ast] + (= :list (. ast :tag))) + +(fn vector?* + [ast] + (= :vector (. ast :tag))) + +(fn hash-map?* + [ast] + (= :hash-map (. ast :tag))) + +(fn fn?* + [ast] + (= :fn (. ast :tag))) + +(fn atom?* + [ast] + (= :atom (. ast :tag))) + +(fn macro?* + [ast] + (and (fn?* ast) + (get-is-macro ast))) + +;; + +(fn macrofy + [fn-ast] + (local macro-ast {}) + (each [k v (pairs fn-ast)] + (tset macro-ast k v)) + (tset macro-ast + :is-macro true) + macro-ast) + +(fn clone-with-meta + [fn-ast meta-ast] + (local new-fn-ast {}) + (each [k v (pairs fn-ast)] + (tset new-fn-ast k v)) + (tset new-fn-ast + :md meta-ast) + new-fn-ast) + +;; + +(fn set-atom-value! + [atom-ast value-ast] + (tset atom-ast + :content value-ast)) + +(fn deref* + [ast] + (if (not (atom?* ast)) + ;; XXX + (error (.. "Expected atom, got: " (get-type ast))) + (get-value ast))) + +(fn reset!* + [atom-ast val-ast] + (set-atom-value! atom-ast val-ast) + val-ast) + +;; + +(fn empty?* + [ast] + (when (or (list?* ast) + (vector?* ast)) + (= (length (get-value ast)) 0))) + +(fn true?* + [ast] + (and (boolean?* ast) + (= true (get-value ast)))) + +(fn false?* + [ast] + (and (boolean?* ast) + (= false (get-value ast)))) + +(fn equals?* + [ast-1 ast-2] + (let [type-1 (get-type ast-1) + type-2 (get-type ast-2)] + (if (and (not= type-1 type-2) + ;; XXX: not elegant + (not (and (list?* ast-1) (vector?* ast-2))) + (not (and (list?* ast-2) (vector?* ast-1)))) + false + (let [val-1 (get-value ast-1) + val-2 (get-value ast-2)] + ;; XXX: when not a collection... + (if (and (not (list?* ast-1)) + (not (vector?* ast-1)) + (not (hash-map?* ast-1))) + (= val-1 val-2) + (if (not= (length val-1) (length val-2)) + false + (if (and (not (hash-map?* ast-1)) + (not (hash-map?* ast-2))) + (do + (var found-unequal false) + (var idx 1) + (while (and (not found-unequal) + (<= idx (length val-1))) + (let [v1 (. val-1 idx) + v2 (. val-2 idx)] + (when (not (equals?* v1 v2)) + (set found-unequal true)) + (set idx (+ idx 1)))) + (not found-unequal)) + (if (or (not (hash-map?* ast-1)) + (not (hash-map?* ast-2))) + false + (do + (var found-unequal false) + (var idx-in-1 1) + (while (and (not found-unequal) + (<= idx-in-1 (length val-1))) + (let [k1 (. val-1 idx-in-1)] + (var found-in-2 false) + (var idx-in-2 1) + (while (and (not found-in-2) + (<= idx-in-2 (length val-2))) + (let [k2 (. val-2 idx-in-2)] + (if (equals?* k1 k2) + (set found-in-2 true) + (set idx-in-2 (+ idx-in-2 2))))) + (if (not found-in-2) + (set found-unequal true) + (let [v1 (. val-1 (+ idx-in-1 1)) + v2 (. val-2 (+ idx-in-2 1))] + (if (not (equals?* v1 v2)) + (set found-unequal true) + (set idx-in-1 (+ idx-in-1 2))))))) + (not found-unequal)))))))))) + +{ + :make-nil make-nil + :make-boolean make-boolean + :make-number make-number + :make-keyword make-keyword + :make-symbol make-symbol + :make-string make-string + :make-list make-list + :make-vector make-vector + :make-hash-map make-hash-map + :make-fn make-fn + :make-atom make-atom + ;; + :mal-nil mal-nil + :mal-true mal-true + :mal-false mal-false + ;; + :get-value get-value + :get-md get-md + :get-is-macro get-is-macro + :get-ast get-ast + :get-params get-params + :get-env get-env + ;; + :nil?* nil?* + :boolean?* boolean?* + :number?* number?* + :keyword?* keyword?* + :symbol?* symbol?* + :string?* string?* + :list?* list?* + :vector?* vector?* + :hash-map?* hash-map?* + :fn?* fn?* + :atom?* atom?* + :macro?* macro?* + ;; + :macrofy macrofy + :clone-with-meta clone-with-meta + ;; + :set-atom-value! set-atom-value! + :deref* deref* + :reset!* reset!* + ;; + :empty?* empty?* + :true?* true?* + :false?* false?* + :equals?* equals?* +} diff --git a/impls/fennel/utils.fnl b/impls/fennel/utils.fnl index c74a07e760..653731efb6 100644 --- a/impls/fennel/utils.fnl +++ b/impls/fennel/utils.fnl @@ -1,137 +1,137 @@ -(fn throw* - [ast] - (error ast)) - -(fn abs-index - [i len] - (if (> i 0) - i - (< i 0) - (+ len i 1) - nil)) - -(comment - - (abs-index 0 9) - ;; => nil - - (abs-index 1 9) - ;; => 1 - - (abs-index -1 9) - ;; => 9 - - (abs-index -2 9) - ;; => 8 - - ) - -(fn slice - [tbl beg end] - (local len-tbl (length tbl)) - (local new-beg - (if beg (abs-index beg len-tbl) 1)) - (local new-end - (if end (abs-index end len-tbl) len-tbl)) - (local start - (if (< new-beg 1) 1 new-beg)) - (local fin - (if (< len-tbl new-end) len-tbl new-end)) - (local new-tbl []) - (for [idx start fin] - (tset new-tbl - (+ (length new-tbl) 1) - (. tbl idx))) - new-tbl) - -(comment - - (slice [7 8 9] 2 -1) - ;; => [8 9] - - (slice [1 2 3] 1 2) - ;; => [1 2] - - ) - -(fn first - [tbl] - (. tbl 1)) - -(comment - - (first [7 8 9]) - ;; => 7 - - ) - -(fn last - [tbl] - (. tbl (length tbl))) - -(comment - - (last [7 8 9]) - ;; => 9 - - ) - -(fn map - [a-fn tbl] - (local new-tbl []) - (each [i elt (ipairs tbl)] - (tset new-tbl i (a-fn elt))) - new-tbl) - -(comment - - (map (fn [x] (+ x 1)) [7 8 9]) - ;; => [8 9 10] - - (map (fn [n] [n (+ n 1)]) [1 2 3]) - ;; => [[1 2] [2 3] [3 4]] - - ) - -(fn reverse - [tbl] - (local new-tbl []) - (for [i (length tbl) 1 -1] - (table.insert new-tbl (. tbl i))) - new-tbl) - -(comment - - (reverse [:a :b :c]) - ;; => ["c" "b" "a"] - - ) - -(fn concat-two - [tbl-1 tbl-2] - (local new-tbl []) - (each [i elt (ipairs tbl-1)] - (table.insert new-tbl elt)) - (each [i elt (ipairs tbl-2)] - (table.insert new-tbl elt)) - new-tbl) - -(comment - - (concat-two [:a :b :c] [:d :e :f]) - ;; => ["a" "b" "c" "d" "e" "f"] - - (concat-two {1 :a 2 :b 3 :c} {1 :d 2 :e 3 :f}) - ;; => ["a" "b" "c" "d" "e" "f"] - - ) - -{ - :throw* throw* - :slice slice - :first first - :last last - :map map - :reverse reverse - :concat-two concat-two -} +(fn throw* + [ast] + (error ast)) + +(fn abs-index + [i len] + (if (> i 0) + i + (< i 0) + (+ len i 1) + nil)) + +(comment + + (abs-index 0 9) + ;; => nil + + (abs-index 1 9) + ;; => 1 + + (abs-index -1 9) + ;; => 9 + + (abs-index -2 9) + ;; => 8 + + ) + +(fn slice + [tbl beg end] + (local len-tbl (length tbl)) + (local new-beg + (if beg (abs-index beg len-tbl) 1)) + (local new-end + (if end (abs-index end len-tbl) len-tbl)) + (local start + (if (< new-beg 1) 1 new-beg)) + (local fin + (if (< len-tbl new-end) len-tbl new-end)) + (local new-tbl []) + (for [idx start fin] + (tset new-tbl + (+ (length new-tbl) 1) + (. tbl idx))) + new-tbl) + +(comment + + (slice [7 8 9] 2 -1) + ;; => [8 9] + + (slice [1 2 3] 1 2) + ;; => [1 2] + + ) + +(fn first + [tbl] + (. tbl 1)) + +(comment + + (first [7 8 9]) + ;; => 7 + + ) + +(fn last + [tbl] + (. tbl (length tbl))) + +(comment + + (last [7 8 9]) + ;; => 9 + + ) + +(fn map + [a-fn tbl] + (local new-tbl []) + (each [i elt (ipairs tbl)] + (tset new-tbl i (a-fn elt))) + new-tbl) + +(comment + + (map (fn [x] (+ x 1)) [7 8 9]) + ;; => [8 9 10] + + (map (fn [n] [n (+ n 1)]) [1 2 3]) + ;; => [[1 2] [2 3] [3 4]] + + ) + +(fn reverse + [tbl] + (local new-tbl []) + (for [i (length tbl) 1 -1] + (table.insert new-tbl (. tbl i))) + new-tbl) + +(comment + + (reverse [:a :b :c]) + ;; => ["c" "b" "a"] + + ) + +(fn concat-two + [tbl-1 tbl-2] + (local new-tbl []) + (each [i elt (ipairs tbl-1)] + (table.insert new-tbl elt)) + (each [i elt (ipairs tbl-2)] + (table.insert new-tbl elt)) + new-tbl) + +(comment + + (concat-two [:a :b :c] [:d :e :f]) + ;; => ["a" "b" "c" "d" "e" "f"] + + (concat-two {1 :a 2 :b 3 :c} {1 :d 2 :e 3 :f}) + ;; => ["a" "b" "c" "d" "e" "f"] + + ) + +{ + :throw* throw* + :slice slice + :first first + :last last + :map map + :reverse reverse + :concat-two concat-two +} diff --git a/impls/forth/Dockerfile b/impls/forth/Dockerfile index c84caec2c4..8708913def 100644 --- a/impls/forth/Dockerfile +++ b/impls/forth/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install gforth +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install gforth diff --git a/impls/forth/Makefile b/impls/forth/Makefile index 70617396d2..f4204fd97b 100644 --- a/impls/forth/Makefile +++ b/impls/forth/Makefile @@ -1,19 +1,19 @@ -SOURCES_BASE = str.fs types.fs reader.fs printer.fs -SOURCES_LISP = env.fs core.fs stepA_mal.fs -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.fs mal - -mal.fs: $(SOURCES) - cat $+ | egrep -v "^require |^droprequire " > $@ - -mal: mal.fs - echo "#! /usr/bin/env gforth" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.fs mal +SOURCES_BASE = str.fs types.fs reader.fs printer.fs +SOURCES_LISP = env.fs core.fs stepA_mal.fs +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.fs mal + +mal.fs: $(SOURCES) + cat $+ | egrep -v "^require |^droprequire " > $@ + +mal: mal.fs + echo "#! /usr/bin/env gforth" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.fs mal diff --git a/impls/forth/core.fs b/impls/forth/core.fs index 9015f4a320..fc6e677a1f 100644 --- a/impls/forth/core.fs +++ b/impls/forth/core.fs @@ -1,249 +1,249 @@ -require env.fs - -0 MalEnv. constant core - -: args-as-native { argv argc -- entry*argc... } - argc 0 ?do - argv i cells + @ as-native - loop ; - -: defcore* ( sym xt ) - MalNativeFn. core env/set ; - -: defcore - parse-allot-name MalSymbol. ( xt ) - ['] defcore* :noname ; - -defcore + args-as-native + MalInt. ;; -defcore - args-as-native - MalInt. ;; -defcore * args-as-native * MalInt. ;; -defcore / args-as-native / MalInt. ;; -defcore < args-as-native < mal-bool ;; -defcore > args-as-native > mal-bool ;; -defcore <= args-as-native <= mal-bool ;; -defcore >= args-as-native >= mal-bool ;; - -defcore list { argv argc } - argc cells allocate throw { start } - argv start argc cells cmove - start argc MalList. ;; - -defcore vector { argv argc } - argc cells allocate throw { start } - argv start argc cells cmove - start argc MalList. - MalVector new swap over MalVector/list ! ;; - -defcore empty? drop @ empty? ;; -defcore count drop @ mal-count ;; - -defcore = drop dup @ swap cell+ @ swap m= mal-bool ;; - -: pr-str-multi ( readably? argv argc ) - ?dup 0= if drop 0 0 - else - { argv argc } - new-str - argv @ pr-buf - argc 1 ?do - a-space - argv i cells + @ pr-buf - loop - endif ; - -defcore prn true -rot pr-str-multi type cr drop mal-nil ;; -defcore pr-str true -rot pr-str-multi MalString. nip ;; -defcore println false -rot pr-str-multi type cr drop mal-nil ;; -defcore str ( argv argc ) - dup 0= if - MalString. - else - { argv argc } - false new-str - argc 0 ?do - argv i cells + @ pr-buf - loop - MalString. nip - endif ;; - -defcore read-string drop @ unpack-str read-str ;; -defcore slurp drop @ unpack-str slurp-file MalString. ;; - -create core-buff 128 allot -defcore readline ( argv argc -- mal-string ) - drop @ unpack-str type stdout flush-file drop - core-buff 128 stdin read-line throw - if core-buff swap MalString. else drop mal-nil endif ;; - - -defcore cons ( argv[item,coll] argc ) - drop dup @ swap cell+ @ ( item coll ) - to-list conj ;; - -defcore concat { lists argc } - MalList new - lists over MalList/start ! - argc over MalList/count ! - MalList/concat ;; - -defcore vec ( argv[coll] argc ) - drop - @ - dup mal-type @ MalList = if - MalVector new tuck MalVector/list ! - endif ;; - -defcore conj { argv argc } - argv @ ( coll ) - argc 1 ?do - argv i cells + @ swap conj - loop ;; - -defcore seq drop @ seq ;; - -defcore assoc { argv argc } - argv @ ( coll ) - argv argc cells + argv cell+ +do - i @ \ key - i cell+ @ \ val - rot assoc - 2 cells +loop ;; - -defcore keys ( argv argc ) - drop @ MalMap/list @ - dup MalList/start @ swap MalList/count @ { start count } - here - start count cells + start +do - i @ , - 2 cells +loop - here>MalList ;; - -defcore vals ( argv argc ) - drop @ MalMap/list @ - dup MalList/start @ swap MalList/count @ { start count } - here - start count cells + start cell+ +do - i @ , - 2 cells +loop - here>MalList ;; - -defcore dissoc { argv argc } - argv @ \ coll - argv argc cells + argv cell+ +do - i @ swap dissoc - cell +loop ;; - -defcore hash-map { argv argc } - MalMap/Empty - argc cells argv + argv +do - i @ i cell+ @ rot assoc - 2 cells +loop ;; - -defcore get { argv argc } - argc 3 < if mal-nil else argv cell+ cell+ @ endif - argv cell+ @ \ key - argv @ \ coll - get ;; - -defcore contains? { argv argc } - 0 - argv cell+ @ \ key - argv @ \ coll - get 0 <> mal-bool ;; - -defcore nth ( argv[coll,i] argc ) - drop dup @ to-list ( argv list ) - swap cell+ @ MalInt/int @ ( list i ) - over MalList/count @ ( list i count ) - 2dup >= if { i count } - 0 0 - new-str i int>str str-append s\" \040>= " count int>str - s" nth out of bounds: " ...throw-str - endif drop ( list i ) - cells swap ( c-offset list ) - MalList/start @ + @ ;; - -defcore first ( argv[coll] argc ) - drop @ to-list - dup MalList/count @ 0= if - drop mal-nil - else - MalList/start @ @ - endif ;; - -defcore rest ( argv[coll] argc ) - drop @ to-list MalList/rest ;; - -defcore meta ( argv[obj] argc ) - drop @ mal-meta @ - ?dup 0= if mal-nil endif ;; - -defcore with-meta ( argv[obj,meta] argc ) - drop ( argv ) - dup cell+ @ swap @ ( meta obj ) - dup mal-type @ MalTypeType-struct @ ( meta obj obj-size ) - dup allocate throw { new-obj } ( meta obj obj-size ) - new-obj swap cmove ( meta ) - new-obj mal-meta ! ( ) - new-obj ;; - -defcore atom ( argv[val] argc ) - drop @ Atom. ;; - -defcore deref ( argv[atom] argc ) - drop @ Atom/val @ ;; - -defcore reset! ( argv[atom,val] argc ) - drop dup cell+ @ ( argv val ) - dup -rot swap @ Atom/val ! ;; - -defcore apply { argv argc -- val } - \ argv is (fn args... more-args) - argv argc 1- cells + @ to-list { more-args } - argc 2 - { list0len } - more-args MalList/count @ list0len + { final-argc } - final-argc cells allocate throw { final-argv } - argv cell+ final-argv list0len cells cmove - more-args MalList/start @ final-argv list0len cells + final-argc list0len - cells cmove - final-argv final-argc argv @ invoke ;; - -defcore throw ( argv argc -- ) - drop @ to exception-object - 1 throw ;; - -defcore map? drop @ mal-type @ MalMap = mal-bool ;; -defcore list? drop @ mal-type @ MalList = mal-bool ;; -defcore vector? drop @ mal-type @ MalVector = mal-bool ;; -defcore keyword? drop @ mal-type @ MalKeyword = mal-bool ;; -defcore symbol? drop @ mal-type @ MalSymbol = mal-bool ;; -defcore string? drop @ mal-type @ MalString = mal-bool ;; -defcore atom? drop @ mal-type @ Atom = mal-bool ;; -defcore true? drop @ mal-true = mal-bool ;; -defcore false? drop @ mal-false = mal-bool ;; -defcore nil? drop @ mal-nil = mal-bool ;; -defcore number? drop @ mal-type @ MalInt = mal-bool ;; -defcore fn? - drop @ - dup mal-type @ MalUserFn = if - MalUserFn/is-macro? @ if - mal-false - else - mal-true - endif - else - mal-type @ MalNativeFn = if - mal-true - else - mal-false - endif - endif ;; -defcore macro? drop @ dup mal-type @ MalUserFn = - swap MalUserFn/is-macro? @ - and mal-bool ;; - -defcore sequential? drop @ sequential? ;; - -defcore keyword drop @ unpack-str MalKeyword. ;; -defcore symbol drop @ unpack-str MalSymbol. ;; - -defcore time-ms 2drop utime d>s 1000 / MalInt. ;; +require env.fs + +0 MalEnv. constant core + +: args-as-native { argv argc -- entry*argc... } + argc 0 ?do + argv i cells + @ as-native + loop ; + +: defcore* ( sym xt ) + MalNativeFn. core env/set ; + +: defcore + parse-allot-name MalSymbol. ( xt ) + ['] defcore* :noname ; + +defcore + args-as-native + MalInt. ;; +defcore - args-as-native - MalInt. ;; +defcore * args-as-native * MalInt. ;; +defcore / args-as-native / MalInt. ;; +defcore < args-as-native < mal-bool ;; +defcore > args-as-native > mal-bool ;; +defcore <= args-as-native <= mal-bool ;; +defcore >= args-as-native >= mal-bool ;; + +defcore list { argv argc } + argc cells allocate throw { start } + argv start argc cells cmove + start argc MalList. ;; + +defcore vector { argv argc } + argc cells allocate throw { start } + argv start argc cells cmove + start argc MalList. + MalVector new swap over MalVector/list ! ;; + +defcore empty? drop @ empty? ;; +defcore count drop @ mal-count ;; + +defcore = drop dup @ swap cell+ @ swap m= mal-bool ;; + +: pr-str-multi ( readably? argv argc ) + ?dup 0= if drop 0 0 + else + { argv argc } + new-str + argv @ pr-buf + argc 1 ?do + a-space + argv i cells + @ pr-buf + loop + endif ; + +defcore prn true -rot pr-str-multi type cr drop mal-nil ;; +defcore pr-str true -rot pr-str-multi MalString. nip ;; +defcore println false -rot pr-str-multi type cr drop mal-nil ;; +defcore str ( argv argc ) + dup 0= if + MalString. + else + { argv argc } + false new-str + argc 0 ?do + argv i cells + @ pr-buf + loop + MalString. nip + endif ;; + +defcore read-string drop @ unpack-str read-str ;; +defcore slurp drop @ unpack-str slurp-file MalString. ;; + +create core-buff 128 allot +defcore readline ( argv argc -- mal-string ) + drop @ unpack-str type stdout flush-file drop + core-buff 128 stdin read-line throw + if core-buff swap MalString. else drop mal-nil endif ;; + + +defcore cons ( argv[item,coll] argc ) + drop dup @ swap cell+ @ ( item coll ) + to-list conj ;; + +defcore concat { lists argc } + MalList new + lists over MalList/start ! + argc over MalList/count ! + MalList/concat ;; + +defcore vec ( argv[coll] argc ) + drop + @ + dup mal-type @ MalList = if + MalVector new tuck MalVector/list ! + endif ;; + +defcore conj { argv argc } + argv @ ( coll ) + argc 1 ?do + argv i cells + @ swap conj + loop ;; + +defcore seq drop @ seq ;; + +defcore assoc { argv argc } + argv @ ( coll ) + argv argc cells + argv cell+ +do + i @ \ key + i cell+ @ \ val + rot assoc + 2 cells +loop ;; + +defcore keys ( argv argc ) + drop @ MalMap/list @ + dup MalList/start @ swap MalList/count @ { start count } + here + start count cells + start +do + i @ , + 2 cells +loop + here>MalList ;; + +defcore vals ( argv argc ) + drop @ MalMap/list @ + dup MalList/start @ swap MalList/count @ { start count } + here + start count cells + start cell+ +do + i @ , + 2 cells +loop + here>MalList ;; + +defcore dissoc { argv argc } + argv @ \ coll + argv argc cells + argv cell+ +do + i @ swap dissoc + cell +loop ;; + +defcore hash-map { argv argc } + MalMap/Empty + argc cells argv + argv +do + i @ i cell+ @ rot assoc + 2 cells +loop ;; + +defcore get { argv argc } + argc 3 < if mal-nil else argv cell+ cell+ @ endif + argv cell+ @ \ key + argv @ \ coll + get ;; + +defcore contains? { argv argc } + 0 + argv cell+ @ \ key + argv @ \ coll + get 0 <> mal-bool ;; + +defcore nth ( argv[coll,i] argc ) + drop dup @ to-list ( argv list ) + swap cell+ @ MalInt/int @ ( list i ) + over MalList/count @ ( list i count ) + 2dup >= if { i count } + 0 0 + new-str i int>str str-append s\" \040>= " count int>str + s" nth out of bounds: " ...throw-str + endif drop ( list i ) + cells swap ( c-offset list ) + MalList/start @ + @ ;; + +defcore first ( argv[coll] argc ) + drop @ to-list + dup MalList/count @ 0= if + drop mal-nil + else + MalList/start @ @ + endif ;; + +defcore rest ( argv[coll] argc ) + drop @ to-list MalList/rest ;; + +defcore meta ( argv[obj] argc ) + drop @ mal-meta @ + ?dup 0= if mal-nil endif ;; + +defcore with-meta ( argv[obj,meta] argc ) + drop ( argv ) + dup cell+ @ swap @ ( meta obj ) + dup mal-type @ MalTypeType-struct @ ( meta obj obj-size ) + dup allocate throw { new-obj } ( meta obj obj-size ) + new-obj swap cmove ( meta ) + new-obj mal-meta ! ( ) + new-obj ;; + +defcore atom ( argv[val] argc ) + drop @ Atom. ;; + +defcore deref ( argv[atom] argc ) + drop @ Atom/val @ ;; + +defcore reset! ( argv[atom,val] argc ) + drop dup cell+ @ ( argv val ) + dup -rot swap @ Atom/val ! ;; + +defcore apply { argv argc -- val } + \ argv is (fn args... more-args) + argv argc 1- cells + @ to-list { more-args } + argc 2 - { list0len } + more-args MalList/count @ list0len + { final-argc } + final-argc cells allocate throw { final-argv } + argv cell+ final-argv list0len cells cmove + more-args MalList/start @ final-argv list0len cells + final-argc list0len - cells cmove + final-argv final-argc argv @ invoke ;; + +defcore throw ( argv argc -- ) + drop @ to exception-object + 1 throw ;; + +defcore map? drop @ mal-type @ MalMap = mal-bool ;; +defcore list? drop @ mal-type @ MalList = mal-bool ;; +defcore vector? drop @ mal-type @ MalVector = mal-bool ;; +defcore keyword? drop @ mal-type @ MalKeyword = mal-bool ;; +defcore symbol? drop @ mal-type @ MalSymbol = mal-bool ;; +defcore string? drop @ mal-type @ MalString = mal-bool ;; +defcore atom? drop @ mal-type @ Atom = mal-bool ;; +defcore true? drop @ mal-true = mal-bool ;; +defcore false? drop @ mal-false = mal-bool ;; +defcore nil? drop @ mal-nil = mal-bool ;; +defcore number? drop @ mal-type @ MalInt = mal-bool ;; +defcore fn? + drop @ + dup mal-type @ MalUserFn = if + MalUserFn/is-macro? @ if + mal-false + else + mal-true + endif + else + mal-type @ MalNativeFn = if + mal-true + else + mal-false + endif + endif ;; +defcore macro? drop @ dup mal-type @ MalUserFn = + swap MalUserFn/is-macro? @ + and mal-bool ;; + +defcore sequential? drop @ sequential? ;; + +defcore keyword drop @ unpack-str MalKeyword. ;; +defcore symbol drop @ unpack-str MalSymbol. ;; + +defcore time-ms 2drop utime d>s 1000 / MalInt. ;; diff --git a/impls/forth/env.fs b/impls/forth/env.fs index 9469bf2b1a..7d76af3896 100644 --- a/impls/forth/env.fs +++ b/impls/forth/env.fs @@ -1,38 +1,38 @@ -require types.fs - -MalType% - cell% field MalEnv/outer - cell% field MalEnv/data -deftype MalEnv - -: MalEnv. { outer -- env } - MalEnv new { env } - outer env MalEnv/outer ! - MalMap/Empty env MalEnv/data ! - env ; - -: env/set { key val env -- } - key val env MalEnv/data @ assoc - env MalEnv/data ! ; - -: env/get-addr { key env -- val-addr } - env - begin ( env ) - key over MalEnv/data @ MalMap/get-addr ( env addr-or-0 ) - ?dup 0= if ( env ) - MalEnv/outer @ dup 0= ( env-or-0 done-looping? ) - else ( env addr ) - nip -1 \ found it! ( addr -1 ) - endif - until ; - -MalEnv - extend pr-buf { env } - env MalEnv/data @ pr-buf - a-space s" outer: " str-append - env MalEnv/outer @ ?dup 0= if - s" " str-append - else - pr-buf - endif ;; -drop +require types.fs + +MalType% + cell% field MalEnv/outer + cell% field MalEnv/data +deftype MalEnv + +: MalEnv. { outer -- env } + MalEnv new { env } + outer env MalEnv/outer ! + MalMap/Empty env MalEnv/data ! + env ; + +: env/set { key val env -- } + key val env MalEnv/data @ assoc + env MalEnv/data ! ; + +: env/get-addr { key env -- val-addr } + env + begin ( env ) + key over MalEnv/data @ MalMap/get-addr ( env addr-or-0 ) + ?dup 0= if ( env ) + MalEnv/outer @ dup 0= ( env-or-0 done-looping? ) + else ( env addr ) + nip -1 \ found it! ( addr -1 ) + endif + until ; + +MalEnv + extend pr-buf { env } + env MalEnv/data @ pr-buf + a-space s" outer: " str-append + env MalEnv/outer @ ?dup 0= if + s" " str-append + else + pr-buf + endif ;; +drop diff --git a/impls/forth/misc-tests.fs b/impls/forth/misc-tests.fs index 6b6d643d48..785cb42964 100644 --- a/impls/forth/misc-tests.fs +++ b/impls/forth/misc-tests.fs @@ -1,100 +1,100 @@ -require printer.fs - -\ === basic testing util === / -: test= - 2dup m= if - 2drop - else - cr ." assert failed on line " sourceline# . - swap cr ." | got " . cr ." | expected " . cr - endif ; - -\ array function tests -create za 2 , 6 , 7 , 10 , 15 , 80 , 81 , - -7 za 2 array-find -1 test= 0 test= -7 za 6 array-find -1 test= 1 test= -7 za 10 array-find -1 test= 3 test= -7 za 81 array-find -1 test= 6 test= -7 za 12 array-find 0 test= 4 test= -7 za 8 array-find 0 test= 3 test= -7 za 100 array-find 0 test= 7 test= -7 za 1 array-find 0 test= 0 test= -6 za 81 array-find 0 test= 6 test= - -10 new-array -1 swap 0 5 array-insert -2 swap 1 7 array-insert -3 swap 3 12 array-insert -4 swap 4 15 array-insert -5 swap 5 20 array-insert - -dup 0 cells + @ 5 test= -dup 1 cells + @ 7 test= -dup 2 cells + @ 10 test= -dup 3 cells + @ 12 test= -dup 4 cells + @ 15 test= -dup 5 cells + @ 20 test= - - -\ Protocol tests - -: t1 -mal-nil -42 MalInt. mal-nil conj -10 MalInt. mal-nil conj conj -20 MalInt. swap conj -23 MalInt. mal-nil conj conj conj -pr-str s" (nil (20 (42) 10) 23)" str= -1 test= - -1500 MalInt. 1500 MalInt. test= - -\ MalList tests - -here 1 MalInt. , 2 MalInt. , 3 MalInt. , here>MalList -4 MalInt. swap conj -5 MalInt. swap conj -pr-str s" (5 4 1 2 3)" str= -1 test= - -\ map tests - -s" one" MalString. s" one" MalString. test= -s" one" MalString. s" x" MalString. m= 0 test= - -MalMap/Empty -1000 MalInt. 1100 rot assoc -2000 MalInt. 2100 rot assoc -3000 MalInt. 3100 rot assoc - -dup 99 2000 MalInt. rot get 2100 test= -dup 99 4000 MalInt. rot get 99 test= -drop - -MalMap/Empty -s" one" MalString. s" first" MalString. rot assoc -s" two" MalString. s" second" MalString. rot assoc -s" three" MalString. s" third" MalString. rot assoc - -dup 99 s" two" MalString. rot get s" second" MalString. test= -dup 99 s" none" MalString. rot get 99 test= -drop - -99 MalInt. 10 MalInt. MalMap/Empty get 99 MalInt. test= - -; -t1 - -\ eval tests - -require step2_eval.fs - -: t2 -mal-nil - 1 MalInt. swap conj - 2 MalInt. swap conj - 3 MalInt. swap conj -mal-eval -; -t2 - -bye +require printer.fs + +\ === basic testing util === / +: test= + 2dup m= if + 2drop + else + cr ." assert failed on line " sourceline# . + swap cr ." | got " . cr ." | expected " . cr + endif ; + +\ array function tests +create za 2 , 6 , 7 , 10 , 15 , 80 , 81 , + +7 za 2 array-find -1 test= 0 test= +7 za 6 array-find -1 test= 1 test= +7 za 10 array-find -1 test= 3 test= +7 za 81 array-find -1 test= 6 test= +7 za 12 array-find 0 test= 4 test= +7 za 8 array-find 0 test= 3 test= +7 za 100 array-find 0 test= 7 test= +7 za 1 array-find 0 test= 0 test= +6 za 81 array-find 0 test= 6 test= + +10 new-array +1 swap 0 5 array-insert +2 swap 1 7 array-insert +3 swap 3 12 array-insert +4 swap 4 15 array-insert +5 swap 5 20 array-insert + +dup 0 cells + @ 5 test= +dup 1 cells + @ 7 test= +dup 2 cells + @ 10 test= +dup 3 cells + @ 12 test= +dup 4 cells + @ 15 test= +dup 5 cells + @ 20 test= + + +\ Protocol tests + +: t1 +mal-nil +42 MalInt. mal-nil conj +10 MalInt. mal-nil conj conj +20 MalInt. swap conj +23 MalInt. mal-nil conj conj conj +pr-str s" (nil (20 (42) 10) 23)" str= -1 test= + +1500 MalInt. 1500 MalInt. test= + +\ MalList tests + +here 1 MalInt. , 2 MalInt. , 3 MalInt. , here>MalList +4 MalInt. swap conj +5 MalInt. swap conj +pr-str s" (5 4 1 2 3)" str= -1 test= + +\ map tests + +s" one" MalString. s" one" MalString. test= +s" one" MalString. s" x" MalString. m= 0 test= + +MalMap/Empty +1000 MalInt. 1100 rot assoc +2000 MalInt. 2100 rot assoc +3000 MalInt. 3100 rot assoc + +dup 99 2000 MalInt. rot get 2100 test= +dup 99 4000 MalInt. rot get 99 test= +drop + +MalMap/Empty +s" one" MalString. s" first" MalString. rot assoc +s" two" MalString. s" second" MalString. rot assoc +s" three" MalString. s" third" MalString. rot assoc + +dup 99 s" two" MalString. rot get s" second" MalString. test= +dup 99 s" none" MalString. rot get 99 test= +drop + +99 MalInt. 10 MalInt. MalMap/Empty get 99 MalInt. test= + +; +t1 + +\ eval tests + +require step2_eval.fs + +: t2 +mal-nil + 1 MalInt. swap conj + 2 MalInt. swap conj + 3 MalInt. swap conj +mal-eval +; +t2 + +bye diff --git a/impls/forth/printer.fs b/impls/forth/printer.fs index 7030e58a60..b3ef04b148 100644 --- a/impls/forth/printer.fs +++ b/impls/forth/printer.fs @@ -1,114 +1,114 @@ -require str.fs -require types.fs - -\ === printer protocol and implementations === / - -def-protocol-method pr-buf ( readably? str-addr str-len this -- str-addr str-len ) -def-protocol-method pr-seq-buf ( readably? str-addr str-len this -- str-addr str-len ) - -: pr-str { obj } - true new-str obj pr-buf rot drop ; - -\ Examples of extending existing protocol methods to existing type -MalDefault - extend pr-buf - { this } - s" #<" str-append - this mal-type @ type-name str-append - a-space - this int>str str-append - s" >" str-append ;; -drop - -MalNil extend pr-buf drop s" nil" str-append ;; drop -MalTrue extend pr-buf drop s" true" str-append ;; drop -MalFalse extend pr-buf drop s" false" str-append ;; drop - -MalList - extend pr-buf - -rot s" (" str-append ( list str-addr str-len ) - rot pr-seq-buf - s" )" str-append ;; - extend pr-seq-buf { list } - list MalList/count @ 0 > if - list MalList/start @ { start } - start @ pr-buf - list MalList/count @ 1 ?do - a-space - start i cells + @ pr-buf - loop - endif ;; -drop - -MalVector - extend pr-buf - MalVector/list @ - -rot s" [" str-append ( list str-addr str-len ) - rot pr-seq-buf - s" ]" str-append ;; -drop - -MalMap - extend pr-buf - MalMap/list @ - -rot s" {" str-append ( list str-addr str-len ) - rot { list } - list MalList/count @ { count } - count 0 > if - list MalList/start @ { start } - start @ pr-buf a-space start cell+ @ pr-buf - count 2 / 1 ?do - a-space - start i 2 * cells + @ pr-buf a-space - start i 2 * 1+ cells + @ pr-buf - loop - endif - s" }" str-append ;; -drop - -MalInt - extend pr-buf - MalInt/int @ int>str str-append ;; -drop - -MalSymbol - extend pr-buf - unpack-sym str-append ;; -drop - -MalKeyword - extend pr-buf { kw } - s" :" str-append - kw unpack-keyword str-append ;; -drop - -: escape-str { addr len } - s\" \"" str-append - addr len + addr ?do - i c@ case - [char] " of s\" \\\"" str-append endof - [char] \ of s\" \\\\" str-append endof - 10 of s\" \\n" str-append endof - 13 of s\" \\r" str-append endof - -rot i 1 str-append rot - endcase - loop - s\" \"" str-append ; - -MalString - extend pr-buf - dup MalString/str-addr @ - swap MalString/str-len @ - 4 pick if - escape-str - else - str-append - endif ;; -drop - -Atom - extend pr-buf { this } - s" (atom " str-append - this Atom/val @ pr-buf - s" )" str-append ;; +require str.fs +require types.fs + +\ === printer protocol and implementations === / + +def-protocol-method pr-buf ( readably? str-addr str-len this -- str-addr str-len ) +def-protocol-method pr-seq-buf ( readably? str-addr str-len this -- str-addr str-len ) + +: pr-str { obj } + true new-str obj pr-buf rot drop ; + +\ Examples of extending existing protocol methods to existing type +MalDefault + extend pr-buf + { this } + s" #<" str-append + this mal-type @ type-name str-append + a-space + this int>str str-append + s" >" str-append ;; +drop + +MalNil extend pr-buf drop s" nil" str-append ;; drop +MalTrue extend pr-buf drop s" true" str-append ;; drop +MalFalse extend pr-buf drop s" false" str-append ;; drop + +MalList + extend pr-buf + -rot s" (" str-append ( list str-addr str-len ) + rot pr-seq-buf + s" )" str-append ;; + extend pr-seq-buf { list } + list MalList/count @ 0 > if + list MalList/start @ { start } + start @ pr-buf + list MalList/count @ 1 ?do + a-space + start i cells + @ pr-buf + loop + endif ;; +drop + +MalVector + extend pr-buf + MalVector/list @ + -rot s" [" str-append ( list str-addr str-len ) + rot pr-seq-buf + s" ]" str-append ;; +drop + +MalMap + extend pr-buf + MalMap/list @ + -rot s" {" str-append ( list str-addr str-len ) + rot { list } + list MalList/count @ { count } + count 0 > if + list MalList/start @ { start } + start @ pr-buf a-space start cell+ @ pr-buf + count 2 / 1 ?do + a-space + start i 2 * cells + @ pr-buf a-space + start i 2 * 1+ cells + @ pr-buf + loop + endif + s" }" str-append ;; +drop + +MalInt + extend pr-buf + MalInt/int @ int>str str-append ;; +drop + +MalSymbol + extend pr-buf + unpack-sym str-append ;; +drop + +MalKeyword + extend pr-buf { kw } + s" :" str-append + kw unpack-keyword str-append ;; +drop + +: escape-str { addr len } + s\" \"" str-append + addr len + addr ?do + i c@ case + [char] " of s\" \\\"" str-append endof + [char] \ of s\" \\\\" str-append endof + 10 of s\" \\n" str-append endof + 13 of s\" \\r" str-append endof + -rot i 1 str-append rot + endcase + loop + s\" \"" str-append ; + +MalString + extend pr-buf + dup MalString/str-addr @ + swap MalString/str-len @ + 4 pick if + escape-str + else + str-append + endif ;; +drop + +Atom + extend pr-buf { this } + s" (atom " str-append + this Atom/val @ pr-buf + s" )" str-append ;; drop \ No newline at end of file diff --git a/impls/forth/reader.fs b/impls/forth/reader.fs index 2fbccae519..1f57062775 100644 --- a/impls/forth/reader.fs +++ b/impls/forth/reader.fs @@ -1,151 +1,151 @@ -require types.fs -require printer.fs - -\ Drop a char off the front of string by advancing the addr and -\ decrementing the length, and fetch next char -: adv-str ( str-addr str-len -- str-addr str-len char ) - swap 1+ swap 1- - dup 0= if 0 ( eof ) - else over c@ endif ; - -: mal-digit? ( char -- flag ) - dup [char] 9 <= if - [char] 0 >= - else - drop 0 - endif ; - -: char-in-str? ( char str-addr str-len ) - rot { needle } - false -rot - over + swap ?do - i c@ needle = if drop true leave endif - loop ; - -: sym-char? ( char -- flag ) - s\" \n\r\t\000[]{}()'\"`,; " char-in-str? 0= ; - -: skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char ) - begin - begin - dup s\" \n\r\t, " char-in-str? - while ( str-addr str-len space-char ) - drop adv-str - repeat - dup [char] ; = if - drop - begin - adv-str s\" \n\r\000" char-in-str? - until - adv-str false - else - true - endif - until ; - -defer read-form ( str-addr str-len -- str-addr str-len mal-obj ) - -: read-int ( str-addr str-len digit-char -- str-addr str-len non-digit-char mal-int ) - 0 { int } - 0 { neg } - dup [char] - = if drop adv-str 1 to neg endif - begin ( str-addr str-len digit-char ) - [char] 0 - int 10 * + to int ( str-addr str-len ) - adv-str dup mal-digit? 0= ( str-addr str-len digit-char ) - until - neg if 0 int - to int endif - int MalInt. ; - -: read-symbol-str ( str-addr str-len sym-char -- str-addr str-len char sym-addr sym-len ) - new-str { sym-addr sym-len } - begin ( str-addr str-len sym-char ) - sym-addr sym-len rot str-append-char to sym-len to sym-addr - adv-str dup sym-char? 0= - until - sym-addr sym-len ; - -: read-string-literal ( in-addr in-len quote-char -- in-addr in-len mal-string ) - new-str { out-addr out-len } - drop \ drop leading quote - begin ( in-addr in-len ) - adv-str over 0= if - 2drop 0 0 s\" expected '\"', got EOF" ...throw-str - endif - dup [char] " <> - while - dup [char] \ = if - drop adv-str - dup [char] n = if drop 10 endif - dup [char] r = if drop 13 endif - endif - out-addr out-len rot str-append-char to out-len to out-addr - repeat - drop adv-str \ skip trailing quote - out-addr out-len MalString. ; - -: read-list ( str-addr str-len open-paren-char close-paren-char - -- str-addr str-len non-paren-char mal-list ) - here { close-char old-here } - drop adv-str - begin ( str-addr str-len char ) - skip-spaces ( str-addr str-len non-space-char ) - over 0= if - drop 2drop 0 0 s" ', got EOF" - close-char pad ! pad 1 - s" expected '" ...throw-str - endif - dup close-char <> - while ( str-addr str-len non-space-non-paren-char ) - read-form , - repeat - drop adv-str - old-here here>MalList ; - -s" deref" MalSymbol. constant deref-sym -s" quote" MalSymbol. constant quote-sym -s" quasiquote" MalSymbol. constant quasiquote-sym -s" splice-unquote" MalSymbol. constant splice-unquote-sym -s" unquote" MalSymbol. constant unquote-sym - -: read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list ) - here { old-here } - , ( buf-addr buf-len char ) - read-form , ( buf-addr buf-len char ) - old-here here>MalList ; - -: read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj ) - skip-spaces - dup [char] - = 3 pick 1 + c@ mal-digit? and if read-int else - dup mal-digit? if read-int else - dup [char] ( = if [char] ) read-list else - dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else - dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else - dup [char] " = if read-string-literal else - dup [char] : = if drop adv-str read-symbol-str MalKeyword. else - dup [char] @ = if drop adv-str deref-sym read-wrapped else - dup [char] ' = if drop adv-str quote-sym read-wrapped else - dup [char] ` = if drop adv-str quasiquote-sym read-wrapped else - dup [char] ~ = if - drop adv-str - dup [char] @ = if drop adv-str splice-unquote-sym read-wrapped - else unquote-sym read-wrapped - endif - else - dup [char] ^ = if - drop adv-str - read-form { meta } read-form { obj } - meta mal-nil conj - obj swap conj - s" with-meta" MalSymbol. swap conj - else - read-symbol-str - 2dup s" true" str= if 2drop mal-true - else 2dup s" false" str= if 2drop mal-false - else 2dup s" nil" str= if 2drop mal-nil - else - MalSymbol. - endif endif endif endif endif endif endif endif endif endif endif endif endif endif endif ; -' read-form2 is read-form - -: read-str ( str-addr str-len - mal-obj ) - over c@ read-form { obj } drop 2drop obj ; +require types.fs +require printer.fs + +\ Drop a char off the front of string by advancing the addr and +\ decrementing the length, and fetch next char +: adv-str ( str-addr str-len -- str-addr str-len char ) + swap 1+ swap 1- + dup 0= if 0 ( eof ) + else over c@ endif ; + +: mal-digit? ( char -- flag ) + dup [char] 9 <= if + [char] 0 >= + else + drop 0 + endif ; + +: char-in-str? ( char str-addr str-len ) + rot { needle } + false -rot + over + swap ?do + i c@ needle = if drop true leave endif + loop ; + +: sym-char? ( char -- flag ) + s\" \n\r\t\000[]{}()'\"`,; " char-in-str? 0= ; + +: skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char ) + begin + begin + dup s\" \n\r\t, " char-in-str? + while ( str-addr str-len space-char ) + drop adv-str + repeat + dup [char] ; = if + drop + begin + adv-str s\" \n\r\000" char-in-str? + until + adv-str false + else + true + endif + until ; + +defer read-form ( str-addr str-len -- str-addr str-len mal-obj ) + +: read-int ( str-addr str-len digit-char -- str-addr str-len non-digit-char mal-int ) + 0 { int } + 0 { neg } + dup [char] - = if drop adv-str 1 to neg endif + begin ( str-addr str-len digit-char ) + [char] 0 - int 10 * + to int ( str-addr str-len ) + adv-str dup mal-digit? 0= ( str-addr str-len digit-char ) + until + neg if 0 int - to int endif + int MalInt. ; + +: read-symbol-str ( str-addr str-len sym-char -- str-addr str-len char sym-addr sym-len ) + new-str { sym-addr sym-len } + begin ( str-addr str-len sym-char ) + sym-addr sym-len rot str-append-char to sym-len to sym-addr + adv-str dup sym-char? 0= + until + sym-addr sym-len ; + +: read-string-literal ( in-addr in-len quote-char -- in-addr in-len mal-string ) + new-str { out-addr out-len } + drop \ drop leading quote + begin ( in-addr in-len ) + adv-str over 0= if + 2drop 0 0 s\" expected '\"', got EOF" ...throw-str + endif + dup [char] " <> + while + dup [char] \ = if + drop adv-str + dup [char] n = if drop 10 endif + dup [char] r = if drop 13 endif + endif + out-addr out-len rot str-append-char to out-len to out-addr + repeat + drop adv-str \ skip trailing quote + out-addr out-len MalString. ; + +: read-list ( str-addr str-len open-paren-char close-paren-char + -- str-addr str-len non-paren-char mal-list ) + here { close-char old-here } + drop adv-str + begin ( str-addr str-len char ) + skip-spaces ( str-addr str-len non-space-char ) + over 0= if + drop 2drop 0 0 s" ', got EOF" + close-char pad ! pad 1 + s" expected '" ...throw-str + endif + dup close-char <> + while ( str-addr str-len non-space-non-paren-char ) + read-form , + repeat + drop adv-str + old-here here>MalList ; + +s" deref" MalSymbol. constant deref-sym +s" quote" MalSymbol. constant quote-sym +s" quasiquote" MalSymbol. constant quasiquote-sym +s" splice-unquote" MalSymbol. constant splice-unquote-sym +s" unquote" MalSymbol. constant unquote-sym + +: read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list ) + here { old-here } + , ( buf-addr buf-len char ) + read-form , ( buf-addr buf-len char ) + old-here here>MalList ; + +: read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj ) + skip-spaces + dup [char] - = 3 pick 1 + c@ mal-digit? and if read-int else + dup mal-digit? if read-int else + dup [char] ( = if [char] ) read-list else + dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else + dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else + dup [char] " = if read-string-literal else + dup [char] : = if drop adv-str read-symbol-str MalKeyword. else + dup [char] @ = if drop adv-str deref-sym read-wrapped else + dup [char] ' = if drop adv-str quote-sym read-wrapped else + dup [char] ` = if drop adv-str quasiquote-sym read-wrapped else + dup [char] ~ = if + drop adv-str + dup [char] @ = if drop adv-str splice-unquote-sym read-wrapped + else unquote-sym read-wrapped + endif + else + dup [char] ^ = if + drop adv-str + read-form { meta } read-form { obj } + meta mal-nil conj + obj swap conj + s" with-meta" MalSymbol. swap conj + else + read-symbol-str + 2dup s" true" str= if 2drop mal-true + else 2dup s" false" str= if 2drop mal-false + else 2dup s" nil" str= if 2drop mal-nil + else + MalSymbol. + endif endif endif endif endif endif endif endif endif endif endif endif endif endif endif ; +' read-form2 is read-form + +: read-str ( str-addr str-len - mal-obj ) + over c@ read-form { obj } drop 2drop obj ; diff --git a/impls/forth/run b/impls/forth/run index c7479ea8a9..ff388052f3 100755 --- a/impls/forth/run +++ b/impls/forth/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec gforth $(dirname $0)/${STEP:-stepA_mal}.fs "${@}" +#!/bin/bash +exec gforth $(dirname $0)/${STEP:-stepA_mal}.fs "${@}" diff --git a/impls/forth/step0_repl.fs b/impls/forth/step0_repl.fs index f69a97d849..994f47e3c1 100644 --- a/impls/forth/step0_repl.fs +++ b/impls/forth/step0_repl.fs @@ -1,25 +1,25 @@ -require types.fs - -: read ; -: eval ; -: print ; - -: rep - read - eval - print ; - -create buff 128 allot - -: read-lines - begin - ." user> " - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap - rep type cr - endif - repeat ; - -read-lines +require types.fs + +: read ; +: eval ; +: print ; + +: rep + read + eval + print ; + +create buff 128 allot + +: read-lines + begin + ." user> " + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap + rep type cr + endif + repeat ; + +read-lines diff --git a/impls/forth/step1_read_print.fs b/impls/forth/step1_read_print.fs index 5d0ee31353..9be806de5c 100644 --- a/impls/forth/step1_read_print.fs +++ b/impls/forth/step1_read_print.fs @@ -1,45 +1,45 @@ -require reader.fs -require printer.fs - -: read read-str ; -: eval ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -: rep ( str-addr str-len -- str-addr str-len ) - read - eval - print ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -: read-lines - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -read-lines -cr -bye +require reader.fs +require printer.fs + +: read read-str ; +: eval ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +: rep ( str-addr str-len -- str-addr str-len ) + read + eval + print ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +: read-lines + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +read-lines +cr +bye diff --git a/impls/forth/step2_eval.fs b/impls/forth/step2_eval.fs index ba8f30b52d..ab9a73b850 100644 --- a/impls/forth/step2_eval.fs +++ b/impls/forth/step2_eval.fs @@ -1,132 +1,132 @@ -require reader.fs -require printer.fs - -: args-as-native { argv argc -- entry*argc... } - argc 0 ?do - argv i cells + @ as-native - loop ; - -: env-assoc ( map sym-str-addr sym-str-len xt ) - -rot MalSymbol. swap MalNativeFn. rot assoc ; - -MalMap/Empty - s" +" :noname args-as-native + MalInt. ; env-assoc - s" -" :noname args-as-native - MalInt. ; env-assoc - s" *" :noname args-as-native * MalInt. ; env-assoc - s" /" :noname args-as-native / MalInt. ; env-assoc -constant repl-env - -: read read-str ; -: eval ( env obj ) mal-eval ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself - -MalKeyword - extend eval-invoke { env list kw -- val } - 0 kw env list MalList/start @ cell+ @ eval get - ?dup 0= if - \ compute not-found value - list MalList/count @ 1 > if - env list MalList/start @ 2 cells + @ eval - else - mal-nil - endif - endif ;; -drop - -\ eval all but the first item of list -: eval-rest { env list -- argv argc } - list MalList/start @ cell+ { expr-start } - list MalList/count @ 1- { argc } - argc cells allocate throw { target } - argc 0 ?do - env expr-start i cells + @ eval - target i cells + ! - loop - target argc ; - -MalNativeFn - extend eval-invoke ( env list this -- list ) - MalNativeFn/xt @ { xt } - eval-rest ( argv argc ) - xt execute ( return-val ) ;; -drop - -MalSymbol - extend mal-eval { env sym -- val } - 0 sym env get - dup 0= if - drop - 0 0 s" ' not found" sym pr-str s" '" ...throw-str - endif ;; -drop - -: eval-ast { env list -- list } - here - list MalList/start @ { expr-start } - list MalList/count @ 0 ?do - env expr-start i cells + @ eval , - loop - here>MalList ; - -MalList - extend mal-eval { env list -- val } - list MalList/count @ 0= if - list - else - env list MalList/start @ @ eval - env list rot eval-invoke - endif ;; -drop - -MalVector - extend mal-eval ( env vector -- vector ) - MalVector/list @ eval-ast - MalVector new swap over MalVector/list ! ;; -drop - -MalMap - extend mal-eval ( env map -- map ) - MalMap/list @ eval-ast - MalMap new swap over MalMap/list ! ;; -drop - -: rep ( str-addr str-len -- str-addr str-len ) - read - repl-env swap eval - print ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -: read-lines - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -read-lines -cr -bye +require reader.fs +require printer.fs + +: args-as-native { argv argc -- entry*argc... } + argc 0 ?do + argv i cells + @ as-native + loop ; + +: env-assoc ( map sym-str-addr sym-str-len xt ) + -rot MalSymbol. swap MalNativeFn. rot assoc ; + +MalMap/Empty + s" +" :noname args-as-native + MalInt. ; env-assoc + s" -" :noname args-as-native - MalInt. ; env-assoc + s" *" :noname args-as-native * MalInt. ; env-assoc + s" /" :noname args-as-native / MalInt. ; env-assoc +constant repl-env + +: read read-str ; +: eval ( env obj ) mal-eval ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself + +MalKeyword + extend eval-invoke { env list kw -- val } + 0 kw env list MalList/start @ cell+ @ eval get + ?dup 0= if + \ compute not-found value + list MalList/count @ 1 > if + env list MalList/start @ 2 cells + @ eval + else + mal-nil + endif + endif ;; +drop + +\ eval all but the first item of list +: eval-rest { env list -- argv argc } + list MalList/start @ cell+ { expr-start } + list MalList/count @ 1- { argc } + argc cells allocate throw { target } + argc 0 ?do + env expr-start i cells + @ eval + target i cells + ! + loop + target argc ; + +MalNativeFn + extend eval-invoke ( env list this -- list ) + MalNativeFn/xt @ { xt } + eval-rest ( argv argc ) + xt execute ( return-val ) ;; +drop + +MalSymbol + extend mal-eval { env sym -- val } + 0 sym env get + dup 0= if + drop + 0 0 s" ' not found" sym pr-str s" '" ...throw-str + endif ;; +drop + +: eval-ast { env list -- list } + here + list MalList/start @ { expr-start } + list MalList/count @ 0 ?do + env expr-start i cells + @ eval , + loop + here>MalList ; + +MalList + extend mal-eval { env list -- val } + list MalList/count @ 0= if + list + else + env list MalList/start @ @ eval + env list rot eval-invoke + endif ;; +drop + +MalVector + extend mal-eval ( env vector -- vector ) + MalVector/list @ eval-ast + MalVector new swap over MalVector/list ! ;; +drop + +MalMap + extend mal-eval ( env map -- map ) + MalMap/list @ eval-ast + MalMap new swap over MalMap/list ! ;; +drop + +: rep ( str-addr str-len -- str-addr str-len ) + read + repl-env swap eval + print ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +: read-lines + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +read-lines +cr +bye diff --git a/impls/forth/step3_env.fs b/impls/forth/step3_env.fs index 939afce4da..e9a77f8f93 100644 --- a/impls/forth/step3_env.fs +++ b/impls/forth/step3_env.fs @@ -1,168 +1,168 @@ -require reader.fs -require printer.fs -require env.fs - -: args-as-native { argv argc -- entry*argc... } - argc 0 ?do - argv i cells + @ as-native - loop ; - -0 MalEnv. constant repl-env -s" +" MalSymbol. :noname args-as-native + MalInt. ; MalNativeFn. repl-env env/set -s" -" MalSymbol. :noname args-as-native - MalInt. ; MalNativeFn. repl-env env/set -s" *" MalSymbol. :noname args-as-native * MalInt. ; MalNativeFn. repl-env env/set -s" /" MalSymbol. :noname args-as-native / MalInt. ; MalNativeFn. repl-env env/set - -: read read-str ; -: eval ( env obj ) mal-eval ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself - -MalKeyword - extend eval-invoke { env list kw -- val } - 0 kw env list MalList/start @ cell+ @ eval get - ?dup 0= if - \ compute not-found value - list MalList/count @ 1 > if - env list MalList/start @ 2 cells + @ eval - else - mal-nil - endif - endif ;; -drop - -\ eval all but the first item of list -: eval-rest { env list -- argv argc } - list MalList/start @ cell+ { expr-start } - list MalList/count @ 1- { argc } - argc cells allocate throw { target } - argc 0 ?do - env expr-start i cells + @ eval - target i cells + ! - loop - target argc ; - -MalNativeFn - extend eval-invoke ( env list this -- list ) - MalNativeFn/xt @ { xt } - eval-rest ( argv argc ) - xt execute ( return-val ) ;; -drop - -SpecialOp - extend eval-invoke ( env list this -- list ) - SpecialOp/xt @ execute ;; -drop - -: install-special ( symbol xt ) - SpecialOp. repl-env env/set ; - -: defspecial - parse-allot-name MalSymbol. - ['] install-special - :noname - ; - -defspecial quote ( env list -- form ) - nip MalList/start @ cell+ @ ;; - -defspecial def! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval dup { val } ( key val ) - env env/set val ;; - -defspecial let* { old-env list -- val } - old-env MalEnv. { env } - list MalList/start @ cell+ dup { arg0 } - @ to-list - dup MalList/start @ { bindings-start } ( list ) - MalList/count @ 0 +do - bindings-start i cells + dup @ swap cell+ @ ( sym expr ) - env swap eval - env env/set - 2 +loop - env arg0 cell+ @ eval - \ TODO: dec refcount of env - ;; - -MalSymbol - extend mal-eval { env sym -- val } - sym env env/get-addr - dup 0= if - drop - 0 0 s" ' not found" sym pr-str s" '" ...throw-str - else - @ - endif ;; -drop - -: eval-ast { env list -- list } - here - list MalList/start @ { expr-start } - list MalList/count @ 0 ?do - env expr-start i cells + @ eval , - loop - here>MalList ; - -MalList - extend mal-eval { env list -- val } - list MalList/count @ 0= if - list - else - env list MalList/start @ @ eval - env list rot eval-invoke - endif ;; -drop - -MalVector - extend mal-eval ( env vector -- vector ) - MalVector/list @ eval-ast - MalVector new swap over MalVector/list ! ;; -drop - -MalMap - extend mal-eval ( env map -- map ) - MalMap/list @ eval-ast - MalMap new swap over MalMap/list ! ;; -drop - -: rep ( str-addr str-len -- str-addr str-len ) - read - repl-env swap eval - print ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -: read-lines - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -read-lines -cr -bye +require reader.fs +require printer.fs +require env.fs + +: args-as-native { argv argc -- entry*argc... } + argc 0 ?do + argv i cells + @ as-native + loop ; + +0 MalEnv. constant repl-env +s" +" MalSymbol. :noname args-as-native + MalInt. ; MalNativeFn. repl-env env/set +s" -" MalSymbol. :noname args-as-native - MalInt. ; MalNativeFn. repl-env env/set +s" *" MalSymbol. :noname args-as-native * MalInt. ; MalNativeFn. repl-env env/set +s" /" MalSymbol. :noname args-as-native / MalInt. ; MalNativeFn. repl-env env/set + +: read read-str ; +: eval ( env obj ) mal-eval ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself + +MalKeyword + extend eval-invoke { env list kw -- val } + 0 kw env list MalList/start @ cell+ @ eval get + ?dup 0= if + \ compute not-found value + list MalList/count @ 1 > if + env list MalList/start @ 2 cells + @ eval + else + mal-nil + endif + endif ;; +drop + +\ eval all but the first item of list +: eval-rest { env list -- argv argc } + list MalList/start @ cell+ { expr-start } + list MalList/count @ 1- { argc } + argc cells allocate throw { target } + argc 0 ?do + env expr-start i cells + @ eval + target i cells + ! + loop + target argc ; + +MalNativeFn + extend eval-invoke ( env list this -- list ) + MalNativeFn/xt @ { xt } + eval-rest ( argv argc ) + xt execute ( return-val ) ;; +drop + +SpecialOp + extend eval-invoke ( env list this -- list ) + SpecialOp/xt @ execute ;; +drop + +: install-special ( symbol xt ) + SpecialOp. repl-env env/set ; + +: defspecial + parse-allot-name MalSymbol. + ['] install-special + :noname + ; + +defspecial quote ( env list -- form ) + nip MalList/start @ cell+ @ ;; + +defspecial def! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval dup { val } ( key val ) + env env/set val ;; + +defspecial let* { old-env list -- val } + old-env MalEnv. { env } + list MalList/start @ cell+ dup { arg0 } + @ to-list + dup MalList/start @ { bindings-start } ( list ) + MalList/count @ 0 +do + bindings-start i cells + dup @ swap cell+ @ ( sym expr ) + env swap eval + env env/set + 2 +loop + env arg0 cell+ @ eval + \ TODO: dec refcount of env + ;; + +MalSymbol + extend mal-eval { env sym -- val } + sym env env/get-addr + dup 0= if + drop + 0 0 s" ' not found" sym pr-str s" '" ...throw-str + else + @ + endif ;; +drop + +: eval-ast { env list -- list } + here + list MalList/start @ { expr-start } + list MalList/count @ 0 ?do + env expr-start i cells + @ eval , + loop + here>MalList ; + +MalList + extend mal-eval { env list -- val } + list MalList/count @ 0= if + list + else + env list MalList/start @ @ eval + env list rot eval-invoke + endif ;; +drop + +MalVector + extend mal-eval ( env vector -- vector ) + MalVector/list @ eval-ast + MalVector new swap over MalVector/list ! ;; +drop + +MalMap + extend mal-eval ( env map -- map ) + MalMap/list @ eval-ast + MalMap new swap over MalMap/list ! ;; +drop + +: rep ( str-addr str-len -- str-addr str-len ) + read + repl-env swap eval + print ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +: read-lines + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +read-lines +cr +bye diff --git a/impls/forth/step4_if_fn_do.fs b/impls/forth/step4_if_fn_do.fs index 72b8ac1615..db9d1a5722 100644 --- a/impls/forth/step4_if_fn_do.fs +++ b/impls/forth/step4_if_fn_do.fs @@ -1,230 +1,230 @@ -require reader.fs -require printer.fs -require core.fs - -core MalEnv. constant repl-env - -: read read-str ; -: eval ( env obj ) mal-eval ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself - -MalKeyword - extend eval-invoke { env list kw -- val } - 0 kw env list MalList/start @ cell+ @ eval get - ?dup 0= if - \ compute not-found value - list MalList/count @ 1 > if - env list MalList/start @ 2 cells + @ eval - else - mal-nil - endif - endif ;; -drop - -\ eval all but the first item of list -: eval-rest { env list -- argv argc } - list MalList/start @ cell+ { expr-start } - list MalList/count @ 1- { argc } - argc cells allocate throw { target } - argc 0 ?do - env expr-start i cells + @ eval - target i cells + ! - loop - target argc ; - -MalNativeFn - extend eval-invoke ( env list this -- list ) - MalNativeFn/xt @ { xt } - eval-rest ( argv argc ) - xt execute ( return-val ) ;; -drop - -SpecialOp - extend eval-invoke ( env list this -- list ) - SpecialOp/xt @ execute ;; -drop - -: install-special ( symbol xt ) - SpecialOp. repl-env env/set ; - -: defspecial - parse-allot-name MalSymbol. - ['] install-special - :noname - ; - -defspecial quote ( env list -- form ) - nip MalList/start @ cell+ @ ;; - -defspecial def! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval dup { val } ( key val ) - env env/set val ;; - -defspecial let* { old-env list -- val } - old-env MalEnv. { env } - list MalList/start @ cell+ dup { arg0 } - @ to-list - dup MalList/start @ { bindings-start } ( list ) - MalList/count @ 0 +do - bindings-start i cells + dup @ swap cell+ @ ( sym expr ) - env swap eval - env env/set - 2 +loop - env arg0 cell+ @ eval - \ TODO: dec refcount of env - ;; - -defspecial do { env list -- val } - list MalList/start @ - 0 - list MalList/count @ 1 ?do - drop - dup i cells + @ env swap eval - loop - nip ;; - -defspecial if { env list -- val } - list MalList/start @ cell+ { arg0 } - env arg0 @ eval ( test-val ) - dup mal-false = if - drop -1 - else - mal-nil = - endif - if - \ branch to false - list MalList/count @ 3 > if - env arg0 cell+ cell+ @ eval - else - mal-nil - endif - else - \ branch to true - env arg0 cell+ @ eval - endif ;; - -s" &" MalSymbol. constant &-sym - -MalUserFn - extend eval-invoke { call-env list mal-fn -- list } - call-env list eval-rest { argv argc } - - mal-fn MalUserFn/formal-args @ { f-args-list } - mal-fn MalUserFn/env @ MalEnv. { env } - - f-args-list MalList/start @ { f-args } - f-args-list MalList/count @ ?dup 0= if else - \ pass empty list for last arg, unless overridden below - 1- cells f-args + @ MalList new env env/set - endif - argc 0 ?do - f-args i cells + @ - dup &-sym m= if - drop - f-args i 1+ cells + @ ( more-args-symbol ) - MalList new ( sym more-args ) - argc i - dup { c } over MalList/count ! - c cells allocate throw dup { start } over MalList/start ! - argv i cells + start c cells cmove - env env/set - leave - endif - argv i cells + @ - env env/set - loop - - env mal-fn MalUserFn/body @ eval ;; -drop - -defspecial fn* { env list -- val } - list MalList/start @ cell+ { arg0 } - MalUserFn new - env over MalUserFn/env ! - arg0 @ to-list over MalUserFn/formal-args ! - arg0 cell+ @ over MalUserFn/body ! ;; - -MalSymbol - extend mal-eval { env sym -- val } - sym env env/get-addr - dup 0= if - drop - 0 0 s" ' not found" sym pr-str s" '" ...throw-str - else - @ - endif ;; -drop - -: eval-ast { env list -- list } - here - list MalList/start @ { expr-start } - list MalList/count @ 0 ?do - env expr-start i cells + @ eval , - loop - here>MalList ; - -MalList - extend mal-eval { env list -- val } - list MalList/count @ 0= if - list - else - env list MalList/start @ @ eval - env list rot eval-invoke - endif ;; -drop - -MalVector - extend mal-eval ( env vector -- vector ) - MalVector/list @ eval-ast - MalVector new swap over MalVector/list ! ;; -drop - -MalMap - extend mal-eval ( env map -- map ) - MalMap/list @ eval-ast - MalMap new swap over MalMap/list ! ;; -drop - -: rep ( str-addr str-len -- str-addr str-len ) - read - repl-env swap eval - print ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -s\" (def! not (fn* (x) (if x false true)))" rep 2drop - -: read-lines - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -read-lines -cr -bye +require reader.fs +require printer.fs +require core.fs + +core MalEnv. constant repl-env + +: read read-str ; +: eval ( env obj ) mal-eval ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself + +MalKeyword + extend eval-invoke { env list kw -- val } + 0 kw env list MalList/start @ cell+ @ eval get + ?dup 0= if + \ compute not-found value + list MalList/count @ 1 > if + env list MalList/start @ 2 cells + @ eval + else + mal-nil + endif + endif ;; +drop + +\ eval all but the first item of list +: eval-rest { env list -- argv argc } + list MalList/start @ cell+ { expr-start } + list MalList/count @ 1- { argc } + argc cells allocate throw { target } + argc 0 ?do + env expr-start i cells + @ eval + target i cells + ! + loop + target argc ; + +MalNativeFn + extend eval-invoke ( env list this -- list ) + MalNativeFn/xt @ { xt } + eval-rest ( argv argc ) + xt execute ( return-val ) ;; +drop + +SpecialOp + extend eval-invoke ( env list this -- list ) + SpecialOp/xt @ execute ;; +drop + +: install-special ( symbol xt ) + SpecialOp. repl-env env/set ; + +: defspecial + parse-allot-name MalSymbol. + ['] install-special + :noname + ; + +defspecial quote ( env list -- form ) + nip MalList/start @ cell+ @ ;; + +defspecial def! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval dup { val } ( key val ) + env env/set val ;; + +defspecial let* { old-env list -- val } + old-env MalEnv. { env } + list MalList/start @ cell+ dup { arg0 } + @ to-list + dup MalList/start @ { bindings-start } ( list ) + MalList/count @ 0 +do + bindings-start i cells + dup @ swap cell+ @ ( sym expr ) + env swap eval + env env/set + 2 +loop + env arg0 cell+ @ eval + \ TODO: dec refcount of env + ;; + +defspecial do { env list -- val } + list MalList/start @ + 0 + list MalList/count @ 1 ?do + drop + dup i cells + @ env swap eval + loop + nip ;; + +defspecial if { env list -- val } + list MalList/start @ cell+ { arg0 } + env arg0 @ eval ( test-val ) + dup mal-false = if + drop -1 + else + mal-nil = + endif + if + \ branch to false + list MalList/count @ 3 > if + env arg0 cell+ cell+ @ eval + else + mal-nil + endif + else + \ branch to true + env arg0 cell+ @ eval + endif ;; + +s" &" MalSymbol. constant &-sym + +MalUserFn + extend eval-invoke { call-env list mal-fn -- list } + call-env list eval-rest { argv argc } + + mal-fn MalUserFn/formal-args @ { f-args-list } + mal-fn MalUserFn/env @ MalEnv. { env } + + f-args-list MalList/start @ { f-args } + f-args-list MalList/count @ ?dup 0= if else + \ pass empty list for last arg, unless overridden below + 1- cells f-args + @ MalList new env env/set + endif + argc 0 ?do + f-args i cells + @ + dup &-sym m= if + drop + f-args i 1+ cells + @ ( more-args-symbol ) + MalList new ( sym more-args ) + argc i - dup { c } over MalList/count ! + c cells allocate throw dup { start } over MalList/start ! + argv i cells + start c cells cmove + env env/set + leave + endif + argv i cells + @ + env env/set + loop + + env mal-fn MalUserFn/body @ eval ;; +drop + +defspecial fn* { env list -- val } + list MalList/start @ cell+ { arg0 } + MalUserFn new + env over MalUserFn/env ! + arg0 @ to-list over MalUserFn/formal-args ! + arg0 cell+ @ over MalUserFn/body ! ;; + +MalSymbol + extend mal-eval { env sym -- val } + sym env env/get-addr + dup 0= if + drop + 0 0 s" ' not found" sym pr-str s" '" ...throw-str + else + @ + endif ;; +drop + +: eval-ast { env list -- list } + here + list MalList/start @ { expr-start } + list MalList/count @ 0 ?do + env expr-start i cells + @ eval , + loop + here>MalList ; + +MalList + extend mal-eval { env list -- val } + list MalList/count @ 0= if + list + else + env list MalList/start @ @ eval + env list rot eval-invoke + endif ;; +drop + +MalVector + extend mal-eval ( env vector -- vector ) + MalVector/list @ eval-ast + MalVector new swap over MalVector/list ! ;; +drop + +MalMap + extend mal-eval ( env map -- map ) + MalMap/list @ eval-ast + MalMap new swap over MalMap/list ! ;; +drop + +: rep ( str-addr str-len -- str-addr str-len ) + read + repl-env swap eval + print ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +s\" (def! not (fn* (x) (if x false true)))" rep 2drop + +: read-lines + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +read-lines +cr +bye diff --git a/impls/forth/step5_tco.fs b/impls/forth/step5_tco.fs index 835f717411..eda92c7e2f 100644 --- a/impls/forth/step5_tco.fs +++ b/impls/forth/step5_tco.fs @@ -1,241 +1,241 @@ -require reader.fs -require printer.fs -require core.fs - -core MalEnv. constant repl-env - -99999999 constant TCO-eval - -: read read-str ; -: eval ( env obj ) - begin - \ ." eval-> " dup pr-str safe-type cr - mal-eval - dup TCO-eval = - while - drop - repeat ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself - -MalKeyword - extend eval-invoke { env list kw -- val } - 0 kw env list MalList/start @ cell+ @ eval get - ?dup 0= if - \ compute not-found value - list MalList/count @ 1 > if - env list MalList/start @ 2 cells + @ TCO-eval - else - mal-nil - endif - endif ;; -drop - -\ eval all but the first item of list -: eval-rest { env list -- argv argc } - list MalList/start @ cell+ { expr-start } - list MalList/count @ 1- { argc } - argc cells allocate throw { target } - argc 0 ?do - env expr-start i cells + @ eval - target i cells + ! - loop - target argc ; - -MalNativeFn - extend eval-invoke ( env list this -- list ) - MalNativeFn/xt @ { xt } - eval-rest ( argv argc ) - xt execute ( return-val ) ;; -drop - -SpecialOp - extend eval-invoke ( env list this -- list ) - SpecialOp/xt @ execute ;; -drop - -: install-special ( symbol xt ) - SpecialOp. repl-env env/set ; - -: defspecial - parse-allot-name MalSymbol. - ['] install-special - :noname - ; - -defspecial quote ( env list -- form ) - nip MalList/start @ cell+ @ ;; - -defspecial def! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval dup { val } ( key val ) - env env/set val ;; - -defspecial let* { old-env list -- val } - old-env MalEnv. { env } - list MalList/start @ cell+ dup { arg0 } - @ to-list - dup MalList/start @ { bindings-start } ( list ) - MalList/count @ 0 +do - bindings-start i cells + dup @ swap cell+ @ ( sym expr ) - env swap eval - env env/set - 2 +loop - env arg0 cell+ @ TCO-eval - \ TODO: dec refcount of env - ;; - -defspecial do { env list -- val } - list MalList/start @ { start } - list MalList/count @ dup 1- { last } 1 ?do - env start i cells + @ - i last = if - TCO-eval - else - eval drop - endif - loop ;; - -defspecial if { env list -- val } - list MalList/start @ cell+ { arg0 } - env arg0 @ eval ( test-val ) - dup mal-false = if - drop -1 - else - mal-nil = - endif - if - \ branch to false - list MalList/count @ 3 > if - env arg0 cell+ cell+ @ TCO-eval - else - mal-nil - endif - else - \ branch to true - env arg0 cell+ @ TCO-eval - endif ;; - -s" &" MalSymbol. constant &-sym - -MalUserFn - extend eval-invoke { call-env list mal-fn -- list } - call-env list eval-rest { argv argc } - - mal-fn MalUserFn/formal-args @ { f-args-list } - mal-fn MalUserFn/env @ MalEnv. { env } - - f-args-list MalList/start @ { f-args } - f-args-list MalList/count @ ?dup 0= if else - \ pass empty list for last arg, unless overridden below - 1- cells f-args + @ MalList new env env/set - endif - argc 0 ?do - f-args i cells + @ - dup &-sym m= if - drop - f-args i 1+ cells + @ ( more-args-symbol ) - MalList new ( sym more-args ) - argc i - dup { c } over MalList/count ! - c cells allocate throw dup { start } over MalList/start ! - argv i cells + start c cells cmove - env env/set - leave - endif - argv i cells + @ - env env/set - loop - - env mal-fn MalUserFn/body @ TCO-eval ;; -drop - -defspecial fn* { env list -- val } - list MalList/start @ cell+ { arg0 } - MalUserFn new - env over MalUserFn/env ! - arg0 @ to-list over MalUserFn/formal-args ! - arg0 cell+ @ over MalUserFn/body ! ;; - -MalSymbol - extend mal-eval { env sym -- val } - sym env env/get-addr - dup 0= if - drop - 0 0 s" ' not found" sym pr-str s" '" ...throw-str - else - @ - endif ;; -drop - -: eval-ast { env list -- list } - here - list MalList/start @ { expr-start } - list MalList/count @ 0 ?do - env expr-start i cells + @ eval , - loop - here>MalList ; - -MalList - extend mal-eval { env list -- val } - list MalList/count @ 0= if - list - else - env list MalList/start @ @ eval - env list rot eval-invoke - endif ;; -drop - -MalVector - extend mal-eval ( env vector -- vector ) - MalVector/list @ eval-ast - MalVector new swap over MalVector/list ! ;; -drop - -MalMap - extend mal-eval ( env map -- map ) - MalMap/list @ eval-ast - MalMap new swap over MalMap/list ! ;; -drop - -: rep ( str-addr str-len -- str-addr str-len ) - read - repl-env swap eval - print ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -s\" (def! not (fn* (x) (if x false true)))" rep 2drop - -: read-lines - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -read-lines -cr -bye +require reader.fs +require printer.fs +require core.fs + +core MalEnv. constant repl-env + +99999999 constant TCO-eval + +: read read-str ; +: eval ( env obj ) + begin + \ ." eval-> " dup pr-str safe-type cr + mal-eval + dup TCO-eval = + while + drop + repeat ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself + +MalKeyword + extend eval-invoke { env list kw -- val } + 0 kw env list MalList/start @ cell+ @ eval get + ?dup 0= if + \ compute not-found value + list MalList/count @ 1 > if + env list MalList/start @ 2 cells + @ TCO-eval + else + mal-nil + endif + endif ;; +drop + +\ eval all but the first item of list +: eval-rest { env list -- argv argc } + list MalList/start @ cell+ { expr-start } + list MalList/count @ 1- { argc } + argc cells allocate throw { target } + argc 0 ?do + env expr-start i cells + @ eval + target i cells + ! + loop + target argc ; + +MalNativeFn + extend eval-invoke ( env list this -- list ) + MalNativeFn/xt @ { xt } + eval-rest ( argv argc ) + xt execute ( return-val ) ;; +drop + +SpecialOp + extend eval-invoke ( env list this -- list ) + SpecialOp/xt @ execute ;; +drop + +: install-special ( symbol xt ) + SpecialOp. repl-env env/set ; + +: defspecial + parse-allot-name MalSymbol. + ['] install-special + :noname + ; + +defspecial quote ( env list -- form ) + nip MalList/start @ cell+ @ ;; + +defspecial def! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval dup { val } ( key val ) + env env/set val ;; + +defspecial let* { old-env list -- val } + old-env MalEnv. { env } + list MalList/start @ cell+ dup { arg0 } + @ to-list + dup MalList/start @ { bindings-start } ( list ) + MalList/count @ 0 +do + bindings-start i cells + dup @ swap cell+ @ ( sym expr ) + env swap eval + env env/set + 2 +loop + env arg0 cell+ @ TCO-eval + \ TODO: dec refcount of env + ;; + +defspecial do { env list -- val } + list MalList/start @ { start } + list MalList/count @ dup 1- { last } 1 ?do + env start i cells + @ + i last = if + TCO-eval + else + eval drop + endif + loop ;; + +defspecial if { env list -- val } + list MalList/start @ cell+ { arg0 } + env arg0 @ eval ( test-val ) + dup mal-false = if + drop -1 + else + mal-nil = + endif + if + \ branch to false + list MalList/count @ 3 > if + env arg0 cell+ cell+ @ TCO-eval + else + mal-nil + endif + else + \ branch to true + env arg0 cell+ @ TCO-eval + endif ;; + +s" &" MalSymbol. constant &-sym + +MalUserFn + extend eval-invoke { call-env list mal-fn -- list } + call-env list eval-rest { argv argc } + + mal-fn MalUserFn/formal-args @ { f-args-list } + mal-fn MalUserFn/env @ MalEnv. { env } + + f-args-list MalList/start @ { f-args } + f-args-list MalList/count @ ?dup 0= if else + \ pass empty list for last arg, unless overridden below + 1- cells f-args + @ MalList new env env/set + endif + argc 0 ?do + f-args i cells + @ + dup &-sym m= if + drop + f-args i 1+ cells + @ ( more-args-symbol ) + MalList new ( sym more-args ) + argc i - dup { c } over MalList/count ! + c cells allocate throw dup { start } over MalList/start ! + argv i cells + start c cells cmove + env env/set + leave + endif + argv i cells + @ + env env/set + loop + + env mal-fn MalUserFn/body @ TCO-eval ;; +drop + +defspecial fn* { env list -- val } + list MalList/start @ cell+ { arg0 } + MalUserFn new + env over MalUserFn/env ! + arg0 @ to-list over MalUserFn/formal-args ! + arg0 cell+ @ over MalUserFn/body ! ;; + +MalSymbol + extend mal-eval { env sym -- val } + sym env env/get-addr + dup 0= if + drop + 0 0 s" ' not found" sym pr-str s" '" ...throw-str + else + @ + endif ;; +drop + +: eval-ast { env list -- list } + here + list MalList/start @ { expr-start } + list MalList/count @ 0 ?do + env expr-start i cells + @ eval , + loop + here>MalList ; + +MalList + extend mal-eval { env list -- val } + list MalList/count @ 0= if + list + else + env list MalList/start @ @ eval + env list rot eval-invoke + endif ;; +drop + +MalVector + extend mal-eval ( env vector -- vector ) + MalVector/list @ eval-ast + MalVector new swap over MalVector/list ! ;; +drop + +MalMap + extend mal-eval ( env map -- map ) + MalMap/list @ eval-ast + MalMap new swap over MalMap/list ! ;; +drop + +: rep ( str-addr str-len -- str-addr str-len ) + read + repl-env swap eval + print ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +s\" (def! not (fn* (x) (if x false true)))" rep 2drop + +: read-lines + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +read-lines +cr +bye diff --git a/impls/forth/step6_file.fs b/impls/forth/step6_file.fs index 5f7e0dad9c..ce780dbbeb 100644 --- a/impls/forth/step6_file.fs +++ b/impls/forth/step6_file.fs @@ -1,287 +1,287 @@ -require reader.fs -require printer.fs -require core.fs - -core MalEnv. constant repl-env - -99999999 constant TCO-eval - -: read read-str ; -: eval ( env obj ) - begin - \ ." eval-> " dup pr-str safe-type cr - mal-eval - dup TCO-eval = - while - drop - repeat ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself - -MalKeyword - extend eval-invoke { env list kw -- val } - 0 kw env list MalList/start @ cell+ @ eval get - ?dup 0= if - \ compute not-found value - list MalList/count @ 1 > if - env list MalList/start @ 2 cells + @ TCO-eval - else - mal-nil - endif - endif ;; -drop - -\ eval all but the first item of list -: eval-rest { env list -- argv argc } - list MalList/start @ cell+ { expr-start } - list MalList/count @ 1- { argc } - argc cells allocate throw { target } - argc 0 ?do - env expr-start i cells + @ eval - target i cells + ! - loop - target argc ; - -MalNativeFn - extend eval-invoke { env list this -- list } - env list eval-rest ( argv argc ) - this invoke ;; - extend invoke ( argv argc this -- val ) - MalNativeFn/xt @ execute ;; -drop - -SpecialOp - extend eval-invoke ( env list this -- list ) - SpecialOp/xt @ execute ;; -drop - -: install-special ( symbol xt ) - SpecialOp. repl-env env/set ; - -: defspecial - parse-allot-name MalSymbol. - ['] install-special - :noname - ; - -defspecial quote ( env list -- form ) - nip MalList/start @ cell+ @ ;; - -defspecial def! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval dup { val } ( key val ) - env env/set val ;; - -defspecial let* { old-env list -- val } - old-env MalEnv. { env } - list MalList/start @ cell+ dup { arg0 } - @ to-list - dup MalList/start @ { bindings-start } ( list ) - MalList/count @ 0 +do - bindings-start i cells + dup @ swap cell+ @ ( sym expr ) - env swap eval - env env/set - 2 +loop - env arg0 cell+ @ TCO-eval - \ TODO: dec refcount of env - ;; - -defspecial do { env list -- val } - list MalList/start @ { start } - list MalList/count @ dup 1- { last } 1 ?do - env start i cells + @ - i last = if - TCO-eval - else - eval drop - endif - loop ;; - -defspecial if { env list -- val } - list MalList/start @ cell+ { arg0 } - env arg0 @ eval ( test-val ) - dup mal-false = if - drop -1 - else - mal-nil = - endif - if - \ branch to false - list MalList/count @ 3 > if - env arg0 cell+ cell+ @ TCO-eval - else - mal-nil - endif - else - \ branch to true - env arg0 cell+ @ TCO-eval - endif ;; - -s" &" MalSymbol. constant &-sym - -: new-user-fn-env { argv argc mal-fn -- env } - mal-fn MalUserFn/formal-args @ { f-args-list } - mal-fn MalUserFn/env @ MalEnv. { env } - - f-args-list MalList/start @ { f-args } - f-args-list MalList/count @ ?dup 0= if else - \ pass empty list for last arg, unless overridden below - 1- cells f-args + @ MalList new env env/set - endif - argc 0 ?do - f-args i cells + @ - dup &-sym m= if - drop - argc i - { c } - c cells allocate throw { start } - argv i cells + start c cells cmove - f-args i 1+ cells + @ ( more-args-symbol ) - start c MalList. env env/set - leave - endif - argv i cells + @ - env env/set - loop - env ; - -MalUserFn - extend eval-invoke { call-env list mal-fn -- list } - call-env list eval-rest - mal-fn invoke ;; - - extend invoke ( argv argc mal-fn ) - dup { mal-fn } new-user-fn-env { env } - env mal-fn MalUserFn/body @ TCO-eval ;; -drop - -defspecial fn* { env list -- val } - list MalList/start @ cell+ { arg0 } - MalUserFn new - env over MalUserFn/env ! - arg0 @ to-list over MalUserFn/formal-args ! - arg0 cell+ @ over MalUserFn/body ! ;; - -MalSymbol - extend mal-eval { env sym -- val } - sym env env/get-addr - dup 0= if - drop - 0 0 s" ' not found" sym pr-str s" '" ...throw-str - else - @ - endif ;; -drop - -: eval-ast { env list -- list } - here - list MalList/start @ { expr-start } - list MalList/count @ 0 ?do - env expr-start i cells + @ eval , - loop - here>MalList ; - -MalList - extend mal-eval { env list -- val } - list MalList/count @ 0= if - list - else - env list MalList/start @ @ eval - env list rot eval-invoke - endif ;; -drop - -MalVector - extend mal-eval ( env vector -- vector ) - MalVector/list @ eval-ast - MalVector new swap over MalVector/list ! ;; -drop - -MalMap - extend mal-eval ( env map -- map ) - MalMap/list @ eval-ast - MalMap new swap over MalMap/list ! ;; -drop - -defcore eval ( argv argc ) - drop @ repl-env swap eval ;; - -: rep ( str-addr str-len -- str-addr str-len ) - read - repl-env swap eval - print ; - -: mk-args-list ( -- ) - here - begin - next-arg 2dup 0 0 d<> while - MalString. , - repeat - 2drop here>MalList ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -: nop ; - -defcore swap! { argv argc -- val } - \ argv is (atom fn args...) - argv @ { atom } - argv cell+ @ { fn } - argc 1- { call-argc } - call-argc cells allocate throw { call-argv } - atom Atom/val call-argv 1 cells cmove - argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove - call-argv call-argc fn invoke - dup TCO-eval = if drop eval endif { new-val } - new-val atom Atom/val ! - new-val ;; - -s\" (def! not (fn* (x) (if x false true)))" rep 2drop -s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop - -: repl ( -- ) - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -: main ( -- ) - mk-args-list { args-list } - args-list MalList/count @ 0= if - s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set - repl - else - args-list MalList/start @ @ { filename } - s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set - - repl-env - here s" load-file" MalSymbol. , filename , here>MalList - eval print - endif ; - -main -cr -bye +require reader.fs +require printer.fs +require core.fs + +core MalEnv. constant repl-env + +99999999 constant TCO-eval + +: read read-str ; +: eval ( env obj ) + begin + \ ." eval-> " dup pr-str safe-type cr + mal-eval + dup TCO-eval = + while + drop + repeat ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself + +MalKeyword + extend eval-invoke { env list kw -- val } + 0 kw env list MalList/start @ cell+ @ eval get + ?dup 0= if + \ compute not-found value + list MalList/count @ 1 > if + env list MalList/start @ 2 cells + @ TCO-eval + else + mal-nil + endif + endif ;; +drop + +\ eval all but the first item of list +: eval-rest { env list -- argv argc } + list MalList/start @ cell+ { expr-start } + list MalList/count @ 1- { argc } + argc cells allocate throw { target } + argc 0 ?do + env expr-start i cells + @ eval + target i cells + ! + loop + target argc ; + +MalNativeFn + extend eval-invoke { env list this -- list } + env list eval-rest ( argv argc ) + this invoke ;; + extend invoke ( argv argc this -- val ) + MalNativeFn/xt @ execute ;; +drop + +SpecialOp + extend eval-invoke ( env list this -- list ) + SpecialOp/xt @ execute ;; +drop + +: install-special ( symbol xt ) + SpecialOp. repl-env env/set ; + +: defspecial + parse-allot-name MalSymbol. + ['] install-special + :noname + ; + +defspecial quote ( env list -- form ) + nip MalList/start @ cell+ @ ;; + +defspecial def! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval dup { val } ( key val ) + env env/set val ;; + +defspecial let* { old-env list -- val } + old-env MalEnv. { env } + list MalList/start @ cell+ dup { arg0 } + @ to-list + dup MalList/start @ { bindings-start } ( list ) + MalList/count @ 0 +do + bindings-start i cells + dup @ swap cell+ @ ( sym expr ) + env swap eval + env env/set + 2 +loop + env arg0 cell+ @ TCO-eval + \ TODO: dec refcount of env + ;; + +defspecial do { env list -- val } + list MalList/start @ { start } + list MalList/count @ dup 1- { last } 1 ?do + env start i cells + @ + i last = if + TCO-eval + else + eval drop + endif + loop ;; + +defspecial if { env list -- val } + list MalList/start @ cell+ { arg0 } + env arg0 @ eval ( test-val ) + dup mal-false = if + drop -1 + else + mal-nil = + endif + if + \ branch to false + list MalList/count @ 3 > if + env arg0 cell+ cell+ @ TCO-eval + else + mal-nil + endif + else + \ branch to true + env arg0 cell+ @ TCO-eval + endif ;; + +s" &" MalSymbol. constant &-sym + +: new-user-fn-env { argv argc mal-fn -- env } + mal-fn MalUserFn/formal-args @ { f-args-list } + mal-fn MalUserFn/env @ MalEnv. { env } + + f-args-list MalList/start @ { f-args } + f-args-list MalList/count @ ?dup 0= if else + \ pass empty list for last arg, unless overridden below + 1- cells f-args + @ MalList new env env/set + endif + argc 0 ?do + f-args i cells + @ + dup &-sym m= if + drop + argc i - { c } + c cells allocate throw { start } + argv i cells + start c cells cmove + f-args i 1+ cells + @ ( more-args-symbol ) + start c MalList. env env/set + leave + endif + argv i cells + @ + env env/set + loop + env ; + +MalUserFn + extend eval-invoke { call-env list mal-fn -- list } + call-env list eval-rest + mal-fn invoke ;; + + extend invoke ( argv argc mal-fn ) + dup { mal-fn } new-user-fn-env { env } + env mal-fn MalUserFn/body @ TCO-eval ;; +drop + +defspecial fn* { env list -- val } + list MalList/start @ cell+ { arg0 } + MalUserFn new + env over MalUserFn/env ! + arg0 @ to-list over MalUserFn/formal-args ! + arg0 cell+ @ over MalUserFn/body ! ;; + +MalSymbol + extend mal-eval { env sym -- val } + sym env env/get-addr + dup 0= if + drop + 0 0 s" ' not found" sym pr-str s" '" ...throw-str + else + @ + endif ;; +drop + +: eval-ast { env list -- list } + here + list MalList/start @ { expr-start } + list MalList/count @ 0 ?do + env expr-start i cells + @ eval , + loop + here>MalList ; + +MalList + extend mal-eval { env list -- val } + list MalList/count @ 0= if + list + else + env list MalList/start @ @ eval + env list rot eval-invoke + endif ;; +drop + +MalVector + extend mal-eval ( env vector -- vector ) + MalVector/list @ eval-ast + MalVector new swap over MalVector/list ! ;; +drop + +MalMap + extend mal-eval ( env map -- map ) + MalMap/list @ eval-ast + MalMap new swap over MalMap/list ! ;; +drop + +defcore eval ( argv argc ) + drop @ repl-env swap eval ;; + +: rep ( str-addr str-len -- str-addr str-len ) + read + repl-env swap eval + print ; + +: mk-args-list ( -- ) + here + begin + next-arg 2dup 0 0 d<> while + MalString. , + repeat + 2drop here>MalList ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +: nop ; + +defcore swap! { argv argc -- val } + \ argv is (atom fn args...) + argv @ { atom } + argv cell+ @ { fn } + argc 1- { call-argc } + call-argc cells allocate throw { call-argv } + atom Atom/val call-argv 1 cells cmove + argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove + call-argv call-argc fn invoke + dup TCO-eval = if drop eval endif { new-val } + new-val atom Atom/val ! + new-val ;; + +s\" (def! not (fn* (x) (if x false true)))" rep 2drop +s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop + +: repl ( -- ) + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +: main ( -- ) + mk-args-list { args-list } + args-list MalList/count @ 0= if + s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set + repl + else + args-list MalList/start @ @ { filename } + s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set + + repl-env + here s" load-file" MalSymbol. , filename , here>MalList + eval print + endif ; + +main +cr +bye diff --git a/impls/forth/step7_quote.fs b/impls/forth/step7_quote.fs index 3198ef33f6..38e9ed2e40 100644 --- a/impls/forth/step7_quote.fs +++ b/impls/forth/step7_quote.fs @@ -1,356 +1,356 @@ -require reader.fs -require printer.fs -require core.fs - -core MalEnv. constant repl-env - -99999999 constant TCO-eval - -: read read-str ; -: eval ( env obj ) - begin - \ ." eval-> " dup pr-str safe-type cr - mal-eval - dup TCO-eval = - while - drop - repeat ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself - -MalKeyword - extend eval-invoke { env list kw -- val } - 0 kw env list MalList/start @ cell+ @ eval get - ?dup 0= if - \ compute not-found value - list MalList/count @ 1 > if - env list MalList/start @ 2 cells + @ TCO-eval - else - mal-nil - endif - endif ;; -drop - -\ eval all but the first item of list -: eval-rest { env list -- argv argc } - list MalList/start @ cell+ { expr-start } - list MalList/count @ 1- { argc } - argc cells allocate throw { target } - argc 0 ?do - env expr-start i cells + @ eval - target i cells + ! - loop - target argc ; - -MalNativeFn - extend eval-invoke { env list this -- list } - env list eval-rest ( argv argc ) - this invoke ;; - extend invoke ( argv argc this -- val ) - MalNativeFn/xt @ execute ;; -drop - -SpecialOp - extend eval-invoke ( env list this -- list ) - SpecialOp/xt @ execute ;; -drop - -: install-special ( symbol xt ) - SpecialOp. repl-env env/set ; - -: defspecial - parse-allot-name MalSymbol. - ['] install-special - :noname - ; - -defspecial quote ( env list -- form ) - nip MalList/start @ cell+ @ ;; - -s" concat" MalSymbol. constant concat-sym -s" cons" MalSymbol. constant cons-sym -s" vec" MalSymbol. constant vec-sym - -defer quasiquote - -( If the list has two elements and the first is sym, return the second ) -( element and true, else return the list unchanged and false. ) -: qq_extract_unquote ( list symbol -- form f ) - over MalList/count @ 2 = if - over MalList/start @ tuck @ m= if ( list start - ) - cell+ @ - nip - true - exit - endif - endif - drop - false ; - -( Transition function for the following quasiquote folder. ) -: qq_loop ( acc elt -- form ) - dup mal-type @ MalList = if - splice-unquote-sym qq_extract_unquote if - here concat-sym , swap , swap , here>MalList - exit - endif - endif - quasiquote - here cons-sym , swap , swap , here>MalList ; - -( Right-fold quasiquoting each element of a list. ) -: qq_foldr ( list -- form ) - dup MalList/count @ if - dup MalList/rest recurse - swap MalList/start @ @ - qq_loop - endif ; - -: quasiquote0 ( ast -- form ) - dup mal-type @ case - MalList of - unquote-sym qq_extract_unquote if - ( the work is already done ) - else - qq_foldr - endif - endof - MalVector of - MalVector/list @ qq_foldr - here vec-sym , swap , here>MalList - endof - MalSymbol of - here quote-sym , swap , here>MalList - endof - MalMap of - here quote-sym , swap , here>MalList - endof - ( other types are returned unchanged ) - endcase ; -' quasiquote0 is quasiquote - -defspecial quasiquoteexpand ( env list -- form ) - nip MalList/start @ cell+ @ quasiquote ;; - -defspecial quasiquote ( env list ) - MalList/start @ cell+ @ ( ast ) - quasiquote TCO-eval ;; - -defspecial def! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval dup { val } ( key val ) - env env/set val ;; - -defspecial let* { old-env list -- val } - old-env MalEnv. { env } - list MalList/start @ cell+ dup { arg0 } - @ to-list - dup MalList/start @ { bindings-start } ( list ) - MalList/count @ 0 +do - bindings-start i cells + dup @ swap cell+ @ ( sym expr ) - env swap eval - env env/set - 2 +loop - env arg0 cell+ @ TCO-eval - \ TODO: dec refcount of env - ;; - -defspecial do { env list -- val } - list MalList/start @ { start } - list MalList/count @ dup 1- { last } 1 ?do - env start i cells + @ - i last = if - TCO-eval - else - eval drop - endif - loop ;; - -defspecial if { env list -- val } - list MalList/start @ cell+ { arg0 } - env arg0 @ eval ( test-val ) - dup mal-false = if - drop -1 - else - mal-nil = - endif - if - \ branch to false - list MalList/count @ 3 > if - env arg0 cell+ cell+ @ TCO-eval - else - mal-nil - endif - else - \ branch to true - env arg0 cell+ @ TCO-eval - endif ;; - -s" &" MalSymbol. constant &-sym - -: new-user-fn-env { argv argc mal-fn -- env } - mal-fn MalUserFn/formal-args @ { f-args-list } - mal-fn MalUserFn/env @ MalEnv. { env } - - f-args-list MalList/start @ { f-args } - f-args-list MalList/count @ ?dup 0= if else - \ pass empty list for last arg, unless overridden below - 1- cells f-args + @ MalList new env env/set - endif - argc 0 ?do - f-args i cells + @ - dup &-sym m= if - drop - argc i - { c } - c cells allocate throw { start } - argv i cells + start c cells cmove - f-args i 1+ cells + @ ( more-args-symbol ) - start c MalList. env env/set - leave - endif - argv i cells + @ - env env/set - loop - env ; - -MalUserFn - extend eval-invoke { call-env list mal-fn -- list } - call-env list eval-rest - mal-fn invoke ;; - - extend invoke ( argv argc mal-fn ) - dup { mal-fn } new-user-fn-env { env } - env mal-fn MalUserFn/body @ TCO-eval ;; -drop - -defspecial fn* { env list -- val } - list MalList/start @ cell+ { arg0 } - MalUserFn new - env over MalUserFn/env ! - arg0 @ to-list over MalUserFn/formal-args ! - arg0 cell+ @ over MalUserFn/body ! ;; - -MalSymbol - extend mal-eval { env sym -- val } - sym env env/get-addr - dup 0= if - drop - 0 0 s" ' not found" sym pr-str s" '" ...throw-str - else - @ - endif ;; -drop - -: eval-ast { env list -- list } - here - list MalList/start @ { expr-start } - list MalList/count @ 0 ?do - env expr-start i cells + @ eval , - loop - here>MalList ; - -MalList - extend mal-eval { env list -- val } - list MalList/count @ 0= if - list - else - env list MalList/start @ @ eval - env list rot eval-invoke - endif ;; -drop - -MalVector - extend mal-eval ( env vector -- vector ) - MalVector/list @ eval-ast - MalVector new swap over MalVector/list ! ;; -drop - -MalMap - extend mal-eval ( env map -- map ) - MalMap/list @ eval-ast - MalMap new swap over MalMap/list ! ;; -drop - -defcore eval ( argv argc ) - drop @ repl-env swap eval ;; - -: rep ( str-addr str-len -- str-addr str-len ) - read - repl-env swap eval - print ; - -: mk-args-list ( -- ) - here - begin - next-arg 2dup 0 0 d<> while - MalString. , - repeat - 2drop here>MalList ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -: nop ; - -defcore swap! { argv argc -- val } - \ argv is (atom fn args...) - argv @ { atom } - argv cell+ @ { fn } - argc 1- { call-argc } - call-argc cells allocate throw { call-argv } - atom Atom/val call-argv 1 cells cmove - argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove - call-argv call-argc fn invoke - dup TCO-eval = if drop eval endif { new-val } - new-val atom Atom/val ! - new-val ;; - -s\" (def! not (fn* (x) (if x false true)))" rep 2drop -s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop - -: repl ( -- ) - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -: main ( -- ) - mk-args-list { args-list } - args-list MalList/count @ 0= if - s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set - repl - else - args-list MalList/start @ @ { filename } - s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set - - repl-env - here s" load-file" MalSymbol. , filename , here>MalList - eval print - endif ; - -main -cr -bye +require reader.fs +require printer.fs +require core.fs + +core MalEnv. constant repl-env + +99999999 constant TCO-eval + +: read read-str ; +: eval ( env obj ) + begin + \ ." eval-> " dup pr-str safe-type cr + mal-eval + dup TCO-eval = + while + drop + repeat ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself + +MalKeyword + extend eval-invoke { env list kw -- val } + 0 kw env list MalList/start @ cell+ @ eval get + ?dup 0= if + \ compute not-found value + list MalList/count @ 1 > if + env list MalList/start @ 2 cells + @ TCO-eval + else + mal-nil + endif + endif ;; +drop + +\ eval all but the first item of list +: eval-rest { env list -- argv argc } + list MalList/start @ cell+ { expr-start } + list MalList/count @ 1- { argc } + argc cells allocate throw { target } + argc 0 ?do + env expr-start i cells + @ eval + target i cells + ! + loop + target argc ; + +MalNativeFn + extend eval-invoke { env list this -- list } + env list eval-rest ( argv argc ) + this invoke ;; + extend invoke ( argv argc this -- val ) + MalNativeFn/xt @ execute ;; +drop + +SpecialOp + extend eval-invoke ( env list this -- list ) + SpecialOp/xt @ execute ;; +drop + +: install-special ( symbol xt ) + SpecialOp. repl-env env/set ; + +: defspecial + parse-allot-name MalSymbol. + ['] install-special + :noname + ; + +defspecial quote ( env list -- form ) + nip MalList/start @ cell+ @ ;; + +s" concat" MalSymbol. constant concat-sym +s" cons" MalSymbol. constant cons-sym +s" vec" MalSymbol. constant vec-sym + +defer quasiquote + +( If the list has two elements and the first is sym, return the second ) +( element and true, else return the list unchanged and false. ) +: qq_extract_unquote ( list symbol -- form f ) + over MalList/count @ 2 = if + over MalList/start @ tuck @ m= if ( list start - ) + cell+ @ + nip + true + exit + endif + endif + drop + false ; + +( Transition function for the following quasiquote folder. ) +: qq_loop ( acc elt -- form ) + dup mal-type @ MalList = if + splice-unquote-sym qq_extract_unquote if + here concat-sym , swap , swap , here>MalList + exit + endif + endif + quasiquote + here cons-sym , swap , swap , here>MalList ; + +( Right-fold quasiquoting each element of a list. ) +: qq_foldr ( list -- form ) + dup MalList/count @ if + dup MalList/rest recurse + swap MalList/start @ @ + qq_loop + endif ; + +: quasiquote0 ( ast -- form ) + dup mal-type @ case + MalList of + unquote-sym qq_extract_unquote if + ( the work is already done ) + else + qq_foldr + endif + endof + MalVector of + MalVector/list @ qq_foldr + here vec-sym , swap , here>MalList + endof + MalSymbol of + here quote-sym , swap , here>MalList + endof + MalMap of + here quote-sym , swap , here>MalList + endof + ( other types are returned unchanged ) + endcase ; +' quasiquote0 is quasiquote + +defspecial quasiquoteexpand ( env list -- form ) + nip MalList/start @ cell+ @ quasiquote ;; + +defspecial quasiquote ( env list ) + MalList/start @ cell+ @ ( ast ) + quasiquote TCO-eval ;; + +defspecial def! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval dup { val } ( key val ) + env env/set val ;; + +defspecial let* { old-env list -- val } + old-env MalEnv. { env } + list MalList/start @ cell+ dup { arg0 } + @ to-list + dup MalList/start @ { bindings-start } ( list ) + MalList/count @ 0 +do + bindings-start i cells + dup @ swap cell+ @ ( sym expr ) + env swap eval + env env/set + 2 +loop + env arg0 cell+ @ TCO-eval + \ TODO: dec refcount of env + ;; + +defspecial do { env list -- val } + list MalList/start @ { start } + list MalList/count @ dup 1- { last } 1 ?do + env start i cells + @ + i last = if + TCO-eval + else + eval drop + endif + loop ;; + +defspecial if { env list -- val } + list MalList/start @ cell+ { arg0 } + env arg0 @ eval ( test-val ) + dup mal-false = if + drop -1 + else + mal-nil = + endif + if + \ branch to false + list MalList/count @ 3 > if + env arg0 cell+ cell+ @ TCO-eval + else + mal-nil + endif + else + \ branch to true + env arg0 cell+ @ TCO-eval + endif ;; + +s" &" MalSymbol. constant &-sym + +: new-user-fn-env { argv argc mal-fn -- env } + mal-fn MalUserFn/formal-args @ { f-args-list } + mal-fn MalUserFn/env @ MalEnv. { env } + + f-args-list MalList/start @ { f-args } + f-args-list MalList/count @ ?dup 0= if else + \ pass empty list for last arg, unless overridden below + 1- cells f-args + @ MalList new env env/set + endif + argc 0 ?do + f-args i cells + @ + dup &-sym m= if + drop + argc i - { c } + c cells allocate throw { start } + argv i cells + start c cells cmove + f-args i 1+ cells + @ ( more-args-symbol ) + start c MalList. env env/set + leave + endif + argv i cells + @ + env env/set + loop + env ; + +MalUserFn + extend eval-invoke { call-env list mal-fn -- list } + call-env list eval-rest + mal-fn invoke ;; + + extend invoke ( argv argc mal-fn ) + dup { mal-fn } new-user-fn-env { env } + env mal-fn MalUserFn/body @ TCO-eval ;; +drop + +defspecial fn* { env list -- val } + list MalList/start @ cell+ { arg0 } + MalUserFn new + env over MalUserFn/env ! + arg0 @ to-list over MalUserFn/formal-args ! + arg0 cell+ @ over MalUserFn/body ! ;; + +MalSymbol + extend mal-eval { env sym -- val } + sym env env/get-addr + dup 0= if + drop + 0 0 s" ' not found" sym pr-str s" '" ...throw-str + else + @ + endif ;; +drop + +: eval-ast { env list -- list } + here + list MalList/start @ { expr-start } + list MalList/count @ 0 ?do + env expr-start i cells + @ eval , + loop + here>MalList ; + +MalList + extend mal-eval { env list -- val } + list MalList/count @ 0= if + list + else + env list MalList/start @ @ eval + env list rot eval-invoke + endif ;; +drop + +MalVector + extend mal-eval ( env vector -- vector ) + MalVector/list @ eval-ast + MalVector new swap over MalVector/list ! ;; +drop + +MalMap + extend mal-eval ( env map -- map ) + MalMap/list @ eval-ast + MalMap new swap over MalMap/list ! ;; +drop + +defcore eval ( argv argc ) + drop @ repl-env swap eval ;; + +: rep ( str-addr str-len -- str-addr str-len ) + read + repl-env swap eval + print ; + +: mk-args-list ( -- ) + here + begin + next-arg 2dup 0 0 d<> while + MalString. , + repeat + 2drop here>MalList ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +: nop ; + +defcore swap! { argv argc -- val } + \ argv is (atom fn args...) + argv @ { atom } + argv cell+ @ { fn } + argc 1- { call-argc } + call-argc cells allocate throw { call-argv } + atom Atom/val call-argv 1 cells cmove + argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove + call-argv call-argc fn invoke + dup TCO-eval = if drop eval endif { new-val } + new-val atom Atom/val ! + new-val ;; + +s\" (def! not (fn* (x) (if x false true)))" rep 2drop +s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop + +: repl ( -- ) + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +: main ( -- ) + mk-args-list { args-list } + args-list MalList/count @ 0= if + s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set + repl + else + args-list MalList/start @ @ { filename } + s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set + + repl-env + here s" load-file" MalSymbol. , filename , here>MalList + eval print + endif ; + +main +cr +bye diff --git a/impls/forth/step8_macros.fs b/impls/forth/step8_macros.fs index 0ea32523a1..c8ad723f7f 100644 --- a/impls/forth/step8_macros.fs +++ b/impls/forth/step8_macros.fs @@ -1,382 +1,382 @@ -require reader.fs -require printer.fs -require core.fs - -core MalEnv. constant repl-env - -99999999 constant TCO-eval - -: read read-str ; -: eval ( env obj ) - begin - \ ." eval-> " dup pr-str safe-type cr - mal-eval - dup TCO-eval = - while - drop - repeat ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself - -MalKeyword - extend eval-invoke { env list kw -- val } - 0 kw env list MalList/start @ cell+ @ eval get - ?dup 0= if - \ compute not-found value - list MalList/count @ 1 > if - env list MalList/start @ 2 cells + @ TCO-eval - else - mal-nil - endif - endif ;; -drop - -\ eval all but the first item of list -: eval-rest { env list -- argv argc } - list MalList/start @ cell+ { expr-start } - list MalList/count @ 1- { argc } - argc cells allocate throw { target } - argc 0 ?do - env expr-start i cells + @ eval - target i cells + ! - loop - target argc ; - -MalNativeFn - extend eval-invoke { env list this -- list } - env list eval-rest ( argv argc ) - this invoke ;; - extend invoke ( argv argc this -- val ) - MalNativeFn/xt @ execute ;; -drop - -SpecialOp - extend eval-invoke ( env list this -- list ) - SpecialOp/xt @ execute ;; -drop - -: install-special ( symbol xt ) - SpecialOp. repl-env env/set ; - -: defspecial - parse-allot-name MalSymbol. - ['] install-special - :noname - ; - -defspecial quote ( env list -- form ) - nip MalList/start @ cell+ @ ;; - -s" concat" MalSymbol. constant concat-sym -s" cons" MalSymbol. constant cons-sym -s" vec" MalSymbol. constant vec-sym - -defer quasiquote - -( If the list has two elements and the first is sym, return the second ) -( element and true, else return the list unchanged and false. ) -: qq_extract_unquote ( list symbol -- form f ) - over MalList/count @ 2 = if - over MalList/start @ tuck @ m= if ( list start - ) - cell+ @ - nip - true - exit - endif - endif - drop - false ; - -( Transition function for the following quasiquote folder. ) -: qq_loop ( acc elt -- form ) - dup mal-type @ MalList = if - splice-unquote-sym qq_extract_unquote if - here concat-sym , swap , swap , here>MalList - exit - endif - endif - quasiquote - here cons-sym , swap , swap , here>MalList ; - -( Right-fold quasiquoting each element of a list. ) -: qq_foldr ( list -- form ) - dup MalList/count @ if - dup MalList/rest recurse - swap MalList/start @ @ - qq_loop - endif ; - -: quasiquote0 ( ast -- form ) - dup mal-type @ case - MalList of - unquote-sym qq_extract_unquote if - ( the work is already done ) - else - qq_foldr - endif - endof - MalVector of - MalVector/list @ qq_foldr - here vec-sym , swap , here>MalList - endof - MalSymbol of - here quote-sym , swap , here>MalList - endof - MalMap of - here quote-sym , swap , here>MalList - endof - ( other types are returned unchanged ) - endcase ; -' quasiquote0 is quasiquote - -defspecial quasiquoteexpand ( env list -- form ) - nip MalList/start @ cell+ @ quasiquote ;; - -defspecial quasiquote ( env list ) - MalList/start @ cell+ @ ( ast ) - quasiquote TCO-eval ;; - -defspecial def! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval dup { val } ( key val ) - env env/set val ;; - -defspecial defmacro! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval { val } - true val MalUserFn/is-macro? ! - val env env/set - val ;; - -defspecial let* { old-env list -- val } - old-env MalEnv. { env } - list MalList/start @ cell+ dup { arg0 } - @ to-list - dup MalList/start @ { bindings-start } ( list ) - MalList/count @ 0 +do - bindings-start i cells + dup @ swap cell+ @ ( sym expr ) - env swap eval - env env/set - 2 +loop - env arg0 cell+ @ TCO-eval - \ TODO: dec refcount of env - ;; - -defspecial do { env list -- val } - list MalList/start @ { start } - list MalList/count @ dup 1- { last } 1 ?do - env start i cells + @ - i last = if - TCO-eval - else - eval drop - endif - loop ;; - -defspecial if { env list -- val } - list MalList/start @ cell+ { arg0 } - env arg0 @ eval ( test-val ) - dup mal-false = if - drop -1 - else - mal-nil = - endif - if - \ branch to false - list MalList/count @ 3 > if - env arg0 cell+ cell+ @ TCO-eval - else - mal-nil - endif - else - \ branch to true - env arg0 cell+ @ TCO-eval - endif ;; - -s" &" MalSymbol. constant &-sym - -: new-user-fn-env { argv argc mal-fn -- env } - mal-fn MalUserFn/formal-args @ { f-args-list } - mal-fn MalUserFn/env @ MalEnv. { env } - - f-args-list MalList/start @ { f-args } - f-args-list MalList/count @ ?dup 0= if else - \ pass empty list for last arg, unless overridden below - 1- cells f-args + @ MalList new env env/set - endif - argc 0 ?do - f-args i cells + @ - dup &-sym m= if - drop - argc i - { c } - c cells allocate throw { start } - argv i cells + start c cells cmove - f-args i 1+ cells + @ ( more-args-symbol ) - start c MalList. env env/set - leave - endif - argv i cells + @ - env env/set - loop - env ; - -MalUserFn - extend eval-invoke { call-env list mal-fn -- list } - mal-fn MalUserFn/is-macro? @ if - list MalList/start @ cell+ \ argv - list MalList/count @ 1- \ argc - mal-fn new-user-fn-env { env } - env mal-fn MalUserFn/body @ eval - call-env swap TCO-eval - else - call-env list eval-rest - mal-fn invoke - endif ;; - - extend invoke ( argv argc mal-fn ) - dup { mal-fn } new-user-fn-env { env } - env mal-fn MalUserFn/body @ TCO-eval ;; -drop - -defspecial fn* { env list -- val } - list MalList/start @ cell+ { arg0 } - MalUserFn new - false over MalUserFn/is-macro? ! - env over MalUserFn/env ! - arg0 @ to-list over MalUserFn/formal-args ! - arg0 cell+ @ over MalUserFn/body ! ;; - -defspecial macroexpand ( env list[_,form] -- form ) - MalList/start @ cell+ @ swap over ( form env form ) - MalList/start @ @ ( form env macro-name-expr ) - eval { macro-fn } ( form ) - dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn ) - new-user-fn-env ( env ) - macro-fn MalUserFn/body @ TCO-eval ;; - -MalSymbol - extend mal-eval { env sym -- val } - sym env env/get-addr - dup 0= if - drop - 0 0 s" ' not found" sym pr-str s" '" ...throw-str - else - @ - endif ;; -drop - -: eval-ast { env list -- list } - here - list MalList/start @ { expr-start } - list MalList/count @ 0 ?do - env expr-start i cells + @ eval , - loop - here>MalList ; - -MalList - extend mal-eval { env list -- val } - list MalList/count @ 0= if - list - else - env list MalList/start @ @ eval - env list rot eval-invoke - endif ;; -drop - -MalVector - extend mal-eval ( env vector -- vector ) - MalVector/list @ eval-ast - MalVector new swap over MalVector/list ! ;; -drop - -MalMap - extend mal-eval ( env map -- map ) - MalMap/list @ eval-ast - MalMap new swap over MalMap/list ! ;; -drop - -defcore eval ( argv argc ) - drop @ repl-env swap eval ;; - -: rep ( str-addr str-len -- str-addr str-len ) - read - repl-env swap eval - print ; - -: mk-args-list ( -- ) - here - begin - next-arg 2dup 0 0 d<> while - MalString. , - repeat - 2drop here>MalList ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -: nop ; - -defcore swap! { argv argc -- val } - \ argv is (atom fn args...) - argv @ { atom } - argv cell+ @ { fn } - argc 1- { call-argc } - call-argc cells allocate throw { call-argv } - atom Atom/val call-argv 1 cells cmove - argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove - call-argv call-argc fn invoke - dup TCO-eval = if drop eval endif { new-val } - new-val atom Atom/val ! - new-val ;; - -s\" (def! not (fn* (x) (if x false true)))" rep 2drop -s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop -s\" (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 2drop - -: repl ( -- ) - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -: main ( -- ) - mk-args-list { args-list } - args-list MalList/count @ 0= if - s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set - repl - else - args-list MalList/start @ @ { filename } - s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set - - repl-env - here s" load-file" MalSymbol. , filename , here>MalList - eval print - endif ; - -main -cr -bye +require reader.fs +require printer.fs +require core.fs + +core MalEnv. constant repl-env + +99999999 constant TCO-eval + +: read read-str ; +: eval ( env obj ) + begin + \ ." eval-> " dup pr-str safe-type cr + mal-eval + dup TCO-eval = + while + drop + repeat ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself + +MalKeyword + extend eval-invoke { env list kw -- val } + 0 kw env list MalList/start @ cell+ @ eval get + ?dup 0= if + \ compute not-found value + list MalList/count @ 1 > if + env list MalList/start @ 2 cells + @ TCO-eval + else + mal-nil + endif + endif ;; +drop + +\ eval all but the first item of list +: eval-rest { env list -- argv argc } + list MalList/start @ cell+ { expr-start } + list MalList/count @ 1- { argc } + argc cells allocate throw { target } + argc 0 ?do + env expr-start i cells + @ eval + target i cells + ! + loop + target argc ; + +MalNativeFn + extend eval-invoke { env list this -- list } + env list eval-rest ( argv argc ) + this invoke ;; + extend invoke ( argv argc this -- val ) + MalNativeFn/xt @ execute ;; +drop + +SpecialOp + extend eval-invoke ( env list this -- list ) + SpecialOp/xt @ execute ;; +drop + +: install-special ( symbol xt ) + SpecialOp. repl-env env/set ; + +: defspecial + parse-allot-name MalSymbol. + ['] install-special + :noname + ; + +defspecial quote ( env list -- form ) + nip MalList/start @ cell+ @ ;; + +s" concat" MalSymbol. constant concat-sym +s" cons" MalSymbol. constant cons-sym +s" vec" MalSymbol. constant vec-sym + +defer quasiquote + +( If the list has two elements and the first is sym, return the second ) +( element and true, else return the list unchanged and false. ) +: qq_extract_unquote ( list symbol -- form f ) + over MalList/count @ 2 = if + over MalList/start @ tuck @ m= if ( list start - ) + cell+ @ + nip + true + exit + endif + endif + drop + false ; + +( Transition function for the following quasiquote folder. ) +: qq_loop ( acc elt -- form ) + dup mal-type @ MalList = if + splice-unquote-sym qq_extract_unquote if + here concat-sym , swap , swap , here>MalList + exit + endif + endif + quasiquote + here cons-sym , swap , swap , here>MalList ; + +( Right-fold quasiquoting each element of a list. ) +: qq_foldr ( list -- form ) + dup MalList/count @ if + dup MalList/rest recurse + swap MalList/start @ @ + qq_loop + endif ; + +: quasiquote0 ( ast -- form ) + dup mal-type @ case + MalList of + unquote-sym qq_extract_unquote if + ( the work is already done ) + else + qq_foldr + endif + endof + MalVector of + MalVector/list @ qq_foldr + here vec-sym , swap , here>MalList + endof + MalSymbol of + here quote-sym , swap , here>MalList + endof + MalMap of + here quote-sym , swap , here>MalList + endof + ( other types are returned unchanged ) + endcase ; +' quasiquote0 is quasiquote + +defspecial quasiquoteexpand ( env list -- form ) + nip MalList/start @ cell+ @ quasiquote ;; + +defspecial quasiquote ( env list ) + MalList/start @ cell+ @ ( ast ) + quasiquote TCO-eval ;; + +defspecial def! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval dup { val } ( key val ) + env env/set val ;; + +defspecial defmacro! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval { val } + true val MalUserFn/is-macro? ! + val env env/set + val ;; + +defspecial let* { old-env list -- val } + old-env MalEnv. { env } + list MalList/start @ cell+ dup { arg0 } + @ to-list + dup MalList/start @ { bindings-start } ( list ) + MalList/count @ 0 +do + bindings-start i cells + dup @ swap cell+ @ ( sym expr ) + env swap eval + env env/set + 2 +loop + env arg0 cell+ @ TCO-eval + \ TODO: dec refcount of env + ;; + +defspecial do { env list -- val } + list MalList/start @ { start } + list MalList/count @ dup 1- { last } 1 ?do + env start i cells + @ + i last = if + TCO-eval + else + eval drop + endif + loop ;; + +defspecial if { env list -- val } + list MalList/start @ cell+ { arg0 } + env arg0 @ eval ( test-val ) + dup mal-false = if + drop -1 + else + mal-nil = + endif + if + \ branch to false + list MalList/count @ 3 > if + env arg0 cell+ cell+ @ TCO-eval + else + mal-nil + endif + else + \ branch to true + env arg0 cell+ @ TCO-eval + endif ;; + +s" &" MalSymbol. constant &-sym + +: new-user-fn-env { argv argc mal-fn -- env } + mal-fn MalUserFn/formal-args @ { f-args-list } + mal-fn MalUserFn/env @ MalEnv. { env } + + f-args-list MalList/start @ { f-args } + f-args-list MalList/count @ ?dup 0= if else + \ pass empty list for last arg, unless overridden below + 1- cells f-args + @ MalList new env env/set + endif + argc 0 ?do + f-args i cells + @ + dup &-sym m= if + drop + argc i - { c } + c cells allocate throw { start } + argv i cells + start c cells cmove + f-args i 1+ cells + @ ( more-args-symbol ) + start c MalList. env env/set + leave + endif + argv i cells + @ + env env/set + loop + env ; + +MalUserFn + extend eval-invoke { call-env list mal-fn -- list } + mal-fn MalUserFn/is-macro? @ if + list MalList/start @ cell+ \ argv + list MalList/count @ 1- \ argc + mal-fn new-user-fn-env { env } + env mal-fn MalUserFn/body @ eval + call-env swap TCO-eval + else + call-env list eval-rest + mal-fn invoke + endif ;; + + extend invoke ( argv argc mal-fn ) + dup { mal-fn } new-user-fn-env { env } + env mal-fn MalUserFn/body @ TCO-eval ;; +drop + +defspecial fn* { env list -- val } + list MalList/start @ cell+ { arg0 } + MalUserFn new + false over MalUserFn/is-macro? ! + env over MalUserFn/env ! + arg0 @ to-list over MalUserFn/formal-args ! + arg0 cell+ @ over MalUserFn/body ! ;; + +defspecial macroexpand ( env list[_,form] -- form ) + MalList/start @ cell+ @ swap over ( form env form ) + MalList/start @ @ ( form env macro-name-expr ) + eval { macro-fn } ( form ) + dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn ) + new-user-fn-env ( env ) + macro-fn MalUserFn/body @ TCO-eval ;; + +MalSymbol + extend mal-eval { env sym -- val } + sym env env/get-addr + dup 0= if + drop + 0 0 s" ' not found" sym pr-str s" '" ...throw-str + else + @ + endif ;; +drop + +: eval-ast { env list -- list } + here + list MalList/start @ { expr-start } + list MalList/count @ 0 ?do + env expr-start i cells + @ eval , + loop + here>MalList ; + +MalList + extend mal-eval { env list -- val } + list MalList/count @ 0= if + list + else + env list MalList/start @ @ eval + env list rot eval-invoke + endif ;; +drop + +MalVector + extend mal-eval ( env vector -- vector ) + MalVector/list @ eval-ast + MalVector new swap over MalVector/list ! ;; +drop + +MalMap + extend mal-eval ( env map -- map ) + MalMap/list @ eval-ast + MalMap new swap over MalMap/list ! ;; +drop + +defcore eval ( argv argc ) + drop @ repl-env swap eval ;; + +: rep ( str-addr str-len -- str-addr str-len ) + read + repl-env swap eval + print ; + +: mk-args-list ( -- ) + here + begin + next-arg 2dup 0 0 d<> while + MalString. , + repeat + 2drop here>MalList ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +: nop ; + +defcore swap! { argv argc -- val } + \ argv is (atom fn args...) + argv @ { atom } + argv cell+ @ { fn } + argc 1- { call-argc } + call-argc cells allocate throw { call-argv } + atom Atom/val call-argv 1 cells cmove + argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove + call-argv call-argc fn invoke + dup TCO-eval = if drop eval endif { new-val } + new-val atom Atom/val ! + new-val ;; + +s\" (def! not (fn* (x) (if x false true)))" rep 2drop +s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop +s\" (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 2drop + +: repl ( -- ) + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +: main ( -- ) + mk-args-list { args-list } + args-list MalList/count @ 0= if + s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set + repl + else + args-list MalList/start @ @ { filename } + s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set + + repl-env + here s" load-file" MalSymbol. , filename , here>MalList + eval print + endif ; + +main +cr +bye diff --git a/impls/forth/step9_try.fs b/impls/forth/step9_try.fs index ab39fd56a3..aafc4bff0d 100644 --- a/impls/forth/step9_try.fs +++ b/impls/forth/step9_try.fs @@ -1,425 +1,425 @@ -require reader.fs -require printer.fs -require core.fs - -core MalEnv. constant repl-env - -99999999 constant TCO-eval - -: read read-str ; -: eval ( env obj ) - begin - \ ." eval-> " dup pr-str safe-type cr - mal-eval - dup TCO-eval = - while - drop - repeat ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself - -MalKeyword - extend eval-invoke { env list kw -- val } - 0 kw env list MalList/start @ cell+ @ eval get - ?dup 0= if - \ compute not-found value - list MalList/count @ 1 > if - env list MalList/start @ 2 cells + @ TCO-eval - else - mal-nil - endif - endif ;; - extend invoke { argv argc kw -- val } - 0 kw argv @ get - ?dup 0= if - argc 1 > if - argv cell+ @ - else - mal-nil - endif - endif ;; -drop - -\ eval all but the first item of list -: eval-rest { env list -- argv argc } - list MalList/start @ cell+ { expr-start } - list MalList/count @ 1- { argc } - argc cells allocate throw { target } - argc 0 ?do - env expr-start i cells + @ eval - target i cells + ! - loop - target argc ; - -MalNativeFn - extend eval-invoke { env list this -- list } - env list eval-rest ( argv argc ) - this invoke ;; - extend invoke ( argv argc this -- val ) - MalNativeFn/xt @ execute ;; -drop - -SpecialOp - extend eval-invoke ( env list this -- list ) - SpecialOp/xt @ execute ;; -drop - -: install-special ( symbol xt ) - SpecialOp. repl-env env/set ; - -: defspecial - parse-allot-name MalSymbol. - ['] install-special - :noname - ; - -defspecial quote ( env list -- form ) - nip MalList/start @ cell+ @ ;; - -s" concat" MalSymbol. constant concat-sym -s" cons" MalSymbol. constant cons-sym -s" vec" MalSymbol. constant vec-sym - -defer quasiquote - -( If the list has two elements and the first is sym, return the second ) -( element and true, else return the list unchanged and false. ) -: qq_extract_unquote ( list symbol -- form f ) - over MalList/count @ 2 = if - over MalList/start @ tuck @ m= if ( list start - ) - cell+ @ - nip - true - exit - endif - endif - drop - false ; - -( Transition function for the following quasiquote folder. ) -: qq_loop ( acc elt -- form ) - dup mal-type @ MalList = if - splice-unquote-sym qq_extract_unquote if - here concat-sym , swap , swap , here>MalList - exit - endif - endif - quasiquote - here cons-sym , swap , swap , here>MalList ; - -( Right-fold quasiquoting each element of a list. ) -: qq_foldr ( list -- form ) - dup MalList/count @ if - dup MalList/rest recurse - swap MalList/start @ @ - qq_loop - endif ; - -: quasiquote0 ( ast -- form ) - dup mal-type @ case - MalList of - unquote-sym qq_extract_unquote if - ( the work is already done ) - else - qq_foldr - endif - endof - MalVector of - MalVector/list @ qq_foldr - here vec-sym , swap , here>MalList - endof - MalSymbol of - here quote-sym , swap , here>MalList - endof - MalMap of - here quote-sym , swap , here>MalList - endof - ( other types are returned unchanged ) - endcase ; -' quasiquote0 is quasiquote - -defspecial quasiquoteexpand ( env list -- form ) - nip MalList/start @ cell+ @ quasiquote ;; - -defspecial quasiquote ( env list ) - MalList/start @ cell+ @ ( ast ) - quasiquote TCO-eval ;; - -defspecial def! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval dup { val } ( key val ) - env env/set val ;; - -defspecial defmacro! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval { val } - true val MalUserFn/is-macro? ! - val env env/set - val ;; - -defspecial let* { old-env list -- val } - old-env MalEnv. { env } - list MalList/start @ cell+ dup { arg0 } - @ to-list - dup MalList/start @ { bindings-start } ( list ) - MalList/count @ 0 +do - bindings-start i cells + dup @ swap cell+ @ ( sym expr ) - env swap eval - env env/set - 2 +loop - env arg0 cell+ @ TCO-eval - \ TODO: dec refcount of env - ;; - -defspecial do { env list -- val } - list MalList/start @ { start } - list MalList/count @ dup 1- { last } 1 ?do - env start i cells + @ - i last = if - TCO-eval - else - eval drop - endif - loop ;; - -defspecial if { env list -- val } - list MalList/start @ cell+ { arg0 } - env arg0 @ eval ( test-val ) - dup mal-false = if - drop -1 - else - mal-nil = - endif - if - \ branch to false - list MalList/count @ 3 > if - env arg0 cell+ cell+ @ TCO-eval - else - mal-nil - endif - else - \ branch to true - env arg0 cell+ @ TCO-eval - endif ;; - -s" &" MalSymbol. constant &-sym - -: new-user-fn-env { argv argc mal-fn -- env } - mal-fn MalUserFn/formal-args @ { f-args-list } - mal-fn MalUserFn/env @ MalEnv. { env } - - f-args-list MalList/start @ { f-args } - f-args-list MalList/count @ ?dup 0= if else - \ pass empty list for last arg, unless overridden below - 1- cells f-args + @ MalList new env env/set - endif - argc 0 ?do - f-args i cells + @ - dup &-sym m= if - drop - argc i - { c } - c cells allocate throw { start } - argv i cells + start c cells cmove - f-args i 1+ cells + @ ( more-args-symbol ) - start c MalList. env env/set - leave - endif - argv i cells + @ - env env/set - loop - env ; - -MalUserFn - extend eval-invoke { call-env list mal-fn -- list } - mal-fn MalUserFn/is-macro? @ if - list MalList/start @ cell+ \ argv - list MalList/count @ 1- \ argc - mal-fn new-user-fn-env { env } - env mal-fn MalUserFn/body @ eval - call-env swap TCO-eval - else - call-env list eval-rest - mal-fn invoke - endif ;; - - extend invoke ( argv argc mal-fn ) - dup { mal-fn } new-user-fn-env { env } - env mal-fn MalUserFn/body @ TCO-eval ;; -drop - -defspecial fn* { env list -- val } - list MalList/start @ cell+ { arg0 } - MalUserFn new - false over MalUserFn/is-macro? ! - env over MalUserFn/env ! - arg0 @ to-list over MalUserFn/formal-args ! - arg0 cell+ @ over MalUserFn/body ! ;; - -defspecial macroexpand ( env list[_,form] -- form ) - MalList/start @ cell+ @ swap over ( form env form ) - MalList/start @ @ ( form env macro-name-expr ) - eval { macro-fn } ( form ) - dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn ) - new-user-fn-env ( env ) - macro-fn MalUserFn/body @ TCO-eval ;; - -5555555555 constant pre-try - -defspecial try* { env list -- val } - list MalList/start @ cell+ { arg0 } - list MalList/count @ 3 < if - env arg0 @ eval - else - pre-try - env arg0 @ ['] eval catch ?dup 0= if - nip - else { errno } - begin pre-try = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - arg0 cell+ @ ( list[catch*,sym,form] ) - MalList/start @ cell+ { catch0 } - env MalEnv. { catch-env } - catch0 @ exception-object catch-env env/set - catch-env catch0 cell+ @ TCO-eval - endif - endif ;; - -MalSymbol - extend mal-eval { env sym -- val } - sym env env/get-addr - dup 0= if - drop - 0 0 s" ' not found" sym pr-str s" '" ...throw-str - else - @ - endif ;; -drop - -: eval-ast { env list -- list } - here - list MalList/start @ { expr-start } - list MalList/count @ 0 ?do - env expr-start i cells + @ eval , - loop - here>MalList ; - -MalList - extend mal-eval { env list -- val } - list MalList/count @ 0= if - list - else - env list MalList/start @ @ eval - env list rot eval-invoke - endif ;; -drop - -MalVector - extend mal-eval ( env vector -- vector ) - MalVector/list @ eval-ast - MalVector new swap over MalVector/list ! ;; -drop - -MalMap - extend mal-eval ( env map -- map ) - MalMap/list @ eval-ast - MalMap new swap over MalMap/list ! ;; -drop - -defcore eval ( argv argc ) - drop @ repl-env swap eval ;; - -: rep ( str-addr str-len -- str-addr str-len ) - read - repl-env swap eval - print ; - -: mk-args-list ( -- ) - here - begin - next-arg 2dup 0 0 d<> while - MalString. , - repeat - 2drop here>MalList ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -: nop ; - -defcore swap! { argv argc -- val } - \ argv is (atom fn args...) - argv @ { atom } - argv cell+ @ { fn } - argc 1- { call-argc } - call-argc cells allocate throw { call-argv } - atom Atom/val call-argv 1 cells cmove - argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove - call-argv call-argc fn invoke - dup TCO-eval = if drop eval endif { new-val } - new-val atom Atom/val ! - new-val ;; - -defcore map ( argv argc -- list ) - drop dup @ swap cell+ @ to-list { fn list } - here - list MalList/start @ list MalList/count @ cells over + swap +do - i 1 fn invoke - dup TCO-eval = if drop eval endif - , - cell +loop - here>MalList ;; - -s\" (def! not (fn* (x) (if x false true)))" rep 2drop -s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop -s\" (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 2drop - -: repl ( -- ) - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -: main ( -- ) - mk-args-list { args-list } - args-list MalList/count @ 0= if - s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set - repl - else - args-list MalList/start @ @ { filename } - s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set - - repl-env - here s" load-file" MalSymbol. , filename , here>MalList - eval print - endif ; - -main -cr -bye +require reader.fs +require printer.fs +require core.fs + +core MalEnv. constant repl-env + +99999999 constant TCO-eval + +: read read-str ; +: eval ( env obj ) + begin + \ ." eval-> " dup pr-str safe-type cr + mal-eval + dup TCO-eval = + while + drop + repeat ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself + +MalKeyword + extend eval-invoke { env list kw -- val } + 0 kw env list MalList/start @ cell+ @ eval get + ?dup 0= if + \ compute not-found value + list MalList/count @ 1 > if + env list MalList/start @ 2 cells + @ TCO-eval + else + mal-nil + endif + endif ;; + extend invoke { argv argc kw -- val } + 0 kw argv @ get + ?dup 0= if + argc 1 > if + argv cell+ @ + else + mal-nil + endif + endif ;; +drop + +\ eval all but the first item of list +: eval-rest { env list -- argv argc } + list MalList/start @ cell+ { expr-start } + list MalList/count @ 1- { argc } + argc cells allocate throw { target } + argc 0 ?do + env expr-start i cells + @ eval + target i cells + ! + loop + target argc ; + +MalNativeFn + extend eval-invoke { env list this -- list } + env list eval-rest ( argv argc ) + this invoke ;; + extend invoke ( argv argc this -- val ) + MalNativeFn/xt @ execute ;; +drop + +SpecialOp + extend eval-invoke ( env list this -- list ) + SpecialOp/xt @ execute ;; +drop + +: install-special ( symbol xt ) + SpecialOp. repl-env env/set ; + +: defspecial + parse-allot-name MalSymbol. + ['] install-special + :noname + ; + +defspecial quote ( env list -- form ) + nip MalList/start @ cell+ @ ;; + +s" concat" MalSymbol. constant concat-sym +s" cons" MalSymbol. constant cons-sym +s" vec" MalSymbol. constant vec-sym + +defer quasiquote + +( If the list has two elements and the first is sym, return the second ) +( element and true, else return the list unchanged and false. ) +: qq_extract_unquote ( list symbol -- form f ) + over MalList/count @ 2 = if + over MalList/start @ tuck @ m= if ( list start - ) + cell+ @ + nip + true + exit + endif + endif + drop + false ; + +( Transition function for the following quasiquote folder. ) +: qq_loop ( acc elt -- form ) + dup mal-type @ MalList = if + splice-unquote-sym qq_extract_unquote if + here concat-sym , swap , swap , here>MalList + exit + endif + endif + quasiquote + here cons-sym , swap , swap , here>MalList ; + +( Right-fold quasiquoting each element of a list. ) +: qq_foldr ( list -- form ) + dup MalList/count @ if + dup MalList/rest recurse + swap MalList/start @ @ + qq_loop + endif ; + +: quasiquote0 ( ast -- form ) + dup mal-type @ case + MalList of + unquote-sym qq_extract_unquote if + ( the work is already done ) + else + qq_foldr + endif + endof + MalVector of + MalVector/list @ qq_foldr + here vec-sym , swap , here>MalList + endof + MalSymbol of + here quote-sym , swap , here>MalList + endof + MalMap of + here quote-sym , swap , here>MalList + endof + ( other types are returned unchanged ) + endcase ; +' quasiquote0 is quasiquote + +defspecial quasiquoteexpand ( env list -- form ) + nip MalList/start @ cell+ @ quasiquote ;; + +defspecial quasiquote ( env list ) + MalList/start @ cell+ @ ( ast ) + quasiquote TCO-eval ;; + +defspecial def! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval dup { val } ( key val ) + env env/set val ;; + +defspecial defmacro! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval { val } + true val MalUserFn/is-macro? ! + val env env/set + val ;; + +defspecial let* { old-env list -- val } + old-env MalEnv. { env } + list MalList/start @ cell+ dup { arg0 } + @ to-list + dup MalList/start @ { bindings-start } ( list ) + MalList/count @ 0 +do + bindings-start i cells + dup @ swap cell+ @ ( sym expr ) + env swap eval + env env/set + 2 +loop + env arg0 cell+ @ TCO-eval + \ TODO: dec refcount of env + ;; + +defspecial do { env list -- val } + list MalList/start @ { start } + list MalList/count @ dup 1- { last } 1 ?do + env start i cells + @ + i last = if + TCO-eval + else + eval drop + endif + loop ;; + +defspecial if { env list -- val } + list MalList/start @ cell+ { arg0 } + env arg0 @ eval ( test-val ) + dup mal-false = if + drop -1 + else + mal-nil = + endif + if + \ branch to false + list MalList/count @ 3 > if + env arg0 cell+ cell+ @ TCO-eval + else + mal-nil + endif + else + \ branch to true + env arg0 cell+ @ TCO-eval + endif ;; + +s" &" MalSymbol. constant &-sym + +: new-user-fn-env { argv argc mal-fn -- env } + mal-fn MalUserFn/formal-args @ { f-args-list } + mal-fn MalUserFn/env @ MalEnv. { env } + + f-args-list MalList/start @ { f-args } + f-args-list MalList/count @ ?dup 0= if else + \ pass empty list for last arg, unless overridden below + 1- cells f-args + @ MalList new env env/set + endif + argc 0 ?do + f-args i cells + @ + dup &-sym m= if + drop + argc i - { c } + c cells allocate throw { start } + argv i cells + start c cells cmove + f-args i 1+ cells + @ ( more-args-symbol ) + start c MalList. env env/set + leave + endif + argv i cells + @ + env env/set + loop + env ; + +MalUserFn + extend eval-invoke { call-env list mal-fn -- list } + mal-fn MalUserFn/is-macro? @ if + list MalList/start @ cell+ \ argv + list MalList/count @ 1- \ argc + mal-fn new-user-fn-env { env } + env mal-fn MalUserFn/body @ eval + call-env swap TCO-eval + else + call-env list eval-rest + mal-fn invoke + endif ;; + + extend invoke ( argv argc mal-fn ) + dup { mal-fn } new-user-fn-env { env } + env mal-fn MalUserFn/body @ TCO-eval ;; +drop + +defspecial fn* { env list -- val } + list MalList/start @ cell+ { arg0 } + MalUserFn new + false over MalUserFn/is-macro? ! + env over MalUserFn/env ! + arg0 @ to-list over MalUserFn/formal-args ! + arg0 cell+ @ over MalUserFn/body ! ;; + +defspecial macroexpand ( env list[_,form] -- form ) + MalList/start @ cell+ @ swap over ( form env form ) + MalList/start @ @ ( form env macro-name-expr ) + eval { macro-fn } ( form ) + dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn ) + new-user-fn-env ( env ) + macro-fn MalUserFn/body @ TCO-eval ;; + +5555555555 constant pre-try + +defspecial try* { env list -- val } + list MalList/start @ cell+ { arg0 } + list MalList/count @ 3 < if + env arg0 @ eval + else + pre-try + env arg0 @ ['] eval catch ?dup 0= if + nip + else { errno } + begin pre-try = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + arg0 cell+ @ ( list[catch*,sym,form] ) + MalList/start @ cell+ { catch0 } + env MalEnv. { catch-env } + catch0 @ exception-object catch-env env/set + catch-env catch0 cell+ @ TCO-eval + endif + endif ;; + +MalSymbol + extend mal-eval { env sym -- val } + sym env env/get-addr + dup 0= if + drop + 0 0 s" ' not found" sym pr-str s" '" ...throw-str + else + @ + endif ;; +drop + +: eval-ast { env list -- list } + here + list MalList/start @ { expr-start } + list MalList/count @ 0 ?do + env expr-start i cells + @ eval , + loop + here>MalList ; + +MalList + extend mal-eval { env list -- val } + list MalList/count @ 0= if + list + else + env list MalList/start @ @ eval + env list rot eval-invoke + endif ;; +drop + +MalVector + extend mal-eval ( env vector -- vector ) + MalVector/list @ eval-ast + MalVector new swap over MalVector/list ! ;; +drop + +MalMap + extend mal-eval ( env map -- map ) + MalMap/list @ eval-ast + MalMap new swap over MalMap/list ! ;; +drop + +defcore eval ( argv argc ) + drop @ repl-env swap eval ;; + +: rep ( str-addr str-len -- str-addr str-len ) + read + repl-env swap eval + print ; + +: mk-args-list ( -- ) + here + begin + next-arg 2dup 0 0 d<> while + MalString. , + repeat + 2drop here>MalList ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +: nop ; + +defcore swap! { argv argc -- val } + \ argv is (atom fn args...) + argv @ { atom } + argv cell+ @ { fn } + argc 1- { call-argc } + call-argc cells allocate throw { call-argv } + atom Atom/val call-argv 1 cells cmove + argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove + call-argv call-argc fn invoke + dup TCO-eval = if drop eval endif { new-val } + new-val atom Atom/val ! + new-val ;; + +defcore map ( argv argc -- list ) + drop dup @ swap cell+ @ to-list { fn list } + here + list MalList/start @ list MalList/count @ cells over + swap +do + i 1 fn invoke + dup TCO-eval = if drop eval endif + , + cell +loop + here>MalList ;; + +s\" (def! not (fn* (x) (if x false true)))" rep 2drop +s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop +s\" (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 2drop + +: repl ( -- ) + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +: main ( -- ) + mk-args-list { args-list } + args-list MalList/count @ 0= if + s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set + repl + else + args-list MalList/start @ @ { filename } + s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set + + repl-env + here s" load-file" MalSymbol. , filename , here>MalList + eval print + endif ; + +main +cr +bye diff --git a/impls/forth/stepA_mal.fs b/impls/forth/stepA_mal.fs index bcf08ff460..09b0f6bd71 100644 --- a/impls/forth/stepA_mal.fs +++ b/impls/forth/stepA_mal.fs @@ -1,434 +1,434 @@ -require reader.fs -require printer.fs -require core.fs - -core MalEnv. constant repl-env - -99999999 constant TCO-eval - -: read read-str ; -: eval ( env obj ) - begin - \ ." eval-> " dup pr-str safe-type cr - mal-eval - dup TCO-eval = - while - drop - repeat ; -: print - \ ." Type: " dup mal-type @ type-name safe-type cr - pr-str ; - -MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself - -MalKeyword - extend eval-invoke { env list kw -- val } - 0 kw env list MalList/start @ cell+ @ eval get - ?dup 0= if - \ compute not-found value - list MalList/count @ 1 > if - env list MalList/start @ 2 cells + @ TCO-eval - else - mal-nil - endif - endif ;; - extend invoke { argv argc kw -- val } - 0 kw argv @ get - ?dup 0= if - argc 1 > if - argv cell+ @ - else - mal-nil - endif - endif ;; -drop - -\ eval all but the first item of list -: eval-rest { env list -- argv argc } - list MalList/start @ cell+ { expr-start } - list MalList/count @ 1- { argc } - argc cells allocate throw { target } - argc 0 ?do - env expr-start i cells + @ eval - target i cells + ! - loop - target argc ; - -MalNativeFn - extend eval-invoke { env list this -- list } - env list eval-rest ( argv argc ) - this invoke ;; - extend invoke ( argv argc this -- val ) - MalNativeFn/xt @ execute ;; -drop - -SpecialOp - extend eval-invoke ( env list this -- list ) - SpecialOp/xt @ execute ;; -drop - -: install-special ( symbol xt ) - SpecialOp. repl-env env/set ; - -: defspecial - parse-allot-name MalSymbol. - ['] install-special - :noname - ; - -defspecial quote ( env list -- form ) - nip MalList/start @ cell+ @ ;; - -s" concat" MalSymbol. constant concat-sym -s" cons" MalSymbol. constant cons-sym -s" vec" MalSymbol. constant vec-sym - -defer quasiquote - -( If the list has two elements and the first is sym, return the second ) -( element and true, else return the list unchanged and false. ) -: qq_extract_unquote ( list symbol -- form f ) - over MalList/count @ 2 = if - over MalList/start @ tuck @ m= if ( list start - ) - cell+ @ - nip - true - exit - endif - endif - drop - false ; - -( Transition function for the following quasiquote folder. ) -: qq_loop ( acc elt -- form ) - dup mal-type @ MalList = if - splice-unquote-sym qq_extract_unquote if - here concat-sym , swap , swap , here>MalList - exit - endif - endif - quasiquote - here cons-sym , swap , swap , here>MalList ; - -( Right-fold quasiquoting each element of a list. ) -: qq_foldr ( list -- form ) - dup MalList/count @ if - dup MalList/rest recurse - swap MalList/start @ @ - qq_loop - endif ; - -: quasiquote0 ( ast -- form ) - dup mal-type @ case - MalList of - unquote-sym qq_extract_unquote if - ( the work is already done ) - else - qq_foldr - endif - endof - MalVector of - MalVector/list @ qq_foldr - here vec-sym , swap , here>MalList - endof - MalSymbol of - here quote-sym , swap , here>MalList - endof - MalMap of - here quote-sym , swap , here>MalList - endof - ( other types are returned unchanged ) - endcase ; -' quasiquote0 is quasiquote - -defspecial quasiquoteexpand ( env list -- form ) - nip MalList/start @ cell+ @ quasiquote ;; - -defspecial quasiquote ( env list ) - MalList/start @ cell+ @ ( ast ) - quasiquote TCO-eval ;; - -defspecial def! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval dup { val } ( key val ) - env env/set val ;; - -defspecial defmacro! { env list -- val } - list MalList/start @ cell+ { arg0 } - arg0 @ ( key ) - env arg0 cell+ @ eval { val } - true val MalUserFn/is-macro? ! - val env env/set - val ;; - -defspecial let* { old-env list -- val } - old-env MalEnv. { env } - list MalList/start @ cell+ dup { arg0 } - @ to-list - dup MalList/start @ { bindings-start } ( list ) - MalList/count @ 0 +do - bindings-start i cells + dup @ swap cell+ @ ( sym expr ) - env swap eval - env env/set - 2 +loop - env arg0 cell+ @ TCO-eval - \ TODO: dec refcount of env - ;; - -defspecial do { env list -- val } - list MalList/start @ { start } - list MalList/count @ dup 1- { last } 1 ?do - env start i cells + @ - i last = if - TCO-eval - else - eval drop - endif - loop ;; - -defspecial if { env list -- val } - list MalList/start @ cell+ { arg0 } - env arg0 @ eval ( test-val ) - dup mal-false = if - drop -1 - else - mal-nil = - endif - if - \ branch to false - list MalList/count @ 3 > if - env arg0 cell+ cell+ @ TCO-eval - else - mal-nil - endif - else - \ branch to true - env arg0 cell+ @ TCO-eval - endif ;; - -s" &" MalSymbol. constant &-sym - -: new-user-fn-env { argv argc mal-fn -- env } - mal-fn MalUserFn/formal-args @ { f-args-list } - mal-fn MalUserFn/env @ MalEnv. { env } - - f-args-list MalList/start @ { f-args } - f-args-list MalList/count @ ?dup 0= if else - \ pass empty list for last arg, unless overridden below - 1- cells f-args + @ MalList new env env/set - endif - argc 0 ?do - f-args i cells + @ - dup &-sym m= if - drop - argc i - { c } - c cells allocate throw { start } - argv i cells + start c cells cmove - f-args i 1+ cells + @ ( more-args-symbol ) - start c MalList. env env/set - leave - endif - argv i cells + @ - env env/set - loop - env ; - -MalUserFn - extend eval-invoke { call-env list mal-fn -- list } - mal-fn MalUserFn/is-macro? @ if - list MalList/start @ cell+ \ argv - list MalList/count @ 1- \ argc - mal-fn new-user-fn-env { env } - env mal-fn MalUserFn/body @ eval - call-env swap TCO-eval - else - call-env list eval-rest - mal-fn invoke - endif ;; - - extend invoke ( argv argc mal-fn ) - dup { mal-fn } new-user-fn-env { env } - env mal-fn MalUserFn/body @ TCO-eval ;; -drop - -defspecial fn* { env list -- val } - list MalList/start @ cell+ { arg0 } - MalUserFn new - false over MalUserFn/is-macro? ! - env over MalUserFn/env ! - arg0 @ to-list over MalUserFn/formal-args ! - arg0 cell+ @ over MalUserFn/body ! ;; - -defspecial macroexpand ( env list[_,form] -- form ) - MalList/start @ cell+ @ swap over ( form env form ) - MalList/start @ @ ( form env macro-name-expr ) - eval { macro-fn } ( form ) - dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn ) - new-user-fn-env ( env ) - macro-fn MalUserFn/body @ TCO-eval ;; - -5555555555 constant pre-try - -defspecial try* { env list -- val } - list MalList/start @ cell+ { arg0 } - list MalList/count @ 3 < if - env arg0 @ eval - else - pre-try - env arg0 @ ['] eval catch ?dup 0= if - nip - else { errno } - begin pre-try = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - arg0 cell+ @ ( list[catch*,sym,form] ) - MalList/start @ cell+ { catch0 } - env MalEnv. { catch-env } - catch0 @ exception-object catch-env env/set - catch-env catch0 cell+ @ TCO-eval - endif - endif ;; - -defspecial . { env coll -- rtn-list } - depth { old-depth } - coll to-list dup MalList/count @ swap MalList/start @ { count start } - count cells start + start cell+ +do - env i @ eval as-native - cell +loop ;; - -MalSymbol - extend mal-eval { env sym -- val } - sym env env/get-addr - dup 0= if - drop - 0 0 s" ' not found" sym pr-str s" '" ...throw-str - else - @ - endif ;; -drop - -: eval-ast { env list -- list } - here - list MalList/start @ { expr-start } - list MalList/count @ 0 ?do - env expr-start i cells + @ eval , - loop - here>MalList ; - -MalList - extend mal-eval { env list -- val } - list MalList/count @ 0= if - list - else - env list MalList/start @ @ eval - env list rot eval-invoke - endif ;; -drop - -MalVector - extend mal-eval ( env vector -- vector ) - MalVector/list @ eval-ast - MalVector new swap over MalVector/list ! ;; -drop - -MalMap - extend mal-eval ( env map -- map ) - MalMap/list @ eval-ast - MalMap new swap over MalMap/list ! ;; -drop - -defcore eval ( argv argc ) - drop @ repl-env swap eval ;; - -: rep ( str-addr str-len -- str-addr str-len ) - read - repl-env swap eval - print ; - -: mk-args-list ( -- ) - here - begin - next-arg 2dup 0 0 d<> while - MalString. , - repeat - 2drop here>MalList ; - -create buff 128 allot -77777777777 constant stack-leak-detect - -: nop ; - -defcore swap! { argv argc -- val } - \ argv is (atom fn args...) - argv @ { atom } - argv cell+ @ { fn } - argc 1- { call-argc } - call-argc cells allocate throw { call-argv } - atom Atom/val call-argv 1 cells cmove - argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove - call-argv call-argc fn invoke - dup TCO-eval = if drop eval endif { new-val } - new-val atom Atom/val ! - new-val ;; - -defcore map ( argv argc -- list ) - drop dup @ swap cell+ @ to-list { fn list } - here - list MalList/start @ list MalList/count @ cells over + swap +do - i 1 fn invoke - dup TCO-eval = if drop eval endif - , - cell +loop - here>MalList ;; - -s\" (def! *host-language* \"forth\")" rep 2drop -s\" (def! not (fn* (x) (if x false true)))" rep 2drop -s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop -s\" (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 2drop - -: repl ( -- ) - s\" (println (str \"Mal [\" *host-language* \"]\"))" rep 2drop - begin - ." user> " - stack-leak-detect - buff 128 stdin read-line throw - while ( num-bytes-read ) - dup 0 <> if - buff swap ( str-addr str-len ) - ['] rep - \ execute ['] nop \ uncomment to see stack traces - catch ?dup 0= if - safe-type cr - stack-leak-detect <> if ." --stack leak--" cr endif - else { errno } - begin stack-leak-detect = until - errno 1 <> if - s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc - to exception-object - endif - ." Uncaught exception: " - exception-object pr-str safe-type cr - endif - endif - repeat ; - -: main ( -- ) - mk-args-list { args-list } - args-list MalList/count @ 0= if - s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set - repl - else - args-list MalList/start @ @ { filename } - s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set - - repl-env - here s" load-file" MalSymbol. , filename , here>MalList - eval print - endif ; - -main -cr -bye +require reader.fs +require printer.fs +require core.fs + +core MalEnv. constant repl-env + +99999999 constant TCO-eval + +: read read-str ; +: eval ( env obj ) + begin + \ ." eval-> " dup pr-str safe-type cr + mal-eval + dup TCO-eval = + while + drop + repeat ; +: print + \ ." Type: " dup mal-type @ type-name safe-type cr + pr-str ; + +MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself + +MalKeyword + extend eval-invoke { env list kw -- val } + 0 kw env list MalList/start @ cell+ @ eval get + ?dup 0= if + \ compute not-found value + list MalList/count @ 1 > if + env list MalList/start @ 2 cells + @ TCO-eval + else + mal-nil + endif + endif ;; + extend invoke { argv argc kw -- val } + 0 kw argv @ get + ?dup 0= if + argc 1 > if + argv cell+ @ + else + mal-nil + endif + endif ;; +drop + +\ eval all but the first item of list +: eval-rest { env list -- argv argc } + list MalList/start @ cell+ { expr-start } + list MalList/count @ 1- { argc } + argc cells allocate throw { target } + argc 0 ?do + env expr-start i cells + @ eval + target i cells + ! + loop + target argc ; + +MalNativeFn + extend eval-invoke { env list this -- list } + env list eval-rest ( argv argc ) + this invoke ;; + extend invoke ( argv argc this -- val ) + MalNativeFn/xt @ execute ;; +drop + +SpecialOp + extend eval-invoke ( env list this -- list ) + SpecialOp/xt @ execute ;; +drop + +: install-special ( symbol xt ) + SpecialOp. repl-env env/set ; + +: defspecial + parse-allot-name MalSymbol. + ['] install-special + :noname + ; + +defspecial quote ( env list -- form ) + nip MalList/start @ cell+ @ ;; + +s" concat" MalSymbol. constant concat-sym +s" cons" MalSymbol. constant cons-sym +s" vec" MalSymbol. constant vec-sym + +defer quasiquote + +( If the list has two elements and the first is sym, return the second ) +( element and true, else return the list unchanged and false. ) +: qq_extract_unquote ( list symbol -- form f ) + over MalList/count @ 2 = if + over MalList/start @ tuck @ m= if ( list start - ) + cell+ @ + nip + true + exit + endif + endif + drop + false ; + +( Transition function for the following quasiquote folder. ) +: qq_loop ( acc elt -- form ) + dup mal-type @ MalList = if + splice-unquote-sym qq_extract_unquote if + here concat-sym , swap , swap , here>MalList + exit + endif + endif + quasiquote + here cons-sym , swap , swap , here>MalList ; + +( Right-fold quasiquoting each element of a list. ) +: qq_foldr ( list -- form ) + dup MalList/count @ if + dup MalList/rest recurse + swap MalList/start @ @ + qq_loop + endif ; + +: quasiquote0 ( ast -- form ) + dup mal-type @ case + MalList of + unquote-sym qq_extract_unquote if + ( the work is already done ) + else + qq_foldr + endif + endof + MalVector of + MalVector/list @ qq_foldr + here vec-sym , swap , here>MalList + endof + MalSymbol of + here quote-sym , swap , here>MalList + endof + MalMap of + here quote-sym , swap , here>MalList + endof + ( other types are returned unchanged ) + endcase ; +' quasiquote0 is quasiquote + +defspecial quasiquoteexpand ( env list -- form ) + nip MalList/start @ cell+ @ quasiquote ;; + +defspecial quasiquote ( env list ) + MalList/start @ cell+ @ ( ast ) + quasiquote TCO-eval ;; + +defspecial def! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval dup { val } ( key val ) + env env/set val ;; + +defspecial defmacro! { env list -- val } + list MalList/start @ cell+ { arg0 } + arg0 @ ( key ) + env arg0 cell+ @ eval { val } + true val MalUserFn/is-macro? ! + val env env/set + val ;; + +defspecial let* { old-env list -- val } + old-env MalEnv. { env } + list MalList/start @ cell+ dup { arg0 } + @ to-list + dup MalList/start @ { bindings-start } ( list ) + MalList/count @ 0 +do + bindings-start i cells + dup @ swap cell+ @ ( sym expr ) + env swap eval + env env/set + 2 +loop + env arg0 cell+ @ TCO-eval + \ TODO: dec refcount of env + ;; + +defspecial do { env list -- val } + list MalList/start @ { start } + list MalList/count @ dup 1- { last } 1 ?do + env start i cells + @ + i last = if + TCO-eval + else + eval drop + endif + loop ;; + +defspecial if { env list -- val } + list MalList/start @ cell+ { arg0 } + env arg0 @ eval ( test-val ) + dup mal-false = if + drop -1 + else + mal-nil = + endif + if + \ branch to false + list MalList/count @ 3 > if + env arg0 cell+ cell+ @ TCO-eval + else + mal-nil + endif + else + \ branch to true + env arg0 cell+ @ TCO-eval + endif ;; + +s" &" MalSymbol. constant &-sym + +: new-user-fn-env { argv argc mal-fn -- env } + mal-fn MalUserFn/formal-args @ { f-args-list } + mal-fn MalUserFn/env @ MalEnv. { env } + + f-args-list MalList/start @ { f-args } + f-args-list MalList/count @ ?dup 0= if else + \ pass empty list for last arg, unless overridden below + 1- cells f-args + @ MalList new env env/set + endif + argc 0 ?do + f-args i cells + @ + dup &-sym m= if + drop + argc i - { c } + c cells allocate throw { start } + argv i cells + start c cells cmove + f-args i 1+ cells + @ ( more-args-symbol ) + start c MalList. env env/set + leave + endif + argv i cells + @ + env env/set + loop + env ; + +MalUserFn + extend eval-invoke { call-env list mal-fn -- list } + mal-fn MalUserFn/is-macro? @ if + list MalList/start @ cell+ \ argv + list MalList/count @ 1- \ argc + mal-fn new-user-fn-env { env } + env mal-fn MalUserFn/body @ eval + call-env swap TCO-eval + else + call-env list eval-rest + mal-fn invoke + endif ;; + + extend invoke ( argv argc mal-fn ) + dup { mal-fn } new-user-fn-env { env } + env mal-fn MalUserFn/body @ TCO-eval ;; +drop + +defspecial fn* { env list -- val } + list MalList/start @ cell+ { arg0 } + MalUserFn new + false over MalUserFn/is-macro? ! + env over MalUserFn/env ! + arg0 @ to-list over MalUserFn/formal-args ! + arg0 cell+ @ over MalUserFn/body ! ;; + +defspecial macroexpand ( env list[_,form] -- form ) + MalList/start @ cell+ @ swap over ( form env form ) + MalList/start @ @ ( form env macro-name-expr ) + eval { macro-fn } ( form ) + dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn ) + new-user-fn-env ( env ) + macro-fn MalUserFn/body @ TCO-eval ;; + +5555555555 constant pre-try + +defspecial try* { env list -- val } + list MalList/start @ cell+ { arg0 } + list MalList/count @ 3 < if + env arg0 @ eval + else + pre-try + env arg0 @ ['] eval catch ?dup 0= if + nip + else { errno } + begin pre-try = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + arg0 cell+ @ ( list[catch*,sym,form] ) + MalList/start @ cell+ { catch0 } + env MalEnv. { catch-env } + catch0 @ exception-object catch-env env/set + catch-env catch0 cell+ @ TCO-eval + endif + endif ;; + +defspecial . { env coll -- rtn-list } + depth { old-depth } + coll to-list dup MalList/count @ swap MalList/start @ { count start } + count cells start + start cell+ +do + env i @ eval as-native + cell +loop ;; + +MalSymbol + extend mal-eval { env sym -- val } + sym env env/get-addr + dup 0= if + drop + 0 0 s" ' not found" sym pr-str s" '" ...throw-str + else + @ + endif ;; +drop + +: eval-ast { env list -- list } + here + list MalList/start @ { expr-start } + list MalList/count @ 0 ?do + env expr-start i cells + @ eval , + loop + here>MalList ; + +MalList + extend mal-eval { env list -- val } + list MalList/count @ 0= if + list + else + env list MalList/start @ @ eval + env list rot eval-invoke + endif ;; +drop + +MalVector + extend mal-eval ( env vector -- vector ) + MalVector/list @ eval-ast + MalVector new swap over MalVector/list ! ;; +drop + +MalMap + extend mal-eval ( env map -- map ) + MalMap/list @ eval-ast + MalMap new swap over MalMap/list ! ;; +drop + +defcore eval ( argv argc ) + drop @ repl-env swap eval ;; + +: rep ( str-addr str-len -- str-addr str-len ) + read + repl-env swap eval + print ; + +: mk-args-list ( -- ) + here + begin + next-arg 2dup 0 0 d<> while + MalString. , + repeat + 2drop here>MalList ; + +create buff 128 allot +77777777777 constant stack-leak-detect + +: nop ; + +defcore swap! { argv argc -- val } + \ argv is (atom fn args...) + argv @ { atom } + argv cell+ @ { fn } + argc 1- { call-argc } + call-argc cells allocate throw { call-argv } + atom Atom/val call-argv 1 cells cmove + argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove + call-argv call-argc fn invoke + dup TCO-eval = if drop eval endif { new-val } + new-val atom Atom/val ! + new-val ;; + +defcore map ( argv argc -- list ) + drop dup @ swap cell+ @ to-list { fn list } + here + list MalList/start @ list MalList/count @ cells over + swap +do + i 1 fn invoke + dup TCO-eval = if drop eval endif + , + cell +loop + here>MalList ;; + +s\" (def! *host-language* \"forth\")" rep 2drop +s\" (def! not (fn* (x) (if x false true)))" rep 2drop +s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop +s\" (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 2drop + +: repl ( -- ) + s\" (println (str \"Mal [\" *host-language* \"]\"))" rep 2drop + begin + ." user> " + stack-leak-detect + buff 128 stdin read-line throw + while ( num-bytes-read ) + dup 0 <> if + buff swap ( str-addr str-len ) + ['] rep + \ execute ['] nop \ uncomment to see stack traces + catch ?dup 0= if + safe-type cr + stack-leak-detect <> if ." --stack leak--" cr endif + else { errno } + begin stack-leak-detect = until + errno 1 <> if + s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc + to exception-object + endif + ." Uncaught exception: " + exception-object pr-str safe-type cr + endif + endif + repeat ; + +: main ( -- ) + mk-args-list { args-list } + args-list MalList/count @ 0= if + s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set + repl + else + args-list MalList/start @ @ { filename } + s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set + + repl-env + here s" load-file" MalSymbol. , filename , here>MalList + eval print + endif ; + +main +cr +bye diff --git a/impls/forth/str.fs b/impls/forth/str.fs index 20aef32da9..8a71a66318 100644 --- a/impls/forth/str.fs +++ b/impls/forth/str.fs @@ -1,73 +1,73 @@ -: safe-type ( str-addr str-len -- ) - dup 256 > if - drop 256 type ." ..." - else - type - endif ; - -\ === mutable string buffer === / -\ string buffer that maintains an allocation larger than the current -\ string size. When appending would cause the string size exceed the -\ current allocation, resize is used to double the allocation. The -\ current allocation is not stored anywhere, but computed based on -\ current string size or str-base-size, whichever is larger. -64 constant str-base-size - -: new-str ( -- addr length ) - str-base-size allocate throw 0 ; - -: round-up ( n -- n ) - 2 - begin - 1 lshift 2dup < - until - nip ; - -: str-append { buf-addr buf-str-len str-addr str-len } - buf-str-len str-len + - { new-len } - new-len str-base-size >= if - buf-str-len new-len xor buf-str-len > if - buf-addr new-len round-up resize throw - to buf-addr - endif - endif - str-addr buf-addr buf-str-len + str-len cmove - buf-addr new-len ; - -\ define a-space, to append a space char to a string -bl c, -here constant space-str -: a-space space-str 1 str-append ; - -: str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len ) - pad ! pad 1 str-append ; - -\ from gforth docs, there named 'my-.' -: int>str ( num -- str-addr str-len ) - \ handling negatives.. behaves like Standard . - s>d \ convert to signed double - swap over dabs \ leave sign byte followed by unsigned double - <<# \ start conversion - #s \ convert all digits - rot sign \ get at sign byte, append "-" if needed - #> \ complete conversion - #>> ; \ release hold area - -defer MalString. - -: ...str - new-str - begin - 2swap - over 0 <> - while - str-append - repeat - 2drop MalString. ; - -nil value exception-object - -: ...throw-str - ...str to exception-object - 1 throw ; +: safe-type ( str-addr str-len -- ) + dup 256 > if + drop 256 type ." ..." + else + type + endif ; + +\ === mutable string buffer === / +\ string buffer that maintains an allocation larger than the current +\ string size. When appending would cause the string size exceed the +\ current allocation, resize is used to double the allocation. The +\ current allocation is not stored anywhere, but computed based on +\ current string size or str-base-size, whichever is larger. +64 constant str-base-size + +: new-str ( -- addr length ) + str-base-size allocate throw 0 ; + +: round-up ( n -- n ) + 2 + begin + 1 lshift 2dup < + until + nip ; + +: str-append { buf-addr buf-str-len str-addr str-len } + buf-str-len str-len + + { new-len } + new-len str-base-size >= if + buf-str-len new-len xor buf-str-len > if + buf-addr new-len round-up resize throw + to buf-addr + endif + endif + str-addr buf-addr buf-str-len + str-len cmove + buf-addr new-len ; + +\ define a-space, to append a space char to a string +bl c, +here constant space-str +: a-space space-str 1 str-append ; + +: str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len ) + pad ! pad 1 str-append ; + +\ from gforth docs, there named 'my-.' +: int>str ( num -- str-addr str-len ) + \ handling negatives.. behaves like Standard . + s>d \ convert to signed double + swap over dabs \ leave sign byte followed by unsigned double + <<# \ start conversion + #s \ convert all digits + rot sign \ get at sign byte, append "-" if needed + #> \ complete conversion + #>> ; \ release hold area + +defer MalString. + +: ...str + new-str + begin + 2swap + over 0 <> + while + str-append + repeat + 2drop MalString. ; + +nil value exception-object + +: ...throw-str + ...str to exception-object + 1 throw ; diff --git a/impls/forth/tests/step5_tco.mal b/impls/forth/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/forth/tests/step5_tco.mal +++ b/impls/forth/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/forth/tests/stepA_mal.mal b/impls/forth/tests/stepA_mal.mal index 3d8db0565b..4a880b26fd 100644 --- a/impls/forth/tests/stepA_mal.mal +++ b/impls/forth/tests/stepA_mal.mal @@ -1,41 +1,41 @@ -;; Basic interop -(. 5 'MalInt.) -;=>5 -(. 11 31 '+ 'MalInt.) -;=>42 -(. "greetings" 'MalString.) -;=>"greetings" -(. "hello" 'type 'cr 'mal-nil) -;/hello -;=>nil - -;; Interop on non-literals -(. (+ 15 27) 'MalInt.) -;=>42 -(let* [a 17] (. a 25 '+ 'MalInt.)) -;=>42 -(let* [a "hello"] (. a 1 '- 'MalString.)) -;=>"hell" - -;; Use of annoyingly-named forth words -(. 1 'MalInt. (symbol ",") 'here (symbol "@")) -;=>1 -(let* (i 'MalInt.) (. 5 i)) -;=>5 -(let* (comma (symbol ",") fetch (symbol "@")) (. 'here 42 'MalInt. comma fetch)) -;=>42 - -;; Multiple .-forms interacting via heap memory and mal locals -(def! string-parts (fn* (s) (. s 'MalInt. 'swap 'MalInt. 'here '-rot (symbol ",") (symbol ",") 'here>MalList))) -(first (rest (string-parts "sketchy"))) -;=>7 -(def! prn-chars (fn* (start count) (if (> count 0) (do (prn (. start 1 'MalString.)) (prn-chars (+ start 1) (- count 1)))))) -(let* (msg (string-parts "sketchy")) (prn-chars (first msg) (first (rest msg)))) -;/"s" -;/"k" -;/"e" -;/"t" -;/"c" -;/"h" -;/"y" -;=>nil +;; Basic interop +(. 5 'MalInt.) +;=>5 +(. 11 31 '+ 'MalInt.) +;=>42 +(. "greetings" 'MalString.) +;=>"greetings" +(. "hello" 'type 'cr 'mal-nil) +;/hello +;=>nil + +;; Interop on non-literals +(. (+ 15 27) 'MalInt.) +;=>42 +(let* [a 17] (. a 25 '+ 'MalInt.)) +;=>42 +(let* [a "hello"] (. a 1 '- 'MalString.)) +;=>"hell" + +;; Use of annoyingly-named forth words +(. 1 'MalInt. (symbol ",") 'here (symbol "@")) +;=>1 +(let* (i 'MalInt.) (. 5 i)) +;=>5 +(let* (comma (symbol ",") fetch (symbol "@")) (. 'here 42 'MalInt. comma fetch)) +;=>42 + +;; Multiple .-forms interacting via heap memory and mal locals +(def! string-parts (fn* (s) (. s 'MalInt. 'swap 'MalInt. 'here '-rot (symbol ",") (symbol ",") 'here>MalList))) +(first (rest (string-parts "sketchy"))) +;=>7 +(def! prn-chars (fn* (start count) (if (> count 0) (do (prn (. start 1 'MalString.)) (prn-chars (+ start 1) (- count 1)))))) +(let* (msg (string-parts "sketchy")) (prn-chars (first msg) (first (rest msg)))) +;/"s" +;/"k" +;/"e" +;/"t" +;/"c" +;/"h" +;/"y" +;=>nil diff --git a/impls/forth/types.fs b/impls/forth/types.fs index 5d3faec346..3b9627cfe2 100644 --- a/impls/forth/types.fs +++ b/impls/forth/types.fs @@ -1,669 +1,669 @@ -require str.fs - -\ === sorted-array === / -\ Here are a few utility functions useful for creating and maintaining -\ the deftype* method tables. The keys array is kept in sorted order, -\ and the methods array is maintained in parallel so that an index into -\ one corresponds to an index in the other. - -\ Search a sorted array for key, returning the index of where it was -\ found. If key is not in the array, return the index where it would -\ be if added. -: array-find { a-length a-addr key -- index found? } - 0 a-length ( start end ) - begin - \ cr 2dup . . - 2dup + 2 / dup ( start end middle middle ) - cells a-addr + @ ( start end middle mid-val ) - dup key < if - drop rot ( end middle start ) - 2dup = if - 2drop dup ( end end ) - else - drop swap ( middle end ) - endif - else - key > if ( start end middle ) - nip ( start middle ) - else - -rot 2drop dup ( middle middle ) - endif - endif - 2dup = until - dup a-length = if - drop false - else - cells a-addr + @ key = - endif ; - -\ Create a new array, one cell in length, initialized the provided value -: new-array { value -- array } - cell allocate throw value over ! ; - -\ Resize a heap-allocated array to be one cell longer, inserting value -\ at idx, and shifting the tail of the array as necessary. Returns the -\ (possibly new) array address -: array-insert { old-array-length old-array idx value -- array } - old-array old-array-length 1+ cells resize throw - { a } - a idx cells + dup cell+ old-array-length idx - cells cmove> - value a idx cells + ! - a - ; - - -\ === deftype* -- protocol-enabled structs === / -\ Each type has MalTypeType% struct allocated on the stack, with -\ mutable fields pointing to all class-shared resources, specifically -\ the data needed to allocate new instances, and the table of protocol -\ methods that have been extended to the type. -\ Use 'deftype*' to define a new type, and 'new' to create new -\ instances of that type. - -struct - cell% field mal-type - cell% field mal-meta - \ cell% field ref-count \ Ha, right. -end-struct MalType% - -struct - cell% 2 * field MalTypeType-struct - cell% field MalTypeType-methods - cell% field MalTypeType-method-keys - cell% field MalTypeType-method-vals - cell% field MalTypeType-name-addr - cell% field MalTypeType-name-len -end-struct MalTypeType% - -: new ( MalTypeType -- obj ) - dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct - dup -rot mal-type ! ( obj ) \ set struct's type pointer to this type - nil over mal-meta ! - ; - -: deftype* ( struct-align struct-len -- MalTypeType ) - MalTypeType% %allot ( s-a s-l MalTypeType ) - dup 2swap rot ( MalTypeType s-a s-l MalTypeType ) - MalTypeType-struct 2! ( MalTypeType ) \ store struct info - dup MalTypeType-methods 0 swap ! ( MalTypeType ) - dup MalTypeType-method-keys nil swap ! ( MalTypeType ) - dup MalTypeType-method-vals nil swap ! ( MalTypeType ) - dup MalTypeType-name-len 0 swap ! ( MalTypeType ) - ; - -\ parse-name uses temporary space, so copy into dictionary stack: -: parse-allot-name { -- new-str-addr str-len } - parse-name { str-addr str-len } - here { new-str-addr } str-len allot - str-addr new-str-addr str-len cmove - new-str-addr str-len ; - -: deftype ( struct-align struct-len R:type-name -- ) - parse-allot-name { name-addr name-len } - - \ allot and initialize type structure - deftype* { mt } - name-addr mt MalTypeType-name-addr ! - name-len mt MalTypeType-name-len ! - \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr - mt name-addr name-len nextname 1 0 const-does> ; - -: type-name ( mal-type ) - dup MalTypeType-name-addr @ ( mal-type name-addr ) - swap MalTypeType-name-len @ ( name-addr name-len ) - ; - -MalType% deftype MalDefault - -\ nil type and instance to support extending protocols to it -MalType% deftype MalNil MalNil new constant mal-nil -MalType% deftype MalTrue MalTrue new constant mal-true -MalType% deftype MalFalse MalFalse new constant mal-false - -: mal-bool - 0= if mal-false else mal-true endif ; - -: not-object? ( obj -- bool ) - dup 7 and 0 <> if - drop true - else - 1000000 < - endif ; - -\ === protocol methods === / - -struct - cell% field call-site/type - cell% field call-site/xt -end-struct call-site% - -\ Used by protocol methods to find the appropriate implementation of -\ themselves for the given object, and then execute that implementation. -: execute-method { obj pxt call-site -- } - obj not-object? if - 0 0 obj int>str s" ' on non-object: " pxt >name name>string - s" Refusing to invoke protocol fn '" ...throw-str - endif - \ ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type ." , cs " call-site . - - obj mal-type @ ( type ) - dup call-site call-site/type @ = if - \ ." hit!" cr - drop - call-site call-site/xt @ - else - \ ." miss!" cr - dup MalTypeType-methods 2@ swap ( type methods method-keys ) - dup 0= if \ No protocols extended to this type; check for a default - 2drop drop MalDefault MalTypeType-methods 2@ swap - endif - - pxt array-find ( type idx found? ) - dup 0= if \ No implementation found for this method; check for a default - 2drop drop MalDefault dup MalTypeType-methods 2@ swap - pxt array-find ( type idx found? ) - endif - 0= if ( type idx ) - 2drop - 0 0 s" '" obj mal-type @ type-name s" ' extended to type '" - pxt >name name>string s" No protocol fn '" ...throw-str - endif - - cells over MalTypeType-method-vals @ + @ ( type xt ) - swap call-site call-site/type ! ( xt ) - dup call-site call-site/xt ! ( xt ) - endif - obj swap execute ; - -\ Extend a type with a protocol method. This mutates the MalTypeType -\ object that represents the MalType being extended. -: extend-method* { type pxt ixt -- type } - \ ." Extend '" pxt dup . >name name>string safe-type ." ' to " type type-name safe-type ." , " - \ type MalTypeType-methods 2@ ( method-keys methods ) - \ 0 ?do - \ dup i cells + @ >name name>string safe-type ." , " - \ \ dup i cells + @ . - \ loop - \ drop cr - - type MalTypeType-methods 2@ swap ( methods method-keys ) - dup 0= if \ no protocols extended to this type - 2drop - 1 type MalTypeType-methods ! - pxt new-array type MalTypeType-method-keys ! - ixt new-array type MalTypeType-method-vals ! - else - pxt array-find { idx found? } - found? if \ overwrite - ." Warning: overwriting protocol method implementation '" - pxt >name name>string safe-type ." ' on " type type-name safe-type ." , " idx . found? . cr - - type MalTypeType-method-vals @ idx cells + ixt ! - else \ resize - type MalTypeType-methods dup @ 1+ dup rot ! ( new-count ) - 1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array ) - type MalTypeType-method-keys ! ( old-count ) - type MalTypeType-method-vals @ idx ixt array-insert ( new-array ) - type MalTypeType-method-vals ! - endif - endif - type - ; - - -\ Define a new protocol function. For example: -\ def-protocol-method pr-str -\ When called as above, defines a new word 'pr-str' and stores there its -\ own xt (known as pxt). When a usage of pr-str is compiled, it -\ allocates a call-site object on the heap and injects a reference to -\ both that and the pxt into the compilation, along with a call to -\ execute-method. Thus when pr-str runs, execute-method can check the -\ call-site object to see if the type of the target object is the same -\ as the last call for this site. If so, it executes the implementation -\ immediately. Otherwise, it searches the target type's method list and -\ if necessary MalDefault's method list. If an implementation of pxt is -\ found, it is cached in the call-site, and then executed. -: make-call-site { pxt -- } - pxt postpone literal \ transfer pxt into call site - call-site% %allocate throw dup postpone literal \ allocate call-site, push reference - \ dup ." Make cs '" pxt >name name>string type ." ' " . cr - 0 swap call-site/type ! - postpone execute-method ; - -: def-protocol-method ( parse: name -- ) - : latestxt postpone literal postpone make-call-site postpone ; immediate - ; - -: extend ( type -- type pxt install-xt ) - parse-name find-name name>int ( type pxt ) - ['] extend-method* - :noname - ; - -: ;; ( type pxt -- type ) - [compile] ; ( type pxt install-xt ixt ) - swap execute - ; immediate - -( -\ These whole-protocol names are only needed for 'satisfies?': -protocol IPrintable - def-protocol-method pr-str -end-protocol - -MalList IPrintable extend - ' pr-str :noname drop s" " ; extend-method* - - extend-method pr-str - drop s" " ;; -end-extend -) - -\ === Mal types and protocols === / - -def-protocol-method conj ( obj this -- this ) -def-protocol-method seq ( obj -- mal-list|nil ) -def-protocol-method assoc ( k v this -- this ) -def-protocol-method dissoc ( k this -- this ) -def-protocol-method get ( not-found k this -- value ) -def-protocol-method mal= ( a b -- bool ) -def-protocol-method as-native ( obj -- ) - -def-protocol-method to-list ( obj -- mal-list ) -def-protocol-method empty? ( obj -- mal-bool ) -def-protocol-method mal-count ( obj -- mal-int ) -def-protocol-method sequential? ( obj -- mal-bool ) -def-protocol-method get-map-hint ( obj -- hint ) -def-protocol-method set-map-hint! ( hint obj -- ) - - -\ Fully evalutate any Mal object: -def-protocol-method mal-eval ( env ast -- val ) - -\ Invoke an object, given whole env and unevaluated argument forms: -def-protocol-method eval-invoke ( env list obj -- ... ) - -\ Invoke a function, given parameter values -def-protocol-method invoke ( argv argc mal-fn -- ... ) - - -: m= ( a b -- bool ) - 2dup = if - 2drop true - else - mal= - endif ; - - -MalType% - cell% field MalInt/int -deftype MalInt - -: MalInt. { int -- mal-int } - MalInt new dup MalInt/int int swap ! ; - -MalInt - extend mal= ( other this -- bool ) - over mal-type @ MalInt = if - MalInt/int @ swap MalInt/int @ = - else - 2drop 0 - endif ;; - - extend as-native ( mal-int -- int ) - MalInt/int @ ;; -drop - - -MalType% - cell% field MalList/count - cell% field MalList/start -deftype MalList - -: MalList. ( start count -- mal-list ) - MalList new - swap over MalList/count ! ( start list ) - swap over MalList/start ! ( list ) ; - -: here>MalList ( old-here -- mal-list ) - here over - { bytes } ( old-here ) - MalList new bytes ( old-here mal-list bytes ) - allocate throw dup { target } over MalList/start ! ( old-here mal-list ) - bytes cell / over MalList/count ! ( old-here mal-list ) - swap target bytes cmove ( mal-list ) - 0 bytes - allot \ pop list contents from dictionary stack - ; - -: MalList/concat ( list-of-lists ) - dup MalList/start @ swap MalList/count @ { lists argc } - 0 lists argc cells + lists +do ( count ) - i @ to-list MalList/count @ + - cell +loop { count } - count cells allocate throw { start } - start lists argc cells + lists +do ( target ) - i @ to-list MalList/count @ cells 2dup i @ to-list MalList/start @ -rot ( target bytes src target bytes ) - cmove ( target bytes ) - + ( new-target ) - cell +loop - drop start count MalList. ; - -MalList - extend to-list ;; - extend sequential? drop mal-true ;; - extend conj { elem old-list -- list } - old-list MalList/count @ 1+ { new-count } - new-count cells allocate throw { new-start } - elem new-start ! - new-count 1 > if - old-list MalList/start @ new-start cell+ new-count 1- cells cmove - endif - new-start new-count MalList. ;; - extend seq - dup MalList/count @ 0= if - drop mal-nil - endif ;; - extend empty? MalList/count @ 0= mal-bool ;; - extend mal-count MalList/count @ MalInt. ;; - extend mal= - over mal-nil = if - 2drop false - else - swap to-list dup 0= if - nip - else - 2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count ) - -rot MalList/start @ swap MalList/start @ { start-b start-a } - true swap ( return-val count ) - 0 ?do - start-a i cells + @ - start-b i cells + @ - m= if else - drop false leave - endif - loop - else - drop 2drop false - endif - endif - endif ;; -drop - -MalList new 0 over MalList/count ! constant MalList/Empty - -: MalList/rest { list -- list } - list MalList/start @ cell+ - list MalList/count @ 1- - MalList. ; - - -MalType% - cell% field MalVector/list -deftype MalVector - -MalVector - extend sequential? drop mal-true ;; - extend to-list - MalVector/list @ ;; - extend empty? - MalVector/list @ - MalList/count @ 0= mal-bool ;; - extend mal-count - MalVector/list @ - MalList/count @ MalInt. ;; - extend mal= - MalVector/list @ swap m= ;; - extend conj - MalVector/list @ { elem old-list } - old-list MalList/count @ { old-count } - old-count 1+ cells allocate throw { new-start } - elem new-start old-count cells + ! - old-list MalList/start @ new-start old-count cells cmove - new-start old-count 1+ MalList. - MalVector new swap - over MalVector/list ! ;; - extend seq - MalVector/list @ seq ;; -drop - -MalType% - cell% field MalMap/list -deftype MalMap - -MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty - -: MalMap/get-addr ( k map -- addr-or-nil ) - MalMap/list @ - dup MalList/start @ - swap MalList/count @ { k start count } - true \ need to search? - k get-map-hint { hint-idx } - hint-idx -1 <> if - hint-idx count < if - hint-idx cells start + { key-addr } - key-addr @ k m= if - key-addr cell+ - nip false - endif - endif - endif - if \ search - nil ( addr ) - count cells start + start +do - i @ k m= if - drop i - dup start - cell / k set-map-hint! - cell+ leave - endif - [ 2 cells ] literal +loop - endif ; - -MalMap - extend conj ( kv map -- map ) - MalMap/list @ \ get list - over MalList/start @ cell+ @ swap conj \ add value - swap MalList/start @ @ swap conj \ add key - MalMap new dup -rot MalMap/list ! \ put back in map - ;; - extend assoc ( k v map -- map ) - MalMap/list @ \ get list - conj conj - MalMap new tuck MalMap/list ! \ put back in map - ;; - extend dissoc { k map -- map } - map MalMap/list @ - dup MalList/start @ swap MalList/count @ { start count } - map \ return original if key not found - count 0 +do - start i cells + @ k mal= if - drop here - start i MalList. , - start i 2 + cells + count i - 2 - MalList. , - here>MalList MalList/concat - MalMap new dup -rot MalMap/list ! \ put back in map - endif - 2 +loop ;; - extend get ( not-found k map -- value ) - MalMap/get-addr ( not-found addr-or-nil ) - dup 0= if drop else nip @ endif ;; - extend empty? - MalMap/list @ - MalList/count @ 0= mal-bool ;; - extend mal-count - MalMap/list @ - MalList/count @ 2 / MalInt. ;; - extend mal= { b a -- bool } - b mal-type @ MalMap = if - a MalMap/list @ MalList/count @ { a-count } - b MalMap/list @ MalList/count @ { b-count } - a-count b-count = if - a MalMap/list @ MalList/start @ { a-start } - true ( return-val ) - a-count 0 +do - a-start i cells + @ ( return-val key ) - dup a MalMap/get-addr swap b MalMap/get-addr ( return-val a-val-addr b-val-addr ) - dup 0= if - drop 2drop false leave - else - @ swap @ ( return-val b-val a-val ) - m= if else - drop false leave - endif - endif - 2 +loop - else - false - endif - else - false - endif ;; -drop - -\ Examples of extending existing protocol methods to existing type -MalDefault - extend conj ( obj this -- this ) - nip ;; - extend to-list drop 0 ;; - extend empty? drop mal-true ;; - extend sequential? drop mal-false ;; - extend mal= = ;; - extend get-map-hint drop -1 ;; - extend set-map-hint! 2drop ;; -drop - -MalNil - extend conj ( item nil -- mal-list ) - drop MalList/Empty conj ;; - extend seq drop mal-nil ;; - extend as-native drop nil ;; - extend get 2drop ;; - extend to-list drop MalList/Empty ;; - extend empty? drop mal-true ;; - extend mal-count drop 0 MalInt. ;; - extend mal= drop mal-nil = ;; -drop - -MalType% - cell% field MalSymbol/sym-addr - cell% field MalSymbol/sym-len - cell% field MalSymbol/map-hint -deftype MalSymbol - -: MalSymbol. { str-addr str-len -- mal-sym } - MalSymbol new { sym } - str-addr sym MalSymbol/sym-addr ! - str-len sym MalSymbol/sym-len ! - -1 sym MalSymbol/map-hint ! - sym ; - -: unpack-sym ( mal-string -- addr len ) - dup MalSymbol/sym-addr @ - swap MalSymbol/sym-len @ ; - -MalSymbol - extend mal= ( other this -- bool ) - over mal-type @ MalSymbol = if - unpack-sym rot unpack-sym str= - else - 2drop 0 - endif ;; - extend get-map-hint MalSymbol/map-hint @ ;; - extend set-map-hint! MalSymbol/map-hint ! ;; - extend as-native ( this ) - unpack-sym evaluate ;; -drop - -MalType% - cell% field MalKeyword/str-addr - cell% field MalKeyword/str-len -deftype MalKeyword - -: unpack-keyword ( mal-keyword -- addr len ) - dup MalKeyword/str-addr @ - swap MalKeyword/str-len @ ; - -MalKeyword - extend mal= ( other this -- bool ) - over mal-type @ MalKeyword = if - unpack-keyword rot unpack-keyword str= - else - 2drop 0 - endif ;; - ' as-native ' unpack-keyword extend-method* -drop - -: MalKeyword. { str-addr str-len -- mal-keyword } - MalKeyword new { kw } - str-addr kw MalKeyword/str-addr ! - str-len kw MalKeyword/str-len ! - kw ; - -MalType% - cell% field MalString/str-addr - cell% field MalString/str-len -deftype MalString - -: MalString.0 { str-addr str-len -- mal-str } - MalString new { str } - str-addr str MalString/str-addr ! - str-len str MalString/str-len ! - str ; -' MalString.0 is MalString. - -: unpack-str ( mal-string -- addr len ) - dup MalString/str-addr @ - swap MalString/str-len @ ; - -MalString - extend mal= ( other this -- bool ) - over mal-type @ MalString = if - unpack-str rot unpack-str str= - else - 2drop 0 - endif ;; - ' as-native ' unpack-str extend-method* - extend seq { str } - str MalString/str-len @ { len } - len 0= if - mal-nil - else - len cells allocate throw { list-start } - len 0 ?do - str MalString/str-addr @ i + 1 MalString. ( new-char-string ) - list-start i cells + ! - loop - list-start len MalList. - endif ;; -drop - - -MalType% - cell% field MalNativeFn/xt -deftype MalNativeFn - -: MalNativeFn. { xt -- mal-fn } - MalNativeFn new { mal-fn } - xt mal-fn MalNativeFn/xt ! - mal-fn ; - - -MalType% - cell% field MalUserFn/is-macro? - cell% field MalUserFn/env - cell% field MalUserFn/formal-args - cell% field MalUserFn/var-arg - cell% field MalUserFn/body -deftype MalUserFn - - -MalType% - cell% field SpecialOp/xt -deftype SpecialOp - -: SpecialOp. - SpecialOp new swap over SpecialOp/xt ! ; - -MalType% - cell% field Atom/val -deftype Atom - -: Atom. Atom new swap over Atom/val ! ; +require str.fs + +\ === sorted-array === / +\ Here are a few utility functions useful for creating and maintaining +\ the deftype* method tables. The keys array is kept in sorted order, +\ and the methods array is maintained in parallel so that an index into +\ one corresponds to an index in the other. + +\ Search a sorted array for key, returning the index of where it was +\ found. If key is not in the array, return the index where it would +\ be if added. +: array-find { a-length a-addr key -- index found? } + 0 a-length ( start end ) + begin + \ cr 2dup . . + 2dup + 2 / dup ( start end middle middle ) + cells a-addr + @ ( start end middle mid-val ) + dup key < if + drop rot ( end middle start ) + 2dup = if + 2drop dup ( end end ) + else + drop swap ( middle end ) + endif + else + key > if ( start end middle ) + nip ( start middle ) + else + -rot 2drop dup ( middle middle ) + endif + endif + 2dup = until + dup a-length = if + drop false + else + cells a-addr + @ key = + endif ; + +\ Create a new array, one cell in length, initialized the provided value +: new-array { value -- array } + cell allocate throw value over ! ; + +\ Resize a heap-allocated array to be one cell longer, inserting value +\ at idx, and shifting the tail of the array as necessary. Returns the +\ (possibly new) array address +: array-insert { old-array-length old-array idx value -- array } + old-array old-array-length 1+ cells resize throw + { a } + a idx cells + dup cell+ old-array-length idx - cells cmove> + value a idx cells + ! + a + ; + + +\ === deftype* -- protocol-enabled structs === / +\ Each type has MalTypeType% struct allocated on the stack, with +\ mutable fields pointing to all class-shared resources, specifically +\ the data needed to allocate new instances, and the table of protocol +\ methods that have been extended to the type. +\ Use 'deftype*' to define a new type, and 'new' to create new +\ instances of that type. + +struct + cell% field mal-type + cell% field mal-meta + \ cell% field ref-count \ Ha, right. +end-struct MalType% + +struct + cell% 2 * field MalTypeType-struct + cell% field MalTypeType-methods + cell% field MalTypeType-method-keys + cell% field MalTypeType-method-vals + cell% field MalTypeType-name-addr + cell% field MalTypeType-name-len +end-struct MalTypeType% + +: new ( MalTypeType -- obj ) + dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct + dup -rot mal-type ! ( obj ) \ set struct's type pointer to this type + nil over mal-meta ! + ; + +: deftype* ( struct-align struct-len -- MalTypeType ) + MalTypeType% %allot ( s-a s-l MalTypeType ) + dup 2swap rot ( MalTypeType s-a s-l MalTypeType ) + MalTypeType-struct 2! ( MalTypeType ) \ store struct info + dup MalTypeType-methods 0 swap ! ( MalTypeType ) + dup MalTypeType-method-keys nil swap ! ( MalTypeType ) + dup MalTypeType-method-vals nil swap ! ( MalTypeType ) + dup MalTypeType-name-len 0 swap ! ( MalTypeType ) + ; + +\ parse-name uses temporary space, so copy into dictionary stack: +: parse-allot-name { -- new-str-addr str-len } + parse-name { str-addr str-len } + here { new-str-addr } str-len allot + str-addr new-str-addr str-len cmove + new-str-addr str-len ; + +: deftype ( struct-align struct-len R:type-name -- ) + parse-allot-name { name-addr name-len } + + \ allot and initialize type structure + deftype* { mt } + name-addr mt MalTypeType-name-addr ! + name-len mt MalTypeType-name-len ! + \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr + mt name-addr name-len nextname 1 0 const-does> ; + +: type-name ( mal-type ) + dup MalTypeType-name-addr @ ( mal-type name-addr ) + swap MalTypeType-name-len @ ( name-addr name-len ) + ; + +MalType% deftype MalDefault + +\ nil type and instance to support extending protocols to it +MalType% deftype MalNil MalNil new constant mal-nil +MalType% deftype MalTrue MalTrue new constant mal-true +MalType% deftype MalFalse MalFalse new constant mal-false + +: mal-bool + 0= if mal-false else mal-true endif ; + +: not-object? ( obj -- bool ) + dup 7 and 0 <> if + drop true + else + 1000000 < + endif ; + +\ === protocol methods === / + +struct + cell% field call-site/type + cell% field call-site/xt +end-struct call-site% + +\ Used by protocol methods to find the appropriate implementation of +\ themselves for the given object, and then execute that implementation. +: execute-method { obj pxt call-site -- } + obj not-object? if + 0 0 obj int>str s" ' on non-object: " pxt >name name>string + s" Refusing to invoke protocol fn '" ...throw-str + endif + \ ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type ." , cs " call-site . + + obj mal-type @ ( type ) + dup call-site call-site/type @ = if + \ ." hit!" cr + drop + call-site call-site/xt @ + else + \ ." miss!" cr + dup MalTypeType-methods 2@ swap ( type methods method-keys ) + dup 0= if \ No protocols extended to this type; check for a default + 2drop drop MalDefault MalTypeType-methods 2@ swap + endif + + pxt array-find ( type idx found? ) + dup 0= if \ No implementation found for this method; check for a default + 2drop drop MalDefault dup MalTypeType-methods 2@ swap + pxt array-find ( type idx found? ) + endif + 0= if ( type idx ) + 2drop + 0 0 s" '" obj mal-type @ type-name s" ' extended to type '" + pxt >name name>string s" No protocol fn '" ...throw-str + endif + + cells over MalTypeType-method-vals @ + @ ( type xt ) + swap call-site call-site/type ! ( xt ) + dup call-site call-site/xt ! ( xt ) + endif + obj swap execute ; + +\ Extend a type with a protocol method. This mutates the MalTypeType +\ object that represents the MalType being extended. +: extend-method* { type pxt ixt -- type } + \ ." Extend '" pxt dup . >name name>string safe-type ." ' to " type type-name safe-type ." , " + \ type MalTypeType-methods 2@ ( method-keys methods ) + \ 0 ?do + \ dup i cells + @ >name name>string safe-type ." , " + \ \ dup i cells + @ . + \ loop + \ drop cr + + type MalTypeType-methods 2@ swap ( methods method-keys ) + dup 0= if \ no protocols extended to this type + 2drop + 1 type MalTypeType-methods ! + pxt new-array type MalTypeType-method-keys ! + ixt new-array type MalTypeType-method-vals ! + else + pxt array-find { idx found? } + found? if \ overwrite + ." Warning: overwriting protocol method implementation '" + pxt >name name>string safe-type ." ' on " type type-name safe-type ." , " idx . found? . cr + + type MalTypeType-method-vals @ idx cells + ixt ! + else \ resize + type MalTypeType-methods dup @ 1+ dup rot ! ( new-count ) + 1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array ) + type MalTypeType-method-keys ! ( old-count ) + type MalTypeType-method-vals @ idx ixt array-insert ( new-array ) + type MalTypeType-method-vals ! + endif + endif + type + ; + + +\ Define a new protocol function. For example: +\ def-protocol-method pr-str +\ When called as above, defines a new word 'pr-str' and stores there its +\ own xt (known as pxt). When a usage of pr-str is compiled, it +\ allocates a call-site object on the heap and injects a reference to +\ both that and the pxt into the compilation, along with a call to +\ execute-method. Thus when pr-str runs, execute-method can check the +\ call-site object to see if the type of the target object is the same +\ as the last call for this site. If so, it executes the implementation +\ immediately. Otherwise, it searches the target type's method list and +\ if necessary MalDefault's method list. If an implementation of pxt is +\ found, it is cached in the call-site, and then executed. +: make-call-site { pxt -- } + pxt postpone literal \ transfer pxt into call site + call-site% %allocate throw dup postpone literal \ allocate call-site, push reference + \ dup ." Make cs '" pxt >name name>string type ." ' " . cr + 0 swap call-site/type ! + postpone execute-method ; + +: def-protocol-method ( parse: name -- ) + : latestxt postpone literal postpone make-call-site postpone ; immediate + ; + +: extend ( type -- type pxt install-xt ) + parse-name find-name name>int ( type pxt ) + ['] extend-method* + :noname + ; + +: ;; ( type pxt -- type ) + [compile] ; ( type pxt install-xt ixt ) + swap execute + ; immediate + +( +\ These whole-protocol names are only needed for 'satisfies?': +protocol IPrintable + def-protocol-method pr-str +end-protocol + +MalList IPrintable extend + ' pr-str :noname drop s" " ; extend-method* + + extend-method pr-str + drop s" " ;; +end-extend +) + +\ === Mal types and protocols === / + +def-protocol-method conj ( obj this -- this ) +def-protocol-method seq ( obj -- mal-list|nil ) +def-protocol-method assoc ( k v this -- this ) +def-protocol-method dissoc ( k this -- this ) +def-protocol-method get ( not-found k this -- value ) +def-protocol-method mal= ( a b -- bool ) +def-protocol-method as-native ( obj -- ) + +def-protocol-method to-list ( obj -- mal-list ) +def-protocol-method empty? ( obj -- mal-bool ) +def-protocol-method mal-count ( obj -- mal-int ) +def-protocol-method sequential? ( obj -- mal-bool ) +def-protocol-method get-map-hint ( obj -- hint ) +def-protocol-method set-map-hint! ( hint obj -- ) + + +\ Fully evalutate any Mal object: +def-protocol-method mal-eval ( env ast -- val ) + +\ Invoke an object, given whole env and unevaluated argument forms: +def-protocol-method eval-invoke ( env list obj -- ... ) + +\ Invoke a function, given parameter values +def-protocol-method invoke ( argv argc mal-fn -- ... ) + + +: m= ( a b -- bool ) + 2dup = if + 2drop true + else + mal= + endif ; + + +MalType% + cell% field MalInt/int +deftype MalInt + +: MalInt. { int -- mal-int } + MalInt new dup MalInt/int int swap ! ; + +MalInt + extend mal= ( other this -- bool ) + over mal-type @ MalInt = if + MalInt/int @ swap MalInt/int @ = + else + 2drop 0 + endif ;; + + extend as-native ( mal-int -- int ) + MalInt/int @ ;; +drop + + +MalType% + cell% field MalList/count + cell% field MalList/start +deftype MalList + +: MalList. ( start count -- mal-list ) + MalList new + swap over MalList/count ! ( start list ) + swap over MalList/start ! ( list ) ; + +: here>MalList ( old-here -- mal-list ) + here over - { bytes } ( old-here ) + MalList new bytes ( old-here mal-list bytes ) + allocate throw dup { target } over MalList/start ! ( old-here mal-list ) + bytes cell / over MalList/count ! ( old-here mal-list ) + swap target bytes cmove ( mal-list ) + 0 bytes - allot \ pop list contents from dictionary stack + ; + +: MalList/concat ( list-of-lists ) + dup MalList/start @ swap MalList/count @ { lists argc } + 0 lists argc cells + lists +do ( count ) + i @ to-list MalList/count @ + + cell +loop { count } + count cells allocate throw { start } + start lists argc cells + lists +do ( target ) + i @ to-list MalList/count @ cells 2dup i @ to-list MalList/start @ -rot ( target bytes src target bytes ) + cmove ( target bytes ) + + ( new-target ) + cell +loop + drop start count MalList. ; + +MalList + extend to-list ;; + extend sequential? drop mal-true ;; + extend conj { elem old-list -- list } + old-list MalList/count @ 1+ { new-count } + new-count cells allocate throw { new-start } + elem new-start ! + new-count 1 > if + old-list MalList/start @ new-start cell+ new-count 1- cells cmove + endif + new-start new-count MalList. ;; + extend seq + dup MalList/count @ 0= if + drop mal-nil + endif ;; + extend empty? MalList/count @ 0= mal-bool ;; + extend mal-count MalList/count @ MalInt. ;; + extend mal= + over mal-nil = if + 2drop false + else + swap to-list dup 0= if + nip + else + 2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count ) + -rot MalList/start @ swap MalList/start @ { start-b start-a } + true swap ( return-val count ) + 0 ?do + start-a i cells + @ + start-b i cells + @ + m= if else + drop false leave + endif + loop + else + drop 2drop false + endif + endif + endif ;; +drop + +MalList new 0 over MalList/count ! constant MalList/Empty + +: MalList/rest { list -- list } + list MalList/start @ cell+ + list MalList/count @ 1- + MalList. ; + + +MalType% + cell% field MalVector/list +deftype MalVector + +MalVector + extend sequential? drop mal-true ;; + extend to-list + MalVector/list @ ;; + extend empty? + MalVector/list @ + MalList/count @ 0= mal-bool ;; + extend mal-count + MalVector/list @ + MalList/count @ MalInt. ;; + extend mal= + MalVector/list @ swap m= ;; + extend conj + MalVector/list @ { elem old-list } + old-list MalList/count @ { old-count } + old-count 1+ cells allocate throw { new-start } + elem new-start old-count cells + ! + old-list MalList/start @ new-start old-count cells cmove + new-start old-count 1+ MalList. + MalVector new swap + over MalVector/list ! ;; + extend seq + MalVector/list @ seq ;; +drop + +MalType% + cell% field MalMap/list +deftype MalMap + +MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty + +: MalMap/get-addr ( k map -- addr-or-nil ) + MalMap/list @ + dup MalList/start @ + swap MalList/count @ { k start count } + true \ need to search? + k get-map-hint { hint-idx } + hint-idx -1 <> if + hint-idx count < if + hint-idx cells start + { key-addr } + key-addr @ k m= if + key-addr cell+ + nip false + endif + endif + endif + if \ search + nil ( addr ) + count cells start + start +do + i @ k m= if + drop i + dup start - cell / k set-map-hint! + cell+ leave + endif + [ 2 cells ] literal +loop + endif ; + +MalMap + extend conj ( kv map -- map ) + MalMap/list @ \ get list + over MalList/start @ cell+ @ swap conj \ add value + swap MalList/start @ @ swap conj \ add key + MalMap new dup -rot MalMap/list ! \ put back in map + ;; + extend assoc ( k v map -- map ) + MalMap/list @ \ get list + conj conj + MalMap new tuck MalMap/list ! \ put back in map + ;; + extend dissoc { k map -- map } + map MalMap/list @ + dup MalList/start @ swap MalList/count @ { start count } + map \ return original if key not found + count 0 +do + start i cells + @ k mal= if + drop here + start i MalList. , + start i 2 + cells + count i - 2 - MalList. , + here>MalList MalList/concat + MalMap new dup -rot MalMap/list ! \ put back in map + endif + 2 +loop ;; + extend get ( not-found k map -- value ) + MalMap/get-addr ( not-found addr-or-nil ) + dup 0= if drop else nip @ endif ;; + extend empty? + MalMap/list @ + MalList/count @ 0= mal-bool ;; + extend mal-count + MalMap/list @ + MalList/count @ 2 / MalInt. ;; + extend mal= { b a -- bool } + b mal-type @ MalMap = if + a MalMap/list @ MalList/count @ { a-count } + b MalMap/list @ MalList/count @ { b-count } + a-count b-count = if + a MalMap/list @ MalList/start @ { a-start } + true ( return-val ) + a-count 0 +do + a-start i cells + @ ( return-val key ) + dup a MalMap/get-addr swap b MalMap/get-addr ( return-val a-val-addr b-val-addr ) + dup 0= if + drop 2drop false leave + else + @ swap @ ( return-val b-val a-val ) + m= if else + drop false leave + endif + endif + 2 +loop + else + false + endif + else + false + endif ;; +drop + +\ Examples of extending existing protocol methods to existing type +MalDefault + extend conj ( obj this -- this ) + nip ;; + extend to-list drop 0 ;; + extend empty? drop mal-true ;; + extend sequential? drop mal-false ;; + extend mal= = ;; + extend get-map-hint drop -1 ;; + extend set-map-hint! 2drop ;; +drop + +MalNil + extend conj ( item nil -- mal-list ) + drop MalList/Empty conj ;; + extend seq drop mal-nil ;; + extend as-native drop nil ;; + extend get 2drop ;; + extend to-list drop MalList/Empty ;; + extend empty? drop mal-true ;; + extend mal-count drop 0 MalInt. ;; + extend mal= drop mal-nil = ;; +drop + +MalType% + cell% field MalSymbol/sym-addr + cell% field MalSymbol/sym-len + cell% field MalSymbol/map-hint +deftype MalSymbol + +: MalSymbol. { str-addr str-len -- mal-sym } + MalSymbol new { sym } + str-addr sym MalSymbol/sym-addr ! + str-len sym MalSymbol/sym-len ! + -1 sym MalSymbol/map-hint ! + sym ; + +: unpack-sym ( mal-string -- addr len ) + dup MalSymbol/sym-addr @ + swap MalSymbol/sym-len @ ; + +MalSymbol + extend mal= ( other this -- bool ) + over mal-type @ MalSymbol = if + unpack-sym rot unpack-sym str= + else + 2drop 0 + endif ;; + extend get-map-hint MalSymbol/map-hint @ ;; + extend set-map-hint! MalSymbol/map-hint ! ;; + extend as-native ( this ) + unpack-sym evaluate ;; +drop + +MalType% + cell% field MalKeyword/str-addr + cell% field MalKeyword/str-len +deftype MalKeyword + +: unpack-keyword ( mal-keyword -- addr len ) + dup MalKeyword/str-addr @ + swap MalKeyword/str-len @ ; + +MalKeyword + extend mal= ( other this -- bool ) + over mal-type @ MalKeyword = if + unpack-keyword rot unpack-keyword str= + else + 2drop 0 + endif ;; + ' as-native ' unpack-keyword extend-method* +drop + +: MalKeyword. { str-addr str-len -- mal-keyword } + MalKeyword new { kw } + str-addr kw MalKeyword/str-addr ! + str-len kw MalKeyword/str-len ! + kw ; + +MalType% + cell% field MalString/str-addr + cell% field MalString/str-len +deftype MalString + +: MalString.0 { str-addr str-len -- mal-str } + MalString new { str } + str-addr str MalString/str-addr ! + str-len str MalString/str-len ! + str ; +' MalString.0 is MalString. + +: unpack-str ( mal-string -- addr len ) + dup MalString/str-addr @ + swap MalString/str-len @ ; + +MalString + extend mal= ( other this -- bool ) + over mal-type @ MalString = if + unpack-str rot unpack-str str= + else + 2drop 0 + endif ;; + ' as-native ' unpack-str extend-method* + extend seq { str } + str MalString/str-len @ { len } + len 0= if + mal-nil + else + len cells allocate throw { list-start } + len 0 ?do + str MalString/str-addr @ i + 1 MalString. ( new-char-string ) + list-start i cells + ! + loop + list-start len MalList. + endif ;; +drop + + +MalType% + cell% field MalNativeFn/xt +deftype MalNativeFn + +: MalNativeFn. { xt -- mal-fn } + MalNativeFn new { mal-fn } + xt mal-fn MalNativeFn/xt ! + mal-fn ; + + +MalType% + cell% field MalUserFn/is-macro? + cell% field MalUserFn/env + cell% field MalUserFn/formal-args + cell% field MalUserFn/var-arg + cell% field MalUserFn/body +deftype MalUserFn + + +MalType% + cell% field SpecialOp/xt +deftype SpecialOp + +: SpecialOp. + SpecialOp new swap over SpecialOp/xt ! ; + +MalType% + cell% field Atom/val +deftype Atom + +: Atom. Atom new swap over Atom/val ! ; diff --git a/impls/fsharp/Dockerfile b/impls/fsharp/Dockerfile index 01cf8044c7..0f9a80bdb4 100644 --- a/impls/fsharp/Dockerfile +++ b/impls/fsharp/Dockerfile @@ -1,27 +1,27 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Deps for Mono-based languages (C#, VB.Net) -RUN apt-get -y install mono-runtime mono-mcs mono-vbnc mono-devel - -RUN apt-get -y install fsharp +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Deps for Mono-based languages (C#, VB.Net) +RUN apt-get -y install mono-runtime mono-mcs mono-vbnc mono-devel + +RUN apt-get -y install fsharp diff --git a/impls/fsharp/Makefile b/impls/fsharp/Makefile index 505d3ee5d3..eab71b7ba7 100644 --- a/impls/fsharp/Makefile +++ b/impls/fsharp/Makefile @@ -1,46 +1,46 @@ -##################### - -DEBUG = - -SOURCES_BASE = types.fs error.fs node.fs printer.fs tokenizer.fs reader.fs \ - readline.fs -SOURCES_LISP = core.fs env.fs stepA_mal.fs -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -TERMINAL_SOURCES = terminal.cs - -##################### - -SRCS = step0_repl.fs step1_read_print.fs step2_eval.fs step3_env.fs \ - step4_if_fn_do.fs step5_tco.fs step6_file.fs step7_quote.fs \ - step8_macros.fs step9_try.fs stepA_mal.fs -DLL_SOURCES = $(filter-out stepA_mal.fs,$(SOURCES)) - -FSFLAGS = $(if $(strip $(DEBUG)),--debug+,--debug- --optimize+ --tailcalls+) -CSFLAGS = $(if $(strip $(DEBUG)),-debug+,) -##################### - -all: $(patsubst %.fs,%.exe,$(SRCS)) - -dist: mal.exe mal - -mal.exe: stepA_mal.exe - cp $< $@ - -# NOTE/WARNING: static linking triggers mono libraries LGPL -# distribution requirements. -# http://www.mono-project.com/archived/guiderunning_mono_applications/ -mal: $(patsubst %.fs,%.exe,$(word $(words $(SOURCES)),$(SOURCES))) Mono.Terminal.dll mal.dll - mkbundle --static -o $@ $+ --deps - -Mono.Terminal.dll: $(TERMINAL_SOURCES) - mcs $(CSFLAGS) -target:library $+ -out:$@ - -mal.dll: $(DLL_SOURCES) Mono.Terminal.dll - fsharpc $(FSFLAGS) -o $@ -r Mono.Terminal.dll -a $(DLL_SOURCES) - -%.exe: %.fs mal.dll - fsharpc $(FSFLAGS) -o $@ -r mal.dll $< - -clean: - rm -f mal *.dll *.exe *.mdb +##################### + +DEBUG = + +SOURCES_BASE = types.fs error.fs node.fs printer.fs tokenizer.fs reader.fs \ + readline.fs +SOURCES_LISP = core.fs env.fs stepA_mal.fs +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +TERMINAL_SOURCES = terminal.cs + +##################### + +SRCS = step0_repl.fs step1_read_print.fs step2_eval.fs step3_env.fs \ + step4_if_fn_do.fs step5_tco.fs step6_file.fs step7_quote.fs \ + step8_macros.fs step9_try.fs stepA_mal.fs +DLL_SOURCES = $(filter-out stepA_mal.fs,$(SOURCES)) + +FSFLAGS = $(if $(strip $(DEBUG)),--debug+,--debug- --optimize+ --tailcalls+) +CSFLAGS = $(if $(strip $(DEBUG)),-debug+,) +##################### + +all: $(patsubst %.fs,%.exe,$(SRCS)) + +dist: mal.exe mal + +mal.exe: stepA_mal.exe + cp $< $@ + +# NOTE/WARNING: static linking triggers mono libraries LGPL +# distribution requirements. +# http://www.mono-project.com/archived/guiderunning_mono_applications/ +mal: $(patsubst %.fs,%.exe,$(word $(words $(SOURCES)),$(SOURCES))) Mono.Terminal.dll mal.dll + mkbundle --static -o $@ $+ --deps + +Mono.Terminal.dll: $(TERMINAL_SOURCES) + mcs $(CSFLAGS) -target:library $+ -out:$@ + +mal.dll: $(DLL_SOURCES) Mono.Terminal.dll + fsharpc $(FSFLAGS) -o $@ -r Mono.Terminal.dll -a $(DLL_SOURCES) + +%.exe: %.fs mal.dll + fsharpc $(FSFLAGS) -o $@ -r mal.dll $< + +clean: + rm -f mal *.dll *.exe *.mdb diff --git a/impls/fsharp/core.fs b/impls/fsharp/core.fs index f64a350199..1d17c25921 100644 --- a/impls/fsharp/core.fs +++ b/impls/fsharp/core.fs @@ -1,309 +1,309 @@ -module Core - - open System - open Types - - let inline toBool b = if b then Node.TRUE else Node.FALSE - - let inline twoNumberOp (f : int64 -> int64 -> Node) = function - | [Number(a); Number(b)] -> f a b - | [_; _] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let inline twoNodeOp (f : Node -> Node -> Node) = function - | [a; b] -> f a b - | _ -> raise <| Error.wrongArity () - - let add = twoNumberOp (fun a b -> a + b |> Number) - let subtract = twoNumberOp (fun a b -> a - b |> Number) - let multiply = twoNumberOp (fun a b -> a * b |> Number) - let divide = twoNumberOp (fun a b -> a / b |> Number) - let lt = twoNodeOp (fun a b -> a < b |> toBool) - let le = twoNodeOp (fun a b -> a <= b |> toBool) - let ge = twoNodeOp (fun a b -> a >= b |> toBool) - let gt = twoNodeOp (fun a b -> a > b |> toBool) - let eq = twoNodeOp (fun a b -> a = b |> toBool) - - let time_ms _ = - DateTime.Now.Ticks / TimeSpan.TicksPerMillisecond |> int64 |> Number - - let list = Node.makeList - let isList = function - | [List(_, _)] -> Node.TRUE - | [_] -> Node.FALSE - | _ -> raise <| Error.wrongArity () - - let isEmpty = function - | [List(_, [])] -> Node.TRUE - | [Vector(_, seg)] when seg.Count <= 0 -> Node.TRUE - | _ -> Node.FALSE - - let count = function - | [List(_, lst)] -> lst |> List.length |> int64 |> Number - | [Vector(_, seg)] -> seg.Count |> int64 |> Number - | [Nil] -> Node.ZERO - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let pr_str nodes = nodes |> Printer.pr_str |> String - let str nodes = nodes |> Printer.str |> String - let prn nodes = nodes |> Printer.prn |> printfn "%s"; Nil - let println nodes = nodes |> Printer.println |> printfn "%s"; Nil - - let read_str = function - | [String(s)] -> - match Reader.read_str s with - | [node] -> node - | nodes -> Symbol("do")::nodes |> Node.makeList - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let slurp = function - | [String(s)] -> System.IO.File.ReadAllText s |> String - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let cons = function - | [node; List(_, lst)] -> node::lst |> Node.makeList - | [node; Vector(_, seg)] -> node::(List.ofSeq seg) |> Node.makeList - | [_; _] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let concat nodes = - let cons st node = node::st - let accumNode acc = function - | List(_, lst) -> lst |> List.fold cons acc - | Vector(_, seg) -> seg |> Seq.fold cons acc - | _ -> raise <| Error.argMismatch () - - nodes - |> List.fold accumNode [] - |> List.rev - |> Node.makeList - - let vec = function - | [Vector(_, _) as v] -> v - | [List(_, xs)] -> Node.ofArray <| Array.ofSeq xs - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let nth = function - | [List(_, lst); Number(n)] -> - let rec nth_list n = function - | [] -> raise <| Error.indexOutOfBounds () - | h::_ when n = 0L -> h - | _::t -> nth_list (n - 1L) t - nth_list n lst - | [Vector(_, seg); Number(n)] -> - if n < 0L || n >= int64(seg.Count) then - raise <| Error.indexOutOfBounds () - else - seg.Array.[int(n)] - | [_; _] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let first = function - | [List(_, [])] -> Node.NIL - | [List(_, h::_)] -> h - | [Vector(_, seg)] when seg.Count > 0 -> seg.Array.[0] - | [Vector(_, _)] -> Node.NIL - | [Nil] -> Node.NIL - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let rest = function - | [List(_, [])] -> Node.EmptyLIST - | [List(_, _::t)] -> t |> Node.makeList - | [Vector(_, seg)] when seg.Count < 2 -> Node.EmptyLIST - | [Vector(_, seg)] -> seg |> Seq.skip 1 |> List.ofSeq |> Node.makeList - | [Nil] -> Node.EmptyLIST - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let throw = function - | [node] -> raise <| Error.MalError(node) - | _ -> raise <| Error.wrongArity () - - let map = function - | [BuiltInFunc(_, _, f); Node.Seq seq] - | [Func(_, _, f, _, _, _); Node.Seq seq] -> - seq |> Seq.map (fun node -> f [node]) |> List.ofSeq |> Node.makeList - | [_; _] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let apply = function - | BuiltInFunc(_, _, f)::rest - | Func(_, _, f, _, _, _)::rest -> - let rec getArgsAndCall acc = function - | [] -> raise <| Error.wrongArity () - | [Node.Seq seq] -> - seq |> Seq.fold (fun acc node -> node::acc) acc |> List.rev |> f - | [_] -> raise <| Error.argMismatch () - | h::rest -> getArgsAndCall (h::acc) rest - getArgsAndCall [] rest - | _::_ -> raise <| Error.argMismatch () - | [] -> raise <| Error.wrongArity () - - let isConst cmp = function - | [node] -> if node = cmp then Node.TRUE else Node.FALSE - | _ -> raise <| Error.wrongArity () - - let isPattern f = function - | [node] -> if f node then Node.TRUE else Node.FALSE - | _ -> raise <| Error.wrongArity () - - let isSymbol = isPattern (function Symbol(_) -> true | _ -> false) - let isKeyword = isPattern (function Keyword(_) -> true | _ -> false) - let isString = isPattern (function String(_) -> true | _ -> false) - let isNumber = isPattern (function Number(_) -> true | _ -> false) - let isFn = isPattern (function BuiltInFunc(_, _, _) | Func(_, _, _, _, _, _) -> true | _ -> false) - let isMacro = isPattern (function Macro(_, _, _, _, _, _) -> true | _ -> false) - let isSequential = isPattern (function Node.Seq(_) -> true | _ -> false) - let isVector = isPattern (function Vector(_, _) -> true | _ -> false) - let isMap = isPattern (function Map(_, _) -> true | _ -> false) - let isAtom = isPattern (function Atom(_, _) -> true | _ -> false) - - let symbol = function - | [String(s)] -> Symbol s - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let keyword = function - | [String(s)] -> Keyword s - | [Keyword(_) as k] -> k - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let vector lst = lst |> Array.ofList |> Node.ofArray - - let rec getPairs lst = - seq { - match lst with - | first::second::t -> - yield first, second - yield! getPairs t - | [_] -> raise <| Error.expectedEvenNodeCount () - | [] -> () - } - - let mapOpN f = function - | Map(_, map)::rest -> f rest map - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let mapOp1 f = - mapOpN (fun rest map -> - match rest with - | [v] -> f v map - | _ -> raise <| Error.wrongArity ()) - - let mapOp0 f = - mapOpN (fun rest map -> - match rest with - | [] -> f map - | _ -> raise <| Error.wrongArity ()) - - let mapKV f = - mapOp0 (fun map -> map |> Map.toSeq |> Seq.map f |> List.ofSeq |> Node.makeList) - - let hashMap lst = lst |> getPairs |> Map.ofSeq |> Node.makeMap - let assoc = mapOpN (fun rest map -> - rest - |> getPairs - |> Seq.fold (fun map (k, v) -> Map.add k v map) map - |> Node.makeMap) - let dissoc = mapOpN (fun keys map -> - keys - |> List.fold (fun map k -> Map.remove k map) map - |> Node.makeMap) - let get = function - | [Nil; _] -> Node.NIL - | _ as rest -> - rest |> mapOp1 (fun key map -> - match Map.tryFind key map with - | Some(node) -> node - | None -> Node.NIL) - let containsKey key map = if Map.containsKey key map then Node.TRUE else Node.FALSE - let contains = mapOp1 containsKey - let keys = mapKV (fun (k, v) -> k) - let vals = mapKV (fun (k, v) -> v) - - let atom nextValue = function - | [node] -> Atom((nextValue ()), ref node) - | _ -> raise <| Error.wrongArity () - - let deref = function - | [Atom(_, r)] -> !r - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let reset = function - | [Atom(_, r); node] -> - r := node - !r - | [_; _] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let swap = function - | Atom(_, r) - ::(BuiltInFunc(_, _, f) | Func(_, _, f, _, _, _)) - ::rest -> - r := f (!r::rest) - !r - | [_; _] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let conj = function - | List(_, lst)::rest -> - rest - |> List.fold (fun lst node -> node::lst) lst - |> Node.makeList - | Vector(_, seg)::rest -> - (* Might be nice to implement a persistent vector here someday. *) - let cnt = List.length rest - if cnt > 0 then - let target : Node array = seg.Count + cnt |> Array.zeroCreate - System.Array.Copy(seg.Array :> System.Array, seg.Offset, - target :> System.Array, 0, seg.Count) - let rec copyElem i = function - | h::t -> - Array.set target i h - copyElem (i + 1) t - | [] -> () - copyElem (seg.Count) rest - target |> Node.ofArray - else - seg |> Node.makeVector - | [_; _] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let seq = function - | [Nil] -> Node.NIL - | [List(_, [])] -> Node.NIL - | [List(_, _) as l] -> l - | [Vector(_, seg)] when seg.Count < 1 -> Node.NIL - | [Vector(_, seg)] -> seg |> List.ofSeq |> Node.makeList - | [String(s)] when String.length s < 1 -> Node.NIL - | [String(s)] -> s |> Seq.map Node.ofChar |> List.ofSeq |> Node.makeList - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let withMeta = function - | [List(_, lst); m] -> List(m, lst) - | [Vector(_, seg); m] -> Vector(m, seg) - | [Map(_, map); m] -> Map(m, map) - | [BuiltInFunc(_, tag, f); m] -> BuiltInFunc(m, tag, f) - | [Func(_, tag, f, a, b, c); m] -> Func(m, tag, f, a, b, c) - | [Macro(_, tag, f, a, b, c); m] -> Macro(m, tag, f, a, b, c) - | [_; _] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let meta = function - | [List(m, _)] - | [Vector(m, _)] - | [Map(m, _)] - | [BuiltInFunc(m, _, _)] - | [Func(m, _, _, _, _, _)] - | [Macro(m, _, _, _, _, _)] -> m - | [_] -> Node.NIL - | _ -> raise <| Error.wrongArity () +module Core + + open System + open Types + + let inline toBool b = if b then Node.TRUE else Node.FALSE + + let inline twoNumberOp (f : int64 -> int64 -> Node) = function + | [Number(a); Number(b)] -> f a b + | [_; _] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let inline twoNodeOp (f : Node -> Node -> Node) = function + | [a; b] -> f a b + | _ -> raise <| Error.wrongArity () + + let add = twoNumberOp (fun a b -> a + b |> Number) + let subtract = twoNumberOp (fun a b -> a - b |> Number) + let multiply = twoNumberOp (fun a b -> a * b |> Number) + let divide = twoNumberOp (fun a b -> a / b |> Number) + let lt = twoNodeOp (fun a b -> a < b |> toBool) + let le = twoNodeOp (fun a b -> a <= b |> toBool) + let ge = twoNodeOp (fun a b -> a >= b |> toBool) + let gt = twoNodeOp (fun a b -> a > b |> toBool) + let eq = twoNodeOp (fun a b -> a = b |> toBool) + + let time_ms _ = + DateTime.Now.Ticks / TimeSpan.TicksPerMillisecond |> int64 |> Number + + let list = Node.makeList + let isList = function + | [List(_, _)] -> Node.TRUE + | [_] -> Node.FALSE + | _ -> raise <| Error.wrongArity () + + let isEmpty = function + | [List(_, [])] -> Node.TRUE + | [Vector(_, seg)] when seg.Count <= 0 -> Node.TRUE + | _ -> Node.FALSE + + let count = function + | [List(_, lst)] -> lst |> List.length |> int64 |> Number + | [Vector(_, seg)] -> seg.Count |> int64 |> Number + | [Nil] -> Node.ZERO + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let pr_str nodes = nodes |> Printer.pr_str |> String + let str nodes = nodes |> Printer.str |> String + let prn nodes = nodes |> Printer.prn |> printfn "%s"; Nil + let println nodes = nodes |> Printer.println |> printfn "%s"; Nil + + let read_str = function + | [String(s)] -> + match Reader.read_str s with + | [node] -> node + | nodes -> Symbol("do")::nodes |> Node.makeList + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let slurp = function + | [String(s)] -> System.IO.File.ReadAllText s |> String + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let cons = function + | [node; List(_, lst)] -> node::lst |> Node.makeList + | [node; Vector(_, seg)] -> node::(List.ofSeq seg) |> Node.makeList + | [_; _] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let concat nodes = + let cons st node = node::st + let accumNode acc = function + | List(_, lst) -> lst |> List.fold cons acc + | Vector(_, seg) -> seg |> Seq.fold cons acc + | _ -> raise <| Error.argMismatch () + + nodes + |> List.fold accumNode [] + |> List.rev + |> Node.makeList + + let vec = function + | [Vector(_, _) as v] -> v + | [List(_, xs)] -> Node.ofArray <| Array.ofSeq xs + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let nth = function + | [List(_, lst); Number(n)] -> + let rec nth_list n = function + | [] -> raise <| Error.indexOutOfBounds () + | h::_ when n = 0L -> h + | _::t -> nth_list (n - 1L) t + nth_list n lst + | [Vector(_, seg); Number(n)] -> + if n < 0L || n >= int64(seg.Count) then + raise <| Error.indexOutOfBounds () + else + seg.Array.[int(n)] + | [_; _] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let first = function + | [List(_, [])] -> Node.NIL + | [List(_, h::_)] -> h + | [Vector(_, seg)] when seg.Count > 0 -> seg.Array.[0] + | [Vector(_, _)] -> Node.NIL + | [Nil] -> Node.NIL + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let rest = function + | [List(_, [])] -> Node.EmptyLIST + | [List(_, _::t)] -> t |> Node.makeList + | [Vector(_, seg)] when seg.Count < 2 -> Node.EmptyLIST + | [Vector(_, seg)] -> seg |> Seq.skip 1 |> List.ofSeq |> Node.makeList + | [Nil] -> Node.EmptyLIST + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let throw = function + | [node] -> raise <| Error.MalError(node) + | _ -> raise <| Error.wrongArity () + + let map = function + | [BuiltInFunc(_, _, f); Node.Seq seq] + | [Func(_, _, f, _, _, _); Node.Seq seq] -> + seq |> Seq.map (fun node -> f [node]) |> List.ofSeq |> Node.makeList + | [_; _] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let apply = function + | BuiltInFunc(_, _, f)::rest + | Func(_, _, f, _, _, _)::rest -> + let rec getArgsAndCall acc = function + | [] -> raise <| Error.wrongArity () + | [Node.Seq seq] -> + seq |> Seq.fold (fun acc node -> node::acc) acc |> List.rev |> f + | [_] -> raise <| Error.argMismatch () + | h::rest -> getArgsAndCall (h::acc) rest + getArgsAndCall [] rest + | _::_ -> raise <| Error.argMismatch () + | [] -> raise <| Error.wrongArity () + + let isConst cmp = function + | [node] -> if node = cmp then Node.TRUE else Node.FALSE + | _ -> raise <| Error.wrongArity () + + let isPattern f = function + | [node] -> if f node then Node.TRUE else Node.FALSE + | _ -> raise <| Error.wrongArity () + + let isSymbol = isPattern (function Symbol(_) -> true | _ -> false) + let isKeyword = isPattern (function Keyword(_) -> true | _ -> false) + let isString = isPattern (function String(_) -> true | _ -> false) + let isNumber = isPattern (function Number(_) -> true | _ -> false) + let isFn = isPattern (function BuiltInFunc(_, _, _) | Func(_, _, _, _, _, _) -> true | _ -> false) + let isMacro = isPattern (function Macro(_, _, _, _, _, _) -> true | _ -> false) + let isSequential = isPattern (function Node.Seq(_) -> true | _ -> false) + let isVector = isPattern (function Vector(_, _) -> true | _ -> false) + let isMap = isPattern (function Map(_, _) -> true | _ -> false) + let isAtom = isPattern (function Atom(_, _) -> true | _ -> false) + + let symbol = function + | [String(s)] -> Symbol s + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let keyword = function + | [String(s)] -> Keyword s + | [Keyword(_) as k] -> k + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let vector lst = lst |> Array.ofList |> Node.ofArray + + let rec getPairs lst = + seq { + match lst with + | first::second::t -> + yield first, second + yield! getPairs t + | [_] -> raise <| Error.expectedEvenNodeCount () + | [] -> () + } + + let mapOpN f = function + | Map(_, map)::rest -> f rest map + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let mapOp1 f = + mapOpN (fun rest map -> + match rest with + | [v] -> f v map + | _ -> raise <| Error.wrongArity ()) + + let mapOp0 f = + mapOpN (fun rest map -> + match rest with + | [] -> f map + | _ -> raise <| Error.wrongArity ()) + + let mapKV f = + mapOp0 (fun map -> map |> Map.toSeq |> Seq.map f |> List.ofSeq |> Node.makeList) + + let hashMap lst = lst |> getPairs |> Map.ofSeq |> Node.makeMap + let assoc = mapOpN (fun rest map -> + rest + |> getPairs + |> Seq.fold (fun map (k, v) -> Map.add k v map) map + |> Node.makeMap) + let dissoc = mapOpN (fun keys map -> + keys + |> List.fold (fun map k -> Map.remove k map) map + |> Node.makeMap) + let get = function + | [Nil; _] -> Node.NIL + | _ as rest -> + rest |> mapOp1 (fun key map -> + match Map.tryFind key map with + | Some(node) -> node + | None -> Node.NIL) + let containsKey key map = if Map.containsKey key map then Node.TRUE else Node.FALSE + let contains = mapOp1 containsKey + let keys = mapKV (fun (k, v) -> k) + let vals = mapKV (fun (k, v) -> v) + + let atom nextValue = function + | [node] -> Atom((nextValue ()), ref node) + | _ -> raise <| Error.wrongArity () + + let deref = function + | [Atom(_, r)] -> !r + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let reset = function + | [Atom(_, r); node] -> + r := node + !r + | [_; _] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let swap = function + | Atom(_, r) + ::(BuiltInFunc(_, _, f) | Func(_, _, f, _, _, _)) + ::rest -> + r := f (!r::rest) + !r + | [_; _] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let conj = function + | List(_, lst)::rest -> + rest + |> List.fold (fun lst node -> node::lst) lst + |> Node.makeList + | Vector(_, seg)::rest -> + (* Might be nice to implement a persistent vector here someday. *) + let cnt = List.length rest + if cnt > 0 then + let target : Node array = seg.Count + cnt |> Array.zeroCreate + System.Array.Copy(seg.Array :> System.Array, seg.Offset, + target :> System.Array, 0, seg.Count) + let rec copyElem i = function + | h::t -> + Array.set target i h + copyElem (i + 1) t + | [] -> () + copyElem (seg.Count) rest + target |> Node.ofArray + else + seg |> Node.makeVector + | [_; _] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let seq = function + | [Nil] -> Node.NIL + | [List(_, [])] -> Node.NIL + | [List(_, _) as l] -> l + | [Vector(_, seg)] when seg.Count < 1 -> Node.NIL + | [Vector(_, seg)] -> seg |> List.ofSeq |> Node.makeList + | [String(s)] when String.length s < 1 -> Node.NIL + | [String(s)] -> s |> Seq.map Node.ofChar |> List.ofSeq |> Node.makeList + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let withMeta = function + | [List(_, lst); m] -> List(m, lst) + | [Vector(_, seg); m] -> Vector(m, seg) + | [Map(_, map); m] -> Map(m, map) + | [BuiltInFunc(_, tag, f); m] -> BuiltInFunc(m, tag, f) + | [Func(_, tag, f, a, b, c); m] -> Func(m, tag, f, a, b, c) + | [Macro(_, tag, f, a, b, c); m] -> Macro(m, tag, f, a, b, c) + | [_; _] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let meta = function + | [List(m, _)] + | [Vector(m, _)] + | [Map(m, _)] + | [BuiltInFunc(m, _, _)] + | [Func(m, _, _, _, _, _)] + | [Macro(m, _, _, _, _, _)] -> m + | [_] -> Node.NIL + | _ -> raise <| Error.wrongArity () diff --git a/impls/fsharp/env.fs b/impls/fsharp/env.fs index 07535dd4ad..9cdc59f776 100644 --- a/impls/fsharp/env.fs +++ b/impls/fsharp/env.fs @@ -1,132 +1,132 @@ -module Env - - open Types - - let makeEmpty () = Env() - - let ofList lst = - let env = makeEmpty () - let accumulate (e : Env) (k, v) = e.Add(k, v); e - List.fold accumulate env lst - - let set (env : EnvChain) key node = - match env with - | head::_ -> head.[key] <- node - | _ -> raise <| Error.noEnvironment () - - let rec find (chain : EnvChain) key = - match chain with - | [] -> None - | env::rest -> - match env.TryGetValue(key) with - | true, v -> Some(v) - | false, _ -> find rest key - - let get chain key = - match find chain key with - | Some(v) -> v - | None -> raise <| Error.symbolNotFound key - - let private getNextValue = - let counter = ref 0 - fun () -> System.Threading.Interlocked.Increment(counter) - - let makeBuiltInFunc f = - BuiltInFunc(Node.NIL, getNextValue (), f) - - let makeFunc f body binds env = - Func(Node.NIL, getNextValue (), f, body, binds, env) - - let makeMacro f body binds env = - Macro(Node.NIL, getNextValue (), f, body, binds, env) - - let makeRootEnv () = - let wrap name f = name, makeBuiltInFunc f - let env = - [ wrap "+" Core.add - wrap "-" Core.subtract - wrap "*" Core.multiply - wrap "/" Core.divide - wrap "list" Core.list - wrap "list?" Core.isList - wrap "empty?" Core.isEmpty - wrap "count" Core.count - wrap "=" Core.eq - wrap "<" Core.lt - wrap "<=" Core.le - wrap ">=" Core.ge - wrap ">" Core.gt - wrap "time-ms" Core.time_ms - wrap "pr-str" Core.pr_str - wrap "str" Core.str - wrap "prn" Core.prn - wrap "println" Core.println - wrap "read-string" Core.read_str - wrap "slurp" Core.slurp - wrap "cons" Core.cons - wrap "concat" Core.concat - wrap "vec" Core.vec - wrap "nth" Core.nth - wrap "first" Core.first - wrap "rest" Core.rest - wrap "throw" Core.throw - wrap "map" Core.map - wrap "apply" Core.apply - wrap "nil?" (Core.isConst Node.NIL) - wrap "true?" (Core.isConst Node.TRUE) - wrap "false?" (Core.isConst Node.FALSE) - wrap "symbol?" Core.isSymbol - wrap "symbol" Core.symbol - wrap "string?" Core.isString - wrap "keyword?" Core.isKeyword - wrap "keyword" Core.keyword - wrap "number?" Core.isNumber - wrap "fn?" Core.isFn - wrap "macro?" Core.isMacro - wrap "sequential?" Core.isSequential - wrap "vector?" Core.isVector - wrap "vector" Core.vector - wrap "map?" Core.isMap - wrap "hash-map" Core.hashMap - wrap "assoc" Core.assoc - wrap "dissoc" Core.dissoc - wrap "get" Core.get - wrap "contains?" Core.contains - wrap "keys" Core.keys - wrap "vals" Core.vals - wrap "atom" (Core.atom getNextValue) - wrap "atom?" Core.isAtom - wrap "deref" Core.deref - wrap "reset!" Core.reset - wrap "swap!" Core.swap - wrap "conj" Core.conj - wrap "seq" Core.seq - wrap "meta" Core.meta - wrap "with-meta" Core.withMeta ] - |> ofList - [ env ] - - let makeNew outer symbols nodes = - let env = (makeEmpty ())::outer - let rec loop symbols nodes = - match symbols, nodes with - | [Symbol("&"); Symbol(s)], nodes -> - set env s (Node.makeList nodes) - env - | Symbol("&")::_, _ -> raise <| Error.onlyOneSymbolAfterAmp () - | Symbol(s)::symbols, n::nodes -> - set env s n - loop symbols nodes - | [], [] -> env - | _, [] -> raise <| Error.notEnoughValues () - | [], _ -> raise <| Error.tooManyValues () - | _, _ -> raise <| Error.errExpectedX "symbol" - loop symbols nodes - - (* Active Patterns to help with pattern matching nodes *) - let inline (|IsMacro|_|) env = function - | List(_, Symbol(sym)::rest) -> - match find env sym with - | Some(Macro(_, _, _, _, _, _) as m) -> Some(IsMacro m, rest) - | _ -> None - | _ -> None +module Env + + open Types + + let makeEmpty () = Env() + + let ofList lst = + let env = makeEmpty () + let accumulate (e : Env) (k, v) = e.Add(k, v); e + List.fold accumulate env lst + + let set (env : EnvChain) key node = + match env with + | head::_ -> head.[key] <- node + | _ -> raise <| Error.noEnvironment () + + let rec find (chain : EnvChain) key = + match chain with + | [] -> None + | env::rest -> + match env.TryGetValue(key) with + | true, v -> Some(v) + | false, _ -> find rest key + + let get chain key = + match find chain key with + | Some(v) -> v + | None -> raise <| Error.symbolNotFound key + + let private getNextValue = + let counter = ref 0 + fun () -> System.Threading.Interlocked.Increment(counter) + + let makeBuiltInFunc f = + BuiltInFunc(Node.NIL, getNextValue (), f) + + let makeFunc f body binds env = + Func(Node.NIL, getNextValue (), f, body, binds, env) + + let makeMacro f body binds env = + Macro(Node.NIL, getNextValue (), f, body, binds, env) + + let makeRootEnv () = + let wrap name f = name, makeBuiltInFunc f + let env = + [ wrap "+" Core.add + wrap "-" Core.subtract + wrap "*" Core.multiply + wrap "/" Core.divide + wrap "list" Core.list + wrap "list?" Core.isList + wrap "empty?" Core.isEmpty + wrap "count" Core.count + wrap "=" Core.eq + wrap "<" Core.lt + wrap "<=" Core.le + wrap ">=" Core.ge + wrap ">" Core.gt + wrap "time-ms" Core.time_ms + wrap "pr-str" Core.pr_str + wrap "str" Core.str + wrap "prn" Core.prn + wrap "println" Core.println + wrap "read-string" Core.read_str + wrap "slurp" Core.slurp + wrap "cons" Core.cons + wrap "concat" Core.concat + wrap "vec" Core.vec + wrap "nth" Core.nth + wrap "first" Core.first + wrap "rest" Core.rest + wrap "throw" Core.throw + wrap "map" Core.map + wrap "apply" Core.apply + wrap "nil?" (Core.isConst Node.NIL) + wrap "true?" (Core.isConst Node.TRUE) + wrap "false?" (Core.isConst Node.FALSE) + wrap "symbol?" Core.isSymbol + wrap "symbol" Core.symbol + wrap "string?" Core.isString + wrap "keyword?" Core.isKeyword + wrap "keyword" Core.keyword + wrap "number?" Core.isNumber + wrap "fn?" Core.isFn + wrap "macro?" Core.isMacro + wrap "sequential?" Core.isSequential + wrap "vector?" Core.isVector + wrap "vector" Core.vector + wrap "map?" Core.isMap + wrap "hash-map" Core.hashMap + wrap "assoc" Core.assoc + wrap "dissoc" Core.dissoc + wrap "get" Core.get + wrap "contains?" Core.contains + wrap "keys" Core.keys + wrap "vals" Core.vals + wrap "atom" (Core.atom getNextValue) + wrap "atom?" Core.isAtom + wrap "deref" Core.deref + wrap "reset!" Core.reset + wrap "swap!" Core.swap + wrap "conj" Core.conj + wrap "seq" Core.seq + wrap "meta" Core.meta + wrap "with-meta" Core.withMeta ] + |> ofList + [ env ] + + let makeNew outer symbols nodes = + let env = (makeEmpty ())::outer + let rec loop symbols nodes = + match symbols, nodes with + | [Symbol("&"); Symbol(s)], nodes -> + set env s (Node.makeList nodes) + env + | Symbol("&")::_, _ -> raise <| Error.onlyOneSymbolAfterAmp () + | Symbol(s)::symbols, n::nodes -> + set env s n + loop symbols nodes + | [], [] -> env + | _, [] -> raise <| Error.notEnoughValues () + | [], _ -> raise <| Error.tooManyValues () + | _, _ -> raise <| Error.errExpectedX "symbol" + loop symbols nodes + + (* Active Patterns to help with pattern matching nodes *) + let inline (|IsMacro|_|) env = function + | List(_, Symbol(sym)::rest) -> + match find env sym with + | Some(Macro(_, _, _, _, _, _) as m) -> Some(IsMacro m, rest) + | _ -> None + | _ -> None diff --git a/impls/fsharp/error.fs b/impls/fsharp/error.fs index 11a0c8cbdf..96db75e0fb 100644 --- a/impls/fsharp/error.fs +++ b/impls/fsharp/error.fs @@ -1,21 +1,21 @@ -module Error - - exception ReaderError of string - exception EvalError of string - exception MalError of Types.Node - - let expectedXButEOF x = ReaderError(sprintf "Expected %s, got EOF" x) - let expectedX x = ReaderError(sprintf "Expected %s" x) - let unexpectedChar () = ReaderError("Unexpected char") - let invalidToken () = ReaderError("Invalid token") - - let expectedEvenNodeCount () = EvalError("Expected even node count") - let wrongArity () = EvalError("Arity: wrong number of arguments") - let argMismatch () = EvalError("Argument mismatch") - let symbolNotFound s = EvalError(sprintf "'%s' not found" s) - let noEnvironment () = EvalError("No environment") - let tooManyValues () = EvalError("Too many values") - let notEnoughValues () = EvalError("Not enough values") - let onlyOneSymbolAfterAmp () = EvalError("only one symbol after &") - let errExpectedX x = EvalError(sprintf "expected %s" x) - let indexOutOfBounds () = EvalError("Index out of bounds") +module Error + + exception ReaderError of string + exception EvalError of string + exception MalError of Types.Node + + let expectedXButEOF x = ReaderError(sprintf "Expected %s, got EOF" x) + let expectedX x = ReaderError(sprintf "Expected %s" x) + let unexpectedChar () = ReaderError("Unexpected char") + let invalidToken () = ReaderError("Invalid token") + + let expectedEvenNodeCount () = EvalError("Expected even node count") + let wrongArity () = EvalError("Arity: wrong number of arguments") + let argMismatch () = EvalError("Argument mismatch") + let symbolNotFound s = EvalError(sprintf "'%s' not found" s) + let noEnvironment () = EvalError("No environment") + let tooManyValues () = EvalError("Too many values") + let notEnoughValues () = EvalError("Not enough values") + let onlyOneSymbolAfterAmp () = EvalError("only one symbol after &") + let errExpectedX x = EvalError(sprintf "expected %s" x) + let indexOutOfBounds () = EvalError("Index out of bounds") diff --git a/impls/fsharp/node.fs b/impls/fsharp/node.fs index 94ae61d657..95eeaccb7c 100644 --- a/impls/fsharp/node.fs +++ b/impls/fsharp/node.fs @@ -1,88 +1,88 @@ -module Node - - open Types - - let TRUE = Bool(true) - let SomeTRUE = Some(TRUE) - let FALSE = Bool(false) - let SomeFALSE = Some(FALSE) - let NIL = Nil - let SomeNIL = Some(NIL) - let ZERO = Number(0L) - - let makeVector seg = Vector(NIL, seg) - let makeList lst = List(NIL, lst) - let makeMap map = Map(NIL, map) - - let EmptyLIST = [] |> makeList - let EmptyVECTOR = System.ArraySegment([| |]) |> makeVector - let EmptyMAP = Map.empty |> makeMap - - let ofArray arr = System.ArraySegment(arr) |> makeVector - - let ofChar chr = sprintf "%c" chr |> String - - let toArray = function - | List(_, lst) -> Array.ofList lst - | Vector(_, seg) -> Array.sub seg.Array seg.Offset seg.Count - | node -> [| node |] - - let length = function - | List(_, lst) -> List.length lst - | Vector(_, seg) -> seg.Count - | Map(_, m) -> m.Count - | _ -> 1 - - (* Active Patterns to help with pattern matching nodes *) - let inline (|Elements|_|) num node = - let rec accumList acc idx lst = - let len = Array.length acc - match lst with - | [] when idx = len -> Some(Elements acc) - | h::t when idx < len -> - acc.[idx] <- h - accumList acc (idx + 1) t - | _ -> None - match node with - | List(_, lst) -> accumList (Array.zeroCreate num) 0 lst - | Vector(_, seg) when seg.Count = num -> Some(toArray node) - | _ -> None - - let inline (|Cons|_|) node = - match node with - | List(_, h::t) -> Some(Cons(h, makeList t)) - | Vector(_, seg) when seg.Count > 0 -> - let h = seg.Array.[seg.Offset] - let t = System.ArraySegment(seg.Array, seg.Offset + 1, seg.Count - 1) - |> makeVector - Some(Cons(h, t)) - | _ -> None - - let inline (|Empty|_|) node = - match node with - | List(_, []) -> Some(Empty) - | Vector(_, seg) when seg.Count = 0 -> Some(Empty) - | _ -> None - - let inline (|Pair|_|) node = - match node with - | List(_, a::b::t) -> Some(a, b, makeList t) - | List(_, []) -> None - | List(_, _) -> raise <| Error.expectedEvenNodeCount () - | Vector(_, seg) -> - match seg.Count with - | 0 -> None - | 1 -> raise <| Error.expectedEvenNodeCount () - | _ -> - let a = seg.Array.[seg.Offset] - let b = seg.Array.[seg.Offset + 1] - let t = System.ArraySegment(seg.Array, seg.Offset + 2, seg.Count - 2) - |> makeVector - Some(a, b, t) - | _ -> None - - let inline (|Seq|_|) node = - match node with - | List(_, lst) -> Some(Seq.ofList lst) - | Vector(_, seg) -> Some(seg :> Node seq) - | _ -> None +module Node + + open Types + + let TRUE = Bool(true) + let SomeTRUE = Some(TRUE) + let FALSE = Bool(false) + let SomeFALSE = Some(FALSE) + let NIL = Nil + let SomeNIL = Some(NIL) + let ZERO = Number(0L) + + let makeVector seg = Vector(NIL, seg) + let makeList lst = List(NIL, lst) + let makeMap map = Map(NIL, map) + + let EmptyLIST = [] |> makeList + let EmptyVECTOR = System.ArraySegment([| |]) |> makeVector + let EmptyMAP = Map.empty |> makeMap + + let ofArray arr = System.ArraySegment(arr) |> makeVector + + let ofChar chr = sprintf "%c" chr |> String + + let toArray = function + | List(_, lst) -> Array.ofList lst + | Vector(_, seg) -> Array.sub seg.Array seg.Offset seg.Count + | node -> [| node |] + + let length = function + | List(_, lst) -> List.length lst + | Vector(_, seg) -> seg.Count + | Map(_, m) -> m.Count + | _ -> 1 + + (* Active Patterns to help with pattern matching nodes *) + let inline (|Elements|_|) num node = + let rec accumList acc idx lst = + let len = Array.length acc + match lst with + | [] when idx = len -> Some(Elements acc) + | h::t when idx < len -> + acc.[idx] <- h + accumList acc (idx + 1) t + | _ -> None + match node with + | List(_, lst) -> accumList (Array.zeroCreate num) 0 lst + | Vector(_, seg) when seg.Count = num -> Some(toArray node) + | _ -> None + + let inline (|Cons|_|) node = + match node with + | List(_, h::t) -> Some(Cons(h, makeList t)) + | Vector(_, seg) when seg.Count > 0 -> + let h = seg.Array.[seg.Offset] + let t = System.ArraySegment(seg.Array, seg.Offset + 1, seg.Count - 1) + |> makeVector + Some(Cons(h, t)) + | _ -> None + + let inline (|Empty|_|) node = + match node with + | List(_, []) -> Some(Empty) + | Vector(_, seg) when seg.Count = 0 -> Some(Empty) + | _ -> None + + let inline (|Pair|_|) node = + match node with + | List(_, a::b::t) -> Some(a, b, makeList t) + | List(_, []) -> None + | List(_, _) -> raise <| Error.expectedEvenNodeCount () + | Vector(_, seg) -> + match seg.Count with + | 0 -> None + | 1 -> raise <| Error.expectedEvenNodeCount () + | _ -> + let a = seg.Array.[seg.Offset] + let b = seg.Array.[seg.Offset + 1] + let t = System.ArraySegment(seg.Array, seg.Offset + 2, seg.Count - 2) + |> makeVector + Some(a, b, t) + | _ -> None + + let inline (|Seq|_|) node = + match node with + | List(_, lst) -> Some(Seq.ofList lst) + | Vector(_, seg) -> Some(seg :> Node seq) + | _ -> None diff --git a/impls/fsharp/printer.fs b/impls/fsharp/printer.fs index ffaefb71cf..6905d47f0d 100644 --- a/impls/fsharp/printer.fs +++ b/impls/fsharp/printer.fs @@ -1,87 +1,87 @@ -module Printer - open System.Text - open Types - - type Profile = { Pretty : bool; Separator : string } - let pr_str_profile = { Pretty = true; Separator = " " } - let str_profile = { Pretty = false; Separator = "" } - let prn_profile = { Pretty = true; Separator = " " } - let println_profile = { Pretty = false; Separator = " " } - - let print profile nodes = - let acc = StringBuilder() - let appendStr (str : string) = acc.Append(str) |> ignore - let rec pr_node = function - | Nil -> appendStr "nil" - | List(_, nodes) -> pr_list nodes - | Vector(_, nodes) -> pr_vector nodes - | Map(_, map) -> pr_map map - | Symbol(symbol) -> appendStr symbol - | Keyword(keyword) -> appendStr ":"; appendStr keyword - | Number(num) -> acc.Append(num) |> ignore - | String(str) when profile.Pretty -> pr_str_pretty str - | String(str) -> appendStr str - | Bool(true) -> appendStr "true" - | Bool(false) -> appendStr "false" - | BuiltInFunc(_, tag, _) | Func(_, tag, _, _, _, _) -> - pr_func "func" tag - | Macro(_, tag, _, _, _, _) -> pr_func "macro" tag - | Atom(tag, r) -> pr_atom tag !r - - and pr separator prefix node = - appendStr prefix - pr_node node - separator - - and std_pr = pr " " - - and pr_str_pretty str = - let appendChar = function - | '\t' -> appendStr "\\t" - | '\b' -> appendStr "\\b" - | '\n' -> appendStr "\\n" - | '\r' -> appendStr "\\r" - | '\f' -> appendStr "\\f" - | '"' -> appendStr "\\\"" - | '\\' -> appendStr "\\\\" - | ch -> acc.Append(ch) |> ignore - appendStr "\"" - str |> Seq.iter appendChar - appendStr "\"" - - and pr_func ftype tag = - sprintf "#<%s %d>" ftype tag |> appendStr - - and pr_atom tag node = - appendStr "(atom " - pr_node node - appendStr ")" - - and pr_list nodes = - appendStr "(" - nodes |> List.fold std_pr "" |> ignore - appendStr ")" - - and pr_vector nodes = - appendStr "[" - nodes |> Seq.fold std_pr "" |> ignore - appendStr "]" - - and pr_map map = - let pr prefix key value = - appendStr prefix - pr_node key - appendStr " " - pr_node value - " " - appendStr "{" - map |> Map.fold pr "" |> ignore - appendStr "}" - - nodes |> Seq.fold (pr profile.Separator) "" |> ignore - acc.ToString() - - let pr_str : seq -> string = print pr_str_profile - let str : seq -> string = print str_profile - let prn : seq -> string = print prn_profile - let println : seq -> string = print println_profile +module Printer + open System.Text + open Types + + type Profile = { Pretty : bool; Separator : string } + let pr_str_profile = { Pretty = true; Separator = " " } + let str_profile = { Pretty = false; Separator = "" } + let prn_profile = { Pretty = true; Separator = " " } + let println_profile = { Pretty = false; Separator = " " } + + let print profile nodes = + let acc = StringBuilder() + let appendStr (str : string) = acc.Append(str) |> ignore + let rec pr_node = function + | Nil -> appendStr "nil" + | List(_, nodes) -> pr_list nodes + | Vector(_, nodes) -> pr_vector nodes + | Map(_, map) -> pr_map map + | Symbol(symbol) -> appendStr symbol + | Keyword(keyword) -> appendStr ":"; appendStr keyword + | Number(num) -> acc.Append(num) |> ignore + | String(str) when profile.Pretty -> pr_str_pretty str + | String(str) -> appendStr str + | Bool(true) -> appendStr "true" + | Bool(false) -> appendStr "false" + | BuiltInFunc(_, tag, _) | Func(_, tag, _, _, _, _) -> + pr_func "func" tag + | Macro(_, tag, _, _, _, _) -> pr_func "macro" tag + | Atom(tag, r) -> pr_atom tag !r + + and pr separator prefix node = + appendStr prefix + pr_node node + separator + + and std_pr = pr " " + + and pr_str_pretty str = + let appendChar = function + | '\t' -> appendStr "\\t" + | '\b' -> appendStr "\\b" + | '\n' -> appendStr "\\n" + | '\r' -> appendStr "\\r" + | '\f' -> appendStr "\\f" + | '"' -> appendStr "\\\"" + | '\\' -> appendStr "\\\\" + | ch -> acc.Append(ch) |> ignore + appendStr "\"" + str |> Seq.iter appendChar + appendStr "\"" + + and pr_func ftype tag = + sprintf "#<%s %d>" ftype tag |> appendStr + + and pr_atom tag node = + appendStr "(atom " + pr_node node + appendStr ")" + + and pr_list nodes = + appendStr "(" + nodes |> List.fold std_pr "" |> ignore + appendStr ")" + + and pr_vector nodes = + appendStr "[" + nodes |> Seq.fold std_pr "" |> ignore + appendStr "]" + + and pr_map map = + let pr prefix key value = + appendStr prefix + pr_node key + appendStr " " + pr_node value + " " + appendStr "{" + map |> Map.fold pr "" |> ignore + appendStr "}" + + nodes |> Seq.fold (pr profile.Separator) "" |> ignore + acc.ToString() + + let pr_str : seq -> string = print pr_str_profile + let str : seq -> string = print str_profile + let prn : seq -> string = print prn_profile + let println : seq -> string = print println_profile diff --git a/impls/fsharp/reader.fs b/impls/fsharp/reader.fs index de3c64a628..b7222016a9 100644 --- a/impls/fsharp/reader.fs +++ b/impls/fsharp/reader.fs @@ -1,88 +1,88 @@ -module Reader - open System - open Tokenizer - open Types - open Node - - type MutableList = System.Collections.Generic.List - let inline addToMutableList (lst:MutableList) item = lst.Add(item); lst - - let quote = Symbol("quote") - let quasiquote = Symbol("quasiquote") - let unquote = Symbol("unquote") - let spliceUnquote = Symbol("splice-unquote") - let deref = Symbol("deref") - let withMeta = Symbol("with-meta") - - let rec readForm = function - | OpenParen::rest -> readList [] rest - | OpenBracket::rest -> readVector (MutableList()) rest - | OpenBrace::rest -> readMap [] rest - | SingleQuote::rest -> wrapForm quote rest - | Backtick::rest -> wrapForm quasiquote rest - | Tilde::rest -> wrapForm unquote rest - | SpliceUnquote::rest -> wrapForm spliceUnquote rest - | At::rest -> wrapForm deref rest - | Caret::rest -> readMeta rest - | tokens -> readAtom tokens - - and wrapForm node tokens = - match readForm tokens with - | Some(form), rest -> Some(makeList [node; form]), rest - | None, _ -> raise <| Error.expectedXButEOF "form" - - and readList acc = function - | CloseParen::rest -> Some(acc |> List.rev |> makeList), rest - | [] -> raise <| Error.expectedXButEOF "')'" - | tokens -> - match readForm tokens with - | Some(form), rest -> readList (form::acc) rest - | None, _ -> raise <| Error.expectedXButEOF "')'" - - and readVector acc = function - | CloseBracket::rest -> Some(acc.ToArray() |> Node.ofArray), rest - | [] -> raise <| Error.expectedXButEOF "']'" - | tokens -> - match readForm tokens with - | Some(form), rest -> readVector (addToMutableList acc form) rest - | None, _ -> raise <| Error.expectedXButEOF "']'" - - and readMap acc = function - | CloseBrace::rest -> Some(acc |> List.rev |> Map.ofList |> makeMap), rest - | [] -> raise <| Error.expectedXButEOF "'}'" - | tokens -> - match readForm tokens with - | Some(key), rest -> - match readForm rest with - | Some(v), rest -> readMap ((key, v)::acc) rest - | None, _ -> raise <| Error.expectedXButEOF "'}'" - | None, _ -> raise <| Error.expectedXButEOF "'}'" - - and readMeta = function - | OpenBrace::rest -> - let meta, rest = readMap [] rest - match readForm rest with - | Some(form), rest -> Some([withMeta; form; meta.Value] |> makeList), rest - | None, _ -> raise <| Error.expectedXButEOF "form" - | _ -> raise <| Error.expectedXButEOF "map" - - and readAtom = function - | Token("nil")::rest -> Node.SomeNIL, rest - | Token("true")::rest -> Node.SomeTRUE, rest - | Token("false")::rest -> Node.SomeFALSE, rest - | Tokenizer.String(str)::rest -> Some(String(str)), rest - | Tokenizer.Keyword(kw)::rest -> Some(Keyword(kw)), rest - | Tokenizer.Number(num)::rest -> Some(Number(Int64.Parse(num))), rest - | Token(sym)::rest -> Some(Symbol(sym)), rest - | [] -> None, [] - | _ -> raise <| Error.invalidToken () - - let rec readForms acc = function - | [] -> List.rev acc - | tokens -> - match readForm tokens with - | Some(form), rest -> readForms (form::acc) rest - | None, rest -> readForms acc rest - - let read_str str = - tokenize str |> readForms [] +module Reader + open System + open Tokenizer + open Types + open Node + + type MutableList = System.Collections.Generic.List + let inline addToMutableList (lst:MutableList) item = lst.Add(item); lst + + let quote = Symbol("quote") + let quasiquote = Symbol("quasiquote") + let unquote = Symbol("unquote") + let spliceUnquote = Symbol("splice-unquote") + let deref = Symbol("deref") + let withMeta = Symbol("with-meta") + + let rec readForm = function + | OpenParen::rest -> readList [] rest + | OpenBracket::rest -> readVector (MutableList()) rest + | OpenBrace::rest -> readMap [] rest + | SingleQuote::rest -> wrapForm quote rest + | Backtick::rest -> wrapForm quasiquote rest + | Tilde::rest -> wrapForm unquote rest + | SpliceUnquote::rest -> wrapForm spliceUnquote rest + | At::rest -> wrapForm deref rest + | Caret::rest -> readMeta rest + | tokens -> readAtom tokens + + and wrapForm node tokens = + match readForm tokens with + | Some(form), rest -> Some(makeList [node; form]), rest + | None, _ -> raise <| Error.expectedXButEOF "form" + + and readList acc = function + | CloseParen::rest -> Some(acc |> List.rev |> makeList), rest + | [] -> raise <| Error.expectedXButEOF "')'" + | tokens -> + match readForm tokens with + | Some(form), rest -> readList (form::acc) rest + | None, _ -> raise <| Error.expectedXButEOF "')'" + + and readVector acc = function + | CloseBracket::rest -> Some(acc.ToArray() |> Node.ofArray), rest + | [] -> raise <| Error.expectedXButEOF "']'" + | tokens -> + match readForm tokens with + | Some(form), rest -> readVector (addToMutableList acc form) rest + | None, _ -> raise <| Error.expectedXButEOF "']'" + + and readMap acc = function + | CloseBrace::rest -> Some(acc |> List.rev |> Map.ofList |> makeMap), rest + | [] -> raise <| Error.expectedXButEOF "'}'" + | tokens -> + match readForm tokens with + | Some(key), rest -> + match readForm rest with + | Some(v), rest -> readMap ((key, v)::acc) rest + | None, _ -> raise <| Error.expectedXButEOF "'}'" + | None, _ -> raise <| Error.expectedXButEOF "'}'" + + and readMeta = function + | OpenBrace::rest -> + let meta, rest = readMap [] rest + match readForm rest with + | Some(form), rest -> Some([withMeta; form; meta.Value] |> makeList), rest + | None, _ -> raise <| Error.expectedXButEOF "form" + | _ -> raise <| Error.expectedXButEOF "map" + + and readAtom = function + | Token("nil")::rest -> Node.SomeNIL, rest + | Token("true")::rest -> Node.SomeTRUE, rest + | Token("false")::rest -> Node.SomeFALSE, rest + | Tokenizer.String(str)::rest -> Some(String(str)), rest + | Tokenizer.Keyword(kw)::rest -> Some(Keyword(kw)), rest + | Tokenizer.Number(num)::rest -> Some(Number(Int64.Parse(num))), rest + | Token(sym)::rest -> Some(Symbol(sym)), rest + | [] -> None, [] + | _ -> raise <| Error.invalidToken () + + let rec readForms acc = function + | [] -> List.rev acc + | tokens -> + match readForm tokens with + | Some(form), rest -> readForms (form::acc) rest + | None, rest -> readForms acc rest + + let read_str str = + tokenize str |> readForms [] diff --git a/impls/fsharp/readline.fs b/impls/fsharp/readline.fs index fe02ed4357..f1209c0974 100644 --- a/impls/fsharp/readline.fs +++ b/impls/fsharp/readline.fs @@ -1,16 +1,16 @@ -module Readline - open System - open Mono.Terminal - - type Mode = - | Terminal - | Raw - - let read prompt = function - | Terminal - -> let editor = LineEditor("Mal") - editor.Edit(prompt, "") - | Raw - -> Console.Write(prompt) - Console.Out.Flush() - Console.ReadLine() +module Readline + open System + open Mono.Terminal + + type Mode = + | Terminal + | Raw + + let read prompt = function + | Terminal + -> let editor = LineEditor("Mal") + editor.Edit(prompt, "") + | Raw + -> Console.Write(prompt) + Console.Out.Flush() + Console.ReadLine() diff --git a/impls/fsharp/run b/impls/fsharp/run index fa517a6ec7..6292af1203 100755 --- a/impls/fsharp/run +++ b/impls/fsharp/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec mono $(dirname $0)/${STEP:-stepA_mal}.exe ${RAW:+--raw} "${@}" +#!/bin/bash +exec mono $(dirname $0)/${STEP:-stepA_mal}.exe ${RAW:+--raw} "${@}" diff --git a/impls/fsharp/step0_repl.fs b/impls/fsharp/step0_repl.fs index 6d8d4574b1..73f8f7663f 100644 --- a/impls/fsharp/step0_repl.fs +++ b/impls/fsharp/step0_repl.fs @@ -1,30 +1,30 @@ -module REPL - let READ input = - input - - let EVAL ast = - ast - - let PRINT v = - printfn "%s" v - - let REP input = - input - |> READ - |> EVAL - |> PRINT - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - [] - let rec main args = - let mode = getReadlineMode args - match Readline.read "user> " mode with - | null -> 0 - | input -> - REP input - main args +module REPL + let READ input = + input + + let EVAL ast = + ast + + let PRINT v = + printfn "%s" v + + let REP input = + input + |> READ + |> EVAL + |> PRINT + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + [] + let rec main args = + let mode = getReadlineMode args + match Readline.read "user> " mode with + | null -> 0 + | input -> + REP input + main args diff --git a/impls/fsharp/step1_read_print.fs b/impls/fsharp/step1_read_print.fs index 1ce61408ff..08ec0a6aa3 100644 --- a/impls/fsharp/step1_read_print.fs +++ b/impls/fsharp/step1_read_print.fs @@ -1,43 +1,43 @@ -module REPL - open System - - let READ input = - try - Reader.read_str input - with - | Error.ReaderError(msg) -> - printfn "%s" msg - [] - - let EVAL ast = - Some(ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let REP input = - READ input - |> Seq.ofList - |> Seq.map (fun form -> EVAL form) - |> Seq.filter Option.isSome - |> Seq.iter (fun value -> PRINT value.Value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - [] - let main args = - let mode = getReadlineMode args - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - REP input - loop() - loop () +module REPL + open System + + let READ input = + try + Reader.read_str input + with + | Error.ReaderError(msg) -> + printfn "%s" msg + [] + + let EVAL ast = + Some(ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let REP input = + READ input + |> Seq.ofList + |> Seq.map (fun form -> EVAL form) + |> Seq.filter Option.isSome + |> Seq.iter (fun value -> PRINT value.Value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + [] + let main args = + let mode = getReadlineMode args + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + REP input + loop() + loop () diff --git a/impls/fsharp/step2_eval.fs b/impls/fsharp/step2_eval.fs index 62bdc4299d..11dae9b6e8 100644 --- a/impls/fsharp/step2_eval.fs +++ b/impls/fsharp/step2_eval.fs @@ -1,63 +1,63 @@ -module REPL - open System - open Node - open Types - - let rec eval_ast env = function - | Symbol(sym) -> Env.get env sym - | List(_, lst) -> lst |> List.map (eval env) |> makeList - | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray - | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap - | node -> node - - and eval env = function - | List(_, []) as emptyList -> emptyList - | List(_, _) as node -> - let resolved = node |> eval_ast env - match resolved with - | List(_, BuiltInFunc(_, _, f)::rest) -> f rest - | _ -> raise <| Error.errExpectedX "func" - | node -> node |> eval_ast env - - let READ input = - Reader.read_str input - - let EVAL env ast = - Some(eval env ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let REP env input = - READ input - |> Seq.ofList - |> Seq.choose (fun form -> EVAL env form) - |> Seq.iter (fun value -> PRINT value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - [] - let main args = - let mode = getReadlineMode args - let env = Env.makeRootEnv () - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - try - REP env input - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "Error: %s" str - | ex -> - printfn "Error: %s" (ex.Message) - loop () - loop () +module REPL + open System + open Node + open Types + + let rec eval_ast env = function + | Symbol(sym) -> Env.get env sym + | List(_, lst) -> lst |> List.map (eval env) |> makeList + | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray + | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap + | node -> node + + and eval env = function + | List(_, []) as emptyList -> emptyList + | List(_, _) as node -> + let resolved = node |> eval_ast env + match resolved with + | List(_, BuiltInFunc(_, _, f)::rest) -> f rest + | _ -> raise <| Error.errExpectedX "func" + | node -> node |> eval_ast env + + let READ input = + Reader.read_str input + + let EVAL env ast = + Some(eval env ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let REP env input = + READ input + |> Seq.ofList + |> Seq.choose (fun form -> EVAL env form) + |> Seq.iter (fun value -> PRINT value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + [] + let main args = + let mode = getReadlineMode args + let env = Env.makeRootEnv () + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/impls/fsharp/step3_env.fs b/impls/fsharp/step3_env.fs index db6408f4cd..88b3e6eaa7 100644 --- a/impls/fsharp/step3_env.fs +++ b/impls/fsharp/step3_env.fs @@ -1,99 +1,99 @@ -module REPL - open System - open Node - open Types - - let rec iterPairs f = function - | Pair(first, second, t) -> - f first second - iterPairs f t - | Empty -> () - | _ -> raise <| Error.errExpectedX "list or vector" - - let rec eval_ast env = function - | Symbol(sym) -> Env.get env sym - | List(_, lst) -> lst |> List.map (eval env) |> makeList - | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray - | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap - | node -> node - - and defBang env = function - | [sym; node] -> - match sym with - | Symbol(sym) -> - let node = eval env node - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and setBinding env first second = - let s = match first with - | Symbol(s) -> s - | _ -> raise <| Error.errExpectedX "symbol" - let form = eval env second - Env.set env s form - - and letStar env = function - | [bindings; form] -> - let newEnv = Env.makeNew env [] [] - let binder = setBinding newEnv - match bindings with - | List(_, _) | Vector(_, _) -> iterPairs binder bindings - | _ -> raise <| Error.errExpectedX "list or vector" - eval newEnv form - | _ -> raise <| Error.wrongArity () - - and eval env = function - | List(_, []) as emptyList -> emptyList - | List(_, Symbol("def!")::rest) -> defBang env rest - | List(_, Symbol("let*")::rest) -> letStar env rest - | List(_, _) as node -> - let resolved = node |> eval_ast env - match resolved with - | List(_, BuiltInFunc(_, _, f)::rest) -> f rest - | _ -> raise <| Error.errExpectedX "func" - | node -> node |> eval_ast env - - let READ input = - Reader.read_str input - - let EVAL env ast = - Some(eval env ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let REP env input = - READ input - |> Seq.ofList - |> Seq.choose (fun form -> EVAL env form) - |> Seq.iter (fun value -> PRINT value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - [] - let main args = - let mode = getReadlineMode args - let env = Env.makeRootEnv () - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - try - REP env input - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "Error: %s" str - | ex -> - printfn "Error: %s" (ex.Message) - loop () - loop () +module REPL + open System + open Node + open Types + + let rec iterPairs f = function + | Pair(first, second, t) -> + f first second + iterPairs f t + | Empty -> () + | _ -> raise <| Error.errExpectedX "list or vector" + + let rec eval_ast env = function + | Symbol(sym) -> Env.get env sym + | List(_, lst) -> lst |> List.map (eval env) |> makeList + | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray + | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap + | node -> node + + and defBang env = function + | [sym; node] -> + match sym with + | Symbol(sym) -> + let node = eval env node + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and setBinding env first second = + let s = match first with + | Symbol(s) -> s + | _ -> raise <| Error.errExpectedX "symbol" + let form = eval env second + Env.set env s form + + and letStar env = function + | [bindings; form] -> + let newEnv = Env.makeNew env [] [] + let binder = setBinding newEnv + match bindings with + | List(_, _) | Vector(_, _) -> iterPairs binder bindings + | _ -> raise <| Error.errExpectedX "list or vector" + eval newEnv form + | _ -> raise <| Error.wrongArity () + + and eval env = function + | List(_, []) as emptyList -> emptyList + | List(_, Symbol("def!")::rest) -> defBang env rest + | List(_, Symbol("let*")::rest) -> letStar env rest + | List(_, _) as node -> + let resolved = node |> eval_ast env + match resolved with + | List(_, BuiltInFunc(_, _, f)::rest) -> f rest + | _ -> raise <| Error.errExpectedX "func" + | node -> node |> eval_ast env + + let READ input = + Reader.read_str input + + let EVAL env ast = + Some(eval env ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let REP env input = + READ input + |> Seq.ofList + |> Seq.choose (fun form -> EVAL env form) + |> Seq.iter (fun value -> PRINT value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + [] + let main args = + let mode = getReadlineMode args + let env = Env.makeRootEnv () + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/impls/fsharp/step4_if_fn_do.fs b/impls/fsharp/step4_if_fn_do.fs index 8b48f64b65..e6c264a5d2 100644 --- a/impls/fsharp/step4_if_fn_do.fs +++ b/impls/fsharp/step4_if_fn_do.fs @@ -1,142 +1,142 @@ -module REPL - open System - open Node - open Types - - let rec iterPairs f = function - | Pair(first, second, t) -> - f first second - iterPairs f t - | Empty -> () - | _ -> raise <| Error.errExpectedX "list or vector" - - let rec eval_ast env = function - | Symbol(sym) -> Env.get env sym - | List(_, lst) -> lst |> List.map (eval env) |> makeList - | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray - | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap - | node -> node - - and defBangForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and setBinding env first second = - let s = match first with - | Symbol(s) -> s - | _ -> raise <| Error.errExpectedX "symbol" - let form = eval env second - Env.set env s form - - and letStarForm env = function - | [bindings; form] -> - let newEnv = Env.makeNew env [] [] - let binder = setBinding newEnv - match bindings with - | List(_, _) | Vector(_, _) -> iterPairs binder bindings - | _ -> raise <| Error.errExpectedX "list or vector" - eval newEnv form - | _ -> raise <| Error.wrongArity () - - and ifForm env = function - | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm - | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil - | _ -> raise <| Error.wrongArity () - - and ifForm3 env condForm trueForm falseForm = - match eval env condForm with - | Bool(false) | Nil -> eval env falseForm - | _ -> eval env trueForm - - and doForm env = function - | [a] -> eval env a - | a::rest -> - eval env a |> ignore - doForm env rest - | _ -> raise <| Error.wrongArity () - - and fnStarForm outer nodes = - let makeFunc binds body = - let f = fun nodes -> - let inner = Env.makeNew outer binds nodes - eval inner body - Env.makeFunc f body binds outer - - match nodes with - | [List(_, binds); body] -> makeFunc binds body - | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body - | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" - | _ -> raise <| Error.wrongArity () - - and eval env = function - | List(_, []) as emptyList -> emptyList - | List(_, Symbol("def!")::rest) -> defBangForm env rest - | List(_, Symbol("let*")::rest) -> letStarForm env rest - | List(_, Symbol("if")::rest) -> ifForm env rest - | List(_, Symbol("do")::rest) -> doForm env rest - | List(_, Symbol("fn*")::rest) -> fnStarForm env rest - | List(_, _) as node -> - let resolved = node |> eval_ast env - match resolved with - | List(_, BuiltInFunc(_, _, f)::rest) -> f rest - | List(_, Func(_, _, _, body, binds, outer)::rest) -> - let inner = Env.makeNew outer binds rest - body |> eval inner - | _ -> raise <| Error.errExpectedX "func" - | node -> node |> eval_ast env - - let READ input = - Reader.read_str input - - let EVAL env ast = - Some(eval env ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let RE env input = - READ input - |> Seq.ofList - |> Seq.choose (fun form -> EVAL env form) - - let REP env input = - input - |> RE env - |> Seq.iter (fun value -> PRINT value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - [] - let main args = - let mode = getReadlineMode args - let env = Env.makeRootEnv () - - RE env "(def! not (fn* (a) (if a false true)))" |> Seq.iter ignore - - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - try - REP env input - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "Error: %s" str - | ex -> - printfn "Error: %s" (ex.Message) - loop () - loop () +module REPL + open System + open Node + open Types + + let rec iterPairs f = function + | Pair(first, second, t) -> + f first second + iterPairs f t + | Empty -> () + | _ -> raise <| Error.errExpectedX "list or vector" + + let rec eval_ast env = function + | Symbol(sym) -> Env.get env sym + | List(_, lst) -> lst |> List.map (eval env) |> makeList + | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray + | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap + | node -> node + + and defBangForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and setBinding env first second = + let s = match first with + | Symbol(s) -> s + | _ -> raise <| Error.errExpectedX "symbol" + let form = eval env second + Env.set env s form + + and letStarForm env = function + | [bindings; form] -> + let newEnv = Env.makeNew env [] [] + let binder = setBinding newEnv + match bindings with + | List(_, _) | Vector(_, _) -> iterPairs binder bindings + | _ -> raise <| Error.errExpectedX "list or vector" + eval newEnv form + | _ -> raise <| Error.wrongArity () + + and ifForm env = function + | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm + | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil + | _ -> raise <| Error.wrongArity () + + and ifForm3 env condForm trueForm falseForm = + match eval env condForm with + | Bool(false) | Nil -> eval env falseForm + | _ -> eval env trueForm + + and doForm env = function + | [a] -> eval env a + | a::rest -> + eval env a |> ignore + doForm env rest + | _ -> raise <| Error.wrongArity () + + and fnStarForm outer nodes = + let makeFunc binds body = + let f = fun nodes -> + let inner = Env.makeNew outer binds nodes + eval inner body + Env.makeFunc f body binds outer + + match nodes with + | [List(_, binds); body] -> makeFunc binds body + | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body + | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" + | _ -> raise <| Error.wrongArity () + + and eval env = function + | List(_, []) as emptyList -> emptyList + | List(_, Symbol("def!")::rest) -> defBangForm env rest + | List(_, Symbol("let*")::rest) -> letStarForm env rest + | List(_, Symbol("if")::rest) -> ifForm env rest + | List(_, Symbol("do")::rest) -> doForm env rest + | List(_, Symbol("fn*")::rest) -> fnStarForm env rest + | List(_, _) as node -> + let resolved = node |> eval_ast env + match resolved with + | List(_, BuiltInFunc(_, _, f)::rest) -> f rest + | List(_, Func(_, _, _, body, binds, outer)::rest) -> + let inner = Env.makeNew outer binds rest + body |> eval inner + | _ -> raise <| Error.errExpectedX "func" + | node -> node |> eval_ast env + + let READ input = + Reader.read_str input + + let EVAL env ast = + Some(eval env ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let RE env input = + READ input + |> Seq.ofList + |> Seq.choose (fun form -> EVAL env form) + + let REP env input = + input + |> RE env + |> Seq.iter (fun value -> PRINT value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + [] + let main args = + let mode = getReadlineMode args + let env = Env.makeRootEnv () + + RE env "(def! not (fn* (a) (if a false true)))" |> Seq.iter ignore + + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/impls/fsharp/step5_tco.fs b/impls/fsharp/step5_tco.fs index 1c82c67a93..4a60c0b28e 100644 --- a/impls/fsharp/step5_tco.fs +++ b/impls/fsharp/step5_tco.fs @@ -1,144 +1,144 @@ -module REPL - open System - open Node - open Types - - let rec iterPairs f = function - | Pair(first, second, t) -> - f first second - iterPairs f t - | Empty -> () - | _ -> raise <| Error.errExpectedX "list or vector" - - let rec eval_ast env = function - | Symbol(sym) -> Env.get env sym - | List(_, lst) -> lst |> List.map (eval env) |> makeList - | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray - | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap - | node -> node - - and defBangForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and setBinding env first second = - let s = match first with - | Symbol(s) -> s - | _ -> raise <| Error.errExpectedX "symbol" - let form = eval env second - Env.set env s form - - and letStarForm outer = function - | [bindings; form] -> - let inner = Env.makeNew outer [] [] - let binder = setBinding inner - match bindings with - | List(_, _) | Vector(_, _)-> iterPairs binder bindings - | _ -> raise <| Error.errExpectedX "list or vector" - inner, form - | _ -> raise <| Error.wrongArity () - - and ifForm env = function - | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm - | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil - | _ -> raise <| Error.wrongArity () - - and ifForm3 env condForm trueForm falseForm = - match eval env condForm with - | Bool(false) | Nil -> falseForm - | _ -> trueForm - - and doForm env = function - | [a] -> a - | a::rest -> - eval env a |> ignore - doForm env rest - | _ -> raise <| Error.wrongArity () - - and fnStarForm outer nodes = - let makeFunc binds body = - let f = fun nodes -> - let inner = Env.makeNew outer binds nodes - eval inner body - Env.makeFunc f body binds outer - - match nodes with - | [List(_, binds); body] -> makeFunc binds body - | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body - | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" - | _ -> raise <| Error.wrongArity () - - and eval env = function - | List(_, []) as emptyList -> emptyList - | List(_, Symbol("def!")::rest) -> defBangForm env rest - | List(_, Symbol("let*")::rest) -> - let inner, form = letStarForm env rest - form |> eval inner - | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env - | List(_, Symbol("do")::rest) -> doForm env rest |> eval env - | List(_, Symbol("fn*")::rest) -> fnStarForm env rest - | List(_, _) as node -> - let resolved = node |> eval_ast env - match resolved with - | List(_, BuiltInFunc(_, _, f)::rest) -> f rest - | List(_, Func(_, _, _, body, binds, outer)::rest) -> - let inner = Env.makeNew outer binds rest - body |> eval inner - | _ -> raise <| Error.errExpectedX "func" - | node -> node |> eval_ast env - - let READ input = - Reader.read_str input - - let EVAL env ast = - Some(eval env ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let RE env input = - READ input - |> Seq.ofList - |> Seq.choose (fun form -> EVAL env form) - - let REP env input = - input - |> RE env - |> Seq.iter (fun value -> PRINT value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - [] - let main args = - let mode = getReadlineMode args - let env = Env.makeRootEnv () - - RE env "(def! not (fn* (a) (if a false true)))" |> Seq.iter ignore - - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - try - REP env input - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "Error: %s" str - | ex -> - printfn "Error: %s" (ex.Message) - loop () - loop () +module REPL + open System + open Node + open Types + + let rec iterPairs f = function + | Pair(first, second, t) -> + f first second + iterPairs f t + | Empty -> () + | _ -> raise <| Error.errExpectedX "list or vector" + + let rec eval_ast env = function + | Symbol(sym) -> Env.get env sym + | List(_, lst) -> lst |> List.map (eval env) |> makeList + | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray + | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap + | node -> node + + and defBangForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and setBinding env first second = + let s = match first with + | Symbol(s) -> s + | _ -> raise <| Error.errExpectedX "symbol" + let form = eval env second + Env.set env s form + + and letStarForm outer = function + | [bindings; form] -> + let inner = Env.makeNew outer [] [] + let binder = setBinding inner + match bindings with + | List(_, _) | Vector(_, _)-> iterPairs binder bindings + | _ -> raise <| Error.errExpectedX "list or vector" + inner, form + | _ -> raise <| Error.wrongArity () + + and ifForm env = function + | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm + | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil + | _ -> raise <| Error.wrongArity () + + and ifForm3 env condForm trueForm falseForm = + match eval env condForm with + | Bool(false) | Nil -> falseForm + | _ -> trueForm + + and doForm env = function + | [a] -> a + | a::rest -> + eval env a |> ignore + doForm env rest + | _ -> raise <| Error.wrongArity () + + and fnStarForm outer nodes = + let makeFunc binds body = + let f = fun nodes -> + let inner = Env.makeNew outer binds nodes + eval inner body + Env.makeFunc f body binds outer + + match nodes with + | [List(_, binds); body] -> makeFunc binds body + | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body + | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" + | _ -> raise <| Error.wrongArity () + + and eval env = function + | List(_, []) as emptyList -> emptyList + | List(_, Symbol("def!")::rest) -> defBangForm env rest + | List(_, Symbol("let*")::rest) -> + let inner, form = letStarForm env rest + form |> eval inner + | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env + | List(_, Symbol("do")::rest) -> doForm env rest |> eval env + | List(_, Symbol("fn*")::rest) -> fnStarForm env rest + | List(_, _) as node -> + let resolved = node |> eval_ast env + match resolved with + | List(_, BuiltInFunc(_, _, f)::rest) -> f rest + | List(_, Func(_, _, _, body, binds, outer)::rest) -> + let inner = Env.makeNew outer binds rest + body |> eval inner + | _ -> raise <| Error.errExpectedX "func" + | node -> node |> eval_ast env + + let READ input = + Reader.read_str input + + let EVAL env ast = + Some(eval env ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let RE env input = + READ input + |> Seq.ofList + |> Seq.choose (fun form -> EVAL env form) + + let REP env input = + input + |> RE env + |> Seq.iter (fun value -> PRINT value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + [] + let main args = + let mode = getReadlineMode args + let env = Env.makeRootEnv () + + RE env "(def! not (fn* (a) (if a false true)))" |> Seq.iter ignore + + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/impls/fsharp/step6_file.fs b/impls/fsharp/step6_file.fs index 92f2072fdd..99690caf4a 100644 --- a/impls/fsharp/step6_file.fs +++ b/impls/fsharp/step6_file.fs @@ -1,170 +1,170 @@ -module REPL - open System - open Node - open Types - - let rec iterPairs f = function - | Pair(first, second, t) -> - f first second - iterPairs f t - | Empty -> () - | _ -> raise <| Error.errExpectedX "list or vector" - - let rec eval_ast env = function - | Symbol(sym) -> Env.get env sym - | List(_, lst) -> lst |> List.map (eval env) |> makeList - | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray - | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap - | node -> node - - and defBangForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and setBinding env first second = - let s = match first with - | Symbol(s) -> s - | _ -> raise <| Error.errExpectedX "symbol" - let form = eval env second - Env.set env s form - - and letStarForm outer = function - | [bindings; form] -> - let inner = Env.makeNew outer [] [] - let binder = setBinding inner - match bindings with - | List(_, _) | Vector(_, _)-> iterPairs binder bindings - | _ -> raise <| Error.errExpectedX "list or vector" - inner, form - | _ -> raise <| Error.wrongArity () - - and ifForm env = function - | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm - | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil - | _ -> raise <| Error.wrongArity () - - and ifForm3 env condForm trueForm falseForm = - match eval env condForm with - | Bool(false) | Nil -> falseForm - | _ -> trueForm - - and doForm env = function - | [a] -> a - | a::rest -> - eval env a |> ignore - doForm env rest - | _ -> raise <| Error.wrongArity () - - and fnStarForm outer nodes = - let makeFunc binds body = - let f = fun nodes -> - let inner = Env.makeNew outer binds nodes - eval inner body - Env.makeFunc f body binds outer - - match nodes with - | [List(_, binds); body] -> makeFunc binds body - | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body - | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" - | _ -> raise <| Error.wrongArity () - - and eval env = function - | List(_, []) as emptyList -> emptyList - | List(_, Symbol("def!")::rest) -> defBangForm env rest - | List(_, Symbol("let*")::rest) -> - let inner, form = letStarForm env rest - form |> eval inner - | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env - | List(_, Symbol("do")::rest) -> doForm env rest |> eval env - | List(_, Symbol("fn*")::rest) -> fnStarForm env rest - | List(_, _) as node -> - let resolved = node |> eval_ast env - match resolved with - | List(_, BuiltInFunc(_, _, f)::rest) -> f rest - | List(_, Func(_, _, _, body, binds, outer)::rest) -> - let inner = Env.makeNew outer binds rest - body |> eval inner - | _ -> raise <| Error.errExpectedX "func" - | node -> node |> eval_ast env - - let READ input = - Reader.read_str input - - let EVAL env ast = - Some(eval env ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let RE env input = - READ input - |> Seq.ofList - |> Seq.choose (fun form -> EVAL env form) - - let REP env input = - input - |> RE env - |> Seq.iter (fun value -> PRINT value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - let eval_func env = function - | [ast] -> eval env ast - | _ -> raise <| Error.wrongArity () - - let argv_func = function - | file::rest -> rest |> List.map Types.String |> makeList - | [] -> EmptyLIST - - let configureEnv args = - let env = Env.makeRootEnv () - - Env.set env "eval" <| Env.makeBuiltInFunc (fun nodes -> eval_func env nodes) - Env.set env "*ARGV*" <| argv_func args - - RE env """ - (def! not (fn* (a) (if a false true))) - (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - """ |> Seq.iter ignore - - env - - [] - let main args = - let mode = getReadlineMode args - let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq - let env = configureEnv args - - match args with - | file::_ -> - System.IO.File.ReadAllText file - |> RE env |> Seq.iter ignore - 0 - | _ -> - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - try - REP env input - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "Error: %s" str - | ex -> - printfn "Error: %s" (ex.Message) - loop () - loop () +module REPL + open System + open Node + open Types + + let rec iterPairs f = function + | Pair(first, second, t) -> + f first second + iterPairs f t + | Empty -> () + | _ -> raise <| Error.errExpectedX "list or vector" + + let rec eval_ast env = function + | Symbol(sym) -> Env.get env sym + | List(_, lst) -> lst |> List.map (eval env) |> makeList + | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray + | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap + | node -> node + + and defBangForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and setBinding env first second = + let s = match first with + | Symbol(s) -> s + | _ -> raise <| Error.errExpectedX "symbol" + let form = eval env second + Env.set env s form + + and letStarForm outer = function + | [bindings; form] -> + let inner = Env.makeNew outer [] [] + let binder = setBinding inner + match bindings with + | List(_, _) | Vector(_, _)-> iterPairs binder bindings + | _ -> raise <| Error.errExpectedX "list or vector" + inner, form + | _ -> raise <| Error.wrongArity () + + and ifForm env = function + | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm + | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil + | _ -> raise <| Error.wrongArity () + + and ifForm3 env condForm trueForm falseForm = + match eval env condForm with + | Bool(false) | Nil -> falseForm + | _ -> trueForm + + and doForm env = function + | [a] -> a + | a::rest -> + eval env a |> ignore + doForm env rest + | _ -> raise <| Error.wrongArity () + + and fnStarForm outer nodes = + let makeFunc binds body = + let f = fun nodes -> + let inner = Env.makeNew outer binds nodes + eval inner body + Env.makeFunc f body binds outer + + match nodes with + | [List(_, binds); body] -> makeFunc binds body + | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body + | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" + | _ -> raise <| Error.wrongArity () + + and eval env = function + | List(_, []) as emptyList -> emptyList + | List(_, Symbol("def!")::rest) -> defBangForm env rest + | List(_, Symbol("let*")::rest) -> + let inner, form = letStarForm env rest + form |> eval inner + | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env + | List(_, Symbol("do")::rest) -> doForm env rest |> eval env + | List(_, Symbol("fn*")::rest) -> fnStarForm env rest + | List(_, _) as node -> + let resolved = node |> eval_ast env + match resolved with + | List(_, BuiltInFunc(_, _, f)::rest) -> f rest + | List(_, Func(_, _, _, body, binds, outer)::rest) -> + let inner = Env.makeNew outer binds rest + body |> eval inner + | _ -> raise <| Error.errExpectedX "func" + | node -> node |> eval_ast env + + let READ input = + Reader.read_str input + + let EVAL env ast = + Some(eval env ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let RE env input = + READ input + |> Seq.ofList + |> Seq.choose (fun form -> EVAL env form) + + let REP env input = + input + |> RE env + |> Seq.iter (fun value -> PRINT value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + let eval_func env = function + | [ast] -> eval env ast + | _ -> raise <| Error.wrongArity () + + let argv_func = function + | file::rest -> rest |> List.map Types.String |> makeList + | [] -> EmptyLIST + + let configureEnv args = + let env = Env.makeRootEnv () + + Env.set env "eval" <| Env.makeBuiltInFunc (fun nodes -> eval_func env nodes) + Env.set env "*ARGV*" <| argv_func args + + RE env """ + (def! not (fn* (a) (if a false true))) + (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + """ |> Seq.iter ignore + + env + + [] + let main args = + let mode = getReadlineMode args + let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq + let env = configureEnv args + + match args with + | file::_ -> + System.IO.File.ReadAllText file + |> RE env |> Seq.iter ignore + 0 + | _ -> + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/impls/fsharp/step7_quote.fs b/impls/fsharp/step7_quote.fs index 83fe274ba3..acc6d738ad 100644 --- a/impls/fsharp/step7_quote.fs +++ b/impls/fsharp/step7_quote.fs @@ -1,196 +1,196 @@ -module REPL - open System - open Node - open Types - - let rec iterPairs f = function - | Pair(first, second, t) -> - f first second - iterPairs f t - | Empty -> () - | _ -> raise <| Error.errExpectedX "list or vector" - - let rec qqLoop elt acc = - match elt with - | List(_, [Symbol("splice-unquote");list]) -> makeList [Symbol "concat"; list; acc] - | List(_, Symbol("splice-unquote")::_) -> raise <| Error.wrongArity () - | _ -> makeList [Symbol "cons"; quasiquote elt; acc] - and quasiquote = function - | List(_, [Symbol("unquote");form]) -> form - | List(_, Symbol("unquote")::_) -> raise <| Error.wrongArity () - | List (_, list) -> List.foldBack qqLoop list Node.EmptyLIST - | Vector(_, segment) -> - let array = Array.sub segment.Array segment.Offset segment.Count - let folded = Array.foldBack qqLoop array Node.EmptyLIST - makeList [Symbol "vec"; folded] - | Map(_) as ast -> makeList [Symbol "quote"; ast] - | Symbol(_) as ast -> makeList [Symbol "quote"; ast] - | ast -> ast - - let quoteForm = function - | [node] -> node - | _ -> raise <| Error.wrongArity () - - let rec eval_ast env = function - | Symbol(sym) -> Env.get env sym - | List(_, lst) -> lst |> List.map (eval env) |> makeList - | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray - | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap - | node -> node - - and defBangForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and setBinding env first second = - let s = match first with - | Symbol(s) -> s - | _ -> raise <| Error.errExpectedX "symbol" - let form = eval env second - Env.set env s form - - and letStarForm outer = function - | [bindings; form] -> - let inner = Env.makeNew outer [] [] - let binder = setBinding inner - match bindings with - | List(_) | Vector(_) -> iterPairs binder bindings - | _ -> raise <| Error.errExpectedX "list or vector" - inner, form - | _ -> raise <| Error.wrongArity () - - and ifForm env = function - | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm - | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil - | _ -> raise <| Error.wrongArity () - - and ifForm3 env condForm trueForm falseForm = - match eval env condForm with - | Bool(false) | Nil -> falseForm - | _ -> trueForm - - and doForm env = function - | [a] -> a - | a::rest -> - eval env a |> ignore - doForm env rest - | _ -> raise <| Error.wrongArity () - - and fnStarForm outer nodes = - let makeFunc binds body = - let f = fun nodes -> - let inner = Env.makeNew outer binds nodes - eval inner body - Env.makeFunc f body binds outer - - match nodes with - | [List(_, binds); body] -> makeFunc binds body - | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body - | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" - | _ -> raise <| Error.wrongArity () - - and eval env = function - | List(_, []) as emptyList -> emptyList - | List(_, Symbol("def!")::rest) -> defBangForm env rest - | List(_, Symbol("let*")::rest) -> - let inner, form = letStarForm env rest - form |> eval inner - | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env - | List(_, Symbol("do")::rest) -> doForm env rest |> eval env - | List(_, Symbol("fn*")::rest) -> fnStarForm env rest - | List(_, Symbol("quote")::rest) -> quoteForm rest - | List(_, [Symbol("quasiquoteexpand");form]) -> quasiquote form - | List(_, Symbol("quasiquoteexpand")::_) -> raise <| Error.wrongArity () - | List(_, [Symbol("quasiquote");form]) -> eval env <| quasiquote form - | List(_, Symbol("quasiquote")::_) -> raise <| Error.wrongArity () - | List(_, _) as node -> - let resolved = node |> eval_ast env - match resolved with - | List(_, BuiltInFunc(_, _, f)::rest) -> f rest - | List(_, Func(_, _, _, body, binds, outer)::rest) -> - let inner = Env.makeNew outer binds rest - body |> eval inner - | _ -> raise <| Error.errExpectedX "func" - | node -> node |> eval_ast env - - let READ input = - Reader.read_str input - - let EVAL env ast = - Some(eval env ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let RE env input = - READ input - |> Seq.ofList - |> Seq.choose (fun form -> EVAL env form) - - let REP env input = - input - |> RE env - |> Seq.iter (fun value -> PRINT value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - let eval_func env = function - | [ast] -> eval env ast - | _ -> raise <| Error.wrongArity () - - let argv_func = function - | file::rest -> rest |> List.map Types.String |> makeList - | [] -> EmptyLIST - - let configureEnv args = - let env = Env.makeRootEnv () - - Env.set env "eval" <| Env.makeBuiltInFunc (fun nodes -> eval_func env nodes) - Env.set env "*ARGV*" <| argv_func args - - RE env """ - (def! not (fn* (a) (if a false true))) - (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - """ |> Seq.iter ignore - - env - - [] - let main args = - let mode = getReadlineMode args - let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq - let env = configureEnv args - - match args with - | file::_ -> - System.IO.File.ReadAllText file - |> RE env |> Seq.iter ignore - 0 - | _ -> - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - try - REP env input - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "Error: %s" str - | ex -> - printfn "Error: %s" (ex.Message) - loop () - loop () +module REPL + open System + open Node + open Types + + let rec iterPairs f = function + | Pair(first, second, t) -> + f first second + iterPairs f t + | Empty -> () + | _ -> raise <| Error.errExpectedX "list or vector" + + let rec qqLoop elt acc = + match elt with + | List(_, [Symbol("splice-unquote");list]) -> makeList [Symbol "concat"; list; acc] + | List(_, Symbol("splice-unquote")::_) -> raise <| Error.wrongArity () + | _ -> makeList [Symbol "cons"; quasiquote elt; acc] + and quasiquote = function + | List(_, [Symbol("unquote");form]) -> form + | List(_, Symbol("unquote")::_) -> raise <| Error.wrongArity () + | List (_, list) -> List.foldBack qqLoop list Node.EmptyLIST + | Vector(_, segment) -> + let array = Array.sub segment.Array segment.Offset segment.Count + let folded = Array.foldBack qqLoop array Node.EmptyLIST + makeList [Symbol "vec"; folded] + | Map(_) as ast -> makeList [Symbol "quote"; ast] + | Symbol(_) as ast -> makeList [Symbol "quote"; ast] + | ast -> ast + + let quoteForm = function + | [node] -> node + | _ -> raise <| Error.wrongArity () + + let rec eval_ast env = function + | Symbol(sym) -> Env.get env sym + | List(_, lst) -> lst |> List.map (eval env) |> makeList + | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray + | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap + | node -> node + + and defBangForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and setBinding env first second = + let s = match first with + | Symbol(s) -> s + | _ -> raise <| Error.errExpectedX "symbol" + let form = eval env second + Env.set env s form + + and letStarForm outer = function + | [bindings; form] -> + let inner = Env.makeNew outer [] [] + let binder = setBinding inner + match bindings with + | List(_) | Vector(_) -> iterPairs binder bindings + | _ -> raise <| Error.errExpectedX "list or vector" + inner, form + | _ -> raise <| Error.wrongArity () + + and ifForm env = function + | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm + | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil + | _ -> raise <| Error.wrongArity () + + and ifForm3 env condForm trueForm falseForm = + match eval env condForm with + | Bool(false) | Nil -> falseForm + | _ -> trueForm + + and doForm env = function + | [a] -> a + | a::rest -> + eval env a |> ignore + doForm env rest + | _ -> raise <| Error.wrongArity () + + and fnStarForm outer nodes = + let makeFunc binds body = + let f = fun nodes -> + let inner = Env.makeNew outer binds nodes + eval inner body + Env.makeFunc f body binds outer + + match nodes with + | [List(_, binds); body] -> makeFunc binds body + | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body + | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" + | _ -> raise <| Error.wrongArity () + + and eval env = function + | List(_, []) as emptyList -> emptyList + | List(_, Symbol("def!")::rest) -> defBangForm env rest + | List(_, Symbol("let*")::rest) -> + let inner, form = letStarForm env rest + form |> eval inner + | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env + | List(_, Symbol("do")::rest) -> doForm env rest |> eval env + | List(_, Symbol("fn*")::rest) -> fnStarForm env rest + | List(_, Symbol("quote")::rest) -> quoteForm rest + | List(_, [Symbol("quasiquoteexpand");form]) -> quasiquote form + | List(_, Symbol("quasiquoteexpand")::_) -> raise <| Error.wrongArity () + | List(_, [Symbol("quasiquote");form]) -> eval env <| quasiquote form + | List(_, Symbol("quasiquote")::_) -> raise <| Error.wrongArity () + | List(_, _) as node -> + let resolved = node |> eval_ast env + match resolved with + | List(_, BuiltInFunc(_, _, f)::rest) -> f rest + | List(_, Func(_, _, _, body, binds, outer)::rest) -> + let inner = Env.makeNew outer binds rest + body |> eval inner + | _ -> raise <| Error.errExpectedX "func" + | node -> node |> eval_ast env + + let READ input = + Reader.read_str input + + let EVAL env ast = + Some(eval env ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let RE env input = + READ input + |> Seq.ofList + |> Seq.choose (fun form -> EVAL env form) + + let REP env input = + input + |> RE env + |> Seq.iter (fun value -> PRINT value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + let eval_func env = function + | [ast] -> eval env ast + | _ -> raise <| Error.wrongArity () + + let argv_func = function + | file::rest -> rest |> List.map Types.String |> makeList + | [] -> EmptyLIST + + let configureEnv args = + let env = Env.makeRootEnv () + + Env.set env "eval" <| Env.makeBuiltInFunc (fun nodes -> eval_func env nodes) + Env.set env "*ARGV*" <| argv_func args + + RE env """ + (def! not (fn* (a) (if a false true))) + (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + """ |> Seq.iter ignore + + env + + [] + let main args = + let mode = getReadlineMode args + let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq + let env = configureEnv args + + match args with + | file::_ -> + System.IO.File.ReadAllText file + |> RE env |> Seq.iter ignore + 0 + | _ -> + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/impls/fsharp/step8_macros.fs b/impls/fsharp/step8_macros.fs index 95d2768005..376471a9d4 100644 --- a/impls/fsharp/step8_macros.fs +++ b/impls/fsharp/step8_macros.fs @@ -1,225 +1,225 @@ -module REPL - open System - open Node - open Types - - let rec iterPairs f = function - | Pair(first, second, t) -> - f first second - iterPairs f t - | Empty -> () - | _ -> raise <| Error.errExpectedX "list or vector" - - let rec qqLoop elt acc = - match elt with - | List(_, [Symbol("splice-unquote");list]) -> makeList [Symbol "concat"; list; acc] - | List(_, Symbol("splice-unquote")::_) -> raise <| Error.wrongArity () - | _ -> makeList [Symbol "cons"; quasiquote elt; acc] - and quasiquote = function - | List(_, [Symbol("unquote");form]) -> form - | List(_, Symbol("unquote")::_) -> raise <| Error.wrongArity () - | List (_, list) -> List.foldBack qqLoop list Node.EmptyLIST - | Vector(_, segment) -> - let array = Array.sub segment.Array segment.Offset segment.Count - let folded = Array.foldBack qqLoop array Node.EmptyLIST - makeList [Symbol "vec"; folded] - | Map(_) as ast -> makeList [Symbol "quote"; ast] - | Symbol(_) as ast -> makeList [Symbol "quote"; ast] - | ast -> ast - - let quoteForm = function - | [node] -> node - | _ -> raise <| Error.wrongArity () - - let rec macroExpand env = function - | Env.IsMacro env (Macro(_, _, f, _, _, _), rest) -> - f rest |> macroExpand env - | node -> node - - let rec eval_ast env = function - | Symbol(sym) -> Env.get env sym - | List(_, lst) -> lst |> List.map (eval env) |> makeList - | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray - | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap - | node -> node - - and defBangForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and defMacroForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - match node with - | Func(_, _, f, body, binds, outer) -> - let node = Env.makeMacro f body binds outer - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "user defined func" - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and macroExpandForm env = function - | [form] -> macroExpand env form - | _ -> raise <| Error.wrongArity () - - and setBinding env first second = - let s = match first with - | Symbol(s) -> s - | _ -> raise <| Error.errExpectedX "symbol" - let form = eval env second - Env.set env s form - - and letStarForm outer = function - | [bindings; form] -> - let inner = Env.makeNew outer [] [] - let binder = setBinding inner - match bindings with - | List(_) | Vector(_) -> iterPairs binder bindings - | _ -> raise <| Error.errExpectedX "list or vector" - inner, form - | _ -> raise <| Error.wrongArity () - - and ifForm env = function - | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm - | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil - | _ -> raise <| Error.wrongArity () - - and ifForm3 env condForm trueForm falseForm = - match eval env condForm with - | Bool(false) | Nil -> falseForm - | _ -> trueForm - - and doForm env = function - | [a] -> a - | a::rest -> - eval env a |> ignore - doForm env rest - | _ -> raise <| Error.wrongArity () - - and fnStarForm outer nodes = - let makeFunc binds body = - let f = fun nodes -> - let inner = Env.makeNew outer binds nodes - eval inner body - Env.makeFunc f body binds outer - - match nodes with - | [List(_, binds); body] -> makeFunc binds body - | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body - | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" - | _ -> raise <| Error.wrongArity () - - and eval env = function - | List(_, _) as node -> - match macroExpand env node with - | List(_, []) as emptyList -> emptyList - | List(_, Symbol("def!")::rest) -> defBangForm env rest - | List(_, Symbol("defmacro!")::rest) -> defMacroForm env rest - | List(_, Symbol("macroexpand")::rest) -> macroExpandForm env rest - | List(_, Symbol("let*")::rest) -> - let inner, form = letStarForm env rest - form |> eval inner - | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env - | List(_, Symbol("do")::rest) -> doForm env rest |> eval env - | List(_, Symbol("fn*")::rest) -> fnStarForm env rest - | List(_, Symbol("quote")::rest) -> quoteForm rest - | List(_, [Symbol("quasiquoteexpand");form]) -> quasiquote form - | List(_, Symbol("quasiquoteexpand")::_) -> raise <| Error.wrongArity () - | List(_, [Symbol("quasiquote");form]) -> eval env <| quasiquote form - | List(_, Symbol("quasiquote")::_) -> raise <| Error.wrongArity () - | List(_, _) as node -> - let resolved = node |> eval_ast env - match resolved with - | List(_, BuiltInFunc(_, _, f)::rest) -> f rest - | List(_, Func(_, _, _, body, binds, outer)::rest) -> - let inner = Env.makeNew outer binds rest - body |> eval inner - | _ -> raise <| Error.errExpectedX "func" - | node -> node |> eval_ast env - | node -> node |> eval_ast env - - let READ input = - Reader.read_str input - - let EVAL env ast = - Some(eval env ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let RE env input = - READ input - |> Seq.ofList - |> Seq.choose (fun form -> EVAL env form) - - let REP env input = - input - |> RE env - |> Seq.iter (fun value -> PRINT value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - let eval_func env = function - | [ast] -> eval env ast - | _ -> raise <| Error.wrongArity () - - let argv_func = function - | file::rest -> rest |> List.map Types.String |> makeList - | [] -> EmptyLIST - - let configureEnv args = - let env = Env.makeRootEnv () - - Env.set env "eval" <| Env.makeBuiltInFunc (fun nodes -> eval_func env nodes) - Env.set env "*ARGV*" <| argv_func args - - RE env """ - (def! not (fn* (a) (if a false true))) - (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - (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))))))) - """ |> Seq.iter ignore - - env - - [] - let main args = - let mode = getReadlineMode args - let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq - let env = configureEnv args - - match args with - | file::_ -> - System.IO.File.ReadAllText file - |> RE env |> Seq.iter ignore - 0 - | _ -> - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - try - REP env input - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "Error: %s" str - | ex -> - printfn "Error: %s" (ex.Message) - loop () - loop () +module REPL + open System + open Node + open Types + + let rec iterPairs f = function + | Pair(first, second, t) -> + f first second + iterPairs f t + | Empty -> () + | _ -> raise <| Error.errExpectedX "list or vector" + + let rec qqLoop elt acc = + match elt with + | List(_, [Symbol("splice-unquote");list]) -> makeList [Symbol "concat"; list; acc] + | List(_, Symbol("splice-unquote")::_) -> raise <| Error.wrongArity () + | _ -> makeList [Symbol "cons"; quasiquote elt; acc] + and quasiquote = function + | List(_, [Symbol("unquote");form]) -> form + | List(_, Symbol("unquote")::_) -> raise <| Error.wrongArity () + | List (_, list) -> List.foldBack qqLoop list Node.EmptyLIST + | Vector(_, segment) -> + let array = Array.sub segment.Array segment.Offset segment.Count + let folded = Array.foldBack qqLoop array Node.EmptyLIST + makeList [Symbol "vec"; folded] + | Map(_) as ast -> makeList [Symbol "quote"; ast] + | Symbol(_) as ast -> makeList [Symbol "quote"; ast] + | ast -> ast + + let quoteForm = function + | [node] -> node + | _ -> raise <| Error.wrongArity () + + let rec macroExpand env = function + | Env.IsMacro env (Macro(_, _, f, _, _, _), rest) -> + f rest |> macroExpand env + | node -> node + + let rec eval_ast env = function + | Symbol(sym) -> Env.get env sym + | List(_, lst) -> lst |> List.map (eval env) |> makeList + | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray + | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap + | node -> node + + and defBangForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and defMacroForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + match node with + | Func(_, _, f, body, binds, outer) -> + let node = Env.makeMacro f body binds outer + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "user defined func" + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and macroExpandForm env = function + | [form] -> macroExpand env form + | _ -> raise <| Error.wrongArity () + + and setBinding env first second = + let s = match first with + | Symbol(s) -> s + | _ -> raise <| Error.errExpectedX "symbol" + let form = eval env second + Env.set env s form + + and letStarForm outer = function + | [bindings; form] -> + let inner = Env.makeNew outer [] [] + let binder = setBinding inner + match bindings with + | List(_) | Vector(_) -> iterPairs binder bindings + | _ -> raise <| Error.errExpectedX "list or vector" + inner, form + | _ -> raise <| Error.wrongArity () + + and ifForm env = function + | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm + | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil + | _ -> raise <| Error.wrongArity () + + and ifForm3 env condForm trueForm falseForm = + match eval env condForm with + | Bool(false) | Nil -> falseForm + | _ -> trueForm + + and doForm env = function + | [a] -> a + | a::rest -> + eval env a |> ignore + doForm env rest + | _ -> raise <| Error.wrongArity () + + and fnStarForm outer nodes = + let makeFunc binds body = + let f = fun nodes -> + let inner = Env.makeNew outer binds nodes + eval inner body + Env.makeFunc f body binds outer + + match nodes with + | [List(_, binds); body] -> makeFunc binds body + | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body + | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" + | _ -> raise <| Error.wrongArity () + + and eval env = function + | List(_, _) as node -> + match macroExpand env node with + | List(_, []) as emptyList -> emptyList + | List(_, Symbol("def!")::rest) -> defBangForm env rest + | List(_, Symbol("defmacro!")::rest) -> defMacroForm env rest + | List(_, Symbol("macroexpand")::rest) -> macroExpandForm env rest + | List(_, Symbol("let*")::rest) -> + let inner, form = letStarForm env rest + form |> eval inner + | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env + | List(_, Symbol("do")::rest) -> doForm env rest |> eval env + | List(_, Symbol("fn*")::rest) -> fnStarForm env rest + | List(_, Symbol("quote")::rest) -> quoteForm rest + | List(_, [Symbol("quasiquoteexpand");form]) -> quasiquote form + | List(_, Symbol("quasiquoteexpand")::_) -> raise <| Error.wrongArity () + | List(_, [Symbol("quasiquote");form]) -> eval env <| quasiquote form + | List(_, Symbol("quasiquote")::_) -> raise <| Error.wrongArity () + | List(_, _) as node -> + let resolved = node |> eval_ast env + match resolved with + | List(_, BuiltInFunc(_, _, f)::rest) -> f rest + | List(_, Func(_, _, _, body, binds, outer)::rest) -> + let inner = Env.makeNew outer binds rest + body |> eval inner + | _ -> raise <| Error.errExpectedX "func" + | node -> node |> eval_ast env + | node -> node |> eval_ast env + + let READ input = + Reader.read_str input + + let EVAL env ast = + Some(eval env ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let RE env input = + READ input + |> Seq.ofList + |> Seq.choose (fun form -> EVAL env form) + + let REP env input = + input + |> RE env + |> Seq.iter (fun value -> PRINT value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + let eval_func env = function + | [ast] -> eval env ast + | _ -> raise <| Error.wrongArity () + + let argv_func = function + | file::rest -> rest |> List.map Types.String |> makeList + | [] -> EmptyLIST + + let configureEnv args = + let env = Env.makeRootEnv () + + Env.set env "eval" <| Env.makeBuiltInFunc (fun nodes -> eval_func env nodes) + Env.set env "*ARGV*" <| argv_func args + + RE env """ + (def! not (fn* (a) (if a false true))) + (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + (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))))))) + """ |> Seq.iter ignore + + env + + [] + let main args = + let mode = getReadlineMode args + let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq + let env = configureEnv args + + match args with + | file::_ -> + System.IO.File.ReadAllText file + |> RE env |> Seq.iter ignore + 0 + | _ -> + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/impls/fsharp/step9_try.fs b/impls/fsharp/step9_try.fs index 68e7158813..3feefcf3a6 100644 --- a/impls/fsharp/step9_try.fs +++ b/impls/fsharp/step9_try.fs @@ -1,247 +1,247 @@ -module REPL - open System - open Node - open Types - - let rec iterPairs f = function - | Pair(first, second, t) -> - f first second - iterPairs f t - | Empty -> () - | _ -> raise <| Error.errExpectedX "list or vector" - - let rec qqLoop elt acc = - match elt with - | List(_, [Symbol("splice-unquote");list]) -> makeList [Symbol "concat"; list; acc] - | List(_, Symbol("splice-unquote")::_) -> raise <| Error.wrongArity () - | _ -> makeList [Symbol "cons"; quasiquote elt; acc] - and quasiquote = function - | List(_, [Symbol("unquote");form]) -> form - | List(_, Symbol("unquote")::_) -> raise <| Error.wrongArity () - | List (_, list) -> List.foldBack qqLoop list Node.EmptyLIST - | Vector(_, segment) -> - let array = Array.sub segment.Array segment.Offset segment.Count - let folded = Array.foldBack qqLoop array Node.EmptyLIST - makeList [Symbol "vec"; folded] - | Map(_) as ast -> makeList [Symbol "quote"; ast] - | Symbol(_) as ast -> makeList [Symbol "quote"; ast] - | ast -> ast - - let quoteForm = function - | [node] -> node - | _ -> raise <| Error.wrongArity () - - let rec macroExpand env = function - | Env.IsMacro env (Macro(_, _, f, _, _, _), rest) -> - f rest |> macroExpand env - | node -> node - - let rec eval_ast env = function - | Symbol(sym) -> Env.get env sym - | List(_, lst) -> lst |> List.map (eval env) |> makeList - | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray - | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap - | node -> node - - and defBangForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and defMacroForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - match node with - | Func(_, _, f, body, binds, outer) -> - let node = Env.makeMacro f body binds outer - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "user defined func" - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and macroExpandForm env = function - | [form] -> macroExpand env form - | _ -> raise <| Error.wrongArity () - - and setBinding env first second = - let s = match first with - | Symbol(s) -> s - | _ -> raise <| Error.errExpectedX "symbol" - let form = eval env second - Env.set env s form - - and letStarForm outer = function - | [bindings; form] -> - let inner = Env.makeNew outer [] [] - let binder = setBinding inner - match bindings with - | List(_) | Vector(_) -> iterPairs binder bindings - | _ -> raise <| Error.errExpectedX "list or vector" - inner, form - | _ -> raise <| Error.wrongArity () - - and ifForm env = function - | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm - | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil - | _ -> raise <| Error.wrongArity () - - and ifForm3 env condForm trueForm falseForm = - match eval env condForm with - | Bool(false) | Nil -> falseForm - | _ -> trueForm - - and doForm env = function - | [a] -> a - | a::rest -> - eval env a |> ignore - doForm env rest - | _ -> raise <| Error.wrongArity () - - and fnStarForm outer nodes = - let makeFunc binds body = - let f = fun nodes -> - let inner = Env.makeNew outer binds nodes - eval inner body - Env.makeFunc f body binds outer - - match nodes with - | [List(_, binds); body] -> makeFunc binds body - | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body - | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" - | _ -> raise <| Error.wrongArity () - - and catchForm env err = function - | List(_, [Symbol("catch*"); Symbol(_) as sym; catchBody]) -> - let inner = Env.makeNew env [sym] [err] - catchBody |> eval inner - | List(_, [_; _; _]) -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - - and tryForm env = function - | [exp] -> - eval env exp - | [exp; catchClause] -> - try - eval env exp - with - | Error.EvalError(str) -> catchForm env (String(str)) catchClause - | Error.MalError(node) -> catchForm env node catchClause - | _ -> raise <| Error.wrongArity () - - and eval env = function - | List(_, _) as node -> - match macroExpand env node with - | List(_, []) as emptyList -> emptyList - | List(_, Symbol("def!")::rest) -> defBangForm env rest - | List(_, Symbol("defmacro!")::rest) -> defMacroForm env rest - | List(_, Symbol("macroexpand")::rest) -> macroExpandForm env rest - | List(_, Symbol("let*")::rest) -> - let inner, form = letStarForm env rest - form |> eval inner - | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env - | List(_, Symbol("do")::rest) -> doForm env rest |> eval env - | List(_, Symbol("fn*")::rest) -> fnStarForm env rest - | List(_, Symbol("quote")::rest) -> quoteForm rest - | List(_, [Symbol("quasiquoteexpand");form]) -> quasiquote form - | List(_, Symbol("quasiquoteexpand")::_) -> raise <| Error.wrongArity () - | List(_, [Symbol("quasiquote");form]) -> eval env <| quasiquote form - | List(_, Symbol("quasiquote")::_) -> raise <| Error.wrongArity () - | List(_, Symbol("try*")::rest) -> tryForm env rest - | List(_, _) as node -> - let resolved = node |> eval_ast env - match resolved with - | List(_, BuiltInFunc(_, _, f)::rest) -> f rest - | List(_, Func(_, _, _, body, binds, outer)::rest) -> - let inner = Env.makeNew outer binds rest - body |> eval inner - | _ -> raise <| Error.errExpectedX "func" - | node -> node |> eval_ast env - | node -> node |> eval_ast env - - let READ input = - Reader.read_str input - - let EVAL env ast = - Some(eval env ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let RE env input = - READ input - |> Seq.ofList - |> Seq.choose (fun form -> EVAL env form) - - let REP env input = - input - |> RE env - |> Seq.iter (fun value -> PRINT value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - let eval_func env = function - | [ast] -> eval env ast - | _ -> raise <| Error.wrongArity () - - let argv_func = function - | file::rest -> rest |> List.map Types.String |> makeList - | [] -> EmptyLIST - - let configureEnv args = - let env = Env.makeRootEnv () - - Env.set env "eval" <| Env.makeBuiltInFunc (fun nodes -> eval_func env nodes) - Env.set env "*ARGV*" <| argv_func args - - RE env """ - (def! not (fn* (a) (if a false true))) - (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - (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))))))) - """ |> Seq.iter ignore - - env - - [] - let main args = - let mode = getReadlineMode args - let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq - let env = configureEnv args - - match args with - | file::_ -> - System.IO.File.ReadAllText file - |> RE env |> Seq.iter ignore - 0 - | _ -> - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - try - REP env input - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "Error: %s" str - | Error.MalError(node) -> - printfn "Error: %s" (Printer.pr_str [node]) - | ex -> - printfn "Error: %s" (ex.Message) - loop () - loop () +module REPL + open System + open Node + open Types + + let rec iterPairs f = function + | Pair(first, second, t) -> + f first second + iterPairs f t + | Empty -> () + | _ -> raise <| Error.errExpectedX "list or vector" + + let rec qqLoop elt acc = + match elt with + | List(_, [Symbol("splice-unquote");list]) -> makeList [Symbol "concat"; list; acc] + | List(_, Symbol("splice-unquote")::_) -> raise <| Error.wrongArity () + | _ -> makeList [Symbol "cons"; quasiquote elt; acc] + and quasiquote = function + | List(_, [Symbol("unquote");form]) -> form + | List(_, Symbol("unquote")::_) -> raise <| Error.wrongArity () + | List (_, list) -> List.foldBack qqLoop list Node.EmptyLIST + | Vector(_, segment) -> + let array = Array.sub segment.Array segment.Offset segment.Count + let folded = Array.foldBack qqLoop array Node.EmptyLIST + makeList [Symbol "vec"; folded] + | Map(_) as ast -> makeList [Symbol "quote"; ast] + | Symbol(_) as ast -> makeList [Symbol "quote"; ast] + | ast -> ast + + let quoteForm = function + | [node] -> node + | _ -> raise <| Error.wrongArity () + + let rec macroExpand env = function + | Env.IsMacro env (Macro(_, _, f, _, _, _), rest) -> + f rest |> macroExpand env + | node -> node + + let rec eval_ast env = function + | Symbol(sym) -> Env.get env sym + | List(_, lst) -> lst |> List.map (eval env) |> makeList + | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray + | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap + | node -> node + + and defBangForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and defMacroForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + match node with + | Func(_, _, f, body, binds, outer) -> + let node = Env.makeMacro f body binds outer + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "user defined func" + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and macroExpandForm env = function + | [form] -> macroExpand env form + | _ -> raise <| Error.wrongArity () + + and setBinding env first second = + let s = match first with + | Symbol(s) -> s + | _ -> raise <| Error.errExpectedX "symbol" + let form = eval env second + Env.set env s form + + and letStarForm outer = function + | [bindings; form] -> + let inner = Env.makeNew outer [] [] + let binder = setBinding inner + match bindings with + | List(_) | Vector(_) -> iterPairs binder bindings + | _ -> raise <| Error.errExpectedX "list or vector" + inner, form + | _ -> raise <| Error.wrongArity () + + and ifForm env = function + | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm + | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil + | _ -> raise <| Error.wrongArity () + + and ifForm3 env condForm trueForm falseForm = + match eval env condForm with + | Bool(false) | Nil -> falseForm + | _ -> trueForm + + and doForm env = function + | [a] -> a + | a::rest -> + eval env a |> ignore + doForm env rest + | _ -> raise <| Error.wrongArity () + + and fnStarForm outer nodes = + let makeFunc binds body = + let f = fun nodes -> + let inner = Env.makeNew outer binds nodes + eval inner body + Env.makeFunc f body binds outer + + match nodes with + | [List(_, binds); body] -> makeFunc binds body + | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body + | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" + | _ -> raise <| Error.wrongArity () + + and catchForm env err = function + | List(_, [Symbol("catch*"); Symbol(_) as sym; catchBody]) -> + let inner = Env.makeNew env [sym] [err] + catchBody |> eval inner + | List(_, [_; _; _]) -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + + and tryForm env = function + | [exp] -> + eval env exp + | [exp; catchClause] -> + try + eval env exp + with + | Error.EvalError(str) -> catchForm env (String(str)) catchClause + | Error.MalError(node) -> catchForm env node catchClause + | _ -> raise <| Error.wrongArity () + + and eval env = function + | List(_, _) as node -> + match macroExpand env node with + | List(_, []) as emptyList -> emptyList + | List(_, Symbol("def!")::rest) -> defBangForm env rest + | List(_, Symbol("defmacro!")::rest) -> defMacroForm env rest + | List(_, Symbol("macroexpand")::rest) -> macroExpandForm env rest + | List(_, Symbol("let*")::rest) -> + let inner, form = letStarForm env rest + form |> eval inner + | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env + | List(_, Symbol("do")::rest) -> doForm env rest |> eval env + | List(_, Symbol("fn*")::rest) -> fnStarForm env rest + | List(_, Symbol("quote")::rest) -> quoteForm rest + | List(_, [Symbol("quasiquoteexpand");form]) -> quasiquote form + | List(_, Symbol("quasiquoteexpand")::_) -> raise <| Error.wrongArity () + | List(_, [Symbol("quasiquote");form]) -> eval env <| quasiquote form + | List(_, Symbol("quasiquote")::_) -> raise <| Error.wrongArity () + | List(_, Symbol("try*")::rest) -> tryForm env rest + | List(_, _) as node -> + let resolved = node |> eval_ast env + match resolved with + | List(_, BuiltInFunc(_, _, f)::rest) -> f rest + | List(_, Func(_, _, _, body, binds, outer)::rest) -> + let inner = Env.makeNew outer binds rest + body |> eval inner + | _ -> raise <| Error.errExpectedX "func" + | node -> node |> eval_ast env + | node -> node |> eval_ast env + + let READ input = + Reader.read_str input + + let EVAL env ast = + Some(eval env ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let RE env input = + READ input + |> Seq.ofList + |> Seq.choose (fun form -> EVAL env form) + + let REP env input = + input + |> RE env + |> Seq.iter (fun value -> PRINT value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + let eval_func env = function + | [ast] -> eval env ast + | _ -> raise <| Error.wrongArity () + + let argv_func = function + | file::rest -> rest |> List.map Types.String |> makeList + | [] -> EmptyLIST + + let configureEnv args = + let env = Env.makeRootEnv () + + Env.set env "eval" <| Env.makeBuiltInFunc (fun nodes -> eval_func env nodes) + Env.set env "*ARGV*" <| argv_func args + + RE env """ + (def! not (fn* (a) (if a false true))) + (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + (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))))))) + """ |> Seq.iter ignore + + env + + [] + let main args = + let mode = getReadlineMode args + let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq + let env = configureEnv args + + match args with + | file::_ -> + System.IO.File.ReadAllText file + |> RE env |> Seq.iter ignore + 0 + | _ -> + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | Error.MalError(node) -> + printfn "Error: %s" (Printer.pr_str [node]) + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/impls/fsharp/stepA_mal.fs b/impls/fsharp/stepA_mal.fs index 6417191ba5..8f8392abaa 100644 --- a/impls/fsharp/stepA_mal.fs +++ b/impls/fsharp/stepA_mal.fs @@ -1,259 +1,259 @@ -module REPL - open System - open Node - open Types - - let rec iterPairs f = function - | Pair(first, second, t) -> - f first second - iterPairs f t - | Empty -> () - | _ -> raise <| Error.errExpectedX "list or vector" - - let rec qqLoop elt acc = - match elt with - | List(_, [Symbol("splice-unquote");list]) -> makeList [Symbol "concat"; list; acc] - | List(_, Symbol("splice-unquote")::_) -> raise <| Error.wrongArity () - | _ -> makeList [Symbol "cons"; quasiquote elt; acc] - and quasiquote = function - | List(_, [Symbol("unquote");form]) -> form - | List(_, Symbol("unquote")::_) -> raise <| Error.wrongArity () - | List (_, list) -> List.foldBack qqLoop list Node.EmptyLIST - | Vector(_, segment) -> - let array = Array.sub segment.Array segment.Offset segment.Count - let folded = Array.foldBack qqLoop array Node.EmptyLIST - makeList [Symbol "vec"; folded] - | Map(_) as ast -> makeList [Symbol "quote"; ast] - | Symbol(_) as ast -> makeList [Symbol "quote"; ast] - | ast -> ast - - let quoteForm = function - | [node] -> node - | _ -> raise <| Error.wrongArity () - - let rec macroExpand env = function - | Env.IsMacro env (Macro(_, _, f, _, _, _), rest) -> - f rest |> macroExpand env - | node -> node - - let rec eval_ast env = function - | Symbol(sym) -> Env.get env sym - | List(_, lst) -> lst |> List.map (eval env) |> makeList - | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray - | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap - | node -> node - - and defBangForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and defMacroForm env = function - | [sym; form] -> - match sym with - | Symbol(sym) -> - let node = eval env form - match node with - | Func(_, _, f, body, binds, outer) -> - let node = Env.makeMacro f body binds outer - Env.set env sym node - node - | _ -> raise <| Error.errExpectedX "user defined func" - | _ -> raise <| Error.errExpectedX "symbol" - | _ -> raise <| Error.wrongArity () - - and macroExpandForm env = function - | [form] -> macroExpand env form - | _ -> raise <| Error.wrongArity () - - and setBinding env first second = - let s = match first with - | Symbol(s) -> s - | _ -> raise <| Error.errExpectedX "symbol" - let form = eval env second - Env.set env s form - - and letStarForm outer = function - | [bindings; form] -> - let inner = Env.makeNew outer [] [] - let binder = setBinding inner - match bindings with - | List(_) | Vector(_) -> iterPairs binder bindings - | _ -> raise <| Error.errExpectedX "list or vector" - inner, form - | _ -> raise <| Error.wrongArity () - - and ifForm env = function - | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm - | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil - | _ -> raise <| Error.wrongArity () - - and ifForm3 env condForm trueForm falseForm = - match eval env condForm with - | Bool(false) | Nil -> falseForm - | _ -> trueForm - - and doForm env = function - | [a] -> a - | a::rest -> - eval env a |> ignore - doForm env rest - | _ -> raise <| Error.wrongArity () - - and fnStarForm outer nodes = - let makeFunc binds body = - let f = fun nodes -> - let inner = Env.makeNew outer binds nodes - eval inner body - Env.makeFunc f body binds outer - - match nodes with - | [List(_, binds); body] -> makeFunc binds body - | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body - | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" - | _ -> raise <| Error.wrongArity () - - and catchForm env err = function - | List(_, [Symbol("catch*"); Symbol(_) as sym; catchBody]) -> - let inner = Env.makeNew env [sym] [err] - catchBody |> eval inner - | List(_, [_; _; _]) -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - - and tryForm env = function - | [exp] -> - eval env exp - | [exp; catchClause] -> - try - eval env exp - with - | Error.EvalError(str) - | Error.ReaderError(str) -> catchForm env (String(str)) catchClause - | Error.MalError(node) -> catchForm env node catchClause - | _ -> raise <| Error.wrongArity () - - and eval env = function - | List(_, _) as node -> - match macroExpand env node with - | List(_, []) as emptyList -> emptyList - | List(_, Symbol("def!")::rest) -> defBangForm env rest - | List(_, Symbol("defmacro!")::rest) -> defMacroForm env rest - | List(_, Symbol("macroexpand")::rest) -> macroExpandForm env rest - | List(_, Symbol("let*")::rest) -> - let inner, form = letStarForm env rest - form |> eval inner - | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env - | List(_, Symbol("do")::rest) -> doForm env rest |> eval env - | List(_, Symbol("fn*")::rest) -> fnStarForm env rest - | List(_, Symbol("quote")::rest) -> quoteForm rest - | List(_, [Symbol("quasiquoteexpand");form]) -> quasiquote form - | List(_, Symbol("quasiquoteexpand")::_) -> raise <| Error.wrongArity () - | List(_, [Symbol("quasiquote");form]) -> eval env <| quasiquote form - | List(_, Symbol("quasiquote")::_) -> raise <| Error.wrongArity () - | List(_, Symbol("try*")::rest) -> tryForm env rest - | List(_, _) as node -> - let resolved = node |> eval_ast env - match resolved with - | List(_, BuiltInFunc(_, _, f)::rest) -> f rest - | List(_, Func(_, _, _, body, binds, outer)::rest) -> - let inner = Env.makeNew outer binds rest - body |> eval inner - | _ -> raise <| Error.errExpectedX "func" - | node -> node |> eval_ast env - | node -> node |> eval_ast env - - let READ input = - Reader.read_str input - - let EVAL env ast = - Some(eval env ast) - - let PRINT v = - v - |> Seq.singleton - |> Printer.pr_str - |> printfn "%s" - - let RE env input = - READ input - |> Seq.ofList - |> Seq.choose (fun form -> EVAL env form) - - let REP env input = - input - |> RE env - |> Seq.iter (fun value -> PRINT value) - - let getReadlineMode args = - if args |> Array.exists (fun e -> e = "--raw") then - Readline.Mode.Raw - else - Readline.Mode.Terminal - - let eval_func env = function - | [ast] -> eval env ast - | _ -> raise <| Error.wrongArity () - - let argv_func = function - | file::rest -> rest |> List.map Types.String |> makeList - | [] -> EmptyLIST - - let readline_func mode = function - | [String(prompt)] -> - match Readline.read prompt mode with - | null -> Node.NIL - | input -> String(input) - | [_] -> raise <| Error.argMismatch () - | _ -> raise <| Error.wrongArity () - - let configureEnv args mode = - let env = Env.makeRootEnv () - - Env.set env "eval" <| Env.makeBuiltInFunc (eval_func env) - Env.set env "*ARGV*" <| argv_func args - Env.set env "readline" <| Env.makeBuiltInFunc (readline_func mode) - - RE env """ - (def! *host-language* "fsharp") - (def! not (fn* (a) (if a false true))) - (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - (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))))))) - """ |> Seq.iter ignore - - env - - [] - let main args = - let mode = getReadlineMode args - let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq - let env = configureEnv args mode - - match args with - | file::_ -> - System.IO.File.ReadAllText file - |> RE env |> Seq.iter ignore - 0 - | _ -> - RE env "(println (str \"Mal [\" *host-language* \"]\"))" |> Seq.iter ignore - let rec loop () = - match Readline.read "user> " mode with - | null -> 0 - | input -> - try - REP env input - with - | Error.EvalError(str) - | Error.ReaderError(str) -> - printfn "Error: %s" str - | Error.MalError(node) -> - printfn "Error: %s" (Printer.pr_str [node]) - | ex -> - printfn "Error: %s" (ex.Message) - loop () - loop () +module REPL + open System + open Node + open Types + + let rec iterPairs f = function + | Pair(first, second, t) -> + f first second + iterPairs f t + | Empty -> () + | _ -> raise <| Error.errExpectedX "list or vector" + + let rec qqLoop elt acc = + match elt with + | List(_, [Symbol("splice-unquote");list]) -> makeList [Symbol "concat"; list; acc] + | List(_, Symbol("splice-unquote")::_) -> raise <| Error.wrongArity () + | _ -> makeList [Symbol "cons"; quasiquote elt; acc] + and quasiquote = function + | List(_, [Symbol("unquote");form]) -> form + | List(_, Symbol("unquote")::_) -> raise <| Error.wrongArity () + | List (_, list) -> List.foldBack qqLoop list Node.EmptyLIST + | Vector(_, segment) -> + let array = Array.sub segment.Array segment.Offset segment.Count + let folded = Array.foldBack qqLoop array Node.EmptyLIST + makeList [Symbol "vec"; folded] + | Map(_) as ast -> makeList [Symbol "quote"; ast] + | Symbol(_) as ast -> makeList [Symbol "quote"; ast] + | ast -> ast + + let quoteForm = function + | [node] -> node + | _ -> raise <| Error.wrongArity () + + let rec macroExpand env = function + | Env.IsMacro env (Macro(_, _, f, _, _, _), rest) -> + f rest |> macroExpand env + | node -> node + + let rec eval_ast env = function + | Symbol(sym) -> Env.get env sym + | List(_, lst) -> lst |> List.map (eval env) |> makeList + | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray + | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap + | node -> node + + and defBangForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and defMacroForm env = function + | [sym; form] -> + match sym with + | Symbol(sym) -> + let node = eval env form + match node with + | Func(_, _, f, body, binds, outer) -> + let node = Env.makeMacro f body binds outer + Env.set env sym node + node + | _ -> raise <| Error.errExpectedX "user defined func" + | _ -> raise <| Error.errExpectedX "symbol" + | _ -> raise <| Error.wrongArity () + + and macroExpandForm env = function + | [form] -> macroExpand env form + | _ -> raise <| Error.wrongArity () + + and setBinding env first second = + let s = match first with + | Symbol(s) -> s + | _ -> raise <| Error.errExpectedX "symbol" + let form = eval env second + Env.set env s form + + and letStarForm outer = function + | [bindings; form] -> + let inner = Env.makeNew outer [] [] + let binder = setBinding inner + match bindings with + | List(_) | Vector(_) -> iterPairs binder bindings + | _ -> raise <| Error.errExpectedX "list or vector" + inner, form + | _ -> raise <| Error.wrongArity () + + and ifForm env = function + | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm + | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil + | _ -> raise <| Error.wrongArity () + + and ifForm3 env condForm trueForm falseForm = + match eval env condForm with + | Bool(false) | Nil -> falseForm + | _ -> trueForm + + and doForm env = function + | [a] -> a + | a::rest -> + eval env a |> ignore + doForm env rest + | _ -> raise <| Error.wrongArity () + + and fnStarForm outer nodes = + let makeFunc binds body = + let f = fun nodes -> + let inner = Env.makeNew outer binds nodes + eval inner body + Env.makeFunc f body binds outer + + match nodes with + | [List(_, binds); body] -> makeFunc binds body + | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body + | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector" + | _ -> raise <| Error.wrongArity () + + and catchForm env err = function + | List(_, [Symbol("catch*"); Symbol(_) as sym; catchBody]) -> + let inner = Env.makeNew env [sym] [err] + catchBody |> eval inner + | List(_, [_; _; _]) -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + + and tryForm env = function + | [exp] -> + eval env exp + | [exp; catchClause] -> + try + eval env exp + with + | Error.EvalError(str) + | Error.ReaderError(str) -> catchForm env (String(str)) catchClause + | Error.MalError(node) -> catchForm env node catchClause + | _ -> raise <| Error.wrongArity () + + and eval env = function + | List(_, _) as node -> + match macroExpand env node with + | List(_, []) as emptyList -> emptyList + | List(_, Symbol("def!")::rest) -> defBangForm env rest + | List(_, Symbol("defmacro!")::rest) -> defMacroForm env rest + | List(_, Symbol("macroexpand")::rest) -> macroExpandForm env rest + | List(_, Symbol("let*")::rest) -> + let inner, form = letStarForm env rest + form |> eval inner + | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env + | List(_, Symbol("do")::rest) -> doForm env rest |> eval env + | List(_, Symbol("fn*")::rest) -> fnStarForm env rest + | List(_, Symbol("quote")::rest) -> quoteForm rest + | List(_, [Symbol("quasiquoteexpand");form]) -> quasiquote form + | List(_, Symbol("quasiquoteexpand")::_) -> raise <| Error.wrongArity () + | List(_, [Symbol("quasiquote");form]) -> eval env <| quasiquote form + | List(_, Symbol("quasiquote")::_) -> raise <| Error.wrongArity () + | List(_, Symbol("try*")::rest) -> tryForm env rest + | List(_, _) as node -> + let resolved = node |> eval_ast env + match resolved with + | List(_, BuiltInFunc(_, _, f)::rest) -> f rest + | List(_, Func(_, _, _, body, binds, outer)::rest) -> + let inner = Env.makeNew outer binds rest + body |> eval inner + | _ -> raise <| Error.errExpectedX "func" + | node -> node |> eval_ast env + | node -> node |> eval_ast env + + let READ input = + Reader.read_str input + + let EVAL env ast = + Some(eval env ast) + + let PRINT v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let RE env input = + READ input + |> Seq.ofList + |> Seq.choose (fun form -> EVAL env form) + + let REP env input = + input + |> RE env + |> Seq.iter (fun value -> PRINT value) + + let getReadlineMode args = + if args |> Array.exists (fun e -> e = "--raw") then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + let eval_func env = function + | [ast] -> eval env ast + | _ -> raise <| Error.wrongArity () + + let argv_func = function + | file::rest -> rest |> List.map Types.String |> makeList + | [] -> EmptyLIST + + let readline_func mode = function + | [String(prompt)] -> + match Readline.read prompt mode with + | null -> Node.NIL + | input -> String(input) + | [_] -> raise <| Error.argMismatch () + | _ -> raise <| Error.wrongArity () + + let configureEnv args mode = + let env = Env.makeRootEnv () + + Env.set env "eval" <| Env.makeBuiltInFunc (eval_func env) + Env.set env "*ARGV*" <| argv_func args + Env.set env "readline" <| Env.makeBuiltInFunc (readline_func mode) + + RE env """ + (def! *host-language* "fsharp") + (def! not (fn* (a) (if a false true))) + (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + (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))))))) + """ |> Seq.iter ignore + + env + + [] + let main args = + let mode = getReadlineMode args + let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq + let env = configureEnv args mode + + match args with + | file::_ -> + System.IO.File.ReadAllText file + |> RE env |> Seq.iter ignore + 0 + | _ -> + RE env "(println (str \"Mal [\" *host-language* \"]\"))" |> Seq.iter ignore + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + try + REP env input + with + | Error.EvalError(str) + | Error.ReaderError(str) -> + printfn "Error: %s" str + | Error.MalError(node) -> + printfn "Error: %s" (Printer.pr_str [node]) + | ex -> + printfn "Error: %s" (ex.Message) + loop () + loop () diff --git a/impls/fsharp/terminal.cs b/impls/fsharp/terminal.cs index c11a11d8b8..40212ab1da 100644 --- a/impls/fsharp/terminal.cs +++ b/impls/fsharp/terminal.cs @@ -1,1089 +1,1089 @@ -// -// getline.cs: A command line editor -// -// Authors: -// Miguel de Icaza (miguel@novell.com) -// -// Copyright 2008 Novell, Inc. -// -// Dual-licensed under the terms of the MIT X11 license or the -// Apache License 2.0 -// -// USE -define:DEMO to build this as a standalone file and test it -// -// TODO: -// Enter an error (a = 1); Notice how the prompt is in the wrong line -// This is caused by Stderr not being tracked by System.Console. -// Completion support -// Why is Thread.Interrupt not working? Currently I resort to Abort which is too much. -// -// Limitations in System.Console: -// Console needs SIGWINCH support of some sort -// Console needs a way of updating its position after things have been written -// behind its back (P/Invoke puts for example). -// System.Console needs to get the DELETE character, and report accordingly. -// - -using System; -using System.Text; -using System.IO; -using System.Threading; -using System.Reflection; - -namespace Mono.Terminal { - - public class LineEditor { - - public class Completion { - public string [] Result; - public string Prefix; - - public Completion (string prefix, string [] result) - { - Prefix = prefix; - Result = result; - } - } - - public delegate Completion AutoCompleteHandler (string text, int pos); - - //static StreamWriter log; - - // The text being edited. - StringBuilder text; - - // The text as it is rendered (replaces (char)1 with ^A on display for example). - StringBuilder rendered_text; - - // The prompt specified, and the prompt shown to the user. - string prompt; - string shown_prompt; - - // The current cursor position, indexes into "text", for an index - // into rendered_text, use TextToRenderPos - int cursor; - - // The row where we started displaying data. - int home_row; - - // The maximum length that has been displayed on the screen - int max_rendered; - - // If we are done editing, this breaks the interactive loop - bool done = false; - - // The thread where the Editing started taking place - Thread edit_thread; - - // Our object that tracks history - History history; - - // The contents of the kill buffer (cut/paste in Emacs parlance) - string kill_buffer = ""; - - // The string being searched for - string search; - string last_search; - - // whether we are searching (-1= reverse; 0 = no; 1 = forward) - int searching; - - // The position where we found the match. - int match_at; - - // Used to implement the Kill semantics (multiple Alt-Ds accumulate) - KeyHandler last_handler; - - delegate void KeyHandler (); - - struct Handler { - public ConsoleKeyInfo CKI; - public KeyHandler KeyHandler; - - public Handler (ConsoleKey key, KeyHandler h) - { - CKI = new ConsoleKeyInfo ((char) 0, key, false, false, false); - KeyHandler = h; - } - - public Handler (char c, KeyHandler h) - { - KeyHandler = h; - // Use the "Zoom" as a flag that we only have a character. - CKI = new ConsoleKeyInfo (c, ConsoleKey.Zoom, false, false, false); - } - - public Handler (ConsoleKeyInfo cki, KeyHandler h) - { - CKI = cki; - KeyHandler = h; - } - - public static Handler Control (char c, KeyHandler h) - { - return new Handler ((char) (c - 'A' + 1), h); - } - - public static Handler Alt (char c, ConsoleKey k, KeyHandler h) - { - ConsoleKeyInfo cki = new ConsoleKeyInfo ((char) c, k, false, true, false); - return new Handler (cki, h); - } - } - - /// - /// Invoked when the user requests auto-completion using the tab character - /// - /// - /// The result is null for no values found, an array with a single - /// string, in that case the string should be the text to be inserted - /// for example if the word at pos is "T", the result for a completion - /// of "ToString" should be "oString", not "ToString". - /// - /// When there are multiple results, the result should be the full - /// text - /// - public AutoCompleteHandler AutoCompleteEvent; - - static Handler [] handlers; - - public LineEditor (string name) : this (name, 10) { } - - public LineEditor (string name, int histsize) - { - handlers = new Handler [] { - new Handler (ConsoleKey.Home, CmdHome), - new Handler (ConsoleKey.End, CmdEnd), - new Handler (ConsoleKey.LeftArrow, CmdLeft), - new Handler (ConsoleKey.RightArrow, CmdRight), - new Handler (ConsoleKey.UpArrow, CmdHistoryPrev), - new Handler (ConsoleKey.DownArrow, CmdHistoryNext), - new Handler (ConsoleKey.Enter, CmdDone), - new Handler (ConsoleKey.Backspace, CmdBackspace), - new Handler (ConsoleKey.Delete, CmdDeleteChar), - new Handler (ConsoleKey.Tab, CmdTabOrComplete), - - // Emacs keys - Handler.Control ('A', CmdHome), - Handler.Control ('E', CmdEnd), - Handler.Control ('B', CmdLeft), - Handler.Control ('F', CmdRight), - Handler.Control ('P', CmdHistoryPrev), - Handler.Control ('N', CmdHistoryNext), - Handler.Control ('K', CmdKillToEOF), - Handler.Control ('Y', CmdYank), - Handler.Control ('D', CmdDeleteChar), - Handler.Control ('L', CmdRefresh), - Handler.Control ('R', CmdReverseSearch), - Handler.Control ('G', delegate {} ), - Handler.Alt ('B', ConsoleKey.B, CmdBackwardWord), - Handler.Alt ('F', ConsoleKey.F, CmdForwardWord), - - Handler.Alt ('D', ConsoleKey.D, CmdDeleteWord), - Handler.Alt ((char) 8, ConsoleKey.Backspace, CmdDeleteBackword), - - // DEBUG - //Handler.Control ('T', CmdDebug), - - // quote - Handler.Control ('Q', delegate { HandleChar (Console.ReadKey (true).KeyChar); }) - }; - - rendered_text = new StringBuilder (); - text = new StringBuilder (); - - history = new History (name, histsize); - - //if (File.Exists ("log"))File.Delete ("log"); - //log = File.CreateText ("log"); - } - - void CmdDebug () - { - history.Dump (); - Console.WriteLine (); - Render (); - } - - void Render () - { - Console.Write (shown_prompt); - Console.Write (rendered_text); - - int max = System.Math.Max (rendered_text.Length + shown_prompt.Length, max_rendered); - - for (int i = rendered_text.Length + shown_prompt.Length; i < max_rendered; i++) - Console.Write (' '); - max_rendered = shown_prompt.Length + rendered_text.Length; - - // Write one more to ensure that we always wrap around properly if we are at the - // end of a line. - Console.Write (' '); - - UpdateHomeRow (max); - } - - void UpdateHomeRow (int screenpos) - { - int lines = 1 + (screenpos / Console.WindowWidth); - - home_row = Console.CursorTop - (lines - 1); - if (home_row < 0) - home_row = 0; - } - - - void RenderFrom (int pos) - { - int rpos = TextToRenderPos (pos); - int i; - - for (i = rpos; i < rendered_text.Length; i++) - Console.Write (rendered_text [i]); - - if ((shown_prompt.Length + rendered_text.Length) > max_rendered) - max_rendered = shown_prompt.Length + rendered_text.Length; - else { - int max_extra = max_rendered - shown_prompt.Length; - for (; i < max_extra; i++) - Console.Write (' '); - } - } - - void ComputeRendered () - { - rendered_text.Length = 0; - - for (int i = 0; i < text.Length; i++){ - int c = (int) text [i]; - if (c < 26){ - if (c == '\t') - rendered_text.Append (" "); - else { - rendered_text.Append ('^'); - rendered_text.Append ((char) (c + (int) 'A' - 1)); - } - } else - rendered_text.Append ((char)c); - } - } - - int TextToRenderPos (int pos) - { - int p = 0; - - for (int i = 0; i < pos; i++){ - int c; - - c = (int) text [i]; - - if (c < 26){ - if (c == 9) - p += 4; - else - p += 2; - } else - p++; - } - - return p; - } - - int TextToScreenPos (int pos) - { - return shown_prompt.Length + TextToRenderPos (pos); - } - - string Prompt { - get { return prompt; } - set { prompt = value; } - } - - int LineCount { - get { - return (shown_prompt.Length + rendered_text.Length)/Console.WindowWidth; - } - } - - void ForceCursor (int newpos) - { - cursor = newpos; - - int actual_pos = shown_prompt.Length + TextToRenderPos (cursor); - int row = home_row + (actual_pos/Console.WindowWidth); - int col = actual_pos % Console.WindowWidth; - - if (row >= Console.BufferHeight) - row = Console.BufferHeight-1; - Console.SetCursorPosition (col, row); - - //log.WriteLine ("Going to cursor={0} row={1} col={2} actual={3} prompt={4} ttr={5} old={6}", newpos, row, col, actual_pos, prompt.Length, TextToRenderPos (cursor), cursor); - //log.Flush (); - } - - void UpdateCursor (int newpos) - { - if (cursor == newpos) - return; - - ForceCursor (newpos); - } - - void InsertChar (char c) - { - int prev_lines = LineCount; - text = text.Insert (cursor, c); - ComputeRendered (); - if (prev_lines != LineCount){ - - Console.SetCursorPosition (0, home_row); - Render (); - ForceCursor (++cursor); - } else { - RenderFrom (cursor); - ForceCursor (++cursor); - UpdateHomeRow (TextToScreenPos (cursor)); - } - } - - // - // Commands - // - void CmdDone () - { - done = true; - } - - void CmdTabOrComplete () - { - bool complete = false; - - if (AutoCompleteEvent != null){ - if (TabAtStartCompletes) - complete = true; - else { - for (int i = 0; i < cursor; i++){ - if (!Char.IsWhiteSpace (text [i])){ - complete = true; - break; - } - } - } - - if (complete){ - Completion completion = AutoCompleteEvent (text.ToString (), cursor); - string [] completions = completion.Result; - if (completions == null) - return; - - int ncompletions = completions.Length; - if (ncompletions == 0) - return; - - if (completions.Length == 1){ - InsertTextAtCursor (completions [0]); - } else { - int last = -1; - - for (int p = 0; p < completions [0].Length; p++){ - char c = completions [0][p]; - - - for (int i = 1; i < ncompletions; i++){ - if (completions [i].Length < p) - goto mismatch; - - if (completions [i][p] != c){ - goto mismatch; - } - } - last = p; - } - mismatch: - if (last != -1){ - InsertTextAtCursor (completions [0].Substring (0, last+1)); - } - Console.WriteLine (); - foreach (string s in completions){ - Console.Write (completion.Prefix); - Console.Write (s); - Console.Write (' '); - } - Console.WriteLine (); - Render (); - ForceCursor (cursor); - } - } else - HandleChar ('\t'); - } else - HandleChar ('t'); - } - - void CmdHome () - { - UpdateCursor (0); - } - - void CmdEnd () - { - UpdateCursor (text.Length); - } - - void CmdLeft () - { - if (cursor == 0) - return; - - UpdateCursor (cursor-1); - } - - void CmdBackwardWord () - { - int p = WordBackward (cursor); - if (p == -1) - return; - UpdateCursor (p); - } - - void CmdForwardWord () - { - int p = WordForward (cursor); - if (p == -1) - return; - UpdateCursor (p); - } - - void CmdRight () - { - if (cursor == text.Length) - return; - - UpdateCursor (cursor+1); - } - - void RenderAfter (int p) - { - ForceCursor (p); - RenderFrom (p); - ForceCursor (cursor); - } - - void CmdBackspace () - { - if (cursor == 0) - return; - - text.Remove (--cursor, 1); - ComputeRendered (); - RenderAfter (cursor); - } - - void CmdDeleteChar () - { - // If there is no input, this behaves like EOF - if (text.Length == 0){ - done = true; - text = null; - Console.WriteLine (); - return; - } - - if (cursor == text.Length) - return; - text.Remove (cursor, 1); - ComputeRendered (); - RenderAfter (cursor); - } - - int WordForward (int p) - { - if (p >= text.Length) - return -1; - - int i = p; - if (Char.IsPunctuation (text [p]) || Char.IsSymbol (text [p]) || Char.IsWhiteSpace (text[p])){ - for (; i < text.Length; i++){ - if (Char.IsLetterOrDigit (text [i])) - break; - } - for (; i < text.Length; i++){ - if (!Char.IsLetterOrDigit (text [i])) - break; - } - } else { - for (; i < text.Length; i++){ - if (!Char.IsLetterOrDigit (text [i])) - break; - } - } - if (i != p) - return i; - return -1; - } - - int WordBackward (int p) - { - if (p == 0) - return -1; - - int i = p-1; - if (i == 0) - return 0; - - if (Char.IsPunctuation (text [i]) || Char.IsSymbol (text [i]) || Char.IsWhiteSpace (text[i])){ - for (; i >= 0; i--){ - if (Char.IsLetterOrDigit (text [i])) - break; - } - for (; i >= 0; i--){ - if (!Char.IsLetterOrDigit (text[i])) - break; - } - } else { - for (; i >= 0; i--){ - if (!Char.IsLetterOrDigit (text [i])) - break; - } - } - i++; - - if (i != p) - return i; - - return -1; - } - - void CmdDeleteWord () - { - int pos = WordForward (cursor); - - if (pos == -1) - return; - - string k = text.ToString (cursor, pos-cursor); - - if (last_handler == CmdDeleteWord) - kill_buffer = kill_buffer + k; - else - kill_buffer = k; - - text.Remove (cursor, pos-cursor); - ComputeRendered (); - RenderAfter (cursor); - } - - void CmdDeleteBackword () - { - int pos = WordBackward (cursor); - if (pos == -1) - return; - - string k = text.ToString (pos, cursor-pos); - - if (last_handler == CmdDeleteBackword) - kill_buffer = k + kill_buffer; - else - kill_buffer = k; - - text.Remove (pos, cursor-pos); - ComputeRendered (); - RenderAfter (pos); - } - - // - // Adds the current line to the history if needed - // - void HistoryUpdateLine () - { - history.Update (text.ToString ()); - } - - void CmdHistoryPrev () - { - if (!history.PreviousAvailable ()) - return; - - HistoryUpdateLine (); - - SetText (history.Previous ()); - } - - void CmdHistoryNext () - { - if (!history.NextAvailable()) - return; - - history.Update (text.ToString ()); - SetText (history.Next ()); - - } - - void CmdKillToEOF () - { - kill_buffer = text.ToString (cursor, text.Length-cursor); - text.Length = cursor; - ComputeRendered (); - RenderAfter (cursor); - } - - void CmdYank () - { - InsertTextAtCursor (kill_buffer); - } - - void InsertTextAtCursor (string str) - { - int prev_lines = LineCount; - text.Insert (cursor, str); - ComputeRendered (); - if (prev_lines != LineCount){ - Console.SetCursorPosition (0, home_row); - Render (); - cursor += str.Length; - ForceCursor (cursor); - } else { - RenderFrom (cursor); - cursor += str.Length; - ForceCursor (cursor); - UpdateHomeRow (TextToScreenPos (cursor)); - } - } - - void SetSearchPrompt (string s) - { - SetPrompt ("(reverse-i-search)`" + s + "': "); - } - - void ReverseSearch () - { - int p; - - if (cursor == text.Length){ - // The cursor is at the end of the string - - p = text.ToString ().LastIndexOf (search); - if (p != -1){ - match_at = p; - cursor = p; - ForceCursor (cursor); - return; - } - } else { - // The cursor is somewhere in the middle of the string - int start = (cursor == match_at) ? cursor - 1 : cursor; - if (start != -1){ - p = text.ToString ().LastIndexOf (search, start); - if (p != -1){ - match_at = p; - cursor = p; - ForceCursor (cursor); - return; - } - } - } - - // Need to search backwards in history - HistoryUpdateLine (); - string s = history.SearchBackward (search); - if (s != null){ - match_at = -1; - SetText (s); - ReverseSearch (); - } - } - - void CmdReverseSearch () - { - if (searching == 0){ - match_at = -1; - last_search = search; - searching = -1; - search = ""; - SetSearchPrompt (""); - } else { - if (search == ""){ - if (last_search != "" && last_search != null){ - search = last_search; - SetSearchPrompt (search); - - ReverseSearch (); - } - return; - } - ReverseSearch (); - } - } - - void SearchAppend (char c) - { - search = search + c; - SetSearchPrompt (search); - - // - // If the new typed data still matches the current text, stay here - // - if (cursor < text.Length){ - string r = text.ToString (cursor, text.Length - cursor); - if (r.StartsWith (search)) - return; - } - - ReverseSearch (); - } - - void CmdRefresh () - { - Console.Clear (); - max_rendered = 0; - Render (); - ForceCursor (cursor); - } - - void InterruptEdit (object sender, ConsoleCancelEventArgs a) - { - // Do not abort our program: - a.Cancel = true; - - // Interrupt the editor - edit_thread.Abort(); - } - - void HandleChar (char c) - { - if (searching != 0) - SearchAppend (c); - else - InsertChar (c); - } - - void EditLoop () - { - ConsoleKeyInfo cki; - - while (!done){ - ConsoleModifiers mod; - - cki = Console.ReadKey (true); - if (cki.Key == ConsoleKey.Escape){ - cki = Console.ReadKey (true); - - mod = ConsoleModifiers.Alt; - } else - mod = cki.Modifiers; - - bool handled = false; - - foreach (Handler handler in handlers){ - ConsoleKeyInfo t = handler.CKI; - - if (t.Key == cki.Key && t.Modifiers == mod){ - handled = true; - handler.KeyHandler (); - last_handler = handler.KeyHandler; - break; - } else if (t.KeyChar == cki.KeyChar && t.Key == ConsoleKey.Zoom){ - handled = true; - handler.KeyHandler (); - last_handler = handler.KeyHandler; - break; - } - } - if (handled){ - if (searching != 0){ - if (last_handler != CmdReverseSearch){ - searching = 0; - SetPrompt (prompt); - } - } - continue; - } - - if (cki.KeyChar != (char) 0) - HandleChar (cki.KeyChar); - } - } - - void InitText (string initial) - { - text = new StringBuilder (initial); - ComputeRendered (); - cursor = text.Length; - Render (); - ForceCursor (cursor); - } - - void SetText (string newtext) - { - Console.SetCursorPosition (0, home_row); - InitText (newtext); - } - - void SetPrompt (string newprompt) - { - shown_prompt = newprompt; - Console.SetCursorPosition (0, home_row); - Render (); - ForceCursor (cursor); - } - - public string Edit (string prompt, string initial) - { - edit_thread = Thread.CurrentThread; - searching = 0; - Console.CancelKeyPress += InterruptEdit; - - done = false; - history.CursorToEnd (); - max_rendered = 0; - - Prompt = prompt; - shown_prompt = prompt; - InitText (initial); - history.Append (initial); - - do { - try { - EditLoop (); - } catch (ThreadAbortException){ - searching = 0; - Thread.ResetAbort (); - Console.WriteLine (); - SetPrompt (prompt); - SetText (""); - } - } while (!done); - Console.WriteLine (); - - Console.CancelKeyPress -= InterruptEdit; - - if (text == null){ - history.Close (); - return null; - } - - string result = text.ToString (); - if (result != "") - history.Accept (result); - else - history.RemoveLast (); - - return result; - } - - public void SaveHistory () - { - if (history != null) { - history.Close (); - } - } - - public bool TabAtStartCompletes { get; set; } - - // - // Emulates the bash-like behavior, where edits done to the - // history are recorded - // - class History { - string [] history; - int head, tail; - int cursor, count; - string histfile; - - public History (string app, int size) - { - if (size < 1) - throw new ArgumentException ("size"); - - if (app != null){ - string dir = Environment.GetFolderPath (Environment.SpecialFolder.Personal); - //Console.WriteLine (dir); - /* - if (!Directory.Exists (dir)){ - try { - Directory.CreateDirectory (dir); - } catch { - app = null; - } - } - if (app != null) - histfile = Path.Combine (dir, app) + ".history"; - */ - histfile = Path.Combine (dir, ".mal-history"); - } - - history = new string [size]; - head = tail = cursor = 0; - - if (File.Exists (histfile)){ - using (StreamReader sr = File.OpenText (histfile)){ - string line; - - while ((line = sr.ReadLine ()) != null){ - if (line != "") - Append (line); - } - } - } - } - - public void Close () - { - if (histfile == null) - return; - - try { - using (StreamWriter sw = File.CreateText (histfile)){ - int start = (count == history.Length) ? head : tail; - for (int i = start; i < start+count; i++){ - int p = i % history.Length; - sw.WriteLine (history [p]); - } - } - } catch { - // ignore - } - } - - // - // Appends a value to the history - // - public void Append (string s) - { - //Console.WriteLine ("APPENDING {0} head={1} tail={2}", s, head, tail); - history [head] = s; - head = (head+1) % history.Length; - if (head == tail) - tail = (tail+1 % history.Length); - if (count != history.Length) - count++; - //Console.WriteLine ("DONE: head={1} tail={2}", s, head, tail); - } - - // - // Updates the current cursor location with the string, - // to support editing of history items. For the current - // line to participate, an Append must be done before. - // - public void Update (string s) - { - history [cursor] = s; - } - - public void RemoveLast () - { - head = head-1; - if (head < 0) - head = history.Length-1; - } - - public void Accept (string s) - { - int t = head-1; - if (t < 0) - t = history.Length-1; - - history [t] = s; - } - - public bool PreviousAvailable () - { - //Console.WriteLine ("h={0} t={1} cursor={2}", head, tail, cursor); - if (count == 0) - return false; - int next = cursor-1; - if (next < 0) - next = count-1; - - if (next == head) - return false; - - return true; - } - - public bool NextAvailable () - { - if (count == 0) - return false; - int next = (cursor + 1) % history.Length; - if (next == head) - return false; - return true; - } - - - // - // Returns: a string with the previous line contents, or - // nul if there is no data in the history to move to. - // - public string Previous () - { - if (!PreviousAvailable ()) - return null; - - cursor--; - if (cursor < 0) - cursor = history.Length - 1; - - return history [cursor]; - } - - public string Next () - { - if (!NextAvailable ()) - return null; - - cursor = (cursor + 1) % history.Length; - return history [cursor]; - } - - public void CursorToEnd () - { - if (head == tail) - return; - - cursor = head; - } - - public void Dump () - { - Console.WriteLine ("Head={0} Tail={1} Cursor={2} count={3}", head, tail, cursor, count); - for (int i = 0; i < history.Length;i++){ - Console.WriteLine (" {0} {1}: {2}", i == cursor ? "==>" : " ", i, history[i]); - } - //log.Flush (); - } - - public string SearchBackward (string term) - { - for (int i = 0; i < count; i++){ - int slot = cursor-i-1; - if (slot < 0) - slot = history.Length+slot; - if (slot >= history.Length) - slot = 0; - if (history [slot] != null && history [slot].IndexOf (term) != -1){ - cursor = slot; - return history [slot]; - } - } - - return null; - } - - } - } - -#if DEMO - class Demo { - static void Main () - { - LineEditor le = new LineEditor ("foo"); - string s; - - while ((s = le.Edit ("shell> ", "")) != null){ - Console.WriteLine ("----> [{0}]", s); - } - } - } -#endif -} +// +// getline.cs: A command line editor +// +// Authors: +// Miguel de Icaza (miguel@novell.com) +// +// Copyright 2008 Novell, Inc. +// +// Dual-licensed under the terms of the MIT X11 license or the +// Apache License 2.0 +// +// USE -define:DEMO to build this as a standalone file and test it +// +// TODO: +// Enter an error (a = 1); Notice how the prompt is in the wrong line +// This is caused by Stderr not being tracked by System.Console. +// Completion support +// Why is Thread.Interrupt not working? Currently I resort to Abort which is too much. +// +// Limitations in System.Console: +// Console needs SIGWINCH support of some sort +// Console needs a way of updating its position after things have been written +// behind its back (P/Invoke puts for example). +// System.Console needs to get the DELETE character, and report accordingly. +// + +using System; +using System.Text; +using System.IO; +using System.Threading; +using System.Reflection; + +namespace Mono.Terminal { + + public class LineEditor { + + public class Completion { + public string [] Result; + public string Prefix; + + public Completion (string prefix, string [] result) + { + Prefix = prefix; + Result = result; + } + } + + public delegate Completion AutoCompleteHandler (string text, int pos); + + //static StreamWriter log; + + // The text being edited. + StringBuilder text; + + // The text as it is rendered (replaces (char)1 with ^A on display for example). + StringBuilder rendered_text; + + // The prompt specified, and the prompt shown to the user. + string prompt; + string shown_prompt; + + // The current cursor position, indexes into "text", for an index + // into rendered_text, use TextToRenderPos + int cursor; + + // The row where we started displaying data. + int home_row; + + // The maximum length that has been displayed on the screen + int max_rendered; + + // If we are done editing, this breaks the interactive loop + bool done = false; + + // The thread where the Editing started taking place + Thread edit_thread; + + // Our object that tracks history + History history; + + // The contents of the kill buffer (cut/paste in Emacs parlance) + string kill_buffer = ""; + + // The string being searched for + string search; + string last_search; + + // whether we are searching (-1= reverse; 0 = no; 1 = forward) + int searching; + + // The position where we found the match. + int match_at; + + // Used to implement the Kill semantics (multiple Alt-Ds accumulate) + KeyHandler last_handler; + + delegate void KeyHandler (); + + struct Handler { + public ConsoleKeyInfo CKI; + public KeyHandler KeyHandler; + + public Handler (ConsoleKey key, KeyHandler h) + { + CKI = new ConsoleKeyInfo ((char) 0, key, false, false, false); + KeyHandler = h; + } + + public Handler (char c, KeyHandler h) + { + KeyHandler = h; + // Use the "Zoom" as a flag that we only have a character. + CKI = new ConsoleKeyInfo (c, ConsoleKey.Zoom, false, false, false); + } + + public Handler (ConsoleKeyInfo cki, KeyHandler h) + { + CKI = cki; + KeyHandler = h; + } + + public static Handler Control (char c, KeyHandler h) + { + return new Handler ((char) (c - 'A' + 1), h); + } + + public static Handler Alt (char c, ConsoleKey k, KeyHandler h) + { + ConsoleKeyInfo cki = new ConsoleKeyInfo ((char) c, k, false, true, false); + return new Handler (cki, h); + } + } + + /// + /// Invoked when the user requests auto-completion using the tab character + /// + /// + /// The result is null for no values found, an array with a single + /// string, in that case the string should be the text to be inserted + /// for example if the word at pos is "T", the result for a completion + /// of "ToString" should be "oString", not "ToString". + /// + /// When there are multiple results, the result should be the full + /// text + /// + public AutoCompleteHandler AutoCompleteEvent; + + static Handler [] handlers; + + public LineEditor (string name) : this (name, 10) { } + + public LineEditor (string name, int histsize) + { + handlers = new Handler [] { + new Handler (ConsoleKey.Home, CmdHome), + new Handler (ConsoleKey.End, CmdEnd), + new Handler (ConsoleKey.LeftArrow, CmdLeft), + new Handler (ConsoleKey.RightArrow, CmdRight), + new Handler (ConsoleKey.UpArrow, CmdHistoryPrev), + new Handler (ConsoleKey.DownArrow, CmdHistoryNext), + new Handler (ConsoleKey.Enter, CmdDone), + new Handler (ConsoleKey.Backspace, CmdBackspace), + new Handler (ConsoleKey.Delete, CmdDeleteChar), + new Handler (ConsoleKey.Tab, CmdTabOrComplete), + + // Emacs keys + Handler.Control ('A', CmdHome), + Handler.Control ('E', CmdEnd), + Handler.Control ('B', CmdLeft), + Handler.Control ('F', CmdRight), + Handler.Control ('P', CmdHistoryPrev), + Handler.Control ('N', CmdHistoryNext), + Handler.Control ('K', CmdKillToEOF), + Handler.Control ('Y', CmdYank), + Handler.Control ('D', CmdDeleteChar), + Handler.Control ('L', CmdRefresh), + Handler.Control ('R', CmdReverseSearch), + Handler.Control ('G', delegate {} ), + Handler.Alt ('B', ConsoleKey.B, CmdBackwardWord), + Handler.Alt ('F', ConsoleKey.F, CmdForwardWord), + + Handler.Alt ('D', ConsoleKey.D, CmdDeleteWord), + Handler.Alt ((char) 8, ConsoleKey.Backspace, CmdDeleteBackword), + + // DEBUG + //Handler.Control ('T', CmdDebug), + + // quote + Handler.Control ('Q', delegate { HandleChar (Console.ReadKey (true).KeyChar); }) + }; + + rendered_text = new StringBuilder (); + text = new StringBuilder (); + + history = new History (name, histsize); + + //if (File.Exists ("log"))File.Delete ("log"); + //log = File.CreateText ("log"); + } + + void CmdDebug () + { + history.Dump (); + Console.WriteLine (); + Render (); + } + + void Render () + { + Console.Write (shown_prompt); + Console.Write (rendered_text); + + int max = System.Math.Max (rendered_text.Length + shown_prompt.Length, max_rendered); + + for (int i = rendered_text.Length + shown_prompt.Length; i < max_rendered; i++) + Console.Write (' '); + max_rendered = shown_prompt.Length + rendered_text.Length; + + // Write one more to ensure that we always wrap around properly if we are at the + // end of a line. + Console.Write (' '); + + UpdateHomeRow (max); + } + + void UpdateHomeRow (int screenpos) + { + int lines = 1 + (screenpos / Console.WindowWidth); + + home_row = Console.CursorTop - (lines - 1); + if (home_row < 0) + home_row = 0; + } + + + void RenderFrom (int pos) + { + int rpos = TextToRenderPos (pos); + int i; + + for (i = rpos; i < rendered_text.Length; i++) + Console.Write (rendered_text [i]); + + if ((shown_prompt.Length + rendered_text.Length) > max_rendered) + max_rendered = shown_prompt.Length + rendered_text.Length; + else { + int max_extra = max_rendered - shown_prompt.Length; + for (; i < max_extra; i++) + Console.Write (' '); + } + } + + void ComputeRendered () + { + rendered_text.Length = 0; + + for (int i = 0; i < text.Length; i++){ + int c = (int) text [i]; + if (c < 26){ + if (c == '\t') + rendered_text.Append (" "); + else { + rendered_text.Append ('^'); + rendered_text.Append ((char) (c + (int) 'A' - 1)); + } + } else + rendered_text.Append ((char)c); + } + } + + int TextToRenderPos (int pos) + { + int p = 0; + + for (int i = 0; i < pos; i++){ + int c; + + c = (int) text [i]; + + if (c < 26){ + if (c == 9) + p += 4; + else + p += 2; + } else + p++; + } + + return p; + } + + int TextToScreenPos (int pos) + { + return shown_prompt.Length + TextToRenderPos (pos); + } + + string Prompt { + get { return prompt; } + set { prompt = value; } + } + + int LineCount { + get { + return (shown_prompt.Length + rendered_text.Length)/Console.WindowWidth; + } + } + + void ForceCursor (int newpos) + { + cursor = newpos; + + int actual_pos = shown_prompt.Length + TextToRenderPos (cursor); + int row = home_row + (actual_pos/Console.WindowWidth); + int col = actual_pos % Console.WindowWidth; + + if (row >= Console.BufferHeight) + row = Console.BufferHeight-1; + Console.SetCursorPosition (col, row); + + //log.WriteLine ("Going to cursor={0} row={1} col={2} actual={3} prompt={4} ttr={5} old={6}", newpos, row, col, actual_pos, prompt.Length, TextToRenderPos (cursor), cursor); + //log.Flush (); + } + + void UpdateCursor (int newpos) + { + if (cursor == newpos) + return; + + ForceCursor (newpos); + } + + void InsertChar (char c) + { + int prev_lines = LineCount; + text = text.Insert (cursor, c); + ComputeRendered (); + if (prev_lines != LineCount){ + + Console.SetCursorPosition (0, home_row); + Render (); + ForceCursor (++cursor); + } else { + RenderFrom (cursor); + ForceCursor (++cursor); + UpdateHomeRow (TextToScreenPos (cursor)); + } + } + + // + // Commands + // + void CmdDone () + { + done = true; + } + + void CmdTabOrComplete () + { + bool complete = false; + + if (AutoCompleteEvent != null){ + if (TabAtStartCompletes) + complete = true; + else { + for (int i = 0; i < cursor; i++){ + if (!Char.IsWhiteSpace (text [i])){ + complete = true; + break; + } + } + } + + if (complete){ + Completion completion = AutoCompleteEvent (text.ToString (), cursor); + string [] completions = completion.Result; + if (completions == null) + return; + + int ncompletions = completions.Length; + if (ncompletions == 0) + return; + + if (completions.Length == 1){ + InsertTextAtCursor (completions [0]); + } else { + int last = -1; + + for (int p = 0; p < completions [0].Length; p++){ + char c = completions [0][p]; + + + for (int i = 1; i < ncompletions; i++){ + if (completions [i].Length < p) + goto mismatch; + + if (completions [i][p] != c){ + goto mismatch; + } + } + last = p; + } + mismatch: + if (last != -1){ + InsertTextAtCursor (completions [0].Substring (0, last+1)); + } + Console.WriteLine (); + foreach (string s in completions){ + Console.Write (completion.Prefix); + Console.Write (s); + Console.Write (' '); + } + Console.WriteLine (); + Render (); + ForceCursor (cursor); + } + } else + HandleChar ('\t'); + } else + HandleChar ('t'); + } + + void CmdHome () + { + UpdateCursor (0); + } + + void CmdEnd () + { + UpdateCursor (text.Length); + } + + void CmdLeft () + { + if (cursor == 0) + return; + + UpdateCursor (cursor-1); + } + + void CmdBackwardWord () + { + int p = WordBackward (cursor); + if (p == -1) + return; + UpdateCursor (p); + } + + void CmdForwardWord () + { + int p = WordForward (cursor); + if (p == -1) + return; + UpdateCursor (p); + } + + void CmdRight () + { + if (cursor == text.Length) + return; + + UpdateCursor (cursor+1); + } + + void RenderAfter (int p) + { + ForceCursor (p); + RenderFrom (p); + ForceCursor (cursor); + } + + void CmdBackspace () + { + if (cursor == 0) + return; + + text.Remove (--cursor, 1); + ComputeRendered (); + RenderAfter (cursor); + } + + void CmdDeleteChar () + { + // If there is no input, this behaves like EOF + if (text.Length == 0){ + done = true; + text = null; + Console.WriteLine (); + return; + } + + if (cursor == text.Length) + return; + text.Remove (cursor, 1); + ComputeRendered (); + RenderAfter (cursor); + } + + int WordForward (int p) + { + if (p >= text.Length) + return -1; + + int i = p; + if (Char.IsPunctuation (text [p]) || Char.IsSymbol (text [p]) || Char.IsWhiteSpace (text[p])){ + for (; i < text.Length; i++){ + if (Char.IsLetterOrDigit (text [i])) + break; + } + for (; i < text.Length; i++){ + if (!Char.IsLetterOrDigit (text [i])) + break; + } + } else { + for (; i < text.Length; i++){ + if (!Char.IsLetterOrDigit (text [i])) + break; + } + } + if (i != p) + return i; + return -1; + } + + int WordBackward (int p) + { + if (p == 0) + return -1; + + int i = p-1; + if (i == 0) + return 0; + + if (Char.IsPunctuation (text [i]) || Char.IsSymbol (text [i]) || Char.IsWhiteSpace (text[i])){ + for (; i >= 0; i--){ + if (Char.IsLetterOrDigit (text [i])) + break; + } + for (; i >= 0; i--){ + if (!Char.IsLetterOrDigit (text[i])) + break; + } + } else { + for (; i >= 0; i--){ + if (!Char.IsLetterOrDigit (text [i])) + break; + } + } + i++; + + if (i != p) + return i; + + return -1; + } + + void CmdDeleteWord () + { + int pos = WordForward (cursor); + + if (pos == -1) + return; + + string k = text.ToString (cursor, pos-cursor); + + if (last_handler == CmdDeleteWord) + kill_buffer = kill_buffer + k; + else + kill_buffer = k; + + text.Remove (cursor, pos-cursor); + ComputeRendered (); + RenderAfter (cursor); + } + + void CmdDeleteBackword () + { + int pos = WordBackward (cursor); + if (pos == -1) + return; + + string k = text.ToString (pos, cursor-pos); + + if (last_handler == CmdDeleteBackword) + kill_buffer = k + kill_buffer; + else + kill_buffer = k; + + text.Remove (pos, cursor-pos); + ComputeRendered (); + RenderAfter (pos); + } + + // + // Adds the current line to the history if needed + // + void HistoryUpdateLine () + { + history.Update (text.ToString ()); + } + + void CmdHistoryPrev () + { + if (!history.PreviousAvailable ()) + return; + + HistoryUpdateLine (); + + SetText (history.Previous ()); + } + + void CmdHistoryNext () + { + if (!history.NextAvailable()) + return; + + history.Update (text.ToString ()); + SetText (history.Next ()); + + } + + void CmdKillToEOF () + { + kill_buffer = text.ToString (cursor, text.Length-cursor); + text.Length = cursor; + ComputeRendered (); + RenderAfter (cursor); + } + + void CmdYank () + { + InsertTextAtCursor (kill_buffer); + } + + void InsertTextAtCursor (string str) + { + int prev_lines = LineCount; + text.Insert (cursor, str); + ComputeRendered (); + if (prev_lines != LineCount){ + Console.SetCursorPosition (0, home_row); + Render (); + cursor += str.Length; + ForceCursor (cursor); + } else { + RenderFrom (cursor); + cursor += str.Length; + ForceCursor (cursor); + UpdateHomeRow (TextToScreenPos (cursor)); + } + } + + void SetSearchPrompt (string s) + { + SetPrompt ("(reverse-i-search)`" + s + "': "); + } + + void ReverseSearch () + { + int p; + + if (cursor == text.Length){ + // The cursor is at the end of the string + + p = text.ToString ().LastIndexOf (search); + if (p != -1){ + match_at = p; + cursor = p; + ForceCursor (cursor); + return; + } + } else { + // The cursor is somewhere in the middle of the string + int start = (cursor == match_at) ? cursor - 1 : cursor; + if (start != -1){ + p = text.ToString ().LastIndexOf (search, start); + if (p != -1){ + match_at = p; + cursor = p; + ForceCursor (cursor); + return; + } + } + } + + // Need to search backwards in history + HistoryUpdateLine (); + string s = history.SearchBackward (search); + if (s != null){ + match_at = -1; + SetText (s); + ReverseSearch (); + } + } + + void CmdReverseSearch () + { + if (searching == 0){ + match_at = -1; + last_search = search; + searching = -1; + search = ""; + SetSearchPrompt (""); + } else { + if (search == ""){ + if (last_search != "" && last_search != null){ + search = last_search; + SetSearchPrompt (search); + + ReverseSearch (); + } + return; + } + ReverseSearch (); + } + } + + void SearchAppend (char c) + { + search = search + c; + SetSearchPrompt (search); + + // + // If the new typed data still matches the current text, stay here + // + if (cursor < text.Length){ + string r = text.ToString (cursor, text.Length - cursor); + if (r.StartsWith (search)) + return; + } + + ReverseSearch (); + } + + void CmdRefresh () + { + Console.Clear (); + max_rendered = 0; + Render (); + ForceCursor (cursor); + } + + void InterruptEdit (object sender, ConsoleCancelEventArgs a) + { + // Do not abort our program: + a.Cancel = true; + + // Interrupt the editor + edit_thread.Abort(); + } + + void HandleChar (char c) + { + if (searching != 0) + SearchAppend (c); + else + InsertChar (c); + } + + void EditLoop () + { + ConsoleKeyInfo cki; + + while (!done){ + ConsoleModifiers mod; + + cki = Console.ReadKey (true); + if (cki.Key == ConsoleKey.Escape){ + cki = Console.ReadKey (true); + + mod = ConsoleModifiers.Alt; + } else + mod = cki.Modifiers; + + bool handled = false; + + foreach (Handler handler in handlers){ + ConsoleKeyInfo t = handler.CKI; + + if (t.Key == cki.Key && t.Modifiers == mod){ + handled = true; + handler.KeyHandler (); + last_handler = handler.KeyHandler; + break; + } else if (t.KeyChar == cki.KeyChar && t.Key == ConsoleKey.Zoom){ + handled = true; + handler.KeyHandler (); + last_handler = handler.KeyHandler; + break; + } + } + if (handled){ + if (searching != 0){ + if (last_handler != CmdReverseSearch){ + searching = 0; + SetPrompt (prompt); + } + } + continue; + } + + if (cki.KeyChar != (char) 0) + HandleChar (cki.KeyChar); + } + } + + void InitText (string initial) + { + text = new StringBuilder (initial); + ComputeRendered (); + cursor = text.Length; + Render (); + ForceCursor (cursor); + } + + void SetText (string newtext) + { + Console.SetCursorPosition (0, home_row); + InitText (newtext); + } + + void SetPrompt (string newprompt) + { + shown_prompt = newprompt; + Console.SetCursorPosition (0, home_row); + Render (); + ForceCursor (cursor); + } + + public string Edit (string prompt, string initial) + { + edit_thread = Thread.CurrentThread; + searching = 0; + Console.CancelKeyPress += InterruptEdit; + + done = false; + history.CursorToEnd (); + max_rendered = 0; + + Prompt = prompt; + shown_prompt = prompt; + InitText (initial); + history.Append (initial); + + do { + try { + EditLoop (); + } catch (ThreadAbortException){ + searching = 0; + Thread.ResetAbort (); + Console.WriteLine (); + SetPrompt (prompt); + SetText (""); + } + } while (!done); + Console.WriteLine (); + + Console.CancelKeyPress -= InterruptEdit; + + if (text == null){ + history.Close (); + return null; + } + + string result = text.ToString (); + if (result != "") + history.Accept (result); + else + history.RemoveLast (); + + return result; + } + + public void SaveHistory () + { + if (history != null) { + history.Close (); + } + } + + public bool TabAtStartCompletes { get; set; } + + // + // Emulates the bash-like behavior, where edits done to the + // history are recorded + // + class History { + string [] history; + int head, tail; + int cursor, count; + string histfile; + + public History (string app, int size) + { + if (size < 1) + throw new ArgumentException ("size"); + + if (app != null){ + string dir = Environment.GetFolderPath (Environment.SpecialFolder.Personal); + //Console.WriteLine (dir); + /* + if (!Directory.Exists (dir)){ + try { + Directory.CreateDirectory (dir); + } catch { + app = null; + } + } + if (app != null) + histfile = Path.Combine (dir, app) + ".history"; + */ + histfile = Path.Combine (dir, ".mal-history"); + } + + history = new string [size]; + head = tail = cursor = 0; + + if (File.Exists (histfile)){ + using (StreamReader sr = File.OpenText (histfile)){ + string line; + + while ((line = sr.ReadLine ()) != null){ + if (line != "") + Append (line); + } + } + } + } + + public void Close () + { + if (histfile == null) + return; + + try { + using (StreamWriter sw = File.CreateText (histfile)){ + int start = (count == history.Length) ? head : tail; + for (int i = start; i < start+count; i++){ + int p = i % history.Length; + sw.WriteLine (history [p]); + } + } + } catch { + // ignore + } + } + + // + // Appends a value to the history + // + public void Append (string s) + { + //Console.WriteLine ("APPENDING {0} head={1} tail={2}", s, head, tail); + history [head] = s; + head = (head+1) % history.Length; + if (head == tail) + tail = (tail+1 % history.Length); + if (count != history.Length) + count++; + //Console.WriteLine ("DONE: head={1} tail={2}", s, head, tail); + } + + // + // Updates the current cursor location with the string, + // to support editing of history items. For the current + // line to participate, an Append must be done before. + // + public void Update (string s) + { + history [cursor] = s; + } + + public void RemoveLast () + { + head = head-1; + if (head < 0) + head = history.Length-1; + } + + public void Accept (string s) + { + int t = head-1; + if (t < 0) + t = history.Length-1; + + history [t] = s; + } + + public bool PreviousAvailable () + { + //Console.WriteLine ("h={0} t={1} cursor={2}", head, tail, cursor); + if (count == 0) + return false; + int next = cursor-1; + if (next < 0) + next = count-1; + + if (next == head) + return false; + + return true; + } + + public bool NextAvailable () + { + if (count == 0) + return false; + int next = (cursor + 1) % history.Length; + if (next == head) + return false; + return true; + } + + + // + // Returns: a string with the previous line contents, or + // nul if there is no data in the history to move to. + // + public string Previous () + { + if (!PreviousAvailable ()) + return null; + + cursor--; + if (cursor < 0) + cursor = history.Length - 1; + + return history [cursor]; + } + + public string Next () + { + if (!NextAvailable ()) + return null; + + cursor = (cursor + 1) % history.Length; + return history [cursor]; + } + + public void CursorToEnd () + { + if (head == tail) + return; + + cursor = head; + } + + public void Dump () + { + Console.WriteLine ("Head={0} Tail={1} Cursor={2} count={3}", head, tail, cursor, count); + for (int i = 0; i < history.Length;i++){ + Console.WriteLine (" {0} {1}: {2}", i == cursor ? "==>" : " ", i, history[i]); + } + //log.Flush (); + } + + public string SearchBackward (string term) + { + for (int i = 0; i < count; i++){ + int slot = cursor-i-1; + if (slot < 0) + slot = history.Length+slot; + if (slot >= history.Length) + slot = 0; + if (history [slot] != null && history [slot].IndexOf (term) != -1){ + cursor = slot; + return history [slot]; + } + } + + return null; + } + + } + } + +#if DEMO + class Demo { + static void Main () + { + LineEditor le = new LineEditor ("foo"); + string s; + + while ((s = le.Edit ("shell> ", "")) != null){ + Console.WriteLine ("----> [{0}]", s); + } + } + } +#endif +} diff --git a/impls/fsharp/tests/step5_tco.mal b/impls/fsharp/tests/step5_tco.mal index db45a80336..49f0b463a8 100644 --- a/impls/fsharp/tests/step5_tco.mal +++ b/impls/fsharp/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; F#: skipping non-TCO recursion -;; Reason: completes at 10,000, unrecoverable segfault at 20,000 +;; F#: skipping non-TCO recursion +;; Reason: completes at 10,000, unrecoverable segfault at 20,000 diff --git a/impls/fsharp/tokenizer.fs b/impls/fsharp/tokenizer.fs index 6bfbc74159..f4595e2f43 100644 --- a/impls/fsharp/tokenizer.fs +++ b/impls/fsharp/tokenizer.fs @@ -1,115 +1,115 @@ -module Tokenizer - - open System - open Types - - type Token = - | EOF - | OpenBracket | CloseBracket - | OpenBrace | CloseBrace - | OpenParen | CloseParen - | SingleQuote - | Backtick - | Tilde | SpliceUnquote - | Caret - | At - | String of string - | Token of string - | Keyword of string - | Number of string - - - let tokenize (str : string) = - let len = str.Length - - let inline isWhiteSpace ch = ch = ',' || Char.IsWhiteSpace(ch) - let inline isNotNewline ch = ch <> '\r' && ch <> '\n' - let inline isDigit ch = Char.IsDigit(ch) - let inline isTokenChar ch = - match ch with - | '[' | ']' | '{' | '}' | '(' | ')' - | '\'' | '"' | '`' | ',' | ';' -> false - | ch when Char.IsWhiteSpace(ch) -> false - | _ -> true - - let rec skipWhile pred p = - if p >= len then p - elif pred (str.[p]) then p + 1 |> skipWhile pred - else p - - let rec accumulateWhile pred (f : string -> Token) start p = - if p >= len then str.Substring(start, p - start) |> f, p - elif pred (str.[p]) then p + 1 |> accumulateWhile pred f start - else str.Substring(start, p - start) |> f, p - - let accumulateString p = - let b = System.Text.StringBuilder() - let rec accChar (ch : char) n = - b.Append(ch) |> ignore - accChars n - and accChars p = - let n = p + 1 - if p >= len then raise <| Error.expectedXButEOF "'\"'" - match str.[p] with - | '\\' -> accEscaped n - | '"' -> n - | ch -> accChar ch n - and accEscaped p = - let n = p + 1 - if p >= len then raise <| Error.expectedXButEOF "char" - match str.[p] with - | 't' -> accChar '\t' n - | 'b' -> accChar '\b' n - | 'n' -> accChar '\n' n - | 'r' -> accChar '\r' n - | 'f' -> accChar '\f' n - | '\'' -> accChar '\'' n - | '"' -> accChar '"' n - | '\\' -> accChar '\\' n - | _ -> raise <| Error.expectedXButEOF "valid escape char" - let n = accChars p - String(b.ToString()), n - - let accumulateKeyword p = - let n = p + 1 - if p >= len then raise <| Error.expectedXButEOF "keyword" - elif isTokenChar str.[p] then accumulateWhile isTokenChar Keyword p n - else raise <| Error.expectedX "keyword char" - - let accumulateSpliceUnquote p = - if p >= len then Tilde, p - elif str.[p] = '@' then SpliceUnquote, (p + 1) - else Tilde, p - - let rec getToken p = - if p >= len then - EOF, p - else - let n = p + 1 - match str.[p] with - | ch when isWhiteSpace ch -> getToken n - | ';' -> skipWhile isNotNewline n |> getToken - | '[' -> OpenBracket, n - | ']' -> CloseBracket, n - | '{' -> OpenBrace, n - | '}' -> CloseBrace, n - | '(' -> OpenParen, n - | ')' -> CloseParen, n - | '\'' -> SingleQuote, n - | '`' -> Backtick, n - | '~' -> accumulateSpliceUnquote n - | '^' -> Caret, n - | '@' -> At, n - | '"' -> accumulateString n - | ':' -> accumulateKeyword n - | '-' when n < len && isDigit str.[n] -> accumulateWhile isDigit Number p n - | ch when isDigit ch -> accumulateWhile isDigit Number p n - | ch when isTokenChar ch -> accumulateWhile isTokenChar Token p n - | _ -> raise <| Error.unexpectedChar () - - let rec accumulate acc p = - match getToken p with - | EOF, p -> List.rev acc - | tok, p -> accumulate (tok::acc) p - - accumulate [] 0 +module Tokenizer + + open System + open Types + + type Token = + | EOF + | OpenBracket | CloseBracket + | OpenBrace | CloseBrace + | OpenParen | CloseParen + | SingleQuote + | Backtick + | Tilde | SpliceUnquote + | Caret + | At + | String of string + | Token of string + | Keyword of string + | Number of string + + + let tokenize (str : string) = + let len = str.Length + + let inline isWhiteSpace ch = ch = ',' || Char.IsWhiteSpace(ch) + let inline isNotNewline ch = ch <> '\r' && ch <> '\n' + let inline isDigit ch = Char.IsDigit(ch) + let inline isTokenChar ch = + match ch with + | '[' | ']' | '{' | '}' | '(' | ')' + | '\'' | '"' | '`' | ',' | ';' -> false + | ch when Char.IsWhiteSpace(ch) -> false + | _ -> true + + let rec skipWhile pred p = + if p >= len then p + elif pred (str.[p]) then p + 1 |> skipWhile pred + else p + + let rec accumulateWhile pred (f : string -> Token) start p = + if p >= len then str.Substring(start, p - start) |> f, p + elif pred (str.[p]) then p + 1 |> accumulateWhile pred f start + else str.Substring(start, p - start) |> f, p + + let accumulateString p = + let b = System.Text.StringBuilder() + let rec accChar (ch : char) n = + b.Append(ch) |> ignore + accChars n + and accChars p = + let n = p + 1 + if p >= len then raise <| Error.expectedXButEOF "'\"'" + match str.[p] with + | '\\' -> accEscaped n + | '"' -> n + | ch -> accChar ch n + and accEscaped p = + let n = p + 1 + if p >= len then raise <| Error.expectedXButEOF "char" + match str.[p] with + | 't' -> accChar '\t' n + | 'b' -> accChar '\b' n + | 'n' -> accChar '\n' n + | 'r' -> accChar '\r' n + | 'f' -> accChar '\f' n + | '\'' -> accChar '\'' n + | '"' -> accChar '"' n + | '\\' -> accChar '\\' n + | _ -> raise <| Error.expectedXButEOF "valid escape char" + let n = accChars p + String(b.ToString()), n + + let accumulateKeyword p = + let n = p + 1 + if p >= len then raise <| Error.expectedXButEOF "keyword" + elif isTokenChar str.[p] then accumulateWhile isTokenChar Keyword p n + else raise <| Error.expectedX "keyword char" + + let accumulateSpliceUnquote p = + if p >= len then Tilde, p + elif str.[p] = '@' then SpliceUnquote, (p + 1) + else Tilde, p + + let rec getToken p = + if p >= len then + EOF, p + else + let n = p + 1 + match str.[p] with + | ch when isWhiteSpace ch -> getToken n + | ';' -> skipWhile isNotNewline n |> getToken + | '[' -> OpenBracket, n + | ']' -> CloseBracket, n + | '{' -> OpenBrace, n + | '}' -> CloseBrace, n + | '(' -> OpenParen, n + | ')' -> CloseParen, n + | '\'' -> SingleQuote, n + | '`' -> Backtick, n + | '~' -> accumulateSpliceUnquote n + | '^' -> Caret, n + | '@' -> At, n + | '"' -> accumulateString n + | ':' -> accumulateKeyword n + | '-' when n < len && isDigit str.[n] -> accumulateWhile isDigit Number p n + | ch when isDigit ch -> accumulateWhile isDigit Number p n + | ch when isTokenChar ch -> accumulateWhile isTokenChar Token p n + | _ -> raise <| Error.unexpectedChar () + + let rec accumulate acc p = + match getToken p with + | EOF, p -> List.rev acc + | tok, p -> accumulate (tok::acc) p + + accumulate [] 0 diff --git a/impls/fsharp/types.fs b/impls/fsharp/types.fs index f58e98e2fd..030c677815 100644 --- a/impls/fsharp/types.fs +++ b/impls/fsharp/types.fs @@ -1,134 +1,134 @@ -module Types - - [] - type Node = - | Nil - | List of Metadata * Node list - | Vector of Metadata * Node System.ArraySegment - | Map of Metadata * Collections.Map - | Symbol of string - | Keyword of string - | Number of int64 - | String of string - | Bool of bool - | BuiltInFunc of Metadata * int * (Node list -> Node) - | Func of Metadata * int * (Node list -> Node) * Node * Node list * EnvChain - | Macro of Metadata * int * (Node list -> Node) * Node * Node list * EnvChain - | Atom of int * Node Ref - - static member private hashSeq (s : seq) = - let iter st node = (st * 397) ^^^ node.GetHashCode() - s |> Seq.fold iter 0 - - static member private allEqual (x : seq) (y : seq) = - use ex = x.GetEnumerator() - use ey = y.GetEnumerator() - let rec loop () = - match ex.MoveNext(), ey.MoveNext() with - | false, false -> true - | false, true - | true, false -> false - | true, true -> - if ex.Current = ey.Current then - loop () - else - false - loop () - - static member private allCompare (x : seq) (y : seq) = - use ex = x.GetEnumerator() - use ey = y.GetEnumerator() - let rec loop () = - match ex.MoveNext(), ey.MoveNext() with - | false, false -> 0 - | false, true -> -1 - | true, false -> 1 - | true, true -> - let cmp = compare ex.Current ey.Current - if cmp = 0 then loop () else cmp - loop () - - static member private rank x = - match x with - | Nil -> 0 - | List(_, _) -> 1 - | Vector(_, _) -> 2 - | Map(_, _) -> 3 - | Symbol(_) -> 4 - | Keyword(_) -> 5 - | Number(_) -> 6 - | String(_) -> 7 - | Bool(_) -> 8 - | BuiltInFunc(_, _, _) - | Func(_, _, _, _, _, _) - | Macro(_, _, _, _, _, _) -> 9 - | Atom(_, _) -> 10 - - static member private equals x y = - match x, y with - | Nil, Nil -> true - | List(_, a), List(_, b) -> a = b - | List(_, a), Vector(_, b) -> Node.allEqual a b - | Vector(_, a), List(_, b) -> Node.allEqual a b - | Vector(_, a), Vector(_, b) -> Node.allEqual a b - | Map(_, a), Map(_, b) -> a = b - | Symbol(a), Symbol(b) -> a = b - | Keyword(a), Keyword(b) -> a = b - | Number(a), Number(b) -> a = b - | String(a), String(b) -> a = b - | Bool(a), Bool(b) -> a = b - | (BuiltInFunc(_, a, _) | Func(_, a, _, _, _, _) | Macro(_, a, _, _, _, _)), - (BuiltInFunc(_, b, _) | Func(_, b, _, _, _, _) | Macro(_, b, _, _, _, _)) -> - a = b - | Atom(a, _), Atom(b, _) -> a = b - | _, _ -> false - - static member private compare x y = - match x, y with - | Nil, Nil -> 0 - | List(_, a), List(_, b) -> compare a b - | List(_, a), Vector(_, b) -> Node.allCompare a b - | Vector(_, a), List(_, b) -> Node.allCompare a b - | Vector(_, a), Vector(_, b) -> Node.allCompare a b - | Map(_, a), Map(_, b) -> compare a b - | Symbol(a), Symbol(b) -> compare a b - | Keyword(a), Keyword(b) -> compare a b - | Number(a), Number(b) -> compare a b - | String(a), String(b) -> compare a b - | Bool(a), Bool(b) -> compare a b - | (BuiltInFunc(_, a, _) | Func(_, a, _, _, _, _) | Macro(_, a, _, _, _, _)), - (BuiltInFunc(_, b, _) | Func(_, b, _, _, _, _) | Macro(_, b, _, _, _, _)) -> - compare a b - | Atom(a, _), Atom(b, _) -> compare a b - | a, b -> compare (Node.rank a) (Node.rank b) - - override x.Equals yobj = - match yobj with - | :? Node as y -> Node.equals x y - | _ -> false - - override x.GetHashCode() = - match x with - | Nil -> 0 - | List(_, lst) -> hash lst - | Vector(_, vec) -> Node.hashSeq vec - | Map(_, map) -> hash map - | Symbol(sym) -> hash sym - | Keyword(key) -> hash key - | Number(num) -> hash num - | String(str) -> hash str - | Bool(b) -> hash b - | BuiltInFunc(_, tag, _) | Func(_, tag, _, _, _, _) | Macro(_, tag, _, _, _, _) -> - hash tag - | Atom(tag, _) -> hash tag - - interface System.IComparable with - member x.CompareTo yobj = - match yobj with - | :? Node as y -> Node.compare x y - | _ -> invalidArg "yobj" "Cannot compare values of different types." - - - and Env = System.Collections.Generic.Dictionary - and EnvChain = Env list - and Metadata = Node +module Types + + [] + type Node = + | Nil + | List of Metadata * Node list + | Vector of Metadata * Node System.ArraySegment + | Map of Metadata * Collections.Map + | Symbol of string + | Keyword of string + | Number of int64 + | String of string + | Bool of bool + | BuiltInFunc of Metadata * int * (Node list -> Node) + | Func of Metadata * int * (Node list -> Node) * Node * Node list * EnvChain + | Macro of Metadata * int * (Node list -> Node) * Node * Node list * EnvChain + | Atom of int * Node Ref + + static member private hashSeq (s : seq) = + let iter st node = (st * 397) ^^^ node.GetHashCode() + s |> Seq.fold iter 0 + + static member private allEqual (x : seq) (y : seq) = + use ex = x.GetEnumerator() + use ey = y.GetEnumerator() + let rec loop () = + match ex.MoveNext(), ey.MoveNext() with + | false, false -> true + | false, true + | true, false -> false + | true, true -> + if ex.Current = ey.Current then + loop () + else + false + loop () + + static member private allCompare (x : seq) (y : seq) = + use ex = x.GetEnumerator() + use ey = y.GetEnumerator() + let rec loop () = + match ex.MoveNext(), ey.MoveNext() with + | false, false -> 0 + | false, true -> -1 + | true, false -> 1 + | true, true -> + let cmp = compare ex.Current ey.Current + if cmp = 0 then loop () else cmp + loop () + + static member private rank x = + match x with + | Nil -> 0 + | List(_, _) -> 1 + | Vector(_, _) -> 2 + | Map(_, _) -> 3 + | Symbol(_) -> 4 + | Keyword(_) -> 5 + | Number(_) -> 6 + | String(_) -> 7 + | Bool(_) -> 8 + | BuiltInFunc(_, _, _) + | Func(_, _, _, _, _, _) + | Macro(_, _, _, _, _, _) -> 9 + | Atom(_, _) -> 10 + + static member private equals x y = + match x, y with + | Nil, Nil -> true + | List(_, a), List(_, b) -> a = b + | List(_, a), Vector(_, b) -> Node.allEqual a b + | Vector(_, a), List(_, b) -> Node.allEqual a b + | Vector(_, a), Vector(_, b) -> Node.allEqual a b + | Map(_, a), Map(_, b) -> a = b + | Symbol(a), Symbol(b) -> a = b + | Keyword(a), Keyword(b) -> a = b + | Number(a), Number(b) -> a = b + | String(a), String(b) -> a = b + | Bool(a), Bool(b) -> a = b + | (BuiltInFunc(_, a, _) | Func(_, a, _, _, _, _) | Macro(_, a, _, _, _, _)), + (BuiltInFunc(_, b, _) | Func(_, b, _, _, _, _) | Macro(_, b, _, _, _, _)) -> + a = b + | Atom(a, _), Atom(b, _) -> a = b + | _, _ -> false + + static member private compare x y = + match x, y with + | Nil, Nil -> 0 + | List(_, a), List(_, b) -> compare a b + | List(_, a), Vector(_, b) -> Node.allCompare a b + | Vector(_, a), List(_, b) -> Node.allCompare a b + | Vector(_, a), Vector(_, b) -> Node.allCompare a b + | Map(_, a), Map(_, b) -> compare a b + | Symbol(a), Symbol(b) -> compare a b + | Keyword(a), Keyword(b) -> compare a b + | Number(a), Number(b) -> compare a b + | String(a), String(b) -> compare a b + | Bool(a), Bool(b) -> compare a b + | (BuiltInFunc(_, a, _) | Func(_, a, _, _, _, _) | Macro(_, a, _, _, _, _)), + (BuiltInFunc(_, b, _) | Func(_, b, _, _, _, _) | Macro(_, b, _, _, _, _)) -> + compare a b + | Atom(a, _), Atom(b, _) -> compare a b + | a, b -> compare (Node.rank a) (Node.rank b) + + override x.Equals yobj = + match yobj with + | :? Node as y -> Node.equals x y + | _ -> false + + override x.GetHashCode() = + match x with + | Nil -> 0 + | List(_, lst) -> hash lst + | Vector(_, vec) -> Node.hashSeq vec + | Map(_, map) -> hash map + | Symbol(sym) -> hash sym + | Keyword(key) -> hash key + | Number(num) -> hash num + | String(str) -> hash str + | Bool(b) -> hash b + | BuiltInFunc(_, tag, _) | Func(_, tag, _, _, _, _) | Macro(_, tag, _, _, _, _) -> + hash tag + | Atom(tag, _) -> hash tag + + interface System.IComparable with + member x.CompareTo yobj = + match yobj with + | :? Node as y -> Node.compare x y + | _ -> invalidArg "yobj" "Cannot compare values of different types." + + + and Env = System.Collections.Generic.Dictionary + and EnvChain = Env list + and Metadata = Node diff --git a/impls/gnu-smalltalk/Dockerfile b/impls/gnu-smalltalk/Dockerfile index 81b7cebc03..c161a72e2b 100644 --- a/impls/gnu-smalltalk/Dockerfile +++ b/impls/gnu-smalltalk/Dockerfile @@ -1,26 +1,26 @@ -FROM ubuntu:wily -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# picolisp -RUN apt-get -y install gnu-smalltalk - +FROM ubuntu:wily +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# picolisp +RUN apt-get -y install gnu-smalltalk + diff --git a/impls/gnu-smalltalk/Makefile b/impls/gnu-smalltalk/Makefile index 7af3113c71..14414a8c2b 100644 --- a/impls/gnu-smalltalk/Makefile +++ b/impls/gnu-smalltalk/Makefile @@ -1,3 +1,3 @@ -all: - -clean: +all: + +clean: diff --git a/impls/gnu-smalltalk/core.st b/impls/gnu-smalltalk/core.st index 4509facdac..f7b08b9c0e 100644 --- a/impls/gnu-smalltalk/core.st +++ b/impls/gnu-smalltalk/core.st @@ -1,255 +1,255 @@ -Object subclass: Core [ - Ns := Dictionary new. - Core class >> Ns [ ^Ns ] - - Core class >> coerce: block [ - block value ifTrue: [ ^MALObject True ] ifFalse: [ ^MALObject False ] - ] - - Core class >> nilable: args else: block [ - args first type = #nil ifTrue: [ - ^MALObject Nil - ] ifFalse: [ - ^block value - ] - ] - - Core class >> printedArgs: args readable: readable sep: sep [ - | items | - items := args collect: - [ :arg | Printer prStr: arg printReadably: readable ]. - "NOTE: {} join returns the unchanged array" - items isEmpty ifTrue: [ ^'' ] ifFalse: [ ^items join: sep ] - ] -] - -Core Ns at: #+ put: - (Fn new: [ :args | MALNumber new: args first value + args second value ]). -Core Ns at: #- put: - (Fn new: [ :args | MALNumber new: args first value - args second value ]). -Core Ns at: #* put: - (Fn new: [ :args | MALNumber new: args first value * args second value ]). -Core Ns at: #/ put: - (Fn new: [ :args | MALNumber new: args first value // args second value ]). - -Core Ns at: #'pr-str' put: - (Fn new: [ :args | MALString new: (Core printedArgs: args readable: true - sep: ' ') ]). -Core Ns at: #str put: - (Fn new: [ :args | MALString new: (Core printedArgs: args readable: false - sep: '') ]). -Core Ns at: #prn put: - (Fn new: [ :args | - (Core printedArgs: args readable: true sep: ' ') displayNl. - MALObject Nil ]). -Core Ns at: #println put: - (Fn new: [ :args | - (Core printedArgs: args readable: false sep: ' ') displayNl. - MALObject Nil ]). - -Core Ns at: #list put: - (Fn new: [ :args | MALList new: (OrderedCollection from: args) ]). -Core Ns at: #'list?' put: - (Fn new: [ :args | Core coerce: [ args first type = #list ] ]). -Core Ns at: #'empty?' put: - (Fn new: [ :args | Core coerce: [ args first value isEmpty ] ]). -Core Ns at: #count put: - (Fn new: [ :args | MALNumber new: args first value size ]). - -Core Ns at: #= put: - (Fn new: [ :args | Core coerce: [ args first = args second ] ]). - -Core Ns at: #< put: - (Fn new: [ :args | Core coerce: [ args first value < args second value ] ]). -Core Ns at: #<= put: - (Fn new: [ :args | Core coerce: [ args first value <= args second value ] ]). -Core Ns at: #> put: - (Fn new: [ :args | Core coerce: [ args first value > args second value ] ]). -Core Ns at: #>= put: - (Fn new: [ :args | Core coerce: [ args first value >= args second value ] ]). - -Core Ns at: #'read-string' put: - (Fn new: [ :args | Reader readStr: args first value ]). -Core Ns at: #slurp put: - (Fn new: [ :args | MALString new: (File path: args first value) contents ]). -Core Ns at: #throw put: - (Fn new: [ :args | MALCustomError new signal: args first ]). -Core Ns at: #readline put: - (Fn new: [ :args | - | result | - result := ReadLine readLine: args first value. - result isString ifTrue: [ - MALString new: result - ] ifFalse: [ - MALObject Nil - ] ]). -Core Ns at: #'time-ms' put: - (Fn new: [ :args | MALNumber new: Time millisecondClock ]). -Core Ns at: #'gst-eval' put: - (Fn new: [ :args | (Behavior evaluate: args first value) toMALValue ]). - -Core Ns at: #atom put: - (Fn new: [ :args | MALAtom new: args first ]). -Core Ns at: #'atom?' put: - (Fn new: [ :args | Core coerce: [ args first type = #atom ] ]). -Core Ns at: #deref put: - (Fn new: [ :args | args first value ]). -Core Ns at: #'reset!' put: - (Fn new: [ :args | args first value: args second. args second ]). -Core Ns at: #'swap!' put: - (Fn new: [ :args | - | a f x xs result | - a := args first. - f := args second fn. - x := a value. - xs := args allButFirst: 2. - result := f value: (xs copyWithFirst: x). - a value: result. - result ]). - -Core Ns at: #cons put: - (Fn new: [ :args | MALList new: (args second value copyWithFirst: args first) ]). -Core Ns at: #concat put: - (Fn new: [ :args | MALList new: (OrderedCollection join: - (args collect: [ :arg | arg value ])) ]). -Core Ns at: #nth put: - (Fn new: [ :args | - | items index | - items := args first value. - index := args second value + 1. - items at: index ifAbsent: [ MALOutOfBounds new signal ] ]). -Core Ns at: #first put: - (Fn new: [ :args | Core nilable: args else: [ - args first value at: 1 ifAbsent: [ MALObject Nil ] ] ]). -Core Ns at: #rest put: - (Fn new: [ :args | - | items rest | - items := args first value. - (args first type = #nil or: [ items isEmpty ]) ifTrue: [ - rest := {} - ] ifFalse: [ - rest := items allButFirst - ]. - MALList new: (OrderedCollection from: rest) ]). -Core Ns at: #conj put: - (Fn new: [ :args | - | kind result items | - kind := args first type. - result := args first value. - items := args allButFirst. - - kind = #list ifTrue: [ - MALList new: (OrderedCollection from: items reverse, result) - ] ifFalse: [ - MALVector new: (OrderedCollection from: result, items) - ] ]). -Core Ns at: #seq put: - (Fn new: [ :args | - | kind storage result | - kind := args first type. - storage := args first value. - Core nilable: args else: [ - storage isEmpty ifTrue: [ - MALObject Nil - ] ifFalse: [ - kind = #string ifTrue: [ - result := (OrderedCollection from: storage) collect: - [ :char | MALString new: char asString ]. - MALList new: result - ] ifFalse: [ - MALList new: (OrderedCollection from: storage) - ] - ] - ] ]). - -Core Ns at: #apply put: - (Fn new: [ :args | - | f rest result | - f := args first fn. - args size < 3 ifTrue: [ - rest := {} - ] ifFalse: [ - rest := args copyFrom: 2 to: args size - 1 - ]. - rest := rest, args last value. - f value: rest ]). -Core Ns at: #map put: - (Fn new: [ :args | - | items f result | - f := args first fn. - items := args second value. - result := items collect: [ :item | f value: {item} ]. - MALList new: (OrderedCollection from: result) ]). - -Core Ns at: #meta put: - (Fn new: [ :args | - | meta | - meta := args first meta. - meta isNil ifTrue: [ MALObject Nil ] ifFalse: [ meta ] ]). -Core Ns at: #'with-meta' put: - (Fn new: [ :args | args first withMeta: args second ]). - -Core Ns at: #'nil?' put: - (Fn new: [ :args | Core coerce: [ args first type = #nil ] ]). -Core Ns at: #'true?' put: - (Fn new: [ :args | Core coerce: [ args first type = #true ] ]). -Core Ns at: #'false?' put: - (Fn new: [ :args | Core coerce: [ args first type = #false ] ]). -Core Ns at: #'number?' put: - (Fn new: [ :args | Core coerce: [ args first type = #number ] ]). -Core Ns at: #'symbol?' put: - (Fn new: [ :args | Core coerce: [ args first type = #symbol ] ]). -Core Ns at: #'keyword?' put: - (Fn new: [ :args | Core coerce: [ args first type = #keyword ] ]). -Core Ns at: #'string?' put: - (Fn new: [ :args | Core coerce: [ args first type = #string ] ]). -Core Ns at: #'vector?' put: - (Fn new: [ :args | Core coerce: [ args first type = #vector ] ]). -Core Ns at: #'map?' put: - (Fn new: [ :args | Core coerce: [ args first type = #map ] ]). -Core Ns at: #'sequential?' put: - (Fn new: [ :args | Core coerce: [ args first type = #list or: - [ args first type = #vector ] ] ]). -Core Ns at: #'fn?' put: - (Fn new: [ :args | Core coerce: [ args first type = #fn or: - [ args first type = #func and: - [ args first isMacro not ] ] ] ]). -Core Ns at: #'macro?' put: - (Fn new: [ :args | Core coerce: [ args first type = #func and: - [ args first isMacro ] ] ]). - -Core Ns at: #symbol put: - (Fn new: [ :args | MALSymbol new: args first value asSymbol ]). -Core Ns at: #keyword put: - (Fn new: [ :args | MALKeyword new: args first value asSymbol ]). -Core Ns at: #'vec' put: - (Fn new: [ :args | MALVector new: args first value ]). -Core Ns at: #vector put: - (Fn new: [ :args | MALVector new: (OrderedCollection from: args) ]). -Core Ns at: #'hash-map' put: - (Fn new: [ :args | MALMap new: args asDictionary ]). - -Core Ns at: #assoc put: - (Fn new: [ :args | - | result keyVals | - result := Dictionary from: args first value associations. - keyVals := args allButFirst. - 1 to: keyVals size by: 2 do: - [ :i | result add: (keyVals at: i) -> (keyVals at: i + 1) ]. - MALMap new: result ]). -Core Ns at: #dissoc put: - (Fn new: [ :args | - | result keys | - result := Dictionary from: args first value associations. - keys := args allButFirst. - keys do: [ :key | result removeKey: key ifAbsent: [ nil ] ]. - MALMap new: result ]). -Core Ns at: #get put: - (Fn new: [ :args | Core nilable: args else: - [ args first value at: args second ifAbsent: [ MALObject Nil ] ] ]). -Core Ns at: #'contains?' put: - (Fn new: [ :args | Core coerce: [ args first value includesKey: args second ] ]). -Core Ns at: #keys put: - (Fn new: [ :args | MALList new: (OrderedCollection from: args first value keys) ]). -Core Ns at: #vals put: - (Fn new: [ :args | MALList new: (OrderedCollection from: args first value values) ]). +Object subclass: Core [ + Ns := Dictionary new. + Core class >> Ns [ ^Ns ] + + Core class >> coerce: block [ + block value ifTrue: [ ^MALObject True ] ifFalse: [ ^MALObject False ] + ] + + Core class >> nilable: args else: block [ + args first type = #nil ifTrue: [ + ^MALObject Nil + ] ifFalse: [ + ^block value + ] + ] + + Core class >> printedArgs: args readable: readable sep: sep [ + | items | + items := args collect: + [ :arg | Printer prStr: arg printReadably: readable ]. + "NOTE: {} join returns the unchanged array" + items isEmpty ifTrue: [ ^'' ] ifFalse: [ ^items join: sep ] + ] +] + +Core Ns at: #+ put: + (Fn new: [ :args | MALNumber new: args first value + args second value ]). +Core Ns at: #- put: + (Fn new: [ :args | MALNumber new: args first value - args second value ]). +Core Ns at: #* put: + (Fn new: [ :args | MALNumber new: args first value * args second value ]). +Core Ns at: #/ put: + (Fn new: [ :args | MALNumber new: args first value // args second value ]). + +Core Ns at: #'pr-str' put: + (Fn new: [ :args | MALString new: (Core printedArgs: args readable: true + sep: ' ') ]). +Core Ns at: #str put: + (Fn new: [ :args | MALString new: (Core printedArgs: args readable: false + sep: '') ]). +Core Ns at: #prn put: + (Fn new: [ :args | + (Core printedArgs: args readable: true sep: ' ') displayNl. + MALObject Nil ]). +Core Ns at: #println put: + (Fn new: [ :args | + (Core printedArgs: args readable: false sep: ' ') displayNl. + MALObject Nil ]). + +Core Ns at: #list put: + (Fn new: [ :args | MALList new: (OrderedCollection from: args) ]). +Core Ns at: #'list?' put: + (Fn new: [ :args | Core coerce: [ args first type = #list ] ]). +Core Ns at: #'empty?' put: + (Fn new: [ :args | Core coerce: [ args first value isEmpty ] ]). +Core Ns at: #count put: + (Fn new: [ :args | MALNumber new: args first value size ]). + +Core Ns at: #= put: + (Fn new: [ :args | Core coerce: [ args first = args second ] ]). + +Core Ns at: #< put: + (Fn new: [ :args | Core coerce: [ args first value < args second value ] ]). +Core Ns at: #<= put: + (Fn new: [ :args | Core coerce: [ args first value <= args second value ] ]). +Core Ns at: #> put: + (Fn new: [ :args | Core coerce: [ args first value > args second value ] ]). +Core Ns at: #>= put: + (Fn new: [ :args | Core coerce: [ args first value >= args second value ] ]). + +Core Ns at: #'read-string' put: + (Fn new: [ :args | Reader readStr: args first value ]). +Core Ns at: #slurp put: + (Fn new: [ :args | MALString new: (File path: args first value) contents ]). +Core Ns at: #throw put: + (Fn new: [ :args | MALCustomError new signal: args first ]). +Core Ns at: #readline put: + (Fn new: [ :args | + | result | + result := ReadLine readLine: args first value. + result isString ifTrue: [ + MALString new: result + ] ifFalse: [ + MALObject Nil + ] ]). +Core Ns at: #'time-ms' put: + (Fn new: [ :args | MALNumber new: Time millisecondClock ]). +Core Ns at: #'gst-eval' put: + (Fn new: [ :args | (Behavior evaluate: args first value) toMALValue ]). + +Core Ns at: #atom put: + (Fn new: [ :args | MALAtom new: args first ]). +Core Ns at: #'atom?' put: + (Fn new: [ :args | Core coerce: [ args first type = #atom ] ]). +Core Ns at: #deref put: + (Fn new: [ :args | args first value ]). +Core Ns at: #'reset!' put: + (Fn new: [ :args | args first value: args second. args second ]). +Core Ns at: #'swap!' put: + (Fn new: [ :args | + | a f x xs result | + a := args first. + f := args second fn. + x := a value. + xs := args allButFirst: 2. + result := f value: (xs copyWithFirst: x). + a value: result. + result ]). + +Core Ns at: #cons put: + (Fn new: [ :args | MALList new: (args second value copyWithFirst: args first) ]). +Core Ns at: #concat put: + (Fn new: [ :args | MALList new: (OrderedCollection join: + (args collect: [ :arg | arg value ])) ]). +Core Ns at: #nth put: + (Fn new: [ :args | + | items index | + items := args first value. + index := args second value + 1. + items at: index ifAbsent: [ MALOutOfBounds new signal ] ]). +Core Ns at: #first put: + (Fn new: [ :args | Core nilable: args else: [ + args first value at: 1 ifAbsent: [ MALObject Nil ] ] ]). +Core Ns at: #rest put: + (Fn new: [ :args | + | items rest | + items := args first value. + (args first type = #nil or: [ items isEmpty ]) ifTrue: [ + rest := {} + ] ifFalse: [ + rest := items allButFirst + ]. + MALList new: (OrderedCollection from: rest) ]). +Core Ns at: #conj put: + (Fn new: [ :args | + | kind result items | + kind := args first type. + result := args first value. + items := args allButFirst. + + kind = #list ifTrue: [ + MALList new: (OrderedCollection from: items reverse, result) + ] ifFalse: [ + MALVector new: (OrderedCollection from: result, items) + ] ]). +Core Ns at: #seq put: + (Fn new: [ :args | + | kind storage result | + kind := args first type. + storage := args first value. + Core nilable: args else: [ + storage isEmpty ifTrue: [ + MALObject Nil + ] ifFalse: [ + kind = #string ifTrue: [ + result := (OrderedCollection from: storage) collect: + [ :char | MALString new: char asString ]. + MALList new: result + ] ifFalse: [ + MALList new: (OrderedCollection from: storage) + ] + ] + ] ]). + +Core Ns at: #apply put: + (Fn new: [ :args | + | f rest result | + f := args first fn. + args size < 3 ifTrue: [ + rest := {} + ] ifFalse: [ + rest := args copyFrom: 2 to: args size - 1 + ]. + rest := rest, args last value. + f value: rest ]). +Core Ns at: #map put: + (Fn new: [ :args | + | items f result | + f := args first fn. + items := args second value. + result := items collect: [ :item | f value: {item} ]. + MALList new: (OrderedCollection from: result) ]). + +Core Ns at: #meta put: + (Fn new: [ :args | + | meta | + meta := args first meta. + meta isNil ifTrue: [ MALObject Nil ] ifFalse: [ meta ] ]). +Core Ns at: #'with-meta' put: + (Fn new: [ :args | args first withMeta: args second ]). + +Core Ns at: #'nil?' put: + (Fn new: [ :args | Core coerce: [ args first type = #nil ] ]). +Core Ns at: #'true?' put: + (Fn new: [ :args | Core coerce: [ args first type = #true ] ]). +Core Ns at: #'false?' put: + (Fn new: [ :args | Core coerce: [ args first type = #false ] ]). +Core Ns at: #'number?' put: + (Fn new: [ :args | Core coerce: [ args first type = #number ] ]). +Core Ns at: #'symbol?' put: + (Fn new: [ :args | Core coerce: [ args first type = #symbol ] ]). +Core Ns at: #'keyword?' put: + (Fn new: [ :args | Core coerce: [ args first type = #keyword ] ]). +Core Ns at: #'string?' put: + (Fn new: [ :args | Core coerce: [ args first type = #string ] ]). +Core Ns at: #'vector?' put: + (Fn new: [ :args | Core coerce: [ args first type = #vector ] ]). +Core Ns at: #'map?' put: + (Fn new: [ :args | Core coerce: [ args first type = #map ] ]). +Core Ns at: #'sequential?' put: + (Fn new: [ :args | Core coerce: [ args first type = #list or: + [ args first type = #vector ] ] ]). +Core Ns at: #'fn?' put: + (Fn new: [ :args | Core coerce: [ args first type = #fn or: + [ args first type = #func and: + [ args first isMacro not ] ] ] ]). +Core Ns at: #'macro?' put: + (Fn new: [ :args | Core coerce: [ args first type = #func and: + [ args first isMacro ] ] ]). + +Core Ns at: #symbol put: + (Fn new: [ :args | MALSymbol new: args first value asSymbol ]). +Core Ns at: #keyword put: + (Fn new: [ :args | MALKeyword new: args first value asSymbol ]). +Core Ns at: #'vec' put: + (Fn new: [ :args | MALVector new: args first value ]). +Core Ns at: #vector put: + (Fn new: [ :args | MALVector new: (OrderedCollection from: args) ]). +Core Ns at: #'hash-map' put: + (Fn new: [ :args | MALMap new: args asDictionary ]). + +Core Ns at: #assoc put: + (Fn new: [ :args | + | result keyVals | + result := Dictionary from: args first value associations. + keyVals := args allButFirst. + 1 to: keyVals size by: 2 do: + [ :i | result add: (keyVals at: i) -> (keyVals at: i + 1) ]. + MALMap new: result ]). +Core Ns at: #dissoc put: + (Fn new: [ :args | + | result keys | + result := Dictionary from: args first value associations. + keys := args allButFirst. + keys do: [ :key | result removeKey: key ifAbsent: [ nil ] ]. + MALMap new: result ]). +Core Ns at: #get put: + (Fn new: [ :args | Core nilable: args else: + [ args first value at: args second ifAbsent: [ MALObject Nil ] ] ]). +Core Ns at: #'contains?' put: + (Fn new: [ :args | Core coerce: [ args first value includesKey: args second ] ]). +Core Ns at: #keys put: + (Fn new: [ :args | MALList new: (OrderedCollection from: args first value keys) ]). +Core Ns at: #vals put: + (Fn new: [ :args | MALList new: (OrderedCollection from: args first value values) ]). diff --git a/impls/gnu-smalltalk/env.st b/impls/gnu-smalltalk/env.st index c62f871434..7984c05107 100644 --- a/impls/gnu-smalltalk/env.st +++ b/impls/gnu-smalltalk/env.st @@ -1,53 +1,53 @@ -Object subclass: Env [ - | data outer | - - Env class >> new: outerEnv [ - ^self new: outerEnv binds: {} exprs: {} - ] - - Env class >> new: outerEnv binds: binds exprs: exprs [ - | env | - env := super new. - env init: outerEnv binds: binds exprs: exprs. - ^env - ] - - init: env binds: binds exprs: exprs [ - data := Dictionary new. - outer := env. - 1 to: binds size do: - [ :i | (binds at: i) = #& ifTrue: [ - | rest | - rest := OrderedCollection from: (exprs copyFrom: i). - self set: (binds at: i + 1) value: (MALList new: rest). - ^nil - ] ifFalse: [ - self set: (binds at: i) value: (exprs at: i) - ] ] - ] - - set: key value: value [ - data at: key put: value. - ] - - find: key [ - ^data at: key ifAbsent: [ - outer notNil ifTrue: [ - outer find: key - ] ifFalse: [ - nil - ] - ] - ] - - get: key [ - | value | - value := self find: key. - - value notNil ifTrue: [ - ^value - ] ifFalse: [ - ^MALUnknownSymbol new signal: key - ] - ] -] +Object subclass: Env [ + | data outer | + + Env class >> new: outerEnv [ + ^self new: outerEnv binds: {} exprs: {} + ] + + Env class >> new: outerEnv binds: binds exprs: exprs [ + | env | + env := super new. + env init: outerEnv binds: binds exprs: exprs. + ^env + ] + + init: env binds: binds exprs: exprs [ + data := Dictionary new. + outer := env. + 1 to: binds size do: + [ :i | (binds at: i) = #& ifTrue: [ + | rest | + rest := OrderedCollection from: (exprs copyFrom: i). + self set: (binds at: i + 1) value: (MALList new: rest). + ^nil + ] ifFalse: [ + self set: (binds at: i) value: (exprs at: i) + ] ] + ] + + set: key value: value [ + data at: key put: value. + ] + + find: key [ + ^data at: key ifAbsent: [ + outer notNil ifTrue: [ + outer find: key + ] ifFalse: [ + nil + ] + ] + ] + + get: key [ + | value | + value := self find: key. + + value notNil ifTrue: [ + ^value + ] ifFalse: [ + ^MALUnknownSymbol new signal: key + ] + ] +] diff --git a/impls/gnu-smalltalk/func.st b/impls/gnu-smalltalk/func.st index dc5e97fe65..03cddab78f 100644 --- a/impls/gnu-smalltalk/func.st +++ b/impls/gnu-smalltalk/func.st @@ -1,28 +1,28 @@ -MALObject subclass: Func [ - | ast params env fn isMacro | - - ast [ ^ast ] - params [ ^params ] - env [ ^env ] - fn [ ^fn ] - isMacro [ ^isMacro ] - - isMacro: bool [ - isMacro := bool - ] - - Func class >> new: ast params: params env: env fn: fn [ - | func | - func := super new: #func value: fn meta: nil. - func init: ast params: params env: env fn: fn. - ^func - ] - - init: anAst params: someParams env: anEnv fn: aFn [ - ast := anAst. - params := someParams. - env := anEnv. - fn := aFn. - isMacro := false - ] -] +MALObject subclass: Func [ + | ast params env fn isMacro | + + ast [ ^ast ] + params [ ^params ] + env [ ^env ] + fn [ ^fn ] + isMacro [ ^isMacro ] + + isMacro: bool [ + isMacro := bool + ] + + Func class >> new: ast params: params env: env fn: fn [ + | func | + func := super new: #func value: fn meta: nil. + func init: ast params: params env: env fn: fn. + ^func + ] + + init: anAst params: someParams env: anEnv fn: aFn [ + ast := anAst. + params := someParams. + env := anEnv. + fn := aFn. + isMacro := false + ] +] diff --git a/impls/gnu-smalltalk/printer.st b/impls/gnu-smalltalk/printer.st index c86fc7ebf3..eca4c97ff0 100644 --- a/impls/gnu-smalltalk/printer.st +++ b/impls/gnu-smalltalk/printer.st @@ -1,56 +1,56 @@ -Object subclass: Printer [ - Printer class >> prStr: sexp printReadably: printReadably [ - sexp type = #fn ifTrue: [ ^'#' ]. - sexp type = #func ifTrue: [ ^'#' ]. - sexp type = #true ifTrue: [ ^'true' ]. - sexp type = #false ifTrue: [ ^'false' ]. - sexp type = #nil ifTrue: [ ^'nil' ]. - - sexp type = #number ifTrue: [ ^sexp value asString ]. - sexp type = #symbol ifTrue: [ ^sexp value asString ]. - sexp type = #keyword ifTrue: [ ^':', sexp value ]. - - sexp type = #string ifTrue: [ - printReadably ifTrue: [ - ^sexp value repr - ] ifFalse: [ - ^sexp value - ] - ]. - - sexp type = #list ifTrue: [ - ^self prList: sexp printReadably: printReadably - starter: '(' ender: ')' - ]. - sexp type = #vector ifTrue: [ - ^self prList: sexp printReadably: printReadably - starter: '[' ender: ']' - ]. - sexp type = #map ifTrue: [ - ^self prMap: sexp printReadably: printReadably - ]. - - sexp type = #atom ifTrue: [ - ^'(atom ', (self prStr: sexp value printReadably: printReadably), ')' - ]. - - Error halt: 'unimplemented type' - ] - - Printer class >> prList: sexp printReadably: printReadably - starter: starter ender: ender [ - | items | - items := sexp value collect: - [ :item | self prStr: item printReadably: printReadably ]. - ^starter, (items join: ' ') , ender - ] - - Printer class >> prMap: sexp printReadably: printReadably [ - | items | - items := sexp value associations collect: - [ :item | - (self prStr: item key printReadably: printReadably), ' ', - (self prStr: item value printReadably: printReadably) ]. - ^'{', (items join: ' '), '}' - ] -] +Object subclass: Printer [ + Printer class >> prStr: sexp printReadably: printReadably [ + sexp type = #fn ifTrue: [ ^'#' ]. + sexp type = #func ifTrue: [ ^'#' ]. + sexp type = #true ifTrue: [ ^'true' ]. + sexp type = #false ifTrue: [ ^'false' ]. + sexp type = #nil ifTrue: [ ^'nil' ]. + + sexp type = #number ifTrue: [ ^sexp value asString ]. + sexp type = #symbol ifTrue: [ ^sexp value asString ]. + sexp type = #keyword ifTrue: [ ^':', sexp value ]. + + sexp type = #string ifTrue: [ + printReadably ifTrue: [ + ^sexp value repr + ] ifFalse: [ + ^sexp value + ] + ]. + + sexp type = #list ifTrue: [ + ^self prList: sexp printReadably: printReadably + starter: '(' ender: ')' + ]. + sexp type = #vector ifTrue: [ + ^self prList: sexp printReadably: printReadably + starter: '[' ender: ']' + ]. + sexp type = #map ifTrue: [ + ^self prMap: sexp printReadably: printReadably + ]. + + sexp type = #atom ifTrue: [ + ^'(atom ', (self prStr: sexp value printReadably: printReadably), ')' + ]. + + Error halt: 'unimplemented type' + ] + + Printer class >> prList: sexp printReadably: printReadably + starter: starter ender: ender [ + | items | + items := sexp value collect: + [ :item | self prStr: item printReadably: printReadably ]. + ^starter, (items join: ' ') , ender + ] + + Printer class >> prMap: sexp printReadably: printReadably [ + | items | + items := sexp value associations collect: + [ :item | + (self prStr: item key printReadably: printReadably), ' ', + (self prStr: item value printReadably: printReadably) ]. + ^'{', (items join: ' '), '}' + ] +] diff --git a/impls/gnu-smalltalk/reader.st b/impls/gnu-smalltalk/reader.st index d2e347f9ed..e8dcce3b0f 100644 --- a/impls/gnu-smalltalk/reader.st +++ b/impls/gnu-smalltalk/reader.st @@ -1,170 +1,170 @@ -Object subclass: Reader [ - | storage index | - - TokenRegex := '[\s,]*(~@|[\[\]{}()''`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}(''"`,;)]*)'. - CommentRegex := ';.*'. - NumberRegex := '-?[0-9]+(?:\.[0-9]+)?'. - StringRegex := '"(?:\\.|[^\\"])*"'. - - Reader class >> tokenizer: input [ - | tokens token hit pos done | - tokens := OrderedCollection new. - pos := 1. - done := false. - - [done] whileFalse: [ - hit := input searchRegex: TokenRegex startingAt: pos. - token := hit at: 1. - token size = 0 ifTrue: [ - tokens add: (input copyFrom: pos to: input size) trimSeparators. - done := true. - ]. - (token size = 0 or: [token matchRegex: CommentRegex]) ifFalse: [ - tokens add: token - ]. - pos := pos + (hit match size). - pos > input size ifTrue: [ - done := true. - ]. - ]. - ^tokens - ] - - Reader class >> readStr: input [ - | tokens reader form | - tokens := self tokenizer: input. - reader := self new: tokens. - tokens isEmpty ifTrue: [ - ^MALEmptyInput new signal - ]. - ^self readForm: reader. - ] - - Reader class >> readForm: reader [ - | token | - token := reader peek. - token = '(' ifTrue: [ - ^self readList: reader class: MALList ender: ')' - ]. - token = '[' ifTrue: [ - ^self readList: reader class: MALVector ender: ']' - ]. - token = '{' ifTrue: [ - ^self readList: reader class: MALMap ender: '}' - ]. - - (token matchRegex: '[])}]') ifTrue: [ - ^MALUnexpectedToken new signal: token - ]. - - token = '''' ifTrue: [ - ^self readSimpleMacro: reader name: #quote - ]. - token = '`' ifTrue: [ - ^self readSimpleMacro: reader name: #quasiquote - ]. - token = '~' ifTrue: [ - ^self readSimpleMacro: reader name: #unquote - ]. - token = '~@' ifTrue: [ - ^self readSimpleMacro: reader name: #'splice-unquote' - ]. - token = '@' ifTrue: [ - ^self readSimpleMacro: reader name: #deref - ]. - - token = '^' ifTrue: [ - ^self readWithMetaMacro: reader - ]. - - ^self readAtom: reader - ] - - Reader class >> readList: reader class: aClass ender: ender [ - | storage token | - storage := OrderedCollection new. - "pop opening token" - reader next. - [ token := reader peek. token isNil ] whileFalse: [ - token = ender ifTrue: [ - ender = '}' ifTrue: [ - storage := storage asDictionary. - ]. - "pop closing token" - reader next. - ^aClass new: storage - ]. - storage add: (self readForm: reader). - ]. - ^MALUnterminatedSequence new signal: ender - ] - - Reader class >> readAtom: reader [ - | token | - token := reader next. - - token = 'true' ifTrue: [ ^MALObject True ]. - token = 'false' ifTrue: [ ^MALObject False ]. - token = 'nil' ifTrue: [ ^MALObject Nil ]. - - (token matchRegex: StringRegex) ifTrue: [ - ^MALString new: token parse - ]. - (token first = $") ifTrue: [ - ^MALUnterminatedSequence new signal: '"' - ]. - - (token matchRegex: NumberRegex) ifTrue: [ - ^MALNumber new: token asNumber - ]. - - (token first = $:) ifTrue: [ - ^MALKeyword new: token allButFirst asSymbol - ]. - - ^MALSymbol new: token asSymbol - ] - - Reader class >> readSimpleMacro: reader name: name [ - | form list | - "pop reader macro token" - reader next. - form := self readForm: reader. - list := OrderedCollection from: { MALSymbol new: name. form }. - ^MALList new: list - ] - - Reader class >> readWithMetaMacro: reader [ - | form meta list | - "pop reader macro token" - reader next. - meta := self readForm: reader. - form := self readForm: reader. - list := OrderedCollection from: - { MALSymbol new: #'with-meta'. form. meta }. - ^MALList new: list - ] - - Reader class >> new: tokens [ - | reader | - reader := super new. - reader init: tokens. - ^reader - ] - - init: tokens [ - storage := tokens. - index := 1. - ] - - peek [ - ^storage at: index ifAbsent: [ nil ] - ] - - next [ - | token | - token := self peek. - index := index + 1. - ^token - ] -] +Object subclass: Reader [ + | storage index | + + TokenRegex := '[\s,]*(~@|[\[\]{}()''`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}(''"`,;)]*)'. + CommentRegex := ';.*'. + NumberRegex := '-?[0-9]+(?:\.[0-9]+)?'. + StringRegex := '"(?:\\.|[^\\"])*"'. + + Reader class >> tokenizer: input [ + | tokens token hit pos done | + tokens := OrderedCollection new. + pos := 1. + done := false. + + [done] whileFalse: [ + hit := input searchRegex: TokenRegex startingAt: pos. + token := hit at: 1. + token size = 0 ifTrue: [ + tokens add: (input copyFrom: pos to: input size) trimSeparators. + done := true. + ]. + (token size = 0 or: [token matchRegex: CommentRegex]) ifFalse: [ + tokens add: token + ]. + pos := pos + (hit match size). + pos > input size ifTrue: [ + done := true. + ]. + ]. + ^tokens + ] + + Reader class >> readStr: input [ + | tokens reader form | + tokens := self tokenizer: input. + reader := self new: tokens. + tokens isEmpty ifTrue: [ + ^MALEmptyInput new signal + ]. + ^self readForm: reader. + ] + + Reader class >> readForm: reader [ + | token | + token := reader peek. + token = '(' ifTrue: [ + ^self readList: reader class: MALList ender: ')' + ]. + token = '[' ifTrue: [ + ^self readList: reader class: MALVector ender: ']' + ]. + token = '{' ifTrue: [ + ^self readList: reader class: MALMap ender: '}' + ]. + + (token matchRegex: '[])}]') ifTrue: [ + ^MALUnexpectedToken new signal: token + ]. + + token = '''' ifTrue: [ + ^self readSimpleMacro: reader name: #quote + ]. + token = '`' ifTrue: [ + ^self readSimpleMacro: reader name: #quasiquote + ]. + token = '~' ifTrue: [ + ^self readSimpleMacro: reader name: #unquote + ]. + token = '~@' ifTrue: [ + ^self readSimpleMacro: reader name: #'splice-unquote' + ]. + token = '@' ifTrue: [ + ^self readSimpleMacro: reader name: #deref + ]. + + token = '^' ifTrue: [ + ^self readWithMetaMacro: reader + ]. + + ^self readAtom: reader + ] + + Reader class >> readList: reader class: aClass ender: ender [ + | storage token | + storage := OrderedCollection new. + "pop opening token" + reader next. + [ token := reader peek. token isNil ] whileFalse: [ + token = ender ifTrue: [ + ender = '}' ifTrue: [ + storage := storage asDictionary. + ]. + "pop closing token" + reader next. + ^aClass new: storage + ]. + storage add: (self readForm: reader). + ]. + ^MALUnterminatedSequence new signal: ender + ] + + Reader class >> readAtom: reader [ + | token | + token := reader next. + + token = 'true' ifTrue: [ ^MALObject True ]. + token = 'false' ifTrue: [ ^MALObject False ]. + token = 'nil' ifTrue: [ ^MALObject Nil ]. + + (token matchRegex: StringRegex) ifTrue: [ + ^MALString new: token parse + ]. + (token first = $") ifTrue: [ + ^MALUnterminatedSequence new signal: '"' + ]. + + (token matchRegex: NumberRegex) ifTrue: [ + ^MALNumber new: token asNumber + ]. + + (token first = $:) ifTrue: [ + ^MALKeyword new: token allButFirst asSymbol + ]. + + ^MALSymbol new: token asSymbol + ] + + Reader class >> readSimpleMacro: reader name: name [ + | form list | + "pop reader macro token" + reader next. + form := self readForm: reader. + list := OrderedCollection from: { MALSymbol new: name. form }. + ^MALList new: list + ] + + Reader class >> readWithMetaMacro: reader [ + | form meta list | + "pop reader macro token" + reader next. + meta := self readForm: reader. + form := self readForm: reader. + list := OrderedCollection from: + { MALSymbol new: #'with-meta'. form. meta }. + ^MALList new: list + ] + + Reader class >> new: tokens [ + | reader | + reader := super new. + reader init: tokens. + ^reader + ] + + init: tokens [ + storage := tokens. + index := 1. + ] + + peek [ + ^storage at: index ifAbsent: [ nil ] + ] + + next [ + | token | + token := self peek. + index := index + 1. + ^token + ] +] diff --git a/impls/gnu-smalltalk/readline.st b/impls/gnu-smalltalk/readline.st index 2dca73c7b6..79a83b2a60 100644 --- a/impls/gnu-smalltalk/readline.st +++ b/impls/gnu-smalltalk/readline.st @@ -1,20 +1,20 @@ -DLD addLibrary: 'libreadline'. -DLD addLibrary: 'libhistory'. - -Object subclass: ReadLine [ - ReadLine class >> readLine: prompt [ - - ] - - ReadLine class >> addHistory: item [ - - ] - - ReadLine class >> readHistory: filePath [ - - ] - - ReadLine class >> writeHistory: filePath [ - - ] -] +DLD addLibrary: 'libreadline'. +DLD addLibrary: 'libhistory'. + +Object subclass: ReadLine [ + ReadLine class >> readLine: prompt [ + + ] + + ReadLine class >> addHistory: item [ + + ] + + ReadLine class >> readHistory: filePath [ + + ] + + ReadLine class >> writeHistory: filePath [ + + ] +] diff --git a/impls/gnu-smalltalk/run b/impls/gnu-smalltalk/run index 4d413ea72d..b1eaad6c08 100755 --- a/impls/gnu-smalltalk/run +++ b/impls/gnu-smalltalk/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec gst -f $(dirname $0)/${STEP:-stepA_mal}.st "${@}" +#!/bin/bash +exec gst -f $(dirname $0)/${STEP:-stepA_mal}.st "${@}" diff --git a/impls/gnu-smalltalk/step0_repl.st b/impls/gnu-smalltalk/step0_repl.st index 5549a89fcd..6ebe4ac65e 100644 --- a/impls/gnu-smalltalk/step0_repl.st +++ b/impls/gnu-smalltalk/step0_repl.st @@ -1,43 +1,43 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^input - ] - - MAL class >> EVAL: sexp [ - ^sexp - ] - - MAL class >> PRINT: sexp [ - ^sexp - ] - - MAL class >> rep: input [ - ^self PRINT: (self EVAL: (self READ: input)) - ] -] - -| input historyFile | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. - -[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - (MAL rep: input) displayNl. - ] -] - -'' displayNl. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^input + ] + + MAL class >> EVAL: sexp [ + ^sexp + ] + + MAL class >> PRINT: sexp [ + ^sexp + ] + + MAL class >> rep: input [ + ^self PRINT: (self EVAL: (self READ: input)) + ] +] + +| input historyFile | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + (MAL rep: input) displayNl. + ] +] + +'' displayNl. diff --git a/impls/gnu-smalltalk/step1_read_print.st b/impls/gnu-smalltalk/step1_read_print.st index 53384b4c05..13052849d4 100644 --- a/impls/gnu-smalltalk/step1_read_print.st +++ b/impls/gnu-smalltalk/step1_read_print.st @@ -1,50 +1,50 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> EVAL: sexp [ - ^sexp - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input [ - ^self PRINT: (self EVAL: (self READ: input)) - ] -] - -| input historyFile | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. - -[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] -] - -'' displayNl. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> EVAL: sexp [ + ^sexp + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input [ + ^self PRINT: (self EVAL: (self READ: input)) + ] +] + +| input historyFile | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. diff --git a/impls/gnu-smalltalk/step2_eval.st b/impls/gnu-smalltalk/step2_eval.st index 7682ccd9db..c487cfb31a 100644 --- a/impls/gnu-smalltalk/step2_eval.st +++ b/impls/gnu-smalltalk/step2_eval.st @@ -1,93 +1,93 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> evalAst: sexp env: env [ - sexp type = #symbol ifTrue: [ - ^env at: sexp value ifAbsent: [ - ^MALUnknownSymbol new signal: sexp value - ]. - ]. - - sexp type = #list ifTrue: [ - ^self evalList: sexp env: env class: MALList - ]. - sexp type = #vector ifTrue: [ - ^self evalList: sexp env: env class: MALVector - ]. - sexp type = #map ifTrue: [ - ^self evalList: sexp env: env class: MALMap - ]. - - ^sexp - ] - - MAL class >> evalList: sexp env: env class: aClass [ - | items | - items := sexp value collect: - [ :item | self EVAL: item env: env ]. - ^aClass new: items - ] - - MAL class >> EVAL: sexp env: env [ - | forms function args | - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - sexp value isEmpty ifTrue: [ - ^sexp - ]. - - forms := (self evalAst: sexp env: env) value. - function := forms first. - args := forms allButFirst asArray. - ^function valueWithArguments: args - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input env: env [ - ^self PRINT: (self EVAL: (self READ: input) env: env) - ] -] - -| input historyFile replEnv | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. -replEnv := Dictionary from: - { #+ -> [ :a :b | MALNumber new: a value + b value ]. - #- -> [ :a :b | MALNumber new: a value - b value ]. - #* -> [ :a :b | MALNumber new: a value * b value ]. - #/ -> [ :a :b | MALNumber new: a value // b value ] }. - -[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input env: replEnv) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] -] - -'' displayNl. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env at: sexp value ifAbsent: [ + ^MALUnknownSymbol new signal: sexp value + ]. + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: sexp env: env [ + | forms function args | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + ^function valueWithArguments: args + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Dictionary from: + { #+ -> [ :a :b | MALNumber new: a value + b value ]. + #- -> [ :a :b | MALNumber new: a value - b value ]. + #* -> [ :a :b | MALNumber new: a value * b value ]. + #/ -> [ :a :b | MALNumber new: a value // b value ] }. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. diff --git a/impls/gnu-smalltalk/step3_env.st b/impls/gnu-smalltalk/step3_env.st index 9c51b7b238..8fff578d86 100644 --- a/impls/gnu-smalltalk/step3_env.st +++ b/impls/gnu-smalltalk/step3_env.st @@ -1,115 +1,115 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. -'env.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> evalAst: sexp env: env [ - sexp type = #symbol ifTrue: [ - ^env get: sexp value - ]. - - sexp type = #list ifTrue: [ - ^self evalList: sexp env: env class: MALList - ]. - sexp type = #vector ifTrue: [ - ^self evalList: sexp env: env class: MALVector - ]. - sexp type = #map ifTrue: [ - ^self evalList: sexp env: env class: MALMap - ]. - - ^sexp - ] - - MAL class >> evalList: sexp env: env class: aClass [ - | items | - items := sexp value collect: - [ :item | self EVAL: item env: env ]. - ^aClass new: items - ] - - MAL class >> EVAL: sexp env: env [ - | ast a0_ a1_ a2 forms function args | - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - sexp value isEmpty ifTrue: [ - ^sexp - ]. - - ast := sexp value. - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) env: env_) ]. - ^self EVAL: a2 env: env_ - ]. - - forms := (self evalAst: sexp env: env) value. - function := forms first. - args := forms allButFirst asArray. - ^function valueWithArguments: args - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input env: env [ - ^self PRINT: (self EVAL: (self READ: input) env: env) - ] -] - -| input historyFile replEnv | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. -replEnv := Env new: nil. - -replEnv set: #+ value: [ :a :b | MALNumber new: a value + b value ]. -replEnv set: #- value: [ :a :b | MALNumber new: a value - b value ]. -replEnv set: #* value: [ :a :b | MALNumber new: a value * b value ]. -replEnv set: #/ value: [ :a :b | MALNumber new: a value // b value ]. - -[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input env: replEnv) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] -] - -'' displayNl. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: sexp env: env [ + | ast a0_ a1_ a2 forms function args | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) env: env_) ]. + ^self EVAL: a2 env: env_ + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + ^function valueWithArguments: args + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +replEnv set: #+ value: [ :a :b | MALNumber new: a value + b value ]. +replEnv set: #- value: [ :a :b | MALNumber new: a value - b value ]. +replEnv set: #* value: [ :a :b | MALNumber new: a value * b value ]. +replEnv set: #/ value: [ :a :b | MALNumber new: a value // b value ]. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. diff --git a/impls/gnu-smalltalk/step4_if_fn_do.st b/impls/gnu-smalltalk/step4_if_fn_do.st index b3cc590d42..1d9de099e6 100644 --- a/impls/gnu-smalltalk/step4_if_fn_do.st +++ b/impls/gnu-smalltalk/step4_if_fn_do.st @@ -1,143 +1,143 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. -'env.st' loadRelative. -'core.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> evalAst: sexp env: env [ - sexp type = #symbol ifTrue: [ - ^env get: sexp value - ]. - - sexp type = #list ifTrue: [ - ^self evalList: sexp env: env class: MALList - ]. - sexp type = #vector ifTrue: [ - ^self evalList: sexp env: env class: MALVector - ]. - sexp type = #map ifTrue: [ - ^self evalList: sexp env: env class: MALMap - ]. - - ^sexp - ] - - MAL class >> evalList: sexp env: env class: aClass [ - | items | - items := sexp value collect: - [ :item | self EVAL: item env: env ]. - ^aClass new: items - ] - - MAL class >> EVAL: sexp env: env [ - | ast a0_ a1 a1_ a1_n a2 a3 forms function args | - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - sexp value isEmpty ifTrue: [ - ^sexp - ]. - - ast := sexp value. - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) env: env_) ]. - ^self EVAL: a2 env: env_ - ]. - - a0_ = #do ifTrue: [ - a1_n := ast allButFirst. - ^(a1_n collect: [ :item | self EVAL: item env: env]) last - ]. - - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: [ condition type = #nil ]) ifTrue: [ - ^self EVAL: a3 env: env - ] ifFalse: [ - ^self EVAL: a2 env: env - ] - ]. - - a0_ = #'fn*' ifTrue: [ - | binds | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - ^Fn new: [ :args | self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ] - ]. - - forms := (self evalAst: sexp env: env) value. - function := forms first fn. - args := forms allButFirst asArray. - ^function value: args - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input env: env [ - ^self PRINT: (self EVAL: (self READ: input) env: env) - ] -] - -| input historyFile replEnv | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. -replEnv := Env new: nil. - -Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. - -MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. - -[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input env: replEnv) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] -] - -'' displayNl. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'core.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: sexp env: env [ + | ast a0_ a1 a1_ a1_n a2 a3 forms function args | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) env: env_) ]. + ^self EVAL: a2 env: env_ + ]. + + a0_ = #do ifTrue: [ + a1_n := ast allButFirst. + ^(a1_n collect: [ :item | self EVAL: item env: env]) last + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: [ condition type = #nil ]) ifTrue: [ + ^self EVAL: a3 env: env + ] ifFalse: [ + ^self EVAL: a2 env: env + ] + ]. + + a0_ = #'fn*' ifTrue: [ + | binds | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + ^Fn new: [ :args | self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ] + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first fn. + args := forms allButFirst asArray. + ^function value: args + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. diff --git a/impls/gnu-smalltalk/step5_tco.st b/impls/gnu-smalltalk/step5_tco.st index 43c7381ca3..212ac9e872 100644 --- a/impls/gnu-smalltalk/step5_tco.st +++ b/impls/gnu-smalltalk/step5_tco.st @@ -1,180 +1,180 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. -'env.st' loadRelative. -'func.st' loadRelative. -'core.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> evalAst: sexp env: env [ - sexp type = #symbol ifTrue: [ - ^env get: sexp value - ]. - - sexp type = #list ifTrue: [ - ^self evalList: sexp env: env class: MALList - ]. - sexp type = #vector ifTrue: [ - ^self evalList: sexp env: env class: MALVector - ]. - sexp type = #map ifTrue: [ - ^self evalList: sexp env: env class: MALMap - ]. - - ^sexp - ] - - MAL class >> evalList: sexp env: env class: aClass [ - | items | - items := sexp value collect: - [ :item | self EVAL: item env: env ]. - ^aClass new: items - ] - - MAL class >> EVAL: aSexp env: anEnv [ - | sexp env ast a0_ a1 a1_ a2 a3 forms function args | - - "NOTE: redefinition of method arguments is not allowed" - sexp := aSexp. - env := anEnv. - - [ - [ :continue | - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - sexp value isEmpty ifTrue: [ - ^sexp - ]. - - ast := sexp value. - a0_ := ast first value. - - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) - env: env_) ]. - env := env_. - sexp := a2. - continue value "TCO" - ]. - - a0_ = #do ifTrue: [ - | forms last | - ast size < 2 ifTrue: [ - forms := {}. - last := MALObject Nil. - ] ifFalse: [ - forms := ast copyFrom: 2 to: ast size - 1. - last := ast last. - ]. - - forms do: [ :form | self EVAL: form env: env ]. - sexp := last. - continue value "TCO" - ]. - - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: - [ condition type = #nil ]) ifTrue: [ - sexp := a3 - ] ifFalse: [ - sexp := a2 - ]. - continue value "TCO" - ]. - - a0_ = #'fn*' ifTrue: [ - | binds env_ fn | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - fn := [ :args | - self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ]. - ^Func new: a2 params: binds env: env fn: fn - ]. - - forms := (self evalAst: sexp env: env) value. - function := forms first. - args := forms allButFirst asArray. - - function type = #fn ifTrue: [ ^function fn value: args ]. - function type = #func ifTrue: [ - | env_ | - sexp := function ast. - env_ := Env new: function env binds: function params - exprs: args. - env := env_. - continue value "TCO" - ] - ] valueWithExit - ] repeat. - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input env: env [ - ^self PRINT: (self EVAL: (self READ: input) env: env) - ] -] - -| input historyFile replEnv | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. -replEnv := Env new: nil. - -Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. - -MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. - -[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input env: replEnv) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] -] - -'' displayNl. +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0_ a1 a1_ a2 a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0_ := ast first value. + + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. + +[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] +] + +'' displayNl. diff --git a/impls/gnu-smalltalk/step6_file.st b/impls/gnu-smalltalk/step6_file.st index 237a88e722..60b779d2b2 100644 --- a/impls/gnu-smalltalk/step6_file.st +++ b/impls/gnu-smalltalk/step6_file.st @@ -1,192 +1,192 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. -'env.st' loadRelative. -'func.st' loadRelative. -'core.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> evalAst: sexp env: env [ - sexp type = #symbol ifTrue: [ - ^env get: sexp value - ]. - - sexp type = #list ifTrue: [ - ^self evalList: sexp env: env class: MALList - ]. - sexp type = #vector ifTrue: [ - ^self evalList: sexp env: env class: MALVector - ]. - sexp type = #map ifTrue: [ - ^self evalList: sexp env: env class: MALMap - ]. - - ^sexp - ] - - MAL class >> evalList: sexp env: env class: aClass [ - | items | - items := sexp value collect: - [ :item | self EVAL: item env: env ]. - ^aClass new: items - ] - - MAL class >> EVAL: aSexp env: anEnv [ - | sexp env ast a0 a0_ a1 a1_ a2 a3 forms function args | - - "NOTE: redefinition of method arguments is not allowed" - sexp := aSexp. - env := anEnv. - - [ - [ :continue | - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - sexp value isEmpty ifTrue: [ - ^sexp - ]. - - ast := sexp value. - a0 := ast first. - - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) - env: env_) ]. - env := env_. - sexp := a2. - continue value "TCO" - ]. - - a0_ = #do ifTrue: [ - | forms last | - ast size < 2 ifTrue: [ - forms := {}. - last := MALObject Nil. - ] ifFalse: [ - forms := ast copyFrom: 2 to: ast size - 1. - last := ast last. - ]. - - forms do: [ :form | self EVAL: form env: env ]. - sexp := last. - continue value "TCO" - ]. - - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: - [ condition type = #nil ]) ifTrue: [ - sexp := a3 - ] ifFalse: [ - sexp := a2 - ]. - continue value "TCO" - ]. - - a0_ = #'fn*' ifTrue: [ - | binds env_ fn | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - fn := [ :args | - self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ]. - ^Func new: a2 params: binds env: env fn: fn - ]. - - forms := (self evalAst: sexp env: env) value. - function := forms first. - args := forms allButFirst asArray. - - function type = #fn ifTrue: [ ^function fn value: args ]. - function type = #func ifTrue: [ - | env_ | - sexp := function ast. - env_ := Env new: function env binds: function params - exprs: args. - env := env_. - continue value "TCO" - ] - ] valueWithExit - ] repeat. - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input env: env [ - ^self PRINT: (self EVAL: (self READ: input) env: env) - ] -] - -| input historyFile replEnv argv | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. -replEnv := Env new: nil. - -argv := Smalltalk arguments. -argv notEmpty ifTrue: [ argv := argv allButFirst ]. -argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). - -Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. -replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). -replEnv set: #'*ARGV*' value: (MALList new: argv). - -MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. -MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. - -Smalltalk arguments notEmpty ifTrue: [ - MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv -] ifFalse: [ - [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input env: replEnv) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] - ]. - - '' displayNl. -] +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0 := ast first. + + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). +replEnv set: #'*ARGV*' value: (MALList new: argv). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] diff --git a/impls/gnu-smalltalk/step7_quote.st b/impls/gnu-smalltalk/step7_quote.st index b0e02de39d..4f0e9a03ee 100644 --- a/impls/gnu-smalltalk/step7_quote.st +++ b/impls/gnu-smalltalk/step7_quote.st @@ -1,249 +1,249 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. -'env.st' loadRelative. -'func.st' loadRelative. -'core.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> evalAst: sexp env: env [ - sexp type = #symbol ifTrue: [ - ^env get: sexp value - ]. - - sexp type = #list ifTrue: [ - ^self evalList: sexp env: env class: MALList - ]. - sexp type = #vector ifTrue: [ - ^self evalList: sexp env: env class: MALVector - ]. - sexp type = #map ifTrue: [ - ^self evalList: sexp env: env class: MALMap - ]. - - ^sexp - ] - - MAL class >> evalList: sexp env: env class: aClass [ - | items | - items := sexp value collect: - [ :item | self EVAL: item env: env ]. - ^aClass new: items - ] - - MAL class >> starts_with: ast sym: sym [ - | a a0 | - ast type = #list ifFalse: [ ^false. ]. - a := ast value. - a isEmpty ifTrue: [ ^false. ]. - a0 := a first. - ^a0 type = #symbol and: [ a0 value = sym ]. - ] - - MAL class >> quasiquote: ast [ - | result acc | - (ast type = #symbol or: [ ast type = #map ]) ifTrue: [ - result := {MALSymbol new: #quote. ast}. - ^MALList new: (OrderedCollection from: result) - ]. - (ast type = #list or: [ ast type = #vector ]) ifFalse: [ - ^ast - ]. - - (self starts_with: ast sym: #unquote) ifTrue: [ - ^ast value second - ]. - - result := {}. - acc := MALList new: (OrderedCollection from: result). - ast value reverseDo: [ : elt | - (self starts_with: elt sym: #'splice-unquote') ifTrue: [ - result := {MALSymbol new: #concat. elt value second. acc} - ] ifFalse: [ - result := {MALSymbol new: #cons. self quasiquote: elt. acc} - ]. - acc := MALList new: (OrderedCollection from: result) - ]. - ast type = #vector ifTrue: [ - result := {MALSymbol new: #vec. acc}. - acc := MALList new: (OrderedCollection from: result) - ]. - ^acc - ] - - MAL class >> EVAL: aSexp env: anEnv [ - | sexp env ast a0 a0_ a1 a1_ a2 a3 forms function args | - - "NOTE: redefinition of method arguments is not allowed" - sexp := aSexp. - env := anEnv. - - [ - [ :continue | - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - sexp value isEmpty ifTrue: [ - ^sexp - ]. - - ast := sexp value. - a0 := ast first. - - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) - env: env_) ]. - env := env_. - sexp := a2. - continue value "TCO" - ]. - - a0_ = #do ifTrue: [ - | forms last | - ast size < 2 ifTrue: [ - forms := {}. - last := MALObject Nil. - ] ifFalse: [ - forms := ast copyFrom: 2 to: ast size - 1. - last := ast last. - ]. - - forms do: [ :form | self EVAL: form env: env ]. - sexp := last. - continue value "TCO" - ]. - - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: - [ condition type = #nil ]) ifTrue: [ - sexp := a3 - ] ifFalse: [ - sexp := a2 - ]. - continue value "TCO" - ]. - - a0_ = #quote ifTrue: [ - a1 := ast second. - ^a1 - ]. - - a0_ = #quasiquoteexpand ifTrue: [ - a1 := ast second. - ^self quasiquote: a1. - ]. - - a0_ = #quasiquote ifTrue: [ - | result | - a1 := ast second. - sexp := self quasiquote: a1. - continue value "TCO" - ]. - - a0_ = #'fn*' ifTrue: [ - | binds env_ fn | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - fn := [ :args | - self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ]. - ^Func new: a2 params: binds env: env fn: fn - ]. - - forms := (self evalAst: sexp env: env) value. - function := forms first. - args := forms allButFirst asArray. - - function type = #fn ifTrue: [ ^function fn value: args ]. - function type = #func ifTrue: [ - | env_ | - sexp := function ast. - env_ := Env new: function env binds: function params - exprs: args. - env := env_. - continue value "TCO" - ] - ] valueWithExit - ] repeat. - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input env: env [ - ^self PRINT: (self EVAL: (self READ: input) env: env) - ] -] - -| input historyFile replEnv argv | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. -replEnv := Env new: nil. - -argv := Smalltalk arguments. -argv notEmpty ifTrue: [ argv := argv allButFirst ]. -argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). - -Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. -replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). -replEnv set: #'*ARGV*' value: (MALList new: argv). - -MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. -MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. - -Smalltalk arguments notEmpty ifTrue: [ - MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv -] ifFalse: [ - [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input env: replEnv) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] - ]. - - '' displayNl. -] +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> starts_with: ast sym: sym [ + | a a0 | + ast type = #list ifFalse: [ ^false. ]. + a := ast value. + a isEmpty ifTrue: [ ^false. ]. + a0 := a first. + ^a0 type = #symbol and: [ a0 value = sym ]. + ] + + MAL class >> quasiquote: ast [ + | result acc | + (ast type = #symbol or: [ ast type = #map ]) ifTrue: [ + result := {MALSymbol new: #quote. ast}. + ^MALList new: (OrderedCollection from: result) + ]. + (ast type = #list or: [ ast type = #vector ]) ifFalse: [ + ^ast + ]. + + (self starts_with: ast sym: #unquote) ifTrue: [ + ^ast value second + ]. + + result := {}. + acc := MALList new: (OrderedCollection from: result). + ast value reverseDo: [ : elt | + (self starts_with: elt sym: #'splice-unquote') ifTrue: [ + result := {MALSymbol new: #concat. elt value second. acc} + ] ifFalse: [ + result := {MALSymbol new: #cons. self quasiquote: elt. acc} + ]. + acc := MALList new: (OrderedCollection from: result) + ]. + ast type = #vector ifTrue: [ + result := {MALSymbol new: #vec. acc}. + acc := MALList new: (OrderedCollection from: result) + ]. + ^acc + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + ast := sexp value. + a0 := ast first. + + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. + + a0_ = #quasiquoteexpand ifTrue: [ + a1 := ast second. + ^self quasiquote: a1. + ]. + + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). +replEnv set: #'*ARGV*' value: (MALList new: argv). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] diff --git a/impls/gnu-smalltalk/step8_macros.st b/impls/gnu-smalltalk/step8_macros.st index ecb07d1b33..0a2923a3ef 100644 --- a/impls/gnu-smalltalk/step8_macros.st +++ b/impls/gnu-smalltalk/step8_macros.st @@ -1,303 +1,303 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. -'env.st' loadRelative. -'func.st' loadRelative. -'core.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> evalAst: sexp env: env [ - sexp type = #symbol ifTrue: [ - ^env get: sexp value - ]. - - sexp type = #list ifTrue: [ - ^self evalList: sexp env: env class: MALList - ]. - sexp type = #vector ifTrue: [ - ^self evalList: sexp env: env class: MALVector - ]. - sexp type = #map ifTrue: [ - ^self evalList: sexp env: env class: MALMap - ]. - - ^sexp - ] - - MAL class >> evalList: sexp env: env class: aClass [ - | items | - items := sexp value collect: - [ :item | self EVAL: item env: env ]. - ^aClass new: items - ] - - MAL class >> starts_with: ast sym: sym [ - | a a0 | - ast type = #list ifFalse: [ ^false. ]. - a := ast value. - a isEmpty ifTrue: [ ^false. ]. - a0 := a first. - ^a0 type = #symbol and: [ a0 value = sym ]. - ] - - MAL class >> quasiquote: ast [ - | result acc | - (ast type = #symbol or: [ ast type = #map ]) ifTrue: [ - result := {MALSymbol new: #quote. ast}. - ^MALList new: (OrderedCollection from: result) - ]. - (ast type = #list or: [ ast type = #vector ]) ifFalse: [ - ^ast - ]. - - (self starts_with: ast sym: #unquote) ifTrue: [ - ^ast value second - ]. - - result := {}. - acc := MALList new: (OrderedCollection from: result). - ast value reverseDo: [ : elt | - (self starts_with: elt sym: #'splice-unquote') ifTrue: [ - result := {MALSymbol new: #concat. elt value second. acc} - ] ifFalse: [ - result := {MALSymbol new: #cons. self quasiquote: elt. acc} - ]. - acc := MALList new: (OrderedCollection from: result) - ]. - ast type = #vector ifTrue: [ - result := {MALSymbol new: #vec. acc}. - acc := MALList new: (OrderedCollection from: result) - ]. - ^acc - ] - - MAL class >> isMacroCall: ast env: env [ - | a0 a0_ f | - ast type = #list ifTrue: [ - a0 := ast value first. - a0_ := a0 value. - a0 type = #symbol ifTrue: [ - f := env find: a0_. - (f notNil and: [ f type = #func ]) ifTrue: [ - ^f isMacro - ] - ] - ]. - ^false - ] - - MAL class >> macroexpand: aSexp env: env [ - | sexp | - - "NOTE: redefinition of method arguments is not allowed" - sexp := aSexp. - - [ self isMacroCall: sexp env: env ] whileTrue: [ - | ast a0_ macro rest | - ast := sexp value. - a0_ := ast first value. - macro := env find: a0_. - rest := ast allButFirst. - sexp := macro fn value: rest. - ]. - - ^sexp - ] - - MAL class >> EVAL: aSexp env: anEnv [ - | sexp env ast a0 a0_ a1 a1_ a2 a3 forms function args | - - "NOTE: redefinition of method arguments is not allowed" - sexp := aSexp. - env := anEnv. - - [ - [ :continue | - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - sexp value isEmpty ifTrue: [ - ^sexp - ]. - - sexp := self macroexpand: sexp env: env. - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - - ast := sexp value. - a0 := ast first. - - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'defmacro!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := (self EVAL: a2 env: env) deepCopy. - result isMacro: true. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'macroexpand' ifTrue: [ - a1 := ast second. - ^self macroexpand: a1 env: env - ]. - - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) - env: env_) ]. - env := env_. - sexp := a2. - continue value "TCO" - ]. - - a0_ = #do ifTrue: [ - | forms last | - ast size < 2 ifTrue: [ - forms := {}. - last := MALObject Nil. - ] ifFalse: [ - forms := ast copyFrom: 2 to: ast size - 1. - last := ast last. - ]. - - forms do: [ :form | self EVAL: form env: env ]. - sexp := last. - continue value "TCO" - ]. - - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: - [ condition type = #nil ]) ifTrue: [ - sexp := a3 - ] ifFalse: [ - sexp := a2 - ]. - continue value "TCO" - ]. - - a0_ = #quote ifTrue: [ - a1 := ast second. - ^a1 - ]. - - a0_ = #quasiquoteexpand ifTrue: [ - a1 := ast second. - ^self quasiquote: a1. - ]. - - a0_ = #quasiquote ifTrue: [ - | result | - a1 := ast second. - sexp := self quasiquote: a1. - continue value "TCO" - ]. - - a0_ = #'fn*' ifTrue: [ - | binds env_ fn | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - fn := [ :args | - self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ]. - ^Func new: a2 params: binds env: env fn: fn - ]. - - forms := (self evalAst: sexp env: env) value. - function := forms first. - args := forms allButFirst asArray. - - function type = #fn ifTrue: [ ^function fn value: args ]. - function type = #func ifTrue: [ - | env_ | - sexp := function ast. - env_ := Env new: function env binds: function params - exprs: args. - env := env_. - continue value "TCO" - ] - ] valueWithExit - ] repeat. - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input env: env [ - ^self PRINT: (self EVAL: (self READ: input) env: env) - ] -] - -| input historyFile replEnv argv | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. -replEnv := Env new: nil. - -argv := Smalltalk arguments. -argv notEmpty ifTrue: [ argv := argv allButFirst ]. -argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). - -Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. -replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). -replEnv set: #'*ARGV*' value: (MALList new: argv). - -MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. -MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. -MAL 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)))))))' env: replEnv. - -Smalltalk arguments notEmpty ifTrue: [ - MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv -] ifFalse: [ - [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input env: replEnv) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] - ]. - - '' displayNl. -] +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> starts_with: ast sym: sym [ + | a a0 | + ast type = #list ifFalse: [ ^false. ]. + a := ast value. + a isEmpty ifTrue: [ ^false. ]. + a0 := a first. + ^a0 type = #symbol and: [ a0 value = sym ]. + ] + + MAL class >> quasiquote: ast [ + | result acc | + (ast type = #symbol or: [ ast type = #map ]) ifTrue: [ + result := {MALSymbol new: #quote. ast}. + ^MALList new: (OrderedCollection from: result) + ]. + (ast type = #list or: [ ast type = #vector ]) ifFalse: [ + ^ast + ]. + + (self starts_with: ast sym: #unquote) ifTrue: [ + ^ast value second + ]. + + result := {}. + acc := MALList new: (OrderedCollection from: result). + ast value reverseDo: [ : elt | + (self starts_with: elt sym: #'splice-unquote') ifTrue: [ + result := {MALSymbol new: #concat. elt value second. acc} + ] ifFalse: [ + result := {MALSymbol new: #cons. self quasiquote: elt. acc} + ]. + acc := MALList new: (OrderedCollection from: result) + ]. + ast type = #vector ifTrue: [ + result := {MALSymbol new: #vec. acc}. + acc := MALList new: (OrderedCollection from: result) + ]. + ^acc + ] + + MAL class >> isMacroCall: ast env: env [ + | a0 a0_ f | + ast type = #list ifTrue: [ + a0 := ast value first. + a0_ := a0 value. + a0 type = #symbol ifTrue: [ + f := env find: a0_. + (f notNil and: [ f type = #func ]) ifTrue: [ + ^f isMacro + ] + ] + ]. + ^false + ] + + MAL class >> macroexpand: aSexp env: env [ + | sexp | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + + [ self isMacroCall: sexp env: env ] whileTrue: [ + | ast a0_ macro rest | + ast := sexp value. + a0_ := ast first value. + macro := env find: a0_. + rest := ast allButFirst. + sexp := macro fn value: rest. + ]. + + ^sexp + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + sexp := self macroexpand: sexp env: env. + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + + ast := sexp value. + a0 := ast first. + + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'defmacro!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := (self EVAL: a2 env: env) deepCopy. + result isMacro: true. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'macroexpand' ifTrue: [ + a1 := ast second. + ^self macroexpand: a1 env: env + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. + + a0_ = #quasiquoteexpand ifTrue: [ + a1 := ast second. + ^self quasiquote: a1. + ]. + + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). +replEnv set: #'*ARGV*' value: (MALList new: argv). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. +MAL 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)))))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] diff --git a/impls/gnu-smalltalk/step9_try.st b/impls/gnu-smalltalk/step9_try.st index c8eeff5c4e..8a26d0bc16 100644 --- a/impls/gnu-smalltalk/step9_try.st +++ b/impls/gnu-smalltalk/step9_try.st @@ -1,324 +1,324 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. -'env.st' loadRelative. -'func.st' loadRelative. -'core.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> evalAst: sexp env: env [ - sexp type = #symbol ifTrue: [ - ^env get: sexp value - ]. - - sexp type = #list ifTrue: [ - ^self evalList: sexp env: env class: MALList - ]. - sexp type = #vector ifTrue: [ - ^self evalList: sexp env: env class: MALVector - ]. - sexp type = #map ifTrue: [ - ^self evalList: sexp env: env class: MALMap - ]. - - ^sexp - ] - - MAL class >> evalList: sexp env: env class: aClass [ - | items | - items := sexp value collect: - [ :item | self EVAL: item env: env ]. - ^aClass new: items - ] - - MAL class >> starts_with: ast sym: sym [ - | a a0 | - ast type = #list ifFalse: [ ^false. ]. - a := ast value. - a isEmpty ifTrue: [ ^false. ]. - a0 := a first. - ^a0 type = #symbol and: [ a0 value = sym ]. - ] - - MAL class >> quasiquote: ast [ - | result acc | - (ast type = #symbol or: [ ast type = #map ]) ifTrue: [ - result := {MALSymbol new: #quote. ast}. - ^MALList new: (OrderedCollection from: result) - ]. - (ast type = #list or: [ ast type = #vector ]) ifFalse: [ - ^ast - ]. - - (self starts_with: ast sym: #unquote) ifTrue: [ - ^ast value second - ]. - - result := {}. - acc := MALList new: (OrderedCollection from: result). - ast value reverseDo: [ : elt | - (self starts_with: elt sym: #'splice-unquote') ifTrue: [ - result := {MALSymbol new: #concat. elt value second. acc} - ] ifFalse: [ - result := {MALSymbol new: #cons. self quasiquote: elt. acc} - ]. - acc := MALList new: (OrderedCollection from: result) - ]. - ast type = #vector ifTrue: [ - result := {MALSymbol new: #vec. acc}. - acc := MALList new: (OrderedCollection from: result) - ]. - ^acc - ] - - MAL class >> isMacroCall: ast env: env [ - | a0 a0_ f | - ast type = #list ifTrue: [ - a0 := ast value first. - a0_ := a0 value. - a0 type = #symbol ifTrue: [ - f := env find: a0_. - (f notNil and: [ f type = #func ]) ifTrue: [ - ^f isMacro - ] - ] - ]. - ^false - ] - - MAL class >> macroexpand: aSexp env: env [ - | sexp | - - "NOTE: redefinition of method arguments is not allowed" - sexp := aSexp. - - [ self isMacroCall: sexp env: env ] whileTrue: [ - | ast a0_ macro rest | - ast := sexp value. - a0_ := ast first value. - macro := env find: a0_. - rest := ast allButFirst. - sexp := macro fn value: rest. - ]. - - ^sexp - ] - - MAL class >> EVAL: aSexp env: anEnv [ - | sexp env ast a0 a0_ a1 a1_ a2 a2_ a3 forms function args | - - "NOTE: redefinition of method arguments is not allowed" - sexp := aSexp. - env := anEnv. - - [ - [ :continue | - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - sexp value isEmpty ifTrue: [ - ^sexp - ]. - - sexp := self macroexpand: sexp env: env. - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - - ast := sexp value. - a0 := ast first. - - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'defmacro!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := (self EVAL: a2 env: env) deepCopy. - result isMacro: true. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'macroexpand' ifTrue: [ - a1 := ast second. - ^self macroexpand: a1 env: env - ]. - - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) - env: env_) ]. - env := env_. - sexp := a2. - continue value "TCO" - ]. - - a0_ = #do ifTrue: [ - | forms last | - ast size < 2 ifTrue: [ - forms := {}. - last := MALObject Nil. - ] ifFalse: [ - forms := ast copyFrom: 2 to: ast size - 1. - last := ast last. - ]. - - forms do: [ :form | self EVAL: form env: env ]. - sexp := last. - continue value "TCO" - ]. - - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: - [ condition type = #nil ]) ifTrue: [ - sexp := a3 - ] ifFalse: [ - sexp := a2 - ]. - continue value "TCO" - ]. - - a0_ = #quote ifTrue: [ - a1 := ast second. - ^a1 - ]. - - a0_ = #quasiquoteexpand ifTrue: [ - a1 := ast second. - ^self quasiquote: a1. - ]. - - a0_ = #quasiquote ifTrue: [ - | result | - a1 := ast second. - sexp := self quasiquote: a1. - continue value "TCO" - ]. - - a0_ = #'try*' ifTrue: [ - | A B C | - A := ast second. - ast at: 3 ifAbsent: [ - ^self EVAL: A env: env. - ]. - a2_ := ast third value. - B := a2_ second value. - C := a2_ third. - ^[ self EVAL: A env: env ] on: MALError do: - [ :err | - | data env_ result | - data := err data. - data isString ifTrue: [ - data := MALString new: data - ]. - env_ := Env new: env binds: {B} exprs: {data}. - err return: (self EVAL: C env: env_) - ] - ]. - - a0_ = #'fn*' ifTrue: [ - | binds env_ fn | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - fn := [ :args | - self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ]. - ^Func new: a2 params: binds env: env fn: fn - ]. - - forms := (self evalAst: sexp env: env) value. - function := forms first. - args := forms allButFirst asArray. - - function type = #fn ifTrue: [ ^function fn value: args ]. - function type = #func ifTrue: [ - | env_ | - sexp := function ast. - env_ := Env new: function env binds: function params - exprs: args. - env := env_. - continue value "TCO" - ] - ] valueWithExit - ] repeat. - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input env: env [ - ^self PRINT: (self EVAL: (self READ: input) env: env) - ] -] - -| input historyFile replEnv argv | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. -replEnv := Env new: nil. - -argv := Smalltalk arguments. -argv notEmpty ifTrue: [ argv := argv allButFirst ]. -argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). - -Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. -replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). -replEnv set: #'*ARGV*' value: (MALList new: argv). - -MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. -MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. -MAL 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)))))))' env: replEnv. - -Smalltalk arguments notEmpty ifTrue: [ - MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv -] ifFalse: [ - [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input env: replEnv) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] - ]. - - '' displayNl. -] +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> starts_with: ast sym: sym [ + | a a0 | + ast type = #list ifFalse: [ ^false. ]. + a := ast value. + a isEmpty ifTrue: [ ^false. ]. + a0 := a first. + ^a0 type = #symbol and: [ a0 value = sym ]. + ] + + MAL class >> quasiquote: ast [ + | result acc | + (ast type = #symbol or: [ ast type = #map ]) ifTrue: [ + result := {MALSymbol new: #quote. ast}. + ^MALList new: (OrderedCollection from: result) + ]. + (ast type = #list or: [ ast type = #vector ]) ifFalse: [ + ^ast + ]. + + (self starts_with: ast sym: #unquote) ifTrue: [ + ^ast value second + ]. + + result := {}. + acc := MALList new: (OrderedCollection from: result). + ast value reverseDo: [ : elt | + (self starts_with: elt sym: #'splice-unquote') ifTrue: [ + result := {MALSymbol new: #concat. elt value second. acc} + ] ifFalse: [ + result := {MALSymbol new: #cons. self quasiquote: elt. acc} + ]. + acc := MALList new: (OrderedCollection from: result) + ]. + ast type = #vector ifTrue: [ + result := {MALSymbol new: #vec. acc}. + acc := MALList new: (OrderedCollection from: result) + ]. + ^acc + ] + + MAL class >> isMacroCall: ast env: env [ + | a0 a0_ f | + ast type = #list ifTrue: [ + a0 := ast value first. + a0_ := a0 value. + a0 type = #symbol ifTrue: [ + f := env find: a0_. + (f notNil and: [ f type = #func ]) ifTrue: [ + ^f isMacro + ] + ] + ]. + ^false + ] + + MAL class >> macroexpand: aSexp env: env [ + | sexp | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + + [ self isMacroCall: sexp env: env ] whileTrue: [ + | ast a0_ macro rest | + ast := sexp value. + a0_ := ast first value. + macro := env find: a0_. + rest := ast allButFirst. + sexp := macro fn value: rest. + ]. + + ^sexp + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a2_ a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + sexp := self macroexpand: sexp env: env. + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + + ast := sexp value. + a0 := ast first. + + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'defmacro!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := (self EVAL: a2 env: env) deepCopy. + result isMacro: true. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'macroexpand' ifTrue: [ + a1 := ast second. + ^self macroexpand: a1 env: env + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. + + a0_ = #quasiquoteexpand ifTrue: [ + a1 := ast second. + ^self quasiquote: a1. + ]. + + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'try*' ifTrue: [ + | A B C | + A := ast second. + ast at: 3 ifAbsent: [ + ^self EVAL: A env: env. + ]. + a2_ := ast third value. + B := a2_ second value. + C := a2_ third. + ^[ self EVAL: A env: env ] on: MALError do: + [ :err | + | data env_ result | + data := err data. + data isString ifTrue: [ + data := MALString new: data + ]. + env_ := Env new: env binds: {B} exprs: {data}. + err return: (self EVAL: C env: env_) + ] + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). +replEnv set: #'*ARGV*' value: (MALList new: argv). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. +MAL 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)))))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] diff --git a/impls/gnu-smalltalk/stepA_mal.st b/impls/gnu-smalltalk/stepA_mal.st index c67c89bf3a..ce42ca200a 100644 --- a/impls/gnu-smalltalk/stepA_mal.st +++ b/impls/gnu-smalltalk/stepA_mal.st @@ -1,326 +1,326 @@ -String extend [ - String >> loadRelative [ - | scriptPath scriptDirectory | - scriptPath := thisContext currentFileName. - scriptDirectory := FilePath stripFileNameFor: scriptPath. - FileStream fileIn: (FilePath append: self to: scriptDirectory) - ] -] - -'readline.st' loadRelative. -'util.st' loadRelative. -'types.st' loadRelative. -'reader.st' loadRelative. -'printer.st' loadRelative. -'env.st' loadRelative. -'func.st' loadRelative. -'core.st' loadRelative. - -Object subclass: MAL [ - MAL class >> READ: input [ - ^Reader readStr: input - ] - - MAL class >> evalAst: sexp env: env [ - sexp type = #symbol ifTrue: [ - ^env get: sexp value - ]. - - sexp type = #list ifTrue: [ - ^self evalList: sexp env: env class: MALList - ]. - sexp type = #vector ifTrue: [ - ^self evalList: sexp env: env class: MALVector - ]. - sexp type = #map ifTrue: [ - ^self evalList: sexp env: env class: MALMap - ]. - - ^sexp - ] - - MAL class >> evalList: sexp env: env class: aClass [ - | items | - items := sexp value collect: - [ :item | self EVAL: item env: env ]. - ^aClass new: items - ] - - MAL class >> starts_with: ast sym: sym [ - | a a0 | - ast type = #list ifFalse: [ ^false. ]. - a := ast value. - a isEmpty ifTrue: [ ^false. ]. - a0 := a first. - ^a0 type = #symbol and: [ a0 value = sym ]. - ] - - MAL class >> quasiquote: ast [ - | result acc | - (ast type = #symbol or: [ ast type = #map ]) ifTrue: [ - result := {MALSymbol new: #quote. ast}. - ^MALList new: (OrderedCollection from: result) - ]. - (ast type = #list or: [ ast type = #vector ]) ifFalse: [ - ^ast - ]. - - (self starts_with: ast sym: #unquote) ifTrue: [ - ^ast value second - ]. - - result := {}. - acc := MALList new: (OrderedCollection from: result). - ast value reverseDo: [ : elt | - (self starts_with: elt sym: #'splice-unquote') ifTrue: [ - result := {MALSymbol new: #concat. elt value second. acc} - ] ifFalse: [ - result := {MALSymbol new: #cons. self quasiquote: elt. acc} - ]. - acc := MALList new: (OrderedCollection from: result) - ]. - ast type = #vector ifTrue: [ - result := {MALSymbol new: #vec. acc}. - acc := MALList new: (OrderedCollection from: result) - ]. - ^acc - ] - - MAL class >> isMacroCall: ast env: env [ - | a0 a0_ f | - ast type = #list ifTrue: [ - a0 := ast value first. - a0_ := a0 value. - a0 type = #symbol ifTrue: [ - f := env find: a0_. - (f notNil and: [ f type = #func ]) ifTrue: [ - ^f isMacro - ] - ] - ]. - ^false - ] - - MAL class >> macroexpand: aSexp env: env [ - | sexp | - - "NOTE: redefinition of method arguments is not allowed" - sexp := aSexp. - - [ self isMacroCall: sexp env: env ] whileTrue: [ - | ast a0_ macro rest | - ast := sexp value. - a0_ := ast first value. - macro := env find: a0_. - rest := ast allButFirst. - sexp := macro fn value: rest. - ]. - - ^sexp - ] - - MAL class >> EVAL: aSexp env: anEnv [ - | sexp env ast a0 a0_ a1 a1_ a2 a2_ a3 forms function args | - - "NOTE: redefinition of method arguments is not allowed" - sexp := aSexp. - env := anEnv. - - [ - [ :continue | - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - sexp value isEmpty ifTrue: [ - ^sexp - ]. - - sexp := self macroexpand: sexp env: env. - sexp type ~= #list ifTrue: [ - ^self evalAst: sexp env: env - ]. - - ast := sexp value. - a0 := ast first. - - a0_ := ast first value. - a0_ = #'def!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := self EVAL: a2 env: env. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'defmacro!' ifTrue: [ - | result | - a1_ := ast second value. - a2 := ast third. - result := (self EVAL: a2 env: env) deepCopy. - result isMacro: true. - env set: a1_ value: result. - ^result - ]. - - a0_ = #'macroexpand' ifTrue: [ - a1 := ast second. - ^self macroexpand: a1 env: env - ]. - - a0_ = #'let*' ifTrue: [ - | env_ | - env_ := Env new: env. - a1_ := ast second value. - a2 := ast third. - 1 to: a1_ size by: 2 do: - [ :i | env_ set: (a1_ at: i) value - value: (self EVAL: (a1_ at: i + 1) - env: env_) ]. - env := env_. - sexp := a2. - continue value "TCO" - ]. - - a0_ = #do ifTrue: [ - | forms last | - ast size < 2 ifTrue: [ - forms := {}. - last := MALObject Nil. - ] ifFalse: [ - forms := ast copyFrom: 2 to: ast size - 1. - last := ast last. - ]. - - forms do: [ :form | self EVAL: form env: env ]. - sexp := last. - continue value "TCO" - ]. - - a0_ = #if ifTrue: [ - | condition | - a1 := ast second. - a2 := ast third. - a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. - condition := self EVAL: a1 env: env. - - (condition type = #false or: - [ condition type = #nil ]) ifTrue: [ - sexp := a3 - ] ifFalse: [ - sexp := a2 - ]. - continue value "TCO" - ]. - - a0_ = #quote ifTrue: [ - a1 := ast second. - ^a1 - ]. - - a0_ = #quasiquoteexpand ifTrue: [ - a1 := ast second. - ^self quasiquote: a1. - ]. - - a0_ = #quasiquote ifTrue: [ - | result | - a1 := ast second. - sexp := self quasiquote: a1. - continue value "TCO" - ]. - - a0_ = #'try*' ifTrue: [ - | A B C | - A := ast second. - ast at: 3 ifAbsent: [ - ^self EVAL: A env: env. - ]. - a2_ := ast third value. - B := a2_ second value. - C := a2_ third. - ^[ self EVAL: A env: env ] on: MALError do: - [ :err | - | data env_ result | - data := err data. - data isString ifTrue: [ - data := MALString new: data - ]. - env_ := Env new: env binds: {B} exprs: {data}. - err return: (self EVAL: C env: env_) - ] - ]. - - a0_ = #'fn*' ifTrue: [ - | binds env_ fn | - a1_ := ast second value. - binds := a1_ collect: [ :item | item value ]. - a2 := ast third. - fn := [ :args | - self EVAL: a2 env: - (Env new: env binds: binds exprs: args) ]. - ^Func new: a2 params: binds env: env fn: fn - ]. - - forms := (self evalAst: sexp env: env) value. - function := forms first. - args := forms allButFirst asArray. - - function type = #fn ifTrue: [ ^function fn value: args ]. - function type = #func ifTrue: [ - | env_ | - sexp := function ast. - env_ := Env new: function env binds: function params - exprs: args. - env := env_. - continue value "TCO" - ] - ] valueWithExit - ] repeat. - ] - - MAL class >> PRINT: sexp [ - ^Printer prStr: sexp printReadably: true - ] - - MAL class >> rep: input env: env [ - ^self PRINT: (self EVAL: (self READ: input) env: env) - ] -] - -| input historyFile replEnv argv | - -historyFile := '.mal_history'. -ReadLine readHistory: historyFile. -replEnv := Env new: nil. - -argv := Smalltalk arguments. -argv notEmpty ifTrue: [ argv := argv allButFirst ]. -argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). - -Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. -replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). -replEnv set: #'*ARGV*' value: (MALList new: argv). -replEnv set: #'*host-language*' value: (MALString new: 'smalltalk'). - -MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. -MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. -MAL 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)))))))' env: replEnv. - -Smalltalk arguments notEmpty ifTrue: [ - MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv -] ifFalse: [ - MAL rep: '(println (str "Mal [" *host-language* "]"))' env: replEnv. - [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ - input isEmpty ifFalse: [ - ReadLine addHistory: input. - ReadLine writeHistory: historyFile. - [ (MAL rep: input env: replEnv) displayNl ] - on: MALEmptyInput do: [ #return ] - on: MALError do: - [ :err | ('error: ', err messageText) displayNl. #return ]. - ] - ]. - - '' displayNl. -] +String extend [ + String >> loadRelative [ + | scriptPath scriptDirectory | + scriptPath := thisContext currentFileName. + scriptDirectory := FilePath stripFileNameFor: scriptPath. + FileStream fileIn: (FilePath append: self to: scriptDirectory) + ] +] + +'readline.st' loadRelative. +'util.st' loadRelative. +'types.st' loadRelative. +'reader.st' loadRelative. +'printer.st' loadRelative. +'env.st' loadRelative. +'func.st' loadRelative. +'core.st' loadRelative. + +Object subclass: MAL [ + MAL class >> READ: input [ + ^Reader readStr: input + ] + + MAL class >> evalAst: sexp env: env [ + sexp type = #symbol ifTrue: [ + ^env get: sexp value + ]. + + sexp type = #list ifTrue: [ + ^self evalList: sexp env: env class: MALList + ]. + sexp type = #vector ifTrue: [ + ^self evalList: sexp env: env class: MALVector + ]. + sexp type = #map ifTrue: [ + ^self evalList: sexp env: env class: MALMap + ]. + + ^sexp + ] + + MAL class >> evalList: sexp env: env class: aClass [ + | items | + items := sexp value collect: + [ :item | self EVAL: item env: env ]. + ^aClass new: items + ] + + MAL class >> starts_with: ast sym: sym [ + | a a0 | + ast type = #list ifFalse: [ ^false. ]. + a := ast value. + a isEmpty ifTrue: [ ^false. ]. + a0 := a first. + ^a0 type = #symbol and: [ a0 value = sym ]. + ] + + MAL class >> quasiquote: ast [ + | result acc | + (ast type = #symbol or: [ ast type = #map ]) ifTrue: [ + result := {MALSymbol new: #quote. ast}. + ^MALList new: (OrderedCollection from: result) + ]. + (ast type = #list or: [ ast type = #vector ]) ifFalse: [ + ^ast + ]. + + (self starts_with: ast sym: #unquote) ifTrue: [ + ^ast value second + ]. + + result := {}. + acc := MALList new: (OrderedCollection from: result). + ast value reverseDo: [ : elt | + (self starts_with: elt sym: #'splice-unquote') ifTrue: [ + result := {MALSymbol new: #concat. elt value second. acc} + ] ifFalse: [ + result := {MALSymbol new: #cons. self quasiquote: elt. acc} + ]. + acc := MALList new: (OrderedCollection from: result) + ]. + ast type = #vector ifTrue: [ + result := {MALSymbol new: #vec. acc}. + acc := MALList new: (OrderedCollection from: result) + ]. + ^acc + ] + + MAL class >> isMacroCall: ast env: env [ + | a0 a0_ f | + ast type = #list ifTrue: [ + a0 := ast value first. + a0_ := a0 value. + a0 type = #symbol ifTrue: [ + f := env find: a0_. + (f notNil and: [ f type = #func ]) ifTrue: [ + ^f isMacro + ] + ] + ]. + ^false + ] + + MAL class >> macroexpand: aSexp env: env [ + | sexp | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + + [ self isMacroCall: sexp env: env ] whileTrue: [ + | ast a0_ macro rest | + ast := sexp value. + a0_ := ast first value. + macro := env find: a0_. + rest := ast allButFirst. + sexp := macro fn value: rest. + ]. + + ^sexp + ] + + MAL class >> EVAL: aSexp env: anEnv [ + | sexp env ast a0 a0_ a1 a1_ a2 a2_ a3 forms function args | + + "NOTE: redefinition of method arguments is not allowed" + sexp := aSexp. + env := anEnv. + + [ + [ :continue | + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + sexp value isEmpty ifTrue: [ + ^sexp + ]. + + sexp := self macroexpand: sexp env: env. + sexp type ~= #list ifTrue: [ + ^self evalAst: sexp env: env + ]. + + ast := sexp value. + a0 := ast first. + + a0_ := ast first value. + a0_ = #'def!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := self EVAL: a2 env: env. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'defmacro!' ifTrue: [ + | result | + a1_ := ast second value. + a2 := ast third. + result := (self EVAL: a2 env: env) deepCopy. + result isMacro: true. + env set: a1_ value: result. + ^result + ]. + + a0_ = #'macroexpand' ifTrue: [ + a1 := ast second. + ^self macroexpand: a1 env: env + ]. + + a0_ = #'let*' ifTrue: [ + | env_ | + env_ := Env new: env. + a1_ := ast second value. + a2 := ast third. + 1 to: a1_ size by: 2 do: + [ :i | env_ set: (a1_ at: i) value + value: (self EVAL: (a1_ at: i + 1) + env: env_) ]. + env := env_. + sexp := a2. + continue value "TCO" + ]. + + a0_ = #do ifTrue: [ + | forms last | + ast size < 2 ifTrue: [ + forms := {}. + last := MALObject Nil. + ] ifFalse: [ + forms := ast copyFrom: 2 to: ast size - 1. + last := ast last. + ]. + + forms do: [ :form | self EVAL: form env: env ]. + sexp := last. + continue value "TCO" + ]. + + a0_ = #if ifTrue: [ + | condition | + a1 := ast second. + a2 := ast third. + a3 := ast at: 4 ifAbsent: [ MALObject Nil ]. + condition := self EVAL: a1 env: env. + + (condition type = #false or: + [ condition type = #nil ]) ifTrue: [ + sexp := a3 + ] ifFalse: [ + sexp := a2 + ]. + continue value "TCO" + ]. + + a0_ = #quote ifTrue: [ + a1 := ast second. + ^a1 + ]. + + a0_ = #quasiquoteexpand ifTrue: [ + a1 := ast second. + ^self quasiquote: a1. + ]. + + a0_ = #quasiquote ifTrue: [ + | result | + a1 := ast second. + sexp := self quasiquote: a1. + continue value "TCO" + ]. + + a0_ = #'try*' ifTrue: [ + | A B C | + A := ast second. + ast at: 3 ifAbsent: [ + ^self EVAL: A env: env. + ]. + a2_ := ast third value. + B := a2_ second value. + C := a2_ third. + ^[ self EVAL: A env: env ] on: MALError do: + [ :err | + | data env_ result | + data := err data. + data isString ifTrue: [ + data := MALString new: data + ]. + env_ := Env new: env binds: {B} exprs: {data}. + err return: (self EVAL: C env: env_) + ] + ]. + + a0_ = #'fn*' ifTrue: [ + | binds env_ fn | + a1_ := ast second value. + binds := a1_ collect: [ :item | item value ]. + a2 := ast third. + fn := [ :args | + self EVAL: a2 env: + (Env new: env binds: binds exprs: args) ]. + ^Func new: a2 params: binds env: env fn: fn + ]. + + forms := (self evalAst: sexp env: env) value. + function := forms first. + args := forms allButFirst asArray. + + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ + | env_ | + sexp := function ast. + env_ := Env new: function env binds: function params + exprs: args. + env := env_. + continue value "TCO" + ] + ] valueWithExit + ] repeat. + ] + + MAL class >> PRINT: sexp [ + ^Printer prStr: sexp printReadably: true + ] + + MAL class >> rep: input env: env [ + ^self PRINT: (self EVAL: (self READ: input) env: env) + ] +] + +| input historyFile replEnv argv | + +historyFile := '.mal_history'. +ReadLine readHistory: historyFile. +replEnv := Env new: nil. + +argv := Smalltalk arguments. +argv notEmpty ifTrue: [ argv := argv allButFirst ]. +argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]). + +Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). +replEnv set: #'*ARGV*' value: (MALList new: argv). +replEnv set: #'*host-language*' value: (MALString new: 'smalltalk'). + +MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. +MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv. +MAL 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)))))))' env: replEnv. + +Smalltalk arguments notEmpty ifTrue: [ + MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv +] ifFalse: [ + MAL rep: '(println (str "Mal [" *host-language* "]"))' env: replEnv. + [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [ + input isEmpty ifFalse: [ + ReadLine addHistory: input. + ReadLine writeHistory: historyFile. + [ (MAL rep: input env: replEnv) displayNl ] + on: MALEmptyInput do: [ #return ] + on: MALError do: + [ :err | ('error: ', err messageText) displayNl. #return ]. + ] + ]. + + '' displayNl. +] diff --git a/impls/gnu-smalltalk/tests/stepA_mal.mal b/impls/gnu-smalltalk/tests/stepA_mal.mal index f8ff39f8f6..ed5229d864 100644 --- a/impls/gnu-smalltalk/tests/stepA_mal.mal +++ b/impls/gnu-smalltalk/tests/stepA_mal.mal @@ -1,11 +1,11 @@ -(gst-eval "1 + 1") -;=>2 - -(gst-eval "{1. 2. 3}") -;=>[1 2 3] - -(gst-eval "#('a' 'b' 'c') join: ' '") -;=>"a b c" - -(gst-eval "'Hello World!' displayNl") -;/Hello World! +(gst-eval "1 + 1") +;=>2 + +(gst-eval "{1. 2. 3}") +;=>[1 2 3] + +(gst-eval "#('a' 'b' 'c') join: ' '") +;=>"a b c" + +(gst-eval "'Hello World!' displayNl") +;/Hello World! diff --git a/impls/gnu-smalltalk/types.st b/impls/gnu-smalltalk/types.st index 86c0da47a8..94e99d0456 100644 --- a/impls/gnu-smalltalk/types.st +++ b/impls/gnu-smalltalk/types.st @@ -1,203 +1,203 @@ -Object subclass: MALObject [ - | type value meta | - - type [ ^type ] - value [ ^value ] - meta [ ^meta ] - - value: aValue [ - value := aValue. - ] - - meta: aMeta [ - meta := aMeta. - ] - - MALObject class >> new: type value: value meta: meta [ - | object | - object := super new. - object init: type value: value meta: meta. - ^object - ] - - init: aType value: aValue meta: aMeta [ - type := aType. - value := aValue. - meta := aMeta. - ] - - withMeta: meta [ - | object | - object := self deepCopy. - object meta: meta. - ^object - ] - - printOn: stream [ - stream nextPutAll: '<'; - nextPutAll: self class printString; - nextPutAll: ': '; - nextPutAll: value printString. - meta notNil ifTrue: [ - stream nextPutAll: ' | ' - nextPutAll: meta printString. - ]. - stream nextPutAll: '>'. - ] - - = x [ - self type ~= x type ifTrue: [ ^false ]. - ^self value = x value - ] - - hash [ - ^self value hash - ] -] - -MALObject subclass: MALTrue [ - MALTrue class >> new [ - ^super new: #true value: true meta: nil. - ] -] - -MALObject subclass: MALFalse [ - MALFalse class >> new [ - ^super new: #false value: false meta: nil. - ] -] - -MALObject subclass: MALNil [ - MALNil class >> new [ - ^super new: #nil value: nil meta: nil. - ] -] - -MALObject class extend [ - True := MALTrue new. - False := MALFalse new. - Nil := MALNil new. - - True [ ^True ] - False [ ^False ] - Nil [ ^Nil ] -] - -MALObject subclass: MALNumber [ - MALNumber class >> new: value [ - ^super new: #number value: value meta: nil. - ] -] - -MALObject subclass: MALString [ - MALString class >> new: value [ - ^super new: #string value: value meta: nil. - ] -] - -MALObject subclass: MALSymbol [ - MALSymbol class >> new: value [ - ^super new: #symbol value: value meta: nil. - ] -] - -MALObject subclass: MALKeyword [ - MALKeyword class >> new: value [ - ^super new: #keyword value: value meta: nil. - ] -] - -MALObject subclass: MALList [ - MALList class >> new: value [ - ^super new: #list value: value meta: nil. - ] - - = x [ - (x type ~= #list and: [ x type ~= #vector ]) ifTrue: [ ^false ]. - ^self value = x value - ] -] - -MALObject subclass: MALVector [ - MALVector class >> new: value [ - ^super new: #vector value: value meta: nil. - ] - - = x [ - (x type ~= #vector and: [ x type ~= #list ]) ifTrue: [ ^false ]. - ^self value = x value - ] -] - -MALObject subclass: MALMap [ - MALMap class >> new: value [ - ^super new: #map value: value meta: nil. - ] -] - -MALObject subclass: MALAtom [ - MALAtom class >> new: value [ - ^super new: #atom value: value meta: nil. - ] -] - -MALObject subclass: Fn [ - | fn | - - fn [ ^fn ] - - Fn class >> new: fn [ - | f | - f := super new: #fn value: fn meta: nil. - f init: fn. - ^f - ] - - init: f [ - fn := f. - ] -] - -Error subclass: MALError [ - description [ ^'A MAL-related error' ] - isResumable [ ^true ] - - data [ ^self messageText ] -] - -MALError subclass: MALUnterminatedSequence [ - MALUnterminatedSequence class >> new [ ^super new ] - - messageText [ ^'expected ''', self basicMessageText, ''', got EOF' ] -] - -MALError subclass: MALUnexpectedToken [ - MALUnexpectedToken class >> new [ ^super new ] - - messageText [ ^'unexpected token: ''', self basicMessageText, ''''] -] - -MALError subclass: MALEmptyInput [ - MALEmptyInput class >> new [ ^super new ] - - messageText [ ^'Empty input' ] -] - -MALError subclass: MALUnknownSymbol [ - MALUnknownSymbol class >> new [ ^super new ] - - messageText [ ^'''', self basicMessageText, ''' not found'] -] - -MALError subclass: MALOutOfBounds [ - MALOutOfBounds class >> new [ ^super new ] - - messageText [ ^'Out of bounds' ] -] - -MALError subclass: MALCustomError [ - MALCustomError class >> new [ ^super new ] - - messageText [ ^Printer prStr: self basicMessageText printReadably: true ] - data [ ^self basicMessageText ] -] +Object subclass: MALObject [ + | type value meta | + + type [ ^type ] + value [ ^value ] + meta [ ^meta ] + + value: aValue [ + value := aValue. + ] + + meta: aMeta [ + meta := aMeta. + ] + + MALObject class >> new: type value: value meta: meta [ + | object | + object := super new. + object init: type value: value meta: meta. + ^object + ] + + init: aType value: aValue meta: aMeta [ + type := aType. + value := aValue. + meta := aMeta. + ] + + withMeta: meta [ + | object | + object := self deepCopy. + object meta: meta. + ^object + ] + + printOn: stream [ + stream nextPutAll: '<'; + nextPutAll: self class printString; + nextPutAll: ': '; + nextPutAll: value printString. + meta notNil ifTrue: [ + stream nextPutAll: ' | ' + nextPutAll: meta printString. + ]. + stream nextPutAll: '>'. + ] + + = x [ + self type ~= x type ifTrue: [ ^false ]. + ^self value = x value + ] + + hash [ + ^self value hash + ] +] + +MALObject subclass: MALTrue [ + MALTrue class >> new [ + ^super new: #true value: true meta: nil. + ] +] + +MALObject subclass: MALFalse [ + MALFalse class >> new [ + ^super new: #false value: false meta: nil. + ] +] + +MALObject subclass: MALNil [ + MALNil class >> new [ + ^super new: #nil value: nil meta: nil. + ] +] + +MALObject class extend [ + True := MALTrue new. + False := MALFalse new. + Nil := MALNil new. + + True [ ^True ] + False [ ^False ] + Nil [ ^Nil ] +] + +MALObject subclass: MALNumber [ + MALNumber class >> new: value [ + ^super new: #number value: value meta: nil. + ] +] + +MALObject subclass: MALString [ + MALString class >> new: value [ + ^super new: #string value: value meta: nil. + ] +] + +MALObject subclass: MALSymbol [ + MALSymbol class >> new: value [ + ^super new: #symbol value: value meta: nil. + ] +] + +MALObject subclass: MALKeyword [ + MALKeyword class >> new: value [ + ^super new: #keyword value: value meta: nil. + ] +] + +MALObject subclass: MALList [ + MALList class >> new: value [ + ^super new: #list value: value meta: nil. + ] + + = x [ + (x type ~= #list and: [ x type ~= #vector ]) ifTrue: [ ^false ]. + ^self value = x value + ] +] + +MALObject subclass: MALVector [ + MALVector class >> new: value [ + ^super new: #vector value: value meta: nil. + ] + + = x [ + (x type ~= #vector and: [ x type ~= #list ]) ifTrue: [ ^false ]. + ^self value = x value + ] +] + +MALObject subclass: MALMap [ + MALMap class >> new: value [ + ^super new: #map value: value meta: nil. + ] +] + +MALObject subclass: MALAtom [ + MALAtom class >> new: value [ + ^super new: #atom value: value meta: nil. + ] +] + +MALObject subclass: Fn [ + | fn | + + fn [ ^fn ] + + Fn class >> new: fn [ + | f | + f := super new: #fn value: fn meta: nil. + f init: fn. + ^f + ] + + init: f [ + fn := f. + ] +] + +Error subclass: MALError [ + description [ ^'A MAL-related error' ] + isResumable [ ^true ] + + data [ ^self messageText ] +] + +MALError subclass: MALUnterminatedSequence [ + MALUnterminatedSequence class >> new [ ^super new ] + + messageText [ ^'expected ''', self basicMessageText, ''', got EOF' ] +] + +MALError subclass: MALUnexpectedToken [ + MALUnexpectedToken class >> new [ ^super new ] + + messageText [ ^'unexpected token: ''', self basicMessageText, ''''] +] + +MALError subclass: MALEmptyInput [ + MALEmptyInput class >> new [ ^super new ] + + messageText [ ^'Empty input' ] +] + +MALError subclass: MALUnknownSymbol [ + MALUnknownSymbol class >> new [ ^super new ] + + messageText [ ^'''', self basicMessageText, ''' not found'] +] + +MALError subclass: MALOutOfBounds [ + MALOutOfBounds class >> new [ ^super new ] + + messageText [ ^'Out of bounds' ] +] + +MALError subclass: MALCustomError [ + MALCustomError class >> new [ ^super new ] + + messageText [ ^Printer prStr: self basicMessageText printReadably: true ] + data [ ^self basicMessageText ] +] diff --git a/impls/gnu-smalltalk/util.st b/impls/gnu-smalltalk/util.st index 4a0009e6b0..e3b2c874f5 100644 --- a/impls/gnu-smalltalk/util.st +++ b/impls/gnu-smalltalk/util.st @@ -1,90 +1,90 @@ -SequenceableCollection extend [ - asDictionary [ - | dict assoc | - dict := Dictionary new. - 1 to: self size by: 2 do: - [ :i | dict add: (self at: i) -> (self at: i + 1) ]. - ^dict - ] -] - -String extend [ - parse [ - |text canary| - canary := 8r177 asCharacter asString. - text := self copyFrom: 2 to: self size - 1. - text := text copyReplaceAll: '\\' with: canary. - text := text copyReplaceAll: '\"' with: '"'. - text := text copyReplaceAll: '\n' with: ' -'. - text := text copyReplaceAll: canary with: '\'. - ^text - ] - - repr [ - |text| - text := self copyReplaceAll: '\' with: '\\'. - text := text copyReplaceAll: ' -' with: '\n'. - text := text copyReplaceAll: '"' with: '\"'. - ^'"', text, '"' - ] -] - -BlockClosure extend [ - valueWithExit [ - ^self value: [ ^nil ] - ] -] - -Object extend [ - toMALValue [ - self = true ifTrue: [ ^MALObject True ]. - self = false ifTrue: [ ^MALObject False ]. - self = nil ifTrue: [ ^MALObject Nil ]. - self isNumber ifTrue: [ ^MALNumber new: self ]. - self isString ifTrue: [ ^MALString new: self ]. - self isSymbol ifTrue: [ ^MALSymbol new: self ]. - self isArray ifTrue: [ - ^MALVector new: (self asOrderedCollection collect: - [ :item | item toMALValue ]) - ]. - self isSequenceable ifTrue: [ - ^MALList new: (self asOrderedCollection collect: - [ :item | item toMALValue ]) - ]. - self class = Dictionary ifTrue: [ - | result | - result := Dictionary new. - self keysAndValuesDo: [ :key :value | - result at: key toMALValue put: value toMALValue - ]. - ^MALMap new: result - ] - ] -] - -"NOTE: bugfix version from 3.2.91 for 3.2.4" -Namespace current: Kernel [ - -MatchingRegexResults extend [ - at: anIndex [ - - | reg text | - anIndex = 0 ifTrue: [^self match]. - cache isNil ifTrue: [cache := Array new: registers size]. - (cache at: anIndex) isNil - ifTrue: - [reg := registers at: anIndex. - text := reg isNil - ifTrue: [nil] - ifFalse: [ - reg isEmpty - ifTrue: [''] - ifFalse: [self subject copyFrom: reg first to: reg last]]. - cache at: anIndex put: text]. - ^cache at: anIndex - ] -] - -] +SequenceableCollection extend [ + asDictionary [ + | dict assoc | + dict := Dictionary new. + 1 to: self size by: 2 do: + [ :i | dict add: (self at: i) -> (self at: i + 1) ]. + ^dict + ] +] + +String extend [ + parse [ + |text canary| + canary := 8r177 asCharacter asString. + text := self copyFrom: 2 to: self size - 1. + text := text copyReplaceAll: '\\' with: canary. + text := text copyReplaceAll: '\"' with: '"'. + text := text copyReplaceAll: '\n' with: ' +'. + text := text copyReplaceAll: canary with: '\'. + ^text + ] + + repr [ + |text| + text := self copyReplaceAll: '\' with: '\\'. + text := text copyReplaceAll: ' +' with: '\n'. + text := text copyReplaceAll: '"' with: '\"'. + ^'"', text, '"' + ] +] + +BlockClosure extend [ + valueWithExit [ + ^self value: [ ^nil ] + ] +] + +Object extend [ + toMALValue [ + self = true ifTrue: [ ^MALObject True ]. + self = false ifTrue: [ ^MALObject False ]. + self = nil ifTrue: [ ^MALObject Nil ]. + self isNumber ifTrue: [ ^MALNumber new: self ]. + self isString ifTrue: [ ^MALString new: self ]. + self isSymbol ifTrue: [ ^MALSymbol new: self ]. + self isArray ifTrue: [ + ^MALVector new: (self asOrderedCollection collect: + [ :item | item toMALValue ]) + ]. + self isSequenceable ifTrue: [ + ^MALList new: (self asOrderedCollection collect: + [ :item | item toMALValue ]) + ]. + self class = Dictionary ifTrue: [ + | result | + result := Dictionary new. + self keysAndValuesDo: [ :key :value | + result at: key toMALValue put: value toMALValue + ]. + ^MALMap new: result + ] + ] +] + +"NOTE: bugfix version from 3.2.91 for 3.2.4" +Namespace current: Kernel [ + +MatchingRegexResults extend [ + at: anIndex [ + + | reg text | + anIndex = 0 ifTrue: [^self match]. + cache isNil ifTrue: [cache := Array new: registers size]. + (cache at: anIndex) isNil + ifTrue: + [reg := registers at: anIndex. + text := reg isNil + ifTrue: [nil] + ifFalse: [ + reg isEmpty + ifTrue: [''] + ifFalse: [self subject copyFrom: reg first to: reg last]]. + cache at: anIndex put: text]. + ^cache at: anIndex + ] +] + +] diff --git a/impls/go/Dockerfile b/impls/go/Dockerfile index 2be2be3f8a..adda95d344 100644 --- a/impls/go/Dockerfile +++ b/impls/go/Dockerfile @@ -1,28 +1,28 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install g++ for any C/C++ based implementations -RUN apt-get -y install g++ - -RUN apt-get -y install pkg-config -RUN apt-get -y install golang +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install g++ for any C/C++ based implementations +RUN apt-get -y install g++ + +RUN apt-get -y install pkg-config +RUN apt-get -y install golang diff --git a/impls/go/Makefile b/impls/go/Makefile index f2094e8e14..4f67e86fbc 100644 --- a/impls/go/Makefile +++ b/impls/go/Makefile @@ -1,33 +1,33 @@ -export GOPATH := $(dir $(abspath $(lastword $(MAKEFILE_LIST)))) - -##################### - -SOURCES_BASE = src/types/types.go src/readline/readline.go \ - src/reader/reader.go src/printer/printer.go \ - src/env/env.go src/core/core.go - -##################### - -SRCS = step0_repl.go step1_read_print.go step2_eval.go step3_env.go \ - step4_if_fn_do.go step5_tco.go step6_file.go step7_quote.go \ - step8_macros.go step9_try.go stepA_mal.go -BINS = $(SRCS:%.go=%) - -##################### - -all: $(BINS) - -dist: mal - -mal: $(word $(words $(BINS)),$(BINS)) - cp $< $@ - -define dep_template -$(1): $(SOURCES_BASE) src/$(1)/$(1).go - go build $$@ -endef - -$(foreach b,$(BINS),$(eval $(call dep_template,$(b)))) - -clean: - rm -f $(BINS) mal +export GOPATH := $(dir $(abspath $(lastword $(MAKEFILE_LIST)))) + +##################### + +SOURCES_BASE = src/types/types.go src/readline/readline.go \ + src/reader/reader.go src/printer/printer.go \ + src/env/env.go src/core/core.go + +##################### + +SRCS = step0_repl.go step1_read_print.go step2_eval.go step3_env.go \ + step4_if_fn_do.go step5_tco.go step6_file.go step7_quote.go \ + step8_macros.go step9_try.go stepA_mal.go +BINS = $(SRCS:%.go=%) + +##################### + +all: $(BINS) + +dist: mal + +mal: $(word $(words $(BINS)),$(BINS)) + cp $< $@ + +define dep_template +$(1): $(SOURCES_BASE) src/$(1)/$(1).go + go build $$@ +endef + +$(foreach b,$(BINS),$(eval $(call dep_template,$(b)))) + +clean: + rm -f $(BINS) mal diff --git a/impls/go/run b/impls/go/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/go/run +++ b/impls/go/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/go/src/core/core.go b/impls/go/src/core/core.go index 2f980fd7f1..5315b1fd06 100644 --- a/impls/go/src/core/core.go +++ b/impls/go/src/core/core.go @@ -1,567 +1,567 @@ -package core - -import ( - "errors" - "fmt" - "io/ioutil" - "strings" - "time" -) - -import ( - "printer" - "reader" - "readline" - . "types" -) - -// Errors/Exceptions -func throw(a []MalType) (MalType, error) { - return nil, MalError{a[0]} -} - -func fn_q(a []MalType) (MalType, error) { - switch f := a[0].(type) { - case MalFunc: - return !f.GetMacro(), nil - case Func: - return true, nil - case func([]MalType) (MalType, error): - return true, nil - default: - return false, nil - } -} - -// String functions - -func pr_str(a []MalType) (MalType, error) { - return printer.Pr_list(a, true, "", "", " "), nil -} - -func str(a []MalType) (MalType, error) { - return printer.Pr_list(a, false, "", "", ""), nil -} - -func prn(a []MalType) (MalType, error) { - fmt.Println(printer.Pr_list(a, true, "", "", " ")) - return nil, nil -} - -func println(a []MalType) (MalType, error) { - fmt.Println(printer.Pr_list(a, false, "", "", " ")) - return nil, nil -} - -func slurp(a []MalType) (MalType, error) { - b, e := ioutil.ReadFile(a[0].(string)) - if e != nil { - return nil, e - } - return string(b), nil -} - -// Number functions -func time_ms(a []MalType) (MalType, error) { - return int(time.Now().UnixNano() / int64(time.Millisecond)), nil -} - -// Hash Map functions -func copy_hash_map(hm HashMap) HashMap { - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range hm.Val { - new_hm.Val[k] = v - } - return new_hm -} - -func assoc(a []MalType) (MalType, error) { - if len(a) < 3 { - return nil, errors.New("assoc requires at least 3 arguments") - } - if len(a)%2 != 1 { - return nil, errors.New("assoc requires odd number of arguments") - } - if !HashMap_Q(a[0]) { - return nil, errors.New("assoc called on non-hash map") - } - new_hm := copy_hash_map(a[0].(HashMap)) - for i := 1; i < len(a); i += 2 { - key := a[i] - if !String_Q(key) { - return nil, errors.New("assoc called with non-string key") - } - new_hm.Val[key.(string)] = a[i+1] - } - return new_hm, nil -} - -func dissoc(a []MalType) (MalType, error) { - if len(a) < 2 { - return nil, errors.New("dissoc requires at least 3 arguments") - } - if !HashMap_Q(a[0]) { - return nil, errors.New("dissoc called on non-hash map") - } - new_hm := copy_hash_map(a[0].(HashMap)) - for i := 1; i < len(a); i += 1 { - key := a[i] - if !String_Q(key) { - return nil, errors.New("dissoc called with non-string key") - } - delete(new_hm.Val, key.(string)) - } - return new_hm, nil -} - -func get(a []MalType) (MalType, error) { - if Nil_Q(a[0]) { - return nil, nil - } - if !HashMap_Q(a[0]) { - return nil, errors.New("get called on non-hash map") - } - if !String_Q(a[1]) { - return nil, errors.New("get called with non-string key") - } - return a[0].(HashMap).Val[a[1].(string)], nil -} - -func contains_Q(hm MalType, key MalType) (MalType, error) { - if Nil_Q(hm) { - return false, nil - } - if !HashMap_Q(hm) { - return nil, errors.New("get called on non-hash map") - } - if !String_Q(key) { - return nil, errors.New("get called with non-string key") - } - _, ok := hm.(HashMap).Val[key.(string)] - return ok, nil -} - -func keys(a []MalType) (MalType, error) { - if !HashMap_Q(a[0]) { - return nil, errors.New("keys called on non-hash map") - } - slc := []MalType{} - for k, _ := range a[0].(HashMap).Val { - slc = append(slc, k) - } - return List{slc, nil}, nil -} - -func vals(a []MalType) (MalType, error) { - if !HashMap_Q(a[0]) { - return nil, errors.New("keys called on non-hash map") - } - slc := []MalType{} - for _, v := range a[0].(HashMap).Val { - slc = append(slc, v) - } - return List{slc, nil}, nil -} - -// Sequence functions - -func cons(a []MalType) (MalType, error) { - val := a[0] - lst, e := GetSlice(a[1]) - if e != nil { - return nil, e - } - return List{append([]MalType{val}, lst...), nil}, nil -} - -func concat(a []MalType) (MalType, error) { - if len(a) == 0 { - return List{}, nil - } - slc1, e := GetSlice(a[0]) - if e != nil { - return nil, e - } - for i := 1; i < len(a); i += 1 { - slc2, e := GetSlice(a[i]) - if e != nil { - return nil, e - } - slc1 = append(slc1, slc2...) - } - return List{slc1, nil}, nil -} - -func vec(a []MalType) (MalType, error) { - switch obj := a[0].(type) { - case Vector: - return obj, nil - case List: - return Vector{obj.Val, nil}, nil - default: - return nil, errors.New("vec: expects a sequence") - } -} - -func nth(a []MalType) (MalType, error) { - slc, e := GetSlice(a[0]) - if e != nil { - return nil, e - } - idx := a[1].(int) - if idx < len(slc) { - return slc[idx], nil - } else { - return nil, errors.New("nth: index out of range") - } -} - -func first(a []MalType) (MalType, error) { - if len(a) == 0 { - return nil, nil - } - if a[0] == nil { - return nil, nil - } - slc, e := GetSlice(a[0]) - if e != nil { - return nil, e - } - if len(slc) == 0 { - return nil, nil - } - return slc[0], nil -} - -func rest(a []MalType) (MalType, error) { - if a[0] == nil { - return List{}, nil - } - slc, e := GetSlice(a[0]) - if e != nil { - return nil, e - } - if len(slc) == 0 { - return List{}, nil - } - return List{slc[1:], nil}, nil -} - -func empty_Q(a []MalType) (MalType, error) { - switch obj := a[0].(type) { - case List: - return len(obj.Val) == 0, nil - case Vector: - return len(obj.Val) == 0, nil - case nil: - return true, nil - default: - return nil, errors.New("empty? called on non-sequence") - } -} - -func count(a []MalType) (MalType, error) { - switch obj := a[0].(type) { - case List: - return len(obj.Val), nil - case Vector: - return len(obj.Val), nil - case map[string]MalType: - return len(obj), nil - case nil: - return 0, nil - default: - return nil, errors.New("count called on non-sequence") - } -} - -func apply(a []MalType) (MalType, error) { - if len(a) < 2 { - return nil, errors.New("apply requires at least 2 args") - } - f := a[0] - args := []MalType{} - for _, b := range a[1 : len(a)-1] { - args = append(args, b) - } - last, e := GetSlice(a[len(a)-1]) - if e != nil { - return nil, e - } - args = append(args, last...) - return Apply(f, args) -} - -func do_map(a []MalType) (MalType, error) { - f := a[0] - results := []MalType{} - args, e := GetSlice(a[1]) - if e != nil { - return nil, e - } - for _, arg := range args { - res, e := Apply(f, []MalType{arg}) - results = append(results, res) - if e != nil { - return nil, e - } - } - return List{results, nil}, nil -} - -func conj(a []MalType) (MalType, error) { - if len(a) < 2 { - return nil, errors.New("conj requires at least 2 arguments") - } - switch seq := a[0].(type) { - case List: - new_slc := []MalType{} - for i := len(a) - 1; i > 0; i -= 1 { - new_slc = append(new_slc, a[i]) - } - return List{append(new_slc, seq.Val...), nil}, nil - case Vector: - new_slc := seq.Val - for _, x := range a[1:] { - new_slc = append(new_slc, x) - } - return Vector{new_slc, nil}, nil - } - - if !HashMap_Q(a[0]) { - return nil, errors.New("dissoc called on non-hash map") - } - new_hm := copy_hash_map(a[0].(HashMap)) - for i := 1; i < len(a); i += 1 { - key := a[i] - if !String_Q(key) { - return nil, errors.New("dissoc called with non-string key") - } - delete(new_hm.Val, key.(string)) - } - return new_hm, nil -} - -func seq(a []MalType) (MalType, error) { - if a[0] == nil { - return nil, nil - } - switch arg := a[0].(type) { - case List: - if len(arg.Val) == 0 { - return nil, nil - } - return arg, nil - case Vector: - if len(arg.Val) == 0 { - return nil, nil - } - return List{arg.Val, nil}, nil - case string: - if len(arg) == 0 { - return nil, nil - } - new_slc := []MalType{} - for _, ch := range strings.Split(arg, "") { - new_slc = append(new_slc, ch) - } - return List{new_slc, nil}, nil - } - return nil, errors.New("seq requires string or list or vector or nil") -} - -// Metadata functions -func with_meta(a []MalType) (MalType, error) { - obj := a[0] - m := a[1] - switch tobj := obj.(type) { - case List: - return List{tobj.Val, m}, nil - case Vector: - return Vector{tobj.Val, m}, nil - case HashMap: - return HashMap{tobj.Val, m}, nil - case Func: - return Func{tobj.Fn, m}, nil - case MalFunc: - fn := tobj - fn.Meta = m - return fn, nil - default: - return nil, errors.New("with-meta not supported on type") - } -} - -func meta(a []MalType) (MalType, error) { - obj := a[0] - switch tobj := obj.(type) { - case List: - return tobj.Meta, nil - case Vector: - return tobj.Meta, nil - case HashMap: - return tobj.Meta, nil - case Func: - return tobj.Meta, nil - case MalFunc: - return tobj.Meta, nil - default: - return nil, errors.New("meta not supported on type") - } -} - -// Atom functions -func deref(a []MalType) (MalType, error) { - if !Atom_Q(a[0]) { - return nil, errors.New("deref called with non-atom") - } - return a[0].(*Atom).Val, nil -} - -func reset_BANG(a []MalType) (MalType, error) { - if !Atom_Q(a[0]) { - return nil, errors.New("reset! called with non-atom") - } - a[0].(*Atom).Set(a[1]) - return a[1], nil -} - -func swap_BANG(a []MalType) (MalType, error) { - if !Atom_Q(a[0]) { - return nil, errors.New("swap! called with non-atom") - } - atm := a[0].(*Atom) - args := []MalType{atm.Val} - f := a[1] - args = append(args, a[2:]...) - res, e := Apply(f, args) - if e != nil { - return nil, e - } - atm.Set(res) - return res, nil -} - -// core namespace -var NS = map[string]MalType{ - "=": call2b(Equal_Q), - "throw": call1e(throw), - "nil?": call1b(Nil_Q), - "true?": call1b(True_Q), - "false?": call1b(False_Q), - "symbol": call1e(func(a []MalType) (MalType, error) { return Symbol{a[0].(string)}, nil }), - "symbol?": call1b(Symbol_Q), - "string?": call1e(func(a []MalType) (MalType, error) { return (String_Q(a[0]) && !Keyword_Q(a[0])), nil }), - "keyword": call1e(func(a []MalType) (MalType, error) { - if Keyword_Q(a[0]) { - return a[0], nil - } else { - return NewKeyword(a[0].(string)) - } - }), - "keyword?": call1b(Keyword_Q), - "number?": call1b(Number_Q), - "fn?": call1e(fn_q), - "macro?": call1e(func(a []MalType) (MalType, error) { return MalFunc_Q(a[0]) && a[0].(MalFunc).GetMacro(), nil }), - "pr-str": callNe(pr_str), - "str": callNe(str), - "prn": callNe(prn), - "println": callNe(println), - "read-string": call1e(func(a []MalType) (MalType, error) { return reader.Read_str(a[0].(string)) }), - "slurp": call1e(slurp), - "readline": call1e(func(a []MalType) (MalType, error) { return readline.Readline(a[0].(string)) }), - "<": call2e(func(a []MalType) (MalType, error) { return a[0].(int) < a[1].(int), nil }), - "<=": call2e(func(a []MalType) (MalType, error) { return a[0].(int) <= a[1].(int), nil }), - ">": call2e(func(a []MalType) (MalType, error) { return a[0].(int) > a[1].(int), nil }), - ">=": call2e(func(a []MalType) (MalType, error) { return a[0].(int) >= a[1].(int), nil }), - "+": call2e(func(a []MalType) (MalType, error) { return a[0].(int) + a[1].(int), nil }), - "-": call2e(func(a []MalType) (MalType, error) { return a[0].(int) - a[1].(int), nil }), - "*": call2e(func(a []MalType) (MalType, error) { return a[0].(int) * a[1].(int), nil }), - "/": call2e(func(a []MalType) (MalType, error) { return a[0].(int) / a[1].(int), nil }), - "time-ms": call0e(time_ms), - "list": callNe(func(a []MalType) (MalType, error) { return List{a, nil}, nil }), - "list?": call1b(List_Q), - "vector": callNe(func(a []MalType) (MalType, error) { return Vector{a, nil}, nil }), - "vector?": call1b(Vector_Q), - "hash-map": callNe(func(a []MalType) (MalType, error) { return NewHashMap(List{a, nil}) }), - "map?": call1b(HashMap_Q), - "assoc": callNe(assoc), // at least 3 - "dissoc": callNe(dissoc), // at least 2 - "get": call2e(get), - "contains?": call2e(func(a []MalType) (MalType, error) { return contains_Q(a[0], a[1]) }), - "keys": call1e(keys), - "vals": call1e(vals), - "sequential?": call1b(Sequential_Q), - "cons": call2e(cons), - "concat": callNe(concat), - "vec": call1e(vec), - "nth": call2e(nth), - "first": call1e(first), - "rest": call1e(rest), - "empty?": call1e(empty_Q), - "count": call1e(count), - "apply": callNe(apply), // at least 2 - "map": call2e(do_map), - "conj": callNe(conj), // at least 2 - "seq": call1e(seq), - "with-meta": call2e(with_meta), - "meta": call1e(meta), - "atom": call1e(func(a []MalType) (MalType, error) { return &Atom{a[0], nil}, nil }), - "atom?": call1b(Atom_Q), - "deref": call1e(deref), - "reset!": call2e(reset_BANG), - "swap!": callNe(swap_BANG), -} - -// callXX functions check the number of arguments -func call0e(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { - return func(args []MalType) (MalType, error) { - if len(args) != 0 { - return nil, fmt.Errorf("wrong number of arguments (%d instead of 0)", len(args)) - } - return f(args) - } -} - -func call1e(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { - return func(args []MalType) (MalType, error) { - if len(args) != 1 { - return nil, fmt.Errorf("wrong number of arguments (%d instead of 1)", len(args)) - } - return f(args) - } -} - -func call2e(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { - return func(args []MalType) (MalType, error) { - if len(args) != 2 { - return nil, fmt.Errorf("wrong number of arguments (%d instead of 2)", len(args)) - } - return f(args) - } -} - -func callNe(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { - // just for documenting purposes, does not check anything - return func(args []MalType) (MalType, error) { - return f(args) - } -} - -func call1b(f func(MalType) bool) func([]MalType) (MalType, error) { - return func(args []MalType) (MalType, error) { - if len(args) != 1 { - return nil, fmt.Errorf("wrong number of arguments (%d instead of 1)", len(args)) - } - return f(args[0]), nil - } -} - -func call2b(f func(MalType, MalType) bool) func([]MalType) (MalType, error) { - return func(args []MalType) (MalType, error) { - if len(args) != 2 { - return nil, fmt.Errorf("wrong number of arguments (%d instead of 2)", len(args)) - } - return f(args[0], args[1]), nil - } -} +package core + +import ( + "errors" + "fmt" + "io/ioutil" + "strings" + "time" +) + +import ( + "printer" + "reader" + "readline" + . "types" +) + +// Errors/Exceptions +func throw(a []MalType) (MalType, error) { + return nil, MalError{a[0]} +} + +func fn_q(a []MalType) (MalType, error) { + switch f := a[0].(type) { + case MalFunc: + return !f.GetMacro(), nil + case Func: + return true, nil + case func([]MalType) (MalType, error): + return true, nil + default: + return false, nil + } +} + +// String functions + +func pr_str(a []MalType) (MalType, error) { + return printer.Pr_list(a, true, "", "", " "), nil +} + +func str(a []MalType) (MalType, error) { + return printer.Pr_list(a, false, "", "", ""), nil +} + +func prn(a []MalType) (MalType, error) { + fmt.Println(printer.Pr_list(a, true, "", "", " ")) + return nil, nil +} + +func println(a []MalType) (MalType, error) { + fmt.Println(printer.Pr_list(a, false, "", "", " ")) + return nil, nil +} + +func slurp(a []MalType) (MalType, error) { + b, e := ioutil.ReadFile(a[0].(string)) + if e != nil { + return nil, e + } + return string(b), nil +} + +// Number functions +func time_ms(a []MalType) (MalType, error) { + return int(time.Now().UnixNano() / int64(time.Millisecond)), nil +} + +// Hash Map functions +func copy_hash_map(hm HashMap) HashMap { + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range hm.Val { + new_hm.Val[k] = v + } + return new_hm +} + +func assoc(a []MalType) (MalType, error) { + if len(a) < 3 { + return nil, errors.New("assoc requires at least 3 arguments") + } + if len(a)%2 != 1 { + return nil, errors.New("assoc requires odd number of arguments") + } + if !HashMap_Q(a[0]) { + return nil, errors.New("assoc called on non-hash map") + } + new_hm := copy_hash_map(a[0].(HashMap)) + for i := 1; i < len(a); i += 2 { + key := a[i] + if !String_Q(key) { + return nil, errors.New("assoc called with non-string key") + } + new_hm.Val[key.(string)] = a[i+1] + } + return new_hm, nil +} + +func dissoc(a []MalType) (MalType, error) { + if len(a) < 2 { + return nil, errors.New("dissoc requires at least 3 arguments") + } + if !HashMap_Q(a[0]) { + return nil, errors.New("dissoc called on non-hash map") + } + new_hm := copy_hash_map(a[0].(HashMap)) + for i := 1; i < len(a); i += 1 { + key := a[i] + if !String_Q(key) { + return nil, errors.New("dissoc called with non-string key") + } + delete(new_hm.Val, key.(string)) + } + return new_hm, nil +} + +func get(a []MalType) (MalType, error) { + if Nil_Q(a[0]) { + return nil, nil + } + if !HashMap_Q(a[0]) { + return nil, errors.New("get called on non-hash map") + } + if !String_Q(a[1]) { + return nil, errors.New("get called with non-string key") + } + return a[0].(HashMap).Val[a[1].(string)], nil +} + +func contains_Q(hm MalType, key MalType) (MalType, error) { + if Nil_Q(hm) { + return false, nil + } + if !HashMap_Q(hm) { + return nil, errors.New("get called on non-hash map") + } + if !String_Q(key) { + return nil, errors.New("get called with non-string key") + } + _, ok := hm.(HashMap).Val[key.(string)] + return ok, nil +} + +func keys(a []MalType) (MalType, error) { + if !HashMap_Q(a[0]) { + return nil, errors.New("keys called on non-hash map") + } + slc := []MalType{} + for k, _ := range a[0].(HashMap).Val { + slc = append(slc, k) + } + return List{slc, nil}, nil +} + +func vals(a []MalType) (MalType, error) { + if !HashMap_Q(a[0]) { + return nil, errors.New("keys called on non-hash map") + } + slc := []MalType{} + for _, v := range a[0].(HashMap).Val { + slc = append(slc, v) + } + return List{slc, nil}, nil +} + +// Sequence functions + +func cons(a []MalType) (MalType, error) { + val := a[0] + lst, e := GetSlice(a[1]) + if e != nil { + return nil, e + } + return List{append([]MalType{val}, lst...), nil}, nil +} + +func concat(a []MalType) (MalType, error) { + if len(a) == 0 { + return List{}, nil + } + slc1, e := GetSlice(a[0]) + if e != nil { + return nil, e + } + for i := 1; i < len(a); i += 1 { + slc2, e := GetSlice(a[i]) + if e != nil { + return nil, e + } + slc1 = append(slc1, slc2...) + } + return List{slc1, nil}, nil +} + +func vec(a []MalType) (MalType, error) { + switch obj := a[0].(type) { + case Vector: + return obj, nil + case List: + return Vector{obj.Val, nil}, nil + default: + return nil, errors.New("vec: expects a sequence") + } +} + +func nth(a []MalType) (MalType, error) { + slc, e := GetSlice(a[0]) + if e != nil { + return nil, e + } + idx := a[1].(int) + if idx < len(slc) { + return slc[idx], nil + } else { + return nil, errors.New("nth: index out of range") + } +} + +func first(a []MalType) (MalType, error) { + if len(a) == 0 { + return nil, nil + } + if a[0] == nil { + return nil, nil + } + slc, e := GetSlice(a[0]) + if e != nil { + return nil, e + } + if len(slc) == 0 { + return nil, nil + } + return slc[0], nil +} + +func rest(a []MalType) (MalType, error) { + if a[0] == nil { + return List{}, nil + } + slc, e := GetSlice(a[0]) + if e != nil { + return nil, e + } + if len(slc) == 0 { + return List{}, nil + } + return List{slc[1:], nil}, nil +} + +func empty_Q(a []MalType) (MalType, error) { + switch obj := a[0].(type) { + case List: + return len(obj.Val) == 0, nil + case Vector: + return len(obj.Val) == 0, nil + case nil: + return true, nil + default: + return nil, errors.New("empty? called on non-sequence") + } +} + +func count(a []MalType) (MalType, error) { + switch obj := a[0].(type) { + case List: + return len(obj.Val), nil + case Vector: + return len(obj.Val), nil + case map[string]MalType: + return len(obj), nil + case nil: + return 0, nil + default: + return nil, errors.New("count called on non-sequence") + } +} + +func apply(a []MalType) (MalType, error) { + if len(a) < 2 { + return nil, errors.New("apply requires at least 2 args") + } + f := a[0] + args := []MalType{} + for _, b := range a[1 : len(a)-1] { + args = append(args, b) + } + last, e := GetSlice(a[len(a)-1]) + if e != nil { + return nil, e + } + args = append(args, last...) + return Apply(f, args) +} + +func do_map(a []MalType) (MalType, error) { + f := a[0] + results := []MalType{} + args, e := GetSlice(a[1]) + if e != nil { + return nil, e + } + for _, arg := range args { + res, e := Apply(f, []MalType{arg}) + results = append(results, res) + if e != nil { + return nil, e + } + } + return List{results, nil}, nil +} + +func conj(a []MalType) (MalType, error) { + if len(a) < 2 { + return nil, errors.New("conj requires at least 2 arguments") + } + switch seq := a[0].(type) { + case List: + new_slc := []MalType{} + for i := len(a) - 1; i > 0; i -= 1 { + new_slc = append(new_slc, a[i]) + } + return List{append(new_slc, seq.Val...), nil}, nil + case Vector: + new_slc := seq.Val + for _, x := range a[1:] { + new_slc = append(new_slc, x) + } + return Vector{new_slc, nil}, nil + } + + if !HashMap_Q(a[0]) { + return nil, errors.New("dissoc called on non-hash map") + } + new_hm := copy_hash_map(a[0].(HashMap)) + for i := 1; i < len(a); i += 1 { + key := a[i] + if !String_Q(key) { + return nil, errors.New("dissoc called with non-string key") + } + delete(new_hm.Val, key.(string)) + } + return new_hm, nil +} + +func seq(a []MalType) (MalType, error) { + if a[0] == nil { + return nil, nil + } + switch arg := a[0].(type) { + case List: + if len(arg.Val) == 0 { + return nil, nil + } + return arg, nil + case Vector: + if len(arg.Val) == 0 { + return nil, nil + } + return List{arg.Val, nil}, nil + case string: + if len(arg) == 0 { + return nil, nil + } + new_slc := []MalType{} + for _, ch := range strings.Split(arg, "") { + new_slc = append(new_slc, ch) + } + return List{new_slc, nil}, nil + } + return nil, errors.New("seq requires string or list or vector or nil") +} + +// Metadata functions +func with_meta(a []MalType) (MalType, error) { + obj := a[0] + m := a[1] + switch tobj := obj.(type) { + case List: + return List{tobj.Val, m}, nil + case Vector: + return Vector{tobj.Val, m}, nil + case HashMap: + return HashMap{tobj.Val, m}, nil + case Func: + return Func{tobj.Fn, m}, nil + case MalFunc: + fn := tobj + fn.Meta = m + return fn, nil + default: + return nil, errors.New("with-meta not supported on type") + } +} + +func meta(a []MalType) (MalType, error) { + obj := a[0] + switch tobj := obj.(type) { + case List: + return tobj.Meta, nil + case Vector: + return tobj.Meta, nil + case HashMap: + return tobj.Meta, nil + case Func: + return tobj.Meta, nil + case MalFunc: + return tobj.Meta, nil + default: + return nil, errors.New("meta not supported on type") + } +} + +// Atom functions +func deref(a []MalType) (MalType, error) { + if !Atom_Q(a[0]) { + return nil, errors.New("deref called with non-atom") + } + return a[0].(*Atom).Val, nil +} + +func reset_BANG(a []MalType) (MalType, error) { + if !Atom_Q(a[0]) { + return nil, errors.New("reset! called with non-atom") + } + a[0].(*Atom).Set(a[1]) + return a[1], nil +} + +func swap_BANG(a []MalType) (MalType, error) { + if !Atom_Q(a[0]) { + return nil, errors.New("swap! called with non-atom") + } + atm := a[0].(*Atom) + args := []MalType{atm.Val} + f := a[1] + args = append(args, a[2:]...) + res, e := Apply(f, args) + if e != nil { + return nil, e + } + atm.Set(res) + return res, nil +} + +// core namespace +var NS = map[string]MalType{ + "=": call2b(Equal_Q), + "throw": call1e(throw), + "nil?": call1b(Nil_Q), + "true?": call1b(True_Q), + "false?": call1b(False_Q), + "symbol": call1e(func(a []MalType) (MalType, error) { return Symbol{a[0].(string)}, nil }), + "symbol?": call1b(Symbol_Q), + "string?": call1e(func(a []MalType) (MalType, error) { return (String_Q(a[0]) && !Keyword_Q(a[0])), nil }), + "keyword": call1e(func(a []MalType) (MalType, error) { + if Keyword_Q(a[0]) { + return a[0], nil + } else { + return NewKeyword(a[0].(string)) + } + }), + "keyword?": call1b(Keyword_Q), + "number?": call1b(Number_Q), + "fn?": call1e(fn_q), + "macro?": call1e(func(a []MalType) (MalType, error) { return MalFunc_Q(a[0]) && a[0].(MalFunc).GetMacro(), nil }), + "pr-str": callNe(pr_str), + "str": callNe(str), + "prn": callNe(prn), + "println": callNe(println), + "read-string": call1e(func(a []MalType) (MalType, error) { return reader.Read_str(a[0].(string)) }), + "slurp": call1e(slurp), + "readline": call1e(func(a []MalType) (MalType, error) { return readline.Readline(a[0].(string)) }), + "<": call2e(func(a []MalType) (MalType, error) { return a[0].(int) < a[1].(int), nil }), + "<=": call2e(func(a []MalType) (MalType, error) { return a[0].(int) <= a[1].(int), nil }), + ">": call2e(func(a []MalType) (MalType, error) { return a[0].(int) > a[1].(int), nil }), + ">=": call2e(func(a []MalType) (MalType, error) { return a[0].(int) >= a[1].(int), nil }), + "+": call2e(func(a []MalType) (MalType, error) { return a[0].(int) + a[1].(int), nil }), + "-": call2e(func(a []MalType) (MalType, error) { return a[0].(int) - a[1].(int), nil }), + "*": call2e(func(a []MalType) (MalType, error) { return a[0].(int) * a[1].(int), nil }), + "/": call2e(func(a []MalType) (MalType, error) { return a[0].(int) / a[1].(int), nil }), + "time-ms": call0e(time_ms), + "list": callNe(func(a []MalType) (MalType, error) { return List{a, nil}, nil }), + "list?": call1b(List_Q), + "vector": callNe(func(a []MalType) (MalType, error) { return Vector{a, nil}, nil }), + "vector?": call1b(Vector_Q), + "hash-map": callNe(func(a []MalType) (MalType, error) { return NewHashMap(List{a, nil}) }), + "map?": call1b(HashMap_Q), + "assoc": callNe(assoc), // at least 3 + "dissoc": callNe(dissoc), // at least 2 + "get": call2e(get), + "contains?": call2e(func(a []MalType) (MalType, error) { return contains_Q(a[0], a[1]) }), + "keys": call1e(keys), + "vals": call1e(vals), + "sequential?": call1b(Sequential_Q), + "cons": call2e(cons), + "concat": callNe(concat), + "vec": call1e(vec), + "nth": call2e(nth), + "first": call1e(first), + "rest": call1e(rest), + "empty?": call1e(empty_Q), + "count": call1e(count), + "apply": callNe(apply), // at least 2 + "map": call2e(do_map), + "conj": callNe(conj), // at least 2 + "seq": call1e(seq), + "with-meta": call2e(with_meta), + "meta": call1e(meta), + "atom": call1e(func(a []MalType) (MalType, error) { return &Atom{a[0], nil}, nil }), + "atom?": call1b(Atom_Q), + "deref": call1e(deref), + "reset!": call2e(reset_BANG), + "swap!": callNe(swap_BANG), +} + +// callXX functions check the number of arguments +func call0e(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 0 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 0)", len(args)) + } + return f(args) + } +} + +func call1e(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 1 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 1)", len(args)) + } + return f(args) + } +} + +func call2e(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 2 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 2)", len(args)) + } + return f(args) + } +} + +func callNe(f func([]MalType) (MalType, error)) func([]MalType) (MalType, error) { + // just for documenting purposes, does not check anything + return func(args []MalType) (MalType, error) { + return f(args) + } +} + +func call1b(f func(MalType) bool) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 1 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 1)", len(args)) + } + return f(args[0]), nil + } +} + +func call2b(f func(MalType, MalType) bool) func([]MalType) (MalType, error) { + return func(args []MalType) (MalType, error) { + if len(args) != 2 { + return nil, fmt.Errorf("wrong number of arguments (%d instead of 2)", len(args)) + } + return f(args[0], args[1]), nil + } +} diff --git a/impls/go/src/env/env.go b/impls/go/src/env/env.go index 88098fcc0a..078b354a86 100644 --- a/impls/go/src/env/env.go +++ b/impls/go/src/env/env.go @@ -1,65 +1,65 @@ -package env - -import ( - "errors" - //"fmt" -) - -import ( - . "types" -) - -type Env struct { - data map[string]MalType - outer EnvType -} - -func NewEnv(outer EnvType, binds_mt MalType, exprs_mt MalType) (EnvType, error) { - env := Env{map[string]MalType{}, outer} - - if binds_mt != nil && exprs_mt != nil { - binds, e := GetSlice(binds_mt) - if e != nil { - return nil, e - } - exprs, e := GetSlice(exprs_mt) - if e != nil { - return nil, e - } - // Return a new Env with symbols in binds boudn to - // corresponding values in exprs - for i := 0; i < len(binds); i += 1 { - if Symbol_Q(binds[i]) && binds[i].(Symbol).Val == "&" { - env.data[binds[i+1].(Symbol).Val] = List{exprs[i:], nil} - break - } else { - env.data[binds[i].(Symbol).Val] = exprs[i] - } - } - } - //return &et, nil - return env, nil -} - -func (e Env) Find(key Symbol) EnvType { - if _, ok := e.data[key.Val]; ok { - return e - } else if e.outer != nil { - return e.outer.Find(key) - } else { - return nil - } -} - -func (e Env) Set(key Symbol, value MalType) MalType { - e.data[key.Val] = value - return value -} - -func (e Env) Get(key Symbol) (MalType, error) { - env := e.Find(key) - if env == nil { - return nil, errors.New("'" + key.Val + "' not found") - } - return env.(Env).data[key.Val], nil -} +package env + +import ( + "errors" + //"fmt" +) + +import ( + . "types" +) + +type Env struct { + data map[string]MalType + outer EnvType +} + +func NewEnv(outer EnvType, binds_mt MalType, exprs_mt MalType) (EnvType, error) { + env := Env{map[string]MalType{}, outer} + + if binds_mt != nil && exprs_mt != nil { + binds, e := GetSlice(binds_mt) + if e != nil { + return nil, e + } + exprs, e := GetSlice(exprs_mt) + if e != nil { + return nil, e + } + // Return a new Env with symbols in binds boudn to + // corresponding values in exprs + for i := 0; i < len(binds); i += 1 { + if Symbol_Q(binds[i]) && binds[i].(Symbol).Val == "&" { + env.data[binds[i+1].(Symbol).Val] = List{exprs[i:], nil} + break + } else { + env.data[binds[i].(Symbol).Val] = exprs[i] + } + } + } + //return &et, nil + return env, nil +} + +func (e Env) Find(key Symbol) EnvType { + if _, ok := e.data[key.Val]; ok { + return e + } else if e.outer != nil { + return e.outer.Find(key) + } else { + return nil + } +} + +func (e Env) Set(key Symbol, value MalType) MalType { + e.data[key.Val] = value + return value +} + +func (e Env) Get(key Symbol) (MalType, error) { + env := e.Find(key) + if env == nil { + return nil, errors.New("'" + key.Val + "' not found") + } + return env.(Env).data[key.Val], nil +} diff --git a/impls/go/src/printer/printer.go b/impls/go/src/printer/printer.go index 016e65f8d8..d5312e335c 100644 --- a/impls/go/src/printer/printer.go +++ b/impls/go/src/printer/printer.go @@ -1,62 +1,62 @@ -package printer - -import ( - "fmt" - "strings" -) - -import ( - "types" -) - -func Pr_list(lst []types.MalType, pr bool, - start string, end string, join string) string { - str_list := make([]string, 0, len(lst)) - for _, e := range lst { - str_list = append(str_list, Pr_str(e, pr)) - } - return start + strings.Join(str_list, join) + end -} - -func Pr_str(obj types.MalType, print_readably bool) string { - switch tobj := obj.(type) { - case types.List: - return Pr_list(tobj.Val, print_readably, "(", ")", " ") - case types.Vector: - return Pr_list(tobj.Val, print_readably, "[", "]", " ") - case types.HashMap: - str_list := make([]string, 0, len(tobj.Val)*2) - for k, v := range tobj.Val { - str_list = append(str_list, Pr_str(k, print_readably)) - str_list = append(str_list, Pr_str(v, print_readably)) - } - return "{" + strings.Join(str_list, " ") + "}" - case string: - if strings.HasPrefix(tobj, "\u029e") { - return ":" + tobj[2:len(tobj)] - } else if print_readably { - return `"` + strings.Replace( - strings.Replace( - strings.Replace(tobj, `\`, `\\`, -1), - `"`, `\"`, -1), - "\n", `\n`, -1) + `"` - } else { - return tobj - } - case types.Symbol: - return tobj.Val - case nil: - return "nil" - case types.MalFunc: - return "(fn* " + - Pr_str(tobj.Params, true) + " " + - Pr_str(tobj.Exp, true) + ")" - case func([]types.MalType) (types.MalType, error): - return fmt.Sprintf("", obj) - case *types.Atom: - return "(atom " + - Pr_str(tobj.Val, true) + ")" - default: - return fmt.Sprintf("%v", obj) - } -} +package printer + +import ( + "fmt" + "strings" +) + +import ( + "types" +) + +func Pr_list(lst []types.MalType, pr bool, + start string, end string, join string) string { + str_list := make([]string, 0, len(lst)) + for _, e := range lst { + str_list = append(str_list, Pr_str(e, pr)) + } + return start + strings.Join(str_list, join) + end +} + +func Pr_str(obj types.MalType, print_readably bool) string { + switch tobj := obj.(type) { + case types.List: + return Pr_list(tobj.Val, print_readably, "(", ")", " ") + case types.Vector: + return Pr_list(tobj.Val, print_readably, "[", "]", " ") + case types.HashMap: + str_list := make([]string, 0, len(tobj.Val)*2) + for k, v := range tobj.Val { + str_list = append(str_list, Pr_str(k, print_readably)) + str_list = append(str_list, Pr_str(v, print_readably)) + } + return "{" + strings.Join(str_list, " ") + "}" + case string: + if strings.HasPrefix(tobj, "\u029e") { + return ":" + tobj[2:len(tobj)] + } else if print_readably { + return `"` + strings.Replace( + strings.Replace( + strings.Replace(tobj, `\`, `\\`, -1), + `"`, `\"`, -1), + "\n", `\n`, -1) + `"` + } else { + return tobj + } + case types.Symbol: + return tobj.Val + case nil: + return "nil" + case types.MalFunc: + return "(fn* " + + Pr_str(tobj.Params, true) + " " + + Pr_str(tobj.Exp, true) + ")" + case func([]types.MalType) (types.MalType, error): + return fmt.Sprintf("", obj) + case *types.Atom: + return "(atom " + + Pr_str(tobj.Val, true) + ")" + default: + return fmt.Sprintf("%v", obj) + } +} diff --git a/impls/go/src/reader/reader.go b/impls/go/src/reader/reader.go index 49d8add63a..349e5301f1 100644 --- a/impls/go/src/reader/reader.go +++ b/impls/go/src/reader/reader.go @@ -1,223 +1,223 @@ -package reader - -import ( - "errors" - "regexp" - "strconv" - "strings" - //"fmt" -) - -import ( - . "types" -) - -type Reader interface { - next() *string - peek() *string -} - -type TokenReader struct { - tokens []string - position int -} - -func (tr *TokenReader) next() *string { - if tr.position >= len(tr.tokens) { - return nil - } - token := tr.tokens[tr.position] - tr.position = tr.position + 1 - return &token -} - -func (tr *TokenReader) peek() *string { - if tr.position >= len(tr.tokens) { - return nil - } - return &tr.tokens[tr.position] -} - -func tokenize(str string) []string { - results := make([]string, 0, 1) - // Work around lack of quoting in backtick - re := regexp.MustCompile(`[\s,]*(~@|[\[\]{}()'` + "`" + - `~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"` + "`" + - `,;)]*)`) - for _, group := range re.FindAllStringSubmatch(str, -1) { - if (group[1] == "") || (group[1][0] == ';') { - continue - } - results = append(results, group[1]) - } - return results -} - -func read_atom(rdr Reader) (MalType, error) { - token := rdr.next() - if token == nil { - return nil, errors.New("read_atom underflow") - } - if match, _ := regexp.MatchString(`^-?[0-9]+$`, *token); match { - var i int - var e error - if i, e = strconv.Atoi(*token); e != nil { - return nil, errors.New("number parse error") - } - return i, nil - } else if match, _ := - regexp.MatchString(`^"(?:\\.|[^\\"])*"$`, *token); match { - str := (*token)[1 : len(*token)-1] - return strings.Replace( - strings.Replace( - strings.Replace( - strings.Replace(str, `\\`, "\u029e", -1), - `\"`, `"`, -1), - `\n`, "\n", -1), - "\u029e", "\\", -1), nil - } else if (*token)[0] == '"' { - return nil, errors.New("expected '\"', got EOF") - } else if (*token)[0] == ':' { - return NewKeyword((*token)[1:len(*token)]) - } else if *token == "nil" { - return nil, nil - } else if *token == "true" { - return true, nil - } else if *token == "false" { - return false, nil - } else { - return Symbol{*token}, nil - } - return token, nil -} - -func read_list(rdr Reader, start string, end string) (MalType, error) { - token := rdr.next() - if token == nil { - return nil, errors.New("read_list underflow") - } - if *token != start { - return nil, errors.New("expected '" + start + "'") - } - - ast_list := []MalType{} - token = rdr.peek() - for ; true; token = rdr.peek() { - if token == nil { - return nil, errors.New("exepected '" + end + "', got EOF") - } - if *token == end { - break - } - f, e := read_form(rdr) - if e != nil { - return nil, e - } - ast_list = append(ast_list, f) - } - rdr.next() - return List{ast_list, nil}, nil -} - -func read_vector(rdr Reader) (MalType, error) { - lst, e := read_list(rdr, "[", "]") - if e != nil { - return nil, e - } - vec := Vector{lst.(List).Val, nil} - return vec, nil -} - -func read_hash_map(rdr Reader) (MalType, error) { - mal_lst, e := read_list(rdr, "{", "}") - if e != nil { - return nil, e - } - return NewHashMap(mal_lst) -} - -func read_form(rdr Reader) (MalType, error) { - token := rdr.peek() - if token == nil { - return nil, errors.New("read_form underflow") - } - switch *token { - - case `'`: - rdr.next() - form, e := read_form(rdr) - if e != nil { - return nil, e - } - return List{[]MalType{Symbol{"quote"}, form}, nil}, nil - case "`": - rdr.next() - form, e := read_form(rdr) - if e != nil { - return nil, e - } - return List{[]MalType{Symbol{"quasiquote"}, form}, nil}, nil - case `~`: - rdr.next() - form, e := read_form(rdr) - if e != nil { - return nil, e - } - return List{[]MalType{Symbol{"unquote"}, form}, nil}, nil - case `~@`: - rdr.next() - form, e := read_form(rdr) - if e != nil { - return nil, e - } - return List{[]MalType{Symbol{"splice-unquote"}, form}, nil}, nil - case `^`: - rdr.next() - meta, e := read_form(rdr) - if e != nil { - return nil, e - } - form, e := read_form(rdr) - if e != nil { - return nil, e - } - return List{[]MalType{Symbol{"with-meta"}, form, meta}, nil}, nil - case `@`: - rdr.next() - form, e := read_form(rdr) - if e != nil { - return nil, e - } - return List{[]MalType{Symbol{"deref"}, form}, nil}, nil - - // list - case ")": - return nil, errors.New("unexpected ')'") - case "(": - return read_list(rdr, "(", ")") - - // vector - case "]": - return nil, errors.New("unexpected ']'") - case "[": - return read_vector(rdr) - - // hash-map - case "}": - return nil, errors.New("unexpected '}'") - case "{": - return read_hash_map(rdr) - default: - return read_atom(rdr) - } - return read_atom(rdr) -} - -func Read_str(str string) (MalType, error) { - var tokens = tokenize(str) - if len(tokens) == 0 { - return nil, errors.New("") - } - - return read_form(&TokenReader{tokens: tokens, position: 0}) -} +package reader + +import ( + "errors" + "regexp" + "strconv" + "strings" + //"fmt" +) + +import ( + . "types" +) + +type Reader interface { + next() *string + peek() *string +} + +type TokenReader struct { + tokens []string + position int +} + +func (tr *TokenReader) next() *string { + if tr.position >= len(tr.tokens) { + return nil + } + token := tr.tokens[tr.position] + tr.position = tr.position + 1 + return &token +} + +func (tr *TokenReader) peek() *string { + if tr.position >= len(tr.tokens) { + return nil + } + return &tr.tokens[tr.position] +} + +func tokenize(str string) []string { + results := make([]string, 0, 1) + // Work around lack of quoting in backtick + re := regexp.MustCompile(`[\s,]*(~@|[\[\]{}()'` + "`" + + `~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"` + "`" + + `,;)]*)`) + for _, group := range re.FindAllStringSubmatch(str, -1) { + if (group[1] == "") || (group[1][0] == ';') { + continue + } + results = append(results, group[1]) + } + return results +} + +func read_atom(rdr Reader) (MalType, error) { + token := rdr.next() + if token == nil { + return nil, errors.New("read_atom underflow") + } + if match, _ := regexp.MatchString(`^-?[0-9]+$`, *token); match { + var i int + var e error + if i, e = strconv.Atoi(*token); e != nil { + return nil, errors.New("number parse error") + } + return i, nil + } else if match, _ := + regexp.MatchString(`^"(?:\\.|[^\\"])*"$`, *token); match { + str := (*token)[1 : len(*token)-1] + return strings.Replace( + strings.Replace( + strings.Replace( + strings.Replace(str, `\\`, "\u029e", -1), + `\"`, `"`, -1), + `\n`, "\n", -1), + "\u029e", "\\", -1), nil + } else if (*token)[0] == '"' { + return nil, errors.New("expected '\"', got EOF") + } else if (*token)[0] == ':' { + return NewKeyword((*token)[1:len(*token)]) + } else if *token == "nil" { + return nil, nil + } else if *token == "true" { + return true, nil + } else if *token == "false" { + return false, nil + } else { + return Symbol{*token}, nil + } + return token, nil +} + +func read_list(rdr Reader, start string, end string) (MalType, error) { + token := rdr.next() + if token == nil { + return nil, errors.New("read_list underflow") + } + if *token != start { + return nil, errors.New("expected '" + start + "'") + } + + ast_list := []MalType{} + token = rdr.peek() + for ; true; token = rdr.peek() { + if token == nil { + return nil, errors.New("exepected '" + end + "', got EOF") + } + if *token == end { + break + } + f, e := read_form(rdr) + if e != nil { + return nil, e + } + ast_list = append(ast_list, f) + } + rdr.next() + return List{ast_list, nil}, nil +} + +func read_vector(rdr Reader) (MalType, error) { + lst, e := read_list(rdr, "[", "]") + if e != nil { + return nil, e + } + vec := Vector{lst.(List).Val, nil} + return vec, nil +} + +func read_hash_map(rdr Reader) (MalType, error) { + mal_lst, e := read_list(rdr, "{", "}") + if e != nil { + return nil, e + } + return NewHashMap(mal_lst) +} + +func read_form(rdr Reader) (MalType, error) { + token := rdr.peek() + if token == nil { + return nil, errors.New("read_form underflow") + } + switch *token { + + case `'`: + rdr.next() + form, e := read_form(rdr) + if e != nil { + return nil, e + } + return List{[]MalType{Symbol{"quote"}, form}, nil}, nil + case "`": + rdr.next() + form, e := read_form(rdr) + if e != nil { + return nil, e + } + return List{[]MalType{Symbol{"quasiquote"}, form}, nil}, nil + case `~`: + rdr.next() + form, e := read_form(rdr) + if e != nil { + return nil, e + } + return List{[]MalType{Symbol{"unquote"}, form}, nil}, nil + case `~@`: + rdr.next() + form, e := read_form(rdr) + if e != nil { + return nil, e + } + return List{[]MalType{Symbol{"splice-unquote"}, form}, nil}, nil + case `^`: + rdr.next() + meta, e := read_form(rdr) + if e != nil { + return nil, e + } + form, e := read_form(rdr) + if e != nil { + return nil, e + } + return List{[]MalType{Symbol{"with-meta"}, form, meta}, nil}, nil + case `@`: + rdr.next() + form, e := read_form(rdr) + if e != nil { + return nil, e + } + return List{[]MalType{Symbol{"deref"}, form}, nil}, nil + + // list + case ")": + return nil, errors.New("unexpected ')'") + case "(": + return read_list(rdr, "(", ")") + + // vector + case "]": + return nil, errors.New("unexpected ']'") + case "[": + return read_vector(rdr) + + // hash-map + case "}": + return nil, errors.New("unexpected '}'") + case "{": + return read_hash_map(rdr) + default: + return read_atom(rdr) + } + return read_atom(rdr) +} + +func Read_str(str string) (MalType, error) { + var tokens = tokenize(str) + if len(tokens) == 0 { + return nil, errors.New("") + } + + return read_form(&TokenReader{tokens: tokens, position: 0}) +} diff --git a/impls/go/src/readline/readline.go b/impls/go/src/readline/readline.go index 31c1fbb37a..d457065985 100644 --- a/impls/go/src/readline/readline.go +++ b/impls/go/src/readline/readline.go @@ -1,79 +1,79 @@ -package readline - -/* -// IMPORTANT: choose one -#cgo LDFLAGS: -ledit -//#cgo LDFLAGS: -lreadline // NOTE: libreadline is GPL - -// free() -#include -// readline() -#include // FILE * -#include -// add_history() -#include -*/ -import "C" - -import ( - "errors" - "fmt" - "io/ioutil" - "os" - "path/filepath" - "strings" - "unsafe" -) - -var HISTORY_FILE = ".mal-history" -var history_path string - -func loadHistory(filename string) error { - content, err := ioutil.ReadFile(history_path) - if err != nil { - return err - } - - for _, add_line := range strings.Split(string(content), "\n") { - if add_line == "" { - continue - } - c_add_line := C.CString(add_line) - C.add_history(c_add_line) - C.free(unsafe.Pointer(c_add_line)) - } - - return nil -} - -func init() { - history_path = filepath.Join(os.Getenv("HOME"), HISTORY_FILE) - loadHistory(history_path) -} - -func Readline(prompt string) (string, error) { - c_prompt := C.CString(prompt) - defer C.free(unsafe.Pointer(c_prompt)) - - c_line := C.readline(c_prompt) - defer C.free(unsafe.Pointer(c_line)) - line := C.GoString(c_line) - - if c_line == nil { - return "", errors.New("C.readline call failed") - } - C.add_history(c_line) - - // append to file - f, e := os.OpenFile(history_path, os.O_APPEND|os.O_WRONLY, 0600) - if e == nil { - defer f.Close() - - _, e = f.WriteString(line + "\n") - if e != nil { - fmt.Printf("error writing to history") - } - } - - return line, nil -} +package readline + +/* +// IMPORTANT: choose one +#cgo LDFLAGS: -ledit +//#cgo LDFLAGS: -lreadline // NOTE: libreadline is GPL + +// free() +#include +// readline() +#include // FILE * +#include +// add_history() +#include +*/ +import "C" + +import ( + "errors" + "fmt" + "io/ioutil" + "os" + "path/filepath" + "strings" + "unsafe" +) + +var HISTORY_FILE = ".mal-history" +var history_path string + +func loadHistory(filename string) error { + content, err := ioutil.ReadFile(history_path) + if err != nil { + return err + } + + for _, add_line := range strings.Split(string(content), "\n") { + if add_line == "" { + continue + } + c_add_line := C.CString(add_line) + C.add_history(c_add_line) + C.free(unsafe.Pointer(c_add_line)) + } + + return nil +} + +func init() { + history_path = filepath.Join(os.Getenv("HOME"), HISTORY_FILE) + loadHistory(history_path) +} + +func Readline(prompt string) (string, error) { + c_prompt := C.CString(prompt) + defer C.free(unsafe.Pointer(c_prompt)) + + c_line := C.readline(c_prompt) + defer C.free(unsafe.Pointer(c_line)) + line := C.GoString(c_line) + + if c_line == nil { + return "", errors.New("C.readline call failed") + } + C.add_history(c_line) + + // append to file + f, e := os.OpenFile(history_path, os.O_APPEND|os.O_WRONLY, 0600) + if e == nil { + defer f.Close() + + _, e = f.WriteString(line + "\n") + if e != nil { + fmt.Printf("error writing to history") + } + } + + return line, nil +} diff --git a/impls/go/src/step0_repl/step0_repl.go b/impls/go/src/step0_repl/step0_repl.go index 644a087f3f..cffc8b8013 100644 --- a/impls/go/src/step0_repl/step0_repl.go +++ b/impls/go/src/step0_repl/step0_repl.go @@ -1,42 +1,42 @@ -package main - -import ( - "fmt" - "strings" -) - -import ( - "readline" -) - -// read -func READ(str string) string { - return str -} - -// eval -func EVAL(ast string, env string) string { - return ast -} - -// print -func PRINT(exp string) string { - return exp -} - -// repl -func rep(str string) string { - return PRINT(EVAL(READ(str), "")) -} - -func main() { - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - fmt.Println(rep(text)) - } -} +package main + +import ( + "fmt" + "strings" +) + +import ( + "readline" +) + +// read +func READ(str string) string { + return str +} + +// eval +func EVAL(ast string, env string) string { + return ast +} + +// print +func PRINT(exp string) string { + return exp +} + +// repl +func rep(str string) string { + return PRINT(EVAL(READ(str), "")) +} + +func main() { + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + fmt.Println(rep(text)) + } +} diff --git a/impls/go/src/step1_read_print/step1_read_print.go b/impls/go/src/step1_read_print/step1_read_print.go index f4c4115a7c..11349a249d 100644 --- a/impls/go/src/step1_read_print/step1_read_print.go +++ b/impls/go/src/step1_read_print/step1_read_print.go @@ -1,66 +1,66 @@ -package main - -import ( - "fmt" - "strings" -) - -import ( - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func EVAL(ast MalType, env string) (MalType, error) { - return ast, nil -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, ""); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} +package main + +import ( + "fmt" + "strings" +) + +import ( + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func EVAL(ast MalType, env string) (MalType, error) { + return ast, nil +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, ""); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} diff --git a/impls/go/src/step2_eval/step2_eval.go b/impls/go/src/step2_eval/step2_eval.go index f73edac623..ccec1f93a7 100644 --- a/impls/go/src/step2_eval/step2_eval.go +++ b/impls/go/src/step2_eval/step2_eval.go @@ -1,166 +1,166 @@ -package main - -import ( - "errors" - "fmt" - "strings" -) - -import ( - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func eval_ast(ast MalType, env map[string]MalType) (MalType, error) { - //fmt.Printf("eval_ast: %#v\n", ast) - if Symbol_Q(ast) { - k := ast.(Symbol).Val - exp, ok := env[k] - if !ok { - return nil, errors.New("'" + k + "' not found") - } - return exp, nil - } else if List_Q(ast) { - lst := []MalType{} - for _, a := range ast.(List).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return List{lst, nil}, nil - } else if Vector_Q(ast) { - lst := []MalType{} - for _, a := range ast.(Vector).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return Vector{lst, nil}, nil - } else if HashMap_Q(ast) { - m := ast.(HashMap) - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range m.Val { - kv, e2 := EVAL(v, env) - if e2 != nil { - return nil, e2 - } - new_hm.Val[k] = kv - } - return new_hm, nil - } else { - return ast, nil - } -} - -func EVAL(ast MalType, env map[string]MalType) (MalType, error) { - //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) - switch ast.(type) { - case List: // continue - default: - return eval_ast(ast, env) - } - - if len(ast.(List).Val) == 0 { - return ast, nil - } - - // apply list - el, e := eval_ast(ast, env) - if e != nil { - return nil, e - } - f, ok := el.(List).Val[0].(func([]MalType) (MalType, error)) - if !ok { - return nil, errors.New("attempt to call non-function") - } - return f(el.(List).Val[1:]) -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -var repl_env = map[string]MalType{ - "+": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) + a[1].(int), nil - }, - "-": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) - a[1].(int), nil - }, - "*": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) * a[1].(int), nil - }, - "/": func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) / a[1].(int), nil - }, -} - -func assertArgNum(a []MalType, n int) error { - if len(a) != n { - return errors.New("wrong number of arguments") - } - return nil -} - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, repl_env); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} +package main + +import ( + "errors" + "fmt" + "strings" +) + +import ( + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func eval_ast(ast MalType, env map[string]MalType) (MalType, error) { + //fmt.Printf("eval_ast: %#v\n", ast) + if Symbol_Q(ast) { + k := ast.(Symbol).Val + exp, ok := env[k] + if !ok { + return nil, errors.New("'" + k + "' not found") + } + return exp, nil + } else if List_Q(ast) { + lst := []MalType{} + for _, a := range ast.(List).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return List{lst, nil}, nil + } else if Vector_Q(ast) { + lst := []MalType{} + for _, a := range ast.(Vector).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return Vector{lst, nil}, nil + } else if HashMap_Q(ast) { + m := ast.(HashMap) + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range m.Val { + kv, e2 := EVAL(v, env) + if e2 != nil { + return nil, e2 + } + new_hm.Val[k] = kv + } + return new_hm, nil + } else { + return ast, nil + } +} + +func EVAL(ast MalType, env map[string]MalType) (MalType, error) { + //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) + switch ast.(type) { + case List: // continue + default: + return eval_ast(ast, env) + } + + if len(ast.(List).Val) == 0 { + return ast, nil + } + + // apply list + el, e := eval_ast(ast, env) + if e != nil { + return nil, e + } + f, ok := el.(List).Val[0].(func([]MalType) (MalType, error)) + if !ok { + return nil, errors.New("attempt to call non-function") + } + return f(el.(List).Val[1:]) +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +var repl_env = map[string]MalType{ + "+": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } + return a[0].(int) + a[1].(int), nil + }, + "-": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } + return a[0].(int) - a[1].(int), nil + }, + "*": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } + return a[0].(int) * a[1].(int), nil + }, + "/": func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } + return a[0].(int) / a[1].(int), nil + }, +} + +func assertArgNum(a []MalType, n int) error { + if len(a) != n { + return errors.New("wrong number of arguments") + } + return nil +} + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, repl_env); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} diff --git a/impls/go/src/step3_env/step3_env.go b/impls/go/src/step3_env/step3_env.go index bd3cd783f4..8fc2b05686 100644 --- a/impls/go/src/step3_env/step3_env.go +++ b/impls/go/src/step3_env/step3_env.go @@ -1,209 +1,209 @@ -package main - -import ( - "errors" - "fmt" - "strings" -) - -import ( - . "env" - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func eval_ast(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("eval_ast: %#v\n", ast) - if Symbol_Q(ast) { - return env.Get(ast.(Symbol)) - } else if List_Q(ast) { - lst := []MalType{} - for _, a := range ast.(List).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return List{lst, nil}, nil - } else if Vector_Q(ast) { - lst := []MalType{} - for _, a := range ast.(Vector).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return Vector{lst, nil}, nil - } else if HashMap_Q(ast) { - m := ast.(HashMap) - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range m.Val { - kv, e2 := EVAL(v, env) - if e2 != nil { - return nil, e2 - } - new_hm.Val[k] = kv - } - return new_hm, nil - } else { - return ast, nil - } -} - -func EVAL(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) - switch ast.(type) { - case List: // continue - default: - return eval_ast(ast, env) - } - - if len(ast.(List).Val) == 0 { - return ast, nil - } - - // apply list - a0 := ast.(List).Val[0] - var a1 MalType = nil - var a2 MalType = nil - switch len(ast.(List).Val) { - case 1: - a1 = nil - a2 = nil - case 2: - a1 = ast.(List).Val[1] - a2 = nil - default: - a1 = ast.(List).Val[1] - a2 = ast.(List).Val[2] - } - a0sym := "__<*fn*>__" - if Symbol_Q(a0) { - a0sym = a0.(Symbol).Val - } - switch a0sym { - case "def!": - res, e := EVAL(a2, env) - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), res), nil - case "let*": - let_env, e := NewEnv(env, nil, nil) - if e != nil { - return nil, e - } - arr1, e := GetSlice(a1) - if e != nil { - return nil, e - } - for i := 0; i < len(arr1); i += 2 { - if !Symbol_Q(arr1[i]) { - return nil, errors.New("non-symbol bind value") - } - exp, e := EVAL(arr1[i+1], let_env) - if e != nil { - return nil, e - } - let_env.Set(arr1[i].(Symbol), exp) - } - return EVAL(a2, let_env) - default: - el, e := eval_ast(ast, env) - if e != nil { - return nil, e - } - f, ok := el.(List).Val[0].(func([]MalType) (MalType, error)) - if !ok { - return nil, errors.New("attempt to call non-function") - } - return f(el.(List).Val[1:]) - } -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -var repl_env, _ = NewEnv(nil, nil, nil) - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, repl_env); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - repl_env.Set(Symbol{"+"}, func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) + a[1].(int), nil - }) - repl_env.Set(Symbol{"-"}, func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) - a[1].(int), nil - }) - repl_env.Set(Symbol{"*"}, func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) * a[1].(int), nil - }) - repl_env.Set(Symbol{"/"}, func(a []MalType) (MalType, error) { - if e := assertArgNum(a, 2); e != nil { - return nil, e - } - return a[0].(int) / a[1].(int), nil - }) - - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} - -func assertArgNum(a []MalType, n int) error { - if len(a) != n { - return errors.New("wrong number of arguments") - } - return nil -} +package main + +import ( + "errors" + "fmt" + "strings" +) + +import ( + . "env" + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func eval_ast(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("eval_ast: %#v\n", ast) + if Symbol_Q(ast) { + return env.Get(ast.(Symbol)) + } else if List_Q(ast) { + lst := []MalType{} + for _, a := range ast.(List).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return List{lst, nil}, nil + } else if Vector_Q(ast) { + lst := []MalType{} + for _, a := range ast.(Vector).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return Vector{lst, nil}, nil + } else if HashMap_Q(ast) { + m := ast.(HashMap) + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range m.Val { + kv, e2 := EVAL(v, env) + if e2 != nil { + return nil, e2 + } + new_hm.Val[k] = kv + } + return new_hm, nil + } else { + return ast, nil + } +} + +func EVAL(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) + switch ast.(type) { + case List: // continue + default: + return eval_ast(ast, env) + } + + if len(ast.(List).Val) == 0 { + return ast, nil + } + + // apply list + a0 := ast.(List).Val[0] + var a1 MalType = nil + var a2 MalType = nil + switch len(ast.(List).Val) { + case 1: + a1 = nil + a2 = nil + case 2: + a1 = ast.(List).Val[1] + a2 = nil + default: + a1 = ast.(List).Val[1] + a2 = ast.(List).Val[2] + } + a0sym := "__<*fn*>__" + if Symbol_Q(a0) { + a0sym = a0.(Symbol).Val + } + switch a0sym { + case "def!": + res, e := EVAL(a2, env) + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), res), nil + case "let*": + let_env, e := NewEnv(env, nil, nil) + if e != nil { + return nil, e + } + arr1, e := GetSlice(a1) + if e != nil { + return nil, e + } + for i := 0; i < len(arr1); i += 2 { + if !Symbol_Q(arr1[i]) { + return nil, errors.New("non-symbol bind value") + } + exp, e := EVAL(arr1[i+1], let_env) + if e != nil { + return nil, e + } + let_env.Set(arr1[i].(Symbol), exp) + } + return EVAL(a2, let_env) + default: + el, e := eval_ast(ast, env) + if e != nil { + return nil, e + } + f, ok := el.(List).Val[0].(func([]MalType) (MalType, error)) + if !ok { + return nil, errors.New("attempt to call non-function") + } + return f(el.(List).Val[1:]) + } +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +var repl_env, _ = NewEnv(nil, nil, nil) + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, repl_env); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + repl_env.Set(Symbol{"+"}, func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } + return a[0].(int) + a[1].(int), nil + }) + repl_env.Set(Symbol{"-"}, func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } + return a[0].(int) - a[1].(int), nil + }) + repl_env.Set(Symbol{"*"}, func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } + return a[0].(int) * a[1].(int), nil + }) + repl_env.Set(Symbol{"/"}, func(a []MalType) (MalType, error) { + if e := assertArgNum(a, 2); e != nil { + return nil, e + } + return a[0].(int) / a[1].(int), nil + }) + + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} + +func assertArgNum(a []MalType, n int) error { + if len(a) != n { + return errors.New("wrong number of arguments") + } + return nil +} diff --git a/impls/go/src/step4_if_fn_do/step4_if_fn_do.go b/impls/go/src/step4_if_fn_do/step4_if_fn_do.go index 4098a18fa8..4acd694881 100644 --- a/impls/go/src/step4_if_fn_do/step4_if_fn_do.go +++ b/impls/go/src/step4_if_fn_do/step4_if_fn_do.go @@ -1,218 +1,218 @@ -package main - -import ( - "errors" - "fmt" - "strings" -) - -import ( - "core" - . "env" - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func eval_ast(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("eval_ast: %#v\n", ast) - if Symbol_Q(ast) { - return env.Get(ast.(Symbol)) - } else if List_Q(ast) { - lst := []MalType{} - for _, a := range ast.(List).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return List{lst, nil}, nil - } else if Vector_Q(ast) { - lst := []MalType{} - for _, a := range ast.(Vector).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return Vector{lst, nil}, nil - } else if HashMap_Q(ast) { - m := ast.(HashMap) - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range m.Val { - kv, e2 := EVAL(v, env) - if e2 != nil { - return nil, e2 - } - new_hm.Val[k] = kv - } - return new_hm, nil - } else { - return ast, nil - } -} - -func EVAL(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) - switch ast.(type) { - case List: // continue - default: - return eval_ast(ast, env) - } - - if len(ast.(List).Val) == 0 { - return ast, nil - } - - // apply list - a0 := ast.(List).Val[0] - var a1 MalType = nil - var a2 MalType = nil - switch len(ast.(List).Val) { - case 1: - a1 = nil - a2 = nil - case 2: - a1 = ast.(List).Val[1] - a2 = nil - default: - a1 = ast.(List).Val[1] - a2 = ast.(List).Val[2] - } - a0sym := "__<*fn*>__" - if Symbol_Q(a0) { - a0sym = a0.(Symbol).Val - } - switch a0sym { - case "def!": - res, e := EVAL(a2, env) - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), res), nil - case "let*": - let_env, e := NewEnv(env, nil, nil) - if e != nil { - return nil, e - } - arr1, e := GetSlice(a1) - if e != nil { - return nil, e - } - for i := 0; i < len(arr1); i += 2 { - if !Symbol_Q(arr1[i]) { - return nil, errors.New("non-symbol bind value") - } - exp, e := EVAL(arr1[i+1], let_env) - if e != nil { - return nil, e - } - let_env.Set(arr1[i].(Symbol), exp) - } - return EVAL(a2, let_env) - case "do": - el, e := eval_ast(List{ast.(List).Val[1:], nil}, env) - if e != nil { - return nil, e - } - lst := el.(List).Val - if len(lst) == 0 { - return nil, nil - } - return lst[len(lst)-1], nil - case "if": - cond, e := EVAL(a1, env) - if e != nil { - return nil, e - } - if cond == nil || cond == false { - if len(ast.(List).Val) >= 4 { - return EVAL(ast.(List).Val[3], env) - } else { - return nil, nil - } - } else { - return EVAL(a2, env) - } - case "fn*": - return func(arguments []MalType) (MalType, error) { - new_env, e := NewEnv(env, a1, List{arguments, nil}) - if e != nil { - return nil, e - } - return EVAL(a2, new_env) - }, nil - default: - el, e := eval_ast(ast, env) - if e != nil { - return nil, e - } - f, ok := el.(List).Val[0].(func([]MalType) (MalType, error)) - if !ok { - return nil, errors.New("attempt to call non-function") - } - return f(el.(List).Val[1:]) - } -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -var repl_env, _ = NewEnv(nil, nil, nil) - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, repl_env); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - // core.go: defined using go - for k, v := range core.NS { - repl_env.Set(Symbol{k}, v) - } - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} +package main + +import ( + "errors" + "fmt" + "strings" +) + +import ( + "core" + . "env" + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func eval_ast(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("eval_ast: %#v\n", ast) + if Symbol_Q(ast) { + return env.Get(ast.(Symbol)) + } else if List_Q(ast) { + lst := []MalType{} + for _, a := range ast.(List).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return List{lst, nil}, nil + } else if Vector_Q(ast) { + lst := []MalType{} + for _, a := range ast.(Vector).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return Vector{lst, nil}, nil + } else if HashMap_Q(ast) { + m := ast.(HashMap) + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range m.Val { + kv, e2 := EVAL(v, env) + if e2 != nil { + return nil, e2 + } + new_hm.Val[k] = kv + } + return new_hm, nil + } else { + return ast, nil + } +} + +func EVAL(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) + switch ast.(type) { + case List: // continue + default: + return eval_ast(ast, env) + } + + if len(ast.(List).Val) == 0 { + return ast, nil + } + + // apply list + a0 := ast.(List).Val[0] + var a1 MalType = nil + var a2 MalType = nil + switch len(ast.(List).Val) { + case 1: + a1 = nil + a2 = nil + case 2: + a1 = ast.(List).Val[1] + a2 = nil + default: + a1 = ast.(List).Val[1] + a2 = ast.(List).Val[2] + } + a0sym := "__<*fn*>__" + if Symbol_Q(a0) { + a0sym = a0.(Symbol).Val + } + switch a0sym { + case "def!": + res, e := EVAL(a2, env) + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), res), nil + case "let*": + let_env, e := NewEnv(env, nil, nil) + if e != nil { + return nil, e + } + arr1, e := GetSlice(a1) + if e != nil { + return nil, e + } + for i := 0; i < len(arr1); i += 2 { + if !Symbol_Q(arr1[i]) { + return nil, errors.New("non-symbol bind value") + } + exp, e := EVAL(arr1[i+1], let_env) + if e != nil { + return nil, e + } + let_env.Set(arr1[i].(Symbol), exp) + } + return EVAL(a2, let_env) + case "do": + el, e := eval_ast(List{ast.(List).Val[1:], nil}, env) + if e != nil { + return nil, e + } + lst := el.(List).Val + if len(lst) == 0 { + return nil, nil + } + return lst[len(lst)-1], nil + case "if": + cond, e := EVAL(a1, env) + if e != nil { + return nil, e + } + if cond == nil || cond == false { + if len(ast.(List).Val) >= 4 { + return EVAL(ast.(List).Val[3], env) + } else { + return nil, nil + } + } else { + return EVAL(a2, env) + } + case "fn*": + return func(arguments []MalType) (MalType, error) { + new_env, e := NewEnv(env, a1, List{arguments, nil}) + if e != nil { + return nil, e + } + return EVAL(a2, new_env) + }, nil + default: + el, e := eval_ast(ast, env) + if e != nil { + return nil, e + } + f, ok := el.(List).Val[0].(func([]MalType) (MalType, error)) + if !ok { + return nil, errors.New("attempt to call non-function") + } + return f(el.(List).Val[1:]) + } +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +var repl_env, _ = NewEnv(nil, nil, nil) + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, repl_env); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + // core.go: defined using go + for k, v := range core.NS { + repl_env.Set(Symbol{k}, v) + } + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} diff --git a/impls/go/src/step5_tco/step5_tco.go b/impls/go/src/step5_tco/step5_tco.go index 841354eef1..8b6db7386d 100644 --- a/impls/go/src/step5_tco/step5_tco.go +++ b/impls/go/src/step5_tco/step5_tco.go @@ -1,228 +1,228 @@ -package main - -import ( - "errors" - "fmt" - "strings" -) - -import ( - "core" - . "env" - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func eval_ast(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("eval_ast: %#v\n", ast) - if Symbol_Q(ast) { - return env.Get(ast.(Symbol)) - } else if List_Q(ast) { - lst := []MalType{} - for _, a := range ast.(List).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return List{lst, nil}, nil - } else if Vector_Q(ast) { - lst := []MalType{} - for _, a := range ast.(Vector).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return Vector{lst, nil}, nil - } else if HashMap_Q(ast) { - m := ast.(HashMap) - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range m.Val { - kv, e2 := EVAL(v, env) - if e2 != nil { - return nil, e2 - } - new_hm.Val[k] = kv - } - return new_hm, nil - } else { - return ast, nil - } -} - -func EVAL(ast MalType, env EnvType) (MalType, error) { - for { - - //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) - switch ast.(type) { - case List: // continue - default: - return eval_ast(ast, env) - } - - if len(ast.(List).Val) == 0 { - return ast, nil - } - - // apply list - a0 := ast.(List).Val[0] - var a1 MalType = nil - var a2 MalType = nil - switch len(ast.(List).Val) { - case 1: - a1 = nil - a2 = nil - case 2: - a1 = ast.(List).Val[1] - a2 = nil - default: - a1 = ast.(List).Val[1] - a2 = ast.(List).Val[2] - } - a0sym := "__<*fn*>__" - if Symbol_Q(a0) { - a0sym = a0.(Symbol).Val - } - switch a0sym { - case "def!": - res, e := EVAL(a2, env) - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), res), nil - case "let*": - let_env, e := NewEnv(env, nil, nil) - if e != nil { - return nil, e - } - arr1, e := GetSlice(a1) - if e != nil { - return nil, e - } - for i := 0; i < len(arr1); i += 2 { - if !Symbol_Q(arr1[i]) { - return nil, errors.New("non-symbol bind value") - } - exp, e := EVAL(arr1[i+1], let_env) - if e != nil { - return nil, e - } - let_env.Set(arr1[i].(Symbol), exp) - } - ast = a2 - env = let_env - case "do": - lst := ast.(List).Val - _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) - if e != nil { - return nil, e - } - if len(lst) == 1 { - return nil, nil - } - ast = lst[len(lst)-1] - case "if": - cond, e := EVAL(a1, env) - if e != nil { - return nil, e - } - if cond == nil || cond == false { - if len(ast.(List).Val) >= 4 { - ast = ast.(List).Val[3] - } else { - return nil, nil - } - } else { - ast = a2 - } - case "fn*": - fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} - return fn, nil - default: - el, e := eval_ast(ast, env) - if e != nil { - return nil, e - } - f := el.(List).Val[0] - if MalFunc_Q(f) { - fn := f.(MalFunc) - ast = fn.Exp - env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) - if e != nil { - return nil, e - } - } else { - fn, ok := f.(Func) - if !ok { - return nil, errors.New("attempt to call non-function") - } - return fn.Fn(el.(List).Val[1:]) - } - } - - } // TCO loop -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -var repl_env, _ = NewEnv(nil, nil, nil) - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, repl_env); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - // core.go: defined using go - for k, v := range core.NS { - repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) - } - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} +package main + +import ( + "errors" + "fmt" + "strings" +) + +import ( + "core" + . "env" + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func eval_ast(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("eval_ast: %#v\n", ast) + if Symbol_Q(ast) { + return env.Get(ast.(Symbol)) + } else if List_Q(ast) { + lst := []MalType{} + for _, a := range ast.(List).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return List{lst, nil}, nil + } else if Vector_Q(ast) { + lst := []MalType{} + for _, a := range ast.(Vector).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return Vector{lst, nil}, nil + } else if HashMap_Q(ast) { + m := ast.(HashMap) + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range m.Val { + kv, e2 := EVAL(v, env) + if e2 != nil { + return nil, e2 + } + new_hm.Val[k] = kv + } + return new_hm, nil + } else { + return ast, nil + } +} + +func EVAL(ast MalType, env EnvType) (MalType, error) { + for { + + //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) + switch ast.(type) { + case List: // continue + default: + return eval_ast(ast, env) + } + + if len(ast.(List).Val) == 0 { + return ast, nil + } + + // apply list + a0 := ast.(List).Val[0] + var a1 MalType = nil + var a2 MalType = nil + switch len(ast.(List).Val) { + case 1: + a1 = nil + a2 = nil + case 2: + a1 = ast.(List).Val[1] + a2 = nil + default: + a1 = ast.(List).Val[1] + a2 = ast.(List).Val[2] + } + a0sym := "__<*fn*>__" + if Symbol_Q(a0) { + a0sym = a0.(Symbol).Val + } + switch a0sym { + case "def!": + res, e := EVAL(a2, env) + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), res), nil + case "let*": + let_env, e := NewEnv(env, nil, nil) + if e != nil { + return nil, e + } + arr1, e := GetSlice(a1) + if e != nil { + return nil, e + } + for i := 0; i < len(arr1); i += 2 { + if !Symbol_Q(arr1[i]) { + return nil, errors.New("non-symbol bind value") + } + exp, e := EVAL(arr1[i+1], let_env) + if e != nil { + return nil, e + } + let_env.Set(arr1[i].(Symbol), exp) + } + ast = a2 + env = let_env + case "do": + lst := ast.(List).Val + _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) + if e != nil { + return nil, e + } + if len(lst) == 1 { + return nil, nil + } + ast = lst[len(lst)-1] + case "if": + cond, e := EVAL(a1, env) + if e != nil { + return nil, e + } + if cond == nil || cond == false { + if len(ast.(List).Val) >= 4 { + ast = ast.(List).Val[3] + } else { + return nil, nil + } + } else { + ast = a2 + } + case "fn*": + fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} + return fn, nil + default: + el, e := eval_ast(ast, env) + if e != nil { + return nil, e + } + f := el.(List).Val[0] + if MalFunc_Q(f) { + fn := f.(MalFunc) + ast = fn.Exp + env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) + if e != nil { + return nil, e + } + } else { + fn, ok := f.(Func) + if !ok { + return nil, errors.New("attempt to call non-function") + } + return fn.Fn(el.(List).Val[1:]) + } + } + + } // TCO loop +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +var repl_env, _ = NewEnv(nil, nil, nil) + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, repl_env); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + // core.go: defined using go + for k, v := range core.NS { + repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) + } + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} diff --git a/impls/go/src/step6_file/step6_file.go b/impls/go/src/step6_file/step6_file.go index 5329b90f06..daab0f539a 100644 --- a/impls/go/src/step6_file/step6_file.go +++ b/impls/go/src/step6_file/step6_file.go @@ -1,248 +1,248 @@ -package main - -import ( - "errors" - "fmt" - "os" - "strings" -) - -import ( - "core" - . "env" - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func eval_ast(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("eval_ast: %#v\n", ast) - if Symbol_Q(ast) { - return env.Get(ast.(Symbol)) - } else if List_Q(ast) { - lst := []MalType{} - for _, a := range ast.(List).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return List{lst, nil}, nil - } else if Vector_Q(ast) { - lst := []MalType{} - for _, a := range ast.(Vector).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return Vector{lst, nil}, nil - } else if HashMap_Q(ast) { - m := ast.(HashMap) - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range m.Val { - kv, e2 := EVAL(v, env) - if e2 != nil { - return nil, e2 - } - new_hm.Val[k] = kv - } - return new_hm, nil - } else { - return ast, nil - } -} - -func EVAL(ast MalType, env EnvType) (MalType, error) { - for { - - //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) - switch ast.(type) { - case List: // continue - default: - return eval_ast(ast, env) - } - - if len(ast.(List).Val) == 0 { - return ast, nil - } - - // apply list - a0 := ast.(List).Val[0] - var a1 MalType = nil - var a2 MalType = nil - switch len(ast.(List).Val) { - case 1: - a1 = nil - a2 = nil - case 2: - a1 = ast.(List).Val[1] - a2 = nil - default: - a1 = ast.(List).Val[1] - a2 = ast.(List).Val[2] - } - a0sym := "__<*fn*>__" - if Symbol_Q(a0) { - a0sym = a0.(Symbol).Val - } - switch a0sym { - case "def!": - res, e := EVAL(a2, env) - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), res), nil - case "let*": - let_env, e := NewEnv(env, nil, nil) - if e != nil { - return nil, e - } - arr1, e := GetSlice(a1) - if e != nil { - return nil, e - } - for i := 0; i < len(arr1); i += 2 { - if !Symbol_Q(arr1[i]) { - return nil, errors.New("non-symbol bind value") - } - exp, e := EVAL(arr1[i+1], let_env) - if e != nil { - return nil, e - } - let_env.Set(arr1[i].(Symbol), exp) - } - ast = a2 - env = let_env - case "do": - lst := ast.(List).Val - _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) - if e != nil { - return nil, e - } - if len(lst) == 1 { - return nil, nil - } - ast = lst[len(lst)-1] - case "if": - cond, e := EVAL(a1, env) - if e != nil { - return nil, e - } - if cond == nil || cond == false { - if len(ast.(List).Val) >= 4 { - ast = ast.(List).Val[3] - } else { - return nil, nil - } - } else { - ast = a2 - } - case "fn*": - fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} - return fn, nil - default: - el, e := eval_ast(ast, env) - if e != nil { - return nil, e - } - f := el.(List).Val[0] - if MalFunc_Q(f) { - fn := f.(MalFunc) - ast = fn.Exp - env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) - if e != nil { - return nil, e - } - } else { - fn, ok := f.(Func) - if !ok { - return nil, errors.New("attempt to call non-function") - } - return fn.Fn(el.(List).Val[1:]) - } - } - - } // TCO loop -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -var repl_env, _ = NewEnv(nil, nil, nil) - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, repl_env); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - // core.go: defined using go - for k, v := range core.NS { - repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) - } - repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { - return EVAL(a[0], repl_env) - }, nil}) - repl_env.Set(Symbol{"*ARGV*"}, List{}) - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - - // called with mal script to load and eval - if len(os.Args) > 1 { - args := make([]MalType, 0, len(os.Args)-2) - for _, a := range os.Args[2:] { - args = append(args, a) - } - repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) - if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { - fmt.Printf("Error: %v\n", e) - os.Exit(1) - } - os.Exit(0) - } - - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} +package main + +import ( + "errors" + "fmt" + "os" + "strings" +) + +import ( + "core" + . "env" + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func eval_ast(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("eval_ast: %#v\n", ast) + if Symbol_Q(ast) { + return env.Get(ast.(Symbol)) + } else if List_Q(ast) { + lst := []MalType{} + for _, a := range ast.(List).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return List{lst, nil}, nil + } else if Vector_Q(ast) { + lst := []MalType{} + for _, a := range ast.(Vector).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return Vector{lst, nil}, nil + } else if HashMap_Q(ast) { + m := ast.(HashMap) + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range m.Val { + kv, e2 := EVAL(v, env) + if e2 != nil { + return nil, e2 + } + new_hm.Val[k] = kv + } + return new_hm, nil + } else { + return ast, nil + } +} + +func EVAL(ast MalType, env EnvType) (MalType, error) { + for { + + //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) + switch ast.(type) { + case List: // continue + default: + return eval_ast(ast, env) + } + + if len(ast.(List).Val) == 0 { + return ast, nil + } + + // apply list + a0 := ast.(List).Val[0] + var a1 MalType = nil + var a2 MalType = nil + switch len(ast.(List).Val) { + case 1: + a1 = nil + a2 = nil + case 2: + a1 = ast.(List).Val[1] + a2 = nil + default: + a1 = ast.(List).Val[1] + a2 = ast.(List).Val[2] + } + a0sym := "__<*fn*>__" + if Symbol_Q(a0) { + a0sym = a0.(Symbol).Val + } + switch a0sym { + case "def!": + res, e := EVAL(a2, env) + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), res), nil + case "let*": + let_env, e := NewEnv(env, nil, nil) + if e != nil { + return nil, e + } + arr1, e := GetSlice(a1) + if e != nil { + return nil, e + } + for i := 0; i < len(arr1); i += 2 { + if !Symbol_Q(arr1[i]) { + return nil, errors.New("non-symbol bind value") + } + exp, e := EVAL(arr1[i+1], let_env) + if e != nil { + return nil, e + } + let_env.Set(arr1[i].(Symbol), exp) + } + ast = a2 + env = let_env + case "do": + lst := ast.(List).Val + _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) + if e != nil { + return nil, e + } + if len(lst) == 1 { + return nil, nil + } + ast = lst[len(lst)-1] + case "if": + cond, e := EVAL(a1, env) + if e != nil { + return nil, e + } + if cond == nil || cond == false { + if len(ast.(List).Val) >= 4 { + ast = ast.(List).Val[3] + } else { + return nil, nil + } + } else { + ast = a2 + } + case "fn*": + fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} + return fn, nil + default: + el, e := eval_ast(ast, env) + if e != nil { + return nil, e + } + f := el.(List).Val[0] + if MalFunc_Q(f) { + fn := f.(MalFunc) + ast = fn.Exp + env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) + if e != nil { + return nil, e + } + } else { + fn, ok := f.(Func) + if !ok { + return nil, errors.New("attempt to call non-function") + } + return fn.Fn(el.(List).Val[1:]) + } + } + + } // TCO loop +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +var repl_env, _ = NewEnv(nil, nil, nil) + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, repl_env); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + // core.go: defined using go + for k, v := range core.NS { + repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) + } + repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { + return EVAL(a[0], repl_env) + }, nil}) + repl_env.Set(Symbol{"*ARGV*"}, List{}) + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + + // called with mal script to load and eval + if len(os.Args) > 1 { + args := make([]MalType, 0, len(os.Args)-2) + for _, a := range os.Args[2:] { + args = append(args, a) + } + repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) + if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { + fmt.Printf("Error: %v\n", e) + os.Exit(1) + } + os.Exit(0) + } + + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} diff --git a/impls/go/src/step7_quote/step7_quote.go b/impls/go/src/step7_quote/step7_quote.go index 78356b2ce5..ef8f01a75a 100644 --- a/impls/go/src/step7_quote/step7_quote.go +++ b/impls/go/src/step7_quote/step7_quote.go @@ -1,299 +1,299 @@ -package main - -import ( - "errors" - "fmt" - "os" - "strings" -) - -import ( - "core" - . "env" - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func starts_with(xs []MalType, sym string) bool { - if 0 < len(xs) { - switch s := xs[0].(type) { - case Symbol: - return s.Val == sym - default: - } - } - return false -} - -func qq_loop(xs []MalType) MalType { - acc := NewList() - for i := len(xs) - 1; 0<=i; i -= 1 { - elt := xs[i] - switch e := elt.(type) { - case List: - if starts_with(e.Val, "splice-unquote") { - acc = NewList(Symbol{"concat"}, e.Val[1], acc) - continue - } - default: - } - acc = NewList(Symbol{"cons"}, quasiquote(elt), acc) - } - return acc -} - -func quasiquote(ast MalType) MalType { - switch a := ast.(type) { - case Vector: - return NewList(Symbol{"vec"}, qq_loop(a.Val)) - case HashMap, Symbol: - return NewList(Symbol{"quote"}, ast) - case List: - if starts_with(a.Val,"unquote") { - return a.Val[1] - } else { - return qq_loop(a.Val) - } - default: - return ast - } -} - -func eval_ast(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("eval_ast: %#v\n", ast) - if Symbol_Q(ast) { - return env.Get(ast.(Symbol)) - } else if List_Q(ast) { - lst := []MalType{} - for _, a := range ast.(List).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return List{lst, nil}, nil - } else if Vector_Q(ast) { - lst := []MalType{} - for _, a := range ast.(Vector).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return Vector{lst, nil}, nil - } else if HashMap_Q(ast) { - m := ast.(HashMap) - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range m.Val { - kv, e2 := EVAL(v, env) - if e2 != nil { - return nil, e2 - } - new_hm.Val[k] = kv - } - return new_hm, nil - } else { - return ast, nil - } -} - -func EVAL(ast MalType, env EnvType) (MalType, error) { - for { - - //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) - switch ast.(type) { - case List: // continue - default: - return eval_ast(ast, env) - } - - if len(ast.(List).Val) == 0 { - return ast, nil - } - - // apply list - a0 := ast.(List).Val[0] - var a1 MalType = nil - var a2 MalType = nil - switch len(ast.(List).Val) { - case 1: - a1 = nil - a2 = nil - case 2: - a1 = ast.(List).Val[1] - a2 = nil - default: - a1 = ast.(List).Val[1] - a2 = ast.(List).Val[2] - } - a0sym := "__<*fn*>__" - if Symbol_Q(a0) { - a0sym = a0.(Symbol).Val - } - switch a0sym { - case "def!": - res, e := EVAL(a2, env) - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), res), nil - case "let*": - let_env, e := NewEnv(env, nil, nil) - if e != nil { - return nil, e - } - arr1, e := GetSlice(a1) - if e != nil { - return nil, e - } - for i := 0; i < len(arr1); i += 2 { - if !Symbol_Q(arr1[i]) { - return nil, errors.New("non-symbol bind value") - } - exp, e := EVAL(arr1[i+1], let_env) - if e != nil { - return nil, e - } - let_env.Set(arr1[i].(Symbol), exp) - } - ast = a2 - env = let_env - case "quote": - return a1, nil - case "quasiquoteexpand": - return quasiquote(a1), nil - case "quasiquote": - ast = quasiquote(a1) - case "do": - lst := ast.(List).Val - _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) - if e != nil { - return nil, e - } - if len(lst) == 1 { - return nil, nil - } - ast = lst[len(lst)-1] - case "if": - cond, e := EVAL(a1, env) - if e != nil { - return nil, e - } - if cond == nil || cond == false { - if len(ast.(List).Val) >= 4 { - ast = ast.(List).Val[3] - } else { - return nil, nil - } - } else { - ast = a2 - } - case "fn*": - fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} - return fn, nil - default: - el, e := eval_ast(ast, env) - if e != nil { - return nil, e - } - f := el.(List).Val[0] - if MalFunc_Q(f) { - fn := f.(MalFunc) - ast = fn.Exp - env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) - if e != nil { - return nil, e - } - } else { - fn, ok := f.(Func) - if !ok { - return nil, errors.New("attempt to call non-function") - } - return fn.Fn(el.(List).Val[1:]) - } - } - - } // TCO loop -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -var repl_env, _ = NewEnv(nil, nil, nil) - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, repl_env); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - // core.go: defined using go - for k, v := range core.NS { - repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) - } - repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { - return EVAL(a[0], repl_env) - }, nil}) - repl_env.Set(Symbol{"*ARGV*"}, List{}) - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - - // called with mal script to load and eval - if len(os.Args) > 1 { - args := make([]MalType, 0, len(os.Args)-2) - for _, a := range os.Args[2:] { - args = append(args, a) - } - repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) - if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { - fmt.Printf("Error: %v\n", e) - os.Exit(1) - } - os.Exit(0) - } - - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} +package main + +import ( + "errors" + "fmt" + "os" + "strings" +) + +import ( + "core" + . "env" + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func starts_with(xs []MalType, sym string) bool { + if 0 < len(xs) { + switch s := xs[0].(type) { + case Symbol: + return s.Val == sym + default: + } + } + return false +} + +func qq_loop(xs []MalType) MalType { + acc := NewList() + for i := len(xs) - 1; 0<=i; i -= 1 { + elt := xs[i] + switch e := elt.(type) { + case List: + if starts_with(e.Val, "splice-unquote") { + acc = NewList(Symbol{"concat"}, e.Val[1], acc) + continue + } + default: + } + acc = NewList(Symbol{"cons"}, quasiquote(elt), acc) + } + return acc +} + +func quasiquote(ast MalType) MalType { + switch a := ast.(type) { + case Vector: + return NewList(Symbol{"vec"}, qq_loop(a.Val)) + case HashMap, Symbol: + return NewList(Symbol{"quote"}, ast) + case List: + if starts_with(a.Val,"unquote") { + return a.Val[1] + } else { + return qq_loop(a.Val) + } + default: + return ast + } +} + +func eval_ast(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("eval_ast: %#v\n", ast) + if Symbol_Q(ast) { + return env.Get(ast.(Symbol)) + } else if List_Q(ast) { + lst := []MalType{} + for _, a := range ast.(List).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return List{lst, nil}, nil + } else if Vector_Q(ast) { + lst := []MalType{} + for _, a := range ast.(Vector).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return Vector{lst, nil}, nil + } else if HashMap_Q(ast) { + m := ast.(HashMap) + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range m.Val { + kv, e2 := EVAL(v, env) + if e2 != nil { + return nil, e2 + } + new_hm.Val[k] = kv + } + return new_hm, nil + } else { + return ast, nil + } +} + +func EVAL(ast MalType, env EnvType) (MalType, error) { + for { + + //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) + switch ast.(type) { + case List: // continue + default: + return eval_ast(ast, env) + } + + if len(ast.(List).Val) == 0 { + return ast, nil + } + + // apply list + a0 := ast.(List).Val[0] + var a1 MalType = nil + var a2 MalType = nil + switch len(ast.(List).Val) { + case 1: + a1 = nil + a2 = nil + case 2: + a1 = ast.(List).Val[1] + a2 = nil + default: + a1 = ast.(List).Val[1] + a2 = ast.(List).Val[2] + } + a0sym := "__<*fn*>__" + if Symbol_Q(a0) { + a0sym = a0.(Symbol).Val + } + switch a0sym { + case "def!": + res, e := EVAL(a2, env) + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), res), nil + case "let*": + let_env, e := NewEnv(env, nil, nil) + if e != nil { + return nil, e + } + arr1, e := GetSlice(a1) + if e != nil { + return nil, e + } + for i := 0; i < len(arr1); i += 2 { + if !Symbol_Q(arr1[i]) { + return nil, errors.New("non-symbol bind value") + } + exp, e := EVAL(arr1[i+1], let_env) + if e != nil { + return nil, e + } + let_env.Set(arr1[i].(Symbol), exp) + } + ast = a2 + env = let_env + case "quote": + return a1, nil + case "quasiquoteexpand": + return quasiquote(a1), nil + case "quasiquote": + ast = quasiquote(a1) + case "do": + lst := ast.(List).Val + _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) + if e != nil { + return nil, e + } + if len(lst) == 1 { + return nil, nil + } + ast = lst[len(lst)-1] + case "if": + cond, e := EVAL(a1, env) + if e != nil { + return nil, e + } + if cond == nil || cond == false { + if len(ast.(List).Val) >= 4 { + ast = ast.(List).Val[3] + } else { + return nil, nil + } + } else { + ast = a2 + } + case "fn*": + fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} + return fn, nil + default: + el, e := eval_ast(ast, env) + if e != nil { + return nil, e + } + f := el.(List).Val[0] + if MalFunc_Q(f) { + fn := f.(MalFunc) + ast = fn.Exp + env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) + if e != nil { + return nil, e + } + } else { + fn, ok := f.(Func) + if !ok { + return nil, errors.New("attempt to call non-function") + } + return fn.Fn(el.(List).Val[1:]) + } + } + + } // TCO loop +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +var repl_env, _ = NewEnv(nil, nil, nil) + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, repl_env); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + // core.go: defined using go + for k, v := range core.NS { + repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) + } + repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { + return EVAL(a[0], repl_env) + }, nil}) + repl_env.Set(Symbol{"*ARGV*"}, List{}) + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + + // called with mal script to load and eval + if len(os.Args) > 1 { + args := make([]MalType, 0, len(os.Args)-2) + for _, a := range os.Args[2:] { + args = append(args, a) + } + repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) + if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { + fmt.Printf("Error: %v\n", e) + os.Exit(1) + } + os.Exit(0) + } + + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} diff --git a/impls/go/src/step8_macros/step8_macros.go b/impls/go/src/step8_macros/step8_macros.go index 63af7f71a2..33cb8d5518 100644 --- a/impls/go/src/step8_macros/step8_macros.go +++ b/impls/go/src/step8_macros/step8_macros.go @@ -1,356 +1,356 @@ -package main - -import ( - "errors" - "fmt" - "os" - "strings" -) - -import ( - "core" - . "env" - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func starts_with(xs []MalType, sym string) bool { - if 0 < len(xs) { - switch s := xs[0].(type) { - case Symbol: - return s.Val == sym - default: - } - } - return false -} - -func qq_loop(xs []MalType) MalType { - acc := NewList() - for i := len(xs) - 1; 0<=i; i -= 1 { - elt := xs[i] - switch e := elt.(type) { - case List: - if starts_with(e.Val, "splice-unquote") { - acc = NewList(Symbol{"concat"}, e.Val[1], acc) - continue - } - default: - } - acc = NewList(Symbol{"cons"}, quasiquote(elt), acc) - } - return acc -} - -func quasiquote(ast MalType) MalType { - switch a := ast.(type) { - case Vector: - return NewList(Symbol{"vec"}, qq_loop(a.Val)) - case HashMap, Symbol: - return NewList(Symbol{"quote"}, ast) - case List: - if starts_with(a.Val,"unquote") { - return a.Val[1] - } else { - return qq_loop(a.Val) - } - default: - return ast - } -} - -func is_macro_call(ast MalType, env EnvType) bool { - if List_Q(ast) { - slc, _ := GetSlice(ast) - if len(slc) == 0 { - return false - } - a0 := slc[0] - if Symbol_Q(a0) && env.Find(a0.(Symbol)) != nil { - mac, e := env.Get(a0.(Symbol)) - if e != nil { - return false - } - if MalFunc_Q(mac) { - return mac.(MalFunc).GetMacro() - } - } - } - return false -} - -func macroexpand(ast MalType, env EnvType) (MalType, error) { - var mac MalType - var e error - for is_macro_call(ast, env) { - slc, _ := GetSlice(ast) - a0 := slc[0] - mac, e = env.Get(a0.(Symbol)) - if e != nil { - return nil, e - } - fn := mac.(MalFunc) - ast, e = Apply(fn, slc[1:]) - if e != nil { - return nil, e - } - } - return ast, nil -} - -func eval_ast(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("eval_ast: %#v\n", ast) - if Symbol_Q(ast) { - return env.Get(ast.(Symbol)) - } else if List_Q(ast) { - lst := []MalType{} - for _, a := range ast.(List).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return List{lst, nil}, nil - } else if Vector_Q(ast) { - lst := []MalType{} - for _, a := range ast.(Vector).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return Vector{lst, nil}, nil - } else if HashMap_Q(ast) { - m := ast.(HashMap) - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range m.Val { - kv, e2 := EVAL(v, env) - if e2 != nil { - return nil, e2 - } - new_hm.Val[k] = kv - } - return new_hm, nil - } else { - return ast, nil - } -} - -func EVAL(ast MalType, env EnvType) (MalType, error) { - var e error - for { - - //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) - switch ast.(type) { - case List: // continue - default: - return eval_ast(ast, env) - } - - // apply list - ast, e = macroexpand(ast, env) - if e != nil { - return nil, e - } - if !List_Q(ast) { - return eval_ast(ast, env) - } - if len(ast.(List).Val) == 0 { - return ast, nil - } - - a0 := ast.(List).Val[0] - var a1 MalType = nil - var a2 MalType = nil - switch len(ast.(List).Val) { - case 1: - a1 = nil - a2 = nil - case 2: - a1 = ast.(List).Val[1] - a2 = nil - default: - a1 = ast.(List).Val[1] - a2 = ast.(List).Val[2] - } - a0sym := "__<*fn*>__" - if Symbol_Q(a0) { - a0sym = a0.(Symbol).Val - } - switch a0sym { - case "def!": - res, e := EVAL(a2, env) - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), res), nil - case "let*": - let_env, e := NewEnv(env, nil, nil) - if e != nil { - return nil, e - } - arr1, e := GetSlice(a1) - if e != nil { - return nil, e - } - for i := 0; i < len(arr1); i += 2 { - if !Symbol_Q(arr1[i]) { - return nil, errors.New("non-symbol bind value") - } - exp, e := EVAL(arr1[i+1], let_env) - if e != nil { - return nil, e - } - let_env.Set(arr1[i].(Symbol), exp) - } - ast = a2 - env = let_env - case "quote": - return a1, nil - case "quasiquoteexpand": - return quasiquote(a1), nil - case "quasiquote": - ast = quasiquote(a1) - case "defmacro!": - fn, e := EVAL(a2, env) - fn = fn.(MalFunc).SetMacro() - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), fn), nil - case "macroexpand": - return macroexpand(a1, env) - case "do": - lst := ast.(List).Val - _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) - if e != nil { - return nil, e - } - if len(lst) == 1 { - return nil, nil - } - ast = lst[len(lst)-1] - case "if": - cond, e := EVAL(a1, env) - if e != nil { - return nil, e - } - if cond == nil || cond == false { - if len(ast.(List).Val) >= 4 { - ast = ast.(List).Val[3] - } else { - return nil, nil - } - } else { - ast = a2 - } - case "fn*": - fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} - return fn, nil - default: - el, e := eval_ast(ast, env) - if e != nil { - return nil, e - } - f := el.(List).Val[0] - if MalFunc_Q(f) { - fn := f.(MalFunc) - ast = fn.Exp - env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) - if e != nil { - return nil, e - } - } else { - fn, ok := f.(Func) - if !ok { - return nil, errors.New("attempt to call non-function") - } - return fn.Fn(el.(List).Val[1:]) - } - } - - } // TCO loop -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -var repl_env, _ = NewEnv(nil, nil, nil) - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, repl_env); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - // core.go: defined using go - for k, v := range core.NS { - repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) - } - repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { - return EVAL(a[0], repl_env) - }, nil}) - repl_env.Set(Symbol{"*ARGV*"}, List{}) - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - 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)))))))") - - // called with mal script to load and eval - if len(os.Args) > 1 { - args := make([]MalType, 0, len(os.Args)-2) - for _, a := range os.Args[2:] { - args = append(args, a) - } - repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) - if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { - fmt.Printf("Error: %v\n", e) - os.Exit(1) - } - os.Exit(0) - } - - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} +package main + +import ( + "errors" + "fmt" + "os" + "strings" +) + +import ( + "core" + . "env" + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func starts_with(xs []MalType, sym string) bool { + if 0 < len(xs) { + switch s := xs[0].(type) { + case Symbol: + return s.Val == sym + default: + } + } + return false +} + +func qq_loop(xs []MalType) MalType { + acc := NewList() + for i := len(xs) - 1; 0<=i; i -= 1 { + elt := xs[i] + switch e := elt.(type) { + case List: + if starts_with(e.Val, "splice-unquote") { + acc = NewList(Symbol{"concat"}, e.Val[1], acc) + continue + } + default: + } + acc = NewList(Symbol{"cons"}, quasiquote(elt), acc) + } + return acc +} + +func quasiquote(ast MalType) MalType { + switch a := ast.(type) { + case Vector: + return NewList(Symbol{"vec"}, qq_loop(a.Val)) + case HashMap, Symbol: + return NewList(Symbol{"quote"}, ast) + case List: + if starts_with(a.Val,"unquote") { + return a.Val[1] + } else { + return qq_loop(a.Val) + } + default: + return ast + } +} + +func is_macro_call(ast MalType, env EnvType) bool { + if List_Q(ast) { + slc, _ := GetSlice(ast) + if len(slc) == 0 { + return false + } + a0 := slc[0] + if Symbol_Q(a0) && env.Find(a0.(Symbol)) != nil { + mac, e := env.Get(a0.(Symbol)) + if e != nil { + return false + } + if MalFunc_Q(mac) { + return mac.(MalFunc).GetMacro() + } + } + } + return false +} + +func macroexpand(ast MalType, env EnvType) (MalType, error) { + var mac MalType + var e error + for is_macro_call(ast, env) { + slc, _ := GetSlice(ast) + a0 := slc[0] + mac, e = env.Get(a0.(Symbol)) + if e != nil { + return nil, e + } + fn := mac.(MalFunc) + ast, e = Apply(fn, slc[1:]) + if e != nil { + return nil, e + } + } + return ast, nil +} + +func eval_ast(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("eval_ast: %#v\n", ast) + if Symbol_Q(ast) { + return env.Get(ast.(Symbol)) + } else if List_Q(ast) { + lst := []MalType{} + for _, a := range ast.(List).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return List{lst, nil}, nil + } else if Vector_Q(ast) { + lst := []MalType{} + for _, a := range ast.(Vector).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return Vector{lst, nil}, nil + } else if HashMap_Q(ast) { + m := ast.(HashMap) + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range m.Val { + kv, e2 := EVAL(v, env) + if e2 != nil { + return nil, e2 + } + new_hm.Val[k] = kv + } + return new_hm, nil + } else { + return ast, nil + } +} + +func EVAL(ast MalType, env EnvType) (MalType, error) { + var e error + for { + + //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) + switch ast.(type) { + case List: // continue + default: + return eval_ast(ast, env) + } + + // apply list + ast, e = macroexpand(ast, env) + if e != nil { + return nil, e + } + if !List_Q(ast) { + return eval_ast(ast, env) + } + if len(ast.(List).Val) == 0 { + return ast, nil + } + + a0 := ast.(List).Val[0] + var a1 MalType = nil + var a2 MalType = nil + switch len(ast.(List).Val) { + case 1: + a1 = nil + a2 = nil + case 2: + a1 = ast.(List).Val[1] + a2 = nil + default: + a1 = ast.(List).Val[1] + a2 = ast.(List).Val[2] + } + a0sym := "__<*fn*>__" + if Symbol_Q(a0) { + a0sym = a0.(Symbol).Val + } + switch a0sym { + case "def!": + res, e := EVAL(a2, env) + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), res), nil + case "let*": + let_env, e := NewEnv(env, nil, nil) + if e != nil { + return nil, e + } + arr1, e := GetSlice(a1) + if e != nil { + return nil, e + } + for i := 0; i < len(arr1); i += 2 { + if !Symbol_Q(arr1[i]) { + return nil, errors.New("non-symbol bind value") + } + exp, e := EVAL(arr1[i+1], let_env) + if e != nil { + return nil, e + } + let_env.Set(arr1[i].(Symbol), exp) + } + ast = a2 + env = let_env + case "quote": + return a1, nil + case "quasiquoteexpand": + return quasiquote(a1), nil + case "quasiquote": + ast = quasiquote(a1) + case "defmacro!": + fn, e := EVAL(a2, env) + fn = fn.(MalFunc).SetMacro() + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), fn), nil + case "macroexpand": + return macroexpand(a1, env) + case "do": + lst := ast.(List).Val + _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) + if e != nil { + return nil, e + } + if len(lst) == 1 { + return nil, nil + } + ast = lst[len(lst)-1] + case "if": + cond, e := EVAL(a1, env) + if e != nil { + return nil, e + } + if cond == nil || cond == false { + if len(ast.(List).Val) >= 4 { + ast = ast.(List).Val[3] + } else { + return nil, nil + } + } else { + ast = a2 + } + case "fn*": + fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} + return fn, nil + default: + el, e := eval_ast(ast, env) + if e != nil { + return nil, e + } + f := el.(List).Val[0] + if MalFunc_Q(f) { + fn := f.(MalFunc) + ast = fn.Exp + env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) + if e != nil { + return nil, e + } + } else { + fn, ok := f.(Func) + if !ok { + return nil, errors.New("attempt to call non-function") + } + return fn.Fn(el.(List).Val[1:]) + } + } + + } // TCO loop +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +var repl_env, _ = NewEnv(nil, nil, nil) + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, repl_env); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + // core.go: defined using go + for k, v := range core.NS { + repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) + } + repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { + return EVAL(a[0], repl_env) + }, nil}) + repl_env.Set(Symbol{"*ARGV*"}, List{}) + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + 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)))))))") + + // called with mal script to load and eval + if len(os.Args) > 1 { + args := make([]MalType, 0, len(os.Args)-2) + for _, a := range os.Args[2:] { + args = append(args, a) + } + repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) + if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { + fmt.Printf("Error: %v\n", e) + os.Exit(1) + } + os.Exit(0) + } + + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} diff --git a/impls/go/src/step9_try/step9_try.go b/impls/go/src/step9_try/step9_try.go index 0360cc6d4c..d1f707cf2c 100644 --- a/impls/go/src/step9_try/step9_try.go +++ b/impls/go/src/step9_try/step9_try.go @@ -1,384 +1,384 @@ -package main - -import ( - "errors" - "fmt" - "os" - "strings" -) - -import ( - "core" - . "env" - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func starts_with(xs []MalType, sym string) bool { - if 0 < len(xs) { - switch s := xs[0].(type) { - case Symbol: - return s.Val == sym - default: - } - } - return false -} - -func qq_loop(xs []MalType) MalType { - acc := NewList() - for i := len(xs) - 1; 0<=i; i -= 1 { - elt := xs[i] - switch e := elt.(type) { - case List: - if starts_with(e.Val, "splice-unquote") { - acc = NewList(Symbol{"concat"}, e.Val[1], acc) - continue - } - default: - } - acc = NewList(Symbol{"cons"}, quasiquote(elt), acc) - } - return acc -} - -func quasiquote(ast MalType) MalType { - switch a := ast.(type) { - case Vector: - return NewList(Symbol{"vec"}, qq_loop(a.Val)) - case HashMap, Symbol: - return NewList(Symbol{"quote"}, ast) - case List: - if starts_with(a.Val,"unquote") { - return a.Val[1] - } else { - return qq_loop(a.Val) - } - default: - return ast - } -} - -func is_macro_call(ast MalType, env EnvType) bool { - if List_Q(ast) { - slc, _ := GetSlice(ast) - if len(slc) == 0 { - return false - } - a0 := slc[0] - if Symbol_Q(a0) && env.Find(a0.(Symbol)) != nil { - mac, e := env.Get(a0.(Symbol)) - if e != nil { - return false - } - if MalFunc_Q(mac) { - return mac.(MalFunc).GetMacro() - } - } - } - return false -} - -func macroexpand(ast MalType, env EnvType) (MalType, error) { - var mac MalType - var e error - for is_macro_call(ast, env) { - slc, _ := GetSlice(ast) - a0 := slc[0] - mac, e = env.Get(a0.(Symbol)) - if e != nil { - return nil, e - } - fn := mac.(MalFunc) - ast, e = Apply(fn, slc[1:]) - if e != nil { - return nil, e - } - } - return ast, nil -} - -func eval_ast(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("eval_ast: %#v\n", ast) - if Symbol_Q(ast) { - return env.Get(ast.(Symbol)) - } else if List_Q(ast) { - lst := []MalType{} - for _, a := range ast.(List).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return List{lst, nil}, nil - } else if Vector_Q(ast) { - lst := []MalType{} - for _, a := range ast.(Vector).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return Vector{lst, nil}, nil - } else if HashMap_Q(ast) { - m := ast.(HashMap) - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range m.Val { - kv, e2 := EVAL(v, env) - if e2 != nil { - return nil, e2 - } - new_hm.Val[k] = kv - } - return new_hm, nil - } else { - return ast, nil - } -} - -func EVAL(ast MalType, env EnvType) (MalType, error) { - var e error - for { - - //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) - switch ast.(type) { - case List: // continue - default: - return eval_ast(ast, env) - } - - // apply list - ast, e = macroexpand(ast, env) - if e != nil { - return nil, e - } - if !List_Q(ast) { - return eval_ast(ast, env) - } - if len(ast.(List).Val) == 0 { - return ast, nil - } - - a0 := ast.(List).Val[0] - var a1 MalType = nil - var a2 MalType = nil - switch len(ast.(List).Val) { - case 1: - a1 = nil - a2 = nil - case 2: - a1 = ast.(List).Val[1] - a2 = nil - default: - a1 = ast.(List).Val[1] - a2 = ast.(List).Val[2] - } - a0sym := "__<*fn*>__" - if Symbol_Q(a0) { - a0sym = a0.(Symbol).Val - } - switch a0sym { - case "def!": - res, e := EVAL(a2, env) - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), res), nil - case "let*": - let_env, e := NewEnv(env, nil, nil) - if e != nil { - return nil, e - } - arr1, e := GetSlice(a1) - if e != nil { - return nil, e - } - for i := 0; i < len(arr1); i += 2 { - if !Symbol_Q(arr1[i]) { - return nil, errors.New("non-symbol bind value") - } - exp, e := EVAL(arr1[i+1], let_env) - if e != nil { - return nil, e - } - let_env.Set(arr1[i].(Symbol), exp) - } - ast = a2 - env = let_env - case "quote": - return a1, nil - case "quasiquoteexpand": - return quasiquote(a1), nil - case "quasiquote": - ast = quasiquote(a1) - case "defmacro!": - fn, e := EVAL(a2, env) - fn = fn.(MalFunc).SetMacro() - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), fn), nil - case "macroexpand": - return macroexpand(a1, env) - case "try*": - var exc MalType - exp, e := EVAL(a1, env) - if e == nil { - return exp, nil - } else { - if a2 != nil && List_Q(a2) { - a2s, _ := GetSlice(a2) - if Symbol_Q(a2s[0]) && (a2s[0].(Symbol).Val == "catch*") { - switch e.(type) { - case MalError: - exc = e.(MalError).Obj - default: - exc = e.Error() - } - binds := NewList(a2s[1]) - new_env, e := NewEnv(env, binds, NewList(exc)) - if e != nil { - return nil, e - } - exp, e = EVAL(a2s[2], new_env) - if e == nil { - return exp, nil - } - } - } - return nil, e - } - case "do": - lst := ast.(List).Val - _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) - if e != nil { - return nil, e - } - if len(lst) == 1 { - return nil, nil - } - ast = lst[len(lst)-1] - case "if": - cond, e := EVAL(a1, env) - if e != nil { - return nil, e - } - if cond == nil || cond == false { - if len(ast.(List).Val) >= 4 { - ast = ast.(List).Val[3] - } else { - return nil, nil - } - } else { - ast = a2 - } - case "fn*": - fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} - return fn, nil - default: - el, e := eval_ast(ast, env) - if e != nil { - return nil, e - } - f := el.(List).Val[0] - if MalFunc_Q(f) { - fn := f.(MalFunc) - ast = fn.Exp - env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) - if e != nil { - return nil, e - } - } else { - fn, ok := f.(Func) - if !ok { - return nil, errors.New("attempt to call non-function") - } - return fn.Fn(el.(List).Val[1:]) - } - } - - } // TCO loop -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -var repl_env, _ = NewEnv(nil, nil, nil) - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, repl_env); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - // core.go: defined using go - for k, v := range core.NS { - repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) - } - repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { - return EVAL(a[0], repl_env) - }, nil}) - repl_env.Set(Symbol{"*ARGV*"}, List{}) - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - 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)))))))") - - // called with mal script to load and eval - if len(os.Args) > 1 { - args := make([]MalType, 0, len(os.Args)-2) - for _, a := range os.Args[2:] { - args = append(args, a) - } - repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) - if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { - fmt.Printf("Error: %v\n", e) - os.Exit(1) - } - os.Exit(0) - } - - // repl loop - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} +package main + +import ( + "errors" + "fmt" + "os" + "strings" +) + +import ( + "core" + . "env" + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func starts_with(xs []MalType, sym string) bool { + if 0 < len(xs) { + switch s := xs[0].(type) { + case Symbol: + return s.Val == sym + default: + } + } + return false +} + +func qq_loop(xs []MalType) MalType { + acc := NewList() + for i := len(xs) - 1; 0<=i; i -= 1 { + elt := xs[i] + switch e := elt.(type) { + case List: + if starts_with(e.Val, "splice-unquote") { + acc = NewList(Symbol{"concat"}, e.Val[1], acc) + continue + } + default: + } + acc = NewList(Symbol{"cons"}, quasiquote(elt), acc) + } + return acc +} + +func quasiquote(ast MalType) MalType { + switch a := ast.(type) { + case Vector: + return NewList(Symbol{"vec"}, qq_loop(a.Val)) + case HashMap, Symbol: + return NewList(Symbol{"quote"}, ast) + case List: + if starts_with(a.Val,"unquote") { + return a.Val[1] + } else { + return qq_loop(a.Val) + } + default: + return ast + } +} + +func is_macro_call(ast MalType, env EnvType) bool { + if List_Q(ast) { + slc, _ := GetSlice(ast) + if len(slc) == 0 { + return false + } + a0 := slc[0] + if Symbol_Q(a0) && env.Find(a0.(Symbol)) != nil { + mac, e := env.Get(a0.(Symbol)) + if e != nil { + return false + } + if MalFunc_Q(mac) { + return mac.(MalFunc).GetMacro() + } + } + } + return false +} + +func macroexpand(ast MalType, env EnvType) (MalType, error) { + var mac MalType + var e error + for is_macro_call(ast, env) { + slc, _ := GetSlice(ast) + a0 := slc[0] + mac, e = env.Get(a0.(Symbol)) + if e != nil { + return nil, e + } + fn := mac.(MalFunc) + ast, e = Apply(fn, slc[1:]) + if e != nil { + return nil, e + } + } + return ast, nil +} + +func eval_ast(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("eval_ast: %#v\n", ast) + if Symbol_Q(ast) { + return env.Get(ast.(Symbol)) + } else if List_Q(ast) { + lst := []MalType{} + for _, a := range ast.(List).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return List{lst, nil}, nil + } else if Vector_Q(ast) { + lst := []MalType{} + for _, a := range ast.(Vector).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return Vector{lst, nil}, nil + } else if HashMap_Q(ast) { + m := ast.(HashMap) + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range m.Val { + kv, e2 := EVAL(v, env) + if e2 != nil { + return nil, e2 + } + new_hm.Val[k] = kv + } + return new_hm, nil + } else { + return ast, nil + } +} + +func EVAL(ast MalType, env EnvType) (MalType, error) { + var e error + for { + + //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) + switch ast.(type) { + case List: // continue + default: + return eval_ast(ast, env) + } + + // apply list + ast, e = macroexpand(ast, env) + if e != nil { + return nil, e + } + if !List_Q(ast) { + return eval_ast(ast, env) + } + if len(ast.(List).Val) == 0 { + return ast, nil + } + + a0 := ast.(List).Val[0] + var a1 MalType = nil + var a2 MalType = nil + switch len(ast.(List).Val) { + case 1: + a1 = nil + a2 = nil + case 2: + a1 = ast.(List).Val[1] + a2 = nil + default: + a1 = ast.(List).Val[1] + a2 = ast.(List).Val[2] + } + a0sym := "__<*fn*>__" + if Symbol_Q(a0) { + a0sym = a0.(Symbol).Val + } + switch a0sym { + case "def!": + res, e := EVAL(a2, env) + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), res), nil + case "let*": + let_env, e := NewEnv(env, nil, nil) + if e != nil { + return nil, e + } + arr1, e := GetSlice(a1) + if e != nil { + return nil, e + } + for i := 0; i < len(arr1); i += 2 { + if !Symbol_Q(arr1[i]) { + return nil, errors.New("non-symbol bind value") + } + exp, e := EVAL(arr1[i+1], let_env) + if e != nil { + return nil, e + } + let_env.Set(arr1[i].(Symbol), exp) + } + ast = a2 + env = let_env + case "quote": + return a1, nil + case "quasiquoteexpand": + return quasiquote(a1), nil + case "quasiquote": + ast = quasiquote(a1) + case "defmacro!": + fn, e := EVAL(a2, env) + fn = fn.(MalFunc).SetMacro() + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), fn), nil + case "macroexpand": + return macroexpand(a1, env) + case "try*": + var exc MalType + exp, e := EVAL(a1, env) + if e == nil { + return exp, nil + } else { + if a2 != nil && List_Q(a2) { + a2s, _ := GetSlice(a2) + if Symbol_Q(a2s[0]) && (a2s[0].(Symbol).Val == "catch*") { + switch e.(type) { + case MalError: + exc = e.(MalError).Obj + default: + exc = e.Error() + } + binds := NewList(a2s[1]) + new_env, e := NewEnv(env, binds, NewList(exc)) + if e != nil { + return nil, e + } + exp, e = EVAL(a2s[2], new_env) + if e == nil { + return exp, nil + } + } + } + return nil, e + } + case "do": + lst := ast.(List).Val + _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) + if e != nil { + return nil, e + } + if len(lst) == 1 { + return nil, nil + } + ast = lst[len(lst)-1] + case "if": + cond, e := EVAL(a1, env) + if e != nil { + return nil, e + } + if cond == nil || cond == false { + if len(ast.(List).Val) >= 4 { + ast = ast.(List).Val[3] + } else { + return nil, nil + } + } else { + ast = a2 + } + case "fn*": + fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} + return fn, nil + default: + el, e := eval_ast(ast, env) + if e != nil { + return nil, e + } + f := el.(List).Val[0] + if MalFunc_Q(f) { + fn := f.(MalFunc) + ast = fn.Exp + env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) + if e != nil { + return nil, e + } + } else { + fn, ok := f.(Func) + if !ok { + return nil, errors.New("attempt to call non-function") + } + return fn.Fn(el.(List).Val[1:]) + } + } + + } // TCO loop +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +var repl_env, _ = NewEnv(nil, nil, nil) + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, repl_env); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + // core.go: defined using go + for k, v := range core.NS { + repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) + } + repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { + return EVAL(a[0], repl_env) + }, nil}) + repl_env.Set(Symbol{"*ARGV*"}, List{}) + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + 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)))))))") + + // called with mal script to load and eval + if len(os.Args) > 1 { + args := make([]MalType, 0, len(os.Args)-2) + for _, a := range os.Args[2:] { + args = append(args, a) + } + repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) + if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { + fmt.Printf("Error: %v\n", e) + os.Exit(1) + } + os.Exit(0) + } + + // repl loop + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} diff --git a/impls/go/src/stepA_mal/stepA_mal.go b/impls/go/src/stepA_mal/stepA_mal.go index dae2e4bb34..3dfae095c2 100644 --- a/impls/go/src/stepA_mal/stepA_mal.go +++ b/impls/go/src/stepA_mal/stepA_mal.go @@ -1,386 +1,386 @@ -package main - -import ( - "errors" - "fmt" - "os" - "strings" -) - -import ( - "core" - . "env" - "printer" - "reader" - "readline" - . "types" -) - -// read -func READ(str string) (MalType, error) { - return reader.Read_str(str) -} - -// eval -func starts_with(xs []MalType, sym string) bool { - if 0 < len(xs) { - switch s := xs[0].(type) { - case Symbol: - return s.Val == sym - default: - } - } - return false -} - -func qq_loop(xs []MalType) MalType { - acc := NewList() - for i := len(xs) - 1; 0<=i; i -= 1 { - elt := xs[i] - switch e := elt.(type) { - case List: - if starts_with(e.Val, "splice-unquote") { - acc = NewList(Symbol{"concat"}, e.Val[1], acc) - continue - } - default: - } - acc = NewList(Symbol{"cons"}, quasiquote(elt), acc) - } - return acc -} - -func quasiquote(ast MalType) MalType { - switch a := ast.(type) { - case Vector: - return NewList(Symbol{"vec"}, qq_loop(a.Val)) - case HashMap, Symbol: - return NewList(Symbol{"quote"}, ast) - case List: - if starts_with(a.Val,"unquote") { - return a.Val[1] - } else { - return qq_loop(a.Val) - } - default: - return ast - } -} - -func is_macro_call(ast MalType, env EnvType) bool { - if List_Q(ast) { - slc, _ := GetSlice(ast) - if len(slc) == 0 { - return false - } - a0 := slc[0] - if Symbol_Q(a0) && env.Find(a0.(Symbol)) != nil { - mac, e := env.Get(a0.(Symbol)) - if e != nil { - return false - } - if MalFunc_Q(mac) { - return mac.(MalFunc).GetMacro() - } - } - } - return false -} - -func macroexpand(ast MalType, env EnvType) (MalType, error) { - var mac MalType - var e error - for is_macro_call(ast, env) { - slc, _ := GetSlice(ast) - a0 := slc[0] - mac, e = env.Get(a0.(Symbol)) - if e != nil { - return nil, e - } - fn := mac.(MalFunc) - ast, e = Apply(fn, slc[1:]) - if e != nil { - return nil, e - } - } - return ast, nil -} - -func eval_ast(ast MalType, env EnvType) (MalType, error) { - //fmt.Printf("eval_ast: %#v\n", ast) - if Symbol_Q(ast) { - return env.Get(ast.(Symbol)) - } else if List_Q(ast) { - lst := []MalType{} - for _, a := range ast.(List).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return List{lst, nil}, nil - } else if Vector_Q(ast) { - lst := []MalType{} - for _, a := range ast.(Vector).Val { - exp, e := EVAL(a, env) - if e != nil { - return nil, e - } - lst = append(lst, exp) - } - return Vector{lst, nil}, nil - } else if HashMap_Q(ast) { - m := ast.(HashMap) - new_hm := HashMap{map[string]MalType{}, nil} - for k, v := range m.Val { - kv, e2 := EVAL(v, env) - if e2 != nil { - return nil, e2 - } - new_hm.Val[k] = kv - } - return new_hm, nil - } else { - return ast, nil - } -} - -func EVAL(ast MalType, env EnvType) (MalType, error) { - var e error - for { - - //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) - switch ast.(type) { - case List: // continue - default: - return eval_ast(ast, env) - } - - // apply list - ast, e = macroexpand(ast, env) - if e != nil { - return nil, e - } - if !List_Q(ast) { - return eval_ast(ast, env) - } - if len(ast.(List).Val) == 0 { - return ast, nil - } - - a0 := ast.(List).Val[0] - var a1 MalType = nil - var a2 MalType = nil - switch len(ast.(List).Val) { - case 1: - a1 = nil - a2 = nil - case 2: - a1 = ast.(List).Val[1] - a2 = nil - default: - a1 = ast.(List).Val[1] - a2 = ast.(List).Val[2] - } - a0sym := "__<*fn*>__" - if Symbol_Q(a0) { - a0sym = a0.(Symbol).Val - } - switch a0sym { - case "def!": - res, e := EVAL(a2, env) - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), res), nil - case "let*": - let_env, e := NewEnv(env, nil, nil) - if e != nil { - return nil, e - } - arr1, e := GetSlice(a1) - if e != nil { - return nil, e - } - for i := 0; i < len(arr1); i += 2 { - if !Symbol_Q(arr1[i]) { - return nil, errors.New("non-symbol bind value") - } - exp, e := EVAL(arr1[i+1], let_env) - if e != nil { - return nil, e - } - let_env.Set(arr1[i].(Symbol), exp) - } - ast = a2 - env = let_env - case "quote": - return a1, nil - case "quasiquoteexpand": - return quasiquote(a1), nil - case "quasiquote": - ast = quasiquote(a1) - case "defmacro!": - fn, e := EVAL(a2, env) - fn = fn.(MalFunc).SetMacro() - if e != nil { - return nil, e - } - return env.Set(a1.(Symbol), fn), nil - case "macroexpand": - return macroexpand(a1, env) - case "try*": - var exc MalType - exp, e := EVAL(a1, env) - if e == nil { - return exp, nil - } else { - if a2 != nil && List_Q(a2) { - a2s, _ := GetSlice(a2) - if Symbol_Q(a2s[0]) && (a2s[0].(Symbol).Val == "catch*") { - switch e.(type) { - case MalError: - exc = e.(MalError).Obj - default: - exc = e.Error() - } - binds := NewList(a2s[1]) - new_env, e := NewEnv(env, binds, NewList(exc)) - if e != nil { - return nil, e - } - exp, e = EVAL(a2s[2], new_env) - if e == nil { - return exp, nil - } - } - } - return nil, e - } - case "do": - lst := ast.(List).Val - _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) - if e != nil { - return nil, e - } - if len(lst) == 1 { - return nil, nil - } - ast = lst[len(lst)-1] - case "if": - cond, e := EVAL(a1, env) - if e != nil { - return nil, e - } - if cond == nil || cond == false { - if len(ast.(List).Val) >= 4 { - ast = ast.(List).Val[3] - } else { - return nil, nil - } - } else { - ast = a2 - } - case "fn*": - fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} - return fn, nil - default: - el, e := eval_ast(ast, env) - if e != nil { - return nil, e - } - f := el.(List).Val[0] - if MalFunc_Q(f) { - fn := f.(MalFunc) - ast = fn.Exp - env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) - if e != nil { - return nil, e - } - } else { - fn, ok := f.(Func) - if !ok { - return nil, errors.New("attempt to call non-function") - } - return fn.Fn(el.(List).Val[1:]) - } - } - - } // TCO loop -} - -// print -func PRINT(exp MalType) (string, error) { - return printer.Pr_str(exp, true), nil -} - -var repl_env, _ = NewEnv(nil, nil, nil) - -// repl -func rep(str string) (MalType, error) { - var exp MalType - var res string - var e error - if exp, e = READ(str); e != nil { - return nil, e - } - if exp, e = EVAL(exp, repl_env); e != nil { - return nil, e - } - if res, e = PRINT(exp); e != nil { - return nil, e - } - return res, nil -} - -func main() { - // core.go: defined using go - for k, v := range core.NS { - repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) - } - repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { - return EVAL(a[0], repl_env) - }, nil}) - repl_env.Set(Symbol{"*ARGV*"}, List{}) - - // core.mal: defined using the language itself - rep("(def! *host-language* \"go\")") - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - 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)))))))") - - // called with mal script to load and eval - if len(os.Args) > 1 { - args := make([]MalType, 0, len(os.Args)-2) - for _, a := range os.Args[2:] { - args = append(args, a) - } - repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) - if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { - fmt.Printf("Error: %v\n", e) - os.Exit(1) - } - os.Exit(0) - } - - // repl loop - rep("(println (str \"Mal [\" *host-language* \"]\"))") - for { - text, err := readline.Readline("user> ") - text = strings.TrimRight(text, "\n") - if err != nil { - return - } - var out MalType - var e error - if out, e = rep(text); e != nil { - if e.Error() == "" { - continue - } - fmt.Printf("Error: %v\n", e) - continue - } - fmt.Printf("%v\n", out) - } -} +package main + +import ( + "errors" + "fmt" + "os" + "strings" +) + +import ( + "core" + . "env" + "printer" + "reader" + "readline" + . "types" +) + +// read +func READ(str string) (MalType, error) { + return reader.Read_str(str) +} + +// eval +func starts_with(xs []MalType, sym string) bool { + if 0 < len(xs) { + switch s := xs[0].(type) { + case Symbol: + return s.Val == sym + default: + } + } + return false +} + +func qq_loop(xs []MalType) MalType { + acc := NewList() + for i := len(xs) - 1; 0<=i; i -= 1 { + elt := xs[i] + switch e := elt.(type) { + case List: + if starts_with(e.Val, "splice-unquote") { + acc = NewList(Symbol{"concat"}, e.Val[1], acc) + continue + } + default: + } + acc = NewList(Symbol{"cons"}, quasiquote(elt), acc) + } + return acc +} + +func quasiquote(ast MalType) MalType { + switch a := ast.(type) { + case Vector: + return NewList(Symbol{"vec"}, qq_loop(a.Val)) + case HashMap, Symbol: + return NewList(Symbol{"quote"}, ast) + case List: + if starts_with(a.Val,"unquote") { + return a.Val[1] + } else { + return qq_loop(a.Val) + } + default: + return ast + } +} + +func is_macro_call(ast MalType, env EnvType) bool { + if List_Q(ast) { + slc, _ := GetSlice(ast) + if len(slc) == 0 { + return false + } + a0 := slc[0] + if Symbol_Q(a0) && env.Find(a0.(Symbol)) != nil { + mac, e := env.Get(a0.(Symbol)) + if e != nil { + return false + } + if MalFunc_Q(mac) { + return mac.(MalFunc).GetMacro() + } + } + } + return false +} + +func macroexpand(ast MalType, env EnvType) (MalType, error) { + var mac MalType + var e error + for is_macro_call(ast, env) { + slc, _ := GetSlice(ast) + a0 := slc[0] + mac, e = env.Get(a0.(Symbol)) + if e != nil { + return nil, e + } + fn := mac.(MalFunc) + ast, e = Apply(fn, slc[1:]) + if e != nil { + return nil, e + } + } + return ast, nil +} + +func eval_ast(ast MalType, env EnvType) (MalType, error) { + //fmt.Printf("eval_ast: %#v\n", ast) + if Symbol_Q(ast) { + return env.Get(ast.(Symbol)) + } else if List_Q(ast) { + lst := []MalType{} + for _, a := range ast.(List).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return List{lst, nil}, nil + } else if Vector_Q(ast) { + lst := []MalType{} + for _, a := range ast.(Vector).Val { + exp, e := EVAL(a, env) + if e != nil { + return nil, e + } + lst = append(lst, exp) + } + return Vector{lst, nil}, nil + } else if HashMap_Q(ast) { + m := ast.(HashMap) + new_hm := HashMap{map[string]MalType{}, nil} + for k, v := range m.Val { + kv, e2 := EVAL(v, env) + if e2 != nil { + return nil, e2 + } + new_hm.Val[k] = kv + } + return new_hm, nil + } else { + return ast, nil + } +} + +func EVAL(ast MalType, env EnvType) (MalType, error) { + var e error + for { + + //fmt.Printf("EVAL: %v\n", printer.Pr_str(ast, true)) + switch ast.(type) { + case List: // continue + default: + return eval_ast(ast, env) + } + + // apply list + ast, e = macroexpand(ast, env) + if e != nil { + return nil, e + } + if !List_Q(ast) { + return eval_ast(ast, env) + } + if len(ast.(List).Val) == 0 { + return ast, nil + } + + a0 := ast.(List).Val[0] + var a1 MalType = nil + var a2 MalType = nil + switch len(ast.(List).Val) { + case 1: + a1 = nil + a2 = nil + case 2: + a1 = ast.(List).Val[1] + a2 = nil + default: + a1 = ast.(List).Val[1] + a2 = ast.(List).Val[2] + } + a0sym := "__<*fn*>__" + if Symbol_Q(a0) { + a0sym = a0.(Symbol).Val + } + switch a0sym { + case "def!": + res, e := EVAL(a2, env) + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), res), nil + case "let*": + let_env, e := NewEnv(env, nil, nil) + if e != nil { + return nil, e + } + arr1, e := GetSlice(a1) + if e != nil { + return nil, e + } + for i := 0; i < len(arr1); i += 2 { + if !Symbol_Q(arr1[i]) { + return nil, errors.New("non-symbol bind value") + } + exp, e := EVAL(arr1[i+1], let_env) + if e != nil { + return nil, e + } + let_env.Set(arr1[i].(Symbol), exp) + } + ast = a2 + env = let_env + case "quote": + return a1, nil + case "quasiquoteexpand": + return quasiquote(a1), nil + case "quasiquote": + ast = quasiquote(a1) + case "defmacro!": + fn, e := EVAL(a2, env) + fn = fn.(MalFunc).SetMacro() + if e != nil { + return nil, e + } + return env.Set(a1.(Symbol), fn), nil + case "macroexpand": + return macroexpand(a1, env) + case "try*": + var exc MalType + exp, e := EVAL(a1, env) + if e == nil { + return exp, nil + } else { + if a2 != nil && List_Q(a2) { + a2s, _ := GetSlice(a2) + if Symbol_Q(a2s[0]) && (a2s[0].(Symbol).Val == "catch*") { + switch e.(type) { + case MalError: + exc = e.(MalError).Obj + default: + exc = e.Error() + } + binds := NewList(a2s[1]) + new_env, e := NewEnv(env, binds, NewList(exc)) + if e != nil { + return nil, e + } + exp, e = EVAL(a2s[2], new_env) + if e == nil { + return exp, nil + } + } + } + return nil, e + } + case "do": + lst := ast.(List).Val + _, e := eval_ast(List{lst[1 : len(lst)-1], nil}, env) + if e != nil { + return nil, e + } + if len(lst) == 1 { + return nil, nil + } + ast = lst[len(lst)-1] + case "if": + cond, e := EVAL(a1, env) + if e != nil { + return nil, e + } + if cond == nil || cond == false { + if len(ast.(List).Val) >= 4 { + ast = ast.(List).Val[3] + } else { + return nil, nil + } + } else { + ast = a2 + } + case "fn*": + fn := MalFunc{EVAL, a2, env, a1, false, NewEnv, nil} + return fn, nil + default: + el, e := eval_ast(ast, env) + if e != nil { + return nil, e + } + f := el.(List).Val[0] + if MalFunc_Q(f) { + fn := f.(MalFunc) + ast = fn.Exp + env, e = NewEnv(fn.Env, fn.Params, List{el.(List).Val[1:], nil}) + if e != nil { + return nil, e + } + } else { + fn, ok := f.(Func) + if !ok { + return nil, errors.New("attempt to call non-function") + } + return fn.Fn(el.(List).Val[1:]) + } + } + + } // TCO loop +} + +// print +func PRINT(exp MalType) (string, error) { + return printer.Pr_str(exp, true), nil +} + +var repl_env, _ = NewEnv(nil, nil, nil) + +// repl +func rep(str string) (MalType, error) { + var exp MalType + var res string + var e error + if exp, e = READ(str); e != nil { + return nil, e + } + if exp, e = EVAL(exp, repl_env); e != nil { + return nil, e + } + if res, e = PRINT(exp); e != nil { + return nil, e + } + return res, nil +} + +func main() { + // core.go: defined using go + for k, v := range core.NS { + repl_env.Set(Symbol{k}, Func{v.(func([]MalType) (MalType, error)), nil}) + } + repl_env.Set(Symbol{"eval"}, Func{func(a []MalType) (MalType, error) { + return EVAL(a[0], repl_env) + }, nil}) + repl_env.Set(Symbol{"*ARGV*"}, List{}) + + // core.mal: defined using the language itself + rep("(def! *host-language* \"go\")") + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + 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)))))))") + + // called with mal script to load and eval + if len(os.Args) > 1 { + args := make([]MalType, 0, len(os.Args)-2) + for _, a := range os.Args[2:] { + args = append(args, a) + } + repl_env.Set(Symbol{"*ARGV*"}, List{args, nil}) + if _, e := rep("(load-file \"" + os.Args[1] + "\")"); e != nil { + fmt.Printf("Error: %v\n", e) + os.Exit(1) + } + os.Exit(0) + } + + // repl loop + rep("(println (str \"Mal [\" *host-language* \"]\"))") + for { + text, err := readline.Readline("user> ") + text = strings.TrimRight(text, "\n") + if err != nil { + return + } + var out MalType + var e error + if out, e = rep(text); e != nil { + if e.Error() == "" { + continue + } + fmt.Printf("Error: %v\n", e) + continue + } + fmt.Printf("%v\n", out) + } +} diff --git a/impls/go/src/types/types.go b/impls/go/src/types/types.go index 9d4cb10b5f..cc29e9fcd8 100644 --- a/impls/go/src/types/types.go +++ b/impls/go/src/types/types.go @@ -1,280 +1,280 @@ -package types - -import ( - "errors" - "fmt" - "reflect" - "strings" -) - -// Errors/Exceptions -type MalError struct { - Obj MalType -} - -func (e MalError) Error() string { - return fmt.Sprintf("%#v", e.Obj) -} - -// General types -type MalType interface { -} - -type EnvType interface { - Find(key Symbol) EnvType - Set(key Symbol, value MalType) MalType - Get(key Symbol) (MalType, error) -} - -// Scalars -func Nil_Q(obj MalType) bool { - return obj == nil -} - -func True_Q(obj MalType) bool { - b, ok := obj.(bool) - return ok && b == true -} - -func False_Q(obj MalType) bool { - b, ok := obj.(bool) - return ok && b == false -} - -func Number_Q(obj MalType) bool { - _, ok := obj.(int) - return ok -} - -// Symbols -type Symbol struct { - Val string -} - -func Symbol_Q(obj MalType) bool { - _, ok := obj.(Symbol) - return ok -} - -// Keywords -func NewKeyword(s string) (MalType, error) { - return "\u029e" + s, nil -} - -func Keyword_Q(obj MalType) bool { - s, ok := obj.(string) - return ok && strings.HasPrefix(s, "\u029e") -} - -// Strings -func String_Q(obj MalType) bool { - _, ok := obj.(string) - return ok -} - -// Functions -type Func struct { - Fn func([]MalType) (MalType, error) - Meta MalType -} - -func Func_Q(obj MalType) bool { - _, ok := obj.(Func) - return ok -} - -type MalFunc struct { - Eval func(MalType, EnvType) (MalType, error) - Exp MalType - Env EnvType - Params MalType - IsMacro bool - GenEnv func(EnvType, MalType, MalType) (EnvType, error) - Meta MalType -} - -func MalFunc_Q(obj MalType) bool { - _, ok := obj.(MalFunc) - return ok -} - -func (f MalFunc) SetMacro() MalType { - f.IsMacro = true - return f -} - -func (f MalFunc) GetMacro() bool { - return f.IsMacro -} - -// Take either a MalFunc or regular function and apply it to the -// arguments -func Apply(f_mt MalType, a []MalType) (MalType, error) { - switch f := f_mt.(type) { - case MalFunc: - env, e := f.GenEnv(f.Env, f.Params, List{a, nil}) - if e != nil { - return nil, e - } - return f.Eval(f.Exp, env) - case Func: - return f.Fn(a) - case func([]MalType) (MalType, error): - return f(a) - default: - return nil, errors.New("Invalid function to Apply") - } -} - -// Lists -type List struct { - Val []MalType - Meta MalType -} - -func NewList(a ...MalType) MalType { - return List{a, nil} -} - -func List_Q(obj MalType) bool { - _, ok := obj.(List) - return ok -} - -// Vectors -type Vector struct { - Val []MalType - Meta MalType -} - -func Vector_Q(obj MalType) bool { - _, ok := obj.(Vector) - return ok -} - -func GetSlice(seq MalType) ([]MalType, error) { - switch obj := seq.(type) { - case List: - return obj.Val, nil - case Vector: - return obj.Val, nil - default: - return nil, errors.New("GetSlice called on non-sequence") - } -} - -// Hash Maps -type HashMap struct { - Val map[string]MalType - Meta MalType -} - -func NewHashMap(seq MalType) (MalType, error) { - lst, e := GetSlice(seq) - if e != nil { - return nil, e - } - if len(lst)%2 == 1 { - return nil, errors.New("Odd number of arguments to NewHashMap") - } - m := map[string]MalType{} - for i := 0; i < len(lst); i += 2 { - str, ok := lst[i].(string) - if !ok { - return nil, errors.New("expected hash-map key string") - } - m[str] = lst[i+1] - } - return HashMap{m, nil}, nil -} - -func HashMap_Q(obj MalType) bool { - _, ok := obj.(HashMap) - return ok -} - -// Atoms -type Atom struct { - Val MalType - Meta MalType -} - -func (a *Atom) Set(val MalType) MalType { - a.Val = val - return a -} - -func Atom_Q(obj MalType) bool { - _, ok := obj.(*Atom) - return ok -} - -// General functions - -func _obj_type(obj MalType) string { - if obj == nil { - return "nil" - } - return reflect.TypeOf(obj).Name() -} - -func Sequential_Q(seq MalType) bool { - if seq == nil { - return false - } - return (reflect.TypeOf(seq).Name() == "List") || - (reflect.TypeOf(seq).Name() == "Vector") -} - -func Equal_Q(a MalType, b MalType) bool { - ota := reflect.TypeOf(a) - otb := reflect.TypeOf(b) - if !((ota == otb) || (Sequential_Q(a) && Sequential_Q(b))) { - return false - } - //av := reflect.ValueOf(a); bv := reflect.ValueOf(b) - //fmt.Printf("here2: %#v\n", reflect.TypeOf(a).Name()) - //switch reflect.TypeOf(a).Name() { - switch a.(type) { - case Symbol: - return a.(Symbol).Val == b.(Symbol).Val - case List: - as, _ := GetSlice(a) - bs, _ := GetSlice(b) - if len(as) != len(bs) { - return false - } - for i := 0; i < len(as); i += 1 { - if !Equal_Q(as[i], bs[i]) { - return false - } - } - return true - case Vector: - as, _ := GetSlice(a) - bs, _ := GetSlice(b) - if len(as) != len(bs) { - return false - } - for i := 0; i < len(as); i += 1 { - if !Equal_Q(as[i], bs[i]) { - return false - } - } - return true - case HashMap: - am := a.(HashMap).Val - bm := b.(HashMap).Val - if len(am) != len(bm) { - return false - } - for k, v := range am { - if !Equal_Q(v, bm[k]) { - return false - } - } - return true - default: - return a == b - } -} +package types + +import ( + "errors" + "fmt" + "reflect" + "strings" +) + +// Errors/Exceptions +type MalError struct { + Obj MalType +} + +func (e MalError) Error() string { + return fmt.Sprintf("%#v", e.Obj) +} + +// General types +type MalType interface { +} + +type EnvType interface { + Find(key Symbol) EnvType + Set(key Symbol, value MalType) MalType + Get(key Symbol) (MalType, error) +} + +// Scalars +func Nil_Q(obj MalType) bool { + return obj == nil +} + +func True_Q(obj MalType) bool { + b, ok := obj.(bool) + return ok && b == true +} + +func False_Q(obj MalType) bool { + b, ok := obj.(bool) + return ok && b == false +} + +func Number_Q(obj MalType) bool { + _, ok := obj.(int) + return ok +} + +// Symbols +type Symbol struct { + Val string +} + +func Symbol_Q(obj MalType) bool { + _, ok := obj.(Symbol) + return ok +} + +// Keywords +func NewKeyword(s string) (MalType, error) { + return "\u029e" + s, nil +} + +func Keyword_Q(obj MalType) bool { + s, ok := obj.(string) + return ok && strings.HasPrefix(s, "\u029e") +} + +// Strings +func String_Q(obj MalType) bool { + _, ok := obj.(string) + return ok +} + +// Functions +type Func struct { + Fn func([]MalType) (MalType, error) + Meta MalType +} + +func Func_Q(obj MalType) bool { + _, ok := obj.(Func) + return ok +} + +type MalFunc struct { + Eval func(MalType, EnvType) (MalType, error) + Exp MalType + Env EnvType + Params MalType + IsMacro bool + GenEnv func(EnvType, MalType, MalType) (EnvType, error) + Meta MalType +} + +func MalFunc_Q(obj MalType) bool { + _, ok := obj.(MalFunc) + return ok +} + +func (f MalFunc) SetMacro() MalType { + f.IsMacro = true + return f +} + +func (f MalFunc) GetMacro() bool { + return f.IsMacro +} + +// Take either a MalFunc or regular function and apply it to the +// arguments +func Apply(f_mt MalType, a []MalType) (MalType, error) { + switch f := f_mt.(type) { + case MalFunc: + env, e := f.GenEnv(f.Env, f.Params, List{a, nil}) + if e != nil { + return nil, e + } + return f.Eval(f.Exp, env) + case Func: + return f.Fn(a) + case func([]MalType) (MalType, error): + return f(a) + default: + return nil, errors.New("Invalid function to Apply") + } +} + +// Lists +type List struct { + Val []MalType + Meta MalType +} + +func NewList(a ...MalType) MalType { + return List{a, nil} +} + +func List_Q(obj MalType) bool { + _, ok := obj.(List) + return ok +} + +// Vectors +type Vector struct { + Val []MalType + Meta MalType +} + +func Vector_Q(obj MalType) bool { + _, ok := obj.(Vector) + return ok +} + +func GetSlice(seq MalType) ([]MalType, error) { + switch obj := seq.(type) { + case List: + return obj.Val, nil + case Vector: + return obj.Val, nil + default: + return nil, errors.New("GetSlice called on non-sequence") + } +} + +// Hash Maps +type HashMap struct { + Val map[string]MalType + Meta MalType +} + +func NewHashMap(seq MalType) (MalType, error) { + lst, e := GetSlice(seq) + if e != nil { + return nil, e + } + if len(lst)%2 == 1 { + return nil, errors.New("Odd number of arguments to NewHashMap") + } + m := map[string]MalType{} + for i := 0; i < len(lst); i += 2 { + str, ok := lst[i].(string) + if !ok { + return nil, errors.New("expected hash-map key string") + } + m[str] = lst[i+1] + } + return HashMap{m, nil}, nil +} + +func HashMap_Q(obj MalType) bool { + _, ok := obj.(HashMap) + return ok +} + +// Atoms +type Atom struct { + Val MalType + Meta MalType +} + +func (a *Atom) Set(val MalType) MalType { + a.Val = val + return a +} + +func Atom_Q(obj MalType) bool { + _, ok := obj.(*Atom) + return ok +} + +// General functions + +func _obj_type(obj MalType) string { + if obj == nil { + return "nil" + } + return reflect.TypeOf(obj).Name() +} + +func Sequential_Q(seq MalType) bool { + if seq == nil { + return false + } + return (reflect.TypeOf(seq).Name() == "List") || + (reflect.TypeOf(seq).Name() == "Vector") +} + +func Equal_Q(a MalType, b MalType) bool { + ota := reflect.TypeOf(a) + otb := reflect.TypeOf(b) + if !((ota == otb) || (Sequential_Q(a) && Sequential_Q(b))) { + return false + } + //av := reflect.ValueOf(a); bv := reflect.ValueOf(b) + //fmt.Printf("here2: %#v\n", reflect.TypeOf(a).Name()) + //switch reflect.TypeOf(a).Name() { + switch a.(type) { + case Symbol: + return a.(Symbol).Val == b.(Symbol).Val + case List: + as, _ := GetSlice(a) + bs, _ := GetSlice(b) + if len(as) != len(bs) { + return false + } + for i := 0; i < len(as); i += 1 { + if !Equal_Q(as[i], bs[i]) { + return false + } + } + return true + case Vector: + as, _ := GetSlice(a) + bs, _ := GetSlice(b) + if len(as) != len(bs) { + return false + } + for i := 0; i < len(as); i += 1 { + if !Equal_Q(as[i], bs[i]) { + return false + } + } + return true + case HashMap: + am := a.(HashMap).Val + bm := b.(HashMap).Val + if len(am) != len(bm) { + return false + } + for k, v := range am { + if !Equal_Q(v, bm[k]) { + return false + } + } + return true + default: + return a == b + } +} diff --git a/impls/go/tests/step2_eval.mal b/impls/go/tests/step2_eval.mal index 4b3a4bf27d..de057827be 100644 --- a/impls/go/tests/step2_eval.mal +++ b/impls/go/tests/step2_eval.mal @@ -1,34 +1,34 @@ -;; Testing evaluation of excessive arguments -(+ 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(+ 1 2) -;=>3 - - -;; Testing evaluation of missing arguments -(+ 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(+) -;=>Error: wrong number of arguments - -;; Testing evaluation of excessive arguments -(- 1 2 3) -;=>Error: wrong number of arguments - -;; Valid call -(- 1 2) -;=>-1 - - -;; Testing evaluation of missing arguments -(- 1) -;=>Error: wrong number of arguments - -;; Testing evaluation of missing arguments -(-) -;=>Error: wrong number of arguments - +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments + +;; Testing evaluation of excessive arguments +(- 1 2 3) +;=>Error: wrong number of arguments + +;; Valid call +(- 1 2) +;=>-1 + + +;; Testing evaluation of missing arguments +(- 1) +;=>Error: wrong number of arguments + +;; Testing evaluation of missing arguments +(-) +;=>Error: wrong number of arguments + diff --git a/impls/go/tests/step4_if_fn_do.mal b/impls/go/tests/step4_if_fn_do.mal index 2134ce66f8..2ba4712625 100644 --- a/impls/go/tests/step4_if_fn_do.mal +++ b/impls/go/tests/step4_if_fn_do.mal @@ -1,34 +1,34 @@ -;; Testing evaluation of excessive arguments -(+ 1 2 3) -;=>Error: wrong number of arguments (3 instead of 2) - -;; Valid call -(+ 1 2) -;=>3 - - -;; Testing evaluation of missing arguments -(+ 1) -;=>Error: wrong number of arguments (1 instead of 2) - -;; Testing evaluation of missing arguments -(+) -;=>Error: wrong number of arguments (0 instead of 2) - -;; Testing evaluation of excessive arguments -(= 1 2 3) -;=>Error: wrong number of arguments (3 instead of 2) - -;; Valid call -(= 1 2) -;=>false - - -;; Testing evaluation of missing arguments -(= 1) -;=>Error: wrong number of arguments (1 instead of 2) - -;; Testing evaluation of missing arguments -(=) -;=>Error: wrong number of arguments (0 instead of 2) - +;; Testing evaluation of excessive arguments +(+ 1 2 3) +;=>Error: wrong number of arguments (3 instead of 2) + +;; Valid call +(+ 1 2) +;=>3 + + +;; Testing evaluation of missing arguments +(+ 1) +;=>Error: wrong number of arguments (1 instead of 2) + +;; Testing evaluation of missing arguments +(+) +;=>Error: wrong number of arguments (0 instead of 2) + +;; Testing evaluation of excessive arguments +(= 1 2 3) +;=>Error: wrong number of arguments (3 instead of 2) + +;; Valid call +(= 1 2) +;=>false + + +;; Testing evaluation of missing arguments +(= 1) +;=>Error: wrong number of arguments (1 instead of 2) + +;; Testing evaluation of missing arguments +(=) +;=>Error: wrong number of arguments (0 instead of 2) + diff --git a/impls/go/tests/step5_tco.mal b/impls/go/tests/step5_tco.mal index 6fa1da6fdf..6d5aeec4e1 100644 --- a/impls/go/tests/step5_tco.mal +++ b/impls/go/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Go: skipping non-TCO recursion -;; Reason: completes even at 100,000 +;; Go: skipping non-TCO recursion +;; Reason: completes even at 100,000 diff --git a/impls/groovy/Dockerfile b/impls/groovy/Dockerfile index 196698ab78..b594bd5229 100644 --- a/impls/groovy/Dockerfile +++ b/impls/groovy/Dockerfile @@ -1,30 +1,30 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Java and Groovy -RUN apt-get -y install openjdk-7-jdk -#RUN apt-get -y install maven2 -#ENV MAVEN_OPTS -Duser.home=/mal -RUN apt-get -y install ant - -RUN apt-get -y install groovy +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Java and Groovy +RUN apt-get -y install openjdk-7-jdk +#RUN apt-get -y install maven2 +#ENV MAVEN_OPTS -Duser.home=/mal +RUN apt-get -y install ant + +RUN apt-get -y install groovy diff --git a/impls/groovy/GroovyWrapper.groovy b/impls/groovy/GroovyWrapper.groovy index b375dd7a24..e0256a5194 100644 --- a/impls/groovy/GroovyWrapper.groovy +++ b/impls/groovy/GroovyWrapper.groovy @@ -1,76 +1,76 @@ -/* From: - * http://groovy.jmiguel.eu/groovy.codehaus.org/WrappingGroovyScript.html - */ -/* - * Copyright 2002-2007 the original author or authors. - * - * Licensed under the Apache License, Version 2.0 (the "License"); - * you may not use this file except in compliance with the License. - * You may obtain a copy of the License at - * - * http://www.apache.org/licenses/LICENSE-2.0 - * - * Unless required by applicable law or agreed to in writing, software - * distributed under the License is distributed on an "AS IS" BASIS, - * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - * See the License for the specific language governing permissions and - * limitations under the License. - */ - -/** - * Wrap a script and groovy jars to an executable jar - */ -def cli = new CliBuilder() -cli.h( longOpt: 'help', required: false, 'show usage information' ) -cli.d( longOpt: 'destfile', argName: 'destfile', required: false, args: 1, 'jar destintation filename, defaults to {mainclass}.jar' ) -cli.m( longOpt: 'mainclass', argName: 'mainclass', required: true, args: 1, 'fully qualified main class, eg. HelloWorld' ) -cli.c( longOpt: 'groovyc', required: false, 'Run groovyc' ) - -//-------------------------------------------------------------------------- -def opt = cli.parse(args) -if (!opt) { return } -if (opt.h) { - cli.usage(); - return -} - -def mainClass = opt.m -def scriptBase = mainClass.replace( '.', '/' ) -def scriptFile = new File( scriptBase + '.groovy' ) -if (!scriptFile.canRead()) { - println "Cannot read script file: '${scriptFile}'" - return -} -def destFile = scriptBase + '.jar' -if (opt.d) { - destFile = opt.d -} - -//-------------------------------------------------------------------------- -def ant = new AntBuilder() - -if (opt.c) { - ant.echo( "Compiling ${scriptFile}" ) - org.codehaus.groovy.tools.FileSystemCompiler.main( [ scriptFile ] as String[] ) -} - -def GROOVY_HOME = new File( System.getenv('GROOVY_HOME') ) -if (!GROOVY_HOME.canRead()) { - ant.echo( "Missing environment variable GROOVY_HOME: '${GROOVY_HOME}'" ) - return -} - -ant.jar( destfile: destFile, compress: true, index: true ) { - //fileset( dir: '.', includes: scriptBase + '*.class' ) - fileset( dir: '.', includes: '*.class' ) - - zipgroupfileset( dir: GROOVY_HOME, includes: 'embeddable/groovy-all-*.jar' ) - zipgroupfileset( dir: GROOVY_HOME, includes: 'lib/commons*.jar' ) - // add more jars here - - manifest { - attribute( name: 'Main-Class', value: mainClass ) - } -} - -ant.echo( "Run script using: \'java -jar ${destFile} ...\'" ) +/* From: + * http://groovy.jmiguel.eu/groovy.codehaus.org/WrappingGroovyScript.html + */ +/* + * Copyright 2002-2007 the original author or authors. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +/** + * Wrap a script and groovy jars to an executable jar + */ +def cli = new CliBuilder() +cli.h( longOpt: 'help', required: false, 'show usage information' ) +cli.d( longOpt: 'destfile', argName: 'destfile', required: false, args: 1, 'jar destintation filename, defaults to {mainclass}.jar' ) +cli.m( longOpt: 'mainclass', argName: 'mainclass', required: true, args: 1, 'fully qualified main class, eg. HelloWorld' ) +cli.c( longOpt: 'groovyc', required: false, 'Run groovyc' ) + +//-------------------------------------------------------------------------- +def opt = cli.parse(args) +if (!opt) { return } +if (opt.h) { + cli.usage(); + return +} + +def mainClass = opt.m +def scriptBase = mainClass.replace( '.', '/' ) +def scriptFile = new File( scriptBase + '.groovy' ) +if (!scriptFile.canRead()) { + println "Cannot read script file: '${scriptFile}'" + return +} +def destFile = scriptBase + '.jar' +if (opt.d) { + destFile = opt.d +} + +//-------------------------------------------------------------------------- +def ant = new AntBuilder() + +if (opt.c) { + ant.echo( "Compiling ${scriptFile}" ) + org.codehaus.groovy.tools.FileSystemCompiler.main( [ scriptFile ] as String[] ) +} + +def GROOVY_HOME = new File( System.getenv('GROOVY_HOME') ) +if (!GROOVY_HOME.canRead()) { + ant.echo( "Missing environment variable GROOVY_HOME: '${GROOVY_HOME}'" ) + return +} + +ant.jar( destfile: destFile, compress: true, index: true ) { + //fileset( dir: '.', includes: scriptBase + '*.class' ) + fileset( dir: '.', includes: '*.class' ) + + zipgroupfileset( dir: GROOVY_HOME, includes: 'embeddable/groovy-all-*.jar' ) + zipgroupfileset( dir: GROOVY_HOME, includes: 'lib/commons*.jar' ) + // add more jars here + + manifest { + attribute( name: 'Main-Class', value: mainClass ) + } +} + +ant.echo( "Run script using: \'java -jar ${destFile} ...\'" ) diff --git a/impls/groovy/Makefile b/impls/groovy/Makefile index 888eb9fc24..e005610b88 100644 --- a/impls/groovy/Makefile +++ b/impls/groovy/Makefile @@ -1,38 +1,38 @@ -CLASSES = types.class reader.class printer.class env.class core.class - -all: ${CLASSES} - -dist: mal.jar - -step1_read_print.groovy: types.class reader.class printer.class -step2_eval.groovy: types.class reader.class printer.class -step3_env.groovy: types.class reader.class printer.class env.class -step4_if_fn_do.groovy step6_file.groovy step7_quote.groovy step8_macros.groovy step9_try.groovy stepA_mal.groovy: ${CLASSES} - -types.class: types.groovy - groovyc $< - -env.class: env.groovy - groovyc $< - -reader.class: reader.groovy - groovyc $< - -printer.class: printer.groovy - groovyc $< - -core.class: core.groovy types.class reader.class printer.class - groovyc $< - -mal.jar: ${CLASSES} - groovyc stepA_mal.groovy - GROOVY_HOME=/usr/share/groovy groovy GroovyWrapper -d $@ -m stepA_mal - -SHELL := bash -mal: mal.jar - cat <(echo -e '#!/bin/sh\nexec java -jar "$$0" "$$@"') mal.jar > $@ - chmod +x mal - -clean: - rm -f *.class classes/* mal.jar mal - rmdir classes || true +CLASSES = types.class reader.class printer.class env.class core.class + +all: ${CLASSES} + +dist: mal.jar + +step1_read_print.groovy: types.class reader.class printer.class +step2_eval.groovy: types.class reader.class printer.class +step3_env.groovy: types.class reader.class printer.class env.class +step4_if_fn_do.groovy step6_file.groovy step7_quote.groovy step8_macros.groovy step9_try.groovy stepA_mal.groovy: ${CLASSES} + +types.class: types.groovy + groovyc $< + +env.class: env.groovy + groovyc $< + +reader.class: reader.groovy + groovyc $< + +printer.class: printer.groovy + groovyc $< + +core.class: core.groovy types.class reader.class printer.class + groovyc $< + +mal.jar: ${CLASSES} + groovyc stepA_mal.groovy + GROOVY_HOME=/usr/share/groovy groovy GroovyWrapper -d $@ -m stepA_mal + +SHELL := bash +mal: mal.jar + cat <(echo -e '#!/bin/sh\nexec java -jar "$$0" "$$@"') mal.jar > $@ + chmod +x mal + +clean: + rm -f *.class classes/* mal.jar mal + rmdir classes || true diff --git a/impls/groovy/core.groovy b/impls/groovy/core.groovy index aaf05d4a58..c5b5b6ab62 100644 --- a/impls/groovy/core.groovy +++ b/impls/groovy/core.groovy @@ -1,136 +1,136 @@ -import types -import types.MalException -import types.MalSymbol -import types.MalFunc -import reader -import printer - -class core { - def static do_pr_str(args) { - return printer._pr_list(args, " ", true) - } - def static do_str(args) { - return printer._pr_list(args, "", false) - } - def static do_prn(args) { - println(printer._pr_list(args, " ", true)) - } - def static do_println(args) { - println(printer._pr_list(args, " ", false)) - } - - def static do_concat(args) { - args.inject([], { a, b -> a + (b as List) }) - } - def static do_nth(args) { - if (args[0].size() <= args[1]) { - throw new MalException("nth: index out of range") - } - args[0][args[1]] - } - def static do_apply(args) { - def start_args = args.drop(1).take(args.size()-2) as List - args[0](start_args + (args.last() as List)) - } - - def static do_swap_BANG(args) { - def (atm,f) = [args[0], args[1]] - atm.value = f([atm.value] + (args.drop(2) as List)) - } - - def static do_conj(args) { - if (types.list_Q(args[0])) { - args.drop(1).inject(args[0], { a, b -> [b] + a }) - } else { - types.vector(args.drop(1).inject(args[0], { a, b -> a + [b] })) - } - } - def static do_seq(args) { - def obj = args[0] - switch (obj) { - case { types.list_Q(obj) }: - return obj.size() == 0 ? null : obj - case { types.vector_Q(obj) }: - return obj.size() == 0 ? null : obj.clone() - case { types.string_Q(obj) }: - return obj.size() == 0 ? null : obj.collect{ it.toString() } - case null: - return null - default: - throw new MalException("seq: called on non-sequence") - } - } - - static ns = [ - "=": { a -> a[0]==a[1]}, - "throw": { a -> throw new MalException(a[0]) }, - - "nil?": { a -> a[0] == null }, - "true?": { a -> a[0] == true }, - "false?": { a -> a[0] == false }, - "string?": { a -> types.string_Q(a[0]) }, - "symbol": { a -> new MalSymbol(a[0]) }, - "symbol?": { a -> a[0] instanceof MalSymbol }, - "keyword": { a -> types.keyword(a[0]) }, - "keyword?": { a -> types.keyword_Q(a[0]) }, - "number?": { a -> a[0] instanceof Integer }, - "fn?": { a -> (a[0] instanceof MalFunc && !a[0].ismacro) || - a[0] instanceof Closure }, - "macro?": { a -> a[0] instanceof MalFunc && a[0].ismacro }, - - "pr-str": core.&do_pr_str, - "str": core.&do_str, - "prn": core.&do_prn, - "println": core.&do_println, - "read-string": reader.&read_str, - "readline": { a -> System.console().readLine(a[0]) }, - "slurp": { a -> new File(a[0]).text }, - - "<": { a -> a[0]": { a -> a[0]>a[1]}, - ">=": { a -> a[0]>=a[1]}, - "+": { a -> a[0]+a[1]}, - "-": { a -> a[0]-a[1]}, - "*": { a -> a[0]*a[1]}, - "/": { a -> a[0]/a[1]}, // / - "time-ms": { a -> System.currentTimeMillis() }, - - "list": { a -> a}, - "list?": { a -> types.list_Q(a[0]) }, - "vector": { a -> types.vector(a) }, - "vector?": { a -> types.vector_Q(a[0]) }, - "hash-map": { a -> types.hash_map(a) }, - "map?": { a -> types.hash_map_Q(a[0]) }, - "assoc": { a -> types.assoc_BANG(types.copy(a[0]), a.drop(1)) }, - "dissoc": { a -> types.dissoc_BANG(types.copy(a[0]), a.drop(1)) }, - "get": { a -> a[0] == null ? null : a[0][a[1]] }, - "contains?": { a -> a[0].containsKey(a[1]) }, - "keys": { a -> a[0].keySet() as List }, - "vals": { a -> a[0].values() as List }, - - "sequential?": { a -> types.&sequential_Q(a[0]) }, - "cons": { a -> [a[0]] + (a[1] as List) }, - "concat": core.&do_concat, - "vec": { a -> types.vector_Q(a[0]) ? a[0] : types.vector(a[0]) }, - "nth": core.&do_nth, - "first": { a -> a[0] == null || a[0].size() == 0 ? null : a[0][0] }, - "rest": { a -> a[0] == null ? [] as List : a[0].drop(1) }, - "empty?": { a -> a[0] == null || a[0].size() == 0 }, - "count": { a -> a[0] == null ? 0 : a[0].size() }, - "apply": core.&do_apply, - "map": { a -> a[1].collect { x -> a[0].call([x]) } }, - - "conj": core.&do_conj, - "seq": core.&do_seq, - - "meta": { a -> a[0].hasProperty("meta") ? a[0].getProperties().meta : null }, - "with-meta": { a -> def b = types.copy(a[0]); b.getMetaClass().meta = a[1]; b }, - "atom": { a -> new types.MalAtom(a[0]) }, - "atom?": { a -> a[0] instanceof types.MalAtom }, - "deref": { a -> a[0].value }, - "reset!": { a -> a[0].value = a[1] }, - "swap!": core.&do_swap_BANG - ] -} - +import types +import types.MalException +import types.MalSymbol +import types.MalFunc +import reader +import printer + +class core { + def static do_pr_str(args) { + return printer._pr_list(args, " ", true) + } + def static do_str(args) { + return printer._pr_list(args, "", false) + } + def static do_prn(args) { + println(printer._pr_list(args, " ", true)) + } + def static do_println(args) { + println(printer._pr_list(args, " ", false)) + } + + def static do_concat(args) { + args.inject([], { a, b -> a + (b as List) }) + } + def static do_nth(args) { + if (args[0].size() <= args[1]) { + throw new MalException("nth: index out of range") + } + args[0][args[1]] + } + def static do_apply(args) { + def start_args = args.drop(1).take(args.size()-2) as List + args[0](start_args + (args.last() as List)) + } + + def static do_swap_BANG(args) { + def (atm,f) = [args[0], args[1]] + atm.value = f([atm.value] + (args.drop(2) as List)) + } + + def static do_conj(args) { + if (types.list_Q(args[0])) { + args.drop(1).inject(args[0], { a, b -> [b] + a }) + } else { + types.vector(args.drop(1).inject(args[0], { a, b -> a + [b] })) + } + } + def static do_seq(args) { + def obj = args[0] + switch (obj) { + case { types.list_Q(obj) }: + return obj.size() == 0 ? null : obj + case { types.vector_Q(obj) }: + return obj.size() == 0 ? null : obj.clone() + case { types.string_Q(obj) }: + return obj.size() == 0 ? null : obj.collect{ it.toString() } + case null: + return null + default: + throw new MalException("seq: called on non-sequence") + } + } + + static ns = [ + "=": { a -> a[0]==a[1]}, + "throw": { a -> throw new MalException(a[0]) }, + + "nil?": { a -> a[0] == null }, + "true?": { a -> a[0] == true }, + "false?": { a -> a[0] == false }, + "string?": { a -> types.string_Q(a[0]) }, + "symbol": { a -> new MalSymbol(a[0]) }, + "symbol?": { a -> a[0] instanceof MalSymbol }, + "keyword": { a -> types.keyword(a[0]) }, + "keyword?": { a -> types.keyword_Q(a[0]) }, + "number?": { a -> a[0] instanceof Integer }, + "fn?": { a -> (a[0] instanceof MalFunc && !a[0].ismacro) || + a[0] instanceof Closure }, + "macro?": { a -> a[0] instanceof MalFunc && a[0].ismacro }, + + "pr-str": core.&do_pr_str, + "str": core.&do_str, + "prn": core.&do_prn, + "println": core.&do_println, + "read-string": reader.&read_str, + "readline": { a -> System.console().readLine(a[0]) }, + "slurp": { a -> new File(a[0]).text }, + + "<": { a -> a[0]": { a -> a[0]>a[1]}, + ">=": { a -> a[0]>=a[1]}, + "+": { a -> a[0]+a[1]}, + "-": { a -> a[0]-a[1]}, + "*": { a -> a[0]*a[1]}, + "/": { a -> a[0]/a[1]}, // / + "time-ms": { a -> System.currentTimeMillis() }, + + "list": { a -> a}, + "list?": { a -> types.list_Q(a[0]) }, + "vector": { a -> types.vector(a) }, + "vector?": { a -> types.vector_Q(a[0]) }, + "hash-map": { a -> types.hash_map(a) }, + "map?": { a -> types.hash_map_Q(a[0]) }, + "assoc": { a -> types.assoc_BANG(types.copy(a[0]), a.drop(1)) }, + "dissoc": { a -> types.dissoc_BANG(types.copy(a[0]), a.drop(1)) }, + "get": { a -> a[0] == null ? null : a[0][a[1]] }, + "contains?": { a -> a[0].containsKey(a[1]) }, + "keys": { a -> a[0].keySet() as List }, + "vals": { a -> a[0].values() as List }, + + "sequential?": { a -> types.&sequential_Q(a[0]) }, + "cons": { a -> [a[0]] + (a[1] as List) }, + "concat": core.&do_concat, + "vec": { a -> types.vector_Q(a[0]) ? a[0] : types.vector(a[0]) }, + "nth": core.&do_nth, + "first": { a -> a[0] == null || a[0].size() == 0 ? null : a[0][0] }, + "rest": { a -> a[0] == null ? [] as List : a[0].drop(1) }, + "empty?": { a -> a[0] == null || a[0].size() == 0 }, + "count": { a -> a[0] == null ? 0 : a[0].size() }, + "apply": core.&do_apply, + "map": { a -> a[1].collect { x -> a[0].call([x]) } }, + + "conj": core.&do_conj, + "seq": core.&do_seq, + + "meta": { a -> a[0].hasProperty("meta") ? a[0].getProperties().meta : null }, + "with-meta": { a -> def b = types.copy(a[0]); b.getMetaClass().meta = a[1]; b }, + "atom": { a -> new types.MalAtom(a[0]) }, + "atom?": { a -> a[0] instanceof types.MalAtom }, + "deref": { a -> a[0].value }, + "reset!": { a -> a[0].value = a[1] }, + "swap!": core.&do_swap_BANG + ] +} + diff --git a/impls/groovy/env.groovy b/impls/groovy/env.groovy index 8ff0e514b0..da7ac90c8b 100644 --- a/impls/groovy/env.groovy +++ b/impls/groovy/env.groovy @@ -1,55 +1,55 @@ -import types.MalException -import types.MalSymbol - -class env { - static class Env { - def data - def outer - - Env() { - outer = null - data = [:] - } - Env(Env outer_env) { - outer = outer_env - data = [:] - } - Env(Env outer_env, binds, exprs) { - outer = outer_env - data = [:] - for (int i=0; i i) ? exprs[i..-1] : [] - break - } else { - data[binds[i].value] = exprs[i] - } - } - } - - def set(MalSymbol key, def val) { - data[key.value] = val - } - - def find(MalSymbol key) { - if (data.containsKey(key.value)) { - this - } else if (outer != null) { - outer.find(key) - } else { - null - } - } - - def get(MalSymbol key) { - def e = find(key) - if (e == null) { - throw new MalException("'${key.value}' not found") - } else { - e.data.get(key.value) - } - } - } - -} - +import types.MalException +import types.MalSymbol + +class env { + static class Env { + def data + def outer + + Env() { + outer = null + data = [:] + } + Env(Env outer_env) { + outer = outer_env + data = [:] + } + Env(Env outer_env, binds, exprs) { + outer = outer_env + data = [:] + for (int i=0; i i) ? exprs[i..-1] : [] + break + } else { + data[binds[i].value] = exprs[i] + } + } + } + + def set(MalSymbol key, def val) { + data[key.value] = val + } + + def find(MalSymbol key) { + if (data.containsKey(key.value)) { + this + } else if (outer != null) { + outer.find(key) + } else { + null + } + } + + def get(MalSymbol key) { + def e = find(key) + if (e == null) { + throw new MalException("'${key.value}' not found") + } else { + e.data.get(key.value) + } + } + } + +} + diff --git a/impls/groovy/printer.groovy b/impls/groovy/printer.groovy index 9631b17fea..8e61318ddb 100644 --- a/impls/groovy/printer.groovy +++ b/impls/groovy/printer.groovy @@ -1,44 +1,44 @@ -import groovy.json.StringEscapeUtils -import types -import types.MalSymbol -import types.MalAtom - - -class printer { - def static _pr_list(lst, sep, Boolean print_readably) { - return lst.collect{ e -> pr_str(e, print_readably) }.join(sep) - } - - def static pr_str(exp, Boolean print_readably) { - def _r = print_readably - switch (exp) { - case { types.list_Q(exp) }: - def lst = exp.collect { pr_str(it, _r) } - return "(${lst.join(" ")})" - case { types.vector_Q(exp) }: - def lst = exp.collect { pr_str(it, _r) } - return "[${lst.join(" ")}]" - case Map: - def lst = [] - exp.each { k,v -> lst.add(pr_str(k,_r)); lst.add(pr_str(v,_r)) } - return "{${lst.join(" ")}}" - case String: - if (types.keyword_Q(exp)) { - return ":" + exp.drop(1) - } else if (print_readably) { - return "\"${StringEscapeUtils.escapeJava(exp)}\"" - } else { - return exp - } - case null: - return 'nil' - case MalSymbol: - return exp.value - case MalAtom: - return "(atom ${exp.value})" - default: - return exp.toString() - } - } -} - +import groovy.json.StringEscapeUtils +import types +import types.MalSymbol +import types.MalAtom + + +class printer { + def static _pr_list(lst, sep, Boolean print_readably) { + return lst.collect{ e -> pr_str(e, print_readably) }.join(sep) + } + + def static pr_str(exp, Boolean print_readably) { + def _r = print_readably + switch (exp) { + case { types.list_Q(exp) }: + def lst = exp.collect { pr_str(it, _r) } + return "(${lst.join(" ")})" + case { types.vector_Q(exp) }: + def lst = exp.collect { pr_str(it, _r) } + return "[${lst.join(" ")}]" + case Map: + def lst = [] + exp.each { k,v -> lst.add(pr_str(k,_r)); lst.add(pr_str(v,_r)) } + return "{${lst.join(" ")}}" + case String: + if (types.keyword_Q(exp)) { + return ":" + exp.drop(1) + } else if (print_readably) { + return "\"${StringEscapeUtils.escapeJava(exp)}\"" + } else { + return exp + } + case null: + return 'nil' + case MalSymbol: + return exp.value + case MalAtom: + return "(atom ${exp.value})" + default: + return exp.toString() + } + } +} + diff --git a/impls/groovy/reader.groovy b/impls/groovy/reader.groovy index 40586adb52..3fb8975f88 100644 --- a/impls/groovy/reader.groovy +++ b/impls/groovy/reader.groovy @@ -1,155 +1,155 @@ -import groovy.json.StringEscapeUtils -import types -import types.MalException -import types.MalSymbol - -class reader { - static class Reader { - def tokens - def position - Reader(def toks) { - tokens = toks - position = 0 - } - - def peek() { - if (position >= tokens.size) { - null - } else { - tokens[position] - } - } - def next() { - if (position >= tokens.size) { - null - } else { - tokens[position++] - } - } - } - - def static tokenizer(String str) { - def m = str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ - def tokens = [] - while (m.find()) { - String token = m.group(1) - if (token != null && - !(token == "") && - !(token[0] == ';')) { - tokens.add(token) - } - } - return tokens - } - - def static read_atom(Reader rdr) { - def token = rdr.next() - def m = token =~ /(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^"((?:\\.|[^\\"])*)"$|^"(.*)$|:(.*)|(^[^"]*$)/ - if (!m.find()) { - throw new MalException("unrecognized token '$token'") - } - if (m.group(1) != null) { - Integer.parseInt(m.group(1)) - } else if (m.group(3) != null) { - null - } else if (m.group(4) != null) { - true - } else if (m.group(5) != null) { - false - } else if (m.group(6) != null) { - if (token[token.length() - 1] != '"') { - throw new MalException("expected '\"', got EOF") - } - StringEscapeUtils.unescapeJava(m.group(6)) - } else if (m.group(7) != null) { - throw new MalException("expected '\"', got EOF") - } else if (m.group(8) != null) { - "\u029e" + m.group(8) - } else if (m.group(9) != null) { - new MalSymbol(m.group(9)) - } else { - throw new MalException("unrecognized '${m.group(0)}'") - } - } - - def static read_list(Reader rdr, char start, char end) { - def token = rdr.next() - def lst = [] - if (token.charAt(0) != start) { - throw new MalException("expected '${start}'") - } - - while ((token = rdr.peek()) != null && token.charAt(0) != end) { - lst.add(read_form(rdr)) - } - - if (token == null) { - throw new MalException("expected '${end}', got EOF") - } - rdr.next() - - return lst - } - - def static read_vector(Reader rdr) { - def lst = read_list(rdr, '[' as char, ']' as char) - return types.vector(lst) - } - - def static read_hash_map(Reader rdr) { - def lst = read_list(rdr, '{' as char, '}' as char) - return types.hash_map(lst) - } - - def static read_form(Reader rdr) { - def token = rdr.peek() - switch (token) { - // reader macros/transforms - case "'": - rdr.next() - return [new MalSymbol("quote"), read_form(rdr)] - case '`': - rdr.next() - return [new MalSymbol("quasiquote"), read_form(rdr)] - case '~': - rdr.next() - return [new MalSymbol("unquote"), read_form(rdr)] - case '~@': - rdr.next() - return [new MalSymbol("splice-unquote"), read_form(rdr)] - case '^': - rdr.next() - def meta = read_form(rdr); - return [new MalSymbol("with-meta"), read_form(rdr), meta] - case '@': - rdr.next() - return [new MalSymbol("deref"), read_form(rdr)] - - // list - case ')': throw new MalException("unexpected ')'") - case '(': return read_list(rdr, '(' as char, ')' as char) - - // vector - case ']': throw new MalException("unexpected ']'") - case '[': return read_vector(rdr) - - // hash-map - case '}': throw new MalException("unexpected '}'") - case '{': return read_hash_map(rdr) - - // atom - default: return read_atom(rdr) - } - } - - def static read_str(String str) { - def tokens = tokenizer(str) - if (tokens.size() == 0) { - return null; - } - //println "tokens ${tokens}" - def rdr = new Reader(tokens) - read_form(rdr) - } -} - +import groovy.json.StringEscapeUtils +import types +import types.MalException +import types.MalSymbol + +class reader { + static class Reader { + def tokens + def position + Reader(def toks) { + tokens = toks + position = 0 + } + + def peek() { + if (position >= tokens.size) { + null + } else { + tokens[position] + } + } + def next() { + if (position >= tokens.size) { + null + } else { + tokens[position++] + } + } + } + + def static tokenizer(String str) { + def m = str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ + def tokens = [] + while (m.find()) { + String token = m.group(1) + if (token != null && + !(token == "") && + !(token[0] == ';')) { + tokens.add(token) + } + } + return tokens + } + + def static read_atom(Reader rdr) { + def token = rdr.next() + def m = token =~ /(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^"((?:\\.|[^\\"])*)"$|^"(.*)$|:(.*)|(^[^"]*$)/ + if (!m.find()) { + throw new MalException("unrecognized token '$token'") + } + if (m.group(1) != null) { + Integer.parseInt(m.group(1)) + } else if (m.group(3) != null) { + null + } else if (m.group(4) != null) { + true + } else if (m.group(5) != null) { + false + } else if (m.group(6) != null) { + if (token[token.length() - 1] != '"') { + throw new MalException("expected '\"', got EOF") + } + StringEscapeUtils.unescapeJava(m.group(6)) + } else if (m.group(7) != null) { + throw new MalException("expected '\"', got EOF") + } else if (m.group(8) != null) { + "\u029e" + m.group(8) + } else if (m.group(9) != null) { + new MalSymbol(m.group(9)) + } else { + throw new MalException("unrecognized '${m.group(0)}'") + } + } + + def static read_list(Reader rdr, char start, char end) { + def token = rdr.next() + def lst = [] + if (token.charAt(0) != start) { + throw new MalException("expected '${start}'") + } + + while ((token = rdr.peek()) != null && token.charAt(0) != end) { + lst.add(read_form(rdr)) + } + + if (token == null) { + throw new MalException("expected '${end}', got EOF") + } + rdr.next() + + return lst + } + + def static read_vector(Reader rdr) { + def lst = read_list(rdr, '[' as char, ']' as char) + return types.vector(lst) + } + + def static read_hash_map(Reader rdr) { + def lst = read_list(rdr, '{' as char, '}' as char) + return types.hash_map(lst) + } + + def static read_form(Reader rdr) { + def token = rdr.peek() + switch (token) { + // reader macros/transforms + case "'": + rdr.next() + return [new MalSymbol("quote"), read_form(rdr)] + case '`': + rdr.next() + return [new MalSymbol("quasiquote"), read_form(rdr)] + case '~': + rdr.next() + return [new MalSymbol("unquote"), read_form(rdr)] + case '~@': + rdr.next() + return [new MalSymbol("splice-unquote"), read_form(rdr)] + case '^': + rdr.next() + def meta = read_form(rdr); + return [new MalSymbol("with-meta"), read_form(rdr), meta] + case '@': + rdr.next() + return [new MalSymbol("deref"), read_form(rdr)] + + // list + case ')': throw new MalException("unexpected ')'") + case '(': return read_list(rdr, '(' as char, ')' as char) + + // vector + case ']': throw new MalException("unexpected ']'") + case '[': return read_vector(rdr) + + // hash-map + case '}': throw new MalException("unexpected '}'") + case '{': return read_hash_map(rdr) + + // atom + default: return read_atom(rdr) + } + } + + def static read_str(String str) { + def tokens = tokenizer(str) + if (tokens.size() == 0) { + return null; + } + //println "tokens ${tokens}" + def rdr = new Reader(tokens) + read_form(rdr) + } +} + diff --git a/impls/groovy/run b/impls/groovy/run index 80a452e6c8..8dbf1565d1 100755 --- a/impls/groovy/run +++ b/impls/groovy/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec groovy $(dirname $0)/${STEP:-stepA_mal}.groovy "${@}" +#!/bin/bash +exec groovy $(dirname $0)/${STEP:-stepA_mal}.groovy "${@}" diff --git a/impls/groovy/step0_repl.groovy b/impls/groovy/step0_repl.groovy index be6c5e22fd..921f0a22ea 100644 --- a/impls/groovy/step0_repl.groovy +++ b/impls/groovy/step0_repl.groovy @@ -1,32 +1,32 @@ -// READ -READ = { str -> - str -} - -// EVAL -EVAL = { ast, env -> - ast -} - -// PRINT -PRINT = { exp -> - exp -} - -// REPL -REP = { str -> - PRINT(EVAL(READ(str), [:])) -} - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break - } - try { - println REP(line) - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +// READ +READ = { str -> + str +} + +// EVAL +EVAL = { ast, env -> + ast +} + +// PRINT +PRINT = { exp -> + exp +} + +// REPL +REP = { str -> + PRINT(EVAL(READ(str), [:])) +} + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break + } + try { + println REP(line) + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/step1_read_print.groovy b/impls/groovy/step1_read_print.groovy index c9775a6a68..36b52b8bd4 100644 --- a/impls/groovy/step1_read_print.groovy +++ b/impls/groovy/step1_read_print.groovy @@ -1,38 +1,38 @@ -import reader -import printer -import types.MalException - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -EVAL = { ast, env -> - ast -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -REP = { str -> - PRINT(EVAL(READ(str), [:])) -} - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types.MalException + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +EVAL = { ast, env -> + ast +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +REP = { str -> + PRINT(EVAL(READ(str), [:])) +} + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/step2_eval.groovy b/impls/groovy/step2_eval.groovy index 5fff657fbf..4cb37cc16c 100644 --- a/impls/groovy/step2_eval.groovy +++ b/impls/groovy/step2_eval.groovy @@ -1,70 +1,70 @@ -import reader -import printer -import types -import types.MalException -import types.MalSymbol - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -eval_ast = { ast, env -> - switch (ast) { - case MalSymbol: - if (env.containsKey(ast.value)) return env.get(ast.value) - throw new MalException("'${ast.value}' not found") - case List: - return types.vector_Q(ast) ? - types.vector(ast.collect { EVAL(it,env) }) : - ast.collect { EVAL(it,env) } - case Map: - def new_hm = [:] - ast.each { k,v -> - new_hm[k] = EVAL(v, env) - } - return new_hm - default: - return ast - } -} - -EVAL = { ast, env -> - if (! types.list_Q(ast)) return eval_ast(ast, env) - if (ast.size() == 0) return ast - - def el = eval_ast(ast, env) - def (f, args) = [el[0], el[1..-1]] - f(args) -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -repl_env = [ - "+": { a -> a[0]+a[1]}, - "-": { a -> a[0]-a[1]}, - "*": { a -> a[0]*a[1]}, - "/": { a -> a[0]/a[1]}] // / -REP = { str -> - PRINT(EVAL(READ(str), repl_env)) -} - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types +import types.MalException +import types.MalSymbol + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +eval_ast = { ast, env -> + switch (ast) { + case MalSymbol: + if (env.containsKey(ast.value)) return env.get(ast.value) + throw new MalException("'${ast.value}' not found") + case List: + return types.vector_Q(ast) ? + types.vector(ast.collect { EVAL(it,env) }) : + ast.collect { EVAL(it,env) } + case Map: + def new_hm = [:] + ast.each { k,v -> + new_hm[k] = EVAL(v, env) + } + return new_hm + default: + return ast + } +} + +EVAL = { ast, env -> + if (! types.list_Q(ast)) return eval_ast(ast, env) + if (ast.size() == 0) return ast + + def el = eval_ast(ast, env) + def (f, args) = [el[0], el[1..-1]] + f(args) +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +repl_env = [ + "+": { a -> a[0]+a[1]}, + "-": { a -> a[0]-a[1]}, + "*": { a -> a[0]*a[1]}, + "/": { a -> a[0]/a[1]}] // / +REP = { str -> + PRINT(EVAL(READ(str), repl_env)) +} + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/step3_env.groovy b/impls/groovy/step3_env.groovy index 66408b5d48..18a03cfb34 100644 --- a/impls/groovy/step3_env.groovy +++ b/impls/groovy/step3_env.groovy @@ -1,78 +1,78 @@ -import reader -import printer -import types -import types.MalException -import types.MalSymbol -import env.Env - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -eval_ast = { ast, env -> - switch (ast) { - case MalSymbol: return env.get(ast); - case List: return types.vector_Q(ast) ? - types.vector(ast.collect { EVAL(it,env) }) : - ast.collect { EVAL(it,env) } - case Map: def new_hm = [:] - ast.each { k,v -> - new_hm[k] = EVAL(v, env) - } - return new_hm - default: return ast - } -} - -EVAL = { ast, env -> - //println("EVAL: ${printer.pr_str(ast,true)}") - if (! types.list_Q(ast)) return eval_ast(ast, env) - if (ast.size() == 0) return ast - - switch (ast[0]) { - case { it instanceof MalSymbol && it.value == "def!" }: - return env.set(ast[1], EVAL(ast[2], env)) - case { it instanceof MalSymbol && it.value == "let*" }: - def let_env = new Env(env) - for (int i=0; i < ast[1].size(); i += 2) { - let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) - } - return EVAL(ast[2], let_env) - default: - def el = eval_ast(ast, env) - def (f, args) = [el[0], el[1..-1]] - f(args) - } -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -repl_env = new Env(); -repl_env.set(new MalSymbol("+"), { a -> a[0]+a[1]}); -repl_env.set(new MalSymbol("-"), { a -> a[0]-a[1]}); -repl_env.set(new MalSymbol("*"), { a -> a[0]*a[1]}); -repl_env.set(new MalSymbol("/"), { a -> a[0]/a[1]}); // / -REP = { str -> - PRINT(EVAL(READ(str), repl_env)) -} - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types +import types.MalException +import types.MalSymbol +import env.Env + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +eval_ast = { ast, env -> + switch (ast) { + case MalSymbol: return env.get(ast); + case List: return types.vector_Q(ast) ? + types.vector(ast.collect { EVAL(it,env) }) : + ast.collect { EVAL(it,env) } + case Map: def new_hm = [:] + ast.each { k,v -> + new_hm[k] = EVAL(v, env) + } + return new_hm + default: return ast + } +} + +EVAL = { ast, env -> + //println("EVAL: ${printer.pr_str(ast,true)}") + if (! types.list_Q(ast)) return eval_ast(ast, env) + if (ast.size() == 0) return ast + + switch (ast[0]) { + case { it instanceof MalSymbol && it.value == "def!" }: + return env.set(ast[1], EVAL(ast[2], env)) + case { it instanceof MalSymbol && it.value == "let*" }: + def let_env = new Env(env) + for (int i=0; i < ast[1].size(); i += 2) { + let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) + } + return EVAL(ast[2], let_env) + default: + def el = eval_ast(ast, env) + def (f, args) = [el[0], el[1..-1]] + f(args) + } +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +repl_env = new Env(); +repl_env.set(new MalSymbol("+"), { a -> a[0]+a[1]}); +repl_env.set(new MalSymbol("-"), { a -> a[0]-a[1]}); +repl_env.set(new MalSymbol("*"), { a -> a[0]*a[1]}); +repl_env.set(new MalSymbol("/"), { a -> a[0]/a[1]}); // / +REP = { str -> + PRINT(EVAL(READ(str), repl_env)) +} + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/step4_if_fn_do.groovy b/impls/groovy/step4_if_fn_do.groovy index 5d873f910b..dc6c93d517 100644 --- a/impls/groovy/step4_if_fn_do.groovy +++ b/impls/groovy/step4_if_fn_do.groovy @@ -1,100 +1,100 @@ -import reader -import printer -import types -import types.MalException -import types.MalSymbol -import types.MalFunc -import env.Env -import core - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -eval_ast = { ast, env -> - switch (ast) { - case MalSymbol: return env.get(ast); - case List: return types.vector_Q(ast) ? - types.vector(ast.collect { EVAL(it,env) }) : - ast.collect { EVAL(it,env) } - case Map: def new_hm = [:] - ast.each { k,v -> - new_hm[k] = EVAL(v, env) - } - return new_hm - default: return ast - } -} - -EVAL = { ast, env -> - //println("EVAL: ${printer.pr_str(ast,true)}") - if (! types.list_Q(ast)) return eval_ast(ast, env) - if (ast.size() == 0) return ast - - switch (ast[0]) { - case { it instanceof MalSymbol && it.value == "def!" }: - return env.set(ast[1], EVAL(ast[2], env)) - case { it instanceof MalSymbol && it.value == "let*" }: - def let_env = new Env(env) - for (int i=0; i < ast[1].size(); i += 2) { - let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) - } - return EVAL(ast[2], let_env) - case { it instanceof MalSymbol && it.value == "do" }: - return eval_ast(ast[1..-1], env)[-1] - case { it instanceof MalSymbol && it.value == "if" }: - def cond = EVAL(ast[1], env) - if (cond == false || cond == null) { - if (ast.size > 3) { - return EVAL(ast[3], env) - } else { - return null - } - } else { - return EVAL(ast[2], env) - } - case { it instanceof MalSymbol && it.value == "fn*" }: - return new MalFunc(EVAL, ast[2], env, ast[1]) - default: - def el = eval_ast(ast, env) - def (f, args) = [el[0], el.size() > 1 ? el[1..-1] : []] - f(args) - } -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -repl_env = new Env(); -REP = { str -> - PRINT(EVAL(READ(str), repl_env)) -} - -// core.EXT: defined using Groovy -core.ns.each { k,v -> - repl_env.set(new MalSymbol(k), v) -} - -// core.mal: defined using mal itself -REP("(def! not (fn* (a) (if a false true)))") - - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types +import types.MalException +import types.MalSymbol +import types.MalFunc +import env.Env +import core + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +eval_ast = { ast, env -> + switch (ast) { + case MalSymbol: return env.get(ast); + case List: return types.vector_Q(ast) ? + types.vector(ast.collect { EVAL(it,env) }) : + ast.collect { EVAL(it,env) } + case Map: def new_hm = [:] + ast.each { k,v -> + new_hm[k] = EVAL(v, env) + } + return new_hm + default: return ast + } +} + +EVAL = { ast, env -> + //println("EVAL: ${printer.pr_str(ast,true)}") + if (! types.list_Q(ast)) return eval_ast(ast, env) + if (ast.size() == 0) return ast + + switch (ast[0]) { + case { it instanceof MalSymbol && it.value == "def!" }: + return env.set(ast[1], EVAL(ast[2], env)) + case { it instanceof MalSymbol && it.value == "let*" }: + def let_env = new Env(env) + for (int i=0; i < ast[1].size(); i += 2) { + let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) + } + return EVAL(ast[2], let_env) + case { it instanceof MalSymbol && it.value == "do" }: + return eval_ast(ast[1..-1], env)[-1] + case { it instanceof MalSymbol && it.value == "if" }: + def cond = EVAL(ast[1], env) + if (cond == false || cond == null) { + if (ast.size > 3) { + return EVAL(ast[3], env) + } else { + return null + } + } else { + return EVAL(ast[2], env) + } + case { it instanceof MalSymbol && it.value == "fn*" }: + return new MalFunc(EVAL, ast[2], env, ast[1]) + default: + def el = eval_ast(ast, env) + def (f, args) = [el[0], el.size() > 1 ? el[1..-1] : []] + f(args) + } +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +repl_env = new Env(); +REP = { str -> + PRINT(EVAL(READ(str), repl_env)) +} + +// core.EXT: defined using Groovy +core.ns.each { k,v -> + repl_env.set(new MalSymbol(k), v) +} + +// core.mal: defined using mal itself +REP("(def! not (fn* (a) (if a false true)))") + + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/step5_tco.groovy b/impls/groovy/step5_tco.groovy index fb020fc799..0287edcf98 100644 --- a/impls/groovy/step5_tco.groovy +++ b/impls/groovy/step5_tco.groovy @@ -1,116 +1,116 @@ -import reader -import printer -import types -import types.MalException -import types.MalSymbol -import types.MalFunc -import env.Env -import core - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -eval_ast = { ast, env -> - switch (ast) { - case MalSymbol: return env.get(ast); - case List: return types.vector_Q(ast) ? - types.vector(ast.collect { EVAL(it,env) }) : - ast.collect { EVAL(it,env) } - case Map: def new_hm = [:] - ast.each { k,v -> - new_hm[k] = EVAL(v, env) - } - return new_hm - default: return ast - } -} - -EVAL = { ast, env -> - while (true) { - //println("EVAL: ${printer.pr_str(ast,true)}") - if (! types.list_Q(ast)) return eval_ast(ast, env) - if (ast.size() == 0) return ast - - switch (ast[0]) { - case { it instanceof MalSymbol && it.value == "def!" }: - return env.set(ast[1], EVAL(ast[2], env)) - case { it instanceof MalSymbol && it.value == "let*" }: - def let_env = new Env(env) - for (int i=0; i < ast[1].size(); i += 2) { - let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) - } - env = let_env - ast = ast[2] - break // TCO - case { it instanceof MalSymbol && it.value == "do" }: - ast.size() > 2 ? eval_ast(ast[1..-2], env) : null - ast = ast[-1] - break // TCO - case { it instanceof MalSymbol && it.value == "if" }: - def cond = EVAL(ast[1], env) - if (cond == false || cond == null) { - if (ast.size > 3) { - ast = ast[3] - break // TCO - } else { - return null - } - } else { - ast = ast[2] - break // TCO - } - case { it instanceof MalSymbol && it.value == "fn*" }: - return new MalFunc(EVAL, ast[2], env, ast[1]) - default: - def el = eval_ast(ast, env) - def (f, args) = [el[0], el.size() > 1 ? el[1..-1] : []] - if (f instanceof MalFunc) { - env = new Env(f.env, f.params, args) - ast = f.ast - break // TCO - } else { - return f(args) - } - } - } -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -repl_env = new Env(); -REP = { str -> - PRINT(EVAL(READ(str), repl_env)) -} - -// core.EXT: defined using Groovy -core.ns.each { k,v -> - repl_env.set(new MalSymbol(k), v) -} - -// core.mal: defined using mal itself -REP("(def! not (fn* (a) (if a false true)))") - - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(StackOverflowError ex) { - println "Error: ${ex}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types +import types.MalException +import types.MalSymbol +import types.MalFunc +import env.Env +import core + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +eval_ast = { ast, env -> + switch (ast) { + case MalSymbol: return env.get(ast); + case List: return types.vector_Q(ast) ? + types.vector(ast.collect { EVAL(it,env) }) : + ast.collect { EVAL(it,env) } + case Map: def new_hm = [:] + ast.each { k,v -> + new_hm[k] = EVAL(v, env) + } + return new_hm + default: return ast + } +} + +EVAL = { ast, env -> + while (true) { + //println("EVAL: ${printer.pr_str(ast,true)}") + if (! types.list_Q(ast)) return eval_ast(ast, env) + if (ast.size() == 0) return ast + + switch (ast[0]) { + case { it instanceof MalSymbol && it.value == "def!" }: + return env.set(ast[1], EVAL(ast[2], env)) + case { it instanceof MalSymbol && it.value == "let*" }: + def let_env = new Env(env) + for (int i=0; i < ast[1].size(); i += 2) { + let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) + } + env = let_env + ast = ast[2] + break // TCO + case { it instanceof MalSymbol && it.value == "do" }: + ast.size() > 2 ? eval_ast(ast[1..-2], env) : null + ast = ast[-1] + break // TCO + case { it instanceof MalSymbol && it.value == "if" }: + def cond = EVAL(ast[1], env) + if (cond == false || cond == null) { + if (ast.size > 3) { + ast = ast[3] + break // TCO + } else { + return null + } + } else { + ast = ast[2] + break // TCO + } + case { it instanceof MalSymbol && it.value == "fn*" }: + return new MalFunc(EVAL, ast[2], env, ast[1]) + default: + def el = eval_ast(ast, env) + def (f, args) = [el[0], el.size() > 1 ? el[1..-1] : []] + if (f instanceof MalFunc) { + env = new Env(f.env, f.params, args) + ast = f.ast + break // TCO + } else { + return f(args) + } + } + } +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +repl_env = new Env(); +REP = { str -> + PRINT(EVAL(READ(str), repl_env)) +} + +// core.EXT: defined using Groovy +core.ns.each { k,v -> + repl_env.set(new MalSymbol(k), v) +} + +// core.mal: defined using mal itself +REP("(def! not (fn* (a) (if a false true)))") + + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(StackOverflowError ex) { + println "Error: ${ex}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/step6_file.groovy b/impls/groovy/step6_file.groovy index 95ab1c22b2..65dab1e7dd 100644 --- a/impls/groovy/step6_file.groovy +++ b/impls/groovy/step6_file.groovy @@ -1,124 +1,124 @@ -import reader -import printer -import types -import types.MalException -import types.MalSymbol -import types.MalFunc -import env.Env -import core - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -eval_ast = { ast, env -> - switch (ast) { - case MalSymbol: return env.get(ast); - case List: return types.vector_Q(ast) ? - types.vector(ast.collect { EVAL(it,env) }) : - ast.collect { EVAL(it,env) } - case Map: def new_hm = [:] - ast.each { k,v -> - new_hm[k] = EVAL(v, env) - } - return new_hm - default: return ast - } -} - -EVAL = { ast, env -> - while (true) { - //println("EVAL: ${printer.pr_str(ast,true)}") - if (! types.list_Q(ast)) return eval_ast(ast, env) - if (ast.size() == 0) return ast - - switch (ast[0]) { - case { it instanceof MalSymbol && it.value == "def!" }: - return env.set(ast[1], EVAL(ast[2], env)) - case { it instanceof MalSymbol && it.value == "let*" }: - def let_env = new Env(env) - for (int i=0; i < ast[1].size(); i += 2) { - let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) - } - env = let_env - ast = ast[2] - break // TCO - case { it instanceof MalSymbol && it.value == "do" }: - ast.size() > 2 ? eval_ast(ast[1..-2], env) : null - ast = ast[-1] - break // TCO - case { it instanceof MalSymbol && it.value == "if" }: - def cond = EVAL(ast[1], env) - if (cond == false || cond == null) { - if (ast.size > 3) { - ast = ast[3] - break // TCO - } else { - return null - } - } else { - ast = ast[2] - break // TCO - } - case { it instanceof MalSymbol && it.value == "fn*" }: - return new MalFunc(EVAL, ast[2], env, ast[1]) - default: - def el = eval_ast(ast, env) - def (f, args) = [el[0], el.drop(1)] - if (f instanceof MalFunc) { - env = new Env(f.env, f.params, args) - ast = f.ast - break // TCO - } else { - return f(args) - } - } - } -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -repl_env = new Env(); -REP = { str -> - PRINT(EVAL(READ(str), repl_env)) -} - -// core.EXT: defined using Groovy -core.ns.each { k,v -> - repl_env.set(new MalSymbol(k), v) -} -repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) -repl_env.set(new MalSymbol("*ARGV*"), this.args as List) - -// core.mal: defined using mal itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if (this.args.size() > 0) { - repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) - REP("(load-file \"${this.args[0]}\")") - System.exit(0) -} - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(StackOverflowError ex) { - println "Error: ${ex}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types +import types.MalException +import types.MalSymbol +import types.MalFunc +import env.Env +import core + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +eval_ast = { ast, env -> + switch (ast) { + case MalSymbol: return env.get(ast); + case List: return types.vector_Q(ast) ? + types.vector(ast.collect { EVAL(it,env) }) : + ast.collect { EVAL(it,env) } + case Map: def new_hm = [:] + ast.each { k,v -> + new_hm[k] = EVAL(v, env) + } + return new_hm + default: return ast + } +} + +EVAL = { ast, env -> + while (true) { + //println("EVAL: ${printer.pr_str(ast,true)}") + if (! types.list_Q(ast)) return eval_ast(ast, env) + if (ast.size() == 0) return ast + + switch (ast[0]) { + case { it instanceof MalSymbol && it.value == "def!" }: + return env.set(ast[1], EVAL(ast[2], env)) + case { it instanceof MalSymbol && it.value == "let*" }: + def let_env = new Env(env) + for (int i=0; i < ast[1].size(); i += 2) { + let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) + } + env = let_env + ast = ast[2] + break // TCO + case { it instanceof MalSymbol && it.value == "do" }: + ast.size() > 2 ? eval_ast(ast[1..-2], env) : null + ast = ast[-1] + break // TCO + case { it instanceof MalSymbol && it.value == "if" }: + def cond = EVAL(ast[1], env) + if (cond == false || cond == null) { + if (ast.size > 3) { + ast = ast[3] + break // TCO + } else { + return null + } + } else { + ast = ast[2] + break // TCO + } + case { it instanceof MalSymbol && it.value == "fn*" }: + return new MalFunc(EVAL, ast[2], env, ast[1]) + default: + def el = eval_ast(ast, env) + def (f, args) = [el[0], el.drop(1)] + if (f instanceof MalFunc) { + env = new Env(f.env, f.params, args) + ast = f.ast + break // TCO + } else { + return f(args) + } + } + } +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +repl_env = new Env(); +REP = { str -> + PRINT(EVAL(READ(str), repl_env)) +} + +// core.EXT: defined using Groovy +core.ns.each { k,v -> + repl_env.set(new MalSymbol(k), v) +} +repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) +repl_env.set(new MalSymbol("*ARGV*"), this.args as List) + +// core.mal: defined using mal itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if (this.args.size() > 0) { + repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) + REP("(load-file \"${this.args[0]}\")") + System.exit(0) +} + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(StackOverflowError ex) { + println "Error: ${ex}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/step7_quote.groovy b/impls/groovy/step7_quote.groovy index b6010efb85..1cee809b96 100644 --- a/impls/groovy/step7_quote.groovy +++ b/impls/groovy/step7_quote.groovy @@ -1,164 +1,164 @@ -import reader -import printer -import types -import types.MalException -import types.MalSymbol -import types.MalFunc -import env.Env -import core - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -starts_with = { lst, sym -> - lst.size() == 2 && lst[0].class == MalSymbol && lst[0].value == sym -} -qq_loop = { elt, acc -> - if (types.list_Q(elt) && starts_with(elt, "splice-unquote")) { - return [new MalSymbol("concat"), elt[1], acc] - } else { - return [new MalSymbol("cons"), quasiquote(elt), acc] - } -} -qq_foldr = { xs -> - def acc = [] - for (int i=xs.size()-1; 0<=i; i-=1) { - acc = qq_loop(xs[i], acc) - } - return acc -} -quasiquote = { ast -> - switch (ast) { - case List: - if (types.vector_Q(ast)) { - return [new MalSymbol("vec"), qq_foldr(ast)] - } else if (starts_with(ast, "unquote")) { - return ast[1] - } else { - return qq_foldr(ast) - } - case MalSymbol: return [new MalSymbol("quote"), ast] - case Map: return [new MalSymbol("quote"), ast] - default: return ast - } -} - -eval_ast = { ast, env -> - switch (ast) { - case MalSymbol: return env.get(ast); - case List: return types.vector_Q(ast) ? - types.vector(ast.collect { EVAL(it,env) }) : - ast.collect { EVAL(it,env) } - case Map: def new_hm = [:] - ast.each { k,v -> - new_hm[k] = EVAL(v, env) - } - return new_hm - default: return ast - } -} - -EVAL = { ast, env -> - while (true) { - //println("EVAL: ${printer.pr_str(ast,true)}") - if (! types.list_Q(ast)) return eval_ast(ast, env) - if (ast.size() == 0) return ast - - switch (ast[0]) { - case { it instanceof MalSymbol && it.value == "def!" }: - return env.set(ast[1], EVAL(ast[2], env)) - case { it instanceof MalSymbol && it.value == "let*" }: - def let_env = new Env(env) - for (int i=0; i < ast[1].size(); i += 2) { - let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) - } - env = let_env - ast = ast[2] - break // TCO - case { it instanceof MalSymbol && it.value == "quote" }: - return ast[1] - case { it instanceof MalSymbol && it.value == "quasiquoteexpand" }: - return quasiquote(ast[1]) - case { it instanceof MalSymbol && it.value == "quasiquote" }: - ast = quasiquote(ast[1]) - break // TCO - case { it instanceof MalSymbol && it.value == "do" }: - ast.size() > 2 ? eval_ast(ast[1..-2], env) : null - ast = ast[-1] - break // TCO - case { it instanceof MalSymbol && it.value == "if" }: - def cond = EVAL(ast[1], env) - if (cond == false || cond == null) { - if (ast.size > 3) { - ast = ast[3] - break // TCO - } else { - return null - } - } else { - ast = ast[2] - break // TCO - } - case { it instanceof MalSymbol && it.value == "fn*" }: - return new MalFunc(EVAL, ast[2], env, ast[1]) - default: - def el = eval_ast(ast, env) - def (f, args) = [el[0], el.drop(1)] - if (f instanceof MalFunc) { - env = new Env(f.env, f.params, args) - ast = f.ast - break // TCO - } else { - return f(args) - } - } - } -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -repl_env = new Env(); -REP = { str -> - PRINT(EVAL(READ(str), repl_env)) -} - -// core.EXT: defined using Groovy -core.ns.each { k,v -> - repl_env.set(new MalSymbol(k), v) -} -repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) -repl_env.set(new MalSymbol("*ARGV*"), this.args as List) - -// core.mal: defined using mal itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if (this.args.size() > 0) { - repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) - REP("(load-file \"${this.args[0]}\")") - System.exit(0) -} - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(StackOverflowError ex) { - println "Error: ${ex}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types +import types.MalException +import types.MalSymbol +import types.MalFunc +import env.Env +import core + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +starts_with = { lst, sym -> + lst.size() == 2 && lst[0].class == MalSymbol && lst[0].value == sym +} +qq_loop = { elt, acc -> + if (types.list_Q(elt) && starts_with(elt, "splice-unquote")) { + return [new MalSymbol("concat"), elt[1], acc] + } else { + return [new MalSymbol("cons"), quasiquote(elt), acc] + } +} +qq_foldr = { xs -> + def acc = [] + for (int i=xs.size()-1; 0<=i; i-=1) { + acc = qq_loop(xs[i], acc) + } + return acc +} +quasiquote = { ast -> + switch (ast) { + case List: + if (types.vector_Q(ast)) { + return [new MalSymbol("vec"), qq_foldr(ast)] + } else if (starts_with(ast, "unquote")) { + return ast[1] + } else { + return qq_foldr(ast) + } + case MalSymbol: return [new MalSymbol("quote"), ast] + case Map: return [new MalSymbol("quote"), ast] + default: return ast + } +} + +eval_ast = { ast, env -> + switch (ast) { + case MalSymbol: return env.get(ast); + case List: return types.vector_Q(ast) ? + types.vector(ast.collect { EVAL(it,env) }) : + ast.collect { EVAL(it,env) } + case Map: def new_hm = [:] + ast.each { k,v -> + new_hm[k] = EVAL(v, env) + } + return new_hm + default: return ast + } +} + +EVAL = { ast, env -> + while (true) { + //println("EVAL: ${printer.pr_str(ast,true)}") + if (! types.list_Q(ast)) return eval_ast(ast, env) + if (ast.size() == 0) return ast + + switch (ast[0]) { + case { it instanceof MalSymbol && it.value == "def!" }: + return env.set(ast[1], EVAL(ast[2], env)) + case { it instanceof MalSymbol && it.value == "let*" }: + def let_env = new Env(env) + for (int i=0; i < ast[1].size(); i += 2) { + let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) + } + env = let_env + ast = ast[2] + break // TCO + case { it instanceof MalSymbol && it.value == "quote" }: + return ast[1] + case { it instanceof MalSymbol && it.value == "quasiquoteexpand" }: + return quasiquote(ast[1]) + case { it instanceof MalSymbol && it.value == "quasiquote" }: + ast = quasiquote(ast[1]) + break // TCO + case { it instanceof MalSymbol && it.value == "do" }: + ast.size() > 2 ? eval_ast(ast[1..-2], env) : null + ast = ast[-1] + break // TCO + case { it instanceof MalSymbol && it.value == "if" }: + def cond = EVAL(ast[1], env) + if (cond == false || cond == null) { + if (ast.size > 3) { + ast = ast[3] + break // TCO + } else { + return null + } + } else { + ast = ast[2] + break // TCO + } + case { it instanceof MalSymbol && it.value == "fn*" }: + return new MalFunc(EVAL, ast[2], env, ast[1]) + default: + def el = eval_ast(ast, env) + def (f, args) = [el[0], el.drop(1)] + if (f instanceof MalFunc) { + env = new Env(f.env, f.params, args) + ast = f.ast + break // TCO + } else { + return f(args) + } + } + } +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +repl_env = new Env(); +REP = { str -> + PRINT(EVAL(READ(str), repl_env)) +} + +// core.EXT: defined using Groovy +core.ns.each { k,v -> + repl_env.set(new MalSymbol(k), v) +} +repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) +repl_env.set(new MalSymbol("*ARGV*"), this.args as List) + +// core.mal: defined using mal itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if (this.args.size() > 0) { + repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) + REP("(load-file \"${this.args[0]}\")") + System.exit(0) +} + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(StackOverflowError ex) { + println "Error: ${ex}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/step8_macros.groovy b/impls/groovy/step8_macros.groovy index a7c110d421..e20720f6b3 100644 --- a/impls/groovy/step8_macros.groovy +++ b/impls/groovy/step8_macros.groovy @@ -1,196 +1,196 @@ -import reader -import printer -import types -import types.MalException -import types.MalSymbol -import types.MalFunc -import env.Env -import core - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -macro_Q = { ast, env -> - if (types.list_Q(ast) && - ast.size() > 0 && - ast[0].class == MalSymbol && - env.find(ast[0])) { - def obj = env.get(ast[0]) - if (obj instanceof MalFunc && obj.ismacro) { - return true - } - } - return false -} -macroexpand = { ast, env -> - while (macro_Q(ast, env)) { - def mac = env.get(ast[0]) - ast = mac(ast.drop(1)) - } - return ast -} - -starts_with = { lst, sym -> - lst.size() == 2 && lst[0].class == MalSymbol && lst[0].value == sym -} -qq_loop = { elt, acc -> - if (types.list_Q(elt) && starts_with(elt, "splice-unquote")) { - return [new MalSymbol("concat"), elt[1], acc] - } else { - return [new MalSymbol("cons"), quasiquote(elt), acc] - } -} -qq_foldr = { xs -> - def acc = [] - for (int i=xs.size()-1; 0<=i; i-=1) { - acc = qq_loop(xs[i], acc) - } - return acc -} -quasiquote = { ast -> - switch (ast) { - case List: - if (types.vector_Q(ast)) { - return [new MalSymbol("vec"), qq_foldr(ast)] - } else if (starts_with(ast, "unquote")) { - return ast[1] - } else { - return qq_foldr(ast) - } - case MalSymbol: return [new MalSymbol("quote"), ast] - case Map: return [new MalSymbol("quote"), ast] - default: return ast - } -} - -eval_ast = { ast, env -> - switch (ast) { - case MalSymbol: return env.get(ast); - case List: return types.vector_Q(ast) ? - types.vector(ast.collect { EVAL(it,env) }) : - ast.collect { EVAL(it,env) } - case Map: def new_hm = [:] - ast.each { k,v -> - new_hm[k] = EVAL(v, env) - } - return new_hm - default: return ast - } -} - -EVAL = { ast, env -> - while (true) { - //println("EVAL: ${printer.pr_str(ast,true)}") - if (! types.list_Q(ast)) return eval_ast(ast, env) - - ast = macroexpand(ast, env) - if (! types.list_Q(ast)) return eval_ast(ast, env) - if (ast.size() == 0) return ast - - switch (ast[0]) { - case { it instanceof MalSymbol && it.value == "def!" }: - return env.set(ast[1], EVAL(ast[2], env)) - case { it instanceof MalSymbol && it.value == "let*" }: - def let_env = new Env(env) - for (int i=0; i < ast[1].size(); i += 2) { - let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) - } - env = let_env - ast = ast[2] - break // TCO - case { it instanceof MalSymbol && it.value == "quote" }: - return ast[1] - case { it instanceof MalSymbol && it.value == "quasiquoteexpand" }: - return quasiquote(ast[1]) - case { it instanceof MalSymbol && it.value == "quasiquote" }: - ast = quasiquote(ast[1]) - break // TCO - case { it instanceof MalSymbol && it.value == "defmacro!" }: - def f = EVAL(ast[2], env) - f = f.clone() - f.ismacro = true - return env.set(ast[1], f) - case { it instanceof MalSymbol && it.value == "macroexpand" }: - return macroexpand(ast[1], env) - case { it instanceof MalSymbol && it.value == "do" }: - ast.size() > 2 ? eval_ast(ast[1..-2], env) : null - ast = ast[-1] - break // TCO - case { it instanceof MalSymbol && it.value == "if" }: - def cond = EVAL(ast[1], env) - if (cond == false || cond == null) { - if (ast.size > 3) { - ast = ast[3] - break // TCO - } else { - return null - } - } else { - ast = ast[2] - break // TCO - } - case { it instanceof MalSymbol && it.value == "fn*" }: - return new MalFunc(EVAL, ast[2], env, ast[1]) - default: - def el = eval_ast(ast, env) - def (f, args) = [el[0], el.drop(1)] - if (f instanceof MalFunc) { - env = new Env(f.env, f.params, args) - ast = f.ast - break // TCO - } else { - return f(args) - } - } - } -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -repl_env = new Env(); -REP = { str -> - PRINT(EVAL(READ(str), repl_env)) -} - -// core.EXT: defined using Groovy -core.ns.each { k,v -> - repl_env.set(new MalSymbol(k), v) -} -repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) -repl_env.set(new MalSymbol("*ARGV*"), this.args as List) - -// core.mal: defined using mal itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))"); - - -if (this.args.size() > 0) { - repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) - REP("(load-file \"${this.args[0]}\")") - System.exit(0) -} - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(StackOverflowError ex) { - println "Error: ${ex}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types +import types.MalException +import types.MalSymbol +import types.MalFunc +import env.Env +import core + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +macro_Q = { ast, env -> + if (types.list_Q(ast) && + ast.size() > 0 && + ast[0].class == MalSymbol && + env.find(ast[0])) { + def obj = env.get(ast[0]) + if (obj instanceof MalFunc && obj.ismacro) { + return true + } + } + return false +} +macroexpand = { ast, env -> + while (macro_Q(ast, env)) { + def mac = env.get(ast[0]) + ast = mac(ast.drop(1)) + } + return ast +} + +starts_with = { lst, sym -> + lst.size() == 2 && lst[0].class == MalSymbol && lst[0].value == sym +} +qq_loop = { elt, acc -> + if (types.list_Q(elt) && starts_with(elt, "splice-unquote")) { + return [new MalSymbol("concat"), elt[1], acc] + } else { + return [new MalSymbol("cons"), quasiquote(elt), acc] + } +} +qq_foldr = { xs -> + def acc = [] + for (int i=xs.size()-1; 0<=i; i-=1) { + acc = qq_loop(xs[i], acc) + } + return acc +} +quasiquote = { ast -> + switch (ast) { + case List: + if (types.vector_Q(ast)) { + return [new MalSymbol("vec"), qq_foldr(ast)] + } else if (starts_with(ast, "unquote")) { + return ast[1] + } else { + return qq_foldr(ast) + } + case MalSymbol: return [new MalSymbol("quote"), ast] + case Map: return [new MalSymbol("quote"), ast] + default: return ast + } +} + +eval_ast = { ast, env -> + switch (ast) { + case MalSymbol: return env.get(ast); + case List: return types.vector_Q(ast) ? + types.vector(ast.collect { EVAL(it,env) }) : + ast.collect { EVAL(it,env) } + case Map: def new_hm = [:] + ast.each { k,v -> + new_hm[k] = EVAL(v, env) + } + return new_hm + default: return ast + } +} + +EVAL = { ast, env -> + while (true) { + //println("EVAL: ${printer.pr_str(ast,true)}") + if (! types.list_Q(ast)) return eval_ast(ast, env) + + ast = macroexpand(ast, env) + if (! types.list_Q(ast)) return eval_ast(ast, env) + if (ast.size() == 0) return ast + + switch (ast[0]) { + case { it instanceof MalSymbol && it.value == "def!" }: + return env.set(ast[1], EVAL(ast[2], env)) + case { it instanceof MalSymbol && it.value == "let*" }: + def let_env = new Env(env) + for (int i=0; i < ast[1].size(); i += 2) { + let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) + } + env = let_env + ast = ast[2] + break // TCO + case { it instanceof MalSymbol && it.value == "quote" }: + return ast[1] + case { it instanceof MalSymbol && it.value == "quasiquoteexpand" }: + return quasiquote(ast[1]) + case { it instanceof MalSymbol && it.value == "quasiquote" }: + ast = quasiquote(ast[1]) + break // TCO + case { it instanceof MalSymbol && it.value == "defmacro!" }: + def f = EVAL(ast[2], env) + f = f.clone() + f.ismacro = true + return env.set(ast[1], f) + case { it instanceof MalSymbol && it.value == "macroexpand" }: + return macroexpand(ast[1], env) + case { it instanceof MalSymbol && it.value == "do" }: + ast.size() > 2 ? eval_ast(ast[1..-2], env) : null + ast = ast[-1] + break // TCO + case { it instanceof MalSymbol && it.value == "if" }: + def cond = EVAL(ast[1], env) + if (cond == false || cond == null) { + if (ast.size > 3) { + ast = ast[3] + break // TCO + } else { + return null + } + } else { + ast = ast[2] + break // TCO + } + case { it instanceof MalSymbol && it.value == "fn*" }: + return new MalFunc(EVAL, ast[2], env, ast[1]) + default: + def el = eval_ast(ast, env) + def (f, args) = [el[0], el.drop(1)] + if (f instanceof MalFunc) { + env = new Env(f.env, f.params, args) + ast = f.ast + break // TCO + } else { + return f(args) + } + } + } +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +repl_env = new Env(); +REP = { str -> + PRINT(EVAL(READ(str), repl_env)) +} + +// core.EXT: defined using Groovy +core.ns.each { k,v -> + repl_env.set(new MalSymbol(k), v) +} +repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) +repl_env.set(new MalSymbol("*ARGV*"), this.args as List) + +// core.mal: defined using mal itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))"); + + +if (this.args.size() > 0) { + repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) + REP("(load-file \"${this.args[0]}\")") + System.exit(0) +} + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(StackOverflowError ex) { + println "Error: ${ex}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/step9_try.groovy b/impls/groovy/step9_try.groovy index 46d68f583a..d8c2712e89 100644 --- a/impls/groovy/step9_try.groovy +++ b/impls/groovy/step9_try.groovy @@ -1,214 +1,214 @@ -import reader -import printer -import types -import types.MalException -import types.MalSymbol -import types.MalFunc -import env.Env -import core - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -macro_Q = { ast, env -> - if (types.list_Q(ast) && - ast.size() > 0 && - ast[0].class == MalSymbol && - env.find(ast[0])) { - def obj = env.get(ast[0]) - if (obj instanceof MalFunc && obj.ismacro) { - return true - } - } - return false -} -macroexpand = { ast, env -> - while (macro_Q(ast, env)) { - def mac = env.get(ast[0]) - ast = mac(ast.drop(1)) - } - return ast -} - -starts_with = { lst, sym -> - lst.size() == 2 && lst[0].class == MalSymbol && lst[0].value == sym -} -qq_loop = { elt, acc -> - if (types.list_Q(elt) && starts_with(elt, "splice-unquote")) { - return [new MalSymbol("concat"), elt[1], acc] - } else { - return [new MalSymbol("cons"), quasiquote(elt), acc] - } -} -qq_foldr = { xs -> - def acc = [] - for (int i=xs.size()-1; 0<=i; i-=1) { - acc = qq_loop(xs[i], acc) - } - return acc -} -quasiquote = { ast -> - switch (ast) { - case List: - if (types.vector_Q(ast)) { - return [new MalSymbol("vec"), qq_foldr(ast)] - } else if (starts_with(ast, "unquote")) { - return ast[1] - } else { - return qq_foldr(ast) - } - case MalSymbol: return [new MalSymbol("quote"), ast] - case Map: return [new MalSymbol("quote"), ast] - default: return ast - } -} - -eval_ast = { ast, env -> - switch (ast) { - case MalSymbol: return env.get(ast); - case List: return types.vector_Q(ast) ? - types.vector(ast.collect { EVAL(it,env) }) : - ast.collect { EVAL(it,env) } - case Map: def new_hm = [:] - ast.each { k,v -> - new_hm[k] = EVAL(v, env) - } - return new_hm - default: return ast - } -} - -EVAL = { ast, env -> - while (true) { - //println("EVAL: ${printer.pr_str(ast,true)}") - if (! types.list_Q(ast)) return eval_ast(ast, env) - - ast = macroexpand(ast, env) - if (! types.list_Q(ast)) return eval_ast(ast, env) - if (ast.size() == 0) return ast - - switch (ast[0]) { - case { it instanceof MalSymbol && it.value == "def!" }: - return env.set(ast[1], EVAL(ast[2], env)) - case { it instanceof MalSymbol && it.value == "let*" }: - def let_env = new Env(env) - for (int i=0; i < ast[1].size(); i += 2) { - let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) - } - env = let_env - ast = ast[2] - break // TCO - case { it instanceof MalSymbol && it.value == "quote" }: - return ast[1] - case { it instanceof MalSymbol && it.value == "quasiquoteexpand" }: - return quasiquote(ast[1]) - case { it instanceof MalSymbol && it.value == "quasiquote" }: - ast = quasiquote(ast[1]) - break // TCO - case { it instanceof MalSymbol && it.value == "defmacro!" }: - def f = EVAL(ast[2], env) - f = f.clone() - f.ismacro = true - return env.set(ast[1], f) - case { it instanceof MalSymbol && it.value == "macroexpand" }: - return macroexpand(ast[1], env) - case { it instanceof MalSymbol && it.value == "try*" }: - try { - return EVAL(ast[1], env) - } catch(exc) { - if (ast.size() > 2 && - ast[2][0] instanceof MalSymbol && - ast[2][0].value == "catch*") { - def e = null - if (exc instanceof MalException) { - e = exc.obj - } else { - e = exc.message - } - return EVAL(ast[2][2], new Env(env, [ast[2][1]], [e])) - } else { - throw exc - } - } - case { it instanceof MalSymbol && it.value == "do" }: - ast.size() > 2 ? eval_ast(ast[1..-2], env) : null - ast = ast[-1] - break // TCO - case { it instanceof MalSymbol && it.value == "if" }: - def cond = EVAL(ast[1], env) - if (cond == false || cond == null) { - if (ast.size > 3) { - ast = ast[3] - break // TCO - } else { - return null - } - } else { - ast = ast[2] - break // TCO - } - case { it instanceof MalSymbol && it.value == "fn*" }: - return new MalFunc(EVAL, ast[2], env, ast[1]) - default: - def el = eval_ast(ast, env) - def (f, args) = [el[0], el.drop(1)] - if (f instanceof MalFunc) { - env = new Env(f.env, f.params, args) - ast = f.ast - break // TCO - } else { - return f(args) - } - } - } -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -repl_env = new Env(); -REP = { str -> - PRINT(EVAL(READ(str), repl_env)) -} - -// core.EXT: defined using Groovy -core.ns.each { k,v -> - repl_env.set(new MalSymbol(k), v) -} -repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) -repl_env.set(new MalSymbol("*ARGV*"), this.args as List) - -// core.mal: defined using mal itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))"); - - -if (this.args.size() > 0) { - repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) - REP("(load-file \"${this.args[0]}\")") - System.exit(0) -} - -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(StackOverflowError ex) { - println "Error: ${ex}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types +import types.MalException +import types.MalSymbol +import types.MalFunc +import env.Env +import core + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +macro_Q = { ast, env -> + if (types.list_Q(ast) && + ast.size() > 0 && + ast[0].class == MalSymbol && + env.find(ast[0])) { + def obj = env.get(ast[0]) + if (obj instanceof MalFunc && obj.ismacro) { + return true + } + } + return false +} +macroexpand = { ast, env -> + while (macro_Q(ast, env)) { + def mac = env.get(ast[0]) + ast = mac(ast.drop(1)) + } + return ast +} + +starts_with = { lst, sym -> + lst.size() == 2 && lst[0].class == MalSymbol && lst[0].value == sym +} +qq_loop = { elt, acc -> + if (types.list_Q(elt) && starts_with(elt, "splice-unquote")) { + return [new MalSymbol("concat"), elt[1], acc] + } else { + return [new MalSymbol("cons"), quasiquote(elt), acc] + } +} +qq_foldr = { xs -> + def acc = [] + for (int i=xs.size()-1; 0<=i; i-=1) { + acc = qq_loop(xs[i], acc) + } + return acc +} +quasiquote = { ast -> + switch (ast) { + case List: + if (types.vector_Q(ast)) { + return [new MalSymbol("vec"), qq_foldr(ast)] + } else if (starts_with(ast, "unquote")) { + return ast[1] + } else { + return qq_foldr(ast) + } + case MalSymbol: return [new MalSymbol("quote"), ast] + case Map: return [new MalSymbol("quote"), ast] + default: return ast + } +} + +eval_ast = { ast, env -> + switch (ast) { + case MalSymbol: return env.get(ast); + case List: return types.vector_Q(ast) ? + types.vector(ast.collect { EVAL(it,env) }) : + ast.collect { EVAL(it,env) } + case Map: def new_hm = [:] + ast.each { k,v -> + new_hm[k] = EVAL(v, env) + } + return new_hm + default: return ast + } +} + +EVAL = { ast, env -> + while (true) { + //println("EVAL: ${printer.pr_str(ast,true)}") + if (! types.list_Q(ast)) return eval_ast(ast, env) + + ast = macroexpand(ast, env) + if (! types.list_Q(ast)) return eval_ast(ast, env) + if (ast.size() == 0) return ast + + switch (ast[0]) { + case { it instanceof MalSymbol && it.value == "def!" }: + return env.set(ast[1], EVAL(ast[2], env)) + case { it instanceof MalSymbol && it.value == "let*" }: + def let_env = new Env(env) + for (int i=0; i < ast[1].size(); i += 2) { + let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) + } + env = let_env + ast = ast[2] + break // TCO + case { it instanceof MalSymbol && it.value == "quote" }: + return ast[1] + case { it instanceof MalSymbol && it.value == "quasiquoteexpand" }: + return quasiquote(ast[1]) + case { it instanceof MalSymbol && it.value == "quasiquote" }: + ast = quasiquote(ast[1]) + break // TCO + case { it instanceof MalSymbol && it.value == "defmacro!" }: + def f = EVAL(ast[2], env) + f = f.clone() + f.ismacro = true + return env.set(ast[1], f) + case { it instanceof MalSymbol && it.value == "macroexpand" }: + return macroexpand(ast[1], env) + case { it instanceof MalSymbol && it.value == "try*" }: + try { + return EVAL(ast[1], env) + } catch(exc) { + if (ast.size() > 2 && + ast[2][0] instanceof MalSymbol && + ast[2][0].value == "catch*") { + def e = null + if (exc instanceof MalException) { + e = exc.obj + } else { + e = exc.message + } + return EVAL(ast[2][2], new Env(env, [ast[2][1]], [e])) + } else { + throw exc + } + } + case { it instanceof MalSymbol && it.value == "do" }: + ast.size() > 2 ? eval_ast(ast[1..-2], env) : null + ast = ast[-1] + break // TCO + case { it instanceof MalSymbol && it.value == "if" }: + def cond = EVAL(ast[1], env) + if (cond == false || cond == null) { + if (ast.size > 3) { + ast = ast[3] + break // TCO + } else { + return null + } + } else { + ast = ast[2] + break // TCO + } + case { it instanceof MalSymbol && it.value == "fn*" }: + return new MalFunc(EVAL, ast[2], env, ast[1]) + default: + def el = eval_ast(ast, env) + def (f, args) = [el[0], el.drop(1)] + if (f instanceof MalFunc) { + env = new Env(f.env, f.params, args) + ast = f.ast + break // TCO + } else { + return f(args) + } + } + } +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +repl_env = new Env(); +REP = { str -> + PRINT(EVAL(READ(str), repl_env)) +} + +// core.EXT: defined using Groovy +core.ns.each { k,v -> + repl_env.set(new MalSymbol(k), v) +} +repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) +repl_env.set(new MalSymbol("*ARGV*"), this.args as List) + +// core.mal: defined using mal itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))"); + + +if (this.args.size() > 0) { + repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) + REP("(load-file \"${this.args[0]}\")") + System.exit(0) +} + +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(StackOverflowError ex) { + println "Error: ${ex}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/stepA_mal.groovy b/impls/groovy/stepA_mal.groovy index 44aeb28f50..e6b9d84f28 100644 --- a/impls/groovy/stepA_mal.groovy +++ b/impls/groovy/stepA_mal.groovy @@ -1,215 +1,215 @@ -import reader -import printer -import types -import types.MalException -import types.MalSymbol -import types.MalFunc -import env.Env -import core - -// READ -READ = { str -> - reader.read_str str -} - -// EVAL -macro_Q = { ast, env -> - if (types.list_Q(ast) && - ast.size() > 0 && - ast[0].class == MalSymbol && - env.find(ast[0])) { - def obj = env.get(ast[0]) - if (obj instanceof MalFunc && obj.ismacro) { - return true - } - } - return false -} -macroexpand = { ast, env -> - while (macro_Q(ast, env)) { - def mac = env.get(ast[0]) - ast = mac(ast.drop(1)) - } - return ast -} - -starts_with = { lst, sym -> - lst.size() == 2 && lst[0].class == MalSymbol && lst[0].value == sym -} -qq_loop = { elt, acc -> - if (types.list_Q(elt) && starts_with(elt, "splice-unquote")) { - return [new MalSymbol("concat"), elt[1], acc] - } else { - return [new MalSymbol("cons"), quasiquote(elt), acc] - } -} -qq_foldr = { xs -> - def acc = [] - for (int i=xs.size()-1; 0<=i; i-=1) { - acc = qq_loop(xs[i], acc) - } - return acc -} -quasiquote = { ast -> - switch (ast) { - case List: - if (types.vector_Q(ast)) { - return [new MalSymbol("vec"), qq_foldr(ast)] - } else if (starts_with(ast, "unquote")) { - return ast[1] - } else { - return qq_foldr(ast) - } - case MalSymbol: return [new MalSymbol("quote"), ast] - case Map: return [new MalSymbol("quote"), ast] - default: return ast - } -} - -eval_ast = { ast, env -> - switch (ast) { - case MalSymbol: return env.get(ast); - case List: return types.vector_Q(ast) ? - types.vector(ast.collect { EVAL(it,env) }) : - ast.collect { EVAL(it,env) } - case Map: def new_hm = [:] - ast.each { k,v -> - new_hm[k] = EVAL(v, env) - } - return new_hm - default: return ast - } -} - -EVAL = { ast, env -> - while (true) { - //println("EVAL: ${printer.pr_str(ast,true)}") - if (! types.list_Q(ast)) return eval_ast(ast, env) - - ast = macroexpand(ast, env) - if (! types.list_Q(ast)) return eval_ast(ast, env) - if (ast.size() == 0) return ast - - switch (ast[0]) { - case { it instanceof MalSymbol && it.value == "def!" }: - return env.set(ast[1], EVAL(ast[2], env)) - case { it instanceof MalSymbol && it.value == "let*" }: - def let_env = new Env(env) - for (int i=0; i < ast[1].size(); i += 2) { - let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) - } - env = let_env - ast = ast[2] - break // TCO - case { it instanceof MalSymbol && it.value == "quote" }: - return ast[1] - case { it instanceof MalSymbol && it.value == "quasiquoteexpand" }: - return quasiquote(ast[1]) - case { it instanceof MalSymbol && it.value == "quasiquote" }: - ast = quasiquote(ast[1]) - break // TCO - case { it instanceof MalSymbol && it.value == "defmacro!" }: - def f = EVAL(ast[2], env) - f = f.clone() - f.ismacro = true - return env.set(ast[1], f) - case { it instanceof MalSymbol && it.value == "macroexpand" }: - return macroexpand(ast[1], env) - case { it instanceof MalSymbol && it.value == "try*" }: - try { - return EVAL(ast[1], env) - } catch(exc) { - if (ast.size() > 2 && - ast[2][0] instanceof MalSymbol && - ast[2][0].value == "catch*") { - def e = null - if (exc instanceof MalException) { - e = exc.obj - } else { - e = exc.message - } - return EVAL(ast[2][2], new Env(env, [ast[2][1]], [e])) - } else { - throw exc - } - } - case { it instanceof MalSymbol && it.value == "do" }: - ast.size() > 2 ? eval_ast(ast[1..-2], env) : null - ast = ast[-1] - break // TCO - case { it instanceof MalSymbol && it.value == "if" }: - def cond = EVAL(ast[1], env) - if (cond == false || cond == null) { - if (ast.size > 3) { - ast = ast[3] - break // TCO - } else { - return null - } - } else { - ast = ast[2] - break // TCO - } - case { it instanceof MalSymbol && it.value == "fn*" }: - return new MalFunc(EVAL, ast[2], env, ast[1]) - default: - def el = eval_ast(ast, env) - def (f, args) = [el[0], el.drop(1)] - if (f instanceof MalFunc) { - env = new Env(f.env, f.params, args) - ast = f.ast - break // TCO - } else { - return f(args) - } - } - } -} - -// PRINT -PRINT = { exp -> - printer.pr_str exp, true -} - -// REPL -repl_env = new Env(); -REP = { str -> - PRINT(EVAL(READ(str), repl_env)) -} - -// core.EXT: defined using Groovy -core.ns.each { k,v -> - repl_env.set(new MalSymbol(k), v) -} -repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) -repl_env.set(new MalSymbol("*ARGV*"), this.args as List) - -// core.mal: defined using mal itself -REP("(def! *host-language* \"groovy\")") -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))"); - -if (this.args.size() > 0) { - repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) - REP("(load-file \"${this.args[0]}\")") - System.exit(0) -} - -REP("(println (str \"Mal [\" *host-language* \"]\"))") -while (true) { - line = System.console().readLine 'user> ' - if (line == null) { - break; - } - try { - println REP(line) - } catch(MalException ex) { - println "Error: ${printer.pr_str(ex.obj, true)}" - } catch(StackOverflowError ex) { - println "Error: ${ex}" - } catch(ex) { - println "Error: $ex" - ex.printStackTrace() - } -} +import reader +import printer +import types +import types.MalException +import types.MalSymbol +import types.MalFunc +import env.Env +import core + +// READ +READ = { str -> + reader.read_str str +} + +// EVAL +macro_Q = { ast, env -> + if (types.list_Q(ast) && + ast.size() > 0 && + ast[0].class == MalSymbol && + env.find(ast[0])) { + def obj = env.get(ast[0]) + if (obj instanceof MalFunc && obj.ismacro) { + return true + } + } + return false +} +macroexpand = { ast, env -> + while (macro_Q(ast, env)) { + def mac = env.get(ast[0]) + ast = mac(ast.drop(1)) + } + return ast +} + +starts_with = { lst, sym -> + lst.size() == 2 && lst[0].class == MalSymbol && lst[0].value == sym +} +qq_loop = { elt, acc -> + if (types.list_Q(elt) && starts_with(elt, "splice-unquote")) { + return [new MalSymbol("concat"), elt[1], acc] + } else { + return [new MalSymbol("cons"), quasiquote(elt), acc] + } +} +qq_foldr = { xs -> + def acc = [] + for (int i=xs.size()-1; 0<=i; i-=1) { + acc = qq_loop(xs[i], acc) + } + return acc +} +quasiquote = { ast -> + switch (ast) { + case List: + if (types.vector_Q(ast)) { + return [new MalSymbol("vec"), qq_foldr(ast)] + } else if (starts_with(ast, "unquote")) { + return ast[1] + } else { + return qq_foldr(ast) + } + case MalSymbol: return [new MalSymbol("quote"), ast] + case Map: return [new MalSymbol("quote"), ast] + default: return ast + } +} + +eval_ast = { ast, env -> + switch (ast) { + case MalSymbol: return env.get(ast); + case List: return types.vector_Q(ast) ? + types.vector(ast.collect { EVAL(it,env) }) : + ast.collect { EVAL(it,env) } + case Map: def new_hm = [:] + ast.each { k,v -> + new_hm[k] = EVAL(v, env) + } + return new_hm + default: return ast + } +} + +EVAL = { ast, env -> + while (true) { + //println("EVAL: ${printer.pr_str(ast,true)}") + if (! types.list_Q(ast)) return eval_ast(ast, env) + + ast = macroexpand(ast, env) + if (! types.list_Q(ast)) return eval_ast(ast, env) + if (ast.size() == 0) return ast + + switch (ast[0]) { + case { it instanceof MalSymbol && it.value == "def!" }: + return env.set(ast[1], EVAL(ast[2], env)) + case { it instanceof MalSymbol && it.value == "let*" }: + def let_env = new Env(env) + for (int i=0; i < ast[1].size(); i += 2) { + let_env.set(ast[1][i], EVAL(ast[1][i+1], let_env)) + } + env = let_env + ast = ast[2] + break // TCO + case { it instanceof MalSymbol && it.value == "quote" }: + return ast[1] + case { it instanceof MalSymbol && it.value == "quasiquoteexpand" }: + return quasiquote(ast[1]) + case { it instanceof MalSymbol && it.value == "quasiquote" }: + ast = quasiquote(ast[1]) + break // TCO + case { it instanceof MalSymbol && it.value == "defmacro!" }: + def f = EVAL(ast[2], env) + f = f.clone() + f.ismacro = true + return env.set(ast[1], f) + case { it instanceof MalSymbol && it.value == "macroexpand" }: + return macroexpand(ast[1], env) + case { it instanceof MalSymbol && it.value == "try*" }: + try { + return EVAL(ast[1], env) + } catch(exc) { + if (ast.size() > 2 && + ast[2][0] instanceof MalSymbol && + ast[2][0].value == "catch*") { + def e = null + if (exc instanceof MalException) { + e = exc.obj + } else { + e = exc.message + } + return EVAL(ast[2][2], new Env(env, [ast[2][1]], [e])) + } else { + throw exc + } + } + case { it instanceof MalSymbol && it.value == "do" }: + ast.size() > 2 ? eval_ast(ast[1..-2], env) : null + ast = ast[-1] + break // TCO + case { it instanceof MalSymbol && it.value == "if" }: + def cond = EVAL(ast[1], env) + if (cond == false || cond == null) { + if (ast.size > 3) { + ast = ast[3] + break // TCO + } else { + return null + } + } else { + ast = ast[2] + break // TCO + } + case { it instanceof MalSymbol && it.value == "fn*" }: + return new MalFunc(EVAL, ast[2], env, ast[1]) + default: + def el = eval_ast(ast, env) + def (f, args) = [el[0], el.drop(1)] + if (f instanceof MalFunc) { + env = new Env(f.env, f.params, args) + ast = f.ast + break // TCO + } else { + return f(args) + } + } + } +} + +// PRINT +PRINT = { exp -> + printer.pr_str exp, true +} + +// REPL +repl_env = new Env(); +REP = { str -> + PRINT(EVAL(READ(str), repl_env)) +} + +// core.EXT: defined using Groovy +core.ns.each { k,v -> + repl_env.set(new MalSymbol(k), v) +} +repl_env.set(new MalSymbol("eval"), { a -> EVAL(a[0], repl_env)}) +repl_env.set(new MalSymbol("*ARGV*"), this.args as List) + +// core.mal: defined using mal itself +REP("(def! *host-language* \"groovy\")") +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))"); + +if (this.args.size() > 0) { + repl_env.set(new MalSymbol("*ARGV*"), this.args.drop(1) as List) + REP("(load-file \"${this.args[0]}\")") + System.exit(0) +} + +REP("(println (str \"Mal [\" *host-language* \"]\"))") +while (true) { + line = System.console().readLine 'user> ' + if (line == null) { + break; + } + try { + println REP(line) + } catch(MalException ex) { + println "Error: ${printer.pr_str(ex.obj, true)}" + } catch(StackOverflowError ex) { + println "Error: ${ex}" + } catch(ex) { + println "Error: $ex" + ex.printStackTrace() + } +} diff --git a/impls/groovy/tests/step5_tco.mal b/impls/groovy/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/groovy/tests/step5_tco.mal +++ b/impls/groovy/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/groovy/types.groovy b/impls/groovy/types.groovy index 3222406a3f..120915ab7c 100644 --- a/impls/groovy/types.groovy +++ b/impls/groovy/types.groovy @@ -1,121 +1,121 @@ -import groovy.transform.InheritConstructors -import groovy.transform.AutoClone - -class types { - def static copy(obj) { - def new_obj = obj - if (obj instanceof Collection || obj instanceof Map) { - new_obj = obj.clone() - if (obj.hasProperty("meta")) { - new_obj.getMetaClass().meta = obj.getProperties().meta - } - if (obj.hasProperty("isvector")) { - new_obj.getMetaClass().isvector = obj.getProperties().isvector - } - } else if (obj instanceof Object) { - new_obj = obj.clone() - } - return new_obj - } - - @InheritConstructors - static class MalException extends Exception { - def obj - MalException(String message) { - super(message) - obj = message - } - MalException(_obj) { - super("mal exception containing object") - obj = _obj - } - } - - def static string_Q(o) { - return o instanceof String && (o.size() == 0 || o[0] != "\u029e") - } - - @AutoClone - static class MalSymbol implements Comparable { - String value - MalSymbol(String name) { - value = name - } - int compareTo(o) { value <=> o.value } - } - - def static keyword(o) { - types.&keyword_Q(o) ? o : ("\u029e" + o) - } - def static keyword_Q(o) { - return o instanceof String && o.size() > 0 && o[0] == "\u029e" - } - - def static list_Q(o) { - //return (o instanceof List || o instanceof Object[]) && - return o instanceof List && !o.hasProperty("isvector") - } - - def static vector(o) { - def v = o.collect() - v.metaClass.isvector = true - v - } - def static vector_Q(o) { - return o instanceof List && o.hasProperty("isvector") && o.isvector - } - - def static hash_map(lst) { - def m = [:] - assoc_BANG(m, lst) - } - def static assoc_BANG(m, kvs) { - for (int i=0; i o.value } + } + + def static keyword(o) { + types.&keyword_Q(o) ? o : ("\u029e" + o) + } + def static keyword_Q(o) { + return o instanceof String && o.size() > 0 && o[0] == "\u029e" + } + + def static list_Q(o) { + //return (o instanceof List || o instanceof Object[]) && + return o instanceof List && !o.hasProperty("isvector") + } + + def static vector(o) { + def v = o.collect() + v.metaClass.isvector = true + v + } + def static vector_Q(o) { + return o instanceof List && o.hasProperty("isvector") && o.isvector + } + + def static hash_map(lst) { + def m = [:] + assoc_BANG(m, lst) + } + def static assoc_BANG(m, kvs) { + for (int i=0; i - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Guile -RUN apt-get -y install libunistring-dev libgc-dev autoconf libtool flex gettext texinfo libgmp-dev -RUN apt-get -y install git pkg-config libffi-dev -# TODO: remove /tmp/guile in same command -RUN git clone git://git.sv.gnu.org/guile.git /tmp/guile \ - && cd /tmp/guile && ./autogen.sh && ./configure && make && make install -RUN ldconfig -# TODO: move this up with other deps -RUN apt-get -y install libpcre3 libpcre3-dev - +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Guile +RUN apt-get -y install libunistring-dev libgc-dev autoconf libtool flex gettext texinfo libgmp-dev +RUN apt-get -y install git pkg-config libffi-dev +# TODO: remove /tmp/guile in same command +RUN git clone git://git.sv.gnu.org/guile.git /tmp/guile \ + && cd /tmp/guile && ./autogen.sh && ./configure && make && make install +RUN ldconfig +# TODO: move this up with other deps +RUN apt-get -y install libpcre3 libpcre3-dev + diff --git a/impls/guile/Makefile b/impls/guile/Makefile index 993bd8cdd8..1d7d93e636 100644 --- a/impls/guile/Makefile +++ b/impls/guile/Makefile @@ -1,17 +1,17 @@ -SOURCES_BASE = readline.scm types.scm reader.scm printer.scm -SOURCES_LISP = env.scm core.scm stepA_mal.scm -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.scm - -mal.scm: $(SOURCES) - echo "#! /usr/bin/env guile" > $@ - echo "!#" >> $@ - cat $+ | sed $(foreach f,$(+),-e 's/(readline)//') >> $@ - chmod +x $@ - -clean: - rm -f mal.scm +SOURCES_BASE = readline.scm types.scm reader.scm printer.scm +SOURCES_LISP = env.scm core.scm stepA_mal.scm +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.scm + +mal.scm: $(SOURCES) + echo "#! /usr/bin/env guile" > $@ + echo "!#" >> $@ + cat $+ | sed $(foreach f,$(+),-e 's/(readline)//') >> $@ + chmod +x $@ + +clean: + rm -f mal.scm diff --git a/impls/guile/core.scm b/impls/guile/core.scm index 4d86cc6de0..c89655263e 100644 --- a/impls/guile/core.scm +++ b/impls/guile/core.scm @@ -1,270 +1,270 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(library (core) - (export core.ns ->list) - (import (guile) (rnrs) (types) (reader) (printer) (ice-9 match) (readline))) - -(define (->list o) ((if (vector? o) vector->list identity) o)) - -(define (vec lst) (if (vector? lst) lst (list->vector lst))) - -(define (_count obj) - (cond - ((_nil? obj) 0) - ((vector? obj) (vector-length obj)) - (else (length obj)))) - -(define (_empty? obj) (zero? (_count obj))) - -;; Well, strange spec... -(define (_equal? o1 o2) - (define (equal-lists? lst1 lst2) - (and (= (length lst1) (length lst2)) - (for-all _equal? lst1 lst2))) - (define (equal-hash-tables? ht1 ht2) - (define (equal-values? k) - (_equal? (_get ht1 k) (_get ht2 k))) - (let ((keys1 (_keys ht1))) - (and (= (length keys1) (length (_keys ht2))) - (for-all equal-values? keys1)))) - (cond - ((and (_sequential? o1) (_sequential? o2)) - (equal-lists? (->list o1) (->list o2))) - ((and (hash-table? o1) (hash-table? o2)) - (equal-hash-tables? o1 o2)) - (else - (equal? o1 o2)))) - -(define (pr-str . args) - (define (pr x) (pr_str x #t)) - (string-join (map pr args) " ")) - -(define (str . args) - (define (pr x) (pr_str x #f)) - (string-join (map pr args) "")) - -(define (prn . args) - (format #t "~a~%" (apply pr-str args)) - nil) - -(define (println . args) - (define (pr x) (pr_str x #f)) - (format #t "~{~a~^ ~}~%" (map pr args)) - nil) - -(define (slurp filename) - (when (not (file-exists? filename)) - (throw 'mal-error (format #f "File/dir '~a' doesn't exist" filename))) - (call-with-input-file filename get-string-all)) - -(define (_cons x y) - (cons x (->list y))) - -(define (concat . args) - (apply append (map ->list args))) - -(define (_nth lst n) - (define ll (->list lst)) - (when (>= n (length ll)) - (throw 'mal-error "nth: index out of range")) - (list-ref ll n)) - -(define (_first lst) - (define ll (->list lst)) - (cond - ((_nil? lst) nil) - ((null? ll) nil) - (else (car ll)))) - -(define (_rest lst) - (define ll (->list lst)) - (cond - ((_nil? lst) '()) - ((null? ll) '()) - (else (cdr ll)))) - -(define (_map f lst) (map (callable-closure f) (->list lst))) - -(define (_apply f . args) - (define ll - (let lp((next args) (ret '())) - (cond - ((null? next) (reverse ret)) - (else - (let ((n (->list (car next)))) - (lp (cdr next) (if (list? n) - (append (reverse n) ret) - (cons n ret)))))))) - (callable-apply f ll)) - -(define (->symbol x) - ((if (symbol? x) identity string->symbol) x)) - -(define (->keyword x) - ((if (_keyword? x) identity string->keyword) x)) - -(define (_hash-map . lst) (list->hash-map lst)) - -(define (_assoc ht . lst) (list->hash-map lst (hash-table-clone ht))) - -(define (_get ht k) - (if (_nil? ht) - nil - (hash-ref ht k nil))) - -(define (_dissoc ht . lst) - (define ht2 (hash-table-clone ht)) - (for-each (lambda (k) (hash-remove! ht2 k)) lst) - ht2) - -(define (_keys ht) (hash-map->list (lambda (k v) k) ht)) - -(define (_vals ht) (hash-map->list (lambda (k v) v) ht)) - -(define (_contains? ht k) - (let ((v (hash-ref ht k '*mal-null*))) - (if (eq? v '*mal-null*) - #f - #t))) - -(define (_sequential? o) (or (list? o) (vector? o))) - -(define (_meta c) - (if (callable? c) - (callable-meta-info c) - (or (object-property c 'meta) nil))) - -(define (_with-meta c ht) - (cond - ((callable? c) - (let ((cc (make-callable ht - (callable-unbox c) - #f - (callable-closure c)))) - cc)) - (else - (let ((cc (box c))) - (set-object-property! cc 'meta ht) - cc)))) - -;; Apply closure 'c' with atom-val as one of arguments, then -;; set the result as the new val of atom. -(define (_swap! atom c . rest) - (let* ((args (cons (atom-val atom) rest)) - (val (callable-apply c args))) - (atom-val-set! atom val) - val)) - -(define (_conj lst . args) - (cond - ((vector? lst) - (list->vector (append (->list lst) args))) - ((list? lst) - (append (reverse args) (->list lst))) - (else (throw 'mal-error (format #f "conj: '~a' is not list/vector" lst))))) - -(define (_seq obj) - (cond - ((_nil? obj) nil) - ((_string? obj) - (if (string-null? obj) nil (map string (string->list obj)))) - ((_empty? obj) nil) - (else (->list obj)))) - -(define (__readline prompt) - (let ((str (_readline prompt))) - (if (eof-object? str) - #f - str))) - -(define (_true? x) (eq? x #t)) -(define (_false? x) (eq? x #f)) - -;; We need regular named procedure for better debug -(define (_atom x) (make-atom x)) -(define (_atom? x) (atom? x)) -(define (_deref x) (atom-val x)) -(define (_reset! x v) (atom-val-set! x v)) - -(define (time-ms) - (let ((t (gettimeofday))) - (round - (+ (* (car t) 1000.0) (/ (cdr t) 1000.0) 0.5)))) - -(define *primitives* - `((list ,list) - (list? ,list?) - (empty? ,_empty?) - (count ,_count) - (= ,_equal?) - (< ,<) - (<= ,<=) - (> ,>) - (>= ,>=) - (+ ,+) - (- ,-) - (* ,*) - (/ ,/) - (pr-str ,pr-str) - (str ,str) - (prn ,prn) - (println ,println) - (read-string ,read_str) - (slurp ,slurp) - (cons ,_cons) - (concat ,concat) - (vec ,vec) - (nth ,_nth) - (first ,_first) - (rest ,_rest) - (map ,_map) - (apply ,_apply) - (nil? ,_nil?) - (true? ,_true?) - (false? ,_false?) - (number? ,number?) - (symbol? ,symbol?) - (symbol ,->symbol) - (string? ,_string?) - (keyword ,->keyword) - (keyword? ,_keyword?) - (vector? ,vector?) - (vector ,vector) - (hash-map ,_hash-map) - (map? ,hash-table?) - (assoc ,_assoc) - (get ,_get) - (dissoc ,_dissoc) - (keys ,_keys) - (vals ,_vals) - (contains? ,_contains?) - (sequential? ,_sequential?) - (fn? ,is-func?) - (macro? ,is-macro?) - (readline ,__readline) - (meta ,_meta) - (with-meta ,_with-meta) - (atom ,_atom) - (atom? ,_atom?) - (deref ,_deref) - (reset! ,_reset!) - (swap! ,_swap!) - (conj ,_conj) - (seq ,_seq) - (time-ms ,time-ms))) - -;; Well, we have to rename it to this strange name... -(define core.ns *primitives*) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(library (core) + (export core.ns ->list) + (import (guile) (rnrs) (types) (reader) (printer) (ice-9 match) (readline))) + +(define (->list o) ((if (vector? o) vector->list identity) o)) + +(define (vec lst) (if (vector? lst) lst (list->vector lst))) + +(define (_count obj) + (cond + ((_nil? obj) 0) + ((vector? obj) (vector-length obj)) + (else (length obj)))) + +(define (_empty? obj) (zero? (_count obj))) + +;; Well, strange spec... +(define (_equal? o1 o2) + (define (equal-lists? lst1 lst2) + (and (= (length lst1) (length lst2)) + (for-all _equal? lst1 lst2))) + (define (equal-hash-tables? ht1 ht2) + (define (equal-values? k) + (_equal? (_get ht1 k) (_get ht2 k))) + (let ((keys1 (_keys ht1))) + (and (= (length keys1) (length (_keys ht2))) + (for-all equal-values? keys1)))) + (cond + ((and (_sequential? o1) (_sequential? o2)) + (equal-lists? (->list o1) (->list o2))) + ((and (hash-table? o1) (hash-table? o2)) + (equal-hash-tables? o1 o2)) + (else + (equal? o1 o2)))) + +(define (pr-str . args) + (define (pr x) (pr_str x #t)) + (string-join (map pr args) " ")) + +(define (str . args) + (define (pr x) (pr_str x #f)) + (string-join (map pr args) "")) + +(define (prn . args) + (format #t "~a~%" (apply pr-str args)) + nil) + +(define (println . args) + (define (pr x) (pr_str x #f)) + (format #t "~{~a~^ ~}~%" (map pr args)) + nil) + +(define (slurp filename) + (when (not (file-exists? filename)) + (throw 'mal-error (format #f "File/dir '~a' doesn't exist" filename))) + (call-with-input-file filename get-string-all)) + +(define (_cons x y) + (cons x (->list y))) + +(define (concat . args) + (apply append (map ->list args))) + +(define (_nth lst n) + (define ll (->list lst)) + (when (>= n (length ll)) + (throw 'mal-error "nth: index out of range")) + (list-ref ll n)) + +(define (_first lst) + (define ll (->list lst)) + (cond + ((_nil? lst) nil) + ((null? ll) nil) + (else (car ll)))) + +(define (_rest lst) + (define ll (->list lst)) + (cond + ((_nil? lst) '()) + ((null? ll) '()) + (else (cdr ll)))) + +(define (_map f lst) (map (callable-closure f) (->list lst))) + +(define (_apply f . args) + (define ll + (let lp((next args) (ret '())) + (cond + ((null? next) (reverse ret)) + (else + (let ((n (->list (car next)))) + (lp (cdr next) (if (list? n) + (append (reverse n) ret) + (cons n ret)))))))) + (callable-apply f ll)) + +(define (->symbol x) + ((if (symbol? x) identity string->symbol) x)) + +(define (->keyword x) + ((if (_keyword? x) identity string->keyword) x)) + +(define (_hash-map . lst) (list->hash-map lst)) + +(define (_assoc ht . lst) (list->hash-map lst (hash-table-clone ht))) + +(define (_get ht k) + (if (_nil? ht) + nil + (hash-ref ht k nil))) + +(define (_dissoc ht . lst) + (define ht2 (hash-table-clone ht)) + (for-each (lambda (k) (hash-remove! ht2 k)) lst) + ht2) + +(define (_keys ht) (hash-map->list (lambda (k v) k) ht)) + +(define (_vals ht) (hash-map->list (lambda (k v) v) ht)) + +(define (_contains? ht k) + (let ((v (hash-ref ht k '*mal-null*))) + (if (eq? v '*mal-null*) + #f + #t))) + +(define (_sequential? o) (or (list? o) (vector? o))) + +(define (_meta c) + (if (callable? c) + (callable-meta-info c) + (or (object-property c 'meta) nil))) + +(define (_with-meta c ht) + (cond + ((callable? c) + (let ((cc (make-callable ht + (callable-unbox c) + #f + (callable-closure c)))) + cc)) + (else + (let ((cc (box c))) + (set-object-property! cc 'meta ht) + cc)))) + +;; Apply closure 'c' with atom-val as one of arguments, then +;; set the result as the new val of atom. +(define (_swap! atom c . rest) + (let* ((args (cons (atom-val atom) rest)) + (val (callable-apply c args))) + (atom-val-set! atom val) + val)) + +(define (_conj lst . args) + (cond + ((vector? lst) + (list->vector (append (->list lst) args))) + ((list? lst) + (append (reverse args) (->list lst))) + (else (throw 'mal-error (format #f "conj: '~a' is not list/vector" lst))))) + +(define (_seq obj) + (cond + ((_nil? obj) nil) + ((_string? obj) + (if (string-null? obj) nil (map string (string->list obj)))) + ((_empty? obj) nil) + (else (->list obj)))) + +(define (__readline prompt) + (let ((str (_readline prompt))) + (if (eof-object? str) + #f + str))) + +(define (_true? x) (eq? x #t)) +(define (_false? x) (eq? x #f)) + +;; We need regular named procedure for better debug +(define (_atom x) (make-atom x)) +(define (_atom? x) (atom? x)) +(define (_deref x) (atom-val x)) +(define (_reset! x v) (atom-val-set! x v)) + +(define (time-ms) + (let ((t (gettimeofday))) + (round + (+ (* (car t) 1000.0) (/ (cdr t) 1000.0) 0.5)))) + +(define *primitives* + `((list ,list) + (list? ,list?) + (empty? ,_empty?) + (count ,_count) + (= ,_equal?) + (< ,<) + (<= ,<=) + (> ,>) + (>= ,>=) + (+ ,+) + (- ,-) + (* ,*) + (/ ,/) + (pr-str ,pr-str) + (str ,str) + (prn ,prn) + (println ,println) + (read-string ,read_str) + (slurp ,slurp) + (cons ,_cons) + (concat ,concat) + (vec ,vec) + (nth ,_nth) + (first ,_first) + (rest ,_rest) + (map ,_map) + (apply ,_apply) + (nil? ,_nil?) + (true? ,_true?) + (false? ,_false?) + (number? ,number?) + (symbol? ,symbol?) + (symbol ,->symbol) + (string? ,_string?) + (keyword ,->keyword) + (keyword? ,_keyword?) + (vector? ,vector?) + (vector ,vector) + (hash-map ,_hash-map) + (map? ,hash-table?) + (assoc ,_assoc) + (get ,_get) + (dissoc ,_dissoc) + (keys ,_keys) + (vals ,_vals) + (contains? ,_contains?) + (sequential? ,_sequential?) + (fn? ,is-func?) + (macro? ,is-macro?) + (readline ,__readline) + (meta ,_meta) + (with-meta ,_with-meta) + (atom ,_atom) + (atom? ,_atom?) + (deref ,_deref) + (reset! ,_reset!) + (swap! ,_swap!) + (conj ,_conj) + (seq ,_seq) + (time-ms ,time-ms))) + +;; Well, we have to rename it to this strange name... +(define core.ns *primitives*) diff --git a/impls/guile/env.scm b/impls/guile/env.scm index c15ea474aa..c26f7ef42b 100644 --- a/impls/guile/env.scm +++ b/impls/guile/env.scm @@ -1,64 +1,64 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(library (env) - (export make-Env env-has env-check) - (import (guile) (types))) - -(define (env-check sym env) - (env-has sym env (lambda _ #f))) - -(define (sym-err-throw sym) - (throw 'mal-error (format #f "'~a' not found" sym))) - -(define* (env-has sym env #:optional (err sym-err-throw)) - (let ((v ((env 'get) sym))) - (if (equal? v '*mal-null*) - (err sym) - v))) - -(define* (make-Env #:key (outer nil) (binds '()) (exprs '())) - (define _env (make-hash-table)) - (define (_set k v) (hash-set! _env k v)) - (define (_get k) - (let ((v (hash-ref _env k '*mal-null*))) - (if (equal? v '*mal-null*) - (if (_nil? outer) - '*mal-null* - ((outer 'get) k)) - v))) - (define (_find k) (_get k)) - (define (_show) - (hash-for-each (lambda (k v) (format #t "~a : ~a~%" k v)) _env) - (display "outer:\n") - (and (not (_nil? outer)) ((outer 'show)))) - (let lp((b binds) (e exprs)) - (cond - ((null? b) #t) - ((eq? (car b) '&) (hash-set! _env (cadr b) e)) ; handle varglist - (else ; normal binding - (when (not (symbol? (car b))) - (throw 'mal-error (format #f "Invalid binding key! '~a'" (car b)))) - (when (null? e) - (throw 'mal-error "Invalid pattern for this macro")) - (hash-set! _env (car b) (car e)) - (lp (cdr b) (cdr e))))) - (lambda (cmd) - (case cmd - ((set) _set) - ((find) _find) - ((get) _get) - ((show) _show) - (else (throw 'mal-error (format #f "BUG: Invalid cmd '~a'" cmd)))))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(library (env) + (export make-Env env-has env-check) + (import (guile) (types))) + +(define (env-check sym env) + (env-has sym env (lambda _ #f))) + +(define (sym-err-throw sym) + (throw 'mal-error (format #f "'~a' not found" sym))) + +(define* (env-has sym env #:optional (err sym-err-throw)) + (let ((v ((env 'get) sym))) + (if (equal? v '*mal-null*) + (err sym) + v))) + +(define* (make-Env #:key (outer nil) (binds '()) (exprs '())) + (define _env (make-hash-table)) + (define (_set k v) (hash-set! _env k v)) + (define (_get k) + (let ((v (hash-ref _env k '*mal-null*))) + (if (equal? v '*mal-null*) + (if (_nil? outer) + '*mal-null* + ((outer 'get) k)) + v))) + (define (_find k) (_get k)) + (define (_show) + (hash-for-each (lambda (k v) (format #t "~a : ~a~%" k v)) _env) + (display "outer:\n") + (and (not (_nil? outer)) ((outer 'show)))) + (let lp((b binds) (e exprs)) + (cond + ((null? b) #t) + ((eq? (car b) '&) (hash-set! _env (cadr b) e)) ; handle varglist + (else ; normal binding + (when (not (symbol? (car b))) + (throw 'mal-error (format #f "Invalid binding key! '~a'" (car b)))) + (when (null? e) + (throw 'mal-error "Invalid pattern for this macro")) + (hash-set! _env (car b) (car e)) + (lp (cdr b) (cdr e))))) + (lambda (cmd) + (case cmd + ((set) _set) + ((find) _find) + ((get) _get) + ((show) _show) + (else (throw 'mal-error (format #f "BUG: Invalid cmd '~a'" cmd)))))) diff --git a/impls/guile/pcre.scm b/impls/guile/pcre.scm index 26de8199c9..eca3df7896 100644 --- a/impls/guile/pcre.scm +++ b/impls/guile/pcre.scm @@ -1,136 +1,136 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(library (pcre) - (export new-pcre - pcre-match - pcre-get-substring - pcre-search) - (import (guile) (rnrs) (system foreign))) - -(define (make-blob-pointer len) - (bytevector->pointer (make-bytevector len))) - -(define pcre-ffi (dynamic-link "libpcre")) - -(define %pcre-compile2 - (pointer->procedure '* - (dynamic-func "pcre_compile2" pcre-ffi) - (list '* int '* '* '* '*))) - -(define %pcre-compile - (pointer->procedure '* - (dynamic-func "pcre_compile" pcre-ffi) - (list '* int '* '* '*))) - -(define %pcre-exec - (pointer->procedure int - (dynamic-func "pcre_exec" pcre-ffi) - (list '* '* '* int int int '* int))) - -(define %pcre-study - (pointer->procedure '* - (dynamic-func "pcre_study" pcre-ffi) - (list '* int '*))) - -(define %pcre-get-substring - (pointer->procedure '* - (dynamic-func "pcre_get_substring" pcre-ffi) - (list '* '* int int '*))) - -(define %pcre-free - (pointer->procedure void - (dynamic-func "pcre_free" pcre-ffi) - (list '*))) - -(define %pcre-free-study (dynamic-func "pcre_free_study" pcre-ffi)) - -(define %pcre-free-substring (dynamic-func "pcre_free_substring" pcre-ffi)) - -(define-record-type pcre - (fields - errptr - (mutable strptr) - (mutable ovector) - (mutable matched) - (mutable code) - (mutable extra))) - -(define (%new-pcre) - (make-pcre (make-blob-pointer (sizeof ptrdiff_t)) ; errptr - #f #f 0 #f #f)) - -(define* (new-pcre re #:optional (options 0)) - (let ((reptr (string->pointer re)) - ;;(errcodeptr (make-blob-pointer int)) - (erroffset (make-blob-pointer int)) - (tableptr %null-pointer) - (pcre (%new-pcre))) - ;; FIXME: add exception handling - (pcre-code-set! pcre (%pcre-compile reptr options (pcre-errptr pcre) - erroffset tableptr)) - ;;(set-pointer-finalizer! (pcre-code pcre) %pcre-free) - pcre)) - -(define* (pcre-match pcre str #:key (study-options 0) (exec-options 0) - (ovecsize 30) (offset 0)) - (let ((extra (%pcre-study (pcre-code pcre) study-options (pcre-errptr pcre))) - (strptr (string->pointer str)) - (ovector (make-blob-pointer (* int ovecsize)))) - (pcre-matched-set! pcre - (%pcre-exec (pcre-code pcre) - extra - strptr - (string-length str) - offset - exec-options - ovector - ovecsize)) - (pcre-ovector-set! pcre ovector) - (pcre-strptr-set! pcre strptr) - (set-pointer-finalizer! extra %pcre-free-study) - pcre)) - -(define (pcre-get-substring pcre index) - (let ((strptr (pcre-strptr pcre)) - (ovector (pcre-ovector pcre)) - (matched (pcre-matched pcre)) - (buf (make-blob-pointer (sizeof ptrdiff_t)))) - (%pcre-get-substring strptr ovector matched index buf) - (let ((ret (pointer->string (dereference-pointer buf)))) - (set-pointer-finalizer! (dereference-pointer buf) %pcre-free-substring) - ret))) - -(define* (pcre-search pcre str #:key (study-options 0) (exec-options 0) - (exclude " ")) - (define (trim s) - (string-trim-both s (lambda (x) (string-contains exclude (string x))))) - (define len (string-length str)) - (let lp((i 0) (ret '())) - (cond - ((>= i len) (reverse ret)) - (else - (pcre-match pcre str #:study-options study-options #:exec-options exec-options #:offset i) - (if (<= (pcre-matched pcre) 0) - (lp len ret) - (let ((hit (trim (pcre-get-substring pcre 1))) - (sublen (string-length (pcre-get-substring pcre 0)))) - (if (zero? sublen) - (lp len ret) - (lp (+ i sublen) (cons hit ret))))))))) - -(define (pcre-free pcre) - (and (not (null-pointer? (pcre-code pcre))) - (%pcre-free (pcre-code pcre)))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(library (pcre) + (export new-pcre + pcre-match + pcre-get-substring + pcre-search) + (import (guile) (rnrs) (system foreign))) + +(define (make-blob-pointer len) + (bytevector->pointer (make-bytevector len))) + +(define pcre-ffi (dynamic-link "libpcre")) + +(define %pcre-compile2 + (pointer->procedure '* + (dynamic-func "pcre_compile2" pcre-ffi) + (list '* int '* '* '* '*))) + +(define %pcre-compile + (pointer->procedure '* + (dynamic-func "pcre_compile" pcre-ffi) + (list '* int '* '* '*))) + +(define %pcre-exec + (pointer->procedure int + (dynamic-func "pcre_exec" pcre-ffi) + (list '* '* '* int int int '* int))) + +(define %pcre-study + (pointer->procedure '* + (dynamic-func "pcre_study" pcre-ffi) + (list '* int '*))) + +(define %pcre-get-substring + (pointer->procedure '* + (dynamic-func "pcre_get_substring" pcre-ffi) + (list '* '* int int '*))) + +(define %pcre-free + (pointer->procedure void + (dynamic-func "pcre_free" pcre-ffi) + (list '*))) + +(define %pcre-free-study (dynamic-func "pcre_free_study" pcre-ffi)) + +(define %pcre-free-substring (dynamic-func "pcre_free_substring" pcre-ffi)) + +(define-record-type pcre + (fields + errptr + (mutable strptr) + (mutable ovector) + (mutable matched) + (mutable code) + (mutable extra))) + +(define (%new-pcre) + (make-pcre (make-blob-pointer (sizeof ptrdiff_t)) ; errptr + #f #f 0 #f #f)) + +(define* (new-pcre re #:optional (options 0)) + (let ((reptr (string->pointer re)) + ;;(errcodeptr (make-blob-pointer int)) + (erroffset (make-blob-pointer int)) + (tableptr %null-pointer) + (pcre (%new-pcre))) + ;; FIXME: add exception handling + (pcre-code-set! pcre (%pcre-compile reptr options (pcre-errptr pcre) + erroffset tableptr)) + ;;(set-pointer-finalizer! (pcre-code pcre) %pcre-free) + pcre)) + +(define* (pcre-match pcre str #:key (study-options 0) (exec-options 0) + (ovecsize 30) (offset 0)) + (let ((extra (%pcre-study (pcre-code pcre) study-options (pcre-errptr pcre))) + (strptr (string->pointer str)) + (ovector (make-blob-pointer (* int ovecsize)))) + (pcre-matched-set! pcre + (%pcre-exec (pcre-code pcre) + extra + strptr + (string-length str) + offset + exec-options + ovector + ovecsize)) + (pcre-ovector-set! pcre ovector) + (pcre-strptr-set! pcre strptr) + (set-pointer-finalizer! extra %pcre-free-study) + pcre)) + +(define (pcre-get-substring pcre index) + (let ((strptr (pcre-strptr pcre)) + (ovector (pcre-ovector pcre)) + (matched (pcre-matched pcre)) + (buf (make-blob-pointer (sizeof ptrdiff_t)))) + (%pcre-get-substring strptr ovector matched index buf) + (let ((ret (pointer->string (dereference-pointer buf)))) + (set-pointer-finalizer! (dereference-pointer buf) %pcre-free-substring) + ret))) + +(define* (pcre-search pcre str #:key (study-options 0) (exec-options 0) + (exclude " ")) + (define (trim s) + (string-trim-both s (lambda (x) (string-contains exclude (string x))))) + (define len (string-length str)) + (let lp((i 0) (ret '())) + (cond + ((>= i len) (reverse ret)) + (else + (pcre-match pcre str #:study-options study-options #:exec-options exec-options #:offset i) + (if (<= (pcre-matched pcre) 0) + (lp len ret) + (let ((hit (trim (pcre-get-substring pcre 1))) + (sublen (string-length (pcre-get-substring pcre 0)))) + (if (zero? sublen) + (lp len ret) + (lp (+ i sublen) (cons hit ret))))))))) + +(define (pcre-free pcre) + (and (not (null-pointer? (pcre-code pcre))) + (%pcre-free (pcre-code pcre)))) diff --git a/impls/guile/printer.scm b/impls/guile/printer.scm index c3400cf30d..ede4db8297 100644 --- a/impls/guile/printer.scm +++ b/impls/guile/printer.scm @@ -1,60 +1,60 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(library (printer) - (export pr_str) - (import (guile) (types) (ice-9 match) (ice-9 regex))) - -(define (print-hashmap hm p) - (call-with-output-string - (lambda (port) - (display "{" port) - (display - (string-join - (hash-map->list - (lambda (k v) - (format #f "~a ~a" (p k) (p v))) - hm) - " ") - port) - (display "}" port)))) - -(define (pr_str obj readable?) - (define (->str s) - (string-sub - (string-sub - (string-sub s "\\\\" "\\\\") - "\"" "\\\"") - "\n" "\\n")) - (define (%pr_str o) (pr_str o readable?)) - (match obj - ((? box?) (%pr_str (unbox obj))) - ((? is-func?) "#") - ((? is-macro?) "#") - ((? list?) (format #f "(~{~a~^ ~})" (map %pr_str obj))) - ((? vector?) (format #f "[~{~a~^ ~}]" (map %pr_str (vector->list obj)))) - ((? hash-table?) (print-hashmap obj %pr_str)) - ((? string?) - (cond - ((_keyword? obj) - => (lambda (m) (format #f ":~a" (substring obj 1)))) - (else (if readable? (format #f "\"~a\"" (->str obj)) obj)))) - ;;((? number?) (format #f "~a" obj)) - ;;((? symbol?) (format #f "~a" obj)) - ((? atom?) (format #f "(atom ~a)" (%pr_str (atom-val obj)))) - ((? _nil?) "nil") - (#t "true") - (#f "false") - (else (format #f "~a" obj)))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(library (printer) + (export pr_str) + (import (guile) (types) (ice-9 match) (ice-9 regex))) + +(define (print-hashmap hm p) + (call-with-output-string + (lambda (port) + (display "{" port) + (display + (string-join + (hash-map->list + (lambda (k v) + (format #f "~a ~a" (p k) (p v))) + hm) + " ") + port) + (display "}" port)))) + +(define (pr_str obj readable?) + (define (->str s) + (string-sub + (string-sub + (string-sub s "\\\\" "\\\\") + "\"" "\\\"") + "\n" "\\n")) + (define (%pr_str o) (pr_str o readable?)) + (match obj + ((? box?) (%pr_str (unbox obj))) + ((? is-func?) "#") + ((? is-macro?) "#") + ((? list?) (format #f "(~{~a~^ ~})" (map %pr_str obj))) + ((? vector?) (format #f "[~{~a~^ ~}]" (map %pr_str (vector->list obj)))) + ((? hash-table?) (print-hashmap obj %pr_str)) + ((? string?) + (cond + ((_keyword? obj) + => (lambda (m) (format #f ":~a" (substring obj 1)))) + (else (if readable? (format #f "\"~a\"" (->str obj)) obj)))) + ;;((? number?) (format #f "~a" obj)) + ;;((? symbol?) (format #f "~a" obj)) + ((? atom?) (format #f "(atom ~a)" (%pr_str (atom-val obj)))) + ((? _nil?) "nil") + (#t "true") + (#f "false") + (else (format #f "~a" obj)))) diff --git a/impls/guile/reader.scm b/impls/guile/reader.scm index 0769e09a34..fadd967a79 100644 --- a/impls/guile/reader.scm +++ b/impls/guile/reader.scm @@ -1,134 +1,134 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(library (reader) - (export read_str) - (import (guile) (pcre) (ice-9 match) (srfi srfi-1) - (ice-9 regex) (types) (ice-9 format))) - -(define (make-Reader tokens) - (lambda (cmd) - (case cmd - ((next) - (if (null? tokens) - '() - (let ((r (car tokens))) (set! tokens (cdr tokens)) r))) - ((peek) (if (null? tokens) '() (car tokens))) - (else (error "Reader: Invalid cmd!" cmd))))) - -(define *token-re* - (new-pcre "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)")) - -(define *str-re* - (new-pcre "^(\"(?:\\\\.|[^\\\\\"])*\")$")) - -(define (tokenizer str) - (filter (lambda (s) (and (not (string-null? s)) (not (string=? (substring s 0 1) ";")))) - (pcre-search *token-re* str))) - -(define (delim-read reader delim) - (let lp((next (reader 'peek)) (ret '())) - (cond - ((null? next) (throw 'mal-error (format #f "expected '~a', got EOF" delim))) - ((string=? next delim) (reader 'next) (reverse ret)) - (else - (let* ((cur (read_form reader)) - (n (reader 'peek))) - (lp n (cons cur ret))))))) - -(define (read_list reader) - (cond - ((string=? ")" (reader 'peek)) - (reader 'next) - '()) - (else (delim-read reader ")")))) - -(define (read_vector reader) - (cond - ((string=? "]" (reader 'peek)) - (reader 'next) - #()) - (else (list->vector (delim-read reader "]"))))) - -(define (read_hashmap reader) - (define ht (make-hash-table)) - (define lst (delim-read reader "}")) - (cond - ((null? lst) ht) - (else - (let lp((next lst)) - (cond - ((null? next) ht) - (else - (when (null? (cdr next)) - (throw 'mal-error - (format #f "read_hashmap: '~a' lack of value" (car next)))) - (let ((k (car next)) - (v (cadr next))) - (hash-set! ht k v) - (lp (cddr next))))))))) - -(define (read_atom reader) - (let ((token (reader 'next))) - (cond - ((string-match "^-?[0-9][0-9.]*$" token) - => (lambda (m) (string->number (match:substring m 0)))) - ((> (length (pcre-search *str-re* token)) 0) - (with-input-from-string token read)) - ((eqv? (string-ref token 0) #\") - (throw 'mal-error "expected '\"', got EOF")) - ((string-match "^:(.*)" token) - => (lambda (m) (string->keyword (match:substring m 1)))) - ((string=? "nil" token) nil) - ((string=? "true" token) #t) - ((string=? "false" token) #f) - (else (string->symbol token))))) - -(define (read_form reader) - (define (clean x) - (if (string? x) - (string-trim-both - x - (lambda (c) (char-set-contains? char-set:whitespace c))) - x)) - (define (next) (reader 'next)) - (define (more) (read_form reader)) - (match (clean (reader 'peek)) - (() (throw 'mal-error "blank line")) ; FIXME: what should be returned? - ("'" (next) (list 'quote (more))) - ("`" (next) (list 'quasiquote (more))) - ("~" (next) (list 'unquote (more))) - ("~@" (next) (list 'splice-unquote (more))) - ("^" (next) (let ((meta (more))) `(with-meta ,(more) ,meta))) - ("@" (next) `(deref ,(more))) - (")" (next) (throw 'mal-error "unexpected ')'")) - ("(" (next) (read_list reader)) - ("]" (throw 'mal-error "unexpected ']'")) - ("[" (next) (read_vector reader)) - ("}" (throw 'mal-error "unexpected '}'")) - ("{" (next) (read_hashmap reader)) - ("" (next) (read_form reader)) - (else (read_atom reader)))) - -(define (read_str str) - (if (eof-object? str) - str - (let* ((tokens (tokenizer str)) - (t (if (null? tokens) - (if (char=? (string-ref str 0) #\;) - '() - (list str)) - tokens))) - (read_form (make-Reader t))))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(library (reader) + (export read_str) + (import (guile) (pcre) (ice-9 match) (srfi srfi-1) + (ice-9 regex) (types) (ice-9 format))) + +(define (make-Reader tokens) + (lambda (cmd) + (case cmd + ((next) + (if (null? tokens) + '() + (let ((r (car tokens))) (set! tokens (cdr tokens)) r))) + ((peek) (if (null? tokens) '() (car tokens))) + (else (error "Reader: Invalid cmd!" cmd))))) + +(define *token-re* + (new-pcre "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)")) + +(define *str-re* + (new-pcre "^(\"(?:\\\\.|[^\\\\\"])*\")$")) + +(define (tokenizer str) + (filter (lambda (s) (and (not (string-null? s)) (not (string=? (substring s 0 1) ";")))) + (pcre-search *token-re* str))) + +(define (delim-read reader delim) + (let lp((next (reader 'peek)) (ret '())) + (cond + ((null? next) (throw 'mal-error (format #f "expected '~a', got EOF" delim))) + ((string=? next delim) (reader 'next) (reverse ret)) + (else + (let* ((cur (read_form reader)) + (n (reader 'peek))) + (lp n (cons cur ret))))))) + +(define (read_list reader) + (cond + ((string=? ")" (reader 'peek)) + (reader 'next) + '()) + (else (delim-read reader ")")))) + +(define (read_vector reader) + (cond + ((string=? "]" (reader 'peek)) + (reader 'next) + #()) + (else (list->vector (delim-read reader "]"))))) + +(define (read_hashmap reader) + (define ht (make-hash-table)) + (define lst (delim-read reader "}")) + (cond + ((null? lst) ht) + (else + (let lp((next lst)) + (cond + ((null? next) ht) + (else + (when (null? (cdr next)) + (throw 'mal-error + (format #f "read_hashmap: '~a' lack of value" (car next)))) + (let ((k (car next)) + (v (cadr next))) + (hash-set! ht k v) + (lp (cddr next))))))))) + +(define (read_atom reader) + (let ((token (reader 'next))) + (cond + ((string-match "^-?[0-9][0-9.]*$" token) + => (lambda (m) (string->number (match:substring m 0)))) + ((> (length (pcre-search *str-re* token)) 0) + (with-input-from-string token read)) + ((eqv? (string-ref token 0) #\") + (throw 'mal-error "expected '\"', got EOF")) + ((string-match "^:(.*)" token) + => (lambda (m) (string->keyword (match:substring m 1)))) + ((string=? "nil" token) nil) + ((string=? "true" token) #t) + ((string=? "false" token) #f) + (else (string->symbol token))))) + +(define (read_form reader) + (define (clean x) + (if (string? x) + (string-trim-both + x + (lambda (c) (char-set-contains? char-set:whitespace c))) + x)) + (define (next) (reader 'next)) + (define (more) (read_form reader)) + (match (clean (reader 'peek)) + (() (throw 'mal-error "blank line")) ; FIXME: what should be returned? + ("'" (next) (list 'quote (more))) + ("`" (next) (list 'quasiquote (more))) + ("~" (next) (list 'unquote (more))) + ("~@" (next) (list 'splice-unquote (more))) + ("^" (next) (let ((meta (more))) `(with-meta ,(more) ,meta))) + ("@" (next) `(deref ,(more))) + (")" (next) (throw 'mal-error "unexpected ')'")) + ("(" (next) (read_list reader)) + ("]" (throw 'mal-error "unexpected ']'")) + ("[" (next) (read_vector reader)) + ("}" (throw 'mal-error "unexpected '}'")) + ("{" (next) (read_hashmap reader)) + ("" (next) (read_form reader)) + (else (read_atom reader)))) + +(define (read_str str) + (if (eof-object? str) + str + (let* ((tokens (tokenizer str)) + (t (if (null? tokens) + (if (char=? (string-ref str 0) #\;) + '() + (list str)) + tokens))) + (read_form (make-Reader t))))) diff --git a/impls/guile/readline.scm b/impls/guile/readline.scm index 51196b6c77..116ba76868 100644 --- a/impls/guile/readline.scm +++ b/impls/guile/readline.scm @@ -1,32 +1,32 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;(use-modules (ice-9 readline)) - -(library (readline) - (export _readline) - (import (guile) (ice-9 readline))) - -(define mal-history - (format #f "~a/.mal-history" (getenv "HOME"))) - -(setenv "GUILE_HISTORY" mal-history) -(readline-set! bounce-parens 0) -(activate-readline) - -(define (_readline prompt) - (let ((str (readline prompt))) - (and (not (eof-object? str)) (add-history str)) - str)) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;(use-modules (ice-9 readline)) + +(library (readline) + (export _readline) + (import (guile) (ice-9 readline))) + +(define mal-history + (format #f "~a/.mal-history" (getenv "HOME"))) + +(setenv "GUILE_HISTORY" mal-history) +(readline-set! bounce-parens 0) +(activate-readline) + +(define (_readline prompt) + (let ((str (readline prompt))) + (and (not (eof-object? str)) (add-history str)) + str)) diff --git a/impls/guile/run b/impls/guile/run index 26eb986017..1de3cb7e3a 100755 --- a/impls/guile/run +++ b/impls/guile/run @@ -1,3 +1,3 @@ -#!/bin/bash -# XDG_CACHE_HOME is where guile stores the compiled files -XDG_CACHE_HOME=.cache/ exec guile -L $(dirname $0) $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" +#!/bin/bash +# XDG_CACHE_HOME is where guile stores the compiled files +XDG_CACHE_HOME=.cache/ exec guile -L $(dirname $0) $(dirname $0)/${STEP:-stepA_mal}.scm "${@}" diff --git a/impls/guile/step0_repl.scm b/impls/guile/step0_repl.scm index 9680c773a0..d29617b18a 100644 --- a/impls/guile/step0_repl.scm +++ b/impls/guile/step0_repl.scm @@ -1,38 +1,38 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline)) - -(define (READ str) - str) - -(define (EVAL ast env) ast) - -(define (PRINT str) - (format #t "~a~%" str)) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (PRINT (EVAL (READ line) '()))))))) - -(REPL) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline)) + +(define (READ str) + str) + +(define (EVAL ast env) ast) + +(define (PRINT str) + (format #t "~a~%" str)) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (PRINT (EVAL (READ line) '()))))))) + +(REPL) diff --git a/impls/guile/step1_read_print.scm b/impls/guile/step1_read_print.scm index cfb9a2ad06..54302af4d8 100644 --- a/impls/guile/step1_read_print.scm +++ b/impls/guile/step1_read_print.scm @@ -1,42 +1,42 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer)) - -(define (READ str) - (read_str str)) - -(define (EVAL ast env) ast) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) '()))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -(REPL) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer)) + +(define (READ str) + (read_str str)) + +(define (EVAL ast env) ast) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) '()))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +(REPL) diff --git a/impls/guile/step2_eval.scm b/impls/guile/step2_eval.scm index d7b85ac3ce..5303ee1c15 100644 --- a/impls/guile/step2_eval.scm +++ b/impls/guile/step2_eval.scm @@ -1,68 +1,68 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)) - -(define *toplevel* - `((+ . ,+) - (- . ,-) - (* . ,*) - (/ . ,/))) - -(define (READ str) - (read_str str)) - -(define (eval_ast ast env) - (define (_eval x) (EVAL x env)) - (match ast - ((? symbol? sym) - (or (assoc-ref env sym) - (throw 'mal-error (format #f "'~a' not found" sym)))) - ((? list? lst) (map _eval lst)) - ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) - ((? hash-table? ht) - (define new-ht (make-hash-table)) - (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) - new-ht) - (else ast))) - -(define (EVAL ast env) - (match ast - (() ast) - ((? list?) - (let ((el (eval_ast ast env))) - (apply (car el) (cdr el)))) - (else (eval_ast ast env)))) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) *toplevel*))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -(REPL) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)) + +(define *toplevel* + `((+ . ,+) + (- . ,-) + (* . ,*) + (/ . ,/))) + +(define (READ str) + (read_str str)) + +(define (eval_ast ast env) + (define (_eval x) (EVAL x env)) + (match ast + ((? symbol? sym) + (or (assoc-ref env sym) + (throw 'mal-error (format #f "'~a' not found" sym)))) + ((? list? lst) (map _eval lst)) + ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) + ((? hash-table? ht) + (define new-ht (make-hash-table)) + (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) + new-ht) + (else ast))) + +(define (EVAL ast env) + (match ast + (() ast) + ((? list?) + (let ((el (eval_ast ast env))) + (apply (car el) (cdr el)))) + (else (eval_ast ast env)))) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +(REPL) diff --git a/impls/guile/step3_env.scm b/impls/guile/step3_env.scm index c3798c6292..ec25708f03 100644 --- a/impls/guile/step3_env.scm +++ b/impls/guile/step3_env.scm @@ -1,87 +1,87 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) - (srfi srfi-1) (ice-9 receive) (env)) - -(define *primitives* - `((+ ,+) - (- ,-) - (* ,*) - (/ ,/))) - -(define *toplevel* - (receive (b e) (unzip2 *primitives*) - (make-Env #:binds b #:exprs e))) - -(define (READ str) - (read_str str)) - -(define (eval_ast ast env) - (define (_eval x) (EVAL x env)) - (match ast - ((? symbol? sym) (env-has sym env)) - ((? list? lst) (map _eval lst)) - ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) - ((? hash-table? ht) - (define new-ht (make-hash-table)) - (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) - new-ht) - (else ast))) - -(define (EVAL ast env) - (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs)) - (define (%unzip2 kvs) - (let lp((next kvs) (k '()) (v '())) - (cond - ;; NOTE: reverse is very important here! - ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) - (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) - (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) - (match ast - ((? (lambda (x) (not (list? x)))) (eval_ast ast env)) - (() ast) - (('def! k v) ((env 'set) k (EVAL v env))) - (('let* kvs body) - (let* ((new-env (make-Env #:outer env)) - (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) - (receive (keys vals) (%unzip2 (->list kvs)) - (for-each setter keys vals)) - (EVAL body new-env))) - (else - (let ((el (eval_ast ast env))) - (apply (car el) (cdr el)))))) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) *toplevel*))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -(REPL) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) + (srfi srfi-1) (ice-9 receive) (env)) + +(define *primitives* + `((+ ,+) + (- ,-) + (* ,*) + (/ ,/))) + +(define *toplevel* + (receive (b e) (unzip2 *primitives*) + (make-Env #:binds b #:exprs e))) + +(define (READ str) + (read_str str)) + +(define (eval_ast ast env) + (define (_eval x) (EVAL x env)) + (match ast + ((? symbol? sym) (env-has sym env)) + ((? list? lst) (map _eval lst)) + ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) + ((? hash-table? ht) + (define new-ht (make-hash-table)) + (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) + new-ht) + (else ast))) + +(define (EVAL ast env) + (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs)) + (define (%unzip2 kvs) + (let lp((next kvs) (k '()) (v '())) + (cond + ;; NOTE: reverse is very important here! + ((null? next) (values (reverse k) (reverse v))) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) + (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) + (match ast + ((? (lambda (x) (not (list? x)))) (eval_ast ast env)) + (() ast) + (('def! k v) ((env 'set) k (EVAL v env))) + (('let* kvs body) + (let* ((new-env (make-Env #:outer env)) + (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) + (receive (keys vals) (%unzip2 (->list kvs)) + (for-each setter keys vals)) + (EVAL body new-env))) + (else + (let ((el (eval_ast ast env))) + (apply (car el) (cdr el)))))) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +(REPL) diff --git a/impls/guile/step4_if_fn_do.scm b/impls/guile/step4_if_fn_do.scm index af4c7e816b..9828a616e9 100644 --- a/impls/guile/step4_if_fn_do.scm +++ b/impls/guile/step4_if_fn_do.scm @@ -1,107 +1,107 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) - (srfi srfi-1) (ice-9 receive) (env) (core) (types)) - -(define *toplevel* - (receive (b e) (unzip2 core.ns) - (make-Env #:binds b #:exprs e))) - -(define (READ str) - (read_str str)) - -(define (eval_ast ast env) - (define (_eval x) (EVAL x env)) - (match ast - ((? _nil? obj) obj) - ((? symbol? sym) (env-has sym env)) - ((? list? lst) (map _eval lst)) - ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) - ((? hash-table? ht) - (define new-ht (make-hash-table)) - (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) - new-ht) - (else ast))) - -(define (eval_seq ast env) - (cond - ((null? ast) nil) - ((null? (cdr ast)) (EVAL (car ast) env)) - (else - (EVAL (car ast) env) - (eval_seq (cdr ast) env)))) - -(define (EVAL ast env) - (define (%unzip2 kvs) - (let lp((next kvs) (k '()) (v '())) - (cond - ;; NOTE: reverse is very important here! - ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) - (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) - (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) - (match ast - ((? non-list?) (eval_ast ast env)) - (() ast) - (('def! k v) ((env 'set) k (EVAL v env))) - (('let* kvs body) - (let* ((new-env (make-Env #:outer env)) - (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) - (receive (keys vals) (%unzip2 (->list kvs)) - (for-each setter keys vals)) - (EVAL body new-env))) - (('do rest ...) - (eval_seq rest env)) - (('if cnd thn els ...) - (cond - ((and (not (null? els)) (not (null? (cdr els)))) - ;; Invalid `if' form - (throw 'mal-error - (format #f "if: failed to match any pattern in form '~a'" ast))) - ((cond-true? (EVAL cnd env)) (EVAL thn env)) - (else (if (null? els) nil (EVAL (car els) env))))) - (('fn* params body ...) ; function definition - (lambda args - (eval_seq body (make-Env #:outer env #:binds (->list params) #:exprs args)))) - (else - (let ((el (map (lambda (x) (EVAL x env)) ast))) - (apply (car el) (cdr el)))))) - -(define (EVAL-string str) - (EVAL (read_str str) *toplevel*)) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) *toplevel*))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -(EVAL-string "(def! not (fn* (x) (if x false true)))") - -(REPL) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) + (srfi srfi-1) (ice-9 receive) (env) (core) (types)) + +(define *toplevel* + (receive (b e) (unzip2 core.ns) + (make-Env #:binds b #:exprs e))) + +(define (READ str) + (read_str str)) + +(define (eval_ast ast env) + (define (_eval x) (EVAL x env)) + (match ast + ((? _nil? obj) obj) + ((? symbol? sym) (env-has sym env)) + ((? list? lst) (map _eval lst)) + ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) + ((? hash-table? ht) + (define new-ht (make-hash-table)) + (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) + new-ht) + (else ast))) + +(define (eval_seq ast env) + (cond + ((null? ast) nil) + ((null? (cdr ast)) (EVAL (car ast) env)) + (else + (EVAL (car ast) env) + (eval_seq (cdr ast) env)))) + +(define (EVAL ast env) + (define (%unzip2 kvs) + (let lp((next kvs) (k '()) (v '())) + (cond + ;; NOTE: reverse is very important here! + ((null? next) (values (reverse k) (reverse v))) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) + (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) + (match ast + ((? non-list?) (eval_ast ast env)) + (() ast) + (('def! k v) ((env 'set) k (EVAL v env))) + (('let* kvs body) + (let* ((new-env (make-Env #:outer env)) + (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) + (receive (keys vals) (%unzip2 (->list kvs)) + (for-each setter keys vals)) + (EVAL body new-env))) + (('do rest ...) + (eval_seq rest env)) + (('if cnd thn els ...) + (cond + ((and (not (null? els)) (not (null? (cdr els)))) + ;; Invalid `if' form + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) + ((cond-true? (EVAL cnd env)) (EVAL thn env)) + (else (if (null? els) nil (EVAL (car els) env))))) + (('fn* params body ...) ; function definition + (lambda args + (eval_seq body (make-Env #:outer env #:binds (->list params) #:exprs args)))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (apply (car el) (cdr el)))))) + +(define (EVAL-string str) + (EVAL (read_str str) *toplevel*)) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +(EVAL-string "(def! not (fn* (x) (if x false true)))") + +(REPL) diff --git a/impls/guile/step5_tco.scm b/impls/guile/step5_tco.scm index c75e01942f..f627c0690f 100644 --- a/impls/guile/step5_tco.scm +++ b/impls/guile/step5_tco.scm @@ -1,133 +1,133 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) - (srfi srfi-1) (ice-9 receive) (env) (core) (types)) - -(define *toplevel* - (receive (b e) (unzip2 core.ns) - (make-Env #:binds b #:exprs (map make-func e)))) - -(define (READ str) - (read_str str)) - -(define (eval_ast ast env) - (define (_eval x) (EVAL x env)) - (match ast - ((? _nil? obj) obj) - ((? symbol? sym) (env-has sym env)) - ((? list? lst) (map _eval lst)) - ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) - ((? hash-table? ht) - (define new-ht (make-hash-table)) - (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) - new-ht) - (else ast))) - -(define (eval_seq ast env) - (cond - ((null? ast) nil) - ((null? (cdr ast)) (EVAL (car ast) env)) - (else - (EVAL (car ast) env) - (eval_seq (cdr ast) env)))) - -(define (EVAL ast env) - (define (%unzip2 kvs) - (let lp((next kvs) (k '()) (v '())) - (cond - ;; NOTE: reverse is very important here! - ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) - (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) - (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) - ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means - ;; it'll bring some trouble in control flow. We have to use continuations to return - ;; and use non-standard `break' feature. In a word, not elegant at all. - ;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO! - ;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of - ;; TCO in Scheme to implement TCO, but it's the same principle with normal loop. - ;; If you're Lispy enough, there's no recursive at all while you saw named let loop. - (let tco-loop((ast ast) (env env)) - (match ast - ((? non-list?) (eval_ast ast env)) - (() ast) - (('def! k v) ((env 'set) k (EVAL v env))) - (('let* kvs body) - (let* ((new-env (make-Env #:outer env)) - (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) - (receive (keys vals) (%unzip2 (->list kvs)) - (for-each setter keys vals)) - (tco-loop body new-env))) - (('do rest ...) - (cond - ((null? rest) - (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) - ((= 1 (length rest)) (tco-loop (car rest) env)) - (else - (let ((mexpr (take rest (1- (length rest)))) - (tail-call (car (take-right rest 1)))) - (eval_seq mexpr env) - (tco-loop tail-call env))))) - (('if cnd thn els ...) - (cond - ((and (not (null? els)) (not (null? (cdr els)))) - ;; Invalid `if' form - (throw 'mal-error - (format #f "if: failed to match any pattern in form '~a'" ast))) - ((cond-true? (EVAL cnd env)) (tco-loop thn env)) - (else (if (null? els) nil (tco-loop (car els) env))))) - (('fn* params body ...) ; function definition - (make-func - (lambda args - (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) - (cond - ((null? body) - (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) - ((= 1 (length body)) (tco-loop (car body) nenv)) - (else - (let ((mexpr (take body (1- (length body)))) - (tail-call (car (take-right body 1)))) - (eval_seq mexpr nenv) - (tco-loop tail-call nenv)))))))) - (else - (let ((el (map (lambda (x) (EVAL x env)) ast))) - (callable-apply (car el) (cdr el))))))) - -(define (EVAL-string str) - (EVAL (read_str str) *toplevel*)) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) *toplevel*))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -(EVAL-string "(def! not (fn* (x) (if x false true)))") - -(REPL) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) + (srfi srfi-1) (ice-9 receive) (env) (core) (types)) + +(define *toplevel* + (receive (b e) (unzip2 core.ns) + (make-Env #:binds b #:exprs (map make-func e)))) + +(define (READ str) + (read_str str)) + +(define (eval_ast ast env) + (define (_eval x) (EVAL x env)) + (match ast + ((? _nil? obj) obj) + ((? symbol? sym) (env-has sym env)) + ((? list? lst) (map _eval lst)) + ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) + ((? hash-table? ht) + (define new-ht (make-hash-table)) + (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) + new-ht) + (else ast))) + +(define (eval_seq ast env) + (cond + ((null? ast) nil) + ((null? (cdr ast)) (EVAL (car ast) env)) + (else + (EVAL (car ast) env) + (eval_seq (cdr ast) env)))) + +(define (EVAL ast env) + (define (%unzip2 kvs) + (let lp((next kvs) (k '()) (v '())) + (cond + ;; NOTE: reverse is very important here! + ((null? next) (values (reverse k) (reverse v))) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) + (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) + ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means + ;; it'll bring some trouble in control flow. We have to use continuations to return + ;; and use non-standard `break' feature. In a word, not elegant at all. + ;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO! + ;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of + ;; TCO in Scheme to implement TCO, but it's the same principle with normal loop. + ;; If you're Lispy enough, there's no recursive at all while you saw named let loop. + (let tco-loop((ast ast) (env env)) + (match ast + ((? non-list?) (eval_ast ast env)) + (() ast) + (('def! k v) ((env 'set) k (EVAL v env))) + (('let* kvs body) + (let* ((new-env (make-Env #:outer env)) + (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) + (receive (keys vals) (%unzip2 (->list kvs)) + (for-each setter keys vals)) + (tco-loop body new-env))) + (('do rest ...) + (cond + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) + ((= 1 (length rest)) (tco-loop (car rest) env)) + (else + (let ((mexpr (take rest (1- (length rest)))) + (tail-call (car (take-right rest 1)))) + (eval_seq mexpr env) + (tco-loop tail-call env))))) + (('if cnd thn els ...) + (cond + ((and (not (null? els)) (not (null? (cdr els)))) + ;; Invalid `if' form + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) + ((cond-true? (EVAL cnd env)) (tco-loop thn env)) + (else (if (null? els) nil (tco-loop (car els) env))))) + (('fn* params body ...) ; function definition + (make-func + (lambda args + (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) + (cond + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) + ((= 1 (length body)) (tco-loop (car body) nenv)) + (else + (let ((mexpr (take body (1- (length body)))) + (tail-call (car (take-right body 1)))) + (eval_seq mexpr nenv) + (tco-loop tail-call nenv)))))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el))))))) + +(define (EVAL-string str) + (EVAL (read_str str) *toplevel*)) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +(EVAL-string "(def! not (fn* (x) (if x false true)))") + +(REPL) diff --git a/impls/guile/step6_file.scm b/impls/guile/step6_file.scm index 1f12845214..e3df991792 100644 --- a/impls/guile/step6_file.scm +++ b/impls/guile/step6_file.scm @@ -1,142 +1,142 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) - (srfi srfi-1) (ice-9 receive) (env) (core) (types)) - -(define *toplevel* - (receive (b e) (unzip2 core.ns) - (make-Env #:binds b #:exprs (map make-func e)))) - -(define (READ str) - (read_str str)) - -(define (eval_ast ast env) - (define (_eval x) (EVAL x env)) - (match ast - ((? _nil? obj) obj) - ((? symbol? sym) (env-has sym env)) - ((? list? lst) (map _eval lst)) - ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) - ((? hash-table? ht) - (define new-ht (make-hash-table)) - (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) - new-ht) - (else ast))) - -(define (eval_seq ast env) - (cond - ((null? ast) nil) - ((null? (cdr ast)) (EVAL (car ast) env)) - (else - (EVAL (car ast) env) - (eval_seq (cdr ast) env)))) - -(define (EVAL ast env) - (define (%unzip2 kvs) - (let lp((next kvs) (k '()) (v '())) - (cond - ;; NOTE: reverse is very important here! - ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) - (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) - (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) - ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means - ;; it'll bring some trouble in control flow. We have to use continuations to return - ;; and use non-standard `break' feature. In a word, not elegant at all. - ;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO! - ;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of - ;; TCO in Scheme to implement TCO, but it's the same principle with normal loop. - ;; If you're Lispy enough, there's no recursive at all while you saw named let loop. - (let tco-loop((ast ast) (env env)) - (match ast - ((? non-list?) (eval_ast ast env)) - (() ast) - (('def! k v) ((env 'set) k (EVAL v env))) - (('let* kvs body) - (let* ((new-env (make-Env #:outer env)) - (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) - (receive (keys vals) (%unzip2 (->list kvs)) - (for-each setter keys vals)) - (tco-loop body new-env))) - (('do rest ...) - (cond - ((null? rest) - (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) - ((= 1 (length rest)) (tco-loop (car rest) env)) - (else - (let ((mexpr (take rest (1- (length rest)))) - (tail-call (car (take-right rest 1)))) - (eval_seq mexpr env) - (tco-loop tail-call env))))) - (('if cnd thn els ...) - (cond - ((and (not (null? els)) (not (null? (cdr els)))) - ;; Invalid `if' form - (throw 'mal-error - (format #f "if: failed to match any pattern in form '~a'" ast))) - ((cond-true? (EVAL cnd env)) (tco-loop thn env)) - (else (if (null? els) nil (tco-loop (car els) env))))) - (('fn* params body ...) ; function definition - (make-func - (lambda args - (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) - (cond - ((null? body) - (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) - ((= 1 (length body)) (tco-loop (car body) nenv)) - (else - (let ((mexpr (take body (1- (length body)))) - (tail-call (car (take-right body 1)))) - (eval_seq mexpr nenv) - (tco-loop tail-call nenv)))))))) - (else - (let ((el (map (lambda (x) (EVAL x env)) ast))) - (callable-apply (car el) (cdr el))))))) - -(define (EVAL-string str) - (EVAL (read_str str) *toplevel*)) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) *toplevel*))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -;; initialization -((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) -((*toplevel* 'set) '*ARGV* '()) -(EVAL-string "(def! not (fn* (x) (if x false true)))") -(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(let ((args (cdr (command-line)))) - (cond - ((> (length args) 0) - ((*toplevel* 'set) '*ARGV* (cdr args)) - (EVAL-string (string-append "(load-file \"" (car args) "\")"))) - (else (REPL)))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) + (srfi srfi-1) (ice-9 receive) (env) (core) (types)) + +(define *toplevel* + (receive (b e) (unzip2 core.ns) + (make-Env #:binds b #:exprs (map make-func e)))) + +(define (READ str) + (read_str str)) + +(define (eval_ast ast env) + (define (_eval x) (EVAL x env)) + (match ast + ((? _nil? obj) obj) + ((? symbol? sym) (env-has sym env)) + ((? list? lst) (map _eval lst)) + ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) + ((? hash-table? ht) + (define new-ht (make-hash-table)) + (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) + new-ht) + (else ast))) + +(define (eval_seq ast env) + (cond + ((null? ast) nil) + ((null? (cdr ast)) (EVAL (car ast) env)) + (else + (EVAL (car ast) env) + (eval_seq (cdr ast) env)))) + +(define (EVAL ast env) + (define (%unzip2 kvs) + (let lp((next kvs) (k '()) (v '())) + (cond + ;; NOTE: reverse is very important here! + ((null? next) (values (reverse k) (reverse v))) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) + (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) + ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means + ;; it'll bring some trouble in control flow. We have to use continuations to return + ;; and use non-standard `break' feature. In a word, not elegant at all. + ;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO! + ;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of + ;; TCO in Scheme to implement TCO, but it's the same principle with normal loop. + ;; If you're Lispy enough, there's no recursive at all while you saw named let loop. + (let tco-loop((ast ast) (env env)) + (match ast + ((? non-list?) (eval_ast ast env)) + (() ast) + (('def! k v) ((env 'set) k (EVAL v env))) + (('let* kvs body) + (let* ((new-env (make-Env #:outer env)) + (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) + (receive (keys vals) (%unzip2 (->list kvs)) + (for-each setter keys vals)) + (tco-loop body new-env))) + (('do rest ...) + (cond + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) + ((= 1 (length rest)) (tco-loop (car rest) env)) + (else + (let ((mexpr (take rest (1- (length rest)))) + (tail-call (car (take-right rest 1)))) + (eval_seq mexpr env) + (tco-loop tail-call env))))) + (('if cnd thn els ...) + (cond + ((and (not (null? els)) (not (null? (cdr els)))) + ;; Invalid `if' form + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) + ((cond-true? (EVAL cnd env)) (tco-loop thn env)) + (else (if (null? els) nil (tco-loop (car els) env))))) + (('fn* params body ...) ; function definition + (make-func + (lambda args + (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) + (cond + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) + ((= 1 (length body)) (tco-loop (car body) nenv)) + (else + (let ((mexpr (take body (1- (length body)))) + (tail-call (car (take-right body 1)))) + (eval_seq mexpr nenv) + (tco-loop tail-call nenv)))))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el))))))) + +(define (EVAL-string str) + (EVAL (read_str str) *toplevel*)) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +;; initialization +((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) +((*toplevel* 'set) '*ARGV* '()) +(EVAL-string "(def! not (fn* (x) (if x false true)))") +(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(let ((args (cdr (command-line)))) + (cond + ((> (length args) 0) + ((*toplevel* 'set) '*ARGV* (cdr args)) + (EVAL-string (string-append "(load-file \"" (car args) "\")"))) + (else (REPL)))) diff --git a/impls/guile/step7_quote.scm b/impls/guile/step7_quote.scm index 8a7d8422d2..bcb5ec0099 100644 --- a/impls/guile/step7_quote.scm +++ b/impls/guile/step7_quote.scm @@ -1,151 +1,151 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) - (srfi srfi-1) (ice-9 receive) (env) (core) (types)) - -(define *toplevel* - (receive (b e) (unzip2 core.ns) - (make-Env #:binds b #:exprs (map make-func e)))) - -(define (READ str) - (read_str str)) - -(define (eval_ast ast env) - (define (_eval x) (EVAL x env)) - (match ast - ((? _nil? obj) obj) - ((? symbol? sym) (env-has sym env)) - ((? list? lst) (map _eval lst)) - ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) - ((? hash-table? ht) - (define new-ht (make-hash-table)) - (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) - new-ht) - (else ast))) - -(define (eval_seq ast env) - (cond - ((null? ast) nil) - ((null? (cdr ast)) (EVAL (car ast) env)) - (else - (EVAL (car ast) env) - (eval_seq (cdr ast) env)))) - -(define (qqIter elt acc) - (match elt - (('splice-unquote x) (list 'concat x acc)) - (else (list 'cons (_quasiquote elt) acc)))) -(define (_quasiquote ast) - (match ast - (('unquote x) x) - ( (xs ...) (fold-right qqIter '() xs)) - (#(xs ...) (list 'vec (fold-right qqIter '() xs))) - ((? hash-table?) (list 'quote ast)) - ((? symbol?) (list 'quote ast)) - (else ast))) - -(define (EVAL ast env) - (define (%unzip2 kvs) - (let lp((next kvs) (k '()) (v '())) - (cond - ;; NOTE: reverse is very important here! - ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) - (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) - (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) - (let tco-loop((ast ast) (env env)) - (match ast - ((? non-list?) (eval_ast ast env)) - (() ast) - (('quote obj) obj) - (('quasiquoteexpand obj) (_quasiquote obj)) - (('quasiquote obj) (EVAL (_quasiquote obj) env)) - (('def! k v) ((env 'set) k (EVAL v env))) - (('let* kvs body) - (let* ((new-env (make-Env #:outer env)) - (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) - (receive (keys vals) (%unzip2 (->list kvs)) - (for-each setter keys vals)) - (tco-loop body new-env))) - (('do rest ...) - (cond - ((null? rest) - (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) - ((= 1 (length rest)) (tco-loop (car rest) env)) - (else - (let ((mexpr (take rest (1- (length rest)))) - (tail-call (car (take-right rest 1)))) - (eval_seq mexpr env) - (tco-loop tail-call env))))) - (('if cnd thn els ...) - (cond - ((and (not (null? els)) (not (null? (cdr els)))) - ;; Invalid `if' form - (throw 'mal-error - (format #f "if: failed to match any pattern in form '~a'" ast))) - ((cond-true? (EVAL cnd env)) (tco-loop thn env)) - (else (if (null? els) nil (tco-loop (car els) env))))) - (('fn* params body ...) ; function definition - (make-func - (lambda args - (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) - (cond - ((null? body) - (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) - ((= 1 (length body)) (tco-loop (car body) nenv)) - (else - (let ((mexpr (take body (1- (length body)))) - (tail-call (car (take-right body 1)))) - (eval_seq mexpr nenv) - (tco-loop tail-call nenv)))))))) - (else - (let ((el (map (lambda (x) (EVAL x env)) ast))) - (callable-apply (car el) (cdr el))))))) - -(define (EVAL-string str) - (EVAL (read_str str) *toplevel*)) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) *toplevel*))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -;; initialization -((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) -((*toplevel* 'set) '*ARGV* '()) -(EVAL-string "(def! not (fn* (x) (if x false true)))") -(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(let ((args (cdr (command-line)))) - (cond - ((> (length args) 0) - ((*toplevel* 'set) '*ARGV* (cdr args)) - (EVAL-string (string-append "(load-file \"" (car args) "\")"))) - (else (REPL)))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) + (srfi srfi-1) (ice-9 receive) (env) (core) (types)) + +(define *toplevel* + (receive (b e) (unzip2 core.ns) + (make-Env #:binds b #:exprs (map make-func e)))) + +(define (READ str) + (read_str str)) + +(define (eval_ast ast env) + (define (_eval x) (EVAL x env)) + (match ast + ((? _nil? obj) obj) + ((? symbol? sym) (env-has sym env)) + ((? list? lst) (map _eval lst)) + ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) + ((? hash-table? ht) + (define new-ht (make-hash-table)) + (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) + new-ht) + (else ast))) + +(define (eval_seq ast env) + (cond + ((null? ast) nil) + ((null? (cdr ast)) (EVAL (car ast) env)) + (else + (EVAL (car ast) env) + (eval_seq (cdr ast) env)))) + +(define (qqIter elt acc) + (match elt + (('splice-unquote x) (list 'concat x acc)) + (else (list 'cons (_quasiquote elt) acc)))) +(define (_quasiquote ast) + (match ast + (('unquote x) x) + ( (xs ...) (fold-right qqIter '() xs)) + (#(xs ...) (list 'vec (fold-right qqIter '() xs))) + ((? hash-table?) (list 'quote ast)) + ((? symbol?) (list 'quote ast)) + (else ast))) + +(define (EVAL ast env) + (define (%unzip2 kvs) + (let lp((next kvs) (k '()) (v '())) + (cond + ;; NOTE: reverse is very important here! + ((null? next) (values (reverse k) (reverse v))) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) + (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) + (let tco-loop((ast ast) (env env)) + (match ast + ((? non-list?) (eval_ast ast env)) + (() ast) + (('quote obj) obj) + (('quasiquoteexpand obj) (_quasiquote obj)) + (('quasiquote obj) (EVAL (_quasiquote obj) env)) + (('def! k v) ((env 'set) k (EVAL v env))) + (('let* kvs body) + (let* ((new-env (make-Env #:outer env)) + (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) + (receive (keys vals) (%unzip2 (->list kvs)) + (for-each setter keys vals)) + (tco-loop body new-env))) + (('do rest ...) + (cond + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) + ((= 1 (length rest)) (tco-loop (car rest) env)) + (else + (let ((mexpr (take rest (1- (length rest)))) + (tail-call (car (take-right rest 1)))) + (eval_seq mexpr env) + (tco-loop tail-call env))))) + (('if cnd thn els ...) + (cond + ((and (not (null? els)) (not (null? (cdr els)))) + ;; Invalid `if' form + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) + ((cond-true? (EVAL cnd env)) (tco-loop thn env)) + (else (if (null? els) nil (tco-loop (car els) env))))) + (('fn* params body ...) ; function definition + (make-func + (lambda args + (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) + (cond + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) + ((= 1 (length body)) (tco-loop (car body) nenv)) + (else + (let ((mexpr (take body (1- (length body)))) + (tail-call (car (take-right body 1)))) + (eval_seq mexpr nenv) + (tco-loop tail-call nenv)))))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el))))))) + +(define (EVAL-string str) + (EVAL (read_str str) *toplevel*)) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +;; initialization +((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) +((*toplevel* 'set) '*ARGV* '()) +(EVAL-string "(def! not (fn* (x) (if x false true)))") +(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(let ((args (cdr (command-line)))) + (cond + ((> (length args) 0) + ((*toplevel* 'set) '*ARGV* (cdr args)) + (EVAL-string (string-append "(load-file \"" (car args) "\")"))) + (else (REPL)))) diff --git a/impls/guile/step8_macros.scm b/impls/guile/step8_macros.scm index e58f4eb991..6c71fe75c5 100644 --- a/impls/guile/step8_macros.scm +++ b/impls/guile/step8_macros.scm @@ -1,171 +1,171 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) - (srfi srfi-1) (ice-9 receive) (env) (core) (types)) - -(define *toplevel* - (receive (b e) (unzip2 core.ns) - (make-Env #:binds b #:exprs (map make-func e)))) - -(define (READ str) - (read_str str)) - -(define (eval_ast ast env) - (define (_eval x) (EVAL x env)) - (match ast - ((? _nil? obj) obj) - ((? symbol? sym) (env-has sym env)) - ((? list? lst) (map _eval lst)) - ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) - ((? hash-table? ht) - (define new-ht (make-hash-table)) - (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) - new-ht) - (else ast))) - -(define (eval_seq ast env) - (cond - ((null? ast) nil) - ((null? (cdr ast)) (EVAL (car ast) env)) - (else - (EVAL (car ast) env) - (eval_seq (cdr ast) env)))) - -(define (qqIter elt acc) - (match elt - (('splice-unquote x) (list 'concat x acc)) - (else (list 'cons (_quasiquote elt) acc)))) -(define (_quasiquote ast) - (match ast - (('unquote x) x) - ( (xs ...) (fold-right qqIter '() xs)) - (#(xs ...) (list 'vec (fold-right qqIter '() xs))) - ((? hash-table?) (list 'quote ast)) - ((? symbol?) (list 'quote ast)) - (else ast))) - -(define (is_macro_call ast env) - (and (list? ast) - (> (length ast) 0) - (and=> (env-check (car ast) env) is-macro))) - -(define (_macroexpand ast env) - (cond - ((is_macro_call ast env) - => (lambda (c) - ;; NOTE: Macros are normal-order, so we shouldn't eval args here. - ;; Or it's applicable-order. - (_macroexpand (callable-apply c (cdr ast)) env))) - (else ast))) - -(define (EVAL ast env) - (define (%unzip2 kvs) - (let lp((next kvs) (k '()) (v '())) - (cond - ;; NOTE: reverse is very important here! - ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) - (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) - (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) - (let tco-loop((ast ast) (env env)) ; expand as possible - (let ((ast (_macroexpand ast env))) - (match ast - ((? non-list?) (eval_ast ast env)) - (() ast) - (('defmacro! k v) - (let ((c (EVAL v env))) - ((env 'set) k (callable-as-macro c)))) - (('macroexpand obj) (_macroexpand obj env)) - (('quote obj) obj) - (('quasiquoteexpand obj) (_quasiquote obj)) - (('quasiquote obj) (EVAL (_quasiquote obj) env)) - (('def! k v) ((env 'set) k (EVAL v env))) - (('let* kvs body) - (let* ((new-env (make-Env #:outer env)) - (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) - (receive (keys vals) (%unzip2 (->list kvs)) - (for-each setter keys vals)) - (tco-loop body new-env))) - (('do rest ...) - (cond - ((null? rest) - (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) - ((= 1 (length rest)) (tco-loop (car rest) env)) - (else - (let ((mexpr (take rest (1- (length rest)))) - (tail-call (car (take-right rest 1)))) - (eval_seq mexpr env) - (tco-loop tail-call env))))) - (('if cnd thn els ...) - (cond - ((and (not (null? els)) (not (null? (cdr els)))) - ;; Invalid `if' form - (throw 'mal-error - (format #f "if: failed to match any pattern in form '~a'" ast))) - ((cond-true? (EVAL cnd env)) (tco-loop thn env)) - (else (if (null? els) nil (tco-loop (car els) env))))) - (('fn* params body ...) ; function definition - (make-anonymous-func - (lambda args - (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) - (cond - ((null? body) - (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) - ((= 1 (length body)) (tco-loop (car body) nenv)) - (else - (let ((mexpr (take body (1- (length body)))) - (tail-call (car (take-right body 1)))) - (eval_seq mexpr nenv) - (tco-loop tail-call nenv)))))))) - (else - (let ((el (map (lambda (x) (EVAL x env)) ast))) - (callable-apply (car el) (cdr el)))))))) - -(define (EVAL-string str) - (EVAL (read_str str) *toplevel*)) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) *toplevel*))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -;; initialization -((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) -((*toplevel* 'set) '*ARGV* '()) -(EVAL-string "(def! not (fn* (x) (if x false true)))") -(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(EVAL-string "(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)))))))") - -(let ((args (cdr (command-line)))) - (cond - ((> (length args) 0) - ((*toplevel* 'set) '*ARGV* (cdr args)) - (EVAL-string (string-append "(load-file \"" (car args) "\")"))) - (else (REPL)))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) + (srfi srfi-1) (ice-9 receive) (env) (core) (types)) + +(define *toplevel* + (receive (b e) (unzip2 core.ns) + (make-Env #:binds b #:exprs (map make-func e)))) + +(define (READ str) + (read_str str)) + +(define (eval_ast ast env) + (define (_eval x) (EVAL x env)) + (match ast + ((? _nil? obj) obj) + ((? symbol? sym) (env-has sym env)) + ((? list? lst) (map _eval lst)) + ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) + ((? hash-table? ht) + (define new-ht (make-hash-table)) + (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) + new-ht) + (else ast))) + +(define (eval_seq ast env) + (cond + ((null? ast) nil) + ((null? (cdr ast)) (EVAL (car ast) env)) + (else + (EVAL (car ast) env) + (eval_seq (cdr ast) env)))) + +(define (qqIter elt acc) + (match elt + (('splice-unquote x) (list 'concat x acc)) + (else (list 'cons (_quasiquote elt) acc)))) +(define (_quasiquote ast) + (match ast + (('unquote x) x) + ( (xs ...) (fold-right qqIter '() xs)) + (#(xs ...) (list 'vec (fold-right qqIter '() xs))) + ((? hash-table?) (list 'quote ast)) + ((? symbol?) (list 'quote ast)) + (else ast))) + +(define (is_macro_call ast env) + (and (list? ast) + (> (length ast) 0) + (and=> (env-check (car ast) env) is-macro))) + +(define (_macroexpand ast env) + (cond + ((is_macro_call ast env) + => (lambda (c) + ;; NOTE: Macros are normal-order, so we shouldn't eval args here. + ;; Or it's applicable-order. + (_macroexpand (callable-apply c (cdr ast)) env))) + (else ast))) + +(define (EVAL ast env) + (define (%unzip2 kvs) + (let lp((next kvs) (k '()) (v '())) + (cond + ;; NOTE: reverse is very important here! + ((null? next) (values (reverse k) (reverse v))) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) + (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) + (let tco-loop((ast ast) (env env)) ; expand as possible + (let ((ast (_macroexpand ast env))) + (match ast + ((? non-list?) (eval_ast ast env)) + (() ast) + (('defmacro! k v) + (let ((c (EVAL v env))) + ((env 'set) k (callable-as-macro c)))) + (('macroexpand obj) (_macroexpand obj env)) + (('quote obj) obj) + (('quasiquoteexpand obj) (_quasiquote obj)) + (('quasiquote obj) (EVAL (_quasiquote obj) env)) + (('def! k v) ((env 'set) k (EVAL v env))) + (('let* kvs body) + (let* ((new-env (make-Env #:outer env)) + (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) + (receive (keys vals) (%unzip2 (->list kvs)) + (for-each setter keys vals)) + (tco-loop body new-env))) + (('do rest ...) + (cond + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) + ((= 1 (length rest)) (tco-loop (car rest) env)) + (else + (let ((mexpr (take rest (1- (length rest)))) + (tail-call (car (take-right rest 1)))) + (eval_seq mexpr env) + (tco-loop tail-call env))))) + (('if cnd thn els ...) + (cond + ((and (not (null? els)) (not (null? (cdr els)))) + ;; Invalid `if' form + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) + ((cond-true? (EVAL cnd env)) (tco-loop thn env)) + (else (if (null? els) nil (tco-loop (car els) env))))) + (('fn* params body ...) ; function definition + (make-anonymous-func + (lambda args + (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) + (cond + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) + ((= 1 (length body)) (tco-loop (car body) nenv)) + (else + (let ((mexpr (take body (1- (length body)))) + (tail-call (car (take-right body 1)))) + (eval_seq mexpr nenv) + (tco-loop tail-call nenv)))))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el)))))))) + +(define (EVAL-string str) + (EVAL (read_str str) *toplevel*)) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +;; initialization +((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) +((*toplevel* 'set) '*ARGV* '()) +(EVAL-string "(def! not (fn* (x) (if x false true)))") +(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(EVAL-string "(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)))))))") + +(let ((args (cdr (command-line)))) + (cond + ((> (length args) 0) + ((*toplevel* 'set) '*ARGV* (cdr args)) + (EVAL-string (string-append "(load-file \"" (car args) "\")"))) + (else (REPL)))) diff --git a/impls/guile/step9_try.scm b/impls/guile/step9_try.scm index 91f3dad7d5..108b2561db 100644 --- a/impls/guile/step9_try.scm +++ b/impls/guile/step9_try.scm @@ -1,194 +1,194 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) - (srfi srfi-1) (ice-9 receive) (env) (core) (types)) - -;; Primitives which doesn't unbox args in default. -;; This is a trick to implement meta-info taking advange of the original -;; types of Guile as possible. -(define *unbox-exception* '(meta assoc swap!)) - -(define *toplevel* - (receive (b e) (unzip2 core.ns) - (let ((env (make-Env #:binds b #:exprs (map make-func e)))) - (for-each (lambda (f) - (callable-unbox-set! ((env 'get) f) #f)) - *unbox-exception*) - env))) - -(define (READ str) - (read_str str)) - -(define (eval_ast ast env) - (define (_eval x) (EVAL x env)) - (match ast - ((? _nil? obj) obj) - ((? symbol? sym) (env-has sym env)) - ((? list? lst) (map _eval lst)) - ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) - ((? hash-table? ht) - (define new-ht (make-hash-table)) - (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) - new-ht) - (else ast))) - - -(define (eval_seq ast env) - (cond - ((null? ast) nil) - ((null? (cdr ast)) (EVAL (car ast) env)) - (else - (EVAL (car ast) env) - (eval_seq (cdr ast) env)))) - -(define (qqIter elt acc) - (match elt - (('splice-unquote x) (list 'concat x acc)) - (else (list 'cons (_quasiquote elt) acc)))) -(define (_quasiquote ast) - (match ast - (('unquote x) x) - ( (xs ...) (fold-right qqIter '() xs)) - (#(xs ...) (list 'vec (fold-right qqIter '() xs))) - ((? hash-table?) (list 'quote ast)) - ((? symbol?) (list 'quote ast)) - (else ast))) - -(define (is_macro_call ast env) - (and (list? ast) - (> (length ast) 0) - (and=> (env-check (car ast) env) is-macro))) - -(define (_macroexpand ast env) - (cond - ((is_macro_call ast env) - => (lambda (c) - ;;(format #t "AAA: ~a, ~a~%" ast (_macroexpand (callable-apply c (cdr ast)) env)) - ;;(format #t "BBB: ~a~%" (_macroexpand (callable-apply c (cdr ast)) env)) - ;; NOTE: Macros are normal-order, so we shouldn't eval args here. - ;; Or it's applicable-order. - (_macroexpand (callable-apply c (cdr ast)) env))) - (else ast))) - -(define (EVAL ast env) - (define (%unzip2 kvs) - (let lp((next kvs) (k '()) (v '())) - (cond - ;; NOTE: reverse is very important here! - ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) - (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) - (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) - (let tco-loop((ast ast) (env env)) ; expand as possible - ;;(format #t "CCC: ~a === ~a~%" ast (_macroexpand ast env)) - (let ((ast (_macroexpand ast env))) - (match ast - ((? non-list?) (eval_ast ast env)) - (() ast) - (('defmacro! k v) - (let ((c (EVAL v env))) - ((env 'set) k (callable-as-macro c)))) - (('macroexpand obj) (_macroexpand obj env)) - (('quote obj) obj) - (('quasiquoteexpand obj) (_quasiquote obj)) - (('quasiquote obj) (EVAL (_quasiquote obj) env)) - (('def! k v) ((env 'set) k (EVAL v env))) - (('let* kvs body) - (let* ((new-env (make-Env #:outer env)) - (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) - (receive (keys vals) (%unzip2 (->list kvs)) - (for-each setter keys vals)) - (tco-loop body new-env))) - (('do rest ...) - (cond - ((null? rest) - (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) - ((= 1 (length rest)) (tco-loop (car rest) env)) - (else - (let ((mexpr (take rest (1- (length rest)))) - (tail-call (car (take-right rest 1)))) - (eval_seq mexpr env) - (tco-loop tail-call env))))) - (('if cnd thn els ...) - (cond - ((and (not (null? els)) (not (null? (cdr els)))) - ;; Invalid `if' form - (throw 'mal-error - (format #f "if: failed to match any pattern in form '~a'" ast))) - ((cond-true? (EVAL cnd env)) (tco-loop thn env)) - (else (if (null? els) nil (tco-loop (car els) env))))) - (('fn* params body ...) ; function definition - (make-anonymous-func - (lambda args - (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) - (cond - ((null? body) - (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) - ((= 1 (length body)) (tco-loop (car body) nenv)) - (else - (let ((mexpr (take body (1- (length body)))) - (tail-call (car (take-right body 1)))) - (eval_seq mexpr nenv) - (tco-loop tail-call nenv)))))))) - (('try* A) - (EVAL A env)) - (('try* A ('catch* B C)) - (catch - #t - (lambda () (EVAL A env)) - (lambda e - (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e)))) - (EVAL C nenv))))) - (else - (let ((el (map (lambda (x) (EVAL x env)) ast))) - (callable-apply (car el) (cdr el)))))))) - -(define (EVAL-string str) - (EVAL (read_str str) *toplevel*)) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) *toplevel*))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -;; initialization -((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) -((*toplevel* 'set) 'throw (make-func (lambda (val) (throw 'mal-error val)))) -((*toplevel* 'set) '*ARGV* '()) -(EVAL-string "(def! not (fn* (x) (if x false true)))") -(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(EVAL-string "(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)))))))") - -(let ((args (cdr (command-line)))) - (cond - ((> (length args) 0) - ((*toplevel* 'set) '*ARGV* (cdr args)) - (EVAL-string (string-append "(load-file \"" (car args) "\")"))) - (else (REPL)))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) + (srfi srfi-1) (ice-9 receive) (env) (core) (types)) + +;; Primitives which doesn't unbox args in default. +;; This is a trick to implement meta-info taking advange of the original +;; types of Guile as possible. +(define *unbox-exception* '(meta assoc swap!)) + +(define *toplevel* + (receive (b e) (unzip2 core.ns) + (let ((env (make-Env #:binds b #:exprs (map make-func e)))) + (for-each (lambda (f) + (callable-unbox-set! ((env 'get) f) #f)) + *unbox-exception*) + env))) + +(define (READ str) + (read_str str)) + +(define (eval_ast ast env) + (define (_eval x) (EVAL x env)) + (match ast + ((? _nil? obj) obj) + ((? symbol? sym) (env-has sym env)) + ((? list? lst) (map _eval lst)) + ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) + ((? hash-table? ht) + (define new-ht (make-hash-table)) + (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) + new-ht) + (else ast))) + + +(define (eval_seq ast env) + (cond + ((null? ast) nil) + ((null? (cdr ast)) (EVAL (car ast) env)) + (else + (EVAL (car ast) env) + (eval_seq (cdr ast) env)))) + +(define (qqIter elt acc) + (match elt + (('splice-unquote x) (list 'concat x acc)) + (else (list 'cons (_quasiquote elt) acc)))) +(define (_quasiquote ast) + (match ast + (('unquote x) x) + ( (xs ...) (fold-right qqIter '() xs)) + (#(xs ...) (list 'vec (fold-right qqIter '() xs))) + ((? hash-table?) (list 'quote ast)) + ((? symbol?) (list 'quote ast)) + (else ast))) + +(define (is_macro_call ast env) + (and (list? ast) + (> (length ast) 0) + (and=> (env-check (car ast) env) is-macro))) + +(define (_macroexpand ast env) + (cond + ((is_macro_call ast env) + => (lambda (c) + ;;(format #t "AAA: ~a, ~a~%" ast (_macroexpand (callable-apply c (cdr ast)) env)) + ;;(format #t "BBB: ~a~%" (_macroexpand (callable-apply c (cdr ast)) env)) + ;; NOTE: Macros are normal-order, so we shouldn't eval args here. + ;; Or it's applicable-order. + (_macroexpand (callable-apply c (cdr ast)) env))) + (else ast))) + +(define (EVAL ast env) + (define (%unzip2 kvs) + (let lp((next kvs) (k '()) (v '())) + (cond + ;; NOTE: reverse is very important here! + ((null? next) (values (reverse k) (reverse v))) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) + (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) + (let tco-loop((ast ast) (env env)) ; expand as possible + ;;(format #t "CCC: ~a === ~a~%" ast (_macroexpand ast env)) + (let ((ast (_macroexpand ast env))) + (match ast + ((? non-list?) (eval_ast ast env)) + (() ast) + (('defmacro! k v) + (let ((c (EVAL v env))) + ((env 'set) k (callable-as-macro c)))) + (('macroexpand obj) (_macroexpand obj env)) + (('quote obj) obj) + (('quasiquoteexpand obj) (_quasiquote obj)) + (('quasiquote obj) (EVAL (_quasiquote obj) env)) + (('def! k v) ((env 'set) k (EVAL v env))) + (('let* kvs body) + (let* ((new-env (make-Env #:outer env)) + (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) + (receive (keys vals) (%unzip2 (->list kvs)) + (for-each setter keys vals)) + (tco-loop body new-env))) + (('do rest ...) + (cond + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) + ((= 1 (length rest)) (tco-loop (car rest) env)) + (else + (let ((mexpr (take rest (1- (length rest)))) + (tail-call (car (take-right rest 1)))) + (eval_seq mexpr env) + (tco-loop tail-call env))))) + (('if cnd thn els ...) + (cond + ((and (not (null? els)) (not (null? (cdr els)))) + ;; Invalid `if' form + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) + ((cond-true? (EVAL cnd env)) (tco-loop thn env)) + (else (if (null? els) nil (tco-loop (car els) env))))) + (('fn* params body ...) ; function definition + (make-anonymous-func + (lambda args + (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) + (cond + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) + ((= 1 (length body)) (tco-loop (car body) nenv)) + (else + (let ((mexpr (take body (1- (length body)))) + (tail-call (car (take-right body 1)))) + (eval_seq mexpr nenv) + (tco-loop tail-call nenv)))))))) + (('try* A) + (EVAL A env)) + (('try* A ('catch* B C)) + (catch + #t + (lambda () (EVAL A env)) + (lambda e + (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e)))) + (EVAL C nenv))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el)))))))) + +(define (EVAL-string str) + (EVAL (read_str str) *toplevel*)) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +;; initialization +((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) +((*toplevel* 'set) 'throw (make-func (lambda (val) (throw 'mal-error val)))) +((*toplevel* 'set) '*ARGV* '()) +(EVAL-string "(def! not (fn* (x) (if x false true)))") +(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(EVAL-string "(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)))))))") + +(let ((args (cdr (command-line)))) + (cond + ((> (length args) 0) + ((*toplevel* 'set) '*ARGV* (cdr args)) + (EVAL-string (string-append "(load-file \"" (car args) "\")"))) + (else (REPL)))) diff --git a/impls/guile/stepA_mal.scm b/impls/guile/stepA_mal.scm index a010273e1b..5ffd15bf6f 100644 --- a/impls/guile/stepA_mal.scm +++ b/impls/guile/stepA_mal.scm @@ -1,194 +1,194 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) - (srfi srfi-1) (ice-9 receive) (env) (core) (types)) - -;; Primitives which doesn't unbox args in default. -;; This is a trick to implement meta-info taking advange of the original -;; types of Guile as possible. -(define *unbox-exception* '(meta assoc swap!)) - -(define *toplevel* - (receive (b e) (unzip2 core.ns) - (let ((env (make-Env #:binds b #:exprs (map make-func e)))) - (for-each (lambda (f) - (callable-unbox-set! ((env 'get) f) #f)) - *unbox-exception*) - env))) - -(define (READ str) - (read_str str)) - -(define (eval_ast ast env) - (define (_eval x) (EVAL x env)) - (match ast - ((? _nil? obj) obj) - ((? symbol? sym) (env-has sym env)) - ((? list? lst) (map _eval lst)) - ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) - ((? hash-table? ht) - (define new-ht (make-hash-table)) - (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) - new-ht) - (else ast))) - - -(define (eval_seq ast env) - (cond - ((null? ast) nil) - ((null? (cdr ast)) (EVAL (car ast) env)) - (else - (EVAL (car ast) env) - (eval_seq (cdr ast) env)))) - -(define (qqIter elt acc) - (match elt - (('splice-unquote x) (list 'concat x acc)) - (else (list 'cons (_quasiquote elt) acc)))) -(define (_quasiquote ast) - (match ast - (('unquote x) x) - ( (xs ...) (fold-right qqIter '() xs)) - (#(xs ...) (list 'vec (fold-right qqIter '() xs))) - ((? hash-table?) (list 'quote ast)) - ((? symbol?) (list 'quote ast)) - (else ast))) - -(define (is_macro_call ast env) - (and (list? ast) - (> (length ast) 0) - (and=> (env-check (car ast) env) is-macro))) - -(define (_macroexpand ast env) - (cond - ((is_macro_call ast env) - => (lambda (c) - ;; NOTE: Macros are normal-order, so we shouldn't eval args here. - ;; Or it's applicable-order. - (_macroexpand (callable-apply c (cdr ast)) env))) - (else ast))) - -(define (EVAL ast env) - (define (%unzip2 kvs) - (let lp((next kvs) (k '()) (v '())) - (cond - ;; NOTE: reverse is very important here! - ((null? next) (values (reverse k) (reverse v))) - ((null? (cdr next)) - (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) - (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) - (let tco-loop((ast ast) (env env)) ; expand as possible - (let ((ast (_macroexpand ast env))) - (match ast - ((? non-list?) (eval_ast ast env)) - (() ast) - (('defmacro! k v) - (let ((c (EVAL v env))) - ((env 'set) k (callable-as-macro c)))) - (('macroexpand obj) (_macroexpand obj env)) - (('quote obj) obj) - (('quasiquoteexpand obj) (_quasiquote obj)) - (('quasiquote obj) (EVAL (_quasiquote obj) env)) - (('def! k v) ((env 'set) k (EVAL v env))) - (('let* kvs body) - (let* ((new-env (make-Env #:outer env)) - (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) - (receive (keys vals) (%unzip2 (->list kvs)) - (for-each setter keys vals)) - (tco-loop body new-env))) - (('do rest ...) - (cond - ((null? rest) - (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) - ((= 1 (length rest)) (tco-loop (car rest) env)) - (else - (let ((mexpr (take rest (1- (length rest)))) - (tail-call (car (take-right rest 1)))) - (eval_seq mexpr env) - (tco-loop tail-call env))))) - (('if cnd thn els ...) - (cond - ((and (not (null? els)) (not (null? (cdr els)))) - ;; Invalid `if' form - (throw 'mal-error - (format #f "if: failed to match any pattern in form '~a'" ast))) - ((cond-true? (EVAL cnd env)) (tco-loop thn env)) - (else (if (null? els) nil (tco-loop (car els) env))))) - (('fn* params body ...) ; function definition - (make-anonymous-func - (lambda args - (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) - (cond - ((null? body) - (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) - ((= 1 (length body)) (tco-loop (car body) nenv)) - (else - (let ((mexpr (take body (1- (length body)))) - (tail-call (car (take-right body 1)))) - (eval_seq mexpr nenv) - (tco-loop tail-call nenv)))))))) - (('try* A) - (EVAL A env)) - (('try* A ('catch* B C)) - (catch - #t - (lambda () (EVAL A env)) - (lambda e - (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e)))) - (EVAL C nenv))))) - (else - (let ((el (map (lambda (x) (EVAL x env)) ast))) - (callable-apply (car el) (cdr el)))))))) - -(define (EVAL-string str) - (EVAL (read_str str) *toplevel*)) - -(define (PRINT exp) - (and (not (eof-object? exp)) - (format #t "~a~%" (pr_str exp #t)))) - -(define (LOOP continue?) - (and continue? (REPL))) - -(define (REPL) - (LOOP - (let ((line (_readline "user> "))) - (cond - ((eof-object? line) #f) - ((string=? line "") #t) - (else - (catch 'mal-error - (lambda () (PRINT (EVAL (READ line) *toplevel*))) - (lambda (k . e) - (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) - -;; initialization -((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) -((*toplevel* 'set) 'throw (make-func (lambda (val) (throw 'mal-error val)))) -((*toplevel* 'set) '*ARGV* '()) -(EVAL-string "(def! not (fn* (x) (if x false true)))") -(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(EVAL-string "(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)))))))") -(EVAL-string "(def! *host-language* \"guile\")") - -(let ((args (cdr (command-line)))) - (cond - ((> (length args) 0) - ((*toplevel* 'set) '*ARGV* (cdr args)) - (EVAL-string (string-append "(load-file \"" (car args) "\")"))) - (else - (EVAL-string "(println (str \"Mal (\" *host-language* \")\"))") - (REPL)))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) + (srfi srfi-1) (ice-9 receive) (env) (core) (types)) + +;; Primitives which doesn't unbox args in default. +;; This is a trick to implement meta-info taking advange of the original +;; types of Guile as possible. +(define *unbox-exception* '(meta assoc swap!)) + +(define *toplevel* + (receive (b e) (unzip2 core.ns) + (let ((env (make-Env #:binds b #:exprs (map make-func e)))) + (for-each (lambda (f) + (callable-unbox-set! ((env 'get) f) #f)) + *unbox-exception*) + env))) + +(define (READ str) + (read_str str)) + +(define (eval_ast ast env) + (define (_eval x) (EVAL x env)) + (match ast + ((? _nil? obj) obj) + ((? symbol? sym) (env-has sym env)) + ((? list? lst) (map _eval lst)) + ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) + ((? hash-table? ht) + (define new-ht (make-hash-table)) + (hash-for-each (lambda (k v) (hash-set! new-ht k (_eval v))) ht) + new-ht) + (else ast))) + + +(define (eval_seq ast env) + (cond + ((null? ast) nil) + ((null? (cdr ast)) (EVAL (car ast) env)) + (else + (EVAL (car ast) env) + (eval_seq (cdr ast) env)))) + +(define (qqIter elt acc) + (match elt + (('splice-unquote x) (list 'concat x acc)) + (else (list 'cons (_quasiquote elt) acc)))) +(define (_quasiquote ast) + (match ast + (('unquote x) x) + ( (xs ...) (fold-right qqIter '() xs)) + (#(xs ...) (list 'vec (fold-right qqIter '() xs))) + ((? hash-table?) (list 'quote ast)) + ((? symbol?) (list 'quote ast)) + (else ast))) + +(define (is_macro_call ast env) + (and (list? ast) + (> (length ast) 0) + (and=> (env-check (car ast) env) is-macro))) + +(define (_macroexpand ast env) + (cond + ((is_macro_call ast env) + => (lambda (c) + ;; NOTE: Macros are normal-order, so we shouldn't eval args here. + ;; Or it's applicable-order. + (_macroexpand (callable-apply c (cdr ast)) env))) + (else ast))) + +(define (EVAL ast env) + (define (%unzip2 kvs) + (let lp((next kvs) (k '()) (v '())) + (cond + ;; NOTE: reverse is very important here! + ((null? next) (values (reverse k) (reverse v))) + ((null? (cdr next)) + (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) + (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) + (let tco-loop((ast ast) (env env)) ; expand as possible + (let ((ast (_macroexpand ast env))) + (match ast + ((? non-list?) (eval_ast ast env)) + (() ast) + (('defmacro! k v) + (let ((c (EVAL v env))) + ((env 'set) k (callable-as-macro c)))) + (('macroexpand obj) (_macroexpand obj env)) + (('quote obj) obj) + (('quasiquoteexpand obj) (_quasiquote obj)) + (('quasiquote obj) (EVAL (_quasiquote obj) env)) + (('def! k v) ((env 'set) k (EVAL v env))) + (('let* kvs body) + (let* ((new-env (make-Env #:outer env)) + (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) + (receive (keys vals) (%unzip2 (->list kvs)) + (for-each setter keys vals)) + (tco-loop body new-env))) + (('do rest ...) + (cond + ((null? rest) + (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) + ((= 1 (length rest)) (tco-loop (car rest) env)) + (else + (let ((mexpr (take rest (1- (length rest)))) + (tail-call (car (take-right rest 1)))) + (eval_seq mexpr env) + (tco-loop tail-call env))))) + (('if cnd thn els ...) + (cond + ((and (not (null? els)) (not (null? (cdr els)))) + ;; Invalid `if' form + (throw 'mal-error + (format #f "if: failed to match any pattern in form '~a'" ast))) + ((cond-true? (EVAL cnd env)) (tco-loop thn env)) + (else (if (null? els) nil (tco-loop (car els) env))))) + (('fn* params body ...) ; function definition + (make-anonymous-func + (lambda args + (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) + (cond + ((null? body) + (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) + ((= 1 (length body)) (tco-loop (car body) nenv)) + (else + (let ((mexpr (take body (1- (length body)))) + (tail-call (car (take-right body 1)))) + (eval_seq mexpr nenv) + (tco-loop tail-call nenv)))))))) + (('try* A) + (EVAL A env)) + (('try* A ('catch* B C)) + (catch + #t + (lambda () (EVAL A env)) + (lambda e + (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e)))) + (EVAL C nenv))))) + (else + (let ((el (map (lambda (x) (EVAL x env)) ast))) + (callable-apply (car el) (cdr el)))))))) + +(define (EVAL-string str) + (EVAL (read_str str) *toplevel*)) + +(define (PRINT exp) + (and (not (eof-object? exp)) + (format #t "~a~%" (pr_str exp #t)))) + +(define (LOOP continue?) + (and continue? (REPL))) + +(define (REPL) + (LOOP + (let ((line (_readline "user> "))) + (cond + ((eof-object? line) #f) + ((string=? line "") #t) + (else + (catch 'mal-error + (lambda () (PRINT (EVAL (READ line) *toplevel*))) + (lambda (k . e) + (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) + +;; initialization +((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) +((*toplevel* 'set) 'throw (make-func (lambda (val) (throw 'mal-error val)))) +((*toplevel* 'set) '*ARGV* '()) +(EVAL-string "(def! not (fn* (x) (if x false true)))") +(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(EVAL-string "(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)))))))") +(EVAL-string "(def! *host-language* \"guile\")") + +(let ((args (cdr (command-line)))) + (cond + ((> (length args) 0) + ((*toplevel* 'set) '*ARGV* (cdr args)) + (EVAL-string (string-append "(load-file \"" (car args) "\")"))) + (else + (EVAL-string "(println (str \"Mal (\" *host-language* \")\"))") + (REPL)))) diff --git a/impls/guile/types.scm b/impls/guile/types.scm index 1e51bc8bc6..f99b6d79d3 100644 --- a/impls/guile/types.scm +++ b/impls/guile/types.scm @@ -1,110 +1,110 @@ -;; Copyright (C) 2015 -;; "Mu Lei" known as "NalaGinrut" -;; This file is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -(library (types) - (export string-sub *eof* non-list? - string->keyword _keyword? _string? - nil _nil? list->hash-map - cond-true? make-anonymous-func - make-atom atom? atom-val atom-val-set! - make-callable callable? callable-is_macro - callable-as-macro callable-closure - is-func is-func? is-macro is-macro? make-func callable-apply - callable-unbox-set! callable-unbox - callable-meta-info hash-table-clone - box? box unbox) - (import (guile) (only (rnrs) define-record-type) (ice-9 regex) (ice-9 session))) - -(define (non-list? x) (not (list? x))) - - -(define (string-sub str p1 p2) - (regexp-substitute/global #f p1 str 'pre p2 'post)) - -(define *eof* (call-with-input-string "" read)) - -(define (string->keyword str) - (when (not (string? str)) - (throw 'mal-error (format #f "string->keyword: '~a' is not a string" str))) - (string-append "\u029e" str)) - -(define (_keyword? k) - (and (string? k) - (> (string-length k) 0) - (char=? #\1236 (string-ref k 0)))) - -(define (_string? s) - (and (string? s) (not (_keyword? s)))) - -(define-record-type mal-nil) - -(define nil (make-mal-nil)) - -(define (_nil? obj) (mal-nil? obj)) - -(define (cond-true? obj) - (and (not (_nil? obj)) obj)) - -(define-record-type atom (fields (mutable val))) - -(define-record-type callable - (fields - meta-info - (mutable unbox) - (mutable is_macro) - closure)) - -(define (make-func closure) (make-callable nil #t #f closure)) -(define (make-anonymous-func closure) (make-callable nil #f #f closure)) - -(define (callable-apply c arglst) - (apply (callable-closure c) (if (callable-unbox c) (map unbox arglst) arglst))) - -(define (callable-check c b) - (and (callable? c) - (eq? (callable-is_macro c) b) - c)) - -(define (is-func c) (callable-check c #f)) -(define (is-func? c) (and (is-func c) #t)) -(define (is-macro c) (callable-check c #t)) -(define (is-macro? c) (and (is-macro c) #t)) -(define (callable-as-macro c) - (make-callable nil (callable-unbox c) #t (callable-closure c))) - -(define (hash-table-clone ht) - (list->hash-map (hash-fold (lambda (k v p) (cons k (cons v p))) '() ht))) - -(define-record-type box (fields val)) - -(define (box o) (make-box o)) -(define (unbox o) - (if (box? o) (box-val o) o)) - -(define* (list->hash-map lst #:optional (ht (make-hash-table))) - (cond - ((null? lst) ht) - (else - (let lp((next lst)) - (cond - ((null? next) ht) - (else - (when (null? (cdr next)) - (throw 'mal-error - (format #f "hash-map: '~a' lack of value" (car next)))) - (let ((k (car next)) - (v (cadr next))) - (hash-set! ht k v) - (lp (cddr next))))))))) +;; Copyright (C) 2015 +;; "Mu Lei" known as "NalaGinrut" +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(library (types) + (export string-sub *eof* non-list? + string->keyword _keyword? _string? + nil _nil? list->hash-map + cond-true? make-anonymous-func + make-atom atom? atom-val atom-val-set! + make-callable callable? callable-is_macro + callable-as-macro callable-closure + is-func is-func? is-macro is-macro? make-func callable-apply + callable-unbox-set! callable-unbox + callable-meta-info hash-table-clone + box? box unbox) + (import (guile) (only (rnrs) define-record-type) (ice-9 regex) (ice-9 session))) + +(define (non-list? x) (not (list? x))) + + +(define (string-sub str p1 p2) + (regexp-substitute/global #f p1 str 'pre p2 'post)) + +(define *eof* (call-with-input-string "" read)) + +(define (string->keyword str) + (when (not (string? str)) + (throw 'mal-error (format #f "string->keyword: '~a' is not a string" str))) + (string-append "\u029e" str)) + +(define (_keyword? k) + (and (string? k) + (> (string-length k) 0) + (char=? #\1236 (string-ref k 0)))) + +(define (_string? s) + (and (string? s) (not (_keyword? s)))) + +(define-record-type mal-nil) + +(define nil (make-mal-nil)) + +(define (_nil? obj) (mal-nil? obj)) + +(define (cond-true? obj) + (and (not (_nil? obj)) obj)) + +(define-record-type atom (fields (mutable val))) + +(define-record-type callable + (fields + meta-info + (mutable unbox) + (mutable is_macro) + closure)) + +(define (make-func closure) (make-callable nil #t #f closure)) +(define (make-anonymous-func closure) (make-callable nil #f #f closure)) + +(define (callable-apply c arglst) + (apply (callable-closure c) (if (callable-unbox c) (map unbox arglst) arglst))) + +(define (callable-check c b) + (and (callable? c) + (eq? (callable-is_macro c) b) + c)) + +(define (is-func c) (callable-check c #f)) +(define (is-func? c) (and (is-func c) #t)) +(define (is-macro c) (callable-check c #t)) +(define (is-macro? c) (and (is-macro c) #t)) +(define (callable-as-macro c) + (make-callable nil (callable-unbox c) #t (callable-closure c))) + +(define (hash-table-clone ht) + (list->hash-map (hash-fold (lambda (k v p) (cons k (cons v p))) '() ht))) + +(define-record-type box (fields val)) + +(define (box o) (make-box o)) +(define (unbox o) + (if (box? o) (box-val o) o)) + +(define* (list->hash-map lst #:optional (ht (make-hash-table))) + (cond + ((null? lst) ht) + (else + (let lp((next lst)) + (cond + ((null? next) ht) + (else + (when (null? (cdr next)) + (throw 'mal-error + (format #f "hash-map: '~a' lack of value" (car next)))) + (let ((k (car next)) + (v (cadr next))) + (hash-set! ht k v) + (lp (cddr next))))))))) diff --git a/impls/haskell/Core.hs b/impls/haskell/Core.hs index f2468cd60a..6f549951e6 100644 --- a/impls/haskell/Core.hs +++ b/impls/haskell/Core.hs @@ -1,400 +1,400 @@ -module Core -( ns ) -where - -import System.IO (hFlush, stdout) -import Control.Monad.Except (throwError) -import Control.Monad.Trans (liftIO) -import qualified Data.Map.Strict as Map -import Data.Foldable (foldlM) -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.IORef (newIORef, readIORef, writeIORef) - -import Readline (readline) -import Reader (read_str) -import Types -import Printer (_pr_list) - --- General functions - -equal_Q :: Fn -equal_Q [a, b] = return $ MalBoolean $ a == b -equal_Q _ = throwStr "illegal arguments to =" - --- Error/Exception functions - -throw :: Fn -throw [mv] = throwError mv -throw _ = throwStr "illegal arguments to throw" - --- Unary predicates - -pred1 :: String -> (MalVal -> Bool) -> (String, Fn) -pred1 name op = (name, fn) where - fn :: Fn - fn [a] = return $ MalBoolean $ op a - fn _ = throwStr $ "illegal arguments to " ++ name - -atom_Q :: MalVal -> Bool -atom_Q (MalAtom _ _) = True -atom_Q _ = False - -false_Q :: MalVal -> Bool -false_Q (MalBoolean False) = True -false_Q _ = False - -fn_Q :: MalVal -> Bool -fn_Q (MalFunction _ _) = True -fn_Q _ = False - -macro_Q :: MalVal -> Bool -macro_Q (MalMacro _) = True -macro_Q _ = False - -map_Q :: MalVal -> Bool -map_Q (MalHashMap _ _) = True -map_Q _ = False - -keyword_Q :: MalVal -> Bool -keyword_Q (MalKeyword _) = True -keyword_Q _ = False - -list_Q :: MalVal -> Bool -list_Q (MalSeq _ (Vect False) _) = True -list_Q _ = False - -nil_Q :: MalVal -> Bool -nil_Q Nil = True -nil_Q _ = False - -number_Q :: MalVal -> Bool -number_Q (MalNumber _) = True -number_Q _ = False - -string_Q :: MalVal -> Bool -string_Q (MalString _) = True -string_Q _ = False - -symbol_Q :: MalVal -> Bool -symbol_Q (MalSymbol _) = True -symbol_Q _ = False - -true_Q :: MalVal -> Bool -true_Q (MalBoolean True) = True -true_Q _ = False - -vector_Q :: MalVal -> Bool -vector_Q (MalSeq _ (Vect True) _) = True -vector_Q _ = False - --- Scalar functions - -symbol :: Fn -symbol [MalString s] = return $ MalSymbol s -symbol _ = throwStr "symbol called with non-string" - -keyword :: Fn -keyword [kw@(MalKeyword _)] = return kw -keyword [MalString s] = return $ MalKeyword s -keyword _ = throwStr "keyword called with non-string" - --- String functions - -pr_str :: Fn -pr_str args = liftIO $ MalString <$> _pr_list True " " args - -str :: Fn -str args = liftIO $ MalString <$> _pr_list False "" args - -prn :: Fn -prn args = liftIO $ do - putStrLn =<< _pr_list True " " args - hFlush stdout - return Nil - -println :: Fn -println args = liftIO $ do - putStrLn =<< _pr_list False " " args - hFlush stdout - return Nil - -slurp :: Fn -slurp [MalString path] = MalString <$> liftIO (readFile path) -slurp _ = throwStr "invalid arguments to slurp" - -do_readline :: Fn -do_readline [MalString prompt] = do - maybeLine <- liftIO $ readline prompt - case maybeLine of - Nothing -> throwStr "readline failed" - Just line -> return $ MalString line -do_readline _ = throwStr "invalid arguments to readline" - -read_string :: Fn -read_string [MalString s] = read_str s -read_string _ = throwStr "invalid read-string" - --- Numeric functions - -num_op :: String -> (Int -> Int -> Int) -> (String, Fn) -num_op name op = (name, fn) where - fn :: Fn - fn [MalNumber a, MalNumber b] = return $ MalNumber $ op a b - fn _ = throwStr $ "illegal arguments to " ++ name - -cmp_op :: String -> (Int -> Int -> Bool) -> (String, Fn) -cmp_op name op = (name, fn) where - fn :: Fn - fn [MalNumber a, MalNumber b] = return $ MalBoolean $ op a b - fn _ = throwStr $ "illegal arguments to " ++ name - -time_ms :: Fn -time_ms [] = MalNumber . round . (* 1000) <$> liftIO getPOSIXTime -time_ms _ = throwStr "invalid time-ms" - - --- List functions - -list :: Fn -list = return . toList - --- Vector functions - -vector :: Fn -vector = return . MalSeq (MetaData Nil) (Vect True) - --- Hash Map functions - -hash_map :: Fn -hash_map kvs = case kv2map Map.empty kvs of - Just m -> return m - Nothing -> throwStr "invalid call to hash-map" - -assoc :: Fn -assoc (MalHashMap _ hm : kvs) = case kv2map hm kvs of - Just m -> return m - Nothing -> throwStr "invalid assoc" -assoc _ = throwStr "invalid call to assoc" - -remover :: Map.Map String MalVal -> MalVal -> IOThrows (Map.Map String MalVal) -remover acc key = case encodeKey key of - Nothing -> throwStr "invalid dissoc" - Just encoded -> return $ Map.delete encoded acc - -dissoc :: Fn -dissoc (MalHashMap _ hm : ks) = MalHashMap (MetaData Nil) <$> foldlM remover hm ks -dissoc _ = throwStr "invalid call to dissoc" - -get :: Fn -get [MalHashMap _ hm, k] = case encodeKey k of - Nothing -> throwStr "invalid call to get" - Just key -> case Map.lookup key hm of - Just mv -> return mv - Nothing -> return Nil -get [Nil, MalString _] = return Nil -get _ = throwStr "invalid call to get" - -contains_Q :: Fn -contains_Q [MalHashMap _ hm, k] = case encodeKey k of - Just key -> return $ MalBoolean $ Map.member key hm - Nothing -> throwStr "invalid call to contains?" -contains_Q [Nil, MalString _] = return $ MalBoolean False -contains_Q [Nil, MalSymbol _] = return $ MalBoolean False -contains_Q _ = throwStr "invalid call to contains?" - -keys :: Fn -keys [MalHashMap _ hm] = return $ toList $ decodeKey <$> Map.keys hm -keys _ = throwStr "invalid call to keys" - -vals :: Fn -vals [MalHashMap _ hm] = return $ toList $ Map.elems hm -vals _ = throwStr "invalid call to vals" - --- Sequence functions - -sequential_Q :: MalVal -> Bool -sequential_Q (MalSeq _ _ _) = True -sequential_Q _ = False - -cons :: Fn -cons [x, Nil ] = return $ toList [x] -cons [x, MalSeq _ _ lst] = return $ toList (x : lst) -cons _ = throwStr "illegal call to cons" - -unwrapSeq :: MalVal -> IOThrows [MalVal] -unwrapSeq (MalSeq _ _ xs) = return xs -unwrapSeq _ = throwStr "invalid concat" - -do_concat :: Fn -do_concat args = toList . concat <$> mapM unwrapSeq args - -vec :: Fn -vec [MalSeq _ _ xs] = return $ MalSeq (MetaData Nil) (Vect True) xs -vec [_] = throwStr "vec: arg type" -vec _ = throwStr "vec: arg count" - -nth :: Fn -nth [MalSeq _ _ lst, MalNumber idx] = - case drop idx lst of - x : _ -> return x - [] -> throwStr "nth: index out of range" --- See https://wiki.haskell.org/Avoiding_partial_functions -nth _ = throwStr "invalid call to nth" - -first :: Fn -first [Nil ] = return Nil -first [MalSeq _ _ [] ] = return Nil -first [MalSeq _ _ (x : _)] = return x -first _ = throwStr "illegal call to first" - -rest :: Fn -rest [Nil ] = return $ toList [] -rest [MalSeq _ _ [] ] = return $ toList [] -rest [MalSeq _ _ (_ : xs)] = return $ toList xs -rest _ = throwStr "illegal call to rest" - -empty_Q :: Fn -empty_Q [Nil] = return $ MalBoolean True -empty_Q [MalSeq _ _ xs] = return $ MalBoolean $ xs == [] -empty_Q _ = throwStr "illegal call to empty?" - -count :: Fn -count [Nil ] = return $ MalNumber 0 -count [MalSeq _ _ lst] = return $ MalNumber $ length lst -count _ = throwStr "non-sequence passed to count" - -concatLast :: [MalVal] -> IOThrows [MalVal] -concatLast [MalSeq _ _ lst] = return lst -concatLast (a : as) = (a :) <$> concatLast as -concatLast _ = throwStr "last argument of apply must be a sequence" - -apply :: Fn -apply (MalFunction _ f : xs) = f =<< concatLast xs -apply _ = throwStr "Illegal call to apply" - -do_map :: Fn -do_map [MalFunction _ f, MalSeq _ _ args] = toList <$> mapM (\x -> f [x]) args -do_map _ = throwStr "Illegal call to map" - -conj :: Fn -conj (MalSeq _ (Vect False) lst : args) = return $ toList $ reverse args ++ lst -conj (MalSeq _ (Vect True) lst : args) = return $ MalSeq (MetaData Nil) (Vect True) $ lst ++ args -conj _ = throwStr "illegal arguments to conj" - -do_seq :: Fn -do_seq [Nil ] = return Nil -do_seq [MalSeq _ _ [] ] = return Nil -do_seq [MalSeq _ _ lst ] = return $ toList lst -do_seq [MalString "" ] = return Nil -do_seq [MalString s ] = return $ toList $ MalString <$> pure <$> s -do_seq _ = throwStr "seq: called on non-sequence" - --- Metadata functions - -with_meta :: Fn -with_meta [MalSeq _ v x, m] = return $ MalSeq (MetaData m) v x -with_meta [MalHashMap _ x, m] = return $ MalHashMap (MetaData m) x -with_meta [MalAtom _ x, m] = return $ MalAtom (MetaData m) x -with_meta [MalFunction _ f, m] = return $ MalFunction (MetaData m) f -with_meta _ = throwStr "invalid with-meta call" - -do_meta :: Fn -do_meta [MalSeq (MetaData m) _ _ ] = return m -do_meta [MalHashMap (MetaData m) _] = return m -do_meta [MalAtom (MetaData m) _ ] = return m -do_meta [MalFunction (MetaData m) _] = return m -do_meta _ = throwStr "invalid meta call" - --- Atom functions - -atom :: Fn -atom [val] = MalAtom (MetaData Nil) <$> liftIO (newIORef val) -atom _ = throwStr "invalid atom call" - -deref :: Fn -deref [MalAtom _ ref] = liftIO $ readIORef ref -deref _ = throwStr "invalid deref call" - -reset_BANG :: Fn -reset_BANG [MalAtom _ ref, val] = do - liftIO $ writeIORef ref val - return val -reset_BANG _ = throwStr "invalid reset!" - -swap_BANG :: Fn -swap_BANG (MalAtom _ ref : MalFunction _ f : args) = do - val <- liftIO $ readIORef ref - new_val <- f (val : args) - liftIO $ writeIORef ref new_val - return new_val -swap_BANG _ = throwStr "Illegal swap!" - -ns :: [(String, Fn)] -ns = [ - ("=", equal_Q), - ("throw", throw), - (pred1 "nil?" nil_Q), - (pred1 "true?" true_Q), - (pred1 "false?" false_Q), - (pred1 "string?" string_Q), - ("symbol", symbol), - (pred1 "symbol?" symbol_Q), - ("keyword", keyword), - (pred1 "keyword?" keyword_Q), - (pred1 "number?" number_Q), - (pred1 "fn?" fn_Q), - (pred1 "macro?" macro_Q), - - ("pr-str", pr_str), - ("str", str), - ("prn", prn), - ("println", println), - ("readline", do_readline), - ("read-string", read_string), - ("slurp", slurp), - - (cmp_op "<" (<)), - (cmp_op "<=" (<=)), - (cmp_op ">" (>)), - (cmp_op ">=" (>=)), - (num_op "+" (+)), - (num_op "-" (-)), - (num_op "*" (*)), - (num_op "/" div), - ("time-ms", time_ms), - - ("list", list), - (pred1 "list?" list_Q), - ("vector", vector), - (pred1 "vector?" vector_Q), - ("hash-map", hash_map), - (pred1 "map?" map_Q), - ("assoc", assoc), - ("dissoc", dissoc), - ("get", get), - ("contains?", contains_Q), - ("keys", keys), - ("vals", vals), - - (pred1 "sequential?" sequential_Q), - ("cons", cons), - ("concat", do_concat), - ("vec", vec), - ("nth", nth), - ("first", first), - ("rest", rest), - ("empty?", empty_Q), - ("count", count), - ("apply", apply), - ("map", do_map), - - ("conj", conj), - ("seq", do_seq), - - ("with-meta", with_meta), - ("meta", do_meta), - ("atom", atom), - (pred1 "atom?" atom_Q), - ("deref", deref), - ("reset!", reset_BANG), - ("swap!", swap_BANG)] +module Core +( ns ) +where + +import System.IO (hFlush, stdout) +import Control.Monad.Except (throwError) +import Control.Monad.Trans (liftIO) +import qualified Data.Map.Strict as Map +import Data.Foldable (foldlM) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.IORef (newIORef, readIORef, writeIORef) + +import Readline (readline) +import Reader (read_str) +import Types +import Printer (_pr_list) + +-- General functions + +equal_Q :: Fn +equal_Q [a, b] = return $ MalBoolean $ a == b +equal_Q _ = throwStr "illegal arguments to =" + +-- Error/Exception functions + +throw :: Fn +throw [mv] = throwError mv +throw _ = throwStr "illegal arguments to throw" + +-- Unary predicates + +pred1 :: String -> (MalVal -> Bool) -> (String, Fn) +pred1 name op = (name, fn) where + fn :: Fn + fn [a] = return $ MalBoolean $ op a + fn _ = throwStr $ "illegal arguments to " ++ name + +atom_Q :: MalVal -> Bool +atom_Q (MalAtom _ _) = True +atom_Q _ = False + +false_Q :: MalVal -> Bool +false_Q (MalBoolean False) = True +false_Q _ = False + +fn_Q :: MalVal -> Bool +fn_Q (MalFunction _ _) = True +fn_Q _ = False + +macro_Q :: MalVal -> Bool +macro_Q (MalMacro _) = True +macro_Q _ = False + +map_Q :: MalVal -> Bool +map_Q (MalHashMap _ _) = True +map_Q _ = False + +keyword_Q :: MalVal -> Bool +keyword_Q (MalKeyword _) = True +keyword_Q _ = False + +list_Q :: MalVal -> Bool +list_Q (MalSeq _ (Vect False) _) = True +list_Q _ = False + +nil_Q :: MalVal -> Bool +nil_Q Nil = True +nil_Q _ = False + +number_Q :: MalVal -> Bool +number_Q (MalNumber _) = True +number_Q _ = False + +string_Q :: MalVal -> Bool +string_Q (MalString _) = True +string_Q _ = False + +symbol_Q :: MalVal -> Bool +symbol_Q (MalSymbol _) = True +symbol_Q _ = False + +true_Q :: MalVal -> Bool +true_Q (MalBoolean True) = True +true_Q _ = False + +vector_Q :: MalVal -> Bool +vector_Q (MalSeq _ (Vect True) _) = True +vector_Q _ = False + +-- Scalar functions + +symbol :: Fn +symbol [MalString s] = return $ MalSymbol s +symbol _ = throwStr "symbol called with non-string" + +keyword :: Fn +keyword [kw@(MalKeyword _)] = return kw +keyword [MalString s] = return $ MalKeyword s +keyword _ = throwStr "keyword called with non-string" + +-- String functions + +pr_str :: Fn +pr_str args = liftIO $ MalString <$> _pr_list True " " args + +str :: Fn +str args = liftIO $ MalString <$> _pr_list False "" args + +prn :: Fn +prn args = liftIO $ do + putStrLn =<< _pr_list True " " args + hFlush stdout + return Nil + +println :: Fn +println args = liftIO $ do + putStrLn =<< _pr_list False " " args + hFlush stdout + return Nil + +slurp :: Fn +slurp [MalString path] = MalString <$> liftIO (readFile path) +slurp _ = throwStr "invalid arguments to slurp" + +do_readline :: Fn +do_readline [MalString prompt] = do + maybeLine <- liftIO $ readline prompt + case maybeLine of + Nothing -> throwStr "readline failed" + Just line -> return $ MalString line +do_readline _ = throwStr "invalid arguments to readline" + +read_string :: Fn +read_string [MalString s] = read_str s +read_string _ = throwStr "invalid read-string" + +-- Numeric functions + +num_op :: String -> (Int -> Int -> Int) -> (String, Fn) +num_op name op = (name, fn) where + fn :: Fn + fn [MalNumber a, MalNumber b] = return $ MalNumber $ op a b + fn _ = throwStr $ "illegal arguments to " ++ name + +cmp_op :: String -> (Int -> Int -> Bool) -> (String, Fn) +cmp_op name op = (name, fn) where + fn :: Fn + fn [MalNumber a, MalNumber b] = return $ MalBoolean $ op a b + fn _ = throwStr $ "illegal arguments to " ++ name + +time_ms :: Fn +time_ms [] = MalNumber . round . (* 1000) <$> liftIO getPOSIXTime +time_ms _ = throwStr "invalid time-ms" + + +-- List functions + +list :: Fn +list = return . toList + +-- Vector functions + +vector :: Fn +vector = return . MalSeq (MetaData Nil) (Vect True) + +-- Hash Map functions + +hash_map :: Fn +hash_map kvs = case kv2map Map.empty kvs of + Just m -> return m + Nothing -> throwStr "invalid call to hash-map" + +assoc :: Fn +assoc (MalHashMap _ hm : kvs) = case kv2map hm kvs of + Just m -> return m + Nothing -> throwStr "invalid assoc" +assoc _ = throwStr "invalid call to assoc" + +remover :: Map.Map String MalVal -> MalVal -> IOThrows (Map.Map String MalVal) +remover acc key = case encodeKey key of + Nothing -> throwStr "invalid dissoc" + Just encoded -> return $ Map.delete encoded acc + +dissoc :: Fn +dissoc (MalHashMap _ hm : ks) = MalHashMap (MetaData Nil) <$> foldlM remover hm ks +dissoc _ = throwStr "invalid call to dissoc" + +get :: Fn +get [MalHashMap _ hm, k] = case encodeKey k of + Nothing -> throwStr "invalid call to get" + Just key -> case Map.lookup key hm of + Just mv -> return mv + Nothing -> return Nil +get [Nil, MalString _] = return Nil +get _ = throwStr "invalid call to get" + +contains_Q :: Fn +contains_Q [MalHashMap _ hm, k] = case encodeKey k of + Just key -> return $ MalBoolean $ Map.member key hm + Nothing -> throwStr "invalid call to contains?" +contains_Q [Nil, MalString _] = return $ MalBoolean False +contains_Q [Nil, MalSymbol _] = return $ MalBoolean False +contains_Q _ = throwStr "invalid call to contains?" + +keys :: Fn +keys [MalHashMap _ hm] = return $ toList $ decodeKey <$> Map.keys hm +keys _ = throwStr "invalid call to keys" + +vals :: Fn +vals [MalHashMap _ hm] = return $ toList $ Map.elems hm +vals _ = throwStr "invalid call to vals" + +-- Sequence functions + +sequential_Q :: MalVal -> Bool +sequential_Q (MalSeq _ _ _) = True +sequential_Q _ = False + +cons :: Fn +cons [x, Nil ] = return $ toList [x] +cons [x, MalSeq _ _ lst] = return $ toList (x : lst) +cons _ = throwStr "illegal call to cons" + +unwrapSeq :: MalVal -> IOThrows [MalVal] +unwrapSeq (MalSeq _ _ xs) = return xs +unwrapSeq _ = throwStr "invalid concat" + +do_concat :: Fn +do_concat args = toList . concat <$> mapM unwrapSeq args + +vec :: Fn +vec [MalSeq _ _ xs] = return $ MalSeq (MetaData Nil) (Vect True) xs +vec [_] = throwStr "vec: arg type" +vec _ = throwStr "vec: arg count" + +nth :: Fn +nth [MalSeq _ _ lst, MalNumber idx] = + case drop idx lst of + x : _ -> return x + [] -> throwStr "nth: index out of range" +-- See https://wiki.haskell.org/Avoiding_partial_functions +nth _ = throwStr "invalid call to nth" + +first :: Fn +first [Nil ] = return Nil +first [MalSeq _ _ [] ] = return Nil +first [MalSeq _ _ (x : _)] = return x +first _ = throwStr "illegal call to first" + +rest :: Fn +rest [Nil ] = return $ toList [] +rest [MalSeq _ _ [] ] = return $ toList [] +rest [MalSeq _ _ (_ : xs)] = return $ toList xs +rest _ = throwStr "illegal call to rest" + +empty_Q :: Fn +empty_Q [Nil] = return $ MalBoolean True +empty_Q [MalSeq _ _ xs] = return $ MalBoolean $ xs == [] +empty_Q _ = throwStr "illegal call to empty?" + +count :: Fn +count [Nil ] = return $ MalNumber 0 +count [MalSeq _ _ lst] = return $ MalNumber $ length lst +count _ = throwStr "non-sequence passed to count" + +concatLast :: [MalVal] -> IOThrows [MalVal] +concatLast [MalSeq _ _ lst] = return lst +concatLast (a : as) = (a :) <$> concatLast as +concatLast _ = throwStr "last argument of apply must be a sequence" + +apply :: Fn +apply (MalFunction _ f : xs) = f =<< concatLast xs +apply _ = throwStr "Illegal call to apply" + +do_map :: Fn +do_map [MalFunction _ f, MalSeq _ _ args] = toList <$> mapM (\x -> f [x]) args +do_map _ = throwStr "Illegal call to map" + +conj :: Fn +conj (MalSeq _ (Vect False) lst : args) = return $ toList $ reverse args ++ lst +conj (MalSeq _ (Vect True) lst : args) = return $ MalSeq (MetaData Nil) (Vect True) $ lst ++ args +conj _ = throwStr "illegal arguments to conj" + +do_seq :: Fn +do_seq [Nil ] = return Nil +do_seq [MalSeq _ _ [] ] = return Nil +do_seq [MalSeq _ _ lst ] = return $ toList lst +do_seq [MalString "" ] = return Nil +do_seq [MalString s ] = return $ toList $ MalString <$> pure <$> s +do_seq _ = throwStr "seq: called on non-sequence" + +-- Metadata functions + +with_meta :: Fn +with_meta [MalSeq _ v x, m] = return $ MalSeq (MetaData m) v x +with_meta [MalHashMap _ x, m] = return $ MalHashMap (MetaData m) x +with_meta [MalAtom _ x, m] = return $ MalAtom (MetaData m) x +with_meta [MalFunction _ f, m] = return $ MalFunction (MetaData m) f +with_meta _ = throwStr "invalid with-meta call" + +do_meta :: Fn +do_meta [MalSeq (MetaData m) _ _ ] = return m +do_meta [MalHashMap (MetaData m) _] = return m +do_meta [MalAtom (MetaData m) _ ] = return m +do_meta [MalFunction (MetaData m) _] = return m +do_meta _ = throwStr "invalid meta call" + +-- Atom functions + +atom :: Fn +atom [val] = MalAtom (MetaData Nil) <$> liftIO (newIORef val) +atom _ = throwStr "invalid atom call" + +deref :: Fn +deref [MalAtom _ ref] = liftIO $ readIORef ref +deref _ = throwStr "invalid deref call" + +reset_BANG :: Fn +reset_BANG [MalAtom _ ref, val] = do + liftIO $ writeIORef ref val + return val +reset_BANG _ = throwStr "invalid reset!" + +swap_BANG :: Fn +swap_BANG (MalAtom _ ref : MalFunction _ f : args) = do + val <- liftIO $ readIORef ref + new_val <- f (val : args) + liftIO $ writeIORef ref new_val + return new_val +swap_BANG _ = throwStr "Illegal swap!" + +ns :: [(String, Fn)] +ns = [ + ("=", equal_Q), + ("throw", throw), + (pred1 "nil?" nil_Q), + (pred1 "true?" true_Q), + (pred1 "false?" false_Q), + (pred1 "string?" string_Q), + ("symbol", symbol), + (pred1 "symbol?" symbol_Q), + ("keyword", keyword), + (pred1 "keyword?" keyword_Q), + (pred1 "number?" number_Q), + (pred1 "fn?" fn_Q), + (pred1 "macro?" macro_Q), + + ("pr-str", pr_str), + ("str", str), + ("prn", prn), + ("println", println), + ("readline", do_readline), + ("read-string", read_string), + ("slurp", slurp), + + (cmp_op "<" (<)), + (cmp_op "<=" (<=)), + (cmp_op ">" (>)), + (cmp_op ">=" (>=)), + (num_op "+" (+)), + (num_op "-" (-)), + (num_op "*" (*)), + (num_op "/" div), + ("time-ms", time_ms), + + ("list", list), + (pred1 "list?" list_Q), + ("vector", vector), + (pred1 "vector?" vector_Q), + ("hash-map", hash_map), + (pred1 "map?" map_Q), + ("assoc", assoc), + ("dissoc", dissoc), + ("get", get), + ("contains?", contains_Q), + ("keys", keys), + ("vals", vals), + + (pred1 "sequential?" sequential_Q), + ("cons", cons), + ("concat", do_concat), + ("vec", vec), + ("nth", nth), + ("first", first), + ("rest", rest), + ("empty?", empty_Q), + ("count", count), + ("apply", apply), + ("map", do_map), + + ("conj", conj), + ("seq", do_seq), + + ("with-meta", with_meta), + ("meta", do_meta), + ("atom", atom), + (pred1 "atom?" atom_Q), + ("deref", deref), + ("reset!", reset_BANG), + ("swap!", swap_BANG)] diff --git a/impls/haskell/Dockerfile b/impls/haskell/Dockerfile index 73650f205a..e48b834510 100644 --- a/impls/haskell/Dockerfile +++ b/impls/haskell/Dockerfile @@ -1,35 +1,35 @@ -FROM ubuntu:wily -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Haskell -RUN apt-get install -y software-properties-common && \ - add-apt-repository -y ppa:hvr/ghc && \ - apt-get update && \ - apt-get install -y cabal-install-1.22 ghc-7.10.3 - -ENV PATH /opt/cabal/1.22/bin:/opt/ghc/7.10.3/bin:$PATH - -RUN cabal update && cabal install --global readline -# TODO: editline when compile bug fixed -RUN cabal install --global parsec - +FROM ubuntu:wily +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Haskell +RUN apt-get install -y software-properties-common && \ + add-apt-repository -y ppa:hvr/ghc && \ + apt-get update && \ + apt-get install -y cabal-install-1.22 ghc-7.10.3 + +ENV PATH /opt/cabal/1.22/bin:/opt/ghc/7.10.3/bin:$PATH + +RUN cabal update && cabal install --global readline +# TODO: editline when compile bug fixed +RUN cabal install --global parsec + diff --git a/impls/haskell/Env.hs b/impls/haskell/Env.hs index 6c8a89b1a2..f9749ca806 100644 --- a/impls/haskell/Env.hs +++ b/impls/haskell/Env.hs @@ -1,60 +1,60 @@ -module Env -( Env, env_apply, env_get, env_let, env_put, env_repl, env_set ) -where - -import Data.IORef (IORef, modifyIORef, newIORef, readIORef) -import qualified Data.Map.Strict as Map - -import Printer (_pr_str) -import Types - -data Binds = Variable (IORef (Map.Map String MalVal)) - | Constant (Map.Map String MalVal) - -type Env = [Binds] - -env_repl :: IO Env -env_repl = (: []) . Variable <$> newIORef Map.empty - -env_let :: Env -> IO Env -env_let outer = (: outer) . Variable <$> newIORef Map.empty - --- catch* should also use this -env_apply :: Env -> [MalVal] -> [MalVal] -> Maybe (Env) -env_apply outer keys values = (: outer) . Constant <$> bind keys values Map.empty - -bind :: [MalVal] -> [MalVal] -> Map.Map String MalVal -> Maybe (Map.Map String MalVal) -bind [MalSymbol "&", (MalSymbol k)] vs m = Just $ Map.insert k (toList vs) m -bind (MalSymbol k : ks) (v : vs) m = bind ks vs $ Map.insert k v m -bind [] [] m = Just m -bind _ _ _ = Nothing - -env_get :: Env -> String -> IO (Maybe MalVal) -env_get env key = loop env where - loop :: Env -> IO (Maybe MalVal) - loop [] = return Nothing - loop (Constant m : outer) = case Map.lookup key m of - Nothing -> loop outer - justVal -> return justVal - loop (Variable ref : outer) = do - m <- readIORef ref - case Map.lookup key m of - Nothing -> loop outer - justVal -> return justVal - --- def! and let* -env_set :: Env -> String -> MalVal -> IO () -env_set (Variable ref : _) key value = modifyIORef ref $ Map.insert key value -env_set _ _ _ = error "assertion failed in env.env_set" - -put1 :: (String, MalVal) -> IO () -put1 (key, value) = do - putChar ' ' - putStr key - putChar ':' - putStr =<< _pr_str True value - -env_put :: Env -> IO () -env_put [] = error "assertion failed in Env.env_format" -env_put (Variable ref : _) = mapM_ put1 =<< Map.assocs <$> readIORef ref -env_put (Constant m : _) = mapM_ put1 $ Map.assocs m +module Env +( Env, env_apply, env_get, env_let, env_put, env_repl, env_set ) +where + +import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +import qualified Data.Map.Strict as Map + +import Printer (_pr_str) +import Types + +data Binds = Variable (IORef (Map.Map String MalVal)) + | Constant (Map.Map String MalVal) + +type Env = [Binds] + +env_repl :: IO Env +env_repl = (: []) . Variable <$> newIORef Map.empty + +env_let :: Env -> IO Env +env_let outer = (: outer) . Variable <$> newIORef Map.empty + +-- catch* should also use this +env_apply :: Env -> [MalVal] -> [MalVal] -> Maybe (Env) +env_apply outer keys values = (: outer) . Constant <$> bind keys values Map.empty + +bind :: [MalVal] -> [MalVal] -> Map.Map String MalVal -> Maybe (Map.Map String MalVal) +bind [MalSymbol "&", (MalSymbol k)] vs m = Just $ Map.insert k (toList vs) m +bind (MalSymbol k : ks) (v : vs) m = bind ks vs $ Map.insert k v m +bind [] [] m = Just m +bind _ _ _ = Nothing + +env_get :: Env -> String -> IO (Maybe MalVal) +env_get env key = loop env where + loop :: Env -> IO (Maybe MalVal) + loop [] = return Nothing + loop (Constant m : outer) = case Map.lookup key m of + Nothing -> loop outer + justVal -> return justVal + loop (Variable ref : outer) = do + m <- readIORef ref + case Map.lookup key m of + Nothing -> loop outer + justVal -> return justVal + +-- def! and let* +env_set :: Env -> String -> MalVal -> IO () +env_set (Variable ref : _) key value = modifyIORef ref $ Map.insert key value +env_set _ _ _ = error "assertion failed in env.env_set" + +put1 :: (String, MalVal) -> IO () +put1 (key, value) = do + putChar ' ' + putStr key + putChar ':' + putStr =<< _pr_str True value + +env_put :: Env -> IO () +env_put [] = error "assertion failed in Env.env_format" +env_put (Variable ref : _) = mapM_ put1 =<< Map.assocs <$> readIORef ref +env_put (Constant m : _) = mapM_ put1 $ Map.assocs m diff --git a/impls/haskell/Makefile b/impls/haskell/Makefile index dc4c310065..a05b8e0270 100644 --- a/impls/haskell/Makefile +++ b/impls/haskell/Makefile @@ -1,21 +1,21 @@ -SRCS = step0_repl.hs step1_read_print.hs step2_eval.hs step3_env.hs \ - step4_if_fn_do.hs step5_tco.hs step6_file.hs step7_quote.hs \ - step8_macros.hs step9_try.hs stepA_mal.hs -OTHER_SRCS = Readline.hs Types.hs Reader.hs Printer.hs Env.hs Core.hs -BINS = $(SRCS:%.hs=%) -ghc_flags = -Wall - -##################### - -all: $(BINS) - -dist: mal - -mal: $(word $(words $(BINS)),$(BINS)) - cp $< $@ - -$(BINS): %: %.hs $(OTHER_SRCS) - ghc ${ghc_flags} --make $< -o $@ - -clean: - rm -f $(BINS) mal *.hi *.o +SRCS = step0_repl.hs step1_read_print.hs step2_eval.hs step3_env.hs \ + step4_if_fn_do.hs step5_tco.hs step6_file.hs step7_quote.hs \ + step8_macros.hs step9_try.hs stepA_mal.hs +OTHER_SRCS = Readline.hs Types.hs Reader.hs Printer.hs Env.hs Core.hs +BINS = $(SRCS:%.hs=%) +ghc_flags = -Wall + +##################### + +all: $(BINS) + +dist: mal + +mal: $(word $(words $(BINS)),$(BINS)) + cp $< $@ + +$(BINS): %: %.hs $(OTHER_SRCS) + ghc ${ghc_flags} --make $< -o $@ + +clean: + rm -f $(BINS) mal *.hi *.o diff --git a/impls/haskell/Printer.hs b/impls/haskell/Printer.hs index e0931b6dd2..70be05c9eb 100644 --- a/impls/haskell/Printer.hs +++ b/impls/haskell/Printer.hs @@ -1,38 +1,38 @@ -module Printer -( _pr_str, _pr_list ) -where - -import qualified Data.Map.Strict as Map -import Data.IORef (readIORef) -import Data.List (intercalate) - -import Types - -_pr_list :: Bool -> String -> [MalVal] -> IO String -_pr_list pr sep = fmap (intercalate sep) . mapM (_pr_str pr) - -enclose :: String -> String -> String -> String -enclose open close middle = open ++ middle ++ close - -escape :: Char -> String -> String -escape '\n' acc = '\\' : 'n' : acc -escape '\\' acc = '\\' : '\\' : acc -escape '"' acc = '\\' : '"' : acc -escape c acc = c : acc - -_pr_str :: Bool -> MalVal -> IO String -_pr_str _ (MalKeyword kwd) = return $ ':' : kwd -_pr_str True (MalString str) = return $ enclose "\"" "\"" $ foldr escape [] str -_pr_str False (MalString str) = return str -_pr_str _ (MalSymbol name) = return name -_pr_str _ (MalNumber num) = return $ show num -_pr_str _ (MalBoolean True) = return "true" -_pr_str _ (MalBoolean False) = return "false" -_pr_str _ Nil = return "nil" -_pr_str pr (MalSeq _ (Vect False) xs) = enclose "(" ")" <$> _pr_list pr " " xs -_pr_str pr (MalSeq _ (Vect True) xs) = enclose "[" "]" <$> _pr_list pr " " xs -_pr_str pr (MalHashMap _ m) = enclose "{" "}" <$> _pr_list pr " " - (Map.foldMapWithKey (\k v -> [decodeKey k, v]) m) -_pr_str pr (MalAtom _ r) = enclose "(atom " ")" <$> (_pr_str pr =<< readIORef r) -_pr_str _ (MalFunction _ _) = return "" -_pr_str _ (MalMacro _) = return "" +module Printer +( _pr_str, _pr_list ) +where + +import qualified Data.Map.Strict as Map +import Data.IORef (readIORef) +import Data.List (intercalate) + +import Types + +_pr_list :: Bool -> String -> [MalVal] -> IO String +_pr_list pr sep = fmap (intercalate sep) . mapM (_pr_str pr) + +enclose :: String -> String -> String -> String +enclose open close middle = open ++ middle ++ close + +escape :: Char -> String -> String +escape '\n' acc = '\\' : 'n' : acc +escape '\\' acc = '\\' : '\\' : acc +escape '"' acc = '\\' : '"' : acc +escape c acc = c : acc + +_pr_str :: Bool -> MalVal -> IO String +_pr_str _ (MalKeyword kwd) = return $ ':' : kwd +_pr_str True (MalString str) = return $ enclose "\"" "\"" $ foldr escape [] str +_pr_str False (MalString str) = return str +_pr_str _ (MalSymbol name) = return name +_pr_str _ (MalNumber num) = return $ show num +_pr_str _ (MalBoolean True) = return "true" +_pr_str _ (MalBoolean False) = return "false" +_pr_str _ Nil = return "nil" +_pr_str pr (MalSeq _ (Vect False) xs) = enclose "(" ")" <$> _pr_list pr " " xs +_pr_str pr (MalSeq _ (Vect True) xs) = enclose "[" "]" <$> _pr_list pr " " xs +_pr_str pr (MalHashMap _ m) = enclose "{" "}" <$> _pr_list pr " " + (Map.foldMapWithKey (\k v -> [decodeKey k, v]) m) +_pr_str pr (MalAtom _ r) = enclose "(atom " ")" <$> (_pr_str pr =<< readIORef r) +_pr_str _ (MalFunction _ _) = return "" +_pr_str _ (MalMacro _) = return "" diff --git a/impls/haskell/Reader.hs b/impls/haskell/Reader.hs index 47ed49cd2d..08faef9eb4 100644 --- a/impls/haskell/Reader.hs +++ b/impls/haskell/Reader.hs @@ -1,123 +1,123 @@ -module Reader -( read_str ) -where - -import qualified Data.Map.Strict as Map -import Text.ParserCombinators.Parsec ( - Parser, parse, char, digit, anyChar, - (<|>), oneOf, noneOf, many, many1) - -import Types - ----------------------------------------------------------------------- --- A MAL grammar and a possible parsing are described here. - --- If you are only interested in the grammar, please ignore the --- left-hand side of <$> and =<< operators (second column). - --- *> <* <*> all mean concatenation --- <|> means alternative --- many p = (many1 p) | empty means p*, zero or more p --- many1 p = p (many p) means p+, one or more p - --- For efficiency, the alternative operator <|> expects each branch --- to either: --- * succeed, --- * fall after looking at the next character without consuming it, --- * or consume some input and fail, indicating that the input is --- incorrect and no remaining branches should be ignored. - -allowedChar :: Parser Char -allowedChar = noneOf "\n\r \"(),;[\\]{}" - -sep :: Parser String -sep = many (oneOf ", \n" - <|> char ';' <* many (noneOf "\n")) - -stringChar :: Parser Char -stringChar = unescapeChar <$> (char '\\' *> anyChar) - <|> noneOf "\"" - -afterMinus :: Parser MalVal -afterMinus = negative <$> many1 digit - <|> hyphenSymbol <$> many allowedChar - -afterTilde :: Parser MalVal -afterTilde = spliceUnquote <$> (char '@' *> sep *> form) - <|> unquote <$> (sep *> form) - -form :: Parser MalVal -form = MalString <$> (char '"' *> many stringChar <* char '"') - <|> MalKeyword <$> (char ':' *> many1 allowedChar) - <|> char '-' *> afterMinus - <|> toList <$> (char '(' *> sep *> many (form <* sep) <* char ')') - <|> vector <$> (char '[' *> sep *> many (form <* sep) <* char ']') - <|> (toMap =<< char '{' *> sep *> many (form <* sep) <* char '}') - <|> quote <$> (char '\'' *> sep *> form) - <|> quasiquote <$> (char '`' *> sep *> form) - <|> deref <$> (char '@' *> sep *> form) - <|> char '~' *> afterTilde - <|> withMeta <$> (char '^' *> sep *> form <* sep) <*> form - <|> positive <$> many1 digit - <|> symbol <$> many1 allowedChar - -read_form :: Parser MalVal -read_form = sep *> form - ----------------------------------------------------------------------- --- Part specific to Haskell - -addPrefix :: String -> MalVal -> MalVal -addPrefix s x = toList [MalSymbol s, x] - -deref :: MalVal -> MalVal -deref = addPrefix "deref" - -hyphenSymbol :: String -> MalVal -hyphenSymbol = MalSymbol . (:) '-' - -negative :: String -> MalVal -negative = MalNumber . negate . read - -positive :: String -> MalVal -positive = MalNumber . read - -quasiquote :: MalVal -> MalVal -quasiquote = addPrefix "quasiquote" - -quote :: MalVal -> MalVal -quote = addPrefix "quote" - -spliceUnquote :: MalVal -> MalVal -spliceUnquote = addPrefix "splice-unquote" - -toMap :: [MalVal] -> Parser MalVal -toMap kvs = case kv2map Map.empty kvs of - Just m -> return m - Nothing -> fail "invalid contents in map braces" - -unquote :: MalVal -> MalVal -unquote = addPrefix "unquote" - -symbol :: String -> MalVal -symbol "true" = MalBoolean True -symbol "false" = MalBoolean False -symbol "nil" = Nil -symbol s = MalSymbol s - -unescapeChar :: Char -> Char -unescapeChar 'n' = '\n' -unescapeChar c = c - -vector :: [MalVal] -> MalVal -vector = MalSeq (MetaData Nil) (Vect True) - -withMeta :: MalVal -> MalVal -> MalVal -withMeta m d = toList [MalSymbol "with-meta", d, m] - --- The only exported function - -read_str :: String -> IOThrows MalVal -read_str str = case parse read_form "Mal" str of - Left err -> throwStr $ show err - Right val -> return val +module Reader +( read_str ) +where + +import qualified Data.Map.Strict as Map +import Text.ParserCombinators.Parsec ( + Parser, parse, char, digit, anyChar, + (<|>), oneOf, noneOf, many, many1) + +import Types + +---------------------------------------------------------------------- +-- A MAL grammar and a possible parsing are described here. + +-- If you are only interested in the grammar, please ignore the +-- left-hand side of <$> and =<< operators (second column). + +-- *> <* <*> all mean concatenation +-- <|> means alternative +-- many p = (many1 p) | empty means p*, zero or more p +-- many1 p = p (many p) means p+, one or more p + +-- For efficiency, the alternative operator <|> expects each branch +-- to either: +-- * succeed, +-- * fall after looking at the next character without consuming it, +-- * or consume some input and fail, indicating that the input is +-- incorrect and no remaining branches should be ignored. + +allowedChar :: Parser Char +allowedChar = noneOf "\n\r \"(),;[\\]{}" + +sep :: Parser String +sep = many (oneOf ", \n" + <|> char ';' <* many (noneOf "\n")) + +stringChar :: Parser Char +stringChar = unescapeChar <$> (char '\\' *> anyChar) + <|> noneOf "\"" + +afterMinus :: Parser MalVal +afterMinus = negative <$> many1 digit + <|> hyphenSymbol <$> many allowedChar + +afterTilde :: Parser MalVal +afterTilde = spliceUnquote <$> (char '@' *> sep *> form) + <|> unquote <$> (sep *> form) + +form :: Parser MalVal +form = MalString <$> (char '"' *> many stringChar <* char '"') + <|> MalKeyword <$> (char ':' *> many1 allowedChar) + <|> char '-' *> afterMinus + <|> toList <$> (char '(' *> sep *> many (form <* sep) <* char ')') + <|> vector <$> (char '[' *> sep *> many (form <* sep) <* char ']') + <|> (toMap =<< char '{' *> sep *> many (form <* sep) <* char '}') + <|> quote <$> (char '\'' *> sep *> form) + <|> quasiquote <$> (char '`' *> sep *> form) + <|> deref <$> (char '@' *> sep *> form) + <|> char '~' *> afterTilde + <|> withMeta <$> (char '^' *> sep *> form <* sep) <*> form + <|> positive <$> many1 digit + <|> symbol <$> many1 allowedChar + +read_form :: Parser MalVal +read_form = sep *> form + +---------------------------------------------------------------------- +-- Part specific to Haskell + +addPrefix :: String -> MalVal -> MalVal +addPrefix s x = toList [MalSymbol s, x] + +deref :: MalVal -> MalVal +deref = addPrefix "deref" + +hyphenSymbol :: String -> MalVal +hyphenSymbol = MalSymbol . (:) '-' + +negative :: String -> MalVal +negative = MalNumber . negate . read + +positive :: String -> MalVal +positive = MalNumber . read + +quasiquote :: MalVal -> MalVal +quasiquote = addPrefix "quasiquote" + +quote :: MalVal -> MalVal +quote = addPrefix "quote" + +spliceUnquote :: MalVal -> MalVal +spliceUnquote = addPrefix "splice-unquote" + +toMap :: [MalVal] -> Parser MalVal +toMap kvs = case kv2map Map.empty kvs of + Just m -> return m + Nothing -> fail "invalid contents in map braces" + +unquote :: MalVal -> MalVal +unquote = addPrefix "unquote" + +symbol :: String -> MalVal +symbol "true" = MalBoolean True +symbol "false" = MalBoolean False +symbol "nil" = Nil +symbol s = MalSymbol s + +unescapeChar :: Char -> Char +unescapeChar 'n' = '\n' +unescapeChar c = c + +vector :: [MalVal] -> MalVal +vector = MalSeq (MetaData Nil) (Vect True) + +withMeta :: MalVal -> MalVal -> MalVal +withMeta m d = toList [MalSymbol "with-meta", d, m] + +-- The only exported function + +read_str :: String -> IOThrows MalVal +read_str str = case parse read_form "Mal" str of + Left err -> throwStr $ show err + Right val -> return val diff --git a/impls/haskell/Readline.hs b/impls/haskell/Readline.hs index 3eca292149..541da0ef40 100644 --- a/impls/haskell/Readline.hs +++ b/impls/haskell/Readline.hs @@ -1,35 +1,35 @@ -module Readline -( addHistory, readline, load_history ) -where - --- Pick one of these: --- GPL license -import qualified System.Console.Readline as RL --- BSD license ---import qualified System.Console.Editline.Readline as RL - -import Control.Monad (when) -import System.Directory (getHomeDirectory, doesFileExist) -import System.IO.Error (tryIOError) - -history_file :: IO String -history_file = do - home <- getHomeDirectory - return $ home ++ "/.mal-history" - -load_history :: IO () -load_history = do - hfile <- history_file - fileExists <- doesFileExist hfile - when fileExists $ do - content <- readFile hfile - mapM_ RL.addHistory (lines content) - -readline :: String -> IO (Maybe String) -readline = RL.readline - -addHistory :: String -> IO () -addHistory line = do - hfile <- history_file - _ <- tryIOError (appendFile hfile (line ++ "\n")) - RL.addHistory line +module Readline +( addHistory, readline, load_history ) +where + +-- Pick one of these: +-- GPL license +import qualified System.Console.Readline as RL +-- BSD license +--import qualified System.Console.Editline.Readline as RL + +import Control.Monad (when) +import System.Directory (getHomeDirectory, doesFileExist) +import System.IO.Error (tryIOError) + +history_file :: IO String +history_file = do + home <- getHomeDirectory + return $ home ++ "/.mal-history" + +load_history :: IO () +load_history = do + hfile <- history_file + fileExists <- doesFileExist hfile + when fileExists $ do + content <- readFile hfile + mapM_ RL.addHistory (lines content) + +readline :: String -> IO (Maybe String) +readline = RL.readline + +addHistory :: String -> IO () +addHistory line = do + hfile <- history_file + _ <- tryIOError (appendFile hfile (line ++ "\n")) + RL.addHistory line diff --git a/impls/haskell/Types.hs b/impls/haskell/Types.hs index d60a74bb00..5b1d88f5b7 100644 --- a/impls/haskell/Types.hs +++ b/impls/haskell/Types.hs @@ -1,73 +1,73 @@ -module Types -( MalVal (..), IOThrows, Fn, MetaData (..), Vect (..), - decodeKey, encodeKey, kv2map, - throwStr, toList) -where - -import Data.IORef (IORef) -import qualified Data.Map.Strict as Map --- The documentation recommends strict except in specific cases. -import Control.Monad.Except (ExceptT, throwError) - --- Base Mal types -- -type Fn = [MalVal] -> IOThrows MalVal - --- Use type safety for unnamed components, without runtime penalty. -newtype MetaData = MetaData MalVal -newtype Vect = Vect Bool - -data MalVal = Nil - | MalBoolean Bool - | MalNumber Int - | MalString String - | MalSymbol String - | MalKeyword String - | MalSeq MetaData Vect [MalVal] - | MalHashMap MetaData (Map.Map String MalVal) - | MalAtom MetaData (IORef MalVal) - | MalFunction MetaData Fn - | MalMacro Fn - --- Stored into maps to distinguish keywords and symbols. -encodeKey :: MalVal -> Maybe String -encodeKey (MalString s) = pure $ 't' : s -encodeKey (MalKeyword s) = pure $ 'e' : s -encodeKey _ = Nothing - -decodeKey :: String -> MalVal -decodeKey ('t' : k) = MalString k -decodeKey ('e' : k) = MalKeyword k -decodeKey _ = error "internal error in Types.decodeKey" - -instance Eq MalVal where - Nil == Nil = True - (MalBoolean a) == (MalBoolean b) = a == b - (MalNumber a) == (MalNumber b) = a == b - (MalString a) == (MalString b) = a == b - (MalKeyword a) == (MalKeyword b) = a == b - (MalSymbol a) == (MalSymbol b) = a == b - (MalSeq _ _ a) == (MalSeq _ _ b) = a == b - (MalHashMap _ a) == (MalHashMap _ b) = a == b - (MalAtom _ a) == (MalAtom _ b) = a == b - _ == _ = False - ---- Errors/Exceptions --- - -type IOThrows = ExceptT MalVal IO - -throwStr :: String -> IOThrows a -throwStr = throwError . MalString - --- Convenient shortcuts for common situations. - -toList :: [MalVal] -> MalVal -toList = MalSeq (MetaData Nil) (Vect False) - -kv2map :: Map.Map String MalVal -> [MalVal] -> Maybe MalVal -kv2map start forms = MalHashMap (MetaData Nil) <$> assoc1 start forms where - assoc1 :: Map.Map String MalVal -> [MalVal] -> Maybe (Map.Map String MalVal) - assoc1 acc (k : v : kvs) = do - encoded <- encodeKey k - assoc1 (Map.insert encoded v acc) kvs - assoc1 acc [] = Just acc - assoc1 _ [_] = Nothing +module Types +( MalVal (..), IOThrows, Fn, MetaData (..), Vect (..), + decodeKey, encodeKey, kv2map, + throwStr, toList) +where + +import Data.IORef (IORef) +import qualified Data.Map.Strict as Map +-- The documentation recommends strict except in specific cases. +import Control.Monad.Except (ExceptT, throwError) + +-- Base Mal types -- +type Fn = [MalVal] -> IOThrows MalVal + +-- Use type safety for unnamed components, without runtime penalty. +newtype MetaData = MetaData MalVal +newtype Vect = Vect Bool + +data MalVal = Nil + | MalBoolean Bool + | MalNumber Int + | MalString String + | MalSymbol String + | MalKeyword String + | MalSeq MetaData Vect [MalVal] + | MalHashMap MetaData (Map.Map String MalVal) + | MalAtom MetaData (IORef MalVal) + | MalFunction MetaData Fn + | MalMacro Fn + +-- Stored into maps to distinguish keywords and symbols. +encodeKey :: MalVal -> Maybe String +encodeKey (MalString s) = pure $ 't' : s +encodeKey (MalKeyword s) = pure $ 'e' : s +encodeKey _ = Nothing + +decodeKey :: String -> MalVal +decodeKey ('t' : k) = MalString k +decodeKey ('e' : k) = MalKeyword k +decodeKey _ = error "internal error in Types.decodeKey" + +instance Eq MalVal where + Nil == Nil = True + (MalBoolean a) == (MalBoolean b) = a == b + (MalNumber a) == (MalNumber b) = a == b + (MalString a) == (MalString b) = a == b + (MalKeyword a) == (MalKeyword b) = a == b + (MalSymbol a) == (MalSymbol b) = a == b + (MalSeq _ _ a) == (MalSeq _ _ b) = a == b + (MalHashMap _ a) == (MalHashMap _ b) = a == b + (MalAtom _ a) == (MalAtom _ b) = a == b + _ == _ = False + +--- Errors/Exceptions --- + +type IOThrows = ExceptT MalVal IO + +throwStr :: String -> IOThrows a +throwStr = throwError . MalString + +-- Convenient shortcuts for common situations. + +toList :: [MalVal] -> MalVal +toList = MalSeq (MetaData Nil) (Vect False) + +kv2map :: Map.Map String MalVal -> [MalVal] -> Maybe MalVal +kv2map start forms = MalHashMap (MetaData Nil) <$> assoc1 start forms where + assoc1 :: Map.Map String MalVal -> [MalVal] -> Maybe (Map.Map String MalVal) + assoc1 acc (k : v : kvs) = do + encoded <- encodeKey k + assoc1 (Map.insert encoded v acc) kvs + assoc1 acc [] = Just acc + assoc1 _ [_] = Nothing diff --git a/impls/haskell/run b/impls/haskell/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/haskell/run +++ b/impls/haskell/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/haskell/step0_repl.hs b/impls/haskell/step0_repl.hs index b92ea7357e..7bae2f53c3 100644 --- a/impls/haskell/step0_repl.hs +++ b/impls/haskell/step0_repl.hs @@ -1,43 +1,43 @@ -import System.IO (hFlush, stdout) - -import Readline (addHistory, readline, load_history) - -type MalVal = String - --- read - -mal_read :: String -> MalVal -mal_read = id - --- eval - -eval :: MalVal -> MalVal -eval = id - --- print - -mal_print :: MalVal -> String -mal_print = id - --- repl - -rep :: String -> String -rep = mal_print . eval . mal_read - -repl_loop :: IO () -repl_loop = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop - Just str -> do - addHistory str - putStrLn $ rep str - hFlush stdout - repl_loop - -main :: IO () -main = do - load_history - - repl_loop +import System.IO (hFlush, stdout) + +import Readline (addHistory, readline, load_history) + +type MalVal = String + +-- read + +mal_read :: String -> MalVal +mal_read = id + +-- eval + +eval :: MalVal -> MalVal +eval = id + +-- print + +mal_print :: MalVal -> String +mal_print = id + +-- repl + +rep :: String -> String +rep = mal_print . eval . mal_read + +repl_loop :: IO () +repl_loop = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop + Just str -> do + addHistory str + putStrLn $ rep str + hFlush stdout + repl_loop + +main :: IO () +main = do + load_history + + repl_loop diff --git a/impls/haskell/step1_read_print.hs b/impls/haskell/step1_read_print.hs index cf9df742d7..647264b8ee 100644 --- a/impls/haskell/step1_read_print.hs +++ b/impls/haskell/step1_read_print.hs @@ -1,49 +1,49 @@ -import System.IO (hFlush, stdout) -import Control.Monad.Except (liftIO, runExceptT) - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer (_pr_str) - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -eval :: MalVal -> MalVal -eval = id - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -rep :: String -> IOThrows String -rep line = mal_print =<< (eval <$> mal_read line) - -repl_loop :: IO () -repl_loop = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop - Just str -> do - addHistory str - res <- runExceptT $ rep str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop - -main :: IO () -main = do - load_history - - repl_loop +import System.IO (hFlush, stdout) +import Control.Monad.Except (liftIO, runExceptT) + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer (_pr_str) + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +eval :: MalVal -> MalVal +eval = id + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +rep :: String -> IOThrows String +rep line = mal_print =<< (eval <$> mal_read line) + +repl_loop :: IO () +repl_loop = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop + Just str -> do + addHistory str + res <- runExceptT $ rep str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop + +main :: IO () +main = do + load_history + + repl_loop diff --git a/impls/haskell/step2_eval.hs b/impls/haskell/step2_eval.hs index 36fd0bedd7..1d18995f9e 100644 --- a/impls/haskell/step2_eval.hs +++ b/impls/haskell/step2_eval.hs @@ -1,103 +1,103 @@ -import System.IO (hFlush, stdout) -import Control.Monad.Except (liftIO, runExceptT) -import qualified Data.Map as Map - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer (_pr_list, _pr_str) - --- --- Set this to True for a trace of each call to Eval. --- -traceEval :: Bool -traceEval = False - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -apply_ast :: MalVal -> [MalVal] -> IOThrows MalVal -apply_ast first rest = do - evd <- eval first - case evd of - MalFunction _ f -> f =<< mapM eval rest - _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) - -eval :: MalVal -> IOThrows MalVal -eval ast = do - case traceEval of - True -> liftIO $ do - putStr "EVAL: " - putStrLn =<< _pr_str True ast - hFlush stdout - False -> pure () - case ast of - MalSymbol sym -> do - case Map.lookup sym repl_env of - Nothing -> throwStr $ "'" ++ sym ++ "' not found" - Just val -> return val - MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as - MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM eval xs - MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM eval xs - _ -> return ast - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -add :: Fn -add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b -add _ = throwStr $ "illegal arguments to +" - -sub :: Fn -sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b -sub _ = throwStr $ "illegal arguments to -" - -mult :: Fn -mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b -mult _ = throwStr $ "illegal arguments to *" - -divd :: Fn -divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b -divd _ = throwStr $ "illegal arguments to /" - -repl_env :: Map.Map String MalVal -repl_env = Map.fromList [("+", _func add), - ("-", _func sub), - ("*", _func mult), - ("/", _func divd)] - -rep :: String -> IOThrows String -rep line = mal_print =<< eval =<< mal_read line - -repl_loop :: IO () -repl_loop = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop - Just str -> do - addHistory str - res <- runExceptT $ rep str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop - -_func :: Fn -> MalVal -_func f = MalFunction (MetaData Nil) f - -main :: IO () -main = do - load_history - - repl_loop +import System.IO (hFlush, stdout) +import Control.Monad.Except (liftIO, runExceptT) +import qualified Data.Map as Map + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer (_pr_list, _pr_str) + +-- +-- Set this to True for a trace of each call to Eval. +-- +traceEval :: Bool +traceEval = False + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +apply_ast :: MalVal -> [MalVal] -> IOThrows MalVal +apply_ast first rest = do + evd <- eval first + case evd of + MalFunction _ f -> f =<< mapM eval rest + _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) + +eval :: MalVal -> IOThrows MalVal +eval ast = do + case traceEval of + True -> liftIO $ do + putStr "EVAL: " + putStrLn =<< _pr_str True ast + hFlush stdout + False -> pure () + case ast of + MalSymbol sym -> do + case Map.lookup sym repl_env of + Nothing -> throwStr $ "'" ++ sym ++ "' not found" + Just val -> return val + MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as + MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM eval xs + MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM eval xs + _ -> return ast + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +add :: Fn +add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b +add _ = throwStr $ "illegal arguments to +" + +sub :: Fn +sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b +sub _ = throwStr $ "illegal arguments to -" + +mult :: Fn +mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b +mult _ = throwStr $ "illegal arguments to *" + +divd :: Fn +divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b +divd _ = throwStr $ "illegal arguments to /" + +repl_env :: Map.Map String MalVal +repl_env = Map.fromList [("+", _func add), + ("-", _func sub), + ("*", _func mult), + ("/", _func divd)] + +rep :: String -> IOThrows String +rep line = mal_print =<< eval =<< mal_read line + +repl_loop :: IO () +repl_loop = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop + Just str -> do + addHistory str + res <- runExceptT $ rep str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop + +_func :: Fn -> MalVal +_func f = MalFunction (MetaData Nil) f + +main :: IO () +main = do + load_history + + repl_loop diff --git a/impls/haskell/step3_env.hs b/impls/haskell/step3_env.hs index 4edb7489d0..bd17206ca3 100644 --- a/impls/haskell/step3_env.hs +++ b/impls/haskell/step3_env.hs @@ -1,129 +1,129 @@ -import System.IO (hFlush, stdout) -import Control.Monad.Except (liftIO, runExceptT) - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer (_pr_list, _pr_str) -import Env (Env, env_get, env_let, env_put, env_repl, env_set) - --- --- Set this to True for a trace of each call to Eval. --- -traceEval :: Bool -traceEval = False - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -let_bind :: Env -> [MalVal] -> IOThrows () -let_bind _ [] = return () -let_bind env (MalSymbol b : e : xs) = do - liftIO . env_set env b =<< eval env e - let_bind env xs -let_bind _ _ = throwStr "invalid let*" - -apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal - -apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do - evd <- eval env a2 - liftIO $ env_set env a1 evd - return evd -apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" - -apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do - let_env <- liftIO $ env_let env - let_bind let_env params - eval let_env a2 -apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" - -apply_ast first rest env = do - evd <- eval env first - case evd of - MalFunction _ f -> f =<< mapM (eval env) rest - _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) - -eval :: Env -> MalVal -> IOThrows MalVal -eval env ast = do - case traceEval of - True -> liftIO $ do - putStr "EVAL: " - putStr =<< _pr_str True ast - putStr " " - env_put env - putStrLn "" - hFlush stdout - False -> pure () - case ast of - MalSymbol sym -> do - maybeVal <- liftIO $ env_get env sym - case maybeVal of - Nothing -> throwStr $ "'" ++ sym ++ "' not found" - Just val -> return val - MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env - MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs - MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs - _ -> return ast - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -add :: Fn -add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b -add _ = throwStr $ "illegal arguments to +" - -sub :: Fn -sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b -sub _ = throwStr $ "illegal arguments to -" - -mult :: Fn -mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b -mult _ = throwStr $ "illegal arguments to *" - -divd :: Fn -divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b -divd _ = throwStr $ "illegal arguments to /" - -rep :: Env -> String -> IOThrows String -rep env line = mal_print =<< eval env =<< mal_read line - -repl_loop :: Env -> IO () -repl_loop env = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop env - Just str -> do - addHistory str - res <- runExceptT $ rep env str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop env - -defBuiltIn :: Env -> String -> Fn -> IO () -defBuiltIn env sym f = - env_set env sym $ MalFunction (MetaData Nil) f - -main :: IO () -main = do - load_history - - repl_env <- env_repl - - defBuiltIn repl_env "+" add - defBuiltIn repl_env "-" sub - defBuiltIn repl_env "*" mult - defBuiltIn repl_env "/" divd - - repl_loop repl_env +import System.IO (hFlush, stdout) +import Control.Monad.Except (liftIO, runExceptT) + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer (_pr_list, _pr_str) +import Env (Env, env_get, env_let, env_put, env_repl, env_set) + +-- +-- Set this to True for a trace of each call to Eval. +-- +traceEval :: Bool +traceEval = False + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +let_bind :: Env -> [MalVal] -> IOThrows () +let_bind _ [] = return () +let_bind env (MalSymbol b : e : xs) = do + liftIO . env_set env b =<< eval env e + let_bind env xs +let_bind _ _ = throwStr "invalid let*" + +apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal + +apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do + evd <- eval env a2 + liftIO $ env_set env a1 evd + return evd +apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" + +apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do + let_env <- liftIO $ env_let env + let_bind let_env params + eval let_env a2 +apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" + +apply_ast first rest env = do + evd <- eval env first + case evd of + MalFunction _ f -> f =<< mapM (eval env) rest + _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) + +eval :: Env -> MalVal -> IOThrows MalVal +eval env ast = do + case traceEval of + True -> liftIO $ do + putStr "EVAL: " + putStr =<< _pr_str True ast + putStr " " + env_put env + putStrLn "" + hFlush stdout + False -> pure () + case ast of + MalSymbol sym -> do + maybeVal <- liftIO $ env_get env sym + case maybeVal of + Nothing -> throwStr $ "'" ++ sym ++ "' not found" + Just val -> return val + MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env + MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs + MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs + _ -> return ast + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +add :: Fn +add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b +add _ = throwStr $ "illegal arguments to +" + +sub :: Fn +sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b +sub _ = throwStr $ "illegal arguments to -" + +mult :: Fn +mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b +mult _ = throwStr $ "illegal arguments to *" + +divd :: Fn +divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b +divd _ = throwStr $ "illegal arguments to /" + +rep :: Env -> String -> IOThrows String +rep env line = mal_print =<< eval env =<< mal_read line + +repl_loop :: Env -> IO () +repl_loop env = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop env + Just str -> do + addHistory str + res <- runExceptT $ rep env str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop env + +defBuiltIn :: Env -> String -> Fn -> IO () +defBuiltIn env sym f = + env_set env sym $ MalFunction (MetaData Nil) f + +main :: IO () +main = do + load_history + + repl_env <- env_repl + + defBuiltIn repl_env "+" add + defBuiltIn repl_env "-" sub + defBuiltIn repl_env "*" mult + defBuiltIn repl_env "/" divd + + repl_loop repl_env diff --git a/impls/haskell/step4_if_fn_do.hs b/impls/haskell/step4_if_fn_do.hs index bfc2e49aa0..501f9eb5b5 100644 --- a/impls/haskell/step4_if_fn_do.hs +++ b/impls/haskell/step4_if_fn_do.hs @@ -1,152 +1,152 @@ -import System.IO (hFlush, stdout) -import Control.Monad.Except (liftIO, runExceptT) -import Data.Foldable (foldlM) - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer(_pr_list, _pr_str) -import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) -import Core (ns) - --- --- Set this to True for a trace of each call to Eval. --- -traceEval :: Bool -traceEval = False - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -let_bind :: Env -> [MalVal] -> IOThrows () -let_bind _ [] = return () -let_bind env (MalSymbol b : e : xs) = do - liftIO . env_set env b =<< eval env e - let_bind env xs -let_bind _ _ = throwStr "invalid let*" - -apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal - -apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do - evd <- eval env a2 - liftIO $ env_set env a1 evd - return evd -apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" - -apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do - let_env <- liftIO $ env_let env - let_bind let_env params - eval let_env a2 -apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" - -apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args - -apply_ast (MalSymbol "if") [a1, a2, a3] env = do - cond <- eval env a1 - eval env $ case cond of - Nil -> a3 - MalBoolean False -> a3 - _ -> a2 -apply_ast (MalSymbol "if") [a1, a2] env = do - cond <- eval env a1 - case cond of - Nil -> return Nil - MalBoolean False -> return Nil - _ -> eval env a2 -apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" - -apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where - fn :: [MalVal] -> IOThrows MalVal - fn args = do - case env_apply env params args of - Just fn_env -> eval fn_env ast - Nothing -> do - p <- liftIO $ _pr_list True " " params - a <- liftIO $ _pr_list True " " args - throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p -apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" - -apply_ast first rest env = do - evd <- eval env first - case evd of - MalFunction _ f -> f =<< mapM (eval env) rest - _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) - -eval :: Env -> MalVal -> IOThrows MalVal -eval env ast = do - case traceEval of - True -> liftIO $ do - putStr "EVAL: " - putStr =<< _pr_str True ast - putStr " " - env_put env - putStrLn "" - hFlush stdout - False -> pure () - case ast of - MalSymbol sym -> do - maybeVal <- liftIO $ env_get env sym - case maybeVal of - Nothing -> throwStr $ "'" ++ sym ++ "' not found" - Just val -> return val - MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env - MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs - MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs - _ -> return ast - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -rep :: Env -> String -> IOThrows String -rep env line = mal_print =<< eval env =<< mal_read line - -repl_loop :: Env -> IO () -repl_loop env = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop env - Just str -> do - addHistory str - res <- runExceptT $ rep env str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop env - --- Read and evaluate a line. Ignore successful results, but crash in --- case of error. This is intended for the startup procedure. -re :: Env -> String -> IO () -re repl_env line = do - res <- runExceptT $ eval repl_env =<< mal_read line - case res of - Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv - Right _ -> return () - -defBuiltIn :: Env -> (String, Fn) -> IO () -defBuiltIn env (sym, f) = - env_set env sym $ MalFunction (MetaData Nil) f - -main :: IO () -main = do - load_history - - repl_env <- env_repl - - -- core.hs: defined using Haskell - mapM_ (defBuiltIn repl_env) Core.ns - - -- core.mal: defined using the language itself - re repl_env "(def! not (fn* (a) (if a false true)))" - - repl_loop repl_env +import System.IO (hFlush, stdout) +import Control.Monad.Except (liftIO, runExceptT) +import Data.Foldable (foldlM) + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer(_pr_list, _pr_str) +import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) +import Core (ns) + +-- +-- Set this to True for a trace of each call to Eval. +-- +traceEval :: Bool +traceEval = False + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +let_bind :: Env -> [MalVal] -> IOThrows () +let_bind _ [] = return () +let_bind env (MalSymbol b : e : xs) = do + liftIO . env_set env b =<< eval env e + let_bind env xs +let_bind _ _ = throwStr "invalid let*" + +apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal + +apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do + evd <- eval env a2 + liftIO $ env_set env a1 evd + return evd +apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" + +apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do + let_env <- liftIO $ env_let env + let_bind let_env params + eval let_env a2 +apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" + +apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args + +apply_ast (MalSymbol "if") [a1, a2, a3] env = do + cond <- eval env a1 + eval env $ case cond of + Nil -> a3 + MalBoolean False -> a3 + _ -> a2 +apply_ast (MalSymbol "if") [a1, a2] env = do + cond <- eval env a1 + case cond of + Nil -> return Nil + MalBoolean False -> return Nil + _ -> eval env a2 +apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" + +apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where + fn :: [MalVal] -> IOThrows MalVal + fn args = do + case env_apply env params args of + Just fn_env -> eval fn_env ast + Nothing -> do + p <- liftIO $ _pr_list True " " params + a <- liftIO $ _pr_list True " " args + throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p +apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" + +apply_ast first rest env = do + evd <- eval env first + case evd of + MalFunction _ f -> f =<< mapM (eval env) rest + _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) + +eval :: Env -> MalVal -> IOThrows MalVal +eval env ast = do + case traceEval of + True -> liftIO $ do + putStr "EVAL: " + putStr =<< _pr_str True ast + putStr " " + env_put env + putStrLn "" + hFlush stdout + False -> pure () + case ast of + MalSymbol sym -> do + maybeVal <- liftIO $ env_get env sym + case maybeVal of + Nothing -> throwStr $ "'" ++ sym ++ "' not found" + Just val -> return val + MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env + MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs + MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs + _ -> return ast + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +rep :: Env -> String -> IOThrows String +rep env line = mal_print =<< eval env =<< mal_read line + +repl_loop :: Env -> IO () +repl_loop env = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop env + Just str -> do + addHistory str + res <- runExceptT $ rep env str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop env + +-- Read and evaluate a line. Ignore successful results, but crash in +-- case of error. This is intended for the startup procedure. +re :: Env -> String -> IO () +re repl_env line = do + res <- runExceptT $ eval repl_env =<< mal_read line + case res of + Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv + Right _ -> return () + +defBuiltIn :: Env -> (String, Fn) -> IO () +defBuiltIn env (sym, f) = + env_set env sym $ MalFunction (MetaData Nil) f + +main :: IO () +main = do + load_history + + repl_env <- env_repl + + -- core.hs: defined using Haskell + mapM_ (defBuiltIn repl_env) Core.ns + + -- core.mal: defined using the language itself + re repl_env "(def! not (fn* (a) (if a false true)))" + + repl_loop repl_env diff --git a/impls/haskell/step5_tco.hs b/impls/haskell/step5_tco.hs index bfc2e49aa0..501f9eb5b5 100644 --- a/impls/haskell/step5_tco.hs +++ b/impls/haskell/step5_tco.hs @@ -1,152 +1,152 @@ -import System.IO (hFlush, stdout) -import Control.Monad.Except (liftIO, runExceptT) -import Data.Foldable (foldlM) - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer(_pr_list, _pr_str) -import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) -import Core (ns) - --- --- Set this to True for a trace of each call to Eval. --- -traceEval :: Bool -traceEval = False - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -let_bind :: Env -> [MalVal] -> IOThrows () -let_bind _ [] = return () -let_bind env (MalSymbol b : e : xs) = do - liftIO . env_set env b =<< eval env e - let_bind env xs -let_bind _ _ = throwStr "invalid let*" - -apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal - -apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do - evd <- eval env a2 - liftIO $ env_set env a1 evd - return evd -apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" - -apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do - let_env <- liftIO $ env_let env - let_bind let_env params - eval let_env a2 -apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" - -apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args - -apply_ast (MalSymbol "if") [a1, a2, a3] env = do - cond <- eval env a1 - eval env $ case cond of - Nil -> a3 - MalBoolean False -> a3 - _ -> a2 -apply_ast (MalSymbol "if") [a1, a2] env = do - cond <- eval env a1 - case cond of - Nil -> return Nil - MalBoolean False -> return Nil - _ -> eval env a2 -apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" - -apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where - fn :: [MalVal] -> IOThrows MalVal - fn args = do - case env_apply env params args of - Just fn_env -> eval fn_env ast - Nothing -> do - p <- liftIO $ _pr_list True " " params - a <- liftIO $ _pr_list True " " args - throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p -apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" - -apply_ast first rest env = do - evd <- eval env first - case evd of - MalFunction _ f -> f =<< mapM (eval env) rest - _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) - -eval :: Env -> MalVal -> IOThrows MalVal -eval env ast = do - case traceEval of - True -> liftIO $ do - putStr "EVAL: " - putStr =<< _pr_str True ast - putStr " " - env_put env - putStrLn "" - hFlush stdout - False -> pure () - case ast of - MalSymbol sym -> do - maybeVal <- liftIO $ env_get env sym - case maybeVal of - Nothing -> throwStr $ "'" ++ sym ++ "' not found" - Just val -> return val - MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env - MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs - MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs - _ -> return ast - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -rep :: Env -> String -> IOThrows String -rep env line = mal_print =<< eval env =<< mal_read line - -repl_loop :: Env -> IO () -repl_loop env = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop env - Just str -> do - addHistory str - res <- runExceptT $ rep env str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop env - --- Read and evaluate a line. Ignore successful results, but crash in --- case of error. This is intended for the startup procedure. -re :: Env -> String -> IO () -re repl_env line = do - res <- runExceptT $ eval repl_env =<< mal_read line - case res of - Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv - Right _ -> return () - -defBuiltIn :: Env -> (String, Fn) -> IO () -defBuiltIn env (sym, f) = - env_set env sym $ MalFunction (MetaData Nil) f - -main :: IO () -main = do - load_history - - repl_env <- env_repl - - -- core.hs: defined using Haskell - mapM_ (defBuiltIn repl_env) Core.ns - - -- core.mal: defined using the language itself - re repl_env "(def! not (fn* (a) (if a false true)))" - - repl_loop repl_env +import System.IO (hFlush, stdout) +import Control.Monad.Except (liftIO, runExceptT) +import Data.Foldable (foldlM) + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer(_pr_list, _pr_str) +import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) +import Core (ns) + +-- +-- Set this to True for a trace of each call to Eval. +-- +traceEval :: Bool +traceEval = False + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +let_bind :: Env -> [MalVal] -> IOThrows () +let_bind _ [] = return () +let_bind env (MalSymbol b : e : xs) = do + liftIO . env_set env b =<< eval env e + let_bind env xs +let_bind _ _ = throwStr "invalid let*" + +apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal + +apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do + evd <- eval env a2 + liftIO $ env_set env a1 evd + return evd +apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" + +apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do + let_env <- liftIO $ env_let env + let_bind let_env params + eval let_env a2 +apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" + +apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args + +apply_ast (MalSymbol "if") [a1, a2, a3] env = do + cond <- eval env a1 + eval env $ case cond of + Nil -> a3 + MalBoolean False -> a3 + _ -> a2 +apply_ast (MalSymbol "if") [a1, a2] env = do + cond <- eval env a1 + case cond of + Nil -> return Nil + MalBoolean False -> return Nil + _ -> eval env a2 +apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" + +apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where + fn :: [MalVal] -> IOThrows MalVal + fn args = do + case env_apply env params args of + Just fn_env -> eval fn_env ast + Nothing -> do + p <- liftIO $ _pr_list True " " params + a <- liftIO $ _pr_list True " " args + throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p +apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" + +apply_ast first rest env = do + evd <- eval env first + case evd of + MalFunction _ f -> f =<< mapM (eval env) rest + _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) + +eval :: Env -> MalVal -> IOThrows MalVal +eval env ast = do + case traceEval of + True -> liftIO $ do + putStr "EVAL: " + putStr =<< _pr_str True ast + putStr " " + env_put env + putStrLn "" + hFlush stdout + False -> pure () + case ast of + MalSymbol sym -> do + maybeVal <- liftIO $ env_get env sym + case maybeVal of + Nothing -> throwStr $ "'" ++ sym ++ "' not found" + Just val -> return val + MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env + MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs + MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs + _ -> return ast + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +rep :: Env -> String -> IOThrows String +rep env line = mal_print =<< eval env =<< mal_read line + +repl_loop :: Env -> IO () +repl_loop env = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop env + Just str -> do + addHistory str + res <- runExceptT $ rep env str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop env + +-- Read and evaluate a line. Ignore successful results, but crash in +-- case of error. This is intended for the startup procedure. +re :: Env -> String -> IO () +re repl_env line = do + res <- runExceptT $ eval repl_env =<< mal_read line + case res of + Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv + Right _ -> return () + +defBuiltIn :: Env -> (String, Fn) -> IO () +defBuiltIn env (sym, f) = + env_set env sym $ MalFunction (MetaData Nil) f + +main :: IO () +main = do + load_history + + repl_env <- env_repl + + -- core.hs: defined using Haskell + mapM_ (defBuiltIn repl_env) Core.ns + + -- core.mal: defined using the language itself + re repl_env "(def! not (fn* (a) (if a false true)))" + + repl_loop repl_env diff --git a/impls/haskell/step6_file.hs b/impls/haskell/step6_file.hs index 01f28a8e3f..07e2753b5c 100644 --- a/impls/haskell/step6_file.hs +++ b/impls/haskell/step6_file.hs @@ -1,166 +1,166 @@ -import System.IO (hFlush, stdout) -import System.Environment (getArgs) -import Control.Monad.Except (liftIO, runExceptT) -import Data.Foldable (foldlM) - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer(_pr_list, _pr_str) -import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) -import Core (ns) - --- --- Set this to True for a trace of each call to Eval. --- -traceEval :: Bool -traceEval = False - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -let_bind :: Env -> [MalVal] -> IOThrows () -let_bind _ [] = return () -let_bind env (MalSymbol b : e : xs) = do - liftIO . env_set env b =<< eval env e - let_bind env xs -let_bind _ _ = throwStr "invalid let*" - -apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal - -apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do - evd <- eval env a2 - liftIO $ env_set env a1 evd - return evd -apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" - -apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do - let_env <- liftIO $ env_let env - let_bind let_env params - eval let_env a2 -apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" - -apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args - -apply_ast (MalSymbol "if") [a1, a2, a3] env = do - cond <- eval env a1 - eval env $ case cond of - Nil -> a3 - MalBoolean False -> a3 - _ -> a2 -apply_ast (MalSymbol "if") [a1, a2] env = do - cond <- eval env a1 - case cond of - Nil -> return Nil - MalBoolean False -> return Nil - _ -> eval env a2 -apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" - -apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where - fn :: [MalVal] -> IOThrows MalVal - fn args = do - case env_apply env params args of - Just fn_env -> eval fn_env ast - Nothing -> do - p <- liftIO $ _pr_list True " " params - a <- liftIO $ _pr_list True " " args - throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p -apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" - -apply_ast first rest env = do - evd <- eval env first - case evd of - MalFunction _ f -> f =<< mapM (eval env) rest - _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) - -eval :: Env -> MalVal -> IOThrows MalVal -eval env ast = do - case traceEval of - True -> liftIO $ do - putStr "EVAL: " - putStr =<< _pr_str True ast - putStr " " - env_put env - putStrLn "" - hFlush stdout - False -> pure () - case ast of - MalSymbol sym -> do - maybeVal <- liftIO $ env_get env sym - case maybeVal of - Nothing -> throwStr $ "'" ++ sym ++ "' not found" - Just val -> return val - MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env - MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs - MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs - _ -> return ast - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -rep :: Env -> String -> IOThrows String -rep env line = mal_print =<< eval env =<< mal_read line - -repl_loop :: Env -> IO () -repl_loop env = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop env - Just str -> do - addHistory str - res <- runExceptT $ rep env str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop env - --- Read and evaluate a line. Ignore successful results, but crash in --- case of error. This is intended for the startup procedure. -re :: Env -> String -> IO () -re repl_env line = do - res <- runExceptT $ eval repl_env =<< mal_read line - case res of - Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv - Right _ -> return () - -defBuiltIn :: Env -> (String, Fn) -> IO () -defBuiltIn env (sym, f) = - env_set env sym $ MalFunction (MetaData Nil) f - -evalFn :: Env -> Fn -evalFn env [ast] = eval env ast -evalFn _ _ = throwStr "illegal call of eval" - -main :: IO () -main = do - args <- getArgs - load_history - - repl_env <- env_repl - - -- core.hs: defined using Haskell - mapM_ (defBuiltIn repl_env) Core.ns - defBuiltIn repl_env ("eval", evalFn repl_env) - - -- core.mal: defined using the language itself - re repl_env "(def! not (fn* (a) (if a false true)))" - re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - - case args of - script : scriptArgs -> do - env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs - re repl_env $ "(load-file \"" ++ script ++ "\")" - [] -> do - env_set repl_env "*ARGV*" $ toList [] - repl_loop repl_env +import System.IO (hFlush, stdout) +import System.Environment (getArgs) +import Control.Monad.Except (liftIO, runExceptT) +import Data.Foldable (foldlM) + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer(_pr_list, _pr_str) +import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) +import Core (ns) + +-- +-- Set this to True for a trace of each call to Eval. +-- +traceEval :: Bool +traceEval = False + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +let_bind :: Env -> [MalVal] -> IOThrows () +let_bind _ [] = return () +let_bind env (MalSymbol b : e : xs) = do + liftIO . env_set env b =<< eval env e + let_bind env xs +let_bind _ _ = throwStr "invalid let*" + +apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal + +apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do + evd <- eval env a2 + liftIO $ env_set env a1 evd + return evd +apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" + +apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do + let_env <- liftIO $ env_let env + let_bind let_env params + eval let_env a2 +apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" + +apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args + +apply_ast (MalSymbol "if") [a1, a2, a3] env = do + cond <- eval env a1 + eval env $ case cond of + Nil -> a3 + MalBoolean False -> a3 + _ -> a2 +apply_ast (MalSymbol "if") [a1, a2] env = do + cond <- eval env a1 + case cond of + Nil -> return Nil + MalBoolean False -> return Nil + _ -> eval env a2 +apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" + +apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where + fn :: [MalVal] -> IOThrows MalVal + fn args = do + case env_apply env params args of + Just fn_env -> eval fn_env ast + Nothing -> do + p <- liftIO $ _pr_list True " " params + a <- liftIO $ _pr_list True " " args + throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p +apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" + +apply_ast first rest env = do + evd <- eval env first + case evd of + MalFunction _ f -> f =<< mapM (eval env) rest + _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) + +eval :: Env -> MalVal -> IOThrows MalVal +eval env ast = do + case traceEval of + True -> liftIO $ do + putStr "EVAL: " + putStr =<< _pr_str True ast + putStr " " + env_put env + putStrLn "" + hFlush stdout + False -> pure () + case ast of + MalSymbol sym -> do + maybeVal <- liftIO $ env_get env sym + case maybeVal of + Nothing -> throwStr $ "'" ++ sym ++ "' not found" + Just val -> return val + MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env + MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs + MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs + _ -> return ast + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +rep :: Env -> String -> IOThrows String +rep env line = mal_print =<< eval env =<< mal_read line + +repl_loop :: Env -> IO () +repl_loop env = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop env + Just str -> do + addHistory str + res <- runExceptT $ rep env str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop env + +-- Read and evaluate a line. Ignore successful results, but crash in +-- case of error. This is intended for the startup procedure. +re :: Env -> String -> IO () +re repl_env line = do + res <- runExceptT $ eval repl_env =<< mal_read line + case res of + Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv + Right _ -> return () + +defBuiltIn :: Env -> (String, Fn) -> IO () +defBuiltIn env (sym, f) = + env_set env sym $ MalFunction (MetaData Nil) f + +evalFn :: Env -> Fn +evalFn env [ast] = eval env ast +evalFn _ _ = throwStr "illegal call of eval" + +main :: IO () +main = do + args <- getArgs + load_history + + repl_env <- env_repl + + -- core.hs: defined using Haskell + mapM_ (defBuiltIn repl_env) Core.ns + defBuiltIn repl_env ("eval", evalFn repl_env) + + -- core.mal: defined using the language itself + re repl_env "(def! not (fn* (a) (if a false true)))" + re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + + case args of + script : scriptArgs -> do + env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs + re repl_env $ "(load-file \"" ++ script ++ "\")" + [] -> do + env_set repl_env "*ARGV*" $ toList [] + repl_loop repl_env diff --git a/impls/haskell/step7_quote.hs b/impls/haskell/step7_quote.hs index 26a4130a1a..49607a8873 100644 --- a/impls/haskell/step7_quote.hs +++ b/impls/haskell/step7_quote.hs @@ -1,193 +1,193 @@ -import System.IO (hFlush, stdout) -import System.Environment (getArgs) -import Control.Monad.Except (liftIO, runExceptT) -import Data.Foldable (foldlM, foldrM) - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer(_pr_list, _pr_str) -import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) -import Core (ns) - --- --- Set this to True for a trace of each call to Eval. --- -traceEval :: Bool -traceEval = False - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -qqIter :: MalVal -> MalVal -> IOThrows MalVal -qqIter (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = return $ toList [MalSymbol "concat", x, acc] -qqIter (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote" -qqIter elt acc = do - qqted <- quasiquote elt - return $ toList [MalSymbol "cons", qqted, acc] - -quasiquote :: MalVal -> IOThrows MalVal -quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) = return x -quasiquote (MalSeq _ (Vect False) (MalSymbol "unquote" : _)) = throwStr "invalid unquote" -quasiquote (MalSeq _ (Vect False) ys) = foldrM qqIter (toList []) ys -quasiquote (MalSeq _ (Vect True) ys) = do - lst <- foldrM qqIter (toList []) ys - return $ toList [MalSymbol "vec", lst] -quasiquote ast@(MalHashMap _ _) = return $ toList [MalSymbol "quote", ast] -quasiquote ast@(MalSymbol _) = return $ toList [MalSymbol "quote", ast] -quasiquote ast = return ast - -let_bind :: Env -> [MalVal] -> IOThrows () -let_bind _ [] = return () -let_bind env (MalSymbol b : e : xs) = do - liftIO . env_set env b =<< eval env e - let_bind env xs -let_bind _ _ = throwStr "invalid let*" - -apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal - -apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do - evd <- eval env a2 - liftIO $ env_set env a1 evd - return evd -apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" - -apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do - let_env <- liftIO $ env_let env - let_bind let_env params - eval let_env a2 -apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" - -apply_ast (MalSymbol "quote") [a1] _ = return a1 -apply_ast (MalSymbol "quote") _ _ = throwStr "invalid quote" - -apply_ast (MalSymbol "quasiquoteexpand") [a1] _ = quasiquote a1 -apply_ast (MalSymbol "quasiquoteexpand") _ _ = throwStr "invalid quasiquote" - -apply_ast (MalSymbol "quasiquote") [a1] env = eval env =<< quasiquote a1 -apply_ast (MalSymbol "quasiquote") _ _ = throwStr "invalid quasiquote" - -apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args - -apply_ast (MalSymbol "if") [a1, a2, a3] env = do - cond <- eval env a1 - eval env $ case cond of - Nil -> a3 - MalBoolean False -> a3 - _ -> a2 -apply_ast (MalSymbol "if") [a1, a2] env = do - cond <- eval env a1 - case cond of - Nil -> return Nil - MalBoolean False -> return Nil - _ -> eval env a2 -apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" - -apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where - fn :: [MalVal] -> IOThrows MalVal - fn args = do - case env_apply env params args of - Just fn_env -> eval fn_env ast - Nothing -> do - p <- liftIO $ _pr_list True " " params - a <- liftIO $ _pr_list True " " args - throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p -apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" - -apply_ast first rest env = do - evd <- eval env first - case evd of - MalFunction _ f -> f =<< mapM (eval env) rest - _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) - -eval :: Env -> MalVal -> IOThrows MalVal -eval env ast = do - case traceEval of - True -> liftIO $ do - putStr "EVAL: " - putStr =<< _pr_str True ast - putStr " " - env_put env - putStrLn "" - hFlush stdout - False -> pure () - case ast of - MalSymbol sym -> do - maybeVal <- liftIO $ env_get env sym - case maybeVal of - Nothing -> throwStr $ "'" ++ sym ++ "' not found" - Just val -> return val - MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env - MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs - MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs - _ -> return ast - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -rep :: Env -> String -> IOThrows String -rep env line = mal_print =<< eval env =<< mal_read line - -repl_loop :: Env -> IO () -repl_loop env = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop env - Just str -> do - addHistory str - res <- runExceptT $ rep env str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop env - --- Read and evaluate a line. Ignore successful results, but crash in --- case of error. This is intended for the startup procedure. -re :: Env -> String -> IO () -re repl_env line = do - res <- runExceptT $ eval repl_env =<< mal_read line - case res of - Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv - Right _ -> return () - -defBuiltIn :: Env -> (String, Fn) -> IO () -defBuiltIn env (sym, f) = - env_set env sym $ MalFunction (MetaData Nil) f - -evalFn :: Env -> Fn -evalFn env [ast] = eval env ast -evalFn _ _ = throwStr "illegal call of eval" - -main :: IO () -main = do - args <- getArgs - load_history - - repl_env <- env_repl - - -- core.hs: defined using Haskell - mapM_ (defBuiltIn repl_env) Core.ns - defBuiltIn repl_env ("eval", evalFn repl_env) - - -- core.mal: defined using the language itself - re repl_env "(def! not (fn* (a) (if a false true)))" - re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - - case args of - script : scriptArgs -> do - env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs - re repl_env $ "(load-file \"" ++ script ++ "\")" - [] -> do - env_set repl_env "*ARGV*" $ toList [] - repl_loop repl_env +import System.IO (hFlush, stdout) +import System.Environment (getArgs) +import Control.Monad.Except (liftIO, runExceptT) +import Data.Foldable (foldlM, foldrM) + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer(_pr_list, _pr_str) +import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) +import Core (ns) + +-- +-- Set this to True for a trace of each call to Eval. +-- +traceEval :: Bool +traceEval = False + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +qqIter :: MalVal -> MalVal -> IOThrows MalVal +qqIter (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = return $ toList [MalSymbol "concat", x, acc] +qqIter (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote" +qqIter elt acc = do + qqted <- quasiquote elt + return $ toList [MalSymbol "cons", qqted, acc] + +quasiquote :: MalVal -> IOThrows MalVal +quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) = return x +quasiquote (MalSeq _ (Vect False) (MalSymbol "unquote" : _)) = throwStr "invalid unquote" +quasiquote (MalSeq _ (Vect False) ys) = foldrM qqIter (toList []) ys +quasiquote (MalSeq _ (Vect True) ys) = do + lst <- foldrM qqIter (toList []) ys + return $ toList [MalSymbol "vec", lst] +quasiquote ast@(MalHashMap _ _) = return $ toList [MalSymbol "quote", ast] +quasiquote ast@(MalSymbol _) = return $ toList [MalSymbol "quote", ast] +quasiquote ast = return ast + +let_bind :: Env -> [MalVal] -> IOThrows () +let_bind _ [] = return () +let_bind env (MalSymbol b : e : xs) = do + liftIO . env_set env b =<< eval env e + let_bind env xs +let_bind _ _ = throwStr "invalid let*" + +apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal + +apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do + evd <- eval env a2 + liftIO $ env_set env a1 evd + return evd +apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" + +apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do + let_env <- liftIO $ env_let env + let_bind let_env params + eval let_env a2 +apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" + +apply_ast (MalSymbol "quote") [a1] _ = return a1 +apply_ast (MalSymbol "quote") _ _ = throwStr "invalid quote" + +apply_ast (MalSymbol "quasiquoteexpand") [a1] _ = quasiquote a1 +apply_ast (MalSymbol "quasiquoteexpand") _ _ = throwStr "invalid quasiquote" + +apply_ast (MalSymbol "quasiquote") [a1] env = eval env =<< quasiquote a1 +apply_ast (MalSymbol "quasiquote") _ _ = throwStr "invalid quasiquote" + +apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args + +apply_ast (MalSymbol "if") [a1, a2, a3] env = do + cond <- eval env a1 + eval env $ case cond of + Nil -> a3 + MalBoolean False -> a3 + _ -> a2 +apply_ast (MalSymbol "if") [a1, a2] env = do + cond <- eval env a1 + case cond of + Nil -> return Nil + MalBoolean False -> return Nil + _ -> eval env a2 +apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" + +apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where + fn :: [MalVal] -> IOThrows MalVal + fn args = do + case env_apply env params args of + Just fn_env -> eval fn_env ast + Nothing -> do + p <- liftIO $ _pr_list True " " params + a <- liftIO $ _pr_list True " " args + throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p +apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" + +apply_ast first rest env = do + evd <- eval env first + case evd of + MalFunction _ f -> f =<< mapM (eval env) rest + _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) + +eval :: Env -> MalVal -> IOThrows MalVal +eval env ast = do + case traceEval of + True -> liftIO $ do + putStr "EVAL: " + putStr =<< _pr_str True ast + putStr " " + env_put env + putStrLn "" + hFlush stdout + False -> pure () + case ast of + MalSymbol sym -> do + maybeVal <- liftIO $ env_get env sym + case maybeVal of + Nothing -> throwStr $ "'" ++ sym ++ "' not found" + Just val -> return val + MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env + MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs + MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs + _ -> return ast + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +rep :: Env -> String -> IOThrows String +rep env line = mal_print =<< eval env =<< mal_read line + +repl_loop :: Env -> IO () +repl_loop env = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop env + Just str -> do + addHistory str + res <- runExceptT $ rep env str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop env + +-- Read and evaluate a line. Ignore successful results, but crash in +-- case of error. This is intended for the startup procedure. +re :: Env -> String -> IO () +re repl_env line = do + res <- runExceptT $ eval repl_env =<< mal_read line + case res of + Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv + Right _ -> return () + +defBuiltIn :: Env -> (String, Fn) -> IO () +defBuiltIn env (sym, f) = + env_set env sym $ MalFunction (MetaData Nil) f + +evalFn :: Env -> Fn +evalFn env [ast] = eval env ast +evalFn _ _ = throwStr "illegal call of eval" + +main :: IO () +main = do + args <- getArgs + load_history + + repl_env <- env_repl + + -- core.hs: defined using Haskell + mapM_ (defBuiltIn repl_env) Core.ns + defBuiltIn repl_env ("eval", evalFn repl_env) + + -- core.mal: defined using the language itself + re repl_env "(def! not (fn* (a) (if a false true)))" + re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + + case args of + script : scriptArgs -> do + env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs + re repl_env $ "(load-file \"" ++ script ++ "\")" + [] -> do + env_set repl_env "*ARGV*" $ toList [] + repl_loop repl_env diff --git a/impls/haskell/step8_macros.hs b/impls/haskell/step8_macros.hs index d49acf1b27..9513e9fd99 100644 --- a/impls/haskell/step8_macros.hs +++ b/impls/haskell/step8_macros.hs @@ -1,216 +1,216 @@ -import System.IO (hFlush, stdout) -import System.Environment (getArgs) -import Control.Monad.Except (liftIO, runExceptT) -import Data.Foldable (foldlM, foldrM) - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer(_pr_list, _pr_str) -import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) -import Core (ns) - --- --- Set this to True for a trace of each call to Eval. --- -traceEval :: Bool -traceEval = False - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -qqIter :: MalVal -> MalVal -> IOThrows MalVal -qqIter (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = return $ toList [MalSymbol "concat", x, acc] -qqIter (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote" -qqIter elt acc = do - qqted <- quasiquote elt - return $ toList [MalSymbol "cons", qqted, acc] - -quasiquote :: MalVal -> IOThrows MalVal -quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) = return x -quasiquote (MalSeq _ (Vect False) (MalSymbol "unquote" : _)) = throwStr "invalid unquote" -quasiquote (MalSeq _ (Vect False) ys) = foldrM qqIter (toList []) ys -quasiquote (MalSeq _ (Vect True) ys) = do - lst <- foldrM qqIter (toList []) ys - return $ toList [MalSymbol "vec", lst] -quasiquote ast@(MalHashMap _ _) = return $ toList [MalSymbol "quote", ast] -quasiquote ast@(MalSymbol _) = return $ toList [MalSymbol "quote", ast] -quasiquote ast = return ast - -macroexpand :: Env -> MalVal -> IOThrows MalVal -macroexpand env ast@(MalSeq _ (Vect False) (MalSymbol a0 : args)) = do - maybeMacro <- liftIO $ env_get env a0 - case maybeMacro of - Just (MalMacro f) -> macroexpand env =<< f args - _ -> return ast -macroexpand _ ast = return ast - -let_bind :: Env -> [MalVal] -> IOThrows () -let_bind _ [] = return () -let_bind env (MalSymbol b : e : xs) = do - liftIO . env_set env b =<< eval env e - let_bind env xs -let_bind _ _ = throwStr "invalid let*" - -apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal - -apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do - evd <- eval env a2 - liftIO $ env_set env a1 evd - return evd -apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" - -apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do - let_env <- liftIO $ env_let env - let_bind let_env params - eval let_env a2 -apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" - -apply_ast (MalSymbol "quote") [a1] _ = return a1 -apply_ast (MalSymbol "quote") _ _ = throwStr "invalid quote" - -apply_ast (MalSymbol "quasiquoteexpand") [a1] _ = quasiquote a1 -apply_ast (MalSymbol "quasiquoteexpand") _ _ = throwStr "invalid quasiquote" - -apply_ast (MalSymbol "quasiquote") [a1] env = eval env =<< quasiquote a1 -apply_ast (MalSymbol "quasiquote") _ _ = throwStr "invalid quasiquote" - -apply_ast (MalSymbol "defmacro!") [MalSymbol a1, a2] env = do - func <- eval env a2 - case func of - MalFunction _ f -> do - let m = MalMacro f - liftIO $ env_set env a1 m - return m - _ -> throwStr "defmacro! on non-function" -apply_ast (MalSymbol "defmacro!") _ _ = throwStr "invalid defmacro!" - -apply_ast (MalSymbol "macroexpand") [a1] env = macroexpand env a1 -apply_ast (MalSymbol "macroexpand") _ _ = throwStr "invalid macroexpand" - -apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args - -apply_ast (MalSymbol "if") [a1, a2, a3] env = do - cond <- eval env a1 - eval env $ case cond of - Nil -> a3 - MalBoolean False -> a3 - _ -> a2 -apply_ast (MalSymbol "if") [a1, a2] env = do - cond <- eval env a1 - case cond of - Nil -> return Nil - MalBoolean False -> return Nil - _ -> eval env a2 -apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" - -apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where - fn :: [MalVal] -> IOThrows MalVal - fn args = do - case env_apply env params args of - Just fn_env -> eval fn_env ast - Nothing -> do - p <- liftIO $ _pr_list True " " params - a <- liftIO $ _pr_list True " " args - throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p -apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" - -apply_ast first rest env = do - evd <- eval env first - case evd of - MalFunction _ f -> f =<< mapM (eval env) rest - MalMacro m -> eval env =<< m rest - _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) - -eval :: Env -> MalVal -> IOThrows MalVal -eval env ast = do - case traceEval of - True -> liftIO $ do - putStr "EVAL: " - putStr =<< _pr_str True ast - putStr " " - env_put env - putStrLn "" - hFlush stdout - False -> pure () - case ast of - MalSymbol sym -> do - maybeVal <- liftIO $ env_get env sym - case maybeVal of - Nothing -> throwStr $ "'" ++ sym ++ "' not found" - Just val -> return val - MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env - MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs - MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs - _ -> return ast - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -rep :: Env -> String -> IOThrows String -rep env line = mal_print =<< eval env =<< mal_read line - -repl_loop :: Env -> IO () -repl_loop env = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop env - Just str -> do - addHistory str - res <- runExceptT $ rep env str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop env - --- Read and evaluate a line. Ignore successful results, but crash in --- case of error. This is intended for the startup procedure. -re :: Env -> String -> IO () -re repl_env line = do - res <- runExceptT $ eval repl_env =<< mal_read line - case res of - Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv - Right _ -> return () - -defBuiltIn :: Env -> (String, Fn) -> IO () -defBuiltIn env (sym, f) = - env_set env sym $ MalFunction (MetaData Nil) f - -evalFn :: Env -> Fn -evalFn env [ast] = eval env ast -evalFn _ _ = throwStr "illegal call of eval" - -main :: IO () -main = do - args <- getArgs - load_history - - repl_env <- env_repl - - -- core.hs: defined using Haskell - mapM_ (defBuiltIn repl_env) Core.ns - defBuiltIn repl_env ("eval", evalFn repl_env) - - -- core.mal: defined using the language itself - re repl_env "(def! not (fn* (a) (if a false true)))" - re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - re repl_env "(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)))))))" - - case args of - script : scriptArgs -> do - env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs - re repl_env $ "(load-file \"" ++ script ++ "\")" - [] -> do - env_set repl_env "*ARGV*" $ toList [] - repl_loop repl_env +import System.IO (hFlush, stdout) +import System.Environment (getArgs) +import Control.Monad.Except (liftIO, runExceptT) +import Data.Foldable (foldlM, foldrM) + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer(_pr_list, _pr_str) +import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) +import Core (ns) + +-- +-- Set this to True for a trace of each call to Eval. +-- +traceEval :: Bool +traceEval = False + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +qqIter :: MalVal -> MalVal -> IOThrows MalVal +qqIter (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = return $ toList [MalSymbol "concat", x, acc] +qqIter (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote" +qqIter elt acc = do + qqted <- quasiquote elt + return $ toList [MalSymbol "cons", qqted, acc] + +quasiquote :: MalVal -> IOThrows MalVal +quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) = return x +quasiquote (MalSeq _ (Vect False) (MalSymbol "unquote" : _)) = throwStr "invalid unquote" +quasiquote (MalSeq _ (Vect False) ys) = foldrM qqIter (toList []) ys +quasiquote (MalSeq _ (Vect True) ys) = do + lst <- foldrM qqIter (toList []) ys + return $ toList [MalSymbol "vec", lst] +quasiquote ast@(MalHashMap _ _) = return $ toList [MalSymbol "quote", ast] +quasiquote ast@(MalSymbol _) = return $ toList [MalSymbol "quote", ast] +quasiquote ast = return ast + +macroexpand :: Env -> MalVal -> IOThrows MalVal +macroexpand env ast@(MalSeq _ (Vect False) (MalSymbol a0 : args)) = do + maybeMacro <- liftIO $ env_get env a0 + case maybeMacro of + Just (MalMacro f) -> macroexpand env =<< f args + _ -> return ast +macroexpand _ ast = return ast + +let_bind :: Env -> [MalVal] -> IOThrows () +let_bind _ [] = return () +let_bind env (MalSymbol b : e : xs) = do + liftIO . env_set env b =<< eval env e + let_bind env xs +let_bind _ _ = throwStr "invalid let*" + +apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal + +apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do + evd <- eval env a2 + liftIO $ env_set env a1 evd + return evd +apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" + +apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do + let_env <- liftIO $ env_let env + let_bind let_env params + eval let_env a2 +apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" + +apply_ast (MalSymbol "quote") [a1] _ = return a1 +apply_ast (MalSymbol "quote") _ _ = throwStr "invalid quote" + +apply_ast (MalSymbol "quasiquoteexpand") [a1] _ = quasiquote a1 +apply_ast (MalSymbol "quasiquoteexpand") _ _ = throwStr "invalid quasiquote" + +apply_ast (MalSymbol "quasiquote") [a1] env = eval env =<< quasiquote a1 +apply_ast (MalSymbol "quasiquote") _ _ = throwStr "invalid quasiquote" + +apply_ast (MalSymbol "defmacro!") [MalSymbol a1, a2] env = do + func <- eval env a2 + case func of + MalFunction _ f -> do + let m = MalMacro f + liftIO $ env_set env a1 m + return m + _ -> throwStr "defmacro! on non-function" +apply_ast (MalSymbol "defmacro!") _ _ = throwStr "invalid defmacro!" + +apply_ast (MalSymbol "macroexpand") [a1] env = macroexpand env a1 +apply_ast (MalSymbol "macroexpand") _ _ = throwStr "invalid macroexpand" + +apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args + +apply_ast (MalSymbol "if") [a1, a2, a3] env = do + cond <- eval env a1 + eval env $ case cond of + Nil -> a3 + MalBoolean False -> a3 + _ -> a2 +apply_ast (MalSymbol "if") [a1, a2] env = do + cond <- eval env a1 + case cond of + Nil -> return Nil + MalBoolean False -> return Nil + _ -> eval env a2 +apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" + +apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where + fn :: [MalVal] -> IOThrows MalVal + fn args = do + case env_apply env params args of + Just fn_env -> eval fn_env ast + Nothing -> do + p <- liftIO $ _pr_list True " " params + a <- liftIO $ _pr_list True " " args + throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p +apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" + +apply_ast first rest env = do + evd <- eval env first + case evd of + MalFunction _ f -> f =<< mapM (eval env) rest + MalMacro m -> eval env =<< m rest + _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) + +eval :: Env -> MalVal -> IOThrows MalVal +eval env ast = do + case traceEval of + True -> liftIO $ do + putStr "EVAL: " + putStr =<< _pr_str True ast + putStr " " + env_put env + putStrLn "" + hFlush stdout + False -> pure () + case ast of + MalSymbol sym -> do + maybeVal <- liftIO $ env_get env sym + case maybeVal of + Nothing -> throwStr $ "'" ++ sym ++ "' not found" + Just val -> return val + MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env + MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs + MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs + _ -> return ast + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +rep :: Env -> String -> IOThrows String +rep env line = mal_print =<< eval env =<< mal_read line + +repl_loop :: Env -> IO () +repl_loop env = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop env + Just str -> do + addHistory str + res <- runExceptT $ rep env str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop env + +-- Read and evaluate a line. Ignore successful results, but crash in +-- case of error. This is intended for the startup procedure. +re :: Env -> String -> IO () +re repl_env line = do + res <- runExceptT $ eval repl_env =<< mal_read line + case res of + Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv + Right _ -> return () + +defBuiltIn :: Env -> (String, Fn) -> IO () +defBuiltIn env (sym, f) = + env_set env sym $ MalFunction (MetaData Nil) f + +evalFn :: Env -> Fn +evalFn env [ast] = eval env ast +evalFn _ _ = throwStr "illegal call of eval" + +main :: IO () +main = do + args <- getArgs + load_history + + repl_env <- env_repl + + -- core.hs: defined using Haskell + mapM_ (defBuiltIn repl_env) Core.ns + defBuiltIn repl_env ("eval", evalFn repl_env) + + -- core.mal: defined using the language itself + re repl_env "(def! not (fn* (a) (if a false true)))" + re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + re repl_env "(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)))))))" + + case args of + script : scriptArgs -> do + env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs + re repl_env $ "(load-file \"" ++ script ++ "\")" + [] -> do + env_set repl_env "*ARGV*" $ toList [] + repl_loop repl_env diff --git a/impls/haskell/step9_try.hs b/impls/haskell/step9_try.hs index d2c26837a1..0dc250aacf 100644 --- a/impls/haskell/step9_try.hs +++ b/impls/haskell/step9_try.hs @@ -1,226 +1,226 @@ -import System.IO (hFlush, stdout) -import System.Environment (getArgs) -import Control.Monad.Except (liftIO, runExceptT) -import Data.Foldable (foldlM, foldrM) - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer(_pr_list, _pr_str) -import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) -import Core (ns) - --- --- Set this to True for a trace of each call to Eval. --- -traceEval :: Bool -traceEval = False - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -qqIter :: MalVal -> MalVal -> IOThrows MalVal -qqIter (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = return $ toList [MalSymbol "concat", x, acc] -qqIter (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote" -qqIter elt acc = do - qqted <- quasiquote elt - return $ toList [MalSymbol "cons", qqted, acc] - -quasiquote :: MalVal -> IOThrows MalVal -quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) = return x -quasiquote (MalSeq _ (Vect False) (MalSymbol "unquote" : _)) = throwStr "invalid unquote" -quasiquote (MalSeq _ (Vect False) ys) = foldrM qqIter (toList []) ys -quasiquote (MalSeq _ (Vect True) ys) = do - lst <- foldrM qqIter (toList []) ys - return $ toList [MalSymbol "vec", lst] -quasiquote ast@(MalHashMap _ _) = return $ toList [MalSymbol "quote", ast] -quasiquote ast@(MalSymbol _) = return $ toList [MalSymbol "quote", ast] -quasiquote ast = return ast - -macroexpand :: Env -> MalVal -> IOThrows MalVal -macroexpand env ast@(MalSeq _ (Vect False) (MalSymbol a0 : args)) = do - maybeMacro <- liftIO $ env_get env a0 - case maybeMacro of - Just (MalMacro f) -> macroexpand env =<< f args - _ -> return ast -macroexpand _ ast = return ast - -let_bind :: Env -> [MalVal] -> IOThrows () -let_bind _ [] = return () -let_bind env (MalSymbol b : e : xs) = do - liftIO . env_set env b =<< eval env e - let_bind env xs -let_bind _ _ = throwStr "invalid let*" - -apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal - -apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do - evd <- eval env a2 - liftIO $ env_set env a1 evd - return evd -apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" - -apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do - let_env <- liftIO $ env_let env - let_bind let_env params - eval let_env a2 -apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" - -apply_ast (MalSymbol "quote") [a1] _ = return a1 -apply_ast (MalSymbol "quote") _ _ = throwStr "invalid quote" - -apply_ast (MalSymbol "quasiquoteexpand") [a1] _ = quasiquote a1 -apply_ast (MalSymbol "quasiquoteexpand") _ _ = throwStr "invalid quasiquote" - -apply_ast (MalSymbol "quasiquote") [a1] env = eval env =<< quasiquote a1 -apply_ast (MalSymbol "quasiquote") _ _ = throwStr "invalid quasiquote" - -apply_ast (MalSymbol "defmacro!") [MalSymbol a1, a2] env = do - func <- eval env a2 - case func of - MalFunction _ f -> do - let m = MalMacro f - liftIO $ env_set env a1 m - return m - _ -> throwStr "defmacro! on non-function" -apply_ast (MalSymbol "defmacro!") _ _ = throwStr "invalid defmacro!" - -apply_ast (MalSymbol "macroexpand") [a1] env = macroexpand env a1 -apply_ast (MalSymbol "macroexpand") _ _ = throwStr "invalid macroexpand" - -apply_ast (MalSymbol "try*") [a1] env = eval env a1 -apply_ast (MalSymbol "try*") [a1, MalSeq _ (Vect False) [MalSymbol "catch*", a21, a22]] env = do - res <- liftIO $ runExceptT $ eval env a1 - case res of - Right val -> return val - Left exc -> case env_apply env [a21] [exc] of - Just try_env -> eval try_env a22 - Nothing -> throwStr "invalid catch*" -apply_ast (MalSymbol "try*") _ _ = throwStr "invalid try*" - -apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args - -apply_ast (MalSymbol "if") [a1, a2, a3] env = do - cond <- eval env a1 - eval env $ case cond of - Nil -> a3 - MalBoolean False -> a3 - _ -> a2 -apply_ast (MalSymbol "if") [a1, a2] env = do - cond <- eval env a1 - case cond of - Nil -> return Nil - MalBoolean False -> return Nil - _ -> eval env a2 -apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" - -apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where - fn :: [MalVal] -> IOThrows MalVal - fn args = do - case env_apply env params args of - Just fn_env -> eval fn_env ast - Nothing -> do - p <- liftIO $ _pr_list True " " params - a <- liftIO $ _pr_list True " " args - throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p -apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" - -apply_ast first rest env = do - evd <- eval env first - case evd of - MalFunction _ f -> f =<< mapM (eval env) rest - MalMacro m -> eval env =<< m rest - _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) - -eval :: Env -> MalVal -> IOThrows MalVal -eval env ast = do - case traceEval of - True -> liftIO $ do - putStr "EVAL: " - putStr =<< _pr_str True ast - putStr " " - env_put env - putStrLn "" - hFlush stdout - False -> pure () - case ast of - MalSymbol sym -> do - maybeVal <- liftIO $ env_get env sym - case maybeVal of - Nothing -> throwStr $ "'" ++ sym ++ "' not found" - Just val -> return val - MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env - MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs - MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs - _ -> return ast - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -rep :: Env -> String -> IOThrows String -rep env line = mal_print =<< eval env =<< mal_read line - -repl_loop :: Env -> IO () -repl_loop env = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop env - Just str -> do - addHistory str - res <- runExceptT $ rep env str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop env - --- Read and evaluate a line. Ignore successful results, but crash in --- case of error. This is intended for the startup procedure. -re :: Env -> String -> IO () -re repl_env line = do - res <- runExceptT $ eval repl_env =<< mal_read line - case res of - Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv - Right _ -> return () - -defBuiltIn :: Env -> (String, Fn) -> IO () -defBuiltIn env (sym, f) = - env_set env sym $ MalFunction (MetaData Nil) f - -evalFn :: Env -> Fn -evalFn env [ast] = eval env ast -evalFn _ _ = throwStr "illegal call of eval" - -main :: IO () -main = do - args <- getArgs - load_history - - repl_env <- env_repl - - -- core.hs: defined using Haskell - mapM_ (defBuiltIn repl_env) Core.ns - defBuiltIn repl_env ("eval", evalFn repl_env) - - -- core.mal: defined using the language itself - re repl_env "(def! not (fn* (a) (if a false true)))" - re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - re repl_env "(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)))))))" - - case args of - script : scriptArgs -> do - env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs - re repl_env $ "(load-file \"" ++ script ++ "\")" - [] -> do - env_set repl_env "*ARGV*" $ toList [] - repl_loop repl_env +import System.IO (hFlush, stdout) +import System.Environment (getArgs) +import Control.Monad.Except (liftIO, runExceptT) +import Data.Foldable (foldlM, foldrM) + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer(_pr_list, _pr_str) +import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) +import Core (ns) + +-- +-- Set this to True for a trace of each call to Eval. +-- +traceEval :: Bool +traceEval = False + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +qqIter :: MalVal -> MalVal -> IOThrows MalVal +qqIter (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = return $ toList [MalSymbol "concat", x, acc] +qqIter (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote" +qqIter elt acc = do + qqted <- quasiquote elt + return $ toList [MalSymbol "cons", qqted, acc] + +quasiquote :: MalVal -> IOThrows MalVal +quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) = return x +quasiquote (MalSeq _ (Vect False) (MalSymbol "unquote" : _)) = throwStr "invalid unquote" +quasiquote (MalSeq _ (Vect False) ys) = foldrM qqIter (toList []) ys +quasiquote (MalSeq _ (Vect True) ys) = do + lst <- foldrM qqIter (toList []) ys + return $ toList [MalSymbol "vec", lst] +quasiquote ast@(MalHashMap _ _) = return $ toList [MalSymbol "quote", ast] +quasiquote ast@(MalSymbol _) = return $ toList [MalSymbol "quote", ast] +quasiquote ast = return ast + +macroexpand :: Env -> MalVal -> IOThrows MalVal +macroexpand env ast@(MalSeq _ (Vect False) (MalSymbol a0 : args)) = do + maybeMacro <- liftIO $ env_get env a0 + case maybeMacro of + Just (MalMacro f) -> macroexpand env =<< f args + _ -> return ast +macroexpand _ ast = return ast + +let_bind :: Env -> [MalVal] -> IOThrows () +let_bind _ [] = return () +let_bind env (MalSymbol b : e : xs) = do + liftIO . env_set env b =<< eval env e + let_bind env xs +let_bind _ _ = throwStr "invalid let*" + +apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal + +apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do + evd <- eval env a2 + liftIO $ env_set env a1 evd + return evd +apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" + +apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do + let_env <- liftIO $ env_let env + let_bind let_env params + eval let_env a2 +apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" + +apply_ast (MalSymbol "quote") [a1] _ = return a1 +apply_ast (MalSymbol "quote") _ _ = throwStr "invalid quote" + +apply_ast (MalSymbol "quasiquoteexpand") [a1] _ = quasiquote a1 +apply_ast (MalSymbol "quasiquoteexpand") _ _ = throwStr "invalid quasiquote" + +apply_ast (MalSymbol "quasiquote") [a1] env = eval env =<< quasiquote a1 +apply_ast (MalSymbol "quasiquote") _ _ = throwStr "invalid quasiquote" + +apply_ast (MalSymbol "defmacro!") [MalSymbol a1, a2] env = do + func <- eval env a2 + case func of + MalFunction _ f -> do + let m = MalMacro f + liftIO $ env_set env a1 m + return m + _ -> throwStr "defmacro! on non-function" +apply_ast (MalSymbol "defmacro!") _ _ = throwStr "invalid defmacro!" + +apply_ast (MalSymbol "macroexpand") [a1] env = macroexpand env a1 +apply_ast (MalSymbol "macroexpand") _ _ = throwStr "invalid macroexpand" + +apply_ast (MalSymbol "try*") [a1] env = eval env a1 +apply_ast (MalSymbol "try*") [a1, MalSeq _ (Vect False) [MalSymbol "catch*", a21, a22]] env = do + res <- liftIO $ runExceptT $ eval env a1 + case res of + Right val -> return val + Left exc -> case env_apply env [a21] [exc] of + Just try_env -> eval try_env a22 + Nothing -> throwStr "invalid catch*" +apply_ast (MalSymbol "try*") _ _ = throwStr "invalid try*" + +apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args + +apply_ast (MalSymbol "if") [a1, a2, a3] env = do + cond <- eval env a1 + eval env $ case cond of + Nil -> a3 + MalBoolean False -> a3 + _ -> a2 +apply_ast (MalSymbol "if") [a1, a2] env = do + cond <- eval env a1 + case cond of + Nil -> return Nil + MalBoolean False -> return Nil + _ -> eval env a2 +apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" + +apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where + fn :: [MalVal] -> IOThrows MalVal + fn args = do + case env_apply env params args of + Just fn_env -> eval fn_env ast + Nothing -> do + p <- liftIO $ _pr_list True " " params + a <- liftIO $ _pr_list True " " args + throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p +apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" + +apply_ast first rest env = do + evd <- eval env first + case evd of + MalFunction _ f -> f =<< mapM (eval env) rest + MalMacro m -> eval env =<< m rest + _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) + +eval :: Env -> MalVal -> IOThrows MalVal +eval env ast = do + case traceEval of + True -> liftIO $ do + putStr "EVAL: " + putStr =<< _pr_str True ast + putStr " " + env_put env + putStrLn "" + hFlush stdout + False -> pure () + case ast of + MalSymbol sym -> do + maybeVal <- liftIO $ env_get env sym + case maybeVal of + Nothing -> throwStr $ "'" ++ sym ++ "' not found" + Just val -> return val + MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env + MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs + MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs + _ -> return ast + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +rep :: Env -> String -> IOThrows String +rep env line = mal_print =<< eval env =<< mal_read line + +repl_loop :: Env -> IO () +repl_loop env = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop env + Just str -> do + addHistory str + res <- runExceptT $ rep env str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop env + +-- Read and evaluate a line. Ignore successful results, but crash in +-- case of error. This is intended for the startup procedure. +re :: Env -> String -> IO () +re repl_env line = do + res <- runExceptT $ eval repl_env =<< mal_read line + case res of + Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv + Right _ -> return () + +defBuiltIn :: Env -> (String, Fn) -> IO () +defBuiltIn env (sym, f) = + env_set env sym $ MalFunction (MetaData Nil) f + +evalFn :: Env -> Fn +evalFn env [ast] = eval env ast +evalFn _ _ = throwStr "illegal call of eval" + +main :: IO () +main = do + args <- getArgs + load_history + + repl_env <- env_repl + + -- core.hs: defined using Haskell + mapM_ (defBuiltIn repl_env) Core.ns + defBuiltIn repl_env ("eval", evalFn repl_env) + + -- core.mal: defined using the language itself + re repl_env "(def! not (fn* (a) (if a false true)))" + re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + re repl_env "(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)))))))" + + case args of + script : scriptArgs -> do + env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs + re repl_env $ "(load-file \"" ++ script ++ "\")" + [] -> do + env_set repl_env "*ARGV*" $ toList [] + repl_loop repl_env diff --git a/impls/haskell/stepA_mal.hs b/impls/haskell/stepA_mal.hs index 3e3517282d..f415fd5add 100644 --- a/impls/haskell/stepA_mal.hs +++ b/impls/haskell/stepA_mal.hs @@ -1,228 +1,228 @@ -import System.IO (hFlush, stdout) -import System.Environment (getArgs) -import Control.Monad.Except (liftIO, runExceptT) -import Data.Foldable (foldlM, foldrM) - -import Readline (addHistory, readline, load_history) -import Types -import Reader (read_str) -import Printer(_pr_list, _pr_str) -import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) -import Core (ns) - --- --- Set this to True for a trace of each call to Eval. --- -traceEval :: Bool -traceEval = False - --- read - -mal_read :: String -> IOThrows MalVal -mal_read = read_str - --- eval - -qqIter :: MalVal -> MalVal -> IOThrows MalVal -qqIter (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = return $ toList [MalSymbol "concat", x, acc] -qqIter (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote" -qqIter elt acc = do - qqted <- quasiquote elt - return $ toList [MalSymbol "cons", qqted, acc] - -quasiquote :: MalVal -> IOThrows MalVal -quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) = return x -quasiquote (MalSeq _ (Vect False) (MalSymbol "unquote" : _)) = throwStr "invalid unquote" -quasiquote (MalSeq _ (Vect False) ys) = foldrM qqIter (toList []) ys -quasiquote (MalSeq _ (Vect True) ys) = do - lst <- foldrM qqIter (toList []) ys - return $ toList [MalSymbol "vec", lst] -quasiquote ast@(MalHashMap _ _) = return $ toList [MalSymbol "quote", ast] -quasiquote ast@(MalSymbol _) = return $ toList [MalSymbol "quote", ast] -quasiquote ast = return ast - -macroexpand :: Env -> MalVal -> IOThrows MalVal -macroexpand env ast@(MalSeq _ (Vect False) (MalSymbol a0 : args)) = do - maybeMacro <- liftIO $ env_get env a0 - case maybeMacro of - Just (MalMacro f) -> macroexpand env =<< f args - _ -> return ast -macroexpand _ ast = return ast - -let_bind :: Env -> [MalVal] -> IOThrows () -let_bind _ [] = return () -let_bind env (MalSymbol b : e : xs) = do - liftIO . env_set env b =<< eval env e - let_bind env xs -let_bind _ _ = throwStr "invalid let*" - -apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal - -apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do - evd <- eval env a2 - liftIO $ env_set env a1 evd - return evd -apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" - -apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do - let_env <- liftIO $ env_let env - let_bind let_env params - eval let_env a2 -apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" - -apply_ast (MalSymbol "quote") [a1] _ = return a1 -apply_ast (MalSymbol "quote") _ _ = throwStr "invalid quote" - -apply_ast (MalSymbol "quasiquoteexpand") [a1] _ = quasiquote a1 -apply_ast (MalSymbol "quasiquoteexpand") _ _ = throwStr "invalid quasiquote" - -apply_ast (MalSymbol "quasiquote") [a1] env = eval env =<< quasiquote a1 -apply_ast (MalSymbol "quasiquote") _ _ = throwStr "invalid quasiquote" - -apply_ast (MalSymbol "defmacro!") [MalSymbol a1, a2] env = do - func <- eval env a2 - case func of - MalFunction _ f -> do - let m = MalMacro f - liftIO $ env_set env a1 m - return m - _ -> throwStr "defmacro! on non-function" -apply_ast (MalSymbol "defmacro!") _ _ = throwStr "invalid defmacro!" - -apply_ast (MalSymbol "macroexpand") [a1] env = macroexpand env a1 -apply_ast (MalSymbol "macroexpand") _ _ = throwStr "invalid macroexpand" - -apply_ast (MalSymbol "try*") [a1] env = eval env a1 -apply_ast (MalSymbol "try*") [a1, MalSeq _ (Vect False) [MalSymbol "catch*", a21, a22]] env = do - res <- liftIO $ runExceptT $ eval env a1 - case res of - Right val -> return val - Left exc -> case env_apply env [a21] [exc] of - Just try_env -> eval try_env a22 - Nothing -> throwStr "invalid catch*" -apply_ast (MalSymbol "try*") _ _ = throwStr "invalid try*" - -apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args - -apply_ast (MalSymbol "if") [a1, a2, a3] env = do - cond <- eval env a1 - eval env $ case cond of - Nil -> a3 - MalBoolean False -> a3 - _ -> a2 -apply_ast (MalSymbol "if") [a1, a2] env = do - cond <- eval env a1 - case cond of - Nil -> return Nil - MalBoolean False -> return Nil - _ -> eval env a2 -apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" - -apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where - fn :: [MalVal] -> IOThrows MalVal - fn args = do - case env_apply env params args of - Just fn_env -> eval fn_env ast - Nothing -> do - p <- liftIO $ _pr_list True " " params - a <- liftIO $ _pr_list True " " args - throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p -apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" - -apply_ast first rest env = do - evd <- eval env first - case evd of - MalFunction _ f -> f =<< mapM (eval env) rest - MalMacro m -> eval env =<< m rest - _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) - -eval :: Env -> MalVal -> IOThrows MalVal -eval env ast = do - case traceEval of - True -> liftIO $ do - putStr "EVAL: " - putStr =<< _pr_str True ast - putStr " " - env_put env - putStrLn "" - hFlush stdout - False -> pure () - case ast of - MalSymbol sym -> do - maybeVal <- liftIO $ env_get env sym - case maybeVal of - Nothing -> throwStr $ "'" ++ sym ++ "' not found" - Just val -> return val - MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env - MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs - MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs - _ -> return ast - --- print - -mal_print :: MalVal -> IOThrows String -mal_print = liftIO . Printer._pr_str True - --- repl - -rep :: Env -> String -> IOThrows String -rep env line = mal_print =<< eval env =<< mal_read line - -repl_loop :: Env -> IO () -repl_loop env = do - line <- readline "user> " - case line of - Nothing -> return () - Just "" -> repl_loop env - Just str -> do - addHistory str - res <- runExceptT $ rep env str - out <- case res of - Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) - Right val -> return val - putStrLn out - hFlush stdout - repl_loop env - --- Read and evaluate a line. Ignore successful results, but crash in --- case of error. This is intended for the startup procedure. -re :: Env -> String -> IO () -re repl_env line = do - res <- runExceptT $ eval repl_env =<< mal_read line - case res of - Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv - Right _ -> return () - -defBuiltIn :: Env -> (String, Fn) -> IO () -defBuiltIn env (sym, f) = - env_set env sym $ MalFunction (MetaData Nil) f - -evalFn :: Env -> Fn -evalFn env [ast] = eval env ast -evalFn _ _ = throwStr "illegal call of eval" - -main :: IO () -main = do - args <- getArgs - load_history - - repl_env <- env_repl - - -- core.hs: defined using Haskell - mapM_ (defBuiltIn repl_env) Core.ns - defBuiltIn repl_env ("eval", evalFn repl_env) - - -- core.mal: defined using the language itself - re repl_env "(def! *host-language* \"haskell\")" - re repl_env "(def! not (fn* (a) (if a false true)))" - re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - re repl_env "(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)))))))" - - case args of - script : scriptArgs -> do - env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs - re repl_env $ "(load-file \"" ++ script ++ "\")" - [] -> do - env_set repl_env "*ARGV*" $ toList [] - re repl_env "(println (str \"Mal [\" *host-language* \"]\"))" - repl_loop repl_env +import System.IO (hFlush, stdout) +import System.Environment (getArgs) +import Control.Monad.Except (liftIO, runExceptT) +import Data.Foldable (foldlM, foldrM) + +import Readline (addHistory, readline, load_history) +import Types +import Reader (read_str) +import Printer(_pr_list, _pr_str) +import Env (Env, env_apply, env_get, env_let, env_put, env_repl, env_set) +import Core (ns) + +-- +-- Set this to True for a trace of each call to Eval. +-- +traceEval :: Bool +traceEval = False + +-- read + +mal_read :: String -> IOThrows MalVal +mal_read = read_str + +-- eval + +qqIter :: MalVal -> MalVal -> IOThrows MalVal +qqIter (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = return $ toList [MalSymbol "concat", x, acc] +qqIter (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote" +qqIter elt acc = do + qqted <- quasiquote elt + return $ toList [MalSymbol "cons", qqted, acc] + +quasiquote :: MalVal -> IOThrows MalVal +quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) = return x +quasiquote (MalSeq _ (Vect False) (MalSymbol "unquote" : _)) = throwStr "invalid unquote" +quasiquote (MalSeq _ (Vect False) ys) = foldrM qqIter (toList []) ys +quasiquote (MalSeq _ (Vect True) ys) = do + lst <- foldrM qqIter (toList []) ys + return $ toList [MalSymbol "vec", lst] +quasiquote ast@(MalHashMap _ _) = return $ toList [MalSymbol "quote", ast] +quasiquote ast@(MalSymbol _) = return $ toList [MalSymbol "quote", ast] +quasiquote ast = return ast + +macroexpand :: Env -> MalVal -> IOThrows MalVal +macroexpand env ast@(MalSeq _ (Vect False) (MalSymbol a0 : args)) = do + maybeMacro <- liftIO $ env_get env a0 + case maybeMacro of + Just (MalMacro f) -> macroexpand env =<< f args + _ -> return ast +macroexpand _ ast = return ast + +let_bind :: Env -> [MalVal] -> IOThrows () +let_bind _ [] = return () +let_bind env (MalSymbol b : e : xs) = do + liftIO . env_set env b =<< eval env e + let_bind env xs +let_bind _ _ = throwStr "invalid let*" + +apply_ast :: MalVal -> [MalVal] -> Env -> IOThrows MalVal + +apply_ast (MalSymbol "def!") [MalSymbol a1, a2] env = do + evd <- eval env a2 + liftIO $ env_set env a1 evd + return evd +apply_ast (MalSymbol "def!") _ _ = throwStr "invalid def!" + +apply_ast (MalSymbol "let*") [MalSeq _ _ params, a2] env = do + let_env <- liftIO $ env_let env + let_bind let_env params + eval let_env a2 +apply_ast (MalSymbol "let*") _ _ = throwStr "invalid let*" + +apply_ast (MalSymbol "quote") [a1] _ = return a1 +apply_ast (MalSymbol "quote") _ _ = throwStr "invalid quote" + +apply_ast (MalSymbol "quasiquoteexpand") [a1] _ = quasiquote a1 +apply_ast (MalSymbol "quasiquoteexpand") _ _ = throwStr "invalid quasiquote" + +apply_ast (MalSymbol "quasiquote") [a1] env = eval env =<< quasiquote a1 +apply_ast (MalSymbol "quasiquote") _ _ = throwStr "invalid quasiquote" + +apply_ast (MalSymbol "defmacro!") [MalSymbol a1, a2] env = do + func <- eval env a2 + case func of + MalFunction _ f -> do + let m = MalMacro f + liftIO $ env_set env a1 m + return m + _ -> throwStr "defmacro! on non-function" +apply_ast (MalSymbol "defmacro!") _ _ = throwStr "invalid defmacro!" + +apply_ast (MalSymbol "macroexpand") [a1] env = macroexpand env a1 +apply_ast (MalSymbol "macroexpand") _ _ = throwStr "invalid macroexpand" + +apply_ast (MalSymbol "try*") [a1] env = eval env a1 +apply_ast (MalSymbol "try*") [a1, MalSeq _ (Vect False) [MalSymbol "catch*", a21, a22]] env = do + res <- liftIO $ runExceptT $ eval env a1 + case res of + Right val -> return val + Left exc -> case env_apply env [a21] [exc] of + Just try_env -> eval try_env a22 + Nothing -> throwStr "invalid catch*" +apply_ast (MalSymbol "try*") _ _ = throwStr "invalid try*" + +apply_ast (MalSymbol "do") args env = foldlM (const $ eval env) Nil args + +apply_ast (MalSymbol "if") [a1, a2, a3] env = do + cond <- eval env a1 + eval env $ case cond of + Nil -> a3 + MalBoolean False -> a3 + _ -> a2 +apply_ast (MalSymbol "if") [a1, a2] env = do + cond <- eval env a1 + case cond of + Nil -> return Nil + MalBoolean False -> return Nil + _ -> eval env a2 +apply_ast (MalSymbol "if") _ _ = throwStr "invalid if" + +apply_ast (MalSymbol "fn*") [MalSeq _ _ params, ast] env = return $ MalFunction (MetaData Nil) fn where + fn :: [MalVal] -> IOThrows MalVal + fn args = do + case env_apply env params args of + Just fn_env -> eval fn_env ast + Nothing -> do + p <- liftIO $ _pr_list True " " params + a <- liftIO $ _pr_list True " " args + throwStr $ "actual parameters: " ++ a ++ " do not match signature: " ++ p +apply_ast (MalSymbol "fn*") _ _ = throwStr "invalid fn*" + +apply_ast first rest env = do + evd <- eval env first + case evd of + MalFunction _ f -> f =<< mapM (eval env) rest + MalMacro m -> eval env =<< m rest + _ -> throwStr . (++) "invalid apply: " =<< liftIO (_pr_list True " " $ first : rest) + +eval :: Env -> MalVal -> IOThrows MalVal +eval env ast = do + case traceEval of + True -> liftIO $ do + putStr "EVAL: " + putStr =<< _pr_str True ast + putStr " " + env_put env + putStrLn "" + hFlush stdout + False -> pure () + case ast of + MalSymbol sym -> do + maybeVal <- liftIO $ env_get env sym + case maybeVal of + Nothing -> throwStr $ "'" ++ sym ++ "' not found" + Just val -> return val + MalSeq _ (Vect False) (a1 : as) -> apply_ast a1 as env + MalSeq _ (Vect True) xs -> MalSeq (MetaData Nil) (Vect True) <$> mapM (eval env) xs + MalHashMap _ xs -> MalHashMap (MetaData Nil) <$> mapM (eval env) xs + _ -> return ast + +-- print + +mal_print :: MalVal -> IOThrows String +mal_print = liftIO . Printer._pr_str True + +-- repl + +rep :: Env -> String -> IOThrows String +rep env line = mal_print =<< eval env =<< mal_read line + +repl_loop :: Env -> IO () +repl_loop env = do + line <- readline "user> " + case line of + Nothing -> return () + Just "" -> repl_loop env + Just str -> do + addHistory str + res <- runExceptT $ rep env str + out <- case res of + Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) + Right val -> return val + putStrLn out + hFlush stdout + repl_loop env + +-- Read and evaluate a line. Ignore successful results, but crash in +-- case of error. This is intended for the startup procedure. +re :: Env -> String -> IO () +re repl_env line = do + res <- runExceptT $ eval repl_env =<< mal_read line + case res of + Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv + Right _ -> return () + +defBuiltIn :: Env -> (String, Fn) -> IO () +defBuiltIn env (sym, f) = + env_set env sym $ MalFunction (MetaData Nil) f + +evalFn :: Env -> Fn +evalFn env [ast] = eval env ast +evalFn _ _ = throwStr "illegal call of eval" + +main :: IO () +main = do + args <- getArgs + load_history + + repl_env <- env_repl + + -- core.hs: defined using Haskell + mapM_ (defBuiltIn repl_env) Core.ns + defBuiltIn repl_env ("eval", evalFn repl_env) + + -- core.mal: defined using the language itself + re repl_env "(def! *host-language* \"haskell\")" + re repl_env "(def! not (fn* (a) (if a false true)))" + re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + re repl_env "(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)))))))" + + case args of + script : scriptArgs -> do + env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs + re repl_env $ "(load-file \"" ++ script ++ "\")" + [] -> do + env_set repl_env "*ARGV*" $ toList [] + re repl_env "(println (str \"Mal [\" *host-language* \"]\"))" + repl_loop repl_env diff --git a/impls/haskell/tests/step5_tco.mal b/impls/haskell/tests/step5_tco.mal index eb5ace7418..e6f5a2d70f 100644 --- a/impls/haskell/tests/step5_tco.mal +++ b/impls/haskell/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Haskell: skipping non-TCO recursion -;; Reason: completes up to 100,000, stackoverflow at 1,000,000 +;; Haskell: skipping non-TCO recursion +;; Reason: completes up to 100,000, stackoverflow at 1,000,000 diff --git a/impls/haxe/Compat.hx b/impls/haxe/Compat.hx index 7882a683d4..4a6291e3b1 100644 --- a/impls/haxe/Compat.hx +++ b/impls/haxe/Compat.hx @@ -1,70 +1,70 @@ -#if js - @:native("console") - extern class Console { - public static function log(s:Dynamic):Void; - } - - @:native("process") - extern class Process { - public static var argv(default,null):Array; - public static function exit(code:Int):Void; - } - - @:jsRequire("fs") - extern class FS { - static function readFileSync(filename:String, - options:{encoding:String}):String; - } - - @:jsRequire("./node_readline") - extern class RL { - static function readline(prompt:String):Null; - } -#end - -class Compat { - public static function println(s:String) { - #if js - Console.log(s); - #else - Sys.println(s); - #end - } - - public static function slurp(filename:String) { - #if js - return FS.readFileSync(filename, {encoding: "utf-8"}); - #else - return sys.io.File.getContent(filename); - #end - } - - public static function exit(code:Int) { - #if js - Process.exit(0); - #else - Sys.exit(0); - #end - } - - public static function cmdline_args() { - #if js - return Process.argv.slice(2); - #else - return Sys.args(); - #end - } - - public static function readline(prompt:String) { - #if js - var line = RL.readline("user> "); - if (line == null) { throw new haxe.io.Eof(); } - #else - Sys.print("user> "); - var line = Sys.stdin().readLine(); - #end - return line; - } - - -} +#if js + @:native("console") + extern class Console { + public static function log(s:Dynamic):Void; + } + + @:native("process") + extern class Process { + public static var argv(default,null):Array; + public static function exit(code:Int):Void; + } + + @:jsRequire("fs") + extern class FS { + static function readFileSync(filename:String, + options:{encoding:String}):String; + } + + @:jsRequire("./node_readline") + extern class RL { + static function readline(prompt:String):Null; + } +#end + +class Compat { + public static function println(s:String) { + #if js + Console.log(s); + #else + Sys.println(s); + #end + } + + public static function slurp(filename:String) { + #if js + return FS.readFileSync(filename, {encoding: "utf-8"}); + #else + return sys.io.File.getContent(filename); + #end + } + + public static function exit(code:Int) { + #if js + Process.exit(0); + #else + Sys.exit(0); + #end + } + + public static function cmdline_args() { + #if js + return Process.argv.slice(2); + #else + return Sys.args(); + #end + } + + public static function readline(prompt:String) { + #if js + var line = RL.readline("user> "); + if (line == null) { throw new haxe.io.Eof(); } + #else + Sys.print("user> "); + var line = Sys.stdin().readLine(); + #end + return line; + } + + +} diff --git a/impls/haxe/Dockerfile b/impls/haxe/Dockerfile index a0b55723c8..2fb3a348e2 100644 --- a/impls/haxe/Dockerfile +++ b/impls/haxe/Dockerfile @@ -1,53 +1,53 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -### -# Node - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm - - -### -# Haxe - -RUN apt-get -y install software-properties-common && \ - add-apt-repository -y ppa:haxe/releases && \ - apt-get -y update - -ENV HOME / -RUN apt-get install -y haxe && \ - mkdir /haxelib && haxelib setup /haxelib - -# Install support for C++ compilation -RUN haxelib install hxcpp - +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +### +# Node + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm + + +### +# Haxe + +RUN apt-get -y install software-properties-common && \ + add-apt-repository -y ppa:haxe/releases && \ + apt-get -y update + +ENV HOME / +RUN apt-get install -y haxe && \ + mkdir /haxelib && haxelib setup /haxelib + +# Install support for C++ compilation +RUN haxelib install hxcpp + diff --git a/impls/haxe/Makefile b/impls/haxe/Makefile index 4d2133ab33..3337c153c6 100644 --- a/impls/haxe/Makefile +++ b/impls/haxe/Makefile @@ -1,104 +1,104 @@ -STEP1_DEPS = Compat.hx types/Types.hx reader/Reader.hx printer/Printer.hx -STEP3_DEPS = $(STEP1_DEPS) env/Env.hx -STEP4_DEPS = $(STEP3_DEPS) core/Core.hx - -STEPS = step0_repl step1_read_print step2_eval step3_env \ - step4_if_fn_do step5_tco step6_file step7_quote \ - step8_macros step9_try stepA_mal - -haxe_MODE ?= neko -dist_neko = mal.n -dist_python = mal.py -dist_cpp = cpp/mal - -all: all-$(haxe_MODE) - -all-neko: $(foreach x,$(STEPS),$(x).n) - -all-python: $(foreach x,$(STEPS),$(x).py) - -all-cpp: $(foreach x,$(STEPS),cpp/$(x)) - -all-js: $(foreach x,$(STEPS),$(x).js) - -dist: mal.n mal.py cpp/mal mal.js mal - -mal.n: stepA_mal.n - cp $< $@ - -mal.py: stepA_mal.py - cp $< $@ - -cpp/mal: cpp/stepA_mal - cp $< $@ - -mal.js: stepA_mal.js - cp $< $@ - - -mal: $(dist_$(haxe_MODE)) - $(if $(filter cpp,$(haxe_MODE)),\ - cp $< $@;,\ - $(if $(filter neko,$(haxe_MODE)),\ - nekotools boot $<;,\ - $(if $(filter js,$(haxe_MODE)),\ - echo "#!/usr/bin/env node" > $@;\ - cat $< >> $@;,\ - $(if $(filter python,$(haxe_MODE)),\ - echo "#!/usr/bin/env python3" > $@;\ - cat $< >> $@;,\ - $(error Invalid haxe_MODE: $(haxe_MODE)))))) - chmod +x $@ - - -# Neko target (neko) - -s%.n: S%.hx - haxe -main $(patsubst %.hx,%,$<) -neko $@ - -step1_read_print.n step2_eval.n: $(STEP1_DEPS) -step3_env.n: $(STEP3_DEPS) -step4_if_fn_do.n step5_tco.n step6_file.n step7_quote.n step8_macros.n step9_try.n stepA_mal.n: $(STEP4_DEPS) - - -# Python 3 target (python) - -s%.py: S%.hx - haxe -main $(patsubst %.hx,%,$<) -python $@ - -step1_read_print.py step2_eval.py: $(STEP1_DEPS) -step3_env.py: $(STEP3_DEPS) -step4_if_fn_do.py step5_tco.py step6_file.py step7_quote.py step8_macros.py step9_try.py stepA_mal.py: $(STEP4_DEPS) - - -# C++ target (cpp) - -cpp/s%: S%.hx - haxe -main $(patsubst %.hx,%,$<) -cpp cpp - cp $(patsubst cpp/s%,cpp/S%,$@) $@ - -cpp/step1_read_print cpp/step2_eval: $(STEP1_DEPS) -cpp/step3_env: $(STEP3_DEPS) -cpp/step4_if_fn_do cpp/step5_tco cpp/step6_file cpp/step7_quote cpp/step8_macros cpp/step9_try cpp/stepA_mal: $(STEP4_DEPS) - - -# JavaScript target (js) - -s%.js: S%.hx - haxe -main $(patsubst %.hx,%,$<) -js $@ - -JS_DEPS = node_readline.js node_modules -step0_repl.js: $(JS_DEPS) -step1_read_print.js step2_eval.js: $(STEP1_DEPS) $(JS_DEPS) -step3_env.js: $(STEP3_DEPS) $(JS_DEPS) -step4_if_fn_do.js step5_tco.js step6_file.js step7_quote.js step8_macros.js step9_try.js stepA_mal.js: $(STEP4_DEPS) $(JS_DEPS) - -node_modules: - npm install - -### - -clean: - rm -f mal.n mal.py cpp/mal mal.js mal - rm -f step*.py step*.js step*.n - [ -e cpp/ ] && rm -r cpp/ || true +STEP1_DEPS = Compat.hx types/Types.hx reader/Reader.hx printer/Printer.hx +STEP3_DEPS = $(STEP1_DEPS) env/Env.hx +STEP4_DEPS = $(STEP3_DEPS) core/Core.hx + +STEPS = step0_repl step1_read_print step2_eval step3_env \ + step4_if_fn_do step5_tco step6_file step7_quote \ + step8_macros step9_try stepA_mal + +haxe_MODE ?= neko +dist_neko = mal.n +dist_python = mal.py +dist_cpp = cpp/mal + +all: all-$(haxe_MODE) + +all-neko: $(foreach x,$(STEPS),$(x).n) + +all-python: $(foreach x,$(STEPS),$(x).py) + +all-cpp: $(foreach x,$(STEPS),cpp/$(x)) + +all-js: $(foreach x,$(STEPS),$(x).js) + +dist: mal.n mal.py cpp/mal mal.js mal + +mal.n: stepA_mal.n + cp $< $@ + +mal.py: stepA_mal.py + cp $< $@ + +cpp/mal: cpp/stepA_mal + cp $< $@ + +mal.js: stepA_mal.js + cp $< $@ + + +mal: $(dist_$(haxe_MODE)) + $(if $(filter cpp,$(haxe_MODE)),\ + cp $< $@;,\ + $(if $(filter neko,$(haxe_MODE)),\ + nekotools boot $<;,\ + $(if $(filter js,$(haxe_MODE)),\ + echo "#!/usr/bin/env node" > $@;\ + cat $< >> $@;,\ + $(if $(filter python,$(haxe_MODE)),\ + echo "#!/usr/bin/env python3" > $@;\ + cat $< >> $@;,\ + $(error Invalid haxe_MODE: $(haxe_MODE)))))) + chmod +x $@ + + +# Neko target (neko) + +s%.n: S%.hx + haxe -main $(patsubst %.hx,%,$<) -neko $@ + +step1_read_print.n step2_eval.n: $(STEP1_DEPS) +step3_env.n: $(STEP3_DEPS) +step4_if_fn_do.n step5_tco.n step6_file.n step7_quote.n step8_macros.n step9_try.n stepA_mal.n: $(STEP4_DEPS) + + +# Python 3 target (python) + +s%.py: S%.hx + haxe -main $(patsubst %.hx,%,$<) -python $@ + +step1_read_print.py step2_eval.py: $(STEP1_DEPS) +step3_env.py: $(STEP3_DEPS) +step4_if_fn_do.py step5_tco.py step6_file.py step7_quote.py step8_macros.py step9_try.py stepA_mal.py: $(STEP4_DEPS) + + +# C++ target (cpp) + +cpp/s%: S%.hx + haxe -main $(patsubst %.hx,%,$<) -cpp cpp + cp $(patsubst cpp/s%,cpp/S%,$@) $@ + +cpp/step1_read_print cpp/step2_eval: $(STEP1_DEPS) +cpp/step3_env: $(STEP3_DEPS) +cpp/step4_if_fn_do cpp/step5_tco cpp/step6_file cpp/step7_quote cpp/step8_macros cpp/step9_try cpp/stepA_mal: $(STEP4_DEPS) + + +# JavaScript target (js) + +s%.js: S%.hx + haxe -main $(patsubst %.hx,%,$<) -js $@ + +JS_DEPS = node_readline.js node_modules +step0_repl.js: $(JS_DEPS) +step1_read_print.js step2_eval.js: $(STEP1_DEPS) $(JS_DEPS) +step3_env.js: $(STEP3_DEPS) $(JS_DEPS) +step4_if_fn_do.js step5_tco.js step6_file.js step7_quote.js step8_macros.js step9_try.js stepA_mal.js: $(STEP4_DEPS) $(JS_DEPS) + +node_modules: + npm install + +### + +clean: + rm -f mal.n mal.py cpp/mal mal.js mal + rm -f step*.py step*.js step*.n + [ -e cpp/ ] && rm -r cpp/ || true diff --git a/impls/haxe/Step0_repl.hx b/impls/haxe/Step0_repl.hx index d34806a8e3..c14304c6c8 100644 --- a/impls/haxe/Step0_repl.hx +++ b/impls/haxe/Step0_repl.hx @@ -1,36 +1,36 @@ -import Compat; - -class Step0_repl { - // READ - static function READ(str:String) { - return str; - } - - // EVAL - static function EVAL(ast:String, env:String) { - return ast; - } - - // PRINT - static function PRINT(exp:String) { - return exp; - } - - // repl - static function rep(line:String) { - return PRINT(EVAL(READ(line), "")); - } - - public static function main() { - while (true) { - try { - var line = Compat.readline("user> "); - Compat.println(rep(line)); - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - Compat.println("Error: " + exc); - } - } - } -} +import Compat; + +class Step0_repl { + // READ + static function READ(str:String) { + return str; + } + + // EVAL + static function EVAL(ast:String, env:String) { + return ast; + } + + // PRINT + static function PRINT(exp:String) { + return exp; + } + + // repl + static function rep(line:String) { + return PRINT(EVAL(READ(line), "")); + } + + public static function main() { + while (true) { + try { + var line = Compat.readline("user> "); + Compat.println(rep(line)); + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + Compat.println("Error: " + exc); + } + } + } +} diff --git a/impls/haxe/Step1_read_print.hx b/impls/haxe/Step1_read_print.hx index dd22fb95b2..debc4e64a1 100644 --- a/impls/haxe/Step1_read_print.hx +++ b/impls/haxe/Step1_read_print.hx @@ -1,42 +1,42 @@ -import Compat; -import types.Types.MalType; -import reader.*; -import printer.*; - -class Step1_read_print { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function EVAL(ast:MalType, env:String) { - return ast; - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static function rep(line:String) { - return PRINT(EVAL(READ(line), "")); - } - - public static function main() { - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - Compat.println("Error: " + exc); - } - } - } -} +import Compat; +import types.Types.MalType; +import reader.*; +import printer.*; + +class Step1_read_print { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function EVAL(ast:MalType, env:String) { + return ast; + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static function rep(line:String) { + return PRINT(EVAL(READ(line), "")); + } + + public static function main() { + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + Compat.println("Error: " + exc); + } + } + } +} diff --git a/impls/haxe/Step2_eval.hx b/impls/haxe/Step2_eval.hx index 02d34f4a54..1f95b245a2 100644 --- a/impls/haxe/Step2_eval.hx +++ b/impls/haxe/Step2_eval.hx @@ -1,92 +1,92 @@ -import Compat; -import types.Types.MalType; -import types.Types.*; -import reader.*; -import printer.*; - -class Step2_eval { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function eval_ast(ast:MalType, env:Map) { - return switch (ast) { - case MalSymbol(s): - if (env.exists(s)) { - env.get(s); - } else { - throw "'" + s + "' not found"; - } - case MalList(l): - MalList(l.map(function(x) { return EVAL(x, env); })); - case MalVector(l): - MalVector(l.map(function(x) { return EVAL(x, env); })); - case MalHashMap(m): - var new_map = new Map(); - for (k in m.keys()) { - new_map[k] = EVAL(m[k], env); - } - MalHashMap(new_map); - case _: ast; - } - } - - static function EVAL(ast:MalType, env:Map):MalType { - if (!list_Q(ast)) { return eval_ast(ast, env); } - - // apply - var alst = switch (ast) { case MalList(lst): lst; case _: []; } - if (alst.length == 0) { return ast; } - - var el = eval_ast(ast, env); - var lst = switch (el) { case MalList(lst): lst; case _: []; } - var a0 = lst[0], args = lst.slice(1); - switch (a0) { - case MalFunc(f,_,_,_,_,_): return f(args); - case _: throw "Call of non-function"; - } - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static function NumOp(op):MalType { - return MalFunc(function(args:Array) { - return switch (args) { - case [MalInt(a), MalInt(b)]: MalInt(op(a,b)); - case _: throw "Invalid numeric op call"; - } - - },null,null,null,false,nil); - } - static var repl_env:Map = - ["+" => NumOp(function(a,b) {return a+b;}), - "-" => NumOp(function(a,b) {return a-b;}), - "*" => NumOp(function(a,b) {return a*b;}), - "/" => NumOp(function(a,b) {return Std.int(a/b);})]; - - static function rep(line:String):String { - return PRINT(EVAL(READ(line), repl_env)); - } - - public static function main() { - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - Compat.println("Error: " + exc); - } - } - } -} +import Compat; +import types.Types.MalType; +import types.Types.*; +import reader.*; +import printer.*; + +class Step2_eval { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function eval_ast(ast:MalType, env:Map) { + return switch (ast) { + case MalSymbol(s): + if (env.exists(s)) { + env.get(s); + } else { + throw "'" + s + "' not found"; + } + case MalList(l): + MalList(l.map(function(x) { return EVAL(x, env); })); + case MalVector(l): + MalVector(l.map(function(x) { return EVAL(x, env); })); + case MalHashMap(m): + var new_map = new Map(); + for (k in m.keys()) { + new_map[k] = EVAL(m[k], env); + } + MalHashMap(new_map); + case _: ast; + } + } + + static function EVAL(ast:MalType, env:Map):MalType { + if (!list_Q(ast)) { return eval_ast(ast, env); } + + // apply + var alst = switch (ast) { case MalList(lst): lst; case _: []; } + if (alst.length == 0) { return ast; } + + var el = eval_ast(ast, env); + var lst = switch (el) { case MalList(lst): lst; case _: []; } + var a0 = lst[0], args = lst.slice(1); + switch (a0) { + case MalFunc(f,_,_,_,_,_): return f(args); + case _: throw "Call of non-function"; + } + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static function NumOp(op):MalType { + return MalFunc(function(args:Array) { + return switch (args) { + case [MalInt(a), MalInt(b)]: MalInt(op(a,b)); + case _: throw "Invalid numeric op call"; + } + + },null,null,null,false,nil); + } + static var repl_env:Map = + ["+" => NumOp(function(a,b) {return a+b;}), + "-" => NumOp(function(a,b) {return a-b;}), + "*" => NumOp(function(a,b) {return a*b;}), + "/" => NumOp(function(a,b) {return Std.int(a/b);})]; + + static function rep(line:String):String { + return PRINT(EVAL(READ(line), repl_env)); + } + + public static function main() { + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + Compat.println("Error: " + exc); + } + } + } +} diff --git a/impls/haxe/Step3_env.hx b/impls/haxe/Step3_env.hx index 5166025841..e6bc4eb103 100644 --- a/impls/haxe/Step3_env.hx +++ b/impls/haxe/Step3_env.hx @@ -1,103 +1,103 @@ -import Compat; -import types.Types.MalType; -import types.Types.*; -import reader.*; -import printer.*; -import env.*; - -class Step3_env { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function eval_ast(ast:MalType, env:Env) { - return switch (ast) { - case MalSymbol(s): env.get(ast); - case MalList(l): - MalList(l.map(function(x) { return EVAL(x, env); })); - case MalVector(l): - MalVector(l.map(function(x) { return EVAL(x, env); })); - case MalHashMap(m): - var new_map = new Map(); - for (k in m.keys()) { - new_map[k] = EVAL(m[k], env); - } - MalHashMap(new_map); - case _: ast; - } - } - - static function EVAL(ast:MalType, env:Env):MalType { - if (!list_Q(ast)) { return eval_ast(ast, env); } - - // apply - var alst = switch (ast) { case MalList(lst): lst; case _: []; } - if (alst.length == 0) { return ast; } - - switch (alst[0]) { - case MalSymbol("def!"): - return env.set(alst[1], EVAL(alst[2], env)); - case MalSymbol("let*"): - var let_env = new Env(env); - switch (alst[1]) { - case MalList(l) | MalVector(l): - for (i in 0...l.length) { - if ((i%2) > 0) { continue; } - let_env.set(l[i], EVAL(l[i+1], let_env)); - } - case _: throw "Invalid let*"; - } - return EVAL(alst[2], let_env); - case _: - var el = eval_ast(ast, env); - var lst = _list(el); - switch (first(el)) { - case MalFunc(f,_,_,_,_,_): return f(_list(el).slice(1)); - case _: throw "Call of non-function"; - } - } - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static function NumOp(op):MalType { - return MalFunc(function(args:Array) { - return switch (args) { - case [MalInt(a), MalInt(b)]: MalInt(op(a,b)); - case _: throw "Invalid numeric op call"; - } - - },null,null,null,false,nil); - } - static var repl_env = new Env(null); - - static function rep(line:String):String { - return PRINT(EVAL(READ(line), repl_env)); - } - - public static function main() { - repl_env.set(MalSymbol("+"), NumOp(function(a,b) {return a+b;})); - repl_env.set(MalSymbol("-"), NumOp(function(a,b) {return a-b;})); - repl_env.set(MalSymbol("*"), NumOp(function(a,b) {return a*b;})); - repl_env.set(MalSymbol("/"), NumOp(function(a,b) {return Std.int(a/b);})); - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - Compat.println("Error: " + exc); - } - } - } -} +import Compat; +import types.Types.MalType; +import types.Types.*; +import reader.*; +import printer.*; +import env.*; + +class Step3_env { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function eval_ast(ast:MalType, env:Env) { + return switch (ast) { + case MalSymbol(s): env.get(ast); + case MalList(l): + MalList(l.map(function(x) { return EVAL(x, env); })); + case MalVector(l): + MalVector(l.map(function(x) { return EVAL(x, env); })); + case MalHashMap(m): + var new_map = new Map(); + for (k in m.keys()) { + new_map[k] = EVAL(m[k], env); + } + MalHashMap(new_map); + case _: ast; + } + } + + static function EVAL(ast:MalType, env:Env):MalType { + if (!list_Q(ast)) { return eval_ast(ast, env); } + + // apply + var alst = switch (ast) { case MalList(lst): lst; case _: []; } + if (alst.length == 0) { return ast; } + + switch (alst[0]) { + case MalSymbol("def!"): + return env.set(alst[1], EVAL(alst[2], env)); + case MalSymbol("let*"): + var let_env = new Env(env); + switch (alst[1]) { + case MalList(l) | MalVector(l): + for (i in 0...l.length) { + if ((i%2) > 0) { continue; } + let_env.set(l[i], EVAL(l[i+1], let_env)); + } + case _: throw "Invalid let*"; + } + return EVAL(alst[2], let_env); + case _: + var el = eval_ast(ast, env); + var lst = _list(el); + switch (first(el)) { + case MalFunc(f,_,_,_,_,_): return f(_list(el).slice(1)); + case _: throw "Call of non-function"; + } + } + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static function NumOp(op):MalType { + return MalFunc(function(args:Array) { + return switch (args) { + case [MalInt(a), MalInt(b)]: MalInt(op(a,b)); + case _: throw "Invalid numeric op call"; + } + + },null,null,null,false,nil); + } + static var repl_env = new Env(null); + + static function rep(line:String):String { + return PRINT(EVAL(READ(line), repl_env)); + } + + public static function main() { + repl_env.set(MalSymbol("+"), NumOp(function(a,b) {return a+b;})); + repl_env.set(MalSymbol("-"), NumOp(function(a,b) {return a-b;})); + repl_env.set(MalSymbol("*"), NumOp(function(a,b) {return a*b;})); + repl_env.set(MalSymbol("/"), NumOp(function(a,b) {return Std.int(a/b);})); + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + Compat.println("Error: " + exc); + } + } + } +} diff --git a/impls/haxe/Step4_if_fn_do.hx b/impls/haxe/Step4_if_fn_do.hx index 6821da74fa..383c3418b2 100644 --- a/impls/haxe/Step4_if_fn_do.hx +++ b/impls/haxe/Step4_if_fn_do.hx @@ -1,119 +1,119 @@ -import Compat; -import types.Types.MalType; -import types.Types.*; -import types.MalException; -import reader.*; -import printer.*; -import env.*; -import core.*; - -class Step4_if_fn_do { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function eval_ast(ast:MalType, env:Env) { - return switch (ast) { - case MalSymbol(s): env.get(ast); - case MalList(l): - MalList(l.map(function(x) { return EVAL(x, env); })); - case MalVector(l): - MalVector(l.map(function(x) { return EVAL(x, env); })); - case MalHashMap(m): - var new_map = new Map(); - for (k in m.keys()) { - new_map[k] = EVAL(m[k], env); - } - MalHashMap(new_map); - case _: ast; - } - } - - static function EVAL(ast:MalType, env:Env):MalType { - if (!list_Q(ast)) { return eval_ast(ast, env); } - - // apply - var alst = _list(ast); - if (alst.length == 0) { return ast; } - - switch (alst[0]) { - case MalSymbol("def!"): - return env.set(alst[1], EVAL(alst[2], env)); - case MalSymbol("let*"): - var let_env = new Env(env); - switch (alst[1]) { - case MalList(l) | MalVector(l): - for (i in 0...l.length) { - if ((i%2) > 0) { continue; } - let_env.set(l[i], EVAL(l[i+1], let_env)); - } - case _: throw "Invalid let*"; - } - return EVAL(alst[2], let_env); - case MalSymbol("do"): - return last(eval_ast(MalList(alst.slice(1)), env)); - case MalSymbol("if"): - var cond = EVAL(alst[1], env); - if (cond != MalFalse && cond != MalNil) { - return EVAL(alst[2], env); - } else if (alst.length > 3) { - return EVAL(alst[3], env); - } else { - return MalNil; - } - case MalSymbol("fn*"): - return MalFunc(function (args) { - return EVAL(alst[2], new Env(env, _list(alst[1]), args)); - },null,null,null,false,nil); - case _: - var el = eval_ast(ast, env); - var lst = _list(el); - switch (first(el)) { - case MalFunc(f,_,_,_,_,_): return f(_list(el).slice(1)); - case _: throw "Call of non-function"; - } - } - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static var repl_env = new Env(null); - - static function rep(line:String):String { - return PRINT(EVAL(READ(line), repl_env)); - } - - public static function main() { - // core.EXT: defined using Haxe - for (k in Core.ns.keys()) { - repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); - } - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))"); - - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - if (Type.getClass(exc) == MalException) { - Compat.println("Error: " + Printer.pr_str(exc.obj, true)); - } else { - Compat.println("Error: " + exc); - }; - } - } - } -} +import Compat; +import types.Types.MalType; +import types.Types.*; +import types.MalException; +import reader.*; +import printer.*; +import env.*; +import core.*; + +class Step4_if_fn_do { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function eval_ast(ast:MalType, env:Env) { + return switch (ast) { + case MalSymbol(s): env.get(ast); + case MalList(l): + MalList(l.map(function(x) { return EVAL(x, env); })); + case MalVector(l): + MalVector(l.map(function(x) { return EVAL(x, env); })); + case MalHashMap(m): + var new_map = new Map(); + for (k in m.keys()) { + new_map[k] = EVAL(m[k], env); + } + MalHashMap(new_map); + case _: ast; + } + } + + static function EVAL(ast:MalType, env:Env):MalType { + if (!list_Q(ast)) { return eval_ast(ast, env); } + + // apply + var alst = _list(ast); + if (alst.length == 0) { return ast; } + + switch (alst[0]) { + case MalSymbol("def!"): + return env.set(alst[1], EVAL(alst[2], env)); + case MalSymbol("let*"): + var let_env = new Env(env); + switch (alst[1]) { + case MalList(l) | MalVector(l): + for (i in 0...l.length) { + if ((i%2) > 0) { continue; } + let_env.set(l[i], EVAL(l[i+1], let_env)); + } + case _: throw "Invalid let*"; + } + return EVAL(alst[2], let_env); + case MalSymbol("do"): + return last(eval_ast(MalList(alst.slice(1)), env)); + case MalSymbol("if"): + var cond = EVAL(alst[1], env); + if (cond != MalFalse && cond != MalNil) { + return EVAL(alst[2], env); + } else if (alst.length > 3) { + return EVAL(alst[3], env); + } else { + return MalNil; + } + case MalSymbol("fn*"): + return MalFunc(function (args) { + return EVAL(alst[2], new Env(env, _list(alst[1]), args)); + },null,null,null,false,nil); + case _: + var el = eval_ast(ast, env); + var lst = _list(el); + switch (first(el)) { + case MalFunc(f,_,_,_,_,_): return f(_list(el).slice(1)); + case _: throw "Call of non-function"; + } + } + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static var repl_env = new Env(null); + + static function rep(line:String):String { + return PRINT(EVAL(READ(line), repl_env)); + } + + public static function main() { + // core.EXT: defined using Haxe + for (k in Core.ns.keys()) { + repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); + } + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))"); + + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; + } + } + } +} diff --git a/impls/haxe/Step5_tco.hx b/impls/haxe/Step5_tco.hx index f1b69b9c67..d8ca4d88c3 100644 --- a/impls/haxe/Step5_tco.hx +++ b/impls/haxe/Step5_tco.hx @@ -1,134 +1,134 @@ -import Compat; -import types.Types.MalType; -import types.Types.*; -import types.MalException; -import reader.*; -import printer.*; -import env.*; -import core.*; - -class Step5_tco { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function eval_ast(ast:MalType, env:Env) { - return switch (ast) { - case MalSymbol(s): env.get(ast); - case MalList(l): - MalList(l.map(function(x) { return EVAL(x, env); })); - case MalVector(l): - MalVector(l.map(function(x) { return EVAL(x, env); })); - case MalHashMap(m): - var new_map = new Map(); - for (k in m.keys()) { - new_map[k] = EVAL(m[k], env); - } - MalHashMap(new_map); - case _: ast; - } - } - - static function EVAL(ast:MalType, env:Env):MalType { - while (true) { - if (!list_Q(ast)) { return eval_ast(ast, env); } - - // apply - var alst = _list(ast); - if (alst.length == 0) { return ast; } - - switch (alst[0]) { - case MalSymbol("def!"): - return env.set(alst[1], EVAL(alst[2], env)); - case MalSymbol("let*"): - var let_env = new Env(env); - switch (alst[1]) { - case MalList(l) | MalVector(l): - for (i in 0...l.length) { - if ((i%2) > 0) { continue; } - let_env.set(l[i], EVAL(l[i+1], let_env)); - } - case _: throw "Invalid let*"; - } - ast = alst[2]; - env = let_env; - continue; // TCO - case MalSymbol("do"): - var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); - ast = last(ast); - continue; // TCO - case MalSymbol("if"): - var cond = EVAL(alst[1], env); - if (cond != MalFalse && cond != MalNil) { - ast = alst[2]; - } else if (alst.length > 3) { - ast = alst[3]; - } else { - return MalNil; - } - continue; // TCO - case MalSymbol("fn*"): - return MalFunc(function (args) { - return EVAL(alst[2], new Env(env, _list(alst[1]), args)); - },alst[2],env,alst[1],false,nil); - case _: - var el = eval_ast(ast, env); - var lst = _list(el); - switch (first(el)) { - case MalFunc(f,a,e,params,_,_): - var args = _list(el).slice(1); - if (a != null) { - ast = a; - env = new Env(e, _list(params), args); - continue; // TCO - } else { - return f(args); - } - case _: throw "Call of non-function"; - } - } - } - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static var repl_env = new Env(null); - - static function rep(line:String):String { - return PRINT(EVAL(READ(line), repl_env)); - } - - public static function main() { - // core.EXT: defined using Haxe - for (k in Core.ns.keys()) { - repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); - } - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))"); - - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - if (Type.getClass(exc) == MalException) { - Compat.println("Error: " + Printer.pr_str(exc.obj, true)); - } else { - Compat.println("Error: " + exc); - }; - } - } - } -} +import Compat; +import types.Types.MalType; +import types.Types.*; +import types.MalException; +import reader.*; +import printer.*; +import env.*; +import core.*; + +class Step5_tco { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function eval_ast(ast:MalType, env:Env) { + return switch (ast) { + case MalSymbol(s): env.get(ast); + case MalList(l): + MalList(l.map(function(x) { return EVAL(x, env); })); + case MalVector(l): + MalVector(l.map(function(x) { return EVAL(x, env); })); + case MalHashMap(m): + var new_map = new Map(); + for (k in m.keys()) { + new_map[k] = EVAL(m[k], env); + } + MalHashMap(new_map); + case _: ast; + } + } + + static function EVAL(ast:MalType, env:Env):MalType { + while (true) { + if (!list_Q(ast)) { return eval_ast(ast, env); } + + // apply + var alst = _list(ast); + if (alst.length == 0) { return ast; } + + switch (alst[0]) { + case MalSymbol("def!"): + return env.set(alst[1], EVAL(alst[2], env)); + case MalSymbol("let*"): + var let_env = new Env(env); + switch (alst[1]) { + case MalList(l) | MalVector(l): + for (i in 0...l.length) { + if ((i%2) > 0) { continue; } + let_env.set(l[i], EVAL(l[i+1], let_env)); + } + case _: throw "Invalid let*"; + } + ast = alst[2]; + env = let_env; + continue; // TCO + case MalSymbol("do"): + var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); + ast = last(ast); + continue; // TCO + case MalSymbol("if"): + var cond = EVAL(alst[1], env); + if (cond != MalFalse && cond != MalNil) { + ast = alst[2]; + } else if (alst.length > 3) { + ast = alst[3]; + } else { + return MalNil; + } + continue; // TCO + case MalSymbol("fn*"): + return MalFunc(function (args) { + return EVAL(alst[2], new Env(env, _list(alst[1]), args)); + },alst[2],env,alst[1],false,nil); + case _: + var el = eval_ast(ast, env); + var lst = _list(el); + switch (first(el)) { + case MalFunc(f,a,e,params,_,_): + var args = _list(el).slice(1); + if (a != null) { + ast = a; + env = new Env(e, _list(params), args); + continue; // TCO + } else { + return f(args); + } + case _: throw "Call of non-function"; + } + } + } + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static var repl_env = new Env(null); + + static function rep(line:String):String { + return PRINT(EVAL(READ(line), repl_env)); + } + + public static function main() { + // core.EXT: defined using Haxe + for (k in Core.ns.keys()) { + repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); + } + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))"); + + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; + } + } + } +} diff --git a/impls/haxe/Step6_file.hx b/impls/haxe/Step6_file.hx index 1eb5288db9..94f66ac6ca 100644 --- a/impls/haxe/Step6_file.hx +++ b/impls/haxe/Step6_file.hx @@ -1,149 +1,149 @@ -import Compat; -import types.Types.MalType; -import types.Types.*; -import types.MalException; -import reader.*; -import printer.*; -import env.*; -import core.*; - -class Step6_file { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function eval_ast(ast:MalType, env:Env) { - return switch (ast) { - case MalSymbol(s): env.get(ast); - case MalList(l): - MalList(l.map(function(x) { return EVAL(x, env); })); - case MalVector(l): - MalVector(l.map(function(x) { return EVAL(x, env); })); - case MalHashMap(m): - var new_map = new Map(); - for (k in m.keys()) { - new_map[k] = EVAL(m[k], env); - } - MalHashMap(new_map); - case _: ast; - } - } - - static function EVAL(ast:MalType, env:Env):MalType { - while (true) { - if (!list_Q(ast)) { return eval_ast(ast, env); } - - // apply - var alst = _list(ast); - if (alst.length == 0) { return ast; } - - switch (alst[0]) { - case MalSymbol("def!"): - return env.set(alst[1], EVAL(alst[2], env)); - case MalSymbol("let*"): - var let_env = new Env(env); - switch (alst[1]) { - case MalList(l) | MalVector(l): - for (i in 0...l.length) { - if ((i%2) > 0) { continue; } - let_env.set(l[i], EVAL(l[i+1], let_env)); - } - case _: throw "Invalid let*"; - } - ast = alst[2]; - env = let_env; - continue; // TCO - case MalSymbol("do"): - var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); - ast = last(ast); - continue; // TCO - case MalSymbol("if"): - var cond = EVAL(alst[1], env); - if (cond != MalFalse && cond != MalNil) { - ast = alst[2]; - } else if (alst.length > 3) { - ast = alst[3]; - } else { - return MalNil; - } - continue; // TCO - case MalSymbol("fn*"): - return MalFunc(function (args) { - return EVAL(alst[2], new Env(env, _list(alst[1]), args)); - },alst[2],env,alst[1],false,nil); - case _: - var el = eval_ast(ast, env); - var lst = _list(el); - switch (first(el)) { - case MalFunc(f,a,e,params,_,_): - var args = _list(el).slice(1); - if (a != null) { - ast = a; - env = new Env(e, _list(params), args); - continue; // TCO - } else { - return f(args); - } - case _: throw "Call of non-function"; - } - } - } - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static var repl_env = new Env(null); - - static function rep(line:String):String { - return PRINT(EVAL(READ(line), repl_env)); - } - - public static function main() { - // core.EXT: defined using Haxe - for (k in Core.ns.keys()) { - repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); - } - - var evalfn = MalFunc(function(args) { - return EVAL(args[0], repl_env); - },null,null,null,false,nil); - repl_env.set(MalSymbol("eval"), evalfn); - - var cmdargs = Compat.cmdline_args(); - var argarray = cmdargs.map(function(a) { return MalString(a); }); - repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))"); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - - if (cmdargs.length > 0) { - rep('(load-file "${cmdargs[0]}")'); - Compat.exit(0); - } - - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - if (Type.getClass(exc) == MalException) { - Compat.println("Error: " + Printer.pr_str(exc.obj, true)); - } else { - Compat.println("Error: " + exc); - }; - } - } - } -} +import Compat; +import types.Types.MalType; +import types.Types.*; +import types.MalException; +import reader.*; +import printer.*; +import env.*; +import core.*; + +class Step6_file { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function eval_ast(ast:MalType, env:Env) { + return switch (ast) { + case MalSymbol(s): env.get(ast); + case MalList(l): + MalList(l.map(function(x) { return EVAL(x, env); })); + case MalVector(l): + MalVector(l.map(function(x) { return EVAL(x, env); })); + case MalHashMap(m): + var new_map = new Map(); + for (k in m.keys()) { + new_map[k] = EVAL(m[k], env); + } + MalHashMap(new_map); + case _: ast; + } + } + + static function EVAL(ast:MalType, env:Env):MalType { + while (true) { + if (!list_Q(ast)) { return eval_ast(ast, env); } + + // apply + var alst = _list(ast); + if (alst.length == 0) { return ast; } + + switch (alst[0]) { + case MalSymbol("def!"): + return env.set(alst[1], EVAL(alst[2], env)); + case MalSymbol("let*"): + var let_env = new Env(env); + switch (alst[1]) { + case MalList(l) | MalVector(l): + for (i in 0...l.length) { + if ((i%2) > 0) { continue; } + let_env.set(l[i], EVAL(l[i+1], let_env)); + } + case _: throw "Invalid let*"; + } + ast = alst[2]; + env = let_env; + continue; // TCO + case MalSymbol("do"): + var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); + ast = last(ast); + continue; // TCO + case MalSymbol("if"): + var cond = EVAL(alst[1], env); + if (cond != MalFalse && cond != MalNil) { + ast = alst[2]; + } else if (alst.length > 3) { + ast = alst[3]; + } else { + return MalNil; + } + continue; // TCO + case MalSymbol("fn*"): + return MalFunc(function (args) { + return EVAL(alst[2], new Env(env, _list(alst[1]), args)); + },alst[2],env,alst[1],false,nil); + case _: + var el = eval_ast(ast, env); + var lst = _list(el); + switch (first(el)) { + case MalFunc(f,a,e,params,_,_): + var args = _list(el).slice(1); + if (a != null) { + ast = a; + env = new Env(e, _list(params), args); + continue; // TCO + } else { + return f(args); + } + case _: throw "Call of non-function"; + } + } + } + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static var repl_env = new Env(null); + + static function rep(line:String):String { + return PRINT(EVAL(READ(line), repl_env)); + } + + public static function main() { + // core.EXT: defined using Haxe + for (k in Core.ns.keys()) { + repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); + } + + var evalfn = MalFunc(function(args) { + return EVAL(args[0], repl_env); + },null,null,null,false,nil); + repl_env.set(MalSymbol("eval"), evalfn); + + var cmdargs = Compat.cmdline_args(); + var argarray = cmdargs.map(function(a) { return MalString(a); }); + repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))"); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + + if (cmdargs.length > 0) { + rep('(load-file "${cmdargs[0]}")'); + Compat.exit(0); + } + + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; + } + } + } +} diff --git a/impls/haxe/Step7_quote.hx b/impls/haxe/Step7_quote.hx index a42b36c424..776dd3a3e0 100644 --- a/impls/haxe/Step7_quote.hx +++ b/impls/haxe/Step7_quote.hx @@ -1,181 +1,181 @@ -import Compat; -import types.Types.MalType; -import types.Types.*; -import types.MalException; -import reader.*; -import printer.*; -import env.*; -import core.*; - -class Step7_quote { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function qq_loop(elt:MalType, acc:MalType) { - switch elt { - case MalList([MalSymbol("splice-unquote"), arg]): - return MalList([MalSymbol("concat"), arg, acc]); - case _: - return MalList([MalSymbol("cons"), quasiquote(elt), acc]); - } - } - static function qq_foldr(xs:Array) { - var acc = MalList([]); - for (i in 1 ... xs.length+1) { - acc = qq_loop (xs[xs.length-i], acc); - } - return acc; - } - static function quasiquote(ast:MalType) { - return switch(ast) { - case MalList([MalSymbol("unquote"), arg]): arg; - case MalList(l): qq_foldr(l); - case MalVector(l): MalList([MalSymbol("vec"), qq_foldr(l)]); - case MalSymbol(_) | MalHashMap(_): MalList([MalSymbol("quote"), ast]); - case _: ast; - } - } - - static function eval_ast(ast:MalType, env:Env) { - return switch (ast) { - case MalSymbol(s): env.get(ast); - case MalList(l): - MalList(l.map(function(x) { return EVAL(x, env); })); - case MalVector(l): - MalVector(l.map(function(x) { return EVAL(x, env); })); - case MalHashMap(m): - var new_map = new Map(); - for (k in m.keys()) { - new_map[k] = EVAL(m[k], env); - } - MalHashMap(new_map); - case _: ast; - } - } - - static function EVAL(ast:MalType, env:Env):MalType { - while (true) { - if (!list_Q(ast)) { return eval_ast(ast, env); } - - // apply - var alst = _list(ast); - if (alst.length == 0) { return ast; } - - switch (alst[0]) { - case MalSymbol("def!"): - return env.set(alst[1], EVAL(alst[2], env)); - case MalSymbol("let*"): - var let_env = new Env(env); - switch (alst[1]) { - case MalList(l) | MalVector(l): - for (i in 0...l.length) { - if ((i%2) > 0) { continue; } - let_env.set(l[i], EVAL(l[i+1], let_env)); - } - case _: throw "Invalid let*"; - } - ast = alst[2]; - env = let_env; - continue; // TCO - case MalSymbol("quote"): - return alst[1]; - case MalSymbol("quasiquoteexpand"): - return quasiquote(alst[1]); - case MalSymbol("quasiquote"): - ast = quasiquote(alst[1]); - continue; // TCO - case MalSymbol("do"): - var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); - ast = last(ast); - continue; // TCO - case MalSymbol("if"): - var cond = EVAL(alst[1], env); - if (cond != MalFalse && cond != MalNil) { - ast = alst[2]; - } else if (alst.length > 3) { - ast = alst[3]; - } else { - return MalNil; - } - continue; // TCO - case MalSymbol("fn*"): - return MalFunc(function (args) { - return EVAL(alst[2], new Env(env, _list(alst[1]), args)); - },alst[2],env,alst[1],false,nil); - case _: - var el = eval_ast(ast, env); - var lst = _list(el); - switch (first(el)) { - case MalFunc(f,a,e,params,_,_): - var args = _list(el).slice(1); - if (a != null) { - ast = a; - env = new Env(e, _list(params), args); - continue; // TCO - } else { - return f(args); - } - case _: throw "Call of non-function"; - } - } - } - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static var repl_env = new Env(null); - - static function rep(line:String):String { - return PRINT(EVAL(READ(line), repl_env)); - } - - public static function main() { - // core.EXT: defined using Haxe - for (k in Core.ns.keys()) { - repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); - } - - var evalfn = MalFunc(function(args) { - return EVAL(args[0], repl_env); - },null,null,null,false,nil); - repl_env.set(MalSymbol("eval"), evalfn); - - var cmdargs = Compat.cmdline_args(); - var argarray = cmdargs.map(function(a) { return MalString(a); }); - repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))"); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - - if (cmdargs.length > 0) { - rep('(load-file "${cmdargs[0]}")'); - Compat.exit(0); - } - - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - if (Type.getClass(exc) == MalException) { - Compat.println("Error: " + Printer.pr_str(exc.obj, true)); - } else { - Compat.println("Error: " + exc); - }; - } - } - } -} +import Compat; +import types.Types.MalType; +import types.Types.*; +import types.MalException; +import reader.*; +import printer.*; +import env.*; +import core.*; + +class Step7_quote { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function qq_loop(elt:MalType, acc:MalType) { + switch elt { + case MalList([MalSymbol("splice-unquote"), arg]): + return MalList([MalSymbol("concat"), arg, acc]); + case _: + return MalList([MalSymbol("cons"), quasiquote(elt), acc]); + } + } + static function qq_foldr(xs:Array) { + var acc = MalList([]); + for (i in 1 ... xs.length+1) { + acc = qq_loop (xs[xs.length-i], acc); + } + return acc; + } + static function quasiquote(ast:MalType) { + return switch(ast) { + case MalList([MalSymbol("unquote"), arg]): arg; + case MalList(l): qq_foldr(l); + case MalVector(l): MalList([MalSymbol("vec"), qq_foldr(l)]); + case MalSymbol(_) | MalHashMap(_): MalList([MalSymbol("quote"), ast]); + case _: ast; + } + } + + static function eval_ast(ast:MalType, env:Env) { + return switch (ast) { + case MalSymbol(s): env.get(ast); + case MalList(l): + MalList(l.map(function(x) { return EVAL(x, env); })); + case MalVector(l): + MalVector(l.map(function(x) { return EVAL(x, env); })); + case MalHashMap(m): + var new_map = new Map(); + for (k in m.keys()) { + new_map[k] = EVAL(m[k], env); + } + MalHashMap(new_map); + case _: ast; + } + } + + static function EVAL(ast:MalType, env:Env):MalType { + while (true) { + if (!list_Q(ast)) { return eval_ast(ast, env); } + + // apply + var alst = _list(ast); + if (alst.length == 0) { return ast; } + + switch (alst[0]) { + case MalSymbol("def!"): + return env.set(alst[1], EVAL(alst[2], env)); + case MalSymbol("let*"): + var let_env = new Env(env); + switch (alst[1]) { + case MalList(l) | MalVector(l): + for (i in 0...l.length) { + if ((i%2) > 0) { continue; } + let_env.set(l[i], EVAL(l[i+1], let_env)); + } + case _: throw "Invalid let*"; + } + ast = alst[2]; + env = let_env; + continue; // TCO + case MalSymbol("quote"): + return alst[1]; + case MalSymbol("quasiquoteexpand"): + return quasiquote(alst[1]); + case MalSymbol("quasiquote"): + ast = quasiquote(alst[1]); + continue; // TCO + case MalSymbol("do"): + var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); + ast = last(ast); + continue; // TCO + case MalSymbol("if"): + var cond = EVAL(alst[1], env); + if (cond != MalFalse && cond != MalNil) { + ast = alst[2]; + } else if (alst.length > 3) { + ast = alst[3]; + } else { + return MalNil; + } + continue; // TCO + case MalSymbol("fn*"): + return MalFunc(function (args) { + return EVAL(alst[2], new Env(env, _list(alst[1]), args)); + },alst[2],env,alst[1],false,nil); + case _: + var el = eval_ast(ast, env); + var lst = _list(el); + switch (first(el)) { + case MalFunc(f,a,e,params,_,_): + var args = _list(el).slice(1); + if (a != null) { + ast = a; + env = new Env(e, _list(params), args); + continue; // TCO + } else { + return f(args); + } + case _: throw "Call of non-function"; + } + } + } + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static var repl_env = new Env(null); + + static function rep(line:String):String { + return PRINT(EVAL(READ(line), repl_env)); + } + + public static function main() { + // core.EXT: defined using Haxe + for (k in Core.ns.keys()) { + repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); + } + + var evalfn = MalFunc(function(args) { + return EVAL(args[0], repl_env); + },null,null,null,false,nil); + repl_env.set(MalSymbol("eval"), evalfn); + + var cmdargs = Compat.cmdline_args(); + var argarray = cmdargs.map(function(a) { return MalString(a); }); + repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))"); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + + if (cmdargs.length > 0) { + rep('(load-file "${cmdargs[0]}")'); + Compat.exit(0); + } + + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; + } + } + } +} diff --git a/impls/haxe/Step8_macros.hx b/impls/haxe/Step8_macros.hx index d76a54c773..696623fd7f 100644 --- a/impls/haxe/Step8_macros.hx +++ b/impls/haxe/Step8_macros.hx @@ -1,219 +1,219 @@ -import Compat; -import types.Types.MalType; -import types.Types.*; -import types.MalException; -import reader.*; -import printer.*; -import env.*; -import core.*; - -class Step8_macros { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function qq_loop(elt:MalType, acc:MalType) { - switch elt { - case MalList([MalSymbol("splice-unquote"), arg]): - return MalList([MalSymbol("concat"), arg, acc]); - case _: - return MalList([MalSymbol("cons"), quasiquote(elt), acc]); - } - } - static function qq_foldr(xs:Array) { - var acc = MalList([]); - for (i in 1 ... xs.length+1) { - acc = qq_loop (xs[xs.length-i], acc); - } - return acc; - } - static function quasiquote(ast:MalType) { - return switch(ast) { - case MalList([MalSymbol("unquote"), arg]): arg; - case MalList(l): qq_foldr(l); - case MalVector(l): MalList([MalSymbol("vec"), qq_foldr(l)]); - case MalSymbol(_) | MalHashMap(_): MalList([MalSymbol("quote"), ast]); - case _: ast; - } - } - - static function is_macro(ast:MalType, env:Env) { - return switch(ast) { - case MalList([]): false; - case MalList(a): - var a0 = a[0]; - return symbol_Q(a0) && - env.find(a0) != null && - _macro_Q(env.get(a0)); - case _: false; - } - } - - static function macroexpand(ast:MalType, env:Env) { - while (is_macro(ast, env)) { - var mac = env.get(first(ast)); - switch (mac) { - case MalFunc(f,_,_,_,_,_): - ast = f(_list(ast).slice(1)); - case _: break; - } - } - return ast; - } - - static function eval_ast(ast:MalType, env:Env) { - return switch (ast) { - case MalSymbol(s): env.get(ast); - case MalList(l): - MalList(l.map(function(x) { return EVAL(x, env); })); - case MalVector(l): - MalVector(l.map(function(x) { return EVAL(x, env); })); - case MalHashMap(m): - var new_map = new Map(); - for (k in m.keys()) { - new_map[k] = EVAL(m[k], env); - } - MalHashMap(new_map); - case _: ast; - } - } - - static function EVAL(ast:MalType, env:Env):MalType { - while (true) { - if (!list_Q(ast)) { return eval_ast(ast, env); } - - // apply - ast = macroexpand(ast, env); - if (!list_Q(ast)) { return eval_ast(ast, env); } - - var alst = _list(ast); - if (alst.length == 0) { return ast; } - switch (alst[0]) { - case MalSymbol("def!"): - return env.set(alst[1], EVAL(alst[2], env)); - case MalSymbol("let*"): - var let_env = new Env(env); - switch (alst[1]) { - case MalList(l) | MalVector(l): - for (i in 0...l.length) { - if ((i%2) > 0) { continue; } - let_env.set(l[i], EVAL(l[i+1], let_env)); - } - case _: throw "Invalid let*"; - } - ast = alst[2]; - env = let_env; - continue; // TCO - case MalSymbol("quote"): - return alst[1]; - case MalSymbol("quasiquoteexpand"): - return quasiquote(alst[1]); - case MalSymbol("quasiquote"): - ast = quasiquote(alst[1]); - continue; // TCO - case MalSymbol("defmacro!"): - var func = EVAL(alst[2], env); - return switch (func) { - case MalFunc(f,ast,e,params,_,_): - env.set(alst[1], MalFunc(f,ast,e,params,true,nil)); - case _: - throw "Invalid defmacro! call"; - } - case MalSymbol("macroexpand"): - return macroexpand(alst[1], env); - case MalSymbol("do"): - var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); - ast = last(ast); - continue; // TCO - case MalSymbol("if"): - var cond = EVAL(alst[1], env); - if (cond != MalFalse && cond != MalNil) { - ast = alst[2]; - } else if (alst.length > 3) { - ast = alst[3]; - } else { - return MalNil; - } - continue; // TCO - case MalSymbol("fn*"): - return MalFunc(function (args) { - return EVAL(alst[2], new Env(env, _list(alst[1]), args)); - },alst[2],env,alst[1],false,nil); - case _: - var el = eval_ast(ast, env); - var lst = _list(el); - switch (first(el)) { - case MalFunc(f,a,e,params,_,_): - var args = _list(el).slice(1); - if (a != null) { - ast = a; - env = new Env(e, _list(params), args); - continue; // TCO - } else { - return f(args); - } - case _: throw "Call of non-function"; - } - } - } - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static var repl_env = new Env(null); - - static function rep(line:String):String { - return PRINT(EVAL(READ(line), repl_env)); - } - - public static function main() { - // core.EXT: defined using Haxe - for (k in Core.ns.keys()) { - repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); - } - - var evalfn = MalFunc(function(args) { - return EVAL(args[0], repl_env); - },null,null,null,false,nil); - repl_env.set(MalSymbol("eval"), evalfn); - - var cmdargs = Compat.cmdline_args(); - var argarray = cmdargs.map(function(a) { return MalString(a); }); - repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))"); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - 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)))))))"); - - - if (cmdargs.length > 0) { - rep('(load-file "${cmdargs[0]}")'); - Compat.exit(0); - } - - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - if (Type.getClass(exc) == MalException) { - Compat.println("Error: " + Printer.pr_str(exc.obj, true)); - } else { - Compat.println("Error: " + exc); - }; - } - } - } -} +import Compat; +import types.Types.MalType; +import types.Types.*; +import types.MalException; +import reader.*; +import printer.*; +import env.*; +import core.*; + +class Step8_macros { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function qq_loop(elt:MalType, acc:MalType) { + switch elt { + case MalList([MalSymbol("splice-unquote"), arg]): + return MalList([MalSymbol("concat"), arg, acc]); + case _: + return MalList([MalSymbol("cons"), quasiquote(elt), acc]); + } + } + static function qq_foldr(xs:Array) { + var acc = MalList([]); + for (i in 1 ... xs.length+1) { + acc = qq_loop (xs[xs.length-i], acc); + } + return acc; + } + static function quasiquote(ast:MalType) { + return switch(ast) { + case MalList([MalSymbol("unquote"), arg]): arg; + case MalList(l): qq_foldr(l); + case MalVector(l): MalList([MalSymbol("vec"), qq_foldr(l)]); + case MalSymbol(_) | MalHashMap(_): MalList([MalSymbol("quote"), ast]); + case _: ast; + } + } + + static function is_macro(ast:MalType, env:Env) { + return switch(ast) { + case MalList([]): false; + case MalList(a): + var a0 = a[0]; + return symbol_Q(a0) && + env.find(a0) != null && + _macro_Q(env.get(a0)); + case _: false; + } + } + + static function macroexpand(ast:MalType, env:Env) { + while (is_macro(ast, env)) { + var mac = env.get(first(ast)); + switch (mac) { + case MalFunc(f,_,_,_,_,_): + ast = f(_list(ast).slice(1)); + case _: break; + } + } + return ast; + } + + static function eval_ast(ast:MalType, env:Env) { + return switch (ast) { + case MalSymbol(s): env.get(ast); + case MalList(l): + MalList(l.map(function(x) { return EVAL(x, env); })); + case MalVector(l): + MalVector(l.map(function(x) { return EVAL(x, env); })); + case MalHashMap(m): + var new_map = new Map(); + for (k in m.keys()) { + new_map[k] = EVAL(m[k], env); + } + MalHashMap(new_map); + case _: ast; + } + } + + static function EVAL(ast:MalType, env:Env):MalType { + while (true) { + if (!list_Q(ast)) { return eval_ast(ast, env); } + + // apply + ast = macroexpand(ast, env); + if (!list_Q(ast)) { return eval_ast(ast, env); } + + var alst = _list(ast); + if (alst.length == 0) { return ast; } + switch (alst[0]) { + case MalSymbol("def!"): + return env.set(alst[1], EVAL(alst[2], env)); + case MalSymbol("let*"): + var let_env = new Env(env); + switch (alst[1]) { + case MalList(l) | MalVector(l): + for (i in 0...l.length) { + if ((i%2) > 0) { continue; } + let_env.set(l[i], EVAL(l[i+1], let_env)); + } + case _: throw "Invalid let*"; + } + ast = alst[2]; + env = let_env; + continue; // TCO + case MalSymbol("quote"): + return alst[1]; + case MalSymbol("quasiquoteexpand"): + return quasiquote(alst[1]); + case MalSymbol("quasiquote"): + ast = quasiquote(alst[1]); + continue; // TCO + case MalSymbol("defmacro!"): + var func = EVAL(alst[2], env); + return switch (func) { + case MalFunc(f,ast,e,params,_,_): + env.set(alst[1], MalFunc(f,ast,e,params,true,nil)); + case _: + throw "Invalid defmacro! call"; + } + case MalSymbol("macroexpand"): + return macroexpand(alst[1], env); + case MalSymbol("do"): + var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); + ast = last(ast); + continue; // TCO + case MalSymbol("if"): + var cond = EVAL(alst[1], env); + if (cond != MalFalse && cond != MalNil) { + ast = alst[2]; + } else if (alst.length > 3) { + ast = alst[3]; + } else { + return MalNil; + } + continue; // TCO + case MalSymbol("fn*"): + return MalFunc(function (args) { + return EVAL(alst[2], new Env(env, _list(alst[1]), args)); + },alst[2],env,alst[1],false,nil); + case _: + var el = eval_ast(ast, env); + var lst = _list(el); + switch (first(el)) { + case MalFunc(f,a,e,params,_,_): + var args = _list(el).slice(1); + if (a != null) { + ast = a; + env = new Env(e, _list(params), args); + continue; // TCO + } else { + return f(args); + } + case _: throw "Call of non-function"; + } + } + } + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static var repl_env = new Env(null); + + static function rep(line:String):String { + return PRINT(EVAL(READ(line), repl_env)); + } + + public static function main() { + // core.EXT: defined using Haxe + for (k in Core.ns.keys()) { + repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); + } + + var evalfn = MalFunc(function(args) { + return EVAL(args[0], repl_env); + },null,null,null,false,nil); + repl_env.set(MalSymbol("eval"), evalfn); + + var cmdargs = Compat.cmdline_args(); + var argarray = cmdargs.map(function(a) { return MalString(a); }); + repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))"); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + 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)))))))"); + + + if (cmdargs.length > 0) { + rep('(load-file "${cmdargs[0]}")'); + Compat.exit(0); + } + + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; + } + } + } +} diff --git a/impls/haxe/Step9_try.hx b/impls/haxe/Step9_try.hx index e2bfbeafce..300403c782 100644 --- a/impls/haxe/Step9_try.hx +++ b/impls/haxe/Step9_try.hx @@ -1,241 +1,241 @@ -import Compat; -import types.Types.MalType; -import types.Types.*; -import types.MalException; -import reader.*; -import printer.*; -import env.*; -import core.*; -import haxe.rtti.Meta; - -class Step9_try { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function qq_loop(elt:MalType, acc:MalType) { - switch elt { - case MalList([MalSymbol("splice-unquote"), arg]): - return MalList([MalSymbol("concat"), arg, acc]); - case _: - return MalList([MalSymbol("cons"), quasiquote(elt), acc]); - } - } - static function qq_foldr(xs:Array) { - var acc = MalList([]); - for (i in 1 ... xs.length+1) { - acc = qq_loop (xs[xs.length-i], acc); - } - return acc; - } - static function quasiquote(ast:MalType) { - return switch(ast) { - case MalList([MalSymbol("unquote"), arg]): arg; - case MalList(l): qq_foldr(l); - case MalVector(l): MalList([MalSymbol("vec"), qq_foldr(l)]); - case MalSymbol(_) | MalHashMap(_): MalList([MalSymbol("quote"), ast]); - case _: ast; - } - } - - static function is_macro(ast:MalType, env:Env) { - return switch(ast) { - case MalList([]): false; - case MalList(a): - var a0 = a[0]; - return symbol_Q(a0) && - env.find(a0) != null && - _macro_Q(env.get(a0)); - case _: false; - } - } - - static function macroexpand(ast:MalType, env:Env) { - while (is_macro(ast, env)) { - var mac = env.get(first(ast)); - switch (mac) { - case MalFunc(f,_,_,_,_,_): - ast = f(_list(ast).slice(1)); - case _: break; - } - } - return ast; - } - - static function eval_ast(ast:MalType, env:Env) { - return switch (ast) { - case MalSymbol(s): env.get(ast); - case MalList(l): - MalList(l.map(function(x) { return EVAL(x, env); })); - case MalVector(l): - MalVector(l.map(function(x) { return EVAL(x, env); })); - case MalHashMap(m): - var new_map = new Map(); - for (k in m.keys()) { - new_map[k] = EVAL(m[k], env); - } - MalHashMap(new_map); - case _: ast; - } - } - - static function EVAL(ast:MalType, env:Env):MalType { - while (true) { - if (!list_Q(ast)) { return eval_ast(ast, env); } - - // apply - ast = macroexpand(ast, env); - if (!list_Q(ast)) { return eval_ast(ast, env); } - - var alst = _list(ast); - if (alst.length == 0) { return ast; } - switch (alst[0]) { - case MalSymbol("def!"): - return env.set(alst[1], EVAL(alst[2], env)); - case MalSymbol("let*"): - var let_env = new Env(env); - switch (alst[1]) { - case MalList(l) | MalVector(l): - for (i in 0...l.length) { - if ((i%2) > 0) { continue; } - let_env.set(l[i], EVAL(l[i+1], let_env)); - } - case _: throw "Invalid let*"; - } - ast = alst[2]; - env = let_env; - continue; // TCO - case MalSymbol("quote"): - return alst[1]; - case MalSymbol("quasiquoteexpand"): - return quasiquote(alst[1]); - case MalSymbol("quasiquote"): - ast = quasiquote(alst[1]); - continue; // TCO - case MalSymbol("defmacro!"): - var func = EVAL(alst[2], env); - return switch (func) { - case MalFunc(f,ast,e,params,_,_): - env.set(alst[1], MalFunc(f,ast,e,params,true,nil)); - case _: - throw "Invalid defmacro! call"; - } - case MalSymbol("macroexpand"): - return macroexpand(alst[1], env); - case MalSymbol("try*"): - try { - return EVAL(alst[1], env); - } catch (err:Dynamic) { - if (alst.length > 2) { - switch (alst[2]) { - case MalList([MalSymbol("catch*"), a21, a22]): - var exc; - if (Type.getClass(err) == MalException) { - exc = err.obj; - } else { - exc = MalString(Std.string(err)); - }; - return EVAL(a22, new Env(env, [a21], [exc])); - case _: - throw err; - } - } else { - throw err; - } - } - case MalSymbol("do"): - var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); - ast = last(ast); - continue; // TCO - case MalSymbol("if"): - var cond = EVAL(alst[1], env); - if (cond != MalFalse && cond != MalNil) { - ast = alst[2]; - } else if (alst.length > 3) { - ast = alst[3]; - } else { - return MalNil; - } - continue; // TCO - case MalSymbol("fn*"): - return MalFunc(function (args) { - return EVAL(alst[2], new Env(env, _list(alst[1]), args)); - },alst[2],env,alst[1],false,nil); - case _: - var el = eval_ast(ast, env); - var lst = _list(el); - switch (first(el)) { - case MalFunc(f,a,e,params,_,_): - var args = _list(el).slice(1); - if (a != null) { - ast = a; - env = new Env(e, _list(params), args); - continue; // TCO - } else { - return f(args); - } - case _: throw "Call of non-function"; - } - } - } - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static var repl_env = new Env(null); - - static function rep(line:String):String { - return PRINT(EVAL(READ(line), repl_env)); - } - - public static function main() { - // core.EXT: defined using Haxe - for (k in Core.ns.keys()) { - repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); - } - - var evalfn = MalFunc(function(args) { - return EVAL(args[0], repl_env); - },null,null,null,false,nil); - repl_env.set(MalSymbol("eval"), evalfn); - - var cmdargs = Compat.cmdline_args(); - var argarray = cmdargs.map(function(a) { return MalString(a); }); - repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); - - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))"); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - 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)))))))"); - - - if (cmdargs.length > 0) { - rep('(load-file "${cmdargs[0]}")'); - Compat.exit(0); - } - - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - if (Type.getClass(exc) == MalException) { - Compat.println("Error: " + Printer.pr_str(exc.obj, true)); - } else { - Compat.println("Error: " + exc); - }; - } - } - } -} +import Compat; +import types.Types.MalType; +import types.Types.*; +import types.MalException; +import reader.*; +import printer.*; +import env.*; +import core.*; +import haxe.rtti.Meta; + +class Step9_try { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function qq_loop(elt:MalType, acc:MalType) { + switch elt { + case MalList([MalSymbol("splice-unquote"), arg]): + return MalList([MalSymbol("concat"), arg, acc]); + case _: + return MalList([MalSymbol("cons"), quasiquote(elt), acc]); + } + } + static function qq_foldr(xs:Array) { + var acc = MalList([]); + for (i in 1 ... xs.length+1) { + acc = qq_loop (xs[xs.length-i], acc); + } + return acc; + } + static function quasiquote(ast:MalType) { + return switch(ast) { + case MalList([MalSymbol("unquote"), arg]): arg; + case MalList(l): qq_foldr(l); + case MalVector(l): MalList([MalSymbol("vec"), qq_foldr(l)]); + case MalSymbol(_) | MalHashMap(_): MalList([MalSymbol("quote"), ast]); + case _: ast; + } + } + + static function is_macro(ast:MalType, env:Env) { + return switch(ast) { + case MalList([]): false; + case MalList(a): + var a0 = a[0]; + return symbol_Q(a0) && + env.find(a0) != null && + _macro_Q(env.get(a0)); + case _: false; + } + } + + static function macroexpand(ast:MalType, env:Env) { + while (is_macro(ast, env)) { + var mac = env.get(first(ast)); + switch (mac) { + case MalFunc(f,_,_,_,_,_): + ast = f(_list(ast).slice(1)); + case _: break; + } + } + return ast; + } + + static function eval_ast(ast:MalType, env:Env) { + return switch (ast) { + case MalSymbol(s): env.get(ast); + case MalList(l): + MalList(l.map(function(x) { return EVAL(x, env); })); + case MalVector(l): + MalVector(l.map(function(x) { return EVAL(x, env); })); + case MalHashMap(m): + var new_map = new Map(); + for (k in m.keys()) { + new_map[k] = EVAL(m[k], env); + } + MalHashMap(new_map); + case _: ast; + } + } + + static function EVAL(ast:MalType, env:Env):MalType { + while (true) { + if (!list_Q(ast)) { return eval_ast(ast, env); } + + // apply + ast = macroexpand(ast, env); + if (!list_Q(ast)) { return eval_ast(ast, env); } + + var alst = _list(ast); + if (alst.length == 0) { return ast; } + switch (alst[0]) { + case MalSymbol("def!"): + return env.set(alst[1], EVAL(alst[2], env)); + case MalSymbol("let*"): + var let_env = new Env(env); + switch (alst[1]) { + case MalList(l) | MalVector(l): + for (i in 0...l.length) { + if ((i%2) > 0) { continue; } + let_env.set(l[i], EVAL(l[i+1], let_env)); + } + case _: throw "Invalid let*"; + } + ast = alst[2]; + env = let_env; + continue; // TCO + case MalSymbol("quote"): + return alst[1]; + case MalSymbol("quasiquoteexpand"): + return quasiquote(alst[1]); + case MalSymbol("quasiquote"): + ast = quasiquote(alst[1]); + continue; // TCO + case MalSymbol("defmacro!"): + var func = EVAL(alst[2], env); + return switch (func) { + case MalFunc(f,ast,e,params,_,_): + env.set(alst[1], MalFunc(f,ast,e,params,true,nil)); + case _: + throw "Invalid defmacro! call"; + } + case MalSymbol("macroexpand"): + return macroexpand(alst[1], env); + case MalSymbol("try*"): + try { + return EVAL(alst[1], env); + } catch (err:Dynamic) { + if (alst.length > 2) { + switch (alst[2]) { + case MalList([MalSymbol("catch*"), a21, a22]): + var exc; + if (Type.getClass(err) == MalException) { + exc = err.obj; + } else { + exc = MalString(Std.string(err)); + }; + return EVAL(a22, new Env(env, [a21], [exc])); + case _: + throw err; + } + } else { + throw err; + } + } + case MalSymbol("do"): + var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); + ast = last(ast); + continue; // TCO + case MalSymbol("if"): + var cond = EVAL(alst[1], env); + if (cond != MalFalse && cond != MalNil) { + ast = alst[2]; + } else if (alst.length > 3) { + ast = alst[3]; + } else { + return MalNil; + } + continue; // TCO + case MalSymbol("fn*"): + return MalFunc(function (args) { + return EVAL(alst[2], new Env(env, _list(alst[1]), args)); + },alst[2],env,alst[1],false,nil); + case _: + var el = eval_ast(ast, env); + var lst = _list(el); + switch (first(el)) { + case MalFunc(f,a,e,params,_,_): + var args = _list(el).slice(1); + if (a != null) { + ast = a; + env = new Env(e, _list(params), args); + continue; // TCO + } else { + return f(args); + } + case _: throw "Call of non-function"; + } + } + } + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static var repl_env = new Env(null); + + static function rep(line:String):String { + return PRINT(EVAL(READ(line), repl_env)); + } + + public static function main() { + // core.EXT: defined using Haxe + for (k in Core.ns.keys()) { + repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); + } + + var evalfn = MalFunc(function(args) { + return EVAL(args[0], repl_env); + },null,null,null,false,nil); + repl_env.set(MalSymbol("eval"), evalfn); + + var cmdargs = Compat.cmdline_args(); + var argarray = cmdargs.map(function(a) { return MalString(a); }); + repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); + + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))"); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + 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)))))))"); + + + if (cmdargs.length > 0) { + rep('(load-file "${cmdargs[0]}")'); + Compat.exit(0); + } + + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; + } + } + } +} diff --git a/impls/haxe/StepA_mal.hx b/impls/haxe/StepA_mal.hx index 7a89cda115..d6ac0e1402 100644 --- a/impls/haxe/StepA_mal.hx +++ b/impls/haxe/StepA_mal.hx @@ -1,243 +1,243 @@ -import Compat; -import types.Types.MalType; -import types.Types.*; -import types.MalException; -import reader.*; -import printer.*; -import env.*; -import core.*; -import haxe.rtti.Meta; - -class StepA_mal { - // READ - static function READ(str:String):MalType { - return Reader.read_str(str); - } - - // EVAL - static function qq_loop(elt:MalType, acc:MalType) { - switch elt { - case MalList([MalSymbol("splice-unquote"), arg]): - return MalList([MalSymbol("concat"), arg, acc]); - case _: - return MalList([MalSymbol("cons"), quasiquote(elt), acc]); - } - } - static function qq_foldr(xs:Array) { - var acc = MalList([]); - for (i in 1 ... xs.length+1) { - acc = qq_loop (xs[xs.length-i], acc); - } - return acc; - } - static function quasiquote(ast:MalType) { - return switch(ast) { - case MalList([MalSymbol("unquote"), arg]): arg; - case MalList(l): qq_foldr(l); - case MalVector(l): MalList([MalSymbol("vec"), qq_foldr(l)]); - case MalSymbol(_) | MalHashMap(_): MalList([MalSymbol("quote"), ast]); - case _: ast; - } - } - - static function is_macro(ast:MalType, env:Env) { - return switch(ast) { - case MalList([]): false; - case MalList(a): - var a0 = a[0]; - return symbol_Q(a0) && - env.find(a0) != null && - _macro_Q(env.get(a0)); - case _: false; - } - } - - static function macroexpand(ast:MalType, env:Env) { - while (is_macro(ast, env)) { - var mac = env.get(first(ast)); - switch (mac) { - case MalFunc(f,_,_,_,_,_): - ast = f(_list(ast).slice(1)); - case _: break; - } - } - return ast; - } - - static function eval_ast(ast:MalType, env:Env) { - return switch (ast) { - case MalSymbol(s): env.get(ast); - case MalList(l): - MalList(l.map(function(x) { return EVAL(x, env); })); - case MalVector(l): - MalVector(l.map(function(x) { return EVAL(x, env); })); - case MalHashMap(m): - var new_map = new Map(); - for (k in m.keys()) { - new_map[k] = EVAL(m[k], env); - } - MalHashMap(new_map); - case _: ast; - } - } - - static function EVAL(ast:MalType, env:Env):MalType { - while (true) { - if (!list_Q(ast)) { return eval_ast(ast, env); } - - // apply - ast = macroexpand(ast, env); - if (!list_Q(ast)) { return eval_ast(ast, env); } - - var alst = _list(ast); - if (alst.length == 0) { return ast; } - switch (alst[0]) { - case MalSymbol("def!"): - return env.set(alst[1], EVAL(alst[2], env)); - case MalSymbol("let*"): - var let_env = new Env(env); - switch (alst[1]) { - case MalList(l) | MalVector(l): - for (i in 0...l.length) { - if ((i%2) > 0) { continue; } - let_env.set(l[i], EVAL(l[i+1], let_env)); - } - case _: throw "Invalid let*"; - } - ast = alst[2]; - env = let_env; - continue; // TCO - case MalSymbol("quote"): - return alst[1]; - case MalSymbol("quasiquoteexpand"): - return quasiquote(alst[1]); - case MalSymbol("quasiquote"): - ast = quasiquote(alst[1]); - continue; // TCO - case MalSymbol("defmacro!"): - var func = EVAL(alst[2], env); - return switch (func) { - case MalFunc(f,ast,e,params,_,_): - env.set(alst[1], MalFunc(f,ast,e,params,true,nil)); - case _: - throw "Invalid defmacro! call"; - } - case MalSymbol("macroexpand"): - return macroexpand(alst[1], env); - case MalSymbol("try*"): - try { - return EVAL(alst[1], env); - } catch (err:Dynamic) { - if (alst.length > 2) { - switch (alst[2]) { - case MalList([MalSymbol("catch*"), a21, a22]): - var exc; - if (Type.getClass(err) == MalException) { - exc = err.obj; - } else { - exc = MalString(Std.string(err)); - }; - return EVAL(a22, new Env(env, [a21], [exc])); - case _: - throw err; - } - } else { - throw err; - } - } - case MalSymbol("do"): - var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); - ast = last(ast); - continue; // TCO - case MalSymbol("if"): - var cond = EVAL(alst[1], env); - if (cond != MalFalse && cond != MalNil) { - ast = alst[2]; - } else if (alst.length > 3) { - ast = alst[3]; - } else { - return MalNil; - } - continue; // TCO - case MalSymbol("fn*"): - return MalFunc(function (args) { - return EVAL(alst[2], new Env(env, _list(alst[1]), args)); - },alst[2],env,alst[1],false,nil); - case _: - var el = eval_ast(ast, env); - var lst = _list(el); - switch (first(el)) { - case MalFunc(f,a,e,params,_,_): - var args = _list(el).slice(1); - if (a != null) { - ast = a; - env = new Env(e, _list(params), args); - continue; // TCO - } else { - return f(args); - } - case _: throw "Call of non-function"; - } - } - } - } - - // PRINT - static function PRINT(exp:MalType):String { - return Printer.pr_str(exp, true); - } - - // repl - static var repl_env = new Env(null); - - static function rep(line:String):String { - return PRINT(EVAL(READ(line), repl_env)); - } - - public static function main() { - // core.EXT: defined using Haxe - for (k in Core.ns.keys()) { - repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); - } - - var evalfn = MalFunc(function(args) { - return EVAL(args[0], repl_env); - },null,null,null,false,nil); - repl_env.set(MalSymbol("eval"), evalfn); - - var cmdargs = Compat.cmdline_args(); - var argarray = cmdargs.map(function(a) { return MalString(a); }); - repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); - - // core.mal: defined using the language itself - rep("(def! *host-language* \"haxe\")"); - rep("(def! not (fn* (a) (if a false true)))"); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - 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)))))))"); - - - if (cmdargs.length > 0) { - rep('(load-file "${cmdargs[0]}")'); - Compat.exit(0); - } - - rep("(println (str \"Mal [\" *host-language* \"]\"))"); - while (true) { - try { - var line = Compat.readline("user> "); - if (line == "") { continue; } - Compat.println(rep(line)); - } catch (exc:BlankLine) { - continue; - } catch (exc:haxe.io.Eof) { - Compat.exit(0); - } catch (exc:Dynamic) { - if (Type.getClass(exc) == MalException) { - Compat.println("Error: " + Printer.pr_str(exc.obj, true)); - } else { - Compat.println("Error: " + exc); - }; - } - } - } -} +import Compat; +import types.Types.MalType; +import types.Types.*; +import types.MalException; +import reader.*; +import printer.*; +import env.*; +import core.*; +import haxe.rtti.Meta; + +class StepA_mal { + // READ + static function READ(str:String):MalType { + return Reader.read_str(str); + } + + // EVAL + static function qq_loop(elt:MalType, acc:MalType) { + switch elt { + case MalList([MalSymbol("splice-unquote"), arg]): + return MalList([MalSymbol("concat"), arg, acc]); + case _: + return MalList([MalSymbol("cons"), quasiquote(elt), acc]); + } + } + static function qq_foldr(xs:Array) { + var acc = MalList([]); + for (i in 1 ... xs.length+1) { + acc = qq_loop (xs[xs.length-i], acc); + } + return acc; + } + static function quasiquote(ast:MalType) { + return switch(ast) { + case MalList([MalSymbol("unquote"), arg]): arg; + case MalList(l): qq_foldr(l); + case MalVector(l): MalList([MalSymbol("vec"), qq_foldr(l)]); + case MalSymbol(_) | MalHashMap(_): MalList([MalSymbol("quote"), ast]); + case _: ast; + } + } + + static function is_macro(ast:MalType, env:Env) { + return switch(ast) { + case MalList([]): false; + case MalList(a): + var a0 = a[0]; + return symbol_Q(a0) && + env.find(a0) != null && + _macro_Q(env.get(a0)); + case _: false; + } + } + + static function macroexpand(ast:MalType, env:Env) { + while (is_macro(ast, env)) { + var mac = env.get(first(ast)); + switch (mac) { + case MalFunc(f,_,_,_,_,_): + ast = f(_list(ast).slice(1)); + case _: break; + } + } + return ast; + } + + static function eval_ast(ast:MalType, env:Env) { + return switch (ast) { + case MalSymbol(s): env.get(ast); + case MalList(l): + MalList(l.map(function(x) { return EVAL(x, env); })); + case MalVector(l): + MalVector(l.map(function(x) { return EVAL(x, env); })); + case MalHashMap(m): + var new_map = new Map(); + for (k in m.keys()) { + new_map[k] = EVAL(m[k], env); + } + MalHashMap(new_map); + case _: ast; + } + } + + static function EVAL(ast:MalType, env:Env):MalType { + while (true) { + if (!list_Q(ast)) { return eval_ast(ast, env); } + + // apply + ast = macroexpand(ast, env); + if (!list_Q(ast)) { return eval_ast(ast, env); } + + var alst = _list(ast); + if (alst.length == 0) { return ast; } + switch (alst[0]) { + case MalSymbol("def!"): + return env.set(alst[1], EVAL(alst[2], env)); + case MalSymbol("let*"): + var let_env = new Env(env); + switch (alst[1]) { + case MalList(l) | MalVector(l): + for (i in 0...l.length) { + if ((i%2) > 0) { continue; } + let_env.set(l[i], EVAL(l[i+1], let_env)); + } + case _: throw "Invalid let*"; + } + ast = alst[2]; + env = let_env; + continue; // TCO + case MalSymbol("quote"): + return alst[1]; + case MalSymbol("quasiquoteexpand"): + return quasiquote(alst[1]); + case MalSymbol("quasiquote"): + ast = quasiquote(alst[1]); + continue; // TCO + case MalSymbol("defmacro!"): + var func = EVAL(alst[2], env); + return switch (func) { + case MalFunc(f,ast,e,params,_,_): + env.set(alst[1], MalFunc(f,ast,e,params,true,nil)); + case _: + throw "Invalid defmacro! call"; + } + case MalSymbol("macroexpand"): + return macroexpand(alst[1], env); + case MalSymbol("try*"): + try { + return EVAL(alst[1], env); + } catch (err:Dynamic) { + if (alst.length > 2) { + switch (alst[2]) { + case MalList([MalSymbol("catch*"), a21, a22]): + var exc; + if (Type.getClass(err) == MalException) { + exc = err.obj; + } else { + exc = MalString(Std.string(err)); + }; + return EVAL(a22, new Env(env, [a21], [exc])); + case _: + throw err; + } + } else { + throw err; + } + } + case MalSymbol("do"): + var el = eval_ast(MalList(alst.slice(1, alst.length-1)), env); + ast = last(ast); + continue; // TCO + case MalSymbol("if"): + var cond = EVAL(alst[1], env); + if (cond != MalFalse && cond != MalNil) { + ast = alst[2]; + } else if (alst.length > 3) { + ast = alst[3]; + } else { + return MalNil; + } + continue; // TCO + case MalSymbol("fn*"): + return MalFunc(function (args) { + return EVAL(alst[2], new Env(env, _list(alst[1]), args)); + },alst[2],env,alst[1],false,nil); + case _: + var el = eval_ast(ast, env); + var lst = _list(el); + switch (first(el)) { + case MalFunc(f,a,e,params,_,_): + var args = _list(el).slice(1); + if (a != null) { + ast = a; + env = new Env(e, _list(params), args); + continue; // TCO + } else { + return f(args); + } + case _: throw "Call of non-function"; + } + } + } + } + + // PRINT + static function PRINT(exp:MalType):String { + return Printer.pr_str(exp, true); + } + + // repl + static var repl_env = new Env(null); + + static function rep(line:String):String { + return PRINT(EVAL(READ(line), repl_env)); + } + + public static function main() { + // core.EXT: defined using Haxe + for (k in Core.ns.keys()) { + repl_env.set(MalSymbol(k), MalFunc(Core.ns[k],null,null,null,false,nil)); + } + + var evalfn = MalFunc(function(args) { + return EVAL(args[0], repl_env); + },null,null,null,false,nil); + repl_env.set(MalSymbol("eval"), evalfn); + + var cmdargs = Compat.cmdline_args(); + var argarray = cmdargs.map(function(a) { return MalString(a); }); + repl_env.set(MalSymbol("*ARGV*"), MalList(argarray.slice(1))); + + // core.mal: defined using the language itself + rep("(def! *host-language* \"haxe\")"); + rep("(def! not (fn* (a) (if a false true)))"); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + 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)))))))"); + + + if (cmdargs.length > 0) { + rep('(load-file "${cmdargs[0]}")'); + Compat.exit(0); + } + + rep("(println (str \"Mal [\" *host-language* \"]\"))"); + while (true) { + try { + var line = Compat.readline("user> "); + if (line == "") { continue; } + Compat.println(rep(line)); + } catch (exc:BlankLine) { + continue; + } catch (exc:haxe.io.Eof) { + Compat.exit(0); + } catch (exc:Dynamic) { + if (Type.getClass(exc) == MalException) { + Compat.println("Error: " + Printer.pr_str(exc.obj, true)); + } else { + Compat.println("Error: " + exc); + }; + } + } + } +} diff --git a/impls/haxe/core/Core.hx b/impls/haxe/core/Core.hx index 99eae9b7d2..7f163188d8 100644 --- a/impls/haxe/core/Core.hx +++ b/impls/haxe/core/Core.hx @@ -1,401 +1,401 @@ -package core; - -import Compat; -import types.Types.MalType; -import types.Types.*; -import types.MalException; -import printer.Printer; -import reader.Reader; -import haxe.Timer; - -class Core { - static function BoolFn(v) { - if (v) { return MalTrue; } - else { return MalFalse; } - } - - static function BoolOp(op) { - return function(args:Array) { - return switch (args) { - case [MalInt(a), MalInt(b)]: BoolFn(op(a,b)); - case _: throw "Invalid boolean op call"; - } - - }; - } - - static function NumOp(op) { - return function(args:Array) { - return switch (args) { - case [MalInt(a), MalInt(b)]: MalInt(op(a,b)); - case _: throw "Invalid numeric op call"; - } - - }; - } - - static var start = Timer.stamp(); - static function time_ms(args) { - return MalInt(Std.int(1000 * (Timer.stamp()-start))); - } - - static function equal_Q(args) { - return BoolFn(_equal_Q(args[0],args[1])); - } - - static function pr_str(args) { - return MalString( - args.map(function(s) { return Printer.pr_str(s,true); }).join(" ") - ); - } - static function str(args) { - return MalString( - args.map(function(s) { return Printer.pr_str(s,false); }).join("") - ); - } - static function prn(args) { - Compat.println(args.map(function(s) { return Printer.pr_str(s,true); }).join(" ")); - return nil; - } - static function println(args) { - Compat.println(args.map(function(s) { return Printer.pr_str(s,false); }).join(" ")); - return nil; - } - - static function symbol(args) { - return switch (args[0]) { - case MalString(s): MalSymbol(s); - case MalSymbol(_): args[0]; - case _: throw "Invalid symbol call"; - } - } - - static function keyword(args) { - return switch (args[0]) { - case MalString(s): - if (keyword_Q(args[0])) { - args[0]; - } else { - MalString("\x7f" + s); - } - case _: throw "Invalid keyword call"; - } - } - - static function read_string(args) { - return switch (args[0]) { - case MalString(s): Reader.read_str(s); - case _: throw "invalid read_str call"; - } - } - - static function readline(args) { - return switch (args[0]) { - case MalString(prompt): - try { - MalString(Compat.readline(prompt)); - } catch (exc:haxe.io.Eof) { - nil; - } - case _: throw "invalid readline call"; - } - } - - static function slurp(args) { - return switch (args[0]) { - case MalString(s): - MalString(Compat.slurp(s)); - case _: throw "invalid slurp call"; - } - } - - // sequential functions - static function sequential_Q(args) { - return BoolFn(list_Q(args[0]) || vector_Q(args[0])); - } - - static function cons(args) { - return switch [args[0], args[1]] { - case [a, MalList(l)] | - [a, MalVector(l)]: - MalList([a].concat(l)); - case [a, MalNil]: - MalList([a]); - case _: throw "Invalid cons call"; - } - } - - static function do_concat(args:Array) { - var res:Array = []; - for (a in args) { - switch (a) { - case MalList(l) | MalVector(l): - res = res.concat(l); - case MalNil: - continue; - case _: - throw "concat called with non-sequence"; - } - } - return MalList(res); - } - - static function do_vec(args:Array) { - switch (args[0]) { - case MalList(l): - return MalVector(l); - case MalVector(l): - return args[0]; - case _: - throw "vec called with non-sequence"; - } - } - - static function nth(args) { - return switch [args[0], args[1]] { - case [seq, MalInt(idx)]: - _nth(seq, idx); - case _: throw "Invalid nth call"; - } - } - - static function empty_Q(args) { - return switch (args[0]) { - case MalList(l) | MalVector(l): - if (l.length == 0) { MalTrue; } - else { MalFalse; } - case MalNil: MalTrue; - case _: MalFalse; - } - } - - static function count(args) { - return switch (args[0]) { - case MalList(l) | MalVector(l): MalInt(l.length); - case MalNil: MalInt(0); - case _: throw "count called on non-sequence"; - } - } - - static function apply(args) { - return switch [args[0], args[args.length-1]] { - case [MalFunc(f,_,_,_,_), MalList(l)] | - [MalFunc(f,_,_,_,_), MalVector(l)]: - var fargs = args.slice(1,args.length-1).concat(l); - return f(fargs); - case _: throw "Invalid apply call"; - } - } - - static function do_map(args) { - return switch [args[0], args[1]] { - case [MalFunc(f,_,_,_,_), MalList(l)] | - [MalFunc(f,_,_,_,_), MalVector(l)]: - return MalList(l.map(function(x) { return f([x]); })); - case _: throw "Invalid map call"; - } - } - - static function conj(args) { - return switch (args[0]) { - case MalList(l): - var elems = args.slice(1); - elems.reverse(); - MalList(elems.concat(l)); - case MalVector(l): - MalVector(l.concat(args.slice(1))); - case _: throw "Invalid conj call"; - } - } - - static function seq(args) { - return switch (args[0]) { - case MalList(l): - l.length > 0 ? args[0] : nil; - case MalVector(l): - l.length > 0 ? MalList(l.slice(0)) : nil; - case MalString(s): - if (s.length == 0) { return nil; } - MalList(s.split("").map(function(c) { return MalString(c); })); - case MalNil: - nil; - case _: throw "seq: called on non-sequence"; - } - } - - - // hash-map functions - - public static function get(hm:MalType, key:MalType) { - return switch [hm, key] { - case [MalHashMap(m), MalString(k)]: - if (m.exists(k)) { - m[k]; - } else { - nil; - } - case [nil, MalString(k)]: - nil; - case _: throw "invalid get call"; - } - } - - public static function assoc(args) { - return switch (args[0]) { - case MalHashMap(m): - var new_m = _clone(args[0]); - MalHashMap(assoc_BANG(new_m, args.slice(1))); - case _: throw "invalid assoc call"; - } - } - - public static function dissoc(args) { - return switch (args[0]) { - case MalHashMap(m): - var new_m = _clone(args[0]); - MalHashMap(dissoc_BANG(new_m, args.slice(1))); - case _: throw "invalid dissoc call"; - } - } - - public static function contains_Q(hm:MalType, key:MalType) { - return switch [hm, key] { - case [MalHashMap(m), MalString(k)]: - m.exists(k); - case _: throw "invalid contains? call"; - } - } - - public static function keys(hm:MalType) { - return switch (hm) { - case MalHashMap(m): - MalList([for (k in m.keys()) MalString(k)]); - case _: throw "invalid keys call"; - } - } - - public static function vals(hm:MalType) { - return switch (hm) { - case MalHashMap(m): - MalList([for (k in m.keys()) m[k]]); - case _: throw "invalid vals call"; - } - } - - // metadata functions - static function meta(args) { - return switch (args[0]) { - case MalFunc(f,_,_,_,_,meta): meta; - case _: throw "meta called on non-function"; - } - } - - static function with_meta(args) { - return switch (args[0]) { - case MalFunc(f,a,e,p,mac,_): - MalFunc(f,a,e,p,mac,args[1]); - case _: throw "with_meta called on non-function"; - } - } - - - - // atom functions - - static function deref(args) { - return switch (args[0]) { - case MalAtom(v): v.val; - case _: throw "deref called on non-atom"; - } - } - - static function reset_BANG(args) { - return switch (args[0]) { - case MalAtom(v): v.val = args[1]; - case _: throw "reset! called on non-atom"; - } - } - - static function swap_BANG(args) { - return switch [args[0], args[1]] { - case [MalAtom(v), MalFunc(f,_,_,_,_)]: - var fargs = [v.val].concat(args.slice(2)); - v.val = f(fargs); - v.val; - case _: throw "swap! called on non-atom"; - } - } - - - public static var ns:Map -> MalType> = [ - "=" => function(a) { return BoolFn(_equal_Q(a[0],a[1])); }, - "throw" => function(a) { throw new MalException(a[0]); }, - - "nil?" => function(a) { return BoolFn(nil_Q(a[0])); }, - "true?" => function(a) { return BoolFn(true_Q(a[0])); }, - "false?" => function(a) { return BoolFn(false_Q(a[0])); }, - "string?" => function(a) { return BoolFn(string_Q(a[0])); }, - "symbol" => symbol, - "symbol?" => function(a) { return BoolFn(symbol_Q(a[0])); }, - "keyword" => keyword, - "keyword?" => function(a) { return BoolFn(keyword_Q(a[0])); }, - "number?" => function(a) { return BoolFn(number_Q(a[0])); }, - "fn?" => function(a) { return BoolFn(_fn_Q(a[0])); }, - "macro?" => function(a) { return BoolFn(_macro_Q(a[0])); }, - - "pr-str" => pr_str, - "str" => str, - "prn" => prn, - "println" => println, - "read-string" => read_string, - "readline" => readline, - "slurp" => slurp, - - "<" => BoolOp(function(a,b) {return a" => BoolOp(function(a,b) {return a>b;}), - ">=" => BoolOp(function(a,b) {return a>=b;}), - "+" => NumOp(function(a,b) {return a+b;}), - "-" => NumOp(function(a,b) {return a-b;}), - "*" => NumOp(function(a,b) {return a*b;}), - "/" => NumOp(function(a,b) {return Std.int(a/b);}), - "time-ms" => time_ms, - - "list" => function(a) { return MalList(a); }, - "list?" => function(a) { return BoolFn(list_Q(a[0])); }, - "vector" => function(a) { return MalVector(a); }, - "vector?" => function(a) { return BoolFn(vector_Q(a[0])); }, - "hash-map" => hash_map, - "map?" => function(a) { return BoolFn(hash_map_Q(a[0])); }, - "assoc" => assoc, - "dissoc" => dissoc, - "get" => function(a) { return get(a[0],a[1]); }, - "contains?" => function(a) { return BoolFn(contains_Q(a[0], a[1])); }, - "keys" => function(a) { return keys(a[0]); } , - "vals" => function(a) { return vals(a[0]); } , - - "sequential?" => sequential_Q, - "cons" => cons, - "concat" => do_concat, - "vec" => do_vec, - - "nth" => nth, - "first" => function(a) { return first(a[0]); }, - "rest" => function(a) { return rest(a[0]); }, - "empty?" => empty_Q, - "count" => count, - "apply" => apply, - "map" => do_map, - - "conj" => conj, - "seq" => seq, - - "meta" => meta, - "with-meta" => with_meta, - "atom" => function(a) { return MalAtom({val:a[0]}); }, - "atom?" => function(a) { return BoolFn(atom_Q(a[0])); }, - "deref" => deref, - "reset!" => reset_BANG, - "swap!" => swap_BANG - ]; -} +package core; + +import Compat; +import types.Types.MalType; +import types.Types.*; +import types.MalException; +import printer.Printer; +import reader.Reader; +import haxe.Timer; + +class Core { + static function BoolFn(v) { + if (v) { return MalTrue; } + else { return MalFalse; } + } + + static function BoolOp(op) { + return function(args:Array) { + return switch (args) { + case [MalInt(a), MalInt(b)]: BoolFn(op(a,b)); + case _: throw "Invalid boolean op call"; + } + + }; + } + + static function NumOp(op) { + return function(args:Array) { + return switch (args) { + case [MalInt(a), MalInt(b)]: MalInt(op(a,b)); + case _: throw "Invalid numeric op call"; + } + + }; + } + + static var start = Timer.stamp(); + static function time_ms(args) { + return MalInt(Std.int(1000 * (Timer.stamp()-start))); + } + + static function equal_Q(args) { + return BoolFn(_equal_Q(args[0],args[1])); + } + + static function pr_str(args) { + return MalString( + args.map(function(s) { return Printer.pr_str(s,true); }).join(" ") + ); + } + static function str(args) { + return MalString( + args.map(function(s) { return Printer.pr_str(s,false); }).join("") + ); + } + static function prn(args) { + Compat.println(args.map(function(s) { return Printer.pr_str(s,true); }).join(" ")); + return nil; + } + static function println(args) { + Compat.println(args.map(function(s) { return Printer.pr_str(s,false); }).join(" ")); + return nil; + } + + static function symbol(args) { + return switch (args[0]) { + case MalString(s): MalSymbol(s); + case MalSymbol(_): args[0]; + case _: throw "Invalid symbol call"; + } + } + + static function keyword(args) { + return switch (args[0]) { + case MalString(s): + if (keyword_Q(args[0])) { + args[0]; + } else { + MalString("\x7f" + s); + } + case _: throw "Invalid keyword call"; + } + } + + static function read_string(args) { + return switch (args[0]) { + case MalString(s): Reader.read_str(s); + case _: throw "invalid read_str call"; + } + } + + static function readline(args) { + return switch (args[0]) { + case MalString(prompt): + try { + MalString(Compat.readline(prompt)); + } catch (exc:haxe.io.Eof) { + nil; + } + case _: throw "invalid readline call"; + } + } + + static function slurp(args) { + return switch (args[0]) { + case MalString(s): + MalString(Compat.slurp(s)); + case _: throw "invalid slurp call"; + } + } + + // sequential functions + static function sequential_Q(args) { + return BoolFn(list_Q(args[0]) || vector_Q(args[0])); + } + + static function cons(args) { + return switch [args[0], args[1]] { + case [a, MalList(l)] | + [a, MalVector(l)]: + MalList([a].concat(l)); + case [a, MalNil]: + MalList([a]); + case _: throw "Invalid cons call"; + } + } + + static function do_concat(args:Array) { + var res:Array = []; + for (a in args) { + switch (a) { + case MalList(l) | MalVector(l): + res = res.concat(l); + case MalNil: + continue; + case _: + throw "concat called with non-sequence"; + } + } + return MalList(res); + } + + static function do_vec(args:Array) { + switch (args[0]) { + case MalList(l): + return MalVector(l); + case MalVector(l): + return args[0]; + case _: + throw "vec called with non-sequence"; + } + } + + static function nth(args) { + return switch [args[0], args[1]] { + case [seq, MalInt(idx)]: + _nth(seq, idx); + case _: throw "Invalid nth call"; + } + } + + static function empty_Q(args) { + return switch (args[0]) { + case MalList(l) | MalVector(l): + if (l.length == 0) { MalTrue; } + else { MalFalse; } + case MalNil: MalTrue; + case _: MalFalse; + } + } + + static function count(args) { + return switch (args[0]) { + case MalList(l) | MalVector(l): MalInt(l.length); + case MalNil: MalInt(0); + case _: throw "count called on non-sequence"; + } + } + + static function apply(args) { + return switch [args[0], args[args.length-1]] { + case [MalFunc(f,_,_,_,_), MalList(l)] | + [MalFunc(f,_,_,_,_), MalVector(l)]: + var fargs = args.slice(1,args.length-1).concat(l); + return f(fargs); + case _: throw "Invalid apply call"; + } + } + + static function do_map(args) { + return switch [args[0], args[1]] { + case [MalFunc(f,_,_,_,_), MalList(l)] | + [MalFunc(f,_,_,_,_), MalVector(l)]: + return MalList(l.map(function(x) { return f([x]); })); + case _: throw "Invalid map call"; + } + } + + static function conj(args) { + return switch (args[0]) { + case MalList(l): + var elems = args.slice(1); + elems.reverse(); + MalList(elems.concat(l)); + case MalVector(l): + MalVector(l.concat(args.slice(1))); + case _: throw "Invalid conj call"; + } + } + + static function seq(args) { + return switch (args[0]) { + case MalList(l): + l.length > 0 ? args[0] : nil; + case MalVector(l): + l.length > 0 ? MalList(l.slice(0)) : nil; + case MalString(s): + if (s.length == 0) { return nil; } + MalList(s.split("").map(function(c) { return MalString(c); })); + case MalNil: + nil; + case _: throw "seq: called on non-sequence"; + } + } + + + // hash-map functions + + public static function get(hm:MalType, key:MalType) { + return switch [hm, key] { + case [MalHashMap(m), MalString(k)]: + if (m.exists(k)) { + m[k]; + } else { + nil; + } + case [nil, MalString(k)]: + nil; + case _: throw "invalid get call"; + } + } + + public static function assoc(args) { + return switch (args[0]) { + case MalHashMap(m): + var new_m = _clone(args[0]); + MalHashMap(assoc_BANG(new_m, args.slice(1))); + case _: throw "invalid assoc call"; + } + } + + public static function dissoc(args) { + return switch (args[0]) { + case MalHashMap(m): + var new_m = _clone(args[0]); + MalHashMap(dissoc_BANG(new_m, args.slice(1))); + case _: throw "invalid dissoc call"; + } + } + + public static function contains_Q(hm:MalType, key:MalType) { + return switch [hm, key] { + case [MalHashMap(m), MalString(k)]: + m.exists(k); + case _: throw "invalid contains? call"; + } + } + + public static function keys(hm:MalType) { + return switch (hm) { + case MalHashMap(m): + MalList([for (k in m.keys()) MalString(k)]); + case _: throw "invalid keys call"; + } + } + + public static function vals(hm:MalType) { + return switch (hm) { + case MalHashMap(m): + MalList([for (k in m.keys()) m[k]]); + case _: throw "invalid vals call"; + } + } + + // metadata functions + static function meta(args) { + return switch (args[0]) { + case MalFunc(f,_,_,_,_,meta): meta; + case _: throw "meta called on non-function"; + } + } + + static function with_meta(args) { + return switch (args[0]) { + case MalFunc(f,a,e,p,mac,_): + MalFunc(f,a,e,p,mac,args[1]); + case _: throw "with_meta called on non-function"; + } + } + + + + // atom functions + + static function deref(args) { + return switch (args[0]) { + case MalAtom(v): v.val; + case _: throw "deref called on non-atom"; + } + } + + static function reset_BANG(args) { + return switch (args[0]) { + case MalAtom(v): v.val = args[1]; + case _: throw "reset! called on non-atom"; + } + } + + static function swap_BANG(args) { + return switch [args[0], args[1]] { + case [MalAtom(v), MalFunc(f,_,_,_,_)]: + var fargs = [v.val].concat(args.slice(2)); + v.val = f(fargs); + v.val; + case _: throw "swap! called on non-atom"; + } + } + + + public static var ns:Map -> MalType> = [ + "=" => function(a) { return BoolFn(_equal_Q(a[0],a[1])); }, + "throw" => function(a) { throw new MalException(a[0]); }, + + "nil?" => function(a) { return BoolFn(nil_Q(a[0])); }, + "true?" => function(a) { return BoolFn(true_Q(a[0])); }, + "false?" => function(a) { return BoolFn(false_Q(a[0])); }, + "string?" => function(a) { return BoolFn(string_Q(a[0])); }, + "symbol" => symbol, + "symbol?" => function(a) { return BoolFn(symbol_Q(a[0])); }, + "keyword" => keyword, + "keyword?" => function(a) { return BoolFn(keyword_Q(a[0])); }, + "number?" => function(a) { return BoolFn(number_Q(a[0])); }, + "fn?" => function(a) { return BoolFn(_fn_Q(a[0])); }, + "macro?" => function(a) { return BoolFn(_macro_Q(a[0])); }, + + "pr-str" => pr_str, + "str" => str, + "prn" => prn, + "println" => println, + "read-string" => read_string, + "readline" => readline, + "slurp" => slurp, + + "<" => BoolOp(function(a,b) {return a" => BoolOp(function(a,b) {return a>b;}), + ">=" => BoolOp(function(a,b) {return a>=b;}), + "+" => NumOp(function(a,b) {return a+b;}), + "-" => NumOp(function(a,b) {return a-b;}), + "*" => NumOp(function(a,b) {return a*b;}), + "/" => NumOp(function(a,b) {return Std.int(a/b);}), + "time-ms" => time_ms, + + "list" => function(a) { return MalList(a); }, + "list?" => function(a) { return BoolFn(list_Q(a[0])); }, + "vector" => function(a) { return MalVector(a); }, + "vector?" => function(a) { return BoolFn(vector_Q(a[0])); }, + "hash-map" => hash_map, + "map?" => function(a) { return BoolFn(hash_map_Q(a[0])); }, + "assoc" => assoc, + "dissoc" => dissoc, + "get" => function(a) { return get(a[0],a[1]); }, + "contains?" => function(a) { return BoolFn(contains_Q(a[0], a[1])); }, + "keys" => function(a) { return keys(a[0]); } , + "vals" => function(a) { return vals(a[0]); } , + + "sequential?" => sequential_Q, + "cons" => cons, + "concat" => do_concat, + "vec" => do_vec, + + "nth" => nth, + "first" => function(a) { return first(a[0]); }, + "rest" => function(a) { return rest(a[0]); }, + "empty?" => empty_Q, + "count" => count, + "apply" => apply, + "map" => do_map, + + "conj" => conj, + "seq" => seq, + + "meta" => meta, + "with-meta" => with_meta, + "atom" => function(a) { return MalAtom({val:a[0]}); }, + "atom?" => function(a) { return BoolFn(atom_Q(a[0])); }, + "deref" => deref, + "reset!" => reset_BANG, + "swap!" => swap_BANG + ]; +} diff --git a/impls/haxe/env/Env.hx b/impls/haxe/env/Env.hx index ce60fa89a5..f08a11aae1 100644 --- a/impls/haxe/env/Env.hx +++ b/impls/haxe/env/Env.hx @@ -1,62 +1,62 @@ -package env; - -import types.Types.MalType; -import types.Types.*; - -class Env { - var data = new Map(); - var outer:Env = null; - - public function new(outer:Env, - binds:Array = null, - exprs:Array = null) { - this.outer = outer; - - if (binds != null) { - for (i in 0...binds.length) { - var b = binds[i], e = exprs[i]; - switch (b) { - case MalSymbol("&"): - switch (binds[i+1]) { - case MalSymbol(b2): - data[b2] = MalList(exprs.slice(i)); - case _: - throw "invalid vararg binding"; - } - break; - case MalSymbol(s): - data[s] = e; - case _: throw "invalid bind"; - } - } - } - } - - public function set(key:MalType, val:MalType) { - switch (key) { - case MalSymbol(s): data[s] = val; - case _: throw "Invalid Env.set call"; - } - return val; - } - - public function find(key:MalType):Env { - return switch (key) { - case MalSymbol(s): - if (data.exists(s)) { this; } - else if (outer != null) { outer.find(key); } - else { null; } - case _: throw "Invalid Env.find call"; - } - } - - public function get(key:MalType):MalType { - return switch (key) { - case MalSymbol(s): - var e = find(key); - if (e == null) { throw "'" + s + "' not found"; } - return e.data.get(s); - case _: throw "Invalid Env.get call"; - } - } -} +package env; + +import types.Types.MalType; +import types.Types.*; + +class Env { + var data = new Map(); + var outer:Env = null; + + public function new(outer:Env, + binds:Array = null, + exprs:Array = null) { + this.outer = outer; + + if (binds != null) { + for (i in 0...binds.length) { + var b = binds[i], e = exprs[i]; + switch (b) { + case MalSymbol("&"): + switch (binds[i+1]) { + case MalSymbol(b2): + data[b2] = MalList(exprs.slice(i)); + case _: + throw "invalid vararg binding"; + } + break; + case MalSymbol(s): + data[s] = e; + case _: throw "invalid bind"; + } + } + } + } + + public function set(key:MalType, val:MalType) { + switch (key) { + case MalSymbol(s): data[s] = val; + case _: throw "Invalid Env.set call"; + } + return val; + } + + public function find(key:MalType):Env { + return switch (key) { + case MalSymbol(s): + if (data.exists(s)) { this; } + else if (outer != null) { outer.find(key); } + else { null; } + case _: throw "Invalid Env.find call"; + } + } + + public function get(key:MalType):MalType { + return switch (key) { + case MalSymbol(s): + var e = find(key); + if (e == null) { throw "'" + s + "' not found"; } + return e.data.get(s); + case _: throw "Invalid Env.get call"; + } + } +} diff --git a/impls/haxe/node_readline.js b/impls/haxe/node_readline.js index 80885cf27b..6edd82e3eb 100644 --- a/impls/haxe/node_readline.js +++ b/impls/haxe/node_readline.js @@ -1,46 +1,46 @@ -// IMPORTANT: choose one -var RL_LIB = "libreadline"; // NOTE: libreadline is GPL -//var RL_LIB = "libedit"; - -var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); - -var rlwrap = {}; // namespace for this module in web context - -var ffi = require('ffi-napi'), - fs = require('fs'); - -var rllib = ffi.Library(RL_LIB, { - 'readline': [ 'string', [ 'string' ] ], - 'add_history': [ 'int', [ 'string' ] ]}); - -var rl_history_loaded = false; - -exports.readline = rlwrap.readline = function(prompt) { - prompt = prompt || "user> "; - - if (!rl_history_loaded) { - rl_history_loaded = true; - var lines = []; - if (fs.existsSync(HISTORY_FILE)) { - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - } - // Max of 2000 lines - lines = lines.slice(Math.max(lines.length - 2000, 0)); - for (var i=0; i "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i"; - } - case _: throw "unknown type for printing"; - } - } -} +package printer; + +import types.Types.MalType; +import types.Types.MalType.*; + +class Printer { + public static function pr_str(exp:MalType, print_readably:Bool = true) { + var _r = print_readably; + return switch(exp) { + case MalNil: "nil"; + case MalTrue: "true"; + case MalFalse: "false"; + case MalInt(v): Std.string(v); + case MalSymbol(v): v; + case MalString(v): + var re1 = ~/\\/g, + re2 = ~/"/g, + re3 = ~/\n/g; + //if (haxe.Utf8.charCodeAt(v, 0) == 255) { + if (v.charAt(0) == "\x7f") { + ":" + v.substr(1); + } else if (_r) { + '"' + re3.replace( + re2.replace( + re1.replace(v, "\\\\"), + '\\"'), + "\\n") + '"'; + } else { + v; + } + case MalList(l): + var lst = l.map(function(e) {return pr_str(e,_r);}); + '(${lst.join(" ")})'; + case MalVector(l): + var lst = l.map(function(e) {return pr_str(e,_r);}); + '[${lst.join(" ")}]'; + case MalHashMap(m): + var elems = []; + for (k in m.keys()) { + elems.push(pr_str(MalString(k), _r)); + elems.push(pr_str(m[k], _r)); + } + '{${elems.join(" ")}}'; + case MalAtom(v): + '(atom ${pr_str(v.val,_r)})'; + case MalFunc(f,ast,_,params,_): + if (ast != null) { + '(fn* ${pr_str(params,true)} ${pr_str(ast)})'; + } else { + "#"; + } + case _: throw "unknown type for printing"; + } + } +} diff --git a/impls/haxe/reader/BlankLine.hx b/impls/haxe/reader/BlankLine.hx index 2b1104026c..fafd51f051 100644 --- a/impls/haxe/reader/BlankLine.hx +++ b/impls/haxe/reader/BlankLine.hx @@ -1,6 +1,6 @@ -package reader; - -class BlankLine { - public function new() { - } -} +package reader; + +class BlankLine { + public function new() { + } +} diff --git a/impls/haxe/reader/Reader.hx b/impls/haxe/reader/Reader.hx index 6c935ec0af..432e4d8e86 100644 --- a/impls/haxe/reader/Reader.hx +++ b/impls/haxe/reader/Reader.hx @@ -1,137 +1,137 @@ -package reader; - -import types.Types.MalType; -import types.Types.*; - -class Reader { - // Reader class implementation - var tokens:Array; - var position:Int = 0; - - public function new(toks:Array) { - tokens = toks; - } - - public function next() { - return tokens[position++]; - } - - public function peek() { - if (tokens.length > position) { - return tokens[position]; - } else { - return null; - } - } - - - // Static functions grouped with Reader class - static function tokenize(str:String) { - var re = ~/[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; - var tokens = new Array(); - var pos = 0; - while (re.matchSub(str, pos)) { - var t = re.matched(1); - if (t == "") { break; } - var pos_len = re.matchedPos(); - pos = pos_len.pos + pos_len.len; - if (t.charAt(0) == ";") { continue; } - tokens.push(t); - - } - return tokens; - } - - static function read_atom(rdr:Reader) { - var re_int = ~/^-?[0-9][0-9]*$/; - var re_str = ~/^"(?:\\.|[^\\"])*"$/; - var re_str_bad = ~/^".*$/; - var token = rdr.next(); - return switch (token) { - case "nil": - MalNil; - case "true": - MalTrue; - case "false": - MalFalse; - case _ if (token.charAt(0) == ":"): - MalString("\x7f" + token.substr(1)); - case _ if (re_int.match(token)): - MalInt(Std.parseInt(token)); - case _ if (re_str.match(token)): - var re1 = ~/\\\\/g, - re2 = ~/\\n/g, - re3 = ~/\\"/g, - re4 = ~/\x7f/g, - s = token.substr(1, token.length-2); - MalString(re4.replace( - re3.replace( - re2.replace( - re1.replace( - s, - "\x7f"), - "\n"), - "\""), - "\\")); - case _ if (re_str_bad.match(token)): - throw 'expected \'"\', got EOF'; - case _: - MalSymbol(token); - } - } - - static function read_seq(rdr:Reader, start, end) { - var lst = []; - var token = rdr.next(); - if (token != start) { - throw 'expected \'${start}\''; - } - while ((token = rdr.peek()) != end) { - if (token == null) { - throw 'expected \'${end}\', got EOF'; - } - lst.push(read_form(rdr)); - } - rdr.next(); - return lst; - } - - static function read_form(rdr:Reader):MalType { - var token = rdr.peek(); - return switch (token) { - // reader macros/transforms - case "'": rdr.next(); - MalList([MalSymbol("quote"), read_form(rdr)]); - case "`": rdr.next(); - MalList([MalSymbol("quasiquote"), read_form(rdr)]); - case "~": rdr.next(); - MalList([MalSymbol("unquote"), read_form(rdr)]); - case "~@": rdr.next(); - MalList([MalSymbol("splice-unquote"), read_form(rdr)]); - case "^": rdr.next(); - var meta = read_form(rdr); - MalList([MalSymbol("with-meta"), read_form(rdr), meta]); - case "@": rdr.next(); - MalList([MalSymbol("deref"), read_form(rdr)]); - - // list - case ")": throw("unexpected ')'"); - case "(": MalList(read_seq(rdr, '(', ')')); - - // vector - case "]": throw("unexpected ']'"); - case "[": MalVector(read_seq(rdr, '[', ']')); - - // hashmap - case "}": throw("unexpected '}'"); - case "{": hash_map(read_seq(rdr, '{', '}')); - case _: read_atom(rdr); - } - } - - public static function read_str(str:String):MalType { - var tokens = tokenize(str); - if (tokens.length == 0) { throw(new BlankLine()); } - return read_form(new Reader(tokens)); - } -} +package reader; + +import types.Types.MalType; +import types.Types.*; + +class Reader { + // Reader class implementation + var tokens:Array; + var position:Int = 0; + + public function new(toks:Array) { + tokens = toks; + } + + public function next() { + return tokens[position++]; + } + + public function peek() { + if (tokens.length > position) { + return tokens[position]; + } else { + return null; + } + } + + + // Static functions grouped with Reader class + static function tokenize(str:String) { + var re = ~/[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; + var tokens = new Array(); + var pos = 0; + while (re.matchSub(str, pos)) { + var t = re.matched(1); + if (t == "") { break; } + var pos_len = re.matchedPos(); + pos = pos_len.pos + pos_len.len; + if (t.charAt(0) == ";") { continue; } + tokens.push(t); + + } + return tokens; + } + + static function read_atom(rdr:Reader) { + var re_int = ~/^-?[0-9][0-9]*$/; + var re_str = ~/^"(?:\\.|[^\\"])*"$/; + var re_str_bad = ~/^".*$/; + var token = rdr.next(); + return switch (token) { + case "nil": + MalNil; + case "true": + MalTrue; + case "false": + MalFalse; + case _ if (token.charAt(0) == ":"): + MalString("\x7f" + token.substr(1)); + case _ if (re_int.match(token)): + MalInt(Std.parseInt(token)); + case _ if (re_str.match(token)): + var re1 = ~/\\\\/g, + re2 = ~/\\n/g, + re3 = ~/\\"/g, + re4 = ~/\x7f/g, + s = token.substr(1, token.length-2); + MalString(re4.replace( + re3.replace( + re2.replace( + re1.replace( + s, + "\x7f"), + "\n"), + "\""), + "\\")); + case _ if (re_str_bad.match(token)): + throw 'expected \'"\', got EOF'; + case _: + MalSymbol(token); + } + } + + static function read_seq(rdr:Reader, start, end) { + var lst = []; + var token = rdr.next(); + if (token != start) { + throw 'expected \'${start}\''; + } + while ((token = rdr.peek()) != end) { + if (token == null) { + throw 'expected \'${end}\', got EOF'; + } + lst.push(read_form(rdr)); + } + rdr.next(); + return lst; + } + + static function read_form(rdr:Reader):MalType { + var token = rdr.peek(); + return switch (token) { + // reader macros/transforms + case "'": rdr.next(); + MalList([MalSymbol("quote"), read_form(rdr)]); + case "`": rdr.next(); + MalList([MalSymbol("quasiquote"), read_form(rdr)]); + case "~": rdr.next(); + MalList([MalSymbol("unquote"), read_form(rdr)]); + case "~@": rdr.next(); + MalList([MalSymbol("splice-unquote"), read_form(rdr)]); + case "^": rdr.next(); + var meta = read_form(rdr); + MalList([MalSymbol("with-meta"), read_form(rdr), meta]); + case "@": rdr.next(); + MalList([MalSymbol("deref"), read_form(rdr)]); + + // list + case ")": throw("unexpected ')'"); + case "(": MalList(read_seq(rdr, '(', ')')); + + // vector + case "]": throw("unexpected ']'"); + case "[": MalVector(read_seq(rdr, '[', ']')); + + // hashmap + case "}": throw("unexpected '}'"); + case "{": hash_map(read_seq(rdr, '{', '}')); + case _: read_atom(rdr); + } + } + + public static function read_str(str:String):MalType { + var tokens = tokenize(str); + if (tokens.length == 0) { throw(new BlankLine()); } + return read_form(new Reader(tokens)); + } +} diff --git a/impls/haxe/run b/impls/haxe/run index 6011b6c1e1..e44edbea1f 100755 --- a/impls/haxe/run +++ b/impls/haxe/run @@ -1,8 +1,8 @@ -#!/bin/bash -case ${haxe_MODE:-neko} in - neko) exec neko $(dirname $0)/${STEP:-stepA_mal}.n "${@}" ;; - python) exec python3 $(dirname $0)/${STEP:-stepA_mal}.py "${@}" ;; - js) exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" ;; - cpp) exec $(dirname $0)/cpp/${STEP:-stepA_mal} "${@}" ;; - *) echo "Invalid haxe_MODE: ${haxe_MODE}"; exit 2 ;; -esac +#!/bin/bash +case ${haxe_MODE:-neko} in + neko) exec neko $(dirname $0)/${STEP:-stepA_mal}.n "${@}" ;; + python) exec python3 $(dirname $0)/${STEP:-stepA_mal}.py "${@}" ;; + js) exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" ;; + cpp) exec $(dirname $0)/cpp/${STEP:-stepA_mal} "${@}" ;; + *) echo "Invalid haxe_MODE: ${haxe_MODE}"; exit 2 ;; +esac diff --git a/impls/haxe/tests/step5_tco.mal b/impls/haxe/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/haxe/tests/step5_tco.mal +++ b/impls/haxe/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/haxe/types/MalException.hx b/impls/haxe/types/MalException.hx index 8e3ff2f021..e53c23f1cc 100644 --- a/impls/haxe/types/MalException.hx +++ b/impls/haxe/types/MalException.hx @@ -1,10 +1,10 @@ -package types; - -import types.Types.MalType; - -class MalException { - public var obj:MalType = null; - public function new(obj:MalType) { - this.obj = obj; - } -} +package types; + +import types.Types.MalType; + +class MalException { + public var obj:MalType = null; + public function new(obj:MalType) { + this.obj = obj; + } +} diff --git a/impls/haxe/types/Types.hx b/impls/haxe/types/Types.hx index 669e29b466..f1a71da1d6 100644 --- a/impls/haxe/types/Types.hx +++ b/impls/haxe/types/Types.hx @@ -1,257 +1,257 @@ -package types; - -import env.Env; - -class MalAtomContainer { -} - -enum MalType { - MalNil; - MalTrue; - MalFalse; - MalInt(val:Int); - MalString(val:String); - MalSymbol(val:String); - MalList(val:Array); - MalVector(val:Array); - MalHashMap(val:Map); - MalAtom(val:{val:MalType}); - MalFunc(val:(Array)->MalType, - ast:MalType, - env:Env, - params:MalType, - ismacro:Bool, - meta:MalType); -} - -class Types { - public static var nil:MalType = MalNil; - - public static function _equal_Q(a:MalType, b:MalType) { - return switch [a, b] { - case [MalInt(va), MalInt(vb)]: va == vb; - case [MalString(va), MalString(vb)] | - [MalSymbol(va), MalSymbol(vb)]: va == vb; - case [MalList(la), MalList(lb)] | - [MalList(la), MalVector(lb)] | - [MalVector(la), MalList(lb)] | - [MalVector(la), MalVector(lb)]: - if (la.length != lb.length) { return false; } - for (i in 0...la.length) { - if (!_equal_Q(la[i], lb[i])) { - false; - } - } - true; - case [MalHashMap(ma), MalHashMap(mb)]: - var maks = ma.keys(), - mbks = mb.keys(), - malen = 0, - mblen = 0; - for (k in maks) { - malen += 1; - if ((!mb.exists(k)) || !_equal_Q(ma[k], mb[k])) { - return false; - } - } - for (k in mbks) { mblen += 1; } - if (malen != mblen) { return false; } - true; - case _: a == b; - } - } - - public static function _clone(a:MalType) { - return switch (a) { - case MalHashMap(m): - var new_m = new Map(); - for (k in m.keys()) { - new_m[k] = m[k]; - } - return new_m; - case _: throw "unsupported clone call"; - } - } - - public static function _fn_Q(x:MalType) { - return switch (x) { - case MalFunc(_,_,_,_,ismacro,_): !ismacro; - case _: false; - } - } - - public static function _macro_Q(x:MalType) { - return switch (x) { - case MalFunc(_,_,_,_,ismacro,_): ismacro; - case _: false; - } - } - - public static function nil_Q(x:MalType) { - return switch (x) { - case MalNil: true; - case _: false; - } - } - - public static function true_Q(x:MalType) { - return switch (x) { - case MalTrue: true; - case _: false; - } - } - - public static function false_Q(x:MalType) { - return switch (x) { - case MalFalse: true; - case _: false; - } - } - - public static function string_Q(x:MalType) { - return switch (x) { - case MalString(s): s.charAt(0) != "\x7f"; - case _: false; - } - } - - - public static function symbol_Q(x:MalType) { - return switch (x) { - case MalSymbol(_): true; - case _: false; - } - } - - public static function keyword_Q(x:MalType) { - return switch (x) { - case MalString(s): - s.charAt(0) == "\x7f"; - case _: false; - } - } - - public static function number_Q(x:MalType) { - return switch (x) { - case MalInt(_): true; - case _: false; - } - } - - - // Sequence operations - public static function list_Q(x:MalType) { - return switch (x) { - case MalList(_): true; - case _: false; - } - } - - public static function vector_Q(x:MalType) { - return switch (x) { - case MalVector(_): true; - case _: false; - } - } - - public static function first(seq:MalType) { - return switch (seq) { - case MalList(l) | MalVector(l): - if (l.length == 0) { nil; } - else { l[0]; } - case MalNil: MalNil; - case _: throw "first called on non-sequence"; - } - } - - public static function rest(seq:MalType) { - return switch (seq) { - case MalList(l) | MalVector(l): - if (l.length <= 1) { MalList([]); } - else { MalList(l.slice(1)); } - case MalNil: MalList([]); - case _: throw "rest called on non-sequence"; - } - } - - public static function _nth(seq:MalType, idx:Int) { - return switch (seq) { - case MalList(l) | MalVector(l): - if (l.length > idx) { - l[idx]; - } else { - throw "nth index out of bounds"; - } - case _: throw "nth called on non-sequence"; - } - } - - public static function _list(seq:MalType) { - return switch (seq) { - case MalList(l) | MalVector(l): l; - case _: throw "_array called on non-sequence"; - } - } - - public static function _map(hm:MalType) { - return switch (hm) { - case MalHashMap(m): m; - case _: throw "_map called on non-hash-map"; - } - } - - public static function last(seq:MalType) { - return switch (seq) { - case MalList(l) | MalVector(l): - if (l.length == 0) { nil; } - else { l[l.length-1]; } - case _: throw "last called on non-sequence"; - } - } - - public static function hash_map(kvs:Array) { - var m = new Map(); - return MalHashMap(assoc_BANG(m, kvs)); - } - - public static function assoc_BANG(m:Map, - kvs:Array) { - for (i in 0...kvs.length) { - if (i % 2 > 0) { continue; } - switch (kvs[i]) { - case MalString(k): - m[k] = kvs[i+1]; - case _: throw "invalid assoc! call"; - } - } - return m; - } - - public static function dissoc_BANG(m:Map, - ks:Array) { - for (i in 0...ks.length) { - switch (ks[i]) { - case MalString(k): - m.remove(k); - case _: throw "invalid dissoc! call"; - } - } - return m; - } - - public static function hash_map_Q(x:MalType) { - return switch (x) { - case MalHashMap(_): true; - case _: false; - } - } - - public static function atom_Q(x:MalType) { - return switch (x) { - case MalAtom(_): true; - case _: false; - } - } - -} - +package types; + +import env.Env; + +class MalAtomContainer { +} + +enum MalType { + MalNil; + MalTrue; + MalFalse; + MalInt(val:Int); + MalString(val:String); + MalSymbol(val:String); + MalList(val:Array); + MalVector(val:Array); + MalHashMap(val:Map); + MalAtom(val:{val:MalType}); + MalFunc(val:(Array)->MalType, + ast:MalType, + env:Env, + params:MalType, + ismacro:Bool, + meta:MalType); +} + +class Types { + public static var nil:MalType = MalNil; + + public static function _equal_Q(a:MalType, b:MalType) { + return switch [a, b] { + case [MalInt(va), MalInt(vb)]: va == vb; + case [MalString(va), MalString(vb)] | + [MalSymbol(va), MalSymbol(vb)]: va == vb; + case [MalList(la), MalList(lb)] | + [MalList(la), MalVector(lb)] | + [MalVector(la), MalList(lb)] | + [MalVector(la), MalVector(lb)]: + if (la.length != lb.length) { return false; } + for (i in 0...la.length) { + if (!_equal_Q(la[i], lb[i])) { + false; + } + } + true; + case [MalHashMap(ma), MalHashMap(mb)]: + var maks = ma.keys(), + mbks = mb.keys(), + malen = 0, + mblen = 0; + for (k in maks) { + malen += 1; + if ((!mb.exists(k)) || !_equal_Q(ma[k], mb[k])) { + return false; + } + } + for (k in mbks) { mblen += 1; } + if (malen != mblen) { return false; } + true; + case _: a == b; + } + } + + public static function _clone(a:MalType) { + return switch (a) { + case MalHashMap(m): + var new_m = new Map(); + for (k in m.keys()) { + new_m[k] = m[k]; + } + return new_m; + case _: throw "unsupported clone call"; + } + } + + public static function _fn_Q(x:MalType) { + return switch (x) { + case MalFunc(_,_,_,_,ismacro,_): !ismacro; + case _: false; + } + } + + public static function _macro_Q(x:MalType) { + return switch (x) { + case MalFunc(_,_,_,_,ismacro,_): ismacro; + case _: false; + } + } + + public static function nil_Q(x:MalType) { + return switch (x) { + case MalNil: true; + case _: false; + } + } + + public static function true_Q(x:MalType) { + return switch (x) { + case MalTrue: true; + case _: false; + } + } + + public static function false_Q(x:MalType) { + return switch (x) { + case MalFalse: true; + case _: false; + } + } + + public static function string_Q(x:MalType) { + return switch (x) { + case MalString(s): s.charAt(0) != "\x7f"; + case _: false; + } + } + + + public static function symbol_Q(x:MalType) { + return switch (x) { + case MalSymbol(_): true; + case _: false; + } + } + + public static function keyword_Q(x:MalType) { + return switch (x) { + case MalString(s): + s.charAt(0) == "\x7f"; + case _: false; + } + } + + public static function number_Q(x:MalType) { + return switch (x) { + case MalInt(_): true; + case _: false; + } + } + + + // Sequence operations + public static function list_Q(x:MalType) { + return switch (x) { + case MalList(_): true; + case _: false; + } + } + + public static function vector_Q(x:MalType) { + return switch (x) { + case MalVector(_): true; + case _: false; + } + } + + public static function first(seq:MalType) { + return switch (seq) { + case MalList(l) | MalVector(l): + if (l.length == 0) { nil; } + else { l[0]; } + case MalNil: MalNil; + case _: throw "first called on non-sequence"; + } + } + + public static function rest(seq:MalType) { + return switch (seq) { + case MalList(l) | MalVector(l): + if (l.length <= 1) { MalList([]); } + else { MalList(l.slice(1)); } + case MalNil: MalList([]); + case _: throw "rest called on non-sequence"; + } + } + + public static function _nth(seq:MalType, idx:Int) { + return switch (seq) { + case MalList(l) | MalVector(l): + if (l.length > idx) { + l[idx]; + } else { + throw "nth index out of bounds"; + } + case _: throw "nth called on non-sequence"; + } + } + + public static function _list(seq:MalType) { + return switch (seq) { + case MalList(l) | MalVector(l): l; + case _: throw "_array called on non-sequence"; + } + } + + public static function _map(hm:MalType) { + return switch (hm) { + case MalHashMap(m): m; + case _: throw "_map called on non-hash-map"; + } + } + + public static function last(seq:MalType) { + return switch (seq) { + case MalList(l) | MalVector(l): + if (l.length == 0) { nil; } + else { l[l.length-1]; } + case _: throw "last called on non-sequence"; + } + } + + public static function hash_map(kvs:Array) { + var m = new Map(); + return MalHashMap(assoc_BANG(m, kvs)); + } + + public static function assoc_BANG(m:Map, + kvs:Array) { + for (i in 0...kvs.length) { + if (i % 2 > 0) { continue; } + switch (kvs[i]) { + case MalString(k): + m[k] = kvs[i+1]; + case _: throw "invalid assoc! call"; + } + } + return m; + } + + public static function dissoc_BANG(m:Map, + ks:Array) { + for (i in 0...ks.length) { + switch (ks[i]) { + case MalString(k): + m.remove(k); + case _: throw "invalid dissoc! call"; + } + } + return m; + } + + public static function hash_map_Q(x:MalType) { + return switch (x) { + case MalHashMap(_): true; + case _: false; + } + } + + public static function atom_Q(x:MalType) { + return switch (x) { + case MalAtom(_): true; + case _: false; + } + } + +} + diff --git a/impls/hy/Dockerfile b/impls/hy/Dockerfile index 4d977ee8b2..af036fa695 100644 --- a/impls/hy/Dockerfile +++ b/impls/hy/Dockerfile @@ -1,28 +1,28 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Hy -RUN apt-get -y install python-pip && \ - pip install hy && \ - mkdir /.cache && \ - chmod uog+rwx /.cache +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Hy +RUN apt-get -y install python-pip && \ + pip install hy && \ + mkdir /.cache && \ + chmod uog+rwx /.cache diff --git a/impls/hy/Makefile b/impls/hy/Makefile index 47f487eba1..40f19dcf9a 100644 --- a/impls/hy/Makefile +++ b/impls/hy/Makefile @@ -1,7 +1,7 @@ -all: mal.hy - -mal.hy: stepA_mal.hy - cp $< $@ - -clean: - rm -f mal.hy *.pyc +all: mal.hy + +mal.hy: stepA_mal.hy + cp $< $@ + +clean: + rm -f mal.hy *.pyc diff --git a/impls/hy/core.hy b/impls/hy/core.hy index 79b063b42a..d6a54d2470 100644 --- a/impls/hy/core.hy +++ b/impls/hy/core.hy @@ -1,98 +1,98 @@ -(import [hy.models [HyKeyword :as Keyword HyString :as Str HySymbol :as Sym]]) -(import [copy [copy]]) -(import [time [time]]) -(import [mal_types [MalException Atom clone]]) -(import [reader [read-str]]) -(import [printer [pr-str]]) - -(defn sequential? [a] - (or (instance? tuple a) (instance? list a))) - -(defn equal [a b] - (if (and (sequential? a) (sequential? b) (= (len a) (len b))) - (every? (fn [[a b]] (equal a b)) (zip a b)) - - (and (instance? dict a) (instance? dict b) (= (.keys a) (.keys b))) - (every? (fn [k] (and (equal (get a k) (get b k)))) a) - - (= (type a) (type b)) - (= a b) - - False)) - -(def ns - {"=" equal - "throw" (fn [a] (raise (MalException a))) - - "nil?" none? - "true?" (fn [a] (and (instance? bool a) (= a True))) - "false?" (fn [a] (and (instance? bool a) (= a False))) - "number?" (fn [a] (and (not (instance? bool a)) (instance? int a))) - "string?" (fn [a] (and (string? a) (not (keyword? a)))) - "symbol" (fn [a] (Sym a)) - "symbol?" (fn [a] (instance? Sym a)) - "keyword" (fn [a] (Keyword (if (keyword? a) a (+ ":" a)))) - "keyword?" (fn [a] (keyword? a)) - "fn?" (fn [a] (and (callable a) (or (not (hasattr a "macro")) - (not a.macro)))) - "macro?" (fn [a] (and (callable a) (and (hasattr a "macro") a.macro))) - - "pr-str" (fn [&rest a] (Str (.join " " (map (fn [e] (pr-str e True)) a)))) - "str" (fn [&rest a] (Str (.join "" (map (fn [e] (pr-str e False)) a)))) - "prn" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e True)) a)))) - "println" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e False)) a)))) - "read-string" read-str - "readline" (fn [a] (Str (raw_input a))) - "slurp" (fn [a] (Str (-> a open .read))) - - "<" < - "<=" <= - ">" > - ">=" >= - "+" + - "-" - - "*" * - "/" (fn [a b] (int (/ a b))) - "time-ms" (fn [] (int (* 1000 (time)))) - - "list" (fn [&rest args] (tuple args)) - "list?" (fn [a] (instance? tuple a)) - "vector" (fn [&rest a] (list a)) - "vector?" (fn [a] (instance? list a)) - "hash-map" (fn [&rest a] (dict (partition a 2))) - "map?" (fn [a] (instance? dict a)) - "assoc" (fn [m &rest a] (setv m (copy m)) - (for [[k v] (partition a 2)] (assoc m k v)) m) - "dissoc" (fn [m &rest a] (setv m (copy m)) - (for [k a] (if (.has_key m k) (.pop m k))) m) - "get" (fn [m a] (if (and m (.has_key m a)) (get m a))) - "contains?" (fn [m a] (if (none? m) None (.has_key m a))) - "keys" (fn [m] (tuple (.keys m))) - "vals" (fn [m] (tuple (.values m))) - - "sequential?" sequential? - "cons" (fn [a b] (tuple (chain [a] b))) - "concat" (fn [&rest a] (tuple (apply chain a))) - "vec" (fn [a] (list a)) - "nth" (fn [a b] (get a b)) - "first" (fn [a] (if (none? a) None (first a))) - "rest" (fn [a] (if (none? a) (,) (tuple (rest a)))) - "empty?" empty? - "count" (fn [a] (if (none? a) 0 (len a))) - "apply" (fn [f &rest a] (apply f (+ (list (butlast a)) (list (last a))))) - "map" (fn [f a] (tuple (map f a))) - - "conj" (fn [a &rest xs] (if (instance? list a) (+ a (list xs)) - (tuple (+ (tuple (reversed xs)) a)))) - "seq" (fn [a] (if (or (none? a) (empty? a)) None - (string? a) (tuple (map Str a)) - (tuple a))) - - "meta" (fn [a] (if (hasattr a "meta") a.meta)) - "with-meta" (fn [a b] (setv a (clone a)) (setv a.meta b) a) - "atom" (fn [a] (Atom a)) - "atom?" (fn [a] (instance? Atom a)) - "deref" (fn [a] a.val) - "reset!" (fn [a b] (do (setv a.val b) b)) - "swap!" (fn [a f &rest xs] (do (setv a.val (apply f (+ (, a.val) xs))) a.val)) - }) +(import [hy.models [HyKeyword :as Keyword HyString :as Str HySymbol :as Sym]]) +(import [copy [copy]]) +(import [time [time]]) +(import [mal_types [MalException Atom clone]]) +(import [reader [read-str]]) +(import [printer [pr-str]]) + +(defn sequential? [a] + (or (instance? tuple a) (instance? list a))) + +(defn equal [a b] + (if (and (sequential? a) (sequential? b) (= (len a) (len b))) + (every? (fn [[a b]] (equal a b)) (zip a b)) + + (and (instance? dict a) (instance? dict b) (= (.keys a) (.keys b))) + (every? (fn [k] (and (equal (get a k) (get b k)))) a) + + (= (type a) (type b)) + (= a b) + + False)) + +(def ns + {"=" equal + "throw" (fn [a] (raise (MalException a))) + + "nil?" none? + "true?" (fn [a] (and (instance? bool a) (= a True))) + "false?" (fn [a] (and (instance? bool a) (= a False))) + "number?" (fn [a] (and (not (instance? bool a)) (instance? int a))) + "string?" (fn [a] (and (string? a) (not (keyword? a)))) + "symbol" (fn [a] (Sym a)) + "symbol?" (fn [a] (instance? Sym a)) + "keyword" (fn [a] (Keyword (if (keyword? a) a (+ ":" a)))) + "keyword?" (fn [a] (keyword? a)) + "fn?" (fn [a] (and (callable a) (or (not (hasattr a "macro")) + (not a.macro)))) + "macro?" (fn [a] (and (callable a) (and (hasattr a "macro") a.macro))) + + "pr-str" (fn [&rest a] (Str (.join " " (map (fn [e] (pr-str e True)) a)))) + "str" (fn [&rest a] (Str (.join "" (map (fn [e] (pr-str e False)) a)))) + "prn" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e True)) a)))) + "println" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e False)) a)))) + "read-string" read-str + "readline" (fn [a] (Str (raw_input a))) + "slurp" (fn [a] (Str (-> a open .read))) + + "<" < + "<=" <= + ">" > + ">=" >= + "+" + + "-" - + "*" * + "/" (fn [a b] (int (/ a b))) + "time-ms" (fn [] (int (* 1000 (time)))) + + "list" (fn [&rest args] (tuple args)) + "list?" (fn [a] (instance? tuple a)) + "vector" (fn [&rest a] (list a)) + "vector?" (fn [a] (instance? list a)) + "hash-map" (fn [&rest a] (dict (partition a 2))) + "map?" (fn [a] (instance? dict a)) + "assoc" (fn [m &rest a] (setv m (copy m)) + (for [[k v] (partition a 2)] (assoc m k v)) m) + "dissoc" (fn [m &rest a] (setv m (copy m)) + (for [k a] (if (.has_key m k) (.pop m k))) m) + "get" (fn [m a] (if (and m (.has_key m a)) (get m a))) + "contains?" (fn [m a] (if (none? m) None (.has_key m a))) + "keys" (fn [m] (tuple (.keys m))) + "vals" (fn [m] (tuple (.values m))) + + "sequential?" sequential? + "cons" (fn [a b] (tuple (chain [a] b))) + "concat" (fn [&rest a] (tuple (apply chain a))) + "vec" (fn [a] (list a)) + "nth" (fn [a b] (get a b)) + "first" (fn [a] (if (none? a) None (first a))) + "rest" (fn [a] (if (none? a) (,) (tuple (rest a)))) + "empty?" empty? + "count" (fn [a] (if (none? a) 0 (len a))) + "apply" (fn [f &rest a] (apply f (+ (list (butlast a)) (list (last a))))) + "map" (fn [f a] (tuple (map f a))) + + "conj" (fn [a &rest xs] (if (instance? list a) (+ a (list xs)) + (tuple (+ (tuple (reversed xs)) a)))) + "seq" (fn [a] (if (or (none? a) (empty? a)) None + (string? a) (tuple (map Str a)) + (tuple a))) + + "meta" (fn [a] (if (hasattr a "meta") a.meta)) + "with-meta" (fn [a b] (setv a (clone a)) (setv a.meta b) a) + "atom" (fn [a] (Atom a)) + "atom?" (fn [a] (instance? Atom a)) + "deref" (fn [a] a.val) + "reset!" (fn [a b] (do (setv a.val b) b)) + "swap!" (fn [a f &rest xs] (do (setv a.val (apply f (+ (, a.val) xs))) a.val)) + }) diff --git a/impls/hy/env.hy b/impls/hy/env.hy index 02161704e4..a1fe51973f 100644 --- a/impls/hy/env.hy +++ b/impls/hy/env.hy @@ -1,31 +1,31 @@ -(import [hy.models [HySymbol :as Sym]]) - -(defn env-new [&optional [outer None] [binds []] [exprs []]] - (setv env {:outer outer}) - (while binds - (if - (= (Sym "&") (first binds)) - (do (assoc env (nth binds 1) (tuple exprs)) (break)) - - True - (do (assoc env (first binds) (first exprs)) - (setv binds (list (rest binds)) - exprs (list (rest exprs)))))) - env) - -(defn env-find [env k] - (if - (.has_key env k) env - (get env ':outer) (env-find (get env ':outer) k) - True None)) - -(defn env-get [env k] - (setv e (env-find env k)) - (if-not e - (raise (Exception (+ "'" k "' not found")))) - (get e k)) - -(defn env-set [env k v] - (assoc env k v) - v) - +(import [hy.models [HySymbol :as Sym]]) + +(defn env-new [&optional [outer None] [binds []] [exprs []]] + (setv env {:outer outer}) + (while binds + (if + (= (Sym "&") (first binds)) + (do (assoc env (nth binds 1) (tuple exprs)) (break)) + + True + (do (assoc env (first binds) (first exprs)) + (setv binds (list (rest binds)) + exprs (list (rest exprs)))))) + env) + +(defn env-find [env k] + (if + (.has_key env k) env + (get env ':outer) (env-find (get env ':outer) k) + True None)) + +(defn env-get [env k] + (setv e (env-find env k)) + (if-not e + (raise (Exception (+ "'" k "' not found")))) + (get e k)) + +(defn env-set [env k v] + (assoc env k v) + v) + diff --git a/impls/hy/mal_types.hy b/impls/hy/mal_types.hy index 4a30e6fdbd..654a2062c6 100644 --- a/impls/hy/mal_types.hy +++ b/impls/hy/mal_types.hy @@ -1,15 +1,15 @@ -(import [types :as pytypes]) - -(defclass MalException [Exception] - (defn --init-- [self val] (setv self.val val))) - -(defclass Atom [] - (defn --init-- [self val] (setv self.val val))) - -(defn clone [obj] - (if (= (type obj) pytypes.FunctionType) - (pytypes.FunctionType obj.__code__ obj.__globals__ - :name obj.__name__ - :argdefs obj.__defaults__ - :closure obj.__closure__) - obj)) +(import [types :as pytypes]) + +(defclass MalException [Exception] + (defn --init-- [self val] (setv self.val val))) + +(defclass Atom [] + (defn --init-- [self val] (setv self.val val))) + +(defn clone [obj] + (if (= (type obj) pytypes.FunctionType) + (pytypes.FunctionType obj.__code__ obj.__globals__ + :name obj.__name__ + :argdefs obj.__defaults__ + :closure obj.__closure__) + obj)) diff --git a/impls/hy/printer.hy b/impls/hy/printer.hy index 55809fc195..c8c553de7a 100644 --- a/impls/hy/printer.hy +++ b/impls/hy/printer.hy @@ -1,25 +1,25 @@ -(import [hy.models [HyInteger :as Int HyKeyword :as Keyword - HyString :as Str HySymbol :as Sym]]) -(import [mal_types [Atom]]) - -(defn escape [s] - (-> (str s) (.replace "\\" "\\\\") - (.replace "\"" "\\\"") - (.replace "\n" "\\n"))) - -(defn pr-str [obj &optional [print-readably True]] - (setv _r print-readably - t (type obj)) - (Str - (if - (none? obj) "nil" - (= t bool) (if obj "true" "false") - (= t Keyword) (+ ":" (name obj)) - (= t Str) (if _r (+ "\"" (escape obj) "\"") obj) - (= t tuple) (+ "(" (.join " " (map (fn [x] (pr-str x _r)) obj)) ")") - (= t list) (+ "[" (.join " " (map (fn [x] (pr-str x _r)) obj)) "]") - (= t dict) (+ "{" (.join " " (map (fn [k] (+ (pr-str k _r) " " - (pr-str (get obj k) _r))) - obj)) "}") - (instance? Atom obj) (+ "(atom " (pr-str obj.val _r) ")") - True (str obj)))) +(import [hy.models [HyInteger :as Int HyKeyword :as Keyword + HyString :as Str HySymbol :as Sym]]) +(import [mal_types [Atom]]) + +(defn escape [s] + (-> (str s) (.replace "\\" "\\\\") + (.replace "\"" "\\\"") + (.replace "\n" "\\n"))) + +(defn pr-str [obj &optional [print-readably True]] + (setv _r print-readably + t (type obj)) + (Str + (if + (none? obj) "nil" + (= t bool) (if obj "true" "false") + (= t Keyword) (+ ":" (name obj)) + (= t Str) (if _r (+ "\"" (escape obj) "\"") obj) + (= t tuple) (+ "(" (.join " " (map (fn [x] (pr-str x _r)) obj)) ")") + (= t list) (+ "[" (.join " " (map (fn [x] (pr-str x _r)) obj)) "]") + (= t dict) (+ "{" (.join " " (map (fn [k] (+ (pr-str k _r) " " + (pr-str (get obj k) _r))) + obj)) "}") + (instance? Atom obj) (+ "(atom " (pr-str obj.val _r) ")") + True (str obj)))) diff --git a/impls/hy/reader.hy b/impls/hy/reader.hy index 26bc5fcd3d..cab7f34f17 100644 --- a/impls/hy/reader.hy +++ b/impls/hy/reader.hy @@ -1,96 +1,96 @@ -(import [hy.models [HyInteger :as Int HyKeyword :as Keyword - HyString :as Str HySymbol :as Sym]] - [re]) - -(defclass Blank [Exception]) - -(defclass Reader [] - (defn --init-- [self tokens &optional [position 0]] - (setv self.tokens tokens self.position position)) - (defn next [self] - (setv self.position (+ 1 self.position)) - (get self.tokens (- self.position 1))) - (defn peek [self] - (if (> (len self.tokens) self.position) - (get self.tokens self.position) - None))) - -(def tok-re (.compile re "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}()'\"`@,;]+)")) -(def int-re (.compile re "-?[0-9]+$")) -(def str-re (.compile re "^\"(?:[\\\\].|[^\\\\\"])*\"$")) -(def str-bad-re (.compile re "^\".*$")) - -(defn tokenize [str] - (list-comp - t - (t (.findall re tok-re str)) - (!= (get t 0) ";"))) - -(defn unescape [s] - (-> s (.replace "\\\\" "\u029e") - (.replace "\\\"" "\"") - (.replace "\\n" "\n") - (.replace "\u029e" "\\"))) - -(defn read-atom [rdr] - (setv token (.next rdr)) - (if - (.match re int-re token) (int token) - (.match re str-re token) (Str (unescape (cut token 1 -1))) - (.match re str-bad-re token) (raise (Exception "expected '\"', got EOF")) - (= ":" (get token 0)) (Keyword token) - (= "nil" token) None - (= "true" token) True - (= "false" token) False - True (Sym token))) - -(defn read-seq [rdr &optional [start "("] [end ")"]] - (setv ast (list) - token (.next rdr)) - (if (!= token start) - (raise (Exception (+ "expected '" start "'"))) - (do - (setv token (.peek rdr)) - (while (!= token end) - (if (not token) (raise (Exception (+ "expected '" end - ", got EOF")))) - (.append ast (read-form rdr)) - (setv token (.peek rdr))) - (.next rdr) - ast))) - -(defn read-form [rdr] - (setv token (.peek rdr)) - (if - (= ";" (get token 0)) (.next rdr) - - (= "'" token) (do (.next rdr) - (tuple [(Sym "quote") (read-form rdr)])) - (= "`" token) (do (.next rdr) - (tuple [(Sym "quasiquote") (read-form rdr)])) - (= "~" token) (do (.next rdr) - (tuple [(Sym "unquote") (read-form rdr)])) - (= "~@" token) (do (.next rdr) - (tuple [(Sym "splice-unquote") - (read-form rdr)])) - (= "^" token) (do (.next rdr) - (setv meta (read-form rdr)) - (tuple [(Sym "with-meta") (read-form rdr) meta])) - (= "@" token) (do (.next rdr) - (tuple [(Sym "deref") (read-form rdr)])) - - (= ")" token) (raise (Exception "unexpected ')'")) - (= "(" token) (tuple (read-seq rdr "(" ")")) - - (= "]" token) (raise (Exception "unexpected ')'")) - (= "[" token) (read-seq rdr "[" "]") - - (= "}" token) (raise (Exception "unexpected '}'")) - (= "{" token) (dict (partition (read-seq rdr "{" "}") 2)) - - True (read-atom rdr))) - -(defn read-str [str] - (setv tokens (tokenize str)) - (if (= 0 (len tokens)) (raise (Blank "blank line"))) - (read-form (Reader tokens))) +(import [hy.models [HyInteger :as Int HyKeyword :as Keyword + HyString :as Str HySymbol :as Sym]] + [re]) + +(defclass Blank [Exception]) + +(defclass Reader [] + (defn --init-- [self tokens &optional [position 0]] + (setv self.tokens tokens self.position position)) + (defn next [self] + (setv self.position (+ 1 self.position)) + (get self.tokens (- self.position 1))) + (defn peek [self] + (if (> (len self.tokens) self.position) + (get self.tokens self.position) + None))) + +(def tok-re (.compile re "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}()'\"`@,;]+)")) +(def int-re (.compile re "-?[0-9]+$")) +(def str-re (.compile re "^\"(?:[\\\\].|[^\\\\\"])*\"$")) +(def str-bad-re (.compile re "^\".*$")) + +(defn tokenize [str] + (list-comp + t + (t (.findall re tok-re str)) + (!= (get t 0) ";"))) + +(defn unescape [s] + (-> s (.replace "\\\\" "\u029e") + (.replace "\\\"" "\"") + (.replace "\\n" "\n") + (.replace "\u029e" "\\"))) + +(defn read-atom [rdr] + (setv token (.next rdr)) + (if + (.match re int-re token) (int token) + (.match re str-re token) (Str (unescape (cut token 1 -1))) + (.match re str-bad-re token) (raise (Exception "expected '\"', got EOF")) + (= ":" (get token 0)) (Keyword token) + (= "nil" token) None + (= "true" token) True + (= "false" token) False + True (Sym token))) + +(defn read-seq [rdr &optional [start "("] [end ")"]] + (setv ast (list) + token (.next rdr)) + (if (!= token start) + (raise (Exception (+ "expected '" start "'"))) + (do + (setv token (.peek rdr)) + (while (!= token end) + (if (not token) (raise (Exception (+ "expected '" end + ", got EOF")))) + (.append ast (read-form rdr)) + (setv token (.peek rdr))) + (.next rdr) + ast))) + +(defn read-form [rdr] + (setv token (.peek rdr)) + (if + (= ";" (get token 0)) (.next rdr) + + (= "'" token) (do (.next rdr) + (tuple [(Sym "quote") (read-form rdr)])) + (= "`" token) (do (.next rdr) + (tuple [(Sym "quasiquote") (read-form rdr)])) + (= "~" token) (do (.next rdr) + (tuple [(Sym "unquote") (read-form rdr)])) + (= "~@" token) (do (.next rdr) + (tuple [(Sym "splice-unquote") + (read-form rdr)])) + (= "^" token) (do (.next rdr) + (setv meta (read-form rdr)) + (tuple [(Sym "with-meta") (read-form rdr) meta])) + (= "@" token) (do (.next rdr) + (tuple [(Sym "deref") (read-form rdr)])) + + (= ")" token) (raise (Exception "unexpected ')'")) + (= "(" token) (tuple (read-seq rdr "(" ")")) + + (= "]" token) (raise (Exception "unexpected ')'")) + (= "[" token) (read-seq rdr "[" "]") + + (= "}" token) (raise (Exception "unexpected '}'")) + (= "{" token) (dict (partition (read-seq rdr "{" "}") 2)) + + True (read-atom rdr))) + +(defn read-str [str] + (setv tokens (tokenize str)) + (if (= 0 (len tokens)) (raise (Blank "blank line"))) + (read-form (Reader tokens))) diff --git a/impls/hy/run b/impls/hy/run index 97f856223b..c55b99e3f0 100755 --- a/impls/hy/run +++ b/impls/hy/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal}.hy "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal}.hy "${@}" diff --git a/impls/hy/step0_repl.hy b/impls/hy/step0_repl.hy index d651bbf0ef..f40f46d97f 100755 --- a/impls/hy/step0_repl.hy +++ b/impls/hy/step0_repl.hy @@ -1,22 +1,22 @@ -#!/usr/bin/env hy - -(defn READ [str] - str) - -(defn EVAL [ast env] - ast) - -(defn PRINT [exp] - exp) - -(defn REP [str] - (PRINT (EVAL (READ str) {}))) - -(defmain [&rest args] - ;; indented to match later steps - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break))))) +#!/usr/bin/env hy + +(defn READ [str] + str) + +(defn EVAL [ast env] + ast) + +(defn PRINT [exp] + exp) + +(defn REP [str] + (PRINT (EVAL (READ str) {}))) + +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break))))) diff --git a/impls/hy/step1_read_print.hy b/impls/hy/step1_read_print.hy index ba8670e14b..6c1a0d17bb 100755 --- a/impls/hy/step1_read_print.hy +++ b/impls/hy/step1_read_print.hy @@ -1,30 +1,30 @@ -#!/usr/bin/env hy - -(import sys traceback) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) - -(defn READ [str] - (read-str str)) - -(defn EVAL [ast env] - ast) - -(defn PRINT [exp] - (pr-str exp True)) - -(defn REP [str] - (PRINT (EVAL (READ str) {}))) - -(defmain [&rest args] - ;; indented to match later steps - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))) +#!/usr/bin/env hy + +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) + +(defn READ [str] + (read-str str)) + +(defn EVAL [ast env] + ast) + +(defn PRINT [exp] + (pr-str exp True)) + +(defn REP [str] + (PRINT (EVAL (READ str) {}))) + +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))) diff --git a/impls/hy/step2_eval.hy b/impls/hy/step2_eval.hy index 80894b1ffb..32cbe10e00 100755 --- a/impls/hy/step2_eval.hy +++ b/impls/hy/step2_eval.hy @@ -1,64 +1,64 @@ -#!/usr/bin/env hy - -(import sys traceback) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) - -;; read -(defn READ [str] - (read-str str)) - -;; eval -(defn eval-ast [ast env] - (if - (symbol? ast) (if (.has_key env ast) (get env ast) - (raise (Exception (+ ast " not found")))) - (instance? dict ast) (dict (map (fn [k] - [k (EVAL (get ast k) env)]) - ast)) - (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) - (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) - True ast)) - -(defn EVAL [ast env] - ;; indented to match later steps - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (if - (empty? ast) - ast - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (apply f args))))) - -;; print -(defn PRINT [exp] - (pr-str exp True)) - -;; repl -(def repl-env {'+ + - '- - - '* * - '/ (fn [a b] (int (/ a b)))}) - -(defn REP [str] - (PRINT (EVAL (READ str) repl-env))) - -(defmain [&rest args] - ;; indented to match later steps - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))) +#!/usr/bin/env hy + +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + (if + (symbol? ast) (if (.has_key env ast) (get env ast) + (raise (Exception (+ ast " not found")))) + (instance? dict ast) (dict (map (fn [k] + [k (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;; indented to match later steps + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (if + (empty? ast) + ast + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (apply f args))))) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env {'+ + + '- - + '* * + '/ (fn [a b] (int (/ a b)))}) + +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))) diff --git a/impls/hy/step3_env.hy b/impls/hy/step3_env.hy index d46a87ba6e..d6763ee1e9 100755 --- a/impls/hy/step3_env.hy +++ b/impls/hy/step3_env.hy @@ -1,80 +1,80 @@ -#!/usr/bin/env hy - -(import [hy.models [HySymbol :as Sym]]) -(import sys traceback) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) -(import [env [env-new env-get env-set]]) - -;; read -(defn READ [str] - (read-str str)) - -;; eval -(defn eval-ast [ast env] - ;;(print "eval-ast:" ast (type ast)) - (if - (symbol? ast) (env-get env ast) - (instance? dict ast) (dict (map (fn [k] - [k (EVAL (get ast k) env)]) - ast)) - (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) - (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) - True ast)) - -(defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast)) - ;; indented to match later steps - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (EVAL a2 env)) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (apply f args)))))) - -;; print -(defn PRINT [exp] - (pr-str exp True)) - -;; repl -(def repl-env (env-new)) -(defn REP [str] - (PRINT (EVAL (READ str) repl-env))) - -(env-set repl-env '+ +) -(env-set repl-env '- -) -(env-set repl-env '* *) -(env-set repl-env '/ /) - -(defmain [&rest args] - ;; indented to match later steps - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (print (.join "" (apply traceback.format_exception - (.exc_info sys)))))))) +#!/usr/bin/env hy + +(import [hy.models [HySymbol :as Sym]]) +(import sys traceback) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [k (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast)) + ;; indented to match later steps + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (EVAL a2 env)) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (apply f args)))))) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +(env-set repl-env '+ +) +(env-set repl-env '- -) +(env-set repl-env '* *) +(env-set repl-env '/ /) + +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (print (.join "" (apply traceback.format_exception + (.exc_info sys)))))))) diff --git a/impls/hy/step4_if_fn_do.hy b/impls/hy/step4_if_fn_do.hy index dbe574cd5c..370c640a76 100755 --- a/impls/hy/step4_if_fn_do.hy +++ b/impls/hy/step4_if_fn_do.hy @@ -1,104 +1,104 @@ -#!/usr/bin/env hy - -(import [hy.models [HySymbol :as Sym]]) -(import sys traceback) -(import [mal_types [MalException]]) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) -(import [env [env-new env-get env-set]]) -(import core) - -;; read -(defn READ [str] - (read-str str)) - -;; eval -(defn eval-ast [ast env] - ;;(print "eval-ast:" ast (type ast)) - (if - (symbol? ast) (env-get env ast) - (instance? dict ast) (dict (map (fn [k] - [k (EVAL (get ast k) env)]) - ast)) - (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) - (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) - True ast)) - -(defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast)) - ;; indented to match later steps - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (EVAL a2 env)) - - (= (Sym "do") a0) - (last (eval-ast (list (rest ast)) env)) - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (EVAL (nth ast 3) env) - None) - (EVAL a2 env))) - - (= (Sym "fn*") a0) - (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (apply f args)))))) - -;; print -(defn PRINT [exp] - (pr-str exp True)) - -;; repl -(def repl-env (env-new)) -(defn REP [str] - (PRINT (EVAL (READ str) repl-env))) - -;; core.hy: defined using Hy -(for [k core.ns] - (env-set repl-env (Sym k) (get core.ns k))) - -;; core.mal: defined using the language itself -(REP "(def! not (fn* [a] (if a false true)))") - -(defmain [&rest args] - ;; indented to match later steps - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (setv msg (.rstrip (.join "" (apply traceback.format_exception - (.exc_info sys))))) - (if (instance? MalException e) - (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) - (print msg))))) +#!/usr/bin/env hy + +(import [hy.models [HySymbol :as Sym]]) +(import sys traceback) +(import [mal_types [MalException]]) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [k (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast)) + ;; indented to match later steps + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (EVAL a2 env)) + + (= (Sym "do") a0) + (last (eval-ast (list (rest ast)) env)) + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (EVAL (nth ast 3) env) + None) + (EVAL a2 env))) + + (= (Sym "fn*") a0) + (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (apply f args)))))) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") + +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))) diff --git a/impls/hy/step5_tco.hy b/impls/hy/step5_tco.hy index 352732326f..037f6e6586 100755 --- a/impls/hy/step5_tco.hy +++ b/impls/hy/step5_tco.hy @@ -1,121 +1,121 @@ -#!/usr/bin/env hy - -(import [hy.models [HySymbol :as Sym]]) -(import sys traceback) -(import [mal_types [MalException]]) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) -(import [env [env-new env-get env-set]]) -(import core) - -;; read -(defn READ [str] - (read-str str)) - -;; eval -(defn eval-ast [ast env] - ;;(print "eval-ast:" ast (type ast)) - (if - (symbol? ast) (env-get env ast) - (instance? dict ast) (dict (map (fn [k] - [k (EVAL (get ast k) env)]) - ast)) - (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) - (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) - True ast)) - -(defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast)) - ;; indented to match later steps - (setv res None) - (while True - (setv res - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - None) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (do - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1) - func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (apply f args))))))) - (break)) - res) - -;; print -(defn PRINT [exp] - (pr-str exp True)) - -;; repl -(def repl-env (env-new)) -(defn REP [str] - (PRINT (EVAL (READ str) repl-env))) - -;; core.hy: defined using Hy -(for [k core.ns] - (env-set repl-env (Sym k) (get core.ns k))) - -;; core.mal: defined using the language itself -(REP "(def! not (fn* [a] (if a false true)))") - -(defmain [&rest args] - ;; indented to match later steps - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (setv msg (.rstrip (.join "" (apply traceback.format_exception - (.exc_info sys))))) - (if (instance? MalException e) - (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) - (print msg))))) +#!/usr/bin/env hy + +(import [hy.models [HySymbol :as Sym]]) +(import sys traceback) +(import [mal_types [MalException]]) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [k (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast)) + ;; indented to match later steps + (setv res None) + (while True + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") + +(defmain [&rest args] + ;; indented to match later steps + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))) diff --git a/impls/hy/step6_file.hy b/impls/hy/step6_file.hy index f5cb1a4cba..fcd1941676 100755 --- a/impls/hy/step6_file.hy +++ b/impls/hy/step6_file.hy @@ -1,128 +1,128 @@ -#!/usr/bin/env hy - -(import [hy.models [HyString :as Str HySymbol :as Sym]]) -(import sys traceback) -(import [mal_types [MalException]]) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) -(import [env [env-new env-get env-set]]) -(import core) - -;; read -(defn READ [str] - (read-str str)) - -;; eval -(defn eval-ast [ast env] - ;;(print "eval-ast:" ast (type ast)) - (if - (symbol? ast) (env-get env ast) - (instance? dict ast) (dict (map (fn [k] - [k (EVAL (get ast k) env)]) - ast)) - (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) - (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) - True ast)) - -(defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) - ;; indented to match later steps - (setv res None) - (while True - (setv res - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - None) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (do - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1) - func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (apply f args))))))) - (break)) - res) - -;; print -(defn PRINT [exp] - (pr-str exp True)) - -;; repl -(def repl-env (env-new)) -(defn REP [str] - (PRINT (EVAL (READ str) repl-env))) - -;; core.hy: defined using Hy -(for [k core.ns] - (env-set repl-env (Sym k) (get core.ns k))) -(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (, )) - -;; core.mal: defined using the language itself -(REP "(def! not (fn* [a] (if a false true)))") -(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(defmain [&rest args] - (if (>= (len args) 2) - (do - (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) - (REP (+ "(load-file \"" (get args 1) "\")"))) - (do - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (setv msg (.rstrip (.join "" (apply traceback.format_exception - (.exc_info sys))))) - (if (instance? MalException e) - (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) - (print msg))))))) +#!/usr/bin/env hy + +(import [hy.models [HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [mal_types [MalException]]) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [k (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + ;; indented to match later steps + (setv res None) + (while True + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (, )) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/impls/hy/step7_quote.hy b/impls/hy/step7_quote.hy index 247d59af3a..97d5b45e2b 100755 --- a/impls/hy/step7_quote.hy +++ b/impls/hy/step7_quote.hy @@ -1,155 +1,155 @@ -#!/usr/bin/env hy - -(import [hy.models [HyString :as Str HySymbol :as Sym]]) -(import sys traceback) -(import [mal_types [MalException]]) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) -(import [env [env-new env-get env-set]]) -(import core) - -;; read -(defn READ [str] - (read-str str)) - -;; eval -(defn qq-loop [elt acc] - (if (and (instance? tuple elt) - (= (first elt) (Sym "splice-unquote"))) - (tuple [(Sym "concat") (get elt 1) acc]) - (tuple [(Sym "cons") (QUASIQUOTE elt) acc]))) -(defn qq-foldr [xs] - (if (empty? xs) - (,) - (qq-loop (first xs) (qq-foldr (tuple (rest xs)))))) -(defn QUASIQUOTE [ast] - (if - (instance? list ast) (tuple [(Sym "vec") (qq-foldr ast)]) - (symbol? ast) (tuple [(Sym "quote") ast]) - (instance? dict ast) (tuple [(Sym "quote") ast]) - (not (instance? tuple ast)) ast - (= (first ast) (Sym "unquote")) (get ast 1) - True (qq-foldr ast))) - -(defn eval-ast [ast env] - ;;(print "eval-ast:" ast (type ast)) - (if - (symbol? ast) (env-get env ast) - (instance? dict ast) (dict (map (fn [k] - [k (EVAL (get ast k) env)]) - ast)) - (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) - (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) - True ast)) - -(defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) - ;; indented to match later steps - (setv res None) - (while True - (setv res - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "quote") a0) - a1 - - (= (Sym "quasiquoteexpand") a0) - (QUASIQUOTE a1) - - (= (Sym "quasiquote") a0) - (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - None) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (do - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1) - func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (apply f args))))))) - (break)) - res) - -;; print -(defn PRINT [exp] - (pr-str exp True)) - -;; repl -(def repl-env (env-new)) -(defn REP [str] - (PRINT (EVAL (READ str) repl-env))) - -;; core.hy: defined using Hy -(for [k core.ns] - (env-set repl-env (Sym k) (get core.ns k))) -(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (, )) - -;; core.mal: defined using the language itself -(REP "(def! not (fn* [a] (if a false true)))") -(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(defmain [&rest args] - (if (>= (len args) 2) - (do - (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) - (REP (+ "(load-file \"" (get args 1) "\")"))) - (do - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (setv msg (.rstrip (.join "" (apply traceback.format_exception - (.exc_info sys))))) - (if (instance? MalException e) - (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) - (print msg))))))) +#!/usr/bin/env hy + +(import [hy.models [HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [mal_types [MalException]]) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn qq-loop [elt acc] + (if (and (instance? tuple elt) + (= (first elt) (Sym "splice-unquote"))) + (tuple [(Sym "concat") (get elt 1) acc]) + (tuple [(Sym "cons") (QUASIQUOTE elt) acc]))) +(defn qq-foldr [xs] + (if (empty? xs) + (,) + (qq-loop (first xs) (qq-foldr (tuple (rest xs)))))) +(defn QUASIQUOTE [ast] + (if + (instance? list ast) (tuple [(Sym "vec") (qq-foldr ast)]) + (symbol? ast) (tuple [(Sym "quote") ast]) + (instance? dict ast) (tuple [(Sym "quote") ast]) + (not (instance? tuple ast)) ast + (= (first ast) (Sym "unquote")) (get ast 1) + True (qq-foldr ast))) + +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [k (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + ;; indented to match later steps + (setv res None) + (while True + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + a1 + + (= (Sym "quasiquoteexpand") a0) + (QUASIQUOTE a1) + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (, )) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/impls/hy/step8_macros.hy b/impls/hy/step8_macros.hy index bd9898db9a..699f50f77b 100755 --- a/impls/hy/step8_macros.hy +++ b/impls/hy/step8_macros.hy @@ -1,184 +1,184 @@ -#!/usr/bin/env hy - -(import [hy.models [HyString :as Str HySymbol :as Sym]]) -(import sys traceback) -(import [mal_types [MalException]]) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) -(import [env [env-new env-get env-set env-find]]) -(import core) - -;; read -(defn READ [str] - (read-str str)) - -;; eval -(defn qq-loop [elt acc] - (if (and (instance? tuple elt) - (= (first elt) (Sym "splice-unquote"))) - (tuple [(Sym "concat") (get elt 1) acc]) - (tuple [(Sym "cons") (QUASIQUOTE elt) acc]))) -(defn qq-foldr [xs] - (if (empty? xs) - (,) - (qq-loop (first xs) (qq-foldr (tuple (rest xs)))))) -(defn QUASIQUOTE [ast] - (if - (instance? list ast) (tuple [(Sym "vec") (qq-foldr ast)]) - (symbol? ast) (tuple [(Sym "quote") ast]) - (instance? dict ast) (tuple [(Sym "quote") ast]) - (not (instance? tuple ast)) ast - (= (first ast) (Sym "unquote")) (get ast 1) - True (qq-foldr ast))) - -(defn macro? [ast env] - (when (and (coll? ast) - (symbol? (first ast)) - (env-find env (first ast))) - (setv mac (env-get env (first ast))) - (and (hasattr mac "macro") - mac.macro))) - -(defn macroexpand [ast env] - (while (macro? ast env) - (setv mac (env-get env (first ast)) - ast (apply mac (tuple (rest ast))))) - ast) - - - -(defn eval-ast [ast env] - ;;(print "eval-ast:" ast (type ast)) - (if - (symbol? ast) (env-get env ast) - (instance? dict ast) (dict (map (fn [k] - [k (EVAL (get ast k) env)]) - ast)) - (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) - (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) - True ast)) - -(defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) - (setv res None) - (while True - (setv res - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (do - (setv ast (macroexpand ast env)) - (if (not (instance? tuple ast)) - (eval-ast ast env) - - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "quote") a0) - a1 - - (= (Sym "quasiquoteexpand") a0) - (QUASIQUOTE a1) - - (= (Sym "quasiquote") a0) - (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - - (= (Sym "defmacro!") a0) - (do (setv func (EVAL a2 env) - func.macro True) - (env-set env a1 func)) - - (= (Sym "macroexpand") a0) - (macroexpand a1 env) - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - None) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (do - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1) - func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (apply f args))))))))) - (break)) - res) - -;; print -(defn PRINT [exp] - (pr-str exp True)) - -;; repl -(def repl-env (env-new)) -(defn REP [str] - (PRINT (EVAL (READ str) repl-env))) - -;; core.hy: defined using Hy -(for [k core.ns] - (env-set repl-env (Sym k) (get core.ns k))) -(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (, )) - -;; core.mal: defined using the language itself -(REP "(def! not (fn* [a] (if a false true)))") -(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(defmain [&rest args] - (if (>= (len args) 2) - (do - (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) - (REP (+ "(load-file \"" (get args 1) "\")"))) - (do - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (setv msg (.rstrip (.join "" (apply traceback.format_exception - (.exc_info sys))))) - (if (instance? MalException e) - (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) - (print msg))))))) +#!/usr/bin/env hy + +(import [hy.models [HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [mal_types [MalException]]) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set env-find]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn qq-loop [elt acc] + (if (and (instance? tuple elt) + (= (first elt) (Sym "splice-unquote"))) + (tuple [(Sym "concat") (get elt 1) acc]) + (tuple [(Sym "cons") (QUASIQUOTE elt) acc]))) +(defn qq-foldr [xs] + (if (empty? xs) + (,) + (qq-loop (first xs) (qq-foldr (tuple (rest xs)))))) +(defn QUASIQUOTE [ast] + (if + (instance? list ast) (tuple [(Sym "vec") (qq-foldr ast)]) + (symbol? ast) (tuple [(Sym "quote") ast]) + (instance? dict ast) (tuple [(Sym "quote") ast]) + (not (instance? tuple ast)) ast + (= (first ast) (Sym "unquote")) (get ast 1) + True (qq-foldr ast))) + +(defn macro? [ast env] + (when (and (coll? ast) + (symbol? (first ast)) + (env-find env (first ast))) + (setv mac (env-get env (first ast))) + (and (hasattr mac "macro") + mac.macro))) + +(defn macroexpand [ast env] + (while (macro? ast env) + (setv mac (env-get env (first ast)) + ast (apply mac (tuple (rest ast))))) + ast) + + + +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [k (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (setv res None) + (while True + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv ast (macroexpand ast env)) + (if (not (instance? tuple ast)) + (eval-ast ast env) + + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + a1 + + (= (Sym "quasiquoteexpand") a0) + (QUASIQUOTE a1) + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "defmacro!") a0) + (do (setv func (EVAL a2 env) + func.macro True) + (env-set env a1 func)) + + (= (Sym "macroexpand") a0) + (macroexpand a1 env) + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (, )) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/impls/hy/step9_try.hy b/impls/hy/step9_try.hy index 46e6dad50b..8a8e284c5a 100755 --- a/impls/hy/step9_try.hy +++ b/impls/hy/step9_try.hy @@ -1,196 +1,196 @@ -#!/usr/bin/env hy - -(import [hy.models [HyString :as Str HySymbol :as Sym]]) -(import sys traceback) -(import [mal_types [MalException]]) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) -(import [env [env-new env-get env-set env-find]]) -(import core) - -;; read -(defn READ [str] - (read-str str)) - -;; eval -(defn qq-loop [elt acc] - (if (and (instance? tuple elt) - (= (first elt) (Sym "splice-unquote"))) - (tuple [(Sym "concat") (get elt 1) acc]) - (tuple [(Sym "cons") (QUASIQUOTE elt) acc]))) -(defn qq-foldr [xs] - (if (empty? xs) - (,) - (qq-loop (first xs) (qq-foldr (tuple (rest xs)))))) -(defn QUASIQUOTE [ast] - (if - (instance? list ast) (tuple [(Sym "vec") (qq-foldr ast)]) - (symbol? ast) (tuple [(Sym "quote") ast]) - (instance? dict ast) (tuple [(Sym "quote") ast]) - (not (instance? tuple ast)) ast - (= (first ast) (Sym "unquote")) (get ast 1) - True (qq-foldr ast))) - -(defn macro? [ast env] - (when (and (coll? ast) - (symbol? (first ast)) - (env-find env (first ast))) - (setv mac (env-get env (first ast))) - (and (hasattr mac "macro") - mac.macro))) - -(defn macroexpand [ast env] - (while (macro? ast env) - (setv mac (env-get env (first ast)) - ast (apply mac (tuple (rest ast))))) - ast) - - - -(defn eval-ast [ast env] - ;;(print "eval-ast:" ast (type ast)) - (if - (symbol? ast) (env-get env ast) - (instance? dict ast) (dict (map (fn [k] - [k (EVAL (get ast k) env)]) - ast)) - (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) - (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) - True ast)) - -(defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) - (setv res None) - (while True - (setv res - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (do - (setv ast (macroexpand ast env)) - (if (not (instance? tuple ast)) - (eval-ast ast env) - - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "quote") a0) - a1 - - (= (Sym "quasiquoteexpand") a0) - (QUASIQUOTE a1) - - (= (Sym "quasiquote") a0) - (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - - (= (Sym "defmacro!") a0) - (do (setv func (EVAL a2 env) - func.macro True) - (env-set env a1 func)) - - (= (Sym "macroexpand") a0) - (macroexpand a1 env) - - (= (Sym "try*") a0) - (if (and a2 (= (Sym "catch*") (nth a2 0))) - (try - (EVAL a1 env) - (except [e Exception] - (if (instance? MalException e) - (setv exc e.val) - (setv exc (Str (get e.args 0)))) - (EVAL (nth a2 2) (env-new env [(nth a2 1)] - [exc])))) - (EVAL a1 env)) - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - None) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (do - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1) - func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (apply f args))))))))) - (break)) - res) - -;; print -(defn PRINT [exp] - (pr-str exp True)) - -;; repl -(def repl-env (env-new)) -(defn REP [str] - (PRINT (EVAL (READ str) repl-env))) - -;; core.hy: defined using Hy -(for [k core.ns] - (env-set repl-env (Sym k) (get core.ns k))) -(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (, )) - -;; core.mal: defined using the language itself -(REP "(def! not (fn* [a] (if a false true)))") -(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(defmain [&rest args] - (if (>= (len args) 2) - (do - (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) - (REP (+ "(load-file \"" (get args 1) "\")"))) - (do - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (setv msg (.rstrip (.join "" (apply traceback.format_exception - (.exc_info sys))))) - (if (instance? MalException e) - (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) - (print msg))))))) +#!/usr/bin/env hy + +(import [hy.models [HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [mal_types [MalException]]) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set env-find]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn qq-loop [elt acc] + (if (and (instance? tuple elt) + (= (first elt) (Sym "splice-unquote"))) + (tuple [(Sym "concat") (get elt 1) acc]) + (tuple [(Sym "cons") (QUASIQUOTE elt) acc]))) +(defn qq-foldr [xs] + (if (empty? xs) + (,) + (qq-loop (first xs) (qq-foldr (tuple (rest xs)))))) +(defn QUASIQUOTE [ast] + (if + (instance? list ast) (tuple [(Sym "vec") (qq-foldr ast)]) + (symbol? ast) (tuple [(Sym "quote") ast]) + (instance? dict ast) (tuple [(Sym "quote") ast]) + (not (instance? tuple ast)) ast + (= (first ast) (Sym "unquote")) (get ast 1) + True (qq-foldr ast))) + +(defn macro? [ast env] + (when (and (coll? ast) + (symbol? (first ast)) + (env-find env (first ast))) + (setv mac (env-get env (first ast))) + (and (hasattr mac "macro") + mac.macro))) + +(defn macroexpand [ast env] + (while (macro? ast env) + (setv mac (env-get env (first ast)) + ast (apply mac (tuple (rest ast))))) + ast) + + + +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [k (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (setv res None) + (while True + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv ast (macroexpand ast env)) + (if (not (instance? tuple ast)) + (eval-ast ast env) + + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + a1 + + (= (Sym "quasiquoteexpand") a0) + (QUASIQUOTE a1) + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "defmacro!") a0) + (do (setv func (EVAL a2 env) + func.macro True) + (env-set env a1 func)) + + (= (Sym "macroexpand") a0) + (macroexpand a1 env) + + (= (Sym "try*") a0) + (if (and a2 (= (Sym "catch*") (nth a2 0))) + (try + (EVAL a1 env) + (except [e Exception] + (if (instance? MalException e) + (setv exc e.val) + (setv exc (Str (get e.args 0)))) + (EVAL (nth a2 2) (env-new env [(nth a2 1)] + [exc])))) + (EVAL a1 env)) + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (, )) + +;; core.mal: defined using the language itself +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/impls/hy/stepA_mal.hy b/impls/hy/stepA_mal.hy index dcb7e6d063..582bb66c85 100755 --- a/impls/hy/stepA_mal.hy +++ b/impls/hy/stepA_mal.hy @@ -1,198 +1,198 @@ -#!/usr/bin/env hy - -(import [hy.models [HyString :as Str HySymbol :as Sym]]) -(import sys traceback) -(import [mal_types [MalException]]) -(import [reader [read-str Blank]]) -(import [printer [pr-str]]) -(import [env [env-new env-get env-set env-find]]) -(import core) - -;; read -(defn READ [str] - (read-str str)) - -;; eval -(defn qq-loop [elt acc] - (if (and (instance? tuple elt) - (= (first elt) (Sym "splice-unquote"))) - (tuple [(Sym "concat") (get elt 1) acc]) - (tuple [(Sym "cons") (QUASIQUOTE elt) acc]))) -(defn qq-foldr [xs] - (if (empty? xs) - (,) - (qq-loop (first xs) (qq-foldr (tuple (rest xs)))))) -(defn QUASIQUOTE [ast] - (if - (instance? list ast) (tuple [(Sym "vec") (qq-foldr ast)]) - (symbol? ast) (tuple [(Sym "quote") ast]) - (instance? dict ast) (tuple [(Sym "quote") ast]) - (not (instance? tuple ast)) ast - (= (first ast) (Sym "unquote")) (get ast 1) - True (qq-foldr ast))) - -(defn macro? [ast env] - (when (and (coll? ast) - (symbol? (first ast)) - (env-find env (first ast))) - (setv mac (env-get env (first ast))) - (and (hasattr mac "macro") - mac.macro))) - -(defn macroexpand [ast env] - (while (macro? ast env) - (setv mac (env-get env (first ast)) - ast (apply mac (tuple (rest ast))))) - ast) - - - -(defn eval-ast [ast env] - ;;(print "eval-ast:" ast (type ast)) - (if - (symbol? ast) (env-get env ast) - (instance? dict ast) (dict (map (fn [k] - [k (EVAL (get ast k) env)]) - ast)) - (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) - (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) - True ast)) - -(defn EVAL [ast env] - ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) - (setv res None) - (while True - (setv res - (if (not (instance? tuple ast)) - (eval-ast ast env) - - ;; apply list - (do - (setv ast (macroexpand ast env)) - (if (not (instance? tuple ast)) - (eval-ast ast env) - - (do - (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) - (if - (none? a0) - ast - - (= (Sym "def!") a0) - (env-set env a1 (EVAL a2 env)) - - (= (Sym "let*") a0) - (do - (setv env (env-new env)) - (for [[b e] (partition a1 2)] - (env-set env b (EVAL e env))) - (setv ast a2) - (continue)) ;; TCO - - (= (Sym "quote") a0) - a1 - - (= (Sym "quasiquoteexpand") a0) - (QUASIQUOTE a1) - - (= (Sym "quasiquote") a0) - (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO - - (= (Sym "defmacro!") a0) - (do (setv func (EVAL a2 env) - func.macro True) - (env-set env a1 func)) - - (= (Sym "macroexpand") a0) - (macroexpand a1 env) - - (= (Sym "try*") a0) - (if (and a2 (= (Sym "catch*") (nth a2 0))) - (try - (EVAL a1 env) - (except [e Exception] - (if (instance? MalException e) - (setv exc e.val) - (setv exc (Str (get e.args 0)))) - (EVAL (nth a2 2) (env-new env [(nth a2 1)] - [exc])))) - (EVAL a1 env)) - - (= (Sym "do") a0) - (do (eval-ast (list (butlast (rest ast))) env) - (setv ast (last ast)) - (continue)) ;; TCO - - (= (Sym "if") a0) - (do - (setv cond (EVAL a1 env)) - (if (or (none? cond) (and (instance? bool cond) - (= cond False))) - (if (> (len ast) 2) - (do (setv ast (nth ast 3)) (continue)) ;; TCO - None) - (do (setv ast a2) (continue)))) ;; TCO - - (= (Sym "fn*") a0) - (do - (setv func (fn [&rest args] - (EVAL a2 (env-new env a1 (or args [])))) - func.ast a2 - func.env env - func.params a1) - func) - - ;; apply - (do - (setv el (eval-ast ast env) - f (first el) - args (list (rest el))) - (if (hasattr f "ast") - (do (setv ast f.ast - env (env-new f.env f.params args)) - (continue)) ;; TCO - (apply f args))))))))) - (break)) - res) - -;; print -(defn PRINT [exp] - (pr-str exp True)) - -;; repl -(def repl-env (env-new)) -(defn REP [str] - (PRINT (EVAL (READ str) repl-env))) - -;; core.hy: defined using Hy -(for [k core.ns] - (env-set repl-env (Sym k) (get core.ns k))) -(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) -(env-set repl-env (Sym "*ARGV*") (, )) - -;; core.mal: defined using the language itself -(REP "(def! *host-language* \"Hy\")") -(REP "(def! not (fn* [a] (if a false true)))") -(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(defmain [&rest args] - (if (>= (len args) 2) - (do - (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) - (REP (+ "(load-file \"" (get args 1) "\")"))) - (do - (REP "(println (str \"Mal [\" *host-language* \"]\"))") - (while True - (try - (do (setv line (raw_input "user> ")) - (if (= "" line) (continue)) - (print (REP line))) - (except [EOFError] (break)) - (except [Blank]) - (except [e Exception] - (setv msg (.rstrip (.join "" (apply traceback.format_exception - (.exc_info sys))))) - (if (instance? MalException e) - (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) - (print msg))))))) +#!/usr/bin/env hy + +(import [hy.models [HyString :as Str HySymbol :as Sym]]) +(import sys traceback) +(import [mal_types [MalException]]) +(import [reader [read-str Blank]]) +(import [printer [pr-str]]) +(import [env [env-new env-get env-set env-find]]) +(import core) + +;; read +(defn READ [str] + (read-str str)) + +;; eval +(defn qq-loop [elt acc] + (if (and (instance? tuple elt) + (= (first elt) (Sym "splice-unquote"))) + (tuple [(Sym "concat") (get elt 1) acc]) + (tuple [(Sym "cons") (QUASIQUOTE elt) acc]))) +(defn qq-foldr [xs] + (if (empty? xs) + (,) + (qq-loop (first xs) (qq-foldr (tuple (rest xs)))))) +(defn QUASIQUOTE [ast] + (if + (instance? list ast) (tuple [(Sym "vec") (qq-foldr ast)]) + (symbol? ast) (tuple [(Sym "quote") ast]) + (instance? dict ast) (tuple [(Sym "quote") ast]) + (not (instance? tuple ast)) ast + (= (first ast) (Sym "unquote")) (get ast 1) + True (qq-foldr ast))) + +(defn macro? [ast env] + (when (and (coll? ast) + (symbol? (first ast)) + (env-find env (first ast))) + (setv mac (env-get env (first ast))) + (and (hasattr mac "macro") + mac.macro))) + +(defn macroexpand [ast env] + (while (macro? ast env) + (setv mac (env-get env (first ast)) + ast (apply mac (tuple (rest ast))))) + ast) + + + +(defn eval-ast [ast env] + ;;(print "eval-ast:" ast (type ast)) + (if + (symbol? ast) (env-get env ast) + (instance? dict ast) (dict (map (fn [k] + [k (EVAL (get ast k) env)]) + ast)) + (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast)) + (instance? list ast) (list (map (fn [x] (EVAL x env)) ast)) + True ast)) + +(defn EVAL [ast env] + ;;(print "EVAL:" ast (type ast) (instance? tuple ast)) + (setv res None) + (while True + (setv res + (if (not (instance? tuple ast)) + (eval-ast ast env) + + ;; apply list + (do + (setv ast (macroexpand ast env)) + (if (not (instance? tuple ast)) + (eval-ast ast env) + + (do + (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)]) + (if + (none? a0) + ast + + (= (Sym "def!") a0) + (env-set env a1 (EVAL a2 env)) + + (= (Sym "let*") a0) + (do + (setv env (env-new env)) + (for [[b e] (partition a1 2)] + (env-set env b (EVAL e env))) + (setv ast a2) + (continue)) ;; TCO + + (= (Sym "quote") a0) + a1 + + (= (Sym "quasiquoteexpand") a0) + (QUASIQUOTE a1) + + (= (Sym "quasiquote") a0) + (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO + + (= (Sym "defmacro!") a0) + (do (setv func (EVAL a2 env) + func.macro True) + (env-set env a1 func)) + + (= (Sym "macroexpand") a0) + (macroexpand a1 env) + + (= (Sym "try*") a0) + (if (and a2 (= (Sym "catch*") (nth a2 0))) + (try + (EVAL a1 env) + (except [e Exception] + (if (instance? MalException e) + (setv exc e.val) + (setv exc (Str (get e.args 0)))) + (EVAL (nth a2 2) (env-new env [(nth a2 1)] + [exc])))) + (EVAL a1 env)) + + (= (Sym "do") a0) + (do (eval-ast (list (butlast (rest ast))) env) + (setv ast (last ast)) + (continue)) ;; TCO + + (= (Sym "if") a0) + (do + (setv cond (EVAL a1 env)) + (if (or (none? cond) (and (instance? bool cond) + (= cond False))) + (if (> (len ast) 2) + (do (setv ast (nth ast 3)) (continue)) ;; TCO + None) + (do (setv ast a2) (continue)))) ;; TCO + + (= (Sym "fn*") a0) + (do + (setv func (fn [&rest args] + (EVAL a2 (env-new env a1 (or args [])))) + func.ast a2 + func.env env + func.params a1) + func) + + ;; apply + (do + (setv el (eval-ast ast env) + f (first el) + args (list (rest el))) + (if (hasattr f "ast") + (do (setv ast f.ast + env (env-new f.env f.params args)) + (continue)) ;; TCO + (apply f args))))))))) + (break)) + res) + +;; print +(defn PRINT [exp] + (pr-str exp True)) + +;; repl +(def repl-env (env-new)) +(defn REP [str] + (PRINT (EVAL (READ str) repl-env))) + +;; core.hy: defined using Hy +(for [k core.ns] + (env-set repl-env (Sym k) (get core.ns k))) +(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env))) +(env-set repl-env (Sym "*ARGV*") (, )) + +;; core.mal: defined using the language itself +(REP "(def! *host-language* \"Hy\")") +(REP "(def! not (fn* [a] (if a false true)))") +(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(defmain [&rest args] + (if (>= (len args) 2) + (do + (env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest args))))) + (REP (+ "(load-file \"" (get args 1) "\")"))) + (do + (REP "(println (str \"Mal [\" *host-language* \"]\"))") + (while True + (try + (do (setv line (raw_input "user> ")) + (if (= "" line) (continue)) + (print (REP line))) + (except [EOFError] (break)) + (except [Blank]) + (except [e Exception] + (setv msg (.rstrip (.join "" (apply traceback.format_exception + (.exc_info sys))))) + (if (instance? MalException e) + (setv msg (+ (.rstrip msg) ": " (pr-str e.val True)))) + (print msg))))))) diff --git a/impls/hy/tests/step5_tco.mal b/impls/hy/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/hy/tests/step5_tco.mal +++ b/impls/hy/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/io/Dockerfile b/impls/io/Dockerfile index e93a326434..0b581f2bde 100644 --- a/impls/io/Dockerfile +++ b/impls/io/Dockerfile @@ -1,33 +1,33 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Zip -RUN apt-get -y install unzip - -RUN cd /tmp && curl -O -J -L http://iobin.suspended-chord.info/linux/iobin-linux-x64-deb-current.zip \ - && unzip iobin-linux-x64-deb-current.zip IoLanguage-2013.11.04-Linux-x64.deb \ - && dpkg -i IoLanguage-2013.11.04-Linux-x64.deb \ - && ldconfig \ - && rm -f iobin-linux-x64-deb-current.zip IoLanguage-2013.11.04-Linux-x64.deb - -ENV HOME /mal +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Zip +RUN apt-get -y install unzip + +RUN cd /tmp && curl -O -J -L http://iobin.suspended-chord.info/linux/iobin-linux-x64-deb-current.zip \ + && unzip iobin-linux-x64-deb-current.zip IoLanguage-2013.11.04-Linux-x64.deb \ + && dpkg -i IoLanguage-2013.11.04-Linux-x64.deb \ + && ldconfig \ + && rm -f iobin-linux-x64-deb-current.zip IoLanguage-2013.11.04-Linux-x64.deb + +ENV HOME /mal diff --git a/impls/io/Env.io b/impls/io/Env.io index 5b793eb22a..a9e3e5f17b 100644 --- a/impls/io/Env.io +++ b/impls/io/Env.io @@ -1,45 +1,45 @@ -Env := Object clone do( - outer ::= nil - data ::= nil - - with := method(aOuter, aBinds, aExprs, - self clone setOuter(aOuter) setData(Map clone) initBinds(aBinds, aExprs) - ) - - initBinds := method(aBinds, aExprs, - if(aBinds isNil not, - aBinds foreach(i, b, - if(b val == "&", - set(aBinds at(i + 1), aExprs slice(i)) break, - set(b, aExprs at(i)) - ) - ) - ) - self - ) - - set := method(key, val, - data atPut(key val, val) - val - ) - - find := method(key, - keyStr := key val - if(data hasKey(keyStr), - self, - if(outer isNil, - nil, - outer find(key) - ) - ) - ) - - get := method(key, - keyStr := key val - foundEnv := find(key) - if(foundEnv isNil, - Exception raise("'" .. keyStr .. "' not found"), - (foundEnv data) at(keyStr) - ) - ) -) +Env := Object clone do( + outer ::= nil + data ::= nil + + with := method(aOuter, aBinds, aExprs, + self clone setOuter(aOuter) setData(Map clone) initBinds(aBinds, aExprs) + ) + + initBinds := method(aBinds, aExprs, + if(aBinds isNil not, + aBinds foreach(i, b, + if(b val == "&", + set(aBinds at(i + 1), aExprs slice(i)) break, + set(b, aExprs at(i)) + ) + ) + ) + self + ) + + set := method(key, val, + data atPut(key val, val) + val + ) + + find := method(key, + keyStr := key val + if(data hasKey(keyStr), + self, + if(outer isNil, + nil, + outer find(key) + ) + ) + ) + + get := method(key, + keyStr := key val + foundEnv := find(key) + if(foundEnv isNil, + Exception raise("'" .. keyStr .. "' not found"), + (foundEnv data) at(keyStr) + ) + ) +) diff --git a/impls/io/Makefile b/impls/io/Makefile index d2e469ecd4..919ca2d085 100644 --- a/impls/io/Makefile +++ b/impls/io/Makefile @@ -1,4 +1,4 @@ -all: - @true - -clean: +all: + @true + +clean: diff --git a/impls/io/MalCore.io b/impls/io/MalCore.io index 740e2c6187..8aed1f45c9 100644 --- a/impls/io/MalCore.io +++ b/impls/io/MalCore.io @@ -1,154 +1,154 @@ -MalCore := Object clone do( - slurp := block(a, - f := File with(a at(0)) - res := f contents - f close - res - ) - - dissoc := block(a, - res := MalMap withMap(a at(0)) - a rest foreach(k, res removeKey(k)) - res - ) - - vec := block(a, - coll := a at(0) - coll type switch( - "MalVector", coll, - "MalList", MalVector with(coll), - Exception raise("vec: arg type"))) - - nth := block(a, - if(a at(1) < a at(0) size, - a at(0) at(a at(1)), - Exception raise("nth: index out of range") - ) - ) - - conj := block(a, - coll := a at(0) - coll type switch( - "MalList", - MalList with(a rest reverse appendSeq(coll)), - "MalVector", - MalVector with(coll appendSeq(a rest)) - ) - ) - - seq := block(a, - obj := a at(0) - (obj isNil) ifTrue(return(nil)) - (obj type == "MalList") ifTrue(return(if(obj isEmpty, nil, obj))) - (obj type == "MalVector") ifTrue(return(if(obj isEmpty, nil, MalList with(obj)))) - (obj type == "Sequence") ifTrue( - if(obj isEmpty, return(nil)) - lst := list() - obj foreach(i, c, lst append(obj inclusiveSlice(i, i))) - return(MalList with(lst)) - ) - nil - ) - - swapBang := block(a, - atom := a at(0) - newVal := a at(1) call(MalList with(list(atom val)) appendSeq(a slice(2))) - atom setVal(newVal) val - ) - - ioToMal := method(v, - (v isNil) ifTrue(return(v)) - (v == true) ifTrue(return(v)) - (v == false) ifTrue(return(v)) - (v type == "Number") ifTrue(return(v)) - (v type == "Sequence") ifTrue(return(v)) - (v type == "List") ifTrue(return(MalList with(v map(e, ioToMal(e))))) - (v type == "Map") ifTrue( - lst := list() - v foreach(key, val, - lst push(key asString) - lst push(ioToMal(val)) - ) - return(MalMap withList(lst)) - ) - v asString - ) - - ioEval := block(a, - MalCore ioToMal(doString(a at(0))) - ) - - NS := Map with( - "=", block(a, a at(0) == a at(1)), - "throw", block(a, MalException with(a at(0)) raise), - - "nil?", block(a, a at(0) isNil), - "true?", block(a, a at(0) == true), - "false?", block(a, a at(0) == false), - "string?", block(a, a at(0) type == "Sequence"), - "symbol", block(a, MalSymbol with(a at(0))), - "symbol?", block(a, a at(0) type == "MalSymbol"), - "keyword", block(a, MalKeyword with(a at(0))), - "keyword?", block(a, a at(0) type == "MalKeyword"), - "number?", block(a, a at(0) type == "Number"), - "fn?", block(a, (a at(0) type == "Block") or - ((a at(0) type == "MalFunc") and (a at(0) isMacro not))), - "macro?", block(a, (a at(0) type == "MalFunc") and (a at(0) isMacro)), - - "pr-str", block(a, a map(s, s malPrint(true)) join(" ")), - "str", block(a, a map(s, s malPrint(false)) join("")), - "prn", block(a, a map(s, s malPrint(true)) join(" ") println ; nil), - "println", block(a, a map(s, s malPrint(false)) join(" ") println ; nil), - "read-string", block(a, MalReader read_str(a at(0))), - "readline", block(a, MalReadline readLine(a at(0))), - "slurp", slurp, - - "<", block(a, a at(0) < a at(1)), - "<=", block(a, a at(0) <= a at(1)), - ">", block(a, a at(0) > a at(1)), - ">=", block(a, a at(0) >= a at(1)), - "+", block(a, a at(0) + a at(1)), - "-", block(a, a at(0) - a at(1)), - "*", block(a, a at(0) * a at(1)), - "/", block(a, a at(0) / a at(1)), - "time-ms", block(a, (Date now asNumber * 1000.0) round), - - "list", block(a, a), - "list?", block(a, a at(0) type == "MalList"), - "vector", block(a, MalVector with(a)), - "vector?", block(a, a at(0) type == "MalVector"), - "hash-map", block(a, MalMap withList(a)), - "map?", block(a, a at(0) type == "MalMap"), - "assoc", block(a, MalMap withMap(a at(0) merge(MalMap withList(a rest)))), - "dissoc", dissoc, - "get", block(a, a at(0) ifNil(return nil) get(a at(1))), - "contains?", block(a, a at(0) ifNil(return nil) contains(a at(1))), - "keys", block(a, a at(0) malKeys), - "vals", block(a, a at(0) malVals), - - "sequential?", block(a, if(a at(0) ?isSequential, true, false)), - "cons", block(a, MalList with(list(a at(0)) appendSeq(a at(1)))), - "concat", block(a, MalList with(a reduce(appendSeq, list()))), - "vec", vec, - "nth", nth, - "first", block(a, a at(0) ifNil(return nil) first), - "rest", block(a, a at(0) ifNil(return MalList with(list())) rest), - "empty?", block(a, a at(0) ifNil(true) isEmpty), - "count", block(a, a at(0) ifNil(return(0)) size), - "apply", block(a, a at(0) call(MalList with(a slice(1, -1) appendSeq(a last)))), - "map", block(a, MalList with(a at(1) map(e, a at(0) call(MalList with(list(e)))))), - - "conj", conj, - "seq", seq, - - "meta", block(a, a at(0) ?meta), - "with-meta", block(a, a at(0) clone setMeta(a at(1))), - "atom", block(a, MalAtom with(a at(0))), - "atom?", block(a, a at(0) type == "MalAtom"), - "deref", block(a, a at(0) val), - "reset!", block(a, a at(0) setVal(a at(1)) ; a at(1)), - "swap!", swapBang, - - "io-eval", ioEval - ) -) +MalCore := Object clone do( + slurp := block(a, + f := File with(a at(0)) + res := f contents + f close + res + ) + + dissoc := block(a, + res := MalMap withMap(a at(0)) + a rest foreach(k, res removeKey(k)) + res + ) + + vec := block(a, + coll := a at(0) + coll type switch( + "MalVector", coll, + "MalList", MalVector with(coll), + Exception raise("vec: arg type"))) + + nth := block(a, + if(a at(1) < a at(0) size, + a at(0) at(a at(1)), + Exception raise("nth: index out of range") + ) + ) + + conj := block(a, + coll := a at(0) + coll type switch( + "MalList", + MalList with(a rest reverse appendSeq(coll)), + "MalVector", + MalVector with(coll appendSeq(a rest)) + ) + ) + + seq := block(a, + obj := a at(0) + (obj isNil) ifTrue(return(nil)) + (obj type == "MalList") ifTrue(return(if(obj isEmpty, nil, obj))) + (obj type == "MalVector") ifTrue(return(if(obj isEmpty, nil, MalList with(obj)))) + (obj type == "Sequence") ifTrue( + if(obj isEmpty, return(nil)) + lst := list() + obj foreach(i, c, lst append(obj inclusiveSlice(i, i))) + return(MalList with(lst)) + ) + nil + ) + + swapBang := block(a, + atom := a at(0) + newVal := a at(1) call(MalList with(list(atom val)) appendSeq(a slice(2))) + atom setVal(newVal) val + ) + + ioToMal := method(v, + (v isNil) ifTrue(return(v)) + (v == true) ifTrue(return(v)) + (v == false) ifTrue(return(v)) + (v type == "Number") ifTrue(return(v)) + (v type == "Sequence") ifTrue(return(v)) + (v type == "List") ifTrue(return(MalList with(v map(e, ioToMal(e))))) + (v type == "Map") ifTrue( + lst := list() + v foreach(key, val, + lst push(key asString) + lst push(ioToMal(val)) + ) + return(MalMap withList(lst)) + ) + v asString + ) + + ioEval := block(a, + MalCore ioToMal(doString(a at(0))) + ) + + NS := Map with( + "=", block(a, a at(0) == a at(1)), + "throw", block(a, MalException with(a at(0)) raise), + + "nil?", block(a, a at(0) isNil), + "true?", block(a, a at(0) == true), + "false?", block(a, a at(0) == false), + "string?", block(a, a at(0) type == "Sequence"), + "symbol", block(a, MalSymbol with(a at(0))), + "symbol?", block(a, a at(0) type == "MalSymbol"), + "keyword", block(a, MalKeyword with(a at(0))), + "keyword?", block(a, a at(0) type == "MalKeyword"), + "number?", block(a, a at(0) type == "Number"), + "fn?", block(a, (a at(0) type == "Block") or + ((a at(0) type == "MalFunc") and (a at(0) isMacro not))), + "macro?", block(a, (a at(0) type == "MalFunc") and (a at(0) isMacro)), + + "pr-str", block(a, a map(s, s malPrint(true)) join(" ")), + "str", block(a, a map(s, s malPrint(false)) join("")), + "prn", block(a, a map(s, s malPrint(true)) join(" ") println ; nil), + "println", block(a, a map(s, s malPrint(false)) join(" ") println ; nil), + "read-string", block(a, MalReader read_str(a at(0))), + "readline", block(a, MalReadline readLine(a at(0))), + "slurp", slurp, + + "<", block(a, a at(0) < a at(1)), + "<=", block(a, a at(0) <= a at(1)), + ">", block(a, a at(0) > a at(1)), + ">=", block(a, a at(0) >= a at(1)), + "+", block(a, a at(0) + a at(1)), + "-", block(a, a at(0) - a at(1)), + "*", block(a, a at(0) * a at(1)), + "/", block(a, a at(0) / a at(1)), + "time-ms", block(a, (Date now asNumber * 1000.0) round), + + "list", block(a, a), + "list?", block(a, a at(0) type == "MalList"), + "vector", block(a, MalVector with(a)), + "vector?", block(a, a at(0) type == "MalVector"), + "hash-map", block(a, MalMap withList(a)), + "map?", block(a, a at(0) type == "MalMap"), + "assoc", block(a, MalMap withMap(a at(0) merge(MalMap withList(a rest)))), + "dissoc", dissoc, + "get", block(a, a at(0) ifNil(return nil) get(a at(1))), + "contains?", block(a, a at(0) ifNil(return nil) contains(a at(1))), + "keys", block(a, a at(0) malKeys), + "vals", block(a, a at(0) malVals), + + "sequential?", block(a, if(a at(0) ?isSequential, true, false)), + "cons", block(a, MalList with(list(a at(0)) appendSeq(a at(1)))), + "concat", block(a, MalList with(a reduce(appendSeq, list()))), + "vec", vec, + "nth", nth, + "first", block(a, a at(0) ifNil(return nil) first), + "rest", block(a, a at(0) ifNil(return MalList with(list())) rest), + "empty?", block(a, a at(0) ifNil(true) isEmpty), + "count", block(a, a at(0) ifNil(return(0)) size), + "apply", block(a, a at(0) call(MalList with(a slice(1, -1) appendSeq(a last)))), + "map", block(a, MalList with(a at(1) map(e, a at(0) call(MalList with(list(e)))))), + + "conj", conj, + "seq", seq, + + "meta", block(a, a at(0) ?meta), + "with-meta", block(a, a at(0) clone setMeta(a at(1))), + "atom", block(a, MalAtom with(a at(0))), + "atom?", block(a, a at(0) type == "MalAtom"), + "deref", block(a, a at(0) val), + "reset!", block(a, a at(0) setVal(a at(1)) ; a at(1)), + "swap!", swapBang, + + "io-eval", ioEval + ) +) diff --git a/impls/io/MalReader.io b/impls/io/MalReader.io index 16cc3bd414..29e251cc30 100644 --- a/impls/io/MalReader.io +++ b/impls/io/MalReader.io @@ -1,92 +1,92 @@ -MalReader := Object clone do ( - - Reader := Object clone do ( - pos ::= 0 - tokens ::= list() - - with := method(theTokens, - self clone setTokens(theTokens) - ) - - peek := method(tokens at(pos)) - - next := method( - pos = pos + 1 - tokens at(pos - 1) - ) - ) - - tokenizerRegex := Regex with("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)") - - tokenize := method(str, - tokenizerRegex matchesIn(str) \ - map(m, m at(1) asMutable strip) \ - select(t, t size > 0) \ - select(t, t exSlice(0, 1) != ";") - ) - - numberRegex := Regex with("^-?[0-9]+$") - stringRegex := Regex with("^\"(?:[\\\\].|[^\\\\\"])*\"$") - - read_string := method(token, - placeholder := 127 asCharacter - token exSlice(1, -1) replaceSeq("\\\\", placeholder) replaceSeq("\\\"", "\"") replaceSeq("\\n", "\n") replaceSeq(placeholder, "\\") - ) - - read_atom := method(rdr, - token := rdr next - (token hasMatchOfRegex(numberRegex)) ifTrue(return(token asNumber)) - (token == "true") ifTrue(return(true)) - (token == "false") ifTrue(return(false)) - (token == "nil") ifTrue(return(nil)) - (token beginsWithSeq(":")) ifTrue(return(MalKeyword with(token exSlice(1)))) - (token hasMatchOfRegex(stringRegex)) ifTrue(return(read_string(token))) - (token beginsWithSeq("\"")) ifTrue(Exception raise("expected '\"', got EOF")) - MalSymbol with(token) - ) - - read_list := method(rdr, start, end, - token := rdr next - if(token != start, Exception raise("expected '" .. start .. "'")) - ast := list() - token = rdr peek - while(token != end, - if(token isNil, Exception raise("expected '" .. end .. "', got EOF")) - ast push(read_form(rdr)) - token = rdr peek - ) - rdr next - ast - ) - - reader_macro := method(symbol, rdr, - rdr next - MalList with(list(MalSymbol with(symbol), read_form(rdr))) - ) - - read_form := method(rdr, - token := rdr peek - (token == "'") ifTrue(return(reader_macro("quote", rdr))) - (token == "`") ifTrue(return(reader_macro("quasiquote", rdr))) - (token == "~") ifTrue(return(reader_macro("unquote", rdr))) - (token == "~@") ifTrue(return(reader_macro("splice-unquote", rdr))) - (token == "^") ifTrue( - rdr next - meta := read_form(rdr) - return(MalList with(list(MalSymbol with("with-meta"), read_form(rdr), meta))) - ) - (token == "@") ifTrue(return(reader_macro("deref", rdr))) - (token == "(") ifTrue(return(MalList with(read_list(rdr, "(", ")")))) - (token == ")") ifTrue(Exception raise("unexepcted ')'")) - (token == "[") ifTrue(return(MalVector with(read_list(rdr, "[", "]")))) - (token == "]") ifTrue(Exception raise("unexepcted ']'")) - (token == "{") ifTrue(return(MalMap withList(read_list(rdr, "{", "}")))) - (token == "}") ifTrue(Exception raise("unexepcted '}'")) - read_atom(rdr) - ) - - read_str := method(str, - tokens := tokenize(str) - if(tokens isEmpty, nil, read_form(Reader with(tokens))) - ) -) +MalReader := Object clone do ( + + Reader := Object clone do ( + pos ::= 0 + tokens ::= list() + + with := method(theTokens, + self clone setTokens(theTokens) + ) + + peek := method(tokens at(pos)) + + next := method( + pos = pos + 1 + tokens at(pos - 1) + ) + ) + + tokenizerRegex := Regex with("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)") + + tokenize := method(str, + tokenizerRegex matchesIn(str) \ + map(m, m at(1) asMutable strip) \ + select(t, t size > 0) \ + select(t, t exSlice(0, 1) != ";") + ) + + numberRegex := Regex with("^-?[0-9]+$") + stringRegex := Regex with("^\"(?:[\\\\].|[^\\\\\"])*\"$") + + read_string := method(token, + placeholder := 127 asCharacter + token exSlice(1, -1) replaceSeq("\\\\", placeholder) replaceSeq("\\\"", "\"") replaceSeq("\\n", "\n") replaceSeq(placeholder, "\\") + ) + + read_atom := method(rdr, + token := rdr next + (token hasMatchOfRegex(numberRegex)) ifTrue(return(token asNumber)) + (token == "true") ifTrue(return(true)) + (token == "false") ifTrue(return(false)) + (token == "nil") ifTrue(return(nil)) + (token beginsWithSeq(":")) ifTrue(return(MalKeyword with(token exSlice(1)))) + (token hasMatchOfRegex(stringRegex)) ifTrue(return(read_string(token))) + (token beginsWithSeq("\"")) ifTrue(Exception raise("expected '\"', got EOF")) + MalSymbol with(token) + ) + + read_list := method(rdr, start, end, + token := rdr next + if(token != start, Exception raise("expected '" .. start .. "'")) + ast := list() + token = rdr peek + while(token != end, + if(token isNil, Exception raise("expected '" .. end .. "', got EOF")) + ast push(read_form(rdr)) + token = rdr peek + ) + rdr next + ast + ) + + reader_macro := method(symbol, rdr, + rdr next + MalList with(list(MalSymbol with(symbol), read_form(rdr))) + ) + + read_form := method(rdr, + token := rdr peek + (token == "'") ifTrue(return(reader_macro("quote", rdr))) + (token == "`") ifTrue(return(reader_macro("quasiquote", rdr))) + (token == "~") ifTrue(return(reader_macro("unquote", rdr))) + (token == "~@") ifTrue(return(reader_macro("splice-unquote", rdr))) + (token == "^") ifTrue( + rdr next + meta := read_form(rdr) + return(MalList with(list(MalSymbol with("with-meta"), read_form(rdr), meta))) + ) + (token == "@") ifTrue(return(reader_macro("deref", rdr))) + (token == "(") ifTrue(return(MalList with(read_list(rdr, "(", ")")))) + (token == ")") ifTrue(Exception raise("unexepcted ')'")) + (token == "[") ifTrue(return(MalVector with(read_list(rdr, "[", "]")))) + (token == "]") ifTrue(Exception raise("unexepcted ']'")) + (token == "{") ifTrue(return(MalMap withList(read_list(rdr, "{", "}")))) + (token == "}") ifTrue(Exception raise("unexepcted '}'")) + read_atom(rdr) + ) + + read_str := method(str, + tokens := tokenize(str) + if(tokens isEmpty, nil, read_form(Reader with(tokens))) + ) +) diff --git a/impls/io/MalReadline.io b/impls/io/MalReadline.io index e38f4099e6..5536da31f5 100644 --- a/impls/io/MalReadline.io +++ b/impls/io/MalReadline.io @@ -1,19 +1,19 @@ -MalReadline := Object clone do ( - historyLoaded := false - historyFile := (System getEnvironmentVariable("HOME")) .. "/.mal-history" - - loadHistory := method( - if(File exists(historyFile), ReadLine loadHistory(historyFile)) - historyLoaded = true - ) - - readLine := method(prompt, - if(historyLoaded not, loadHistory) - line := ReadLine readLine(prompt) - if(line isNil, return(nil)) - if(line isEmpty, return(line)) - ReadLine addHistory(line) - ReadLine saveHistory(historyFile) - line - ) -) +MalReadline := Object clone do ( + historyLoaded := false + historyFile := (System getEnvironmentVariable("HOME")) .. "/.mal-history" + + loadHistory := method( + if(File exists(historyFile), ReadLine loadHistory(historyFile)) + historyLoaded = true + ) + + readLine := method(prompt, + if(historyLoaded not, loadHistory) + line := ReadLine readLine(prompt) + if(line isNil, return(nil)) + if(line isEmpty, return(line)) + ReadLine addHistory(line) + ReadLine saveHistory(historyFile) + line + ) +) diff --git a/impls/io/MalTypes.io b/impls/io/MalTypes.io index a5b7c0c644..eb52a6e435 100644 --- a/impls/io/MalTypes.io +++ b/impls/io/MalTypes.io @@ -1,134 +1,134 @@ -MalTypes := Object clone - -nil malPrint := method(readable, self asString) -true malPrint := method(readable, self asString) -false malPrint := method(readable, self asString) -Number malPrint := method(readable, self asString) - -// Io strings are of type Sequence -Sequence malPrint := method(readable, - if(readable, - "\"" .. (self asString asMutable replaceSeq("\\", "\\\\") replaceSeq("\"", "\\\"") replaceSeq("\n", "\\n")) .. "\"", - self asString) -) - -MalMeta := Object clone do( - meta ::= nil -) - -MalSymbol := Object clone appendProto(MalMeta) do ( - val ::= nil - with := method(str, self clone setVal(if(str ?val, str val, str))) - malPrint := method(readable, val) - == := method(other, (self type == other type) and (val == other val)) -) - -MalKeyword := Object clone do ( - val ::= nil - with := method(str, self clone setVal(if(str ?val, str val, str))) - malPrint := method(readable, ":" .. val) - == := method(other, (self type == other type) and (val == other val)) -) - -MalSequential := Object clone do( - isSequential := method(true) - equalSequence := method(other, - if((other ?isSequential) not, return false) - if(self size != other size, return false) - unequalElement := self detect(i, valA, - (valA == (other at(i))) not - ) - if(unequalElement, false, true) - ) -) - -MalList := List clone appendProto(MalSequential) appendProto(MalMeta) do ( - with := method(lst, self clone copy(lst)) - malPrint := method(readable, - "(" .. (self map(e, e malPrint(readable)) join(" ")) .. ")" - ) - rest := method(MalList with(resend)) - slice := method(MalList with(resend)) - == := method(other, equalSequence(other)) -) - -MalVector := List clone appendProto(MalSequential) appendProto(MalMeta) do ( - with := method(lst, self clone copy(lst)) - malPrint := method(readable, - "[" .. (self map(e, e malPrint(readable)) join(" ")) .. "]" - ) - rest := method(MalList with(resend)) - slice := method(MalList with(resend)) - == := method(other, equalSequence(other)) -) - -MalMap := Map clone appendProto(MalMeta) do ( - withList := method(lst, - obj := self clone - k := nil - lst foreach(i, e, - if(i % 2 == 0, - k := e, - obj atPut(objToKey(k), e) - ) - ) - obj - ) - withMap := method(aMap, self clone merge(aMap)) - objToKey := method(obj, - if(obj type == "MalKeyword", "K_" .. (obj val), "S_" .. obj) - ) - keyToObj := method(s, - if(s beginsWithSeq("K_"), - MalKeyword with(s exSlice(2)), - s exSlice(2) - ) - ) - malPrint := method(readable, - "{" .. - (self map(k, v, - (keyToObj(k) malPrint(readable)) .. " " .. (v malPrint(readable)) - ) join(" ")) .. "}" - ) - contains := method(obj, hasKey(objToKey(obj))) - get := method(obj, at(objToKey(obj))) - malKeys := method(MalList with(keys map(k, keyToObj(k)))) - malVals := method(MalList with(values)) - removeKey := method(obj, removeAt(objToKey(obj))) - == := method(other, - if(self type != other type, return false) - if(keys size != other keys size, return false) - unequalElement := self detect(k, valA, - (valA == (other at(k))) not - ) - if(unequalElement, false, true) - ) -) - -Block malPrint := method(readable, "#") -Block appendProto(MalMeta) - -MalFunc := Object clone appendProto(MalMeta) do ( - ast ::= nil - params ::= nil - env ::= nil - blk ::= nil - isMacro ::= false - with := method(aAst, aParams, aEnv, aBlk, - self clone setAst(aAst) setParams(aParams) setEnv(aEnv) setBlk(aBlk) - ) - malPrint := method(readable, "#") - call := method(args, blk call(args)) -) - -MalAtom := Object clone appendProto(MalMeta) do ( - val ::= nil - with := method(str, self clone setVal(str)) - malPrint := method(readable, "(atom " .. (val malPrint(true)) .. ")") - == := method(other, (self type == other type) and (val == other val)) -) - -MalException := Exception clone do ( - val ::= nil - with := method(str, self clone setVal(str)) -) +MalTypes := Object clone + +nil malPrint := method(readable, self asString) +true malPrint := method(readable, self asString) +false malPrint := method(readable, self asString) +Number malPrint := method(readable, self asString) + +// Io strings are of type Sequence +Sequence malPrint := method(readable, + if(readable, + "\"" .. (self asString asMutable replaceSeq("\\", "\\\\") replaceSeq("\"", "\\\"") replaceSeq("\n", "\\n")) .. "\"", + self asString) +) + +MalMeta := Object clone do( + meta ::= nil +) + +MalSymbol := Object clone appendProto(MalMeta) do ( + val ::= nil + with := method(str, self clone setVal(if(str ?val, str val, str))) + malPrint := method(readable, val) + == := method(other, (self type == other type) and (val == other val)) +) + +MalKeyword := Object clone do ( + val ::= nil + with := method(str, self clone setVal(if(str ?val, str val, str))) + malPrint := method(readable, ":" .. val) + == := method(other, (self type == other type) and (val == other val)) +) + +MalSequential := Object clone do( + isSequential := method(true) + equalSequence := method(other, + if((other ?isSequential) not, return false) + if(self size != other size, return false) + unequalElement := self detect(i, valA, + (valA == (other at(i))) not + ) + if(unequalElement, false, true) + ) +) + +MalList := List clone appendProto(MalSequential) appendProto(MalMeta) do ( + with := method(lst, self clone copy(lst)) + malPrint := method(readable, + "(" .. (self map(e, e malPrint(readable)) join(" ")) .. ")" + ) + rest := method(MalList with(resend)) + slice := method(MalList with(resend)) + == := method(other, equalSequence(other)) +) + +MalVector := List clone appendProto(MalSequential) appendProto(MalMeta) do ( + with := method(lst, self clone copy(lst)) + malPrint := method(readable, + "[" .. (self map(e, e malPrint(readable)) join(" ")) .. "]" + ) + rest := method(MalList with(resend)) + slice := method(MalList with(resend)) + == := method(other, equalSequence(other)) +) + +MalMap := Map clone appendProto(MalMeta) do ( + withList := method(lst, + obj := self clone + k := nil + lst foreach(i, e, + if(i % 2 == 0, + k := e, + obj atPut(objToKey(k), e) + ) + ) + obj + ) + withMap := method(aMap, self clone merge(aMap)) + objToKey := method(obj, + if(obj type == "MalKeyword", "K_" .. (obj val), "S_" .. obj) + ) + keyToObj := method(s, + if(s beginsWithSeq("K_"), + MalKeyword with(s exSlice(2)), + s exSlice(2) + ) + ) + malPrint := method(readable, + "{" .. + (self map(k, v, + (keyToObj(k) malPrint(readable)) .. " " .. (v malPrint(readable)) + ) join(" ")) .. "}" + ) + contains := method(obj, hasKey(objToKey(obj))) + get := method(obj, at(objToKey(obj))) + malKeys := method(MalList with(keys map(k, keyToObj(k)))) + malVals := method(MalList with(values)) + removeKey := method(obj, removeAt(objToKey(obj))) + == := method(other, + if(self type != other type, return false) + if(keys size != other keys size, return false) + unequalElement := self detect(k, valA, + (valA == (other at(k))) not + ) + if(unequalElement, false, true) + ) +) + +Block malPrint := method(readable, "#") +Block appendProto(MalMeta) + +MalFunc := Object clone appendProto(MalMeta) do ( + ast ::= nil + params ::= nil + env ::= nil + blk ::= nil + isMacro ::= false + with := method(aAst, aParams, aEnv, aBlk, + self clone setAst(aAst) setParams(aParams) setEnv(aEnv) setBlk(aBlk) + ) + malPrint := method(readable, "#") + call := method(args, blk call(args)) +) + +MalAtom := Object clone appendProto(MalMeta) do ( + val ::= nil + with := method(str, self clone setVal(str)) + malPrint := method(readable, "(atom " .. (val malPrint(true)) .. ")") + == := method(other, (self type == other type) and (val == other val)) +) + +MalException := Exception clone do ( + val ::= nil + with := method(str, self clone setVal(str)) +) diff --git a/impls/io/run b/impls/io/run index 1c38be7185..1cf45d63c1 100755 --- a/impls/io/run +++ b/impls/io/run @@ -1,6 +1,6 @@ -#!/bin/bash - -# Io prints the line "Registering Regex: Regex" when loading the Regex module -# for the first time, and there's no way to suppress it. To avoid polluting -# the Mal script output, we swallow the first 25 bytes. -io $(dirname $0)/${STEP:-stepA_mal}.io "$@" | (read -N 25 -t 10 ; cat) +#!/bin/bash + +# Io prints the line "Registering Regex: Regex" when loading the Regex module +# for the first time, and there's no way to suppress it. To avoid polluting +# the Mal script output, we swallow the first 25 bytes. +io $(dirname $0)/${STEP:-stepA_mal}.io "$@" | (read -N 25 -t 10 ; cat) diff --git a/impls/io/step0_repl.io b/impls/io/step0_repl.io index 154d7c0876..367ae152e4 100644 --- a/impls/io/step0_repl.io +++ b/impls/io/step0_repl.io @@ -1,18 +1,18 @@ -Regex - -READ := method(str, str) - -EVAL := method(ast, env, ast) - -PRINT := method(exp, exp) - -RE := method(str, EVAL(READ(str), nil)) - -REP := method(str, PRINT(RE(str))) - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - REP(line) println -) +Regex + +READ := method(str, str) + +EVAL := method(ast, env, ast) + +PRINT := method(exp, exp) + +RE := method(str, EVAL(READ(str), nil)) + +REP := method(str, PRINT(RE(str))) + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + REP(line) println +) diff --git a/impls/io/step1_read_print.io b/impls/io/step1_read_print.io index b1cd57ecd1..74e2685bcc 100644 --- a/impls/io/step1_read_print.io +++ b/impls/io/step1_read_print.io @@ -1,22 +1,22 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -EVAL := method(ast, env, ast) - -PRINT := method(exp, exp malPrint(true)) - -RE := method(str, EVAL(READ(str), nil)) - -REP := method(str, PRINT(RE(str))) - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - ("Error: " .. (e error)) println - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +EVAL := method(ast, env, ast) + +PRINT := method(exp, exp malPrint(true)) + +RE := method(str, EVAL(READ(str), nil)) + +REP := method(str, PRINT(RE(str))) + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + ("Error: " .. (e error)) println + ) +) diff --git a/impls/io/step2_eval.io b/impls/io/step2_eval.io index fd85f1ce12..4c999bbbbf 100644 --- a/impls/io/step2_eval.io +++ b/impls/io/step2_eval.io @@ -1,51 +1,51 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -eval_ast := method(ast, env, - (ast type) switch( - "MalSymbol", env at(ast val) ifNil(Exception raise("'" .. (ast val) "' not found")), - "MalList", MalList with(ast map(a, EVAL(a, env))), - "MalVector", MalVector with(ast map(a, EVAL(a, env))), - "MalMap", - m := MalMap clone - ast foreach(k, v, - m atPut(k, EVAL(v, env)) - ) - m, - ast - ) -) - -EVAL := method(ast, env, - if(ast type != "MalList", return(eval_ast(ast, env))) - if(ast isEmpty, return ast) - el := eval_ast(ast, env) - f := el at(0) - args := el rest - f callWithArgList(args) -) - -PRINT := method(exp, exp malPrint(true)) - -repl_env := Map with( - "+", block(a, b, a + b), - "-", block(a, b, a - b), - "*", block(a, b, a * b), - "/", block(a, b, a / b) -) - -RE := method(str, EVAL(READ(str), repl_env)) - -REP := method(str, PRINT(RE(str))) - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - ("Error: " .. (e error)) println - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +eval_ast := method(ast, env, + (ast type) switch( + "MalSymbol", env at(ast val) ifNil(Exception raise("'" .. (ast val) "' not found")), + "MalList", MalList with(ast map(a, EVAL(a, env))), + "MalVector", MalVector with(ast map(a, EVAL(a, env))), + "MalMap", + m := MalMap clone + ast foreach(k, v, + m atPut(k, EVAL(v, env)) + ) + m, + ast + ) +) + +EVAL := method(ast, env, + if(ast type != "MalList", return(eval_ast(ast, env))) + if(ast isEmpty, return ast) + el := eval_ast(ast, env) + f := el at(0) + args := el rest + f callWithArgList(args) +) + +PRINT := method(exp, exp malPrint(true)) + +repl_env := Map with( + "+", block(a, b, a + b), + "-", block(a, b, a - b), + "*", block(a, b, a * b), + "/", block(a, b, a / b) +) + +RE := method(str, EVAL(READ(str), repl_env)) + +REP := method(str, PRINT(RE(str))) + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + ("Error: " .. (e error)) println + ) +) diff --git a/impls/io/step3_env.io b/impls/io/step3_env.io index 87d1195182..b988081611 100644 --- a/impls/io/step3_env.io +++ b/impls/io/step3_env.io @@ -1,68 +1,68 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -eval_ast := method(ast, env, - (ast type) switch( - "MalSymbol", env get(ast), - "MalList", MalList with(ast map(a, EVAL(a, env))), - "MalVector", MalVector with(ast map(a, EVAL(a, env))), - "MalMap", - m := MalMap clone - ast foreach(k, v, - m atPut(k, EVAL(v, env)) - ) - m, - ast - ) -) - -EVAL := method(ast, env, - if(ast type != "MalList", return(eval_ast(ast, env))) - if(ast isEmpty, return ast) - if(ast at(0) type == "MalSymbol", - ast at(0) val switch( - "def!", - return(env set(ast at(1), EVAL(ast at(2), env))), - "let*", - letEnv := Env with(env) - varName := nil - ast at(1) foreach(i, e, - if(i % 2 == 0, - varName := e, - letEnv set(varName, EVAL(e, letEnv)) - ) - ) - return(EVAL(ast at(2), letEnv)) - ) - ) - - // Apply - el := eval_ast(ast, env) - f := el at(0) - args := el rest - f callWithArgList(args) -) - -PRINT := method(exp, exp malPrint(true)) - -repl_env := Env with(nil) -repl_env set(MalSymbol with("+"), block(a, b, a + b)) -repl_env set(MalSymbol with("-"), block(a, b, a - b)) -repl_env set(MalSymbol with("*"), block(a, b, a * b)) -repl_env set(MalSymbol with("/"), block(a, b, a / b)) - -RE := method(str, EVAL(READ(str), repl_env)) - -REP := method(str, PRINT(RE(str))) - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - ("Error: " .. (e error)) println - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +eval_ast := method(ast, env, + (ast type) switch( + "MalSymbol", env get(ast), + "MalList", MalList with(ast map(a, EVAL(a, env))), + "MalVector", MalVector with(ast map(a, EVAL(a, env))), + "MalMap", + m := MalMap clone + ast foreach(k, v, + m atPut(k, EVAL(v, env)) + ) + m, + ast + ) +) + +EVAL := method(ast, env, + if(ast type != "MalList", return(eval_ast(ast, env))) + if(ast isEmpty, return ast) + if(ast at(0) type == "MalSymbol", + ast at(0) val switch( + "def!", + return(env set(ast at(1), EVAL(ast at(2), env))), + "let*", + letEnv := Env with(env) + varName := nil + ast at(1) foreach(i, e, + if(i % 2 == 0, + varName := e, + letEnv set(varName, EVAL(e, letEnv)) + ) + ) + return(EVAL(ast at(2), letEnv)) + ) + ) + + // Apply + el := eval_ast(ast, env) + f := el at(0) + args := el rest + f callWithArgList(args) +) + +PRINT := method(exp, exp malPrint(true)) + +repl_env := Env with(nil) +repl_env set(MalSymbol with("+"), block(a, b, a + b)) +repl_env set(MalSymbol with("-"), block(a, b, a - b)) +repl_env set(MalSymbol with("*"), block(a, b, a * b)) +repl_env set(MalSymbol with("/"), block(a, b, a / b)) + +RE := method(str, EVAL(READ(str), repl_env)) + +REP := method(str, PRINT(RE(str))) + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + ("Error: " .. (e error)) println + ) +) diff --git a/impls/io/step4_if_fn_do.io b/impls/io/step4_if_fn_do.io index 885f1753a2..93694aad93 100644 --- a/impls/io/step4_if_fn_do.io +++ b/impls/io/step4_if_fn_do.io @@ -1,77 +1,77 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -eval_ast := method(ast, env, - (ast type) switch( - "MalSymbol", env get(ast), - "MalList", MalList with(ast map(a, EVAL(a, env))), - "MalVector", MalVector with(ast map(a, EVAL(a, env))), - "MalMap", - m := MalMap clone - ast foreach(k, v, - m atPut(k, EVAL(v, env)) - ) - m, - ast - ) -) - -EVAL := method(ast, env, - if(ast type != "MalList", return(eval_ast(ast, env))) - if(ast isEmpty, return ast) - if(ast at(0) type == "MalSymbol", - ast at(0) val switch( - "def!", - return(env set(ast at(1), EVAL(ast at(2), env))), - "do", - return(eval_ast(ast rest, env) last), - "if", - return(EVAL(if(EVAL(ast at(1), env), ast at(2), ast at(3)), env)), - "fn*", - return(block(a, EVAL(ast at(2), Env with(env, ast at(1), a)))), - "let*", - letEnv := Env with(env) - varName := nil - ast at(1) foreach(i, e, - if(i % 2 == 0, - varName := e, - letEnv set(varName, EVAL(e, letEnv)) - ) - ) - return(EVAL(ast at(2), letEnv)) - ) - ) - - // Apply - el := eval_ast(ast, env) - f := el at(0) - args := el rest - f call(args) -) - -PRINT := method(exp, exp malPrint(true)) - -RE := method(str, EVAL(READ(str), repl_env)) - -REP := method(str, PRINT(RE(str))) - -repl_env := Env with(nil) -MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) - -// core.mal: defined using the language itself -RE("(def! not (fn* (a) (if a false true)))") - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - if(e type == "MalException", - ("Error: " .. ((e val) malPrint(true))) println, - ("Error: " .. (e error)) println - ) - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +eval_ast := method(ast, env, + (ast type) switch( + "MalSymbol", env get(ast), + "MalList", MalList with(ast map(a, EVAL(a, env))), + "MalVector", MalVector with(ast map(a, EVAL(a, env))), + "MalMap", + m := MalMap clone + ast foreach(k, v, + m atPut(k, EVAL(v, env)) + ) + m, + ast + ) +) + +EVAL := method(ast, env, + if(ast type != "MalList", return(eval_ast(ast, env))) + if(ast isEmpty, return ast) + if(ast at(0) type == "MalSymbol", + ast at(0) val switch( + "def!", + return(env set(ast at(1), EVAL(ast at(2), env))), + "do", + return(eval_ast(ast rest, env) last), + "if", + return(EVAL(if(EVAL(ast at(1), env), ast at(2), ast at(3)), env)), + "fn*", + return(block(a, EVAL(ast at(2), Env with(env, ast at(1), a)))), + "let*", + letEnv := Env with(env) + varName := nil + ast at(1) foreach(i, e, + if(i % 2 == 0, + varName := e, + letEnv set(varName, EVAL(e, letEnv)) + ) + ) + return(EVAL(ast at(2), letEnv)) + ) + ) + + // Apply + el := eval_ast(ast, env) + f := el at(0) + args := el rest + f call(args) +) + +PRINT := method(exp, exp malPrint(true)) + +RE := method(str, EVAL(READ(str), repl_env)) + +REP := method(str, PRINT(RE(str))) + +repl_env := Env with(nil) +MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) + +// core.mal: defined using the language itself +RE("(def! not (fn* (a) (if a false true)))") + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) + ) +) diff --git a/impls/io/step5_tco.io b/impls/io/step5_tco.io index db5ba26ae9..1acbb84e1c 100644 --- a/impls/io/step5_tco.io +++ b/impls/io/step5_tco.io @@ -1,92 +1,92 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -eval_ast := method(ast, env, - (ast type) switch( - "MalSymbol", env get(ast), - "MalList", MalList with(ast map(a, EVAL(a, env))), - "MalVector", MalVector with(ast map(a, EVAL(a, env))), - "MalMap", - m := MalMap clone - ast foreach(k, v, - m atPut(k, EVAL(v, env)) - ) - m, - ast - ) -) - -EVAL := method(ast, env, - loop( - if(ast type != "MalList", return(eval_ast(ast, env))) - if(ast isEmpty, return ast) - if(ast at(0) type == "MalSymbol", - ast at(0) val switch( - "def!", - return(env set(ast at(1), EVAL(ast at(2), env))), - "do", - eval_ast(ast slice(1,-1), env) - ast = ast last - continue, // TCO - "if", - ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) - continue, // TCO - "fn*", - return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), - "let*", - letEnv := Env with(env) - varName := nil - ast at(1) foreach(i, e, - if(i % 2 == 0, - varName := e, - letEnv set(varName, EVAL(e, letEnv)) - ) - ) - ast = ast at(2) - env = letEnv - continue // TCO - ) - ) - - // Apply - el := eval_ast(ast, env) - f := el at(0) - args := el rest - f type switch( - "Block", - return(f call(args)), - "MalFunc", - ast = f ast - env = Env with(f env, f params, args) - continue, // TCO - Exception raise("Unknown function type") - ) - ) -) - -PRINT := method(exp, exp malPrint(true)) - -RE := method(str, EVAL(READ(str), repl_env)) - -REP := method(str, PRINT(RE(str))) - -repl_env := Env with(nil) -MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) - -// core.mal: defined using the language itself -RE("(def! not (fn* (a) (if a false true)))") - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - if(e type == "MalException", - ("Error: " .. ((e val) malPrint(true))) println, - ("Error: " .. (e error)) println - ) - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +eval_ast := method(ast, env, + (ast type) switch( + "MalSymbol", env get(ast), + "MalList", MalList with(ast map(a, EVAL(a, env))), + "MalVector", MalVector with(ast map(a, EVAL(a, env))), + "MalMap", + m := MalMap clone + ast foreach(k, v, + m atPut(k, EVAL(v, env)) + ) + m, + ast + ) +) + +EVAL := method(ast, env, + loop( + if(ast type != "MalList", return(eval_ast(ast, env))) + if(ast isEmpty, return ast) + if(ast at(0) type == "MalSymbol", + ast at(0) val switch( + "def!", + return(env set(ast at(1), EVAL(ast at(2), env))), + "do", + eval_ast(ast slice(1,-1), env) + ast = ast last + continue, // TCO + "if", + ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) + continue, // TCO + "fn*", + return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), + "let*", + letEnv := Env with(env) + varName := nil + ast at(1) foreach(i, e, + if(i % 2 == 0, + varName := e, + letEnv set(varName, EVAL(e, letEnv)) + ) + ) + ast = ast at(2) + env = letEnv + continue // TCO + ) + ) + + // Apply + el := eval_ast(ast, env) + f := el at(0) + args := el rest + f type switch( + "Block", + return(f call(args)), + "MalFunc", + ast = f ast + env = Env with(f env, f params, args) + continue, // TCO + Exception raise("Unknown function type") + ) + ) +) + +PRINT := method(exp, exp malPrint(true)) + +RE := method(str, EVAL(READ(str), repl_env)) + +REP := method(str, PRINT(RE(str))) + +repl_env := Env with(nil) +MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) + +// core.mal: defined using the language itself +RE("(def! not (fn* (a) (if a false true)))") + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) + ) +) diff --git a/impls/io/step6_file.io b/impls/io/step6_file.io index 2f70faee15..aee8e42c28 100644 --- a/impls/io/step6_file.io +++ b/impls/io/step6_file.io @@ -1,101 +1,101 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -eval_ast := method(ast, env, - (ast type) switch( - "MalSymbol", env get(ast), - "MalList", MalList with(ast map(a, EVAL(a, env))), - "MalVector", MalVector with(ast map(a, EVAL(a, env))), - "MalMap", - m := MalMap clone - ast foreach(k, v, - m atPut(k, EVAL(v, env)) - ) - m, - ast - ) -) - -EVAL := method(ast, env, - loop( - if(ast type != "MalList", return(eval_ast(ast, env))) - if(ast isEmpty, return ast) - if(ast at(0) type == "MalSymbol", - ast at(0) val switch( - "def!", - return(env set(ast at(1), EVAL(ast at(2), env))), - "do", - eval_ast(ast slice(1,-1), env) - ast = ast last - continue, // TCO - "if", - ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) - continue, // TCO - "fn*", - return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), - "let*", - letEnv := Env with(env) - varName := nil - ast at(1) foreach(i, e, - if(i % 2 == 0, - varName := e, - letEnv set(varName, EVAL(e, letEnv)) - ) - ) - ast = ast at(2) - env = letEnv - continue // TCO - ) - ) - - // Apply - el := eval_ast(ast, env) - f := el at(0) - args := el rest - f type switch( - "Block", - return(f call(args)), - "MalFunc", - ast = f ast - env = Env with(f env, f params, args) - continue, // TCO - Exception raise("Unknown function type") - ) - ) -) - -PRINT := method(exp, exp malPrint(true)) - -repl_env := Env with(nil) - -RE := method(str, EVAL(READ(str), repl_env)) - -REP := method(str, PRINT(RE(str))) - -MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) -repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) -repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) - -// core.mal: defined using the language itself -RE("(def! not (fn* (a) (if a false true)))") -RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if(System args size > 1, - REP("(load-file \"" .. (System args at(1)) .. "\")") - System exit(0) -) - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - if(e type == "MalException", - ("Error: " .. ((e val) malPrint(true))) println, - ("Error: " .. (e error)) println - ) - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +eval_ast := method(ast, env, + (ast type) switch( + "MalSymbol", env get(ast), + "MalList", MalList with(ast map(a, EVAL(a, env))), + "MalVector", MalVector with(ast map(a, EVAL(a, env))), + "MalMap", + m := MalMap clone + ast foreach(k, v, + m atPut(k, EVAL(v, env)) + ) + m, + ast + ) +) + +EVAL := method(ast, env, + loop( + if(ast type != "MalList", return(eval_ast(ast, env))) + if(ast isEmpty, return ast) + if(ast at(0) type == "MalSymbol", + ast at(0) val switch( + "def!", + return(env set(ast at(1), EVAL(ast at(2), env))), + "do", + eval_ast(ast slice(1,-1), env) + ast = ast last + continue, // TCO + "if", + ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) + continue, // TCO + "fn*", + return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), + "let*", + letEnv := Env with(env) + varName := nil + ast at(1) foreach(i, e, + if(i % 2 == 0, + varName := e, + letEnv set(varName, EVAL(e, letEnv)) + ) + ) + ast = ast at(2) + env = letEnv + continue // TCO + ) + ) + + // Apply + el := eval_ast(ast, env) + f := el at(0) + args := el rest + f type switch( + "Block", + return(f call(args)), + "MalFunc", + ast = f ast + env = Env with(f env, f params, args) + continue, // TCO + Exception raise("Unknown function type") + ) + ) +) + +PRINT := method(exp, exp malPrint(true)) + +repl_env := Env with(nil) + +RE := method(str, EVAL(READ(str), repl_env)) + +REP := method(str, PRINT(RE(str))) + +MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) +repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) +repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) + +// core.mal: defined using the language itself +RE("(def! not (fn* (a) (if a false true)))") +RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if(System args size > 1, + REP("(load-file \"" .. (System args at(1)) .. "\")") + System exit(0) +) + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) + ) +) diff --git a/impls/io/step7_quote.io b/impls/io/step7_quote.io index 1ac52462fd..9c1fc82c94 100644 --- a/impls/io/step7_quote.io +++ b/impls/io/step7_quote.io @@ -1,125 +1,125 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -qq_foldr := method(xs, - xs reverseReduce(acc, elt, - if((elt type == "MalList") and (elt size == 2) and (elt at(0) == MalSymbol with("splice-unquote")), - MalList with(list(MalSymbol with("concat"), elt at(1), acc)), - MalList with(list(MalSymbol with("cons"), quasiquote(elt), acc))), - MalList with(list()))) - -quasiquote := method(ast, - ast type switch( - "MalSymbol", MalList with(list(MalSymbol with("quote"), ast)), - "MalMap", MalList with(list(MalSymbol with("quote"), ast)), - "MalVector", MalList with(list(MalSymbol with("vec"), qq_foldr(ast))), - "MalList", if((ast size == 2) and (ast at(0) == MalSymbol with("unquote")), - ast at(1), - qq_foldr(ast)), - ast)) - -eval_ast := method(ast, env, - (ast type) switch( - "MalSymbol", env get(ast), - "MalList", MalList with(ast map(a, EVAL(a, env))), - "MalVector", MalVector with(ast map(a, EVAL(a, env))), - "MalMap", - m := MalMap clone - ast foreach(k, v, - m atPut(k, EVAL(v, env)) - ) - m, - ast - ) -) - -EVAL := method(ast, env, - loop( - if(ast type != "MalList", return(eval_ast(ast, env))) - if(ast isEmpty, return ast) - if(ast at(0) type == "MalSymbol", - ast at(0) val switch( - "def!", - return(env set(ast at(1), EVAL(ast at(2), env))), - "do", - eval_ast(ast slice(1,-1), env) - ast = ast last - continue, // TCO - "if", - ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) - continue, // TCO - "fn*", - return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), - "let*", - letEnv := Env with(env) - varName := nil - ast at(1) foreach(i, e, - if(i % 2 == 0, - varName := e, - letEnv set(varName, EVAL(e, letEnv)) - ) - ) - ast = ast at(2) - env = letEnv - continue, // TCO - "quote", - return(ast at(1)), - "quasiquoteexpand", - return quasiquote(ast at(1)), - "quasiquote", - ast = quasiquote(ast at(1)) - continue // TCO - ) - ) - - // Apply - el := eval_ast(ast, env) - f := el at(0) - args := el rest - f type switch( - "Block", - return(f call(args)), - "MalFunc", - ast = f ast - env = Env with(f env, f params, args) - continue, // TCO - Exception raise("Unknown function type") - ) - ) -) - -PRINT := method(exp, exp malPrint(true)) - -repl_env := Env with(nil) - -RE := method(str, EVAL(READ(str), repl_env)) - -REP := method(str, PRINT(RE(str))) - -MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) -repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) -repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) - -// core.mal: defined using the language itself -RE("(def! not (fn* (a) (if a false true)))") -RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if(System args size > 1, - REP("(load-file \"" .. (System args at(1)) .. "\")") - System exit(0) -) - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - if(e type == "MalException", - ("Error: " .. ((e val) malPrint(true))) println, - ("Error: " .. (e error)) println - ) - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +qq_foldr := method(xs, + xs reverseReduce(acc, elt, + if((elt type == "MalList") and (elt size == 2) and (elt at(0) == MalSymbol with("splice-unquote")), + MalList with(list(MalSymbol with("concat"), elt at(1), acc)), + MalList with(list(MalSymbol with("cons"), quasiquote(elt), acc))), + MalList with(list()))) + +quasiquote := method(ast, + ast type switch( + "MalSymbol", MalList with(list(MalSymbol with("quote"), ast)), + "MalMap", MalList with(list(MalSymbol with("quote"), ast)), + "MalVector", MalList with(list(MalSymbol with("vec"), qq_foldr(ast))), + "MalList", if((ast size == 2) and (ast at(0) == MalSymbol with("unquote")), + ast at(1), + qq_foldr(ast)), + ast)) + +eval_ast := method(ast, env, + (ast type) switch( + "MalSymbol", env get(ast), + "MalList", MalList with(ast map(a, EVAL(a, env))), + "MalVector", MalVector with(ast map(a, EVAL(a, env))), + "MalMap", + m := MalMap clone + ast foreach(k, v, + m atPut(k, EVAL(v, env)) + ) + m, + ast + ) +) + +EVAL := method(ast, env, + loop( + if(ast type != "MalList", return(eval_ast(ast, env))) + if(ast isEmpty, return ast) + if(ast at(0) type == "MalSymbol", + ast at(0) val switch( + "def!", + return(env set(ast at(1), EVAL(ast at(2), env))), + "do", + eval_ast(ast slice(1,-1), env) + ast = ast last + continue, // TCO + "if", + ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) + continue, // TCO + "fn*", + return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), + "let*", + letEnv := Env with(env) + varName := nil + ast at(1) foreach(i, e, + if(i % 2 == 0, + varName := e, + letEnv set(varName, EVAL(e, letEnv)) + ) + ) + ast = ast at(2) + env = letEnv + continue, // TCO + "quote", + return(ast at(1)), + "quasiquoteexpand", + return quasiquote(ast at(1)), + "quasiquote", + ast = quasiquote(ast at(1)) + continue // TCO + ) + ) + + // Apply + el := eval_ast(ast, env) + f := el at(0) + args := el rest + f type switch( + "Block", + return(f call(args)), + "MalFunc", + ast = f ast + env = Env with(f env, f params, args) + continue, // TCO + Exception raise("Unknown function type") + ) + ) +) + +PRINT := method(exp, exp malPrint(true)) + +repl_env := Env with(nil) + +RE := method(str, EVAL(READ(str), repl_env)) + +REP := method(str, PRINT(RE(str))) + +MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) +repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) +repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) + +// core.mal: defined using the language itself +RE("(def! not (fn* (a) (if a false true)))") +RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if(System args size > 1, + REP("(load-file \"" .. (System args at(1)) .. "\")") + System exit(0) +) + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) + ) +) diff --git a/impls/io/step8_macros.io b/impls/io/step8_macros.io index 102b1e31f1..7f560884ec 100644 --- a/impls/io/step8_macros.io +++ b/impls/io/step8_macros.io @@ -1,151 +1,151 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -qq_foldr := method(xs, - xs reverseReduce(acc, elt, - if((elt type == "MalList") and (elt size == 2) and (elt at(0) == MalSymbol with("splice-unquote")), - MalList with(list(MalSymbol with("concat"), elt at(1), acc)), - MalList with(list(MalSymbol with("cons"), quasiquote(elt), acc))), - MalList with(list()))) - -quasiquote := method(ast, - ast type switch( - "MalSymbol", MalList with(list(MalSymbol with("quote"), ast)), - "MalMap", MalList with(list(MalSymbol with("quote"), ast)), - "MalVector", MalList with(list(MalSymbol with("vec"), qq_foldr(ast))), - "MalList", if((ast size == 2) and (ast at(0) == MalSymbol with("unquote")), - ast at(1), - qq_foldr(ast)), - ast)) - -isMacroCall := method(ast, env, - if(ast type != "MalList", return false) - a0 := ast first - if(a0 type != "MalSymbol", return false) - if(env find(a0) isNil, return false) - f := env get(a0) - (f type == "MalFunc") and (f isMacro) -) - -macroexpand := method(ast, env, - while(isMacroCall(ast, env), - macro := env get(ast at(0)) - ast = macro blk call(ast rest) - ) - ast -) - -eval_ast := method(ast, env, - (ast type) switch( - "MalSymbol", env get(ast), - "MalList", MalList with(ast map(a, EVAL(a, env))), - "MalVector", MalVector with(ast map(a, EVAL(a, env))), - "MalMap", - m := MalMap clone - ast foreach(k, v, - m atPut(k, EVAL(v, env)) - ) - m, - ast - ) -) - -EVAL := method(ast, env, - loop( - if(ast type != "MalList", return(eval_ast(ast, env))) - - ast = macroexpand(ast, env) - if(ast type != "MalList", return(eval_ast(ast, env))) - if(ast isEmpty, return ast) - - if(ast at(0) type == "MalSymbol", - ast at(0) val switch( - "def!", - return(env set(ast at(1), EVAL(ast at(2), env))), - "do", - eval_ast(ast slice(1,-1), env) - ast = ast last - continue, // TCO - "if", - ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) - continue, // TCO - "fn*", - return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), - "let*", - letEnv := Env with(env) - varName := nil - ast at(1) foreach(i, e, - if(i % 2 == 0, - varName := e, - letEnv set(varName, EVAL(e, letEnv)) - ) - ) - ast = ast at(2) - env = letEnv - continue, // TCO - "quote", - return(ast at(1)), - "quasiquoteexpand", - return quasiquote(ast at(1)), - "quasiquote", - ast = quasiquote(ast at(1)) - continue, // TCO - "defmacro!", - return(env set(ast at(1), EVAL(ast at(2), env) clone setIsMacro(true))), - "macroexpand", - return(macroexpand(ast at(1), env)) - ) - ) - - // Apply - el := eval_ast(ast, env) - f := el at(0) - args := el rest - f type switch( - "Block", - return(f call(args)), - "MalFunc", - ast = f ast - env = Env with(f env, f params, args) - continue, // TCO - Exception raise("Unknown function type") - ) - ) -) - -PRINT := method(exp, exp malPrint(true)) - -repl_env := Env with(nil) - -RE := method(str, EVAL(READ(str), repl_env)) - -REP := method(str, PRINT(RE(str))) - -MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) -repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) -repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) - -// core.mal: defined using the language itself -RE("(def! not (fn* (a) (if a false true)))") -RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -RE("(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)))))))") - -if(System args size > 1, - REP("(load-file \"" .. (System args at(1)) .. "\")") - System exit(0) -) - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - if(e type == "MalException", - ("Error: " .. ((e val) malPrint(true))) println, - ("Error: " .. (e error)) println - ) - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +qq_foldr := method(xs, + xs reverseReduce(acc, elt, + if((elt type == "MalList") and (elt size == 2) and (elt at(0) == MalSymbol with("splice-unquote")), + MalList with(list(MalSymbol with("concat"), elt at(1), acc)), + MalList with(list(MalSymbol with("cons"), quasiquote(elt), acc))), + MalList with(list()))) + +quasiquote := method(ast, + ast type switch( + "MalSymbol", MalList with(list(MalSymbol with("quote"), ast)), + "MalMap", MalList with(list(MalSymbol with("quote"), ast)), + "MalVector", MalList with(list(MalSymbol with("vec"), qq_foldr(ast))), + "MalList", if((ast size == 2) and (ast at(0) == MalSymbol with("unquote")), + ast at(1), + qq_foldr(ast)), + ast)) + +isMacroCall := method(ast, env, + if(ast type != "MalList", return false) + a0 := ast first + if(a0 type != "MalSymbol", return false) + if(env find(a0) isNil, return false) + f := env get(a0) + (f type == "MalFunc") and (f isMacro) +) + +macroexpand := method(ast, env, + while(isMacroCall(ast, env), + macro := env get(ast at(0)) + ast = macro blk call(ast rest) + ) + ast +) + +eval_ast := method(ast, env, + (ast type) switch( + "MalSymbol", env get(ast), + "MalList", MalList with(ast map(a, EVAL(a, env))), + "MalVector", MalVector with(ast map(a, EVAL(a, env))), + "MalMap", + m := MalMap clone + ast foreach(k, v, + m atPut(k, EVAL(v, env)) + ) + m, + ast + ) +) + +EVAL := method(ast, env, + loop( + if(ast type != "MalList", return(eval_ast(ast, env))) + + ast = macroexpand(ast, env) + if(ast type != "MalList", return(eval_ast(ast, env))) + if(ast isEmpty, return ast) + + if(ast at(0) type == "MalSymbol", + ast at(0) val switch( + "def!", + return(env set(ast at(1), EVAL(ast at(2), env))), + "do", + eval_ast(ast slice(1,-1), env) + ast = ast last + continue, // TCO + "if", + ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) + continue, // TCO + "fn*", + return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), + "let*", + letEnv := Env with(env) + varName := nil + ast at(1) foreach(i, e, + if(i % 2 == 0, + varName := e, + letEnv set(varName, EVAL(e, letEnv)) + ) + ) + ast = ast at(2) + env = letEnv + continue, // TCO + "quote", + return(ast at(1)), + "quasiquoteexpand", + return quasiquote(ast at(1)), + "quasiquote", + ast = quasiquote(ast at(1)) + continue, // TCO + "defmacro!", + return(env set(ast at(1), EVAL(ast at(2), env) clone setIsMacro(true))), + "macroexpand", + return(macroexpand(ast at(1), env)) + ) + ) + + // Apply + el := eval_ast(ast, env) + f := el at(0) + args := el rest + f type switch( + "Block", + return(f call(args)), + "MalFunc", + ast = f ast + env = Env with(f env, f params, args) + continue, // TCO + Exception raise("Unknown function type") + ) + ) +) + +PRINT := method(exp, exp malPrint(true)) + +repl_env := Env with(nil) + +RE := method(str, EVAL(READ(str), repl_env)) + +REP := method(str, PRINT(RE(str))) + +MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) +repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) +repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) + +// core.mal: defined using the language itself +RE("(def! not (fn* (a) (if a false true)))") +RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +RE("(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)))))))") + +if(System args size > 1, + REP("(load-file \"" .. (System args at(1)) .. "\")") + System exit(0) +) + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) + ) +) diff --git a/impls/io/step9_try.io b/impls/io/step9_try.io index b2d966e413..fdcda9f63b 100644 --- a/impls/io/step9_try.io +++ b/impls/io/step9_try.io @@ -1,162 +1,162 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -qq_foldr := method(xs, - xs reverseReduce(acc, elt, - if((elt type == "MalList") and (elt size == 2) and (elt at(0) == MalSymbol with("splice-unquote")), - MalList with(list(MalSymbol with("concat"), elt at(1), acc)), - MalList with(list(MalSymbol with("cons"), quasiquote(elt), acc))), - MalList with(list()))) - -quasiquote := method(ast, - ast type switch( - "MalSymbol", MalList with(list(MalSymbol with("quote"), ast)), - "MalMap", MalList with(list(MalSymbol with("quote"), ast)), - "MalVector", MalList with(list(MalSymbol with("vec"), qq_foldr(ast))), - "MalList", if((ast size == 2) and (ast at(0) == MalSymbol with("unquote")), - ast at(1), - qq_foldr(ast)), - ast)) - -isMacroCall := method(ast, env, - if(ast type != "MalList", return false) - a0 := ast first - if(a0 type != "MalSymbol", return false) - if(env find(a0) isNil, return false) - f := env get(a0) - (f type == "MalFunc") and (f isMacro) -) - -macroexpand := method(ast, env, - while(isMacroCall(ast, env), - macro := env get(ast at(0)) - ast = macro blk call(ast rest) - ) - ast -) - -eval_ast := method(ast, env, - (ast type) switch( - "MalSymbol", env get(ast), - "MalList", MalList with(ast map(a, EVAL(a, env))), - "MalVector", MalVector with(ast map(a, EVAL(a, env))), - "MalMap", - m := MalMap clone - ast foreach(k, v, - m atPut(k, EVAL(v, env)) - ) - m, - ast - ) -) - -EVAL := method(ast, env, - loop( - if(ast type != "MalList", return(eval_ast(ast, env))) - - ast = macroexpand(ast, env) - if(ast type != "MalList", return(eval_ast(ast, env))) - if(ast isEmpty, return ast) - - if(ast at(0) type == "MalSymbol", - ast at(0) val switch( - "def!", - return(env set(ast at(1), EVAL(ast at(2), env))), - "do", - eval_ast(ast slice(1,-1), env) - ast = ast last - continue, // TCO - "if", - ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) - continue, // TCO - "fn*", - return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), - "let*", - letEnv := Env with(env) - varName := nil - ast at(1) foreach(i, e, - if(i % 2 == 0, - varName := e, - letEnv set(varName, EVAL(e, letEnv)) - ) - ) - ast = ast at(2) - env = letEnv - continue, // TCO - "quote", - return(ast at(1)), - "quasiquoteexpand", - return quasiquote(ast at(1)), - "quasiquote", - ast = quasiquote(ast at(1)) - continue, // TCO - "defmacro!", - return(env set(ast at(1), EVAL(ast at(2), env) clone setIsMacro(true))), - "macroexpand", - return(macroexpand(ast at(1), env)), - "try*", - if(ast at(2) == nil, return(EVAL(ast at(1), env))) - e := try(result := EVAL(ast at(1), env)) - e catch(Exception, - exc := if(e type == "MalException", e val, e error) - catchAst := ast at(2) - catchEnv := Env with(env) - catchEnv set(catchAst at(1), exc) - result := EVAL(catchAst at(2), catchEnv) - ) - return(result) - ) - ) - - // Apply - el := eval_ast(ast, env) - f := el at(0) - args := el rest - f type switch( - "Block", - return(f call(args)), - "MalFunc", - ast = f ast - env = Env with(f env, f params, args) - continue, // TCO - Exception raise("Unknown function type") - ) - ) -) - -PRINT := method(exp, exp malPrint(true)) - -repl_env := Env with(nil) - -RE := method(str, EVAL(READ(str), repl_env)) - -REP := method(str, PRINT(RE(str))) - -MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) -repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) -repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) - -// core.mal: defined using the language itself -RE("(def! not (fn* (a) (if a false true)))") -RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -RE("(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)))))))") - -if(System args size > 1, - REP("(load-file \"" .. (System args at(1)) .. "\")") - System exit(0) -) - -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - if(e type == "MalException", - ("Error: " .. ((e val) malPrint(true))) println, - ("Error: " .. (e error)) println - ) - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +qq_foldr := method(xs, + xs reverseReduce(acc, elt, + if((elt type == "MalList") and (elt size == 2) and (elt at(0) == MalSymbol with("splice-unquote")), + MalList with(list(MalSymbol with("concat"), elt at(1), acc)), + MalList with(list(MalSymbol with("cons"), quasiquote(elt), acc))), + MalList with(list()))) + +quasiquote := method(ast, + ast type switch( + "MalSymbol", MalList with(list(MalSymbol with("quote"), ast)), + "MalMap", MalList with(list(MalSymbol with("quote"), ast)), + "MalVector", MalList with(list(MalSymbol with("vec"), qq_foldr(ast))), + "MalList", if((ast size == 2) and (ast at(0) == MalSymbol with("unquote")), + ast at(1), + qq_foldr(ast)), + ast)) + +isMacroCall := method(ast, env, + if(ast type != "MalList", return false) + a0 := ast first + if(a0 type != "MalSymbol", return false) + if(env find(a0) isNil, return false) + f := env get(a0) + (f type == "MalFunc") and (f isMacro) +) + +macroexpand := method(ast, env, + while(isMacroCall(ast, env), + macro := env get(ast at(0)) + ast = macro blk call(ast rest) + ) + ast +) + +eval_ast := method(ast, env, + (ast type) switch( + "MalSymbol", env get(ast), + "MalList", MalList with(ast map(a, EVAL(a, env))), + "MalVector", MalVector with(ast map(a, EVAL(a, env))), + "MalMap", + m := MalMap clone + ast foreach(k, v, + m atPut(k, EVAL(v, env)) + ) + m, + ast + ) +) + +EVAL := method(ast, env, + loop( + if(ast type != "MalList", return(eval_ast(ast, env))) + + ast = macroexpand(ast, env) + if(ast type != "MalList", return(eval_ast(ast, env))) + if(ast isEmpty, return ast) + + if(ast at(0) type == "MalSymbol", + ast at(0) val switch( + "def!", + return(env set(ast at(1), EVAL(ast at(2), env))), + "do", + eval_ast(ast slice(1,-1), env) + ast = ast last + continue, // TCO + "if", + ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) + continue, // TCO + "fn*", + return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), + "let*", + letEnv := Env with(env) + varName := nil + ast at(1) foreach(i, e, + if(i % 2 == 0, + varName := e, + letEnv set(varName, EVAL(e, letEnv)) + ) + ) + ast = ast at(2) + env = letEnv + continue, // TCO + "quote", + return(ast at(1)), + "quasiquoteexpand", + return quasiquote(ast at(1)), + "quasiquote", + ast = quasiquote(ast at(1)) + continue, // TCO + "defmacro!", + return(env set(ast at(1), EVAL(ast at(2), env) clone setIsMacro(true))), + "macroexpand", + return(macroexpand(ast at(1), env)), + "try*", + if(ast at(2) == nil, return(EVAL(ast at(1), env))) + e := try(result := EVAL(ast at(1), env)) + e catch(Exception, + exc := if(e type == "MalException", e val, e error) + catchAst := ast at(2) + catchEnv := Env with(env) + catchEnv set(catchAst at(1), exc) + result := EVAL(catchAst at(2), catchEnv) + ) + return(result) + ) + ) + + // Apply + el := eval_ast(ast, env) + f := el at(0) + args := el rest + f type switch( + "Block", + return(f call(args)), + "MalFunc", + ast = f ast + env = Env with(f env, f params, args) + continue, // TCO + Exception raise("Unknown function type") + ) + ) +) + +PRINT := method(exp, exp malPrint(true)) + +repl_env := Env with(nil) + +RE := method(str, EVAL(READ(str), repl_env)) + +REP := method(str, PRINT(RE(str))) + +MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) +repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) +repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) + +// core.mal: defined using the language itself +RE("(def! not (fn* (a) (if a false true)))") +RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +RE("(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)))))))") + +if(System args size > 1, + REP("(load-file \"" .. (System args at(1)) .. "\")") + System exit(0) +) + +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) + ) +) diff --git a/impls/io/stepA_mal.io b/impls/io/stepA_mal.io index ee0fbe4fa7..b06cb6e2bf 100644 --- a/impls/io/stepA_mal.io +++ b/impls/io/stepA_mal.io @@ -1,164 +1,164 @@ -MalTypes -MalReader - -READ := method(str, MalReader read_str(str)) - -qq_foldr := method(xs, - xs reverseReduce(acc, elt, - if((elt type == "MalList") and (elt size == 2) and (elt at(0) == MalSymbol with("splice-unquote")), - MalList with(list(MalSymbol with("concat"), elt at(1), acc)), - MalList with(list(MalSymbol with("cons"), quasiquote(elt), acc))), - MalList with(list()))) - -quasiquote := method(ast, - ast type switch( - "MalSymbol", MalList with(list(MalSymbol with("quote"), ast)), - "MalMap", MalList with(list(MalSymbol with("quote"), ast)), - "MalVector", MalList with(list(MalSymbol with("vec"), qq_foldr(ast))), - "MalList", if((ast size == 2) and (ast at(0) == MalSymbol with("unquote")), - ast at(1), - qq_foldr(ast)), - ast)) - -isMacroCall := method(ast, env, - if(ast type != "MalList", return false) - a0 := ast first - if(a0 type != "MalSymbol", return false) - if(env find(a0) isNil, return false) - f := env get(a0) - (f type == "MalFunc") and (f isMacro) -) - -macroexpand := method(ast, env, - while(isMacroCall(ast, env), - macro := env get(ast at(0)) - ast = macro blk call(ast rest) - ) - ast -) - -eval_ast := method(ast, env, - (ast type) switch( - "MalSymbol", env get(ast), - "MalList", MalList with(ast map(a, EVAL(a, env))), - "MalVector", MalVector with(ast map(a, EVAL(a, env))), - "MalMap", - m := MalMap clone - ast foreach(k, v, - m atPut(k, EVAL(v, env)) - ) - m, - ast - ) -) - -EVAL := method(ast, env, - loop( - if(ast type != "MalList", return(eval_ast(ast, env))) - - ast = macroexpand(ast, env) - if(ast type != "MalList", return(eval_ast(ast, env))) - if(ast isEmpty, return ast) - - if(ast at(0) type == "MalSymbol", - ast at(0) val switch( - "def!", - return(env set(ast at(1), EVAL(ast at(2), env))), - "do", - eval_ast(ast slice(1,-1), env) - ast = ast last - continue, // TCO - "if", - ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) - continue, // TCO - "fn*", - return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), - "let*", - letEnv := Env with(env) - varName := nil - ast at(1) foreach(i, e, - if(i % 2 == 0, - varName := e, - letEnv set(varName, EVAL(e, letEnv)) - ) - ) - ast = ast at(2) - env = letEnv - continue, // TCO - "quote", - return(ast at(1)), - "quasiquoteexpand", - return quasiquote(ast at(1)), - "quasiquote", - ast = quasiquote(ast at(1)) - continue, // TCO - "defmacro!", - return(env set(ast at(1), EVAL(ast at(2), env) clone setIsMacro(true))), - "macroexpand", - return(macroexpand(ast at(1), env)), - "try*", - if(ast at(2) == nil, return(EVAL(ast at(1), env))) - e := try(result := EVAL(ast at(1), env)) - e catch(Exception, - exc := if(e type == "MalException", e val, e error) - catchAst := ast at(2) - catchEnv := Env with(env) - catchEnv set(catchAst at(1), exc) - result := EVAL(catchAst at(2), catchEnv) - ) - return(result) - ) - ) - - // Apply - el := eval_ast(ast, env) - f := el at(0) - args := el rest - f type switch( - "Block", - return(f call(args)), - "MalFunc", - ast = f ast - env = Env with(f env, f params, args) - continue, // TCO - Exception raise("Unknown function type") - ) - ) -) - -PRINT := method(exp, exp malPrint(true)) - -repl_env := Env with(nil) - -RE := method(str, EVAL(READ(str), repl_env)) - -REP := method(str, PRINT(RE(str))) - -MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) -repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) -repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) - -// core.mal: defined using the language itself -RE("(def! *host-language* \"io\")") -RE("(def! not (fn* (a) (if a false true)))") -RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -RE("(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)))))))") - -if(System args size > 1, - REP("(load-file \"" .. (System args at(1)) .. "\")") - System exit(0) -) - -RE("(println (str \"Mal [\" *host-language* \"]\"))") -loop( - line := MalReadline readLine("user> ") - if(line isNil, break) - if(line isEmpty, continue) - e := try(REP(line) println) - e catch(Exception, - if(e type == "MalException", - ("Error: " .. ((e val) malPrint(true))) println, - ("Error: " .. (e error)) println - ) - ) -) +MalTypes +MalReader + +READ := method(str, MalReader read_str(str)) + +qq_foldr := method(xs, + xs reverseReduce(acc, elt, + if((elt type == "MalList") and (elt size == 2) and (elt at(0) == MalSymbol with("splice-unquote")), + MalList with(list(MalSymbol with("concat"), elt at(1), acc)), + MalList with(list(MalSymbol with("cons"), quasiquote(elt), acc))), + MalList with(list()))) + +quasiquote := method(ast, + ast type switch( + "MalSymbol", MalList with(list(MalSymbol with("quote"), ast)), + "MalMap", MalList with(list(MalSymbol with("quote"), ast)), + "MalVector", MalList with(list(MalSymbol with("vec"), qq_foldr(ast))), + "MalList", if((ast size == 2) and (ast at(0) == MalSymbol with("unquote")), + ast at(1), + qq_foldr(ast)), + ast)) + +isMacroCall := method(ast, env, + if(ast type != "MalList", return false) + a0 := ast first + if(a0 type != "MalSymbol", return false) + if(env find(a0) isNil, return false) + f := env get(a0) + (f type == "MalFunc") and (f isMacro) +) + +macroexpand := method(ast, env, + while(isMacroCall(ast, env), + macro := env get(ast at(0)) + ast = macro blk call(ast rest) + ) + ast +) + +eval_ast := method(ast, env, + (ast type) switch( + "MalSymbol", env get(ast), + "MalList", MalList with(ast map(a, EVAL(a, env))), + "MalVector", MalVector with(ast map(a, EVAL(a, env))), + "MalMap", + m := MalMap clone + ast foreach(k, v, + m atPut(k, EVAL(v, env)) + ) + m, + ast + ) +) + +EVAL := method(ast, env, + loop( + if(ast type != "MalList", return(eval_ast(ast, env))) + + ast = macroexpand(ast, env) + if(ast type != "MalList", return(eval_ast(ast, env))) + if(ast isEmpty, return ast) + + if(ast at(0) type == "MalSymbol", + ast at(0) val switch( + "def!", + return(env set(ast at(1), EVAL(ast at(2), env))), + "do", + eval_ast(ast slice(1,-1), env) + ast = ast last + continue, // TCO + "if", + ast = if(EVAL(ast at(1), env), ast at(2), ast at(3)) + continue, // TCO + "fn*", + return(MalFunc with(ast at(2), ast at(1), env, block(a, EVAL(ast at(2), Env with(env, ast at(1), a))))), + "let*", + letEnv := Env with(env) + varName := nil + ast at(1) foreach(i, e, + if(i % 2 == 0, + varName := e, + letEnv set(varName, EVAL(e, letEnv)) + ) + ) + ast = ast at(2) + env = letEnv + continue, // TCO + "quote", + return(ast at(1)), + "quasiquoteexpand", + return quasiquote(ast at(1)), + "quasiquote", + ast = quasiquote(ast at(1)) + continue, // TCO + "defmacro!", + return(env set(ast at(1), EVAL(ast at(2), env) clone setIsMacro(true))), + "macroexpand", + return(macroexpand(ast at(1), env)), + "try*", + if(ast at(2) == nil, return(EVAL(ast at(1), env))) + e := try(result := EVAL(ast at(1), env)) + e catch(Exception, + exc := if(e type == "MalException", e val, e error) + catchAst := ast at(2) + catchEnv := Env with(env) + catchEnv set(catchAst at(1), exc) + result := EVAL(catchAst at(2), catchEnv) + ) + return(result) + ) + ) + + // Apply + el := eval_ast(ast, env) + f := el at(0) + args := el rest + f type switch( + "Block", + return(f call(args)), + "MalFunc", + ast = f ast + env = Env with(f env, f params, args) + continue, // TCO + Exception raise("Unknown function type") + ) + ) +) + +PRINT := method(exp, exp malPrint(true)) + +repl_env := Env with(nil) + +RE := method(str, EVAL(READ(str), repl_env)) + +REP := method(str, PRINT(RE(str))) + +MalCore NS foreach(k, v, repl_env set(MalSymbol with(k), v)) +repl_env set(MalSymbol with("eval"), block(a, EVAL(a at(0), repl_env))) +repl_env set(MalSymbol with("*ARGV*"), MalList with(System args slice(2))) + +// core.mal: defined using the language itself +RE("(def! *host-language* \"io\")") +RE("(def! not (fn* (a) (if a false true)))") +RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +RE("(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)))))))") + +if(System args size > 1, + REP("(load-file \"" .. (System args at(1)) .. "\")") + System exit(0) +) + +RE("(println (str \"Mal [\" *host-language* \"]\"))") +loop( + line := MalReadline readLine("user> ") + if(line isNil, break) + if(line isEmpty, continue) + e := try(REP(line) println) + e catch(Exception, + if(e type == "MalException", + ("Error: " .. ((e val) malPrint(true))) println, + ("Error: " .. (e error)) println + ) + ) +) diff --git a/impls/io/tests/step5_tco.mal b/impls/io/tests/step5_tco.mal index 58142ab23c..a6134eff50 100644 --- a/impls/io/tests/step5_tco.mal +++ b/impls/io/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Io: skipping non-TCO recursion -;; Reason: never completes, never segfaults +;; Io: skipping non-TCO recursion +;; Reason: never completes, never segfaults diff --git a/impls/io/tests/stepA_mal.mal b/impls/io/tests/stepA_mal.mal index 5b0f5dcdd3..3969ff2d8c 100644 --- a/impls/io/tests/stepA_mal.mal +++ b/impls/io/tests/stepA_mal.mal @@ -1,33 +1,33 @@ -;; Testing basic Io interop - -(io-eval "7") -;=>7 - -(io-eval "\"7\"") -;=>"7" - -(io-eval "123 == 123") -;=>true - -(io-eval "123 == 456") -;=>false - -(io-eval "list(7, 8, 9)") -;=>(7 8 9) - -(io-eval "Map with(\"abc\", 789)") -;=>{"abc" 789} - -(io-eval "\"hello\" println") -;/hello -;=>"hello" - -(io-eval "Lobby foo := 8") -(io-eval "Lobby foo") -;=>8 - -(io-eval "list(\"a\", \"b\", \"c\") map(x, \"X\" .. x .. \"Y\") join(\" \")") -;=>"XaY XbY XcY" - -(io-eval "list(1, 2, 3) map(x, 1 + x)") -;=>(2 3 4) +;; Testing basic Io interop + +(io-eval "7") +;=>7 + +(io-eval "\"7\"") +;=>"7" + +(io-eval "123 == 123") +;=>true + +(io-eval "123 == 456") +;=>false + +(io-eval "list(7, 8, 9)") +;=>(7 8 9) + +(io-eval "Map with(\"abc\", 789)") +;=>{"abc" 789} + +(io-eval "\"hello\" println") +;/hello +;=>"hello" + +(io-eval "Lobby foo := 8") +(io-eval "Lobby foo") +;=>8 + +(io-eval "list(\"a\", \"b\", \"c\") map(x, \"X\" .. x .. \"Y\") join(\" \")") +;=>"XaY XbY XcY" + +(io-eval "list(1, 2, 3) map(x, 1 + x)") +;=>(2 3 4) diff --git a/impls/janet/Dockerfile b/impls/janet/Dockerfile index 37f242cae7..8f9375c931 100644 --- a/impls/janet/Dockerfile +++ b/impls/janet/Dockerfile @@ -1,29 +1,29 @@ -FROM ubuntu:20.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install wget libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# janet -RUN cd /usr/lib/x86_64-linux-gnu/ \ - && wget https://github.com/janet-lang/janet/releases/download/v1.12.2/janet-v1.12.2-linux.tar.gz \ - && tar xvzf janet-v1.12.2-linux.tar.gz \ - && ln -sf /usr/lib/x86_64-linux-gnu/janet-v1.12.2-linux/janet /usr/bin/janet \ - && rm janet-v1.12.2-linux.tar.gz +FROM ubuntu:20.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install wget libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# janet +RUN cd /usr/lib/x86_64-linux-gnu/ \ + && wget https://github.com/janet-lang/janet/releases/download/v1.12.2/janet-v1.12.2-linux.tar.gz \ + && tar xvzf janet-v1.12.2-linux.tar.gz \ + && ln -sf /usr/lib/x86_64-linux-gnu/janet-v1.12.2-linux/janet /usr/bin/janet \ + && rm janet-v1.12.2-linux.tar.gz diff --git a/impls/janet/Makefile b/impls/janet/Makefile index 8a7cbb717e..b52aefe1d1 100644 --- a/impls/janet/Makefile +++ b/impls/janet/Makefile @@ -1,2 +1,2 @@ -all: - true +all: + true diff --git a/impls/janet/core.janet b/impls/janet/core.janet index ba7eb5956e..ce7c83411a 100644 --- a/impls/janet/core.janet +++ b/impls/janet/core.janet @@ -1,777 +1,777 @@ -(import ./types :as t) -(import ./utils :as u) -(import ./printer) -(import ./reader) - -(defn deref* - [ast] - (if (not (t/atom?* ast)) - (u/throw* (t/make-string (string "Expected atom, got: " (t/get-type ast)))) - (t/get-value ast))) - -(defn reset!* - [atom-ast val-ast] - (t/set-atom-value! atom-ast val-ast) - val-ast) - -(defn cons* - [head-ast tail-ast] - [head-ast ;(t/get-value tail-ast)]) - -(defn concat* - [& list-asts] - (reduce (fn [acc list-ast] - [;acc ;(t/get-value list-ast)]) - [] - list-asts)) - -(defn nth* - [coll-ast num-ast] - (let [elts (t/get-value coll-ast) - n-elts (length elts) - i (t/get-value num-ast)] - (if (< i n-elts) - (in elts i) - (u/throw* (t/make-string (string "Index out of range: " i)))))) - -(defn first* - [coll-or-nil-ast] - (if (or (t/nil?* coll-or-nil-ast) - (t/empty?* coll-or-nil-ast)) - t/mal-nil - (in (t/get-value coll-or-nil-ast) 0))) - -(defn rest* - [coll-or-nil-ast] - (if (or (t/nil?* coll-or-nil-ast) - (t/empty?* coll-or-nil-ast)) - (t/make-list []) - (t/make-list (slice (t/get-value coll-or-nil-ast) 1)))) - -(defn janet-eval* - [janet-val] - (case (type janet-val) - :nil - t/mal-nil - ## - :boolean - (t/make-boolean janet-val) - ## - :number # XXX: there may be some incompatibilities - (t/make-number janet-val) - ## - :string - (t/make-string janet-val) - ## - :keyword # XXX: there may be some incompatibilities - (t/make-keyword (string ":" janet-val)) - ## - :symbol # XXX: there may be some incompatibilities - (t/make-symbol (string janet-val)) - ## - :tuple - (t/make-list (map janet-eval* janet-val)) - ## - :array - (t/make-list (map janet-eval* janet-val)) - ## - :struct - (t/make-hash-map (struct ;(map janet-eval* (kvs janet-val)))) - ## - :table - (t/make-hash-map (struct ;(map janet-eval* (kvs janet-val)))) - ## - (u/throw* (t/make-string (string "Unsupported type: " (type janet-val)))))) - -(defn arith-fn - [op] - (t/make-function - (fn [asts] - (t/make-number - (op ;(map |(t/get-value $) - asts)))))) - -(defn cmp-fn - [op] - (t/make-function - (fn [asts] - (if (op ;(map |(t/get-value $) asts)) - t/mal-true - t/mal-false)))) - -(def mal-symbol - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "symbol requires 1 argument"))) - (t/make-symbol (t/get-value (in asts 0)))))) - -(def mal-keyword - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "keyword requires 1 argument"))) - (let [arg-ast (in asts 0)] - (cond - (t/keyword?* arg-ast) - arg-ast - ## - (t/string?* arg-ast) - (t/make-keyword (string ":" (t/get-value arg-ast))) - ## - (u/throw* (t/make-string "Expected string"))))))) - -(def mal-list - (t/make-function - (fn [asts] - (t/make-list asts)))) - -(def mal-vector - (t/make-function - (fn [asts] - (t/make-vector asts)))) - -(def mal-vec - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "vec requires 1 argument"))) - (let [ast (in asts 0)] - (cond - (t/vector?* ast) - ast - ## - (t/list?* ast) - (t/make-vector (t/get-value ast)) - ## - (t/nil?* ast) - (t/make-vector ()) - ## - (u/throw* (t/make-string "vec requires a vector, list, or nil"))))))) - -(def mal-hash-map - (t/make-function - (fn [asts] - (when (= 1 (% (length asts) 2)) - (u/throw* (t/make-string - "hash-map requires an even number of arguments"))) - (t/make-hash-map asts)))) - -(def mal-atom - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "atom requires 1 argument"))) - (t/make-atom (in asts 0))))) - -(def mal-nil? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "nil? requires 1 argument"))) - (if (t/nil?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-true? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "true? requires 1 argument"))) - (if (t/true?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-false? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "false? requires 1 argument"))) - (if (t/false?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-number? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "number? requires 1 argument"))) - (if (t/number?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-symbol? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "symbol? requires 1 argument"))) - (if (t/symbol?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-keyword? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "keyword? requires 1 argument"))) - (if (t/keyword?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-string? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "string? requires 1 argument"))) - (if (t/string?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-list? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "list? requires 1 argument"))) - (if (t/list?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-vector? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "vector? requires 1 argument"))) - (if (t/vector?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-map? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "map? requires 1 argument"))) - (if (t/hash-map?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-fn? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "fn? requires 1 argument"))) - (let [target-ast (in asts 0)] - (if (and (t/fn?* target-ast) - (not (t/get-is-macro target-ast))) - t/mal-true - t/mal-false))))) - -(def mal-macro? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "macro? requires 1 argument"))) - (let [the-ast (in asts 0)] - (if (t/macro?* the-ast) - t/mal-true - t/mal-false))))) - -(def mal-atom? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "atom? requires 1 argument"))) - (if (t/atom?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-sequential? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "sequential? requires 1 argument"))) - (if (or (t/list?* (in asts 0)) - (t/vector?* (in asts 0))) - t/mal-true - t/mal-false)))) - -(def mal-= - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "= requires 2 arguments"))) - (let [ast-1 (in asts 0) - ast-2 (in asts 1)] - (if (t/equals?* ast-1 ast-2) - t/mal-true - t/mal-false))))) - -(def mal-empty? - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "empty? requires 1 argument"))) - (if (t/empty?* (in asts 0)) - t/mal-true - t/mal-false)))) - -(def mal-contains? - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "contains? requires 2 arguments"))) - (let [head-ast (in asts 0)] - (when (not (or (t/hash-map?* head-ast) - (t/nil?* head-ast))) - (u/throw* (t/make-string - "contains? first argument should be a hash-map or nil"))) - (if (t/nil?* head-ast) - t/mal-nil - (let [item-struct (t/get-value head-ast) - key-ast (in asts 1)] - (if-let [val-ast (get item-struct key-ast)] - t/mal-true - t/mal-false))))))) - -(def mal-deref - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "deref requires 1 argument"))) - (let [ast (in asts 0)] - (deref* ast))))) - -(def mal-reset! - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "reset! requires 2 arguments"))) - (let [atom-ast (in asts 0) - val-ast (in asts 1)] - (reset!* atom-ast val-ast))))) - -(def mal-swap! - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "swap! requires at least 2 arguments"))) - (let [atom-ast (in asts 0) - fn-ast (in asts 1) - args-asts (slice asts 2) - inner-ast (deref* atom-ast)] - (reset!* atom-ast - ((t/get-value fn-ast) [inner-ast ;args-asts])))))) - -(def mal-pr-str - (t/make-function - (fn [asts] - (def buf @"") - (when (> (length asts) 0) - (each ast asts - (buffer/push-string buf (printer/pr_str ast true)) - (buffer/push-string buf " ")) - # remove extra space at end - (buffer/popn buf 1)) - (t/make-string (string buf))))) - -(def mal-str - (t/make-function - (fn [asts] - (def buf @"") - (when (> (length asts) 0) - (each ast asts - (buffer/push-string buf (printer/pr_str ast false)))) - (t/make-string (string buf))))) - -(def mal-prn - (t/make-function - (fn [asts] - (def buf @"") - (when (> (length asts) 0) - (each ast asts - (buffer/push-string buf (printer/pr_str ast true)) - (buffer/push-string buf " ")) - # remove extra space at end - (buffer/popn buf 1)) - (print (string buf)) - t/mal-nil))) - -(def mal-println - (t/make-function - (fn [asts] - (def buf @"") - (when (> (length asts) 0) - (each ast asts - (buffer/push-string buf (printer/pr_str ast false)) - (buffer/push-string buf " ")) - # remove extra space at end - (buffer/popn buf 1)) - (print (string buf)) - t/mal-nil))) - -(def mal-read-string - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "read-string requires 1 argument"))) - (if-let [res (reader/read_str (t/get-value (in asts 0)))] - res - (u/throw* (t/make-string "No code content")))))) - -(def mal-slurp - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "slurp requires 1 argument"))) - (let [a-str (t/get-value (in asts 0))] - (if (not (os/stat a-str)) - (u/throw* (string "File not found: " a-str)) - # XXX: escaping? - (t/make-string (slurp a-str))))))) - -(def mal-count - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "count requires 1 argument"))) - (let [ast (in asts 0)] - (if (t/nil?* ast) - (t/make-number 0) - (t/make-number (length (t/get-value ast)))))))) - -(def mal-cons - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "cons requires 2 arguments"))) - (let [head-ast (in asts 0) - tail-ast (in asts 1)] - (t/make-list (cons* head-ast tail-ast)))))) - -(def mal-concat - (t/make-function - (fn [asts] - (t/make-list (concat* ;asts))))) - -(def mal-nth - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "nth requires 2 arguments"))) - (let [coll-ast (in asts 0) - num-ast (in asts 1)] - (nth* coll-ast num-ast))))) - -(def mal-first - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "first requires 1 argument"))) - (let [coll-or-nil-ast (in asts 0)] - (first* coll-or-nil-ast))))) - -(def mal-rest - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "rest requires 1 argument"))) - (let [coll-or-nil-ast (in asts 0)] - (rest* coll-or-nil-ast))))) - -(def mal-assoc - (t/make-function - (fn [asts] - (when (< (length asts) 3) - (u/throw* (t/make-string "assoc requires at least 3 arguments"))) - (let [head-ast (in asts 0)] - (when (not (or (t/hash-map?* head-ast) - (t/nil?* head-ast))) - (u/throw* (t/make-string - "assoc first argument should be a hash-map or nil"))) - (if (t/nil?* head-ast) - t/mal-nil - (let [item-table (table ;(kvs (t/get-value head-ast))) - kv-asts (slice asts 1 -1)] - (each [key-ast val-ast] (partition 2 kv-asts) - (put item-table key-ast val-ast)) - (t/make-hash-map (table/to-struct item-table)))))))) - -(def mal-dissoc - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "dissoc requires at least 2 arguments"))) - (let [head-ast (in asts 0)] - (when (not (or (t/hash-map?* head-ast) - (t/nil?* head-ast))) - (u/throw* (t/make-string - "dissoc first argument should be a hash-map or nil"))) - (if (t/nil?* head-ast) - t/mal-nil - (let [item-table (table ;(kvs (t/get-value head-ast))) - key-asts (slice asts 1 -1)] - (each key-ast key-asts - (put item-table key-ast nil)) - (t/make-hash-map (table/to-struct item-table)))))))) - -(def mal-get - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "get requires 2 arguments"))) - (let [head-ast (in asts 0)] - (when (not (or (t/hash-map?* head-ast) - (t/nil?* head-ast))) - (u/throw* (t/make-string - "get first argument should be a hash-map or nil"))) - (if (t/nil?* head-ast) - t/mal-nil - (let [item-struct (t/get-value head-ast) - key-ast (in asts 1)] - (if-let [val-ast (get item-struct key-ast)] - val-ast - t/mal-nil))))))) - -(def mal-keys - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "keys requires 1 argument"))) - (let [head-ast (in asts 0)] - (when (not (or (t/hash-map?* head-ast) - (t/nil?* head-ast))) - (u/throw* (t/make-string - "keys first argument should be a hash-map or nil"))) - (if (t/nil?* head-ast) - t/mal-nil - (let [item-struct (t/get-value head-ast)] - (t/make-list (keys item-struct)))))))) - -(def mal-vals - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "vals requires 1 argument"))) - (let [head-ast (in asts 0)] - (when (not (or (t/hash-map?* head-ast) - (t/nil?* head-ast))) - (u/throw* (t/make-string - "vals first argument should be a hash-map or nil"))) - (if (t/nil?* head-ast) - t/mal-nil - (let [item-struct (t/get-value head-ast)] - (t/make-list (values item-struct)))))))) - -(def mal-conj - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "conj requires at least 2 arguments"))) - (let [coll-ast (in asts 0) - item-asts (slice asts 1)] - (cond - (t/nil?* coll-ast) - (t/make-list [;(reverse item-asts)]) - ## - (t/list?* coll-ast) - (t/make-list [;(reverse item-asts) ;(t/get-value coll-ast)]) - ## - (t/vector?* coll-ast) - (t/make-vector [;(t/get-value coll-ast) ;item-asts]) - ## - (u/throw* (t/make-string "Expected list or vector"))))))) - -(def mal-seq - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "seq requires 1 argument"))) - (let [arg-ast (in asts 0)] - (cond - (t/list?* arg-ast) - (if (t/empty?* arg-ast) - t/mal-nil - arg-ast) - ## - (t/vector?* arg-ast) - (if (t/empty?* arg-ast) - t/mal-nil - (t/make-list (t/get-value arg-ast))) - ## - (t/string?* arg-ast) - (if (t/empty?* arg-ast) - t/mal-nil - (let [str-asts (map |(t/make-string (string/from-bytes $)) - (t/get-value arg-ast))] - (t/make-list str-asts))) - ## - (t/nil?* arg-ast) - arg-ast - ## - (u/throw* (t/make-string "Expected list, vector, string, or nil"))))))) - -(def mal-map - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "map requires at least 2 arguments"))) - (let [the-fn (t/get-value (in asts 0)) - coll (t/get-value (in asts 1))] - (t/make-list (map |(the-fn [$]) - coll)))))) - -# (apply F A B [C D]) is equivalent to (F A B C D) -(def mal-apply - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "apply requires at least 1 argument"))) - (let [the-fn (t/get-value (in asts 0))] # e.g. F - (if (= (length asts) 1) - (the-fn []) - (let [last-asts (t/get-value (get (slice asts -2) 0)) # e.g. [C D] - args-asts (slice asts 1 -2)] # e.g. [A B] - (the-fn [;args-asts ;last-asts]))))))) - -(def mal-meta - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "meta requires 1 argument"))) - (let [head-ast (in asts 0)] - (if (or (t/list?* head-ast) - (t/vector?* head-ast) - (t/hash-map?* head-ast) - (t/fn?* head-ast)) - (t/get-meta (in asts 0)) - t/mal-nil))))) - -(def mal-with-meta - (t/make-function - (fn [asts] - (when (< (length asts) 2) - (u/throw* (t/make-string "with-meta requires 2 arguments"))) - (let [target-ast (in asts 0) - meta-ast (in asts 1)] - (cond - (t/list?* target-ast) - (t/make-list (t/get-value target-ast) meta-ast) - ## - (t/vector?* target-ast) - (t/make-vector (t/get-value target-ast) meta-ast) - ## - (t/hash-map?* target-ast) - (t/make-hash-map (t/get-value target-ast) meta-ast) - ## - (t/fn?* target-ast) - (t/clone-with-meta target-ast meta-ast) - ## - (u/throw* (t/make-string "Expected list, vector, hash-map, or fn"))))))) - -(def mal-throw - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "throw requires 1 argument"))) - (u/throw* (in asts 0))))) - -(def mal-readline - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "readline requires 1 argument"))) - (let [prompt (t/get-value (in asts 0)) - buf @""] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf) - (if (< 0 (length buf)) - (t/make-string (string/trimr buf)) - t/mal-nil))))) - -(def mal-time-ms - (t/make-function - (fn [asts] - (t/make-number - (math/floor (* 1000 (os/clock))))))) - -(def mal-janet-eval - (t/make-function - (fn [asts] - (when (< (length asts) 1) - (u/throw* (t/make-string "janet-eval requires 1 argument"))) - (let [head-ast (in asts 0)] - (when (not (t/string?* head-ast)) - (u/throw* (t/make-string - "janet-eval first argument should be a string"))) - (let [res (try - (eval-string (t/get-value head-ast)) # XXX: escaping? - ([err] - (u/throw* (t/make-string (string "Eval failed: " err)))))] - (janet-eval* res)))))) - -(def unimplemented mal-throw) - -(def ns - {(t/make-symbol "+") (arith-fn +) - (t/make-symbol "-") (arith-fn -) - (t/make-symbol "*") (arith-fn *) - (t/make-symbol "/") (arith-fn /) - (t/make-symbol "list") mal-list - (t/make-symbol "list?") mal-list? - (t/make-symbol "vec") mal-vec - (t/make-symbol "vector?") mal-vector? - (t/make-symbol "empty?") mal-empty? - (t/make-symbol "count") mal-count - (t/make-symbol "=") mal-= - (t/make-symbol "<") (cmp-fn <) - (t/make-symbol "<=") (cmp-fn <=) - (t/make-symbol ">") (cmp-fn >) - (t/make-symbol ">=") (cmp-fn >=) - (t/make-symbol "pr-str") mal-pr-str - (t/make-symbol "str") mal-str - (t/make-symbol "prn") mal-prn - (t/make-symbol "println") mal-println - (t/make-symbol "read-string") mal-read-string - (t/make-symbol "slurp") mal-slurp - (t/make-symbol "atom") mal-atom - (t/make-symbol "atom?") mal-atom? - (t/make-symbol "deref") mal-deref - (t/make-symbol "reset!") mal-reset! - (t/make-symbol "swap!") mal-swap! - (t/make-symbol "cons") mal-cons - (t/make-symbol "concat") mal-concat - (t/make-symbol "nth") mal-nth - (t/make-symbol "first") mal-first - (t/make-symbol "rest") mal-rest - (t/make-symbol "throw") mal-throw - (t/make-symbol "apply") mal-apply - (t/make-symbol "map") mal-map - (t/make-symbol "nil?") mal-nil? - (t/make-symbol "true?") mal-true? - (t/make-symbol "false?") mal-false? - (t/make-symbol "symbol?") mal-symbol? - (t/make-symbol "symbol") mal-symbol - (t/make-symbol "keyword") mal-keyword - (t/make-symbol "keyword?") mal-keyword? - (t/make-symbol "vector") mal-vector - (t/make-symbol "sequential?") mal-sequential? - (t/make-symbol "hash-map") mal-hash-map - (t/make-symbol "map?") mal-map? - (t/make-symbol "assoc") mal-assoc - (t/make-symbol "dissoc") mal-dissoc - (t/make-symbol "get") mal-get - (t/make-symbol "contains?") mal-contains? - (t/make-symbol "keys") mal-keys - (t/make-symbol "vals") mal-vals - (t/make-symbol "readline") mal-readline - (t/make-symbol "time-ms") mal-time-ms - (t/make-symbol "meta") mal-meta - (t/make-symbol "with-meta") mal-with-meta - (t/make-symbol "fn?") mal-fn? - (t/make-symbol "string?") mal-string? - (t/make-symbol "number?") mal-number? - (t/make-symbol "conj") mal-conj - (t/make-symbol "seq") mal-seq - (t/make-symbol "macro?") mal-macro? - (t/make-symbol "janet-eval") mal-janet-eval -}) +(import ./types :as t) +(import ./utils :as u) +(import ./printer) +(import ./reader) + +(defn deref* + [ast] + (if (not (t/atom?* ast)) + (u/throw* (t/make-string (string "Expected atom, got: " (t/get-type ast)))) + (t/get-value ast))) + +(defn reset!* + [atom-ast val-ast] + (t/set-atom-value! atom-ast val-ast) + val-ast) + +(defn cons* + [head-ast tail-ast] + [head-ast ;(t/get-value tail-ast)]) + +(defn concat* + [& list-asts] + (reduce (fn [acc list-ast] + [;acc ;(t/get-value list-ast)]) + [] + list-asts)) + +(defn nth* + [coll-ast num-ast] + (let [elts (t/get-value coll-ast) + n-elts (length elts) + i (t/get-value num-ast)] + (if (< i n-elts) + (in elts i) + (u/throw* (t/make-string (string "Index out of range: " i)))))) + +(defn first* + [coll-or-nil-ast] + (if (or (t/nil?* coll-or-nil-ast) + (t/empty?* coll-or-nil-ast)) + t/mal-nil + (in (t/get-value coll-or-nil-ast) 0))) + +(defn rest* + [coll-or-nil-ast] + (if (or (t/nil?* coll-or-nil-ast) + (t/empty?* coll-or-nil-ast)) + (t/make-list []) + (t/make-list (slice (t/get-value coll-or-nil-ast) 1)))) + +(defn janet-eval* + [janet-val] + (case (type janet-val) + :nil + t/mal-nil + ## + :boolean + (t/make-boolean janet-val) + ## + :number # XXX: there may be some incompatibilities + (t/make-number janet-val) + ## + :string + (t/make-string janet-val) + ## + :keyword # XXX: there may be some incompatibilities + (t/make-keyword (string ":" janet-val)) + ## + :symbol # XXX: there may be some incompatibilities + (t/make-symbol (string janet-val)) + ## + :tuple + (t/make-list (map janet-eval* janet-val)) + ## + :array + (t/make-list (map janet-eval* janet-val)) + ## + :struct + (t/make-hash-map (struct ;(map janet-eval* (kvs janet-val)))) + ## + :table + (t/make-hash-map (struct ;(map janet-eval* (kvs janet-val)))) + ## + (u/throw* (t/make-string (string "Unsupported type: " (type janet-val)))))) + +(defn arith-fn + [op] + (t/make-function + (fn [asts] + (t/make-number + (op ;(map |(t/get-value $) + asts)))))) + +(defn cmp-fn + [op] + (t/make-function + (fn [asts] + (if (op ;(map |(t/get-value $) asts)) + t/mal-true + t/mal-false)))) + +(def mal-symbol + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "symbol requires 1 argument"))) + (t/make-symbol (t/get-value (in asts 0)))))) + +(def mal-keyword + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "keyword requires 1 argument"))) + (let [arg-ast (in asts 0)] + (cond + (t/keyword?* arg-ast) + arg-ast + ## + (t/string?* arg-ast) + (t/make-keyword (string ":" (t/get-value arg-ast))) + ## + (u/throw* (t/make-string "Expected string"))))))) + +(def mal-list + (t/make-function + (fn [asts] + (t/make-list asts)))) + +(def mal-vector + (t/make-function + (fn [asts] + (t/make-vector asts)))) + +(def mal-vec + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "vec requires 1 argument"))) + (let [ast (in asts 0)] + (cond + (t/vector?* ast) + ast + ## + (t/list?* ast) + (t/make-vector (t/get-value ast)) + ## + (t/nil?* ast) + (t/make-vector ()) + ## + (u/throw* (t/make-string "vec requires a vector, list, or nil"))))))) + +(def mal-hash-map + (t/make-function + (fn [asts] + (when (= 1 (% (length asts) 2)) + (u/throw* (t/make-string + "hash-map requires an even number of arguments"))) + (t/make-hash-map asts)))) + +(def mal-atom + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "atom requires 1 argument"))) + (t/make-atom (in asts 0))))) + +(def mal-nil? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "nil? requires 1 argument"))) + (if (t/nil?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-true? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "true? requires 1 argument"))) + (if (t/true?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-false? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "false? requires 1 argument"))) + (if (t/false?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-number? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "number? requires 1 argument"))) + (if (t/number?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-symbol? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "symbol? requires 1 argument"))) + (if (t/symbol?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-keyword? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "keyword? requires 1 argument"))) + (if (t/keyword?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-string? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "string? requires 1 argument"))) + (if (t/string?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-list? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "list? requires 1 argument"))) + (if (t/list?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-vector? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "vector? requires 1 argument"))) + (if (t/vector?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-map? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "map? requires 1 argument"))) + (if (t/hash-map?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-fn? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "fn? requires 1 argument"))) + (let [target-ast (in asts 0)] + (if (and (t/fn?* target-ast) + (not (t/get-is-macro target-ast))) + t/mal-true + t/mal-false))))) + +(def mal-macro? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "macro? requires 1 argument"))) + (let [the-ast (in asts 0)] + (if (t/macro?* the-ast) + t/mal-true + t/mal-false))))) + +(def mal-atom? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "atom? requires 1 argument"))) + (if (t/atom?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-sequential? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "sequential? requires 1 argument"))) + (if (or (t/list?* (in asts 0)) + (t/vector?* (in asts 0))) + t/mal-true + t/mal-false)))) + +(def mal-= + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "= requires 2 arguments"))) + (let [ast-1 (in asts 0) + ast-2 (in asts 1)] + (if (t/equals?* ast-1 ast-2) + t/mal-true + t/mal-false))))) + +(def mal-empty? + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "empty? requires 1 argument"))) + (if (t/empty?* (in asts 0)) + t/mal-true + t/mal-false)))) + +(def mal-contains? + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "contains? requires 2 arguments"))) + (let [head-ast (in asts 0)] + (when (not (or (t/hash-map?* head-ast) + (t/nil?* head-ast))) + (u/throw* (t/make-string + "contains? first argument should be a hash-map or nil"))) + (if (t/nil?* head-ast) + t/mal-nil + (let [item-struct (t/get-value head-ast) + key-ast (in asts 1)] + (if-let [val-ast (get item-struct key-ast)] + t/mal-true + t/mal-false))))))) + +(def mal-deref + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "deref requires 1 argument"))) + (let [ast (in asts 0)] + (deref* ast))))) + +(def mal-reset! + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "reset! requires 2 arguments"))) + (let [atom-ast (in asts 0) + val-ast (in asts 1)] + (reset!* atom-ast val-ast))))) + +(def mal-swap! + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "swap! requires at least 2 arguments"))) + (let [atom-ast (in asts 0) + fn-ast (in asts 1) + args-asts (slice asts 2) + inner-ast (deref* atom-ast)] + (reset!* atom-ast + ((t/get-value fn-ast) [inner-ast ;args-asts])))))) + +(def mal-pr-str + (t/make-function + (fn [asts] + (def buf @"") + (when (> (length asts) 0) + (each ast asts + (buffer/push-string buf (printer/pr_str ast true)) + (buffer/push-string buf " ")) + # remove extra space at end + (buffer/popn buf 1)) + (t/make-string (string buf))))) + +(def mal-str + (t/make-function + (fn [asts] + (def buf @"") + (when (> (length asts) 0) + (each ast asts + (buffer/push-string buf (printer/pr_str ast false)))) + (t/make-string (string buf))))) + +(def mal-prn + (t/make-function + (fn [asts] + (def buf @"") + (when (> (length asts) 0) + (each ast asts + (buffer/push-string buf (printer/pr_str ast true)) + (buffer/push-string buf " ")) + # remove extra space at end + (buffer/popn buf 1)) + (print (string buf)) + t/mal-nil))) + +(def mal-println + (t/make-function + (fn [asts] + (def buf @"") + (when (> (length asts) 0) + (each ast asts + (buffer/push-string buf (printer/pr_str ast false)) + (buffer/push-string buf " ")) + # remove extra space at end + (buffer/popn buf 1)) + (print (string buf)) + t/mal-nil))) + +(def mal-read-string + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "read-string requires 1 argument"))) + (if-let [res (reader/read_str (t/get-value (in asts 0)))] + res + (u/throw* (t/make-string "No code content")))))) + +(def mal-slurp + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "slurp requires 1 argument"))) + (let [a-str (t/get-value (in asts 0))] + (if (not (os/stat a-str)) + (u/throw* (string "File not found: " a-str)) + # XXX: escaping? + (t/make-string (slurp a-str))))))) + +(def mal-count + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "count requires 1 argument"))) + (let [ast (in asts 0)] + (if (t/nil?* ast) + (t/make-number 0) + (t/make-number (length (t/get-value ast)))))))) + +(def mal-cons + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "cons requires 2 arguments"))) + (let [head-ast (in asts 0) + tail-ast (in asts 1)] + (t/make-list (cons* head-ast tail-ast)))))) + +(def mal-concat + (t/make-function + (fn [asts] + (t/make-list (concat* ;asts))))) + +(def mal-nth + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "nth requires 2 arguments"))) + (let [coll-ast (in asts 0) + num-ast (in asts 1)] + (nth* coll-ast num-ast))))) + +(def mal-first + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "first requires 1 argument"))) + (let [coll-or-nil-ast (in asts 0)] + (first* coll-or-nil-ast))))) + +(def mal-rest + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "rest requires 1 argument"))) + (let [coll-or-nil-ast (in asts 0)] + (rest* coll-or-nil-ast))))) + +(def mal-assoc + (t/make-function + (fn [asts] + (when (< (length asts) 3) + (u/throw* (t/make-string "assoc requires at least 3 arguments"))) + (let [head-ast (in asts 0)] + (when (not (or (t/hash-map?* head-ast) + (t/nil?* head-ast))) + (u/throw* (t/make-string + "assoc first argument should be a hash-map or nil"))) + (if (t/nil?* head-ast) + t/mal-nil + (let [item-table (table ;(kvs (t/get-value head-ast))) + kv-asts (slice asts 1 -1)] + (each [key-ast val-ast] (partition 2 kv-asts) + (put item-table key-ast val-ast)) + (t/make-hash-map (table/to-struct item-table)))))))) + +(def mal-dissoc + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "dissoc requires at least 2 arguments"))) + (let [head-ast (in asts 0)] + (when (not (or (t/hash-map?* head-ast) + (t/nil?* head-ast))) + (u/throw* (t/make-string + "dissoc first argument should be a hash-map or nil"))) + (if (t/nil?* head-ast) + t/mal-nil + (let [item-table (table ;(kvs (t/get-value head-ast))) + key-asts (slice asts 1 -1)] + (each key-ast key-asts + (put item-table key-ast nil)) + (t/make-hash-map (table/to-struct item-table)))))))) + +(def mal-get + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "get requires 2 arguments"))) + (let [head-ast (in asts 0)] + (when (not (or (t/hash-map?* head-ast) + (t/nil?* head-ast))) + (u/throw* (t/make-string + "get first argument should be a hash-map or nil"))) + (if (t/nil?* head-ast) + t/mal-nil + (let [item-struct (t/get-value head-ast) + key-ast (in asts 1)] + (if-let [val-ast (get item-struct key-ast)] + val-ast + t/mal-nil))))))) + +(def mal-keys + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "keys requires 1 argument"))) + (let [head-ast (in asts 0)] + (when (not (or (t/hash-map?* head-ast) + (t/nil?* head-ast))) + (u/throw* (t/make-string + "keys first argument should be a hash-map or nil"))) + (if (t/nil?* head-ast) + t/mal-nil + (let [item-struct (t/get-value head-ast)] + (t/make-list (keys item-struct)))))))) + +(def mal-vals + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "vals requires 1 argument"))) + (let [head-ast (in asts 0)] + (when (not (or (t/hash-map?* head-ast) + (t/nil?* head-ast))) + (u/throw* (t/make-string + "vals first argument should be a hash-map or nil"))) + (if (t/nil?* head-ast) + t/mal-nil + (let [item-struct (t/get-value head-ast)] + (t/make-list (values item-struct)))))))) + +(def mal-conj + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "conj requires at least 2 arguments"))) + (let [coll-ast (in asts 0) + item-asts (slice asts 1)] + (cond + (t/nil?* coll-ast) + (t/make-list [;(reverse item-asts)]) + ## + (t/list?* coll-ast) + (t/make-list [;(reverse item-asts) ;(t/get-value coll-ast)]) + ## + (t/vector?* coll-ast) + (t/make-vector [;(t/get-value coll-ast) ;item-asts]) + ## + (u/throw* (t/make-string "Expected list or vector"))))))) + +(def mal-seq + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "seq requires 1 argument"))) + (let [arg-ast (in asts 0)] + (cond + (t/list?* arg-ast) + (if (t/empty?* arg-ast) + t/mal-nil + arg-ast) + ## + (t/vector?* arg-ast) + (if (t/empty?* arg-ast) + t/mal-nil + (t/make-list (t/get-value arg-ast))) + ## + (t/string?* arg-ast) + (if (t/empty?* arg-ast) + t/mal-nil + (let [str-asts (map |(t/make-string (string/from-bytes $)) + (t/get-value arg-ast))] + (t/make-list str-asts))) + ## + (t/nil?* arg-ast) + arg-ast + ## + (u/throw* (t/make-string "Expected list, vector, string, or nil"))))))) + +(def mal-map + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "map requires at least 2 arguments"))) + (let [the-fn (t/get-value (in asts 0)) + coll (t/get-value (in asts 1))] + (t/make-list (map |(the-fn [$]) + coll)))))) + +# (apply F A B [C D]) is equivalent to (F A B C D) +(def mal-apply + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "apply requires at least 1 argument"))) + (let [the-fn (t/get-value (in asts 0))] # e.g. F + (if (= (length asts) 1) + (the-fn []) + (let [last-asts (t/get-value (get (slice asts -2) 0)) # e.g. [C D] + args-asts (slice asts 1 -2)] # e.g. [A B] + (the-fn [;args-asts ;last-asts]))))))) + +(def mal-meta + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "meta requires 1 argument"))) + (let [head-ast (in asts 0)] + (if (or (t/list?* head-ast) + (t/vector?* head-ast) + (t/hash-map?* head-ast) + (t/fn?* head-ast)) + (t/get-meta (in asts 0)) + t/mal-nil))))) + +(def mal-with-meta + (t/make-function + (fn [asts] + (when (< (length asts) 2) + (u/throw* (t/make-string "with-meta requires 2 arguments"))) + (let [target-ast (in asts 0) + meta-ast (in asts 1)] + (cond + (t/list?* target-ast) + (t/make-list (t/get-value target-ast) meta-ast) + ## + (t/vector?* target-ast) + (t/make-vector (t/get-value target-ast) meta-ast) + ## + (t/hash-map?* target-ast) + (t/make-hash-map (t/get-value target-ast) meta-ast) + ## + (t/fn?* target-ast) + (t/clone-with-meta target-ast meta-ast) + ## + (u/throw* (t/make-string "Expected list, vector, hash-map, or fn"))))))) + +(def mal-throw + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "throw requires 1 argument"))) + (u/throw* (in asts 0))))) + +(def mal-readline + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "readline requires 1 argument"))) + (let [prompt (t/get-value (in asts 0)) + buf @""] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf) + (if (< 0 (length buf)) + (t/make-string (string/trimr buf)) + t/mal-nil))))) + +(def mal-time-ms + (t/make-function + (fn [asts] + (t/make-number + (math/floor (* 1000 (os/clock))))))) + +(def mal-janet-eval + (t/make-function + (fn [asts] + (when (< (length asts) 1) + (u/throw* (t/make-string "janet-eval requires 1 argument"))) + (let [head-ast (in asts 0)] + (when (not (t/string?* head-ast)) + (u/throw* (t/make-string + "janet-eval first argument should be a string"))) + (let [res (try + (eval-string (t/get-value head-ast)) # XXX: escaping? + ([err] + (u/throw* (t/make-string (string "Eval failed: " err)))))] + (janet-eval* res)))))) + +(def unimplemented mal-throw) + +(def ns + {(t/make-symbol "+") (arith-fn +) + (t/make-symbol "-") (arith-fn -) + (t/make-symbol "*") (arith-fn *) + (t/make-symbol "/") (arith-fn /) + (t/make-symbol "list") mal-list + (t/make-symbol "list?") mal-list? + (t/make-symbol "vec") mal-vec + (t/make-symbol "vector?") mal-vector? + (t/make-symbol "empty?") mal-empty? + (t/make-symbol "count") mal-count + (t/make-symbol "=") mal-= + (t/make-symbol "<") (cmp-fn <) + (t/make-symbol "<=") (cmp-fn <=) + (t/make-symbol ">") (cmp-fn >) + (t/make-symbol ">=") (cmp-fn >=) + (t/make-symbol "pr-str") mal-pr-str + (t/make-symbol "str") mal-str + (t/make-symbol "prn") mal-prn + (t/make-symbol "println") mal-println + (t/make-symbol "read-string") mal-read-string + (t/make-symbol "slurp") mal-slurp + (t/make-symbol "atom") mal-atom + (t/make-symbol "atom?") mal-atom? + (t/make-symbol "deref") mal-deref + (t/make-symbol "reset!") mal-reset! + (t/make-symbol "swap!") mal-swap! + (t/make-symbol "cons") mal-cons + (t/make-symbol "concat") mal-concat + (t/make-symbol "nth") mal-nth + (t/make-symbol "first") mal-first + (t/make-symbol "rest") mal-rest + (t/make-symbol "throw") mal-throw + (t/make-symbol "apply") mal-apply + (t/make-symbol "map") mal-map + (t/make-symbol "nil?") mal-nil? + (t/make-symbol "true?") mal-true? + (t/make-symbol "false?") mal-false? + (t/make-symbol "symbol?") mal-symbol? + (t/make-symbol "symbol") mal-symbol + (t/make-symbol "keyword") mal-keyword + (t/make-symbol "keyword?") mal-keyword? + (t/make-symbol "vector") mal-vector + (t/make-symbol "sequential?") mal-sequential? + (t/make-symbol "hash-map") mal-hash-map + (t/make-symbol "map?") mal-map? + (t/make-symbol "assoc") mal-assoc + (t/make-symbol "dissoc") mal-dissoc + (t/make-symbol "get") mal-get + (t/make-symbol "contains?") mal-contains? + (t/make-symbol "keys") mal-keys + (t/make-symbol "vals") mal-vals + (t/make-symbol "readline") mal-readline + (t/make-symbol "time-ms") mal-time-ms + (t/make-symbol "meta") mal-meta + (t/make-symbol "with-meta") mal-with-meta + (t/make-symbol "fn?") mal-fn? + (t/make-symbol "string?") mal-string? + (t/make-symbol "number?") mal-number? + (t/make-symbol "conj") mal-conj + (t/make-symbol "seq") mal-seq + (t/make-symbol "macro?") mal-macro? + (t/make-symbol "janet-eval") mal-janet-eval +}) diff --git a/impls/janet/env.janet b/impls/janet/env.janet index d3a94100f8..4f184b4f5e 100644 --- a/impls/janet/env.janet +++ b/impls/janet/env.janet @@ -1,50 +1,50 @@ -(import ./types :as t) -(import ./utils :as u) - -(defn make-env - [&opt outer binds exprs] - (default binds []) - (default exprs []) - (def n-binds (length binds)) - (var found-amp false) - (var idx 0) - (while (and (not found-amp) - (< idx n-binds)) - (def c-bind (in binds idx)) - (when (= (t/get-value c-bind) "&") - (set found-amp true) - (break)) - (++ idx)) - (def new-binds - (if found-amp - (array/concat (array ;(slice binds 0 idx)) - (in binds (inc idx))) - binds)) - (def new-exprs - (if found-amp - (array/concat (array ;(slice exprs 0 idx)) - (array (t/make-list (slice exprs idx)))) - exprs)) - # XXX: would length mismatches of new-binds / new-exprs ever be an issue? - @{:data (zipcoll new-binds new-exprs) - :outer outer}) - -(defn env-set - [env sym value] - (put-in env [:data sym] - value)) - -(defn env-find - [env sym] - (if (get-in env [:data sym]) - env - (when-let [outer (get env :outer)] - (env-find outer sym)))) - -(defn env-get - [env sym] - (if-let [goal-env (env-find env sym)] - (get-in goal-env [:data sym]) - (u/throw* - (t/make-string - (string "'" (t/get-value sym) "'" " not found" ))))) +(import ./types :as t) +(import ./utils :as u) + +(defn make-env + [&opt outer binds exprs] + (default binds []) + (default exprs []) + (def n-binds (length binds)) + (var found-amp false) + (var idx 0) + (while (and (not found-amp) + (< idx n-binds)) + (def c-bind (in binds idx)) + (when (= (t/get-value c-bind) "&") + (set found-amp true) + (break)) + (++ idx)) + (def new-binds + (if found-amp + (array/concat (array ;(slice binds 0 idx)) + (in binds (inc idx))) + binds)) + (def new-exprs + (if found-amp + (array/concat (array ;(slice exprs 0 idx)) + (array (t/make-list (slice exprs idx)))) + exprs)) + # XXX: would length mismatches of new-binds / new-exprs ever be an issue? + @{:data (zipcoll new-binds new-exprs) + :outer outer}) + +(defn env-set + [env sym value] + (put-in env [:data sym] + value)) + +(defn env-find + [env sym] + (if (get-in env [:data sym]) + env + (when-let [outer (get env :outer)] + (env-find outer sym)))) + +(defn env-get + [env sym] + (if-let [goal-env (env-find env sym)] + (get-in goal-env [:data sym]) + (u/throw* + (t/make-string + (string "'" (t/get-value sym) "'" " not found" ))))) diff --git a/impls/janet/printer.janet b/impls/janet/printer.janet index a4d35fe04a..c8f0e35dd9 100644 --- a/impls/janet/printer.janet +++ b/impls/janet/printer.janet @@ -1,101 +1,101 @@ -(import ./types :as t) - -(defn escape - [a-str] - (->> (buffer a-str) - (peg/replace-all "\\" "\\\\") - (peg/replace-all "\"" "\\\"") - (peg/replace-all "\n" "\\n") - string)) - -(defn code* - [ast buf print_readably] - (cond - (or (t/boolean?* ast) - (t/nil?* ast) - (t/keyword?* ast) - (t/symbol?* ast)) - (buffer/push-string buf (t/get-value ast)) - ## - (t/number?* ast) - (buffer/push-string buf (string (t/get-value ast))) - ## - (t/string?* ast) - (if print_readably - (buffer/push-string buf (string "\"" - (escape (t/get-value ast)) - "\"")) - (buffer/push-string buf (t/get-value ast))) - ## - (t/list?* ast) - (do - (buffer/push-string buf "(") - (var remove false) - (each elt (t/get-value ast) - (code* elt buf print_readably) - (buffer/push-string buf " ") - (set remove true)) - (when remove - (buffer/popn buf 1)) - (buffer/push-string buf ")")) - ## - (t/hash-map?* ast) - (do - (buffer/push-string buf "{") - (var remove false) - (eachp [k v] (t/get-value ast) - (code* k buf print_readably) - (buffer/push-string buf " ") - (code* v buf print_readably) - (buffer/push-string buf " ") - (set remove true)) - (when remove - (buffer/popn buf 1)) - (buffer/push-string buf "}")) - ## - (t/vector?* ast) - (do - (buffer/push-string buf "[") - (var remove false) - (each elt (t/get-value ast) - (code* elt buf print_readably) - (buffer/push-string buf " ") - (set remove true)) - (when remove - (buffer/popn buf 1)) - (buffer/push-string buf "]")) - ## XXX: what about macro? - (t/fn?* ast) - (buffer/push-string buf "#") - ## - (t/atom?* ast) - (do - (buffer/push-string buf "(atom ") - (code* (t/get-value ast) buf print_readably) - (buffer/push-string buf ")")) - ## - (t/exception?* ast) - (do - (buffer/push-string buf "Error: ") - (code* (t/get-value ast) buf print_readably)))) - -(comment - - (let [buf @""] - (code* (make-number 1) buf false)) - # => @"1" - - ) - -(defn pr_str - [ast print_readably] - (let [buf @""] - (code* ast buf print_readably) - buf)) - -(comment - - (pr_str (make-number 1) false) - # => @"1" - - ) +(import ./types :as t) + +(defn escape + [a-str] + (->> (buffer a-str) + (peg/replace-all "\\" "\\\\") + (peg/replace-all "\"" "\\\"") + (peg/replace-all "\n" "\\n") + string)) + +(defn code* + [ast buf print_readably] + (cond + (or (t/boolean?* ast) + (t/nil?* ast) + (t/keyword?* ast) + (t/symbol?* ast)) + (buffer/push-string buf (t/get-value ast)) + ## + (t/number?* ast) + (buffer/push-string buf (string (t/get-value ast))) + ## + (t/string?* ast) + (if print_readably + (buffer/push-string buf (string "\"" + (escape (t/get-value ast)) + "\"")) + (buffer/push-string buf (t/get-value ast))) + ## + (t/list?* ast) + (do + (buffer/push-string buf "(") + (var remove false) + (each elt (t/get-value ast) + (code* elt buf print_readably) + (buffer/push-string buf " ") + (set remove true)) + (when remove + (buffer/popn buf 1)) + (buffer/push-string buf ")")) + ## + (t/hash-map?* ast) + (do + (buffer/push-string buf "{") + (var remove false) + (eachp [k v] (t/get-value ast) + (code* k buf print_readably) + (buffer/push-string buf " ") + (code* v buf print_readably) + (buffer/push-string buf " ") + (set remove true)) + (when remove + (buffer/popn buf 1)) + (buffer/push-string buf "}")) + ## + (t/vector?* ast) + (do + (buffer/push-string buf "[") + (var remove false) + (each elt (t/get-value ast) + (code* elt buf print_readably) + (buffer/push-string buf " ") + (set remove true)) + (when remove + (buffer/popn buf 1)) + (buffer/push-string buf "]")) + ## XXX: what about macro? + (t/fn?* ast) + (buffer/push-string buf "#") + ## + (t/atom?* ast) + (do + (buffer/push-string buf "(atom ") + (code* (t/get-value ast) buf print_readably) + (buffer/push-string buf ")")) + ## + (t/exception?* ast) + (do + (buffer/push-string buf "Error: ") + (code* (t/get-value ast) buf print_readably)))) + +(comment + + (let [buf @""] + (code* (make-number 1) buf false)) + # => @"1" + + ) + +(defn pr_str + [ast print_readably] + (let [buf @""] + (code* ast buf print_readably) + buf)) + +(comment + + (pr_str (make-number 1) false) + # => @"1" + + ) diff --git a/impls/janet/reader.janet b/impls/janet/reader.janet index 0d856dcdfa..0ea660b1aa 100644 --- a/impls/janet/reader.janet +++ b/impls/janet/reader.janet @@ -1,311 +1,311 @@ -(import ./types :as t) -(import ./utils :as u) - -(def grammar - ~{:main (capture (some :input)) - :input (choice :gap :form) - :gap (choice :ws :comment) - :ws (set " \f\n\r\t,") - :comment (sequence ";" - (any (if-not (set "\r\n") - 1))) - :form (choice :boolean :nil :number :keyword :symbol - :string :list :vector :hash-map - :deref :quasiquote :quote :splice-unquote :unquote - :with-meta) - :name-char (if-not (set " \f\n\r\t,[]{}()'`~^@\";") - 1) - :boolean (sequence (choice "false" "true") - (not :name-char)) - :nil (sequence "nil" - (not :name-char)) - :number (drop (cmt - (capture (some :name-char)) - ,scan-number)) - :keyword (sequence ":" - (any :name-char)) - :symbol (some :name-char) - :string (sequence "\"" - (any (if-not (set "\"\\") - 1)) - (any (sequence "\\" - 1 - (any (if-not (set "\"\\") - 1)))) - (choice "\"" - (error (constant "unbalanced \"")))) - :hash-map (sequence "{" - (any :input) - (choice "}" - (error (constant "unbalanced }")))) - :list (sequence "(" - (any :input) - (choice ")" - (error (constant "unbalanced )")))) - :vector (sequence "[" - (any :input) - (choice "]" - (error (constant "unbalanced ]")))) - :deref (sequence "@" :form) - :quasiquote (sequence "`" :form) - :quote (sequence "'" :form) - :splice-unquote (sequence "~@" :form) - :unquote (sequence "~" :form) - :with-meta (sequence "^" :form (some :gap) :form) - } - ) - -(comment - - (peg/match grammar " ") - # => @[" "] - - (peg/match grammar "; hello") - # => @["; hello"] - - (peg/match grammar "true") - # => @["true"] - - (peg/match grammar "false") - # => @["false"] - - (peg/match grammar "nil") - # => @["nil"] - - (peg/match grammar "18") - # => @["18"] - - (peg/match grammar "sym") - # => @["sym"] - - (peg/match grammar ":alpha") - # => @[":alpha"] - - (peg/match grammar "\"a string\"") - # => @["\"a string\""] - - (peg/match grammar "(+ 1 2)") - # => @["(+ 1 2)"] - - (peg/match grammar "[:a :b :c]") - # => @["[:a :b :c]"] - - (peg/match grammar "{:a 1 :b 2}") - # => @{"{:a 1 :b 2}"] - - ) - -(defn unescape - [a-str] - (->> a-str - (peg/replace-all "\\\\" "\u029e") # XXX: a hack? - (peg/replace-all "\\\"" "\"") - (peg/replace-all "\\n" "\n") - (peg/replace-all "\u029e" "\\") - string)) - -(def enlive-grammar - (let [cg (table ;(kvs grammar))] - (each kwd [# :comment # XX: don't capture comments - :boolean :keyword :nil - :symbol - # :ws # XXX: dont' capture whitespace - ] - (put cg kwd - ~(cmt (capture ,(in cg kwd)) - ,|{:tag (keyword kwd) - :content $}))) - (put cg :number - ~(cmt (capture ,(in cg :number)) - ,|{:tag :number - :content (scan-number $)})) - (put cg :string - ~(cmt (capture ,(in cg :string)) - ,|{:tag :string - # discard surrounding double quotes - :content (unescape (slice $ 1 -2))})) - (each kwd [:deref :quasiquote :quote :splice-unquote :unquote] - (put cg kwd - ~(cmt (capture ,(in cg kwd)) - ,|{:tag :list - :content [{:tag :symbol - :content (string kwd)} - ;(slice $& 0 -2)]}))) - (each kwd [:list :vector] - (put cg kwd - (tuple # array needs to be converted - ;(put (array ;(in cg kwd)) - 2 ~(cmt (capture ,(get-in cg [kwd 2])) - ,|{:tag (keyword kwd) - :content (slice $& 0 -2)}))))) - (put cg :hash-map - (tuple # array needs to be converted - ;(put (array ;(in cg :hash-map)) - 2 ~(cmt (capture ,(get-in cg [:hash-map 2])) - ,|{:tag :hash-map - :content (struct ;(slice $& 0 -2))})))) - (put cg :with-meta - ~(cmt (capture ,(in cg :with-meta)) - ,|{:tag :list - :content [{:tag :symbol - :content "with-meta"} - (get $& 1) - (get $& 0)]})) - # tried using a table with a peg but had a problem, so use a struct - (table/to-struct cg))) - -(comment - - (peg/match enlive-grammar "nil") - # => @[{:content "nil" :tag :nil} "nil"] - - (peg/match enlive-grammar "true") - # => @[{:content "true" :tag :boolean} "true"] - - (peg/match enlive-grammar ":hi") - # => @[{:content ":hi" :tag :keyword} ":hi"] - - (peg/match enlive-grammar "sym") - # => @[{:content "sym" :tag :symbol} "sym"] - - (peg/match enlive-grammar "'a") - `` - '@[{:content ({:content "quote" - :tag :symbol} - {:content "a" - :tag :symbol}) - :tag :list} "'a"] - `` - - (peg/match enlive-grammar "@a") - `` - '@[{:content ({:content "deref" - :tag :symbol} - {:content "a" - :tag :symbol}) - :tag :list} "@a"] - `` - - (peg/match enlive-grammar "`a") - `` - '@[{:content ({:content "quasiquote" - :tag :symbol} - {:content "a" - :tag :symbol}) - :tag :list} "`a"] - `` - - (peg/match enlive-grammar "~a") - `` - '@[{:content ({:content "unquote" - :tag :symbol} - {:content "a" - :tag :symbol}) - :tag :list} "~a"] - `` - - (peg/match enlive-grammar "~@a") - `` - '@[{:content ({:content "splice-unquote" - :tag :symbol} - {:content "a" - :tag :symbol}) - :tag :list} "~@a"] - `` - - (peg/match enlive-grammar "(a b c)") - `` - '@[{:content ({:content "a" - :tag :symbol} - {:content "b" - :tag :symbol} - {:content "c" - :tag :symbol}) - :tag :list} "(a b c)"] - `` - - (peg/match enlive-grammar "(a [:x :y] c)") - `` - '@[{:content ({:content "a" - :tag :symbol} - {:content ({:content ":x" - :tag :keyword} - {:content ":y" - :tag :keyword}) - :tag :vector} - {:content "c" - :tag :symbol}) - :tag :list} "(a [:x :y] c)"] - `` - - (peg/match enlive-grammar "^{:a 1} [:x :y]") - `` - '@[{:content ({:content "with-meta" - :tag :symbol} - {:content ({:content ":x" - :tag :keyword} - {:content ":y" - :tag :keyword}) - :tag :vector} - {:content {{:content ":a" - :tag :keyword} - {:content "1" - :tag :number}} - :tag :hash-map}) - :tag :list} "^{:a 1} [:x :y]"] - `` - - (peg/match enlive-grammar ";; hi") - # => @[";; hi"] - - (peg/match enlive-grammar "[:x ;; hi\n :y]") - `` - '@[{:content ({:content ":x" - :tag :keyword} - {:content ":y" - :tag :keyword}) - :tag :vector} "[:x ;; hi\n :y]"] - `` - - (peg/match enlive-grammar " 7 ") - # => @[{:content 7 :tag :number} " 7 "] - - (peg/match enlive-grammar " abc ") - # => @[{:content "abc" :tag :symbol} " abc "] - - (peg/match enlive-grammar " \nabc ") - # => @[{:content "abc" :tag :symbol} " \nabc "] - - ) - -(defn read_str - [code-str] - (let [[parsed _] - (try - (peg/match enlive-grammar code-str) - ([err] - (u/throw* (t/make-string err))))] - (if (= (type parsed) :struct) - parsed - (u/throw* t/mal-nil)))) - -(comment - - (read_str "(+ 1 2)") - `` - '{:content ({:content "+" - :tag :symbol} - {:content 1 - :tag :number} - {:content 2 - :tag :number}) - :tag :list} - `` - - (read_str ";; hello") - # => nil - - (read_str "\"1\"") - # => {:content "1" :tag :string} - - ) +(import ./types :as t) +(import ./utils :as u) + +(def grammar + ~{:main (capture (some :input)) + :input (choice :gap :form) + :gap (choice :ws :comment) + :ws (set " \f\n\r\t,") + :comment (sequence ";" + (any (if-not (set "\r\n") + 1))) + :form (choice :boolean :nil :number :keyword :symbol + :string :list :vector :hash-map + :deref :quasiquote :quote :splice-unquote :unquote + :with-meta) + :name-char (if-not (set " \f\n\r\t,[]{}()'`~^@\";") + 1) + :boolean (sequence (choice "false" "true") + (not :name-char)) + :nil (sequence "nil" + (not :name-char)) + :number (drop (cmt + (capture (some :name-char)) + ,scan-number)) + :keyword (sequence ":" + (any :name-char)) + :symbol (some :name-char) + :string (sequence "\"" + (any (if-not (set "\"\\") + 1)) + (any (sequence "\\" + 1 + (any (if-not (set "\"\\") + 1)))) + (choice "\"" + (error (constant "unbalanced \"")))) + :hash-map (sequence "{" + (any :input) + (choice "}" + (error (constant "unbalanced }")))) + :list (sequence "(" + (any :input) + (choice ")" + (error (constant "unbalanced )")))) + :vector (sequence "[" + (any :input) + (choice "]" + (error (constant "unbalanced ]")))) + :deref (sequence "@" :form) + :quasiquote (sequence "`" :form) + :quote (sequence "'" :form) + :splice-unquote (sequence "~@" :form) + :unquote (sequence "~" :form) + :with-meta (sequence "^" :form (some :gap) :form) + } + ) + +(comment + + (peg/match grammar " ") + # => @[" "] + + (peg/match grammar "; hello") + # => @["; hello"] + + (peg/match grammar "true") + # => @["true"] + + (peg/match grammar "false") + # => @["false"] + + (peg/match grammar "nil") + # => @["nil"] + + (peg/match grammar "18") + # => @["18"] + + (peg/match grammar "sym") + # => @["sym"] + + (peg/match grammar ":alpha") + # => @[":alpha"] + + (peg/match grammar "\"a string\"") + # => @["\"a string\""] + + (peg/match grammar "(+ 1 2)") + # => @["(+ 1 2)"] + + (peg/match grammar "[:a :b :c]") + # => @["[:a :b :c]"] + + (peg/match grammar "{:a 1 :b 2}") + # => @{"{:a 1 :b 2}"] + + ) + +(defn unescape + [a-str] + (->> a-str + (peg/replace-all "\\\\" "\u029e") # XXX: a hack? + (peg/replace-all "\\\"" "\"") + (peg/replace-all "\\n" "\n") + (peg/replace-all "\u029e" "\\") + string)) + +(def enlive-grammar + (let [cg (table ;(kvs grammar))] + (each kwd [# :comment # XX: don't capture comments + :boolean :keyword :nil + :symbol + # :ws # XXX: dont' capture whitespace + ] + (put cg kwd + ~(cmt (capture ,(in cg kwd)) + ,|{:tag (keyword kwd) + :content $}))) + (put cg :number + ~(cmt (capture ,(in cg :number)) + ,|{:tag :number + :content (scan-number $)})) + (put cg :string + ~(cmt (capture ,(in cg :string)) + ,|{:tag :string + # discard surrounding double quotes + :content (unescape (slice $ 1 -2))})) + (each kwd [:deref :quasiquote :quote :splice-unquote :unquote] + (put cg kwd + ~(cmt (capture ,(in cg kwd)) + ,|{:tag :list + :content [{:tag :symbol + :content (string kwd)} + ;(slice $& 0 -2)]}))) + (each kwd [:list :vector] + (put cg kwd + (tuple # array needs to be converted + ;(put (array ;(in cg kwd)) + 2 ~(cmt (capture ,(get-in cg [kwd 2])) + ,|{:tag (keyword kwd) + :content (slice $& 0 -2)}))))) + (put cg :hash-map + (tuple # array needs to be converted + ;(put (array ;(in cg :hash-map)) + 2 ~(cmt (capture ,(get-in cg [:hash-map 2])) + ,|{:tag :hash-map + :content (struct ;(slice $& 0 -2))})))) + (put cg :with-meta + ~(cmt (capture ,(in cg :with-meta)) + ,|{:tag :list + :content [{:tag :symbol + :content "with-meta"} + (get $& 1) + (get $& 0)]})) + # tried using a table with a peg but had a problem, so use a struct + (table/to-struct cg))) + +(comment + + (peg/match enlive-grammar "nil") + # => @[{:content "nil" :tag :nil} "nil"] + + (peg/match enlive-grammar "true") + # => @[{:content "true" :tag :boolean} "true"] + + (peg/match enlive-grammar ":hi") + # => @[{:content ":hi" :tag :keyword} ":hi"] + + (peg/match enlive-grammar "sym") + # => @[{:content "sym" :tag :symbol} "sym"] + + (peg/match enlive-grammar "'a") + `` + '@[{:content ({:content "quote" + :tag :symbol} + {:content "a" + :tag :symbol}) + :tag :list} "'a"] + `` + + (peg/match enlive-grammar "@a") + `` + '@[{:content ({:content "deref" + :tag :symbol} + {:content "a" + :tag :symbol}) + :tag :list} "@a"] + `` + + (peg/match enlive-grammar "`a") + `` + '@[{:content ({:content "quasiquote" + :tag :symbol} + {:content "a" + :tag :symbol}) + :tag :list} "`a"] + `` + + (peg/match enlive-grammar "~a") + `` + '@[{:content ({:content "unquote" + :tag :symbol} + {:content "a" + :tag :symbol}) + :tag :list} "~a"] + `` + + (peg/match enlive-grammar "~@a") + `` + '@[{:content ({:content "splice-unquote" + :tag :symbol} + {:content "a" + :tag :symbol}) + :tag :list} "~@a"] + `` + + (peg/match enlive-grammar "(a b c)") + `` + '@[{:content ({:content "a" + :tag :symbol} + {:content "b" + :tag :symbol} + {:content "c" + :tag :symbol}) + :tag :list} "(a b c)"] + `` + + (peg/match enlive-grammar "(a [:x :y] c)") + `` + '@[{:content ({:content "a" + :tag :symbol} + {:content ({:content ":x" + :tag :keyword} + {:content ":y" + :tag :keyword}) + :tag :vector} + {:content "c" + :tag :symbol}) + :tag :list} "(a [:x :y] c)"] + `` + + (peg/match enlive-grammar "^{:a 1} [:x :y]") + `` + '@[{:content ({:content "with-meta" + :tag :symbol} + {:content ({:content ":x" + :tag :keyword} + {:content ":y" + :tag :keyword}) + :tag :vector} + {:content {{:content ":a" + :tag :keyword} + {:content "1" + :tag :number}} + :tag :hash-map}) + :tag :list} "^{:a 1} [:x :y]"] + `` + + (peg/match enlive-grammar ";; hi") + # => @[";; hi"] + + (peg/match enlive-grammar "[:x ;; hi\n :y]") + `` + '@[{:content ({:content ":x" + :tag :keyword} + {:content ":y" + :tag :keyword}) + :tag :vector} "[:x ;; hi\n :y]"] + `` + + (peg/match enlive-grammar " 7 ") + # => @[{:content 7 :tag :number} " 7 "] + + (peg/match enlive-grammar " abc ") + # => @[{:content "abc" :tag :symbol} " abc "] + + (peg/match enlive-grammar " \nabc ") + # => @[{:content "abc" :tag :symbol} " \nabc "] + + ) + +(defn read_str + [code-str] + (let [[parsed _] + (try + (peg/match enlive-grammar code-str) + ([err] + (u/throw* (t/make-string err))))] + (if (= (type parsed) :struct) + parsed + (u/throw* t/mal-nil)))) + +(comment + + (read_str "(+ 1 2)") + `` + '{:content ({:content "+" + :tag :symbol} + {:content 1 + :tag :number} + {:content 2 + :tag :number}) + :tag :list} + `` + + (read_str ";; hello") + # => nil + + (read_str "\"1\"") + # => {:content "1" :tag :string} + + ) diff --git a/impls/janet/run b/impls/janet/run index 35b33525d7..d7ccd12434 100755 --- a/impls/janet/run +++ b/impls/janet/run @@ -1,3 +1,3 @@ -#!/bin/bash - -exec janet $(dirname $0)/${STEP:-stepA_mal}.janet "${@}" +#!/bin/bash + +exec janet $(dirname $0)/${STEP:-stepA_mal}.janet "${@}" diff --git a/impls/janet/step0_repl.janet b/impls/janet/step0_repl.janet index d31b9d11ea..0a1d50c555 100644 --- a/impls/janet/step0_repl.janet +++ b/impls/janet/step0_repl.janet @@ -1,31 +1,31 @@ -(defn READ - [code-str] - code-str) - -(defn EVAL - [ast] - ast) - -(defn PRINT - [ast] - ast) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str)))) - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn main - [& args] - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (< 0 (length buf)) - (prin (rep buf)) - (break)))) +(defn READ + [code-str] + code-str) + +(defn EVAL + [ast] + ast) + +(defn PRINT + [ast] + ast) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str)))) + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn main + [& args] + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (< 0 (length buf)) + (prin (rep buf)) + (break)))) diff --git a/impls/janet/step1_read_print.janet b/impls/janet/step1_read_print.janet index fa9e71fa63..8c88003f1b 100644 --- a/impls/janet/step1_read_print.janet +++ b/impls/janet/step1_read_print.janet @@ -1,49 +1,49 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(defn EVAL - [ast] - ast) - -(defn PRINT - [value] - (printer/pr_str value true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str)))) - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err)))))) +(import ./reader) +(import ./printer) +(import ./types :as t) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(defn EVAL + [ast] + ast) + +(defn PRINT + [value] + (printer/pr_str value true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str)))) + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err)))))) diff --git a/impls/janet/step2_eval.janet b/impls/janet/step2_eval.janet index 111bdf9b76..0094431eed 100644 --- a/impls/janet/step2_eval.janet +++ b/impls/janet/step2_eval.janet @@ -1,95 +1,95 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(defn arith-fn - [op] - (fn [ast-1 ast-2] - (t/make-number (op (t/get-value ast-1) - (t/get-value ast-2))))) - -(def repl_env - {(t/make-symbol "+") (arith-fn +) - (t/make-symbol "-") (arith-fn -) - (t/make-symbol "*") (arith-fn *) - (t/make-symbol "/") (arith-fn /)}) - -(var EVAL nil) - -(defn eval_ast - [ast env] - (cond - (t/symbol?* ast) - (if-let [val (env ast)] - val - (error (t/make-string (string "unbound symbol: " (t/get-value ast))))) - # - (t/hash-map?* ast) - (t/make-hash-map (struct ;(map |(EVAL $0 env) - (kvs (t/get-value ast))))) - # - (t/list?* ast) - (t/make-list (map |(EVAL $0 env) - (t/get-value ast))) - # - (t/vector?* ast) - (t/make-vector (map |(EVAL $0 env) - (t/get-value ast))) - # - ast)) - -(varfn EVAL - [ast env] - (cond - (not (t/list?* ast)) - (eval_ast ast env) - # - (t/empty?* ast) - ast - # - (let [eval-list (t/get-value (eval_ast ast env)) - f (first eval-list) - args (drop 1 eval-list)] - (apply f args)))) - -(defn PRINT - [value] - (printer/pr_str value true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err)))))) +(import ./reader) +(import ./printer) +(import ./types :as t) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(defn arith-fn + [op] + (fn [ast-1 ast-2] + (t/make-number (op (t/get-value ast-1) + (t/get-value ast-2))))) + +(def repl_env + {(t/make-symbol "+") (arith-fn +) + (t/make-symbol "-") (arith-fn -) + (t/make-symbol "*") (arith-fn *) + (t/make-symbol "/") (arith-fn /)}) + +(var EVAL nil) + +(defn eval_ast + [ast env] + (cond + (t/symbol?* ast) + (if-let [val (env ast)] + val + (error (t/make-string (string "unbound symbol: " (t/get-value ast))))) + # + (t/hash-map?* ast) + (t/make-hash-map (struct ;(map |(EVAL $0 env) + (kvs (t/get-value ast))))) + # + (t/list?* ast) + (t/make-list (map |(EVAL $0 env) + (t/get-value ast))) + # + (t/vector?* ast) + (t/make-vector (map |(EVAL $0 env) + (t/get-value ast))) + # + ast)) + +(varfn EVAL + [ast env] + (cond + (not (t/list?* ast)) + (eval_ast ast env) + # + (t/empty?* ast) + ast + # + (let [eval-list (t/get-value (eval_ast ast env)) + f (first eval-list) + args (drop 1 eval-list)] + (apply f args)))) + +(defn PRINT + [value] + (printer/pr_str value true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err)))))) diff --git a/impls/janet/step3_env.janet b/impls/janet/step3_env.janet index 9f99e80ee1..dbdf3d8cd5 100644 --- a/impls/janet/step3_env.janet +++ b/impls/janet/step3_env.janet @@ -1,114 +1,114 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) -(import ./env :as e) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(defn arith-fn - [op] - (fn [ast-1 ast-2] - (t/make-number (op (t/get-value ast-1) - (t/get-value ast-2))))) - -(def repl_env - (let [env (e/make-env)] - (e/env-set env (t/make-symbol "+") (arith-fn +)) - (e/env-set env (t/make-symbol "-") (arith-fn -)) - (e/env-set env (t/make-symbol "*") (arith-fn *)) - (e/env-set env (t/make-symbol "/") (arith-fn /)) - env)) - -(var EVAL nil) - -(defn eval_ast - [ast env] - (cond - (t/symbol?* ast) - (e/env-get env ast) - # - (t/hash-map?* ast) - (t/make-hash-map (struct ;(map |(EVAL $0 env) - (kvs (t/get-value ast))))) - # - (t/list?* ast) - (t/make-list (map |(EVAL $0 env) - (t/get-value ast))) - # - (t/vector?* ast) - (t/make-vector (map |(EVAL $0 env) - (t/get-value ast))) - # - ast)) - -(varfn EVAL - [ast env] - (cond - (not (t/list?* ast)) - (eval_ast ast env) - # - (t/empty?* ast) - ast - # - (let [ast-head (first (t/get-value ast)) - head-name (t/get-value ast-head)] - (case head-name - "def!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env)] - (e/env-set env - def-name def-val) - def-val) - # - "let*" - (let [new-env (e/make-env env) - bindings (t/get-value (in (t/get-value ast) 1))] - (each [let-name let-val] (partition 2 bindings) - (e/env-set new-env - let-name (EVAL let-val new-env))) - (EVAL (in (t/get-value ast) 2) new-env)) - # - (let [eval-list (t/get-value (eval_ast ast env)) - f (first eval-list) - args (drop 1 eval-list)] - (apply f args)))))) - -(defn PRINT - [value] - (printer/pr_str value true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err)))))) +(import ./reader) +(import ./printer) +(import ./types :as t) +(import ./env :as e) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(defn arith-fn + [op] + (fn [ast-1 ast-2] + (t/make-number (op (t/get-value ast-1) + (t/get-value ast-2))))) + +(def repl_env + (let [env (e/make-env)] + (e/env-set env (t/make-symbol "+") (arith-fn +)) + (e/env-set env (t/make-symbol "-") (arith-fn -)) + (e/env-set env (t/make-symbol "*") (arith-fn *)) + (e/env-set env (t/make-symbol "/") (arith-fn /)) + env)) + +(var EVAL nil) + +(defn eval_ast + [ast env] + (cond + (t/symbol?* ast) + (e/env-get env ast) + # + (t/hash-map?* ast) + (t/make-hash-map (struct ;(map |(EVAL $0 env) + (kvs (t/get-value ast))))) + # + (t/list?* ast) + (t/make-list (map |(EVAL $0 env) + (t/get-value ast))) + # + (t/vector?* ast) + (t/make-vector (map |(EVAL $0 env) + (t/get-value ast))) + # + ast)) + +(varfn EVAL + [ast env] + (cond + (not (t/list?* ast)) + (eval_ast ast env) + # + (t/empty?* ast) + ast + # + (let [ast-head (first (t/get-value ast)) + head-name (t/get-value ast-head)] + (case head-name + "def!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env)] + (e/env-set env + def-name def-val) + def-val) + # + "let*" + (let [new-env (e/make-env env) + bindings (t/get-value (in (t/get-value ast) 1))] + (each [let-name let-val] (partition 2 bindings) + (e/env-set new-env + let-name (EVAL let-val new-env))) + (EVAL (in (t/get-value ast) 2) new-env)) + # + (let [eval-list (t/get-value (eval_ast ast env)) + f (first eval-list) + args (drop 1 eval-list)] + (apply f args)))))) + +(defn PRINT + [value] + (printer/pr_str value true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err)))))) diff --git a/impls/janet/step4_if_fn_do.janet b/impls/janet/step4_if_fn_do.janet index e812eeb0ea..674a426cfc 100644 --- a/impls/janet/step4_if_fn_do.janet +++ b/impls/janet/step4_if_fn_do.janet @@ -1,130 +1,130 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) -(import ./env :as e) -(import ./core) - -(def repl_env - (let [env (e/make-env)] - (eachp [k v] core/ns - (e/env-set env k v)) - env)) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(var EVAL nil) - -(defn eval_ast - [ast env] - (cond - (t/symbol?* ast) - (e/env-get env ast) - # - (t/hash-map?* ast) - (t/make-hash-map (struct ;(map |(EVAL $0 env) - (kvs (t/get-value ast))))) - # - (t/list?* ast) - (t/make-list (map |(EVAL $0 env) - (t/get-value ast))) - # - (t/vector?* ast) - (t/make-vector (map |(EVAL $0 env) - (t/get-value ast))) - # - ast)) - -(varfn EVAL - [ast env] - (cond - (not (t/list?* ast)) - (eval_ast ast env) - # - (t/empty?* ast) - ast - # - (let [ast-head (first (t/get-value ast)) - head-name (t/get-value ast-head)] - (case head-name - "def!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env)] - (e/env-set env - def-name def-val) - def-val) - # - "let*" - (let [new-env (e/make-env env) - bindings (t/get-value (in (t/get-value ast) 1))] - (each [let-name let-val] (partition 2 bindings) - (e/env-set new-env - let-name (EVAL let-val new-env))) - (EVAL (in (t/get-value ast) 2) new-env)) - # - "do" - (let [do-body-forms (drop 1 (t/get-value ast)) - res-ast (eval_ast (t/make-list do-body-forms) env)] - (last (t/get-value res-ast))) - # - "if" - (let [cond-res (EVAL (in (t/get-value ast) 1) env)] - (if (or (t/nil?* cond-res) - (t/false?* cond-res)) - (if-let [else-ast (get (t/get-value ast) 3)] - (EVAL else-ast env) - t/mal-nil) - (EVAL (in (t/get-value ast) 2) env))) - # - "fn*" - (let [args (t/get-value (in (t/get-value ast) 1)) - body (in (t/get-value ast) 2)] - (t/make-function (fn [params] - (EVAL body - (e/make-env env args params))))) - # - (let [eval-list (t/get-value (eval_ast ast env)) - f (first eval-list) - args (drop 1 eval-list)] - ((t/get-value f) args)))))) - -(defn PRINT - [ast] - (printer/pr_str ast true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err)))))) +(import ./reader) +(import ./printer) +(import ./types :as t) +(import ./env :as e) +(import ./core) + +(def repl_env + (let [env (e/make-env)] + (eachp [k v] core/ns + (e/env-set env k v)) + env)) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(var EVAL nil) + +(defn eval_ast + [ast env] + (cond + (t/symbol?* ast) + (e/env-get env ast) + # + (t/hash-map?* ast) + (t/make-hash-map (struct ;(map |(EVAL $0 env) + (kvs (t/get-value ast))))) + # + (t/list?* ast) + (t/make-list (map |(EVAL $0 env) + (t/get-value ast))) + # + (t/vector?* ast) + (t/make-vector (map |(EVAL $0 env) + (t/get-value ast))) + # + ast)) + +(varfn EVAL + [ast env] + (cond + (not (t/list?* ast)) + (eval_ast ast env) + # + (t/empty?* ast) + ast + # + (let [ast-head (first (t/get-value ast)) + head-name (t/get-value ast-head)] + (case head-name + "def!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env)] + (e/env-set env + def-name def-val) + def-val) + # + "let*" + (let [new-env (e/make-env env) + bindings (t/get-value (in (t/get-value ast) 1))] + (each [let-name let-val] (partition 2 bindings) + (e/env-set new-env + let-name (EVAL let-val new-env))) + (EVAL (in (t/get-value ast) 2) new-env)) + # + "do" + (let [do-body-forms (drop 1 (t/get-value ast)) + res-ast (eval_ast (t/make-list do-body-forms) env)] + (last (t/get-value res-ast))) + # + "if" + (let [cond-res (EVAL (in (t/get-value ast) 1) env)] + (if (or (t/nil?* cond-res) + (t/false?* cond-res)) + (if-let [else-ast (get (t/get-value ast) 3)] + (EVAL else-ast env) + t/mal-nil) + (EVAL (in (t/get-value ast) 2) env))) + # + "fn*" + (let [args (t/get-value (in (t/get-value ast) 1)) + body (in (t/get-value ast) 2)] + (t/make-function (fn [params] + (EVAL body + (e/make-env env args params))))) + # + (let [eval-list (t/get-value (eval_ast ast env)) + f (first eval-list) + args (drop 1 eval-list)] + ((t/get-value f) args)))))) + +(defn PRINT + [ast] + (printer/pr_str ast true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err)))))) diff --git a/impls/janet/step5_tco.janet b/impls/janet/step5_tco.janet index a06cf4ebc9..fc2bc0526c 100644 --- a/impls/janet/step5_tco.janet +++ b/impls/janet/step5_tco.janet @@ -1,149 +1,149 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) -(import ./env :as e) -(import ./core) - -(def repl_env - (let [env (e/make-env)] - (eachp [k v] core/ns - (e/env-set env k v)) - env)) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(var EVAL nil) - -(defn eval_ast - [ast env] - (cond - (t/symbol?* ast) - (e/env-get env ast) - # - (t/hash-map?* ast) - (t/make-hash-map (struct ;(map |(EVAL $0 env) - (kvs (t/get-value ast))))) - # - (t/list?* ast) - (t/make-list (map |(EVAL $0 env) - (t/get-value ast))) - # - (t/vector?* ast) - (t/make-vector (map |(EVAL $0 env) - (t/get-value ast))) - # - ast)) - -(varfn EVAL - [ast-param env-param] - (var ast ast-param) - (var env env-param) - (label result - (while true - (cond - (not (t/list?* ast)) - (return result (eval_ast ast env)) - ## - (t/empty?* ast) - (return result ast) - ## - (let [ast-head (first (t/get-value ast)) - head-name (t/get-value ast-head)] - (case head-name - "def!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env)] - (e/env-set env - def-name def-val) - (return result def-val)) - ## - "let*" - (let [new-env (e/make-env env) - bindings (t/get-value (in (t/get-value ast) 1))] - (each [let-name let-val] (partition 2 bindings) - (e/env-set new-env - let-name (EVAL let-val new-env))) - ## tco - (set ast (in (t/get-value ast) 2)) - (set env new-env)) - ## - "do" - (let [most-do-body-forms (slice (t/get-value ast) 1 -2) - last-body-form (last (t/get-value ast)) - res-ast (eval_ast (t/make-list most-do-body-forms) env)] - ## tco - (set ast last-body-form)) - ## - "if" - (let [cond-res (EVAL (in (t/get-value ast) 1) env)] - (if (or (t/nil?* cond-res) - (t/false?* cond-res)) - (if-let [else-ast (get (t/get-value ast) 3)] - ## tco - (set ast else-ast) - (return result t/mal-nil)) - ## tco - (set ast (in (t/get-value ast) 2)))) - ## - "fn*" - (let [params (t/get-value (in (t/get-value ast) 1)) - body (in (t/get-value ast) 2)] - ## tco - (return result - (t/make-function (fn [args] - (EVAL body - (e/make-env env params args))) - nil false - body params env))) - ## - (let [eval-list (t/get-value (eval_ast ast env)) - f (first eval-list) - args (drop 1 eval-list)] - (if-let [body (t/get-ast f)] ## tco - (do - (set ast body) - (set env (e/make-env (t/get-env f) (t/get-params f) args))) - (return result - ((t/get-value f) args)))))))))) - -(defn PRINT - [ast] - (printer/pr_str ast true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err)))))) +(import ./reader) +(import ./printer) +(import ./types :as t) +(import ./env :as e) +(import ./core) + +(def repl_env + (let [env (e/make-env)] + (eachp [k v] core/ns + (e/env-set env k v)) + env)) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(var EVAL nil) + +(defn eval_ast + [ast env] + (cond + (t/symbol?* ast) + (e/env-get env ast) + # + (t/hash-map?* ast) + (t/make-hash-map (struct ;(map |(EVAL $0 env) + (kvs (t/get-value ast))))) + # + (t/list?* ast) + (t/make-list (map |(EVAL $0 env) + (t/get-value ast))) + # + (t/vector?* ast) + (t/make-vector (map |(EVAL $0 env) + (t/get-value ast))) + # + ast)) + +(varfn EVAL + [ast-param env-param] + (var ast ast-param) + (var env env-param) + (label result + (while true + (cond + (not (t/list?* ast)) + (return result (eval_ast ast env)) + ## + (t/empty?* ast) + (return result ast) + ## + (let [ast-head (first (t/get-value ast)) + head-name (t/get-value ast-head)] + (case head-name + "def!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env)] + (e/env-set env + def-name def-val) + (return result def-val)) + ## + "let*" + (let [new-env (e/make-env env) + bindings (t/get-value (in (t/get-value ast) 1))] + (each [let-name let-val] (partition 2 bindings) + (e/env-set new-env + let-name (EVAL let-val new-env))) + ## tco + (set ast (in (t/get-value ast) 2)) + (set env new-env)) + ## + "do" + (let [most-do-body-forms (slice (t/get-value ast) 1 -2) + last-body-form (last (t/get-value ast)) + res-ast (eval_ast (t/make-list most-do-body-forms) env)] + ## tco + (set ast last-body-form)) + ## + "if" + (let [cond-res (EVAL (in (t/get-value ast) 1) env)] + (if (or (t/nil?* cond-res) + (t/false?* cond-res)) + (if-let [else-ast (get (t/get-value ast) 3)] + ## tco + (set ast else-ast) + (return result t/mal-nil)) + ## tco + (set ast (in (t/get-value ast) 2)))) + ## + "fn*" + (let [params (t/get-value (in (t/get-value ast) 1)) + body (in (t/get-value ast) 2)] + ## tco + (return result + (t/make-function (fn [args] + (EVAL body + (e/make-env env params args))) + nil false + body params env))) + ## + (let [eval-list (t/get-value (eval_ast ast env)) + f (first eval-list) + args (drop 1 eval-list)] + (if-let [body (t/get-ast f)] ## tco + (do + (set ast body) + (set env (e/make-env (t/get-env f) (t/get-params f) args))) + (return result + ((t/get-value f) args)))))))))) + +(defn PRINT + [ast] + (printer/pr_str ast true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err)))))) diff --git a/impls/janet/step6_file.janet b/impls/janet/step6_file.janet index b7e2dd91f2..68466b25bf 100644 --- a/impls/janet/step6_file.janet +++ b/impls/janet/step6_file.janet @@ -1,177 +1,177 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) -(import ./env :as e) -(import ./core) - -(def repl_env - (let [env (e/make-env)] - (eachp [k v] core/ns - (e/env-set env k v)) - env)) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(var EVAL nil) - -(defn eval_ast - [ast env] - (cond - (t/symbol?* ast) - (e/env-get env ast) - # - (t/hash-map?* ast) - (t/make-hash-map (struct ;(map |(EVAL $0 env) - (kvs (t/get-value ast))))) - # - (t/list?* ast) - (t/make-list (map |(EVAL $0 env) - (t/get-value ast))) - # - (t/vector?* ast) - (t/make-vector (map |(EVAL $0 env) - (t/get-value ast))) - # - ast)) - -(varfn EVAL - [ast-param env-param] - (var ast ast-param) - (var env env-param) - (label result - (while true - (cond - (not (t/list?* ast)) - (return result (eval_ast ast env)) - ## - (t/empty?* ast) - (return result ast) - ## - (let [ast-head (first (t/get-value ast)) - head-name (t/get-value ast-head)] - (case head-name - "def!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env)] - (e/env-set env - def-name def-val) - (return result def-val)) - ## - "let*" - (let [new-env (e/make-env env) - bindings (t/get-value (in (t/get-value ast) 1))] - (each [let-name let-val] (partition 2 bindings) - (e/env-set new-env - let-name (EVAL let-val new-env))) - ## tco - (set ast (in (t/get-value ast) 2)) - (set env new-env)) - ## - "do" - (let [most-do-body-forms (slice (t/get-value ast) 1 -2) - last-body-form (last (t/get-value ast)) - res-ast (eval_ast (t/make-list most-do-body-forms) env)] - ## tco - (set ast last-body-form)) - ## - "if" - (let [cond-res (EVAL (in (t/get-value ast) 1) env)] - (if (or (t/nil?* cond-res) - (t/false?* cond-res)) - (if-let [else-ast (get (t/get-value ast) 3)] - ## tco - (set ast else-ast) - (return result t/mal-nil)) - ## tco - (set ast (in (t/get-value ast) 2)))) - ## - "fn*" - (let [params (t/get-value (in (t/get-value ast) 1)) - body (in (t/get-value ast) 2)] - ## tco - (return result - (t/make-function (fn [args] - (EVAL body - (e/make-env env params args))) - nil false - body params env))) - ## - (let [eval-list (t/get-value (eval_ast ast env)) - f (first eval-list) - args (drop 1 eval-list)] - (if-let [body (t/get-ast f)] ## tco - (do - (set ast body) - (set env (e/make-env (t/get-env f) (t/get-params f) args))) - (return result - ((t/get-value f) args)))))))))) - -(defn PRINT - [ast] - (printer/pr_str ast true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e/env-set repl_env - (t/make-symbol "eval") - (t/make-function (fn [asts] - (EVAL (in asts 0) repl_env)))) - -(rep `` - (def! load-file - (fn* (fpath) - (eval - (read-string (str "(do " - (slurp fpath) "\n" - "nil)"))))) -``) - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (let [args-len (length args) - argv (if (<= 2 args-len) - (drop 2 args) - ())] - (e/env-set repl_env - (t/make-symbol "*ARGV*") - (t/make-list (map t/make-string argv))) - (if (< 1 args-len) - (try - (rep - (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? - ([err] - (handle-error err))) - (do - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err))))))))) +(import ./reader) +(import ./printer) +(import ./types :as t) +(import ./env :as e) +(import ./core) + +(def repl_env + (let [env (e/make-env)] + (eachp [k v] core/ns + (e/env-set env k v)) + env)) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(var EVAL nil) + +(defn eval_ast + [ast env] + (cond + (t/symbol?* ast) + (e/env-get env ast) + # + (t/hash-map?* ast) + (t/make-hash-map (struct ;(map |(EVAL $0 env) + (kvs (t/get-value ast))))) + # + (t/list?* ast) + (t/make-list (map |(EVAL $0 env) + (t/get-value ast))) + # + (t/vector?* ast) + (t/make-vector (map |(EVAL $0 env) + (t/get-value ast))) + # + ast)) + +(varfn EVAL + [ast-param env-param] + (var ast ast-param) + (var env env-param) + (label result + (while true + (cond + (not (t/list?* ast)) + (return result (eval_ast ast env)) + ## + (t/empty?* ast) + (return result ast) + ## + (let [ast-head (first (t/get-value ast)) + head-name (t/get-value ast-head)] + (case head-name + "def!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env)] + (e/env-set env + def-name def-val) + (return result def-val)) + ## + "let*" + (let [new-env (e/make-env env) + bindings (t/get-value (in (t/get-value ast) 1))] + (each [let-name let-val] (partition 2 bindings) + (e/env-set new-env + let-name (EVAL let-val new-env))) + ## tco + (set ast (in (t/get-value ast) 2)) + (set env new-env)) + ## + "do" + (let [most-do-body-forms (slice (t/get-value ast) 1 -2) + last-body-form (last (t/get-value ast)) + res-ast (eval_ast (t/make-list most-do-body-forms) env)] + ## tco + (set ast last-body-form)) + ## + "if" + (let [cond-res (EVAL (in (t/get-value ast) 1) env)] + (if (or (t/nil?* cond-res) + (t/false?* cond-res)) + (if-let [else-ast (get (t/get-value ast) 3)] + ## tco + (set ast else-ast) + (return result t/mal-nil)) + ## tco + (set ast (in (t/get-value ast) 2)))) + ## + "fn*" + (let [params (t/get-value (in (t/get-value ast) 1)) + body (in (t/get-value ast) 2)] + ## tco + (return result + (t/make-function (fn [args] + (EVAL body + (e/make-env env params args))) + nil false + body params env))) + ## + (let [eval-list (t/get-value (eval_ast ast env)) + f (first eval-list) + args (drop 1 eval-list)] + (if-let [body (t/get-ast f)] ## tco + (do + (set ast body) + (set env (e/make-env (t/get-env f) (t/get-params f) args))) + (return result + ((t/get-value f) args)))))))))) + +(defn PRINT + [ast] + (printer/pr_str ast true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e/env-set repl_env + (t/make-symbol "eval") + (t/make-function (fn [asts] + (EVAL (in asts 0) repl_env)))) + +(rep `` + (def! load-file + (fn* (fpath) + (eval + (read-string (str "(do " + (slurp fpath) "\n" + "nil)"))))) +``) + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (let [args-len (length args) + argv (if (<= 2 args-len) + (drop 2 args) + ())] + (e/env-set repl_env + (t/make-symbol "*ARGV*") + (t/make-list (map t/make-string argv))) + (if (< 1 args-len) + (try + (rep + (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? + ([err] + (handle-error err))) + (do + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err))))))))) diff --git a/impls/janet/step7_quote.janet b/impls/janet/step7_quote.janet index 7760582212..6af0aaceb2 100644 --- a/impls/janet/step7_quote.janet +++ b/impls/janet/step7_quote.janet @@ -1,230 +1,230 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) -(import ./env :as e) -(import ./core) - -(def repl_env - (let [env (e/make-env)] - (eachp [k v] core/ns - (e/env-set env k v)) - env)) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(var EVAL nil) - -(defn eval_ast - [ast env] - (cond - (t/symbol?* ast) - (e/env-get env ast) - # - (t/hash-map?* ast) - (t/make-hash-map (struct ;(map |(EVAL $0 env) - (kvs (t/get-value ast))))) - # - (t/list?* ast) - (t/make-list (map |(EVAL $0 env) - (t/get-value ast))) - # - (t/vector?* ast) - (t/make-vector (map |(EVAL $0 env) - (t/get-value ast))) - # - ast)) - -(defn starts-with - [ast name] - (when (and (t/list?* ast) - (not (t/empty?* ast))) - (let [head-ast (in (t/get-value ast) 0)] - (and (t/symbol?* head-ast) - (= name (t/get-value head-ast)))))) - -(var quasiquote* nil) - -(defn qq-iter - [ast] - (if (t/empty?* ast) - (t/make-list ()) - (let [elt (in (t/get-value ast) 0) - acc (qq-iter (t/make-list (slice (t/get-value ast) 1)))] - (if (starts-with elt "splice-unquote") - (t/make-list [(t/make-symbol "concat") - (in (t/get-value elt) 1) - acc]) - (t/make-list [(t/make-symbol "cons") - (quasiquote* elt) - acc]))))) - -(varfn quasiquote* - [ast] - (cond - (starts-with ast "unquote") - (in (t/get-value ast) 1) - ## - (t/list?* ast) - (qq-iter ast) - ## - (t/vector?* ast) - (t/make-list [(t/make-symbol "vec") (qq-iter ast)]) - ## - (or (t/symbol?* ast) - (t/hash-map?* ast)) - (t/make-list [(t/make-symbol "quote") ast]) - ## - ast)) - -(varfn EVAL - [ast-param env-param] - (var ast ast-param) - (var env env-param) - (label result - (while true - (cond - (not (t/list?* ast)) - (return result (eval_ast ast env)) - ## - (t/empty?* ast) - (return result ast) - ## - (let [ast-head (first (t/get-value ast)) - head-name (t/get-value ast-head)] - (case head-name - "def!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env)] - (e/env-set env - def-name def-val) - (return result def-val)) - ## - "let*" - (let [new-env (e/make-env env) - bindings (t/get-value (in (t/get-value ast) 1))] - (each [let-name let-val] (partition 2 bindings) - (e/env-set new-env - let-name (EVAL let-val new-env))) - ## tco - (set ast (in (t/get-value ast) 2)) - (set env new-env)) - ## - "quote" - (return result (in (t/get-value ast) 1)) - ## - "quasiquoteexpand" - ## tco - (return result (quasiquote* (in (t/get-value ast) 1))) - ## - "quasiquote" - ## tco - (set ast (quasiquote* (in (t/get-value ast) 1))) - ## - "do" - (let [most-do-body-forms (slice (t/get-value ast) 1 -2) - last-body-form (last (t/get-value ast)) - res-ast (eval_ast (t/make-list most-do-body-forms) env)] - ## tco - (set ast last-body-form)) - ## - "if" - (let [cond-res (EVAL (in (t/get-value ast) 1) env)] - (if (or (t/nil?* cond-res) - (t/false?* cond-res)) - (if-let [else-ast (get (t/get-value ast) 3)] - ## tco - (set ast else-ast) - (return result t/mal-nil)) - ## tco - (set ast (in (t/get-value ast) 2)))) - ## - "fn*" - (let [params (t/get-value (in (t/get-value ast) 1)) - body (in (t/get-value ast) 2)] - ## tco - (return result - (t/make-function (fn [args] - (EVAL body - (e/make-env env params args))) - nil false - body params env))) - ## - (let [eval-list (t/get-value (eval_ast ast env)) - f (first eval-list) - args (drop 1 eval-list)] - (if-let [body (t/get-ast f)] ## tco - (do - (set ast body) - (set env (e/make-env (t/get-env f) (t/get-params f) args))) - (return result - ((t/get-value f) args)))))))))) - -(defn PRINT - [ast] - (printer/pr_str ast true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e/env-set repl_env - (t/make-symbol "eval") - (t/make-function (fn [asts] - (EVAL (in asts 0) repl_env)))) - -(rep `` - (def! load-file - (fn* (fpath) - (eval - (read-string (str "(do " - (slurp fpath) "\n" - "nil)"))))) -``) - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (let [args-len (length args) - argv (if (<= 2 args-len) - (drop 2 args) - ())] - (e/env-set repl_env - (t/make-symbol "*ARGV*") - (t/make-list (map t/make-string argv))) - (if (< 1 args-len) - (try - (rep - (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? - ([err] - (handle-error err))) - (do - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err))))))))) +(import ./reader) +(import ./printer) +(import ./types :as t) +(import ./env :as e) +(import ./core) + +(def repl_env + (let [env (e/make-env)] + (eachp [k v] core/ns + (e/env-set env k v)) + env)) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(var EVAL nil) + +(defn eval_ast + [ast env] + (cond + (t/symbol?* ast) + (e/env-get env ast) + # + (t/hash-map?* ast) + (t/make-hash-map (struct ;(map |(EVAL $0 env) + (kvs (t/get-value ast))))) + # + (t/list?* ast) + (t/make-list (map |(EVAL $0 env) + (t/get-value ast))) + # + (t/vector?* ast) + (t/make-vector (map |(EVAL $0 env) + (t/get-value ast))) + # + ast)) + +(defn starts-with + [ast name] + (when (and (t/list?* ast) + (not (t/empty?* ast))) + (let [head-ast (in (t/get-value ast) 0)] + (and (t/symbol?* head-ast) + (= name (t/get-value head-ast)))))) + +(var quasiquote* nil) + +(defn qq-iter + [ast] + (if (t/empty?* ast) + (t/make-list ()) + (let [elt (in (t/get-value ast) 0) + acc (qq-iter (t/make-list (slice (t/get-value ast) 1)))] + (if (starts-with elt "splice-unquote") + (t/make-list [(t/make-symbol "concat") + (in (t/get-value elt) 1) + acc]) + (t/make-list [(t/make-symbol "cons") + (quasiquote* elt) + acc]))))) + +(varfn quasiquote* + [ast] + (cond + (starts-with ast "unquote") + (in (t/get-value ast) 1) + ## + (t/list?* ast) + (qq-iter ast) + ## + (t/vector?* ast) + (t/make-list [(t/make-symbol "vec") (qq-iter ast)]) + ## + (or (t/symbol?* ast) + (t/hash-map?* ast)) + (t/make-list [(t/make-symbol "quote") ast]) + ## + ast)) + +(varfn EVAL + [ast-param env-param] + (var ast ast-param) + (var env env-param) + (label result + (while true + (cond + (not (t/list?* ast)) + (return result (eval_ast ast env)) + ## + (t/empty?* ast) + (return result ast) + ## + (let [ast-head (first (t/get-value ast)) + head-name (t/get-value ast-head)] + (case head-name + "def!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env)] + (e/env-set env + def-name def-val) + (return result def-val)) + ## + "let*" + (let [new-env (e/make-env env) + bindings (t/get-value (in (t/get-value ast) 1))] + (each [let-name let-val] (partition 2 bindings) + (e/env-set new-env + let-name (EVAL let-val new-env))) + ## tco + (set ast (in (t/get-value ast) 2)) + (set env new-env)) + ## + "quote" + (return result (in (t/get-value ast) 1)) + ## + "quasiquoteexpand" + ## tco + (return result (quasiquote* (in (t/get-value ast) 1))) + ## + "quasiquote" + ## tco + (set ast (quasiquote* (in (t/get-value ast) 1))) + ## + "do" + (let [most-do-body-forms (slice (t/get-value ast) 1 -2) + last-body-form (last (t/get-value ast)) + res-ast (eval_ast (t/make-list most-do-body-forms) env)] + ## tco + (set ast last-body-form)) + ## + "if" + (let [cond-res (EVAL (in (t/get-value ast) 1) env)] + (if (or (t/nil?* cond-res) + (t/false?* cond-res)) + (if-let [else-ast (get (t/get-value ast) 3)] + ## tco + (set ast else-ast) + (return result t/mal-nil)) + ## tco + (set ast (in (t/get-value ast) 2)))) + ## + "fn*" + (let [params (t/get-value (in (t/get-value ast) 1)) + body (in (t/get-value ast) 2)] + ## tco + (return result + (t/make-function (fn [args] + (EVAL body + (e/make-env env params args))) + nil false + body params env))) + ## + (let [eval-list (t/get-value (eval_ast ast env)) + f (first eval-list) + args (drop 1 eval-list)] + (if-let [body (t/get-ast f)] ## tco + (do + (set ast body) + (set env (e/make-env (t/get-env f) (t/get-params f) args))) + (return result + ((t/get-value f) args)))))))))) + +(defn PRINT + [ast] + (printer/pr_str ast true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e/env-set repl_env + (t/make-symbol "eval") + (t/make-function (fn [asts] + (EVAL (in asts 0) repl_env)))) + +(rep `` + (def! load-file + (fn* (fpath) + (eval + (read-string (str "(do " + (slurp fpath) "\n" + "nil)"))))) +``) + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (let [args-len (length args) + argv (if (<= 2 args-len) + (drop 2 args) + ())] + (e/env-set repl_env + (t/make-symbol "*ARGV*") + (t/make-list (map t/make-string argv))) + (if (< 1 args-len) + (try + (rep + (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? + ([err] + (handle-error err))) + (do + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err))))))))) diff --git a/impls/janet/step8_macros.janet b/impls/janet/step8_macros.janet index 6ebb8cc824..5288824a4e 100644 --- a/impls/janet/step8_macros.janet +++ b/impls/janet/step8_macros.janet @@ -1,278 +1,278 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) -(import ./env :as e) -(import ./core) - -(def repl_env - (let [env (e/make-env)] - (eachp [k v] core/ns - (e/env-set env k v)) - env)) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(defn is_macro_call - [ast env] - (when (and (t/list?* ast) - (not (t/empty?* ast))) - (let [head-ast (in (t/get-value ast) 0)] - (when (and (t/symbol?* head-ast) - (e/env-find env head-ast)) - (let [target-ast (e/env-get env head-ast)] - (t/macro?* target-ast)))))) - -(defn macroexpand - [ast env] - (var ast-var ast) - (while (is_macro_call ast-var env) - (let [inner-asts (t/get-value ast-var) - head-ast (in inner-asts 0) - macro-fn (t/get-value (e/env-get env head-ast)) - args (drop 1 inner-asts)] - (set ast-var (macro-fn args)))) - ast-var) - -(var EVAL nil) - -(defn eval_ast - [ast env] - (cond - (t/symbol?* ast) - (e/env-get env ast) - # - (t/hash-map?* ast) - (t/make-hash-map (struct ;(map |(EVAL $0 env) - (kvs (t/get-value ast))))) - # - (t/list?* ast) - (t/make-list (map |(EVAL $0 env) - (t/get-value ast))) - # - (t/vector?* ast) - (t/make-vector (map |(EVAL $0 env) - (t/get-value ast))) - # - ast)) - -(defn starts-with - [ast name] - (when (and (t/list?* ast) - (not (t/empty?* ast))) - (let [head-ast (in (t/get-value ast) 0)] - (and (t/symbol?* head-ast) - (= name (t/get-value head-ast)))))) - -(var quasiquote* nil) - -(defn qq-iter - [ast] - (if (t/empty?* ast) - (t/make-list ()) - (let [elt (in (t/get-value ast) 0) - acc (qq-iter (t/make-list (slice (t/get-value ast) 1)))] - (if (starts-with elt "splice-unquote") - (t/make-list [(t/make-symbol "concat") - (in (t/get-value elt) 1) - acc]) - (t/make-list [(t/make-symbol "cons") - (quasiquote* elt) - acc]))))) - -(varfn quasiquote* - [ast] - (cond - (starts-with ast "unquote") - (in (t/get-value ast) 1) - ## - (t/list?* ast) - (qq-iter ast) - ## - (t/vector?* ast) - (t/make-list [(t/make-symbol "vec") (qq-iter ast)]) - ## - (or (t/symbol?* ast) - (t/hash-map?* ast)) - (t/make-list [(t/make-symbol "quote") ast]) - ## - ast)) - -(varfn EVAL - [ast-param env-param] - (var ast ast-param) - (var env env-param) - (label result - (while true - (when (not (t/list?* ast)) - (return result (eval_ast ast env))) - ## - (set ast (macroexpand ast env)) - ## - (when (not (t/list?* ast)) - (return result (eval_ast ast env))) - ## - (when (t/empty?* ast) - (return result ast)) - ## - (let [ast-head (first (t/get-value ast)) - head-name (t/get-value ast-head)] - (case head-name - "def!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env)] - (e/env-set env - def-name def-val) - (return result def-val)) - ## - "defmacro!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env) - macro-ast (t/macrofy def-val)] - (e/env-set env - def-name macro-ast) - (return result macro-ast)) - ## - "macroexpand" - (return result (macroexpand (in (t/get-value ast) 1) env)) - ## - "let*" - (let [new-env (e/make-env env) - bindings (t/get-value (in (t/get-value ast) 1))] - (each [let-name let-val] (partition 2 bindings) - (e/env-set new-env - let-name (EVAL let-val new-env))) - ## tco - (set ast (in (t/get-value ast) 2)) - (set env new-env)) - ## - "quote" - (return result (in (t/get-value ast) 1)) - ## - "quasiquoteexpand" - ## tco - (return result (quasiquote* (in (t/get-value ast) 1))) - ## - "quasiquote" - ## tco - (set ast (quasiquote* (in (t/get-value ast) 1))) - ## - "do" - (let [most-do-body-forms (slice (t/get-value ast) 1 -2) - last-body-form (last (t/get-value ast)) - res-ast (eval_ast (t/make-list most-do-body-forms) env)] - ## tco - (set ast last-body-form)) - ## - "if" - (let [cond-res (EVAL (in (t/get-value ast) 1) env)] - (if (or (t/nil?* cond-res) - (t/false?* cond-res)) - (if-let [else-ast (get (t/get-value ast) 3)] - ## tco - (set ast else-ast) - (return result t/mal-nil)) - ## tco - (set ast (in (t/get-value ast) 2)))) - ## - "fn*" - (let [params (t/get-value (in (t/get-value ast) 1)) - body (in (t/get-value ast) 2)] - ## tco - (return result - (t/make-function (fn [args] - (EVAL body - (e/make-env env params args))) - nil false - body params env))) - ## - (let [eval-list (t/get-value (eval_ast ast env)) - f (first eval-list) - args (drop 1 eval-list)] - (if-let [body (t/get-ast f)] ## tco - (do - (set ast body) - (set env (e/make-env (t/get-env f) (t/get-params f) args))) - (return result - ((t/get-value f) args))))))))) - -(defn PRINT - [ast] - (printer/pr_str ast true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e/env-set repl_env - (t/make-symbol "eval") - (t/make-function (fn [asts] - (EVAL (in asts 0) repl_env)))) - -(rep `` - (def! load-file - (fn* (fpath) - (eval - (read-string (str "(do " - (slurp fpath) "\n" - "nil)"))))) -``) - -(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))))))) -``) - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (let [args-len (length args) - argv (if (<= 2 args-len) - (drop 2 args) - ())] - (e/env-set repl_env - (t/make-symbol "*ARGV*") - (t/make-list (map t/make-string argv))) - (if (< 1 args-len) - (try - (rep - (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? - ([err] - (handle-error err))) - (do - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err))))))))) +(import ./reader) +(import ./printer) +(import ./types :as t) +(import ./env :as e) +(import ./core) + +(def repl_env + (let [env (e/make-env)] + (eachp [k v] core/ns + (e/env-set env k v)) + env)) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(defn is_macro_call + [ast env] + (when (and (t/list?* ast) + (not (t/empty?* ast))) + (let [head-ast (in (t/get-value ast) 0)] + (when (and (t/symbol?* head-ast) + (e/env-find env head-ast)) + (let [target-ast (e/env-get env head-ast)] + (t/macro?* target-ast)))))) + +(defn macroexpand + [ast env] + (var ast-var ast) + (while (is_macro_call ast-var env) + (let [inner-asts (t/get-value ast-var) + head-ast (in inner-asts 0) + macro-fn (t/get-value (e/env-get env head-ast)) + args (drop 1 inner-asts)] + (set ast-var (macro-fn args)))) + ast-var) + +(var EVAL nil) + +(defn eval_ast + [ast env] + (cond + (t/symbol?* ast) + (e/env-get env ast) + # + (t/hash-map?* ast) + (t/make-hash-map (struct ;(map |(EVAL $0 env) + (kvs (t/get-value ast))))) + # + (t/list?* ast) + (t/make-list (map |(EVAL $0 env) + (t/get-value ast))) + # + (t/vector?* ast) + (t/make-vector (map |(EVAL $0 env) + (t/get-value ast))) + # + ast)) + +(defn starts-with + [ast name] + (when (and (t/list?* ast) + (not (t/empty?* ast))) + (let [head-ast (in (t/get-value ast) 0)] + (and (t/symbol?* head-ast) + (= name (t/get-value head-ast)))))) + +(var quasiquote* nil) + +(defn qq-iter + [ast] + (if (t/empty?* ast) + (t/make-list ()) + (let [elt (in (t/get-value ast) 0) + acc (qq-iter (t/make-list (slice (t/get-value ast) 1)))] + (if (starts-with elt "splice-unquote") + (t/make-list [(t/make-symbol "concat") + (in (t/get-value elt) 1) + acc]) + (t/make-list [(t/make-symbol "cons") + (quasiquote* elt) + acc]))))) + +(varfn quasiquote* + [ast] + (cond + (starts-with ast "unquote") + (in (t/get-value ast) 1) + ## + (t/list?* ast) + (qq-iter ast) + ## + (t/vector?* ast) + (t/make-list [(t/make-symbol "vec") (qq-iter ast)]) + ## + (or (t/symbol?* ast) + (t/hash-map?* ast)) + (t/make-list [(t/make-symbol "quote") ast]) + ## + ast)) + +(varfn EVAL + [ast-param env-param] + (var ast ast-param) + (var env env-param) + (label result + (while true + (when (not (t/list?* ast)) + (return result (eval_ast ast env))) + ## + (set ast (macroexpand ast env)) + ## + (when (not (t/list?* ast)) + (return result (eval_ast ast env))) + ## + (when (t/empty?* ast) + (return result ast)) + ## + (let [ast-head (first (t/get-value ast)) + head-name (t/get-value ast-head)] + (case head-name + "def!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env)] + (e/env-set env + def-name def-val) + (return result def-val)) + ## + "defmacro!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env) + macro-ast (t/macrofy def-val)] + (e/env-set env + def-name macro-ast) + (return result macro-ast)) + ## + "macroexpand" + (return result (macroexpand (in (t/get-value ast) 1) env)) + ## + "let*" + (let [new-env (e/make-env env) + bindings (t/get-value (in (t/get-value ast) 1))] + (each [let-name let-val] (partition 2 bindings) + (e/env-set new-env + let-name (EVAL let-val new-env))) + ## tco + (set ast (in (t/get-value ast) 2)) + (set env new-env)) + ## + "quote" + (return result (in (t/get-value ast) 1)) + ## + "quasiquoteexpand" + ## tco + (return result (quasiquote* (in (t/get-value ast) 1))) + ## + "quasiquote" + ## tco + (set ast (quasiquote* (in (t/get-value ast) 1))) + ## + "do" + (let [most-do-body-forms (slice (t/get-value ast) 1 -2) + last-body-form (last (t/get-value ast)) + res-ast (eval_ast (t/make-list most-do-body-forms) env)] + ## tco + (set ast last-body-form)) + ## + "if" + (let [cond-res (EVAL (in (t/get-value ast) 1) env)] + (if (or (t/nil?* cond-res) + (t/false?* cond-res)) + (if-let [else-ast (get (t/get-value ast) 3)] + ## tco + (set ast else-ast) + (return result t/mal-nil)) + ## tco + (set ast (in (t/get-value ast) 2)))) + ## + "fn*" + (let [params (t/get-value (in (t/get-value ast) 1)) + body (in (t/get-value ast) 2)] + ## tco + (return result + (t/make-function (fn [args] + (EVAL body + (e/make-env env params args))) + nil false + body params env))) + ## + (let [eval-list (t/get-value (eval_ast ast env)) + f (first eval-list) + args (drop 1 eval-list)] + (if-let [body (t/get-ast f)] ## tco + (do + (set ast body) + (set env (e/make-env (t/get-env f) (t/get-params f) args))) + (return result + ((t/get-value f) args))))))))) + +(defn PRINT + [ast] + (printer/pr_str ast true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e/env-set repl_env + (t/make-symbol "eval") + (t/make-function (fn [asts] + (EVAL (in asts 0) repl_env)))) + +(rep `` + (def! load-file + (fn* (fpath) + (eval + (read-string (str "(do " + (slurp fpath) "\n" + "nil)"))))) +``) + +(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))))))) +``) + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (let [args-len (length args) + argv (if (<= 2 args-len) + (drop 2 args) + ())] + (e/env-set repl_env + (t/make-symbol "*ARGV*") + (t/make-list (map t/make-string argv))) + (if (< 1 args-len) + (try + (rep + (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? + ([err] + (handle-error err))) + (do + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err))))))))) diff --git a/impls/janet/step9_try.janet b/impls/janet/step9_try.janet index b297965cd2..61fa359935 100644 --- a/impls/janet/step9_try.janet +++ b/impls/janet/step9_try.janet @@ -1,303 +1,303 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) -(import ./utils :as u) -(import ./env :as e) -(import ./core) - -(def repl_env - (let [env (e/make-env)] - (eachp [k v] core/ns - (e/env-set env k v)) - env)) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(defn is_macro_call - [ast env] - (when (and (t/list?* ast) - (not (t/empty?* ast))) - (let [head-ast (in (t/get-value ast) 0)] - (when (and (t/symbol?* head-ast) - (e/env-find env head-ast)) - (let [target-ast (e/env-get env head-ast)] - (t/macro?* target-ast)))))) - -(defn macroexpand - [ast env] - (var ast-var ast) - (while (is_macro_call ast-var env) - (let [inner-asts (t/get-value ast-var) - head-ast (in inner-asts 0) - macro-fn (t/get-value (e/env-get env head-ast)) - args (drop 1 inner-asts)] - (set ast-var (macro-fn args)))) - ast-var) - -(var EVAL nil) - -(defn eval_ast - [ast env] - (cond - (t/symbol?* ast) - (e/env-get env ast) - # - (t/hash-map?* ast) - (t/make-hash-map (struct ;(map |(EVAL $0 env) - (kvs (t/get-value ast))))) - # - (t/list?* ast) - (t/make-list (map |(EVAL $0 env) - (t/get-value ast))) - # - (t/vector?* ast) - (t/make-vector (map |(EVAL $0 env) - (t/get-value ast))) - # - ast)) - -(defn starts-with - [ast name] - (when (and (t/list?* ast) - (not (t/empty?* ast))) - (let [head-ast (in (t/get-value ast) 0)] - (and (t/symbol?* head-ast) - (= name (t/get-value head-ast)))))) - -(var quasiquote* nil) - -(defn qq-iter - [ast] - (if (t/empty?* ast) - (t/make-list ()) - (let [elt (in (t/get-value ast) 0) - acc (qq-iter (t/make-list (slice (t/get-value ast) 1)))] - (if (starts-with elt "splice-unquote") - (t/make-list [(t/make-symbol "concat") - (in (t/get-value elt) 1) - acc]) - (t/make-list [(t/make-symbol "cons") - (quasiquote* elt) - acc]))))) - -(varfn quasiquote* - [ast] - (cond - (starts-with ast "unquote") - (in (t/get-value ast) 1) - ## - (t/list?* ast) - (qq-iter ast) - ## - (t/vector?* ast) - (t/make-list [(t/make-symbol "vec") (qq-iter ast)]) - ## - (or (t/symbol?* ast) - (t/hash-map?* ast)) - (t/make-list [(t/make-symbol "quote") ast]) - ## - ast)) - -(varfn EVAL - [ast-param env-param] - (var ast ast-param) - (var env env-param) - (label result - (while true - (when (not (t/list?* ast)) - (return result (eval_ast ast env))) - ## - (set ast (macroexpand ast env)) - ## - (when (not (t/list?* ast)) - (return result (eval_ast ast env))) - ## - (when (t/empty?* ast) - (return result ast)) - ## - (let [ast-head (first (t/get-value ast)) - head-name (t/get-value ast-head)] - (case head-name - "def!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env)] - (e/env-set env - def-name def-val) - (return result def-val)) - ## - "defmacro!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env) - macro-ast (t/macrofy def-val)] - (e/env-set env - def-name macro-ast) - (return result macro-ast)) - ## - "macroexpand" - (return result (macroexpand (in (t/get-value ast) 1) env)) - ## - "let*" - (let [new-env (e/make-env env) - bindings (t/get-value (in (t/get-value ast) 1))] - (each [let-name let-val] (partition 2 bindings) - (e/env-set new-env - let-name (EVAL let-val new-env))) - ## tco - (set ast (in (t/get-value ast) 2)) - (set env new-env)) - ## - "quote" - (return result (in (t/get-value ast) 1)) - ## - "quasiquoteexpand" - ## tco - (return result (quasiquote* (in (t/get-value ast) 1))) - ## - "quasiquote" - ## tco - (set ast (quasiquote* (in (t/get-value ast) 1))) - ## - "try*" - (let [res - (try - (EVAL (in (t/get-value ast) 1) env) - ([err] - (if-let [maybe-catch-ast (get (t/get-value ast) 2)] - (if (starts-with maybe-catch-ast "catch*") - (let [catch-asts (t/get-value maybe-catch-ast)] - (if (>= (length catch-asts) 2) - (let [catch-sym-ast (in catch-asts 1) - catch-body-ast (in catch-asts 2)] - (EVAL catch-body-ast (e/make-env env - [catch-sym-ast] - [err]))) - (u/throw* - (t/make-string - "catch* requires at least 2 arguments")))) - (u/throw* - (t/make-string - "Expected catch* form"))) - # XXX: is this appropriate? show error message? - (u/throw* err))))] - (return result res)) - ## - "do" - (let [most-do-body-forms (slice (t/get-value ast) 1 -2) - last-body-form (last (t/get-value ast)) - res-ast (eval_ast (t/make-list most-do-body-forms) env)] - ## tco - (set ast last-body-form)) - ## - "if" - (let [cond-res (EVAL (in (t/get-value ast) 1) env)] - (if (or (t/nil?* cond-res) - (t/false?* cond-res)) - (if-let [else-ast (get (t/get-value ast) 3)] - ## tco - (set ast else-ast) - (return result t/mal-nil)) - ## tco - (set ast (in (t/get-value ast) 2)))) - ## - "fn*" - (let [params (t/get-value (in (t/get-value ast) 1)) - body (in (t/get-value ast) 2)] - ## tco - (return result - (t/make-function (fn [args] - (EVAL body - (e/make-env env params args))) - nil false - body params env))) - ## - (let [eval-list (t/get-value (eval_ast ast env)) - f (first eval-list) - args (drop 1 eval-list)] - (if-let [body (t/get-ast f)] ## tco - (do - (set ast body) - (set env (e/make-env (t/get-env f) (t/get-params f) args))) - (return result - ((t/get-value f) args))))))))) - -(defn PRINT - [ast] - (printer/pr_str ast true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e/env-set repl_env - (t/make-symbol "eval") - (t/make-function (fn [asts] - (EVAL (in asts 0) repl_env)))) - -(rep `` - (def! load-file - (fn* (fpath) - (eval - (read-string (str "(do " - (slurp fpath) "\n" - "nil)"))))) -``) - -(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))))))) -``) - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (let [args-len (length args) - argv (if (<= 2 args-len) - (drop 2 args) - ())] - (e/env-set repl_env - (t/make-symbol "*ARGV*") - (t/make-list (map t/make-string argv))) - (if (< 1 args-len) - (try - (rep - (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? - ([err] - (handle-error err))) - (do - (var buf nil) - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err))))))))) +(import ./reader) +(import ./printer) +(import ./types :as t) +(import ./utils :as u) +(import ./env :as e) +(import ./core) + +(def repl_env + (let [env (e/make-env)] + (eachp [k v] core/ns + (e/env-set env k v)) + env)) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(defn is_macro_call + [ast env] + (when (and (t/list?* ast) + (not (t/empty?* ast))) + (let [head-ast (in (t/get-value ast) 0)] + (when (and (t/symbol?* head-ast) + (e/env-find env head-ast)) + (let [target-ast (e/env-get env head-ast)] + (t/macro?* target-ast)))))) + +(defn macroexpand + [ast env] + (var ast-var ast) + (while (is_macro_call ast-var env) + (let [inner-asts (t/get-value ast-var) + head-ast (in inner-asts 0) + macro-fn (t/get-value (e/env-get env head-ast)) + args (drop 1 inner-asts)] + (set ast-var (macro-fn args)))) + ast-var) + +(var EVAL nil) + +(defn eval_ast + [ast env] + (cond + (t/symbol?* ast) + (e/env-get env ast) + # + (t/hash-map?* ast) + (t/make-hash-map (struct ;(map |(EVAL $0 env) + (kvs (t/get-value ast))))) + # + (t/list?* ast) + (t/make-list (map |(EVAL $0 env) + (t/get-value ast))) + # + (t/vector?* ast) + (t/make-vector (map |(EVAL $0 env) + (t/get-value ast))) + # + ast)) + +(defn starts-with + [ast name] + (when (and (t/list?* ast) + (not (t/empty?* ast))) + (let [head-ast (in (t/get-value ast) 0)] + (and (t/symbol?* head-ast) + (= name (t/get-value head-ast)))))) + +(var quasiquote* nil) + +(defn qq-iter + [ast] + (if (t/empty?* ast) + (t/make-list ()) + (let [elt (in (t/get-value ast) 0) + acc (qq-iter (t/make-list (slice (t/get-value ast) 1)))] + (if (starts-with elt "splice-unquote") + (t/make-list [(t/make-symbol "concat") + (in (t/get-value elt) 1) + acc]) + (t/make-list [(t/make-symbol "cons") + (quasiquote* elt) + acc]))))) + +(varfn quasiquote* + [ast] + (cond + (starts-with ast "unquote") + (in (t/get-value ast) 1) + ## + (t/list?* ast) + (qq-iter ast) + ## + (t/vector?* ast) + (t/make-list [(t/make-symbol "vec") (qq-iter ast)]) + ## + (or (t/symbol?* ast) + (t/hash-map?* ast)) + (t/make-list [(t/make-symbol "quote") ast]) + ## + ast)) + +(varfn EVAL + [ast-param env-param] + (var ast ast-param) + (var env env-param) + (label result + (while true + (when (not (t/list?* ast)) + (return result (eval_ast ast env))) + ## + (set ast (macroexpand ast env)) + ## + (when (not (t/list?* ast)) + (return result (eval_ast ast env))) + ## + (when (t/empty?* ast) + (return result ast)) + ## + (let [ast-head (first (t/get-value ast)) + head-name (t/get-value ast-head)] + (case head-name + "def!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env)] + (e/env-set env + def-name def-val) + (return result def-val)) + ## + "defmacro!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env) + macro-ast (t/macrofy def-val)] + (e/env-set env + def-name macro-ast) + (return result macro-ast)) + ## + "macroexpand" + (return result (macroexpand (in (t/get-value ast) 1) env)) + ## + "let*" + (let [new-env (e/make-env env) + bindings (t/get-value (in (t/get-value ast) 1))] + (each [let-name let-val] (partition 2 bindings) + (e/env-set new-env + let-name (EVAL let-val new-env))) + ## tco + (set ast (in (t/get-value ast) 2)) + (set env new-env)) + ## + "quote" + (return result (in (t/get-value ast) 1)) + ## + "quasiquoteexpand" + ## tco + (return result (quasiquote* (in (t/get-value ast) 1))) + ## + "quasiquote" + ## tco + (set ast (quasiquote* (in (t/get-value ast) 1))) + ## + "try*" + (let [res + (try + (EVAL (in (t/get-value ast) 1) env) + ([err] + (if-let [maybe-catch-ast (get (t/get-value ast) 2)] + (if (starts-with maybe-catch-ast "catch*") + (let [catch-asts (t/get-value maybe-catch-ast)] + (if (>= (length catch-asts) 2) + (let [catch-sym-ast (in catch-asts 1) + catch-body-ast (in catch-asts 2)] + (EVAL catch-body-ast (e/make-env env + [catch-sym-ast] + [err]))) + (u/throw* + (t/make-string + "catch* requires at least 2 arguments")))) + (u/throw* + (t/make-string + "Expected catch* form"))) + # XXX: is this appropriate? show error message? + (u/throw* err))))] + (return result res)) + ## + "do" + (let [most-do-body-forms (slice (t/get-value ast) 1 -2) + last-body-form (last (t/get-value ast)) + res-ast (eval_ast (t/make-list most-do-body-forms) env)] + ## tco + (set ast last-body-form)) + ## + "if" + (let [cond-res (EVAL (in (t/get-value ast) 1) env)] + (if (or (t/nil?* cond-res) + (t/false?* cond-res)) + (if-let [else-ast (get (t/get-value ast) 3)] + ## tco + (set ast else-ast) + (return result t/mal-nil)) + ## tco + (set ast (in (t/get-value ast) 2)))) + ## + "fn*" + (let [params (t/get-value (in (t/get-value ast) 1)) + body (in (t/get-value ast) 2)] + ## tco + (return result + (t/make-function (fn [args] + (EVAL body + (e/make-env env params args))) + nil false + body params env))) + ## + (let [eval-list (t/get-value (eval_ast ast env)) + f (first eval-list) + args (drop 1 eval-list)] + (if-let [body (t/get-ast f)] ## tco + (do + (set ast body) + (set env (e/make-env (t/get-env f) (t/get-params f) args))) + (return result + ((t/get-value f) args))))))))) + +(defn PRINT + [ast] + (printer/pr_str ast true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e/env-set repl_env + (t/make-symbol "eval") + (t/make-function (fn [asts] + (EVAL (in asts 0) repl_env)))) + +(rep `` + (def! load-file + (fn* (fpath) + (eval + (read-string (str "(do " + (slurp fpath) "\n" + "nil)"))))) +``) + +(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))))))) +``) + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (let [args-len (length args) + argv (if (<= 2 args-len) + (drop 2 args) + ())] + (e/env-set repl_env + (t/make-symbol "*ARGV*") + (t/make-list (map t/make-string argv))) + (if (< 1 args-len) + (try + (rep + (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? + ([err] + (handle-error err))) + (do + (var buf nil) + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err))))))))) diff --git a/impls/janet/stepA_mal.janet b/impls/janet/stepA_mal.janet index ca33086d8c..e1d6be920c 100644 --- a/impls/janet/stepA_mal.janet +++ b/impls/janet/stepA_mal.janet @@ -1,308 +1,308 @@ -(import ./reader) -(import ./printer) -(import ./types :as t) -(import ./utils :as u) -(import ./env :as e) -(import ./core) - -(def repl_env - (let [env (e/make-env)] - (eachp [k v] core/ns - (e/env-set env k v)) - env)) - -(defn READ - [code-str] - (reader/read_str code-str)) - -(defn is_macro_call - [ast env] - (when (and (t/list?* ast) - (not (t/empty?* ast))) - (let [head-ast (in (t/get-value ast) 0)] - (when (and (t/symbol?* head-ast) - (e/env-find env head-ast)) - (let [target-ast (e/env-get env head-ast)] - (t/macro?* target-ast)))))) - -(defn macroexpand - [ast env] - (var ast-var ast) - (while (is_macro_call ast-var env) - (let [inner-asts (t/get-value ast-var) - head-ast (in inner-asts 0) - macro-fn (t/get-value (e/env-get env head-ast)) - args (drop 1 inner-asts)] - (set ast-var (macro-fn args)))) - ast-var) - -(var EVAL nil) - -(defn eval_ast - [ast env] - (cond - (t/symbol?* ast) - (e/env-get env ast) - # - (t/hash-map?* ast) - (t/make-hash-map (struct ;(map |(EVAL $0 env) - (kvs (t/get-value ast))))) - # - (t/list?* ast) - (t/make-list (map |(EVAL $0 env) - (t/get-value ast))) - # - (t/vector?* ast) - (t/make-vector (map |(EVAL $0 env) - (t/get-value ast))) - # - ast)) - -(defn starts-with - [ast name] - (when (and (t/list?* ast) - (not (t/empty?* ast))) - (let [head-ast (in (t/get-value ast) 0)] - (and (t/symbol?* head-ast) - (= name (t/get-value head-ast)))))) - -(var quasiquote* nil) - -(defn qq-iter - [ast] - (if (t/empty?* ast) - (t/make-list ()) - (let [elt (in (t/get-value ast) 0) - acc (qq-iter (t/make-list (slice (t/get-value ast) 1)))] - (if (starts-with elt "splice-unquote") - (t/make-list [(t/make-symbol "concat") - (in (t/get-value elt) 1) - acc]) - (t/make-list [(t/make-symbol "cons") - (quasiquote* elt) - acc]))))) - -(varfn quasiquote* - [ast] - (cond - (starts-with ast "unquote") - (in (t/get-value ast) 1) - ## - (t/list?* ast) - (qq-iter ast) - ## - (t/vector?* ast) - (t/make-list [(t/make-symbol "vec") (qq-iter ast)]) - ## - (or (t/symbol?* ast) - (t/hash-map?* ast)) - (t/make-list [(t/make-symbol "quote") ast]) - ## - ast)) - -(varfn EVAL - [ast-param env-param] - (var ast ast-param) - (var env env-param) - (label result - (while true - (when (not (t/list?* ast)) - (return result (eval_ast ast env))) - ## - (set ast (macroexpand ast env)) - ## - (when (not (t/list?* ast)) - (return result (eval_ast ast env))) - ## - (when (t/empty?* ast) - (return result ast)) - ## - (let [ast-head (in (t/get-value ast) 0) - head-name (t/get-value ast-head)] - (case head-name - "def!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env)] - (e/env-set env - def-name def-val) - (return result def-val)) - ## - "defmacro!" - (let [def-name (in (t/get-value ast) 1) - def-val (EVAL (in (t/get-value ast) 2) env) - macro-ast (t/macrofy def-val)] - (e/env-set env - def-name macro-ast) - (return result macro-ast)) - ## - "macroexpand" - (return result (macroexpand (in (t/get-value ast) 1) env)) - ## - "let*" - (let [new-env (e/make-env env) - bindings (t/get-value (in (t/get-value ast) 1))] - (each [let-name let-val] (partition 2 bindings) - (e/env-set new-env - let-name (EVAL let-val new-env))) - ## tco - (set ast (in (t/get-value ast) 2)) - (set env new-env)) - ## - "quote" - (return result (in (t/get-value ast) 1)) - ## - "quasiquoteexpand" - ## tco - (return result (quasiquote* (in (t/get-value ast) 1))) - ## - "quasiquote" - ## tco - (set ast (quasiquote* (in (t/get-value ast) 1))) - ## - "try*" - (let [res - (try - (EVAL (in (t/get-value ast) 1) env) - ([err] - (if-let [maybe-catch-ast (get (t/get-value ast) 2)] - (if (starts-with maybe-catch-ast "catch*") - (let [catch-asts (t/get-value maybe-catch-ast)] - (if (>= (length catch-asts) 2) - (let [catch-sym-ast (in catch-asts 1) - catch-body-ast (in catch-asts 2)] - (EVAL catch-body-ast (e/make-env env - [catch-sym-ast] - [err]))) - (u/throw* - (t/make-string - "catch* requires at least 2 arguments")))) - (u/throw* - (t/make-string - "Expected catch* form"))) - # XXX: is this appropriate? show error message? - (u/throw* err))))] - (return result res)) - ## - "do" - (let [most-do-body-forms (slice (t/get-value ast) 1 -2) - last-body-form (last (t/get-value ast)) - res-ast (eval_ast (t/make-list most-do-body-forms) env)] - ## tco - (set ast last-body-form)) - ## - "if" - (let [cond-res (EVAL (in (t/get-value ast) 1) env)] - (if (or (t/nil?* cond-res) - (t/false?* cond-res)) - (if-let [else-ast (get (t/get-value ast) 3)] - ## tco - (set ast else-ast) - (return result t/mal-nil)) - ## tco - (set ast (in (t/get-value ast) 2)))) - ## - "fn*" - (let [params (t/get-value (in (t/get-value ast) 1)) - body (in (t/get-value ast) 2)] - ## tco - (return result - (t/make-function (fn [args] - (EVAL body - (e/make-env env params args))) - nil false - body params env))) - ## - (let [eval-list (t/get-value (eval_ast ast env)) - f (first eval-list) - args (drop 1 eval-list)] - (if-let [body (t/get-ast f)] ## tco - (do - (set ast body) - (set env (e/make-env (t/get-env f) (t/get-params f) args))) - (return result - ((t/get-value f) args))))))))) - -(defn PRINT - [ast] - (printer/pr_str ast true)) - -(defn rep - [code-str] - (PRINT (EVAL (READ code-str) repl_env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(e/env-set repl_env - (t/make-symbol "eval") - (t/make-function (fn [asts] - (EVAL (in asts 0) repl_env)))) - -(rep `` - (def! load-file - (fn* (fpath) - (eval - (read-string (str "(do " - (slurp fpath) "\n" - "nil)"))))) -``) - -(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))))))) -``) - -(e/env-set repl_env - (t/make-symbol "*host-language*") - (t/make-string "janet")) - -# getline gives problems -(defn getstdin [prompt buf] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - -(defn handle-error - [err] - (cond - (t/nil?* err) - (print) - ## - (string? err) - (print err) - ## - (print (string "Error: " (PRINT err))))) - -(defn main - [& args] - (let [args-len (length args) - argv (if (<= 2 args-len) - (drop 2 args) - ())] - (e/env-set repl_env - (t/make-symbol "*ARGV*") - (t/make-list (map t/make-string argv))) - (if (< 1 args-len) - (try - (rep - (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? - ([err] - (handle-error err))) - (do - (var buf nil) - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (while true - (set buf @"") - (getstdin "user> " buf) - (if (= 0 (length buf)) - (break) - (try - (print (rep buf)) - ([err] - (handle-error err))))))))) +(import ./reader) +(import ./printer) +(import ./types :as t) +(import ./utils :as u) +(import ./env :as e) +(import ./core) + +(def repl_env + (let [env (e/make-env)] + (eachp [k v] core/ns + (e/env-set env k v)) + env)) + +(defn READ + [code-str] + (reader/read_str code-str)) + +(defn is_macro_call + [ast env] + (when (and (t/list?* ast) + (not (t/empty?* ast))) + (let [head-ast (in (t/get-value ast) 0)] + (when (and (t/symbol?* head-ast) + (e/env-find env head-ast)) + (let [target-ast (e/env-get env head-ast)] + (t/macro?* target-ast)))))) + +(defn macroexpand + [ast env] + (var ast-var ast) + (while (is_macro_call ast-var env) + (let [inner-asts (t/get-value ast-var) + head-ast (in inner-asts 0) + macro-fn (t/get-value (e/env-get env head-ast)) + args (drop 1 inner-asts)] + (set ast-var (macro-fn args)))) + ast-var) + +(var EVAL nil) + +(defn eval_ast + [ast env] + (cond + (t/symbol?* ast) + (e/env-get env ast) + # + (t/hash-map?* ast) + (t/make-hash-map (struct ;(map |(EVAL $0 env) + (kvs (t/get-value ast))))) + # + (t/list?* ast) + (t/make-list (map |(EVAL $0 env) + (t/get-value ast))) + # + (t/vector?* ast) + (t/make-vector (map |(EVAL $0 env) + (t/get-value ast))) + # + ast)) + +(defn starts-with + [ast name] + (when (and (t/list?* ast) + (not (t/empty?* ast))) + (let [head-ast (in (t/get-value ast) 0)] + (and (t/symbol?* head-ast) + (= name (t/get-value head-ast)))))) + +(var quasiquote* nil) + +(defn qq-iter + [ast] + (if (t/empty?* ast) + (t/make-list ()) + (let [elt (in (t/get-value ast) 0) + acc (qq-iter (t/make-list (slice (t/get-value ast) 1)))] + (if (starts-with elt "splice-unquote") + (t/make-list [(t/make-symbol "concat") + (in (t/get-value elt) 1) + acc]) + (t/make-list [(t/make-symbol "cons") + (quasiquote* elt) + acc]))))) + +(varfn quasiquote* + [ast] + (cond + (starts-with ast "unquote") + (in (t/get-value ast) 1) + ## + (t/list?* ast) + (qq-iter ast) + ## + (t/vector?* ast) + (t/make-list [(t/make-symbol "vec") (qq-iter ast)]) + ## + (or (t/symbol?* ast) + (t/hash-map?* ast)) + (t/make-list [(t/make-symbol "quote") ast]) + ## + ast)) + +(varfn EVAL + [ast-param env-param] + (var ast ast-param) + (var env env-param) + (label result + (while true + (when (not (t/list?* ast)) + (return result (eval_ast ast env))) + ## + (set ast (macroexpand ast env)) + ## + (when (not (t/list?* ast)) + (return result (eval_ast ast env))) + ## + (when (t/empty?* ast) + (return result ast)) + ## + (let [ast-head (in (t/get-value ast) 0) + head-name (t/get-value ast-head)] + (case head-name + "def!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env)] + (e/env-set env + def-name def-val) + (return result def-val)) + ## + "defmacro!" + (let [def-name (in (t/get-value ast) 1) + def-val (EVAL (in (t/get-value ast) 2) env) + macro-ast (t/macrofy def-val)] + (e/env-set env + def-name macro-ast) + (return result macro-ast)) + ## + "macroexpand" + (return result (macroexpand (in (t/get-value ast) 1) env)) + ## + "let*" + (let [new-env (e/make-env env) + bindings (t/get-value (in (t/get-value ast) 1))] + (each [let-name let-val] (partition 2 bindings) + (e/env-set new-env + let-name (EVAL let-val new-env))) + ## tco + (set ast (in (t/get-value ast) 2)) + (set env new-env)) + ## + "quote" + (return result (in (t/get-value ast) 1)) + ## + "quasiquoteexpand" + ## tco + (return result (quasiquote* (in (t/get-value ast) 1))) + ## + "quasiquote" + ## tco + (set ast (quasiquote* (in (t/get-value ast) 1))) + ## + "try*" + (let [res + (try + (EVAL (in (t/get-value ast) 1) env) + ([err] + (if-let [maybe-catch-ast (get (t/get-value ast) 2)] + (if (starts-with maybe-catch-ast "catch*") + (let [catch-asts (t/get-value maybe-catch-ast)] + (if (>= (length catch-asts) 2) + (let [catch-sym-ast (in catch-asts 1) + catch-body-ast (in catch-asts 2)] + (EVAL catch-body-ast (e/make-env env + [catch-sym-ast] + [err]))) + (u/throw* + (t/make-string + "catch* requires at least 2 arguments")))) + (u/throw* + (t/make-string + "Expected catch* form"))) + # XXX: is this appropriate? show error message? + (u/throw* err))))] + (return result res)) + ## + "do" + (let [most-do-body-forms (slice (t/get-value ast) 1 -2) + last-body-form (last (t/get-value ast)) + res-ast (eval_ast (t/make-list most-do-body-forms) env)] + ## tco + (set ast last-body-form)) + ## + "if" + (let [cond-res (EVAL (in (t/get-value ast) 1) env)] + (if (or (t/nil?* cond-res) + (t/false?* cond-res)) + (if-let [else-ast (get (t/get-value ast) 3)] + ## tco + (set ast else-ast) + (return result t/mal-nil)) + ## tco + (set ast (in (t/get-value ast) 2)))) + ## + "fn*" + (let [params (t/get-value (in (t/get-value ast) 1)) + body (in (t/get-value ast) 2)] + ## tco + (return result + (t/make-function (fn [args] + (EVAL body + (e/make-env env params args))) + nil false + body params env))) + ## + (let [eval-list (t/get-value (eval_ast ast env)) + f (first eval-list) + args (drop 1 eval-list)] + (if-let [body (t/get-ast f)] ## tco + (do + (set ast body) + (set env (e/make-env (t/get-env f) (t/get-params f) args))) + (return result + ((t/get-value f) args))))))))) + +(defn PRINT + [ast] + (printer/pr_str ast true)) + +(defn rep + [code-str] + (PRINT (EVAL (READ code-str) repl_env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(e/env-set repl_env + (t/make-symbol "eval") + (t/make-function (fn [asts] + (EVAL (in asts 0) repl_env)))) + +(rep `` + (def! load-file + (fn* (fpath) + (eval + (read-string (str "(do " + (slurp fpath) "\n" + "nil)"))))) +``) + +(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))))))) +``) + +(e/env-set repl_env + (t/make-symbol "*host-language*") + (t/make-string "janet")) + +# getline gives problems +(defn getstdin [prompt buf] + (file/write stdout prompt) + (file/flush stdout) + (file/read stdin :line buf)) + +(defn handle-error + [err] + (cond + (t/nil?* err) + (print) + ## + (string? err) + (print err) + ## + (print (string "Error: " (PRINT err))))) + +(defn main + [& args] + (let [args-len (length args) + argv (if (<= 2 args-len) + (drop 2 args) + ())] + (e/env-set repl_env + (t/make-symbol "*ARGV*") + (t/make-list (map t/make-string argv))) + (if (< 1 args-len) + (try + (rep + (string "(load-file \"" (in args 1) "\")")) # XXX: escaping? + ([err] + (handle-error err))) + (do + (var buf nil) + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (while true + (set buf @"") + (getstdin "user> " buf) + (if (= 0 (length buf)) + (break) + (try + (print (rep buf)) + ([err] + (handle-error err))))))))) diff --git a/impls/janet/tests/stepA_mal.mal b/impls/janet/tests/stepA_mal.mal index 2b6ba61721..334d5e6eed 100644 --- a/impls/janet/tests/stepA_mal.mal +++ b/impls/janet/tests/stepA_mal.mal @@ -1,42 +1,42 @@ -;; Testing basic Janet interop - -(janet-eval "7") -;=>7 - -(janet-eval "\"7\"") -;=>"7" - -(janet-eval "nil") -;=>nil - -(janet-eval "(= 123 123)") -;=>true - -(janet-eval "(= 123 456)") -;=>false - -(janet-eval ":my-keyword") -;=>:my-keyword - -(janet-eval "'(7 8 9)") -;=>(7 8 9) - -(janet-eval "{:abc 789}") -;=>{:abc 789} - -(janet-eval "(print \"hello\")") -;/hello -;=>nil - -(janet-eval "(defn foo [] 8)") -(janet-eval "(foo)") -;=>8 - -(janet-eval "(let [tup [:a 1 :b 2]] (struct ;tup))") -;=>{:a 1 :b 2} - -(janet-eval "(do (def tbl @{}) (put tbl :x 8) tbl)") -;=>{:x 8} - -(janet-eval "(do (var mut 1) (set mut 2) mut)") -;=>2 +;; Testing basic Janet interop + +(janet-eval "7") +;=>7 + +(janet-eval "\"7\"") +;=>"7" + +(janet-eval "nil") +;=>nil + +(janet-eval "(= 123 123)") +;=>true + +(janet-eval "(= 123 456)") +;=>false + +(janet-eval ":my-keyword") +;=>:my-keyword + +(janet-eval "'(7 8 9)") +;=>(7 8 9) + +(janet-eval "{:abc 789}") +;=>{:abc 789} + +(janet-eval "(print \"hello\")") +;/hello +;=>nil + +(janet-eval "(defn foo [] 8)") +(janet-eval "(foo)") +;=>8 + +(janet-eval "(let [tup [:a 1 :b 2]] (struct ;tup))") +;=>{:a 1 :b 2} + +(janet-eval "(do (def tbl @{}) (put tbl :x 8) tbl)") +;=>{:x 8} + +(janet-eval "(do (var mut 1) (set mut 2) mut)") +;=>2 diff --git a/impls/janet/types.janet b/impls/janet/types.janet index 1931dcf6e1..c00205fa29 100644 --- a/impls/janet/types.janet +++ b/impls/janet/types.janet @@ -1,245 +1,245 @@ -(defn make-nil - [] - {:tag :nil - :content "nil"}) - -(defn make-boolean - [bool] - {:tag :boolean - :content (string bool)}) - -(defn make-keyword - [a-str] - {:tag :keyword - :content a-str}) - -(defn make-number - [a-num] - {:tag :number - :content a-num}) - -(defn make-string - [a-str] - {:tag :string - :content a-str}) - -(defn make-symbol - [a-str] - {:tag :symbol - :content a-str}) - -(defn make-hash-map - [items &opt meta] - (default meta (make-nil)) - (let [a-struct (if (dictionary? items) - items - (struct ;items))] - {:tag :hash-map - :content a-struct - :meta meta})) - -(defn make-list - [items &opt meta] - (default meta (make-nil)) - {:tag :list - :content items - :meta meta}) - -(defn make-vector - [items &opt meta] - (default meta (make-nil)) - {:tag :vector - :content items - :meta meta}) - -(defn make-function - [a-fn &opt meta is-macro ast params env] - (default meta (make-nil)) - (default is-macro false) - {:tag :function - :content a-fn - :meta meta - :is-macro is-macro - :ast ast - :params params - :env env}) - -(defn make-atom - [ast] - @{:tag :atom - :content ast}) - -(defn set-atom-value! - [atom-ast value-ast] - (put atom-ast - :content value-ast)) - -(defn make-exception - [ast] - {:tag :exception - :content ast}) - -## common accessors - -(defn get-value - [ast] - (ast :content)) - -(defn get-type - [ast] - (ast :tag)) - -(defn get-meta - [ast] - (ast :meta)) - -## function-specific accessors - -(defn get-is-macro - [ast] - (ast :is-macro)) - -(defn get-ast - [ast] - (ast :ast)) - -(defn get-params - [ast] - (ast :params)) - -(defn get-env - [ast] - (ast :env)) - -## function-specific functions - -(defn macrofy - [fn-ast] - (merge fn-ast {:is-macro true})) - -(defn clone-with-meta - [fn-ast meta-ast] - (merge fn-ast {:meta meta-ast})) - -## predicates - -(defn nil?* - [ast] - (= :nil (get-type ast))) - -(defn boolean?* - [ast] - (= :boolean (get-type ast))) - -(defn true?* - [ast] - (and (boolean?* ast) - (= "true" (get-value ast)))) - -(defn false?* - [ast] - (and (boolean?* ast) - (= "false" (get-value ast)))) - -(defn number?* - [ast] - (= :number (get-type ast))) - -(defn symbol?* - [ast] - (= :symbol (get-type ast))) - -(defn keyword?* - [ast] - (= :keyword (get-type ast))) - -(defn string?* - [ast] - (= :string (get-type ast))) - -(defn list?* - [ast] - (= :list (get-type ast))) - -(defn vector?* - [ast] - (= :vector (get-type ast))) - -(defn hash-map?* - [ast] - (= :hash-map (get-type ast))) - -(defn fn?* - [ast] - (= :function (get-type ast))) - -(defn macro?* - [ast] - (and (fn?* ast) - (get-is-macro ast))) - -(defn atom?* - [ast] - (= :atom (get-type ast))) - -(defn exception?* - [ast] - (= :exception (get-type ast))) - -(defn empty?* - [ast] - (empty? (get-value ast))) - -# XXX: likely this could be simpler -(defn equals?* - [ast-1 ast-2] - (let [type-1 (get-type ast-1) - type-2 (get-type ast-2)] - (if (and (not= type-1 type-2) - # XXX: not elegant - (not (and (list?* ast-1) (vector?* ast-2))) - (not (and (list?* ast-2) (vector?* ast-1)))) - false - (let [val-1 (get-value ast-1) - val-2 (get-value ast-2)] - # XXX: when not a collection... - (if (and (not (list?* ast-1)) - (not (vector?* ast-1)) - (not (hash-map?* ast-1))) - (= val-1 val-2) - (if (not= (length val-1) (length val-2)) - false - (if (and (not (hash-map?* ast-1)) - (not (hash-map?* ast-2))) - (do - (var found-unequal false) - (each [v1 v2] (partition 2 (interleave val-1 val-2)) - (when (not (equals?* v1 v2)) - (set found-unequal true) - (break))) - (not found-unequal)) - (if (or (not (hash-map?* ast-1)) - (not (hash-map?* ast-2))) - false - (do - (var found-unequal false) - (each [k1 k2] (partition 2 (interleave (keys val-1) - (keys val-2))) - (when (not (equals?* k1 k2)) - (set found-unequal true) - (break)) - (when (not (equals?* (val-1 k1) (val-2 k2))) - (set found-unequal true) - (break))) - (not found-unequal)))))))))) - -## highlander types - -(def mal-nil - (make-nil)) - -(def mal-true - (make-boolean true)) - -(def mal-false - (make-boolean false)) +(defn make-nil + [] + {:tag :nil + :content "nil"}) + +(defn make-boolean + [bool] + {:tag :boolean + :content (string bool)}) + +(defn make-keyword + [a-str] + {:tag :keyword + :content a-str}) + +(defn make-number + [a-num] + {:tag :number + :content a-num}) + +(defn make-string + [a-str] + {:tag :string + :content a-str}) + +(defn make-symbol + [a-str] + {:tag :symbol + :content a-str}) + +(defn make-hash-map + [items &opt meta] + (default meta (make-nil)) + (let [a-struct (if (dictionary? items) + items + (struct ;items))] + {:tag :hash-map + :content a-struct + :meta meta})) + +(defn make-list + [items &opt meta] + (default meta (make-nil)) + {:tag :list + :content items + :meta meta}) + +(defn make-vector + [items &opt meta] + (default meta (make-nil)) + {:tag :vector + :content items + :meta meta}) + +(defn make-function + [a-fn &opt meta is-macro ast params env] + (default meta (make-nil)) + (default is-macro false) + {:tag :function + :content a-fn + :meta meta + :is-macro is-macro + :ast ast + :params params + :env env}) + +(defn make-atom + [ast] + @{:tag :atom + :content ast}) + +(defn set-atom-value! + [atom-ast value-ast] + (put atom-ast + :content value-ast)) + +(defn make-exception + [ast] + {:tag :exception + :content ast}) + +## common accessors + +(defn get-value + [ast] + (ast :content)) + +(defn get-type + [ast] + (ast :tag)) + +(defn get-meta + [ast] + (ast :meta)) + +## function-specific accessors + +(defn get-is-macro + [ast] + (ast :is-macro)) + +(defn get-ast + [ast] + (ast :ast)) + +(defn get-params + [ast] + (ast :params)) + +(defn get-env + [ast] + (ast :env)) + +## function-specific functions + +(defn macrofy + [fn-ast] + (merge fn-ast {:is-macro true})) + +(defn clone-with-meta + [fn-ast meta-ast] + (merge fn-ast {:meta meta-ast})) + +## predicates + +(defn nil?* + [ast] + (= :nil (get-type ast))) + +(defn boolean?* + [ast] + (= :boolean (get-type ast))) + +(defn true?* + [ast] + (and (boolean?* ast) + (= "true" (get-value ast)))) + +(defn false?* + [ast] + (and (boolean?* ast) + (= "false" (get-value ast)))) + +(defn number?* + [ast] + (= :number (get-type ast))) + +(defn symbol?* + [ast] + (= :symbol (get-type ast))) + +(defn keyword?* + [ast] + (= :keyword (get-type ast))) + +(defn string?* + [ast] + (= :string (get-type ast))) + +(defn list?* + [ast] + (= :list (get-type ast))) + +(defn vector?* + [ast] + (= :vector (get-type ast))) + +(defn hash-map?* + [ast] + (= :hash-map (get-type ast))) + +(defn fn?* + [ast] + (= :function (get-type ast))) + +(defn macro?* + [ast] + (and (fn?* ast) + (get-is-macro ast))) + +(defn atom?* + [ast] + (= :atom (get-type ast))) + +(defn exception?* + [ast] + (= :exception (get-type ast))) + +(defn empty?* + [ast] + (empty? (get-value ast))) + +# XXX: likely this could be simpler +(defn equals?* + [ast-1 ast-2] + (let [type-1 (get-type ast-1) + type-2 (get-type ast-2)] + (if (and (not= type-1 type-2) + # XXX: not elegant + (not (and (list?* ast-1) (vector?* ast-2))) + (not (and (list?* ast-2) (vector?* ast-1)))) + false + (let [val-1 (get-value ast-1) + val-2 (get-value ast-2)] + # XXX: when not a collection... + (if (and (not (list?* ast-1)) + (not (vector?* ast-1)) + (not (hash-map?* ast-1))) + (= val-1 val-2) + (if (not= (length val-1) (length val-2)) + false + (if (and (not (hash-map?* ast-1)) + (not (hash-map?* ast-2))) + (do + (var found-unequal false) + (each [v1 v2] (partition 2 (interleave val-1 val-2)) + (when (not (equals?* v1 v2)) + (set found-unequal true) + (break))) + (not found-unequal)) + (if (or (not (hash-map?* ast-1)) + (not (hash-map?* ast-2))) + false + (do + (var found-unequal false) + (each [k1 k2] (partition 2 (interleave (keys val-1) + (keys val-2))) + (when (not (equals?* k1 k2)) + (set found-unequal true) + (break)) + (when (not (equals?* (val-1 k1) (val-2 k2))) + (set found-unequal true) + (break))) + (not found-unequal)))))))))) + +## highlander types + +(def mal-nil + (make-nil)) + +(def mal-true + (make-boolean true)) + +(def mal-false + (make-boolean false)) diff --git a/impls/janet/utils.janet b/impls/janet/utils.janet index 2fe6b6d156..f55799a14a 100644 --- a/impls/janet/utils.janet +++ b/impls/janet/utils.janet @@ -1,3 +1,3 @@ -(defn throw* - [ast] - (error ast)) +(defn throw* + [ast] + (error ast)) diff --git a/impls/java-truffle/.gitignore b/impls/java-truffle/.gitignore index e797f2e42f..b09297a9f4 100644 --- a/impls/java-truffle/.gitignore +++ b/impls/java-truffle/.gitignore @@ -1,10 +1,10 @@ -.classpath -.project -.settings -target -/.gradle/ -/build/ -.factorypath -.apt_generated -bin -graal_dumps +.classpath +.project +.settings +target +/.gradle/ +/build/ +.factorypath +.apt_generated +bin +graal_dumps diff --git a/impls/java-truffle/Makefile b/impls/java-truffle/Makefile index 4ce458d18d..d368272cd9 100644 --- a/impls/java-truffle/Makefile +++ b/impls/java-truffle/Makefile @@ -1,8 +1,8 @@ -all: - gradle build - -build/classes/java/main/truffle/mal/step%.class: src/main/java/truffle/mal/*.java - gradle build - -clean: - gradle clean +all: + gradle build + +build/classes/java/main/truffle/mal/step%.class: src/main/java/truffle/mal/*.java + gradle build + +clean: + gradle clean diff --git a/impls/java-truffle/README.md b/impls/java-truffle/README.md index 932b742207..136d19366b 100644 --- a/impls/java-truffle/README.md +++ b/impls/java-truffle/README.md @@ -1,699 +1,699 @@ -# Truffle Mal - -This Mal is implemented in Java using the [Truffle Framework](https://github.com/oracle/graal/blob/master/truffle/README.md). -Truffle is a library for implementing interpreters. When -these interpreters are run on GraalVM, the GraalVM compiler -is able to JIT compile interpreted programs using a technique -called [partial evaluation](https://en.wikipedia.org/wiki/Partial_evaluation). - -Partially evaluating an interpreter plus a program to produce compiled -code requires a careful balance. If every last bit of interpreter code -(including supporting libraries, etc.) -is subject to partial evaluation, the result will explode to -unreasonable size. Boundaries must be drawn. Exclude too much, though, -and the speed up resulting from compilation may not be worth the -effort of the compilation. - -Truffle's "thesis" is that a small set of primitives are sufficient to make -JIT compilation via partial evaluation practical. -These primitives feed runtime data collected by the executing interpreter -to the compiler, allowing it to _specialize_, or optimistically -simplify, the interpreter code at compilation time. The compiler inserts -lightweight runtime checks of the assumptions that justify its -simplifications. If the checks fail, the compiled code is _de-optimized_, -and control is returned to the interpreter. -See [Practical Partial Evaluation for High-Performance Dynamic Language Runtimes](http://chrisseaton.com/rubytruffle/pldi17-truffle/pldi17-truffle.pdf), from PLDI 2017, for a deeper treatment of the ideas behind Truffle. - -The Truffle Mal implementation is my attempt at putting the Truffle thesis -to the test. - -Can I, an engineer without a background in compiler design, use Truffle to -implement an interpreter for a dynamic language (Mal) that substantially -outperforms the existing Java interpreter for Mal? - -*The Short Answer: Yup.* - -```bash - # Recursive Fibonacci on OpenJDK 11 with java mal - $ ./run ../tests/fib.mal 30 10 - Times (in ms) for (fib 30) on java: [2062 1809 1814 1777 1772 1791 1725 1723 1786 1745] - - # Recursive Fibonacci on GraalVM with java-truffle mal - $ ./run ../tests/fib.mal 30 10 - Times (in ms) for (fib 30) on java-truffle: [280 142 21 26 22 75 21 26 21 24] - - # That's an 82x speed-up! Just out of curiosity... - # How does Clojure on OpenJDK 11? We'll even throw in a type hint. - $ lein repl - Clojure 1.10.0 - OpenJDK 64-Bit Server VM 11.0.7+10-post-Ubuntu-2ubuntu218.04 - user=> (defn fib [^long n] (if (= n 0) 1 (if (= n 1) 1 (+ (fib (- n 1)) (fib (- n 2)))))) - #'user/fib - user=> (dotimes [i 5] (time (fib 30))) - "Elapsed time: 32.0791 msecs" - "Elapsed time: 31.7552 msecs" - "Elapsed time: 31.5361 msecs" - "Elapsed time: 31.4796 msecs" - "Elapsed time: 31.4541 msecs" -``` - -A recursive Fibonacci computation is _obviously_ not sufficient to characterize the -performance of our implementation (and as we'll see, it turns out to be -something of a best-case scenario), but it sure looks impressive! - -Do more complicated Mal programs show similar speed-ups? - -How much simplicity did we have to sacrifice in the name of performance? - -Was it worth it? - -How much of the speed-up is really attributable to the Truffle/GraalVM combo, -and how much came from putting more time into the code itself? - -We'll explore the answers to these questions together in the remainder! - -## Disclaimers - -*First and foremost*: To the extend that this experiment _succeeds_ in its goal of -producing an efficient Mal implementation, the credit is due to the teams -behind Truffle and GraalVM. To the extend that this experiment _fails_, the blame -falls on *me*! The reader should assume, by default, that any deficiencies in -this Mal implementation are due to my own failure to understand or -properly apply the tools at my disposal, and _not_ due to any fundamental -limitations of Truffle or GraalVM. - -*Second:* This Mal implementation is _not_ idiomatic Java, and it's _not_ an -idiomatic application of Truffle. The project's -unusual organization (large numbers of package-private classes bundled -into single files like Types.java, substantial duplication between step files) -represent my attempt to adhere both to the spirit of Mal's -pedagogical approach and the organization of the existing Java implementation. -Consequently I have abused Truffle in several ways (that I am aware of, and perhaps -others that I am not?). Each Mal step -registers a distinct Truffle implementation whose language id has the form "mal_step${n}". -The languages for each step have distinct AST node sub-classes, but they share -the built-in AST nodes in Core.java and the runtime types in Types.java. This sharing -creates some awkwardness in Core.java. - -## Prerequisites - -[GraalVM Community Edition](https://www.graalvm.org/downloads/) (version 20.1.0 or higher) -should be on your PATH and pointed to by JAVA_HOME. - -You'll also need to [install Gradle](https://gradle.org/install/) -if you're going to build without using the provided Docker image. - -## Outline of Approach - -For step 0 through step A, I've purposefully avoided Truffle-specific optimizations. -Step A is intended to be a fully naive application of Truffle, where -a 'pure' interpreter is developed using Truffle AST nodes, but without any attempt -to leverage Truffle primitives to specialize compiled code. - -By comparing Truffle step A on OpenJDK to the existing Java step A, we can get a sense of the -overhead imposed by the Truffle framework on interpreter performance. - -By comparing Truffle step A on OpenJDK to Truffle step A on GraalVM, we can get a sense of how -much performance the GraalVM compiler can give the language implementor "for free". - -Each step _after_ A employs Truffle primitives to enable specialization -of code during compilation. - -* Step B specializes function calls by assuming that the same function will - always be called (i.e. that call sites are _monomorphic_), until proven otherwise. - At call sites where the same function _actually is_ always called, the compiler - can eliminate some code and perform inlining. - -* Step C optimizes and specializes environment lookups, allowing - us to avoid HashMap-related overhead for lookups of symbols that are statically in - scope (i.e. function arguments and let bindings) under the assumption that some - def! doesn't dynamically bind the looked-up symbols at runtime in scopes where they - aren't declared. - -* Step D enables _further_ specialization of environment lookups for closed-over - environments, allowing us to skip the lookups entirely under the assumption that - the symbols have not been rebound. - -* Step E specializes macro expansion, allowing the results of a macro expansion to - _replace_ the apply form entirely. We have to 'cheat' in this step, and extend Mal's - macro semantics (in a backward-compatible way!). The results are worth it! - -## Performance Evaluation Method - -Truffle Mal performance is evaluated relative to Java Mal on several benchmarks. -For each benchmark, we run Java Mal and Truffle Mal on both OpenJDK and GraalVM. - -```bash - # OpenJDK - $ java -version - openjdk version "11.0.7" 2020-04-14 - OpenJDK Runtime Environment (build 11.0.7+10-post-Ubuntu-2ubuntu218.04) - OpenJDK 64-Bit Server VM (build 11.0.7+10-post-Ubuntu-2ubuntu218.04, mixed mode, sharing) - - # GraalVM - $ java -version - openjdk version "11.0.7" 2020-04-14 - OpenJDK Runtime Environment GraalVM CE 20.1.0 (build 11.0.7+10-jvmci-20.1-b02) - OpenJDK 64-Bit Server VM GraalVM CE 20.1.0 (build 11.0.7+10-jvmci-20.1-b02, mixed mode, sharing) -``` - -It must be said that Truffle Mal leverage Clojure's implementations of persistent -vectors and maps. This likely has little to no impact on the perf4 and fib benchmarks, -which don't operate on vectors or maps. Self-hosted Mal, however, depends on -the host Mal's map implementation for its environments. Since Java Mal's maps -are built on java.util.HashMap and don't take advantage of structural sharing, -we expect the complexity of Java Mal's assoc and dissoc functions to be strictly -worse than Truffle Mal's ( O(n) versus O(lg(n)) ). Whether or not this actually -tips things in favor of Truffle Mal isn't clear; the sizes of the environments -in question are quite small. I have not made any attempt to account for this -in the results. - -### Fib - -This simple benchmark focuses on symbol lookups, arithmetic, and function application. -We use the naive recursive approach to computing the 30th Fibonacci number. We run -the computation 10 times, and select the fastest result. - -### Busywork - -The busywork.mal benchmark is a refactoring of the perf3.mal benchmark, -which primarily tests macro and atom performance. - -We measure how long it takes to execute 10,000 iterations of a 'busywork' function. -As with fib.mal, this is done 10 times and we use the fastest result. - -### Fib on Mal - -For a more interesting test, we run the `fib.mal` benchmark using self-hosted -Mal. This gives each implementation a more comprehensive workout. We compute -the 15th Fibonacci number 10 times, and take the fastest execution time. - -Note that self-hosted Mal does not support tail call optimization, and so consumes more -stack the longer it runs. For Truffle Mal, we need to increase the stack size from the -default of 1MB to 8MB to avoid stack overflow. - -## Results - -Truffle performance is given in absolute terms, and relative to the faster of the -Java implementation's OpenJDK and GraalVM runs for the same benchmark. - -### Step A: No Optimizations - -Step A represents a naive Mal interpreter written using Truffle AST nodes, but with -no special effort made to leverage Truffle primitives to assist the GraalVM compiler. - -| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | -| ---------- | -------------- | ----------------- | ----------------- | -| Fib | 1700 ms | 1293 ms (1.3x) | 675 ms (2.5x) | -| Busywork | 781 ms | 914 ms | 888 ms | -| Fib on Mal | 686 ms | 2101 ms | 1664 ms | - -On the Fib benchmark, the Java and Truffle implementations of Mal are in the same -ball park on OpenJDK, with Truffle being 1.3x faster. However, when we run the -Truffle implementation on GraalVM, we see nearly a 2x speed-up over OpenJDK effectively -for free, putting it at 2.5x faster than plain old Java. - -The Busywork benchmark is a different story, with the Truffle implementation _slightly_ -slower on both OpenJDK and GraalVM, and with GraalVM providing very little extra performance. - -Fib on Mal is stranger yet: the Truffle implementation is 3x _slower_ on OpenJDK, and GraalVM -doesn't offer much help. What's going on?! - -A bit of profiling quickly yields the answer: Macros. - -From `truffle.mal.stepA_mal$ApplyNode`: - -```java - if (fn.isMacro) { - // Mal's macro semantics are... interesting. To preserve them in the - // general case, we must re-expand a macro each time it's applied. - // Executing the result means turning it into a Truffle AST, creating - // a CallTarget, calling it, and then throwing it away. - // This is TERRIBLE for performance! Truffle should not be used like this! - var result = applyMacro(env, fn); - var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); - var target = Truffle.getRuntime().createCallTarget(newRoot); - return invokeNode.invoke(target, new Object[] {}, false); - } else { -``` - -A Truffle `CallTarget` represents an AST that can be called from other code. Call Target construction -is a heavy-weight operation that traverses the entire AST to do various initialization things. -The cost of this is _supposed_ to be amortized over the many calls to the code, and offset by the -gains we see for code that is called often enough to be JIT compiled. Truffle ASTs support self-modification. -Ideally, we'd expand a macro once, and then replace the macro application node with the result. - -Mal's macro semantics, alas, prevent us from doing so. -A Mal macro can choose to expand code one way or another based on the current value of any in-scope -environment, or even user input. Even worse, Mal's incremental macro expansion behavior is such that it -is allowable to write 'tail-recursive' macros that would, if eagerly expanded, take up space -exponential in their inputs. Consider a sumdown macro: - -``` - (defmacro! sumdown-via-macro* (fn* [acc n] - `(if (<= ~n 0) - ~acc - (sumdown-via-macro* ~(+ acc n) ~(- n 1))))) - - (defmacro! sumdown-via-macro2 (fn* [n] - `(sumdown-via-macro* 0 ~(eval n)))) -``` - -This executes without issue in any conforming Mal implementation! - -We'll return to macros in Step E, but before we do, we'll see what we can specialize -within the confines of Mal's semantics. - -### Step B: Specializing Function Calls - -In Step A, all function call sites are represented in the AST using Truffle's -`IndirectCallNode`. Truffle also provides a `DirectCallNode` for use at call sites -where the same function is always called. Direct function calls may be inlined by -the GraalVM compiler. - -Mal's semantics make it difficult (and sometimes impossible?) to prove statically -that the same function will always be called at a given call site. However, it's -trivial for our interpreter to _assume_ that a call site is direct up until we -learn that it isn't. If we use Truffle properly, we can express this assumption -in a way that the GraalVM compiler understands. - -Here's what the Steb B version of `InvokeNode` looks like: - -```java - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private boolean usingCachedTarget; - @CompilationFinal private CallTarget cachedTarget; - @CompilationFinal @Child private DirectCallNode directCallNode; - @CompilationFinal @Child private IndirectCallNode indirectCallNode; - - /* SNIP */ - - Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { - if (tailPosition && allowTailCall) { - throw new TailCallException(target, args); - } else { - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - usingCachedTarget = true; - cachedTarget = target; - directCallNode = Truffle.getRuntime().createDirectCallNode(target); - } - while (true) { - try { - if (usingCachedTarget) { - if (cachedTarget == target) { - return directCallNode.call(args); - } - CompilerDirectives.transferToInterpreterAndInvalidate(); - usingCachedTarget = false; - indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); - } - return indirectCallNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } -``` - -It _looks_ like it should be slower now, with all the branching. What have we done? - -Notice that all the new member variables have been annotated with `@CompilationFinal`. -This tells the compiler to treat these variables as if they were `final`, because their values -will not change in compiled code. - -We _ensure_ that they do not change in compiled code -by inserting the `CompilerDirectives.transferToInterpreterAndInvalidate()` intrinsic. -In interpreted code, this is a no-op. In _compiled_ code, it is replaced with an instruction -that causes the compiler to _de-optimize_ the compiled code and return to the interpreter -to continue execution. - -Suppose a function containing a call site that is not in tail position has been executed -enough times to trigger compilation, -and each time the invoked function has been the same. When compilation kicks in, the -variables `initialized` and `usingCachedTarget` would be true, and `tailPosition` would -be false. -Accordingly, the invoke code simplifies to: - -```java - Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { - while (true) { - try { - if (cachedTarget == target) { - return directCallNode.call(args); - } - CompilerDirectives.transferToInterpreterAndInvalidate(); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } -``` - -Much better! - -Because we're using a `DirectCallNode`, the compiler might decide to inline the called -function as well. Function inlining allows the partial evaluation algorithm to extend -across function boundaries. - -Let's see if there's an improvement in practice... - -| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | -| ---------- | -------------- | ----------------- | ----------------- | -| Fib | 1700 ms | 991 ms (1.7x) | 430 ms (3.9x) | -| Busywork | 781 ms | 671 ms (1.2x) | 409 ms (1.9x) | -| Fib on Mal | 686 ms | 1912 ms (0.35x) | 1407 ms (0.48x) | - -We see modest improvements over Step A in all cases, with the Busywork benchmark -having a 2x improvement over Step A on GraalVM. - -### Step C: Static Symbol Lookup - -A little profiling shows that quite a lot of the 'work' that goes into executing a Mal -program is just environment maintenance: constructing HashMaps, putting symbol/value pairs -into them, and looking them back up again. For code that does a lot of function calling -(like our Fib benchmark), this adds up to a lot of overhead. - -Why do we need the HashMaps at all? Why can't we build environments around Object arrays? -During construction of an AST from a Mal form, we can keep track of the variables in -each lexical scope, and assign each one a _slot_ (an index in the Object array for the -environment associated with that scope). During execution, we can construct -environments out of Object arrays, and get/set values using these slots. No more -HashMaps! Right? - -The trouble, of course, is that `def!` can mutate environments at runtime, adding -bindings for symbols that were never 'declared' via `let*` or `fn*`. Consider this -function: - -``` - (def! f (fn* [x b] (do (who-knows? b) y))) -``` - -The symbol `y` isn't lexically in scope, so we wouldn't assign -it a slot; we'd have to try to look it up in the global environment -at execution time. But what if, at execution time, `who-knows?` turns out -to resolve to a _macro_ like: - -``` - (fn* [b] (if b `(def! y 42))) -``` - -If `b` is truthy, the `y` symbol ends up bound in the function body's environment after all, -but there's no slot for it in the environment's object array. Drat! - -But the power of Truffle is that we don't _need_ to statically prove that our slot -assignments and usage are valid. We're not writing a compiler! Instead, we can just -_assume_ that the slot assignments we make are valid, right up until we find that they -aren't. Then we can fall back on a less efficient but more general approach. - -I won't elaborate much on the details of the code too much in step, it involves the most significant changes. -At a high level, here's what we do: - -* Introduce a `LexicalScope` class that assigns symbols to array indices, and - thread `LexicalScope` objects through our AST construction methods. -* Extend `MalEnv` with a `staticBindings` Object array _in addition to_ the normal - `bindings` HashMap. The Object array is constructed based on the number of symbols in - the associated `LexicalScope`. The `bindings` HashMap is only constructed _lazily_, - if a symbol that isn't in a `LexicalScope` is bound via a `def!`. -* Further extend `MalEnv` with slot-based `get` and `set` methods, in addition to the - existing symbol-based `get` and `set` methods. -* Extend the AST nodes for `let*` and `fn*` to introduce new `LexicalScope` objects - with the right symbols, assign slots to those symbols, - and use the slot-based `get` and `set` methods on `MalEnv` to bind symbols. -* Modify the AST node for symbol lookups to speculatively use slot-based lookups - when the symbol in question is in a lexical scope _under the assumption that it has - not been re-defined via `def!`. - -That last bit is the key to the whole thing: We use Truffle's `Assumption` abstraction -to tell the compiler about the assumption that our slot-based symbol look-ups depend on. -When a `LexicalScope` assigns a slot, it creates an `Assumption` that the symbol -has not been bound by `def!` in that or any outer `LexicalScope`. The slot-based -symbol lookup code is guarded by that assumption. The 'dynamic' `set` method of `MalEnv` -(the one used by `def!`) is modified to _invalidate_ that assumption, triggering -de-optimization of any symbol lookups that might have been rendered incorrect. - -After slot assignment, where do we stand? - -| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | -| ---------- | -------------- | ----------------- | ----------------- | -| Fib | 1700 ms | 829 ms (2.1x) | 219 ms (7.8x) | -| Busywork | 781 ms | 686 ms (1.1x) | 394 ms (2.0x) | -| Fib on Mal | 686 ms | 1932 ms (0.35x) | 1507 ms (0.46x) | - -This optimization starts to show off the real power of the Truffle framework on GraalVM, -at least for the Fib benchmark. -On the JDK, we see a modest improvement (1.2x) over Step B that comes from eliminating -some of the HashMap overhead. Given the complexity that we had to introduce, -this isn't very satisfying, On GraalVM, though, we see a better than 2x speed-up, taking -us to almost 8x faster than the Java interpreter. - -However, the other two benchmarks show no meaningful improvement at all. Fib on Mal -even seems to have become slower! Once again, we're bit by macros here. Recall that -since we currently create a new AST each and every time we -encounter a macro, the compiler never has a chance to compile it. We pay all the overhead -of our extra book-keeping, and get absolutely no benefit. - -### Step D: Caching Symbol Lookups - -We can take the symbol lookup improvements much further, now that we've laid the groundwork! - -Symbol lookups for symbols that are declared in some lexical scope will now use the fast-path Object array -lookups instead of the HashMap lookups, and Truffle _should_ even be able to unroll the loops -that walk up the chain of environments for us. For local symbol lookups, we probably won't do -much better. - -But what about symbols in a function body that _aren't_ lexically in scope? In a well-behaved -Mal program that isn't doing anything fancy with `def!`, these symbols will either produce -runtime environments, or resolve to the global environment. In practice, they're almost always -looking up core functions, whose values are unlikely (but not impossible!) to change over -the lifetime of the program. - -We can _further_ specialize symbol lookups by simply caching looked-up values for symbols -that are not lexically in scope, and _skipping subsequent lookups entirely_ unless the -looked-up symbol gets rebound. Once again, we create an `Assumption` for each cached -lookup to represent that we assume it has not been redefined, update `def!` to invalidate -that assumption. - -| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | -| ---------- | -------------- | ----------------- | ----------------- | -| Fib | 1700 ms | 733 ms (2.3x) | 18 ms (94x !!) | -| Busywork | 781 ms | 657 ms (1.2x) | 311 ms (2.5x) | -| Fib on Mal | 686 ms | 1971 ms (0.35x) | 1474 ms (0.47x) | - -On our Fib benchmark, caching symbol lookups makes a _huge_ difference. Look at the -code for `fib`: - -``` -(def! fib (fn* [n] - (if (= n 0) - 1 - (if (= n 1) - 1 - (+ (fib (- n 1)) - (fib (- n 2))))))) -``` - -There are 7 look-ups of symbols not in lexical scope (`=`, `=`, `+`, `fib`, `-`, `fib`, and `-`), -and we've effectively eliminated all of them. All that's left are fast slot-based lookups for `n`, -two comparisons, and three arithmetic operations. All of those end up getting inlined by the compiler. -Moreover, the compiler actually 'unrolls' the recorsion several levels for us by inlining `fib` into itself. -The result is quite fast, even out-performing type-hinted Clojure (Mal's inspiration)... on OpenJDK, anyway. - -Alas, the macros still defeat us on the other benchmarks, for the same reasons. The time has come to do something -about that. - -### Step E: Macro Inlining - -If we stay within the confines of Mal's semantics, macros are a -show-stopper performance killer for us. Mal's -macro semantics are just too dynamic for their own good. Sure, you _can_ -write tail recursive macros... but why _would_ you? - -In practice, macros are often just introducing 'syntactic sugar' to improve expressiveness. -Consider the macros `cond`, `or`, `and`, `->`, and `->>`. Their -expansion behavior does not depend on runtime values (so they expand the same -way on each application), and they produce code that is linear in the size of -their inputs. - -Why do all the work to re-expand them on every application? Why not expand them _once_, -and then just substitute the result? Clojure macros, for example, work this way. - -To make further progress, we're going to have to "cheat" our way into fast macros. -We extend Mal's semantics -such that a macro with a map for metadata containing the entry `:inline? true` -is expanded once, and the result is _inlined_ in place of the macro application -forever after. We then mark all of the above macros as inlined macros. - -This isn't a Truffle-specific optimization by any means. Any Mal interpreter -that supports these semantics will see _substantial_ performance gains. However, -the immutable nature of Mal data structures might make the refactoring of -these interpreters a bit trickier than we'd like. - -Using Truffle, though, it's a trivial change. Truffle ASTs are explicitly self-modifying. -It boils down to this: - -```java - if (fn.isMacro) { - var expanded = applyMacro(env, fn); - if (isInlinableMacro(fn)) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - var newNode = expanded.body; - this.replace(newNode); - return newNode.executeGeneric(frame, env); - } else { - return invokeMacro(expanded); - } - else { -``` - -A few extra lines is all it takes. Look what happens now... - -| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | -| ---------- | -------------- | ----------------- | ----------------- | -| Fib | 1700 ms | 718 ms (2.3x) | 21 ms (81x) | -| Busywork | 781 ms | 19 ms (41x) | 12 ms (65x) | -| Fib on Mal | 686 ms | 104 ms (6.6x) | 25 ms (27x) | - -No substantial difference on Fib, which makes sense: that benchmark doesn't use macros. - -_Huge_ gains on Busywork and Fib on Mal, because both are so dependent on macros. -It's a bit suspicious, though, that there isn't more of a performance difference between -the OpenJDK and GraalVM runs. Maybe the test runs so fast we're not sufficiently warmed up? -Let's crank up the number of iterations from 10k to 100k and see what happens. - - -| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | -| ------------ | -------------- | ----------------- | ----------------- | -| Busywork 10x | 7264 ms | 223 ms (32x) | 37 ms (196x) | - -That's more like it. Recall that before this macro optimization, Java -and Java Truffle were close in performance. If we implemented macro inlining -in Java Mal, to make for a fair comparison, it's still likely that Truffle Mal -wins by around 6-7x, which is pretty decent! - -What about the Fib on Mal benchmark? Why don't we see a bigger difference -between the OpenJDK and GraalVM runs? It's not insufficient warm-up this time. -Doing some profiling shows that we're spending quite a bit of time in -code that isn't partially evaluated. For example, self-hosted Mal's environment -implementation turns symbols into strings, and uses the strings as -keys in environment maps, instead of just using the symbols themselves. -The code for turning objects into strings in Printer depends heavily on -JDK-provided classes that were not designed with partial evaluation in mind, -so we must exclude them from partial evaluation to avoid an explosion in -code size. - -## Conclusions - -Does Truffle deliver on the promise of high-performance JIT-ed code via -partial evaluation of interpreter code? Based on my experience, it certainly does. -It's not exactly magic pixie dust that gives you 100x for free, but it -doesn't claim to be. It _does_ enable order-of-magnitude speed improvements -over plain old interpreters with _much_ less than an order-of-magnitude -increase in effort. - -Let's revisit the questions we started with: - -*Do more complicated Mal programs show similar speed-ups?* - -No, GraalVM JIT compilation does not provide arbitrary Mal programs with the -massive performance gains we see on the Fib benchmark. This should be -totally unsurprising. - -*How much of the speed-up is really attributable to the Truffle/GraalVM combo, -and how much came from optimizations that could be applied to any Mal interpreter?* - -Our benchmarks show that the answer depends heavily on the nature of the -program. Let's look at the performance of Truffle Mal on GraalVM relative -to its performance on OpenJDK (where we don't have the benefit of Truffle- -enabled partial evaluation): - -| Benchmark | TruffleMal (GraalVM relative to OpenJDK) | -| ------------ | ---------------------------------------- | -| Fib | 34x | -| Busywork 10x | 6x | -| Fib On Mal | 4x | - -In extreme cases, for programs that are heavy on arithmetic and function calls, -our use of Truffle/GraalVM buys us 30x _after accounting for our optimizations_. - -That's pretty amazing. - -Realistically, though, we're likely to see more 3-6x speed-ups directly attributable -to Truffle/GraalVM. Still impressive! - -*How much simplicity did we have to sacrifice in the name of performance?* - -Let's look at the size, in lines of code, of each implementation. - -| File | LOC (Java) | LOC (Truffle Step A) | LOC (Truffle Step E) | -| -------------- | ---------- | -------------------- | -------------------- | -| stepA_mal.java | 310 | 757 | 886 | -| env.java | 58 | 145 | 370 | -| printer.java | 53 | 100 | 100 | -| reader.java | 151 | 166 | 166 | -| types.java | 381 | 532 | 545 | -| core.java | 633 | 1506 | 1511 | -| *Total* | 1586 | 3206 (2x) | 3578 (2.25x) | - -The Truffle-based implementation, before optimizations, weighs in at about -2x the size of the Java implementation. -Much of this can be attributed to 'boilerplate' associated with use of the Truffle framework. -In my opinion, this boilerplate adds effectively nothing to the conceptual complexity of -the implementation. In fact, much of the extra weight comes from the core functions. -The LOC count is longer because we make use of the Truffle DSL, a feature not covered in -this write-up, to trivially allow specialization of core functions based on argument type. -I would argue that while this increases code _size_, it may actually _reduce_ code complexity -via a form of pattern matching. - -Our specializations to the interpreter nodes themselves added about 15%, or 120 lines. -More significantly, we increased the size of the environment implementation by 2.5x, -adding substantial complexity in the process. - -*Was it worth it?* - -This is both totally subjective and a gross over-simplification, -but let's just guess that we've increased the complexity of the baseline Java interpreter -overall by roughly 1.5 x, and environments in particular by 3x. -In exchange for this increase in complexity, we've managed to obtain between from 25x to 80x -better performance over the baseline Java interpreter, depending on the Mal -program. - -We could perform most of our optimizations on that Java interpreter _without_ -using Truffle. However, we'd end up at a similar level of complexity, and -would see substantially smaller performance gains. - -Based on these results, if I were to attempt a 'production quality' Mal implementation, -I'd probably do it with Truffle and GraalVM. The performance gains alone seem to justify it. - -It's also worth observing that the Truffle/GraalVM provide _other_ interesting benefits -that are not performance-related. I won't cover them here. I think the most interesting -non-performance benefit is the promise of interoperability with other Truffle languages. - -## Bonus: AOT-compiled Mal - -GraalVM can ahead-of-time compile Java into a stand-alone executable (with some caveats) -called a _native image_. -This works even for Truffle interpreters! With AOT-compiled Mal, we get all the JIT compilation -goodness of Truffle, _and_ we ditch the need for a Java runtime, **and** we skip the long JVM -start-up time! A GraalVM native image of our Mal interpreter is well suited for scripts and -command line applications. - -The `make-native.sh` script can be used to compile a native image of any Mal step. -To run it, though, you'll need some additional -[prerequisites](https://www.graalvm.org/reference-manual/native-image/#prerequisites). - -The `make-native.sh` script - -* assumes you've already run `gradle build` to compile all Java classes -* takes as its only argument a step name, e.g. `step3_env` -** when no argument is supplied, `stepE_macros` is selected by default -* produces a `build/${STEP}` native image - +# Truffle Mal + +This Mal is implemented in Java using the [Truffle Framework](https://github.com/oracle/graal/blob/master/truffle/README.md). +Truffle is a library for implementing interpreters. When +these interpreters are run on GraalVM, the GraalVM compiler +is able to JIT compile interpreted programs using a technique +called [partial evaluation](https://en.wikipedia.org/wiki/Partial_evaluation). + +Partially evaluating an interpreter plus a program to produce compiled +code requires a careful balance. If every last bit of interpreter code +(including supporting libraries, etc.) +is subject to partial evaluation, the result will explode to +unreasonable size. Boundaries must be drawn. Exclude too much, though, +and the speed up resulting from compilation may not be worth the +effort of the compilation. + +Truffle's "thesis" is that a small set of primitives are sufficient to make +JIT compilation via partial evaluation practical. +These primitives feed runtime data collected by the executing interpreter +to the compiler, allowing it to _specialize_, or optimistically +simplify, the interpreter code at compilation time. The compiler inserts +lightweight runtime checks of the assumptions that justify its +simplifications. If the checks fail, the compiled code is _de-optimized_, +and control is returned to the interpreter. +See [Practical Partial Evaluation for High-Performance Dynamic Language Runtimes](http://chrisseaton.com/rubytruffle/pldi17-truffle/pldi17-truffle.pdf), from PLDI 2017, for a deeper treatment of the ideas behind Truffle. + +The Truffle Mal implementation is my attempt at putting the Truffle thesis +to the test. + +Can I, an engineer without a background in compiler design, use Truffle to +implement an interpreter for a dynamic language (Mal) that substantially +outperforms the existing Java interpreter for Mal? + +*The Short Answer: Yup.* + +```bash + # Recursive Fibonacci on OpenJDK 11 with java mal + $ ./run ../tests/fib.mal 30 10 + Times (in ms) for (fib 30) on java: [2062 1809 1814 1777 1772 1791 1725 1723 1786 1745] + + # Recursive Fibonacci on GraalVM with java-truffle mal + $ ./run ../tests/fib.mal 30 10 + Times (in ms) for (fib 30) on java-truffle: [280 142 21 26 22 75 21 26 21 24] + + # That's an 82x speed-up! Just out of curiosity... + # How does Clojure on OpenJDK 11? We'll even throw in a type hint. + $ lein repl + Clojure 1.10.0 + OpenJDK 64-Bit Server VM 11.0.7+10-post-Ubuntu-2ubuntu218.04 + user=> (defn fib [^long n] (if (= n 0) 1 (if (= n 1) 1 (+ (fib (- n 1)) (fib (- n 2)))))) + #'user/fib + user=> (dotimes [i 5] (time (fib 30))) + "Elapsed time: 32.0791 msecs" + "Elapsed time: 31.7552 msecs" + "Elapsed time: 31.5361 msecs" + "Elapsed time: 31.4796 msecs" + "Elapsed time: 31.4541 msecs" +``` + +A recursive Fibonacci computation is _obviously_ not sufficient to characterize the +performance of our implementation (and as we'll see, it turns out to be +something of a best-case scenario), but it sure looks impressive! + +Do more complicated Mal programs show similar speed-ups? + +How much simplicity did we have to sacrifice in the name of performance? + +Was it worth it? + +How much of the speed-up is really attributable to the Truffle/GraalVM combo, +and how much came from putting more time into the code itself? + +We'll explore the answers to these questions together in the remainder! + +## Disclaimers + +*First and foremost*: To the extend that this experiment _succeeds_ in its goal of +producing an efficient Mal implementation, the credit is due to the teams +behind Truffle and GraalVM. To the extend that this experiment _fails_, the blame +falls on *me*! The reader should assume, by default, that any deficiencies in +this Mal implementation are due to my own failure to understand or +properly apply the tools at my disposal, and _not_ due to any fundamental +limitations of Truffle or GraalVM. + +*Second:* This Mal implementation is _not_ idiomatic Java, and it's _not_ an +idiomatic application of Truffle. The project's +unusual organization (large numbers of package-private classes bundled +into single files like Types.java, substantial duplication between step files) +represent my attempt to adhere both to the spirit of Mal's +pedagogical approach and the organization of the existing Java implementation. +Consequently I have abused Truffle in several ways (that I am aware of, and perhaps +others that I am not?). Each Mal step +registers a distinct Truffle implementation whose language id has the form "mal_step${n}". +The languages for each step have distinct AST node sub-classes, but they share +the built-in AST nodes in Core.java and the runtime types in Types.java. This sharing +creates some awkwardness in Core.java. + +## Prerequisites + +[GraalVM Community Edition](https://www.graalvm.org/downloads/) (version 20.1.0 or higher) +should be on your PATH and pointed to by JAVA_HOME. + +You'll also need to [install Gradle](https://gradle.org/install/) +if you're going to build without using the provided Docker image. + +## Outline of Approach + +For step 0 through step A, I've purposefully avoided Truffle-specific optimizations. +Step A is intended to be a fully naive application of Truffle, where +a 'pure' interpreter is developed using Truffle AST nodes, but without any attempt +to leverage Truffle primitives to specialize compiled code. + +By comparing Truffle step A on OpenJDK to the existing Java step A, we can get a sense of the +overhead imposed by the Truffle framework on interpreter performance. + +By comparing Truffle step A on OpenJDK to Truffle step A on GraalVM, we can get a sense of how +much performance the GraalVM compiler can give the language implementor "for free". + +Each step _after_ A employs Truffle primitives to enable specialization +of code during compilation. + +* Step B specializes function calls by assuming that the same function will + always be called (i.e. that call sites are _monomorphic_), until proven otherwise. + At call sites where the same function _actually is_ always called, the compiler + can eliminate some code and perform inlining. + +* Step C optimizes and specializes environment lookups, allowing + us to avoid HashMap-related overhead for lookups of symbols that are statically in + scope (i.e. function arguments and let bindings) under the assumption that some + def! doesn't dynamically bind the looked-up symbols at runtime in scopes where they + aren't declared. + +* Step D enables _further_ specialization of environment lookups for closed-over + environments, allowing us to skip the lookups entirely under the assumption that + the symbols have not been rebound. + +* Step E specializes macro expansion, allowing the results of a macro expansion to + _replace_ the apply form entirely. We have to 'cheat' in this step, and extend Mal's + macro semantics (in a backward-compatible way!). The results are worth it! + +## Performance Evaluation Method + +Truffle Mal performance is evaluated relative to Java Mal on several benchmarks. +For each benchmark, we run Java Mal and Truffle Mal on both OpenJDK and GraalVM. + +```bash + # OpenJDK + $ java -version + openjdk version "11.0.7" 2020-04-14 + OpenJDK Runtime Environment (build 11.0.7+10-post-Ubuntu-2ubuntu218.04) + OpenJDK 64-Bit Server VM (build 11.0.7+10-post-Ubuntu-2ubuntu218.04, mixed mode, sharing) + + # GraalVM + $ java -version + openjdk version "11.0.7" 2020-04-14 + OpenJDK Runtime Environment GraalVM CE 20.1.0 (build 11.0.7+10-jvmci-20.1-b02) + OpenJDK 64-Bit Server VM GraalVM CE 20.1.0 (build 11.0.7+10-jvmci-20.1-b02, mixed mode, sharing) +``` + +It must be said that Truffle Mal leverage Clojure's implementations of persistent +vectors and maps. This likely has little to no impact on the perf4 and fib benchmarks, +which don't operate on vectors or maps. Self-hosted Mal, however, depends on +the host Mal's map implementation for its environments. Since Java Mal's maps +are built on java.util.HashMap and don't take advantage of structural sharing, +we expect the complexity of Java Mal's assoc and dissoc functions to be strictly +worse than Truffle Mal's ( O(n) versus O(lg(n)) ). Whether or not this actually +tips things in favor of Truffle Mal isn't clear; the sizes of the environments +in question are quite small. I have not made any attempt to account for this +in the results. + +### Fib + +This simple benchmark focuses on symbol lookups, arithmetic, and function application. +We use the naive recursive approach to computing the 30th Fibonacci number. We run +the computation 10 times, and select the fastest result. + +### Busywork + +The busywork.mal benchmark is a refactoring of the perf3.mal benchmark, +which primarily tests macro and atom performance. + +We measure how long it takes to execute 10,000 iterations of a 'busywork' function. +As with fib.mal, this is done 10 times and we use the fastest result. + +### Fib on Mal + +For a more interesting test, we run the `fib.mal` benchmark using self-hosted +Mal. This gives each implementation a more comprehensive workout. We compute +the 15th Fibonacci number 10 times, and take the fastest execution time. + +Note that self-hosted Mal does not support tail call optimization, and so consumes more +stack the longer it runs. For Truffle Mal, we need to increase the stack size from the +default of 1MB to 8MB to avoid stack overflow. + +## Results + +Truffle performance is given in absolute terms, and relative to the faster of the +Java implementation's OpenJDK and GraalVM runs for the same benchmark. + +### Step A: No Optimizations + +Step A represents a naive Mal interpreter written using Truffle AST nodes, but with +no special effort made to leverage Truffle primitives to assist the GraalVM compiler. + +| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | +| ---------- | -------------- | ----------------- | ----------------- | +| Fib | 1700 ms | 1293 ms (1.3x) | 675 ms (2.5x) | +| Busywork | 781 ms | 914 ms | 888 ms | +| Fib on Mal | 686 ms | 2101 ms | 1664 ms | + +On the Fib benchmark, the Java and Truffle implementations of Mal are in the same +ball park on OpenJDK, with Truffle being 1.3x faster. However, when we run the +Truffle implementation on GraalVM, we see nearly a 2x speed-up over OpenJDK effectively +for free, putting it at 2.5x faster than plain old Java. + +The Busywork benchmark is a different story, with the Truffle implementation _slightly_ +slower on both OpenJDK and GraalVM, and with GraalVM providing very little extra performance. + +Fib on Mal is stranger yet: the Truffle implementation is 3x _slower_ on OpenJDK, and GraalVM +doesn't offer much help. What's going on?! + +A bit of profiling quickly yields the answer: Macros. + +From `truffle.mal.stepA_mal$ApplyNode`: + +```java + if (fn.isMacro) { + // Mal's macro semantics are... interesting. To preserve them in the + // general case, we must re-expand a macro each time it's applied. + // Executing the result means turning it into a Truffle AST, creating + // a CallTarget, calling it, and then throwing it away. + // This is TERRIBLE for performance! Truffle should not be used like this! + var result = applyMacro(env, fn); + var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); + var target = Truffle.getRuntime().createCallTarget(newRoot); + return invokeNode.invoke(target, new Object[] {}, false); + } else { +``` + +A Truffle `CallTarget` represents an AST that can be called from other code. Call Target construction +is a heavy-weight operation that traverses the entire AST to do various initialization things. +The cost of this is _supposed_ to be amortized over the many calls to the code, and offset by the +gains we see for code that is called often enough to be JIT compiled. Truffle ASTs support self-modification. +Ideally, we'd expand a macro once, and then replace the macro application node with the result. + +Mal's macro semantics, alas, prevent us from doing so. +A Mal macro can choose to expand code one way or another based on the current value of any in-scope +environment, or even user input. Even worse, Mal's incremental macro expansion behavior is such that it +is allowable to write 'tail-recursive' macros that would, if eagerly expanded, take up space +exponential in their inputs. Consider a sumdown macro: + +``` + (defmacro! sumdown-via-macro* (fn* [acc n] + `(if (<= ~n 0) + ~acc + (sumdown-via-macro* ~(+ acc n) ~(- n 1))))) + + (defmacro! sumdown-via-macro2 (fn* [n] + `(sumdown-via-macro* 0 ~(eval n)))) +``` + +This executes without issue in any conforming Mal implementation! + +We'll return to macros in Step E, but before we do, we'll see what we can specialize +within the confines of Mal's semantics. + +### Step B: Specializing Function Calls + +In Step A, all function call sites are represented in the AST using Truffle's +`IndirectCallNode`. Truffle also provides a `DirectCallNode` for use at call sites +where the same function is always called. Direct function calls may be inlined by +the GraalVM compiler. + +Mal's semantics make it difficult (and sometimes impossible?) to prove statically +that the same function will always be called at a given call site. However, it's +trivial for our interpreter to _assume_ that a call site is direct up until we +learn that it isn't. If we use Truffle properly, we can express this assumption +in a way that the GraalVM compiler understands. + +Here's what the Steb B version of `InvokeNode` looks like: + +```java + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private boolean usingCachedTarget; + @CompilationFinal private CallTarget cachedTarget; + @CompilationFinal @Child private DirectCallNode directCallNode; + @CompilationFinal @Child private IndirectCallNode indirectCallNode; + + /* SNIP */ + + Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { + if (tailPosition && allowTailCall) { + throw new TailCallException(target, args); + } else { + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + usingCachedTarget = true; + cachedTarget = target; + directCallNode = Truffle.getRuntime().createDirectCallNode(target); + } + while (true) { + try { + if (usingCachedTarget) { + if (cachedTarget == target) { + return directCallNode.call(args); + } + CompilerDirectives.transferToInterpreterAndInvalidate(); + usingCachedTarget = false; + indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); + } + return indirectCallNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } +``` + +It _looks_ like it should be slower now, with all the branching. What have we done? + +Notice that all the new member variables have been annotated with `@CompilationFinal`. +This tells the compiler to treat these variables as if they were `final`, because their values +will not change in compiled code. + +We _ensure_ that they do not change in compiled code +by inserting the `CompilerDirectives.transferToInterpreterAndInvalidate()` intrinsic. +In interpreted code, this is a no-op. In _compiled_ code, it is replaced with an instruction +that causes the compiler to _de-optimize_ the compiled code and return to the interpreter +to continue execution. + +Suppose a function containing a call site that is not in tail position has been executed +enough times to trigger compilation, +and each time the invoked function has been the same. When compilation kicks in, the +variables `initialized` and `usingCachedTarget` would be true, and `tailPosition` would +be false. +Accordingly, the invoke code simplifies to: + +```java + Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { + while (true) { + try { + if (cachedTarget == target) { + return directCallNode.call(args); + } + CompilerDirectives.transferToInterpreterAndInvalidate(); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } +``` + +Much better! + +Because we're using a `DirectCallNode`, the compiler might decide to inline the called +function as well. Function inlining allows the partial evaluation algorithm to extend +across function boundaries. + +Let's see if there's an improvement in practice... + +| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | +| ---------- | -------------- | ----------------- | ----------------- | +| Fib | 1700 ms | 991 ms (1.7x) | 430 ms (3.9x) | +| Busywork | 781 ms | 671 ms (1.2x) | 409 ms (1.9x) | +| Fib on Mal | 686 ms | 1912 ms (0.35x) | 1407 ms (0.48x) | + +We see modest improvements over Step A in all cases, with the Busywork benchmark +having a 2x improvement over Step A on GraalVM. + +### Step C: Static Symbol Lookup + +A little profiling shows that quite a lot of the 'work' that goes into executing a Mal +program is just environment maintenance: constructing HashMaps, putting symbol/value pairs +into them, and looking them back up again. For code that does a lot of function calling +(like our Fib benchmark), this adds up to a lot of overhead. + +Why do we need the HashMaps at all? Why can't we build environments around Object arrays? +During construction of an AST from a Mal form, we can keep track of the variables in +each lexical scope, and assign each one a _slot_ (an index in the Object array for the +environment associated with that scope). During execution, we can construct +environments out of Object arrays, and get/set values using these slots. No more +HashMaps! Right? + +The trouble, of course, is that `def!` can mutate environments at runtime, adding +bindings for symbols that were never 'declared' via `let*` or `fn*`. Consider this +function: + +``` + (def! f (fn* [x b] (do (who-knows? b) y))) +``` + +The symbol `y` isn't lexically in scope, so we wouldn't assign +it a slot; we'd have to try to look it up in the global environment +at execution time. But what if, at execution time, `who-knows?` turns out +to resolve to a _macro_ like: + +``` + (fn* [b] (if b `(def! y 42))) +``` + +If `b` is truthy, the `y` symbol ends up bound in the function body's environment after all, +but there's no slot for it in the environment's object array. Drat! + +But the power of Truffle is that we don't _need_ to statically prove that our slot +assignments and usage are valid. We're not writing a compiler! Instead, we can just +_assume_ that the slot assignments we make are valid, right up until we find that they +aren't. Then we can fall back on a less efficient but more general approach. + +I won't elaborate much on the details of the code too much in step, it involves the most significant changes. +At a high level, here's what we do: + +* Introduce a `LexicalScope` class that assigns symbols to array indices, and + thread `LexicalScope` objects through our AST construction methods. +* Extend `MalEnv` with a `staticBindings` Object array _in addition to_ the normal + `bindings` HashMap. The Object array is constructed based on the number of symbols in + the associated `LexicalScope`. The `bindings` HashMap is only constructed _lazily_, + if a symbol that isn't in a `LexicalScope` is bound via a `def!`. +* Further extend `MalEnv` with slot-based `get` and `set` methods, in addition to the + existing symbol-based `get` and `set` methods. +* Extend the AST nodes for `let*` and `fn*` to introduce new `LexicalScope` objects + with the right symbols, assign slots to those symbols, + and use the slot-based `get` and `set` methods on `MalEnv` to bind symbols. +* Modify the AST node for symbol lookups to speculatively use slot-based lookups + when the symbol in question is in a lexical scope _under the assumption that it has + not been re-defined via `def!`. + +That last bit is the key to the whole thing: We use Truffle's `Assumption` abstraction +to tell the compiler about the assumption that our slot-based symbol look-ups depend on. +When a `LexicalScope` assigns a slot, it creates an `Assumption` that the symbol +has not been bound by `def!` in that or any outer `LexicalScope`. The slot-based +symbol lookup code is guarded by that assumption. The 'dynamic' `set` method of `MalEnv` +(the one used by `def!`) is modified to _invalidate_ that assumption, triggering +de-optimization of any symbol lookups that might have been rendered incorrect. + +After slot assignment, where do we stand? + +| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | +| ---------- | -------------- | ----------------- | ----------------- | +| Fib | 1700 ms | 829 ms (2.1x) | 219 ms (7.8x) | +| Busywork | 781 ms | 686 ms (1.1x) | 394 ms (2.0x) | +| Fib on Mal | 686 ms | 1932 ms (0.35x) | 1507 ms (0.46x) | + +This optimization starts to show off the real power of the Truffle framework on GraalVM, +at least for the Fib benchmark. +On the JDK, we see a modest improvement (1.2x) over Step B that comes from eliminating +some of the HashMap overhead. Given the complexity that we had to introduce, +this isn't very satisfying, On GraalVM, though, we see a better than 2x speed-up, taking +us to almost 8x faster than the Java interpreter. + +However, the other two benchmarks show no meaningful improvement at all. Fib on Mal +even seems to have become slower! Once again, we're bit by macros here. Recall that +since we currently create a new AST each and every time we +encounter a macro, the compiler never has a chance to compile it. We pay all the overhead +of our extra book-keeping, and get absolutely no benefit. + +### Step D: Caching Symbol Lookups + +We can take the symbol lookup improvements much further, now that we've laid the groundwork! + +Symbol lookups for symbols that are declared in some lexical scope will now use the fast-path Object array +lookups instead of the HashMap lookups, and Truffle _should_ even be able to unroll the loops +that walk up the chain of environments for us. For local symbol lookups, we probably won't do +much better. + +But what about symbols in a function body that _aren't_ lexically in scope? In a well-behaved +Mal program that isn't doing anything fancy with `def!`, these symbols will either produce +runtime environments, or resolve to the global environment. In practice, they're almost always +looking up core functions, whose values are unlikely (but not impossible!) to change over +the lifetime of the program. + +We can _further_ specialize symbol lookups by simply caching looked-up values for symbols +that are not lexically in scope, and _skipping subsequent lookups entirely_ unless the +looked-up symbol gets rebound. Once again, we create an `Assumption` for each cached +lookup to represent that we assume it has not been redefined, update `def!` to invalidate +that assumption. + +| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | +| ---------- | -------------- | ----------------- | ----------------- | +| Fib | 1700 ms | 733 ms (2.3x) | 18 ms (94x !!) | +| Busywork | 781 ms | 657 ms (1.2x) | 311 ms (2.5x) | +| Fib on Mal | 686 ms | 1971 ms (0.35x) | 1474 ms (0.47x) | + +On our Fib benchmark, caching symbol lookups makes a _huge_ difference. Look at the +code for `fib`: + +``` +(def! fib (fn* [n] + (if (= n 0) + 1 + (if (= n 1) + 1 + (+ (fib (- n 1)) + (fib (- n 2))))))) +``` + +There are 7 look-ups of symbols not in lexical scope (`=`, `=`, `+`, `fib`, `-`, `fib`, and `-`), +and we've effectively eliminated all of them. All that's left are fast slot-based lookups for `n`, +two comparisons, and three arithmetic operations. All of those end up getting inlined by the compiler. +Moreover, the compiler actually 'unrolls' the recorsion several levels for us by inlining `fib` into itself. +The result is quite fast, even out-performing type-hinted Clojure (Mal's inspiration)... on OpenJDK, anyway. + +Alas, the macros still defeat us on the other benchmarks, for the same reasons. The time has come to do something +about that. + +### Step E: Macro Inlining + +If we stay within the confines of Mal's semantics, macros are a +show-stopper performance killer for us. Mal's +macro semantics are just too dynamic for their own good. Sure, you _can_ +write tail recursive macros... but why _would_ you? + +In practice, macros are often just introducing 'syntactic sugar' to improve expressiveness. +Consider the macros `cond`, `or`, `and`, `->`, and `->>`. Their +expansion behavior does not depend on runtime values (so they expand the same +way on each application), and they produce code that is linear in the size of +their inputs. + +Why do all the work to re-expand them on every application? Why not expand them _once_, +and then just substitute the result? Clojure macros, for example, work this way. + +To make further progress, we're going to have to "cheat" our way into fast macros. +We extend Mal's semantics +such that a macro with a map for metadata containing the entry `:inline? true` +is expanded once, and the result is _inlined_ in place of the macro application +forever after. We then mark all of the above macros as inlined macros. + +This isn't a Truffle-specific optimization by any means. Any Mal interpreter +that supports these semantics will see _substantial_ performance gains. However, +the immutable nature of Mal data structures might make the refactoring of +these interpreters a bit trickier than we'd like. + +Using Truffle, though, it's a trivial change. Truffle ASTs are explicitly self-modifying. +It boils down to this: + +```java + if (fn.isMacro) { + var expanded = applyMacro(env, fn); + if (isInlinableMacro(fn)) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + var newNode = expanded.body; + this.replace(newNode); + return newNode.executeGeneric(frame, env); + } else { + return invokeMacro(expanded); + } + else { +``` + +A few extra lines is all it takes. Look what happens now... + +| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | +| ---------- | -------------- | ----------------- | ----------------- | +| Fib | 1700 ms | 718 ms (2.3x) | 21 ms (81x) | +| Busywork | 781 ms | 19 ms (41x) | 12 ms (65x) | +| Fib on Mal | 686 ms | 104 ms (6.6x) | 25 ms (27x) | + +No substantial difference on Fib, which makes sense: that benchmark doesn't use macros. + +_Huge_ gains on Busywork and Fib on Mal, because both are so dependent on macros. +It's a bit suspicious, though, that there isn't more of a performance difference between +the OpenJDK and GraalVM runs. Maybe the test runs so fast we're not sufficiently warmed up? +Let's crank up the number of iterations from 10k to 100k and see what happens. + + +| Benchmark | Java (OpenJDK) | Truffle (OpenJDK) | Truffle (GraalVM) | +| ------------ | -------------- | ----------------- | ----------------- | +| Busywork 10x | 7264 ms | 223 ms (32x) | 37 ms (196x) | + +That's more like it. Recall that before this macro optimization, Java +and Java Truffle were close in performance. If we implemented macro inlining +in Java Mal, to make for a fair comparison, it's still likely that Truffle Mal +wins by around 6-7x, which is pretty decent! + +What about the Fib on Mal benchmark? Why don't we see a bigger difference +between the OpenJDK and GraalVM runs? It's not insufficient warm-up this time. +Doing some profiling shows that we're spending quite a bit of time in +code that isn't partially evaluated. For example, self-hosted Mal's environment +implementation turns symbols into strings, and uses the strings as +keys in environment maps, instead of just using the symbols themselves. +The code for turning objects into strings in Printer depends heavily on +JDK-provided classes that were not designed with partial evaluation in mind, +so we must exclude them from partial evaluation to avoid an explosion in +code size. + +## Conclusions + +Does Truffle deliver on the promise of high-performance JIT-ed code via +partial evaluation of interpreter code? Based on my experience, it certainly does. +It's not exactly magic pixie dust that gives you 100x for free, but it +doesn't claim to be. It _does_ enable order-of-magnitude speed improvements +over plain old interpreters with _much_ less than an order-of-magnitude +increase in effort. + +Let's revisit the questions we started with: + +*Do more complicated Mal programs show similar speed-ups?* + +No, GraalVM JIT compilation does not provide arbitrary Mal programs with the +massive performance gains we see on the Fib benchmark. This should be +totally unsurprising. + +*How much of the speed-up is really attributable to the Truffle/GraalVM combo, +and how much came from optimizations that could be applied to any Mal interpreter?* + +Our benchmarks show that the answer depends heavily on the nature of the +program. Let's look at the performance of Truffle Mal on GraalVM relative +to its performance on OpenJDK (where we don't have the benefit of Truffle- +enabled partial evaluation): + +| Benchmark | TruffleMal (GraalVM relative to OpenJDK) | +| ------------ | ---------------------------------------- | +| Fib | 34x | +| Busywork 10x | 6x | +| Fib On Mal | 4x | + +In extreme cases, for programs that are heavy on arithmetic and function calls, +our use of Truffle/GraalVM buys us 30x _after accounting for our optimizations_. + +That's pretty amazing. + +Realistically, though, we're likely to see more 3-6x speed-ups directly attributable +to Truffle/GraalVM. Still impressive! + +*How much simplicity did we have to sacrifice in the name of performance?* + +Let's look at the size, in lines of code, of each implementation. + +| File | LOC (Java) | LOC (Truffle Step A) | LOC (Truffle Step E) | +| -------------- | ---------- | -------------------- | -------------------- | +| stepA_mal.java | 310 | 757 | 886 | +| env.java | 58 | 145 | 370 | +| printer.java | 53 | 100 | 100 | +| reader.java | 151 | 166 | 166 | +| types.java | 381 | 532 | 545 | +| core.java | 633 | 1506 | 1511 | +| *Total* | 1586 | 3206 (2x) | 3578 (2.25x) | + +The Truffle-based implementation, before optimizations, weighs in at about +2x the size of the Java implementation. +Much of this can be attributed to 'boilerplate' associated with use of the Truffle framework. +In my opinion, this boilerplate adds effectively nothing to the conceptual complexity of +the implementation. In fact, much of the extra weight comes from the core functions. +The LOC count is longer because we make use of the Truffle DSL, a feature not covered in +this write-up, to trivially allow specialization of core functions based on argument type. +I would argue that while this increases code _size_, it may actually _reduce_ code complexity +via a form of pattern matching. + +Our specializations to the interpreter nodes themselves added about 15%, or 120 lines. +More significantly, we increased the size of the environment implementation by 2.5x, +adding substantial complexity in the process. + +*Was it worth it?* + +This is both totally subjective and a gross over-simplification, +but let's just guess that we've increased the complexity of the baseline Java interpreter +overall by roughly 1.5 x, and environments in particular by 3x. +In exchange for this increase in complexity, we've managed to obtain between from 25x to 80x +better performance over the baseline Java interpreter, depending on the Mal +program. + +We could perform most of our optimizations on that Java interpreter _without_ +using Truffle. However, we'd end up at a similar level of complexity, and +would see substantially smaller performance gains. + +Based on these results, if I were to attempt a 'production quality' Mal implementation, +I'd probably do it with Truffle and GraalVM. The performance gains alone seem to justify it. + +It's also worth observing that the Truffle/GraalVM provide _other_ interesting benefits +that are not performance-related. I won't cover them here. I think the most interesting +non-performance benefit is the promise of interoperability with other Truffle languages. + +## Bonus: AOT-compiled Mal + +GraalVM can ahead-of-time compile Java into a stand-alone executable (with some caveats) +called a _native image_. +This works even for Truffle interpreters! With AOT-compiled Mal, we get all the JIT compilation +goodness of Truffle, _and_ we ditch the need for a Java runtime, **and** we skip the long JVM +start-up time! A GraalVM native image of our Mal interpreter is well suited for scripts and +command line applications. + +The `make-native.sh` script can be used to compile a native image of any Mal step. +To run it, though, you'll need some additional +[prerequisites](https://www.graalvm.org/reference-manual/native-image/#prerequisites). + +The `make-native.sh` script + +* assumes you've already run `gradle build` to compile all Java classes +* takes as its only argument a step name, e.g. `step3_env` +** when no argument is supplied, `stepE_macros` is selected by default +* produces a `build/${STEP}` native image + diff --git a/impls/java-truffle/build.gradle b/impls/java-truffle/build.gradle index a5d5c9c62f..afcd957049 100644 --- a/impls/java-truffle/build.gradle +++ b/impls/java-truffle/build.gradle @@ -1,28 +1,28 @@ -/* - * This file was generated by the Gradle 'init' task. - */ - -plugins { - id 'java' -} - -repositories { - mavenLocal() - maven { - url = uri('https://repo.maven.apache.org/maven2') - } -} - -dependencies { - implementation 'org.graalvm.truffle:truffle-api:21.1.0' - implementation 'org.organicdesign:Paguro:3.2.0' - annotationProcessor 'org.graalvm.truffle:truffle-dsl-processor:21.1.0' -} - -group = 'com.github.mmcgill' -version = '0.0.1' -sourceCompatibility = '11' - -task printClasspath { - println sourceSets.main.runtimeClasspath.getAsPath() -} +/* + * This file was generated by the Gradle 'init' task. + */ + +plugins { + id 'java' +} + +repositories { + mavenLocal() + maven { + url = uri('https://repo.maven.apache.org/maven2') + } +} + +dependencies { + implementation 'org.graalvm.truffle:truffle-api:21.1.0' + implementation 'org.organicdesign:Paguro:3.2.0' + annotationProcessor 'org.graalvm.truffle:truffle-dsl-processor:21.1.0' +} + +group = 'com.github.mmcgill' +version = '0.0.1' +sourceCompatibility = '11' + +task printClasspath { + println sourceSets.main.runtimeClasspath.getAsPath() +} diff --git a/impls/java-truffle/make-native.sh b/impls/java-truffle/make-native.sh index db86494e4d..67e2ba6dd5 100755 --- a/impls/java-truffle/make-native.sh +++ b/impls/java-truffle/make-native.sh @@ -1,8 +1,8 @@ -#!/usr/bin/env bash - -STEP=${1:-stepE_macros} - -CP=$(gradle -q --console plain printClasspath) -native-image --macro:truffle --no-fallback --initialize-at-build-time \ - -H:+TruffleCheckBlackListedMethods \ - -cp "$CP" truffle.mal.$STEP build/$STEP +#!/usr/bin/env bash + +STEP=${1:-stepE_macros} + +CP=$(gradle -q --console plain printClasspath) +native-image --macro:truffle --no-fallback --initialize-at-build-time \ + -H:+TruffleCheckBlackListedMethods \ + -cp "$CP" truffle.mal.$STEP build/$STEP diff --git a/impls/java-truffle/run b/impls/java-truffle/run index a8667ac162..60fd4d90e3 100755 --- a/impls/java-truffle/run +++ b/impls/java-truffle/run @@ -1,20 +1,20 @@ -#!/bin/bash - -CP=$(gradle -q --console plain printClasspath) - -# -Dgraal.LogVerbose=true \ -# -Dgraal.TraceTruffleStackTraceLimit=100 \ -# -Dgraal.TruffleCompilationThreshold=100 \ -# -Dgraal.TraceTruffleCompilationDetails=true \ -# -Dgraal.Dump=Truffle:2 \ -# -Dgraal.TraceTruffleCompilation=true \ -# -Dgraal.TruffleFunctionInlining=true \ -# -Dgraal.TruffleCompilationExceptionsArePrinted=true \ -java \ - -Dgraalvm.locatorDisabled=true \ - -Xss8m \ - --add-opens org.graalvm.truffle/com.oracle.truffle.api=ALL-UNNAMED \ - --add-opens org.graalvm.truffle/com.oracle.truffle.api.interop=ALL-UNNAMED \ - --add-opens org.graalvm.truffle/com.oracle.truffle.api.nodes=ALL-UNNAMED \ - -classpath $CP \ - truffle.mal.${STEP:-stepE_macros} "$@" +#!/bin/bash + +CP=$(gradle -q --console plain printClasspath) + +# -Dgraal.LogVerbose=true \ +# -Dgraal.TraceTruffleStackTraceLimit=100 \ +# -Dgraal.TruffleCompilationThreshold=100 \ +# -Dgraal.TraceTruffleCompilationDetails=true \ +# -Dgraal.Dump=Truffle:2 \ +# -Dgraal.TraceTruffleCompilation=true \ +# -Dgraal.TruffleFunctionInlining=true \ +# -Dgraal.TruffleCompilationExceptionsArePrinted=true \ +java \ + -Dgraalvm.locatorDisabled=true \ + -Xss8m \ + --add-opens org.graalvm.truffle/com.oracle.truffle.api=ALL-UNNAMED \ + --add-opens org.graalvm.truffle/com.oracle.truffle.api.interop=ALL-UNNAMED \ + --add-opens org.graalvm.truffle/com.oracle.truffle.api.nodes=ALL-UNNAMED \ + -classpath $CP \ + truffle.mal.${STEP:-stepE_macros} "$@" diff --git a/impls/java-truffle/settings.gradle b/impls/java-truffle/settings.gradle index f94aa36156..c012b97faa 100644 --- a/impls/java-truffle/settings.gradle +++ b/impls/java-truffle/settings.gradle @@ -1,5 +1,5 @@ -/* - * This file was generated by the Gradle 'init' task. - */ - -rootProject.name = 'truffle-mal' +/* + * This file was generated by the Gradle 'init' task. + */ + +rootProject.name = 'truffle-mal' diff --git a/impls/java-truffle/src/main/java/truffle/mal/Core.java b/impls/java-truffle/src/main/java/truffle/mal/Core.java index 294049e131..013ea66294 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/Core.java +++ b/impls/java-truffle/src/main/java/truffle/mal/Core.java @@ -1,1515 +1,1515 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.FileInputStream; -import java.io.FileNotFoundException; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.io.StringWriter; -import java.util.ArrayList; -import java.util.HashMap; -import java.util.Map; -import java.util.Stack; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.dsl.Fallback; -import com.oracle.truffle.api.dsl.GenerateNodeFactory; -import com.oracle.truffle.api.dsl.NodeChild; -import com.oracle.truffle.api.dsl.NodeFactory; -import com.oracle.truffle.api.dsl.Specialization; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; - -class Core { - static final Map> NS = new HashMap<>(); - - static { - NS.put("+", AddBuiltinFactory.getInstance()); - NS.put("-", SubtractBuiltinFactory.getInstance()); - NS.put("*", MultiplyBuiltinFactory.getInstance()); - NS.put("/", DivideBuiltinFactory.getInstance()); - - NS.put("prn", PrnBuiltinFactory.getInstance()); - NS.put("list", ListBuiltinFactory.getInstance()); - NS.put("list?", IsListBuiltinFactory.getInstance()); - NS.put("empty?", IsEmptyBuiltinFactory.getInstance()); - NS.put("count", CountBuiltinFactory.getInstance()); - NS.put("=", EqualsBuiltinFactory.getInstance()); - NS.put("<", LessThanBuiltinFactory.getInstance()); - NS.put("<=", LessThanEqualBuiltinFactory.getInstance()); - NS.put(">", GreaterThanBuiltinFactory.getInstance()); - NS.put(">=", GreaterThanEqualBuiltinFactory.getInstance()); - NS.put("pr-str", PrStrBuiltinFactory.getInstance()); - NS.put("str", StrBuiltinFactory.getInstance()); - NS.put("println", PrintlnBuiltinFactory.getInstance()); - - NS.put("read-string", ReadStringBuiltinFactory.getInstance()); - NS.put("slurp", SlurpBuiltinFactory.getInstance()); - NS.put("eval", EvalBuiltinFactory.getInstance()); - NS.put("atom", AtomBuiltinFactory.getInstance()); - NS.put("atom?", IsAtomBuiltinFactory.getInstance()); - NS.put("deref", DerefBuiltinFactory.getInstance()); - NS.put("reset!", ResetBuiltinFactory.getInstance()); - NS.put("swap!", SwapBuiltinFactory.getInstance()); - - NS.put("cons", ConsBuiltinFactory.getInstance()); - NS.put("concat", ConcatBuiltinFactory.getInstance()); - NS.put("vec", VecBuiltinFactory.getInstance()); - - NS.put("nth", NthBuiltinFactory.getInstance()); - NS.put("first", FirstBuiltinFactory.getInstance()); - NS.put("rest", RestBuiltinFactory.getInstance()); - - NS.put("throw", ThrowBuiltinFactory.getInstance()); - NS.put("apply", ApplyBuiltinFactory.getInstance()); - NS.put("map", MapBuiltinFactory.getInstance()); - NS.put("nil?", IsNilBuiltinFactory.getInstance()); - NS.put("true?", IsTrueBuiltinFactory.getInstance()); - NS.put("false?", IsFalseBuiltinFactory.getInstance()); - NS.put("symbol?", IsSymbolBuiltinFactory.getInstance()); - NS.put("symbol", SymbolBuiltinFactory.getInstance()); - NS.put("keyword", KeywordBuiltinFactory.getInstance()); - NS.put("keyword?", IsKeywordBuiltinFactory.getInstance()); - NS.put("vector", VectorBuiltinFactory.getInstance()); - NS.put("vector?", IsVectorBuiltinFactory.getInstance()); - NS.put("sequential?", IsSequentialBuiltinFactory.getInstance()); - NS.put("hash-map", HashMapBuiltinFactory.getInstance()); - NS.put("map?", IsMapBuiltinFactory.getInstance()); - NS.put("assoc", AssocBuiltinFactory.getInstance()); - NS.put("dissoc", DissocBuiltinFactory.getInstance()); - NS.put("get", GetBuiltinFactory.getInstance()); - NS.put("contains?", ContainsBuiltinFactory.getInstance()); - NS.put("keys", KeysBuiltinFactory.getInstance()); - NS.put("vals", ValsBuiltinFactory.getInstance()); - - NS.put("readline", ReadlineBuiltinFactory.getInstance()); - NS.put("meta", MetaBuiltinFactory.getInstance()); - NS.put("with-meta", WithMetaBuiltinFactory.getInstance()); - NS.put("time-ms", TimeMsBuiltinFactory.getInstance()); - NS.put("conj", ConjBuiltinFactory.getInstance()); - NS.put("string?", IsStringBuiltinFactory.getInstance()); - NS.put("number?", IsNumberBuiltinFactory.getInstance()); - NS.put("fn?", IsFnBuiltinFactory.getInstance()); - NS.put("macro?", IsMacroBuiltinFactory.getInstance()); - NS.put("seq", SeqBuiltinFactory.getInstance()); - } - - static MalEnv newGlobalEnv(Class> languageClass, TruffleLanguage language) { - var env = new MalEnv(languageClass); - for (var entry : NS.entrySet()) { - var root = new BuiltinRootNode(language, entry.getValue()); - var fnVal = new MalFunction( - Truffle.getRuntime().createCallTarget(root), null, root.getNumArgs(), - // Built-in functions should not be tail called. It doesn't help with - // stack consumption, since they aren't recursive, and it *does* - // invalidate direct call sites, which hurts performance. - false); - env.set(MalSymbol.get(entry.getKey()), fnVal); - } - return env; - } -} - -abstract class AbstractInvokeNode extends Node { - abstract Object invoke(CallTarget target, Object[] args); -} -/** A hack to make certain nodes sharable across languages. - */ -interface IMalLanguage { - CallTarget evalForm(Object form); - AbstractInvokeNode invokeNode(); - PrintStream out(); - BufferedReader in(); -} - -abstract class BuiltinNode extends Node { - protected IMalLanguage language; - - protected void setLanguage(IMalLanguage language) { - this.language = language; - } - - @TruffleBoundary - protected static MalException illegalArgumentException(String expectedType, Object obj) { - return new MalException("Illegal argument: '"+obj.toString()+"' is not of type "+expectedType); - } - - final String name; - - protected BuiltinNode(String name) { - this.name = name; - } - - abstract Object executeGeneric(VirtualFrame frame); - - long executeLong(VirtualFrame frame) throws UnexpectedResultException { - var value = executeGeneric(frame); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - boolean executeBoolean(VirtualFrame frame) throws UnexpectedResultException { - var value = executeGeneric(frame); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } -} - -class ReadArgNode extends Node { - final int argNum; - - ReadArgNode(int argNum) { - this.argNum = argNum; - } - - Object executeGeneric(VirtualFrame frame) { - return frame.getArguments()[argNum]; - } -} - -class ReadArgsNode extends Node { - final int argPos; - - ReadArgsNode(int argPos) { - this.argPos = argPos; - } - - Object executeGeneric(VirtualFrame frame) { - Object[] args = frame.getArguments(); - final var len = args.length - argPos; - var result = new Object[len]; - System.arraycopy(args, argPos, result, 0, len); - return result; - } -} - -class BuiltinRootNode extends RootNode { - private final int numArgs; - @Child private BuiltinNode node; - - public BuiltinRootNode(TruffleLanguage lang, NodeFactory nodeFactory) { - super(lang); - var sig = nodeFactory.getExecutionSignature(); - int numArgs = nodeFactory.getExecutionSignature().size(); - Object[] readArgNodes = new Node[numArgs]; - for (int i=0; i < numArgs; ++i) { - if (sig.get(i).equals(ReadArgsNode.class)) { - assert i == numArgs-1 : "ReadArgsNode must be last argument"; - readArgNodes[i] = new ReadArgsNode(i+1); - numArgs = -1; // variadic - } else { - readArgNodes[i] = new ReadArgNode(i+1); - } - } - node = nodeFactory.createNode(readArgNodes); - if (lang instanceof IMalLanguage) { - node.setLanguage((IMalLanguage)lang); - } - this.numArgs = numArgs; - } - - public int getNumArgs() { - return numArgs; - } - - @Override - public Object execute(VirtualFrame frame) { - return node.executeGeneric(frame); - } - - @Override - public String toString() { - return "#"; - } -} - -/************** MATH *******************/ - -@NodeChild(value="lhs", type=ReadArgNode.class) -@NodeChild(value="rhs", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class AddBuiltin extends BuiltinNode { - - protected AddBuiltin() { super("+"); } - - @Specialization - protected long add(long lhs, long rhs) { - return lhs + rhs; - } -} - -@NodeChild(value="lhs", type=ReadArgNode.class) -@NodeChild(value="rhs", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class SubtractBuiltin extends BuiltinNode { - - protected SubtractBuiltin() { super("-"); } - - @Specialization - protected long subtract(long lhs, long rhs) { - return lhs - rhs; - } - -} - -@NodeChild(value="lhs", type=ReadArgNode.class) -@NodeChild(value="rhs", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class MultiplyBuiltin extends BuiltinNode { - - protected MultiplyBuiltin() { super("*"); } - - @Specialization - protected long multiply(long lhs, long rhs) { - return lhs * rhs; - } -} - -@NodeChild(value="lhs", type=ReadArgNode.class) -@NodeChild(value="rhs", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class DivideBuiltin extends BuiltinNode { - protected DivideBuiltin() { super("/"); } - - @Specialization - protected long divide(long lhs, long rhs) { - return lhs / rhs; - } -} - -/************** STRINGS *******************/ - -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class PrnBuiltin extends BuiltinNode { - protected PrnBuiltin() { super("prn"); } - - @Specialization - @TruffleBoundary - protected Object prn(Object[] args) { - var buf = new StringBuilder(); - if (args.length > 0) { - Printer.prStr(buf, args[0], true); - } - for (int i=1; i < args.length; ++i) { - buf.append(' '); - Printer.prStr(buf, args[i], true); - } - language.out().println(buf.toString()); - return MalNil.NIL; - } -} - -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class PrStrBuiltin extends BuiltinNode { - - protected PrStrBuiltin() { super("pr-str"); } - - @Specialization - @TruffleBoundary - protected String prStr(Object... args) { - var buf = new StringBuilder(); - if (args.length > 0) { - Printer.prStr(buf, args[0], true); - } - for (int i=1; i < args.length; ++i) { - buf.append(' '); - Printer.prStr(buf, args[i], true); - } - return buf.toString(); - } -} - -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class StrBuiltin extends BuiltinNode { - - protected StrBuiltin() { super("str"); } - - @Specialization - @TruffleBoundary - protected String prStr(Object... args) { - var buf = new StringBuilder(); - for (int i=0; i < args.length; ++i) { - Printer.prStr(buf, args[i], false); - } - return buf.toString(); - } -} - -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class PrintlnBuiltin extends BuiltinNode { - - protected PrintlnBuiltin() { super("println"); } - - @Specialization - @TruffleBoundary - protected MalNil println(Object... args) { - var buf = new StringBuilder(); - if (args.length > 0) { - Printer.prStr(buf, args[0], false); - } - for (int i=1; i < args.length; ++i) { - buf.append(' '); - Printer.prStr(buf, args[i], false); - } - // The correct thing is to use the output stream associated with our language context. - // However, since each step is effectively its own language, and we wish - // to share this node among them, we'll just cheat and call System.out directly. - language.out().println(buf.toString()); - return MalNil.NIL; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class ReadStringBuiltin extends BuiltinNode { - - protected ReadStringBuiltin() { super("read-string"); } - - @TruffleBoundary - @Specialization - protected Object readString(String s) { - return Reader.readStr(s); - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class SlurpBuiltin extends BuiltinNode { - - protected SlurpBuiltin() { super("slurp"); } - - @TruffleBoundary - @Specialization - protected String slurp(String path) { - try { - var writer = new StringWriter(); - var reader = new InputStreamReader(new FileInputStream(path)); - try { - reader.transferTo(writer); - return writer.toString(); - } finally { - reader.close(); - } - } catch (FileNotFoundException ex) { - throw new MalException(ex.getMessage()); - } catch (IOException ex) { - throw new MalException(ex.getMessage()); - } - } -} - -/************ COLLECTIONS *****************/ - -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class ListBuiltin extends BuiltinNode { - - protected ListBuiltin() { super("list"); } - - @Specialization - protected MalList list(Object[] args) { - var result = MalList.EMPTY; - for (int i=args.length-1; i >= 0; --i) { - result = result.cons(args[i]); - } - return result; - } -} - -@NodeChild(value = "list", type = ReadArgNode.class) -@GenerateNodeFactory -abstract class IsListBuiltin extends BuiltinNode { - - protected IsListBuiltin() { super("list?"); } - - @Specialization - public boolean isList(MalList list) { - return true; - } - - @Fallback - public boolean isList(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsEmptyBuiltin extends BuiltinNode { - - protected IsEmptyBuiltin() { super("empty?"); } - - @Specialization - protected boolean isEmpty(MalList list) { - return list.head == null; - } - - @Specialization - protected boolean isEmpty(MalVector vector) { - return vector.size() == 0; - } - - @Fallback - protected Object typeError(Object arg) { - throw illegalArgumentException("list", arg); - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class CountBuiltin extends BuiltinNode { - - protected CountBuiltin() { super("count"); } - - @Specialization - protected long count(MalList arg) { - return arg.length; - } - - @Specialization - protected long count(MalVector arg) { - return arg.size(); - } - - @Specialization - protected long count(MalNil arg) { - return 0; - } - - @Fallback - protected Object count(Object arg) { - throw illegalArgumentException("list", arg); - } -} - -@NodeChild(value="obj", type=ReadArgNode.class) -@NodeChild(value="list", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class ConsBuiltin extends BuiltinNode { - - protected ConsBuiltin() { super("cons"); } - - @Specialization - @TruffleBoundary - protected MalList cons(Object obj, MalVector vec) { - return cons(obj, vec.toList()); - } - - @Specialization - @TruffleBoundary - protected MalList cons(Object obj, MalList list) { - return list.cons(obj); - } -} - -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class ConcatBuiltin extends BuiltinNode { - - protected ConcatBuiltin() { super("concat"); } - - private MalList concat1(MalList a, MalList b) { - var elems = new Stack(); - for (Object elem : a) { - elems.push(elem); - } - while (!elems.isEmpty()) { - b = b.cons(elems.pop()); - } - return b; - } - - private MalList concat1(MalVector a, MalList b) { - for (int i=a.size()-1; i >= 0; i--) { - b = b.cons(a.get(i)); - } - return b; - } - - @Specialization - @TruffleBoundary - protected MalList concat(Object... args) { - if (args.length == 0) { - return MalList.EMPTY; - } - Object arg = args[args.length-1]; - MalList result; - if (arg instanceof MalVector) { - result = ((MalVector) arg).toList(); - } else { - result = (MalList)arg; - } - for (int i=args.length-2; i >= 0; --i) { - arg = args[i]; - if (arg instanceof MalVector) { - result = concat1((MalVector)arg, result); - } else { - result = concat1((MalList)arg, result); - } - } - return result; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class VecBuiltin extends BuiltinNode { - - protected VecBuiltin() { super("vec"); } - - @Specialization - protected MalVector vec(MalVector v) { - return v; - } - - @Specialization - protected MalVector vec(MalList l) { - return MalVector.EMPTY.concat(l); - } -} - -@NodeChild(value="list", type=ReadArgNode.class) -@NodeChild(value="n", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class NthBuiltin extends BuiltinNode { - - protected NthBuiltin() { super("nth"); } - - @Specialization - @TruffleBoundary - protected Object nth(MalVector vec, long n) { - if (n >= vec.size()) { - throwInvalidArgument(); - } - return vec.get((int)n); - } - - private void throwInvalidArgument() { - throw new MalException("Out of bounds"); - } - - @Specialization - protected Object nth(MalList list, long n) { - if (n >= list.length) { - throwInvalidArgument(); - } - while (--n >= 0) { - list = list.tail; - } - return list.head; - } -} - -@GenerateNodeFactory -@NodeChild(value="arg", type=ReadArgNode.class) -abstract class FirstBuiltin extends BuiltinNode { - protected FirstBuiltin() { super("first"); } - - @Specialization - protected MalNil first(MalNil nil) { - return MalNil.NIL; - } - - @Specialization - protected Object first(MalVector vec) { - if (vec.size() == 0) - return MalNil.NIL; - return vec.get(0); - } - - @Specialization - protected Object first(MalList list) { - if (list.head == null) { - return MalNil.NIL; - } - return list.head; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class RestBuiltin extends BuiltinNode { - - protected RestBuiltin() { super("rest"); } - - @Specialization - protected MalList rest(MalNil nil) { - return MalList.EMPTY; - } - - @Specialization - @TruffleBoundary - protected MalList rest(MalVector vec) { - return rest(vec.toList()); - } - - @Specialization - protected MalList rest(MalList list) { - if (list.head == null) { - return list; - } - return list.tail; - } -} - -@NodeChild(value="fn", type=ReadArgNode.class) -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class ApplyBuiltin extends BuiltinNode { - @Child private AbstractInvokeNode invokeNode; - - protected ApplyBuiltin() { - super("apply"); - } - - @Override - protected void setLanguage(IMalLanguage language) { - super.setLanguage(language); - this.invokeNode = language.invokeNode(); - } - - @TruffleBoundary - private Object[] getArgs(Object[] args) { - Object[] fnArgs; - if (args.length == 0) { - fnArgs = args; - } else { - Object lastArg = args[args.length-1]; - int lastArgSize; - if (lastArg instanceof MalVector) { - lastArgSize = ((MalVector)lastArg).size(); - } else { - lastArgSize = (int)((MalList)lastArg).length; - } - fnArgs = new Object[args.length + lastArgSize]; - for (int i=0; i < args.length-1; i++) { - fnArgs[i+1] = args[i]; - } - int i = args.length; - assert lastArg instanceof Iterable; - for (Object obj : ((Iterable)lastArg)) { - fnArgs[i++] = obj; - } - } - return fnArgs; - } - - @Specialization - protected Object apply(VirtualFrame frame, MalFunction fn, Object[] args) { - var fnArgs = getArgs(args); - fnArgs[0] = fn.closedOverEnv; - return invokeNode.invoke(fn.callTarget, fnArgs); - } -} - -@NodeChild(value="fn", type=ReadArgNode.class) -@NodeChild(value="col", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class MapBuiltin extends BuiltinNode { - @Child private AbstractInvokeNode invokeNode; - - protected MapBuiltin() { - super("map"); - } - - @Override - protected void setLanguage(IMalLanguage language) { - super.setLanguage(language); - invokeNode = language.invokeNode(); - } - - @TruffleBoundary - private Object doMap(MalFunction fn, Iterable vals) { - var result = new ArrayList(); - Object[] args = new Object[2]; - args[0] = fn.closedOverEnv; - for (Object obj : vals) { - args[1] = obj; - result.add(invokeNode.invoke(fn.callTarget, args)); - } - return MalList.from(result); - } - - @Specialization - protected Object map(MalFunction fn, MalVector vec) { - return doMap(fn, vec); - } - - @Specialization - protected Object map(MalFunction fn, MalList list) { - return doMap(fn, list); - } -} - -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class VectorBuiltin extends BuiltinNode { - - protected VectorBuiltin() { super("vector"); } - - @TruffleBoundary - @Specialization - public MalVector vector(Object[] args) { - MalVector v = MalVector.EMPTY; - for (Object arg : args) { - v = v.append(arg); - } - return v; - } -} - -@NodeChild(value="col", type=ReadArgNode.class) -@NodeChild(value="elems", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class ConjBuiltin extends BuiltinNode { - - protected ConjBuiltin() { super("conj"); } - - @Specialization - protected MalList conj(MalList list, Object[] elems) { - for (int i=0; i < elems.length; i++) { - list = list.cons(elems[i]); - } - return list; - } - - @Specialization - protected MalVector conj(MalVector vec, Object[] elems) { - for (int i=0; i < elems.length; i++) { - vec = vec.append(elems[i]); - } - return vec; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class SeqBuiltin extends BuiltinNode { - - protected SeqBuiltin() { super("seq"); } - - @Specialization - protected Object seq(MalList list) { - if (list.length == 0) { - return MalNil.NIL; - } - return list; - } - @Specialization - protected Object seq(MalVector vec) { - if (vec.size() == 0) { - return MalNil.NIL; - } - return vec.toList(); - } - @Specialization - protected Object seq(String str) { - if (str.isEmpty()) { - return MalNil.NIL; - } - MalList l = MalList.EMPTY; - for (int i=str.length()-1; i >= 0; i--) { - l = l.cons(str.substring(i, i+1)); - } - return l; - } - @Specialization - protected MalNil seq(MalNil nil) { - return nil; - } -} - -/************* Maps ********************/ - -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class HashMapBuiltin extends BuiltinNode { - - protected HashMapBuiltin() { super("hash-map"); } - - @Specialization - @TruffleBoundary - protected MalMap hashMap(Object[] args) { - MalMap map = MalMap.EMPTY; - for (int i=0; i < args.length; i += 2) { - map = map.assoc(args[i], args[i+1]); - } - return map; - } -} - -@NodeChild(value="map", type=ReadArgNode.class) -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class AssocBuiltin extends BuiltinNode { - - protected AssocBuiltin() { super("assoc"); } - - @Specialization - protected Object assoc(MalMap map, Object[] args) { - for (int i=0; i < args.length; i+=2) { - map = map.assoc(args[i], args[i+1]); - } - return map; - } -} - -@NodeChild(value="map", type=ReadArgNode.class) -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class DissocBuiltin extends BuiltinNode { - - protected DissocBuiltin() { super("dissoc"); } - - @Specialization - protected MalMap dissoc(MalMap map, Object[] args) { - for (Object arg : args) { - map = map.dissoc(arg); - } - return map; - } -} - -@NodeChild(value="map", type=ReadArgNode.class) -@NodeChild(value="key", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class GetBuiltin extends BuiltinNode { - - protected GetBuiltin() { super("get"); } - - @Specialization - @TruffleBoundary - protected Object get(MalMap map, Object key) { - return map.map.getOrDefault(key, MalNil.NIL); - } - - @Specialization - protected Object get(MalNil nil, Object key) { - return MalNil.NIL; - } -} - -@NodeChild(value="map", type=ReadArgNode.class) -@NodeChild(value="key", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class ContainsBuiltin extends BuiltinNode { - - protected ContainsBuiltin() { super("contains?"); } - - @Specialization - @TruffleBoundary - protected boolean contains(MalMap map, Object key) { - return map.map.containsKey(key); - } -} - -@NodeChild(value="map", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class KeysBuiltin extends BuiltinNode { - - protected KeysBuiltin() { super("keys"); } - - @Specialization - @TruffleBoundary - protected MalList keys(MalMap map) { - MalList list = MalList.EMPTY; - var iter = map.map.keyIterator(); - while (iter.hasNext()) { - list = list.cons(iter.next()); - } - return list; - } -} - -@NodeChild(value="map", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class ValsBuiltin extends BuiltinNode { - - protected ValsBuiltin() { super("vals"); } - - @Specialization - @TruffleBoundary - protected Object vals(MalMap map) { - MalList list = MalList.EMPTY; - var iter = map.map.valIterator(); - while (iter.hasNext()) { - list = list.cons(iter.next()); - } - return list; - } -} - -/************* COMPARISONS *************/ - -@NodeChild(value="lhs", type=ReadArgNode.class) -@NodeChild(value="rhs", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class EqualsBuiltin extends BuiltinNode { - - protected EqualsBuiltin() { super("="); } - - @Specialization - protected boolean equals(long lhs, long rhs) { - return lhs == rhs; - } - - @Specialization - protected boolean equals(boolean lhs, boolean rhs) { - return lhs == rhs; - } - - @TruffleBoundary - @Specialization - protected boolean equals(String lhs, String rhs) { - return lhs.equals(rhs); - } - - @Specialization - protected boolean equals(MalFunction lhs, MalFunction rhs) { - return lhs == rhs; - } - - @Specialization - protected boolean equals(MalNil lhs, MalNil rhs) { - return lhs == rhs; - } - - @TruffleBoundary - @Specialization - protected boolean equals(MalValue lhs, MalValue rhs) { - if (lhs == null) { - return lhs == rhs; - } else { - return lhs.equals(rhs); - } - } - - @Fallback - protected boolean equals(Object lhs, Object rhs) { - return false; - } -} - -@NodeChild(value="lhs", type=ReadArgNode.class) -@NodeChild(value="rhs", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class GreaterThanBuiltin extends BuiltinNode { - - protected GreaterThanBuiltin() { super(">"); } - - @Specialization - protected boolean greaterThan(long lhs, long rhs) { - return lhs > rhs; - } - - @Specialization - protected Object typeError(Object lhs, long rhs) { - throw illegalArgumentException("integer", lhs); - } - - @Fallback - protected Object typeError(Object lhs, Object rhs) { - throw illegalArgumentException("integer", rhs); - } -} - -@NodeChild(value="lhs", type=ReadArgNode.class) -@NodeChild(value="rhs", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class GreaterThanEqualBuiltin extends BuiltinNode { - - protected GreaterThanEqualBuiltin() { super(">="); } - - @Specialization - protected boolean greaterThanEqual(long lhs, long rhs) { - return lhs >= rhs; - } - - @Specialization - protected Object typeError(Object lhs, long rhs) { - throw illegalArgumentException("integer", lhs); - } - - @Fallback - protected Object typeError(Object lhs, Object rhs) { - throw illegalArgumentException("integer", rhs); - } -} - -@NodeChild(value="lhs", type=ReadArgNode.class) -@NodeChild(value="rhs", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class LessThanBuiltin extends BuiltinNode { - - protected LessThanBuiltin() { super("<"); } - - @Specialization - protected boolean lessThan(long lhs, long rhs) { - return lhs < rhs; - } - - @Specialization - protected Object typeError(Object lhs, long rhs) { - throw illegalArgumentException("integer", lhs); - } - - @Fallback - protected Object typeError(Object lhs, Object rhs) { - throw illegalArgumentException("integer", rhs); - } -} - -@NodeChild(value="lhs", type=ReadArgNode.class) -@NodeChild(value="rhs", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class LessThanEqualBuiltin extends BuiltinNode { - - protected LessThanEqualBuiltin() { super("<="); } - - @Specialization - protected boolean lessThanEqual(long lhs, long rhs) { - return lhs <= rhs; - } - - @Specialization - protected Object typeError(Object lhs, long rhs) { - throw illegalArgumentException("integer", lhs); - } - - @Fallback - protected Object typeError(Object lhs, Object rhs) { - throw illegalArgumentException("integer", rhs); - } -} - -/*************** Atoms ********************/ - -@NodeChild(value="val", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class AtomBuiltin extends BuiltinNode { - protected AtomBuiltin() { super("atom"); } - - @Specialization - protected MalAtom atom(Object val) { - return new MalAtom(val); - } -} - -@NodeChild(value="val", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsAtomBuiltin extends BuiltinNode { - - protected IsAtomBuiltin() { super("atom?"); } - - @Specialization - protected boolean isAtom(Object obj) { - return obj instanceof MalAtom; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class DerefBuiltin extends BuiltinNode { - - protected DerefBuiltin() { super("deref"); } - - @Specialization - protected Object deref(MalAtom atom) { - return atom.deref(); - } -} - -@NodeChild(value="atom", type=ReadArgNode.class) -@NodeChild(value="val", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class ResetBuiltin extends BuiltinNode { - - protected ResetBuiltin() { super("reset!"); } - - @Specialization - protected Object reset(MalAtom atom, Object val) { - atom.reset(val); - return val; - } -} - -@NodeChild(value="atom", type=ReadArgNode.class) -@NodeChild(value="fn", type=ReadArgNode.class) -@NodeChild(value="args", type=ReadArgsNode.class) -@GenerateNodeFactory -abstract class SwapBuiltin extends BuiltinNode { - @Child private AbstractInvokeNode invokeNode; - - protected SwapBuiltin() { - super("swap!"); - } - - @Override - protected void setLanguage(IMalLanguage language) { - super.setLanguage(language); - this.invokeNode = language.invokeNode(); - } - - @Specialization - protected Object swap(MalAtom atom, MalFunction fn, Object... args) { - synchronized (atom) { - Object[] fnArgs = new Object[2+args.length]; - fnArgs[0] = fn.closedOverEnv; - fnArgs[1] = atom.deref(); - for (int i=0; i < args.length; i++) { - fnArgs[i+2] = args[i]; - } - Object newVal = invokeNode.invoke(fn.callTarget, fnArgs); - atom.reset(newVal); - return newVal; - } - } -} - -/*************** Predicates ***************/ - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsNilBuiltin extends BuiltinNode { - protected IsNilBuiltin() { super("nil?"); } - - @Specialization - protected boolean isNil(MalNil nil) { - return true; - } - - @Fallback - protected boolean isNil(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsTrueBuiltin extends BuiltinNode { - protected IsTrueBuiltin() { super("true?"); } - - @Specialization - protected boolean isTrue(boolean b) { - return b == true; - } - - @Fallback - protected boolean isTrue(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsFalseBuiltin extends BuiltinNode { - protected IsFalseBuiltin() { super("false?"); } - - @Specialization - protected boolean isFalse(boolean b) { - return b == false; - } - - @Fallback - protected boolean isFalse(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsSymbolBuiltin extends BuiltinNode { - protected IsSymbolBuiltin() { super("symbol?"); } - - @Specialization - protected boolean isSymbol(MalSymbol sym) { - return true; - } - - @Fallback - protected boolean isSymbol(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsKeywordBuiltin extends BuiltinNode { - - protected IsKeywordBuiltin() { super("keyword?"); } - - @Specialization - protected boolean isKeyword(MalKeyword kw) { - return true; - } - - @Fallback - protected boolean isKeyword(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsVectorBuiltin extends BuiltinNode { - - protected IsVectorBuiltin() { super("vector?"); } - - @Specialization - protected boolean isVector(MalVector vec) { - return true; - } - - @Fallback - protected boolean isVector(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsSequentialBuiltin extends BuiltinNode { - - protected IsSequentialBuiltin() { super("sequential?"); } - - @Specialization - protected Object isSequential(MalList list) { - return true; - } - @Specialization - protected Object isSequential(MalVector vec) { - return true; - } - @Fallback - protected Object isSequential(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsMapBuiltin extends BuiltinNode { - - protected IsMapBuiltin() { super("map?"); } - - @Specialization - protected boolean isMap(MalMap map) { - return true; - } - @Fallback - protected boolean isMap(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsStringBuiltin extends BuiltinNode { - - protected IsStringBuiltin() { super("string?"); } - - @Specialization - protected boolean isString(String val) { - return true; - } - - @Fallback - protected boolean isString(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsNumberBuiltin extends BuiltinNode { - - protected IsNumberBuiltin() { super("number?"); } - - @Specialization - protected boolean isNumber(long n) { - return true; - } - - @Fallback - protected boolean isNumber(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsFnBuiltin extends BuiltinNode { - - protected IsFnBuiltin() { super("fn?"); } - - @Specialization - protected boolean isFn(MalFunction fn) { - return !fn.isMacro; - } - - @Fallback - protected boolean isFn(Object obj) { - return false; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class IsMacroBuiltin extends BuiltinNode { - - protected IsMacroBuiltin() { super("macro?"); } - - @Specialization - protected boolean isMacro(MalFunction fn) { - return fn.isMacro; - } - - @Fallback - protected boolean isMacro(Object obj) { - return false; - } -} - -/*************** Other ********************/ - -@NodeChild(value="ast", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class EvalBuiltin extends BuiltinNode { - - protected EvalBuiltin() { super("eval"); } - - @Specialization - @TruffleBoundary - protected Object eval(Object ast) { - return language.evalForm(ast).call(); - } -} - -@NodeChild(value="obj", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class ThrowBuiltin extends BuiltinNode { - - protected ThrowBuiltin() { super("throw"); } - - @TruffleBoundary - @Specialization - protected Object throwException(String obj) { - throw new MalException(obj); - } - - @TruffleBoundary - @Fallback - protected Object throwException(Object obj) { - throw new MalException(obj); - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class SymbolBuiltin extends BuiltinNode { - - protected SymbolBuiltin() { super("symbol"); } - - @Specialization - protected MalSymbol symbol(String str) { - return MalSymbol.get(str); - } - - @Specialization - protected MalSymbol symbol(MalSymbol sym) { - return sym; - } -} - -@GenerateNodeFactory -@NodeChild(value="arg", type=ReadArgNode.class) -abstract class KeywordBuiltin extends BuiltinNode { - - protected KeywordBuiltin() { super("keyword"); } - - @Specialization - protected MalKeyword keyword(String arg) { - return MalKeyword.get(arg); - } - - @Specialization - protected MalKeyword keyword(MalKeyword kw) { - return kw; - } -} - -@NodeChild(value="prompt", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class ReadlineBuiltin extends BuiltinNode { - - protected ReadlineBuiltin() { super("readline"); } - - @Specialization - @TruffleBoundary - protected Object readline(String prompt) { - language.out().print(prompt); - language.out().flush(); - try { - String s = language.in().readLine(); - return s == null ? MalNil.NIL : s; - } catch (IOException ex) { - throw new MalException(ex.getMessage()); - } - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class MetaBuiltin extends BuiltinNode { - - protected MetaBuiltin() { super("meta"); } - - @Specialization - protected Object meta(MetaHolder arg) { - return arg.getMeta(); - } - - @Fallback - protected Object meta(Object obj) { - return MalNil.NIL; - } -} - -@NodeChild(value="arg", type=ReadArgNode.class) -@NodeChild(value="meta", type=ReadArgNode.class) -@GenerateNodeFactory -abstract class WithMetaBuiltin extends BuiltinNode { - - protected WithMetaBuiltin() { super("with-meta"); } - - @Specialization - protected Object withMeta(MetaHolder holder, Object meta) { - return holder.withMeta(meta); - } -} - -@GenerateNodeFactory -abstract class TimeMsBuiltin extends BuiltinNode { - - protected TimeMsBuiltin() { super("time-ms"); } - - @TruffleBoundary - @Specialization - protected long timeMs() { - return System.nanoTime() / 1000000; - } +package truffle.mal; + +import java.io.BufferedReader; +import java.io.FileInputStream; +import java.io.FileNotFoundException; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.io.StringWriter; +import java.util.ArrayList; +import java.util.HashMap; +import java.util.Map; +import java.util.Stack; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.dsl.Fallback; +import com.oracle.truffle.api.dsl.GenerateNodeFactory; +import com.oracle.truffle.api.dsl.NodeChild; +import com.oracle.truffle.api.dsl.NodeFactory; +import com.oracle.truffle.api.dsl.Specialization; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; + +class Core { + static final Map> NS = new HashMap<>(); + + static { + NS.put("+", AddBuiltinFactory.getInstance()); + NS.put("-", SubtractBuiltinFactory.getInstance()); + NS.put("*", MultiplyBuiltinFactory.getInstance()); + NS.put("/", DivideBuiltinFactory.getInstance()); + + NS.put("prn", PrnBuiltinFactory.getInstance()); + NS.put("list", ListBuiltinFactory.getInstance()); + NS.put("list?", IsListBuiltinFactory.getInstance()); + NS.put("empty?", IsEmptyBuiltinFactory.getInstance()); + NS.put("count", CountBuiltinFactory.getInstance()); + NS.put("=", EqualsBuiltinFactory.getInstance()); + NS.put("<", LessThanBuiltinFactory.getInstance()); + NS.put("<=", LessThanEqualBuiltinFactory.getInstance()); + NS.put(">", GreaterThanBuiltinFactory.getInstance()); + NS.put(">=", GreaterThanEqualBuiltinFactory.getInstance()); + NS.put("pr-str", PrStrBuiltinFactory.getInstance()); + NS.put("str", StrBuiltinFactory.getInstance()); + NS.put("println", PrintlnBuiltinFactory.getInstance()); + + NS.put("read-string", ReadStringBuiltinFactory.getInstance()); + NS.put("slurp", SlurpBuiltinFactory.getInstance()); + NS.put("eval", EvalBuiltinFactory.getInstance()); + NS.put("atom", AtomBuiltinFactory.getInstance()); + NS.put("atom?", IsAtomBuiltinFactory.getInstance()); + NS.put("deref", DerefBuiltinFactory.getInstance()); + NS.put("reset!", ResetBuiltinFactory.getInstance()); + NS.put("swap!", SwapBuiltinFactory.getInstance()); + + NS.put("cons", ConsBuiltinFactory.getInstance()); + NS.put("concat", ConcatBuiltinFactory.getInstance()); + NS.put("vec", VecBuiltinFactory.getInstance()); + + NS.put("nth", NthBuiltinFactory.getInstance()); + NS.put("first", FirstBuiltinFactory.getInstance()); + NS.put("rest", RestBuiltinFactory.getInstance()); + + NS.put("throw", ThrowBuiltinFactory.getInstance()); + NS.put("apply", ApplyBuiltinFactory.getInstance()); + NS.put("map", MapBuiltinFactory.getInstance()); + NS.put("nil?", IsNilBuiltinFactory.getInstance()); + NS.put("true?", IsTrueBuiltinFactory.getInstance()); + NS.put("false?", IsFalseBuiltinFactory.getInstance()); + NS.put("symbol?", IsSymbolBuiltinFactory.getInstance()); + NS.put("symbol", SymbolBuiltinFactory.getInstance()); + NS.put("keyword", KeywordBuiltinFactory.getInstance()); + NS.put("keyword?", IsKeywordBuiltinFactory.getInstance()); + NS.put("vector", VectorBuiltinFactory.getInstance()); + NS.put("vector?", IsVectorBuiltinFactory.getInstance()); + NS.put("sequential?", IsSequentialBuiltinFactory.getInstance()); + NS.put("hash-map", HashMapBuiltinFactory.getInstance()); + NS.put("map?", IsMapBuiltinFactory.getInstance()); + NS.put("assoc", AssocBuiltinFactory.getInstance()); + NS.put("dissoc", DissocBuiltinFactory.getInstance()); + NS.put("get", GetBuiltinFactory.getInstance()); + NS.put("contains?", ContainsBuiltinFactory.getInstance()); + NS.put("keys", KeysBuiltinFactory.getInstance()); + NS.put("vals", ValsBuiltinFactory.getInstance()); + + NS.put("readline", ReadlineBuiltinFactory.getInstance()); + NS.put("meta", MetaBuiltinFactory.getInstance()); + NS.put("with-meta", WithMetaBuiltinFactory.getInstance()); + NS.put("time-ms", TimeMsBuiltinFactory.getInstance()); + NS.put("conj", ConjBuiltinFactory.getInstance()); + NS.put("string?", IsStringBuiltinFactory.getInstance()); + NS.put("number?", IsNumberBuiltinFactory.getInstance()); + NS.put("fn?", IsFnBuiltinFactory.getInstance()); + NS.put("macro?", IsMacroBuiltinFactory.getInstance()); + NS.put("seq", SeqBuiltinFactory.getInstance()); + } + + static MalEnv newGlobalEnv(Class> languageClass, TruffleLanguage language) { + var env = new MalEnv(languageClass); + for (var entry : NS.entrySet()) { + var root = new BuiltinRootNode(language, entry.getValue()); + var fnVal = new MalFunction( + Truffle.getRuntime().createCallTarget(root), null, root.getNumArgs(), + // Built-in functions should not be tail called. It doesn't help with + // stack consumption, since they aren't recursive, and it *does* + // invalidate direct call sites, which hurts performance. + false); + env.set(MalSymbol.get(entry.getKey()), fnVal); + } + return env; + } +} + +abstract class AbstractInvokeNode extends Node { + abstract Object invoke(CallTarget target, Object[] args); +} +/** A hack to make certain nodes sharable across languages. + */ +interface IMalLanguage { + CallTarget evalForm(Object form); + AbstractInvokeNode invokeNode(); + PrintStream out(); + BufferedReader in(); +} + +abstract class BuiltinNode extends Node { + protected IMalLanguage language; + + protected void setLanguage(IMalLanguage language) { + this.language = language; + } + + @TruffleBoundary + protected static MalException illegalArgumentException(String expectedType, Object obj) { + return new MalException("Illegal argument: '"+obj.toString()+"' is not of type "+expectedType); + } + + final String name; + + protected BuiltinNode(String name) { + this.name = name; + } + + abstract Object executeGeneric(VirtualFrame frame); + + long executeLong(VirtualFrame frame) throws UnexpectedResultException { + var value = executeGeneric(frame); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + boolean executeBoolean(VirtualFrame frame) throws UnexpectedResultException { + var value = executeGeneric(frame); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } +} + +class ReadArgNode extends Node { + final int argNum; + + ReadArgNode(int argNum) { + this.argNum = argNum; + } + + Object executeGeneric(VirtualFrame frame) { + return frame.getArguments()[argNum]; + } +} + +class ReadArgsNode extends Node { + final int argPos; + + ReadArgsNode(int argPos) { + this.argPos = argPos; + } + + Object executeGeneric(VirtualFrame frame) { + Object[] args = frame.getArguments(); + final var len = args.length - argPos; + var result = new Object[len]; + System.arraycopy(args, argPos, result, 0, len); + return result; + } +} + +class BuiltinRootNode extends RootNode { + private final int numArgs; + @Child private BuiltinNode node; + + public BuiltinRootNode(TruffleLanguage lang, NodeFactory nodeFactory) { + super(lang); + var sig = nodeFactory.getExecutionSignature(); + int numArgs = nodeFactory.getExecutionSignature().size(); + Object[] readArgNodes = new Node[numArgs]; + for (int i=0; i < numArgs; ++i) { + if (sig.get(i).equals(ReadArgsNode.class)) { + assert i == numArgs-1 : "ReadArgsNode must be last argument"; + readArgNodes[i] = new ReadArgsNode(i+1); + numArgs = -1; // variadic + } else { + readArgNodes[i] = new ReadArgNode(i+1); + } + } + node = nodeFactory.createNode(readArgNodes); + if (lang instanceof IMalLanguage) { + node.setLanguage((IMalLanguage)lang); + } + this.numArgs = numArgs; + } + + public int getNumArgs() { + return numArgs; + } + + @Override + public Object execute(VirtualFrame frame) { + return node.executeGeneric(frame); + } + + @Override + public String toString() { + return "#"; + } +} + +/************** MATH *******************/ + +@NodeChild(value="lhs", type=ReadArgNode.class) +@NodeChild(value="rhs", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class AddBuiltin extends BuiltinNode { + + protected AddBuiltin() { super("+"); } + + @Specialization + protected long add(long lhs, long rhs) { + return lhs + rhs; + } +} + +@NodeChild(value="lhs", type=ReadArgNode.class) +@NodeChild(value="rhs", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class SubtractBuiltin extends BuiltinNode { + + protected SubtractBuiltin() { super("-"); } + + @Specialization + protected long subtract(long lhs, long rhs) { + return lhs - rhs; + } + +} + +@NodeChild(value="lhs", type=ReadArgNode.class) +@NodeChild(value="rhs", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class MultiplyBuiltin extends BuiltinNode { + + protected MultiplyBuiltin() { super("*"); } + + @Specialization + protected long multiply(long lhs, long rhs) { + return lhs * rhs; + } +} + +@NodeChild(value="lhs", type=ReadArgNode.class) +@NodeChild(value="rhs", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class DivideBuiltin extends BuiltinNode { + protected DivideBuiltin() { super("/"); } + + @Specialization + protected long divide(long lhs, long rhs) { + return lhs / rhs; + } +} + +/************** STRINGS *******************/ + +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class PrnBuiltin extends BuiltinNode { + protected PrnBuiltin() { super("prn"); } + + @Specialization + @TruffleBoundary + protected Object prn(Object[] args) { + var buf = new StringBuilder(); + if (args.length > 0) { + Printer.prStr(buf, args[0], true); + } + for (int i=1; i < args.length; ++i) { + buf.append(' '); + Printer.prStr(buf, args[i], true); + } + language.out().println(buf.toString()); + return MalNil.NIL; + } +} + +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class PrStrBuiltin extends BuiltinNode { + + protected PrStrBuiltin() { super("pr-str"); } + + @Specialization + @TruffleBoundary + protected String prStr(Object... args) { + var buf = new StringBuilder(); + if (args.length > 0) { + Printer.prStr(buf, args[0], true); + } + for (int i=1; i < args.length; ++i) { + buf.append(' '); + Printer.prStr(buf, args[i], true); + } + return buf.toString(); + } +} + +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class StrBuiltin extends BuiltinNode { + + protected StrBuiltin() { super("str"); } + + @Specialization + @TruffleBoundary + protected String prStr(Object... args) { + var buf = new StringBuilder(); + for (int i=0; i < args.length; ++i) { + Printer.prStr(buf, args[i], false); + } + return buf.toString(); + } +} + +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class PrintlnBuiltin extends BuiltinNode { + + protected PrintlnBuiltin() { super("println"); } + + @Specialization + @TruffleBoundary + protected MalNil println(Object... args) { + var buf = new StringBuilder(); + if (args.length > 0) { + Printer.prStr(buf, args[0], false); + } + for (int i=1; i < args.length; ++i) { + buf.append(' '); + Printer.prStr(buf, args[i], false); + } + // The correct thing is to use the output stream associated with our language context. + // However, since each step is effectively its own language, and we wish + // to share this node among them, we'll just cheat and call System.out directly. + language.out().println(buf.toString()); + return MalNil.NIL; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class ReadStringBuiltin extends BuiltinNode { + + protected ReadStringBuiltin() { super("read-string"); } + + @TruffleBoundary + @Specialization + protected Object readString(String s) { + return Reader.readStr(s); + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class SlurpBuiltin extends BuiltinNode { + + protected SlurpBuiltin() { super("slurp"); } + + @TruffleBoundary + @Specialization + protected String slurp(String path) { + try { + var writer = new StringWriter(); + var reader = new InputStreamReader(new FileInputStream(path)); + try { + reader.transferTo(writer); + return writer.toString(); + } finally { + reader.close(); + } + } catch (FileNotFoundException ex) { + throw new MalException(ex.getMessage()); + } catch (IOException ex) { + throw new MalException(ex.getMessage()); + } + } +} + +/************ COLLECTIONS *****************/ + +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class ListBuiltin extends BuiltinNode { + + protected ListBuiltin() { super("list"); } + + @Specialization + protected MalList list(Object[] args) { + var result = MalList.EMPTY; + for (int i=args.length-1; i >= 0; --i) { + result = result.cons(args[i]); + } + return result; + } +} + +@NodeChild(value = "list", type = ReadArgNode.class) +@GenerateNodeFactory +abstract class IsListBuiltin extends BuiltinNode { + + protected IsListBuiltin() { super("list?"); } + + @Specialization + public boolean isList(MalList list) { + return true; + } + + @Fallback + public boolean isList(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsEmptyBuiltin extends BuiltinNode { + + protected IsEmptyBuiltin() { super("empty?"); } + + @Specialization + protected boolean isEmpty(MalList list) { + return list.head == null; + } + + @Specialization + protected boolean isEmpty(MalVector vector) { + return vector.size() == 0; + } + + @Fallback + protected Object typeError(Object arg) { + throw illegalArgumentException("list", arg); + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class CountBuiltin extends BuiltinNode { + + protected CountBuiltin() { super("count"); } + + @Specialization + protected long count(MalList arg) { + return arg.length; + } + + @Specialization + protected long count(MalVector arg) { + return arg.size(); + } + + @Specialization + protected long count(MalNil arg) { + return 0; + } + + @Fallback + protected Object count(Object arg) { + throw illegalArgumentException("list", arg); + } +} + +@NodeChild(value="obj", type=ReadArgNode.class) +@NodeChild(value="list", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class ConsBuiltin extends BuiltinNode { + + protected ConsBuiltin() { super("cons"); } + + @Specialization + @TruffleBoundary + protected MalList cons(Object obj, MalVector vec) { + return cons(obj, vec.toList()); + } + + @Specialization + @TruffleBoundary + protected MalList cons(Object obj, MalList list) { + return list.cons(obj); + } +} + +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class ConcatBuiltin extends BuiltinNode { + + protected ConcatBuiltin() { super("concat"); } + + private MalList concat1(MalList a, MalList b) { + var elems = new Stack(); + for (Object elem : a) { + elems.push(elem); + } + while (!elems.isEmpty()) { + b = b.cons(elems.pop()); + } + return b; + } + + private MalList concat1(MalVector a, MalList b) { + for (int i=a.size()-1; i >= 0; i--) { + b = b.cons(a.get(i)); + } + return b; + } + + @Specialization + @TruffleBoundary + protected MalList concat(Object... args) { + if (args.length == 0) { + return MalList.EMPTY; + } + Object arg = args[args.length-1]; + MalList result; + if (arg instanceof MalVector) { + result = ((MalVector) arg).toList(); + } else { + result = (MalList)arg; + } + for (int i=args.length-2; i >= 0; --i) { + arg = args[i]; + if (arg instanceof MalVector) { + result = concat1((MalVector)arg, result); + } else { + result = concat1((MalList)arg, result); + } + } + return result; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class VecBuiltin extends BuiltinNode { + + protected VecBuiltin() { super("vec"); } + + @Specialization + protected MalVector vec(MalVector v) { + return v; + } + + @Specialization + protected MalVector vec(MalList l) { + return MalVector.EMPTY.concat(l); + } +} + +@NodeChild(value="list", type=ReadArgNode.class) +@NodeChild(value="n", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class NthBuiltin extends BuiltinNode { + + protected NthBuiltin() { super("nth"); } + + @Specialization + @TruffleBoundary + protected Object nth(MalVector vec, long n) { + if (n >= vec.size()) { + throwInvalidArgument(); + } + return vec.get((int)n); + } + + private void throwInvalidArgument() { + throw new MalException("Out of bounds"); + } + + @Specialization + protected Object nth(MalList list, long n) { + if (n >= list.length) { + throwInvalidArgument(); + } + while (--n >= 0) { + list = list.tail; + } + return list.head; + } +} + +@GenerateNodeFactory +@NodeChild(value="arg", type=ReadArgNode.class) +abstract class FirstBuiltin extends BuiltinNode { + protected FirstBuiltin() { super("first"); } + + @Specialization + protected MalNil first(MalNil nil) { + return MalNil.NIL; + } + + @Specialization + protected Object first(MalVector vec) { + if (vec.size() == 0) + return MalNil.NIL; + return vec.get(0); + } + + @Specialization + protected Object first(MalList list) { + if (list.head == null) { + return MalNil.NIL; + } + return list.head; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class RestBuiltin extends BuiltinNode { + + protected RestBuiltin() { super("rest"); } + + @Specialization + protected MalList rest(MalNil nil) { + return MalList.EMPTY; + } + + @Specialization + @TruffleBoundary + protected MalList rest(MalVector vec) { + return rest(vec.toList()); + } + + @Specialization + protected MalList rest(MalList list) { + if (list.head == null) { + return list; + } + return list.tail; + } +} + +@NodeChild(value="fn", type=ReadArgNode.class) +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class ApplyBuiltin extends BuiltinNode { + @Child private AbstractInvokeNode invokeNode; + + protected ApplyBuiltin() { + super("apply"); + } + + @Override + protected void setLanguage(IMalLanguage language) { + super.setLanguage(language); + this.invokeNode = language.invokeNode(); + } + + @TruffleBoundary + private Object[] getArgs(Object[] args) { + Object[] fnArgs; + if (args.length == 0) { + fnArgs = args; + } else { + Object lastArg = args[args.length-1]; + int lastArgSize; + if (lastArg instanceof MalVector) { + lastArgSize = ((MalVector)lastArg).size(); + } else { + lastArgSize = (int)((MalList)lastArg).length; + } + fnArgs = new Object[args.length + lastArgSize]; + for (int i=0; i < args.length-1; i++) { + fnArgs[i+1] = args[i]; + } + int i = args.length; + assert lastArg instanceof Iterable; + for (Object obj : ((Iterable)lastArg)) { + fnArgs[i++] = obj; + } + } + return fnArgs; + } + + @Specialization + protected Object apply(VirtualFrame frame, MalFunction fn, Object[] args) { + var fnArgs = getArgs(args); + fnArgs[0] = fn.closedOverEnv; + return invokeNode.invoke(fn.callTarget, fnArgs); + } +} + +@NodeChild(value="fn", type=ReadArgNode.class) +@NodeChild(value="col", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class MapBuiltin extends BuiltinNode { + @Child private AbstractInvokeNode invokeNode; + + protected MapBuiltin() { + super("map"); + } + + @Override + protected void setLanguage(IMalLanguage language) { + super.setLanguage(language); + invokeNode = language.invokeNode(); + } + + @TruffleBoundary + private Object doMap(MalFunction fn, Iterable vals) { + var result = new ArrayList(); + Object[] args = new Object[2]; + args[0] = fn.closedOverEnv; + for (Object obj : vals) { + args[1] = obj; + result.add(invokeNode.invoke(fn.callTarget, args)); + } + return MalList.from(result); + } + + @Specialization + protected Object map(MalFunction fn, MalVector vec) { + return doMap(fn, vec); + } + + @Specialization + protected Object map(MalFunction fn, MalList list) { + return doMap(fn, list); + } +} + +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class VectorBuiltin extends BuiltinNode { + + protected VectorBuiltin() { super("vector"); } + + @TruffleBoundary + @Specialization + public MalVector vector(Object[] args) { + MalVector v = MalVector.EMPTY; + for (Object arg : args) { + v = v.append(arg); + } + return v; + } +} + +@NodeChild(value="col", type=ReadArgNode.class) +@NodeChild(value="elems", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class ConjBuiltin extends BuiltinNode { + + protected ConjBuiltin() { super("conj"); } + + @Specialization + protected MalList conj(MalList list, Object[] elems) { + for (int i=0; i < elems.length; i++) { + list = list.cons(elems[i]); + } + return list; + } + + @Specialization + protected MalVector conj(MalVector vec, Object[] elems) { + for (int i=0; i < elems.length; i++) { + vec = vec.append(elems[i]); + } + return vec; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class SeqBuiltin extends BuiltinNode { + + protected SeqBuiltin() { super("seq"); } + + @Specialization + protected Object seq(MalList list) { + if (list.length == 0) { + return MalNil.NIL; + } + return list; + } + @Specialization + protected Object seq(MalVector vec) { + if (vec.size() == 0) { + return MalNil.NIL; + } + return vec.toList(); + } + @Specialization + protected Object seq(String str) { + if (str.isEmpty()) { + return MalNil.NIL; + } + MalList l = MalList.EMPTY; + for (int i=str.length()-1; i >= 0; i--) { + l = l.cons(str.substring(i, i+1)); + } + return l; + } + @Specialization + protected MalNil seq(MalNil nil) { + return nil; + } +} + +/************* Maps ********************/ + +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class HashMapBuiltin extends BuiltinNode { + + protected HashMapBuiltin() { super("hash-map"); } + + @Specialization + @TruffleBoundary + protected MalMap hashMap(Object[] args) { + MalMap map = MalMap.EMPTY; + for (int i=0; i < args.length; i += 2) { + map = map.assoc(args[i], args[i+1]); + } + return map; + } +} + +@NodeChild(value="map", type=ReadArgNode.class) +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class AssocBuiltin extends BuiltinNode { + + protected AssocBuiltin() { super("assoc"); } + + @Specialization + protected Object assoc(MalMap map, Object[] args) { + for (int i=0; i < args.length; i+=2) { + map = map.assoc(args[i], args[i+1]); + } + return map; + } +} + +@NodeChild(value="map", type=ReadArgNode.class) +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class DissocBuiltin extends BuiltinNode { + + protected DissocBuiltin() { super("dissoc"); } + + @Specialization + protected MalMap dissoc(MalMap map, Object[] args) { + for (Object arg : args) { + map = map.dissoc(arg); + } + return map; + } +} + +@NodeChild(value="map", type=ReadArgNode.class) +@NodeChild(value="key", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class GetBuiltin extends BuiltinNode { + + protected GetBuiltin() { super("get"); } + + @Specialization + @TruffleBoundary + protected Object get(MalMap map, Object key) { + return map.map.getOrDefault(key, MalNil.NIL); + } + + @Specialization + protected Object get(MalNil nil, Object key) { + return MalNil.NIL; + } +} + +@NodeChild(value="map", type=ReadArgNode.class) +@NodeChild(value="key", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class ContainsBuiltin extends BuiltinNode { + + protected ContainsBuiltin() { super("contains?"); } + + @Specialization + @TruffleBoundary + protected boolean contains(MalMap map, Object key) { + return map.map.containsKey(key); + } +} + +@NodeChild(value="map", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class KeysBuiltin extends BuiltinNode { + + protected KeysBuiltin() { super("keys"); } + + @Specialization + @TruffleBoundary + protected MalList keys(MalMap map) { + MalList list = MalList.EMPTY; + var iter = map.map.keyIterator(); + while (iter.hasNext()) { + list = list.cons(iter.next()); + } + return list; + } +} + +@NodeChild(value="map", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class ValsBuiltin extends BuiltinNode { + + protected ValsBuiltin() { super("vals"); } + + @Specialization + @TruffleBoundary + protected Object vals(MalMap map) { + MalList list = MalList.EMPTY; + var iter = map.map.valIterator(); + while (iter.hasNext()) { + list = list.cons(iter.next()); + } + return list; + } +} + +/************* COMPARISONS *************/ + +@NodeChild(value="lhs", type=ReadArgNode.class) +@NodeChild(value="rhs", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class EqualsBuiltin extends BuiltinNode { + + protected EqualsBuiltin() { super("="); } + + @Specialization + protected boolean equals(long lhs, long rhs) { + return lhs == rhs; + } + + @Specialization + protected boolean equals(boolean lhs, boolean rhs) { + return lhs == rhs; + } + + @TruffleBoundary + @Specialization + protected boolean equals(String lhs, String rhs) { + return lhs.equals(rhs); + } + + @Specialization + protected boolean equals(MalFunction lhs, MalFunction rhs) { + return lhs == rhs; + } + + @Specialization + protected boolean equals(MalNil lhs, MalNil rhs) { + return lhs == rhs; + } + + @TruffleBoundary + @Specialization + protected boolean equals(MalValue lhs, MalValue rhs) { + if (lhs == null) { + return lhs == rhs; + } else { + return lhs.equals(rhs); + } + } + + @Fallback + protected boolean equals(Object lhs, Object rhs) { + return false; + } +} + +@NodeChild(value="lhs", type=ReadArgNode.class) +@NodeChild(value="rhs", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class GreaterThanBuiltin extends BuiltinNode { + + protected GreaterThanBuiltin() { super(">"); } + + @Specialization + protected boolean greaterThan(long lhs, long rhs) { + return lhs > rhs; + } + + @Specialization + protected Object typeError(Object lhs, long rhs) { + throw illegalArgumentException("integer", lhs); + } + + @Fallback + protected Object typeError(Object lhs, Object rhs) { + throw illegalArgumentException("integer", rhs); + } +} + +@NodeChild(value="lhs", type=ReadArgNode.class) +@NodeChild(value="rhs", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class GreaterThanEqualBuiltin extends BuiltinNode { + + protected GreaterThanEqualBuiltin() { super(">="); } + + @Specialization + protected boolean greaterThanEqual(long lhs, long rhs) { + return lhs >= rhs; + } + + @Specialization + protected Object typeError(Object lhs, long rhs) { + throw illegalArgumentException("integer", lhs); + } + + @Fallback + protected Object typeError(Object lhs, Object rhs) { + throw illegalArgumentException("integer", rhs); + } +} + +@NodeChild(value="lhs", type=ReadArgNode.class) +@NodeChild(value="rhs", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class LessThanBuiltin extends BuiltinNode { + + protected LessThanBuiltin() { super("<"); } + + @Specialization + protected boolean lessThan(long lhs, long rhs) { + return lhs < rhs; + } + + @Specialization + protected Object typeError(Object lhs, long rhs) { + throw illegalArgumentException("integer", lhs); + } + + @Fallback + protected Object typeError(Object lhs, Object rhs) { + throw illegalArgumentException("integer", rhs); + } +} + +@NodeChild(value="lhs", type=ReadArgNode.class) +@NodeChild(value="rhs", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class LessThanEqualBuiltin extends BuiltinNode { + + protected LessThanEqualBuiltin() { super("<="); } + + @Specialization + protected boolean lessThanEqual(long lhs, long rhs) { + return lhs <= rhs; + } + + @Specialization + protected Object typeError(Object lhs, long rhs) { + throw illegalArgumentException("integer", lhs); + } + + @Fallback + protected Object typeError(Object lhs, Object rhs) { + throw illegalArgumentException("integer", rhs); + } +} + +/*************** Atoms ********************/ + +@NodeChild(value="val", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class AtomBuiltin extends BuiltinNode { + protected AtomBuiltin() { super("atom"); } + + @Specialization + protected MalAtom atom(Object val) { + return new MalAtom(val); + } +} + +@NodeChild(value="val", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsAtomBuiltin extends BuiltinNode { + + protected IsAtomBuiltin() { super("atom?"); } + + @Specialization + protected boolean isAtom(Object obj) { + return obj instanceof MalAtom; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class DerefBuiltin extends BuiltinNode { + + protected DerefBuiltin() { super("deref"); } + + @Specialization + protected Object deref(MalAtom atom) { + return atom.deref(); + } +} + +@NodeChild(value="atom", type=ReadArgNode.class) +@NodeChild(value="val", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class ResetBuiltin extends BuiltinNode { + + protected ResetBuiltin() { super("reset!"); } + + @Specialization + protected Object reset(MalAtom atom, Object val) { + atom.reset(val); + return val; + } +} + +@NodeChild(value="atom", type=ReadArgNode.class) +@NodeChild(value="fn", type=ReadArgNode.class) +@NodeChild(value="args", type=ReadArgsNode.class) +@GenerateNodeFactory +abstract class SwapBuiltin extends BuiltinNode { + @Child private AbstractInvokeNode invokeNode; + + protected SwapBuiltin() { + super("swap!"); + } + + @Override + protected void setLanguage(IMalLanguage language) { + super.setLanguage(language); + this.invokeNode = language.invokeNode(); + } + + @Specialization + protected Object swap(MalAtom atom, MalFunction fn, Object... args) { + synchronized (atom) { + Object[] fnArgs = new Object[2+args.length]; + fnArgs[0] = fn.closedOverEnv; + fnArgs[1] = atom.deref(); + for (int i=0; i < args.length; i++) { + fnArgs[i+2] = args[i]; + } + Object newVal = invokeNode.invoke(fn.callTarget, fnArgs); + atom.reset(newVal); + return newVal; + } + } +} + +/*************** Predicates ***************/ + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsNilBuiltin extends BuiltinNode { + protected IsNilBuiltin() { super("nil?"); } + + @Specialization + protected boolean isNil(MalNil nil) { + return true; + } + + @Fallback + protected boolean isNil(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsTrueBuiltin extends BuiltinNode { + protected IsTrueBuiltin() { super("true?"); } + + @Specialization + protected boolean isTrue(boolean b) { + return b == true; + } + + @Fallback + protected boolean isTrue(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsFalseBuiltin extends BuiltinNode { + protected IsFalseBuiltin() { super("false?"); } + + @Specialization + protected boolean isFalse(boolean b) { + return b == false; + } + + @Fallback + protected boolean isFalse(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsSymbolBuiltin extends BuiltinNode { + protected IsSymbolBuiltin() { super("symbol?"); } + + @Specialization + protected boolean isSymbol(MalSymbol sym) { + return true; + } + + @Fallback + protected boolean isSymbol(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsKeywordBuiltin extends BuiltinNode { + + protected IsKeywordBuiltin() { super("keyword?"); } + + @Specialization + protected boolean isKeyword(MalKeyword kw) { + return true; + } + + @Fallback + protected boolean isKeyword(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsVectorBuiltin extends BuiltinNode { + + protected IsVectorBuiltin() { super("vector?"); } + + @Specialization + protected boolean isVector(MalVector vec) { + return true; + } + + @Fallback + protected boolean isVector(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsSequentialBuiltin extends BuiltinNode { + + protected IsSequentialBuiltin() { super("sequential?"); } + + @Specialization + protected Object isSequential(MalList list) { + return true; + } + @Specialization + protected Object isSequential(MalVector vec) { + return true; + } + @Fallback + protected Object isSequential(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsMapBuiltin extends BuiltinNode { + + protected IsMapBuiltin() { super("map?"); } + + @Specialization + protected boolean isMap(MalMap map) { + return true; + } + @Fallback + protected boolean isMap(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsStringBuiltin extends BuiltinNode { + + protected IsStringBuiltin() { super("string?"); } + + @Specialization + protected boolean isString(String val) { + return true; + } + + @Fallback + protected boolean isString(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsNumberBuiltin extends BuiltinNode { + + protected IsNumberBuiltin() { super("number?"); } + + @Specialization + protected boolean isNumber(long n) { + return true; + } + + @Fallback + protected boolean isNumber(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsFnBuiltin extends BuiltinNode { + + protected IsFnBuiltin() { super("fn?"); } + + @Specialization + protected boolean isFn(MalFunction fn) { + return !fn.isMacro; + } + + @Fallback + protected boolean isFn(Object obj) { + return false; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class IsMacroBuiltin extends BuiltinNode { + + protected IsMacroBuiltin() { super("macro?"); } + + @Specialization + protected boolean isMacro(MalFunction fn) { + return fn.isMacro; + } + + @Fallback + protected boolean isMacro(Object obj) { + return false; + } +} + +/*************** Other ********************/ + +@NodeChild(value="ast", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class EvalBuiltin extends BuiltinNode { + + protected EvalBuiltin() { super("eval"); } + + @Specialization + @TruffleBoundary + protected Object eval(Object ast) { + return language.evalForm(ast).call(); + } +} + +@NodeChild(value="obj", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class ThrowBuiltin extends BuiltinNode { + + protected ThrowBuiltin() { super("throw"); } + + @TruffleBoundary + @Specialization + protected Object throwException(String obj) { + throw new MalException(obj); + } + + @TruffleBoundary + @Fallback + protected Object throwException(Object obj) { + throw new MalException(obj); + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class SymbolBuiltin extends BuiltinNode { + + protected SymbolBuiltin() { super("symbol"); } + + @Specialization + protected MalSymbol symbol(String str) { + return MalSymbol.get(str); + } + + @Specialization + protected MalSymbol symbol(MalSymbol sym) { + return sym; + } +} + +@GenerateNodeFactory +@NodeChild(value="arg", type=ReadArgNode.class) +abstract class KeywordBuiltin extends BuiltinNode { + + protected KeywordBuiltin() { super("keyword"); } + + @Specialization + protected MalKeyword keyword(String arg) { + return MalKeyword.get(arg); + } + + @Specialization + protected MalKeyword keyword(MalKeyword kw) { + return kw; + } +} + +@NodeChild(value="prompt", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class ReadlineBuiltin extends BuiltinNode { + + protected ReadlineBuiltin() { super("readline"); } + + @Specialization + @TruffleBoundary + protected Object readline(String prompt) { + language.out().print(prompt); + language.out().flush(); + try { + String s = language.in().readLine(); + return s == null ? MalNil.NIL : s; + } catch (IOException ex) { + throw new MalException(ex.getMessage()); + } + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class MetaBuiltin extends BuiltinNode { + + protected MetaBuiltin() { super("meta"); } + + @Specialization + protected Object meta(MetaHolder arg) { + return arg.getMeta(); + } + + @Fallback + protected Object meta(Object obj) { + return MalNil.NIL; + } +} + +@NodeChild(value="arg", type=ReadArgNode.class) +@NodeChild(value="meta", type=ReadArgNode.class) +@GenerateNodeFactory +abstract class WithMetaBuiltin extends BuiltinNode { + + protected WithMetaBuiltin() { super("with-meta"); } + + @Specialization + protected Object withMeta(MetaHolder holder, Object meta) { + return holder.withMeta(meta); + } +} + +@GenerateNodeFactory +abstract class TimeMsBuiltin extends BuiltinNode { + + protected TimeMsBuiltin() { super("time-ms"); } + + @TruffleBoundary + @Specialization + protected long timeMs() { + return System.nanoTime() / 1000000; + } } \ No newline at end of file diff --git a/impls/java-truffle/src/main/java/truffle/mal/MalEnv.java b/impls/java-truffle/src/main/java/truffle/mal/MalEnv.java index 3678b679bd..111f72ef19 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/MalEnv.java +++ b/impls/java-truffle/src/main/java/truffle/mal/MalEnv.java @@ -1,374 +1,374 @@ -package truffle.mal; - -import java.util.HashMap; -import java.util.Map; - -import com.oracle.truffle.api.Assumption; -import com.oracle.truffle.api.CompilerDirectives; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.interop.InteropLibrary; -import com.oracle.truffle.api.interop.InvalidArrayIndexException; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.library.ExportLibrary; -import com.oracle.truffle.api.library.ExportMessage; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.utilities.UnionAssumption; - -import truffle.mal.LexicalScope.EnvSlot; - -@ExportLibrary(InteropLibrary.class) -class MalEnv implements TruffleObject { - final Class> language; - final MalEnv outer; - // bindings is initialized lazily, to avoid the overhead of creating a new HashMap - // in cases where nothing will be bound (e.g. invoking a function with no arguments) - private Map bindings; - final LexicalScope scope; - final Object[] staticBindings; - private Map cachedResults; - - private MalEnv(Class> language, MalEnv outer, LexicalScope scope, Object[] staticBindings) { - this.language = language; - this.outer = outer; - this.scope = scope; - this.staticBindings = staticBindings; - } - - MalEnv(Class> language) { - this(language, null, null, null); - } - - MalEnv(MalEnv outer) { - this(outer.language, outer, null, null); - } - - MalEnv(Class> language, LexicalScope scope) { - this(language, null, scope, new Object[scope.getStaticBindingCount()]); - } - - MalEnv(MalEnv outer, LexicalScope scope) { - this(outer.language, outer, scope, new Object[scope.getStaticBindingCount()]); - } - - /** - * Dynamic set, for use by def! to bind a symbol that wasn't assigned a slot via a LexicalScope. - * - * @param symbol the symbol to bind - * @param value its new value - */ - @TruffleBoundary - void set(MalSymbol symbol, Object value) { - if (bindings == null) { - bindings = new HashMap<>(); - } - if (!bindings.containsKey(symbol) && scope != null) { - scope.wasDynamicallyBound(symbol); - } - if (cachedResults != null) { - var result = cachedResults.get(symbol); - if (result != null) { - result.notRedefined.invalidate(); - } - } - bindings.put(symbol, value); - } - - /** - * Bind a symbol that was assigned a slot via a LexicalScope. - * @param slot the slot assigned to the symbol - * @param value the symbol's new value - */ - void set(EnvSlot slot, Object value) { - assert slot.height == 0; - staticBindings[slot.slotNum] = value; - } - - /** - * Dynamic get, for when the looked-up symbol has been assigned a slot - * but isn't guaranteed to resolve from that lexical scope, e.g. because a def! - * may have dynamically bound it in an inner scope. - * - * @param symbol - * @param slot - * @return - */ - @TruffleBoundary - Object get(MalSymbol symbol, EnvSlot slot) { - var env = this; - int height = 0; - while (height < slot.height) { - Object result = null; - if (env.bindings != null) { - result = env.bindings.get(symbol); - } - if (result != null) { - return result; - } - env = env.outer; - height++; - } - return env.staticBindings[slot.slotNum]; - } - - /** - * Dynamic get, for when the looked-up symbol has no statically assigned slot. - * - * @param symbol the symbol to look up - * @return its current value, or null if unbound - */ - @TruffleBoundary - Object get(MalSymbol symbol) { - MalEnv env = this; - while (env != null) { - if (env.bindings != null) { - var result = env.bindings.get(symbol); - if (result != null) { - return result; - } - } - env = env.outer; - } - return null; - } - - @TruffleBoundary - CachedResult cachedGet(MalSymbol symbol) { - if (cachedResults == null) { - cachedResults = new HashMap<>(); - } - var result = cachedResults.get(symbol); - if (result == null) { - Object obj = null; - if (bindings != null) { - obj = bindings.get(symbol); - } - if (obj == null && outer != null) { - result = outer.cachedGet(symbol); - } else { - result = new CachedResult(obj); - } - cachedResults.put(symbol, result); - } - return result; - } - - /** - * Static get, for when the looked-up symbol is guaranteed to resolve from a particular lexical scope. - * @param slot - * @return - */ - @ExplodeLoop - Object get(EnvSlot slot) { - MalEnv env = this; - for (int i=0; i < slot.height; i++) { - env = env.outer; - } - return env.staticBindings[slot.slotNum]; - } - - @ExportMessage - boolean hasLanguage() { - return true; - } - - @ExportMessage - Class> getLanguage() { - return language; - } - - @ExportMessage - boolean hasMembers() { - return true; - } - - @ExportMessage - @TruffleBoundary - Object readMember(String member) { - return bindings.get(MalSymbol.get(member)); - } - - @ExportMessage - @TruffleBoundary - boolean isMemberReadable(String member) { - return bindings.containsKey(MalSymbol.get(member)); - } - - @ExportMessage - @TruffleBoundary - Object toDisplayString(boolean allowSideEffects) { - return "#"; - } - - @ExportMessage - @TruffleBoundary - boolean isMemberInsertable(String member) { - return !bindings.containsKey(MalSymbol.get(member)); - } - - @ExportMessage - @TruffleBoundary - boolean isMemberModifiable(String member) { - return bindings.containsKey(MalSymbol.get(member)); - } - - @ExportMessage - @TruffleBoundary - void writeMember(String member, Object value) { - set(MalSymbol.get(member), value); - } - - @ExportMessage - @TruffleBoundary - Object getMembers(boolean includeInternal) { - Object[] names = new Object[bindings.size()]; - int i=0; - for (MalSymbol sym : bindings.keySet()) { - names[i++] = sym.symbol; - } - return new EnvMembersObject(names); - } - - static class CachedResult { - final Object result; - final Assumption notRedefined = Truffle.getRuntime().createAssumption(); - - CachedResult(Object result) { - this.result = result; - } - } -} - -@ExportLibrary(InteropLibrary.class) -final class EnvMembersObject implements TruffleObject { - private final Object[] names; - - EnvMembersObject(Object[] names) { - this.names = names; - } - @ExportMessage - boolean hasArrayElements() { - return true; - } - @ExportMessage - boolean isArrayElementReadable(long index) { - return index >= 0 && index < names.length; - } - @ExportMessage - long getArraySize() { - return names.length; - } - @ExportMessage - Object readArrayElement(long index) throws InvalidArrayIndexException { - if (!isArrayElementReadable(index)) { - CompilerDirectives.transferToInterpreter(); - throw InvalidArrayIndexException.create(index); - } - return names[(int)index]; - } -} - -/** - * A LexicalScope tracks the variables known statically to be in a given lexical scope, and keeps track of - * associated environment slots. - */ -class LexicalScope { - final LexicalScope parent; - final int depth; - final Map slots; - private int staticBindingCount; - final Map notDynamicallyBound; - - LexicalScope() { - this(null); - } - - LexicalScope(LexicalScope parent) { - this.parent = parent; - this.depth = parent == null? 0 : parent.depth+1; - this.slots = new HashMap<>(); - this.staticBindingCount = 0; - this.notDynamicallyBound = new HashMap<>(); - } - - private Assumption getNotDynamicallyBound(MalSymbol symbol) { - var assumption = notDynamicallyBound.get(symbol); - if (assumption == null) { - assumption = Truffle.getRuntime().createAssumption(symbol.symbol+" not dynamically shadowed"); - notDynamicallyBound.put(symbol, assumption); - } - return assumption; - } - - /** - * Allocate a slot for a symbol in this lexical scope, or return the slot already bound to the symbol. - * - * @param symbol - * @return - */ - @TruffleBoundary - public EnvSlot allocateSlot(MalSymbol symbol) { - var slot = new EnvSlot(0, slots.size(), getNotDynamicallyBound(symbol)); - slots.put(symbol, slot); - staticBindingCount++; - return slot; - } - - /** - * If symbols is statically known to be in scope, returns a slot that can be used to look up - * the bound symbol efficiently. Otherwise, returns null; - * - * @param symbol - * @return - */ - @TruffleBoundary - public EnvSlot getSlot(MalEnv env, MalSymbol symbol) { - int height = 0; - var scope = this; - Assumption assumption = getNotDynamicallyBound(symbol); - while (scope != null) { - if (scope.slots.containsKey(symbol)) { - var slot = scope.slots.get(symbol); - if (env.get(slot) != null) { - if (height == 0) { - return slot; - } else { - return new EnvSlot(height, scope.slots.get(symbol).slotNum, assumption); - } - } - } - height++; - scope = scope.parent; - env = env.outer; - if (scope != null) { - assumption = new UnionAssumption(assumption, scope.getNotDynamicallyBound(symbol)); - } - } - return null; - } - - @TruffleBoundary - public void wasDynamicallyBound(MalSymbol sym) { - var assumption = notDynamicallyBound.get(sym); - if (assumption != null) { - assumption.invalidate(); - } - } - - public int getStaticBindingCount() { - return staticBindingCount; - } - - static class EnvSlot { - public final int height; - public final int slotNum; - public final Assumption notDynamicallyBound; - - private EnvSlot(int height, int slotNum, Assumption notDynamicallyBound) { - this.height = height; - this.slotNum = slotNum; - this.notDynamicallyBound = notDynamicallyBound; - } - } +package truffle.mal; + +import java.util.HashMap; +import java.util.Map; + +import com.oracle.truffle.api.Assumption; +import com.oracle.truffle.api.CompilerDirectives; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.interop.InteropLibrary; +import com.oracle.truffle.api.interop.InvalidArrayIndexException; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.library.ExportLibrary; +import com.oracle.truffle.api.library.ExportMessage; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.utilities.UnionAssumption; + +import truffle.mal.LexicalScope.EnvSlot; + +@ExportLibrary(InteropLibrary.class) +class MalEnv implements TruffleObject { + final Class> language; + final MalEnv outer; + // bindings is initialized lazily, to avoid the overhead of creating a new HashMap + // in cases where nothing will be bound (e.g. invoking a function with no arguments) + private Map bindings; + final LexicalScope scope; + final Object[] staticBindings; + private Map cachedResults; + + private MalEnv(Class> language, MalEnv outer, LexicalScope scope, Object[] staticBindings) { + this.language = language; + this.outer = outer; + this.scope = scope; + this.staticBindings = staticBindings; + } + + MalEnv(Class> language) { + this(language, null, null, null); + } + + MalEnv(MalEnv outer) { + this(outer.language, outer, null, null); + } + + MalEnv(Class> language, LexicalScope scope) { + this(language, null, scope, new Object[scope.getStaticBindingCount()]); + } + + MalEnv(MalEnv outer, LexicalScope scope) { + this(outer.language, outer, scope, new Object[scope.getStaticBindingCount()]); + } + + /** + * Dynamic set, for use by def! to bind a symbol that wasn't assigned a slot via a LexicalScope. + * + * @param symbol the symbol to bind + * @param value its new value + */ + @TruffleBoundary + void set(MalSymbol symbol, Object value) { + if (bindings == null) { + bindings = new HashMap<>(); + } + if (!bindings.containsKey(symbol) && scope != null) { + scope.wasDynamicallyBound(symbol); + } + if (cachedResults != null) { + var result = cachedResults.get(symbol); + if (result != null) { + result.notRedefined.invalidate(); + } + } + bindings.put(symbol, value); + } + + /** + * Bind a symbol that was assigned a slot via a LexicalScope. + * @param slot the slot assigned to the symbol + * @param value the symbol's new value + */ + void set(EnvSlot slot, Object value) { + assert slot.height == 0; + staticBindings[slot.slotNum] = value; + } + + /** + * Dynamic get, for when the looked-up symbol has been assigned a slot + * but isn't guaranteed to resolve from that lexical scope, e.g. because a def! + * may have dynamically bound it in an inner scope. + * + * @param symbol + * @param slot + * @return + */ + @TruffleBoundary + Object get(MalSymbol symbol, EnvSlot slot) { + var env = this; + int height = 0; + while (height < slot.height) { + Object result = null; + if (env.bindings != null) { + result = env.bindings.get(symbol); + } + if (result != null) { + return result; + } + env = env.outer; + height++; + } + return env.staticBindings[slot.slotNum]; + } + + /** + * Dynamic get, for when the looked-up symbol has no statically assigned slot. + * + * @param symbol the symbol to look up + * @return its current value, or null if unbound + */ + @TruffleBoundary + Object get(MalSymbol symbol) { + MalEnv env = this; + while (env != null) { + if (env.bindings != null) { + var result = env.bindings.get(symbol); + if (result != null) { + return result; + } + } + env = env.outer; + } + return null; + } + + @TruffleBoundary + CachedResult cachedGet(MalSymbol symbol) { + if (cachedResults == null) { + cachedResults = new HashMap<>(); + } + var result = cachedResults.get(symbol); + if (result == null) { + Object obj = null; + if (bindings != null) { + obj = bindings.get(symbol); + } + if (obj == null && outer != null) { + result = outer.cachedGet(symbol); + } else { + result = new CachedResult(obj); + } + cachedResults.put(symbol, result); + } + return result; + } + + /** + * Static get, for when the looked-up symbol is guaranteed to resolve from a particular lexical scope. + * @param slot + * @return + */ + @ExplodeLoop + Object get(EnvSlot slot) { + MalEnv env = this; + for (int i=0; i < slot.height; i++) { + env = env.outer; + } + return env.staticBindings[slot.slotNum]; + } + + @ExportMessage + boolean hasLanguage() { + return true; + } + + @ExportMessage + Class> getLanguage() { + return language; + } + + @ExportMessage + boolean hasMembers() { + return true; + } + + @ExportMessage + @TruffleBoundary + Object readMember(String member) { + return bindings.get(MalSymbol.get(member)); + } + + @ExportMessage + @TruffleBoundary + boolean isMemberReadable(String member) { + return bindings.containsKey(MalSymbol.get(member)); + } + + @ExportMessage + @TruffleBoundary + Object toDisplayString(boolean allowSideEffects) { + return "#"; + } + + @ExportMessage + @TruffleBoundary + boolean isMemberInsertable(String member) { + return !bindings.containsKey(MalSymbol.get(member)); + } + + @ExportMessage + @TruffleBoundary + boolean isMemberModifiable(String member) { + return bindings.containsKey(MalSymbol.get(member)); + } + + @ExportMessage + @TruffleBoundary + void writeMember(String member, Object value) { + set(MalSymbol.get(member), value); + } + + @ExportMessage + @TruffleBoundary + Object getMembers(boolean includeInternal) { + Object[] names = new Object[bindings.size()]; + int i=0; + for (MalSymbol sym : bindings.keySet()) { + names[i++] = sym.symbol; + } + return new EnvMembersObject(names); + } + + static class CachedResult { + final Object result; + final Assumption notRedefined = Truffle.getRuntime().createAssumption(); + + CachedResult(Object result) { + this.result = result; + } + } +} + +@ExportLibrary(InteropLibrary.class) +final class EnvMembersObject implements TruffleObject { + private final Object[] names; + + EnvMembersObject(Object[] names) { + this.names = names; + } + @ExportMessage + boolean hasArrayElements() { + return true; + } + @ExportMessage + boolean isArrayElementReadable(long index) { + return index >= 0 && index < names.length; + } + @ExportMessage + long getArraySize() { + return names.length; + } + @ExportMessage + Object readArrayElement(long index) throws InvalidArrayIndexException { + if (!isArrayElementReadable(index)) { + CompilerDirectives.transferToInterpreter(); + throw InvalidArrayIndexException.create(index); + } + return names[(int)index]; + } +} + +/** + * A LexicalScope tracks the variables known statically to be in a given lexical scope, and keeps track of + * associated environment slots. + */ +class LexicalScope { + final LexicalScope parent; + final int depth; + final Map slots; + private int staticBindingCount; + final Map notDynamicallyBound; + + LexicalScope() { + this(null); + } + + LexicalScope(LexicalScope parent) { + this.parent = parent; + this.depth = parent == null? 0 : parent.depth+1; + this.slots = new HashMap<>(); + this.staticBindingCount = 0; + this.notDynamicallyBound = new HashMap<>(); + } + + private Assumption getNotDynamicallyBound(MalSymbol symbol) { + var assumption = notDynamicallyBound.get(symbol); + if (assumption == null) { + assumption = Truffle.getRuntime().createAssumption(symbol.symbol+" not dynamically shadowed"); + notDynamicallyBound.put(symbol, assumption); + } + return assumption; + } + + /** + * Allocate a slot for a symbol in this lexical scope, or return the slot already bound to the symbol. + * + * @param symbol + * @return + */ + @TruffleBoundary + public EnvSlot allocateSlot(MalSymbol symbol) { + var slot = new EnvSlot(0, slots.size(), getNotDynamicallyBound(symbol)); + slots.put(symbol, slot); + staticBindingCount++; + return slot; + } + + /** + * If symbols is statically known to be in scope, returns a slot that can be used to look up + * the bound symbol efficiently. Otherwise, returns null; + * + * @param symbol + * @return + */ + @TruffleBoundary + public EnvSlot getSlot(MalEnv env, MalSymbol symbol) { + int height = 0; + var scope = this; + Assumption assumption = getNotDynamicallyBound(symbol); + while (scope != null) { + if (scope.slots.containsKey(symbol)) { + var slot = scope.slots.get(symbol); + if (env.get(slot) != null) { + if (height == 0) { + return slot; + } else { + return new EnvSlot(height, scope.slots.get(symbol).slotNum, assumption); + } + } + } + height++; + scope = scope.parent; + env = env.outer; + if (scope != null) { + assumption = new UnionAssumption(assumption, scope.getNotDynamicallyBound(symbol)); + } + } + return null; + } + + @TruffleBoundary + public void wasDynamicallyBound(MalSymbol sym) { + var assumption = notDynamicallyBound.get(sym); + if (assumption != null) { + assumption.invalidate(); + } + } + + public int getStaticBindingCount() { + return staticBindingCount; + } + + static class EnvSlot { + public final int height; + public final int slotNum; + public final Assumption notDynamicallyBound; + + private EnvSlot(int height, int slotNum, Assumption notDynamicallyBound) { + this.height = height; + this.slotNum = slotNum; + this.notDynamicallyBound = notDynamicallyBound; + } + } } \ No newline at end of file diff --git a/impls/java-truffle/src/main/java/truffle/mal/Printer.java b/impls/java-truffle/src/main/java/truffle/mal/Printer.java index 37056cb3f7..cbd728c268 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/Printer.java +++ b/impls/java-truffle/src/main/java/truffle/mal/Printer.java @@ -1,100 +1,100 @@ -package truffle.mal; - -public class Printer { - - public static String prStr(Object form, boolean printReadably) { - var buf = new StringBuilder(); - prStr(buf, form, printReadably); - return buf.toString(); - } - - public static void prStr(StringBuilder buf, Object form, boolean printReadably) { - if (form instanceof Boolean) { - - buf.append((boolean)form); - - } else if (form instanceof Long) { - - buf.append((long)form); - - } else if (form instanceof String) { - - var s = (String)form; - if (printReadably) { - buf.append('"'); - buf.append(s.replace("\\", "\\\\").replace("\n", "\\n").replace("\"", "\\\"")); - buf.append('"'); - } else { - buf.append(s); - } - - } else if (form instanceof MalSymbol) { - - buf.append(((MalSymbol)form).symbol); - - } else if (form instanceof MalKeyword) { - - buf.append(':'); - buf.append(((MalKeyword)form).keyword); - - } else if (form instanceof MalNil) { - - buf.append("nil"); - - } else if (form instanceof MalList) { - - var list = (MalList)form; - buf.append("("); - MalList l = list; - while (l != null && l.head != null) { - prStr(buf, l.head, printReadably); - l = l.tail; - if (l.head != null) { - buf.append(' '); - } - } - buf.append(")"); - - } else if (form instanceof MalVector) { - - var vector = (MalVector)form; - final int size = vector.size(); - buf.append('['); - for (int i=0; i < size; ++i) { - prStr(buf, vector.get(i), printReadably); - if (i < size-1) { - buf.append(' '); - } - } - buf.append(']'); - - } else if (form instanceof MalMap) { - - var map = (MalMap)form; - int i = 0; - buf.append('{'); - for (var entry : map.map) { - prStr(buf, entry.getKey(), printReadably); - buf.append(' '); - prStr(buf, entry.getValue(), printReadably); - if (++i < map.map.size()) { - buf.append(' '); - } - } - buf.append('}'); - - } else if (form instanceof MalFunction) { - - buf.append("#"); - - } else if (form instanceof MalAtom) { - - buf.append("(atom "); - prStr(buf, ((MalAtom)form).deref(), printReadably); - buf.append(")"); - - } else { - throw new RuntimeException("Not a MAL type: "+form.getClass().getCanonicalName()); - } - } -} +package truffle.mal; + +public class Printer { + + public static String prStr(Object form, boolean printReadably) { + var buf = new StringBuilder(); + prStr(buf, form, printReadably); + return buf.toString(); + } + + public static void prStr(StringBuilder buf, Object form, boolean printReadably) { + if (form instanceof Boolean) { + + buf.append((boolean)form); + + } else if (form instanceof Long) { + + buf.append((long)form); + + } else if (form instanceof String) { + + var s = (String)form; + if (printReadably) { + buf.append('"'); + buf.append(s.replace("\\", "\\\\").replace("\n", "\\n").replace("\"", "\\\"")); + buf.append('"'); + } else { + buf.append(s); + } + + } else if (form instanceof MalSymbol) { + + buf.append(((MalSymbol)form).symbol); + + } else if (form instanceof MalKeyword) { + + buf.append(':'); + buf.append(((MalKeyword)form).keyword); + + } else if (form instanceof MalNil) { + + buf.append("nil"); + + } else if (form instanceof MalList) { + + var list = (MalList)form; + buf.append("("); + MalList l = list; + while (l != null && l.head != null) { + prStr(buf, l.head, printReadably); + l = l.tail; + if (l.head != null) { + buf.append(' '); + } + } + buf.append(")"); + + } else if (form instanceof MalVector) { + + var vector = (MalVector)form; + final int size = vector.size(); + buf.append('['); + for (int i=0; i < size; ++i) { + prStr(buf, vector.get(i), printReadably); + if (i < size-1) { + buf.append(' '); + } + } + buf.append(']'); + + } else if (form instanceof MalMap) { + + var map = (MalMap)form; + int i = 0; + buf.append('{'); + for (var entry : map.map) { + prStr(buf, entry.getKey(), printReadably); + buf.append(' '); + prStr(buf, entry.getValue(), printReadably); + if (++i < map.map.size()) { + buf.append(' '); + } + } + buf.append('}'); + + } else if (form instanceof MalFunction) { + + buf.append("#"); + + } else if (form instanceof MalAtom) { + + buf.append("(atom "); + prStr(buf, ((MalAtom)form).deref(), printReadably); + buf.append(")"); + + } else { + throw new RuntimeException("Not a MAL type: "+form.getClass().getCanonicalName()); + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/Reader.java b/impls/java-truffle/src/main/java/truffle/mal/Reader.java index 0a888c4cf2..5ed5c5a3ec 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/Reader.java +++ b/impls/java-truffle/src/main/java/truffle/mal/Reader.java @@ -1,166 +1,166 @@ -package truffle.mal; - -import java.util.ArrayList; -import java.util.List; -import java.util.regex.Pattern; - -public class Reader { - private static final Pattern TOKEN_PATTERN = Pattern.compile("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)"); - - public static List tokenize(String s) { - var m = TOKEN_PATTERN.matcher(s); - var result = new ArrayList(); - while (m.find()) { - String t = m.group(1); - if (!t.isEmpty()) { - result.add(t); - } - } - return result; - } - - public static Object readStr(String s) { - return new Reader(tokenize(s)).readForm(); - } - - private int i = 0; - private final List tokens; - - private Reader(List tokens) { - this.tokens = tokens; - } - - private boolean hasNext() { - return i < tokens.size(); - } - - private String peek() { - if (!hasNext()) { - throw new MalException("EOF"); - } - return tokens.get(i); - } - - private String next() { - if (!hasNext()) { - throw new MalException("EOF"); - } - return tokens.get(i++); - } - - private Object readForm() { - if (!hasNext()) { - return MalNil.NIL; - } - String t = peek(); - if (t.equals("'")) { - next(); - return MalList.EMPTY.cons(readForm()).cons(MalSymbol.QUOTE); - } else if (t.equals("`")) { - next(); - return MalList.EMPTY.cons(readForm()).cons(MalSymbol.QUASIQUOTE); - } else if (t.equals("@")) { - next(); - return MalList.EMPTY.cons(readForm()).cons(MalSymbol.DEREF); - } else if (t.equals("~")) { - next(); - return MalList.EMPTY.cons(readForm()).cons(MalSymbol.UNQUOTE); - } else if (t.equals("~@")) { - next(); - return MalList.EMPTY.cons(readForm()).cons(MalSymbol.SPLICE_UNQUOTE); - } else if (t.equals("^")) { - next(); - var meta = readForm(); - var obj = readForm(); - return MalList.EMPTY.cons(meta).cons(obj).cons(MalSymbol.get("with-meta")); - } else if (t.equals("(")) { - return readList(); - } else if (t.equals("[")) { - return readVector(); - } else if (t.equals("{")) { - return readMap(); - } else if (t.startsWith(";")) { - // gobble up consecutive comments without consuming stack space - while (t.startsWith(";")) { - next(); - if (!hasNext()) - break; - t = peek(); - } - return readForm(); - } else { - return readAtom(); - } - } - - private MalVector readVector() { - var elements = new ArrayList(); - next(); // consume '[' - while (!peek().equals("]")) { - elements.add(readForm()); - } - next(); // consume ']' - return MalVector.EMPTY.concat(elements); - } - - private MalList readList() { - var elements = new ArrayList(); - next(); // consume '(' - while (!peek().equals(")")) { - elements.add(readForm()); - } - next(); // consume ')' - MalList result = MalList.EMPTY; - var iter = elements.listIterator(elements.size()); - while (iter.hasPrevious()) { - result = result.cons(iter.previous()); - } - return result; - } - - private MalMap readMap() { - MalMap map = MalMap.EMPTY; - next(); // consume '{' - while (!peek().equals("}")) { - map = map.assoc(readForm(), readForm()); - } - next(); // consume '}' - return map; - } - - private Object readAtom() { - String t = next(); - if (t.charAt(0) == '"') { - StringBuilder sb = new StringBuilder(); - int i=1; - for (int j=t.indexOf('\\', i); j != -1; j=t.indexOf('\\', i)) { - sb.append(t.subSequence(i, j)); - switch (t.charAt(j+1)) { - case 'n': sb.append('\n'); break; - case '"': sb.append('"'); break; - case '\\': sb.append('\\'); break; - } - i = j+2; - } - if (i > t.length()-1 || t.charAt(t.length()-1) != '"') { - throw new MalException("EOF"); - } - sb.append(t.substring(i, t.length()-1)); - return sb.toString(); - } else if (t.charAt(0) == ':') { - return MalKeyword.get(t.substring(1)); - } else if (t.charAt(0) >= '0' && t.charAt(0) <= '9') { - return Long.parseLong(t); - } else if (t.length() > 1 && t.charAt(0) == '-' && t.charAt(1) >= '0' && t.charAt(1) <= '9') { - return Long.parseLong(t); - } else if (t.equals("true")) { - return true; - } else if (t.equals("false")) { - return false; - } else if (t.equals("nil")) { - return MalNil.NIL; - } else { - return MalSymbol.get(t); - } - } -} +package truffle.mal; + +import java.util.ArrayList; +import java.util.List; +import java.util.regex.Pattern; + +public class Reader { + private static final Pattern TOKEN_PATTERN = Pattern.compile("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)"); + + public static List tokenize(String s) { + var m = TOKEN_PATTERN.matcher(s); + var result = new ArrayList(); + while (m.find()) { + String t = m.group(1); + if (!t.isEmpty()) { + result.add(t); + } + } + return result; + } + + public static Object readStr(String s) { + return new Reader(tokenize(s)).readForm(); + } + + private int i = 0; + private final List tokens; + + private Reader(List tokens) { + this.tokens = tokens; + } + + private boolean hasNext() { + return i < tokens.size(); + } + + private String peek() { + if (!hasNext()) { + throw new MalException("EOF"); + } + return tokens.get(i); + } + + private String next() { + if (!hasNext()) { + throw new MalException("EOF"); + } + return tokens.get(i++); + } + + private Object readForm() { + if (!hasNext()) { + return MalNil.NIL; + } + String t = peek(); + if (t.equals("'")) { + next(); + return MalList.EMPTY.cons(readForm()).cons(MalSymbol.QUOTE); + } else if (t.equals("`")) { + next(); + return MalList.EMPTY.cons(readForm()).cons(MalSymbol.QUASIQUOTE); + } else if (t.equals("@")) { + next(); + return MalList.EMPTY.cons(readForm()).cons(MalSymbol.DEREF); + } else if (t.equals("~")) { + next(); + return MalList.EMPTY.cons(readForm()).cons(MalSymbol.UNQUOTE); + } else if (t.equals("~@")) { + next(); + return MalList.EMPTY.cons(readForm()).cons(MalSymbol.SPLICE_UNQUOTE); + } else if (t.equals("^")) { + next(); + var meta = readForm(); + var obj = readForm(); + return MalList.EMPTY.cons(meta).cons(obj).cons(MalSymbol.get("with-meta")); + } else if (t.equals("(")) { + return readList(); + } else if (t.equals("[")) { + return readVector(); + } else if (t.equals("{")) { + return readMap(); + } else if (t.startsWith(";")) { + // gobble up consecutive comments without consuming stack space + while (t.startsWith(";")) { + next(); + if (!hasNext()) + break; + t = peek(); + } + return readForm(); + } else { + return readAtom(); + } + } + + private MalVector readVector() { + var elements = new ArrayList(); + next(); // consume '[' + while (!peek().equals("]")) { + elements.add(readForm()); + } + next(); // consume ']' + return MalVector.EMPTY.concat(elements); + } + + private MalList readList() { + var elements = new ArrayList(); + next(); // consume '(' + while (!peek().equals(")")) { + elements.add(readForm()); + } + next(); // consume ')' + MalList result = MalList.EMPTY; + var iter = elements.listIterator(elements.size()); + while (iter.hasPrevious()) { + result = result.cons(iter.previous()); + } + return result; + } + + private MalMap readMap() { + MalMap map = MalMap.EMPTY; + next(); // consume '{' + while (!peek().equals("}")) { + map = map.assoc(readForm(), readForm()); + } + next(); // consume '}' + return map; + } + + private Object readAtom() { + String t = next(); + if (t.charAt(0) == '"') { + StringBuilder sb = new StringBuilder(); + int i=1; + for (int j=t.indexOf('\\', i); j != -1; j=t.indexOf('\\', i)) { + sb.append(t.subSequence(i, j)); + switch (t.charAt(j+1)) { + case 'n': sb.append('\n'); break; + case '"': sb.append('"'); break; + case '\\': sb.append('\\'); break; + } + i = j+2; + } + if (i > t.length()-1 || t.charAt(t.length()-1) != '"') { + throw new MalException("EOF"); + } + sb.append(t.substring(i, t.length()-1)); + return sb.toString(); + } else if (t.charAt(0) == ':') { + return MalKeyword.get(t.substring(1)); + } else if (t.charAt(0) >= '0' && t.charAt(0) <= '9') { + return Long.parseLong(t); + } else if (t.length() > 1 && t.charAt(0) == '-' && t.charAt(1) >= '0' && t.charAt(1) <= '9') { + return Long.parseLong(t); + } else if (t.equals("true")) { + return true; + } else if (t.equals("false")) { + return false; + } else if (t.equals("nil")) { + return MalNil.NIL; + } else { + return MalSymbol.get(t); + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/Types.java b/impls/java-truffle/src/main/java/truffle/mal/Types.java index 11a65c7659..da453c16b8 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/Types.java +++ b/impls/java-truffle/src/main/java/truffle/mal/Types.java @@ -1,555 +1,555 @@ -package truffle.mal; - -import java.util.Iterator; -import java.util.Stack; - -import org.organicdesign.fp.collections.PersistentHashMap; -import org.organicdesign.fp.collections.PersistentVector; - -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.TruffleException; -import com.oracle.truffle.api.interop.InteropLibrary; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.library.ExportLibrary; -import com.oracle.truffle.api.library.ExportMessage; -import com.oracle.truffle.api.nodes.Node; - -public class Types { -} - -interface MetaHolder { - Object getMeta(); - T withMeta(Object meta); -} - -@SuppressWarnings("serial") -class MalException extends RuntimeException implements TruffleException { - final Object obj; - - MalException(String message) { - super(message); - this.obj = message; - } - - MalException(Object obj) { - super(Printer.prStr(obj, true)); - this.obj = obj; - } - - @Override - public Throwable fillInStackTrace() { - return this; - } - - @Override - public Node getLocation() { - return null; - } -} - -abstract class MalValue { - @Override - @TruffleBoundary - public String toString() { - return Printer.prStr(this, true); - } -} - -@ExportLibrary(InteropLibrary.class) -class MalNil extends MalValue implements TruffleObject { - public static final MalNil NIL = new MalNil(); - - private MalNil() {} - - @ExportMessage - Object toDisplayString(boolean allowSideEffects) { - return this.toString(); - } -} - -@ExportLibrary(InteropLibrary.class) -class MalList extends MalValue implements TruffleObject, Iterable, MetaHolder { - public static final MalList EMPTY = new MalList(); - - @TruffleBoundary - public static MalList from(Iterable list) { - var result = EMPTY; - var stack = new Stack(); - list.forEach(stack::add); - while (!stack.isEmpty()) { - result = result.cons(stack.pop()); - } - return result; - } - - private static int computeHash(Object head, MalList tail) { - final int prime = 31; - int result = 1; - result = prime * result + head.hashCode(); - result = prime * result + tail.hashCode(); - return result; - } - - public final Object head; - public final MalList tail; - private final int hash; - // The lazy programmer's way of ensuring constant-time size() calls: waste lots of memory! - public final int length; - public final Object meta; - - @TruffleBoundary - private MalList() { - this.head = null; - this.tail = null; - this.hash = 31; - this.length = 0; - this.meta = MalNil.NIL; - } - - @TruffleBoundary - private MalList(MalList list, Object meta) { - this.head = list.head; - this.tail = list.tail; - this.hash = list.hash; - this.length = list.length; - this.meta = meta; - } - - @TruffleBoundary - private MalList(Object head, MalList tail, Object meta) { - this.head = head; - this.tail = tail; - this.hash = computeHash(head, tail); - this.length = tail.length+1; - this.meta = meta; - } - - public boolean isEmpty() { - return head == null; - } - - @TruffleBoundary - public MalList cons(Object val) { - return new MalList(val, this, this.meta); - } - - @Override - public int hashCode() { - return hash; - } - - @Override - @TruffleBoundary - public boolean equals(Object obj) { - if (this == obj) - return true; - if (obj == null) - return false; - if (obj instanceof MalVector) { - MalVector other = (MalVector)obj; - if (this.length != other.size()) - return false; - int i=0; - MalList list = this; - while (!list.isEmpty()) { - if (!list.head.equals(other.get(i))) { - return false; - } - i++; - list = list.tail; - } - return true; - } - if (this.getClass() != obj.getClass()) - return false; - - MalList other = (MalList) obj; - if (head == null) { - if (other.head != null) - return false; - } else if (!head.equals(other.head)) - return false; - if (tail == null) { - if (other.tail != null) - return false; - } else if (!tail.equals(other.tail)) - return false; - return true; - } - - @ExportMessage - Object toDisplayString(boolean allowSideEffects) { - return this.toString(); - } - - @Override - public Iterator iterator() { - return new MalListIterator(this); - } - - private static class MalListIterator implements Iterator { - private MalList list; - - MalListIterator(MalList list) { - this.list = list; - } - - @Override - public boolean hasNext() { - return !list.equals(MalList.EMPTY); - } - - @Override - public Object next() { - Object obj = list.head; - list = list.tail; - return obj; - } - } - - @Override - public Object getMeta() { - return meta; - } - - @Override - public MalList withMeta(Object meta) { - return new MalList(this, meta); - } -} - -@ExportLibrary(InteropLibrary.class) -class MalVector extends MalValue implements TruffleObject, Iterable, MetaHolder { - public static final MalVector EMPTY = new MalVector(); - - private final PersistentVector vector; - private final Object meta; - - private MalVector() { - vector = PersistentVector.empty(); - meta = MalNil.NIL; - } - - private MalVector(PersistentVector vector, Object meta) { - this.vector = vector; - this.meta = meta; - } - - @TruffleBoundary - public MalVector append(Object obj) { - return new MalVector(vector.append(obj), this.meta); - } - - @TruffleBoundary - public MalVector concat(Object[] objs) { - var v = vector.mutable(); - for (int i=0; i < objs.length; ++i) { - v.append(objs[i]); - } - return new MalVector(v.immutable(), meta); - } - - @TruffleBoundary - public MalVector concat(Iterable objs) { - return new MalVector(vector.concat(objs), meta); - } - - public int size() { - return vector.size(); - } - - public Object get(int i) { - return vector.get(i); - } - - @Override - public int hashCode() { - return vector.hashCode(); - } - - @Override - @TruffleBoundary - public boolean equals(Object obj) { - if (this == obj) - return true; - if (obj == null) - return false; - if (obj instanceof MalList) - return obj.equals(this); - if (getClass() != obj.getClass()) - return false; - MalVector other = (MalVector) obj; - return vector.equals(other.vector); - } - - @Override - public Iterator iterator() { - return vector.iterator(); - } - - @TruffleBoundary - public MalList toList() { - MalList result = MalList.EMPTY; - for (int i=vector.size()-1; i >= 0; i--) { - result = result.cons(vector.get(i)); - } - return result; - } - - @ExportMessage - Object toDisplayString(boolean allowSideEffects) { - return this.toString(); - } - - @Override - public Object getMeta() { - return meta; - } - - @Override - public MalVector withMeta(Object meta) { - return new MalVector(this.vector, meta); - } -} - -@ExportLibrary(InteropLibrary.class) -class MalMap extends MalValue implements TruffleObject, MetaHolder { - public static final MalMap EMPTY = new MalMap(); - - public final PersistentHashMap map; - private final Object meta; - - private MalMap() { - map = PersistentHashMap.EMPTY; - meta = MalNil.NIL; - } - - private MalMap(PersistentHashMap map, Object meta) { - this.map = map; - this.meta = meta; - } - - @TruffleBoundary - public MalMap assoc(Object key, Object val) { - return new MalMap(map.assoc(key, val), meta); - } - - @TruffleBoundary - public MalMap dissoc(Object key) { - return new MalMap(map.without(key), meta); - } - - @TruffleBoundary - public Object get(Object key) { - if (map.containsKey(key)) { - return map.get(key); - } else { - return MalNil.NIL; - } - } - - @TruffleBoundary - @Override - public int hashCode() { - return map.hashCode(); - } - - @TruffleBoundary - @Override - public boolean equals(Object obj) { - if (this == obj) - return true; - if (obj == null) - return false; - if (getClass() != obj.getClass()) - return false; - MalMap other = (MalMap) obj; - return map.equals(other.map); - } - - @ExportMessage - Object toDisplayString(boolean allowSideEffects) { - return this.toString(); - } - - @Override - public Object getMeta() { - return meta; - } - - @Override - public MalMap withMeta(Object meta) { - return new MalMap(map, meta); - } -} - -@ExportLibrary(InteropLibrary.class) -class MalKeyword extends MalValue implements TruffleObject { - public static final MalKeyword INLINE_Q = MalKeyword.get("inline?"); - - public final String keyword; - - public static MalKeyword get(String keyword) { - return new MalKeyword(keyword); - } - - private MalKeyword(String keyword) { - this.keyword = keyword; - } - - @Override - public int hashCode() { - return keyword.hashCode(); - } - - @Override - public boolean equals(Object obj) { - if (obj == null) { - return false; - } - if (!(obj instanceof MalKeyword)) { - return false; - } - return keyword.equals(((MalKeyword)obj).keyword); - } - - @ExportMessage - Object toDisplayString(boolean allowSideEffects) { - return this.toString(); - } -} - -@ExportLibrary(InteropLibrary.class) -class MalSymbol extends MalValue implements TruffleObject { - public static MalSymbol get(String symbol) { - return new MalSymbol(symbol); - } - - public static final MalSymbol LET_STAR = MalSymbol.get("let*"); - public static final MalSymbol DEF_BANG = MalSymbol.get("def!"); - public static final MalSymbol DO = MalSymbol.get("do"); - public static final MalSymbol IF = MalSymbol.get("if"); - public static final MalSymbol FN_STAR = MalSymbol.get("fn*"); - public static final MalSymbol AMPERSAND = MalSymbol.get("&"); - public static final MalSymbol QUOTE = MalSymbol.get("quote"); - public static final MalSymbol QUASIQUOTE = MalSymbol.get("quasiquote"); - public static final MalSymbol UNQUOTE = MalSymbol.get("unquote"); - public static final MalSymbol SPLICE_UNQUOTE = MalSymbol.get("splice-unquote"); - public static final MalSymbol DEFMACRO = MalSymbol.get("defmacro!"); - public static final MalSymbol MACROEXPAND = MalSymbol.get("macroexpand"); - public static final MalSymbol DEREF = MalSymbol.get("deref"); - public static final MalSymbol TRY = MalSymbol.get("try*"); - public static final MalSymbol CATCH = MalSymbol.get("catch*"); - - public final String symbol; - - private MalSymbol(String symbol) { - this.symbol = symbol; - } - - @Override - public int hashCode() { - return symbol.hashCode(); - } - - @Override - public boolean equals(Object obj) { - if (this == obj) - return true; - if (obj == null) - return false; - if (getClass() != obj.getClass()) - return false; - MalSymbol other = (MalSymbol) obj; - if (symbol == null) { - if (other.symbol != null) - return false; - } else if (!symbol.equals(other.symbol)) - return false; - return true; - } - - @ExportMessage - Object toDisplayString(boolean allowSideEffects) { - return this.toString(); - } -} - -@ExportLibrary(InteropLibrary.class) -class MalFunction extends MalValue implements TruffleObject, MetaHolder { - final RootCallTarget callTarget; - final MalEnv closedOverEnv; - final int numArgs; - final boolean isMacro; - final Object meta; - final boolean canBeTailCalled; - - MalFunction(RootCallTarget callTarget, MalEnv closedOverEnv, int numArgs, boolean canBeTailCalled) { - this.callTarget = callTarget; - this.closedOverEnv = closedOverEnv; - this.numArgs = numArgs; - this.isMacro = false; - this.meta = MalNil.NIL; - this.canBeTailCalled = canBeTailCalled; - } - - MalFunction(RootCallTarget callTarget, MalEnv closedOverEnv, int numArgs) { - this(callTarget, closedOverEnv, numArgs, true); - } - - MalFunction(MalFunction f, boolean isMacro) { - this(f, f.meta, isMacro, true); - } - - MalFunction(MalFunction f, Object meta, boolean isMacro) { - this(f, meta, isMacro, true); - } - - MalFunction(MalFunction f, Object meta, boolean isMacro, boolean canBeTailCalled) { - this.callTarget = f.callTarget; - this.closedOverEnv = f.closedOverEnv; - this.numArgs = f.numArgs; - this.isMacro = isMacro; - this.meta = meta; - this.canBeTailCalled = canBeTailCalled; - } - - @ExportMessage - Object toDisplayString(boolean allowSideEffects) { - return this.toString(); - } - - @Override - public Object getMeta() { - return meta; - } - - @Override - public MalFunction withMeta(Object meta) { - return new MalFunction(this, meta, this.isMacro); - } -} - -@ExportLibrary(InteropLibrary.class) -class MalAtom extends MalValue implements TruffleObject { - private Object value; - - public MalAtom(Object initialValue) { - this.value = initialValue; - } - - public Object deref() { - return value; - } - - public Object reset(Object newValue) { - this.value = newValue; - return newValue; - } - - @ExportMessage - Object toDisplayString(boolean allowSideEffects) { - return this.toString(); - } +package truffle.mal; + +import java.util.Iterator; +import java.util.Stack; + +import org.organicdesign.fp.collections.PersistentHashMap; +import org.organicdesign.fp.collections.PersistentVector; + +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.TruffleException; +import com.oracle.truffle.api.interop.InteropLibrary; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.library.ExportLibrary; +import com.oracle.truffle.api.library.ExportMessage; +import com.oracle.truffle.api.nodes.Node; + +public class Types { +} + +interface MetaHolder { + Object getMeta(); + T withMeta(Object meta); +} + +@SuppressWarnings("serial") +class MalException extends RuntimeException implements TruffleException { + final Object obj; + + MalException(String message) { + super(message); + this.obj = message; + } + + MalException(Object obj) { + super(Printer.prStr(obj, true)); + this.obj = obj; + } + + @Override + public Throwable fillInStackTrace() { + return this; + } + + @Override + public Node getLocation() { + return null; + } +} + +abstract class MalValue { + @Override + @TruffleBoundary + public String toString() { + return Printer.prStr(this, true); + } +} + +@ExportLibrary(InteropLibrary.class) +class MalNil extends MalValue implements TruffleObject { + public static final MalNil NIL = new MalNil(); + + private MalNil() {} + + @ExportMessage + Object toDisplayString(boolean allowSideEffects) { + return this.toString(); + } +} + +@ExportLibrary(InteropLibrary.class) +class MalList extends MalValue implements TruffleObject, Iterable, MetaHolder { + public static final MalList EMPTY = new MalList(); + + @TruffleBoundary + public static MalList from(Iterable list) { + var result = EMPTY; + var stack = new Stack(); + list.forEach(stack::add); + while (!stack.isEmpty()) { + result = result.cons(stack.pop()); + } + return result; + } + + private static int computeHash(Object head, MalList tail) { + final int prime = 31; + int result = 1; + result = prime * result + head.hashCode(); + result = prime * result + tail.hashCode(); + return result; + } + + public final Object head; + public final MalList tail; + private final int hash; + // The lazy programmer's way of ensuring constant-time size() calls: waste lots of memory! + public final int length; + public final Object meta; + + @TruffleBoundary + private MalList() { + this.head = null; + this.tail = null; + this.hash = 31; + this.length = 0; + this.meta = MalNil.NIL; + } + + @TruffleBoundary + private MalList(MalList list, Object meta) { + this.head = list.head; + this.tail = list.tail; + this.hash = list.hash; + this.length = list.length; + this.meta = meta; + } + + @TruffleBoundary + private MalList(Object head, MalList tail, Object meta) { + this.head = head; + this.tail = tail; + this.hash = computeHash(head, tail); + this.length = tail.length+1; + this.meta = meta; + } + + public boolean isEmpty() { + return head == null; + } + + @TruffleBoundary + public MalList cons(Object val) { + return new MalList(val, this, this.meta); + } + + @Override + public int hashCode() { + return hash; + } + + @Override + @TruffleBoundary + public boolean equals(Object obj) { + if (this == obj) + return true; + if (obj == null) + return false; + if (obj instanceof MalVector) { + MalVector other = (MalVector)obj; + if (this.length != other.size()) + return false; + int i=0; + MalList list = this; + while (!list.isEmpty()) { + if (!list.head.equals(other.get(i))) { + return false; + } + i++; + list = list.tail; + } + return true; + } + if (this.getClass() != obj.getClass()) + return false; + + MalList other = (MalList) obj; + if (head == null) { + if (other.head != null) + return false; + } else if (!head.equals(other.head)) + return false; + if (tail == null) { + if (other.tail != null) + return false; + } else if (!tail.equals(other.tail)) + return false; + return true; + } + + @ExportMessage + Object toDisplayString(boolean allowSideEffects) { + return this.toString(); + } + + @Override + public Iterator iterator() { + return new MalListIterator(this); + } + + private static class MalListIterator implements Iterator { + private MalList list; + + MalListIterator(MalList list) { + this.list = list; + } + + @Override + public boolean hasNext() { + return !list.equals(MalList.EMPTY); + } + + @Override + public Object next() { + Object obj = list.head; + list = list.tail; + return obj; + } + } + + @Override + public Object getMeta() { + return meta; + } + + @Override + public MalList withMeta(Object meta) { + return new MalList(this, meta); + } +} + +@ExportLibrary(InteropLibrary.class) +class MalVector extends MalValue implements TruffleObject, Iterable, MetaHolder { + public static final MalVector EMPTY = new MalVector(); + + private final PersistentVector vector; + private final Object meta; + + private MalVector() { + vector = PersistentVector.empty(); + meta = MalNil.NIL; + } + + private MalVector(PersistentVector vector, Object meta) { + this.vector = vector; + this.meta = meta; + } + + @TruffleBoundary + public MalVector append(Object obj) { + return new MalVector(vector.append(obj), this.meta); + } + + @TruffleBoundary + public MalVector concat(Object[] objs) { + var v = vector.mutable(); + for (int i=0; i < objs.length; ++i) { + v.append(objs[i]); + } + return new MalVector(v.immutable(), meta); + } + + @TruffleBoundary + public MalVector concat(Iterable objs) { + return new MalVector(vector.concat(objs), meta); + } + + public int size() { + return vector.size(); + } + + public Object get(int i) { + return vector.get(i); + } + + @Override + public int hashCode() { + return vector.hashCode(); + } + + @Override + @TruffleBoundary + public boolean equals(Object obj) { + if (this == obj) + return true; + if (obj == null) + return false; + if (obj instanceof MalList) + return obj.equals(this); + if (getClass() != obj.getClass()) + return false; + MalVector other = (MalVector) obj; + return vector.equals(other.vector); + } + + @Override + public Iterator iterator() { + return vector.iterator(); + } + + @TruffleBoundary + public MalList toList() { + MalList result = MalList.EMPTY; + for (int i=vector.size()-1; i >= 0; i--) { + result = result.cons(vector.get(i)); + } + return result; + } + + @ExportMessage + Object toDisplayString(boolean allowSideEffects) { + return this.toString(); + } + + @Override + public Object getMeta() { + return meta; + } + + @Override + public MalVector withMeta(Object meta) { + return new MalVector(this.vector, meta); + } +} + +@ExportLibrary(InteropLibrary.class) +class MalMap extends MalValue implements TruffleObject, MetaHolder { + public static final MalMap EMPTY = new MalMap(); + + public final PersistentHashMap map; + private final Object meta; + + private MalMap() { + map = PersistentHashMap.EMPTY; + meta = MalNil.NIL; + } + + private MalMap(PersistentHashMap map, Object meta) { + this.map = map; + this.meta = meta; + } + + @TruffleBoundary + public MalMap assoc(Object key, Object val) { + return new MalMap(map.assoc(key, val), meta); + } + + @TruffleBoundary + public MalMap dissoc(Object key) { + return new MalMap(map.without(key), meta); + } + + @TruffleBoundary + public Object get(Object key) { + if (map.containsKey(key)) { + return map.get(key); + } else { + return MalNil.NIL; + } + } + + @TruffleBoundary + @Override + public int hashCode() { + return map.hashCode(); + } + + @TruffleBoundary + @Override + public boolean equals(Object obj) { + if (this == obj) + return true; + if (obj == null) + return false; + if (getClass() != obj.getClass()) + return false; + MalMap other = (MalMap) obj; + return map.equals(other.map); + } + + @ExportMessage + Object toDisplayString(boolean allowSideEffects) { + return this.toString(); + } + + @Override + public Object getMeta() { + return meta; + } + + @Override + public MalMap withMeta(Object meta) { + return new MalMap(map, meta); + } +} + +@ExportLibrary(InteropLibrary.class) +class MalKeyword extends MalValue implements TruffleObject { + public static final MalKeyword INLINE_Q = MalKeyword.get("inline?"); + + public final String keyword; + + public static MalKeyword get(String keyword) { + return new MalKeyword(keyword); + } + + private MalKeyword(String keyword) { + this.keyword = keyword; + } + + @Override + public int hashCode() { + return keyword.hashCode(); + } + + @Override + public boolean equals(Object obj) { + if (obj == null) { + return false; + } + if (!(obj instanceof MalKeyword)) { + return false; + } + return keyword.equals(((MalKeyword)obj).keyword); + } + + @ExportMessage + Object toDisplayString(boolean allowSideEffects) { + return this.toString(); + } +} + +@ExportLibrary(InteropLibrary.class) +class MalSymbol extends MalValue implements TruffleObject { + public static MalSymbol get(String symbol) { + return new MalSymbol(symbol); + } + + public static final MalSymbol LET_STAR = MalSymbol.get("let*"); + public static final MalSymbol DEF_BANG = MalSymbol.get("def!"); + public static final MalSymbol DO = MalSymbol.get("do"); + public static final MalSymbol IF = MalSymbol.get("if"); + public static final MalSymbol FN_STAR = MalSymbol.get("fn*"); + public static final MalSymbol AMPERSAND = MalSymbol.get("&"); + public static final MalSymbol QUOTE = MalSymbol.get("quote"); + public static final MalSymbol QUASIQUOTE = MalSymbol.get("quasiquote"); + public static final MalSymbol UNQUOTE = MalSymbol.get("unquote"); + public static final MalSymbol SPLICE_UNQUOTE = MalSymbol.get("splice-unquote"); + public static final MalSymbol DEFMACRO = MalSymbol.get("defmacro!"); + public static final MalSymbol MACROEXPAND = MalSymbol.get("macroexpand"); + public static final MalSymbol DEREF = MalSymbol.get("deref"); + public static final MalSymbol TRY = MalSymbol.get("try*"); + public static final MalSymbol CATCH = MalSymbol.get("catch*"); + + public final String symbol; + + private MalSymbol(String symbol) { + this.symbol = symbol; + } + + @Override + public int hashCode() { + return symbol.hashCode(); + } + + @Override + public boolean equals(Object obj) { + if (this == obj) + return true; + if (obj == null) + return false; + if (getClass() != obj.getClass()) + return false; + MalSymbol other = (MalSymbol) obj; + if (symbol == null) { + if (other.symbol != null) + return false; + } else if (!symbol.equals(other.symbol)) + return false; + return true; + } + + @ExportMessage + Object toDisplayString(boolean allowSideEffects) { + return this.toString(); + } +} + +@ExportLibrary(InteropLibrary.class) +class MalFunction extends MalValue implements TruffleObject, MetaHolder { + final RootCallTarget callTarget; + final MalEnv closedOverEnv; + final int numArgs; + final boolean isMacro; + final Object meta; + final boolean canBeTailCalled; + + MalFunction(RootCallTarget callTarget, MalEnv closedOverEnv, int numArgs, boolean canBeTailCalled) { + this.callTarget = callTarget; + this.closedOverEnv = closedOverEnv; + this.numArgs = numArgs; + this.isMacro = false; + this.meta = MalNil.NIL; + this.canBeTailCalled = canBeTailCalled; + } + + MalFunction(RootCallTarget callTarget, MalEnv closedOverEnv, int numArgs) { + this(callTarget, closedOverEnv, numArgs, true); + } + + MalFunction(MalFunction f, boolean isMacro) { + this(f, f.meta, isMacro, true); + } + + MalFunction(MalFunction f, Object meta, boolean isMacro) { + this(f, meta, isMacro, true); + } + + MalFunction(MalFunction f, Object meta, boolean isMacro, boolean canBeTailCalled) { + this.callTarget = f.callTarget; + this.closedOverEnv = f.closedOverEnv; + this.numArgs = f.numArgs; + this.isMacro = isMacro; + this.meta = meta; + this.canBeTailCalled = canBeTailCalled; + } + + @ExportMessage + Object toDisplayString(boolean allowSideEffects) { + return this.toString(); + } + + @Override + public Object getMeta() { + return meta; + } + + @Override + public MalFunction withMeta(Object meta) { + return new MalFunction(this, meta, this.isMacro); + } +} + +@ExportLibrary(InteropLibrary.class) +class MalAtom extends MalValue implements TruffleObject { + private Object value; + + public MalAtom(Object initialValue) { + this.value = initialValue; + } + + public Object deref() { + return value; + } + + public Object reset(Object newValue) { + this.value = newValue; + return newValue; + } + + @ExportMessage + Object toDisplayString(boolean allowSideEffects) { + return this.toString(); + } } \ No newline at end of file diff --git a/impls/java-truffle/src/main/java/truffle/mal/step1_read_print.java b/impls/java-truffle/src/main/java/truffle/mal/step1_read_print.java index edb179bd66..bd783896ad 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/step1_read_print.java +++ b/impls/java-truffle/src/main/java/truffle/mal/step1_read_print.java @@ -1,26 +1,26 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; - -public class step1_read_print { - - public static void main(String[] args) throws IOException { - boolean done = false; - var reader = new BufferedReader(new InputStreamReader(System.in)); - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - System.out.println(Printer.prStr(Reader.readStr(s), true)); - } catch (MalException ex) { - System.out.println(ex.getMessage()); - } - } - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; + +public class step1_read_print { + + public static void main(String[] args) throws IOException { + boolean done = false; + var reader = new BufferedReader(new InputStreamReader(System.in)); + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + System.out.println(Printer.prStr(Reader.readStr(s), true)); + } catch (MalException ex) { + System.out.println(ex.getMessage()); + } + } + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/step2_eval.java b/impls/java-truffle/src/main/java/truffle/mal/step2_eval.java index 5f9068af94..8ce8d72d01 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/step2_eval.java +++ b/impls/java-truffle/src/main/java/truffle/mal/step2_eval.java @@ -1,258 +1,258 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.util.HashMap; -import java.util.Map; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class step2_eval { - static final String LANGUAGE_ID = "mal_step2"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - var context = Context.create(LANGUAGE_ID); - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - System.out.println(val.toString()); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - static Map replEnv = new HashMap<>(); - static { - replEnv.put(MalSymbol.get("+"), new BuiltinFn(args -> { return (long)args[0]+(long)args[1]; })); - replEnv.put(MalSymbol.get("-"), new BuiltinFn(args -> { return (long)args[0]-(long)args[1]; })); - replEnv.put(MalSymbol.get("*"), new BuiltinFn(args -> { return (long)args[0]*(long)args[1]; })); - replEnv.put(MalSymbol.get("/"), new BuiltinFn(args -> { return (long)args[0]/(long)args[1]; })); - }; - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame); - - public long executeLong(VirtualFrame frame) throws UnexpectedResultException { - var value = executeGeneric(frame); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame) throws UnexpectedResultException { - var value = executeGeneric(frame); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static MalNode formToNode(Object form) { - if (form instanceof MalSymbol) { - - return new LookupNode((MalSymbol)form); - - } else if (form instanceof MalVector) { - - return new VectorNode((MalVector)form); - - } else if (form instanceof MalMap) { - - return new MapNode((MalMap)form); - - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - - return new ApplyNode((MalList)form); - - } else { - - return new LiteralNode(form); - - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(vector.get(i)); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame) { - var elements = new Object[elementNodes.length]; - for (int i=0; i < elementNodes.length; i++) { - elements[i] = elementNodes[i].executeGeneric(frame); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(entry.getKey()); - nodes[i++] = formToNode(entry.getValue()); - } - } - @Override - public Object executeGeneric(VirtualFrame frame) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame), nodes[i+1].executeGeneric(frame)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @TruffleBoundary - private Object lookup() { - var result = replEnv.get(symbol); - if (result == null) { - throw new MalException(symbol+" not found"); - } - return result; - } - - @Override - public Object executeGeneric(VirtualFrame frame) { - return lookup(); - } - } - - static class ApplyNode extends MalNode { - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - - ApplyNode(MalList list) { - super(list); - fnNode = formToNode(list.head); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(list.head); - list = list.tail; - } - } - - @Override - public Object executeGeneric(VirtualFrame frame) { - var fn = (BuiltinFn)fnNode.executeGeneric(frame); - var args = new Object[argNodes.length]; - for (int i=0; i < args.length; i++) { - args[i] = argNodes[i].executeGeneric(frame); - } - return fn.fn.apply(args); - } - } - - static class MalRootNode extends RootNode { - final Object form; - @Child MalNode body; - - MalRootNode(TruffleLanguage language, Object form) { - super(language, new FrameDescriptor()); - this.form = form; - this.body = formToNode(form); - } - - @Override - public Object execute(VirtualFrame frame) { - return body.executeGeneric(frame); - } - } - - public final static class MalContext { - - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - var root = new MalRootNode(this, Reader.readStr(s)); - return Truffle.getRuntime().createCallTarget(root); - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.util.HashMap; +import java.util.Map; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class step2_eval { + static final String LANGUAGE_ID = "mal_step2"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + var context = Context.create(LANGUAGE_ID); + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + System.out.println(val.toString()); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + static Map replEnv = new HashMap<>(); + static { + replEnv.put(MalSymbol.get("+"), new BuiltinFn(args -> { return (long)args[0]+(long)args[1]; })); + replEnv.put(MalSymbol.get("-"), new BuiltinFn(args -> { return (long)args[0]-(long)args[1]; })); + replEnv.put(MalSymbol.get("*"), new BuiltinFn(args -> { return (long)args[0]*(long)args[1]; })); + replEnv.put(MalSymbol.get("/"), new BuiltinFn(args -> { return (long)args[0]/(long)args[1]; })); + }; + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame); + + public long executeLong(VirtualFrame frame) throws UnexpectedResultException { + var value = executeGeneric(frame); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame) throws UnexpectedResultException { + var value = executeGeneric(frame); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static MalNode formToNode(Object form) { + if (form instanceof MalSymbol) { + + return new LookupNode((MalSymbol)form); + + } else if (form instanceof MalVector) { + + return new VectorNode((MalVector)form); + + } else if (form instanceof MalMap) { + + return new MapNode((MalMap)form); + + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + + return new ApplyNode((MalList)form); + + } else { + + return new LiteralNode(form); + + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(vector.get(i)); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame) { + var elements = new Object[elementNodes.length]; + for (int i=0; i < elementNodes.length; i++) { + elements[i] = elementNodes[i].executeGeneric(frame); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(entry.getKey()); + nodes[i++] = formToNode(entry.getValue()); + } + } + @Override + public Object executeGeneric(VirtualFrame frame) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame), nodes[i+1].executeGeneric(frame)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @TruffleBoundary + private Object lookup() { + var result = replEnv.get(symbol); + if (result == null) { + throw new MalException(symbol+" not found"); + } + return result; + } + + @Override + public Object executeGeneric(VirtualFrame frame) { + return lookup(); + } + } + + static class ApplyNode extends MalNode { + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + + ApplyNode(MalList list) { + super(list); + fnNode = formToNode(list.head); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(list.head); + list = list.tail; + } + } + + @Override + public Object executeGeneric(VirtualFrame frame) { + var fn = (BuiltinFn)fnNode.executeGeneric(frame); + var args = new Object[argNodes.length]; + for (int i=0; i < args.length; i++) { + args[i] = argNodes[i].executeGeneric(frame); + } + return fn.fn.apply(args); + } + } + + static class MalRootNode extends RootNode { + final Object form; + @Child MalNode body; + + MalRootNode(TruffleLanguage language, Object form) { + super(language, new FrameDescriptor()); + this.form = form; + this.body = formToNode(form); + } + + @Override + public Object execute(VirtualFrame frame) { + return body.executeGeneric(frame); + } + } + + public final static class MalContext { + + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + var root = new MalRootNode(this, Reader.readStr(s)); + return Truffle.getRuntime().createCallTarget(root); + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/step3_env.java b/impls/java-truffle/src/main/java/truffle/mal/step3_env.java index 913cff7733..e2865b883f 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/step3_env.java +++ b/impls/java-truffle/src/main/java/truffle/mal/step3_env.java @@ -1,307 +1,307 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.util.ArrayList; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class step3_env { - static final String LANGUAGE_ID = "mal_step3"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - var context = Context.create(LANGUAGE_ID); - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - System.out.println(val.toString()); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static MalNode formToNode(Object form) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form); - } else if (form instanceof MalVector) { - return new VectorNode((MalVector)form); - } else if (form instanceof MalMap) { - return new MapNode((MalMap)form); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head)) { - return new DefNode(list); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(list); - } else { - return new ApplyNode(list); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(vector.get(i)); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(entry.getKey()); - nodes[i++] = formToNode(entry.getValue()); - } - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = env.get(symbol); - if (result == null) { - throw new MalException(symbol+" not found"); - } - return result; - } - } - - static class ApplyNode extends MalNode { - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - - ApplyNode(MalList list) { - super(list); - fnNode = formToNode(list.head); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(list.head); - list = list.tail; - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (BuiltinFn)fnNode.executeGeneric(frame, env); - var args = new Object[argNodes.length]; - for (int i=0; i < args.length; i++) { - args[i] = argNodes[i].executeGeneric(frame, env); - } - return fn.fn.apply(args); - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - DefNode(MalList list) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.valueNode = formToNode(list.tail.tail.head); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - env.set(symbol, value); - return value; - } - } - - static class LetBindingNode extends Node { - private final MalSymbol symbol; - @Child private MalNode valueNode; - LetBindingNode(MalSymbol symbol, Object valueForm) { - this.symbol = symbol; - this.valueNode = formToNode(valueForm); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(symbol, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalList form) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode((MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); - } - bodyNode = formToNode(form.tail.tail.head); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - static class MalRootNode extends RootNode { - final Object form; - @Child MalNode body; - - MalRootNode(TruffleLanguage language, Object form) { - super(language, new FrameDescriptor()); - this.form = form; - this.body = formToNode(form); - } - - @Override - public Object execute(VirtualFrame frame) { - var ctx = lookupContextReference(MalLanguage.class).get(); - return body.executeGeneric(frame, ctx.globalEnv); - } - } - - final static class MalContext { - final MalEnv globalEnv = new MalEnv(MalLanguage.class); - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage { - @Override - protected MalContext createContext(Env env) { - var ctx = new MalContext(); - ctx.globalEnv.set(MalSymbol.get("+"), new BuiltinFn(args -> { return (long)args[0]+(long)args[1]; })); - ctx.globalEnv.set(MalSymbol.get("-"), new BuiltinFn(args -> { return (long)args[0]-(long)args[1]; })); - ctx.globalEnv.set(MalSymbol.get("*"), new BuiltinFn(args -> { return (long)args[0]*(long)args[1]; })); - ctx.globalEnv.set(MalSymbol.get("/"), new BuiltinFn(args -> { return (long)args[0]/(long)args[1]; })); - return ctx; - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - var root = new MalRootNode(this, Reader.readStr(s)); - return Truffle.getRuntime().createCallTarget(root); - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.util.ArrayList; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class step3_env { + static final String LANGUAGE_ID = "mal_step3"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + var context = Context.create(LANGUAGE_ID); + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + System.out.println(val.toString()); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static MalNode formToNode(Object form) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form); + } else if (form instanceof MalVector) { + return new VectorNode((MalVector)form); + } else if (form instanceof MalMap) { + return new MapNode((MalMap)form); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head)) { + return new DefNode(list); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(list); + } else { + return new ApplyNode(list); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(vector.get(i)); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(entry.getKey()); + nodes[i++] = formToNode(entry.getValue()); + } + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = env.get(symbol); + if (result == null) { + throw new MalException(symbol+" not found"); + } + return result; + } + } + + static class ApplyNode extends MalNode { + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + + ApplyNode(MalList list) { + super(list); + fnNode = formToNode(list.head); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(list.head); + list = list.tail; + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (BuiltinFn)fnNode.executeGeneric(frame, env); + var args = new Object[argNodes.length]; + for (int i=0; i < args.length; i++) { + args[i] = argNodes[i].executeGeneric(frame, env); + } + return fn.fn.apply(args); + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + DefNode(MalList list) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.valueNode = formToNode(list.tail.tail.head); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + env.set(symbol, value); + return value; + } + } + + static class LetBindingNode extends Node { + private final MalSymbol symbol; + @Child private MalNode valueNode; + LetBindingNode(MalSymbol symbol, Object valueForm) { + this.symbol = symbol; + this.valueNode = formToNode(valueForm); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(symbol, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalList form) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode((MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); + } + bodyNode = formToNode(form.tail.tail.head); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + static class MalRootNode extends RootNode { + final Object form; + @Child MalNode body; + + MalRootNode(TruffleLanguage language, Object form) { + super(language, new FrameDescriptor()); + this.form = form; + this.body = formToNode(form); + } + + @Override + public Object execute(VirtualFrame frame) { + var ctx = lookupContextReference(MalLanguage.class).get(); + return body.executeGeneric(frame, ctx.globalEnv); + } + } + + final static class MalContext { + final MalEnv globalEnv = new MalEnv(MalLanguage.class); + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage { + @Override + protected MalContext createContext(Env env) { + var ctx = new MalContext(); + ctx.globalEnv.set(MalSymbol.get("+"), new BuiltinFn(args -> { return (long)args[0]+(long)args[1]; })); + ctx.globalEnv.set(MalSymbol.get("-"), new BuiltinFn(args -> { return (long)args[0]-(long)args[1]; })); + ctx.globalEnv.set(MalSymbol.get("*"), new BuiltinFn(args -> { return (long)args[0]*(long)args[1]; })); + ctx.globalEnv.set(MalSymbol.get("/"), new BuiltinFn(args -> { return (long)args[0]/(long)args[1]; })); + return ctx; + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + var root = new MalRootNode(this, Reader.readStr(s)); + return Truffle.getRuntime().createCallTarget(root); + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/step4_if_fn_do.java b/impls/java-truffle/src/main/java/truffle/mal/step4_if_fn_do.java index 3909f26a22..5a99658372 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/step4_if_fn_do.java +++ b/impls/java-truffle/src/main/java/truffle/mal/step4_if_fn_do.java @@ -1,532 +1,532 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class step4_if_fn_do { - static final String LANGUAGE_ID = "mal_step4"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static MalNode formToNode(MalLanguage language, Object form) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head)) { - return new DefNode(language, list); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list); - } else { - return new ApplyNode(language, list); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i)); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey()); - nodes[i++] = formToNode(language, entry.getValue()); - } - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = env.get(symbol); - if (result == null) { - throw new MalException(symbol+" not found"); - } - return result; - } - } - - static class InvokeNode extends AbstractInvokeNode { - @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); - - InvokeNode() { - } - - Object invoke(CallTarget target, Object[] args) { - return callNode.call(target, args); - } - } - - static class ApplyNode extends MalNode { - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); - - ApplyNode(MalLanguage language, MalList list) { - super(list); - fnNode = formToNode(language, list.head); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head); - list = list.tail; - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return callNode.call(fn.callTarget, args); - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - DefNode(MalLanguage language, MalList list) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.valueNode = formToNode(language, list.tail.tail.head); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - env.set(symbol, value); - return value; - } - } - - static class LetBindingNode extends Node { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { - this.symbol = symbol; - this.valueNode = formToNode(language, valueForm); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(symbol, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); - } - bodyNode = formToNode(language, form.tail.tail.head); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - static class MalRootNode extends RootNode { - final Object form; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form) { - super(language, new FrameDescriptor()); - this.form = form; - this.body = formToNode(language, form); - } - - @Override - public Object execute(VirtualFrame frame) { - var ctx = lookupContextReference(MalLanguage.class).get(); - return body.executeGeneric(frame, ctx.globalEnv); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form) { - super(form); - conditionNode = formToNode(language, form.tail.head); - trueNode = formToNode(language, form.tail.tail.head); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final MalSymbol symbol; - protected final int argPos; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos) { - this.symbol = symbol; - this.argPos = argPos; - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, buildVarArgsList(frame.getArguments())); - } - } - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0]); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form) { - super(form); - fnRoot = new FnRootNode(language, form); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - final static class MalContext { - final MalEnv globalEnv; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var root = new MalRootNode(this, form); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class step4_if_fn_do { + static final String LANGUAGE_ID = "mal_step4"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static MalNode formToNode(MalLanguage language, Object form) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head)) { + return new DefNode(language, list); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list); + } else { + return new ApplyNode(language, list); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i)); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey()); + nodes[i++] = formToNode(language, entry.getValue()); + } + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = env.get(symbol); + if (result == null) { + throw new MalException(symbol+" not found"); + } + return result; + } + } + + static class InvokeNode extends AbstractInvokeNode { + @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); + + InvokeNode() { + } + + Object invoke(CallTarget target, Object[] args) { + return callNode.call(target, args); + } + } + + static class ApplyNode extends MalNode { + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); + + ApplyNode(MalLanguage language, MalList list) { + super(list); + fnNode = formToNode(language, list.head); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head); + list = list.tail; + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return callNode.call(fn.callTarget, args); + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + DefNode(MalLanguage language, MalList list) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.valueNode = formToNode(language, list.tail.tail.head); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + env.set(symbol, value); + return value; + } + } + + static class LetBindingNode extends Node { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { + this.symbol = symbol; + this.valueNode = formToNode(language, valueForm); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(symbol, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); + } + bodyNode = formToNode(language, form.tail.tail.head); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + static class MalRootNode extends RootNode { + final Object form; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form) { + super(language, new FrameDescriptor()); + this.form = form; + this.body = formToNode(language, form); + } + + @Override + public Object execute(VirtualFrame frame) { + var ctx = lookupContextReference(MalLanguage.class).get(); + return body.executeGeneric(frame, ctx.globalEnv); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form) { + super(form); + conditionNode = formToNode(language, form.tail.head); + trueNode = formToNode(language, form.tail.tail.head); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final MalSymbol symbol; + protected final int argPos; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos) { + this.symbol = symbol; + this.argPos = argPos; + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, buildVarArgsList(frame.getArguments())); + } + } + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0]); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form) { + super(form); + fnRoot = new FnRootNode(language, form); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + final static class MalContext { + final MalEnv globalEnv; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var root = new MalRootNode(this, form); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/step5_tco.java b/impls/java-truffle/src/main/java/truffle/mal/step5_tco.java index 5b21db24c8..6002e20030 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/step5_tco.java +++ b/impls/java-truffle/src/main/java/truffle/mal/step5_tco.java @@ -1,562 +1,562 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class step5_tco { - static final String LANGUAGE_ID = "mal_step5"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head)) { - return new DefNode(language, list); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list); - } else { - return new ApplyNode(language, list, tailPosition); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false); - nodes[i++] = formToNode(language, entry.getValue(), false); - } - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = env.get(symbol); - if (result == null) { - throw new MalException(symbol+" not found"); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - if (tailPosition) { - throw new TailCallException(target, args); - } else { - while (true) { - try { - return callNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - static class ApplyNode extends MalNode { - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { - super(list); - fnNode = formToNode(language, list.head, false); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args); - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - DefNode(MalLanguage language, MalList list) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.valueNode = formToNode(language, list.tail.tail.head, false); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - env.set(symbol, value); - return value; - } - } - - static class LetBindingNode extends Node { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { - this.symbol = symbol; - this.valueNode = formToNode(language, valueForm, false); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(symbol, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a top-level evaluated form. - */ - static class MalRootNode extends RootNode { - final Object form; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, false); - } - - @Override - public Object execute(VirtualFrame frame) { - var ctx = lookupContextReference(MalLanguage.class).get(); - return body.executeGeneric(frame, ctx.globalEnv); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - conditionNode = formToNode(language, form.tail.head, false); - trueNode = formToNode(language, form.tail.tail.head, tailPosition); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final MalSymbol symbol; - protected final int argPos; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos) { - this.symbol = symbol; - this.argPos = argPos; - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, buildVarArgsList(frame.getArguments())); - } - } - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0]); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form) { - super(form); - fnRoot = new FnRootNode(language, form); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - final static class MalContext { - final MalEnv globalEnv; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var root = new MalRootNode(this, form); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class step5_tco { + static final String LANGUAGE_ID = "mal_step5"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head)) { + return new DefNode(language, list); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list); + } else { + return new ApplyNode(language, list, tailPosition); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false); + nodes[i++] = formToNode(language, entry.getValue(), false); + } + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = env.get(symbol); + if (result == null) { + throw new MalException(symbol+" not found"); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + if (tailPosition) { + throw new TailCallException(target, args); + } else { + while (true) { + try { + return callNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + static class ApplyNode extends MalNode { + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { + super(list); + fnNode = formToNode(language, list.head, false); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args); + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + DefNode(MalLanguage language, MalList list) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.valueNode = formToNode(language, list.tail.tail.head, false); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + env.set(symbol, value); + return value; + } + } + + static class LetBindingNode extends Node { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { + this.symbol = symbol; + this.valueNode = formToNode(language, valueForm, false); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(symbol, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a top-level evaluated form. + */ + static class MalRootNode extends RootNode { + final Object form; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, false); + } + + @Override + public Object execute(VirtualFrame frame) { + var ctx = lookupContextReference(MalLanguage.class).get(); + return body.executeGeneric(frame, ctx.globalEnv); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + conditionNode = formToNode(language, form.tail.head, false); + trueNode = formToNode(language, form.tail.tail.head, tailPosition); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final MalSymbol symbol; + protected final int argPos; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos) { + this.symbol = symbol; + this.argPos = argPos; + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, buildVarArgsList(frame.getArguments())); + } + } + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0]); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form) { + super(form); + fnRoot = new FnRootNode(language, form); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + final static class MalContext { + final MalEnv globalEnv; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var root = new MalRootNode(this, form); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/step6_file.java b/impls/java-truffle/src/main/java/truffle/mal/step6_file.java index 692f4e979e..c72a2bc930 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/step6_file.java +++ b/impls/java-truffle/src/main/java/truffle/mal/step6_file.java @@ -1,579 +1,579 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class step6_file { - static final String LANGUAGE_ID = "mal_step6"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - - var buf = new StringBuilder(); - buf.append("(def! *ARGV* (list"); - for (int i=1; i < args.length; i++) { - buf.append(' '); - buf.append(Printer.prStr(args[i], true)); - } - buf.append("))"); - context.eval(LANGUAGE_ID, buf.toString()); - - if (args.length > 0) { - context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); - return; - } - - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head)) { - return new DefNode(language, list); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list); - } else { - return new ApplyNode(language, list, tailPosition); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false); - nodes[i++] = formToNode(language, entry.getValue(), false); - } - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = env.get(symbol); - if (result == null) { - throw new MalException(symbol+" not found"); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - if (tailPosition) { - throw new TailCallException(target, args); - } else { - while (true) { - try { - return callNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - static class ApplyNode extends MalNode { - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { - super(list); - fnNode = formToNode(language, list.head, false); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args); - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - DefNode(MalLanguage language, MalList list) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.valueNode = formToNode(language, list.tail.tail.head, false); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - env.set(symbol, value); - return value; - } - } - - static class LetBindingNode extends Node { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { - this.symbol = symbol; - this.valueNode = formToNode(language, valueForm, false); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(symbol, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a top-level evaluated form. - */ - static class MalRootNode extends RootNode { - final Object form; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, false); - } - - @Override - public Object execute(VirtualFrame frame) { - var ctx = lookupContextReference(MalLanguage.class).get(); - return body.executeGeneric(frame, ctx.globalEnv); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - conditionNode = formToNode(language, form.tail.head, false); - trueNode = formToNode(language, form.tail.tail.head, tailPosition); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final MalSymbol symbol; - protected final int argPos; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos) { - this.symbol = symbol; - this.argPos = argPos; - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, buildVarArgsList(frame.getArguments())); - } - } - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0]); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form) { - super(form); - fnRoot = new FnRootNode(language, form); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - final static class MalContext { - final MalEnv globalEnv; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var root = new MalRootNode(this, form); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class step6_file { + static final String LANGUAGE_ID = "mal_step6"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + + var buf = new StringBuilder(); + buf.append("(def! *ARGV* (list"); + for (int i=1; i < args.length; i++) { + buf.append(' '); + buf.append(Printer.prStr(args[i], true)); + } + buf.append("))"); + context.eval(LANGUAGE_ID, buf.toString()); + + if (args.length > 0) { + context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); + return; + } + + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head)) { + return new DefNode(language, list); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list); + } else { + return new ApplyNode(language, list, tailPosition); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false); + nodes[i++] = formToNode(language, entry.getValue(), false); + } + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = env.get(symbol); + if (result == null) { + throw new MalException(symbol+" not found"); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + if (tailPosition) { + throw new TailCallException(target, args); + } else { + while (true) { + try { + return callNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + static class ApplyNode extends MalNode { + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { + super(list); + fnNode = formToNode(language, list.head, false); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args); + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + DefNode(MalLanguage language, MalList list) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.valueNode = formToNode(language, list.tail.tail.head, false); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + env.set(symbol, value); + return value; + } + } + + static class LetBindingNode extends Node { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { + this.symbol = symbol; + this.valueNode = formToNode(language, valueForm, false); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(symbol, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a top-level evaluated form. + */ + static class MalRootNode extends RootNode { + final Object form; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, false); + } + + @Override + public Object execute(VirtualFrame frame) { + var ctx = lookupContextReference(MalLanguage.class).get(); + return body.executeGeneric(frame, ctx.globalEnv); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + conditionNode = formToNode(language, form.tail.head, false); + trueNode = formToNode(language, form.tail.tail.head, tailPosition); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final MalSymbol symbol; + protected final int argPos; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos) { + this.symbol = symbol; + this.argPos = argPos; + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, buildVarArgsList(frame.getArguments())); + } + } + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0]); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form) { + super(form); + fnRoot = new FnRootNode(language, form); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + final static class MalContext { + final MalEnv globalEnv; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var root = new MalRootNode(this, form); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/step7_quote.java b/impls/java-truffle/src/main/java/truffle/mal/step7_quote.java index b517fc34bb..e0d3fd9523 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/step7_quote.java +++ b/impls/java-truffle/src/main/java/truffle/mal/step7_quote.java @@ -1,623 +1,623 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class step7_quote { - static final String LANGUAGE_ID = "mal_step7"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - - var buf = new StringBuilder(); - buf.append("(def! *ARGV* (list"); - for (int i=1; i < args.length; i++) { - buf.append(' '); - buf.append(Printer.prStr(args[i], true)); - } - buf.append("))"); - context.eval(LANGUAGE_ID, buf.toString()); - - if (args.length > 0) { - context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); - return; - } - - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static boolean isPair(Object obj) { - return (obj instanceof MalList && ((MalList)obj).length > 0) - || - (obj instanceof MalVector && ((MalVector)obj).size() > 0); - } - - private static Object quasiquote(Object form) { - if (!isPair(form)) { - return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); - } - MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; - if (MalSymbol.UNQUOTE.equals(list.head)) { - return list.tail.head; - } - var result = new ArrayList(); - if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { - result.add(MalSymbol.get("concat")); - result.add(((MalList)list.head).tail.head); - } else { - result.add(MalSymbol.get("cons")); - result.add(quasiquote(list.head)); - } - result.add(quasiquote(list.tail)); - return MalList.from(result); - } - - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head)) { - return new DefNode(language, list); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list); - } else if (MalSymbol.QUOTE.equals(head)) { - return new QuoteNode(language, list); - } else if (MalSymbol.QUASIQUOTE.equals(head)) { - return formToNode(language, quasiquote(list.tail.head), tailPosition); - } else { - return new ApplyNode(language, list, tailPosition); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false); - nodes[i++] = formToNode(language, entry.getValue(), false); - } - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = env.get(symbol); - if (result == null) { - throw new MalException(symbol+" not found"); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - if (tailPosition) { - throw new TailCallException(target, args); - } else { - while (true) { - try { - return callNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - static class ApplyNode extends MalNode { - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { - super(list); - fnNode = formToNode(language, list.head, false); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args); - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - DefNode(MalLanguage language, MalList list) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.valueNode = formToNode(language, list.tail.tail.head, false); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - env.set(symbol, value); - return value; - } - } - - static class LetBindingNode extends Node { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { - this.symbol = symbol; - this.valueNode = formToNode(language, valueForm, false); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(symbol, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a top-level evaluated form. - */ - static class MalRootNode extends RootNode { - final Object form; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, false); - } - - @Override - public Object execute(VirtualFrame frame) { - var ctx = lookupContextReference(MalLanguage.class).get(); - return body.executeGeneric(frame, ctx.globalEnv); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - conditionNode = formToNode(language, form.tail.head, false); - trueNode = formToNode(language, form.tail.tail.head, tailPosition); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final MalSymbol symbol; - protected final int argPos; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos) { - this.symbol = symbol; - this.argPos = argPos; - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, buildVarArgsList(frame.getArguments())); - } - } - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0]); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form) { - super(form); - fnRoot = new FnRootNode(language, form); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - static class QuoteNode extends MalNode { - final Object quoted; - - QuoteNode(MalLanguage language, MalList form) { - super(form); - quoted = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return quoted; - } - } - - final static class MalContext { - final MalEnv globalEnv; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var root = new MalRootNode(this, form); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class step7_quote { + static final String LANGUAGE_ID = "mal_step7"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + + var buf = new StringBuilder(); + buf.append("(def! *ARGV* (list"); + for (int i=1; i < args.length; i++) { + buf.append(' '); + buf.append(Printer.prStr(args[i], true)); + } + buf.append("))"); + context.eval(LANGUAGE_ID, buf.toString()); + + if (args.length > 0) { + context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); + return; + } + + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static boolean isPair(Object obj) { + return (obj instanceof MalList && ((MalList)obj).length > 0) + || + (obj instanceof MalVector && ((MalVector)obj).size() > 0); + } + + private static Object quasiquote(Object form) { + if (!isPair(form)) { + return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); + } + MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; + if (MalSymbol.UNQUOTE.equals(list.head)) { + return list.tail.head; + } + var result = new ArrayList(); + if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { + result.add(MalSymbol.get("concat")); + result.add(((MalList)list.head).tail.head); + } else { + result.add(MalSymbol.get("cons")); + result.add(quasiquote(list.head)); + } + result.add(quasiquote(list.tail)); + return MalList.from(result); + } + + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head)) { + return new DefNode(language, list); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list); + } else if (MalSymbol.QUOTE.equals(head)) { + return new QuoteNode(language, list); + } else if (MalSymbol.QUASIQUOTE.equals(head)) { + return formToNode(language, quasiquote(list.tail.head), tailPosition); + } else { + return new ApplyNode(language, list, tailPosition); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false); + nodes[i++] = formToNode(language, entry.getValue(), false); + } + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = env.get(symbol); + if (result == null) { + throw new MalException(symbol+" not found"); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + if (tailPosition) { + throw new TailCallException(target, args); + } else { + while (true) { + try { + return callNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + static class ApplyNode extends MalNode { + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { + super(list); + fnNode = formToNode(language, list.head, false); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args); + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + DefNode(MalLanguage language, MalList list) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.valueNode = formToNode(language, list.tail.tail.head, false); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + env.set(symbol, value); + return value; + } + } + + static class LetBindingNode extends Node { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { + this.symbol = symbol; + this.valueNode = formToNode(language, valueForm, false); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(symbol, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a top-level evaluated form. + */ + static class MalRootNode extends RootNode { + final Object form; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, false); + } + + @Override + public Object execute(VirtualFrame frame) { + var ctx = lookupContextReference(MalLanguage.class).get(); + return body.executeGeneric(frame, ctx.globalEnv); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + conditionNode = formToNode(language, form.tail.head, false); + trueNode = formToNode(language, form.tail.tail.head, tailPosition); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final MalSymbol symbol; + protected final int argPos; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos) { + this.symbol = symbol; + this.argPos = argPos; + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, buildVarArgsList(frame.getArguments())); + } + } + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0]); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form) { + super(form); + fnRoot = new FnRootNode(language, form); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + static class QuoteNode extends MalNode { + final Object quoted; + + QuoteNode(MalLanguage language, MalList form) { + super(form); + quoted = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return quoted; + } + } + + final static class MalContext { + final MalEnv globalEnv; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var root = new MalRootNode(this, form); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/step8_macros.java b/impls/java-truffle/src/main/java/truffle/mal/step8_macros.java index 1790e65ce5..5fa6b081f6 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/step8_macros.java +++ b/impls/java-truffle/src/main/java/truffle/mal/step8_macros.java @@ -1,712 +1,712 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class step8_macros { - static final String LANGUAGE_ID = "mal_step8"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - context.eval(LANGUAGE_ID, "(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)))))))"); - - var buf = new StringBuilder(); - buf.append("(def! *ARGV* (list"); - for (int i=1; i < args.length; i++) { - buf.append(' '); - buf.append(Printer.prStr(args[i], true)); - } - buf.append("))"); - context.eval(LANGUAGE_ID, buf.toString()); - - if (args.length > 0) { - context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); - return; - } - - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static boolean isPair(Object obj) { - return (obj instanceof MalList && ((MalList)obj).length > 0) - || - (obj instanceof MalVector && ((MalVector)obj).size() > 0); - } - - private static Object quasiquote(Object form) { - if (!isPair(form)) { - return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); - } - MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; - if (MalSymbol.UNQUOTE.equals(list.head)) { - return list.tail.head; - } - var result = new ArrayList(); - if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { - result.add(MalSymbol.get("concat")); - result.add(((MalList)list.head).tail.head); - } else { - result.add(MalSymbol.get("cons")); - result.add(quasiquote(list.head)); - } - result.add(quasiquote(list.tail)); - return MalList.from(result); - } - - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { - return new DefNode(language, list); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list); - } else if (MalSymbol.QUOTE.equals(head)) { - return new QuoteNode(language, list); - } else if (MalSymbol.QUASIQUOTE.equals(head)) { - return formToNode(language, quasiquote(list.tail.head), tailPosition); - } else if (MalSymbol.MACROEXPAND.equals(head)) { - return new MacroexpandNode(list); - } else { - return new ApplyNode(language, list, tailPosition); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false); - nodes[i++] = formToNode(language, entry.getValue(), false); - } - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = env.get(symbol); - if (result == null) { - throw new MalException(symbol+" not found"); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - return invoke(target, args, true); - } - - Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { - if (tailPosition && allowTailCall) { - throw new TailCallException(target, args); - } else { - while (true) { - try { - return callNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - private static MalFunction getMacroFn(MalEnv env, Object form) { - if (!(form instanceof MalList)) - return null; - MalList list = (MalList)form; - if (!(list.head instanceof MalSymbol)) - return null; - MalSymbol fnSym = (MalSymbol)list.head; - var obj = env.get(fnSym); - if (obj == null) - return null; - if (!(obj instanceof MalFunction)) - return null; - MalFunction fn = (MalFunction)obj; - return fn.isMacro ? fn : null; - } - - static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { - var fn = getMacroFn(env, form); - while (fn != null) { - MalList list = (MalList)form; - var args = new Object[(int)list.length]; - args[0] = fn.closedOverEnv; - int i=1; - list = list.tail; - while (!list.isEmpty()) { - args[i++] = list.head; - list = list.tail; - } - form = invokeNode.invoke(fn.callTarget, args, false); - fn = getMacroFn(env, form); - } - return form; - } - - static class MacroexpandNode extends MalNode { - @Child private InvokeNode invokeNode = new InvokeNode(false); - private final Object body; - - MacroexpandNode(MalList form) { - super(form); - this.body = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return macroexpand(invokeNode, env, body); - } - } - - static class ApplyNode extends MalNode { - final MalLanguage language; - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { - super(list); - this.language = language; - fnNode = formToNode(language, list.head, false); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @TruffleBoundary - private CallTarget applyMacro(MalEnv env, MalFunction fn) { - Object[] args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; ++i) { - args[i+1] = argNodes[i].form; - } - // We should never throw a tail call during expansion! - var result = macroexpand(invokeNode, env, form); - var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); - return Truffle.getRuntime().createCallTarget(newRoot); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - if (fn.isMacro) { - // Mal's macro semantics are... interesting. To preserve them in the - // general case, we must re-expand a macro each time it's applied. - // Executing the result means turning it into a Truffle AST, creating - // a CallTarget, calling it, and then throwing it away. - // This is TERRIBLE for performance! Truffle should not be used like this! - var target = applyMacro(env, fn); - return invokeNode.invoke(target, new Object[] {}, false); - } else { - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args); - } - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - private final boolean macro; - @Child private MalNode valueNode; - - DefNode(MalLanguage language, MalList list) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.macro = MalSymbol.DEFMACRO.equals(list.head); - this.valueNode = formToNode(language, list.tail.tail.head, false); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - if (macro) { - value = new MalFunction((MalFunction)value, true); - } - env.set(symbol, value); - return value; - } - } - - static class LetBindingNode extends Node { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { - this.symbol = symbol; - this.valueNode = formToNode(language, valueForm, false); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(symbol, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a form to be evaluated, together with an environment. - */ - static class MalRootNode extends RootNode { - final Object form; - final MalEnv env; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, tailPosition); - this.env = env; - } - - @Override - public Object execute(VirtualFrame frame) { - return body.executeGeneric(frame, env); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - conditionNode = formToNode(language, form.tail.head, false); - trueNode = formToNode(language, form.tail.tail.head, tailPosition); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final MalSymbol symbol; - protected final int argPos; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos) { - this.symbol = symbol; - this.argPos = argPos; - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, buildVarArgsList(frame.getArguments())); - } - } - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0]); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form) { - super(form); - fnRoot = new FnRootNode(language, form); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - static class QuoteNode extends MalNode { - final Object quoted; - - QuoteNode(MalLanguage language, MalList form) { - super(form); - quoted = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return quoted; - } - } - - final static class MalContext { - final MalEnv globalEnv; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var env = getCurrentContext(MalLanguage.class).globalEnv; - var root = new MalRootNode(this, form, env, false); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class step8_macros { + static final String LANGUAGE_ID = "mal_step8"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + context.eval(LANGUAGE_ID, "(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)))))))"); + + var buf = new StringBuilder(); + buf.append("(def! *ARGV* (list"); + for (int i=1; i < args.length; i++) { + buf.append(' '); + buf.append(Printer.prStr(args[i], true)); + } + buf.append("))"); + context.eval(LANGUAGE_ID, buf.toString()); + + if (args.length > 0) { + context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); + return; + } + + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static boolean isPair(Object obj) { + return (obj instanceof MalList && ((MalList)obj).length > 0) + || + (obj instanceof MalVector && ((MalVector)obj).size() > 0); + } + + private static Object quasiquote(Object form) { + if (!isPair(form)) { + return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); + } + MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; + if (MalSymbol.UNQUOTE.equals(list.head)) { + return list.tail.head; + } + var result = new ArrayList(); + if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { + result.add(MalSymbol.get("concat")); + result.add(((MalList)list.head).tail.head); + } else { + result.add(MalSymbol.get("cons")); + result.add(quasiquote(list.head)); + } + result.add(quasiquote(list.tail)); + return MalList.from(result); + } + + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { + return new DefNode(language, list); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list); + } else if (MalSymbol.QUOTE.equals(head)) { + return new QuoteNode(language, list); + } else if (MalSymbol.QUASIQUOTE.equals(head)) { + return formToNode(language, quasiquote(list.tail.head), tailPosition); + } else if (MalSymbol.MACROEXPAND.equals(head)) { + return new MacroexpandNode(list); + } else { + return new ApplyNode(language, list, tailPosition); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false); + nodes[i++] = formToNode(language, entry.getValue(), false); + } + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = env.get(symbol); + if (result == null) { + throw new MalException(symbol+" not found"); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + return invoke(target, args, true); + } + + Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { + if (tailPosition && allowTailCall) { + throw new TailCallException(target, args); + } else { + while (true) { + try { + return callNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + private static MalFunction getMacroFn(MalEnv env, Object form) { + if (!(form instanceof MalList)) + return null; + MalList list = (MalList)form; + if (!(list.head instanceof MalSymbol)) + return null; + MalSymbol fnSym = (MalSymbol)list.head; + var obj = env.get(fnSym); + if (obj == null) + return null; + if (!(obj instanceof MalFunction)) + return null; + MalFunction fn = (MalFunction)obj; + return fn.isMacro ? fn : null; + } + + static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { + var fn = getMacroFn(env, form); + while (fn != null) { + MalList list = (MalList)form; + var args = new Object[(int)list.length]; + args[0] = fn.closedOverEnv; + int i=1; + list = list.tail; + while (!list.isEmpty()) { + args[i++] = list.head; + list = list.tail; + } + form = invokeNode.invoke(fn.callTarget, args, false); + fn = getMacroFn(env, form); + } + return form; + } + + static class MacroexpandNode extends MalNode { + @Child private InvokeNode invokeNode = new InvokeNode(false); + private final Object body; + + MacroexpandNode(MalList form) { + super(form); + this.body = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return macroexpand(invokeNode, env, body); + } + } + + static class ApplyNode extends MalNode { + final MalLanguage language; + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { + super(list); + this.language = language; + fnNode = formToNode(language, list.head, false); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @TruffleBoundary + private CallTarget applyMacro(MalEnv env, MalFunction fn) { + Object[] args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; ++i) { + args[i+1] = argNodes[i].form; + } + // We should never throw a tail call during expansion! + var result = macroexpand(invokeNode, env, form); + var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); + return Truffle.getRuntime().createCallTarget(newRoot); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + if (fn.isMacro) { + // Mal's macro semantics are... interesting. To preserve them in the + // general case, we must re-expand a macro each time it's applied. + // Executing the result means turning it into a Truffle AST, creating + // a CallTarget, calling it, and then throwing it away. + // This is TERRIBLE for performance! Truffle should not be used like this! + var target = applyMacro(env, fn); + return invokeNode.invoke(target, new Object[] {}, false); + } else { + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args); + } + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + private final boolean macro; + @Child private MalNode valueNode; + + DefNode(MalLanguage language, MalList list) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.macro = MalSymbol.DEFMACRO.equals(list.head); + this.valueNode = formToNode(language, list.tail.tail.head, false); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + if (macro) { + value = new MalFunction((MalFunction)value, true); + } + env.set(symbol, value); + return value; + } + } + + static class LetBindingNode extends Node { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { + this.symbol = symbol; + this.valueNode = formToNode(language, valueForm, false); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(symbol, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a form to be evaluated, together with an environment. + */ + static class MalRootNode extends RootNode { + final Object form; + final MalEnv env; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, tailPosition); + this.env = env; + } + + @Override + public Object execute(VirtualFrame frame) { + return body.executeGeneric(frame, env); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + conditionNode = formToNode(language, form.tail.head, false); + trueNode = formToNode(language, form.tail.tail.head, tailPosition); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final MalSymbol symbol; + protected final int argPos; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos) { + this.symbol = symbol; + this.argPos = argPos; + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, buildVarArgsList(frame.getArguments())); + } + } + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0]); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form) { + super(form); + fnRoot = new FnRootNode(language, form); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + static class QuoteNode extends MalNode { + final Object quoted; + + QuoteNode(MalLanguage language, MalList form) { + super(form); + quoted = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return quoted; + } + } + + final static class MalContext { + final MalEnv globalEnv; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var env = getCurrentContext(MalLanguage.class).globalEnv; + var root = new MalRootNode(this, form, env, false); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/step9_try.java b/impls/java-truffle/src/main/java/truffle/mal/step9_try.java index 5abb11b668..01e80dcc8c 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/step9_try.java +++ b/impls/java-truffle/src/main/java/truffle/mal/step9_try.java @@ -1,750 +1,750 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class step9_try { - static final String LANGUAGE_ID = "mal_step9"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - context.eval(LANGUAGE_ID, "(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)))))))"); - - var buf = new StringBuilder(); - buf.append("(def! *ARGV* (list"); - for (int i=1; i < args.length; i++) { - buf.append(' '); - buf.append(Printer.prStr(args[i], true)); - } - buf.append("))"); - context.eval(LANGUAGE_ID, buf.toString()); - - if (args.length > 0) { - context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); - return; - } - - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static boolean isPair(Object obj) { - return (obj instanceof MalList && ((MalList)obj).length > 0) - || - (obj instanceof MalVector && ((MalVector)obj).size() > 0); - } - - private static Object quasiquote(Object form) { - if (!isPair(form)) { - return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); - } - MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; - if (MalSymbol.UNQUOTE.equals(list.head)) { - return list.tail.head; - } - var result = new ArrayList(); - if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { - result.add(MalSymbol.get("concat")); - result.add(((MalList)list.head).tail.head); - } else { - result.add(MalSymbol.get("cons")); - result.add(quasiquote(list.head)); - } - result.add(quasiquote(list.tail)); - return MalList.from(result); - } - - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { - return new DefNode(language, list); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list); - } else if (MalSymbol.QUOTE.equals(head)) { - return new QuoteNode(language, list); - } else if (MalSymbol.QUASIQUOTE.equals(head)) { - return formToNode(language, quasiquote(list.tail.head), tailPosition); - } else if (MalSymbol.MACROEXPAND.equals(head)) { - return new MacroexpandNode(list); - } else if (MalSymbol.TRY.equals(head)) { - return new TryNode(language, list, tailPosition); - } else { - return new ApplyNode(language, list, tailPosition); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false); - nodes[i++] = formToNode(language, entry.getValue(), false); - } - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = env.get(symbol); - if (result == null) { - throw new MalException("'"+symbol+"' not found"); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - return invoke(target, args, true); - } - - Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { - if (tailPosition && allowTailCall) { - throw new TailCallException(target, args); - } else { - while (true) { - try { - return callNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - private static MalFunction getMacroFn(MalEnv env, Object form) { - if (!(form instanceof MalList)) - return null; - MalList list = (MalList)form; - if (!(list.head instanceof MalSymbol)) - return null; - MalSymbol fnSym = (MalSymbol)list.head; - var obj = env.get(fnSym); - if (obj == null) - return null; - if (!(obj instanceof MalFunction)) - return null; - MalFunction fn = (MalFunction)obj; - return fn.isMacro ? fn : null; - } - - static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { - var fn = getMacroFn(env, form); - while (fn != null) { - MalList list = (MalList)form; - var args = new Object[(int)list.length]; - args[0] = fn.closedOverEnv; - int i=1; - list = list.tail; - while (!list.isEmpty()) { - args[i++] = list.head; - list = list.tail; - } - form = invokeNode.invoke(fn.callTarget, args, false); - fn = getMacroFn(env, form); - } - return form; - } - - static class MacroexpandNode extends MalNode { - @Child private InvokeNode invokeNode = new InvokeNode(false); - private final Object body; - - MacroexpandNode(MalList form) { - super(form); - this.body = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return macroexpand(invokeNode, env, body); - } - } - - static class ApplyNode extends MalNode { - final MalLanguage language; - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { - super(list); - this.language = language; - fnNode = formToNode(language, list.head, false); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @TruffleBoundary - private CallTarget applyMacro(MalEnv env, MalFunction fn) { - Object[] args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; ++i) { - args[i+1] = argNodes[i].form; - } - // We should never throw a tail call during expansion! - Object form = invokeNode.invoke(fn.callTarget, args, false); - var result = macroexpand(invokeNode, env, form); - var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); - return Truffle.getRuntime().createCallTarget(newRoot); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - if (fn.isMacro) { - // Mal's macro semantics are... interesting. To preserve them in the - // general case, we must re-expand a macro each time it's applied. - // Executing the result means turning it into a Truffle AST, creating - // a CallTarget, calling it, and then throwing it away. - // This is TERRIBLE for performance! Truffle should not be used like this! - var target = applyMacro(env, fn); - return invokeNode.invoke(target, new Object[] {}, false); - } else { - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args); - } - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - private final boolean macro; - @Child private MalNode valueNode; - - DefNode(MalLanguage language, MalList list) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.macro = MalSymbol.DEFMACRO.equals(list.head); - this.valueNode = formToNode(language, list.tail.tail.head, false); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - if (macro) { - value = new MalFunction((MalFunction)value, true); - } - env.set(symbol, value); - return value; - } - } - - static class LetBindingNode extends Node { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { - this.symbol = symbol; - this.valueNode = formToNode(language, valueForm, false); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(symbol, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a form to be evaluated, together with an environment. - */ - static class MalRootNode extends RootNode { - final Object form; - final MalEnv env; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, tailPosition); - this.env = env; - } - - @Override - public Object execute(VirtualFrame frame) { - return body.executeGeneric(frame, env); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - conditionNode = formToNode(language, form.tail.head, false); - trueNode = formToNode(language, form.tail.tail.head, tailPosition); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final MalSymbol symbol; - protected final int argPos; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos) { - this.symbol = symbol; - this.argPos = argPos; - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, buildVarArgsList(frame.getArguments())); - } - } - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0]); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form) { - super(form); - fnRoot = new FnRootNode(language, form); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - static class QuoteNode extends MalNode { - final Object quoted; - - QuoteNode(MalLanguage language, MalList form) { - super(form); - quoted = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return quoted; - } - } - - static class TryNode extends MalNode { - @Child private MalNode tryBody; - @Child private MalNode catchBody; - final MalSymbol exSymbol; - - TryNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var tryForm = form.tail.head; - var catchForm = (MalList)form.tail.tail.head; - // We don't allow tail calls inside a try body, because - // they'd get thrown past the catch that should catch subsequent failures. - this.tryBody = formToNode(language, tryForm, false); - if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { - exSymbol = (MalSymbol)catchForm.tail.head; - catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition); - } else { - exSymbol = null; - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - try { - return tryBody.executeGeneric(frame, env); - } catch (MalException ex) { - if (catchBody == null) { - throw ex; - } - var catchEnv = new MalEnv(env); - catchEnv.set(exSymbol, ex.obj); - return catchBody.executeGeneric(frame, catchEnv); - } - } - } - - final static class MalContext { - final MalEnv globalEnv; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var env = getCurrentContext(MalLanguage.class).globalEnv; - var root = new MalRootNode(this, form, env, false); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class step9_try { + static final String LANGUAGE_ID = "mal_step9"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + context.eval(LANGUAGE_ID, "(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)))))))"); + + var buf = new StringBuilder(); + buf.append("(def! *ARGV* (list"); + for (int i=1; i < args.length; i++) { + buf.append(' '); + buf.append(Printer.prStr(args[i], true)); + } + buf.append("))"); + context.eval(LANGUAGE_ID, buf.toString()); + + if (args.length > 0) { + context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); + return; + } + + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static boolean isPair(Object obj) { + return (obj instanceof MalList && ((MalList)obj).length > 0) + || + (obj instanceof MalVector && ((MalVector)obj).size() > 0); + } + + private static Object quasiquote(Object form) { + if (!isPair(form)) { + return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); + } + MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; + if (MalSymbol.UNQUOTE.equals(list.head)) { + return list.tail.head; + } + var result = new ArrayList(); + if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { + result.add(MalSymbol.get("concat")); + result.add(((MalList)list.head).tail.head); + } else { + result.add(MalSymbol.get("cons")); + result.add(quasiquote(list.head)); + } + result.add(quasiquote(list.tail)); + return MalList.from(result); + } + + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { + return new DefNode(language, list); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list); + } else if (MalSymbol.QUOTE.equals(head)) { + return new QuoteNode(language, list); + } else if (MalSymbol.QUASIQUOTE.equals(head)) { + return formToNode(language, quasiquote(list.tail.head), tailPosition); + } else if (MalSymbol.MACROEXPAND.equals(head)) { + return new MacroexpandNode(list); + } else if (MalSymbol.TRY.equals(head)) { + return new TryNode(language, list, tailPosition); + } else { + return new ApplyNode(language, list, tailPosition); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false); + nodes[i++] = formToNode(language, entry.getValue(), false); + } + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = env.get(symbol); + if (result == null) { + throw new MalException("'"+symbol+"' not found"); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + return invoke(target, args, true); + } + + Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { + if (tailPosition && allowTailCall) { + throw new TailCallException(target, args); + } else { + while (true) { + try { + return callNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + private static MalFunction getMacroFn(MalEnv env, Object form) { + if (!(form instanceof MalList)) + return null; + MalList list = (MalList)form; + if (!(list.head instanceof MalSymbol)) + return null; + MalSymbol fnSym = (MalSymbol)list.head; + var obj = env.get(fnSym); + if (obj == null) + return null; + if (!(obj instanceof MalFunction)) + return null; + MalFunction fn = (MalFunction)obj; + return fn.isMacro ? fn : null; + } + + static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { + var fn = getMacroFn(env, form); + while (fn != null) { + MalList list = (MalList)form; + var args = new Object[(int)list.length]; + args[0] = fn.closedOverEnv; + int i=1; + list = list.tail; + while (!list.isEmpty()) { + args[i++] = list.head; + list = list.tail; + } + form = invokeNode.invoke(fn.callTarget, args, false); + fn = getMacroFn(env, form); + } + return form; + } + + static class MacroexpandNode extends MalNode { + @Child private InvokeNode invokeNode = new InvokeNode(false); + private final Object body; + + MacroexpandNode(MalList form) { + super(form); + this.body = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return macroexpand(invokeNode, env, body); + } + } + + static class ApplyNode extends MalNode { + final MalLanguage language; + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { + super(list); + this.language = language; + fnNode = formToNode(language, list.head, false); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @TruffleBoundary + private CallTarget applyMacro(MalEnv env, MalFunction fn) { + Object[] args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; ++i) { + args[i+1] = argNodes[i].form; + } + // We should never throw a tail call during expansion! + Object form = invokeNode.invoke(fn.callTarget, args, false); + var result = macroexpand(invokeNode, env, form); + var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); + return Truffle.getRuntime().createCallTarget(newRoot); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + if (fn.isMacro) { + // Mal's macro semantics are... interesting. To preserve them in the + // general case, we must re-expand a macro each time it's applied. + // Executing the result means turning it into a Truffle AST, creating + // a CallTarget, calling it, and then throwing it away. + // This is TERRIBLE for performance! Truffle should not be used like this! + var target = applyMacro(env, fn); + return invokeNode.invoke(target, new Object[] {}, false); + } else { + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args); + } + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + private final boolean macro; + @Child private MalNode valueNode; + + DefNode(MalLanguage language, MalList list) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.macro = MalSymbol.DEFMACRO.equals(list.head); + this.valueNode = formToNode(language, list.tail.tail.head, false); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + if (macro) { + value = new MalFunction((MalFunction)value, true); + } + env.set(symbol, value); + return value; + } + } + + static class LetBindingNode extends Node { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { + this.symbol = symbol; + this.valueNode = formToNode(language, valueForm, false); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(symbol, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a form to be evaluated, together with an environment. + */ + static class MalRootNode extends RootNode { + final Object form; + final MalEnv env; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, tailPosition); + this.env = env; + } + + @Override + public Object execute(VirtualFrame frame) { + return body.executeGeneric(frame, env); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-2); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + conditionNode = formToNode(language, form.tail.head, false); + trueNode = formToNode(language, form.tail.tail.head, tailPosition); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final MalSymbol symbol; + protected final int argPos; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos) { + this.symbol = symbol; + this.argPos = argPos; + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, buildVarArgsList(frame.getArguments())); + } + } + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0]); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form) { + super(form); + fnRoot = new FnRootNode(language, form); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + static class QuoteNode extends MalNode { + final Object quoted; + + QuoteNode(MalLanguage language, MalList form) { + super(form); + quoted = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return quoted; + } + } + + static class TryNode extends MalNode { + @Child private MalNode tryBody; + @Child private MalNode catchBody; + final MalSymbol exSymbol; + + TryNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var tryForm = form.tail.head; + var catchForm = (MalList)form.tail.tail.head; + // We don't allow tail calls inside a try body, because + // they'd get thrown past the catch that should catch subsequent failures. + this.tryBody = formToNode(language, tryForm, false); + if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { + exSymbol = (MalSymbol)catchForm.tail.head; + catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition); + } else { + exSymbol = null; + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + try { + return tryBody.executeGeneric(frame, env); + } catch (MalException ex) { + if (catchBody == null) { + throw ex; + } + var catchEnv = new MalEnv(env); + catchEnv.set(exSymbol, ex.obj); + return catchBody.executeGeneric(frame, catchEnv); + } + } + } + + final static class MalContext { + final MalEnv globalEnv; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var env = getCurrentContext(MalLanguage.class).globalEnv; + var root = new MalRootNode(this, form, env, false); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/stepA_mal.java b/impls/java-truffle/src/main/java/truffle/mal/stepA_mal.java index e4a45eabb6..0ccc24ae42 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/stepA_mal.java +++ b/impls/java-truffle/src/main/java/truffle/mal/stepA_mal.java @@ -1,757 +1,757 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class stepA_mal { - static final String LANGUAGE_ID = "mal_stepA"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - context.eval(LANGUAGE_ID, "(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)))))))"); - context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); - - var buf = new StringBuilder(); - buf.append("(def! *ARGV* (list"); - for (int i=1; i < args.length; i++) { - buf.append(' '); - buf.append(Printer.prStr(args[i], true)); - } - buf.append("))"); - context.eval(LANGUAGE_ID, buf.toString()); - - if (args.length > 0) { - context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); - return; - } - - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static boolean isPair(Object obj) { - return (obj instanceof MalList && ((MalList)obj).length > 0) - || - (obj instanceof MalVector && ((MalVector)obj).size() > 0); - } - - private static Object quasiquote(Object form) { - if (!isPair(form)) { - return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); - } - MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; - if (MalSymbol.UNQUOTE.equals(list.head)) { - return list.tail.head; - } - var result = new ArrayList(); - if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { - result.add(MalSymbol.get("concat")); - result.add(((MalList)list.head).tail.head); - } else { - result.add(MalSymbol.get("cons")); - result.add(quasiquote(list.head)); - } - result.add(quasiquote(list.tail)); - return MalList.from(result); - } - - @TruffleBoundary - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { - return new DefNode(language, list); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list); - } else if (MalSymbol.QUOTE.equals(head)) { - return new QuoteNode(language, list); - } else if (MalSymbol.QUASIQUOTE.equals(head)) { - return formToNode(language, quasiquote(list.tail.head), tailPosition); - } else if (MalSymbol.MACROEXPAND.equals(head)) { - return new MacroexpandNode(list); - } else if (MalSymbol.TRY.equals(head)) { - return new TryNode(language, list, tailPosition); - } else { - return new ApplyNode(language, list, tailPosition); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false); - nodes[i++] = formToNode(language, entry.getValue(), false); - } - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = env.get(symbol); - if (result == null) { - throw new MalException("'"+symbol+"' not found"); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - return invoke(target, args, true); - } - - Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { - if (tailPosition && allowTailCall) { - throw new TailCallException(target, args); - } else { - while (true) { - try { - return callNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - private static MalFunction getMacroFn(MalEnv env, Object form) { - if (!(form instanceof MalList)) - return null; - MalList list = (MalList)form; - if (!(list.head instanceof MalSymbol)) - return null; - MalSymbol fnSym = (MalSymbol)list.head; - var obj = env.get(fnSym); - if (obj == null) - return null; - if (!(obj instanceof MalFunction)) - return null; - MalFunction fn = (MalFunction)obj; - return fn.isMacro ? fn : null; - } - - static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { - var fn = getMacroFn(env, form); - while (fn != null) { - MalList list = (MalList)form; - var args = new Object[(int)list.length]; - args[0] = fn.closedOverEnv; - int i=1; - list = list.tail; - while (!list.isEmpty()) { - args[i++] = list.head; - list = list.tail; - } - form = invokeNode.invoke(fn.callTarget, args, false); - fn = getMacroFn(env, form); - } - return form; - } - - static class MacroexpandNode extends MalNode { - @Child private InvokeNode invokeNode = new InvokeNode(false); - private final Object body; - - MacroexpandNode(MalList form) { - super(form); - this.body = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return macroexpand(invokeNode, env, body); - } - } - - static class ApplyNode extends MalNode { - final MalLanguage language; - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { - super(list); - this.language = language; - fnNode = formToNode(language, list.head, false); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @TruffleBoundary - private CallTarget applyMacro(MalEnv env, MalFunction fn) { - Object[] args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; ++i) { - args[i+1] = argNodes[i].form; - } - // We should never throw a tail call during expansion! - Object form = invokeNode.invoke(fn.callTarget, args, false); - var result = macroexpand(invokeNode, env, form); - var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); - return Truffle.getRuntime().createCallTarget(newRoot); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - if (fn.isMacro) { - // Mal's macro semantics are... interesting. To preserve them in the - // general case, we must re-expand a macro each time it's applied. - // Executing the result means turning it into a Truffle AST, creating - // a CallTarget, calling it, and then throwing it away. - // This is TERRIBLE for performance! Truffle should not be used like this! - var target = applyMacro(env, fn); - return invokeNode.invoke(target, new Object[] {}, false); - } else { - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args); - } - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - private final boolean macro; - @Child private MalNode valueNode; - - DefNode(MalLanguage language, MalList list) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.macro = MalSymbol.DEFMACRO.equals(list.head); - this.valueNode = formToNode(language, list.tail.tail.head, false); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - if (macro) { - value = new MalFunction((MalFunction)value, true); - } - env.set(symbol, value); - return value; - } - } - - static class LetBindingNode extends Node { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { - this.symbol = symbol; - this.valueNode = formToNode(language, valueForm, false); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(symbol, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a form to be evaluated, together with an environment. - */ - static class MalRootNode extends RootNode { - final Object form; - final MalEnv env; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, tailPosition); - this.env = env; - } - - @Override - public Object execute(VirtualFrame frame) { - return body.executeGeneric(frame, env); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - conditionNode = formToNode(language, form.tail.head, false); - trueNode = formToNode(language, form.tail.tail.head, tailPosition); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final MalSymbol symbol; - protected final int argPos; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos) { - this.symbol = symbol; - this.argPos = argPos; - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, buildVarArgsList(frame.getArguments())); - } - } - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0]); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - - @Override - public String toString() { - return form.toString(); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form) { - super(form); - fnRoot = new FnRootNode(language, form); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - static class QuoteNode extends MalNode { - final Object quoted; - - QuoteNode(MalLanguage language, MalList form) { - super(form); - quoted = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return quoted; - } - } - - static class TryNode extends MalNode { - @Child private MalNode tryBody; - @Child private MalNode catchBody; - final MalSymbol exSymbol; - - TryNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var tryForm = form.tail.head; - var catchForm = (MalList)form.tail.tail.head; - // We don't allow tail calls inside a try body, because - // they'd get thrown past the catch that should catch subsequent failures. - this.tryBody = formToNode(language, tryForm, false); - if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { - exSymbol = (MalSymbol)catchForm.tail.head; - catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition); - } else { - exSymbol = null; - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - try { - return tryBody.executeGeneric(frame, env); - } catch (MalException ex) { - if (catchBody == null) { - throw ex; - } - var catchEnv = new MalEnv(env); - catchEnv.set(exSymbol, ex.obj); - return catchBody.executeGeneric(frame, catchEnv); - } - } - } - - final static class MalContext { - final MalEnv globalEnv; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var env = getCurrentContext(MalLanguage.class).globalEnv; - var root = new MalRootNode(this, form, env, false); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class stepA_mal { + static final String LANGUAGE_ID = "mal_stepA"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + context.eval(LANGUAGE_ID, "(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)))))))"); + context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); + + var buf = new StringBuilder(); + buf.append("(def! *ARGV* (list"); + for (int i=1; i < args.length; i++) { + buf.append(' '); + buf.append(Printer.prStr(args[i], true)); + } + buf.append("))"); + context.eval(LANGUAGE_ID, buf.toString()); + + if (args.length > 0) { + context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); + return; + } + + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static boolean isPair(Object obj) { + return (obj instanceof MalList && ((MalList)obj).length > 0) + || + (obj instanceof MalVector && ((MalVector)obj).size() > 0); + } + + private static Object quasiquote(Object form) { + if (!isPair(form)) { + return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); + } + MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; + if (MalSymbol.UNQUOTE.equals(list.head)) { + return list.tail.head; + } + var result = new ArrayList(); + if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { + result.add(MalSymbol.get("concat")); + result.add(((MalList)list.head).tail.head); + } else { + result.add(MalSymbol.get("cons")); + result.add(quasiquote(list.head)); + } + result.add(quasiquote(list.tail)); + return MalList.from(result); + } + + @TruffleBoundary + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { + return new DefNode(language, list); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list); + } else if (MalSymbol.QUOTE.equals(head)) { + return new QuoteNode(language, list); + } else if (MalSymbol.QUASIQUOTE.equals(head)) { + return formToNode(language, quasiquote(list.tail.head), tailPosition); + } else if (MalSymbol.MACROEXPAND.equals(head)) { + return new MacroexpandNode(list); + } else if (MalSymbol.TRY.equals(head)) { + return new TryNode(language, list, tailPosition); + } else { + return new ApplyNode(language, list, tailPosition); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false); + nodes[i++] = formToNode(language, entry.getValue(), false); + } + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = env.get(symbol); + if (result == null) { + throw new MalException("'"+symbol+"' not found"); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @Child private IndirectCallNode callNode = Truffle.getRuntime().createIndirectCallNode(); + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + return invoke(target, args, true); + } + + Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { + if (tailPosition && allowTailCall) { + throw new TailCallException(target, args); + } else { + while (true) { + try { + return callNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + private static MalFunction getMacroFn(MalEnv env, Object form) { + if (!(form instanceof MalList)) + return null; + MalList list = (MalList)form; + if (!(list.head instanceof MalSymbol)) + return null; + MalSymbol fnSym = (MalSymbol)list.head; + var obj = env.get(fnSym); + if (obj == null) + return null; + if (!(obj instanceof MalFunction)) + return null; + MalFunction fn = (MalFunction)obj; + return fn.isMacro ? fn : null; + } + + static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { + var fn = getMacroFn(env, form); + while (fn != null) { + MalList list = (MalList)form; + var args = new Object[(int)list.length]; + args[0] = fn.closedOverEnv; + int i=1; + list = list.tail; + while (!list.isEmpty()) { + args[i++] = list.head; + list = list.tail; + } + form = invokeNode.invoke(fn.callTarget, args, false); + fn = getMacroFn(env, form); + } + return form; + } + + static class MacroexpandNode extends MalNode { + @Child private InvokeNode invokeNode = new InvokeNode(false); + private final Object body; + + MacroexpandNode(MalList form) { + super(form); + this.body = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return macroexpand(invokeNode, env, body); + } + } + + static class ApplyNode extends MalNode { + final MalLanguage language; + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { + super(list); + this.language = language; + fnNode = formToNode(language, list.head, false); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @TruffleBoundary + private CallTarget applyMacro(MalEnv env, MalFunction fn) { + Object[] args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; ++i) { + args[i+1] = argNodes[i].form; + } + // We should never throw a tail call during expansion! + Object form = invokeNode.invoke(fn.callTarget, args, false); + var result = macroexpand(invokeNode, env, form); + var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); + return Truffle.getRuntime().createCallTarget(newRoot); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + if (fn.isMacro) { + // Mal's macro semantics are... interesting. To preserve them in the + // general case, we must re-expand a macro each time it's applied. + // Executing the result means turning it into a Truffle AST, creating + // a CallTarget, calling it, and then throwing it away. + // This is TERRIBLE for performance! Truffle should not be used like this! + var target = applyMacro(env, fn); + return invokeNode.invoke(target, new Object[] {}, false); + } else { + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args); + } + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + private final boolean macro; + @Child private MalNode valueNode; + + DefNode(MalLanguage language, MalList list) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.macro = MalSymbol.DEFMACRO.equals(list.head); + this.valueNode = formToNode(language, list.tail.tail.head, false); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + if (macro) { + value = new MalFunction((MalFunction)value, true); + } + env.set(symbol, value); + return value; + } + } + + static class LetBindingNode extends Node { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { + this.symbol = symbol; + this.valueNode = formToNode(language, valueForm, false); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(symbol, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a form to be evaluated, together with an environment. + */ + static class MalRootNode extends RootNode { + final Object form; + final MalEnv env; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, tailPosition); + this.env = env; + } + + @Override + public Object execute(VirtualFrame frame) { + return body.executeGeneric(frame, env); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + conditionNode = formToNode(language, form.tail.head, false); + trueNode = formToNode(language, form.tail.tail.head, tailPosition); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final MalSymbol symbol; + protected final int argPos; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos) { + this.symbol = symbol; + this.argPos = argPos; + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, buildVarArgsList(frame.getArguments())); + } + } + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0]); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + + @Override + public String toString() { + return form.toString(); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form) { + super(form); + fnRoot = new FnRootNode(language, form); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + static class QuoteNode extends MalNode { + final Object quoted; + + QuoteNode(MalLanguage language, MalList form) { + super(form); + quoted = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return quoted; + } + } + + static class TryNode extends MalNode { + @Child private MalNode tryBody; + @Child private MalNode catchBody; + final MalSymbol exSymbol; + + TryNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var tryForm = form.tail.head; + var catchForm = (MalList)form.tail.tail.head; + // We don't allow tail calls inside a try body, because + // they'd get thrown past the catch that should catch subsequent failures. + this.tryBody = formToNode(language, tryForm, false); + if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { + exSymbol = (MalSymbol)catchForm.tail.head; + catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition); + } else { + exSymbol = null; + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + try { + return tryBody.executeGeneric(frame, env); + } catch (MalException ex) { + if (catchBody == null) { + throw ex; + } + var catchEnv = new MalEnv(env); + catchEnv.set(exSymbol, ex.obj); + return catchBody.executeGeneric(frame, catchEnv); + } + } + } + + final static class MalContext { + final MalEnv globalEnv; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var env = getCurrentContext(MalLanguage.class).globalEnv; + var root = new MalRootNode(this, form, env, false); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/stepB_calls.java b/impls/java-truffle/src/main/java/truffle/mal/stepB_calls.java index 60a5f8019b..4d785eebba 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/stepB_calls.java +++ b/impls/java-truffle/src/main/java/truffle/mal/stepB_calls.java @@ -1,797 +1,797 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives; -import com.oracle.truffle.api.CompilerDirectives.CompilationFinal; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.DirectCallNode; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -public class stepB_calls { - static final String LANGUAGE_ID = "mal_stepB"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - context.eval(LANGUAGE_ID, "(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)))))))"); - context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); - - var buf = new StringBuilder(); - buf.append("(def! *ARGV* (list"); - for (int i=1; i < args.length; i++) { - buf.append(' '); - buf.append(Printer.prStr(args[i], true)); - } - buf.append("))"); - context.eval(LANGUAGE_ID, buf.toString()); - - if (args.length > 0) { - context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); - return; - } - - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static boolean isPair(Object obj) { - return (obj instanceof MalList && ((MalList)obj).length > 0) - || - (obj instanceof MalVector && ((MalVector)obj).size() > 0); - } - - private static Object quasiquote(Object form) { - if (!isPair(form)) { - return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); - } - MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; - if (MalSymbol.UNQUOTE.equals(list.head)) { - return list.tail.head; - } - var result = new ArrayList(); - if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { - result.add(MalSymbol.get("concat")); - result.add(((MalList)list.head).tail.head); - } else { - result.add(MalSymbol.get("cons")); - result.add(quasiquote(list.head)); - } - result.add(quasiquote(list.tail)); - return MalList.from(result); - } - - @TruffleBoundary - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { - return new DefNode(language, list); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list); - } else if (MalSymbol.QUOTE.equals(head)) { - return new QuoteNode(language, list); - } else if (MalSymbol.QUASIQUOTE.equals(head)) { - return formToNode(language, quasiquote(list.tail.head), tailPosition); - } else if (MalSymbol.MACROEXPAND.equals(head)) { - return new MacroexpandNode(list); - } else if (MalSymbol.TRY.equals(head)) { - return new TryNode(language, list, tailPosition); - } else { - return new ApplyNode(language, list, tailPosition); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false); - nodes[i++] = formToNode(language, entry.getValue(), false); - } - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - - LookupNode(MalSymbol symbol) { - super(symbol); - this.symbol = symbol; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = env.get(symbol); - if (result == null) { - throw new MalException("'"+symbol+"' not found"); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - @TruffleBoundary - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private boolean usingCachedTarget; - @CompilationFinal private CallTarget cachedTarget; - @CompilationFinal @Child private DirectCallNode directCallNode; - @CompilationFinal @Child private IndirectCallNode indirectCallNode; - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - return invoke(target, args, true); - } - - Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { - if (tailPosition && allowTailCall) { - throw new TailCallException(target, args); - } else { - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - usingCachedTarget = true; - cachedTarget = target; - directCallNode = Truffle.getRuntime().createDirectCallNode(target); - } - while (true) { - try { - if (usingCachedTarget) { - if (cachedTarget == target) { - return directCallNode.call(args); - } - CompilerDirectives.transferToInterpreterAndInvalidate(); - usingCachedTarget = false; - indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); - } - return indirectCallNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - private static MalFunction getMacroFn(MalEnv env, Object form) { - if (!(form instanceof MalList)) - return null; - MalList list = (MalList)form; - if (!(list.head instanceof MalSymbol)) - return null; - MalSymbol fnSym = (MalSymbol)list.head; - var obj = env.get(fnSym); - if (obj == null) - return null; - if (!(obj instanceof MalFunction)) - return null; - MalFunction fn = (MalFunction)obj; - return fn.isMacro ? fn : null; - } - - static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { - var fn = getMacroFn(env, form); - while (fn != null) { - MalList list = (MalList)form; - var args = new Object[(int)list.length]; - args[0] = fn.closedOverEnv; - int i=1; - list = list.tail; - while (!list.isEmpty()) { - args[i++] = list.head; - list = list.tail; - } - form = invokeNode.invoke(fn.callTarget, args, false); - fn = getMacroFn(env, form); - } - return form; - } - - static class MacroexpandNode extends MalNode { - @Child private InvokeNode invokeNode = new InvokeNode(false); - private final Object body; - - MacroexpandNode(MalList form) { - super(form); - this.body = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return macroexpand(invokeNode, env, body); - } - } - - static class ApplyNode extends MalNode { - final MalLanguage language; - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private boolean usingCachedFn; - @CompilationFinal private MalFunction cachedFn; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { - super(list); - this.language = language; - fnNode = formToNode(language, list.head, false); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @TruffleBoundary - private CallTarget applyMacro(MalEnv env, MalFunction fn) { - Object[] args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; ++i) { - args[i+1] = argNodes[i].form; - } - // We should never throw a tail call during expansion! - Object form = invokeNode.invoke(fn.callTarget, args, false); - var result = macroexpand(invokeNode, env, form); - var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); - return Truffle.getRuntime().createCallTarget(newRoot); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - cachedFn = fn; - usingCachedFn = true; - } - if (usingCachedFn) { - if (fn != cachedFn) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - usingCachedFn = false; - } else { - fn = cachedFn; - } - } - if (fn.isMacro) { - // Mal's macro semantics are... interesting. To preserve them in the - // general case, we must re-expand a macro each time it's applied. - // Executing the result means turning it into a Truffle AST, creating - // a CallTarget, calling it, and then throwing it away. - // This is TERRIBLE for performance! Truffle should not be used like this! - var target = applyMacro(env, fn); - return invokeNode.invoke(target, new Object[] {}, false); - } else { - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args, fn.canBeTailCalled); - } - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - private final boolean macro; - @Child private MalNode valueNode; - - DefNode(MalLanguage language, MalList list) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.macro = MalSymbol.DEFMACRO.equals(list.head); - this.valueNode = formToNode(language, list.tail.tail.head, false); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - if (macro) { - value = new MalFunction((MalFunction)value, true); - } - env.set(symbol, value); - return value; - } - } - - static class LetBindingNode extends Node { - private final MalSymbol symbol; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { - this.symbol = symbol; - this.valueNode = formToNode(language, valueForm, false); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(symbol, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a form to be evaluated, together with an environment. - */ - static class MalRootNode extends RootNode { - final Object form; - final MalEnv env; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, tailPosition); - this.env = env; - } - - @Override - public Object execute(VirtualFrame frame) { - return body.executeGeneric(frame, env); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - conditionNode = formToNode(language, form.tail.head, false); - trueNode = formToNode(language, form.tail.tail.head, tailPosition); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || val == Boolean.FALSE) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final MalSymbol symbol; - protected final int argPos; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos) { - this.symbol = symbol; - this.argPos = argPos; - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos) { - super(symbol, argPos); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(symbol, buildVarArgsList(frame.getArguments())); - } - } - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0]); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - - @Override - public String toString() { - return form.toString(); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form) { - super(form); - fnRoot = new FnRootNode(language, form); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - static class QuoteNode extends MalNode { - final Object quoted; - - QuoteNode(MalLanguage language, MalList form) { - super(form); - quoted = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return quoted; - } - } - - static class TryNode extends MalNode { - @Child private MalNode tryBody; - @Child private MalNode catchBody; - final MalSymbol exSymbol; - - TryNode(MalLanguage language, MalList form, boolean tailPosition) { - super(form); - var tryForm = form.tail.head; - var catchForm = (MalList)form.tail.tail.head; - // We don't allow tail calls inside a try body, because - // they'd get thrown past the catch that should catch subsequent failures. - this.tryBody = formToNode(language, tryForm, false); - if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { - exSymbol = (MalSymbol)catchForm.tail.head; - catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition); - } else { - exSymbol = null; - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - try { - return tryBody.executeGeneric(frame, env); - } catch (MalException ex) { - if (catchBody == null) { - throw ex; - } - var catchEnv = new MalEnv(env); - catchEnv.set(exSymbol, ex.obj); - return catchBody.executeGeneric(frame, catchEnv); - } - } - } - - final static class MalContext { - final MalEnv globalEnv; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var env = getCurrentContext(MalLanguage.class).globalEnv; - var root = new MalRootNode(this, form, env, false); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives; +import com.oracle.truffle.api.CompilerDirectives.CompilationFinal; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.DirectCallNode; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +public class stepB_calls { + static final String LANGUAGE_ID = "mal_stepB"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + context.eval(LANGUAGE_ID, "(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)))))))"); + context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); + + var buf = new StringBuilder(); + buf.append("(def! *ARGV* (list"); + for (int i=1; i < args.length; i++) { + buf.append(' '); + buf.append(Printer.prStr(args[i], true)); + } + buf.append("))"); + context.eval(LANGUAGE_ID, buf.toString()); + + if (args.length > 0) { + context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); + return; + } + + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static boolean isPair(Object obj) { + return (obj instanceof MalList && ((MalList)obj).length > 0) + || + (obj instanceof MalVector && ((MalVector)obj).size() > 0); + } + + private static Object quasiquote(Object form) { + if (!isPair(form)) { + return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); + } + MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; + if (MalSymbol.UNQUOTE.equals(list.head)) { + return list.tail.head; + } + var result = new ArrayList(); + if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { + result.add(MalSymbol.get("concat")); + result.add(((MalList)list.head).tail.head); + } else { + result.add(MalSymbol.get("cons")); + result.add(quasiquote(list.head)); + } + result.add(quasiquote(list.tail)); + return MalList.from(result); + } + + @TruffleBoundary + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { + return new DefNode(language, list); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list); + } else if (MalSymbol.QUOTE.equals(head)) { + return new QuoteNode(language, list); + } else if (MalSymbol.QUASIQUOTE.equals(head)) { + return formToNode(language, quasiquote(list.tail.head), tailPosition); + } else if (MalSymbol.MACROEXPAND.equals(head)) { + return new MacroexpandNode(list); + } else if (MalSymbol.TRY.equals(head)) { + return new TryNode(language, list, tailPosition); + } else { + return new ApplyNode(language, list, tailPosition); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false); + nodes[i++] = formToNode(language, entry.getValue(), false); + } + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + result = result.assoc(nodes[i].executeGeneric(frame, env), nodes[i+1].executeGeneric(frame, env)); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + + LookupNode(MalSymbol symbol) { + super(symbol); + this.symbol = symbol; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = env.get(symbol); + if (result == null) { + throw new MalException("'"+symbol+"' not found"); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + @TruffleBoundary + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private boolean usingCachedTarget; + @CompilationFinal private CallTarget cachedTarget; + @CompilationFinal @Child private DirectCallNode directCallNode; + @CompilationFinal @Child private IndirectCallNode indirectCallNode; + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + return invoke(target, args, true); + } + + Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { + if (tailPosition && allowTailCall) { + throw new TailCallException(target, args); + } else { + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + usingCachedTarget = true; + cachedTarget = target; + directCallNode = Truffle.getRuntime().createDirectCallNode(target); + } + while (true) { + try { + if (usingCachedTarget) { + if (cachedTarget == target) { + return directCallNode.call(args); + } + CompilerDirectives.transferToInterpreterAndInvalidate(); + usingCachedTarget = false; + indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); + } + return indirectCallNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + private static MalFunction getMacroFn(MalEnv env, Object form) { + if (!(form instanceof MalList)) + return null; + MalList list = (MalList)form; + if (!(list.head instanceof MalSymbol)) + return null; + MalSymbol fnSym = (MalSymbol)list.head; + var obj = env.get(fnSym); + if (obj == null) + return null; + if (!(obj instanceof MalFunction)) + return null; + MalFunction fn = (MalFunction)obj; + return fn.isMacro ? fn : null; + } + + static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { + var fn = getMacroFn(env, form); + while (fn != null) { + MalList list = (MalList)form; + var args = new Object[(int)list.length]; + args[0] = fn.closedOverEnv; + int i=1; + list = list.tail; + while (!list.isEmpty()) { + args[i++] = list.head; + list = list.tail; + } + form = invokeNode.invoke(fn.callTarget, args, false); + fn = getMacroFn(env, form); + } + return form; + } + + static class MacroexpandNode extends MalNode { + @Child private InvokeNode invokeNode = new InvokeNode(false); + private final Object body; + + MacroexpandNode(MalList form) { + super(form); + this.body = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return macroexpand(invokeNode, env, body); + } + } + + static class ApplyNode extends MalNode { + final MalLanguage language; + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private boolean usingCachedFn; + @CompilationFinal private MalFunction cachedFn; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition) { + super(list); + this.language = language; + fnNode = formToNode(language, list.head, false); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @TruffleBoundary + private CallTarget applyMacro(MalEnv env, MalFunction fn) { + Object[] args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; ++i) { + args[i+1] = argNodes[i].form; + } + // We should never throw a tail call during expansion! + Object form = invokeNode.invoke(fn.callTarget, args, false); + var result = macroexpand(invokeNode, env, form); + var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition); + return Truffle.getRuntime().createCallTarget(newRoot); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + cachedFn = fn; + usingCachedFn = true; + } + if (usingCachedFn) { + if (fn != cachedFn) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + usingCachedFn = false; + } else { + fn = cachedFn; + } + } + if (fn.isMacro) { + // Mal's macro semantics are... interesting. To preserve them in the + // general case, we must re-expand a macro each time it's applied. + // Executing the result means turning it into a Truffle AST, creating + // a CallTarget, calling it, and then throwing it away. + // This is TERRIBLE for performance! Truffle should not be used like this! + var target = applyMacro(env, fn); + return invokeNode.invoke(target, new Object[] {}, false); + } else { + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args, fn.canBeTailCalled); + } + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + private final boolean macro; + @Child private MalNode valueNode; + + DefNode(MalLanguage language, MalList list) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.macro = MalSymbol.DEFMACRO.equals(list.head); + this.valueNode = formToNode(language, list.tail.tail.head, false); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + if (macro) { + value = new MalFunction((MalFunction)value, true); + } + env.set(symbol, value); + return value; + } + } + + static class LetBindingNode extends Node { + private final MalSymbol symbol; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm) { + this.symbol = symbol; + this.valueNode = formToNode(language, valueForm, false); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(symbol, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1)); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a form to be evaluated, together with an environment. + */ + static class MalRootNode extends RootNode { + final Object form; + final MalEnv env; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, tailPosition); + this.env = env; + } + + @Override + public Object execute(VirtualFrame frame) { + return body.executeGeneric(frame, env); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + conditionNode = formToNode(language, form.tail.head, false); + trueNode = formToNode(language, form.tail.tail.head, tailPosition); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || val == Boolean.FALSE) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final MalSymbol symbol; + protected final int argPos; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos) { + this.symbol = symbol; + this.argPos = argPos; + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos) { + super(symbol, argPos); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(symbol, buildVarArgsList(frame.getArguments())); + } + } + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0]); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + + @Override + public String toString() { + return form.toString(); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form) { + super(form); + fnRoot = new FnRootNode(language, form); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + static class QuoteNode extends MalNode { + final Object quoted; + + QuoteNode(MalLanguage language, MalList form) { + super(form); + quoted = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return quoted; + } + } + + static class TryNode extends MalNode { + @Child private MalNode tryBody; + @Child private MalNode catchBody; + final MalSymbol exSymbol; + + TryNode(MalLanguage language, MalList form, boolean tailPosition) { + super(form); + var tryForm = form.tail.head; + var catchForm = (MalList)form.tail.tail.head; + // We don't allow tail calls inside a try body, because + // they'd get thrown past the catch that should catch subsequent failures. + this.tryBody = formToNode(language, tryForm, false); + if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { + exSymbol = (MalSymbol)catchForm.tail.head; + catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition); + } else { + exSymbol = null; + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + try { + return tryBody.executeGeneric(frame, env); + } catch (MalException ex) { + if (catchBody == null) { + throw ex; + } + var catchEnv = new MalEnv(env); + catchEnv.set(exSymbol, ex.obj); + return catchBody.executeGeneric(frame, catchEnv); + } + } + } + + final static class MalContext { + final MalEnv globalEnv; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var env = getCurrentContext(MalLanguage.class).globalEnv; + var root = new MalRootNode(this, form, env, false); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/stepC_slots.java b/impls/java-truffle/src/main/java/truffle/mal/stepC_slots.java index a528bc7a0f..fc2a66187c 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/stepC_slots.java +++ b/impls/java-truffle/src/main/java/truffle/mal/stepC_slots.java @@ -1,848 +1,848 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives; -import com.oracle.truffle.api.CompilerDirectives.CompilationFinal; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.DirectCallNode; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -import truffle.mal.LexicalScope.EnvSlot; - -public class stepC_slots { - static final String LANGUAGE_ID = "mal_stepC"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - context.eval(LANGUAGE_ID, "(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)))))))"); - context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); - - var buf = new StringBuilder(); - buf.append("(def! *ARGV* (list"); - for (int i=1; i < args.length; i++) { - buf.append(' '); - buf.append(Printer.prStr(args[i], true)); - } - buf.append("))"); - context.eval(LANGUAGE_ID, buf.toString()); - - if (args.length > 0) { - context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); - return; - } - - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static boolean isPair(Object obj) { - return (obj instanceof MalList && ((MalList)obj).length > 0) - || - (obj instanceof MalVector && ((MalVector)obj).size() > 0); - } - - private static Object quasiquote(Object form) { - if (!isPair(form)) { - return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); - } - MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; - if (MalSymbol.UNQUOTE.equals(list.head)) { - return list.tail.head; - } - var result = new ArrayList(); - if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { - result.add(MalSymbol.get("concat")); - result.add(((MalList)list.head).tail.head); - } else { - result.add(MalSymbol.get("cons")); - result.add(quasiquote(list.head)); - } - result.add(quasiquote(list.tail)); - return MalList.from(result); - } - - @TruffleBoundary - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition, LexicalScope scope) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form, scope); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form, scope); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form, scope); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { - return new DefNode(language, list, scope); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition, scope); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition, scope); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition, scope); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list, scope); - } else if (MalSymbol.QUOTE.equals(head)) { - return new QuoteNode(language, list); - } else if (MalSymbol.QUASIQUOTE.equals(head)) { - return formToNode(language, quasiquote(list.tail.head), tailPosition, scope); - } else if (MalSymbol.MACROEXPAND.equals(head)) { - return new MacroexpandNode(list); - } else if (MalSymbol.TRY.equals(head)) { - return new TryNode(language, list, tailPosition, scope); - } else { - return new ApplyNode(language, list, tailPosition, scope); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector, LexicalScope scope) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false, scope); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map, LexicalScope scope) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false, scope); - nodes[i++] = formToNode(language, entry.getValue(), false, scope); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - var k = nodes[i].executeGeneric(frame, env); - var v = nodes[i+1].executeGeneric(frame, env); - result = result.assoc(k, v); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - private final LexicalScope scope; - @CompilationFinal boolean initialized = false; - @CompilationFinal EnvSlot slot; - - LookupNode(MalSymbol symbol, LexicalScope scope) { - super(symbol); - this.symbol = symbol; - this.scope = scope; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - slot = scope.getSlot(env, symbol); - } - Object result = null; - if (slot != null) { - if (slot.notDynamicallyBound.isValid()) { - result = env.get(slot); - } else { - result = env.get(symbol, slot); - } - } else { - result = env.get(symbol); - } - if (result == null) { - throw new MalException("'"+symbol.symbol+"' not found"); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private boolean usingCachedTarget; - @CompilationFinal private CallTarget cachedTarget; - @CompilationFinal @Child private DirectCallNode directCallNode; - @CompilationFinal @Child private IndirectCallNode indirectCallNode; - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - return invoke(target, args, true); - } - - Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { - if (tailPosition && allowTailCall) { - throw new TailCallException(target, args); - } else { - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - usingCachedTarget = true; - cachedTarget = target; - directCallNode = Truffle.getRuntime().createDirectCallNode(target); - } - while (true) { - try { - if (usingCachedTarget) { - if (cachedTarget == target) { - return directCallNode.call(args); - } - CompilerDirectives.transferToInterpreterAndInvalidate(); - usingCachedTarget = false; - indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); - } - return indirectCallNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - private static MalFunction getMacroFn(MalEnv env, Object form) { - if (!(form instanceof MalList)) - return null; - MalList list = (MalList)form; - if (!(list.head instanceof MalSymbol)) - return null; - MalSymbol fnSym = (MalSymbol)list.head; - var obj = env.get(fnSym); - if (obj == null) - return null; - if (!(obj instanceof MalFunction)) - return null; - MalFunction fn = (MalFunction)obj; - return fn.isMacro ? fn : null; - } - - static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { - var fn = getMacroFn(env, form); - while (fn != null) { - MalList list = (MalList)form; - var args = new Object[(int)list.length]; - args[0] = fn.closedOverEnv; - int i=1; - list = list.tail; - while (!list.isEmpty()) { - args[i++] = list.head; - list = list.tail; - } - form = invokeNode.invoke(fn.callTarget, args, false); - fn = getMacroFn(env, form); - } - return form; - } - - static class MacroexpandNode extends MalNode { - @Child private InvokeNode invokeNode = new InvokeNode(false); - private final Object body; - - MacroexpandNode(MalList form) { - super(form); - this.body = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return macroexpand(invokeNode, env, body); - } - } - - static class ApplyNode extends MalNode { - final MalLanguage language; - final LexicalScope scope; - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private boolean usingCachedFn; - @CompilationFinal private MalFunction cachedFn; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition, LexicalScope scope) { - super(list); - this.language = language; - this.scope = scope; - fnNode = formToNode(language, list.head, false, scope); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false, scope); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @TruffleBoundary - private CallTarget applyMacro(MalEnv env, MalFunction fn) { - Object[] args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; ++i) { - args[i+1] = argNodes[i].form; - } - // We should never throw a tail call during expansion! - Object form = invokeNode.invoke(fn.callTarget, args, false); - var result = macroexpand(invokeNode, env, form); - var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition, scope); - return Truffle.getRuntime().createCallTarget(newRoot); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - cachedFn = fn; - usingCachedFn = true; - } - if (usingCachedFn) { - if (fn != cachedFn) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - usingCachedFn = false; - } else { - fn = cachedFn; - } - } - if (fn.isMacro) { - // Mal's macro semantics are... interesting. To preserve them in the - // general case, we must re-expand a macro each time it's applied. - // Executing the result means turning it into a Truffle AST, creating - // a CallTarget, calling it, and then throwing it away. - // This is TERRIBLE for performance! Truffle should not be used like this! - var target = applyMacro(env, fn); - return invokeNode.invoke(target, new Object[] {}, false); - } else { - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args, fn.canBeTailCalled); - } - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - private final boolean macro; - private final LexicalScope scope; - @Child private MalNode valueNode; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private EnvSlot slot; - - DefNode(MalLanguage language, MalList list, LexicalScope scope) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.macro = MalSymbol.DEFMACRO.equals(list.head); - this.scope = scope; - this.valueNode = formToNode(language, list.tail.tail.head, false, scope); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - if (macro) { - value = new MalFunction((MalFunction)value, true); - } - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - var slot = scope.getSlot(env, symbol); - if (slot != null && slot.height == 0) { - this.slot = slot; - } - } - if (slot != null) { - env.set(slot, value); - } else { - env.set(symbol, value); - } - return value; - } - } - - static class LetBindingNode extends Node { - private final EnvSlot slot; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm, LexicalScope scope) { - this.slot = scope.allocateSlot(symbol); - this.valueNode = formToNode(language, valueForm, false, scope); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(slot, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - private final LexicalScope scope; - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope outerScope) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - scope = new LexicalScope(outerScope); - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1), scope); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition, scope); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv, scope); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a form to be evaluated, together with an environment. - */ - static class MalRootNode extends RootNode { - final Object form; - final MalEnv env; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition, LexicalScope scope) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, tailPosition, scope); - this.env = env; - } - - @Override - public Object execute(VirtualFrame frame) { - return body.executeGeneric(frame, env); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1, scope); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { - super(form); - conditionNode = formToNode(language, form.tail.head, false, scope); - trueNode = formToNode(language, form.tail.tail.head, tailPosition, scope); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition, scope); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final int argPos; - protected final EnvSlot slot; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { - this.argPos = argPos; - this.slot = scope.allocateSlot(symbol); - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { - super(symbol, argPos, scope); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(slot, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos, LexicalScope scope) { - super(symbol, argPos, scope); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(slot, buildVarArgsList(frame.getArguments())); - } - } - - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - final LexicalScope scope; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form, LexicalScope outerScope) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - this.scope = new LexicalScope(outerScope); - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1, scope); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1, scope); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true, scope); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0], scope); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - - @Override - public String toString() { - return form.toString(); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form, LexicalScope scope) { - super(form); - fnRoot = new FnRootNode(language, form, scope); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - static class QuoteNode extends MalNode { - final Object quoted; - - QuoteNode(MalLanguage language, MalList form) { - super(form); - quoted = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return quoted; - } - } - - static class TryNode extends MalNode { - @Child private MalNode tryBody; - @Child private MalNode catchBody; - final EnvSlot exSlot; - final LexicalScope catchScope; - - TryNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { - super(form); - var tryForm = form.tail.head; - var catchForm = (MalList)form.tail.tail.head; - // We don't allow tail calls inside a try body, because - // they'd get thrown past the catch that should catch subsequent failures. - this.tryBody = formToNode(language, tryForm, false, scope); - if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { - catchScope = new LexicalScope(scope); - var exSymbol = (MalSymbol)catchForm.tail.head; - exSlot = catchScope.allocateSlot(exSymbol); - catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition, catchScope); - } else { - catchScope = null; - exSlot = null; - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - try { - return tryBody.executeGeneric(frame, env); - } catch (MalException ex) { - if (catchBody == null) { - throw ex; - } - var catchEnv = new MalEnv(env, catchScope); - catchEnv.set(exSlot, ex.obj); - return catchBody.executeGeneric(frame, catchEnv); - } - } - } - - final static class MalContext { - final MalEnv globalEnv; - final LexicalScope globalScope; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - globalScope = new LexicalScope(); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var ctx = getCurrentContext(MalLanguage.class); - var root = new MalRootNode(this, form, ctx.globalEnv, false, ctx.globalScope); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives; +import com.oracle.truffle.api.CompilerDirectives.CompilationFinal; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.DirectCallNode; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +import truffle.mal.LexicalScope.EnvSlot; + +public class stepC_slots { + static final String LANGUAGE_ID = "mal_stepC"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + context.eval(LANGUAGE_ID, "(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)))))))"); + context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); + + var buf = new StringBuilder(); + buf.append("(def! *ARGV* (list"); + for (int i=1; i < args.length; i++) { + buf.append(' '); + buf.append(Printer.prStr(args[i], true)); + } + buf.append("))"); + context.eval(LANGUAGE_ID, buf.toString()); + + if (args.length > 0) { + context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); + return; + } + + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static boolean isPair(Object obj) { + return (obj instanceof MalList && ((MalList)obj).length > 0) + || + (obj instanceof MalVector && ((MalVector)obj).size() > 0); + } + + private static Object quasiquote(Object form) { + if (!isPair(form)) { + return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); + } + MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; + if (MalSymbol.UNQUOTE.equals(list.head)) { + return list.tail.head; + } + var result = new ArrayList(); + if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { + result.add(MalSymbol.get("concat")); + result.add(((MalList)list.head).tail.head); + } else { + result.add(MalSymbol.get("cons")); + result.add(quasiquote(list.head)); + } + result.add(quasiquote(list.tail)); + return MalList.from(result); + } + + @TruffleBoundary + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition, LexicalScope scope) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form, scope); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form, scope); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form, scope); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { + return new DefNode(language, list, scope); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition, scope); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition, scope); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition, scope); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list, scope); + } else if (MalSymbol.QUOTE.equals(head)) { + return new QuoteNode(language, list); + } else if (MalSymbol.QUASIQUOTE.equals(head)) { + return formToNode(language, quasiquote(list.tail.head), tailPosition, scope); + } else if (MalSymbol.MACROEXPAND.equals(head)) { + return new MacroexpandNode(list); + } else if (MalSymbol.TRY.equals(head)) { + return new TryNode(language, list, tailPosition, scope); + } else { + return new ApplyNode(language, list, tailPosition, scope); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector, LexicalScope scope) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false, scope); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map, LexicalScope scope) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false, scope); + nodes[i++] = formToNode(language, entry.getValue(), false, scope); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + var k = nodes[i].executeGeneric(frame, env); + var v = nodes[i+1].executeGeneric(frame, env); + result = result.assoc(k, v); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + private final LexicalScope scope; + @CompilationFinal boolean initialized = false; + @CompilationFinal EnvSlot slot; + + LookupNode(MalSymbol symbol, LexicalScope scope) { + super(symbol); + this.symbol = symbol; + this.scope = scope; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + slot = scope.getSlot(env, symbol); + } + Object result = null; + if (slot != null) { + if (slot.notDynamicallyBound.isValid()) { + result = env.get(slot); + } else { + result = env.get(symbol, slot); + } + } else { + result = env.get(symbol); + } + if (result == null) { + throw new MalException("'"+symbol.symbol+"' not found"); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private boolean usingCachedTarget; + @CompilationFinal private CallTarget cachedTarget; + @CompilationFinal @Child private DirectCallNode directCallNode; + @CompilationFinal @Child private IndirectCallNode indirectCallNode; + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + return invoke(target, args, true); + } + + Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { + if (tailPosition && allowTailCall) { + throw new TailCallException(target, args); + } else { + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + usingCachedTarget = true; + cachedTarget = target; + directCallNode = Truffle.getRuntime().createDirectCallNode(target); + } + while (true) { + try { + if (usingCachedTarget) { + if (cachedTarget == target) { + return directCallNode.call(args); + } + CompilerDirectives.transferToInterpreterAndInvalidate(); + usingCachedTarget = false; + indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); + } + return indirectCallNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + private static MalFunction getMacroFn(MalEnv env, Object form) { + if (!(form instanceof MalList)) + return null; + MalList list = (MalList)form; + if (!(list.head instanceof MalSymbol)) + return null; + MalSymbol fnSym = (MalSymbol)list.head; + var obj = env.get(fnSym); + if (obj == null) + return null; + if (!(obj instanceof MalFunction)) + return null; + MalFunction fn = (MalFunction)obj; + return fn.isMacro ? fn : null; + } + + static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { + var fn = getMacroFn(env, form); + while (fn != null) { + MalList list = (MalList)form; + var args = new Object[(int)list.length]; + args[0] = fn.closedOverEnv; + int i=1; + list = list.tail; + while (!list.isEmpty()) { + args[i++] = list.head; + list = list.tail; + } + form = invokeNode.invoke(fn.callTarget, args, false); + fn = getMacroFn(env, form); + } + return form; + } + + static class MacroexpandNode extends MalNode { + @Child private InvokeNode invokeNode = new InvokeNode(false); + private final Object body; + + MacroexpandNode(MalList form) { + super(form); + this.body = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return macroexpand(invokeNode, env, body); + } + } + + static class ApplyNode extends MalNode { + final MalLanguage language; + final LexicalScope scope; + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private boolean usingCachedFn; + @CompilationFinal private MalFunction cachedFn; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition, LexicalScope scope) { + super(list); + this.language = language; + this.scope = scope; + fnNode = formToNode(language, list.head, false, scope); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false, scope); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @TruffleBoundary + private CallTarget applyMacro(MalEnv env, MalFunction fn) { + Object[] args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; ++i) { + args[i+1] = argNodes[i].form; + } + // We should never throw a tail call during expansion! + Object form = invokeNode.invoke(fn.callTarget, args, false); + var result = macroexpand(invokeNode, env, form); + var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition, scope); + return Truffle.getRuntime().createCallTarget(newRoot); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + cachedFn = fn; + usingCachedFn = true; + } + if (usingCachedFn) { + if (fn != cachedFn) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + usingCachedFn = false; + } else { + fn = cachedFn; + } + } + if (fn.isMacro) { + // Mal's macro semantics are... interesting. To preserve them in the + // general case, we must re-expand a macro each time it's applied. + // Executing the result means turning it into a Truffle AST, creating + // a CallTarget, calling it, and then throwing it away. + // This is TERRIBLE for performance! Truffle should not be used like this! + var target = applyMacro(env, fn); + return invokeNode.invoke(target, new Object[] {}, false); + } else { + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args, fn.canBeTailCalled); + } + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + private final boolean macro; + private final LexicalScope scope; + @Child private MalNode valueNode; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private EnvSlot slot; + + DefNode(MalLanguage language, MalList list, LexicalScope scope) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.macro = MalSymbol.DEFMACRO.equals(list.head); + this.scope = scope; + this.valueNode = formToNode(language, list.tail.tail.head, false, scope); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + if (macro) { + value = new MalFunction((MalFunction)value, true); + } + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + var slot = scope.getSlot(env, symbol); + if (slot != null && slot.height == 0) { + this.slot = slot; + } + } + if (slot != null) { + env.set(slot, value); + } else { + env.set(symbol, value); + } + return value; + } + } + + static class LetBindingNode extends Node { + private final EnvSlot slot; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm, LexicalScope scope) { + this.slot = scope.allocateSlot(symbol); + this.valueNode = formToNode(language, valueForm, false, scope); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(slot, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + private final LexicalScope scope; + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope outerScope) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + scope = new LexicalScope(outerScope); + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1), scope); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition, scope); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv, scope); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a form to be evaluated, together with an environment. + */ + static class MalRootNode extends RootNode { + final Object form; + final MalEnv env; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition, LexicalScope scope) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, tailPosition, scope); + this.env = env; + } + + @Override + public Object execute(VirtualFrame frame) { + return body.executeGeneric(frame, env); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1, scope); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { + super(form); + conditionNode = formToNode(language, form.tail.head, false, scope); + trueNode = formToNode(language, form.tail.tail.head, tailPosition, scope); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition, scope); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final int argPos; + protected final EnvSlot slot; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { + this.argPos = argPos; + this.slot = scope.allocateSlot(symbol); + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { + super(symbol, argPos, scope); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(slot, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos, LexicalScope scope) { + super(symbol, argPos, scope); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(slot, buildVarArgsList(frame.getArguments())); + } + } + + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + final LexicalScope scope; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form, LexicalScope outerScope) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + this.scope = new LexicalScope(outerScope); + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1, scope); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1, scope); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true, scope); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0], scope); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + + @Override + public String toString() { + return form.toString(); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form, LexicalScope scope) { + super(form); + fnRoot = new FnRootNode(language, form, scope); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + static class QuoteNode extends MalNode { + final Object quoted; + + QuoteNode(MalLanguage language, MalList form) { + super(form); + quoted = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return quoted; + } + } + + static class TryNode extends MalNode { + @Child private MalNode tryBody; + @Child private MalNode catchBody; + final EnvSlot exSlot; + final LexicalScope catchScope; + + TryNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { + super(form); + var tryForm = form.tail.head; + var catchForm = (MalList)form.tail.tail.head; + // We don't allow tail calls inside a try body, because + // they'd get thrown past the catch that should catch subsequent failures. + this.tryBody = formToNode(language, tryForm, false, scope); + if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { + catchScope = new LexicalScope(scope); + var exSymbol = (MalSymbol)catchForm.tail.head; + exSlot = catchScope.allocateSlot(exSymbol); + catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition, catchScope); + } else { + catchScope = null; + exSlot = null; + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + try { + return tryBody.executeGeneric(frame, env); + } catch (MalException ex) { + if (catchBody == null) { + throw ex; + } + var catchEnv = new MalEnv(env, catchScope); + catchEnv.set(exSlot, ex.obj); + return catchBody.executeGeneric(frame, catchEnv); + } + } + } + + final static class MalContext { + final MalEnv globalEnv; + final LexicalScope globalScope; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + globalScope = new LexicalScope(); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var ctx = getCurrentContext(MalLanguage.class); + var root = new MalRootNode(this, form, ctx.globalEnv, false, ctx.globalScope); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/stepD_caching.java b/impls/java-truffle/src/main/java/truffle/mal/stepD_caching.java index 28d5c2a36a..670c73ff34 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/stepD_caching.java +++ b/impls/java-truffle/src/main/java/truffle/mal/stepD_caching.java @@ -1,860 +1,860 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.Assumption; -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives; -import com.oracle.truffle.api.CompilerDirectives.CompilationFinal; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.DirectCallNode; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -import truffle.mal.LexicalScope.EnvSlot; -import truffle.mal.MalEnv.CachedResult; - -public class stepD_caching { - static final String LANGUAGE_ID = "mal_stepD"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - context.eval(LANGUAGE_ID, "(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)))))))"); - context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); - - var buf = new StringBuilder(); - buf.append("(def! *ARGV* (list"); - for (int i=1; i < args.length; i++) { - buf.append(' '); - buf.append(Printer.prStr(args[i], true)); - } - buf.append("))"); - context.eval(LANGUAGE_ID, buf.toString()); - - if (args.length > 0) { - context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); - return; - } - - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static boolean isPair(Object obj) { - return (obj instanceof MalList && ((MalList)obj).length > 0) - || - (obj instanceof MalVector && ((MalVector)obj).size() > 0); - } - - private static Object quasiquote(Object form) { - if (!isPair(form)) { - return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); - } - MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; - if (MalSymbol.UNQUOTE.equals(list.head)) { - return list.tail.head; - } - var result = new ArrayList(); - if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { - result.add(MalSymbol.get("concat")); - result.add(((MalList)list.head).tail.head); - } else { - result.add(MalSymbol.get("cons")); - result.add(quasiquote(list.head)); - } - result.add(quasiquote(list.tail)); - return MalList.from(result); - } - - @TruffleBoundary - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition, LexicalScope scope) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form, scope); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form, scope); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form, scope); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { - return new DefNode(language, list, scope); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition, scope); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition, scope); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition, scope); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list, scope); - } else if (MalSymbol.QUOTE.equals(head)) { - return new QuoteNode(language, list); - } else if (MalSymbol.QUASIQUOTE.equals(head)) { - return formToNode(language, quasiquote(list.tail.head), tailPosition, scope); - } else if (MalSymbol.MACROEXPAND.equals(head)) { - return new MacroexpandNode(list); - } else if (MalSymbol.TRY.equals(head)) { - return new TryNode(language, list, tailPosition, scope); - } else { - return new ApplyNode(language, list, tailPosition, scope); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector, LexicalScope scope) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false, scope); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new ArrayList<>(elementNodes.length); - for (int i=0; i < elementNodes.length; i++) { - elements.add(elementNodes[i].executeGeneric(frame, env)); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map, LexicalScope scope) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false, scope); - nodes[i++] = formToNode(language, entry.getValue(), false, scope); - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - var k = nodes[i].executeGeneric(frame, env); - var v = nodes[i+1].executeGeneric(frame, env); - result = result.assoc(k, v); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - private final LexicalScope scope; - @CompilationFinal boolean initialized = false; - @CompilationFinal EnvSlot slot; - @CompilationFinal CachedResult cachedResult; - @CompilationFinal Assumption notRedefined; - - LookupNode(MalSymbol symbol, LexicalScope scope) { - super(symbol); - this.symbol = symbol; - this.scope = scope; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - slot = scope.getSlot(env, symbol); - if (slot == null) { - cachedResult = env.cachedGet(symbol); - notRedefined = cachedResult.notRedefined; - } - } - Object result = null; - if (slot != null) { - if (slot.notDynamicallyBound.isValid()) { - result = env.get(slot); - } else { - result = env.get(symbol, slot); - } - } else { - if (notRedefined.isValid()) { - result = cachedResult.result; - } else { - result = env.get(symbol); - } - } - if (result == null) { - throw new MalException("'"+symbol.symbol+"' not found"); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private boolean usingCachedTarget; - @CompilationFinal private CallTarget cachedTarget; - @CompilationFinal @Child private DirectCallNode directCallNode; - @CompilationFinal @Child private IndirectCallNode indirectCallNode; - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - return invoke(target, args, true); - } - - Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { - if (tailPosition && allowTailCall) { - throw new TailCallException(target, args); - } else { - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - usingCachedTarget = true; - cachedTarget = target; - directCallNode = Truffle.getRuntime().createDirectCallNode(target); - } - while (true) { - try { - if (usingCachedTarget) { - if (cachedTarget == target) { - return directCallNode.call(args); - } - CompilerDirectives.transferToInterpreterAndInvalidate(); - usingCachedTarget = false; - indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); - } - return indirectCallNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - private static MalFunction getMacroFn(MalEnv env, Object form) { - if (!(form instanceof MalList)) - return null; - MalList list = (MalList)form; - if (!(list.head instanceof MalSymbol)) - return null; - MalSymbol fnSym = (MalSymbol)list.head; - var obj = env.get(fnSym); - if (obj == null) - return null; - if (!(obj instanceof MalFunction)) - return null; - MalFunction fn = (MalFunction)obj; - return fn.isMacro ? fn : null; - } - - static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { - var fn = getMacroFn(env, form); - while (fn != null) { - MalList list = (MalList)form; - var args = new Object[(int)list.length]; - args[0] = fn.closedOverEnv; - int i=1; - list = list.tail; - while (!list.isEmpty()) { - args[i++] = list.head; - list = list.tail; - } - form = invokeNode.invoke(fn.callTarget, args, false); - fn = getMacroFn(env, form); - } - return form; - } - - static class MacroexpandNode extends MalNode { - @Child private InvokeNode invokeNode = new InvokeNode(false); - private final Object body; - - MacroexpandNode(MalList form) { - super(form); - this.body = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return macroexpand(invokeNode, env, body); - } - } - - static class ApplyNode extends MalNode { - final MalLanguage language; - final LexicalScope scope; - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private boolean usingCachedFn; - @CompilationFinal private MalFunction cachedFn; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition, LexicalScope scope) { - super(list); - this.language = language; - this.scope = scope; - fnNode = formToNode(language, list.head, false, scope); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false, scope); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @TruffleBoundary - private CallTarget applyMacro(MalEnv env, MalFunction fn) { - Object[] args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; ++i) { - args[i+1] = argNodes[i].form; - } - // We should never throw a tail call during expansion! - Object form = invokeNode.invoke(fn.callTarget, args, false); - var result = macroexpand(invokeNode, env, form); - var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition, scope); - return Truffle.getRuntime().createCallTarget(newRoot); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - cachedFn = fn; - usingCachedFn = true; - } - if (usingCachedFn) { - if (fn != cachedFn) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - usingCachedFn = false; - } else { - fn = cachedFn; - } - } - if (fn.isMacro) { - // Mal's macro semantics are... interesting. To preserve them in the - // general case, we must re-expand a macro each time it's applied. - // Executing the result means turning it into a Truffle AST, creating - // a CallTarget, calling it, and then throwing it away. - // This is TERRIBLE for performance! Truffle should not be used like this! - var target = applyMacro(env, fn); - return invokeNode.invoke(target, new Object[] {}, false); - } else { - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args, fn.canBeTailCalled); - } - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - private final boolean macro; - private final LexicalScope scope; - @Child private MalNode valueNode; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private EnvSlot slot; - - DefNode(MalLanguage language, MalList list, LexicalScope scope) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.macro = MalSymbol.DEFMACRO.equals(list.head); - this.scope = scope; - this.valueNode = formToNode(language, list.tail.tail.head, false, scope); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - if (macro) { - value = new MalFunction((MalFunction)value, true); - } - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - var slot = scope.getSlot(env, symbol); - if (slot != null && slot.height == 0) { - this.slot = slot; - } - } - if (slot != null) { - env.set(slot, value); - } else { - env.set(symbol, value); - } - return value; - } - } - - static class LetBindingNode extends Node { - private final EnvSlot slot; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm, LexicalScope scope) { - this.slot = scope.allocateSlot(symbol); - this.valueNode = formToNode(language, valueForm, false, scope); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(slot, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - private final LexicalScope scope; - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope outerScope) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - scope = new LexicalScope(outerScope); - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1), scope); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition, scope); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv, scope); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a form to be evaluated, together with an environment. - */ - static class MalRootNode extends RootNode { - final Object form; - final MalEnv env; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition, LexicalScope scope) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, tailPosition, scope); - this.env = env; - } - - @Override - public Object execute(VirtualFrame frame) { - return body.executeGeneric(frame, env); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1, scope); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { - super(form); - conditionNode = formToNode(language, form.tail.head, false, scope); - trueNode = formToNode(language, form.tail.tail.head, tailPosition, scope); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition, scope); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final int argPos; - protected final EnvSlot slot; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { - this.argPos = argPos; - this.slot = scope.allocateSlot(symbol); - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { - super(symbol, argPos, scope); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(slot, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos, LexicalScope scope) { - super(symbol, argPos, scope); - } - - @TruffleBoundary - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(slot, buildVarArgsList(frame.getArguments())); - } - } - - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - final LexicalScope scope; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form, LexicalScope outerScope) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - this.scope = new LexicalScope(outerScope); - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1, scope); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1, scope); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true, scope); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0], scope); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - - @Override - public String toString() { - return form.toString(); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form, LexicalScope scope) { - super(form); - fnRoot = new FnRootNode(language, form, scope); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - static class QuoteNode extends MalNode { - final Object quoted; - - QuoteNode(MalLanguage language, MalList form) { - super(form); - quoted = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return quoted; - } - } - - static class TryNode extends MalNode { - @Child private MalNode tryBody; - @Child private MalNode catchBody; - final EnvSlot exSlot; - final LexicalScope catchScope; - - TryNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { - super(form); - var tryForm = form.tail.head; - var catchForm = (MalList)form.tail.tail.head; - // We don't allow tail calls inside a try body, because - // they'd get thrown past the catch that should catch subsequent failures. - this.tryBody = formToNode(language, tryForm, false, scope); - if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { - catchScope = new LexicalScope(scope); - var exSymbol = (MalSymbol)catchForm.tail.head; - exSlot = catchScope.allocateSlot(exSymbol); - catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition, catchScope); - } else { - catchScope = null; - exSlot = null; - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - try { - return tryBody.executeGeneric(frame, env); - } catch (MalException ex) { - if (catchBody == null) { - throw ex; - } - var catchEnv = new MalEnv(env, catchScope); - catchEnv.set(exSlot, ex.obj); - return catchBody.executeGeneric(frame, catchEnv); - } - } - } - - final static class MalContext { - final MalEnv globalEnv; - final LexicalScope globalScope; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - globalScope = new LexicalScope(); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var ctx = getCurrentContext(MalLanguage.class); - var root = new MalRootNode(this, form, ctx.globalEnv, false, ctx.globalScope); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.Assumption; +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives; +import com.oracle.truffle.api.CompilerDirectives.CompilationFinal; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.DirectCallNode; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +import truffle.mal.LexicalScope.EnvSlot; +import truffle.mal.MalEnv.CachedResult; + +public class stepD_caching { + static final String LANGUAGE_ID = "mal_stepD"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + context.eval(LANGUAGE_ID, "(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)))))))"); + context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); + + var buf = new StringBuilder(); + buf.append("(def! *ARGV* (list"); + for (int i=1; i < args.length; i++) { + buf.append(' '); + buf.append(Printer.prStr(args[i], true)); + } + buf.append("))"); + context.eval(LANGUAGE_ID, buf.toString()); + + if (args.length > 0) { + context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); + return; + } + + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static boolean isPair(Object obj) { + return (obj instanceof MalList && ((MalList)obj).length > 0) + || + (obj instanceof MalVector && ((MalVector)obj).size() > 0); + } + + private static Object quasiquote(Object form) { + if (!isPair(form)) { + return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); + } + MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; + if (MalSymbol.UNQUOTE.equals(list.head)) { + return list.tail.head; + } + var result = new ArrayList(); + if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { + result.add(MalSymbol.get("concat")); + result.add(((MalList)list.head).tail.head); + } else { + result.add(MalSymbol.get("cons")); + result.add(quasiquote(list.head)); + } + result.add(quasiquote(list.tail)); + return MalList.from(result); + } + + @TruffleBoundary + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition, LexicalScope scope) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form, scope); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form, scope); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form, scope); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { + return new DefNode(language, list, scope); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition, scope); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition, scope); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition, scope); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list, scope); + } else if (MalSymbol.QUOTE.equals(head)) { + return new QuoteNode(language, list); + } else if (MalSymbol.QUASIQUOTE.equals(head)) { + return formToNode(language, quasiquote(list.tail.head), tailPosition, scope); + } else if (MalSymbol.MACROEXPAND.equals(head)) { + return new MacroexpandNode(list); + } else if (MalSymbol.TRY.equals(head)) { + return new TryNode(language, list, tailPosition, scope); + } else { + return new ApplyNode(language, list, tailPosition, scope); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector, LexicalScope scope) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false, scope); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new ArrayList<>(elementNodes.length); + for (int i=0; i < elementNodes.length; i++) { + elements.add(elementNodes[i].executeGeneric(frame, env)); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map, LexicalScope scope) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false, scope); + nodes[i++] = formToNode(language, entry.getValue(), false, scope); + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + var k = nodes[i].executeGeneric(frame, env); + var v = nodes[i+1].executeGeneric(frame, env); + result = result.assoc(k, v); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + private final LexicalScope scope; + @CompilationFinal boolean initialized = false; + @CompilationFinal EnvSlot slot; + @CompilationFinal CachedResult cachedResult; + @CompilationFinal Assumption notRedefined; + + LookupNode(MalSymbol symbol, LexicalScope scope) { + super(symbol); + this.symbol = symbol; + this.scope = scope; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + slot = scope.getSlot(env, symbol); + if (slot == null) { + cachedResult = env.cachedGet(symbol); + notRedefined = cachedResult.notRedefined; + } + } + Object result = null; + if (slot != null) { + if (slot.notDynamicallyBound.isValid()) { + result = env.get(slot); + } else { + result = env.get(symbol, slot); + } + } else { + if (notRedefined.isValid()) { + result = cachedResult.result; + } else { + result = env.get(symbol); + } + } + if (result == null) { + throw new MalException("'"+symbol.symbol+"' not found"); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private boolean usingCachedTarget; + @CompilationFinal private CallTarget cachedTarget; + @CompilationFinal @Child private DirectCallNode directCallNode; + @CompilationFinal @Child private IndirectCallNode indirectCallNode; + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + return invoke(target, args, true); + } + + Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { + if (tailPosition && allowTailCall) { + throw new TailCallException(target, args); + } else { + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + usingCachedTarget = true; + cachedTarget = target; + directCallNode = Truffle.getRuntime().createDirectCallNode(target); + } + while (true) { + try { + if (usingCachedTarget) { + if (cachedTarget == target) { + return directCallNode.call(args); + } + CompilerDirectives.transferToInterpreterAndInvalidate(); + usingCachedTarget = false; + indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); + } + return indirectCallNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + private static MalFunction getMacroFn(MalEnv env, Object form) { + if (!(form instanceof MalList)) + return null; + MalList list = (MalList)form; + if (!(list.head instanceof MalSymbol)) + return null; + MalSymbol fnSym = (MalSymbol)list.head; + var obj = env.get(fnSym); + if (obj == null) + return null; + if (!(obj instanceof MalFunction)) + return null; + MalFunction fn = (MalFunction)obj; + return fn.isMacro ? fn : null; + } + + static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { + var fn = getMacroFn(env, form); + while (fn != null) { + MalList list = (MalList)form; + var args = new Object[(int)list.length]; + args[0] = fn.closedOverEnv; + int i=1; + list = list.tail; + while (!list.isEmpty()) { + args[i++] = list.head; + list = list.tail; + } + form = invokeNode.invoke(fn.callTarget, args, false); + fn = getMacroFn(env, form); + } + return form; + } + + static class MacroexpandNode extends MalNode { + @Child private InvokeNode invokeNode = new InvokeNode(false); + private final Object body; + + MacroexpandNode(MalList form) { + super(form); + this.body = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return macroexpand(invokeNode, env, body); + } + } + + static class ApplyNode extends MalNode { + final MalLanguage language; + final LexicalScope scope; + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private boolean usingCachedFn; + @CompilationFinal private MalFunction cachedFn; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition, LexicalScope scope) { + super(list); + this.language = language; + this.scope = scope; + fnNode = formToNode(language, list.head, false, scope); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false, scope); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @TruffleBoundary + private CallTarget applyMacro(MalEnv env, MalFunction fn) { + Object[] args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; ++i) { + args[i+1] = argNodes[i].form; + } + // We should never throw a tail call during expansion! + Object form = invokeNode.invoke(fn.callTarget, args, false); + var result = macroexpand(invokeNode, env, form); + var newRoot = new MalRootNode(language, result, env, invokeNode.tailPosition, scope); + return Truffle.getRuntime().createCallTarget(newRoot); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + cachedFn = fn; + usingCachedFn = true; + } + if (usingCachedFn) { + if (fn != cachedFn) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + usingCachedFn = false; + } else { + fn = cachedFn; + } + } + if (fn.isMacro) { + // Mal's macro semantics are... interesting. To preserve them in the + // general case, we must re-expand a macro each time it's applied. + // Executing the result means turning it into a Truffle AST, creating + // a CallTarget, calling it, and then throwing it away. + // This is TERRIBLE for performance! Truffle should not be used like this! + var target = applyMacro(env, fn); + return invokeNode.invoke(target, new Object[] {}, false); + } else { + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args, fn.canBeTailCalled); + } + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + private final boolean macro; + private final LexicalScope scope; + @Child private MalNode valueNode; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private EnvSlot slot; + + DefNode(MalLanguage language, MalList list, LexicalScope scope) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.macro = MalSymbol.DEFMACRO.equals(list.head); + this.scope = scope; + this.valueNode = formToNode(language, list.tail.tail.head, false, scope); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + if (macro) { + value = new MalFunction((MalFunction)value, true); + } + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + var slot = scope.getSlot(env, symbol); + if (slot != null && slot.height == 0) { + this.slot = slot; + } + } + if (slot != null) { + env.set(slot, value); + } else { + env.set(symbol, value); + } + return value; + } + } + + static class LetBindingNode extends Node { + private final EnvSlot slot; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm, LexicalScope scope) { + this.slot = scope.allocateSlot(symbol); + this.valueNode = formToNode(language, valueForm, false, scope); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(slot, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + private final LexicalScope scope; + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope outerScope) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + scope = new LexicalScope(outerScope); + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1), scope); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition, scope); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv, scope); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a form to be evaluated, together with an environment. + */ + static class MalRootNode extends RootNode { + final Object form; + final MalEnv env; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition, LexicalScope scope) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, tailPosition, scope); + this.env = env; + } + + @Override + public Object execute(VirtualFrame frame) { + return body.executeGeneric(frame, env); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1, scope); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { + super(form); + conditionNode = formToNode(language, form.tail.head, false, scope); + trueNode = formToNode(language, form.tail.tail.head, tailPosition, scope); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition, scope); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final int argPos; + protected final EnvSlot slot; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { + this.argPos = argPos; + this.slot = scope.allocateSlot(symbol); + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { + super(symbol, argPos, scope); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(slot, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos, LexicalScope scope) { + super(symbol, argPos, scope); + } + + @TruffleBoundary + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(slot, buildVarArgsList(frame.getArguments())); + } + } + + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + final LexicalScope scope; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form, LexicalScope outerScope) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + this.scope = new LexicalScope(outerScope); + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1, scope); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1, scope); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true, scope); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0], scope); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + + @Override + public String toString() { + return form.toString(); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form, LexicalScope scope) { + super(form); + fnRoot = new FnRootNode(language, form, scope); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + static class QuoteNode extends MalNode { + final Object quoted; + + QuoteNode(MalLanguage language, MalList form) { + super(form); + quoted = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return quoted; + } + } + + static class TryNode extends MalNode { + @Child private MalNode tryBody; + @Child private MalNode catchBody; + final EnvSlot exSlot; + final LexicalScope catchScope; + + TryNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { + super(form); + var tryForm = form.tail.head; + var catchForm = (MalList)form.tail.tail.head; + // We don't allow tail calls inside a try body, because + // they'd get thrown past the catch that should catch subsequent failures. + this.tryBody = formToNode(language, tryForm, false, scope); + if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { + catchScope = new LexicalScope(scope); + var exSymbol = (MalSymbol)catchForm.tail.head; + exSlot = catchScope.allocateSlot(exSymbol); + catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition, catchScope); + } else { + catchScope = null; + exSlot = null; + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + try { + return tryBody.executeGeneric(frame, env); + } catch (MalException ex) { + if (catchBody == null) { + throw ex; + } + var catchEnv = new MalEnv(env, catchScope); + catchEnv.set(exSlot, ex.obj); + return catchBody.executeGeneric(frame, catchEnv); + } + } + } + + final static class MalContext { + final MalEnv globalEnv; + final LexicalScope globalScope; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + globalScope = new LexicalScope(); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var ctx = getCurrentContext(MalLanguage.class); + var root = new MalRootNode(this, form, ctx.globalEnv, false, ctx.globalScope); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java-truffle/src/main/java/truffle/mal/stepE_macros.java b/impls/java-truffle/src/main/java/truffle/mal/stepE_macros.java index b0f7f5202a..e941b05a13 100644 --- a/impls/java-truffle/src/main/java/truffle/mal/stepE_macros.java +++ b/impls/java-truffle/src/main/java/truffle/mal/stepE_macros.java @@ -1,905 +1,905 @@ -package truffle.mal; - -import java.io.BufferedReader; -import java.io.IOException; -import java.io.InputStreamReader; -import java.io.PrintStream; -import java.util.ArrayList; -import java.util.Collections; -import java.util.function.Function; - -import org.graalvm.polyglot.Context; -import org.graalvm.polyglot.PolyglotException; -import org.graalvm.polyglot.Value; - -import com.oracle.truffle.api.Assumption; -import com.oracle.truffle.api.CallTarget; -import com.oracle.truffle.api.CompilerDirectives; -import com.oracle.truffle.api.CompilerDirectives.CompilationFinal; -import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; -import com.oracle.truffle.api.RootCallTarget; -import com.oracle.truffle.api.Scope; -import com.oracle.truffle.api.Truffle; -import com.oracle.truffle.api.TruffleLanguage; -import com.oracle.truffle.api.frame.FrameDescriptor; -import com.oracle.truffle.api.frame.VirtualFrame; -import com.oracle.truffle.api.interop.TruffleObject; -import com.oracle.truffle.api.nodes.ControlFlowException; -import com.oracle.truffle.api.nodes.DirectCallNode; -import com.oracle.truffle.api.nodes.ExplodeLoop; -import com.oracle.truffle.api.nodes.IndirectCallNode; -import com.oracle.truffle.api.nodes.Node; -import com.oracle.truffle.api.nodes.RootNode; -import com.oracle.truffle.api.nodes.UnexpectedResultException; -import com.oracle.truffle.api.source.Source; - -import truffle.mal.LexicalScope.EnvSlot; -import truffle.mal.MalEnv.CachedResult; - -public class stepE_macros { - static final String LANGUAGE_ID = "mal_stepE"; - - public static void main(String[] args) throws IOException { - boolean done = false; - BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); - - var context = Context.create(LANGUAGE_ID); - context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); - context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - context.eval(LANGUAGE_ID, "(defmacro! cond ^{:inline? true} (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)))))))"); - context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); - - var buf = new StringBuilder(); - buf.append("(def! *ARGV* (list"); - for (int i=1; i < args.length; i++) { - buf.append(' '); - buf.append(Printer.prStr(args[i], true)); - } - buf.append("))"); - context.eval(LANGUAGE_ID, buf.toString()); - - if (args.length > 0) { - context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); - return; - } - - while (!done) { - System.out.print("user> "); - String s = reader.readLine(); - if (s == null) { - done = true; - } else { - try { - Value val = context.eval(LANGUAGE_ID, s); - context.getBindings(LANGUAGE_ID).putMember("*1", val); - context.eval(LANGUAGE_ID, "(prn *1)"); - } catch (PolyglotException ex) { - if (ex.isGuestException()) { - System.out.println("Error: "+ex.getMessage()); - } else { - throw ex; - } - } - } - } - } - - static class BuiltinFn implements TruffleObject { - final Function fn; - BuiltinFn(Function fn) { - this.fn = fn; - } - } - - static abstract class MalNode extends Node { - final Object form; - protected MalNode(Object form) { - this.form = form; - } - - public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); - - public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Long) { - return (long)value; - } - throw new UnexpectedResultException(value); - } - - public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { - var value = executeGeneric(frame, env); - if (value instanceof Boolean) { - return (boolean)value; - } - throw new UnexpectedResultException(value); - } - } - - private static boolean isPair(Object obj) { - return (obj instanceof MalList && ((MalList)obj).length > 0) - || - (obj instanceof MalVector && ((MalVector)obj).size() > 0); - } - - private static Object quasiquote(Object form) { - if (!isPair(form)) { - return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); - } - MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; - if (MalSymbol.UNQUOTE.equals(list.head)) { - return list.tail.head; - } - var result = new ArrayList(); - if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { - result.add(MalSymbol.get("concat")); - result.add(((MalList)list.head).tail.head); - } else { - result.add(MalSymbol.get("cons")); - result.add(quasiquote(list.head)); - } - result.add(quasiquote(list.tail)); - return MalList.from(result); - } - - @TruffleBoundary - private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition, LexicalScope scope) { - if (form instanceof MalSymbol) { - return new LookupNode((MalSymbol)form, scope); - } else if (form instanceof MalVector) { - return new VectorNode(language, (MalVector)form, scope); - } else if (form instanceof MalMap) { - return new MapNode(language, (MalMap)form, scope); - } else if (form instanceof MalList && !((MalList)form).isEmpty()) { - var list = (MalList)form; - var head = list.head; - if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { - return new DefNode(language, list, scope); - } else if (MalSymbol.LET_STAR.equals(head)) { - return new LetNode(language, list, tailPosition, scope); - } else if (MalSymbol.DO.equals(head)) { - return new DoNode(language, list, tailPosition, scope); - } else if (MalSymbol.IF.equals(head)) { - return new IfNode(language, list, tailPosition, scope); - } else if (MalSymbol.FN_STAR.equals(head)) { - return new FnNode(language, list, scope); - } else if (MalSymbol.QUOTE.equals(head)) { - return new QuoteNode(language, list); - } else if (MalSymbol.QUASIQUOTE.equals(head)) { - return formToNode(language, quasiquote(list.tail.head), tailPosition, scope); - } else if (MalSymbol.MACROEXPAND.equals(head)) { - return new MacroexpandNode(list); - } else if (MalSymbol.TRY.equals(head)) { - return new TryNode(language, list, tailPosition, scope); - } else { - return new ApplyNode(language, list, tailPosition, scope); - } - } else { - return new LiteralNode(form); - } - } - - static class LiteralNode extends MalNode { - LiteralNode(Object form) { - super(form); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return form; - } - } - - static class VectorNode extends MalNode { - @Children private MalNode[] elementNodes; - - VectorNode(MalLanguage language, MalVector vector, LexicalScope scope) { - super(vector); - this.elementNodes = new MalNode[vector.size()]; - for (int i=0; i < vector.size(); i++) { - elementNodes[i] = formToNode(language, vector.get(i), false, scope); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var elements = new Object[elementNodes.length]; - for (int i=0; i < elementNodes.length; i++) { - elements[i] = elementNodes[i].executeGeneric(frame, env); - } - return MalVector.EMPTY.concat(elements); - } - } - - static class MapNode extends MalNode { - @Children private MalNode[] nodes; - MapNode(MalLanguage language, MalMap map, LexicalScope scope) { - super(map); - nodes = new MalNode[map.map.size()*2]; - int i=0; - for (var entry : map.map) { - nodes[i++] = formToNode(language, entry.getKey(), false, scope); - nodes[i++] = formToNode(language, entry.getValue(), false, scope); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var result = MalMap.EMPTY; - for (int i=0; i < nodes.length; i += 2) { - var k = nodes[i].executeGeneric(frame, env); - var v = nodes[i+1].executeGeneric(frame, env); - result = result.assoc(k, v); - } - return result; - } - } - - static class LookupNode extends MalNode { - private final MalSymbol symbol; - private final LexicalScope scope; - @CompilationFinal boolean initialized = false; - @CompilationFinal EnvSlot slot; - @CompilationFinal CachedResult cachedResult; - @CompilationFinal Assumption notRedefined; - - LookupNode(MalSymbol symbol, LexicalScope scope) { - super(symbol); - this.symbol = symbol; - this.scope = scope; - } - - @TruffleBoundary - private void throwNotFound() { - throw new MalException("'"+symbol.symbol+"' not found"); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - slot = scope.getSlot(env, symbol); - if (slot == null) { - cachedResult = env.cachedGet(symbol); - notRedefined = cachedResult.notRedefined; - } - } - Object result = null; - if (slot != null) { - if (slot.notDynamicallyBound.isValid()) { - result = env.get(slot); - } else { - result = env.get(symbol, slot); - } - } else { - if (notRedefined.isValid()) { - result = cachedResult.result; - } else { - result = env.get(symbol); - } - } - if (result == null) { - throwNotFound(); - } - return result; - } - } - - @SuppressWarnings("serial") - static class TailCallException extends ControlFlowException { - final CallTarget callTarget; - final Object[] args; - TailCallException(CallTarget target, Object[] args) { - this.callTarget = target; - this.args = args; - } - } - - static class InvokeNode extends AbstractInvokeNode { - final boolean tailPosition; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private boolean usingCachedTarget; - @CompilationFinal private CallTarget cachedTarget; - @CompilationFinal @Child private DirectCallNode directCallNode; - @CompilationFinal @Child private IndirectCallNode indirectCallNode; - - InvokeNode(boolean tailPosition) { - this.tailPosition = tailPosition; - } - - Object invoke(CallTarget target, Object[] args) { - return invoke(target, args, true); - } - - Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { - if (tailPosition && allowTailCall) { - throw new TailCallException(target, args); - } else { - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - usingCachedTarget = true; - cachedTarget = target; - directCallNode = Truffle.getRuntime().createDirectCallNode(target); - } - while (true) { - try { - if (usingCachedTarget) { - if (cachedTarget == target) { - return directCallNode.call(args); - } - CompilerDirectives.transferToInterpreterAndInvalidate(); - usingCachedTarget = false; - indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); - } - return indirectCallNode.call(target, args); - } catch (TailCallException ex) { - target = ex.callTarget; - args = ex.args; - } - } - } - } - } - - private static MalFunction getMacroFn(MalEnv env, Object form) { - if (!(form instanceof MalList)) - return null; - MalList list = (MalList)form; - if (!(list.head instanceof MalSymbol)) - return null; - MalSymbol fnSym = (MalSymbol)list.head; - var obj = env.get(fnSym); - if (obj == null) - return null; - if (!(obj instanceof MalFunction)) - return null; - MalFunction fn = (MalFunction)obj; - return fn.isMacro ? fn : null; - } - - static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { - var fn = getMacroFn(env, form); - while (fn != null) { - MalList list = (MalList)form; - var args = new Object[(int)list.length]; - args[0] = fn.closedOverEnv; - int i=1; - list = list.tail; - while (!list.isEmpty()) { - args[i++] = list.head; - list = list.tail; - } - form = invokeNode.invoke(fn.callTarget, args, false); - fn = getMacroFn(env, form); - } - return form; - } - - static class MacroexpandNode extends MalNode { - @Child private InvokeNode invokeNode = new InvokeNode(false); - private final Object body; - - MacroexpandNode(MalList form) { - super(form); - this.body = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return macroexpand(invokeNode, env, body); - } - } - - private static boolean isInlinableMacro(MalFunction fn) { - var meta = fn.getMeta(); - if (meta == null || !(meta instanceof MalMap)) - return false; - var inline = ((MalMap)meta).get(MalKeyword.INLINE_Q); - return Boolean.TRUE.equals(inline); - } - - static class InlinedMacroNode extends MalNode { - @Child private DirectCallNode node; - InlinedMacroNode(Object form, CallTarget target) { - super(form); - node = Truffle.getRuntime().createDirectCallNode(target); - } - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return node.call(); - } - } - - static class ApplyNode extends MalNode { - final MalLanguage language; - final LexicalScope scope; - @Child private MalNode fnNode; - @Children private MalNode[] argNodes; - @Child private InvokeNode invokeNode; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private boolean usingCachedFn; - @CompilationFinal private MalFunction cachedFn; - - ApplyNode(MalLanguage language, MalList list, boolean tailPosition, LexicalScope scope) { - super(list); - this.language = language; - this.scope = scope; - fnNode = formToNode(language, list.head, false, scope); - argNodes = new MalNode[list.length-1]; - int i=0; - list = list.tail; - while (!list.isEmpty()) { - argNodes[i++] = formToNode(language, list.head, false, scope); - list = list.tail; - } - invokeNode = new InvokeNode(tailPosition); - } - - @TruffleBoundary - private MalRootNode applyMacro(MalEnv env, MalFunction fn) { - Object[] args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; ++i) { - args[i+1] = argNodes[i].form; - } - // We should never throw a tail call during expansion! - Object form = invokeNode.invoke(fn.callTarget, args, false); - var result = macroexpand(invokeNode, env, form); - return new MalRootNode(language, result, env, invokeNode.tailPosition, scope); - } - - @TruffleBoundary - private Object invokeMacro(MalRootNode macroNode) { - // Mal's macro semantics are... interesting. To preserve them in the - // general case, we must re-expand a macro each time it's applied. - // Executing the result means turning it into a Truffle AST, creating - // a CallTarget, calling it, and then throwing it away. - // This is TERRIBLE for performance! Truffle should not be used like this! - var target = Truffle.getRuntime().createCallTarget(macroNode); - return invokeNode.invoke(target, new Object[] {}, false); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var fn = (MalFunction)fnNode.executeGeneric(frame, env); - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - cachedFn = fn; - usingCachedFn = true; - } - if (usingCachedFn) { - if (fn != cachedFn) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - usingCachedFn = false; - } else { - fn = cachedFn; - } - } - if (fn.isMacro) { - var expanded = applyMacro(env, fn); - if (isInlinableMacro(fn)) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - var newNode = expanded.body; - this.replace(newNode); - return newNode.executeGeneric(frame, env); - } else { - return invokeMacro(expanded); - } - } else { - var args = new Object[argNodes.length+1]; - args[0] = fn.closedOverEnv; - for (int i=0; i < argNodes.length; i++) { - args[i+1] = argNodes[i].executeGeneric(frame, env); - } - return invokeNode.invoke(fn.callTarget, args, fn.canBeTailCalled); - } - } - } - - static class DefNode extends MalNode { - private final MalSymbol symbol; - private final boolean macro; - private final LexicalScope scope; - @Child private MalNode valueNode; - @CompilationFinal private boolean initialized = false; - @CompilationFinal private EnvSlot slot; - - DefNode(MalLanguage language, MalList list, LexicalScope scope) { - super(list); - this.symbol = (MalSymbol)list.tail.head; - this.macro = MalSymbol.DEFMACRO.equals(list.head); - this.scope = scope; - this.valueNode = formToNode(language, list.tail.tail.head, false, scope); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var value = valueNode.executeGeneric(frame, env); - if (macro) { - value = new MalFunction((MalFunction)value, true); - } - if (!initialized) { - CompilerDirectives.transferToInterpreterAndInvalidate(); - initialized = true; - var slot = scope.getSlot(env, symbol); - if (slot != null && slot.height == 0) { - this.slot = slot; - } - } - if (slot != null) { - env.set(slot, value); - } else { - env.set(symbol, value); - } - return value; - } - } - - static class LetBindingNode extends Node { - private final EnvSlot slot; - @Child private MalNode valueNode; - - LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm, LexicalScope scope) { - this.slot = scope.allocateSlot(symbol); - this.valueNode = formToNode(language, valueForm, false, scope); - } - - public void executeGeneric(VirtualFrame frame, MalEnv env) { - env.set(slot, valueNode.executeGeneric(frame, env)); - } - } - - static class LetNode extends MalNode { - private final LexicalScope scope; - @Children private LetBindingNode[] bindings; - @Child private MalNode bodyNode; - - LetNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope outerScope) { - super(form); - var bindingForms = new ArrayList(); - assert form.tail.head instanceof Iterable; - ((Iterable)form.tail.head).forEach(bindingForms::add); - bindings = new LetBindingNode[bindingForms.size()/2]; - scope = new LexicalScope(outerScope); - for (int i=0; i < bindingForms.size(); i+=2) { - bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1), scope); - } - bodyNode = formToNode(language, form.tail.tail.head, tailPosition, scope); - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { - var innerEnv = new MalEnv(outerEnv, scope); - for (int i=0; i < bindings.length; i++) { - bindings[i].executeGeneric(frame, innerEnv); - } - return bodyNode.executeGeneric(frame, innerEnv); - } - } - - /** - * Represents a form to be evaluated, together with an environment. - */ - static class MalRootNode extends RootNode { - final Object form; - final MalEnv env; - @Child MalNode body; - - MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition, LexicalScope scope) { - super(language, new FrameDescriptor()); - this.form = form; - // There's no stack to unwind at the top level, so - // a top-level form is never in tail position. - this.body = formToNode(language, form, tailPosition, scope); - this.env = env; - } - - @Override - public Object execute(VirtualFrame frame) { - return body.executeGeneric(frame, env); - } - - @Override - public String toString() { - return Printer.prStr(form, true); - } - } - - static class DoNode extends MalNode { - @Children private MalNode[] bodyNodes; - - DoNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { - super(form); - bodyNodes = new MalNode[form.length-1]; - int i = 0; - for (var f : form.tail) { - bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1, scope); - } - } - - @ExplodeLoop - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - if (bodyNodes.length == 0) { - return MalNil.NIL; - } - - for (int i=0; i < bodyNodes.length-1; i++) { - bodyNodes[i].executeGeneric(frame, env); - } - return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); - } - } - - static class IfNode extends MalNode { - @Child private MalNode conditionNode; - @Child private MalNode trueNode; - @Child private MalNode falseNode; - - IfNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { - super(form); - conditionNode = formToNode(language, form.tail.head, false, scope); - trueNode = formToNode(language, form.tail.tail.head, tailPosition, scope); - var falseForm = form.tail.tail.tail.head; - falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition, scope); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - var val = conditionNode.executeGeneric(frame, env); - if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { - if (falseNode == null) { - return MalNil.NIL; - } else { - return falseNode.executeGeneric(frame, env); - } - } else { - return trueNode.executeGeneric(frame, env); - } - } - } - - static abstract class AbstractBindArgNode extends Node { - protected final int argPos; - protected final EnvSlot slot; - - protected AbstractBindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { - this.argPos = argPos; - this.slot = scope.allocateSlot(symbol); - } - - public abstract void execute(VirtualFrame frame, MalEnv env); - } - - static class BindArgNode extends AbstractBindArgNode { - - public BindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { - super(symbol, argPos, scope); - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - env.set(slot, frame.getArguments()[argPos]); - } - } - - static class BindVarargsNode extends BindArgNode { - public BindVarargsNode(MalSymbol symbol, int argPos, LexicalScope scope) { - super(symbol, argPos, scope); - } - - private MalList buildVarArgsList(Object[] args) { - MalList varArgs = MalList.EMPTY; - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - return varArgs; - } - - @Override - public void execute(VirtualFrame frame, MalEnv env) { - //env.set(slot, buildVarArgsList(frame.getArguments())); - MalList varArgs = MalList.EMPTY; - var args = frame.getArguments(); - for (int i=args.length-1; i >= argPos; --i) { - varArgs = varArgs.cons(args[i]); - } - //env.set(slot, varArgs); - env.staticBindings[slot.slotNum] = varArgs; - } - } - - /** - * Root node of a user-defined function, responsible for managing - * the environment when the function is invoked. - */ - static class FnRootNode extends RootNode { - final MalList form; - final int numArgs; - final LexicalScope scope; - @Children AbstractBindArgNode[] bindNodes; - @Child MalNode bodyNode; - - FnRootNode(MalLanguage language, MalList form, LexicalScope outerScope) { - super(language, new FrameDescriptor()); - this.form = form; - var argNamesList = new ArrayList(); - assert form.tail.head instanceof Iterable; - var foundAmpersand = false; - for (var name : (Iterable)form.tail.head) { - if (MalSymbol.AMPERSAND.equals(name)) { - foundAmpersand = true; - } else { - argNamesList.add((MalSymbol)name); - } - } - this.numArgs = foundAmpersand? -1 : argNamesList.size(); - this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; - this.scope = new LexicalScope(outerScope); - for (int i=0; i < argNamesList.size(); i++) { - if (numArgs == -1 && i == argNamesList.size()-1) { - bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1, scope); - } else { - bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1, scope); - } - } - this.bodyNode = formToNode(language, form.tail.tail.head, true, scope); - } - - @ExplodeLoop - @Override - public Object execute(VirtualFrame frame) { - var env = new MalEnv((MalEnv)frame.getArguments()[0], scope); - for (int i=0; i < bindNodes.length; i++) { - bindNodes[i].execute(frame, env); - } - return bodyNode.executeGeneric(frame, env); - } - - @Override - public String toString() { - return form.toString(); - } - } - - /** - * Node representing a (fn* ...) form. - */ - static class FnNode extends MalNode { - final FnRootNode fnRoot; - final RootCallTarget fnCallTarget; - - FnNode(MalLanguage language, MalList form, LexicalScope scope) { - super(form); - fnRoot = new FnRootNode(language, form, scope); - this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return new MalFunction(fnCallTarget, env, fnRoot.numArgs); - } - } - - static class QuoteNode extends MalNode { - final Object quoted; - - QuoteNode(MalLanguage language, MalList form) { - super(form); - quoted = form.tail.head; - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - return quoted; - } - } - - static class TryNode extends MalNode { - @Child private MalNode tryBody; - @Child private MalNode catchBody; - final EnvSlot exSlot; - final LexicalScope catchScope; - - TryNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { - super(form); - var tryForm = form.tail.head; - var catchForm = (MalList)form.tail.tail.head; - // We don't allow tail calls inside a try body, because - // they'd get thrown past the catch that should catch subsequent failures. - this.tryBody = formToNode(language, tryForm, false, scope); - if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { - catchScope = new LexicalScope(scope); - var exSymbol = (MalSymbol)catchForm.tail.head; - exSlot = catchScope.allocateSlot(exSymbol); - catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition, catchScope); - } else { - catchScope = null; - exSlot = null; - } - } - - @Override - public Object executeGeneric(VirtualFrame frame, MalEnv env) { - try { - return tryBody.executeGeneric(frame, env); - } catch (MalException ex) { - if (catchBody == null) { - throw ex; - } - var catchEnv = new MalEnv(env, catchScope); - catchEnv.set(exSlot, ex.obj); - return catchBody.executeGeneric(frame, catchEnv); - } - } - } - - final static class MalContext { - final MalEnv globalEnv; - final LexicalScope globalScope; - final Iterable topScopes; - final PrintStream out; - final BufferedReader in; - - MalContext(MalLanguage language) { - globalEnv = Core.newGlobalEnv(MalLanguage.class, language); - globalScope = new LexicalScope(); - topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); - out = System.out; - in = new BufferedReader(new InputStreamReader(System.in)); - } - } - - @TruffleLanguage.Registration( - id=LANGUAGE_ID, - name=LANGUAGE_ID, - defaultMimeType = "application/x-"+LANGUAGE_ID, - characterMimeTypes = "application/x-"+LANGUAGE_ID) - public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { - @Override - protected MalContext createContext(Env env) { - return new MalContext(this); - } - - @Override - public CallTarget evalForm(Object form) { - var ctx = getCurrentContext(MalLanguage.class); - var root = new MalRootNode(this, form, ctx.globalEnv, false, ctx.globalScope); - return Truffle.getRuntime().createCallTarget(root); - } - - @Override - public AbstractInvokeNode invokeNode() { - return new InvokeNode(false); - } - - @Override - protected CallTarget parse(ParsingRequest request) throws Exception { - Source source = request.getSource(); - String s = source.getCharacters().toString(); - return evalForm(Reader.readStr(s)); - } - - @Override - protected Iterable findTopScopes(MalContext context) { - return context.topScopes; - } - - @Override - public PrintStream out() { - return getCurrentContext(MalLanguage.class).out; - } - - @Override - public BufferedReader in() { - return getCurrentContext(MalLanguage.class).in; - } - } -} +package truffle.mal; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStreamReader; +import java.io.PrintStream; +import java.util.ArrayList; +import java.util.Collections; +import java.util.function.Function; + +import org.graalvm.polyglot.Context; +import org.graalvm.polyglot.PolyglotException; +import org.graalvm.polyglot.Value; + +import com.oracle.truffle.api.Assumption; +import com.oracle.truffle.api.CallTarget; +import com.oracle.truffle.api.CompilerDirectives; +import com.oracle.truffle.api.CompilerDirectives.CompilationFinal; +import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary; +import com.oracle.truffle.api.RootCallTarget; +import com.oracle.truffle.api.Scope; +import com.oracle.truffle.api.Truffle; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.frame.FrameDescriptor; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.interop.TruffleObject; +import com.oracle.truffle.api.nodes.ControlFlowException; +import com.oracle.truffle.api.nodes.DirectCallNode; +import com.oracle.truffle.api.nodes.ExplodeLoop; +import com.oracle.truffle.api.nodes.IndirectCallNode; +import com.oracle.truffle.api.nodes.Node; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.nodes.UnexpectedResultException; +import com.oracle.truffle.api.source.Source; + +import truffle.mal.LexicalScope.EnvSlot; +import truffle.mal.MalEnv.CachedResult; + +public class stepE_macros { + static final String LANGUAGE_ID = "mal_stepE"; + + public static void main(String[] args) throws IOException { + boolean done = false; + BufferedReader reader = new BufferedReader(new InputStreamReader(System.in)); + + var context = Context.create(LANGUAGE_ID); + context.eval(LANGUAGE_ID, "(def! not (fn* [a] (if a false true)))"); + context.eval(LANGUAGE_ID, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + context.eval(LANGUAGE_ID, "(defmacro! cond ^{:inline? true} (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)))))))"); + context.eval(LANGUAGE_ID, "(def! *host-language* \"java-truffle\")"); + + var buf = new StringBuilder(); + buf.append("(def! *ARGV* (list"); + for (int i=1; i < args.length; i++) { + buf.append(' '); + buf.append(Printer.prStr(args[i], true)); + } + buf.append("))"); + context.eval(LANGUAGE_ID, buf.toString()); + + if (args.length > 0) { + context.eval(LANGUAGE_ID, "(load-file \""+args[0]+"\")"); + return; + } + + while (!done) { + System.out.print("user> "); + String s = reader.readLine(); + if (s == null) { + done = true; + } else { + try { + Value val = context.eval(LANGUAGE_ID, s); + context.getBindings(LANGUAGE_ID).putMember("*1", val); + context.eval(LANGUAGE_ID, "(prn *1)"); + } catch (PolyglotException ex) { + if (ex.isGuestException()) { + System.out.println("Error: "+ex.getMessage()); + } else { + throw ex; + } + } + } + } + } + + static class BuiltinFn implements TruffleObject { + final Function fn; + BuiltinFn(Function fn) { + this.fn = fn; + } + } + + static abstract class MalNode extends Node { + final Object form; + protected MalNode(Object form) { + this.form = form; + } + + public abstract Object executeGeneric(VirtualFrame frame, MalEnv env); + + public long executeLong(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Long) { + return (long)value; + } + throw new UnexpectedResultException(value); + } + + public boolean executeBoolean(VirtualFrame frame, MalEnv env) throws UnexpectedResultException { + var value = executeGeneric(frame, env); + if (value instanceof Boolean) { + return (boolean)value; + } + throw new UnexpectedResultException(value); + } + } + + private static boolean isPair(Object obj) { + return (obj instanceof MalList && ((MalList)obj).length > 0) + || + (obj instanceof MalVector && ((MalVector)obj).size() > 0); + } + + private static Object quasiquote(Object form) { + if (!isPair(form)) { + return MalList.EMPTY.cons(form).cons(MalSymbol.QUOTE); + } + MalList list = (form instanceof MalVector) ? ((MalVector)form).toList() : (MalList)form; + if (MalSymbol.UNQUOTE.equals(list.head)) { + return list.tail.head; + } + var result = new ArrayList(); + if (isPair(list.head) && MalSymbol.SPLICE_UNQUOTE.equals(((MalList)list.head).head)) { + result.add(MalSymbol.get("concat")); + result.add(((MalList)list.head).tail.head); + } else { + result.add(MalSymbol.get("cons")); + result.add(quasiquote(list.head)); + } + result.add(quasiquote(list.tail)); + return MalList.from(result); + } + + @TruffleBoundary + private static MalNode formToNode(MalLanguage language, Object form, boolean tailPosition, LexicalScope scope) { + if (form instanceof MalSymbol) { + return new LookupNode((MalSymbol)form, scope); + } else if (form instanceof MalVector) { + return new VectorNode(language, (MalVector)form, scope); + } else if (form instanceof MalMap) { + return new MapNode(language, (MalMap)form, scope); + } else if (form instanceof MalList && !((MalList)form).isEmpty()) { + var list = (MalList)form; + var head = list.head; + if (MalSymbol.DEF_BANG.equals(head) || MalSymbol.DEFMACRO.equals(head)) { + return new DefNode(language, list, scope); + } else if (MalSymbol.LET_STAR.equals(head)) { + return new LetNode(language, list, tailPosition, scope); + } else if (MalSymbol.DO.equals(head)) { + return new DoNode(language, list, tailPosition, scope); + } else if (MalSymbol.IF.equals(head)) { + return new IfNode(language, list, tailPosition, scope); + } else if (MalSymbol.FN_STAR.equals(head)) { + return new FnNode(language, list, scope); + } else if (MalSymbol.QUOTE.equals(head)) { + return new QuoteNode(language, list); + } else if (MalSymbol.QUASIQUOTE.equals(head)) { + return formToNode(language, quasiquote(list.tail.head), tailPosition, scope); + } else if (MalSymbol.MACROEXPAND.equals(head)) { + return new MacroexpandNode(list); + } else if (MalSymbol.TRY.equals(head)) { + return new TryNode(language, list, tailPosition, scope); + } else { + return new ApplyNode(language, list, tailPosition, scope); + } + } else { + return new LiteralNode(form); + } + } + + static class LiteralNode extends MalNode { + LiteralNode(Object form) { + super(form); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return form; + } + } + + static class VectorNode extends MalNode { + @Children private MalNode[] elementNodes; + + VectorNode(MalLanguage language, MalVector vector, LexicalScope scope) { + super(vector); + this.elementNodes = new MalNode[vector.size()]; + for (int i=0; i < vector.size(); i++) { + elementNodes[i] = formToNode(language, vector.get(i), false, scope); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var elements = new Object[elementNodes.length]; + for (int i=0; i < elementNodes.length; i++) { + elements[i] = elementNodes[i].executeGeneric(frame, env); + } + return MalVector.EMPTY.concat(elements); + } + } + + static class MapNode extends MalNode { + @Children private MalNode[] nodes; + MapNode(MalLanguage language, MalMap map, LexicalScope scope) { + super(map); + nodes = new MalNode[map.map.size()*2]; + int i=0; + for (var entry : map.map) { + nodes[i++] = formToNode(language, entry.getKey(), false, scope); + nodes[i++] = formToNode(language, entry.getValue(), false, scope); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var result = MalMap.EMPTY; + for (int i=0; i < nodes.length; i += 2) { + var k = nodes[i].executeGeneric(frame, env); + var v = nodes[i+1].executeGeneric(frame, env); + result = result.assoc(k, v); + } + return result; + } + } + + static class LookupNode extends MalNode { + private final MalSymbol symbol; + private final LexicalScope scope; + @CompilationFinal boolean initialized = false; + @CompilationFinal EnvSlot slot; + @CompilationFinal CachedResult cachedResult; + @CompilationFinal Assumption notRedefined; + + LookupNode(MalSymbol symbol, LexicalScope scope) { + super(symbol); + this.symbol = symbol; + this.scope = scope; + } + + @TruffleBoundary + private void throwNotFound() { + throw new MalException("'"+symbol.symbol+"' not found"); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + slot = scope.getSlot(env, symbol); + if (slot == null) { + cachedResult = env.cachedGet(symbol); + notRedefined = cachedResult.notRedefined; + } + } + Object result = null; + if (slot != null) { + if (slot.notDynamicallyBound.isValid()) { + result = env.get(slot); + } else { + result = env.get(symbol, slot); + } + } else { + if (notRedefined.isValid()) { + result = cachedResult.result; + } else { + result = env.get(symbol); + } + } + if (result == null) { + throwNotFound(); + } + return result; + } + } + + @SuppressWarnings("serial") + static class TailCallException extends ControlFlowException { + final CallTarget callTarget; + final Object[] args; + TailCallException(CallTarget target, Object[] args) { + this.callTarget = target; + this.args = args; + } + } + + static class InvokeNode extends AbstractInvokeNode { + final boolean tailPosition; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private boolean usingCachedTarget; + @CompilationFinal private CallTarget cachedTarget; + @CompilationFinal @Child private DirectCallNode directCallNode; + @CompilationFinal @Child private IndirectCallNode indirectCallNode; + + InvokeNode(boolean tailPosition) { + this.tailPosition = tailPosition; + } + + Object invoke(CallTarget target, Object[] args) { + return invoke(target, args, true); + } + + Object invoke(CallTarget target, Object[] args, boolean allowTailCall) { + if (tailPosition && allowTailCall) { + throw new TailCallException(target, args); + } else { + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + usingCachedTarget = true; + cachedTarget = target; + directCallNode = Truffle.getRuntime().createDirectCallNode(target); + } + while (true) { + try { + if (usingCachedTarget) { + if (cachedTarget == target) { + return directCallNode.call(args); + } + CompilerDirectives.transferToInterpreterAndInvalidate(); + usingCachedTarget = false; + indirectCallNode = Truffle.getRuntime().createIndirectCallNode(); + } + return indirectCallNode.call(target, args); + } catch (TailCallException ex) { + target = ex.callTarget; + args = ex.args; + } + } + } + } + } + + private static MalFunction getMacroFn(MalEnv env, Object form) { + if (!(form instanceof MalList)) + return null; + MalList list = (MalList)form; + if (!(list.head instanceof MalSymbol)) + return null; + MalSymbol fnSym = (MalSymbol)list.head; + var obj = env.get(fnSym); + if (obj == null) + return null; + if (!(obj instanceof MalFunction)) + return null; + MalFunction fn = (MalFunction)obj; + return fn.isMacro ? fn : null; + } + + static Object macroexpand(InvokeNode invokeNode, MalEnv env, Object form) { + var fn = getMacroFn(env, form); + while (fn != null) { + MalList list = (MalList)form; + var args = new Object[(int)list.length]; + args[0] = fn.closedOverEnv; + int i=1; + list = list.tail; + while (!list.isEmpty()) { + args[i++] = list.head; + list = list.tail; + } + form = invokeNode.invoke(fn.callTarget, args, false); + fn = getMacroFn(env, form); + } + return form; + } + + static class MacroexpandNode extends MalNode { + @Child private InvokeNode invokeNode = new InvokeNode(false); + private final Object body; + + MacroexpandNode(MalList form) { + super(form); + this.body = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return macroexpand(invokeNode, env, body); + } + } + + private static boolean isInlinableMacro(MalFunction fn) { + var meta = fn.getMeta(); + if (meta == null || !(meta instanceof MalMap)) + return false; + var inline = ((MalMap)meta).get(MalKeyword.INLINE_Q); + return Boolean.TRUE.equals(inline); + } + + static class InlinedMacroNode extends MalNode { + @Child private DirectCallNode node; + InlinedMacroNode(Object form, CallTarget target) { + super(form); + node = Truffle.getRuntime().createDirectCallNode(target); + } + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return node.call(); + } + } + + static class ApplyNode extends MalNode { + final MalLanguage language; + final LexicalScope scope; + @Child private MalNode fnNode; + @Children private MalNode[] argNodes; + @Child private InvokeNode invokeNode; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private boolean usingCachedFn; + @CompilationFinal private MalFunction cachedFn; + + ApplyNode(MalLanguage language, MalList list, boolean tailPosition, LexicalScope scope) { + super(list); + this.language = language; + this.scope = scope; + fnNode = formToNode(language, list.head, false, scope); + argNodes = new MalNode[list.length-1]; + int i=0; + list = list.tail; + while (!list.isEmpty()) { + argNodes[i++] = formToNode(language, list.head, false, scope); + list = list.tail; + } + invokeNode = new InvokeNode(tailPosition); + } + + @TruffleBoundary + private MalRootNode applyMacro(MalEnv env, MalFunction fn) { + Object[] args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; ++i) { + args[i+1] = argNodes[i].form; + } + // We should never throw a tail call during expansion! + Object form = invokeNode.invoke(fn.callTarget, args, false); + var result = macroexpand(invokeNode, env, form); + return new MalRootNode(language, result, env, invokeNode.tailPosition, scope); + } + + @TruffleBoundary + private Object invokeMacro(MalRootNode macroNode) { + // Mal's macro semantics are... interesting. To preserve them in the + // general case, we must re-expand a macro each time it's applied. + // Executing the result means turning it into a Truffle AST, creating + // a CallTarget, calling it, and then throwing it away. + // This is TERRIBLE for performance! Truffle should not be used like this! + var target = Truffle.getRuntime().createCallTarget(macroNode); + return invokeNode.invoke(target, new Object[] {}, false); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var fn = (MalFunction)fnNode.executeGeneric(frame, env); + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + cachedFn = fn; + usingCachedFn = true; + } + if (usingCachedFn) { + if (fn != cachedFn) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + usingCachedFn = false; + } else { + fn = cachedFn; + } + } + if (fn.isMacro) { + var expanded = applyMacro(env, fn); + if (isInlinableMacro(fn)) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + var newNode = expanded.body; + this.replace(newNode); + return newNode.executeGeneric(frame, env); + } else { + return invokeMacro(expanded); + } + } else { + var args = new Object[argNodes.length+1]; + args[0] = fn.closedOverEnv; + for (int i=0; i < argNodes.length; i++) { + args[i+1] = argNodes[i].executeGeneric(frame, env); + } + return invokeNode.invoke(fn.callTarget, args, fn.canBeTailCalled); + } + } + } + + static class DefNode extends MalNode { + private final MalSymbol symbol; + private final boolean macro; + private final LexicalScope scope; + @Child private MalNode valueNode; + @CompilationFinal private boolean initialized = false; + @CompilationFinal private EnvSlot slot; + + DefNode(MalLanguage language, MalList list, LexicalScope scope) { + super(list); + this.symbol = (MalSymbol)list.tail.head; + this.macro = MalSymbol.DEFMACRO.equals(list.head); + this.scope = scope; + this.valueNode = formToNode(language, list.tail.tail.head, false, scope); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var value = valueNode.executeGeneric(frame, env); + if (macro) { + value = new MalFunction((MalFunction)value, true); + } + if (!initialized) { + CompilerDirectives.transferToInterpreterAndInvalidate(); + initialized = true; + var slot = scope.getSlot(env, symbol); + if (slot != null && slot.height == 0) { + this.slot = slot; + } + } + if (slot != null) { + env.set(slot, value); + } else { + env.set(symbol, value); + } + return value; + } + } + + static class LetBindingNode extends Node { + private final EnvSlot slot; + @Child private MalNode valueNode; + + LetBindingNode(MalLanguage language, MalSymbol symbol, Object valueForm, LexicalScope scope) { + this.slot = scope.allocateSlot(symbol); + this.valueNode = formToNode(language, valueForm, false, scope); + } + + public void executeGeneric(VirtualFrame frame, MalEnv env) { + env.set(slot, valueNode.executeGeneric(frame, env)); + } + } + + static class LetNode extends MalNode { + private final LexicalScope scope; + @Children private LetBindingNode[] bindings; + @Child private MalNode bodyNode; + + LetNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope outerScope) { + super(form); + var bindingForms = new ArrayList(); + assert form.tail.head instanceof Iterable; + ((Iterable)form.tail.head).forEach(bindingForms::add); + bindings = new LetBindingNode[bindingForms.size()/2]; + scope = new LexicalScope(outerScope); + for (int i=0; i < bindingForms.size(); i+=2) { + bindings[i/2] = new LetBindingNode(language, (MalSymbol)bindingForms.get(i), bindingForms.get(i+1), scope); + } + bodyNode = formToNode(language, form.tail.tail.head, tailPosition, scope); + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv outerEnv) { + var innerEnv = new MalEnv(outerEnv, scope); + for (int i=0; i < bindings.length; i++) { + bindings[i].executeGeneric(frame, innerEnv); + } + return bodyNode.executeGeneric(frame, innerEnv); + } + } + + /** + * Represents a form to be evaluated, together with an environment. + */ + static class MalRootNode extends RootNode { + final Object form; + final MalEnv env; + @Child MalNode body; + + MalRootNode(MalLanguage language, Object form, MalEnv env, boolean tailPosition, LexicalScope scope) { + super(language, new FrameDescriptor()); + this.form = form; + // There's no stack to unwind at the top level, so + // a top-level form is never in tail position. + this.body = formToNode(language, form, tailPosition, scope); + this.env = env; + } + + @Override + public Object execute(VirtualFrame frame) { + return body.executeGeneric(frame, env); + } + + @Override + public String toString() { + return Printer.prStr(form, true); + } + } + + static class DoNode extends MalNode { + @Children private MalNode[] bodyNodes; + + DoNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { + super(form); + bodyNodes = new MalNode[form.length-1]; + int i = 0; + for (var f : form.tail) { + bodyNodes[i++] = formToNode(language, f, tailPosition && i == form.length-1, scope); + } + } + + @ExplodeLoop + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + if (bodyNodes.length == 0) { + return MalNil.NIL; + } + + for (int i=0; i < bodyNodes.length-1; i++) { + bodyNodes[i].executeGeneric(frame, env); + } + return bodyNodes[bodyNodes.length-1].executeGeneric(frame, env); + } + } + + static class IfNode extends MalNode { + @Child private MalNode conditionNode; + @Child private MalNode trueNode; + @Child private MalNode falseNode; + + IfNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { + super(form); + conditionNode = formToNode(language, form.tail.head, false, scope); + trueNode = formToNode(language, form.tail.tail.head, tailPosition, scope); + var falseForm = form.tail.tail.tail.head; + falseNode = falseForm == null ? null : formToNode(language, falseForm, tailPosition, scope); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + var val = conditionNode.executeGeneric(frame, env); + if (val == MalNil.NIL || Boolean.FALSE.equals(val)) { + if (falseNode == null) { + return MalNil.NIL; + } else { + return falseNode.executeGeneric(frame, env); + } + } else { + return trueNode.executeGeneric(frame, env); + } + } + } + + static abstract class AbstractBindArgNode extends Node { + protected final int argPos; + protected final EnvSlot slot; + + protected AbstractBindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { + this.argPos = argPos; + this.slot = scope.allocateSlot(symbol); + } + + public abstract void execute(VirtualFrame frame, MalEnv env); + } + + static class BindArgNode extends AbstractBindArgNode { + + public BindArgNode(MalSymbol symbol, int argPos, LexicalScope scope) { + super(symbol, argPos, scope); + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + env.set(slot, frame.getArguments()[argPos]); + } + } + + static class BindVarargsNode extends BindArgNode { + public BindVarargsNode(MalSymbol symbol, int argPos, LexicalScope scope) { + super(symbol, argPos, scope); + } + + private MalList buildVarArgsList(Object[] args) { + MalList varArgs = MalList.EMPTY; + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + return varArgs; + } + + @Override + public void execute(VirtualFrame frame, MalEnv env) { + //env.set(slot, buildVarArgsList(frame.getArguments())); + MalList varArgs = MalList.EMPTY; + var args = frame.getArguments(); + for (int i=args.length-1; i >= argPos; --i) { + varArgs = varArgs.cons(args[i]); + } + //env.set(slot, varArgs); + env.staticBindings[slot.slotNum] = varArgs; + } + } + + /** + * Root node of a user-defined function, responsible for managing + * the environment when the function is invoked. + */ + static class FnRootNode extends RootNode { + final MalList form; + final int numArgs; + final LexicalScope scope; + @Children AbstractBindArgNode[] bindNodes; + @Child MalNode bodyNode; + + FnRootNode(MalLanguage language, MalList form, LexicalScope outerScope) { + super(language, new FrameDescriptor()); + this.form = form; + var argNamesList = new ArrayList(); + assert form.tail.head instanceof Iterable; + var foundAmpersand = false; + for (var name : (Iterable)form.tail.head) { + if (MalSymbol.AMPERSAND.equals(name)) { + foundAmpersand = true; + } else { + argNamesList.add((MalSymbol)name); + } + } + this.numArgs = foundAmpersand? -1 : argNamesList.size(); + this.bindNodes = new AbstractBindArgNode[argNamesList.size()]; + this.scope = new LexicalScope(outerScope); + for (int i=0; i < argNamesList.size(); i++) { + if (numArgs == -1 && i == argNamesList.size()-1) { + bindNodes[i] = new BindVarargsNode(argNamesList.get(i), i+1, scope); + } else { + bindNodes[i] = new BindArgNode(argNamesList.get(i), i+1, scope); + } + } + this.bodyNode = formToNode(language, form.tail.tail.head, true, scope); + } + + @ExplodeLoop + @Override + public Object execute(VirtualFrame frame) { + var env = new MalEnv((MalEnv)frame.getArguments()[0], scope); + for (int i=0; i < bindNodes.length; i++) { + bindNodes[i].execute(frame, env); + } + return bodyNode.executeGeneric(frame, env); + } + + @Override + public String toString() { + return form.toString(); + } + } + + /** + * Node representing a (fn* ...) form. + */ + static class FnNode extends MalNode { + final FnRootNode fnRoot; + final RootCallTarget fnCallTarget; + + FnNode(MalLanguage language, MalList form, LexicalScope scope) { + super(form); + fnRoot = new FnRootNode(language, form, scope); + this.fnCallTarget = Truffle.getRuntime().createCallTarget(fnRoot); + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return new MalFunction(fnCallTarget, env, fnRoot.numArgs); + } + } + + static class QuoteNode extends MalNode { + final Object quoted; + + QuoteNode(MalLanguage language, MalList form) { + super(form); + quoted = form.tail.head; + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + return quoted; + } + } + + static class TryNode extends MalNode { + @Child private MalNode tryBody; + @Child private MalNode catchBody; + final EnvSlot exSlot; + final LexicalScope catchScope; + + TryNode(MalLanguage language, MalList form, boolean tailPosition, LexicalScope scope) { + super(form); + var tryForm = form.tail.head; + var catchForm = (MalList)form.tail.tail.head; + // We don't allow tail calls inside a try body, because + // they'd get thrown past the catch that should catch subsequent failures. + this.tryBody = formToNode(language, tryForm, false, scope); + if (catchForm != null && MalSymbol.CATCH.equals(catchForm.head)) { + catchScope = new LexicalScope(scope); + var exSymbol = (MalSymbol)catchForm.tail.head; + exSlot = catchScope.allocateSlot(exSymbol); + catchBody = formToNode(language, catchForm.tail.tail.head, tailPosition, catchScope); + } else { + catchScope = null; + exSlot = null; + } + } + + @Override + public Object executeGeneric(VirtualFrame frame, MalEnv env) { + try { + return tryBody.executeGeneric(frame, env); + } catch (MalException ex) { + if (catchBody == null) { + throw ex; + } + var catchEnv = new MalEnv(env, catchScope); + catchEnv.set(exSlot, ex.obj); + return catchBody.executeGeneric(frame, catchEnv); + } + } + } + + final static class MalContext { + final MalEnv globalEnv; + final LexicalScope globalScope; + final Iterable topScopes; + final PrintStream out; + final BufferedReader in; + + MalContext(MalLanguage language) { + globalEnv = Core.newGlobalEnv(MalLanguage.class, language); + globalScope = new LexicalScope(); + topScopes = Collections.singleton(Scope.newBuilder("global", globalEnv).build()); + out = System.out; + in = new BufferedReader(new InputStreamReader(System.in)); + } + } + + @TruffleLanguage.Registration( + id=LANGUAGE_ID, + name=LANGUAGE_ID, + defaultMimeType = "application/x-"+LANGUAGE_ID, + characterMimeTypes = "application/x-"+LANGUAGE_ID) + public final static class MalLanguage extends TruffleLanguage implements IMalLanguage { + @Override + protected MalContext createContext(Env env) { + return new MalContext(this); + } + + @Override + public CallTarget evalForm(Object form) { + var ctx = getCurrentContext(MalLanguage.class); + var root = new MalRootNode(this, form, ctx.globalEnv, false, ctx.globalScope); + return Truffle.getRuntime().createCallTarget(root); + } + + @Override + public AbstractInvokeNode invokeNode() { + return new InvokeNode(false); + } + + @Override + protected CallTarget parse(ParsingRequest request) throws Exception { + Source source = request.getSource(); + String s = source.getCharacters().toString(); + return evalForm(Reader.readStr(s)); + } + + @Override + protected Iterable findTopScopes(MalContext context) { + return context.topScopes; + } + + @Override + public PrintStream out() { + return getCurrentContext(MalLanguage.class).out; + } + + @Override + public BufferedReader in() { + return getCurrentContext(MalLanguage.class).in; + } + } +} diff --git a/impls/java/Dockerfile b/impls/java/Dockerfile index 7c9fdd4aea..d1f4be37b4 100644 --- a/impls/java/Dockerfile +++ b/impls/java/Dockerfile @@ -1,28 +1,28 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Java and maven -RUN apt-get -y install openjdk-8-jdk -RUN apt-get -y install maven -ENV MAVEN_OPTS -Duser.home=/mal - +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Java and maven +RUN apt-get -y install openjdk-8-jdk +RUN apt-get -y install maven +ENV MAVEN_OPTS -Duser.home=/mal + diff --git a/impls/java/Makefile b/impls/java/Makefile index 34d38feb7d..3107b36522 100644 --- a/impls/java/Makefile +++ b/impls/java/Makefile @@ -1,30 +1,30 @@ - -SOURCES_BASE = src/main/java/mal/readline.java src/main/java/mal/types.java \ - src/main/java/mal/reader.java src/main/java/mal/printer.java -SOURCES_LISP = src/main/java/mal/env.java src/main/java/mal/core.java \ - src/main/java/mal/stepA_mal.java -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - mvn install - -dist: mal.jar mal - -mal.jar: target/classes/mal/stepA_mal.class - mvn assembly:assembly - cp target/mal-0.0.1.jar $@ - -SHELL := bash -mal: mal.jar - cat <(echo -e '#!/bin/sh\nexec java -jar "$$0" "$$@"') mal.jar > $@ - chmod +x mal - -src/main/mal/%.java: - mvn install - -target/classes/mal/step%.class: src/main/java/mal/step%.java ${SOURCES} - mvn install - -clean: - mvn clean - rm -f mal.jar mal + +SOURCES_BASE = src/main/java/mal/readline.java src/main/java/mal/types.java \ + src/main/java/mal/reader.java src/main/java/mal/printer.java +SOURCES_LISP = src/main/java/mal/env.java src/main/java/mal/core.java \ + src/main/java/mal/stepA_mal.java +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + mvn install + +dist: mal.jar mal + +mal.jar: target/classes/mal/stepA_mal.class + mvn assembly:assembly + cp target/mal-0.0.1.jar $@ + +SHELL := bash +mal: mal.jar + cat <(echo -e '#!/bin/sh\nexec java -jar "$$0" "$$@"') mal.jar > $@ + chmod +x mal + +src/main/mal/%.java: + mvn install + +target/classes/mal/step%.class: src/main/java/mal/step%.java ${SOURCES} + mvn install + +clean: + mvn clean + rm -f mal.jar mal diff --git a/impls/java/pom.xml b/impls/java/pom.xml index 63621f87b5..7131effacf 100644 --- a/impls/java/pom.xml +++ b/impls/java/pom.xml @@ -1,95 +1,95 @@ - - - 4.0.0 - org.martintribe - mal - jar - 0.0.1 - - - - com.google.guava - guava - 16.0.1 - - - org.apache.commons - commons-lang3 - 3.3 - - - net.java.dev.jna - jna - 4.0.0 - - - - - - - maven-compiler-plugin - 3.0 - - 1.7 - 1.7 - - - - org.codehaus.mojo - exec-maven-plugin - 1.2.1 - - - - java - - - - - - - - - org.apache.maven.plugins - maven-shade-plugin - 1.7.1 - - - package - - shade - - - - - mal.stepA_mal - - - - - - - - maven-assembly-plugin - - - jar-with-dependencies - - - - mal.stepA_mal - - - - - - - + + + 4.0.0 + org.martintribe + mal + jar + 0.0.1 + + + + com.google.guava + guava + 16.0.1 + + + org.apache.commons + commons-lang3 + 3.3 + + + net.java.dev.jna + jna + 4.0.0 + + + + + + + maven-compiler-plugin + 3.0 + + 1.7 + 1.7 + + + + org.codehaus.mojo + exec-maven-plugin + 1.2.1 + + + + java + + + + + + + + + org.apache.maven.plugins + maven-shade-plugin + 1.7.1 + + + package + + shade + + + + + mal.stepA_mal + + + + + + + + maven-assembly-plugin + + + jar-with-dependencies + + + + mal.stepA_mal + + + + + + + diff --git a/impls/java/run b/impls/java/run index 7119297e78..6a6eab0ba9 100755 --- a/impls/java/run +++ b/impls/java/run @@ -1,9 +1,9 @@ -#!/bin/bash -args="" -if [ "$#" -gt 0 ]; then - args="-Dexec.args='$1'" - for a in "${@:2}"; do - args="$args '$a'" - done -fi -exec mvn -quiet -e exec:java -Dexec.mainClass="mal.${STEP:-stepA_mal}" ${args:+"$args"} +#!/bin/bash +args="" +if [ "$#" -gt 0 ]; then + args="-Dexec.args='$1'" + for a in "${@:2}"; do + args="$args '$a'" + done +fi +exec mvn -quiet -e exec:java -Dexec.mainClass="mal.${STEP:-stepA_mal}" ${args:+"$args"} diff --git a/impls/java/src/main/java/mal/core.java b/impls/java/src/main/java/mal/core.java index 977d5ab844..78c4ed4415 100644 --- a/impls/java/src/main/java/mal/core.java +++ b/impls/java/src/main/java/mal/core.java @@ -1,633 +1,633 @@ -package mal; - -import java.util.List; -import java.util.ArrayList; -import java.util.Set; -import java.util.Map; -import java.util.HashMap; -import com.google.common.collect.ImmutableMap; - -import java.io.IOException; -import java.io.FileNotFoundException; -import java.util.Scanner; -import java.io.File; - -import mal.types.*; -import mal.printer; -import mal.readline; - -public class core { - // Local references for convenience - static MalConstant Nil = mal.types.Nil; - static MalConstant True = mal.types.True; - static MalConstant False = mal.types.False; - - - // Errors/Exceptions - static MalFunction mal_throw = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - throw new MalException(a.nth(0)); - } - }; - - - // Scalar functions - static MalFunction nil_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return args.nth(0) == Nil ? True : False; - } - }; - - static MalFunction true_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return args.nth(0) == True ? True : False; - } - }; - - static MalFunction false_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return args.nth(0) == False ? True : False; - } - }; - static MalFunction number_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return args.nth(0) instanceof MalInteger ? True : False; - } - }; - static MalFunction string_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - if (!(args.nth(0) instanceof MalString)) { return False; } - String s = ((MalString)args.nth(0)).getValue(); - if (s.length() != 0 && s.charAt(0) == '\u029e') { return False; } - return True; - } - }; - - static MalFunction symbol = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return new MalSymbol((MalString)args.nth(0)); - } - }; - static MalFunction symbol_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return args.nth(0) instanceof MalSymbol ? True : False; - } - }; - static MalFunction keyword = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - if (args.nth(0) instanceof MalString && - (((MalString)args.nth(0)).getValue().charAt(0) == '\u029e')) { - return (MalString)args.nth(0); - } else { - return new MalString( - "\u029e" + ((MalString)args.nth(0)).getValue()); - } - } - }; - static MalFunction keyword_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - if (!(args.nth(0) instanceof MalString)) { return False; } - String s = ((MalString)args.nth(0)).getValue(); - if (s.length() == 0 || s.charAt(0) != '\u029e') { return False; } - return True; - } - }; - static MalFunction fn_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - if (!(args.nth(0) instanceof MalFunction)) { return False; } - return ((MalFunction)args.nth(0)).isMacro() ? False : True; - } - }; - static MalFunction macro_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - if (!(args.nth(0) instanceof MalFunction)) { return False; } - return ((MalFunction)args.nth(0)).isMacro() ? True : False; - } - }; - - - // String functions - static MalFunction pr_str = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return new MalString(printer._pr_str_args(args, " ", true)); - } - }; - - static MalFunction str = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return new MalString(printer._pr_str_args(args, "", false)); - } - }; - - static MalFunction prn = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - System.out.println(printer._pr_str_args(args, " ", true)); - return Nil; - } - }; - - static MalFunction println = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - System.out.println(printer._pr_str_args(args, " ", false)); - return Nil; - } - }; - - - static MalFunction equal_Q = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return types._equal_Q(args.nth(0), args.nth(1)) ? True : False; - } - }; - - static MalFunction mal_readline = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - String prompt = ((MalString)args.nth(0)).getValue(); - try { - return new MalString(readline.readline(prompt)); - } catch (IOException e) { - throw new MalException(new MalString(e.getMessage())); - } catch (readline.EOFException e) { - return Nil; - } - } - }; - - static MalFunction read_string = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - try { - return reader.read_str(((MalString)args.nth(0)).getValue()); - } catch (MalContinue c) { - return types.Nil; - } - } - }; - - static MalFunction slurp = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - String fname = ((MalString)args.nth(0)).getValue(); - try { - // Scanner drops final newline, so add it back - return new MalString( - new Scanner(new File(fname)).useDelimiter("\\Z").next() - + "\n"); - } catch (FileNotFoundException e) { - throw new MalError(e.getMessage()); - } - } - }; - - - // Number functions - static MalFunction add = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).add((MalInteger)a.nth(1)); - } - }; - static MalFunction subtract = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).subtract((MalInteger)a.nth(1)); - } - }; - static MalFunction multiply = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).multiply((MalInteger)a.nth(1)); - } - }; - static MalFunction divide = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).divide((MalInteger)a.nth(1)); - } - }; - - static MalFunction lt = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).lt((MalInteger)a.nth(1)); - } - }; - static MalFunction lte = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).lte((MalInteger)a.nth(1)); - } - }; - static MalFunction gt = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).gt((MalInteger)a.nth(1)); - } - }; - static MalFunction gte = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).gte((MalInteger)a.nth(1)); - } - }; - - static MalFunction time_ms = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return new MalInteger((int)System.currentTimeMillis()); - } - }; - - - // List functions - static MalFunction new_list = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return new MalList(a.value); - } - }; - - static public Boolean _list_Q(MalVal mv) { - return mv.getClass().equals(MalList.class); - } - static MalFunction list_Q = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return _list_Q(a.nth(0)) ? True : False; - } - }; - - - // Vector functions - static MalFunction new_vector = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return new MalVector(a.value); - } - }; - - static public Boolean _vector_Q(MalVal mv) { - return mv.getClass().equals(MalVector.class); - } - static MalFunction vector_Q = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return _vector_Q(a.nth(0)) ? True : False; - } - }; - - // HashMap functions - static MalFunction new_hash_map = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return new MalHashMap(a); - } - }; - static MalFunction hash_map_Q = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return a.nth(0) instanceof MalHashMap ? True : False; - } - }; - - static MalFunction contains_Q = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - String key = ((MalString)a.nth(1)).getValue(); - MalHashMap mhm = (MalHashMap)a.nth(0); - HashMap hm = (HashMap)mhm.value; - return hm.containsKey(key) ? True : False; - } - }; - - static MalFunction assoc = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - MalHashMap mhm = (MalHashMap)a.nth(0); - HashMap hm = (HashMap)mhm.value; - MalHashMap new_mhm = new MalHashMap((Map)hm.clone()); - new_mhm.assoc_BANG((MalList)a.slice(1)); - return new_mhm; - } - }; - - static MalFunction dissoc = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - MalHashMap mhm = (MalHashMap)a.nth(0); - HashMap hm = (HashMap)mhm.value; - MalHashMap new_mhm = new MalHashMap((Map)hm.clone()); - new_mhm.dissoc_BANG((MalList)a.slice(1)); - return new_mhm; - } - }; - - static MalFunction get = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - if (a.nth(0) == Nil) { - return Nil; - } else { - String key = ((MalString)a.nth(1)).getValue(); - MalHashMap mhm = (MalHashMap)a.nth(0); - HashMap hm = (HashMap)mhm.value; - if (hm.containsKey(key)) { - return hm.get(key); - } else { - return Nil; - } - } - } - }; - - static MalFunction keys = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - MalHashMap mhm = (MalHashMap)a.nth(0); - HashMap hm = (HashMap)mhm.value; - MalList key_lst = new MalList(); - for (String key : hm.keySet()) { - key_lst.conj_BANG(new MalString(key)); - } - return key_lst; - } - }; - - static MalFunction vals = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - MalHashMap mhm = (MalHashMap)a.nth(0); - HashMap hm = (HashMap)mhm.value; - //return new ArrayList(((HashMap)hm).values()); - MalList val_lst = new MalList(); - for (MalVal val : hm.values()) { - val_lst.conj_BANG(val); - } - return val_lst; - } - }; - - - // Sequence functions - static MalFunction sequential_Q = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return a.nth(0) instanceof MalList ? True : False; - } - }; - - static MalFunction count = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - if (a.nth(0) == Nil) { - return new MalInteger(0); - } else { - return new MalInteger(((MalList)a.nth(0)).size()); - } - } - }; - - static MalFunction empty_Q = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - MalVal exp = a.nth(0); - if (exp == Nil || (exp instanceof MalList && - ((MalList)exp).size() == 0)) { - return True; - } else { - return False; - } - } - }; - - static MalFunction cons = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - List lst = new ArrayList(); - lst.add(a.nth(0)); - lst.addAll(((MalList)a.nth(1)).getList()); - return (MalVal)new MalList(lst); - } - }; - - static MalFunction concat = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - if (a.size() == 0) { return new MalList(); } - List lst = new ArrayList(); - lst.addAll(((MalList)a.nth(0)).value); - for(Integer i=1; i 0 ? ml.nth(0) : Nil; - } - }; - - static MalFunction rest = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - MalVal exp = a.nth(0); - if (exp == Nil) { - return new MalList(); - } - MalList ml = ((MalList)exp); - return ml.rest(); - } - }; - - static MalFunction nth = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - Integer idx = ((MalInteger)a.nth(1)).getValue(); - if (idx < ((MalList)a.nth(0)).size()) { - return ((MalList)a.nth(0)).nth(idx); - } else { - throw new MalError("nth: index out of range"); - } - } - }; - - // General sequence functions - static MalFunction apply = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - MalFunction f = (MalFunction)a.nth(0); - MalList args = a.slice(1,a.size()-1); - args.value.addAll( ((MalList)a.nth(a.size()-1)).value); - return f.apply(args); - } - }; - - static MalFunction map = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - MalFunction f = (MalFunction) a.nth(0); - MalList src_lst = (MalList) a.nth(1); - MalList new_lst = new MalList(); - for(Integer i=0; i lst = new ArrayList(); - for (String c : s.split("(?!^)")) { - lst.add(new MalString(c)); - } - return new MalList(lst); - } else if (mv == Nil) { - return Nil; - } else { - throw new MalError("seq: called on non-sequence"); - } - } - }; - - - // Metadata functions - - static MalFunction meta = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return args.nth(0).getMeta(); - } - }; - - static MalFunction with_meta = new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - MalVal new_mv = ((MalVal)args.nth(0)).copy(); - new_mv.setMeta(args.nth(1)); - return new_mv; - } - }; - - - // Atom functions - static MalFunction new_atom = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return new MalAtom(a.nth(0)); - } - }; - - static MalFunction atom_Q = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return a.nth(0) instanceof MalAtom ? True : False; - } - }; - - static MalFunction deref = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalAtom)a.nth(0)).value; - } - }; - - static MalFunction reset_BANG = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalAtom)a.nth(0)).value = a.nth(1); - } - }; - - static MalFunction swap_BANG = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - MalAtom atm = (MalAtom)a.nth(0); - MalFunction f = (MalFunction)a.nth(1); - MalList new_args = new MalList(); - new_args.value.addAll(((MalList)a.slice(2)).value); - new_args.value.add(0, atm.value); - atm.value = f.apply(new_args); - return atm.value; - } - }; - - - - - - // types_ns is namespace of type functions - static Map ns = ImmutableMap.builder() - .put("=", equal_Q) - .put("throw", mal_throw) - .put("nil?", nil_Q) - .put("true?", true_Q) - .put("false?", false_Q) - .put("number?", number_Q) - .put("string?", string_Q) - .put("symbol", symbol) - .put("symbol?", symbol_Q) - .put("keyword", keyword) - .put("keyword?", keyword_Q) - .put("fn?", fn_Q) - .put("macro?", macro_Q) - - .put("pr-str", pr_str) - .put("str", str) - .put("prn", prn) - .put("println", println) - .put("readline", mal_readline) - .put("read-string", read_string) - .put("slurp", slurp) - .put("<", lt) - .put("<=", lte) - .put(">", gt) - .put(">=", gte) - .put("+", add) - .put("-", subtract) - .put("*", multiply) - .put("/", divide) - .put("time-ms", time_ms) - - .put("list", new_list) - .put("list?", list_Q) - .put("vector", new_vector) - .put("vector?", vector_Q) - .put("hash-map", new_hash_map) - .put("map?", hash_map_Q) - .put("assoc", assoc) - .put("dissoc", dissoc) - .put("contains?", contains_Q) - .put("get", get) - .put("keys", keys) - .put("vals", vals) - - .put("sequential?", sequential_Q) - .put("cons", cons) - .put("concat", concat) - .put("vec", vec) - .put("nth", nth) - .put("first", first) - .put("rest", rest) - .put("empty?", empty_Q) - .put("count", count) - .put("apply", apply) - .put("map", map) - - .put("conj", conj) - .put("seq", seq) - - .put("with-meta", with_meta) - .put("meta", meta) - .put("atom", new_atom) - .put("atom?", atom_Q) - .put("deref", deref) - .put("reset!", reset_BANG) - .put("swap!", swap_BANG) - .build(); -} +package mal; + +import java.util.List; +import java.util.ArrayList; +import java.util.Set; +import java.util.Map; +import java.util.HashMap; +import com.google.common.collect.ImmutableMap; + +import java.io.IOException; +import java.io.FileNotFoundException; +import java.util.Scanner; +import java.io.File; + +import mal.types.*; +import mal.printer; +import mal.readline; + +public class core { + // Local references for convenience + static MalConstant Nil = mal.types.Nil; + static MalConstant True = mal.types.True; + static MalConstant False = mal.types.False; + + + // Errors/Exceptions + static MalFunction mal_throw = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + throw new MalException(a.nth(0)); + } + }; + + + // Scalar functions + static MalFunction nil_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return args.nth(0) == Nil ? True : False; + } + }; + + static MalFunction true_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return args.nth(0) == True ? True : False; + } + }; + + static MalFunction false_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return args.nth(0) == False ? True : False; + } + }; + static MalFunction number_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return args.nth(0) instanceof MalInteger ? True : False; + } + }; + static MalFunction string_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + if (!(args.nth(0) instanceof MalString)) { return False; } + String s = ((MalString)args.nth(0)).getValue(); + if (s.length() != 0 && s.charAt(0) == '\u029e') { return False; } + return True; + } + }; + + static MalFunction symbol = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return new MalSymbol((MalString)args.nth(0)); + } + }; + static MalFunction symbol_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return args.nth(0) instanceof MalSymbol ? True : False; + } + }; + static MalFunction keyword = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + if (args.nth(0) instanceof MalString && + (((MalString)args.nth(0)).getValue().charAt(0) == '\u029e')) { + return (MalString)args.nth(0); + } else { + return new MalString( + "\u029e" + ((MalString)args.nth(0)).getValue()); + } + } + }; + static MalFunction keyword_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + if (!(args.nth(0) instanceof MalString)) { return False; } + String s = ((MalString)args.nth(0)).getValue(); + if (s.length() == 0 || s.charAt(0) != '\u029e') { return False; } + return True; + } + }; + static MalFunction fn_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + if (!(args.nth(0) instanceof MalFunction)) { return False; } + return ((MalFunction)args.nth(0)).isMacro() ? False : True; + } + }; + static MalFunction macro_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + if (!(args.nth(0) instanceof MalFunction)) { return False; } + return ((MalFunction)args.nth(0)).isMacro() ? True : False; + } + }; + + + // String functions + static MalFunction pr_str = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return new MalString(printer._pr_str_args(args, " ", true)); + } + }; + + static MalFunction str = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return new MalString(printer._pr_str_args(args, "", false)); + } + }; + + static MalFunction prn = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + System.out.println(printer._pr_str_args(args, " ", true)); + return Nil; + } + }; + + static MalFunction println = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + System.out.println(printer._pr_str_args(args, " ", false)); + return Nil; + } + }; + + + static MalFunction equal_Q = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return types._equal_Q(args.nth(0), args.nth(1)) ? True : False; + } + }; + + static MalFunction mal_readline = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + String prompt = ((MalString)args.nth(0)).getValue(); + try { + return new MalString(readline.readline(prompt)); + } catch (IOException e) { + throw new MalException(new MalString(e.getMessage())); + } catch (readline.EOFException e) { + return Nil; + } + } + }; + + static MalFunction read_string = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + try { + return reader.read_str(((MalString)args.nth(0)).getValue()); + } catch (MalContinue c) { + return types.Nil; + } + } + }; + + static MalFunction slurp = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + String fname = ((MalString)args.nth(0)).getValue(); + try { + // Scanner drops final newline, so add it back + return new MalString( + new Scanner(new File(fname)).useDelimiter("\\Z").next() + + "\n"); + } catch (FileNotFoundException e) { + throw new MalError(e.getMessage()); + } + } + }; + + + // Number functions + static MalFunction add = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).add((MalInteger)a.nth(1)); + } + }; + static MalFunction subtract = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).subtract((MalInteger)a.nth(1)); + } + }; + static MalFunction multiply = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).multiply((MalInteger)a.nth(1)); + } + }; + static MalFunction divide = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).divide((MalInteger)a.nth(1)); + } + }; + + static MalFunction lt = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).lt((MalInteger)a.nth(1)); + } + }; + static MalFunction lte = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).lte((MalInteger)a.nth(1)); + } + }; + static MalFunction gt = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).gt((MalInteger)a.nth(1)); + } + }; + static MalFunction gte = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).gte((MalInteger)a.nth(1)); + } + }; + + static MalFunction time_ms = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return new MalInteger((int)System.currentTimeMillis()); + } + }; + + + // List functions + static MalFunction new_list = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return new MalList(a.value); + } + }; + + static public Boolean _list_Q(MalVal mv) { + return mv.getClass().equals(MalList.class); + } + static MalFunction list_Q = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return _list_Q(a.nth(0)) ? True : False; + } + }; + + + // Vector functions + static MalFunction new_vector = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return new MalVector(a.value); + } + }; + + static public Boolean _vector_Q(MalVal mv) { + return mv.getClass().equals(MalVector.class); + } + static MalFunction vector_Q = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return _vector_Q(a.nth(0)) ? True : False; + } + }; + + // HashMap functions + static MalFunction new_hash_map = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return new MalHashMap(a); + } + }; + static MalFunction hash_map_Q = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return a.nth(0) instanceof MalHashMap ? True : False; + } + }; + + static MalFunction contains_Q = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + String key = ((MalString)a.nth(1)).getValue(); + MalHashMap mhm = (MalHashMap)a.nth(0); + HashMap hm = (HashMap)mhm.value; + return hm.containsKey(key) ? True : False; + } + }; + + static MalFunction assoc = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + MalHashMap mhm = (MalHashMap)a.nth(0); + HashMap hm = (HashMap)mhm.value; + MalHashMap new_mhm = new MalHashMap((Map)hm.clone()); + new_mhm.assoc_BANG((MalList)a.slice(1)); + return new_mhm; + } + }; + + static MalFunction dissoc = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + MalHashMap mhm = (MalHashMap)a.nth(0); + HashMap hm = (HashMap)mhm.value; + MalHashMap new_mhm = new MalHashMap((Map)hm.clone()); + new_mhm.dissoc_BANG((MalList)a.slice(1)); + return new_mhm; + } + }; + + static MalFunction get = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + if (a.nth(0) == Nil) { + return Nil; + } else { + String key = ((MalString)a.nth(1)).getValue(); + MalHashMap mhm = (MalHashMap)a.nth(0); + HashMap hm = (HashMap)mhm.value; + if (hm.containsKey(key)) { + return hm.get(key); + } else { + return Nil; + } + } + } + }; + + static MalFunction keys = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + MalHashMap mhm = (MalHashMap)a.nth(0); + HashMap hm = (HashMap)mhm.value; + MalList key_lst = new MalList(); + for (String key : hm.keySet()) { + key_lst.conj_BANG(new MalString(key)); + } + return key_lst; + } + }; + + static MalFunction vals = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + MalHashMap mhm = (MalHashMap)a.nth(0); + HashMap hm = (HashMap)mhm.value; + //return new ArrayList(((HashMap)hm).values()); + MalList val_lst = new MalList(); + for (MalVal val : hm.values()) { + val_lst.conj_BANG(val); + } + return val_lst; + } + }; + + + // Sequence functions + static MalFunction sequential_Q = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return a.nth(0) instanceof MalList ? True : False; + } + }; + + static MalFunction count = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + if (a.nth(0) == Nil) { + return new MalInteger(0); + } else { + return new MalInteger(((MalList)a.nth(0)).size()); + } + } + }; + + static MalFunction empty_Q = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + MalVal exp = a.nth(0); + if (exp == Nil || (exp instanceof MalList && + ((MalList)exp).size() == 0)) { + return True; + } else { + return False; + } + } + }; + + static MalFunction cons = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + List lst = new ArrayList(); + lst.add(a.nth(0)); + lst.addAll(((MalList)a.nth(1)).getList()); + return (MalVal)new MalList(lst); + } + }; + + static MalFunction concat = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + if (a.size() == 0) { return new MalList(); } + List lst = new ArrayList(); + lst.addAll(((MalList)a.nth(0)).value); + for(Integer i=1; i 0 ? ml.nth(0) : Nil; + } + }; + + static MalFunction rest = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + MalVal exp = a.nth(0); + if (exp == Nil) { + return new MalList(); + } + MalList ml = ((MalList)exp); + return ml.rest(); + } + }; + + static MalFunction nth = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + Integer idx = ((MalInteger)a.nth(1)).getValue(); + if (idx < ((MalList)a.nth(0)).size()) { + return ((MalList)a.nth(0)).nth(idx); + } else { + throw new MalError("nth: index out of range"); + } + } + }; + + // General sequence functions + static MalFunction apply = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + MalFunction f = (MalFunction)a.nth(0); + MalList args = a.slice(1,a.size()-1); + args.value.addAll( ((MalList)a.nth(a.size()-1)).value); + return f.apply(args); + } + }; + + static MalFunction map = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + MalFunction f = (MalFunction) a.nth(0); + MalList src_lst = (MalList) a.nth(1); + MalList new_lst = new MalList(); + for(Integer i=0; i lst = new ArrayList(); + for (String c : s.split("(?!^)")) { + lst.add(new MalString(c)); + } + return new MalList(lst); + } else if (mv == Nil) { + return Nil; + } else { + throw new MalError("seq: called on non-sequence"); + } + } + }; + + + // Metadata functions + + static MalFunction meta = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return args.nth(0).getMeta(); + } + }; + + static MalFunction with_meta = new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + MalVal new_mv = ((MalVal)args.nth(0)).copy(); + new_mv.setMeta(args.nth(1)); + return new_mv; + } + }; + + + // Atom functions + static MalFunction new_atom = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return new MalAtom(a.nth(0)); + } + }; + + static MalFunction atom_Q = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return a.nth(0) instanceof MalAtom ? True : False; + } + }; + + static MalFunction deref = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalAtom)a.nth(0)).value; + } + }; + + static MalFunction reset_BANG = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalAtom)a.nth(0)).value = a.nth(1); + } + }; + + static MalFunction swap_BANG = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + MalAtom atm = (MalAtom)a.nth(0); + MalFunction f = (MalFunction)a.nth(1); + MalList new_args = new MalList(); + new_args.value.addAll(((MalList)a.slice(2)).value); + new_args.value.add(0, atm.value); + atm.value = f.apply(new_args); + return atm.value; + } + }; + + + + + + // types_ns is namespace of type functions + static Map ns = ImmutableMap.builder() + .put("=", equal_Q) + .put("throw", mal_throw) + .put("nil?", nil_Q) + .put("true?", true_Q) + .put("false?", false_Q) + .put("number?", number_Q) + .put("string?", string_Q) + .put("symbol", symbol) + .put("symbol?", symbol_Q) + .put("keyword", keyword) + .put("keyword?", keyword_Q) + .put("fn?", fn_Q) + .put("macro?", macro_Q) + + .put("pr-str", pr_str) + .put("str", str) + .put("prn", prn) + .put("println", println) + .put("readline", mal_readline) + .put("read-string", read_string) + .put("slurp", slurp) + .put("<", lt) + .put("<=", lte) + .put(">", gt) + .put(">=", gte) + .put("+", add) + .put("-", subtract) + .put("*", multiply) + .put("/", divide) + .put("time-ms", time_ms) + + .put("list", new_list) + .put("list?", list_Q) + .put("vector", new_vector) + .put("vector?", vector_Q) + .put("hash-map", new_hash_map) + .put("map?", hash_map_Q) + .put("assoc", assoc) + .put("dissoc", dissoc) + .put("contains?", contains_Q) + .put("get", get) + .put("keys", keys) + .put("vals", vals) + + .put("sequential?", sequential_Q) + .put("cons", cons) + .put("concat", concat) + .put("vec", vec) + .put("nth", nth) + .put("first", first) + .put("rest", rest) + .put("empty?", empty_Q) + .put("count", count) + .put("apply", apply) + .put("map", map) + + .put("conj", conj) + .put("seq", seq) + + .put("with-meta", with_meta) + .put("meta", meta) + .put("atom", new_atom) + .put("atom?", atom_Q) + .put("deref", deref) + .put("reset!", reset_BANG) + .put("swap!", swap_BANG) + .build(); +} diff --git a/impls/java/src/main/java/mal/env.java b/impls/java/src/main/java/mal/env.java index 711a9eee76..6e82a5a83f 100644 --- a/impls/java/src/main/java/mal/env.java +++ b/impls/java/src/main/java/mal/env.java @@ -1,58 +1,58 @@ -package mal; - -import java.util.HashMap; - -import mal.types.MalThrowable; -import mal.types.MalException; -import mal.types.MalVal; -import mal.types.MalSymbol; -import mal.types.MalList; - -public class env { - public static class Env { - Env outer = null; - HashMap data = new HashMap(); - - public Env(Env outer) { - this.outer = outer; - } - public Env(Env outer, MalList binds, MalList exprs) { - this.outer = outer; - for (Integer i=0; i data = new HashMap(); + + public Env(Env outer) { + this.outer = outer; + } + public Env(Env outer, MalList binds, MalList exprs) { + this.outer = outer; + for (Integer i=0; i value, - String delim, Boolean print_readably) { - ArrayList strs = new ArrayList(); - for (MalVal mv : value) { - strs.add(mv.toString(print_readably)); - } - return Joiner.on(delim).join(strs); - } - - public static String join(Map value, - String delim, Boolean print_readably) { - ArrayList strs = new ArrayList(); - for (Map.Entry entry : value.entrySet()) { - if (entry.getKey().length() > 0 && - entry.getKey().charAt(0) == '\u029e') { - strs.add(":" + entry.getKey().substring(1)); - } else if (print_readably) { - strs.add("\"" + entry.getKey().toString() + "\""); - } else { - strs.add(entry.getKey().toString()); - } - strs.add(entry.getValue().toString(print_readably)); - } - return Joiner.on(" ").join(strs); - } - - public static String _pr_str(MalVal mv, - Boolean print_readably) { - return mv.toString(print_readably); - } - - public static String _pr_str_args(MalList args, - String sep, Boolean print_readably) { - return join(args.getList(), sep, print_readably); - } - - public static String escapeString(String value) { - return StringEscapeUtils.escapeJava(value); - } -} +package mal; + +import java.util.List; +import java.util.ArrayList; +import com.google.common.base.Joiner; +import java.util.Map; +import org.apache.commons.lang3.StringEscapeUtils; + +import mal.types.MalVal; +import mal.types.MalList; + +public class printer { + + public static String join(List value, + String delim, Boolean print_readably) { + ArrayList strs = new ArrayList(); + for (MalVal mv : value) { + strs.add(mv.toString(print_readably)); + } + return Joiner.on(delim).join(strs); + } + + public static String join(Map value, + String delim, Boolean print_readably) { + ArrayList strs = new ArrayList(); + for (Map.Entry entry : value.entrySet()) { + if (entry.getKey().length() > 0 && + entry.getKey().charAt(0) == '\u029e') { + strs.add(":" + entry.getKey().substring(1)); + } else if (print_readably) { + strs.add("\"" + entry.getKey().toString() + "\""); + } else { + strs.add(entry.getKey().toString()); + } + strs.add(entry.getValue().toString(print_readably)); + } + return Joiner.on(" ").join(strs); + } + + public static String _pr_str(MalVal mv, + Boolean print_readably) { + return mv.toString(print_readably); + } + + public static String _pr_str_args(MalList args, + String sep, Boolean print_readably) { + return join(args.getList(), sep, print_readably); + } + + public static String escapeString(String value) { + return StringEscapeUtils.escapeJava(value); + } +} diff --git a/impls/java/src/main/java/mal/reader.java b/impls/java/src/main/java/mal/reader.java index c84e57c3e6..c30fd85bd9 100644 --- a/impls/java/src/main/java/mal/reader.java +++ b/impls/java/src/main/java/mal/reader.java @@ -1,151 +1,151 @@ -package mal; - -import java.util.ArrayList; -import java.util.regex.Matcher; -import java.util.regex.Pattern; -import org.apache.commons.lang3.StringEscapeUtils; -import mal.types.*; - -public class reader { - public static class ParseError extends MalThrowable { - public ParseError(String msg) { - super(msg); - } - } - - public static class Reader { - ArrayList tokens; - Integer position; - public Reader(ArrayList t) { - tokens = t; - position = 0; - } - - public String peek() { - if (position >= tokens.size()) { - return null; - } else { - return tokens.get(position); - } - } - public String next() { - return tokens.get(position++); - } - } - - public static ArrayList tokenize(String str) { - ArrayList tokens = new ArrayList(); - Pattern pattern = Pattern.compile("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)"); - Matcher matcher = pattern.matcher(str); - while (matcher.find()) { - String token = matcher.group(1); - if (token != null && - !token.equals("") && - !(token.charAt(0) == ';')) { - tokens.add(token); - } - } - return tokens; - } - - public static MalVal read_atom(Reader rdr) - throws ParseError { - String token = rdr.next(); - Pattern pattern = Pattern.compile("(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"((?:[\\\\].|[^\\\\\"])*)\"$|^\"(.*)$|:(.*)|(^[^\"]*$)"); - Matcher matcher = pattern.matcher(token); - if (!matcher.find()) { - throw new ParseError("unrecognized token '" + token + "'"); - } - if (matcher.group(1) != null) { - return new MalInteger(Integer.parseInt(matcher.group(1))); - } else if (matcher.group(3) != null) { - return types.Nil; - } else if (matcher.group(4) != null) { - return types.True; - } else if (matcher.group(5) != null) { - return types.False; - } else if (matcher.group(6) != null) { - return new MalString(StringEscapeUtils.unescapeJava(matcher.group(6))); - } else if (matcher.group(7) != null) { - throw new ParseError("expected '\"', got EOF"); - } else if (matcher.group(8) != null) { - return new MalString("\u029e" + matcher.group(8)); - } else if (matcher.group(9) != null) { - return new MalSymbol(matcher.group(9)); - } else { - throw new ParseError("unrecognized '" + matcher.group(0) + "'"); - } - } - - public static MalVal read_list(Reader rdr, MalList lst, char start, char end) - throws MalContinue, ParseError { - String token = rdr.next(); - if (token.charAt(0) != start) { - throw new ParseError("expected '" + start + "'"); - } - - while ((token = rdr.peek()) != null && token.charAt(0) != end) { - lst.conj_BANG(read_form(rdr)); - } - - if (token == null) { - throw new ParseError("expected '" + end + "', got EOF"); - } - rdr.next(); - - return lst; - } - - public static MalVal read_hash_map(Reader rdr) - throws MalContinue, ParseError { - MalList lst = (MalList)read_list(rdr, new MalList(), '{', '}'); - return new MalHashMap(lst); - } - - public static MalVal read_form(Reader rdr) - throws MalContinue, ParseError { - String token = rdr.peek(); - if (token == null) { throw new MalContinue(); } - MalVal form; - - switch (token.charAt(0)) { - case '\'': rdr.next(); - return new MalList(new MalSymbol("quote"), - read_form(rdr)); - case '`': rdr.next(); - return new MalList(new MalSymbol("quasiquote"), - read_form(rdr)); - case '~': - if (token.equals("~")) { - rdr.next(); - return new MalList(new MalSymbol("unquote"), - read_form(rdr)); - } else { - rdr.next(); - return new MalList(new MalSymbol("splice-unquote"), - read_form(rdr)); - } - case '^': rdr.next(); - MalVal meta = read_form(rdr); - return new MalList(new MalSymbol("with-meta"), - read_form(rdr), - meta); - case '@': rdr.next(); - return new MalList(new MalSymbol("deref"), - read_form(rdr)); - case '(': form = read_list(rdr, new MalList(), '(' , ')'); break; - case ')': throw new ParseError("unexpected ')'"); - case '[': form = read_list(rdr, new MalVector(), '[' , ']'); break; - case ']': throw new ParseError("unexpected ']'"); - case '{': form = read_hash_map(rdr); break; - case '}': throw new ParseError("unexpected '}'"); - default: form = read_atom(rdr); - } - return form; - } - - public static MalVal read_str(String str) - throws MalContinue, ParseError { - return read_form(new Reader(tokenize(str))); - } -} +package mal; + +import java.util.ArrayList; +import java.util.regex.Matcher; +import java.util.regex.Pattern; +import org.apache.commons.lang3.StringEscapeUtils; +import mal.types.*; + +public class reader { + public static class ParseError extends MalThrowable { + public ParseError(String msg) { + super(msg); + } + } + + public static class Reader { + ArrayList tokens; + Integer position; + public Reader(ArrayList t) { + tokens = t; + position = 0; + } + + public String peek() { + if (position >= tokens.size()) { + return null; + } else { + return tokens.get(position); + } + } + public String next() { + return tokens.get(position++); + } + } + + public static ArrayList tokenize(String str) { + ArrayList tokens = new ArrayList(); + Pattern pattern = Pattern.compile("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)"); + Matcher matcher = pattern.matcher(str); + while (matcher.find()) { + String token = matcher.group(1); + if (token != null && + !token.equals("") && + !(token.charAt(0) == ';')) { + tokens.add(token); + } + } + return tokens; + } + + public static MalVal read_atom(Reader rdr) + throws ParseError { + String token = rdr.next(); + Pattern pattern = Pattern.compile("(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"((?:[\\\\].|[^\\\\\"])*)\"$|^\"(.*)$|:(.*)|(^[^\"]*$)"); + Matcher matcher = pattern.matcher(token); + if (!matcher.find()) { + throw new ParseError("unrecognized token '" + token + "'"); + } + if (matcher.group(1) != null) { + return new MalInteger(Integer.parseInt(matcher.group(1))); + } else if (matcher.group(3) != null) { + return types.Nil; + } else if (matcher.group(4) != null) { + return types.True; + } else if (matcher.group(5) != null) { + return types.False; + } else if (matcher.group(6) != null) { + return new MalString(StringEscapeUtils.unescapeJava(matcher.group(6))); + } else if (matcher.group(7) != null) { + throw new ParseError("expected '\"', got EOF"); + } else if (matcher.group(8) != null) { + return new MalString("\u029e" + matcher.group(8)); + } else if (matcher.group(9) != null) { + return new MalSymbol(matcher.group(9)); + } else { + throw new ParseError("unrecognized '" + matcher.group(0) + "'"); + } + } + + public static MalVal read_list(Reader rdr, MalList lst, char start, char end) + throws MalContinue, ParseError { + String token = rdr.next(); + if (token.charAt(0) != start) { + throw new ParseError("expected '" + start + "'"); + } + + while ((token = rdr.peek()) != null && token.charAt(0) != end) { + lst.conj_BANG(read_form(rdr)); + } + + if (token == null) { + throw new ParseError("expected '" + end + "', got EOF"); + } + rdr.next(); + + return lst; + } + + public static MalVal read_hash_map(Reader rdr) + throws MalContinue, ParseError { + MalList lst = (MalList)read_list(rdr, new MalList(), '{', '}'); + return new MalHashMap(lst); + } + + public static MalVal read_form(Reader rdr) + throws MalContinue, ParseError { + String token = rdr.peek(); + if (token == null) { throw new MalContinue(); } + MalVal form; + + switch (token.charAt(0)) { + case '\'': rdr.next(); + return new MalList(new MalSymbol("quote"), + read_form(rdr)); + case '`': rdr.next(); + return new MalList(new MalSymbol("quasiquote"), + read_form(rdr)); + case '~': + if (token.equals("~")) { + rdr.next(); + return new MalList(new MalSymbol("unquote"), + read_form(rdr)); + } else { + rdr.next(); + return new MalList(new MalSymbol("splice-unquote"), + read_form(rdr)); + } + case '^': rdr.next(); + MalVal meta = read_form(rdr); + return new MalList(new MalSymbol("with-meta"), + read_form(rdr), + meta); + case '@': rdr.next(); + return new MalList(new MalSymbol("deref"), + read_form(rdr)); + case '(': form = read_list(rdr, new MalList(), '(' , ')'); break; + case ')': throw new ParseError("unexpected ')'"); + case '[': form = read_list(rdr, new MalVector(), '[' , ']'); break; + case ']': throw new ParseError("unexpected ']'"); + case '{': form = read_hash_map(rdr); break; + case '}': throw new ParseError("unexpected '}'"); + default: form = read_atom(rdr); + } + return form; + } + + public static MalVal read_str(String str) + throws MalContinue, ParseError { + return read_form(new Reader(tokenize(str))); + } +} diff --git a/impls/java/src/main/java/mal/readline.java b/impls/java/src/main/java/mal/readline.java index 9220267d80..d1e1f73737 100644 --- a/impls/java/src/main/java/mal/readline.java +++ b/impls/java/src/main/java/mal/readline.java @@ -1,105 +1,105 @@ -package mal; - -import java.io.IOException; -import java.io.BufferedReader; -import java.io.InputStreamReader; -import java.io.BufferedWriter; -import java.io.FileWriter; - -import java.io.File; -import com.google.common.io.Files; -import java.nio.charset.StandardCharsets; -import java.util.List; - -import com.sun.jna.Library; -import com.sun.jna.Native; -import com.sun.jna.Platform; - -class readline { - public enum Mode { JNA, JAVA } - static Mode mode = Mode.JNA; - - static String HISTORY_FILE = null; - static Boolean historyLoaded = false; - - static { - HISTORY_FILE = System.getProperty("user.home") + "/.mal-history"; - } - - public static class EOFException extends Exception { - } - - public interface RLLibrary extends Library { - // Select a library to use. - // WARNING: GNU readline is GPL. - - // GNU readline (GPL) - RLLibrary INSTANCE = (RLLibrary) - Native.loadLibrary("readline", RLLibrary.class); - // Libedit (BSD) -// RLLibrary INSTANCE = (RLLibrary) -// Native.loadLibrary("edit", RLLibrary.class); - - String readline(String prompt); - void add_history(String line); - } - - public static void loadHistory(String filename) { - File file = new File(filename); - try { - List lines = Files.readLines(file, - StandardCharsets.UTF_8); - for (String line : lines) { - RLLibrary.INSTANCE.add_history(line); - } - } catch (IOException e) { - // ignore - } - } - - public static void appendHistory(String filename, String line) { - try { - BufferedWriter w; - w = new BufferedWriter(new FileWriter(filename, true)); - w.append(line + "\n"); - w.close(); - } catch (IOException e) { - // ignore - } - } - - public static String jna_readline(String prompt) - throws EOFException, IOException { - if (!historyLoaded) { - loadHistory(HISTORY_FILE); - } - String line = RLLibrary.INSTANCE.readline(prompt); - if (line == null) { - throw new EOFException(); - } - RLLibrary.INSTANCE.add_history(line); - appendHistory(HISTORY_FILE, line); - return line; - } - - // Just java readline (no history, or line editing) - public static String java_readline(String prompt) - throws EOFException, IOException { - System.out.print(prompt); - BufferedReader buffer=new BufferedReader(new InputStreamReader(System.in)); - String line=buffer.readLine(); - if (line == null) { - throw new EOFException(); - } - return line; - } - - public static String readline(String prompt) - throws EOFException, IOException { - if (mode == Mode.JNA) { - return jna_readline(prompt); - } else { - return java_readline(prompt); - } - } -} +package mal; + +import java.io.IOException; +import java.io.BufferedReader; +import java.io.InputStreamReader; +import java.io.BufferedWriter; +import java.io.FileWriter; + +import java.io.File; +import com.google.common.io.Files; +import java.nio.charset.StandardCharsets; +import java.util.List; + +import com.sun.jna.Library; +import com.sun.jna.Native; +import com.sun.jna.Platform; + +class readline { + public enum Mode { JNA, JAVA } + static Mode mode = Mode.JNA; + + static String HISTORY_FILE = null; + static Boolean historyLoaded = false; + + static { + HISTORY_FILE = System.getProperty("user.home") + "/.mal-history"; + } + + public static class EOFException extends Exception { + } + + public interface RLLibrary extends Library { + // Select a library to use. + // WARNING: GNU readline is GPL. + + // GNU readline (GPL) + RLLibrary INSTANCE = (RLLibrary) + Native.loadLibrary("readline", RLLibrary.class); + // Libedit (BSD) +// RLLibrary INSTANCE = (RLLibrary) +// Native.loadLibrary("edit", RLLibrary.class); + + String readline(String prompt); + void add_history(String line); + } + + public static void loadHistory(String filename) { + File file = new File(filename); + try { + List lines = Files.readLines(file, + StandardCharsets.UTF_8); + for (String line : lines) { + RLLibrary.INSTANCE.add_history(line); + } + } catch (IOException e) { + // ignore + } + } + + public static void appendHistory(String filename, String line) { + try { + BufferedWriter w; + w = new BufferedWriter(new FileWriter(filename, true)); + w.append(line + "\n"); + w.close(); + } catch (IOException e) { + // ignore + } + } + + public static String jna_readline(String prompt) + throws EOFException, IOException { + if (!historyLoaded) { + loadHistory(HISTORY_FILE); + } + String line = RLLibrary.INSTANCE.readline(prompt); + if (line == null) { + throw new EOFException(); + } + RLLibrary.INSTANCE.add_history(line); + appendHistory(HISTORY_FILE, line); + return line; + } + + // Just java readline (no history, or line editing) + public static String java_readline(String prompt) + throws EOFException, IOException { + System.out.print(prompt); + BufferedReader buffer=new BufferedReader(new InputStreamReader(System.in)); + String line=buffer.readLine(); + if (line == null) { + throw new EOFException(); + } + return line; + } + + public static String readline(String prompt) + throws EOFException, IOException { + if (mode == Mode.JNA) { + return jna_readline(prompt); + } else { + return java_readline(prompt); + } + } +} diff --git a/impls/java/src/main/java/mal/step0_repl.java b/impls/java/src/main/java/mal/step0_repl.java index b966a1f776..d6027c4982 100644 --- a/impls/java/src/main/java/mal/step0_repl.java +++ b/impls/java/src/main/java/mal/step0_repl.java @@ -1,48 +1,48 @@ -package mal; - -import java.io.IOException; - -import mal.readline; - -public class step0_repl { - // read - public static String READ(String str) { - return str; - } - - // eval - public static String EVAL(String ast, String env) { - return ast; - } - - // print - public static String PRINT(String exp) { - return exp; - } - - // repl - public static String RE(String env, String str) { - return EVAL(READ(str), env); - } - - public static void main(String[] args) { - String prompt = "user> "; - - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - } - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - System.out.println(PRINT(RE(null, line))); - } - } -} +package mal; + +import java.io.IOException; + +import mal.readline; + +public class step0_repl { + // read + public static String READ(String str) { + return str; + } + + // eval + public static String EVAL(String ast, String env) { + return ast; + } + + // print + public static String PRINT(String exp) { + return exp; + } + + // repl + public static String RE(String env, String str) { + return EVAL(READ(str), env); + } + + public static void main(String[] args) { + String prompt = "user> "; + + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + } + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + System.out.println(PRINT(RE(null, line))); + } + } +} diff --git a/impls/java/src/main/java/mal/step1_read_print.java b/impls/java/src/main/java/mal/step1_read_print.java index e849052a3e..9da6fe8619 100644 --- a/impls/java/src/main/java/mal/step1_read_print.java +++ b/impls/java/src/main/java/mal/step1_read_print.java @@ -1,61 +1,61 @@ -package mal; - -import java.io.IOException; - -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; - -public class step1_read_print { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static MalVal EVAL(MalVal ast, String env) { - return ast; - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(String env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - } - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(null, line))); - } catch (MalContinue e) { - continue; - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; + +public class step1_read_print { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static MalVal EVAL(MalVal ast, String env) { + return ast; + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(String env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + } + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(null, line))); + } catch (MalContinue e) { + continue; + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/step2_eval.java b/impls/java/src/main/java/mal/step2_eval.java index 6de69cd811..976b2a2905 100644 --- a/impls/java/src/main/java/mal/step2_eval.java +++ b/impls/java/src/main/java/mal/step2_eval.java @@ -1,138 +1,138 @@ -package mal; - -import java.io.IOException; - -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Iterator; -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; - -public class step2_eval { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static MalVal eval_ast(MalVal ast, HashMap env) throws MalThrowable { - if (ast instanceof MalSymbol) { - MalSymbol sym = (MalSymbol)ast; - return (MalVal)env.get(sym.getName()); - } else if (ast instanceof MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - for (MalVal mv : (List)old_lst.value) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast instanceof MalHashMap) { - MalHashMap new_hm = new MalHashMap(); - Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); - while (it.hasNext()) { - Map.Entry entry = (Map.Entry)it.next(); - new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); - } - return new_hm; - } else { - return ast; - } - } - - public static MalVal EVAL(MalVal orig_ast, HashMap env) throws MalThrowable { - MalVal a0; - //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast.nth(0); - if (!(a0 instanceof MalSymbol)) { - throw new MalError("attempt to apply on non-symbol '" - + printer._pr_str(a0,true) + "'"); - } - MalVal args = eval_ast(ast.rest(), env); - MalSymbol fsym = (MalSymbol)a0; - ILambda f = (ILambda)env.get(fsym.getName()); - if (f == null) { - throw new MalError("'" + fsym.getName() + "' not found"); - } - return f.apply((MalList)args); - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(HashMap env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - static MalFunction add = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).add((MalInteger)a.nth(1)); - } - }; - static MalFunction subtract = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).subtract((MalInteger)a.nth(1)); - } - }; - static MalFunction multiply = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).multiply((MalInteger)a.nth(1)); - } - }; - static MalFunction divide = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).divide((MalInteger)a.nth(1)); - } - }; - - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - HashMap repl_env = new HashMap(); - repl_env.put("+", add); - repl_env.put("-", subtract); - repl_env.put("*", multiply); - repl_env.put("/", divide); - - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - } - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(repl_env, line))); - } catch (MalContinue e) { - continue; - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import java.util.List; +import java.util.Map; +import java.util.HashMap; +import java.util.Iterator; +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; + +public class step2_eval { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static MalVal eval_ast(MalVal ast, HashMap env) throws MalThrowable { + if (ast instanceof MalSymbol) { + MalSymbol sym = (MalSymbol)ast; + return (MalVal)env.get(sym.getName()); + } else if (ast instanceof MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + for (MalVal mv : (List)old_lst.value) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast instanceof MalHashMap) { + MalHashMap new_hm = new MalHashMap(); + Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); + while (it.hasNext()) { + Map.Entry entry = (Map.Entry)it.next(); + new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); + } + return new_hm; + } else { + return ast; + } + } + + public static MalVal EVAL(MalVal orig_ast, HashMap env) throws MalThrowable { + MalVal a0; + //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast.nth(0); + if (!(a0 instanceof MalSymbol)) { + throw new MalError("attempt to apply on non-symbol '" + + printer._pr_str(a0,true) + "'"); + } + MalVal args = eval_ast(ast.rest(), env); + MalSymbol fsym = (MalSymbol)a0; + ILambda f = (ILambda)env.get(fsym.getName()); + if (f == null) { + throw new MalError("'" + fsym.getName() + "' not found"); + } + return f.apply((MalList)args); + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(HashMap env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + static MalFunction add = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).add((MalInteger)a.nth(1)); + } + }; + static MalFunction subtract = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).subtract((MalInteger)a.nth(1)); + } + }; + static MalFunction multiply = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).multiply((MalInteger)a.nth(1)); + } + }; + static MalFunction divide = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).divide((MalInteger)a.nth(1)); + } + }; + + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + HashMap repl_env = new HashMap(); + repl_env.put("+", add); + repl_env.put("-", subtract); + repl_env.put("*", multiply); + repl_env.put("/", divide); + + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + } + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(repl_env, line))); + } catch (MalContinue e) { + continue; + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/step3_env.java b/impls/java/src/main/java/mal/step3_env.java index 65649718b8..e44960ae05 100644 --- a/impls/java/src/main/java/mal/step3_env.java +++ b/impls/java/src/main/java/mal/step3_env.java @@ -1,158 +1,158 @@ -package mal; - -import java.io.IOException; - -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Iterator; -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; -import mal.env.Env; - -public class step3_env { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { - if (ast instanceof MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast instanceof MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - for (MalVal mv : (List)old_lst.value) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast instanceof MalHashMap) { - MalHashMap new_hm = new MalHashMap(); - Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); - while (it.hasNext()) { - Map.Entry entry = (Map.Entry)it.next(); - new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); - } - return new_hm; - } else { - return ast; - } - } - - public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { - MalVal a0, a1,a2, res; - //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast.nth(0); - if (!(a0 instanceof MalSymbol)) { - throw new MalError("attempt to apply on non-symbol '" - + printer._pr_str(a0,true) + "'"); - } - - switch (((MalSymbol)a0).getName()) { - case "def!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - env.set(((MalSymbol)a1), res); - return res; - case "let*": - a1 = ast.nth(1); - a2 = ast.nth(2); - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1).nth(i); - val = ((MalList)a1).nth(i+1); - let_env.set(key, EVAL(val, let_env)); - } - return EVAL(a2, let_env); - default: - MalVal args = eval_ast(ast.rest(), env); - ILambda f = (ILambda)env.get((MalSymbol)a0); - return f.apply((MalList)args); - } - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(Env env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - static MalFunction add = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).add((MalInteger)a.nth(1)); - } - }; - static MalFunction subtract = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).subtract((MalInteger)a.nth(1)); - } - }; - static MalFunction multiply = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).multiply((MalInteger)a.nth(1)); - } - }; - static MalFunction divide = new MalFunction() { - public MalVal apply(MalList a) throws MalThrowable { - return ((MalInteger)a.nth(0)).divide((MalInteger)a.nth(1)); - } - }; - - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - Env repl_env = new Env(null); - repl_env.set(new MalSymbol("+"), add); - repl_env.set(new MalSymbol("-"), subtract); - repl_env.set(new MalSymbol("*"), multiply); - repl_env.set(new MalSymbol("/"), divide); - - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - } - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(repl_env, line))); - } catch (MalContinue e) { - continue; - } catch (MalException e) { - System.out.println("Error: " + printer._pr_str(e.getValue(), false)); - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import java.util.List; +import java.util.Map; +import java.util.HashMap; +import java.util.Iterator; +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; +import mal.env.Env; + +public class step3_env { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { + if (ast instanceof MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast instanceof MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + for (MalVal mv : (List)old_lst.value) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast instanceof MalHashMap) { + MalHashMap new_hm = new MalHashMap(); + Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); + while (it.hasNext()) { + Map.Entry entry = (Map.Entry)it.next(); + new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); + } + return new_hm; + } else { + return ast; + } + } + + public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { + MalVal a0, a1,a2, res; + //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast.nth(0); + if (!(a0 instanceof MalSymbol)) { + throw new MalError("attempt to apply on non-symbol '" + + printer._pr_str(a0,true) + "'"); + } + + switch (((MalSymbol)a0).getName()) { + case "def!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + env.set(((MalSymbol)a1), res); + return res; + case "let*": + a1 = ast.nth(1); + a2 = ast.nth(2); + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1).nth(i); + val = ((MalList)a1).nth(i+1); + let_env.set(key, EVAL(val, let_env)); + } + return EVAL(a2, let_env); + default: + MalVal args = eval_ast(ast.rest(), env); + ILambda f = (ILambda)env.get((MalSymbol)a0); + return f.apply((MalList)args); + } + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(Env env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + static MalFunction add = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).add((MalInteger)a.nth(1)); + } + }; + static MalFunction subtract = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).subtract((MalInteger)a.nth(1)); + } + }; + static MalFunction multiply = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).multiply((MalInteger)a.nth(1)); + } + }; + static MalFunction divide = new MalFunction() { + public MalVal apply(MalList a) throws MalThrowable { + return ((MalInteger)a.nth(0)).divide((MalInteger)a.nth(1)); + } + }; + + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + Env repl_env = new Env(null); + repl_env.set(new MalSymbol("+"), add); + repl_env.set(new MalSymbol("-"), subtract); + repl_env.set(new MalSymbol("*"), multiply); + repl_env.set(new MalSymbol("/"), divide); + + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + } + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(repl_env, line))); + } catch (MalContinue e) { + continue; + } catch (MalException e) { + System.out.println("Error: " + printer._pr_str(e.getValue(), false)); + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/step4_if_fn_do.java b/impls/java/src/main/java/mal/step4_if_fn_do.java index ff15709f55..8044d33b6f 100644 --- a/impls/java/src/main/java/mal/step4_if_fn_do.java +++ b/impls/java/src/main/java/mal/step4_if_fn_do.java @@ -1,165 +1,165 @@ -package mal; - -import java.io.IOException; - -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Iterator; -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; -import mal.env.Env; -import mal.core; - -public class step4_if_fn_do { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { - if (ast instanceof MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast instanceof MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - for (MalVal mv : (List)old_lst.value) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast instanceof MalHashMap) { - MalHashMap new_hm = new MalHashMap(); - Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); - while (it.hasNext()) { - Map.Entry entry = (Map.Entry)it.next(); - new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); - } - return new_hm; - } else { - return ast; - } - } - - public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { - MalVal a0, a1,a2, a3, res; - MalList el; - //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast.nth(0); - String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - switch (a0sym) { - case "def!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - env.set(((MalSymbol)a1), res); - return res; - case "let*": - a1 = ast.nth(1); - a2 = ast.nth(2); - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1).nth(i); - val = ((MalList)a1).nth(i+1); - let_env.set(key, EVAL(val, let_env)); - } - return EVAL(a2, let_env); - case "do": - el = (MalList)eval_ast(ast.rest(), env); - return el.nth(el.size()-1); - case "if": - a1 = ast.nth(1); - MalVal cond = EVAL(a1, env); - if (cond == types.Nil || cond == types.False) { - // eval false slot form - if (ast.size() > 3) { - a3 = ast.nth(3); - return EVAL(a3, env); - } else { - return types.Nil; - } - } else { - // eval true slot form - a2 = ast.nth(2); - return EVAL(a2, env); - } - case "fn*": - final MalList a1f = (MalList)ast.nth(1); - final MalVal a2f = ast.nth(2); - final Env cur_env = env; - return new MalFunction () { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(a2f, new Env(cur_env, a1f, args)); - } - }; - default: - el = (MalList)eval_ast(ast, env); - MalFunction f = (MalFunction)el.nth(0); - return f.apply(el.rest()); - } - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(Env env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - Env repl_env = new Env(null); - - // core.java: defined using Java - for (String key : core.ns.keySet()) { - repl_env.set(new MalSymbol(key), core.ns.get(key)); - } - - // core.mal: defined using the language itself - RE(repl_env, "(def! not (fn* (a) (if a false true)))"); - - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - } - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(repl_env, line))); - } catch (MalContinue e) { - continue; - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import java.util.List; +import java.util.Map; +import java.util.HashMap; +import java.util.Iterator; +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; +import mal.env.Env; +import mal.core; + +public class step4_if_fn_do { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { + if (ast instanceof MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast instanceof MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + for (MalVal mv : (List)old_lst.value) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast instanceof MalHashMap) { + MalHashMap new_hm = new MalHashMap(); + Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); + while (it.hasNext()) { + Map.Entry entry = (Map.Entry)it.next(); + new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); + } + return new_hm; + } else { + return ast; + } + } + + public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { + MalVal a0, a1,a2, a3, res; + MalList el; + //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast.nth(0); + String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + switch (a0sym) { + case "def!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + env.set(((MalSymbol)a1), res); + return res; + case "let*": + a1 = ast.nth(1); + a2 = ast.nth(2); + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1).nth(i); + val = ((MalList)a1).nth(i+1); + let_env.set(key, EVAL(val, let_env)); + } + return EVAL(a2, let_env); + case "do": + el = (MalList)eval_ast(ast.rest(), env); + return el.nth(el.size()-1); + case "if": + a1 = ast.nth(1); + MalVal cond = EVAL(a1, env); + if (cond == types.Nil || cond == types.False) { + // eval false slot form + if (ast.size() > 3) { + a3 = ast.nth(3); + return EVAL(a3, env); + } else { + return types.Nil; + } + } else { + // eval true slot form + a2 = ast.nth(2); + return EVAL(a2, env); + } + case "fn*": + final MalList a1f = (MalList)ast.nth(1); + final MalVal a2f = ast.nth(2); + final Env cur_env = env; + return new MalFunction () { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(a2f, new Env(cur_env, a1f, args)); + } + }; + default: + el = (MalList)eval_ast(ast, env); + MalFunction f = (MalFunction)el.nth(0); + return f.apply(el.rest()); + } + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(Env env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + Env repl_env = new Env(null); + + // core.java: defined using Java + for (String key : core.ns.keySet()) { + repl_env.set(new MalSymbol(key), core.ns.get(key)); + } + + // core.mal: defined using the language itself + RE(repl_env, "(def! not (fn* (a) (if a false true)))"); + + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + } + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(repl_env, line))); + } catch (MalContinue e) { + continue; + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/step5_tco.java b/impls/java/src/main/java/mal/step5_tco.java index 43c87b73fd..433ee1398b 100644 --- a/impls/java/src/main/java/mal/step5_tco.java +++ b/impls/java/src/main/java/mal/step5_tco.java @@ -1,178 +1,178 @@ -package mal; - -import java.io.IOException; - -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Iterator; -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; -import mal.env.Env; -import mal.core; - -public class step5_tco { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { - if (ast instanceof MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast instanceof MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - for (MalVal mv : (List)old_lst.value) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast instanceof MalHashMap) { - MalHashMap new_hm = new MalHashMap(); - Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); - while (it.hasNext()) { - Map.Entry entry = (Map.Entry)it.next(); - new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); - } - return new_hm; - } else { - return ast; - } - } - - public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { - MalVal a0, a1,a2, a3, res; - MalList el; - - while (true) { - - //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast.nth(0); - String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - switch (a0sym) { - case "def!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - env.set(((MalSymbol)a1), res); - return res; - case "let*": - a1 = ast.nth(1); - a2 = ast.nth(2); - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1).nth(i); - val = ((MalList)a1).nth(i+1); - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast.nth(ast.size()-1); - break; - case "if": - a1 = ast.nth(1); - MalVal cond = EVAL(a1, env); - if (cond == types.Nil || cond == types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast.nth(3); - } else { - return types.Nil; - } - } else { - // eval true slot form - orig_ast = ast.nth(2); - } - break; - case "fn*": - final MalList a1f = (MalList)ast.nth(1); - final MalVal a2f = ast.nth(2); - final Env cur_env = env; - return new MalFunction (a2f, (mal.env.Env)env, a1f) { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(a2f, new Env(cur_env, a1f, args)); - } - }; - default: - el = (MalList)eval_ast(ast, env); - MalFunction f = (MalFunction)el.nth(0); - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.slice(1)); - } else { - return f.apply(el.rest()); - } - } - - } - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(Env env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - Env repl_env = new Env(null); - - // core.java: defined using Java - for (String key : core.ns.keySet()) { - repl_env.set(new MalSymbol(key), core.ns.get(key)); - } - - // core.mal: defined using the language itself - RE(repl_env, "(def! not (fn* (a) (if a false true)))"); - - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - } - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(repl_env, line))); - } catch (MalContinue e) { - continue; - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import java.util.List; +import java.util.Map; +import java.util.HashMap; +import java.util.Iterator; +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; +import mal.env.Env; +import mal.core; + +public class step5_tco { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { + if (ast instanceof MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast instanceof MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + for (MalVal mv : (List)old_lst.value) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast instanceof MalHashMap) { + MalHashMap new_hm = new MalHashMap(); + Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); + while (it.hasNext()) { + Map.Entry entry = (Map.Entry)it.next(); + new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); + } + return new_hm; + } else { + return ast; + } + } + + public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { + MalVal a0, a1,a2, a3, res; + MalList el; + + while (true) { + + //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast.nth(0); + String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + switch (a0sym) { + case "def!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + env.set(((MalSymbol)a1), res); + return res; + case "let*": + a1 = ast.nth(1); + a2 = ast.nth(2); + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1).nth(i); + val = ((MalList)a1).nth(i+1); + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast.nth(ast.size()-1); + break; + case "if": + a1 = ast.nth(1); + MalVal cond = EVAL(a1, env); + if (cond == types.Nil || cond == types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast.nth(3); + } else { + return types.Nil; + } + } else { + // eval true slot form + orig_ast = ast.nth(2); + } + break; + case "fn*": + final MalList a1f = (MalList)ast.nth(1); + final MalVal a2f = ast.nth(2); + final Env cur_env = env; + return new MalFunction (a2f, (mal.env.Env)env, a1f) { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(a2f, new Env(cur_env, a1f, args)); + } + }; + default: + el = (MalList)eval_ast(ast, env); + MalFunction f = (MalFunction)el.nth(0); + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.slice(1)); + } else { + return f.apply(el.rest()); + } + } + + } + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(Env env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + Env repl_env = new Env(null); + + // core.java: defined using Java + for (String key : core.ns.keySet()) { + repl_env.set(new MalSymbol(key), core.ns.get(key)); + } + + // core.mal: defined using the language itself + RE(repl_env, "(def! not (fn* (a) (if a false true)))"); + + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + } + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(repl_env, line))); + } catch (MalContinue e) { + continue; + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/step6_file.java b/impls/java/src/main/java/mal/step6_file.java index bcaf764c57..009e25d281 100644 --- a/impls/java/src/main/java/mal/step6_file.java +++ b/impls/java/src/main/java/mal/step6_file.java @@ -1,196 +1,196 @@ -package mal; - -import java.io.IOException; - -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Iterator; -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; -import mal.env.Env; -import mal.core; - -public class step6_file { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { - if (ast instanceof MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast instanceof MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - for (MalVal mv : (List)old_lst.value) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast instanceof MalHashMap) { - MalHashMap new_hm = new MalHashMap(); - Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); - while (it.hasNext()) { - Map.Entry entry = (Map.Entry)it.next(); - new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); - } - return new_hm; - } else { - return ast; - } - } - - public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { - MalVal a0, a1,a2, a3, res; - MalList el; - - while (true) { - - //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast.nth(0); - String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - switch (a0sym) { - case "def!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - env.set(((MalSymbol)a1), res); - return res; - case "let*": - a1 = ast.nth(1); - a2 = ast.nth(2); - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1).nth(i); - val = ((MalList)a1).nth(i+1); - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast.nth(ast.size()-1); - break; - case "if": - a1 = ast.nth(1); - MalVal cond = EVAL(a1, env); - if (cond == types.Nil || cond == types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast.nth(3); - } else { - return types.Nil; - } - } else { - // eval true slot form - orig_ast = ast.nth(2); - } - break; - case "fn*": - final MalList a1f = (MalList)ast.nth(1); - final MalVal a2f = ast.nth(2); - final Env cur_env = env; - return new MalFunction (a2f, (mal.env.Env)env, a1f) { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(a2f, new Env(cur_env, a1f, args)); - } - }; - default: - el = (MalList)eval_ast(ast, env); - MalFunction f = (MalFunction)el.nth(0); - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.slice(1)); - } else { - return f.apply(el.rest()); - } - } - - } - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(Env env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - final Env repl_env = new Env(null); - - // core.java: defined using Java - for (String key : core.ns.keySet()) { - repl_env.set(new MalSymbol(key), core.ns.get(key)); - } - repl_env.set(new MalSymbol("eval"), new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(args.nth(0), repl_env); - } - }); - MalList _argv = new MalList(); - for (Integer i=1; i < args.length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - - // core.mal: defined using the language itself - RE(repl_env, "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - - Integer fileIdx = 0; - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - fileIdx = 1; - } - if (args.length > fileIdx) { - RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); - return; - } - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(repl_env, line))); - } catch (MalContinue e) { - continue; - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import java.util.List; +import java.util.Map; +import java.util.HashMap; +import java.util.Iterator; +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; +import mal.env.Env; +import mal.core; + +public class step6_file { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { + if (ast instanceof MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast instanceof MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + for (MalVal mv : (List)old_lst.value) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast instanceof MalHashMap) { + MalHashMap new_hm = new MalHashMap(); + Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); + while (it.hasNext()) { + Map.Entry entry = (Map.Entry)it.next(); + new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); + } + return new_hm; + } else { + return ast; + } + } + + public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { + MalVal a0, a1,a2, a3, res; + MalList el; + + while (true) { + + //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast.nth(0); + String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + switch (a0sym) { + case "def!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + env.set(((MalSymbol)a1), res); + return res; + case "let*": + a1 = ast.nth(1); + a2 = ast.nth(2); + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1).nth(i); + val = ((MalList)a1).nth(i+1); + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast.nth(ast.size()-1); + break; + case "if": + a1 = ast.nth(1); + MalVal cond = EVAL(a1, env); + if (cond == types.Nil || cond == types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast.nth(3); + } else { + return types.Nil; + } + } else { + // eval true slot form + orig_ast = ast.nth(2); + } + break; + case "fn*": + final MalList a1f = (MalList)ast.nth(1); + final MalVal a2f = ast.nth(2); + final Env cur_env = env; + return new MalFunction (a2f, (mal.env.Env)env, a1f) { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(a2f, new Env(cur_env, a1f, args)); + } + }; + default: + el = (MalList)eval_ast(ast, env); + MalFunction f = (MalFunction)el.nth(0); + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.slice(1)); + } else { + return f.apply(el.rest()); + } + } + + } + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(Env env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + final Env repl_env = new Env(null); + + // core.java: defined using Java + for (String key : core.ns.keySet()) { + repl_env.set(new MalSymbol(key), core.ns.get(key)); + } + repl_env.set(new MalSymbol("eval"), new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(args.nth(0), repl_env); + } + }); + MalList _argv = new MalList(); + for (Integer i=1; i < args.length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + + // core.mal: defined using the language itself + RE(repl_env, "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + + Integer fileIdx = 0; + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + fileIdx = 1; + } + if (args.length > fileIdx) { + RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); + return; + } + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(repl_env, line))); + } catch (MalContinue e) { + continue; + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/step7_quote.java b/impls/java/src/main/java/mal/step7_quote.java index b82a64a152..9ef35675d2 100644 --- a/impls/java/src/main/java/mal/step7_quote.java +++ b/impls/java/src/main/java/mal/step7_quote.java @@ -1,235 +1,235 @@ -package mal; - -import java.io.IOException; - -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Iterator; -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; -import mal.env.Env; -import mal.core; - -public class step7_quote { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static Boolean starts_with(MalVal ast, String sym) { - // Liskov, forgive me - if (ast instanceof MalList && !(ast instanceof MalVector) && ((MalList)ast).size() == 2) { - MalVal a0 = ((MalList)ast).nth(0); - return a0 instanceof MalSymbol && ((MalSymbol)a0).getName().equals(sym); - } - return false; - } - - public static MalVal quasiquote(MalVal ast) { - if ((ast instanceof MalSymbol || ast instanceof MalHashMap)) - return new MalList(new MalSymbol("quote"), ast); - - if (!(ast instanceof MalList)) - return ast; - - if (starts_with(ast, "unquote")) - return ((MalList)ast).nth(1); - - MalVal res = new MalList(); - for (Integer i=((MalList)ast).size()-1; 0<=i; i--) { - MalVal elt = ((MalList)ast).nth(i); - if (starts_with(elt, "splice-unquote")) - res = new MalList(new MalSymbol("concat"), ((MalList)elt).nth(1), res); - else - res = new MalList(new MalSymbol("cons"), quasiquote(elt), res); - } - if (ast instanceof MalVector) - res = new MalList(new MalSymbol("vec"), res); - return res; - } - - public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { - if (ast instanceof MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast instanceof MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - for (MalVal mv : (List)old_lst.value) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast instanceof MalHashMap) { - MalHashMap new_hm = new MalHashMap(); - Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); - while (it.hasNext()) { - Map.Entry entry = (Map.Entry)it.next(); - new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); - } - return new_hm; - } else { - return ast; - } - } - - public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { - MalVal a0, a1,a2, a3, res; - MalList el; - - while (true) { - - //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - - // apply list - MalList ast = (MalList)orig_ast; - if (ast.size() == 0) { return ast; } - a0 = ast.nth(0); - String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - switch (a0sym) { - case "def!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - env.set(((MalSymbol)a1), res); - return res; - case "let*": - a1 = ast.nth(1); - a2 = ast.nth(2); - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1).nth(i); - val = ((MalList)a1).nth(i+1); - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "quote": - return ast.nth(1); - case "quasiquoteexpand": - return quasiquote(ast.nth(1)); - case "quasiquote": - orig_ast = quasiquote(ast.nth(1)); - break; - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast.nth(ast.size()-1); - break; - case "if": - a1 = ast.nth(1); - MalVal cond = EVAL(a1, env); - if (cond == types.Nil || cond == types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast.nth(3); - } else { - return types.Nil; - } - } else { - // eval true slot form - orig_ast = ast.nth(2); - } - break; - case "fn*": - final MalList a1f = (MalList)ast.nth(1); - final MalVal a2f = ast.nth(2); - final Env cur_env = env; - return new MalFunction (a2f, (mal.env.Env)env, a1f) { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(a2f, new Env(cur_env, a1f, args)); - } - }; - default: - el = (MalList)eval_ast(ast, env); - MalFunction f = (MalFunction)el.nth(0); - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.slice(1)); - } else { - return f.apply(el.rest()); - } - } - - } - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(Env env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - final Env repl_env = new Env(null); - - // core.java: defined using Java - for (String key : core.ns.keySet()) { - repl_env.set(new MalSymbol(key), core.ns.get(key)); - } - repl_env.set(new MalSymbol("eval"), new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(args.nth(0), repl_env); - } - }); - MalList _argv = new MalList(); - for (Integer i=1; i < args.length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - - // core.mal: defined using the language itself - RE(repl_env, "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - - Integer fileIdx = 0; - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - fileIdx = 1; - } - if (args.length > fileIdx) { - RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); - return; - } - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(repl_env, line))); - } catch (MalContinue e) { - continue; - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import java.util.List; +import java.util.Map; +import java.util.HashMap; +import java.util.Iterator; +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; +import mal.env.Env; +import mal.core; + +public class step7_quote { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static Boolean starts_with(MalVal ast, String sym) { + // Liskov, forgive me + if (ast instanceof MalList && !(ast instanceof MalVector) && ((MalList)ast).size() == 2) { + MalVal a0 = ((MalList)ast).nth(0); + return a0 instanceof MalSymbol && ((MalSymbol)a0).getName().equals(sym); + } + return false; + } + + public static MalVal quasiquote(MalVal ast) { + if ((ast instanceof MalSymbol || ast instanceof MalHashMap)) + return new MalList(new MalSymbol("quote"), ast); + + if (!(ast instanceof MalList)) + return ast; + + if (starts_with(ast, "unquote")) + return ((MalList)ast).nth(1); + + MalVal res = new MalList(); + for (Integer i=((MalList)ast).size()-1; 0<=i; i--) { + MalVal elt = ((MalList)ast).nth(i); + if (starts_with(elt, "splice-unquote")) + res = new MalList(new MalSymbol("concat"), ((MalList)elt).nth(1), res); + else + res = new MalList(new MalSymbol("cons"), quasiquote(elt), res); + } + if (ast instanceof MalVector) + res = new MalList(new MalSymbol("vec"), res); + return res; + } + + public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { + if (ast instanceof MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast instanceof MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + for (MalVal mv : (List)old_lst.value) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast instanceof MalHashMap) { + MalHashMap new_hm = new MalHashMap(); + Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); + while (it.hasNext()) { + Map.Entry entry = (Map.Entry)it.next(); + new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); + } + return new_hm; + } else { + return ast; + } + } + + public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { + MalVal a0, a1,a2, a3, res; + MalList el; + + while (true) { + + //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + + // apply list + MalList ast = (MalList)orig_ast; + if (ast.size() == 0) { return ast; } + a0 = ast.nth(0); + String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + switch (a0sym) { + case "def!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + env.set(((MalSymbol)a1), res); + return res; + case "let*": + a1 = ast.nth(1); + a2 = ast.nth(2); + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1).nth(i); + val = ((MalList)a1).nth(i+1); + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "quote": + return ast.nth(1); + case "quasiquoteexpand": + return quasiquote(ast.nth(1)); + case "quasiquote": + orig_ast = quasiquote(ast.nth(1)); + break; + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast.nth(ast.size()-1); + break; + case "if": + a1 = ast.nth(1); + MalVal cond = EVAL(a1, env); + if (cond == types.Nil || cond == types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast.nth(3); + } else { + return types.Nil; + } + } else { + // eval true slot form + orig_ast = ast.nth(2); + } + break; + case "fn*": + final MalList a1f = (MalList)ast.nth(1); + final MalVal a2f = ast.nth(2); + final Env cur_env = env; + return new MalFunction (a2f, (mal.env.Env)env, a1f) { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(a2f, new Env(cur_env, a1f, args)); + } + }; + default: + el = (MalList)eval_ast(ast, env); + MalFunction f = (MalFunction)el.nth(0); + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.slice(1)); + } else { + return f.apply(el.rest()); + } + } + + } + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(Env env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + final Env repl_env = new Env(null); + + // core.java: defined using Java + for (String key : core.ns.keySet()) { + repl_env.set(new MalSymbol(key), core.ns.get(key)); + } + repl_env.set(new MalSymbol("eval"), new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(args.nth(0), repl_env); + } + }); + MalList _argv = new MalList(); + for (Integer i=1; i < args.length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + + // core.mal: defined using the language itself + RE(repl_env, "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + + Integer fileIdx = 0; + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + fileIdx = 1; + } + if (args.length > fileIdx) { + RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); + return; + } + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(repl_env, line))); + } catch (MalContinue e) { + continue; + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/step8_macros.java b/impls/java/src/main/java/mal/step8_macros.java index 60353f6e8a..1a619e44ba 100644 --- a/impls/java/src/main/java/mal/step8_macros.java +++ b/impls/java/src/main/java/mal/step8_macros.java @@ -1,278 +1,278 @@ -package mal; - -import java.io.IOException; - -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Iterator; -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; -import mal.env.Env; -import mal.core; - -public class step8_macros { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static Boolean starts_with(MalVal ast, String sym) { - // Liskov, forgive me - if (ast instanceof MalList && !(ast instanceof MalVector) && ((MalList)ast).size() == 2) { - MalVal a0 = ((MalList)ast).nth(0); - return a0 instanceof MalSymbol && ((MalSymbol)a0).getName().equals(sym); - } - return false; - } - - public static MalVal quasiquote(MalVal ast) { - if ((ast instanceof MalSymbol || ast instanceof MalHashMap)) - return new MalList(new MalSymbol("quote"), ast); - - if (!(ast instanceof MalList)) - return ast; - - if (starts_with(ast, "unquote")) - return ((MalList)ast).nth(1); - - MalVal res = new MalList(); - for (Integer i=((MalList)ast).size()-1; 0<=i; i--) { - MalVal elt = ((MalList)ast).nth(i); - if (starts_with(elt, "splice-unquote")) - res = new MalList(new MalSymbol("concat"), ((MalList)elt).nth(1), res); - else - res = new MalList(new MalSymbol("cons"), quasiquote(elt), res); - } - if (ast instanceof MalVector) - res = new MalList(new MalSymbol("vec"), res); - return res; - } - - public static Boolean is_macro_call(MalVal ast, Env env) - throws MalThrowable { - if (ast instanceof MalList) { - MalVal a0 = ((MalList)ast).nth(0); - if (a0 instanceof MalSymbol && - env.find(((MalSymbol)a0)) != null) { - MalVal mac = env.get(((MalSymbol)a0)); - if (mac instanceof MalFunction && - ((MalFunction)mac).isMacro()) { - return true; - } - } - } - return false; - } - - public static MalVal macroexpand(MalVal ast, Env env) - throws MalThrowable { - while (is_macro_call(ast, env)) { - MalSymbol a0 = (MalSymbol)((MalList)ast).nth(0); - MalFunction mac = (MalFunction) env.get(a0); - ast = mac.apply(((MalList)ast).rest()); - } - return ast; - } - - public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { - if (ast instanceof MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast instanceof MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - for (MalVal mv : (List)old_lst.value) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast instanceof MalHashMap) { - MalHashMap new_hm = new MalHashMap(); - Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); - while (it.hasNext()) { - Map.Entry entry = (Map.Entry)it.next(); - new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); - } - return new_hm; - } else { - return ast; - } - } - - public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { - MalVal a0, a1,a2, a3, res; - MalList el; - - while (true) { - - //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - if (((MalList)orig_ast).size() == 0) { return orig_ast; } - - // apply list - MalVal expanded = macroexpand(orig_ast, env); - if (!expanded.list_Q()) { - return eval_ast(expanded, env); - } - MalList ast = (MalList) expanded; - if (ast.size() == 0) { return ast; } - a0 = ast.nth(0); - String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - switch (a0sym) { - case "def!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - env.set(((MalSymbol)a1), res); - return res; - case "let*": - a1 = ast.nth(1); - a2 = ast.nth(2); - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1).nth(i); - val = ((MalList)a1).nth(i+1); - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "quote": - return ast.nth(1); - case "quasiquoteexpand": - return quasiquote(ast.nth(1)); - case "quasiquote": - orig_ast = quasiquote(ast.nth(1)); - break; - case "defmacro!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - res = res.copy(); - ((MalFunction)res).setMacro(); - env.set((MalSymbol)a1, res); - return res; - case "macroexpand": - a1 = ast.nth(1); - return macroexpand(a1, env); - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast.nth(ast.size()-1); - break; - case "if": - a1 = ast.nth(1); - MalVal cond = EVAL(a1, env); - if (cond == types.Nil || cond == types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast.nth(3); - } else { - return types.Nil; - } - } else { - // eval true slot form - orig_ast = ast.nth(2); - } - break; - case "fn*": - final MalList a1f = (MalList)ast.nth(1); - final MalVal a2f = ast.nth(2); - final Env cur_env = env; - return new MalFunction (a2f, (mal.env.Env)env, a1f) { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(a2f, new Env(cur_env, a1f, args)); - } - }; - default: - el = (MalList)eval_ast(ast, env); - MalFunction f = (MalFunction)el.nth(0); - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.slice(1)); - } else { - return f.apply(el.rest()); - } - } - - } - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(Env env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - final Env repl_env = new Env(null); - - // core.java: defined using Java - for (String key : core.ns.keySet()) { - repl_env.set(new MalSymbol(key), core.ns.get(key)); - } - repl_env.set(new MalSymbol("eval"), new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(args.nth(0), repl_env); - } - }); - MalList _argv = new MalList(); - for (Integer i=1; i < args.length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - - // core.mal: defined using the language itself - RE(repl_env, "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - RE(repl_env, "(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)))))))"); - - Integer fileIdx = 0; - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - fileIdx = 1; - } - if (args.length > fileIdx) { - RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); - return; - } - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(repl_env, line))); - } catch (MalContinue e) { - continue; - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import java.util.List; +import java.util.Map; +import java.util.HashMap; +import java.util.Iterator; +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; +import mal.env.Env; +import mal.core; + +public class step8_macros { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static Boolean starts_with(MalVal ast, String sym) { + // Liskov, forgive me + if (ast instanceof MalList && !(ast instanceof MalVector) && ((MalList)ast).size() == 2) { + MalVal a0 = ((MalList)ast).nth(0); + return a0 instanceof MalSymbol && ((MalSymbol)a0).getName().equals(sym); + } + return false; + } + + public static MalVal quasiquote(MalVal ast) { + if ((ast instanceof MalSymbol || ast instanceof MalHashMap)) + return new MalList(new MalSymbol("quote"), ast); + + if (!(ast instanceof MalList)) + return ast; + + if (starts_with(ast, "unquote")) + return ((MalList)ast).nth(1); + + MalVal res = new MalList(); + for (Integer i=((MalList)ast).size()-1; 0<=i; i--) { + MalVal elt = ((MalList)ast).nth(i); + if (starts_with(elt, "splice-unquote")) + res = new MalList(new MalSymbol("concat"), ((MalList)elt).nth(1), res); + else + res = new MalList(new MalSymbol("cons"), quasiquote(elt), res); + } + if (ast instanceof MalVector) + res = new MalList(new MalSymbol("vec"), res); + return res; + } + + public static Boolean is_macro_call(MalVal ast, Env env) + throws MalThrowable { + if (ast instanceof MalList) { + MalVal a0 = ((MalList)ast).nth(0); + if (a0 instanceof MalSymbol && + env.find(((MalSymbol)a0)) != null) { + MalVal mac = env.get(((MalSymbol)a0)); + if (mac instanceof MalFunction && + ((MalFunction)mac).isMacro()) { + return true; + } + } + } + return false; + } + + public static MalVal macroexpand(MalVal ast, Env env) + throws MalThrowable { + while (is_macro_call(ast, env)) { + MalSymbol a0 = (MalSymbol)((MalList)ast).nth(0); + MalFunction mac = (MalFunction) env.get(a0); + ast = mac.apply(((MalList)ast).rest()); + } + return ast; + } + + public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { + if (ast instanceof MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast instanceof MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + for (MalVal mv : (List)old_lst.value) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast instanceof MalHashMap) { + MalHashMap new_hm = new MalHashMap(); + Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); + while (it.hasNext()) { + Map.Entry entry = (Map.Entry)it.next(); + new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); + } + return new_hm; + } else { + return ast; + } + } + + public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { + MalVal a0, a1,a2, a3, res; + MalList el; + + while (true) { + + //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + if (((MalList)orig_ast).size() == 0) { return orig_ast; } + + // apply list + MalVal expanded = macroexpand(orig_ast, env); + if (!expanded.list_Q()) { + return eval_ast(expanded, env); + } + MalList ast = (MalList) expanded; + if (ast.size() == 0) { return ast; } + a0 = ast.nth(0); + String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + switch (a0sym) { + case "def!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + env.set(((MalSymbol)a1), res); + return res; + case "let*": + a1 = ast.nth(1); + a2 = ast.nth(2); + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1).nth(i); + val = ((MalList)a1).nth(i+1); + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "quote": + return ast.nth(1); + case "quasiquoteexpand": + return quasiquote(ast.nth(1)); + case "quasiquote": + orig_ast = quasiquote(ast.nth(1)); + break; + case "defmacro!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + res = res.copy(); + ((MalFunction)res).setMacro(); + env.set((MalSymbol)a1, res); + return res; + case "macroexpand": + a1 = ast.nth(1); + return macroexpand(a1, env); + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast.nth(ast.size()-1); + break; + case "if": + a1 = ast.nth(1); + MalVal cond = EVAL(a1, env); + if (cond == types.Nil || cond == types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast.nth(3); + } else { + return types.Nil; + } + } else { + // eval true slot form + orig_ast = ast.nth(2); + } + break; + case "fn*": + final MalList a1f = (MalList)ast.nth(1); + final MalVal a2f = ast.nth(2); + final Env cur_env = env; + return new MalFunction (a2f, (mal.env.Env)env, a1f) { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(a2f, new Env(cur_env, a1f, args)); + } + }; + default: + el = (MalList)eval_ast(ast, env); + MalFunction f = (MalFunction)el.nth(0); + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.slice(1)); + } else { + return f.apply(el.rest()); + } + } + + } + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(Env env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + final Env repl_env = new Env(null); + + // core.java: defined using Java + for (String key : core.ns.keySet()) { + repl_env.set(new MalSymbol(key), core.ns.get(key)); + } + repl_env.set(new MalSymbol("eval"), new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(args.nth(0), repl_env); + } + }); + MalList _argv = new MalList(); + for (Integer i=1; i < args.length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + + // core.mal: defined using the language itself + RE(repl_env, "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + RE(repl_env, "(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)))))))"); + + Integer fileIdx = 0; + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + fileIdx = 1; + } + if (args.length > fileIdx) { + RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); + return; + } + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(repl_env, line))); + } catch (MalContinue e) { + continue; + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/step9_try.java b/impls/java/src/main/java/mal/step9_try.java index e96b86da5e..d46a7260c5 100644 --- a/impls/java/src/main/java/mal/step9_try.java +++ b/impls/java/src/main/java/mal/step9_try.java @@ -1,309 +1,309 @@ -package mal; - -import java.io.IOException; - -import java.io.StringWriter; -import java.io.PrintWriter; -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Iterator; -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; -import mal.env.Env; -import mal.core; - -public class step9_try { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static Boolean starts_with(MalVal ast, String sym) { - // Liskov, forgive me - if (ast instanceof MalList && !(ast instanceof MalVector) && ((MalList)ast).size() == 2) { - MalVal a0 = ((MalList)ast).nth(0); - return a0 instanceof MalSymbol && ((MalSymbol)a0).getName().equals(sym); - } - return false; - } - - public static MalVal quasiquote(MalVal ast) { - if ((ast instanceof MalSymbol || ast instanceof MalHashMap)) - return new MalList(new MalSymbol("quote"), ast); - - if (!(ast instanceof MalList)) - return ast; - - if (starts_with(ast, "unquote")) - return ((MalList)ast).nth(1); - - MalVal res = new MalList(); - for (Integer i=((MalList)ast).size()-1; 0<=i; i--) { - MalVal elt = ((MalList)ast).nth(i); - if (starts_with(elt, "splice-unquote")) - res = new MalList(new MalSymbol("concat"), ((MalList)elt).nth(1), res); - else - res = new MalList(new MalSymbol("cons"), quasiquote(elt), res); - } - if (ast instanceof MalVector) - res = new MalList(new MalSymbol("vec"), res); - return res; - } - - public static Boolean is_macro_call(MalVal ast, Env env) - throws MalThrowable { - if (ast instanceof MalList) { - MalVal a0 = ((MalList)ast).nth(0); - if (a0 instanceof MalSymbol && - env.find(((MalSymbol)a0)) != null) { - MalVal mac = env.get(((MalSymbol)a0)); - if (mac instanceof MalFunction && - ((MalFunction)mac).isMacro()) { - return true; - } - } - } - return false; - } - - public static MalVal macroexpand(MalVal ast, Env env) - throws MalThrowable { - while (is_macro_call(ast, env)) { - MalSymbol a0 = (MalSymbol)((MalList)ast).nth(0); - MalFunction mac = (MalFunction) env.get(a0); - ast = mac.apply(((MalList)ast).rest()); - } - return ast; - } - - public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { - if (ast instanceof MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast instanceof MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - for (MalVal mv : (List)old_lst.value) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast instanceof MalHashMap) { - MalHashMap new_hm = new MalHashMap(); - Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); - while (it.hasNext()) { - Map.Entry entry = (Map.Entry)it.next(); - new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); - } - return new_hm; - } else { - return ast; - } - } - - public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { - MalVal a0, a1,a2, a3, res; - MalList el; - - while (true) { - - //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - if (((MalList)orig_ast).size() == 0) { return orig_ast; } - - // apply list - MalVal expanded = macroexpand(orig_ast, env); - if (!expanded.list_Q()) { - return eval_ast(expanded, env); - } - MalList ast = (MalList) expanded; - if (ast.size() == 0) { return ast; } - a0 = ast.nth(0); - String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - switch (a0sym) { - case "def!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - env.set(((MalSymbol)a1), res); - return res; - case "let*": - a1 = ast.nth(1); - a2 = ast.nth(2); - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1).nth(i); - val = ((MalList)a1).nth(i+1); - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "quote": - return ast.nth(1); - case "quasiquoteexpand": - return quasiquote(ast.nth(1)); - case "quasiquote": - orig_ast = quasiquote(ast.nth(1)); - break; - case "defmacro!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - res = res.copy(); - ((MalFunction)res).setMacro(); - env.set((MalSymbol)a1, res); - return res; - case "macroexpand": - a1 = ast.nth(1); - return macroexpand(a1, env); - case "try*": - try { - return EVAL(ast.nth(1), env); - } catch (Throwable t) { - if (ast.size() > 2) { - MalVal exc; - a2 = ast.nth(2); - MalVal a20 = ((MalList)a2).nth(0); - if (((MalSymbol)a20).getName().equals("catch*")) { - if (t instanceof MalException) { - exc = ((MalException)t).getValue(); - } else { - StringWriter sw = new StringWriter(); - t.printStackTrace(new PrintWriter(sw)); - String tstr = sw.toString(); - exc = new MalString(t.getMessage() + ": " + tstr); - } - return EVAL(((MalList)a2).nth(2), - new Env(env, ((MalList)a2).slice(1,2), - new MalList(exc))); - } - } - throw t; - } - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast.nth(ast.size()-1); - break; - case "if": - a1 = ast.nth(1); - MalVal cond = EVAL(a1, env); - if (cond == types.Nil || cond == types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast.nth(3); - } else { - return types.Nil; - } - } else { - // eval true slot form - orig_ast = ast.nth(2); - } - break; - case "fn*": - final MalList a1f = (MalList)ast.nth(1); - final MalVal a2f = ast.nth(2); - final Env cur_env = env; - return new MalFunction (a2f, (mal.env.Env)env, a1f) { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(a2f, new Env(cur_env, a1f, args)); - } - }; - default: - el = (MalList)eval_ast(ast, env); - MalFunction f = (MalFunction)el.nth(0); - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.slice(1)); - } else { - return f.apply(el.rest()); - } - } - - } - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(Env env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - final Env repl_env = new Env(null); - - // core.java: defined using Java - for (String key : core.ns.keySet()) { - repl_env.set(new MalSymbol(key), core.ns.get(key)); - } - repl_env.set(new MalSymbol("eval"), new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(args.nth(0), repl_env); - } - }); - MalList _argv = new MalList(); - for (Integer i=1; i < args.length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - - // core.mal: defined using the language itself - RE(repl_env, "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - RE(repl_env, "(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)))))))"); - - Integer fileIdx = 0; - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - fileIdx = 1; - } - if (args.length > fileIdx) { - RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); - return; - } - - // repl loop - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(repl_env, line))); - } catch (MalContinue e) { - continue; - } catch (MalException e) { - System.out.println("Error: " + printer._pr_str(e.getValue(), false)); - continue; - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import java.io.StringWriter; +import java.io.PrintWriter; +import java.util.List; +import java.util.Map; +import java.util.HashMap; +import java.util.Iterator; +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; +import mal.env.Env; +import mal.core; + +public class step9_try { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static Boolean starts_with(MalVal ast, String sym) { + // Liskov, forgive me + if (ast instanceof MalList && !(ast instanceof MalVector) && ((MalList)ast).size() == 2) { + MalVal a0 = ((MalList)ast).nth(0); + return a0 instanceof MalSymbol && ((MalSymbol)a0).getName().equals(sym); + } + return false; + } + + public static MalVal quasiquote(MalVal ast) { + if ((ast instanceof MalSymbol || ast instanceof MalHashMap)) + return new MalList(new MalSymbol("quote"), ast); + + if (!(ast instanceof MalList)) + return ast; + + if (starts_with(ast, "unquote")) + return ((MalList)ast).nth(1); + + MalVal res = new MalList(); + for (Integer i=((MalList)ast).size()-1; 0<=i; i--) { + MalVal elt = ((MalList)ast).nth(i); + if (starts_with(elt, "splice-unquote")) + res = new MalList(new MalSymbol("concat"), ((MalList)elt).nth(1), res); + else + res = new MalList(new MalSymbol("cons"), quasiquote(elt), res); + } + if (ast instanceof MalVector) + res = new MalList(new MalSymbol("vec"), res); + return res; + } + + public static Boolean is_macro_call(MalVal ast, Env env) + throws MalThrowable { + if (ast instanceof MalList) { + MalVal a0 = ((MalList)ast).nth(0); + if (a0 instanceof MalSymbol && + env.find(((MalSymbol)a0)) != null) { + MalVal mac = env.get(((MalSymbol)a0)); + if (mac instanceof MalFunction && + ((MalFunction)mac).isMacro()) { + return true; + } + } + } + return false; + } + + public static MalVal macroexpand(MalVal ast, Env env) + throws MalThrowable { + while (is_macro_call(ast, env)) { + MalSymbol a0 = (MalSymbol)((MalList)ast).nth(0); + MalFunction mac = (MalFunction) env.get(a0); + ast = mac.apply(((MalList)ast).rest()); + } + return ast; + } + + public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { + if (ast instanceof MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast instanceof MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + for (MalVal mv : (List)old_lst.value) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast instanceof MalHashMap) { + MalHashMap new_hm = new MalHashMap(); + Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); + while (it.hasNext()) { + Map.Entry entry = (Map.Entry)it.next(); + new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); + } + return new_hm; + } else { + return ast; + } + } + + public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { + MalVal a0, a1,a2, a3, res; + MalList el; + + while (true) { + + //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + if (((MalList)orig_ast).size() == 0) { return orig_ast; } + + // apply list + MalVal expanded = macroexpand(orig_ast, env); + if (!expanded.list_Q()) { + return eval_ast(expanded, env); + } + MalList ast = (MalList) expanded; + if (ast.size() == 0) { return ast; } + a0 = ast.nth(0); + String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + switch (a0sym) { + case "def!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + env.set(((MalSymbol)a1), res); + return res; + case "let*": + a1 = ast.nth(1); + a2 = ast.nth(2); + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1).nth(i); + val = ((MalList)a1).nth(i+1); + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "quote": + return ast.nth(1); + case "quasiquoteexpand": + return quasiquote(ast.nth(1)); + case "quasiquote": + orig_ast = quasiquote(ast.nth(1)); + break; + case "defmacro!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + res = res.copy(); + ((MalFunction)res).setMacro(); + env.set((MalSymbol)a1, res); + return res; + case "macroexpand": + a1 = ast.nth(1); + return macroexpand(a1, env); + case "try*": + try { + return EVAL(ast.nth(1), env); + } catch (Throwable t) { + if (ast.size() > 2) { + MalVal exc; + a2 = ast.nth(2); + MalVal a20 = ((MalList)a2).nth(0); + if (((MalSymbol)a20).getName().equals("catch*")) { + if (t instanceof MalException) { + exc = ((MalException)t).getValue(); + } else { + StringWriter sw = new StringWriter(); + t.printStackTrace(new PrintWriter(sw)); + String tstr = sw.toString(); + exc = new MalString(t.getMessage() + ": " + tstr); + } + return EVAL(((MalList)a2).nth(2), + new Env(env, ((MalList)a2).slice(1,2), + new MalList(exc))); + } + } + throw t; + } + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast.nth(ast.size()-1); + break; + case "if": + a1 = ast.nth(1); + MalVal cond = EVAL(a1, env); + if (cond == types.Nil || cond == types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast.nth(3); + } else { + return types.Nil; + } + } else { + // eval true slot form + orig_ast = ast.nth(2); + } + break; + case "fn*": + final MalList a1f = (MalList)ast.nth(1); + final MalVal a2f = ast.nth(2); + final Env cur_env = env; + return new MalFunction (a2f, (mal.env.Env)env, a1f) { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(a2f, new Env(cur_env, a1f, args)); + } + }; + default: + el = (MalList)eval_ast(ast, env); + MalFunction f = (MalFunction)el.nth(0); + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.slice(1)); + } else { + return f.apply(el.rest()); + } + } + + } + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(Env env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + final Env repl_env = new Env(null); + + // core.java: defined using Java + for (String key : core.ns.keySet()) { + repl_env.set(new MalSymbol(key), core.ns.get(key)); + } + repl_env.set(new MalSymbol("eval"), new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(args.nth(0), repl_env); + } + }); + MalList _argv = new MalList(); + for (Integer i=1; i < args.length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + + // core.mal: defined using the language itself + RE(repl_env, "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + RE(repl_env, "(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)))))))"); + + Integer fileIdx = 0; + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + fileIdx = 1; + } + if (args.length > fileIdx) { + RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); + return; + } + + // repl loop + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(repl_env, line))); + } catch (MalContinue e) { + continue; + } catch (MalException e) { + System.out.println("Error: " + printer._pr_str(e.getValue(), false)); + continue; + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/stepA_mal.java b/impls/java/src/main/java/mal/stepA_mal.java index 4c8af749d2..a5acfc3c30 100644 --- a/impls/java/src/main/java/mal/stepA_mal.java +++ b/impls/java/src/main/java/mal/stepA_mal.java @@ -1,311 +1,311 @@ -package mal; - -import java.io.IOException; - -import java.io.StringWriter; -import java.io.PrintWriter; -import java.util.List; -import java.util.Map; -import java.util.HashMap; -import java.util.Iterator; -import mal.types.*; -import mal.readline; -import mal.reader; -import mal.printer; -import mal.env.Env; -import mal.core; - -public class stepA_mal { - // read - public static MalVal READ(String str) throws MalThrowable { - return reader.read_str(str); - } - - // eval - public static Boolean starts_with(MalVal ast, String sym) { - // Liskov, forgive me - if (ast instanceof MalList && !(ast instanceof MalVector) && ((MalList)ast).size() == 2) { - MalVal a0 = ((MalList)ast).nth(0); - return a0 instanceof MalSymbol && ((MalSymbol)a0).getName().equals(sym); - } - return false; - } - - public static MalVal quasiquote(MalVal ast) { - if ((ast instanceof MalSymbol || ast instanceof MalHashMap)) - return new MalList(new MalSymbol("quote"), ast); - - if (!(ast instanceof MalList)) - return ast; - - if (starts_with(ast, "unquote")) - return ((MalList)ast).nth(1); - - MalVal res = new MalList(); - for (Integer i=((MalList)ast).size()-1; 0<=i; i--) { - MalVal elt = ((MalList)ast).nth(i); - if (starts_with(elt, "splice-unquote")) - res = new MalList(new MalSymbol("concat"), ((MalList)elt).nth(1), res); - else - res = new MalList(new MalSymbol("cons"), quasiquote(elt), res); - } - if (ast instanceof MalVector) - res = new MalList(new MalSymbol("vec"), res); - return res; - } - - public static Boolean is_macro_call(MalVal ast, Env env) - throws MalThrowable { - if (ast instanceof MalList) { - MalVal a0 = ((MalList)ast).nth(0); - if (a0 instanceof MalSymbol && - env.find(((MalSymbol)a0)) != null) { - MalVal mac = env.get(((MalSymbol)a0)); - if (mac instanceof MalFunction && - ((MalFunction)mac).isMacro()) { - return true; - } - } - } - return false; - } - - public static MalVal macroexpand(MalVal ast, Env env) - throws MalThrowable { - while (is_macro_call(ast, env)) { - MalSymbol a0 = (MalSymbol)((MalList)ast).nth(0); - MalFunction mac = (MalFunction) env.get(a0); - ast = mac.apply(((MalList)ast).rest()); - } - return ast; - } - - public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { - if (ast instanceof MalSymbol) { - return env.get((MalSymbol)ast); - } else if (ast instanceof MalList) { - MalList old_lst = (MalList)ast; - MalList new_lst = ast.list_Q() ? new MalList() - : (MalList)new MalVector(); - for (MalVal mv : (List)old_lst.value) { - new_lst.conj_BANG(EVAL(mv, env)); - } - return new_lst; - } else if (ast instanceof MalHashMap) { - MalHashMap new_hm = new MalHashMap(); - Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); - while (it.hasNext()) { - Map.Entry entry = (Map.Entry)it.next(); - new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); - } - return new_hm; - } else { - return ast; - } - } - - public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { - MalVal a0, a1,a2, a3, res; - MalList el; - - while (true) { - - //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); - if (!orig_ast.list_Q()) { - return eval_ast(orig_ast, env); - } - if (((MalList)orig_ast).size() == 0) { return orig_ast; } - - // apply list - MalVal expanded = macroexpand(orig_ast, env); - if (!expanded.list_Q()) { - return eval_ast(expanded, env); - } - MalList ast = (MalList) expanded; - if (ast.size() == 0) { return ast; } - a0 = ast.nth(0); - String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() - : "__<*fn*>__"; - switch (a0sym) { - case "def!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - env.set(((MalSymbol)a1), res); - return res; - case "let*": - a1 = ast.nth(1); - a2 = ast.nth(2); - MalSymbol key; - MalVal val; - Env let_env = new Env(env); - for(int i=0; i<((MalList)a1).size(); i+=2) { - key = (MalSymbol)((MalList)a1).nth(i); - val = ((MalList)a1).nth(i+1); - let_env.set(key, EVAL(val, let_env)); - } - orig_ast = a2; - env = let_env; - break; - case "quote": - return ast.nth(1); - case "quasiquoteexpand": - return quasiquote(ast.nth(1)); - case "quasiquote": - orig_ast = quasiquote(ast.nth(1)); - break; - case "defmacro!": - a1 = ast.nth(1); - a2 = ast.nth(2); - res = EVAL(a2, env); - res = res.copy(); - ((MalFunction)res).setMacro(); - env.set((MalSymbol)a1, res); - return res; - case "macroexpand": - a1 = ast.nth(1); - return macroexpand(a1, env); - case "try*": - try { - return EVAL(ast.nth(1), env); - } catch (Throwable t) { - if (ast.size() > 2) { - MalVal exc; - a2 = ast.nth(2); - MalVal a20 = ((MalList)a2).nth(0); - if (((MalSymbol)a20).getName().equals("catch*")) { - if (t instanceof MalException) { - exc = ((MalException)t).getValue(); - } else { - StringWriter sw = new StringWriter(); - t.printStackTrace(new PrintWriter(sw)); - String tstr = sw.toString(); - exc = new MalString(t.getMessage() + ": " + tstr); - } - return EVAL(((MalList)a2).nth(2), - new Env(env, ((MalList)a2).slice(1,2), - new MalList(exc))); - } - } - throw t; - } - case "do": - eval_ast(ast.slice(1, ast.size()-1), env); - orig_ast = ast.nth(ast.size()-1); - break; - case "if": - a1 = ast.nth(1); - MalVal cond = EVAL(a1, env); - if (cond == types.Nil || cond == types.False) { - // eval false slot form - if (ast.size() > 3) { - orig_ast = ast.nth(3); - } else { - return types.Nil; - } - } else { - // eval true slot form - orig_ast = ast.nth(2); - } - break; - case "fn*": - final MalList a1f = (MalList)ast.nth(1); - final MalVal a2f = ast.nth(2); - final Env cur_env = env; - return new MalFunction (a2f, (mal.env.Env)env, a1f) { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(a2f, new Env(cur_env, a1f, args)); - } - }; - default: - el = (MalList)eval_ast(ast, env); - MalFunction f = (MalFunction)el.nth(0); - MalVal fnast = f.getAst(); - if (fnast != null) { - orig_ast = fnast; - env = f.genEnv(el.slice(1)); - } else { - return f.apply(el.rest()); - } - } - - } - } - - // print - public static String PRINT(MalVal exp) { - return printer._pr_str(exp, true); - } - - // repl - public static MalVal RE(Env env, String str) throws MalThrowable { - return EVAL(READ(str), env); - } - - public static void main(String[] args) throws MalThrowable { - String prompt = "user> "; - - final Env repl_env = new Env(null); - - // core.java: defined using Java - for (String key : core.ns.keySet()) { - repl_env.set(new MalSymbol(key), core.ns.get(key)); - } - repl_env.set(new MalSymbol("eval"), new MalFunction() { - public MalVal apply(MalList args) throws MalThrowable { - return EVAL(args.nth(0), repl_env); - } - }); - MalList _argv = new MalList(); - for (Integer i=1; i < args.length; i++) { - _argv.conj_BANG(new MalString(args[i])); - } - repl_env.set(new MalSymbol("*ARGV*"), _argv); - - - // core.mal: defined using the language itself - RE(repl_env, "(def! *host-language* \"java\")"); - RE(repl_env, "(def! not (fn* (a) (if a false true)))"); - RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - RE(repl_env, "(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)))))))"); - - Integer fileIdx = 0; - if (args.length > 0 && args[0].equals("--raw")) { - readline.mode = readline.Mode.JAVA; - fileIdx = 1; - } - if (args.length > fileIdx) { - RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); - return; - } - - // repl loop - RE(repl_env, "(println (str \"Mal [\" *host-language* \"]\"))"); - while (true) { - String line; - try { - line = readline.readline(prompt); - if (line == null) { continue; } - } catch (readline.EOFException e) { - break; - } catch (IOException e) { - System.out.println("IOException: " + e.getMessage()); - break; - } - try { - System.out.println(PRINT(RE(repl_env, line))); - } catch (MalContinue e) { - continue; - } catch (MalException e) { - System.out.println("Error: " + printer._pr_str(e.getValue(), false)); - continue; - } catch (MalThrowable t) { - System.out.println("Error: " + t.getMessage()); - continue; - } catch (Throwable t) { - System.out.println("Uncaught " + t + ": " + t.getMessage()); - continue; - } - } - } -} +package mal; + +import java.io.IOException; + +import java.io.StringWriter; +import java.io.PrintWriter; +import java.util.List; +import java.util.Map; +import java.util.HashMap; +import java.util.Iterator; +import mal.types.*; +import mal.readline; +import mal.reader; +import mal.printer; +import mal.env.Env; +import mal.core; + +public class stepA_mal { + // read + public static MalVal READ(String str) throws MalThrowable { + return reader.read_str(str); + } + + // eval + public static Boolean starts_with(MalVal ast, String sym) { + // Liskov, forgive me + if (ast instanceof MalList && !(ast instanceof MalVector) && ((MalList)ast).size() == 2) { + MalVal a0 = ((MalList)ast).nth(0); + return a0 instanceof MalSymbol && ((MalSymbol)a0).getName().equals(sym); + } + return false; + } + + public static MalVal quasiquote(MalVal ast) { + if ((ast instanceof MalSymbol || ast instanceof MalHashMap)) + return new MalList(new MalSymbol("quote"), ast); + + if (!(ast instanceof MalList)) + return ast; + + if (starts_with(ast, "unquote")) + return ((MalList)ast).nth(1); + + MalVal res = new MalList(); + for (Integer i=((MalList)ast).size()-1; 0<=i; i--) { + MalVal elt = ((MalList)ast).nth(i); + if (starts_with(elt, "splice-unquote")) + res = new MalList(new MalSymbol("concat"), ((MalList)elt).nth(1), res); + else + res = new MalList(new MalSymbol("cons"), quasiquote(elt), res); + } + if (ast instanceof MalVector) + res = new MalList(new MalSymbol("vec"), res); + return res; + } + + public static Boolean is_macro_call(MalVal ast, Env env) + throws MalThrowable { + if (ast instanceof MalList) { + MalVal a0 = ((MalList)ast).nth(0); + if (a0 instanceof MalSymbol && + env.find(((MalSymbol)a0)) != null) { + MalVal mac = env.get(((MalSymbol)a0)); + if (mac instanceof MalFunction && + ((MalFunction)mac).isMacro()) { + return true; + } + } + } + return false; + } + + public static MalVal macroexpand(MalVal ast, Env env) + throws MalThrowable { + while (is_macro_call(ast, env)) { + MalSymbol a0 = (MalSymbol)((MalList)ast).nth(0); + MalFunction mac = (MalFunction) env.get(a0); + ast = mac.apply(((MalList)ast).rest()); + } + return ast; + } + + public static MalVal eval_ast(MalVal ast, Env env) throws MalThrowable { + if (ast instanceof MalSymbol) { + return env.get((MalSymbol)ast); + } else if (ast instanceof MalList) { + MalList old_lst = (MalList)ast; + MalList new_lst = ast.list_Q() ? new MalList() + : (MalList)new MalVector(); + for (MalVal mv : (List)old_lst.value) { + new_lst.conj_BANG(EVAL(mv, env)); + } + return new_lst; + } else if (ast instanceof MalHashMap) { + MalHashMap new_hm = new MalHashMap(); + Iterator it = ((MalHashMap)ast).value.entrySet().iterator(); + while (it.hasNext()) { + Map.Entry entry = (Map.Entry)it.next(); + new_hm.value.put(entry.getKey(), EVAL((MalVal)entry.getValue(), env)); + } + return new_hm; + } else { + return ast; + } + } + + public static MalVal EVAL(MalVal orig_ast, Env env) throws MalThrowable { + MalVal a0, a1,a2, a3, res; + MalList el; + + while (true) { + + //System.out.println("EVAL: " + printer._pr_str(orig_ast, true)); + if (!orig_ast.list_Q()) { + return eval_ast(orig_ast, env); + } + if (((MalList)orig_ast).size() == 0) { return orig_ast; } + + // apply list + MalVal expanded = macroexpand(orig_ast, env); + if (!expanded.list_Q()) { + return eval_ast(expanded, env); + } + MalList ast = (MalList) expanded; + if (ast.size() == 0) { return ast; } + a0 = ast.nth(0); + String a0sym = a0 instanceof MalSymbol ? ((MalSymbol)a0).getName() + : "__<*fn*>__"; + switch (a0sym) { + case "def!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + env.set(((MalSymbol)a1), res); + return res; + case "let*": + a1 = ast.nth(1); + a2 = ast.nth(2); + MalSymbol key; + MalVal val; + Env let_env = new Env(env); + for(int i=0; i<((MalList)a1).size(); i+=2) { + key = (MalSymbol)((MalList)a1).nth(i); + val = ((MalList)a1).nth(i+1); + let_env.set(key, EVAL(val, let_env)); + } + orig_ast = a2; + env = let_env; + break; + case "quote": + return ast.nth(1); + case "quasiquoteexpand": + return quasiquote(ast.nth(1)); + case "quasiquote": + orig_ast = quasiquote(ast.nth(1)); + break; + case "defmacro!": + a1 = ast.nth(1); + a2 = ast.nth(2); + res = EVAL(a2, env); + res = res.copy(); + ((MalFunction)res).setMacro(); + env.set((MalSymbol)a1, res); + return res; + case "macroexpand": + a1 = ast.nth(1); + return macroexpand(a1, env); + case "try*": + try { + return EVAL(ast.nth(1), env); + } catch (Throwable t) { + if (ast.size() > 2) { + MalVal exc; + a2 = ast.nth(2); + MalVal a20 = ((MalList)a2).nth(0); + if (((MalSymbol)a20).getName().equals("catch*")) { + if (t instanceof MalException) { + exc = ((MalException)t).getValue(); + } else { + StringWriter sw = new StringWriter(); + t.printStackTrace(new PrintWriter(sw)); + String tstr = sw.toString(); + exc = new MalString(t.getMessage() + ": " + tstr); + } + return EVAL(((MalList)a2).nth(2), + new Env(env, ((MalList)a2).slice(1,2), + new MalList(exc))); + } + } + throw t; + } + case "do": + eval_ast(ast.slice(1, ast.size()-1), env); + orig_ast = ast.nth(ast.size()-1); + break; + case "if": + a1 = ast.nth(1); + MalVal cond = EVAL(a1, env); + if (cond == types.Nil || cond == types.False) { + // eval false slot form + if (ast.size() > 3) { + orig_ast = ast.nth(3); + } else { + return types.Nil; + } + } else { + // eval true slot form + orig_ast = ast.nth(2); + } + break; + case "fn*": + final MalList a1f = (MalList)ast.nth(1); + final MalVal a2f = ast.nth(2); + final Env cur_env = env; + return new MalFunction (a2f, (mal.env.Env)env, a1f) { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(a2f, new Env(cur_env, a1f, args)); + } + }; + default: + el = (MalList)eval_ast(ast, env); + MalFunction f = (MalFunction)el.nth(0); + MalVal fnast = f.getAst(); + if (fnast != null) { + orig_ast = fnast; + env = f.genEnv(el.slice(1)); + } else { + return f.apply(el.rest()); + } + } + + } + } + + // print + public static String PRINT(MalVal exp) { + return printer._pr_str(exp, true); + } + + // repl + public static MalVal RE(Env env, String str) throws MalThrowable { + return EVAL(READ(str), env); + } + + public static void main(String[] args) throws MalThrowable { + String prompt = "user> "; + + final Env repl_env = new Env(null); + + // core.java: defined using Java + for (String key : core.ns.keySet()) { + repl_env.set(new MalSymbol(key), core.ns.get(key)); + } + repl_env.set(new MalSymbol("eval"), new MalFunction() { + public MalVal apply(MalList args) throws MalThrowable { + return EVAL(args.nth(0), repl_env); + } + }); + MalList _argv = new MalList(); + for (Integer i=1; i < args.length; i++) { + _argv.conj_BANG(new MalString(args[i])); + } + repl_env.set(new MalSymbol("*ARGV*"), _argv); + + + // core.mal: defined using the language itself + RE(repl_env, "(def! *host-language* \"java\")"); + RE(repl_env, "(def! not (fn* (a) (if a false true)))"); + RE(repl_env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + RE(repl_env, "(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)))))))"); + + Integer fileIdx = 0; + if (args.length > 0 && args[0].equals("--raw")) { + readline.mode = readline.Mode.JAVA; + fileIdx = 1; + } + if (args.length > fileIdx) { + RE(repl_env, "(load-file \"" + args[fileIdx] + "\")"); + return; + } + + // repl loop + RE(repl_env, "(println (str \"Mal [\" *host-language* \"]\"))"); + while (true) { + String line; + try { + line = readline.readline(prompt); + if (line == null) { continue; } + } catch (readline.EOFException e) { + break; + } catch (IOException e) { + System.out.println("IOException: " + e.getMessage()); + break; + } + try { + System.out.println(PRINT(RE(repl_env, line))); + } catch (MalContinue e) { + continue; + } catch (MalException e) { + System.out.println("Error: " + printer._pr_str(e.getValue(), false)); + continue; + } catch (MalThrowable t) { + System.out.println("Error: " + t.getMessage()); + continue; + } catch (Throwable t) { + System.out.println("Uncaught " + t + ": " + t.getMessage()); + continue; + } + } + } +} diff --git a/impls/java/src/main/java/mal/types.java b/impls/java/src/main/java/mal/types.java index aa11cf8cca..64d591eee8 100644 --- a/impls/java/src/main/java/mal/types.java +++ b/impls/java/src/main/java/mal/types.java @@ -1,381 +1,381 @@ -package mal; - -import java.util.List; -import java.util.ArrayList; -import java.util.Set; -import java.util.Map; -import java.util.HashMap; - -import mal.printer; -import mal.env.Env; - -public class types { - // - // Exceptions/Errors - // - public static class MalThrowable extends Exception { - public MalThrowable() { } - public MalThrowable(String msg) { super(msg); } - } - public static class MalError extends MalThrowable { - public MalError(String msg) { super(msg); } - } - public static class MalContinue extends MalThrowable { } - - // Thrown by throw function - public static class MalException extends MalThrowable { - MalVal value; - public MalException(MalVal value) { - this.value = value; - } - public MalException(String value) { - this.value = new MalString(value); - } - public MalVal getValue() { return value; } - } - - // - // General functions - // - - public static Boolean _equal_Q(MalVal a, MalVal b) { - Class ota = a.getClass(), otb = b.getClass(); - if (!((ota == otb) || - (a instanceof MalList && b instanceof MalList))) { - return false; - } else { - if (a instanceof MalInteger) { - return ((MalInteger)a).getValue() == - ((MalInteger)b).getValue(); - } else if (a instanceof MalSymbol) { - return ((MalSymbol)a).getName().equals( - ((MalSymbol)b).getName()); - } else if (a instanceof MalString) { - return ((MalString)a).getValue().equals( - ((MalString)b).getValue()); - } else if (a instanceof MalList) { - if (((MalList)a).size() != ((MalList)b).size()) { - return false; - } - for (Integer i=0; i<((MalList)a).size(); i++) { - if (! _equal_Q(((MalList)a).nth(i), - ((MalList)b).nth(i))) { - return false; - } - } - return true; - } else if (a instanceof MalHashMap) { - if (((MalHashMap)a).value.size() != ((MalHashMap)b).value.size()) { - return false; - } - //HashMap hm = (HashMap)a.value; - MalHashMap mhm = ((MalHashMap)a); - HashMap hm = (HashMap)mhm.value; - for (String k : hm.keySet()) { - if (! _equal_Q(((MalVal)((MalHashMap)a).value.get(k)), - ((MalVal)((MalHashMap)b).value.get(k)))) { - return false; - } - } - return true; - } else { - return a == b; - } - } - } - - // - // Mal boxed types - // - abstract public static class MalVal { - MalVal meta = Nil; - abstract public MalVal copy() throws MalThrowable; - - // Default is just to call regular toString() - public String toString(Boolean print_readably) { - return this.toString(); - } - public MalVal getMeta() { return meta; } - public void setMeta(MalVal m) { meta = m; } - public Boolean list_Q() { return false; } - } - public static class MalConstant extends MalVal { - String value; - public MalConstant(String name) { value = name; } - public MalConstant copy() throws MalThrowable { return this; } - - public String toString() { return value; } - } - public static MalConstant Nil = new MalConstant("nil"); - public static MalConstant True = new MalConstant("true"); - public static MalConstant False = new MalConstant("false"); - - public static class MalInteger extends MalVal { - Integer value; - public MalInteger(Integer v) { value = v; } - public MalInteger copy() throws MalThrowable { return this; } - - public Integer getValue() { return value; } - @Override public String toString() { - return value.toString(); - } - public MalInteger add(MalInteger other) { - return new MalInteger(value + other.getValue()); - } - public MalInteger subtract(MalInteger other) { - return new MalInteger(value - other.getValue()); - } - public MalInteger multiply(MalInteger other) { - return new MalInteger(value * other.getValue()); - } - public MalInteger divide(MalInteger other) { - return new MalInteger(value / other.getValue()); - } - public MalConstant lt(MalInteger other) { - return (value < other.getValue()) ? True : False; - } - public MalConstant lte(MalInteger other) { - return (value <= other.getValue()) ? True : False; - } - public MalConstant gt(MalInteger other) { - return (value > other.getValue()) ? True : False; - } - public MalConstant gte(MalInteger other) { - return (value >= other.getValue()) ? True : False; - } - } - - public static class MalSymbol extends MalVal { - String value; - public MalSymbol(String v) { value = v; } - public MalSymbol(MalString v) { value = v.getValue(); } - public MalSymbol copy() throws MalThrowable { return this; } - - public String getName() { return value; } - @Override public String toString() { - return value; - } - } - - public static class MalString extends MalVal { - String value; - public MalString(String v) { value = v; } - public MalString copy() throws MalThrowable { return this; } - - public String getValue() { return value; } - @Override public String toString() { - return "\"" + value + "\""; - } - public String toString(Boolean print_readably) { - if (value.length() > 0 && value.charAt(0) == '\u029e') { - return ":" + value.substring(1); - } else if (print_readably) { - return "\"" + printer.escapeString(value) + "\""; - } else { - return value; - } - } - } - - public static class MalList extends MalVal { - String start = "(", end = ")"; - List value; - public MalList(List val) { - value = val; - } - public MalList(MalVal... mvs) { - value = new ArrayList(); - conj_BANG(mvs); - } - public MalList copy() throws MalThrowable { - MalList new_ml = new MalList(); - new_ml.value.addAll(value); - new_ml.meta = meta; - return new_ml; - } - - @Override public String toString() { - return start + printer.join(value, " ", true) + end; - } - public String toString(Boolean print_readably) { - return start + printer.join(value, " ", print_readably) + end; - } - - public List getList() { return value; } - public Boolean list_Q() { return true; } - - public MalList conj_BANG(MalVal... mvs) { - for (MalVal mv : mvs) { - value.add(mv); - } - return this; - } - - public Integer size() { - return value.size(); - } - - public MalVal nth(Integer idx) { - return (MalVal)value.get(idx); - } - public MalList rest () { - if (size() > 0) { - return new MalList(value.subList(1, value.size())); - } else { - return new MalList(); - } - } - - - public MalList slice(Integer start, Integer end) { - return new MalList(value.subList(start, end)); - } - public MalList slice(Integer start) { - return slice(start, value.size()); - } - } - - public static class MalVector extends MalList { - // Same implementation except for instantiation methods - public MalVector(List val) { - value = val; - start = "["; - end = "]"; - } - public MalVector(MalVal... mvs) { - super(mvs); - start = "["; - end = "]"; - } - public MalVector copy() throws MalThrowable { - MalVector new_mv = new MalVector(); - new_mv.value.addAll(value); - new_mv.meta = meta; - return new_mv; - } - - public Boolean list_Q() { return false; } - - public MalVector slice(Integer start, Integer end) { - return new MalVector(value.subList(start, end)); - } - } - - public static class MalHashMap extends MalVal { - Map value; - public MalHashMap(Map val) { - value = val; - } - public MalHashMap(MalList lst) { - value = new HashMap(); - assoc_BANG(lst); - } - public MalHashMap(MalVal... mvs) { - value = new HashMap(); - assoc_BANG(mvs); - } - public MalHashMap copy() throws MalThrowable { - Map shallowCopy = new HashMap(); - shallowCopy.putAll(value); - MalHashMap new_hm = new MalHashMap(shallowCopy); - new_hm.meta = meta; - return new_hm; - } - - @Override public String toString() { - return "{" + printer.join(value, " ", true) + "}"; - } - public String toString(Boolean print_readably) { - return "{" + printer.join(value, " ", print_readably) + "}"; - } - - public Set _entries() { - return value.entrySet(); - } - - public MalHashMap assoc_BANG(MalVal... mvs) { - for (Integer i=0; i hm = (HashMap)a.value; + MalHashMap mhm = ((MalHashMap)a); + HashMap hm = (HashMap)mhm.value; + for (String k : hm.keySet()) { + if (! _equal_Q(((MalVal)((MalHashMap)a).value.get(k)), + ((MalVal)((MalHashMap)b).value.get(k)))) { + return false; + } + } + return true; + } else { + return a == b; + } + } + } + + // + // Mal boxed types + // + abstract public static class MalVal { + MalVal meta = Nil; + abstract public MalVal copy() throws MalThrowable; + + // Default is just to call regular toString() + public String toString(Boolean print_readably) { + return this.toString(); + } + public MalVal getMeta() { return meta; } + public void setMeta(MalVal m) { meta = m; } + public Boolean list_Q() { return false; } + } + public static class MalConstant extends MalVal { + String value; + public MalConstant(String name) { value = name; } + public MalConstant copy() throws MalThrowable { return this; } + + public String toString() { return value; } + } + public static MalConstant Nil = new MalConstant("nil"); + public static MalConstant True = new MalConstant("true"); + public static MalConstant False = new MalConstant("false"); + + public static class MalInteger extends MalVal { + Integer value; + public MalInteger(Integer v) { value = v; } + public MalInteger copy() throws MalThrowable { return this; } + + public Integer getValue() { return value; } + @Override public String toString() { + return value.toString(); + } + public MalInteger add(MalInteger other) { + return new MalInteger(value + other.getValue()); + } + public MalInteger subtract(MalInteger other) { + return new MalInteger(value - other.getValue()); + } + public MalInteger multiply(MalInteger other) { + return new MalInteger(value * other.getValue()); + } + public MalInteger divide(MalInteger other) { + return new MalInteger(value / other.getValue()); + } + public MalConstant lt(MalInteger other) { + return (value < other.getValue()) ? True : False; + } + public MalConstant lte(MalInteger other) { + return (value <= other.getValue()) ? True : False; + } + public MalConstant gt(MalInteger other) { + return (value > other.getValue()) ? True : False; + } + public MalConstant gte(MalInteger other) { + return (value >= other.getValue()) ? True : False; + } + } + + public static class MalSymbol extends MalVal { + String value; + public MalSymbol(String v) { value = v; } + public MalSymbol(MalString v) { value = v.getValue(); } + public MalSymbol copy() throws MalThrowable { return this; } + + public String getName() { return value; } + @Override public String toString() { + return value; + } + } + + public static class MalString extends MalVal { + String value; + public MalString(String v) { value = v; } + public MalString copy() throws MalThrowable { return this; } + + public String getValue() { return value; } + @Override public String toString() { + return "\"" + value + "\""; + } + public String toString(Boolean print_readably) { + if (value.length() > 0 && value.charAt(0) == '\u029e') { + return ":" + value.substring(1); + } else if (print_readably) { + return "\"" + printer.escapeString(value) + "\""; + } else { + return value; + } + } + } + + public static class MalList extends MalVal { + String start = "(", end = ")"; + List value; + public MalList(List val) { + value = val; + } + public MalList(MalVal... mvs) { + value = new ArrayList(); + conj_BANG(mvs); + } + public MalList copy() throws MalThrowable { + MalList new_ml = new MalList(); + new_ml.value.addAll(value); + new_ml.meta = meta; + return new_ml; + } + + @Override public String toString() { + return start + printer.join(value, " ", true) + end; + } + public String toString(Boolean print_readably) { + return start + printer.join(value, " ", print_readably) + end; + } + + public List getList() { return value; } + public Boolean list_Q() { return true; } + + public MalList conj_BANG(MalVal... mvs) { + for (MalVal mv : mvs) { + value.add(mv); + } + return this; + } + + public Integer size() { + return value.size(); + } + + public MalVal nth(Integer idx) { + return (MalVal)value.get(idx); + } + public MalList rest () { + if (size() > 0) { + return new MalList(value.subList(1, value.size())); + } else { + return new MalList(); + } + } + + + public MalList slice(Integer start, Integer end) { + return new MalList(value.subList(start, end)); + } + public MalList slice(Integer start) { + return slice(start, value.size()); + } + } + + public static class MalVector extends MalList { + // Same implementation except for instantiation methods + public MalVector(List val) { + value = val; + start = "["; + end = "]"; + } + public MalVector(MalVal... mvs) { + super(mvs); + start = "["; + end = "]"; + } + public MalVector copy() throws MalThrowable { + MalVector new_mv = new MalVector(); + new_mv.value.addAll(value); + new_mv.meta = meta; + return new_mv; + } + + public Boolean list_Q() { return false; } + + public MalVector slice(Integer start, Integer end) { + return new MalVector(value.subList(start, end)); + } + } + + public static class MalHashMap extends MalVal { + Map value; + public MalHashMap(Map val) { + value = val; + } + public MalHashMap(MalList lst) { + value = new HashMap(); + assoc_BANG(lst); + } + public MalHashMap(MalVal... mvs) { + value = new HashMap(); + assoc_BANG(mvs); + } + public MalHashMap copy() throws MalThrowable { + Map shallowCopy = new HashMap(); + shallowCopy.putAll(value); + MalHashMap new_hm = new MalHashMap(shallowCopy); + new_hm.meta = meta; + return new_hm; + } + + @Override public String toString() { + return "{" + printer.join(value, " ", true) + "}"; + } + public String toString(Boolean print_readably) { + return "{" + printer.join(value, " ", print_readably) + "}"; + } + + public Set _entries() { + return value.entrySet(); + } + + public MalHashMap assoc_BANG(MalVal... mvs) { + for (Integer i=0; i55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/jq/Dockerfile b/impls/jq/Dockerfile index 80d2c08d89..9ac4594cf6 100644 --- a/impls/jq/Dockerfile +++ b/impls/jq/Dockerfile @@ -1,32 +1,32 @@ -FROM ubuntu:bionic -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev libpcre3-dev - -RUN mkdir -p /mal -WORKDIR /mal - -######################################################### -# Specific implementation requirements -######################################################### - -RUN apt-get -y install python3.8 wget -RUN update-alternatives --install /usr/bin/python python /usr/bin/python3.8 10 - -# grab jq 1.6 from github releases -RUN wget https://github.com/stedolan/jq/releases/download/jq-1.6/jq-linux64 - -RUN chmod +x jq-linux64 -# a bit ugly, but it'll do? -RUN mv jq-linux64 /usr/bin/jq +FROM ubuntu:bionic +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev libpcre3-dev + +RUN mkdir -p /mal +WORKDIR /mal + +######################################################### +# Specific implementation requirements +######################################################### + +RUN apt-get -y install python3.8 wget +RUN update-alternatives --install /usr/bin/python python /usr/bin/python3.8 10 + +# grab jq 1.6 from github releases +RUN wget https://github.com/stedolan/jq/releases/download/jq-1.6/jq-linux64 + +RUN chmod +x jq-linux64 +# a bit ugly, but it'll do? +RUN mv jq-linux64 /usr/bin/jq diff --git a/impls/jq/Makefile b/impls/jq/Makefile index 27668e3c03..d5b4cf4b72 100644 --- a/impls/jq/Makefile +++ b/impls/jq/Makefile @@ -1,3 +1,3 @@ -all: - -.PHONY: clean +all: + +.PHONY: clean diff --git a/impls/jq/core.jq b/impls/jq/core.jq index 87d6385c7a..b8591f48a5 100644 --- a/impls/jq/core.jq +++ b/impls/jq/core.jq @@ -1,492 +1,492 @@ -include "utils"; -include "printer"; -include "reader"; - -def core_identify: - { - "env": { - kind: "fn", - function: "env", - inputs: 0 - }, - "prn": { - kind: "fn", - function: "prn", - inputs: -1 - }, - "pr-str": { - kind: "fn", - function: "pr-str", - inputs: -1 - }, - "str": { - kind: "fn", - function: "str", - inputs: -1 - }, - "println": { - kind: "fn", - function: "println", - inputs: -1 - }, - "list": { - kind: "fn", - function: "list", - inputs: -1 - }, - "list?": { - kind: "fn", - function: "list?", - inputs: 1 - }, - "empty?": { - kind: "fn", - function: "empty?", - inputs: 1 - }, - "count": { - kind: "fn", - function: "count", - inputs: 1 - }, - "=": { - kind: "fn", - function: "=", - inputs: 2 - }, - "<": { - kind: "fn", - function: "<", - inputs: 2 - }, - "<=": { - kind: "fn", - function: "<=", - inputs: 2 - }, - ">": { - kind: "fn", - function: ">", - inputs: 2 - }, - ">=": { - kind: "fn", - function: ">=", - inputs: 2 - }, - "read-string": { - kind: "fn", - function: "read-string", - inputs: 1 - }, - "slurp": { - kind: "fn", - function: "slurp", - inputs: 1 - }, - "atom": { - kind: "fn", - function: "atom", - inputs: 1 - }, - "atom?": { - kind: "fn", - function: "atom?", - inputs: 1 - }, - "deref": { - kind: "fn", - function: "deref", - inputs: 1 - }, - "reset!": { # defined in interp - kind: "fn", - function: "reset!", - inputs: 2 - }, - "swap!": { # defined in interp - kind: "fn", - function: "swap!", - inputs: -3 - }, - "cons": { - kind: "fn", - function: "cons", - inputs: 2 - }, - "concat": { - kind: "fn", - function: "concat", - inputs: -1 - }, - "vec": { - kind: "fn", - function: "vec", - inputs: 1 - }, - "nth": { - kind: "fn", - function: "nth", - inputs: 2 - }, - "first": { - kind: "fn", - function: "first", - inputs: 1 - }, - "rest": { - kind: "fn", - function: "rest", - inputs: 1 - }, - "throw": { - kind: "fn", - function: "throw", - inputs: 1 - }, - "apply": { # defined in interp - kind: "fn", - function: "apply", - inputs: -3 - }, - "map": { # defined in interp - kind: "fn", - function: "map", - inputs: 2 - }, - "nil?": { - kind: "fn", - function: "nil?", - inputs: 1 - }, - "true?": { - kind: "fn", - function: "true?", - inputs: 1 - }, - "false?": { - kind: "fn", - function: "false?", - inputs: 1 - }, - "symbol": { - kind: "fn", - function: "symbol", - inputs: 1 - }, - "symbol?": { - kind: "fn", - function: "symbol?", - inputs: 1 - }, - "keyword": { - kind: "fn", - function: "keyword", - inputs: 1 - }, - "keyword?": { - kind: "fn", - function: "keyword?", - inputs: 1 - }, - "vector": { - kind: "fn", - function: "vector", - inputs: -1 - }, - "vector?": { - kind: "fn", - function: "vector?", - inputs: 1 - }, - "sequential?": { - kind: "fn", - function: "sequential?", - inputs: 1 - }, - "hash-map": { - kind: "fn", - function: "hash-map", - inputs: -1 - }, - "map?": { - kind: "fn", - function: "map?", - inputs: 1 - }, - "assoc": { - kind: "fn", - function: "assoc", - inputs: -2 - }, - "dissoc": { - kind: "fn", - function: "dissoc", - inputs: -2 - }, - "get": { - kind: "fn", - function: "get", - inputs: 2 - }, - "contains?": { - kind: "fn", - function: "contains?", - inputs: 2 - }, - "keys": { - kind: "fn", - function: "keys", - inputs: 1 - }, - "vals": { - kind: "fn", - function: "vals", - inputs: 1 - }, - "string?": { - kind: "fn", - function: "string?", - inputs: 1 - }, - "fn?": { - kind: "fn", - function: "fn?", - inputs: 1 - }, - "number?": { - kind: "fn", - function: "number?", - inputs: 1 - }, - "macro?": { - kind: "fn", - function: "macro?", - inputs: 1 - }, - "readline": { - kind: "fn", - function: "readline", - inputs: 1 - }, - "time-ms": { - kind: "fn", - function: "time-ms", - inputs: 0 - }, - "meta": { - kind: "fn", - function: "meta", - inputs: 1 - }, - "with-meta": { - kind: "fn", - function: "with-meta", - inputs: 2 - }, - "seq": { - kind: "fn", - function: "seq", - inputs: 1 - }, - "conj": { - kind: "fn", - function: "conj", - inputs: -3 - } - }; - -def vec2list(obj): - if obj.kind == "list" then - obj.value | map(vec2list(.)) | wrap("list") - else - if obj.kind == "vector" then - obj.value | map(vec2list(.)) | wrap("list") - else - if obj.kind == "hashmap" then - obj.value | map_values(.value |= vec2list(.)) | wrap("hashmap") - else - obj - end - end - end; - -def make_sequence: - . as $dot - | if .value|length == 0 then null | wrap("nil") else - ( - select(.kind == "string") | .value | split("") | map(wrap("string")) - ) // ( - select(.kind == "list" or .kind == "vector") | .value - ) // jqmal_error("cannot make sequence from \(.kind)") | wrap("list") - end; - -def core_interp(arguments; env): - ( - select(.function == "number_add") | - arguments | map(.value) | .[0] + .[1] | wrap("number") - ) // ( - select(.function == "number_sub") | - arguments | map(.value) | .[0] - .[1] | wrap("number") - ) // ( - select(.function == "number_mul") | - arguments | map(.value) | .[0] * .[1] | wrap("number") - ) // ( - select(.function == "number_div") | - arguments | map(.value) | .[0] / .[1] | wrap("number") - ) // ( - select(.function == "env") | - env | tojson | wrap("string") - ) // ( - select(.function == "prn") | - arguments | map(pr_str(env; {readable: true})) | join(" ") | _display | null | wrap("nil") - ) // ( - select(.function == "pr-str") | - arguments | map(pr_str(env; {readable: true})) | join(" ") | wrap("string") - ) // ( - select(.function == "str") | - arguments | map(pr_str(env; {readable: false})) | join("") | wrap("string") - ) // ( - select(.function == "println") | - arguments | map(pr_str(env; {readable: false})) | join(" ") | _display | null | wrap("nil") - ) // ( - select(.function == "list") | - arguments | wrap("list") - ) // ( - select(.function == "list?") | null | wrap(arguments | first.kind == "list" | tostring) - ) // ( - select(.function == "empty?") | null | wrap(arguments|first.value | length == 0 | tostring) - ) // ( - select(.function == "count") | arguments|first.value | length | wrap("number") - ) // ( - select(.function == "=") | null | wrap(vec2list(arguments[0]) == vec2list(arguments[1]) | tostring) - ) // ( - select(.function == "<") | null | wrap(arguments[0].value < arguments[1].value | tostring) - ) // ( - select(.function == "<=") | null | wrap(arguments[0].value <= arguments[1].value | tostring) - ) // ( - select(.function == ">") | null | wrap(arguments[0].value > arguments[1].value | tostring) - ) // ( - select(.function == ">=") | null | wrap(arguments[0].value >= arguments[1].value | tostring) - ) // ( - select(.function == "slurp") | arguments | map(.value) | issue_extern("read") | wrap("string") - ) // ( - select(.function == "read-string") | arguments | first.value | read_str | read_form.value - ) // ( - select(.function == "atom?") | null | wrap(arguments | first.kind == "atom" | tostring) - ) // ( - select(.function == "cons") | ([arguments[0]] + arguments[1].value) | wrap("list") - ) // ( - select(.function == "concat") | arguments | map(.value) | (add//[]) | wrap("list") - ) // ( - select(.function == "vec") | {kind:"vector", value:arguments[0].value} - ) // ( - select(.function == "nth") - | _debug(arguments) - | arguments[0].value as $lst - | arguments[1].value as $idx - | if ($lst|length < $idx) or ($idx < 0) then - jqmal_error("index out of range") - else - $lst[$idx] - end - ) // ( - select(.function == "first") | arguments[0].value | first // {kind:"nil"} - ) // ( - select(.function == "rest") | arguments[0]?.value?[1:]? // [] | wrap("list") - ) // ( - select(.function == "throw") | jqmal_error(arguments[0] | tojson) - ) // ( - select(.function == "nil?") | null | wrap((arguments[0].kind == "nil") | tostring) - ) // ( - select(.function == "true?") | null | wrap((arguments[0].kind == "true") | tostring) - ) // ( - select(.function == "false?") | null | wrap((arguments[0].kind == "false") | tostring) - ) // ( - select(.function == "symbol?") | null | wrap((arguments[0].kind == "symbol") | tostring) - ) // ( - select(.function == "symbol") | arguments[0].value | wrap("symbol") - ) // ( - select(.function == "keyword") | arguments[0].value | wrap("keyword") - ) // ( - select(.function == "keyword?") | null | wrap((arguments[0].kind == "keyword") | tostring) - ) // ( - select(.function == "vector") | arguments | wrap("vector") - ) // ( - select(.function == "vector?") | null | wrap((arguments[0].kind == "vector") | tostring) - ) // ( - select(.function == "sequential?") | null | wrap((arguments[0].kind == "vector" or arguments[0].kind == "list") | tostring) - ) // ( - select(.function == "hash-map") | - if (arguments|length) % 2 == 1 then - jqmal_error("Odd number of arguments to hash-map") - else - [ arguments | - nwise(2) | - try { - key: (.[0] | extract_string), - value: { - kkind: .[0].kind, - value: .[1] - } - } - ] | from_entries | wrap("hashmap") - end - ) // ( - select(.function == "map?") | null | wrap((arguments[0].kind == "hashmap") | tostring) - ) // ( - select(.function == "assoc") | - if (arguments|length) % 2 == 0 then - jqmal_error("Odd number of key-values to assoc") - else - arguments[0].value + ([ arguments[1:] | - nwise(2) | - try { - key: (.[0] | extract_string), - value: { - kkind: .[0].kind, - value: .[1] - } - } - ] | from_entries) | wrap("hashmap") - end - ) // ( - select(.function == "dissoc") | - arguments[1:] | map(.value) as $keynames | - arguments[0].value | with_entries(select(.key as $k | $keynames | contains([$k]) | not)) | wrap("hashmap") - ) // ( - select(.function == "get") | arguments[0].value[arguments[1].value].value // {kind:"nil"} - ) // ( - select(.function == "contains?") | null | wrap((arguments[0].value | has(arguments[1].value)) | tostring) - ) // ( - select(.function == "keys") | arguments[0].value | with_entries(.value as $v | .key as $k | {key: $k, value: {value: $k, kind: $v.kkind}}) | to_entries | map(.value) | wrap("list") - ) // ( - select(.function == "vals") | arguments[0].value | map(.value) | to_entries | map(.value) | wrap("list") - ) // ( - select(.function == "string?") | null | wrap((arguments[0].kind == "string") | tostring) - ) // ( - select(.function == "fn?") | null | wrap((arguments[0].kind == "fn" or (arguments[0].kind == "function" and (arguments[0].is_macro|not))) | tostring) - ) // ( - select(.function == "number?") | null | wrap((arguments[0].kind == "number") | tostring) - ) // ( - select(.function == "macro?") | null | wrap((arguments[0].is_macro == true) | tostring) - ) // ( - select(.function == "readline") | arguments[0].value | __readline | wrap("string") - ) // ( - select(.function == "time-ms") | now * 1000 | wrap("number") - ) // ( - select(.function == "meta") | arguments[0].meta // {kind:"nil"} - ) // ( - select(.function == "with-meta") | arguments[0] | .meta |= arguments[1] - ) // ( - select(.function == "seq") | arguments[0] | make_sequence - ) // ( - select(.function == "conj") - | arguments[0] as $orig - | arguments[1:] as $stuff - | if $orig.kind == "list" then - [ $stuff|reverse[], $orig.value[] ] | wrap("list") - else - [ $orig.value[], $stuff[] ] | wrap("vector") - end - ) // jqmal_error("Unknown native function \(.function)"); +include "utils"; +include "printer"; +include "reader"; + +def core_identify: + { + "env": { + kind: "fn", + function: "env", + inputs: 0 + }, + "prn": { + kind: "fn", + function: "prn", + inputs: -1 + }, + "pr-str": { + kind: "fn", + function: "pr-str", + inputs: -1 + }, + "str": { + kind: "fn", + function: "str", + inputs: -1 + }, + "println": { + kind: "fn", + function: "println", + inputs: -1 + }, + "list": { + kind: "fn", + function: "list", + inputs: -1 + }, + "list?": { + kind: "fn", + function: "list?", + inputs: 1 + }, + "empty?": { + kind: "fn", + function: "empty?", + inputs: 1 + }, + "count": { + kind: "fn", + function: "count", + inputs: 1 + }, + "=": { + kind: "fn", + function: "=", + inputs: 2 + }, + "<": { + kind: "fn", + function: "<", + inputs: 2 + }, + "<=": { + kind: "fn", + function: "<=", + inputs: 2 + }, + ">": { + kind: "fn", + function: ">", + inputs: 2 + }, + ">=": { + kind: "fn", + function: ">=", + inputs: 2 + }, + "read-string": { + kind: "fn", + function: "read-string", + inputs: 1 + }, + "slurp": { + kind: "fn", + function: "slurp", + inputs: 1 + }, + "atom": { + kind: "fn", + function: "atom", + inputs: 1 + }, + "atom?": { + kind: "fn", + function: "atom?", + inputs: 1 + }, + "deref": { + kind: "fn", + function: "deref", + inputs: 1 + }, + "reset!": { # defined in interp + kind: "fn", + function: "reset!", + inputs: 2 + }, + "swap!": { # defined in interp + kind: "fn", + function: "swap!", + inputs: -3 + }, + "cons": { + kind: "fn", + function: "cons", + inputs: 2 + }, + "concat": { + kind: "fn", + function: "concat", + inputs: -1 + }, + "vec": { + kind: "fn", + function: "vec", + inputs: 1 + }, + "nth": { + kind: "fn", + function: "nth", + inputs: 2 + }, + "first": { + kind: "fn", + function: "first", + inputs: 1 + }, + "rest": { + kind: "fn", + function: "rest", + inputs: 1 + }, + "throw": { + kind: "fn", + function: "throw", + inputs: 1 + }, + "apply": { # defined in interp + kind: "fn", + function: "apply", + inputs: -3 + }, + "map": { # defined in interp + kind: "fn", + function: "map", + inputs: 2 + }, + "nil?": { + kind: "fn", + function: "nil?", + inputs: 1 + }, + "true?": { + kind: "fn", + function: "true?", + inputs: 1 + }, + "false?": { + kind: "fn", + function: "false?", + inputs: 1 + }, + "symbol": { + kind: "fn", + function: "symbol", + inputs: 1 + }, + "symbol?": { + kind: "fn", + function: "symbol?", + inputs: 1 + }, + "keyword": { + kind: "fn", + function: "keyword", + inputs: 1 + }, + "keyword?": { + kind: "fn", + function: "keyword?", + inputs: 1 + }, + "vector": { + kind: "fn", + function: "vector", + inputs: -1 + }, + "vector?": { + kind: "fn", + function: "vector?", + inputs: 1 + }, + "sequential?": { + kind: "fn", + function: "sequential?", + inputs: 1 + }, + "hash-map": { + kind: "fn", + function: "hash-map", + inputs: -1 + }, + "map?": { + kind: "fn", + function: "map?", + inputs: 1 + }, + "assoc": { + kind: "fn", + function: "assoc", + inputs: -2 + }, + "dissoc": { + kind: "fn", + function: "dissoc", + inputs: -2 + }, + "get": { + kind: "fn", + function: "get", + inputs: 2 + }, + "contains?": { + kind: "fn", + function: "contains?", + inputs: 2 + }, + "keys": { + kind: "fn", + function: "keys", + inputs: 1 + }, + "vals": { + kind: "fn", + function: "vals", + inputs: 1 + }, + "string?": { + kind: "fn", + function: "string?", + inputs: 1 + }, + "fn?": { + kind: "fn", + function: "fn?", + inputs: 1 + }, + "number?": { + kind: "fn", + function: "number?", + inputs: 1 + }, + "macro?": { + kind: "fn", + function: "macro?", + inputs: 1 + }, + "readline": { + kind: "fn", + function: "readline", + inputs: 1 + }, + "time-ms": { + kind: "fn", + function: "time-ms", + inputs: 0 + }, + "meta": { + kind: "fn", + function: "meta", + inputs: 1 + }, + "with-meta": { + kind: "fn", + function: "with-meta", + inputs: 2 + }, + "seq": { + kind: "fn", + function: "seq", + inputs: 1 + }, + "conj": { + kind: "fn", + function: "conj", + inputs: -3 + } + }; + +def vec2list(obj): + if obj.kind == "list" then + obj.value | map(vec2list(.)) | wrap("list") + else + if obj.kind == "vector" then + obj.value | map(vec2list(.)) | wrap("list") + else + if obj.kind == "hashmap" then + obj.value | map_values(.value |= vec2list(.)) | wrap("hashmap") + else + obj + end + end + end; + +def make_sequence: + . as $dot + | if .value|length == 0 then null | wrap("nil") else + ( + select(.kind == "string") | .value | split("") | map(wrap("string")) + ) // ( + select(.kind == "list" or .kind == "vector") | .value + ) // jqmal_error("cannot make sequence from \(.kind)") | wrap("list") + end; + +def core_interp(arguments; env): + ( + select(.function == "number_add") | + arguments | map(.value) | .[0] + .[1] | wrap("number") + ) // ( + select(.function == "number_sub") | + arguments | map(.value) | .[0] - .[1] | wrap("number") + ) // ( + select(.function == "number_mul") | + arguments | map(.value) | .[0] * .[1] | wrap("number") + ) // ( + select(.function == "number_div") | + arguments | map(.value) | .[0] / .[1] | wrap("number") + ) // ( + select(.function == "env") | + env | tojson | wrap("string") + ) // ( + select(.function == "prn") | + arguments | map(pr_str(env; {readable: true})) | join(" ") | _display | null | wrap("nil") + ) // ( + select(.function == "pr-str") | + arguments | map(pr_str(env; {readable: true})) | join(" ") | wrap("string") + ) // ( + select(.function == "str") | + arguments | map(pr_str(env; {readable: false})) | join("") | wrap("string") + ) // ( + select(.function == "println") | + arguments | map(pr_str(env; {readable: false})) | join(" ") | _display | null | wrap("nil") + ) // ( + select(.function == "list") | + arguments | wrap("list") + ) // ( + select(.function == "list?") | null | wrap(arguments | first.kind == "list" | tostring) + ) // ( + select(.function == "empty?") | null | wrap(arguments|first.value | length == 0 | tostring) + ) // ( + select(.function == "count") | arguments|first.value | length | wrap("number") + ) // ( + select(.function == "=") | null | wrap(vec2list(arguments[0]) == vec2list(arguments[1]) | tostring) + ) // ( + select(.function == "<") | null | wrap(arguments[0].value < arguments[1].value | tostring) + ) // ( + select(.function == "<=") | null | wrap(arguments[0].value <= arguments[1].value | tostring) + ) // ( + select(.function == ">") | null | wrap(arguments[0].value > arguments[1].value | tostring) + ) // ( + select(.function == ">=") | null | wrap(arguments[0].value >= arguments[1].value | tostring) + ) // ( + select(.function == "slurp") | arguments | map(.value) | issue_extern("read") | wrap("string") + ) // ( + select(.function == "read-string") | arguments | first.value | read_str | read_form.value + ) // ( + select(.function == "atom?") | null | wrap(arguments | first.kind == "atom" | tostring) + ) // ( + select(.function == "cons") | ([arguments[0]] + arguments[1].value) | wrap("list") + ) // ( + select(.function == "concat") | arguments | map(.value) | (add//[]) | wrap("list") + ) // ( + select(.function == "vec") | {kind:"vector", value:arguments[0].value} + ) // ( + select(.function == "nth") + | _debug(arguments) + | arguments[0].value as $lst + | arguments[1].value as $idx + | if ($lst|length < $idx) or ($idx < 0) then + jqmal_error("index out of range") + else + $lst[$idx] + end + ) // ( + select(.function == "first") | arguments[0].value | first // {kind:"nil"} + ) // ( + select(.function == "rest") | arguments[0]?.value?[1:]? // [] | wrap("list") + ) // ( + select(.function == "throw") | jqmal_error(arguments[0] | tojson) + ) // ( + select(.function == "nil?") | null | wrap((arguments[0].kind == "nil") | tostring) + ) // ( + select(.function == "true?") | null | wrap((arguments[0].kind == "true") | tostring) + ) // ( + select(.function == "false?") | null | wrap((arguments[0].kind == "false") | tostring) + ) // ( + select(.function == "symbol?") | null | wrap((arguments[0].kind == "symbol") | tostring) + ) // ( + select(.function == "symbol") | arguments[0].value | wrap("symbol") + ) // ( + select(.function == "keyword") | arguments[0].value | wrap("keyword") + ) // ( + select(.function == "keyword?") | null | wrap((arguments[0].kind == "keyword") | tostring) + ) // ( + select(.function == "vector") | arguments | wrap("vector") + ) // ( + select(.function == "vector?") | null | wrap((arguments[0].kind == "vector") | tostring) + ) // ( + select(.function == "sequential?") | null | wrap((arguments[0].kind == "vector" or arguments[0].kind == "list") | tostring) + ) // ( + select(.function == "hash-map") | + if (arguments|length) % 2 == 1 then + jqmal_error("Odd number of arguments to hash-map") + else + [ arguments | + nwise(2) | + try { + key: (.[0] | extract_string), + value: { + kkind: .[0].kind, + value: .[1] + } + } + ] | from_entries | wrap("hashmap") + end + ) // ( + select(.function == "map?") | null | wrap((arguments[0].kind == "hashmap") | tostring) + ) // ( + select(.function == "assoc") | + if (arguments|length) % 2 == 0 then + jqmal_error("Odd number of key-values to assoc") + else + arguments[0].value + ([ arguments[1:] | + nwise(2) | + try { + key: (.[0] | extract_string), + value: { + kkind: .[0].kind, + value: .[1] + } + } + ] | from_entries) | wrap("hashmap") + end + ) // ( + select(.function == "dissoc") | + arguments[1:] | map(.value) as $keynames | + arguments[0].value | with_entries(select(.key as $k | $keynames | contains([$k]) | not)) | wrap("hashmap") + ) // ( + select(.function == "get") | arguments[0].value[arguments[1].value].value // {kind:"nil"} + ) // ( + select(.function == "contains?") | null | wrap((arguments[0].value | has(arguments[1].value)) | tostring) + ) // ( + select(.function == "keys") | arguments[0].value | with_entries(.value as $v | .key as $k | {key: $k, value: {value: $k, kind: $v.kkind}}) | to_entries | map(.value) | wrap("list") + ) // ( + select(.function == "vals") | arguments[0].value | map(.value) | to_entries | map(.value) | wrap("list") + ) // ( + select(.function == "string?") | null | wrap((arguments[0].kind == "string") | tostring) + ) // ( + select(.function == "fn?") | null | wrap((arguments[0].kind == "fn" or (arguments[0].kind == "function" and (arguments[0].is_macro|not))) | tostring) + ) // ( + select(.function == "number?") | null | wrap((arguments[0].kind == "number") | tostring) + ) // ( + select(.function == "macro?") | null | wrap((arguments[0].is_macro == true) | tostring) + ) // ( + select(.function == "readline") | arguments[0].value | __readline | wrap("string") + ) // ( + select(.function == "time-ms") | now * 1000 | wrap("number") + ) // ( + select(.function == "meta") | arguments[0].meta // {kind:"nil"} + ) // ( + select(.function == "with-meta") | arguments[0] | .meta |= arguments[1] + ) // ( + select(.function == "seq") | arguments[0] | make_sequence + ) // ( + select(.function == "conj") + | arguments[0] as $orig + | arguments[1:] as $stuff + | if $orig.kind == "list" then + [ $stuff|reverse[], $orig.value[] ] | wrap("list") + else + [ $orig.value[], $stuff[] ] | wrap("vector") + end + ) // jqmal_error("Unknown native function \(.function)"); diff --git a/impls/jq/env.jq b/impls/jq/env.jq index 7be2191b68..cf48341065 100644 --- a/impls/jq/env.jq +++ b/impls/jq/env.jq @@ -1,281 +1,281 @@ -include "utils"; - -def childEnv(binds; exprs): - { - parent: ., - fallback: null, - environment: [binds, exprs] | transpose | ( - . as $dot | reduce .[] as $item ( - { value: [], seen: false, name: null, idx: 0 }; - if $item[1] != null then - if .seen then - { - value: (.value[1:-1] + (.value|last[1].value += [$item[1]])), - seen: true, - name: .name - } - else - if $item[0] == "&" then - $dot[.idx+1][0] as $name | { - value: (.value + [[$name, {kind:"list", value: [$item[1]]}]]), - seen: true, - name: $name - } - else - { - value: (.value + [$item]), - seen: false, - name: null - } - end - end | (.idx |= .idx + 1) - else - if $item[0] == "&" then - $dot[.idx+1][0] as $name | { - value: (.value + [[$name, {kind:"list", value: []}]]), - seen: true, - name: $name - } - else . end - end - ) - ) | .value | map({(.[0]): .[1]}) | add - }; - -def pureChildEnv: - { - parent: ., - environment: {}, - fallback: null - }; - -def rootEnv: - { - parent: null, - fallback: null, - environment: {} - }; - -def inform_function(name): - (.names += [name]) | (.names |= unique); - -def inform_function_multi(names): - . as $dot | reduce names[] as $name( - $dot; - inform_function($name) - ); - -def env_multiset(keys; value): - (if value.kind == "function" then # multiset not allowed on atoms - value | inform_function_multi(keys) - else - value - end) as $value | { - parent: .parent, - environment: ( - .environment + (reduce keys[] as $key(.environment; .[$key] |= value)) - ), - fallback: .fallback - }; - -def env_multiset(env; keys; value): - env | env_multiset(keys; value); - -def env_set($key; $value): - (if $value.kind == "function" or $value.kind == "atom" then - # inform the function/atom of its names - ($value | - if $value.kind == "atom" then - # check if the one we have is newer - env_req(env; key) as $ours | - if $ours.last_modified > $value.last_modified then - $ours - else - # update modification timestamp - $value | .last_modified |= now - end - else - . - end) | inform_function($key) - else - $value - end) as $value | { - parent: .parent, - environment: (.environment + (.environment | .[$key] |= $value)), # merge together, as .environment[key] |= value does not work - fallback: .fallback - }; - -def env_dump_keys: - def _dump1: - .environment // {} | keys; - if . == null then [] else - if .parent == null then - ( - _dump1 + - (.fallback | env_dump_keys) - ) - else - ( - _dump1 + - (.parent | env_dump_keys) + - (.fallback | env_dump_keys) - ) - end | unique - end; - -def env_find(env): - if env.environment[.] == null then - if env.parent then - env_find(env.parent) // if env.fallback then env_find(env.fallback) else null end - else - null - end - else - env - end; - -def env_get(env): - . as $key | $key | env_find(env).environment[$key] as $value | - if $value == null then - jqmal_error("'\($key)' not found") - else - if $value.kind == "atom" then - $value.identity as $id | - $key | env_find(env.parent).environment[$key] as $possibly_newer | - if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then - $possibly_newer - else - $value - end - else - $value - end - end; - -def env_get(env; key): - key | env_get(env); - -def env_req(env; key): - key as $key | key | env_find(env).environment[$key] as $value | - if $value == null then - null - else - if $value.kind == "atom" then - $value.identity as $id | - $key | env_find(env.parent).environment[$key] as $possibly_newer | - if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then - $possibly_newer - else - $value - end - else - $value - end - end; - -def env_set(env; $key; $value): - (if $value.kind == "function" then - # inform the function/atom of its names - $value | (.names += [$key]) | (.names |= unique) - else - $value - end) as $value | { - parent: env.parent, - environment: ((env.environment // jqmal_error("Environment empty in \(env | keys)")) + (env.environment | .[$key] |= $value)), # merge together, as env.environment[key] |= value does not work - fallback: env.fallback - }; - -def env_setfallback(env; fallback): - { - parent: env.parent, - fallback: fallback, - environment: env.environment - }; - -def addEnv(env): - { - expr: ., - env: env - }; - -def addToEnv(env; name; expr): - { - expr: expr, - env: env_set(env; name; expr) - }; - - -def wrapEnv(atoms): - { - replEnv: ., - currentEnv: ., - atoms: atoms, - isReplEnv: true - }; - -def wrapEnv(replEnv; atoms): - { - replEnv: replEnv, - currentEnv: ., - atoms: atoms, # id -> value - isReplEnv: (replEnv == .) # should we allow separate copies? - }; - -def unwrapReplEnv: - .replEnv; - -def unwrapCurrentEnv: - .currentEnv; - -def env_set6(env; key; value): - if env.isReplEnv then - env_set(env.currentEnv; key; value) | wrapEnv(env.atoms) - else - env_set(env.currentEnv; key; value) | wrapEnv(env.replEnv; env.atoms) - end; - -def env_set_(env; key; value): - if env.currentEnv != null then - env_set6(env; key; value) - else - env_set(env; key; value) - end; - -def addToEnv(envexp; name): - envexp.expr as $value - | envexp.env as $rawEnv - | (if $rawEnv.isReplEnv then - env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.atoms) - else - env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.replEnv; $rawEnv.atoms) - end) as $newEnv - | { - expr: $value, - env: $newEnv - }; - -def _env_remove_references(refs): - if . != null then - if .environment == null then - _debug("This one broke the rules, officer: \(.)") - else - { - environment: (.environment | to_entries | map(select(.key as $key | refs | contains([$key]) | not)) | from_entries), - parent: (.parent | _env_remove_references(refs)), - fallback: (.fallback | _env_remove_references(refs)) - } - end - else . end; - -def env_remove_references(refs): - . as $env - | if (refs|length == 0) then - # optimisation: most functions are purely lexical - $env - else - if has("replEnv") then - .currentEnv |= _env_remove_references(refs) - else - _env_remove_references(refs) - end +include "utils"; + +def childEnv(binds; exprs): + { + parent: ., + fallback: null, + environment: [binds, exprs] | transpose | ( + . as $dot | reduce .[] as $item ( + { value: [], seen: false, name: null, idx: 0 }; + if $item[1] != null then + if .seen then + { + value: (.value[1:-1] + (.value|last[1].value += [$item[1]])), + seen: true, + name: .name + } + else + if $item[0] == "&" then + $dot[.idx+1][0] as $name | { + value: (.value + [[$name, {kind:"list", value: [$item[1]]}]]), + seen: true, + name: $name + } + else + { + value: (.value + [$item]), + seen: false, + name: null + } + end + end | (.idx |= .idx + 1) + else + if $item[0] == "&" then + $dot[.idx+1][0] as $name | { + value: (.value + [[$name, {kind:"list", value: []}]]), + seen: true, + name: $name + } + else . end + end + ) + ) | .value | map({(.[0]): .[1]}) | add + }; + +def pureChildEnv: + { + parent: ., + environment: {}, + fallback: null + }; + +def rootEnv: + { + parent: null, + fallback: null, + environment: {} + }; + +def inform_function(name): + (.names += [name]) | (.names |= unique); + +def inform_function_multi(names): + . as $dot | reduce names[] as $name( + $dot; + inform_function($name) + ); + +def env_multiset(keys; value): + (if value.kind == "function" then # multiset not allowed on atoms + value | inform_function_multi(keys) + else + value + end) as $value | { + parent: .parent, + environment: ( + .environment + (reduce keys[] as $key(.environment; .[$key] |= value)) + ), + fallback: .fallback + }; + +def env_multiset(env; keys; value): + env | env_multiset(keys; value); + +def env_set($key; $value): + (if $value.kind == "function" or $value.kind == "atom" then + # inform the function/atom of its names + ($value | + if $value.kind == "atom" then + # check if the one we have is newer + env_req(env; key) as $ours | + if $ours.last_modified > $value.last_modified then + $ours + else + # update modification timestamp + $value | .last_modified |= now + end + else + . + end) | inform_function($key) + else + $value + end) as $value | { + parent: .parent, + environment: (.environment + (.environment | .[$key] |= $value)), # merge together, as .environment[key] |= value does not work + fallback: .fallback + }; + +def env_dump_keys: + def _dump1: + .environment // {} | keys; + if . == null then [] else + if .parent == null then + ( + _dump1 + + (.fallback | env_dump_keys) + ) + else + ( + _dump1 + + (.parent | env_dump_keys) + + (.fallback | env_dump_keys) + ) + end | unique + end; + +def env_find(env): + if env.environment[.] == null then + if env.parent then + env_find(env.parent) // if env.fallback then env_find(env.fallback) else null end + else + null + end + else + env + end; + +def env_get(env): + . as $key | $key | env_find(env).environment[$key] as $value | + if $value == null then + jqmal_error("'\($key)' not found") + else + if $value.kind == "atom" then + $value.identity as $id | + $key | env_find(env.parent).environment[$key] as $possibly_newer | + if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then + $possibly_newer + else + $value + end + else + $value + end + end; + +def env_get(env; key): + key | env_get(env); + +def env_req(env; key): + key as $key | key | env_find(env).environment[$key] as $value | + if $value == null then + null + else + if $value.kind == "atom" then + $value.identity as $id | + $key | env_find(env.parent).environment[$key] as $possibly_newer | + if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then + $possibly_newer + else + $value + end + else + $value + end + end; + +def env_set(env; $key; $value): + (if $value.kind == "function" then + # inform the function/atom of its names + $value | (.names += [$key]) | (.names |= unique) + else + $value + end) as $value | { + parent: env.parent, + environment: ((env.environment // jqmal_error("Environment empty in \(env | keys)")) + (env.environment | .[$key] |= $value)), # merge together, as env.environment[key] |= value does not work + fallback: env.fallback + }; + +def env_setfallback(env; fallback): + { + parent: env.parent, + fallback: fallback, + environment: env.environment + }; + +def addEnv(env): + { + expr: ., + env: env + }; + +def addToEnv(env; name; expr): + { + expr: expr, + env: env_set(env; name; expr) + }; + + +def wrapEnv(atoms): + { + replEnv: ., + currentEnv: ., + atoms: atoms, + isReplEnv: true + }; + +def wrapEnv(replEnv; atoms): + { + replEnv: replEnv, + currentEnv: ., + atoms: atoms, # id -> value + isReplEnv: (replEnv == .) # should we allow separate copies? + }; + +def unwrapReplEnv: + .replEnv; + +def unwrapCurrentEnv: + .currentEnv; + +def env_set6(env; key; value): + if env.isReplEnv then + env_set(env.currentEnv; key; value) | wrapEnv(env.atoms) + else + env_set(env.currentEnv; key; value) | wrapEnv(env.replEnv; env.atoms) + end; + +def env_set_(env; key; value): + if env.currentEnv != null then + env_set6(env; key; value) + else + env_set(env; key; value) + end; + +def addToEnv(envexp; name): + envexp.expr as $value + | envexp.env as $rawEnv + | (if $rawEnv.isReplEnv then + env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.atoms) + else + env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.replEnv; $rawEnv.atoms) + end) as $newEnv + | { + expr: $value, + env: $newEnv + }; + +def _env_remove_references(refs): + if . != null then + if .environment == null then + _debug("This one broke the rules, officer: \(.)") + else + { + environment: (.environment | to_entries | map(select(.key as $key | refs | contains([$key]) | not)) | from_entries), + parent: (.parent | _env_remove_references(refs)), + fallback: (.fallback | _env_remove_references(refs)) + } + end + else . end; + +def env_remove_references(refs): + . as $env + | if (refs|length == 0) then + # optimisation: most functions are purely lexical + $env + else + if has("replEnv") then + .currentEnv |= _env_remove_references(refs) + else + _env_remove_references(refs) + end end; \ No newline at end of file diff --git a/impls/jq/interp.jq b/impls/jq/interp.jq index a60693f46c..8d12883ffe 100644 --- a/impls/jq/interp.jq +++ b/impls/jq/interp.jq @@ -1,178 +1,178 @@ -include "utils"; -include "core"; -include "env"; -include "printer"; - -def arg_check(args): - if .inputs < 0 then - if (abs(.inputs) - 1) > (args | length) then - jqmal_error("Invalid number of arguments (expected at least \(abs(.inputs) - 1), got \(args|length))") - else - . - end - else if .inputs != (args|length) then - jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") - else - . - end end; - -def extractReplEnv(env): - env | .replEnv // .; - -def extractEnv(env): - env | .currentEnv // .; - -def updateReplEnv(renv): - def findpath: - if .env.parent then - .path += ["parent"] | - .env |= .parent | - findpath - else - .path - end; - ({ env: ., path: [] } | findpath) as $path | - setpath($path; renv); - -def extractCurrentReplEnv(env): - def findpath: - if .env.parent then - .path += ["parent"] | - .env |= .parent | - findpath - else - .path - end; - if env.currentEnv != null then - ({ env: env.currentEnv, path: [] } | findpath) as $path | - env.currentEnv | getpath($path) - else - env - end; - -def extractAtoms(env): - env.atoms // {}; - -def addFrees(newEnv; frees): - . as $env - | reduce frees[] as $free ( - $env; - . as $dot - | extractEnv(newEnv) as $env - | env_req($env; $free) as $lookup - | if $lookup != null then - env_set_(.; $free; $lookup) - else - . - end) - | . as $env - | $env; - -def interpret(arguments; env; _eval): - extractReplEnv(env) as $replEnv | - extractAtoms(env) as $envAtoms | - (if $DEBUG then _debug("INTERP: \(. | pr_str(env))") else . end) | - (select(.kind == "fn") | - arg_check(arguments) | - (select(.function == "eval") | - # special function - { expr: arguments[0], env: $replEnv|wrapEnv($replEnv; $envAtoms) } - | _eval - | .env as $xenv - | extractReplEnv($xenv) as $xreplenv - | setpath( - ["env", "currentEnv"]; - extractEnv(env) | updateReplEnv($xreplenv)) - ) // - (select(.function == "reset!") | - # env modifying function - arguments[0].identity as $id | - ($envAtoms | setpath([$id]; arguments[1])) as $envAtoms | - arguments[1] | addEnv(env | setpath(["atoms"]; $envAtoms)) - ) // - (select(.function == "swap!") | - # env modifying function - arguments[0].identity as $id | - $envAtoms[$id] as $initValue | - arguments[1] as $function | - ([$initValue] + arguments[2:]) as $args | - ($function | interpret($args; env; _eval)) as $newEnvValue | - ($envAtoms | setpath([$id]; $newEnvValue.expr)) as $envAtoms | - $newEnvValue.expr | addEnv(env | setpath(["atoms"]; $envAtoms)) - ) // (select(.function == "atom") | - (now|tostring) as $id | - {kind: "atom", identity: $id} as $value | - ($envAtoms | setpath([$id]; arguments[0])) as $envAtoms | - $value | addEnv(env | setpath(["atoms"]; $envAtoms)) - ) // (select(.function == "deref") | - $envAtoms[arguments[0].identity] | addEnv(env) - ) // - (select(.function == "apply") | - # (apply F ...T A) -> (F ...T ...A) - arguments as $args - | ($args|first) as $F - | ($args|last.value) as $A - | $args[1:-1] as $T - | $F | interpret([$T[], $A[]]; env; _eval) - ) // - (select(.function == "map") | - arguments - | first as $F - | last.value as $L - | (reduce $L[] as $elem ( - {env: env, val: []}; - . as $dot | - ($F | interpret([$elem]; $dot.env; _eval)) as $val | - { - val: (.val + [$val.expr]), - env: (.env | setpath(["atoms"]; $val.env.atoms)) - } - )) as $ex - | $ex.val | wrap("list") | addEnv($ex.env) - ) // - (core_interp(arguments; env) | addEnv(env)) - ) // - (select(.kind == "function") as $fn | - # todo: arg_check - (.body | pr_str(env)) as $src | - # _debug("INTERP " + $src) | - # _debug("FREES " + ($fn.free_referencess | tostring)) | - env_setfallback(extractEnv(.env | addFrees(env; $fn.free_referencess)); extractEnv(env)) | childEnv($fn.binds; arguments) as $fnEnv | - # tell it about its surroundings - (reduce $fn.free_referencess[] as $name ( - $fnEnv; - . as $env | try env_set_( - .; - $name; - $name | env_get(env) | . as $xvalue - | if $xvalue.kind == "function" then - setpath(["free_referencess"]; $fn.free_referencess) - else - $xvalue - end - ) catch $env)) as $fnEnv | - # tell it about itself - env_multiset($fnEnv; $fn.names; $fn) as $fnEnv | - { - env: env_multiset($fnEnv; $fn.names; $fn) - | wrapEnv($replEnv; $envAtoms), - expr: $fn.body - } - | . as $dot - # | _debug("FNEXEC " + (.expr | pr_str) + " " + (env_req($dot.env; $fn.binds[0]) | pr_str)) - | _eval - | . as $envexp - | (extractReplEnv($envexp.env)) as $xreplenv - | - { - expr: .expr, - env: extractEnv(env) - | updateReplEnv($xreplenv) - | wrapEnv($xreplenv; $envexp.env.atoms) - } - # | . as $dot - # | _debug("FNPOST " + (.expr | pr_str) + " " + (env_req($dot.expr.env; $fn.binds[0]) | pr_str)) - # | _debug("INTERP " + $src + " = " + (.expr|pr_str)) - ) // - jqmal_error("Unsupported function kind \(.kind)"); +include "utils"; +include "core"; +include "env"; +include "printer"; + +def arg_check(args): + if .inputs < 0 then + if (abs(.inputs) - 1) > (args | length) then + jqmal_error("Invalid number of arguments (expected at least \(abs(.inputs) - 1), got \(args|length))") + else + . + end + else if .inputs != (args|length) then + jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") + else + . + end end; + +def extractReplEnv(env): + env | .replEnv // .; + +def extractEnv(env): + env | .currentEnv // .; + +def updateReplEnv(renv): + def findpath: + if .env.parent then + .path += ["parent"] | + .env |= .parent | + findpath + else + .path + end; + ({ env: ., path: [] } | findpath) as $path | + setpath($path; renv); + +def extractCurrentReplEnv(env): + def findpath: + if .env.parent then + .path += ["parent"] | + .env |= .parent | + findpath + else + .path + end; + if env.currentEnv != null then + ({ env: env.currentEnv, path: [] } | findpath) as $path | + env.currentEnv | getpath($path) + else + env + end; + +def extractAtoms(env): + env.atoms // {}; + +def addFrees(newEnv; frees): + . as $env + | reduce frees[] as $free ( + $env; + . as $dot + | extractEnv(newEnv) as $env + | env_req($env; $free) as $lookup + | if $lookup != null then + env_set_(.; $free; $lookup) + else + . + end) + | . as $env + | $env; + +def interpret(arguments; env; _eval): + extractReplEnv(env) as $replEnv | + extractAtoms(env) as $envAtoms | + (if $DEBUG then _debug("INTERP: \(. | pr_str(env))") else . end) | + (select(.kind == "fn") | + arg_check(arguments) | + (select(.function == "eval") | + # special function + { expr: arguments[0], env: $replEnv|wrapEnv($replEnv; $envAtoms) } + | _eval + | .env as $xenv + | extractReplEnv($xenv) as $xreplenv + | setpath( + ["env", "currentEnv"]; + extractEnv(env) | updateReplEnv($xreplenv)) + ) // + (select(.function == "reset!") | + # env modifying function + arguments[0].identity as $id | + ($envAtoms | setpath([$id]; arguments[1])) as $envAtoms | + arguments[1] | addEnv(env | setpath(["atoms"]; $envAtoms)) + ) // + (select(.function == "swap!") | + # env modifying function + arguments[0].identity as $id | + $envAtoms[$id] as $initValue | + arguments[1] as $function | + ([$initValue] + arguments[2:]) as $args | + ($function | interpret($args; env; _eval)) as $newEnvValue | + ($envAtoms | setpath([$id]; $newEnvValue.expr)) as $envAtoms | + $newEnvValue.expr | addEnv(env | setpath(["atoms"]; $envAtoms)) + ) // (select(.function == "atom") | + (now|tostring) as $id | + {kind: "atom", identity: $id} as $value | + ($envAtoms | setpath([$id]; arguments[0])) as $envAtoms | + $value | addEnv(env | setpath(["atoms"]; $envAtoms)) + ) // (select(.function == "deref") | + $envAtoms[arguments[0].identity] | addEnv(env) + ) // + (select(.function == "apply") | + # (apply F ...T A) -> (F ...T ...A) + arguments as $args + | ($args|first) as $F + | ($args|last.value) as $A + | $args[1:-1] as $T + | $F | interpret([$T[], $A[]]; env; _eval) + ) // + (select(.function == "map") | + arguments + | first as $F + | last.value as $L + | (reduce $L[] as $elem ( + {env: env, val: []}; + . as $dot | + ($F | interpret([$elem]; $dot.env; _eval)) as $val | + { + val: (.val + [$val.expr]), + env: (.env | setpath(["atoms"]; $val.env.atoms)) + } + )) as $ex + | $ex.val | wrap("list") | addEnv($ex.env) + ) // + (core_interp(arguments; env) | addEnv(env)) + ) // + (select(.kind == "function") as $fn | + # todo: arg_check + (.body | pr_str(env)) as $src | + # _debug("INTERP " + $src) | + # _debug("FREES " + ($fn.free_referencess | tostring)) | + env_setfallback(extractEnv(.env | addFrees(env; $fn.free_referencess)); extractEnv(env)) | childEnv($fn.binds; arguments) as $fnEnv | + # tell it about its surroundings + (reduce $fn.free_referencess[] as $name ( + $fnEnv; + . as $env | try env_set_( + .; + $name; + $name | env_get(env) | . as $xvalue + | if $xvalue.kind == "function" then + setpath(["free_referencess"]; $fn.free_referencess) + else + $xvalue + end + ) catch $env)) as $fnEnv | + # tell it about itself + env_multiset($fnEnv; $fn.names; $fn) as $fnEnv | + { + env: env_multiset($fnEnv; $fn.names; $fn) + | wrapEnv($replEnv; $envAtoms), + expr: $fn.body + } + | . as $dot + # | _debug("FNEXEC " + (.expr | pr_str) + " " + (env_req($dot.env; $fn.binds[0]) | pr_str)) + | _eval + | . as $envexp + | (extractReplEnv($envexp.env)) as $xreplenv + | + { + expr: .expr, + env: extractEnv(env) + | updateReplEnv($xreplenv) + | wrapEnv($xreplenv; $envexp.env.atoms) + } + # | . as $dot + # | _debug("FNPOST " + (.expr | pr_str) + " " + (env_req($dot.expr.env; $fn.binds[0]) | pr_str)) + # | _debug("INTERP " + $src + " = " + (.expr|pr_str)) + ) // + jqmal_error("Unsupported function kind \(.kind)"); \ No newline at end of file diff --git a/impls/jq/printer.jq b/impls/jq/printer.jq index 703eb65056..979fc261d0 100644 --- a/impls/jq/printer.jq +++ b/impls/jq/printer.jq @@ -1,29 +1,29 @@ -# {key: string, value: {kkind: kind, value: value}} -> [{kind: value.kkind, value: key}, value.value] -def _reconstruct_hash: - map([{ - kind: .value.kkind, - value: .key - }, - .value.value]); - -def pr_str(env; opt): - (select(.kind == "symbol") | .value) // - (select(.kind == "string") | .value | if opt.readable then tojson else . end) // - (select(.kind == "keyword") | ":\(.value)") // - (select(.kind == "number") | .value | tostring) // - (select(.kind == "list") | .value | map(pr_str(env; opt)) | join(" ") | "(\(.))") // - (select(.kind == "vector") | .value | map(pr_str(env; opt)) | join(" ") | "[\(.)]") // - (select(.kind == "hashmap") | .value | to_entries | _reconstruct_hash | add // [] | map(pr_str(env; opt)) | join(" ") | "{\(.)}") // - (select(.kind == "nil") | "nil") // - (select(.kind == "true") | "true") // - (select(.kind == "false") | "false") // - (select(.kind == "fn") | "#") // - (select(.kind == "function")| "#") // - (select(.kind == "atom") | "(atom \(env.atoms[.identity] | pr_str(env; opt)))") // - "#"; - -def pr_str(env): - pr_str(env; {readable: true}); - -def pr_str: +# {key: string, value: {kkind: kind, value: value}} -> [{kind: value.kkind, value: key}, value.value] +def _reconstruct_hash: + map([{ + kind: .value.kkind, + value: .key + }, + .value.value]); + +def pr_str(env; opt): + (select(.kind == "symbol") | .value) // + (select(.kind == "string") | .value | if opt.readable then tojson else . end) // + (select(.kind == "keyword") | ":\(.value)") // + (select(.kind == "number") | .value | tostring) // + (select(.kind == "list") | .value | map(pr_str(env; opt)) | join(" ") | "(\(.))") // + (select(.kind == "vector") | .value | map(pr_str(env; opt)) | join(" ") | "[\(.)]") // + (select(.kind == "hashmap") | .value | to_entries | _reconstruct_hash | add // [] | map(pr_str(env; opt)) | join(" ") | "{\(.)}") // + (select(.kind == "nil") | "nil") // + (select(.kind == "true") | "true") // + (select(.kind == "false") | "false") // + (select(.kind == "fn") | "#") // + (select(.kind == "function")| "#") // + (select(.kind == "atom") | "(atom \(env.atoms[.identity] | pr_str(env; opt)))") // + "#"; + +def pr_str(env): + pr_str(env; {readable: true}); + +def pr_str: pr_str(null); # for stepX where X<6 \ No newline at end of file diff --git a/impls/jq/reader.jq b/impls/jq/reader.jq index d8c98198f7..7a97f574df 100644 --- a/impls/jq/reader.jq +++ b/impls/jq/reader.jq @@ -1,311 +1,311 @@ -include "utils"; - -def tokenize: - [ . | scan("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)") | select(.|length > 0)[0] | select(.[0:1] != ";") ]; - -def read_str: - tokenize; - -def escape_control: - (select(. == "\u0000") | "\\u0000") // - (select(. == "\u0001") | "\\u0001") // - (select(. == "\u0002") | "\\u0002") // - (select(. == "\u0003") | "\\u0003") // - (select(. == "\u0004") | "\\u0004") // - (select(. == "\u0005") | "\\u0005") // - (select(. == "\u0006") | "\\u0006") // - (select(. == "\u0007") | "\\u0007") // - (select(. == "\u0008") | "\\u0008") // - (select(. == "\u0009") | "\\u0009") // - (select(. == "\u0010") | "\\u0010") // - (select(. == "\u0011") | "\\u0011") // - (select(. == "\u0012") | "\\u0012") // - (select(. == "\u0013") | "\\u0013") // - (select(. == "\u0014") | "\\u0014") // - (select(. == "\u0015") | "\\u0015") // - (select(. == "\u0016") | "\\u0016") // - (select(. == "\u0017") | "\\u0017") // - (select(. == "\u0018") | "\\u0018") // - (select(. == "\u0019") | "\\u0019") // - (select(. == "\u0020") | "\\u0020") // - (select(. == "\u0021") | "\\u0021") // - (select(. == "\u0022") | "\\u0022") // - (select(. == "\u0023") | "\\u0023") // - (select(. == "\u0024") | "\\u0024") // - (select(. == "\u0025") | "\\u0025") // - (select(. == "\u0026") | "\\u0026") // - (select(. == "\u0027") | "\\u0027") // - (select(. == "\u0028") | "\\u0028") // - (select(. == "\u0029") | "\\u0029") // - (select(. == "\u0030") | "\\u0030") // - (select(. == "\u0031") | "\\u0031") // - (select(. == "\n") | "\\n") // - .; - -def read_string: - gsub("(?[\u0000-\u001f])"; "\(.z | escape_control)") | fromjson; - -def extract_string: - . as $val | if ["keyword", "symbol", "string"] | contains([$val.kind]) then - $val.value - else - jqmal_error("assoc called with non-string key of type \($val.kind)") - end; - -# stuff comes in as {tokens: [...], } -def read_atom: - (.tokens | first) as $lookahead | . | ( - if $lookahead == "nil" then - { - tokens: .tokens[1:], - value: { - kind: "nil" - } - } - else if $lookahead == "true" then - { - tokens: .tokens[1:], - value: { - kind: "true" - } - } - else if $lookahead == "false" then - { - tokens: .tokens[1:], - value: { - kind: "false" - } - } - else if $lookahead | test("^\"") then - if $lookahead | test("^\"(?:\\\\.|[^\\\\\"])*\"$") then - { - tokens: .tokens[1:], - value: { - kind: "string", - value: $lookahead | read_string - } - } - else - jqmal_error("EOF while reading string") - end - else if $lookahead | test("^:") then - { - tokens: .tokens[1:], - value: { - kind: "keyword", - value: $lookahead[1:] - } - } - else if $lookahead | test("^-?[0-9]+(?:\\.[0-9]+)?$") then - { - tokens: .tokens[1:], - value: { - kind: "number", - value: $lookahead | tonumber - } - } - else if [")", "]", "}"] | contains([$lookahead]) then # this isn't our business - empty - else - { - tokens: .tokens[1:], - value: { - kind: "symbol", - value: $lookahead - } - } - end end end end end end end - ); - -def read_form_(depth): - (.tokens | first) as $lookahead | . | ( - if $lookahead == null then - null - # read_list - else - if $lookahead | test("^\\(") then - [ (.tokens |= .[1:]) | {tokens: .tokens, value: [], finish: false} | (until(.finish; - if try (.tokens | first | test("^\\)")) catch true then - .finish |= true - else - . as $orig | read_form_(depth+1) as $res | { - tokens: $res.tokens, - value: ($orig.value + [$res.value]), - finish: $orig.finish - } - end)) ] | map(select(.tokens)) | last as $result | - if $result.tokens | first != ")" then - jqmal_error("unbalanced parentheses in \($result.tokens)") - else - { - tokens: $result.tokens[1:], - value: { - kind: "list", - value: $result.value - }, - } - end - # read_list '[' - else if $lookahead | test("^\\[") then - [ (.tokens |= .[1:]) | {tokens: .tokens, value: [], finish: false} | (until(.finish; - if try (.tokens | first | test("^\\]")) catch true then - .finish |= true - else - . as $orig | read_form_(depth+1) as $res | { - tokens: $res.tokens, - value: ($orig.value + [$res.value]), - finish: $orig.finish - } - end)) ] | map(select(.tokens)) | last as $result | - if $result.tokens | first != "]" then - jqmal_error("unbalanced brackets in \($result.tokens)") - else - { - tokens: $result.tokens[1:], - value: { - kind: "vector", - value: $result.value - }, - } - end - # read_list '{' - else if $lookahead | test("^\\{") then - [ (.tokens |= .[1:]) | {tokens: .tokens, value: [], finish: false} | (until(.finish; - if try (.tokens | first | test("^\\}")) catch true then - .finish |= true - else - . as $orig | read_form_(depth+1) as $res | { - tokens: $res.tokens, - value: ($orig.value + [$res.value]), - finish: $orig.finish - } - end)) ] | map(select(.tokens)) | last as $result | - if $result.tokens | first != "}" then - jqmal_error("unbalanced braces in \($result.tokens)") - else - if $result.value | length % 2 == 1 then - # odd number of elements not allowed - jqmal_error("Odd number of parameters to assoc") - else - { - tokens: $result.tokens[1:], - value: { - kind: "hashmap", - value: - [ $result.value | - nwise(2) | - try { - key: (.[0] | extract_string), - value: { - kkind: .[0].kind, - value: .[1] - } - } - ] | from_entries - } - } - end - end - # quote - else if $lookahead == "'" then - (.tokens |= .[1:]) | read_form_(depth+1) | ( - { - tokens: .tokens, - value: { - kind: "list", - value: [ - { - kind: "symbol", - value: "quote" - }, - .value - ] - } - }) - # quasiquote - else if $lookahead == "`" then - (.tokens |= .[1:]) | read_form_(depth+1) | ( - { - tokens: .tokens, - value: { - kind: "list", - value: [ - { - kind: "symbol", - value: "quasiquote" - }, - .value - ] - } - }) - # unquote - else if $lookahead == "~" then - (.tokens |= .[1:]) | read_form_(depth+1) | ( - { - tokens: .tokens, - value: { - kind: "list", - value: [ - { - kind: "symbol", - value: "unquote" - }, - .value - ] - } - }) - # split-unquote - else if $lookahead == "~@" then - (.tokens |= .[1:]) | read_form_(depth+1) | ( - { - tokens: .tokens, - value: { - kind: "list", - value: [ - { - kind: "symbol", - value: "splice-unquote" - }, - .value - ] - } - }) - # deref - else if $lookahead == "@" then - (.tokens |= .[1:]) | read_form_(depth+1) | ( - { - tokens: .tokens, - value: { - kind: "list", - value: [ - { - kind: "symbol", - value: "deref" - }, - .value - ] - } - }) - # with-meta - else if $lookahead == "^" then - (.tokens |= .[1:]) | read_form_(depth+1) as $meta | $meta | read_form_(depth+1) as $value | ( - { - tokens: $value.tokens, - value: { - kind: "list", - value: [ - { - kind: "symbol", - value: "with-meta" - }, - $value.value, - $meta.value - ] - } - }) - else - . as $prev | read_atom - end end end end end end end end end end); - -def read_form: - {tokens: .} | read_form_(0); +include "utils"; + +def tokenize: + [ . | scan("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)") | select(.|length > 0)[0] | select(.[0:1] != ";") ]; + +def read_str: + tokenize; + +def escape_control: + (select(. == "\u0000") | "\\u0000") // + (select(. == "\u0001") | "\\u0001") // + (select(. == "\u0002") | "\\u0002") // + (select(. == "\u0003") | "\\u0003") // + (select(. == "\u0004") | "\\u0004") // + (select(. == "\u0005") | "\\u0005") // + (select(. == "\u0006") | "\\u0006") // + (select(. == "\u0007") | "\\u0007") // + (select(. == "\u0008") | "\\u0008") // + (select(. == "\u0009") | "\\u0009") // + (select(. == "\u0010") | "\\u0010") // + (select(. == "\u0011") | "\\u0011") // + (select(. == "\u0012") | "\\u0012") // + (select(. == "\u0013") | "\\u0013") // + (select(. == "\u0014") | "\\u0014") // + (select(. == "\u0015") | "\\u0015") // + (select(. == "\u0016") | "\\u0016") // + (select(. == "\u0017") | "\\u0017") // + (select(. == "\u0018") | "\\u0018") // + (select(. == "\u0019") | "\\u0019") // + (select(. == "\u0020") | "\\u0020") // + (select(. == "\u0021") | "\\u0021") // + (select(. == "\u0022") | "\\u0022") // + (select(. == "\u0023") | "\\u0023") // + (select(. == "\u0024") | "\\u0024") // + (select(. == "\u0025") | "\\u0025") // + (select(. == "\u0026") | "\\u0026") // + (select(. == "\u0027") | "\\u0027") // + (select(. == "\u0028") | "\\u0028") // + (select(. == "\u0029") | "\\u0029") // + (select(. == "\u0030") | "\\u0030") // + (select(. == "\u0031") | "\\u0031") // + (select(. == "\n") | "\\n") // + .; + +def read_string: + gsub("(?[\u0000-\u001f])"; "\(.z | escape_control)") | fromjson; + +def extract_string: + . as $val | if ["keyword", "symbol", "string"] | contains([$val.kind]) then + $val.value + else + jqmal_error("assoc called with non-string key of type \($val.kind)") + end; + +# stuff comes in as {tokens: [...], } +def read_atom: + (.tokens | first) as $lookahead | . | ( + if $lookahead == "nil" then + { + tokens: .tokens[1:], + value: { + kind: "nil" + } + } + else if $lookahead == "true" then + { + tokens: .tokens[1:], + value: { + kind: "true" + } + } + else if $lookahead == "false" then + { + tokens: .tokens[1:], + value: { + kind: "false" + } + } + else if $lookahead | test("^\"") then + if $lookahead | test("^\"(?:\\\\.|[^\\\\\"])*\"$") then + { + tokens: .tokens[1:], + value: { + kind: "string", + value: $lookahead | read_string + } + } + else + jqmal_error("EOF while reading string") + end + else if $lookahead | test("^:") then + { + tokens: .tokens[1:], + value: { + kind: "keyword", + value: $lookahead[1:] + } + } + else if $lookahead | test("^-?[0-9]+(?:\\.[0-9]+)?$") then + { + tokens: .tokens[1:], + value: { + kind: "number", + value: $lookahead | tonumber + } + } + else if [")", "]", "}"] | contains([$lookahead]) then # this isn't our business + empty + else + { + tokens: .tokens[1:], + value: { + kind: "symbol", + value: $lookahead + } + } + end end end end end end end + ); + +def read_form_(depth): + (.tokens | first) as $lookahead | . | ( + if $lookahead == null then + null + # read_list + else + if $lookahead | test("^\\(") then + [ (.tokens |= .[1:]) | {tokens: .tokens, value: [], finish: false} | (until(.finish; + if try (.tokens | first | test("^\\)")) catch true then + .finish |= true + else + . as $orig | read_form_(depth+1) as $res | { + tokens: $res.tokens, + value: ($orig.value + [$res.value]), + finish: $orig.finish + } + end)) ] | map(select(.tokens)) | last as $result | + if $result.tokens | first != ")" then + jqmal_error("unbalanced parentheses in \($result.tokens)") + else + { + tokens: $result.tokens[1:], + value: { + kind: "list", + value: $result.value + }, + } + end + # read_list '[' + else if $lookahead | test("^\\[") then + [ (.tokens |= .[1:]) | {tokens: .tokens, value: [], finish: false} | (until(.finish; + if try (.tokens | first | test("^\\]")) catch true then + .finish |= true + else + . as $orig | read_form_(depth+1) as $res | { + tokens: $res.tokens, + value: ($orig.value + [$res.value]), + finish: $orig.finish + } + end)) ] | map(select(.tokens)) | last as $result | + if $result.tokens | first != "]" then + jqmal_error("unbalanced brackets in \($result.tokens)") + else + { + tokens: $result.tokens[1:], + value: { + kind: "vector", + value: $result.value + }, + } + end + # read_list '{' + else if $lookahead | test("^\\{") then + [ (.tokens |= .[1:]) | {tokens: .tokens, value: [], finish: false} | (until(.finish; + if try (.tokens | first | test("^\\}")) catch true then + .finish |= true + else + . as $orig | read_form_(depth+1) as $res | { + tokens: $res.tokens, + value: ($orig.value + [$res.value]), + finish: $orig.finish + } + end)) ] | map(select(.tokens)) | last as $result | + if $result.tokens | first != "}" then + jqmal_error("unbalanced braces in \($result.tokens)") + else + if $result.value | length % 2 == 1 then + # odd number of elements not allowed + jqmal_error("Odd number of parameters to assoc") + else + { + tokens: $result.tokens[1:], + value: { + kind: "hashmap", + value: + [ $result.value | + nwise(2) | + try { + key: (.[0] | extract_string), + value: { + kkind: .[0].kind, + value: .[1] + } + } + ] | from_entries + } + } + end + end + # quote + else if $lookahead == "'" then + (.tokens |= .[1:]) | read_form_(depth+1) | ( + { + tokens: .tokens, + value: { + kind: "list", + value: [ + { + kind: "symbol", + value: "quote" + }, + .value + ] + } + }) + # quasiquote + else if $lookahead == "`" then + (.tokens |= .[1:]) | read_form_(depth+1) | ( + { + tokens: .tokens, + value: { + kind: "list", + value: [ + { + kind: "symbol", + value: "quasiquote" + }, + .value + ] + } + }) + # unquote + else if $lookahead == "~" then + (.tokens |= .[1:]) | read_form_(depth+1) | ( + { + tokens: .tokens, + value: { + kind: "list", + value: [ + { + kind: "symbol", + value: "unquote" + }, + .value + ] + } + }) + # split-unquote + else if $lookahead == "~@" then + (.tokens |= .[1:]) | read_form_(depth+1) | ( + { + tokens: .tokens, + value: { + kind: "list", + value: [ + { + kind: "symbol", + value: "splice-unquote" + }, + .value + ] + } + }) + # deref + else if $lookahead == "@" then + (.tokens |= .[1:]) | read_form_(depth+1) | ( + { + tokens: .tokens, + value: { + kind: "list", + value: [ + { + kind: "symbol", + value: "deref" + }, + .value + ] + } + }) + # with-meta + else if $lookahead == "^" then + (.tokens |= .[1:]) | read_form_(depth+1) as $meta | $meta | read_form_(depth+1) as $value | ( + { + tokens: $value.tokens, + value: { + kind: "list", + value: [ + { + kind: "symbol", + value: "with-meta" + }, + $value.value, + $meta.value + ] + } + }) + else + . as $prev | read_atom + end end end end end end end end end end); + +def read_form: + {tokens: .} | read_form_(0); diff --git a/impls/jq/rts.py b/impls/jq/rts.py index fe1f16b637..7c1f11b1b3 100644 --- a/impls/jq/rts.py +++ b/impls/jq/rts.py @@ -1,112 +1,112 @@ -import os -from os import fork, execv, pipe, close, dup2, kill, read, write -from select import select -import json -from os.path import dirname, realpath -from os import environ -import signal -from sys import argv -import fcntl - -DEBUG = False -HALT = False - -# Bestow IO upon jq - -def _read(fname, out=None): - with open(fname, "r") as f: - data = json.dumps(f.read()) + "\n" - # print("data =", data) - write(out, bytes(data, 'utf-8')) - -def _readline(prompt="", out=None): - data = json.dumps(input(prompt)) + "\n" - # print("data =", data) - write(out, bytes(data, 'utf-8')) - -def _fwrite(fname, data, out=None): - return - -def _halt(out=None): - global HALT - HALT = True - -def stub(*args, out=None): - raise Exception("command not understood") - -rts = { - "read": _read, - "readline": _readline, - "fwrite": _fwrite, - "halt": _halt, -} - -def process(cmd, fout): - if type(cmd) == str: - print(cmd, end="") - elif type(cmd) == dict: - cmd = cmd['command'] - command = cmd['cmd'] - args = cmd['args'] - fn = rts.get(command, stub) - fn(*args, out=fout) - -def get_one(fd): - s = b"" - while True: - x = read(fd, 1) - if x == b'\n': - break - if x == b'': - break - s += x - if s == "": - return None - return s.decode('utf-8') - - -def main(args): - args = [ - "jq", "--argjson", "DEBUG", json.dumps(DEBUG), "-nrRM", - "-f", - dirname(realpath(__file__)) + "/" + environ.get("STEP", "stepA_mal") + ".jq", - "--args", - *args - ] - # print(args) - sin_pipe = pipe() - sout_pipe = pipe() - - pid = fork() - if pid == 0: - # jq - close(sin_pipe[1]) - close(sout_pipe[0]) - - dup2(sin_pipe[0], 0) - dup2(sout_pipe[1], 2) # bind to stderr, as we write there - dup2(sout_pipe[1], 1) - - execv("/usr/bin/jq", args) - else: - close(sin_pipe[0]) - close(sout_pipe[1]) - - msout = sin_pipe[1] - msin = sout_pipe[0] - - while True: - try: - if HALT: - break - cmd = get_one(msin) - # print(cmd) - if cmd: - process(json.loads(cmd)[1], msout) - except KeyboardInterrupt: - exit() - except Exception as e: - print("RTS Error:", e) - - -main(argv[1:]) +import os +from os import fork, execv, pipe, close, dup2, kill, read, write +from select import select +import json +from os.path import dirname, realpath +from os import environ +import signal +from sys import argv +import fcntl + +DEBUG = False +HALT = False + +# Bestow IO upon jq + +def _read(fname, out=None): + with open(fname, "r") as f: + data = json.dumps(f.read()) + "\n" + # print("data =", data) + write(out, bytes(data, 'utf-8')) + +def _readline(prompt="", out=None): + data = json.dumps(input(prompt)) + "\n" + # print("data =", data) + write(out, bytes(data, 'utf-8')) + +def _fwrite(fname, data, out=None): + return + +def _halt(out=None): + global HALT + HALT = True + +def stub(*args, out=None): + raise Exception("command not understood") + +rts = { + "read": _read, + "readline": _readline, + "fwrite": _fwrite, + "halt": _halt, +} + +def process(cmd, fout): + if type(cmd) == str: + print(cmd, end="") + elif type(cmd) == dict: + cmd = cmd['command'] + command = cmd['cmd'] + args = cmd['args'] + fn = rts.get(command, stub) + fn(*args, out=fout) + +def get_one(fd): + s = b"" + while True: + x = read(fd, 1) + if x == b'\n': + break + if x == b'': + break + s += x + if s == "": + return None + return s.decode('utf-8') + + +def main(args): + args = [ + "jq", "--argjson", "DEBUG", json.dumps(DEBUG), "-nrRM", + "-f", + dirname(realpath(__file__)) + "/" + environ.get("STEP", "stepA_mal") + ".jq", + "--args", + *args + ] + # print(args) + sin_pipe = pipe() + sout_pipe = pipe() + + pid = fork() + if pid == 0: + # jq + close(sin_pipe[1]) + close(sout_pipe[0]) + + dup2(sin_pipe[0], 0) + dup2(sout_pipe[1], 2) # bind to stderr, as we write there + dup2(sout_pipe[1], 1) + + execv("/usr/bin/jq", args) + else: + close(sin_pipe[0]) + close(sout_pipe[1]) + + msout = sin_pipe[1] + msin = sout_pipe[0] + + while True: + try: + if HALT: + break + cmd = get_one(msin) + # print(cmd) + if cmd: + process(json.loads(cmd)[1], msout) + except KeyboardInterrupt: + exit() + except Exception as e: + print("RTS Error:", e) + + +main(argv[1:]) diff --git a/impls/jq/run b/impls/jq/run index 02e476e49f..e3cb112966 100755 --- a/impls/jq/run +++ b/impls/jq/run @@ -1,3 +1,3 @@ -#!/bin/sh - -exec python rts.py "${@}" +#!/bin/sh + +exec python rts.py "${@}" diff --git a/impls/jq/step0_repl.jq b/impls/jq/step0_repl.jq index 46c5a5eaf8..3544e20204 100644 --- a/impls/jq/step0_repl.jq +++ b/impls/jq/step0_repl.jq @@ -1,27 +1,27 @@ -include "utils"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - .; - -def EVAL: - .; - -def PRINT: - .; - -def rep: - READ | EVAL | PRINT | _display; - -def repl_: - ("user> " | _print) | - (read_line | rep); - -def repl: - while(true; repl_); - -repl +include "utils"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + .; + +def EVAL: + .; + +def PRINT: + .; + +def rep: + READ | EVAL | PRINT | _display; + +def repl_: + ("user> " | _print) | + (read_line | rep); + +def repl: + while(true; repl_); + +repl diff --git a/impls/jq/step1_read_print.jq b/impls/jq/step1_read_print.jq index d0069c27ed..a6dd38d7e1 100644 --- a/impls/jq/step1_read_print.jq +++ b/impls/jq/step1_read_print.jq @@ -1,42 +1,42 @@ -include "reader"; -include "printer"; -include "utils"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -def EVAL: - .; - -def PRINT: - pr_str; - -def rep: - READ | EVAL | - if . != null then - PRINT - else - null - end; - -def repl_: - ("user> " | _print) | - (read_line | rep); - -def repl: - {continue: true} | while( - .continue; - try {value: repl_, continue: true} - catch - if is_jqmal_error then - {value: "Error: \(.)", continue: true} - else - {value: ., continue: false} - end) | if .value then .value|_display else empty end; - -repl +include "reader"; +include "printer"; +include "utils"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +def EVAL: + .; + +def PRINT: + pr_str; + +def rep: + READ | EVAL | + if . != null then + PRINT + else + null + end; + +def repl_: + ("user> " | _print) | + (read_line | rep); + +def repl: + {continue: true} | while( + .continue; + try {value: repl_, continue: true} + catch + if is_jqmal_error then + {value: "Error: \(.)", continue: true} + else + {value: ., continue: false} + end) | if .value then .value|_display else empty end; + +repl diff --git a/impls/jq/step2_eval.jq b/impls/jq/step2_eval.jq index e04ce81ded..e4c3ec4599 100644 --- a/impls/jq/step2_eval.jq +++ b/impls/jq/step2_eval.jq @@ -1,121 +1,121 @@ -include "reader"; -include "printer"; -include "utils"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -def lookup(env): - env[.] // - jqmal_error("'\(.)' not found"); - -def arg_check(args): - if .inputs != (args|length) then - jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") - else - . - end; - -def interpret(arguments; env): - (select(.kind == "fn") | - arg_check(arguments) | - ( - select(.function == "number_add") | - arguments | map(.value) | .[0] + .[1] | wrap("number") - ) // ( - select(.function == "number_sub") | - arguments | map(.value) | .[0] - .[1] | wrap("number") - ) // ( - select(.function == "number_mul") | - arguments | map(.value) | .[0] * .[1] | wrap("number") - ) // ( - select(.function == "number_div") | - arguments | map(.value) | .[0] / .[1] | wrap("number") - ) - ) // - jqmal_error("Unsupported native function kind \(.kind)"); - -def EVAL(env): - def eval_ast: - (select(.kind == "symbol") | .value | lookup(env)) // - (select(.kind == "list") | { - kind: "list", - value: .value | map(EVAL(env)) - }) // .; - (select(.kind == "list") | - if .value | length == 0 then - . - else - eval_ast|.value as $evald | $evald | first | interpret($evald[1:]; env) - end - ) // - (select(.kind == "vector") | - { - kind: "vector", - value: .value|map(EVAL(env)) - } - ) // - (select(.kind == "hashmap") | - { - kind: "hashmap", - value: .value|map_values(.value |= EVAL(env)) - } - ) // eval_ast; - -def PRINT: - pr_str; - -def rep(env): - READ | EVAL(env) | - if . != null then - PRINT - else - null - end; - -def repl_(env): - ("user> " | _print) | - (read_line | rep(env)); - -# we don't have no indirect functions, so we'll have to interpret the old way -def replEnv: - { - "+": { - kind: "fn", # native function - inputs: 2, - function: "number_add" - }, - "-": { - kind: "fn", # native function - inputs: 2, - function: "number_sub" - }, - "*": { - kind: "fn", # native function - inputs: 2, - function: "number_mul" - }, - "/": { - kind: "fn", # native function - inputs: 2, - function: "number_div" - }, - }; - -def repl(env): - {continue: true} | while( - .continue; - try {value: repl_(env), continue: true} - catch - if is_jqmal_error then - {value: "Error: \(.)", continue: true} - else - {value: ., continue: false} - end) | if .value then .value|_display else empty end; - +include "reader"; +include "printer"; +include "utils"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +def lookup(env): + env[.] // + jqmal_error("'\(.)' not found"); + +def arg_check(args): + if .inputs != (args|length) then + jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") + else + . + end; + +def interpret(arguments; env): + (select(.kind == "fn") | + arg_check(arguments) | + ( + select(.function == "number_add") | + arguments | map(.value) | .[0] + .[1] | wrap("number") + ) // ( + select(.function == "number_sub") | + arguments | map(.value) | .[0] - .[1] | wrap("number") + ) // ( + select(.function == "number_mul") | + arguments | map(.value) | .[0] * .[1] | wrap("number") + ) // ( + select(.function == "number_div") | + arguments | map(.value) | .[0] / .[1] | wrap("number") + ) + ) // + jqmal_error("Unsupported native function kind \(.kind)"); + +def EVAL(env): + def eval_ast: + (select(.kind == "symbol") | .value | lookup(env)) // + (select(.kind == "list") | { + kind: "list", + value: .value | map(EVAL(env)) + }) // .; + (select(.kind == "list") | + if .value | length == 0 then + . + else + eval_ast|.value as $evald | $evald | first | interpret($evald[1:]; env) + end + ) // + (select(.kind == "vector") | + { + kind: "vector", + value: .value|map(EVAL(env)) + } + ) // + (select(.kind == "hashmap") | + { + kind: "hashmap", + value: .value|map_values(.value |= EVAL(env)) + } + ) // eval_ast; + +def PRINT: + pr_str; + +def rep(env): + READ | EVAL(env) | + if . != null then + PRINT + else + null + end; + +def repl_(env): + ("user> " | _print) | + (read_line | rep(env)); + +# we don't have no indirect functions, so we'll have to interpret the old way +def replEnv: + { + "+": { + kind: "fn", # native function + inputs: 2, + function: "number_add" + }, + "-": { + kind: "fn", # native function + inputs: 2, + function: "number_sub" + }, + "*": { + kind: "fn", # native function + inputs: 2, + function: "number_mul" + }, + "/": { + kind: "fn", # native function + inputs: 2, + function: "number_div" + }, + }; + +def repl(env): + {continue: true} | while( + .continue; + try {value: repl_(env), continue: true} + catch + if is_jqmal_error then + {value: "Error: \(.)", continue: true} + else + {value: ., continue: false} + end) | if .value then .value|_display else empty end; + repl(replEnv) \ No newline at end of file diff --git a/impls/jq/step3_env.jq b/impls/jq/step3_env.jq index 64c13e68a9..59e9f31a4b 100644 --- a/impls/jq/step3_env.jq +++ b/impls/jq/step3_env.jq @@ -1,218 +1,218 @@ -include "reader"; -include "printer"; -include "utils"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -# Environment functions - -def pureChildEnv: - { - parent: ., - environment: {} - }; - -def env_set(env; $key; $value): - { - parent: env.parent, - environment: (env.environment + (env.environment | .[$key] |= $value)) # merge together, as .environment[key] |= value does not work - }; - -def env_find(env): - if env.environment[.] == null then - if env.parent then - env_find(env.parent) - else - null - end - else - env - end; - -def addToEnv(envexp; name): - { - expr: envexp.expr, - env: env_set(envexp.env; name; envexp.expr) - }; - -def env_get(env): - . as $key | $key | env_find(env).environment[$key] as $value | - if $value == null then - jqmal_error("'\($key)' not found") - else - $value - end; - -def addEnv(env): - { - expr: ., - env: env - }; - -# Evaluation - -def arg_check(args): - if .inputs != (args|length) then - jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") - else - . - end; - -def interpret(arguments; env): - (select(.kind == "fn") | - arg_check(arguments) | - ( - select(.function == "number_add") | - arguments | map(.value) | .[0] + .[1] | wrap("number") - ) // ( - select(.function == "number_sub") | - arguments | map(.value) | .[0] - .[1] | wrap("number") - ) // ( - select(.function == "number_mul") | - arguments | map(.value) | .[0] * .[1] | wrap("number") - ) // ( - select(.function == "number_div") | - arguments | map(.value) | .[0] / .[1] | wrap("number") - ) - ) | addEnv(env) // - jqmal_error("Unsupported native function kind \(.kind)"); - -def EVAL(env): - def hmap_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem[1] | EVAL($env) as $resv | - { value: [$elem[0], $resv.expr], env: env }, - ({env: $resv.env, list: $rest} | hmap_with_env) - end; - def map_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem | EVAL($env) as $resv | - { value: $resv.expr, env: env }, - ({env: $resv.env, list: $rest} | map_with_env) - end; - (select(.kind == "list") | - if .value | length == 0 then - . | addEnv(env) - else - ( - ( - .value | select(.[0].value == "def!") as $value | - ($value[2] | EVAL(env)) as $evval | - addToEnv($evval; $value[1].value) - ) // - ( - .value | select(.[0].value == "let*") as $value | - (env | pureChildEnv) as $subenv | - (reduce ($value[1].value | nwise(2)) as $xvalue ( - $subenv; - . as $env | $xvalue[1] | EVAL($env) as $expenv | - env_set($expenv.env; $xvalue[0].value; $expenv.expr))) as $env - | $value[2] | { expr: EVAL($env).expr, env: env } - ) // - ( - reduce .value[] as $elem ( - []; - . as $dot | $elem | EVAL(env) as $eval_env | - ($dot + [$eval_env.expr]) - ) | { expr: ., env: env } as $ev - | $ev.expr | first | - interpret($ev.expr[1:]; $ev.env) - ) // - addEnv(env) - ) - end - ) // - (select(.kind == "vector") | - [ { env: env, list: .value } | map_with_env ] as $res | - { - kind: "vector", - value: $res | map(.value) - } | addEnv($res | last.env) - ) // - (select(.kind == "hashmap") | - [ { env: env, list: .value | to_entries } | hmap_with_env ] as $res | - { - kind: "hashmap", - value: $res | map(.value) | from_entries - } | addEnv($res | last.env) - ) // - (select(.kind == "symbol") | - .value | env_get(env) | addEnv(env) - ) // addEnv(env); - -def PRINT: - pr_str; - -def rep(env): - READ | EVAL(env) as $expenv | - if $expenv.expr != null then - $expenv.expr | PRINT - else - null - end | addEnv($expenv.env); - -def repl_(env): - ("user> " | _print) | - (read_line | rep(env)); - -def childEnv(binds; value): - { - parent: ., - environment: [binds, value] | transpose | map({(.[0]): .[1]}) | from_entries - }; - -# we don't have no indirect functions, so we'll have to interpret the old way -def replEnv: - { - parent: null, - environment: { - "+": { - kind: "fn", # native function - inputs: 2, - function: "number_add" - }, - "-": { - kind: "fn", # native function - inputs: 2, - function: "number_sub" - }, - "*": { - kind: "fn", # native function - inputs: 2, - function: "number_mul" - }, - "/": { - kind: "fn", # native function - inputs: 2, - function: "number_div" - }, - } - }; - -def repl(env): - def xrepl: - (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | - { - value: $expenv.expr, - stop: false, - env: ($expenv.env // .env) - } | ., xrepl; - {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; - -repl(replEnv) +include "reader"; +include "printer"; +include "utils"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +# Environment functions + +def pureChildEnv: + { + parent: ., + environment: {} + }; + +def env_set(env; $key; $value): + { + parent: env.parent, + environment: (env.environment + (env.environment | .[$key] |= $value)) # merge together, as .environment[key] |= value does not work + }; + +def env_find(env): + if env.environment[.] == null then + if env.parent then + env_find(env.parent) + else + null + end + else + env + end; + +def addToEnv(envexp; name): + { + expr: envexp.expr, + env: env_set(envexp.env; name; envexp.expr) + }; + +def env_get(env): + . as $key | $key | env_find(env).environment[$key] as $value | + if $value == null then + jqmal_error("'\($key)' not found") + else + $value + end; + +def addEnv(env): + { + expr: ., + env: env + }; + +# Evaluation + +def arg_check(args): + if .inputs != (args|length) then + jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") + else + . + end; + +def interpret(arguments; env): + (select(.kind == "fn") | + arg_check(arguments) | + ( + select(.function == "number_add") | + arguments | map(.value) | .[0] + .[1] | wrap("number") + ) // ( + select(.function == "number_sub") | + arguments | map(.value) | .[0] - .[1] | wrap("number") + ) // ( + select(.function == "number_mul") | + arguments | map(.value) | .[0] * .[1] | wrap("number") + ) // ( + select(.function == "number_div") | + arguments | map(.value) | .[0] / .[1] | wrap("number") + ) + ) | addEnv(env) // + jqmal_error("Unsupported native function kind \(.kind)"); + +def EVAL(env): + def hmap_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem[1] | EVAL($env) as $resv | + { value: [$elem[0], $resv.expr], env: env }, + ({env: $resv.env, list: $rest} | hmap_with_env) + end; + def map_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem | EVAL($env) as $resv | + { value: $resv.expr, env: env }, + ({env: $resv.env, list: $rest} | map_with_env) + end; + (select(.kind == "list") | + if .value | length == 0 then + . | addEnv(env) + else + ( + ( + .value | select(.[0].value == "def!") as $value | + ($value[2] | EVAL(env)) as $evval | + addToEnv($evval; $value[1].value) + ) // + ( + .value | select(.[0].value == "let*") as $value | + (env | pureChildEnv) as $subenv | + (reduce ($value[1].value | nwise(2)) as $xvalue ( + $subenv; + . as $env | $xvalue[1] | EVAL($env) as $expenv | + env_set($expenv.env; $xvalue[0].value; $expenv.expr))) as $env + | $value[2] | { expr: EVAL($env).expr, env: env } + ) // + ( + reduce .value[] as $elem ( + []; + . as $dot | $elem | EVAL(env) as $eval_env | + ($dot + [$eval_env.expr]) + ) | { expr: ., env: env } as $ev + | $ev.expr | first | + interpret($ev.expr[1:]; $ev.env) + ) // + addEnv(env) + ) + end + ) // + (select(.kind == "vector") | + [ { env: env, list: .value } | map_with_env ] as $res | + { + kind: "vector", + value: $res | map(.value) + } | addEnv($res | last.env) + ) // + (select(.kind == "hashmap") | + [ { env: env, list: .value | to_entries } | hmap_with_env ] as $res | + { + kind: "hashmap", + value: $res | map(.value) | from_entries + } | addEnv($res | last.env) + ) // + (select(.kind == "symbol") | + .value | env_get(env) | addEnv(env) + ) // addEnv(env); + +def PRINT: + pr_str; + +def rep(env): + READ | EVAL(env) as $expenv | + if $expenv.expr != null then + $expenv.expr | PRINT + else + null + end | addEnv($expenv.env); + +def repl_(env): + ("user> " | _print) | + (read_line | rep(env)); + +def childEnv(binds; value): + { + parent: ., + environment: [binds, value] | transpose | map({(.[0]): .[1]}) | from_entries + }; + +# we don't have no indirect functions, so we'll have to interpret the old way +def replEnv: + { + parent: null, + environment: { + "+": { + kind: "fn", # native function + inputs: 2, + function: "number_add" + }, + "-": { + kind: "fn", # native function + inputs: 2, + function: "number_sub" + }, + "*": { + kind: "fn", # native function + inputs: 2, + function: "number_mul" + }, + "/": { + kind: "fn", # native function + inputs: 2, + function: "number_div" + }, + } + }; + +def repl(env): + def xrepl: + (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | + { + value: $expenv.expr, + stop: false, + env: ($expenv.env // .env) + } | ., xrepl; + {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; + +repl(replEnv) diff --git a/impls/jq/step4_if_fn_do.jq b/impls/jq/step4_if_fn_do.jq index bccd27e71a..f4be71a23f 100644 --- a/impls/jq/step4_if_fn_do.jq +++ b/impls/jq/step4_if_fn_do.jq @@ -1,566 +1,566 @@ -include "reader"; -include "printer"; -include "utils"; -include "core"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -# Environment Functions - -def childEnv(binds; exprs): - { - parent: ., - fallback: null, - environment: [binds, exprs] | transpose | ( - . as $dot | reduce .[] as $item ( - { value: [], seen: false, name: null, idx: 0 }; - if $item[1] != null then - if .seen then - { - value: (.value[1:-1] + (.value|last[1].value += [$item[1]])), - seen: true, - name: .name - } - else - if $item[0] == "&" then - $dot[.idx+1][0] as $name | { - value: (.value + [[$name, {kind:"list", value: [$item[1]]}]]), - seen: true, - name: $name - } - else - { - value: (.value + [$item]), - seen: false, - name: null - } - end - end | (.idx |= .idx + 1) - else - if $item[0] == "&" then - $dot[.idx+1][0] as $name | { - value: (.value + [[$name, {kind:"list", value: []}]]), - seen: true, - name: $name - } - else . end - end - ) - ) | .value | map({(.[0]): .[1]}) | add - }; - -def pureChildEnv: - { - parent: ., - environment: {}, - fallback: null - }; - -def rootEnv: - { - parent: null, - fallback: null, - environment: {} - }; - -def inform_function(name): - (.names += [name]) | (.names |= unique); - -def inform_function_multi(names): - . as $dot | reduce names[] as $name( - $dot; - inform_function($name) - ); - -def env_multiset(keys; value): - (if value.kind == "function" then # multiset not allowed on atoms - value | inform_function_multi(keys) - else - value - end) as $value | { - parent: .parent, - environment: ( - .environment + (reduce keys[] as $key(.environment; .[$key] |= value)) - ), - fallback: .fallback - }; - -def env_multiset(env; keys; value): - env | env_multiset(keys; value); - -def env_set($key; $value): - (if $value.kind == "function" or $value.kind == "atom" then - # inform the function/atom of its names - ($value | - if $value.kind == "atom" then - # check if the one we have is newer - env_req(env; key) as $ours | - if $ours.last_modified > $value.last_modified then - $ours - else - # update modification timestamp - $value | .last_modified |= now - end - else - . - end) | inform_function($key) - else - $value - end) as $value | { - parent: .parent, - environment: (.environment + (.environment | .[$key] |= $value)), # merge together, as .environment[key] |= value does not work - fallback: .fallback - }; - -def env_dump_keys: - def _dump1: - .environment // {} | keys; - if . == null then [] else - if .parent == null then - ( - _dump1 + - (.fallback | env_dump_keys) - ) - else - ( - _dump1 + - (.parent | env_dump_keys) + - (.fallback | env_dump_keys) - ) - end | unique - end; - -def env_find(env): - if env.environment[.] == null then - if env.parent then - env_find(env.parent) // if env.fallback then env_find(env.fallback) else null end - else - null - end - else - env - end; - -def env_get(env): - . as $key | $key | env_find(env).environment[$key] as $value | - if $value == null then - jqmal_error("'\($key)' not found") - else - if $value.kind == "atom" then - $value.identity as $id | - $key | env_find(env.parent).environment[$key] as $possibly_newer | - if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then - $possibly_newer - else - $value - end - else - $value - end - end; - -def env_get(env; key): - key | env_get(env); - -def env_req(env; key): - key as $key | key | env_find(env).environment[$key] as $value | - if $value == null then - null - else - if $value.kind == "atom" then - $value.identity as $id | - $key | env_find(env.parent).environment[$key] as $possibly_newer | - if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then - $possibly_newer - else - $value - end - else - $value - end - end; - -def env_set(env; $key; $value): - (if $value.kind == "function" or $value.kind == "atom" then - # inform the function/atom of its names - $value | (.names += [$key]) | (.names |= unique) | - if $value.kind == "atom" then - # check if the one we have is newer - env_req(env; $key) as $ours | - if $ours.last_modified > $value.last_modified then - $ours - else - # update modification timestamp - $value | .last_modified |= now - end - else - . - end - else - $value - end) as $value | { - parent: env.parent, - environment: ((env.environment // jqmal_error("Environment empty in \(env | keys)")) + (env.environment | .[$key] |= $value)), # merge together, as env.environment[key] |= value does not work - fallback: env.fallback - }; - -def env_setfallback(env; fallback): - { - parent: env.parent, - fallback: fallback, - environment: env.environment - }; - -def addEnv(env): - { - expr: ., - env: env - }; - -def addToEnv(env; name; expr): - { - expr: expr, - env: env_set(env; name; expr) - }; - - -def wrapEnv(atoms): - { - replEnv: ., - currentEnv: ., - atoms: atoms, - isReplEnv: true - }; - -def wrapEnv(replEnv; atoms): - { - replEnv: replEnv, - currentEnv: ., - atoms: atoms, # id -> value - isReplEnv: (replEnv == .) # should we allow separate copies? - }; - -def unwrapReplEnv: - .replEnv; - -def unwrapCurrentEnv: - .currentEnv; - -def env_set6(env; key; value): - if env.isReplEnv then - env_set(env.currentEnv; key; value) | wrapEnv(env.atoms) - else - env_set(env.currentEnv; key; value) | wrapEnv(env.replEnv; env.atoms) - end; - -def env_set_(env; key; value): - if env.currentEnv != null then - env_set6(env; key; value) - else - env_set(env; key; value) - end; - -def addToEnv6(envexp; name): - envexp.expr as $value - | envexp.env as $rawEnv - | (if $rawEnv.isReplEnv then - env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.atoms) - else - env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.replEnv; $rawEnv.atoms) - end) as $newEnv - | { - expr: $value, - env: $newEnv - }; - -def addToEnv(envexp; name): - if envexp.env.replEnv != null then - addToEnv6(envexp; name) - else { - expr: envexp.expr, - env: env_set_(envexp.env; name; envexp.expr) - } end; - -def _env_remove_references(refs): - if . != null then - { - environment: (.environment | to_entries | map(select(.key as $key | refs | contains([$key]) | not)) | from_entries), - parent: (.parent | _env_remove_references(refs)), - fallback: (.fallback | _env_remove_references(refs)) - } - else . end; - -def env_remove_references(refs): - . as $env - | if has("replEnv") then - .currentEnv |= _env_remove_references(refs) - else - _env_remove_references(refs) - end; - -# Evaluation - -def arg_check(args): - if .inputs < 0 then - if (abs(.inputs) - 1) > (args | length) then - jqmal_error("Invalid number of arguments (expected at least \(abs(.inputs) - 1), got \(args|length))") - else - . - end - else if .inputs != (args|length) then - jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") - else - . - end end; - -def addFrees(newEnv; frees): - . as $env - | reduce frees[] as $free ( - $env; - . as $dot - | env_req(newEnv; $free) as $lookup - | if $lookup != null then - env_set_(.; $free; $lookup) - else - . - end) - | . as $env - | $env; - -def interpret(arguments; env; _eval): - (if $DEBUG then _debug("INTERP: \(. | pr_str(env))") else . end) | - (select(.kind == "fn") | - arg_check(arguments) | - (core_interp(arguments; env) | addEnv(env)) - ) // - (select(.kind == "function") as $fn | - # todo: arg_check - (.body | pr_str(env)) as $src | - # _debug("INTERP " + $src) | - # _debug("FREES " + ($fn.free_referencess | tostring)) | - env_setfallback((.env | addFrees(env; $fn.free_referencess)); env) | childEnv($fn.binds; arguments) as $fnEnv | - # tell it about its surroundings - (reduce $fn.free_referencess[] as $name ( - $fnEnv; - . as $env | try env_set( - .; - $name; - $name | env_get(env) | . as $xvalue - | if $xvalue.kind == "function" then - setpath(["free_referencess"]; $fn.free_referencess) - else - $xvalue - end - ) catch $env)) as $fnEnv | - # tell it about itself - env_multiset($fnEnv; $fn.names; $fn) as $fnEnv | - { - env: env_multiset($fnEnv; $fn.names; $fn), - expr: $fn.body - } - | . as $dot - # | _debug("FNEXEC " + (.expr | pr_str) + " " + (env_req($dot.env; $fn.binds[0]) | pr_str)) - | _eval - | . as $envexp - | - { - expr: .expr, - env: env - } - # | . as $dot - # | _debug("FNPOST " + (.expr | pr_str) + " " + (env_req($dot.expr.env; $fn.binds[0]) | pr_str)) - # | _debug("INTERP " + $src + " = " + (.expr|pr_str)) - ) // - jqmal_error("Unsupported function kind \(.kind)"); - -def recurseflip(x; y): - recurse(y; x); - -def TCOWrap(env; retenv; continue): - { - ast: ., - env: env, - ret_env: retenv, - finish: (continue | not), - cont: true # set inside - }; - -def EVAL(env): - def _eval_here: - .env as $env | .expr | EVAL($env); - - def hmap_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem[1] | EVAL($env) as $resv | - { value: [$elem[0], $resv.expr], env: env }, - ({env: $resv.env, list: $rest} | hmap_with_env) - end; - def map_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem | EVAL($env) as $resv | - { value: $resv.expr, env: env }, - ({env: $resv.env, list: $rest} | map_with_env) - end; - (select(.kind == "list") | - if .value | length == 0 then - . | addEnv(env) - else - ( - ( - .value | select(.[0].value == "def!") as $value | - ($value[2] | EVAL(env)) as $evval | - addToEnv($evval; $value[1].value) - ) // - ( - .value | select(.[0].value == "let*") as $value | - (env | pureChildEnv) as $subenv | - (reduce ($value[1].value | nwise(2)) as $xvalue ( - $subenv; - . as $env | $xvalue[1] | EVAL($env) as $expenv | - env_set($expenv.env; $xvalue[0].value; $expenv.expr))) as $env - | $value[2] | { expr: EVAL($env).expr, env: env } - ) // - ( - .value | select(.[0].value == "do") as $value | - (reduce ($value[1:][]) as $xvalue ( - { env: env, expr: {kind:"nil"} }; - .env as $env | $xvalue | EVAL($env) - )) - ) // - ( - .value | select(.[0].value == "if") as $value | - $value[1] | EVAL(env) as $condenv | - if (["false", "nil"] | contains([$condenv.expr.kind])) then - ($value[3] // {kind:"nil"}) | EVAL($condenv.env) - else - $value[2] | EVAL($condenv.env) - end - ) // - ( - .value | select(.[0].value == "fn*") as $value | - # we can't do what the guide says, so we'll skip over this - # and ues the later implementation - # (fn* args body) - $value[1].value | map(.value) as $binds | { - kind: "function", - binds: $binds, - env: env, - body: $value[2], - names: [], # we can't do that circular reference thing - free_referencess: $value[2] | find_free_references(env | env_dump_keys + $binds) # for dynamically scoped variables - } | addEnv(env) - ) // - ( - reduce .value[] as $elem ( - []; - . as $dot | $elem | EVAL(env) as $eval_env | - ($dot + [$eval_env.expr]) - ) | { expr: ., env: env } as $ev - | $ev.expr | first | - interpret($ev.expr[1:]; $ev.env; _eval_here) - ) // - addEnv(env) - ) - end - ) // - (select(.kind == "vector") | - if .value|length == 0 then - { - kind: "vector", - value: [] - } | addEnv(env) - else - [ { env: env, list: .value } | map_with_env ] as $res | - { - kind: "vector", - value: $res | map(.value) - } | addEnv($res | last.env) - end - ) // - (select(.kind == "hashmap") | - [ { env: env, list: .value | to_entries } | hmap_with_env ] as $res | - { - kind: "hashmap", - value: $res | map(.value) | from_entries - } | addEnv($res | last.env) - ) // - (select(.kind == "function") | - . | addEnv(env) # return this unchanged, since it can only be applied to - ) // - (select(.kind == "symbol") | - .value | env_get(env) | addEnv(env) - ) // addEnv(env); - -def PRINT: - pr_str; - -def rep(env): - READ | EVAL(env) as $expenv | - if $expenv.expr != null then - $expenv.expr | PRINT - else - null - end | addEnv($expenv.env); - -def repl_(env): - ("user> " | _print) | - (read_line | rep(env)); - -# we don't have no indirect functions, so we'll have to interpret the old way -def replEnv: - { - parent: null, - environment: ({ - "+": { - kind: "fn", # native function - inputs: 2, - function: "number_add" - }, - "-": { - kind: "fn", # native function - inputs: 2, - function: "number_sub" - }, - "*": { - kind: "fn", # native function - inputs: 2, - function: "number_mul" - }, - "/": { - kind: "fn", # native function - inputs: 2, - function: "number_div" - }, - } + core_identify), - fallback: null - }; - -def repl(env): - def xrepl: - (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | - { - value: $expenv.expr, - stop: false, - env: ($expenv.env // .env) - } | ., xrepl; - {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; - -repl( - "(def! not (fn* (a) (if a false true)))" | rep(replEnv) | .env -) +include "reader"; +include "printer"; +include "utils"; +include "core"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +# Environment Functions + +def childEnv(binds; exprs): + { + parent: ., + fallback: null, + environment: [binds, exprs] | transpose | ( + . as $dot | reduce .[] as $item ( + { value: [], seen: false, name: null, idx: 0 }; + if $item[1] != null then + if .seen then + { + value: (.value[1:-1] + (.value|last[1].value += [$item[1]])), + seen: true, + name: .name + } + else + if $item[0] == "&" then + $dot[.idx+1][0] as $name | { + value: (.value + [[$name, {kind:"list", value: [$item[1]]}]]), + seen: true, + name: $name + } + else + { + value: (.value + [$item]), + seen: false, + name: null + } + end + end | (.idx |= .idx + 1) + else + if $item[0] == "&" then + $dot[.idx+1][0] as $name | { + value: (.value + [[$name, {kind:"list", value: []}]]), + seen: true, + name: $name + } + else . end + end + ) + ) | .value | map({(.[0]): .[1]}) | add + }; + +def pureChildEnv: + { + parent: ., + environment: {}, + fallback: null + }; + +def rootEnv: + { + parent: null, + fallback: null, + environment: {} + }; + +def inform_function(name): + (.names += [name]) | (.names |= unique); + +def inform_function_multi(names): + . as $dot | reduce names[] as $name( + $dot; + inform_function($name) + ); + +def env_multiset(keys; value): + (if value.kind == "function" then # multiset not allowed on atoms + value | inform_function_multi(keys) + else + value + end) as $value | { + parent: .parent, + environment: ( + .environment + (reduce keys[] as $key(.environment; .[$key] |= value)) + ), + fallback: .fallback + }; + +def env_multiset(env; keys; value): + env | env_multiset(keys; value); + +def env_set($key; $value): + (if $value.kind == "function" or $value.kind == "atom" then + # inform the function/atom of its names + ($value | + if $value.kind == "atom" then + # check if the one we have is newer + env_req(env; key) as $ours | + if $ours.last_modified > $value.last_modified then + $ours + else + # update modification timestamp + $value | .last_modified |= now + end + else + . + end) | inform_function($key) + else + $value + end) as $value | { + parent: .parent, + environment: (.environment + (.environment | .[$key] |= $value)), # merge together, as .environment[key] |= value does not work + fallback: .fallback + }; + +def env_dump_keys: + def _dump1: + .environment // {} | keys; + if . == null then [] else + if .parent == null then + ( + _dump1 + + (.fallback | env_dump_keys) + ) + else + ( + _dump1 + + (.parent | env_dump_keys) + + (.fallback | env_dump_keys) + ) + end | unique + end; + +def env_find(env): + if env.environment[.] == null then + if env.parent then + env_find(env.parent) // if env.fallback then env_find(env.fallback) else null end + else + null + end + else + env + end; + +def env_get(env): + . as $key | $key | env_find(env).environment[$key] as $value | + if $value == null then + jqmal_error("'\($key)' not found") + else + if $value.kind == "atom" then + $value.identity as $id | + $key | env_find(env.parent).environment[$key] as $possibly_newer | + if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then + $possibly_newer + else + $value + end + else + $value + end + end; + +def env_get(env; key): + key | env_get(env); + +def env_req(env; key): + key as $key | key | env_find(env).environment[$key] as $value | + if $value == null then + null + else + if $value.kind == "atom" then + $value.identity as $id | + $key | env_find(env.parent).environment[$key] as $possibly_newer | + if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then + $possibly_newer + else + $value + end + else + $value + end + end; + +def env_set(env; $key; $value): + (if $value.kind == "function" or $value.kind == "atom" then + # inform the function/atom of its names + $value | (.names += [$key]) | (.names |= unique) | + if $value.kind == "atom" then + # check if the one we have is newer + env_req(env; $key) as $ours | + if $ours.last_modified > $value.last_modified then + $ours + else + # update modification timestamp + $value | .last_modified |= now + end + else + . + end + else + $value + end) as $value | { + parent: env.parent, + environment: ((env.environment // jqmal_error("Environment empty in \(env | keys)")) + (env.environment | .[$key] |= $value)), # merge together, as env.environment[key] |= value does not work + fallback: env.fallback + }; + +def env_setfallback(env; fallback): + { + parent: env.parent, + fallback: fallback, + environment: env.environment + }; + +def addEnv(env): + { + expr: ., + env: env + }; + +def addToEnv(env; name; expr): + { + expr: expr, + env: env_set(env; name; expr) + }; + + +def wrapEnv(atoms): + { + replEnv: ., + currentEnv: ., + atoms: atoms, + isReplEnv: true + }; + +def wrapEnv(replEnv; atoms): + { + replEnv: replEnv, + currentEnv: ., + atoms: atoms, # id -> value + isReplEnv: (replEnv == .) # should we allow separate copies? + }; + +def unwrapReplEnv: + .replEnv; + +def unwrapCurrentEnv: + .currentEnv; + +def env_set6(env; key; value): + if env.isReplEnv then + env_set(env.currentEnv; key; value) | wrapEnv(env.atoms) + else + env_set(env.currentEnv; key; value) | wrapEnv(env.replEnv; env.atoms) + end; + +def env_set_(env; key; value): + if env.currentEnv != null then + env_set6(env; key; value) + else + env_set(env; key; value) + end; + +def addToEnv6(envexp; name): + envexp.expr as $value + | envexp.env as $rawEnv + | (if $rawEnv.isReplEnv then + env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.atoms) + else + env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.replEnv; $rawEnv.atoms) + end) as $newEnv + | { + expr: $value, + env: $newEnv + }; + +def addToEnv(envexp; name): + if envexp.env.replEnv != null then + addToEnv6(envexp; name) + else { + expr: envexp.expr, + env: env_set_(envexp.env; name; envexp.expr) + } end; + +def _env_remove_references(refs): + if . != null then + { + environment: (.environment | to_entries | map(select(.key as $key | refs | contains([$key]) | not)) | from_entries), + parent: (.parent | _env_remove_references(refs)), + fallback: (.fallback | _env_remove_references(refs)) + } + else . end; + +def env_remove_references(refs): + . as $env + | if has("replEnv") then + .currentEnv |= _env_remove_references(refs) + else + _env_remove_references(refs) + end; + +# Evaluation + +def arg_check(args): + if .inputs < 0 then + if (abs(.inputs) - 1) > (args | length) then + jqmal_error("Invalid number of arguments (expected at least \(abs(.inputs) - 1), got \(args|length))") + else + . + end + else if .inputs != (args|length) then + jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") + else + . + end end; + +def addFrees(newEnv; frees): + . as $env + | reduce frees[] as $free ( + $env; + . as $dot + | env_req(newEnv; $free) as $lookup + | if $lookup != null then + env_set_(.; $free; $lookup) + else + . + end) + | . as $env + | $env; + +def interpret(arguments; env; _eval): + (if $DEBUG then _debug("INTERP: \(. | pr_str(env))") else . end) | + (select(.kind == "fn") | + arg_check(arguments) | + (core_interp(arguments; env) | addEnv(env)) + ) // + (select(.kind == "function") as $fn | + # todo: arg_check + (.body | pr_str(env)) as $src | + # _debug("INTERP " + $src) | + # _debug("FREES " + ($fn.free_referencess | tostring)) | + env_setfallback((.env | addFrees(env; $fn.free_referencess)); env) | childEnv($fn.binds; arguments) as $fnEnv | + # tell it about its surroundings + (reduce $fn.free_referencess[] as $name ( + $fnEnv; + . as $env | try env_set( + .; + $name; + $name | env_get(env) | . as $xvalue + | if $xvalue.kind == "function" then + setpath(["free_referencess"]; $fn.free_referencess) + else + $xvalue + end + ) catch $env)) as $fnEnv | + # tell it about itself + env_multiset($fnEnv; $fn.names; $fn) as $fnEnv | + { + env: env_multiset($fnEnv; $fn.names; $fn), + expr: $fn.body + } + | . as $dot + # | _debug("FNEXEC " + (.expr | pr_str) + " " + (env_req($dot.env; $fn.binds[0]) | pr_str)) + | _eval + | . as $envexp + | + { + expr: .expr, + env: env + } + # | . as $dot + # | _debug("FNPOST " + (.expr | pr_str) + " " + (env_req($dot.expr.env; $fn.binds[0]) | pr_str)) + # | _debug("INTERP " + $src + " = " + (.expr|pr_str)) + ) // + jqmal_error("Unsupported function kind \(.kind)"); + +def recurseflip(x; y): + recurse(y; x); + +def TCOWrap(env; retenv; continue): + { + ast: ., + env: env, + ret_env: retenv, + finish: (continue | not), + cont: true # set inside + }; + +def EVAL(env): + def _eval_here: + .env as $env | .expr | EVAL($env); + + def hmap_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem[1] | EVAL($env) as $resv | + { value: [$elem[0], $resv.expr], env: env }, + ({env: $resv.env, list: $rest} | hmap_with_env) + end; + def map_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem | EVAL($env) as $resv | + { value: $resv.expr, env: env }, + ({env: $resv.env, list: $rest} | map_with_env) + end; + (select(.kind == "list") | + if .value | length == 0 then + . | addEnv(env) + else + ( + ( + .value | select(.[0].value == "def!") as $value | + ($value[2] | EVAL(env)) as $evval | + addToEnv($evval; $value[1].value) + ) // + ( + .value | select(.[0].value == "let*") as $value | + (env | pureChildEnv) as $subenv | + (reduce ($value[1].value | nwise(2)) as $xvalue ( + $subenv; + . as $env | $xvalue[1] | EVAL($env) as $expenv | + env_set($expenv.env; $xvalue[0].value; $expenv.expr))) as $env + | $value[2] | { expr: EVAL($env).expr, env: env } + ) // + ( + .value | select(.[0].value == "do") as $value | + (reduce ($value[1:][]) as $xvalue ( + { env: env, expr: {kind:"nil"} }; + .env as $env | $xvalue | EVAL($env) + )) + ) // + ( + .value | select(.[0].value == "if") as $value | + $value[1] | EVAL(env) as $condenv | + if (["false", "nil"] | contains([$condenv.expr.kind])) then + ($value[3] // {kind:"nil"}) | EVAL($condenv.env) + else + $value[2] | EVAL($condenv.env) + end + ) // + ( + .value | select(.[0].value == "fn*") as $value | + # we can't do what the guide says, so we'll skip over this + # and ues the later implementation + # (fn* args body) + $value[1].value | map(.value) as $binds | { + kind: "function", + binds: $binds, + env: env, + body: $value[2], + names: [], # we can't do that circular reference thing + free_referencess: $value[2] | find_free_references(env | env_dump_keys + $binds) # for dynamically scoped variables + } | addEnv(env) + ) // + ( + reduce .value[] as $elem ( + []; + . as $dot | $elem | EVAL(env) as $eval_env | + ($dot + [$eval_env.expr]) + ) | { expr: ., env: env } as $ev + | $ev.expr | first | + interpret($ev.expr[1:]; $ev.env; _eval_here) + ) // + addEnv(env) + ) + end + ) // + (select(.kind == "vector") | + if .value|length == 0 then + { + kind: "vector", + value: [] + } | addEnv(env) + else + [ { env: env, list: .value } | map_with_env ] as $res | + { + kind: "vector", + value: $res | map(.value) + } | addEnv($res | last.env) + end + ) // + (select(.kind == "hashmap") | + [ { env: env, list: .value | to_entries } | hmap_with_env ] as $res | + { + kind: "hashmap", + value: $res | map(.value) | from_entries + } | addEnv($res | last.env) + ) // + (select(.kind == "function") | + . | addEnv(env) # return this unchanged, since it can only be applied to + ) // + (select(.kind == "symbol") | + .value | env_get(env) | addEnv(env) + ) // addEnv(env); + +def PRINT: + pr_str; + +def rep(env): + READ | EVAL(env) as $expenv | + if $expenv.expr != null then + $expenv.expr | PRINT + else + null + end | addEnv($expenv.env); + +def repl_(env): + ("user> " | _print) | + (read_line | rep(env)); + +# we don't have no indirect functions, so we'll have to interpret the old way +def replEnv: + { + parent: null, + environment: ({ + "+": { + kind: "fn", # native function + inputs: 2, + function: "number_add" + }, + "-": { + kind: "fn", # native function + inputs: 2, + function: "number_sub" + }, + "*": { + kind: "fn", # native function + inputs: 2, + function: "number_mul" + }, + "/": { + kind: "fn", # native function + inputs: 2, + function: "number_div" + }, + } + core_identify), + fallback: null + }; + +def repl(env): + def xrepl: + (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | + { + value: $expenv.expr, + stop: false, + env: ($expenv.env // .env) + } | ., xrepl; + {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; + +repl( + "(def! not (fn* (a) (if a false true)))" | rep(replEnv) | .env +) diff --git a/impls/jq/step5_tco.jq b/impls/jq/step5_tco.jq index c2053e30d7..f4957f3336 100644 --- a/impls/jq/step5_tco.jq +++ b/impls/jq/step5_tco.jq @@ -1,582 +1,582 @@ -include "reader"; -include "printer"; -include "utils"; -include "core"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -# Environment Functions - -def childEnv(binds; exprs): - { - parent: ., - fallback: null, - environment: [binds, exprs] | transpose | ( - . as $dot | reduce .[] as $item ( - { value: [], seen: false, name: null, idx: 0 }; - if $item[1] != null then - if .seen then - { - value: (.value[1:-1] + (.value|last[1].value += [$item[1]])), - seen: true, - name: .name - } - else - if $item[0] == "&" then - $dot[.idx+1][0] as $name | { - value: (.value + [[$name, {kind:"list", value: [$item[1]]}]]), - seen: true, - name: $name - } - else - { - value: (.value + [$item]), - seen: false, - name: null - } - end - end | (.idx |= .idx + 1) - else - if $item[0] == "&" then - $dot[.idx+1][0] as $name | { - value: (.value + [[$name, {kind:"list", value: []}]]), - seen: true, - name: $name - } - else . end - end - ) - ) | .value | map({(.[0]): .[1]}) | add - }; - -def pureChildEnv: - { - parent: ., - environment: {}, - fallback: null - }; - -def rootEnv: - { - parent: null, - fallback: null, - environment: {} - }; - -def inform_function(name): - (.names += [name]) | (.names |= unique); - -def inform_function_multi(names): - . as $dot | reduce names[] as $name( - $dot; - inform_function($name) - ); - -def env_multiset(keys; value): - (if value.kind == "function" then # multiset not allowed on atoms - value | inform_function_multi(keys) - else - value - end) as $value | { - parent: .parent, - environment: ( - .environment + (reduce keys[] as $key(.environment; .[$key] |= value)) - ), - fallback: .fallback - }; - -def env_multiset(env; keys; value): - env | env_multiset(keys; value); - -def env_set($key; $value): - (if $value.kind == "function" or $value.kind == "atom" then - # inform the function/atom of its names - ($value | - if $value.kind == "atom" then - # check if the one we have is newer - env_req(env; key) as $ours | - if $ours.last_modified > $value.last_modified then - $ours - else - # update modification timestamp - $value | .last_modified |= now - end - else - . - end) | inform_function($key) - else - $value - end) as $value | { - parent: .parent, - environment: (.environment + (.environment | .[$key] |= $value)), # merge together, as .environment[key] |= value does not work - fallback: .fallback - }; - -def env_dump_keys: - def _dump1: - .environment // {} | keys; - if . == null then [] else - if .parent == null then - ( - _dump1 + - (.fallback | env_dump_keys) - ) - else - ( - _dump1 + - (.parent | env_dump_keys) + - (.fallback | env_dump_keys) - ) - end | unique - end; - -def env_find(env): - if env.environment[.] == null then - if env.parent then - env_find(env.parent) // if env.fallback then env_find(env.fallback) else null end - else - null - end - else - env - end; - -def env_get(env): - . as $key | $key | env_find(env).environment[$key] as $value | - if $value == null then - jqmal_error("'\($key)' not found") - else - if $value.kind == "atom" then - $value.identity as $id | - $key | env_find(env.parent).environment[$key] as $possibly_newer | - if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then - $possibly_newer - else - $value - end - else - $value - end - end; - -def env_get(env; key): - key | env_get(env); - -def env_req(env; key): - key as $key | key | env_find(env).environment[$key] as $value | - if $value == null then - null - else - if $value.kind == "atom" then - $value.identity as $id | - $key | env_find(env.parent).environment[$key] as $possibly_newer | - if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then - $possibly_newer - else - $value - end - else - $value - end - end; - -def env_set(env; $key; $value): - (if $value.kind == "function" or $value.kind == "atom" then - # inform the function/atom of its names - $value | (.names += [$key]) | (.names |= unique) | - if $value.kind == "atom" then - # check if the one we have is newer - env_req(env; $key) as $ours | - if $ours.last_modified > $value.last_modified then - $ours - else - # update modification timestamp - $value | .last_modified |= now - end - else - . - end - else - $value - end) as $value | { - parent: env.parent, - environment: ((env.environment // jqmal_error("Environment empty in \(env | keys)")) + (env.environment | .[$key] |= $value)), # merge together, as env.environment[key] |= value does not work - fallback: env.fallback - }; - -def env_setfallback(env; fallback): - { - parent: env.parent, - fallback: fallback, - environment: env.environment - }; - -def addEnv(env): - { - expr: ., - env: env - }; - -def addToEnv(env; name; expr): - { - expr: expr, - env: env_set(env; name; expr) - }; - - -def wrapEnv(atoms): - { - replEnv: ., - currentEnv: ., - atoms: atoms, - isReplEnv: true - }; - -def wrapEnv(replEnv; atoms): - { - replEnv: replEnv, - currentEnv: ., - atoms: atoms, # id -> value - isReplEnv: (replEnv == .) # should we allow separate copies? - }; - -def unwrapReplEnv: - .replEnv; - -def unwrapCurrentEnv: - .currentEnv; - -def env_set6(env; key; value): - if env.isReplEnv then - env_set(env.currentEnv; key; value) | wrapEnv(env.atoms) - else - env_set(env.currentEnv; key; value) | wrapEnv(env.replEnv; env.atoms) - end; - -def env_set_(env; key; value): - if env.currentEnv != null then - env_set6(env; key; value) - else - env_set(env; key; value) - end; - -def addToEnv6(envexp; name): - envexp.expr as $value - | envexp.env as $rawEnv - | (if $rawEnv.isReplEnv then - env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.atoms) - else - env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.replEnv; $rawEnv.atoms) - end) as $newEnv - | { - expr: $value, - env: $newEnv - }; - -def addToEnv(envexp; name): - if envexp.env.replEnv != null then - addToEnv6(envexp; name) - else { - expr: envexp.expr, - env: env_set_(envexp.env; name; envexp.expr) - } end; - -def _env_remove_references(refs): - if . != null then - { - environment: (.environment | to_entries | map(select(.key as $key | refs | contains([$key]) | not)) | from_entries), - parent: (.parent | _env_remove_references(refs)), - fallback: (.fallback | _env_remove_references(refs)) - } - else . end; - -def env_remove_references(refs): - . as $env - | if has("replEnv") then - .currentEnv |= _env_remove_references(refs) - else - _env_remove_references(refs) - end; - -# Evaluation - -def arg_check(args): - if .inputs < 0 then - if (abs(.inputs) - 1) > (args | length) then - jqmal_error("Invalid number of arguments (expected at least \(abs(.inputs) - 1), got \(args|length))") - else - . - end - else if .inputs != (args|length) then - jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") - else - . - end end; - -def addFrees(newEnv; frees): - . as $env - | reduce frees[] as $free ( - $env; - . as $dot - | env_req(newEnv; $free) as $lookup - | if $lookup != null then - env_set_(.; $free; $lookup) - else - . - end) - | . as $env - | $env; - -def interpret(arguments; env; _eval): - (if $DEBUG then _debug("INTERP: \(. | pr_str(env))") else . end) | - (select(.kind == "fn") | - arg_check(arguments) | - (core_interp(arguments; env) | addEnv(env)) - ) // - (select(.kind == "function") as $fn | - # todo: arg_check - (.body | pr_str(env)) as $src | - # _debug("INTERP " + $src) | - # _debug("FREES " + ($fn.free_referencess | tostring)) | - env_setfallback((.env | addFrees(env; $fn.free_referencess)); env) | childEnv($fn.binds; arguments) as $fnEnv | - # tell it about its surroundings - (reduce $fn.free_referencess[] as $name ( - $fnEnv; - . as $env | try env_set( - .; - $name; - $name | env_get(env) | . as $xvalue - | if $xvalue.kind == "function" then - setpath(["free_referencess"]; $fn.free_referencess) - else - $xvalue - end - ) catch $env)) as $fnEnv | - # tell it about itself - env_multiset($fnEnv; $fn.names; $fn) as $fnEnv | - { - env: env_multiset($fnEnv; $fn.names; $fn), - expr: $fn.body - } - | . as $dot - # | _debug("FNEXEC " + (.expr | pr_str) + " " + (env_req($dot.env; $fn.binds[0]) | pr_str)) - | _eval - | . as $envexp - | - { - expr: .expr, - env: env - } - # | . as $dot - # | _debug("FNPOST " + (.expr | pr_str) + " " + (env_req($dot.expr.env; $fn.binds[0]) | pr_str)) - # | _debug("INTERP " + $src + " = " + (.expr|pr_str)) - ) // - jqmal_error("Unsupported function kind \(.kind)"); - -def recurseflip(x; y): - recurse(y; x); - -def TCOWrap(env; retenv; continue): - { - ast: ., - env: env, - ret_env: retenv, - finish: (continue | not), - cont: true # set inside - }; - -def EVAL(env): - def _eval_here: - .env as $env | .expr | EVAL($env); - - def hmap_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem[1] | EVAL($env) as $resv | - { value: [$elem[0], $resv.expr], env: env }, - ({env: $resv.env, list: $rest} | hmap_with_env) - end; - def map_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem | EVAL($env) as $resv | - { value: $resv.expr, env: env }, - ({env: $resv.env, list: $rest} | map_with_env) - end; - . as $ast - | { env: env, ast: ., cont: true, finish: false, ret_env: null } - | [ recurseflip(.cont; - .env as $_menv - | if .finish then - .cont |= false - else - (.ret_env//.env) as $_retenv - | .ret_env as $_orig_retenv - | .ast - | - (select(.kind == "list") | - if .value | length == 0 then - . | TCOWrap($_menv; $_orig_retenv; false) - else - ( - ( - .value | select(.[0].value == "def!") as $value | - ($value[2] | EVAL($_menv)) as $evval | - addToEnv($evval; $value[1].value) as $val | - $val.expr | TCOWrap($val.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "let*") as $value | - ($_menv | pureChildEnv) as $subenv | - (reduce ($value[1].value | nwise(2)) as $xvalue ( - $subenv; - . as $env | $xvalue[1] | EVAL($env) as $expenv | - env_set($expenv.env; $xvalue[0].value; $expenv.expr))) as $env - | $value[2] | TCOWrap($env; $_retenv; true) - ) // - ( - .value | select(.[0].value == "do") as $value | - (reduce ($value[1:][]) as $xvalue ( - { env: $_menv, expr: {kind:"nil"} }; - .env as $env | $xvalue | EVAL($env) - )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "if") as $value | - $value[1] | EVAL(env) as $condenv | - (if (["false", "nil"] | contains([$condenv.expr.kind])) then - ($value[3] // {kind:"nil"}) - else - $value[2] - end) | TCOWrap($condenv.env; $_orig_retenv; true) - ) // - ( - .value | select(.[0].value == "fn*") as $value | - # (fn* args body) - $value[1].value | map(.value) as $binds | { - kind: "function", - binds: $binds, - env: $_menv, - body: $value[2], - names: [], # we can't do that circular reference thing - free_referencess: $value[2] | find_free_references($_menv | env_dump_keys + $binds) # for dynamically scoped variables - } | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - reduce .value[] as $elem ( - []; - . as $dot | $elem | EVAL($_menv) as $eval_env | - ($dot + [$eval_env.expr]) - ) | . as $expr | first | - interpret($expr[1:]; $_menv; _eval_here) as $exprenv | - $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) - ) // - TCOWrap($_menv; $_orig_retenv; false) - ) - end - ) // - (select(.kind == "vector") | - if .value|length == 0 then - { - kind: "vector", - value: [] - } | TCOWrap($_menv; $_orig_retenv; false) - else - [ { env: $_menv, list: .value } | map_with_env ] as $res | - { - kind: "vector", - value: $res | map(.value) - } | TCOWrap($res | last.env; $_orig_retenv; false) - end - ) // - (select(.kind == "hashmap") | - [ { env: $_menv, list: .value | to_entries } | hmap_with_env ] as $res | - { - kind: "hashmap", - value: $res | map(.value) | from_entries - } | TCOWrap($res | last.env; $_orig_retenv; false) - ) // - (select(.kind == "function") | - . | TCOWrap($_menv; $_orig_retenv; false) # return this unchanged, since it can only be applied to - ) // - (select(.kind == "symbol") | - .value | env_get($_menv) | TCOWrap($_menv; null; false) - ) // TCOWrap($_menv; $_orig_retenv; false) - end - ) ] - | last as $result - | ($result.ret_env // $result.env) as $env - | $result.ast - | addEnv($env); - -def PRINT: - pr_str; - -def rep(env): - READ | EVAL(env) as $expenv | - if $expenv.expr != null then - $expenv.expr | PRINT - else - null - end | addEnv($expenv.env); - -def repl_(env): - ("user> " | _print) | - (read_line | rep(env)); - -# we don't have no indirect functions, so we'll have to interpret the old way -def replEnv: - { - parent: null, - environment: ({ - "+": { - kind: "fn", # native function - inputs: 2, - function: "number_add" - }, - "-": { - kind: "fn", # native function - inputs: 2, - function: "number_sub" - }, - "*": { - kind: "fn", # native function - inputs: 2, - function: "number_mul" - }, - "/": { - kind: "fn", # native function - inputs: 2, - function: "number_div" - }, - } + core_identify), - fallback: null - }; - -def repl(env): - def xrepl: - (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | - { - value: $expenv.expr, - stop: false, - env: ($expenv.env // .env) - } | ., xrepl; - {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; - -repl( - "(def! not (fn* (a) (if a false true)))" | rep(replEnv) | .env -) +include "reader"; +include "printer"; +include "utils"; +include "core"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +# Environment Functions + +def childEnv(binds; exprs): + { + parent: ., + fallback: null, + environment: [binds, exprs] | transpose | ( + . as $dot | reduce .[] as $item ( + { value: [], seen: false, name: null, idx: 0 }; + if $item[1] != null then + if .seen then + { + value: (.value[1:-1] + (.value|last[1].value += [$item[1]])), + seen: true, + name: .name + } + else + if $item[0] == "&" then + $dot[.idx+1][0] as $name | { + value: (.value + [[$name, {kind:"list", value: [$item[1]]}]]), + seen: true, + name: $name + } + else + { + value: (.value + [$item]), + seen: false, + name: null + } + end + end | (.idx |= .idx + 1) + else + if $item[0] == "&" then + $dot[.idx+1][0] as $name | { + value: (.value + [[$name, {kind:"list", value: []}]]), + seen: true, + name: $name + } + else . end + end + ) + ) | .value | map({(.[0]): .[1]}) | add + }; + +def pureChildEnv: + { + parent: ., + environment: {}, + fallback: null + }; + +def rootEnv: + { + parent: null, + fallback: null, + environment: {} + }; + +def inform_function(name): + (.names += [name]) | (.names |= unique); + +def inform_function_multi(names): + . as $dot | reduce names[] as $name( + $dot; + inform_function($name) + ); + +def env_multiset(keys; value): + (if value.kind == "function" then # multiset not allowed on atoms + value | inform_function_multi(keys) + else + value + end) as $value | { + parent: .parent, + environment: ( + .environment + (reduce keys[] as $key(.environment; .[$key] |= value)) + ), + fallback: .fallback + }; + +def env_multiset(env; keys; value): + env | env_multiset(keys; value); + +def env_set($key; $value): + (if $value.kind == "function" or $value.kind == "atom" then + # inform the function/atom of its names + ($value | + if $value.kind == "atom" then + # check if the one we have is newer + env_req(env; key) as $ours | + if $ours.last_modified > $value.last_modified then + $ours + else + # update modification timestamp + $value | .last_modified |= now + end + else + . + end) | inform_function($key) + else + $value + end) as $value | { + parent: .parent, + environment: (.environment + (.environment | .[$key] |= $value)), # merge together, as .environment[key] |= value does not work + fallback: .fallback + }; + +def env_dump_keys: + def _dump1: + .environment // {} | keys; + if . == null then [] else + if .parent == null then + ( + _dump1 + + (.fallback | env_dump_keys) + ) + else + ( + _dump1 + + (.parent | env_dump_keys) + + (.fallback | env_dump_keys) + ) + end | unique + end; + +def env_find(env): + if env.environment[.] == null then + if env.parent then + env_find(env.parent) // if env.fallback then env_find(env.fallback) else null end + else + null + end + else + env + end; + +def env_get(env): + . as $key | $key | env_find(env).environment[$key] as $value | + if $value == null then + jqmal_error("'\($key)' not found") + else + if $value.kind == "atom" then + $value.identity as $id | + $key | env_find(env.parent).environment[$key] as $possibly_newer | + if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then + $possibly_newer + else + $value + end + else + $value + end + end; + +def env_get(env; key): + key | env_get(env); + +def env_req(env; key): + key as $key | key | env_find(env).environment[$key] as $value | + if $value == null then + null + else + if $value.kind == "atom" then + $value.identity as $id | + $key | env_find(env.parent).environment[$key] as $possibly_newer | + if $possibly_newer.identity == $id and $possibly_newer.last_modified > $value.last_modified then + $possibly_newer + else + $value + end + else + $value + end + end; + +def env_set(env; $key; $value): + (if $value.kind == "function" or $value.kind == "atom" then + # inform the function/atom of its names + $value | (.names += [$key]) | (.names |= unique) | + if $value.kind == "atom" then + # check if the one we have is newer + env_req(env; $key) as $ours | + if $ours.last_modified > $value.last_modified then + $ours + else + # update modification timestamp + $value | .last_modified |= now + end + else + . + end + else + $value + end) as $value | { + parent: env.parent, + environment: ((env.environment // jqmal_error("Environment empty in \(env | keys)")) + (env.environment | .[$key] |= $value)), # merge together, as env.environment[key] |= value does not work + fallback: env.fallback + }; + +def env_setfallback(env; fallback): + { + parent: env.parent, + fallback: fallback, + environment: env.environment + }; + +def addEnv(env): + { + expr: ., + env: env + }; + +def addToEnv(env; name; expr): + { + expr: expr, + env: env_set(env; name; expr) + }; + + +def wrapEnv(atoms): + { + replEnv: ., + currentEnv: ., + atoms: atoms, + isReplEnv: true + }; + +def wrapEnv(replEnv; atoms): + { + replEnv: replEnv, + currentEnv: ., + atoms: atoms, # id -> value + isReplEnv: (replEnv == .) # should we allow separate copies? + }; + +def unwrapReplEnv: + .replEnv; + +def unwrapCurrentEnv: + .currentEnv; + +def env_set6(env; key; value): + if env.isReplEnv then + env_set(env.currentEnv; key; value) | wrapEnv(env.atoms) + else + env_set(env.currentEnv; key; value) | wrapEnv(env.replEnv; env.atoms) + end; + +def env_set_(env; key; value): + if env.currentEnv != null then + env_set6(env; key; value) + else + env_set(env; key; value) + end; + +def addToEnv6(envexp; name): + envexp.expr as $value + | envexp.env as $rawEnv + | (if $rawEnv.isReplEnv then + env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.atoms) + else + env_set_($rawEnv.currentEnv; name; $value) | wrapEnv($rawEnv.replEnv; $rawEnv.atoms) + end) as $newEnv + | { + expr: $value, + env: $newEnv + }; + +def addToEnv(envexp; name): + if envexp.env.replEnv != null then + addToEnv6(envexp; name) + else { + expr: envexp.expr, + env: env_set_(envexp.env; name; envexp.expr) + } end; + +def _env_remove_references(refs): + if . != null then + { + environment: (.environment | to_entries | map(select(.key as $key | refs | contains([$key]) | not)) | from_entries), + parent: (.parent | _env_remove_references(refs)), + fallback: (.fallback | _env_remove_references(refs)) + } + else . end; + +def env_remove_references(refs): + . as $env + | if has("replEnv") then + .currentEnv |= _env_remove_references(refs) + else + _env_remove_references(refs) + end; + +# Evaluation + +def arg_check(args): + if .inputs < 0 then + if (abs(.inputs) - 1) > (args | length) then + jqmal_error("Invalid number of arguments (expected at least \(abs(.inputs) - 1), got \(args|length))") + else + . + end + else if .inputs != (args|length) then + jqmal_error("Invalid number of arguments (expected \(.inputs), got \(args|length))") + else + . + end end; + +def addFrees(newEnv; frees): + . as $env + | reduce frees[] as $free ( + $env; + . as $dot + | env_req(newEnv; $free) as $lookup + | if $lookup != null then + env_set_(.; $free; $lookup) + else + . + end) + | . as $env + | $env; + +def interpret(arguments; env; _eval): + (if $DEBUG then _debug("INTERP: \(. | pr_str(env))") else . end) | + (select(.kind == "fn") | + arg_check(arguments) | + (core_interp(arguments; env) | addEnv(env)) + ) // + (select(.kind == "function") as $fn | + # todo: arg_check + (.body | pr_str(env)) as $src | + # _debug("INTERP " + $src) | + # _debug("FREES " + ($fn.free_referencess | tostring)) | + env_setfallback((.env | addFrees(env; $fn.free_referencess)); env) | childEnv($fn.binds; arguments) as $fnEnv | + # tell it about its surroundings + (reduce $fn.free_referencess[] as $name ( + $fnEnv; + . as $env | try env_set( + .; + $name; + $name | env_get(env) | . as $xvalue + | if $xvalue.kind == "function" then + setpath(["free_referencess"]; $fn.free_referencess) + else + $xvalue + end + ) catch $env)) as $fnEnv | + # tell it about itself + env_multiset($fnEnv; $fn.names; $fn) as $fnEnv | + { + env: env_multiset($fnEnv; $fn.names; $fn), + expr: $fn.body + } + | . as $dot + # | _debug("FNEXEC " + (.expr | pr_str) + " " + (env_req($dot.env; $fn.binds[0]) | pr_str)) + | _eval + | . as $envexp + | + { + expr: .expr, + env: env + } + # | . as $dot + # | _debug("FNPOST " + (.expr | pr_str) + " " + (env_req($dot.expr.env; $fn.binds[0]) | pr_str)) + # | _debug("INTERP " + $src + " = " + (.expr|pr_str)) + ) // + jqmal_error("Unsupported function kind \(.kind)"); + +def recurseflip(x; y): + recurse(y; x); + +def TCOWrap(env; retenv; continue): + { + ast: ., + env: env, + ret_env: retenv, + finish: (continue | not), + cont: true # set inside + }; + +def EVAL(env): + def _eval_here: + .env as $env | .expr | EVAL($env); + + def hmap_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem[1] | EVAL($env) as $resv | + { value: [$elem[0], $resv.expr], env: env }, + ({env: $resv.env, list: $rest} | hmap_with_env) + end; + def map_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem | EVAL($env) as $resv | + { value: $resv.expr, env: env }, + ({env: $resv.env, list: $rest} | map_with_env) + end; + . as $ast + | { env: env, ast: ., cont: true, finish: false, ret_env: null } + | [ recurseflip(.cont; + .env as $_menv + | if .finish then + .cont |= false + else + (.ret_env//.env) as $_retenv + | .ret_env as $_orig_retenv + | .ast + | + (select(.kind == "list") | + if .value | length == 0 then + . | TCOWrap($_menv; $_orig_retenv; false) + else + ( + ( + .value | select(.[0].value == "def!") as $value | + ($value[2] | EVAL($_menv)) as $evval | + addToEnv($evval; $value[1].value) as $val | + $val.expr | TCOWrap($val.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "let*") as $value | + ($_menv | pureChildEnv) as $subenv | + (reduce ($value[1].value | nwise(2)) as $xvalue ( + $subenv; + . as $env | $xvalue[1] | EVAL($env) as $expenv | + env_set($expenv.env; $xvalue[0].value; $expenv.expr))) as $env + | $value[2] | TCOWrap($env; $_retenv; true) + ) // + ( + .value | select(.[0].value == "do") as $value | + (reduce ($value[1:][]) as $xvalue ( + { env: $_menv, expr: {kind:"nil"} }; + .env as $env | $xvalue | EVAL($env) + )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "if") as $value | + $value[1] | EVAL(env) as $condenv | + (if (["false", "nil"] | contains([$condenv.expr.kind])) then + ($value[3] // {kind:"nil"}) + else + $value[2] + end) | TCOWrap($condenv.env; $_orig_retenv; true) + ) // + ( + .value | select(.[0].value == "fn*") as $value | + # (fn* args body) + $value[1].value | map(.value) as $binds | { + kind: "function", + binds: $binds, + env: $_menv, + body: $value[2], + names: [], # we can't do that circular reference thing + free_referencess: $value[2] | find_free_references($_menv | env_dump_keys + $binds) # for dynamically scoped variables + } | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + reduce .value[] as $elem ( + []; + . as $dot | $elem | EVAL($_menv) as $eval_env | + ($dot + [$eval_env.expr]) + ) | . as $expr | first | + interpret($expr[1:]; $_menv; _eval_here) as $exprenv | + $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) + ) // + TCOWrap($_menv; $_orig_retenv; false) + ) + end + ) // + (select(.kind == "vector") | + if .value|length == 0 then + { + kind: "vector", + value: [] + } | TCOWrap($_menv; $_orig_retenv; false) + else + [ { env: $_menv, list: .value } | map_with_env ] as $res | + { + kind: "vector", + value: $res | map(.value) + } | TCOWrap($res | last.env; $_orig_retenv; false) + end + ) // + (select(.kind == "hashmap") | + [ { env: $_menv, list: .value | to_entries } | hmap_with_env ] as $res | + { + kind: "hashmap", + value: $res | map(.value) | from_entries + } | TCOWrap($res | last.env; $_orig_retenv; false) + ) // + (select(.kind == "function") | + . | TCOWrap($_menv; $_orig_retenv; false) # return this unchanged, since it can only be applied to + ) // + (select(.kind == "symbol") | + .value | env_get($_menv) | TCOWrap($_menv; null; false) + ) // TCOWrap($_menv; $_orig_retenv; false) + end + ) ] + | last as $result + | ($result.ret_env // $result.env) as $env + | $result.ast + | addEnv($env); + +def PRINT: + pr_str; + +def rep(env): + READ | EVAL(env) as $expenv | + if $expenv.expr != null then + $expenv.expr | PRINT + else + null + end | addEnv($expenv.env); + +def repl_(env): + ("user> " | _print) | + (read_line | rep(env)); + +# we don't have no indirect functions, so we'll have to interpret the old way +def replEnv: + { + parent: null, + environment: ({ + "+": { + kind: "fn", # native function + inputs: 2, + function: "number_add" + }, + "-": { + kind: "fn", # native function + inputs: 2, + function: "number_sub" + }, + "*": { + kind: "fn", # native function + inputs: 2, + function: "number_mul" + }, + "/": { + kind: "fn", # native function + inputs: 2, + function: "number_div" + }, + } + core_identify), + fallback: null + }; + +def repl(env): + def xrepl: + (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | + { + value: $expenv.expr, + stop: false, + env: ($expenv.env // .env) + } | ., xrepl; + {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; + +repl( + "(def! not (fn* (a) (if a false true)))" | rep(replEnv) | .env +) diff --git a/impls/jq/step6_file.jq b/impls/jq/step6_file.jq index 5a3076e5aa..6156793a7b 100644 --- a/impls/jq/step6_file.jq +++ b/impls/jq/step6_file.jq @@ -1,253 +1,253 @@ -include "reader"; -include "printer"; -include "utils"; -include "interp"; -include "env"; -include "core"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -def recurseflip(x; y): - recurse(y; x); - -def TCOWrap(env; retenv; continue): - { - ast: ., - env: env, - ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), - finish: (continue | not), - cont: true # set inside - }; - -def EVAL(env): - def _eval_here: - .env as $env | .expr | EVAL($env); - - def hmap_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem.value.value | EVAL($env) as $resv | - { - value: { - key: $elem.key, - value: { kkind: $elem.value.kkind, value: $resv.expr } - }, - env: env - }, - ({env: $resv.env, list: $rest} | hmap_with_env) - end; - def map_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem | EVAL($env) as $resv | - { value: $resv.expr, env: env }, - ({env: $resv.env, list: $rest} | map_with_env) - end; - . as $ast - | { env: env, ast: ., cont: true, finish: false, ret_env: null } - | [ recurseflip(.cont; - .env as $_menv - | if .finish then - .cont |= false - else - (.ret_env//.env) as $_retenv - | .ret_env as $_orig_retenv - | .ast - | . as $init - | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" - | $_menv | unwrapReplEnv as $replEnv # - - | $init - | - (select(.kind == "list") | - if .value | length == 0 then - . | TCOWrap($_menv; $_orig_retenv; false) - else - ( - ( - .value | select(.[0].value == "def!") as $value | - ($value[2] | EVAL($_menv)) as $evval | - addToEnv($evval; $value[1].value) as $val | - $val.expr | TCOWrap($val.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "let*") as $value | - ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $subenv | - (reduce ($value[1].value | nwise(2)) as $xvalue ( - $subenv; - . as $env | $xvalue[1] | EVAL($env) as $expenv | - env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) | . as $env - | $value[2] | TCOWrap($env; $_retenv; true) - ) // - ( - .value | select(.[0].value == "do") as $value | - (reduce ($value[1:][]) as $xvalue ( - { env: $_menv, expr: {kind:"nil"} }; - .env as $env | $xvalue | EVAL($env) - )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "if") as $value | - $value[1] | EVAL($_menv) as $condenv | - (if (["false", "nil"] | contains([$condenv.expr.kind])) then - ($value[3] // {kind:"nil"}) - else - $value[2] - end) | TCOWrap($condenv.env; $_orig_retenv; true) - ) // - ( - .value | select(.[0].value == "fn*") as $value | - # (fn* args body) - $value[1].value | map(.value) as $binds | - ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { - kind: "function", - binds: $binds, - env: ($_menv | env_remove_references($free_referencess)), - body: $value[2], - names: [], # we can't do that circular reference thing - free_referencess: $free_referencess # for dynamically scoped variables - } | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - reduce .value[] as $elem ( - {env: $_menv, val: []}; - . as $dot | $elem | EVAL($dot.env) as $eval_env | - ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | - {env: $_menv, val: ($dot.val + [$eval_env.expr])} - ) | . as $expr | $expr.val | first | - interpret($expr.val[1:]; $expr.env; _eval_here) as $exprenv | - $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) - ) // - TCOWrap($_menv; $_orig_retenv; false) - ) - end - ) // - (select(.kind == "vector") | - if .value|length == 0 then - { - kind: "vector", - value: [] - } | TCOWrap($_menv; $_orig_retenv; false) - else - [ { env: env, list: .value } | map_with_env ] as $res | - { - kind: "vector", - value: $res | map(.value) - } | TCOWrap($res | last.env; $_orig_retenv; false) - end - ) // - (select(.kind == "hashmap") | - [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | - { - kind: "hashmap", - value: $res | map(.value) | from_entries - } | TCOWrap($res | last.env; $_orig_retenv; false) - ) // - (select(.kind == "function") | - . | TCOWrap($_menv; $_orig_retenv; false) # return this unchanged, since it can only be applied to - ) // - (select(.kind == "symbol") | - .value | env_get($currentEnv) | TCOWrap($_menv; null; false) - ) // TCOWrap($_menv; $_orig_retenv; false) - end - ) ] - | last as $result - | ($result.ret_env // $result.env) as $env - | $result.ast - | addEnv($env); - -def PRINT(env): - pr_str(env); - -def rep(env): - READ | EVAL(env) as $expenv | - if $expenv.expr != null then - $expenv.expr | PRINT($expenv.env) - else - null - end | addEnv($expenv.env); - -def repl_(env): - ("user> " | _print) | - (read_line | rep(env)); - -# we don't have no indirect functions, so we'll have to interpret the old way -def replEnv: - { - parent: null, - environment: ({ - "+": { - kind: "fn", # native function - inputs: 2, - function: "number_add" - }, - "-": { - kind: "fn", # native function - inputs: 2, - function: "number_sub" - }, - "*": { - kind: "fn", # native function - inputs: 2, - function: "number_mul" - }, - "/": { - kind: "fn", # native function - inputs: 2, - function: "number_div" - }, - "eval": { - kind: "fn", - inputs: 1, - function: "eval" - } - } + core_identify), - fallback: null, - }; - -def repl(env): - def xrepl: - (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | - { - value: $expenv.expr, - stop: false, - env: ($expenv.env // .env) - } | ., xrepl; - {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; - -def eval_ign(expr): - . as $env | expr | rep($env) | .env; - -def eval_val(expr): - . as $env | expr | rep($env) | .expr; - -def getEnv: - replEnv - | wrapEnv({}) - | eval_ign("(def! not (fn* (a) (if a false true)))") - | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))"); - -def main: - if $ARGS.positional|length > 0 then - getEnv as $env | - env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | - eval_val("(load-file \($ARGS.positional[0] | tojson))") | - "" - else - repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) - end; - -[ main ] | _halt +include "reader"; +include "printer"; +include "utils"; +include "interp"; +include "env"; +include "core"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +def recurseflip(x; y): + recurse(y; x); + +def TCOWrap(env; retenv; continue): + { + ast: ., + env: env, + ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), + finish: (continue | not), + cont: true # set inside + }; + +def EVAL(env): + def _eval_here: + .env as $env | .expr | EVAL($env); + + def hmap_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem.value.value | EVAL($env) as $resv | + { + value: { + key: $elem.key, + value: { kkind: $elem.value.kkind, value: $resv.expr } + }, + env: env + }, + ({env: $resv.env, list: $rest} | hmap_with_env) + end; + def map_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem | EVAL($env) as $resv | + { value: $resv.expr, env: env }, + ({env: $resv.env, list: $rest} | map_with_env) + end; + . as $ast + | { env: env, ast: ., cont: true, finish: false, ret_env: null } + | [ recurseflip(.cont; + .env as $_menv + | if .finish then + .cont |= false + else + (.ret_env//.env) as $_retenv + | .ret_env as $_orig_retenv + | .ast + | . as $init + | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" + | $_menv | unwrapReplEnv as $replEnv # - + | $init + | + (select(.kind == "list") | + if .value | length == 0 then + . | TCOWrap($_menv; $_orig_retenv; false) + else + ( + ( + .value | select(.[0].value == "def!") as $value | + ($value[2] | EVAL($_menv)) as $evval | + addToEnv($evval; $value[1].value) as $val | + $val.expr | TCOWrap($val.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "let*") as $value | + ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $subenv | + (reduce ($value[1].value | nwise(2)) as $xvalue ( + $subenv; + . as $env | $xvalue[1] | EVAL($env) as $expenv | + env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) | . as $env + | $value[2] | TCOWrap($env; $_retenv; true) + ) // + ( + .value | select(.[0].value == "do") as $value | + (reduce ($value[1:][]) as $xvalue ( + { env: $_menv, expr: {kind:"nil"} }; + .env as $env | $xvalue | EVAL($env) + )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "if") as $value | + $value[1] | EVAL($_menv) as $condenv | + (if (["false", "nil"] | contains([$condenv.expr.kind])) then + ($value[3] // {kind:"nil"}) + else + $value[2] + end) | TCOWrap($condenv.env; $_orig_retenv; true) + ) // + ( + .value | select(.[0].value == "fn*") as $value | + # (fn* args body) + $value[1].value | map(.value) as $binds | + ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { + kind: "function", + binds: $binds, + env: ($_menv | env_remove_references($free_referencess)), + body: $value[2], + names: [], # we can't do that circular reference thing + free_referencess: $free_referencess # for dynamically scoped variables + } | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + reduce .value[] as $elem ( + {env: $_menv, val: []}; + . as $dot | $elem | EVAL($dot.env) as $eval_env | + ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | + {env: $_menv, val: ($dot.val + [$eval_env.expr])} + ) | . as $expr | $expr.val | first | + interpret($expr.val[1:]; $expr.env; _eval_here) as $exprenv | + $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) + ) // + TCOWrap($_menv; $_orig_retenv; false) + ) + end + ) // + (select(.kind == "vector") | + if .value|length == 0 then + { + kind: "vector", + value: [] + } | TCOWrap($_menv; $_orig_retenv; false) + else + [ { env: env, list: .value } | map_with_env ] as $res | + { + kind: "vector", + value: $res | map(.value) + } | TCOWrap($res | last.env; $_orig_retenv; false) + end + ) // + (select(.kind == "hashmap") | + [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | + { + kind: "hashmap", + value: $res | map(.value) | from_entries + } | TCOWrap($res | last.env; $_orig_retenv; false) + ) // + (select(.kind == "function") | + . | TCOWrap($_menv; $_orig_retenv; false) # return this unchanged, since it can only be applied to + ) // + (select(.kind == "symbol") | + .value | env_get($currentEnv) | TCOWrap($_menv; null; false) + ) // TCOWrap($_menv; $_orig_retenv; false) + end + ) ] + | last as $result + | ($result.ret_env // $result.env) as $env + | $result.ast + | addEnv($env); + +def PRINT(env): + pr_str(env); + +def rep(env): + READ | EVAL(env) as $expenv | + if $expenv.expr != null then + $expenv.expr | PRINT($expenv.env) + else + null + end | addEnv($expenv.env); + +def repl_(env): + ("user> " | _print) | + (read_line | rep(env)); + +# we don't have no indirect functions, so we'll have to interpret the old way +def replEnv: + { + parent: null, + environment: ({ + "+": { + kind: "fn", # native function + inputs: 2, + function: "number_add" + }, + "-": { + kind: "fn", # native function + inputs: 2, + function: "number_sub" + }, + "*": { + kind: "fn", # native function + inputs: 2, + function: "number_mul" + }, + "/": { + kind: "fn", # native function + inputs: 2, + function: "number_div" + }, + "eval": { + kind: "fn", + inputs: 1, + function: "eval" + } + } + core_identify), + fallback: null, + }; + +def repl(env): + def xrepl: + (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | + { + value: $expenv.expr, + stop: false, + env: ($expenv.env // .env) + } | ., xrepl; + {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; + +def eval_ign(expr): + . as $env | expr | rep($env) | .env; + +def eval_val(expr): + . as $env | expr | rep($env) | .expr; + +def getEnv: + replEnv + | wrapEnv({}) + | eval_ign("(def! not (fn* (a) (if a false true)))") + | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))"); + +def main: + if $ARGS.positional|length > 0 then + getEnv as $env | + env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | + eval_val("(load-file \($ARGS.positional[0] | tojson))") | + "" + else + repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) + end; + +[ main ] | _halt diff --git a/impls/jq/step7_quote.jq b/impls/jq/step7_quote.jq index bd7ddfdfda..9c84f6af15 100644 --- a/impls/jq/step7_quote.jq +++ b/impls/jq/step7_quote.jq @@ -1,313 +1,313 @@ -include "reader"; -include "printer"; -include "utils"; -include "interp"; -include "env"; -include "core"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -def recurseflip(x; y): - recurse(y; x); - -def TCOWrap(env; retenv; continue): - { - ast: ., - env: env, - ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), - finish: (continue | not), - cont: true # set inside - }; - -def _symbol(name): - { - kind: "symbol", - value: name - }; - -def _symbol_v(name): - if .kind == "symbol" then - .value == name - else - false - end; - -def quasiquote: - - # If input is ('name, arg), return arg, else nothing. - def _starts_with(name): - select(.kind == "list") - | .value - | select(length == 2) - | select(.[0] | _symbol_v(name)) - | .[1]; - - # Right-folding function. The current element is provided as input. - def qq_loop(acc): - ((_starts_with("splice-unquote") | [_symbol("concat"), ., acc]) - // [_symbol("cons"), quasiquote, acc]) - | {kind:"list", value:.}; - - # Adapt parameters for jq foldr. - def qq_foldr: - .value - | reverse - | reduce .[] as $elt ({kind:"list", value:[]}; - . as $acc | $elt | qq_loop($acc)); - - _starts_with("unquote") - // ( - select(.kind == "list") - | qq_foldr - ) // ( - select(.kind == "vector") - | {kind:"list", value:[_symbol("vec"), qq_foldr]} - ) // ( - select(.kind == "hashmap" or .kind == "symbol") - | {kind:"list", value:[_symbol("quote"), .]} - ) // .; - -def EVAL(env): - def _eval_here: - .env as $env | .expr | EVAL($env); - - def hmap_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem.value.value | EVAL($env) as $resv | - { - value: { - key: $elem.key, - value: { kkind: $elem.value.kkind, value: $resv.expr } - }, - env: env - }, - ({env: $resv.env, list: $rest} | hmap_with_env) - end; - def map_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem | EVAL($env) as $resv | - { value: $resv.expr, env: env }, - ({env: $resv.env, list: $rest} | map_with_env) - end; - . as $ast - | { env: env, ast: ., cont: true, finish: false, ret_env: null } - | [ recurseflip(.cont; - .env as $_menv - | if .finish then - .cont |= false - else - (.ret_env//.env) as $_retenv - | .ret_env as $_orig_retenv - | .ast - | . as $init - | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" - | $_menv | unwrapReplEnv as $replEnv # - - | $init - | - (select(.kind == "list") | - if .value | length == 0 then - . | TCOWrap($_menv; $_orig_retenv; false) - else - ( - ( - .value | select(.[0].value == "def!") as $value | - ($value[2] | EVAL($_menv)) as $evval | - addToEnv($evval; $value[1].value) as $val | - $val.expr | TCOWrap($val.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "let*") as $value | - ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $_menv | - (reduce ($value[1].value | nwise(2)) as $xvalue ( - $_menv; - . as $env | $xvalue[1] | EVAL($env) as $expenv | - env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) as $env - | $value[2] | TCOWrap($env; $_retenv; true) - ) // - ( - .value | select(.[0].value == "do") as $value | - (reduce ($value[1:][]) as $xvalue ( - { env: $_menv, expr: {kind:"nil"} }; - .env as $env | $xvalue | EVAL($env) - )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "if") as $value | - $value[1] | EVAL($_menv) as $condenv | - (if (["false", "nil"] | contains([$condenv.expr.kind])) then - ($value[3] // {kind:"nil"}) - else - $value[2] - end) | TCOWrap($condenv.env; $_orig_retenv; true) - ) // - ( - .value | select(.[0].value == "fn*") as $value | - # (fn* args body) - $value[1].value | map(.value) as $binds | - ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { - kind: "function", - binds: $binds, - env: ($_menv | env_remove_references($free_referencess)), - body: $value[2], - names: [], # we can't do that circular reference thing - free_referencess: $free_referencess # for dynamically scoped variables - } | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quote") as $value | - $value[1] | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quasiquoteexpand") - | .[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quasiquote") as $value | - $value[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; true) - ) // - ( - reduce .value[] as $elem ( - {env: $_menv, val: []}; - . as $dot | $elem | EVAL($dot.env) as $eval_env | - ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | - {env: $_menv, val: ($dot.val + [$eval_env.expr])} - ) | . as $expr | $expr.val | first | - interpret($expr.val[1:]; $expr.env; _eval_here) as $exprenv | - $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) - ) // - TCOWrap($_menv; $_orig_retenv; false) - ) - end - ) // - (select(.kind == "vector") | - if .value|length == 0 then - { - kind: "vector", - value: [] - } | TCOWrap($_menv; $_orig_retenv; false) - else - [ { env: env, list: .value } | map_with_env ] as $res | - { - kind: "vector", - value: $res | map(.value) - } | TCOWrap($res | last.env; $_orig_retenv; false) - end - ) // - (select(.kind == "hashmap") | - [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | - { - kind: "hashmap", - value: $res | map(.value) | from_entries - } | TCOWrap($res | last.env; $_orig_retenv; false) - ) // - (select(.kind == "function") | - . | TCOWrap($_menv; $_orig_retenv; false) # return this unchanged, since it can only be applied to - ) // - (select(.kind == "symbol") | - .value | env_get($currentEnv) | TCOWrap($_menv; null; false) - ) // TCOWrap($_menv; $_orig_retenv; false) - end - ) ] - | last as $result - | ($result.ret_env // $result.env) as $env - | $result.ast - | addEnv($env); - -def PRINT(env): - pr_str(env); - -def rep(env): - READ | EVAL(env) as $expenv | - if $expenv.expr != null then - $expenv.expr | PRINT($expenv.env) - else - null - end | addEnv($expenv.env); - -def repl_(env): - ("user> " | _print) | - (read_line | rep(env)); - -# we don't have no indirect functions, so we'll have to interpret the old way -def replEnv: - { - parent: null, - environment: ({ - "+": { - kind: "fn", # native function - inputs: 2, - function: "number_add" - }, - "-": { - kind: "fn", # native function - inputs: 2, - function: "number_sub" - }, - "*": { - kind: "fn", # native function - inputs: 2, - function: "number_mul" - }, - "/": { - kind: "fn", # native function - inputs: 2, - function: "number_div" - }, - "eval": { - kind: "fn", - inputs: 1, - function: "eval" - } - } + core_identify), - fallback: null - }; - -def repl(env): - def xrepl: - (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | - { - value: $expenv.expr, - stop: false, - env: ($expenv.env // .env) - } | ., xrepl; - {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; - -def eval_ign(expr): - . as $env | expr | rep($env) | .env; - -def eval_val(expr): - . as $env | expr | rep($env) | .expr; - -def getEnv: - replEnv - | wrapEnv({}) - | eval_ign("(def! not (fn* (a) (if a false true)))") - | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))"); - -def main: - if $ARGS.positional|length > 0 then - getEnv as $env | - env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | - eval_val("(load-file \($ARGS.positional[0] | tojson))") | - "" - else - repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) - end; - -[ main ] | _halt +include "reader"; +include "printer"; +include "utils"; +include "interp"; +include "env"; +include "core"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +def recurseflip(x; y): + recurse(y; x); + +def TCOWrap(env; retenv; continue): + { + ast: ., + env: env, + ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), + finish: (continue | not), + cont: true # set inside + }; + +def _symbol(name): + { + kind: "symbol", + value: name + }; + +def _symbol_v(name): + if .kind == "symbol" then + .value == name + else + false + end; + +def quasiquote: + + # If input is ('name, arg), return arg, else nothing. + def _starts_with(name): + select(.kind == "list") + | .value + | select(length == 2) + | select(.[0] | _symbol_v(name)) + | .[1]; + + # Right-folding function. The current element is provided as input. + def qq_loop(acc): + ((_starts_with("splice-unquote") | [_symbol("concat"), ., acc]) + // [_symbol("cons"), quasiquote, acc]) + | {kind:"list", value:.}; + + # Adapt parameters for jq foldr. + def qq_foldr: + .value + | reverse + | reduce .[] as $elt ({kind:"list", value:[]}; + . as $acc | $elt | qq_loop($acc)); + + _starts_with("unquote") + // ( + select(.kind == "list") + | qq_foldr + ) // ( + select(.kind == "vector") + | {kind:"list", value:[_symbol("vec"), qq_foldr]} + ) // ( + select(.kind == "hashmap" or .kind == "symbol") + | {kind:"list", value:[_symbol("quote"), .]} + ) // .; + +def EVAL(env): + def _eval_here: + .env as $env | .expr | EVAL($env); + + def hmap_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem.value.value | EVAL($env) as $resv | + { + value: { + key: $elem.key, + value: { kkind: $elem.value.kkind, value: $resv.expr } + }, + env: env + }, + ({env: $resv.env, list: $rest} | hmap_with_env) + end; + def map_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem | EVAL($env) as $resv | + { value: $resv.expr, env: env }, + ({env: $resv.env, list: $rest} | map_with_env) + end; + . as $ast + | { env: env, ast: ., cont: true, finish: false, ret_env: null } + | [ recurseflip(.cont; + .env as $_menv + | if .finish then + .cont |= false + else + (.ret_env//.env) as $_retenv + | .ret_env as $_orig_retenv + | .ast + | . as $init + | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" + | $_menv | unwrapReplEnv as $replEnv # - + | $init + | + (select(.kind == "list") | + if .value | length == 0 then + . | TCOWrap($_menv; $_orig_retenv; false) + else + ( + ( + .value | select(.[0].value == "def!") as $value | + ($value[2] | EVAL($_menv)) as $evval | + addToEnv($evval; $value[1].value) as $val | + $val.expr | TCOWrap($val.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "let*") as $value | + ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $_menv | + (reduce ($value[1].value | nwise(2)) as $xvalue ( + $_menv; + . as $env | $xvalue[1] | EVAL($env) as $expenv | + env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) as $env + | $value[2] | TCOWrap($env; $_retenv; true) + ) // + ( + .value | select(.[0].value == "do") as $value | + (reduce ($value[1:][]) as $xvalue ( + { env: $_menv, expr: {kind:"nil"} }; + .env as $env | $xvalue | EVAL($env) + )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "if") as $value | + $value[1] | EVAL($_menv) as $condenv | + (if (["false", "nil"] | contains([$condenv.expr.kind])) then + ($value[3] // {kind:"nil"}) + else + $value[2] + end) | TCOWrap($condenv.env; $_orig_retenv; true) + ) // + ( + .value | select(.[0].value == "fn*") as $value | + # (fn* args body) + $value[1].value | map(.value) as $binds | + ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { + kind: "function", + binds: $binds, + env: ($_menv | env_remove_references($free_referencess)), + body: $value[2], + names: [], # we can't do that circular reference thing + free_referencess: $free_referencess # for dynamically scoped variables + } | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quote") as $value | + $value[1] | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quasiquoteexpand") + | .[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quasiquote") as $value | + $value[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; true) + ) // + ( + reduce .value[] as $elem ( + {env: $_menv, val: []}; + . as $dot | $elem | EVAL($dot.env) as $eval_env | + ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | + {env: $_menv, val: ($dot.val + [$eval_env.expr])} + ) | . as $expr | $expr.val | first | + interpret($expr.val[1:]; $expr.env; _eval_here) as $exprenv | + $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) + ) // + TCOWrap($_menv; $_orig_retenv; false) + ) + end + ) // + (select(.kind == "vector") | + if .value|length == 0 then + { + kind: "vector", + value: [] + } | TCOWrap($_menv; $_orig_retenv; false) + else + [ { env: env, list: .value } | map_with_env ] as $res | + { + kind: "vector", + value: $res | map(.value) + } | TCOWrap($res | last.env; $_orig_retenv; false) + end + ) // + (select(.kind == "hashmap") | + [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | + { + kind: "hashmap", + value: $res | map(.value) | from_entries + } | TCOWrap($res | last.env; $_orig_retenv; false) + ) // + (select(.kind == "function") | + . | TCOWrap($_menv; $_orig_retenv; false) # return this unchanged, since it can only be applied to + ) // + (select(.kind == "symbol") | + .value | env_get($currentEnv) | TCOWrap($_menv; null; false) + ) // TCOWrap($_menv; $_orig_retenv; false) + end + ) ] + | last as $result + | ($result.ret_env // $result.env) as $env + | $result.ast + | addEnv($env); + +def PRINT(env): + pr_str(env); + +def rep(env): + READ | EVAL(env) as $expenv | + if $expenv.expr != null then + $expenv.expr | PRINT($expenv.env) + else + null + end | addEnv($expenv.env); + +def repl_(env): + ("user> " | _print) | + (read_line | rep(env)); + +# we don't have no indirect functions, so we'll have to interpret the old way +def replEnv: + { + parent: null, + environment: ({ + "+": { + kind: "fn", # native function + inputs: 2, + function: "number_add" + }, + "-": { + kind: "fn", # native function + inputs: 2, + function: "number_sub" + }, + "*": { + kind: "fn", # native function + inputs: 2, + function: "number_mul" + }, + "/": { + kind: "fn", # native function + inputs: 2, + function: "number_div" + }, + "eval": { + kind: "fn", + inputs: 1, + function: "eval" + } + } + core_identify), + fallback: null + }; + +def repl(env): + def xrepl: + (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | + { + value: $expenv.expr, + stop: false, + env: ($expenv.env // .env) + } | ., xrepl; + {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; + +def eval_ign(expr): + . as $env | expr | rep($env) | .env; + +def eval_val(expr): + . as $env | expr | rep($env) | .expr; + +def getEnv: + replEnv + | wrapEnv({}) + | eval_ign("(def! not (fn* (a) (if a false true)))") + | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))"); + +def main: + if $ARGS.positional|length > 0 then + getEnv as $env | + env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | + eval_val("(load-file \($ARGS.positional[0] | tojson))") | + "" + else + repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) + end; + +[ main ] | _halt diff --git a/impls/jq/step8_macros.jq b/impls/jq/step8_macros.jq index 75c18c5129..4b7bb81d15 100644 --- a/impls/jq/step8_macros.jq +++ b/impls/jq/step8_macros.jq @@ -1,381 +1,381 @@ -include "reader"; -include "printer"; -include "utils"; -include "interp"; -include "env"; -include "core"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -def recurseflip(x; y): - recurse(y; x); - -def TCOWrap(env; retenv; continue): - { - ast: ., - env: env, - ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), - finish: (continue | not), - cont: true # set inside - }; - -def _symbol(name): - { - kind: "symbol", - value: name - }; - -def _symbol_v(name): - if .kind == "symbol" then - .value == name - else - false - end; - -def quasiquote: - - # If input is ('name, arg), return arg, else nothing. - def _starts_with(name): - select(.kind == "list") - | .value - | select(length == 2) - | select(.[0] | _symbol_v(name)) - | .[1]; - - # Right-folding function. The current element is provided as input. - def qq_loop(acc): - ((_starts_with("splice-unquote") | [_symbol("concat"), ., acc]) - // [_symbol("cons"), quasiquote, acc]) - | {kind:"list", value:.}; - - # Adapt parameters for jq foldr. - def qq_foldr: - .value - | reverse - | reduce .[] as $elt ({kind:"list", value:[]}; - . as $acc | $elt | qq_loop($acc)); - - _starts_with("unquote") - // ( - select(.kind == "list") - | qq_foldr - ) // ( - select(.kind == "vector") - | {kind:"list", value:[_symbol("vec"), qq_foldr]} - ) // ( - select(.kind == "hashmap" or .kind == "symbol") - | {kind:"list", value:[_symbol("quote"), .]} - ) // .; - -def set_macro_function: - if .kind != "function" then - jqmal_error("expected a function to be defined by defmacro!") - else - .is_macro |= true - end; - -def is_macro_call(env): - if .kind != "list" then - false - else - if (.value|first.kind == "symbol") then - env_req(env; .value|first.value) - | if .kind != "function" then - false - else - .is_macro - end - else - false - end - end; - -def EVAL(env): - def _eval_here: - .env as $env | .expr | EVAL($env); - - def _interpret($_menv): - reduce .value[] as $elem ( - {env: $_menv, val: []}; - . as $dot | $elem | EVAL($dot.env) as $eval_env | - ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | - {env: $_menv, val: ($dot.val + [$eval_env.expr])} - ) | . as $expr | $expr.val | first | - interpret($expr.val[1:]; $expr.env; _eval_here); - - def macroexpand(env): - . as $dot | - $dot | - [ while(is_macro_call(env | unwrapCurrentEnv); - . as $dot - | ($dot.value[0] | EVAL(env).expr) as $fn - | $dot.value[1:] as $args - | $fn - | interpret($args; env; _eval_here).expr) // . ] - | last - | if is_macro_call(env | unwrapCurrentEnv) then - . as $dot - | ($dot.value[0] | EVAL(env).expr) as $fn - | $dot.value[1:] as $args - | $fn - | interpret($args; env; _eval_here).expr - else - . - end - ; - - def hmap_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem.value.value | EVAL($env) as $resv | - { - value: { - key: $elem.key, - value: { kkind: $elem.value.kkind, value: $resv.expr } - }, - env: env - }, - ({env: $resv.env, list: $rest} | hmap_with_env) - end; - def map_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem | EVAL($env) as $resv | - { value: $resv.expr, env: env }, - ({env: $resv.env, list: $rest} | map_with_env) - end; - def eval_ast(env): - (select(.kind == "vector") | - if .value|length == 0 then - { - kind: "vector", - value: [] - } - else - [ { env: env, list: .value } | map_with_env ] as $res | - { - kind: "vector", - value: $res | map(.value) - } - end - ) // - (select(.kind == "hashmap") | - [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | - { - kind: "hashmap", - value: $res | map(.value) | from_entries - } - ) // - (select(.kind == "function") | - .# return this unchanged, since it can only be applied to - ) // - (select(.kind == "symbol") | - .value | env_get(env | unwrapCurrentEnv) - ) // .; - - . as $ast - | { env: env, ast: ., cont: true, finish: false, ret_env: null } - | [ recurseflip(.cont; - .env as $_menv - | if .finish then - .cont |= false - else - (.ret_env//.env) as $_retenv - | .ret_env as $_orig_retenv - | .ast - | . as $init - | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" - | $_menv | unwrapReplEnv as $replEnv # - - | $init - | - (select(.kind == "list") | - macroexpand($_menv) | - if .kind != "list" then - eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false) - else - if .value | length == 0 then - . | TCOWrap($_menv; $_orig_retenv; false) - else - ( - ( - .value | select(.[0].value == "def!") as $value | - ($value[2] | EVAL($_menv)) as $evval | - addToEnv($evval; $value[1].value) as $val | - $val.expr | TCOWrap($val.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "defmacro!") as $value | - ($value[2] | EVAL($_menv) | (.expr |= set_macro_function)) as $evval | - addToEnv($evval; $value[1].value) as $val | - $val.expr | TCOWrap($val.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "let*") as $value | - ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $_menv | - (reduce ($value[1].value | nwise(2)) as $xvalue ( - $_menv; - . as $env | $xvalue[1] | EVAL($env) as $expenv | - env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) as $env - | $value[2] | TCOWrap($env; $_retenv; true) - ) // - ( - .value | select(.[0].value == "do") as $value | - (reduce ($value[1:][]) as $xvalue ( - { env: $_menv, expr: {kind:"nil"} }; - .env as $env | $xvalue | EVAL($env) - )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "if") as $value | - $value[1] | EVAL($_menv) as $condenv | - (if (["false", "nil"] | contains([$condenv.expr.kind])) then - ($value[3] // {kind:"nil"}) - else - $value[2] - end) | TCOWrap($condenv.env; $_orig_retenv; true) - ) // - ( - .value | select(.[0].value == "fn*") as $value | - # (fn* args body) - $value[1].value | map(.value) as $binds | - ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { - kind: "function", - binds: $binds, - env: ($_menv | env_remove_references($free_referencess)), - body: $value[2], - names: [], # we can't do that circular reference thing - free_referencess: $free_referencess, # for dynamically scoped variables - is_macro: false - } | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quote") as $value | - $value[1] | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quasiquoteexpand") - | .[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quasiquote") as $value | - $value[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; true) - ) // - ( - .value | select(.[0].value == "macroexpand") as $value | - $value[1] | macroexpand(env) | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - . as $dot | _interpret($_menv) as $exprenv | - $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) - ) // - TCOWrap($_menv; $_orig_retenv; false) - ) - end - end - ) // - (eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false)) - end - ) ] - | last as $result - | ($result.ret_env // $result.env) as $env - | $result.ast - | addEnv($env); - -def PRINT(env): - pr_str(env); - -def rep(env): - READ | EVAL(env) as $expenv | - if $expenv.expr != null then - $expenv.expr | PRINT($expenv.env) - else - null - end | addEnv($expenv.env); - -def repl_(env): - ("user> " | _print) | - (read_line | rep(env)); - -# we don't have no indirect functions, so we'll have to interpret the old way -def replEnv: - { - parent: null, - environment: ({ - "+": { - kind: "fn", # native function - inputs: 2, - function: "number_add" - }, - "-": { - kind: "fn", # native function - inputs: 2, - function: "number_sub" - }, - "*": { - kind: "fn", # native function - inputs: 2, - function: "number_mul" - }, - "/": { - kind: "fn", # native function - inputs: 2, - function: "number_div" - }, - "eval": { - kind: "fn", - inputs: 1, - function: "eval" - } - } + core_identify), - fallback: null - }; - -def repl(env): - def xrepl: - (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | - { - value: $expenv.expr, - stop: false, - env: ($expenv.env // .env) - } | ., xrepl; - {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; - -def eval_ign(expr): - . as $env | expr | rep($env) | .env; - -def eval_val(expr): - . as $env | expr | rep($env) | .expr; - -def getEnv: - replEnv - | wrapEnv({}) - | eval_ign("(def! not (fn* (a) (if a false true)))") - | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))") - | eval_ign("(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)))))))") - ; - -def main: - if $ARGS.positional|length > 0 then - getEnv as $env | - env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | - eval_val("(load-file \($ARGS.positional[0] | tojson))") | - "" - else - repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) - end; - -[ main ] | _halt +include "reader"; +include "printer"; +include "utils"; +include "interp"; +include "env"; +include "core"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +def recurseflip(x; y): + recurse(y; x); + +def TCOWrap(env; retenv; continue): + { + ast: ., + env: env, + ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), + finish: (continue | not), + cont: true # set inside + }; + +def _symbol(name): + { + kind: "symbol", + value: name + }; + +def _symbol_v(name): + if .kind == "symbol" then + .value == name + else + false + end; + +def quasiquote: + + # If input is ('name, arg), return arg, else nothing. + def _starts_with(name): + select(.kind == "list") + | .value + | select(length == 2) + | select(.[0] | _symbol_v(name)) + | .[1]; + + # Right-folding function. The current element is provided as input. + def qq_loop(acc): + ((_starts_with("splice-unquote") | [_symbol("concat"), ., acc]) + // [_symbol("cons"), quasiquote, acc]) + | {kind:"list", value:.}; + + # Adapt parameters for jq foldr. + def qq_foldr: + .value + | reverse + | reduce .[] as $elt ({kind:"list", value:[]}; + . as $acc | $elt | qq_loop($acc)); + + _starts_with("unquote") + // ( + select(.kind == "list") + | qq_foldr + ) // ( + select(.kind == "vector") + | {kind:"list", value:[_symbol("vec"), qq_foldr]} + ) // ( + select(.kind == "hashmap" or .kind == "symbol") + | {kind:"list", value:[_symbol("quote"), .]} + ) // .; + +def set_macro_function: + if .kind != "function" then + jqmal_error("expected a function to be defined by defmacro!") + else + .is_macro |= true + end; + +def is_macro_call(env): + if .kind != "list" then + false + else + if (.value|first.kind == "symbol") then + env_req(env; .value|first.value) + | if .kind != "function" then + false + else + .is_macro + end + else + false + end + end; + +def EVAL(env): + def _eval_here: + .env as $env | .expr | EVAL($env); + + def _interpret($_menv): + reduce .value[] as $elem ( + {env: $_menv, val: []}; + . as $dot | $elem | EVAL($dot.env) as $eval_env | + ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | + {env: $_menv, val: ($dot.val + [$eval_env.expr])} + ) | . as $expr | $expr.val | first | + interpret($expr.val[1:]; $expr.env; _eval_here); + + def macroexpand(env): + . as $dot | + $dot | + [ while(is_macro_call(env | unwrapCurrentEnv); + . as $dot + | ($dot.value[0] | EVAL(env).expr) as $fn + | $dot.value[1:] as $args + | $fn + | interpret($args; env; _eval_here).expr) // . ] + | last + | if is_macro_call(env | unwrapCurrentEnv) then + . as $dot + | ($dot.value[0] | EVAL(env).expr) as $fn + | $dot.value[1:] as $args + | $fn + | interpret($args; env; _eval_here).expr + else + . + end + ; + + def hmap_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem.value.value | EVAL($env) as $resv | + { + value: { + key: $elem.key, + value: { kkind: $elem.value.kkind, value: $resv.expr } + }, + env: env + }, + ({env: $resv.env, list: $rest} | hmap_with_env) + end; + def map_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem | EVAL($env) as $resv | + { value: $resv.expr, env: env }, + ({env: $resv.env, list: $rest} | map_with_env) + end; + def eval_ast(env): + (select(.kind == "vector") | + if .value|length == 0 then + { + kind: "vector", + value: [] + } + else + [ { env: env, list: .value } | map_with_env ] as $res | + { + kind: "vector", + value: $res | map(.value) + } + end + ) // + (select(.kind == "hashmap") | + [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | + { + kind: "hashmap", + value: $res | map(.value) | from_entries + } + ) // + (select(.kind == "function") | + .# return this unchanged, since it can only be applied to + ) // + (select(.kind == "symbol") | + .value | env_get(env | unwrapCurrentEnv) + ) // .; + + . as $ast + | { env: env, ast: ., cont: true, finish: false, ret_env: null } + | [ recurseflip(.cont; + .env as $_menv + | if .finish then + .cont |= false + else + (.ret_env//.env) as $_retenv + | .ret_env as $_orig_retenv + | .ast + | . as $init + | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" + | $_menv | unwrapReplEnv as $replEnv # - + | $init + | + (select(.kind == "list") | + macroexpand($_menv) | + if .kind != "list" then + eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false) + else + if .value | length == 0 then + . | TCOWrap($_menv; $_orig_retenv; false) + else + ( + ( + .value | select(.[0].value == "def!") as $value | + ($value[2] | EVAL($_menv)) as $evval | + addToEnv($evval; $value[1].value) as $val | + $val.expr | TCOWrap($val.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "defmacro!") as $value | + ($value[2] | EVAL($_menv) | (.expr |= set_macro_function)) as $evval | + addToEnv($evval; $value[1].value) as $val | + $val.expr | TCOWrap($val.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "let*") as $value | + ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $_menv | + (reduce ($value[1].value | nwise(2)) as $xvalue ( + $_menv; + . as $env | $xvalue[1] | EVAL($env) as $expenv | + env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) as $env + | $value[2] | TCOWrap($env; $_retenv; true) + ) // + ( + .value | select(.[0].value == "do") as $value | + (reduce ($value[1:][]) as $xvalue ( + { env: $_menv, expr: {kind:"nil"} }; + .env as $env | $xvalue | EVAL($env) + )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "if") as $value | + $value[1] | EVAL($_menv) as $condenv | + (if (["false", "nil"] | contains([$condenv.expr.kind])) then + ($value[3] // {kind:"nil"}) + else + $value[2] + end) | TCOWrap($condenv.env; $_orig_retenv; true) + ) // + ( + .value | select(.[0].value == "fn*") as $value | + # (fn* args body) + $value[1].value | map(.value) as $binds | + ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { + kind: "function", + binds: $binds, + env: ($_menv | env_remove_references($free_referencess)), + body: $value[2], + names: [], # we can't do that circular reference thing + free_referencess: $free_referencess, # for dynamically scoped variables + is_macro: false + } | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quote") as $value | + $value[1] | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quasiquoteexpand") + | .[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quasiquote") as $value | + $value[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; true) + ) // + ( + .value | select(.[0].value == "macroexpand") as $value | + $value[1] | macroexpand(env) | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + . as $dot | _interpret($_menv) as $exprenv | + $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) + ) // + TCOWrap($_menv; $_orig_retenv; false) + ) + end + end + ) // + (eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false)) + end + ) ] + | last as $result + | ($result.ret_env // $result.env) as $env + | $result.ast + | addEnv($env); + +def PRINT(env): + pr_str(env); + +def rep(env): + READ | EVAL(env) as $expenv | + if $expenv.expr != null then + $expenv.expr | PRINT($expenv.env) + else + null + end | addEnv($expenv.env); + +def repl_(env): + ("user> " | _print) | + (read_line | rep(env)); + +# we don't have no indirect functions, so we'll have to interpret the old way +def replEnv: + { + parent: null, + environment: ({ + "+": { + kind: "fn", # native function + inputs: 2, + function: "number_add" + }, + "-": { + kind: "fn", # native function + inputs: 2, + function: "number_sub" + }, + "*": { + kind: "fn", # native function + inputs: 2, + function: "number_mul" + }, + "/": { + kind: "fn", # native function + inputs: 2, + function: "number_div" + }, + "eval": { + kind: "fn", + inputs: 1, + function: "eval" + } + } + core_identify), + fallback: null + }; + +def repl(env): + def xrepl: + (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | + { + value: $expenv.expr, + stop: false, + env: ($expenv.env // .env) + } | ., xrepl; + {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; + +def eval_ign(expr): + . as $env | expr | rep($env) | .env; + +def eval_val(expr): + . as $env | expr | rep($env) | .expr; + +def getEnv: + replEnv + | wrapEnv({}) + | eval_ign("(def! not (fn* (a) (if a false true)))") + | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))") + | eval_ign("(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)))))))") + ; + +def main: + if $ARGS.positional|length > 0 then + getEnv as $env | + env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | + eval_val("(load-file \($ARGS.positional[0] | tojson))") | + "" + else + repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) + end; + +[ main ] | _halt diff --git a/impls/jq/step9_try.jq b/impls/jq/step9_try.jq index 9c3d416f48..2b41b51080 100644 --- a/impls/jq/step9_try.jq +++ b/impls/jq/step9_try.jq @@ -1,410 +1,410 @@ -include "reader"; -include "printer"; -include "utils"; -include "interp"; -include "env"; -include "core"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -def recurseflip(x; y): - recurse(y; x); - -def TCOWrap(env; retenv; continue): - { - ast: ., - env: env, - ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), - finish: (continue | not), - cont: true # set inside - }; - -def _symbol(name): - { - kind: "symbol", - value: name - }; - -def _symbol_v(name): - if .kind == "symbol" then - .value == name - else - false - end; - -def quasiquote: - - # If input is ('name, arg), return arg, else nothing. - def _starts_with(name): - select(.kind == "list") - | .value - | select(length == 2) - | select(.[0] | _symbol_v(name)) - | .[1]; - - # Right-folding function. The current element is provided as input. - def qq_loop(acc): - ((_starts_with("splice-unquote") | [_symbol("concat"), ., acc]) - // [_symbol("cons"), quasiquote, acc]) - | {kind:"list", value:.}; - - # Adapt parameters for jq foldr. - def qq_foldr: - .value - | reverse - | reduce .[] as $elt ({kind:"list", value:[]}; - . as $acc | $elt | qq_loop($acc)); - - _starts_with("unquote") - // ( - select(.kind == "list") - | qq_foldr - ) // ( - select(.kind == "vector") - | {kind:"list", value:[_symbol("vec"), qq_foldr]} - ) // ( - select(.kind == "hashmap" or .kind == "symbol") - | {kind:"list", value:[_symbol("quote"), .]} - ) // .; - -def set_macro_function: - if .kind != "function" then - jqmal_error("expected a function to be defined by defmacro!") - else - .is_macro |= true - end; - -def is_macro_call(env): - if .kind != "list" then - false - else - if (.value|first.kind == "symbol") then - env_req(env; .value|first.value) - | if .kind != "function" then - false - else - .is_macro - end - else - false - end - end; - -def EVAL(env): - def _eval_here: - .env as $env | .expr | EVAL($env); - - def _interpret($_menv): - reduce .value[] as $elem ( - {env: $_menv, val: []}; - . as $dot | $elem | EVAL($dot.env) as $eval_env | - ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | - {env: $_menv, val: ($dot.val + [$eval_env.expr])} - ) | . as $expr | $expr.val | first | - interpret($expr.val[1:]; $expr.env; _eval_here); - - def macroexpand(env): - . as $dot | - $dot | - [ while(is_macro_call(env | unwrapCurrentEnv); - . as $dot - | ($dot.value[0] | EVAL(env).expr) as $fn - | $dot.value[1:] as $args - | $fn - | interpret($args; env; _eval_here).expr) // . ] - | last - | if is_macro_call(env | unwrapCurrentEnv) then - . as $dot - | ($dot.value[0] | EVAL(env).expr) as $fn - | $dot.value[1:] as $args - | $fn - | interpret($args; env; _eval_here).expr - else - . - end - ; - - def hmap_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem.value.value | EVAL($env) as $resv | - { - value: { - key: $elem.key, - value: { kkind: $elem.value.kkind, value: $resv.expr } - }, - env: env - }, - ({env: $resv.env, list: $rest} | hmap_with_env) - end; - def map_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem | EVAL($env) as $resv | - { value: $resv.expr, env: env }, - ({env: $resv.env, list: $rest} | map_with_env) - end; - def eval_ast(env): - (select(.kind == "vector") | - if .value|length == 0 then - { - kind: "vector", - value: [] - } - else - [ { env: env, list: .value } | map_with_env ] as $res | - { - kind: "vector", - value: $res | map(.value) - } - end - ) // - (select(.kind == "hashmap") | - [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | - { - kind: "hashmap", - value: $res | map(.value) | from_entries - } - ) // - (select(.kind == "function") | - .# return this unchanged, since it can only be applied to - ) // - (select(.kind == "symbol") | - .value | env_get(env | unwrapCurrentEnv) - ) // .; - - . as $ast - | { env: env, ast: ., cont: true, finish: false, ret_env: null } - | [ recurseflip(.cont; - .env as $_menv - | if .finish then - .cont |= false - else - (.ret_env//.env) as $_retenv - | .ret_env as $_orig_retenv - | .ast - | . as $init - | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" - | $_menv | unwrapReplEnv as $replEnv # - - | $init - | - (select(.kind == "list") | - macroexpand($_menv) | - if .kind != "list" then - eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false) - else - if .value | length == 0 then - . | TCOWrap($_menv; $_orig_retenv; false) - else - ( - ( - .value | select(.[0].value == "def!") as $value | - ($value[2] | EVAL($_menv)) as $evval | - addToEnv($evval; $value[1].value) as $val | - $val.expr | TCOWrap($val.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "defmacro!") as $value | - ($value[2] | EVAL($_menv) | (.expr |= set_macro_function)) as $evval | - addToEnv($evval; $value[1].value) as $val | - $val.expr | TCOWrap($val.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "let*") as $value | - ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $_menv | - (reduce ($value[1].value | nwise(2)) as $xvalue ( - $_menv; - . as $env | $xvalue[1] | EVAL($env) as $expenv | - env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) as $env - | $value[2] | TCOWrap($env; $_retenv; true) - ) // - ( - .value | select(.[0].value == "do") as $value | - (reduce ($value[1:][]) as $xvalue ( - { env: $_menv, expr: {kind:"nil"} }; - .env as $env | $xvalue | EVAL($env) - )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "try*") as $value | - try ( - $value[1] | EVAL($_menv) as $exp | $exp.expr | TCOWrap($exp.env; $_orig_retenv; false) - ) catch ( . as $exc | - if $value[2] then - if ($value[2].value[0] | _symbol_v("catch*")) then - (if ($exc | is_jqmal_error) then - $exc[19:] as $ex | - try ( - $ex - | fromjson - ) catch ( - $ex | - wrap("string") - ) - else - $exc|wrap("string") - end) as $exc | - $value[2].value[2] | EVAL($currentEnv | childEnv([$value[2].value[1].value]; [$exc]) | wrapEnv($replEnv; $_menv.atoms)) as $ex | - $ex.expr | TCOWrap($ex.env; $_retenv; false) - else - error($exc) - end - else - error($exc) - end - ) - ) // - ( - .value | select(.[0].value == "if") as $value | - $value[1] | EVAL($_menv) as $condenv | - (if (["false", "nil"] | contains([$condenv.expr.kind])) then - ($value[3] // {kind:"nil"}) - else - $value[2] - end) | TCOWrap($condenv.env; $_orig_retenv; true) - ) // - ( - .value | select(.[0].value == "fn*") as $value | - # (fn* args body) - $value[1].value | map(.value) as $binds | - ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { - kind: "function", - binds: $binds, - env: ($_menv | env_remove_references($free_referencess)), - body: $value[2], - names: [], # we can't do that circular reference thing - free_referencess: $free_referencess, # for dynamically scoped variables - is_macro: false - } | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quote") as $value | - $value[1] | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quasiquoteexpand") - | .[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quasiquote") as $value | - $value[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; true) - ) // - ( - .value | select(.[0].value == "macroexpand") as $value | - $value[1] | macroexpand(env) | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - . as $dot | _interpret($_menv) as $exprenv | - $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) - ) // - TCOWrap($_menv; $_orig_retenv; false) - ) - end - end - ) // - (eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false)) - end - ) ] - | last as $result - | ($result.ret_env // $result.env) as $env - | $result.ast - | addEnv($env); - -def PRINT(env): - pr_str(env); - -def rep(env): - READ | EVAL(env) as $expenv | - if $expenv.expr != null then - $expenv.expr | PRINT($expenv.env) - else - null - end | addEnv($expenv.env); - -def repl_(env): - ("user> " | _print) | - (read_line | rep(env)); - -# we don't have no indirect functions, so we'll have to interpret the old way -def replEnv: - { - parent: null, - environment: ({ - "+": { - kind: "fn", # native function - inputs: 2, - function: "number_add" - }, - "-": { - kind: "fn", # native function - inputs: 2, - function: "number_sub" - }, - "*": { - kind: "fn", # native function - inputs: 2, - function: "number_mul" - }, - "/": { - kind: "fn", # native function - inputs: 2, - function: "number_div" - }, - "eval": { - kind: "fn", - inputs: 1, - function: "eval" - } - } + core_identify), - fallback: null - }; - -def repl(env): - def xrepl: - (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | - { - value: $expenv.expr, - stop: false, - env: ($expenv.env // .env) - } | ., xrepl; - {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; - -def eval_ign(expr): - . as $env | expr | rep($env) | .env; - -def eval_val(expr): - . as $env | expr | rep($env) | .expr; - -def getEnv: - replEnv - | wrapEnv({}) - | eval_ign("(def! not (fn* (a) (if a false true)))") - | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))") - | eval_ign("(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)))))))") - ; - -def main: - if $ARGS.positional|length > 0 then - getEnv as $env | - env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | - eval_val("(load-file \($ARGS.positional[0] | tojson))") | - "" - else - repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) - end; - -[ main ] | _halt +include "reader"; +include "printer"; +include "utils"; +include "interp"; +include "env"; +include "core"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +def recurseflip(x; y): + recurse(y; x); + +def TCOWrap(env; retenv; continue): + { + ast: ., + env: env, + ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), + finish: (continue | not), + cont: true # set inside + }; + +def _symbol(name): + { + kind: "symbol", + value: name + }; + +def _symbol_v(name): + if .kind == "symbol" then + .value == name + else + false + end; + +def quasiquote: + + # If input is ('name, arg), return arg, else nothing. + def _starts_with(name): + select(.kind == "list") + | .value + | select(length == 2) + | select(.[0] | _symbol_v(name)) + | .[1]; + + # Right-folding function. The current element is provided as input. + def qq_loop(acc): + ((_starts_with("splice-unquote") | [_symbol("concat"), ., acc]) + // [_symbol("cons"), quasiquote, acc]) + | {kind:"list", value:.}; + + # Adapt parameters for jq foldr. + def qq_foldr: + .value + | reverse + | reduce .[] as $elt ({kind:"list", value:[]}; + . as $acc | $elt | qq_loop($acc)); + + _starts_with("unquote") + // ( + select(.kind == "list") + | qq_foldr + ) // ( + select(.kind == "vector") + | {kind:"list", value:[_symbol("vec"), qq_foldr]} + ) // ( + select(.kind == "hashmap" or .kind == "symbol") + | {kind:"list", value:[_symbol("quote"), .]} + ) // .; + +def set_macro_function: + if .kind != "function" then + jqmal_error("expected a function to be defined by defmacro!") + else + .is_macro |= true + end; + +def is_macro_call(env): + if .kind != "list" then + false + else + if (.value|first.kind == "symbol") then + env_req(env; .value|first.value) + | if .kind != "function" then + false + else + .is_macro + end + else + false + end + end; + +def EVAL(env): + def _eval_here: + .env as $env | .expr | EVAL($env); + + def _interpret($_menv): + reduce .value[] as $elem ( + {env: $_menv, val: []}; + . as $dot | $elem | EVAL($dot.env) as $eval_env | + ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | + {env: $_menv, val: ($dot.val + [$eval_env.expr])} + ) | . as $expr | $expr.val | first | + interpret($expr.val[1:]; $expr.env; _eval_here); + + def macroexpand(env): + . as $dot | + $dot | + [ while(is_macro_call(env | unwrapCurrentEnv); + . as $dot + | ($dot.value[0] | EVAL(env).expr) as $fn + | $dot.value[1:] as $args + | $fn + | interpret($args; env; _eval_here).expr) // . ] + | last + | if is_macro_call(env | unwrapCurrentEnv) then + . as $dot + | ($dot.value[0] | EVAL(env).expr) as $fn + | $dot.value[1:] as $args + | $fn + | interpret($args; env; _eval_here).expr + else + . + end + ; + + def hmap_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem.value.value | EVAL($env) as $resv | + { + value: { + key: $elem.key, + value: { kkind: $elem.value.kkind, value: $resv.expr } + }, + env: env + }, + ({env: $resv.env, list: $rest} | hmap_with_env) + end; + def map_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem | EVAL($env) as $resv | + { value: $resv.expr, env: env }, + ({env: $resv.env, list: $rest} | map_with_env) + end; + def eval_ast(env): + (select(.kind == "vector") | + if .value|length == 0 then + { + kind: "vector", + value: [] + } + else + [ { env: env, list: .value } | map_with_env ] as $res | + { + kind: "vector", + value: $res | map(.value) + } + end + ) // + (select(.kind == "hashmap") | + [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | + { + kind: "hashmap", + value: $res | map(.value) | from_entries + } + ) // + (select(.kind == "function") | + .# return this unchanged, since it can only be applied to + ) // + (select(.kind == "symbol") | + .value | env_get(env | unwrapCurrentEnv) + ) // .; + + . as $ast + | { env: env, ast: ., cont: true, finish: false, ret_env: null } + | [ recurseflip(.cont; + .env as $_menv + | if .finish then + .cont |= false + else + (.ret_env//.env) as $_retenv + | .ret_env as $_orig_retenv + | .ast + | . as $init + | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" + | $_menv | unwrapReplEnv as $replEnv # - + | $init + | + (select(.kind == "list") | + macroexpand($_menv) | + if .kind != "list" then + eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false) + else + if .value | length == 0 then + . | TCOWrap($_menv; $_orig_retenv; false) + else + ( + ( + .value | select(.[0].value == "def!") as $value | + ($value[2] | EVAL($_menv)) as $evval | + addToEnv($evval; $value[1].value) as $val | + $val.expr | TCOWrap($val.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "defmacro!") as $value | + ($value[2] | EVAL($_menv) | (.expr |= set_macro_function)) as $evval | + addToEnv($evval; $value[1].value) as $val | + $val.expr | TCOWrap($val.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "let*") as $value | + ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $_menv | + (reduce ($value[1].value | nwise(2)) as $xvalue ( + $_menv; + . as $env | $xvalue[1] | EVAL($env) as $expenv | + env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) as $env + | $value[2] | TCOWrap($env; $_retenv; true) + ) // + ( + .value | select(.[0].value == "do") as $value | + (reduce ($value[1:][]) as $xvalue ( + { env: $_menv, expr: {kind:"nil"} }; + .env as $env | $xvalue | EVAL($env) + )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "try*") as $value | + try ( + $value[1] | EVAL($_menv) as $exp | $exp.expr | TCOWrap($exp.env; $_orig_retenv; false) + ) catch ( . as $exc | + if $value[2] then + if ($value[2].value[0] | _symbol_v("catch*")) then + (if ($exc | is_jqmal_error) then + $exc[19:] as $ex | + try ( + $ex + | fromjson + ) catch ( + $ex | + wrap("string") + ) + else + $exc|wrap("string") + end) as $exc | + $value[2].value[2] | EVAL($currentEnv | childEnv([$value[2].value[1].value]; [$exc]) | wrapEnv($replEnv; $_menv.atoms)) as $ex | + $ex.expr | TCOWrap($ex.env; $_retenv; false) + else + error($exc) + end + else + error($exc) + end + ) + ) // + ( + .value | select(.[0].value == "if") as $value | + $value[1] | EVAL($_menv) as $condenv | + (if (["false", "nil"] | contains([$condenv.expr.kind])) then + ($value[3] // {kind:"nil"}) + else + $value[2] + end) | TCOWrap($condenv.env; $_orig_retenv; true) + ) // + ( + .value | select(.[0].value == "fn*") as $value | + # (fn* args body) + $value[1].value | map(.value) as $binds | + ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { + kind: "function", + binds: $binds, + env: ($_menv | env_remove_references($free_referencess)), + body: $value[2], + names: [], # we can't do that circular reference thing + free_referencess: $free_referencess, # for dynamically scoped variables + is_macro: false + } | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quote") as $value | + $value[1] | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quasiquoteexpand") + | .[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quasiquote") as $value | + $value[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; true) + ) // + ( + .value | select(.[0].value == "macroexpand") as $value | + $value[1] | macroexpand(env) | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + . as $dot | _interpret($_menv) as $exprenv | + $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) + ) // + TCOWrap($_menv; $_orig_retenv; false) + ) + end + end + ) // + (eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false)) + end + ) ] + | last as $result + | ($result.ret_env // $result.env) as $env + | $result.ast + | addEnv($env); + +def PRINT(env): + pr_str(env); + +def rep(env): + READ | EVAL(env) as $expenv | + if $expenv.expr != null then + $expenv.expr | PRINT($expenv.env) + else + null + end | addEnv($expenv.env); + +def repl_(env): + ("user> " | _print) | + (read_line | rep(env)); + +# we don't have no indirect functions, so we'll have to interpret the old way +def replEnv: + { + parent: null, + environment: ({ + "+": { + kind: "fn", # native function + inputs: 2, + function: "number_add" + }, + "-": { + kind: "fn", # native function + inputs: 2, + function: "number_sub" + }, + "*": { + kind: "fn", # native function + inputs: 2, + function: "number_mul" + }, + "/": { + kind: "fn", # native function + inputs: 2, + function: "number_div" + }, + "eval": { + kind: "fn", + inputs: 1, + function: "eval" + } + } + core_identify), + fallback: null + }; + +def repl(env): + def xrepl: + (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | + { + value: $expenv.expr, + stop: false, + env: ($expenv.env // .env) + } | ., xrepl; + {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; + +def eval_ign(expr): + . as $env | expr | rep($env) | .env; + +def eval_val(expr): + . as $env | expr | rep($env) | .expr; + +def getEnv: + replEnv + | wrapEnv({}) + | eval_ign("(def! not (fn* (a) (if a false true)))") + | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))") + | eval_ign("(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)))))))") + ; + +def main: + if $ARGS.positional|length > 0 then + getEnv as $env | + env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | + eval_val("(load-file \($ARGS.positional[0] | tojson))") | + "" + else + repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) + end; + +[ main ] | _halt diff --git a/impls/jq/stepA_mal.jq b/impls/jq/stepA_mal.jq index 0c794f3751..479fccb67d 100644 --- a/impls/jq/stepA_mal.jq +++ b/impls/jq/stepA_mal.jq @@ -1,422 +1,422 @@ -include "reader"; -include "printer"; -include "utils"; -include "interp"; -include "env"; -include "core"; - -def read_line: - . as $in - | label $top - | _readline; - -def READ: - read_str | read_form | .value; - -def recurseflip(x; y): - recurse(y; x); - -def TCOWrap(env; retenv; continue): - { - ast: ., - env: env, - ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), - finish: (continue | not), - cont: true # set inside - }; - -def _symbol(name): - { - kind: "symbol", - value: name - }; - -def _symbol_v(name): - if .kind == "symbol" then - .value == name - else - false - end; - -def quasiquote: - - # If input is ('name, arg), return arg, else nothing. - def _starts_with(name): - select(.kind == "list") - | .value - | select(length == 2) - | select(.[0] | _symbol_v(name)) - | .[1]; - - # Right-folding function. The current element is provided as input. - def qq_loop(acc): - ((_starts_with("splice-unquote") | [_symbol("concat"), ., acc]) - // [_symbol("cons"), quasiquote, acc]) - | {kind:"list", value:.}; - - # Adapt parameters for jq foldr. - def qq_foldr: - .value - | reverse - | reduce .[] as $elt ({kind:"list", value:[]}; - . as $acc | $elt | qq_loop($acc)); - - _starts_with("unquote") - // ( - select(.kind == "list") - | qq_foldr - ) // ( - select(.kind == "vector") - | {kind:"list", value:[_symbol("vec"), qq_foldr]} - ) // ( - select(.kind == "hashmap" or .kind == "symbol") - | {kind:"list", value:[_symbol("quote"), .]} - ) // .; - -def set_macro_function: - if .kind != "function" then - jqmal_error("expected a function to be defined by defmacro!") - else - .is_macro |= true - end; - -def is_macro_call(env): - if .kind != "list" then - false - else - if (.value|first.kind == "symbol") then - env_req(env; .value|first.value) - | if .kind != "function" then - false - else - .is_macro - end - else - false - end - end; - -def EVAL(env): - def _eval_here: - .env as $env | .expr | EVAL($env); - - def _interpret($_menv): - reduce .value[] as $elem ( - {env: $_menv, val: []}; - . as $dot | $elem | EVAL($dot.env) as $eval_env | - ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | - {env: $_menv, val: ($dot.val + [$eval_env.expr])} - ) | . as $expr | $expr.val | first | - interpret($expr.val[1:]; $expr.env; _eval_here); - - def macroexpand(env): - . as $dot | - $dot | - [ while(is_macro_call(env | unwrapCurrentEnv); - . as $dot - | ($dot.value[0] | EVAL(env).expr) as $fn - | $dot.value[1:] as $args - | $fn - | interpret($args; env; _eval_here).expr) // . ] - | last - | if is_macro_call(env | unwrapCurrentEnv) then - . as $dot - | ($dot.value[0] | EVAL(env).expr) as $fn - | $dot.value[1:] as $args - | $fn - | interpret($args; env; _eval_here).expr - else - . - end - ; - - def hmap_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem.value.value | EVAL($env) as $resv | - { - value: { - key: $elem.key, - value: { kkind: $elem.value.kkind, value: $resv.expr } - }, - env: env - }, - ({env: $resv.env, list: $rest} | hmap_with_env) - end; - def map_with_env: - .env as $env | .list as $list | - if $list|length == 0 then - empty - else - $list[0] as $elem | - $list[1:] as $rest | - $elem | EVAL($env) as $resv | - { value: $resv.expr, env: env }, - ({env: $resv.env, list: $rest} | map_with_env) - end; - def eval_ast(env): - (select(.kind == "vector") | - if .value|length == 0 then - { - kind: "vector", - value: [] - } - else - [ { env: env, list: .value } | map_with_env ] as $res | - { - kind: "vector", - value: $res | map(.value) - } - end - ) // - (select(.kind == "hashmap") | - [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | - { - kind: "hashmap", - value: $res | map(.value) | from_entries - } - ) // - (select(.kind == "function") | - .# return this unchanged, since it can only be applied to - ) // - (select(.kind == "symbol") | - .value | env_get(env | unwrapCurrentEnv) - ) // .; - - . as $ast - | { env: env, ast: ., cont: true, finish: false, ret_env: null } - | [ recurseflip(.cont; - .env as $_menv - | (if $DEBUG then _debug("EVAL: \($ast | pr_str($_menv))") else . end) - | (if $DEBUG then _debug("ATOMS: \($_menv.atoms)") else . end) - | if .finish then - .cont |= false - else - (.ret_env//.env) as $_retenv - | .ret_env as $_orig_retenv - | .ast - | . as $init - | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" - | $_menv | unwrapReplEnv as $replEnv # - - | $init - | - (select(.kind == "list") | - macroexpand($_menv) | - if .kind != "list" then - eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false) - else - if .value | length == 0 then - . | TCOWrap($_menv; $_orig_retenv; false) - else - ( - ( - .value | select(.[0].value == "atoms??") as $value | - $_menv.atoms | keys | map(wrap("string")) | wrap("list") | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "def!") as $value | - ($value[2] | EVAL($_menv)) as $evval | - addToEnv($evval; $value[1].value) as $val | - $val.expr | TCOWrap($val.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "defmacro!") as $value | - ($value[2] | EVAL($_menv) | (.expr |= set_macro_function)) as $evval | - addToEnv($evval; $value[1].value) as $val | - $val.expr | TCOWrap($val.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "let*") as $value | - ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $_menv | - (reduce ($value[1].value | nwise(2)) as $xvalue ( - $_menv; - . as $env | $xvalue[1] | EVAL($env) as $expenv | - env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) as $env - | $value[2] | TCOWrap($env; $_retenv; true) - ) // - ( - .value | select(.[0].value == "do") as $value | - (reduce ($value[1:][]) as $xvalue ( - { env: $_menv, expr: {kind:"nil"} }; - .env as $env | $xvalue | EVAL($env) - )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "try*") as $value | - try ( - $value[1] | EVAL($_menv) as $exp | $exp.expr | TCOWrap($exp.env; $_orig_retenv; false) - ) catch ( . as $exc | - if $value[2] then - if ($value[2].value[0] | _symbol_v("catch*")) then - (if ($exc | is_jqmal_error) then - $exc[19:] as $ex | - try ( - $ex - | fromjson - ) catch ( - $ex | - wrap("string") - ) - else - $exc|wrap("string") - end) as $exc | - $value[2].value[2] | EVAL($currentEnv | childEnv([$value[2].value[1].value]; [$exc]) | wrapEnv($replEnv; $_menv.atoms)) as $ex | - $ex.expr | TCOWrap($ex.env; $_retenv; false) - else - error($exc) - end - else - error($exc) - end - ) - ) // - ( - .value | select(.[0].value == "if") as $value | - $value[1] | EVAL($_menv) as $condenv | - (if (["false", "nil"] | contains([$condenv.expr.kind])) then - ($value[3] // {kind:"nil"}) - else - $value[2] - end) | TCOWrap($condenv.env; $_orig_retenv; true) - ) // - ( - .value | select(.[0].value == "fn*") as $value | - # (fn* args body) - $value[1].value | map(.value) as $binds | - ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { - kind: "function", - binds: $binds, - env: ($_menv | env_remove_references($free_referencess)), - body: $value[2], - names: [], # we can't do that circular reference thing - free_referencess: $free_referencess, # for dynamically scoped variables - is_macro: false - } | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quote") as $value | - $value[1] | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quasiquoteexpand") - | .[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - .value | select(.[0].value == "quasiquote") as $value | - $value[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; true) - ) // - ( - .value | select(.[0].value == "macroexpand") as $value | - $value[1] | macroexpand($_menv) | TCOWrap($_menv; $_orig_retenv; false) - ) // - ( - . as $dot | _interpret($_menv) as $exprenv | - $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) - ) // - TCOWrap($_menv; $_orig_retenv; false) - ) - end - end - ) // - (eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false)) - end - | (if $DEBUG then _debug("POSTEVAL: \($ast | pr_str($_menv)) = \(.ast | pr_str($_menv))") else . end) - ) ] - | last as $result - | ($result.ret_env // $result.env) as $env - | $result.ast - | addEnv($env); - -def PRINT(env): - pr_str(env); - -def rep(env): - READ | EVAL(env) as $expenv | - if $expenv.expr != null then - $expenv.expr | PRINT($expenv.env) - else - null - end | addEnv($expenv.env); - -def repl_(env): - ("user> " | _print) | - (read_line | rep(env)); - -# we don't have no indirect functions, so we'll have to interpret the old way -def replEnv: - { - parent: null, - environment: ({ - "+": { - kind: "fn", # native function - inputs: 2, - function: "number_add" - }, - "-": { - kind: "fn", # native function - inputs: 2, - function: "number_sub" - }, - "*": { - kind: "fn", # native function - inputs: 2, - function: "number_mul" - }, - "/": { - kind: "fn", # native function - inputs: 2, - function: "number_div" - }, - "eval": { - kind: "fn", - inputs: 1, - function: "eval" - } - } + core_identify), - fallback: null - }; - -def repl(env): - def xrepl: - (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | - { - value: $expenv.expr, - stop: false, - env: ($expenv.env // .env) - } | ., xrepl; - {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; - -def eval_ign(expr): - . as $env | expr | rep($env) | .env; - -def eval_val(expr): - . as $env | expr | rep($env) | .expr; - -def getEnv: - replEnv - | wrapEnv({}) - | eval_ign("(def! *host-language* \"jq\")") - | eval_ign("(def! not (fn* (a) (if a false true)))") - | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))") - | eval_ign("(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)))))))") - ; - -def main: - if $ARGS.positional|length > 0 then - try ( - getEnv as $env | - env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | - eval_val("(load-file \($ARGS.positional[0] | tojson))") | - "" - ) catch ( - _print - ) - else - repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) - end; - -[ main ] | _halt +include "reader"; +include "printer"; +include "utils"; +include "interp"; +include "env"; +include "core"; + +def read_line: + . as $in + | label $top + | _readline; + +def READ: + read_str | read_form | .value; + +def recurseflip(x; y): + recurse(y; x); + +def TCOWrap(env; retenv; continue): + { + ast: ., + env: env, + ret_env: (if retenv != null then (retenv | setpath(["atoms"]; env.atoms)) else retenv end), + finish: (continue | not), + cont: true # set inside + }; + +def _symbol(name): + { + kind: "symbol", + value: name + }; + +def _symbol_v(name): + if .kind == "symbol" then + .value == name + else + false + end; + +def quasiquote: + + # If input is ('name, arg), return arg, else nothing. + def _starts_with(name): + select(.kind == "list") + | .value + | select(length == 2) + | select(.[0] | _symbol_v(name)) + | .[1]; + + # Right-folding function. The current element is provided as input. + def qq_loop(acc): + ((_starts_with("splice-unquote") | [_symbol("concat"), ., acc]) + // [_symbol("cons"), quasiquote, acc]) + | {kind:"list", value:.}; + + # Adapt parameters for jq foldr. + def qq_foldr: + .value + | reverse + | reduce .[] as $elt ({kind:"list", value:[]}; + . as $acc | $elt | qq_loop($acc)); + + _starts_with("unquote") + // ( + select(.kind == "list") + | qq_foldr + ) // ( + select(.kind == "vector") + | {kind:"list", value:[_symbol("vec"), qq_foldr]} + ) // ( + select(.kind == "hashmap" or .kind == "symbol") + | {kind:"list", value:[_symbol("quote"), .]} + ) // .; + +def set_macro_function: + if .kind != "function" then + jqmal_error("expected a function to be defined by defmacro!") + else + .is_macro |= true + end; + +def is_macro_call(env): + if .kind != "list" then + false + else + if (.value|first.kind == "symbol") then + env_req(env; .value|first.value) + | if .kind != "function" then + false + else + .is_macro + end + else + false + end + end; + +def EVAL(env): + def _eval_here: + .env as $env | .expr | EVAL($env); + + def _interpret($_menv): + reduce .value[] as $elem ( + {env: $_menv, val: []}; + . as $dot | $elem | EVAL($dot.env) as $eval_env | + ($dot.env | setpath(["atoms"]; $eval_env.env.atoms)) as $_menv | + {env: $_menv, val: ($dot.val + [$eval_env.expr])} + ) | . as $expr | $expr.val | first | + interpret($expr.val[1:]; $expr.env; _eval_here); + + def macroexpand(env): + . as $dot | + $dot | + [ while(is_macro_call(env | unwrapCurrentEnv); + . as $dot + | ($dot.value[0] | EVAL(env).expr) as $fn + | $dot.value[1:] as $args + | $fn + | interpret($args; env; _eval_here).expr) // . ] + | last + | if is_macro_call(env | unwrapCurrentEnv) then + . as $dot + | ($dot.value[0] | EVAL(env).expr) as $fn + | $dot.value[1:] as $args + | $fn + | interpret($args; env; _eval_here).expr + else + . + end + ; + + def hmap_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem.value.value | EVAL($env) as $resv | + { + value: { + key: $elem.key, + value: { kkind: $elem.value.kkind, value: $resv.expr } + }, + env: env + }, + ({env: $resv.env, list: $rest} | hmap_with_env) + end; + def map_with_env: + .env as $env | .list as $list | + if $list|length == 0 then + empty + else + $list[0] as $elem | + $list[1:] as $rest | + $elem | EVAL($env) as $resv | + { value: $resv.expr, env: env }, + ({env: $resv.env, list: $rest} | map_with_env) + end; + def eval_ast(env): + (select(.kind == "vector") | + if .value|length == 0 then + { + kind: "vector", + value: [] + } + else + [ { env: env, list: .value } | map_with_env ] as $res | + { + kind: "vector", + value: $res | map(.value) + } + end + ) // + (select(.kind == "hashmap") | + [ { env: env, list: (.value | to_entries) } | hmap_with_env ] as $res | + { + kind: "hashmap", + value: $res | map(.value) | from_entries + } + ) // + (select(.kind == "function") | + .# return this unchanged, since it can only be applied to + ) // + (select(.kind == "symbol") | + .value | env_get(env | unwrapCurrentEnv) + ) // .; + + . as $ast + | { env: env, ast: ., cont: true, finish: false, ret_env: null } + | [ recurseflip(.cont; + .env as $_menv + | (if $DEBUG then _debug("EVAL: \($ast | pr_str($_menv))") else . end) + | (if $DEBUG then _debug("ATOMS: \($_menv.atoms)") else . end) + | if .finish then + .cont |= false + else + (.ret_env//.env) as $_retenv + | .ret_env as $_orig_retenv + | .ast + | . as $init + | $_menv | unwrapCurrentEnv as $currentEnv # unwrap env "package" + | $_menv | unwrapReplEnv as $replEnv # - + | $init + | + (select(.kind == "list") | + macroexpand($_menv) | + if .kind != "list" then + eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false) + else + if .value | length == 0 then + . | TCOWrap($_menv; $_orig_retenv; false) + else + ( + ( + .value | select(.[0].value == "atoms??") as $value | + $_menv.atoms | keys | map(wrap("string")) | wrap("list") | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "def!") as $value | + ($value[2] | EVAL($_menv)) as $evval | + addToEnv($evval; $value[1].value) as $val | + $val.expr | TCOWrap($val.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "defmacro!") as $value | + ($value[2] | EVAL($_menv) | (.expr |= set_macro_function)) as $evval | + addToEnv($evval; $value[1].value) as $val | + $val.expr | TCOWrap($val.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "let*") as $value | + ($currentEnv | pureChildEnv | wrapEnv($replEnv; $_menv.atoms)) as $_menv | + (reduce ($value[1].value | nwise(2)) as $xvalue ( + $_menv; + . as $env | $xvalue[1] | EVAL($env) as $expenv | + env_set_($expenv.env; $xvalue[0].value; $expenv.expr))) as $env + | $value[2] | TCOWrap($env; $_retenv; true) + ) // + ( + .value | select(.[0].value == "do") as $value | + (reduce ($value[1:][]) as $xvalue ( + { env: $_menv, expr: {kind:"nil"} }; + .env as $env | $xvalue | EVAL($env) + )) | . as $ex | .expr | TCOWrap($ex.env; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "try*") as $value | + try ( + $value[1] | EVAL($_menv) as $exp | $exp.expr | TCOWrap($exp.env; $_orig_retenv; false) + ) catch ( . as $exc | + if $value[2] then + if ($value[2].value[0] | _symbol_v("catch*")) then + (if ($exc | is_jqmal_error) then + $exc[19:] as $ex | + try ( + $ex + | fromjson + ) catch ( + $ex | + wrap("string") + ) + else + $exc|wrap("string") + end) as $exc | + $value[2].value[2] | EVAL($currentEnv | childEnv([$value[2].value[1].value]; [$exc]) | wrapEnv($replEnv; $_menv.atoms)) as $ex | + $ex.expr | TCOWrap($ex.env; $_retenv; false) + else + error($exc) + end + else + error($exc) + end + ) + ) // + ( + .value | select(.[0].value == "if") as $value | + $value[1] | EVAL($_menv) as $condenv | + (if (["false", "nil"] | contains([$condenv.expr.kind])) then + ($value[3] // {kind:"nil"}) + else + $value[2] + end) | TCOWrap($condenv.env; $_orig_retenv; true) + ) // + ( + .value | select(.[0].value == "fn*") as $value | + # (fn* args body) + $value[1].value | map(.value) as $binds | + ($value[2] | find_free_references($currentEnv | env_dump_keys + $binds)) as $free_referencess | { + kind: "function", + binds: $binds, + env: ($_menv | env_remove_references($free_referencess)), + body: $value[2], + names: [], # we can't do that circular reference thing + free_referencess: $free_referencess, # for dynamically scoped variables + is_macro: false + } | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quote") as $value | + $value[1] | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quasiquoteexpand") + | .[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + .value | select(.[0].value == "quasiquote") as $value | + $value[1] | quasiquote | TCOWrap($_menv; $_orig_retenv; true) + ) // + ( + .value | select(.[0].value == "macroexpand") as $value | + $value[1] | macroexpand($_menv) | TCOWrap($_menv; $_orig_retenv; false) + ) // + ( + . as $dot | _interpret($_menv) as $exprenv | + $exprenv.expr | TCOWrap($exprenv.env; $_orig_retenv; false) + ) // + TCOWrap($_menv; $_orig_retenv; false) + ) + end + end + ) // + (eval_ast($_menv) | TCOWrap($_menv; $_orig_retenv; false)) + end + | (if $DEBUG then _debug("POSTEVAL: \($ast | pr_str($_menv)) = \(.ast | pr_str($_menv))") else . end) + ) ] + | last as $result + | ($result.ret_env // $result.env) as $env + | $result.ast + | addEnv($env); + +def PRINT(env): + pr_str(env); + +def rep(env): + READ | EVAL(env) as $expenv | + if $expenv.expr != null then + $expenv.expr | PRINT($expenv.env) + else + null + end | addEnv($expenv.env); + +def repl_(env): + ("user> " | _print) | + (read_line | rep(env)); + +# we don't have no indirect functions, so we'll have to interpret the old way +def replEnv: + { + parent: null, + environment: ({ + "+": { + kind: "fn", # native function + inputs: 2, + function: "number_add" + }, + "-": { + kind: "fn", # native function + inputs: 2, + function: "number_sub" + }, + "*": { + kind: "fn", # native function + inputs: 2, + function: "number_mul" + }, + "/": { + kind: "fn", # native function + inputs: 2, + function: "number_div" + }, + "eval": { + kind: "fn", + inputs: 1, + function: "eval" + } + } + core_identify), + fallback: null + }; + +def repl(env): + def xrepl: + (.env as $env | try repl_($env) catch addEnv($env)) as $expenv | + { + value: $expenv.expr, + stop: false, + env: ($expenv.env // .env) + } | ., xrepl; + {stop: false, env: env} | xrepl | if .value then (.value | _display) else empty end; + +def eval_ign(expr): + . as $env | expr | rep($env) | .env; + +def eval_val(expr): + . as $env | expr | rep($env) | .expr; + +def getEnv: + replEnv + | wrapEnv({}) + | eval_ign("(def! *host-language* \"jq\")") + | eval_ign("(def! not (fn* (a) (if a false true)))") + | eval_ign("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))))") + | eval_ign("(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)))))))") + ; + +def main: + if $ARGS.positional|length > 0 then + try ( + getEnv as $env | + env_set_($env; "*ARGV*"; $ARGS.positional[1:] | map(wrap("string")) | wrap("list")) | + eval_val("(load-file \($ARGS.positional[0] | tojson))") | + "" + ) catch ( + _print + ) + else + repl( getEnv as $env | env_set_($env; "*ARGV*"; [] | wrap("list")) ) + end; + +[ main ] | _halt diff --git a/impls/jq/utils.jq b/impls/jq/utils.jq index 7b0876b7cb..d738c95457 100644 --- a/impls/jq/utils.jq +++ b/impls/jq/utils.jq @@ -1,151 +1,151 @@ -def _debug(ex): - . as $top - | ex - | debug - | $top; - -def _print: - tostring; - -def nwise(n): - def _nwise: - if length <= n then - . - else - .[0:n], (.[n:] | _nwise) - end; - _nwise; - -def abs(x): - if x < 0 then 0 - x else x end; - -def jqmal_error(e): - error("JqMAL Exception :: " + e); - -def is_jqmal_error: - startswith("JqMAL Exception :: "); - -def wrap(kind): - { - kind: kind, - value: . - }; - -def wrap2(kind; opts): - opts + { - kind: kind, - value: . - }; - - -def find_free_references(keys): - def _refs: - if . == null then [] else - . as $dot - | if .kind == "symbol" then - if keys | contains([$dot.value]) then [] else [$dot.value] end - else if "list" == $dot.kind then - # if - scan args - # def! - scan body - # let* - add keys sequentially, scan body - # fn* - add keys, scan body - # quote - [] - # quasiquote - ??? - $dot.value[0] as $head - | if $head.kind == "symbol" then - ( - select($head.value == "if") | $dot.value[1:] | map(_refs) | reduce .[] as $x ([]; . + $x) - ) // ( - select($head.value == "def!") | $dot.value[2] | _refs - ) // ( - select($head.value == "let*") | $dot.value[2] | find_free_references(($dot.value[1].value as $value | ([ range(0; $value|length; 2) ] | map(select(. % 2 == 0) | $value[.].value))) + keys) - ) // ( - select($head.value == "fn*") | $dot.value[2] | find_free_references(($dot.value[1].value | map(.value)) + keys) - ) // ( - select($head.value == "quote") | [] - ) // ( - select($head.value == "quasiquote") | [] - ) // ($dot.value | map(_refs) | reduce .[] as $x ([]; . + $x)) - else - [ $dot.values[1:][] | _refs ] - end - else if "vector" == $dot.kind then - ($dot.value | map(_refs) | reduce .[] as $x ([]; . + $x)) - else if "hashmap" == $dot.kind then - ([$dot.value | to_entries[] | ({kind: .value.kkind, value: .key}, .value.value) ] | map(_refs) | reduce .[] as $x ([]; . + $x)) - else - [] - end end end end - end; - _refs | unique; - -def tomal: - ( - select(type == "array") | ( - map(tomal) | wrap("list") - ) - ) // ( - select(type == "string") | ( - if startswith("sym/") then - .[4:] | wrap("symbol") - else - wrap("string") - end - ) - ) // ( - select(type == "number") | ( - wrap("number") - ) - ); - -def _extern(options): - {command: .} - | debug - | if (options.nowait | not) then - input | fromjson - else - null - end; - -def issue_extern(cmd; options): - {cmd: cmd, args: .} - | _extern(options); - -def issue_extern(cmd): - issue_extern(cmd; {}); - -def _readline: - [.] - | issue_extern("readline"; {nowait: false}) - ; - -def __readline(prompt): - . as $top - | prompt - | _readline; - -def __readline: - __readline(.); - -def _display: - tostring | .+"\n" | debug; - -def _write_to_file(name): - . as $value - | [(name|tojson), (.|tojson), (false|tojson)] - | issue_extern("fwrite"; {nowait: true}) - | $value; - -def _append_to_file(name): - . as $value - | [(name|tojson), (.|tojson), (true|tojson)] - | issue_extern("fwrite"; {nowait: true}) - | $value; - -def _halt: - [] - | issue_extern("halt"; {nowait: true}) - | halt; - -def trap: - _write_to_file("trap_reason.json") | jqmal_error("trap"); +def _debug(ex): + . as $top + | ex + | debug + | $top; + +def _print: + tostring; + +def nwise(n): + def _nwise: + if length <= n then + . + else + .[0:n], (.[n:] | _nwise) + end; + _nwise; + +def abs(x): + if x < 0 then 0 - x else x end; + +def jqmal_error(e): + error("JqMAL Exception :: " + e); + +def is_jqmal_error: + startswith("JqMAL Exception :: "); + +def wrap(kind): + { + kind: kind, + value: . + }; + +def wrap2(kind; opts): + opts + { + kind: kind, + value: . + }; + + +def find_free_references(keys): + def _refs: + if . == null then [] else + . as $dot + | if .kind == "symbol" then + if keys | contains([$dot.value]) then [] else [$dot.value] end + else if "list" == $dot.kind then + # if - scan args + # def! - scan body + # let* - add keys sequentially, scan body + # fn* - add keys, scan body + # quote - [] + # quasiquote - ??? + $dot.value[0] as $head + | if $head.kind == "symbol" then + ( + select($head.value == "if") | $dot.value[1:] | map(_refs) | reduce .[] as $x ([]; . + $x) + ) // ( + select($head.value == "def!") | $dot.value[2] | _refs + ) // ( + select($head.value == "let*") | $dot.value[2] | find_free_references(($dot.value[1].value as $value | ([ range(0; $value|length; 2) ] | map(select(. % 2 == 0) | $value[.].value))) + keys) + ) // ( + select($head.value == "fn*") | $dot.value[2] | find_free_references(($dot.value[1].value | map(.value)) + keys) + ) // ( + select($head.value == "quote") | [] + ) // ( + select($head.value == "quasiquote") | [] + ) // ($dot.value | map(_refs) | reduce .[] as $x ([]; . + $x)) + else + [ $dot.values[1:][] | _refs ] + end + else if "vector" == $dot.kind then + ($dot.value | map(_refs) | reduce .[] as $x ([]; . + $x)) + else if "hashmap" == $dot.kind then + ([$dot.value | to_entries[] | ({kind: .value.kkind, value: .key}, .value.value) ] | map(_refs) | reduce .[] as $x ([]; . + $x)) + else + [] + end end end end + end; + _refs | unique; + +def tomal: + ( + select(type == "array") | ( + map(tomal) | wrap("list") + ) + ) // ( + select(type == "string") | ( + if startswith("sym/") then + .[4:] | wrap("symbol") + else + wrap("string") + end + ) + ) // ( + select(type == "number") | ( + wrap("number") + ) + ); + +def _extern(options): + {command: .} + | debug + | if (options.nowait | not) then + input | fromjson + else + null + end; + +def issue_extern(cmd; options): + {cmd: cmd, args: .} + | _extern(options); + +def issue_extern(cmd): + issue_extern(cmd; {}); + +def _readline: + [.] + | issue_extern("readline"; {nowait: false}) + ; + +def __readline(prompt): + . as $top + | prompt + | _readline; + +def __readline: + __readline(.); + +def _display: + tostring | .+"\n" | debug; + +def _write_to_file(name): + . as $value + | [(name|tojson), (.|tojson), (false|tojson)] + | issue_extern("fwrite"; {nowait: true}) + | $value; + +def _append_to_file(name): + . as $value + | [(name|tojson), (.|tojson), (true|tojson)] + | issue_extern("fwrite"; {nowait: true}) + | $value; + +def _halt: + [] + | issue_extern("halt"; {nowait: true}) + | halt; + +def trap: + _write_to_file("trap_reason.json") | jqmal_error("trap"); diff --git a/impls/js/Dockerfile b/impls/js/Dockerfile index f7677e91c8..725fd2586b 100644 --- a/impls/js/Dockerfile +++ b/impls/js/Dockerfile @@ -1,34 +1,34 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/impls/js/Makefile b/impls/js/Makefile index faef0bfe28..dc54468516 100644 --- a/impls/js/Makefile +++ b/impls/js/Makefile @@ -1,43 +1,43 @@ - -TESTS = tests/types.js tests/reader.js - -SOURCES_BASE = node_readline.js types.js reader.js printer.js interop.js -SOURCES_LISP = env.js core.js stepA_mal.js -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -WEB_SOURCES = $(SOURCES:node_readline.js=jq_readline.js) - -STEPS = step0_repl.js step1_read_print.js step2_eval.js step3_env.js \ - step4_if_fn_do.js step5_tco.js step6_file.js \ - step7_quote.js step8_macros.js step9_try.js stepA_mal.js - -all: node_modules - -dist: mal.js mal web/mal.js - -node_modules: - npm install - -$(STEPS): node_modules - -mal.js: $(SOURCES) - cat $+ | grep -v "= *require('./" >> $@ - -mal: mal.js - echo "#!/usr/bin/env node" > $@ - cat $< >> $@ - chmod +x $@ - -web/mal.js: $(WEB_SOURCES) - cat $+ | grep -v "= *require('./" > $@ - -clean: - rm -f mal.js web/mal.js - rm -rf node_modules - -.PHONY: tests $(TESTS) - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - node $@ || exit 1; \ + +TESTS = tests/types.js tests/reader.js + +SOURCES_BASE = node_readline.js types.js reader.js printer.js interop.js +SOURCES_LISP = env.js core.js stepA_mal.js +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) +WEB_SOURCES = $(SOURCES:node_readline.js=jq_readline.js) + +STEPS = step0_repl.js step1_read_print.js step2_eval.js step3_env.js \ + step4_if_fn_do.js step5_tco.js step6_file.js \ + step7_quote.js step8_macros.js step9_try.js stepA_mal.js + +all: node_modules + +dist: mal.js mal web/mal.js + +node_modules: + npm install + +$(STEPS): node_modules + +mal.js: $(SOURCES) + cat $+ | grep -v "= *require('./" >> $@ + +mal: mal.js + echo "#!/usr/bin/env node" > $@ + cat $< >> $@ + chmod +x $@ + +web/mal.js: $(WEB_SOURCES) + cat $+ | grep -v "= *require('./" > $@ + +clean: + rm -f mal.js web/mal.js + rm -rf node_modules + +.PHONY: tests $(TESTS) + +tests: $(TESTS) + +$(TESTS): + @echo "Running $@"; \ + node $@ || exit 1; \ diff --git a/impls/js/core.js b/impls/js/core.js index 2df84831aa..d6c9c93dd6 100644 --- a/impls/js/core.js +++ b/impls/js/core.js @@ -1,272 +1,272 @@ -// Node vs browser behavior -var core = {}; -if (typeof module === 'undefined') { - var exports = core; -} else { - var types = require('./types'), - readline = require('./node_readline'), - reader = require('./reader'), - printer = require('./printer'), - interop = require('./interop'); -} - -// Errors/Exceptions -function mal_throw(exc) { throw exc; } - - -// String functions -function pr_str() { - return Array.prototype.map.call(arguments,function(exp) { - return printer._pr_str(exp, true); - }).join(" "); -} - -function str() { - return Array.prototype.map.call(arguments,function(exp) { - return printer._pr_str(exp, false); - }).join(""); -} - -function prn() { - printer.println.apply({}, Array.prototype.map.call(arguments,function(exp) { - return printer._pr_str(exp, true); - })); -} - -function println() { - printer.println.apply({}, Array.prototype.map.call(arguments,function(exp) { - return printer._pr_str(exp, false); - })); -} - -function slurp(f) { - if (typeof require !== 'undefined') { - return require('fs').readFileSync(f, 'utf-8'); - } else { - var req = new XMLHttpRequest(); - req.open("GET", f, false); - req.send(); - if (req.status == 200) { - return req.responseText; - } else { - throw new Error("Failed to slurp file: " + f); - } - } -} - - -// Number functions -function time_ms() { return new Date().getTime(); } - - -// Hash Map functions -function assoc(src_hm) { - var hm = types._clone(src_hm); - var args = [hm].concat(Array.prototype.slice.call(arguments, 1)); - return types._assoc_BANG.apply(null, args); -} - -function dissoc(src_hm) { - var hm = types._clone(src_hm); - var args = [hm].concat(Array.prototype.slice.call(arguments, 1)); - return types._dissoc_BANG.apply(null, args); -} - -function get(hm, key) { - if (hm != null && key in hm) { - return hm[key]; - } else { - return null; - } -} - -function contains_Q(hm, key) { - if (key in hm) { return true; } else { return false; } -} - -function keys(hm) { return Object.keys(hm); } -function vals(hm) { return Object.keys(hm).map(function(k) { return hm[k]; }); } - - -// Sequence functions -function cons(a, b) { return [a].concat(b); } - -function concat(lst) { - lst = lst || []; - return lst.concat.apply(lst, Array.prototype.slice.call(arguments, 1)); -} -function vec(lst) { - if (types._list_Q(lst)) { - var v = Array.prototype.slice.call(lst, 0); - v.__isvector__ = true; - return v; - } else { - return lst; - } -} - -function nth(lst, idx) { - if (idx < lst.length) { return lst[idx]; } - else { throw new Error("nth: index out of range"); } -} - -function first(lst) { return (lst === null) ? null : lst[0]; } - -function rest(lst) { return (lst == null) ? [] : lst.slice(1); } - -function empty_Q(lst) { return lst.length === 0; } - -function count(s) { - if (Array.isArray(s)) { return s.length; } - else if (s === null) { return 0; } - else { return Object.keys(s).length; } -} - -function conj(lst) { - if (types._list_Q(lst)) { - return Array.prototype.slice.call(arguments, 1).reverse().concat(lst); - } else { - var v = lst.concat(Array.prototype.slice.call(arguments, 1)); - v.__isvector__ = true; - return v; - } -} - -function seq(obj) { - if (types._list_Q(obj)) { - return obj.length > 0 ? obj : null; - } else if (types._vector_Q(obj)) { - return obj.length > 0 ? Array.prototype.slice.call(obj, 0): null; - } else if (types._string_Q(obj)) { - return obj.length > 0 ? obj.split('') : null; - } else if (obj === null) { - return null; - } else { - throw new Error("seq: called on non-sequence"); - } -} - - -function apply(f) { - var args = Array.prototype.slice.call(arguments, 1); - return f.apply(f, args.slice(0, args.length-1).concat(args[args.length-1])); -} - -function map(f, lst) { - return lst.map(function(el){ return f(el); }); -} - - -// Metadata functions -function with_meta(obj, m) { - var new_obj = types._clone(obj); - new_obj.__meta__ = m; - return new_obj; -} - -function meta(obj) { - // TODO: support symbols and atoms - if ((!types._sequential_Q(obj)) && - (!(types._hash_map_Q(obj))) && - (!(types._function_Q(obj)))) { - throw new Error("attempt to get metadata from: " + types._obj_type(obj)); - } - return obj.__meta__; -} - - -// Atom functions -function deref(atm) { return atm.val; } -function reset_BANG(atm, val) { return atm.val = val; } -function swap_BANG(atm, f) { - var args = [atm.val].concat(Array.prototype.slice.call(arguments, 2)); - atm.val = f.apply(f, args); - return atm.val; -} - -function js_eval(str) { - return interop.js_to_mal(eval(str.toString())); -} - -function js_method_call(object_method_str) { - var args = Array.prototype.slice.call(arguments, 1), - r = interop.resolve_js(object_method_str), - obj = r[0], f = r[1]; - var res = f.apply(obj, args); - return interop.js_to_mal(res); -} - -// types.ns is namespace of type functions -var ns = {'type': types._obj_type, - '=': types._equal_Q, - 'throw': mal_throw, - 'nil?': types._nil_Q, - 'true?': types._true_Q, - 'false?': types._false_Q, - 'number?': types._number_Q, - 'string?': types._string_Q, - 'symbol': types._symbol, - 'symbol?': types._symbol_Q, - 'keyword': types._keyword, - 'keyword?': types._keyword_Q, - 'fn?': types._fn_Q, - 'macro?': types._macro_Q, - - 'pr-str': pr_str, - 'str': str, - 'prn': prn, - 'println': println, - 'readline': readline.readline, - 'read-string': reader.read_str, - 'slurp': slurp, - '<' : function(a,b){return a' : function(a,b){return a>b;}, - '>=' : function(a,b){return a>=b;}, - '+' : function(a,b){return a+b;}, - '-' : function(a,b){return a-b;}, - '*' : function(a,b){return a*b;}, - '/' : function(a,b){return a/b;}, - "time-ms": time_ms, - - 'list': types._list, - 'list?': types._list_Q, - 'vector': types._vector, - 'vector?': types._vector_Q, - 'hash-map': types._hash_map, - 'map?': types._hash_map_Q, - 'assoc': assoc, - 'dissoc': dissoc, - 'get': get, - 'contains?': contains_Q, - 'keys': keys, - 'vals': vals, - - 'sequential?': types._sequential_Q, - 'cons': cons, - 'concat': concat, - 'vec': vec, - 'nth': nth, - 'first': first, - 'rest': rest, - 'empty?': empty_Q, - 'count': count, - 'apply': apply, - 'map': map, - - 'conj': conj, - 'seq': seq, - - 'with-meta': with_meta, - 'meta': meta, - 'atom': types._atom, - 'atom?': types._atom_Q, - "deref": deref, - "reset!": reset_BANG, - "swap!": swap_BANG, - - 'js-eval': js_eval, - '.': js_method_call -}; - -exports.ns = core.ns = ns; +// Node vs browser behavior +var core = {}; +if (typeof module === 'undefined') { + var exports = core; +} else { + var types = require('./types'), + readline = require('./node_readline'), + reader = require('./reader'), + printer = require('./printer'), + interop = require('./interop'); +} + +// Errors/Exceptions +function mal_throw(exc) { throw exc; } + + +// String functions +function pr_str() { + return Array.prototype.map.call(arguments,function(exp) { + return printer._pr_str(exp, true); + }).join(" "); +} + +function str() { + return Array.prototype.map.call(arguments,function(exp) { + return printer._pr_str(exp, false); + }).join(""); +} + +function prn() { + printer.println.apply({}, Array.prototype.map.call(arguments,function(exp) { + return printer._pr_str(exp, true); + })); +} + +function println() { + printer.println.apply({}, Array.prototype.map.call(arguments,function(exp) { + return printer._pr_str(exp, false); + })); +} + +function slurp(f) { + if (typeof require !== 'undefined') { + return require('fs').readFileSync(f, 'utf-8'); + } else { + var req = new XMLHttpRequest(); + req.open("GET", f, false); + req.send(); + if (req.status == 200) { + return req.responseText; + } else { + throw new Error("Failed to slurp file: " + f); + } + } +} + + +// Number functions +function time_ms() { return new Date().getTime(); } + + +// Hash Map functions +function assoc(src_hm) { + var hm = types._clone(src_hm); + var args = [hm].concat(Array.prototype.slice.call(arguments, 1)); + return types._assoc_BANG.apply(null, args); +} + +function dissoc(src_hm) { + var hm = types._clone(src_hm); + var args = [hm].concat(Array.prototype.slice.call(arguments, 1)); + return types._dissoc_BANG.apply(null, args); +} + +function get(hm, key) { + if (hm != null && key in hm) { + return hm[key]; + } else { + return null; + } +} + +function contains_Q(hm, key) { + if (key in hm) { return true; } else { return false; } +} + +function keys(hm) { return Object.keys(hm); } +function vals(hm) { return Object.keys(hm).map(function(k) { return hm[k]; }); } + + +// Sequence functions +function cons(a, b) { return [a].concat(b); } + +function concat(lst) { + lst = lst || []; + return lst.concat.apply(lst, Array.prototype.slice.call(arguments, 1)); +} +function vec(lst) { + if (types._list_Q(lst)) { + var v = Array.prototype.slice.call(lst, 0); + v.__isvector__ = true; + return v; + } else { + return lst; + } +} + +function nth(lst, idx) { + if (idx < lst.length) { return lst[idx]; } + else { throw new Error("nth: index out of range"); } +} + +function first(lst) { return (lst === null) ? null : lst[0]; } + +function rest(lst) { return (lst == null) ? [] : lst.slice(1); } + +function empty_Q(lst) { return lst.length === 0; } + +function count(s) { + if (Array.isArray(s)) { return s.length; } + else if (s === null) { return 0; } + else { return Object.keys(s).length; } +} + +function conj(lst) { + if (types._list_Q(lst)) { + return Array.prototype.slice.call(arguments, 1).reverse().concat(lst); + } else { + var v = lst.concat(Array.prototype.slice.call(arguments, 1)); + v.__isvector__ = true; + return v; + } +} + +function seq(obj) { + if (types._list_Q(obj)) { + return obj.length > 0 ? obj : null; + } else if (types._vector_Q(obj)) { + return obj.length > 0 ? Array.prototype.slice.call(obj, 0): null; + } else if (types._string_Q(obj)) { + return obj.length > 0 ? obj.split('') : null; + } else if (obj === null) { + return null; + } else { + throw new Error("seq: called on non-sequence"); + } +} + + +function apply(f) { + var args = Array.prototype.slice.call(arguments, 1); + return f.apply(f, args.slice(0, args.length-1).concat(args[args.length-1])); +} + +function map(f, lst) { + return lst.map(function(el){ return f(el); }); +} + + +// Metadata functions +function with_meta(obj, m) { + var new_obj = types._clone(obj); + new_obj.__meta__ = m; + return new_obj; +} + +function meta(obj) { + // TODO: support symbols and atoms + if ((!types._sequential_Q(obj)) && + (!(types._hash_map_Q(obj))) && + (!(types._function_Q(obj)))) { + throw new Error("attempt to get metadata from: " + types._obj_type(obj)); + } + return obj.__meta__; +} + + +// Atom functions +function deref(atm) { return atm.val; } +function reset_BANG(atm, val) { return atm.val = val; } +function swap_BANG(atm, f) { + var args = [atm.val].concat(Array.prototype.slice.call(arguments, 2)); + atm.val = f.apply(f, args); + return atm.val; +} + +function js_eval(str) { + return interop.js_to_mal(eval(str.toString())); +} + +function js_method_call(object_method_str) { + var args = Array.prototype.slice.call(arguments, 1), + r = interop.resolve_js(object_method_str), + obj = r[0], f = r[1]; + var res = f.apply(obj, args); + return interop.js_to_mal(res); +} + +// types.ns is namespace of type functions +var ns = {'type': types._obj_type, + '=': types._equal_Q, + 'throw': mal_throw, + 'nil?': types._nil_Q, + 'true?': types._true_Q, + 'false?': types._false_Q, + 'number?': types._number_Q, + 'string?': types._string_Q, + 'symbol': types._symbol, + 'symbol?': types._symbol_Q, + 'keyword': types._keyword, + 'keyword?': types._keyword_Q, + 'fn?': types._fn_Q, + 'macro?': types._macro_Q, + + 'pr-str': pr_str, + 'str': str, + 'prn': prn, + 'println': println, + 'readline': readline.readline, + 'read-string': reader.read_str, + 'slurp': slurp, + '<' : function(a,b){return a' : function(a,b){return a>b;}, + '>=' : function(a,b){return a>=b;}, + '+' : function(a,b){return a+b;}, + '-' : function(a,b){return a-b;}, + '*' : function(a,b){return a*b;}, + '/' : function(a,b){return a/b;}, + "time-ms": time_ms, + + 'list': types._list, + 'list?': types._list_Q, + 'vector': types._vector, + 'vector?': types._vector_Q, + 'hash-map': types._hash_map, + 'map?': types._hash_map_Q, + 'assoc': assoc, + 'dissoc': dissoc, + 'get': get, + 'contains?': contains_Q, + 'keys': keys, + 'vals': vals, + + 'sequential?': types._sequential_Q, + 'cons': cons, + 'concat': concat, + 'vec': vec, + 'nth': nth, + 'first': first, + 'rest': rest, + 'empty?': empty_Q, + 'count': count, + 'apply': apply, + 'map': map, + + 'conj': conj, + 'seq': seq, + + 'with-meta': with_meta, + 'meta': meta, + 'atom': types._atom, + 'atom?': types._atom_Q, + "deref": deref, + "reset!": reset_BANG, + "swap!": swap_BANG, + + 'js-eval': js_eval, + '.': js_method_call +}; + +exports.ns = core.ns = ns; diff --git a/impls/js/env.js b/impls/js/env.js index 421b2200ce..bb655b8d1f 100644 --- a/impls/js/env.js +++ b/impls/js/env.js @@ -1,52 +1,52 @@ -// Node vs browser behavior -var env = {}; -if (typeof module === 'undefined') { - var exports = env; -} - -// Env implementation -function Env(outer, binds, exprs) { - this.data = {}; - this.outer = outer || null; - - if (binds && exprs) { - // Returns a new Env with symbols in binds bound to - // corresponding values in exprs - // TODO: check types of binds and exprs and compare lengths - for (var i=0; i max_history_length) { - lines = lines.slice(lines.length-max_history_length); - } - jq.SetHistory(lines); - } -} - -function jq_save_history(jq) { - var lines = jq.GetHistory(); - localStorage['mal_history'] = JSON.stringify(lines); -} - - -var readline = { - 'readline': function(prompt_str) { - return prompt(prompt_str); - }}; - +var max_history_length = 1000; + +function jq_load_history(jq) { + if (localStorage['mal_history']) { + var lines = JSON.parse(localStorage['mal_history']); + if (lines.length > max_history_length) { + lines = lines.slice(lines.length-max_history_length); + } + jq.SetHistory(lines); + } +} + +function jq_save_history(jq) { + var lines = jq.GetHistory(); + localStorage['mal_history'] = JSON.stringify(lines); +} + + +var readline = { + 'readline': function(prompt_str) { + return prompt(prompt_str); + }}; + diff --git a/impls/js/node_readline.js b/impls/js/node_readline.js index 6042eaa0af..9bfa296bb2 100644 --- a/impls/js/node_readline.js +++ b/impls/js/node_readline.js @@ -1,46 +1,46 @@ -// IMPORTANT: choose one -var RL_LIB = "libreadline"; // NOTE: libreadline is GPL -//var RL_LIB = "libedit"; - -var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); - -var rlwrap = {}; // namespace for this module in web context - -var ffi = require('ffi-napi'), - fs = require('fs'); - -var rllib = ffi.Library(RL_LIB, { - 'readline': [ 'string', [ 'string' ] ], - 'add_history': [ 'int', [ 'string' ] ]}); - -var rl_history_loaded = false; - -exports.readline = rlwrap.readline = function(prompt) { - prompt = typeof prompt !== 'undefined' ? prompt : "user> "; - - if (!rl_history_loaded) { - rl_history_loaded = true; - var lines = []; - if (fs.existsSync(HISTORY_FILE)) { - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - } - // Max of 2000 lines - lines = lines.slice(Math.max(lines.length - 2000, 0)); - for (var i=0; i "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i "); - if (line === null) { break; } - if (line) { printer.println(rep(line)); } - } -} +if (typeof module !== 'undefined') { + var readline = require('./node_readline'); + var printer = require('./printer'); +} + +// read +function READ(str) { + return str; +} + +// eval +function EVAL(ast, env) { + return ast; +} + +// print +function PRINT(exp) { + return exp; +} + +// repl +var rep = function(str) { return PRINT(EVAL(READ(str), {})); }; + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + if (line) { printer.println(rep(line)); } + } +} diff --git a/impls/js/step1_read_print.js b/impls/js/step1_read_print.js index d712a2f2bd..031bb36f12 100644 --- a/impls/js/step1_read_print.js +++ b/impls/js/step1_read_print.js @@ -1,41 +1,41 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function EVAL(ast, env) { - return ast; -} - -// print -function PRINT(exp) { - return printer._pr_str(exp, true); -} - -// repl -var re = function(str) { return EVAL(READ(str), {}); }; -var rep = function(str) { return PRINT(EVAL(READ(str), {})); }; - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function EVAL(ast, env) { + return ast; +} + +// print +function PRINT(exp) { + return printer._pr_str(exp, true); +} + +// repl +var re = function(str) { return EVAL(READ(str), {}); }; +var rep = function(str) { return PRINT(EVAL(READ(str), {})); }; + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/step2_eval.js b/impls/js/step2_eval.js index 1fea09e808..d2ca4a1381 100644 --- a/impls/js/step2_eval.js +++ b/impls/js/step2_eval.js @@ -1,85 +1,85 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function eval_ast(ast, env) { - if (types._symbol_Q(ast)) { - if (ast in env) { - return env[ast]; - } else { - throw new Error("'" + ast.value + "' not found"); - } - } else if (types._list_Q(ast)) { - return ast.map(function(a) { return EVAL(a, env); }); - } else if (types._vector_Q(ast)) { - var v = ast.map(function(a) { return EVAL(a, env); }); - v.__isvector__ = true; - return v; - } else if (types._hash_map_Q(ast)) { - var new_hm = {}; - for (k in ast) { - new_hm[k] = EVAL(ast[k], env); - } - return new_hm; - } else { - return ast; - } -} - -function _EVAL(ast, env) { - //printer.println("EVAL:", printer._pr_str(ast, true)); - if (!types._list_Q(ast)) { - return eval_ast(ast, env); - } - if (ast.length === 0) { - return ast; - } - - // apply list - var el = eval_ast(ast, env), f = el[0]; - return f.apply(f, el.slice(1)); -} - -function EVAL(ast, env) { - var result = _EVAL(ast, env); - return (typeof result !== "undefined") ? result : null; -} - -// print -function PRINT(exp) { - return printer._pr_str(exp, true); -} - -// repl -repl_env = {}; -var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; - -repl_env['+'] = function(a,b){return a+b;}; -repl_env['-'] = function(a,b){return a-b;}; -repl_env['*'] = function(a,b){return a*b;}; -repl_env['/'] = function(a,b){return a/b;}; - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function eval_ast(ast, env) { + if (types._symbol_Q(ast)) { + if (ast in env) { + return env[ast]; + } else { + throw new Error("'" + ast.value + "' not found"); + } + } else if (types._list_Q(ast)) { + return ast.map(function(a) { return EVAL(a, env); }); + } else if (types._vector_Q(ast)) { + var v = ast.map(function(a) { return EVAL(a, env); }); + v.__isvector__ = true; + return v; + } else if (types._hash_map_Q(ast)) { + var new_hm = {}; + for (k in ast) { + new_hm[k] = EVAL(ast[k], env); + } + return new_hm; + } else { + return ast; + } +} + +function _EVAL(ast, env) { + //printer.println("EVAL:", printer._pr_str(ast, true)); + if (!types._list_Q(ast)) { + return eval_ast(ast, env); + } + if (ast.length === 0) { + return ast; + } + + // apply list + var el = eval_ast(ast, env), f = el[0]; + return f.apply(f, el.slice(1)); +} + +function EVAL(ast, env) { + var result = _EVAL(ast, env); + return (typeof result !== "undefined") ? result : null; +} + +// print +function PRINT(exp) { + return printer._pr_str(exp, true); +} + +// repl +repl_env = {}; +var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; + +repl_env['+'] = function(a,b){return a+b;}; +repl_env['-'] = function(a,b){return a-b;}; +repl_env['*'] = function(a,b){return a*b;}; +repl_env['/'] = function(a,b){return a/b;}; + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/step3_env.js b/impls/js/step3_env.js index cff15d536e..b4abb32034 100644 --- a/impls/js/step3_env.js +++ b/impls/js/step3_env.js @@ -1,95 +1,95 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); - var Env = require('./env').Env; -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function eval_ast(ast, env) { - if (types._symbol_Q(ast)) { - return env.get(ast); - } else if (types._list_Q(ast)) { - return ast.map(function(a) { return EVAL(a, env); }); - } else if (types._vector_Q(ast)) { - var v = ast.map(function(a) { return EVAL(a, env); }); - v.__isvector__ = true; - return v; - } else if (types._hash_map_Q(ast)) { - var new_hm = {}; - for (k in ast) { - new_hm[k] = EVAL(ast[k], env); - } - return new_hm; - } else { - return ast; - } -} - -function _EVAL(ast, env) { - //printer.println("EVAL:", printer._pr_str(ast, true)); - if (!types._list_Q(ast)) { - return eval_ast(ast, env); - } - if (ast.length === 0) { - return ast; - } - - // apply list - var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; - switch (a0.value) { - case "def!": - var res = EVAL(a2, env); - return env.set(a1, res); - case "let*": - var let_env = new Env(env); - for (var i=0; i < a1.length; i+=2) { - let_env.set(a1[i], EVAL(a1[i+1], let_env)); - } - return EVAL(a2, let_env); - default: - var el = eval_ast(ast, env), f = el[0]; - return f.apply(f, el.slice(1)); - } -} - -function EVAL(ast, env) { - var result = _EVAL(ast, env); - return (typeof result !== "undefined") ? result : null; -} - -// print -function PRINT(exp) { - return printer._pr_str(exp, true); -} - -// repl -var repl_env = new Env(); -var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; - -repl_env.set(types._symbol('+'), function(a,b){return a+b;}); -repl_env.set(types._symbol('-'), function(a,b){return a-b;}); -repl_env.set(types._symbol('*'), function(a,b){return a*b;}); -repl_env.set(types._symbol('/'), function(a,b){return a/b;}); - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); + var Env = require('./env').Env; +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function eval_ast(ast, env) { + if (types._symbol_Q(ast)) { + return env.get(ast); + } else if (types._list_Q(ast)) { + return ast.map(function(a) { return EVAL(a, env); }); + } else if (types._vector_Q(ast)) { + var v = ast.map(function(a) { return EVAL(a, env); }); + v.__isvector__ = true; + return v; + } else if (types._hash_map_Q(ast)) { + var new_hm = {}; + for (k in ast) { + new_hm[k] = EVAL(ast[k], env); + } + return new_hm; + } else { + return ast; + } +} + +function _EVAL(ast, env) { + //printer.println("EVAL:", printer._pr_str(ast, true)); + if (!types._list_Q(ast)) { + return eval_ast(ast, env); + } + if (ast.length === 0) { + return ast; + } + + // apply list + var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; + switch (a0.value) { + case "def!": + var res = EVAL(a2, env); + return env.set(a1, res); + case "let*": + var let_env = new Env(env); + for (var i=0; i < a1.length; i+=2) { + let_env.set(a1[i], EVAL(a1[i+1], let_env)); + } + return EVAL(a2, let_env); + default: + var el = eval_ast(ast, env), f = el[0]; + return f.apply(f, el.slice(1)); + } +} + +function EVAL(ast, env) { + var result = _EVAL(ast, env); + return (typeof result !== "undefined") ? result : null; +} + +// print +function PRINT(exp) { + return printer._pr_str(exp, true); +} + +// repl +var repl_env = new Env(); +var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; + +repl_env.set(types._symbol('+'), function(a,b){return a+b;}); +repl_env.set(types._symbol('-'), function(a,b){return a-b;}); +repl_env.set(types._symbol('*'), function(a,b){return a*b;}); +repl_env.set(types._symbol('/'), function(a,b){return a/b;}); + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/step4_if_fn_do.js b/impls/js/step4_if_fn_do.js index 88d1f55d49..7efa4daf6b 100644 --- a/impls/js/step4_if_fn_do.js +++ b/impls/js/step4_if_fn_do.js @@ -1,111 +1,111 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); - var Env = require('./env').Env; - var core = require('./core'); -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function eval_ast(ast, env) { - if (types._symbol_Q(ast)) { - return env.get(ast); - } else if (types._list_Q(ast)) { - return ast.map(function(a) { return EVAL(a, env); }); - } else if (types._vector_Q(ast)) { - var v = ast.map(function(a) { return EVAL(a, env); }); - v.__isvector__ = true; - return v; - } else if (types._hash_map_Q(ast)) { - var new_hm = {}; - for (k in ast) { - new_hm[k] = EVAL(ast[k], env); - } - return new_hm; - } else { - return ast; - } -} - -function _EVAL(ast, env) { - //printer.println("EVAL:", printer._pr_str(ast, true)); - if (!types._list_Q(ast)) { - return eval_ast(ast, env); - } - if (ast.length === 0) { - return ast; - } - - // apply list - var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; - switch (a0.value) { - case "def!": - var res = EVAL(a2, env); - return env.set(a1, res); - case "let*": - var let_env = new Env(env); - for (var i=0; i < a1.length; i+=2) { - let_env.set(a1[i], EVAL(a1[i+1], let_env)); - } - return EVAL(a2, let_env); - case "do": - var el = eval_ast(ast.slice(1), env); - return el[el.length-1]; - case "if": - var cond = EVAL(a1, env); - if (cond === null || cond === false) { - return typeof a3 !== "undefined" ? EVAL(a3, env) : null; - } else { - return EVAL(a2, env); - } - case "fn*": - return function() { - return EVAL(a2, new Env(env, a1, arguments)); - }; - default: - var el = eval_ast(ast, env), f = el[0]; - return f.apply(f, el.slice(1)); - } -} - -function EVAL(ast, env) { - var result = _EVAL(ast, env); - return (typeof result !== "undefined") ? result : null; -} - -// print -function PRINT(exp) { - return printer._pr_str(exp, true); -} - -// repl -var repl_env = new Env(); -var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; - -// core.js: defined using javascript -for (var n in core.ns) { repl_env.set(types._symbol(n), core.ns[n]); } - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); + var Env = require('./env').Env; + var core = require('./core'); +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function eval_ast(ast, env) { + if (types._symbol_Q(ast)) { + return env.get(ast); + } else if (types._list_Q(ast)) { + return ast.map(function(a) { return EVAL(a, env); }); + } else if (types._vector_Q(ast)) { + var v = ast.map(function(a) { return EVAL(a, env); }); + v.__isvector__ = true; + return v; + } else if (types._hash_map_Q(ast)) { + var new_hm = {}; + for (k in ast) { + new_hm[k] = EVAL(ast[k], env); + } + return new_hm; + } else { + return ast; + } +} + +function _EVAL(ast, env) { + //printer.println("EVAL:", printer._pr_str(ast, true)); + if (!types._list_Q(ast)) { + return eval_ast(ast, env); + } + if (ast.length === 0) { + return ast; + } + + // apply list + var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; + switch (a0.value) { + case "def!": + var res = EVAL(a2, env); + return env.set(a1, res); + case "let*": + var let_env = new Env(env); + for (var i=0; i < a1.length; i+=2) { + let_env.set(a1[i], EVAL(a1[i+1], let_env)); + } + return EVAL(a2, let_env); + case "do": + var el = eval_ast(ast.slice(1), env); + return el[el.length-1]; + case "if": + var cond = EVAL(a1, env); + if (cond === null || cond === false) { + return typeof a3 !== "undefined" ? EVAL(a3, env) : null; + } else { + return EVAL(a2, env); + } + case "fn*": + return function() { + return EVAL(a2, new Env(env, a1, arguments)); + }; + default: + var el = eval_ast(ast, env), f = el[0]; + return f.apply(f, el.slice(1)); + } +} + +function EVAL(ast, env) { + var result = _EVAL(ast, env); + return (typeof result !== "undefined") ? result : null; +} + +// print +function PRINT(exp) { + return printer._pr_str(exp, true); +} + +// repl +var repl_env = new Env(); +var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; + +// core.js: defined using javascript +for (var n in core.ns) { repl_env.set(types._symbol(n), core.ns[n]); } + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/step5_tco.js b/impls/js/step5_tco.js index 18cfe949e3..ba829c6cf8 100644 --- a/impls/js/step5_tco.js +++ b/impls/js/step5_tco.js @@ -1,122 +1,122 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); - var Env = require('./env').Env; - var core = require('./core'); -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function eval_ast(ast, env) { - if (types._symbol_Q(ast)) { - return env.get(ast); - } else if (types._list_Q(ast)) { - return ast.map(function(a) { return EVAL(a, env); }); - } else if (types._vector_Q(ast)) { - var v = ast.map(function(a) { return EVAL(a, env); }); - v.__isvector__ = true; - return v; - } else if (types._hash_map_Q(ast)) { - var new_hm = {}; - for (k in ast) { - new_hm[k] = EVAL(ast[k], env); - } - return new_hm; - } else { - return ast; - } -} - -function _EVAL(ast, env) { - while (true) { - - //printer.println("EVAL:", printer._pr_str(ast, true)); - if (!types._list_Q(ast)) { - return eval_ast(ast, env); - } - if (ast.length === 0) { - return ast; - } - - // apply list - var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; - switch (a0.value) { - case "def!": - var res = EVAL(a2, env); - return env.set(a1, res); - case "let*": - var let_env = new Env(env); - for (var i=0; i < a1.length; i+=2) { - let_env.set(a1[i], EVAL(a1[i+1], let_env)); - } - ast = a2; - env = let_env; - break; - case "do": - eval_ast(ast.slice(1, -1), env); - ast = ast[ast.length-1]; - break; - case "if": - var cond = EVAL(a1, env); - if (cond === null || cond === false) { - ast = (typeof a3 !== "undefined") ? a3 : null; - } else { - ast = a2; - } - break; - case "fn*": - return types._function(EVAL, Env, a2, env, a1); - default: - var el = eval_ast(ast, env), f = el[0]; - if (f.__ast__) { - ast = f.__ast__; - env = f.__gen_env__(el.slice(1)); - } else { - return f.apply(f, el.slice(1)); - } - } - - } -} - -function EVAL(ast, env) { - var result = _EVAL(ast, env); - return (typeof result !== "undefined") ? result : null; -} - -// print -function PRINT(exp) { - return printer._pr_str(exp, true); -} - -// repl -var repl_env = new Env(); -var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; - -// core.js: defined using javascript -for (var n in core.ns) { repl_env.set(types._symbol(n), core.ns[n]); } - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); + var Env = require('./env').Env; + var core = require('./core'); +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function eval_ast(ast, env) { + if (types._symbol_Q(ast)) { + return env.get(ast); + } else if (types._list_Q(ast)) { + return ast.map(function(a) { return EVAL(a, env); }); + } else if (types._vector_Q(ast)) { + var v = ast.map(function(a) { return EVAL(a, env); }); + v.__isvector__ = true; + return v; + } else if (types._hash_map_Q(ast)) { + var new_hm = {}; + for (k in ast) { + new_hm[k] = EVAL(ast[k], env); + } + return new_hm; + } else { + return ast; + } +} + +function _EVAL(ast, env) { + while (true) { + + //printer.println("EVAL:", printer._pr_str(ast, true)); + if (!types._list_Q(ast)) { + return eval_ast(ast, env); + } + if (ast.length === 0) { + return ast; + } + + // apply list + var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; + switch (a0.value) { + case "def!": + var res = EVAL(a2, env); + return env.set(a1, res); + case "let*": + var let_env = new Env(env); + for (var i=0; i < a1.length; i+=2) { + let_env.set(a1[i], EVAL(a1[i+1], let_env)); + } + ast = a2; + env = let_env; + break; + case "do": + eval_ast(ast.slice(1, -1), env); + ast = ast[ast.length-1]; + break; + case "if": + var cond = EVAL(a1, env); + if (cond === null || cond === false) { + ast = (typeof a3 !== "undefined") ? a3 : null; + } else { + ast = a2; + } + break; + case "fn*": + return types._function(EVAL, Env, a2, env, a1); + default: + var el = eval_ast(ast, env), f = el[0]; + if (f.__ast__) { + ast = f.__ast__; + env = f.__gen_env__(el.slice(1)); + } else { + return f.apply(f, el.slice(1)); + } + } + + } +} + +function EVAL(ast, env) { + var result = _EVAL(ast, env); + return (typeof result !== "undefined") ? result : null; +} + +// print +function PRINT(exp) { + return printer._pr_str(exp, true); +} + +// repl +var repl_env = new Env(); +var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; + +// core.js: defined using javascript +for (var n in core.ns) { repl_env.set(types._symbol(n), core.ns[n]); } + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/step6_file.js b/impls/js/step6_file.js index 12450cc8c3..b4c2bc091a 100644 --- a/impls/js/step6_file.js +++ b/impls/js/step6_file.js @@ -1,132 +1,132 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); - var Env = require('./env').Env; - var core = require('./core'); -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function eval_ast(ast, env) { - if (types._symbol_Q(ast)) { - return env.get(ast); - } else if (types._list_Q(ast)) { - return ast.map(function(a) { return EVAL(a, env); }); - } else if (types._vector_Q(ast)) { - var v = ast.map(function(a) { return EVAL(a, env); }); - v.__isvector__ = true; - return v; - } else if (types._hash_map_Q(ast)) { - var new_hm = {}; - for (k in ast) { - new_hm[k] = EVAL(ast[k], env); - } - return new_hm; - } else { - return ast; - } -} - -function _EVAL(ast, env) { - while (true) { - - //printer.println("EVAL:", printer._pr_str(ast, true)); - if (!types._list_Q(ast)) { - return eval_ast(ast, env); - } - if (ast.length === 0) { - return ast; - } - - // apply list - var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; - switch (a0.value) { - case "def!": - var res = EVAL(a2, env); - return env.set(a1, res); - case "let*": - var let_env = new Env(env); - for (var i=0; i < a1.length; i+=2) { - let_env.set(a1[i], EVAL(a1[i+1], let_env)); - } - ast = a2; - env = let_env; - break; - case "do": - eval_ast(ast.slice(1, -1), env); - ast = ast[ast.length-1]; - break; - case "if": - var cond = EVAL(a1, env); - if (cond === null || cond === false) { - ast = (typeof a3 !== "undefined") ? a3 : null; - } else { - ast = a2; - } - break; - case "fn*": - return types._function(EVAL, Env, a2, env, a1); - default: - var el = eval_ast(ast, env), f = el[0]; - if (f.__ast__) { - ast = f.__ast__; - env = f.__gen_env__(el.slice(1)); - } else { - return f.apply(f, el.slice(1)); - } - } - - } -} - -function EVAL(ast, env) { - var result = _EVAL(ast, env); - return (typeof result !== "undefined") ? result : null; -} - -// print -function PRINT(exp) { - return printer._pr_str(exp, true); -} - -// repl -var repl_env = new Env(); -var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; - -// core.js: defined using javascript -for (var n in core.ns) { repl_env.set(types._symbol(n), core.ns[n]); } -repl_env.set(types._symbol('eval'), function(ast) { - return EVAL(ast, repl_env); }); -repl_env.set(types._symbol('*ARGV*'), []); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - -if (typeof process !== 'undefined' && process.argv.length > 2) { - repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); - rep('(load-file "' + process.argv[2] + '")'); - process.exit(0); -} - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); + var Env = require('./env').Env; + var core = require('./core'); +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function eval_ast(ast, env) { + if (types._symbol_Q(ast)) { + return env.get(ast); + } else if (types._list_Q(ast)) { + return ast.map(function(a) { return EVAL(a, env); }); + } else if (types._vector_Q(ast)) { + var v = ast.map(function(a) { return EVAL(a, env); }); + v.__isvector__ = true; + return v; + } else if (types._hash_map_Q(ast)) { + var new_hm = {}; + for (k in ast) { + new_hm[k] = EVAL(ast[k], env); + } + return new_hm; + } else { + return ast; + } +} + +function _EVAL(ast, env) { + while (true) { + + //printer.println("EVAL:", printer._pr_str(ast, true)); + if (!types._list_Q(ast)) { + return eval_ast(ast, env); + } + if (ast.length === 0) { + return ast; + } + + // apply list + var a0 = ast[0], a1 = ast[1], a2 = ast[2], a3 = ast[3]; + switch (a0.value) { + case "def!": + var res = EVAL(a2, env); + return env.set(a1, res); + case "let*": + var let_env = new Env(env); + for (var i=0; i < a1.length; i+=2) { + let_env.set(a1[i], EVAL(a1[i+1], let_env)); + } + ast = a2; + env = let_env; + break; + case "do": + eval_ast(ast.slice(1, -1), env); + ast = ast[ast.length-1]; + break; + case "if": + var cond = EVAL(a1, env); + if (cond === null || cond === false) { + ast = (typeof a3 !== "undefined") ? a3 : null; + } else { + ast = a2; + } + break; + case "fn*": + return types._function(EVAL, Env, a2, env, a1); + default: + var el = eval_ast(ast, env), f = el[0]; + if (f.__ast__) { + ast = f.__ast__; + env = f.__gen_env__(el.slice(1)); + } else { + return f.apply(f, el.slice(1)); + } + } + + } +} + +function EVAL(ast, env) { + var result = _EVAL(ast, env); + return (typeof result !== "undefined") ? result : null; +} + +// print +function PRINT(exp) { + return printer._pr_str(exp, true); +} + +// repl +var repl_env = new Env(); +var rep = function(str) { return PRINT(EVAL(READ(str), repl_env)); }; + +// core.js: defined using javascript +for (var n in core.ns) { repl_env.set(types._symbol(n), core.ns[n]); } +repl_env.set(types._symbol('eval'), function(ast) { + return EVAL(ast, repl_env); }); +repl_env.set(types._symbol('*ARGV*'), []); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + +if (typeof process !== 'undefined' && process.argv.length > 2) { + repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); + rep('(load-file "' + process.argv[2] + '")'); + process.exit(0); +} + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/step7_quote.js b/impls/js/step7_quote.js index 7774b0cfd3..af4aacd0f6 100644 --- a/impls/js/step7_quote.js +++ b/impls/js/step7_quote.js @@ -1,162 +1,162 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); - var Env = require('./env').Env; - var core = require('./core'); -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function qqLoop (acc, elt) { - if (types._list_Q(elt) && elt.length - && types._symbol_Q(elt[0]) && elt[0].value == 'splice-unquote') { - return [types._symbol("concat"), elt[1], acc]; - } else { - return [types._symbol("cons"), quasiquote (elt), acc]; - } -} -function quasiquote(ast) { - if (types._list_Q(ast) && 0 2) { - repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); - rep('(load-file "' + process.argv[2] + '")'); - process.exit(0); -} - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); + var Env = require('./env').Env; + var core = require('./core'); +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function qqLoop (acc, elt) { + if (types._list_Q(elt) && elt.length + && types._symbol_Q(elt[0]) && elt[0].value == 'splice-unquote') { + return [types._symbol("concat"), elt[1], acc]; + } else { + return [types._symbol("cons"), quasiquote (elt), acc]; + } +} +function quasiquote(ast) { + if (types._list_Q(ast) && 0 2) { + repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); + rep('(load-file "' + process.argv[2] + '")'); + process.exit(0); +} + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/step8_macros.js b/impls/js/step8_macros.js index 3141b30c7a..4f3d7fbdec 100644 --- a/impls/js/step8_macros.js +++ b/impls/js/step8_macros.js @@ -1,189 +1,189 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); - var Env = require('./env').Env; - var core = require('./core'); -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function qqLoop (acc, elt) { - if (types._list_Q(elt) && elt.length - && types._symbol_Q(elt[0]) && elt[0].value == 'splice-unquote') { - return [types._symbol("concat"), elt[1], acc]; - } else { - return [types._symbol("cons"), quasiquote (elt), acc]; - } -} -function quasiquote(ast) { - if (types._list_Q(ast) && 0 (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)))))))"); - -if (typeof process !== 'undefined' && process.argv.length > 2) { - repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); - rep('(load-file "' + process.argv[2] + '")'); - process.exit(0); -} - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); + var Env = require('./env').Env; + var core = require('./core'); +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function qqLoop (acc, elt) { + if (types._list_Q(elt) && elt.length + && types._symbol_Q(elt[0]) && elt[0].value == 'splice-unquote') { + return [types._symbol("concat"), elt[1], acc]; + } else { + return [types._symbol("cons"), quasiquote (elt), acc]; + } +} +function quasiquote(ast) { + if (types._list_Q(ast) && 0 (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)))))))"); + +if (typeof process !== 'undefined' && process.argv.length > 2) { + repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); + rep('(load-file "' + process.argv[2] + '")'); + process.exit(0); +} + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/step9_try.js b/impls/js/step9_try.js index 71089fc3eb..ff8b66dbab 100644 --- a/impls/js/step9_try.js +++ b/impls/js/step9_try.js @@ -1,200 +1,200 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); - var Env = require('./env').Env; - var core = require('./core'); -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function qqLoop (acc, elt) { - if (types._list_Q(elt) && elt.length - && types._symbol_Q(elt[0]) && elt[0].value == 'splice-unquote') { - return [types._symbol("concat"), elt[1], acc]; - } else { - return [types._symbol("cons"), quasiquote (elt), acc]; - } -} -function quasiquote(ast) { - if (types._list_Q(ast) && 0 (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)))))))"); - -if (typeof process !== 'undefined' && process.argv.length > 2) { - repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); - rep('(load-file "' + process.argv[2] + '")'); - process.exit(0); -} - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); + var Env = require('./env').Env; + var core = require('./core'); +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function qqLoop (acc, elt) { + if (types._list_Q(elt) && elt.length + && types._symbol_Q(elt[0]) && elt[0].value == 'splice-unquote') { + return [types._symbol("concat"), elt[1], acc]; + } else { + return [types._symbol("cons"), quasiquote (elt), acc]; + } +} +function quasiquote(ast) { + if (types._list_Q(ast) && 0 (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)))))))"); + +if (typeof process !== 'undefined' && process.argv.length > 2) { + repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); + rep('(load-file "' + process.argv[2] + '")'); + process.exit(0); +} + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/stepA_mal.js b/impls/js/stepA_mal.js index 7d1cadb808..8425ea16f1 100644 --- a/impls/js/stepA_mal.js +++ b/impls/js/stepA_mal.js @@ -1,202 +1,202 @@ -if (typeof module !== 'undefined') { - var types = require('./types'); - var readline = require('./node_readline'); - var reader = require('./reader'); - var printer = require('./printer'); - var Env = require('./env').Env; - var core = require('./core'); -} - -// read -function READ(str) { - return reader.read_str(str); -} - -// eval -function qqLoop (acc, elt) { - if (types._list_Q(elt) && elt.length - && types._symbol_Q(elt[0]) && elt[0].value == 'splice-unquote') { - return [types._symbol("concat"), elt[1], acc]; - } else { - return [types._symbol("cons"), quasiquote (elt), acc]; - } -} -function quasiquote(ast) { - if (types._list_Q(ast) && 0 (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)))))))"); - -if (typeof process !== 'undefined' && process.argv.length > 2) { - repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); - rep('(load-file "' + process.argv[2] + '")'); - process.exit(0); -} - -// repl loop -if (typeof require !== 'undefined' && require.main === module) { - // Synchronous node.js commandline mode - rep("(println (str \"Mal [\" *host-language* \"]\"))"); - while (true) { - var line = readline.readline("user> "); - if (line === null) { break; } - try { - if (line) { printer.println(rep(line)); } - } catch (exc) { - if (exc instanceof reader.BlankException) { continue } - if (exc instanceof Error) { console.warn(exc.stack) } - else { console.warn("Error: " + printer._pr_str(exc, true)) } - } - } -} +if (typeof module !== 'undefined') { + var types = require('./types'); + var readline = require('./node_readline'); + var reader = require('./reader'); + var printer = require('./printer'); + var Env = require('./env').Env; + var core = require('./core'); +} + +// read +function READ(str) { + return reader.read_str(str); +} + +// eval +function qqLoop (acc, elt) { + if (types._list_Q(elt) && elt.length + && types._symbol_Q(elt[0]) && elt[0].value == 'splice-unquote') { + return [types._symbol("concat"), elt[1], acc]; + } else { + return [types._symbol("cons"), quasiquote (elt), acc]; + } +} +function quasiquote(ast) { + if (types._list_Q(ast) && 0 (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)))))))"); + +if (typeof process !== 'undefined' && process.argv.length > 2) { + repl_env.set(types._symbol('*ARGV*'), process.argv.slice(3)); + rep('(load-file "' + process.argv[2] + '")'); + process.exit(0); +} + +// repl loop +if (typeof require !== 'undefined' && require.main === module) { + // Synchronous node.js commandline mode + rep("(println (str \"Mal [\" *host-language* \"]\"))"); + while (true) { + var line = readline.readline("user> "); + if (line === null) { break; } + try { + if (line) { printer.println(rep(line)); } + } catch (exc) { + if (exc instanceof reader.BlankException) { continue } + if (exc instanceof Error) { console.warn(exc.stack) } + else { console.warn("Error: " + printer._pr_str(exc, true)) } + } + } +} diff --git a/impls/js/tests/common.js b/impls/js/tests/common.js index a95d79b5fa..5f771257bc 100644 --- a/impls/js/tests/common.js +++ b/impls/js/tests/common.js @@ -1,15 +1,15 @@ -fs = require('fs'); -assert = require('assert'); - -function assert_eq(a, b) { - GLOBAL.assert.deepEqual(a, b, a + " !== " + b); -} - -function load(file) { - console.log(process.cwd()); - //process.chdir('../'); - eval(fs.readFileSync(file,'utf8')); -} - -exports.assert_eq = assert_eq; -exports.load = load; +fs = require('fs'); +assert = require('assert'); + +function assert_eq(a, b) { + GLOBAL.assert.deepEqual(a, b, a + " !== " + b); +} + +function load(file) { + console.log(process.cwd()); + //process.chdir('../'); + eval(fs.readFileSync(file,'utf8')); +} + +exports.assert_eq = assert_eq; +exports.load = load; diff --git a/impls/js/tests/reader.js b/impls/js/tests/reader.js index 132ec4fa22..9bccb44408 100644 --- a/impls/js/tests/reader.js +++ b/impls/js/tests/reader.js @@ -1,69 +1,69 @@ -common = require('./common.js'); -types = require('../types'); -reader = require('../reader'); -core = require('../core'); -var assert_eq = common.assert_eq, - read_str = reader.read_str, - nth = core.ns.nth; - -console.log("Testing read of constants/strings"); -assert_eq(2,read_str('2')); -assert_eq(12345,read_str('12345')); -assert_eq(12345,read_str('12345 "abc"')); -assert_eq('abc',read_str('"abc"')); -assert_eq('a string (with parens)',read_str('"a string (with parens)"')); - -console.log("Testing read of symbols"); -assert(types._symbol_Q(read_str('abc'))); -assert_eq('abc',read_str('abc').value); -assert_eq('.',read_str('.').value); - -console.log("Testing READ_STR of strings"); -assert_eq('a string',read_str('"a string"')); -assert_eq('a string (with parens)',read_str('"a string (with parens)"')); -assert_eq('a string',read_str('"a string"()')); -assert_eq('a string',read_str('"a string"123')); -assert_eq('a string',read_str('"a string"abc')); -assert_eq('',read_str('""')); -assert_eq('abc ',read_str('"abc "')); -assert_eq(' abc',read_str('" abc"')); -assert_eq('$abc',read_str('"$abc"')); -assert_eq('abc$()',read_str('"abc$()"')); -assert_eq('"xyz"',read_str('"\\"xyz\\""')); - - -console.log("Testing READ_STR of lists"); -assert_eq(2,core.ns.count(read_str('(2 3)'))); -assert_eq(2,core.ns.first(read_str('(2 3)'))); -assert_eq(3,core.ns.first(core.ns.rest(read_str('(2 3)')))); -L = read_str('(+ 1 2 "str1" "string (with parens) and \'single quotes\'")'); -assert_eq(5,core.ns.count(L)); -assert_eq('str1',nth(L,3)); -assert_eq('string (with parens) and \'single quotes\'',nth(L,4)); -assert_eq([2,3],read_str('(2 3)')); -assert_eq([2,3, 'string (with parens)'],read_str('(2 3 "string (with parens)")')); - - -console.log("Testing READ_STR of quote/quasiquote"); -assert_eq('quote',nth(read_str('\'1'),0).value); -assert_eq(1,nth(read_str('\'1'),1)); -assert_eq('quote',nth(read_str('\'(1 2 3)'),0).value); -assert_eq(3,nth(nth(read_str('\'(1 2 3)'),1),2)); - -assert_eq('quasiquote',nth(read_str('`1'),0).value); -assert_eq(1,nth(read_str('`1'),1)); -assert_eq('quasiquote',nth(read_str('`(1 2 3)'),0).value); -assert_eq(3,nth(nth(read_str('`(1 2 3)'),1),2)); - -assert_eq('unquote',nth(read_str('~1'),0).value); -assert_eq(1,nth(read_str('~1'),1)); -assert_eq('unquote',nth(read_str('~(1 2 3)'),0).value); -assert_eq(3,nth(nth(read_str('~(1 2 3)'),1),2)); - -assert_eq('splice-unquote',nth(read_str('~@1'),0).value); -assert_eq(1,nth(read_str('~@1'),1)); -assert_eq('splice-unquote',nth(read_str('~@(1 2 3)'),0).value); -assert_eq(3,nth(nth(read_str('~@(1 2 3)'),1),2)); - - -console.log("All tests completed"); +common = require('./common.js'); +types = require('../types'); +reader = require('../reader'); +core = require('../core'); +var assert_eq = common.assert_eq, + read_str = reader.read_str, + nth = core.ns.nth; + +console.log("Testing read of constants/strings"); +assert_eq(2,read_str('2')); +assert_eq(12345,read_str('12345')); +assert_eq(12345,read_str('12345 "abc"')); +assert_eq('abc',read_str('"abc"')); +assert_eq('a string (with parens)',read_str('"a string (with parens)"')); + +console.log("Testing read of symbols"); +assert(types._symbol_Q(read_str('abc'))); +assert_eq('abc',read_str('abc').value); +assert_eq('.',read_str('.').value); + +console.log("Testing READ_STR of strings"); +assert_eq('a string',read_str('"a string"')); +assert_eq('a string (with parens)',read_str('"a string (with parens)"')); +assert_eq('a string',read_str('"a string"()')); +assert_eq('a string',read_str('"a string"123')); +assert_eq('a string',read_str('"a string"abc')); +assert_eq('',read_str('""')); +assert_eq('abc ',read_str('"abc "')); +assert_eq(' abc',read_str('" abc"')); +assert_eq('$abc',read_str('"$abc"')); +assert_eq('abc$()',read_str('"abc$()"')); +assert_eq('"xyz"',read_str('"\\"xyz\\""')); + + +console.log("Testing READ_STR of lists"); +assert_eq(2,core.ns.count(read_str('(2 3)'))); +assert_eq(2,core.ns.first(read_str('(2 3)'))); +assert_eq(3,core.ns.first(core.ns.rest(read_str('(2 3)')))); +L = read_str('(+ 1 2 "str1" "string (with parens) and \'single quotes\'")'); +assert_eq(5,core.ns.count(L)); +assert_eq('str1',nth(L,3)); +assert_eq('string (with parens) and \'single quotes\'',nth(L,4)); +assert_eq([2,3],read_str('(2 3)')); +assert_eq([2,3, 'string (with parens)'],read_str('(2 3 "string (with parens)")')); + + +console.log("Testing READ_STR of quote/quasiquote"); +assert_eq('quote',nth(read_str('\'1'),0).value); +assert_eq(1,nth(read_str('\'1'),1)); +assert_eq('quote',nth(read_str('\'(1 2 3)'),0).value); +assert_eq(3,nth(nth(read_str('\'(1 2 3)'),1),2)); + +assert_eq('quasiquote',nth(read_str('`1'),0).value); +assert_eq(1,nth(read_str('`1'),1)); +assert_eq('quasiquote',nth(read_str('`(1 2 3)'),0).value); +assert_eq(3,nth(nth(read_str('`(1 2 3)'),1),2)); + +assert_eq('unquote',nth(read_str('~1'),0).value); +assert_eq(1,nth(read_str('~1'),1)); +assert_eq('unquote',nth(read_str('~(1 2 3)'),0).value); +assert_eq(3,nth(nth(read_str('~(1 2 3)'),1),2)); + +assert_eq('splice-unquote',nth(read_str('~@1'),0).value); +assert_eq(1,nth(read_str('~@1'),1)); +assert_eq('splice-unquote',nth(read_str('~@(1 2 3)'),0).value); +assert_eq(3,nth(nth(read_str('~@(1 2 3)'),1),2)); + + +console.log("All tests completed"); diff --git a/impls/js/tests/step5_tco.mal b/impls/js/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/js/tests/step5_tco.mal +++ b/impls/js/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/js/tests/stepA_mal.mal b/impls/js/tests/stepA_mal.mal index 54127682d9..c820b17e04 100644 --- a/impls/js/tests/stepA_mal.mal +++ b/impls/js/tests/stepA_mal.mal @@ -1,39 +1,39 @@ -;; Testing basic bash interop - -(js-eval "7") -;=>7 - -(js-eval "'7'") -;=>"7" - -(js-eval "[7,8,9]") -;=>(7 8 9) - -(js-eval "console.log('hello');") -;/hello -;=>nil - -(js-eval "foo=8;") -(js-eval "foo;") -;=>8 - -(js-eval "['a','b','c'].map(function(x){return 'X'+x+'Y'}).join(' ')") -;=>"XaY XbY XcY" - -(js-eval "[1,2,3].map(function(x){return 1+x})") -;=>(2 3 4) - -(js-eval (str "3 * " (* 4 5))) -;=>60 - -(. "console.log" "abc" 123 '(4 5 6) {"kk" "vv"} (= 1 1) nil) -;/abc 123 \[ 4, 5, 6 \] \{ kk: 'vv' \} true null -;=>nil - -(js-eval "myobj = { v: 10, myfunc: function(a,b,c) { return a * b * c * this.v; } }") -(. "myobj.myfunc" 2 3 4) -;=>240 - -(js-eval "myarray = [1,2,3,4,5]") -(. "myarray.join" "#") -;=>"1#2#3#4#5" +;; Testing basic bash interop + +(js-eval "7") +;=>7 + +(js-eval "'7'") +;=>"7" + +(js-eval "[7,8,9]") +;=>(7 8 9) + +(js-eval "console.log('hello');") +;/hello +;=>nil + +(js-eval "foo=8;") +(js-eval "foo;") +;=>8 + +(js-eval "['a','b','c'].map(function(x){return 'X'+x+'Y'}).join(' ')") +;=>"XaY XbY XcY" + +(js-eval "[1,2,3].map(function(x){return 1+x})") +;=>(2 3 4) + +(js-eval (str "3 * " (* 4 5))) +;=>60 + +(. "console.log" "abc" 123 '(4 5 6) {"kk" "vv"} (= 1 1) nil) +;/abc 123 \[ 4, 5, 6 \] \{ kk: 'vv' \} true null +;=>nil + +(js-eval "myobj = { v: 10, myfunc: function(a,b,c) { return a * b * c * this.v; } }") +(. "myobj.myfunc" 2 3 4) +;=>240 + +(js-eval "myarray = [1,2,3,4,5]") +(. "myarray.join" "#") +;=>"1#2#3#4#5" diff --git a/impls/js/tests/types.js b/impls/js/tests/types.js index d200cf7e80..c8341b754a 100644 --- a/impls/js/tests/types.js +++ b/impls/js/tests/types.js @@ -1,96 +1,96 @@ -common = require('./common.js'); -var assert_eq = common.assert_eq; -var types = require('../types.js'); -var core = require('../core.js'); -var env = require('../env.js'); -var symbol = types._symbol, - hash_map = core.ns['hash-map'], - hash_map_Q = core.ns['map?'], - assoc = core.ns['assoc'], - dissoc = core.ns['dissoc'], - get = core.ns['get'], - contains_Q = core.ns['contains?'], - count = core.ns['count'], - equal_Q = core.ns['=']; - - -console.log("Testing hash_maps"); -X = hash_map(); -assert_eq(true, hash_map_Q(X)); - -assert_eq(null, get(X,'a')); -assert_eq(false, contains_Q(X, 'a')); -X1 = assoc(X, 'a', "value of X a"); -assert_eq(null, get(X,'a')); -assert_eq(false, contains_Q(X, 'a')); -assert_eq("value of X a", get(X1, 'a')); -assert_eq(true, contains_Q(X1, 'a')); - -Y = hash_map(); -assert_eq(0, count(Y)); -Y1 = assoc(Y, 'a', "value of Y a"); -assert_eq(1, count(Y1)); -Y2 = assoc(Y1, 'b', "value of Y b"); -assert_eq(2, count(Y2)); -assert_eq("value of Y a", get(Y2, 'a')); -assert_eq("value of Y b", get(Y2, 'b')); - -X2 = assoc(X1, 'b', Y2); -assert_eq(2, count(Y2)); - -assert_eq(true, hash_map_Q(get(X2,'b'))); - -assert_eq('value of Y a', get(get(X2,'b'),'a')); -assert_eq('value of Y b', get(get(X2,'b'),'b')); - -Y3 = dissoc(Y2, 'a'); -assert_eq(2, count(Y2)); -assert_eq(1, count(Y3)); -assert_eq(null, get(Y3, 'a')); -Y4 = dissoc(Y3, 'b'); -assert_eq(0, count(Y4)); -assert_eq(null, get(Y4, 'b')); - - -console.log("Testing equal? function"); -assert_eq(true, equal_Q(2,2)); -assert_eq(false, equal_Q(2,3)); -assert_eq(false, equal_Q(2,3)); -assert_eq(true, equal_Q("abc","abc")); -assert_eq(false, equal_Q("abc","abz")); -assert_eq(false, equal_Q("zbc","abc")); -assert_eq(true, equal_Q(symbol("abc"),symbol("abc"))); -assert_eq(false, equal_Q(symbol("abc"),symbol("abz"))); -assert_eq(false, equal_Q(symbol("zbc"),symbol("abc"))); -L6 = [1, 2, 3]; -L7 = [1, 2, 3]; -L8 = [1, 2, "Z"]; -L9 = ["Z", 2, 3]; -L10 = [1, 2]; -assert_eq(true, equal_Q(L6, L7)); -assert_eq(false, equal_Q(L6, L8)); -assert_eq(false, equal_Q(L6, L9)); -assert_eq(false, equal_Q(L6, L10)); -assert_eq(false, equal_Q(L10, L6)); - - -console.log("Testing ENV (1 level)") -env1 = new env.Env(); -assert_eq('val_a',env1.set('a','val_a')); -assert_eq('val_b',env1.set('b','val_b')); -assert_eq('val_eq',env1.set('=','val_eq')); -assert_eq('val_a',env1.get('a')); -assert_eq('val_b',env1.get('b')); -assert_eq('val_eq',env1.get('=')); - -console.log("Testing ENV (2 levels)"); -env2 = new env.Env(env1); -assert_eq('val_b2',env2.set('b','val_b2')); -assert_eq('val_c',env2.set('c','val_c')); -assert_eq(env1,env2.find('a')); -assert_eq(env2,env2.find('b')); -assert_eq(env2,env2.find('c')); -assert_eq('val_a', env2.get('a')); -assert_eq('val_b2',env2.get('b')); -assert_eq('val_c', env2.get('c')); - +common = require('./common.js'); +var assert_eq = common.assert_eq; +var types = require('../types.js'); +var core = require('../core.js'); +var env = require('../env.js'); +var symbol = types._symbol, + hash_map = core.ns['hash-map'], + hash_map_Q = core.ns['map?'], + assoc = core.ns['assoc'], + dissoc = core.ns['dissoc'], + get = core.ns['get'], + contains_Q = core.ns['contains?'], + count = core.ns['count'], + equal_Q = core.ns['=']; + + +console.log("Testing hash_maps"); +X = hash_map(); +assert_eq(true, hash_map_Q(X)); + +assert_eq(null, get(X,'a')); +assert_eq(false, contains_Q(X, 'a')); +X1 = assoc(X, 'a', "value of X a"); +assert_eq(null, get(X,'a')); +assert_eq(false, contains_Q(X, 'a')); +assert_eq("value of X a", get(X1, 'a')); +assert_eq(true, contains_Q(X1, 'a')); + +Y = hash_map(); +assert_eq(0, count(Y)); +Y1 = assoc(Y, 'a', "value of Y a"); +assert_eq(1, count(Y1)); +Y2 = assoc(Y1, 'b', "value of Y b"); +assert_eq(2, count(Y2)); +assert_eq("value of Y a", get(Y2, 'a')); +assert_eq("value of Y b", get(Y2, 'b')); + +X2 = assoc(X1, 'b', Y2); +assert_eq(2, count(Y2)); + +assert_eq(true, hash_map_Q(get(X2,'b'))); + +assert_eq('value of Y a', get(get(X2,'b'),'a')); +assert_eq('value of Y b', get(get(X2,'b'),'b')); + +Y3 = dissoc(Y2, 'a'); +assert_eq(2, count(Y2)); +assert_eq(1, count(Y3)); +assert_eq(null, get(Y3, 'a')); +Y4 = dissoc(Y3, 'b'); +assert_eq(0, count(Y4)); +assert_eq(null, get(Y4, 'b')); + + +console.log("Testing equal? function"); +assert_eq(true, equal_Q(2,2)); +assert_eq(false, equal_Q(2,3)); +assert_eq(false, equal_Q(2,3)); +assert_eq(true, equal_Q("abc","abc")); +assert_eq(false, equal_Q("abc","abz")); +assert_eq(false, equal_Q("zbc","abc")); +assert_eq(true, equal_Q(symbol("abc"),symbol("abc"))); +assert_eq(false, equal_Q(symbol("abc"),symbol("abz"))); +assert_eq(false, equal_Q(symbol("zbc"),symbol("abc"))); +L6 = [1, 2, 3]; +L7 = [1, 2, 3]; +L8 = [1, 2, "Z"]; +L9 = ["Z", 2, 3]; +L10 = [1, 2]; +assert_eq(true, equal_Q(L6, L7)); +assert_eq(false, equal_Q(L6, L8)); +assert_eq(false, equal_Q(L6, L9)); +assert_eq(false, equal_Q(L6, L10)); +assert_eq(false, equal_Q(L10, L6)); + + +console.log("Testing ENV (1 level)") +env1 = new env.Env(); +assert_eq('val_a',env1.set('a','val_a')); +assert_eq('val_b',env1.set('b','val_b')); +assert_eq('val_eq',env1.set('=','val_eq')); +assert_eq('val_a',env1.get('a')); +assert_eq('val_b',env1.get('b')); +assert_eq('val_eq',env1.get('=')); + +console.log("Testing ENV (2 levels)"); +env2 = new env.Env(env1); +assert_eq('val_b2',env2.set('b','val_b2')); +assert_eq('val_c',env2.set('c','val_c')); +assert_eq(env1,env2.find('a')); +assert_eq(env2,env2.find('b')); +assert_eq(env2,env2.find('c')); +assert_eq('val_a', env2.get('a')); +assert_eq('val_b2',env2.get('b')); +assert_eq('val_c', env2.get('c')); + diff --git a/impls/js/types.js b/impls/js/types.js index 0fb324e711..06ace4fa74 100644 --- a/impls/js/types.js +++ b/impls/js/types.js @@ -1,230 +1,230 @@ -// Node vs browser behavior -var types = {}; -if (typeof module === 'undefined') { - var exports = types; -} - -// General functions - -function _obj_type(obj) { - if (_symbol_Q(obj)) { return 'symbol'; } - else if (_list_Q(obj)) { return 'list'; } - else if (_vector_Q(obj)) { return 'vector'; } - else if (_hash_map_Q(obj)) { return 'hash-map'; } - else if (_nil_Q(obj)) { return 'nil'; } - else if (_true_Q(obj)) { return 'true'; } - else if (_false_Q(obj)) { return 'false'; } - else if (_atom_Q(obj)) { return 'atom'; } - else { - switch (typeof(obj)) { - case 'number': return 'number'; - case 'function': return 'function'; - case 'string': return obj[0] == '\u029e' ? 'keyword' : 'string'; - default: throw new Error("Unknown type '" + typeof(obj) + "'"); - } - } -} - -function _sequential_Q(lst) { return _list_Q(lst) || _vector_Q(lst); } - - -function _equal_Q (a, b) { - var ota = _obj_type(a), otb = _obj_type(b); - if (!(ota === otb || (_sequential_Q(a) && _sequential_Q(b)))) { - return false; - } - switch (ota) { - case 'symbol': return a.value === b.value; - case 'list': - case 'vector': - if (a.length !== b.length) { return false; } - for (var i=0; i - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Julia -RUN apt-get -y install software-properties-common -RUN apt-add-repository -y ppa:staticfloat/juliareleases -RUN apt-get update -y -RUN apt-get -y install julia - +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Julia +RUN apt-get -y install software-properties-common +RUN apt-add-repository -y ppa:staticfloat/juliareleases +RUN apt-get update -y +RUN apt-get -y install julia + diff --git a/impls/julia/Makefile b/impls/julia/Makefile index 82fa2ef848..376cd696a1 100644 --- a/impls/julia/Makefile +++ b/impls/julia/Makefile @@ -1,4 +1,4 @@ -all: - -clean: - +all: + +clean: + diff --git a/impls/julia/core.jl b/impls/julia/core.jl index a210db292e..9665b4fda7 100644 --- a/impls/julia/core.jl +++ b/impls/julia/core.jl @@ -1,141 +1,141 @@ -module core - -import types -import reader -using printer -import readline_mod - -export ns - -function string_Q(obj) - isa(obj,AbstractString) && (length(obj) == 0 || obj[1] != '\u029e') -end - -function keyword_Q(obj) - isa(obj,AbstractString) && (length(obj) > 0 && obj[1] == '\u029e') -end - -function concat(args...) - res = [] - for a=args - res = [res; Any[a...]] - end - res -end - -function do_apply(f, all_args...) - fn = isa(f,types.MalFunc) ? f.fn : f - args = concat(all_args[1:end-1], all_args[end]) - fn(args...) -end - -function do_map(a,b) - # map and convert to array/list - if isa(a,types.MalFunc) - collect(map(a.fn,b)) - else - collect(map(a,b)) - end -end - -function conj(seq, args...) - if isa(seq,Array) - concat(reverse(args), seq) - else - tuple(concat(seq, args)...) - end -end - -function do_seq(obj) - if isa(obj,Array) - length(obj) > 0 ? obj : nothing - elseif isa(obj,Tuple) - length(obj) > 0 ? Any[obj...] : nothing - elseif isa(obj,AbstractString) - length(obj) > 0 ? [string(c) for c=obj] : nothing - elseif obj == nothing - nothing - else - error("seq: called on non-sequence") - end -end - - -function with_meta(obj, meta) - new_obj = types.copy(obj) - new_obj.meta = meta - new_obj -end - -ns = Dict{Any,Any}( - symbol("=") => (a,b) -> types.equal_Q(a, b), - :throw => (a) -> throw(types.MalException(a)), - - symbol("nil?") => (a) -> a === nothing, - symbol("true?") => (a) -> a === true, - symbol("false?") => (a) -> a === false, - symbol("string?") => string_Q, - symbol("symbol") => (a) -> symbol(a), - symbol("symbol?") => (a) -> typeof(a) === Symbol, - symbol("keyword") => (a) -> a[1] == '\u029e' ? a : "\u029e$(a)", - symbol("keyword?") => keyword_Q, - symbol("number?") => (a) -> isa(a, AbstractFloat) || isa(a, Int64), - symbol("fn?") => (a) -> isa(a, Function) || (isa(a, types.MalFunc) && !a.ismacro), - symbol("macro?") => (a) -> isa(a, types.MalFunc) && a.ismacro, - - symbol("pr-str") => (a...) -> join(map((e)->pr_str(e, true),a)," "), - :str => (a...) -> join(map((e)->pr_str(e, false),a),""), - :prn => (a...) -> println(join(map((e)->pr_str(e, true),a)," ")), - :println => (a...) -> println(join(map((e)->pr_str(e, false),a)," ")), - symbol("read-string") => (a) -> reader.read_str(a), - :readline => readline_mod.do_readline, - :slurp => (a) -> readall(open(a)), - - :< => <, - :<= => <=, - :> => >, - :>= => >=, - :+ => +, - :- => -, - symbol("*") => *, - :/ => div, - symbol("time-ms") => () -> round(Int, time()*1000), - - :list => (a...) -> Any[a...], - symbol("list?") => (a) -> isa(a, Array), - :vector => (a...) -> tuple(a...), - symbol("vector?") => (a) -> isa(a, Tuple), - symbol("hash-map") => types.hash_map, - symbol("map?") => (a) -> isa(a, Dict), - :assoc => (a, b...) -> merge(a, types.hash_map(b...)), - :dissoc => (a, b...) -> foldl((x,y) -> delete!(x,y),copy(a), b), - :get => (a,b) -> a === nothing ? nothing : get(a,b,nothing), - symbol("contains?") => haskey, - :keys => (a) -> [keys(a)...], - :vals => (a) -> [values(a)...], - - symbol("sequential?") => types.sequential_Q, - :cons => (a,b) -> [Any[a]; Any[b...]], - :concat => concat, - :vec => (a) -> tuple(a...), - :nth => (a,b) -> b+1 > length(a) ? error("nth: index out of range") : a[b+1], - :first => (a) -> a === nothing || isempty(a) ? nothing : first(a), - :rest => (a) -> a === nothing ? Any[] : Any[a[2:end]...], - symbol("empty?") => isempty, - :count => (a) -> a == nothing ? 0 : length(a), - :apply => do_apply, - :map => do_map, - - :conj => conj, - :seq => do_seq, - - :meta => (a) -> isa(a,types.MalFunc) ? a.meta : nothing, - symbol("with-meta") => with_meta, - :atom => (a) -> types.Atom(a), - symbol("atom?") => (a) -> isa(a,types.Atom), - :deref => (a) -> a.val, - :reset! => (a,b) -> a.val = b, - :swap! => (a,b,c...) -> a.val = do_apply(b, a.val, c), - ) - -end +module core + +import types +import reader +using printer +import readline_mod + +export ns + +function string_Q(obj) + isa(obj,AbstractString) && (length(obj) == 0 || obj[1] != '\u029e') +end + +function keyword_Q(obj) + isa(obj,AbstractString) && (length(obj) > 0 && obj[1] == '\u029e') +end + +function concat(args...) + res = [] + for a=args + res = [res; Any[a...]] + end + res +end + +function do_apply(f, all_args...) + fn = isa(f,types.MalFunc) ? f.fn : f + args = concat(all_args[1:end-1], all_args[end]) + fn(args...) +end + +function do_map(a,b) + # map and convert to array/list + if isa(a,types.MalFunc) + collect(map(a.fn,b)) + else + collect(map(a,b)) + end +end + +function conj(seq, args...) + if isa(seq,Array) + concat(reverse(args), seq) + else + tuple(concat(seq, args)...) + end +end + +function do_seq(obj) + if isa(obj,Array) + length(obj) > 0 ? obj : nothing + elseif isa(obj,Tuple) + length(obj) > 0 ? Any[obj...] : nothing + elseif isa(obj,AbstractString) + length(obj) > 0 ? [string(c) for c=obj] : nothing + elseif obj == nothing + nothing + else + error("seq: called on non-sequence") + end +end + + +function with_meta(obj, meta) + new_obj = types.copy(obj) + new_obj.meta = meta + new_obj +end + +ns = Dict{Any,Any}( + symbol("=") => (a,b) -> types.equal_Q(a, b), + :throw => (a) -> throw(types.MalException(a)), + + symbol("nil?") => (a) -> a === nothing, + symbol("true?") => (a) -> a === true, + symbol("false?") => (a) -> a === false, + symbol("string?") => string_Q, + symbol("symbol") => (a) -> symbol(a), + symbol("symbol?") => (a) -> typeof(a) === Symbol, + symbol("keyword") => (a) -> a[1] == '\u029e' ? a : "\u029e$(a)", + symbol("keyword?") => keyword_Q, + symbol("number?") => (a) -> isa(a, AbstractFloat) || isa(a, Int64), + symbol("fn?") => (a) -> isa(a, Function) || (isa(a, types.MalFunc) && !a.ismacro), + symbol("macro?") => (a) -> isa(a, types.MalFunc) && a.ismacro, + + symbol("pr-str") => (a...) -> join(map((e)->pr_str(e, true),a)," "), + :str => (a...) -> join(map((e)->pr_str(e, false),a),""), + :prn => (a...) -> println(join(map((e)->pr_str(e, true),a)," ")), + :println => (a...) -> println(join(map((e)->pr_str(e, false),a)," ")), + symbol("read-string") => (a) -> reader.read_str(a), + :readline => readline_mod.do_readline, + :slurp => (a) -> readall(open(a)), + + :< => <, + :<= => <=, + :> => >, + :>= => >=, + :+ => +, + :- => -, + symbol("*") => *, + :/ => div, + symbol("time-ms") => () -> round(Int, time()*1000), + + :list => (a...) -> Any[a...], + symbol("list?") => (a) -> isa(a, Array), + :vector => (a...) -> tuple(a...), + symbol("vector?") => (a) -> isa(a, Tuple), + symbol("hash-map") => types.hash_map, + symbol("map?") => (a) -> isa(a, Dict), + :assoc => (a, b...) -> merge(a, types.hash_map(b...)), + :dissoc => (a, b...) -> foldl((x,y) -> delete!(x,y),copy(a), b), + :get => (a,b) -> a === nothing ? nothing : get(a,b,nothing), + symbol("contains?") => haskey, + :keys => (a) -> [keys(a)...], + :vals => (a) -> [values(a)...], + + symbol("sequential?") => types.sequential_Q, + :cons => (a,b) -> [Any[a]; Any[b...]], + :concat => concat, + :vec => (a) -> tuple(a...), + :nth => (a,b) -> b+1 > length(a) ? error("nth: index out of range") : a[b+1], + :first => (a) -> a === nothing || isempty(a) ? nothing : first(a), + :rest => (a) -> a === nothing ? Any[] : Any[a[2:end]...], + symbol("empty?") => isempty, + :count => (a) -> a == nothing ? 0 : length(a), + :apply => do_apply, + :map => do_map, + + :conj => conj, + :seq => do_seq, + + :meta => (a) -> isa(a,types.MalFunc) ? a.meta : nothing, + symbol("with-meta") => with_meta, + :atom => (a) -> types.Atom(a), + symbol("atom?") => (a) -> isa(a,types.Atom), + :deref => (a) -> a.val, + :reset! => (a,b) -> a.val = b, + :swap! => (a,b,c...) -> a.val = do_apply(b, a.val, c), + ) + +end diff --git a/impls/julia/env.jl b/impls/julia/env.jl index 2451b51fa9..230c756b32 100644 --- a/impls/julia/env.jl +++ b/impls/julia/env.jl @@ -1,55 +1,55 @@ -module env - -export Env, env_set, env_find, env_get - -type Env - outer::Any - data::Dict{Symbol,Any} -end - -function Env() - Env(nothing, Dict()) -end - -function Env(outer) - Env(outer, Dict()) -end - -function Env(outer, binds, exprs) - e = Env(outer, Dict()) - for i=1:length(binds) - if binds[i] == :& - e.data[binds[i+1]] = exprs[i:end] - break - else - e.data[binds[i]] = exprs[i] - end - end - e -end - - -function env_set(env::Env, k::Symbol, v) - env.data[k] = v -end - -function env_find(env::Env, k::Symbol) - if haskey(env.data, k) - env - elseif env.outer != nothing - env_find(env.outer, k) - else - nothing - end -end - -function env_get(env::Env, k::Symbol) - e = env_find(env, k) - if e != nothing - e.data[k] - else - error("'$(string(k))' not found") - end -end - -end +module env + +export Env, env_set, env_find, env_get + +type Env + outer::Any + data::Dict{Symbol,Any} +end + +function Env() + Env(nothing, Dict()) +end + +function Env(outer) + Env(outer, Dict()) +end + +function Env(outer, binds, exprs) + e = Env(outer, Dict()) + for i=1:length(binds) + if binds[i] == :& + e.data[binds[i+1]] = exprs[i:end] + break + else + e.data[binds[i]] = exprs[i] + end + end + e +end + + +function env_set(env::Env, k::Symbol, v) + env.data[k] = v +end + +function env_find(env::Env, k::Symbol) + if haskey(env.data, k) + env + elseif env.outer != nothing + env_find(env.outer, k) + else + nothing + end +end + +function env_get(env::Env, k::Symbol) + e = env_find(env, k) + if e != nothing + e.data[k] + else + error("'$(string(k))' not found") + end +end + +end diff --git a/impls/julia/printer.jl b/impls/julia/printer.jl index 44e0b1e850..99603226b2 100644 --- a/impls/julia/printer.jl +++ b/impls/julia/printer.jl @@ -1,40 +1,40 @@ -module printer - -import types - -export pr_str - -function pr_str(obj, print_readably=true) - _r = print_readably - if isa(obj, Array) - "($(join([pr_str(o, _r) for o=obj], " ")))" - elseif isa(obj, Tuple) - "[$(join([pr_str(o, _r) for o=obj], " "))]" - elseif isa(obj, Dict) - "{$(join(["$(pr_str(o[1],_r)) $(pr_str(o[2],_r))" for o=obj], " "))}" - elseif isa(obj, AbstractString) - if length(obj) > 0 && obj[1] == '\u029e' - ":$(obj[3:end])" - elseif _r - str = replace(replace(replace(obj, - "\\", "\\\\"), - "\"", "\\\""), - "\n", "\\n") - "\"$(str)\"" - else - obj - end - elseif obj == nothing - "nil" - elseif typeof(obj) == types.MalFunc - "(fn* $(pr_str(obj.params,true)) $(pr_str(obj.ast,true)))" - elseif typeof(obj) == types.Atom - "(atom $(pr_str(obj.val,true)))" - elseif typeof(obj) == Function - "#" - else - string(obj) - end -end - -end +module printer + +import types + +export pr_str + +function pr_str(obj, print_readably=true) + _r = print_readably + if isa(obj, Array) + "($(join([pr_str(o, _r) for o=obj], " ")))" + elseif isa(obj, Tuple) + "[$(join([pr_str(o, _r) for o=obj], " "))]" + elseif isa(obj, Dict) + "{$(join(["$(pr_str(o[1],_r)) $(pr_str(o[2],_r))" for o=obj], " "))}" + elseif isa(obj, AbstractString) + if length(obj) > 0 && obj[1] == '\u029e' + ":$(obj[3:end])" + elseif _r + str = replace(replace(replace(obj, + "\\", "\\\\"), + "\"", "\\\""), + "\n", "\\n") + "\"$(str)\"" + else + obj + end + elseif obj == nothing + "nil" + elseif typeof(obj) == types.MalFunc + "(fn* $(pr_str(obj.params,true)) $(pr_str(obj.ast,true)))" + elseif typeof(obj) == types.Atom + "(atom $(pr_str(obj.val,true)))" + elseif typeof(obj) == Function + "#" + else + string(obj) + end +end + +end diff --git a/impls/julia/reader.jl b/impls/julia/reader.jl index 2a46cc4f57..b752abb284 100644 --- a/impls/julia/reader.jl +++ b/impls/julia/reader.jl @@ -1,132 +1,132 @@ -module reader - -export read_str - -import types - -type Reader - tokens - position::Int64 -end - -function next(rdr::Reader) - if rdr.position > length(rdr.tokens) - return nothing - end - rdr.position += 1 - rdr.tokens[rdr.position-1] -end - -function peek(rdr::Reader) - if rdr.position > length(rdr.tokens) - return nothing - end - rdr.tokens[rdr.position] -end - - -function tokenize(str) - re = r"[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:\\.|[^\\\"])*\"?|;.*|[^\s\[\]{}('\"`,;)]*)" - tokens = map((m) -> m.captures[1], eachmatch(re, str)) - filter((t) -> t != "" && t[1] != ';', tokens) -end - -function read_atom(rdr) - token = next(rdr) - if ismatch(r"^-?[0-9]+$", token) - parse(Int,token) - elseif ismatch(r"^-?[0-9][0-9.]*$", token) - float(token) - elseif ismatch(r"^\"(?:\\.|[^\\\"])*\"$", token) - replace(token[2:end-1], r"\\.", (r) -> get(Dict("\\n"=>"\n", - "\\\""=>"\"", - "\\\\"=>"\\"), r, r)) - elseif ismatch(r"^\".*$", token) - error("expected '\"', got EOF") - elseif token[1] == ':' - "\u029e$(token[2:end])" - elseif token == "nil" - nothing - elseif token == "true" - true - elseif token == "false" - false - else - symbol(token) - end -end - -function read_list(rdr, start="(", last=")") - ast = Any[] - token = next(rdr) - if (token != start) - error("expected '$(start)'") - end - while ((token = peek(rdr)) != last) - if token == nothing - error("expected '$(last)', got EOF") - end - push!(ast, read_form(rdr)) - end - next(rdr) - ast -end - -function read_vector(rdr) - lst = read_list(rdr, "[", "]") - tuple(lst...) -end - -function read_hash_map(rdr) - lst = read_list(rdr, "{", "}") - types.hash_map(lst...) -end - -function read_form(rdr) - token = peek(rdr) - if token == "'" - next(rdr) - [[:quote]; Any[read_form(rdr)]] - elseif token == "`" - next(rdr) - [[:quasiquote]; Any[read_form(rdr)]] - elseif token == "~" - next(rdr) - [[:unquote]; Any[read_form(rdr)]] - elseif token == "~@" - next(rdr) - [[symbol("splice-unquote")]; Any[read_form(rdr)]] - elseif token == "^" - next(rdr) - meta = read_form(rdr) - [[symbol("with-meta")]; Any[read_form(rdr)]; Any[meta]] - elseif token == "@" - next(rdr) - [[symbol("deref")]; Any[read_form(rdr)]] - - elseif token == ")" - error("unexpected ')'") - elseif token == "(" - read_list(rdr) - elseif token == "]" - error("unexpected ']'") - elseif token == "[" - read_vector(rdr) - elseif token == "}" - error("unexpected '}'") - elseif token == "{" - read_hash_map(rdr) - else - read_atom(rdr) - end -end - -function read_str(str) - tokens = tokenize(str) - if length(tokens) == 0 - return nothing - end - read_form(Reader(tokens, 1)) -end - -end +module reader + +export read_str + +import types + +type Reader + tokens + position::Int64 +end + +function next(rdr::Reader) + if rdr.position > length(rdr.tokens) + return nothing + end + rdr.position += 1 + rdr.tokens[rdr.position-1] +end + +function peek(rdr::Reader) + if rdr.position > length(rdr.tokens) + return nothing + end + rdr.tokens[rdr.position] +end + + +function tokenize(str) + re = r"[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:\\.|[^\\\"])*\"?|;.*|[^\s\[\]{}('\"`,;)]*)" + tokens = map((m) -> m.captures[1], eachmatch(re, str)) + filter((t) -> t != "" && t[1] != ';', tokens) +end + +function read_atom(rdr) + token = next(rdr) + if ismatch(r"^-?[0-9]+$", token) + parse(Int,token) + elseif ismatch(r"^-?[0-9][0-9.]*$", token) + float(token) + elseif ismatch(r"^\"(?:\\.|[^\\\"])*\"$", token) + replace(token[2:end-1], r"\\.", (r) -> get(Dict("\\n"=>"\n", + "\\\""=>"\"", + "\\\\"=>"\\"), r, r)) + elseif ismatch(r"^\".*$", token) + error("expected '\"', got EOF") + elseif token[1] == ':' + "\u029e$(token[2:end])" + elseif token == "nil" + nothing + elseif token == "true" + true + elseif token == "false" + false + else + symbol(token) + end +end + +function read_list(rdr, start="(", last=")") + ast = Any[] + token = next(rdr) + if (token != start) + error("expected '$(start)'") + end + while ((token = peek(rdr)) != last) + if token == nothing + error("expected '$(last)', got EOF") + end + push!(ast, read_form(rdr)) + end + next(rdr) + ast +end + +function read_vector(rdr) + lst = read_list(rdr, "[", "]") + tuple(lst...) +end + +function read_hash_map(rdr) + lst = read_list(rdr, "{", "}") + types.hash_map(lst...) +end + +function read_form(rdr) + token = peek(rdr) + if token == "'" + next(rdr) + [[:quote]; Any[read_form(rdr)]] + elseif token == "`" + next(rdr) + [[:quasiquote]; Any[read_form(rdr)]] + elseif token == "~" + next(rdr) + [[:unquote]; Any[read_form(rdr)]] + elseif token == "~@" + next(rdr) + [[symbol("splice-unquote")]; Any[read_form(rdr)]] + elseif token == "^" + next(rdr) + meta = read_form(rdr) + [[symbol("with-meta")]; Any[read_form(rdr)]; Any[meta]] + elseif token == "@" + next(rdr) + [[symbol("deref")]; Any[read_form(rdr)]] + + elseif token == ")" + error("unexpected ')'") + elseif token == "(" + read_list(rdr) + elseif token == "]" + error("unexpected ']'") + elseif token == "[" + read_vector(rdr) + elseif token == "}" + error("unexpected '}'") + elseif token == "{" + read_hash_map(rdr) + else + read_atom(rdr) + end +end + +function read_str(str) + tokens = tokenize(str) + if length(tokens) == 0 + return nothing + end + read_form(Reader(tokens, 1)) +end + +end diff --git a/impls/julia/readline_mod.jl b/impls/julia/readline_mod.jl index 94c47f762f..12150ac28e 100644 --- a/impls/julia/readline_mod.jl +++ b/impls/julia/readline_mod.jl @@ -1,15 +1,15 @@ -module readline_mod - -export do_readline - -function do_readline(prompt) - print(prompt) - flush(STDOUT) - line = readline(STDIN) - if line == "" - return nothing - end - chomp(line) -end - -end +module readline_mod + +export do_readline + +function do_readline(prompt) + print(prompt) + flush(STDOUT) + line = readline(STDIN) + if line == "" + return nothing + end + chomp(line) +end + +end diff --git a/impls/julia/run b/impls/julia/run index 2acaf1b202..4adb469624 100755 --- a/impls/julia/run +++ b/impls/julia/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec julia $(dirname $0)/${STEP:-stepA_mal}.jl "${@}" +#!/bin/bash +exec julia $(dirname $0)/${STEP:-stepA_mal}.jl "${@}" diff --git a/impls/julia/step0_repl.jl b/impls/julia/step0_repl.jl index 049cde1418..78c884e721 100755 --- a/impls/julia/step0_repl.jl +++ b/impls/julia/step0_repl.jl @@ -1,30 +1,30 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod - -# READ -function READ(str) - str -end - -# EVAL -function EVAL(ast, env) - ast -end - -# PRINT -function PRINT(exp) - exp -end - -# REPL -function REP(str) - return PRINT(EVAL(READ(str), [])) -end - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - println(REP(line)) -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod + +# READ +function READ(str) + str +end + +# EVAL +function EVAL(ast, env) + ast +end + +# PRINT +function PRINT(exp) + exp +end + +# REPL +function REP(str) + return PRINT(EVAL(READ(str), [])) +end + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + println(REP(line)) +end diff --git a/impls/julia/step1_read_print.jl b/impls/julia/step1_read_print.jl index 604b1f9c3d..1b682668d1 100755 --- a/impls/julia/step1_read_print.jl +++ b/impls/julia/step1_read_print.jl @@ -1,43 +1,43 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function EVAL(ast, env) - ast -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -function REP(str) - return PRINT(EVAL(READ(str), [])) -end - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function EVAL(ast, env) + ast +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +function REP(str) + return PRINT(EVAL(READ(str), [])) +end + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + println() + end +end diff --git a/impls/julia/step2_eval.jl b/impls/julia/step2_eval.jl index f61697866e..7a68eb01de 100755 --- a/impls/julia/step2_eval.jl +++ b/impls/julia/step2_eval.jl @@ -1,65 +1,65 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function eval_ast(ast, env) - if typeof(ast) == Symbol - env[ast] - elseif isa(ast, Array) || isa(ast, Tuple) - map((x) -> EVAL(x,env), ast) - elseif isa(ast, Dict) - [x[1] => EVAL(x[2], env) for x=ast] - else - ast - end -end - -function EVAL(ast, env) - if !isa(ast, Array) return eval_ast(ast, env) end - if isempty(ast) return ast end - - # apply - el = eval_ast(ast, env) - f, args = el[1], el[2:end] - f(args...) -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -repl_env = Dict{Any,Any}(:+ => +, - :- => -, - :* => *, - :/ => div) -function REP(str) - return PRINT(EVAL(READ(str), repl_env)) -end - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function eval_ast(ast, env) + if typeof(ast) == Symbol + env[ast] + elseif isa(ast, Array) || isa(ast, Tuple) + map((x) -> EVAL(x,env), ast) + elseif isa(ast, Dict) + [x[1] => EVAL(x[2], env) for x=ast] + else + ast + end +end + +function EVAL(ast, env) + if !isa(ast, Array) return eval_ast(ast, env) end + if isempty(ast) return ast end + + # apply + el = eval_ast(ast, env) + f, args = el[1], el[2:end] + f(args...) +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +repl_env = Dict{Any,Any}(:+ => +, + :- => -, + :* => *, + :/ => div) +function REP(str) + return PRINT(EVAL(READ(str), repl_env)) +end + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + println() + end +end diff --git a/impls/julia/step3_env.jl b/impls/julia/step3_env.jl index 1436bcb6ef..990c10761f 100755 --- a/impls/julia/step3_env.jl +++ b/impls/julia/step3_env.jl @@ -1,77 +1,77 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer -using env - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function eval_ast(ast, env) - if typeof(ast) == Symbol - env_get(env,ast) - elseif isa(ast, Array) || isa(ast, Tuple) - map((x) -> EVAL(x,env), ast) - elseif isa(ast, Dict) - [x[1] => EVAL(x[2], env) for x=ast] - else - ast - end -end - -function EVAL(ast, env) - if !isa(ast, Array) return eval_ast(ast, env) end - if isempty(ast) return ast end - - # apply - if :def! == ast[1] - env_set(env, ast[2], EVAL(ast[3], env)) - elseif symbol("let*") == ast[1] - let_env = Env(env) - for i = 1:2:length(ast[2]) - env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) - end - EVAL(ast[3], let_env) - else - el = eval_ast(ast, env) - f, args = el[1], el[2:end] - f(args...) - end -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -repl_env = Env(nothing, - Dict{Any,Any}(:+ => +, - :- => -, - :* => *, - :/ => div)) -function REP(str) - return PRINT(EVAL(READ(str), repl_env)) -end - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer +using env + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function eval_ast(ast, env) + if typeof(ast) == Symbol + env_get(env,ast) + elseif isa(ast, Array) || isa(ast, Tuple) + map((x) -> EVAL(x,env), ast) + elseif isa(ast, Dict) + [x[1] => EVAL(x[2], env) for x=ast] + else + ast + end +end + +function EVAL(ast, env) + if !isa(ast, Array) return eval_ast(ast, env) end + if isempty(ast) return ast end + + # apply + if :def! == ast[1] + env_set(env, ast[2], EVAL(ast[3], env)) + elseif symbol("let*") == ast[1] + let_env = Env(env) + for i = 1:2:length(ast[2]) + env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) + end + EVAL(ast[3], let_env) + else + el = eval_ast(ast, env) + f, args = el[1], el[2:end] + f(args...) + end +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +repl_env = Env(nothing, + Dict{Any,Any}(:+ => +, + :- => -, + :* => *, + :/ => div)) +function REP(str) + return PRINT(EVAL(READ(str), repl_env)) +end + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + println() + end +end diff --git a/impls/julia/step4_if_fn_do.jl b/impls/julia/step4_if_fn_do.jl index 5891975874..c21155b501 100755 --- a/impls/julia/step4_if_fn_do.jl +++ b/impls/julia/step4_if_fn_do.jl @@ -1,97 +1,97 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer -using env -import core - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function eval_ast(ast, env) - if typeof(ast) == Symbol - env_get(env,ast) - elseif isa(ast, Array) || isa(ast, Tuple) - map((x) -> EVAL(x,env), ast) - elseif isa(ast, Dict) - [x[1] => EVAL(x[2], env) for x=ast] - else - ast - end -end - -function EVAL(ast, env) - if !isa(ast, Array) return eval_ast(ast, env) end - if isempty(ast) return ast end - - # apply - if :def! == ast[1] - env_set(env, ast[2], EVAL(ast[3], env)) - elseif symbol("let*") == ast[1] - let_env = Env(env) - for i = 1:2:length(ast[2]) - env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) - end - EVAL(ast[3], let_env) - elseif :do == ast[1] - eval_ast(ast[2:end], env)[end] - elseif :if == ast[1] - cond = EVAL(ast[2], env) - if cond === nothing || cond === false - if length(ast) >= 4 - EVAL(ast[4], env) - else - nothing - end - else - EVAL(ast[3], env) - end - elseif symbol("fn*") == ast[1] - (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])) - else - el = eval_ast(ast, env) - f, args = el[1], el[2:end] - f(args...) - end -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -repl_env = nothing -function REP(str) - return PRINT(EVAL(READ(str), repl_env)) -end - -# core.jl: defined using Julia -repl_env = Env(nothing, core.ns) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - if !isa(e, StackOverflowError) - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - end - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer +using env +import core + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function eval_ast(ast, env) + if typeof(ast) == Symbol + env_get(env,ast) + elseif isa(ast, Array) || isa(ast, Tuple) + map((x) -> EVAL(x,env), ast) + elseif isa(ast, Dict) + [x[1] => EVAL(x[2], env) for x=ast] + else + ast + end +end + +function EVAL(ast, env) + if !isa(ast, Array) return eval_ast(ast, env) end + if isempty(ast) return ast end + + # apply + if :def! == ast[1] + env_set(env, ast[2], EVAL(ast[3], env)) + elseif symbol("let*") == ast[1] + let_env = Env(env) + for i = 1:2:length(ast[2]) + env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) + end + EVAL(ast[3], let_env) + elseif :do == ast[1] + eval_ast(ast[2:end], env)[end] + elseif :if == ast[1] + cond = EVAL(ast[2], env) + if cond === nothing || cond === false + if length(ast) >= 4 + EVAL(ast[4], env) + else + nothing + end + else + EVAL(ast[3], env) + end + elseif symbol("fn*") == ast[1] + (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])) + else + el = eval_ast(ast, env) + f, args = el[1], el[2:end] + f(args...) + end +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +repl_env = nothing +function REP(str) + return PRINT(EVAL(READ(str), repl_env)) +end + +# core.jl: defined using Julia +repl_env = Env(nothing, core.ns) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + if !isa(e, StackOverflowError) + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + end + println() + end +end diff --git a/impls/julia/step5_tco.jl b/impls/julia/step5_tco.jl index 42b48febbe..4e0e1f49f3 100755 --- a/impls/julia/step5_tco.jl +++ b/impls/julia/step5_tco.jl @@ -1,116 +1,116 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer -using env -import core -using types - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function eval_ast(ast, env) - if typeof(ast) == Symbol - env_get(env,ast) - elseif isa(ast, Array) || isa(ast, Tuple) - map((x) -> EVAL(x,env), ast) - elseif isa(ast, Dict) - [x[1] => EVAL(x[2], env) for x=ast] - else - ast - end -end - -function EVAL(ast, env) - while true - #println("EVAL: $(printer.pr_str(ast,true))") - if !isa(ast, Array) return eval_ast(ast, env) end - if isempty(ast) return ast end - - # apply - if :def! == ast[1] - return env_set(env, ast[2], EVAL(ast[3], env)) - elseif symbol("let*") == ast[1] - let_env = Env(env) - for i = 1:2:length(ast[2]) - env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) - end - env = let_env - ast = ast[3] - # TCO loop - elseif :do == ast[1] - eval_ast(ast[2:end-1], env) - ast = ast[end] - # TCO loop - elseif :if == ast[1] - cond = EVAL(ast[2], env) - if cond === nothing || cond === false - if length(ast) >= 4 - ast = ast[4] - # TCO loop - else - return nothing - end - else - ast = ast[3] - # TCO loop - end - elseif symbol("fn*") == ast[1] - return MalFunc( - (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), - ast[3], env, ast[2]) - else - el = eval_ast(ast, env) - f, args = el[1], el[2:end] - if isa(f, MalFunc) - ast = f.ast - env = Env(f.env, f.params, args) - # TCO loop - else - return f(args...) - end - end - end -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -repl_env = nothing -function REP(str) - return PRINT(EVAL(READ(str), repl_env)) -end - -# core.jl: defined using Julia -repl_env = Env(nothing, core.ns) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - # TODO: show at least part of stack - if !isa(e, StackOverflowError) - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - end - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer +using env +import core +using types + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function eval_ast(ast, env) + if typeof(ast) == Symbol + env_get(env,ast) + elseif isa(ast, Array) || isa(ast, Tuple) + map((x) -> EVAL(x,env), ast) + elseif isa(ast, Dict) + [x[1] => EVAL(x[2], env) for x=ast] + else + ast + end +end + +function EVAL(ast, env) + while true + #println("EVAL: $(printer.pr_str(ast,true))") + if !isa(ast, Array) return eval_ast(ast, env) end + if isempty(ast) return ast end + + # apply + if :def! == ast[1] + return env_set(env, ast[2], EVAL(ast[3], env)) + elseif symbol("let*") == ast[1] + let_env = Env(env) + for i = 1:2:length(ast[2]) + env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) + end + env = let_env + ast = ast[3] + # TCO loop + elseif :do == ast[1] + eval_ast(ast[2:end-1], env) + ast = ast[end] + # TCO loop + elseif :if == ast[1] + cond = EVAL(ast[2], env) + if cond === nothing || cond === false + if length(ast) >= 4 + ast = ast[4] + # TCO loop + else + return nothing + end + else + ast = ast[3] + # TCO loop + end + elseif symbol("fn*") == ast[1] + return MalFunc( + (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), + ast[3], env, ast[2]) + else + el = eval_ast(ast, env) + f, args = el[1], el[2:end] + if isa(f, MalFunc) + ast = f.ast + env = Env(f.env, f.params, args) + # TCO loop + else + return f(args...) + end + end + end +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +repl_env = nothing +function REP(str) + return PRINT(EVAL(READ(str), repl_env)) +end + +# core.jl: defined using Julia +repl_env = Env(nothing, core.ns) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + # TODO: show at least part of stack + if !isa(e, StackOverflowError) + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + end + println() + end +end diff --git a/impls/julia/step6_file.jl b/impls/julia/step6_file.jl index 51190c8e8f..c96421e365 100755 --- a/impls/julia/step6_file.jl +++ b/impls/julia/step6_file.jl @@ -1,124 +1,124 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer -using env -import core -using types - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function eval_ast(ast, env) - if typeof(ast) == Symbol - env_get(env,ast) - elseif isa(ast, Array) || isa(ast, Tuple) - map((x) -> EVAL(x,env), ast) - elseif isa(ast, Dict) - [x[1] => EVAL(x[2], env) for x=ast] - else - ast - end -end - -function EVAL(ast, env) - while true - #println("EVAL: $(printer.pr_str(ast,true))") - if !isa(ast, Array) return eval_ast(ast, env) end - if isempty(ast) return ast end - - # apply - if :def! == ast[1] - return env_set(env, ast[2], EVAL(ast[3], env)) - elseif symbol("let*") == ast[1] - let_env = Env(env) - for i = 1:2:length(ast[2]) - env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) - end - env = let_env - ast = ast[3] - # TCO loop - elseif :do == ast[1] - eval_ast(ast[2:end-1], env) - ast = ast[end] - # TCO loop - elseif :if == ast[1] - cond = EVAL(ast[2], env) - if cond === nothing || cond === false - if length(ast) >= 4 - ast = ast[4] - # TCO loop - else - return nothing - end - else - ast = ast[3] - # TCO loop - end - elseif symbol("fn*") == ast[1] - return MalFunc( - (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), - ast[3], env, ast[2]) - else - el = eval_ast(ast, env) - f, args = el[1], el[2:end] - if isa(f, MalFunc) - ast = f.ast - env = Env(f.env, f.params, args) - # TCO loop - else - return f(args...) - end - end - end -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -repl_env = nothing -function REP(str) - return PRINT(EVAL(READ(str), repl_env)) -end - -# core.jl: defined using Julia -repl_env = Env(nothing, core.ns) -env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) -env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if length(ARGS) > 0 - REP("(load-file \"$(ARGS[1])\")") - exit(0) -end - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - # TODO: show at least part of stack - if !isa(e, StackOverflowError) - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - end - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer +using env +import core +using types + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function eval_ast(ast, env) + if typeof(ast) == Symbol + env_get(env,ast) + elseif isa(ast, Array) || isa(ast, Tuple) + map((x) -> EVAL(x,env), ast) + elseif isa(ast, Dict) + [x[1] => EVAL(x[2], env) for x=ast] + else + ast + end +end + +function EVAL(ast, env) + while true + #println("EVAL: $(printer.pr_str(ast,true))") + if !isa(ast, Array) return eval_ast(ast, env) end + if isempty(ast) return ast end + + # apply + if :def! == ast[1] + return env_set(env, ast[2], EVAL(ast[3], env)) + elseif symbol("let*") == ast[1] + let_env = Env(env) + for i = 1:2:length(ast[2]) + env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) + end + env = let_env + ast = ast[3] + # TCO loop + elseif :do == ast[1] + eval_ast(ast[2:end-1], env) + ast = ast[end] + # TCO loop + elseif :if == ast[1] + cond = EVAL(ast[2], env) + if cond === nothing || cond === false + if length(ast) >= 4 + ast = ast[4] + # TCO loop + else + return nothing + end + else + ast = ast[3] + # TCO loop + end + elseif symbol("fn*") == ast[1] + return MalFunc( + (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), + ast[3], env, ast[2]) + else + el = eval_ast(ast, env) + f, args = el[1], el[2:end] + if isa(f, MalFunc) + ast = f.ast + env = Env(f.env, f.params, args) + # TCO loop + else + return f(args...) + end + end + end +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +repl_env = nothing +function REP(str) + return PRINT(EVAL(READ(str), repl_env)) +end + +# core.jl: defined using Julia +repl_env = Env(nothing, core.ns) +env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) +env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if length(ARGS) > 0 + REP("(load-file \"$(ARGS[1])\")") + exit(0) +end + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + # TODO: show at least part of stack + if !isa(e, StackOverflowError) + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + end + println() + end +end diff --git a/impls/julia/step7_quote.jl b/impls/julia/step7_quote.jl index d21e423951..82c29ca435 100755 --- a/impls/julia/step7_quote.jl +++ b/impls/julia/step7_quote.jl @@ -1,160 +1,160 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer -using env -import core -using types - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function quasiquote_loop(elts) - acc = Any[] - for i in length(elts):-1:1 - elt = elts[i] - if isa(elt, Array) && length(elt) == 2 && elt[1] == symbol("splice-unquote") - acc = Any[:concat, elt[2], acc] - else - acc = Any[:cons, quasiquote(elt), acc] - end - end - return acc -end - -function quasiquote(ast) - if isa(ast, Array) - if length(ast) == 2 && ast[1] == symbol("unquote") - ast[2] - else - quasiquote_loop(ast) - end - elseif isa(ast, Tuple) - Any[:vec, quasiquote_loop(ast)] - elseif typeof(ast) == Symbol || isa(ast, Dict) - Any[:quote, ast] - else - ast - end -end - -function eval_ast(ast, env) - if typeof(ast) == Symbol - env_get(env,ast) - elseif isa(ast, Array) || isa(ast, Tuple) - map((x) -> EVAL(x,env), ast) - elseif isa(ast, Dict) - [x[1] => EVAL(x[2], env) for x=ast] - else - ast - end -end - -function EVAL(ast, env) - while true - #println("EVAL: $(printer.pr_str(ast,true))") - if !isa(ast, Array) return eval_ast(ast, env) end - if isempty(ast) return ast end - - # apply - if :def! == ast[1] - return env_set(env, ast[2], EVAL(ast[3], env)) - elseif symbol("let*") == ast[1] - let_env = Env(env) - for i = 1:2:length(ast[2]) - env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) - end - env = let_env - ast = ast[3] - # TCO loop - elseif :quote == ast[1] - return ast[2] - elseif :quasiquoteexpand == ast[1] - return quasiquote(ast[2]) - elseif :quasiquote == ast[1] - ast = quasiquote(ast[2]) - # TCO loop - elseif :do == ast[1] - eval_ast(ast[2:end-1], env) - ast = ast[end] - # TCO loop - elseif :if == ast[1] - cond = EVAL(ast[2], env) - if cond === nothing || cond === false - if length(ast) >= 4 - ast = ast[4] - # TCO loop - else - return nothing - end - else - ast = ast[3] - # TCO loop - end - elseif symbol("fn*") == ast[1] - return MalFunc( - (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), - ast[3], env, ast[2]) - else - el = eval_ast(ast, env) - f, args = el[1], el[2:end] - if isa(f, MalFunc) - ast = f.ast - env = Env(f.env, f.params, args) - # TCO loop - else - return f(args...) - end - end - end -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -repl_env = nothing -function REP(str) - return PRINT(EVAL(READ(str), repl_env)) -end - -# core.jl: defined using Julia -repl_env = Env(nothing, core.ns) -env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) -env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if length(ARGS) > 0 - REP("(load-file \"$(ARGS[1])\")") - exit(0) -end - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - # TODO: show at least part of stack - if !isa(e, StackOverflowError) - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - end - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer +using env +import core +using types + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function quasiquote_loop(elts) + acc = Any[] + for i in length(elts):-1:1 + elt = elts[i] + if isa(elt, Array) && length(elt) == 2 && elt[1] == symbol("splice-unquote") + acc = Any[:concat, elt[2], acc] + else + acc = Any[:cons, quasiquote(elt), acc] + end + end + return acc +end + +function quasiquote(ast) + if isa(ast, Array) + if length(ast) == 2 && ast[1] == symbol("unquote") + ast[2] + else + quasiquote_loop(ast) + end + elseif isa(ast, Tuple) + Any[:vec, quasiquote_loop(ast)] + elseif typeof(ast) == Symbol || isa(ast, Dict) + Any[:quote, ast] + else + ast + end +end + +function eval_ast(ast, env) + if typeof(ast) == Symbol + env_get(env,ast) + elseif isa(ast, Array) || isa(ast, Tuple) + map((x) -> EVAL(x,env), ast) + elseif isa(ast, Dict) + [x[1] => EVAL(x[2], env) for x=ast] + else + ast + end +end + +function EVAL(ast, env) + while true + #println("EVAL: $(printer.pr_str(ast,true))") + if !isa(ast, Array) return eval_ast(ast, env) end + if isempty(ast) return ast end + + # apply + if :def! == ast[1] + return env_set(env, ast[2], EVAL(ast[3], env)) + elseif symbol("let*") == ast[1] + let_env = Env(env) + for i = 1:2:length(ast[2]) + env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) + end + env = let_env + ast = ast[3] + # TCO loop + elseif :quote == ast[1] + return ast[2] + elseif :quasiquoteexpand == ast[1] + return quasiquote(ast[2]) + elseif :quasiquote == ast[1] + ast = quasiquote(ast[2]) + # TCO loop + elseif :do == ast[1] + eval_ast(ast[2:end-1], env) + ast = ast[end] + # TCO loop + elseif :if == ast[1] + cond = EVAL(ast[2], env) + if cond === nothing || cond === false + if length(ast) >= 4 + ast = ast[4] + # TCO loop + else + return nothing + end + else + ast = ast[3] + # TCO loop + end + elseif symbol("fn*") == ast[1] + return MalFunc( + (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), + ast[3], env, ast[2]) + else + el = eval_ast(ast, env) + f, args = el[1], el[2:end] + if isa(f, MalFunc) + ast = f.ast + env = Env(f.env, f.params, args) + # TCO loop + else + return f(args...) + end + end + end +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +repl_env = nothing +function REP(str) + return PRINT(EVAL(READ(str), repl_env)) +end + +# core.jl: defined using Julia +repl_env = Env(nothing, core.ns) +env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) +env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if length(ARGS) > 0 + REP("(load-file \"$(ARGS[1])\")") + exit(0) +end + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + # TODO: show at least part of stack + if !isa(e, StackOverflowError) + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + end + println() + end +end diff --git a/impls/julia/step8_macros.jl b/impls/julia/step8_macros.jl index 49b7833869..8b8d77c5a5 100755 --- a/impls/julia/step8_macros.jl +++ b/impls/julia/step8_macros.jl @@ -1,188 +1,188 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer -using env -import core -using types - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function quasiquote_loop(elts) - acc = Any[] - for i in length(elts):-1:1 - elt = elts[i] - if isa(elt, Array) && length(elt) == 2 && elt[1] == symbol("splice-unquote") - acc = Any[:concat, elt[2], acc] - else - acc = Any[:cons, quasiquote(elt), acc] - end - end - return acc -end - -function quasiquote(ast) - if isa(ast, Array) - if length(ast) == 2 && ast[1] == symbol("unquote") - ast[2] - else - quasiquote_loop(ast) - end - elseif isa(ast, Tuple) - Any[:vec, quasiquote_loop(ast)] - elseif typeof(ast) == Symbol || isa(ast, Dict) - Any[:quote, ast] - else - ast - end -end - -function ismacroCall(ast, env) - return isa(ast, Array) && - !isempty(ast) && - isa(ast[1], Symbol) && - env_find(env, ast[1]) != nothing && - isa(env_get(env, ast[1]), MalFunc) && - env_get(env, ast[1]).ismacro -end - -function macroexpand(ast, env) - while ismacroCall(ast, env) - mac = env_get(env, ast[1]) - ast = mac.fn(ast[2:end]...) - end - ast -end - -function eval_ast(ast, env) - if typeof(ast) == Symbol - env_get(env,ast) - elseif isa(ast, Array) || isa(ast, Tuple) - map((x) -> EVAL(x,env), ast) - elseif isa(ast, Dict) - [x[1] => EVAL(x[2], env) for x=ast] - else - ast - end -end - -function EVAL(ast, env) - while true - #println("EVAL: $(printer.pr_str(ast,true))") - if !isa(ast, Array) return eval_ast(ast, env) end - - # apply - ast = macroexpand(ast, env) - if !isa(ast, Array) return eval_ast(ast, env) end - if isempty(ast) return ast end - - if :def! == ast[1] - return env_set(env, ast[2], EVAL(ast[3], env)) - elseif symbol("let*") == ast[1] - let_env = Env(env) - for i = 1:2:length(ast[2]) - env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) - end - env = let_env - ast = ast[3] - # TCO loop - elseif :quote == ast[1] - return ast[2] - elseif :quasiquoteexpand == ast[1] - return quasiquote(ast[2]) - elseif :quasiquote == ast[1] - ast = quasiquote(ast[2]) - # TCO loop - elseif :defmacro! == ast[1] - func = EVAL(ast[3], env) - func.ismacro = true - return env_set(env, ast[2], func) - elseif :macroexpand == ast[1] - return macroexpand(ast[2], env) - elseif :do == ast[1] - eval_ast(ast[2:end-1], env) - ast = ast[end] - # TCO loop - elseif :if == ast[1] - cond = EVAL(ast[2], env) - if cond === nothing || cond === false - if length(ast) >= 4 - ast = ast[4] - # TCO loop - else - return nothing - end - else - ast = ast[3] - # TCO loop - end - elseif symbol("fn*") == ast[1] - return MalFunc( - (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), - ast[3], env, ast[2]) - else - el = eval_ast(ast, env) - f, args = el[1], el[2:end] - if isa(f, MalFunc) - ast = f.ast - env = Env(f.env, f.params, args) - # TCO loop - else - return f(args...) - end - end - end -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -repl_env = nothing -function REP(str) - return PRINT(EVAL(READ(str), repl_env)) -end - -# core.jl: defined using Julia -repl_env = Env(nothing, core.ns) -env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) -env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))") - - -if length(ARGS) > 0 - REP("(load-file \"$(ARGS[1])\")") - exit(0) -end - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - # TODO: show at least part of stack - if !isa(e, StackOverflowError) - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - end - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer +using env +import core +using types + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function quasiquote_loop(elts) + acc = Any[] + for i in length(elts):-1:1 + elt = elts[i] + if isa(elt, Array) && length(elt) == 2 && elt[1] == symbol("splice-unquote") + acc = Any[:concat, elt[2], acc] + else + acc = Any[:cons, quasiquote(elt), acc] + end + end + return acc +end + +function quasiquote(ast) + if isa(ast, Array) + if length(ast) == 2 && ast[1] == symbol("unquote") + ast[2] + else + quasiquote_loop(ast) + end + elseif isa(ast, Tuple) + Any[:vec, quasiquote_loop(ast)] + elseif typeof(ast) == Symbol || isa(ast, Dict) + Any[:quote, ast] + else + ast + end +end + +function ismacroCall(ast, env) + return isa(ast, Array) && + !isempty(ast) && + isa(ast[1], Symbol) && + env_find(env, ast[1]) != nothing && + isa(env_get(env, ast[1]), MalFunc) && + env_get(env, ast[1]).ismacro +end + +function macroexpand(ast, env) + while ismacroCall(ast, env) + mac = env_get(env, ast[1]) + ast = mac.fn(ast[2:end]...) + end + ast +end + +function eval_ast(ast, env) + if typeof(ast) == Symbol + env_get(env,ast) + elseif isa(ast, Array) || isa(ast, Tuple) + map((x) -> EVAL(x,env), ast) + elseif isa(ast, Dict) + [x[1] => EVAL(x[2], env) for x=ast] + else + ast + end +end + +function EVAL(ast, env) + while true + #println("EVAL: $(printer.pr_str(ast,true))") + if !isa(ast, Array) return eval_ast(ast, env) end + + # apply + ast = macroexpand(ast, env) + if !isa(ast, Array) return eval_ast(ast, env) end + if isempty(ast) return ast end + + if :def! == ast[1] + return env_set(env, ast[2], EVAL(ast[3], env)) + elseif symbol("let*") == ast[1] + let_env = Env(env) + for i = 1:2:length(ast[2]) + env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) + end + env = let_env + ast = ast[3] + # TCO loop + elseif :quote == ast[1] + return ast[2] + elseif :quasiquoteexpand == ast[1] + return quasiquote(ast[2]) + elseif :quasiquote == ast[1] + ast = quasiquote(ast[2]) + # TCO loop + elseif :defmacro! == ast[1] + func = EVAL(ast[3], env) + func.ismacro = true + return env_set(env, ast[2], func) + elseif :macroexpand == ast[1] + return macroexpand(ast[2], env) + elseif :do == ast[1] + eval_ast(ast[2:end-1], env) + ast = ast[end] + # TCO loop + elseif :if == ast[1] + cond = EVAL(ast[2], env) + if cond === nothing || cond === false + if length(ast) >= 4 + ast = ast[4] + # TCO loop + else + return nothing + end + else + ast = ast[3] + # TCO loop + end + elseif symbol("fn*") == ast[1] + return MalFunc( + (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), + ast[3], env, ast[2]) + else + el = eval_ast(ast, env) + f, args = el[1], el[2:end] + if isa(f, MalFunc) + ast = f.ast + env = Env(f.env, f.params, args) + # TCO loop + else + return f(args...) + end + end + end +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +repl_env = nothing +function REP(str) + return PRINT(EVAL(READ(str), repl_env)) +end + +# core.jl: defined using Julia +repl_env = Env(nothing, core.ns) +env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) +env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))") + + +if length(ARGS) > 0 + REP("(load-file \"$(ARGS[1])\")") + exit(0) +end + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + # TODO: show at least part of stack + if !isa(e, StackOverflowError) + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + end + println() + end +end diff --git a/impls/julia/step9_try.jl b/impls/julia/step9_try.jl index a739930ec4..edd2794a0e 100755 --- a/impls/julia/step9_try.jl +++ b/impls/julia/step9_try.jl @@ -1,206 +1,206 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer -using env -import core -using types - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function quasiquote_loop(elts) - acc = Any[] - for i in length(elts):-1:1 - elt = elts[i] - if isa(elt, Array) && length(elt) == 2 && elt[1] == symbol("splice-unquote") - acc = Any[:concat, elt[2], acc] - else - acc = Any[:cons, quasiquote(elt), acc] - end - end - return acc -end - -function quasiquote(ast) - if isa(ast, Array) - if length(ast) == 2 && ast[1] == symbol("unquote") - ast[2] - else - quasiquote_loop(ast) - end - elseif isa(ast, Tuple) - Any[:vec, quasiquote_loop(ast)] - elseif typeof(ast) == Symbol || isa(ast, Dict) - Any[:quote, ast] - else - ast - end -end - -function ismacroCall(ast, env) - return isa(ast, Array) && - !isempty(ast) && - isa(ast[1], Symbol) && - env_find(env, ast[1]) != nothing && - isa(env_get(env, ast[1]), MalFunc) && - env_get(env, ast[1]).ismacro -end - -function macroexpand(ast, env) - while ismacroCall(ast, env) - mac = env_get(env, ast[1]) - ast = mac.fn(ast[2:end]...) - end - ast -end - -function eval_ast(ast, env) - if typeof(ast) == Symbol - env_get(env,ast) - elseif isa(ast, Array) || isa(ast, Tuple) - map((x) -> EVAL(x,env), ast) - elseif isa(ast, Dict) - [x[1] => EVAL(x[2], env) for x=ast] - else - ast - end -end - -function EVAL(ast, env) - while true - #println("EVAL: $(printer.pr_str(ast,true))") - if !isa(ast, Array) return eval_ast(ast, env) end - - # apply - ast = macroexpand(ast, env) - if !isa(ast, Array) return eval_ast(ast, env) end - if isempty(ast) return ast end - - if :def! == ast[1] - return env_set(env, ast[2], EVAL(ast[3], env)) - elseif symbol("let*") == ast[1] - let_env = Env(env) - for i = 1:2:length(ast[2]) - env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) - end - env = let_env - ast = ast[3] - # TCO loop - elseif :quote == ast[1] - return ast[2] - elseif :quasiquoteexpand == ast[1] - return quasiquote(ast[2]) - elseif :quasiquote == ast[1] - ast = quasiquote(ast[2]) - # TCO loop - elseif :defmacro! == ast[1] - func = EVAL(ast[3], env) - func.ismacro = true - return env_set(env, ast[2], func) - elseif :macroexpand == ast[1] - return macroexpand(ast[2], env) - elseif symbol("try*") == ast[1] - try - return EVAL(ast[2], env) - catch exc - e = string(exc) - if isa(exc, MalException) - e = exc.malval - elseif isa(exc, ErrorException) - e = exc.msg - else - e = string(e) - end - if length(ast) > 2 && ast[3][1] == symbol("catch*") - return EVAL(ast[3][3], Env(env, Any[ast[3][2]], Any[e])) - else - rethrow(exc) - end - end - elseif :do == ast[1] - eval_ast(ast[2:end-1], env) - ast = ast[end] - # TCO loop - elseif :if == ast[1] - cond = EVAL(ast[2], env) - if cond === nothing || cond === false - if length(ast) >= 4 - ast = ast[4] - # TCO loop - else - return nothing - end - else - ast = ast[3] - # TCO loop - end - elseif symbol("fn*") == ast[1] - return MalFunc( - (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), - ast[3], env, ast[2]) - else - el = eval_ast(ast, env) - f, args = el[1], el[2:end] - if isa(f, MalFunc) - ast = f.ast - env = Env(f.env, f.params, args) - # TCO loop - else - return f(args...) - end - end - end -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -repl_env = nothing -function REP(str) - return PRINT(EVAL(READ(str), repl_env)) -end - -# core.jl: defined using Julia -repl_env = Env(nothing, core.ns) -env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) -env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))") - - -if length(ARGS) > 0 - REP("(load-file \"$(ARGS[1])\")") - exit(0) -end - -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - # TODO: show at least part of stack - if !isa(e, StackOverflowError) - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - end - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer +using env +import core +using types + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function quasiquote_loop(elts) + acc = Any[] + for i in length(elts):-1:1 + elt = elts[i] + if isa(elt, Array) && length(elt) == 2 && elt[1] == symbol("splice-unquote") + acc = Any[:concat, elt[2], acc] + else + acc = Any[:cons, quasiquote(elt), acc] + end + end + return acc +end + +function quasiquote(ast) + if isa(ast, Array) + if length(ast) == 2 && ast[1] == symbol("unquote") + ast[2] + else + quasiquote_loop(ast) + end + elseif isa(ast, Tuple) + Any[:vec, quasiquote_loop(ast)] + elseif typeof(ast) == Symbol || isa(ast, Dict) + Any[:quote, ast] + else + ast + end +end + +function ismacroCall(ast, env) + return isa(ast, Array) && + !isempty(ast) && + isa(ast[1], Symbol) && + env_find(env, ast[1]) != nothing && + isa(env_get(env, ast[1]), MalFunc) && + env_get(env, ast[1]).ismacro +end + +function macroexpand(ast, env) + while ismacroCall(ast, env) + mac = env_get(env, ast[1]) + ast = mac.fn(ast[2:end]...) + end + ast +end + +function eval_ast(ast, env) + if typeof(ast) == Symbol + env_get(env,ast) + elseif isa(ast, Array) || isa(ast, Tuple) + map((x) -> EVAL(x,env), ast) + elseif isa(ast, Dict) + [x[1] => EVAL(x[2], env) for x=ast] + else + ast + end +end + +function EVAL(ast, env) + while true + #println("EVAL: $(printer.pr_str(ast,true))") + if !isa(ast, Array) return eval_ast(ast, env) end + + # apply + ast = macroexpand(ast, env) + if !isa(ast, Array) return eval_ast(ast, env) end + if isempty(ast) return ast end + + if :def! == ast[1] + return env_set(env, ast[2], EVAL(ast[3], env)) + elseif symbol("let*") == ast[1] + let_env = Env(env) + for i = 1:2:length(ast[2]) + env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) + end + env = let_env + ast = ast[3] + # TCO loop + elseif :quote == ast[1] + return ast[2] + elseif :quasiquoteexpand == ast[1] + return quasiquote(ast[2]) + elseif :quasiquote == ast[1] + ast = quasiquote(ast[2]) + # TCO loop + elseif :defmacro! == ast[1] + func = EVAL(ast[3], env) + func.ismacro = true + return env_set(env, ast[2], func) + elseif :macroexpand == ast[1] + return macroexpand(ast[2], env) + elseif symbol("try*") == ast[1] + try + return EVAL(ast[2], env) + catch exc + e = string(exc) + if isa(exc, MalException) + e = exc.malval + elseif isa(exc, ErrorException) + e = exc.msg + else + e = string(e) + end + if length(ast) > 2 && ast[3][1] == symbol("catch*") + return EVAL(ast[3][3], Env(env, Any[ast[3][2]], Any[e])) + else + rethrow(exc) + end + end + elseif :do == ast[1] + eval_ast(ast[2:end-1], env) + ast = ast[end] + # TCO loop + elseif :if == ast[1] + cond = EVAL(ast[2], env) + if cond === nothing || cond === false + if length(ast) >= 4 + ast = ast[4] + # TCO loop + else + return nothing + end + else + ast = ast[3] + # TCO loop + end + elseif symbol("fn*") == ast[1] + return MalFunc( + (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), + ast[3], env, ast[2]) + else + el = eval_ast(ast, env) + f, args = el[1], el[2:end] + if isa(f, MalFunc) + ast = f.ast + env = Env(f.env, f.params, args) + # TCO loop + else + return f(args...) + end + end + end +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +repl_env = nothing +function REP(str) + return PRINT(EVAL(READ(str), repl_env)) +end + +# core.jl: defined using Julia +repl_env = Env(nothing, core.ns) +env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) +env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))") + + +if length(ARGS) > 0 + REP("(load-file \"$(ARGS[1])\")") + exit(0) +end + +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + # TODO: show at least part of stack + if !isa(e, StackOverflowError) + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + end + println() + end +end diff --git a/impls/julia/stepA_mal.jl b/impls/julia/stepA_mal.jl index 77bdaa9f00..16e16a5d7c 100755 --- a/impls/julia/stepA_mal.jl +++ b/impls/julia/stepA_mal.jl @@ -1,208 +1,208 @@ -#!/usr/bin/env julia - -push!(LOAD_PATH, pwd(), "/usr/share/julia/base") -import readline_mod -import reader -import printer -using env -import core -using types - -# READ -function READ(str) - reader.read_str(str) -end - -# EVAL -function quasiquote_loop(elts) - acc = Any[] - for i in length(elts):-1:1 - elt = elts[i] - if isa(elt, Array) && length(elt) == 2 && elt[1] == symbol("splice-unquote") - acc = Any[:concat, elt[2], acc] - else - acc = Any[:cons, quasiquote(elt), acc] - end - end - return acc -end - -function quasiquote(ast) - if isa(ast, Array) - if length(ast) == 2 && ast[1] == symbol("unquote") - ast[2] - else - quasiquote_loop(ast) - end - elseif isa(ast, Tuple) - Any[:vec, quasiquote_loop(ast)] - elseif typeof(ast) == Symbol || isa(ast, Dict) - Any[:quote, ast] - else - ast - end -end - -function ismacroCall(ast, env) - return isa(ast, Array) && - !isempty(ast) && - isa(ast[1], Symbol) && - env_find(env, ast[1]) != nothing && - isa(env_get(env, ast[1]), MalFunc) && - env_get(env, ast[1]).ismacro -end - -function macroexpand(ast, env) - while ismacroCall(ast, env) - mac = env_get(env, ast[1]) - ast = mac.fn(ast[2:end]...) - end - ast -end - -function eval_ast(ast, env) - if typeof(ast) == Symbol - env_get(env,ast) - elseif isa(ast, Array) || isa(ast, Tuple) - map((x) -> EVAL(x,env), ast) - elseif isa(ast, Dict) - [x[1] => EVAL(x[2], env) for x=ast] - else - ast - end -end - -function EVAL(ast, env) - while true - #println("EVAL: $(printer.pr_str(ast,true))") - if !isa(ast, Array) return eval_ast(ast, env) end - - # apply - ast = macroexpand(ast, env) - if !isa(ast, Array) return eval_ast(ast, env) end - if isempty(ast) return ast end - - if :def! == ast[1] - return env_set(env, ast[2], EVAL(ast[3], env)) - elseif symbol("let*") == ast[1] - let_env = Env(env) - for i = 1:2:length(ast[2]) - env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) - end - env = let_env - ast = ast[3] - # TCO loop - elseif :quote == ast[1] - return ast[2] - elseif :quasiquoteexpand == ast[1] - return quasiquote(ast[2]) - elseif :quasiquote == ast[1] - ast = quasiquote(ast[2]) - # TCO loop - elseif :defmacro! == ast[1] - func = EVAL(ast[3], env) - func.ismacro = true - return env_set(env, ast[2], func) - elseif :macroexpand == ast[1] - return macroexpand(ast[2], env) - elseif symbol("try*") == ast[1] - try - return EVAL(ast[2], env) - catch exc - e = string(exc) - if isa(exc, MalException) - e = exc.malval - elseif isa(exc, ErrorException) - e = exc.msg - else - e = string(e) - end - if length(ast) > 2 && ast[3][1] == symbol("catch*") - return EVAL(ast[3][3], Env(env, Any[ast[3][2]], Any[e])) - else - rethrow(exc) - end - end - elseif :do == ast[1] - eval_ast(ast[2:end-1], env) - ast = ast[end] - # TCO loop - elseif :if == ast[1] - cond = EVAL(ast[2], env) - if cond === nothing || cond === false - if length(ast) >= 4 - ast = ast[4] - # TCO loop - else - return nothing - end - else - ast = ast[3] - # TCO loop - end - elseif symbol("fn*") == ast[1] - return MalFunc( - (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), - ast[3], env, ast[2]) - else - el = eval_ast(ast, env) - f, args = el[1], el[2:end] - if isa(f, MalFunc) - ast = f.ast - env = Env(f.env, f.params, args) - # TCO loop - else - return f(args...) - end - end - end -end - -# PRINT -function PRINT(exp) - printer.pr_str(exp) -end - -# REPL -repl_env = nothing -function REP(str) - return PRINT(EVAL(READ(str), repl_env)) -end - -# core.jl: defined using Julia -repl_env = Env(nothing, core.ns) -env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) -env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) - -# core.mal: defined using the language itself -REP("(def! *host-language* \"julia\")") -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))") - - -if length(ARGS) > 0 - REP("(load-file \"$(ARGS[1])\")") - exit(0) -end - -REP("(println (str \"Mal [\" *host-language* \"]\"))") -while true - line = readline_mod.do_readline("user> ") - if line === nothing break end - try - println(REP(line)) - catch e - if isa(e, ErrorException) - println("Error: $(e.msg)") - else - println("Error: $(string(e))") - end - # TODO: show at least part of stack - if !isa(e, StackOverflowError) - bt = catch_backtrace() - Base.show_backtrace(STDERR, bt) - end - println() - end -end +#!/usr/bin/env julia + +push!(LOAD_PATH, pwd(), "/usr/share/julia/base") +import readline_mod +import reader +import printer +using env +import core +using types + +# READ +function READ(str) + reader.read_str(str) +end + +# EVAL +function quasiquote_loop(elts) + acc = Any[] + for i in length(elts):-1:1 + elt = elts[i] + if isa(elt, Array) && length(elt) == 2 && elt[1] == symbol("splice-unquote") + acc = Any[:concat, elt[2], acc] + else + acc = Any[:cons, quasiquote(elt), acc] + end + end + return acc +end + +function quasiquote(ast) + if isa(ast, Array) + if length(ast) == 2 && ast[1] == symbol("unquote") + ast[2] + else + quasiquote_loop(ast) + end + elseif isa(ast, Tuple) + Any[:vec, quasiquote_loop(ast)] + elseif typeof(ast) == Symbol || isa(ast, Dict) + Any[:quote, ast] + else + ast + end +end + +function ismacroCall(ast, env) + return isa(ast, Array) && + !isempty(ast) && + isa(ast[1], Symbol) && + env_find(env, ast[1]) != nothing && + isa(env_get(env, ast[1]), MalFunc) && + env_get(env, ast[1]).ismacro +end + +function macroexpand(ast, env) + while ismacroCall(ast, env) + mac = env_get(env, ast[1]) + ast = mac.fn(ast[2:end]...) + end + ast +end + +function eval_ast(ast, env) + if typeof(ast) == Symbol + env_get(env,ast) + elseif isa(ast, Array) || isa(ast, Tuple) + map((x) -> EVAL(x,env), ast) + elseif isa(ast, Dict) + [x[1] => EVAL(x[2], env) for x=ast] + else + ast + end +end + +function EVAL(ast, env) + while true + #println("EVAL: $(printer.pr_str(ast,true))") + if !isa(ast, Array) return eval_ast(ast, env) end + + # apply + ast = macroexpand(ast, env) + if !isa(ast, Array) return eval_ast(ast, env) end + if isempty(ast) return ast end + + if :def! == ast[1] + return env_set(env, ast[2], EVAL(ast[3], env)) + elseif symbol("let*") == ast[1] + let_env = Env(env) + for i = 1:2:length(ast[2]) + env_set(let_env, ast[2][i], EVAL(ast[2][i+1], let_env)) + end + env = let_env + ast = ast[3] + # TCO loop + elseif :quote == ast[1] + return ast[2] + elseif :quasiquoteexpand == ast[1] + return quasiquote(ast[2]) + elseif :quasiquote == ast[1] + ast = quasiquote(ast[2]) + # TCO loop + elseif :defmacro! == ast[1] + func = EVAL(ast[3], env) + func.ismacro = true + return env_set(env, ast[2], func) + elseif :macroexpand == ast[1] + return macroexpand(ast[2], env) + elseif symbol("try*") == ast[1] + try + return EVAL(ast[2], env) + catch exc + e = string(exc) + if isa(exc, MalException) + e = exc.malval + elseif isa(exc, ErrorException) + e = exc.msg + else + e = string(e) + end + if length(ast) > 2 && ast[3][1] == symbol("catch*") + return EVAL(ast[3][3], Env(env, Any[ast[3][2]], Any[e])) + else + rethrow(exc) + end + end + elseif :do == ast[1] + eval_ast(ast[2:end-1], env) + ast = ast[end] + # TCO loop + elseif :if == ast[1] + cond = EVAL(ast[2], env) + if cond === nothing || cond === false + if length(ast) >= 4 + ast = ast[4] + # TCO loop + else + return nothing + end + else + ast = ast[3] + # TCO loop + end + elseif symbol("fn*") == ast[1] + return MalFunc( + (args...) -> EVAL(ast[3], Env(env, ast[2], Any[args...])), + ast[3], env, ast[2]) + else + el = eval_ast(ast, env) + f, args = el[1], el[2:end] + if isa(f, MalFunc) + ast = f.ast + env = Env(f.env, f.params, args) + # TCO loop + else + return f(args...) + end + end + end +end + +# PRINT +function PRINT(exp) + printer.pr_str(exp) +end + +# REPL +repl_env = nothing +function REP(str) + return PRINT(EVAL(READ(str), repl_env)) +end + +# core.jl: defined using Julia +repl_env = Env(nothing, core.ns) +env_set(repl_env, :eval, (ast) -> EVAL(ast, repl_env)) +env_set(repl_env, symbol("*ARGV*"), ARGS[2:end]) + +# core.mal: defined using the language itself +REP("(def! *host-language* \"julia\")") +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))") + + +if length(ARGS) > 0 + REP("(load-file \"$(ARGS[1])\")") + exit(0) +end + +REP("(println (str \"Mal [\" *host-language* \"]\"))") +while true + line = readline_mod.do_readline("user> ") + if line === nothing break end + try + println(REP(line)) + catch e + if isa(e, ErrorException) + println("Error: $(e.msg)") + else + println("Error: $(string(e))") + end + # TODO: show at least part of stack + if !isa(e, StackOverflowError) + bt = catch_backtrace() + Base.show_backtrace(STDERR, bt) + end + println() + end +end diff --git a/impls/julia/tests/step5_tco.mal b/impls/julia/tests/step5_tco.mal index 087368335f..ef06829c45 100644 --- a/impls/julia/tests/step5_tco.mal +++ b/impls/julia/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 100000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 100000)) +res1 +;=>nil diff --git a/impls/julia/types.jl b/impls/julia/types.jl index ba735784fa..38cd97db14 100644 --- a/impls/julia/types.jl +++ b/impls/julia/types.jl @@ -1,81 +1,81 @@ -module types - -export MalException, MalFunc, sequential_Q, equal_Q, hash_map, Atom - -import Base.copy - -type MalException <: Exception - malval -end - -type MalFunc - fn::Function - ast - env - params - ismacro - meta -end - -# ismacro default to false -function MalFunc(fn, ast, env, params) - MalFunc(fn, ast, env, params, false, nothing) -end - -function copy(f::MalFunc) - MalFunc(f.fn, f.ast, f.env, f.params, f.ismacro, f.meta) -end - -function sequential_Q(obj) - isa(obj, Array) || isa(obj, Tuple) -end - -function equal_Q(a, b) - ota = typeof(a) - otb = typeof(b) - if !(ota === otb || (sequential_Q(a) && sequential_Q(b))) - return false - end - - if sequential_Q(a) - if length(a) !== length(b) - return false - end - for (x, y) in zip(a,b) - if !equal_Q(x, y) - return false - end - end - return true - elseif isa(a,AbstractString) - a == b - elseif isa(a,Dict) - if length(a) !== length(b) - return false - end - for (k,v) in a - if !equal_Q(v,b[k]) - return false - end - end - return true - else - a === b - end -end - -function hash_map(lst...) - hm = Dict() - for i = 1:2:length(lst) - hm[lst[i]] = lst[i+1] - end - hm -end - -type Atom - val -end - -end - - +module types + +export MalException, MalFunc, sequential_Q, equal_Q, hash_map, Atom + +import Base.copy + +type MalException <: Exception + malval +end + +type MalFunc + fn::Function + ast + env + params + ismacro + meta +end + +# ismacro default to false +function MalFunc(fn, ast, env, params) + MalFunc(fn, ast, env, params, false, nothing) +end + +function copy(f::MalFunc) + MalFunc(f.fn, f.ast, f.env, f.params, f.ismacro, f.meta) +end + +function sequential_Q(obj) + isa(obj, Array) || isa(obj, Tuple) +end + +function equal_Q(a, b) + ota = typeof(a) + otb = typeof(b) + if !(ota === otb || (sequential_Q(a) && sequential_Q(b))) + return false + end + + if sequential_Q(a) + if length(a) !== length(b) + return false + end + for (x, y) in zip(a,b) + if !equal_Q(x, y) + return false + end + end + return true + elseif isa(a,AbstractString) + a == b + elseif isa(a,Dict) + if length(a) !== length(b) + return false + end + for (k,v) in a + if !equal_Q(v,b[k]) + return false + end + end + return true + else + a === b + end +end + +function hash_map(lst...) + hm = Dict() + for i = 1:2:length(lst) + hm[lst[i]] = lst[i+1] + end + hm +end + +type Atom + val +end + +end + + diff --git a/impls/kotlin/Dockerfile b/impls/kotlin/Dockerfile index dfb83bb887..c2e7280f09 100644 --- a/impls/kotlin/Dockerfile +++ b/impls/kotlin/Dockerfile @@ -1,34 +1,34 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Java and Zip -RUN apt-get -y install openjdk-7-jdk -RUN apt-get -y install unzip - -RUN curl -O -J -L https://github.com/JetBrains/kotlin/releases/download/v1.0.6/kotlin-compiler-1.0.6.zip - -RUN mkdir -p /kotlin-compiler -RUN unzip kotlin-compiler-1.0.6.zip -d /kotlin-compiler - -ENV KOTLIN_HOME /kotlin-compiler/kotlinc -ENV PATH $KOTLIN_HOME/bin:$PATH +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Java and Zip +RUN apt-get -y install openjdk-7-jdk +RUN apt-get -y install unzip + +RUN curl -O -J -L https://github.com/JetBrains/kotlin/releases/download/v1.0.6/kotlin-compiler-1.0.6.zip + +RUN mkdir -p /kotlin-compiler +RUN unzip kotlin-compiler-1.0.6.zip -d /kotlin-compiler + +ENV KOTLIN_HOME /kotlin-compiler/kotlinc +ENV PATH $KOTLIN_HOME/bin:$PATH diff --git a/impls/kotlin/Makefile b/impls/kotlin/Makefile index 1a9a6dfee1..42346b9ddf 100644 --- a/impls/kotlin/Makefile +++ b/impls/kotlin/Makefile @@ -1,23 +1,23 @@ -SOURCES_BASE = reader.kt printer.kt types.kt env.kt core.kt readline.kt -SOURCES_LISP = step0_repl.kt step1_read_print.kt step2_eval.kt step3_env.kt step4_if_fn_do.kt \ - step5_tco.kt step6_file.kt step7_quote.kt step8_macros.kt step9_try.kt stepA_mal.kt - -JARS = $(SOURCES_LISP:%.kt=%.jar) - -all: $(JARS) - -dist: mal.jar mal - -mal.jar: stepA_mal.jar - cp $< $@ - -SHELL := bash -mal: mal.jar - cat <(echo -e '#!/bin/sh\nexec java -jar "$$0" "$$@"') mal.jar > $@ - chmod +x mal - -clean: - rm -vf $(JARS) mal.jar mal - -$(JARS): %.jar: src/mal/%.kt $(SOURCES_BASE:%.kt=src/mal/%.kt) - kotlinc src/mal/$(@:%.jar=%.kt) $(SOURCES_BASE:%.kt=src/mal/%.kt) -include-runtime -d $@ +SOURCES_BASE = reader.kt printer.kt types.kt env.kt core.kt readline.kt +SOURCES_LISP = step0_repl.kt step1_read_print.kt step2_eval.kt step3_env.kt step4_if_fn_do.kt \ + step5_tco.kt step6_file.kt step7_quote.kt step8_macros.kt step9_try.kt stepA_mal.kt + +JARS = $(SOURCES_LISP:%.kt=%.jar) + +all: $(JARS) + +dist: mal.jar mal + +mal.jar: stepA_mal.jar + cp $< $@ + +SHELL := bash +mal: mal.jar + cat <(echo -e '#!/bin/sh\nexec java -jar "$$0" "$$@"') mal.jar > $@ + chmod +x mal + +clean: + rm -vf $(JARS) mal.jar mal + +$(JARS): %.jar: src/mal/%.kt $(SOURCES_BASE:%.kt=src/mal/%.kt) + kotlinc src/mal/$(@:%.jar=%.kt) $(SOURCES_BASE:%.kt=src/mal/%.kt) -include-runtime -d $@ diff --git a/impls/kotlin/run b/impls/kotlin/run index 8840277bd1..4395dde951 100755 --- a/impls/kotlin/run +++ b/impls/kotlin/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec java -jar $(dirname $0)/${STEP:-stepA_mal}.jar "${@}" +#!/bin/bash +exec java -jar $(dirname $0)/${STEP:-stepA_mal}.jar "${@}" diff --git a/impls/kotlin/src/mal/core.kt b/impls/kotlin/src/mal/core.kt index e14b41502e..414235778c 100644 --- a/impls/kotlin/src/mal/core.kt +++ b/impls/kotlin/src/mal/core.kt @@ -1,242 +1,242 @@ -package mal - -import java.io.File -import java.util.* - -val ns = hashMapOf( - envPair("+", { a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger + y as MalInteger }) }), - envPair("-", { a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger - y as MalInteger }) }), - envPair("*", { a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger * y as MalInteger }) }), - envPair("/", { a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger / y as MalInteger }) }), - - envPair("list", { a: ISeq -> MalList(a) }), - envPair("list?", { a: ISeq -> if (a.first() is MalList) TRUE else FALSE }), - envPair("empty?", { a: ISeq -> if (a.first() !is ISeq || !(a.first() as ISeq).seq().any()) TRUE else FALSE }), - envPair("count", { a: ISeq -> - if (a.first() is ISeq) MalInteger((a.first() as ISeq).count().toLong()) else MalInteger(0) - }), - - envPair("=", { a: ISeq -> pairwiseEquals(a) }), - envPair("<", { a: ISeq -> pairwiseCompare(a, { x, y -> x.value < y.value }) }), - envPair("<=", { a: ISeq -> pairwiseCompare(a, { x, y -> x.value <= y.value }) }), - envPair(">", { a: ISeq -> pairwiseCompare(a, { x, y -> x.value > y.value }) }), - envPair(">=", { a: ISeq -> pairwiseCompare(a, { x, y -> x.value >= y.value }) }), - - envPair("pr-str", { a: ISeq -> - MalString(a.seq().map({ it -> pr_str(it, print_readably = true) }).joinToString(" ")) - }), - envPair("str", { a: ISeq -> - MalString(a.seq().map({ it -> pr_str(it, print_readably = false) }).joinToString("")) - }), - envPair("prn", { a: ISeq -> - println(a.seq().map({ it -> pr_str(it, print_readably = true) }).joinToString(" ")) - NIL - }), - envPair("println", { a: ISeq -> - println(a.seq().map({ it -> pr_str(it, print_readably = false) }).joinToString(" ")) - NIL - }), - - envPair("read-string", { a: ISeq -> - val string = a.first() as? MalString ?: throw MalException("slurp requires a string parameter") - read_str(string.value) - }), - envPair("slurp", { a: ISeq -> - val name = a.first() as? MalString ?: throw MalException("slurp requires a filename parameter") - val text = File(name.value).readText() - MalString(text) - }), - - envPair("cons", { a: ISeq -> - val list = a.nth(1) as? ISeq ?: throw MalException("cons requires a list as its second parameter") - val mutableList = list.seq().toCollection(LinkedList()) - mutableList.addFirst(a.nth(0)) - MalList(mutableList) - }), - envPair("concat", { a: ISeq -> MalList(a.seq().flatMap({ it -> (it as ISeq).seq() }).toCollection(LinkedList())) }), - envPair("vec", { a: ISeq -> - val list = a.first() as? ISeq ?: throw MalException("vec requires a sequence") - MalVector(list) - }), - envPair("nth", { a: ISeq -> - val list = a.nth(0) as? ISeq ?: throw MalException("nth requires a list as its first parameter") - val index = a.nth(1) as? MalInteger ?: throw MalException("nth requires an integer as its second parameter") - if (index.value >= list.count()) throw MalException("index out of bounds") - list.nth(index.value.toInt()) - }), - envPair("first", { a: ISeq -> - if (a.nth(0) == NIL) NIL - else { - val list = a.nth(0) as? ISeq ?: throw MalException("first requires a list parameter") - if (list.seq().any()) list.first() else NIL - } - }), - envPair("rest", { a: ISeq -> - if (a.nth(0) == NIL) MalList() - else { - val list = a.nth(0) as? ISeq ?: throw MalException("rest requires a list parameter") - MalList(list.rest()) - } - }), - - envPair("throw", { a: ISeq -> - val throwable = a.nth(0) - throw MalCoreException(pr_str(throwable), throwable) - }), - - envPair("apply", { a: ISeq -> - val function = a.nth(0) as MalFunction - val params = MalList() - a.seq().drop(1).forEach({ it -> - if (it is ISeq) { - it.seq().forEach({ x -> params.conj_BANG(x) }) - } else { - params.conj_BANG(it) - } - }) - function.apply(params) - }), - - envPair("map", { a: ISeq -> - val function = a.nth(0) as MalFunction - MalList((a.nth(1) as ISeq).seq().map({ it -> - val params = MalList() - params.conj_BANG(it) - function.apply(params) - }).toCollection(LinkedList())) - }), - - envPair("nil?", { a: ISeq -> if (a.nth(0) == NIL) TRUE else FALSE }), - envPair("true?", { a: ISeq -> if (a.nth(0) == TRUE) TRUE else FALSE }), - envPair("false?", { a: ISeq -> if (a.nth(0) == FALSE) TRUE else FALSE }), - envPair("string?", { a: ISeq -> - if (a.nth(0) is MalString && !(a.nth(0) is MalKeyword)) TRUE else FALSE - }), - envPair("symbol?", { a: ISeq -> if (a.nth(0) is MalSymbol) TRUE else FALSE }), - - envPair("symbol", { a: ISeq -> MalSymbol((a.nth(0) as MalString).value) }), - envPair("keyword", { a: ISeq -> - val param = a.nth(0) - if (param is MalKeyword) param else MalKeyword((a.nth(0) as MalString).value) - }), - envPair("keyword?", { a: ISeq -> if (a.nth(0) is MalKeyword) TRUE else FALSE }), - envPair("number?", { a: ISeq -> if (a.nth(0) is MalInteger) TRUE else FALSE }), - envPair("fn?", { a: ISeq -> if ((a.nth(0) as? MalFunction)?.is_macro ?: true) FALSE else TRUE }), - envPair("macro?", { a: ISeq -> if ((a.nth(0) as? MalFunction)?.is_macro ?: false) TRUE else FALSE }), - - envPair("vector", { a: ISeq -> MalVector(a) }), - envPair("vector?", { a: ISeq -> if (a.nth(0) is MalVector) TRUE else FALSE }), - - envPair("hash-map", { a: ISeq -> - val map = MalHashMap() - pairwise(a).forEach({ it -> map.assoc_BANG(it.first as MalString, it.second) }) - map - }), - envPair("map?", { a: ISeq -> if (a.nth(0) is MalHashMap) TRUE else FALSE }), - envPair("assoc", { a: ISeq -> - val map = MalHashMap(a.first() as MalHashMap) - pairwise(a.rest()).forEach({ it -> map.assoc_BANG(it.first as MalString, it.second) }) - map - }), - envPair("dissoc", { a: ISeq -> - val map = MalHashMap(a.first() as MalHashMap) - a.rest().seq().forEach({ it -> map.dissoc_BANG(it as MalString) }) - map - }), - envPair("get", { a: ISeq -> - val map = a.nth(0) as? MalHashMap - val key = a.nth(1) as MalString - map?.elements?.get(key) ?: NIL - }), - envPair("contains?", { a: ISeq -> - val map = a.nth(0) as? MalHashMap - val key = a.nth(1) as MalString - if (map?.elements?.get(key) != null) TRUE else FALSE - }), - envPair("keys", { a: ISeq -> - val map = a.nth(0) as MalHashMap - MalList(map.elements.keys.toCollection(LinkedList())) - }), - envPair("vals", { a: ISeq -> - val map = a.nth(0) as MalHashMap - MalList(map.elements.values.toCollection(LinkedList())) - }), - envPair("count", { a: ISeq -> - val seq = a.nth(0) as? ISeq - if (seq != null) MalInteger(seq.count().toLong()) else ZERO - }), - envPair("sequential?", { a: ISeq -> if (a.nth(0) is ISeq) TRUE else FALSE }), - - envPair("with-meta", { a: ISeq -> - val obj = a.nth(0) - val metadata = a.nth(1) - obj.with_meta(metadata) - }), - envPair("meta", { a: ISeq -> a.first().metadata }), - - envPair("conj", { a: ISeq -> (a.first() as ISeq).conj(a.rest()) }), - envPair("seq", { a: ISeq -> - val obj = a.nth(0) - if (obj is ISeq) { - if (obj.count() == 0) NIL - else MalList(obj.seq().toCollection(LinkedList())) - } else if (obj is MalString && !(obj is MalKeyword)) { - if (obj.value.length == 0) NIL - else { - var strs = obj.value.map({ c -> MalString(c.toString()) }) - MalList(strs.toCollection(LinkedList())) - } - } else { - NIL - } - }), - - envPair("atom", { a: ISeq -> MalAtom(a.first()) }), - envPair("atom?", { a: ISeq -> if (a.first() is MalAtom) TRUE else FALSE }), - envPair("deref", { a: ISeq -> (a.first() as MalAtom).value }), - envPair("reset!", { a: ISeq -> - val atom = a.nth(0) as MalAtom - val value = a.nth(1) - atom.value = value - value - }), - envPair("swap!", { a: ISeq -> - val atom = a.nth(0) as MalAtom - val function = a.nth(1) as MalFunction - - val params = MalList() - params.conj_BANG(atom.value) - a.seq().drop(2).forEach({ it -> params.conj_BANG(it) }) - - val value = function.apply(params) - atom.value = value - - value - }), - - envPair("readline", { a: ISeq -> - val prompt = a.first() as MalString - try { - MalString(readline(prompt.value)) - } catch (e: java.io.IOException) { - throw MalException(e.message) - } catch (e: EofException) { - NIL - } - }), - - envPair("time-ms", { a: ISeq -> MalInteger(System.currentTimeMillis()) }) -) - -private fun envPair(k: String, v: (ISeq) -> MalType): Pair = Pair(MalSymbol(k), MalFunction(v)) - -private fun pairwise(s: ISeq): List> { - val (keys, vals) = s.seq().withIndex().partition({ it -> it.index % 2 == 0 }) - return keys.map({ it -> it.value }).zip(vals.map({ it -> it.value })) -} - -private fun pairwiseCompare(s: ISeq, pred: (MalInteger, MalInteger) -> Boolean): MalConstant = - if (pairwise(s).all({ it -> pred(it.first as MalInteger, it.second as MalInteger) })) TRUE else FALSE - -private fun pairwiseEquals(s: ISeq): MalConstant = - if (pairwise(s).all({ it -> it.first == it.second })) TRUE else FALSE +package mal + +import java.io.File +import java.util.* + +val ns = hashMapOf( + envPair("+", { a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger + y as MalInteger }) }), + envPair("-", { a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger - y as MalInteger }) }), + envPair("*", { a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger * y as MalInteger }) }), + envPair("/", { a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger / y as MalInteger }) }), + + envPair("list", { a: ISeq -> MalList(a) }), + envPair("list?", { a: ISeq -> if (a.first() is MalList) TRUE else FALSE }), + envPair("empty?", { a: ISeq -> if (a.first() !is ISeq || !(a.first() as ISeq).seq().any()) TRUE else FALSE }), + envPair("count", { a: ISeq -> + if (a.first() is ISeq) MalInteger((a.first() as ISeq).count().toLong()) else MalInteger(0) + }), + + envPair("=", { a: ISeq -> pairwiseEquals(a) }), + envPair("<", { a: ISeq -> pairwiseCompare(a, { x, y -> x.value < y.value }) }), + envPair("<=", { a: ISeq -> pairwiseCompare(a, { x, y -> x.value <= y.value }) }), + envPair(">", { a: ISeq -> pairwiseCompare(a, { x, y -> x.value > y.value }) }), + envPair(">=", { a: ISeq -> pairwiseCompare(a, { x, y -> x.value >= y.value }) }), + + envPair("pr-str", { a: ISeq -> + MalString(a.seq().map({ it -> pr_str(it, print_readably = true) }).joinToString(" ")) + }), + envPair("str", { a: ISeq -> + MalString(a.seq().map({ it -> pr_str(it, print_readably = false) }).joinToString("")) + }), + envPair("prn", { a: ISeq -> + println(a.seq().map({ it -> pr_str(it, print_readably = true) }).joinToString(" ")) + NIL + }), + envPair("println", { a: ISeq -> + println(a.seq().map({ it -> pr_str(it, print_readably = false) }).joinToString(" ")) + NIL + }), + + envPair("read-string", { a: ISeq -> + val string = a.first() as? MalString ?: throw MalException("slurp requires a string parameter") + read_str(string.value) + }), + envPair("slurp", { a: ISeq -> + val name = a.first() as? MalString ?: throw MalException("slurp requires a filename parameter") + val text = File(name.value).readText() + MalString(text) + }), + + envPair("cons", { a: ISeq -> + val list = a.nth(1) as? ISeq ?: throw MalException("cons requires a list as its second parameter") + val mutableList = list.seq().toCollection(LinkedList()) + mutableList.addFirst(a.nth(0)) + MalList(mutableList) + }), + envPair("concat", { a: ISeq -> MalList(a.seq().flatMap({ it -> (it as ISeq).seq() }).toCollection(LinkedList())) }), + envPair("vec", { a: ISeq -> + val list = a.first() as? ISeq ?: throw MalException("vec requires a sequence") + MalVector(list) + }), + envPair("nth", { a: ISeq -> + val list = a.nth(0) as? ISeq ?: throw MalException("nth requires a list as its first parameter") + val index = a.nth(1) as? MalInteger ?: throw MalException("nth requires an integer as its second parameter") + if (index.value >= list.count()) throw MalException("index out of bounds") + list.nth(index.value.toInt()) + }), + envPair("first", { a: ISeq -> + if (a.nth(0) == NIL) NIL + else { + val list = a.nth(0) as? ISeq ?: throw MalException("first requires a list parameter") + if (list.seq().any()) list.first() else NIL + } + }), + envPair("rest", { a: ISeq -> + if (a.nth(0) == NIL) MalList() + else { + val list = a.nth(0) as? ISeq ?: throw MalException("rest requires a list parameter") + MalList(list.rest()) + } + }), + + envPair("throw", { a: ISeq -> + val throwable = a.nth(0) + throw MalCoreException(pr_str(throwable), throwable) + }), + + envPair("apply", { a: ISeq -> + val function = a.nth(0) as MalFunction + val params = MalList() + a.seq().drop(1).forEach({ it -> + if (it is ISeq) { + it.seq().forEach({ x -> params.conj_BANG(x) }) + } else { + params.conj_BANG(it) + } + }) + function.apply(params) + }), + + envPair("map", { a: ISeq -> + val function = a.nth(0) as MalFunction + MalList((a.nth(1) as ISeq).seq().map({ it -> + val params = MalList() + params.conj_BANG(it) + function.apply(params) + }).toCollection(LinkedList())) + }), + + envPair("nil?", { a: ISeq -> if (a.nth(0) == NIL) TRUE else FALSE }), + envPair("true?", { a: ISeq -> if (a.nth(0) == TRUE) TRUE else FALSE }), + envPair("false?", { a: ISeq -> if (a.nth(0) == FALSE) TRUE else FALSE }), + envPair("string?", { a: ISeq -> + if (a.nth(0) is MalString && !(a.nth(0) is MalKeyword)) TRUE else FALSE + }), + envPair("symbol?", { a: ISeq -> if (a.nth(0) is MalSymbol) TRUE else FALSE }), + + envPair("symbol", { a: ISeq -> MalSymbol((a.nth(0) as MalString).value) }), + envPair("keyword", { a: ISeq -> + val param = a.nth(0) + if (param is MalKeyword) param else MalKeyword((a.nth(0) as MalString).value) + }), + envPair("keyword?", { a: ISeq -> if (a.nth(0) is MalKeyword) TRUE else FALSE }), + envPair("number?", { a: ISeq -> if (a.nth(0) is MalInteger) TRUE else FALSE }), + envPair("fn?", { a: ISeq -> if ((a.nth(0) as? MalFunction)?.is_macro ?: true) FALSE else TRUE }), + envPair("macro?", { a: ISeq -> if ((a.nth(0) as? MalFunction)?.is_macro ?: false) TRUE else FALSE }), + + envPair("vector", { a: ISeq -> MalVector(a) }), + envPair("vector?", { a: ISeq -> if (a.nth(0) is MalVector) TRUE else FALSE }), + + envPair("hash-map", { a: ISeq -> + val map = MalHashMap() + pairwise(a).forEach({ it -> map.assoc_BANG(it.first as MalString, it.second) }) + map + }), + envPair("map?", { a: ISeq -> if (a.nth(0) is MalHashMap) TRUE else FALSE }), + envPair("assoc", { a: ISeq -> + val map = MalHashMap(a.first() as MalHashMap) + pairwise(a.rest()).forEach({ it -> map.assoc_BANG(it.first as MalString, it.second) }) + map + }), + envPair("dissoc", { a: ISeq -> + val map = MalHashMap(a.first() as MalHashMap) + a.rest().seq().forEach({ it -> map.dissoc_BANG(it as MalString) }) + map + }), + envPair("get", { a: ISeq -> + val map = a.nth(0) as? MalHashMap + val key = a.nth(1) as MalString + map?.elements?.get(key) ?: NIL + }), + envPair("contains?", { a: ISeq -> + val map = a.nth(0) as? MalHashMap + val key = a.nth(1) as MalString + if (map?.elements?.get(key) != null) TRUE else FALSE + }), + envPair("keys", { a: ISeq -> + val map = a.nth(0) as MalHashMap + MalList(map.elements.keys.toCollection(LinkedList())) + }), + envPair("vals", { a: ISeq -> + val map = a.nth(0) as MalHashMap + MalList(map.elements.values.toCollection(LinkedList())) + }), + envPair("count", { a: ISeq -> + val seq = a.nth(0) as? ISeq + if (seq != null) MalInteger(seq.count().toLong()) else ZERO + }), + envPair("sequential?", { a: ISeq -> if (a.nth(0) is ISeq) TRUE else FALSE }), + + envPair("with-meta", { a: ISeq -> + val obj = a.nth(0) + val metadata = a.nth(1) + obj.with_meta(metadata) + }), + envPair("meta", { a: ISeq -> a.first().metadata }), + + envPair("conj", { a: ISeq -> (a.first() as ISeq).conj(a.rest()) }), + envPair("seq", { a: ISeq -> + val obj = a.nth(0) + if (obj is ISeq) { + if (obj.count() == 0) NIL + else MalList(obj.seq().toCollection(LinkedList())) + } else if (obj is MalString && !(obj is MalKeyword)) { + if (obj.value.length == 0) NIL + else { + var strs = obj.value.map({ c -> MalString(c.toString()) }) + MalList(strs.toCollection(LinkedList())) + } + } else { + NIL + } + }), + + envPair("atom", { a: ISeq -> MalAtom(a.first()) }), + envPair("atom?", { a: ISeq -> if (a.first() is MalAtom) TRUE else FALSE }), + envPair("deref", { a: ISeq -> (a.first() as MalAtom).value }), + envPair("reset!", { a: ISeq -> + val atom = a.nth(0) as MalAtom + val value = a.nth(1) + atom.value = value + value + }), + envPair("swap!", { a: ISeq -> + val atom = a.nth(0) as MalAtom + val function = a.nth(1) as MalFunction + + val params = MalList() + params.conj_BANG(atom.value) + a.seq().drop(2).forEach({ it -> params.conj_BANG(it) }) + + val value = function.apply(params) + atom.value = value + + value + }), + + envPair("readline", { a: ISeq -> + val prompt = a.first() as MalString + try { + MalString(readline(prompt.value)) + } catch (e: java.io.IOException) { + throw MalException(e.message) + } catch (e: EofException) { + NIL + } + }), + + envPair("time-ms", { a: ISeq -> MalInteger(System.currentTimeMillis()) }) +) + +private fun envPair(k: String, v: (ISeq) -> MalType): Pair = Pair(MalSymbol(k), MalFunction(v)) + +private fun pairwise(s: ISeq): List> { + val (keys, vals) = s.seq().withIndex().partition({ it -> it.index % 2 == 0 }) + return keys.map({ it -> it.value }).zip(vals.map({ it -> it.value })) +} + +private fun pairwiseCompare(s: ISeq, pred: (MalInteger, MalInteger) -> Boolean): MalConstant = + if (pairwise(s).all({ it -> pred(it.first as MalInteger, it.second as MalInteger) })) TRUE else FALSE + +private fun pairwiseEquals(s: ISeq): MalConstant = + if (pairwise(s).all({ it -> it.first == it.second })) TRUE else FALSE diff --git a/impls/kotlin/src/mal/env.kt b/impls/kotlin/src/mal/env.kt index fa7b599124..3c320157e8 100644 --- a/impls/kotlin/src/mal/env.kt +++ b/impls/kotlin/src/mal/env.kt @@ -1,36 +1,36 @@ -package mal - -import java.util.* - -class Env(val outer: Env?, binds: Sequence?, exprs: Sequence?) { - val data = HashMap() - - init { - if (binds != null && exprs != null) { - val itb = binds.iterator() - val ite = exprs.iterator() - while (itb.hasNext()) { - val b = itb.next() - if (b.value != "&") { - set(b, if (ite.hasNext()) ite.next() else NIL) - } else { - if (!itb.hasNext()) throw MalException("expected a symbol name for varargs") - set(itb.next(), MalList(ite.asSequence().toCollection(LinkedList()))) - break - } - } - } - } - - constructor() : this(null, null, null) - constructor(outer: Env?) : this(outer, null, null) - - fun set(key: MalSymbol, value: MalType): MalType { - data.put(key.value, value) - return value - } - - fun find(key: MalSymbol): MalType? = data[key.value] ?: outer?.find(key) - - fun get(key: MalSymbol): MalType = find(key) ?: throw MalException("'${key.value}' not found") -} +package mal + +import java.util.* + +class Env(val outer: Env?, binds: Sequence?, exprs: Sequence?) { + val data = HashMap() + + init { + if (binds != null && exprs != null) { + val itb = binds.iterator() + val ite = exprs.iterator() + while (itb.hasNext()) { + val b = itb.next() + if (b.value != "&") { + set(b, if (ite.hasNext()) ite.next() else NIL) + } else { + if (!itb.hasNext()) throw MalException("expected a symbol name for varargs") + set(itb.next(), MalList(ite.asSequence().toCollection(LinkedList()))) + break + } + } + } + } + + constructor() : this(null, null, null) + constructor(outer: Env?) : this(outer, null, null) + + fun set(key: MalSymbol, value: MalType): MalType { + data.put(key.value, value) + return value + } + + fun find(key: MalSymbol): MalType? = data[key.value] ?: outer?.find(key) + + fun get(key: MalSymbol): MalType = find(key) ?: throw MalException("'${key.value}' not found") +} diff --git a/impls/kotlin/src/mal/printer.kt b/impls/kotlin/src/mal/printer.kt index 25a2233ab6..660a6ac71d 100644 --- a/impls/kotlin/src/mal/printer.kt +++ b/impls/kotlin/src/mal/printer.kt @@ -1,27 +1,27 @@ -package mal - -fun pr_str(malType: MalType, print_readably: Boolean = false): String = - when (malType) { - is MalInteger -> malType.value.toString() - is MalKeyword -> ":" + malType.value.substring(1) - is MalString -> - if (print_readably) { - "\"" + malType.value.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n") + "\"" - } else malType.value - is MalConstant -> malType.value - is MalSymbol -> malType.value - is MalFunction -> "#" + malType - is MalCoreException -> pr_str(malType.value, print_readably) - is MalException -> "\"" + (malType.message ?: "exception") + "\"" - is MalList -> pr_str(malType.elements, "(", ")", print_readably) - is MalVector -> pr_str(malType.elements, "[", "]", print_readably) - is MalHashMap -> malType.elements.map({ it -> pr_str(it, print_readably) }).joinToString(" ", "{", "}") - is MalAtom -> "(atom " + pr_str(malType.value, print_readably) + ")" - else -> throw MalPrinterException("Unrecognized MalType: " + malType) - } - -private fun pr_str(coll: Collection, start: String, end: String, print_readably: Boolean = false): String = - coll.map({ it -> pr_str(it, print_readably) }).joinToString(" ", start, end) - -private fun pr_str(mapEntry: Map.Entry, print_readably: Boolean = false): String = - pr_str(mapEntry.key, print_readably) + " " + pr_str(mapEntry.value, print_readably) +package mal + +fun pr_str(malType: MalType, print_readably: Boolean = false): String = + when (malType) { + is MalInteger -> malType.value.toString() + is MalKeyword -> ":" + malType.value.substring(1) + is MalString -> + if (print_readably) { + "\"" + malType.value.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n") + "\"" + } else malType.value + is MalConstant -> malType.value + is MalSymbol -> malType.value + is MalFunction -> "#" + malType + is MalCoreException -> pr_str(malType.value, print_readably) + is MalException -> "\"" + (malType.message ?: "exception") + "\"" + is MalList -> pr_str(malType.elements, "(", ")", print_readably) + is MalVector -> pr_str(malType.elements, "[", "]", print_readably) + is MalHashMap -> malType.elements.map({ it -> pr_str(it, print_readably) }).joinToString(" ", "{", "}") + is MalAtom -> "(atom " + pr_str(malType.value, print_readably) + ")" + else -> throw MalPrinterException("Unrecognized MalType: " + malType) + } + +private fun pr_str(coll: Collection, start: String, end: String, print_readably: Boolean = false): String = + coll.map({ it -> pr_str(it, print_readably) }).joinToString(" ", start, end) + +private fun pr_str(mapEntry: Map.Entry, print_readably: Boolean = false): String = + pr_str(mapEntry.key, print_readably) + " " + pr_str(mapEntry.value, print_readably) diff --git a/impls/kotlin/src/mal/reader.kt b/impls/kotlin/src/mal/reader.kt index 0d03f4aa02..092b58bd68 100644 --- a/impls/kotlin/src/mal/reader.kt +++ b/impls/kotlin/src/mal/reader.kt @@ -1,156 +1,156 @@ -package mal - -import kotlin.text.Regex - -val TOKEN_REGEX = Regex("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)") -val ATOM_REGEX = Regex("(^-?[0-9]+$)|(^nil$)|(^true$)|(^false$)|^\"((?:\\\\.|[^\\\\\"])*)\"$|^\"(.*)$|:(.*)|(^[^\"]*$)") - -class Reader(sequence: Sequence) { - val tokens = sequence.iterator() - var current = advance() - - fun next(): String? { - var result = current - current = advance() - return result - } - - fun peek(): String? = current - - private fun advance(): String? = if (tokens.hasNext()) tokens.next() else null -} - -fun read_str(input: String?): MalType { - val tokens = tokenizer(input) ?: return NIL - return read_form(Reader(tokens)) -} - -fun tokenizer(input: String?): Sequence? { - if (input == null) return null - - return TOKEN_REGEX.findAll(input) - .map({ it -> it.groups[1]?.value as String }) - .filter({ it != "" && !it.startsWith(";")}) -} - -fun read_form(reader: Reader): MalType = - when (reader.peek()) { - null -> throw MalContinue() - "(" -> read_list(reader) - ")" -> throw MalReaderException("expected form, got ')'") - "[" -> read_vector(reader) - "]" -> throw MalReaderException("expected form, got ']'") - "{" -> read_hashmap(reader) - "}" -> throw MalReaderException("expected form, got '}'") - "'" -> read_shorthand(reader, "quote") - "`" -> read_shorthand(reader, "quasiquote") - "~" -> read_shorthand(reader, "unquote") - "~@" -> read_shorthand(reader, "splice-unquote") - "^" -> read_with_meta(reader) - "@" -> read_shorthand(reader, "deref") - else -> read_atom(reader) - } - -fun read_list(reader: Reader): MalType = read_sequence(reader, MalList(), ")") -fun read_vector(reader: Reader): MalType = read_sequence(reader, MalVector(), "]") - -private fun read_sequence(reader: Reader, sequence: IMutableSeq, end: String): MalType { - reader.next() - - do { - val form = when (reader.peek()) { - null -> throw MalReaderException("expected '$end', got EOF") - end -> { reader.next(); null } - else -> read_form(reader) - } - - if (form != null) { - sequence.conj_BANG(form) - } - } while (form != null) - - return sequence -} - -fun read_hashmap(reader: Reader): MalType { - reader.next() - val hashMap = MalHashMap() - - do { - var value : MalType? = null; - val key = when (reader.peek()) { - null -> throw MalReaderException("expected '}', got EOF") - "}" -> { reader.next(); null } - else -> { - var key = read_form(reader) - if (key !is MalString) { - throw MalReaderException("hash-map keys must be strings or keywords") - } - value = when (reader.peek()) { - null -> throw MalReaderException("expected form, got EOF") - else -> read_form(reader) - } - key - } - } - - if (key != null) { - hashMap.assoc_BANG(key, value as MalType) - } - } while (key != null) - - return hashMap -} - -fun read_shorthand(reader: Reader, symbol: String): MalType { - reader.next() - - val list = MalList() - list.conj_BANG(MalSymbol(symbol)) - list.conj_BANG(read_form(reader)) - - return list -} - -fun read_with_meta(reader: Reader): MalType { - reader.next() - - val meta = read_form(reader) - val obj = read_form(reader) - - val list = MalList() - list.conj_BANG(MalSymbol("with-meta")) - list.conj_BANG(obj) - list.conj_BANG(meta) - - return list -} - -fun read_atom(reader: Reader): MalType { - val next = reader.next() ?: throw MalReaderException("Unexpected null token") - val groups = ATOM_REGEX.find(next)?.groups ?: throw MalReaderException("Unrecognized token: " + next) - - return if (groups[1]?.value != null) { - MalInteger(groups[1]?.value?.toLong() ?: throw MalReaderException("Error parsing number: " + next)) - } else if (groups[2]?.value != null) { - NIL - } else if (groups[3]?.value != null) { - TRUE - } else if (groups[4]?.value != null) { - FALSE - } else if (groups[5]?.value != null) { - MalString((groups[5]?.value as String).replace(Regex("""\\(.)""")) - { m: MatchResult -> - if (m.groups[1]?.value == "n") "\n" - else m.groups[1]?.value.toString() - }) - } else if (groups[6]?.value != null) { - throw MalReaderException("expected '\"', got EOF") - } else if (groups[7]?.value != null) { - MalKeyword(groups[7]?.value as String) - } else if (groups[8]?.value != null) { - MalSymbol(groups[8]?.value as String) - } else { - throw MalReaderException("Unrecognized token: " + next) - } -} +package mal + +import kotlin.text.Regex + +val TOKEN_REGEX = Regex("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)") +val ATOM_REGEX = Regex("(^-?[0-9]+$)|(^nil$)|(^true$)|(^false$)|^\"((?:\\\\.|[^\\\\\"])*)\"$|^\"(.*)$|:(.*)|(^[^\"]*$)") + +class Reader(sequence: Sequence) { + val tokens = sequence.iterator() + var current = advance() + + fun next(): String? { + var result = current + current = advance() + return result + } + + fun peek(): String? = current + + private fun advance(): String? = if (tokens.hasNext()) tokens.next() else null +} + +fun read_str(input: String?): MalType { + val tokens = tokenizer(input) ?: return NIL + return read_form(Reader(tokens)) +} + +fun tokenizer(input: String?): Sequence? { + if (input == null) return null + + return TOKEN_REGEX.findAll(input) + .map({ it -> it.groups[1]?.value as String }) + .filter({ it != "" && !it.startsWith(";")}) +} + +fun read_form(reader: Reader): MalType = + when (reader.peek()) { + null -> throw MalContinue() + "(" -> read_list(reader) + ")" -> throw MalReaderException("expected form, got ')'") + "[" -> read_vector(reader) + "]" -> throw MalReaderException("expected form, got ']'") + "{" -> read_hashmap(reader) + "}" -> throw MalReaderException("expected form, got '}'") + "'" -> read_shorthand(reader, "quote") + "`" -> read_shorthand(reader, "quasiquote") + "~" -> read_shorthand(reader, "unquote") + "~@" -> read_shorthand(reader, "splice-unquote") + "^" -> read_with_meta(reader) + "@" -> read_shorthand(reader, "deref") + else -> read_atom(reader) + } + +fun read_list(reader: Reader): MalType = read_sequence(reader, MalList(), ")") +fun read_vector(reader: Reader): MalType = read_sequence(reader, MalVector(), "]") + +private fun read_sequence(reader: Reader, sequence: IMutableSeq, end: String): MalType { + reader.next() + + do { + val form = when (reader.peek()) { + null -> throw MalReaderException("expected '$end', got EOF") + end -> { reader.next(); null } + else -> read_form(reader) + } + + if (form != null) { + sequence.conj_BANG(form) + } + } while (form != null) + + return sequence +} + +fun read_hashmap(reader: Reader): MalType { + reader.next() + val hashMap = MalHashMap() + + do { + var value : MalType? = null; + val key = when (reader.peek()) { + null -> throw MalReaderException("expected '}', got EOF") + "}" -> { reader.next(); null } + else -> { + var key = read_form(reader) + if (key !is MalString) { + throw MalReaderException("hash-map keys must be strings or keywords") + } + value = when (reader.peek()) { + null -> throw MalReaderException("expected form, got EOF") + else -> read_form(reader) + } + key + } + } + + if (key != null) { + hashMap.assoc_BANG(key, value as MalType) + } + } while (key != null) + + return hashMap +} + +fun read_shorthand(reader: Reader, symbol: String): MalType { + reader.next() + + val list = MalList() + list.conj_BANG(MalSymbol(symbol)) + list.conj_BANG(read_form(reader)) + + return list +} + +fun read_with_meta(reader: Reader): MalType { + reader.next() + + val meta = read_form(reader) + val obj = read_form(reader) + + val list = MalList() + list.conj_BANG(MalSymbol("with-meta")) + list.conj_BANG(obj) + list.conj_BANG(meta) + + return list +} + +fun read_atom(reader: Reader): MalType { + val next = reader.next() ?: throw MalReaderException("Unexpected null token") + val groups = ATOM_REGEX.find(next)?.groups ?: throw MalReaderException("Unrecognized token: " + next) + + return if (groups[1]?.value != null) { + MalInteger(groups[1]?.value?.toLong() ?: throw MalReaderException("Error parsing number: " + next)) + } else if (groups[2]?.value != null) { + NIL + } else if (groups[3]?.value != null) { + TRUE + } else if (groups[4]?.value != null) { + FALSE + } else if (groups[5]?.value != null) { + MalString((groups[5]?.value as String).replace(Regex("""\\(.)""")) + { m: MatchResult -> + if (m.groups[1]?.value == "n") "\n" + else m.groups[1]?.value.toString() + }) + } else if (groups[6]?.value != null) { + throw MalReaderException("expected '\"', got EOF") + } else if (groups[7]?.value != null) { + MalKeyword(groups[7]?.value as String) + } else if (groups[8]?.value != null) { + MalSymbol(groups[8]?.value as String) + } else { + throw MalReaderException("Unrecognized token: " + next) + } +} diff --git a/impls/kotlin/src/mal/readline.kt b/impls/kotlin/src/mal/readline.kt index 97902386fb..e79c9f1790 100644 --- a/impls/kotlin/src/mal/readline.kt +++ b/impls/kotlin/src/mal/readline.kt @@ -1,8 +1,8 @@ -package mal - -class EofException : Exception("EOF") - -fun readline(prompt: String): String { - print(prompt) - return readLine() ?: throw EofException() -} +package mal + +class EofException : Exception("EOF") + +fun readline(prompt: String): String { + print(prompt) + return readLine() ?: throw EofException() +} diff --git a/impls/kotlin/src/mal/step0_repl.kt b/impls/kotlin/src/mal/step0_repl.kt index 1ced37d3a8..5e1cb2cd4d 100644 --- a/impls/kotlin/src/mal/step0_repl.kt +++ b/impls/kotlin/src/mal/step0_repl.kt @@ -1,19 +1,19 @@ -package mal - -fun main(args: Array) { - fun read(input: String?): String? = input - fun eval(expression: String?): String? = expression - fun print(result: String?): String? = result - - while (true) { - val input = readline("user> ") - - try { - println(print(eval(read(input)))) - } catch (e: EofException) { - break - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - } - } -} +package mal + +fun main(args: Array) { + fun read(input: String?): String? = input + fun eval(expression: String?): String? = expression + fun print(result: String?): String? = result + + while (true) { + val input = readline("user> ") + + try { + println(print(eval(read(input)))) + } catch (e: EofException) { + break + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + } + } +} diff --git a/impls/kotlin/src/mal/step1_read_print.kt b/impls/kotlin/src/mal/step1_read_print.kt index 18ee081df1..b77b24e49e 100644 --- a/impls/kotlin/src/mal/step1_read_print.kt +++ b/impls/kotlin/src/mal/step1_read_print.kt @@ -1,22 +1,22 @@ -package mal - -fun main(args: Array) { - fun read(input: String?): MalType = read_str(input) - fun eval(expression: MalType): MalType = expression - fun print(result: MalType) = pr_str(result, print_readably = true) - - while (true) { - val input = readline("user> ") - - try { - println(print(eval(read(input)))) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - } - } -} +package mal + +fun main(args: Array) { + fun read(input: String?): MalType = read_str(input) + fun eval(expression: MalType): MalType = expression + fun print(result: MalType) = pr_str(result, print_readably = true) + + while (true) { + val input = readline("user> ") + + try { + println(print(eval(read(input)))) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + } + } +} diff --git a/impls/kotlin/src/mal/step2_eval.kt b/impls/kotlin/src/mal/step2_eval.kt index 630745a1c0..96512d350d 100644 --- a/impls/kotlin/src/mal/step2_eval.kt +++ b/impls/kotlin/src/mal/step2_eval.kt @@ -1,45 +1,45 @@ -package mal - -fun read(input: String?): MalType = read_str(input) - -fun eval(ast: MalType, env: Map): MalType = - if (ast is MalList && ast.count() > 0) { - val evaluated = eval_ast(ast, env) as ISeq - if (evaluated.first() !is MalFunction) throw MalException("cannot execute non-function") - (evaluated.first() as MalFunction).apply(evaluated.rest()) - } else eval_ast(ast, env) - -fun eval_ast(ast: MalType, env: Map): MalType = - when (ast) { - is MalSymbol -> env[ast.value] ?: throw MalException("'${ast.value}' not found") - is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) - else -> ast - } - -fun print(result: MalType) = pr_str(result, print_readably = true) - -fun main(args: Array) { - val env = hashMapOf( - Pair("+", MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger + y as MalInteger }) })), - Pair("-", MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger - y as MalInteger }) })), - Pair("*", MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger * y as MalInteger }) })), - Pair("/", MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger / y as MalInteger }) })) - ) - - while (true) { - val input = readline("user> ") - - try { - println(print(eval(read(input), env))) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - } - } -} +package mal + +fun read(input: String?): MalType = read_str(input) + +fun eval(ast: MalType, env: Map): MalType = + if (ast is MalList && ast.count() > 0) { + val evaluated = eval_ast(ast, env) as ISeq + if (evaluated.first() !is MalFunction) throw MalException("cannot execute non-function") + (evaluated.first() as MalFunction).apply(evaluated.rest()) + } else eval_ast(ast, env) + +fun eval_ast(ast: MalType, env: Map): MalType = + when (ast) { + is MalSymbol -> env[ast.value] ?: throw MalException("'${ast.value}' not found") + is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) + else -> ast + } + +fun print(result: MalType) = pr_str(result, print_readably = true) + +fun main(args: Array) { + val env = hashMapOf( + Pair("+", MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger + y as MalInteger }) })), + Pair("-", MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger - y as MalInteger }) })), + Pair("*", MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger * y as MalInteger }) })), + Pair("/", MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger / y as MalInteger }) })) + ) + + while (true) { + val input = readline("user> ") + + try { + println(print(eval(read(input), env))) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + } + } +} diff --git a/impls/kotlin/src/mal/step3_env.kt b/impls/kotlin/src/mal/step3_env.kt index 021ac4875d..d0ae6bb8c6 100644 --- a/impls/kotlin/src/mal/step3_env.kt +++ b/impls/kotlin/src/mal/step3_env.kt @@ -1,61 +1,61 @@ -package mal - -fun read(input: String?): MalType = read_str(input) - -fun eval(ast: MalType, env: Env): MalType = - if (ast is MalList && ast.count() > 0) { - val first = ast.first() - if (first is MalSymbol && first.value == "def!") { - env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) - } else if (first is MalSymbol && first.value == "let*") { - val child = Env(env) - val bindings = ast.nth(1) - if (bindings !is ISeq) throw MalException("expected sequence as the first parameter to let*") - val it = bindings.seq().iterator() - while (it.hasNext()) { - val key = it.next() - if (!it.hasNext()) throw MalException("odd number of binding elements in let*") - val value = eval(it.next(), child) - child.set(key as MalSymbol, value) - } - eval(ast.nth(2), child) - } else { - val evaluated = eval_ast(ast, env) as ISeq - if (evaluated.first() !is MalFunction) throw MalException("cannot execute non-function") - (evaluated.first() as MalFunction).apply(evaluated.rest()) - } - } else eval_ast(ast, env) - -fun eval_ast(ast: MalType, env: Env): MalType = - when (ast) { - is MalSymbol -> env.get(ast) - is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) - else -> ast - } - -fun print(result: MalType) = pr_str(result, print_readably = true) - -fun main(args: Array) { - val env = Env() - env.set(MalSymbol("+"), MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger + y as MalInteger }) })) - env.set(MalSymbol("-"), MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger - y as MalInteger }) })) - env.set(MalSymbol("*"), MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger * y as MalInteger }) })) - env.set(MalSymbol("/"), MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger / y as MalInteger }) })) - - while (true) { - val input = readline("user> ") - - try { - println(print(eval(read(input), env))) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - } - } -} +package mal + +fun read(input: String?): MalType = read_str(input) + +fun eval(ast: MalType, env: Env): MalType = + if (ast is MalList && ast.count() > 0) { + val first = ast.first() + if (first is MalSymbol && first.value == "def!") { + env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) + } else if (first is MalSymbol && first.value == "let*") { + val child = Env(env) + val bindings = ast.nth(1) + if (bindings !is ISeq) throw MalException("expected sequence as the first parameter to let*") + val it = bindings.seq().iterator() + while (it.hasNext()) { + val key = it.next() + if (!it.hasNext()) throw MalException("odd number of binding elements in let*") + val value = eval(it.next(), child) + child.set(key as MalSymbol, value) + } + eval(ast.nth(2), child) + } else { + val evaluated = eval_ast(ast, env) as ISeq + if (evaluated.first() !is MalFunction) throw MalException("cannot execute non-function") + (evaluated.first() as MalFunction).apply(evaluated.rest()) + } + } else eval_ast(ast, env) + +fun eval_ast(ast: MalType, env: Env): MalType = + when (ast) { + is MalSymbol -> env.get(ast) + is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) + else -> ast + } + +fun print(result: MalType) = pr_str(result, print_readably = true) + +fun main(args: Array) { + val env = Env() + env.set(MalSymbol("+"), MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger + y as MalInteger }) })) + env.set(MalSymbol("-"), MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger - y as MalInteger }) })) + env.set(MalSymbol("*"), MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger * y as MalInteger }) })) + env.set(MalSymbol("/"), MalFunction({ a: ISeq -> a.seq().reduce({ x, y -> x as MalInteger / y as MalInteger }) })) + + while (true) { + val input = readline("user> ") + + try { + println(print(eval(read(input), env))) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + } + } +} diff --git a/impls/kotlin/src/mal/step4_if_fn_do.kt b/impls/kotlin/src/mal/step4_if_fn_do.kt index ff7ae5c58b..725180dfab 100644 --- a/impls/kotlin/src/mal/step4_if_fn_do.kt +++ b/impls/kotlin/src/mal/step4_if_fn_do.kt @@ -1,103 +1,103 @@ -package mal - -fun read(input: String?): MalType = read_str(input) - -fun eval(ast: MalType, env: Env): MalType = - if (ast is MalList && ast.count() > 0) { - val first = ast.first() - if (first is MalSymbol) { - when (first.value) { - "def!" -> eval_def_BANG(ast, env) - "let*" -> eval_let_STAR(ast, env) - "fn*" -> eval_fn_STAR(ast, env) - "do" -> eval_do(ast, env) - "if" -> eval_if(ast, env) - else -> eval_function_call(ast, env) - } - } else eval_function_call(ast, env) - } else eval_ast(ast, env) - -private fun eval_def_BANG(ast: ISeq, env: Env): MalType = - env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) - -private fun eval_let_STAR(ast: ISeq, env: Env): MalType { - val child = Env(env) - val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") - - val it = bindings.seq().iterator() - while (it.hasNext()) { - val key = it.next() - if (!it.hasNext()) throw MalException("odd number of binding elements in let*") - - val value = eval(it.next(), child) - child.set(key as MalSymbol, value) - } - - return eval(ast.nth(2), child) -} - -private fun eval_fn_STAR(ast: ISeq, env: Env): MalType { - val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") - val symbols = binds.seq().filterIsInstance() - val body = ast.nth(2) - - return MalFunction({ s: ISeq -> - eval(body, Env(env, symbols, s.seq())) - }) -} - -private fun eval_do(ast: ISeq, env: Env): MalType = - (eval_ast(MalList(ast.rest()), env) as ISeq).seq().last() - -private fun eval_if(ast: ISeq, env: Env): MalType { - val check = eval(ast.nth(1), env) - - return if (check != NIL && check != FALSE) { - eval(ast.nth(2), env) - } else if (ast.count() > 3) { - eval(ast.nth(3), env) - } else NIL -} - -private fun eval_function_call(ast: ISeq, env: Env): MalType { - val evaluated = eval_ast(ast, env) as ISeq - val first = evaluated.first() as? MalFunction ?: throw MalException("cannot execute non-function") - return first.apply(evaluated.rest()) -} - -fun eval_ast(ast: MalType, env: Env): MalType = - when (ast) { - is MalSymbol -> env.get(ast) - is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) - else -> ast - } - -fun print(result: MalType) = pr_str(result, print_readably = true) - -fun rep(input: String, env: Env): String = - print(eval(read(input), env)) - -fun main(args: Array) { - val repl_env = Env() - ns.forEach({ it -> repl_env.set(it.key, it.value) }) - - rep("(def! not (fn* (a) (if a false true)))", repl_env) - - while (true) { - val input = readline("user> ") - - try { - println(rep(input, repl_env)) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - t.printStackTrace() - } - } -} +package mal + +fun read(input: String?): MalType = read_str(input) + +fun eval(ast: MalType, env: Env): MalType = + if (ast is MalList && ast.count() > 0) { + val first = ast.first() + if (first is MalSymbol) { + when (first.value) { + "def!" -> eval_def_BANG(ast, env) + "let*" -> eval_let_STAR(ast, env) + "fn*" -> eval_fn_STAR(ast, env) + "do" -> eval_do(ast, env) + "if" -> eval_if(ast, env) + else -> eval_function_call(ast, env) + } + } else eval_function_call(ast, env) + } else eval_ast(ast, env) + +private fun eval_def_BANG(ast: ISeq, env: Env): MalType = + env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) + +private fun eval_let_STAR(ast: ISeq, env: Env): MalType { + val child = Env(env) + val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") + + val it = bindings.seq().iterator() + while (it.hasNext()) { + val key = it.next() + if (!it.hasNext()) throw MalException("odd number of binding elements in let*") + + val value = eval(it.next(), child) + child.set(key as MalSymbol, value) + } + + return eval(ast.nth(2), child) +} + +private fun eval_fn_STAR(ast: ISeq, env: Env): MalType { + val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") + val symbols = binds.seq().filterIsInstance() + val body = ast.nth(2) + + return MalFunction({ s: ISeq -> + eval(body, Env(env, symbols, s.seq())) + }) +} + +private fun eval_do(ast: ISeq, env: Env): MalType = + (eval_ast(MalList(ast.rest()), env) as ISeq).seq().last() + +private fun eval_if(ast: ISeq, env: Env): MalType { + val check = eval(ast.nth(1), env) + + return if (check != NIL && check != FALSE) { + eval(ast.nth(2), env) + } else if (ast.count() > 3) { + eval(ast.nth(3), env) + } else NIL +} + +private fun eval_function_call(ast: ISeq, env: Env): MalType { + val evaluated = eval_ast(ast, env) as ISeq + val first = evaluated.first() as? MalFunction ?: throw MalException("cannot execute non-function") + return first.apply(evaluated.rest()) +} + +fun eval_ast(ast: MalType, env: Env): MalType = + when (ast) { + is MalSymbol -> env.get(ast) + is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) + else -> ast + } + +fun print(result: MalType) = pr_str(result, print_readably = true) + +fun rep(input: String, env: Env): String = + print(eval(read(input), env)) + +fun main(args: Array) { + val repl_env = Env() + ns.forEach({ it -> repl_env.set(it.key, it.value) }) + + rep("(def! not (fn* (a) (if a false true)))", repl_env) + + while (true) { + val input = readline("user> ") + + try { + println(rep(input, repl_env)) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + t.printStackTrace() + } + } +} diff --git a/impls/kotlin/src/mal/step5_tco.kt b/impls/kotlin/src/mal/step5_tco.kt index cfc750f387..141f8ba876 100644 --- a/impls/kotlin/src/mal/step5_tco.kt +++ b/impls/kotlin/src/mal/step5_tco.kt @@ -1,103 +1,103 @@ -package mal - -fun read(input: String?): MalType = read_str(input) - -fun eval(_ast: MalType, _env: Env): MalType { - var ast = _ast - var env = _env - - while (true) { - if (ast is MalList) { - if (ast.count() == 0) return ast - when ((ast.first() as? MalSymbol)?.value) { - "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) - "let*" -> { - val childEnv = Env(env) - val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") - - val it = bindings.seq().iterator() - while (it.hasNext()) { - val key = it.next() - if (!it.hasNext()) throw MalException("odd number of binding elements in let*") - childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) - } - - env = childEnv - ast = ast.nth(2) - } - "fn*" -> return fn_STAR(ast, env) - "do" -> { - eval_ast(ast.slice(1, ast.count() - 1), env) - ast = ast.seq().last() - } - "if" -> { - val check = eval(ast.nth(1), env) - - if (check !== NIL && check !== FALSE) { - ast = ast.nth(2) - } else if (ast.count() > 3) { - ast = ast.nth(3) - } else return NIL - } - else -> { - val evaluated = eval_ast(ast, env) as ISeq - val firstEval = evaluated.first() - - when (firstEval) { - is MalFnFunction -> { - ast = firstEval.ast - env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) - } - is MalFunction -> return firstEval.apply(evaluated.rest()) - else -> throw MalException("cannot execute non-function") - } - } - } - } else return eval_ast(ast, env) - } -} - -fun eval_ast(ast: MalType, env: Env): MalType = - when (ast) { - is MalSymbol -> env.get(ast) - is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) - else -> ast - } - -private fun fn_STAR(ast: MalList, env: Env): MalType { - val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") - val params = binds.seq().filterIsInstance() - val body = ast.nth(2) - - return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) -} - -fun print(result: MalType) = pr_str(result, print_readably = true) - -fun rep(input: String, env: Env): String = - print(eval(read(input), env)) - -fun main(args: Array) { - val repl_env = Env() - ns.forEach({ it -> repl_env.set(it.key, it.value) }) - - rep("(def! not (fn* (a) (if a false true)))", repl_env) - - while (true) { - val input = readline("user> ") - - try { - println(rep(input, repl_env)) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - t.printStackTrace() - } - } -} +package mal + +fun read(input: String?): MalType = read_str(input) + +fun eval(_ast: MalType, _env: Env): MalType { + var ast = _ast + var env = _env + + while (true) { + if (ast is MalList) { + if (ast.count() == 0) return ast + when ((ast.first() as? MalSymbol)?.value) { + "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) + "let*" -> { + val childEnv = Env(env) + val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") + + val it = bindings.seq().iterator() + while (it.hasNext()) { + val key = it.next() + if (!it.hasNext()) throw MalException("odd number of binding elements in let*") + childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) + } + + env = childEnv + ast = ast.nth(2) + } + "fn*" -> return fn_STAR(ast, env) + "do" -> { + eval_ast(ast.slice(1, ast.count() - 1), env) + ast = ast.seq().last() + } + "if" -> { + val check = eval(ast.nth(1), env) + + if (check !== NIL && check !== FALSE) { + ast = ast.nth(2) + } else if (ast.count() > 3) { + ast = ast.nth(3) + } else return NIL + } + else -> { + val evaluated = eval_ast(ast, env) as ISeq + val firstEval = evaluated.first() + + when (firstEval) { + is MalFnFunction -> { + ast = firstEval.ast + env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) + } + is MalFunction -> return firstEval.apply(evaluated.rest()) + else -> throw MalException("cannot execute non-function") + } + } + } + } else return eval_ast(ast, env) + } +} + +fun eval_ast(ast: MalType, env: Env): MalType = + when (ast) { + is MalSymbol -> env.get(ast) + is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) + else -> ast + } + +private fun fn_STAR(ast: MalList, env: Env): MalType { + val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") + val params = binds.seq().filterIsInstance() + val body = ast.nth(2) + + return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) +} + +fun print(result: MalType) = pr_str(result, print_readably = true) + +fun rep(input: String, env: Env): String = + print(eval(read(input), env)) + +fun main(args: Array) { + val repl_env = Env() + ns.forEach({ it -> repl_env.set(it.key, it.value) }) + + rep("(def! not (fn* (a) (if a false true)))", repl_env) + + while (true) { + val input = readline("user> ") + + try { + println(rep(input, repl_env)) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + t.printStackTrace() + } + } +} diff --git a/impls/kotlin/src/mal/step6_file.kt b/impls/kotlin/src/mal/step6_file.kt index 12baaaf33a..d1310a562a 100644 --- a/impls/kotlin/src/mal/step6_file.kt +++ b/impls/kotlin/src/mal/step6_file.kt @@ -1,114 +1,114 @@ -package mal - -import java.util.* - -fun read(input: String?): MalType = read_str(input) - -fun eval(_ast: MalType, _env: Env): MalType { - var ast = _ast - var env = _env - - while (true) { - if (ast is MalList) { - if (ast.count() == 0) return ast - when ((ast.first() as? MalSymbol)?.value) { - "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) - "let*" -> { - val childEnv = Env(env) - val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") - - val it = bindings.seq().iterator() - while (it.hasNext()) { - val key = it.next() - if (!it.hasNext()) throw MalException("odd number of binding elements in let*") - childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) - } - - env = childEnv - ast = ast.nth(2) - } - "fn*" -> return fn_STAR(ast, env) - "do" -> { - eval_ast(ast.slice(1, ast.count() - 1), env) - ast = ast.seq().last() - } - "if" -> { - val check = eval(ast.nth(1), env) - - if (check !== NIL && check !== FALSE) { - ast = ast.nth(2) - } else if (ast.count() > 3) { - ast = ast.nth(3) - } else return NIL - } - else -> { - val evaluated = eval_ast(ast, env) as ISeq - val firstEval = evaluated.first() - - when (firstEval) { - is MalFnFunction -> { - ast = firstEval.ast - env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) - } - is MalFunction -> return firstEval.apply(evaluated.rest()) - else -> throw MalException("cannot execute non-function") - } - } - } - } else return eval_ast(ast, env) - } -} - -fun eval_ast(ast: MalType, env: Env): MalType = - when (ast) { - is MalSymbol -> env.get(ast) - is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) - else -> ast - } - -private fun fn_STAR(ast: MalList, env: Env): MalType { - val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") - val params = binds.seq().filterIsInstance() - val body = ast.nth(2) - - return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) -} - -fun print(result: MalType) = pr_str(result, print_readably = true) - -fun rep(input: String, env: Env): String = - print(eval(read(input), env)) - -fun main(args: Array) { - val repl_env = Env() - ns.forEach({ it -> repl_env.set(it.key, it.value) }) - - repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) - repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) - - rep("(def! not (fn* (a) (if a false true)))", repl_env) - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - - if (args.any()) { - rep("(load-file \"${args[0]}\")", repl_env) - return - } - - while (true) { - val input = readline("user> ") - - try { - println(rep(input, repl_env)) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - t.printStackTrace() - } - } -} +package mal + +import java.util.* + +fun read(input: String?): MalType = read_str(input) + +fun eval(_ast: MalType, _env: Env): MalType { + var ast = _ast + var env = _env + + while (true) { + if (ast is MalList) { + if (ast.count() == 0) return ast + when ((ast.first() as? MalSymbol)?.value) { + "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) + "let*" -> { + val childEnv = Env(env) + val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") + + val it = bindings.seq().iterator() + while (it.hasNext()) { + val key = it.next() + if (!it.hasNext()) throw MalException("odd number of binding elements in let*") + childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) + } + + env = childEnv + ast = ast.nth(2) + } + "fn*" -> return fn_STAR(ast, env) + "do" -> { + eval_ast(ast.slice(1, ast.count() - 1), env) + ast = ast.seq().last() + } + "if" -> { + val check = eval(ast.nth(1), env) + + if (check !== NIL && check !== FALSE) { + ast = ast.nth(2) + } else if (ast.count() > 3) { + ast = ast.nth(3) + } else return NIL + } + else -> { + val evaluated = eval_ast(ast, env) as ISeq + val firstEval = evaluated.first() + + when (firstEval) { + is MalFnFunction -> { + ast = firstEval.ast + env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) + } + is MalFunction -> return firstEval.apply(evaluated.rest()) + else -> throw MalException("cannot execute non-function") + } + } + } + } else return eval_ast(ast, env) + } +} + +fun eval_ast(ast: MalType, env: Env): MalType = + when (ast) { + is MalSymbol -> env.get(ast) + is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) + else -> ast + } + +private fun fn_STAR(ast: MalList, env: Env): MalType { + val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") + val params = binds.seq().filterIsInstance() + val body = ast.nth(2) + + return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) +} + +fun print(result: MalType) = pr_str(result, print_readably = true) + +fun rep(input: String, env: Env): String = + print(eval(read(input), env)) + +fun main(args: Array) { + val repl_env = Env() + ns.forEach({ it -> repl_env.set(it.key, it.value) }) + + repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) + repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) + + rep("(def! not (fn* (a) (if a false true)))", repl_env) + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + + if (args.any()) { + rep("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + val input = readline("user> ") + + try { + println(rep(input, repl_env)) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + t.printStackTrace() + } + } +} diff --git a/impls/kotlin/src/mal/step7_quote.kt b/impls/kotlin/src/mal/step7_quote.kt index 9cb803fe98..a1d1eac683 100644 --- a/impls/kotlin/src/mal/step7_quote.kt +++ b/impls/kotlin/src/mal/step7_quote.kt @@ -1,155 +1,155 @@ -package mal - -import java.util.* - -fun read(input: String?): MalType = read_str(input) - -fun eval(_ast: MalType, _env: Env): MalType { - var ast = _ast - var env = _env - - while (true) { - if (ast is MalList) { - if (ast.count() == 0) return ast - when ((ast.first() as? MalSymbol)?.value) { - "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) - "let*" -> { - val childEnv = Env(env) - val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") - - val it = bindings.seq().iterator() - while (it.hasNext()) { - val key = it.next() - if (!it.hasNext()) throw MalException("odd number of binding elements in let*") - childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) - } - - env = childEnv - ast = ast.nth(2) - } - "fn*" -> return fn_STAR(ast, env) - "do" -> { - eval_ast(ast.slice(1, ast.count() - 1), env) - ast = ast.seq().last() - } - "if" -> { - val check = eval(ast.nth(1), env) - - if (check !== NIL && check !== FALSE) { - ast = ast.nth(2) - } else if (ast.count() > 3) { - ast = ast.nth(3) - } else return NIL - } - "quote" -> return ast.nth(1) - "quasiquoteexpand" -> return quasiquote(ast.nth(1)) - "quasiquote" -> ast = quasiquote(ast.nth(1)) - else -> { - val evaluated = eval_ast(ast, env) as ISeq - val firstEval = evaluated.first() - - when (firstEval) { - is MalFnFunction -> { - ast = firstEval.ast - env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) - } - is MalFunction -> return firstEval.apply(evaluated.rest()) - else -> throw MalException("cannot execute non-function") - } - } - } - } else return eval_ast(ast, env) - } -} - -fun eval_ast(ast: MalType, env: Env): MalType = - when (ast) { - is MalSymbol -> env.get(ast) - is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) - else -> ast - } - -private fun fn_STAR(ast: MalList, env: Env): MalType { - val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") - val params = binds.seq().filterIsInstance() - val body = ast.nth(2) - - return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) -} - -private fun quasiquote(ast: MalType): MalType { - when (ast) { - is MalList -> { - if (ast.count() == 2 && (ast.first() as? MalSymbol)?.value == "unquote") { - return ast.nth(1) - } else { - return ast.elements.foldRight(MalList(), ::quasiquote_loop) - } - } - is MalVector -> { - val result = MalList() - result.conj_BANG(MalSymbol("vec")) - result.conj_BANG(ast.elements.foldRight(MalList(), ::quasiquote_loop)) - return result - } - is MalSymbol, is MalHashMap -> { - val quoted = MalList() - quoted.conj_BANG(MalSymbol("quote")) - quoted.conj_BANG(ast) - return quoted - } - else -> return ast - } -} - -private fun quasiquote_loop(elt: MalType, acc: MalList): MalList { - val result = MalList() - if (elt is MalList && elt.count() == 2 && (elt.first() as? MalSymbol)?.value == "splice-unquote") { - result.conj_BANG(MalSymbol("concat")) - result.conj_BANG(elt.nth(1)) - } else { - result.conj_BANG(MalSymbol("cons")) - result.conj_BANG(quasiquote(elt)) - } - result.conj_BANG(acc) - return result -} - -fun print(result: MalType) = pr_str(result, print_readably = true) - -fun rep(input: String, env: Env): String = - print(eval(read(input), env)) - -fun main(args: Array) { - val repl_env = Env() - ns.forEach({ it -> repl_env.set(it.key, it.value) }) - - repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) - repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) - - rep("(def! not (fn* (a) (if a false true)))", repl_env) - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - - if (args.any()) { - rep("(load-file \"${args[0]}\")", repl_env) - return - } - - while (true) { - val input = readline("user> ") - - try { - println(rep(input, repl_env)) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - t.printStackTrace() - } - } -} +package mal + +import java.util.* + +fun read(input: String?): MalType = read_str(input) + +fun eval(_ast: MalType, _env: Env): MalType { + var ast = _ast + var env = _env + + while (true) { + if (ast is MalList) { + if (ast.count() == 0) return ast + when ((ast.first() as? MalSymbol)?.value) { + "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) + "let*" -> { + val childEnv = Env(env) + val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") + + val it = bindings.seq().iterator() + while (it.hasNext()) { + val key = it.next() + if (!it.hasNext()) throw MalException("odd number of binding elements in let*") + childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) + } + + env = childEnv + ast = ast.nth(2) + } + "fn*" -> return fn_STAR(ast, env) + "do" -> { + eval_ast(ast.slice(1, ast.count() - 1), env) + ast = ast.seq().last() + } + "if" -> { + val check = eval(ast.nth(1), env) + + if (check !== NIL && check !== FALSE) { + ast = ast.nth(2) + } else if (ast.count() > 3) { + ast = ast.nth(3) + } else return NIL + } + "quote" -> return ast.nth(1) + "quasiquoteexpand" -> return quasiquote(ast.nth(1)) + "quasiquote" -> ast = quasiquote(ast.nth(1)) + else -> { + val evaluated = eval_ast(ast, env) as ISeq + val firstEval = evaluated.first() + + when (firstEval) { + is MalFnFunction -> { + ast = firstEval.ast + env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) + } + is MalFunction -> return firstEval.apply(evaluated.rest()) + else -> throw MalException("cannot execute non-function") + } + } + } + } else return eval_ast(ast, env) + } +} + +fun eval_ast(ast: MalType, env: Env): MalType = + when (ast) { + is MalSymbol -> env.get(ast) + is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) + else -> ast + } + +private fun fn_STAR(ast: MalList, env: Env): MalType { + val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") + val params = binds.seq().filterIsInstance() + val body = ast.nth(2) + + return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) +} + +private fun quasiquote(ast: MalType): MalType { + when (ast) { + is MalList -> { + if (ast.count() == 2 && (ast.first() as? MalSymbol)?.value == "unquote") { + return ast.nth(1) + } else { + return ast.elements.foldRight(MalList(), ::quasiquote_loop) + } + } + is MalVector -> { + val result = MalList() + result.conj_BANG(MalSymbol("vec")) + result.conj_BANG(ast.elements.foldRight(MalList(), ::quasiquote_loop)) + return result + } + is MalSymbol, is MalHashMap -> { + val quoted = MalList() + quoted.conj_BANG(MalSymbol("quote")) + quoted.conj_BANG(ast) + return quoted + } + else -> return ast + } +} + +private fun quasiquote_loop(elt: MalType, acc: MalList): MalList { + val result = MalList() + if (elt is MalList && elt.count() == 2 && (elt.first() as? MalSymbol)?.value == "splice-unquote") { + result.conj_BANG(MalSymbol("concat")) + result.conj_BANG(elt.nth(1)) + } else { + result.conj_BANG(MalSymbol("cons")) + result.conj_BANG(quasiquote(elt)) + } + result.conj_BANG(acc) + return result +} + +fun print(result: MalType) = pr_str(result, print_readably = true) + +fun rep(input: String, env: Env): String = + print(eval(read(input), env)) + +fun main(args: Array) { + val repl_env = Env() + ns.forEach({ it -> repl_env.set(it.key, it.value) }) + + repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) + repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) + + rep("(def! not (fn* (a) (if a false true)))", repl_env) + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + + if (args.any()) { + rep("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + val input = readline("user> ") + + try { + println(rep(input, repl_env)) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + t.printStackTrace() + } + } +} diff --git a/impls/kotlin/src/mal/step8_macros.kt b/impls/kotlin/src/mal/step8_macros.kt index d3c031fae7..1130adf460 100644 --- a/impls/kotlin/src/mal/step8_macros.kt +++ b/impls/kotlin/src/mal/step8_macros.kt @@ -1,186 +1,186 @@ -package mal - -import java.util.* - -fun read(input: String?): MalType = read_str(input) - -fun eval(_ast: MalType, _env: Env): MalType { - var ast = _ast - var env = _env - - while (true) { - ast = macroexpand(ast, env) - - if (ast is MalList) { - if (ast.count() == 0) return ast - when ((ast.first() as? MalSymbol)?.value) { - "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) - "let*" -> { - val childEnv = Env(env) - val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") - - val it = bindings.seq().iterator() - while (it.hasNext()) { - val key = it.next() - if (!it.hasNext()) throw MalException("odd number of binding elements in let*") - childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) - } - - env = childEnv - ast = ast.nth(2) - } - "fn*" -> return fn_STAR(ast, env) - "do" -> { - eval_ast(ast.slice(1, ast.count() - 1), env) - ast = ast.seq().last() - } - "if" -> { - val check = eval(ast.nth(1), env) - - if (check !== NIL && check !== FALSE) { - ast = ast.nth(2) - } else if (ast.count() > 3) { - ast = ast.nth(3) - } else return NIL - } - "quote" -> return ast.nth(1) - "quasiquoteexpand" -> return quasiquote(ast.nth(1)) - "quasiquote" -> ast = quasiquote(ast.nth(1)) - "defmacro!" -> return defmacro(ast, env) - "macroexpand" -> return macroexpand(ast.nth(1), env) - else -> { - val evaluated = eval_ast(ast, env) as ISeq - val firstEval = evaluated.first() - - when (firstEval) { - is MalFnFunction -> { - ast = firstEval.ast - env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) - } - is MalFunction -> return firstEval.apply(evaluated.rest()) - else -> throw MalException("cannot execute non-function") - } - } - } - } else return eval_ast(ast, env) - } -} - -fun eval_ast(ast: MalType, env: Env): MalType = - when (ast) { - is MalSymbol -> env.get(ast) - is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) - else -> ast - } - -private fun fn_STAR(ast: MalList, env: Env): MalType { - val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") - val params = binds.seq().filterIsInstance() - val body = ast.nth(2) - - return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) -} - -private fun quasiquote(ast: MalType): MalType { - when (ast) { - is MalList -> { - if (ast.count() == 2 && (ast.first() as? MalSymbol)?.value == "unquote") { - return ast.nth(1) - } else { - return ast.elements.foldRight(MalList(), ::quasiquote_loop) - } - } - is MalVector -> { - val result = MalList() - result.conj_BANG(MalSymbol("vec")) - result.conj_BANG(ast.elements.foldRight(MalList(), ::quasiquote_loop)) - return result - } - is MalSymbol, is MalHashMap -> { - val quoted = MalList() - quoted.conj_BANG(MalSymbol("quote")) - quoted.conj_BANG(ast) - return quoted - } - else -> return ast - } -} - -private fun quasiquote_loop(elt: MalType, acc: MalList): MalList { - val result = MalList() - if (elt is MalList && elt.count() == 2 && (elt.first() as? MalSymbol)?.value == "splice-unquote") { - result.conj_BANG(MalSymbol("concat")) - result.conj_BANG(elt.nth(1)) - } else { - result.conj_BANG(MalSymbol("cons")) - result.conj_BANG(quasiquote(elt)) - } - result.conj_BANG(acc) - return result -} - -private fun is_macro_call(ast: MalType, env: Env): Boolean { - val ast_list = ast as? MalList ?: return false - if (ast_list.count() == 0) return false - val symbol = ast_list.first() as? MalSymbol ?: return false - val function = env.find(symbol) as? MalFunction ?: return false - - return function.is_macro -} - -private fun macroexpand(_ast: MalType, env: Env): MalType { - var ast = _ast - while (is_macro_call(ast, env)) { - val symbol = (ast as MalList).first() as MalSymbol - val function = env.find(symbol) as MalFunction - ast = function.apply(ast.rest()) - } - return ast -} - -private fun defmacro(ast: MalList, env: Env): MalType { - val macro = eval(ast.nth(2), env) as MalFunction - macro.is_macro = true - - return env.set(ast.nth(1) as MalSymbol, macro) -} - -fun print(result: MalType) = pr_str(result, print_readably = true) - -fun rep(input: String, env: Env): String = - print(eval(read(input), env)) - -fun main(args: Array) { - val repl_env = Env() - ns.forEach({ it -> repl_env.set(it.key, it.value) }) - - repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) - repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) - - rep("(def! not (fn* (a) (if a false true)))", repl_env) - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - 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)))))))", repl_env) - - if (args.any()) { - rep("(load-file \"${args[0]}\")", repl_env) - return - } - - while (true) { - val input = readline("user> ") - - try { - println(rep(input, repl_env)) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - t.printStackTrace() - } - } -} +package mal + +import java.util.* + +fun read(input: String?): MalType = read_str(input) + +fun eval(_ast: MalType, _env: Env): MalType { + var ast = _ast + var env = _env + + while (true) { + ast = macroexpand(ast, env) + + if (ast is MalList) { + if (ast.count() == 0) return ast + when ((ast.first() as? MalSymbol)?.value) { + "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) + "let*" -> { + val childEnv = Env(env) + val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") + + val it = bindings.seq().iterator() + while (it.hasNext()) { + val key = it.next() + if (!it.hasNext()) throw MalException("odd number of binding elements in let*") + childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) + } + + env = childEnv + ast = ast.nth(2) + } + "fn*" -> return fn_STAR(ast, env) + "do" -> { + eval_ast(ast.slice(1, ast.count() - 1), env) + ast = ast.seq().last() + } + "if" -> { + val check = eval(ast.nth(1), env) + + if (check !== NIL && check !== FALSE) { + ast = ast.nth(2) + } else if (ast.count() > 3) { + ast = ast.nth(3) + } else return NIL + } + "quote" -> return ast.nth(1) + "quasiquoteexpand" -> return quasiquote(ast.nth(1)) + "quasiquote" -> ast = quasiquote(ast.nth(1)) + "defmacro!" -> return defmacro(ast, env) + "macroexpand" -> return macroexpand(ast.nth(1), env) + else -> { + val evaluated = eval_ast(ast, env) as ISeq + val firstEval = evaluated.first() + + when (firstEval) { + is MalFnFunction -> { + ast = firstEval.ast + env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) + } + is MalFunction -> return firstEval.apply(evaluated.rest()) + else -> throw MalException("cannot execute non-function") + } + } + } + } else return eval_ast(ast, env) + } +} + +fun eval_ast(ast: MalType, env: Env): MalType = + when (ast) { + is MalSymbol -> env.get(ast) + is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) + else -> ast + } + +private fun fn_STAR(ast: MalList, env: Env): MalType { + val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") + val params = binds.seq().filterIsInstance() + val body = ast.nth(2) + + return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) +} + +private fun quasiquote(ast: MalType): MalType { + when (ast) { + is MalList -> { + if (ast.count() == 2 && (ast.first() as? MalSymbol)?.value == "unquote") { + return ast.nth(1) + } else { + return ast.elements.foldRight(MalList(), ::quasiquote_loop) + } + } + is MalVector -> { + val result = MalList() + result.conj_BANG(MalSymbol("vec")) + result.conj_BANG(ast.elements.foldRight(MalList(), ::quasiquote_loop)) + return result + } + is MalSymbol, is MalHashMap -> { + val quoted = MalList() + quoted.conj_BANG(MalSymbol("quote")) + quoted.conj_BANG(ast) + return quoted + } + else -> return ast + } +} + +private fun quasiquote_loop(elt: MalType, acc: MalList): MalList { + val result = MalList() + if (elt is MalList && elt.count() == 2 && (elt.first() as? MalSymbol)?.value == "splice-unquote") { + result.conj_BANG(MalSymbol("concat")) + result.conj_BANG(elt.nth(1)) + } else { + result.conj_BANG(MalSymbol("cons")) + result.conj_BANG(quasiquote(elt)) + } + result.conj_BANG(acc) + return result +} + +private fun is_macro_call(ast: MalType, env: Env): Boolean { + val ast_list = ast as? MalList ?: return false + if (ast_list.count() == 0) return false + val symbol = ast_list.first() as? MalSymbol ?: return false + val function = env.find(symbol) as? MalFunction ?: return false + + return function.is_macro +} + +private fun macroexpand(_ast: MalType, env: Env): MalType { + var ast = _ast + while (is_macro_call(ast, env)) { + val symbol = (ast as MalList).first() as MalSymbol + val function = env.find(symbol) as MalFunction + ast = function.apply(ast.rest()) + } + return ast +} + +private fun defmacro(ast: MalList, env: Env): MalType { + val macro = eval(ast.nth(2), env) as MalFunction + macro.is_macro = true + + return env.set(ast.nth(1) as MalSymbol, macro) +} + +fun print(result: MalType) = pr_str(result, print_readably = true) + +fun rep(input: String, env: Env): String = + print(eval(read(input), env)) + +fun main(args: Array) { + val repl_env = Env() + ns.forEach({ it -> repl_env.set(it.key, it.value) }) + + repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) + repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) + + rep("(def! not (fn* (a) (if a false true)))", repl_env) + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + 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)))))))", repl_env) + + if (args.any()) { + rep("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + val input = readline("user> ") + + try { + println(rep(input, repl_env)) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + t.printStackTrace() + } + } +} diff --git a/impls/kotlin/src/mal/step9_try.kt b/impls/kotlin/src/mal/step9_try.kt index a65659f860..46060c2c10 100644 --- a/impls/kotlin/src/mal/step9_try.kt +++ b/impls/kotlin/src/mal/step9_try.kt @@ -1,202 +1,202 @@ -package mal - -import java.util.* - -fun read(input: String?): MalType = read_str(input) - -fun eval(_ast: MalType, _env: Env): MalType { - var ast = _ast - var env = _env - - while (true) { - ast = macroexpand(ast, env) - - if (ast is MalList) { - if (ast.count() == 0) return ast - when ((ast.first() as? MalSymbol)?.value) { - "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) - "let*" -> { - val childEnv = Env(env) - val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") - - val it = bindings.seq().iterator() - while (it.hasNext()) { - val key = it.next() - if (!it.hasNext()) throw MalException("odd number of binding elements in let*") - childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) - } - - env = childEnv - ast = ast.nth(2) - } - "fn*" -> return fn_STAR(ast, env) - "do" -> { - eval_ast(ast.slice(1, ast.count() - 1), env) - ast = ast.seq().last() - } - "if" -> { - val check = eval(ast.nth(1), env) - - if (check !== NIL && check !== FALSE) { - ast = ast.nth(2) - } else if (ast.count() > 3) { - ast = ast.nth(3) - } else return NIL - } - "quote" -> return ast.nth(1) - "quasiquoteexpand" -> return quasiquote(ast.nth(1)) - "quasiquote" -> ast = quasiquote(ast.nth(1)) - "defmacro!" -> return defmacro(ast, env) - "macroexpand" -> return macroexpand(ast.nth(1), env) - "try*" -> return try_catch(ast, env) - else -> { - val evaluated = eval_ast(ast, env) as ISeq - val firstEval = evaluated.first() - - when (firstEval) { - is MalFnFunction -> { - ast = firstEval.ast - env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) - } - is MalFunction -> return firstEval.apply(evaluated.rest()) - else -> throw MalException("cannot execute non-function") - } - } - } - } else return eval_ast(ast, env) - } -} - -fun eval_ast(ast: MalType, env: Env): MalType = - when (ast) { - is MalSymbol -> env.get(ast) - is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) - else -> ast - } - -private fun fn_STAR(ast: MalList, env: Env): MalType { - val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") - val params = binds.seq().filterIsInstance() - val body = ast.nth(2) - - return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) -} - -private fun quasiquote(ast: MalType): MalType { - when (ast) { - is MalList -> { - if (ast.count() == 2 && (ast.first() as? MalSymbol)?.value == "unquote") { - return ast.nth(1) - } else { - return ast.elements.foldRight(MalList(), ::quasiquote_loop) - } - } - is MalVector -> { - val result = MalList() - result.conj_BANG(MalSymbol("vec")) - result.conj_BANG(ast.elements.foldRight(MalList(), ::quasiquote_loop)) - return result - } - is MalSymbol, is MalHashMap -> { - val quoted = MalList() - quoted.conj_BANG(MalSymbol("quote")) - quoted.conj_BANG(ast) - return quoted - } - else -> return ast - } -} - -private fun quasiquote_loop(elt: MalType, acc: MalList): MalList { - val result = MalList() - if (elt is MalList && elt.count() == 2 && (elt.first() as? MalSymbol)?.value == "splice-unquote") { - result.conj_BANG(MalSymbol("concat")) - result.conj_BANG(elt.nth(1)) - } else { - result.conj_BANG(MalSymbol("cons")) - result.conj_BANG(quasiquote(elt)) - } - result.conj_BANG(acc) - return result -} - -private fun is_macro_call(ast: MalType, env: Env): Boolean { - val ast_list = ast as? MalList ?: return false - if (ast_list.count() == 0) return false - val symbol = ast_list.first() as? MalSymbol ?: return false - val function = env.find(symbol) as? MalFunction ?: return false - - return function.is_macro -} - -private fun macroexpand(_ast: MalType, env: Env): MalType { - var ast = _ast - while (is_macro_call(ast, env)) { - val symbol = (ast as MalList).first() as MalSymbol - val function = env.find(symbol) as MalFunction - ast = function.apply(ast.rest()) - } - return ast -} - -private fun defmacro(ast: MalList, env: Env): MalType { - val macro = eval(ast.nth(2), env) as MalFunction - macro.is_macro = true - - return env.set(ast.nth(1) as MalSymbol, macro) -} - -private fun try_catch(ast: MalList, env: Env): MalType = - try { - eval(ast.nth(1), env) - } catch (e: Exception) { - if (ast.count() < 3) { throw e } - val thrown = if (e is MalException) e else MalException(e.message) - val symbol = (ast.nth(2) as MalList).nth(1) as MalSymbol - - val catchBody = (ast.nth(2) as MalList).nth(2) - val catchEnv = Env(env) - catchEnv.set(symbol, thrown) - - eval(catchBody, catchEnv) - } - -fun print(result: MalType) = pr_str(result, print_readably = true) - -fun rep(input: String, env: Env): String = - print(eval(read(input), env)) - -fun main(args: Array) { - val repl_env = Env() - ns.forEach({ it -> repl_env.set(it.key, it.value) }) - - repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) - repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) - - rep("(def! not (fn* (a) (if a false true)))", repl_env) - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - 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)))))))", repl_env) - - if (args.any()) { - rep("(load-file \"${args[0]}\")", repl_env) - return - } - - while (true) { - val input = readline("user> ") - - try { - println(rep(input, repl_env)) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - t.printStackTrace() - } - } -} +package mal + +import java.util.* + +fun read(input: String?): MalType = read_str(input) + +fun eval(_ast: MalType, _env: Env): MalType { + var ast = _ast + var env = _env + + while (true) { + ast = macroexpand(ast, env) + + if (ast is MalList) { + if (ast.count() == 0) return ast + when ((ast.first() as? MalSymbol)?.value) { + "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) + "let*" -> { + val childEnv = Env(env) + val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") + + val it = bindings.seq().iterator() + while (it.hasNext()) { + val key = it.next() + if (!it.hasNext()) throw MalException("odd number of binding elements in let*") + childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) + } + + env = childEnv + ast = ast.nth(2) + } + "fn*" -> return fn_STAR(ast, env) + "do" -> { + eval_ast(ast.slice(1, ast.count() - 1), env) + ast = ast.seq().last() + } + "if" -> { + val check = eval(ast.nth(1), env) + + if (check !== NIL && check !== FALSE) { + ast = ast.nth(2) + } else if (ast.count() > 3) { + ast = ast.nth(3) + } else return NIL + } + "quote" -> return ast.nth(1) + "quasiquoteexpand" -> return quasiquote(ast.nth(1)) + "quasiquote" -> ast = quasiquote(ast.nth(1)) + "defmacro!" -> return defmacro(ast, env) + "macroexpand" -> return macroexpand(ast.nth(1), env) + "try*" -> return try_catch(ast, env) + else -> { + val evaluated = eval_ast(ast, env) as ISeq + val firstEval = evaluated.first() + + when (firstEval) { + is MalFnFunction -> { + ast = firstEval.ast + env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) + } + is MalFunction -> return firstEval.apply(evaluated.rest()) + else -> throw MalException("cannot execute non-function") + } + } + } + } else return eval_ast(ast, env) + } +} + +fun eval_ast(ast: MalType, env: Env): MalType = + when (ast) { + is MalSymbol -> env.get(ast) + is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) + else -> ast + } + +private fun fn_STAR(ast: MalList, env: Env): MalType { + val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") + val params = binds.seq().filterIsInstance() + val body = ast.nth(2) + + return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) +} + +private fun quasiquote(ast: MalType): MalType { + when (ast) { + is MalList -> { + if (ast.count() == 2 && (ast.first() as? MalSymbol)?.value == "unquote") { + return ast.nth(1) + } else { + return ast.elements.foldRight(MalList(), ::quasiquote_loop) + } + } + is MalVector -> { + val result = MalList() + result.conj_BANG(MalSymbol("vec")) + result.conj_BANG(ast.elements.foldRight(MalList(), ::quasiquote_loop)) + return result + } + is MalSymbol, is MalHashMap -> { + val quoted = MalList() + quoted.conj_BANG(MalSymbol("quote")) + quoted.conj_BANG(ast) + return quoted + } + else -> return ast + } +} + +private fun quasiquote_loop(elt: MalType, acc: MalList): MalList { + val result = MalList() + if (elt is MalList && elt.count() == 2 && (elt.first() as? MalSymbol)?.value == "splice-unquote") { + result.conj_BANG(MalSymbol("concat")) + result.conj_BANG(elt.nth(1)) + } else { + result.conj_BANG(MalSymbol("cons")) + result.conj_BANG(quasiquote(elt)) + } + result.conj_BANG(acc) + return result +} + +private fun is_macro_call(ast: MalType, env: Env): Boolean { + val ast_list = ast as? MalList ?: return false + if (ast_list.count() == 0) return false + val symbol = ast_list.first() as? MalSymbol ?: return false + val function = env.find(symbol) as? MalFunction ?: return false + + return function.is_macro +} + +private fun macroexpand(_ast: MalType, env: Env): MalType { + var ast = _ast + while (is_macro_call(ast, env)) { + val symbol = (ast as MalList).first() as MalSymbol + val function = env.find(symbol) as MalFunction + ast = function.apply(ast.rest()) + } + return ast +} + +private fun defmacro(ast: MalList, env: Env): MalType { + val macro = eval(ast.nth(2), env) as MalFunction + macro.is_macro = true + + return env.set(ast.nth(1) as MalSymbol, macro) +} + +private fun try_catch(ast: MalList, env: Env): MalType = + try { + eval(ast.nth(1), env) + } catch (e: Exception) { + if (ast.count() < 3) { throw e } + val thrown = if (e is MalException) e else MalException(e.message) + val symbol = (ast.nth(2) as MalList).nth(1) as MalSymbol + + val catchBody = (ast.nth(2) as MalList).nth(2) + val catchEnv = Env(env) + catchEnv.set(symbol, thrown) + + eval(catchBody, catchEnv) + } + +fun print(result: MalType) = pr_str(result, print_readably = true) + +fun rep(input: String, env: Env): String = + print(eval(read(input), env)) + +fun main(args: Array) { + val repl_env = Env() + ns.forEach({ it -> repl_env.set(it.key, it.value) }) + + repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) + repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) + + rep("(def! not (fn* (a) (if a false true)))", repl_env) + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + 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)))))))", repl_env) + + if (args.any()) { + rep("(load-file \"${args[0]}\")", repl_env) + return + } + + while (true) { + val input = readline("user> ") + + try { + println(rep(input, repl_env)) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + t.printStackTrace() + } + } +} diff --git a/impls/kotlin/src/mal/stepA_mal.kt b/impls/kotlin/src/mal/stepA_mal.kt index b72bfd3627..151f87084a 100644 --- a/impls/kotlin/src/mal/stepA_mal.kt +++ b/impls/kotlin/src/mal/stepA_mal.kt @@ -1,203 +1,203 @@ -package mal - -import java.util.* - -fun read(input: String?): MalType = read_str(input) - -fun eval(_ast: MalType, _env: Env): MalType { - var ast = _ast - var env = _env - - while (true) { - ast = macroexpand(ast, env) - - if (ast is MalList) { - if (ast.count() == 0) return ast - when ((ast.first() as? MalSymbol)?.value) { - "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) - "let*" -> { - val childEnv = Env(env) - val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") - - val it = bindings.seq().iterator() - while (it.hasNext()) { - val key = it.next() - if (!it.hasNext()) throw MalException("odd number of binding elements in let*") - childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) - } - - env = childEnv - ast = ast.nth(2) - } - "fn*" -> return fn_STAR(ast, env) - "do" -> { - eval_ast(ast.slice(1, ast.count() - 1), env) - ast = ast.seq().last() - } - "if" -> { - val check = eval(ast.nth(1), env) - - if (check !== NIL && check !== FALSE) { - ast = ast.nth(2) - } else if (ast.count() > 3) { - ast = ast.nth(3) - } else return NIL - } - "quote" -> return ast.nth(1) - "quasiquoteexpand" -> return quasiquote(ast.nth(1)) - "quasiquote" -> ast = quasiquote(ast.nth(1)) - "defmacro!" -> return defmacro(ast, env) - "macroexpand" -> return macroexpand(ast.nth(1), env) - "try*" -> return try_catch(ast, env) - else -> { - val evaluated = eval_ast(ast, env) as ISeq - val firstEval = evaluated.first() - - when (firstEval) { - is MalFnFunction -> { - ast = firstEval.ast - env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) - } - is MalFunction -> return firstEval.apply(evaluated.rest()) - else -> throw MalException("cannot execute non-function") - } - } - } - } else return eval_ast(ast, env) - } -} - -fun eval_ast(ast: MalType, env: Env): MalType = - when (ast) { - is MalSymbol -> env.get(ast) - is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) - is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) - else -> ast - } - -private fun fn_STAR(ast: MalList, env: Env): MalType { - val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") - val params = binds.seq().filterIsInstance() - val body = ast.nth(2) - - return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) -} - -private fun quasiquote(ast: MalType): MalType { - when (ast) { - is MalList -> { - if (ast.count() == 2 && (ast.first() as? MalSymbol)?.value == "unquote") { - return ast.nth(1) - } else { - return ast.elements.foldRight(MalList(), ::quasiquote_loop) - } - } - is MalVector -> { - val result = MalList() - result.conj_BANG(MalSymbol("vec")) - result.conj_BANG(ast.elements.foldRight(MalList(), ::quasiquote_loop)) - return result - } - is MalSymbol, is MalHashMap -> { - val quoted = MalList() - quoted.conj_BANG(MalSymbol("quote")) - quoted.conj_BANG(ast) - return quoted - } - else -> return ast - } -} - -private fun quasiquote_loop(elt: MalType, acc: MalList): MalList { - val result = MalList() - if (elt is MalList && elt.count() == 2 && (elt.first() as? MalSymbol)?.value == "splice-unquote") { - result.conj_BANG(MalSymbol("concat")) - result.conj_BANG(elt.nth(1)) - } else { - result.conj_BANG(MalSymbol("cons")) - result.conj_BANG(quasiquote(elt)) - } - result.conj_BANG(acc) - return result -} - -private fun is_macro_call(ast: MalType, env: Env): Boolean { - val ast_list = ast as? MalList ?: return false - if (ast_list.count() == 0) return false - val symbol = ast_list.first() as? MalSymbol ?: return false - val function = env.find(symbol) as? MalFunction ?: return false - - return function.is_macro -} - -private fun macroexpand(_ast: MalType, env: Env): MalType { - var ast = _ast - while (is_macro_call(ast, env)) { - val symbol = (ast as MalList).first() as MalSymbol - val function = env.find(symbol) as MalFunction - ast = function.apply(ast.rest()) - } - return ast -} - -private fun defmacro(ast: MalList, env: Env): MalType { - val macro = eval(ast.nth(2), env) as MalFunction - macro.is_macro = true - - return env.set(ast.nth(1) as MalSymbol, macro) -} - -private fun try_catch(ast: MalList, env: Env): MalType = - try { - eval(ast.nth(1), env) - } catch (e: Exception) { - if (ast.count() < 3) { throw e } - val thrown = if (e is MalException) e else MalException(e.message) - val symbol = (ast.nth(2) as MalList).nth(1) as MalSymbol - - val catchBody = (ast.nth(2) as MalList).nth(2) - val catchEnv = Env(env) - catchEnv.set(symbol, thrown) - - eval(catchBody, catchEnv) - } - -fun print(result: MalType) = pr_str(result, print_readably = true) - -fun rep(input: String, env: Env): String = - print(eval(read(input), env)) - -fun main(args: Array) { - val repl_env = Env() - ns.forEach({ it -> repl_env.set(it.key, it.value) }) - - repl_env.set(MalSymbol("*host-language*"), MalString("kotlin")) - repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) - repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) - - rep("(def! not (fn* (a) (if a false true)))", repl_env) - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - 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)))))))", repl_env) - - if (args.any()) { - rep("(load-file \"${args[0]}\")", repl_env) - return - } - - rep("(println (str \"Mal [\" *host-language* \"]\"))", repl_env) - while (true) { - val input = readline("user> ") - try { - println(rep(input, repl_env)) - } catch (e: EofException) { - break - } catch (e: MalContinue) { - } catch (e: MalException) { - println("Error: " + e.message) - } catch (t: Throwable) { - println("Uncaught " + t + ": " + t.message) - t.printStackTrace() - } - } -} +package mal + +import java.util.* + +fun read(input: String?): MalType = read_str(input) + +fun eval(_ast: MalType, _env: Env): MalType { + var ast = _ast + var env = _env + + while (true) { + ast = macroexpand(ast, env) + + if (ast is MalList) { + if (ast.count() == 0) return ast + when ((ast.first() as? MalSymbol)?.value) { + "def!" -> return env.set(ast.nth(1) as MalSymbol, eval(ast.nth(2), env)) + "let*" -> { + val childEnv = Env(env) + val bindings = ast.nth(1) as? ISeq ?: throw MalException("expected sequence as the first parameter to let*") + + val it = bindings.seq().iterator() + while (it.hasNext()) { + val key = it.next() + if (!it.hasNext()) throw MalException("odd number of binding elements in let*") + childEnv.set(key as MalSymbol, eval(it.next(), childEnv)) + } + + env = childEnv + ast = ast.nth(2) + } + "fn*" -> return fn_STAR(ast, env) + "do" -> { + eval_ast(ast.slice(1, ast.count() - 1), env) + ast = ast.seq().last() + } + "if" -> { + val check = eval(ast.nth(1), env) + + if (check !== NIL && check !== FALSE) { + ast = ast.nth(2) + } else if (ast.count() > 3) { + ast = ast.nth(3) + } else return NIL + } + "quote" -> return ast.nth(1) + "quasiquoteexpand" -> return quasiquote(ast.nth(1)) + "quasiquote" -> ast = quasiquote(ast.nth(1)) + "defmacro!" -> return defmacro(ast, env) + "macroexpand" -> return macroexpand(ast.nth(1), env) + "try*" -> return try_catch(ast, env) + else -> { + val evaluated = eval_ast(ast, env) as ISeq + val firstEval = evaluated.first() + + when (firstEval) { + is MalFnFunction -> { + ast = firstEval.ast + env = Env(firstEval.env, firstEval.params, evaluated.rest().seq()) + } + is MalFunction -> return firstEval.apply(evaluated.rest()) + else -> throw MalException("cannot execute non-function") + } + } + } + } else return eval_ast(ast, env) + } +} + +fun eval_ast(ast: MalType, env: Env): MalType = + when (ast) { + is MalSymbol -> env.get(ast) + is MalList -> ast.elements.fold(MalList(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalVector -> ast.elements.fold(MalVector(), { a, b -> a.conj_BANG(eval(b, env)); a }) + is MalHashMap -> ast.elements.entries.fold(MalHashMap(), { a, b -> a.assoc_BANG(b.key, eval(b.value, env)); a }) + else -> ast + } + +private fun fn_STAR(ast: MalList, env: Env): MalType { + val binds = ast.nth(1) as? ISeq ?: throw MalException("fn* requires a binding list as first parameter") + val params = binds.seq().filterIsInstance() + val body = ast.nth(2) + + return MalFnFunction(body, params, env, { s: ISeq -> eval(body, Env(env, params, s.seq())) }) +} + +private fun quasiquote(ast: MalType): MalType { + when (ast) { + is MalList -> { + if (ast.count() == 2 && (ast.first() as? MalSymbol)?.value == "unquote") { + return ast.nth(1) + } else { + return ast.elements.foldRight(MalList(), ::quasiquote_loop) + } + } + is MalVector -> { + val result = MalList() + result.conj_BANG(MalSymbol("vec")) + result.conj_BANG(ast.elements.foldRight(MalList(), ::quasiquote_loop)) + return result + } + is MalSymbol, is MalHashMap -> { + val quoted = MalList() + quoted.conj_BANG(MalSymbol("quote")) + quoted.conj_BANG(ast) + return quoted + } + else -> return ast + } +} + +private fun quasiquote_loop(elt: MalType, acc: MalList): MalList { + val result = MalList() + if (elt is MalList && elt.count() == 2 && (elt.first() as? MalSymbol)?.value == "splice-unquote") { + result.conj_BANG(MalSymbol("concat")) + result.conj_BANG(elt.nth(1)) + } else { + result.conj_BANG(MalSymbol("cons")) + result.conj_BANG(quasiquote(elt)) + } + result.conj_BANG(acc) + return result +} + +private fun is_macro_call(ast: MalType, env: Env): Boolean { + val ast_list = ast as? MalList ?: return false + if (ast_list.count() == 0) return false + val symbol = ast_list.first() as? MalSymbol ?: return false + val function = env.find(symbol) as? MalFunction ?: return false + + return function.is_macro +} + +private fun macroexpand(_ast: MalType, env: Env): MalType { + var ast = _ast + while (is_macro_call(ast, env)) { + val symbol = (ast as MalList).first() as MalSymbol + val function = env.find(symbol) as MalFunction + ast = function.apply(ast.rest()) + } + return ast +} + +private fun defmacro(ast: MalList, env: Env): MalType { + val macro = eval(ast.nth(2), env) as MalFunction + macro.is_macro = true + + return env.set(ast.nth(1) as MalSymbol, macro) +} + +private fun try_catch(ast: MalList, env: Env): MalType = + try { + eval(ast.nth(1), env) + } catch (e: Exception) { + if (ast.count() < 3) { throw e } + val thrown = if (e is MalException) e else MalException(e.message) + val symbol = (ast.nth(2) as MalList).nth(1) as MalSymbol + + val catchBody = (ast.nth(2) as MalList).nth(2) + val catchEnv = Env(env) + catchEnv.set(symbol, thrown) + + eval(catchBody, catchEnv) + } + +fun print(result: MalType) = pr_str(result, print_readably = true) + +fun rep(input: String, env: Env): String = + print(eval(read(input), env)) + +fun main(args: Array) { + val repl_env = Env() + ns.forEach({ it -> repl_env.set(it.key, it.value) }) + + repl_env.set(MalSymbol("*host-language*"), MalString("kotlin")) + repl_env.set(MalSymbol("*ARGV*"), MalList(args.drop(1).map({ it -> MalString(it) }).toCollection(LinkedList()))) + repl_env.set(MalSymbol("eval"), MalFunction({ a: ISeq -> eval(a.first(), repl_env) })) + + rep("(def! not (fn* (a) (if a false true)))", repl_env) + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + 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)))))))", repl_env) + + if (args.any()) { + rep("(load-file \"${args[0]}\")", repl_env) + return + } + + rep("(println (str \"Mal [\" *host-language* \"]\"))", repl_env) + while (true) { + val input = readline("user> ") + try { + println(rep(input, repl_env)) + } catch (e: EofException) { + break + } catch (e: MalContinue) { + } catch (e: MalException) { + println("Error: " + e.message) + } catch (t: Throwable) { + println("Uncaught " + t + ": " + t.message) + t.printStackTrace() + } + } +} diff --git a/impls/kotlin/src/mal/types.kt b/impls/kotlin/src/mal/types.kt index a981f4ecb1..30366477b3 100644 --- a/impls/kotlin/src/mal/types.kt +++ b/impls/kotlin/src/mal/types.kt @@ -1,222 +1,222 @@ -package mal - -import java.util.* - -open class MalException(message: String?) : Exception(message), MalType { - override var metadata: MalType = NIL - override fun with_meta(meta: MalType): MalType { - val exception = MalException(message) - exception.metadata = meta - return exception - } -} - -class MalContinue() : MalException("continue") -class MalReaderException(message: String) : MalException(message) -class MalPrinterException(message: String) : MalException(message) - -class MalCoreException(message: String, val value: MalType) : MalException(message) { - override fun with_meta(meta: MalType): MalType { - val exception = MalCoreException(message as String, value) - exception.metadata = meta - return exception - } -} - -interface MalType { - var metadata: MalType - fun with_meta(meta: MalType): MalType -} - -open class MalConstant(val value: String) : MalType { - override var metadata: MalType = NIL - - override fun equals(other: Any?): Boolean = other is MalConstant && value.equals(other.value) - override fun hashCode(): Int = value.hashCode() - - override fun with_meta(meta: MalType): MalType { - val obj = MalConstant(value) - obj.metadata = meta - return obj - } -} - -class MalInteger(val value: Long) : MalType { - override var metadata: MalType = NIL - - operator fun plus(a: MalInteger): MalInteger = MalInteger(value + a.value) - operator fun minus(a: MalInteger): MalInteger = MalInteger(value - a.value) - operator fun times(a: MalInteger): MalInteger = MalInteger(value * a.value) - operator fun div(a: MalInteger): MalInteger = MalInteger(value / a.value) - operator fun compareTo(a: MalInteger): Int = value.compareTo(a.value) - - override fun equals(other: Any?): Boolean = other is MalInteger && value.equals(other.value) - - override fun with_meta(meta: MalType): MalType { - val obj = MalInteger(value) - obj.metadata = meta - return obj - } -} - -class MalSymbol(val value: String) : MalType { - override var metadata: MalType = NIL - - override fun equals(other: Any?): Boolean = other is MalSymbol && value.equals(other.value) - - override fun with_meta(meta: MalType): MalType { - val obj = MalSymbol(value) - obj.metadata = meta - return obj - } -} - -open class MalString(value: String) : MalConstant(value) { - override fun with_meta(meta: MalType): MalType { - val obj = MalString(value) - obj.metadata = meta - return obj - } -} - -class MalKeyword(value: String) : MalString("\u029E" + value) { - override fun with_meta(meta: MalType): MalType { - val obj = MalKeyword(value) - obj.metadata = meta - return obj - } -} - -interface ILambda : MalType { - fun apply(seq: ISeq): MalType -} - -open class MalFunction(val lambda: (ISeq) -> MalType) : MalType, ILambda { - var is_macro: Boolean = false - override var metadata: MalType = NIL - - override fun apply(seq: ISeq): MalType = lambda(seq) - - override fun with_meta(meta: MalType): MalType { - val obj = MalFunction(lambda) - obj.metadata = meta - return obj - } -} - -class MalFnFunction(val ast: MalType, val params: Sequence, val env: Env, lambda: (ISeq) -> MalType) : MalFunction(lambda) { - override fun with_meta(meta: MalType): MalType { - val obj = MalFnFunction(ast, params, env, lambda) - obj.metadata = meta - return obj - } -} - -interface ISeq : MalType { - fun seq(): Sequence - fun first(): MalType - fun rest(): ISeq - fun nth(n: Int): MalType - fun count(): Int - fun slice(fromIndex: Int, toIndex: Int): ISeq - fun conj(s: ISeq): ISeq -} - -interface IMutableSeq : ISeq { - fun conj_BANG(form: MalType) -} - -abstract class MalSequence(val elements: MutableList) : MalType, IMutableSeq { - override var metadata: MalType = NIL - - override fun seq(): Sequence = elements.asSequence() - override fun first(): MalType = elements.first() - override fun nth(n: Int): MalType = elements.elementAt(n) - override fun count(): Int = elements.count() - - override fun conj_BANG(form: MalType) { - elements.add(form) - } - - override fun equals(other: Any?): Boolean = - (other is ISeq) - && elements.size == other.count() - && elements.asSequence().zip(other.seq()).all({ it -> it.first == it.second }) -} - -class MalList(elements: MutableList) : MalSequence(elements) { - constructor() : this(LinkedList()) - constructor(s: ISeq) : this(s.seq().toCollection(LinkedList())) - - override fun rest(): ISeq = MalList(elements.drop(1).toCollection(LinkedList())) - - override fun slice(fromIndex: Int, toIndex: Int): MalList = - MalList(elements.subList(fromIndex, toIndex)) - - override fun conj(s: ISeq): ISeq { - val list = LinkedList(elements) - s.seq().forEach({ it -> list.addFirst(it) }) - return MalList(list) - } - - override fun with_meta(meta: MalType): MalType { - val obj = MalList(elements) - obj.metadata = meta - return obj - } -} - -class MalVector(elements: MutableList) : MalSequence(elements) { - override var metadata: MalType = NIL - - constructor() : this(ArrayList()) - constructor(s: ISeq) : this(s.seq().toCollection(ArrayList())) - - override fun rest(): ISeq = MalVector(elements.drop(1).toCollection(ArrayList())) - - override fun slice(fromIndex: Int, toIndex: Int): MalVector = - MalVector(elements.subList(fromIndex, toIndex)) - - override fun conj(s: ISeq): ISeq = MalVector(elements.plus(s.seq()).toCollection(ArrayList())) - - override fun with_meta(meta: MalType): MalType { - val obj = MalVector(elements) - obj.metadata = meta - return obj - } -} - -class MalHashMap() : MalType { - override var metadata: MalType = NIL - - val elements = HashMap() - - constructor(other: MalHashMap) : this() { - other.elements.forEach({ it -> assoc_BANG(it.key, it.value) }) - } - - fun assoc_BANG(key: MalString, value: MalType) = elements.put(key, value) - - fun dissoc_BANG(key: MalString) { - elements.remove(key) - } - - override fun with_meta(meta: MalType): MalType { - val obj = MalHashMap(this) - obj.metadata = meta - return obj - } - - override fun equals(other: Any?): Boolean = - (other is MalHashMap) && elements.equals(other.elements) -} - -class MalAtom(var value: MalType) : MalType { - override var metadata: MalType = NIL - override fun with_meta(meta: MalType): MalType = throw UnsupportedOperationException() -} - -val NIL = MalConstant("nil") -val TRUE = MalConstant("true") -val FALSE = MalConstant("false") -val ZERO = MalInteger(0) +package mal + +import java.util.* + +open class MalException(message: String?) : Exception(message), MalType { + override var metadata: MalType = NIL + override fun with_meta(meta: MalType): MalType { + val exception = MalException(message) + exception.metadata = meta + return exception + } +} + +class MalContinue() : MalException("continue") +class MalReaderException(message: String) : MalException(message) +class MalPrinterException(message: String) : MalException(message) + +class MalCoreException(message: String, val value: MalType) : MalException(message) { + override fun with_meta(meta: MalType): MalType { + val exception = MalCoreException(message as String, value) + exception.metadata = meta + return exception + } +} + +interface MalType { + var metadata: MalType + fun with_meta(meta: MalType): MalType +} + +open class MalConstant(val value: String) : MalType { + override var metadata: MalType = NIL + + override fun equals(other: Any?): Boolean = other is MalConstant && value.equals(other.value) + override fun hashCode(): Int = value.hashCode() + + override fun with_meta(meta: MalType): MalType { + val obj = MalConstant(value) + obj.metadata = meta + return obj + } +} + +class MalInteger(val value: Long) : MalType { + override var metadata: MalType = NIL + + operator fun plus(a: MalInteger): MalInteger = MalInteger(value + a.value) + operator fun minus(a: MalInteger): MalInteger = MalInteger(value - a.value) + operator fun times(a: MalInteger): MalInteger = MalInteger(value * a.value) + operator fun div(a: MalInteger): MalInteger = MalInteger(value / a.value) + operator fun compareTo(a: MalInteger): Int = value.compareTo(a.value) + + override fun equals(other: Any?): Boolean = other is MalInteger && value.equals(other.value) + + override fun with_meta(meta: MalType): MalType { + val obj = MalInteger(value) + obj.metadata = meta + return obj + } +} + +class MalSymbol(val value: String) : MalType { + override var metadata: MalType = NIL + + override fun equals(other: Any?): Boolean = other is MalSymbol && value.equals(other.value) + + override fun with_meta(meta: MalType): MalType { + val obj = MalSymbol(value) + obj.metadata = meta + return obj + } +} + +open class MalString(value: String) : MalConstant(value) { + override fun with_meta(meta: MalType): MalType { + val obj = MalString(value) + obj.metadata = meta + return obj + } +} + +class MalKeyword(value: String) : MalString("\u029E" + value) { + override fun with_meta(meta: MalType): MalType { + val obj = MalKeyword(value) + obj.metadata = meta + return obj + } +} + +interface ILambda : MalType { + fun apply(seq: ISeq): MalType +} + +open class MalFunction(val lambda: (ISeq) -> MalType) : MalType, ILambda { + var is_macro: Boolean = false + override var metadata: MalType = NIL + + override fun apply(seq: ISeq): MalType = lambda(seq) + + override fun with_meta(meta: MalType): MalType { + val obj = MalFunction(lambda) + obj.metadata = meta + return obj + } +} + +class MalFnFunction(val ast: MalType, val params: Sequence, val env: Env, lambda: (ISeq) -> MalType) : MalFunction(lambda) { + override fun with_meta(meta: MalType): MalType { + val obj = MalFnFunction(ast, params, env, lambda) + obj.metadata = meta + return obj + } +} + +interface ISeq : MalType { + fun seq(): Sequence + fun first(): MalType + fun rest(): ISeq + fun nth(n: Int): MalType + fun count(): Int + fun slice(fromIndex: Int, toIndex: Int): ISeq + fun conj(s: ISeq): ISeq +} + +interface IMutableSeq : ISeq { + fun conj_BANG(form: MalType) +} + +abstract class MalSequence(val elements: MutableList) : MalType, IMutableSeq { + override var metadata: MalType = NIL + + override fun seq(): Sequence = elements.asSequence() + override fun first(): MalType = elements.first() + override fun nth(n: Int): MalType = elements.elementAt(n) + override fun count(): Int = elements.count() + + override fun conj_BANG(form: MalType) { + elements.add(form) + } + + override fun equals(other: Any?): Boolean = + (other is ISeq) + && elements.size == other.count() + && elements.asSequence().zip(other.seq()).all({ it -> it.first == it.second }) +} + +class MalList(elements: MutableList) : MalSequence(elements) { + constructor() : this(LinkedList()) + constructor(s: ISeq) : this(s.seq().toCollection(LinkedList())) + + override fun rest(): ISeq = MalList(elements.drop(1).toCollection(LinkedList())) + + override fun slice(fromIndex: Int, toIndex: Int): MalList = + MalList(elements.subList(fromIndex, toIndex)) + + override fun conj(s: ISeq): ISeq { + val list = LinkedList(elements) + s.seq().forEach({ it -> list.addFirst(it) }) + return MalList(list) + } + + override fun with_meta(meta: MalType): MalType { + val obj = MalList(elements) + obj.metadata = meta + return obj + } +} + +class MalVector(elements: MutableList) : MalSequence(elements) { + override var metadata: MalType = NIL + + constructor() : this(ArrayList()) + constructor(s: ISeq) : this(s.seq().toCollection(ArrayList())) + + override fun rest(): ISeq = MalVector(elements.drop(1).toCollection(ArrayList())) + + override fun slice(fromIndex: Int, toIndex: Int): MalVector = + MalVector(elements.subList(fromIndex, toIndex)) + + override fun conj(s: ISeq): ISeq = MalVector(elements.plus(s.seq()).toCollection(ArrayList())) + + override fun with_meta(meta: MalType): MalType { + val obj = MalVector(elements) + obj.metadata = meta + return obj + } +} + +class MalHashMap() : MalType { + override var metadata: MalType = NIL + + val elements = HashMap() + + constructor(other: MalHashMap) : this() { + other.elements.forEach({ it -> assoc_BANG(it.key, it.value) }) + } + + fun assoc_BANG(key: MalString, value: MalType) = elements.put(key, value) + + fun dissoc_BANG(key: MalString) { + elements.remove(key) + } + + override fun with_meta(meta: MalType): MalType { + val obj = MalHashMap(this) + obj.metadata = meta + return obj + } + + override fun equals(other: Any?): Boolean = + (other is MalHashMap) && elements.equals(other.elements) +} + +class MalAtom(var value: MalType) : MalType { + override var metadata: MalType = NIL + override fun with_meta(meta: MalType): MalType = throw UnsupportedOperationException() +} + +val NIL = MalConstant("nil") +val TRUE = MalConstant("true") +val FALSE = MalConstant("false") +val ZERO = MalInteger(0) diff --git a/impls/kotlin/tests/step5_tco.mal b/impls/kotlin/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/kotlin/tests/step5_tco.mal +++ b/impls/kotlin/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/lib/README.md b/impls/lib/README.md index e04c6526cf..cc06647be1 100644 --- a/impls/lib/README.md +++ b/impls/lib/README.md @@ -1,32 +1,32 @@ -This directory contains general-purpose reusable code that does not -fit in the process. - -The split in small files is motivated by implementations too limited -to load a single big file, but MAL has no proper module management. - -However, here are some guidelines. - -- Begin with an one-line ;; short description - -- Describe the restrictions on each parameter in comments. - -- Define private symbols in hidden environments when possible. If this - is not possible, for example for macros, give them a name starting - with an underscore. - -If a module provides tests, you may run against an implementation IMPL -with these commands. -``` -make IMPL^stepA -cd tests -python ../runtest.py lib/MODULE.mal ../IMPL/run -``` - -Users and implementors should use the following syntax in order to -ensure that the same file is only loaded once. - -``` -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/foo.mal") -(load-file-once "../lib/bar.mal") -``` +This directory contains general-purpose reusable code that does not +fit in the process. + +The split in small files is motivated by implementations too limited +to load a single big file, but MAL has no proper module management. + +However, here are some guidelines. + +- Begin with an one-line ;; short description + +- Describe the restrictions on each parameter in comments. + +- Define private symbols in hidden environments when possible. If this + is not possible, for example for macros, give them a name starting + with an underscore. + +If a module provides tests, you may run against an implementation IMPL +with these commands. +``` +make IMPL^stepA +cd tests +python ../runtest.py lib/MODULE.mal ../IMPL/run +``` + +Users and implementors should use the following syntax in order to +ensure that the same file is only loaded once. + +``` +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/foo.mal") +(load-file-once "../lib/bar.mal") +``` diff --git a/impls/lib/alias-hacks.mal b/impls/lib/alias-hacks.mal index 5d2ac87336..39bb1ac726 100644 --- a/impls/lib/alias-hacks.mal +++ b/impls/lib/alias-hacks.mal @@ -1,22 +1,22 @@ -;; aliases for common clojure names to mal builtins -;; NOTE: this is a hack - -;; Origin: https://github.com/chr15m/frock - -; TODO: re-implement as actually useful macros: -; destructuring, arg checking, etc. - -(def! _alias_add_implicit - (fn* [special added] - (fn* [x & xs] - (list special x (cons added xs))))) - -(defmacro! let (_alias_add_implicit 'let* 'do)) -(defmacro! when (_alias_add_implicit 'if 'do)) -(defmacro! def (_alias_add_implicit 'def! 'do)) -(defmacro! fn (_alias_add_implicit 'fn* 'do)) -(defmacro! defn (_alias_add_implicit 'def! 'fn)) - -(def! partial (fn* [pfn & args] - (fn* [& args-inner] - (apply pfn (concat args args-inner))))) +;; aliases for common clojure names to mal builtins +;; NOTE: this is a hack + +;; Origin: https://github.com/chr15m/frock + +; TODO: re-implement as actually useful macros: +; destructuring, arg checking, etc. + +(def! _alias_add_implicit + (fn* [special added] + (fn* [x & xs] + (list special x (cons added xs))))) + +(defmacro! let (_alias_add_implicit 'let* 'do)) +(defmacro! when (_alias_add_implicit 'if 'do)) +(defmacro! def (_alias_add_implicit 'def! 'do)) +(defmacro! fn (_alias_add_implicit 'fn* 'do)) +(defmacro! defn (_alias_add_implicit 'def! 'fn)) + +(def! partial (fn* [pfn & args] + (fn* [& args-inner] + (apply pfn (concat args args-inner))))) diff --git a/impls/lib/benchmark.mal b/impls/lib/benchmark.mal index 8ea2d2ae6e..8ee3abba1d 100644 --- a/impls/lib/benchmark.mal +++ b/impls/lib/benchmark.mal @@ -1,15 +1,15 @@ -;; An alternative approach, to complement perf.mal -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/trivial.mal") ; gensym inc - -(def! benchmark* (fn* [f n results] - (if (< 0 n) - (let* [start-ms (time-ms) - _ (f) - end-ms (time-ms)] - (benchmark* f (- n 1) (conj results (- end-ms start-ms)))) - results))) - -(defmacro! benchmark (fn* [expr n] - `(benchmark* (fn* [] ~expr) ~n []))) - +;; An alternative approach, to complement perf.mal +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/trivial.mal") ; gensym inc + +(def! benchmark* (fn* [f n results] + (if (< 0 n) + (let* [start-ms (time-ms) + _ (f) + end-ms (time-ms)] + (benchmark* f (- n 1) (conj results (- end-ms start-ms)))) + results))) + +(defmacro! benchmark (fn* [expr n] + `(benchmark* (fn* [] ~expr) ~n []))) + diff --git a/impls/lib/equality.mal b/impls/lib/equality.mal index 90ca5287aa..7d8764f405 100644 --- a/impls/lib/equality.mal +++ b/impls/lib/equality.mal @@ -1,77 +1,77 @@ -;; equality.mal - -;; This file checks whether the `=` function correctly implements equality of -;; hash-maps and sequences (lists and vectors). If not, it redefines the `=` -;; function with a pure mal (recursive) implementation that only relies on the -;; native original `=` function for comparing scalars (integers, booleans, -;; symbols, strings, keywords, atoms, nil). - -;; Save the original (native) `=` as scalar-equal? -(def! scalar-equal? =) - -;; A faster `and` macro which doesn't use `=` internally. -(defmacro! bool-and ; boolean - (fn* [& xs] ; interpreted as logical values - (if (empty? xs) - true - `(if ~(first xs) (bool-and ~@(rest xs)) false)))) -(defmacro! bool-or ; boolean - (fn* [& xs] ; interpreted as logical values - (if (empty? xs) - false - `(if ~(first xs) true (bool-or ~@(rest xs)))))) - -(def! starts-with? - (fn* [a b] - (bool-or (empty? a) - (bool-and (mal-equal? (first a) (first b)) - (starts-with? (rest a) (rest b)))))) - -(def! hash-map-vals-equal? - (fn* [a b map-keys] - (bool-or (empty? map-keys) - (let* [key (first map-keys)] - (bool-and (contains? b key) - (mal-equal? (get a key) (get b key)) - (hash-map-vals-equal? a b (rest map-keys))))))) - -;; This implements = in pure mal (using only scalar-equal? as native impl) -(def! mal-equal? - (fn* [a b] - (cond - - (sequential? a) - (bool-and (sequential? b) - (scalar-equal? (count a) (count b)) - (starts-with? a b)) - - (map? a) - (let* [keys-a (keys a)] - (bool-and (map? b) - (scalar-equal? (count keys-a) (count (keys b))) - (hash-map-vals-equal? a b keys-a))) - - true - (scalar-equal? a b)))) - -(def! hash-map-equality-correct? - (fn* [] - (try* - (bool-and (= {:a 1} {:a 1}) - (not (= {:a 1} {:a 1 :b 2}))) - (catch* _ false)))) - -(def! sequence-equality-correct? - (fn* [] - (try* - (bool-and (= [:a :b] (list :a :b)) - (not (= [:a :b] [:a :b :c]))) - (catch* _ false)))) - -;; If the native `=` implementation doesn't support sequences or hash-maps -;; correctly, replace it with the pure mal implementation -(if (not (bool-and (hash-map-equality-correct?) - (sequence-equality-correct?))) - (do - (def! = mal-equal?) - (println "equality.mal: Replaced = with pure mal implementation"))) +;; equality.mal + +;; This file checks whether the `=` function correctly implements equality of +;; hash-maps and sequences (lists and vectors). If not, it redefines the `=` +;; function with a pure mal (recursive) implementation that only relies on the +;; native original `=` function for comparing scalars (integers, booleans, +;; symbols, strings, keywords, atoms, nil). + +;; Save the original (native) `=` as scalar-equal? +(def! scalar-equal? =) + +;; A faster `and` macro which doesn't use `=` internally. +(defmacro! bool-and ; boolean + (fn* [& xs] ; interpreted as logical values + (if (empty? xs) + true + `(if ~(first xs) (bool-and ~@(rest xs)) false)))) +(defmacro! bool-or ; boolean + (fn* [& xs] ; interpreted as logical values + (if (empty? xs) + false + `(if ~(first xs) true (bool-or ~@(rest xs)))))) + +(def! starts-with? + (fn* [a b] + (bool-or (empty? a) + (bool-and (mal-equal? (first a) (first b)) + (starts-with? (rest a) (rest b)))))) + +(def! hash-map-vals-equal? + (fn* [a b map-keys] + (bool-or (empty? map-keys) + (let* [key (first map-keys)] + (bool-and (contains? b key) + (mal-equal? (get a key) (get b key)) + (hash-map-vals-equal? a b (rest map-keys))))))) + +;; This implements = in pure mal (using only scalar-equal? as native impl) +(def! mal-equal? + (fn* [a b] + (cond + + (sequential? a) + (bool-and (sequential? b) + (scalar-equal? (count a) (count b)) + (starts-with? a b)) + + (map? a) + (let* [keys-a (keys a)] + (bool-and (map? b) + (scalar-equal? (count keys-a) (count (keys b))) + (hash-map-vals-equal? a b keys-a))) + + true + (scalar-equal? a b)))) + +(def! hash-map-equality-correct? + (fn* [] + (try* + (bool-and (= {:a 1} {:a 1}) + (not (= {:a 1} {:a 1 :b 2}))) + (catch* _ false)))) + +(def! sequence-equality-correct? + (fn* [] + (try* + (bool-and (= [:a :b] (list :a :b)) + (not (= [:a :b] [:a :b :c]))) + (catch* _ false)))) + +;; If the native `=` implementation doesn't support sequences or hash-maps +;; correctly, replace it with the pure mal implementation +(if (not (bool-and (hash-map-equality-correct?) + (sequence-equality-correct?))) + (do + (def! = mal-equal?) + (println "equality.mal: Replaced = with pure mal implementation"))) diff --git a/impls/lib/load-file-once.mal b/impls/lib/load-file-once.mal index 2d7ac0c115..12a2c674f5 100644 --- a/impls/lib/load-file-once.mal +++ b/impls/lib/load-file-once.mal @@ -1,16 +1,16 @@ -;; Like load-file, but will never load the same path twice. - -;; This file is normally loaded with `load-file`, so it needs a -;; different mechanism to neutralize multiple inclusions of -;; itself. Moreover, the file list should never be reset. - -(def! load-file-once - (try* - load-file-once - (catch* _ - (let* [seen (atom {"../lib/load-file-once.mal" nil})] - (fn* [filename] - (if (not (contains? @seen filename)) - (do - (swap! seen assoc filename nil) - (load-file filename)))))))) +;; Like load-file, but will never load the same path twice. + +;; This file is normally loaded with `load-file`, so it needs a +;; different mechanism to neutralize multiple inclusions of +;; itself. Moreover, the file list should never be reset. + +(def! load-file-once + (try* + load-file-once + (catch* _ + (let* [seen (atom {"../lib/load-file-once.mal" nil})] + (fn* [filename] + (if (not (contains? @seen filename)) + (do + (swap! seen assoc filename nil) + (load-file filename)))))))) diff --git a/impls/lib/memoize.mal b/impls/lib/memoize.mal index ca3a47957f..a1f93f10b7 100644 --- a/impls/lib/memoize.mal +++ b/impls/lib/memoize.mal @@ -1,25 +1,25 @@ -;; Memoize any function. - -;; Implement `memoize` using an atom (`mem`) which holds the memoized results -;; (hash-map from the arguments to the result). When the function is called, -;; the hash-map is checked to see if the result for the given argument was already -;; calculated and stored. If this is the case, it is returned immediately; -;; otherwise, it is calculated and stored in `mem`. - -;; For recursive functions, take care to store the wrapper under the -;; same name than the original computation with an assignment like -;; `(def! f (memoize f))`, so that intermediate results are memorized. - -;; Adapted from http://clojure.org/atoms - -(def! memoize - (fn* [f] - (let* [mem (atom {})] - (fn* [& args] - (let* [key (str args)] - (if (contains? @mem key) - (get @mem key) - (let* [ret (apply f args)] - (do - (swap! mem assoc key ret) - ret)))))))) +;; Memoize any function. + +;; Implement `memoize` using an atom (`mem`) which holds the memoized results +;; (hash-map from the arguments to the result). When the function is called, +;; the hash-map is checked to see if the result for the given argument was already +;; calculated and stored. If this is the case, it is returned immediately; +;; otherwise, it is calculated and stored in `mem`. + +;; For recursive functions, take care to store the wrapper under the +;; same name than the original computation with an assignment like +;; `(def! f (memoize f))`, so that intermediate results are memorized. + +;; Adapted from http://clojure.org/atoms + +(def! memoize + (fn* [f] + (let* [mem (atom {})] + (fn* [& args] + (let* [key (str args)] + (if (contains? @mem key) + (get @mem key) + (let* [ret (apply f args)] + (do + (swap! mem assoc key ret) + ret)))))))) diff --git a/impls/lib/perf.mal b/impls/lib/perf.mal index 32a3189f72..ad62f6f947 100644 --- a/impls/lib/perf.mal +++ b/impls/lib/perf.mal @@ -1,41 +1,41 @@ -;; Mesure performances. - -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/trivial.mal") ; gensym inc - -;; Evaluate an expression, but report the time spent -(defmacro! time - (fn* (exp) - (let* [start (gensym) - ret (gensym)] - `(let* (~start (time-ms) - ~ret ~exp) - (do - (println "Elapsed time:" (- (time-ms) ~start) "msecs") - ~ret))))) - -;; Count evaluations of a function during a given time frame. -(def! run-fn-for - - (let* [ - run-fn-for* (fn* [fn max-ms acc-ms last-iters] - (let* [start (time-ms) - _ (fn) - elapsed (- (time-ms) start) - iters (inc last-iters) - new-acc-ms (+ acc-ms elapsed)] - ;; (do (prn "new-acc-ms:" new-acc-ms "iters:" iters)) - (if (>= new-acc-ms max-ms) - last-iters - (run-fn-for* fn max-ms new-acc-ms iters)))) - ] - - (fn* [fn max-secs] - ;; fn : function without parameters - ;; max-secs : number (seconds) - ;; return : number (iterations) - (do - ;; Warm it up first - (run-fn-for* fn 1000 0 0) - ;; Now do the test - (run-fn-for* fn (* 1000 max-secs) 0 0))))) +;; Mesure performances. + +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/trivial.mal") ; gensym inc + +;; Evaluate an expression, but report the time spent +(defmacro! time + (fn* (exp) + (let* [start (gensym) + ret (gensym)] + `(let* (~start (time-ms) + ~ret ~exp) + (do + (println "Elapsed time:" (- (time-ms) ~start) "msecs") + ~ret))))) + +;; Count evaluations of a function during a given time frame. +(def! run-fn-for + + (let* [ + run-fn-for* (fn* [fn max-ms acc-ms last-iters] + (let* [start (time-ms) + _ (fn) + elapsed (- (time-ms) start) + iters (inc last-iters) + new-acc-ms (+ acc-ms elapsed)] + ;; (do (prn "new-acc-ms:" new-acc-ms "iters:" iters)) + (if (>= new-acc-ms max-ms) + last-iters + (run-fn-for* fn max-ms new-acc-ms iters)))) + ] + + (fn* [fn max-secs] + ;; fn : function without parameters + ;; max-secs : number (seconds) + ;; return : number (iterations) + (do + ;; Warm it up first + (run-fn-for* fn 1000 0 0) + ;; Now do the test + (run-fn-for* fn (* 1000 max-secs) 0 0))))) diff --git a/impls/lib/pprint.mal b/impls/lib/pprint.mal index c5be941c06..c458de23c8 100644 --- a/impls/lib/pprint.mal +++ b/impls/lib/pprint.mal @@ -1,43 +1,43 @@ -;; Pretty printer a MAL object. - -(def! pprint - - (let* [ - - spaces- (fn* [indent] - (if (> indent 0) - (str " " (spaces- (- indent 1))) - "")) - - pp-seq- (fn* [obj indent] - (let* [xindent (+ 1 indent)] - (apply str (pp- (first obj) 0) - (map (fn* [x] (str "\n" (spaces- xindent) - (pp- x xindent))) - (rest obj))))) - - pp-map- (fn* [obj indent] - (let* [ks (keys obj) - kindent (+ 1 indent) - kwidth (count (seq (str (first ks)))) - vindent (+ 1 (+ kwidth kindent))] - (apply str (pp- (first ks) 0) - " " - (pp- (get obj (first ks)) 0) - (map (fn* [k] (str "\n" (spaces- kindent) - (pp- k kindent) - " " - (pp- (get obj k) vindent))) - (rest (keys obj)))))) - - pp- (fn* [obj indent] - (cond - (list? obj) (str "(" (pp-seq- obj indent) ")") - (vector? obj) (str "[" (pp-seq- obj indent) "]") - (map? obj) (str "{" (pp-map- obj indent) "}") - :else (pr-str obj))) - - ] - - (fn* [obj] - (println (pp- obj 0))))) +;; Pretty printer a MAL object. + +(def! pprint + + (let* [ + + spaces- (fn* [indent] + (if (> indent 0) + (str " " (spaces- (- indent 1))) + "")) + + pp-seq- (fn* [obj indent] + (let* [xindent (+ 1 indent)] + (apply str (pp- (first obj) 0) + (map (fn* [x] (str "\n" (spaces- xindent) + (pp- x xindent))) + (rest obj))))) + + pp-map- (fn* [obj indent] + (let* [ks (keys obj) + kindent (+ 1 indent) + kwidth (count (seq (str (first ks)))) + vindent (+ 1 (+ kwidth kindent))] + (apply str (pp- (first ks) 0) + " " + (pp- (get obj (first ks)) 0) + (map (fn* [k] (str "\n" (spaces- kindent) + (pp- k kindent) + " " + (pp- (get obj k) vindent))) + (rest (keys obj)))))) + + pp- (fn* [obj indent] + (cond + (list? obj) (str "(" (pp-seq- obj indent) ")") + (vector? obj) (str "[" (pp-seq- obj indent) "]") + (map? obj) (str "{" (pp-map- obj indent) "}") + :else (pr-str obj))) + + ] + + (fn* [obj] + (println (pp- obj 0))))) diff --git a/impls/lib/protocols.mal b/impls/lib/protocols.mal index 4bd8b80bdc..868b16c3b9 100644 --- a/impls/lib/protocols.mal +++ b/impls/lib/protocols.mal @@ -1,95 +1,95 @@ -;; A sketch of Clojure-like protocols, implemented in Mal - -;; By chouser (Chris Houser) -;; Original: https://gist.github.com/Chouser/6081ea66d144d13e56fc - -;; This function maps a MAL value to a keyword representing its type. -;; Most applications will override the default with an explicit value -;; for the `:type` key in the metadata. -(def! find-type (fn* [obj] - (cond - (symbol? obj) :mal/symbol - (keyword? obj) :mal/keyword - (atom? obj) :mal/atom - (nil? obj) :mal/nil - (true? obj) :mal/boolean - (false? obj) :mal/boolean - (number? obj) :mal/number - (string? obj) :mal/string - (macro? obj) :mal/macro - true - (let* [metadata (meta obj) - type (if (map? metadata) (get metadata :type))] - (cond - (keyword? type) type - (list? obj) :mal/list - (vector? obj) :mal/vector - (map? obj) :mal/map - (fn? obj) :mal/function - true (throw "unknown MAL value in protocols")))))) - -;; A protocol (abstract class, interface..) is represented by a symbol. -;; It describes methods (abstract functions, contracts, signals..). -;; Each method is described by a sequence of two elements. -;; First, a symbol setting the name of the method. -;; Second, a vector setting its formal parameters. -;; The first parameter is required, plays a special role. -;; It is usually named `this` (`self`..). -;; For example, -;; (defprotocol protocol -;; (method1 [this]) -;; (method2 [this argument])) -;; can be thought as: -;; (def! method1 (fn* [this]) ..) -;; (def! method2 (fn* [this argument]) ..) -;; (def! protocol ..) -;; The return value is the new protocol. -(defmacro! defprotocol (fn* [proto-name & methods] - ;; A protocol is an atom mapping a type extending the protocol to - ;; another map from method names as keywords to implementations. - (let* [ - drop2 (fn* [args] - (if (= 2 (count args)) - () - (cons (first args) (drop2 (rest args))))) - rewrite (fn* [method] - (let* [ - name (first method) - args (nth method 1) - argc (count args) - varargs? (if (<= 2 argc) (= '& (nth args (- argc 2)))) - dispatch `(get (get @~proto-name - (find-type ~(first args))) - ~(keyword (str name))) - body (if varargs? - `(apply ~dispatch ~@(drop2 args) ~(nth args (- argc 1))) - (cons dispatch args)) - ] - (list 'def! name (list 'fn* args body)))) - ] - `(do - ~@(map rewrite methods) - (def! ~proto-name (atom {})))))) - -;; A type (concrete class..) extends (is a subclass of, implements..) -;; a protocol when it provides implementations for the required methods. -;; (extend type protocol { -;; :method1 (fn* [this] ..) -;; :method2 (fn* [this arg1 arg2])}) -;; Additionnal protocol/methods pairs are equivalent to successive -;; calls with the same type. -;; The return value is `nil`. -(def! extend (fn* [type proto methods & more] - (do - (swap! proto assoc type methods) - (if (first more) - (apply extend type more))))) - -;; An object satisfies a protocol when its type extends the protocol, -;; that is if the required methods can be applied to the object. -(def! satisfies? (fn* [protocol obj] - (contains? @protocol (find-type obj)))) -;; If `(satisfies protocol obj)` with the protocol below -;; then `(method1 obj)` and `(method2 obj 1 2)` -;; dispatch to the concrete implementation provided by the exact type. -;; Should the type evolve, the calling code needs not change. +;; A sketch of Clojure-like protocols, implemented in Mal + +;; By chouser (Chris Houser) +;; Original: https://gist.github.com/Chouser/6081ea66d144d13e56fc + +;; This function maps a MAL value to a keyword representing its type. +;; Most applications will override the default with an explicit value +;; for the `:type` key in the metadata. +(def! find-type (fn* [obj] + (cond + (symbol? obj) :mal/symbol + (keyword? obj) :mal/keyword + (atom? obj) :mal/atom + (nil? obj) :mal/nil + (true? obj) :mal/boolean + (false? obj) :mal/boolean + (number? obj) :mal/number + (string? obj) :mal/string + (macro? obj) :mal/macro + true + (let* [metadata (meta obj) + type (if (map? metadata) (get metadata :type))] + (cond + (keyword? type) type + (list? obj) :mal/list + (vector? obj) :mal/vector + (map? obj) :mal/map + (fn? obj) :mal/function + true (throw "unknown MAL value in protocols")))))) + +;; A protocol (abstract class, interface..) is represented by a symbol. +;; It describes methods (abstract functions, contracts, signals..). +;; Each method is described by a sequence of two elements. +;; First, a symbol setting the name of the method. +;; Second, a vector setting its formal parameters. +;; The first parameter is required, plays a special role. +;; It is usually named `this` (`self`..). +;; For example, +;; (defprotocol protocol +;; (method1 [this]) +;; (method2 [this argument])) +;; can be thought as: +;; (def! method1 (fn* [this]) ..) +;; (def! method2 (fn* [this argument]) ..) +;; (def! protocol ..) +;; The return value is the new protocol. +(defmacro! defprotocol (fn* [proto-name & methods] + ;; A protocol is an atom mapping a type extending the protocol to + ;; another map from method names as keywords to implementations. + (let* [ + drop2 (fn* [args] + (if (= 2 (count args)) + () + (cons (first args) (drop2 (rest args))))) + rewrite (fn* [method] + (let* [ + name (first method) + args (nth method 1) + argc (count args) + varargs? (if (<= 2 argc) (= '& (nth args (- argc 2)))) + dispatch `(get (get @~proto-name + (find-type ~(first args))) + ~(keyword (str name))) + body (if varargs? + `(apply ~dispatch ~@(drop2 args) ~(nth args (- argc 1))) + (cons dispatch args)) + ] + (list 'def! name (list 'fn* args body)))) + ] + `(do + ~@(map rewrite methods) + (def! ~proto-name (atom {})))))) + +;; A type (concrete class..) extends (is a subclass of, implements..) +;; a protocol when it provides implementations for the required methods. +;; (extend type protocol { +;; :method1 (fn* [this] ..) +;; :method2 (fn* [this arg1 arg2])}) +;; Additionnal protocol/methods pairs are equivalent to successive +;; calls with the same type. +;; The return value is `nil`. +(def! extend (fn* [type proto methods & more] + (do + (swap! proto assoc type methods) + (if (first more) + (apply extend type more))))) + +;; An object satisfies a protocol when its type extends the protocol, +;; that is if the required methods can be applied to the object. +(def! satisfies? (fn* [protocol obj] + (contains? @protocol (find-type obj)))) +;; If `(satisfies protocol obj)` with the protocol below +;; then `(method1 obj)` and `(method2 obj 1 2)` +;; dispatch to the concrete implementation provided by the exact type. +;; Should the type evolve, the calling code needs not change. diff --git a/impls/lib/reducers.mal b/impls/lib/reducers.mal index f8e6dc7fe3..3c2c1a2eb0 100644 --- a/impls/lib/reducers.mal +++ b/impls/lib/reducers.mal @@ -1,32 +1,32 @@ -;; Left and right folds. - -;; Left fold (f (.. (f (f init x1) x2) ..) xn) -(def! reduce - (fn* (f init xs) - ;; f : Accumulator Element -> Accumulator - ;; init : Accumulator - ;; xs : sequence of Elements x1 x2 .. xn - ;; return : Accumulator - (if (empty? xs) - init - (reduce f (f init (first xs)) (rest xs))))) - -;; Right fold (f x1 (f x2 (.. (f xn init)) ..)) -;; The natural implementation for `foldr` is not tail-recursive, and -;; the one based on `reduce` constructs many intermediate functions, so we -;; rely on efficient `nth` and `count`. -(def! foldr - - (let* [ - rec (fn* [f xs acc index] - (if (< index 0) - acc - (rec f xs (f (nth xs index) acc) (- index 1)))) - ] - - (fn* [f init xs] - ;; f : Element Accumulator -> Accumulator - ;; init : Accumulator - ;; xs : sequence of Elements x1 x2 .. xn - ;; return : Accumulator - (rec f xs init (- (count xs) 1))))) +;; Left and right folds. + +;; Left fold (f (.. (f (f init x1) x2) ..) xn) +(def! reduce + (fn* (f init xs) + ;; f : Accumulator Element -> Accumulator + ;; init : Accumulator + ;; xs : sequence of Elements x1 x2 .. xn + ;; return : Accumulator + (if (empty? xs) + init + (reduce f (f init (first xs)) (rest xs))))) + +;; Right fold (f x1 (f x2 (.. (f xn init)) ..)) +;; The natural implementation for `foldr` is not tail-recursive, and +;; the one based on `reduce` constructs many intermediate functions, so we +;; rely on efficient `nth` and `count`. +(def! foldr + + (let* [ + rec (fn* [f xs acc index] + (if (< index 0) + acc + (rec f xs (f (nth xs index) acc) (- index 1)))) + ] + + (fn* [f init xs] + ;; f : Element Accumulator -> Accumulator + ;; init : Accumulator + ;; xs : sequence of Elements x1 x2 .. xn + ;; return : Accumulator + (rec f xs init (- (count xs) 1))))) diff --git a/impls/lib/test_cascade.mal b/impls/lib/test_cascade.mal index d2d81e7747..d2cdfc4a85 100644 --- a/impls/lib/test_cascade.mal +++ b/impls/lib/test_cascade.mal @@ -1,67 +1,67 @@ -;; Iteration on evaluations interpreted as boolean values. - -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/trivial.mal") ; gensym - -;; `(cond test1 result1 test2 result2 .. testn resultn)` -;; is rewritten (in the step files) as -;; `(if test1 result1 (if test2 result2 (.. (if testn resultn nil))))` -;; It is common that `testn` is `"else"`, `:else`, `true` or similar. - -;; `(or x1 x2 .. xn x)` -;; is almost rewritten as -;; `(if x1 x1 (if x2 x2 (.. (if xn xn x))))` -;; except that each argument is evaluated at most once. -;; Without arguments, returns `nil`. -(defmacro! or (fn* [& xs] - (if (< (count xs) 2) - (first xs) - (let* [r (gensym)] - `(let* (~r ~(first xs)) (if ~r ~r (or ~@(rest xs)))))))) - -;; Conjonction of predicate values (pred x1) and .. and (pred xn) -;; Evaluate `pred x` for each `x` in turn. Return `false` if a result -;; is `nil` or `false`, without evaluating the predicate for the -;; remaining elements. If all test pass, return `true`. -(def! every? - (fn* (pred xs) - ;; pred : Element -> interpreted as a logical value - ;; xs : sequence of Elements x1 x2 .. xn - ;; return : boolean - (cond (empty? xs) true - (pred (first xs)) (every? pred (rest xs)) - true false))) - -;; Disjonction of predicate values (pred x1) or .. (pred xn) -;; Evaluate `(pred x)` for each `x` in turn. Return the first result -;; that is neither `nil` nor `false`, without evaluating the predicate -;; for the remaining elements. If all tests fail, return nil. -(def! some - (fn* (pred xs) - ;; pred : Element -> interpreted as a logical value - ;; xs : sequence of Elements x1 x2 .. xn - ;; return : boolean - (if (empty? xs) - nil - (or (pred (first xs)) - (some pred (rest xs)))))) - -;; Search for first evaluation returning `nil` or `false`. -;; Rewrite `x1 x2 .. xn x` as -;; (let* [r1 x1] -;; (if r1 test1 -;; (let* [r2 x2] -;; .. -;; (if rn -;; x -;; rn) ..) -;; r1)) -;; Without arguments, returns `true`. -(defmacro! and - (fn* (& xs) - ;; Arguments and the result are interpreted as boolean values. - (cond (empty? xs) true - (= 1 (count xs)) (first xs) - true (let* (condvar (gensym)) - `(let* (~condvar ~(first xs)) - (if ~condvar (and ~@(rest xs)) ~condvar)))))) +;; Iteration on evaluations interpreted as boolean values. + +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/trivial.mal") ; gensym + +;; `(cond test1 result1 test2 result2 .. testn resultn)` +;; is rewritten (in the step files) as +;; `(if test1 result1 (if test2 result2 (.. (if testn resultn nil))))` +;; It is common that `testn` is `"else"`, `:else`, `true` or similar. + +;; `(or x1 x2 .. xn x)` +;; is almost rewritten as +;; `(if x1 x1 (if x2 x2 (.. (if xn xn x))))` +;; except that each argument is evaluated at most once. +;; Without arguments, returns `nil`. +(defmacro! or (fn* [& xs] + (if (< (count xs) 2) + (first xs) + (let* [r (gensym)] + `(let* (~r ~(first xs)) (if ~r ~r (or ~@(rest xs)))))))) + +;; Conjonction of predicate values (pred x1) and .. and (pred xn) +;; Evaluate `pred x` for each `x` in turn. Return `false` if a result +;; is `nil` or `false`, without evaluating the predicate for the +;; remaining elements. If all test pass, return `true`. +(def! every? + (fn* (pred xs) + ;; pred : Element -> interpreted as a logical value + ;; xs : sequence of Elements x1 x2 .. xn + ;; return : boolean + (cond (empty? xs) true + (pred (first xs)) (every? pred (rest xs)) + true false))) + +;; Disjonction of predicate values (pred x1) or .. (pred xn) +;; Evaluate `(pred x)` for each `x` in turn. Return the first result +;; that is neither `nil` nor `false`, without evaluating the predicate +;; for the remaining elements. If all tests fail, return nil. +(def! some + (fn* (pred xs) + ;; pred : Element -> interpreted as a logical value + ;; xs : sequence of Elements x1 x2 .. xn + ;; return : boolean + (if (empty? xs) + nil + (or (pred (first xs)) + (some pred (rest xs)))))) + +;; Search for first evaluation returning `nil` or `false`. +;; Rewrite `x1 x2 .. xn x` as +;; (let* [r1 x1] +;; (if r1 test1 +;; (let* [r2 x2] +;; .. +;; (if rn +;; x +;; rn) ..) +;; r1)) +;; Without arguments, returns `true`. +(defmacro! and + (fn* (& xs) + ;; Arguments and the result are interpreted as boolean values. + (cond (empty? xs) true + (= 1 (count xs)) (first xs) + true (let* (condvar (gensym)) + `(let* (~condvar ~(first xs)) + (if ~condvar (and ~@(rest xs)) ~condvar)))))) diff --git a/impls/lib/threading.mal b/impls/lib/threading.mal index 36bf468f9a..1be87e74cf 100644 --- a/impls/lib/threading.mal +++ b/impls/lib/threading.mal @@ -1,34 +1,34 @@ -;; Composition of partially applied functions. - -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/reducers.mal") ; reduce - -;; Rewrite x (a a1 a2) .. (b b1 b2) as -;; (b (.. (a x a1 a2) ..) b1 b2) -;; If anything else than a list is found were `(a a1 a2)` is expected, -;; replace it with a list with one element, so that `-> x a` is -;; equivalent to `-> x (list a)`. -(defmacro! -> - (fn* (x & xs) - (reduce _iter-> x xs))) - -(def! _iter-> - (fn* [acc form] - (if (list? form) - `(~(first form) ~acc ~@(rest form)) - (list form acc)))) - -;; Like `->`, but the arguments describe functions that are partially -;; applied with *left* arguments. The previous result is inserted at -;; the *end* of the new argument list. -;; Rewrite x ((a a1 a2) .. (b b1 b2)) as -;; (b b1 b2 (.. (a a1 a2 x) ..)). -(defmacro! ->> - (fn* (x & xs) - (reduce _iter->> x xs))) - -(def! _iter->> - (fn* [acc form] - (if (list? form) - `(~(first form) ~@(rest form) ~acc) - (list form acc)))) +;; Composition of partially applied functions. + +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/reducers.mal") ; reduce + +;; Rewrite x (a a1 a2) .. (b b1 b2) as +;; (b (.. (a x a1 a2) ..) b1 b2) +;; If anything else than a list is found were `(a a1 a2)` is expected, +;; replace it with a list with one element, so that `-> x a` is +;; equivalent to `-> x (list a)`. +(defmacro! -> + (fn* (x & xs) + (reduce _iter-> x xs))) + +(def! _iter-> + (fn* [acc form] + (if (list? form) + `(~(first form) ~acc ~@(rest form)) + (list form acc)))) + +;; Like `->`, but the arguments describe functions that are partially +;; applied with *left* arguments. The previous result is inserted at +;; the *end* of the new argument list. +;; Rewrite x ((a a1 a2) .. (b b1 b2)) as +;; (b b1 b2 (.. (a a1 a2 x) ..)). +(defmacro! ->> + (fn* (x & xs) + (reduce _iter->> x xs))) + +(def! _iter->> + (fn* [acc form] + (if (list? form) + `(~(first form) ~@(rest form) ~acc) + (list form acc)))) diff --git a/impls/lib/trivial.mal b/impls/lib/trivial.mal index aa2169104b..a076b0beaa 100644 --- a/impls/lib/trivial.mal +++ b/impls/lib/trivial.mal @@ -1,20 +1,20 @@ -;; Trivial but convenient functions. - -;; Integer predecessor (number -> number) -(def! inc (fn* [a] (+ a 1))) - -;; Integer predecessor (number -> number) -(def! dec (fn* (a) (- a 1))) - -;; Integer nullity test (number -> boolean) -(def! zero? (fn* (n) (= 0 n))) - -;; Returns the unchanged argument. -(def! identity (fn* (x) x)) - -;; Generate a hopefully unique symbol. See section "Plugging the Leaks" -;; of http://www.gigamonkeys.com/book/macros-defining-your-own.html -(def! gensym - (let* [counter (atom 0)] - (fn* [] - (symbol (str "G__" (swap! counter inc)))))) +;; Trivial but convenient functions. + +;; Integer predecessor (number -> number) +(def! inc (fn* [a] (+ a 1))) + +;; Integer predecessor (number -> number) +(def! dec (fn* (a) (- a 1))) + +;; Integer nullity test (number -> boolean) +(def! zero? (fn* (n) (= 0 n))) + +;; Returns the unchanged argument. +(def! identity (fn* (x) x)) + +;; Generate a hopefully unique symbol. See section "Plugging the Leaks" +;; of http://www.gigamonkeys.com/book/macros-defining-your-own.html +(def! gensym + (let* [counter (atom 0)] + (fn* [] + (symbol (str "G__" (swap! counter inc)))))) diff --git a/impls/livescript/Dockerfile b/impls/livescript/Dockerfile index f7677e91c8..725fd2586b 100644 --- a/impls/livescript/Dockerfile +++ b/impls/livescript/Dockerfile @@ -1,34 +1,34 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/impls/livescript/Makefile b/impls/livescript/Makefile index 07c91d250a..f365455297 100644 --- a/impls/livescript/Makefile +++ b/impls/livescript/Makefile @@ -1,31 +1,31 @@ -SOURCES_BASE = reader.ls printer.ls env.ls core.ls utils.ls -SOURCES_STEPS = step0_repl.ls step1_read_print.ls step2_eval.ls \ - step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ - step8_macros.ls step9_try.ls stepA_mal.ls -SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) - -BINS = $(SOURCES:%.ls=%.js) - -LSC = node_modules/.bin/lsc - -all: node_modules $(BINS) - -node_modules: - npm install - -%.js: %.ls node_modules - $(LSC) -d -c $(@:%.js=%.ls) - -step1_read_print.js: utils.js reader.js printer.js -step2_eval.js: utils.js reader.js printer.js -step3_env.js: utils.js reader.js printer.js env.js -step4_if_fn_do.js: utils.js reader.js printer.js env.js core.js -step5_tco.js: utils.js reader.js printer.js env.js core.js -step6_file.js: utils.js reader.js printer.js env.js core.js -step7_quote.js: utils.js reader.js printer.js env.js core.js -step8_macros.js: utils.js reader.js printer.js env.js core.js -step9_try.js: utils.js reader.js printer.js env.js core.js -stepA_mal.js: utils.js reader.js printer.js env.js core.js - -clean: - rm -f $(BINS) +SOURCES_BASE = reader.ls printer.ls env.ls core.ls utils.ls +SOURCES_STEPS = step0_repl.ls step1_read_print.ls step2_eval.ls \ + step4_if_fn_do.ls step5_tco.ls step6_file.ls step7_quote.ls \ + step8_macros.ls step9_try.ls stepA_mal.ls +SOURCES = $(SOURCES_BASE) $(SOURCES_STEPS) + +BINS = $(SOURCES:%.ls=%.js) + +LSC = node_modules/.bin/lsc + +all: node_modules $(BINS) + +node_modules: + npm install + +%.js: %.ls node_modules + $(LSC) -d -c $(@:%.js=%.ls) + +step1_read_print.js: utils.js reader.js printer.js +step2_eval.js: utils.js reader.js printer.js +step3_env.js: utils.js reader.js printer.js env.js +step4_if_fn_do.js: utils.js reader.js printer.js env.js core.js +step5_tco.js: utils.js reader.js printer.js env.js core.js +step6_file.js: utils.js reader.js printer.js env.js core.js +step7_quote.js: utils.js reader.js printer.js env.js core.js +step8_macros.js: utils.js reader.js printer.js env.js core.js +step9_try.js: utils.js reader.js printer.js env.js core.js +stepA_mal.js: utils.js reader.js printer.js env.js core.js + +clean: + rm -f $(BINS) diff --git a/impls/livescript/core.ls b/impls/livescript/core.ls index 6f45e9633c..b3ccd94979 100644 --- a/impls/livescript/core.ls +++ b/impls/livescript/core.ls @@ -1,349 +1,349 @@ - -{ - zip, map, apply, and-list, join, Obj, concat, all, - pairs-to-obj, obj-to-pairs, reject, keys, values, - difference, empty, reverse, chars -} = require 'prelude-ls' -{pr_str} = require './printer' -{read_str, list-to-map, map-keyword, keyword-prefix} = require './reader' -fs = require 'fs' -{readline} = require './node_readline' - - -export runtime-error = (msg) -> throw new Error msg - -export unpack-tco = (ast) -> - if ast.type == \tco - then ast.eval! - else ast - -fn = (body) -> {type: \function, value: body} -const-nil = -> {type: \const, value: \nil} -const-int = (int) -> {type: \int, value: int} -const-bool = (bool) -> {type: \const, value: if bool then \true else \false} -const-str = (str) -> {type: \string, value: str} - -list-or-vector = ({type}) -> type in [\list \vector] - -are-lists-equal = (equals-fn, a, b) -> - if a.length != b.length then false - else zip a, b |> map (apply equals-fn) |> and-list - -deep-equals = (a, b) -> - if (list-or-vector a) and (list-or-vector b) then - are-lists-equal deep-equals, a.value, b.value - else if a.type == \map and b.type == \map then - a-keys = keys a.value - b-keys = keys b.value - if a-keys.length == b-keys.length and \ - empty (difference a-keys, b-keys) - #if are-lists-equal (==), a-keys, b-keys - a-keys |> map (key) -> [a.value[key], b.value[key]] - |> map (apply deep-equals) - |> and-list - else false - else if a.type != b.type then false - else a.value == b.value - - -check-param = (name, idx, test, expected, actual) -> - if not test - runtime-error "'#{name}' expected parameter #{idx} - to be #{expected}, got #{actual}" - - -check-type = (name, idx, expected, actual) -> - check-param name, idx, expected == actual, expected, actual - - -export ns = do - '+': fn (a, b) -> const-int a.value + b.value - '-': fn (a, b) -> const-int a.value - b.value - '*': fn (a, b) -> const-int a.value * b.value - '/': fn (a, b) -> const-int parseInt (a.value / b.value) - - 'list': fn (...list) -> {type: \list, value: list} - 'list?': fn (param) -> const-bool param.type == \list - - 'empty?': fn ({type, value}) -> - switch type - | \const => - if value == \nil - then const-bool true - else runtime-error "'empty?' is not supported on #{value}" - | \list, \vector => - const-bool value.length == 0 - | \map => - const-bool Obj.empty value - | otherwise => - runtime-error "'empty?' is not supported on type #{type}" - - 'count': fn ({type, value}) -> - switch type - | \const => - if value == \nil - then const-int 0 - else runtime-error "'count' is not supported on #{value}" - | \list, \vector => - const-int value.length - | \map => - value |> Obj.keys |> (.length) |> const-int - | otherwise => - runtime-error "'count' is not supported on type #{type}" - - '=': fn (a, b) -> const-bool (deep-equals a, b) - '<': fn (a, b) -> const-bool a.value < b.value - '>': fn (a, b) -> const-bool a.value > b.value - '<=': fn (a, b) -> const-bool a.value <= b.value - '>=': fn (a, b) -> const-bool a.value >= b.value - - 'pr-str': fn (...params) -> - params |> map (p) -> pr_str p, print_readably=true - |> join ' ' - |> const-str - - 'str': fn (...params) -> - params |> map (p) -> pr_str p, print_readably=false - |> join '' - |> const-str - - 'prn': fn (...params) -> - params |> map (p) -> pr_str p, print_readably=true - |> join ' ' - |> console.log - |> const-nil - - 'println': fn (...params) -> - params |> map (p) -> pr_str p, print_readbly=false - |> join ' ' - |> console.log - |> const-nil - - 'read-string': fn ({type, value}) -> - check-type 'read-string', 0, \string, type - read_str value - - 'slurp': fn (filename) -> - if filename.type != \string - runtime-error "'slurp' expected the first parameter - to be a string, got a #{filename.type}" - - const-str <| fs.readFileSync filename.value, 'utf8' - - 'atom': fn (value) -> {type: \atom, value: value} - 'atom?': fn (atom) -> const-bool atom.type == \atom - 'deref': fn (atom) -> - check-type 'deref', 0, \atom, atom.type - atom.value - - 'reset!': fn (atom, value) -> - check-type 'reset!', 0, \atom, atom.type - atom.value = value - - 'swap!': fn (atom, fn, ...args) -> - check-type 'swap!', 0, \atom, atom.type - if fn.type != \function - runtime-error "'swap!' expected the second parameter - to be a function, got a #{fn.type}" - - atom.value = unpack-tco (fn.value.apply @, [atom.value] ++ args) - - 'cons': fn (value, list) -> - check-param 'cons', 1, (list-or-vector list), - 'list or vector', list.type - - {type: \list, value: [value] ++ list.value} - - 'concat': fn (...params) -> - if not all list-or-vector, params - runtime-error "'concat' expected all parameters to be a list or vector" - - {type: \list, value: params |> map (.value) |> concat} - - 'vec': fn (sequence) -> - check-param 'vec', 0, (list-or-vector sequence), - 'list or vector', sequence.type - - {type: \vector, value: sequence.value} - - 'nth': fn (list, index) -> - check-param 'nth', 0, (list-or-vector list), - 'list or vector', list.type - check-param 'nth', 1, index.type == \int, - 'int', index.type - - if index.value < 0 or index.value >= list.value.length - runtime-error 'list index out of bounds' - - list.value[index.value] - - 'first': fn (list) -> - if list.type == \const and list.value == \nil - return const-nil! - - check-param 'first', 0, (list-or-vector list), - 'list or vector', list.type - - if list.value.length == 0 - then const-nil! - else list.value[0] - - 'rest': fn (list) -> - if list.type == \const and list.value == \nil - return {type: \list, value: []} - - check-param 'rest', 0, (list-or-vector list), - 'list or vector', list.type - - {type: \list, value: list.value.slice 1} - - 'throw': fn (value) -> throw value - - 'apply': fn (fn, ...params, list) -> - check-type 'apply', 0, \function, fn.type - if not list then runtime-error "apply expected at least two parameters" - check-param 'apply', params.length+1, (list-or-vector list), - 'list or vector', list.type - - unpack-tco fn.value.apply @, params ++ list.value - - 'map': fn (fn, list) -> - check-type 'map', 0, \function, fn.type - check-param 'map', 1, (list-or-vector list), - 'list or vector', list.type - - mapped-list = list.value |> map (value) -> - unpack-tco fn.value.apply @, [value] - - {type: \list, value: mapped-list} - - 'nil?': fn (ast) -> const-bool (ast.type == \const and ast.value == \nil) - 'true?': fn (ast) -> const-bool (ast.type == \const and ast.value == \true) - 'false?': fn (ast) -> const-bool (ast.type == \const and ast.value == \false) - 'symbol?': fn (ast) -> const-bool ast.type == \symbol - - 'symbol': fn (str) -> - check-type 'symbol', 0, \string, str.type - {type: \symbol, value: str.value} - - 'keyword': fn (str) -> - check-type 'keyword', 0, \string, str.type - {type: \keyword, value: ':' + str.value} - - 'keyword?': fn (ast) -> const-bool ast.type == \keyword - - 'number?': fn (ast) -> const-bool ast.type == \int - 'fn?': fn (ast) -> const-bool (ast.type == \function and not ast.is_macro) - 'macro?': fn (ast) -> const-bool (ast.type == \function and ast.is_macro) - - 'vector': fn (...params) -> {type: \vector, value: params} - 'vector?': fn (ast) -> const-bool ast.type == \vector - - 'hash-map': fn (...params) -> list-to-map params - - 'map?': fn (ast) -> const-bool ast.type == \map - - 'assoc': fn (m, ...params) -> - check-type 'assoc', 0, \map, m.type - - # Turn the params into a map, this is kind of hacky. - params-map = list-to-map params - - # Copy the map by cloning (prototyping). - new-map = ^^m.value - - for k, v of params-map.value - new-map[k] = v - - {type: \map, value: new-map} - - 'dissoc': fn (m, ...keys) -> - check-type 'dissoc', 0, \map, m.type - - # Convert keyword to map key strings. - str-keys = keys |> map map-keyword - - new-map = m.value - |> obj-to-pairs - |> reject ([key, value]) -> key in str-keys - |> pairs-to-obj - - {type: \map, value: new-map} - - 'get': fn (m, key) -> - if m.type == \const and m.value == \nil - then return const-nil! - - check-type 'get', 0, \map, m.type - str-key = map-keyword key - value = m.value[str-key] - if value then value else const-nil! - - 'contains?': fn (m, key) -> - check-type 'contains?', 0, \map, m.type - str-key = map-keyword key - const-bool (str-key of m.value) - - 'keys': fn (m) -> - check-type 'keys', 0, \map, m.type - result = keys m.value |> map (key) -> - if key.startsWith keyword-prefix - then {type: \keyword, value: key.substring 1} - else {type: \string, value: key} - {type: \list, value: result} - - 'vals': fn (m) -> - check-type 'vals', 0, \map, m.type - {type: \list, value: values m.value} - - 'sequential?': fn (ast) -> const-bool list-or-vector ast - - 'with-meta': fn (ast, m) -> - ast with {meta: m} - - 'meta': fn (ast) -> - if ast.meta - then ast.meta - else const-nil! - - 'readline': fn (prompt) -> - check-type 'readline', 0, \string, prompt.type - result = readline prompt.value - if result? - then const-str result - else const-nil! - - 'time-ms': fn -> - const-int (new Date).getTime! - - 'conj': fn (list, ...params) -> - check-param 'conj', 0, (list-or-vector list), - 'list or vector', list.type - - if list.type == \list - type: \list - value: (reverse params) ++ list.value - else - type: \vector - value: list.value ++ params - - 'string?': fn (ast) -> const-bool ast.type == \string - - 'seq': fn (seq) -> - switch seq.type - | \list => - if seq.value.length - then seq - else const-nil! - | \vector => - if seq.value.length - then {type: \list, value: seq.value} - else const-nil! - | \string => - if seq.value.length - then {type: \list, value: chars seq.value |> map const-str} - else const-nil! - | otherwise => - if seq.type == \const and seq.value == \nil - then const-nil! - else runtime-error "unsupported type for 'seq': #{seq.type}" + +{ + zip, map, apply, and-list, join, Obj, concat, all, + pairs-to-obj, obj-to-pairs, reject, keys, values, + difference, empty, reverse, chars +} = require 'prelude-ls' +{pr_str} = require './printer' +{read_str, list-to-map, map-keyword, keyword-prefix} = require './reader' +fs = require 'fs' +{readline} = require './node_readline' + + +export runtime-error = (msg) -> throw new Error msg + +export unpack-tco = (ast) -> + if ast.type == \tco + then ast.eval! + else ast + +fn = (body) -> {type: \function, value: body} +const-nil = -> {type: \const, value: \nil} +const-int = (int) -> {type: \int, value: int} +const-bool = (bool) -> {type: \const, value: if bool then \true else \false} +const-str = (str) -> {type: \string, value: str} + +list-or-vector = ({type}) -> type in [\list \vector] + +are-lists-equal = (equals-fn, a, b) -> + if a.length != b.length then false + else zip a, b |> map (apply equals-fn) |> and-list + +deep-equals = (a, b) -> + if (list-or-vector a) and (list-or-vector b) then + are-lists-equal deep-equals, a.value, b.value + else if a.type == \map and b.type == \map then + a-keys = keys a.value + b-keys = keys b.value + if a-keys.length == b-keys.length and \ + empty (difference a-keys, b-keys) + #if are-lists-equal (==), a-keys, b-keys + a-keys |> map (key) -> [a.value[key], b.value[key]] + |> map (apply deep-equals) + |> and-list + else false + else if a.type != b.type then false + else a.value == b.value + + +check-param = (name, idx, test, expected, actual) -> + if not test + runtime-error "'#{name}' expected parameter #{idx} + to be #{expected}, got #{actual}" + + +check-type = (name, idx, expected, actual) -> + check-param name, idx, expected == actual, expected, actual + + +export ns = do + '+': fn (a, b) -> const-int a.value + b.value + '-': fn (a, b) -> const-int a.value - b.value + '*': fn (a, b) -> const-int a.value * b.value + '/': fn (a, b) -> const-int parseInt (a.value / b.value) + + 'list': fn (...list) -> {type: \list, value: list} + 'list?': fn (param) -> const-bool param.type == \list + + 'empty?': fn ({type, value}) -> + switch type + | \const => + if value == \nil + then const-bool true + else runtime-error "'empty?' is not supported on #{value}" + | \list, \vector => + const-bool value.length == 0 + | \map => + const-bool Obj.empty value + | otherwise => + runtime-error "'empty?' is not supported on type #{type}" + + 'count': fn ({type, value}) -> + switch type + | \const => + if value == \nil + then const-int 0 + else runtime-error "'count' is not supported on #{value}" + | \list, \vector => + const-int value.length + | \map => + value |> Obj.keys |> (.length) |> const-int + | otherwise => + runtime-error "'count' is not supported on type #{type}" + + '=': fn (a, b) -> const-bool (deep-equals a, b) + '<': fn (a, b) -> const-bool a.value < b.value + '>': fn (a, b) -> const-bool a.value > b.value + '<=': fn (a, b) -> const-bool a.value <= b.value + '>=': fn (a, b) -> const-bool a.value >= b.value + + 'pr-str': fn (...params) -> + params |> map (p) -> pr_str p, print_readably=true + |> join ' ' + |> const-str + + 'str': fn (...params) -> + params |> map (p) -> pr_str p, print_readably=false + |> join '' + |> const-str + + 'prn': fn (...params) -> + params |> map (p) -> pr_str p, print_readably=true + |> join ' ' + |> console.log + |> const-nil + + 'println': fn (...params) -> + params |> map (p) -> pr_str p, print_readbly=false + |> join ' ' + |> console.log + |> const-nil + + 'read-string': fn ({type, value}) -> + check-type 'read-string', 0, \string, type + read_str value + + 'slurp': fn (filename) -> + if filename.type != \string + runtime-error "'slurp' expected the first parameter + to be a string, got a #{filename.type}" + + const-str <| fs.readFileSync filename.value, 'utf8' + + 'atom': fn (value) -> {type: \atom, value: value} + 'atom?': fn (atom) -> const-bool atom.type == \atom + 'deref': fn (atom) -> + check-type 'deref', 0, \atom, atom.type + atom.value + + 'reset!': fn (atom, value) -> + check-type 'reset!', 0, \atom, atom.type + atom.value = value + + 'swap!': fn (atom, fn, ...args) -> + check-type 'swap!', 0, \atom, atom.type + if fn.type != \function + runtime-error "'swap!' expected the second parameter + to be a function, got a #{fn.type}" + + atom.value = unpack-tco (fn.value.apply @, [atom.value] ++ args) + + 'cons': fn (value, list) -> + check-param 'cons', 1, (list-or-vector list), + 'list or vector', list.type + + {type: \list, value: [value] ++ list.value} + + 'concat': fn (...params) -> + if not all list-or-vector, params + runtime-error "'concat' expected all parameters to be a list or vector" + + {type: \list, value: params |> map (.value) |> concat} + + 'vec': fn (sequence) -> + check-param 'vec', 0, (list-or-vector sequence), + 'list or vector', sequence.type + + {type: \vector, value: sequence.value} + + 'nth': fn (list, index) -> + check-param 'nth', 0, (list-or-vector list), + 'list or vector', list.type + check-param 'nth', 1, index.type == \int, + 'int', index.type + + if index.value < 0 or index.value >= list.value.length + runtime-error 'list index out of bounds' + + list.value[index.value] + + 'first': fn (list) -> + if list.type == \const and list.value == \nil + return const-nil! + + check-param 'first', 0, (list-or-vector list), + 'list or vector', list.type + + if list.value.length == 0 + then const-nil! + else list.value[0] + + 'rest': fn (list) -> + if list.type == \const and list.value == \nil + return {type: \list, value: []} + + check-param 'rest', 0, (list-or-vector list), + 'list or vector', list.type + + {type: \list, value: list.value.slice 1} + + 'throw': fn (value) -> throw value + + 'apply': fn (fn, ...params, list) -> + check-type 'apply', 0, \function, fn.type + if not list then runtime-error "apply expected at least two parameters" + check-param 'apply', params.length+1, (list-or-vector list), + 'list or vector', list.type + + unpack-tco fn.value.apply @, params ++ list.value + + 'map': fn (fn, list) -> + check-type 'map', 0, \function, fn.type + check-param 'map', 1, (list-or-vector list), + 'list or vector', list.type + + mapped-list = list.value |> map (value) -> + unpack-tco fn.value.apply @, [value] + + {type: \list, value: mapped-list} + + 'nil?': fn (ast) -> const-bool (ast.type == \const and ast.value == \nil) + 'true?': fn (ast) -> const-bool (ast.type == \const and ast.value == \true) + 'false?': fn (ast) -> const-bool (ast.type == \const and ast.value == \false) + 'symbol?': fn (ast) -> const-bool ast.type == \symbol + + 'symbol': fn (str) -> + check-type 'symbol', 0, \string, str.type + {type: \symbol, value: str.value} + + 'keyword': fn (str) -> + check-type 'keyword', 0, \string, str.type + {type: \keyword, value: ':' + str.value} + + 'keyword?': fn (ast) -> const-bool ast.type == \keyword + + 'number?': fn (ast) -> const-bool ast.type == \int + 'fn?': fn (ast) -> const-bool (ast.type == \function and not ast.is_macro) + 'macro?': fn (ast) -> const-bool (ast.type == \function and ast.is_macro) + + 'vector': fn (...params) -> {type: \vector, value: params} + 'vector?': fn (ast) -> const-bool ast.type == \vector + + 'hash-map': fn (...params) -> list-to-map params + + 'map?': fn (ast) -> const-bool ast.type == \map + + 'assoc': fn (m, ...params) -> + check-type 'assoc', 0, \map, m.type + + # Turn the params into a map, this is kind of hacky. + params-map = list-to-map params + + # Copy the map by cloning (prototyping). + new-map = ^^m.value + + for k, v of params-map.value + new-map[k] = v + + {type: \map, value: new-map} + + 'dissoc': fn (m, ...keys) -> + check-type 'dissoc', 0, \map, m.type + + # Convert keyword to map key strings. + str-keys = keys |> map map-keyword + + new-map = m.value + |> obj-to-pairs + |> reject ([key, value]) -> key in str-keys + |> pairs-to-obj + + {type: \map, value: new-map} + + 'get': fn (m, key) -> + if m.type == \const and m.value == \nil + then return const-nil! + + check-type 'get', 0, \map, m.type + str-key = map-keyword key + value = m.value[str-key] + if value then value else const-nil! + + 'contains?': fn (m, key) -> + check-type 'contains?', 0, \map, m.type + str-key = map-keyword key + const-bool (str-key of m.value) + + 'keys': fn (m) -> + check-type 'keys', 0, \map, m.type + result = keys m.value |> map (key) -> + if key.startsWith keyword-prefix + then {type: \keyword, value: key.substring 1} + else {type: \string, value: key} + {type: \list, value: result} + + 'vals': fn (m) -> + check-type 'vals', 0, \map, m.type + {type: \list, value: values m.value} + + 'sequential?': fn (ast) -> const-bool list-or-vector ast + + 'with-meta': fn (ast, m) -> + ast with {meta: m} + + 'meta': fn (ast) -> + if ast.meta + then ast.meta + else const-nil! + + 'readline': fn (prompt) -> + check-type 'readline', 0, \string, prompt.type + result = readline prompt.value + if result? + then const-str result + else const-nil! + + 'time-ms': fn -> + const-int (new Date).getTime! + + 'conj': fn (list, ...params) -> + check-param 'conj', 0, (list-or-vector list), + 'list or vector', list.type + + if list.type == \list + type: \list + value: (reverse params) ++ list.value + else + type: \vector + value: list.value ++ params + + 'string?': fn (ast) -> const-bool ast.type == \string + + 'seq': fn (seq) -> + switch seq.type + | \list => + if seq.value.length + then seq + else const-nil! + | \vector => + if seq.value.length + then {type: \list, value: seq.value} + else const-nil! + | \string => + if seq.value.length + then {type: \list, value: chars seq.value |> map const-str} + else const-nil! + | otherwise => + if seq.type == \const and seq.value == \nil + then const-nil! + else runtime-error "unsupported type for 'seq': #{seq.type}" diff --git a/impls/livescript/env.ls b/impls/livescript/env.ls index 594048012d..ef4e200cda 100644 --- a/impls/livescript/env.ls +++ b/impls/livescript/env.ls @@ -1,21 +1,21 @@ -export class Env - (outer = null, data = {}) -> - @outer = outer - @data = data - - set: (symbol, ast) -> - @data[symbol] = ast - - find: (symbol) -> - if symbol of @data then @ - else if @outer? then @outer.find symbol - - get: (symbol) -> - result = @try-get symbol - if not result - then throw new Error "'#{symbol}' not found" - else result - - try-get: (symbol) -> - env = @find symbol - if env then env.data[symbol] +export class Env + (outer = null, data = {}) -> + @outer = outer + @data = data + + set: (symbol, ast) -> + @data[symbol] = ast + + find: (symbol) -> + if symbol of @data then @ + else if @outer? then @outer.find symbol + + get: (symbol) -> + result = @try-get symbol + if not result + then throw new Error "'#{symbol}' not found" + else result + + try-get: (symbol) -> + env = @find symbol + if env then env.data[symbol] diff --git a/impls/livescript/node_readline.js b/impls/livescript/node_readline.js index 0a50f91f36..2e0de41a25 100644 --- a/impls/livescript/node_readline.js +++ b/impls/livescript/node_readline.js @@ -1,47 +1,47 @@ -// IMPORTANT: choose one -var RL_LIB = "libreadline"; // NOTE: libreadline is GPL -//var RL_LIB = "libedit"; - -var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); - -var rlwrap = {}; // namespace for this module in web context - -var ffi = require('ffi-napi'), - fs = require('fs'); - -var rllib = ffi.Library(RL_LIB, { - 'readline': [ 'string', [ 'string' ] ], - 'add_history': [ 'int', [ 'string' ] ]}); - -var rl_history_loaded = false; - -exports.readline = rlwrap.readline = function(prompt) { - prompt = typeof prompt !== 'undefined' ? prompt : "user> "; - - if (!rl_history_loaded) { - rl_history_loaded = true; - var lines = []; - if (fs.existsSync(HISTORY_FILE)) { - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - } - // Max of 2000 lines - lines = lines.slice(Math.max(lines.length - 2000, 0)); - for (var i=0; i "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i - switch type - | \const => value - | \int => value - | \string => - if print_readably - then encode-string value - else value - | \symbol => value - | \keyword => value - | \list => '(' + (pr_list value, print_readably) + ')' - | \vector => '[' + (pr_list value, print_readably) + ']' - | \map => '{' + (pr_map value, print_readably) + '}' - | \function => '#' - | \atom => '(atom ' + (pr_str value) + ')' - - -encode-string = (str) -> - str |> (.replace /[\n\"\\]/g, - (ch) -> switch ch - | '\n' => '\\n' - | '"' => '\\"' - | '\\' => '\\\\') - |> (enc) -> "\"#{enc}\"" - - -pr_list = (list, print_readably) -> - list |> map (ast) -> pr_str ast, print_readably - |> join ' ' - - -pr_map_key = (key, print_readably) -> - if key.startsWith keyword-prefix - key.substring 1 - else if print_readably - encode-string key - else - key - -pr_map = (obj, print_readably) -> - obj |> obj-to-pairs - |> map ([key, value]) -> - key_str = pr_map_key key, print_readably - value_str = pr_str value, print_readably - key_str + ' ' + value_str - |> join ' ' +{is-type, map, join, obj-to-pairs} = require 'prelude-ls' +{keyword-prefix} = require './reader' + + +export pr_str = ({type, value}: ast, print_readably=true) -> + switch type + | \const => value + | \int => value + | \string => + if print_readably + then encode-string value + else value + | \symbol => value + | \keyword => value + | \list => '(' + (pr_list value, print_readably) + ')' + | \vector => '[' + (pr_list value, print_readably) + ']' + | \map => '{' + (pr_map value, print_readably) + '}' + | \function => '#' + | \atom => '(atom ' + (pr_str value) + ')' + + +encode-string = (str) -> + str |> (.replace /[\n\"\\]/g, + (ch) -> switch ch + | '\n' => '\\n' + | '"' => '\\"' + | '\\' => '\\\\') + |> (enc) -> "\"#{enc}\"" + + +pr_list = (list, print_readably) -> + list |> map (ast) -> pr_str ast, print_readably + |> join ' ' + + +pr_map_key = (key, print_readably) -> + if key.startsWith keyword-prefix + key.substring 1 + else if print_readably + encode-string key + else + key + +pr_map = (obj, print_readably) -> + obj |> obj-to-pairs + |> map ([key, value]) -> + key_str = pr_map_key key, print_readably + value_str = pr_str value, print_readably + key_str + ' ' + value_str + |> join ' ' diff --git a/impls/livescript/reader.ls b/impls/livescript/reader.ls index 119ab9f23a..5578797e72 100644 --- a/impls/livescript/reader.ls +++ b/impls/livescript/reader.ls @@ -1,181 +1,181 @@ -readline = require 'readline' -{id, map, pairs-to-obj} = require 'prelude-ls' -{list-to-pairs} = require './utils' - -export class OnlyComment - -parse-error = (msg) -> throw new Error msg - -class Reader - (tokens) -> - @tokens = tokens - @pos = 0 - - # returns the token at the current position - # and increments position. - next: -> - result = @peek! - if result? then @pos += 1 - result - - # just returns the token at the current position. - peek: -> - if @pos < @tokens.length - @tokens[@pos] - - -eof-or-comment = (reader) -> - token = reader.peek! - if token? and not token.startsWith ';' - then parse-error "expected EOF, got '#{token}'" - - -export read_str = (str) -> - str - |> tokenizer - |> (tokens) -> new Reader tokens - |> (reader) -> - result = read_form reader - if token? then parse-error "expected EOF, got '#{token}'" - result - - -# This function will take a single string and return an array/list -# of all the tokens (strings) in it. -tokenizer = (str) -> - re = // - [\s,]* # whitespace or commas - ( ~@ # special two-char ~@ - | [\[\]{}()'`~^@] # special single char one of []{}'`~^@ - | "(?:\\.| [^\\"])*"? # double-quoted string - | ;.* # any seq of chars starting ; - | [^\s\[\]{}('"`,;)]+ # seq of non-special chars: symbols, numbers, - ) # "true", "false" and "nil". - //y - - tokens = [] - while re.lastIndex < str.length - idx = re.lastIndex - m = re.exec str - if not m - # Allow whitespace or commas at the end of the input. - break if /[\s,]+/.exec str.substring idx - parse-error "parse error at character #{idx}" - - tok = m[1] - # Ignore comments. - if tok[0] != ';' then tokens.push m[1] - - tokens - -read_form = (reader) -> - switch reader.peek! - | '(' => read_list reader, ')' - | '[' => read_list reader, ']' - | '{' => read_list reader, '}' - | '\'' => read-macro 'quote', reader - | '\`' => read-macro 'quasiquote', reader - | '~' => read-macro 'unquote', reader - | '~@' => read-macro 'splice-unquote', reader - | '@' => read-macro 'deref', reader # todo only symbol? - | '^' => read-with-meta reader - | otherwise => - if that? then read_atom reader - else parse-error 'expected a form, got EOF' - - -read_list = (reader, end) -> - list = [] - reader.next! # accept '(', '[' or '{' - loop - token = reader.peek! - if not token? - parse-error "expected '#{end}', got EOF" - else if token == end - reader.next! - break - - list.push read_form reader - - switch end - | ')' => {type: \list, value: list} - | ']' => {type: \vector, value: list} - | '}' => list-to-map list - - -special_chars = '[]{}\'`~^@' -constants = [\true \false \nil] - - -read_atom = (reader) -> - token = reader.peek! - if token in constants - {type: \const, value: reader.next!} - else if token.match /^"(?:\\.|[^\\"])*"$/ - {type: \string, value: decode-string reader.next!} - else if token[0] == '"' - parse-error "expected '\"', got EOF" - else if token.match /^-?\d+$/ - {type: \int, value: parseInt reader.next!} - else if token != '~@' and token not in special_chars - if token.startsWith ':' - {type: \keyword, value: reader.next!} - else - {type: \symbol, value: reader.next!} - else - parse-error "expected an atom, got #{token}" - - -decode-string = (str) -> - str |> (.slice 1, -1) - |> (.replace /\\[\"\\n]/g, - (esc) -> switch esc - | '\\n' => '\n' - | '\\"' => '"' - | '\\\\' => '\\') - - -export keyword-prefix = '\u029e' - -export map-keyword = (key) -> - switch key.type - | \string => key.value - | \keyword => keyword-prefix + key.value - | otherwise => - parse-error "#{key.type} can't be a map key" - -export list-to-map = (list) -> - if list.length % 2 != 0 - parse-error "map should have an even number - of elements, got #{list.length}" - - list-to-pairs list - |> map ([key, value]) -> [(map-keyword key), value] - |> pairs-to-obj - |> (obj) -> {type: \map, value: obj} - - -read-macro = (symbol, reader) -> - reader.next! # accept macro start token - - do - type: \list - value: - * {type: \symbol, value: symbol} - * read_form reader - - -read-with-meta = (reader) -> - reader.next! # accept ^ - if reader.peek! != '{' - parse-error "expected a map after with-meta reader macro '^'" - - meta = read_list reader, '}' - form = read_form reader - - do - type: \list - value: - * {type: \symbol, value: 'with-meta'} - * form - * meta +readline = require 'readline' +{id, map, pairs-to-obj} = require 'prelude-ls' +{list-to-pairs} = require './utils' + +export class OnlyComment + +parse-error = (msg) -> throw new Error msg + +class Reader + (tokens) -> + @tokens = tokens + @pos = 0 + + # returns the token at the current position + # and increments position. + next: -> + result = @peek! + if result? then @pos += 1 + result + + # just returns the token at the current position. + peek: -> + if @pos < @tokens.length + @tokens[@pos] + + +eof-or-comment = (reader) -> + token = reader.peek! + if token? and not token.startsWith ';' + then parse-error "expected EOF, got '#{token}'" + + +export read_str = (str) -> + str + |> tokenizer + |> (tokens) -> new Reader tokens + |> (reader) -> + result = read_form reader + if token? then parse-error "expected EOF, got '#{token}'" + result + + +# This function will take a single string and return an array/list +# of all the tokens (strings) in it. +tokenizer = (str) -> + re = // + [\s,]* # whitespace or commas + ( ~@ # special two-char ~@ + | [\[\]{}()'`~^@] # special single char one of []{}'`~^@ + | "(?:\\.| [^\\"])*"? # double-quoted string + | ;.* # any seq of chars starting ; + | [^\s\[\]{}('"`,;)]+ # seq of non-special chars: symbols, numbers, + ) # "true", "false" and "nil". + //y + + tokens = [] + while re.lastIndex < str.length + idx = re.lastIndex + m = re.exec str + if not m + # Allow whitespace or commas at the end of the input. + break if /[\s,]+/.exec str.substring idx + parse-error "parse error at character #{idx}" + + tok = m[1] + # Ignore comments. + if tok[0] != ';' then tokens.push m[1] + + tokens + +read_form = (reader) -> + switch reader.peek! + | '(' => read_list reader, ')' + | '[' => read_list reader, ']' + | '{' => read_list reader, '}' + | '\'' => read-macro 'quote', reader + | '\`' => read-macro 'quasiquote', reader + | '~' => read-macro 'unquote', reader + | '~@' => read-macro 'splice-unquote', reader + | '@' => read-macro 'deref', reader # todo only symbol? + | '^' => read-with-meta reader + | otherwise => + if that? then read_atom reader + else parse-error 'expected a form, got EOF' + + +read_list = (reader, end) -> + list = [] + reader.next! # accept '(', '[' or '{' + loop + token = reader.peek! + if not token? + parse-error "expected '#{end}', got EOF" + else if token == end + reader.next! + break + + list.push read_form reader + + switch end + | ')' => {type: \list, value: list} + | ']' => {type: \vector, value: list} + | '}' => list-to-map list + + +special_chars = '[]{}\'`~^@' +constants = [\true \false \nil] + + +read_atom = (reader) -> + token = reader.peek! + if token in constants + {type: \const, value: reader.next!} + else if token.match /^"(?:\\.|[^\\"])*"$/ + {type: \string, value: decode-string reader.next!} + else if token[0] == '"' + parse-error "expected '\"', got EOF" + else if token.match /^-?\d+$/ + {type: \int, value: parseInt reader.next!} + else if token != '~@' and token not in special_chars + if token.startsWith ':' + {type: \keyword, value: reader.next!} + else + {type: \symbol, value: reader.next!} + else + parse-error "expected an atom, got #{token}" + + +decode-string = (str) -> + str |> (.slice 1, -1) + |> (.replace /\\[\"\\n]/g, + (esc) -> switch esc + | '\\n' => '\n' + | '\\"' => '"' + | '\\\\' => '\\') + + +export keyword-prefix = '\u029e' + +export map-keyword = (key) -> + switch key.type + | \string => key.value + | \keyword => keyword-prefix + key.value + | otherwise => + parse-error "#{key.type} can't be a map key" + +export list-to-map = (list) -> + if list.length % 2 != 0 + parse-error "map should have an even number + of elements, got #{list.length}" + + list-to-pairs list + |> map ([key, value]) -> [(map-keyword key), value] + |> pairs-to-obj + |> (obj) -> {type: \map, value: obj} + + +read-macro = (symbol, reader) -> + reader.next! # accept macro start token + + do + type: \list + value: + * {type: \symbol, value: symbol} + * read_form reader + + +read-with-meta = (reader) -> + reader.next! # accept ^ + if reader.peek! != '{' + parse-error "expected a map after with-meta reader macro '^'" + + meta = read_list reader, '}' + form = read_form reader + + do + type: \list + value: + * {type: \symbol, value: 'with-meta'} + * form + * meta diff --git a/impls/livescript/run b/impls/livescript/run index 6605303a29..75d63815c6 100755 --- a/impls/livescript/run +++ b/impls/livescript/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" +#!/bin/bash +exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" diff --git a/impls/livescript/step0_repl.ls b/impls/livescript/step0_repl.ls index 0395fc9a23..ff986bc0f3 100644 --- a/impls/livescript/step0_repl.ls +++ b/impls/livescript/step0_repl.ls @@ -1,28 +1,28 @@ -readline = require './node_readline' -{id} = require 'prelude-ls' - - -READ = id -EVAL = id -PRINT = id - -rep = (line) -> PRINT EVAL READ line - -loop - line = readline.readline 'user> ' - break if not line? or line == '' - console.log rep line - -# rl = readline.createInterface do -# input : process.stdin -# output : process.stdout -# prompt: 'user> ' - -# rl.prompt! - -# rl.on 'line', (line) -> -# console.log rep line -# rl.prompt! - -# rl.on 'close', -> -# process.exit 0 +readline = require './node_readline' +{id} = require 'prelude-ls' + + +READ = id +EVAL = id +PRINT = id + +rep = (line) -> PRINT EVAL READ line + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + console.log rep line + +# rl = readline.createInterface do +# input : process.stdin +# output : process.stdout +# prompt: 'user> ' + +# rl.prompt! + +# rl.on 'line', (line) -> +# console.log rep line +# rl.prompt! + +# rl.on 'close', -> +# process.exit 0 diff --git a/impls/livescript/step1_read_print.ls b/impls/livescript/step1_read_print.ls index 1c15955a16..14d9be8e61 100644 --- a/impls/livescript/step1_read_print.ls +++ b/impls/livescript/step1_read_print.ls @@ -1,18 +1,18 @@ -readline = require './node_readline' -{id} = require 'prelude-ls' -{read_str, OnlyComment} = require './reader' -{pr_str} = require './printer' - - -EVAL = id - -rep = (line) -> pr_str EVAL read_str line - -loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch {message}: ex - if ex not instanceof OnlyComment - console.log message +readline = require './node_readline' +{id} = require 'prelude-ls' +{read_str, OnlyComment} = require './reader' +{pr_str} = require './printer' + + +EVAL = id + +rep = (line) -> pr_str EVAL read_str line + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message}: ex + if ex not instanceof OnlyComment + console.log message diff --git a/impls/livescript/step2_eval.ls b/impls/livescript/step2_eval.ls index aa4124da97..0c45846a06 100644 --- a/impls/livescript/step2_eval.ls +++ b/impls/livescript/step2_eval.ls @@ -1,53 +1,53 @@ -readline = require './node_readline' -{id, map, Obj} = require 'prelude-ls' -{read_str} = require './reader' -{pr_str} = require './printer' - -repl_env = do - '+': - type: \function - value: (a, b) -> {type: \int, value: a.value + b.value} - '-': - type: \function - value: (a, b) -> {type: \int, value: a.value - b.value} - '*': - type: \function - value: (a, b) -> {type: \int, value: a.value * b.value} - '/': - type: \function - value: (a, b) -> {type: \int, value: parseInt(a.value / b.value)} - -eval_ast = (repl_env, {type, value}: ast) --> - switch type - | \symbol => - result = repl_env[value] - if not result? then throw new Error 'symbol not found: ', value - result - | \list, \vector => - result = value |> map eval_ast repl_env - if type == \list and result.length != 0 - fn = result[0] - if fn.type != \function - throw new Error fn.value, ' is not a function' - fn.value.apply repl_env, result.slice 1 - else - {type: type, value: result} - | \map => - {type: \map, value: value |> Obj.map eval_ast repl_env} - | otherwise => - ast - - -rep = (line) -> - line - |> read_str - |> eval_ast repl_env - |> pr_str - -loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch {message} - console.error message +readline = require './node_readline' +{id, map, Obj} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' + +repl_env = do + '+': + type: \function + value: (a, b) -> {type: \int, value: a.value + b.value} + '-': + type: \function + value: (a, b) -> {type: \int, value: a.value - b.value} + '*': + type: \function + value: (a, b) -> {type: \int, value: a.value * b.value} + '/': + type: \function + value: (a, b) -> {type: \int, value: parseInt(a.value / b.value)} + +eval_ast = (repl_env, {type, value}: ast) --> + switch type + | \symbol => + result = repl_env[value] + if not result? then throw new Error 'symbol not found: ', value + result + | \list, \vector => + result = value |> map eval_ast repl_env + if type == \list and result.length != 0 + fn = result[0] + if fn.type != \function + throw new Error fn.value, ' is not a function' + fn.value.apply repl_env, result.slice 1 + else + {type: type, value: result} + | \map => + {type: \map, value: value |> Obj.map eval_ast repl_env} + | otherwise => + ast + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> pr_str + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch {message} + console.error message diff --git a/impls/livescript/step3_env.ls b/impls/livescript/step3_env.ls index b6100f2d1b..eb10c76ca4 100644 --- a/impls/livescript/step3_env.ls +++ b/impls/livescript/step3_env.ls @@ -1,126 +1,126 @@ -readline = require './node_readline' -{id, map, each} = require 'prelude-ls' -{read_str} = require './reader' -{pr_str} = require './printer' -{Env} = require './env' - -repl_env = new Env null, do - '+': - type: \function - value: (a, b) -> {type: \int, value: a.value + b.value} - '-': - type: \function - value: (a, b) -> {type: \int, value: a.value - b.value} - '*': - type: \function - value: (a, b) -> {type: \int, value: a.value * b.value} - '/': - type: \function - value: (a, b) -> {type: \int, value: parseInt(a.value / b.value)} - - -is-symbol = ({type, value}: ast, name) -> - type == \symbol and value == name - - -list-to-pairs = (list) -> - [0 to (list.length - 2) by 2] \ - |> map (idx) -> [list[idx], list[idx+1]] - - -eval_simple = (env, {type, value}: ast) -> - switch type - | \symbol => env.get value - | \list, \vector => do - type: type - value: value |> map eval_ast env - | otherwise => ast - - -eval_ast = (env, {type, value}: ast) --> - if type != \list then eval_simple env, ast - else if value.length == 0 then ast - else if value[0].type == \symbol - params = value[1 to] - switch value[0].value - | 'def!' => eval_def env, params - | 'let*' => eval_let env, params - | otherwise => eval_apply env, value - else - eval_apply env, value - - -check_params = (name, params, expected) -> - if params.length != expected - throw new Error "#{name} expected #{expected} parameters, - got #{params.length}" - - -eval_def = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - throw new Error "expected a symbol for the first parameter - of def!, got a #{name.type}" - - # Evaluate the second parameter and store - # it under name in the env. - env.set name.value, (eval_ast env, params[1]) - - -eval_let = (env, params) -> - check_params 'let*', params, 2 - - binding_list = params[0] - if binding_list.type not in [\list \vector] - throw new Error "expected 1st parameter of let* to - be a binding list (or vector), - got a #{binding_list.type}" - else if binding_list.value.length % 2 != 0 - throw new Error "binding list of let* must have an even - number of parameters" - - # Make a new environment with the - # current environment as outer. - let_env = new Env env - - # Evaluate all binding values in the - # new environment. - binding_list.value - |> list-to-pairs - |> each ([binding_name, binding_value]) -> - if binding_name.type != \symbol - throw new Error "expected a symbol as binding name, - got a #{binding_name.type}" - - let_env.set binding_name.value, (eval_ast let_env, binding_value) - - # Evaluate the 'body' of let* with the new environment. - eval_ast let_env, params[1] - - -eval_apply = (env, list) -> - [fn, ...args] = list |> map eval_ast env - if fn.type != \function - throw new Error fn.value, ' is not a function' - fn.value.apply env, args - - -rep = (line) -> - line - |> read_str - |> eval_ast repl_env - |> pr_str - - -loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch error - if error.message - then console.error error.message - else console.error "Error:", pr_str error, print_readably=true +readline = require './node_readline' +{id, map, each} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' + +repl_env = new Env null, do + '+': + type: \function + value: (a, b) -> {type: \int, value: a.value + b.value} + '-': + type: \function + value: (a, b) -> {type: \int, value: a.value - b.value} + '*': + type: \function + value: (a, b) -> {type: \int, value: a.value * b.value} + '/': + type: \function + value: (a, b) -> {type: \int, value: parseInt(a.value / b.value)} + + +is-symbol = ({type, value}: ast, name) -> + type == \symbol and value == name + + +list-to-pairs = (list) -> + [0 to (list.length - 2) by 2] \ + |> map (idx) -> [list[idx], list[idx+1]] + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => do + type: type + value: value |> map eval_ast env + | otherwise => ast + + +eval_ast = (env, {type, value}: ast) --> + if type != \list then eval_simple env, ast + else if value.length == 0 then ast + else if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + +check_params = (name, params, expected) -> + if params.length != expected + throw new Error "#{name} expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + throw new Error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + throw new Error "expected 1st parameter of let* to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + throw new Error "binding list of let* must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + throw new Error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Evaluate the 'body' of let* with the new environment. + eval_ast let_env, params[1] + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + throw new Error fn.value, ' is not a function' + fn.value.apply env, args + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> pr_str + + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/impls/livescript/step4_if_fn_do.ls b/impls/livescript/step4_if_fn_do.ls index 61b74fd00a..5065a9a9a2 100644 --- a/impls/livescript/step4_if_fn_do.ls +++ b/impls/livescript/step4_if_fn_do.ls @@ -1,199 +1,199 @@ -readline = require './node_readline' -{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' -{read_str} = require './reader' -{pr_str} = require './printer' -{Env} = require './env' -{runtime-error, ns} = require './core' -{list-to-pairs} = require './utils' - - -is-thruthy = ({type, value}) -> - type != \const or value not in [\nil \false] - - -fmap-ast = (fn, {type, value}: ast) --> - {type: type, value: fn value} - - -eval_simple = (env, {type, value}: ast) -> - switch type - | \symbol => env.get value - | \list, \vector => ast |> fmap-ast map eval_ast env - | \map => ast |> fmap-ast Obj.map eval_ast env - | otherwise => ast - - -eval_ast = (env, {type, value}: ast) --> - if type != \list then eval_simple env, ast - else if value.length == 0 then ast - else if value[0].type == \symbol - params = value[1 to] - switch value[0].value - | 'def!' => eval_def env, params - | 'let*' => eval_let env, params - | 'do' => eval_do env, params - | 'if' => eval_if env, params - | 'fn*' => eval_fn env, params - | otherwise => eval_apply env, value - else - eval_apply env, value - - -check_params = (name, params, expected) -> - if params.length != expected - runtime-error "'#{name}' expected #{expected} parameters, - got #{params.length}" - - -eval_def = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of def!, got a #{name.type}" - - # Evaluate the second parameter and store - # it under name in the env. - env.set name.value, (eval_ast env, params[1]) - - -eval_let = (env, params) -> - check_params 'let*', params, 2 - - binding_list = params[0] - if binding_list.type not in [\list \vector] - runtime-error "expected 1st parameter of 'let*' to - be a binding list (or vector), - got a #{binding_list.type}" - else if binding_list.value.length % 2 != 0 - runtime-error "binding list of 'let*' must have an even - number of parameters" - - # Make a new environment with the - # current environment as outer. - let_env = new Env env - - # Evaluate all binding values in the - # new environment. - binding_list.value - |> list-to-pairs - |> each ([binding_name, binding_value]) -> - if binding_name.type != \symbol - runtime-error "expected a symbol as binding name, - got a #{binding_name.type}" - - let_env.set binding_name.value, (eval_ast let_env, binding_value) - - # Evaluate the 'body' of let* with the new environment. - eval_ast let_env, params[1] - - -eval_do = (env, params) -> - if params.length == 0 - runtime-error "'do' expected at least one parameter" - - params |> map eval_ast env |> last - - -eval_if = (env, params) -> - if params.length < 2 - runtime-error "'if' expected at least 2 parameters" - else if params.length > 3 - runtime-error "'if' expected at most 3 parameters" - - cond = eval_ast env, params[0] - if is-thruthy cond - eval_ast env, params[1] - else if params.length > 2 - eval_ast env, params[2] - else - {type: \const, value: \nil} - - -eval_fn = (env, params) -> - check_params 'fn*', params, 2 - - if params[0].type not in [\list \vector] - runtime-error "'fn*' expected first parameter to be a list or vector." - - if not all (.type == \symbol), params[0].value - runtime-error "'fn*' expected only symbols in the parameters list." - - binds = params[0].value |> map (.value) - vargs = null - - # Parse variadic bind. - if binds.length >= 2 - [...rest, amper, name] = binds - if amper == '&' and name != '&' - binds = rest - vargs = name - - if elem-index '&', binds - runtime-error "'fn*' invalid usage of variadic parameters." - - if (unique binds).length != binds.length - runtime-error "'fn*' duplicate symbols in parameters list." - - body = params[1] - - fn_instance = (...values) -> - if not vargs and values.length != binds.length - runtime-error "function expected #{binds.length} parameters, - got #{values.length}" - else if vargs and values.length < binds.length - runtime-error "function expected at least - #{binds.length} parameters, - got #{values.length}" - - # Set binds to values in the new env. - fn_env = new Env env - - for [name, value] in (zip binds, values) - fn_env.set name, value - - if vargs - fn_env.set vargs, do - type: \list - value: values.slice binds.length - - # Evaluate the function body with the new environment. - eval_ast fn_env, body - - {type: \function, value: fn_instance} - - -eval_apply = (env, list) -> - [fn, ...args] = list |> map eval_ast env - if fn.type != \function - runtime-error "#{fn.value} is not a function, got a #{fn.type}" - - fn.value.apply env, args - - -repl_env = new Env -for symbol, value of ns - repl_env.set symbol, value - - -rep = (line) -> - line - |> read_str - |> eval_ast repl_env - |> (ast) -> pr_str ast, print_readably=true - - -# Define not. -rep '(def! not (fn* (x) (if x false true)))' - -loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch error - if error.message - then console.error error.message - else console.error "Error:", pr_str error, print_readably=true +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns} = require './core' +{list-to-pairs} = require './utils' + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, {type, value}: ast) --> + if type != \list then eval_simple env, ast + else if value.length == 0 then ast + else if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Evaluate the 'body' of let* with the new environment. + eval_ast let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + params |> map eval_ast env |> last + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + eval_ast env, params[1] + else if params.length > 2 + eval_ast env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, do + type: \list + value: values.slice binds.length + + # Evaluate the function body with the new environment. + eval_ast fn_env, body + + {type: \function, value: fn_instance} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function, got a #{fn.type}" + + fn.value.apply env, args + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define not. +rep '(def! not (fn* (x) (if x false true)))' + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/impls/livescript/step5_tco.ls b/impls/livescript/step5_tco.ls index 10c845c60e..059b58d4ad 100644 --- a/impls/livescript/step5_tco.ls +++ b/impls/livescript/step5_tco.ls @@ -1,217 +1,217 @@ -readline = require './node_readline' -{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' -{read_str} = require './reader' -{pr_str} = require './printer' -{Env} = require './env' -{runtime-error, ns} = require './core' -{list-to-pairs} = require './utils' - - -defer-tco = (env, ast) -> - type: \tco - env: env - ast: ast - - -is-thruthy = ({type, value}) -> - type != \const or value not in [\nil \false] - - -fmap-ast = (fn, {type, value}: ast) --> - {type: type, value: fn value} - - -eval_simple = (env, {type, value}: ast) -> - switch type - | \symbol => env.get value - | \list, \vector => ast |> fmap-ast map eval_ast env - | \map => ast |> fmap-ast Obj.map eval_ast env - | otherwise => ast - - -eval_ast = (env, {type, value}: ast) --> - loop - if type != \list - return eval_simple env, ast - else if value.length == 0 - return ast - - result = if value[0].type == \symbol - params = value[1 to] - switch value[0].value - | 'def!' => eval_def env, params - | 'let*' => eval_let env, params - | 'do' => eval_do env, params - | 'if' => eval_if env, params - | 'fn*' => eval_fn env, params - | otherwise => eval_apply env, value - else - eval_apply env, value - - if result.type == \tco - env = result.env - {type, value}: ast = result.ast - else - return result - - -check_params = (name, params, expected) -> - if params.length != expected - runtime-error "'#{name}' expected #{expected} parameters, - got #{params.length}" - - -eval_def = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of def!, got a #{name.type}" - - # Evaluate the second parameter and store - # it under name in the env. - env.set name.value, (eval_ast env, params[1]) - - -eval_let = (env, params) -> - check_params 'let*', params, 2 - - binding_list = params[0] - if binding_list.type not in [\list \vector] - runtime-error "expected 1st parameter of 'let*' to - be a binding list (or vector), - got a #{binding_list.type}" - else if binding_list.value.length % 2 != 0 - runtime-error "binding list of 'let*' must have an even - number of parameters" - - # Make a new environment with the - # current environment as outer. - let_env = new Env env - - # Evaluate all binding values in the - # new environment. - binding_list.value - |> list-to-pairs - |> each ([binding_name, binding_value]) -> - if binding_name.type != \symbol - runtime-error "expected a symbol as binding name, - got a #{binding_name.type}" - - let_env.set binding_name.value, (eval_ast let_env, binding_value) - - # Defer evaluation of let* body with TCO. - defer-tco let_env, params[1] - - -eval_do = (env, params) -> - if params.length == 0 - runtime-error "'do' expected at least one parameter" - - [...rest, last-param] = params - rest |> each eval_ast env - tco env, last-param - - -eval_if = (env, params) -> - if params.length < 2 - runtime-error "'if' expected at least 2 parameters" - else if params.length > 3 - runtime-error "'if' expected at most 3 parameters" - - cond = eval_ast env, params[0] - if is-thruthy cond - defer-tco env, params[1] - else if params.length > 2 - defer-tco env, params[2] - else - {type: \const, value: \nil} - - -eval_fn = (env, params) -> - check_params 'fn*', params, 2 - - if params[0].type not in [\list \vector] - runtime-error "'fn*' expected first parameter to be a list or vector." - - if not all (.type == \symbol), params[0].value - runtime-error "'fn*' expected only symbols in the parameters list." - - binds = params[0].value |> map (.value) - vargs = null - - # Parse variadic bind. - if binds.length >= 2 - [...rest, amper, name] = binds - if amper == '&' and name != '&' - binds = rest - vargs = name - - if elem-index '&', binds - runtime-error "'fn*' invalid usage of variadic parameters." - - if (unique binds).length != binds.length - runtime-error "'fn*' duplicate symbols in parameters list." - - body = params[1] - - fn_instance = (...values) -> - if not vargs and values.length != binds.length - runtime-error "function expected #{binds.length} parameters, - got #{values.length}" - else if vargs and values.length < binds.length - runtime-error "function expected at least - #{binds.length} parameters, - got #{values.length}" - - # Set binds to values in the new env. - fn_env = new Env env - - for [name, value] in (zip binds, values) - fn_env.set name, value - - if vargs - fn_env.set vargs, do - type: \list - value: values.slice binds.length - - # Defer evaluation of the function body to TCO. - defer-tco fn_env, body - - {type: \function, value: fn_instance} - - -eval_apply = (env, list) -> - [fn, ...args] = list |> map eval_ast env - if fn.type != \function - runtime-error "#{fn.value} is not a function, got a #{fn.type}" - - fn.value.apply env, args - - -repl_env = new Env -for symbol, value of ns - repl_env.set symbol, value - - -rep = (line) -> - line - |> read_str - |> eval_ast repl_env - |> (ast) -> pr_str ast, print_readably=true - - -# Define not. -rep '(def! not (fn* (x) (if x false true)))' - -loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch error - if error.message - then console.error error.message - else console.error "Error:", pr_str error, print_readably=true +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, {type, value}: ast) --> + loop + if type != \list + return eval_simple env, ast + else if value.length == 0 + return ast + + result = if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + if result.type == \tco + env = result.env + {type, value}: ast = result.ast + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, do + type: \list + value: values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function, got a #{fn.type}" + + fn.value.apply env, args + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define not. +rep '(def! not (fn* (x) (if x false true)))' + +loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/impls/livescript/step6_file.ls b/impls/livescript/step6_file.ls index fac53c29d9..ae3c3615ba 100644 --- a/impls/livescript/step6_file.ls +++ b/impls/livescript/step6_file.ls @@ -1,247 +1,247 @@ -readline = require './node_readline' -{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' -{read_str} = require './reader' -{pr_str} = require './printer' -{Env} = require './env' -{runtime-error, ns} = require './core' -{list-to-pairs} = require './utils' - - -defer-tco = (env, ast) -> - type: \tco - env: env - ast: ast - eval: -> eval_ast env, ast - - -is-thruthy = ({type, value}) -> - type != \const or value not in [\nil \false] - - -fmap-ast = (fn, {type, value}: ast) --> - {type: type, value: fn value} - - -eval_simple = (env, {type, value}: ast) -> - switch type - | \symbol => env.get value - | \list, \vector => ast |> fmap-ast map eval_ast env - | \map => ast |> fmap-ast Obj.map eval_ast env - | otherwise => ast - - -eval_ast = (env, {type, value}: ast) --> - loop - if type != \list - return eval_simple env, ast - else if value.length == 0 - return ast - - result = if value[0].type == \symbol - params = value[1 to] - switch value[0].value - | 'def!' => eval_def env, params - | 'let*' => eval_let env, params - | 'do' => eval_do env, params - | 'if' => eval_if env, params - | 'fn*' => eval_fn env, params - | otherwise => eval_apply env, value - else - eval_apply env, value - - if result.type == \tco - env = result.env - {type, value}: ast = result.ast - else - return result - - -check_params = (name, params, expected) -> - if params.length != expected - runtime-error "'#{name}' expected #{expected} parameters, - got #{params.length}" - - -eval_def = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of def!, got a #{name.type}" - - # Evaluate the second parameter and store - # it under name in the env. - env.set name.value, (eval_ast env, params[1]) - - -eval_let = (env, params) -> - check_params 'let*', params, 2 - - binding_list = params[0] - if binding_list.type not in [\list \vector] - runtime-error "expected 1st parameter of 'let*' to - be a binding list (or vector), - got a #{binding_list.type}" - else if binding_list.value.length % 2 != 0 - runtime-error "binding list of 'let*' must have an even - number of parameters" - - # Make a new environment with the - # current environment as outer. - let_env = new Env env - - # Evaluate all binding values in the - # new environment. - binding_list.value - |> list-to-pairs - |> each ([binding_name, binding_value]) -> - if binding_name.type != \symbol - runtime-error "expected a symbol as binding name, - got a #{binding_name.type}" - - let_env.set binding_name.value, (eval_ast let_env, binding_value) - - # Defer evaluation of let* body with TCO. - defer-tco let_env, params[1] - - -eval_do = (env, params) -> - if params.length == 0 - runtime-error "'do' expected at least one parameter" - - [...rest, last-param] = params - rest |> each eval_ast env - defer-tco env, last-param - - -eval_if = (env, params) -> - if params.length < 2 - runtime-error "'if' expected at least 2 parameters" - else if params.length > 3 - runtime-error "'if' expected at most 3 parameters" - - cond = eval_ast env, params[0] - if is-thruthy cond - defer-tco env, params[1] - else if params.length > 2 - defer-tco env, params[2] - else - {type: \const, value: \nil} - - -eval_fn = (env, params) -> - check_params 'fn*', params, 2 - - if params[0].type not in [\list \vector] - runtime-error "'fn*' expected first parameter to be a list or vector." - - if not all (.type == \symbol), params[0].value - runtime-error "'fn*' expected only symbols in the parameters list." - - binds = params[0].value |> map (.value) - vargs = null - - # Parse variadic bind. - if binds.length >= 2 - [...rest, amper, name] = binds - if amper == '&' and name != '&' - binds = rest - vargs = name - - if elem-index '&', binds - runtime-error "'fn*' invalid usage of variadic parameters." - - if (unique binds).length != binds.length - runtime-error "'fn*' duplicate symbols in parameters list." - - body = params[1] - - fn_instance = (...values) -> - if not vargs and values.length != binds.length - runtime-error "function expected #{binds.length} parameters, - got #{values.length}" - else if vargs and values.length < binds.length - runtime-error "function expected at least - #{binds.length} parameters, - got #{values.length}" - - # Set binds to values in the new env. - fn_env = new Env env - - for [name, value] in (zip binds, values) - fn_env.set name, value - - if vargs - fn_env.set vargs, do - type: \list - value: values.slice binds.length - - # Defer evaluation of the function body to TCO. - defer-tco fn_env, body - - {type: \function, value: fn_instance} - - -eval_apply = (env, list) -> - [fn, ...args] = list |> map eval_ast env - if fn.type != \function - runtime-error "#{fn.value} is not a function, got a #{fn.type}" - - fn.value.apply env, args - - -repl_env = new Env -for symbol, value of ns - repl_env.set symbol, value - -# Evil eval. -repl_env.set 'eval', do - type: \function - value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). - - -rep = (line) -> - line - |> read_str - |> eval_ast repl_env - |> (ast) -> pr_str ast, print_readably=true - - -# Define not. -rep '(def! not (fn* (x) (if x false true)))' - -# Define load-file. -rep ' -(def! load-file - (fn* (f) - (eval - (read-string - (str "(do " (slurp f) "\nnil)")))))' - -# Parse program arguments. -# The first two (exe and core-file) are, respectively, -# the interpreter executable (nodejs or lsc) and the -# source file being executed (stepX_*.(ls|js)). -[exe, core-file, mal-file, ...argv] = process.argv - -repl_env.set '*ARGV*', do - type: \list - value: argv |> map (arg) -> - type: \string - value: arg - -if mal-file - rep "(load-file \"#{mal-file}\")" -else - # REPL. - loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch error - if error.message - then console.error error.message - else console.error "Error:", pr_str error, print_readably=true +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, {type, value}: ast) --> + loop + if type != \list + return eval_simple env, ast + else if value.length == 0 + return ast + + result = if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + if result.type == \tco + env = result.env + {type, value}: ast = result.ast + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, do + type: \list + value: values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function, got a #{fn.type}" + + fn.value.apply env, args + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define not. +rep '(def! not (fn* (x) (if x false true)))' + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) "\nnil)")))))' + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/impls/livescript/step7_quote.ls b/impls/livescript/step7_quote.ls index 9b83bb47c0..e00978231d 100644 --- a/impls/livescript/step7_quote.ls +++ b/impls/livescript/step7_quote.ls @@ -1,310 +1,310 @@ -readline = require './node_readline' -{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' -{read_str} = require './reader' -{pr_str} = require './printer' -{Env} = require './env' -{runtime-error, ns} = require './core' -{list-to-pairs} = require './utils' - - -defer-tco = (env, ast) -> - type: \tco - env: env - ast: ast - eval: -> eval_ast env, ast - - -is-thruthy = ({type, value}) -> - type != \const or value not in [\nil \false] - - -fmap-ast = (fn, {type, value}: ast) --> - {type: type, value: fn value} - - -make-symbol = (name) -> {type: \symbol, value: name} -make-list = (value) -> {type: \list, value: value} -make-call = (name, params) -> make-list [make-symbol name] ++ params -is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name - - -eval_simple = (env, {type, value}: ast) -> - switch type - | \symbol => env.get value - | \list, \vector => ast |> fmap-ast map eval_ast env - | \map => ast |> fmap-ast Obj.map eval_ast env - | otherwise => ast - - -eval_ast = (env, {type, value}: ast) --> - loop - if type != \list - return eval_simple env, ast - else if value.length == 0 - return ast - - result = if value[0].type == \symbol - params = value[1 to] - switch value[0].value - | 'def!' => eval_def env, params - | 'let*' => eval_let env, params - | 'do' => eval_do env, params - | 'if' => eval_if env, params - | 'fn*' => eval_fn env, params - | 'quote' => eval_quote env, params - | 'quasiquoteexpand' => eval_quasiquoteexpand params - | 'quasiquote' => eval_quasiquote env, params - | otherwise => eval_apply env, value - else - eval_apply env, value - - if result.type == \tco - env = result.env - {type, value}: ast = result.ast - else - return result - - -check_params = (name, params, expected) -> - if params.length != expected - runtime-error "'#{name}' expected #{expected} parameters, - got #{params.length}" - - -eval_def = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of def!, got a #{name.type}" - - # Evaluate the second parameter and store - # it under name in the env. - env.set name.value, (eval_ast env, params[1]) - - -eval_let = (env, params) -> - check_params 'let*', params, 2 - - binding_list = params[0] - if binding_list.type not in [\list \vector] - runtime-error "expected 1st parameter of 'let*' to - be a binding list (or vector), - got a #{binding_list.type}" - else if binding_list.value.length % 2 != 0 - runtime-error "binding list of 'let*' must have an even - number of parameters" - - # Make a new environment with the - # current environment as outer. - let_env = new Env env - - # Evaluate all binding values in the - # new environment. - binding_list.value - |> list-to-pairs - |> each ([binding_name, binding_value]) -> - if binding_name.type != \symbol - runtime-error "expected a symbol as binding name, - got a #{binding_name.type}" - - let_env.set binding_name.value, (eval_ast let_env, binding_value) - - # Defer evaluation of let* body with TCO. - defer-tco let_env, params[1] - - -eval_do = (env, params) -> - if params.length == 0 - runtime-error "'do' expected at least one parameter" - - [...rest, last-param] = params - rest |> each eval_ast env - defer-tco env, last-param - - -eval_if = (env, params) -> - if params.length < 2 - runtime-error "'if' expected at least 2 parameters" - else if params.length > 3 - runtime-error "'if' expected at most 3 parameters" - - cond = eval_ast env, params[0] - if is-thruthy cond - defer-tco env, params[1] - else if params.length > 2 - defer-tco env, params[2] - else - {type: \const, value: \nil} - - -eval_fn = (env, params) -> - check_params 'fn*', params, 2 - - if params[0].type not in [\list \vector] - runtime-error "'fn*' expected first parameter to be a list or vector." - - if not all (.type == \symbol), params[0].value - runtime-error "'fn*' expected only symbols in the parameters list." - - binds = params[0].value |> map (.value) - vargs = null - - # Parse variadic bind. - if binds.length >= 2 - [...rest, amper, name] = binds - if amper == '&' and name != '&' - binds = rest - vargs = name - - if elem-index '&', binds - runtime-error "'fn*' invalid usage of variadic parameters." - - if (unique binds).length != binds.length - runtime-error "'fn*' duplicate symbols in parameters list." - - body = params[1] - - fn_instance = (...values) -> - if not vargs and values.length != binds.length - runtime-error "function expected #{binds.length} parameters, - got #{values.length}" - else if vargs and values.length < binds.length - runtime-error "function expected at least - #{binds.length} parameters, - got #{values.length}" - - # Set binds to values in the new env. - fn_env = new Env env - - for [name, value] in (zip binds, values) - fn_env.set name, value - - if vargs - fn_env.set vargs, - make-list values.slice binds.length - - # Defer evaluation of the function body to TCO. - defer-tco fn_env, body - - {type: \function, value: fn_instance} - - -eval_apply = (env, list) -> - [fn, ...args] = list |> map eval_ast env - if fn.type != \function - runtime-error "#{fn.value} is not a function, got a #{fn.type}" - - fn.value.apply env, args - - -eval_quote = (env, params) -> - if params.length != 1 - runtime-error "quote expected 1 parameter, got #{params.length}" - - params[0] - - -eval_quasiquoteexpand = (params) -> - if params.length != 1 - runtime-error "quasiquote expected 1 parameter, got #{params.length}" - - ast = params[0] - quasiquote ast - - -quasiquote = (ast) -> - if ast.type in [\symbol, \map] - make-call 'quote', [ast] - else if ast.type == \vector - make-call 'vec', [qq_foldr ast.value] - else if ast.type != \list - ast - else if (ast.value.length == 2) and is-symbol ast.value[0], 'unquote' - ast.value[1] - else - qq_foldr ast.value - - -qq_foldr = (xs) -> - result = make-list [] - for i from xs.length - 1 to 0 by -1 - result := qq_loop xs[i], result - result - - -qq_loop = (elt, acc) -> - if elt.type == \list and \ - elt.value.length == 2 and \ - is-symbol elt.value[0], 'splice-unquote' - make-call 'concat', [ - elt.value[1] - acc - ] - else - make-call 'cons', [ - quasiquote elt - acc - ] - - -eval_quasiquote = (env, params) -> - new-ast = eval_quasiquoteexpand params - defer-tco env, new-ast - - -repl_env = new Env -for symbol, value of ns - repl_env.set symbol, value - -# Evil eval. -repl_env.set 'eval', do - type: \function - value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). - - -rep = (line) -> - line - |> read_str - |> eval_ast repl_env - |> (ast) -> pr_str ast, print_readably=true - - -# Define not. -rep '(def! not (fn* (x) (if x false true)))' - -# Define load-file. -rep ' -(def! load-file - (fn* (f) - (eval - (read-string - (str "(do " (slurp f) "\nnil)")))))' - -# Parse program arguments. -# The first two (exe and core-file) are, respectively, -# the interpreter executable (nodejs or lsc) and the -# source file being executed (stepX_*.(ls|js)). -[exe, core-file, mal-file, ...argv] = process.argv - -repl_env.set '*ARGV*', do - type: \list - value: argv |> map (arg) -> - type: \string - value: arg - -if mal-file - rep "(load-file \"#{mal-file}\")" -else - # REPL. - loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch error - if error.message - then console.error error.message - else console.error "Error:", pr_str error, print_readably=true +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +make-symbol = (name) -> {type: \symbol, value: name} +make-list = (value) -> {type: \list, value: value} +make-call = (name, params) -> make-list [make-symbol name] ++ params +is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, {type, value}: ast) --> + loop + if type != \list + return eval_simple env, ast + else if value.length == 0 + return ast + + result = if value[0].type == \symbol + params = value[1 to] + switch value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | 'quote' => eval_quote env, params + | 'quasiquoteexpand' => eval_quasiquoteexpand params + | 'quasiquote' => eval_quasiquote env, params + | otherwise => eval_apply env, value + else + eval_apply env, value + + if result.type == \tco + env = result.env + {type, value}: ast = result.ast + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, + make-list values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function, got a #{fn.type}" + + fn.value.apply env, args + + +eval_quote = (env, params) -> + if params.length != 1 + runtime-error "quote expected 1 parameter, got #{params.length}" + + params[0] + + +eval_quasiquoteexpand = (params) -> + if params.length != 1 + runtime-error "quasiquote expected 1 parameter, got #{params.length}" + + ast = params[0] + quasiquote ast + + +quasiquote = (ast) -> + if ast.type in [\symbol, \map] + make-call 'quote', [ast] + else if ast.type == \vector + make-call 'vec', [qq_foldr ast.value] + else if ast.type != \list + ast + else if (ast.value.length == 2) and is-symbol ast.value[0], 'unquote' + ast.value[1] + else + qq_foldr ast.value + + +qq_foldr = (xs) -> + result = make-list [] + for i from xs.length - 1 to 0 by -1 + result := qq_loop xs[i], result + result + + +qq_loop = (elt, acc) -> + if elt.type == \list and \ + elt.value.length == 2 and \ + is-symbol elt.value[0], 'splice-unquote' + make-call 'concat', [ + elt.value[1] + acc + ] + else + make-call 'cons', [ + quasiquote elt + acc + ] + + +eval_quasiquote = (env, params) -> + new-ast = eval_quasiquoteexpand params + defer-tco env, new-ast + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + + +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define not. +rep '(def! not (fn* (x) (if x false true)))' + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) "\nnil)")))))' + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/impls/livescript/step8_macros.ls b/impls/livescript/step8_macros.ls index 337e678cd5..4a14d7f6eb 100644 --- a/impls/livescript/step8_macros.ls +++ b/impls/livescript/step8_macros.ls @@ -1,371 +1,371 @@ -readline = require './node_readline' -{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' -{read_str} = require './reader' -{pr_str} = require './printer' -{Env} = require './env' -{runtime-error, ns, unpack-tco} = require './core' -{list-to-pairs} = require './utils' - - -defer-tco = (env, ast) -> - type: \tco - env: env - ast: ast - eval: -> eval_ast env, ast - - -is-thruthy = ({type, value}) -> - type != \const or value not in [\nil \false] - - -fmap-ast = (fn, {type, value}: ast) --> - {type: type, value: fn value} - - -make-symbol = (name) -> {type: \symbol, value: name} -make-list = (value) -> {type: \list, value: value} -make-call = (name, params) -> make-list [make-symbol name] ++ params -is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name - - -eval_simple = (env, {type, value}: ast) -> - switch type - | \symbol => env.get value - | \list, \vector => ast |> fmap-ast map eval_ast env - | \map => ast |> fmap-ast Obj.map eval_ast env - | otherwise => ast - - -eval_ast = (env, ast) --> - loop - if ast.type != \list - return eval_simple env, ast - - ast = macroexpand env, ast - if ast.type != \list - return eval_simple env, ast - else if ast.value.length == 0 - return ast - - result = if ast.value[0].type == \symbol - params = ast.value[1 to] - switch ast.value[0].value - | 'def!' => eval_def env, params - | 'let*' => eval_let env, params - | 'do' => eval_do env, params - | 'if' => eval_if env, params - | 'fn*' => eval_fn env, params - | 'quote' => eval_quote env, params - | 'quasiquoteexpand' => eval_quasiquoteexpand params - | 'quasiquote' => eval_quasiquote env, params - | 'defmacro!' => eval_defmacro env, params - | 'macroexpand' => eval_macroexpand env, params - | otherwise => eval_apply env, ast.value - else - eval_apply env, ast.value - - if result.type == \tco - {env, ast} = result - else - return result - - -check_params = (name, params, expected) -> - if params.length != expected - runtime-error "'#{name}' expected #{expected} parameters, - got #{params.length}" - - -eval_def = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of def!, got a #{name.type}" - - # Evaluate the second parameter and store - # it under name in the env. - env.set name.value, (eval_ast env, params[1]) - - -eval_let = (env, params) -> - check_params 'let*', params, 2 - - binding_list = params[0] - if binding_list.type not in [\list \vector] - runtime-error "expected 1st parameter of 'let*' to - be a binding list (or vector), - got a #{binding_list.type}" - else if binding_list.value.length % 2 != 0 - runtime-error "binding list of 'let*' must have an even - number of parameters" - - # Make a new environment with the - # current environment as outer. - let_env = new Env env - - # Evaluate all binding values in the - # new environment. - binding_list.value - |> list-to-pairs - |> each ([binding_name, binding_value]) -> - if binding_name.type != \symbol - runtime-error "expected a symbol as binding name, - got a #{binding_name.type}" - - let_env.set binding_name.value, (eval_ast let_env, binding_value) - - # Defer evaluation of let* body with TCO. - defer-tco let_env, params[1] - - -eval_do = (env, params) -> - if params.length == 0 - runtime-error "'do' expected at least one parameter" - - [...rest, last-param] = params - rest |> each eval_ast env - defer-tco env, last-param - - -eval_if = (env, params) -> - if params.length < 2 - runtime-error "'if' expected at least 2 parameters" - else if params.length > 3 - runtime-error "'if' expected at most 3 parameters" - - cond = eval_ast env, params[0] - if is-thruthy cond - defer-tco env, params[1] - else if params.length > 2 - defer-tco env, params[2] - else - {type: \const, value: \nil} - - -eval_fn = (env, params) -> - check_params 'fn*', params, 2 - - if params[0].type not in [\list \vector] - runtime-error "'fn*' expected first parameter to be a list or vector." - - if not all (.type == \symbol), params[0].value - runtime-error "'fn*' expected only symbols in the parameters list." - - binds = params[0].value |> map (.value) - vargs = null - - # Parse variadic bind. - if binds.length >= 2 - [...rest, amper, name] = binds - if amper == '&' and name != '&' - binds = rest - vargs = name - - if elem-index '&', binds - runtime-error "'fn*' invalid usage of variadic parameters." - - if (unique binds).length != binds.length - runtime-error "'fn*' duplicate symbols in parameters list." - - body = params[1] - - fn_instance = (...values) -> - if not vargs and values.length != binds.length - runtime-error "function expected #{binds.length} parameters, - got #{values.length}" - else if vargs and values.length < binds.length - runtime-error "function expected at least - #{binds.length} parameters, - got #{values.length}" - - # Set binds to values in the new env. - fn_env = new Env env - - for [name, value] in (zip binds, values) - fn_env.set name, value - - if vargs - fn_env.set vargs, - make-list values.slice binds.length - - # Defer evaluation of the function body to TCO. - defer-tco fn_env, body - - {type: \function, value: fn_instance, is_macro: false} - - -eval_apply = (env, list) -> - [fn, ...args] = list |> map eval_ast env - if fn.type != \function - runtime-error "#{fn.value} is not a function, got a #{fn.type}" - - fn.value.apply env, args - - -eval_quote = (env, params) -> - if params.length != 1 - runtime-error "quote expected 1 parameter, got #{params.length}" - - params[0] - - -eval_quasiquoteexpand = (params) -> - if params.length != 1 - runtime-error "quasiquote expected 1 parameter, got #{params.length}" - - ast = params[0] - quasiquote ast - - -quasiquote = (ast) -> - if ast.type in [\symbol, \map] - make-call 'quote', [ast] - else if ast.type == \vector - make-call 'vec', [qq_foldr ast.value] - else if ast.type != \list - ast - else if (ast.value.length == 2) and is-symbol ast.value[0], 'unquote' - ast.value[1] - else - qq_foldr ast.value - - -qq_foldr = (xs) -> - result = make-list [] - for i from xs.length - 1 to 0 by -1 - result := qq_loop xs[i], result - result - - -qq_loop = (elt, acc) -> - if elt.type == \list and \ - elt.value.length == 2 and \ - is-symbol elt.value[0], 'splice-unquote' - make-call 'concat', [ - elt.value[1] - acc - ] - else - make-call 'cons', [ - quasiquote elt - acc - ] - - -eval_quasiquote = (env, params) -> - new-ast = eval_quasiquoteexpand params - defer-tco env, new-ast - - -eval_defmacro = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of defmacro!, got a #{name.type}" - - # Evaluate the second parameter. - fn = eval_ast env, params[1] - if fn.type != \function - runtime-error "expected a function for the second parameter - of defmacro!, got a #{fn.type}" - - # Copy fn and mark the function as a macro. - macro_fn = fn with is_macro: true - env.set name.value, macro_fn - - -get-macro-fn = (env, ast) -> - if ast.type == \list and - ast.value.length != 0 and - ast.value[0].type == \symbol - fn = env.try-get ast.value[0].value - if fn and fn.type == \function and fn.is_macro - then fn - - -macroexpand = (env, ast) -> - loop # until ast is not a macro function call. - macro_fn = get-macro-fn env, ast - if not macro_fn then return ast - ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] - - -eval_macroexpand = (env, params) -> - if params.length != 1 - runtime-error "'macroexpand' expected 1 parameter, - got #{params.length}" - - macroexpand env, params[0] - - -repl_env = new Env -for symbol, value of ns - repl_env.set symbol, value - -# Evil eval. -repl_env.set 'eval', do - type: \function - value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). - -# Read, Evaluate, Print -rep = (line) -> - line - |> read_str - |> eval_ast repl_env - |> (ast) -> pr_str ast, print_readably=true - - -# Define not. -rep '(def! not (fn* (x) (if x false true)))' - -# Define load-file. -rep ' -(def! load-file - (fn* (f) - (eval - (read-string - (str "(do " (slurp f) "\nnil)")))))' - -# Define cond. -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)))))))' - -# Parse program arguments. -# The first two (exe and core-file) are, respectively, -# the interpreter executable (nodejs or lsc) and the -# source file being executed (stepX_*.(ls|js)). -[exe, core-file, mal-file, ...argv] = process.argv - -repl_env.set '*ARGV*', do - type: \list - value: argv |> map (arg) -> - type: \string - value: arg - - -if mal-file - rep "(load-file \"#{mal-file}\")" -else - # REPL. - loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch error - if error.message - then console.error error.message - else console.error "Error:", pr_str error, print_readably=true +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns, unpack-tco} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +make-symbol = (name) -> {type: \symbol, value: name} +make-list = (value) -> {type: \list, value: value} +make-call = (name, params) -> make-list [make-symbol name] ++ params +is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, ast) --> + loop + if ast.type != \list + return eval_simple env, ast + + ast = macroexpand env, ast + if ast.type != \list + return eval_simple env, ast + else if ast.value.length == 0 + return ast + + result = if ast.value[0].type == \symbol + params = ast.value[1 to] + switch ast.value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | 'quote' => eval_quote env, params + | 'quasiquoteexpand' => eval_quasiquoteexpand params + | 'quasiquote' => eval_quasiquote env, params + | 'defmacro!' => eval_defmacro env, params + | 'macroexpand' => eval_macroexpand env, params + | otherwise => eval_apply env, ast.value + else + eval_apply env, ast.value + + if result.type == \tco + {env, ast} = result + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, + make-list values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance, is_macro: false} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function, got a #{fn.type}" + + fn.value.apply env, args + + +eval_quote = (env, params) -> + if params.length != 1 + runtime-error "quote expected 1 parameter, got #{params.length}" + + params[0] + + +eval_quasiquoteexpand = (params) -> + if params.length != 1 + runtime-error "quasiquote expected 1 parameter, got #{params.length}" + + ast = params[0] + quasiquote ast + + +quasiquote = (ast) -> + if ast.type in [\symbol, \map] + make-call 'quote', [ast] + else if ast.type == \vector + make-call 'vec', [qq_foldr ast.value] + else if ast.type != \list + ast + else if (ast.value.length == 2) and is-symbol ast.value[0], 'unquote' + ast.value[1] + else + qq_foldr ast.value + + +qq_foldr = (xs) -> + result = make-list [] + for i from xs.length - 1 to 0 by -1 + result := qq_loop xs[i], result + result + + +qq_loop = (elt, acc) -> + if elt.type == \list and \ + elt.value.length == 2 and \ + is-symbol elt.value[0], 'splice-unquote' + make-call 'concat', [ + elt.value[1] + acc + ] + else + make-call 'cons', [ + quasiquote elt + acc + ] + + +eval_quasiquote = (env, params) -> + new-ast = eval_quasiquoteexpand params + defer-tco env, new-ast + + +eval_defmacro = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of defmacro!, got a #{name.type}" + + # Evaluate the second parameter. + fn = eval_ast env, params[1] + if fn.type != \function + runtime-error "expected a function for the second parameter + of defmacro!, got a #{fn.type}" + + # Copy fn and mark the function as a macro. + macro_fn = fn with is_macro: true + env.set name.value, macro_fn + + +get-macro-fn = (env, ast) -> + if ast.type == \list and + ast.value.length != 0 and + ast.value[0].type == \symbol + fn = env.try-get ast.value[0].value + if fn and fn.type == \function and fn.is_macro + then fn + + +macroexpand = (env, ast) -> + loop # until ast is not a macro function call. + macro_fn = get-macro-fn env, ast + if not macro_fn then return ast + ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] + + +eval_macroexpand = (env, params) -> + if params.length != 1 + runtime-error "'macroexpand' expected 1 parameter, + got #{params.length}" + + macroexpand env, params[0] + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + +# Read, Evaluate, Print +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define not. +rep '(def! not (fn* (x) (if x false true)))' + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) "\nnil)")))))' + +# Define cond. +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)))))))' + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/impls/livescript/step9_try.ls b/impls/livescript/step9_try.ls index 7945a17884..24c26456b5 100644 --- a/impls/livescript/step9_try.ls +++ b/impls/livescript/step9_try.ls @@ -1,402 +1,402 @@ -readline = require './node_readline' -{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' -{read_str} = require './reader' -{pr_str} = require './printer' -{Env} = require './env' -{runtime-error, ns, unpack-tco} = require './core' -{list-to-pairs} = require './utils' - - -defer-tco = (env, ast) -> - type: \tco - env: env - ast: ast - eval: -> eval_ast env, ast - - -is-thruthy = ({type, value}) -> - type != \const or value not in [\nil \false] - - -fmap-ast = (fn, {type, value}: ast) --> - {type: type, value: fn value} - - -make-symbol = (name) -> {type: \symbol, value: name} -make-list = (value) -> {type: \list, value: value} -make-call = (name, params) -> make-list [make-symbol name] ++ params -is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name - - -eval_simple = (env, {type, value}: ast) -> - switch type - | \symbol => env.get value - | \list, \vector => ast |> fmap-ast map eval_ast env - | \map => ast |> fmap-ast Obj.map eval_ast env - | otherwise => ast - - -eval_ast = (env, ast) --> - loop - if ast.type != \list - return eval_simple env, ast - - ast = macroexpand env, ast - if ast.type != \list - return eval_simple env, ast - else if ast.value.length == 0 - return ast - - result = if ast.value[0].type == \symbol - params = ast.value[1 to] - switch ast.value[0].value - | 'def!' => eval_def env, params - | 'let*' => eval_let env, params - | 'do' => eval_do env, params - | 'if' => eval_if env, params - | 'fn*' => eval_fn env, params - | 'quote' => eval_quote env, params - | 'quasiquoteexpand' => eval_quasiquoteexpand params - | 'quasiquote' => eval_quasiquote env, params - | 'defmacro!' => eval_defmacro env, params - | 'macroexpand' => eval_macroexpand env, params - | 'try*' => eval_try env, params - | otherwise => eval_apply env, ast.value - else - eval_apply env, ast.value - - if result.type == \tco - {env, ast} = result - else - return result - - -check_params = (name, params, expected) -> - if params.length != expected - runtime-error "'#{name}' expected #{expected} parameters, - got #{params.length}" - - -eval_def = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of def!, got a #{name.type}" - - # Evaluate the second parameter and store - # it under name in the env. - env.set name.value, (eval_ast env, params[1]) - - -eval_let = (env, params) -> - check_params 'let*', params, 2 - - binding_list = params[0] - if binding_list.type not in [\list \vector] - runtime-error "expected 1st parameter of 'let*' to - be a binding list (or vector), - got a #{binding_list.type}" - else if binding_list.value.length % 2 != 0 - runtime-error "binding list of 'let*' must have an even - number of parameters" - - # Make a new environment with the - # current environment as outer. - let_env = new Env env - - # Evaluate all binding values in the - # new environment. - binding_list.value - |> list-to-pairs - |> each ([binding_name, binding_value]) -> - if binding_name.type != \symbol - runtime-error "expected a symbol as binding name, - got a #{binding_name.type}" - - let_env.set binding_name.value, (eval_ast let_env, binding_value) - - # Defer evaluation of let* body with TCO. - defer-tco let_env, params[1] - - -eval_do = (env, params) -> - if params.length == 0 - runtime-error "'do' expected at least one parameter" - - [...rest, last-param] = params - rest |> each eval_ast env - defer-tco env, last-param - - -eval_if = (env, params) -> - if params.length < 2 - runtime-error "'if' expected at least 2 parameters" - else if params.length > 3 - runtime-error "'if' expected at most 3 parameters" - - cond = eval_ast env, params[0] - if is-thruthy cond - defer-tco env, params[1] - else if params.length > 2 - defer-tco env, params[2] - else - {type: \const, value: \nil} - - -eval_fn = (env, params) -> - check_params 'fn*', params, 2 - - if params[0].type not in [\list \vector] - runtime-error "'fn*' expected first parameter to be a list or vector." - - if not all (.type == \symbol), params[0].value - runtime-error "'fn*' expected only symbols in the parameters list." - - binds = params[0].value |> map (.value) - vargs = null - - # Parse variadic bind. - if binds.length >= 2 - [...rest, amper, name] = binds - if amper == '&' and name != '&' - binds = rest - vargs = name - - if elem-index '&', binds - runtime-error "'fn*' invalid usage of variadic parameters." - - if (unique binds).length != binds.length - runtime-error "'fn*' duplicate symbols in parameters list." - - body = params[1] - - fn_instance = (...values) -> - if not vargs and values.length != binds.length - runtime-error "function expected #{binds.length} parameters, - got #{values.length}" - else if vargs and values.length < binds.length - runtime-error "function expected at least - #{binds.length} parameters, - got #{values.length}" - - # Set binds to values in the new env. - fn_env = new Env env - - for [name, value] in (zip binds, values) - fn_env.set name, value - - if vargs - fn_env.set vargs, - make-list values.slice binds.length - - # Defer evaluation of the function body to TCO. - defer-tco fn_env, body - - {type: \function, value: fn_instance, is_macro: false} - - -eval_apply = (env, list) -> - [fn, ...args] = list |> map eval_ast env - if fn.type != \function - runtime-error "#{fn.value} is not a function, got a #{fn.type}" - - fn.value.apply env, args - - -eval_quote = (env, params) -> - if params.length != 1 - runtime-error "quote expected 1 parameter, got #{params.length}" - - params[0] - - -eval_quasiquoteexpand = (params) -> - if params.length != 1 - runtime-error "quasiquote expected 1 parameter, got #{params.length}" - - ast = params[0] - quasiquote ast - - -quasiquote = (ast) -> - if ast.type in [\symbol, \map] - make-call 'quote', [ast] - else if ast.type == \vector - make-call 'vec', [qq_foldr ast.value] - else if ast.type != \list - ast - else if (ast.value.length == 2) and is-symbol ast.value[0], 'unquote' - ast.value[1] - else - qq_foldr ast.value - - -qq_foldr = (xs) -> - result = make-list [] - for i from xs.length - 1 to 0 by -1 - result := qq_loop xs[i], result - result - - -qq_loop = (elt, acc) -> - if elt.type == \list and \ - elt.value.length == 2 and \ - is-symbol elt.value[0], 'splice-unquote' - make-call 'concat', [ - elt.value[1] - acc - ] - else - make-call 'cons', [ - quasiquote elt - acc - ] - - -eval_quasiquote = (env, params) -> - new-ast = eval_quasiquoteexpand params - defer-tco env, new-ast - - -eval_defmacro = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of defmacro!, got a #{name.type}" - - # Evaluate the second parameter. - fn = eval_ast env, params[1] - if fn.type != \function - runtime-error "expected a function for the second parameter - of defmacro!, got a #{fn.type}" - - # Copy fn and mark the function as a macro. - macro_fn = fn with is_macro: true - env.set name.value, macro_fn - - -get-macro-fn = (env, ast) -> - if ast.type == \list and - ast.value.length != 0 and - ast.value[0].type == \symbol - fn = env.try-get ast.value[0].value - if fn and fn.type == \function and fn.is_macro - then fn - - -macroexpand = (env, ast) -> - loop # until ast is not a macro function call. - macro_fn = get-macro-fn env, ast - if not macro_fn then return ast - ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] - - -eval_macroexpand = (env, params) -> - if params.length != 1 - runtime-error "'macroexpand' expected 1 parameter, - got #{params.length}" - - macroexpand env, params[0] - - -eval_try = (env, params) -> - if params.length > 2 - runtime-error "'try*' expected 1 or 2 parameters, - got #{params.length}" - try-form = params[0] - if params.length == 1 - return eval_ast env, try-form - - catch-clause = params[1] - if catch-clause.type != \list or - catch-clause.value.length != 3 or - not (is-symbol catch-clause.value[0], 'catch*') or - catch-clause.value[1].type != \symbol - runtime-error "'try*' expected the second parameter to be - of the form (catch* A B)" - - try - eval_ast env, try-form - catch error - error-symbol = catch-clause.value[1].value - error-value = \ - if error.message - then {type: \string, value: error.message} - else error - - catch-env = new Env env - catch-env.set error-symbol, error-value - eval_ast catch-env, catch-clause.value[2] - - -repl_env = new Env -for symbol, value of ns - repl_env.set symbol, value - -# Evil eval. -repl_env.set 'eval', do - type: \function - value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). - -# Read, Evaluate, Print -rep = (line) -> - line - |> read_str - |> eval_ast repl_env - |> (ast) -> pr_str ast, print_readably=true - - -# Define not. -rep '(def! not (fn* (x) (if x false true)))' - -# Define load-file. -rep ' -(def! load-file - (fn* (f) - (eval - (read-string - (str "(do " (slurp f) "\nnil)")))))' - -# Define cond. -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)))))))' - -# Parse program arguments. -# The first two (exe and core-file) are, respectively, -# the interpreter executable (nodejs or lsc) and the -# source file being executed (stepX_*.(ls|js)). -[exe, core-file, mal-file, ...argv] = process.argv - -repl_env.set '*ARGV*', do - type: \list - value: argv |> map (arg) -> - type: \string - value: arg - - -if mal-file - rep "(load-file \"#{mal-file}\")" -else - # REPL. - loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch error - if error.message - then console.error error.message - else console.error "Error:", pr_str error, print_readably=true +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns, unpack-tco} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +make-symbol = (name) -> {type: \symbol, value: name} +make-list = (value) -> {type: \list, value: value} +make-call = (name, params) -> make-list [make-symbol name] ++ params +is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, ast) --> + loop + if ast.type != \list + return eval_simple env, ast + + ast = macroexpand env, ast + if ast.type != \list + return eval_simple env, ast + else if ast.value.length == 0 + return ast + + result = if ast.value[0].type == \symbol + params = ast.value[1 to] + switch ast.value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | 'quote' => eval_quote env, params + | 'quasiquoteexpand' => eval_quasiquoteexpand params + | 'quasiquote' => eval_quasiquote env, params + | 'defmacro!' => eval_defmacro env, params + | 'macroexpand' => eval_macroexpand env, params + | 'try*' => eval_try env, params + | otherwise => eval_apply env, ast.value + else + eval_apply env, ast.value + + if result.type == \tco + {env, ast} = result + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, + make-list values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance, is_macro: false} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function, got a #{fn.type}" + + fn.value.apply env, args + + +eval_quote = (env, params) -> + if params.length != 1 + runtime-error "quote expected 1 parameter, got #{params.length}" + + params[0] + + +eval_quasiquoteexpand = (params) -> + if params.length != 1 + runtime-error "quasiquote expected 1 parameter, got #{params.length}" + + ast = params[0] + quasiquote ast + + +quasiquote = (ast) -> + if ast.type in [\symbol, \map] + make-call 'quote', [ast] + else if ast.type == \vector + make-call 'vec', [qq_foldr ast.value] + else if ast.type != \list + ast + else if (ast.value.length == 2) and is-symbol ast.value[0], 'unquote' + ast.value[1] + else + qq_foldr ast.value + + +qq_foldr = (xs) -> + result = make-list [] + for i from xs.length - 1 to 0 by -1 + result := qq_loop xs[i], result + result + + +qq_loop = (elt, acc) -> + if elt.type == \list and \ + elt.value.length == 2 and \ + is-symbol elt.value[0], 'splice-unquote' + make-call 'concat', [ + elt.value[1] + acc + ] + else + make-call 'cons', [ + quasiquote elt + acc + ] + + +eval_quasiquote = (env, params) -> + new-ast = eval_quasiquoteexpand params + defer-tco env, new-ast + + +eval_defmacro = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of defmacro!, got a #{name.type}" + + # Evaluate the second parameter. + fn = eval_ast env, params[1] + if fn.type != \function + runtime-error "expected a function for the second parameter + of defmacro!, got a #{fn.type}" + + # Copy fn and mark the function as a macro. + macro_fn = fn with is_macro: true + env.set name.value, macro_fn + + +get-macro-fn = (env, ast) -> + if ast.type == \list and + ast.value.length != 0 and + ast.value[0].type == \symbol + fn = env.try-get ast.value[0].value + if fn and fn.type == \function and fn.is_macro + then fn + + +macroexpand = (env, ast) -> + loop # until ast is not a macro function call. + macro_fn = get-macro-fn env, ast + if not macro_fn then return ast + ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] + + +eval_macroexpand = (env, params) -> + if params.length != 1 + runtime-error "'macroexpand' expected 1 parameter, + got #{params.length}" + + macroexpand env, params[0] + + +eval_try = (env, params) -> + if params.length > 2 + runtime-error "'try*' expected 1 or 2 parameters, + got #{params.length}" + try-form = params[0] + if params.length == 1 + return eval_ast env, try-form + + catch-clause = params[1] + if catch-clause.type != \list or + catch-clause.value.length != 3 or + not (is-symbol catch-clause.value[0], 'catch*') or + catch-clause.value[1].type != \symbol + runtime-error "'try*' expected the second parameter to be + of the form (catch* A B)" + + try + eval_ast env, try-form + catch error + error-symbol = catch-clause.value[1].value + error-value = \ + if error.message + then {type: \string, value: error.message} + else error + + catch-env = new Env env + catch-env.set error-symbol, error-value + eval_ast catch-env, catch-clause.value[2] + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + +# Read, Evaluate, Print +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define not. +rep '(def! not (fn* (x) (if x false true)))' + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) "\nnil)")))))' + +# Define cond. +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)))))))' + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/impls/livescript/stepA_mal.ls b/impls/livescript/stepA_mal.ls index 7ee72908f0..b9f86a2be8 100644 --- a/impls/livescript/stepA_mal.ls +++ b/impls/livescript/stepA_mal.ls @@ -1,406 +1,406 @@ -readline = require './node_readline' -{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' -{read_str} = require './reader' -{pr_str} = require './printer' -{Env} = require './env' -{runtime-error, ns, unpack-tco} = require './core' -{list-to-pairs} = require './utils' - - -defer-tco = (env, ast) -> - type: \tco - env: env - ast: ast - eval: -> eval_ast env, ast - - -is-thruthy = ({type, value}) -> - type != \const or value not in [\nil \false] - - -fmap-ast = (fn, {type, value}: ast) --> - {type: type, value: fn value} - - -make-symbol = (name) -> {type: \symbol, value: name} -make-list = (value) -> {type: \list, value: value} -make-call = (name, params) -> make-list [make-symbol name] ++ params -is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name - - -eval_simple = (env, {type, value}: ast) -> - switch type - | \symbol => env.get value - | \list, \vector => ast |> fmap-ast map eval_ast env - | \map => ast |> fmap-ast Obj.map eval_ast env - | otherwise => ast - - -eval_ast = (env, ast) --> - loop - if ast.type != \list - return eval_simple env, ast - - ast = macroexpand env, ast - if ast.type != \list - return eval_simple env, ast - else if ast.value.length == 0 - return ast - - result = if ast.value[0].type == \symbol - params = ast.value[1 to] - switch ast.value[0].value - | 'def!' => eval_def env, params - | 'let*' => eval_let env, params - | 'do' => eval_do env, params - | 'if' => eval_if env, params - | 'fn*' => eval_fn env, params - | 'quote' => eval_quote env, params - | 'quasiquoteexpand' => eval_quasiquoteexpand params - | 'quasiquote' => eval_quasiquote env, params - | 'defmacro!' => eval_defmacro env, params - | 'macroexpand' => eval_macroexpand env, params - | 'try*' => eval_try env, params - | otherwise => eval_apply env, ast.value - else - eval_apply env, ast.value - - if result.type == \tco - {env, ast} = result - else - return result - - -check_params = (name, params, expected) -> - if params.length != expected - runtime-error "'#{name}' expected #{expected} parameters, - got #{params.length}" - - -eval_def = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of def!, got a #{name.type}" - - # Evaluate the second parameter and store - # it under name in the env. - env.set name.value, (eval_ast env, params[1]) - - -eval_let = (env, params) -> - check_params 'let*', params, 2 - - binding_list = params[0] - if binding_list.type not in [\list \vector] - runtime-error "expected 1st parameter of 'let*' to - be a binding list (or vector), - got a #{binding_list.type}" - else if binding_list.value.length % 2 != 0 - runtime-error "binding list of 'let*' must have an even - number of parameters" - - # Make a new environment with the - # current environment as outer. - let_env = new Env env - - # Evaluate all binding values in the - # new environment. - binding_list.value - |> list-to-pairs - |> each ([binding_name, binding_value]) -> - if binding_name.type != \symbol - runtime-error "expected a symbol as binding name, - got a #{binding_name.type}" - - let_env.set binding_name.value, (eval_ast let_env, binding_value) - - # Defer evaluation of let* body with TCO. - defer-tco let_env, params[1] - - -eval_do = (env, params) -> - if params.length == 0 - runtime-error "'do' expected at least one parameter" - - [...rest, last-param] = params - rest |> each eval_ast env - defer-tco env, last-param - - -eval_if = (env, params) -> - if params.length < 2 - runtime-error "'if' expected at least 2 parameters" - else if params.length > 3 - runtime-error "'if' expected at most 3 parameters" - - cond = eval_ast env, params[0] - if is-thruthy cond - defer-tco env, params[1] - else if params.length > 2 - defer-tco env, params[2] - else - {type: \const, value: \nil} - - -eval_fn = (env, params) -> - check_params 'fn*', params, 2 - - if params[0].type not in [\list \vector] - runtime-error "'fn*' expected first parameter to be a list or vector." - - if not all (.type == \symbol), params[0].value - runtime-error "'fn*' expected only symbols in the parameters list." - - binds = params[0].value |> map (.value) - vargs = null - - # Parse variadic bind. - if binds.length >= 2 - [...rest, amper, name] = binds - if amper == '&' and name != '&' - binds = rest - vargs = name - - if elem-index '&', binds - runtime-error "'fn*' invalid usage of variadic parameters." - - if (unique binds).length != binds.length - runtime-error "'fn*' duplicate symbols in parameters list." - - body = params[1] - - fn_instance = (...values) -> - if not vargs and values.length != binds.length - runtime-error "function expected #{binds.length} parameters, - got #{values.length}" - else if vargs and values.length < binds.length - runtime-error "function expected at least - #{binds.length} parameters, - got #{values.length}" - - # Set binds to values in the new env. - fn_env = new Env env - - for [name, value] in (zip binds, values) - fn_env.set name, value - - if vargs - fn_env.set vargs, - make-list values.slice binds.length - - # Defer evaluation of the function body to TCO. - defer-tco fn_env, body - - {type: \function, value: fn_instance, is_macro: false} - - -eval_apply = (env, list) -> - [fn, ...args] = list |> map eval_ast env - if fn.type != \function - runtime-error "#{fn.value} is not a function, got a #{fn.type}" - - fn.value.apply env, args - - -eval_quote = (env, params) -> - if params.length != 1 - runtime-error "quote expected 1 parameter, got #{params.length}" - - params[0] - - -eval_quasiquoteexpand = (params) -> - if params.length != 1 - runtime-error "quasiquote expected 1 parameter, got #{params.length}" - - ast = params[0] - quasiquote ast - - -quasiquote = (ast) -> - if ast.type in [\symbol, \map] - make-call 'quote', [ast] - else if ast.type == \vector - make-call 'vec', [qq_foldr ast.value] - else if ast.type != \list - ast - else if (ast.value.length == 2) and is-symbol ast.value[0], 'unquote' - ast.value[1] - else - qq_foldr ast.value - - -qq_foldr = (xs) -> - result = make-list [] - for i from xs.length - 1 to 0 by -1 - result := qq_loop xs[i], result - result - - -qq_loop = (elt, acc) -> - if elt.type == \list and \ - elt.value.length == 2 and \ - is-symbol elt.value[0], 'splice-unquote' - make-call 'concat', [ - elt.value[1] - acc - ] - else - make-call 'cons', [ - quasiquote elt - acc - ] - - -eval_quasiquote = (env, params) -> - new-ast = eval_quasiquoteexpand params - defer-tco env, new-ast - - -eval_defmacro = (env, params) -> - check_params 'def!', params, 2 - - # Name is in the first parameter, and is not evaluated. - name = params[0] - if name.type != \symbol - runtime-error "expected a symbol for the first parameter - of defmacro!, got a #{name.type}" - - # Evaluate the second parameter. - fn = eval_ast env, params[1] - if fn.type != \function - runtime-error "expected a function for the second parameter - of defmacro!, got a #{fn.type}" - - # Copy fn and mark the function as a macro. - macro_fn = fn with is_macro: true - env.set name.value, macro_fn - - -get-macro-fn = (env, ast) -> - if ast.type == \list and - ast.value.length != 0 and - ast.value[0].type == \symbol - fn = env.try-get ast.value[0].value - if fn and fn.type == \function and fn.is_macro - then fn - - -macroexpand = (env, ast) -> - loop # until ast is not a macro function call. - macro_fn = get-macro-fn env, ast - if not macro_fn then return ast - ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] - - -eval_macroexpand = (env, params) -> - if params.length != 1 - runtime-error "'macroexpand' expected 1 parameter, - got #{params.length}" - - macroexpand env, params[0] - - -eval_try = (env, params) -> - if params.length > 2 - runtime-error "'try*' expected 1 or 2 parameters, - got #{params.length}" - try-form = params[0] - if params.length == 1 - return eval_ast env, try-form - - catch-clause = params[1] - if catch-clause.type != \list or - catch-clause.value.length != 3 or - not (is-symbol catch-clause.value[0], 'catch*') or - catch-clause.value[1].type != \symbol - runtime-error "'try*' expected the second parameter to be - of the form (catch* A B)" - - try - eval_ast env, try-form - catch error - error-symbol = catch-clause.value[1].value - error-value = \ - if error.message - then {type: \string, value: error.message} - else error - - catch-env = new Env env - catch-env.set error-symbol, error-value - eval_ast catch-env, catch-clause.value[2] - - -repl_env = new Env -for symbol, value of ns - repl_env.set symbol, value - -# Evil eval. -repl_env.set 'eval', do - type: \function - value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). - -# Read, Evaluate, Print -rep = (line) -> - line - |> read_str - |> eval_ast repl_env - |> (ast) -> pr_str ast, print_readably=true - - -# Define not. -rep '(def! not (fn* (x) (if x false true)))' - -# Define load-file. -rep ' -(def! load-file - (fn* (f) - (eval - (read-string - (str "(do " (slurp f) "\nnil)")))))' - -# Define cond. -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)))))))' - -# Parse program arguments. -# The first two (exe and core-file) are, respectively, -# the interpreter executable (nodejs or lsc) and the -# source file being executed (stepX_*.(ls|js)). -[exe, core-file, mal-file, ...argv] = process.argv - -repl_env.set '*ARGV*', do - type: \list - value: argv |> map (arg) -> - type: \string - value: arg - -repl_env.set '*host-language*', - {type: \string, value: 'livescript'} - - -if mal-file - rep "(load-file \"#{mal-file}\")" -else - # REPL. - rep '(println (str "Mal [" *host-language* "]"))' - loop - line = readline.readline 'user> ' - break if not line? or line == '' - try - console.log rep line - catch error - if error.message - then console.error error.message - else console.error "Error:", pr_str error, print_readably=true +readline = require './node_readline' +{id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' +{read_str} = require './reader' +{pr_str} = require './printer' +{Env} = require './env' +{runtime-error, ns, unpack-tco} = require './core' +{list-to-pairs} = require './utils' + + +defer-tco = (env, ast) -> + type: \tco + env: env + ast: ast + eval: -> eval_ast env, ast + + +is-thruthy = ({type, value}) -> + type != \const or value not in [\nil \false] + + +fmap-ast = (fn, {type, value}: ast) --> + {type: type, value: fn value} + + +make-symbol = (name) -> {type: \symbol, value: name} +make-list = (value) -> {type: \list, value: value} +make-call = (name, params) -> make-list [make-symbol name] ++ params +is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name + + +eval_simple = (env, {type, value}: ast) -> + switch type + | \symbol => env.get value + | \list, \vector => ast |> fmap-ast map eval_ast env + | \map => ast |> fmap-ast Obj.map eval_ast env + | otherwise => ast + + +eval_ast = (env, ast) --> + loop + if ast.type != \list + return eval_simple env, ast + + ast = macroexpand env, ast + if ast.type != \list + return eval_simple env, ast + else if ast.value.length == 0 + return ast + + result = if ast.value[0].type == \symbol + params = ast.value[1 to] + switch ast.value[0].value + | 'def!' => eval_def env, params + | 'let*' => eval_let env, params + | 'do' => eval_do env, params + | 'if' => eval_if env, params + | 'fn*' => eval_fn env, params + | 'quote' => eval_quote env, params + | 'quasiquoteexpand' => eval_quasiquoteexpand params + | 'quasiquote' => eval_quasiquote env, params + | 'defmacro!' => eval_defmacro env, params + | 'macroexpand' => eval_macroexpand env, params + | 'try*' => eval_try env, params + | otherwise => eval_apply env, ast.value + else + eval_apply env, ast.value + + if result.type == \tco + {env, ast} = result + else + return result + + +check_params = (name, params, expected) -> + if params.length != expected + runtime-error "'#{name}' expected #{expected} parameters, + got #{params.length}" + + +eval_def = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of def!, got a #{name.type}" + + # Evaluate the second parameter and store + # it under name in the env. + env.set name.value, (eval_ast env, params[1]) + + +eval_let = (env, params) -> + check_params 'let*', params, 2 + + binding_list = params[0] + if binding_list.type not in [\list \vector] + runtime-error "expected 1st parameter of 'let*' to + be a binding list (or vector), + got a #{binding_list.type}" + else if binding_list.value.length % 2 != 0 + runtime-error "binding list of 'let*' must have an even + number of parameters" + + # Make a new environment with the + # current environment as outer. + let_env = new Env env + + # Evaluate all binding values in the + # new environment. + binding_list.value + |> list-to-pairs + |> each ([binding_name, binding_value]) -> + if binding_name.type != \symbol + runtime-error "expected a symbol as binding name, + got a #{binding_name.type}" + + let_env.set binding_name.value, (eval_ast let_env, binding_value) + + # Defer evaluation of let* body with TCO. + defer-tco let_env, params[1] + + +eval_do = (env, params) -> + if params.length == 0 + runtime-error "'do' expected at least one parameter" + + [...rest, last-param] = params + rest |> each eval_ast env + defer-tco env, last-param + + +eval_if = (env, params) -> + if params.length < 2 + runtime-error "'if' expected at least 2 parameters" + else if params.length > 3 + runtime-error "'if' expected at most 3 parameters" + + cond = eval_ast env, params[0] + if is-thruthy cond + defer-tco env, params[1] + else if params.length > 2 + defer-tco env, params[2] + else + {type: \const, value: \nil} + + +eval_fn = (env, params) -> + check_params 'fn*', params, 2 + + if params[0].type not in [\list \vector] + runtime-error "'fn*' expected first parameter to be a list or vector." + + if not all (.type == \symbol), params[0].value + runtime-error "'fn*' expected only symbols in the parameters list." + + binds = params[0].value |> map (.value) + vargs = null + + # Parse variadic bind. + if binds.length >= 2 + [...rest, amper, name] = binds + if amper == '&' and name != '&' + binds = rest + vargs = name + + if elem-index '&', binds + runtime-error "'fn*' invalid usage of variadic parameters." + + if (unique binds).length != binds.length + runtime-error "'fn*' duplicate symbols in parameters list." + + body = params[1] + + fn_instance = (...values) -> + if not vargs and values.length != binds.length + runtime-error "function expected #{binds.length} parameters, + got #{values.length}" + else if vargs and values.length < binds.length + runtime-error "function expected at least + #{binds.length} parameters, + got #{values.length}" + + # Set binds to values in the new env. + fn_env = new Env env + + for [name, value] in (zip binds, values) + fn_env.set name, value + + if vargs + fn_env.set vargs, + make-list values.slice binds.length + + # Defer evaluation of the function body to TCO. + defer-tco fn_env, body + + {type: \function, value: fn_instance, is_macro: false} + + +eval_apply = (env, list) -> + [fn, ...args] = list |> map eval_ast env + if fn.type != \function + runtime-error "#{fn.value} is not a function, got a #{fn.type}" + + fn.value.apply env, args + + +eval_quote = (env, params) -> + if params.length != 1 + runtime-error "quote expected 1 parameter, got #{params.length}" + + params[0] + + +eval_quasiquoteexpand = (params) -> + if params.length != 1 + runtime-error "quasiquote expected 1 parameter, got #{params.length}" + + ast = params[0] + quasiquote ast + + +quasiquote = (ast) -> + if ast.type in [\symbol, \map] + make-call 'quote', [ast] + else if ast.type == \vector + make-call 'vec', [qq_foldr ast.value] + else if ast.type != \list + ast + else if (ast.value.length == 2) and is-symbol ast.value[0], 'unquote' + ast.value[1] + else + qq_foldr ast.value + + +qq_foldr = (xs) -> + result = make-list [] + for i from xs.length - 1 to 0 by -1 + result := qq_loop xs[i], result + result + + +qq_loop = (elt, acc) -> + if elt.type == \list and \ + elt.value.length == 2 and \ + is-symbol elt.value[0], 'splice-unquote' + make-call 'concat', [ + elt.value[1] + acc + ] + else + make-call 'cons', [ + quasiquote elt + acc + ] + + +eval_quasiquote = (env, params) -> + new-ast = eval_quasiquoteexpand params + defer-tco env, new-ast + + +eval_defmacro = (env, params) -> + check_params 'def!', params, 2 + + # Name is in the first parameter, and is not evaluated. + name = params[0] + if name.type != \symbol + runtime-error "expected a symbol for the first parameter + of defmacro!, got a #{name.type}" + + # Evaluate the second parameter. + fn = eval_ast env, params[1] + if fn.type != \function + runtime-error "expected a function for the second parameter + of defmacro!, got a #{fn.type}" + + # Copy fn and mark the function as a macro. + macro_fn = fn with is_macro: true + env.set name.value, macro_fn + + +get-macro-fn = (env, ast) -> + if ast.type == \list and + ast.value.length != 0 and + ast.value[0].type == \symbol + fn = env.try-get ast.value[0].value + if fn and fn.type == \function and fn.is_macro + then fn + + +macroexpand = (env, ast) -> + loop # until ast is not a macro function call. + macro_fn = get-macro-fn env, ast + if not macro_fn then return ast + ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] + + +eval_macroexpand = (env, params) -> + if params.length != 1 + runtime-error "'macroexpand' expected 1 parameter, + got #{params.length}" + + macroexpand env, params[0] + + +eval_try = (env, params) -> + if params.length > 2 + runtime-error "'try*' expected 1 or 2 parameters, + got #{params.length}" + try-form = params[0] + if params.length == 1 + return eval_ast env, try-form + + catch-clause = params[1] + if catch-clause.type != \list or + catch-clause.value.length != 3 or + not (is-symbol catch-clause.value[0], 'catch*') or + catch-clause.value[1].type != \symbol + runtime-error "'try*' expected the second parameter to be + of the form (catch* A B)" + + try + eval_ast env, try-form + catch error + error-symbol = catch-clause.value[1].value + error-value = \ + if error.message + then {type: \string, value: error.message} + else error + + catch-env = new Env env + catch-env.set error-symbol, error-value + eval_ast catch-env, catch-clause.value[2] + + +repl_env = new Env +for symbol, value of ns + repl_env.set symbol, value + +# Evil eval. +repl_env.set 'eval', do + type: \function + value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). + +# Read, Evaluate, Print +rep = (line) -> + line + |> read_str + |> eval_ast repl_env + |> (ast) -> pr_str ast, print_readably=true + + +# Define not. +rep '(def! not (fn* (x) (if x false true)))' + +# Define load-file. +rep ' +(def! load-file + (fn* (f) + (eval + (read-string + (str "(do " (slurp f) "\nnil)")))))' + +# Define cond. +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)))))))' + +# Parse program arguments. +# The first two (exe and core-file) are, respectively, +# the interpreter executable (nodejs or lsc) and the +# source file being executed (stepX_*.(ls|js)). +[exe, core-file, mal-file, ...argv] = process.argv + +repl_env.set '*ARGV*', do + type: \list + value: argv |> map (arg) -> + type: \string + value: arg + +repl_env.set '*host-language*', + {type: \string, value: 'livescript'} + + +if mal-file + rep "(load-file \"#{mal-file}\")" +else + # REPL. + rep '(println (str "Mal [" *host-language* "]"))' + loop + line = readline.readline 'user> ' + break if not line? or line == '' + try + console.log rep line + catch error + if error.message + then console.error error.message + else console.error "Error:", pr_str error, print_readably=true diff --git a/impls/livescript/utils.ls b/impls/livescript/utils.ls index 21d1ac3c22..106623f37a 100644 --- a/impls/livescript/utils.ls +++ b/impls/livescript/utils.ls @@ -1,6 +1,6 @@ -{map} = require 'prelude-ls' - - -export list-to-pairs = (list) -> - [0 to (list.length - 2) by 2] \ - |> map (idx) -> [list[idx], list[idx+1]] +{map} = require 'prelude-ls' + + +export list-to-pairs = (list) -> + [0 to (list.length - 2) by 2] \ + |> map (idx) -> [list[idx], list[idx+1]] diff --git a/impls/logo/Dockerfile b/impls/logo/Dockerfile index c9ca5c27f7..af75aa4668 100644 --- a/impls/logo/Dockerfile +++ b/impls/logo/Dockerfile @@ -1,49 +1,49 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install g++ for any C/C++ based implementations -RUN apt-get -y install g++ - -# Install UCBLogo 6.0: -# * Fix the makefile to build correctly -# * Tweat GC settings to improve performance (it's still very slow) -# * Add the timems function implemented in C -RUN apt-get -y install libx11-dev \ - && cd /tmp \ - && curl -O -J -L http://www.cs.berkeley.edu/~bh/downloads/ucblogo.tar.gz \ - && tar xf ucblogo.tar.gz \ - && cd /tmp/ucblogo-6.0 \ - && rm -rf csls/CVS \ - && ./configure \ - && sed -i -e 's/svnversion/echo 206/' -e 's/^\s*(cd docs/#\0/' makefile \ - && echo "all: everything" >> makefile \ - && sed -i -e 's/^#define *SEG_SIZE *16000 /#define SEG_SIZE 6400000 /' logo.h \ - && sed -i -e 's/^#define GCMAX 16000$/#define GCMAX 16000000/' mem.c \ - && echo "extern NODE *ltimems(NODE *);" >> globals.h \ - && echo "NODE *ltimems(NODE *args) { struct timeval tv; gettimeofday(&tv, NULL); return(make_floatnode(((FLONUM)tv.tv_sec) * 1000.0 + (tv.tv_usec / 1000))); }" >> coms.c \ - && sed -i -e 's/^\(.*lthrow.*\)$/\1 {"timems", 0, 0, 0, PREFIX_PRIORITY, ltimems},/' init.c \ - && make install \ - && cd /tmp \ - && rm -rf /tmp/ucblogo.tar.gz /tmp/ucblogo-6.0 - -ENV HOME /mal +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install g++ for any C/C++ based implementations +RUN apt-get -y install g++ + +# Install UCBLogo 6.0: +# * Fix the makefile to build correctly +# * Tweat GC settings to improve performance (it's still very slow) +# * Add the timems function implemented in C +RUN apt-get -y install libx11-dev \ + && cd /tmp \ + && curl -O -J -L http://www.cs.berkeley.edu/~bh/downloads/ucblogo.tar.gz \ + && tar xf ucblogo.tar.gz \ + && cd /tmp/ucblogo-6.0 \ + && rm -rf csls/CVS \ + && ./configure \ + && sed -i -e 's/svnversion/echo 206/' -e 's/^\s*(cd docs/#\0/' makefile \ + && echo "all: everything" >> makefile \ + && sed -i -e 's/^#define *SEG_SIZE *16000 /#define SEG_SIZE 6400000 /' logo.h \ + && sed -i -e 's/^#define GCMAX 16000$/#define GCMAX 16000000/' mem.c \ + && echo "extern NODE *ltimems(NODE *);" >> globals.h \ + && echo "NODE *ltimems(NODE *args) { struct timeval tv; gettimeofday(&tv, NULL); return(make_floatnode(((FLONUM)tv.tv_sec) * 1000.0 + (tv.tv_usec / 1000))); }" >> coms.c \ + && sed -i -e 's/^\(.*lthrow.*\)$/\1 {"timems", 0, 0, 0, PREFIX_PRIORITY, ltimems},/' init.c \ + && make install \ + && cd /tmp \ + && rm -rf /tmp/ucblogo.tar.gz /tmp/ucblogo-6.0 + +ENV HOME /mal diff --git a/impls/logo/Makefile b/impls/logo/Makefile index bb1b747413..b02fc02997 100644 --- a/impls/logo/Makefile +++ b/impls/logo/Makefile @@ -1,21 +1,21 @@ -SOURCES_BASE = readline.lg types.lg reader.lg printer.lg -SOURCES_LISP = env.lg core.lg stepA_mal.lg -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -.PHONY: all dist clean - -all: - @true - -dist: mal.lg mal - -mal.lg: $(SOURCES) - cat $+ | grep -v "^load " > $@ - -mal: mal.lg - echo "#!/usr/bin/env logo" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.lg mal +SOURCES_BASE = readline.lg types.lg reader.lg printer.lg +SOURCES_LISP = env.lg core.lg stepA_mal.lg +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +.PHONY: all dist clean + +all: + @true + +dist: mal.lg mal + +mal.lg: $(SOURCES) + cat $+ | grep -v "^load " > $@ + +mal: mal.lg + echo "#!/usr/bin/env logo" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.lg mal diff --git a/impls/logo/core.lg b/impls/logo/core.lg index 52bd0fbb28..3b177153f6 100644 --- a/impls/logo/core.lg +++ b/impls/logo/core.lg @@ -1,438 +1,438 @@ -load "../logo/types.lg -load "../logo/reader.lg -load "../logo/printer.lg - -make "global_exception [] - -to bool_to_mal :bool -output ifelse :bool [true_new] [false_new] -end - -to mal_equal_q :a :b -output bool_to_mal equal_q :a :b -end - -to mal_throw :a -make "global_exception :a -(throw "error "_mal_exception_) -end - -to mal_nil_q :a -output bool_to_mal ((obj_type :a) = "nil) -end - -to mal_true_q :a -output bool_to_mal ((obj_type :a) = "true) -end - -to mal_false_q :a -output bool_to_mal ((obj_type :a) = "false) -end - -to mal_string_q :a -output bool_to_mal ((obj_type :a) = "string) -end - -to mal_symbol :a -output symbol_new obj_val :a -end - -to mal_symbol_q :a -output bool_to_mal ((obj_type :a) = "symbol) -end - -to mal_keyword :a -output obj_new "keyword obj_val :a -end - -to mal_keyword_q :a -output bool_to_mal ((obj_type :a) = "keyword) -end - -to mal_number_q :a -output bool_to_mal ((obj_type :a) = "number) -end - -to mal_fn_q :a -case obj_type :a [ - [[nativefn] output true_new ] - [[fn] output bool_to_mal not fn_is_macro :a] - [else output false_new ] -] -end - -to mal_macro_q :a -if ((obj_type :a) = "fn) [ output bool_to_mal fn_is_macro :a ] -output false_new -end - -to mal_pr_str [:args] -output obj_new "string pr_seq :args "true " " :space_char -end - -to mal_str [:args] -output obj_new "string pr_seq :args "false " " " -end - -to mal_prn [:args] -print pr_seq :args "true " " :space_char -output nil_new -end - -to mal_println [:args] -print pr_seq :args "false " " :space_char -output nil_new -end - -to mal_read_string :str -output read_str obj_val :str -end - -to mal_readline :prompt -localmake "line readline obj_val :prompt -if :line=[] [output nil_new] -output obj_new "string :line -end - -to mal_slurp :str -openread obj_val :str -setread obj_val :str -localmake "content " -while [not eofp] [ - make "content word :content readchar -] -close obj_val :str -output obj_new "string :content -end - -to mal_lt :a :b -output bool_to_mal ((obj_val :a) < (obj_val :b)) -end - -to mal_lte :a :b -output bool_to_mal ((obj_val :a) <= (obj_val :b)) -end - -to mal_gt :a :b -output bool_to_mal ((obj_val :a) > (obj_val :b)) -end - -to mal_gte :a :b -output bool_to_mal ((obj_val :a) >= (obj_val :b)) -end - -to mal_add :a :b -output obj_new "number ((obj_val :a) + (obj_val :b)) -end - -to mal_sub :a :b -output obj_new "number ((obj_val :a) - (obj_val :b)) -end - -to mal_mul :a :b -output obj_new "number ((obj_val :a) * (obj_val :b)) -end - -to mal_div :a :b -output obj_new "number ((obj_val :a) / (obj_val :b)) -end - -to mal_time_ms -; Native function timems is added to coms.c (see Dockerfile) -output obj_new "number timems -end - -to mal_list [:args] -output obj_new "list :args -end - -to mal_list_q :a -output bool_to_mal ((obj_type :a) = "list) -end - -to mal_vector [:args] -output obj_new "vector :args -end - -to mal_vector_q :a -output bool_to_mal ((obj_type :a) = "vector) -end - -to mal_hash_map [:args] -localmake "h [] -localmake "i 1 -while [:i < count :args] [ - make "h hashmap_put :h item :i :args item (:i + 1) :args - make "i (:i + 2) -] -output obj_new "hashmap :h -end - -to mal_map_q :a -output bool_to_mal ((obj_type :a) = "hashmap) -end - -to mal_assoc :map [:args] -localmake "h obj_val :map -localmake "i 1 -while [:i < count :args] [ - make "h hashmap_put :h item :i :args item (:i + 1) :args - make "i (:i + 2) -] -output obj_new "hashmap :h -end - -to mal_dissoc :map [:args] -localmake "h obj_val :map -foreach :args [make "h hashmap_delete :h ?] -output obj_new "hashmap :h -end - -to mal_get :map :key -localmake "val hashmap_get obj_val :map :key -if emptyp :val [output nil_new] -output :val -end - -to mal_contains_q :map :key -localmake "val hashmap_get obj_val :map :key -output bool_to_mal not emptyp :val -end - -to mal_keys :map -localmake "h obj_val :map -localmake "keys [] -localmake "i 1 -while [:i <= count :h] [ - make "keys lput item :i :h :keys - make "i (:i + 2) -] -output obj_new "list :keys -end - -to mal_vals :map -localmake "h obj_val :map -localmake "values [] -localmake "i 2 -while [:i <= count :h] [ - make "values lput item :i :h :values - make "i (:i + 2) -] -output obj_new "list :values -end - -to mal_sequential_q :a -output bool_to_mal sequentialp :a -end - -to mal_cons :a :b -output obj_new "list fput :a obj_val :b -end - -to mal_concat [:args] -output obj_new "list apply "sentence map [obj_val ?] :args -end - -to mal_vec :s -output obj_new "vector obj_val :s -end - -to mal_nth :a :i -if (obj_val :i) >= _count :a [(throw "error [nth: index out of range])] -output nth :a obj_val :i -end - -to mal_first :a -output cond [ - [[(obj_type :a) = "nil] nil_new] - [[(_count :a) = 0] nil_new] - [else first obj_val :a] -] -end - -to mal_rest :a -output obj_new "list cond [ - [[(obj_type :a) = "nil] []] - [[(_count :a) = 0] []] - [else butfirst obj_val :a] -] -end - -to mal_empty_q :a -output bool_to_mal (emptyp obj_val :a) -end - -to mal_count :a -output obj_new "number _count :a -end - -to mal_apply :f [:args] -localmake "callargs obj_new "list sentence butlast :args obj_val last :args -output invoke_fn :f :callargs -end - -to mal_map :f :seq -output obj_new "list map [invoke_fn :f obj_new "list (list ?)] obj_val :seq -end - -to mal_conj :a0 [:rest] -case obj_type :a0 [ - [[list] localmake "newlist :a0 - foreach :rest [make "newlist mal_cons ? :newlist] - output :newlist ] - [[vector] output obj_new "vector sentence obj_val :a0 :rest ] - [else (throw "error [conj requires list or vector]) ] -] -end - -to mal_seq :a -case obj_type :a [ - [[string] - if (_count :a) = 0 [output nil_new] - localmake "chars [] - foreach obj_val :a [ make "chars lput obj_new "string ? :chars ] - output obj_new "list :chars ] - [[list] - if (_count :a) = 0 [output nil_new] - output :a ] - [[vector] - if (_count :a) = 0 [output nil_new] - output obj_new "list obj_val :a ] - [[nil] output nil_new ] - [else (throw "error [seq requires string or list or vector or nil]) ] -] -end - -to mal_meta :a -localmake "m obj_meta :a -if emptyp :m [output nil_new] -output :m -end - -to mal_with_meta :a :new_meta -localmake "m ifelse (obj_type :new_meta) = "nil [[]] [:new_meta] -output obj_new_with_meta obj_type :a obj_val :a :m -end - -to mal_atom :a -output obj_new "atom :a -end - -to mal_atom_q :a -output bool_to_mal ((obj_type :a) = "atom) -end - -to mal_deref :a -output obj_val :a -end - -to mal_reset_bang :a :val -.setfirst butfirst :a :val -output :val -end - -to invoke_fn :f :callargs -output case obj_type :f [ - [[nativefn] - apply obj_val :f obj_val :callargs ] - [[fn] - _eval fn_body :f env_new fn_env :f fn_args :f :callargs ] - [else - (throw "error [Wrong type for apply])] -] -end - -to mal_swap_bang :atom :f [:args] -localmake "callargs obj_new "list fput mal_deref :atom :args -output mal_reset_bang :atom invoke_fn :f :callargs -end - -to logo_to_mal :a -output cond [ - [[:a = "true] true_new] - [[:a = "false] false_new] - [[numberp :a] obj_new "number :a] - [[wordp :a] obj_new "string :a] - [[listp :a] obj_new "list map [logo_to_mal ?] :a] - [else nil_new] -] -end - -to mal_logo_eval :str -localmake "res runresult obj_val :str -if emptyp :res [output nil_new] -output logo_to_mal first :res -end - -make "core_ns [ - [[symbol =] [nativefn mal_equal_q]] - [[symbol throw] [nativefn mal_throw]] - - [[symbol nil?] [nativefn mal_nil_q]] - [[symbol true?] [nativefn mal_true_q]] - [[symbol false?] [nativefn mal_false_q]] - [[symbol string?] [nativefn mal_string_q]] - [[symbol symbol] [nativefn mal_symbol]] - [[symbol symbol?] [nativefn mal_symbol_q]] - [[symbol keyword] [nativefn mal_keyword]] - [[symbol keyword?] [nativefn mal_keyword_q]] - [[symbol number?] [nativefn mal_number_q]] - [[symbol fn?] [nativefn mal_fn_q]] - [[symbol macro?] [nativefn mal_macro_q]] - - [[symbol pr-str] [nativefn mal_pr_str]] - [[symbol str] [nativefn mal_str]] - [[symbol prn] [nativefn mal_prn]] - [[symbol println] [nativefn mal_println]] - [[symbol read-string] [nativefn mal_read_string]] - [[symbol readline] [nativefn mal_readline]] - [[symbol slurp] [nativefn mal_slurp]] - - [[symbol <] [nativefn mal_lt]] - [[symbol <=] [nativefn mal_lte]] - [[symbol >] [nativefn mal_gt]] - [[symbol >=] [nativefn mal_gte]] - [[symbol +] [nativefn mal_add]] - [[symbol -] [nativefn mal_sub]] - [[symbol *] [nativefn mal_mul]] - [[symbol /] [nativefn mal_div]] - [[symbol time-ms] [nativefn mal_time_ms]] - - [[symbol list] [nativefn mal_list]] - [[symbol list?] [nativefn mal_list_q]] - [[symbol vector] [nativefn mal_vector]] - [[symbol vector?] [nativefn mal_vector_q]] - [[symbol hash-map] [nativefn mal_hash_map]] - [[symbol map?] [nativefn mal_map_q]] - [[symbol assoc] [nativefn mal_assoc]] - [[symbol dissoc] [nativefn mal_dissoc]] - [[symbol get] [nativefn mal_get]] - [[symbol contains?] [nativefn mal_contains_q]] - [[symbol keys] [nativefn mal_keys]] - [[symbol vals] [nativefn mal_vals]] - - [[symbol sequential?] [nativefn mal_sequential_q]] - [[symbol cons] [nativefn mal_cons]] - [[symbol concat] [nativefn mal_concat]] - [[symbol vec] [nativefn mal_vec]] - [[symbol nth] [nativefn mal_nth]] - [[symbol first] [nativefn mal_first]] - [[symbol rest] [nativefn mal_rest]] - [[symbol empty?] [nativefn mal_empty_q]] - [[symbol count] [nativefn mal_count]] - [[symbol apply] [nativefn mal_apply]] - [[symbol map] [nativefn mal_map]] - - [[symbol conj] [nativefn mal_conj]] - [[symbol seq] [nativefn mal_seq]] - - [[symbol meta] [nativefn mal_meta]] - [[symbol with-meta] [nativefn mal_with_meta]] - [[symbol atom] [nativefn mal_atom]] - [[symbol atom?] [nativefn mal_atom_q]] - [[symbol deref] [nativefn mal_deref]] - [[symbol reset!] [nativefn mal_reset_bang]] - [[symbol swap!] [nativefn mal_swap_bang]] - - [[symbol logo-eval] [nativefn mal_logo_eval]] -] +load "../logo/types.lg +load "../logo/reader.lg +load "../logo/printer.lg + +make "global_exception [] + +to bool_to_mal :bool +output ifelse :bool [true_new] [false_new] +end + +to mal_equal_q :a :b +output bool_to_mal equal_q :a :b +end + +to mal_throw :a +make "global_exception :a +(throw "error "_mal_exception_) +end + +to mal_nil_q :a +output bool_to_mal ((obj_type :a) = "nil) +end + +to mal_true_q :a +output bool_to_mal ((obj_type :a) = "true) +end + +to mal_false_q :a +output bool_to_mal ((obj_type :a) = "false) +end + +to mal_string_q :a +output bool_to_mal ((obj_type :a) = "string) +end + +to mal_symbol :a +output symbol_new obj_val :a +end + +to mal_symbol_q :a +output bool_to_mal ((obj_type :a) = "symbol) +end + +to mal_keyword :a +output obj_new "keyword obj_val :a +end + +to mal_keyword_q :a +output bool_to_mal ((obj_type :a) = "keyword) +end + +to mal_number_q :a +output bool_to_mal ((obj_type :a) = "number) +end + +to mal_fn_q :a +case obj_type :a [ + [[nativefn] output true_new ] + [[fn] output bool_to_mal not fn_is_macro :a] + [else output false_new ] +] +end + +to mal_macro_q :a +if ((obj_type :a) = "fn) [ output bool_to_mal fn_is_macro :a ] +output false_new +end + +to mal_pr_str [:args] +output obj_new "string pr_seq :args "true " " :space_char +end + +to mal_str [:args] +output obj_new "string pr_seq :args "false " " " +end + +to mal_prn [:args] +print pr_seq :args "true " " :space_char +output nil_new +end + +to mal_println [:args] +print pr_seq :args "false " " :space_char +output nil_new +end + +to mal_read_string :str +output read_str obj_val :str +end + +to mal_readline :prompt +localmake "line readline obj_val :prompt +if :line=[] [output nil_new] +output obj_new "string :line +end + +to mal_slurp :str +openread obj_val :str +setread obj_val :str +localmake "content " +while [not eofp] [ + make "content word :content readchar +] +close obj_val :str +output obj_new "string :content +end + +to mal_lt :a :b +output bool_to_mal ((obj_val :a) < (obj_val :b)) +end + +to mal_lte :a :b +output bool_to_mal ((obj_val :a) <= (obj_val :b)) +end + +to mal_gt :a :b +output bool_to_mal ((obj_val :a) > (obj_val :b)) +end + +to mal_gte :a :b +output bool_to_mal ((obj_val :a) >= (obj_val :b)) +end + +to mal_add :a :b +output obj_new "number ((obj_val :a) + (obj_val :b)) +end + +to mal_sub :a :b +output obj_new "number ((obj_val :a) - (obj_val :b)) +end + +to mal_mul :a :b +output obj_new "number ((obj_val :a) * (obj_val :b)) +end + +to mal_div :a :b +output obj_new "number ((obj_val :a) / (obj_val :b)) +end + +to mal_time_ms +; Native function timems is added to coms.c (see Dockerfile) +output obj_new "number timems +end + +to mal_list [:args] +output obj_new "list :args +end + +to mal_list_q :a +output bool_to_mal ((obj_type :a) = "list) +end + +to mal_vector [:args] +output obj_new "vector :args +end + +to mal_vector_q :a +output bool_to_mal ((obj_type :a) = "vector) +end + +to mal_hash_map [:args] +localmake "h [] +localmake "i 1 +while [:i < count :args] [ + make "h hashmap_put :h item :i :args item (:i + 1) :args + make "i (:i + 2) +] +output obj_new "hashmap :h +end + +to mal_map_q :a +output bool_to_mal ((obj_type :a) = "hashmap) +end + +to mal_assoc :map [:args] +localmake "h obj_val :map +localmake "i 1 +while [:i < count :args] [ + make "h hashmap_put :h item :i :args item (:i + 1) :args + make "i (:i + 2) +] +output obj_new "hashmap :h +end + +to mal_dissoc :map [:args] +localmake "h obj_val :map +foreach :args [make "h hashmap_delete :h ?] +output obj_new "hashmap :h +end + +to mal_get :map :key +localmake "val hashmap_get obj_val :map :key +if emptyp :val [output nil_new] +output :val +end + +to mal_contains_q :map :key +localmake "val hashmap_get obj_val :map :key +output bool_to_mal not emptyp :val +end + +to mal_keys :map +localmake "h obj_val :map +localmake "keys [] +localmake "i 1 +while [:i <= count :h] [ + make "keys lput item :i :h :keys + make "i (:i + 2) +] +output obj_new "list :keys +end + +to mal_vals :map +localmake "h obj_val :map +localmake "values [] +localmake "i 2 +while [:i <= count :h] [ + make "values lput item :i :h :values + make "i (:i + 2) +] +output obj_new "list :values +end + +to mal_sequential_q :a +output bool_to_mal sequentialp :a +end + +to mal_cons :a :b +output obj_new "list fput :a obj_val :b +end + +to mal_concat [:args] +output obj_new "list apply "sentence map [obj_val ?] :args +end + +to mal_vec :s +output obj_new "vector obj_val :s +end + +to mal_nth :a :i +if (obj_val :i) >= _count :a [(throw "error [nth: index out of range])] +output nth :a obj_val :i +end + +to mal_first :a +output cond [ + [[(obj_type :a) = "nil] nil_new] + [[(_count :a) = 0] nil_new] + [else first obj_val :a] +] +end + +to mal_rest :a +output obj_new "list cond [ + [[(obj_type :a) = "nil] []] + [[(_count :a) = 0] []] + [else butfirst obj_val :a] +] +end + +to mal_empty_q :a +output bool_to_mal (emptyp obj_val :a) +end + +to mal_count :a +output obj_new "number _count :a +end + +to mal_apply :f [:args] +localmake "callargs obj_new "list sentence butlast :args obj_val last :args +output invoke_fn :f :callargs +end + +to mal_map :f :seq +output obj_new "list map [invoke_fn :f obj_new "list (list ?)] obj_val :seq +end + +to mal_conj :a0 [:rest] +case obj_type :a0 [ + [[list] localmake "newlist :a0 + foreach :rest [make "newlist mal_cons ? :newlist] + output :newlist ] + [[vector] output obj_new "vector sentence obj_val :a0 :rest ] + [else (throw "error [conj requires list or vector]) ] +] +end + +to mal_seq :a +case obj_type :a [ + [[string] + if (_count :a) = 0 [output nil_new] + localmake "chars [] + foreach obj_val :a [ make "chars lput obj_new "string ? :chars ] + output obj_new "list :chars ] + [[list] + if (_count :a) = 0 [output nil_new] + output :a ] + [[vector] + if (_count :a) = 0 [output nil_new] + output obj_new "list obj_val :a ] + [[nil] output nil_new ] + [else (throw "error [seq requires string or list or vector or nil]) ] +] +end + +to mal_meta :a +localmake "m obj_meta :a +if emptyp :m [output nil_new] +output :m +end + +to mal_with_meta :a :new_meta +localmake "m ifelse (obj_type :new_meta) = "nil [[]] [:new_meta] +output obj_new_with_meta obj_type :a obj_val :a :m +end + +to mal_atom :a +output obj_new "atom :a +end + +to mal_atom_q :a +output bool_to_mal ((obj_type :a) = "atom) +end + +to mal_deref :a +output obj_val :a +end + +to mal_reset_bang :a :val +.setfirst butfirst :a :val +output :val +end + +to invoke_fn :f :callargs +output case obj_type :f [ + [[nativefn] + apply obj_val :f obj_val :callargs ] + [[fn] + _eval fn_body :f env_new fn_env :f fn_args :f :callargs ] + [else + (throw "error [Wrong type for apply])] +] +end + +to mal_swap_bang :atom :f [:args] +localmake "callargs obj_new "list fput mal_deref :atom :args +output mal_reset_bang :atom invoke_fn :f :callargs +end + +to logo_to_mal :a +output cond [ + [[:a = "true] true_new] + [[:a = "false] false_new] + [[numberp :a] obj_new "number :a] + [[wordp :a] obj_new "string :a] + [[listp :a] obj_new "list map [logo_to_mal ?] :a] + [else nil_new] +] +end + +to mal_logo_eval :str +localmake "res runresult obj_val :str +if emptyp :res [output nil_new] +output logo_to_mal first :res +end + +make "core_ns [ + [[symbol =] [nativefn mal_equal_q]] + [[symbol throw] [nativefn mal_throw]] + + [[symbol nil?] [nativefn mal_nil_q]] + [[symbol true?] [nativefn mal_true_q]] + [[symbol false?] [nativefn mal_false_q]] + [[symbol string?] [nativefn mal_string_q]] + [[symbol symbol] [nativefn mal_symbol]] + [[symbol symbol?] [nativefn mal_symbol_q]] + [[symbol keyword] [nativefn mal_keyword]] + [[symbol keyword?] [nativefn mal_keyword_q]] + [[symbol number?] [nativefn mal_number_q]] + [[symbol fn?] [nativefn mal_fn_q]] + [[symbol macro?] [nativefn mal_macro_q]] + + [[symbol pr-str] [nativefn mal_pr_str]] + [[symbol str] [nativefn mal_str]] + [[symbol prn] [nativefn mal_prn]] + [[symbol println] [nativefn mal_println]] + [[symbol read-string] [nativefn mal_read_string]] + [[symbol readline] [nativefn mal_readline]] + [[symbol slurp] [nativefn mal_slurp]] + + [[symbol <] [nativefn mal_lt]] + [[symbol <=] [nativefn mal_lte]] + [[symbol >] [nativefn mal_gt]] + [[symbol >=] [nativefn mal_gte]] + [[symbol +] [nativefn mal_add]] + [[symbol -] [nativefn mal_sub]] + [[symbol *] [nativefn mal_mul]] + [[symbol /] [nativefn mal_div]] + [[symbol time-ms] [nativefn mal_time_ms]] + + [[symbol list] [nativefn mal_list]] + [[symbol list?] [nativefn mal_list_q]] + [[symbol vector] [nativefn mal_vector]] + [[symbol vector?] [nativefn mal_vector_q]] + [[symbol hash-map] [nativefn mal_hash_map]] + [[symbol map?] [nativefn mal_map_q]] + [[symbol assoc] [nativefn mal_assoc]] + [[symbol dissoc] [nativefn mal_dissoc]] + [[symbol get] [nativefn mal_get]] + [[symbol contains?] [nativefn mal_contains_q]] + [[symbol keys] [nativefn mal_keys]] + [[symbol vals] [nativefn mal_vals]] + + [[symbol sequential?] [nativefn mal_sequential_q]] + [[symbol cons] [nativefn mal_cons]] + [[symbol concat] [nativefn mal_concat]] + [[symbol vec] [nativefn mal_vec]] + [[symbol nth] [nativefn mal_nth]] + [[symbol first] [nativefn mal_first]] + [[symbol rest] [nativefn mal_rest]] + [[symbol empty?] [nativefn mal_empty_q]] + [[symbol count] [nativefn mal_count]] + [[symbol apply] [nativefn mal_apply]] + [[symbol map] [nativefn mal_map]] + + [[symbol conj] [nativefn mal_conj]] + [[symbol seq] [nativefn mal_seq]] + + [[symbol meta] [nativefn mal_meta]] + [[symbol with-meta] [nativefn mal_with_meta]] + [[symbol atom] [nativefn mal_atom]] + [[symbol atom?] [nativefn mal_atom_q]] + [[symbol deref] [nativefn mal_deref]] + [[symbol reset!] [nativefn mal_reset_bang]] + [[symbol swap!] [nativefn mal_swap_bang]] + + [[symbol logo-eval] [nativefn mal_logo_eval]] +] diff --git a/impls/logo/env.lg b/impls/logo/env.lg index b3f5b74e89..f5d71cb6a1 100644 --- a/impls/logo/env.lg +++ b/impls/logo/env.lg @@ -1,51 +1,51 @@ -load "../logo/printer.lg -load "../logo/types.lg - -to env_new :outer :binds :exprs -localmake "data [] -if not emptyp :binds [ - localmake "i 0 - while [:i < _count :binds] [ - ifelse (nth :binds :i) = [symbol &] [ - localmake "val drop :exprs :i - make "i (:i + 1) - localmake "key nth :binds :i - ] [ - localmake "val nth :exprs :i - localmake "key nth :binds :i - ] - make "data hashmap_put :data :key :val - make "i (:i + 1) - ] -] -output listtoarray list :outer :data -end - -to env_outer :env -output item 1 :env -end - -to env_data :env -output item 2 :env -end - -to env_find :env :key -if emptyp :env [output []] -localmake "val hashmap_get env_data :env :key -ifelse emptyp :val [ - output env_find env_outer :env :key -] [ - output :env -] -end - -to env_get :env :key -localmake "foundenv env_find :env :key -if emptyp :foundenv [(throw "error sentence (word "' pr_str :key "true "' ) [not found])] -output hashmap_get env_data :foundenv :key -end - -to env_set :env :key :val -.setitem 2 :env hashmap_put env_data :env :key :val -output :val -end +load "../logo/printer.lg +load "../logo/types.lg + +to env_new :outer :binds :exprs +localmake "data [] +if not emptyp :binds [ + localmake "i 0 + while [:i < _count :binds] [ + ifelse (nth :binds :i) = [symbol &] [ + localmake "val drop :exprs :i + make "i (:i + 1) + localmake "key nth :binds :i + ] [ + localmake "val nth :exprs :i + localmake "key nth :binds :i + ] + make "data hashmap_put :data :key :val + make "i (:i + 1) + ] +] +output listtoarray list :outer :data +end + +to env_outer :env +output item 1 :env +end + +to env_data :env +output item 2 :env +end + +to env_find :env :key +if emptyp :env [output []] +localmake "val hashmap_get env_data :env :key +ifelse emptyp :val [ + output env_find env_outer :env :key +] [ + output :env +] +end + +to env_get :env :key +localmake "foundenv env_find :env :key +if emptyp :foundenv [(throw "error sentence (word "' pr_str :key "true "' ) [not found])] +output hashmap_get env_data :foundenv :key +end + +to env_set :env :key :val +.setitem 2 :env hashmap_put env_data :env :key :val +output :val +end diff --git a/impls/logo/examples/tree.mal b/impls/logo/examples/tree.mal index 5813ad3257..63f197d91f 100644 --- a/impls/logo/examples/tree.mal +++ b/impls/logo/examples/tree.mal @@ -1,25 +1,25 @@ -; Draw a tree -; -; The classic Logo demo for recursive functions - now in Mal! - -; White background with blue pen -(logo-eval "setbackground 7") -(logo-eval "setpencolor 1") - -; Initialize turtle location -(logo-eval "penup setxy 0 -100 pendown") - -; Expose Logo drawing functions to Mal code -(def! fd (fn* [size] (logo-eval (str "fd " size)))) -(def! bk (fn* [size] (logo-eval (str "bk " size)))) -(def! lt (fn* [size] (logo-eval (str "lt " size)))) -(def! rt (fn* [size] (logo-eval (str "rt " size)))) - -; Tree parts -(def! leaf (fn* [size] (do (fd size) (bk size)))) -(def! branch (fn* [size] (do (fd size) (draw-tree size) (bk size)))) -(def! two-branches (fn* [size] (do (lt 10) (branch size) (rt 40) (branch size) (lt 30)))) -(def! draw-tree (fn* [size] (if (< size 5) (leaf size) (two-branches (/ size 2))))) - -; Draw it -(draw-tree 250) +; Draw a tree +; +; The classic Logo demo for recursive functions - now in Mal! + +; White background with blue pen +(logo-eval "setbackground 7") +(logo-eval "setpencolor 1") + +; Initialize turtle location +(logo-eval "penup setxy 0 -100 pendown") + +; Expose Logo drawing functions to Mal code +(def! fd (fn* [size] (logo-eval (str "fd " size)))) +(def! bk (fn* [size] (logo-eval (str "bk " size)))) +(def! lt (fn* [size] (logo-eval (str "lt " size)))) +(def! rt (fn* [size] (logo-eval (str "rt " size)))) + +; Tree parts +(def! leaf (fn* [size] (do (fd size) (bk size)))) +(def! branch (fn* [size] (do (fd size) (draw-tree size) (bk size)))) +(def! two-branches (fn* [size] (do (lt 10) (branch size) (rt 40) (branch size) (lt 30)))) +(def! draw-tree (fn* [size] (if (< size 5) (leaf size) (two-branches (/ size 2))))) + +; Draw it +(draw-tree 250) diff --git a/impls/logo/printer.lg b/impls/logo/printer.lg index efe1339854..ccbac757bb 100644 --- a/impls/logo/printer.lg +++ b/impls/logo/printer.lg @@ -1,54 +1,54 @@ -load "../logo/types.lg - -to pr_str :exp :readable -if emptyp :exp [output []] -output case obj_type :exp [ - [[nil] "nil] - [[true] "true] - [[false] "false] - [[number] obj_val :exp] - [[symbol] obj_val :exp] - [[keyword] word ": obj_val :exp] - [[string] print_string :exp :readable] - [[list] pr_seq obj_val :exp :readable "\( "\) :space_char] - [[vector] pr_seq obj_val :exp :readable "\[ "\] :space_char] - [[hashmap] pr_seq obj_val :exp :readable "\{ "\} :space_char] - [[atom] (word "\(atom :space_char pr_str obj_val :exp :readable "\) ) ] - [[nativefn] (word "#) ] - [[fn] (word "#) ] - [else (throw "error (sentence [unknown type] obj_type :exp))] -] -end - -to escape_string :s -localmake "i 1 -localmake "res " -while [:i <= count :s] [ - localmake "c item :i :s - make "res word :res cond [ - [[ :c = "\\ ] "\\\\ ] - [[ :c = char 10 ] "\\n ] - [[ :c = "\" ] "\\\" ] - [else :c ] - ] - make "i (:i + 1) -] -output :res -end - -to print_string :exp :readable -ifelse :readable [ - output (word "\" escape_string obj_val :exp "\" ) -] [ - output obj_val :exp -] -end - -to pr_seq :seq :readable :start_char :end_char :delim_char -localmake "res :start_char -foreach :seq [ - if # > 1 [make "res word :res :delim_char] - make "res word :res pr_str ? :readable -] -output word :res :end_char -end +load "../logo/types.lg + +to pr_str :exp :readable +if emptyp :exp [output []] +output case obj_type :exp [ + [[nil] "nil] + [[true] "true] + [[false] "false] + [[number] obj_val :exp] + [[symbol] obj_val :exp] + [[keyword] word ": obj_val :exp] + [[string] print_string :exp :readable] + [[list] pr_seq obj_val :exp :readable "\( "\) :space_char] + [[vector] pr_seq obj_val :exp :readable "\[ "\] :space_char] + [[hashmap] pr_seq obj_val :exp :readable "\{ "\} :space_char] + [[atom] (word "\(atom :space_char pr_str obj_val :exp :readable "\) ) ] + [[nativefn] (word "#) ] + [[fn] (word "#) ] + [else (throw "error (sentence [unknown type] obj_type :exp))] +] +end + +to escape_string :s +localmake "i 1 +localmake "res " +while [:i <= count :s] [ + localmake "c item :i :s + make "res word :res cond [ + [[ :c = "\\ ] "\\\\ ] + [[ :c = char 10 ] "\\n ] + [[ :c = "\" ] "\\\" ] + [else :c ] + ] + make "i (:i + 1) +] +output :res +end + +to print_string :exp :readable +ifelse :readable [ + output (word "\" escape_string obj_val :exp "\" ) +] [ + output obj_val :exp +] +end + +to pr_seq :seq :readable :start_char :end_char :delim_char +localmake "res :start_char +foreach :seq [ + if # > 1 [make "res word :res :delim_char] + make "res word :res pr_str ? :readable +] +output word :res :end_char +end diff --git a/impls/logo/reader.lg b/impls/logo/reader.lg index 049428d0c3..1b011da096 100644 --- a/impls/logo/reader.lg +++ b/impls/logo/reader.lg @@ -1,221 +1,221 @@ -load "../logo/types.lg - -make "open_paren_char char 40 -make "close_paren_char char 41 -make "open_bracket_char char 91 -make "close_bracket_char char 93 -make "open_brace_char char 123 -make "close_brace_char char 125 - -to newlinep :char -output case ascii :char [ - [[10 13] "true] - [else "false] -] -end - -to whitespacep :char -output case ascii :char [ - [[9 10 13 32] "true] - [else "false] -] -end - -to singlechartokenp :char -output case :char [ - [[ ( ) \[ \] \{ \} ' ` \^ @ ] "true] - [else "false] -] -end - -to separatorp :char -output ifelse whitespacep :char [ - "true -] [ - case :char [ - [[ ( ) \[ \] \{ \} ' \" ` , \; ] "true] - [else "false] - ] -] -end - -to read_comment_token :s -localmake "rest :s -while [not emptyp :rest] [ - localmake "c first :rest - ifelse newlinep :c [ - output list " butfirst :rest - ] [ - make "rest butfirst :rest - ] -] -output list " :rest -end - -to read_word_token :s -localmake "w " -localmake "rest :s -while [not emptyp :rest] [ - localmake "c first :rest - ifelse separatorp :c [ - output list :w :rest - ] [ - make "w word :w :c - make "rest butfirst :rest - ] -] -output list :w :rest -end - -to read_string_token :s -localmake "w first :s -localmake "rest butfirst :s -while [not emptyp :rest] [ - localmake "c first :rest - if :c = "" [ - make "w word :w :c - output list :w butfirst :rest - ] - if :c = "\\ [ - make "w word :w :c - make "rest butfirst :rest - make "c first :rest - ] - make "w word :w :c - make "rest butfirst :rest -] -(throw "error [Expected closing quotes, not EOF]) -end - -to read_next_token :s -localmake "c first :s -localmake "rest butfirst :s -output cond [ - [[whitespacep :c] list " :rest] - [[:c = ",] list " :rest] - [[:c = "~] ifelse ((first :rest) = "@) [list "~@ butfirst :rest] [list "~ :rest] ] - [[singlechartokenp :c] list :c :rest] - [[:c = "\;] read_comment_token :s] - [[:c = ""] read_string_token :s] - [else read_word_token :s] -] -output list first :s butfirst :s -end - -to tokenize :str -localmake "tokens [] -localmake "s :str -while [not emptyp :s] [ - localmake "res read_next_token :s - localmake "token first :res - make "s last :res - if not emptyp :token [ - make "tokens lput :token :tokens - ] -] -output :tokens -end - -to reader_new :tokens -output listtoarray list :tokens 1 -end - -to reader_peek :reader -localmake "tokens item 1 :reader -localmake "pos item 2 :reader -if :pos > count :tokens [output []] -output item :pos :tokens -end - -to reader_next :reader -make "token reader_peek :reader -localmake "pos item 2 :reader -setitem 2 :reader (1 + :pos) -output :token -end - -to unescape_string :token -localmake "s butfirst butlast :token ; remove surrounding double-quotes -localmake "i 1 -localmake "res " -while [:i <= count :s] [ - localmake "c item :i :s - ifelse :c = "\\ [ - make "i (:i + 1) - make "c item :i :s - make "res word :res case :c [ - [[ n ] char 10] - [[ " ] "\" ] - [[ \\ ] "\\ ] - [else :c] - ] - ] [ - make "res word :res :c - ] - make "i (:i + 1) -] -output :res -end - -to read_atom :reader -localmake "token reader_next :reader -output cond [ - [[:token = "nil] nil_new] - [[:token = "true] true_new] - [[:token = "false] false_new] - [[numberp :token] obj_new "number :token] - [[(first :token) = ": ] obj_new "keyword butfirst :token] - [[(first :token) = "\" ] obj_new "string unescape_string :token] - [else symbol_new :token] -] -end - -to read_seq :reader :value_type :start_char :end_char -localmake "token reader_next :reader -if :token <> :start_char [(throw "error sentence "expected (word "' :start_char "'))] -localmake "seq [] -make "token reader_peek :reader -while [:token <> :end_char] [ - if emptyp :token [(throw "error (sentence [expected] (word "' :end_char "',) [got EOF]))] - make "seq lput read_form :reader :seq - make "token reader_peek :reader -] -ignore reader_next :reader -output obj_new :value_type :seq -end - -to reader_macro :reader :symbol_name -ignore reader_next :reader -output obj_new "list list symbol_new :symbol_name read_form :reader -end - -to with_meta_reader_macro :reader -ignore reader_next :reader -localmake "meta read_form :reader -output obj_new "list (list symbol_new "with-meta read_form :reader :meta) -end - -to read_form :reader -output case reader_peek :reader [ - [[ ' ] reader_macro :reader "quote ] - [[ ` ] reader_macro :reader "quasiquote ] - [[ ~ ] reader_macro :reader "unquote ] - [[ ~@ ] reader_macro :reader "splice-unquote ] - [[ \^ ] with_meta_reader_macro :reader ] - [[ @ ] reader_macro :reader "deref ] - [[ ( ] read_seq :reader "list :open_paren_char :close_paren_char ] - [[ ) ] (throw "error sentence [unexpected] (word "' :close_paren_char "')) ] - [[ \[ ] read_seq :reader "vector :open_bracket_char :close_bracket_char ] - [[ \] ] (throw "error sentence [unexpected] (word "' :close_bracket_char "')) ] - [[ \{ ] read_seq :reader "hashmap :open_brace_char :close_brace_char ] - [[ \} ] (throw "error sentence [unexpected] (word "' :close_brace_char "')) ] - [else read_atom :reader] -] -end - -to read_str :str -localmake "tokens tokenize :str -if emptyp :tokens [output []] -localmake "reader reader_new :tokens -output read_form :reader -end +load "../logo/types.lg + +make "open_paren_char char 40 +make "close_paren_char char 41 +make "open_bracket_char char 91 +make "close_bracket_char char 93 +make "open_brace_char char 123 +make "close_brace_char char 125 + +to newlinep :char +output case ascii :char [ + [[10 13] "true] + [else "false] +] +end + +to whitespacep :char +output case ascii :char [ + [[9 10 13 32] "true] + [else "false] +] +end + +to singlechartokenp :char +output case :char [ + [[ ( ) \[ \] \{ \} ' ` \^ @ ] "true] + [else "false] +] +end + +to separatorp :char +output ifelse whitespacep :char [ + "true +] [ + case :char [ + [[ ( ) \[ \] \{ \} ' \" ` , \; ] "true] + [else "false] + ] +] +end + +to read_comment_token :s +localmake "rest :s +while [not emptyp :rest] [ + localmake "c first :rest + ifelse newlinep :c [ + output list " butfirst :rest + ] [ + make "rest butfirst :rest + ] +] +output list " :rest +end + +to read_word_token :s +localmake "w " +localmake "rest :s +while [not emptyp :rest] [ + localmake "c first :rest + ifelse separatorp :c [ + output list :w :rest + ] [ + make "w word :w :c + make "rest butfirst :rest + ] +] +output list :w :rest +end + +to read_string_token :s +localmake "w first :s +localmake "rest butfirst :s +while [not emptyp :rest] [ + localmake "c first :rest + if :c = "" [ + make "w word :w :c + output list :w butfirst :rest + ] + if :c = "\\ [ + make "w word :w :c + make "rest butfirst :rest + make "c first :rest + ] + make "w word :w :c + make "rest butfirst :rest +] +(throw "error [Expected closing quotes, not EOF]) +end + +to read_next_token :s +localmake "c first :s +localmake "rest butfirst :s +output cond [ + [[whitespacep :c] list " :rest] + [[:c = ",] list " :rest] + [[:c = "~] ifelse ((first :rest) = "@) [list "~@ butfirst :rest] [list "~ :rest] ] + [[singlechartokenp :c] list :c :rest] + [[:c = "\;] read_comment_token :s] + [[:c = ""] read_string_token :s] + [else read_word_token :s] +] +output list first :s butfirst :s +end + +to tokenize :str +localmake "tokens [] +localmake "s :str +while [not emptyp :s] [ + localmake "res read_next_token :s + localmake "token first :res + make "s last :res + if not emptyp :token [ + make "tokens lput :token :tokens + ] +] +output :tokens +end + +to reader_new :tokens +output listtoarray list :tokens 1 +end + +to reader_peek :reader +localmake "tokens item 1 :reader +localmake "pos item 2 :reader +if :pos > count :tokens [output []] +output item :pos :tokens +end + +to reader_next :reader +make "token reader_peek :reader +localmake "pos item 2 :reader +setitem 2 :reader (1 + :pos) +output :token +end + +to unescape_string :token +localmake "s butfirst butlast :token ; remove surrounding double-quotes +localmake "i 1 +localmake "res " +while [:i <= count :s] [ + localmake "c item :i :s + ifelse :c = "\\ [ + make "i (:i + 1) + make "c item :i :s + make "res word :res case :c [ + [[ n ] char 10] + [[ " ] "\" ] + [[ \\ ] "\\ ] + [else :c] + ] + ] [ + make "res word :res :c + ] + make "i (:i + 1) +] +output :res +end + +to read_atom :reader +localmake "token reader_next :reader +output cond [ + [[:token = "nil] nil_new] + [[:token = "true] true_new] + [[:token = "false] false_new] + [[numberp :token] obj_new "number :token] + [[(first :token) = ": ] obj_new "keyword butfirst :token] + [[(first :token) = "\" ] obj_new "string unescape_string :token] + [else symbol_new :token] +] +end + +to read_seq :reader :value_type :start_char :end_char +localmake "token reader_next :reader +if :token <> :start_char [(throw "error sentence "expected (word "' :start_char "'))] +localmake "seq [] +make "token reader_peek :reader +while [:token <> :end_char] [ + if emptyp :token [(throw "error (sentence [expected] (word "' :end_char "',) [got EOF]))] + make "seq lput read_form :reader :seq + make "token reader_peek :reader +] +ignore reader_next :reader +output obj_new :value_type :seq +end + +to reader_macro :reader :symbol_name +ignore reader_next :reader +output obj_new "list list symbol_new :symbol_name read_form :reader +end + +to with_meta_reader_macro :reader +ignore reader_next :reader +localmake "meta read_form :reader +output obj_new "list (list symbol_new "with-meta read_form :reader :meta) +end + +to read_form :reader +output case reader_peek :reader [ + [[ ' ] reader_macro :reader "quote ] + [[ ` ] reader_macro :reader "quasiquote ] + [[ ~ ] reader_macro :reader "unquote ] + [[ ~@ ] reader_macro :reader "splice-unquote ] + [[ \^ ] with_meta_reader_macro :reader ] + [[ @ ] reader_macro :reader "deref ] + [[ ( ] read_seq :reader "list :open_paren_char :close_paren_char ] + [[ ) ] (throw "error sentence [unexpected] (word "' :close_paren_char "')) ] + [[ \[ ] read_seq :reader "vector :open_bracket_char :close_bracket_char ] + [[ \] ] (throw "error sentence [unexpected] (word "' :close_bracket_char "')) ] + [[ \{ ] read_seq :reader "hashmap :open_brace_char :close_brace_char ] + [[ \} ] (throw "error sentence [unexpected] (word "' :close_brace_char "')) ] + [else read_atom :reader] +] +end + +to read_str :str +localmake "tokens tokenize :str +if emptyp :tokens [output []] +localmake "reader reader_new :tokens +output read_form :reader +end diff --git a/impls/logo/readline.lg b/impls/logo/readline.lg index b015ff397f..00c967539b 100644 --- a/impls/logo/readline.lg +++ b/impls/logo/readline.lg @@ -1,27 +1,27 @@ -make "backspace_char char 8 -make "space_char char 32 - -to readline :prompt -type :prompt -wait 0 ; flush standard output -localmake "line " -forever [ - localmake "c readchar - ifelse emptyp :c [ - output [] - ] [ - localmake "ascii rawascii :c - case :ascii [ - [[4] output []] - [[10] type :c - output :line] - [[127] if not emptyp :line [ - type (word :backspace_char :space_char :backspace_char) - make "line butlast :line - ]] - [else type :c - make "line word :line :c] - ] - ] -] -end +make "backspace_char char 8 +make "space_char char 32 + +to readline :prompt +type :prompt +wait 0 ; flush standard output +localmake "line " +forever [ + localmake "c readchar + ifelse emptyp :c [ + output [] + ] [ + localmake "ascii rawascii :c + case :ascii [ + [[4] output []] + [[10] type :c + output :line] + [[127] if not emptyp :line [ + type (word :backspace_char :space_char :backspace_char) + make "line butlast :line + ]] + [else type :c + make "line word :line :c] + ] + ] +] +end diff --git a/impls/logo/run b/impls/logo/run index 5d90e8a7ab..352914d4d6 100755 --- a/impls/logo/run +++ b/impls/logo/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec logo $(dirname $0)/${STEP:-stepA_mal}.lg - "${@}" +#!/bin/bash +exec logo $(dirname $0)/${STEP:-stepA_mal}.lg - "${@}" diff --git a/impls/logo/step0_repl.lg b/impls/logo/step0_repl.lg index f62cd8d675..54ef95ad98 100644 --- a/impls/logo/step0_repl.lg +++ b/impls/logo/step0_repl.lg @@ -1,31 +1,31 @@ -load "../logo/readline.lg - -to _read :str -output :str -end - -to _eval :ast :env -output :ast -end - -to _print :exp -output :exp -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - print _print _eval _read :line [] - ] - ] -] -end - -repl -bye +load "../logo/readline.lg + +to _read :str +output :str +end + +to _eval :ast :env +output :ast +end + +to _print :exp +output :exp +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + print _print _eval _read :line [] + ] + ] +] +end + +repl +bye diff --git a/impls/logo/step1_read_print.lg b/impls/logo/step1_read_print.lg index c3e5e61008..30e6c8beac 100644 --- a/impls/logo/step1_read_print.lg +++ b/impls/logo/step1_read_print.lg @@ -1,41 +1,41 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg - -to _read :str -output read_str :str -end - -to _eval :ast :env -output :ast -end - -to _print :exp -output pr_str :exp "true -end - -to rep :str -output _print _eval _read :str [] -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - localmake "exception error - if not emptyp :exception [ - (print "Error: first butfirst :exception) - ] - ] - ] -] -end - -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg + +to _read :str +output read_str :str +end + +to _eval :ast :env +output :ast +end + +to _print :exp +output pr_str :exp "true +end + +to rep :str +output _print _eval _read :str [] +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + localmake "exception error + if not emptyp :exception [ + (print "Error: first butfirst :exception) + ] + ] + ] +] +end + +repl +bye diff --git a/impls/logo/step2_eval.lg b/impls/logo/step2_eval.lg index de1be205a2..00d020b9b8 100644 --- a/impls/logo/step2_eval.lg +++ b/impls/logo/step2_eval.lg @@ -1,78 +1,78 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg -load "../logo/types.lg - -to _read :str -output read_str :str -end - -to eval_ast :ast :env -output case (obj_type :ast) [ - [[symbol] localmake "val hashmap_get :env :ast - if emptyp :val [(throw "error sentence (word "' obj_val :ast "' ) [not found])] - :val ] - [[list] obj_new "list map [_eval ? :env] obj_val :ast] - [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] - [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] - [else :ast] -] -end - -to _eval :ast :env -if (obj_type :ast) <> "list [output eval_ast :ast :env] -if emptyp obj_val :ast [output :ast] -make "el obj_val eval_ast :ast :env -output apply first :el butfirst :el -end - -to _print :exp -output pr_str :exp "true -end - -to rep :str -output _print _eval _read :str :repl_env -end - -to mal_add :a :b -output obj_new "number ((obj_val :a) + (obj_val :b)) -end - -to mal_sub :a :b -output obj_new "number ((obj_val :a) - (obj_val :b)) -end - -to mal_mul :a :b -output obj_new "number ((obj_val :a) * (obj_val :b)) -end - -to mal_div :a :b -output obj_new "number ((obj_val :a) / (obj_val :b)) -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - localmake "exception error - if not emptyp :exception [ - (print "Error: first butfirst :exception) - ] - ] - ] -] -end - -make "repl_env [] -make "repl_env hashmap_put :repl_env symbol_new "+ "mal_add -make "repl_env hashmap_put :repl_env symbol_new "- "mal_sub -make "repl_env hashmap_put :repl_env symbol_new "* "mal_mul -make "repl_env hashmap_put :repl_env symbol_new "/ "mal_div -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg +load "../logo/types.lg + +to _read :str +output read_str :str +end + +to eval_ast :ast :env +output case (obj_type :ast) [ + [[symbol] localmake "val hashmap_get :env :ast + if emptyp :val [(throw "error sentence (word "' obj_val :ast "' ) [not found])] + :val ] + [[list] obj_new "list map [_eval ? :env] obj_val :ast] + [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] + [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] + [else :ast] +] +end + +to _eval :ast :env +if (obj_type :ast) <> "list [output eval_ast :ast :env] +if emptyp obj_val :ast [output :ast] +make "el obj_val eval_ast :ast :env +output apply first :el butfirst :el +end + +to _print :exp +output pr_str :exp "true +end + +to rep :str +output _print _eval _read :str :repl_env +end + +to mal_add :a :b +output obj_new "number ((obj_val :a) + (obj_val :b)) +end + +to mal_sub :a :b +output obj_new "number ((obj_val :a) - (obj_val :b)) +end + +to mal_mul :a :b +output obj_new "number ((obj_val :a) * (obj_val :b)) +end + +to mal_div :a :b +output obj_new "number ((obj_val :a) / (obj_val :b)) +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + localmake "exception error + if not emptyp :exception [ + (print "Error: first butfirst :exception) + ] + ] + ] +] +end + +make "repl_env [] +make "repl_env hashmap_put :repl_env symbol_new "+ "mal_add +make "repl_env hashmap_put :repl_env symbol_new "- "mal_sub +make "repl_env hashmap_put :repl_env symbol_new "* "mal_mul +make "repl_env hashmap_put :repl_env symbol_new "/ "mal_div +repl +bye diff --git a/impls/logo/step3_env.lg b/impls/logo/step3_env.lg index 05147038d6..1e4906dd04 100644 --- a/impls/logo/step3_env.lg +++ b/impls/logo/step3_env.lg @@ -1,96 +1,96 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg -load "../logo/types.lg -load "../logo/env.lg - -to _read :str -output read_str :str -end - -to eval_ast :ast :env -output case (obj_type :ast) [ - [[symbol] env_get :env :ast] - [[list] obj_new "list map [_eval ? :env] obj_val :ast] - [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] - [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] - [else :ast] -] -end - -to _eval :ast :env -if (obj_type :ast) <> "list [output eval_ast :ast :env] -if emptyp obj_val :ast [output :ast] -localmake "a0 nth :ast 0 -case list obj_type :a0 obj_val :a0 [ - [[[symbol def!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - output env_set :env :a1 _eval :a2 :env ] - - [[[symbol let*]] - localmake "a1 nth :ast 1 - localmake "letenv env_new :env [] [] - localmake "i 0 - while [:i < _count :a1] [ - ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv - make "i (:i + 2) - ] - output _eval nth :ast 2 :letenv ] - - [else - make "el obj_val eval_ast :ast :env - output apply first :el butfirst :el ] -] -end - -to _print :exp -output pr_str :exp "true -end - -to rep :str -output _print _eval _read :str :repl_env -end - -to mal_add :a :b -output obj_new "number ((obj_val :a) + (obj_val :b)) -end - -to mal_sub :a :b -output obj_new "number ((obj_val :a) - (obj_val :b)) -end - -to mal_mul :a :b -output obj_new "number ((obj_val :a) * (obj_val :b)) -end - -to mal_div :a :b -output obj_new "number ((obj_val :a) / (obj_val :b)) -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - localmake "exception error - if not emptyp :exception [ - (print "Error: first butfirst :exception) - ] - ] - ] -] -end - -make "repl_env env_new [] [] [] -ignore env_set :repl_env obj_new "symbol "+ "mal_add -ignore env_set :repl_env obj_new "symbol "- "mal_sub -ignore env_set :repl_env obj_new "symbol "* "mal_mul -ignore env_set :repl_env obj_new "symbol "/ "mal_div -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg +load "../logo/types.lg +load "../logo/env.lg + +to _read :str +output read_str :str +end + +to eval_ast :ast :env +output case (obj_type :ast) [ + [[symbol] env_get :env :ast] + [[list] obj_new "list map [_eval ? :env] obj_val :ast] + [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] + [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] + [else :ast] +] +end + +to _eval :ast :env +if (obj_type :ast) <> "list [output eval_ast :ast :env] +if emptyp obj_val :ast [output :ast] +localmake "a0 nth :ast 0 +case list obj_type :a0 obj_val :a0 [ + [[[symbol def!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + output env_set :env :a1 _eval :a2 :env ] + + [[[symbol let*]] + localmake "a1 nth :ast 1 + localmake "letenv env_new :env [] [] + localmake "i 0 + while [:i < _count :a1] [ + ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv + make "i (:i + 2) + ] + output _eval nth :ast 2 :letenv ] + + [else + make "el obj_val eval_ast :ast :env + output apply first :el butfirst :el ] +] +end + +to _print :exp +output pr_str :exp "true +end + +to rep :str +output _print _eval _read :str :repl_env +end + +to mal_add :a :b +output obj_new "number ((obj_val :a) + (obj_val :b)) +end + +to mal_sub :a :b +output obj_new "number ((obj_val :a) - (obj_val :b)) +end + +to mal_mul :a :b +output obj_new "number ((obj_val :a) * (obj_val :b)) +end + +to mal_div :a :b +output obj_new "number ((obj_val :a) / (obj_val :b)) +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + localmake "exception error + if not emptyp :exception [ + (print "Error: first butfirst :exception) + ] + ] + ] +] +end + +make "repl_env env_new [] [] [] +ignore env_set :repl_env obj_new "symbol "+ "mal_add +ignore env_set :repl_env obj_new "symbol "- "mal_sub +ignore env_set :repl_env obj_new "symbol "* "mal_mul +ignore env_set :repl_env obj_new "symbol "/ "mal_div +repl +bye diff --git a/impls/logo/step4_if_fn_do.lg b/impls/logo/step4_if_fn_do.lg index fd1293ea3d..4c736d8807 100644 --- a/impls/logo/step4_if_fn_do.lg +++ b/impls/logo/step4_if_fn_do.lg @@ -1,113 +1,113 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg -load "../logo/types.lg -load "../logo/env.lg -load "../logo/core.lg - -to _read :str -output read_str :str -end - -to eval_ast :ast :env -output case (obj_type :ast) [ - [[symbol] env_get :env :ast] - [[list] obj_new "list map [_eval ? :env] obj_val :ast] - [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] - [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] - [else :ast] -] -end - -to _eval :ast :env -if (obj_type :ast) <> "list [output eval_ast :ast :env] -if emptyp obj_val :ast [output :ast] -localmake "a0 nth :ast 0 -case list obj_type :a0 obj_val :a0 [ - [[[symbol def!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - output env_set :env :a1 _eval :a2 :env ] - - [[[symbol let*]] - localmake "a1 nth :ast 1 - localmake "letenv env_new :env [] [] - localmake "i 0 - while [:i < _count :a1] [ - ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv - make "i (:i + 2) - ] - output _eval nth :ast 2 :letenv ] - - [[[symbol do]] - output last obj_val eval_ast rest :ast :env ] - - [[[symbol if]] - localmake "a1 nth :ast 1 - localmake "cond _eval :a1 :env - output case obj_type :cond [ - [[nil false] ifelse (_count :ast) > 3 [ - _eval nth :ast 3 :env - ] [ - nil_new - ]] - [else _eval nth :ast 2 :env] - ]] - - [[[symbol fn*]] - output fn_new nth :ast 1 :env nth :ast 2 ] - - [else - localmake "el eval_ast :ast :env - localmake "f nth :el 0 - case obj_type :f [ - [[nativefn] - output apply obj_val :f butfirst obj_val :el ] - [[fn] - localmake "funcenv env_new fn_env :f fn_args :f rest :el - output _eval fn_body :f :funcenv ] - [else - (throw "error [Wrong type for apply])] - ] ] -] -end - -to _print :exp -output pr_str :exp "true -end - -to re :str -output _eval _read :str :repl_env -end - -to rep :str -output _print re :str -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - localmake "exception error - if not emptyp :exception [ - (print "Error: first butfirst :exception) - ] - ] - ] -] -end - -make "repl_env env_new [] [] [] -foreach :core_ns [ - ignore env_set :repl_env first ? first butfirst ? -] -; core.mal: defined using the language itself -ignore re "|(def! not (fn* (a) (if a false true)))| -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg +load "../logo/types.lg +load "../logo/env.lg +load "../logo/core.lg + +to _read :str +output read_str :str +end + +to eval_ast :ast :env +output case (obj_type :ast) [ + [[symbol] env_get :env :ast] + [[list] obj_new "list map [_eval ? :env] obj_val :ast] + [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] + [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] + [else :ast] +] +end + +to _eval :ast :env +if (obj_type :ast) <> "list [output eval_ast :ast :env] +if emptyp obj_val :ast [output :ast] +localmake "a0 nth :ast 0 +case list obj_type :a0 obj_val :a0 [ + [[[symbol def!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + output env_set :env :a1 _eval :a2 :env ] + + [[[symbol let*]] + localmake "a1 nth :ast 1 + localmake "letenv env_new :env [] [] + localmake "i 0 + while [:i < _count :a1] [ + ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv + make "i (:i + 2) + ] + output _eval nth :ast 2 :letenv ] + + [[[symbol do]] + output last obj_val eval_ast rest :ast :env ] + + [[[symbol if]] + localmake "a1 nth :ast 1 + localmake "cond _eval :a1 :env + output case obj_type :cond [ + [[nil false] ifelse (_count :ast) > 3 [ + _eval nth :ast 3 :env + ] [ + nil_new + ]] + [else _eval nth :ast 2 :env] + ]] + + [[[symbol fn*]] + output fn_new nth :ast 1 :env nth :ast 2 ] + + [else + localmake "el eval_ast :ast :env + localmake "f nth :el 0 + case obj_type :f [ + [[nativefn] + output apply obj_val :f butfirst obj_val :el ] + [[fn] + localmake "funcenv env_new fn_env :f fn_args :f rest :el + output _eval fn_body :f :funcenv ] + [else + (throw "error [Wrong type for apply])] + ] ] +] +end + +to _print :exp +output pr_str :exp "true +end + +to re :str +output _eval _read :str :repl_env +end + +to rep :str +output _print re :str +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + localmake "exception error + if not emptyp :exception [ + (print "Error: first butfirst :exception) + ] + ] + ] +] +end + +make "repl_env env_new [] [] [] +foreach :core_ns [ + ignore env_set :repl_env first ? first butfirst ? +] +; core.mal: defined using the language itself +ignore re "|(def! not (fn* (a) (if a false true)))| +repl +bye diff --git a/impls/logo/step5_tco.lg b/impls/logo/step5_tco.lg index a9171f39a2..43110b3411 100644 --- a/impls/logo/step5_tco.lg +++ b/impls/logo/step5_tco.lg @@ -1,123 +1,123 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg -load "../logo/types.lg -load "../logo/env.lg -load "../logo/core.lg - -to _read :str -output read_str :str -end - -to eval_ast :ast :env -output case (obj_type :ast) [ - [[symbol] env_get :env :ast] - [[list] obj_new "list map [_eval ? :env] obj_val :ast] - [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] - [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] - [else :ast] -] -end - -to _eval :a_ast :a_env -localmake "ast :a_ast -localmake "env :a_env -forever [ - if (obj_type :ast) <> "list [output eval_ast :ast :env] - if emptyp obj_val :ast [output :ast] - localmake "a0 nth :ast 0 - case list obj_type :a0 obj_val :a0 [ - [[[symbol def!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - output env_set :env :a1 _eval :a2 :env ] - - [[[symbol let*]] - localmake "a1 nth :ast 1 - localmake "letenv env_new :env [] [] - localmake "i 0 - while [:i < _count :a1] [ - ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv - make "i (:i + 2) - ] - make "env :letenv - make "ast nth :ast 2 ] ; TCO - - [[[symbol do]] - localmake "i 1 - while [:i < ((_count :ast) - 1)] [ - ignore _eval nth :ast :i :env - make "i (:i + 1) - ] - make "ast last obj_val :ast ] ; TCO - - [[[symbol if]] - localmake "a1 nth :ast 1 - localmake "cond _eval :a1 :env - case obj_type :cond [ - [[nil false] ifelse (_count :ast) > 3 [ - make "ast nth :ast 3 ; TCO - ] [ - output nil_new - ]] - [else make "ast nth :ast 2] ; TCO - ]] - - [[[symbol fn*]] - output fn_new nth :ast 1 :env nth :ast 2 ] - - [else - localmake "el eval_ast :ast :env - localmake "f nth :el 0 - case obj_type :f [ - [[nativefn] - output apply obj_val :f butfirst obj_val :el ] - [[fn] - make "env env_new fn_env :f fn_args :f rest :el - make "ast fn_body :f ] ; TCO - [else - (throw "error [Wrong type for apply])] - ] ] - ] -] -end - -to _print :exp -output pr_str :exp "true -end - -to re :str -output _eval _read :str :repl_env -end - -to rep :str -output _print re :str -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - localmake "exception error - if not emptyp :exception [ - (print "Error: first butfirst :exception) - ] - ] - ] -] -end - -make "repl_env env_new [] [] [] -foreach :core_ns [ - ignore env_set :repl_env first ? first butfirst ? -] -; core.mal: defined using the language itself -ignore re "|(def! not (fn* (a) (if a false true)))| -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg +load "../logo/types.lg +load "../logo/env.lg +load "../logo/core.lg + +to _read :str +output read_str :str +end + +to eval_ast :ast :env +output case (obj_type :ast) [ + [[symbol] env_get :env :ast] + [[list] obj_new "list map [_eval ? :env] obj_val :ast] + [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] + [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] + [else :ast] +] +end + +to _eval :a_ast :a_env +localmake "ast :a_ast +localmake "env :a_env +forever [ + if (obj_type :ast) <> "list [output eval_ast :ast :env] + if emptyp obj_val :ast [output :ast] + localmake "a0 nth :ast 0 + case list obj_type :a0 obj_val :a0 [ + [[[symbol def!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + output env_set :env :a1 _eval :a2 :env ] + + [[[symbol let*]] + localmake "a1 nth :ast 1 + localmake "letenv env_new :env [] [] + localmake "i 0 + while [:i < _count :a1] [ + ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv + make "i (:i + 2) + ] + make "env :letenv + make "ast nth :ast 2 ] ; TCO + + [[[symbol do]] + localmake "i 1 + while [:i < ((_count :ast) - 1)] [ + ignore _eval nth :ast :i :env + make "i (:i + 1) + ] + make "ast last obj_val :ast ] ; TCO + + [[[symbol if]] + localmake "a1 nth :ast 1 + localmake "cond _eval :a1 :env + case obj_type :cond [ + [[nil false] ifelse (_count :ast) > 3 [ + make "ast nth :ast 3 ; TCO + ] [ + output nil_new + ]] + [else make "ast nth :ast 2] ; TCO + ]] + + [[[symbol fn*]] + output fn_new nth :ast 1 :env nth :ast 2 ] + + [else + localmake "el eval_ast :ast :env + localmake "f nth :el 0 + case obj_type :f [ + [[nativefn] + output apply obj_val :f butfirst obj_val :el ] + [[fn] + make "env env_new fn_env :f fn_args :f rest :el + make "ast fn_body :f ] ; TCO + [else + (throw "error [Wrong type for apply])] + ] ] + ] +] +end + +to _print :exp +output pr_str :exp "true +end + +to re :str +output _eval _read :str :repl_env +end + +to rep :str +output _print re :str +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + localmake "exception error + if not emptyp :exception [ + (print "Error: first butfirst :exception) + ] + ] + ] +] +end + +make "repl_env env_new [] [] [] +foreach :core_ns [ + ignore env_set :repl_env first ? first butfirst ? +] +; core.mal: defined using the language itself +ignore re "|(def! not (fn* (a) (if a false true)))| +repl +bye diff --git a/impls/logo/step6_file.lg b/impls/logo/step6_file.lg index ef51812e9a..c03b222f72 100644 --- a/impls/logo/step6_file.lg +++ b/impls/logo/step6_file.lg @@ -1,151 +1,151 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg -load "../logo/types.lg -load "../logo/env.lg -load "../logo/core.lg - -to _read :str -output read_str :str -end - -to eval_ast :ast :env -output case (obj_type :ast) [ - [[symbol] env_get :env :ast] - [[list] obj_new "list map [_eval ? :env] obj_val :ast] - [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] - [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] - [else :ast] -] -end - -to _eval :a_ast :a_env -localmake "ast :a_ast -localmake "env :a_env -forever [ - if (obj_type :ast) <> "list [output eval_ast :ast :env] - if emptyp obj_val :ast [output :ast] - localmake "a0 nth :ast 0 - case list obj_type :a0 obj_val :a0 [ - [[[symbol def!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - output env_set :env :a1 _eval :a2 :env ] - - [[[symbol let*]] - localmake "a1 nth :ast 1 - localmake "letenv env_new :env [] [] - localmake "i 0 - while [:i < _count :a1] [ - ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv - make "i (:i + 2) - ] - make "env :letenv - make "ast nth :ast 2 ] ; TCO - - [[[symbol do]] - localmake "i 1 - while [:i < ((_count :ast) - 1)] [ - ignore _eval nth :ast :i :env - make "i (:i + 1) - ] - make "ast last obj_val :ast ] ; TCO - - [[[symbol if]] - localmake "a1 nth :ast 1 - localmake "cond _eval :a1 :env - case obj_type :cond [ - [[nil false] ifelse (_count :ast) > 3 [ - make "ast nth :ast 3 ; TCO - ] [ - output nil_new - ]] - [else make "ast nth :ast 2] ; TCO - ]] - - [[[symbol fn*]] - output fn_new nth :ast 1 :env nth :ast 2 ] - - [else - localmake "el eval_ast :ast :env - localmake "f nth :el 0 - case obj_type :f [ - [[nativefn] - output apply obj_val :f butfirst obj_val :el ] - [[fn] - make "env env_new fn_env :f fn_args :f rest :el - make "ast fn_body :f ] ; TCO - [else - (throw "error [Wrong type for apply])] - ] ] - ] -] -end - -to _print :exp -output pr_str :exp "true -end - -to re :str -output _eval _read :str :repl_env -end - -to rep :str -output _print re :str -end - -to print_exception :exception -if not emptyp :exception [ - localmake "e first butfirst :exception - ifelse :e = "_mal_exception_ [ - (print "Error: pr_str :global_exception "false) - ] [ - (print "Error: :e) - ] -] -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - print_exception error - ] - ] -] -end - -to mal_eval :a -output _eval :a :repl_env -end - -to argv_list -localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] -output obj_new "list map [obj_new "string ?] :argv -end - -make "repl_env env_new [] [] [] -foreach :core_ns [ - ignore env_set :repl_env first ? first butfirst ? -] -ignore env_set :repl_env [symbol eval] [nativefn mal_eval] -ignore env_set :repl_env [symbol *ARGV*] argv_list - -; core.mal: defined using the language itself -ignore re "|(def! not (fn* (a) (if a false true)))| -ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| - -if not emptyp :command.line [ - catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] - print_exception error - bye -] - -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg +load "../logo/types.lg +load "../logo/env.lg +load "../logo/core.lg + +to _read :str +output read_str :str +end + +to eval_ast :ast :env +output case (obj_type :ast) [ + [[symbol] env_get :env :ast] + [[list] obj_new "list map [_eval ? :env] obj_val :ast] + [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] + [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] + [else :ast] +] +end + +to _eval :a_ast :a_env +localmake "ast :a_ast +localmake "env :a_env +forever [ + if (obj_type :ast) <> "list [output eval_ast :ast :env] + if emptyp obj_val :ast [output :ast] + localmake "a0 nth :ast 0 + case list obj_type :a0 obj_val :a0 [ + [[[symbol def!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + output env_set :env :a1 _eval :a2 :env ] + + [[[symbol let*]] + localmake "a1 nth :ast 1 + localmake "letenv env_new :env [] [] + localmake "i 0 + while [:i < _count :a1] [ + ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv + make "i (:i + 2) + ] + make "env :letenv + make "ast nth :ast 2 ] ; TCO + + [[[symbol do]] + localmake "i 1 + while [:i < ((_count :ast) - 1)] [ + ignore _eval nth :ast :i :env + make "i (:i + 1) + ] + make "ast last obj_val :ast ] ; TCO + + [[[symbol if]] + localmake "a1 nth :ast 1 + localmake "cond _eval :a1 :env + case obj_type :cond [ + [[nil false] ifelse (_count :ast) > 3 [ + make "ast nth :ast 3 ; TCO + ] [ + output nil_new + ]] + [else make "ast nth :ast 2] ; TCO + ]] + + [[[symbol fn*]] + output fn_new nth :ast 1 :env nth :ast 2 ] + + [else + localmake "el eval_ast :ast :env + localmake "f nth :el 0 + case obj_type :f [ + [[nativefn] + output apply obj_val :f butfirst obj_val :el ] + [[fn] + make "env env_new fn_env :f fn_args :f rest :el + make "ast fn_body :f ] ; TCO + [else + (throw "error [Wrong type for apply])] + ] ] + ] +] +end + +to _print :exp +output pr_str :exp "true +end + +to re :str +output _eval _read :str :repl_env +end + +to rep :str +output _print re :str +end + +to print_exception :exception +if not emptyp :exception [ + localmake "e first butfirst :exception + ifelse :e = "_mal_exception_ [ + (print "Error: pr_str :global_exception "false) + ] [ + (print "Error: :e) + ] +] +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + print_exception error + ] + ] +] +end + +to mal_eval :a +output _eval :a :repl_env +end + +to argv_list +localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] +output obj_new "list map [obj_new "string ?] :argv +end + +make "repl_env env_new [] [] [] +foreach :core_ns [ + ignore env_set :repl_env first ? first butfirst ? +] +ignore env_set :repl_env [symbol eval] [nativefn mal_eval] +ignore env_set :repl_env [symbol *ARGV*] argv_list + +; core.mal: defined using the language itself +ignore re "|(def! not (fn* (a) (if a false true)))| +ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| + +if not emptyp :command.line [ + catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] + print_exception error + bye +] + +repl +bye diff --git a/impls/logo/step7_quote.lg b/impls/logo/step7_quote.lg index ff93a88719..f5df29fecb 100644 --- a/impls/logo/step7_quote.lg +++ b/impls/logo/step7_quote.lg @@ -1,186 +1,186 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg -load "../logo/types.lg -load "../logo/env.lg -load "../logo/core.lg - -to _read :str -output read_str :str -end - -to starts_with :ast :sym -if (obj_type :ast) <> "list [output "false] -localmake "xs obj_val :ast -if emptyp :xs [output "false] -localmake "a0 first :xs -output and ((obj_type :a0) = "symbol) ((obj_val :a0) = :sym) -end - -to quasiquote :ast -if memberp obj_type :ast [hashmap symbol] [output (mal_list symbol_new "quote :ast)] -if not sequentialp :ast [output :ast] -if starts_with :ast "unquote [output nth :ast 1] -localmake "result mal_list -foreach reverse obj_val :ast [ - ifelse starts_with ? "splice-unquote [ - make "result (mal_list symbol_new "concat nth ? 1 :result) - ] [ - make "result (mal_list symbol_new "cons quasiquote ? :result) - ] ] -if (obj_type :ast) = "vector [make "result (mal_list symbol_new "vec :result)] -output :result -end - -to eval_ast :ast :env -output case (obj_type :ast) [ - [[symbol] env_get :env :ast] - [[list] obj_new "list map [_eval ? :env] obj_val :ast] - [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] - [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] - [else :ast] -] -end - -to _eval :a_ast :a_env -localmake "ast :a_ast -localmake "env :a_env -forever [ - if (obj_type :ast) <> "list [output eval_ast :ast :env] - if emptyp obj_val :ast [output :ast] - localmake "a0 nth :ast 0 - case list obj_type :a0 obj_val :a0 [ - [[[symbol def!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - output env_set :env :a1 _eval :a2 :env ] - - [[[symbol let*]] - localmake "a1 nth :ast 1 - localmake "letenv env_new :env [] [] - localmake "i 0 - while [:i < _count :a1] [ - ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv - make "i (:i + 2) - ] - make "env :letenv - make "ast nth :ast 2 ] ; TCO - - [[[symbol quote]] - output nth :ast 1 ] - - [[[symbol quasiquote]] - make "ast quasiquote nth :ast 1 ] ; TCO - - [[[symbol quasiquoteexpand]] - output quasiquote nth :ast 1] - - [[[symbol do]] - localmake "i 1 - while [:i < ((_count :ast) - 1)] [ - ignore _eval nth :ast :i :env - make "i (:i + 1) - ] - make "ast last obj_val :ast ] ; TCO - - [[[symbol if]] - localmake "a1 nth :ast 1 - localmake "cond _eval :a1 :env - case obj_type :cond [ - [[nil false] ifelse (_count :ast) > 3 [ - make "ast nth :ast 3 ; TCO - ] [ - output nil_new - ]] - [else make "ast nth :ast 2] ; TCO - ]] - - [[[symbol fn*]] - output fn_new nth :ast 1 :env nth :ast 2 ] - - [else - localmake "el eval_ast :ast :env - localmake "f nth :el 0 - case obj_type :f [ - [[nativefn] - output apply obj_val :f butfirst obj_val :el ] - [[fn] - make "env env_new fn_env :f fn_args :f rest :el - make "ast fn_body :f ] ; TCO - [else - (throw "error [Wrong type for apply])] - ] ] - ] -] -end - -to _print :exp -output pr_str :exp "true -end - -to re :str -output _eval _read :str :repl_env -end - -to rep :str -output _print re :str -end - -to print_exception :exception -if not emptyp :exception [ - localmake "e first butfirst :exception - ifelse :e = "_mal_exception_ [ - (print "Error: pr_str :global_exception "false) - ] [ - (print "Error: :e) - ] -] -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - localmake "exception error - if not emptyp :exception [ - (print "Error: first butfirst :exception) - ] - ] - ] -] -end - -to mal_eval :a -output _eval :a :repl_env -end - -to argv_list -localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] -output obj_new "list map [obj_new "string ?] :argv -end - -make "repl_env env_new [] [] [] -foreach :core_ns [ - ignore env_set :repl_env first ? first butfirst ? -] -ignore env_set :repl_env [symbol eval] [nativefn mal_eval] -ignore env_set :repl_env [symbol *ARGV*] argv_list - -; core.mal: defined using the language itself -ignore re "|(def! not (fn* (a) (if a false true)))| -ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| - -if not emptyp :command.line [ - catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] - print_exception error - bye -] - -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg +load "../logo/types.lg +load "../logo/env.lg +load "../logo/core.lg + +to _read :str +output read_str :str +end + +to starts_with :ast :sym +if (obj_type :ast) <> "list [output "false] +localmake "xs obj_val :ast +if emptyp :xs [output "false] +localmake "a0 first :xs +output and ((obj_type :a0) = "symbol) ((obj_val :a0) = :sym) +end + +to quasiquote :ast +if memberp obj_type :ast [hashmap symbol] [output (mal_list symbol_new "quote :ast)] +if not sequentialp :ast [output :ast] +if starts_with :ast "unquote [output nth :ast 1] +localmake "result mal_list +foreach reverse obj_val :ast [ + ifelse starts_with ? "splice-unquote [ + make "result (mal_list symbol_new "concat nth ? 1 :result) + ] [ + make "result (mal_list symbol_new "cons quasiquote ? :result) + ] ] +if (obj_type :ast) = "vector [make "result (mal_list symbol_new "vec :result)] +output :result +end + +to eval_ast :ast :env +output case (obj_type :ast) [ + [[symbol] env_get :env :ast] + [[list] obj_new "list map [_eval ? :env] obj_val :ast] + [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] + [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] + [else :ast] +] +end + +to _eval :a_ast :a_env +localmake "ast :a_ast +localmake "env :a_env +forever [ + if (obj_type :ast) <> "list [output eval_ast :ast :env] + if emptyp obj_val :ast [output :ast] + localmake "a0 nth :ast 0 + case list obj_type :a0 obj_val :a0 [ + [[[symbol def!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + output env_set :env :a1 _eval :a2 :env ] + + [[[symbol let*]] + localmake "a1 nth :ast 1 + localmake "letenv env_new :env [] [] + localmake "i 0 + while [:i < _count :a1] [ + ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv + make "i (:i + 2) + ] + make "env :letenv + make "ast nth :ast 2 ] ; TCO + + [[[symbol quote]] + output nth :ast 1 ] + + [[[symbol quasiquote]] + make "ast quasiquote nth :ast 1 ] ; TCO + + [[[symbol quasiquoteexpand]] + output quasiquote nth :ast 1] + + [[[symbol do]] + localmake "i 1 + while [:i < ((_count :ast) - 1)] [ + ignore _eval nth :ast :i :env + make "i (:i + 1) + ] + make "ast last obj_val :ast ] ; TCO + + [[[symbol if]] + localmake "a1 nth :ast 1 + localmake "cond _eval :a1 :env + case obj_type :cond [ + [[nil false] ifelse (_count :ast) > 3 [ + make "ast nth :ast 3 ; TCO + ] [ + output nil_new + ]] + [else make "ast nth :ast 2] ; TCO + ]] + + [[[symbol fn*]] + output fn_new nth :ast 1 :env nth :ast 2 ] + + [else + localmake "el eval_ast :ast :env + localmake "f nth :el 0 + case obj_type :f [ + [[nativefn] + output apply obj_val :f butfirst obj_val :el ] + [[fn] + make "env env_new fn_env :f fn_args :f rest :el + make "ast fn_body :f ] ; TCO + [else + (throw "error [Wrong type for apply])] + ] ] + ] +] +end + +to _print :exp +output pr_str :exp "true +end + +to re :str +output _eval _read :str :repl_env +end + +to rep :str +output _print re :str +end + +to print_exception :exception +if not emptyp :exception [ + localmake "e first butfirst :exception + ifelse :e = "_mal_exception_ [ + (print "Error: pr_str :global_exception "false) + ] [ + (print "Error: :e) + ] +] +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + localmake "exception error + if not emptyp :exception [ + (print "Error: first butfirst :exception) + ] + ] + ] +] +end + +to mal_eval :a +output _eval :a :repl_env +end + +to argv_list +localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] +output obj_new "list map [obj_new "string ?] :argv +end + +make "repl_env env_new [] [] [] +foreach :core_ns [ + ignore env_set :repl_env first ? first butfirst ? +] +ignore env_set :repl_env [symbol eval] [nativefn mal_eval] +ignore env_set :repl_env [symbol *ARGV*] argv_list + +; core.mal: defined using the language itself +ignore re "|(def! not (fn* (a) (if a false true)))| +ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| + +if not emptyp :command.line [ + catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] + print_exception error + bye +] + +repl +bye diff --git a/impls/logo/step8_macros.lg b/impls/logo/step8_macros.lg index 4f760d7aea..a09863dbc9 100644 --- a/impls/logo/step8_macros.lg +++ b/impls/logo/step8_macros.lg @@ -1,220 +1,220 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg -load "../logo/types.lg -load "../logo/env.lg -load "../logo/core.lg - -to _read :str -output read_str :str -end - -to starts_with :ast :sym -if (obj_type :ast) <> "list [output "false] -localmake "xs obj_val :ast -if emptyp :xs [output "false] -localmake "a0 first :xs -output and ((obj_type :a0) = "symbol) ((obj_val :a0) = :sym) -end - -to quasiquote :ast -if memberp obj_type :ast [hashmap symbol] [output (mal_list symbol_new "quote :ast)] -if not sequentialp :ast [output :ast] -if starts_with :ast "unquote [output nth :ast 1] -localmake "result mal_list -foreach reverse obj_val :ast [ - ifelse starts_with ? "splice-unquote [ - make "result (mal_list symbol_new "concat nth ? 1 :result) - ] [ - make "result (mal_list symbol_new "cons quasiquote ? :result) - ] ] -if (obj_type :ast) = "vector [make "result (mal_list symbol_new "vec :result)] -output :result -end - -to macrocallp :ast :env -if (obj_type :ast) = "list [ - if (_count :ast) > 0 [ - localmake "a0 nth :ast 0 - if (obj_type :a0) = "symbol [ - if not emptyp env_find :env :a0 [ - localmake "f env_get :env :a0 - if (obj_type :f) = "fn [ - output fn_is_macro :f - ] - ] - ] - ] -] -output "false -end - -to _macroexpand :ast :env -if not macrocallp :ast :env [output :ast] -localmake "a0 nth :ast 0 -localmake "f env_get :env :a0 -output _macroexpand invoke_fn :f rest :ast :env -end - -to eval_ast :ast :env -output case (obj_type :ast) [ - [[symbol] env_get :env :ast] - [[list] obj_new "list map [_eval ? :env] obj_val :ast] - [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] - [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] - [else :ast] -] -end - -to _eval :a_ast :a_env -localmake "ast :a_ast -localmake "env :a_env -forever [ - if (obj_type :ast) <> "list [output eval_ast :ast :env] - make "ast _macroexpand :ast :env - if (obj_type :ast) <> "list [output eval_ast :ast :env] - if emptyp obj_val :ast [output :ast] - localmake "a0 nth :ast 0 - case list obj_type :a0 obj_val :a0 [ - [[[symbol def!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - output env_set :env :a1 _eval :a2 :env ] - - [[[symbol let*]] - localmake "a1 nth :ast 1 - localmake "letenv env_new :env [] [] - localmake "i 0 - while [:i < _count :a1] [ - ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv - make "i (:i + 2) - ] - make "env :letenv - make "ast nth :ast 2 ] ; TCO - - [[[symbol quote]] - output nth :ast 1 ] - - [[[symbol quasiquote]] - make "ast quasiquote nth :ast 1 ] ; TCO - - [[[symbol quasiquoteexpand]] - output quasiquote nth :ast 1] - - [[[symbol defmacro!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - localmake "macro_fn _eval :a2 :env - fn_set_macro :macro_fn - output env_set :env :a1 :macro_fn ] - - [[[symbol macroexpand]] - output _macroexpand nth :ast 1 :env ] - - [[[symbol do]] - localmake "i 1 - while [:i < ((_count :ast) - 1)] [ - ignore _eval nth :ast :i :env - make "i (:i + 1) - ] - make "ast last obj_val :ast ] ; TCO - - [[[symbol if]] - localmake "a1 nth :ast 1 - localmake "cond _eval :a1 :env - case obj_type :cond [ - [[nil false] ifelse (_count :ast) > 3 [ - make "ast nth :ast 3 ; TCO - ] [ - output nil_new - ]] - [else make "ast nth :ast 2] ; TCO - ]] - - [[[symbol fn*]] - output fn_new nth :ast 1 :env nth :ast 2 ] - - [else - localmake "el eval_ast :ast :env - localmake "f nth :el 0 - case obj_type :f [ - [[nativefn] - output apply obj_val :f butfirst obj_val :el ] - [[fn] - make "env env_new fn_env :f fn_args :f rest :el - make "ast fn_body :f ] ; TCO - [else - (throw "error [Wrong type for apply])] - ] ] - ] -] -end - -to _print :exp -output pr_str :exp "true -end - -to re :str -output _eval _read :str :repl_env -end - -to rep :str -output _print re :str -end - -to print_exception :exception -if not emptyp :exception [ - localmake "e first butfirst :exception - ifelse :e = "_mal_exception_ [ - (print "Error: pr_str :global_exception "false) - ] [ - (print "Error: :e) - ] -] -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - print_exception error - ] - ] -] -end - -to mal_eval :a -output _eval :a :repl_env -end - -to argv_list -localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] -output obj_new "list map [obj_new "string ?] :argv -end - -make "repl_env env_new [] [] [] -foreach :core_ns [ - ignore env_set :repl_env first ? first butfirst ? -] -ignore env_set :repl_env [symbol eval] [nativefn mal_eval] -ignore env_set :repl_env [symbol *ARGV*] argv_list - -; core.mal: defined using the language itself -ignore re "|(def! not (fn* (a) (if a false true)))| -ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| -ignore re "|(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)))))))| - -if not emptyp :command.line [ - catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] - print_exception error - bye -] - -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg +load "../logo/types.lg +load "../logo/env.lg +load "../logo/core.lg + +to _read :str +output read_str :str +end + +to starts_with :ast :sym +if (obj_type :ast) <> "list [output "false] +localmake "xs obj_val :ast +if emptyp :xs [output "false] +localmake "a0 first :xs +output and ((obj_type :a0) = "symbol) ((obj_val :a0) = :sym) +end + +to quasiquote :ast +if memberp obj_type :ast [hashmap symbol] [output (mal_list symbol_new "quote :ast)] +if not sequentialp :ast [output :ast] +if starts_with :ast "unquote [output nth :ast 1] +localmake "result mal_list +foreach reverse obj_val :ast [ + ifelse starts_with ? "splice-unquote [ + make "result (mal_list symbol_new "concat nth ? 1 :result) + ] [ + make "result (mal_list symbol_new "cons quasiquote ? :result) + ] ] +if (obj_type :ast) = "vector [make "result (mal_list symbol_new "vec :result)] +output :result +end + +to macrocallp :ast :env +if (obj_type :ast) = "list [ + if (_count :ast) > 0 [ + localmake "a0 nth :ast 0 + if (obj_type :a0) = "symbol [ + if not emptyp env_find :env :a0 [ + localmake "f env_get :env :a0 + if (obj_type :f) = "fn [ + output fn_is_macro :f + ] + ] + ] + ] +] +output "false +end + +to _macroexpand :ast :env +if not macrocallp :ast :env [output :ast] +localmake "a0 nth :ast 0 +localmake "f env_get :env :a0 +output _macroexpand invoke_fn :f rest :ast :env +end + +to eval_ast :ast :env +output case (obj_type :ast) [ + [[symbol] env_get :env :ast] + [[list] obj_new "list map [_eval ? :env] obj_val :ast] + [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] + [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] + [else :ast] +] +end + +to _eval :a_ast :a_env +localmake "ast :a_ast +localmake "env :a_env +forever [ + if (obj_type :ast) <> "list [output eval_ast :ast :env] + make "ast _macroexpand :ast :env + if (obj_type :ast) <> "list [output eval_ast :ast :env] + if emptyp obj_val :ast [output :ast] + localmake "a0 nth :ast 0 + case list obj_type :a0 obj_val :a0 [ + [[[symbol def!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + output env_set :env :a1 _eval :a2 :env ] + + [[[symbol let*]] + localmake "a1 nth :ast 1 + localmake "letenv env_new :env [] [] + localmake "i 0 + while [:i < _count :a1] [ + ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv + make "i (:i + 2) + ] + make "env :letenv + make "ast nth :ast 2 ] ; TCO + + [[[symbol quote]] + output nth :ast 1 ] + + [[[symbol quasiquote]] + make "ast quasiquote nth :ast 1 ] ; TCO + + [[[symbol quasiquoteexpand]] + output quasiquote nth :ast 1] + + [[[symbol defmacro!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + localmake "macro_fn _eval :a2 :env + fn_set_macro :macro_fn + output env_set :env :a1 :macro_fn ] + + [[[symbol macroexpand]] + output _macroexpand nth :ast 1 :env ] + + [[[symbol do]] + localmake "i 1 + while [:i < ((_count :ast) - 1)] [ + ignore _eval nth :ast :i :env + make "i (:i + 1) + ] + make "ast last obj_val :ast ] ; TCO + + [[[symbol if]] + localmake "a1 nth :ast 1 + localmake "cond _eval :a1 :env + case obj_type :cond [ + [[nil false] ifelse (_count :ast) > 3 [ + make "ast nth :ast 3 ; TCO + ] [ + output nil_new + ]] + [else make "ast nth :ast 2] ; TCO + ]] + + [[[symbol fn*]] + output fn_new nth :ast 1 :env nth :ast 2 ] + + [else + localmake "el eval_ast :ast :env + localmake "f nth :el 0 + case obj_type :f [ + [[nativefn] + output apply obj_val :f butfirst obj_val :el ] + [[fn] + make "env env_new fn_env :f fn_args :f rest :el + make "ast fn_body :f ] ; TCO + [else + (throw "error [Wrong type for apply])] + ] ] + ] +] +end + +to _print :exp +output pr_str :exp "true +end + +to re :str +output _eval _read :str :repl_env +end + +to rep :str +output _print re :str +end + +to print_exception :exception +if not emptyp :exception [ + localmake "e first butfirst :exception + ifelse :e = "_mal_exception_ [ + (print "Error: pr_str :global_exception "false) + ] [ + (print "Error: :e) + ] +] +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + print_exception error + ] + ] +] +end + +to mal_eval :a +output _eval :a :repl_env +end + +to argv_list +localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] +output obj_new "list map [obj_new "string ?] :argv +end + +make "repl_env env_new [] [] [] +foreach :core_ns [ + ignore env_set :repl_env first ? first butfirst ? +] +ignore env_set :repl_env [symbol eval] [nativefn mal_eval] +ignore env_set :repl_env [symbol *ARGV*] argv_list + +; core.mal: defined using the language itself +ignore re "|(def! not (fn* (a) (if a false true)))| +ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| +ignore re "|(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)))))))| + +if not emptyp :command.line [ + catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] + print_exception error + bye +] + +repl +bye diff --git a/impls/logo/step9_try.lg b/impls/logo/step9_try.lg index de7882edef..553b94c630 100644 --- a/impls/logo/step9_try.lg +++ b/impls/logo/step9_try.lg @@ -1,239 +1,239 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg -load "../logo/types.lg -load "../logo/env.lg -load "../logo/core.lg - -to _read :str -output read_str :str -end - -to starts_with :ast :sym -if (obj_type :ast) <> "list [output "false] -localmake "xs obj_val :ast -if emptyp :xs [output "false] -localmake "a0 first :xs -output and ((obj_type :a0) = "symbol) ((obj_val :a0) = :sym) -end - -to quasiquote :ast -if memberp obj_type :ast [hashmap symbol] [output (mal_list symbol_new "quote :ast)] -if not sequentialp :ast [output :ast] -if starts_with :ast "unquote [output nth :ast 1] -localmake "result mal_list -foreach reverse obj_val :ast [ - ifelse starts_with ? "splice-unquote [ - make "result (mal_list symbol_new "concat nth ? 1 :result) - ] [ - make "result (mal_list symbol_new "cons quasiquote ? :result) - ] ] -if (obj_type :ast) = "vector [make "result (mal_list symbol_new "vec :result)] -output :result -end - -to macrocallp :ast :env -if (obj_type :ast) = "list [ - if (_count :ast) > 0 [ - localmake "a0 nth :ast 0 - if (obj_type :a0) = "symbol [ - if not emptyp env_find :env :a0 [ - localmake "f env_get :env :a0 - if (obj_type :f) = "fn [ - output fn_is_macro :f - ] - ] - ] - ] -] -output "false -end - -to _macroexpand :ast :env -if not macrocallp :ast :env [output :ast] -localmake "a0 nth :ast 0 -localmake "f env_get :env :a0 -output _macroexpand invoke_fn :f rest :ast :env -end - -to eval_ast :ast :env -output case (obj_type :ast) [ - [[symbol] env_get :env :ast] - [[list] obj_new "list map [_eval ? :env] obj_val :ast] - [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] - [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] - [else :ast] -] -end - -to _eval :a_ast :a_env -localmake "ast :a_ast -localmake "env :a_env -forever [ - if (obj_type :ast) <> "list [output eval_ast :ast :env] - make "ast _macroexpand :ast :env - if (obj_type :ast) <> "list [output eval_ast :ast :env] - if emptyp obj_val :ast [output :ast] - localmake "a0 nth :ast 0 - case list obj_type :a0 obj_val :a0 [ - [[[symbol def!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - output env_set :env :a1 _eval :a2 :env ] - - [[[symbol let*]] - localmake "a1 nth :ast 1 - localmake "letenv env_new :env [] [] - localmake "i 0 - while [:i < _count :a1] [ - ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv - make "i (:i + 2) - ] - make "env :letenv - make "ast nth :ast 2 ] ; TCO - - [[[symbol quote]] - output nth :ast 1 ] - - [[[symbol quasiquote]] - make "ast quasiquote nth :ast 1 ] ; TCO - - [[[symbol quasiquoteexpand]] - output quasiquote nth :ast 1] - - [[[symbol defmacro!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - localmake "macro_fn _eval :a2 :env - fn_set_macro :macro_fn - output env_set :env :a1 :macro_fn ] - - [[[symbol macroexpand]] - output _macroexpand nth :ast 1 :env ] - - [[[symbol try*]] - localmake "a1 nth :ast 1 - if (_count :ast) < 3 [ - output _eval :a1 :env - ] - localmake "result nil_new - catch "error [make "result _eval :a1 :env] - localmake "exception error - ifelse emptyp :exception [ - output :result - ] [ - localmake "e first butfirst :exception - localmake "exception_obj ifelse :e = "_mal_exception_ [:global_exception] [obj_new "string :e] - localmake "a2 nth :ast 2 - localmake "catchenv env_new :env [] [] - ignore env_set :catchenv nth :a2 1 :exception_obj - output _eval nth :a2 2 :catchenv - ] ] - - [[[symbol do]] - localmake "i 1 - while [:i < ((_count :ast) - 1)] [ - ignore _eval nth :ast :i :env - make "i (:i + 1) - ] - make "ast last obj_val :ast ] ; TCO - - [[[symbol if]] - localmake "a1 nth :ast 1 - localmake "cond _eval :a1 :env - case obj_type :cond [ - [[nil false] ifelse (_count :ast) > 3 [ - make "ast nth :ast 3 ; TCO - ] [ - output nil_new - ]] - [else make "ast nth :ast 2] ; TCO - ]] - - [[[symbol fn*]] - output fn_new nth :ast 1 :env nth :ast 2 ] - - [else - localmake "el eval_ast :ast :env - localmake "f nth :el 0 - case obj_type :f [ - [[nativefn] - output apply obj_val :f butfirst obj_val :el ] - [[fn] - make "env env_new fn_env :f fn_args :f rest :el - make "ast fn_body :f ] ; TCO - [else - (throw "error [Wrong type for apply])] - ] ] - ] -] -end - -to _print :exp -output pr_str :exp "true -end - -to re :str -output _eval _read :str :repl_env -end - -to rep :str -output _print re :str -end - -to print_exception :exception -if not emptyp :exception [ - localmake "e first butfirst :exception - ifelse :e = "_mal_exception_ [ - (print "Error: pr_str :global_exception "false) - ] [ - (print "Error: :e) - ] -] -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - print_exception error - ] - ] -] -end - -to mal_eval :a -output _eval :a :repl_env -end - -to argv_list -localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] -output obj_new "list map [obj_new "string ?] :argv -end - -make "repl_env env_new [] [] [] -foreach :core_ns [ - ignore env_set :repl_env first ? first butfirst ? -] -ignore env_set :repl_env [symbol eval] [nativefn mal_eval] -ignore env_set :repl_env [symbol *ARGV*] argv_list - -; core.mal: defined using the language itself -ignore re "|(def! not (fn* (a) (if a false true)))| -ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| -ignore re "|(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)))))))| - -if not emptyp :command.line [ - catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] - print_exception error - bye -] - -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg +load "../logo/types.lg +load "../logo/env.lg +load "../logo/core.lg + +to _read :str +output read_str :str +end + +to starts_with :ast :sym +if (obj_type :ast) <> "list [output "false] +localmake "xs obj_val :ast +if emptyp :xs [output "false] +localmake "a0 first :xs +output and ((obj_type :a0) = "symbol) ((obj_val :a0) = :sym) +end + +to quasiquote :ast +if memberp obj_type :ast [hashmap symbol] [output (mal_list symbol_new "quote :ast)] +if not sequentialp :ast [output :ast] +if starts_with :ast "unquote [output nth :ast 1] +localmake "result mal_list +foreach reverse obj_val :ast [ + ifelse starts_with ? "splice-unquote [ + make "result (mal_list symbol_new "concat nth ? 1 :result) + ] [ + make "result (mal_list symbol_new "cons quasiquote ? :result) + ] ] +if (obj_type :ast) = "vector [make "result (mal_list symbol_new "vec :result)] +output :result +end + +to macrocallp :ast :env +if (obj_type :ast) = "list [ + if (_count :ast) > 0 [ + localmake "a0 nth :ast 0 + if (obj_type :a0) = "symbol [ + if not emptyp env_find :env :a0 [ + localmake "f env_get :env :a0 + if (obj_type :f) = "fn [ + output fn_is_macro :f + ] + ] + ] + ] +] +output "false +end + +to _macroexpand :ast :env +if not macrocallp :ast :env [output :ast] +localmake "a0 nth :ast 0 +localmake "f env_get :env :a0 +output _macroexpand invoke_fn :f rest :ast :env +end + +to eval_ast :ast :env +output case (obj_type :ast) [ + [[symbol] env_get :env :ast] + [[list] obj_new "list map [_eval ? :env] obj_val :ast] + [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] + [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] + [else :ast] +] +end + +to _eval :a_ast :a_env +localmake "ast :a_ast +localmake "env :a_env +forever [ + if (obj_type :ast) <> "list [output eval_ast :ast :env] + make "ast _macroexpand :ast :env + if (obj_type :ast) <> "list [output eval_ast :ast :env] + if emptyp obj_val :ast [output :ast] + localmake "a0 nth :ast 0 + case list obj_type :a0 obj_val :a0 [ + [[[symbol def!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + output env_set :env :a1 _eval :a2 :env ] + + [[[symbol let*]] + localmake "a1 nth :ast 1 + localmake "letenv env_new :env [] [] + localmake "i 0 + while [:i < _count :a1] [ + ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv + make "i (:i + 2) + ] + make "env :letenv + make "ast nth :ast 2 ] ; TCO + + [[[symbol quote]] + output nth :ast 1 ] + + [[[symbol quasiquote]] + make "ast quasiquote nth :ast 1 ] ; TCO + + [[[symbol quasiquoteexpand]] + output quasiquote nth :ast 1] + + [[[symbol defmacro!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + localmake "macro_fn _eval :a2 :env + fn_set_macro :macro_fn + output env_set :env :a1 :macro_fn ] + + [[[symbol macroexpand]] + output _macroexpand nth :ast 1 :env ] + + [[[symbol try*]] + localmake "a1 nth :ast 1 + if (_count :ast) < 3 [ + output _eval :a1 :env + ] + localmake "result nil_new + catch "error [make "result _eval :a1 :env] + localmake "exception error + ifelse emptyp :exception [ + output :result + ] [ + localmake "e first butfirst :exception + localmake "exception_obj ifelse :e = "_mal_exception_ [:global_exception] [obj_new "string :e] + localmake "a2 nth :ast 2 + localmake "catchenv env_new :env [] [] + ignore env_set :catchenv nth :a2 1 :exception_obj + output _eval nth :a2 2 :catchenv + ] ] + + [[[symbol do]] + localmake "i 1 + while [:i < ((_count :ast) - 1)] [ + ignore _eval nth :ast :i :env + make "i (:i + 1) + ] + make "ast last obj_val :ast ] ; TCO + + [[[symbol if]] + localmake "a1 nth :ast 1 + localmake "cond _eval :a1 :env + case obj_type :cond [ + [[nil false] ifelse (_count :ast) > 3 [ + make "ast nth :ast 3 ; TCO + ] [ + output nil_new + ]] + [else make "ast nth :ast 2] ; TCO + ]] + + [[[symbol fn*]] + output fn_new nth :ast 1 :env nth :ast 2 ] + + [else + localmake "el eval_ast :ast :env + localmake "f nth :el 0 + case obj_type :f [ + [[nativefn] + output apply obj_val :f butfirst obj_val :el ] + [[fn] + make "env env_new fn_env :f fn_args :f rest :el + make "ast fn_body :f ] ; TCO + [else + (throw "error [Wrong type for apply])] + ] ] + ] +] +end + +to _print :exp +output pr_str :exp "true +end + +to re :str +output _eval _read :str :repl_env +end + +to rep :str +output _print re :str +end + +to print_exception :exception +if not emptyp :exception [ + localmake "e first butfirst :exception + ifelse :e = "_mal_exception_ [ + (print "Error: pr_str :global_exception "false) + ] [ + (print "Error: :e) + ] +] +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + print_exception error + ] + ] +] +end + +to mal_eval :a +output _eval :a :repl_env +end + +to argv_list +localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] +output obj_new "list map [obj_new "string ?] :argv +end + +make "repl_env env_new [] [] [] +foreach :core_ns [ + ignore env_set :repl_env first ? first butfirst ? +] +ignore env_set :repl_env [symbol eval] [nativefn mal_eval] +ignore env_set :repl_env [symbol *ARGV*] argv_list + +; core.mal: defined using the language itself +ignore re "|(def! not (fn* (a) (if a false true)))| +ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| +ignore re "|(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)))))))| + +if not emptyp :command.line [ + catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] + print_exception error + bye +] + +repl +bye diff --git a/impls/logo/stepA_mal.lg b/impls/logo/stepA_mal.lg index c3d1340444..295176d3dc 100644 --- a/impls/logo/stepA_mal.lg +++ b/impls/logo/stepA_mal.lg @@ -1,241 +1,241 @@ -load "../logo/readline.lg -load "../logo/reader.lg -load "../logo/printer.lg -load "../logo/types.lg -load "../logo/env.lg -load "../logo/core.lg - -to _read :str -output read_str :str -end - -to starts_with :ast :sym -if (obj_type :ast) <> "list [output "false] -localmake "xs obj_val :ast -if emptyp :xs [output "false] -localmake "a0 first :xs -output and ((obj_type :a0) = "symbol) ((obj_val :a0) = :sym) -end - -to quasiquote :ast -if memberp obj_type :ast [hashmap symbol] [output (mal_list symbol_new "quote :ast)] -if not sequentialp :ast [output :ast] -if starts_with :ast "unquote [output nth :ast 1] -localmake "result mal_list -foreach reverse obj_val :ast [ - ifelse starts_with ? "splice-unquote [ - make "result (mal_list symbol_new "concat nth ? 1 :result) - ] [ - make "result (mal_list symbol_new "cons quasiquote ? :result) - ] ] -if (obj_type :ast) = "vector [make "result (mal_list symbol_new "vec :result)] -output :result -end - -to macrocallp :ast :env -if (obj_type :ast) = "list [ - if (_count :ast) > 0 [ - localmake "a0 nth :ast 0 - if (obj_type :a0) = "symbol [ - if not emptyp env_find :env :a0 [ - localmake "f env_get :env :a0 - if (obj_type :f) = "fn [ - output fn_is_macro :f - ] - ] - ] - ] -] -output "false -end - -to _macroexpand :ast :env -if not macrocallp :ast :env [output :ast] -localmake "a0 nth :ast 0 -localmake "f env_get :env :a0 -output _macroexpand invoke_fn :f rest :ast :env -end - -to eval_ast :ast :env -output case (obj_type :ast) [ - [[symbol] env_get :env :ast] - [[list] obj_new "list map [_eval ? :env] obj_val :ast] - [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] - [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] - [else :ast] -] -end - -to _eval :a_ast :a_env -localmake "ast :a_ast -localmake "env :a_env -forever [ - if (obj_type :ast) <> "list [output eval_ast :ast :env] - make "ast _macroexpand :ast :env - if (obj_type :ast) <> "list [output eval_ast :ast :env] - if emptyp obj_val :ast [output :ast] - localmake "a0 nth :ast 0 - case list obj_type :a0 obj_val :a0 [ - [[[symbol def!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - output env_set :env :a1 _eval :a2 :env ] - - [[[symbol let*]] - localmake "a1 nth :ast 1 - localmake "letenv env_new :env [] [] - localmake "i 0 - while [:i < _count :a1] [ - ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv - make "i (:i + 2) - ] - make "env :letenv - make "ast nth :ast 2 ] ; TCO - - [[[symbol quote]] - output nth :ast 1 ] - - [[[symbol quasiquote]] - make "ast quasiquote nth :ast 1 ] ; TCO - - [[[symbol quasiquoteexpand]] - output quasiquote nth :ast 1] - - [[[symbol defmacro!]] - localmake "a1 nth :ast 1 - localmake "a2 nth :ast 2 - localmake "macro_fn _eval :a2 :env - fn_set_macro :macro_fn - output env_set :env :a1 :macro_fn ] - - [[[symbol macroexpand]] - output _macroexpand nth :ast 1 :env ] - - [[[symbol try*]] - localmake "a1 nth :ast 1 - if (_count :ast) < 3 [ - output _eval :a1 :env - ] - localmake "result nil_new - catch "error [make "result _eval :a1 :env] - localmake "exception error - ifelse emptyp :exception [ - output :result - ] [ - localmake "e first butfirst :exception - localmake "exception_obj ifelse :e = "_mal_exception_ [:global_exception] [obj_new "string :e] - localmake "a2 nth :ast 2 - localmake "catchenv env_new :env [] [] - ignore env_set :catchenv nth :a2 1 :exception_obj - output _eval nth :a2 2 :catchenv - ] ] - - [[[symbol do]] - localmake "i 1 - while [:i < ((_count :ast) - 1)] [ - ignore _eval nth :ast :i :env - make "i (:i + 1) - ] - make "ast last obj_val :ast ] ; TCO - - [[[symbol if]] - localmake "a1 nth :ast 1 - localmake "cond _eval :a1 :env - case obj_type :cond [ - [[nil false] ifelse (_count :ast) > 3 [ - make "ast nth :ast 3 ; TCO - ] [ - output nil_new - ]] - [else make "ast nth :ast 2] ; TCO - ]] - - [[[symbol fn*]] - output fn_new nth :ast 1 :env nth :ast 2 ] - - [else - localmake "el eval_ast :ast :env - localmake "f nth :el 0 - case obj_type :f [ - [[nativefn] - output apply obj_val :f butfirst obj_val :el ] - [[fn] - make "env env_new fn_env :f fn_args :f rest :el - make "ast fn_body :f ] ; TCO - [else - (throw "error [Wrong type for apply])] - ] ] - ] -] -end - -to _print :exp -output pr_str :exp "true -end - -to re :str -output _eval _read :str :repl_env -end - -to rep :str -output _print re :str -end - -to print_exception :exception -if not emptyp :exception [ - localmake "e first butfirst :exception - ifelse :e = "_mal_exception_ [ - (print "Error: pr_str :global_exception "false) - ] [ - (print "Error: :e) - ] -] -end - -to repl -localmake "running "true -while [:running] [ - localmake "line readline word "user> :space_char - ifelse :line=[] [ - print " - make "running "false - ] [ - if not emptyp :line [ - catch "error [print rep :line] - print_exception error - ] - ] -] -end - -to mal_eval :a -output _eval :a :repl_env -end - -to argv_list -localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] -output obj_new "list map [obj_new "string ?] :argv -end - -make "repl_env env_new [] [] [] -foreach :core_ns [ - ignore env_set :repl_env first ? first butfirst ? -] -ignore env_set :repl_env [symbol eval] [nativefn mal_eval] -ignore env_set :repl_env [symbol *ARGV*] argv_list - -; core.mal: defined using the language itself -ignore re "|(def! *host-language* "logo")| -ignore re "|(def! not (fn* (a) (if a false true)))| -ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| -ignore re "|(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)))))))| - -if not emptyp :command.line [ - catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] - print_exception error - bye -] - -ignore re "|(println (str "Mal [" *host-language* "]"))| -repl -bye +load "../logo/readline.lg +load "../logo/reader.lg +load "../logo/printer.lg +load "../logo/types.lg +load "../logo/env.lg +load "../logo/core.lg + +to _read :str +output read_str :str +end + +to starts_with :ast :sym +if (obj_type :ast) <> "list [output "false] +localmake "xs obj_val :ast +if emptyp :xs [output "false] +localmake "a0 first :xs +output and ((obj_type :a0) = "symbol) ((obj_val :a0) = :sym) +end + +to quasiquote :ast +if memberp obj_type :ast [hashmap symbol] [output (mal_list symbol_new "quote :ast)] +if not sequentialp :ast [output :ast] +if starts_with :ast "unquote [output nth :ast 1] +localmake "result mal_list +foreach reverse obj_val :ast [ + ifelse starts_with ? "splice-unquote [ + make "result (mal_list symbol_new "concat nth ? 1 :result) + ] [ + make "result (mal_list symbol_new "cons quasiquote ? :result) + ] ] +if (obj_type :ast) = "vector [make "result (mal_list symbol_new "vec :result)] +output :result +end + +to macrocallp :ast :env +if (obj_type :ast) = "list [ + if (_count :ast) > 0 [ + localmake "a0 nth :ast 0 + if (obj_type :a0) = "symbol [ + if not emptyp env_find :env :a0 [ + localmake "f env_get :env :a0 + if (obj_type :f) = "fn [ + output fn_is_macro :f + ] + ] + ] + ] +] +output "false +end + +to _macroexpand :ast :env +if not macrocallp :ast :env [output :ast] +localmake "a0 nth :ast 0 +localmake "f env_get :env :a0 +output _macroexpand invoke_fn :f rest :ast :env +end + +to eval_ast :ast :env +output case (obj_type :ast) [ + [[symbol] env_get :env :ast] + [[list] obj_new "list map [_eval ? :env] obj_val :ast] + [[vector] obj_new "vector map [_eval ? :env] obj_val :ast] + [[hashmap] obj_new "hashmap map [_eval ? :env] obj_val :ast] + [else :ast] +] +end + +to _eval :a_ast :a_env +localmake "ast :a_ast +localmake "env :a_env +forever [ + if (obj_type :ast) <> "list [output eval_ast :ast :env] + make "ast _macroexpand :ast :env + if (obj_type :ast) <> "list [output eval_ast :ast :env] + if emptyp obj_val :ast [output :ast] + localmake "a0 nth :ast 0 + case list obj_type :a0 obj_val :a0 [ + [[[symbol def!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + output env_set :env :a1 _eval :a2 :env ] + + [[[symbol let*]] + localmake "a1 nth :ast 1 + localmake "letenv env_new :env [] [] + localmake "i 0 + while [:i < _count :a1] [ + ignore env_set :letenv nth :a1 :i _eval nth :a1 (:i + 1) :letenv + make "i (:i + 2) + ] + make "env :letenv + make "ast nth :ast 2 ] ; TCO + + [[[symbol quote]] + output nth :ast 1 ] + + [[[symbol quasiquote]] + make "ast quasiquote nth :ast 1 ] ; TCO + + [[[symbol quasiquoteexpand]] + output quasiquote nth :ast 1] + + [[[symbol defmacro!]] + localmake "a1 nth :ast 1 + localmake "a2 nth :ast 2 + localmake "macro_fn _eval :a2 :env + fn_set_macro :macro_fn + output env_set :env :a1 :macro_fn ] + + [[[symbol macroexpand]] + output _macroexpand nth :ast 1 :env ] + + [[[symbol try*]] + localmake "a1 nth :ast 1 + if (_count :ast) < 3 [ + output _eval :a1 :env + ] + localmake "result nil_new + catch "error [make "result _eval :a1 :env] + localmake "exception error + ifelse emptyp :exception [ + output :result + ] [ + localmake "e first butfirst :exception + localmake "exception_obj ifelse :e = "_mal_exception_ [:global_exception] [obj_new "string :e] + localmake "a2 nth :ast 2 + localmake "catchenv env_new :env [] [] + ignore env_set :catchenv nth :a2 1 :exception_obj + output _eval nth :a2 2 :catchenv + ] ] + + [[[symbol do]] + localmake "i 1 + while [:i < ((_count :ast) - 1)] [ + ignore _eval nth :ast :i :env + make "i (:i + 1) + ] + make "ast last obj_val :ast ] ; TCO + + [[[symbol if]] + localmake "a1 nth :ast 1 + localmake "cond _eval :a1 :env + case obj_type :cond [ + [[nil false] ifelse (_count :ast) > 3 [ + make "ast nth :ast 3 ; TCO + ] [ + output nil_new + ]] + [else make "ast nth :ast 2] ; TCO + ]] + + [[[symbol fn*]] + output fn_new nth :ast 1 :env nth :ast 2 ] + + [else + localmake "el eval_ast :ast :env + localmake "f nth :el 0 + case obj_type :f [ + [[nativefn] + output apply obj_val :f butfirst obj_val :el ] + [[fn] + make "env env_new fn_env :f fn_args :f rest :el + make "ast fn_body :f ] ; TCO + [else + (throw "error [Wrong type for apply])] + ] ] + ] +] +end + +to _print :exp +output pr_str :exp "true +end + +to re :str +output _eval _read :str :repl_env +end + +to rep :str +output _print re :str +end + +to print_exception :exception +if not emptyp :exception [ + localmake "e first butfirst :exception + ifelse :e = "_mal_exception_ [ + (print "Error: pr_str :global_exception "false) + ] [ + (print "Error: :e) + ] +] +end + +to repl +localmake "running "true +while [:running] [ + localmake "line readline word "user> :space_char + ifelse :line=[] [ + print " + make "running "false + ] [ + if not emptyp :line [ + catch "error [print rep :line] + print_exception error + ] + ] +] +end + +to mal_eval :a +output _eval :a :repl_env +end + +to argv_list +localmake "argv ifelse emptyp :command.line [[]] [butfirst :command.line] +output obj_new "list map [obj_new "string ?] :argv +end + +make "repl_env env_new [] [] [] +foreach :core_ns [ + ignore env_set :repl_env first ? first butfirst ? +] +ignore env_set :repl_env [symbol eval] [nativefn mal_eval] +ignore env_set :repl_env [symbol *ARGV*] argv_list + +; core.mal: defined using the language itself +ignore re "|(def! *host-language* "logo")| +ignore re "|(def! not (fn* (a) (if a false true)))| +ignore re "|(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))| +ignore re "|(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)))))))| + +if not emptyp :command.line [ + catch "error [ignore re (word "\(load-file :space_char "\" first :command.line "\"\) )] + print_exception error + bye +] + +ignore re "|(println (str "Mal [" *host-language* "]"))| +repl +bye diff --git a/impls/logo/tests/stepA_mal.mal b/impls/logo/tests/stepA_mal.mal index 9175626d1f..6124862033 100644 --- a/impls/logo/tests/stepA_mal.mal +++ b/impls/logo/tests/stepA_mal.mal @@ -1,30 +1,30 @@ -;; Testing basic Logo interop - -(logo-eval "7") -;=>7 - -(logo-eval "\"hello") -;=>"hello" - -(logo-eval "[7 8 9]") -;=>(7 8 9) - -(logo-eval "123 = 123") -;=>true - -(logo-eval "not emptyp []") -;=>false - -(logo-eval "print [hello world]") -;/hello world -;=>nil - -(logo-eval "make \"foo 8") -(logo-eval ":foo") -;=>8 - -(logo-eval "apply \"word map [reverse ?] [Abc Abcd Abcde]") -;=>"cbAdcbAedcbA" - -(logo-eval "map [1 + ?] [1 2 3]") -;=>(2 3 4) +;; Testing basic Logo interop + +(logo-eval "7") +;=>7 + +(logo-eval "\"hello") +;=>"hello" + +(logo-eval "[7 8 9]") +;=>(7 8 9) + +(logo-eval "123 = 123") +;=>true + +(logo-eval "not emptyp []") +;=>false + +(logo-eval "print [hello world]") +;/hello world +;=>nil + +(logo-eval "make \"foo 8") +(logo-eval ":foo") +;=>8 + +(logo-eval "apply \"word map [reverse ?] [Abc Abcd Abcde]") +;=>"cbAdcbAedcbA" + +(logo-eval "map [1 + ?] [1 2 3]") +;=>(2 3 4) diff --git a/impls/logo/types.lg b/impls/logo/types.lg index dd5fcd1a98..d09a160716 100644 --- a/impls/logo/types.lg +++ b/impls/logo/types.lg @@ -1,171 +1,171 @@ -; Make Logo's string-comparison case sensitive -make "caseignoredp "false - -; Load the 'case' library macro -case "dummy [] - -; Redefine 'case' macro to not override caseignoredp -.macro case :case.value :case.clauses -catch "case.error [output case.helper :case.value :case.clauses] -(throw "error [Empty CASE clause]) -end - -to obj_new :type :val -output list :type :val -end - -to obj_new_with_meta :type :val :meta -output (list :type :val :meta) -end - -to obj_type :obj -output first :obj -end - -to obj_val :obj -output item 2 :obj -end - -to obj_meta :obj -if (count :obj) < 3 [output []] -output item 3 :obj -end - -make "global_nil obj_new "nil [] - -to nil_new -output :global_nil -end - -make "global_true obj_new "true [] - -to true_new -output :global_true -end - -make "global_false obj_new "false [] - -to false_new -output :global_false -end - -to symbol_new :name -output obj_new "symbol :name -end - -to hashmap_get :h :key -localmake "i 1 -while [:i < count :h] [ - if equal_q item :i :h :key [ - output item (:i + 1) :h - ] - make "i (:i + 2) -] -output [] -end - -; Returns a new list with the key-val pair set -to hashmap_put :h :key :val -localmake "res hashmap_delete :h :key -make "res lput :key :res -make "res lput :val :res -output :res -end - -; Returns a new list without the key-val pair set -to hashmap_delete :h :key -localmake "res [] -localmake "i 1 -while [:i < count :h] [ - if (item :i :h) <> :key [ - make "res lput item :i :h :res - make "res lput item (:i + 1) :h :res - ] - make "i (:i + 2) -] -output :res -end - -to fn_new :args :env :body -output obj_new "fn (list :args :env :body "false) -end - -to fn_args :fn -output item 1 obj_val :fn -end - -to fn_env :fn -output item 2 obj_val :fn -end - -to fn_body :fn -output item 3 obj_val :fn -end - -to fn_is_macro :fn -output item 4 obj_val :fn -end - -to fn_set_macro :fn -.setfirst butfirst butfirst butfirst obj_val :fn "true -end - -; zero-based sequence addressing -to nth :seq :index -output item (:index + 1) obj_val :seq -end - -to _count :seq -output count obj_val :seq -end - -to rest :seq -output obj_new obj_type :seq butfirst obj_val :seq -end - -to drop :seq :num -if or :num = 0 (_count :seq) = 0 [output :seq] -foreach obj_val :seq [ - if # >= :num [output obj_new obj_type :seq ?rest] -] -end - -to sequentialp :obj -output memberp obj_type :obj [list vector] -end - -to equal_sequential_q :a :b -if (_count :a) <> (_count :b) [output "false] -(foreach obj_val :a obj_val :b [ - if not equal_q ?1 ?2 [output "false] -]) -output "true -end - -to equal_hashmap_q :a :b -if (_count :a) <> (_count :b) [output "false] -localmake "a_keys obj_val mal_keys :a -foreach :a_keys [ - localmake "a_val hashmap_get obj_val :a ? - localmake "b_val hashmap_get obj_val :b ? - if emptyp :b_val [output "false] - if not equal_q :a_val :b_val [output "false] -] -output "true -end - -to equal_q :a :b -output cond [ - [[and sequentialp :a sequentialp :b] - equal_sequential_q :a :b] - [[((obj_type :a) = (obj_type :b))] - case obj_type :a [ - [[true false nil] "true] - [[number string keyword symbol] ((obj_val :a) = (obj_val :b))] - [[hashmap] equal_hashmap_q :a :b] - [[atom] equal_q obj_val :a obj_val :b] - [else "false] - ]] - [else "false] -] -end +; Make Logo's string-comparison case sensitive +make "caseignoredp "false + +; Load the 'case' library macro +case "dummy [] + +; Redefine 'case' macro to not override caseignoredp +.macro case :case.value :case.clauses +catch "case.error [output case.helper :case.value :case.clauses] +(throw "error [Empty CASE clause]) +end + +to obj_new :type :val +output list :type :val +end + +to obj_new_with_meta :type :val :meta +output (list :type :val :meta) +end + +to obj_type :obj +output first :obj +end + +to obj_val :obj +output item 2 :obj +end + +to obj_meta :obj +if (count :obj) < 3 [output []] +output item 3 :obj +end + +make "global_nil obj_new "nil [] + +to nil_new +output :global_nil +end + +make "global_true obj_new "true [] + +to true_new +output :global_true +end + +make "global_false obj_new "false [] + +to false_new +output :global_false +end + +to symbol_new :name +output obj_new "symbol :name +end + +to hashmap_get :h :key +localmake "i 1 +while [:i < count :h] [ + if equal_q item :i :h :key [ + output item (:i + 1) :h + ] + make "i (:i + 2) +] +output [] +end + +; Returns a new list with the key-val pair set +to hashmap_put :h :key :val +localmake "res hashmap_delete :h :key +make "res lput :key :res +make "res lput :val :res +output :res +end + +; Returns a new list without the key-val pair set +to hashmap_delete :h :key +localmake "res [] +localmake "i 1 +while [:i < count :h] [ + if (item :i :h) <> :key [ + make "res lput item :i :h :res + make "res lput item (:i + 1) :h :res + ] + make "i (:i + 2) +] +output :res +end + +to fn_new :args :env :body +output obj_new "fn (list :args :env :body "false) +end + +to fn_args :fn +output item 1 obj_val :fn +end + +to fn_env :fn +output item 2 obj_val :fn +end + +to fn_body :fn +output item 3 obj_val :fn +end + +to fn_is_macro :fn +output item 4 obj_val :fn +end + +to fn_set_macro :fn +.setfirst butfirst butfirst butfirst obj_val :fn "true +end + +; zero-based sequence addressing +to nth :seq :index +output item (:index + 1) obj_val :seq +end + +to _count :seq +output count obj_val :seq +end + +to rest :seq +output obj_new obj_type :seq butfirst obj_val :seq +end + +to drop :seq :num +if or :num = 0 (_count :seq) = 0 [output :seq] +foreach obj_val :seq [ + if # >= :num [output obj_new obj_type :seq ?rest] +] +end + +to sequentialp :obj +output memberp obj_type :obj [list vector] +end + +to equal_sequential_q :a :b +if (_count :a) <> (_count :b) [output "false] +(foreach obj_val :a obj_val :b [ + if not equal_q ?1 ?2 [output "false] +]) +output "true +end + +to equal_hashmap_q :a :b +if (_count :a) <> (_count :b) [output "false] +localmake "a_keys obj_val mal_keys :a +foreach :a_keys [ + localmake "a_val hashmap_get obj_val :a ? + localmake "b_val hashmap_get obj_val :b ? + if emptyp :b_val [output "false] + if not equal_q :a_val :b_val [output "false] +] +output "true +end + +to equal_q :a :b +output cond [ + [[and sequentialp :a sequentialp :b] + equal_sequential_q :a :b] + [[((obj_type :a) = (obj_type :b))] + case obj_type :a [ + [[true false nil] "true] + [[number string keyword symbol] ((obj_val :a) = (obj_val :b))] + [[hashmap] equal_hashmap_q :a :b] + [[atom] equal_q obj_val :a obj_val :b] + [else "false] + ]] + [else "false] +] +end diff --git a/impls/lua/Dockerfile b/impls/lua/Dockerfile index 1fc29ea9d1..2fee1c6cf8 100644 --- a/impls/lua/Dockerfile +++ b/impls/lua/Dockerfile @@ -1,43 +1,43 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Lua -RUN apt-get -y install gcc wget unzip libpcre3-dev - -RUN \ -curl -R -O http://www.lua.org/ftp/lua-5.3.5.tar.gz && \ -tar -zxf lua-5.3.5.tar.gz && \ -cd lua-5.3.5 && \ -make linux test && \ -make install - -RUN \ -wget https://luarocks.org/releases/luarocks-3.3.1.tar.gz && \ -tar zxpf luarocks-3.3.1.tar.gz && \ -cd luarocks-3.3.1 && \ -./configure && \ -make && \ -make install - -# luarocks .cache directory is relative to HOME -ENV HOME /mal +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Lua +RUN apt-get -y install gcc wget unzip libpcre3-dev + +RUN \ +curl -R -O http://www.lua.org/ftp/lua-5.3.5.tar.gz && \ +tar -zxf lua-5.3.5.tar.gz && \ +cd lua-5.3.5 && \ +make linux test && \ +make install + +RUN \ +wget https://luarocks.org/releases/luarocks-3.3.1.tar.gz && \ +tar zxpf luarocks-3.3.1.tar.gz && \ +cd luarocks-3.3.1 && \ +./configure && \ +make && \ +make install + +# luarocks .cache directory is relative to HOME +ENV HOME /mal diff --git a/impls/lua/Makefile b/impls/lua/Makefile index 8c8fb28966..15fd79e3a9 100644 --- a/impls/lua/Makefile +++ b/impls/lua/Makefile @@ -1,39 +1,39 @@ -SOURCES_BASE = utils.lua types.lua reader.lua printer.lua -SOURCES_LISP = env.lua core.lua stepA_mal.lua -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: libs - -dist: mal.lua mal - -SOURCE_NAMES = $(patsubst %.lua,%,$(SOURCES)) -mal.lua: $(SOURCES) - echo "local $(foreach n,$(SOURCE_NAMES),$(n),) M" > $@ - echo "M={} $(foreach n,$(SOURCE_NAMES),$(n)=M);" >> $@ - cat $+ | grep -v -e "return M$$" \ - -e "return Env" \ - -e "local M =" \ - -e "^#!" \ - $(foreach n,$(SOURCE_NAMES),-e "require('$(n)')") >> $@ - -mal: mal.lua - echo "#!/usr/bin/env lua" > $@ - cat $< >> $@ - chmod +x $@ - - -clean: - rm -f linenoise.so rex_pcre.so mal.lua mal - rm -rf lib - -.PHONY: libs -libs: linenoise.so rex_pcre.so - -linenoise.so: - luarocks install --tree=./ linenoise - ln -sf $$(find . -name linenoise.so) $@ - -rex_pcre.so: - luarocks install --tree=./ lrexlib-pcre - ln -sf $$(find . -name rex_pcre.so) $@ - +SOURCES_BASE = utils.lua types.lua reader.lua printer.lua +SOURCES_LISP = env.lua core.lua stepA_mal.lua +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: libs + +dist: mal.lua mal + +SOURCE_NAMES = $(patsubst %.lua,%,$(SOURCES)) +mal.lua: $(SOURCES) + echo "local $(foreach n,$(SOURCE_NAMES),$(n),) M" > $@ + echo "M={} $(foreach n,$(SOURCE_NAMES),$(n)=M);" >> $@ + cat $+ | grep -v -e "return M$$" \ + -e "return Env" \ + -e "local M =" \ + -e "^#!" \ + $(foreach n,$(SOURCE_NAMES),-e "require('$(n)')") >> $@ + +mal: mal.lua + echo "#!/usr/bin/env lua" > $@ + cat $< >> $@ + chmod +x $@ + + +clean: + rm -f linenoise.so rex_pcre.so mal.lua mal + rm -rf lib + +.PHONY: libs +libs: linenoise.so rex_pcre.so + +linenoise.so: + luarocks install --tree=./ linenoise + ln -sf $$(find . -name linenoise.so) $@ + +rex_pcre.so: + luarocks install --tree=./ lrexlib-pcre + ln -sf $$(find . -name rex_pcre.so) $@ + diff --git a/impls/lua/core.lua b/impls/lua/core.lua index 631479da1b..48afb70937 100644 --- a/impls/lua/core.lua +++ b/impls/lua/core.lua @@ -1,325 +1,325 @@ -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local readline = require('readline') - -local Nil, List, HashMap, _pr_str = types.Nil, types.List, types.HashMap, printer._pr_str - -local M = {} - --- string functions - -function pr_str(...) - return table.concat( - utils.map(function(e) return _pr_str(e, true) end, - table.pack(...)), " ") -end - -function str(...) - return table.concat( - utils.map(function(e) return _pr_str(e, false) end, - table.pack(...)), "") -end - -function prn(...) - print(table.concat( - utils.map(function(e) return _pr_str(e, true) end, - table.pack(...)), " ")) - io.flush() - return Nil -end - -function println(...) - print(table.concat( - utils.map(function(e) return _pr_str(e, false) end, - table.pack(...)), " ")) - io.flush() - return Nil -end - -function slurp(file) - local lines = {} - for line in io.lines(file) do - lines[#lines+1] = line - end - return table.concat(lines, "\n") .. "\n" -end - -function do_readline(prompt) - local line = readline.readline(prompt) - if line == nil then - return Nil - else - return line - end -end - --- hash map functions - -function assoc(hm, ...) - return types._assoc_BANG(types.copy(hm), ...) -end - -function dissoc(hm, ...) - return types._dissoc_BANG(types.copy(hm), ...) -end - -function get(hm, key) - local res = hm[key] - if res == nil then return Nil end - return res -end - -function keys(hm) - local res = {} - for k,v in pairs(hm) do - res[#res+1] = k - end - return List:new(res) -end - -function vals(hm) - local res = {} - for k,v in pairs(hm) do - res[#res+1] = v - end - return List:new(res) -end - --- sequential functions - -function cons(a,lst) - local new_lst = lst:slice(1) - table.insert(new_lst, 1, a) - return List:new(new_lst) -end - -function concat(...) - local arg = table.pack(...) - local new_lst = {} - for i = 1, #arg do - for j = 1, #arg[i] do - table.insert(new_lst, arg[i][j]) - end - end - return List:new(new_lst) -end - -function vec(a) - return types.Vector:new(a) -end - -function nth(seq, idx) - if idx+1 <= #seq then - return seq[idx+1] - else - types.throw("nth: index out of range") - end -end - -function first(a) - if #a == 0 then - return Nil - else - return a[1] - end -end - -function rest(a) - if a == Nil then - return List:new() - else - return List:new(a:slice(2)) - end -end - -function apply(f, ...) - local arg = table.pack(...) - if types._malfunc_Q(f) then - f = f.fn - end - local args = concat(types.slice(arg, 1, #arg-1), - arg[#arg]) - return f(table.unpack(args)) -end - -function map(f, lst) - if types._malfunc_Q(f) then - f = f.fn - end - return List:new(utils.map(f, lst)) -end - --- metadata functions - -function meta(obj) - local m = getmetatable(obj) - if m == nil or m.meta == nil then return Nil end - return m.meta -end - -function with_meta(obj, meta) - local new_obj = types.copy(obj) - getmetatable(new_obj).meta = meta - return new_obj -end - --- atom functions - -function swap_BANG(atm,f,...) - if types._malfunc_Q(f) then - f = f.fn - end - local args = List:new(table.pack(...)) - table.insert(args, 1, atm.val) - atm.val = f(table.unpack(args)) - return atm.val -end - -local function conj(obj, ...) - local arg = table.pack(...) - local new_obj = types.copy(obj) - if types._list_Q(new_obj) then - for i, v in ipairs(arg) do - table.insert(new_obj, 1, v) - end - else - for i, v in ipairs(arg) do - table.insert(new_obj, v) - end - end - return new_obj -end - -local function seq(obj, ...) - if obj == Nil or #obj == 0 then - return Nil - elseif types._list_Q(obj) then - return obj - elseif types._vector_Q(obj) then - return List:new(obj) - elseif types._string_Q(obj) then - local chars = {} - for i = 1, #obj do - chars[#chars+1] = string.sub(obj,i,i) - end - return List:new(chars) - end - return Nil -end - -local function lua_to_mal(a) - if a == nil then - return Nil - elseif type(a) == "boolean" or type(a) == "number" or type(a) == "string" then - return a - elseif type(a) == "table" then - local first_key, _ = next(a) - if first_key == nil then - return List:new({}) - elseif type(first_key) == "number" then - local list = {} - for i, v in ipairs(a) do - list[i] = lua_to_mal(v) - end - return List:new(list) - else - local hashmap = {} - for k, v in pairs(a) do - hashmap[lua_to_mal(k)] = lua_to_mal(v) - end - return HashMap:new(hashmap) - end - end - return tostring(a) -end - -local function lua_eval(str) - local f, err = load("return "..str) - if err then - types.throw("lua-eval: can't load code: "..err) - end - return lua_to_mal(f()) -end - -M.ns = { - ['='] = types._equal_Q, - throw = types.throw, - - ['nil?'] = function(a) return a==Nil end, - ['true?'] = function(a) return a==true end, - ['false?'] = function(a) return a==false end, - ['number?'] = function(a) return types._number_Q(a) end, - symbol = function(a) return types.Symbol:new(a) end, - ['symbol?'] = function(a) return types._symbol_Q(a) end, - ['string?'] = function(a) return types._string_Q(a) and "\u{029e}" ~= string.sub(a,1,2) end, - keyword = function(a) - if types._keyword_Q(a) then - return a - else - return "\u{029e}"..a - end - end, - ['keyword?'] = function(a) return types._keyword_Q(a) end, - ['fn?'] = function(a) return types._fn_Q(a) end, - ['macro?'] = function(a) return types._macro_Q(a) end, - - ['pr-str'] = pr_str, - str = str, - prn = prn, - println = println, - ['read-string'] = reader.read_str, - readline = do_readline, - slurp = slurp, - - ['<'] = function(a,b) return a'] = function(a,b) return a>b end, - ['>='] = function(a,b) return a>=b end, - ['+'] = function(a,b) return a+b end, - ['-'] = function(a,b) return a-b end, - ['*'] = function(a,b) return a*b end, - ['/'] = function(a,b) return math.floor(a/b) end, - ['time-ms'] = function() return math.floor(os.clock()*1000000) end, - - list = function(...) return List:new(table.pack(...)) end, - ['list?'] = function(a) return types._list_Q(a) end, - vector = function(...) return types.Vector:new(table.pack(...)) end, - ['vector?'] = types._vector_Q, - ['hash-map'] = types.hash_map, - ['map?'] = types._hash_map_Q, - assoc = assoc, - dissoc = dissoc, - get = get, - ['contains?'] = function(a,b) return a[b] ~= nil end, - keys = keys, - vals = vals, - - ['sequential?'] = types._sequential_Q, - cons = cons, - concat = concat, - vec = vec, - nth = nth, - first = first, - rest = rest, - ['empty?'] = function(a) return a==Nil or #a == 0 end, - count = function(a) return #a end, - apply = apply, - map = map, - conj = conj, - seq = seq, - - meta = meta, - ['with-meta'] = with_meta, - atom = function(a) return types.Atom:new(a) end, - ['atom?'] = types._atom_Q, - deref = function(a) return a.val end, - ['reset!'] = function(a,b) a.val = b; return b end, - ['swap!'] = swap_BANG, - - ['lua-eval'] = lua_eval, -} - -return M - +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local readline = require('readline') + +local Nil, List, HashMap, _pr_str = types.Nil, types.List, types.HashMap, printer._pr_str + +local M = {} + +-- string functions + +function pr_str(...) + return table.concat( + utils.map(function(e) return _pr_str(e, true) end, + table.pack(...)), " ") +end + +function str(...) + return table.concat( + utils.map(function(e) return _pr_str(e, false) end, + table.pack(...)), "") +end + +function prn(...) + print(table.concat( + utils.map(function(e) return _pr_str(e, true) end, + table.pack(...)), " ")) + io.flush() + return Nil +end + +function println(...) + print(table.concat( + utils.map(function(e) return _pr_str(e, false) end, + table.pack(...)), " ")) + io.flush() + return Nil +end + +function slurp(file) + local lines = {} + for line in io.lines(file) do + lines[#lines+1] = line + end + return table.concat(lines, "\n") .. "\n" +end + +function do_readline(prompt) + local line = readline.readline(prompt) + if line == nil then + return Nil + else + return line + end +end + +-- hash map functions + +function assoc(hm, ...) + return types._assoc_BANG(types.copy(hm), ...) +end + +function dissoc(hm, ...) + return types._dissoc_BANG(types.copy(hm), ...) +end + +function get(hm, key) + local res = hm[key] + if res == nil then return Nil end + return res +end + +function keys(hm) + local res = {} + for k,v in pairs(hm) do + res[#res+1] = k + end + return List:new(res) +end + +function vals(hm) + local res = {} + for k,v in pairs(hm) do + res[#res+1] = v + end + return List:new(res) +end + +-- sequential functions + +function cons(a,lst) + local new_lst = lst:slice(1) + table.insert(new_lst, 1, a) + return List:new(new_lst) +end + +function concat(...) + local arg = table.pack(...) + local new_lst = {} + for i = 1, #arg do + for j = 1, #arg[i] do + table.insert(new_lst, arg[i][j]) + end + end + return List:new(new_lst) +end + +function vec(a) + return types.Vector:new(a) +end + +function nth(seq, idx) + if idx+1 <= #seq then + return seq[idx+1] + else + types.throw("nth: index out of range") + end +end + +function first(a) + if #a == 0 then + return Nil + else + return a[1] + end +end + +function rest(a) + if a == Nil then + return List:new() + else + return List:new(a:slice(2)) + end +end + +function apply(f, ...) + local arg = table.pack(...) + if types._malfunc_Q(f) then + f = f.fn + end + local args = concat(types.slice(arg, 1, #arg-1), + arg[#arg]) + return f(table.unpack(args)) +end + +function map(f, lst) + if types._malfunc_Q(f) then + f = f.fn + end + return List:new(utils.map(f, lst)) +end + +-- metadata functions + +function meta(obj) + local m = getmetatable(obj) + if m == nil or m.meta == nil then return Nil end + return m.meta +end + +function with_meta(obj, meta) + local new_obj = types.copy(obj) + getmetatable(new_obj).meta = meta + return new_obj +end + +-- atom functions + +function swap_BANG(atm,f,...) + if types._malfunc_Q(f) then + f = f.fn + end + local args = List:new(table.pack(...)) + table.insert(args, 1, atm.val) + atm.val = f(table.unpack(args)) + return atm.val +end + +local function conj(obj, ...) + local arg = table.pack(...) + local new_obj = types.copy(obj) + if types._list_Q(new_obj) then + for i, v in ipairs(arg) do + table.insert(new_obj, 1, v) + end + else + for i, v in ipairs(arg) do + table.insert(new_obj, v) + end + end + return new_obj +end + +local function seq(obj, ...) + if obj == Nil or #obj == 0 then + return Nil + elseif types._list_Q(obj) then + return obj + elseif types._vector_Q(obj) then + return List:new(obj) + elseif types._string_Q(obj) then + local chars = {} + for i = 1, #obj do + chars[#chars+1] = string.sub(obj,i,i) + end + return List:new(chars) + end + return Nil +end + +local function lua_to_mal(a) + if a == nil then + return Nil + elseif type(a) == "boolean" or type(a) == "number" or type(a) == "string" then + return a + elseif type(a) == "table" then + local first_key, _ = next(a) + if first_key == nil then + return List:new({}) + elseif type(first_key) == "number" then + local list = {} + for i, v in ipairs(a) do + list[i] = lua_to_mal(v) + end + return List:new(list) + else + local hashmap = {} + for k, v in pairs(a) do + hashmap[lua_to_mal(k)] = lua_to_mal(v) + end + return HashMap:new(hashmap) + end + end + return tostring(a) +end + +local function lua_eval(str) + local f, err = load("return "..str) + if err then + types.throw("lua-eval: can't load code: "..err) + end + return lua_to_mal(f()) +end + +M.ns = { + ['='] = types._equal_Q, + throw = types.throw, + + ['nil?'] = function(a) return a==Nil end, + ['true?'] = function(a) return a==true end, + ['false?'] = function(a) return a==false end, + ['number?'] = function(a) return types._number_Q(a) end, + symbol = function(a) return types.Symbol:new(a) end, + ['symbol?'] = function(a) return types._symbol_Q(a) end, + ['string?'] = function(a) return types._string_Q(a) and "\u{029e}" ~= string.sub(a,1,2) end, + keyword = function(a) + if types._keyword_Q(a) then + return a + else + return "\u{029e}"..a + end + end, + ['keyword?'] = function(a) return types._keyword_Q(a) end, + ['fn?'] = function(a) return types._fn_Q(a) end, + ['macro?'] = function(a) return types._macro_Q(a) end, + + ['pr-str'] = pr_str, + str = str, + prn = prn, + println = println, + ['read-string'] = reader.read_str, + readline = do_readline, + slurp = slurp, + + ['<'] = function(a,b) return a'] = function(a,b) return a>b end, + ['>='] = function(a,b) return a>=b end, + ['+'] = function(a,b) return a+b end, + ['-'] = function(a,b) return a-b end, + ['*'] = function(a,b) return a*b end, + ['/'] = function(a,b) return math.floor(a/b) end, + ['time-ms'] = function() return math.floor(os.clock()*1000000) end, + + list = function(...) return List:new(table.pack(...)) end, + ['list?'] = function(a) return types._list_Q(a) end, + vector = function(...) return types.Vector:new(table.pack(...)) end, + ['vector?'] = types._vector_Q, + ['hash-map'] = types.hash_map, + ['map?'] = types._hash_map_Q, + assoc = assoc, + dissoc = dissoc, + get = get, + ['contains?'] = function(a,b) return a[b] ~= nil end, + keys = keys, + vals = vals, + + ['sequential?'] = types._sequential_Q, + cons = cons, + concat = concat, + vec = vec, + nth = nth, + first = first, + rest = rest, + ['empty?'] = function(a) return a==Nil or #a == 0 end, + count = function(a) return #a end, + apply = apply, + map = map, + conj = conj, + seq = seq, + + meta = meta, + ['with-meta'] = with_meta, + atom = function(a) return types.Atom:new(a) end, + ['atom?'] = types._atom_Q, + deref = function(a) return a.val end, + ['reset!'] = function(a,b) a.val = b; return b end, + ['swap!'] = swap_BANG, + + ['lua-eval'] = lua_eval, +} + +return M + diff --git a/impls/lua/env.lua b/impls/lua/env.lua index ee19c90f31..b2403ee3fa 100644 --- a/impls/lua/env.lua +++ b/impls/lua/env.lua @@ -1,53 +1,53 @@ -local rex = require('rex_pcre') -local string = require('string') -local table = require('table') -local utils = require('utils') -local types = require('types') - -local Env = {} - -function Env:new(outer, binds, exprs) - local data = {} - local newObj = {outer = outer, data = data} - self.__index = self - if binds then - for i, b in ipairs(binds) do - if binds[i].val == '&' then - local new_exprs = types.List:new() - for j = i, #exprs do - table.insert(new_exprs, exprs[j]) - end - table.remove(exprs, 1) - data[binds[i+1].val] = new_exprs - break - end - data[binds[i].val] = exprs[i] - end - end - return setmetatable(newObj, self) -end -function Env:find(sym) - if self.data[sym.val] ~= nil then - return self - else - if self.outer ~= nil then - return self.outer:find(sym) - else - return nil - end - end -end -function Env:set(sym,val) - self.data[sym.val] = val - return val -end -function Env:get(sym) - local env = self:find(sym) - if env then - return env.data[sym.val] - else - types.throw("'"..sym.val.."' not found") - end -end - -return Env +local rex = require('rex_pcre') +local string = require('string') +local table = require('table') +local utils = require('utils') +local types = require('types') + +local Env = {} + +function Env:new(outer, binds, exprs) + local data = {} + local newObj = {outer = outer, data = data} + self.__index = self + if binds then + for i, b in ipairs(binds) do + if binds[i].val == '&' then + local new_exprs = types.List:new() + for j = i, #exprs do + table.insert(new_exprs, exprs[j]) + end + table.remove(exprs, 1) + data[binds[i+1].val] = new_exprs + break + end + data[binds[i].val] = exprs[i] + end + end + return setmetatable(newObj, self) +end +function Env:find(sym) + if self.data[sym.val] ~= nil then + return self + else + if self.outer ~= nil then + return self.outer:find(sym) + else + return nil + end + end +end +function Env:set(sym,val) + self.data[sym.val] = val + return val +end +function Env:get(sym) + local env = self:find(sym) + if env then + return env.data[sym.val] + else + types.throw("'"..sym.val.."' not found") + end +end + +return Env diff --git a/impls/lua/printer.lua b/impls/lua/printer.lua index 96a7f17e6d..7409a92531 100644 --- a/impls/lua/printer.lua +++ b/impls/lua/printer.lua @@ -1,55 +1,55 @@ -local string = require('string') -local table = require('table') -local types = require('types') -local utils = require('utils') - -local M = {} - -function M._pr_str(obj, print_readably) - local _r = print_readably - if utils.instanceOf(obj, types.Symbol) then - return obj.val - elseif types._list_Q(obj) then - return "(" .. table.concat(utils.map(function(e) - return M._pr_str(e,_r) end, obj), " ") .. ")" - elseif types._vector_Q(obj) then - return "[" .. table.concat(utils.map(function(e) - return M._pr_str(e,_r) end, obj), " ") .. "]" - elseif types._hash_map_Q(obj) then - local res = {} - for k,v in pairs(obj) do - res[#res+1] = M._pr_str(k, _r) - res[#res+1] = M._pr_str(v, _r) - end - return "{".. table.concat(res, " ").."}" - elseif type(obj) == 'string' then - if string.sub(obj,1,2) == "\u{029e}" then - return ':' .. string.sub(obj,3) - else - if _r then - local sval = obj:gsub('\\', '\\\\') - sval = sval:gsub('"', '\\"') - sval = sval:gsub('\n', '\\n') - return '"' .. sval .. '"' - else - return obj - end - end - elseif obj == types.Nil then - return "nil" - elseif obj == true then - return "true" - elseif obj == false then - return "false" - elseif types._malfunc_Q(obj) then - return "(fn* "..M._pr_str(obj.params).." "..M._pr_str(obj.ast)..")" - elseif types._atom_Q(obj) then - return "(atom "..M._pr_str(obj.val)..")" - elseif type(obj) == 'function' or types._functionref_Q(obj) then - return "#" - else - return string.format("%s", obj) - end -end - -return M +local string = require('string') +local table = require('table') +local types = require('types') +local utils = require('utils') + +local M = {} + +function M._pr_str(obj, print_readably) + local _r = print_readably + if utils.instanceOf(obj, types.Symbol) then + return obj.val + elseif types._list_Q(obj) then + return "(" .. table.concat(utils.map(function(e) + return M._pr_str(e,_r) end, obj), " ") .. ")" + elseif types._vector_Q(obj) then + return "[" .. table.concat(utils.map(function(e) + return M._pr_str(e,_r) end, obj), " ") .. "]" + elseif types._hash_map_Q(obj) then + local res = {} + for k,v in pairs(obj) do + res[#res+1] = M._pr_str(k, _r) + res[#res+1] = M._pr_str(v, _r) + end + return "{".. table.concat(res, " ").."}" + elseif type(obj) == 'string' then + if string.sub(obj,1,2) == "\u{029e}" then + return ':' .. string.sub(obj,3) + else + if _r then + local sval = obj:gsub('\\', '\\\\') + sval = sval:gsub('"', '\\"') + sval = sval:gsub('\n', '\\n') + return '"' .. sval .. '"' + else + return obj + end + end + elseif obj == types.Nil then + return "nil" + elseif obj == true then + return "true" + elseif obj == false then + return "false" + elseif types._malfunc_Q(obj) then + return "(fn* "..M._pr_str(obj.params).." "..M._pr_str(obj.ast)..")" + elseif types._atom_Q(obj) then + return "(atom "..M._pr_str(obj.val)..")" + elseif type(obj) == 'function' or types._functionref_Q(obj) then + return "#" + else + return string.format("%s", obj) + end +end + +return M diff --git a/impls/lua/reader.lua b/impls/lua/reader.lua index 07ce1477c7..3b35b5692f 100644 --- a/impls/lua/reader.lua +++ b/impls/lua/reader.lua @@ -1,132 +1,132 @@ -local rex = require('rex_pcre') -local string = require('string') -local table = require('table') -local types = require('types') -local throw, Nil, Symbol, List = types.throw, types.Nil, - types.Symbol, types.List - -local M = {} - -Reader = {} -function Reader:new(tokens) - local newObj = {tokens = tokens, position = 1} - self.__index = self - return setmetatable(newObj, self) -end -function Reader:next() - self.position = self.position + 1 - return self.tokens[self.position-1] -end -function Reader:peek() - return self.tokens[self.position] -end - -function M.tokenize(str) - local results = {} - local re_pos = 1 - local re = rex.new("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)", rex.flags().EXTENDED) - while true do - local s, e, t = re:exec(str, re_pos) - if not s or s > e then break end - re_pos = e + 1 - local val = string.sub(str,t[1],t[2]) - if string.sub(val,1,1) ~= ";" then - table.insert(results, val) - end - end - return results -end - -function M.read_atom(rdr) - local int_re = rex.new("^-?[0-9]+$") - local float_re = rex.new("^-?[0-9][0-9.]*$") - local string_re = rex.new("^\"(?:\\\\.|[^\\\\\"])*\"$") - local token = rdr:next() - if int_re:exec(token) then return tonumber(token) - elseif float_re:exec(token) then return tonumber(token) - elseif string_re:exec(token) then - local sval = string.sub(token,2,string.len(token)-1) - sval = string.gsub(sval, '\\\\', '\u{029e}') - sval = string.gsub(sval, '\\"', '"') - sval = string.gsub(sval, '\\n', '\n') - sval = string.gsub(sval, '\u{029e}', '\\') - return sval - elseif string.sub(token,1,1) == '"' then - throw("expected '\"', got EOF") - elseif string.sub(token,1,1) == ':' then - return "\u{029e}" .. string.sub(token,2) - elseif token == "nil" then return Nil - elseif token == "true" then return true - elseif token == "false" then return false - else return Symbol:new(token) - end -end - -function M.read_sequence(rdr, start, last) - local ast = {} - local token = rdr:next() - if token ~= start then throw("expected '"..start.."'") end - - token = rdr:peek() - while token ~= last do - if not token then throw("expected '"..last.."', got EOF") end - table.insert(ast, M.read_form(rdr)) - token = rdr:peek() - end - rdr:next() - return ast -end - -function M.read_list(rdr) - return types.List:new(M.read_sequence(rdr, '(', ')')) -end - -function M.read_vector(rdr) - return types.Vector:new(M.read_sequence(rdr, '[', ']')) -end - -function M.read_hash_map(rdr) - local seq = M.read_sequence(rdr, '{', '}') - return types._assoc_BANG(types.HashMap:new(), table.unpack(seq)) -end - -function M.read_form(rdr) - local token = rdr:peek() - - if "'" == token then - rdr:next() - return List:new({Symbol:new('quote'), M.read_form(rdr)}) - elseif '`' == token then - rdr:next() - return List:new({Symbol:new('quasiquote'), M.read_form(rdr)}) - elseif '~' == token then - rdr:next() - return List:new({Symbol:new('unquote'), M.read_form(rdr)}) - elseif '~@' == token then - rdr:next() - return List:new({Symbol:new('splice-unquote'), M.read_form(rdr)}) - elseif '^' == token then - rdr:next() - local meta = M.read_form(rdr) - return List:new({Symbol:new('with-meta'), M.read_form(rdr), meta}) - elseif '@' == token then - rdr:next() - return List:new({Symbol:new('deref'), M.read_form(rdr)}) - - elseif ')' == token then throw("unexpected ')'") - elseif '(' == token then return M.read_list(rdr) - elseif ']' == token then throw("unexpected ']'") - elseif '[' == token then return M.read_vector(rdr) - elseif '}' == token then throw("unexpected '}'") - elseif '{' == token then return M.read_hash_map(rdr) - else return M.read_atom(rdr) - end -end - -function M.read_str(str) - local tokens = M.tokenize(str) - if #tokens == 0 then error(nil) end - return M.read_form(Reader:new(tokens)) -end - -return M +local rex = require('rex_pcre') +local string = require('string') +local table = require('table') +local types = require('types') +local throw, Nil, Symbol, List = types.throw, types.Nil, + types.Symbol, types.List + +local M = {} + +Reader = {} +function Reader:new(tokens) + local newObj = {tokens = tokens, position = 1} + self.__index = self + return setmetatable(newObj, self) +end +function Reader:next() + self.position = self.position + 1 + return self.tokens[self.position-1] +end +function Reader:peek() + return self.tokens[self.position] +end + +function M.tokenize(str) + local results = {} + local re_pos = 1 + local re = rex.new("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)", rex.flags().EXTENDED) + while true do + local s, e, t = re:exec(str, re_pos) + if not s or s > e then break end + re_pos = e + 1 + local val = string.sub(str,t[1],t[2]) + if string.sub(val,1,1) ~= ";" then + table.insert(results, val) + end + end + return results +end + +function M.read_atom(rdr) + local int_re = rex.new("^-?[0-9]+$") + local float_re = rex.new("^-?[0-9][0-9.]*$") + local string_re = rex.new("^\"(?:\\\\.|[^\\\\\"])*\"$") + local token = rdr:next() + if int_re:exec(token) then return tonumber(token) + elseif float_re:exec(token) then return tonumber(token) + elseif string_re:exec(token) then + local sval = string.sub(token,2,string.len(token)-1) + sval = string.gsub(sval, '\\\\', '\u{029e}') + sval = string.gsub(sval, '\\"', '"') + sval = string.gsub(sval, '\\n', '\n') + sval = string.gsub(sval, '\u{029e}', '\\') + return sval + elseif string.sub(token,1,1) == '"' then + throw("expected '\"', got EOF") + elseif string.sub(token,1,1) == ':' then + return "\u{029e}" .. string.sub(token,2) + elseif token == "nil" then return Nil + elseif token == "true" then return true + elseif token == "false" then return false + else return Symbol:new(token) + end +end + +function M.read_sequence(rdr, start, last) + local ast = {} + local token = rdr:next() + if token ~= start then throw("expected '"..start.."'") end + + token = rdr:peek() + while token ~= last do + if not token then throw("expected '"..last.."', got EOF") end + table.insert(ast, M.read_form(rdr)) + token = rdr:peek() + end + rdr:next() + return ast +end + +function M.read_list(rdr) + return types.List:new(M.read_sequence(rdr, '(', ')')) +end + +function M.read_vector(rdr) + return types.Vector:new(M.read_sequence(rdr, '[', ']')) +end + +function M.read_hash_map(rdr) + local seq = M.read_sequence(rdr, '{', '}') + return types._assoc_BANG(types.HashMap:new(), table.unpack(seq)) +end + +function M.read_form(rdr) + local token = rdr:peek() + + if "'" == token then + rdr:next() + return List:new({Symbol:new('quote'), M.read_form(rdr)}) + elseif '`' == token then + rdr:next() + return List:new({Symbol:new('quasiquote'), M.read_form(rdr)}) + elseif '~' == token then + rdr:next() + return List:new({Symbol:new('unquote'), M.read_form(rdr)}) + elseif '~@' == token then + rdr:next() + return List:new({Symbol:new('splice-unquote'), M.read_form(rdr)}) + elseif '^' == token then + rdr:next() + local meta = M.read_form(rdr) + return List:new({Symbol:new('with-meta'), M.read_form(rdr), meta}) + elseif '@' == token then + rdr:next() + return List:new({Symbol:new('deref'), M.read_form(rdr)}) + + elseif ')' == token then throw("unexpected ')'") + elseif '(' == token then return M.read_list(rdr) + elseif ']' == token then throw("unexpected ']'") + elseif '[' == token then return M.read_vector(rdr) + elseif '}' == token then throw("unexpected '}'") + elseif '{' == token then return M.read_hash_map(rdr) + else return M.read_atom(rdr) + end +end + +function M.read_str(str) + local tokens = M.tokenize(str) + if #tokens == 0 then error(nil) end + return M.read_form(Reader:new(tokens)) +end + +return M diff --git a/impls/lua/readline.lua b/impls/lua/readline.lua index ba390a7f7b..c59df26661 100644 --- a/impls/lua/readline.lua +++ b/impls/lua/readline.lua @@ -1,41 +1,41 @@ -local LN = require('linenoise') - -local M = {} - -local history_loaded = false -local history_file = os.getenv("HOME") .. "/.mal-history" - -M.raw = false - -function M.readline(prompt) - if not history_loaded then - history_loaded = true - xpcall(function() - for line in io.lines(history_file) do - LN.historyadd(line) - end - end, function(exc) - return true -- ignore the error - end) - end - - if M.raw then - io.write(prompt); io.flush(); - line = io.read() - else - line = LN.linenoise(prompt) - end - if line then - LN.historyadd(line) - xpcall(function() - local f = io.open(history_file, "a") - f:write(line.."\n") - f:close() - end, function(exc) - return true -- ignore the error - end) - end - return line -end - -return M +local LN = require('linenoise') + +local M = {} + +local history_loaded = false +local history_file = os.getenv("HOME") .. "/.mal-history" + +M.raw = false + +function M.readline(prompt) + if not history_loaded then + history_loaded = true + xpcall(function() + for line in io.lines(history_file) do + LN.historyadd(line) + end + end, function(exc) + return true -- ignore the error + end) + end + + if M.raw then + io.write(prompt); io.flush(); + line = io.read() + else + line = LN.linenoise(prompt) + end + if line then + LN.historyadd(line) + xpcall(function() + local f = io.open(history_file, "a") + f:write(line.."\n") + f:close() + end, function(exc) + return true -- ignore the error + end) + end + return line +end + +return M diff --git a/impls/lua/run b/impls/lua/run index f73e5b6f8f..b97db81db9 100755 --- a/impls/lua/run +++ b/impls/lua/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec lua $(dirname $0)/${STEP:-stepA_mal}.lua "${@}" +#!/bin/bash +exec lua $(dirname $0)/${STEP:-stepA_mal}.lua "${@}" diff --git a/impls/lua/step0_repl.lua b/impls/lua/step0_repl.lua index bb082a599d..c12436dc5c 100755 --- a/impls/lua/step0_repl.lua +++ b/impls/lua/step0_repl.lua @@ -1,29 +1,29 @@ -#!/usr/bin/env lua - -local readline = require('readline') - -function READ(str) - return str -end - -function EVAL(ast, any) - return ast -end - -function PRINT(exp) - return exp -end - -function rep(str) - return PRINT(EVAL(READ(str),"")) -end - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true -end - -while true do - line = readline.readline("user> ") - if not line then break end - print(rep(line)) -end +#!/usr/bin/env lua + +local readline = require('readline') + +function READ(str) + return str +end + +function EVAL(ast, any) + return ast +end + +function PRINT(exp) + return exp +end + +function rep(str) + return PRINT(EVAL(READ(str),"")) +end + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true +end + +while true do + line = readline.readline("user> ") + if not line then break end + print(rep(line)) +end diff --git a/impls/lua/step1_read_print.lua b/impls/lua/step1_read_print.lua index 424001c026..875d049648 100755 --- a/impls/lua/step1_read_print.lua +++ b/impls/lua/step1_read_print.lua @@ -1,47 +1,47 @@ -#!/usr/bin/env lua - -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function EVAL(ast, env) - return ast -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -function rep(str) - return PRINT(EVAL(READ(str),"")) -end - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true -end - -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() - print(rep(line)) - end, function(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end - end) -end +#!/usr/bin/env lua + +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function EVAL(ast, env) + return ast +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +function rep(str) + return PRINT(EVAL(READ(str),"")) +end + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true +end + +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() + print(rep(line)) + end, function(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end + end) +end diff --git a/impls/lua/step2_eval.lua b/impls/lua/step2_eval.lua index df3fb835bf..0376cb5fbc 100755 --- a/impls/lua/step2_eval.lua +++ b/impls/lua/step2_eval.lua @@ -1,80 +1,80 @@ -#!/usr/bin/env lua - -local table = require('table') - -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local List, Vector, HashMap = types.List, types.Vector, types.HashMap - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function eval_ast(ast, env) - if types._symbol_Q(ast) then - if env[ast.val] == nil then - types.throw("'"..ast.val.."' not found") - end - return env[ast.val] - elseif types._list_Q(ast) then - return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._vector_Q(ast) then - return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._hash_map_Q(ast) then - local new_hm = {} - for k,v in pairs(ast) do - new_hm[k] = EVAL(v, env) - end - return HashMap:new(new_hm) - else - return ast - end -end - -function EVAL(ast, env) - --print("EVAL: "..printer._pr_str(ast,true)) - if not types._list_Q(ast) then return eval_ast(ast, env) end - if #ast == 0 then return ast end - local args = eval_ast(ast, env) - local f = table.remove(args, 1) - return f(table.unpack(args)) -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -local repl_env = {['+'] = function(a,b) return a+b end, - ['-'] = function(a,b) return a-b end, - ['*'] = function(a,b) return a*b end, - ['/'] = function(a,b) return math.floor(a/b) end} -function rep(str) - return PRINT(EVAL(READ(str),repl_env)) -end - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true -end - -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() - print(rep(line)) - end, function(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end - end) -end +#!/usr/bin/env lua + +local table = require('table') + +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local List, Vector, HashMap = types.List, types.Vector, types.HashMap + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function eval_ast(ast, env) + if types._symbol_Q(ast) then + if env[ast.val] == nil then + types.throw("'"..ast.val.."' not found") + end + return env[ast.val] + elseif types._list_Q(ast) then + return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._vector_Q(ast) then + return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._hash_map_Q(ast) then + local new_hm = {} + for k,v in pairs(ast) do + new_hm[k] = EVAL(v, env) + end + return HashMap:new(new_hm) + else + return ast + end +end + +function EVAL(ast, env) + --print("EVAL: "..printer._pr_str(ast,true)) + if not types._list_Q(ast) then return eval_ast(ast, env) end + if #ast == 0 then return ast end + local args = eval_ast(ast, env) + local f = table.remove(args, 1) + return f(table.unpack(args)) +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +local repl_env = {['+'] = function(a,b) return a+b end, + ['-'] = function(a,b) return a-b end, + ['*'] = function(a,b) return a*b end, + ['/'] = function(a,b) return math.floor(a/b) end} +function rep(str) + return PRINT(EVAL(READ(str),repl_env)) +end + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true +end + +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() + print(rep(line)) + end, function(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end + end) +end diff --git a/impls/lua/step3_env.lua b/impls/lua/step3_env.lua index 36575f8ac4..a38fc949a9 100755 --- a/impls/lua/step3_env.lua +++ b/impls/lua/step3_env.lua @@ -1,93 +1,93 @@ -#!/usr/bin/env lua - -local table = require('table') - -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local Env = require('env') -local List, Vector, HashMap = types.List, types.Vector, types.HashMap - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function eval_ast(ast, env) - if types._symbol_Q(ast) then - return env:get(ast) - elseif types._list_Q(ast) then - return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._vector_Q(ast) then - return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._hash_map_Q(ast) then - local new_hm = {} - for k,v in pairs(ast) do - new_hm[k] = EVAL(v, env) - end - return HashMap:new(new_hm) - else - return ast - end -end - -function EVAL(ast, env) - --print("EVAL: "..printer._pr_str(ast,true)) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - local a0,a1,a2 = ast[1], ast[2],ast[3] - if not a0 then return ast end - local a0sym = types._symbol_Q(a0) and a0.val or "" - if 'def!' == a0sym then - return env:set(a1, EVAL(a2, env)) - elseif 'let*' == a0sym then - local let_env = Env:new(env) - for i = 1,#a1,2 do - let_env:set(a1[i], EVAL(a1[i+1], let_env)) - end - return EVAL(a2, let_env) - else - local args = eval_ast(ast, env) - local f = table.remove(args, 1) - return f(table.unpack(args)) - end -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -local repl_env = Env:new() -function rep(str) - return PRINT(EVAL(READ(str),repl_env)) -end - -repl_env:set(types.Symbol:new('+'), function(a,b) return a+b end) -repl_env:set(types.Symbol:new('-'), function(a,b) return a-b end) -repl_env:set(types.Symbol:new('*'), function(a,b) return a*b end) -repl_env:set(types.Symbol:new('/'), function(a,b) return math.floor(a/b) end) - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true -end - -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() - print(rep(line)) - end, function(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end - end) -end +#!/usr/bin/env lua + +local table = require('table') + +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local Env = require('env') +local List, Vector, HashMap = types.List, types.Vector, types.HashMap + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function eval_ast(ast, env) + if types._symbol_Q(ast) then + return env:get(ast) + elseif types._list_Q(ast) then + return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._vector_Q(ast) then + return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._hash_map_Q(ast) then + local new_hm = {} + for k,v in pairs(ast) do + new_hm[k] = EVAL(v, env) + end + return HashMap:new(new_hm) + else + return ast + end +end + +function EVAL(ast, env) + --print("EVAL: "..printer._pr_str(ast,true)) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + local a0,a1,a2 = ast[1], ast[2],ast[3] + if not a0 then return ast end + local a0sym = types._symbol_Q(a0) and a0.val or "" + if 'def!' == a0sym then + return env:set(a1, EVAL(a2, env)) + elseif 'let*' == a0sym then + local let_env = Env:new(env) + for i = 1,#a1,2 do + let_env:set(a1[i], EVAL(a1[i+1], let_env)) + end + return EVAL(a2, let_env) + else + local args = eval_ast(ast, env) + local f = table.remove(args, 1) + return f(table.unpack(args)) + end +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +local repl_env = Env:new() +function rep(str) + return PRINT(EVAL(READ(str),repl_env)) +end + +repl_env:set(types.Symbol:new('+'), function(a,b) return a+b end) +repl_env:set(types.Symbol:new('-'), function(a,b) return a-b end) +repl_env:set(types.Symbol:new('*'), function(a,b) return a*b end) +repl_env:set(types.Symbol:new('/'), function(a,b) return math.floor(a/b) end) + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true +end + +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() + print(rep(line)) + end, function(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end + end) +end diff --git a/impls/lua/step4_if_fn_do.lua b/impls/lua/step4_if_fn_do.lua index 23cdc8ea82..12d38a89a7 100755 --- a/impls/lua/step4_if_fn_do.lua +++ b/impls/lua/step4_if_fn_do.lua @@ -1,111 +1,111 @@ -#!/usr/bin/env lua - -local table = require('table') - -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local Env = require('env') -local core = require('core') -local List, Vector, HashMap = types.List, types.Vector, types.HashMap - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function eval_ast(ast, env) - if types._symbol_Q(ast) then - return env:get(ast) - elseif types._list_Q(ast) then - return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._vector_Q(ast) then - return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._hash_map_Q(ast) then - local new_hm = {} - for k,v in pairs(ast) do - new_hm[k] = EVAL(v, env) - end - return HashMap:new(new_hm) - else - return ast - end -end - -function EVAL(ast, env) - --print("EVAL: "..printer._pr_str(ast,true)) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] - if not a0 then return ast end - local a0sym = types._symbol_Q(a0) and a0.val or "" - if 'def!' == a0sym then - return env:set(a1, EVAL(a2, env)) - elseif 'let*' == a0sym then - local let_env = Env:new(env) - for i = 1,#a1,2 do - let_env:set(a1[i], EVAL(a1[i+1], let_env)) - end - return EVAL(a2, let_env) - elseif 'do' == a0sym then - local el = eval_ast(ast:slice(2,#ast), env) - return el[#el] - elseif 'if' == a0sym then - local cond = EVAL(a1, env) - if cond == types.Nil or cond == false then - if #ast > 3 then return EVAL(a3, env) else return types.Nil end - else - return EVAL(a2, env) - end - elseif 'fn*' == a0sym then - return function(...) - return EVAL(a2, Env:new(env, a1, table.pack(...))) - end - else - local args = eval_ast(ast, env) - local f = table.remove(args, 1) - return f(table.unpack(args)) - end -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -local repl_env = Env:new() -function rep(str) - return PRINT(EVAL(READ(str),repl_env)) -end - --- core.lua: defined using Lua -for k,v in pairs(core.ns) do - repl_env:set(types.Symbol:new(k), v) -end - --- core.mal: defined using mal -rep("(def! not (fn* (a) (if a false true)))") - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true -end - -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() - print(rep(line)) - end, function(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end - end) -end +#!/usr/bin/env lua + +local table = require('table') + +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local Env = require('env') +local core = require('core') +local List, Vector, HashMap = types.List, types.Vector, types.HashMap + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function eval_ast(ast, env) + if types._symbol_Q(ast) then + return env:get(ast) + elseif types._list_Q(ast) then + return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._vector_Q(ast) then + return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._hash_map_Q(ast) then + local new_hm = {} + for k,v in pairs(ast) do + new_hm[k] = EVAL(v, env) + end + return HashMap:new(new_hm) + else + return ast + end +end + +function EVAL(ast, env) + --print("EVAL: "..printer._pr_str(ast,true)) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] + if not a0 then return ast end + local a0sym = types._symbol_Q(a0) and a0.val or "" + if 'def!' == a0sym then + return env:set(a1, EVAL(a2, env)) + elseif 'let*' == a0sym then + local let_env = Env:new(env) + for i = 1,#a1,2 do + let_env:set(a1[i], EVAL(a1[i+1], let_env)) + end + return EVAL(a2, let_env) + elseif 'do' == a0sym then + local el = eval_ast(ast:slice(2,#ast), env) + return el[#el] + elseif 'if' == a0sym then + local cond = EVAL(a1, env) + if cond == types.Nil or cond == false then + if #ast > 3 then return EVAL(a3, env) else return types.Nil end + else + return EVAL(a2, env) + end + elseif 'fn*' == a0sym then + return function(...) + return EVAL(a2, Env:new(env, a1, table.pack(...))) + end + else + local args = eval_ast(ast, env) + local f = table.remove(args, 1) + return f(table.unpack(args)) + end +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +local repl_env = Env:new() +function rep(str) + return PRINT(EVAL(READ(str),repl_env)) +end + +-- core.lua: defined using Lua +for k,v in pairs(core.ns) do + repl_env:set(types.Symbol:new(k), v) +end + +-- core.mal: defined using mal +rep("(def! not (fn* (a) (if a false true)))") + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true +end + +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() + print(rep(line)) + end, function(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end + end) +end diff --git a/impls/lua/step5_tco.lua b/impls/lua/step5_tco.lua index d8c6742a04..fb16e39bb8 100755 --- a/impls/lua/step5_tco.lua +++ b/impls/lua/step5_tco.lua @@ -1,119 +1,119 @@ -#!/usr/bin/env lua - -local table = require('table') - -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local Env = require('env') -local core = require('core') -local List, Vector, HashMap = types.List, types.Vector, types.HashMap - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function eval_ast(ast, env) - if types._symbol_Q(ast) then - return env:get(ast) - elseif types._list_Q(ast) then - return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._vector_Q(ast) then - return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._hash_map_Q(ast) then - local new_hm = {} - for k,v in pairs(ast) do - new_hm[k] = EVAL(v, env) - end - return HashMap:new(new_hm) - else - return ast - end -end - -function EVAL(ast, env) - while true do - --print("EVAL: "..printer._pr_str(ast,true)) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] - if not a0 then return ast end - local a0sym = types._symbol_Q(a0) and a0.val or "" - if 'def!' == a0sym then - return env:set(a1, EVAL(a2, env)) - elseif 'let*' == a0sym then - local let_env = Env:new(env) - for i = 1,#a1,2 do - let_env:set(a1[i], EVAL(a1[i+1], let_env)) - end - env = let_env - ast = a2 -- TCO - elseif 'do' == a0sym then - local el = eval_ast(ast:slice(2,#ast-1), env) - ast = ast[#ast] -- TCO - elseif 'if' == a0sym then - local cond = EVAL(a1, env) - if cond == types.Nil or cond == false then - if #ast > 3 then ast = a3 else return types.Nil end -- TCO - else - ast = a2 -- TCO - end - elseif 'fn*' == a0sym then - return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, table.pack(...))) - end, a2, env, a1) - else - local args = eval_ast(ast, env) - local f = table.remove(args, 1) - if types._malfunc_Q(f) then - ast = f.ast - env = Env:new(f.env, f.params, args) -- TCO - else - return f(table.unpack(args)) - end - end - end -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -local repl_env = Env:new() -function rep(str) - return PRINT(EVAL(READ(str),repl_env)) -end - --- core.lua: defined using Lua -for k,v in pairs(core.ns) do - repl_env:set(types.Symbol:new(k), v) -end - --- core.mal: defined using mal -rep("(def! not (fn* (a) (if a false true)))") - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true -end - -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() - print(rep(line)) - end, function(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end - end) -end +#!/usr/bin/env lua + +local table = require('table') + +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local Env = require('env') +local core = require('core') +local List, Vector, HashMap = types.List, types.Vector, types.HashMap + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function eval_ast(ast, env) + if types._symbol_Q(ast) then + return env:get(ast) + elseif types._list_Q(ast) then + return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._vector_Q(ast) then + return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._hash_map_Q(ast) then + local new_hm = {} + for k,v in pairs(ast) do + new_hm[k] = EVAL(v, env) + end + return HashMap:new(new_hm) + else + return ast + end +end + +function EVAL(ast, env) + while true do + --print("EVAL: "..printer._pr_str(ast,true)) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] + if not a0 then return ast end + local a0sym = types._symbol_Q(a0) and a0.val or "" + if 'def!' == a0sym then + return env:set(a1, EVAL(a2, env)) + elseif 'let*' == a0sym then + local let_env = Env:new(env) + for i = 1,#a1,2 do + let_env:set(a1[i], EVAL(a1[i+1], let_env)) + end + env = let_env + ast = a2 -- TCO + elseif 'do' == a0sym then + local el = eval_ast(ast:slice(2,#ast-1), env) + ast = ast[#ast] -- TCO + elseif 'if' == a0sym then + local cond = EVAL(a1, env) + if cond == types.Nil or cond == false then + if #ast > 3 then ast = a3 else return types.Nil end -- TCO + else + ast = a2 -- TCO + end + elseif 'fn*' == a0sym then + return types.MalFunc:new(function(...) + return EVAL(a2, Env:new(env, a1, table.pack(...))) + end, a2, env, a1) + else + local args = eval_ast(ast, env) + local f = table.remove(args, 1) + if types._malfunc_Q(f) then + ast = f.ast + env = Env:new(f.env, f.params, args) -- TCO + else + return f(table.unpack(args)) + end + end + end +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +local repl_env = Env:new() +function rep(str) + return PRINT(EVAL(READ(str),repl_env)) +end + +-- core.lua: defined using Lua +for k,v in pairs(core.ns) do + repl_env:set(types.Symbol:new(k), v) +end + +-- core.mal: defined using mal +rep("(def! not (fn* (a) (if a false true)))") + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true +end + +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() + print(rep(line)) + end, function(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end + end) +end diff --git a/impls/lua/step6_file.lua b/impls/lua/step6_file.lua index 152b617eed..f605aef10e 100755 --- a/impls/lua/step6_file.lua +++ b/impls/lua/step6_file.lua @@ -1,129 +1,129 @@ -#!/usr/bin/env lua - -local table = require('table') - -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local Env = require('env') -local core = require('core') -local List, Vector, HashMap = types.List, types.Vector, types.HashMap - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function eval_ast(ast, env) - if types._symbol_Q(ast) then - return env:get(ast) - elseif types._list_Q(ast) then - return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._vector_Q(ast) then - return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._hash_map_Q(ast) then - local new_hm = {} - for k,v in pairs(ast) do - new_hm[k] = EVAL(v, env) - end - return HashMap:new(new_hm) - else - return ast - end -end - -function EVAL(ast, env) - while true do - --print("EVAL: "..printer._pr_str(ast,true)) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] - if not a0 then return ast end - local a0sym = types._symbol_Q(a0) and a0.val or "" - if 'def!' == a0sym then - return env:set(a1, EVAL(a2, env)) - elseif 'let*' == a0sym then - local let_env = Env:new(env) - for i = 1,#a1,2 do - let_env:set(a1[i], EVAL(a1[i+1], let_env)) - end - env = let_env - ast = a2 -- TCO - elseif 'do' == a0sym then - local el = eval_ast(ast:slice(2,#ast-1), env) - ast = ast[#ast] -- TCO - elseif 'if' == a0sym then - local cond = EVAL(a1, env) - if cond == types.Nil or cond == false then - if #ast > 3 then ast = a3 else return types.Nil end -- TCO - else - ast = a2 -- TCO - end - elseif 'fn*' == a0sym then - return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, table.pack(...))) - end, a2, env, a1) - else - local args = eval_ast(ast, env) - local f = table.remove(args, 1) - if types._malfunc_Q(f) then - ast = f.ast - env = Env:new(f.env, f.params, args) -- TCO - else - return f(table.unpack(args)) - end - end - end -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -local repl_env = Env:new() -function rep(str) - return PRINT(EVAL(READ(str),repl_env)) -end - --- core.lua: defined using Lua -for k,v in pairs(core.ns) do - repl_env:set(types.Symbol:new(k), v) -end -repl_env:set(types.Symbol:new('eval'), - function(ast) return EVAL(ast, repl_env) end) -repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) - --- core.mal: defined using mal -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true - table.remove(arg,1) -end - -if #arg > 0 then - rep("(load-file \""..arg[1].."\")") - os.exit(0) -end - -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() - print(rep(line)) - end, function(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end - end) -end +#!/usr/bin/env lua + +local table = require('table') + +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local Env = require('env') +local core = require('core') +local List, Vector, HashMap = types.List, types.Vector, types.HashMap + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function eval_ast(ast, env) + if types._symbol_Q(ast) then + return env:get(ast) + elseif types._list_Q(ast) then + return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._vector_Q(ast) then + return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._hash_map_Q(ast) then + local new_hm = {} + for k,v in pairs(ast) do + new_hm[k] = EVAL(v, env) + end + return HashMap:new(new_hm) + else + return ast + end +end + +function EVAL(ast, env) + while true do + --print("EVAL: "..printer._pr_str(ast,true)) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] + if not a0 then return ast end + local a0sym = types._symbol_Q(a0) and a0.val or "" + if 'def!' == a0sym then + return env:set(a1, EVAL(a2, env)) + elseif 'let*' == a0sym then + local let_env = Env:new(env) + for i = 1,#a1,2 do + let_env:set(a1[i], EVAL(a1[i+1], let_env)) + end + env = let_env + ast = a2 -- TCO + elseif 'do' == a0sym then + local el = eval_ast(ast:slice(2,#ast-1), env) + ast = ast[#ast] -- TCO + elseif 'if' == a0sym then + local cond = EVAL(a1, env) + if cond == types.Nil or cond == false then + if #ast > 3 then ast = a3 else return types.Nil end -- TCO + else + ast = a2 -- TCO + end + elseif 'fn*' == a0sym then + return types.MalFunc:new(function(...) + return EVAL(a2, Env:new(env, a1, table.pack(...))) + end, a2, env, a1) + else + local args = eval_ast(ast, env) + local f = table.remove(args, 1) + if types._malfunc_Q(f) then + ast = f.ast + env = Env:new(f.env, f.params, args) -- TCO + else + return f(table.unpack(args)) + end + end + end +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +local repl_env = Env:new() +function rep(str) + return PRINT(EVAL(READ(str),repl_env)) +end + +-- core.lua: defined using Lua +for k,v in pairs(core.ns) do + repl_env:set(types.Symbol:new(k), v) +end +repl_env:set(types.Symbol:new('eval'), + function(ast) return EVAL(ast, repl_env) end) +repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) + +-- core.mal: defined using mal +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true + table.remove(arg,1) +end + +if #arg > 0 then + rep("(load-file \""..arg[1].."\")") + os.exit(0) +end + +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() + print(rep(line)) + end, function(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end + end) +end diff --git a/impls/lua/step7_quote.lua b/impls/lua/step7_quote.lua index 4c84378c43..bd756ddfb6 100755 --- a/impls/lua/step7_quote.lua +++ b/impls/lua/step7_quote.lua @@ -1,168 +1,168 @@ -#!/usr/bin/env lua - -local table = require('table') - -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local Env = require('env') -local core = require('core') -local List, Vector, HashMap = types.List, types.Vector, types.HashMap - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function starts_with(ast, sym) - return 0 < #ast and types._symbol_Q(ast[1]) and ast[1].val == sym -end - -function quasiquote_loop(ast) - local acc = types.List:new({}) - for i = #ast,1,-1 do - local elt = ast[i] - if types._list_Q(elt) and starts_with(elt, "splice-unquote") then - acc = types.List:new({types.Symbol:new("concat"), elt[2], acc}) - else - acc = types.List:new({types.Symbol:new("cons"), quasiquote(elt), acc}) - end - end - return acc -end - -function quasiquote(ast) - if types._list_Q(ast) then - if starts_with(ast, "unquote") then - return ast[2] - else - return quasiquote_loop(ast) - end - elseif types._vector_Q(ast) then - return types.List:new({types.Symbol:new("vec"), quasiquote_loop(ast)}) - elseif types._symbol_Q(ast) or types._hash_map_Q(ast) then - return types.List:new({types.Symbol:new("quote"), ast}) - else - return ast - end -end - -function eval_ast(ast, env) - if types._symbol_Q(ast) then - return env:get(ast) - elseif types._list_Q(ast) then - return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._vector_Q(ast) then - return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._hash_map_Q(ast) then - local new_hm = {} - for k,v in pairs(ast) do - new_hm[k] = EVAL(v, env) - end - return HashMap:new(new_hm) - else - return ast - end -end - -function EVAL(ast, env) - while true do - --print("EVAL: "..printer._pr_str(ast,true)) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] - if not a0 then return ast end - local a0sym = types._symbol_Q(a0) and a0.val or "" - if 'def!' == a0sym then - return env:set(a1, EVAL(a2, env)) - elseif 'let*' == a0sym then - local let_env = Env:new(env) - for i = 1,#a1,2 do - let_env:set(a1[i], EVAL(a1[i+1], let_env)) - end - env = let_env - ast = a2 -- TCO - elseif 'quote' == a0sym then - return a1 - elseif 'quasiquoteexpand' == a0sym then - return quasiquote(a1) - elseif 'quasiquote' == a0sym then - ast = quasiquote(a1) -- TCO - elseif 'do' == a0sym then - local el = eval_ast(ast:slice(2,#ast-1), env) - ast = ast[#ast] -- TCO - elseif 'if' == a0sym then - local cond = EVAL(a1, env) - if cond == types.Nil or cond == false then - if #ast > 3 then ast = a3 else return types.Nil end -- TCO - else - ast = a2 -- TCO - end - elseif 'fn*' == a0sym then - return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, table.pack(...))) - end, a2, env, a1) - else - local args = eval_ast(ast, env) - local f = table.remove(args, 1) - if types._malfunc_Q(f) then - ast = f.ast - env = Env:new(f.env, f.params, args) -- TCO - else - return f(table.unpack(args)) - end - end - end -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -local repl_env = Env:new() -function rep(str) - return PRINT(EVAL(READ(str),repl_env)) -end - --- core.lua: defined using Lua -for k,v in pairs(core.ns) do - repl_env:set(types.Symbol:new(k), v) -end -repl_env:set(types.Symbol:new('eval'), - function(ast) return EVAL(ast, repl_env) end) -repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) - --- core.mal: defined using mal -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true - table.remove(arg,1) -end - -if #arg > 0 then - rep("(load-file \""..arg[1].."\")") - os.exit(0) -end - -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() - print(rep(line)) - end, function(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end - end) -end +#!/usr/bin/env lua + +local table = require('table') + +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local Env = require('env') +local core = require('core') +local List, Vector, HashMap = types.List, types.Vector, types.HashMap + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function starts_with(ast, sym) + return 0 < #ast and types._symbol_Q(ast[1]) and ast[1].val == sym +end + +function quasiquote_loop(ast) + local acc = types.List:new({}) + for i = #ast,1,-1 do + local elt = ast[i] + if types._list_Q(elt) and starts_with(elt, "splice-unquote") then + acc = types.List:new({types.Symbol:new("concat"), elt[2], acc}) + else + acc = types.List:new({types.Symbol:new("cons"), quasiquote(elt), acc}) + end + end + return acc +end + +function quasiquote(ast) + if types._list_Q(ast) then + if starts_with(ast, "unquote") then + return ast[2] + else + return quasiquote_loop(ast) + end + elseif types._vector_Q(ast) then + return types.List:new({types.Symbol:new("vec"), quasiquote_loop(ast)}) + elseif types._symbol_Q(ast) or types._hash_map_Q(ast) then + return types.List:new({types.Symbol:new("quote"), ast}) + else + return ast + end +end + +function eval_ast(ast, env) + if types._symbol_Q(ast) then + return env:get(ast) + elseif types._list_Q(ast) then + return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._vector_Q(ast) then + return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._hash_map_Q(ast) then + local new_hm = {} + for k,v in pairs(ast) do + new_hm[k] = EVAL(v, env) + end + return HashMap:new(new_hm) + else + return ast + end +end + +function EVAL(ast, env) + while true do + --print("EVAL: "..printer._pr_str(ast,true)) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] + if not a0 then return ast end + local a0sym = types._symbol_Q(a0) and a0.val or "" + if 'def!' == a0sym then + return env:set(a1, EVAL(a2, env)) + elseif 'let*' == a0sym then + local let_env = Env:new(env) + for i = 1,#a1,2 do + let_env:set(a1[i], EVAL(a1[i+1], let_env)) + end + env = let_env + ast = a2 -- TCO + elseif 'quote' == a0sym then + return a1 + elseif 'quasiquoteexpand' == a0sym then + return quasiquote(a1) + elseif 'quasiquote' == a0sym then + ast = quasiquote(a1) -- TCO + elseif 'do' == a0sym then + local el = eval_ast(ast:slice(2,#ast-1), env) + ast = ast[#ast] -- TCO + elseif 'if' == a0sym then + local cond = EVAL(a1, env) + if cond == types.Nil or cond == false then + if #ast > 3 then ast = a3 else return types.Nil end -- TCO + else + ast = a2 -- TCO + end + elseif 'fn*' == a0sym then + return types.MalFunc:new(function(...) + return EVAL(a2, Env:new(env, a1, table.pack(...))) + end, a2, env, a1) + else + local args = eval_ast(ast, env) + local f = table.remove(args, 1) + if types._malfunc_Q(f) then + ast = f.ast + env = Env:new(f.env, f.params, args) -- TCO + else + return f(table.unpack(args)) + end + end + end +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +local repl_env = Env:new() +function rep(str) + return PRINT(EVAL(READ(str),repl_env)) +end + +-- core.lua: defined using Lua +for k,v in pairs(core.ns) do + repl_env:set(types.Symbol:new(k), v) +end +repl_env:set(types.Symbol:new('eval'), + function(ast) return EVAL(ast, repl_env) end) +repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) + +-- core.mal: defined using mal +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true + table.remove(arg,1) +end + +if #arg > 0 then + rep("(load-file \""..arg[1].."\")") + os.exit(0) +end + +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() + print(rep(line)) + end, function(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end + end) +end diff --git a/impls/lua/step8_macros.lua b/impls/lua/step8_macros.lua index c99c93671b..497a139e23 100755 --- a/impls/lua/step8_macros.lua +++ b/impls/lua/step8_macros.lua @@ -1,196 +1,196 @@ -#!/usr/bin/env lua - -local table = require('table') - -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local Env = require('env') -local core = require('core') -local List, Vector, HashMap = types.List, types.Vector, types.HashMap - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function starts_with(ast, sym) - return 0 < #ast and types._symbol_Q(ast[1]) and ast[1].val == sym -end - -function quasiquote_loop(ast) - local acc = types.List:new({}) - for i = #ast,1,-1 do - local elt = ast[i] - if types._list_Q(elt) and starts_with(elt, "splice-unquote") then - acc = types.List:new({types.Symbol:new("concat"), elt[2], acc}) - else - acc = types.List:new({types.Symbol:new("cons"), quasiquote(elt), acc}) - end - end - return acc -end - -function quasiquote(ast) - if types._list_Q(ast) then - if starts_with(ast, "unquote") then - return ast[2] - else - return quasiquote_loop(ast) - end - elseif types._vector_Q(ast) then - return types.List:new({types.Symbol:new("vec"), quasiquote_loop(ast)}) - elseif types._symbol_Q(ast) or types._hash_map_Q(ast) then - return types.List:new({types.Symbol:new("quote"), ast}) - else - return ast - end -end - -function is_macro_call(ast, env) - if types._list_Q(ast) and - types._symbol_Q(ast[1]) and - env:find(ast[1]) then - local f = env:get(ast[1]) - return types._malfunc_Q(f) and f.ismacro - end -end - -function macroexpand(ast, env) - while is_macro_call(ast, env) do - local mac = env:get(ast[1]) - ast = mac.fn(table.unpack(ast:slice(2))) - end - return ast -end - -function eval_ast(ast, env) - if types._symbol_Q(ast) then - return env:get(ast) - elseif types._list_Q(ast) then - return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._vector_Q(ast) then - return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._hash_map_Q(ast) then - local new_hm = {} - for k,v in pairs(ast) do - new_hm[k] = EVAL(v, env) - end - return HashMap:new(new_hm) - else - return ast - end -end - -function EVAL(ast, env) - while true do - --print("EVAL: "..printer._pr_str(ast,true)) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - -- apply list - ast = macroexpand(ast, env) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] - if not a0 then return ast end - local a0sym = types._symbol_Q(a0) and a0.val or "" - if 'def!' == a0sym then - return env:set(a1, EVAL(a2, env)) - elseif 'let*' == a0sym then - local let_env = Env:new(env) - for i = 1,#a1,2 do - let_env:set(a1[i], EVAL(a1[i+1], let_env)) - end - env = let_env - ast = a2 -- TCO - elseif 'quote' == a0sym then - return a1 - elseif 'quasiquoteexpand' == a0sym then - return quasiquote(a1) - elseif 'quasiquote' == a0sym then - ast = quasiquote(a1) -- TCO - elseif 'defmacro!' == a0sym then - local mac = EVAL(a2, env) - mac.ismacro = true - return env:set(a1, mac) - elseif 'macroexpand' == a0sym then - return macroexpand(a1, env) - elseif 'do' == a0sym then - local el = eval_ast(ast:slice(2,#ast-1), env) - ast = ast[#ast] -- TCO - elseif 'if' == a0sym then - local cond = EVAL(a1, env) - if cond == types.Nil or cond == false then - if #ast > 3 then ast = a3 else return types.Nil end -- TCO - else - ast = a2 -- TCO - end - elseif 'fn*' == a0sym then - return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, table.pack(...))) - end, a2, env, a1) - else - local args = eval_ast(ast, env) - local f = table.remove(args, 1) - if types._malfunc_Q(f) then - ast = f.ast - env = Env:new(f.env, f.params, args) -- TCO - else - return f(table.unpack(args)) - end - end - end -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -local repl_env = Env:new() -function rep(str) - return PRINT(EVAL(READ(str),repl_env)) -end - --- core.lua: defined using Lua -for k,v in pairs(core.ns) do - repl_env:set(types.Symbol:new(k), v) -end -repl_env:set(types.Symbol:new('eval'), - function(ast) return EVAL(ast, repl_env) end) -repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) - --- core.mal: defined using mal -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))") - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true - table.remove(arg,1) -end - -if #arg > 0 then - rep("(load-file \""..arg[1].."\")") - os.exit(0) -end - -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() - print(rep(line)) - end, function(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end - end) -end +#!/usr/bin/env lua + +local table = require('table') + +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local Env = require('env') +local core = require('core') +local List, Vector, HashMap = types.List, types.Vector, types.HashMap + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function starts_with(ast, sym) + return 0 < #ast and types._symbol_Q(ast[1]) and ast[1].val == sym +end + +function quasiquote_loop(ast) + local acc = types.List:new({}) + for i = #ast,1,-1 do + local elt = ast[i] + if types._list_Q(elt) and starts_with(elt, "splice-unquote") then + acc = types.List:new({types.Symbol:new("concat"), elt[2], acc}) + else + acc = types.List:new({types.Symbol:new("cons"), quasiquote(elt), acc}) + end + end + return acc +end + +function quasiquote(ast) + if types._list_Q(ast) then + if starts_with(ast, "unquote") then + return ast[2] + else + return quasiquote_loop(ast) + end + elseif types._vector_Q(ast) then + return types.List:new({types.Symbol:new("vec"), quasiquote_loop(ast)}) + elseif types._symbol_Q(ast) or types._hash_map_Q(ast) then + return types.List:new({types.Symbol:new("quote"), ast}) + else + return ast + end +end + +function is_macro_call(ast, env) + if types._list_Q(ast) and + types._symbol_Q(ast[1]) and + env:find(ast[1]) then + local f = env:get(ast[1]) + return types._malfunc_Q(f) and f.ismacro + end +end + +function macroexpand(ast, env) + while is_macro_call(ast, env) do + local mac = env:get(ast[1]) + ast = mac.fn(table.unpack(ast:slice(2))) + end + return ast +end + +function eval_ast(ast, env) + if types._symbol_Q(ast) then + return env:get(ast) + elseif types._list_Q(ast) then + return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._vector_Q(ast) then + return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._hash_map_Q(ast) then + local new_hm = {} + for k,v in pairs(ast) do + new_hm[k] = EVAL(v, env) + end + return HashMap:new(new_hm) + else + return ast + end +end + +function EVAL(ast, env) + while true do + --print("EVAL: "..printer._pr_str(ast,true)) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + -- apply list + ast = macroexpand(ast, env) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] + if not a0 then return ast end + local a0sym = types._symbol_Q(a0) and a0.val or "" + if 'def!' == a0sym then + return env:set(a1, EVAL(a2, env)) + elseif 'let*' == a0sym then + local let_env = Env:new(env) + for i = 1,#a1,2 do + let_env:set(a1[i], EVAL(a1[i+1], let_env)) + end + env = let_env + ast = a2 -- TCO + elseif 'quote' == a0sym then + return a1 + elseif 'quasiquoteexpand' == a0sym then + return quasiquote(a1) + elseif 'quasiquote' == a0sym then + ast = quasiquote(a1) -- TCO + elseif 'defmacro!' == a0sym then + local mac = EVAL(a2, env) + mac.ismacro = true + return env:set(a1, mac) + elseif 'macroexpand' == a0sym then + return macroexpand(a1, env) + elseif 'do' == a0sym then + local el = eval_ast(ast:slice(2,#ast-1), env) + ast = ast[#ast] -- TCO + elseif 'if' == a0sym then + local cond = EVAL(a1, env) + if cond == types.Nil or cond == false then + if #ast > 3 then ast = a3 else return types.Nil end -- TCO + else + ast = a2 -- TCO + end + elseif 'fn*' == a0sym then + return types.MalFunc:new(function(...) + return EVAL(a2, Env:new(env, a1, table.pack(...))) + end, a2, env, a1) + else + local args = eval_ast(ast, env) + local f = table.remove(args, 1) + if types._malfunc_Q(f) then + ast = f.ast + env = Env:new(f.env, f.params, args) -- TCO + else + return f(table.unpack(args)) + end + end + end +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +local repl_env = Env:new() +function rep(str) + return PRINT(EVAL(READ(str),repl_env)) +end + +-- core.lua: defined using Lua +for k,v in pairs(core.ns) do + repl_env:set(types.Symbol:new(k), v) +end +repl_env:set(types.Symbol:new('eval'), + function(ast) return EVAL(ast, repl_env) end) +repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) + +-- core.mal: defined using mal +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))") + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true + table.remove(arg,1) +end + +if #arg > 0 then + rep("(load-file \""..arg[1].."\")") + os.exit(0) +end + +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() + print(rep(line)) + end, function(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end + end) +end diff --git a/impls/lua/step9_try.lua b/impls/lua/step9_try.lua index 2ad0b93d8d..30fa45924e 100755 --- a/impls/lua/step9_try.lua +++ b/impls/lua/step9_try.lua @@ -1,216 +1,216 @@ -#!/usr/bin/env lua - -local table = require('table') - -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local Env = require('env') -local core = require('core') -local List, Vector, HashMap = types.List, types.Vector, types.HashMap - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function starts_with(ast, sym) - return 0 < #ast and types._symbol_Q(ast[1]) and ast[1].val == sym -end - -function quasiquote_loop(ast) - local acc = types.List:new({}) - for i = #ast,1,-1 do - local elt = ast[i] - if types._list_Q(elt) and starts_with(elt, "splice-unquote") then - acc = types.List:new({types.Symbol:new("concat"), elt[2], acc}) - else - acc = types.List:new({types.Symbol:new("cons"), quasiquote(elt), acc}) - end - end - return acc -end - -function quasiquote(ast) - if types._list_Q(ast) then - if starts_with(ast, "unquote") then - return ast[2] - else - return quasiquote_loop(ast) - end - elseif types._vector_Q(ast) then - return types.List:new({types.Symbol:new("vec"), quasiquote_loop(ast)}) - elseif types._symbol_Q(ast) or types._hash_map_Q(ast) then - return types.List:new({types.Symbol:new("quote"), ast}) - else - return ast - end -end - -function is_macro_call(ast, env) - if types._list_Q(ast) and - types._symbol_Q(ast[1]) and - env:find(ast[1]) then - local f = env:get(ast[1]) - return types._malfunc_Q(f) and f.ismacro - end -end - -function macroexpand(ast, env) - while is_macro_call(ast, env) do - local mac = env:get(ast[1]) - ast = mac.fn(table.unpack(ast:slice(2))) - end - return ast -end - -function eval_ast(ast, env) - if types._symbol_Q(ast) then - return env:get(ast) - elseif types._list_Q(ast) then - return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._vector_Q(ast) then - return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._hash_map_Q(ast) then - local new_hm = {} - for k,v in pairs(ast) do - new_hm[k] = EVAL(v, env) - end - return HashMap:new(new_hm) - else - return ast - end -end - -function EVAL(ast, env) - while true do - --print("EVAL: "..printer._pr_str(ast,true)) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - -- apply list - ast = macroexpand(ast, env) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] - if not a0 then return ast end - local a0sym = types._symbol_Q(a0) and a0.val or "" - if 'def!' == a0sym then - return env:set(a1, EVAL(a2, env)) - elseif 'let*' == a0sym then - local let_env = Env:new(env) - for i = 1,#a1,2 do - let_env:set(a1[i], EVAL(a1[i+1], let_env)) - end - env = let_env - ast = a2 -- TCO - elseif 'quote' == a0sym then - return a1 - elseif 'quasiquoteexpand' == a0sym then - return quasiquote(a1) - elseif 'quasiquote' == a0sym then - ast = quasiquote(a1) -- TCO - elseif 'defmacro!' == a0sym then - local mac = EVAL(a2, env) - mac.ismacro = true - return env:set(a1, mac) - elseif 'macroexpand' == a0sym then - return macroexpand(a1, env) - elseif 'try*' == a0sym then - local exc, result = nil, nil - xpcall(function() - result = EVAL(a1, env) - end, function(err) - exc = err - end) - if exc ~= nil then - if types._malexception_Q(exc) then - exc = exc.val - end - if a2 and a2[1].val == 'catch*' then - result = EVAL(a2[3], Env:new(env, {a2[2]}, {exc})) - else - types.throw(exc) - end - end - return result - elseif 'do' == a0sym then - local el = eval_ast(ast:slice(2,#ast-1), env) - ast = ast[#ast] -- TCO - elseif 'if' == a0sym then - local cond = EVAL(a1, env) - if cond == types.Nil or cond == false then - if #ast > 3 then ast = a3 else return types.Nil end -- TCO - else - ast = a2 -- TCO - end - elseif 'fn*' == a0sym then - return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, table.pack(...))) - end, a2, env, a1) - else - local args = eval_ast(ast, env) - local f = table.remove(args, 1) - if types._malfunc_Q(f) then - ast = f.ast - env = Env:new(f.env, f.params, args) -- TCO - else - return f(table.unpack(args)) - end - end - end -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -local repl_env = Env:new() -function rep(str) - return PRINT(EVAL(READ(str),repl_env)) -end - --- core.lua: defined using Lua -for k,v in pairs(core.ns) do - repl_env:set(types.Symbol:new(k), v) -end -repl_env:set(types.Symbol:new('eval'), - function(ast) return EVAL(ast, repl_env) end) -repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) - --- core.mal: defined using mal -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))") - -function print_exception(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end -end - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true - table.remove(arg,1) -end - -if #arg > 0 then - xpcall(function() rep("(load-file \""..arg[1].."\")") end, - print_exception) - os.exit(0) -end - -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() print(rep(line)) end, - print_exception) -end +#!/usr/bin/env lua + +local table = require('table') + +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local Env = require('env') +local core = require('core') +local List, Vector, HashMap = types.List, types.Vector, types.HashMap + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function starts_with(ast, sym) + return 0 < #ast and types._symbol_Q(ast[1]) and ast[1].val == sym +end + +function quasiquote_loop(ast) + local acc = types.List:new({}) + for i = #ast,1,-1 do + local elt = ast[i] + if types._list_Q(elt) and starts_with(elt, "splice-unquote") then + acc = types.List:new({types.Symbol:new("concat"), elt[2], acc}) + else + acc = types.List:new({types.Symbol:new("cons"), quasiquote(elt), acc}) + end + end + return acc +end + +function quasiquote(ast) + if types._list_Q(ast) then + if starts_with(ast, "unquote") then + return ast[2] + else + return quasiquote_loop(ast) + end + elseif types._vector_Q(ast) then + return types.List:new({types.Symbol:new("vec"), quasiquote_loop(ast)}) + elseif types._symbol_Q(ast) or types._hash_map_Q(ast) then + return types.List:new({types.Symbol:new("quote"), ast}) + else + return ast + end +end + +function is_macro_call(ast, env) + if types._list_Q(ast) and + types._symbol_Q(ast[1]) and + env:find(ast[1]) then + local f = env:get(ast[1]) + return types._malfunc_Q(f) and f.ismacro + end +end + +function macroexpand(ast, env) + while is_macro_call(ast, env) do + local mac = env:get(ast[1]) + ast = mac.fn(table.unpack(ast:slice(2))) + end + return ast +end + +function eval_ast(ast, env) + if types._symbol_Q(ast) then + return env:get(ast) + elseif types._list_Q(ast) then + return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._vector_Q(ast) then + return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._hash_map_Q(ast) then + local new_hm = {} + for k,v in pairs(ast) do + new_hm[k] = EVAL(v, env) + end + return HashMap:new(new_hm) + else + return ast + end +end + +function EVAL(ast, env) + while true do + --print("EVAL: "..printer._pr_str(ast,true)) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + -- apply list + ast = macroexpand(ast, env) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] + if not a0 then return ast end + local a0sym = types._symbol_Q(a0) and a0.val or "" + if 'def!' == a0sym then + return env:set(a1, EVAL(a2, env)) + elseif 'let*' == a0sym then + local let_env = Env:new(env) + for i = 1,#a1,2 do + let_env:set(a1[i], EVAL(a1[i+1], let_env)) + end + env = let_env + ast = a2 -- TCO + elseif 'quote' == a0sym then + return a1 + elseif 'quasiquoteexpand' == a0sym then + return quasiquote(a1) + elseif 'quasiquote' == a0sym then + ast = quasiquote(a1) -- TCO + elseif 'defmacro!' == a0sym then + local mac = EVAL(a2, env) + mac.ismacro = true + return env:set(a1, mac) + elseif 'macroexpand' == a0sym then + return macroexpand(a1, env) + elseif 'try*' == a0sym then + local exc, result = nil, nil + xpcall(function() + result = EVAL(a1, env) + end, function(err) + exc = err + end) + if exc ~= nil then + if types._malexception_Q(exc) then + exc = exc.val + end + if a2 and a2[1].val == 'catch*' then + result = EVAL(a2[3], Env:new(env, {a2[2]}, {exc})) + else + types.throw(exc) + end + end + return result + elseif 'do' == a0sym then + local el = eval_ast(ast:slice(2,#ast-1), env) + ast = ast[#ast] -- TCO + elseif 'if' == a0sym then + local cond = EVAL(a1, env) + if cond == types.Nil or cond == false then + if #ast > 3 then ast = a3 else return types.Nil end -- TCO + else + ast = a2 -- TCO + end + elseif 'fn*' == a0sym then + return types.MalFunc:new(function(...) + return EVAL(a2, Env:new(env, a1, table.pack(...))) + end, a2, env, a1) + else + local args = eval_ast(ast, env) + local f = table.remove(args, 1) + if types._malfunc_Q(f) then + ast = f.ast + env = Env:new(f.env, f.params, args) -- TCO + else + return f(table.unpack(args)) + end + end + end +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +local repl_env = Env:new() +function rep(str) + return PRINT(EVAL(READ(str),repl_env)) +end + +-- core.lua: defined using Lua +for k,v in pairs(core.ns) do + repl_env:set(types.Symbol:new(k), v) +end +repl_env:set(types.Symbol:new('eval'), + function(ast) return EVAL(ast, repl_env) end) +repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) + +-- core.mal: defined using mal +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))") + +function print_exception(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end +end + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true + table.remove(arg,1) +end + +if #arg > 0 then + xpcall(function() rep("(load-file \""..arg[1].."\")") end, + print_exception) + os.exit(0) +end + +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() print(rep(line)) end, + print_exception) +end diff --git a/impls/lua/stepA_mal.lua b/impls/lua/stepA_mal.lua index 5aa947479b..1438d624be 100755 --- a/impls/lua/stepA_mal.lua +++ b/impls/lua/stepA_mal.lua @@ -1,219 +1,219 @@ -#!/usr/bin/env lua - -local table = require('table') - -package.path = '../lua/?.lua;' .. package.path -local readline = require('readline') -local utils = require('utils') -local types = require('types') -local reader = require('reader') -local printer = require('printer') -local Env = require('env') -local core = require('core') -local List, Vector, HashMap = types.List, types.Vector, types.HashMap - --- read -function READ(str) - return reader.read_str(str) -end - --- eval -function starts_with(ast, sym) - return 0 < #ast and types._symbol_Q(ast[1]) and ast[1].val == sym -end - -function quasiquote_loop(ast) - local acc = types.List:new({}) - for i = #ast,1,-1 do - local elt = ast[i] - if types._list_Q(elt) and starts_with(elt, "splice-unquote") then - acc = types.List:new({types.Symbol:new("concat"), elt[2], acc}) - else - acc = types.List:new({types.Symbol:new("cons"), quasiquote(elt), acc}) - end - end - return acc -end - -function quasiquote(ast) - if types._list_Q(ast) then - if starts_with(ast, "unquote") then - return ast[2] - else - return quasiquote_loop(ast) - end - elseif types._vector_Q(ast) then - return types.List:new({types.Symbol:new("vec"), quasiquote_loop(ast)}) - elseif types._symbol_Q(ast) or types._hash_map_Q(ast) then - return types.List:new({types.Symbol:new("quote"), ast}) - else - return ast - end -end - -function is_macro_call(ast, env) - if types._list_Q(ast) and - types._symbol_Q(ast[1]) and - env:find(ast[1]) then - local f = env:get(ast[1]) - return types._malfunc_Q(f) and f.ismacro - end -end - -function macroexpand(ast, env) - while is_macro_call(ast, env) do - local mac = env:get(ast[1]) - ast = mac.fn(table.unpack(ast:slice(2))) - end - return ast -end - -function eval_ast(ast, env) - if types._symbol_Q(ast) then - return env:get(ast) - elseif types._list_Q(ast) then - return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._vector_Q(ast) then - return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) - elseif types._hash_map_Q(ast) then - local new_hm = {} - for k,v in pairs(ast) do - new_hm[k] = EVAL(v, env) - end - return HashMap:new(new_hm) - else - return ast - end -end - -function EVAL(ast, env) - while true do - --print("EVAL: "..printer._pr_str(ast,true)) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - -- apply list - ast = macroexpand(ast, env) - if not types._list_Q(ast) then return eval_ast(ast, env) end - - local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] - if not a0 then return ast end - local a0sym = types._symbol_Q(a0) and a0.val or "" - if 'def!' == a0sym then - return env:set(a1, EVAL(a2, env)) - elseif 'let*' == a0sym then - local let_env = Env:new(env) - for i = 1,#a1,2 do - let_env:set(a1[i], EVAL(a1[i+1], let_env)) - end - env = let_env - ast = a2 -- TCO - elseif 'quote' == a0sym then - return a1 - elseif 'quasiquoteexpand' == a0sym then - return quasiquote(a1) - elseif 'quasiquote' == a0sym then - ast = quasiquote(a1) -- TCO - elseif 'defmacro!' == a0sym then - local mac = EVAL(a2, env) - mac.ismacro = true - return env:set(a1, mac) - elseif 'macroexpand' == a0sym then - return macroexpand(a1, env) - elseif 'try*' == a0sym then - local exc, result = nil, nil - xpcall(function() - result = EVAL(a1, env) - end, function(err) - exc = err - end) - if exc ~= nil then - if types._malexception_Q(exc) then - exc = exc.val - end - if a2 and a2[1].val == 'catch*' then - result = EVAL(a2[3], Env:new(env, {a2[2]}, {exc})) - else - types.throw(exc) - end - end - return result - elseif 'do' == a0sym then - local el = eval_ast(ast:slice(2,#ast-1), env) - ast = ast[#ast] -- TCO - elseif 'if' == a0sym then - local cond = EVAL(a1, env) - if cond == types.Nil or cond == false then - if #ast > 3 then ast = a3 else return types.Nil end -- TCO - else - ast = a2 -- TCO - end - elseif 'fn*' == a0sym then - return types.MalFunc:new(function(...) - return EVAL(a2, Env:new(env, a1, table.pack(...))) - end, a2, env, a1) - else - local args = eval_ast(ast, env) - local f = table.remove(args, 1) - if types._malfunc_Q(f) then - ast = f.ast - env = Env:new(f.env, f.params, args) -- TCO - else - return f(table.unpack(args)) - end - end - end -end - --- print -function PRINT(exp) - return printer._pr_str(exp, true) -end - --- repl -local repl_env = Env:new() -function rep(str) - return PRINT(EVAL(READ(str),repl_env)) -end - --- core.lua: defined using Lua -for k,v in pairs(core.ns) do - repl_env:set(types.Symbol:new(k), v) -end -repl_env:set(types.Symbol:new('eval'), - function(ast) return EVAL(ast, repl_env) end) -repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) - --- core.mal: defined using mal -rep("(def! *host-language* \"lua\")") -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))") - -function print_exception(exc) - if exc then - if types._malexception_Q(exc) then - exc = printer._pr_str(exc.val, true) - end - print("Error: " .. exc) - print(debug.traceback()) - end -end - -if #arg > 0 and arg[1] == "--raw" then - readline.raw = true - table.remove(arg,1) -end - -if #arg > 0 then - xpcall(function() rep("(load-file \""..arg[1].."\")") end, - print_exception) - os.exit(0) -end - -rep("(println (str \"Mal [\" *host-language* \"]\"))") -while true do - line = readline.readline("user> ") - if not line then break end - xpcall(function() print(rep(line)) end, - print_exception) -end +#!/usr/bin/env lua + +local table = require('table') + +package.path = '../lua/?.lua;' .. package.path +local readline = require('readline') +local utils = require('utils') +local types = require('types') +local reader = require('reader') +local printer = require('printer') +local Env = require('env') +local core = require('core') +local List, Vector, HashMap = types.List, types.Vector, types.HashMap + +-- read +function READ(str) + return reader.read_str(str) +end + +-- eval +function starts_with(ast, sym) + return 0 < #ast and types._symbol_Q(ast[1]) and ast[1].val == sym +end + +function quasiquote_loop(ast) + local acc = types.List:new({}) + for i = #ast,1,-1 do + local elt = ast[i] + if types._list_Q(elt) and starts_with(elt, "splice-unquote") then + acc = types.List:new({types.Symbol:new("concat"), elt[2], acc}) + else + acc = types.List:new({types.Symbol:new("cons"), quasiquote(elt), acc}) + end + end + return acc +end + +function quasiquote(ast) + if types._list_Q(ast) then + if starts_with(ast, "unquote") then + return ast[2] + else + return quasiquote_loop(ast) + end + elseif types._vector_Q(ast) then + return types.List:new({types.Symbol:new("vec"), quasiquote_loop(ast)}) + elseif types._symbol_Q(ast) or types._hash_map_Q(ast) then + return types.List:new({types.Symbol:new("quote"), ast}) + else + return ast + end +end + +function is_macro_call(ast, env) + if types._list_Q(ast) and + types._symbol_Q(ast[1]) and + env:find(ast[1]) then + local f = env:get(ast[1]) + return types._malfunc_Q(f) and f.ismacro + end +end + +function macroexpand(ast, env) + while is_macro_call(ast, env) do + local mac = env:get(ast[1]) + ast = mac.fn(table.unpack(ast:slice(2))) + end + return ast +end + +function eval_ast(ast, env) + if types._symbol_Q(ast) then + return env:get(ast) + elseif types._list_Q(ast) then + return List:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._vector_Q(ast) then + return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast)) + elseif types._hash_map_Q(ast) then + local new_hm = {} + for k,v in pairs(ast) do + new_hm[k] = EVAL(v, env) + end + return HashMap:new(new_hm) + else + return ast + end +end + +function EVAL(ast, env) + while true do + --print("EVAL: "..printer._pr_str(ast,true)) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + -- apply list + ast = macroexpand(ast, env) + if not types._list_Q(ast) then return eval_ast(ast, env) end + + local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4] + if not a0 then return ast end + local a0sym = types._symbol_Q(a0) and a0.val or "" + if 'def!' == a0sym then + return env:set(a1, EVAL(a2, env)) + elseif 'let*' == a0sym then + local let_env = Env:new(env) + for i = 1,#a1,2 do + let_env:set(a1[i], EVAL(a1[i+1], let_env)) + end + env = let_env + ast = a2 -- TCO + elseif 'quote' == a0sym then + return a1 + elseif 'quasiquoteexpand' == a0sym then + return quasiquote(a1) + elseif 'quasiquote' == a0sym then + ast = quasiquote(a1) -- TCO + elseif 'defmacro!' == a0sym then + local mac = EVAL(a2, env) + mac.ismacro = true + return env:set(a1, mac) + elseif 'macroexpand' == a0sym then + return macroexpand(a1, env) + elseif 'try*' == a0sym then + local exc, result = nil, nil + xpcall(function() + result = EVAL(a1, env) + end, function(err) + exc = err + end) + if exc ~= nil then + if types._malexception_Q(exc) then + exc = exc.val + end + if a2 and a2[1].val == 'catch*' then + result = EVAL(a2[3], Env:new(env, {a2[2]}, {exc})) + else + types.throw(exc) + end + end + return result + elseif 'do' == a0sym then + local el = eval_ast(ast:slice(2,#ast-1), env) + ast = ast[#ast] -- TCO + elseif 'if' == a0sym then + local cond = EVAL(a1, env) + if cond == types.Nil or cond == false then + if #ast > 3 then ast = a3 else return types.Nil end -- TCO + else + ast = a2 -- TCO + end + elseif 'fn*' == a0sym then + return types.MalFunc:new(function(...) + return EVAL(a2, Env:new(env, a1, table.pack(...))) + end, a2, env, a1) + else + local args = eval_ast(ast, env) + local f = table.remove(args, 1) + if types._malfunc_Q(f) then + ast = f.ast + env = Env:new(f.env, f.params, args) -- TCO + else + return f(table.unpack(args)) + end + end + end +end + +-- print +function PRINT(exp) + return printer._pr_str(exp, true) +end + +-- repl +local repl_env = Env:new() +function rep(str) + return PRINT(EVAL(READ(str),repl_env)) +end + +-- core.lua: defined using Lua +for k,v in pairs(core.ns) do + repl_env:set(types.Symbol:new(k), v) +end +repl_env:set(types.Symbol:new('eval'), + function(ast) return EVAL(ast, repl_env) end) +repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2))) + +-- core.mal: defined using mal +rep("(def! *host-language* \"lua\")") +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))") + +function print_exception(exc) + if exc then + if types._malexception_Q(exc) then + exc = printer._pr_str(exc.val, true) + end + print("Error: " .. exc) + print(debug.traceback()) + end +end + +if #arg > 0 and arg[1] == "--raw" then + readline.raw = true + table.remove(arg,1) +end + +if #arg > 0 then + xpcall(function() rep("(load-file \""..arg[1].."\")") end, + print_exception) + os.exit(0) +end + +rep("(println (str \"Mal [\" *host-language* \"]\"))") +while true do + line = readline.readline("user> ") + if not line then break end + xpcall(function() print(rep(line)) end, + print_exception) +end diff --git a/impls/lua/tests/step5_tco.mal b/impls/lua/tests/step5_tco.mal index 087368335f..ef06829c45 100644 --- a/impls/lua/tests/step5_tco.mal +++ b/impls/lua/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 100000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 100000)) +res1 +;=>nil diff --git a/impls/lua/tests/stepA_mal.mal b/impls/lua/tests/stepA_mal.mal index 70a142315d..bfea07a7b6 100644 --- a/impls/lua/tests/stepA_mal.mal +++ b/impls/lua/tests/stepA_mal.mal @@ -1,38 +1,38 @@ -;; Testing basic Lua interop - -;;; lua-eval adds the string "return " to the beginning of the evaluated string -;;; and supplies that to Lua's loadstring(). If complex programs are needed, -;;; those can be wrapped by an anonymous function which is called immediately -;;; (see the foo = 8 example below). - -(lua-eval "7") -;=>7 - -(lua-eval "'7'") -;=>"7" - -(lua-eval "123 == 123") -;=>true - -(lua-eval "123 == 456") -;=>false - -(lua-eval "{7,8,9}") -;=>(7 8 9) - -(lua-eval "{abc = 789}") -;=>{"abc" 789} - -(lua-eval "print('hello')") -;/hello -;=>nil - -(lua-eval "(function() foo = 8 end)()") -(lua-eval "foo") -;=>8 - -(lua-eval "string.gsub('This sentence has five words', '%w+', function(w) return '*'..#w..'*' end)") -;=>"*4* *8* *3* *4* *5*" - -(lua-eval "table.concat({3, 'a', 45, 'b'}, '|')") -;=>"3|a|45|b" +;; Testing basic Lua interop + +;;; lua-eval adds the string "return " to the beginning of the evaluated string +;;; and supplies that to Lua's loadstring(). If complex programs are needed, +;;; those can be wrapped by an anonymous function which is called immediately +;;; (see the foo = 8 example below). + +(lua-eval "7") +;=>7 + +(lua-eval "'7'") +;=>"7" + +(lua-eval "123 == 123") +;=>true + +(lua-eval "123 == 456") +;=>false + +(lua-eval "{7,8,9}") +;=>(7 8 9) + +(lua-eval "{abc = 789}") +;=>{"abc" 789} + +(lua-eval "print('hello')") +;/hello +;=>nil + +(lua-eval "(function() foo = 8 end)()") +(lua-eval "foo") +;=>8 + +(lua-eval "string.gsub('This sentence has five words', '%w+', function(w) return '*'..#w..'*' end)") +;=>"*4* *8* *3* *4* *5*" + +(lua-eval "table.concat({3, 'a', 45, 'b'}, '|')") +;=>"3|a|45|b" diff --git a/impls/lua/types.lua b/impls/lua/types.lua index 8684a061a9..13e5dd43bb 100644 --- a/impls/lua/types.lua +++ b/impls/lua/types.lua @@ -1,229 +1,229 @@ -local utils = require('utils') - -local M = {} - --- type functions - -function M._sequential_Q(obj) - return M._list_Q(obj) or M._vector_Q(obj) -end - -function M._equal_Q(a,b) - if M._symbol_Q(a) and M._symbol_Q(b) then - return a.val == b.val - elseif M._sequential_Q(a) and M._sequential_Q(b) then - if #a ~= #b then return false end - for i, v in ipairs(a) do - if not M._equal_Q(v,b[i]) then return false end - end - return true - elseif M._hash_map_Q(a) and M._hash_map_Q(b) then - if #a ~= #b then return false end - for k, v in pairs(a) do - if not M._equal_Q(v,b[k]) then return false end - end - return true - else - return a == b - end -end - -function M.copy(obj) - if type(obj) == "function" then - return M.FunctionRef:new(obj) - end - if type(obj) ~= "table" then return obj end - - -- copy object data - local new_obj = {} - for k,v in pairs(obj) do - new_obj[k] = v - end - - -- copy metatable and link to original - local old_mt = getmetatable(obj) - if old_mt ~= nil then - local new_mt = {} - for k,v in pairs(old_mt) do - new_mt[k] = v - end - setmetatable(new_mt, old_mt) - setmetatable(new_obj, new_mt) - end - - return new_obj -end - -function M.slice(lst, start, last) - if last == nil then last = #lst end - local new_lst = {} - if start <= last then - for i = start, last do - new_lst[#new_lst+1] = lst[i] - end - end - return new_lst -end - --- Error/exceptions - -M.MalException = {} -function M.MalException:new(val) - local newObj = {val = val} - self.__index = self - return setmetatable(newObj, self) -end -function M._malexception_Q(obj) - return utils.instanceOf(obj, M.MalException) -end - -function M.throw(val) - error(M.MalException:new(val)) -end - --- Nil - -local NilType = {} -function NilType:new(val) - local newObj = {} - self.__index = self - return setmetatable(newObj, self) -end -M.Nil = NilType:new() -function M._nil_Q(obj) - return obj == Nil -end - --- Numbers -function M._number_Q(obj) - return type(obj) == "number" -end - --- Strings -function M._string_Q(obj) - return type(obj) == "string" -end - --- Symbols - -M.Symbol = {} -function M.Symbol:new(val) - local newObj = {val = val} - self.__index = self - return setmetatable(newObj, self) -end -function M._symbol_Q(obj) - return utils.instanceOf(obj, M.Symbol) -end - --- Keywords -function M._keyword_Q(obj) - return M._string_Q(obj) and "\u{029e}" == string.sub(obj,1,2) -end - - --- Lists - -M.List = {} -function M.List:new(lst) - local newObj = lst and lst or {} - self.__index = self - return setmetatable(newObj, self) -end -function M._list_Q(obj) - return utils.instanceOf(obj, M.List) -end -function M.List:slice(start,last) - return M.List:new(M.slice(self,start,last)) -end - --- Vectors - -M.Vector = {} -function M.Vector:new(lst) - local newObj = lst and lst or {} - self.__index = self - return setmetatable(newObj, self) -end -function M._vector_Q(obj) - return utils.instanceOf(obj, M.Vector) -end -function M.Vector:slice(start,last) - return M.Vector:new(M.slice(self,start,last)) -end - --- Hash Maps --- -M.HashMap = {} -function M.HashMap:new(val) - local newObj = val and val or {} - self.__index = self - return setmetatable(newObj, self) -end -function M.hash_map(...) - return M._assoc_BANG(M.HashMap:new(), ...) -end -function M._hash_map_Q(obj) - return utils.instanceOf(obj, M.HashMap) -end -function M._assoc_BANG(hm, ...) - local arg = table.pack(...) - for i = 1, #arg, 2 do - hm[arg[i]] = arg[i+1] - end - return hm -end -function M._dissoc_BANG(hm, ...) - local arg = table.pack(...) - for i = 1, #arg do - hm[arg[i]] = nil - end - return hm -end - --- Functions - -M.MalFunc = {} -function M.MalFunc:new(fn, ast, env, params) - local newObj = {fn = fn, ast = ast, env = env, - params = params, ismacro = false} - self.__index = self - return setmetatable(newObj, self) -end -function M._malfunc_Q(obj) - return utils.instanceOf(obj, M.MalFunc) -end -function M._fn_Q(obj) - return type(obj) == "function" or (M._malfunc_Q(obj) and not obj.ismacro) -end -function M._macro_Q(obj) - return M._malfunc_Q(obj) and obj.ismacro -end - --- Atoms - -M.Atom = {} -function M.Atom:new(val) - local newObj = {val = val} - self.__index = self - return setmetatable(newObj, self) -end -function M._atom_Q(obj) - return utils.instanceOf(obj, M.Atom) -end - --- FunctionRefs - -M.FunctionRef = {} -function M.FunctionRef:new(fn) - local newObj = {fn = fn} - return setmetatable(newObj, self) -end -function M._functionref_Q(obj) - return utils.instanceOf(obj, M.FunctionRef) -end -function M.FunctionRef:__call(...) - return self.fn(...) -end - -return M +local utils = require('utils') + +local M = {} + +-- type functions + +function M._sequential_Q(obj) + return M._list_Q(obj) or M._vector_Q(obj) +end + +function M._equal_Q(a,b) + if M._symbol_Q(a) and M._symbol_Q(b) then + return a.val == b.val + elseif M._sequential_Q(a) and M._sequential_Q(b) then + if #a ~= #b then return false end + for i, v in ipairs(a) do + if not M._equal_Q(v,b[i]) then return false end + end + return true + elseif M._hash_map_Q(a) and M._hash_map_Q(b) then + if #a ~= #b then return false end + for k, v in pairs(a) do + if not M._equal_Q(v,b[k]) then return false end + end + return true + else + return a == b + end +end + +function M.copy(obj) + if type(obj) == "function" then + return M.FunctionRef:new(obj) + end + if type(obj) ~= "table" then return obj end + + -- copy object data + local new_obj = {} + for k,v in pairs(obj) do + new_obj[k] = v + end + + -- copy metatable and link to original + local old_mt = getmetatable(obj) + if old_mt ~= nil then + local new_mt = {} + for k,v in pairs(old_mt) do + new_mt[k] = v + end + setmetatable(new_mt, old_mt) + setmetatable(new_obj, new_mt) + end + + return new_obj +end + +function M.slice(lst, start, last) + if last == nil then last = #lst end + local new_lst = {} + if start <= last then + for i = start, last do + new_lst[#new_lst+1] = lst[i] + end + end + return new_lst +end + +-- Error/exceptions + +M.MalException = {} +function M.MalException:new(val) + local newObj = {val = val} + self.__index = self + return setmetatable(newObj, self) +end +function M._malexception_Q(obj) + return utils.instanceOf(obj, M.MalException) +end + +function M.throw(val) + error(M.MalException:new(val)) +end + +-- Nil + +local NilType = {} +function NilType:new(val) + local newObj = {} + self.__index = self + return setmetatable(newObj, self) +end +M.Nil = NilType:new() +function M._nil_Q(obj) + return obj == Nil +end + +-- Numbers +function M._number_Q(obj) + return type(obj) == "number" +end + +-- Strings +function M._string_Q(obj) + return type(obj) == "string" +end + +-- Symbols + +M.Symbol = {} +function M.Symbol:new(val) + local newObj = {val = val} + self.__index = self + return setmetatable(newObj, self) +end +function M._symbol_Q(obj) + return utils.instanceOf(obj, M.Symbol) +end + +-- Keywords +function M._keyword_Q(obj) + return M._string_Q(obj) and "\u{029e}" == string.sub(obj,1,2) +end + + +-- Lists + +M.List = {} +function M.List:new(lst) + local newObj = lst and lst or {} + self.__index = self + return setmetatable(newObj, self) +end +function M._list_Q(obj) + return utils.instanceOf(obj, M.List) +end +function M.List:slice(start,last) + return M.List:new(M.slice(self,start,last)) +end + +-- Vectors + +M.Vector = {} +function M.Vector:new(lst) + local newObj = lst and lst or {} + self.__index = self + return setmetatable(newObj, self) +end +function M._vector_Q(obj) + return utils.instanceOf(obj, M.Vector) +end +function M.Vector:slice(start,last) + return M.Vector:new(M.slice(self,start,last)) +end + +-- Hash Maps +-- +M.HashMap = {} +function M.HashMap:new(val) + local newObj = val and val or {} + self.__index = self + return setmetatable(newObj, self) +end +function M.hash_map(...) + return M._assoc_BANG(M.HashMap:new(), ...) +end +function M._hash_map_Q(obj) + return utils.instanceOf(obj, M.HashMap) +end +function M._assoc_BANG(hm, ...) + local arg = table.pack(...) + for i = 1, #arg, 2 do + hm[arg[i]] = arg[i+1] + end + return hm +end +function M._dissoc_BANG(hm, ...) + local arg = table.pack(...) + for i = 1, #arg do + hm[arg[i]] = nil + end + return hm +end + +-- Functions + +M.MalFunc = {} +function M.MalFunc:new(fn, ast, env, params) + local newObj = {fn = fn, ast = ast, env = env, + params = params, ismacro = false} + self.__index = self + return setmetatable(newObj, self) +end +function M._malfunc_Q(obj) + return utils.instanceOf(obj, M.MalFunc) +end +function M._fn_Q(obj) + return type(obj) == "function" or (M._malfunc_Q(obj) and not obj.ismacro) +end +function M._macro_Q(obj) + return M._malfunc_Q(obj) and obj.ismacro +end + +-- Atoms + +M.Atom = {} +function M.Atom:new(val) + local newObj = {val = val} + self.__index = self + return setmetatable(newObj, self) +end +function M._atom_Q(obj) + return utils.instanceOf(obj, M.Atom) +end + +-- FunctionRefs + +M.FunctionRef = {} +function M.FunctionRef:new(fn) + local newObj = {fn = fn} + return setmetatable(newObj, self) +end +function M._functionref_Q(obj) + return utils.instanceOf(obj, M.FunctionRef) +end +function M.FunctionRef:__call(...) + return self.fn(...) +end + +return M diff --git a/impls/lua/utils.lua b/impls/lua/utils.lua index 1ed03e1121..8754737ec1 100644 --- a/impls/lua/utils.lua +++ b/impls/lua/utils.lua @@ -1,53 +1,53 @@ -local M = {} - -function M.try(f, catch_f) - local status, exception = pcall(f) - if not status then - catch_f(exception) - end -end - -function M.instanceOf(subject, super) - super = tostring(super) - local mt = getmetatable(subject) - - while true do - if mt == nil then return false end - if tostring(mt) == super then return true end - mt = getmetatable(mt) - end -end - ---[[ -function M.isArray(o) - local i = 0 - for _ in pairs(o) do - i = i + 1 - if o[i] == nil then return false end - end - return true -end -]]-- - -function M.map(func, obj) - local new_obj = {} - for i,v in ipairs(obj) do - new_obj[i] = func(v) - end - return new_obj -end - -function M.dump(o) - if type(o) == 'table' then - local s = '{ ' - for k,v in pairs(o) do - if type(k) ~= 'number' then k = '"'..k..'"' end - s = s .. '['..k..'] = ' .. M.dump(v) .. ',' - end - return s .. '} ' - else - return tostring(o) - end -end - -return M +local M = {} + +function M.try(f, catch_f) + local status, exception = pcall(f) + if not status then + catch_f(exception) + end +end + +function M.instanceOf(subject, super) + super = tostring(super) + local mt = getmetatable(subject) + + while true do + if mt == nil then return false end + if tostring(mt) == super then return true end + mt = getmetatable(mt) + end +end + +--[[ +function M.isArray(o) + local i = 0 + for _ in pairs(o) do + i = i + 1 + if o[i] == nil then return false end + end + return true +end +]]-- + +function M.map(func, obj) + local new_obj = {} + for i,v in ipairs(obj) do + new_obj[i] = func(v) + end + return new_obj +end + +function M.dump(o) + if type(o) == 'table' then + local s = '{ ' + for k,v in pairs(o) do + if type(k) ~= 'number' then k = '"'..k..'"' end + s = s .. '['..k..'] = ' .. M.dump(v) .. ',' + end + return s .. '} ' + else + return tostring(o) + end +end + +return M diff --git a/impls/make/Dockerfile b/impls/make/Dockerfile index 5f61062ee3..826a9393aa 100644 --- a/impls/make/Dockerfile +++ b/impls/make/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Nothing additional needed for make +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Nothing additional needed for make diff --git a/impls/make/Makefile b/impls/make/Makefile index f8a16ebb1c..ce0195df74 100644 --- a/impls/make/Makefile +++ b/impls/make/Makefile @@ -1,31 +1,31 @@ - -TESTS = tests/types.mk tests/reader.mk tests/stepA_mal.mk - -SOURCES_BASE = util.mk numbers.mk readline.mk gmsl.mk types.mk \ - reader.mk printer.mk -SOURCES_LISP = env.mk core.mk stepA_mal.mk -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.mk mal - -mal.mk: $(SOURCES) - cat $+ | grep -v "^include " > $@ - -mal: mal.mk - echo "#!/usr/bin/make -f" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.mk mal - -.PHONY: tests $(TESTS) - -tests: $(TESTS) - -$(TESTS): - @echo "Running $@"; \ - make -f $@ || exit 1; \ + +TESTS = tests/types.mk tests/reader.mk tests/stepA_mal.mk + +SOURCES_BASE = util.mk numbers.mk readline.mk gmsl.mk types.mk \ + reader.mk printer.mk +SOURCES_LISP = env.mk core.mk stepA_mal.mk +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.mk mal + +mal.mk: $(SOURCES) + cat $+ | grep -v "^include " > $@ + +mal: mal.mk + echo "#!/usr/bin/make -f" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.mk mal + +.PHONY: tests $(TESTS) + +tests: $(TESTS) + +$(TESTS): + @echo "Running $@"; \ + make -f $@ || exit 1; \ diff --git a/impls/make/core.mk b/impls/make/core.mk index 1823cb2e28..89b0853ad4 100644 --- a/impls/make/core.mk +++ b/impls/make/core.mk @@ -1,304 +1,304 @@ -# -# mal (Make a Lisp) Core functions -# - -ifndef __mal_core_included -__mal_core_included := true - -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)util.mk -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)readline.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk - - -# Errors/Exceptions -throw = $(eval __ERROR := $(1)) - - -# General functions - -# Return the type of the object (or "make" if it's not a object -obj_type = $(call _string,$(call _obj_type,$(1))) - -equal? = $(if $(call _equal?,$(word 1,$(1)),$(word 2,$(1))),$(__true),$(__false)) - - -# Scalar functions -nil? = $(if $(call _nil?,$(1)),$(__true),$(__false)) -true? = $(if $(call _true?,$(1)),$(__true),$(__false)) -false? = $(if $(call _false?,$(1)),$(__true),$(__false)) - - -# Symbol functions -symbol = $(call _symbol,$(call str_decode,$($(1)_value))) -symbol? = $(if $(call _symbol?,$(1)),$(__true),$(__false)) - -# Keyword functions -keyword = $(call _keyword,$(call str_decode,$($(1)_value))) -keyword? = $(if $(call _keyword?,$(1)),$(__true),$(__false)) - - -# Number functions -number? = $(if $(call _number?,$(1)),$(__true),$(__false)) - -number_lt = $(if $(call int_lt_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value)),$(__true),$(__false)) -number_lte = $(if $(call int_lte_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value)),$(__true),$(__false)) -number_gt = $(if $(call int_gt_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value)),$(__true),$(__false)) -number_gte = $(if $(call int_gte_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value)),$(__true),$(__false)) - -number_plus = $(call _pnumber,$(call int_add_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value))) -number_subtract = $(call _pnumber,$(call int_sub_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value))) -number_multiply = $(call _pnumber,$(call int_mult_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value))) -number_divide = $(call _pnumber,$(call int_div_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value))) - -time_ms = $(call _number,$(shell echo $$(date +%s%3N))) - -# String functions - -string? = $(if $(call _string?,$(1)),$(if $(call _keyword?,$(1)),$(__false),$(__true)),$(__false)) - -pr_str = $(call _string,$(call _pr_str_mult,$(1),yes, )) -str = $(call _string,$(call _pr_str_mult,$(1),,)) -prn = $(info $(call _pr_str_mult,$(1),yes, )) -println = $(info $(subst \n,$(NEWLINE),$(call _pr_str_mult,$(1),, ))) - -readline= $(foreach res,$(call _string,$(call READLINE,"$(call str_decode,$($(1)_value))")),$(if $(READLINE_EOF),$(eval READLINE_EOF :=)$(__nil),$(res))) -read_str= $(call READ_STR,$(1)) -slurp = $(call _string,$(call _read_file,$(call str_decode,$($(1)_value)))) - -subs = $(strip \ - $(foreach start,$(call int_add,1,$(call int_decode,$($(word 2,$(1))_value))),\ - $(foreach end,$(if $(3),$(call int_decode,$($(3)_value)),$(words $($(word 1,$(1))_value))),\ - $(call _string,$(wordlist $(start),$(end),$($(word 1,$(1))_value)))))) - - - -# Function functions -fn? = $(if $(call _function?,$(1)),$(if $(_macro_$(1)),$(__false),$(__true)),$(__false)) -macro? = $(if $(_macro_$(1)),$(__true),$(__false)) - - -# List functions -list? = $(if $(call _list?,$(1)),$(__true),$(__false)) - - -# Vector functions -vector? = $(if $(call _vector?,$(1)),$(__true),$(__false)) - -vec = $(if $(_list?),$(call _vector,$($1_value)),$(if $(_vector?),$1,$(call _error,vec: called on non-sequence))) - - -# Hash map (associative array) functions -hash_map? = $(if $(call _hash_map?,$(1)),$(__true),$(__false)) - -# set a key/value in a copy of the hash map -assoc = $(word 1,\ - $(foreach hm,$(call _clone_obj,$(word 1,$(1))),\ - $(hm) \ - $(call _assoc_seq!,$(hm),$(wordlist 2,$(words $(1)),$(1))))) - -# unset keys in a copy of the hash map -# TODO: this could be made more efficient by copying only the -# keys that not being removed. -dissoc = $(word 1,\ - $(foreach hm,$(call _clone_obj,$(word 1,$(1))),\ - $(hm) \ - $(call _dissoc_seq!,$(hm),$(wordlist 2,$(words $(1)),$(1))))) - -keys = $(foreach new_list,$(call _list),$(new_list)$(eval $(new_list)_value := $(foreach v,$(call __get_obj_values,$(1)),$(foreach vval,$(word 4,$(subst _, ,$(v))),$(if $(filter $(__keyword)%,$(vval)),$(call _keyword,$(patsubst $(__keyword)%,%,$(vval))),$(call _string,$(vval))))))) - -vals = $(foreach new_list,$(call _list),$(new_list)$(eval $(new_list)_value := $(foreach v,$(call __get_obj_values,$(1)),$($(v))))) - -# Hash map and vector functions - -# retrieve the value of a string key object from the hash map, or -# retrive a vector by number object index -get = $(strip \ - $(if $(call _nil?,$(word 1,$(1))),\ - $(__nil),\ - $(if $(call _hash_map?,$(word 1,$(1))),\ - $(call _get,$(word 1,$(1)),$(call str_decode,$($(word 2,$(1))_value))),\ - $(call _get,$(word 1,$(1)),$(call int_decode,$($(word 2,$(1))_value)))))) - -contains? = $(if $(call _contains?,$(word 1,$(1)),$(call str_decode,$($(word 2,$(1))_value))),$(__true),$(__false)) - - -# sequence operations - -sequential? = $(if $(call _sequential?,$(1)),$(__true),$(__false)) - -cons = $(word 1,$(foreach new_list,$(call _list),$(new_list) $(eval $(new_list)_value := $(strip $(word 1,$(1)) $(call __get_obj_values,$(word 2,$(1))))))) - -concat = $(word 1,$(foreach new_list,$(call _list),$(new_list) $(eval $(new_list)_value := $(strip $(foreach lst,$1,$(call __get_obj_values,$(lst))))))) - -nth = $(strip \ - $(if $(call int_lt,$($(word 2,$(1))_value),$(call int_encode,$(call _count,$(word 1,$(1))))),\ - $(word $(call int_add,1,$(call int_decode,$($(word 2,$(1))_value))),$($(word 1,$(1))_value)),\ - $(call _error,nth: index out of range))) - -sfirst = $(word 1,$($(1)_value)) - -slast = $(word $(words $($(1)_value)),$($(1)_value)) - -empty? = $(if $(_empty?),$(__true),$(__false)) - -count = $(call _number,$(call _count,$(1))) - -# Creates a new vector/list of the everything after but the first -# element -srest = $(word 1,$(foreach new_list,$(call _list),\ - $(new_list) \ - $(eval $(new_list)_value := $(wordlist 2,$(words $($(1)_value)),$($(1)_value))))) - -# Takes a space separated arguments and invokes the first argument -# (function object) using the remaining arguments. -sapply = $(call $(word 1,$(1))_value,$(strip \ - $(wordlist 2,$(call int_sub,$(words $(1)),1),$(1)) \ - $($(word $(words $(1)),$(1))_value))) - -# Map a function object over a list object -smap = $(strip\ - $(foreach func,$(word 1,$(1)),\ - $(foreach lst,$(word 2,$(1)),\ - $(foreach type,list,\ - $(foreach new_hcode,$(call __new_obj_hash_code),\ - $(foreach sz,$(words $(call __get_obj_values,$(lst))),\ - $(eval $(__obj_magic)_$(type)_$(new_hcode)_value := $(strip \ - $(foreach val,$(call __get_obj_values,$(lst)),\ - $(call $(func)_value,$(val))))))\ - $(__obj_magic)_$(type)_$(new_hcode)))))) - -conj = $(word 1,$(foreach new_list,$(call __new_obj_like,$(word 1,$(1))),\ - $(new_list) \ - $(eval $(new_list)_value := $(strip $($(word 1,$(1))_value))) \ - $(if $(call _list?,$(new_list)),\ - $(foreach elem,$(wordlist 2,$(words $(1)),$(1)),\ - $(eval $(new_list)_value := $(strip $(elem) $($(new_list)_value)))),\ - $(eval $(new_list)_value := $(strip $($(new_list)_value) $(wordlist 2,$(words $(1)),$(1))))))) - -seq = $(strip\ - $(if $(call _list?,$(1)),\ - $(if $(call _EQ,0,$(call _count,$(1))),$(__nil),$(1)),\ - $(if $(call _vector?,$(1)),\ - $(if $(call _EQ,0,$(call _count,$(1))),\ - $(__nil),\ - $(word 1,$(foreach new_list,$(call _list),\ - $(new_list) \ - $(eval $(new_list)_value := $(strip $($(word 1,$(1))_value)))))),\ - $(if $(call _EQ,string,$(call _obj_type,$(1))),\ - $(if $(call _EQ,0,$(call _count,$(1))),\ - $(__nil),\ - $(word 1,$(foreach new_list,$(call _list),\ - $(new_list) \ - $(eval $(new_list)_value := $(strip \ - $(foreach c,$($(word 1,$(1))_value),\ - $(call _string,$(c)))))))),\ - $(if $(call _nil?,$(1)),\ - $(__nil),\ - $(call _error,seq: called on non-sequence)))))) - -# Metadata functions - -with_meta = $(strip \ - $(foreach new_obj,$(call _clone_obj,$(word 1,$(1))),\ - $(eval $(new_obj)_meta := $(strip $(word 2,$(1))))\ - $(new_obj))) - -meta = $(strip $($(1)_meta)) - - -# Atom functions - -atom = $(strip \ - $(foreach hcode,$(call __new_obj_hash_code),\ - $(foreach new_atom,$(__obj_magic)_atom_$(hcode),\ - $(new_atom)\ - $(eval $(new_atom)_value := $(1))))) -atom? = $(if $(call _atom?,$(1)),$(__true),$(__false)) - -deref = $($(1)_value) - -reset! = $(eval $(word 1,$(1))_value := $(word 2,$(1)))$(word 2,$(1)) - -swap! = $(foreach resp,$(call $(word 2,$(1))_value,$($(word 1,$(1))_value) $(wordlist 3,$(words $(1)),$(1))),\ - $(eval $(word 1,$(1))_value := $(resp))\ - $(resp)) - - - - -# Namespace of core functions - -core_ns = type obj_type \ - = equal? \ - throw throw \ - nil? nil? \ - true? true? \ - false? false? \ - string? string? \ - symbol symbol \ - symbol? symbol? \ - keyword keyword \ - keyword? keyword? \ - number? number? \ - fn? fn? \ - macro? macro? \ - \ - pr-str pr_str \ - str str \ - prn prn \ - println println \ - readline readline \ - read-string read_str \ - slurp slurp \ - subs subs \ - < number_lt \ - <= number_lte \ - > number_gt \ - >= number_gte \ - + number_plus \ - - number_subtract \ - * number_multiply \ - / number_divide \ - time-ms time_ms \ - \ - list _list \ - list? list? \ - vector _vector \ - vector? vector? \ - hash-map _hash_map \ - map? hash_map? \ - assoc assoc \ - dissoc dissoc \ - get get \ - contains? contains? \ - keys keys \ - vals vals \ - \ - sequential? sequential? \ - cons cons \ - concat concat \ - vec vec \ - nth nth \ - first sfirst \ - rest srest \ - last slast \ - empty? empty? \ - count count \ - apply sapply \ - map smap \ - \ - conj conj \ - seq seq \ - \ - with-meta with_meta \ - meta meta \ - atom atom \ - atom? atom? \ - deref deref \ - reset! reset! \ - swap! swap! - -endif +# +# mal (Make a Lisp) Core functions +# + +ifndef __mal_core_included +__mal_core_included := true + +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)util.mk +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)readline.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk + + +# Errors/Exceptions +throw = $(eval __ERROR := $(1)) + + +# General functions + +# Return the type of the object (or "make" if it's not a object +obj_type = $(call _string,$(call _obj_type,$(1))) + +equal? = $(if $(call _equal?,$(word 1,$(1)),$(word 2,$(1))),$(__true),$(__false)) + + +# Scalar functions +nil? = $(if $(call _nil?,$(1)),$(__true),$(__false)) +true? = $(if $(call _true?,$(1)),$(__true),$(__false)) +false? = $(if $(call _false?,$(1)),$(__true),$(__false)) + + +# Symbol functions +symbol = $(call _symbol,$(call str_decode,$($(1)_value))) +symbol? = $(if $(call _symbol?,$(1)),$(__true),$(__false)) + +# Keyword functions +keyword = $(call _keyword,$(call str_decode,$($(1)_value))) +keyword? = $(if $(call _keyword?,$(1)),$(__true),$(__false)) + + +# Number functions +number? = $(if $(call _number?,$(1)),$(__true),$(__false)) + +number_lt = $(if $(call int_lt_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value)),$(__true),$(__false)) +number_lte = $(if $(call int_lte_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value)),$(__true),$(__false)) +number_gt = $(if $(call int_gt_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value)),$(__true),$(__false)) +number_gte = $(if $(call int_gte_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value)),$(__true),$(__false)) + +number_plus = $(call _pnumber,$(call int_add_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value))) +number_subtract = $(call _pnumber,$(call int_sub_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value))) +number_multiply = $(call _pnumber,$(call int_mult_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value))) +number_divide = $(call _pnumber,$(call int_div_encoded,$($(word 1,$(1))_value),$($(word 2,$(1))_value))) + +time_ms = $(call _number,$(shell echo $$(date +%s%3N))) + +# String functions + +string? = $(if $(call _string?,$(1)),$(if $(call _keyword?,$(1)),$(__false),$(__true)),$(__false)) + +pr_str = $(call _string,$(call _pr_str_mult,$(1),yes, )) +str = $(call _string,$(call _pr_str_mult,$(1),,)) +prn = $(info $(call _pr_str_mult,$(1),yes, )) +println = $(info $(subst \n,$(NEWLINE),$(call _pr_str_mult,$(1),, ))) + +readline= $(foreach res,$(call _string,$(call READLINE,"$(call str_decode,$($(1)_value))")),$(if $(READLINE_EOF),$(eval READLINE_EOF :=)$(__nil),$(res))) +read_str= $(call READ_STR,$(1)) +slurp = $(call _string,$(call _read_file,$(call str_decode,$($(1)_value)))) + +subs = $(strip \ + $(foreach start,$(call int_add,1,$(call int_decode,$($(word 2,$(1))_value))),\ + $(foreach end,$(if $(3),$(call int_decode,$($(3)_value)),$(words $($(word 1,$(1))_value))),\ + $(call _string,$(wordlist $(start),$(end),$($(word 1,$(1))_value)))))) + + + +# Function functions +fn? = $(if $(call _function?,$(1)),$(if $(_macro_$(1)),$(__false),$(__true)),$(__false)) +macro? = $(if $(_macro_$(1)),$(__true),$(__false)) + + +# List functions +list? = $(if $(call _list?,$(1)),$(__true),$(__false)) + + +# Vector functions +vector? = $(if $(call _vector?,$(1)),$(__true),$(__false)) + +vec = $(if $(_list?),$(call _vector,$($1_value)),$(if $(_vector?),$1,$(call _error,vec: called on non-sequence))) + + +# Hash map (associative array) functions +hash_map? = $(if $(call _hash_map?,$(1)),$(__true),$(__false)) + +# set a key/value in a copy of the hash map +assoc = $(word 1,\ + $(foreach hm,$(call _clone_obj,$(word 1,$(1))),\ + $(hm) \ + $(call _assoc_seq!,$(hm),$(wordlist 2,$(words $(1)),$(1))))) + +# unset keys in a copy of the hash map +# TODO: this could be made more efficient by copying only the +# keys that not being removed. +dissoc = $(word 1,\ + $(foreach hm,$(call _clone_obj,$(word 1,$(1))),\ + $(hm) \ + $(call _dissoc_seq!,$(hm),$(wordlist 2,$(words $(1)),$(1))))) + +keys = $(foreach new_list,$(call _list),$(new_list)$(eval $(new_list)_value := $(foreach v,$(call __get_obj_values,$(1)),$(foreach vval,$(word 4,$(subst _, ,$(v))),$(if $(filter $(__keyword)%,$(vval)),$(call _keyword,$(patsubst $(__keyword)%,%,$(vval))),$(call _string,$(vval))))))) + +vals = $(foreach new_list,$(call _list),$(new_list)$(eval $(new_list)_value := $(foreach v,$(call __get_obj_values,$(1)),$($(v))))) + +# Hash map and vector functions + +# retrieve the value of a string key object from the hash map, or +# retrive a vector by number object index +get = $(strip \ + $(if $(call _nil?,$(word 1,$(1))),\ + $(__nil),\ + $(if $(call _hash_map?,$(word 1,$(1))),\ + $(call _get,$(word 1,$(1)),$(call str_decode,$($(word 2,$(1))_value))),\ + $(call _get,$(word 1,$(1)),$(call int_decode,$($(word 2,$(1))_value)))))) + +contains? = $(if $(call _contains?,$(word 1,$(1)),$(call str_decode,$($(word 2,$(1))_value))),$(__true),$(__false)) + + +# sequence operations + +sequential? = $(if $(call _sequential?,$(1)),$(__true),$(__false)) + +cons = $(word 1,$(foreach new_list,$(call _list),$(new_list) $(eval $(new_list)_value := $(strip $(word 1,$(1)) $(call __get_obj_values,$(word 2,$(1))))))) + +concat = $(word 1,$(foreach new_list,$(call _list),$(new_list) $(eval $(new_list)_value := $(strip $(foreach lst,$1,$(call __get_obj_values,$(lst))))))) + +nth = $(strip \ + $(if $(call int_lt,$($(word 2,$(1))_value),$(call int_encode,$(call _count,$(word 1,$(1))))),\ + $(word $(call int_add,1,$(call int_decode,$($(word 2,$(1))_value))),$($(word 1,$(1))_value)),\ + $(call _error,nth: index out of range))) + +sfirst = $(word 1,$($(1)_value)) + +slast = $(word $(words $($(1)_value)),$($(1)_value)) + +empty? = $(if $(_empty?),$(__true),$(__false)) + +count = $(call _number,$(call _count,$(1))) + +# Creates a new vector/list of the everything after but the first +# element +srest = $(word 1,$(foreach new_list,$(call _list),\ + $(new_list) \ + $(eval $(new_list)_value := $(wordlist 2,$(words $($(1)_value)),$($(1)_value))))) + +# Takes a space separated arguments and invokes the first argument +# (function object) using the remaining arguments. +sapply = $(call $(word 1,$(1))_value,$(strip \ + $(wordlist 2,$(call int_sub,$(words $(1)),1),$(1)) \ + $($(word $(words $(1)),$(1))_value))) + +# Map a function object over a list object +smap = $(strip\ + $(foreach func,$(word 1,$(1)),\ + $(foreach lst,$(word 2,$(1)),\ + $(foreach type,list,\ + $(foreach new_hcode,$(call __new_obj_hash_code),\ + $(foreach sz,$(words $(call __get_obj_values,$(lst))),\ + $(eval $(__obj_magic)_$(type)_$(new_hcode)_value := $(strip \ + $(foreach val,$(call __get_obj_values,$(lst)),\ + $(call $(func)_value,$(val))))))\ + $(__obj_magic)_$(type)_$(new_hcode)))))) + +conj = $(word 1,$(foreach new_list,$(call __new_obj_like,$(word 1,$(1))),\ + $(new_list) \ + $(eval $(new_list)_value := $(strip $($(word 1,$(1))_value))) \ + $(if $(call _list?,$(new_list)),\ + $(foreach elem,$(wordlist 2,$(words $(1)),$(1)),\ + $(eval $(new_list)_value := $(strip $(elem) $($(new_list)_value)))),\ + $(eval $(new_list)_value := $(strip $($(new_list)_value) $(wordlist 2,$(words $(1)),$(1))))))) + +seq = $(strip\ + $(if $(call _list?,$(1)),\ + $(if $(call _EQ,0,$(call _count,$(1))),$(__nil),$(1)),\ + $(if $(call _vector?,$(1)),\ + $(if $(call _EQ,0,$(call _count,$(1))),\ + $(__nil),\ + $(word 1,$(foreach new_list,$(call _list),\ + $(new_list) \ + $(eval $(new_list)_value := $(strip $($(word 1,$(1))_value)))))),\ + $(if $(call _EQ,string,$(call _obj_type,$(1))),\ + $(if $(call _EQ,0,$(call _count,$(1))),\ + $(__nil),\ + $(word 1,$(foreach new_list,$(call _list),\ + $(new_list) \ + $(eval $(new_list)_value := $(strip \ + $(foreach c,$($(word 1,$(1))_value),\ + $(call _string,$(c)))))))),\ + $(if $(call _nil?,$(1)),\ + $(__nil),\ + $(call _error,seq: called on non-sequence)))))) + +# Metadata functions + +with_meta = $(strip \ + $(foreach new_obj,$(call _clone_obj,$(word 1,$(1))),\ + $(eval $(new_obj)_meta := $(strip $(word 2,$(1))))\ + $(new_obj))) + +meta = $(strip $($(1)_meta)) + + +# Atom functions + +atom = $(strip \ + $(foreach hcode,$(call __new_obj_hash_code),\ + $(foreach new_atom,$(__obj_magic)_atom_$(hcode),\ + $(new_atom)\ + $(eval $(new_atom)_value := $(1))))) +atom? = $(if $(call _atom?,$(1)),$(__true),$(__false)) + +deref = $($(1)_value) + +reset! = $(eval $(word 1,$(1))_value := $(word 2,$(1)))$(word 2,$(1)) + +swap! = $(foreach resp,$(call $(word 2,$(1))_value,$($(word 1,$(1))_value) $(wordlist 3,$(words $(1)),$(1))),\ + $(eval $(word 1,$(1))_value := $(resp))\ + $(resp)) + + + + +# Namespace of core functions + +core_ns = type obj_type \ + = equal? \ + throw throw \ + nil? nil? \ + true? true? \ + false? false? \ + string? string? \ + symbol symbol \ + symbol? symbol? \ + keyword keyword \ + keyword? keyword? \ + number? number? \ + fn? fn? \ + macro? macro? \ + \ + pr-str pr_str \ + str str \ + prn prn \ + println println \ + readline readline \ + read-string read_str \ + slurp slurp \ + subs subs \ + < number_lt \ + <= number_lte \ + > number_gt \ + >= number_gte \ + + number_plus \ + - number_subtract \ + * number_multiply \ + / number_divide \ + time-ms time_ms \ + \ + list _list \ + list? list? \ + vector _vector \ + vector? vector? \ + hash-map _hash_map \ + map? hash_map? \ + assoc assoc \ + dissoc dissoc \ + get get \ + contains? contains? \ + keys keys \ + vals vals \ + \ + sequential? sequential? \ + cons cons \ + concat concat \ + vec vec \ + nth nth \ + first sfirst \ + rest srest \ + last slast \ + empty? empty? \ + count count \ + apply sapply \ + map smap \ + \ + conj conj \ + seq seq \ + \ + with-meta with_meta \ + meta meta \ + atom atom \ + atom? atom? \ + deref deref \ + reset! reset! \ + swap! swap! + +endif diff --git a/impls/make/env.mk b/impls/make/env.mk index c8f8792a10..68fe991f3d 100644 --- a/impls/make/env.mk +++ b/impls/make/env.mk @@ -1,50 +1,50 @@ -# -# mal (Make Lisp) Object Types and Functions -# - -ifndef __mal_env_included -__mal_env_included := true - -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk - -# -# ENV -# - -# An ENV environment is a hash-map with an __outer__ reference to an -# outer environment -define BIND_ARGS -$(strip \ - $(word 1,$(1) \ - $(foreach fparam,$(call _nth,$(2),0),\ - $(if $(call _EQ,&,$($(fparam)_value)), - $(call ENV_SET,$(1),$($(call _nth,$(2),1)_value),$(strip \ - $(foreach new_list,$(call _list), - $(word 1,$(new_list) \ - $(foreach val,$(3),$(call _conj!,$(new_list),$(val))))))),\ - $(foreach val,$(word 1,$(3)),\ - $(call ENV_SET,$(1),$($(fparam)_value),$(val))\ - $(foreach left,$(call srest,$(2)),\ - $(if $(call _EQ,0,$(call _count,$(left))),\ - ,\ - $(call BIND_ARGS,$(1),$(left),$(wordlist 2,$(words $(3)),$(3)))))))))) -endef - -# Create a new ENV and optional bind values in it -# $(1): outer environment (set as a key named __outer__) -# $(2): list/vector object of bind forms -# $(3): space separated list of expressions to bind -ENV = $(strip $(foreach new_env,$(call _assoc!,$(call _hash_map),__outer__,$(if $(1),$(1),$(__nil))),$(if $(2),$(call BIND_ARGS,$(new_env),$(2),$(3)),$(new_env)))) -ENV_FIND = $(strip \ - $(if $(call _contains?,$(1),$(subst =,$(__equal),$(2))),\ - $(1),\ - $(if $(call _EQ,$(__nil),$(call _get,$(1),__outer__)),\ - ,\ - $(call ENV_FIND,$(call _get,$(1),__outer__),$(2))))) - -ENV_GET = $(foreach env,|$(call ENV_FIND,$(1),$(2))|,$(if $(call _EQ,||,$(env)),$(call _error,'$(2)' not found)$(__nil),$(call _get,$(strip $(subst |,,$(env))),$(subst =,$(__equal),$(2))))) - -ENV_SET = $(if $(call _assoc!,$(1),$(subst =,$(__equal),$(2)),$(3)),$(1),) - -endif +# +# mal (Make Lisp) Object Types and Functions +# + +ifndef __mal_env_included +__mal_env_included := true + +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk + +# +# ENV +# + +# An ENV environment is a hash-map with an __outer__ reference to an +# outer environment +define BIND_ARGS +$(strip \ + $(word 1,$(1) \ + $(foreach fparam,$(call _nth,$(2),0),\ + $(if $(call _EQ,&,$($(fparam)_value)), + $(call ENV_SET,$(1),$($(call _nth,$(2),1)_value),$(strip \ + $(foreach new_list,$(call _list), + $(word 1,$(new_list) \ + $(foreach val,$(3),$(call _conj!,$(new_list),$(val))))))),\ + $(foreach val,$(word 1,$(3)),\ + $(call ENV_SET,$(1),$($(fparam)_value),$(val))\ + $(foreach left,$(call srest,$(2)),\ + $(if $(call _EQ,0,$(call _count,$(left))),\ + ,\ + $(call BIND_ARGS,$(1),$(left),$(wordlist 2,$(words $(3)),$(3)))))))))) +endef + +# Create a new ENV and optional bind values in it +# $(1): outer environment (set as a key named __outer__) +# $(2): list/vector object of bind forms +# $(3): space separated list of expressions to bind +ENV = $(strip $(foreach new_env,$(call _assoc!,$(call _hash_map),__outer__,$(if $(1),$(1),$(__nil))),$(if $(2),$(call BIND_ARGS,$(new_env),$(2),$(3)),$(new_env)))) +ENV_FIND = $(strip \ + $(if $(call _contains?,$(1),$(subst =,$(__equal),$(2))),\ + $(1),\ + $(if $(call _EQ,$(__nil),$(call _get,$(1),__outer__)),\ + ,\ + $(call ENV_FIND,$(call _get,$(1),__outer__),$(2))))) + +ENV_GET = $(foreach env,|$(call ENV_FIND,$(1),$(2))|,$(if $(call _EQ,||,$(env)),$(call _error,'$(2)' not found)$(__nil),$(call _get,$(strip $(subst |,,$(env))),$(subst =,$(__equal),$(2))))) + +ENV_SET = $(if $(call _assoc!,$(1),$(subst =,$(__equal),$(2)),$(3)),$(1),) + +endif diff --git a/impls/make/gmsl.mk b/impls/make/gmsl.mk index adfb953582..16019cb30d 100644 --- a/impls/make/gmsl.mk +++ b/impls/make/gmsl.mk @@ -1,62 +1,62 @@ -# -# mal (Make Lisp) trimmed and namespaced GMSL functions/definitions -# - derived from the GMSL 1.1.3 -# - -ifndef __mal_gmsl_included -__mal_gmsl_included := true - -# ---------------------------------------------------------------------------- -# -# GNU Make Standard Library (GMSL) -# -# A library of functions to be used with GNU Make's $(call) that -# provides functionality not available in standard GNU Make. -# -# Copyright (c) 2005-2013 John Graham-Cumming -# -# This file is part of GMSL -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions -# are met: -# -# Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# -# Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# -# Neither the name of the John Graham-Cumming nor the names of its -# contributors may be used to endorse or promote products derived from -# this software without specific prior written permission. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS -# FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -# COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, -# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, -# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -# POSSIBILITY OF SUCH DAMAGE. -# -# ---------------------------------------------------------------------------- - -# Strings - -gmsl_characters := A B C D E F G H I J K L M N O P Q R S T U V W X Y Z -gmsl_characters += a b c d e f g h i j k l m n o p q r s t u v w x y z -gmsl_characters += 0 1 2 3 4 5 6 7 8 9 -gmsl_characters += ` ~ ! @ \# $$ % ^ & * ( ) - _ = + -gmsl_characters += { } [ ] \ : ; ' " < > , . / ? | - -gmsl_pairmap = $(strip \ - $(if $2$3,$(call $1,$(word 1,$2),$(word 1,$3)) \ - $(call gmsl_pairmap,$1,$(wordlist 2,$(words $2),$2),$(wordlist 2,$(words $3),$3)))) - -endif +# +# mal (Make Lisp) trimmed and namespaced GMSL functions/definitions +# - derived from the GMSL 1.1.3 +# + +ifndef __mal_gmsl_included +__mal_gmsl_included := true + +# ---------------------------------------------------------------------------- +# +# GNU Make Standard Library (GMSL) +# +# A library of functions to be used with GNU Make's $(call) that +# provides functionality not available in standard GNU Make. +# +# Copyright (c) 2005-2013 John Graham-Cumming +# +# This file is part of GMSL +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions +# are met: +# +# Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# +# Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# +# Neither the name of the John Graham-Cumming nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +# FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +# COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. +# +# ---------------------------------------------------------------------------- + +# Strings + +gmsl_characters := A B C D E F G H I J K L M N O P Q R S T U V W X Y Z +gmsl_characters += a b c d e f g h i j k l m n o p q r s t u v w x y z +gmsl_characters += 0 1 2 3 4 5 6 7 8 9 +gmsl_characters += ` ~ ! @ \# $$ % ^ & * ( ) - _ = + +gmsl_characters += { } [ ] \ : ; ' " < > , . / ? | + +gmsl_pairmap = $(strip \ + $(if $2$3,$(call $1,$(word 1,$2),$(word 1,$3)) \ + $(call gmsl_pairmap,$1,$(wordlist 2,$(words $2),$2),$(wordlist 2,$(words $3),$3)))) + +endif diff --git a/impls/make/numbers.mk b/impls/make/numbers.mk index 6d35bbbc34..d753fb660f 100644 --- a/impls/make/numbers.mk +++ b/impls/make/numbers.mk @@ -1,516 +1,516 @@ -# -# mal (Make a Lisp) number types -# - -ifndef __mal_numbers_included -__mal_numbers_included := true - -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)util.mk - -LIST20_X := x x x x x x x x x x x x x x x x x x x x -LIST100_X := $(foreach x,$(LIST20_X),X X X X X) -LIST100_0 := $(foreach x,$(LIST20_X),0 0 0 0 0) -LIST100_9 := $(foreach x,$(LIST20_X),9 9 9 9 9) - -### -### general numeric utility functions -### - -int_encode = $(strip $(call _reverse,\ - $(eval __temp := $(1))\ - $(foreach a,- 0 1 2 3 4 5 6 7 8 9,\ - $(eval __temp := $$(subst $$a,$$a$$(SPACE),$(__temp))))$(__temp))) - -int_decode = $(strip $(call _join,$(call _reverse,$(1)))) - -# trim extaneous zero digits off the end (front of number) -_trim_zeros = $(if $(call _EQ,0,$(strip $(1))),0,$(if $(call _EQ,0,$(word 1,$(1))),$(call _trim_zeros,$(wordlist 2,$(words $(1)),$(1))),$(1))) -trim_zeros = $(strip \ - $(if $(call _EQ,0,$(strip $(filter-out -,$(1)))),\ - $(filter-out -,$(1)),\ - $(call _reverse,$(call _trim_zeros,$(call _reverse,$(filter-out -,$(1))))))\ - $(if $(filter -,$(1)), -,)) - -# drop the last element of a list of words/digits -drop_last = $(call _reverse,$(wordlist 2,$(words $(1)),$(call _reverse,$(1)))) - -### utility function tests - -#$(info $(filter-out 1,$(filter 1%,1 132 456))) -#$(info (int_encode 13): [$(call int_encode,13)]) -#$(info (int_encode 156463): [$(call int_encode,156463)]) -#$(info (int_encode -156463): [$(call int_encode,-156463)]) -#$(info (int_decode (int_encode 156463)): [$(call int_decode,$(call int_encode,156463))]) - -#$(info trim_zeros(0 0 0): [$(call trim_zeros,0 0 0)]) -#$(info trim_zeros(0 0 0 -): [$(call trim_zeros,0 0 0 -)]) - - -### -### comparisons -### - -# compare two digits and return 'true' if digit 1 is less than or -# equal to digit 2 -_lte_digit = $(strip \ - $(if $(call _EQ,$(1),$(2)),\ - true,\ - $(if $(call _EQ,0,$(1)),\ - true,\ - $(if $(wordlist $(1),$(2),$(LIST20_X)),\ - true,\ - )))) - -# compare two lists of digits (MSB->LSB) of equal length and return -# 'true' if number 1 is less than number 2 -_lte_digits = $(strip \ - $(if $(strip $(1)),\ - $(if $(call _EQ,$(word 1,$(1)),$(word 1,$(2))),\ - $(call _lte_digits,$(wordlist 2,$(words $(1)),$(1)),$(wordlist 2,$(words $(2)),$(2))),\ - $(if $(call _lte_digit,$(word 1,$(1)),$(word 1,$(2))),true,)),\ - true)) - -### lte/less than or equal to - -_int_lte_encoded = $(strip \ - $(foreach len1,$(words $(1)),$(foreach len2,$(words $(2)),\ - $(if $(call _EQ,$(len1),$(len2)),\ - $(call _lte_digits,$(call _reverse,$(1)),$(call _reverse,$(2))),\ - $(if $(wordlist $(len1),$(len2),$(LIST100_X)),\ - true,\ - ))))) - -int_lte_encoded = $(strip \ - $(if $(filter -,$(1)),\ - $(if $(filter -,$(2)),\ - $(call _int_lte_encoded,$(filter-out -,$(2)),$(filter-out -,$(1))),\ - true),\ - $(if $(filter -,$(2)),\ - ,\ - $(call _int_lte_encoded,$(1),$(2))))) - -int_lte = $(call int_lte_encoded,$(call int_encode,$(1)),$(call int_encode,$(2))) - -### lt/less than - -int_lt_encoded = $(strip \ - $(if $(call _EQ,$(strip $(1)),$(strip $(2))),\ - ,\ - $(call int_lte_encoded,$(1),$(2)))) - -int_lt = $(call int_lt_encoded,$(call int_encode,$(1)),$(call int_encode,$(2))) - -### gte/greater than or equal to - -int_gte_encoded = $(strip \ - $(if $(call _EQ,$(strip $(1)),$(strip $(2))),\ - true,\ - $(if $(call int_lte_encoded,$(1),$(2)),,true))) - -int_gte = $(call int_gte_encoded,$(call int_encode,$(1)),$(call int_encode,$(2))) - -### gt/greater than - -int_gt_encoded = $(strip \ - $(if $(call _EQ,$(strip $(1)),$(strip $(2))),\ - ,\ - $(call int_gte_encoded,$(1),$(2)))) - -int_gt = $(call int_gt_encoded,$(call int_encode,$(1)),$(call int_encode,$(2))) - -#$(info _lte_digit,7,8: [$(call _lte_digit,7,8)]) -#$(info _lte_digit,8,8: [$(call _lte_digit,8,8)]) -#$(info _lte_digit,2,1: [$(call _lte_digit,2,1)]) -#$(info _lte_digit,0,0: [$(call _lte_digit,0,0)]) -#$(info _lte_digit,0,1: [$(call _lte_digit,0,1)]) -#$(info _lte_digit,1,0: [$(call _lte_digit,1,0)]) - -#$(info _lte_digits,1 2 3,1 2 4: [$(call _lte_digits,1 2 3,1 2 4)]) -#$(info _lte_digits,1 2 4,1 2 4: [$(call _lte_digits,1 2 4,1 2 4)]) -#$(info _lte_digits,1 2 5,1 2 4: [$(call _lte_digits,1 2 5,1 2 4)]) -#$(info _lte_digits,4 1,9 0: [$(call _lte_digits,4 1,9 0)]) - -# The main comparison operator (others are built on this) -#$(info int_lte_encoded,1,1: [$(call int_lte_encoded,1,1)]) -#$(info int_lte_encoded,1,2: [$(call int_lte_encoded,1,2)]) -#$(info int_lte_encoded,2,1: [$(call int_lte_encoded,2,1)]) -#$(info int_lte_encoded,0,3: [$(call int_lte_encoded,0,3)]) -#$(info int_lte_encoded,3,0: [$(call int_lte_encoded,3,0)]) -#$(info int_lte_encoded,1 4,0 9: [$(call int_lte_encoded,1 4,0 9)]) -#$(info int_lte_encoded,4 3 2 1,4 3 2 1: [$(call int_lte_encoded,4 3 2 1,4 3 2 1)]) -#$(info int_lte_encoded,5 3 2 1,4 3 2 1: [$(call int_lte_encoded,5 3 2 1,4 3 2 1)]) -#$(info int_lte_encoded,4 3 2 1,5 3 2 1: [$(call int_lte_encoded,4 3 2 1,5 3 2 1)]) -# negative numbers -#$(info int_lte_encoded,7 -,7: [$(call int_lte_encoded,7 -,7)]) -#$(info int_lte_encoded,7,7 -: [$(call int_lte_encoded,7,7 -)]) -#$(info int_lte_encoded,7 -,7 -: [$(call int_lte_encoded,7 -,7 -)]) -#$(info int_lte_encoded,1 7 -,0 7: [$(call int_lte_encoded,1 7 -,0 7)]) -#$(info int_lte_encoded,1 7,0 7 -: [$(call int_lte_encoded,1 7,0 7 -)]) -#$(info int_lte_encoded,1 7 -,0 7 -: [$(call int_lte_encoded,1 7 -,0 7 -)]) -#$(info int_lte_encoded,4 3 2 1 -,4 3 2 1: [$(call int_lte_encoded,4 3 2 1 -,4 3 2 1)]) -#$(info int_lte_encoded,4 3 2 1,4 3 2 1 -: [$(call int_lte_encoded,4 3 2 1,4 3 2 1 -)]) -#$(info int_lte_encoded,4 3 2 1 -,4 3 2 1 -: [$(call int_lte_encoded,4 3 2 1 -,4 3 2 1 -)]) - -#$(info int_lte,1,1: [$(call int_lte,1,1)]) -#$(info int_lte,1,2: [$(call int_lte,1,2)]) -#$(info int_lte,2,1: [$(call int_lte,2,1)]) -#$(info int_lte,0,3: [$(call int_lte,0,3)]) -#$(info int_lte,3,0: [$(call int_lte,3,0)]) -#$(info int_lte,1234,1234: [$(call int_lte,1234,1234)]) -#$(info int_lte,1235,1234: [$(call int_lte,1235,1234)]) -#$(info int_lte,1234,1235: [$(call int_lte,1234,1235)]) -#$(info int_lte,-1234,1235: [$(call int_lte,-1234,1235)]) -#$(info int_lte,1234,-1235: [$(call int_lte,1234,-1235)]) -#$(info int_lte,-1234,-1235: [$(call int_lte,-1234,-1235)]) - -#$(info int_lt,1,1: [$(call int_lt,1,1)]) -#$(info int_lt,1,2: [$(call int_lt,1,2)]) -#$(info int_lt,2,1: [$(call int_lt,2,1)]) -#$(info int_lt,0,3: [$(call int_lt,0,3)]) -#$(info int_lt,3,0: [$(call int_lt,3,0)]) -#$(info int_lt,1234,1234: [$(call int_lt,1234,1234)]) -#$(info int_lt,1235,1234: [$(call int_lt,1235,1234)]) -#$(info int_lt,1234,1235: [$(call int_lt,1234,1235)]) -# -#$(info int_gte,1,1: [$(call int_gte,1,1)]) -#$(info int_gte,1,2: [$(call int_gte,1,2)]) -#$(info int_gte,2,1: [$(call int_gte,2,1)]) -#$(info int_gte,0,3: [$(call int_gte,0,3)]) -#$(info int_gte,3,0: [$(call int_gte,3,0)]) -#$(info int_gte,1234,1234: [$(call int_gte,1234,1234)]) -#$(info int_gte,1235,1234: [$(call int_gte,1235,1234)]) -#$(info int_gte,1234,1235: [$(call int_gte,1234,1235)]) -# -#$(info int_gt,1,1: [$(call int_gt,1,1)]) -#$(info int_gt,1,2: [$(call int_gt,1,2)]) -#$(info int_gt,2,1: [$(call int_gt,2,1)]) -#$(info int_gt,0,3: [$(call int_gt,0,3)]) -#$(info int_gt,3,0: [$(call int_gt,3,0)]) -#$(info int_gt,1234,1234: [$(call int_gt,1234,1234)]) -#$(info int_gt,1235,1234: [$(call int_gt,1235,1234)]) -#$(info int_gt,1234,1235: [$(call int_gt,1234,1235)]) -#$(info int_gt,-1234,1235: [$(call int_gt,-1234,1235)]) -#$(info int_gt,-1234,-1235: [$(call int_gt,-1234,-1235)]) - - -### -### addition -### - - -# add_digits_with_carry -_add_digit = $(words $(if $(strip $(1)),$(wordlist 1,$(1),$(LIST20_X)),) \ - $(if $(strip $(2)),$(wordlist 1,$(2),$(LIST20_X)),)) - -# add one to a single digit -_inc_digit = $(words $(wordlist 1,$(if $(1),$(1),0),$(LIST20_X)) x) - -# add two encoded numbers digit by digit without resolving carries -# (each digit will be larger than 9 if there is a carry value) -_add = $(if $(1)$(2),$(call _add_digit,$(word 1,$(1)),$(word 1,$(2))) $(call _add,$(wordlist 2,$(words $(1)),$(1)),$(wordlist 2,$(words $(2)),$(2))),) - -# take the result of _add and resolve the carry values digit by digit -_resolve_carries = $(strip \ - $(if $(1),\ - $(foreach num,$(word 1,$(1)),\ - $(if $(filter-out 1,$(filter 1%,$(num))),\ - $(call _resolve_carries,$(call _inc_digit,$(word 2,$(1))) $(wordlist 3,$(words $(1)),$(1)),$(2) $(patsubst 1%,%,$(num))),\ - $(call _resolve_carries,$(wordlist 2,$(words $(1)),$(1)),$(2) $(num)))),\ - $(2))) - -_negate = $(strip \ - $(if $(call _EQ,0,$(strip $(1))),\ - 0,\ - $(if $(filter -,$(1)),$(filter-out -,$(1)),$(1) -))) - -# add two encoded numbers, returns encoded number -_int_add_encoded = $(call _resolve_carries,$(call _add,$(1),$(2))) - -int_add_encoded = $(strip \ - $(if $(filter -,$(1)),\ - $(if $(filter -,$(2)),\ - $(call _negate,$(call _int_add_encoded,$(filter-out -,$(1)),$(filter-out -,$(2)))),\ - $(call int_sub_encoded,$(2),$(filter-out -,$(1)))),\ - $(if $(filter -,$(2)),\ - $(call int_sub_encoded,$(1),$(filter-out -,$(2))),\ - $(call _int_add_encoded,$(1),$(2))))) - -# add two unencoded numbers, returns unencoded number -int_add = $(call int_decode,$(call int_add_encoded,$(call int_encode,$(1)),$(call int_encode,$(2)))) - -### addition tests - -#$(info _add_digit(7,6,1): [$(call _add_digit,7,6,1)]) -#$(info _add_digit(7,6,0): [$(call _add_digit,7,6,0)]) -#$(info _add_digit(7,6,0): [$(call _add_digit,7,6,0)]) -#$(info _carries(12 14 15): [$(call _carries,12 14 15)]) -#$(info _inc_digit(0): $(call _inc_digit,0)) -#$(info _inc_digit(1): $(call _inc_digit,1)) -#$(info _inc_digit(9): $(call _inc_digit,9)) -#$(info _inc_digit(18): $(call _inc_digit,18)) -#$(info int_add_encoded(0,0): [$(call int_add_encoded,0,0)]) - -#$(info int_add(1,2): [$(call int_add,1,2)]) -#$(info int_add(9,9): [$(call int_add,9,9)]) -#$(info int_add(0,9): [$(call int_add,0,9)]) -#$(info int_add(9,0): [$(call int_add,9,0)]) -#$(info int_add(0,0): [$(call int_add,0,0)]) -#$(info int_add(123,456): [$(call int_add,123,456)]) -#$(info int_add(678,789): [$(call int_add,678,789)]) -#$(info int_add(1,12): [$(call int_add,1,12)]) -#$(info int_add(123,5): [$(call int_add,123,5)]) -#$(info int_add(123456,9): [$(call int_add,123456,9)]) -#$(info int_add(999999991,9): [$(call int_add,999999991,9)]) -# negative numbers -#$(info int_add(-2,2): [$(call int_add,-2,2)]) -#$(info int_add(-1,2): [$(call int_add,-1,2)]) -#$(info int_add(1,-2): [$(call int_add,1,-2)]) -#$(info int_add(-1,-2): [$(call int_add,-1,-2)]) - -### -### subtraction -### - -_get_zeros = $(if $(call _EQ,0,$(word 1,$(1))),$(call _get_zeros,$(wordlist 2,$(words $(1)),$(1)),$(2) 0),$(2)) - -# return a 9's complement of a single digit -_complement9 = $(strip \ - $(if $(call _EQ,0,$(1)),9,\ - $(if $(call _EQ,1,$(1)),8,\ - $(if $(call _EQ,2,$(1)),7,\ - $(if $(call _EQ,3,$(1)),6,\ - $(if $(call _EQ,4,$(1)),5,\ - $(if $(call _EQ,5,$(1)),4,\ - $(if $(call _EQ,6,$(1)),3,\ - $(if $(call _EQ,7,$(1)),2,\ - $(if $(call _EQ,8,$(1)),1,\ - $(if $(call _EQ,9,$(1)),0))))))))))) - -# return a 10's complement of a single digit -_complement10 = $(call _inc_digit,$(call _complement9,$(1))) - -# -_complement_rest = $(if $(strip $(1)),\ - $(strip \ - $(call _complement10,$(word 1,$(1))) \ - $(foreach digit,$(wordlist 2,$(words $(1)),$(1)),\ - $(call _complement9,$(digit)))),) - -# return the complement of a number -_complement = $(strip $(call _get_zeros,$(1)) \ - $(call _complement_rest,$(wordlist $(call _inc_digit,$(words $(call _get_zeros,$(1)))),$(words $(1)),$(1)))) - -# subtracted encoded number 2 from encoded number 1 and return and -# encoded number result. both numbers must be positive but may have -# a negative result -__int_sub_encoded = $(strip \ - $(call trim_zeros,\ - $(call drop_last,\ - $(call int_add_encoded,\ - $(1),\ - $(wordlist 1,$(words $(1)),$(call _complement,$(2)) $(LIST100_9)))))) - -_int_sub_encoded = $(strip \ - $(if $(call _EQ,0,$(strip $(2))),\ - $(1),\ - $(if $(call _int_lte_encoded,$(2),$(1)),\ - $(call __int_sub_encoded,$(1),$(2)),\ - $(call _negate,$(call __int_sub_encoded,$(2),$(1)))))) - -int_sub_encoded = $(strip \ - $(if $(filter -,$(1)),\ - $(if $(filter -,$(2)),\ - $(call _int_sub_encoded,$(filter-out -,$(2)),$(filter-out -,$(1))),\ - $(call _negate,$(call _int_add_encoded,$(filter-out -,$(1)),$(2)))),\ - $(if $(filter -,$(2)),\ - $(call _int_add_encoded,$(1),$(filter-out -,$(2))),\ - $(call _int_sub_encoded,$(1),$(2))))) - -# subtract unencoded number 2 from unencoded number 1 and return -# unencoded result -int_sub = $(call int_decode,$(call int_sub_encoded,$(call int_encode,$(1)),$(call int_encode,$(2)))) - -### subtraction tests - -#$(info _get_zeros(5 7): [$(call _get_zeros,5 7)]) -#$(info _get_zeros(0 0 0 2): [$(call _get_zeros,0 0 0 2)]) -#$(info _get_zeros(0 0 0 2 5): [$(call _get_zeros,0 0 0 2 5)]) - -#$(info _complement(0): [$(call _complement,0)]) -#$(info _complement(1): [$(call _complement,1)]) -#$(info _complement(9): [$(call _complement,9)]) -#$(info _complement(5 7): [$(call _complement,5 7)]) -#$(info _complement(0 0 0 2): [$(call _complement,0 0 0 2)]) -#$(info _complement(0 0 0 5 4 3 2 1): [$(call _complement,0 0 0 5 4 3 2 1)]) - -#$(info int_sub_encoded(0 0 1, 3 1): [$(call int_sub_encoded,0 0 1,3 1)]) -#$(info int_sub_encoded(2, 2): [$(call int_sub_encoded,2,2)]) - -#$(info int_sub(2,1): [$(call int_sub,2,1)]) -#$(info int_sub(2,0): [$(call int_sub,2,0)]) -#$(info int_sub(2,2): [$(call int_sub,2,2)]) -#$(info int_sub(100,13): [$(call int_sub,100,13)]) -#$(info int_sub(100,99): [$(call int_sub,100,99)]) -#$(info int_sub(91,19): [$(call int_sub,91,19)]) -# negative numbers -#$(info int_sub(1,2): [$(call int_sub,1,2)]) -#$(info int_sub(-1,2): [$(call int_sub,-1,2)]) -#$(info int_sub(1,-2): [$(call int_sub,1,-2)]) -#$(info int_sub(-1,-2): [$(call int_sub,-1,-2)]) -#$(info int_sub(-2,-1): [$(call int_sub,-2,-1)]) -#$(info int_sub(19,91): [$(call int_sub,19,91)]) -#$(info int_sub(91,-19): [$(call int_sub,91,-19)]) -#$(info int_sub(-91,19): [$(call int_sub,-91,19)]) -#$(info int_sub(-91,-19): [$(call int_sub,-91,-19)]) - - -### -### multiplication -### - -# multiply two digits -#_mult_digit = $(words $(foreach x,$(1),$(2))) -_mult_digit = $(strip \ - $(words $(foreach x,$(wordlist 1,$(1),$(LIST20_X)),\ - $(wordlist 1,$(2),$(LIST20_X))))) - -# multipy every digit of number 1 with number 2 -# params: digits, digit, indent_zeros, results -_mult_row = $(if $(strip $(1)),$(call _mult_row,$(wordlist 2,$(words $(1)),$(1)),$(2),$(3)0,$(4) $(call _mult_digit,$(word 1,$(1)),$(2))$(3)),$(4)) - -# multiply every digit of number 2 with every digit of number 1 adding -# correct zero padding to the end of each result -# params: digits, digits, indent_zeros, results -_mult_each = $(if $(strip $(2)),$(call _mult_each,$(1),$(wordlist 2,$(words $(2)),$(2)),$(3)0,$(4) $(call _mult_row,$(1),$(word 1,$(2)),$(3))),$(4)) - -# add up a bunch of unencoded numbers. Basically reduce into the first number -_add_many = $(if $(word 2,$(1)),$(call _add_many,$(call int_add,$(word 1,$(1)),$(word 2,$(1))) $(wordlist 3,$(words $(1)),$(1))),$(1)) - -# multiply two encoded numbers, returns encoded number -_int_mult_encoded = $(call trim_zeros,$(call int_encode,$(call _add_many,$(call _mult_each,$(1),$(2))))) - -int_mult_encoded = $(strip \ - $(if $(filter -,$(1)),\ - $(if $(filter -,$(2)),\ - $(call _int_mult_encoded,$(filter-out -,$(1)),$(filter-out -,$(2))),\ - $(call _negate,$(call _int_mult_encoded,$(filter-out -,$(1)),$(2)))),\ - $(if $(filter -,$(2)),\ - $(call _negate,$(call _int_mult_encoded,$(1),$(filter-out -,$(2)))),\ - $(call _int_mult_encoded,$(1),$(2))))) - -# multiply two unencoded numbers, returns unencoded number -int_mult = $(call int_decode,$(call int_mult_encoded,$(call int_encode,$(1)),$(call int_encode,$(2)))) - -#$(info _mult_digit(8,6): [$(call _mult_digit,8,6)]) -#$(info _mult_digit(7,6): [$(call _mult_digit,7,6)]) -#$(info _mult_row(8,6): [$(call _mult_row,8,6)]) -#$(info _mult_row(8 7,6): [$(call _mult_row,8 7,6)]) -#$(info _mult_row(8 7 3,6): [$(call _mult_row,8 7 3,6)]) -#$(info _mult_each(8 7 6, 4 3 2): [$(call _mult_each,8 7 6,4 3 2)]) -#$(info _add_many(123 234 345 456): [$(call _add_many,123 234 345 456)]) - -#$(info int_mult_encoded(8 7 3,6): [$(call int_mult_encoded,8 7 3,6)]) -#$(info int_mult_encoded(8 7 3,0): [$(call int_mult_encoded,8 7 3,0)]) - -#$(info int_mult(378,6): [$(call int_mult,378,6)]) -#$(info int_mult(678,234): [$(call int_mult,678,234)]) -#$(info int_mult(1,23456): [$(call int_mult,1,23456)]) -#$(info int_mult(0,23456): [$(call int_mult,0,23456)]) -#$(info int_mult(0,0): [$(call int_mult,0,0)]) -# negative numbers -#$(info int_mult(-378,6): [$(call int_mult,-378,6)]) -#$(info int_mult(678,-234): [$(call int_mult,678,-234)]) -#$(info int_mult(-1,-23456): [$(call int_mult,-1,-23456)]) -#$(info int_mult(0,-23456): [$(call int_mult,0,-23456)]) - -### -### division -### - -# return list of zeros needed to pad number 2 to the same length as number 1 -_zero_pad = $(strip $(wordlist 1,$(call int_sub,$(words $(1)),$(words $(2))),$(LIST100_0))) - -# num1, num2, zero pad, result_accumulator -# algorithm: -# - B = pad with zeros to make same digit length as A -# - loop -# - if (B <= A) -# - A = subtract B from A -# - C = C + 10^(B pad.length) -# - else -# - if B.length < origin B.length: break -# - chop least significant digit of B -_div = $(strip \ - $(if $(call int_lte_encoded,$(3) $(2),$(1)),\ - $(call _div,$(call int_sub_encoded,$(1),$(3) $(2)),$(2),$(3),$(call int_add_encoded,$(4),$(3) 1)),\ - $(if $(3),\ - $(call _div,$(1),$(2),$(wordlist 2,$(words $(3)),$(3)),$(4)),\ - $(4)))) - -# divide two encoded numbers, returns encoded number -_int_div_encoded = $(strip \ - $(if $(call _EQ,0,$(1)),\ - 0,\ - $(if $(call _EQ,$(1),$(2)),\ - 1,\ - $(if $(call int_gt_encoded,$(2),$(1)),\ - 0,\ - $(call _div,$(1),$(2),$(call _zero_pad,$(1),$(2)),0))))) - -int_div_encoded = $(strip \ - $(if $(filter -,$(1)),\ - $(if $(filter -,$(2)),\ - $(call _int_div_encoded,$(filter-out -,$(1)),$(filter-out -,$(2))),\ - $(call _negate,$(call _int_div_encoded,$(filter-out -,$(1)),$(2)))),\ - $(if $(filter -,$(2)),\ - $(call _negate,$(call _int_div_encoded,$(1),$(filter-out -,$(2)))),\ - $(call _int_div_encoded,$(1),$(2))))) - -# divide two unencoded numbers, returns unencoded number -int_div = $(call int_decode,$(call int_div_encoded,$(call int_encode,$(1)),$(call int_encode,$(2)))) - -### division tests - -#$(info _zero_pad(1 2 3 4,1 3): [$(call _zero_pad,1 2 3 4,1 3)]) -#$(info _zero_pad(1 2,1 3): [$(call _zero_pad,1 2,1 3)]) -#$(info _zero_pad(2,1 3): [$(call _zero_pad,1 2,1 3)]) -# -#$(info int_div_encoded(2,1): [$(call int_div_encoded,2,1)]) -#$(info int_div_encoded(3,1): [$(call int_div_encoded,3,1)]) -#$(info int_div_encoded(3,2): [$(call int_div_encoded,3,2)]) -#$(info int_div_encoded(0,7): [$(call int_div_encoded,0,7)]) -#$(info int_div_encoded(0 3,0 2): [$(call int_div_encoded,0 3,0 2)]) -#$(info int_div_encoded(0 3,5): [$(call int_div_encoded,0 3,5)]) -# -#$(info int_div(5,1): [$(call int_div,5,1)]) -#$(info int_div(5,2): [$(call int_div,5,2)]) -#$(info int_div(123,7): [$(call int_div,123,7)]) -#$(info int_div(100,7): [$(call int_div,100,7)]) -# negative numbers -#$(info int_div(-5,1): [$(call int_div,-5,1)]) -#$(info int_div(5,-2): [$(call int_div,5,-2)]) -#$(info int_div(-123,-7): [$(call int_div,-123,-7)]) - - -### combination tests - -# (/ (- (+ 515 (* 222 311)) 300) 41) = 1689 -#$(info int_mult,222,311: [$(call int_mult,222,311)]) -#$(info int_add(515,69042): [$(call int_add,515,69042)]) -#$(info int_sub(69557,300): [$(call int_sub,69557,300)]) -#$(info int_div(69257,41): [$(call int_div,69257,41)]) -# (/ (- (+ 515 (* -222 311)) 300) 41) = -1678 -#$(info int_mult,-222,311: [$(call int_mult,-222,311)]) -#$(info int_add(515,-69042): [$(call int_add,515,-69042)]) -#$(info int_sub(-68527,300): [$(call int_sub,-68527,300)]) -#$(info int_div(-68827,41): [$(call int_div,-68827,41)]) - -############################################################### - -all: - @true - -endif - -# vim: ts=2 et +# +# mal (Make a Lisp) number types +# + +ifndef __mal_numbers_included +__mal_numbers_included := true + +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)util.mk + +LIST20_X := x x x x x x x x x x x x x x x x x x x x +LIST100_X := $(foreach x,$(LIST20_X),X X X X X) +LIST100_0 := $(foreach x,$(LIST20_X),0 0 0 0 0) +LIST100_9 := $(foreach x,$(LIST20_X),9 9 9 9 9) + +### +### general numeric utility functions +### + +int_encode = $(strip $(call _reverse,\ + $(eval __temp := $(1))\ + $(foreach a,- 0 1 2 3 4 5 6 7 8 9,\ + $(eval __temp := $$(subst $$a,$$a$$(SPACE),$(__temp))))$(__temp))) + +int_decode = $(strip $(call _join,$(call _reverse,$(1)))) + +# trim extaneous zero digits off the end (front of number) +_trim_zeros = $(if $(call _EQ,0,$(strip $(1))),0,$(if $(call _EQ,0,$(word 1,$(1))),$(call _trim_zeros,$(wordlist 2,$(words $(1)),$(1))),$(1))) +trim_zeros = $(strip \ + $(if $(call _EQ,0,$(strip $(filter-out -,$(1)))),\ + $(filter-out -,$(1)),\ + $(call _reverse,$(call _trim_zeros,$(call _reverse,$(filter-out -,$(1))))))\ + $(if $(filter -,$(1)), -,)) + +# drop the last element of a list of words/digits +drop_last = $(call _reverse,$(wordlist 2,$(words $(1)),$(call _reverse,$(1)))) + +### utility function tests + +#$(info $(filter-out 1,$(filter 1%,1 132 456))) +#$(info (int_encode 13): [$(call int_encode,13)]) +#$(info (int_encode 156463): [$(call int_encode,156463)]) +#$(info (int_encode -156463): [$(call int_encode,-156463)]) +#$(info (int_decode (int_encode 156463)): [$(call int_decode,$(call int_encode,156463))]) + +#$(info trim_zeros(0 0 0): [$(call trim_zeros,0 0 0)]) +#$(info trim_zeros(0 0 0 -): [$(call trim_zeros,0 0 0 -)]) + + +### +### comparisons +### + +# compare two digits and return 'true' if digit 1 is less than or +# equal to digit 2 +_lte_digit = $(strip \ + $(if $(call _EQ,$(1),$(2)),\ + true,\ + $(if $(call _EQ,0,$(1)),\ + true,\ + $(if $(wordlist $(1),$(2),$(LIST20_X)),\ + true,\ + )))) + +# compare two lists of digits (MSB->LSB) of equal length and return +# 'true' if number 1 is less than number 2 +_lte_digits = $(strip \ + $(if $(strip $(1)),\ + $(if $(call _EQ,$(word 1,$(1)),$(word 1,$(2))),\ + $(call _lte_digits,$(wordlist 2,$(words $(1)),$(1)),$(wordlist 2,$(words $(2)),$(2))),\ + $(if $(call _lte_digit,$(word 1,$(1)),$(word 1,$(2))),true,)),\ + true)) + +### lte/less than or equal to + +_int_lte_encoded = $(strip \ + $(foreach len1,$(words $(1)),$(foreach len2,$(words $(2)),\ + $(if $(call _EQ,$(len1),$(len2)),\ + $(call _lte_digits,$(call _reverse,$(1)),$(call _reverse,$(2))),\ + $(if $(wordlist $(len1),$(len2),$(LIST100_X)),\ + true,\ + ))))) + +int_lte_encoded = $(strip \ + $(if $(filter -,$(1)),\ + $(if $(filter -,$(2)),\ + $(call _int_lte_encoded,$(filter-out -,$(2)),$(filter-out -,$(1))),\ + true),\ + $(if $(filter -,$(2)),\ + ,\ + $(call _int_lte_encoded,$(1),$(2))))) + +int_lte = $(call int_lte_encoded,$(call int_encode,$(1)),$(call int_encode,$(2))) + +### lt/less than + +int_lt_encoded = $(strip \ + $(if $(call _EQ,$(strip $(1)),$(strip $(2))),\ + ,\ + $(call int_lte_encoded,$(1),$(2)))) + +int_lt = $(call int_lt_encoded,$(call int_encode,$(1)),$(call int_encode,$(2))) + +### gte/greater than or equal to + +int_gte_encoded = $(strip \ + $(if $(call _EQ,$(strip $(1)),$(strip $(2))),\ + true,\ + $(if $(call int_lte_encoded,$(1),$(2)),,true))) + +int_gte = $(call int_gte_encoded,$(call int_encode,$(1)),$(call int_encode,$(2))) + +### gt/greater than + +int_gt_encoded = $(strip \ + $(if $(call _EQ,$(strip $(1)),$(strip $(2))),\ + ,\ + $(call int_gte_encoded,$(1),$(2)))) + +int_gt = $(call int_gt_encoded,$(call int_encode,$(1)),$(call int_encode,$(2))) + +#$(info _lte_digit,7,8: [$(call _lte_digit,7,8)]) +#$(info _lte_digit,8,8: [$(call _lte_digit,8,8)]) +#$(info _lte_digit,2,1: [$(call _lte_digit,2,1)]) +#$(info _lte_digit,0,0: [$(call _lte_digit,0,0)]) +#$(info _lte_digit,0,1: [$(call _lte_digit,0,1)]) +#$(info _lte_digit,1,0: [$(call _lte_digit,1,0)]) + +#$(info _lte_digits,1 2 3,1 2 4: [$(call _lte_digits,1 2 3,1 2 4)]) +#$(info _lte_digits,1 2 4,1 2 4: [$(call _lte_digits,1 2 4,1 2 4)]) +#$(info _lte_digits,1 2 5,1 2 4: [$(call _lte_digits,1 2 5,1 2 4)]) +#$(info _lte_digits,4 1,9 0: [$(call _lte_digits,4 1,9 0)]) + +# The main comparison operator (others are built on this) +#$(info int_lte_encoded,1,1: [$(call int_lte_encoded,1,1)]) +#$(info int_lte_encoded,1,2: [$(call int_lte_encoded,1,2)]) +#$(info int_lte_encoded,2,1: [$(call int_lte_encoded,2,1)]) +#$(info int_lte_encoded,0,3: [$(call int_lte_encoded,0,3)]) +#$(info int_lte_encoded,3,0: [$(call int_lte_encoded,3,0)]) +#$(info int_lte_encoded,1 4,0 9: [$(call int_lte_encoded,1 4,0 9)]) +#$(info int_lte_encoded,4 3 2 1,4 3 2 1: [$(call int_lte_encoded,4 3 2 1,4 3 2 1)]) +#$(info int_lte_encoded,5 3 2 1,4 3 2 1: [$(call int_lte_encoded,5 3 2 1,4 3 2 1)]) +#$(info int_lte_encoded,4 3 2 1,5 3 2 1: [$(call int_lte_encoded,4 3 2 1,5 3 2 1)]) +# negative numbers +#$(info int_lte_encoded,7 -,7: [$(call int_lte_encoded,7 -,7)]) +#$(info int_lte_encoded,7,7 -: [$(call int_lte_encoded,7,7 -)]) +#$(info int_lte_encoded,7 -,7 -: [$(call int_lte_encoded,7 -,7 -)]) +#$(info int_lte_encoded,1 7 -,0 7: [$(call int_lte_encoded,1 7 -,0 7)]) +#$(info int_lte_encoded,1 7,0 7 -: [$(call int_lte_encoded,1 7,0 7 -)]) +#$(info int_lte_encoded,1 7 -,0 7 -: [$(call int_lte_encoded,1 7 -,0 7 -)]) +#$(info int_lte_encoded,4 3 2 1 -,4 3 2 1: [$(call int_lte_encoded,4 3 2 1 -,4 3 2 1)]) +#$(info int_lte_encoded,4 3 2 1,4 3 2 1 -: [$(call int_lte_encoded,4 3 2 1,4 3 2 1 -)]) +#$(info int_lte_encoded,4 3 2 1 -,4 3 2 1 -: [$(call int_lte_encoded,4 3 2 1 -,4 3 2 1 -)]) + +#$(info int_lte,1,1: [$(call int_lte,1,1)]) +#$(info int_lte,1,2: [$(call int_lte,1,2)]) +#$(info int_lte,2,1: [$(call int_lte,2,1)]) +#$(info int_lte,0,3: [$(call int_lte,0,3)]) +#$(info int_lte,3,0: [$(call int_lte,3,0)]) +#$(info int_lte,1234,1234: [$(call int_lte,1234,1234)]) +#$(info int_lte,1235,1234: [$(call int_lte,1235,1234)]) +#$(info int_lte,1234,1235: [$(call int_lte,1234,1235)]) +#$(info int_lte,-1234,1235: [$(call int_lte,-1234,1235)]) +#$(info int_lte,1234,-1235: [$(call int_lte,1234,-1235)]) +#$(info int_lte,-1234,-1235: [$(call int_lte,-1234,-1235)]) + +#$(info int_lt,1,1: [$(call int_lt,1,1)]) +#$(info int_lt,1,2: [$(call int_lt,1,2)]) +#$(info int_lt,2,1: [$(call int_lt,2,1)]) +#$(info int_lt,0,3: [$(call int_lt,0,3)]) +#$(info int_lt,3,0: [$(call int_lt,3,0)]) +#$(info int_lt,1234,1234: [$(call int_lt,1234,1234)]) +#$(info int_lt,1235,1234: [$(call int_lt,1235,1234)]) +#$(info int_lt,1234,1235: [$(call int_lt,1234,1235)]) +# +#$(info int_gte,1,1: [$(call int_gte,1,1)]) +#$(info int_gte,1,2: [$(call int_gte,1,2)]) +#$(info int_gte,2,1: [$(call int_gte,2,1)]) +#$(info int_gte,0,3: [$(call int_gte,0,3)]) +#$(info int_gte,3,0: [$(call int_gte,3,0)]) +#$(info int_gte,1234,1234: [$(call int_gte,1234,1234)]) +#$(info int_gte,1235,1234: [$(call int_gte,1235,1234)]) +#$(info int_gte,1234,1235: [$(call int_gte,1234,1235)]) +# +#$(info int_gt,1,1: [$(call int_gt,1,1)]) +#$(info int_gt,1,2: [$(call int_gt,1,2)]) +#$(info int_gt,2,1: [$(call int_gt,2,1)]) +#$(info int_gt,0,3: [$(call int_gt,0,3)]) +#$(info int_gt,3,0: [$(call int_gt,3,0)]) +#$(info int_gt,1234,1234: [$(call int_gt,1234,1234)]) +#$(info int_gt,1235,1234: [$(call int_gt,1235,1234)]) +#$(info int_gt,1234,1235: [$(call int_gt,1234,1235)]) +#$(info int_gt,-1234,1235: [$(call int_gt,-1234,1235)]) +#$(info int_gt,-1234,-1235: [$(call int_gt,-1234,-1235)]) + + +### +### addition +### + + +# add_digits_with_carry +_add_digit = $(words $(if $(strip $(1)),$(wordlist 1,$(1),$(LIST20_X)),) \ + $(if $(strip $(2)),$(wordlist 1,$(2),$(LIST20_X)),)) + +# add one to a single digit +_inc_digit = $(words $(wordlist 1,$(if $(1),$(1),0),$(LIST20_X)) x) + +# add two encoded numbers digit by digit without resolving carries +# (each digit will be larger than 9 if there is a carry value) +_add = $(if $(1)$(2),$(call _add_digit,$(word 1,$(1)),$(word 1,$(2))) $(call _add,$(wordlist 2,$(words $(1)),$(1)),$(wordlist 2,$(words $(2)),$(2))),) + +# take the result of _add and resolve the carry values digit by digit +_resolve_carries = $(strip \ + $(if $(1),\ + $(foreach num,$(word 1,$(1)),\ + $(if $(filter-out 1,$(filter 1%,$(num))),\ + $(call _resolve_carries,$(call _inc_digit,$(word 2,$(1))) $(wordlist 3,$(words $(1)),$(1)),$(2) $(patsubst 1%,%,$(num))),\ + $(call _resolve_carries,$(wordlist 2,$(words $(1)),$(1)),$(2) $(num)))),\ + $(2))) + +_negate = $(strip \ + $(if $(call _EQ,0,$(strip $(1))),\ + 0,\ + $(if $(filter -,$(1)),$(filter-out -,$(1)),$(1) -))) + +# add two encoded numbers, returns encoded number +_int_add_encoded = $(call _resolve_carries,$(call _add,$(1),$(2))) + +int_add_encoded = $(strip \ + $(if $(filter -,$(1)),\ + $(if $(filter -,$(2)),\ + $(call _negate,$(call _int_add_encoded,$(filter-out -,$(1)),$(filter-out -,$(2)))),\ + $(call int_sub_encoded,$(2),$(filter-out -,$(1)))),\ + $(if $(filter -,$(2)),\ + $(call int_sub_encoded,$(1),$(filter-out -,$(2))),\ + $(call _int_add_encoded,$(1),$(2))))) + +# add two unencoded numbers, returns unencoded number +int_add = $(call int_decode,$(call int_add_encoded,$(call int_encode,$(1)),$(call int_encode,$(2)))) + +### addition tests + +#$(info _add_digit(7,6,1): [$(call _add_digit,7,6,1)]) +#$(info _add_digit(7,6,0): [$(call _add_digit,7,6,0)]) +#$(info _add_digit(7,6,0): [$(call _add_digit,7,6,0)]) +#$(info _carries(12 14 15): [$(call _carries,12 14 15)]) +#$(info _inc_digit(0): $(call _inc_digit,0)) +#$(info _inc_digit(1): $(call _inc_digit,1)) +#$(info _inc_digit(9): $(call _inc_digit,9)) +#$(info _inc_digit(18): $(call _inc_digit,18)) +#$(info int_add_encoded(0,0): [$(call int_add_encoded,0,0)]) + +#$(info int_add(1,2): [$(call int_add,1,2)]) +#$(info int_add(9,9): [$(call int_add,9,9)]) +#$(info int_add(0,9): [$(call int_add,0,9)]) +#$(info int_add(9,0): [$(call int_add,9,0)]) +#$(info int_add(0,0): [$(call int_add,0,0)]) +#$(info int_add(123,456): [$(call int_add,123,456)]) +#$(info int_add(678,789): [$(call int_add,678,789)]) +#$(info int_add(1,12): [$(call int_add,1,12)]) +#$(info int_add(123,5): [$(call int_add,123,5)]) +#$(info int_add(123456,9): [$(call int_add,123456,9)]) +#$(info int_add(999999991,9): [$(call int_add,999999991,9)]) +# negative numbers +#$(info int_add(-2,2): [$(call int_add,-2,2)]) +#$(info int_add(-1,2): [$(call int_add,-1,2)]) +#$(info int_add(1,-2): [$(call int_add,1,-2)]) +#$(info int_add(-1,-2): [$(call int_add,-1,-2)]) + +### +### subtraction +### + +_get_zeros = $(if $(call _EQ,0,$(word 1,$(1))),$(call _get_zeros,$(wordlist 2,$(words $(1)),$(1)),$(2) 0),$(2)) + +# return a 9's complement of a single digit +_complement9 = $(strip \ + $(if $(call _EQ,0,$(1)),9,\ + $(if $(call _EQ,1,$(1)),8,\ + $(if $(call _EQ,2,$(1)),7,\ + $(if $(call _EQ,3,$(1)),6,\ + $(if $(call _EQ,4,$(1)),5,\ + $(if $(call _EQ,5,$(1)),4,\ + $(if $(call _EQ,6,$(1)),3,\ + $(if $(call _EQ,7,$(1)),2,\ + $(if $(call _EQ,8,$(1)),1,\ + $(if $(call _EQ,9,$(1)),0))))))))))) + +# return a 10's complement of a single digit +_complement10 = $(call _inc_digit,$(call _complement9,$(1))) + +# +_complement_rest = $(if $(strip $(1)),\ + $(strip \ + $(call _complement10,$(word 1,$(1))) \ + $(foreach digit,$(wordlist 2,$(words $(1)),$(1)),\ + $(call _complement9,$(digit)))),) + +# return the complement of a number +_complement = $(strip $(call _get_zeros,$(1)) \ + $(call _complement_rest,$(wordlist $(call _inc_digit,$(words $(call _get_zeros,$(1)))),$(words $(1)),$(1)))) + +# subtracted encoded number 2 from encoded number 1 and return and +# encoded number result. both numbers must be positive but may have +# a negative result +__int_sub_encoded = $(strip \ + $(call trim_zeros,\ + $(call drop_last,\ + $(call int_add_encoded,\ + $(1),\ + $(wordlist 1,$(words $(1)),$(call _complement,$(2)) $(LIST100_9)))))) + +_int_sub_encoded = $(strip \ + $(if $(call _EQ,0,$(strip $(2))),\ + $(1),\ + $(if $(call _int_lte_encoded,$(2),$(1)),\ + $(call __int_sub_encoded,$(1),$(2)),\ + $(call _negate,$(call __int_sub_encoded,$(2),$(1)))))) + +int_sub_encoded = $(strip \ + $(if $(filter -,$(1)),\ + $(if $(filter -,$(2)),\ + $(call _int_sub_encoded,$(filter-out -,$(2)),$(filter-out -,$(1))),\ + $(call _negate,$(call _int_add_encoded,$(filter-out -,$(1)),$(2)))),\ + $(if $(filter -,$(2)),\ + $(call _int_add_encoded,$(1),$(filter-out -,$(2))),\ + $(call _int_sub_encoded,$(1),$(2))))) + +# subtract unencoded number 2 from unencoded number 1 and return +# unencoded result +int_sub = $(call int_decode,$(call int_sub_encoded,$(call int_encode,$(1)),$(call int_encode,$(2)))) + +### subtraction tests + +#$(info _get_zeros(5 7): [$(call _get_zeros,5 7)]) +#$(info _get_zeros(0 0 0 2): [$(call _get_zeros,0 0 0 2)]) +#$(info _get_zeros(0 0 0 2 5): [$(call _get_zeros,0 0 0 2 5)]) + +#$(info _complement(0): [$(call _complement,0)]) +#$(info _complement(1): [$(call _complement,1)]) +#$(info _complement(9): [$(call _complement,9)]) +#$(info _complement(5 7): [$(call _complement,5 7)]) +#$(info _complement(0 0 0 2): [$(call _complement,0 0 0 2)]) +#$(info _complement(0 0 0 5 4 3 2 1): [$(call _complement,0 0 0 5 4 3 2 1)]) + +#$(info int_sub_encoded(0 0 1, 3 1): [$(call int_sub_encoded,0 0 1,3 1)]) +#$(info int_sub_encoded(2, 2): [$(call int_sub_encoded,2,2)]) + +#$(info int_sub(2,1): [$(call int_sub,2,1)]) +#$(info int_sub(2,0): [$(call int_sub,2,0)]) +#$(info int_sub(2,2): [$(call int_sub,2,2)]) +#$(info int_sub(100,13): [$(call int_sub,100,13)]) +#$(info int_sub(100,99): [$(call int_sub,100,99)]) +#$(info int_sub(91,19): [$(call int_sub,91,19)]) +# negative numbers +#$(info int_sub(1,2): [$(call int_sub,1,2)]) +#$(info int_sub(-1,2): [$(call int_sub,-1,2)]) +#$(info int_sub(1,-2): [$(call int_sub,1,-2)]) +#$(info int_sub(-1,-2): [$(call int_sub,-1,-2)]) +#$(info int_sub(-2,-1): [$(call int_sub,-2,-1)]) +#$(info int_sub(19,91): [$(call int_sub,19,91)]) +#$(info int_sub(91,-19): [$(call int_sub,91,-19)]) +#$(info int_sub(-91,19): [$(call int_sub,-91,19)]) +#$(info int_sub(-91,-19): [$(call int_sub,-91,-19)]) + + +### +### multiplication +### + +# multiply two digits +#_mult_digit = $(words $(foreach x,$(1),$(2))) +_mult_digit = $(strip \ + $(words $(foreach x,$(wordlist 1,$(1),$(LIST20_X)),\ + $(wordlist 1,$(2),$(LIST20_X))))) + +# multipy every digit of number 1 with number 2 +# params: digits, digit, indent_zeros, results +_mult_row = $(if $(strip $(1)),$(call _mult_row,$(wordlist 2,$(words $(1)),$(1)),$(2),$(3)0,$(4) $(call _mult_digit,$(word 1,$(1)),$(2))$(3)),$(4)) + +# multiply every digit of number 2 with every digit of number 1 adding +# correct zero padding to the end of each result +# params: digits, digits, indent_zeros, results +_mult_each = $(if $(strip $(2)),$(call _mult_each,$(1),$(wordlist 2,$(words $(2)),$(2)),$(3)0,$(4) $(call _mult_row,$(1),$(word 1,$(2)),$(3))),$(4)) + +# add up a bunch of unencoded numbers. Basically reduce into the first number +_add_many = $(if $(word 2,$(1)),$(call _add_many,$(call int_add,$(word 1,$(1)),$(word 2,$(1))) $(wordlist 3,$(words $(1)),$(1))),$(1)) + +# multiply two encoded numbers, returns encoded number +_int_mult_encoded = $(call trim_zeros,$(call int_encode,$(call _add_many,$(call _mult_each,$(1),$(2))))) + +int_mult_encoded = $(strip \ + $(if $(filter -,$(1)),\ + $(if $(filter -,$(2)),\ + $(call _int_mult_encoded,$(filter-out -,$(1)),$(filter-out -,$(2))),\ + $(call _negate,$(call _int_mult_encoded,$(filter-out -,$(1)),$(2)))),\ + $(if $(filter -,$(2)),\ + $(call _negate,$(call _int_mult_encoded,$(1),$(filter-out -,$(2)))),\ + $(call _int_mult_encoded,$(1),$(2))))) + +# multiply two unencoded numbers, returns unencoded number +int_mult = $(call int_decode,$(call int_mult_encoded,$(call int_encode,$(1)),$(call int_encode,$(2)))) + +#$(info _mult_digit(8,6): [$(call _mult_digit,8,6)]) +#$(info _mult_digit(7,6): [$(call _mult_digit,7,6)]) +#$(info _mult_row(8,6): [$(call _mult_row,8,6)]) +#$(info _mult_row(8 7,6): [$(call _mult_row,8 7,6)]) +#$(info _mult_row(8 7 3,6): [$(call _mult_row,8 7 3,6)]) +#$(info _mult_each(8 7 6, 4 3 2): [$(call _mult_each,8 7 6,4 3 2)]) +#$(info _add_many(123 234 345 456): [$(call _add_many,123 234 345 456)]) + +#$(info int_mult_encoded(8 7 3,6): [$(call int_mult_encoded,8 7 3,6)]) +#$(info int_mult_encoded(8 7 3,0): [$(call int_mult_encoded,8 7 3,0)]) + +#$(info int_mult(378,6): [$(call int_mult,378,6)]) +#$(info int_mult(678,234): [$(call int_mult,678,234)]) +#$(info int_mult(1,23456): [$(call int_mult,1,23456)]) +#$(info int_mult(0,23456): [$(call int_mult,0,23456)]) +#$(info int_mult(0,0): [$(call int_mult,0,0)]) +# negative numbers +#$(info int_mult(-378,6): [$(call int_mult,-378,6)]) +#$(info int_mult(678,-234): [$(call int_mult,678,-234)]) +#$(info int_mult(-1,-23456): [$(call int_mult,-1,-23456)]) +#$(info int_mult(0,-23456): [$(call int_mult,0,-23456)]) + +### +### division +### + +# return list of zeros needed to pad number 2 to the same length as number 1 +_zero_pad = $(strip $(wordlist 1,$(call int_sub,$(words $(1)),$(words $(2))),$(LIST100_0))) + +# num1, num2, zero pad, result_accumulator +# algorithm: +# - B = pad with zeros to make same digit length as A +# - loop +# - if (B <= A) +# - A = subtract B from A +# - C = C + 10^(B pad.length) +# - else +# - if B.length < origin B.length: break +# - chop least significant digit of B +_div = $(strip \ + $(if $(call int_lte_encoded,$(3) $(2),$(1)),\ + $(call _div,$(call int_sub_encoded,$(1),$(3) $(2)),$(2),$(3),$(call int_add_encoded,$(4),$(3) 1)),\ + $(if $(3),\ + $(call _div,$(1),$(2),$(wordlist 2,$(words $(3)),$(3)),$(4)),\ + $(4)))) + +# divide two encoded numbers, returns encoded number +_int_div_encoded = $(strip \ + $(if $(call _EQ,0,$(1)),\ + 0,\ + $(if $(call _EQ,$(1),$(2)),\ + 1,\ + $(if $(call int_gt_encoded,$(2),$(1)),\ + 0,\ + $(call _div,$(1),$(2),$(call _zero_pad,$(1),$(2)),0))))) + +int_div_encoded = $(strip \ + $(if $(filter -,$(1)),\ + $(if $(filter -,$(2)),\ + $(call _int_div_encoded,$(filter-out -,$(1)),$(filter-out -,$(2))),\ + $(call _negate,$(call _int_div_encoded,$(filter-out -,$(1)),$(2)))),\ + $(if $(filter -,$(2)),\ + $(call _negate,$(call _int_div_encoded,$(1),$(filter-out -,$(2)))),\ + $(call _int_div_encoded,$(1),$(2))))) + +# divide two unencoded numbers, returns unencoded number +int_div = $(call int_decode,$(call int_div_encoded,$(call int_encode,$(1)),$(call int_encode,$(2)))) + +### division tests + +#$(info _zero_pad(1 2 3 4,1 3): [$(call _zero_pad,1 2 3 4,1 3)]) +#$(info _zero_pad(1 2,1 3): [$(call _zero_pad,1 2,1 3)]) +#$(info _zero_pad(2,1 3): [$(call _zero_pad,1 2,1 3)]) +# +#$(info int_div_encoded(2,1): [$(call int_div_encoded,2,1)]) +#$(info int_div_encoded(3,1): [$(call int_div_encoded,3,1)]) +#$(info int_div_encoded(3,2): [$(call int_div_encoded,3,2)]) +#$(info int_div_encoded(0,7): [$(call int_div_encoded,0,7)]) +#$(info int_div_encoded(0 3,0 2): [$(call int_div_encoded,0 3,0 2)]) +#$(info int_div_encoded(0 3,5): [$(call int_div_encoded,0 3,5)]) +# +#$(info int_div(5,1): [$(call int_div,5,1)]) +#$(info int_div(5,2): [$(call int_div,5,2)]) +#$(info int_div(123,7): [$(call int_div,123,7)]) +#$(info int_div(100,7): [$(call int_div,100,7)]) +# negative numbers +#$(info int_div(-5,1): [$(call int_div,-5,1)]) +#$(info int_div(5,-2): [$(call int_div,5,-2)]) +#$(info int_div(-123,-7): [$(call int_div,-123,-7)]) + + +### combination tests + +# (/ (- (+ 515 (* 222 311)) 300) 41) = 1689 +#$(info int_mult,222,311: [$(call int_mult,222,311)]) +#$(info int_add(515,69042): [$(call int_add,515,69042)]) +#$(info int_sub(69557,300): [$(call int_sub,69557,300)]) +#$(info int_div(69257,41): [$(call int_div,69257,41)]) +# (/ (- (+ 515 (* -222 311)) 300) 41) = -1678 +#$(info int_mult,-222,311: [$(call int_mult,-222,311)]) +#$(info int_add(515,-69042): [$(call int_add,515,-69042)]) +#$(info int_sub(-68527,300): [$(call int_sub,-68527,300)]) +#$(info int_div(-68827,41): [$(call int_div,-68827,41)]) + +############################################################### + +all: + @true + +endif + +# vim: ts=2 et diff --git a/impls/make/printer.mk b/impls/make/printer.mk index dda5ee63b0..d0f617e3e7 100644 --- a/impls/make/printer.mk +++ b/impls/make/printer.mk @@ -1,47 +1,47 @@ -# -# mal (Make a Lisp) printer -# - -ifndef __mal_printer_included -__mal_printer_included := true - -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)util.mk -include $(_TOP_DIR)types.mk - -# return a printable form of the argument, the second parameter is -# 'print_readably' which backslashes quotes in string values -_pr_str = $(if $(1),$(foreach ot,$(call _obj_type,$(1)),$(if $(call _EQ,make,$(ot)),$(call _error,_pr_str failed on $(1)),$(call $(ot)_pr_str,$(1),$(2)))),) - -# Like _pr_str but takes multiple values in first argument, the second -# parameter is 'print_readably' which backslashes quotes in string -# values, the third parameter is the delimeter to use between each -# _pr_str'd value -_pr_str_mult = $(call _pr_str,$(word 1,$(1)),$(2))$(if $(word 2,$(1)),$(3)$(call _pr_str_mult,$(wordlist 2,$(words $(1)),$(1)),$(2),$(3)),) - - -# Type specific printing - -nil_pr_str = nil -true_pr_str = true -false_pr_str = false - -number_pr_str = $(call int_decode,$($(1)_value)) - -symbol_pr_str = $($(1)_value) - -keyword_pr_str = $(COLON)$(patsubst $(__keyword)%,%,$(call str_decode,$($(1)_value))) - -string_pr_str = $(if $(filter $(__keyword)%,$(call str_decode,$($(1)_value))),$(COLON)$(patsubst $(__keyword)%,%,$(call str_decode,$($(1)_value))),$(if $(2),"$(subst $(NEWLINE),$(ESC_N),$(subst $(DQUOTE),$(ESC_DQUOTE),$(subst $(SLASH),$(SLASH)$(SLASH),$(call str_decode,$($(1)_value)))))",$(call str_decode,$($(1)_value)))) - -function_pr_str = <$(if $(word 6,$(value $(1)_value)),$(wordlist 1,5,$(value $(1)_value))...,$(value $(1)_value))> - -list_pr_str = ($(foreach v,$(call __get_obj_values,$(1)),$(call _pr_str,$(v),$(2)))) - -vector_pr_str = [$(foreach v,$(call __get_obj_values,$(1)),$(call _pr_str,$(v),$(2)))] - -hash_map_pr_str = {$(foreach v,$(call __get_obj_values,$(1)),$(foreach vval,$(foreach hcode,$(word 3,$(subst _, ,$(1))),$(patsubst $(1)_%,%,$(v:%_value=%))),$(if $(filter $(__keyword)%,$(vval)),$(patsubst $(__keyword)%,$(COLON)%,$(vval)),"$(vval)")) $(call _pr_str,$($(v)),$(2)))} - -atom_pr_str = (atom $(call _pr_str,$($(1)_value),$(2))) - -endif +# +# mal (Make a Lisp) printer +# + +ifndef __mal_printer_included +__mal_printer_included := true + +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)util.mk +include $(_TOP_DIR)types.mk + +# return a printable form of the argument, the second parameter is +# 'print_readably' which backslashes quotes in string values +_pr_str = $(if $(1),$(foreach ot,$(call _obj_type,$(1)),$(if $(call _EQ,make,$(ot)),$(call _error,_pr_str failed on $(1)),$(call $(ot)_pr_str,$(1),$(2)))),) + +# Like _pr_str but takes multiple values in first argument, the second +# parameter is 'print_readably' which backslashes quotes in string +# values, the third parameter is the delimeter to use between each +# _pr_str'd value +_pr_str_mult = $(call _pr_str,$(word 1,$(1)),$(2))$(if $(word 2,$(1)),$(3)$(call _pr_str_mult,$(wordlist 2,$(words $(1)),$(1)),$(2),$(3)),) + + +# Type specific printing + +nil_pr_str = nil +true_pr_str = true +false_pr_str = false + +number_pr_str = $(call int_decode,$($(1)_value)) + +symbol_pr_str = $($(1)_value) + +keyword_pr_str = $(COLON)$(patsubst $(__keyword)%,%,$(call str_decode,$($(1)_value))) + +string_pr_str = $(if $(filter $(__keyword)%,$(call str_decode,$($(1)_value))),$(COLON)$(patsubst $(__keyword)%,%,$(call str_decode,$($(1)_value))),$(if $(2),"$(subst $(NEWLINE),$(ESC_N),$(subst $(DQUOTE),$(ESC_DQUOTE),$(subst $(SLASH),$(SLASH)$(SLASH),$(call str_decode,$($(1)_value)))))",$(call str_decode,$($(1)_value)))) + +function_pr_str = <$(if $(word 6,$(value $(1)_value)),$(wordlist 1,5,$(value $(1)_value))...,$(value $(1)_value))> + +list_pr_str = ($(foreach v,$(call __get_obj_values,$(1)),$(call _pr_str,$(v),$(2)))) + +vector_pr_str = [$(foreach v,$(call __get_obj_values,$(1)),$(call _pr_str,$(v),$(2)))] + +hash_map_pr_str = {$(foreach v,$(call __get_obj_values,$(1)),$(foreach vval,$(foreach hcode,$(word 3,$(subst _, ,$(1))),$(patsubst $(1)_%,%,$(v:%_value=%))),$(if $(filter $(__keyword)%,$(vval)),$(patsubst $(__keyword)%,$(COLON)%,$(vval)),"$(vval)")) $(call _pr_str,$($(v)),$(2)))} + +atom_pr_str = (atom $(call _pr_str,$($(1)_value),$(2))) + +endif diff --git a/impls/make/reader.mk b/impls/make/reader.mk index 2dc0f53203..3dbafb1dd2 100755 --- a/impls/make/reader.mk +++ b/impls/make/reader.mk @@ -1,201 +1,201 @@ -# -# mal (Make Lisp) Parser/Reader -# - -ifndef __mal_reader_included -__mal_reader_included := true - -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)util.mk -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)readline.mk - -READER_DEBUG ?= - -_TOKEN_DELIMS := $(SEMI) $(COMMA) $(DQUOTE) $(QQUOTE) $(_SP) $(_NL) $(_LC) $(_RC) $(_LP) $(_RP) $(LBRACKET) $(RBRACKET) - -define READ_NUMBER -$(foreach ch,$(word 1,$($(1))),\ - $(if $(ch),\ - $(if $(filter $(_TOKEN_DELIMS),$(ch)),\ - ,\ - $(if $(filter-out $(MINUS) $(NUMBERS),$(ch)),\ - $(call _error,Invalid number character '$(ch)'),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(and $(READER_DEBUG),$(info READ_NUMBER ch: $(ch) | $($(1))))\ - $(ch)$(strip $(call READ_NUMBER,$(1))))),\ - )) -endef - -# $(_NL) is used here instead of $(NEWLINE) because $(strip) removes -# $(NEWLINE). str_encode will just pass through $(_NL) so str_decode -# later will restore a correct newline -define READ_STRING -$(foreach ch,$(word 1,$($(1))),\ - $(if $(ch),\ - $(if $(and $(filter \,$(ch)),$(filter $(DQUOTE),$(word 2,$($(1))))),\ - $(eval $(1) := $(wordlist 3,$(words $($(1))),$($(1))))\ - $(and $(READER_DEBUG),$(info READ_STRING ch: \$(word 1,$($(1))) | $($(1))))\ - $(DQUOTE) $(strip $(call READ_STRING,$(1))),\ - $(if $(and $(filter \,$(ch)),$(filter n,$(word 2,$($(1))))),\ - $(eval $(1) := $(wordlist 3,$(words $($(1))),$($(1))))\ - $(and $(READER_DEBUG),$(info READ_STRING ch: \$(word 1,$($(1))) | $($(1))))\ - $(_NL) $(strip $(call READ_STRING,$(1))),\ - $(if $(and $(filter \,$(ch)),$(filter \,$(word 2,$($(1))))),\ - $(eval $(1) := $(wordlist 3,$(words $($(1))),$($(1))))\ - $(and $(READER_DEBUG),$(info READ_STRING ch: \$(word 1,$($(1))) | $($(1))))\ - \ $(strip $(call READ_STRING,$(1))),\ - $(if $(filter $(DQUOTE),$(ch)),\ - ,\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(and $(READER_DEBUG),$(info READ_STRING ch: $(ch) | $($(1))))\ - $(ch) $(strip $(call READ_STRING,$(1))))))),)) -endef - -define READ_SYMBOL -$(foreach ch,$(word 1,$($(1))),\ - $(if $(ch),\ - $(if $(filter $(_TOKEN_DELIMS),$(ch)),\ - ,\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(and $(READER_DEBUG),$(info READ_SYMBOL ch: $(ch) | $($(1))))\ - $(ch)$(strip $(call READ_SYMBOL,$(1)))),\ - )) -endef - -define READ_KEYWORD -$(foreach ch,$(word 1,$($(1))),\ - $(if $(ch),\ - $(if $(filter $(_TOKEN_DELIMS),$(ch)),\ - ,\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(and $(READER_DEBUG),$(info READ_KEYWORD ch: $(ch) | $($(1))))\ - $(ch)$(strip $(call READ_KEYWORD,$(1)))),\ - )) -endef - -define READ_ATOM -$(and $(READER_DEBUG),$(info READ_ATOM: $($(1)))) -$(foreach ch,$(word 1,$($(1))),\ - $(if $(and $(filter $(MINUS),$(ch)),$(filter $(NUMBERS),$(word 2,$($(1))))),\ - $(call _number,$(call READ_NUMBER,$(1))),\ - $(if $(filter $(NUMBERS),$(ch)),\ - $(call _number,$(call READ_NUMBER,$(1))),\ - $(if $(filter $(DQUOTE),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call __string,$(strip $(call READ_STRING,$(1))))\ - $(eval $(if $(filter $(DQUOTE),$(word 1,$($(1)))),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ - $(call _error,Expected '$(DQUOTE)' in; $($(1))$(COMMA) got EOF))),\ - $(if $(filter $(COLON),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call _keyword,$(call READ_KEYWORD,$(1))),\ - $(foreach sym,$(call READ_SYMBOL,$(1)),\ - $(if $(call _EQ,nil,$(sym)),\ - $(__nil),\ - $(if $(call _EQ,true,$(sym)),\ - $(__true),\ - $(if $(call _EQ,false,$(sym)),\ - $(__false),\ - $(call _symbol,$(sym))))))))))) -endef - -# read and return tokens until $(2) found -define READ_UNTIL -$(and $(READER_DEBUG),$(info READ_UNTIL: $($(1)) [$(2) $(3)])) -$(foreach ch,$(word 1,$($(1))),\ - $(if $(ch),\ - $(if $(filter $(2),$(ch)),\ - ,\ - $(call READ_FORM,$(1))\ - $(call READ_UNTIL,$(1),$(2),$(3))),\ - $(call _error,Expected '$(3)'$(COMMA) got EOF))) -endef - -define DROP_UNTIL -$(and $(READER_DEBUG),$(info DROP_UNTIL: $($(1)) [$(2)])) -$(foreach ch,$(word 1,$($(1))),\ - $(if $(ch),\ - $(if $(filter $(2),$(ch)),\ - ,\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call DROP_UNTIL,$(1),$(2),$(3))),\ - )) -endef - -define READ_SPACES -$(and $(READER_DEBUG),$(info READ_SPACES: $($(1)))) -$(foreach ch,$(word 1,$($(1))),\ - $(if $(filter $(_SP) $(_NL) $(COMMA),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call READ_SPACES,$(1)),)) -endef - -define READ_FORM -$(and $(READER_DEBUG),$(info READ_FORM: $($(1)))) -$(call READ_SPACES,$(1)) -$(foreach ch,$(word 1,$($(1))),\ - $(if $(filter $(SEMI),$(ch)),\ - $(call DROP_UNTIL,$(1),$(_NL)),\ - $(if $(filter $(SQUOTE),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call _list,$(call _symbol,quote) $(strip $(call READ_FORM,$(1)))),\ - $(if $(filter $(QQUOTE),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call _list,$(call _symbol,quasiquote) $(strip $(call READ_FORM,$(1)))),\ - $(if $(filter $(UNQUOTE),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call _list,$(call _symbol,unquote) $(strip $(call READ_FORM,$(1)))),\ - $(if $(filter $(_SUQ),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call _list,$(call _symbol,splice-unquote) $(strip $(call READ_FORM,$(1)))),\ - $(if $(filter $(CARET),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(foreach meta,$(strip $(call READ_FORM,$(1))),\ - $(call _list,$(call _symbol,with-meta) $(strip $(call READ_FORM,$(1))) $(meta))),\ - $(if $(filter $(ATSIGN),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call _list,$(call _symbol,deref) $(strip $(call READ_FORM,$(1)))),\ - $(if $(filter $(_RC),$(ch)),\ - $(call _error,Unexpected '$(RCURLY)'),\ - $(if $(filter $(_LC),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call READ_SPACES,$(1))\ - $(foreach thm,$(call _hash_map),\ - $(call do,$(call _assoc_seq!,$(thm),$(strip $(call READ_UNTIL,$(1),$(_RC),$(RCURLY)))))\ - $(eval $(if $(filter $(_RC),$(word 1,$($(1)))),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ - $(call _error,Expected '$(RCURLY)'$(COMMA) got EOF)))\ - $(thm)),\ - $(if $(filter $(_RP),$(ch)),\ - $(call _error,Unexpected '$(RPAREN)'),\ - $(if $(filter $(_LP),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call READ_SPACES,$(1))\ - $(foreach tlist,$(call _list),\ - $(eval $(foreach item,$(strip $(call READ_UNTIL,$(1),$(_RP),$(RPAREN))),\ - $(call do,$(call _conj!,$(tlist),$(item)))))\ - $(eval $(if $(filter $(_RP),$(word 1,$($(1)))),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ - $(call _error,Expected '$(RPAREN)'$(COMMA) got EOF)))\ - $(tlist)),\ - $(if $(filter $(RBRACKET),$(ch)),\ - $(call _error,Unexpected '$(RBRACKET)'),\ - $(if $(filter $(LBRACKET),$(ch)),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ - $(call READ_SPACES,$(1))\ - $(foreach tvec,$(call _vector),\ - $(eval $(foreach item,$(strip $(call READ_UNTIL,$(1),$(RBRACKET),$(RBRACKET))),\ - $(call do,$(call _conj!,$(tvec),$(item)))))\ - $(eval $(if $(filter $(RBRACKET),$(word 1,$($(1)))),\ - $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ - $(call _error,Expected '$(RBRACKET)'$(COMMA) got EOF)))\ - $(tvec)),\ - $(call READ_ATOM,$(1)))))))))))))))) -$(call READ_SPACES,$(1)) -endef - -# read-str from a raw "string" or from a string object -READ_STR = $(strip $(eval __reader_temp := $(call str_encode,$(if $(call _string?,$(1)),$(call str_decode,$($(1)_value)),$(1))))$(call READ_FORM,__reader_temp)) - -endif +# +# mal (Make Lisp) Parser/Reader +# + +ifndef __mal_reader_included +__mal_reader_included := true + +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)util.mk +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)readline.mk + +READER_DEBUG ?= + +_TOKEN_DELIMS := $(SEMI) $(COMMA) $(DQUOTE) $(QQUOTE) $(_SP) $(_NL) $(_LC) $(_RC) $(_LP) $(_RP) $(LBRACKET) $(RBRACKET) + +define READ_NUMBER +$(foreach ch,$(word 1,$($(1))),\ + $(if $(ch),\ + $(if $(filter $(_TOKEN_DELIMS),$(ch)),\ + ,\ + $(if $(filter-out $(MINUS) $(NUMBERS),$(ch)),\ + $(call _error,Invalid number character '$(ch)'),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(and $(READER_DEBUG),$(info READ_NUMBER ch: $(ch) | $($(1))))\ + $(ch)$(strip $(call READ_NUMBER,$(1))))),\ + )) +endef + +# $(_NL) is used here instead of $(NEWLINE) because $(strip) removes +# $(NEWLINE). str_encode will just pass through $(_NL) so str_decode +# later will restore a correct newline +define READ_STRING +$(foreach ch,$(word 1,$($(1))),\ + $(if $(ch),\ + $(if $(and $(filter \,$(ch)),$(filter $(DQUOTE),$(word 2,$($(1))))),\ + $(eval $(1) := $(wordlist 3,$(words $($(1))),$($(1))))\ + $(and $(READER_DEBUG),$(info READ_STRING ch: \$(word 1,$($(1))) | $($(1))))\ + $(DQUOTE) $(strip $(call READ_STRING,$(1))),\ + $(if $(and $(filter \,$(ch)),$(filter n,$(word 2,$($(1))))),\ + $(eval $(1) := $(wordlist 3,$(words $($(1))),$($(1))))\ + $(and $(READER_DEBUG),$(info READ_STRING ch: \$(word 1,$($(1))) | $($(1))))\ + $(_NL) $(strip $(call READ_STRING,$(1))),\ + $(if $(and $(filter \,$(ch)),$(filter \,$(word 2,$($(1))))),\ + $(eval $(1) := $(wordlist 3,$(words $($(1))),$($(1))))\ + $(and $(READER_DEBUG),$(info READ_STRING ch: \$(word 1,$($(1))) | $($(1))))\ + \ $(strip $(call READ_STRING,$(1))),\ + $(if $(filter $(DQUOTE),$(ch)),\ + ,\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(and $(READER_DEBUG),$(info READ_STRING ch: $(ch) | $($(1))))\ + $(ch) $(strip $(call READ_STRING,$(1))))))),)) +endef + +define READ_SYMBOL +$(foreach ch,$(word 1,$($(1))),\ + $(if $(ch),\ + $(if $(filter $(_TOKEN_DELIMS),$(ch)),\ + ,\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(and $(READER_DEBUG),$(info READ_SYMBOL ch: $(ch) | $($(1))))\ + $(ch)$(strip $(call READ_SYMBOL,$(1)))),\ + )) +endef + +define READ_KEYWORD +$(foreach ch,$(word 1,$($(1))),\ + $(if $(ch),\ + $(if $(filter $(_TOKEN_DELIMS),$(ch)),\ + ,\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(and $(READER_DEBUG),$(info READ_KEYWORD ch: $(ch) | $($(1))))\ + $(ch)$(strip $(call READ_KEYWORD,$(1)))),\ + )) +endef + +define READ_ATOM +$(and $(READER_DEBUG),$(info READ_ATOM: $($(1)))) +$(foreach ch,$(word 1,$($(1))),\ + $(if $(and $(filter $(MINUS),$(ch)),$(filter $(NUMBERS),$(word 2,$($(1))))),\ + $(call _number,$(call READ_NUMBER,$(1))),\ + $(if $(filter $(NUMBERS),$(ch)),\ + $(call _number,$(call READ_NUMBER,$(1))),\ + $(if $(filter $(DQUOTE),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call __string,$(strip $(call READ_STRING,$(1))))\ + $(eval $(if $(filter $(DQUOTE),$(word 1,$($(1)))),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ + $(call _error,Expected '$(DQUOTE)' in; $($(1))$(COMMA) got EOF))),\ + $(if $(filter $(COLON),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call _keyword,$(call READ_KEYWORD,$(1))),\ + $(foreach sym,$(call READ_SYMBOL,$(1)),\ + $(if $(call _EQ,nil,$(sym)),\ + $(__nil),\ + $(if $(call _EQ,true,$(sym)),\ + $(__true),\ + $(if $(call _EQ,false,$(sym)),\ + $(__false),\ + $(call _symbol,$(sym))))))))))) +endef + +# read and return tokens until $(2) found +define READ_UNTIL +$(and $(READER_DEBUG),$(info READ_UNTIL: $($(1)) [$(2) $(3)])) +$(foreach ch,$(word 1,$($(1))),\ + $(if $(ch),\ + $(if $(filter $(2),$(ch)),\ + ,\ + $(call READ_FORM,$(1))\ + $(call READ_UNTIL,$(1),$(2),$(3))),\ + $(call _error,Expected '$(3)'$(COMMA) got EOF))) +endef + +define DROP_UNTIL +$(and $(READER_DEBUG),$(info DROP_UNTIL: $($(1)) [$(2)])) +$(foreach ch,$(word 1,$($(1))),\ + $(if $(ch),\ + $(if $(filter $(2),$(ch)),\ + ,\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call DROP_UNTIL,$(1),$(2),$(3))),\ + )) +endef + +define READ_SPACES +$(and $(READER_DEBUG),$(info READ_SPACES: $($(1)))) +$(foreach ch,$(word 1,$($(1))),\ + $(if $(filter $(_SP) $(_NL) $(COMMA),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call READ_SPACES,$(1)),)) +endef + +define READ_FORM +$(and $(READER_DEBUG),$(info READ_FORM: $($(1)))) +$(call READ_SPACES,$(1)) +$(foreach ch,$(word 1,$($(1))),\ + $(if $(filter $(SEMI),$(ch)),\ + $(call DROP_UNTIL,$(1),$(_NL)),\ + $(if $(filter $(SQUOTE),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call _list,$(call _symbol,quote) $(strip $(call READ_FORM,$(1)))),\ + $(if $(filter $(QQUOTE),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call _list,$(call _symbol,quasiquote) $(strip $(call READ_FORM,$(1)))),\ + $(if $(filter $(UNQUOTE),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call _list,$(call _symbol,unquote) $(strip $(call READ_FORM,$(1)))),\ + $(if $(filter $(_SUQ),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call _list,$(call _symbol,splice-unquote) $(strip $(call READ_FORM,$(1)))),\ + $(if $(filter $(CARET),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(foreach meta,$(strip $(call READ_FORM,$(1))),\ + $(call _list,$(call _symbol,with-meta) $(strip $(call READ_FORM,$(1))) $(meta))),\ + $(if $(filter $(ATSIGN),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call _list,$(call _symbol,deref) $(strip $(call READ_FORM,$(1)))),\ + $(if $(filter $(_RC),$(ch)),\ + $(call _error,Unexpected '$(RCURLY)'),\ + $(if $(filter $(_LC),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call READ_SPACES,$(1))\ + $(foreach thm,$(call _hash_map),\ + $(call do,$(call _assoc_seq!,$(thm),$(strip $(call READ_UNTIL,$(1),$(_RC),$(RCURLY)))))\ + $(eval $(if $(filter $(_RC),$(word 1,$($(1)))),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ + $(call _error,Expected '$(RCURLY)'$(COMMA) got EOF)))\ + $(thm)),\ + $(if $(filter $(_RP),$(ch)),\ + $(call _error,Unexpected '$(RPAREN)'),\ + $(if $(filter $(_LP),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call READ_SPACES,$(1))\ + $(foreach tlist,$(call _list),\ + $(eval $(foreach item,$(strip $(call READ_UNTIL,$(1),$(_RP),$(RPAREN))),\ + $(call do,$(call _conj!,$(tlist),$(item)))))\ + $(eval $(if $(filter $(_RP),$(word 1,$($(1)))),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ + $(call _error,Expected '$(RPAREN)'$(COMMA) got EOF)))\ + $(tlist)),\ + $(if $(filter $(RBRACKET),$(ch)),\ + $(call _error,Unexpected '$(RBRACKET)'),\ + $(if $(filter $(LBRACKET),$(ch)),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1))))\ + $(call READ_SPACES,$(1))\ + $(foreach tvec,$(call _vector),\ + $(eval $(foreach item,$(strip $(call READ_UNTIL,$(1),$(RBRACKET),$(RBRACKET))),\ + $(call do,$(call _conj!,$(tvec),$(item)))))\ + $(eval $(if $(filter $(RBRACKET),$(word 1,$($(1)))),\ + $(eval $(1) := $(wordlist 2,$(words $($(1))),$($(1)))),\ + $(call _error,Expected '$(RBRACKET)'$(COMMA) got EOF)))\ + $(tvec)),\ + $(call READ_ATOM,$(1)))))))))))))))) +$(call READ_SPACES,$(1)) +endef + +# read-str from a raw "string" or from a string object +READ_STR = $(strip $(eval __reader_temp := $(call str_encode,$(if $(call _string?,$(1)),$(call str_decode,$($(1)_value)),$(1))))$(call READ_FORM,__reader_temp)) + +endif diff --git a/impls/make/readline.mk b/impls/make/readline.mk index 39918c52ad..a7a5620dd4 100644 --- a/impls/make/readline.mk +++ b/impls/make/readline.mk @@ -1,23 +1,23 @@ -# -# mal (Make Lisp) shell readline wrapper -# - -ifndef __mal_readline_included -__mal_readline_included := true - -# Call bash read/readline. Since each call is in a separate shell -# instance we need to restore and save after each call in order to -# have readline history. -READLINE_EOF := -READLINE_HISTORY_FILE := $${HOME}/.mal-history -READLINE = $(eval __readline_temp := $(shell \ - history -r $(READLINE_HISTORY_FILE); \ - read -u 0 -r -e -p $(if $(1),$(1),"user> ") line && \ - history -s -- "$${line}" && \ - echo "$${line}" || \ - echo "__||EOF||__"; \ - history -a $(READLINE_HISTORY_FILE) 2>/dev/null || \ - true \ -))$(if $(filter __||EOF||__,$(__readline_temp)),$(eval READLINE_EOF := yes),$(__readline_temp)) - -endif +# +# mal (Make Lisp) shell readline wrapper +# + +ifndef __mal_readline_included +__mal_readline_included := true + +# Call bash read/readline. Since each call is in a separate shell +# instance we need to restore and save after each call in order to +# have readline history. +READLINE_EOF := +READLINE_HISTORY_FILE := $${HOME}/.mal-history +READLINE = $(eval __readline_temp := $(shell \ + history -r $(READLINE_HISTORY_FILE); \ + read -u 0 -r -e -p $(if $(1),$(1),"user> ") line && \ + history -s -- "$${line}" && \ + echo "$${line}" || \ + echo "__||EOF||__"; \ + history -a $(READLINE_HISTORY_FILE) 2>/dev/null || \ + true \ +))$(if $(filter __||EOF||__,$(__readline_temp)),$(eval READLINE_EOF := yes),$(__readline_temp)) + +endif diff --git a/impls/make/rules.mk b/impls/make/rules.mk index a73dba5d41..e41cc6e29d 100644 --- a/impls/make/rules.mk +++ b/impls/make/rules.mk @@ -1,34 +1,34 @@ -# To load this file: -# $(eval include rules.mk) - -# Usage: -# (make* "$(eval $(call PRINT_RULE,abc,,@echo \"building $$@\"))") -define PRINT_RULE -$(1): $(2) - $(3) -endef - -# Usage: -# (make* "$(eval $(call PRINT_LINES,abc:, @echo \"shell command\"))") -define PRINT_LINES -$(1) -$(2) -$(3) -$(4) -$(5) -$(6) -$(7) -$(8) -$(9) -$(10) -$(11) -$(12) -$(13) -$(14) -$(15) -$(16) -$(17) -$(18) -$(19) -$(20) -endef +# To load this file: +# $(eval include rules.mk) + +# Usage: +# (make* "$(eval $(call PRINT_RULE,abc,,@echo \"building $$@\"))") +define PRINT_RULE +$(1): $(2) + $(3) +endef + +# Usage: +# (make* "$(eval $(call PRINT_LINES,abc:, @echo \"shell command\"))") +define PRINT_LINES +$(1) +$(2) +$(3) +$(4) +$(5) +$(6) +$(7) +$(8) +$(9) +$(10) +$(11) +$(12) +$(13) +$(14) +$(15) +$(16) +$(17) +$(18) +$(19) +$(20) +endef diff --git a/impls/make/run b/impls/make/run index f897b62de8..8c761f7cde 100755 --- a/impls/make/run +++ b/impls/make/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec make --no-print-directory -f $(dirname $0)/${STEP:-stepA_mal}.mk "${@}" +#!/bin/bash +exec make --no-print-directory -f $(dirname $0)/${STEP:-stepA_mal}.mk "${@}" diff --git a/impls/make/step0_repl.mk b/impls/make/step0_repl.mk index 46b4756ae7..e63ef22704 100644 --- a/impls/make/step0_repl.mk +++ b/impls/make/step0_repl.mk @@ -1,25 +1,25 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)readline.mk - -SHELL := /bin/bash - -define READ -$(call READLINE) -endef - -define EVAL -$(if $(READLINE_EOF),,$(1)) -endef - -define PRINT -$(1) -endef - -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ))))) -REPL = $(info $(call REP))$(if $(READLINE_EOF),,$(call REPL)) - -# Call the read-eval-print loop -$(call REPL) +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)readline.mk + +SHELL := /bin/bash + +define READ +$(call READLINE) +endef + +define EVAL +$(if $(READLINE_EOF),,$(1)) +endef + +define PRINT +$(1) +endef + +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ))))) +REPL = $(info $(call REP))$(if $(READLINE_EOF),,$(call REPL)) + +# Call the read-eval-print loop +$(call REPL) diff --git a/impls/make/step1_read_print.mk b/impls/make/step1_read_print.mk index f695a7e174..313ba8ad8f 100644 --- a/impls/make/step1_read_print.mk +++ b/impls/make/step1_read_print.mk @@ -1,32 +1,32 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk - -SHELL := /bin/bash -INTERACTIVE ?= yes - -# READ: read and parse input -define READ -$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) -endef - -# EVAL: just return the input -define EVAL -$(if $(READLINE_EOF)$(__ERROR),,$(1)) -endef - -# PRINT: -define PRINT -$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) -endef - -# REPL: read, eval, print, loop -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) -REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) - -# repl loop -$(if $(strip $(INTERACTIVE)),$(call REPL)) +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk + +SHELL := /bin/bash +INTERACTIVE ?= yes + +# READ: read and parse input +define READ +$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) +endef + +# EVAL: just return the input +define EVAL +$(if $(READLINE_EOF)$(__ERROR),,$(1)) +endef + +# PRINT: +define PRINT +$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) +endef + +# REPL: read, eval, print, loop +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) +REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) + +# repl loop +$(if $(strip $(INTERACTIVE)),$(call REPL)) diff --git a/impls/make/step2_eval.mk b/impls/make/step2_eval.mk index 0fed27c7d3..c730686183 100644 --- a/impls/make/step2_eval.mk +++ b/impls/make/step2_eval.mk @@ -1,75 +1,75 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk -include $(_TOP_DIR)core.mk - -SHELL := /bin/bash -INTERACTIVE ?= yes -EVAL_DEBUG ?= - -# READ: read and parse input -define READ -$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) -endef - -# EVAL: evaluate the parameter -define EVAL_AST -$(strip \ - $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ - $(if $(call _symbol?,$(1)),\ - $(foreach key,$($(1)_value),\ - $(if $(call _contains?,$(2),$(key)),\ - $(call _get,$(2),$(key)),\ - $(call _error,'$(key)' not found in REPL_ENV ($(2))))),\ - $(if $(call _list?,$(1)),\ - $(call _smap,EVAL,$(1),$(2)),\ - $(if $(call _vector?,$(1)),\ - $(call _smap_vec,EVAL,$(1),$(2)),\ - $(if $(call _hash_map?,$(1)),\ - $(foreach new_hmap,$(call __new_obj,hmap),\ - $(foreach v,$(call __get_obj_values,$(1)),\ - $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ - $(eval $(new_hmap)_size := $($(1)_size))\ - $(new_hmap)),\ - $(1)))))) -endef - -define EVAL_INVOKE -$(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1))))\ - $(foreach el,$(call EVAL_AST,$(1),$(2)),\ - $(call _apply,$(call sfirst,$(el)),$(call srest,$(el))))) -endef - -define EVAL -$(strip $(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ - $(if $(call _list?,$(1)),\ - $(if $(call _EQ,0,$(call _count,$(1))),\ - $(1),\ - $(strip $(call EVAL_INVOKE,$(1),$(2)))),\ - $(call EVAL_AST,$(1),$(2))))) -endef - - -# PRINT: -define PRINT -$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) -endef - -# REPL: -REPL_ENV := $(call _hash_map) -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) -REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) - -$(call do,$(call _assoc!,$(REPL_ENV),+,number_plus)) -$(call do,$(call _assoc!,$(REPL_ENV),-,number_subtract)) -$(call do,$(call _assoc!,$(REPL_ENV),*,number_multiply)) -$(call do,$(call _assoc!,$(REPL_ENV),/,number_divide)) - -# repl loop -$(if $(strip $(INTERACTIVE)),$(call REPL)) +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk +include $(_TOP_DIR)core.mk + +SHELL := /bin/bash +INTERACTIVE ?= yes +EVAL_DEBUG ?= + +# READ: read and parse input +define READ +$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) +endef + +# EVAL: evaluate the parameter +define EVAL_AST +$(strip \ + $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ + $(if $(call _symbol?,$(1)),\ + $(foreach key,$($(1)_value),\ + $(if $(call _contains?,$(2),$(key)),\ + $(call _get,$(2),$(key)),\ + $(call _error,'$(key)' not found in REPL_ENV ($(2))))),\ + $(if $(call _list?,$(1)),\ + $(call _smap,EVAL,$(1),$(2)),\ + $(if $(call _vector?,$(1)),\ + $(call _smap_vec,EVAL,$(1),$(2)),\ + $(if $(call _hash_map?,$(1)),\ + $(foreach new_hmap,$(call __new_obj,hmap),\ + $(foreach v,$(call __get_obj_values,$(1)),\ + $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ + $(eval $(new_hmap)_size := $($(1)_size))\ + $(new_hmap)),\ + $(1)))))) +endef + +define EVAL_INVOKE +$(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1))))\ + $(foreach el,$(call EVAL_AST,$(1),$(2)),\ + $(call _apply,$(call sfirst,$(el)),$(call srest,$(el))))) +endef + +define EVAL +$(strip $(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ + $(if $(call _list?,$(1)),\ + $(if $(call _EQ,0,$(call _count,$(1))),\ + $(1),\ + $(strip $(call EVAL_INVOKE,$(1),$(2)))),\ + $(call EVAL_AST,$(1),$(2))))) +endef + + +# PRINT: +define PRINT +$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) +endef + +# REPL: +REPL_ENV := $(call _hash_map) +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) +REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) + +$(call do,$(call _assoc!,$(REPL_ENV),+,number_plus)) +$(call do,$(call _assoc!,$(REPL_ENV),-,number_subtract)) +$(call do,$(call _assoc!,$(REPL_ENV),*,number_multiply)) +$(call do,$(call _assoc!,$(REPL_ENV),/,number_divide)) + +# repl loop +$(if $(strip $(INTERACTIVE)),$(call REPL)) diff --git a/impls/make/step3_env.mk b/impls/make/step3_env.mk index 810e296501..9c4fdf268c 100644 --- a/impls/make/step3_env.mk +++ b/impls/make/step3_env.mk @@ -1,98 +1,98 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk -include $(_TOP_DIR)env.mk -include $(_TOP_DIR)core.mk - -SHELL := /bin/bash -INTERACTIVE ?= yes -EVAL_DEBUG ?= - -# READ: read and parse input -define READ -$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) -endef - -# EVAL: evaluate the parameter -define LET -$(strip \ - $(word 1,$(2) \ - $(foreach var,$(call _nth,$(1),0),\ - $(foreach val,$(call _nth,$(1),1),\ - $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ - $(foreach left,$(call srest,$(call srest,$(1))), - $(if $(call _EQ,0,$(call _count,$(left))),\ - ,\ - $(call LET,$(left),$(2)))))))) -endef - -define EVAL_AST -$(strip \ - $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ - $(if $(call _symbol?,$(1)),\ - $(foreach key,$($(1)_value),\ - $(call ENV_GET,$(2),$(key))),\ - $(if $(call _list?,$(1)),\ - $(call _smap,EVAL,$(1),$(2)),\ - $(if $(call _vector?,$(1)),\ - $(call _smap_vec,EVAL,$(1),$(2)),\ - $(if $(call _hash_map?,$(1)),\ - $(foreach new_hmap,$(call __new_obj,hmap),\ - $(foreach v,$(call __get_obj_values,$(1)),\ - $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ - $(eval $(new_hmap)_size := $($(1)_size))\ - $(new_hmap)),\ - $(1)))))) -endef - -define EVAL_INVOKE -$(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) - $(foreach a0,$(call _nth,$(1),0),\ - $(if $(call _EQ,def!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(__ERROR),,\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ - $(if $(call _EQ,let*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ - $(foreach el,$(call EVAL_AST,$(1),$(2)),\ - $(call _apply,$(call sfirst,$(el)),$(call srest,$(el)))))))) -endef - -define EVAL -$(strip $(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ - $(if $(call _list?,$(1)),\ - $(if $(call _EQ,0,$(call _count,$(1))),\ - $(1),\ - $(strip $(call EVAL_INVOKE,$(1),$(2)))),\ - $(call EVAL_AST,$(1),$(2))))) -endef - - -# PRINT: -define PRINT -$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) -endef - -# REPL: -REPL_ENV := $(call ENV) -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) -REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) - -# Setup the environment -REPL_ENV := $(call ENV_SET,$(REPL_ENV),+,number_plus) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),-,number_subtract) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),*,number_multiply) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),/,number_divide) - -# repl loop -$(if $(strip $(INTERACTIVE)),$(call REPL)) +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk +include $(_TOP_DIR)env.mk +include $(_TOP_DIR)core.mk + +SHELL := /bin/bash +INTERACTIVE ?= yes +EVAL_DEBUG ?= + +# READ: read and parse input +define READ +$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) +endef + +# EVAL: evaluate the parameter +define LET +$(strip \ + $(word 1,$(2) \ + $(foreach var,$(call _nth,$(1),0),\ + $(foreach val,$(call _nth,$(1),1),\ + $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ + $(foreach left,$(call srest,$(call srest,$(1))), + $(if $(call _EQ,0,$(call _count,$(left))),\ + ,\ + $(call LET,$(left),$(2)))))))) +endef + +define EVAL_AST +$(strip \ + $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ + $(if $(call _symbol?,$(1)),\ + $(foreach key,$($(1)_value),\ + $(call ENV_GET,$(2),$(key))),\ + $(if $(call _list?,$(1)),\ + $(call _smap,EVAL,$(1),$(2)),\ + $(if $(call _vector?,$(1)),\ + $(call _smap_vec,EVAL,$(1),$(2)),\ + $(if $(call _hash_map?,$(1)),\ + $(foreach new_hmap,$(call __new_obj,hmap),\ + $(foreach v,$(call __get_obj_values,$(1)),\ + $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ + $(eval $(new_hmap)_size := $($(1)_size))\ + $(new_hmap)),\ + $(1)))))) +endef + +define EVAL_INVOKE +$(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) + $(foreach a0,$(call _nth,$(1),0),\ + $(if $(call _EQ,def!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(if $(__ERROR),,\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ + $(if $(call _EQ,let*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ + $(foreach el,$(call EVAL_AST,$(1),$(2)),\ + $(call _apply,$(call sfirst,$(el)),$(call srest,$(el)))))))) +endef + +define EVAL +$(strip $(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ + $(if $(call _list?,$(1)),\ + $(if $(call _EQ,0,$(call _count,$(1))),\ + $(1),\ + $(strip $(call EVAL_INVOKE,$(1),$(2)))),\ + $(call EVAL_AST,$(1),$(2))))) +endef + + +# PRINT: +define PRINT +$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) +endef + +# REPL: +REPL_ENV := $(call ENV) +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) +REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) + +# Setup the environment +REPL_ENV := $(call ENV_SET,$(REPL_ENV),+,number_plus) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),-,number_subtract) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),*,number_multiply) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),/,number_divide) + +# repl loop +$(if $(strip $(INTERACTIVE)),$(call REPL)) diff --git a/impls/make/step4_if_fn_do.mk b/impls/make/step4_if_fn_do.mk index 0fa266d691..7d7e600966 100644 --- a/impls/make/step4_if_fn_do.mk +++ b/impls/make/step4_if_fn_do.mk @@ -1,116 +1,116 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk -include $(_TOP_DIR)env.mk -include $(_TOP_DIR)core.mk - -SHELL := /bin/bash -INTERACTIVE ?= yes -EVAL_DEBUG ?= - -# READ: read and parse input -define READ -$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) -endef - -# EVAL: evaluate the parameter -define LET -$(strip \ - $(word 1,$(2) \ - $(foreach var,$(call _nth,$(1),0),\ - $(foreach val,$(call _nth,$(1),1),\ - $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ - $(foreach left,$(call srest,$(call srest,$(1))), - $(if $(call _EQ,0,$(call _count,$(left))),\ - ,\ - $(call LET,$(left),$(2)))))))) -endef - -define EVAL_AST -$(strip \ - $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ - $(if $(call _symbol?,$(1)),\ - $(foreach key,$($(1)_value),\ - $(call ENV_GET,$(2),$(key))),\ - $(if $(call _list?,$(1)),\ - $(call _smap,EVAL,$(1),$(2)),\ - $(if $(call _vector?,$(1)),\ - $(call _smap_vec,EVAL,$(1),$(2)),\ - $(if $(call _hash_map?,$(1)),\ - $(foreach new_hmap,$(call __new_obj,hmap),\ - $(foreach v,$(call __get_obj_values,$(1)),\ - $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ - $(eval $(new_hmap)_size := $($(1)_size))\ - $(new_hmap)),\ - $(1)))))) -endef - -define EVAL_INVOKE -$(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) - $(foreach a0,$(call _nth,$(1),0),\ - $(if $(call _EQ,def!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(__ERROR),,\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ - $(if $(call _EQ,let*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ - $(if $(call _EQ,do,$($(a0)_value)),\ - $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ - $(if $(call _EQ,if,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach cond,$(call EVAL,$(a1),$(2)),\ - $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ - $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ - $(call EVAL,$(a2),$(2)))))),\ - $(if $(call _EQ,fn*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ - $(foreach el,$(call EVAL_AST,$(1),$(2)),\ - $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ - $(foreach f,$(call sfirst,$(el)),\ - $(foreach args,$(call srest,$(el)),\ - $(call apply,$(f),$(args)))))))))))) -endef - -define EVAL -$(strip $(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ - $(if $(call _list?,$(1)),\ - $(if $(call _EQ,0,$(call _count,$(1))),\ - $(1),\ - $(word 1,$(strip $(call EVAL_INVOKE,$(1),$(2)) $(__nil)))),\ - $(call EVAL_AST,$(1),$(2))))) -endef - - -# PRINT: -define PRINT -$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) -endef - -# REPL: -REPL_ENV := $(call ENV) -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) -REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) - -# core.mk: defined using Make -_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) -_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) -$(call _import_core,$(core_ns)) - -# core.mal: defined in terms of the language itself -$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) - -# repl loop -$(if $(strip $(INTERACTIVE)),$(call REPL)) +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk +include $(_TOP_DIR)env.mk +include $(_TOP_DIR)core.mk + +SHELL := /bin/bash +INTERACTIVE ?= yes +EVAL_DEBUG ?= + +# READ: read and parse input +define READ +$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) +endef + +# EVAL: evaluate the parameter +define LET +$(strip \ + $(word 1,$(2) \ + $(foreach var,$(call _nth,$(1),0),\ + $(foreach val,$(call _nth,$(1),1),\ + $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ + $(foreach left,$(call srest,$(call srest,$(1))), + $(if $(call _EQ,0,$(call _count,$(left))),\ + ,\ + $(call LET,$(left),$(2)))))))) +endef + +define EVAL_AST +$(strip \ + $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ + $(if $(call _symbol?,$(1)),\ + $(foreach key,$($(1)_value),\ + $(call ENV_GET,$(2),$(key))),\ + $(if $(call _list?,$(1)),\ + $(call _smap,EVAL,$(1),$(2)),\ + $(if $(call _vector?,$(1)),\ + $(call _smap_vec,EVAL,$(1),$(2)),\ + $(if $(call _hash_map?,$(1)),\ + $(foreach new_hmap,$(call __new_obj,hmap),\ + $(foreach v,$(call __get_obj_values,$(1)),\ + $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ + $(eval $(new_hmap)_size := $($(1)_size))\ + $(new_hmap)),\ + $(1)))))) +endef + +define EVAL_INVOKE +$(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) + $(foreach a0,$(call _nth,$(1),0),\ + $(if $(call _EQ,def!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(if $(__ERROR),,\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ + $(if $(call _EQ,let*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ + $(if $(call _EQ,do,$($(a0)_value)),\ + $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ + $(if $(call _EQ,if,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach cond,$(call EVAL,$(a1),$(2)),\ + $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ + $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ + $(call EVAL,$(a2),$(2)))))),\ + $(if $(call _EQ,fn*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ + $(foreach el,$(call EVAL_AST,$(1),$(2)),\ + $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ + $(foreach f,$(call sfirst,$(el)),\ + $(foreach args,$(call srest,$(el)),\ + $(call apply,$(f),$(args)))))))))))) +endef + +define EVAL +$(strip $(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ + $(if $(call _list?,$(1)),\ + $(if $(call _EQ,0,$(call _count,$(1))),\ + $(1),\ + $(word 1,$(strip $(call EVAL_INVOKE,$(1),$(2)) $(__nil)))),\ + $(call EVAL_AST,$(1),$(2))))) +endef + + +# PRINT: +define PRINT +$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) +endef + +# REPL: +REPL_ENV := $(call ENV) +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) +REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) + +# core.mk: defined using Make +_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) +_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) +$(call _import_core,$(core_ns)) + +# core.mal: defined in terms of the language itself +$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) + +# repl loop +$(if $(strip $(INTERACTIVE)),$(call REPL)) diff --git a/impls/make/step6_file.mk b/impls/make/step6_file.mk index f851747e52..462d9b9947 100644 --- a/impls/make/step6_file.mk +++ b/impls/make/step6_file.mk @@ -1,131 +1,131 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk -include $(_TOP_DIR)env.mk -include $(_TOP_DIR)core.mk - -SHELL := /bin/bash -INTERACTIVE ?= yes -EVAL_DEBUG ?= - -# READ: read and parse input -define READ -$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) -endef - -# EVAL: evaluate the parameter -define LET -$(strip \ - $(word 1,$(2) \ - $(foreach var,$(call _nth,$(1),0),\ - $(foreach val,$(call _nth,$(1),1),\ - $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ - $(foreach left,$(call srest,$(call srest,$(1))), - $(if $(call _EQ,0,$(call _count,$(left))),\ - ,\ - $(call LET,$(left),$(2)))))))) -endef - -define EVAL_AST -$(strip \ - $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ - $(if $(call _symbol?,$(1)),\ - $(foreach key,$($(1)_value),\ - $(call ENV_GET,$(2),$(key))),\ - $(if $(call _list?,$(1)),\ - $(call _smap,EVAL,$(1),$(2)),\ - $(if $(call _vector?,$(1)),\ - $(call _smap_vec,EVAL,$(1),$(2)),\ - $(if $(call _hash_map?,$(1)),\ - $(foreach new_hmap,$(call __new_obj,hmap),\ - $(foreach v,$(call __get_obj_values,$(1)),\ - $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ - $(eval $(new_hmap)_size := $($(1)_size))\ - $(new_hmap)),\ - $(1)))))) -endef - -define EVAL_INVOKE -$(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) - $(foreach a0,$(call _nth,$(1),0),\ - $(if $(call _EQ,def!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(__ERROR),,\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ - $(if $(call _EQ,let*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ - $(if $(call _EQ,do,$($(a0)_value)),\ - $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ - $(if $(call _EQ,if,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach cond,$(call EVAL,$(a1),$(2)),\ - $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ - $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ - $(call EVAL,$(a2),$(2)))))),\ - $(if $(call _EQ,fn*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ - $(foreach el,$(call EVAL_AST,$(1),$(2)),\ - $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ - $(foreach f,$(call sfirst,$(el)),\ - $(foreach args,$(call srest,$(el)),\ - $(call apply,$(f),$(args)))))))))))) -endef - -define EVAL -$(strip $(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ - $(if $(call _list?,$(1)),\ - $(if $(call _EQ,0,$(call _count,$(1))),\ - $(1),\ - $(word 1,$(strip $(call EVAL_INVOKE,$(1),$(2)) $(__nil)))),\ - $(call EVAL_AST,$(1),$(2))))) -endef - - -# PRINT: -define PRINT -$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) -endef - -# REPL: -REPL_ENV := $(call ENV) -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) -REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) - -# core.mk: defined using Make -_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) -_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) -$(call _import_core,$(core_ns)) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) -_argv := $(call _list) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) - -# core.mal: defined in terms of the language itself -$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) -$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) - -# Load and eval any files specified on the command line -$(if $(MAKECMDGOALS),\ - $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ - $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ - $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ - $(eval INTERACTIVE :=),) - -# repl loop -$(if $(strip $(INTERACTIVE)),$(call REPL)) - -.PHONY: none $(MAKECMDGOALS) -none $(MAKECMDGOALS): - @true +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk +include $(_TOP_DIR)env.mk +include $(_TOP_DIR)core.mk + +SHELL := /bin/bash +INTERACTIVE ?= yes +EVAL_DEBUG ?= + +# READ: read and parse input +define READ +$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) +endef + +# EVAL: evaluate the parameter +define LET +$(strip \ + $(word 1,$(2) \ + $(foreach var,$(call _nth,$(1),0),\ + $(foreach val,$(call _nth,$(1),1),\ + $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ + $(foreach left,$(call srest,$(call srest,$(1))), + $(if $(call _EQ,0,$(call _count,$(left))),\ + ,\ + $(call LET,$(left),$(2)))))))) +endef + +define EVAL_AST +$(strip \ + $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ + $(if $(call _symbol?,$(1)),\ + $(foreach key,$($(1)_value),\ + $(call ENV_GET,$(2),$(key))),\ + $(if $(call _list?,$(1)),\ + $(call _smap,EVAL,$(1),$(2)),\ + $(if $(call _vector?,$(1)),\ + $(call _smap_vec,EVAL,$(1),$(2)),\ + $(if $(call _hash_map?,$(1)),\ + $(foreach new_hmap,$(call __new_obj,hmap),\ + $(foreach v,$(call __get_obj_values,$(1)),\ + $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ + $(eval $(new_hmap)_size := $($(1)_size))\ + $(new_hmap)),\ + $(1)))))) +endef + +define EVAL_INVOKE +$(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) + $(foreach a0,$(call _nth,$(1),0),\ + $(if $(call _EQ,def!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(if $(__ERROR),,\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ + $(if $(call _EQ,let*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ + $(if $(call _EQ,do,$($(a0)_value)),\ + $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ + $(if $(call _EQ,if,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach cond,$(call EVAL,$(a1),$(2)),\ + $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ + $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ + $(call EVAL,$(a2),$(2)))))),\ + $(if $(call _EQ,fn*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ + $(foreach el,$(call EVAL_AST,$(1),$(2)),\ + $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ + $(foreach f,$(call sfirst,$(el)),\ + $(foreach args,$(call srest,$(el)),\ + $(call apply,$(f),$(args)))))))))))) +endef + +define EVAL +$(strip $(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ + $(if $(call _list?,$(1)),\ + $(if $(call _EQ,0,$(call _count,$(1))),\ + $(1),\ + $(word 1,$(strip $(call EVAL_INVOKE,$(1),$(2)) $(__nil)))),\ + $(call EVAL_AST,$(1),$(2))))) +endef + + +# PRINT: +define PRINT +$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) +endef + +# REPL: +REPL_ENV := $(call ENV) +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) +REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) + +# core.mk: defined using Make +_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) +_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) +$(call _import_core,$(core_ns)) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) +_argv := $(call _list) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) + +# core.mal: defined in terms of the language itself +$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) +$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) + +# Load and eval any files specified on the command line +$(if $(MAKECMDGOALS),\ + $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ + $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ + $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ + $(eval INTERACTIVE :=),) + +# repl loop +$(if $(strip $(INTERACTIVE)),$(call REPL)) + +.PHONY: none $(MAKECMDGOALS) +none $(MAKECMDGOALS): + @true diff --git a/impls/make/step7_quote.mk b/impls/make/step7_quote.mk index 92c0dcb777..6cb658b4f1 100644 --- a/impls/make/step7_quote.mk +++ b/impls/make/step7_quote.mk @@ -1,156 +1,156 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk -include $(_TOP_DIR)env.mk -include $(_TOP_DIR)core.mk - -SHELL := /bin/bash -INTERACTIVE ?= yes -EVAL_DEBUG ?= - -# READ: read and parse input -define READ -$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) -endef - -# EVAL: evaluate the parameter - -# elt, accumulator list -> new accumulator list -QQ_LOOP = $(call _list,\ - $(if $(and $(_list?),$(call _EQ,splice-unquote,$($(sfirst)_value))),\ - $(call _symbol,concat) $(call _nth,$1,1),\ - $(call _symbol,cons) $(QUASIQUOTE))\ - $2) - -# list or vector source -> right folded list -QQ_FOLD = $(if $(_empty?),$(call _list,),$(call QQ_LOOP,$(sfirst),$(call QQ_FOLD,$(srest)))) - -QUASIQUOTE = $(strip \ - $(if $(_list?), $(if $(call _EQ,unquote,$($(sfirst)_value)),\ - $(call _nth,$1,1),\ - $(QQ_FOLD)),\ - $(if $(_vector?), $(call _list,$(call _symbol,vec) $(QQ_FOLD)),\ - $(if $(_symbol?)$(_hash_map?), $(call _list,$(call _symbol,quote) $1),\ - $1)))) - -define LET -$(strip \ - $(word 1,$(2) \ - $(foreach var,$(call _nth,$(1),0),\ - $(foreach val,$(call _nth,$(1),1),\ - $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ - $(foreach left,$(call srest,$(call srest,$(1))), - $(if $(call _EQ,0,$(call _count,$(left))),\ - ,\ - $(call LET,$(left),$(2)))))))) -endef - -define EVAL_AST -$(strip \ - $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ - $(if $(call _symbol?,$(1)),\ - $(foreach key,$($(1)_value),\ - $(call ENV_GET,$(2),$(key))),\ - $(if $(call _list?,$(1)),\ - $(call _smap,EVAL,$(1),$(2)),\ - $(if $(call _vector?,$(1)),\ - $(call _smap_vec,EVAL,$(1),$(2)),\ - $(if $(call _hash_map?,$(1)),\ - $(foreach new_hmap,$(call __new_obj,hmap),\ - $(foreach v,$(call __get_obj_values,$(1)),\ - $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ - $(eval $(new_hmap)_size := $($(1)_size))\ - $(new_hmap)),\ - $(1)))))) -endef - -define EVAL_INVOKE -$(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) - $(foreach a0,$(call _nth,$(1),0),\ - $(if $(call _EQ,def!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(__ERROR),,\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ - $(if $(call _EQ,let*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ - $(if $(call _EQ,quote,$($(a0)_value)),\ - $(call _nth,$(1),1),\ - $(if $(call _EQ,quasiquoteexpand,$($(a0)_value)),\ - $(call QUASIQUOTE,$(call _nth,$(1),1)),\ - $(if $(call _EQ,quasiquote,$($(a0)_value)),\ - $(call EVAL,$(call QUASIQUOTE,$(call _nth,$(1),1)),$(2)),\ - $(if $(call _EQ,do,$($(a0)_value)),\ - $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ - $(if $(call _EQ,if,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach cond,$(call EVAL,$(a1),$(2)),\ - $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ - $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ - $(call EVAL,$(a2),$(2)))))),\ - $(if $(call _EQ,fn*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ - $(foreach el,$(call EVAL_AST,$(1),$(2)),\ - $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ - $(foreach f,$(call sfirst,$(el)),\ - $(foreach args,$(call srest,$(el)),\ - $(call apply,$(f),$(args))))))))))))))) -endef - -define EVAL -$(strip $(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ - $(if $(call _list?,$(1)),\ - $(if $(call _EQ,0,$(call _count,$(1))),\ - $(1),\ - $(word 1,$(strip $(call EVAL_INVOKE,$(1),$(2)) $(__nil)))),\ - $(call EVAL_AST,$(1),$(2))))) -endef - - -# PRINT: -define PRINT -$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) -endef - -# REPL: -REPL_ENV := $(call ENV) -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) -REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) - -# core.mk: defined using Make -_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) -_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) -$(call _import_core,$(core_ns)) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) -_argv := $(call _list) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) - -# core.mal: defined in terms of the language itself -$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) -$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) - -# Load and eval any files specified on the command line -$(if $(MAKECMDGOALS),\ - $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ - $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ - $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ - $(eval INTERACTIVE :=),) - -# repl loop -$(if $(strip $(INTERACTIVE)),$(call REPL)) - -.PHONY: none $(MAKECMDGOALS) -none $(MAKECMDGOALS): - @true +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk +include $(_TOP_DIR)env.mk +include $(_TOP_DIR)core.mk + +SHELL := /bin/bash +INTERACTIVE ?= yes +EVAL_DEBUG ?= + +# READ: read and parse input +define READ +$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) +endef + +# EVAL: evaluate the parameter + +# elt, accumulator list -> new accumulator list +QQ_LOOP = $(call _list,\ + $(if $(and $(_list?),$(call _EQ,splice-unquote,$($(sfirst)_value))),\ + $(call _symbol,concat) $(call _nth,$1,1),\ + $(call _symbol,cons) $(QUASIQUOTE))\ + $2) + +# list or vector source -> right folded list +QQ_FOLD = $(if $(_empty?),$(call _list,),$(call QQ_LOOP,$(sfirst),$(call QQ_FOLD,$(srest)))) + +QUASIQUOTE = $(strip \ + $(if $(_list?), $(if $(call _EQ,unquote,$($(sfirst)_value)),\ + $(call _nth,$1,1),\ + $(QQ_FOLD)),\ + $(if $(_vector?), $(call _list,$(call _symbol,vec) $(QQ_FOLD)),\ + $(if $(_symbol?)$(_hash_map?), $(call _list,$(call _symbol,quote) $1),\ + $1)))) + +define LET +$(strip \ + $(word 1,$(2) \ + $(foreach var,$(call _nth,$(1),0),\ + $(foreach val,$(call _nth,$(1),1),\ + $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ + $(foreach left,$(call srest,$(call srest,$(1))), + $(if $(call _EQ,0,$(call _count,$(left))),\ + ,\ + $(call LET,$(left),$(2)))))))) +endef + +define EVAL_AST +$(strip \ + $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ + $(if $(call _symbol?,$(1)),\ + $(foreach key,$($(1)_value),\ + $(call ENV_GET,$(2),$(key))),\ + $(if $(call _list?,$(1)),\ + $(call _smap,EVAL,$(1),$(2)),\ + $(if $(call _vector?,$(1)),\ + $(call _smap_vec,EVAL,$(1),$(2)),\ + $(if $(call _hash_map?,$(1)),\ + $(foreach new_hmap,$(call __new_obj,hmap),\ + $(foreach v,$(call __get_obj_values,$(1)),\ + $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ + $(eval $(new_hmap)_size := $($(1)_size))\ + $(new_hmap)),\ + $(1)))))) +endef + +define EVAL_INVOKE +$(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) + $(foreach a0,$(call _nth,$(1),0),\ + $(if $(call _EQ,def!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(if $(__ERROR),,\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ + $(if $(call _EQ,let*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ + $(if $(call _EQ,quote,$($(a0)_value)),\ + $(call _nth,$(1),1),\ + $(if $(call _EQ,quasiquoteexpand,$($(a0)_value)),\ + $(call QUASIQUOTE,$(call _nth,$(1),1)),\ + $(if $(call _EQ,quasiquote,$($(a0)_value)),\ + $(call EVAL,$(call QUASIQUOTE,$(call _nth,$(1),1)),$(2)),\ + $(if $(call _EQ,do,$($(a0)_value)),\ + $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ + $(if $(call _EQ,if,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach cond,$(call EVAL,$(a1),$(2)),\ + $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ + $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ + $(call EVAL,$(a2),$(2)))))),\ + $(if $(call _EQ,fn*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ + $(foreach el,$(call EVAL_AST,$(1),$(2)),\ + $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ + $(foreach f,$(call sfirst,$(el)),\ + $(foreach args,$(call srest,$(el)),\ + $(call apply,$(f),$(args))))))))))))))) +endef + +define EVAL +$(strip $(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ + $(if $(call _list?,$(1)),\ + $(if $(call _EQ,0,$(call _count,$(1))),\ + $(1),\ + $(word 1,$(strip $(call EVAL_INVOKE,$(1),$(2)) $(__nil)))),\ + $(call EVAL_AST,$(1),$(2))))) +endef + + +# PRINT: +define PRINT +$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) +endef + +# REPL: +REPL_ENV := $(call ENV) +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) +REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) + +# core.mk: defined using Make +_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) +_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) +$(call _import_core,$(core_ns)) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) +_argv := $(call _list) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) + +# core.mal: defined in terms of the language itself +$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) +$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) + +# Load and eval any files specified on the command line +$(if $(MAKECMDGOALS),\ + $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ + $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ + $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ + $(eval INTERACTIVE :=),) + +# repl loop +$(if $(strip $(INTERACTIVE)),$(call REPL)) + +.PHONY: none $(MAKECMDGOALS) +none $(MAKECMDGOALS): + @true diff --git a/impls/make/step8_macros.mk b/impls/make/step8_macros.mk index 10d4046a1a..0e4b2a8637 100644 --- a/impls/make/step8_macros.mk +++ b/impls/make/step8_macros.mk @@ -1,179 +1,179 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk -include $(_TOP_DIR)env.mk -include $(_TOP_DIR)core.mk - -SHELL := /bin/bash -INTERACTIVE ?= yes -EVAL_DEBUG ?= - -# READ: read and parse input -define READ -$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) -endef - -# EVAL: evaluate the parameter - -# elt, accumulator list -> new accumulator list -QQ_LOOP = $(call _list,\ - $(if $(and $(_list?),$(call _EQ,splice-unquote,$($(sfirst)_value))),\ - $(call _symbol,concat) $(call _nth,$1,1),\ - $(call _symbol,cons) $(QUASIQUOTE))\ - $2) - -# list or vector source -> right folded list -QQ_FOLD = $(if $(_empty?),$(call _list,),$(call QQ_LOOP,$(sfirst),$(call QQ_FOLD,$(srest)))) - -QUASIQUOTE = $(strip \ - $(if $(_list?), $(if $(call _EQ,unquote,$($(sfirst)_value)),\ - $(call _nth,$1,1),\ - $(QQ_FOLD)),\ - $(if $(_vector?), $(call _list,$(call _symbol,vec) $(QQ_FOLD)),\ - $(if $(_symbol?)$(_hash_map?), $(call _list,$(call _symbol,quote) $1),\ - $1)))) -define IS_MACRO_CALL -$(if $(call _list?,$(1)),$(if $(call ENV_FIND,$(2),$($(call _nth,$(1),0)_value)),$(_macro_$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value))),),) -endef - -define MACROEXPAND -$(strip $(if $(__ERROR),,\ - $(if $(call IS_MACRO_CALL,$(1),$(2)),\ - $(foreach mac,$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value)),\ - $(call MACROEXPAND,$(call apply,$(mac),$(call srest,$(1))),$(2))),\ - $(1)))) -endef - -define LET -$(strip \ - $(word 1,$(2) \ - $(foreach var,$(call _nth,$(1),0),\ - $(foreach val,$(call _nth,$(1),1),\ - $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ - $(foreach left,$(call srest,$(call srest,$(1))), - $(if $(call _EQ,0,$(call _count,$(left))),\ - ,\ - $(call LET,$(left),$(2)))))))) -endef - -define EVAL_AST -$(strip \ - $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ - $(if $(call _symbol?,$(1)),\ - $(foreach key,$($(1)_value),\ - $(call ENV_GET,$(2),$(key))),\ - $(if $(call _list?,$(1)),\ - $(call _smap,EVAL,$(1),$(2)),\ - $(if $(call _vector?,$(1)),\ - $(call _smap_vec,EVAL,$(1),$(2)),\ - $(if $(call _hash_map?,$(1)),\ - $(foreach new_hmap,$(call __new_obj,hmap),\ - $(foreach v,$(call __get_obj_values,$(1)),\ - $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ - $(eval $(new_hmap)_size := $($(1)_size))\ - $(new_hmap)),\ - $(1)))))) -endef - -define EVAL_INVOKE -$(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) - $(foreach a0,$(call _nth,$(1),0),\ - $(if $(call _EQ,def!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(__ERROR),,\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ - $(if $(call _EQ,let*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ - $(if $(call _EQ,quote,$($(a0)_value)),\ - $(call _nth,$(1),1),\ - $(if $(call _EQ,quasiquoteexpand,$($(a0)_value)),\ - $(call QUASIQUOTE,$(call _nth,$(1),1)),\ - $(if $(call _EQ,quasiquote,$($(a0)_value)),\ - $(call EVAL,$(call QUASIQUOTE,$(call _nth,$(1),1)),$(2)),\ - $(if $(call _EQ,defmacro!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(eval _macro_$(res) = true)\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),)))),\ - $(if $(call _EQ,macroexpand,$($(a0)_value)),\ - $(call MACROEXPAND,$(call _nth,$(1),1),$(2)),\ - $(if $(call _EQ,do,$($(a0)_value)),\ - $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ - $(if $(call _EQ,if,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach cond,$(call EVAL,$(a1),$(2)),\ - $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ - $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ - $(call EVAL,$(a2),$(2)))))),\ - $(if $(call _EQ,fn*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ - $(foreach el,$(call EVAL_AST,$(1),$(2)),\ - $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ - $(foreach f,$(call sfirst,$(el)),\ - $(foreach args,$(call srest,$(el)),\ - $(call apply,$(f),$(args))))))))))))))))) -endef - -define EVAL -$(strip $(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ - $(if $(call _list?,$(1)),\ - $(foreach ast,$(call MACROEXPAND,$(1),$(2)), - $(if $(call _list?,$(ast)),\ - $(if $(call _EQ,0,$(call _count,$(ast))),\ - $(ast),\ - $(word 1,$(strip $(call EVAL_INVOKE,$(ast),$(2)) $(__nil)))),\ - $(call EVAL_AST,$(ast),$(2)))),\ - $(call EVAL_AST,$(1),$(2))))) -endef - - -# PRINT: -define PRINT -$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) -endef - -# REPL: -REPL_ENV := $(call ENV) -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) -REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) - -# core.mk: defined using Make -_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) -_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) -$(call _import_core,$(core_ns)) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) -_argv := $(call _list) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) - -# core.mal: defined in terms of the language itself -$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) -$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) -$(call do,$(call 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))))))) )) - -# Load and eval any files specified on the command line -$(if $(MAKECMDGOALS),\ - $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ - $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ - $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ - $(eval INTERACTIVE :=),) - -# repl loop -$(if $(strip $(INTERACTIVE)),$(call REPL)) - -.PHONY: none $(MAKECMDGOALS) -none $(MAKECMDGOALS): - @true +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk +include $(_TOP_DIR)env.mk +include $(_TOP_DIR)core.mk + +SHELL := /bin/bash +INTERACTIVE ?= yes +EVAL_DEBUG ?= + +# READ: read and parse input +define READ +$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) +endef + +# EVAL: evaluate the parameter + +# elt, accumulator list -> new accumulator list +QQ_LOOP = $(call _list,\ + $(if $(and $(_list?),$(call _EQ,splice-unquote,$($(sfirst)_value))),\ + $(call _symbol,concat) $(call _nth,$1,1),\ + $(call _symbol,cons) $(QUASIQUOTE))\ + $2) + +# list or vector source -> right folded list +QQ_FOLD = $(if $(_empty?),$(call _list,),$(call QQ_LOOP,$(sfirst),$(call QQ_FOLD,$(srest)))) + +QUASIQUOTE = $(strip \ + $(if $(_list?), $(if $(call _EQ,unquote,$($(sfirst)_value)),\ + $(call _nth,$1,1),\ + $(QQ_FOLD)),\ + $(if $(_vector?), $(call _list,$(call _symbol,vec) $(QQ_FOLD)),\ + $(if $(_symbol?)$(_hash_map?), $(call _list,$(call _symbol,quote) $1),\ + $1)))) +define IS_MACRO_CALL +$(if $(call _list?,$(1)),$(if $(call ENV_FIND,$(2),$($(call _nth,$(1),0)_value)),$(_macro_$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value))),),) +endef + +define MACROEXPAND +$(strip $(if $(__ERROR),,\ + $(if $(call IS_MACRO_CALL,$(1),$(2)),\ + $(foreach mac,$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value)),\ + $(call MACROEXPAND,$(call apply,$(mac),$(call srest,$(1))),$(2))),\ + $(1)))) +endef + +define LET +$(strip \ + $(word 1,$(2) \ + $(foreach var,$(call _nth,$(1),0),\ + $(foreach val,$(call _nth,$(1),1),\ + $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ + $(foreach left,$(call srest,$(call srest,$(1))), + $(if $(call _EQ,0,$(call _count,$(left))),\ + ,\ + $(call LET,$(left),$(2)))))))) +endef + +define EVAL_AST +$(strip \ + $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ + $(if $(call _symbol?,$(1)),\ + $(foreach key,$($(1)_value),\ + $(call ENV_GET,$(2),$(key))),\ + $(if $(call _list?,$(1)),\ + $(call _smap,EVAL,$(1),$(2)),\ + $(if $(call _vector?,$(1)),\ + $(call _smap_vec,EVAL,$(1),$(2)),\ + $(if $(call _hash_map?,$(1)),\ + $(foreach new_hmap,$(call __new_obj,hmap),\ + $(foreach v,$(call __get_obj_values,$(1)),\ + $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ + $(eval $(new_hmap)_size := $($(1)_size))\ + $(new_hmap)),\ + $(1)))))) +endef + +define EVAL_INVOKE +$(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) + $(foreach a0,$(call _nth,$(1),0),\ + $(if $(call _EQ,def!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(if $(__ERROR),,\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ + $(if $(call _EQ,let*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ + $(if $(call _EQ,quote,$($(a0)_value)),\ + $(call _nth,$(1),1),\ + $(if $(call _EQ,quasiquoteexpand,$($(a0)_value)),\ + $(call QUASIQUOTE,$(call _nth,$(1),1)),\ + $(if $(call _EQ,quasiquote,$($(a0)_value)),\ + $(call EVAL,$(call QUASIQUOTE,$(call _nth,$(1),1)),$(2)),\ + $(if $(call _EQ,defmacro!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(eval _macro_$(res) = true)\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),)))),\ + $(if $(call _EQ,macroexpand,$($(a0)_value)),\ + $(call MACROEXPAND,$(call _nth,$(1),1),$(2)),\ + $(if $(call _EQ,do,$($(a0)_value)),\ + $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ + $(if $(call _EQ,if,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach cond,$(call EVAL,$(a1),$(2)),\ + $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ + $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ + $(call EVAL,$(a2),$(2)))))),\ + $(if $(call _EQ,fn*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ + $(foreach el,$(call EVAL_AST,$(1),$(2)),\ + $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ + $(foreach f,$(call sfirst,$(el)),\ + $(foreach args,$(call srest,$(el)),\ + $(call apply,$(f),$(args))))))))))))))))) +endef + +define EVAL +$(strip $(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ + $(if $(call _list?,$(1)),\ + $(foreach ast,$(call MACROEXPAND,$(1),$(2)), + $(if $(call _list?,$(ast)),\ + $(if $(call _EQ,0,$(call _count,$(ast))),\ + $(ast),\ + $(word 1,$(strip $(call EVAL_INVOKE,$(ast),$(2)) $(__nil)))),\ + $(call EVAL_AST,$(ast),$(2)))),\ + $(call EVAL_AST,$(1),$(2))))) +endef + + +# PRINT: +define PRINT +$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) +endef + +# REPL: +REPL_ENV := $(call ENV) +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) +REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) + +# core.mk: defined using Make +_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) +_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) +$(call _import_core,$(core_ns)) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) +_argv := $(call _list) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) + +# core.mal: defined in terms of the language itself +$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) +$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) +$(call do,$(call 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))))))) )) + +# Load and eval any files specified on the command line +$(if $(MAKECMDGOALS),\ + $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ + $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ + $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ + $(eval INTERACTIVE :=),) + +# repl loop +$(if $(strip $(INTERACTIVE)),$(call REPL)) + +.PHONY: none $(MAKECMDGOALS) +none $(MAKECMDGOALS): + @true diff --git a/impls/make/step9_try.mk b/impls/make/step9_try.mk index fd49e82dd1..50b1de31de 100644 --- a/impls/make/step9_try.mk +++ b/impls/make/step9_try.mk @@ -1,194 +1,194 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk -include $(_TOP_DIR)env.mk -include $(_TOP_DIR)core.mk - -SHELL := /bin/bash -INTERACTIVE ?= yes -EVAL_DEBUG ?= - -# READ: read and parse input -define READ -$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) -endef - -# EVAL: evaluate the parameter - -# elt, accumulator list -> new accumulator list -QQ_LOOP = $(call _list,\ - $(if $(and $(_list?),$(call _EQ,splice-unquote,$($(sfirst)_value))),\ - $(call _symbol,concat) $(call _nth,$1,1),\ - $(call _symbol,cons) $(QUASIQUOTE))\ - $2) - -# list or vector source -> right folded list -QQ_FOLD = $(if $(_empty?),$(call _list,),$(call QQ_LOOP,$(sfirst),$(call QQ_FOLD,$(srest)))) - -QUASIQUOTE = $(strip \ - $(if $(_list?), $(if $(call _EQ,unquote,$($(sfirst)_value)),\ - $(call _nth,$1,1),\ - $(QQ_FOLD)),\ - $(if $(_vector?), $(call _list,$(call _symbol,vec) $(QQ_FOLD)),\ - $(if $(_symbol?)$(_hash_map?), $(call _list,$(call _symbol,quote) $1),\ - $1)))) -define IS_MACRO_CALL -$(if $(call _list?,$(1)),$(if $(call ENV_FIND,$(2),$($(call _nth,$(1),0)_value)),$(_macro_$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value))),),) -endef - -define MACROEXPAND -$(strip $(if $(__ERROR),,\ - $(if $(call IS_MACRO_CALL,$(1),$(2)),\ - $(foreach mac,$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value)),\ - $(call MACROEXPAND,$(call apply,$(mac),$(call srest,$(1))),$(2))),\ - $(1)))) -endef - -define LET -$(strip \ - $(word 1,$(2) \ - $(foreach var,$(call _nth,$(1),0),\ - $(foreach val,$(call _nth,$(1),1),\ - $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ - $(foreach left,$(call srest,$(call srest,$(1))), - $(if $(call _EQ,0,$(call _count,$(left))),\ - ,\ - $(call LET,$(left),$(2)))))))) -endef - -define EVAL_AST -$(strip \ - $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ - $(if $(call _symbol?,$(1)),\ - $(foreach key,$($(1)_value),\ - $(call ENV_GET,$(2),$(key))),\ - $(if $(call _list?,$(1)),\ - $(call _smap,EVAL,$(1),$(2)),\ - $(if $(call _vector?,$(1)),\ - $(call _smap_vec,EVAL,$(1),$(2)),\ - $(if $(call _hash_map?,$(1)),\ - $(foreach new_hmap,$(call __new_obj,hmap),\ - $(foreach v,$(call __get_obj_values,$(1)),\ - $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ - $(eval $(new_hmap)_size := $($(1)_size))\ - $(new_hmap)),\ - $(1)))))) -endef - -define EVAL_INVOKE -$(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) - $(foreach a0,$(call _nth,$(1),0),\ - $(if $(call _EQ,def!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(__ERROR),,\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ - $(if $(call _EQ,let*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ - $(if $(call _EQ,quote,$($(a0)_value)),\ - $(call _nth,$(1),1),\ - $(if $(call _EQ,quasiquoteexpand,$($(a0)_value)),\ - $(call QUASIQUOTE,$(call _nth,$(1),1)),\ - $(if $(call _EQ,quasiquote,$($(a0)_value)),\ - $(call EVAL,$(call QUASIQUOTE,$(call _nth,$(1),1)),$(2)),\ - $(if $(call _EQ,defmacro!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(eval _macro_$(res) = true)\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),)))),\ - $(if $(call _EQ,macroexpand,$($(a0)_value)),\ - $(call MACROEXPAND,$(call _nth,$(1),1),$(2)),\ - $(if $(call _EQ,try*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach res,$(call EVAL,$(a1),$(2)),\ - $(if $(__ERROR),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach a20,$(call _nth,$(a2),0),\ - $(if $(call _EQ,catch*,$($(a20)_value)),\ - $(foreach a21,$(call _nth,$(a2),1),\ - $(foreach a22,$(call _nth,$(a2),2),\ - $(foreach binds,$(call _list,$(a21)),\ - $(foreach catch_env,$(call ENV,$(2),$(binds),$(__ERROR)),\ - $(eval __ERROR :=)\ - $(call EVAL,$(a22),$(catch_env)))))),\ - $(res)))),\ - $(res)))),\ - $(if $(call _EQ,do,$($(a0)_value)),\ - $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ - $(if $(call _EQ,if,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach cond,$(call EVAL,$(a1),$(2)),\ - $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ - $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ - $(call EVAL,$(a2),$(2)))))),\ - $(if $(call _EQ,fn*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ - $(foreach el,$(call EVAL_AST,$(1),$(2)),\ - $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ - $(foreach f,$(call sfirst,$(el)),\ - $(foreach args,$(call srest,$(el)),\ - $(call apply,$(f),$(args)))))))))))))))))) -endef - -define EVAL -$(strip $(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ - $(if $(call _list?,$(1)),\ - $(foreach ast,$(call MACROEXPAND,$(1),$(2)), - $(if $(call _list?,$(ast)),\ - $(if $(call _EQ,0,$(call _count,$(ast))),\ - $(ast),\ - $(word 1,$(strip $(call EVAL_INVOKE,$(ast),$(2)) $(__nil)))),\ - $(call EVAL_AST,$(ast),$(2)))),\ - $(call EVAL_AST,$(1),$(2))))) -endef - - -# PRINT: -define PRINT -$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) -endef - -# REPL: -REPL_ENV := $(call ENV) -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) -REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) - -# core.mk: defined using Make -_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) -_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) -$(call _import_core,$(core_ns)) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) -_argv := $(call _list) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) - -# core.mal: defined in terms of the language itself -$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) -$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) -$(call do,$(call 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))))))) )) - -# Load and eval any files specified on the command line -$(if $(MAKECMDGOALS),\ - $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ - $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ - $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ - $(eval INTERACTIVE :=),) - -# repl loop -$(if $(strip $(INTERACTIVE)),$(call REPL)) - -.PHONY: none $(MAKECMDGOALS) -none $(MAKECMDGOALS): - @true +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk +include $(_TOP_DIR)env.mk +include $(_TOP_DIR)core.mk + +SHELL := /bin/bash +INTERACTIVE ?= yes +EVAL_DEBUG ?= + +# READ: read and parse input +define READ +$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) +endef + +# EVAL: evaluate the parameter + +# elt, accumulator list -> new accumulator list +QQ_LOOP = $(call _list,\ + $(if $(and $(_list?),$(call _EQ,splice-unquote,$($(sfirst)_value))),\ + $(call _symbol,concat) $(call _nth,$1,1),\ + $(call _symbol,cons) $(QUASIQUOTE))\ + $2) + +# list or vector source -> right folded list +QQ_FOLD = $(if $(_empty?),$(call _list,),$(call QQ_LOOP,$(sfirst),$(call QQ_FOLD,$(srest)))) + +QUASIQUOTE = $(strip \ + $(if $(_list?), $(if $(call _EQ,unquote,$($(sfirst)_value)),\ + $(call _nth,$1,1),\ + $(QQ_FOLD)),\ + $(if $(_vector?), $(call _list,$(call _symbol,vec) $(QQ_FOLD)),\ + $(if $(_symbol?)$(_hash_map?), $(call _list,$(call _symbol,quote) $1),\ + $1)))) +define IS_MACRO_CALL +$(if $(call _list?,$(1)),$(if $(call ENV_FIND,$(2),$($(call _nth,$(1),0)_value)),$(_macro_$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value))),),) +endef + +define MACROEXPAND +$(strip $(if $(__ERROR),,\ + $(if $(call IS_MACRO_CALL,$(1),$(2)),\ + $(foreach mac,$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value)),\ + $(call MACROEXPAND,$(call apply,$(mac),$(call srest,$(1))),$(2))),\ + $(1)))) +endef + +define LET +$(strip \ + $(word 1,$(2) \ + $(foreach var,$(call _nth,$(1),0),\ + $(foreach val,$(call _nth,$(1),1),\ + $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ + $(foreach left,$(call srest,$(call srest,$(1))), + $(if $(call _EQ,0,$(call _count,$(left))),\ + ,\ + $(call LET,$(left),$(2)))))))) +endef + +define EVAL_AST +$(strip \ + $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ + $(if $(call _symbol?,$(1)),\ + $(foreach key,$($(1)_value),\ + $(call ENV_GET,$(2),$(key))),\ + $(if $(call _list?,$(1)),\ + $(call _smap,EVAL,$(1),$(2)),\ + $(if $(call _vector?,$(1)),\ + $(call _smap_vec,EVAL,$(1),$(2)),\ + $(if $(call _hash_map?,$(1)),\ + $(foreach new_hmap,$(call __new_obj,hmap),\ + $(foreach v,$(call __get_obj_values,$(1)),\ + $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ + $(eval $(new_hmap)_size := $($(1)_size))\ + $(new_hmap)),\ + $(1)))))) +endef + +define EVAL_INVOKE +$(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) + $(foreach a0,$(call _nth,$(1),0),\ + $(if $(call _EQ,def!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(if $(__ERROR),,\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ + $(if $(call _EQ,let*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ + $(if $(call _EQ,quote,$($(a0)_value)),\ + $(call _nth,$(1),1),\ + $(if $(call _EQ,quasiquoteexpand,$($(a0)_value)),\ + $(call QUASIQUOTE,$(call _nth,$(1),1)),\ + $(if $(call _EQ,quasiquote,$($(a0)_value)),\ + $(call EVAL,$(call QUASIQUOTE,$(call _nth,$(1),1)),$(2)),\ + $(if $(call _EQ,defmacro!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(eval _macro_$(res) = true)\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),)))),\ + $(if $(call _EQ,macroexpand,$($(a0)_value)),\ + $(call MACROEXPAND,$(call _nth,$(1),1),$(2)),\ + $(if $(call _EQ,try*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach res,$(call EVAL,$(a1),$(2)),\ + $(if $(__ERROR),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach a20,$(call _nth,$(a2),0),\ + $(if $(call _EQ,catch*,$($(a20)_value)),\ + $(foreach a21,$(call _nth,$(a2),1),\ + $(foreach a22,$(call _nth,$(a2),2),\ + $(foreach binds,$(call _list,$(a21)),\ + $(foreach catch_env,$(call ENV,$(2),$(binds),$(__ERROR)),\ + $(eval __ERROR :=)\ + $(call EVAL,$(a22),$(catch_env)))))),\ + $(res)))),\ + $(res)))),\ + $(if $(call _EQ,do,$($(a0)_value)),\ + $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ + $(if $(call _EQ,if,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach cond,$(call EVAL,$(a1),$(2)),\ + $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ + $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ + $(call EVAL,$(a2),$(2)))))),\ + $(if $(call _EQ,fn*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ + $(foreach el,$(call EVAL_AST,$(1),$(2)),\ + $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ + $(foreach f,$(call sfirst,$(el)),\ + $(foreach args,$(call srest,$(el)),\ + $(call apply,$(f),$(args)))))))))))))))))) +endef + +define EVAL +$(strip $(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ + $(if $(call _list?,$(1)),\ + $(foreach ast,$(call MACROEXPAND,$(1),$(2)), + $(if $(call _list?,$(ast)),\ + $(if $(call _EQ,0,$(call _count,$(ast))),\ + $(ast),\ + $(word 1,$(strip $(call EVAL_INVOKE,$(ast),$(2)) $(__nil)))),\ + $(call EVAL_AST,$(ast),$(2)))),\ + $(call EVAL_AST,$(1),$(2))))) +endef + + +# PRINT: +define PRINT +$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) +endef + +# REPL: +REPL_ENV := $(call ENV) +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) +REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) + +# core.mk: defined using Make +_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) +_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) +$(call _import_core,$(core_ns)) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) +_argv := $(call _list) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) + +# core.mal: defined in terms of the language itself +$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) +$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) +$(call do,$(call 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))))))) )) + +# Load and eval any files specified on the command line +$(if $(MAKECMDGOALS),\ + $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ + $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ + $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ + $(eval INTERACTIVE :=),) + +# repl loop +$(if $(strip $(INTERACTIVE)),$(call REPL)) + +.PHONY: none $(MAKECMDGOALS) +none $(MAKECMDGOALS): + @true diff --git a/impls/make/stepA_mal.mk b/impls/make/stepA_mal.mk index fb5c4648b6..1fa89764c8 100644 --- a/impls/make/stepA_mal.mk +++ b/impls/make/stepA_mal.mk @@ -1,201 +1,201 @@ -# -# mal (Make Lisp) -# -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)types.mk -include $(_TOP_DIR)reader.mk -include $(_TOP_DIR)printer.mk -include $(_TOP_DIR)env.mk -include $(_TOP_DIR)core.mk - -SHELL := /bin/bash -INTERACTIVE ?= yes -EVAL_DEBUG ?= - -# READ: read and parse input -define READ -$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) -endef - -# EVAL: evaluate the parameter - -# elt, accumulator list -> new accumulator list -QQ_LOOP = $(call _list,\ - $(if $(and $(_list?),$(call _EQ,splice-unquote,$($(sfirst)_value))),\ - $(call _symbol,concat) $(call _nth,$1,1),\ - $(call _symbol,cons) $(QUASIQUOTE))\ - $2) - -# list or vector source -> right folded list -QQ_FOLD = $(if $(_empty?),$(call _list,),$(call QQ_LOOP,$(sfirst),$(call QQ_FOLD,$(srest)))) - -QUASIQUOTE = $(strip \ - $(if $(_list?), $(if $(call _EQ,unquote,$($(sfirst)_value)),\ - $(call _nth,$1,1),\ - $(QQ_FOLD)),\ - $(if $(_vector?), $(call _list,$(call _symbol,vec) $(QQ_FOLD)),\ - $(if $(_symbol?)$(_hash_map?), $(call _list,$(call _symbol,quote) $1),\ - $1)))) -define IS_MACRO_CALL -$(if $(call _list?,$(1)),$(if $(call ENV_FIND,$(2),$($(call _nth,$(1),0)_value)),$(_macro_$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value))),),) -endef - -define MACROEXPAND -$(strip $(if $(__ERROR),,\ - $(if $(call IS_MACRO_CALL,$(1),$(2)),\ - $(foreach mac,$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value)),\ - $(call MACROEXPAND,$(call apply,$(mac),$(call srest,$(1))),$(2))),\ - $(1)))) -endef - -define LET -$(strip \ - $(word 1,$(2) \ - $(foreach var,$(call _nth,$(1),0),\ - $(foreach val,$(call _nth,$(1),1),\ - $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ - $(foreach left,$(call srest,$(call srest,$(1))), - $(if $(call _EQ,0,$(call _count,$(left))),\ - ,\ - $(call LET,$(left),$(2)))))))) -endef - -define EVAL_AST -$(strip \ - $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ - $(if $(call _symbol?,$(1)),\ - $(foreach key,$($(1)_value),\ - $(call ENV_GET,$(2),$(key))),\ - $(if $(call _list?,$(1)),\ - $(call _smap,EVAL,$(1),$(2)),\ - $(if $(call _vector?,$(1)),\ - $(call _smap_vec,EVAL,$(1),$(2)),\ - $(if $(call _hash_map?,$(1)),\ - $(foreach new_hmap,$(call __new_obj,hmap),\ - $(foreach v,$(call __get_obj_values,$(1)),\ - $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ - $(eval $(new_hmap)_size := $($(1)_size))\ - $(new_hmap)),\ - $(1)))))) -endef - -define EVAL_INVOKE -$(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) - $(foreach a0,$(call _nth,$(1),0),\ - $(if $(call _EQ,def!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(if $(__ERROR),,\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ - $(if $(call _EQ,let*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ - $(if $(call _EQ,quote,$($(a0)_value)),\ - $(call _nth,$(1),1),\ - $(if $(call _EQ,quasiquoteexpand,$($(a0)_value)),\ - $(call QUASIQUOTE,$(call _nth,$(1),1)),\ - $(if $(call _EQ,quasiquote,$($(a0)_value)),\ - $(call EVAL,$(call QUASIQUOTE,$(call _nth,$(1),1)),$(2)),\ - $(if $(call _EQ,defmacro!,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach res,$(call EVAL,$(a2),$(2)),\ - $(eval _macro_$(res) = true)\ - $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),)))),\ - $(if $(call _EQ,macroexpand,$($(a0)_value)),\ - $(call MACROEXPAND,$(call _nth,$(1),1),$(2)),\ - $(if $(call _EQ,make*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(and $(EVAL_DEBUG),$(info make*: $$(eval __result := $(call str_decode,$(value $(a1)_value)))))\ - $(eval __result := $(call str_decode,$(value $(a1)_value)))$(call _string,$(__result))),\ - $(if $(call _EQ,try*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach res,$(call EVAL,$(a1),$(2)),\ - $(if $(__ERROR),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach a20,$(call _nth,$(a2),0),\ - $(if $(call _EQ,catch*,$($(a20)_value)),\ - $(foreach a21,$(call _nth,$(a2),1),\ - $(foreach a22,$(call _nth,$(a2),2),\ - $(foreach binds,$(call _list,$(a21)),\ - $(foreach catch_env,$(call ENV,$(2),$(binds),$(__ERROR)),\ - $(eval __ERROR :=)\ - $(call EVAL,$(a22),$(catch_env)))))),\ - $(res)))),\ - $(res)))),\ - $(if $(call _EQ,do,$($(a0)_value)),\ - $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ - $(if $(call _EQ,if,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(foreach cond,$(call EVAL,$(a1),$(2)),\ - $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ - $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ - $(call EVAL,$(a2),$(2)))))),\ - $(if $(call _EQ,fn*,$($(a0)_value)),\ - $(foreach a1,$(call _nth,$(1),1),\ - $(foreach a2,$(call _nth,$(1),2),\ - $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ - $(foreach el,$(call EVAL_AST,$(1),$(2)),\ - $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ - $(foreach f,$(call sfirst,$(el)),\ - $(foreach args,$(call srest,$(el)),\ - $(call apply,$(f),$(args))))))))))))))))))) -endef - -define EVAL -$(strip $(if $(__ERROR),,\ - $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ - $(if $(call _list?,$(1)),\ - $(foreach ast,$(call MACROEXPAND,$(1),$(2)), - $(if $(call _list?,$(ast)),\ - $(if $(call _EQ,0,$(call _count,$(ast))),\ - $(ast),\ - $(word 1,$(strip $(call EVAL_INVOKE,$(ast),$(2)) $(__nil)))),\ - $(call EVAL_AST,$(ast),$(2)))),\ - $(call EVAL_AST,$(1),$(2))))) -endef - - -# PRINT: -define PRINT -$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) -endef - -# REPL: -REPL_ENV := $(call ENV) -REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) -REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) - -# core.mk: defined using Make -_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) -_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) -$(call _import_core,$(core_ns)) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) -_argv := $(call _list) -REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) - -# core.mal: defined in terms of the language itself -$(call do,$(call REP, (def! *host-language* "make") )) -$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) -$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) -$(call do,$(call 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))))))) )) - -# Load and eval any files specified on the command line -$(if $(MAKECMDGOALS),\ - $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ - $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ - $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ - $(eval INTERACTIVE :=),) - -# repl loop -$(if $(strip $(INTERACTIVE)),\ - $(call do,$(call REP, (println (str "Mal [" *host-language* "]")) )) \ - $(call REPL)) - -.PHONY: none $(MAKECMDGOALS) -none $(MAKECMDGOALS): - @true +# +# mal (Make Lisp) +# +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)types.mk +include $(_TOP_DIR)reader.mk +include $(_TOP_DIR)printer.mk +include $(_TOP_DIR)env.mk +include $(_TOP_DIR)core.mk + +SHELL := /bin/bash +INTERACTIVE ?= yes +EVAL_DEBUG ?= + +# READ: read and parse input +define READ +$(if $(READLINE_EOF)$(__ERROR),,$(call READ_STR,$(if $(1),$(1),$(call READLINE,"user> ")))) +endef + +# EVAL: evaluate the parameter + +# elt, accumulator list -> new accumulator list +QQ_LOOP = $(call _list,\ + $(if $(and $(_list?),$(call _EQ,splice-unquote,$($(sfirst)_value))),\ + $(call _symbol,concat) $(call _nth,$1,1),\ + $(call _symbol,cons) $(QUASIQUOTE))\ + $2) + +# list or vector source -> right folded list +QQ_FOLD = $(if $(_empty?),$(call _list,),$(call QQ_LOOP,$(sfirst),$(call QQ_FOLD,$(srest)))) + +QUASIQUOTE = $(strip \ + $(if $(_list?), $(if $(call _EQ,unquote,$($(sfirst)_value)),\ + $(call _nth,$1,1),\ + $(QQ_FOLD)),\ + $(if $(_vector?), $(call _list,$(call _symbol,vec) $(QQ_FOLD)),\ + $(if $(_symbol?)$(_hash_map?), $(call _list,$(call _symbol,quote) $1),\ + $1)))) +define IS_MACRO_CALL +$(if $(call _list?,$(1)),$(if $(call ENV_FIND,$(2),$($(call _nth,$(1),0)_value)),$(_macro_$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value))),),) +endef + +define MACROEXPAND +$(strip $(if $(__ERROR),,\ + $(if $(call IS_MACRO_CALL,$(1),$(2)),\ + $(foreach mac,$(call ENV_GET,$(2),$($(call _nth,$(1),0)_value)),\ + $(call MACROEXPAND,$(call apply,$(mac),$(call srest,$(1))),$(2))),\ + $(1)))) +endef + +define LET +$(strip \ + $(word 1,$(2) \ + $(foreach var,$(call _nth,$(1),0),\ + $(foreach val,$(call _nth,$(1),1),\ + $(call ENV_SET,$(2),$($(var)_value),$(call EVAL,$(val),$(2)))\ + $(foreach left,$(call srest,$(call srest,$(1))), + $(if $(call _EQ,0,$(call _count,$(left))),\ + ,\ + $(call LET,$(left),$(2)))))))) +endef + +define EVAL_AST +$(strip \ + $(and $(EVAL_DEBUG),$(info EVAL_AST: $(call _pr_str,$(1))))\ + $(if $(call _symbol?,$(1)),\ + $(foreach key,$($(1)_value),\ + $(call ENV_GET,$(2),$(key))),\ + $(if $(call _list?,$(1)),\ + $(call _smap,EVAL,$(1),$(2)),\ + $(if $(call _vector?,$(1)),\ + $(call _smap_vec,EVAL,$(1),$(2)),\ + $(if $(call _hash_map?,$(1)),\ + $(foreach new_hmap,$(call __new_obj,hmap),\ + $(foreach v,$(call __get_obj_values,$(1)),\ + $(eval $(v:$(1)_%=$(new_hmap)_%) := $(call EVAL,$($(v)),$(2))))\ + $(eval $(new_hmap)_size := $($(1)_size))\ + $(new_hmap)),\ + $(1)))))) +endef + +define EVAL_INVOKE +$(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL_INVOKE: $(call _pr_str,$(1)))) + $(foreach a0,$(call _nth,$(1),0),\ + $(if $(call _EQ,def!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(if $(__ERROR),,\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),))))),\ + $(if $(call _EQ,let*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call EVAL,$(a2),$(call LET,$(a1),$(call ENV,$(2)))))),\ + $(if $(call _EQ,quote,$($(a0)_value)),\ + $(call _nth,$(1),1),\ + $(if $(call _EQ,quasiquoteexpand,$($(a0)_value)),\ + $(call QUASIQUOTE,$(call _nth,$(1),1)),\ + $(if $(call _EQ,quasiquote,$($(a0)_value)),\ + $(call EVAL,$(call QUASIQUOTE,$(call _nth,$(1),1)),$(2)),\ + $(if $(call _EQ,defmacro!,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach res,$(call EVAL,$(a2),$(2)),\ + $(eval _macro_$(res) = true)\ + $(if $(call ENV_SET,$(2),$($(a1)_value),$(res)),$(res),)))),\ + $(if $(call _EQ,macroexpand,$($(a0)_value)),\ + $(call MACROEXPAND,$(call _nth,$(1),1),$(2)),\ + $(if $(call _EQ,make*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(and $(EVAL_DEBUG),$(info make*: $$(eval __result := $(call str_decode,$(value $(a1)_value)))))\ + $(eval __result := $(call str_decode,$(value $(a1)_value)))$(call _string,$(__result))),\ + $(if $(call _EQ,try*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach res,$(call EVAL,$(a1),$(2)),\ + $(if $(__ERROR),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach a20,$(call _nth,$(a2),0),\ + $(if $(call _EQ,catch*,$($(a20)_value)),\ + $(foreach a21,$(call _nth,$(a2),1),\ + $(foreach a22,$(call _nth,$(a2),2),\ + $(foreach binds,$(call _list,$(a21)),\ + $(foreach catch_env,$(call ENV,$(2),$(binds),$(__ERROR)),\ + $(eval __ERROR :=)\ + $(call EVAL,$(a22),$(catch_env)))))),\ + $(res)))),\ + $(res)))),\ + $(if $(call _EQ,do,$($(a0)_value)),\ + $(call slast,$(call EVAL_AST,$(call srest,$(1)),$(2))),\ + $(if $(call _EQ,if,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(foreach cond,$(call EVAL,$(a1),$(2)),\ + $(if $(or $(call _EQ,$(__nil),$(cond)),$(call _EQ,$(__false),$(cond))),\ + $(foreach a3,$(call _nth,$(1),3),$(call EVAL,$(a3),$(2))),\ + $(call EVAL,$(a2),$(2)))))),\ + $(if $(call _EQ,fn*,$($(a0)_value)),\ + $(foreach a1,$(call _nth,$(1),1),\ + $(foreach a2,$(call _nth,$(1),2),\ + $(call _function,$$(call EVAL,$(a2),$$(call ENV,$(2),$(a1),$$1))))),\ + $(foreach el,$(call EVAL_AST,$(1),$(2)),\ + $(and $(EVAL_DEBUG),$(info invoke: $(call _pr_str,$(el))))\ + $(foreach f,$(call sfirst,$(el)),\ + $(foreach args,$(call srest,$(el)),\ + $(call apply,$(f),$(args))))))))))))))))))) +endef + +define EVAL +$(strip $(if $(__ERROR),,\ + $(and $(EVAL_DEBUG),$(info EVAL: $(call _pr_str,$(1))))\ + $(if $(call _list?,$(1)),\ + $(foreach ast,$(call MACROEXPAND,$(1),$(2)), + $(if $(call _list?,$(ast)),\ + $(if $(call _EQ,0,$(call _count,$(ast))),\ + $(ast),\ + $(word 1,$(strip $(call EVAL_INVOKE,$(ast),$(2)) $(__nil)))),\ + $(call EVAL_AST,$(ast),$(2)))),\ + $(call EVAL_AST,$(1),$(2))))) +endef + + +# PRINT: +define PRINT +$(if $(__ERROR),Error: $(call _pr_str,$(__ERROR),yes),$(if $(1),$(call _pr_str,$(1),yes)))$(if $(__ERROR),$(eval __ERROR :=),) +endef + +# REPL: +REPL_ENV := $(call ENV) +REP = $(call PRINT,$(strip $(call EVAL,$(strip $(call READ,$(1))),$(REPL_ENV)))) +REPL = $(info $(call REP,$(call READLINE,"user> ")))$(if $(READLINE_EOF),,$(call REPL)) + +# core.mk: defined using Make +_fref = $(eval REPL_ENV := $(call ENV_SET,$(REPL_ENV),$(1),$(call _function,$$(call $(2),$$1)))) +_import_core = $(if $(strip $(1)),$(call _fref,$(word 1,$(1)),$(word 2,$(1)))$(call _import_core,$(wordlist 3,$(words $(1)),$(1))),) +$(call _import_core,$(core_ns)) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),eval,$(call _function,$$(call EVAL,$$(1),$$(REPL_ENV)))) +_argv := $(call _list) +REPL_ENV := $(call ENV_SET,$(REPL_ENV),*ARGV*,$(_argv)) + +# core.mal: defined in terms of the language itself +$(call do,$(call REP, (def! *host-language* "make") )) +$(call do,$(call REP, (def! not (fn* (a) (if a false true))) )) +$(call do,$(call REP, (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) )) +$(call do,$(call 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))))))) )) + +# Load and eval any files specified on the command line +$(if $(MAKECMDGOALS),\ + $(foreach arg,$(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)),\ + $(call do,$(call _conj!,$(_argv),$(call _string,$(arg)))))\ + $(call do,$(call REP, (load-file "$(word 1,$(MAKECMDGOALS))") )) \ + $(eval INTERACTIVE :=),) + +# repl loop +$(if $(strip $(INTERACTIVE)),\ + $(call do,$(call REP, (println (str "Mal [" *host-language* "]")) )) \ + $(call REPL)) + +.PHONY: none $(MAKECMDGOALS) +none $(MAKECMDGOALS): + @true diff --git a/impls/make/tests/stepA_mal.mal b/impls/make/tests/stepA_mal.mal index ed5551cacf..dccb82f914 100644 --- a/impls/make/tests/stepA_mal.mal +++ b/impls/make/tests/stepA_mal.mal @@ -1,19 +1,19 @@ -;; Testing basic make interop - -(make* "7") -;=>"7" - -(make* "$(info foo)") -;/foo -;=>"" - -(make* "$(eval foo := 8)") -(make* "$(foo)") -;=>"8" - -(make* "$(foreach v,a b c,X$(v)Y)") -;=>"XaY XbY XcY" - -(read-string (make* "($(foreach v,1 2 3,$(call int_add,1,$(v))))")) -;=>(2 3 4) - +;; Testing basic make interop + +(make* "7") +;=>"7" + +(make* "$(info foo)") +;/foo +;=>"" + +(make* "$(eval foo := 8)") +(make* "$(foo)") +;=>"8" + +(make* "$(foreach v,a b c,X$(v)Y)") +;=>"XaY XbY XcY" + +(read-string (make* "($(foreach v,1 2 3,$(call int_add,1,$(v))))")) +;=>(2 3 4) + diff --git a/impls/make/types.mk b/impls/make/types.mk index a5a055a5bf..b1a0b60756 100644 --- a/impls/make/types.mk +++ b/impls/make/types.mk @@ -1,268 +1,268 @@ -# -# mal (Make a Lisp) object types -# - -ifndef __mal_types_included -__mal_types_included := true - -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)gmsl.mk -include $(_TOP_DIR)util.mk -include $(_TOP_DIR)numbers.mk - - -# Low-level type implemenation - -# magic is \u2344 \u204a -__obj_magic = ⍄⁊ -# \u2256 -__equal = ≛ -__keyword = ʞ -__obj_hash_code = 0 - -__new_obj_hash_code = $(eval __obj_hash_code := $(call int_add,1,$(__obj_hash_code)))$(__obj_hash_code) - -__new_obj = $(__obj_magic)_$(1)_$(call __new_obj_hash_code) - -__new_obj_like = $(foreach type,$(word 2,$(subst _, ,$(1))),$(__obj_magic)_$(type)_$(__new_obj_hash_code)) - -__get_obj_values = $(strip \ - $(if $(filter $(__obj_magic)_hmap_%,$(1)),\ - $(sort $(foreach v,$(filter %_value,$(filter $(1)_%,$(.VARIABLES))),$(if $(call _undefined?,$(v)),,$(v)))),\ - $($(1)_value))) - - -# Visualize Objects in memory -__var_name = $(word 2,$(subst _, ,$(1)))_$(word 3,$(subst _, ,$(1))) -__var_idx := 0 -__var_print = $(foreach v,$(1),\ - $(foreach var,$(call __var_name,$(v)),\ - $(if $(or $(call _list?,$(v)),$(call _vector?,$(v))),\ - $(info $(2)$(var):)\ - $(eval __var_idx := $(call int_add,1,$(__var_idx)))\ - $(foreach lidx,__lidx_$(__var_idx),\ - $(eval $(lidx) := 0)\ - $(foreach val,$($(v)_value),\ - $(call __var_print,$(val),$(2)$(SPACE)$(SPACE)$($(lidx)): )\ - $(eval $(lidx) := $(call int_add,1,$($(lidx)))))),\ - $(if $(call _hash_map?,$(v)),\ - $(info $(2)$(var):)\ - $(foreach vkey,$(filter $(v)_%,$(.VARIABLES)),\ - $(foreach key,$(word 4,$(subst _, ,$(vkey))),\ - $(info $(2)$(SPACE)$(SPACE)$(subst $(__equal),=,$(key)): )\ - $(call __var_print,$($(vkey)),$(2)$(SPACE)$(SPACE)$(SPACE)$(SPACE)))),\ - $(if $(call _symbol?,$(v)),\ - $(info $(2)$(var): $($(v)_value)),\ - $(if $(call _keyword?,$(v)),\ - $(info $(2)$(var): $($(v)_value)),\ - $(if $(call _number?,$(v)),\ - $(info $(2)$(var): $(call int_decode,$($(v)_value))),\ - $(if $(call _nil?,$(v)),\ - $(info $(2)nil),\ - $(if $(call _function?,$(v)),\ - $(if $(word 6,$(value $(v)_value)),\ - $(info $(2)$(var): $(wordlist 1,5,$(value $(v)_value))...),\ - $(info $(2)$(var): $(value $(v)_value))),\ - $(info $(2)$(var): ...)))))))))) - -_visualize_memory = $(foreach var,$(sort $(foreach vv,$(filter $(__obj_magic)_%,$(.VARIABLES)),$(call __var_name,$(vv)))),$(call __var_print,$(__obj_magic)_$(var))) - - -# Errors/Exceptions -__ERROR := -_error = $(strip $(eval __ERROR := $(call _string,$(1)))) - - -# Constant atomic values -__undefined = $(__obj_magic)_undf_0 -__nil = $(__obj_magic)__nil_0 -__true = $(__obj_magic)_true_0 -__false = $(__obj_magic)_fals_0 - - -# General functions - -# Return the type of the object (or "make" if it's not a object -_obj_type = $(strip \ - $(if $(filter $(__obj_magic)_symb_%,$(1)),symbol,\ - $(if $(filter $(__obj_magic)_list_%,$(1)),list,\ - $(if $(filter $(__obj_magic)_numb_%,$(1)),number,\ - $(if $(filter $(__obj_magic)_func_%,$(1)),function,\ - $(if $(filter $(__obj_magic)_strn_%,$(1)),\ - $(if $(filter $(__keyword)%,$($(1)_value)),keyword,string),\ - $(if $(filter $(__obj_magic)__nil_%,$(1)),nil,\ - $(if $(filter $(__obj_magic)_true_%,$(1)),true,\ - $(if $(filter $(__obj_magic)_fals_%,$(1)),false,\ - $(if $(filter $(__obj_magic)_vect_%,$(1)),vector,\ - $(if $(filter $(__obj_magic)_atom_%,$(1)),atom,\ - $(if $(filter $(__obj_magic)_hmap_%,$(1)),hash_map,\ - $(if $(filter $(__obj_magic)_undf_%,$(1)),undefined,\ - make))))))))))))) - -_clone_obj = $(strip \ - $(foreach new_hcode,$(call __new_obj_hash_code),\ - $(foreach new_obj,$(foreach type,$(word 2,$(subst _, ,$(1))),$(__obj_magic)_$(type)_$(new_hcode)),\ - $(if $(filter $(__obj_magic)_hmap_%,$(1)),\ - $(foreach v,$(call __get_obj_values,$(1)),\ - $(eval $(v:$(1)_%=$(new_obj)_%) := $($(v))))\ - $(eval $(new_obj)_size := $($(1)_size)),\ - $(if $(filter $(__obj_magic)_func_%,$(1)),\ - $(eval $(new_obj)_value = $(value $(1)_value)),\ - $(eval $(new_obj)_value := $(strip $($(1)_value)))))\ - $(new_obj)))) - -_hash_equal? = $(strip \ - $(if $(and $(call _EQ,$(foreach v,$(call __get_obj_values,$(1)),$(word 4,$(subst _, ,$(v)))),$(foreach v,$(call __get_obj_values,$(2)),$(word 4,$(subst _, ,$(v))))),\ - $(call _EQ,$(call _count,$(1)),$(words $(call gmsl_pairmap,_equal?,$(foreach v,$(call __get_obj_values,$(1)),$($(v))),$(foreach v,$(call __get_obj_values,$(2)),$($(v))))))),\ - $(__true),)) - -_equal? = $(strip \ - $(foreach ot1,$(call _obj_type,$(1)),$(foreach ot2,$(call _obj_type,$(2)),\ - $(if $(or $(call _EQ,$(ot1),$(ot2)),\ - $(and $(call _sequential?,$(1)),$(call _sequential?,$(2)))),\ - $(if $(or $(call _string?,$(1)),$(call _symbol?,$(1)),$(call _keyword?,$(1)),$(call _number?,$(1))),\ - $(call _EQ,$($(1)_value),$($(2)_value)),\ - $(if $(call _hash_map?,$(1)),\ - $(call _hash_equal?,$(1),$(2)),\ - $(if $(or $(call _vector?,$(1)),$(call _list?,$(1))),\ - $(if $(and $(call _EQ,$(call _count,$(1)),$(call _count,$(2))),\ - $(call _EQ,$(call _count,$(1)),$(words $(call gmsl_pairmap,_equal?,$(call __get_obj_values,$(1)),$(call __get_obj_values,$(2)))))),\ - $(__true),),\ - $(call _EQ,$(1),$(2))))))))) - -_undefined? = $(or $(call _EQ,undefined,$(origin $(1))),$(filter $(__undefined),$($(1)))) - -_nil? = $(if $(filter $(__obj_magic)__nil_%,$(1)),$(__true),) - -_true? = $(if $(filter $(__obj_magic)_true_%,$(1)),$(__true),) - -_false? = $(if $(filter $(__obj_magic)_fals_%,$(1)),$(__true),) - - -# Symbols -_symbol = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_symb_$(hcode)$(eval $(__obj_magic)_symb_$(hcode)_value := $(1))) -_symbol? = $(if $(filter $(__obj_magic)_symb_%,$(1)),$(__true),) - - -# Keywords -_keyword = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_strn_$(hcode)$(eval $(__obj_magic)_strn_$(hcode)_value := $(__keyword)$(1))) -_keyword? = $(if $(filter $(__obj_magic)_strn_%,$(1)),$(if $(filter $(__keyword)%,$($(1)_value)),$(__true),)) - - -# Numbers -_pnumber = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_numb_$(hcode)$(eval $(__obj_magic)_numb_$(hcode)_value := $(1))) -_number = $(call _pnumber,$(call int_encode,$(1))) -_number? = $(if $(filter $(__obj_magic)_numb_%,$(1)),$(__true),) - - -# Strings -__string = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_strn_$(hcode)$(eval $(__obj_magic)_strn_$(hcode)_value := $(1))) -_string = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_strn_$(hcode)$(eval $(__obj_magic)_strn_$(hcode)_value := $(call str_encode,$(1)))) -_string? = $(if $(filter $(__obj_magic)_strn_%,$(1)),$(__true),) - -# Functions - -# Return a function object. The first parameter is the -# function/macro 'source'. Note that any $ must be escaped as $$ to be -# preserved and become positional arguments for when the -# function/macro is later invoked. -_function = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_func_$(hcode)$(eval $(__obj_magic)_func_$(hcode)_value = $(1))) -_function? = $(if $(filter $(__obj_magic)_func_%,$(1)),$(__true),) - -# Takes a function name and a list object of arguments and invokes -# the function with space separated arguments -_apply = $(call $(1),$($(2)_value)) - -# Takes a function object and a list object of arguments and invokes -# the function with space separated arguments -apply = $(call $(1)_value,$($(2)_value)) - - -# Lists -_list = $(word 1,$(foreach new_list,$(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_list_$(hcode)),$(new_list) $(eval $(new_list)_value := $1))) -_list? = $(if $(filter $(__obj_magic)_list_%,$(1)),$(__true),) - - -# Vectors (same as lists for now) -_vector = $(word 1,$(foreach new_vect,$(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_vect_$(hcode)),$(new_vect) $(eval $(new_vect)_value := $1))) -_vector? = $(if $(filter $(__obj_magic)_vect_%,$(1)),$(__true),) - - -# Hash maps (associative arrays) -_hash_map = $(word 1,$(foreach hcode,$(call __new_obj_hash_code),$(foreach new_hmap,$(__obj_magic)_hmap_$(hcode),$(new_hmap) $(eval $(new_hmap)_size := 0) $(if $(1),$(call _assoc_seq!,$(new_hmap),$(1)))))) -_hash_map? = $(if $(filter $(__obj_magic)_hmap_%,$(1)),$(__true),) - -# Set multiple key/values in a map -_assoc_seq! = $(call _assoc!,$(1),$(call str_decode,$($(word 1,$(2))_value)),$(word 2,$(2)))$(if $(word 3,$(2)),$(call _assoc_seq!,$(1),$(wordlist 3,$(words $(2)),$(2))),) - -_dissoc_seq! = $(foreach key,$(2),\ - $(call _dissoc!,$(1),$(call str_decode,$($(key)_value)))) - -# set a key/value in the hash map -_assoc! = $(foreach k,$(subst =,$(__equal),$(2)),$(if $(call _undefined?,$(1)_$(k)_value),$(eval $(1)_size := $(call int_add,$($(1)_size),1)),)$(eval $(1)_$(k)_value := $(3))$(1)) - -# unset a key in the hash map -_dissoc! = $(foreach k,$(subst =,$(__equal),$(2)),$(if $(call _undefined?,$(1)_$(k)_value),,$(eval $(1)_$(k)_value := $(__undefined))$(eval $(1)_size := $(call int_sub,$($(1)_size),1))))$(1) - -# Hash map and vector functions - -# retrieve the value of a plain string key from the hash map, or -# retrive a vector by plain index -_get = $(strip \ - $(if $(call _hash_map?,$(1)),\ - $(foreach k,$(subst =,$(__equal),$(2)),$(if $(call _undefined?,$(1)_$(k)_value),,$($(1)_$(k)_value))),\ - $(if $(call _vector?,$(1)),\ - $(word $(call int_add,1,$(2)),$($(1)_value)),\ - ,))) - -_contains? = $(strip \ - $(if $(call _hash_map?,$(1)),\ - $(foreach k,$(subst =,$(__equal),$(2)),$(if $(call _undefined?,$(1)_$(k)_value),,$(__true))),\ - $(if $(call _vector?,$(1)),\ - $(if $(word $(call int_add,1,$(2)),$($(1)_value)),$(__true),),\ - ,))) - - -# sequence operations - -_sequential? = $(if $(filter $(__obj_magic)_list_% $(__obj_magic)_vect_%,$(1)),$(__true),) - -_nth = $(word $(call int_add,1,$(2)),$($(1)_value)) - -# conj that mutates a sequence in-place to append the call arguments -_conj! = $(eval $(1)_value := $(strip $($(1)_value) $2 $3 $4 $5 $6 $7 $8 $9 $(10) $(11) $(12) $(13) $(14) $(15) $(16) $(17) $(18) $(19) $(20)))$(1) - -_count = $(strip \ - $(if $(call _hash_map?,$(1)),\ - $($(1)_size),\ - $(words $($(1)_value)))) - -_empty? = $(call _EQ,0,$(_count)) - -# Creates a new vector/list of the everything after but the first -# element -srest = $(word 1,$(foreach new_list,$(call _list),\ - $(new_list) \ - $(eval $(new_list)_value := $(wordlist 2,$(words $($(1)_value)),$($(1)_value))))) - -# maps a make function over a list object, using mutating _conj! -_smap = $(word 1,\ - $(foreach new_list,$(call _list),\ - $(new_list)\ - $(foreach v,$(call __get_obj_values,$(2)),\ - $(call _conj!,$(new_list),$(call $(1),$(v),$(3),$(4)))))) - -# Same as _smap but returns a vector -_smap_vec = $(word 1,\ - $(foreach new_vector,$(call _vector),\ - $(new_vector)\ - $(foreach v,$(call __get_obj_values,$(2)),\ - $(call _conj!,$(new_vector),$(call $(1),$(v),$(3),$(4)))))) - - -# atoms - -_atom? = $(if $(filter $(__obj_magic)_atom_%,$(1)),$(__true),) - - -endif +# +# mal (Make a Lisp) object types +# + +ifndef __mal_types_included +__mal_types_included := true + +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)gmsl.mk +include $(_TOP_DIR)util.mk +include $(_TOP_DIR)numbers.mk + + +# Low-level type implemenation + +# magic is \u2344 \u204a +__obj_magic = ⍄⁊ +# \u2256 +__equal = ≛ +__keyword = ʞ +__obj_hash_code = 0 + +__new_obj_hash_code = $(eval __obj_hash_code := $(call int_add,1,$(__obj_hash_code)))$(__obj_hash_code) + +__new_obj = $(__obj_magic)_$(1)_$(call __new_obj_hash_code) + +__new_obj_like = $(foreach type,$(word 2,$(subst _, ,$(1))),$(__obj_magic)_$(type)_$(__new_obj_hash_code)) + +__get_obj_values = $(strip \ + $(if $(filter $(__obj_magic)_hmap_%,$(1)),\ + $(sort $(foreach v,$(filter %_value,$(filter $(1)_%,$(.VARIABLES))),$(if $(call _undefined?,$(v)),,$(v)))),\ + $($(1)_value))) + + +# Visualize Objects in memory +__var_name = $(word 2,$(subst _, ,$(1)))_$(word 3,$(subst _, ,$(1))) +__var_idx := 0 +__var_print = $(foreach v,$(1),\ + $(foreach var,$(call __var_name,$(v)),\ + $(if $(or $(call _list?,$(v)),$(call _vector?,$(v))),\ + $(info $(2)$(var):)\ + $(eval __var_idx := $(call int_add,1,$(__var_idx)))\ + $(foreach lidx,__lidx_$(__var_idx),\ + $(eval $(lidx) := 0)\ + $(foreach val,$($(v)_value),\ + $(call __var_print,$(val),$(2)$(SPACE)$(SPACE)$($(lidx)): )\ + $(eval $(lidx) := $(call int_add,1,$($(lidx)))))),\ + $(if $(call _hash_map?,$(v)),\ + $(info $(2)$(var):)\ + $(foreach vkey,$(filter $(v)_%,$(.VARIABLES)),\ + $(foreach key,$(word 4,$(subst _, ,$(vkey))),\ + $(info $(2)$(SPACE)$(SPACE)$(subst $(__equal),=,$(key)): )\ + $(call __var_print,$($(vkey)),$(2)$(SPACE)$(SPACE)$(SPACE)$(SPACE)))),\ + $(if $(call _symbol?,$(v)),\ + $(info $(2)$(var): $($(v)_value)),\ + $(if $(call _keyword?,$(v)),\ + $(info $(2)$(var): $($(v)_value)),\ + $(if $(call _number?,$(v)),\ + $(info $(2)$(var): $(call int_decode,$($(v)_value))),\ + $(if $(call _nil?,$(v)),\ + $(info $(2)nil),\ + $(if $(call _function?,$(v)),\ + $(if $(word 6,$(value $(v)_value)),\ + $(info $(2)$(var): $(wordlist 1,5,$(value $(v)_value))...),\ + $(info $(2)$(var): $(value $(v)_value))),\ + $(info $(2)$(var): ...)))))))))) + +_visualize_memory = $(foreach var,$(sort $(foreach vv,$(filter $(__obj_magic)_%,$(.VARIABLES)),$(call __var_name,$(vv)))),$(call __var_print,$(__obj_magic)_$(var))) + + +# Errors/Exceptions +__ERROR := +_error = $(strip $(eval __ERROR := $(call _string,$(1)))) + + +# Constant atomic values +__undefined = $(__obj_magic)_undf_0 +__nil = $(__obj_magic)__nil_0 +__true = $(__obj_magic)_true_0 +__false = $(__obj_magic)_fals_0 + + +# General functions + +# Return the type of the object (or "make" if it's not a object +_obj_type = $(strip \ + $(if $(filter $(__obj_magic)_symb_%,$(1)),symbol,\ + $(if $(filter $(__obj_magic)_list_%,$(1)),list,\ + $(if $(filter $(__obj_magic)_numb_%,$(1)),number,\ + $(if $(filter $(__obj_magic)_func_%,$(1)),function,\ + $(if $(filter $(__obj_magic)_strn_%,$(1)),\ + $(if $(filter $(__keyword)%,$($(1)_value)),keyword,string),\ + $(if $(filter $(__obj_magic)__nil_%,$(1)),nil,\ + $(if $(filter $(__obj_magic)_true_%,$(1)),true,\ + $(if $(filter $(__obj_magic)_fals_%,$(1)),false,\ + $(if $(filter $(__obj_magic)_vect_%,$(1)),vector,\ + $(if $(filter $(__obj_magic)_atom_%,$(1)),atom,\ + $(if $(filter $(__obj_magic)_hmap_%,$(1)),hash_map,\ + $(if $(filter $(__obj_magic)_undf_%,$(1)),undefined,\ + make))))))))))))) + +_clone_obj = $(strip \ + $(foreach new_hcode,$(call __new_obj_hash_code),\ + $(foreach new_obj,$(foreach type,$(word 2,$(subst _, ,$(1))),$(__obj_magic)_$(type)_$(new_hcode)),\ + $(if $(filter $(__obj_magic)_hmap_%,$(1)),\ + $(foreach v,$(call __get_obj_values,$(1)),\ + $(eval $(v:$(1)_%=$(new_obj)_%) := $($(v))))\ + $(eval $(new_obj)_size := $($(1)_size)),\ + $(if $(filter $(__obj_magic)_func_%,$(1)),\ + $(eval $(new_obj)_value = $(value $(1)_value)),\ + $(eval $(new_obj)_value := $(strip $($(1)_value)))))\ + $(new_obj)))) + +_hash_equal? = $(strip \ + $(if $(and $(call _EQ,$(foreach v,$(call __get_obj_values,$(1)),$(word 4,$(subst _, ,$(v)))),$(foreach v,$(call __get_obj_values,$(2)),$(word 4,$(subst _, ,$(v))))),\ + $(call _EQ,$(call _count,$(1)),$(words $(call gmsl_pairmap,_equal?,$(foreach v,$(call __get_obj_values,$(1)),$($(v))),$(foreach v,$(call __get_obj_values,$(2)),$($(v))))))),\ + $(__true),)) + +_equal? = $(strip \ + $(foreach ot1,$(call _obj_type,$(1)),$(foreach ot2,$(call _obj_type,$(2)),\ + $(if $(or $(call _EQ,$(ot1),$(ot2)),\ + $(and $(call _sequential?,$(1)),$(call _sequential?,$(2)))),\ + $(if $(or $(call _string?,$(1)),$(call _symbol?,$(1)),$(call _keyword?,$(1)),$(call _number?,$(1))),\ + $(call _EQ,$($(1)_value),$($(2)_value)),\ + $(if $(call _hash_map?,$(1)),\ + $(call _hash_equal?,$(1),$(2)),\ + $(if $(or $(call _vector?,$(1)),$(call _list?,$(1))),\ + $(if $(and $(call _EQ,$(call _count,$(1)),$(call _count,$(2))),\ + $(call _EQ,$(call _count,$(1)),$(words $(call gmsl_pairmap,_equal?,$(call __get_obj_values,$(1)),$(call __get_obj_values,$(2)))))),\ + $(__true),),\ + $(call _EQ,$(1),$(2))))))))) + +_undefined? = $(or $(call _EQ,undefined,$(origin $(1))),$(filter $(__undefined),$($(1)))) + +_nil? = $(if $(filter $(__obj_magic)__nil_%,$(1)),$(__true),) + +_true? = $(if $(filter $(__obj_magic)_true_%,$(1)),$(__true),) + +_false? = $(if $(filter $(__obj_magic)_fals_%,$(1)),$(__true),) + + +# Symbols +_symbol = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_symb_$(hcode)$(eval $(__obj_magic)_symb_$(hcode)_value := $(1))) +_symbol? = $(if $(filter $(__obj_magic)_symb_%,$(1)),$(__true),) + + +# Keywords +_keyword = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_strn_$(hcode)$(eval $(__obj_magic)_strn_$(hcode)_value := $(__keyword)$(1))) +_keyword? = $(if $(filter $(__obj_magic)_strn_%,$(1)),$(if $(filter $(__keyword)%,$($(1)_value)),$(__true),)) + + +# Numbers +_pnumber = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_numb_$(hcode)$(eval $(__obj_magic)_numb_$(hcode)_value := $(1))) +_number = $(call _pnumber,$(call int_encode,$(1))) +_number? = $(if $(filter $(__obj_magic)_numb_%,$(1)),$(__true),) + + +# Strings +__string = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_strn_$(hcode)$(eval $(__obj_magic)_strn_$(hcode)_value := $(1))) +_string = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_strn_$(hcode)$(eval $(__obj_magic)_strn_$(hcode)_value := $(call str_encode,$(1)))) +_string? = $(if $(filter $(__obj_magic)_strn_%,$(1)),$(__true),) + +# Functions + +# Return a function object. The first parameter is the +# function/macro 'source'. Note that any $ must be escaped as $$ to be +# preserved and become positional arguments for when the +# function/macro is later invoked. +_function = $(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_func_$(hcode)$(eval $(__obj_magic)_func_$(hcode)_value = $(1))) +_function? = $(if $(filter $(__obj_magic)_func_%,$(1)),$(__true),) + +# Takes a function name and a list object of arguments and invokes +# the function with space separated arguments +_apply = $(call $(1),$($(2)_value)) + +# Takes a function object and a list object of arguments and invokes +# the function with space separated arguments +apply = $(call $(1)_value,$($(2)_value)) + + +# Lists +_list = $(word 1,$(foreach new_list,$(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_list_$(hcode)),$(new_list) $(eval $(new_list)_value := $1))) +_list? = $(if $(filter $(__obj_magic)_list_%,$(1)),$(__true),) + + +# Vectors (same as lists for now) +_vector = $(word 1,$(foreach new_vect,$(foreach hcode,$(call __new_obj_hash_code),$(__obj_magic)_vect_$(hcode)),$(new_vect) $(eval $(new_vect)_value := $1))) +_vector? = $(if $(filter $(__obj_magic)_vect_%,$(1)),$(__true),) + + +# Hash maps (associative arrays) +_hash_map = $(word 1,$(foreach hcode,$(call __new_obj_hash_code),$(foreach new_hmap,$(__obj_magic)_hmap_$(hcode),$(new_hmap) $(eval $(new_hmap)_size := 0) $(if $(1),$(call _assoc_seq!,$(new_hmap),$(1)))))) +_hash_map? = $(if $(filter $(__obj_magic)_hmap_%,$(1)),$(__true),) + +# Set multiple key/values in a map +_assoc_seq! = $(call _assoc!,$(1),$(call str_decode,$($(word 1,$(2))_value)),$(word 2,$(2)))$(if $(word 3,$(2)),$(call _assoc_seq!,$(1),$(wordlist 3,$(words $(2)),$(2))),) + +_dissoc_seq! = $(foreach key,$(2),\ + $(call _dissoc!,$(1),$(call str_decode,$($(key)_value)))) + +# set a key/value in the hash map +_assoc! = $(foreach k,$(subst =,$(__equal),$(2)),$(if $(call _undefined?,$(1)_$(k)_value),$(eval $(1)_size := $(call int_add,$($(1)_size),1)),)$(eval $(1)_$(k)_value := $(3))$(1)) + +# unset a key in the hash map +_dissoc! = $(foreach k,$(subst =,$(__equal),$(2)),$(if $(call _undefined?,$(1)_$(k)_value),,$(eval $(1)_$(k)_value := $(__undefined))$(eval $(1)_size := $(call int_sub,$($(1)_size),1))))$(1) + +# Hash map and vector functions + +# retrieve the value of a plain string key from the hash map, or +# retrive a vector by plain index +_get = $(strip \ + $(if $(call _hash_map?,$(1)),\ + $(foreach k,$(subst =,$(__equal),$(2)),$(if $(call _undefined?,$(1)_$(k)_value),,$($(1)_$(k)_value))),\ + $(if $(call _vector?,$(1)),\ + $(word $(call int_add,1,$(2)),$($(1)_value)),\ + ,))) + +_contains? = $(strip \ + $(if $(call _hash_map?,$(1)),\ + $(foreach k,$(subst =,$(__equal),$(2)),$(if $(call _undefined?,$(1)_$(k)_value),,$(__true))),\ + $(if $(call _vector?,$(1)),\ + $(if $(word $(call int_add,1,$(2)),$($(1)_value)),$(__true),),\ + ,))) + + +# sequence operations + +_sequential? = $(if $(filter $(__obj_magic)_list_% $(__obj_magic)_vect_%,$(1)),$(__true),) + +_nth = $(word $(call int_add,1,$(2)),$($(1)_value)) + +# conj that mutates a sequence in-place to append the call arguments +_conj! = $(eval $(1)_value := $(strip $($(1)_value) $2 $3 $4 $5 $6 $7 $8 $9 $(10) $(11) $(12) $(13) $(14) $(15) $(16) $(17) $(18) $(19) $(20)))$(1) + +_count = $(strip \ + $(if $(call _hash_map?,$(1)),\ + $($(1)_size),\ + $(words $($(1)_value)))) + +_empty? = $(call _EQ,0,$(_count)) + +# Creates a new vector/list of the everything after but the first +# element +srest = $(word 1,$(foreach new_list,$(call _list),\ + $(new_list) \ + $(eval $(new_list)_value := $(wordlist 2,$(words $($(1)_value)),$($(1)_value))))) + +# maps a make function over a list object, using mutating _conj! +_smap = $(word 1,\ + $(foreach new_list,$(call _list),\ + $(new_list)\ + $(foreach v,$(call __get_obj_values,$(2)),\ + $(call _conj!,$(new_list),$(call $(1),$(v),$(3),$(4)))))) + +# Same as _smap but returns a vector +_smap_vec = $(word 1,\ + $(foreach new_vector,$(call _vector),\ + $(new_vector)\ + $(foreach v,$(call __get_obj_values,$(2)),\ + $(call _conj!,$(new_vector),$(call $(1),$(v),$(3),$(4)))))) + + +# atoms + +_atom? = $(if $(filter $(__obj_magic)_atom_%,$(1)),$(__true),) + + +endif diff --git a/impls/make/util.mk b/impls/make/util.mk index bee3e319fa..99f8a93e33 100644 --- a/impls/make/util.mk +++ b/impls/make/util.mk @@ -1,99 +1,99 @@ -# -# mal (Make Lisp) utility functions/definitions -# - -ifndef __mal_util_included -__mal_util_included := true - -_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) -include $(_TOP_DIR)gmsl.mk - -SEMI := ; -COMMA := , -COLON := : -LCURLY := { -RCURLY := } -LPAREN := ( -RPAREN := ) -LBRACKET := [ -RBRACKET := ] -DQUOTE := "# " -SLASH := $(strip \ ) -ESC_DQUOTE := $(SLASH)$(DQUOTE) -ESC_N := $(SLASH)n -SQUOTE := '# ' -QQUOTE := `# ` -SPACE := -SPACE += -MINUS := - -NUMBERS := 0 1 2 3 4 5 6 7 8 9 -UNQUOTE := ~ -SPLICE_UNQUOTE := ~@ -define NEWLINE - - -endef -CARET := ^ -ATSIGN := @ - -# \u00ab -_LP := « -# \u00bb -_RP := » -# \u00ed -_LC := í -# \u00ec -_RC := ì -## \u00a7 -_SP := § -## \u00ae -_SUQ := ® -## \u015e -_DOL := Ş -## \u00b6 -_NL := ¶ -## \u00a8 -###_EDQ := ¨ - - -# -# Utility functions -# - -_EQ = $(if $(subst x$1,,x$2)$(subst x$2,,x$1),,true) - -_NOT = $(if $1,,true) - -# take a list of words and join them with a separator -# params: words, seperator, result -_join = $(strip \ - $(if $(strip $(1)),\ - $(if $(strip $(3)),\ - $(call _join,$(wordlist 2,$(words $(1)),$(1)),$(2),$(3)$(2)$(word 1,$(1))),\ - $(call _join,$(wordlist 2,$(words $(1)),$(1)),$(2),$(word 1,$(1)))),\ - $(3))) - -#$(info _join(1 2 3 4): [$(call _join,1 2 3 4)]) -#$(info _join(1 2 3 4,X): [$(call _join,1 2 3 4, )]) -#$(info _join(1): [$(call _join,1)]) -#$(info _join(): [$(call _join,)]) - -# reverse list of words -_reverse = $(if $(1),$(call _reverse,$(wordlist 2,$(words $(1)),$(1)))) $(firstword $(1)) - -#$(info reverse(1 2 3 4 5): $(call reverse,1 2 3 4 5)) - -# str_encode: take a string and return an encoded version of it with -# every character separated by a space and special characters replaced -# with special Unicode characters -str_encode = $(strip $(eval __temp := $$(subst $$$$,$(_DOL) ,$$(subst $(SPLICE_UNQUOTE),$(_SUQ) ,$$(subst $$(LPAREN),$$(_LP) ,$$(subst $$(RPAREN),$$(_RP) ,$$(subst $$(LCURLY),$$(_LC) ,$$(subst $$(RCURLY),$$(_RC) ,$$(subst $$(NEWLINE),$$(_NL) ,$$(subst $$(SPACE),$(_SP) ,$$1)))))))))$(foreach a,$(gmsl_characters),$(eval __temp := $$(subst $$a,$$a$$(SPACE),$(__temp))))$(__temp)) - -# str_decode: take an encoded string an return an unencoded version of -# it by replacing the special Unicode charactes with the real -# characters and with all characters joined into a regular string -str_decode = $(subst $(_SP),$(SPACE),$(subst $(_NL),$(NEWLINE),$(subst $(_LC),$(LCURLY),$(subst $(_RC),$(RCURLY),$(subst $(_LP),$(LPAREN),$(subst $(_RP),$(RPAREN),$(subst $(_SUQ),$(SPLICE_UNQUOTE),$(subst $(_DOL),$$,$(strip $(call _join,$(1))))))))))) - -# Read a whole file substituting newlines with $(_NL) -_read_file = $(subst $(_NL),$(NEWLINE),$(shell out=""; while read -r l; do out="$${out}$${l}$(_NL)"; done < $(1); echo "$$out")) - -endif +# +# mal (Make Lisp) utility functions/definitions +# + +ifndef __mal_util_included +__mal_util_included := true + +_TOP_DIR := $(dir $(lastword $(MAKEFILE_LIST))) +include $(_TOP_DIR)gmsl.mk + +SEMI := ; +COMMA := , +COLON := : +LCURLY := { +RCURLY := } +LPAREN := ( +RPAREN := ) +LBRACKET := [ +RBRACKET := ] +DQUOTE := "# " +SLASH := $(strip \ ) +ESC_DQUOTE := $(SLASH)$(DQUOTE) +ESC_N := $(SLASH)n +SQUOTE := '# ' +QQUOTE := `# ` +SPACE := +SPACE += +MINUS := - +NUMBERS := 0 1 2 3 4 5 6 7 8 9 +UNQUOTE := ~ +SPLICE_UNQUOTE := ~@ +define NEWLINE + + +endef +CARET := ^ +ATSIGN := @ + +# \u00ab +_LP := « +# \u00bb +_RP := » +# \u00ed +_LC := í +# \u00ec +_RC := ì +## \u00a7 +_SP := § +## \u00ae +_SUQ := ® +## \u015e +_DOL := Ş +## \u00b6 +_NL := ¶ +## \u00a8 +###_EDQ := ¨ + + +# +# Utility functions +# + +_EQ = $(if $(subst x$1,,x$2)$(subst x$2,,x$1),,true) + +_NOT = $(if $1,,true) + +# take a list of words and join them with a separator +# params: words, seperator, result +_join = $(strip \ + $(if $(strip $(1)),\ + $(if $(strip $(3)),\ + $(call _join,$(wordlist 2,$(words $(1)),$(1)),$(2),$(3)$(2)$(word 1,$(1))),\ + $(call _join,$(wordlist 2,$(words $(1)),$(1)),$(2),$(word 1,$(1)))),\ + $(3))) + +#$(info _join(1 2 3 4): [$(call _join,1 2 3 4)]) +#$(info _join(1 2 3 4,X): [$(call _join,1 2 3 4, )]) +#$(info _join(1): [$(call _join,1)]) +#$(info _join(): [$(call _join,)]) + +# reverse list of words +_reverse = $(if $(1),$(call _reverse,$(wordlist 2,$(words $(1)),$(1)))) $(firstword $(1)) + +#$(info reverse(1 2 3 4 5): $(call reverse,1 2 3 4 5)) + +# str_encode: take a string and return an encoded version of it with +# every character separated by a space and special characters replaced +# with special Unicode characters +str_encode = $(strip $(eval __temp := $$(subst $$$$,$(_DOL) ,$$(subst $(SPLICE_UNQUOTE),$(_SUQ) ,$$(subst $$(LPAREN),$$(_LP) ,$$(subst $$(RPAREN),$$(_RP) ,$$(subst $$(LCURLY),$$(_LC) ,$$(subst $$(RCURLY),$$(_RC) ,$$(subst $$(NEWLINE),$$(_NL) ,$$(subst $$(SPACE),$(_SP) ,$$1)))))))))$(foreach a,$(gmsl_characters),$(eval __temp := $$(subst $$a,$$a$$(SPACE),$(__temp))))$(__temp)) + +# str_decode: take an encoded string an return an unencoded version of +# it by replacing the special Unicode charactes with the real +# characters and with all characters joined into a regular string +str_decode = $(subst $(_SP),$(SPACE),$(subst $(_NL),$(NEWLINE),$(subst $(_LC),$(LCURLY),$(subst $(_RC),$(RCURLY),$(subst $(_LP),$(LPAREN),$(subst $(_RP),$(RPAREN),$(subst $(_SUQ),$(SPLICE_UNQUOTE),$(subst $(_DOL),$$,$(strip $(call _join,$(1))))))))))) + +# Read a whole file substituting newlines with $(_NL) +_read_file = $(subst $(_NL),$(NEWLINE),$(shell out=""; while read -r l; do out="$${out}$${l}$(_NL)"; done < $(1); echo "$$out")) + +endif diff --git a/impls/mal/Dockerfile b/impls/mal/Dockerfile index f7677e91c8..725fd2586b 100644 --- a/impls/mal/Dockerfile +++ b/impls/mal/Dockerfile @@ -1,34 +1,34 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/impls/mal/Makefile b/impls/mal/Makefile index 13b82f790f..9494e4c56a 100644 --- a/impls/mal/Makefile +++ b/impls/mal/Makefile @@ -1,10 +1,10 @@ -all: mal.mal - -mal.mal: stepA_mal.mal - cp $< $@ - -%.mal: - @true - -clean: - rm -f mal.mal +all: mal.mal + +mal.mal: stepA_mal.mal + cp $< $@ + +%.mal: + @true + +clean: + rm -f mal.mal diff --git a/impls/mal/core.mal b/impls/mal/core.mal index 6592cac914..6608eb9930 100644 --- a/impls/mal/core.mal +++ b/impls/mal/core.mal @@ -1,11 +1,11 @@ -(def! _macro? (fn* [x] - (if (map? x) - (contains? x :__MAL_MACRO__) - false))) - -(def! core_ns '[* + - / < <= = > >= apply assoc atom atom? concat conj - cons contains? count deref dissoc empty? false? first fn? get - hash-map keys keyword keyword? list list? map map? meta nil? - nth number? pr-str println prn read-string readline reset! rest seq - sequential? slurp str string? swap! symbol symbol? throw time-ms - true? vals vec vector vector? with-meta]) +(def! _macro? (fn* [x] + (if (map? x) + (contains? x :__MAL_MACRO__) + false))) + +(def! core_ns '[* + - / < <= = > >= apply assoc atom atom? concat conj + cons contains? count deref dissoc empty? false? first fn? get + hash-map keys keyword keyword? list list? map map? meta nil? + nth number? pr-str println prn read-string readline reset! rest seq + sequential? slurp str string? swap! symbol symbol? throw time-ms + true? vals vec vector vector? with-meta]) diff --git a/impls/mal/env.mal b/impls/mal/env.mal index b802ddad54..e5edfd5c03 100644 --- a/impls/mal/env.mal +++ b/impls/mal/env.mal @@ -1,40 +1,40 @@ -;; An environment is an atom referencing a map where keys are strings -;; instead of symbols. The outer environment is the value associated -;; with the normally invalid :outer key. - -;; Private helper for new-env. -(def! bind-env (fn* [env b e] - (if (empty? b) - env - (let* [b0 (first b)] - (if (= '& b0) - (assoc env (str (nth b 1)) e) - (bind-env (assoc env (str b0) (first e)) (rest b) (rest e))))))) - -(def! new-env (fn* [& args] - (if (<= (count args) 1) - (atom {:outer (first args)}) - (atom (apply bind-env {:outer (first args)} (rest args)))))) - -(def! env-find (fn* [env k] - (env-find-str env (str k)))) - -;; Private helper for env-find and env-get. -(def! env-find-str (fn* [env ks] - (if env - (let* [data @env] - (if (contains? data ks) - env - (env-find-str (get data :outer) ks)))))) - -(def! env-get (fn* [env k] - (let* [ks (str k) - e (env-find-str env ks)] - (if e - (get @e ks) - (throw (str "'" ks "' not found")))))) - -(def! env-set (fn* [env k v] - (do - (swap! env assoc (str k) v) - v))) +;; An environment is an atom referencing a map where keys are strings +;; instead of symbols. The outer environment is the value associated +;; with the normally invalid :outer key. + +;; Private helper for new-env. +(def! bind-env (fn* [env b e] + (if (empty? b) + env + (let* [b0 (first b)] + (if (= '& b0) + (assoc env (str (nth b 1)) e) + (bind-env (assoc env (str b0) (first e)) (rest b) (rest e))))))) + +(def! new-env (fn* [& args] + (if (<= (count args) 1) + (atom {:outer (first args)}) + (atom (apply bind-env {:outer (first args)} (rest args)))))) + +(def! env-find (fn* [env k] + (env-find-str env (str k)))) + +;; Private helper for env-find and env-get. +(def! env-find-str (fn* [env ks] + (if env + (let* [data @env] + (if (contains? data ks) + env + (env-find-str (get data :outer) ks)))))) + +(def! env-get (fn* [env k] + (let* [ks (str k) + e (env-find-str env ks)] + (if e + (get @e ks) + (throw (str "'" ks "' not found")))))) + +(def! env-set (fn* [env k v] + (do + (swap! env assoc (str k) v) + v))) diff --git a/impls/mal/run b/impls/mal/run index 119ef194f2..05f5942694 100755 --- a/impls/mal/run +++ b/impls/mal/run @@ -1,9 +1,9 @@ -#!/bin/bash -MAL_FILE=../mal/${STEP:-stepA_mal}.mal -export STEP=stepA_mal # force MAL_IMPL to use stepA -case ${MAL_IMPL} in -*-mal) - MAL_IMPL=${MAL_IMPL%%-mal} - MAL_FILE="../mal/stepA_mal.mal ${MAL_FILE}" ;; -esac -exec ./../${MAL_IMPL:-js}/run ${MAL_FILE} "${@}" +#!/bin/bash +MAL_FILE=../mal/${STEP:-stepA_mal}.mal +export STEP=stepA_mal # force MAL_IMPL to use stepA +case ${MAL_IMPL} in +*-mal) + MAL_IMPL=${MAL_IMPL%%-mal} + MAL_FILE="../mal/stepA_mal.mal ${MAL_FILE}" ;; +esac +exec ./../${MAL_IMPL:-js}/run ${MAL_FILE} "${@}" diff --git a/impls/mal/step0_repl.mal b/impls/mal/step0_repl.mal index 837a5fc65e..dcc436086d 100644 --- a/impls/mal/step0_repl.mal +++ b/impls/mal/step0_repl.mal @@ -1,25 +1,25 @@ -;; read -(def! READ (fn* [strng] - strng)) - -;; eval -(def! EVAL (fn* [ast] - ast)) - -;; print -(def! PRINT (fn* [exp] exp)) - -;; repl -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng))))) - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (println (rep line))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(repl-loop "") +;; read +(def! READ (fn* [strng] + strng)) + +;; eval +(def! EVAL (fn* [ast] + ast)) + +;; print +(def! PRINT (fn* [exp] exp)) + +;; repl +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng))))) + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (println (rep line))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(repl-loop "") diff --git a/impls/mal/step1_read_print.mal b/impls/mal/step1_read_print.mal index dd541faa9d..e686cdf7c9 100644 --- a/impls/mal/step1_read_print.mal +++ b/impls/mal/step1_read_print.mal @@ -1,28 +1,28 @@ -;; read -(def! READ read-string) - - -;; eval -(def! EVAL (fn* [ast] - ast)) - -;; print -(def! PRINT pr-str) - -;; repl -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng))))) - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (try* - (println (rep line)) - (catch* exc - (println "Uncaught exception:" exc)))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(repl-loop "") +;; read +(def! READ read-string) + + +;; eval +(def! EVAL (fn* [ast] + ast)) + +;; print +(def! PRINT pr-str) + +;; repl +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng))))) + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (try* + (println (rep line)) + (catch* exc + (println "Uncaught exception:" exc)))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(repl-loop "") diff --git a/impls/mal/step2_eval.mal b/impls/mal/step2_eval.mal index a42c47482f..c899db093c 100644 --- a/impls/mal/step2_eval.mal +++ b/impls/mal/step2_eval.mal @@ -1,70 +1,70 @@ -;; EVAL extends this stack trace when propagating exceptions. If the -;; exception reaches the REPL loop, the full trace is printed. -(def! trace (atom "")) - -;; read -(def! READ read-string) - - -;; eval -(def! eval-ast (fn* [ast env] - ;; (do (prn "eval-ast" ast "/" (keys env)) ) - (cond - (symbol? ast) (let* [res (get env (str ast))] - (if res res (throw (str ast " not found")))) - - (list? ast) (map (fn* [exp] (EVAL exp env)) ast) - - (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) - - (map? ast) (apply hash-map - (apply concat - (map (fn* [k] [k (EVAL (get ast k) env)]) - (keys ast)))) - - "else" ast))) - - -(def! EVAL (fn* [ast env] - ;; (do (prn "EVAL" ast) ) - (try* - (if (not (list? ast)) - (eval-ast ast env) - - ;; apply list - (if (empty? ast) - ast - (let* [el (eval-ast ast env)] - (apply (first el) (rest el))))) - - (catch* exc - (do - (swap! trace str "\n in mal EVAL: " ast) - (throw exc)))))) - -;; print -(def! PRINT pr-str) - -;; repl -(def! repl-env {"+" + - "-" - - "*" * - "/" /}) -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng) repl-env)))) - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (try* - (println (rep line)) - (catch* exc - (do - (println "Uncaught exception:" exc @trace) - (reset! trace ""))))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(repl-loop "") +;; EVAL extends this stack trace when propagating exceptions. If the +;; exception reaches the REPL loop, the full trace is printed. +(def! trace (atom "")) + +;; read +(def! READ read-string) + + +;; eval +(def! eval-ast (fn* [ast env] + ;; (do (prn "eval-ast" ast "/" (keys env)) ) + (cond + (symbol? ast) (let* [res (get env (str ast))] + (if res res (throw (str ast " not found")))) + + (list? ast) (map (fn* [exp] (EVAL exp env)) ast) + + (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) + + (map? ast) (apply hash-map + (apply concat + (map (fn* [k] [k (EVAL (get ast k) env)]) + (keys ast)))) + + "else" ast))) + + +(def! EVAL (fn* [ast env] + ;; (do (prn "EVAL" ast) ) + (try* + (if (not (list? ast)) + (eval-ast ast env) + + ;; apply list + (if (empty? ast) + ast + (let* [el (eval-ast ast env)] + (apply (first el) (rest el))))) + + (catch* exc + (do + (swap! trace str "\n in mal EVAL: " ast) + (throw exc)))))) + +;; print +(def! PRINT pr-str) + +;; repl +(def! repl-env {"+" + + "-" - + "*" * + "/" /}) +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng) repl-env)))) + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (try* + (println (rep line)) + (catch* exc + (do + (println "Uncaught exception:" exc @trace) + (reset! trace ""))))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(repl-loop "") diff --git a/impls/mal/step3_env.mal b/impls/mal/step3_env.mal index ef813b833b..4b307fd033 100644 --- a/impls/mal/step3_env.mal +++ b/impls/mal/step3_env.mal @@ -1,89 +1,89 @@ -(load-file "../mal/env.mal") - -;; EVAL extends this stack trace when propagating exceptions. If the -;; exception reaches the REPL loop, the full trace is printed. -(def! trace (atom "")) - -;; read -(def! READ read-string) - - -;; eval -(def! eval-ast (fn* [ast env] - ;; (do (prn "eval-ast" ast "/" (keys @env)) ) - (cond - (symbol? ast) (env-get env ast) - - (list? ast) (map (fn* [exp] (EVAL exp env)) ast) - - (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) - - (map? ast) (apply hash-map - (apply concat - (map (fn* [k] [k (EVAL (get ast k) env)]) - (keys ast)))) - - "else" ast))) - -(def! LET (fn* [env binds form] - (if (empty? binds) - (EVAL form env) - (do - (env-set env (first binds) (EVAL (nth binds 1) env)) - (LET env (rest (rest binds)) form))))) - -(def! EVAL (fn* [ast env] - ;; (do (prn "EVAL" ast "/" (keys @env)) ) - (try* - (if (not (list? ast)) - (eval-ast ast env) - - ;; apply list - (let* [a0 (first ast)] - (cond - (empty? ast) - ast - - (= 'def! a0) - (env-set env (nth ast 1) (EVAL (nth ast 2) env)) - - (= 'let* a0) - (LET (new-env env) (nth ast 1) (nth ast 2)) - - "else" - (let* [el (eval-ast ast env)] - (apply (first el) (rest el)))))) - - (catch* exc - (do - (swap! trace str "\n in mal EVAL: " ast) - (throw exc)))))) - -;; print -(def! PRINT pr-str) - -;; repl -(def! repl-env (new-env)) -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng) repl-env)))) - -(env-set repl-env "+" +) -(env-set repl-env "-" -) -(env-set repl-env "*" *) -(env-set repl-env "/" /) - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (try* - (println (rep line)) - (catch* exc - (do - (println "Uncaught exception:" exc @trace) - (reset! trace ""))))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(repl-loop "") +(load-file "../mal/env.mal") + +;; EVAL extends this stack trace when propagating exceptions. If the +;; exception reaches the REPL loop, the full trace is printed. +(def! trace (atom "")) + +;; read +(def! READ read-string) + + +;; eval +(def! eval-ast (fn* [ast env] + ;; (do (prn "eval-ast" ast "/" (keys @env)) ) + (cond + (symbol? ast) (env-get env ast) + + (list? ast) (map (fn* [exp] (EVAL exp env)) ast) + + (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) + + (map? ast) (apply hash-map + (apply concat + (map (fn* [k] [k (EVAL (get ast k) env)]) + (keys ast)))) + + "else" ast))) + +(def! LET (fn* [env binds form] + (if (empty? binds) + (EVAL form env) + (do + (env-set env (first binds) (EVAL (nth binds 1) env)) + (LET env (rest (rest binds)) form))))) + +(def! EVAL (fn* [ast env] + ;; (do (prn "EVAL" ast "/" (keys @env)) ) + (try* + (if (not (list? ast)) + (eval-ast ast env) + + ;; apply list + (let* [a0 (first ast)] + (cond + (empty? ast) + ast + + (= 'def! a0) + (env-set env (nth ast 1) (EVAL (nth ast 2) env)) + + (= 'let* a0) + (LET (new-env env) (nth ast 1) (nth ast 2)) + + "else" + (let* [el (eval-ast ast env)] + (apply (first el) (rest el)))))) + + (catch* exc + (do + (swap! trace str "\n in mal EVAL: " ast) + (throw exc)))))) + +;; print +(def! PRINT pr-str) + +;; repl +(def! repl-env (new-env)) +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng) repl-env)))) + +(env-set repl-env "+" +) +(env-set repl-env "-" -) +(env-set repl-env "*" *) +(env-set repl-env "/" /) + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (try* + (println (rep line)) + (catch* exc + (do + (println "Uncaught exception:" exc @trace) + (reset! trace ""))))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(repl-loop "") diff --git a/impls/mal/step4_if_fn_do.mal b/impls/mal/step4_if_fn_do.mal index cd6b05ffa4..bafb52778e 100644 --- a/impls/mal/step4_if_fn_do.mal +++ b/impls/mal/step4_if_fn_do.mal @@ -1,103 +1,103 @@ -(load-file "../mal/env.mal") -(load-file "../mal/core.mal") - -;; EVAL extends this stack trace when propagating exceptions. If the -;; exception reaches the REPL loop, the full trace is printed. -(def! trace (atom "")) - -;; read -(def! READ read-string) - - -;; eval -(def! eval-ast (fn* [ast env] - ;; (do (prn "eval-ast" ast "/" (keys @env)) ) - (cond - (symbol? ast) (env-get env ast) - - (list? ast) (map (fn* [exp] (EVAL exp env)) ast) - - (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) - - (map? ast) (apply hash-map - (apply concat - (map (fn* [k] [k (EVAL (get ast k) env)]) - (keys ast)))) - - "else" ast))) - -(def! LET (fn* [env binds form] - (if (empty? binds) - (EVAL form env) - (do - (env-set env (first binds) (EVAL (nth binds 1) env)) - (LET env (rest (rest binds)) form))))) - -(def! EVAL (fn* [ast env] - ;; (do (prn "EVAL" ast "/" (keys @env)) ) - (try* - (if (not (list? ast)) - (eval-ast ast env) - - ;; apply list - (let* [a0 (first ast)] - (cond - (empty? ast) - ast - - (= 'def! a0) - (env-set env (nth ast 1) (EVAL (nth ast 2) env)) - - (= 'let* a0) - (LET (new-env env) (nth ast 1) (nth ast 2)) - - (= 'do a0) - (nth (eval-ast (rest ast) env) (- (count ast) 2)) - - (= 'if a0) - (if (EVAL (nth ast 1) env) - (EVAL (nth ast 2) env) - (if (> (count ast) 3) - (EVAL (nth ast 3) env))) - - (= 'fn* a0) - (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) - - "else" - (let* [el (eval-ast ast env)] - (apply (first el) (rest el)))))) - - (catch* exc - (do - (swap! trace str "\n in mal EVAL: " ast) - (throw exc)))))) - -;; print -(def! PRINT pr-str) - -;; repl -(def! repl-env (new-env)) -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng) repl-env)))) - -;; core.mal: defined directly using mal -(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) - -;; core.mal: defined using the new language itself -(rep "(def! not (fn* [a] (if a false true)))") - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (try* - (println (rep line)) - (catch* exc - (do - (println "Uncaught exception:" exc @trace) - (reset! trace ""))))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(repl-loop "") +(load-file "../mal/env.mal") +(load-file "../mal/core.mal") + +;; EVAL extends this stack trace when propagating exceptions. If the +;; exception reaches the REPL loop, the full trace is printed. +(def! trace (atom "")) + +;; read +(def! READ read-string) + + +;; eval +(def! eval-ast (fn* [ast env] + ;; (do (prn "eval-ast" ast "/" (keys @env)) ) + (cond + (symbol? ast) (env-get env ast) + + (list? ast) (map (fn* [exp] (EVAL exp env)) ast) + + (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) + + (map? ast) (apply hash-map + (apply concat + (map (fn* [k] [k (EVAL (get ast k) env)]) + (keys ast)))) + + "else" ast))) + +(def! LET (fn* [env binds form] + (if (empty? binds) + (EVAL form env) + (do + (env-set env (first binds) (EVAL (nth binds 1) env)) + (LET env (rest (rest binds)) form))))) + +(def! EVAL (fn* [ast env] + ;; (do (prn "EVAL" ast "/" (keys @env)) ) + (try* + (if (not (list? ast)) + (eval-ast ast env) + + ;; apply list + (let* [a0 (first ast)] + (cond + (empty? ast) + ast + + (= 'def! a0) + (env-set env (nth ast 1) (EVAL (nth ast 2) env)) + + (= 'let* a0) + (LET (new-env env) (nth ast 1) (nth ast 2)) + + (= 'do a0) + (nth (eval-ast (rest ast) env) (- (count ast) 2)) + + (= 'if a0) + (if (EVAL (nth ast 1) env) + (EVAL (nth ast 2) env) + (if (> (count ast) 3) + (EVAL (nth ast 3) env))) + + (= 'fn* a0) + (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) + + "else" + (let* [el (eval-ast ast env)] + (apply (first el) (rest el)))))) + + (catch* exc + (do + (swap! trace str "\n in mal EVAL: " ast) + (throw exc)))))) + +;; print +(def! PRINT pr-str) + +;; repl +(def! repl-env (new-env)) +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng) repl-env)))) + +;; core.mal: defined directly using mal +(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) + +;; core.mal: defined using the new language itself +(rep "(def! not (fn* [a] (if a false true)))") + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (try* + (println (rep line)) + (catch* exc + (do + (println "Uncaught exception:" exc @trace) + (reset! trace ""))))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(repl-loop "") diff --git a/impls/mal/step6_file.mal b/impls/mal/step6_file.mal index 3d7ee78607..6df8402985 100644 --- a/impls/mal/step6_file.mal +++ b/impls/mal/step6_file.mal @@ -1,108 +1,108 @@ -(load-file "../mal/env.mal") -(load-file "../mal/core.mal") - -;; EVAL extends this stack trace when propagating exceptions. If the -;; exception reaches the REPL loop, the full trace is printed. -(def! trace (atom "")) - -;; read -(def! READ read-string) - - -;; eval -(def! eval-ast (fn* [ast env] - ;; (do (prn "eval-ast" ast "/" (keys @env)) ) - (cond - (symbol? ast) (env-get env ast) - - (list? ast) (map (fn* [exp] (EVAL exp env)) ast) - - (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) - - (map? ast) (apply hash-map - (apply concat - (map (fn* [k] [k (EVAL (get ast k) env)]) - (keys ast)))) - - "else" ast))) - -(def! LET (fn* [env binds form] - (if (empty? binds) - (EVAL form env) - (do - (env-set env (first binds) (EVAL (nth binds 1) env)) - (LET env (rest (rest binds)) form))))) - -(def! EVAL (fn* [ast env] - ;; (do (prn "EVAL" ast "/" (keys @env)) ) - (try* - (if (not (list? ast)) - (eval-ast ast env) - - ;; apply list - (let* [a0 (first ast)] - (cond - (empty? ast) - ast - - (= 'def! a0) - (env-set env (nth ast 1) (EVAL (nth ast 2) env)) - - (= 'let* a0) - (LET (new-env env) (nth ast 1) (nth ast 2)) - - (= 'do a0) - (nth (eval-ast (rest ast) env) (- (count ast) 2)) - - (= 'if a0) - (if (EVAL (nth ast 1) env) - (EVAL (nth ast 2) env) - (if (> (count ast) 3) - (EVAL (nth ast 3) env))) - - (= 'fn* a0) - (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) - - "else" - (let* [el (eval-ast ast env)] - (apply (first el) (rest el)))))) - - (catch* exc - (do - (swap! trace str "\n in mal EVAL: " ast) - (throw exc)))))) - -;; print -(def! PRINT pr-str) - -;; repl -(def! repl-env (new-env)) -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng) repl-env)))) - -;; core.mal: defined directly using mal -(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) -(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (rest *ARGV*)) - -;; core.mal: defined using the new language itself -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (try* - (println (rep line)) - (catch* exc - (do - (println "Uncaught exception:" exc @trace) - (reset! trace ""))))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(if (empty? *ARGV*) - (repl-loop "") - (rep (str "(load-file \"" (first *ARGV*) "\")"))) +(load-file "../mal/env.mal") +(load-file "../mal/core.mal") + +;; EVAL extends this stack trace when propagating exceptions. If the +;; exception reaches the REPL loop, the full trace is printed. +(def! trace (atom "")) + +;; read +(def! READ read-string) + + +;; eval +(def! eval-ast (fn* [ast env] + ;; (do (prn "eval-ast" ast "/" (keys @env)) ) + (cond + (symbol? ast) (env-get env ast) + + (list? ast) (map (fn* [exp] (EVAL exp env)) ast) + + (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) + + (map? ast) (apply hash-map + (apply concat + (map (fn* [k] [k (EVAL (get ast k) env)]) + (keys ast)))) + + "else" ast))) + +(def! LET (fn* [env binds form] + (if (empty? binds) + (EVAL form env) + (do + (env-set env (first binds) (EVAL (nth binds 1) env)) + (LET env (rest (rest binds)) form))))) + +(def! EVAL (fn* [ast env] + ;; (do (prn "EVAL" ast "/" (keys @env)) ) + (try* + (if (not (list? ast)) + (eval-ast ast env) + + ;; apply list + (let* [a0 (first ast)] + (cond + (empty? ast) + ast + + (= 'def! a0) + (env-set env (nth ast 1) (EVAL (nth ast 2) env)) + + (= 'let* a0) + (LET (new-env env) (nth ast 1) (nth ast 2)) + + (= 'do a0) + (nth (eval-ast (rest ast) env) (- (count ast) 2)) + + (= 'if a0) + (if (EVAL (nth ast 1) env) + (EVAL (nth ast 2) env) + (if (> (count ast) 3) + (EVAL (nth ast 3) env))) + + (= 'fn* a0) + (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) + + "else" + (let* [el (eval-ast ast env)] + (apply (first el) (rest el)))))) + + (catch* exc + (do + (swap! trace str "\n in mal EVAL: " ast) + (throw exc)))))) + +;; print +(def! PRINT pr-str) + +;; repl +(def! repl-env (new-env)) +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng) repl-env)))) + +;; core.mal: defined directly using mal +(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) +(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (rest *ARGV*)) + +;; core.mal: defined using the new language itself +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (try* + (println (rep line)) + (catch* exc + (do + (println "Uncaught exception:" exc @trace) + (reset! trace ""))))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(if (empty? *ARGV*) + (repl-loop "") + (rep (str "(load-file \"" (first *ARGV*) "\")"))) diff --git a/impls/mal/step7_quote.mal b/impls/mal/step7_quote.mal index 9e85f55d75..3bb70b2b4a 100644 --- a/impls/mal/step7_quote.mal +++ b/impls/mal/step7_quote.mal @@ -1,135 +1,135 @@ -(load-file "../mal/env.mal") -(load-file "../mal/core.mal") - -;; EVAL extends this stack trace when propagating exceptions. If the -;; exception reaches the REPL loop, the full trace is printed. -(def! trace (atom "")) - -;; read -(def! READ read-string) - - -;; eval - -(def! qq-loop (fn* [elt acc] - (if (if (list? elt) (= (first elt) 'splice-unquote)) ; 2nd 'if' means 'and' - (list 'concat (nth elt 1) acc) - (list 'cons (QUASIQUOTE elt) acc)))) -(def! qq-foldr (fn* [xs] - (if (empty? xs) - () - (qq-loop (first xs) (qq-foldr (rest xs)))))) -(def! QUASIQUOTE (fn* [ast] - (cond - (vector? ast) (list 'vec (qq-foldr ast)) - (map? ast) (list 'quote ast) - (symbol? ast) (list 'quote ast) - (not (list? ast)) ast - (= (first ast) 'unquote) (nth ast 1) - "else" (qq-foldr ast)))) - -(def! eval-ast (fn* [ast env] - ;; (do (prn "eval-ast" ast "/" (keys @env)) ) - (cond - (symbol? ast) (env-get env ast) - - (list? ast) (map (fn* [exp] (EVAL exp env)) ast) - - (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) - - (map? ast) (apply hash-map - (apply concat - (map (fn* [k] [k (EVAL (get ast k) env)]) - (keys ast)))) - - "else" ast))) - -(def! LET (fn* [env binds form] - (if (empty? binds) - (EVAL form env) - (do - (env-set env (first binds) (EVAL (nth binds 1) env)) - (LET env (rest (rest binds)) form))))) - -(def! EVAL (fn* [ast env] - ;; (do (prn "EVAL" ast "/" (keys @env)) ) - (try* - (if (not (list? ast)) - (eval-ast ast env) - - ;; apply list - (let* [a0 (first ast)] - (cond - (empty? ast) - ast - - (= 'def! a0) - (env-set env (nth ast 1) (EVAL (nth ast 2) env)) - - (= 'let* a0) - (LET (new-env env) (nth ast 1) (nth ast 2)) - - (= 'quote a0) - (nth ast 1) - - (= 'quasiquoteexpand a0) - (QUASIQUOTE (nth ast 1)) - - (= 'quasiquote a0) - (EVAL (QUASIQUOTE (nth ast 1)) env) - - (= 'do a0) - (nth (eval-ast (rest ast) env) (- (count ast) 2)) - - (= 'if a0) - (if (EVAL (nth ast 1) env) - (EVAL (nth ast 2) env) - (if (> (count ast) 3) - (EVAL (nth ast 3) env))) - - (= 'fn* a0) - (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) - - "else" - (let* [el (eval-ast ast env)] - (apply (first el) (rest el)))))) - - (catch* exc - (do - (swap! trace str "\n in mal EVAL: " ast) - (throw exc)))))) - -;; print -(def! PRINT pr-str) - -;; repl -(def! repl-env (new-env)) -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng) repl-env)))) - -;; core.mal: defined directly using mal -(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) -(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (rest *ARGV*)) - -;; core.mal: defined using the new language itself -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (try* - (println (rep line)) - (catch* exc - (do - (println "Uncaught exception:" exc @trace) - (reset! trace ""))))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(if (empty? *ARGV*) - (repl-loop "") - (rep (str "(load-file \"" (first *ARGV*) "\")"))) +(load-file "../mal/env.mal") +(load-file "../mal/core.mal") + +;; EVAL extends this stack trace when propagating exceptions. If the +;; exception reaches the REPL loop, the full trace is printed. +(def! trace (atom "")) + +;; read +(def! READ read-string) + + +;; eval + +(def! qq-loop (fn* [elt acc] + (if (if (list? elt) (= (first elt) 'splice-unquote)) ; 2nd 'if' means 'and' + (list 'concat (nth elt 1) acc) + (list 'cons (QUASIQUOTE elt) acc)))) +(def! qq-foldr (fn* [xs] + (if (empty? xs) + () + (qq-loop (first xs) (qq-foldr (rest xs)))))) +(def! QUASIQUOTE (fn* [ast] + (cond + (vector? ast) (list 'vec (qq-foldr ast)) + (map? ast) (list 'quote ast) + (symbol? ast) (list 'quote ast) + (not (list? ast)) ast + (= (first ast) 'unquote) (nth ast 1) + "else" (qq-foldr ast)))) + +(def! eval-ast (fn* [ast env] + ;; (do (prn "eval-ast" ast "/" (keys @env)) ) + (cond + (symbol? ast) (env-get env ast) + + (list? ast) (map (fn* [exp] (EVAL exp env)) ast) + + (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) + + (map? ast) (apply hash-map + (apply concat + (map (fn* [k] [k (EVAL (get ast k) env)]) + (keys ast)))) + + "else" ast))) + +(def! LET (fn* [env binds form] + (if (empty? binds) + (EVAL form env) + (do + (env-set env (first binds) (EVAL (nth binds 1) env)) + (LET env (rest (rest binds)) form))))) + +(def! EVAL (fn* [ast env] + ;; (do (prn "EVAL" ast "/" (keys @env)) ) + (try* + (if (not (list? ast)) + (eval-ast ast env) + + ;; apply list + (let* [a0 (first ast)] + (cond + (empty? ast) + ast + + (= 'def! a0) + (env-set env (nth ast 1) (EVAL (nth ast 2) env)) + + (= 'let* a0) + (LET (new-env env) (nth ast 1) (nth ast 2)) + + (= 'quote a0) + (nth ast 1) + + (= 'quasiquoteexpand a0) + (QUASIQUOTE (nth ast 1)) + + (= 'quasiquote a0) + (EVAL (QUASIQUOTE (nth ast 1)) env) + + (= 'do a0) + (nth (eval-ast (rest ast) env) (- (count ast) 2)) + + (= 'if a0) + (if (EVAL (nth ast 1) env) + (EVAL (nth ast 2) env) + (if (> (count ast) 3) + (EVAL (nth ast 3) env))) + + (= 'fn* a0) + (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) + + "else" + (let* [el (eval-ast ast env)] + (apply (first el) (rest el)))))) + + (catch* exc + (do + (swap! trace str "\n in mal EVAL: " ast) + (throw exc)))))) + +;; print +(def! PRINT pr-str) + +;; repl +(def! repl-env (new-env)) +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng) repl-env)))) + +;; core.mal: defined directly using mal +(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) +(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (rest *ARGV*)) + +;; core.mal: defined using the new language itself +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (try* + (println (rep line)) + (catch* exc + (do + (println "Uncaught exception:" exc @trace) + (reset! trace ""))))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(if (empty? *ARGV*) + (repl-loop "") + (rep (str "(load-file \"" (first *ARGV*) "\")"))) diff --git a/impls/mal/step8_macros.mal b/impls/mal/step8_macros.mal index cbbc6d4cb6..641647fce7 100644 --- a/impls/mal/step8_macros.mal +++ b/impls/mal/step8_macros.mal @@ -1,152 +1,152 @@ -(load-file "../mal/env.mal") -(load-file "../mal/core.mal") - -;; EVAL extends this stack trace when propagating exceptions. If the -;; exception reaches the REPL loop, the full trace is printed. -(def! trace (atom "")) - -;; read -(def! READ read-string) - - -;; eval - -(def! qq-loop (fn* [elt acc] - (if (if (list? elt) (= (first elt) 'splice-unquote)) ; 2nd 'if' means 'and' - (list 'concat (nth elt 1) acc) - (list 'cons (QUASIQUOTE elt) acc)))) -(def! qq-foldr (fn* [xs] - (if (empty? xs) - () - (qq-loop (first xs) (qq-foldr (rest xs)))))) -(def! QUASIQUOTE (fn* [ast] - (cond - (vector? ast) (list 'vec (qq-foldr ast)) - (map? ast) (list 'quote ast) - (symbol? ast) (list 'quote ast) - (not (list? ast)) ast - (= (first ast) 'unquote) (nth ast 1) - "else" (qq-foldr ast)))) - -(def! MACROEXPAND (fn* [ast env] - (let* [a0 (if (list? ast) (first ast)) - e (if (symbol? a0) (env-find env a0)) - m (if e (env-get e a0))] - (if (_macro? m) - (MACROEXPAND (apply (get m :__MAL_MACRO__) (rest ast)) env) - ast)))) - -(def! eval-ast (fn* [ast env] - ;; (do (prn "eval-ast" ast "/" (keys @env)) ) - (cond - (symbol? ast) (env-get env ast) - - (list? ast) (map (fn* [exp] (EVAL exp env)) ast) - - (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) - - (map? ast) (apply hash-map - (apply concat - (map (fn* [k] [k (EVAL (get ast k) env)]) - (keys ast)))) - - "else" ast))) - -(def! LET (fn* [env binds form] - (if (empty? binds) - (EVAL form env) - (do - (env-set env (first binds) (EVAL (nth binds 1) env)) - (LET env (rest (rest binds)) form))))) - -(def! EVAL (fn* [ast env] - ;; (do (prn "EVAL" ast "/" (keys @env)) ) - (try* - (let* [ast (MACROEXPAND ast env)] - (if (not (list? ast)) - (eval-ast ast env) - - ;; apply list - (let* [a0 (first ast)] - (cond - (empty? ast) - ast - - (= 'def! a0) - (env-set env (nth ast 1) (EVAL (nth ast 2) env)) - - (= 'let* a0) - (LET (new-env env) (nth ast 1) (nth ast 2)) - - (= 'quote a0) - (nth ast 1) - - (= 'quasiquoteexpand a0) - (QUASIQUOTE (nth ast 1)) - - (= 'quasiquote a0) - (EVAL (QUASIQUOTE (nth ast 1)) env) - - (= 'defmacro! a0) - (env-set env (nth ast 1) (hash-map :__MAL_MACRO__ - (EVAL (nth ast 2) env))) - - (= 'macroexpand a0) - (MACROEXPAND (nth ast 1) env) - - (= 'do a0) - (nth (eval-ast (rest ast) env) (- (count ast) 2)) - - (= 'if a0) - (if (EVAL (nth ast 1) env) - (EVAL (nth ast 2) env) - (if (> (count ast) 3) - (EVAL (nth ast 3) env))) - - (= 'fn* a0) - (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) - - "else" - (let* [el (eval-ast ast env)] - (apply (first el) (rest el))))))) - - (catch* exc - (do - (swap! trace str "\n in mal EVAL: " ast) - (throw exc)))))) - -;; print -(def! PRINT pr-str) - -;; repl -(def! repl-env (new-env)) -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng) repl-env)))) - -;; core.mal: defined directly using mal -(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) -(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (rest *ARGV*)) - -;; core.mal: defined using the new language itself -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (try* - (println (rep line)) - (catch* exc - (do - (println "Uncaught exception:" exc @trace) - (reset! trace ""))))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(if (empty? *ARGV*) - (repl-loop "") - (rep (str "(load-file \"" (first *ARGV*) "\")"))) +(load-file "../mal/env.mal") +(load-file "../mal/core.mal") + +;; EVAL extends this stack trace when propagating exceptions. If the +;; exception reaches the REPL loop, the full trace is printed. +(def! trace (atom "")) + +;; read +(def! READ read-string) + + +;; eval + +(def! qq-loop (fn* [elt acc] + (if (if (list? elt) (= (first elt) 'splice-unquote)) ; 2nd 'if' means 'and' + (list 'concat (nth elt 1) acc) + (list 'cons (QUASIQUOTE elt) acc)))) +(def! qq-foldr (fn* [xs] + (if (empty? xs) + () + (qq-loop (first xs) (qq-foldr (rest xs)))))) +(def! QUASIQUOTE (fn* [ast] + (cond + (vector? ast) (list 'vec (qq-foldr ast)) + (map? ast) (list 'quote ast) + (symbol? ast) (list 'quote ast) + (not (list? ast)) ast + (= (first ast) 'unquote) (nth ast 1) + "else" (qq-foldr ast)))) + +(def! MACROEXPAND (fn* [ast env] + (let* [a0 (if (list? ast) (first ast)) + e (if (symbol? a0) (env-find env a0)) + m (if e (env-get e a0))] + (if (_macro? m) + (MACROEXPAND (apply (get m :__MAL_MACRO__) (rest ast)) env) + ast)))) + +(def! eval-ast (fn* [ast env] + ;; (do (prn "eval-ast" ast "/" (keys @env)) ) + (cond + (symbol? ast) (env-get env ast) + + (list? ast) (map (fn* [exp] (EVAL exp env)) ast) + + (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) + + (map? ast) (apply hash-map + (apply concat + (map (fn* [k] [k (EVAL (get ast k) env)]) + (keys ast)))) + + "else" ast))) + +(def! LET (fn* [env binds form] + (if (empty? binds) + (EVAL form env) + (do + (env-set env (first binds) (EVAL (nth binds 1) env)) + (LET env (rest (rest binds)) form))))) + +(def! EVAL (fn* [ast env] + ;; (do (prn "EVAL" ast "/" (keys @env)) ) + (try* + (let* [ast (MACROEXPAND ast env)] + (if (not (list? ast)) + (eval-ast ast env) + + ;; apply list + (let* [a0 (first ast)] + (cond + (empty? ast) + ast + + (= 'def! a0) + (env-set env (nth ast 1) (EVAL (nth ast 2) env)) + + (= 'let* a0) + (LET (new-env env) (nth ast 1) (nth ast 2)) + + (= 'quote a0) + (nth ast 1) + + (= 'quasiquoteexpand a0) + (QUASIQUOTE (nth ast 1)) + + (= 'quasiquote a0) + (EVAL (QUASIQUOTE (nth ast 1)) env) + + (= 'defmacro! a0) + (env-set env (nth ast 1) (hash-map :__MAL_MACRO__ + (EVAL (nth ast 2) env))) + + (= 'macroexpand a0) + (MACROEXPAND (nth ast 1) env) + + (= 'do a0) + (nth (eval-ast (rest ast) env) (- (count ast) 2)) + + (= 'if a0) + (if (EVAL (nth ast 1) env) + (EVAL (nth ast 2) env) + (if (> (count ast) 3) + (EVAL (nth ast 3) env))) + + (= 'fn* a0) + (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) + + "else" + (let* [el (eval-ast ast env)] + (apply (first el) (rest el))))))) + + (catch* exc + (do + (swap! trace str "\n in mal EVAL: " ast) + (throw exc)))))) + +;; print +(def! PRINT pr-str) + +;; repl +(def! repl-env (new-env)) +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng) repl-env)))) + +;; core.mal: defined directly using mal +(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) +(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (rest *ARGV*)) + +;; core.mal: defined using the new language itself +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (try* + (println (rep line)) + (catch* exc + (do + (println "Uncaught exception:" exc @trace) + (reset! trace ""))))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(if (empty? *ARGV*) + (repl-loop "") + (rep (str "(load-file \"" (first *ARGV*) "\")"))) diff --git a/impls/mal/step9_try.mal b/impls/mal/step9_try.mal index 1d7bbe44d6..24b0d0d947 100644 --- a/impls/mal/step9_try.mal +++ b/impls/mal/step9_try.mal @@ -1,163 +1,163 @@ -(load-file "../mal/env.mal") -(load-file "../mal/core.mal") - -;; EVAL extends this stack trace when propagating exceptions. If the -;; exception reaches the REPL loop, the full trace is printed. -(def! trace (atom "")) - -;; read -(def! READ read-string) - - -;; eval - -(def! qq-loop (fn* [elt acc] - (if (if (list? elt) (= (first elt) 'splice-unquote)) ; 2nd 'if' means 'and' - (list 'concat (nth elt 1) acc) - (list 'cons (QUASIQUOTE elt) acc)))) -(def! qq-foldr (fn* [xs] - (if (empty? xs) - () - (qq-loop (first xs) (qq-foldr (rest xs)))))) -(def! QUASIQUOTE (fn* [ast] - (cond - (vector? ast) (list 'vec (qq-foldr ast)) - (map? ast) (list 'quote ast) - (symbol? ast) (list 'quote ast) - (not (list? ast)) ast - (= (first ast) 'unquote) (nth ast 1) - "else" (qq-foldr ast)))) - -(def! MACROEXPAND (fn* [ast env] - (let* [a0 (if (list? ast) (first ast)) - e (if (symbol? a0) (env-find env a0)) - m (if e (env-get e a0))] - (if (_macro? m) - (MACROEXPAND (apply (get m :__MAL_MACRO__) (rest ast)) env) - ast)))) - -(def! eval-ast (fn* [ast env] - ;; (do (prn "eval-ast" ast "/" (keys @env)) ) - (cond - (symbol? ast) (env-get env ast) - - (list? ast) (map (fn* [exp] (EVAL exp env)) ast) - - (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) - - (map? ast) (apply hash-map - (apply concat - (map (fn* [k] [k (EVAL (get ast k) env)]) - (keys ast)))) - - "else" ast))) - -(def! LET (fn* [env binds form] - (if (empty? binds) - (EVAL form env) - (do - (env-set env (first binds) (EVAL (nth binds 1) env)) - (LET env (rest (rest binds)) form))))) - -(def! EVAL (fn* [ast env] - ;; (do (prn "EVAL" ast "/" (keys @env)) ) - (try* - (let* [ast (MACROEXPAND ast env)] - (if (not (list? ast)) - (eval-ast ast env) - - ;; apply list - (let* [a0 (first ast)] - (cond - (empty? ast) - ast - - (= 'def! a0) - (env-set env (nth ast 1) (EVAL (nth ast 2) env)) - - (= 'let* a0) - (LET (new-env env) (nth ast 1) (nth ast 2)) - - (= 'quote a0) - (nth ast 1) - - (= 'quasiquoteexpand a0) - (QUASIQUOTE (nth ast 1)) - - (= 'quasiquote a0) - (EVAL (QUASIQUOTE (nth ast 1)) env) - - (= 'defmacro! a0) - (env-set env (nth ast 1) (hash-map :__MAL_MACRO__ - (EVAL (nth ast 2) env))) - - (= 'macroexpand a0) - (MACROEXPAND (nth ast 1) env) - - (= 'try* a0) - (if (< (count ast) 3) - (EVAL (nth ast 1) env) - (try* - (EVAL (nth ast 1) env) - (catch* exc - (do - (reset! trace "") - (let* [a2 (nth ast 2)] - (EVAL (nth a2 2) (new-env env [(nth a2 1)] [exc]))))))) - - (= 'do a0) - (nth (eval-ast (rest ast) env) (- (count ast) 2)) - - (= 'if a0) - (if (EVAL (nth ast 1) env) - (EVAL (nth ast 2) env) - (if (> (count ast) 3) - (EVAL (nth ast 3) env))) - - (= 'fn* a0) - (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) - - "else" - (let* [el (eval-ast ast env)] - (apply (first el) (rest el))))))) - - (catch* exc - (do - (swap! trace str "\n in mal EVAL: " ast) - (throw exc)))))) - -;; print -(def! PRINT pr-str) - -;; repl -(def! repl-env (new-env)) -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng) repl-env)))) - -;; core.mal: defined directly using mal -(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) -(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (rest *ARGV*)) - -;; core.mal: defined using the new language itself -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (try* - (println (rep line)) - (catch* exc - (do - (println "Uncaught exception:" exc @trace) - (reset! trace ""))))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(if (empty? *ARGV*) - (repl-loop "") - (rep (str "(load-file \"" (first *ARGV*) "\")"))) +(load-file "../mal/env.mal") +(load-file "../mal/core.mal") + +;; EVAL extends this stack trace when propagating exceptions. If the +;; exception reaches the REPL loop, the full trace is printed. +(def! trace (atom "")) + +;; read +(def! READ read-string) + + +;; eval + +(def! qq-loop (fn* [elt acc] + (if (if (list? elt) (= (first elt) 'splice-unquote)) ; 2nd 'if' means 'and' + (list 'concat (nth elt 1) acc) + (list 'cons (QUASIQUOTE elt) acc)))) +(def! qq-foldr (fn* [xs] + (if (empty? xs) + () + (qq-loop (first xs) (qq-foldr (rest xs)))))) +(def! QUASIQUOTE (fn* [ast] + (cond + (vector? ast) (list 'vec (qq-foldr ast)) + (map? ast) (list 'quote ast) + (symbol? ast) (list 'quote ast) + (not (list? ast)) ast + (= (first ast) 'unquote) (nth ast 1) + "else" (qq-foldr ast)))) + +(def! MACROEXPAND (fn* [ast env] + (let* [a0 (if (list? ast) (first ast)) + e (if (symbol? a0) (env-find env a0)) + m (if e (env-get e a0))] + (if (_macro? m) + (MACROEXPAND (apply (get m :__MAL_MACRO__) (rest ast)) env) + ast)))) + +(def! eval-ast (fn* [ast env] + ;; (do (prn "eval-ast" ast "/" (keys @env)) ) + (cond + (symbol? ast) (env-get env ast) + + (list? ast) (map (fn* [exp] (EVAL exp env)) ast) + + (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) + + (map? ast) (apply hash-map + (apply concat + (map (fn* [k] [k (EVAL (get ast k) env)]) + (keys ast)))) + + "else" ast))) + +(def! LET (fn* [env binds form] + (if (empty? binds) + (EVAL form env) + (do + (env-set env (first binds) (EVAL (nth binds 1) env)) + (LET env (rest (rest binds)) form))))) + +(def! EVAL (fn* [ast env] + ;; (do (prn "EVAL" ast "/" (keys @env)) ) + (try* + (let* [ast (MACROEXPAND ast env)] + (if (not (list? ast)) + (eval-ast ast env) + + ;; apply list + (let* [a0 (first ast)] + (cond + (empty? ast) + ast + + (= 'def! a0) + (env-set env (nth ast 1) (EVAL (nth ast 2) env)) + + (= 'let* a0) + (LET (new-env env) (nth ast 1) (nth ast 2)) + + (= 'quote a0) + (nth ast 1) + + (= 'quasiquoteexpand a0) + (QUASIQUOTE (nth ast 1)) + + (= 'quasiquote a0) + (EVAL (QUASIQUOTE (nth ast 1)) env) + + (= 'defmacro! a0) + (env-set env (nth ast 1) (hash-map :__MAL_MACRO__ + (EVAL (nth ast 2) env))) + + (= 'macroexpand a0) + (MACROEXPAND (nth ast 1) env) + + (= 'try* a0) + (if (< (count ast) 3) + (EVAL (nth ast 1) env) + (try* + (EVAL (nth ast 1) env) + (catch* exc + (do + (reset! trace "") + (let* [a2 (nth ast 2)] + (EVAL (nth a2 2) (new-env env [(nth a2 1)] [exc]))))))) + + (= 'do a0) + (nth (eval-ast (rest ast) env) (- (count ast) 2)) + + (= 'if a0) + (if (EVAL (nth ast 1) env) + (EVAL (nth ast 2) env) + (if (> (count ast) 3) + (EVAL (nth ast 3) env))) + + (= 'fn* a0) + (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) + + "else" + (let* [el (eval-ast ast env)] + (apply (first el) (rest el))))))) + + (catch* exc + (do + (swap! trace str "\n in mal EVAL: " ast) + (throw exc)))))) + +;; print +(def! PRINT pr-str) + +;; repl +(def! repl-env (new-env)) +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng) repl-env)))) + +;; core.mal: defined directly using mal +(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) +(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (rest *ARGV*)) + +;; core.mal: defined using the new language itself +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (try* + (println (rep line)) + (catch* exc + (do + (println "Uncaught exception:" exc @trace) + (reset! trace ""))))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(if (empty? *ARGV*) + (repl-loop "") + (rep (str "(load-file \"" (first *ARGV*) "\")"))) diff --git a/impls/mal/stepA_mal.mal b/impls/mal/stepA_mal.mal index 432dd31935..8a9f9c9dd6 100644 --- a/impls/mal/stepA_mal.mal +++ b/impls/mal/stepA_mal.mal @@ -1,165 +1,165 @@ -(load-file "../mal/env.mal") -(load-file "../mal/core.mal") - -;; EVAL extends this stack trace when propagating exceptions. If the -;; exception reaches the REPL loop, the full trace is printed. -(def! trace (atom "")) - -;; read -(def! READ read-string) - - -;; eval - -(def! qq-loop (fn* [elt acc] - (if (if (list? elt) (= (first elt) 'splice-unquote)) ; 2nd 'if' means 'and' - (list 'concat (nth elt 1) acc) - (list 'cons (QUASIQUOTE elt) acc)))) -(def! qq-foldr (fn* [xs] - (if (empty? xs) - () - (qq-loop (first xs) (qq-foldr (rest xs)))))) -(def! QUASIQUOTE (fn* [ast] - (cond - (vector? ast) (list 'vec (qq-foldr ast)) - (map? ast) (list 'quote ast) - (symbol? ast) (list 'quote ast) - (not (list? ast)) ast - (= (first ast) 'unquote) (nth ast 1) - "else" (qq-foldr ast)))) - -(def! MACROEXPAND (fn* [ast env] - (let* [a0 (if (list? ast) (first ast)) - e (if (symbol? a0) (env-find env a0)) - m (if e (env-get e a0))] - (if (_macro? m) - (MACROEXPAND (apply (get m :__MAL_MACRO__) (rest ast)) env) - ast)))) - -(def! eval-ast (fn* [ast env] - ;; (do (prn "eval-ast" ast "/" (keys @env)) ) - (cond - (symbol? ast) (env-get env ast) - - (list? ast) (map (fn* [exp] (EVAL exp env)) ast) - - (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) - - (map? ast) (apply hash-map - (apply concat - (map (fn* [k] [k (EVAL (get ast k) env)]) - (keys ast)))) - - "else" ast))) - -(def! LET (fn* [env binds form] - (if (empty? binds) - (EVAL form env) - (do - (env-set env (first binds) (EVAL (nth binds 1) env)) - (LET env (rest (rest binds)) form))))) - -(def! EVAL (fn* [ast env] - ;; (do (prn "EVAL" ast "/" (keys @env)) ) - (try* - (let* [ast (MACROEXPAND ast env)] - (if (not (list? ast)) - (eval-ast ast env) - - ;; apply list - (let* [a0 (first ast)] - (cond - (empty? ast) - ast - - (= 'def! a0) - (env-set env (nth ast 1) (EVAL (nth ast 2) env)) - - (= 'let* a0) - (LET (new-env env) (nth ast 1) (nth ast 2)) - - (= 'quote a0) - (nth ast 1) - - (= 'quasiquoteexpand a0) - (QUASIQUOTE (nth ast 1)) - - (= 'quasiquote a0) - (EVAL (QUASIQUOTE (nth ast 1)) env) - - (= 'defmacro! a0) - (env-set env (nth ast 1) (hash-map :__MAL_MACRO__ - (EVAL (nth ast 2) env))) - - (= 'macroexpand a0) - (MACROEXPAND (nth ast 1) env) - - (= 'try* a0) - (if (< (count ast) 3) - (EVAL (nth ast 1) env) - (try* - (EVAL (nth ast 1) env) - (catch* exc - (do - (reset! trace "") - (let* [a2 (nth ast 2)] - (EVAL (nth a2 2) (new-env env [(nth a2 1)] [exc]))))))) - - (= 'do a0) - (nth (eval-ast (rest ast) env) (- (count ast) 2)) - - (= 'if a0) - (if (EVAL (nth ast 1) env) - (EVAL (nth ast 2) env) - (if (> (count ast) 3) - (EVAL (nth ast 3) env))) - - (= 'fn* a0) - (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) - - "else" - (let* [el (eval-ast ast env)] - (apply (first el) (rest el))))))) - - (catch* exc - (do - (swap! trace str "\n in mal EVAL: " ast) - (throw exc)))))) - -;; print -(def! PRINT pr-str) - -;; repl -(def! repl-env (new-env)) -(def! rep (fn* [strng] - (PRINT (EVAL (READ strng) repl-env)))) - -;; core.mal: defined directly using mal -(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) -(env-set repl-env 'macro? _macro?) -(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (rest *ARGV*)) - -;; core.mal: defined using the new language itself -(rep (str "(def! *host-language* \"" *host-language* "-mal\")")) -(rep "(def! not (fn* [a] (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -;; repl loop -(def! repl-loop (fn* [line] - (if line - (do - (if (not (= "" line)) - (try* - (println (rep line)) - (catch* exc - (do - (println "Uncaught exception:" exc @trace) - (reset! trace ""))))) - (repl-loop (readline "mal-user> ")))))) - -;; main -(if (empty? *ARGV*) - (repl-loop "(println (str \"Mal [\" *host-language* \"]\"))") - (rep (str "(load-file \"" (first *ARGV*) "\")"))) +(load-file "../mal/env.mal") +(load-file "../mal/core.mal") + +;; EVAL extends this stack trace when propagating exceptions. If the +;; exception reaches the REPL loop, the full trace is printed. +(def! trace (atom "")) + +;; read +(def! READ read-string) + + +;; eval + +(def! qq-loop (fn* [elt acc] + (if (if (list? elt) (= (first elt) 'splice-unquote)) ; 2nd 'if' means 'and' + (list 'concat (nth elt 1) acc) + (list 'cons (QUASIQUOTE elt) acc)))) +(def! qq-foldr (fn* [xs] + (if (empty? xs) + () + (qq-loop (first xs) (qq-foldr (rest xs)))))) +(def! QUASIQUOTE (fn* [ast] + (cond + (vector? ast) (list 'vec (qq-foldr ast)) + (map? ast) (list 'quote ast) + (symbol? ast) (list 'quote ast) + (not (list? ast)) ast + (= (first ast) 'unquote) (nth ast 1) + "else" (qq-foldr ast)))) + +(def! MACROEXPAND (fn* [ast env] + (let* [a0 (if (list? ast) (first ast)) + e (if (symbol? a0) (env-find env a0)) + m (if e (env-get e a0))] + (if (_macro? m) + (MACROEXPAND (apply (get m :__MAL_MACRO__) (rest ast)) env) + ast)))) + +(def! eval-ast (fn* [ast env] + ;; (do (prn "eval-ast" ast "/" (keys @env)) ) + (cond + (symbol? ast) (env-get env ast) + + (list? ast) (map (fn* [exp] (EVAL exp env)) ast) + + (vector? ast) (vec (map (fn* [exp] (EVAL exp env)) ast)) + + (map? ast) (apply hash-map + (apply concat + (map (fn* [k] [k (EVAL (get ast k) env)]) + (keys ast)))) + + "else" ast))) + +(def! LET (fn* [env binds form] + (if (empty? binds) + (EVAL form env) + (do + (env-set env (first binds) (EVAL (nth binds 1) env)) + (LET env (rest (rest binds)) form))))) + +(def! EVAL (fn* [ast env] + ;; (do (prn "EVAL" ast "/" (keys @env)) ) + (try* + (let* [ast (MACROEXPAND ast env)] + (if (not (list? ast)) + (eval-ast ast env) + + ;; apply list + (let* [a0 (first ast)] + (cond + (empty? ast) + ast + + (= 'def! a0) + (env-set env (nth ast 1) (EVAL (nth ast 2) env)) + + (= 'let* a0) + (LET (new-env env) (nth ast 1) (nth ast 2)) + + (= 'quote a0) + (nth ast 1) + + (= 'quasiquoteexpand a0) + (QUASIQUOTE (nth ast 1)) + + (= 'quasiquote a0) + (EVAL (QUASIQUOTE (nth ast 1)) env) + + (= 'defmacro! a0) + (env-set env (nth ast 1) (hash-map :__MAL_MACRO__ + (EVAL (nth ast 2) env))) + + (= 'macroexpand a0) + (MACROEXPAND (nth ast 1) env) + + (= 'try* a0) + (if (< (count ast) 3) + (EVAL (nth ast 1) env) + (try* + (EVAL (nth ast 1) env) + (catch* exc + (do + (reset! trace "") + (let* [a2 (nth ast 2)] + (EVAL (nth a2 2) (new-env env [(nth a2 1)] [exc]))))))) + + (= 'do a0) + (nth (eval-ast (rest ast) env) (- (count ast) 2)) + + (= 'if a0) + (if (EVAL (nth ast 1) env) + (EVAL (nth ast 2) env) + (if (> (count ast) 3) + (EVAL (nth ast 3) env))) + + (= 'fn* a0) + (fn* [& args] (EVAL (nth ast 2) (new-env env (nth ast 1) args))) + + "else" + (let* [el (eval-ast ast env)] + (apply (first el) (rest el))))))) + + (catch* exc + (do + (swap! trace str "\n in mal EVAL: " ast) + (throw exc)))))) + +;; print +(def! PRINT pr-str) + +;; repl +(def! repl-env (new-env)) +(def! rep (fn* [strng] + (PRINT (EVAL (READ strng) repl-env)))) + +;; core.mal: defined directly using mal +(map (fn* [sym] (env-set repl-env sym (eval sym))) core_ns) +(env-set repl-env 'macro? _macro?) +(env-set repl-env 'eval (fn* [ast] (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (rest *ARGV*)) + +;; core.mal: defined using the new language itself +(rep (str "(def! *host-language* \"" *host-language* "-mal\")")) +(rep "(def! not (fn* [a] (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +;; repl loop +(def! repl-loop (fn* [line] + (if line + (do + (if (not (= "" line)) + (try* + (println (rep line)) + (catch* exc + (do + (println "Uncaught exception:" exc @trace) + (reset! trace ""))))) + (repl-loop (readline "mal-user> ")))))) + +;; main +(if (empty? *ARGV*) + (repl-loop "(println (str \"Mal [\" *host-language* \"]\"))") + (rep (str "(load-file \"" (first *ARGV*) "\")"))) diff --git a/impls/matlab/+types/Atom.m b/impls/matlab/+types/Atom.m index 7338ce2a12..8ca681843e 100644 --- a/impls/matlab/+types/Atom.m +++ b/impls/matlab/+types/Atom.m @@ -1,10 +1,10 @@ -classdef Atom < handle - properties - val - end - methods - function atm = Atom(val) - atm.val = val; - end - end -end +classdef Atom < handle + properties + val + end + methods + function atm = Atom(val) + atm.val = val; + end + end +end diff --git a/impls/matlab/+types/Function.m b/impls/matlab/+types/Function.m index bbbcc9ad7f..482143b512 100644 --- a/impls/matlab/+types/Function.m +++ b/impls/matlab/+types/Function.m @@ -1,24 +1,24 @@ -classdef Function < handle - properties - fn - ast - env - params - is_macro = false; - meta = type_utils.nil; - end - methods - function f = Function(fn, ast, env, params) - f.fn = fn; - f.ast = ast; - f.env = env; - f.params = params; - end - - function ret = clone(obj) - ret = types.Function(obj.fn, obj.ast, obj.env, obj.params); - ret.is_macro = obj.is_macro; - ret.meta = obj.meta; - end - end -end +classdef Function < handle + properties + fn + ast + env + params + is_macro = false; + meta = type_utils.nil; + end + methods + function f = Function(fn, ast, env, params) + f.fn = fn; + f.ast = ast; + f.env = env; + f.params = params; + end + + function ret = clone(obj) + ret = types.Function(obj.fn, obj.ast, obj.env, obj.params); + ret.is_macro = obj.is_macro; + ret.meta = obj.meta; + end + end +end diff --git a/impls/matlab/+types/HashMap.m b/impls/matlab/+types/HashMap.m index ab5e76ce56..28525b5f7b 100644 --- a/impls/matlab/+types/HashMap.m +++ b/impls/matlab/+types/HashMap.m @@ -1,66 +1,66 @@ -classdef HashMap < handle - properties - data - meta = type_utils.nil; - end - methods - function obj = HashMap(varargin) - if nargin == 0 - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - obj.data = Dict(); - else - obj.data = containers.Map(); - end - else - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - obj.data = Dict(); - for i=1:2:length(varargin) - obj.data(varargin{i}) = varargin{i+1}; - end - else - obj.data = containers.Map(varargin(1:2:end), ... - varargin(2:2:end)); - end - end - end - - function len = length(obj) - len = length(obj.data); - end - - function ret = get(obj, key) - ret = obj.data(key); - end - - function ret = set(obj, key, val) - obj.data(key) = val; - ret = val; - end - - function ret = keys(obj) - ret = obj.data.keys(); - end - - function ret = values(obj) - ret = obj.data.values(); - end - - function ret = clone(obj) - ret = types.HashMap(); - if length(obj) > 0 - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - ret.data = Dict(obj.data.keys(), obj.data.values()); - else - ret.data = containers.Map(obj.data.keys(), obj.data.values()); - end - else - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - ret.data = Dict(); - else - ret.data = containers.Map(); - end - end - ret.meta = obj.meta; - end - end -end +classdef HashMap < handle + properties + data + meta = type_utils.nil; + end + methods + function obj = HashMap(varargin) + if nargin == 0 + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + obj.data = Dict(); + else + obj.data = containers.Map(); + end + else + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + obj.data = Dict(); + for i=1:2:length(varargin) + obj.data(varargin{i}) = varargin{i+1}; + end + else + obj.data = containers.Map(varargin(1:2:end), ... + varargin(2:2:end)); + end + end + end + + function len = length(obj) + len = length(obj.data); + end + + function ret = get(obj, key) + ret = obj.data(key); + end + + function ret = set(obj, key, val) + obj.data(key) = val; + ret = val; + end + + function ret = keys(obj) + ret = obj.data.keys(); + end + + function ret = values(obj) + ret = obj.data.values(); + end + + function ret = clone(obj) + ret = types.HashMap(); + if length(obj) > 0 + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + ret.data = Dict(obj.data.keys(), obj.data.values()); + else + ret.data = containers.Map(obj.data.keys(), obj.data.values()); + end + else + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + ret.data = Dict(); + else + ret.data = containers.Map(); + end + end + ret.meta = obj.meta; + end + end +end diff --git a/impls/matlab/+types/List.m b/impls/matlab/+types/List.m index f96ae4cddd..bc7608d389 100644 --- a/impls/matlab/+types/List.m +++ b/impls/matlab/+types/List.m @@ -1,67 +1,67 @@ -classdef List < handle - properties - data - meta = type_utils.nil; - end - methods - function obj = List(varargin) - obj.data = varargin; - meta = type_utils.nil; - end - - function len = length(obj) - len = length(obj.data); - end - - function ret = get(obj, idx) - ret = obj.data{idx}; - end - - function ret = set(obj, key, val) - obj.data{key} = val; - ret = val; - end - - function ret = append(obj, val) - obj.data{end+1} = val; - ret = val; - end - - function ret = slice(obj, start, last) - if nargin < 3 - last = length(obj.data); - end - ret = types.List(obj.data{start:last}); - end - - function ret = clone(obj) - ret = types.List(); - ret.data = obj.data; - ret.meta = obj.meta; - end - -% function varargout = subsref(vec, S) -% % This doesn't work for ranges -% [varargout{1:nargout}] = builtin('subsref', vec.data, S); -% -% varargout = cell(1,max(1,nargout)); -% [varargout{:}] = builtin('subsref',vec.data,S); -% -%% switch S.type -%% case '()' -%% varargout = cell(1,numel(vec)); -%% varargout{1} = builtin('subsref', vec.data, S); -%% case '{}' -%% varargout = cell(1,numel(vec)); -%% varargout{1} = builtin('subsref', vec.data, S); -%% case '.' -%% error('Vector property access not yet implemented'); -%% end -% end - -% %function n = numel(varargin) -% % n = 1; -% %end - - end -end +classdef List < handle + properties + data + meta = type_utils.nil; + end + methods + function obj = List(varargin) + obj.data = varargin; + meta = type_utils.nil; + end + + function len = length(obj) + len = length(obj.data); + end + + function ret = get(obj, idx) + ret = obj.data{idx}; + end + + function ret = set(obj, key, val) + obj.data{key} = val; + ret = val; + end + + function ret = append(obj, val) + obj.data{end+1} = val; + ret = val; + end + + function ret = slice(obj, start, last) + if nargin < 3 + last = length(obj.data); + end + ret = types.List(obj.data{start:last}); + end + + function ret = clone(obj) + ret = types.List(); + ret.data = obj.data; + ret.meta = obj.meta; + end + +% function varargout = subsref(vec, S) +% % This doesn't work for ranges +% [varargout{1:nargout}] = builtin('subsref', vec.data, S); +% +% varargout = cell(1,max(1,nargout)); +% [varargout{:}] = builtin('subsref',vec.data,S); +% +%% switch S.type +%% case '()' +%% varargout = cell(1,numel(vec)); +%% varargout{1} = builtin('subsref', vec.data, S); +%% case '{}' +%% varargout = cell(1,numel(vec)); +%% varargout{1} = builtin('subsref', vec.data, S); +%% case '.' +%% error('Vector property access not yet implemented'); +%% end +% end + +% %function n = numel(varargin) +% % n = 1; +% %end + + end +end diff --git a/impls/matlab/+types/MalException.m b/impls/matlab/+types/MalException.m index 1269a1d54f..fba5af17b9 100644 --- a/impls/matlab/+types/MalException.m +++ b/impls/matlab/+types/MalException.m @@ -1,11 +1,11 @@ -classdef MalException < MException - properties - obj - end - methods - function exc = MalException(obj) - exc@MException('MalException:object', 'MalException'); - exc.obj = obj; - end - end -end +classdef MalException < MException + properties + obj + end + methods + function exc = MalException(obj) + exc@MException('MalException:object', 'MalException'); + exc.obj = obj; + end + end +end diff --git a/impls/matlab/+types/Nil.m b/impls/matlab/+types/Nil.m index 7aa8130138..9f8ad7060e 100644 --- a/impls/matlab/+types/Nil.m +++ b/impls/matlab/+types/Nil.m @@ -1,10 +1,10 @@ -classdef Nil - methods - function len = length(obj) - len = 0; - end - function ret = eq(a,b) - ret = strcmp(class(b),'types.Nil'); - end - end -end +classdef Nil + methods + function len = length(obj) + len = 0; + end + function ret = eq(a,b) + ret = strcmp(class(b),'types.Nil'); + end + end +end diff --git a/impls/matlab/+types/Reader.m b/impls/matlab/+types/Reader.m index c18ea54d28..2b08143082 100644 --- a/impls/matlab/+types/Reader.m +++ b/impls/matlab/+types/Reader.m @@ -1,27 +1,27 @@ -classdef Reader < handle - properties - tokens - position - end - methods - function rdr = Reader(tokens) - rdr.tokens = tokens; - rdr.position = 1; - end - function tok = next(rdr) - rdr.position = rdr.position + 1; - if rdr.position-1 > length(rdr.tokens) - tok = false; - else - tok = rdr.tokens{rdr.position-1}; - end - end - function tok = peek(rdr) - if rdr.position > length(rdr.tokens) - tok = false; - else - tok = rdr.tokens{rdr.position}; - end - end - end -end +classdef Reader < handle + properties + tokens + position + end + methods + function rdr = Reader(tokens) + rdr.tokens = tokens; + rdr.position = 1; + end + function tok = next(rdr) + rdr.position = rdr.position + 1; + if rdr.position-1 > length(rdr.tokens) + tok = false; + else + tok = rdr.tokens{rdr.position-1}; + end + end + function tok = peek(rdr) + if rdr.position > length(rdr.tokens) + tok = false; + else + tok = rdr.tokens{rdr.position}; + end + end + end +end diff --git a/impls/matlab/+types/Symbol.m b/impls/matlab/+types/Symbol.m index 5da6b7a241..a985b6249c 100644 --- a/impls/matlab/+types/Symbol.m +++ b/impls/matlab/+types/Symbol.m @@ -1,13 +1,13 @@ -classdef Symbol - properties - name - end - methods - function sym = Symbol(name) - sym.name = name; - end - function ret = eq(a,b) - ret = strcmp(a.name, b.name); - end - end -end +classdef Symbol + properties + name + end + methods + function sym = Symbol(name) + sym.name = name; + end + function ret = eq(a,b) + ret = strcmp(a.name, b.name); + end + end +end diff --git a/impls/matlab/+types/Vector.m b/impls/matlab/+types/Vector.m index f75ae8470c..b8cd4d84ac 100644 --- a/impls/matlab/+types/Vector.m +++ b/impls/matlab/+types/Vector.m @@ -1,21 +1,21 @@ -classdef Vector < types.List - methods - function obj = Vector(varargin) - obj.data = varargin; - meta = type_utils.nil; - end - - function ret = slice(obj, start, last) - if nargin < 3 - last = length(obj.data); - end - ret = types.Vector(obj.data{2:end}); - end - - function ret = clone(obj) - ret = types.Vector(); - ret.data = obj.data; - ret.meta = obj.meta; - end - end -end +classdef Vector < types.List + methods + function obj = Vector(varargin) + obj.data = varargin; + meta = type_utils.nil; + end + + function ret = slice(obj, start, last) + if nargin < 3 + last = length(obj.data); + end + ret = types.Vector(obj.data{2:end}); + end + + function ret = clone(obj) + ret = types.Vector(); + ret.data = obj.data; + ret.meta = obj.meta; + end + end +end diff --git a/impls/matlab/.dockerignore b/impls/matlab/.dockerignore index 1f682026d7..52c458171b 100644 --- a/impls/matlab/.dockerignore +++ b/impls/matlab/.dockerignore @@ -1 +1 @@ -octave-4.0.0* +octave-4.0.0* diff --git a/impls/matlab/Dict.m b/impls/matlab/Dict.m index f0f15ec60e..a318ce3b12 100644 --- a/impls/matlab/Dict.m +++ b/impls/matlab/Dict.m @@ -1,61 +1,61 @@ -% Implement containers.Map like structure -% This only applies to GNU Octave and will break in Matlab when -% arbitrary string keys are used. -classdef Dict < handle - properties - data - end - methods - function dict = Dict(keys, values) - dict.data = struct(); - - if nargin > 0 - for i=1:length(keys) - dict.data.(keys{i}) = values{i}; - end - end - end - - function ret = subsasgn(dict, ind, val) - dict.data.(ind(1).subs{1}) = val; - ret = dict; - end - function ret = subsref(dict, ind) - if strcmp('.', ind(1).type) - % Function call - switch ind(1).subs - case 'isKey' - if numel(ind) > 1 - ret = isfield(dict.data, ind(2).subs{1}); - else - error('Dict:invalidArgs', ... - sprintf('''%s'' called with no arguments', ind(1).subs)); - end - case 'keys' - ret = fieldnames(dict.data); - case 'values' - ret = {}; - keys = fieldnames(dict.data); - for i=1:length(keys) - ret{end+1} = dict.data.(keys{i}); - end - case 'remove' - if numel(ind) > 1 - if numel(ind(2).subs) > 0 - dict.data = rmfield(dict.data, ind(2).subs{1}); - end - else - error('Dict:invalidArgs', ... - sprintf('''%s'' called with no arguments', ind(1).subs)); - end - otherwise - error('Dict:notfound', ... - sprintf('''%s'' not found', ind(1).subs)); - end - else - % Key lookup - ret = dict.data.(ind(1).subs{1}); - end - end - end -end +% Implement containers.Map like structure +% This only applies to GNU Octave and will break in Matlab when +% arbitrary string keys are used. +classdef Dict < handle + properties + data + end + methods + function dict = Dict(keys, values) + dict.data = struct(); + + if nargin > 0 + for i=1:length(keys) + dict.data.(keys{i}) = values{i}; + end + end + end + + function ret = subsasgn(dict, ind, val) + dict.data.(ind(1).subs{1}) = val; + ret = dict; + end + function ret = subsref(dict, ind) + if strcmp('.', ind(1).type) + % Function call + switch ind(1).subs + case 'isKey' + if numel(ind) > 1 + ret = isfield(dict.data, ind(2).subs{1}); + else + error('Dict:invalidArgs', ... + sprintf('''%s'' called with no arguments', ind(1).subs)); + end + case 'keys' + ret = fieldnames(dict.data); + case 'values' + ret = {}; + keys = fieldnames(dict.data); + for i=1:length(keys) + ret{end+1} = dict.data.(keys{i}); + end + case 'remove' + if numel(ind) > 1 + if numel(ind(2).subs) > 0 + dict.data = rmfield(dict.data, ind(2).subs{1}); + end + else + error('Dict:invalidArgs', ... + sprintf('''%s'' called with no arguments', ind(1).subs)); + end + otherwise + error('Dict:notfound', ... + sprintf('''%s'' not found', ind(1).subs)); + end + else + % Key lookup + ret = dict.data.(ind(1).subs{1}); + end + end + end +end diff --git a/impls/matlab/Dockerfile b/impls/matlab/Dockerfile index 4ac3468975..31ecf3d1d1 100644 --- a/impls/matlab/Dockerfile +++ b/impls/matlab/Dockerfile @@ -1,35 +1,35 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Java and maven deps -RUN apt-get -y install openjdk-8-jdk -RUN apt-get -y install maven -ENV MAVEN_OPTS -Duser.home=/mal - -# GNU Octave -RUN apt-get -y install software-properties-common && \ - apt-add-repository -y ppa:octave/stable && \ - apt-get -y update && \ - apt-get -y install octave - -ENV HOME /mal +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Java and maven deps +RUN apt-get -y install openjdk-8-jdk +RUN apt-get -y install maven +ENV MAVEN_OPTS -Duser.home=/mal + +# GNU Octave +RUN apt-get -y install software-properties-common && \ + apt-add-repository -y ppa:octave/stable && \ + apt-get -y update && \ + apt-get -y install octave + +ENV HOME /mal diff --git a/impls/matlab/Env.m b/impls/matlab/Env.m index d541a14348..6486297149 100644 --- a/impls/matlab/Env.m +++ b/impls/matlab/Env.m @@ -1,67 +1,67 @@ -classdef Env < handle - properties - data - outer - end - methods - function env = Env(outer, binds, exprs) - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - env.data = Dict(); - else - env.data = containers.Map(); - end - - if nargin == 0 - env.outer = false; - else - % Workaround Octave calling bug when the first - % argument is the same type as the class (the class is - % not properly initialized in that case) - env.outer = outer{1}; - end - - if nargin > 1 - %env = Env(outer); - for i=1:length(binds) - k = binds.get(i).name; - if strcmp(k, '&') - env.data(binds.get(i+1).name) = exprs.slice(i); - break; - else - env.data(k) = exprs.get(i); - end - end - end - end - - function ret = set(env, k, v) - env.data(k.name) = v; - ret = v; - end - function ret = find(env, k) - if env.data.isKey(k.name) - ret = env; - else - if ~islogical(env.outer) - ret = env.outer.find(k); - else - ret = false; - end - end - end - function ret = get(env, k) - fenv = env.find(k); - if ~islogical(fenv) - ret = fenv.data(k.name); - else - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - error('ENV:notfound', ... - sprintf('''%s'' not found', k.name)); - else - throw(MException('ENV:notfound', ... - sprintf('''%s'' not found', k.name))); - end - end - end - end -end +classdef Env < handle + properties + data + outer + end + methods + function env = Env(outer, binds, exprs) + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + env.data = Dict(); + else + env.data = containers.Map(); + end + + if nargin == 0 + env.outer = false; + else + % Workaround Octave calling bug when the first + % argument is the same type as the class (the class is + % not properly initialized in that case) + env.outer = outer{1}; + end + + if nargin > 1 + %env = Env(outer); + for i=1:length(binds) + k = binds.get(i).name; + if strcmp(k, '&') + env.data(binds.get(i+1).name) = exprs.slice(i); + break; + else + env.data(k) = exprs.get(i); + end + end + end + end + + function ret = set(env, k, v) + env.data(k.name) = v; + ret = v; + end + function ret = find(env, k) + if env.data.isKey(k.name) + ret = env; + else + if ~islogical(env.outer) + ret = env.outer.find(k); + else + ret = false; + end + end + end + function ret = get(env, k) + fenv = env.find(k); + if ~islogical(fenv) + ret = fenv.data(k.name); + else + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + error('ENV:notfound', ... + sprintf('''%s'' not found', k.name)); + else + throw(MException('ENV:notfound', ... + sprintf('''%s'' not found', k.name))); + end + end + end + end +end diff --git a/impls/matlab/Makefile b/impls/matlab/Makefile index 82fa2ef848..376cd696a1 100644 --- a/impls/matlab/Makefile +++ b/impls/matlab/Makefile @@ -1,4 +1,4 @@ -all: - -clean: - +all: + +clean: + diff --git a/impls/matlab/core.m b/impls/matlab/core.m index 44c0ba4e90..f1aceea5da 100644 --- a/impls/matlab/core.m +++ b/impls/matlab/core.m @@ -1,304 +1,304 @@ -classdef core - methods(Static) - function ret = throw(obj) - ret = type_utils.nil; - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - % Until Octave has MException objects, we need to - % store the error object globally to be able to pass - % it to the error handler. - global error_object; - error_object = obj; - exc = struct('identifier', 'MalException:object',... - 'message', 'MalException'); - rethrow(exc); - else - throw(types.MalException(obj)); - end - end - - function str = pr_str(varargin) - strs = cellfun(@(s) printer.pr_str(s,true), varargin, ... - 'UniformOutput', false); - str = strjoin(strs, ' '); - end - function str = do_str(varargin) - strs = cellfun(@(s) printer.pr_str(s,false), varargin, ... - 'UniformOutput', false); - str = strjoin(strs, ''); - end - function ret = prn(varargin) - strs = cellfun(@(s) printer.pr_str(s,true), varargin, ... - 'UniformOutput', false); - fprintf('%s\n', strjoin(strs, ' ')); - ret = type_utils.nil; - end - function ret = println(varargin) - strs = cellfun(@(s) printer.pr_str(s,false), varargin, ... - 'UniformOutput', false); - fprintf('%s\n', strjoin(strs, ' ')); - ret = type_utils.nil; - end - - function ret = time_ms() - secs = now-repmat(datenum('1970-1-1 00:00:00'),size(now)); - ret = floor(secs.*repmat(24*3600.0*1000,size(now))); - end - - function new_hm = assoc(hm, varargin) - new_hm = clone(hm); - for i=1:2:length(varargin) - new_hm.set(varargin{i}, varargin{i+1}); - end - end - - function new_hm = dissoc(hm, varargin) - new_hm = clone(hm); - ks = intersect(hm.keys(),varargin); - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - new_hm.data.remove(ks); - else - remove(new_hm.data, ks); - end - end - - function ret = get(hm, key) - if isa(hm, 'types.Nil') - ret = type_utils.nil; - elseif hm.data.isKey(key) - ret = hm.data(key); - else - ret = type_utils.nil; - end - end - - function ret = keys(hm) - ks = hm.keys(); - ret = types.List(ks{:}); - end - - function ret = vals(hm) - vs = hm.values(); - ret = types.List(vs{:}); - end - - function ret = cons(a, seq) - cella = [{a}, seq.data]; - ret = types.List(cella{:}); - end - - function ret = concat(varargin) - if nargin == 0 - cella = {}; - else - cells = cellfun(@(x) x.data, varargin, ... - 'UniformOutput', false); - cella = cat(2,cells{:}); - end - ret = types.List(cella{:}); - end - - function ret = first(seq) - if isa(seq, 'types.Nil') - ret = type_utils.nil; - elseif length(seq) < 1 - ret = type_utils.nil; - else - ret = seq.get(1); - end - end - - function ret = rest(seq) - if isa(seq, 'types.Nil') - ret = types.List(); - else - cella = seq.data(2:end); - ret = types.List(cella{:}); - end - end - - function ret = nth(seq, idx) - if idx+1 > length(seq) - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - error('Range:nth', ... - 'nth: index out of range'); - else - throw(MException('Range:nth', ... - 'nth: index out of range')) - end - end - ret = seq.get(idx+1); - end - - function ret = apply(varargin) - f = varargin{1}; - if isa(f, 'types.Function') - f = f.fn; - end - first_args = varargin(2:end-1); - rest_args = varargin{end}.data; - args = [first_args rest_args]; - ret = f(args{:}); - end - - function ret = map(f, lst) - if isa(f, 'types.Function') - f = f.fn; - end - cells = cellfun(@(x) f(x), lst.data, 'UniformOutput', false); - ret = types.List(cells{:}); - end - - function ret = conj(varargin) - seq = varargin{1}; - args = varargin(2:end); - if type_utils.list_Q(seq) - cella = [fliplr(args), seq.data]; - ret = types.List(cella{:}); - else - cella = [seq.data, args]; - ret = types.Vector(cella{:}); - end - end - - function ret = seq(obj) - if type_utils.list_Q(obj) - if length(obj) > 0 - ret = obj; - else - ret = type_utils.nil; - end - elseif type_utils.vector_Q(obj) - if length(obj) > 0 - ret = types.List(obj.data{:}); - else - ret = type_utils.nil; - end - elseif type_utils.string_Q(obj) - if length(obj) > 0 - cells = cellfun(@(c) char(c),... - num2cell(double(obj)),... - 'UniformOutput', false); - ret = types.List(cells{:}); - else - ret = type_utils.nil; - end - elseif isa(obj, 'types.Nil') - ret = type_utils.nil; - else - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - error('Type:seq', ... - 'seq: called on non-sequence'); - else - throw(MException('Type:seq',... - 'seq: called on non-sequence')) - end - end - end - - function new_obj = with_meta(obj, meta) - new_obj = clone(obj); - new_obj.meta = meta; - end - - function meta = meta(obj) - switch class(obj) - case {'types.List', 'types.Vector', - 'types.HashMap', 'types.Function'} - meta = obj.meta; - otherwise - meta = type_utils.nil; - end - end - - function ret = reset_BANG(atm, val) - atm.val = val; - ret = val; - end - - function ret = swap_BANG(atm, f, varargin) - args = [{atm.val} varargin]; - if isa(f, 'types.Function') - f = f.fn; - end - atm.val = f(args{:}); - ret = atm.val; - end - - function n = ns() - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - n = Dict(); - else - n = containers.Map(); - end - n('=') = @(a,b) type_utils.equal(a,b); - n('throw') = @(a) core.throw(a); - n('nil?') = @(a) isa(a, 'types.Nil'); - n('true?') = @(a) isa(a, 'logical') && a == true; - n('false?') = @(a) isa(a, 'logical') && a == false; - n('string?') = @(a) type_utils.string_Q(a); - n('symbol') = @(a) types.Symbol(a); - n('symbol?') = @(a) isa(a, 'types.Symbol'); - n('keyword') = @(a) type_utils.keyword(a); - n('keyword?') = @(a) type_utils.keyword_Q(a); - n('number?') = @(a) type_utils.number_Q(a); - n('fn?') = @(a) type_utils.fn_Q(a); - n('macro?') = @(a) type_utils.macro_Q(a); - - n('pr-str') = @(varargin) core.pr_str(varargin{:}); - n('str') = @(varargin) core.do_str(varargin{:}); - n('prn') = @(varargin) core.prn(varargin{:}); - n('println') = @(varargin) core.println(varargin{:}); - n('read-string') = @(a) reader.read_str(a); - n('readline') = @(p) input(p, 's'); - n('slurp') = @(a) fileread(a); - - n('<') = @(a,b) a') = @(a,b) a>b; - n('>=') = @(a,b) a>=b; - n('+') = @(a,b) a+b; - n('-') = @(a,b) a-b; - n('*') = @(a,b) a*b; - n('/') = @(a,b) floor(a/b); - n('time-ms') = @() core.time_ms(); - - n('list') = @(varargin) types.List(varargin{:}); - n('list?') = @(a) type_utils.list_Q(a); - n('vector') = @(varargin) types.Vector(varargin{:}); - n('vector?') = @(a) type_utils.vector_Q(a); - n('hash-map') = @(varargin) types.HashMap(varargin{:}); - n('map?') = @(a) type_utils.hash_map_Q(a); - n('assoc') = @(varargin) core.assoc(varargin{:}); - n('dissoc') = @(varargin) core.dissoc(varargin{:}); - n('get') = @(a,b) core.get(a,b); - n('contains?') = @(a,b) a.data.isKey(b); - n('keys') = @(a) core.keys(a); - n('vals') = @(a) core.vals(a); - - n('sequential?') = @(a) type_utils.sequential_Q(a); - n('cons') = @(a,b) core.cons(a,b); - n('concat') = @(varargin) core.concat(varargin{:}); - n('vec') = @(a) types.Vector(a.data{:}); - n('nth') = @(a,b) core.nth(a,b); - n('first') = @(a) core.first(a); - n('rest') = @(a) core.rest(a); - n('empty?') = @(a) length(a) == 0; - % workaround Octave always giving length(a) of 1 - n('count') = @(a) 0 + length(a); - n('apply') = @(varargin) core.apply(varargin{:}); - n('map') = @(varargin) core.map(varargin{:}); - - n('conj') = @(varargin) core.conj(varargin{:}); - n('seq') = @(a) core.seq(a); - - n('with-meta') = @(a,b) core.with_meta(a,b); - n('meta') = @(a) core.meta(a); - n('atom') = @(a) types.Atom(a); - n('atom?') = @(a) isa(a, 'types.Atom'); - n('deref') = @(a) a.val; - n('reset!') = @(a,b) core.reset_BANG(a,b); - n('swap!') = @(varargin) core.swap_BANG(varargin{:}); - end - end -end - +classdef core + methods(Static) + function ret = throw(obj) + ret = type_utils.nil; + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + % Until Octave has MException objects, we need to + % store the error object globally to be able to pass + % it to the error handler. + global error_object; + error_object = obj; + exc = struct('identifier', 'MalException:object',... + 'message', 'MalException'); + rethrow(exc); + else + throw(types.MalException(obj)); + end + end + + function str = pr_str(varargin) + strs = cellfun(@(s) printer.pr_str(s,true), varargin, ... + 'UniformOutput', false); + str = strjoin(strs, ' '); + end + function str = do_str(varargin) + strs = cellfun(@(s) printer.pr_str(s,false), varargin, ... + 'UniformOutput', false); + str = strjoin(strs, ''); + end + function ret = prn(varargin) + strs = cellfun(@(s) printer.pr_str(s,true), varargin, ... + 'UniformOutput', false); + fprintf('%s\n', strjoin(strs, ' ')); + ret = type_utils.nil; + end + function ret = println(varargin) + strs = cellfun(@(s) printer.pr_str(s,false), varargin, ... + 'UniformOutput', false); + fprintf('%s\n', strjoin(strs, ' ')); + ret = type_utils.nil; + end + + function ret = time_ms() + secs = now-repmat(datenum('1970-1-1 00:00:00'),size(now)); + ret = floor(secs.*repmat(24*3600.0*1000,size(now))); + end + + function new_hm = assoc(hm, varargin) + new_hm = clone(hm); + for i=1:2:length(varargin) + new_hm.set(varargin{i}, varargin{i+1}); + end + end + + function new_hm = dissoc(hm, varargin) + new_hm = clone(hm); + ks = intersect(hm.keys(),varargin); + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + new_hm.data.remove(ks); + else + remove(new_hm.data, ks); + end + end + + function ret = get(hm, key) + if isa(hm, 'types.Nil') + ret = type_utils.nil; + elseif hm.data.isKey(key) + ret = hm.data(key); + else + ret = type_utils.nil; + end + end + + function ret = keys(hm) + ks = hm.keys(); + ret = types.List(ks{:}); + end + + function ret = vals(hm) + vs = hm.values(); + ret = types.List(vs{:}); + end + + function ret = cons(a, seq) + cella = [{a}, seq.data]; + ret = types.List(cella{:}); + end + + function ret = concat(varargin) + if nargin == 0 + cella = {}; + else + cells = cellfun(@(x) x.data, varargin, ... + 'UniformOutput', false); + cella = cat(2,cells{:}); + end + ret = types.List(cella{:}); + end + + function ret = first(seq) + if isa(seq, 'types.Nil') + ret = type_utils.nil; + elseif length(seq) < 1 + ret = type_utils.nil; + else + ret = seq.get(1); + end + end + + function ret = rest(seq) + if isa(seq, 'types.Nil') + ret = types.List(); + else + cella = seq.data(2:end); + ret = types.List(cella{:}); + end + end + + function ret = nth(seq, idx) + if idx+1 > length(seq) + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + error('Range:nth', ... + 'nth: index out of range'); + else + throw(MException('Range:nth', ... + 'nth: index out of range')) + end + end + ret = seq.get(idx+1); + end + + function ret = apply(varargin) + f = varargin{1}; + if isa(f, 'types.Function') + f = f.fn; + end + first_args = varargin(2:end-1); + rest_args = varargin{end}.data; + args = [first_args rest_args]; + ret = f(args{:}); + end + + function ret = map(f, lst) + if isa(f, 'types.Function') + f = f.fn; + end + cells = cellfun(@(x) f(x), lst.data, 'UniformOutput', false); + ret = types.List(cells{:}); + end + + function ret = conj(varargin) + seq = varargin{1}; + args = varargin(2:end); + if type_utils.list_Q(seq) + cella = [fliplr(args), seq.data]; + ret = types.List(cella{:}); + else + cella = [seq.data, args]; + ret = types.Vector(cella{:}); + end + end + + function ret = seq(obj) + if type_utils.list_Q(obj) + if length(obj) > 0 + ret = obj; + else + ret = type_utils.nil; + end + elseif type_utils.vector_Q(obj) + if length(obj) > 0 + ret = types.List(obj.data{:}); + else + ret = type_utils.nil; + end + elseif type_utils.string_Q(obj) + if length(obj) > 0 + cells = cellfun(@(c) char(c),... + num2cell(double(obj)),... + 'UniformOutput', false); + ret = types.List(cells{:}); + else + ret = type_utils.nil; + end + elseif isa(obj, 'types.Nil') + ret = type_utils.nil; + else + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + error('Type:seq', ... + 'seq: called on non-sequence'); + else + throw(MException('Type:seq',... + 'seq: called on non-sequence')) + end + end + end + + function new_obj = with_meta(obj, meta) + new_obj = clone(obj); + new_obj.meta = meta; + end + + function meta = meta(obj) + switch class(obj) + case {'types.List', 'types.Vector', + 'types.HashMap', 'types.Function'} + meta = obj.meta; + otherwise + meta = type_utils.nil; + end + end + + function ret = reset_BANG(atm, val) + atm.val = val; + ret = val; + end + + function ret = swap_BANG(atm, f, varargin) + args = [{atm.val} varargin]; + if isa(f, 'types.Function') + f = f.fn; + end + atm.val = f(args{:}); + ret = atm.val; + end + + function n = ns() + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + n = Dict(); + else + n = containers.Map(); + end + n('=') = @(a,b) type_utils.equal(a,b); + n('throw') = @(a) core.throw(a); + n('nil?') = @(a) isa(a, 'types.Nil'); + n('true?') = @(a) isa(a, 'logical') && a == true; + n('false?') = @(a) isa(a, 'logical') && a == false; + n('string?') = @(a) type_utils.string_Q(a); + n('symbol') = @(a) types.Symbol(a); + n('symbol?') = @(a) isa(a, 'types.Symbol'); + n('keyword') = @(a) type_utils.keyword(a); + n('keyword?') = @(a) type_utils.keyword_Q(a); + n('number?') = @(a) type_utils.number_Q(a); + n('fn?') = @(a) type_utils.fn_Q(a); + n('macro?') = @(a) type_utils.macro_Q(a); + + n('pr-str') = @(varargin) core.pr_str(varargin{:}); + n('str') = @(varargin) core.do_str(varargin{:}); + n('prn') = @(varargin) core.prn(varargin{:}); + n('println') = @(varargin) core.println(varargin{:}); + n('read-string') = @(a) reader.read_str(a); + n('readline') = @(p) input(p, 's'); + n('slurp') = @(a) fileread(a); + + n('<') = @(a,b) a') = @(a,b) a>b; + n('>=') = @(a,b) a>=b; + n('+') = @(a,b) a+b; + n('-') = @(a,b) a-b; + n('*') = @(a,b) a*b; + n('/') = @(a,b) floor(a/b); + n('time-ms') = @() core.time_ms(); + + n('list') = @(varargin) types.List(varargin{:}); + n('list?') = @(a) type_utils.list_Q(a); + n('vector') = @(varargin) types.Vector(varargin{:}); + n('vector?') = @(a) type_utils.vector_Q(a); + n('hash-map') = @(varargin) types.HashMap(varargin{:}); + n('map?') = @(a) type_utils.hash_map_Q(a); + n('assoc') = @(varargin) core.assoc(varargin{:}); + n('dissoc') = @(varargin) core.dissoc(varargin{:}); + n('get') = @(a,b) core.get(a,b); + n('contains?') = @(a,b) a.data.isKey(b); + n('keys') = @(a) core.keys(a); + n('vals') = @(a) core.vals(a); + + n('sequential?') = @(a) type_utils.sequential_Q(a); + n('cons') = @(a,b) core.cons(a,b); + n('concat') = @(varargin) core.concat(varargin{:}); + n('vec') = @(a) types.Vector(a.data{:}); + n('nth') = @(a,b) core.nth(a,b); + n('first') = @(a) core.first(a); + n('rest') = @(a) core.rest(a); + n('empty?') = @(a) length(a) == 0; + % workaround Octave always giving length(a) of 1 + n('count') = @(a) 0 + length(a); + n('apply') = @(varargin) core.apply(varargin{:}); + n('map') = @(varargin) core.map(varargin{:}); + + n('conj') = @(varargin) core.conj(varargin{:}); + n('seq') = @(a) core.seq(a); + + n('with-meta') = @(a,b) core.with_meta(a,b); + n('meta') = @(a) core.meta(a); + n('atom') = @(a) types.Atom(a); + n('atom?') = @(a) isa(a, 'types.Atom'); + n('deref') = @(a) a.val; + n('reset!') = @(a,b) core.reset_BANG(a,b); + n('swap!') = @(varargin) core.swap_BANG(varargin{:}); + end + end +end + diff --git a/impls/matlab/printer.m b/impls/matlab/printer.m index 91c8f0d372..4fa5b71d14 100644 --- a/impls/matlab/printer.m +++ b/impls/matlab/printer.m @@ -1,55 +1,55 @@ -% this is just being used as a namespace -classdef printer - methods (Static = true) - function str = pr_str(obj, print_readably) - switch class(obj) - case 'types.Symbol' - str = obj.name; - case 'double' - str = num2str(obj); - case 'char' - if type_utils.keyword_Q(obj) - str = sprintf(':%s', obj(2:end)); - else - if print_readably - str = strrep(obj, '\', '\\'); - str = strrep(str, '"', '\"'); - str = strrep(str, char(10), '\n'); - str = sprintf('"%s"', str); - else - str = obj; - end - end - case 'types.List' - strs = cellfun(@(x) printer.pr_str(x, print_readably), ... - obj.data, 'UniformOutput', false); - str = sprintf('(%s)', strjoin(strs, ' ')); - case 'types.Vector' - strs = cellfun(@(x) printer.pr_str(x, print_readably), ... - obj.data, 'UniformOutput', false); - str = sprintf('[%s]', strjoin(strs, ' ')); - case 'types.HashMap' - strs = {}; - ks = obj.keys(); - for i=1:length(ks) - k = ks{i}; - strs{end+1} = printer.pr_str(k, print_readably); - strs{end+1} = printer.pr_str(obj.get(k), print_readably); - end - str = sprintf('{%s}', strjoin(strs, ' ')); - case 'types.Nil' - str = 'nil'; - case 'logical' - if eq(obj, true) - str = 'true'; - else - str = 'false'; - end - case 'types.Atom' - str = sprintf('(atom %s)', printer.pr_str(obj.val,true)); - otherwise - str = '#'; - end - end - end -end +% this is just being used as a namespace +classdef printer + methods (Static = true) + function str = pr_str(obj, print_readably) + switch class(obj) + case 'types.Symbol' + str = obj.name; + case 'double' + str = num2str(obj); + case 'char' + if type_utils.keyword_Q(obj) + str = sprintf(':%s', obj(2:end)); + else + if print_readably + str = strrep(obj, '\', '\\'); + str = strrep(str, '"', '\"'); + str = strrep(str, char(10), '\n'); + str = sprintf('"%s"', str); + else + str = obj; + end + end + case 'types.List' + strs = cellfun(@(x) printer.pr_str(x, print_readably), ... + obj.data, 'UniformOutput', false); + str = sprintf('(%s)', strjoin(strs, ' ')); + case 'types.Vector' + strs = cellfun(@(x) printer.pr_str(x, print_readably), ... + obj.data, 'UniformOutput', false); + str = sprintf('[%s]', strjoin(strs, ' ')); + case 'types.HashMap' + strs = {}; + ks = obj.keys(); + for i=1:length(ks) + k = ks{i}; + strs{end+1} = printer.pr_str(k, print_readably); + strs{end+1} = printer.pr_str(obj.get(k), print_readably); + end + str = sprintf('{%s}', strjoin(strs, ' ')); + case 'types.Nil' + str = 'nil'; + case 'logical' + if eq(obj, true) + str = 'true'; + else + str = 'false'; + end + case 'types.Atom' + str = sprintf('(atom %s)', printer.pr_str(obj.val,true)); + otherwise + str = '#'; + end + end + end +end diff --git a/impls/matlab/reader.m b/impls/matlab/reader.m index 55d672c28b..0e6c05c53f 100644 --- a/impls/matlab/reader.m +++ b/impls/matlab/reader.m @@ -1,131 +1,131 @@ -% this is just being used as a namespace -classdef reader - methods (Static = true) - function tokens = tokenize(str) - re = '[\s,]*(~@|[\[\]{}()''`~^@]|"(?:\\.|[^\\"])*"?|;[^\n]*|[^\s\[\]{}(''"`,;)]*)'; - % extract the capture group (to ignore spaces and commas) - tokens = cellfun(@(x) x(1), regexp(str, re, 'tokens')); - comments = cellfun(@(x) length(x) > 0 && x(1) == ';', tokens); - tokens = tokens(~comments); - end - - function atm = read_atom(rdr) - token = rdr.next(); - %fprintf('in read_atom: %s\n', token); - if not(isempty(regexp(token, '^-?[0-9]+$', 'match'))) - atm = str2double(token); - elseif not(isempty(regexp(token, '^"(?:\\.|[^\\"])*"$', 'match'))) - atm = token(2:length(token)-1); - % If overlaps is enabled here then only the first '\\' - % is replaced. Probably an GNU Octave bug since the - % other repeated pairs are substituted correctly. - atm = strrep(atm, '\\', char(255), 'overlaps', false); - atm = strrep(atm, '\"', '"'); - atm = strrep(atm, '\n', char(10)); - atm = strrep(atm, char(255), '\'); - elseif strcmp(token(1), '"') - error('expected ''"'', got EOF'); - elseif strcmp(token(1), ':') - s = token(2:end); - atm = type_utils.keyword(s); - elseif strcmp(token, 'nil') - atm = type_utils.nil; - elseif strcmp(token, 'true') - atm = true; - elseif strcmp(token, 'false') - atm = false; - else - atm = types.Symbol(token); - end - end - - function seq = read_seq(rdr, start, last) - %fprintf('in read_seq\n'); - seq = {}; - token = rdr.next(); - if not(strcmp(token, start)) - error(sprintf('expected ''%s'', got EOF', start)); - end - token = rdr.peek(); - while true - if eq(token, false) - error(sprintf('expected ''%s'', got EOF', last)); - end - if strcmp(token, last), break, end - seq{end+1} = reader.read_form(rdr); - token = rdr.peek(); - end - rdr.next(); - end - - function lst = read_list(rdr) - seq = reader.read_seq(rdr, '(', ')'); - lst = types.List(seq{:}); - end - - function vec = read_vector(rdr) - seq = reader.read_seq(rdr, '[', ']'); - vec = types.Vector(seq{:}); - end - - function map = read_hash_map(rdr) - seq = reader.read_seq(rdr, '{', '}'); - map = types.HashMap(seq{:}); - end - - function ast = read_form(rdr) - %fprintf('in read_form\n'); - token = rdr.peek(); - switch token - case '''' - rdr.next(); - ast = types.List(types.Symbol('quote'), ... - reader.read_form(rdr)); - case '`' - rdr.next(); - ast = types.List(types.Symbol('quasiquote'), ... - reader.read_form(rdr)); - case '~' - rdr.next(); - ast = types.List(types.Symbol('unquote'), ... - reader.read_form(rdr)); - case '~@' - rdr.next(); - ast = types.List(types.Symbol('splice-unquote'), ... - reader.read_form(rdr)); - case '^' - rdr.next(); - meta = reader.read_form(rdr); - ast = types.List(types.Symbol('with-meta'), ... - reader.read_form(rdr), meta); - case '@' - rdr.next(); - ast = types.List(types.Symbol('deref'), ... - reader.read_form(rdr)); - - case ')' - error('unexpected '')'''); - case '(' - ast = reader.read_list(rdr); - case ']' - error('unexpected '']'''); - case '[' - ast = reader.read_vector(rdr); - case '}' - error('unexpected ''}'''); - case '{' - ast = reader.read_hash_map(rdr); - otherwise - ast = reader.read_atom(rdr); - end - end - - function ast = read_str(str) - %fprintf('in read_str\n'); - tokens = reader.tokenize(str); - %disp(tokens); - rdr = types.Reader(tokens); - ast = reader.read_form(rdr); - end - end -end +% this is just being used as a namespace +classdef reader + methods (Static = true) + function tokens = tokenize(str) + re = '[\s,]*(~@|[\[\]{}()''`~^@]|"(?:\\.|[^\\"])*"?|;[^\n]*|[^\s\[\]{}(''"`,;)]*)'; + % extract the capture group (to ignore spaces and commas) + tokens = cellfun(@(x) x(1), regexp(str, re, 'tokens')); + comments = cellfun(@(x) length(x) > 0 && x(1) == ';', tokens); + tokens = tokens(~comments); + end + + function atm = read_atom(rdr) + token = rdr.next(); + %fprintf('in read_atom: %s\n', token); + if not(isempty(regexp(token, '^-?[0-9]+$', 'match'))) + atm = str2double(token); + elseif not(isempty(regexp(token, '^"(?:\\.|[^\\"])*"$', 'match'))) + atm = token(2:length(token)-1); + % If overlaps is enabled here then only the first '\\' + % is replaced. Probably an GNU Octave bug since the + % other repeated pairs are substituted correctly. + atm = strrep(atm, '\\', char(255), 'overlaps', false); + atm = strrep(atm, '\"', '"'); + atm = strrep(atm, '\n', char(10)); + atm = strrep(atm, char(255), '\'); + elseif strcmp(token(1), '"') + error('expected ''"'', got EOF'); + elseif strcmp(token(1), ':') + s = token(2:end); + atm = type_utils.keyword(s); + elseif strcmp(token, 'nil') + atm = type_utils.nil; + elseif strcmp(token, 'true') + atm = true; + elseif strcmp(token, 'false') + atm = false; + else + atm = types.Symbol(token); + end + end + + function seq = read_seq(rdr, start, last) + %fprintf('in read_seq\n'); + seq = {}; + token = rdr.next(); + if not(strcmp(token, start)) + error(sprintf('expected ''%s'', got EOF', start)); + end + token = rdr.peek(); + while true + if eq(token, false) + error(sprintf('expected ''%s'', got EOF', last)); + end + if strcmp(token, last), break, end + seq{end+1} = reader.read_form(rdr); + token = rdr.peek(); + end + rdr.next(); + end + + function lst = read_list(rdr) + seq = reader.read_seq(rdr, '(', ')'); + lst = types.List(seq{:}); + end + + function vec = read_vector(rdr) + seq = reader.read_seq(rdr, '[', ']'); + vec = types.Vector(seq{:}); + end + + function map = read_hash_map(rdr) + seq = reader.read_seq(rdr, '{', '}'); + map = types.HashMap(seq{:}); + end + + function ast = read_form(rdr) + %fprintf('in read_form\n'); + token = rdr.peek(); + switch token + case '''' + rdr.next(); + ast = types.List(types.Symbol('quote'), ... + reader.read_form(rdr)); + case '`' + rdr.next(); + ast = types.List(types.Symbol('quasiquote'), ... + reader.read_form(rdr)); + case '~' + rdr.next(); + ast = types.List(types.Symbol('unquote'), ... + reader.read_form(rdr)); + case '~@' + rdr.next(); + ast = types.List(types.Symbol('splice-unquote'), ... + reader.read_form(rdr)); + case '^' + rdr.next(); + meta = reader.read_form(rdr); + ast = types.List(types.Symbol('with-meta'), ... + reader.read_form(rdr), meta); + case '@' + rdr.next(); + ast = types.List(types.Symbol('deref'), ... + reader.read_form(rdr)); + + case ')' + error('unexpected '')'''); + case '(' + ast = reader.read_list(rdr); + case ']' + error('unexpected '']'''); + case '[' + ast = reader.read_vector(rdr); + case '}' + error('unexpected ''}'''); + case '{' + ast = reader.read_hash_map(rdr); + otherwise + ast = reader.read_atom(rdr); + end + end + + function ast = read_str(str) + %fprintf('in read_str\n'); + tokens = reader.tokenize(str); + %disp(tokens); + rdr = types.Reader(tokens); + ast = reader.read_form(rdr); + end + end +end diff --git a/impls/matlab/run b/impls/matlab/run index e3f209dea1..a8abd01305 100755 --- a/impls/matlab/run +++ b/impls/matlab/run @@ -1,13 +1,13 @@ -#!/bin/bash -args="" -if [ "$#" -gt 0 ]; then - args="'$1'" - for a in "${@:2}"; do - args="$args,'$a'" - done -fi -if [ "$matlab_MODE" = "matlab" ] ; then - exec matlab -nodisplay -nosplash -nodesktop -nojvm -r "${STEP:-stepA_mal}($args);quit;" -else - exec octave -q --no-gui --no-history --eval "${STEP:-stepA_mal}($args);quit;" -fi +#!/bin/bash +args="" +if [ "$#" -gt 0 ]; then + args="'$1'" + for a in "${@:2}"; do + args="$args,'$a'" + done +fi +if [ "$matlab_MODE" = "matlab" ] ; then + exec matlab -nodisplay -nosplash -nodesktop -nojvm -r "${STEP:-stepA_mal}($args);quit;" +else + exec octave -q --no-gui --no-history --eval "${STEP:-stepA_mal}($args);quit;" +fi diff --git a/impls/matlab/step0_repl.m b/impls/matlab/step0_repl.m index 3b4e7ca36b..44ae38bf97 100644 --- a/impls/matlab/step0_repl.m +++ b/impls/matlab/step0_repl.m @@ -1,28 +1,28 @@ -function step0_repl(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = str; -end - -% eval -function ret = EVAL(ast, env) - ret = ast; -end - -% print -function ret = PRINT(ast) - ret = ast; -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - while (true) - line = input('user> ', 's'); - fprintf('%s\n', rep(line, '')); - end -end +function step0_repl(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = str; +end + +% eval +function ret = EVAL(ast, env) + ret = ast; +end + +% print +function ret = PRINT(ast) + ret = ast; +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + while (true) + line = input('user> ', 's'); + fprintf('%s\n', rep(line, '')); + end +end diff --git a/impls/matlab/step1_read_print.m b/impls/matlab/step1_read_print.m index 06dcc57924..c06ce41b8e 100644 --- a/impls/matlab/step1_read_print.m +++ b/impls/matlab/step1_read_print.m @@ -1,39 +1,39 @@ -function step1_read_print(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = EVAL(ast, env) - ret = ast; -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - %cleanObj = onCleanup(@() disp('*** here1 ***')); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, '')); - catch err - fprintf('Error: %s\n', err.message); - type_utils.print_stack(err); - end - end -end +function step1_read_print(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = EVAL(ast, env) + ret = ast; +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + %cleanObj = onCleanup(@() disp('*** here1 ***')); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, '')); + catch err + fprintf('Error: %s\n', err.message); + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/step2_eval.m b/impls/matlab/step2_eval.m index 0f20237063..d7d0cef315 100644 --- a/impls/matlab/step2_eval.m +++ b/impls/matlab/step2_eval.m @@ -1,89 +1,89 @@ -function step2_eval(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = eval_ast(ast, env) - switch class(ast) - case 'types.Symbol' - ret = env(ast.name); - case 'types.List' - ret = types.List(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.Vector' - ret = types.Vector(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.HashMap' - ret = types.HashMap(); - ks = ast.keys(); - for i=1:length(ks) - k = ks{i}; - ret.set(k, EVAL(ast.get(k), env)); - end - otherwise - ret = ast; - end -end - -function ret = EVAL(ast, env) - %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - % apply - if length(ast) == 0 - ret = ast; - return; - end - el = eval_ast(ast, env); - f = el.get(1); - args = el.data(2:end); - ret = f(args{:}); -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - repl_env = Dict(); - else - repl_env = containers.Map(); - end - repl_env('+') = @(a,b) a+b; - repl_env('-') = @(a,b) a-b; - repl_env('*') = @(a,b) a*b; - repl_env('/') = @(a,b) floor(a/b); - - %cleanObj = onCleanup(@() disp('*** here1 ***')); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, repl_env)); - catch err - fprintf('Error: %s\n', err.message); - type_utils.print_stack(err); - end - end -end +function step2_eval(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = eval_ast(ast, env) + switch class(ast) + case 'types.Symbol' + ret = env(ast.name); + case 'types.List' + ret = types.List(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.Vector' + ret = types.Vector(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.HashMap' + ret = types.HashMap(); + ks = ast.keys(); + for i=1:length(ks) + k = ks{i}; + ret.set(k, EVAL(ast.get(k), env)); + end + otherwise + ret = ast; + end +end + +function ret = EVAL(ast, env) + %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + % apply + if length(ast) == 0 + ret = ast; + return; + end + el = eval_ast(ast, env); + f = el.get(1); + args = el.data(2:end); + ret = f(args{:}); +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + repl_env = Dict(); + else + repl_env = containers.Map(); + end + repl_env('+') = @(a,b) a+b; + repl_env('-') = @(a,b) a-b; + repl_env('*') = @(a,b) a*b; + repl_env('/') = @(a,b) floor(a/b); + + %cleanObj = onCleanup(@() disp('*** here1 ***')); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, repl_env)); + catch err + fprintf('Error: %s\n', err.message); + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/step3_env.m b/impls/matlab/step3_env.m index c85e5c69c8..6021744c4d 100644 --- a/impls/matlab/step3_env.m +++ b/impls/matlab/step3_env.m @@ -1,101 +1,101 @@ -function step3_env(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = eval_ast(ast, env) - switch class(ast) - case 'types.Symbol' - ret = env.get(ast); - case 'types.List' - ret = types.List(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.Vector' - ret = types.Vector(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.HashMap' - ret = types.HashMap(); - ks = ast.keys(); - for i=1:length(ks) - k = ks{i}; - ret.set(k, EVAL(ast.get(k), env)); - end - otherwise - ret = ast; - end -end - -function ret = EVAL(ast, env) - %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - % apply - if length(ast) == 0 - ret = ast; - return; - end - if isa(ast.get(1),'types.Symbol') - a1sym = ast.get(1).name; - else - a1sym = '_@$fn$@_'; - end - switch (a1sym) - case 'def!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - case 'let*' - let_env = Env({env}); - for i=1:2:length(ast.get(2)) - let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); - end - ret = EVAL(ast.get(3), let_env); - otherwise - el = eval_ast(ast, env); - f = el.get(1); - args = el.data(2:end); - ret = f(args{:}); - end -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - repl_env = Env(); - repl_env.set(types.Symbol('+'), @(a,b) a+b); - repl_env.set(types.Symbol('-'), @(a,b) a-b); - repl_env.set(types.Symbol('*'), @(a,b) a*b); - repl_env.set(types.Symbol('/'), @(a,b) floor(a/b)); - - %cleanObj = onCleanup(@() disp('*** here1 ***')); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, repl_env)); - catch err - fprintf('Error: %s\n', err.message); - type_utils.print_stack(err); - end - end -end +function step3_env(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = eval_ast(ast, env) + switch class(ast) + case 'types.Symbol' + ret = env.get(ast); + case 'types.List' + ret = types.List(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.Vector' + ret = types.Vector(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.HashMap' + ret = types.HashMap(); + ks = ast.keys(); + for i=1:length(ks) + k = ks{i}; + ret.set(k, EVAL(ast.get(k), env)); + end + otherwise + ret = ast; + end +end + +function ret = EVAL(ast, env) + %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + % apply + if length(ast) == 0 + ret = ast; + return; + end + if isa(ast.get(1),'types.Symbol') + a1sym = ast.get(1).name; + else + a1sym = '_@$fn$@_'; + end + switch (a1sym) + case 'def!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + case 'let*' + let_env = Env({env}); + for i=1:2:length(ast.get(2)) + let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); + end + ret = EVAL(ast.get(3), let_env); + otherwise + el = eval_ast(ast, env); + f = el.get(1); + args = el.data(2:end); + ret = f(args{:}); + end +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + repl_env = Env(); + repl_env.set(types.Symbol('+'), @(a,b) a+b); + repl_env.set(types.Symbol('-'), @(a,b) a-b); + repl_env.set(types.Symbol('*'), @(a,b) a*b); + repl_env.set(types.Symbol('/'), @(a,b) floor(a/b)); + + %cleanObj = onCleanup(@() disp('*** here1 ***')); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, repl_env)); + catch err + fprintf('Error: %s\n', err.message); + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/step4_if_fn_do.m b/impls/matlab/step4_if_fn_do.m index 2e1b651327..0e20225cc5 100644 --- a/impls/matlab/step4_if_fn_do.m +++ b/impls/matlab/step4_if_fn_do.m @@ -1,125 +1,125 @@ -function step4_if_fn_do(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = eval_ast(ast, env) - switch class(ast) - case 'types.Symbol' - ret = env.get(ast); - case 'types.List' - ret = types.List(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.Vector' - ret = types.Vector(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.HashMap' - ret = types.HashMap(); - ks = ast.keys(); - for i=1:length(ks) - k = ks{i}; - ret.set(k, EVAL(ast.get(k), env)); - end - otherwise - ret = ast; - end -end - -function ret = EVAL(ast, env) - %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - % apply - if length(ast) == 0 - ret = ast; - return; - end - if isa(ast.get(1),'types.Symbol') - a1sym = ast.get(1).name; - else - a1sym = '_@$fn$@_'; - end - switch (a1sym) - case 'def!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - case 'let*' - let_env = Env({env}); - for i=1:2:length(ast.get(2)) - let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); - end - ret = EVAL(ast.get(3), let_env); - case 'do' - el = eval_ast(ast.slice(2), env); - ret = el.get(length(el)); - case 'if' - cond = EVAL(ast.get(2), env); - if strcmp(class(cond), 'types.Nil') || ... - (islogical(cond) && cond == false) - if length(ast) > 3 - ret = EVAL(ast.get(4), env); - else - ret = type_utils.nil; - end - else - ret = EVAL(ast.get(3), env); - end - case 'fn*' - ret = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... - types.List(varargin{:}))); - otherwise - el = eval_ast(ast, env); - f = el.get(1); - args = el.data(2:end); - ret = f(args{:}); - end -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - repl_env = Env(); - - % core.m: defined using matlab - ns = core.ns(); ks = ns.keys(); - for i=1:length(ks) - k = ks{i}; - repl_env.set(types.Symbol(k), ns(k)); - end - - % core.mal: defined using the langauge itself - rep('(def! not (fn* (a) (if a false true)))', repl_env); - - %cleanObj = onCleanup(@() disp('*** here1 ***')); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, repl_env)); - catch err - fprintf('Error: %s\n', err.message); - type_utils.print_stack(err); - end - end -end +function step4_if_fn_do(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = eval_ast(ast, env) + switch class(ast) + case 'types.Symbol' + ret = env.get(ast); + case 'types.List' + ret = types.List(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.Vector' + ret = types.Vector(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.HashMap' + ret = types.HashMap(); + ks = ast.keys(); + for i=1:length(ks) + k = ks{i}; + ret.set(k, EVAL(ast.get(k), env)); + end + otherwise + ret = ast; + end +end + +function ret = EVAL(ast, env) + %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + % apply + if length(ast) == 0 + ret = ast; + return; + end + if isa(ast.get(1),'types.Symbol') + a1sym = ast.get(1).name; + else + a1sym = '_@$fn$@_'; + end + switch (a1sym) + case 'def!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + case 'let*' + let_env = Env({env}); + for i=1:2:length(ast.get(2)) + let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); + end + ret = EVAL(ast.get(3), let_env); + case 'do' + el = eval_ast(ast.slice(2), env); + ret = el.get(length(el)); + case 'if' + cond = EVAL(ast.get(2), env); + if strcmp(class(cond), 'types.Nil') || ... + (islogical(cond) && cond == false) + if length(ast) > 3 + ret = EVAL(ast.get(4), env); + else + ret = type_utils.nil; + end + else + ret = EVAL(ast.get(3), env); + end + case 'fn*' + ret = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... + types.List(varargin{:}))); + otherwise + el = eval_ast(ast, env); + f = el.get(1); + args = el.data(2:end); + ret = f(args{:}); + end +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + repl_env = Env(); + + % core.m: defined using matlab + ns = core.ns(); ks = ns.keys(); + for i=1:length(ks) + k = ks{i}; + repl_env.set(types.Symbol(k), ns(k)); + end + + % core.mal: defined using the langauge itself + rep('(def! not (fn* (a) (if a false true)))', repl_env); + + %cleanObj = onCleanup(@() disp('*** here1 ***')); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, repl_env)); + catch err + fprintf('Error: %s\n', err.message); + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/step5_tco.m b/impls/matlab/step5_tco.m index bd0c5a1244..436ea9b391 100644 --- a/impls/matlab/step5_tco.m +++ b/impls/matlab/step5_tco.m @@ -1,138 +1,138 @@ -function step5_tco(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = eval_ast(ast, env) - switch class(ast) - case 'types.Symbol' - ret = env.get(ast); - case 'types.List' - ret = types.List(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.Vector' - ret = types.Vector(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.HashMap' - ret = types.HashMap(); - ks = ast.keys(); - for i=1:length(ks) - k = ks{i}; - ret.set(k, EVAL(ast.get(k), env)); - end - otherwise - ret = ast; - end -end - -function ret = EVAL(ast, env) - while true - %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - % apply - if length(ast) == 0 - ret = ast; - return; - end - if isa(ast.get(1),'types.Symbol') - a1sym = ast.get(1).name; - else - a1sym = '_@$fn$@_'; - end - switch (a1sym) - case 'def!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - return; - case 'let*' - let_env = Env({env}); - for i=1:2:length(ast.get(2)) - let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); - end - env = let_env; - ast = ast.get(3); % TCO - case 'do' - el = eval_ast(ast.slice(2,length(ast)-1), env); - ast = ast.get(length(ast)); % TCO - case 'if' - cond = EVAL(ast.get(2), env); - if strcmp(class(cond), 'types.Nil') || ... - (islogical(cond) && cond == false) - if length(ast) > 3 - ast = ast.get(4); % TCO - else - ret = type_utils.nil; - return; - end - else - ast = ast.get(3); % TCO - end - case 'fn*' - fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... - types.List(varargin{:}))); - ret = types.Function(fn, ast.get(3), env, ast.get(2)); - return; - otherwise - el = eval_ast(ast, env); - f = el.get(1); - args = el.slice(2); - if isa(f, 'types.Function') - env = Env({f.env}, f.params, args); - ast = f.ast; % TCO - else - ret = f(args.data{:}); - return - end - end - end -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - repl_env = Env(); - - % core.m: defined using matlab - ns = core.ns(); ks = ns.keys(); - for i=1:length(ks) - k = ks{i}; - repl_env.set(types.Symbol(k), ns(k)); - end - - % core.mal: defined using the langauge itself - rep('(def! not (fn* (a) (if a false true)))', repl_env); - - %cleanObj = onCleanup(@() disp('*** here1 ***')); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, repl_env)); - catch err - fprintf('Error: %s\n', err.message); - type_utils.print_stack(err); - end - end -end +function step5_tco(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = eval_ast(ast, env) + switch class(ast) + case 'types.Symbol' + ret = env.get(ast); + case 'types.List' + ret = types.List(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.Vector' + ret = types.Vector(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.HashMap' + ret = types.HashMap(); + ks = ast.keys(); + for i=1:length(ks) + k = ks{i}; + ret.set(k, EVAL(ast.get(k), env)); + end + otherwise + ret = ast; + end +end + +function ret = EVAL(ast, env) + while true + %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + % apply + if length(ast) == 0 + ret = ast; + return; + end + if isa(ast.get(1),'types.Symbol') + a1sym = ast.get(1).name; + else + a1sym = '_@$fn$@_'; + end + switch (a1sym) + case 'def!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + return; + case 'let*' + let_env = Env({env}); + for i=1:2:length(ast.get(2)) + let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); + end + env = let_env; + ast = ast.get(3); % TCO + case 'do' + el = eval_ast(ast.slice(2,length(ast)-1), env); + ast = ast.get(length(ast)); % TCO + case 'if' + cond = EVAL(ast.get(2), env); + if strcmp(class(cond), 'types.Nil') || ... + (islogical(cond) && cond == false) + if length(ast) > 3 + ast = ast.get(4); % TCO + else + ret = type_utils.nil; + return; + end + else + ast = ast.get(3); % TCO + end + case 'fn*' + fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... + types.List(varargin{:}))); + ret = types.Function(fn, ast.get(3), env, ast.get(2)); + return; + otherwise + el = eval_ast(ast, env); + f = el.get(1); + args = el.slice(2); + if isa(f, 'types.Function') + env = Env({f.env}, f.params, args); + ast = f.ast; % TCO + else + ret = f(args.data{:}); + return + end + end + end +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + repl_env = Env(); + + % core.m: defined using matlab + ns = core.ns(); ks = ns.keys(); + for i=1:length(ks) + k = ks{i}; + repl_env.set(types.Symbol(k), ns(k)); + end + + % core.mal: defined using the langauge itself + rep('(def! not (fn* (a) (if a false true)))', repl_env); + + %cleanObj = onCleanup(@() disp('*** here1 ***')); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, repl_env)); + catch err + fprintf('Error: %s\n', err.message); + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/step6_file.m b/impls/matlab/step6_file.m index 3488a25e9c..c446929c8c 100644 --- a/impls/matlab/step6_file.m +++ b/impls/matlab/step6_file.m @@ -1,147 +1,147 @@ -function step6_file(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = eval_ast(ast, env) - switch class(ast) - case 'types.Symbol' - ret = env.get(ast); - case 'types.List' - ret = types.List(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.Vector' - ret = types.Vector(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.HashMap' - ret = types.HashMap(); - ks = ast.keys(); - for i=1:length(ks) - k = ks{i}; - ret.set(k, EVAL(ast.get(k), env)); - end - otherwise - ret = ast; - end -end - -function ret = EVAL(ast, env) - while true - %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - % apply - if length(ast) == 0 - ret = ast; - return; - end - if isa(ast.get(1),'types.Symbol') - a1sym = ast.get(1).name; - else - a1sym = '_@$fn$@_'; - end - switch (a1sym) - case 'def!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - return; - case 'let*' - let_env = Env({env}); - for i=1:2:length(ast.get(2)) - let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); - end - env = let_env; - ast = ast.get(3); % TCO - case 'do' - el = eval_ast(ast.slice(2,length(ast)-1), env); - ast = ast.get(length(ast)); % TCO - case 'if' - cond = EVAL(ast.get(2), env); - if strcmp(class(cond), 'types.Nil') || ... - (islogical(cond) && cond == false) - if length(ast) > 3 - ast = ast.get(4); % TCO - else - ret = type_utils.nil; - return; - end - else - ast = ast.get(3); % TCO - end - case 'fn*' - fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... - types.List(varargin{:}))); - ret = types.Function(fn, ast.get(3), env, ast.get(2)); - return; - otherwise - el = eval_ast(ast, env); - f = el.get(1); - args = el.slice(2); - if isa(f, 'types.Function') - env = Env({f.env}, f.params, args); - ast = f.ast; % TCO - else - ret = f(args.data{:}); - return - end - end - end -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - repl_env = Env(); - - % core.m: defined using matlab - ns = core.ns(); ks = ns.keys(); - for i=1:length(ks) - k = ks{i}; - repl_env.set(types.Symbol(k), ns(k)); - end - repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); - rest_args = args(2:end); - repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); - - % core.mal: defined using the langauge itself - rep('(def! not (fn* (a) (if a false true)))', repl_env); - rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); - - if ~isempty(args) - rep(sprintf('(load-file "%s")', args{1}), repl_env); - quit; - end - - %cleanObj = onCleanup(@() disp('*** here1 ***')); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, repl_env)); - catch err - fprintf('Error: %s\n', err.message); - type_utils.print_stack(err); - end - end -end +function step6_file(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = eval_ast(ast, env) + switch class(ast) + case 'types.Symbol' + ret = env.get(ast); + case 'types.List' + ret = types.List(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.Vector' + ret = types.Vector(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.HashMap' + ret = types.HashMap(); + ks = ast.keys(); + for i=1:length(ks) + k = ks{i}; + ret.set(k, EVAL(ast.get(k), env)); + end + otherwise + ret = ast; + end +end + +function ret = EVAL(ast, env) + while true + %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + % apply + if length(ast) == 0 + ret = ast; + return; + end + if isa(ast.get(1),'types.Symbol') + a1sym = ast.get(1).name; + else + a1sym = '_@$fn$@_'; + end + switch (a1sym) + case 'def!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + return; + case 'let*' + let_env = Env({env}); + for i=1:2:length(ast.get(2)) + let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); + end + env = let_env; + ast = ast.get(3); % TCO + case 'do' + el = eval_ast(ast.slice(2,length(ast)-1), env); + ast = ast.get(length(ast)); % TCO + case 'if' + cond = EVAL(ast.get(2), env); + if strcmp(class(cond), 'types.Nil') || ... + (islogical(cond) && cond == false) + if length(ast) > 3 + ast = ast.get(4); % TCO + else + ret = type_utils.nil; + return; + end + else + ast = ast.get(3); % TCO + end + case 'fn*' + fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... + types.List(varargin{:}))); + ret = types.Function(fn, ast.get(3), env, ast.get(2)); + return; + otherwise + el = eval_ast(ast, env); + f = el.get(1); + args = el.slice(2); + if isa(f, 'types.Function') + env = Env({f.env}, f.params, args); + ast = f.ast; % TCO + else + ret = f(args.data{:}); + return + end + end + end +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + repl_env = Env(); + + % core.m: defined using matlab + ns = core.ns(); ks = ns.keys(); + for i=1:length(ks) + k = ks{i}; + repl_env.set(types.Symbol(k), ns(k)); + end + repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); + rest_args = args(2:end); + repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); + + % core.mal: defined using the langauge itself + rep('(def! not (fn* (a) (if a false true)))', repl_env); + rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); + + if ~isempty(args) + rep(sprintf('(load-file "%s")', args{1}), repl_env); + quit; + end + + %cleanObj = onCleanup(@() disp('*** here1 ***')); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, repl_env)); + catch err + fprintf('Error: %s\n', err.message); + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/step7_quote.m b/impls/matlab/step7_quote.m index 311d283a65..f042d598fe 100644 --- a/impls/matlab/step7_quote.m +++ b/impls/matlab/step7_quote.m @@ -1,192 +1,192 @@ -function step7_quote(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = starts_with(ast, sym) - ret = length(ast); - if ret - first = ast.get(1); - ret = isa(first,'types.Symbol') && strcmp(first.name, sym); - end -end - -function ret = quasiquote_loop(ast) - ret = types.List(); - for i=length(ast):-1:1 - elt = ast.get(i) - if isa(elt, 'types.List') && starts_with(elt, 'splice-unquote') - ret = types.List(types.Symbol('concat'), elt.get(2), ret); - else - ret = types.List(types.Symbol('cons'), quasiquote(elt), ret); - end - end -end - -function ret = quasiquote(ast) - switch class(ast) - case 'types.List' - if starts_with(ast, 'unquote') - ret = ast.get(2); - else - ret = quasiquote_loop(ast); - end - case 'types.Vector' - ret = types.List(types.Symbol('vec'), quasiquote_loop(ast)); - case {'types.Symbol', 'types.HashMap'} - ret = types.List(types.Symbol('quote'), ast); - otherwise - ret = ast; - end -end - -function ret = eval_ast(ast, env) - switch class(ast) - case 'types.Symbol' - ret = env.get(ast); - case 'types.List' - ret = types.List(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.Vector' - ret = types.Vector(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.HashMap' - ret = types.HashMap(); - ks = ast.keys(); - for i=1:length(ks) - k = ks{i}; - ret.set(k, EVAL(ast.get(k), env)); - end - otherwise - ret = ast; - end -end - -function ret = EVAL(ast, env) - while true - %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - % apply - if length(ast) == 0 - ret = ast; - return; - end - if isa(ast.get(1),'types.Symbol') - a1sym = ast.get(1).name; - else - a1sym = '_@$fn$@_'; - end - switch (a1sym) - case 'def!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - return; - case 'let*' - let_env = Env({env}); - for i=1:2:length(ast.get(2)) - let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); - end - env = let_env; - ast = ast.get(3); % TCO - case 'quote' - ret = ast.get(2); - return; - case 'quasiquoteexpand' - ret = quasiquote(ast.get(2)); - return; - case 'quasiquote' - ast = quasiquote(ast.get(2)); % TCO - case 'do' - el = eval_ast(ast.slice(2,length(ast)-1), env); - ast = ast.get(length(ast)); % TCO - case 'if' - cond = EVAL(ast.get(2), env); - if strcmp(class(cond), 'types.Nil') || ... - (islogical(cond) && cond == false) - if length(ast) > 3 - ast = ast.get(4); % TCO - else - ret = type_utils.nil; - return; - end - else - ast = ast.get(3); % TCO - end - case 'fn*' - fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... - types.List(varargin{:}))); - ret = types.Function(fn, ast.get(3), env, ast.get(2)); - return; - otherwise - el = eval_ast(ast, env); - f = el.get(1); - args = el.slice(2); - if isa(f, 'types.Function') - env = Env({f.env}, f.params, args); - ast = f.ast; % TCO - else - ret = f(args.data{:}); - return - end - end - end -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - repl_env = Env(); - - % core.m: defined using matlab - ns = core.ns(); ks = ns.keys(); - for i=1:length(ks) - k = ks{i}; - repl_env.set(types.Symbol(k), ns(k)); - end - repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); - rest_args = args(2:end); - repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); - - % core.mal: defined using the langauge itself - rep('(def! not (fn* (a) (if a false true)))', repl_env); - rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); - - if ~isempty(args) - rep(sprintf('(load-file "%s")', args{1}), repl_env); - quit; - end - - %cleanObj = onCleanup(@() disp('*** here1 ***')); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, repl_env)); - catch err - fprintf('Error: %s\n', err.message); - type_utils.print_stack(err); - end - end -end +function step7_quote(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = starts_with(ast, sym) + ret = length(ast); + if ret + first = ast.get(1); + ret = isa(first,'types.Symbol') && strcmp(first.name, sym); + end +end + +function ret = quasiquote_loop(ast) + ret = types.List(); + for i=length(ast):-1:1 + elt = ast.get(i) + if isa(elt, 'types.List') && starts_with(elt, 'splice-unquote') + ret = types.List(types.Symbol('concat'), elt.get(2), ret); + else + ret = types.List(types.Symbol('cons'), quasiquote(elt), ret); + end + end +end + +function ret = quasiquote(ast) + switch class(ast) + case 'types.List' + if starts_with(ast, 'unquote') + ret = ast.get(2); + else + ret = quasiquote_loop(ast); + end + case 'types.Vector' + ret = types.List(types.Symbol('vec'), quasiquote_loop(ast)); + case {'types.Symbol', 'types.HashMap'} + ret = types.List(types.Symbol('quote'), ast); + otherwise + ret = ast; + end +end + +function ret = eval_ast(ast, env) + switch class(ast) + case 'types.Symbol' + ret = env.get(ast); + case 'types.List' + ret = types.List(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.Vector' + ret = types.Vector(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.HashMap' + ret = types.HashMap(); + ks = ast.keys(); + for i=1:length(ks) + k = ks{i}; + ret.set(k, EVAL(ast.get(k), env)); + end + otherwise + ret = ast; + end +end + +function ret = EVAL(ast, env) + while true + %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + % apply + if length(ast) == 0 + ret = ast; + return; + end + if isa(ast.get(1),'types.Symbol') + a1sym = ast.get(1).name; + else + a1sym = '_@$fn$@_'; + end + switch (a1sym) + case 'def!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + return; + case 'let*' + let_env = Env({env}); + for i=1:2:length(ast.get(2)) + let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); + end + env = let_env; + ast = ast.get(3); % TCO + case 'quote' + ret = ast.get(2); + return; + case 'quasiquoteexpand' + ret = quasiquote(ast.get(2)); + return; + case 'quasiquote' + ast = quasiquote(ast.get(2)); % TCO + case 'do' + el = eval_ast(ast.slice(2,length(ast)-1), env); + ast = ast.get(length(ast)); % TCO + case 'if' + cond = EVAL(ast.get(2), env); + if strcmp(class(cond), 'types.Nil') || ... + (islogical(cond) && cond == false) + if length(ast) > 3 + ast = ast.get(4); % TCO + else + ret = type_utils.nil; + return; + end + else + ast = ast.get(3); % TCO + end + case 'fn*' + fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... + types.List(varargin{:}))); + ret = types.Function(fn, ast.get(3), env, ast.get(2)); + return; + otherwise + el = eval_ast(ast, env); + f = el.get(1); + args = el.slice(2); + if isa(f, 'types.Function') + env = Env({f.env}, f.params, args); + ast = f.ast; % TCO + else + ret = f(args.data{:}); + return + end + end + end +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + repl_env = Env(); + + % core.m: defined using matlab + ns = core.ns(); ks = ns.keys(); + for i=1:length(ks) + k = ks{i}; + repl_env.set(types.Symbol(k), ns(k)); + end + repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); + rest_args = args(2:end); + repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); + + % core.mal: defined using the langauge itself + rep('(def! not (fn* (a) (if a false true)))', repl_env); + rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); + + if ~isempty(args) + rep(sprintf('(load-file "%s")', args{1}), repl_env); + quit; + end + + %cleanObj = onCleanup(@() disp('*** here1 ***')); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, repl_env)); + catch err + fprintf('Error: %s\n', err.message); + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/step8_macros.m b/impls/matlab/step8_macros.m index 5620639c0c..6a82bcfe19 100644 --- a/impls/matlab/step8_macros.m +++ b/impls/matlab/step8_macros.m @@ -1,225 +1,225 @@ -function step8_macros(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = starts_with(ast, sym) - ret = length(ast); - if ret - first = ast.get(1); - ret = isa(first,'types.Symbol') && strcmp(first.name, sym); - end -end - -function ret = quasiquote_loop(ast) - ret = types.List(); - for i=length(ast):-1:1 - elt = ast.get(i) - if isa(elt, 'types.List') && starts_with(elt, 'splice-unquote') - ret = types.List(types.Symbol('concat'), elt.get(2), ret); - else - ret = types.List(types.Symbol('cons'), quasiquote(elt), ret); - end - end -end - -function ret = quasiquote(ast) - switch class(ast) - case 'types.List' - if starts_with(ast, 'unquote') - ret = ast.get(2); - else - ret = quasiquote_loop(ast); - end - case 'types.Vector' - ret = types.List(types.Symbol('vec'), quasiquote_loop(ast)); - case {'types.Symbol', 'types.HashMap'} - ret = types.List(types.Symbol('quote'), ast); - otherwise - ret = ast; - end -end - -function ret = is_macro_call(ast, env) - if type_utils.list_Q(ast) && isa(ast.get(1), 'types.Symbol') && ... - ~islogical(env.find(ast.get(1))) - f = env.get(ast.get(1)); - ret = isa(f,'types.Function') && f.is_macro; - else - ret = false; - end -end - -function ret = macroexpand(ast, env) - while is_macro_call(ast, env) - mac = env.get(ast.get(1)); - args = ast.slice(2); - ast = mac.fn(args.data{:}); - end - ret = ast; -end - -function ret = eval_ast(ast, env) - switch class(ast) - case 'types.Symbol' - ret = env.get(ast); - case 'types.List' - ret = types.List(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.Vector' - ret = types.Vector(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.HashMap' - ret = types.HashMap(); - ks = ast.keys(); - for i=1:length(ks) - k = ks{i}; - ret.set(k, EVAL(ast.get(k), env)); - end - otherwise - ret = ast; - end -end - -function ret = EVAL(ast, env) - while true - %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - % apply - if length(ast) == 0 - ret = ast; - return; - end - ast = macroexpand(ast, env); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - if isa(ast.get(1),'types.Symbol') - a1sym = ast.get(1).name; - else - a1sym = '_@$fn$@_'; - end - switch (a1sym) - case 'def!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - return; - case 'let*' - let_env = Env({env}); - for i=1:2:length(ast.get(2)) - let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); - end - env = let_env; - ast = ast.get(3); % TCO - case 'quote' - ret = ast.get(2); - return; - case 'quasiquoteexpand' - ret = quasiquote(ast.get(2)); - return; - case 'quasiquote' - ast = quasiquote(ast.get(2)); % TCO - case 'defmacro!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - ret.is_macro = true; - return; - case 'macroexpand' - ret = macroexpand(ast.get(2), env); - return; - case 'do' - el = eval_ast(ast.slice(2,length(ast)-1), env); - ast = ast.get(length(ast)); % TCO - case 'if' - cond = EVAL(ast.get(2), env); - if strcmp(class(cond), 'types.Nil') || ... - (islogical(cond) && cond == false) - if length(ast) > 3 - ast = ast.get(4); % TCO - else - ret = type_utils.nil; - return; - end - else - ast = ast.get(3); % TCO - end - case 'fn*' - fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... - types.List(varargin{:}))); - ret = types.Function(fn, ast.get(3), env, ast.get(2)); - return; - otherwise - el = eval_ast(ast, env); - f = el.get(1); - args = el.slice(2); - if isa(f, 'types.Function') - env = Env({f.env}, f.params, args); - ast = f.ast; % TCO - else - ret = f(args.data{:}); - return - end - end - end -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - repl_env = Env(); - - % core.m: defined using matlab - ns = core.ns(); ks = ns.keys(); - for i=1:length(ks) - k = ks{i}; - repl_env.set(types.Symbol(k), ns(k)); - end - repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); - rest_args = args(2:end); - repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); - - % core.mal: defined using the langauge itself - rep('(def! not (fn* (a) (if a false true)))', repl_env); - rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); - 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)))))))', repl_env); - - if ~isempty(args) - rep(sprintf('(load-file "%s")', args{1}), repl_env); - quit; - end - - %cleanObj = onCleanup(@() disp('*** here1 ***')); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, repl_env)); - catch err - fprintf('Error: %s\n', err.message); - type_utils.print_stack(err); - end - end -end +function step8_macros(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = starts_with(ast, sym) + ret = length(ast); + if ret + first = ast.get(1); + ret = isa(first,'types.Symbol') && strcmp(first.name, sym); + end +end + +function ret = quasiquote_loop(ast) + ret = types.List(); + for i=length(ast):-1:1 + elt = ast.get(i) + if isa(elt, 'types.List') && starts_with(elt, 'splice-unquote') + ret = types.List(types.Symbol('concat'), elt.get(2), ret); + else + ret = types.List(types.Symbol('cons'), quasiquote(elt), ret); + end + end +end + +function ret = quasiquote(ast) + switch class(ast) + case 'types.List' + if starts_with(ast, 'unquote') + ret = ast.get(2); + else + ret = quasiquote_loop(ast); + end + case 'types.Vector' + ret = types.List(types.Symbol('vec'), quasiquote_loop(ast)); + case {'types.Symbol', 'types.HashMap'} + ret = types.List(types.Symbol('quote'), ast); + otherwise + ret = ast; + end +end + +function ret = is_macro_call(ast, env) + if type_utils.list_Q(ast) && isa(ast.get(1), 'types.Symbol') && ... + ~islogical(env.find(ast.get(1))) + f = env.get(ast.get(1)); + ret = isa(f,'types.Function') && f.is_macro; + else + ret = false; + end +end + +function ret = macroexpand(ast, env) + while is_macro_call(ast, env) + mac = env.get(ast.get(1)); + args = ast.slice(2); + ast = mac.fn(args.data{:}); + end + ret = ast; +end + +function ret = eval_ast(ast, env) + switch class(ast) + case 'types.Symbol' + ret = env.get(ast); + case 'types.List' + ret = types.List(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.Vector' + ret = types.Vector(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.HashMap' + ret = types.HashMap(); + ks = ast.keys(); + for i=1:length(ks) + k = ks{i}; + ret.set(k, EVAL(ast.get(k), env)); + end + otherwise + ret = ast; + end +end + +function ret = EVAL(ast, env) + while true + %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + % apply + if length(ast) == 0 + ret = ast; + return; + end + ast = macroexpand(ast, env); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + if isa(ast.get(1),'types.Symbol') + a1sym = ast.get(1).name; + else + a1sym = '_@$fn$@_'; + end + switch (a1sym) + case 'def!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + return; + case 'let*' + let_env = Env({env}); + for i=1:2:length(ast.get(2)) + let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); + end + env = let_env; + ast = ast.get(3); % TCO + case 'quote' + ret = ast.get(2); + return; + case 'quasiquoteexpand' + ret = quasiquote(ast.get(2)); + return; + case 'quasiquote' + ast = quasiquote(ast.get(2)); % TCO + case 'defmacro!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + ret.is_macro = true; + return; + case 'macroexpand' + ret = macroexpand(ast.get(2), env); + return; + case 'do' + el = eval_ast(ast.slice(2,length(ast)-1), env); + ast = ast.get(length(ast)); % TCO + case 'if' + cond = EVAL(ast.get(2), env); + if strcmp(class(cond), 'types.Nil') || ... + (islogical(cond) && cond == false) + if length(ast) > 3 + ast = ast.get(4); % TCO + else + ret = type_utils.nil; + return; + end + else + ast = ast.get(3); % TCO + end + case 'fn*' + fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... + types.List(varargin{:}))); + ret = types.Function(fn, ast.get(3), env, ast.get(2)); + return; + otherwise + el = eval_ast(ast, env); + f = el.get(1); + args = el.slice(2); + if isa(f, 'types.Function') + env = Env({f.env}, f.params, args); + ast = f.ast; % TCO + else + ret = f(args.data{:}); + return + end + end + end +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + repl_env = Env(); + + % core.m: defined using matlab + ns = core.ns(); ks = ns.keys(); + for i=1:length(ks) + k = ks{i}; + repl_env.set(types.Symbol(k), ns(k)); + end + repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); + rest_args = args(2:end); + repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); + + % core.mal: defined using the langauge itself + rep('(def! not (fn* (a) (if a false true)))', repl_env); + rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); + 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)))))))', repl_env); + + if ~isempty(args) + rep(sprintf('(load-file "%s")', args{1}), repl_env); + quit; + end + + %cleanObj = onCleanup(@() disp('*** here1 ***')); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, repl_env)); + catch err + fprintf('Error: %s\n', err.message); + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/step9_try.m b/impls/matlab/step9_try.m index c95536cc68..3e0f55c6f6 100644 --- a/impls/matlab/step9_try.m +++ b/impls/matlab/step9_try.m @@ -1,258 +1,258 @@ -function step9_try(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = starts_with(ast, sym) - ret = length(ast); - if ret - first = ast.get(1); - ret = isa(first,'types.Symbol') && strcmp(first.name, sym); - end -end - -function ret = quasiquote_loop(ast) - ret = types.List(); - for i=length(ast):-1:1 - elt = ast.get(i) - if isa(elt, 'types.List') && starts_with(elt, 'splice-unquote') - ret = types.List(types.Symbol('concat'), elt.get(2), ret); - else - ret = types.List(types.Symbol('cons'), quasiquote(elt), ret); - end - end -end - -function ret = quasiquote(ast) - switch class(ast) - case 'types.List' - if starts_with(ast, 'unquote') - ret = ast.get(2); - else - ret = quasiquote_loop(ast); - end - case 'types.Vector' - ret = types.List(types.Symbol('vec'), quasiquote_loop(ast)); - case {'types.Symbol', 'types.HashMap'} - ret = types.List(types.Symbol('quote'), ast); - otherwise - ret = ast; - end -end - -function ret = is_macro_call(ast, env) - if type_utils.list_Q(ast) && isa(ast.get(1), 'types.Symbol') && ... - ~islogical(env.find(ast.get(1))) - f = env.get(ast.get(1)); - ret = isa(f,'types.Function') && f.is_macro; - else - ret = false; - end -end - -function ret = macroexpand(ast, env) - while is_macro_call(ast, env) - mac = env.get(ast.get(1)); - args = ast.slice(2); - ast = mac.fn(args.data{:}); - end - ret = ast; -end - -function ret = eval_ast(ast, env) - switch class(ast) - case 'types.Symbol' - ret = env.get(ast); - case 'types.List' - ret = types.List(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.Vector' - ret = types.Vector(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.HashMap' - ret = types.HashMap(); - ks = ast.keys(); - for i=1:length(ks) - k = ks{i}; - ret.set(k, EVAL(ast.get(k), env)); - end - otherwise - ret = ast; - end -end - -function ret = EVAL(ast, env) - while true - %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - % apply - if length(ast) == 0 - ret = ast; - return; - end - ast = macroexpand(ast, env); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - if isa(ast.get(1),'types.Symbol') - a1sym = ast.get(1).name; - else - a1sym = '_@$fn$@_'; - end - switch (a1sym) - case 'def!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - return; - case 'let*' - let_env = Env({env}); - for i=1:2:length(ast.get(2)) - let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); - end - env = let_env; - ast = ast.get(3); % TCO - case 'quote' - ret = ast.get(2); - return; - case 'quasiquoteexpand' - ret = quasiquote(ast.get(2)); - return; - case 'quasiquote' - ast = quasiquote(ast.get(2)); % TCO - case 'defmacro!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - ret.is_macro = true; - return; - case 'macroexpand' - ret = macroexpand(ast.get(2), env); - return; - case 'try*' - try - ret = EVAL(ast.get(2), env); - return; - catch e - if length(ast) > 2 && strcmp(ast.get(3).get(1).name, 'catch*') - if strcmp(e.identifier, 'MalException:object') - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - global error_object; - exc = error_object; - else - exc = e.obj; - end - else - exc = e.message; - end - catch_env = Env({env}, types.List(ast.get(3).get(2)), ... - types.List(exc)); - ret = EVAL(ast.get(3).get(3), catch_env); - return; - else - rethrow(e); - end - end - case 'do' - el = eval_ast(ast.slice(2,length(ast)-1), env); - ast = ast.get(length(ast)); % TCO - case 'if' - cond = EVAL(ast.get(2), env); - if strcmp(class(cond), 'types.Nil') || ... - (islogical(cond) && cond == false) - if length(ast) > 3 - ast = ast.get(4); % TCO - else - ret = type_utils.nil; - return; - end - else - ast = ast.get(3); % TCO - end - case 'fn*' - fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... - types.List(varargin{:}))); - ret = types.Function(fn, ast.get(3), env, ast.get(2)); - return; - otherwise - el = eval_ast(ast, env); - f = el.get(1); - args = el.slice(2); - if isa(f, 'types.Function') - env = Env({f.env}, f.params, args); - ast = f.ast; % TCO - else - ret = f(args.data{:}); - return - end - end - end -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - repl_env = Env(); - - % core.m: defined using matlab - ns = core.ns(); ks = ns.keys(); - for i=1:length(ks) - k = ks{i}; - repl_env.set(types.Symbol(k), ns(k)); - end - repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); - rest_args = args(2:end); - repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); - - % core.mal: defined using the langauge itself - rep('(def! not (fn* (a) (if a false true)))', repl_env); - rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); - 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)))))))', repl_env); - - if ~isempty(args) - rep(sprintf('(load-file "%s")', args{1}), repl_env); - quit; - end - - %cleanObj = onCleanup(@() disp('*** here1 ***')); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, repl_env)); - catch err - if strcmp('MalException:object', err.identifier) - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - global error_object; - fprintf('Error: %s\n', printer.pr_str(error_object, true)); - else - fprintf('Error: %s\n', printer.pr_str(err.obj, true)); - end - else - fprintf('Error: %s\n', err.message); - end - type_utils.print_stack(err); - end - end -end +function step9_try(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = starts_with(ast, sym) + ret = length(ast); + if ret + first = ast.get(1); + ret = isa(first,'types.Symbol') && strcmp(first.name, sym); + end +end + +function ret = quasiquote_loop(ast) + ret = types.List(); + for i=length(ast):-1:1 + elt = ast.get(i) + if isa(elt, 'types.List') && starts_with(elt, 'splice-unquote') + ret = types.List(types.Symbol('concat'), elt.get(2), ret); + else + ret = types.List(types.Symbol('cons'), quasiquote(elt), ret); + end + end +end + +function ret = quasiquote(ast) + switch class(ast) + case 'types.List' + if starts_with(ast, 'unquote') + ret = ast.get(2); + else + ret = quasiquote_loop(ast); + end + case 'types.Vector' + ret = types.List(types.Symbol('vec'), quasiquote_loop(ast)); + case {'types.Symbol', 'types.HashMap'} + ret = types.List(types.Symbol('quote'), ast); + otherwise + ret = ast; + end +end + +function ret = is_macro_call(ast, env) + if type_utils.list_Q(ast) && isa(ast.get(1), 'types.Symbol') && ... + ~islogical(env.find(ast.get(1))) + f = env.get(ast.get(1)); + ret = isa(f,'types.Function') && f.is_macro; + else + ret = false; + end +end + +function ret = macroexpand(ast, env) + while is_macro_call(ast, env) + mac = env.get(ast.get(1)); + args = ast.slice(2); + ast = mac.fn(args.data{:}); + end + ret = ast; +end + +function ret = eval_ast(ast, env) + switch class(ast) + case 'types.Symbol' + ret = env.get(ast); + case 'types.List' + ret = types.List(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.Vector' + ret = types.Vector(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.HashMap' + ret = types.HashMap(); + ks = ast.keys(); + for i=1:length(ks) + k = ks{i}; + ret.set(k, EVAL(ast.get(k), env)); + end + otherwise + ret = ast; + end +end + +function ret = EVAL(ast, env) + while true + %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + % apply + if length(ast) == 0 + ret = ast; + return; + end + ast = macroexpand(ast, env); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + if isa(ast.get(1),'types.Symbol') + a1sym = ast.get(1).name; + else + a1sym = '_@$fn$@_'; + end + switch (a1sym) + case 'def!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + return; + case 'let*' + let_env = Env({env}); + for i=1:2:length(ast.get(2)) + let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); + end + env = let_env; + ast = ast.get(3); % TCO + case 'quote' + ret = ast.get(2); + return; + case 'quasiquoteexpand' + ret = quasiquote(ast.get(2)); + return; + case 'quasiquote' + ast = quasiquote(ast.get(2)); % TCO + case 'defmacro!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + ret.is_macro = true; + return; + case 'macroexpand' + ret = macroexpand(ast.get(2), env); + return; + case 'try*' + try + ret = EVAL(ast.get(2), env); + return; + catch e + if length(ast) > 2 && strcmp(ast.get(3).get(1).name, 'catch*') + if strcmp(e.identifier, 'MalException:object') + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + global error_object; + exc = error_object; + else + exc = e.obj; + end + else + exc = e.message; + end + catch_env = Env({env}, types.List(ast.get(3).get(2)), ... + types.List(exc)); + ret = EVAL(ast.get(3).get(3), catch_env); + return; + else + rethrow(e); + end + end + case 'do' + el = eval_ast(ast.slice(2,length(ast)-1), env); + ast = ast.get(length(ast)); % TCO + case 'if' + cond = EVAL(ast.get(2), env); + if strcmp(class(cond), 'types.Nil') || ... + (islogical(cond) && cond == false) + if length(ast) > 3 + ast = ast.get(4); % TCO + else + ret = type_utils.nil; + return; + end + else + ast = ast.get(3); % TCO + end + case 'fn*' + fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... + types.List(varargin{:}))); + ret = types.Function(fn, ast.get(3), env, ast.get(2)); + return; + otherwise + el = eval_ast(ast, env); + f = el.get(1); + args = el.slice(2); + if isa(f, 'types.Function') + env = Env({f.env}, f.params, args); + ast = f.ast; % TCO + else + ret = f(args.data{:}); + return + end + end + end +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + repl_env = Env(); + + % core.m: defined using matlab + ns = core.ns(); ks = ns.keys(); + for i=1:length(ks) + k = ks{i}; + repl_env.set(types.Symbol(k), ns(k)); + end + repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); + rest_args = args(2:end); + repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); + + % core.mal: defined using the langauge itself + rep('(def! not (fn* (a) (if a false true)))', repl_env); + rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); + 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)))))))', repl_env); + + if ~isempty(args) + rep(sprintf('(load-file "%s")', args{1}), repl_env); + quit; + end + + %cleanObj = onCleanup(@() disp('*** here1 ***')); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, repl_env)); + catch err + if strcmp('MalException:object', err.identifier) + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + global error_object; + fprintf('Error: %s\n', printer.pr_str(error_object, true)); + else + fprintf('Error: %s\n', printer.pr_str(err.obj, true)); + end + else + fprintf('Error: %s\n', err.message); + end + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/stepA_mal.m b/impls/matlab/stepA_mal.m index 5e68b09fc3..7ca0b10ebb 100644 --- a/impls/matlab/stepA_mal.m +++ b/impls/matlab/stepA_mal.m @@ -1,260 +1,260 @@ -function stepA_mal(varargin), main(varargin), end - -% read -function ret = READ(str) - ret = reader.read_str(str); -end - -% eval -function ret = starts_with(ast, sym) - ret = length(ast); - if ret - first = ast.get(1); - ret = isa(first,'types.Symbol') && strcmp(first.name, sym); - end -end - -function ret = quasiquote_loop(ast) - ret = types.List(); - for i=length(ast):-1:1 - elt = ast.get(i) - if isa(elt, 'types.List') && starts_with(elt, 'splice-unquote') - ret = types.List(types.Symbol('concat'), elt.get(2), ret); - else - ret = types.List(types.Symbol('cons'), quasiquote(elt), ret); - end - end -end - -function ret = quasiquote(ast) - switch class(ast) - case 'types.List' - if starts_with(ast, 'unquote') - ret = ast.get(2); - else - ret = quasiquote_loop(ast); - end - case 'types.Vector' - ret = types.List(types.Symbol('vec'), quasiquote_loop(ast)); - case {'types.Symbol', 'types.HashMap'} - ret = types.List(types.Symbol('quote'), ast); - otherwise - ret = ast; - end -end - -function ret = is_macro_call(ast, env) - if type_utils.list_Q(ast) && isa(ast.get(1), 'types.Symbol') && ... - ~islogical(env.find(ast.get(1))) - f = env.get(ast.get(1)); - ret = isa(f,'types.Function') && f.is_macro; - else - ret = false; - end -end - -function ret = macroexpand(ast, env) - while is_macro_call(ast, env) - mac = env.get(ast.get(1)); - args = ast.slice(2); - ast = mac.fn(args.data{:}); - end - ret = ast; -end - -function ret = eval_ast(ast, env) - switch class(ast) - case 'types.Symbol' - ret = env.get(ast); - case 'types.List' - ret = types.List(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.Vector' - ret = types.Vector(); - for i=1:length(ast) - ret.append(EVAL(ast.get(i), env)); - end - case 'types.HashMap' - ret = types.HashMap(); - ks = ast.keys(); - for i=1:length(ks) - k = ks{i}; - ret.set(k, EVAL(ast.get(k), env)); - end - otherwise - ret = ast; - end -end - -function ret = EVAL(ast, env) - while true - %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - % apply - if length(ast) == 0 - ret = ast; - return; - end - ast = macroexpand(ast, env); - if ~type_utils.list_Q(ast) - ret = eval_ast(ast, env); - return; - end - - if isa(ast.get(1),'types.Symbol') - a1sym = ast.get(1).name; - else - a1sym = '_@$fn$@_'; - end - switch (a1sym) - case 'def!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - return; - case 'let*' - let_env = Env({env}); - for i=1:2:length(ast.get(2)) - let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); - end - env = let_env; - ast = ast.get(3); % TCO - case 'quote' - ret = ast.get(2); - return; - case 'quasiquoteexpand' - ret = quasiquote(ast.get(2)); - return; - case 'quasiquote' - ast = quasiquote(ast.get(2)); % TCO - case 'defmacro!' - ret = env.set(ast.get(2), EVAL(ast.get(3), env)); - ret.is_macro = true; - return; - case 'macroexpand' - ret = macroexpand(ast.get(2), env); - return; - case 'try*' - try - ret = EVAL(ast.get(2), env); - return; - catch e - if length(ast) > 2 && strcmp(ast.get(3).get(1).name, 'catch*') - if strcmp(e.identifier, 'MalException:object') - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - global error_object; - exc = error_object; - else - exc = e.obj; - end - else - exc = e.message; - end - catch_env = Env({env}, types.List(ast.get(3).get(2)), ... - types.List(exc)); - ret = EVAL(ast.get(3).get(3), catch_env); - return; - else - rethrow(e); - end - end - case 'do' - el = eval_ast(ast.slice(2,length(ast)-1), env); - ast = ast.get(length(ast)); % TCO - case 'if' - cond = EVAL(ast.get(2), env); - if strcmp(class(cond), 'types.Nil') || ... - (islogical(cond) && cond == false) - if length(ast) > 3 - ast = ast.get(4); % TCO - else - ret = type_utils.nil; - return; - end - else - ast = ast.get(3); % TCO - end - case 'fn*' - fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... - types.List(varargin{:}))); - ret = types.Function(fn, ast.get(3), env, ast.get(2)); - return; - otherwise - el = eval_ast(ast, env); - f = el.get(1); - args = el.slice(2); - if isa(f, 'types.Function') - env = Env({f.env}, f.params, args); - ast = f.ast; % TCO - else - ret = f(args.data{:}); - return - end - end - end -end - -% print -function ret = PRINT(ast) - ret = printer.pr_str(ast, true); -end - -% REPL -function ret = rep(str, env) - ret = PRINT(EVAL(READ(str), env)); -end - -function main(args) - repl_env = Env(); - - % core.m: defined using matlab - ns = core.ns(); ks = ns.keys(); - for i=1:length(ks) - k = ks{i}; - repl_env.set(types.Symbol(k), ns(k)); - end - repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); - rest_args = args(2:end); - repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); - - % core.mal: defined using the langauge itself - rep('(def! *host-language* "matlab")', repl_env); - rep('(def! not (fn* (a) (if a false true)))', repl_env); - rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); - 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)))))))', repl_env); - - if ~isempty(args) - rep(sprintf('(load-file "%s")', args{1}), repl_env); - quit; - end - - %cleanObj = onCleanup(@() disp('*** here1 ***')); - rep('(println (str "Mal [" *host-language* "]"))', repl_env); - while (true) - try - line = input('user> ', 's'); - catch err - return - end - if strcmp(strtrim(line),''), continue, end - try - fprintf('%s\n', rep(line, repl_env)); - catch err - if strcmp('MalException:object', err.identifier) - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - global error_object; - fprintf('Error: %s\n', printer.pr_str(error_object, true)); - else - fprintf('Error: %s\n', printer.pr_str(err.obj, true)); - end - else - fprintf('Error: %s\n', err.message); - end - type_utils.print_stack(err); - end - end -end +function stepA_mal(varargin), main(varargin), end + +% read +function ret = READ(str) + ret = reader.read_str(str); +end + +% eval +function ret = starts_with(ast, sym) + ret = length(ast); + if ret + first = ast.get(1); + ret = isa(first,'types.Symbol') && strcmp(first.name, sym); + end +end + +function ret = quasiquote_loop(ast) + ret = types.List(); + for i=length(ast):-1:1 + elt = ast.get(i) + if isa(elt, 'types.List') && starts_with(elt, 'splice-unquote') + ret = types.List(types.Symbol('concat'), elt.get(2), ret); + else + ret = types.List(types.Symbol('cons'), quasiquote(elt), ret); + end + end +end + +function ret = quasiquote(ast) + switch class(ast) + case 'types.List' + if starts_with(ast, 'unquote') + ret = ast.get(2); + else + ret = quasiquote_loop(ast); + end + case 'types.Vector' + ret = types.List(types.Symbol('vec'), quasiquote_loop(ast)); + case {'types.Symbol', 'types.HashMap'} + ret = types.List(types.Symbol('quote'), ast); + otherwise + ret = ast; + end +end + +function ret = is_macro_call(ast, env) + if type_utils.list_Q(ast) && isa(ast.get(1), 'types.Symbol') && ... + ~islogical(env.find(ast.get(1))) + f = env.get(ast.get(1)); + ret = isa(f,'types.Function') && f.is_macro; + else + ret = false; + end +end + +function ret = macroexpand(ast, env) + while is_macro_call(ast, env) + mac = env.get(ast.get(1)); + args = ast.slice(2); + ast = mac.fn(args.data{:}); + end + ret = ast; +end + +function ret = eval_ast(ast, env) + switch class(ast) + case 'types.Symbol' + ret = env.get(ast); + case 'types.List' + ret = types.List(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.Vector' + ret = types.Vector(); + for i=1:length(ast) + ret.append(EVAL(ast.get(i), env)); + end + case 'types.HashMap' + ret = types.HashMap(); + ks = ast.keys(); + for i=1:length(ks) + k = ks{i}; + ret.set(k, EVAL(ast.get(k), env)); + end + otherwise + ret = ast; + end +end + +function ret = EVAL(ast, env) + while true + %fprintf('EVAL: %s\n', printer.pr_str(ast, true)); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + % apply + if length(ast) == 0 + ret = ast; + return; + end + ast = macroexpand(ast, env); + if ~type_utils.list_Q(ast) + ret = eval_ast(ast, env); + return; + end + + if isa(ast.get(1),'types.Symbol') + a1sym = ast.get(1).name; + else + a1sym = '_@$fn$@_'; + end + switch (a1sym) + case 'def!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + return; + case 'let*' + let_env = Env({env}); + for i=1:2:length(ast.get(2)) + let_env.set(ast.get(2).get(i), EVAL(ast.get(2).get(i+1), let_env)); + end + env = let_env; + ast = ast.get(3); % TCO + case 'quote' + ret = ast.get(2); + return; + case 'quasiquoteexpand' + ret = quasiquote(ast.get(2)); + return; + case 'quasiquote' + ast = quasiquote(ast.get(2)); % TCO + case 'defmacro!' + ret = env.set(ast.get(2), EVAL(ast.get(3), env)); + ret.is_macro = true; + return; + case 'macroexpand' + ret = macroexpand(ast.get(2), env); + return; + case 'try*' + try + ret = EVAL(ast.get(2), env); + return; + catch e + if length(ast) > 2 && strcmp(ast.get(3).get(1).name, 'catch*') + if strcmp(e.identifier, 'MalException:object') + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + global error_object; + exc = error_object; + else + exc = e.obj; + end + else + exc = e.message; + end + catch_env = Env({env}, types.List(ast.get(3).get(2)), ... + types.List(exc)); + ret = EVAL(ast.get(3).get(3), catch_env); + return; + else + rethrow(e); + end + end + case 'do' + el = eval_ast(ast.slice(2,length(ast)-1), env); + ast = ast.get(length(ast)); % TCO + case 'if' + cond = EVAL(ast.get(2), env); + if strcmp(class(cond), 'types.Nil') || ... + (islogical(cond) && cond == false) + if length(ast) > 3 + ast = ast.get(4); % TCO + else + ret = type_utils.nil; + return; + end + else + ast = ast.get(3); % TCO + end + case 'fn*' + fn = @(varargin) EVAL(ast.get(3), Env({env}, ast.get(2), ... + types.List(varargin{:}))); + ret = types.Function(fn, ast.get(3), env, ast.get(2)); + return; + otherwise + el = eval_ast(ast, env); + f = el.get(1); + args = el.slice(2); + if isa(f, 'types.Function') + env = Env({f.env}, f.params, args); + ast = f.ast; % TCO + else + ret = f(args.data{:}); + return + end + end + end +end + +% print +function ret = PRINT(ast) + ret = printer.pr_str(ast, true); +end + +% REPL +function ret = rep(str, env) + ret = PRINT(EVAL(READ(str), env)); +end + +function main(args) + repl_env = Env(); + + % core.m: defined using matlab + ns = core.ns(); ks = ns.keys(); + for i=1:length(ks) + k = ks{i}; + repl_env.set(types.Symbol(k), ns(k)); + end + repl_env.set(types.Symbol('eval'), @(a) EVAL(a, repl_env)); + rest_args = args(2:end); + repl_env.set(types.Symbol('*ARGV*'), types.List(rest_args{:})); + + % core.mal: defined using the langauge itself + rep('(def! *host-language* "matlab")', repl_env); + rep('(def! not (fn* (a) (if a false true)))', repl_env); + rep('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"', repl_env); + 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)))))))', repl_env); + + if ~isempty(args) + rep(sprintf('(load-file "%s")', args{1}), repl_env); + quit; + end + + %cleanObj = onCleanup(@() disp('*** here1 ***')); + rep('(println (str "Mal [" *host-language* "]"))', repl_env); + while (true) + try + line = input('user> ', 's'); + catch err + return + end + if strcmp(strtrim(line),''), continue, end + try + fprintf('%s\n', rep(line, repl_env)); + catch err + if strcmp('MalException:object', err.identifier) + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + global error_object; + fprintf('Error: %s\n', printer.pr_str(error_object, true)); + else + fprintf('Error: %s\n', printer.pr_str(err.obj, true)); + end + else + fprintf('Error: %s\n', err.message); + end + type_utils.print_stack(err); + end + end +end diff --git a/impls/matlab/type_utils.m b/impls/matlab/type_utils.m index 939df5260e..295ca7dd16 100644 --- a/impls/matlab/type_utils.m +++ b/impls/matlab/type_utils.m @@ -1,104 +1,104 @@ -classdef type_utils - properties (Constant = true) - nil = types.Nil(); - end - - methods(Static) - function ret = equal(a,b) - ret = false; - ota = class(a); otb = class(b); - if ~(strcmp(ota,otb) || ... - (type_utils.sequential_Q(a) && type_utils.sequential_Q(b))) - return; - end - switch (ota) - case {'types.List', 'types.Vector'} - if ~(length(a) == length(b)) - return; - end - for i=1:length(a) - if ~(type_utils.equal(a.get(i), b.get(i))) - return; - end - end - ret = true; - case 'types.HashMap' - if ~(length(a) == length(b)) - return; - end - ks1 = a.keys(); - for i=1:length(ks1) - k = ks1{i}; - if ~(b.data.isKey(k)) - return; - end - if ~(type_utils.equal(a.data(k), b.data(k))) - return; - end - end - ret = true; - case 'char' - ret = strcmp(a,b); - otherwise - ret = a == b; - end - end - - function ret = sequential_Q(obj) - ret = strcmp(class(obj), 'types.List') || ... - strcmp(class(obj), 'types.Vector'); - end - - function ret = list_Q(obj) - ret = strcmp(class(obj), 'types.List'); - end - function ret = vector_Q(obj) - ret = strcmp(class(obj), 'types.Vector'); - end - function ret = hash_map_Q(obj) - ret = strcmp(class(obj), 'types.HashMap'); - end - - function ret = keyword(str) - if type_utils.keyword_Q(str) - ret = str; - else - ret = sprintf('%c%s', 255, str); - end - end - function ret = keyword_Q(obj) - ret = length(obj) > 1 && strcmp(obj(1), sprintf('%c', 255)); - end - - function ret = string_Q(obj) - ret = strcmp(class(obj), 'char') && ~type_utils.keyword_Q(obj); - end - - function ret = number_Q(obj) - ret = strcmp(class(obj), 'double'); - end - - function ret = fn_Q(obj) - ret = isa(obj,'function_handle') || ... - (isa(obj,'types.Function') && ~obj.is_macro); - end - - function ret = macro_Q(obj) - ret = isa(obj,'types.Function') && obj.is_macro; - end - - function print_stack(err) - for i=1:numel(err.stack) - stack = err.stack(i); - if exist('OCTAVE_VERSION', 'builtin') ~= 0 - fprintf(' %s at line %d column %d (%s)\n', ... - stack.name, stack.line, stack.column, stack.file); - else - fprintf(' %s at line %d (%s)\n', ... - stack.name, stack.line, stack.file); - end - end - end - end -end - +classdef type_utils + properties (Constant = true) + nil = types.Nil(); + end + + methods(Static) + function ret = equal(a,b) + ret = false; + ota = class(a); otb = class(b); + if ~(strcmp(ota,otb) || ... + (type_utils.sequential_Q(a) && type_utils.sequential_Q(b))) + return; + end + switch (ota) + case {'types.List', 'types.Vector'} + if ~(length(a) == length(b)) + return; + end + for i=1:length(a) + if ~(type_utils.equal(a.get(i), b.get(i))) + return; + end + end + ret = true; + case 'types.HashMap' + if ~(length(a) == length(b)) + return; + end + ks1 = a.keys(); + for i=1:length(ks1) + k = ks1{i}; + if ~(b.data.isKey(k)) + return; + end + if ~(type_utils.equal(a.data(k), b.data(k))) + return; + end + end + ret = true; + case 'char' + ret = strcmp(a,b); + otherwise + ret = a == b; + end + end + + function ret = sequential_Q(obj) + ret = strcmp(class(obj), 'types.List') || ... + strcmp(class(obj), 'types.Vector'); + end + + function ret = list_Q(obj) + ret = strcmp(class(obj), 'types.List'); + end + function ret = vector_Q(obj) + ret = strcmp(class(obj), 'types.Vector'); + end + function ret = hash_map_Q(obj) + ret = strcmp(class(obj), 'types.HashMap'); + end + + function ret = keyword(str) + if type_utils.keyword_Q(str) + ret = str; + else + ret = sprintf('%c%s', 255, str); + end + end + function ret = keyword_Q(obj) + ret = length(obj) > 1 && strcmp(obj(1), sprintf('%c', 255)); + end + + function ret = string_Q(obj) + ret = strcmp(class(obj), 'char') && ~type_utils.keyword_Q(obj); + end + + function ret = number_Q(obj) + ret = strcmp(class(obj), 'double'); + end + + function ret = fn_Q(obj) + ret = isa(obj,'function_handle') || ... + (isa(obj,'types.Function') && ~obj.is_macro); + end + + function ret = macro_Q(obj) + ret = isa(obj,'types.Function') && obj.is_macro; + end + + function print_stack(err) + for i=1:numel(err.stack) + stack = err.stack(i); + if exist('OCTAVE_VERSION', 'builtin') ~= 0 + fprintf(' %s at line %d column %d (%s)\n', ... + stack.name, stack.line, stack.column, stack.file); + else + fprintf(' %s at line %d (%s)\n', ... + stack.name, stack.line, stack.file); + end + end + end + end +end + diff --git a/impls/miniMAL/Dockerfile b/impls/miniMAL/Dockerfile index fa54933ccb..861ca688a6 100644 --- a/impls/miniMAL/Dockerfile +++ b/impls/miniMAL/Dockerfile @@ -1,37 +1,37 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm - -# install miniMAL -RUN npm install -g minimal-lisp +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm + +# install miniMAL +RUN npm install -g minimal-lisp diff --git a/impls/miniMAL/Makefile b/impls/miniMAL/Makefile index 4d5a808de2..8d0d0ba026 100644 --- a/impls/miniMAL/Makefile +++ b/impls/miniMAL/Makefile @@ -1,30 +1,30 @@ - -SOURCES_BASE = node_readline.js miniMAL-core.json \ - types.json reader.json printer.json -SOURCES_LISP = env.json core.json stepA_mal.json -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) -FFI_STEPS = step4_if_fn_do step5_tco step6_file \ - step7_quote step8_macros step9_try stepA_mal - -all: node_modules - -node_modules: - npm install - -$(foreach S,$(FFI_STEPS),$(S).json): node_modules - -dist: mal.json mal - -mal.json: $(filter-out %.js,$(SOURCES)) - echo '["do",' >> $@ - $(foreach f,$+,\ - cat $(f) | egrep -v '^ *[[]"load-file"' >> $@; \ - echo "," >> $@;) - echo 'null]' >> $@ - -mal: mal.json - echo '#!/usr/bin/env miniMAL' > $@ - cat $< >> $@ - chmod +x $@ - -clean: + +SOURCES_BASE = node_readline.js miniMAL-core.json \ + types.json reader.json printer.json +SOURCES_LISP = env.json core.json stepA_mal.json +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) +FFI_STEPS = step4_if_fn_do step5_tco step6_file \ + step7_quote step8_macros step9_try stepA_mal + +all: node_modules + +node_modules: + npm install + +$(foreach S,$(FFI_STEPS),$(S).json): node_modules + +dist: mal.json mal + +mal.json: $(filter-out %.js,$(SOURCES)) + echo '["do",' >> $@ + $(foreach f,$+,\ + cat $(f) | egrep -v '^ *[[]"load-file"' >> $@; \ + echo "," >> $@;) + echo 'null]' >> $@ + +mal: mal.json + echo '#!/usr/bin/env miniMAL' > $@ + cat $< >> $@ + chmod +x $@ + +clean: diff --git a/impls/miniMAL/core.json b/impls/miniMAL/core.json index d80efad732..87890eceaf 100644 --- a/impls/miniMAL/core.json +++ b/impls/miniMAL/core.json @@ -1,194 +1,194 @@ -["do", - -["def", "_path", ["require", ["`", "path"]]], - -["def", "_node_readline", ["require", [".", "_path", ["`", "resolve"], - ["`", "."], - ["`", "node_readline.js"]]]], - -["def", "_string?", ["fn", ["s"], - ["and", ["string?", "s"], - ["not", ["=", ["`", "\u029e"], ["get", "s", 0]]]]]], - -["def", "div", ["fn", ["a", "b"], ["parseInt", ["/", "a", "b"]]]], - -["def", "time-ms", ["fn", [], - [".", ["new", "Date"], ["`", "getTime"]]]], - - -["def", "assoc", ["fn", ["src-hm", "&", "kvs"], - ["let", ["hm", ["clone", "src-hm"]], - ["assocs!", "hm", "kvs"]]]], - -["def", "dissoc", ["fn", ["src-hm", "&", "ks"], - ["let", ["hm", ["clone", "src-hm"]], - ["do", - ["map", ["fn", ["k"], ["del", "hm", "k"]], "ks"], - "hm"]]]], - -["def", "_get", ["fn", ["obj", "key"], - ["if", ["null?", "obj"], - null, - ["if", ["contains?", "obj", "key"], - ["get", "obj", "key"], - null]]]], - -["def", "_count", ["fn", ["a"], - ["if", ["=", null, "a"], - 0, - ["count", "a"]]]], - -["def", "_nth", ["fn", ["seq", "idx"], - ["if", [">=", "idx", ["count", "seq"]], - ["throw", "nth: index out of range"], - ["nth", "seq", "idx"]]]], - -["def", "_first", ["fn", ["seq"], - ["if", ["empty?", "seq"], - null, - ["first", "seq"]]]], - -["def", "_rest", ["fn", ["seq"], - ["if", ["empty?", "seq"], - ["`", []], - ["rest", "seq"]]]], - -["def", "_apply", ["fn", ["f", "&", "args"], - ["let", ["fn", ["if", ["malfunc?", "f"], ["get", "f", ["`", "fn"]], "f"], - "fargs", ["concat", ["slice", "args", 0, ["-", ["count", "args"], 1]], - ["nth", "args", ["-", ["count", "args"], 1]]]], - ["apply", "fn", "fargs"]]]], - -["def", "_map", ["fn", ["f", "seq"], - ["let", ["fn", ["if", ["malfunc?", "f"], ["get", "f", ["`", "fn"]], "f"]], - ["map", "fn", "seq"]]]], - -["def", "_conj", ["fn", ["seq", "&", "a"], - ["if", ["list?", "seq"], - [".", [".", "a", ["`", "reverse"]], ["`", "concat"], "seq"], - ["vectorl", [".", "seq", ["`", "concat"], "a"]]]]], - -["def", "_seq", ["fn", ["obj"], - ["if", ["list?", "obj"], - ["if", [">", ["count", "obj"], 0], "obj", null], - ["if", ["vector?", "obj"], - ["if", [">", ["count", "obj"], 0], ["slice", "obj", 0], null], - ["if", ["string?", "obj"], - ["if", [">", ["count", "obj"], 0], - [".", "obj", ["`", "split"], ["`", ""]], - null], - ["if", ["null?", "obj"], - null, - ["throw", "seq: called on non-sequence"] - ]]]]]], - -["def", "with_meta", ["fn", ["obj", "m"], - ["let", ["new-obj", ["clone", "obj"]], - ["do", - ["set", "new-obj", ["`", "__meta__"], "m"], - "new-obj"]]]], - -["def", "meta", ["fn", ["obj"], - ["if", ["or", ["sequential?", "obj"], - ["map?", "obj"], - ["malfunc?", "obj"]], - ["if", ["contains?", "obj", ["`", "__meta__"]], - ["get", "obj", ["`", "__meta__"]], - null], - null]]], - -["def", "reset!", ["fn", ["atm", "val"], - ["do", ["set", "atm", ["`", "val"], "val"], "val"]]], - -["def", "swap!", ["fn", ["atm", "f", "&", "args"], - ["let", ["fn", ["if", ["malfunc?", "f"], ["get", "f", ["`", "fn"]], "f"], - "fargs", ["cons", ["get", "atm", ["`", "val"]], "args"], - "val", ["apply", "fn", "fargs"]], - ["do", - ["set", "atm", ["`", "val"], "val"], - "val"]]]], - -["def", "core-ns", - ["hash-map", - ["`", "="], "equal?", - ["`", "throw"], "throw", - - ["`", "nil?"], "null?", - ["`", "true?"], "true?", - ["`", "false?"], "false?", - ["`", "string?"], "_string?", - ["`", "symbol"], "symbol", - ["`", "symbol?"], "symbol?", - ["`", "keyword"], "keyword", - ["`", "keyword?"], "keyword?", - ["`", "number?"], "number?", - ["`", "fn?"], ["fn", ["a"], - ["or", ["function?", "a"], - ["and", ["malfunc?", "a"], - ["not", ["get", "a", ["`", "macro?"]]]]]], - ["`", "macro?"], ["fn", ["a"], - ["and", ["malfunc?", "a"], - ["get", "a", ["`", "macro?"]]]], - - ["`", "pr-str"], ["fn", ["&", "a"], ["pr-list", "a", true, ["`", " "]]], - ["`", "str"], ["fn", ["&", "a"], ["pr-list", "a", false, ["`", ""]]], - ["`", "prn"], ["fn", ["&", "a"], - ["do", - ["println", ["pr-list", "a", true, ["`", " "]]], - null]], - ["`", "println"], ["fn", ["&", "a"], - ["do", - ["println", ["pr-list", "a", false, ["`", " "]]], - null]], - ["`", "read-string"], "read-str", - ["`", "readline"], ["fn", ["p"], - [".", "_node_readline", ["`", "readline"], "p"]], - ["`", "slurp"], "slurp", - - ["`", "<"], "<", - ["`", "<="], "<=", - ["`", ">"], ">", - ["`", ">="], ">=", - ["`", "+"], "+", - ["`", "-"], "-", - ["`", "*"], "*", - ["`", "/"], "div", - ["`", "time-ms"], "time-ms", - - ["`", "list"], "list", - ["`", "list?"], "list?", - ["`", "vector"], "vector", - ["`", "vector?"], "vector?", - ["`", "hash-map"], "hash-map", - ["`", "assoc"], "assoc", - ["`", "dissoc"], "dissoc", - ["`", "map?"], "map?", - ["`", "get"], "_get", - ["`", "contains?"], "contains?", - ["`", "keys"], "keys", - ["`", "vals"], "vals", - - ["`", "sequential?"], "sequential?", - ["`", "cons"], "cons", - ["`", "concat"], "concat", - ["`", "vec"], "vectorl", - ["`", "nth"], "_nth", - ["`", "first"], "_first", - ["`", "rest"], "_rest", - ["`", "empty?"], "empty?", - ["`", "count"], "_count", - ["`", "apply"], "_apply", - ["`", "map"], "_map", - - ["`", "conj"], "_conj", - ["`", "seq"], "_seq", - - ["`", "with-meta"], "with_meta", - ["`", "meta"], "meta", - ["`", "atom"], "atom", - ["`", "atom?"], "atom?", - ["`", "deref"], ["fn", ["a"], ["get", "a", ["`", "val"]]], - ["`", "reset!"], "reset!", - ["`", "swap!"], "swap!"]], - -null] +["do", + +["def", "_path", ["require", ["`", "path"]]], + +["def", "_node_readline", ["require", [".", "_path", ["`", "resolve"], + ["`", "."], + ["`", "node_readline.js"]]]], + +["def", "_string?", ["fn", ["s"], + ["and", ["string?", "s"], + ["not", ["=", ["`", "\u029e"], ["get", "s", 0]]]]]], + +["def", "div", ["fn", ["a", "b"], ["parseInt", ["/", "a", "b"]]]], + +["def", "time-ms", ["fn", [], + [".", ["new", "Date"], ["`", "getTime"]]]], + + +["def", "assoc", ["fn", ["src-hm", "&", "kvs"], + ["let", ["hm", ["clone", "src-hm"]], + ["assocs!", "hm", "kvs"]]]], + +["def", "dissoc", ["fn", ["src-hm", "&", "ks"], + ["let", ["hm", ["clone", "src-hm"]], + ["do", + ["map", ["fn", ["k"], ["del", "hm", "k"]], "ks"], + "hm"]]]], + +["def", "_get", ["fn", ["obj", "key"], + ["if", ["null?", "obj"], + null, + ["if", ["contains?", "obj", "key"], + ["get", "obj", "key"], + null]]]], + +["def", "_count", ["fn", ["a"], + ["if", ["=", null, "a"], + 0, + ["count", "a"]]]], + +["def", "_nth", ["fn", ["seq", "idx"], + ["if", [">=", "idx", ["count", "seq"]], + ["throw", "nth: index out of range"], + ["nth", "seq", "idx"]]]], + +["def", "_first", ["fn", ["seq"], + ["if", ["empty?", "seq"], + null, + ["first", "seq"]]]], + +["def", "_rest", ["fn", ["seq"], + ["if", ["empty?", "seq"], + ["`", []], + ["rest", "seq"]]]], + +["def", "_apply", ["fn", ["f", "&", "args"], + ["let", ["fn", ["if", ["malfunc?", "f"], ["get", "f", ["`", "fn"]], "f"], + "fargs", ["concat", ["slice", "args", 0, ["-", ["count", "args"], 1]], + ["nth", "args", ["-", ["count", "args"], 1]]]], + ["apply", "fn", "fargs"]]]], + +["def", "_map", ["fn", ["f", "seq"], + ["let", ["fn", ["if", ["malfunc?", "f"], ["get", "f", ["`", "fn"]], "f"]], + ["map", "fn", "seq"]]]], + +["def", "_conj", ["fn", ["seq", "&", "a"], + ["if", ["list?", "seq"], + [".", [".", "a", ["`", "reverse"]], ["`", "concat"], "seq"], + ["vectorl", [".", "seq", ["`", "concat"], "a"]]]]], + +["def", "_seq", ["fn", ["obj"], + ["if", ["list?", "obj"], + ["if", [">", ["count", "obj"], 0], "obj", null], + ["if", ["vector?", "obj"], + ["if", [">", ["count", "obj"], 0], ["slice", "obj", 0], null], + ["if", ["string?", "obj"], + ["if", [">", ["count", "obj"], 0], + [".", "obj", ["`", "split"], ["`", ""]], + null], + ["if", ["null?", "obj"], + null, + ["throw", "seq: called on non-sequence"] + ]]]]]], + +["def", "with_meta", ["fn", ["obj", "m"], + ["let", ["new-obj", ["clone", "obj"]], + ["do", + ["set", "new-obj", ["`", "__meta__"], "m"], + "new-obj"]]]], + +["def", "meta", ["fn", ["obj"], + ["if", ["or", ["sequential?", "obj"], + ["map?", "obj"], + ["malfunc?", "obj"]], + ["if", ["contains?", "obj", ["`", "__meta__"]], + ["get", "obj", ["`", "__meta__"]], + null], + null]]], + +["def", "reset!", ["fn", ["atm", "val"], + ["do", ["set", "atm", ["`", "val"], "val"], "val"]]], + +["def", "swap!", ["fn", ["atm", "f", "&", "args"], + ["let", ["fn", ["if", ["malfunc?", "f"], ["get", "f", ["`", "fn"]], "f"], + "fargs", ["cons", ["get", "atm", ["`", "val"]], "args"], + "val", ["apply", "fn", "fargs"]], + ["do", + ["set", "atm", ["`", "val"], "val"], + "val"]]]], + +["def", "core-ns", + ["hash-map", + ["`", "="], "equal?", + ["`", "throw"], "throw", + + ["`", "nil?"], "null?", + ["`", "true?"], "true?", + ["`", "false?"], "false?", + ["`", "string?"], "_string?", + ["`", "symbol"], "symbol", + ["`", "symbol?"], "symbol?", + ["`", "keyword"], "keyword", + ["`", "keyword?"], "keyword?", + ["`", "number?"], "number?", + ["`", "fn?"], ["fn", ["a"], + ["or", ["function?", "a"], + ["and", ["malfunc?", "a"], + ["not", ["get", "a", ["`", "macro?"]]]]]], + ["`", "macro?"], ["fn", ["a"], + ["and", ["malfunc?", "a"], + ["get", "a", ["`", "macro?"]]]], + + ["`", "pr-str"], ["fn", ["&", "a"], ["pr-list", "a", true, ["`", " "]]], + ["`", "str"], ["fn", ["&", "a"], ["pr-list", "a", false, ["`", ""]]], + ["`", "prn"], ["fn", ["&", "a"], + ["do", + ["println", ["pr-list", "a", true, ["`", " "]]], + null]], + ["`", "println"], ["fn", ["&", "a"], + ["do", + ["println", ["pr-list", "a", false, ["`", " "]]], + null]], + ["`", "read-string"], "read-str", + ["`", "readline"], ["fn", ["p"], + [".", "_node_readline", ["`", "readline"], "p"]], + ["`", "slurp"], "slurp", + + ["`", "<"], "<", + ["`", "<="], "<=", + ["`", ">"], ">", + ["`", ">="], ">=", + ["`", "+"], "+", + ["`", "-"], "-", + ["`", "*"], "*", + ["`", "/"], "div", + ["`", "time-ms"], "time-ms", + + ["`", "list"], "list", + ["`", "list?"], "list?", + ["`", "vector"], "vector", + ["`", "vector?"], "vector?", + ["`", "hash-map"], "hash-map", + ["`", "assoc"], "assoc", + ["`", "dissoc"], "dissoc", + ["`", "map?"], "map?", + ["`", "get"], "_get", + ["`", "contains?"], "contains?", + ["`", "keys"], "keys", + ["`", "vals"], "vals", + + ["`", "sequential?"], "sequential?", + ["`", "cons"], "cons", + ["`", "concat"], "concat", + ["`", "vec"], "vectorl", + ["`", "nth"], "_nth", + ["`", "first"], "_first", + ["`", "rest"], "_rest", + ["`", "empty?"], "empty?", + ["`", "count"], "_count", + ["`", "apply"], "_apply", + ["`", "map"], "_map", + + ["`", "conj"], "_conj", + ["`", "seq"], "_seq", + + ["`", "with-meta"], "with_meta", + ["`", "meta"], "meta", + ["`", "atom"], "atom", + ["`", "atom?"], "atom?", + ["`", "deref"], ["fn", ["a"], ["get", "a", ["`", "val"]]], + ["`", "reset!"], "reset!", + ["`", "swap!"], "swap!"]], + +null] diff --git a/impls/miniMAL/env.json b/impls/miniMAL/env.json index 0dfa67b5f9..84e2ecd4a0 100644 --- a/impls/miniMAL/env.json +++ b/impls/miniMAL/env.json @@ -1,42 +1,42 @@ -["do", - -["def", "env-bind", ["fn", ["env", "b", "e"], - ["if", ["empty?", "b"], - "env", - ["if", ["=", ["`", "&"], - ["get", ["first", "b"], ["`", "val"]]], - ["assoc!", "env", ["get", ["nth", "b", 1], ["`", "val"]], "e"], - ["env-bind", ["assoc!", "env", ["get", ["first", "b"], ["`", "val"]], - ["first", "e"]], - ["rest", "b"], - ["rest", "e"]]]]]], - -["def", "env-new", ["fn", ["&", "args"], - ["let", ["env", ["hash-map", ["`", "__outer__"], ["first", "args"]]], - ["if", ["<=", ["count", "args"], 1], - "env", - ["env-bind", "env", ["get", "args", 1], ["get", "args", 2]]]]]], - -["def", "env-find", ["fn", ["env", "key"], - ["let", ["k", ["get", "key", ["`", "val"]]], - ["if", ["contains?", "env", "k"], - "env", - ["if", ["get", "env", ["`", "__outer__"]], - ["env-find", ["get", "env", ["`", "__outer__"]], "key"], - null]]]]], - -["def", "env-get", ["fn", ["env", "key"], - ["let", ["k", ["get", "key", ["`", "val"]], - "e", ["env-find", "env", "key"]], - ["if", "e", - ["get", "e", "k"], - ["throw", ["str", ["`", "'"], "k", ["`", "' not found"]]]]]]], - -["def", "env-set", ["fn", ["env", "key", "val"], - ["let", ["k", ["get", "key", ["`", "val"]]], - ["do", - ["assoc!", "env", "k", "val"], - "val"]]]], - -null -] +["do", + +["def", "env-bind", ["fn", ["env", "b", "e"], + ["if", ["empty?", "b"], + "env", + ["if", ["=", ["`", "&"], + ["get", ["first", "b"], ["`", "val"]]], + ["assoc!", "env", ["get", ["nth", "b", 1], ["`", "val"]], "e"], + ["env-bind", ["assoc!", "env", ["get", ["first", "b"], ["`", "val"]], + ["first", "e"]], + ["rest", "b"], + ["rest", "e"]]]]]], + +["def", "env-new", ["fn", ["&", "args"], + ["let", ["env", ["hash-map", ["`", "__outer__"], ["first", "args"]]], + ["if", ["<=", ["count", "args"], 1], + "env", + ["env-bind", "env", ["get", "args", 1], ["get", "args", 2]]]]]], + +["def", "env-find", ["fn", ["env", "key"], + ["let", ["k", ["get", "key", ["`", "val"]]], + ["if", ["contains?", "env", "k"], + "env", + ["if", ["get", "env", ["`", "__outer__"]], + ["env-find", ["get", "env", ["`", "__outer__"]], "key"], + null]]]]], + +["def", "env-get", ["fn", ["env", "key"], + ["let", ["k", ["get", "key", ["`", "val"]], + "e", ["env-find", "env", "key"]], + ["if", "e", + ["get", "e", "k"], + ["throw", ["str", ["`", "'"], "k", ["`", "' not found"]]]]]]], + +["def", "env-set", ["fn", ["env", "key", "val"], + ["let", ["k", ["get", "key", ["`", "val"]]], + ["do", + ["assoc!", "env", "k", "val"], + "val"]]]], + +null +] diff --git a/impls/miniMAL/miniMAL-core.json b/impls/miniMAL/miniMAL-core.json index cc3379f0e7..db26486164 100644 --- a/impls/miniMAL/miniMAL-core.json +++ b/impls/miniMAL/miniMAL-core.json @@ -1,140 +1,140 @@ -["do", - -["def", "new", ["fn", ["a", "&", "b"], - [".", "Reflect", ["`", "construct"], "a", "b"]]], -["def", "del", ["fn", ["a", "b"], - [".", "Reflect", ["`", "deleteProperty"], "a", "b"]]], -["def", "map", ["fn", ["a", "b"], - [".", "b", ["`", "map"], ["fn", ["x"], ["a", "x"]]]]], -["def", "list", ["fn", ["&", "a"], "a"]], -["def", ">=", ["fn", ["a", "b"], - ["if", ["<", "a", "b"], false, true]]], -["def", ">", ["fn", ["a", "b"], - ["if", [">=", "a", "b"], - ["if", ["=", "a", "b"], false, true], - false]]], -["def", "<=", ["fn", ["a", "b"], - ["if", [">", "a", "b"], false, true]]], - -["def", "classOf", ["fn", ["a"], - [".", [".-", [".-", "Object", ["`", "prototype"]], ["`", "toString"]], - ["`", "call"], "a"]]], - -["def", "not", ["fn", ["a"], ["if", "a", false, true]]], - -["def", "null?", ["fn", ["a"], ["=", null, "a"]]], -["def", "true?", ["fn", ["a"], ["=", true, "a"]]], -["def", "false?", ["fn", ["a"], ["=", false, "a"]]], -["def", "string?", ["fn", ["a"], - ["if", ["=", "a", null], - false, - ["=", ["`", "String"], - [".-", [".-", "a", ["`", "constructor"]], - ["`", "name"]]]]]], -["def", "number?", ["fn", ["a"], - ["=", ["`", "[object Number]"], ["classOf", "a"]]]], -["def", "function?", ["fn", ["a"], - ["isa", "a", "Function"]]], - -["def", "pr-list*", ["fn", ["a", "b", "c"], - [".", ["map", ["fn", ["x"], - ["if", "c", - [".", "JSON", ["`", "stringify"], "x"], - ["if", ["string?", "x"], - "x", - [".", "JSON", ["`", "stringify"], "x"]]]], - "a"], - ["`", "join"], "b"]]], -["def", "pr-str", ["fn", ["&", "a"], - ["pr-list*", "a", ["`", " "], true]]], -["def", "str", ["fn", ["&", "a"], - ["pr-list*", "a", ["`", ""], false]]], -["def", "prn", ["fn", ["&", "a"], - ["do", [".", "console", ["`", "log"], - ["pr-list*", "a", ["`", " "], true]], null]]], -["def", "println", ["fn", ["&", "a"], - ["do", [".", "console", ["`", "log"], - ["pr-list*", "a", ["`", " "], false]], null]]], - -["def", "list?", ["fn", ["a"], - [".", "Array", ["`", "isArray"], "a"]]], -["def", "contains?", ["fn", ["a", "b"], - [".", "a", ["`", "hasOwnProperty"], "b"]]], -["def", "get", ["fn", ["a", "b"], - ["if", ["contains?", "a", "b"], [".-", "a", "b"], null]]], -["def", "set", ["fn", ["a", "b", "c"], - ["do", [".-", "a", "b", "c"], "a"]]], -["def", "keys", ["fn", ["a"], - [".", "Object", ["`", "keys"], "a"]]], -["def", "vals", ["fn", ["a"], - ["map",["fn", ["k"], ["get", "a", "k"]], ["keys", "a"]]]], - -["def", "cons", ["fn", ["a", "b"], - [".", ["`", []], - ["`", "concat"], ["list", "a"], "b"]]], -["def", "concat", ["fn", ["&", "a"], - [".", [".-", ["list"], ["`", "concat"]], - ["`", "apply"], ["list"], "a"]]], -["def", "nth", "get"], -["def", "first", ["fn", ["a"], - ["if", [">", [".-", "a", ["`", "length"]], 0], - ["nth", "a", 0], - null]]], -["def", "last", ["fn", ["a"], - ["nth", "a", ["-", [".-", "a", ["`", "length"]], 1]]]], -["def", "count", ["fn", ["a"], - [".-", "a", ["`", "length"]]]], -["def", "empty?", ["fn", ["a"], - ["if", ["list?", "a"], - ["if", ["=", 0, [".-", "a", ["`", "length"]]], true, false], - ["=", "a", null]]]], -["def", "slice", ["fn", ["a", "b", "&", "end"], - [".", "a", ["`", "slice"], "b", - ["if", [">", ["count", "end"], 0], - ["get", "end", 0], - [".-", "a", ["`", "length"]]]]]], -["def", "rest", ["fn", ["a"], ["slice", "a", 1]]], - -["def", "apply", ["fn", ["f", "&", "b"], - [".", "f", ["`", "apply"], "f", - ["concat", ["slice", "b", 0, -1], ["last", "b"]]]]], - -["def", "and", ["~", ["fn", ["&", "xs"], - ["if", ["empty?", "xs"], - true, - ["if", ["=", 1, ["count", "xs"]], - ["first", "xs"], - ["list", ["`", "let"], ["list", ["`", "and_FIXME"], ["first", "xs"]], - ["list", ["`", "if"], ["`", "and_FIXME"], - ["concat", ["`", ["and"]], ["rest", "xs"]], - ["`", "and_FIXME"]]]]]]]], - -["def", "or", ["~", ["fn", ["&", "xs"], - ["if", ["empty?", "xs"], - null, - ["if", ["=", 1, ["count", "xs"]], - ["first", "xs"], - ["list", ["`", "let"], ["list", ["`", "or_FIXME"], ["first", "xs"]], - ["list", ["`", "if"], ["`", "or_FIXME"], - ["`", "or_FIXME"], - ["concat", ["`", ["or"]], ["rest", "xs"]]]]]]]]], - -["def", "repl", ["fn",["prompt", "rep"], - ["let", ["readline", ["require", ["`", "readline"]], - "opts", ["new", "Object"], - "_", ["set", "opts", ["`", "input"], [".-", "process", ["`", "stdin"]]], - "_", ["set", "opts", ["`", "output"], [".-", "process", ["`", "stdout"]]], - "_", ["set", "opts", ["`", "terminal"], false], - "rl", [".", "readline", ["`", "createInterface"], "opts"], - "evl", ["fn", ["line"], - ["do", - ["println", ["rep", "line"]], - [".", "rl", ["`", "prompt"]]]]], - ["do", - [".", "rl", ["`", "setPrompt"], "prompt"], - [".", "rl", ["`", "prompt"]], - [".", "rl", ["`", "on"], ["`", "line"], "evl"]]]]], - -null -] - +["do", + +["def", "new", ["fn", ["a", "&", "b"], + [".", "Reflect", ["`", "construct"], "a", "b"]]], +["def", "del", ["fn", ["a", "b"], + [".", "Reflect", ["`", "deleteProperty"], "a", "b"]]], +["def", "map", ["fn", ["a", "b"], + [".", "b", ["`", "map"], ["fn", ["x"], ["a", "x"]]]]], +["def", "list", ["fn", ["&", "a"], "a"]], +["def", ">=", ["fn", ["a", "b"], + ["if", ["<", "a", "b"], false, true]]], +["def", ">", ["fn", ["a", "b"], + ["if", [">=", "a", "b"], + ["if", ["=", "a", "b"], false, true], + false]]], +["def", "<=", ["fn", ["a", "b"], + ["if", [">", "a", "b"], false, true]]], + +["def", "classOf", ["fn", ["a"], + [".", [".-", [".-", "Object", ["`", "prototype"]], ["`", "toString"]], + ["`", "call"], "a"]]], + +["def", "not", ["fn", ["a"], ["if", "a", false, true]]], + +["def", "null?", ["fn", ["a"], ["=", null, "a"]]], +["def", "true?", ["fn", ["a"], ["=", true, "a"]]], +["def", "false?", ["fn", ["a"], ["=", false, "a"]]], +["def", "string?", ["fn", ["a"], + ["if", ["=", "a", null], + false, + ["=", ["`", "String"], + [".-", [".-", "a", ["`", "constructor"]], + ["`", "name"]]]]]], +["def", "number?", ["fn", ["a"], + ["=", ["`", "[object Number]"], ["classOf", "a"]]]], +["def", "function?", ["fn", ["a"], + ["isa", "a", "Function"]]], + +["def", "pr-list*", ["fn", ["a", "b", "c"], + [".", ["map", ["fn", ["x"], + ["if", "c", + [".", "JSON", ["`", "stringify"], "x"], + ["if", ["string?", "x"], + "x", + [".", "JSON", ["`", "stringify"], "x"]]]], + "a"], + ["`", "join"], "b"]]], +["def", "pr-str", ["fn", ["&", "a"], + ["pr-list*", "a", ["`", " "], true]]], +["def", "str", ["fn", ["&", "a"], + ["pr-list*", "a", ["`", ""], false]]], +["def", "prn", ["fn", ["&", "a"], + ["do", [".", "console", ["`", "log"], + ["pr-list*", "a", ["`", " "], true]], null]]], +["def", "println", ["fn", ["&", "a"], + ["do", [".", "console", ["`", "log"], + ["pr-list*", "a", ["`", " "], false]], null]]], + +["def", "list?", ["fn", ["a"], + [".", "Array", ["`", "isArray"], "a"]]], +["def", "contains?", ["fn", ["a", "b"], + [".", "a", ["`", "hasOwnProperty"], "b"]]], +["def", "get", ["fn", ["a", "b"], + ["if", ["contains?", "a", "b"], [".-", "a", "b"], null]]], +["def", "set", ["fn", ["a", "b", "c"], + ["do", [".-", "a", "b", "c"], "a"]]], +["def", "keys", ["fn", ["a"], + [".", "Object", ["`", "keys"], "a"]]], +["def", "vals", ["fn", ["a"], + ["map",["fn", ["k"], ["get", "a", "k"]], ["keys", "a"]]]], + +["def", "cons", ["fn", ["a", "b"], + [".", ["`", []], + ["`", "concat"], ["list", "a"], "b"]]], +["def", "concat", ["fn", ["&", "a"], + [".", [".-", ["list"], ["`", "concat"]], + ["`", "apply"], ["list"], "a"]]], +["def", "nth", "get"], +["def", "first", ["fn", ["a"], + ["if", [">", [".-", "a", ["`", "length"]], 0], + ["nth", "a", 0], + null]]], +["def", "last", ["fn", ["a"], + ["nth", "a", ["-", [".-", "a", ["`", "length"]], 1]]]], +["def", "count", ["fn", ["a"], + [".-", "a", ["`", "length"]]]], +["def", "empty?", ["fn", ["a"], + ["if", ["list?", "a"], + ["if", ["=", 0, [".-", "a", ["`", "length"]]], true, false], + ["=", "a", null]]]], +["def", "slice", ["fn", ["a", "b", "&", "end"], + [".", "a", ["`", "slice"], "b", + ["if", [">", ["count", "end"], 0], + ["get", "end", 0], + [".-", "a", ["`", "length"]]]]]], +["def", "rest", ["fn", ["a"], ["slice", "a", 1]]], + +["def", "apply", ["fn", ["f", "&", "b"], + [".", "f", ["`", "apply"], "f", + ["concat", ["slice", "b", 0, -1], ["last", "b"]]]]], + +["def", "and", ["~", ["fn", ["&", "xs"], + ["if", ["empty?", "xs"], + true, + ["if", ["=", 1, ["count", "xs"]], + ["first", "xs"], + ["list", ["`", "let"], ["list", ["`", "and_FIXME"], ["first", "xs"]], + ["list", ["`", "if"], ["`", "and_FIXME"], + ["concat", ["`", ["and"]], ["rest", "xs"]], + ["`", "and_FIXME"]]]]]]]], + +["def", "or", ["~", ["fn", ["&", "xs"], + ["if", ["empty?", "xs"], + null, + ["if", ["=", 1, ["count", "xs"]], + ["first", "xs"], + ["list", ["`", "let"], ["list", ["`", "or_FIXME"], ["first", "xs"]], + ["list", ["`", "if"], ["`", "or_FIXME"], + ["`", "or_FIXME"], + ["concat", ["`", ["or"]], ["rest", "xs"]]]]]]]]], + +["def", "repl", ["fn",["prompt", "rep"], + ["let", ["readline", ["require", ["`", "readline"]], + "opts", ["new", "Object"], + "_", ["set", "opts", ["`", "input"], [".-", "process", ["`", "stdin"]]], + "_", ["set", "opts", ["`", "output"], [".-", "process", ["`", "stdout"]]], + "_", ["set", "opts", ["`", "terminal"], false], + "rl", [".", "readline", ["`", "createInterface"], "opts"], + "evl", ["fn", ["line"], + ["do", + ["println", ["rep", "line"]], + [".", "rl", ["`", "prompt"]]]]], + ["do", + [".", "rl", ["`", "setPrompt"], "prompt"], + [".", "rl", ["`", "prompt"]], + [".", "rl", ["`", "on"], ["`", "line"], "evl"]]]]], + +null +] + diff --git a/impls/miniMAL/node_readline.js b/impls/miniMAL/node_readline.js index 6042eaa0af..9bfa296bb2 100644 --- a/impls/miniMAL/node_readline.js +++ b/impls/miniMAL/node_readline.js @@ -1,46 +1,46 @@ -// IMPORTANT: choose one -var RL_LIB = "libreadline"; // NOTE: libreadline is GPL -//var RL_LIB = "libedit"; - -var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); - -var rlwrap = {}; // namespace for this module in web context - -var ffi = require('ffi-napi'), - fs = require('fs'); - -var rllib = ffi.Library(RL_LIB, { - 'readline': [ 'string', [ 'string' ] ], - 'add_history': [ 'int', [ 'string' ] ]}); - -var rl_history_loaded = false; - -exports.readline = rlwrap.readline = function(prompt) { - prompt = typeof prompt !== 'undefined' ? prompt : "user> "; - - if (!rl_history_loaded) { - rl_history_loaded = true; - var lines = []; - if (fs.existsSync(HISTORY_FILE)) { - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - } - // Max of 2000 lines - lines = lines.slice(Math.max(lines.length - 2000, 0)); - for (var i=0; i "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i"]], - ["if", ["atom?", "exp"], - ["str", ["`", "(atom "], ["get", "exp", ["`", "val"]], ["`", ")"]], - ["str", ["`", "#"]]]]]]]]]]]]]]]], - -["def", "pr-list", ["fn", ["lst", "print_readably", "sep"], - [".", ["map", ["fn", ["s"], ["pr-str", "s", "print_readably"]], "lst"], - ["`", "join"], "sep"]]], - -null -] +["do", + +["def", "pr-str", ["fn", ["exp", "print_readably"], + ["if", ["list?", "exp"], + ["str", + ["`", "("], + [".", ["map", ["fn", ["x"], ["pr-str", "x", "print_readably"]], "exp"], + ["`", "join"], ["`", " "]], + ["`", ")"]], + ["if", ["vector?", "exp"], + ["str", + ["`", "["], + [".", ["map", ["fn", ["x"], ["pr-str", "x", "print_readably"]], "exp"], + ["`", "join"], ["`", " "]], + ["`", "]"]], + ["if", ["map?", "exp"], + ["str", + ["`", "{"], + [".", ["map", ["fn", ["k"], + ["str", ["pr-str", "k", "print_readably"], + ["`", " "], + ["pr-str", ["get", "exp", "k"], "print_readably"]]], + ["keys", "exp"]], + ["`", "join"], ["`", " "]], + ["`", "}"]], + ["if", ["=", ["`", "[object String]"], ["classOf", "exp"]], + ["if", ["=", ["`", "\u029e"], ["get", "exp", 0]], + ["str", ["`", ":"], ["slice", "exp", 1]], + ["if", "print_readably", + ["str", ["`", "\""], + [".", + [".", + [".", "exp", + ["`", "replace"], ["RegExp", ["`", "\\\\"], ["`", "g"]], ["`", "\\\\"]], + ["`", "replace"], ["RegExp", ["`", "\""], ["`", "g"]], ["`", "\\\""]], + ["`", "replace"], ["RegExp", ["`", "\n"], ["`", "g"]], ["`", "\\n"]], + ["`", "\""]], + "exp"]], + ["if", ["=", ["`", "[object Number]"], ["classOf", "exp"]], + "exp", + ["if", ["=", null, "exp"], + ["`", "nil"], + ["if", ["=", true, "exp"], + ["`", "true"], + ["if", ["=", false, "exp"], + ["`", "false"], + ["if", ["symbol?", "exp"], + ["get", "exp", ["`", "val"]], + ["if", ["malfunc?", "exp"], + ["str", ["`", "(fn* "], + ["pr-str", ["get", "exp", ["`", "params"]]], + ["`", " "], + ["pr-str", ["get", "exp", ["`", "ast"]]], + ["`", ")"]], + ["if", ["=", ["`", "[object Function]"], ["classOf", "exp"]], + ["str", ["`", "#"]], + ["if", ["atom?", "exp"], + ["str", ["`", "(atom "], ["get", "exp", ["`", "val"]], ["`", ")"]], + ["str", ["`", "#"]]]]]]]]]]]]]]]], + +["def", "pr-list", ["fn", ["lst", "print_readably", "sep"], + [".", ["map", ["fn", ["s"], ["pr-str", "s", "print_readably"]], "lst"], + ["`", "join"], "sep"]]], + +null +] diff --git a/impls/miniMAL/reader.json b/impls/miniMAL/reader.json index 6cbb8bc9dd..a116c6d3d1 100644 --- a/impls/miniMAL/reader.json +++ b/impls/miniMAL/reader.json @@ -1,130 +1,130 @@ -["do", - -["def", "rdr-new", ["fn", ["tokens"], - ["hash-map", ["`", "tokens"], "tokens", - ["`", "position"], 0]]], - -["def", "rdr-next", ["fn", ["rdr"], - ["let", ["pos", ["get", "rdr", ["`", "position"]], - "val", ["get", ["get", "rdr", ["`", "tokens"]], "pos"]], - ["do", - ["assoc!", "rdr", ["`", "position"], ["+", 1, "pos"]], - "val"]]]], - -["def", "rdr-peek", ["fn", ["rdr"], - ["let", ["pos", ["get", "rdr", ["`", "position"]]], - ["get", ["get", "rdr", ["`", "tokens"]], "pos"]]]], - - -["def", "re-matches", ["fn", ["re", "strn", "acc"], - ["let", ["match", [".", "re", ["`", "exec"], "strn"], - "g1", ["get", "match", 1]], - ["if", ["=", "g1", ["`", ""]], - "acc", - ["re-matches", "re", "strn", ["concat", "acc", "g1"]]]]]], - -["def", "tokenize", ["fn", ["strn"], - ["let", ["re-str", ["`", "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)"], - "re", ["RegExp", "re-str", ["`", "g"]]], - [".", - ["re-matches", "re", "strn", ["`", []]], - ["`", "filter"], - ["fn", ["x"], ["not", ["=", ["get", "x", 0], - ["`", ";"]]]]]]]], - -["def", "read-atom", ["fn", ["rdr"], - ["let", ["token", ["rdr-next", "rdr"]], - ["if", [".", "token", ["`", "match"], ["RegExp", ["`", "^-?[0-9]+$"]]], - ["parseInt", "token", 10], - ["if", [".", "token", ["`", "match"], ["RegExp", ["`", "^\"(?:\\\\.|[^\\\\\"])*\"$"]]], - [".", - ["slice", "token", 1, ["-", ["count", "token"], 1]], - ["`", "replace"], ["RegExp", ["`", "\\\\(.)"], ["`", "g"]], - ["fn", ["_", "c"], - ["if", ["=", "c", ["`", "n"]], - ["`", "\n"], - "c"]]], - ["if", ["=", ["`", "\""], ["get", "token", 0]], - ["throw", ["`", "expected '\"', got EOF"]], - ["if", ["=", ["`", ":"], ["get", "token", 0]], - ["keyword", ["slice", "token", 1]], - ["if", ["=", ["`", "nil"], "token"], - null, - ["if", ["=", ["`", "true"], "token"], - true, - ["if", ["=", ["`", "false"], "token"], - false, - ["symbol", "token"]]]]]]]]]]], - -["def", "read-list-entries", ["fn", ["rdr", "start", "end"], - ["let", ["tok", ["rdr-peek", "rdr"]], - ["if", "tok", - ["if", ["=", "end", "tok"], - ["`", []], - ["cons", ["read-form", "rdr"], - ["read-list-entries", "rdr", "start", "end"]]], - ["throw", ["str", ["`", "expected "], "end", ["`", ", got EOF"]]]]]]], - -["def", "read-list", ["fn", ["rdr", "start", "end"], - ["let", ["token", ["rdr-next", "rdr"]], - ["if", ["=", "start", "token"], - ["let", ["lst", ["read-list-entries", "rdr", "start", "end"]], - ["do", - ["rdr-next", "rdr"], - "lst"]], - ["throw", ["str", ["`", "expected "], "start"]]]]]], - -["def", "read-form", ["fn", ["rdr"], - ["let", ["token", ["rdr-peek", "rdr"]], - ["if", ["=", ["`", "'"], "token"], - ["do", - ["rdr-next", "rdr"], - ["list", ["symbol", ["`", "quote"]], ["read-form", "rdr"]]], - ["if", ["=", ["`", "`"], "token"], - ["do", - ["rdr-next", "rdr"], - ["list", ["symbol", ["`", "quasiquote"]], ["read-form", "rdr"]]], - ["if", ["=", ["`", "~"], "token"], - ["do", - ["rdr-next", "rdr"], - ["list", ["symbol", ["`", "unquote"]], ["read-form", "rdr"]]], - ["if", ["=", ["`", "~@"], "token"], - ["do", - ["rdr-next", "rdr"], - ["list", ["symbol", ["`", "splice-unquote"]], ["read-form", "rdr"]]], - ["if", ["=", ["`", "^"], "token"], - ["do", - ["rdr-next", "rdr"], - ["let", ["meta", ["read-form", "rdr"]], - ["list", ["symbol", ["`", "with-meta"]], ["read-form", "rdr"], "meta"]]], - ["if", ["=", ["`", "@"], "token"], - ["do", - ["rdr-next", "rdr"], - ["list", ["symbol", ["`", "deref"]], ["read-form", "rdr"]]], - - ["if", ["=", ["`", ")"], "token"], - ["throw", ["`", "unexpected ')'"]], - ["if", ["=", ["`", "("], "token"], - ["read-list", "rdr", ["`", "("], ["`", ")"]], - - ["if", ["=", ["`", "]"], "token"], - ["throw", ["`", "unexpected ']'"]], - ["if", ["=", ["`", "["], "token"], - ["vectorl", ["read-list", "rdr", ["`", "["], ["`", "]"]]], - - ["if", ["=", ["`", "}"], "token"], - ["throw", ["`", "unexpected '}'"]], - ["if", ["=", ["`", "{"], "token"], - ["apply", "hash-map", ["read-list", "rdr", ["`", "{"], ["`", "}"]]], - - ["read-atom", "rdr"]]]]]]]]]]]]]]]], - -["def", "read-str", ["fn", ["strn"], - ["let", ["tokens", ["tokenize", "strn"], - "rdr", ["rdr-new", "tokens"]], - ["if", ["empty?", "tokens"], - null, - ["read-form", "rdr"]]]]], - -null -] +["do", + +["def", "rdr-new", ["fn", ["tokens"], + ["hash-map", ["`", "tokens"], "tokens", + ["`", "position"], 0]]], + +["def", "rdr-next", ["fn", ["rdr"], + ["let", ["pos", ["get", "rdr", ["`", "position"]], + "val", ["get", ["get", "rdr", ["`", "tokens"]], "pos"]], + ["do", + ["assoc!", "rdr", ["`", "position"], ["+", 1, "pos"]], + "val"]]]], + +["def", "rdr-peek", ["fn", ["rdr"], + ["let", ["pos", ["get", "rdr", ["`", "position"]]], + ["get", ["get", "rdr", ["`", "tokens"]], "pos"]]]], + + +["def", "re-matches", ["fn", ["re", "strn", "acc"], + ["let", ["match", [".", "re", ["`", "exec"], "strn"], + "g1", ["get", "match", 1]], + ["if", ["=", "g1", ["`", ""]], + "acc", + ["re-matches", "re", "strn", ["concat", "acc", "g1"]]]]]], + +["def", "tokenize", ["fn", ["strn"], + ["let", ["re-str", ["`", "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)"], + "re", ["RegExp", "re-str", ["`", "g"]]], + [".", + ["re-matches", "re", "strn", ["`", []]], + ["`", "filter"], + ["fn", ["x"], ["not", ["=", ["get", "x", 0], + ["`", ";"]]]]]]]], + +["def", "read-atom", ["fn", ["rdr"], + ["let", ["token", ["rdr-next", "rdr"]], + ["if", [".", "token", ["`", "match"], ["RegExp", ["`", "^-?[0-9]+$"]]], + ["parseInt", "token", 10], + ["if", [".", "token", ["`", "match"], ["RegExp", ["`", "^\"(?:\\\\.|[^\\\\\"])*\"$"]]], + [".", + ["slice", "token", 1, ["-", ["count", "token"], 1]], + ["`", "replace"], ["RegExp", ["`", "\\\\(.)"], ["`", "g"]], + ["fn", ["_", "c"], + ["if", ["=", "c", ["`", "n"]], + ["`", "\n"], + "c"]]], + ["if", ["=", ["`", "\""], ["get", "token", 0]], + ["throw", ["`", "expected '\"', got EOF"]], + ["if", ["=", ["`", ":"], ["get", "token", 0]], + ["keyword", ["slice", "token", 1]], + ["if", ["=", ["`", "nil"], "token"], + null, + ["if", ["=", ["`", "true"], "token"], + true, + ["if", ["=", ["`", "false"], "token"], + false, + ["symbol", "token"]]]]]]]]]]], + +["def", "read-list-entries", ["fn", ["rdr", "start", "end"], + ["let", ["tok", ["rdr-peek", "rdr"]], + ["if", "tok", + ["if", ["=", "end", "tok"], + ["`", []], + ["cons", ["read-form", "rdr"], + ["read-list-entries", "rdr", "start", "end"]]], + ["throw", ["str", ["`", "expected "], "end", ["`", ", got EOF"]]]]]]], + +["def", "read-list", ["fn", ["rdr", "start", "end"], + ["let", ["token", ["rdr-next", "rdr"]], + ["if", ["=", "start", "token"], + ["let", ["lst", ["read-list-entries", "rdr", "start", "end"]], + ["do", + ["rdr-next", "rdr"], + "lst"]], + ["throw", ["str", ["`", "expected "], "start"]]]]]], + +["def", "read-form", ["fn", ["rdr"], + ["let", ["token", ["rdr-peek", "rdr"]], + ["if", ["=", ["`", "'"], "token"], + ["do", + ["rdr-next", "rdr"], + ["list", ["symbol", ["`", "quote"]], ["read-form", "rdr"]]], + ["if", ["=", ["`", "`"], "token"], + ["do", + ["rdr-next", "rdr"], + ["list", ["symbol", ["`", "quasiquote"]], ["read-form", "rdr"]]], + ["if", ["=", ["`", "~"], "token"], + ["do", + ["rdr-next", "rdr"], + ["list", ["symbol", ["`", "unquote"]], ["read-form", "rdr"]]], + ["if", ["=", ["`", "~@"], "token"], + ["do", + ["rdr-next", "rdr"], + ["list", ["symbol", ["`", "splice-unquote"]], ["read-form", "rdr"]]], + ["if", ["=", ["`", "^"], "token"], + ["do", + ["rdr-next", "rdr"], + ["let", ["meta", ["read-form", "rdr"]], + ["list", ["symbol", ["`", "with-meta"]], ["read-form", "rdr"], "meta"]]], + ["if", ["=", ["`", "@"], "token"], + ["do", + ["rdr-next", "rdr"], + ["list", ["symbol", ["`", "deref"]], ["read-form", "rdr"]]], + + ["if", ["=", ["`", ")"], "token"], + ["throw", ["`", "unexpected ')'"]], + ["if", ["=", ["`", "("], "token"], + ["read-list", "rdr", ["`", "("], ["`", ")"]], + + ["if", ["=", ["`", "]"], "token"], + ["throw", ["`", "unexpected ']'"]], + ["if", ["=", ["`", "["], "token"], + ["vectorl", ["read-list", "rdr", ["`", "["], ["`", "]"]]], + + ["if", ["=", ["`", "}"], "token"], + ["throw", ["`", "unexpected '}'"]], + ["if", ["=", ["`", "{"], "token"], + ["apply", "hash-map", ["read-list", "rdr", ["`", "{"], ["`", "}"]]], + + ["read-atom", "rdr"]]]]]]]]]]]]]]]], + +["def", "read-str", ["fn", ["strn"], + ["let", ["tokens", ["tokenize", "strn"], + "rdr", ["rdr-new", "tokens"]], + ["if", ["empty?", "tokens"], + null, + ["read-form", "rdr"]]]]], + +null +] diff --git a/impls/miniMAL/run b/impls/miniMAL/run index db4875f09f..a853b26b6f 100755 --- a/impls/miniMAL/run +++ b/impls/miniMAL/run @@ -1,3 +1,3 @@ -#!/bin/bash -cd $(dirname $0) -exec miniMAL ./${STEP:-stepA_mal}.json "${@}" +#!/bin/bash +cd $(dirname $0) +exec miniMAL ./${STEP:-stepA_mal}.json "${@}" diff --git a/impls/miniMAL/step0_repl.json b/impls/miniMAL/step0_repl.json index ca4cdf1bbf..15851cba99 100644 --- a/impls/miniMAL/step0_repl.json +++ b/impls/miniMAL/step0_repl.json @@ -1,22 +1,22 @@ -["do", - - -["load", ["`", "miniMAL-core.json"]], - -["def", "READ", ["fn", ["strng"], - "strng"]], - -["def", "EVAL", ["fn", ["ast", "env"], - "ast"]], - -["def", "PRINT", ["fn", ["exp"], - "exp"]], - -["def", "rep", ["fn", ["strng"], - ["PRINT", ["EVAL", ["READ", "strng"], null]]]], - -["repl", ["`", "user> "], "rep"], - -null - -] +["do", + + +["load", ["`", "miniMAL-core.json"]], + +["def", "READ", ["fn", ["strng"], + "strng"]], + +["def", "EVAL", ["fn", ["ast", "env"], + "ast"]], + +["def", "PRINT", ["fn", ["exp"], + "exp"]], + +["def", "rep", ["fn", ["strng"], + ["PRINT", ["EVAL", ["READ", "strng"], null]]]], + +["repl", ["`", "user> "], "rep"], + +null + +] diff --git a/impls/miniMAL/step1_read_print.json b/impls/miniMAL/step1_read_print.json index c8e3d6129a..c6127eb685 100644 --- a/impls/miniMAL/step1_read_print.json +++ b/impls/miniMAL/step1_read_print.json @@ -1,27 +1,27 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], - -["def", "READ", ["fn", ["strng"], - ["read-str", "strng"]]], - -["def", "EVAL", ["fn", ["ast", "env"], - "ast"]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], null]], - ["catch", "exc", - ["str", ["`", "Error: "], "exc"]]]]], - -["repl", ["`", "user> "], "rep"], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], + +["def", "READ", ["fn", ["strng"], + ["read-str", "strng"]]], + +["def", "EVAL", ["fn", ["ast", "env"], + "ast"]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], null]], + ["catch", "exc", + ["str", ["`", "Error: "], "exc"]]]]], + +["repl", ["`", "user> "], "rep"], + +null + +] diff --git a/impls/miniMAL/step2_eval.json b/impls/miniMAL/step2_eval.json index 6ca9e8b95f..bd95dce111 100644 --- a/impls/miniMAL/step2_eval.json +++ b/impls/miniMAL/step2_eval.json @@ -1,62 +1,62 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], - -["def", "READ", ["fn", ["strng"], - ["read-str", "strng"]]], - -["def", "eval-ast", ["fn", ["ast", "env"], - ["if", ["symbol?", "ast"], - ["let", ["sym", ["get", "ast", ["`", "val"]]], - ["if", ["contains?", "env", "sym"], - ["get", "env", "sym"], - ["throw", ["str", ["`", "'"], "sym", ["`", "' not found"]]]]], - ["if", ["list?", "ast"], - ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], - ["if", ["vector?", "ast"], - ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], - ["if", ["map?", "ast"], - ["let", ["new-hm", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], ["set", "new-hm", - "k", - ["EVAL", ["get", "ast", "k"], "env"]]], - ["keys", "ast"]], - "new-hm"]], - "ast"]]]]]], - -["def", "EVAL", ["fn", ["ast", "env"], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["if", ["empty?", "ast"], - "ast", - ["let", ["el", ["eval-ast", "ast", "env"], - "f", ["first", "el"], - "args", ["rest", "el"]], - ["apply", "f", "args"]]]]]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - - -["def", "repl-env", - ["hash-map", - ["`", "+"], "+", - ["`", "-"], "-", - ["`", "*"], "*", - ["`", "/"], ["fn", ["a", "b"], ["parseInt", ["/", "a", "b"]]]]], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], - ["catch", "exc", - ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], - -["repl", ["`", "user> "], "rep"], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], + +["def", "READ", ["fn", ["strng"], + ["read-str", "strng"]]], + +["def", "eval-ast", ["fn", ["ast", "env"], + ["if", ["symbol?", "ast"], + ["let", ["sym", ["get", "ast", ["`", "val"]]], + ["if", ["contains?", "env", "sym"], + ["get", "env", "sym"], + ["throw", ["str", ["`", "'"], "sym", ["`", "' not found"]]]]], + ["if", ["list?", "ast"], + ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], + ["if", ["vector?", "ast"], + ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], + ["if", ["map?", "ast"], + ["let", ["new-hm", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], ["set", "new-hm", + "k", + ["EVAL", ["get", "ast", "k"], "env"]]], + ["keys", "ast"]], + "new-hm"]], + "ast"]]]]]], + +["def", "EVAL", ["fn", ["ast", "env"], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["if", ["empty?", "ast"], + "ast", + ["let", ["el", ["eval-ast", "ast", "env"], + "f", ["first", "el"], + "args", ["rest", "el"]], + ["apply", "f", "args"]]]]]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + + +["def", "repl-env", + ["hash-map", + ["`", "+"], "+", + ["`", "-"], "-", + ["`", "*"], "*", + ["`", "/"], ["fn", ["a", "b"], ["parseInt", ["/", "a", "b"]]]]], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], + ["catch", "exc", + ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], + +["repl", ["`", "user> "], "rep"], + +null + +] diff --git a/impls/miniMAL/step3_env.json b/impls/miniMAL/step3_env.json index 7c0b6b35df..a6aa39e30b 100644 --- a/impls/miniMAL/step3_env.json +++ b/impls/miniMAL/step3_env.json @@ -1,76 +1,76 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], -["load", ["`", "env.json"]], - -["def", "READ", ["fn", ["strng"], - ["read-str", "strng"]]], - -["def", "eval-ast", ["fn", ["ast", "env"], - ["if", ["symbol?", "ast"], - ["env-get", "env", "ast"], - ["if", ["list?", "ast"], - ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], - ["if", ["vector?", "ast"], - ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], - ["if", ["map?", "ast"], - ["let", ["new-hm", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], ["set", "new-hm", - "k", - ["EVAL", ["get", "ast", "k"], "env"]]], - ["keys", "ast"]], - "new-hm"]], - "ast"]]]]]], - -["def", "LET", ["fn", ["env", "args"], - ["if", [">", ["count", "args"], 0], - ["do", - ["env-set", "env", ["nth", "args", 0], - ["EVAL", ["nth", "args", 1], "env"]], - ["LET", "env", ["rest", ["rest", "args"]]]]]]], - -["def", "EVAL", ["fn", ["ast", "env"], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["if", ["empty?", "ast"], - "ast", - ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], - ["if", ["=", ["`", "def!"], "a0"], - ["env-set", "env", ["nth", "ast", 1], - ["EVAL", ["nth", "ast", 2], "env"]], - ["if", ["=", ["`", "let*"], "a0"], - ["let", ["let-env", ["env-new", "env"]], - ["do", - ["LET", "let-env", ["nth", "ast", 1]], - ["EVAL", ["nth", "ast", 2], "let-env"]]], - ["let", ["el", ["eval-ast", "ast", "env"], - "f", ["first", "el"], - "args", ["rest", "el"]], - ["apply", "f", "args"]]]]]]]]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - - -["def", "repl-env", ["env-new"]], -["env-set", "repl-env", ["symbol", ["`", "+"]], "+"], -["env-set", "repl-env", ["symbol", ["`", "-"]], "-"], -["env-set", "repl-env", ["symbol", ["`", "*"]], "*"], -["def", "div", ["fn", ["a", "b"], ["parseInt", ["/", "a", "b"]]]], -["env-set", "repl-env", ["symbol", ["`", "/"]], "div"], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], - ["catch", "exc", - ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], - -["repl", ["`", "user> "], "rep"], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], +["load", ["`", "env.json"]], + +["def", "READ", ["fn", ["strng"], + ["read-str", "strng"]]], + +["def", "eval-ast", ["fn", ["ast", "env"], + ["if", ["symbol?", "ast"], + ["env-get", "env", "ast"], + ["if", ["list?", "ast"], + ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], + ["if", ["vector?", "ast"], + ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], + ["if", ["map?", "ast"], + ["let", ["new-hm", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], ["set", "new-hm", + "k", + ["EVAL", ["get", "ast", "k"], "env"]]], + ["keys", "ast"]], + "new-hm"]], + "ast"]]]]]], + +["def", "LET", ["fn", ["env", "args"], + ["if", [">", ["count", "args"], 0], + ["do", + ["env-set", "env", ["nth", "args", 0], + ["EVAL", ["nth", "args", 1], "env"]], + ["LET", "env", ["rest", ["rest", "args"]]]]]]], + +["def", "EVAL", ["fn", ["ast", "env"], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["if", ["empty?", "ast"], + "ast", + ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], + ["if", ["=", ["`", "def!"], "a0"], + ["env-set", "env", ["nth", "ast", 1], + ["EVAL", ["nth", "ast", 2], "env"]], + ["if", ["=", ["`", "let*"], "a0"], + ["let", ["let-env", ["env-new", "env"]], + ["do", + ["LET", "let-env", ["nth", "ast", 1]], + ["EVAL", ["nth", "ast", 2], "let-env"]]], + ["let", ["el", ["eval-ast", "ast", "env"], + "f", ["first", "el"], + "args", ["rest", "el"]], + ["apply", "f", "args"]]]]]]]]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + + +["def", "repl-env", ["env-new"]], +["env-set", "repl-env", ["symbol", ["`", "+"]], "+"], +["env-set", "repl-env", ["symbol", ["`", "-"]], "-"], +["env-set", "repl-env", ["symbol", ["`", "*"]], "*"], +["def", "div", ["fn", ["a", "b"], ["parseInt", ["/", "a", "b"]]]], +["env-set", "repl-env", ["symbol", ["`", "/"]], "div"], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], + ["catch", "exc", + ["str", ["`", "Error: "], [".", "exc", ["`", "toString"]]]]]]], + +["repl", ["`", "user> "], "rep"], + +null + +] diff --git a/impls/miniMAL/step4_if_fn_do.json b/impls/miniMAL/step4_if_fn_do.json index 3cbaa67c13..f04cedaabc 100644 --- a/impls/miniMAL/step4_if_fn_do.json +++ b/impls/miniMAL/step4_if_fn_do.json @@ -1,97 +1,97 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], -["load", ["`", "env.json"]], -["load", ["`", "core.json"]], - -["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], - -["def", "eval-ast", ["fn", ["ast", "env"], - ["if", ["symbol?", "ast"], - ["env-get", "env", "ast"], - ["if", ["list?", "ast"], - ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], - ["if", ["vector?", "ast"], - ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], - ["if", ["map?", "ast"], - ["let", ["new-hm", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], ["set", "new-hm", - "k", - ["EVAL", ["get", "ast", "k"], "env"]]], - ["keys", "ast"]], - "new-hm"]], - "ast"]]]]]], - -["def", "LET", ["fn", ["env", "args"], - ["if", [">", ["count", "args"], 0], - ["do", - ["env-set", "env", ["nth", "args", 0], - ["EVAL", ["nth", "args", 1], "env"]], - ["LET", "env", ["rest", ["rest", "args"]]]]]]], - -["def", "EVAL", ["fn", ["ast", "env"], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["if", ["empty?", "ast"], - "ast", - ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], - ["if", ["=", ["`", "def!"], "a0"], - ["env-set", "env", ["nth", "ast", 1], - ["EVAL", ["nth", "ast", 2], "env"]], - ["if", ["=", ["`", "let*"], "a0"], - ["let", ["let-env", ["env-new", "env"]], - ["do", - ["LET", "let-env", ["nth", "ast", 1]], - ["EVAL", ["nth", "ast", 2], "let-env"]]], - ["if", ["=", ["`", "do"], "a0"], - ["let", ["el", ["eval-ast", ["rest", "ast"], "env"]], - ["nth", "el", ["-", ["count", "el"], 1]]], - ["if", ["=", ["`", "if"], "a0"], - ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], - ["if", ["or", ["=", "cond", null], ["=", "cond", false]], - ["if", [">", ["count", "ast"], 3], - ["EVAL", ["nth", "ast", 3], "env"], - null], - ["EVAL", ["nth", "ast", 2], "env"]]], - ["if", ["=", ["`", "fn*"], "a0"], - ["fn", ["&", "args"], - ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], - ["EVAL", ["nth", "ast", 2], "e"]]], - ["let", ["el", ["eval-ast", "ast", "env"], - "f", ["first", "el"], - "args", ["rest", "el"]], - ["apply", "f", "args"]]]]]]]]]]]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - - -["def", "repl-env", ["env-new"]], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], - ["catch", "exc", - ["str", ["`", "Error: "], - ["if", ["isa", "exc", "Error"], - [".", "exc", ["`", "toString"]], - ["pr-str", "exc", true]]]]]]], - -["`", "core.mal: defined using miniMAL"], -["map", ["fn", ["k"], ["env-set", "repl-env", - ["symbol", "k"], - ["get", "core-ns", "k"]]], - ["keys", "core-ns"]], - -["`", "core.mal: defined using mal itself"], -["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], - -["repl", ["`", "user> "], "rep"], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], +["load", ["`", "env.json"]], +["load", ["`", "core.json"]], + +["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], + +["def", "eval-ast", ["fn", ["ast", "env"], + ["if", ["symbol?", "ast"], + ["env-get", "env", "ast"], + ["if", ["list?", "ast"], + ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], + ["if", ["vector?", "ast"], + ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], + ["if", ["map?", "ast"], + ["let", ["new-hm", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], ["set", "new-hm", + "k", + ["EVAL", ["get", "ast", "k"], "env"]]], + ["keys", "ast"]], + "new-hm"]], + "ast"]]]]]], + +["def", "LET", ["fn", ["env", "args"], + ["if", [">", ["count", "args"], 0], + ["do", + ["env-set", "env", ["nth", "args", 0], + ["EVAL", ["nth", "args", 1], "env"]], + ["LET", "env", ["rest", ["rest", "args"]]]]]]], + +["def", "EVAL", ["fn", ["ast", "env"], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["if", ["empty?", "ast"], + "ast", + ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], + ["if", ["=", ["`", "def!"], "a0"], + ["env-set", "env", ["nth", "ast", 1], + ["EVAL", ["nth", "ast", 2], "env"]], + ["if", ["=", ["`", "let*"], "a0"], + ["let", ["let-env", ["env-new", "env"]], + ["do", + ["LET", "let-env", ["nth", "ast", 1]], + ["EVAL", ["nth", "ast", 2], "let-env"]]], + ["if", ["=", ["`", "do"], "a0"], + ["let", ["el", ["eval-ast", ["rest", "ast"], "env"]], + ["nth", "el", ["-", ["count", "el"], 1]]], + ["if", ["=", ["`", "if"], "a0"], + ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], + ["if", ["or", ["=", "cond", null], ["=", "cond", false]], + ["if", [">", ["count", "ast"], 3], + ["EVAL", ["nth", "ast", 3], "env"], + null], + ["EVAL", ["nth", "ast", 2], "env"]]], + ["if", ["=", ["`", "fn*"], "a0"], + ["fn", ["&", "args"], + ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], + ["EVAL", ["nth", "ast", 2], "e"]]], + ["let", ["el", ["eval-ast", "ast", "env"], + "f", ["first", "el"], + "args", ["rest", "el"]], + ["apply", "f", "args"]]]]]]]]]]]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + + +["def", "repl-env", ["env-new"]], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], + ["catch", "exc", + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], + +["`", "core.mal: defined using miniMAL"], +["map", ["fn", ["k"], ["env-set", "repl-env", + ["symbol", "k"], + ["get", "core-ns", "k"]]], + ["keys", "core-ns"]], + +["`", "core.mal: defined using mal itself"], +["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], + +["repl", ["`", "user> "], "rep"], + +null + +] diff --git a/impls/miniMAL/step5_tco.json b/impls/miniMAL/step5_tco.json index 6a6f4e0ebf..444b45db59 100644 --- a/impls/miniMAL/step5_tco.json +++ b/impls/miniMAL/step5_tco.json @@ -1,105 +1,105 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], -["load", ["`", "env.json"]], -["load", ["`", "core.json"]], - -["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], - -["def", "eval-ast", ["fn", ["ast", "env"], - ["if", ["symbol?", "ast"], - ["env-get", "env", "ast"], - ["if", ["list?", "ast"], - ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], - ["if", ["vector?", "ast"], - ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], - ["if", ["map?", "ast"], - ["let", ["new-hm", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], ["set", "new-hm", - "k", - ["EVAL", ["get", "ast", "k"], "env"]]], - ["keys", "ast"]], - "new-hm"]], - "ast"]]]]]], - -["def", "LET", ["fn", ["env", "args"], - ["if", [">", ["count", "args"], 0], - ["do", - ["env-set", "env", ["nth", "args", 0], - ["EVAL", ["nth", "args", 1], "env"]], - ["LET", "env", ["rest", ["rest", "args"]]]]]]], - -["def", "EVAL", ["fn", ["ast", "env"], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["if", ["empty?", "ast"], - "ast", - ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], - ["if", ["=", ["`", "def!"], "a0"], - ["env-set", "env", ["nth", "ast", 1], - ["EVAL", ["nth", "ast", 2], "env"]], - ["if", ["=", ["`", "let*"], "a0"], - ["let", ["let-env", ["env-new", "env"]], - ["do", - ["LET", "let-env", ["nth", "ast", 1]], - ["EVAL", ["nth", "ast", 2], "let-env"]]], - ["if", ["=", ["`", "do"], "a0"], - ["do", - ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], - ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], - ["if", ["=", ["`", "if"], "a0"], - ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], - ["if", ["or", ["=", "cond", null], ["=", "cond", false]], - ["if", [">", ["count", "ast"], 3], - ["EVAL", ["nth", "ast", 3], "env"], - null], - ["EVAL", ["nth", "ast", 2], "env"]]], - ["if", ["=", ["`", "fn*"], "a0"], - ["malfunc", - ["fn", ["&", "args"], - ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], - ["EVAL", ["nth", "ast", 2], "e"]]], - ["nth", "ast", 2], "env", ["nth", "ast", 1]], - ["let", ["el", ["eval-ast", "ast", "env"], - "f", ["first", "el"], - "args", ["rest", "el"]], - ["if", ["malfunc?", "f"], - ["EVAL", ["get", "f", ["`", "ast"]], - ["env-new", ["get", "f", ["`", "env"]], - ["get", "f", ["`", "params"]], - "args"]], - ["apply", "f", "args"]]]]]]]]]]]]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - - -["def", "repl-env", ["env-new"]], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], - ["catch", "exc", - ["str", ["`", "Error: "], - ["if", ["isa", "exc", "Error"], - [".", "exc", ["`", "toString"]], - ["pr-str", "exc", true]]]]]]], - -["`", "core.mal: defined using miniMAL"], -["map", ["fn", ["k"], ["env-set", "repl-env", - ["symbol", "k"], - ["get", "core-ns", "k"]]], - ["keys", "core-ns"]], - -["`", "core.mal: defined using mal itself"], -["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], - -["repl", ["`", "user> "], "rep"], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], +["load", ["`", "env.json"]], +["load", ["`", "core.json"]], + +["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], + +["def", "eval-ast", ["fn", ["ast", "env"], + ["if", ["symbol?", "ast"], + ["env-get", "env", "ast"], + ["if", ["list?", "ast"], + ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], + ["if", ["vector?", "ast"], + ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], + ["if", ["map?", "ast"], + ["let", ["new-hm", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], ["set", "new-hm", + "k", + ["EVAL", ["get", "ast", "k"], "env"]]], + ["keys", "ast"]], + "new-hm"]], + "ast"]]]]]], + +["def", "LET", ["fn", ["env", "args"], + ["if", [">", ["count", "args"], 0], + ["do", + ["env-set", "env", ["nth", "args", 0], + ["EVAL", ["nth", "args", 1], "env"]], + ["LET", "env", ["rest", ["rest", "args"]]]]]]], + +["def", "EVAL", ["fn", ["ast", "env"], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["if", ["empty?", "ast"], + "ast", + ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], + ["if", ["=", ["`", "def!"], "a0"], + ["env-set", "env", ["nth", "ast", 1], + ["EVAL", ["nth", "ast", 2], "env"]], + ["if", ["=", ["`", "let*"], "a0"], + ["let", ["let-env", ["env-new", "env"]], + ["do", + ["LET", "let-env", ["nth", "ast", 1]], + ["EVAL", ["nth", "ast", 2], "let-env"]]], + ["if", ["=", ["`", "do"], "a0"], + ["do", + ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], + ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], + ["if", ["=", ["`", "if"], "a0"], + ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], + ["if", ["or", ["=", "cond", null], ["=", "cond", false]], + ["if", [">", ["count", "ast"], 3], + ["EVAL", ["nth", "ast", 3], "env"], + null], + ["EVAL", ["nth", "ast", 2], "env"]]], + ["if", ["=", ["`", "fn*"], "a0"], + ["malfunc", + ["fn", ["&", "args"], + ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], + ["EVAL", ["nth", "ast", 2], "e"]]], + ["nth", "ast", 2], "env", ["nth", "ast", 1]], + ["let", ["el", ["eval-ast", "ast", "env"], + "f", ["first", "el"], + "args", ["rest", "el"]], + ["if", ["malfunc?", "f"], + ["EVAL", ["get", "f", ["`", "ast"]], + ["env-new", ["get", "f", ["`", "env"]], + ["get", "f", ["`", "params"]], + "args"]], + ["apply", "f", "args"]]]]]]]]]]]]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + + +["def", "repl-env", ["env-new"]], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], + ["catch", "exc", + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], + +["`", "core.mal: defined using miniMAL"], +["map", ["fn", ["k"], ["env-set", "repl-env", + ["symbol", "k"], + ["get", "core-ns", "k"]]], + ["keys", "core-ns"]], + +["`", "core.mal: defined using mal itself"], +["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], + +["repl", ["`", "user> "], "rep"], + +null + +] diff --git a/impls/miniMAL/step6_file.json b/impls/miniMAL/step6_file.json index 71091b65a8..e7e775bbf2 100644 --- a/impls/miniMAL/step6_file.json +++ b/impls/miniMAL/step6_file.json @@ -1,112 +1,112 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], -["load", ["`", "env.json"]], -["load", ["`", "core.json"]], - -["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], - -["def", "eval-ast", ["fn", ["ast", "env"], - ["if", ["symbol?", "ast"], - ["env-get", "env", "ast"], - ["if", ["list?", "ast"], - ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], - ["if", ["vector?", "ast"], - ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], - ["if", ["map?", "ast"], - ["let", ["new-hm", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], ["set", "new-hm", - "k", - ["EVAL", ["get", "ast", "k"], "env"]]], - ["keys", "ast"]], - "new-hm"]], - "ast"]]]]]], - -["def", "LET", ["fn", ["env", "args"], - ["if", [">", ["count", "args"], 0], - ["do", - ["env-set", "env", ["nth", "args", 0], - ["EVAL", ["nth", "args", 1], "env"]], - ["LET", "env", ["rest", ["rest", "args"]]]]]]], - -["def", "EVAL", ["fn", ["ast", "env"], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["if", ["empty?", "ast"], - "ast", - ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], - ["if", ["=", ["`", "def!"], "a0"], - ["env-set", "env", ["nth", "ast", 1], - ["EVAL", ["nth", "ast", 2], "env"]], - ["if", ["=", ["`", "let*"], "a0"], - ["let", ["let-env", ["env-new", "env"]], - ["do", - ["LET", "let-env", ["nth", "ast", 1]], - ["EVAL", ["nth", "ast", 2], "let-env"]]], - ["if", ["=", ["`", "do"], "a0"], - ["do", - ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], - ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], - ["if", ["=", ["`", "if"], "a0"], - ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], - ["if", ["or", ["=", "cond", null], ["=", "cond", false]], - ["if", [">", ["count", "ast"], 3], - ["EVAL", ["nth", "ast", 3], "env"], - null], - ["EVAL", ["nth", "ast", 2], "env"]]], - ["if", ["=", ["`", "fn*"], "a0"], - ["malfunc", - ["fn", ["&", "args"], - ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], - ["EVAL", ["nth", "ast", 2], "e"]]], - ["nth", "ast", 2], "env", ["nth", "ast", 1]], - ["let", ["el", ["eval-ast", "ast", "env"], - "f", ["first", "el"], - "args", ["rest", "el"]], - ["if", ["malfunc?", "f"], - ["EVAL", ["get", "f", ["`", "ast"]], - ["env-new", ["get", "f", ["`", "env"]], - ["get", "f", ["`", "params"]], - "args"]], - ["apply", "f", "args"]]]]]]]]]]]]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - - -["def", "repl-env", ["env-new"]], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], - ["catch", "exc", - ["str", ["`", "Error: "], - ["if", ["isa", "exc", "Error"], - [".", "exc", ["`", "toString"]], - ["pr-str", "exc", true]]]]]]], - -["`", "core.mal: defined using miniMAL"], -["map", ["fn", ["k"], ["env-set", "repl-env", - ["symbol", "k"], - ["get", "core-ns", "k"]]], - ["keys", "core-ns"]], -["env-set", "repl-env", ["symbol", ["`", "eval"]], - ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], -["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], - ["slice", "ARGS", 1]], - -["`", "core.mal: defined using mal itself"], -["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], -["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], - -["if", ["not", ["empty?", "ARGS"]], - ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], - ["repl", ["`", "user> "], "rep"]], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], +["load", ["`", "env.json"]], +["load", ["`", "core.json"]], + +["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], + +["def", "eval-ast", ["fn", ["ast", "env"], + ["if", ["symbol?", "ast"], + ["env-get", "env", "ast"], + ["if", ["list?", "ast"], + ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], + ["if", ["vector?", "ast"], + ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], + ["if", ["map?", "ast"], + ["let", ["new-hm", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], ["set", "new-hm", + "k", + ["EVAL", ["get", "ast", "k"], "env"]]], + ["keys", "ast"]], + "new-hm"]], + "ast"]]]]]], + +["def", "LET", ["fn", ["env", "args"], + ["if", [">", ["count", "args"], 0], + ["do", + ["env-set", "env", ["nth", "args", 0], + ["EVAL", ["nth", "args", 1], "env"]], + ["LET", "env", ["rest", ["rest", "args"]]]]]]], + +["def", "EVAL", ["fn", ["ast", "env"], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["if", ["empty?", "ast"], + "ast", + ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], + ["if", ["=", ["`", "def!"], "a0"], + ["env-set", "env", ["nth", "ast", 1], + ["EVAL", ["nth", "ast", 2], "env"]], + ["if", ["=", ["`", "let*"], "a0"], + ["let", ["let-env", ["env-new", "env"]], + ["do", + ["LET", "let-env", ["nth", "ast", 1]], + ["EVAL", ["nth", "ast", 2], "let-env"]]], + ["if", ["=", ["`", "do"], "a0"], + ["do", + ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], + ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], + ["if", ["=", ["`", "if"], "a0"], + ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], + ["if", ["or", ["=", "cond", null], ["=", "cond", false]], + ["if", [">", ["count", "ast"], 3], + ["EVAL", ["nth", "ast", 3], "env"], + null], + ["EVAL", ["nth", "ast", 2], "env"]]], + ["if", ["=", ["`", "fn*"], "a0"], + ["malfunc", + ["fn", ["&", "args"], + ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], + ["EVAL", ["nth", "ast", 2], "e"]]], + ["nth", "ast", 2], "env", ["nth", "ast", 1]], + ["let", ["el", ["eval-ast", "ast", "env"], + "f", ["first", "el"], + "args", ["rest", "el"]], + ["if", ["malfunc?", "f"], + ["EVAL", ["get", "f", ["`", "ast"]], + ["env-new", ["get", "f", ["`", "env"]], + ["get", "f", ["`", "params"]], + "args"]], + ["apply", "f", "args"]]]]]]]]]]]]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + + +["def", "repl-env", ["env-new"]], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], + ["catch", "exc", + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], + +["`", "core.mal: defined using miniMAL"], +["map", ["fn", ["k"], ["env-set", "repl-env", + ["symbol", "k"], + ["get", "core-ns", "k"]]], + ["keys", "core-ns"]], +["env-set", "repl-env", ["symbol", ["`", "eval"]], + ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], +["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], + ["slice", "ARGS", 1]], + +["`", "core.mal: defined using mal itself"], +["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], +["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], + +["if", ["not", ["empty?", "ARGS"]], + ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], + ["repl", ["`", "user> "], "rep"]], + +null + +] diff --git a/impls/miniMAL/step7_quote.json b/impls/miniMAL/step7_quote.json index eeac76ce29..8316f71e06 100644 --- a/impls/miniMAL/step7_quote.json +++ b/impls/miniMAL/step7_quote.json @@ -1,145 +1,145 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], -["load", ["`", "env.json"]], -["load", ["`", "core.json"]], - -["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], - -["def", "starts-with", ["fn", ["ast", "sym"], - ["and", ["not", ["empty?", "ast"]], - ["let", ["a0", ["first", "ast"]], - ["and", ["symbol?", "a0"], - ["=", "sym", ["get", "a0", ["`", "val"]]]]]]]], - -["def", "quasiquote-loop", ["fn", ["xs"], - ["if", ["empty?", "xs"], - ["list"], - ["let", ["elt", ["first", "xs"], - "acc", ["quasiquote-loop", ["rest", "xs"]]], - ["if", ["and", ["list?", "elt"], - ["starts-with", "elt", ["`", "splice-unquote"]]], - ["list", ["symbol", ["`", "concat"]], ["nth", "elt", 1], "acc"], - ["list", ["symbol", ["`", "cons"]], ["quasiquote", "elt"], "acc"]]]]]], - -["def", "quasiquote", ["fn", ["ast"], - ["if", ["list?", "ast"], - ["if", ["starts-with", "ast", ["`", "unquote"]], - ["nth", "ast", 1], - ["quasiquote-loop", "ast"]], - ["if", ["vector?", "ast"], - ["list", ["symbol", ["`", "vec"]], ["quasiquote-loop", "ast"]], - ["if", ["or", ["map?", "ast"], ["symbol?", "ast"]], - ["list", ["symbol", ["`", "quote"]], "ast"], - "ast"]]]]], - -["def", "eval-ast", ["fn", ["ast", "env"], - ["if", ["symbol?", "ast"], - ["env-get", "env", "ast"], - ["if", ["list?", "ast"], - ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], - ["if", ["vector?", "ast"], - ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], - ["if", ["map?", "ast"], - ["let", ["new-hm", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], ["set", "new-hm", - "k", - ["EVAL", ["get", "ast", "k"], "env"]]], - ["keys", "ast"]], - "new-hm"]], - "ast"]]]]]], - -["def", "LET", ["fn", ["env", "args"], - ["if", [">", ["count", "args"], 0], - ["do", - ["env-set", "env", ["nth", "args", 0], - ["EVAL", ["nth", "args", 1], "env"]], - ["LET", "env", ["rest", ["rest", "args"]]]]]]], - -["def", "EVAL", ["fn", ["ast", "env"], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["if", ["empty?", "ast"], - "ast", - ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], - ["if", ["=", ["`", "def!"], "a0"], - ["env-set", "env", ["nth", "ast", 1], - ["EVAL", ["nth", "ast", 2], "env"]], - ["if", ["=", ["`", "let*"], "a0"], - ["let", ["let-env", ["env-new", "env"]], - ["do", - ["LET", "let-env", ["nth", "ast", 1]], - ["EVAL", ["nth", "ast", 2], "let-env"]]], - ["if", ["=", ["`", "quote"], "a0"], - ["nth", "ast", 1], - ["if", ["=", ["`", "quasiquoteexpand"], "a0"], - ["quasiquote", ["nth", "ast", 1]], - ["if", ["=", ["`", "quasiquote"], "a0"], - ["EVAL", ["quasiquote", ["nth", "ast", 1]], "env"], - ["if", ["=", ["`", "do"], "a0"], - ["do", - ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], - ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], - ["if", ["=", ["`", "if"], "a0"], - ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], - ["if", ["or", ["=", "cond", null], ["=", "cond", false]], - ["if", [">", ["count", "ast"], 3], - ["EVAL", ["nth", "ast", 3], "env"], - null], - ["EVAL", ["nth", "ast", 2], "env"]]], - ["if", ["=", ["`", "fn*"], "a0"], - ["malfunc", - ["fn", ["&", "args"], - ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], - ["EVAL", ["nth", "ast", 2], "e"]]], - ["nth", "ast", 2], "env", ["nth", "ast", 1]], - ["let", ["el", ["eval-ast", "ast", "env"], - "f", ["first", "el"], - "args", ["rest", "el"]], - ["if", ["malfunc?", "f"], - ["EVAL", ["get", "f", ["`", "ast"]], - ["env-new", ["get", "f", ["`", "env"]], - ["get", "f", ["`", "params"]], - "args"]], - ["apply", "f", "args"]]]]]]]]]]]]]]]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - - -["def", "repl-env", ["env-new"]], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], - ["catch", "exc", - ["str", ["`", "Error: "], - ["if", ["isa", "exc", "Error"], - [".", "exc", ["`", "toString"]], - ["pr-str", "exc", true]]]]]]], - -["`", "core.mal: defined using miniMAL"], -["map", ["fn", ["k"], ["env-set", "repl-env", - ["symbol", "k"], - ["get", "core-ns", "k"]]], - ["keys", "core-ns"]], -["env-set", "repl-env", ["symbol", ["`", "eval"]], - ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], -["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], - ["slice", "ARGS", 1]], - -["`", "core.mal: defined using mal itself"], -["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], -["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], - -["if", ["not", ["empty?", "ARGS"]], - ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], - ["repl", ["`", "user> "], "rep"]], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], +["load", ["`", "env.json"]], +["load", ["`", "core.json"]], + +["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], + +["def", "starts-with", ["fn", ["ast", "sym"], + ["and", ["not", ["empty?", "ast"]], + ["let", ["a0", ["first", "ast"]], + ["and", ["symbol?", "a0"], + ["=", "sym", ["get", "a0", ["`", "val"]]]]]]]], + +["def", "quasiquote-loop", ["fn", ["xs"], + ["if", ["empty?", "xs"], + ["list"], + ["let", ["elt", ["first", "xs"], + "acc", ["quasiquote-loop", ["rest", "xs"]]], + ["if", ["and", ["list?", "elt"], + ["starts-with", "elt", ["`", "splice-unquote"]]], + ["list", ["symbol", ["`", "concat"]], ["nth", "elt", 1], "acc"], + ["list", ["symbol", ["`", "cons"]], ["quasiquote", "elt"], "acc"]]]]]], + +["def", "quasiquote", ["fn", ["ast"], + ["if", ["list?", "ast"], + ["if", ["starts-with", "ast", ["`", "unquote"]], + ["nth", "ast", 1], + ["quasiquote-loop", "ast"]], + ["if", ["vector?", "ast"], + ["list", ["symbol", ["`", "vec"]], ["quasiquote-loop", "ast"]], + ["if", ["or", ["map?", "ast"], ["symbol?", "ast"]], + ["list", ["symbol", ["`", "quote"]], "ast"], + "ast"]]]]], + +["def", "eval-ast", ["fn", ["ast", "env"], + ["if", ["symbol?", "ast"], + ["env-get", "env", "ast"], + ["if", ["list?", "ast"], + ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], + ["if", ["vector?", "ast"], + ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], + ["if", ["map?", "ast"], + ["let", ["new-hm", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], ["set", "new-hm", + "k", + ["EVAL", ["get", "ast", "k"], "env"]]], + ["keys", "ast"]], + "new-hm"]], + "ast"]]]]]], + +["def", "LET", ["fn", ["env", "args"], + ["if", [">", ["count", "args"], 0], + ["do", + ["env-set", "env", ["nth", "args", 0], + ["EVAL", ["nth", "args", 1], "env"]], + ["LET", "env", ["rest", ["rest", "args"]]]]]]], + +["def", "EVAL", ["fn", ["ast", "env"], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["if", ["empty?", "ast"], + "ast", + ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], + ["if", ["=", ["`", "def!"], "a0"], + ["env-set", "env", ["nth", "ast", 1], + ["EVAL", ["nth", "ast", 2], "env"]], + ["if", ["=", ["`", "let*"], "a0"], + ["let", ["let-env", ["env-new", "env"]], + ["do", + ["LET", "let-env", ["nth", "ast", 1]], + ["EVAL", ["nth", "ast", 2], "let-env"]]], + ["if", ["=", ["`", "quote"], "a0"], + ["nth", "ast", 1], + ["if", ["=", ["`", "quasiquoteexpand"], "a0"], + ["quasiquote", ["nth", "ast", 1]], + ["if", ["=", ["`", "quasiquote"], "a0"], + ["EVAL", ["quasiquote", ["nth", "ast", 1]], "env"], + ["if", ["=", ["`", "do"], "a0"], + ["do", + ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], + ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], + ["if", ["=", ["`", "if"], "a0"], + ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], + ["if", ["or", ["=", "cond", null], ["=", "cond", false]], + ["if", [">", ["count", "ast"], 3], + ["EVAL", ["nth", "ast", 3], "env"], + null], + ["EVAL", ["nth", "ast", 2], "env"]]], + ["if", ["=", ["`", "fn*"], "a0"], + ["malfunc", + ["fn", ["&", "args"], + ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], + ["EVAL", ["nth", "ast", 2], "e"]]], + ["nth", "ast", 2], "env", ["nth", "ast", 1]], + ["let", ["el", ["eval-ast", "ast", "env"], + "f", ["first", "el"], + "args", ["rest", "el"]], + ["if", ["malfunc?", "f"], + ["EVAL", ["get", "f", ["`", "ast"]], + ["env-new", ["get", "f", ["`", "env"]], + ["get", "f", ["`", "params"]], + "args"]], + ["apply", "f", "args"]]]]]]]]]]]]]]]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + + +["def", "repl-env", ["env-new"]], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], + ["catch", "exc", + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], + +["`", "core.mal: defined using miniMAL"], +["map", ["fn", ["k"], ["env-set", "repl-env", + ["symbol", "k"], + ["get", "core-ns", "k"]]], + ["keys", "core-ns"]], +["env-set", "repl-env", ["symbol", ["`", "eval"]], + ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], +["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], + ["slice", "ARGS", 1]], + +["`", "core.mal: defined using mal itself"], +["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], +["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], + +["if", ["not", ["empty?", "ARGS"]], + ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], + ["repl", ["`", "user> "], "rep"]], + +null + +] diff --git a/impls/miniMAL/step8_macros.json b/impls/miniMAL/step8_macros.json index 2a362d7963..df28a4c7ea 100644 --- a/impls/miniMAL/step8_macros.json +++ b/impls/miniMAL/step8_macros.json @@ -1,170 +1,170 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], -["load", ["`", "env.json"]], -["load", ["`", "core.json"]], - -["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], - -["def", "starts-with", ["fn", ["ast", "sym"], - ["and", ["not", ["empty?", "ast"]], - ["let", ["a0", ["first", "ast"]], - ["and", ["symbol?", "a0"], - ["=", "sym", ["get", "a0", ["`", "val"]]]]]]]], - -["def", "quasiquote-loop", ["fn", ["xs"], - ["if", ["empty?", "xs"], - ["list"], - ["let", ["elt", ["first", "xs"], - "acc", ["quasiquote-loop", ["rest", "xs"]]], - ["if", ["and", ["list?", "elt"], - ["starts-with", "elt", ["`", "splice-unquote"]]], - ["list", ["symbol", ["`", "concat"]], ["nth", "elt", 1], "acc"], - ["list", ["symbol", ["`", "cons"]], ["quasiquote", "elt"], "acc"]]]]]], - -["def", "quasiquote", ["fn", ["ast"], - ["if", ["list?", "ast"], - ["if", ["starts-with", "ast", ["`", "unquote"]], - ["nth", "ast", 1], - ["quasiquote-loop", "ast"]], - ["if", ["vector?", "ast"], - ["list", ["symbol", ["`", "vec"]], ["quasiquote-loop", "ast"]], - ["if", ["or", ["map?", "ast"], ["symbol?", "ast"]], - ["list", ["symbol", ["`", "quote"]], "ast"], - "ast"]]]]], - -["def", "macro?", ["fn", ["ast", "env"], - ["and", ["list?", "ast"], - ["symbol?", ["first", "ast"]], - ["not", ["=", null, ["env-find", "env", ["first", "ast"]]]], - ["let", ["fn", ["env-get", "env", ["first", "ast"]]], - ["and", ["malfunc?", "fn"], - ["get", "fn", ["`", "macro?"]]]]]]], - -["def", "macroexpand", ["fn", ["ast", "env"], - ["if", ["macro?", "ast", "env"], - ["let", ["mac", ["get", ["env-get", "env", ["first", "ast"]], ["`", "fn"]]], - ["macroexpand", ["apply", "mac", ["rest", "ast"]], "env"]], - "ast"]]], - -["def", "eval-ast", ["fn", ["ast", "env"], - ["if", ["symbol?", "ast"], - ["env-get", "env", "ast"], - ["if", ["list?", "ast"], - ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], - ["if", ["vector?", "ast"], - ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], - ["if", ["map?", "ast"], - ["let", ["new-hm", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], ["set", "new-hm", - "k", - ["EVAL", ["get", "ast", "k"], "env"]]], - ["keys", "ast"]], - "new-hm"]], - "ast"]]]]]], - -["def", "LET", ["fn", ["env", "args"], - ["if", [">", ["count", "args"], 0], - ["do", - ["env-set", "env", ["nth", "args", 0], - ["EVAL", ["nth", "args", 1], "env"]], - ["LET", "env", ["rest", ["rest", "args"]]]]]]], - -["def", "EVAL", ["fn", ["ast", "env"], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["let", ["ast", ["macroexpand", "ast", "env"]], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["if", ["empty?", "ast"], - "ast", - ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], - ["if", ["=", ["`", "def!"], "a0"], - ["env-set", "env", ["nth", "ast", 1], - ["EVAL", ["nth", "ast", 2], "env"]], - ["if", ["=", ["`", "let*"], "a0"], - ["let", ["let-env", ["env-new", "env"]], - ["do", - ["LET", "let-env", ["nth", "ast", 1]], - ["EVAL", ["nth", "ast", 2], "let-env"]]], - ["if", ["=", ["`", "quote"], "a0"], - ["nth", "ast", 1], - ["if", ["=", ["`", "quasiquoteexpand"], "a0"], - ["quasiquote", ["nth", "ast", 1]], - ["if", ["=", ["`", "quasiquote"], "a0"], - ["EVAL", ["quasiquote", ["nth", "ast", 1]], "env"], - ["if", ["=", ["`", "defmacro!"], "a0"], - ["let", ["func", ["EVAL", ["nth", "ast", 2], "env"]], - ["do", - ["set", "func", ["`", "macro?"], true], - ["env-set", "env", ["nth", "ast", 1], "func"]]], - ["if", ["=", ["`", "macroexpand"], "a0"], - ["macroexpand", ["nth", "ast", 1], "env"], - ["if", ["=", ["`", "do"], "a0"], - ["do", - ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], - ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], - ["if", ["=", ["`", "if"], "a0"], - ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], - ["if", ["or", ["=", "cond", null], ["=", "cond", false]], - ["if", [">", ["count", "ast"], 3], - ["EVAL", ["nth", "ast", 3], "env"], - null], - ["EVAL", ["nth", "ast", 2], "env"]]], - ["if", ["=", ["`", "fn*"], "a0"], - ["malfunc", - ["fn", ["&", "args"], - ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], - ["EVAL", ["nth", "ast", 2], "e"]]], - ["nth", "ast", 2], "env", ["nth", "ast", 1]], - ["let", ["el", ["eval-ast", "ast", "env"], - "f", ["first", "el"], - "args", ["rest", "el"]], - ["if", ["malfunc?", "f"], - ["EVAL", ["get", "f", ["`", "ast"]], - ["env-new", ["get", "f", ["`", "env"]], - ["get", "f", ["`", "params"]], - "args"]], - ["apply", "f", "args"]]]]]]]]]]]]]]]]]]]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - - -["def", "repl-env", ["env-new"]], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], - ["catch", "exc", - ["str", ["`", "Error: "], - ["if", ["isa", "exc", "Error"], - [".", "exc", ["`", "toString"]], - ["pr-str", "exc", true]]]]]]], - -["`", "core.mal: defined using miniMAL"], -["map", ["fn", ["k"], ["env-set", "repl-env", - ["symbol", "k"], - ["get", "core-ns", "k"]]], - ["keys", "core-ns"]], -["env-set", "repl-env", ["symbol", ["`", "eval"]], - ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], -["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], - ["slice", "ARGS", 1]], - -["`", "core.mal: defined using mal itself"], -["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], -["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], -["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)))))))"]], - -["if", ["not", ["empty?", "ARGS"]], - ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], - ["repl", ["`", "user> "], "rep"]], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], +["load", ["`", "env.json"]], +["load", ["`", "core.json"]], + +["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], + +["def", "starts-with", ["fn", ["ast", "sym"], + ["and", ["not", ["empty?", "ast"]], + ["let", ["a0", ["first", "ast"]], + ["and", ["symbol?", "a0"], + ["=", "sym", ["get", "a0", ["`", "val"]]]]]]]], + +["def", "quasiquote-loop", ["fn", ["xs"], + ["if", ["empty?", "xs"], + ["list"], + ["let", ["elt", ["first", "xs"], + "acc", ["quasiquote-loop", ["rest", "xs"]]], + ["if", ["and", ["list?", "elt"], + ["starts-with", "elt", ["`", "splice-unquote"]]], + ["list", ["symbol", ["`", "concat"]], ["nth", "elt", 1], "acc"], + ["list", ["symbol", ["`", "cons"]], ["quasiquote", "elt"], "acc"]]]]]], + +["def", "quasiquote", ["fn", ["ast"], + ["if", ["list?", "ast"], + ["if", ["starts-with", "ast", ["`", "unquote"]], + ["nth", "ast", 1], + ["quasiquote-loop", "ast"]], + ["if", ["vector?", "ast"], + ["list", ["symbol", ["`", "vec"]], ["quasiquote-loop", "ast"]], + ["if", ["or", ["map?", "ast"], ["symbol?", "ast"]], + ["list", ["symbol", ["`", "quote"]], "ast"], + "ast"]]]]], + +["def", "macro?", ["fn", ["ast", "env"], + ["and", ["list?", "ast"], + ["symbol?", ["first", "ast"]], + ["not", ["=", null, ["env-find", "env", ["first", "ast"]]]], + ["let", ["fn", ["env-get", "env", ["first", "ast"]]], + ["and", ["malfunc?", "fn"], + ["get", "fn", ["`", "macro?"]]]]]]], + +["def", "macroexpand", ["fn", ["ast", "env"], + ["if", ["macro?", "ast", "env"], + ["let", ["mac", ["get", ["env-get", "env", ["first", "ast"]], ["`", "fn"]]], + ["macroexpand", ["apply", "mac", ["rest", "ast"]], "env"]], + "ast"]]], + +["def", "eval-ast", ["fn", ["ast", "env"], + ["if", ["symbol?", "ast"], + ["env-get", "env", "ast"], + ["if", ["list?", "ast"], + ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], + ["if", ["vector?", "ast"], + ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], + ["if", ["map?", "ast"], + ["let", ["new-hm", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], ["set", "new-hm", + "k", + ["EVAL", ["get", "ast", "k"], "env"]]], + ["keys", "ast"]], + "new-hm"]], + "ast"]]]]]], + +["def", "LET", ["fn", ["env", "args"], + ["if", [">", ["count", "args"], 0], + ["do", + ["env-set", "env", ["nth", "args", 0], + ["EVAL", ["nth", "args", 1], "env"]], + ["LET", "env", ["rest", ["rest", "args"]]]]]]], + +["def", "EVAL", ["fn", ["ast", "env"], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["let", ["ast", ["macroexpand", "ast", "env"]], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["if", ["empty?", "ast"], + "ast", + ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], + ["if", ["=", ["`", "def!"], "a0"], + ["env-set", "env", ["nth", "ast", 1], + ["EVAL", ["nth", "ast", 2], "env"]], + ["if", ["=", ["`", "let*"], "a0"], + ["let", ["let-env", ["env-new", "env"]], + ["do", + ["LET", "let-env", ["nth", "ast", 1]], + ["EVAL", ["nth", "ast", 2], "let-env"]]], + ["if", ["=", ["`", "quote"], "a0"], + ["nth", "ast", 1], + ["if", ["=", ["`", "quasiquoteexpand"], "a0"], + ["quasiquote", ["nth", "ast", 1]], + ["if", ["=", ["`", "quasiquote"], "a0"], + ["EVAL", ["quasiquote", ["nth", "ast", 1]], "env"], + ["if", ["=", ["`", "defmacro!"], "a0"], + ["let", ["func", ["EVAL", ["nth", "ast", 2], "env"]], + ["do", + ["set", "func", ["`", "macro?"], true], + ["env-set", "env", ["nth", "ast", 1], "func"]]], + ["if", ["=", ["`", "macroexpand"], "a0"], + ["macroexpand", ["nth", "ast", 1], "env"], + ["if", ["=", ["`", "do"], "a0"], + ["do", + ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], + ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], + ["if", ["=", ["`", "if"], "a0"], + ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], + ["if", ["or", ["=", "cond", null], ["=", "cond", false]], + ["if", [">", ["count", "ast"], 3], + ["EVAL", ["nth", "ast", 3], "env"], + null], + ["EVAL", ["nth", "ast", 2], "env"]]], + ["if", ["=", ["`", "fn*"], "a0"], + ["malfunc", + ["fn", ["&", "args"], + ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], + ["EVAL", ["nth", "ast", 2], "e"]]], + ["nth", "ast", 2], "env", ["nth", "ast", 1]], + ["let", ["el", ["eval-ast", "ast", "env"], + "f", ["first", "el"], + "args", ["rest", "el"]], + ["if", ["malfunc?", "f"], + ["EVAL", ["get", "f", ["`", "ast"]], + ["env-new", ["get", "f", ["`", "env"]], + ["get", "f", ["`", "params"]], + "args"]], + ["apply", "f", "args"]]]]]]]]]]]]]]]]]]]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + + +["def", "repl-env", ["env-new"]], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], + ["catch", "exc", + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], + +["`", "core.mal: defined using miniMAL"], +["map", ["fn", ["k"], ["env-set", "repl-env", + ["symbol", "k"], + ["get", "core-ns", "k"]]], + ["keys", "core-ns"]], +["env-set", "repl-env", ["symbol", ["`", "eval"]], + ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], +["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], + ["slice", "ARGS", 1]], + +["`", "core.mal: defined using mal itself"], +["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], +["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], +["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)))))))"]], + +["if", ["not", ["empty?", "ARGS"]], + ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], + ["repl", ["`", "user> "], "rep"]], + +null + +] diff --git a/impls/miniMAL/step9_try.json b/impls/miniMAL/step9_try.json index a66146c39c..1fcb421b04 100644 --- a/impls/miniMAL/step9_try.json +++ b/impls/miniMAL/step9_try.json @@ -1,183 +1,183 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], -["load", ["`", "env.json"]], -["load", ["`", "core.json"]], - -["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], - -["def", "starts-with", ["fn", ["ast", "sym"], - ["and", ["not", ["empty?", "ast"]], - ["let", ["a0", ["first", "ast"]], - ["and", ["symbol?", "a0"], - ["=", "sym", ["get", "a0", ["`", "val"]]]]]]]], - -["def", "quasiquote-loop", ["fn", ["xs"], - ["if", ["empty?", "xs"], - ["list"], - ["let", ["elt", ["first", "xs"], - "acc", ["quasiquote-loop", ["rest", "xs"]]], - ["if", ["and", ["list?", "elt"], - ["starts-with", "elt", ["`", "splice-unquote"]]], - ["list", ["symbol", ["`", "concat"]], ["nth", "elt", 1], "acc"], - ["list", ["symbol", ["`", "cons"]], ["quasiquote", "elt"], "acc"]]]]]], - -["def", "quasiquote", ["fn", ["ast"], - ["if", ["list?", "ast"], - ["if", ["starts-with", "ast", ["`", "unquote"]], - ["nth", "ast", 1], - ["quasiquote-loop", "ast"]], - ["if", ["vector?", "ast"], - ["list", ["symbol", ["`", "vec"]], ["quasiquote-loop", "ast"]], - ["if", ["or", ["map?", "ast"], ["symbol?", "ast"]], - ["list", ["symbol", ["`", "quote"]], "ast"], - "ast"]]]]], - -["def", "macro?", ["fn", ["ast", "env"], - ["and", ["list?", "ast"], - ["symbol?", ["first", "ast"]], - ["not", ["=", null, ["env-find", "env", ["first", "ast"]]]], - ["let", ["fn", ["env-get", "env", ["first", "ast"]]], - ["and", ["malfunc?", "fn"], - ["get", "fn", ["`", "macro?"]]]]]]], - -["def", "macroexpand", ["fn", ["ast", "env"], - ["if", ["macro?", "ast", "env"], - ["let", ["mac", ["get", ["env-get", "env", ["first", "ast"]], ["`", "fn"]]], - ["macroexpand", ["apply", "mac", ["rest", "ast"]], "env"]], - "ast"]]], - -["def", "eval-ast", ["fn", ["ast", "env"], - ["if", ["symbol?", "ast"], - ["env-get", "env", "ast"], - ["if", ["list?", "ast"], - ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], - ["if", ["vector?", "ast"], - ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], - ["if", ["map?", "ast"], - ["let", ["new-hm", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], ["set", "new-hm", - "k", - ["EVAL", ["get", "ast", "k"], "env"]]], - ["keys", "ast"]], - "new-hm"]], - "ast"]]]]]], - -["def", "LET", ["fn", ["env", "args"], - ["if", [">", ["count", "args"], 0], - ["do", - ["env-set", "env", ["nth", "args", 0], - ["EVAL", ["nth", "args", 1], "env"]], - ["LET", "env", ["rest", ["rest", "args"]]]]]]], - -["def", "EVAL", ["fn", ["ast", "env"], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["let", ["ast", ["macroexpand", "ast", "env"]], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["if", ["empty?", "ast"], - "ast", - ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], - ["if", ["=", ["`", "def!"], "a0"], - ["env-set", "env", ["nth", "ast", 1], - ["EVAL", ["nth", "ast", 2], "env"]], - ["if", ["=", ["`", "let*"], "a0"], - ["let", ["let-env", ["env-new", "env"]], - ["do", - ["LET", "let-env", ["nth", "ast", 1]], - ["EVAL", ["nth", "ast", 2], "let-env"]]], - ["if", ["=", ["`", "quote"], "a0"], - ["nth", "ast", 1], - ["if", ["=", ["`", "quasiquoteexpand"], "a0"], - ["quasiquote", ["nth", "ast", 1]], - ["if", ["=", ["`", "quasiquote"], "a0"], - ["EVAL", ["quasiquote", ["nth", "ast", 1]], "env"], - ["if", ["=", ["`", "defmacro!"], "a0"], - ["let", ["func", ["EVAL", ["nth", "ast", 2], "env"]], - ["do", - ["set", "func", ["`", "macro?"], true], - ["env-set", "env", ["nth", "ast", 1], "func"]]], - ["if", ["=", ["`", "macroexpand"], "a0"], - ["macroexpand", ["nth", "ast", 1], "env"], - ["if", ["=", ["`", "try*"], "a0"], - ["if", ["and", [">", ["count", "ast"], 2], - ["=", ["`", "catch*"], - ["get", ["nth", ["nth", "ast", 2], 0], - ["`", "val"]]]], - ["try", - ["EVAL", ["nth", "ast", 1], "env"], - ["catch", "exc", - ["EVAL", ["nth", ["nth", "ast", 2], 2], - ["env-new", "env", - ["list", ["nth", ["nth", "ast", 2], 1]], - ["list", "exc"]]]]], - ["EVAL", ["nth", "ast", 1], "env"]], - ["if", ["=", ["`", "do"], "a0"], - ["do", - ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], - ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], - ["if", ["=", ["`", "if"], "a0"], - ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], - ["if", ["or", ["=", "cond", null], ["=", "cond", false]], - ["if", [">", ["count", "ast"], 3], - ["EVAL", ["nth", "ast", 3], "env"], - null], - ["EVAL", ["nth", "ast", 2], "env"]]], - ["if", ["=", ["`", "fn*"], "a0"], - ["malfunc", - ["fn", ["&", "args"], - ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], - ["EVAL", ["nth", "ast", 2], "e"]]], - ["nth", "ast", 2], "env", ["nth", "ast", 1]], - ["let", ["el", ["eval-ast", "ast", "env"], - "f", ["first", "el"], - "args", ["rest", "el"]], - ["if", ["malfunc?", "f"], - ["EVAL", ["get", "f", ["`", "ast"]], - ["env-new", ["get", "f", ["`", "env"]], - ["get", "f", ["`", "params"]], - "args"]], - ["apply", "f", "args"]]]]]]]]]]]]]]]]]]]]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - - -["def", "repl-env", ["env-new"]], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], - ["catch", "exc", - ["str", ["`", "Error: "], - ["if", ["isa", "exc", "Error"], - [".", "exc", ["`", "toString"]], - ["pr-str", "exc", true]]]]]]], - -["`", "core.mal: defined using miniMAL"], -["map", ["fn", ["k"], ["env-set", "repl-env", - ["symbol", "k"], - ["get", "core-ns", "k"]]], - ["keys", "core-ns"]], -["env-set", "repl-env", ["symbol", ["`", "eval"]], - ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], -["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], - ["slice", "ARGS", 1]], - -["`", "core.mal: defined using mal itself"], -["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], -["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], -["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)))))))"]], - -["if", ["not", ["empty?", "ARGS"]], - ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], - ["repl", ["`", "user> "], "rep"]], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], +["load", ["`", "env.json"]], +["load", ["`", "core.json"]], + +["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], + +["def", "starts-with", ["fn", ["ast", "sym"], + ["and", ["not", ["empty?", "ast"]], + ["let", ["a0", ["first", "ast"]], + ["and", ["symbol?", "a0"], + ["=", "sym", ["get", "a0", ["`", "val"]]]]]]]], + +["def", "quasiquote-loop", ["fn", ["xs"], + ["if", ["empty?", "xs"], + ["list"], + ["let", ["elt", ["first", "xs"], + "acc", ["quasiquote-loop", ["rest", "xs"]]], + ["if", ["and", ["list?", "elt"], + ["starts-with", "elt", ["`", "splice-unquote"]]], + ["list", ["symbol", ["`", "concat"]], ["nth", "elt", 1], "acc"], + ["list", ["symbol", ["`", "cons"]], ["quasiquote", "elt"], "acc"]]]]]], + +["def", "quasiquote", ["fn", ["ast"], + ["if", ["list?", "ast"], + ["if", ["starts-with", "ast", ["`", "unquote"]], + ["nth", "ast", 1], + ["quasiquote-loop", "ast"]], + ["if", ["vector?", "ast"], + ["list", ["symbol", ["`", "vec"]], ["quasiquote-loop", "ast"]], + ["if", ["or", ["map?", "ast"], ["symbol?", "ast"]], + ["list", ["symbol", ["`", "quote"]], "ast"], + "ast"]]]]], + +["def", "macro?", ["fn", ["ast", "env"], + ["and", ["list?", "ast"], + ["symbol?", ["first", "ast"]], + ["not", ["=", null, ["env-find", "env", ["first", "ast"]]]], + ["let", ["fn", ["env-get", "env", ["first", "ast"]]], + ["and", ["malfunc?", "fn"], + ["get", "fn", ["`", "macro?"]]]]]]], + +["def", "macroexpand", ["fn", ["ast", "env"], + ["if", ["macro?", "ast", "env"], + ["let", ["mac", ["get", ["env-get", "env", ["first", "ast"]], ["`", "fn"]]], + ["macroexpand", ["apply", "mac", ["rest", "ast"]], "env"]], + "ast"]]], + +["def", "eval-ast", ["fn", ["ast", "env"], + ["if", ["symbol?", "ast"], + ["env-get", "env", "ast"], + ["if", ["list?", "ast"], + ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], + ["if", ["vector?", "ast"], + ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], + ["if", ["map?", "ast"], + ["let", ["new-hm", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], ["set", "new-hm", + "k", + ["EVAL", ["get", "ast", "k"], "env"]]], + ["keys", "ast"]], + "new-hm"]], + "ast"]]]]]], + +["def", "LET", ["fn", ["env", "args"], + ["if", [">", ["count", "args"], 0], + ["do", + ["env-set", "env", ["nth", "args", 0], + ["EVAL", ["nth", "args", 1], "env"]], + ["LET", "env", ["rest", ["rest", "args"]]]]]]], + +["def", "EVAL", ["fn", ["ast", "env"], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["let", ["ast", ["macroexpand", "ast", "env"]], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["if", ["empty?", "ast"], + "ast", + ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], + ["if", ["=", ["`", "def!"], "a0"], + ["env-set", "env", ["nth", "ast", 1], + ["EVAL", ["nth", "ast", 2], "env"]], + ["if", ["=", ["`", "let*"], "a0"], + ["let", ["let-env", ["env-new", "env"]], + ["do", + ["LET", "let-env", ["nth", "ast", 1]], + ["EVAL", ["nth", "ast", 2], "let-env"]]], + ["if", ["=", ["`", "quote"], "a0"], + ["nth", "ast", 1], + ["if", ["=", ["`", "quasiquoteexpand"], "a0"], + ["quasiquote", ["nth", "ast", 1]], + ["if", ["=", ["`", "quasiquote"], "a0"], + ["EVAL", ["quasiquote", ["nth", "ast", 1]], "env"], + ["if", ["=", ["`", "defmacro!"], "a0"], + ["let", ["func", ["EVAL", ["nth", "ast", 2], "env"]], + ["do", + ["set", "func", ["`", "macro?"], true], + ["env-set", "env", ["nth", "ast", 1], "func"]]], + ["if", ["=", ["`", "macroexpand"], "a0"], + ["macroexpand", ["nth", "ast", 1], "env"], + ["if", ["=", ["`", "try*"], "a0"], + ["if", ["and", [">", ["count", "ast"], 2], + ["=", ["`", "catch*"], + ["get", ["nth", ["nth", "ast", 2], 0], + ["`", "val"]]]], + ["try", + ["EVAL", ["nth", "ast", 1], "env"], + ["catch", "exc", + ["EVAL", ["nth", ["nth", "ast", 2], 2], + ["env-new", "env", + ["list", ["nth", ["nth", "ast", 2], 1]], + ["list", "exc"]]]]], + ["EVAL", ["nth", "ast", 1], "env"]], + ["if", ["=", ["`", "do"], "a0"], + ["do", + ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], + ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], + ["if", ["=", ["`", "if"], "a0"], + ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], + ["if", ["or", ["=", "cond", null], ["=", "cond", false]], + ["if", [">", ["count", "ast"], 3], + ["EVAL", ["nth", "ast", 3], "env"], + null], + ["EVAL", ["nth", "ast", 2], "env"]]], + ["if", ["=", ["`", "fn*"], "a0"], + ["malfunc", + ["fn", ["&", "args"], + ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], + ["EVAL", ["nth", "ast", 2], "e"]]], + ["nth", "ast", 2], "env", ["nth", "ast", 1]], + ["let", ["el", ["eval-ast", "ast", "env"], + "f", ["first", "el"], + "args", ["rest", "el"]], + ["if", ["malfunc?", "f"], + ["EVAL", ["get", "f", ["`", "ast"]], + ["env-new", ["get", "f", ["`", "env"]], + ["get", "f", ["`", "params"]], + "args"]], + ["apply", "f", "args"]]]]]]]]]]]]]]]]]]]]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + + +["def", "repl-env", ["env-new"]], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], + ["catch", "exc", + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], + +["`", "core.mal: defined using miniMAL"], +["map", ["fn", ["k"], ["env-set", "repl-env", + ["symbol", "k"], + ["get", "core-ns", "k"]]], + ["keys", "core-ns"]], +["env-set", "repl-env", ["symbol", ["`", "eval"]], + ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], +["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], + ["slice", "ARGS", 1]], + +["`", "core.mal: defined using mal itself"], +["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], +["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], +["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)))))))"]], + +["if", ["not", ["empty?", "ARGS"]], + ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], + ["repl", ["`", "user> "], "rep"]], + +null + +] diff --git a/impls/miniMAL/stepA_mal.json b/impls/miniMAL/stepA_mal.json index e5b64ed92f..1fa38b1368 100644 --- a/impls/miniMAL/stepA_mal.json +++ b/impls/miniMAL/stepA_mal.json @@ -1,186 +1,186 @@ -["do", - -["load", ["`", "miniMAL-core.json"]], -["load", ["`", "types.json"]], -["load", ["`", "reader.json"]], -["load", ["`", "printer.json"]], -["load", ["`", "env.json"]], -["load", ["`", "core.json"]], - -["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], - -["def", "starts-with", ["fn", ["ast", "sym"], - ["and", ["not", ["empty?", "ast"]], - ["let", ["a0", ["first", "ast"]], - ["and", ["symbol?", "a0"], - ["=", "sym", ["get", "a0", ["`", "val"]]]]]]]], - -["def", "quasiquote-loop", ["fn", ["xs"], - ["if", ["empty?", "xs"], - ["list"], - ["let", ["elt", ["first", "xs"], - "acc", ["quasiquote-loop", ["rest", "xs"]]], - ["if", ["and", ["list?", "elt"], - ["starts-with", "elt", ["`", "splice-unquote"]]], - ["list", ["symbol", ["`", "concat"]], ["nth", "elt", 1], "acc"], - ["list", ["symbol", ["`", "cons"]], ["quasiquote", "elt"], "acc"]]]]]], - -["def", "quasiquote", ["fn", ["ast"], - ["if", ["list?", "ast"], - ["if", ["starts-with", "ast", ["`", "unquote"]], - ["nth", "ast", 1], - ["quasiquote-loop", "ast"]], - ["if", ["vector?", "ast"], - ["list", ["symbol", ["`", "vec"]], ["quasiquote-loop", "ast"]], - ["if", ["or", ["map?", "ast"], ["symbol?", "ast"]], - ["list", ["symbol", ["`", "quote"]], "ast"], - "ast"]]]]], - -["def", "macro?", ["fn", ["ast", "env"], - ["and", ["list?", "ast"], - ["symbol?", ["first", "ast"]], - ["not", ["=", null, ["env-find", "env", ["first", "ast"]]]], - ["let", ["fn", ["env-get", "env", ["first", "ast"]]], - ["and", ["malfunc?", "fn"], - ["get", "fn", ["`", "macro?"]]]]]]], - -["def", "macroexpand", ["fn", ["ast", "env"], - ["if", ["macro?", "ast", "env"], - ["let", ["mac", ["get", ["env-get", "env", ["first", "ast"]], ["`", "fn"]]], - ["macroexpand", ["apply", "mac", ["rest", "ast"]], "env"]], - "ast"]]], - -["def", "eval-ast", ["fn", ["ast", "env"], - ["if", ["symbol?", "ast"], - ["env-get", "env", "ast"], - ["if", ["list?", "ast"], - ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], - ["if", ["vector?", "ast"], - ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], - ["if", ["map?", "ast"], - ["let", ["new-hm", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], ["set", "new-hm", - "k", - ["EVAL", ["get", "ast", "k"], "env"]]], - ["keys", "ast"]], - "new-hm"]], - "ast"]]]]]], - -["def", "LET", ["fn", ["env", "args"], - ["if", [">", ["count", "args"], 0], - ["do", - ["env-set", "env", ["nth", "args", 0], - ["EVAL", ["nth", "args", 1], "env"]], - ["LET", "env", ["rest", ["rest", "args"]]]]]]], - -["def", "EVAL", ["fn", ["ast", "env"], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["let", ["ast", ["macroexpand", "ast", "env"]], - ["if", ["not", ["list?", "ast"]], - ["eval-ast", "ast", "env"], - ["if", ["empty?", "ast"], - "ast", - ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], - ["if", ["=", ["`", "def!"], "a0"], - ["env-set", "env", ["nth", "ast", 1], - ["EVAL", ["nth", "ast", 2], "env"]], - ["if", ["=", ["`", "let*"], "a0"], - ["let", ["let-env", ["env-new", "env"]], - ["do", - ["LET", "let-env", ["nth", "ast", 1]], - ["EVAL", ["nth", "ast", 2], "let-env"]]], - ["if", ["=", ["`", "quote"], "a0"], - ["nth", "ast", 1], - ["if", ["=", ["`", "quasiquoteexpand"], "a0"], - ["quasiquote", ["nth", "ast", 1]], - ["if", ["=", ["`", "quasiquote"], "a0"], - ["EVAL", ["quasiquote", ["nth", "ast", 1]], "env"], - ["if", ["=", ["`", "defmacro!"], "a0"], - ["let", ["func", ["EVAL", ["nth", "ast", 2], "env"]], - ["do", - ["set", "func", ["`", "macro?"], true], - ["env-set", "env", ["nth", "ast", 1], "func"]]], - ["if", ["=", ["`", "macroexpand"], "a0"], - ["macroexpand", ["nth", "ast", 1], "env"], - ["if", ["=", ["`", "try*"], "a0"], - ["if", ["and", [">", ["count", "ast"], 2], - ["=", ["`", "catch*"], - ["get", ["nth", ["nth", "ast", 2], 0], - ["`", "val"]]]], - ["try", - ["EVAL", ["nth", "ast", 1], "env"], - ["catch", "exc", - ["EVAL", ["nth", ["nth", "ast", 2], 2], - ["env-new", "env", - ["list", ["nth", ["nth", "ast", 2], 1]], - ["list", "exc"]]]]], - ["EVAL", ["nth", "ast", 1], "env"]], - ["if", ["=", ["`", "do"], "a0"], - ["do", - ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], - ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], - ["if", ["=", ["`", "if"], "a0"], - ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], - ["if", ["or", ["=", "cond", null], ["=", "cond", false]], - ["if", [">", ["count", "ast"], 3], - ["EVAL", ["nth", "ast", 3], "env"], - null], - ["EVAL", ["nth", "ast", 2], "env"]]], - ["if", ["=", ["`", "fn*"], "a0"], - ["malfunc", - ["fn", ["&", "args"], - ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], - ["EVAL", ["nth", "ast", 2], "e"]]], - ["nth", "ast", 2], "env", ["nth", "ast", 1]], - ["let", ["el", ["eval-ast", "ast", "env"], - "f", ["first", "el"], - "args", ["rest", "el"]], - ["if", ["malfunc?", "f"], - ["EVAL", ["get", "f", ["`", "ast"]], - ["env-new", ["get", "f", ["`", "env"]], - ["get", "f", ["`", "params"]], - "args"]], - ["apply", "f", "args"]]]]]]]]]]]]]]]]]]]]], - -["def", "PRINT", ["fn", ["exp"], - ["pr-str", "exp", true]]], - - -["def", "repl-env", ["env-new"]], - -["def", "rep", ["fn", ["strng"], - ["try", - ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], - ["catch", "exc", - ["str", ["`", "Error: "], - ["if", ["isa", "exc", "Error"], - [".", "exc", ["`", "toString"]], - ["pr-str", "exc", true]]]]]]], - -["`", "core.mal: defined using miniMAL"], -["map", ["fn", ["k"], ["env-set", "repl-env", - ["symbol", "k"], - ["get", "core-ns", "k"]]], - ["keys", "core-ns"]], -["env-set", "repl-env", ["symbol", ["`", "eval"]], - ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], -["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], - ["slice", "ARGS", 1]], - -["`", "core.mal: defined using mal itself"], -["rep", ["`", "(def! *host-language* \"miniMAL\")"]], -["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], -["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], -["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)))))))"]], - -["if", ["not", ["empty?", "ARGS"]], - ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], - ["do", - ["rep", ["`", "(println (str \"Mal [\" *host-language* \"]\"))"]], - ["repl", ["`", "user> "], "rep"]]], - -null - -] +["do", + +["load", ["`", "miniMAL-core.json"]], +["load", ["`", "types.json"]], +["load", ["`", "reader.json"]], +["load", ["`", "printer.json"]], +["load", ["`", "env.json"]], +["load", ["`", "core.json"]], + +["def", "READ", ["fn", ["strng"], ["read-str", "strng"]]], + +["def", "starts-with", ["fn", ["ast", "sym"], + ["and", ["not", ["empty?", "ast"]], + ["let", ["a0", ["first", "ast"]], + ["and", ["symbol?", "a0"], + ["=", "sym", ["get", "a0", ["`", "val"]]]]]]]], + +["def", "quasiquote-loop", ["fn", ["xs"], + ["if", ["empty?", "xs"], + ["list"], + ["let", ["elt", ["first", "xs"], + "acc", ["quasiquote-loop", ["rest", "xs"]]], + ["if", ["and", ["list?", "elt"], + ["starts-with", "elt", ["`", "splice-unquote"]]], + ["list", ["symbol", ["`", "concat"]], ["nth", "elt", 1], "acc"], + ["list", ["symbol", ["`", "cons"]], ["quasiquote", "elt"], "acc"]]]]]], + +["def", "quasiquote", ["fn", ["ast"], + ["if", ["list?", "ast"], + ["if", ["starts-with", "ast", ["`", "unquote"]], + ["nth", "ast", 1], + ["quasiquote-loop", "ast"]], + ["if", ["vector?", "ast"], + ["list", ["symbol", ["`", "vec"]], ["quasiquote-loop", "ast"]], + ["if", ["or", ["map?", "ast"], ["symbol?", "ast"]], + ["list", ["symbol", ["`", "quote"]], "ast"], + "ast"]]]]], + +["def", "macro?", ["fn", ["ast", "env"], + ["and", ["list?", "ast"], + ["symbol?", ["first", "ast"]], + ["not", ["=", null, ["env-find", "env", ["first", "ast"]]]], + ["let", ["fn", ["env-get", "env", ["first", "ast"]]], + ["and", ["malfunc?", "fn"], + ["get", "fn", ["`", "macro?"]]]]]]], + +["def", "macroexpand", ["fn", ["ast", "env"], + ["if", ["macro?", "ast", "env"], + ["let", ["mac", ["get", ["env-get", "env", ["first", "ast"]], ["`", "fn"]]], + ["macroexpand", ["apply", "mac", ["rest", "ast"]], "env"]], + "ast"]]], + +["def", "eval-ast", ["fn", ["ast", "env"], + ["if", ["symbol?", "ast"], + ["env-get", "env", "ast"], + ["if", ["list?", "ast"], + ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"], + ["if", ["vector?", "ast"], + ["vectorl", ["map", ["fn", ["x"], ["EVAL", "x", "env"]], "ast"]], + ["if", ["map?", "ast"], + ["let", ["new-hm", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], ["set", "new-hm", + "k", + ["EVAL", ["get", "ast", "k"], "env"]]], + ["keys", "ast"]], + "new-hm"]], + "ast"]]]]]], + +["def", "LET", ["fn", ["env", "args"], + ["if", [">", ["count", "args"], 0], + ["do", + ["env-set", "env", ["nth", "args", 0], + ["EVAL", ["nth", "args", 1], "env"]], + ["LET", "env", ["rest", ["rest", "args"]]]]]]], + +["def", "EVAL", ["fn", ["ast", "env"], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["let", ["ast", ["macroexpand", "ast", "env"]], + ["if", ["not", ["list?", "ast"]], + ["eval-ast", "ast", "env"], + ["if", ["empty?", "ast"], + "ast", + ["let", ["a0", ["get", ["first", "ast"], ["`", "val"]]], + ["if", ["=", ["`", "def!"], "a0"], + ["env-set", "env", ["nth", "ast", 1], + ["EVAL", ["nth", "ast", 2], "env"]], + ["if", ["=", ["`", "let*"], "a0"], + ["let", ["let-env", ["env-new", "env"]], + ["do", + ["LET", "let-env", ["nth", "ast", 1]], + ["EVAL", ["nth", "ast", 2], "let-env"]]], + ["if", ["=", ["`", "quote"], "a0"], + ["nth", "ast", 1], + ["if", ["=", ["`", "quasiquoteexpand"], "a0"], + ["quasiquote", ["nth", "ast", 1]], + ["if", ["=", ["`", "quasiquote"], "a0"], + ["EVAL", ["quasiquote", ["nth", "ast", 1]], "env"], + ["if", ["=", ["`", "defmacro!"], "a0"], + ["let", ["func", ["EVAL", ["nth", "ast", 2], "env"]], + ["do", + ["set", "func", ["`", "macro?"], true], + ["env-set", "env", ["nth", "ast", 1], "func"]]], + ["if", ["=", ["`", "macroexpand"], "a0"], + ["macroexpand", ["nth", "ast", 1], "env"], + ["if", ["=", ["`", "try*"], "a0"], + ["if", ["and", [">", ["count", "ast"], 2], + ["=", ["`", "catch*"], + ["get", ["nth", ["nth", "ast", 2], 0], + ["`", "val"]]]], + ["try", + ["EVAL", ["nth", "ast", 1], "env"], + ["catch", "exc", + ["EVAL", ["nth", ["nth", "ast", 2], 2], + ["env-new", "env", + ["list", ["nth", ["nth", "ast", 2], 1]], + ["list", "exc"]]]]], + ["EVAL", ["nth", "ast", 1], "env"]], + ["if", ["=", ["`", "do"], "a0"], + ["do", + ["eval-ast", ["slice", "ast", 1, ["-", ["count", "ast"], 1]], "env"], + ["EVAL", ["nth", "ast", ["-", ["count", "ast"], 1]], "env"]], + ["if", ["=", ["`", "if"], "a0"], + ["let", ["cond", ["EVAL", ["nth", "ast", 1], "env"]], + ["if", ["or", ["=", "cond", null], ["=", "cond", false]], + ["if", [">", ["count", "ast"], 3], + ["EVAL", ["nth", "ast", 3], "env"], + null], + ["EVAL", ["nth", "ast", 2], "env"]]], + ["if", ["=", ["`", "fn*"], "a0"], + ["malfunc", + ["fn", ["&", "args"], + ["let", ["e", ["env-new", "env", ["nth", "ast", 1], "args"]], + ["EVAL", ["nth", "ast", 2], "e"]]], + ["nth", "ast", 2], "env", ["nth", "ast", 1]], + ["let", ["el", ["eval-ast", "ast", "env"], + "f", ["first", "el"], + "args", ["rest", "el"]], + ["if", ["malfunc?", "f"], + ["EVAL", ["get", "f", ["`", "ast"]], + ["env-new", ["get", "f", ["`", "env"]], + ["get", "f", ["`", "params"]], + "args"]], + ["apply", "f", "args"]]]]]]]]]]]]]]]]]]]]], + +["def", "PRINT", ["fn", ["exp"], + ["pr-str", "exp", true]]], + + +["def", "repl-env", ["env-new"]], + +["def", "rep", ["fn", ["strng"], + ["try", + ["PRINT", ["EVAL", ["READ", "strng"], "repl-env"]], + ["catch", "exc", + ["str", ["`", "Error: "], + ["if", ["isa", "exc", "Error"], + [".", "exc", ["`", "toString"]], + ["pr-str", "exc", true]]]]]]], + +["`", "core.mal: defined using miniMAL"], +["map", ["fn", ["k"], ["env-set", "repl-env", + ["symbol", "k"], + ["get", "core-ns", "k"]]], + ["keys", "core-ns"]], +["env-set", "repl-env", ["symbol", ["`", "eval"]], + ["fn", ["ast"], ["EVAL", "ast", "repl-env"]]], +["env-set", "repl-env", ["symbol", ["`", "*ARGV*"]], + ["slice", "ARGS", 1]], + +["`", "core.mal: defined using mal itself"], +["rep", ["`", "(def! *host-language* \"miniMAL\")"]], +["rep", ["`", "(def! not (fn* (a) (if a false true)))"]], +["rep", ["`", "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"]], +["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)))))))"]], + +["if", ["not", ["empty?", "ARGS"]], + ["rep", ["str", ["`", "(load-file \""], ["get", "ARGS", 0], ["`", "\")"]]], + ["do", + ["rep", ["`", "(println (str \"Mal [\" *host-language* \"]\"))"]], + ["repl", ["`", "user> "], "rep"]]], + +null + +] diff --git a/impls/miniMAL/tests/step5_tco.mal b/impls/miniMAL/tests/step5_tco.mal index c5ab084ce6..22441dbd9b 100644 --- a/impls/miniMAL/tests/step5_tco.mal +++ b/impls/miniMAL/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; miniMAL skipping non-TCO recursion -;; Reason: Unrecoverable stack overflow at 10,000 +;; miniMAL skipping non-TCO recursion +;; Reason: Unrecoverable stack overflow at 10,000 diff --git a/impls/miniMAL/types.json b/impls/miniMAL/types.json index 3d3e22d7bb..8a5e0403c0 100644 --- a/impls/miniMAL/types.json +++ b/impls/miniMAL/types.json @@ -1,166 +1,166 @@ -["do", - -["`", "Utility Functions"], -["def", "_cmp_seqs", ["fn", ["a", "b"], - ["if", ["not", ["=", ["count", "a"], ["count", "b"]]], - false, - ["if", ["empty?", "a"], - true, - ["if", ["equal?", ["get", "a", 0], ["get", "b", 0]], - ["_cmp_seqs", ["rest", "a"], ["rest", "b"]], - false]]]]], - -["def", "_check_hash_map_keys", ["fn", ["ks", "a", "b"], - ["if", ["empty?", "ks"], - true, - ["let", ["k", ["first", "ks"]], - ["if", ["equal?", ["get", "a", "k"], ["get", "b", "k"]], - ["_check_hash_map_keys", ["rest", "ks"], "a", "b"], - false]]]]], -["def", "_cmp_hash_maps", ["fn", ["a", "b"], - ["let", ["aks", ["keys", "a"]], - ["if", ["not", ["=", ["count", "aks"], ["count", ["keys", "b"]]]], - false, - ["_check_hash_map_keys", "aks", "a", "b"]]]]], - -["def", "equal?", ["fn", ["a", "b"], - ["if", ["sequential?", "a"], - ["if", ["sequential?", "b"], - ["_cmp_seqs", "a", "b"], - false], - ["if", ["map?", "a"], - ["if", ["map?", "b"], - ["_cmp_hash_maps", "a", "b"], - false], - ["if", ["symbol?", "a"], - ["if", ["symbol?", "b"], - ["=", ["get", "a", ["`", "val"]], ["get", "b", ["`", "val"]]], - false], - ["=", "a", "b"]]]]]], - -["def", "_clone", ["fn", ["obj"], - ["if", ["list?", "obj"], - ["slice", "obj", 0], - ["if", ["vector?", "obj"], - ["let", ["new-obj", ["slice", "obj", 0]], - ["do", - ["set", "new-obj", ["`", "__vector?__"], true], - "new-obj"]], - ["if", ["map?", "obj"], - ["let", ["new-obj", ["hash-map"]], - ["do", - ["map", ["fn", ["k"], - ["if", [".", "obj", ["`", "hasOwnProperty"], "k"], - ["set", "new-obj", "k", ["get", "obj", "k"]], - null]], - ["keys", "obj"]], - "new-obj"]], - ["if", ["malfunc?", "obj"], - ["let", ["new-obj", ["malfunc", ["get", "obj", ["`", "fn"]], - ["get", "obj", ["`", "ast"]], - ["get", "obj", ["`", "env"]], - ["get", "obj", ["`", "params"]]]], - ["do", - ["set", "new-obj", ["`", "macro?"], ["get", "obj", ["`", "macro?"]]], - ["set", "new-obj", ["`", "__meta__"], ["get", "obj", ["`", "__meta__"]]], - "new-obj"]], - ["throw", "clone of unsupported type"]]]]]]], - -["def", "clone", ["fn", ["obj"], - ["let", ["new-obj", ["_clone", "obj"]], - ["do", - [".", "Object", ["`", "defineProperty"], "new-obj", ["`", "__meta__"], - {"enumerable": false, "writable": true}], - "new-obj"]]]], - -["def", "assoc!", ["fn", ["a", "b", "c"], ["do", ["set", "a", "b", "c"], "a"]]], -["def", "assocs!", ["fn", ["hm", "kvs"], - ["if", ["empty?", "kvs"], - "hm", - ["do", - ["assoc!", "hm", ["get", "kvs", 0], ["get", "kvs", 1]], - ["assocs!", "hm", ["slice", "kvs", 2]]]]]], - - -["def", "Symbol", ["fn", [], null]], -["def", "symbol", ["fn", ["name"], - ["assoc!", ["new", "Symbol"], ["`", "val"], "name"]]], - -["def", "symbol?", ["fn", ["a"], - ["isa", "a", "Symbol"]]], - - -["def", "keyword", ["fn", ["name"], - ["if", ["keyword?", "name"], - "name", - ["str", ["`", "\u029e"], "name"]]]], - -["def", "keyword?", ["fn", ["kw"], - ["and", ["=", ["`", "[object String]"], ["classOf", "kw"]], - ["=", ["`", "\u029e"], ["get", "kw", 0]]]]], - - -["`", "Override some list defs to account for Vectors"], -["def", "sequential?", ["fn", ["a"], - [".", "Array", ["`", "isArray"], "a"]]], - -["def", "list?", ["fn", ["a"], - ["if", [".", "Array", ["`", "isArray"], "a"], - ["if", [".-", "a", ["`", "__vector?__"]], - false, - true], - false]]], - -["def", "empty?", ["fn", ["a"], - ["if", ["sequential?", "a"], - ["if", ["=", 0, [".-", "a", ["`", "length"]]], - true, - false], - ["=", "a", null]]]], - - -["def", "vectorl", ["fn", ["lst"], - ["let", ["vec", ["slice", "lst", 0]], - ["do", - ["set", "vec", ["`", "__vector?__"], true], - "vec"]]]], - -["def", "vector", ["fn", ["&", "args"], ["vectorl", "args"]]], - -["def", "vector?", ["fn", ["a"], - ["if", [".", "Array", ["`", "isArray"], "a"], - ["if", [".-", "a", ["`", "__vector?__"]], - true, - false], - false]]], - - -["def", "HashMap", ["fn", [], null]], -["def", "hash-map", ["fn", ["&", "a"], - ["assocs!", ["new", "HashMap"], "a"]]], -["def", "map?", ["fn", ["a"], - ["isa", "a", "HashMap"]]], - -["def", "MalFunc", ["fn", [], null]], -["def", "malfunc", ["fn", ["fn", "ast", "env", "params"], - ["assocs!", ["new", "MalFunc"], - ["list", ["`", "fn"], "fn", - ["`", "ast"], "ast", - ["`", "env"], "env", - ["`", "params"], "params", - ["`", "macro?"], false]]]], - -["def", "malfunc?", ["fn", ["a"], - ["isa", "a", "MalFunc"]]], - -["def", "Atom", ["fn", [], null]], -["def", "atom", ["fn", ["a"], - ["let", ["atm", ["new", "Atom"]], - ["do", - ["set", "atm", ["`", "val"], "a"], - "atm"]]]], -["def", "atom?", ["fn", ["a"], - ["isa", "a", "Atom"]]], - -null -] +["do", + +["`", "Utility Functions"], +["def", "_cmp_seqs", ["fn", ["a", "b"], + ["if", ["not", ["=", ["count", "a"], ["count", "b"]]], + false, + ["if", ["empty?", "a"], + true, + ["if", ["equal?", ["get", "a", 0], ["get", "b", 0]], + ["_cmp_seqs", ["rest", "a"], ["rest", "b"]], + false]]]]], + +["def", "_check_hash_map_keys", ["fn", ["ks", "a", "b"], + ["if", ["empty?", "ks"], + true, + ["let", ["k", ["first", "ks"]], + ["if", ["equal?", ["get", "a", "k"], ["get", "b", "k"]], + ["_check_hash_map_keys", ["rest", "ks"], "a", "b"], + false]]]]], +["def", "_cmp_hash_maps", ["fn", ["a", "b"], + ["let", ["aks", ["keys", "a"]], + ["if", ["not", ["=", ["count", "aks"], ["count", ["keys", "b"]]]], + false, + ["_check_hash_map_keys", "aks", "a", "b"]]]]], + +["def", "equal?", ["fn", ["a", "b"], + ["if", ["sequential?", "a"], + ["if", ["sequential?", "b"], + ["_cmp_seqs", "a", "b"], + false], + ["if", ["map?", "a"], + ["if", ["map?", "b"], + ["_cmp_hash_maps", "a", "b"], + false], + ["if", ["symbol?", "a"], + ["if", ["symbol?", "b"], + ["=", ["get", "a", ["`", "val"]], ["get", "b", ["`", "val"]]], + false], + ["=", "a", "b"]]]]]], + +["def", "_clone", ["fn", ["obj"], + ["if", ["list?", "obj"], + ["slice", "obj", 0], + ["if", ["vector?", "obj"], + ["let", ["new-obj", ["slice", "obj", 0]], + ["do", + ["set", "new-obj", ["`", "__vector?__"], true], + "new-obj"]], + ["if", ["map?", "obj"], + ["let", ["new-obj", ["hash-map"]], + ["do", + ["map", ["fn", ["k"], + ["if", [".", "obj", ["`", "hasOwnProperty"], "k"], + ["set", "new-obj", "k", ["get", "obj", "k"]], + null]], + ["keys", "obj"]], + "new-obj"]], + ["if", ["malfunc?", "obj"], + ["let", ["new-obj", ["malfunc", ["get", "obj", ["`", "fn"]], + ["get", "obj", ["`", "ast"]], + ["get", "obj", ["`", "env"]], + ["get", "obj", ["`", "params"]]]], + ["do", + ["set", "new-obj", ["`", "macro?"], ["get", "obj", ["`", "macro?"]]], + ["set", "new-obj", ["`", "__meta__"], ["get", "obj", ["`", "__meta__"]]], + "new-obj"]], + ["throw", "clone of unsupported type"]]]]]]], + +["def", "clone", ["fn", ["obj"], + ["let", ["new-obj", ["_clone", "obj"]], + ["do", + [".", "Object", ["`", "defineProperty"], "new-obj", ["`", "__meta__"], + {"enumerable": false, "writable": true}], + "new-obj"]]]], + +["def", "assoc!", ["fn", ["a", "b", "c"], ["do", ["set", "a", "b", "c"], "a"]]], +["def", "assocs!", ["fn", ["hm", "kvs"], + ["if", ["empty?", "kvs"], + "hm", + ["do", + ["assoc!", "hm", ["get", "kvs", 0], ["get", "kvs", 1]], + ["assocs!", "hm", ["slice", "kvs", 2]]]]]], + + +["def", "Symbol", ["fn", [], null]], +["def", "symbol", ["fn", ["name"], + ["assoc!", ["new", "Symbol"], ["`", "val"], "name"]]], + +["def", "symbol?", ["fn", ["a"], + ["isa", "a", "Symbol"]]], + + +["def", "keyword", ["fn", ["name"], + ["if", ["keyword?", "name"], + "name", + ["str", ["`", "\u029e"], "name"]]]], + +["def", "keyword?", ["fn", ["kw"], + ["and", ["=", ["`", "[object String]"], ["classOf", "kw"]], + ["=", ["`", "\u029e"], ["get", "kw", 0]]]]], + + +["`", "Override some list defs to account for Vectors"], +["def", "sequential?", ["fn", ["a"], + [".", "Array", ["`", "isArray"], "a"]]], + +["def", "list?", ["fn", ["a"], + ["if", [".", "Array", ["`", "isArray"], "a"], + ["if", [".-", "a", ["`", "__vector?__"]], + false, + true], + false]]], + +["def", "empty?", ["fn", ["a"], + ["if", ["sequential?", "a"], + ["if", ["=", 0, [".-", "a", ["`", "length"]]], + true, + false], + ["=", "a", null]]]], + + +["def", "vectorl", ["fn", ["lst"], + ["let", ["vec", ["slice", "lst", 0]], + ["do", + ["set", "vec", ["`", "__vector?__"], true], + "vec"]]]], + +["def", "vector", ["fn", ["&", "args"], ["vectorl", "args"]]], + +["def", "vector?", ["fn", ["a"], + ["if", [".", "Array", ["`", "isArray"], "a"], + ["if", [".-", "a", ["`", "__vector?__"]], + true, + false], + false]]], + + +["def", "HashMap", ["fn", [], null]], +["def", "hash-map", ["fn", ["&", "a"], + ["assocs!", ["new", "HashMap"], "a"]]], +["def", "map?", ["fn", ["a"], + ["isa", "a", "HashMap"]]], + +["def", "MalFunc", ["fn", [], null]], +["def", "malfunc", ["fn", ["fn", "ast", "env", "params"], + ["assocs!", ["new", "MalFunc"], + ["list", ["`", "fn"], "fn", + ["`", "ast"], "ast", + ["`", "env"], "env", + ["`", "params"], "params", + ["`", "macro?"], false]]]], + +["def", "malfunc?", ["fn", ["a"], + ["isa", "a", "MalFunc"]]], + +["def", "Atom", ["fn", [], null]], +["def", "atom", ["fn", ["a"], + ["let", ["atm", ["new", "Atom"]], + ["do", + ["set", "atm", ["`", "val"], "a"], + "atm"]]]], +["def", "atom?", ["fn", ["a"], + ["isa", "a", "Atom"]]], + +null +] diff --git a/impls/nasm/Dockerfile b/impls/nasm/Dockerfile index 29008471ee..fab4230f60 100644 --- a/impls/nasm/Dockerfile +++ b/impls/nasm/Dockerfile @@ -1,26 +1,26 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install nasm and ld -RUN apt-get -y install nasm binutils - +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install nasm and ld +RUN apt-get -y install nasm binutils + diff --git a/impls/nasm/Makefile b/impls/nasm/Makefile index a3cf08c0aa..03ff700207 100644 --- a/impls/nasm/Makefile +++ b/impls/nasm/Makefile @@ -1,17 +1,17 @@ - -STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal - -COMPONENTS = env.asm core.asm reader.asm printer.asm types.asm system.asm exceptions.asm - - -all: $(STEPS) - -%.o: %.asm $(COMPONENTS) - nasm -felf64 $< - -%: %.o - ld -o $@ $< - -.PHONY: clean -clean: - rm -f $(STEPS) $(STEPS:%=%.o) + +STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal + +COMPONENTS = env.asm core.asm reader.asm printer.asm types.asm system.asm exceptions.asm + + +all: $(STEPS) + +%.o: %.asm $(COMPONENTS) + nasm -felf64 $< + +%: %.o + ld -o $@ $< + +.PHONY: clean +clean: + rm -f $(STEPS) $(STEPS:%=%.o) diff --git a/impls/nasm/README.md b/impls/nasm/README.md index 170a7c2c58..c2bb146061 100644 --- a/impls/nasm/README.md +++ b/impls/nasm/README.md @@ -1,30 +1,30 @@ -# x86_64 NASM implementation - -Notes and known issues: - -* No library dependencies, only Linux system calls - -* Simple readline implemented, just supporting backspace for editing - -* Reference counting used for memory management. No attempt is made - to find circular references, so leaks are possible. In particular - defining a function with def! creates a circular reference loop. - -* The exception/error handling just resets the stack and jumps to a handler, - so does not release memory - -* Memory is allocated by two fixed-size allocators (`Cons` and `Array` objects) - which have limits specified in types.asm. If more memory is needed - then this must currently be done at compile-time, but adding sys_brk - calls could be done. - -* The hash map implementation is just a list of key-value pairs. - Moving symbols around in the core environment makes a significant difference - (20-30%) to the performance test. A simple optimisation could be to - move items when found to the start of the list so that frequently - searched keys are nearer the front. - -* `conj` function not yet implemented - -* `*env*` symbol evaluates to current Environment. - +# x86_64 NASM implementation + +Notes and known issues: + +* No library dependencies, only Linux system calls + +* Simple readline implemented, just supporting backspace for editing + +* Reference counting used for memory management. No attempt is made + to find circular references, so leaks are possible. In particular + defining a function with def! creates a circular reference loop. + +* The exception/error handling just resets the stack and jumps to a handler, + so does not release memory + +* Memory is allocated by two fixed-size allocators (`Cons` and `Array` objects) + which have limits specified in types.asm. If more memory is needed + then this must currently be done at compile-time, but adding sys_brk + calls could be done. + +* The hash map implementation is just a list of key-value pairs. + Moving symbols around in the core environment makes a significant difference + (20-30%) to the performance test. A simple optimisation could be to + move items when found to the start of the list so that frequently + searched keys are nearer the front. + +* `conj` function not yet implemented + +* `*env*` symbol evaluates to current Environment. + diff --git a/impls/nasm/core.asm b/impls/nasm/core.asm index 1cbcc12aa5..d44deac6cc 100644 --- a/impls/nasm/core.asm +++ b/impls/nasm/core.asm @@ -1,3347 +1,3347 @@ -;; Core functions -;; -;; - -%include "macros.mac" - -section .data - -;; Symbols for comparison - static core_add_symbol, db "+" - static core_sub_symbol, db "-" - static core_mul_symbol, db "*" - static core_div_symbol, db "/" - - static core_listp_symbol, db "list?" - static core_emptyp_symbol, db "empty?" - - static core_equal_symbol, db "=" - static core_gt_symbol, db ">" - static core_lt_symbol, db "<" - static core_ge_symbol, db ">=" - static core_le_symbol, db "<=" - - static core_count_symbol, db "count" - static core_keys_symbol, db "keys" - static core_vals_symbol, db "vals" - - static core_list_symbol, db "list" - - static core_pr_str_symbol, db "pr-str" - static core_prn_symbol, db "prn" - static core_str_symbol, db "str" - static core_println_symbol, db "println" - - static core_read_string_symbol, db "read-string" - static core_slurp_symbol, db "slurp" - static core_eval_symbol, db "eval" - - static core_atom_symbol, db "atom" - static core_deref_symbol, db "deref" - static core_atomp_symbol, db "atom?" - static core_reset_symbol, db "reset!" - static core_swap_symbol, db "swap!" - - static core_cons_symbol, db "cons" - static core_concat_symbol, db "concat" - static core_vec_symbol, db "vec" - - static core_first_symbol, db "first" - static core_rest_symbol, db "rest" - static core_nth_symbol, db "nth" - - static core_nilp_symbol, db "nil?" - static core_truep_symbol, db "true?" - static core_falsep_symbol, db "false?" - static core_numberp_symbol, db "number?" - - static core_symbolp_symbol, db "symbol?" - static core_stringp_symbol, db "string?" - static core_fnp_symbol, db "fn?" - static core_macrop_symbol, db "macro?" - static core_keywordp_symbol, db "keyword?" - - static core_containsp_symbol, db "contains?" - static core_get_symbol, db "get" - static core_vectorp_symbol, db "vector?" - static core_mapp_symbol, db "map?" - static core_sequentialp_symbol, db "sequential?" - - static core_throw_symbol, db "throw" - - static core_map_symbol, db "map" - static core_apply_symbol, db "apply" - - static core_symbol_symbol, db "symbol" - static core_vector_symbol, db "vector" - static core_hashmap_symbol, db "hash-map" - static core_keyword_symbol, db "keyword" - - static core_assoc_symbol, db "assoc" - static core_dissoc_symbol, db "dissoc" - - static core_readline_symbol, db "readline" - - static core_meta_symbol, db "meta" - static core_with_meta_symbol, db "with-meta" - - static core_time_ms_symbol, db "time-ms" - - static core_seq_symbol, db "seq" - -;; Strings - - static core_arith_missing_args, db "integer arithmetic missing arguments" - static core_arith_not_int, db "non-integer argument to integer arithmetic" - - static core_emptyp_error_string, db "empty? expects a list, vector or map",10 - static core_count_error_string, db "count expects a list or vector",10 - - static core_keys_not_map, db "keys expects a map as first argument" - static core_vals_not_map, db "vals expects a map as first argument" - - static core_numeric_expect_ints, db "comparison operator expected two numbers",10 - - static core_deref_not_atom, db "Error: argument to deref is not an atom" - static core_reset_not_atom, db "Error: argument to reset is not an atom" - static core_reset_no_value, db "Error: missing value argument to reset" - - static core_swap_not_atom, db "Error: swap! expects atom as first argument" - static core_swap_no_function, db "Error: swap! expects function as second argument" - - static core_cons_missing_arg, db "Error: missing argument to cons" - static core_cons_not_vector, db "Error: cons expects a list or vector" - - static core_concat_not_list, db "Error: concat expects lists or vectors" - - static core_vec_wrong_arg, db "Error: vec expects a list or vector " - - static core_first_missing_arg, db "Error: missing argument to first" - static core_first_not_list, db "Error: first expects a list or vector" - - static core_rest_missing_arg, db "Error: missing argument to rest" - static core_rest_not_list, db "Error: rest expects a list or vector" - - static core_nth_missing_arg, db "Error: missing argument to nth" - static core_nth_not_list, db "Error: nth expects a list or vector as first argument" - static core_nth_not_int, db "Error: nth expects an integer as second argument" - static core_nth_out_of_range, db "Error: nth index out of range" - - static core_value_p_missing_args, db "Error: value predicate (nil/true/false) missing args" - - static core_containsp_not_map, db "Error: contains? expects map as first argument" - static core_containsp_no_key, db "Error: contains? missing key argument" - - static core_get_not_map, db "Error: get expects map as first argument" - static core_get_no_key, db "Error: get missing key argument" - - static core_map_missing_args, db "Error: map expects two arguments (function, list/vector)" - static core_map_not_function, db "Error: map expects a ufunction for first argument" - static core_map_not_seq, db "Error: map expects a list or vector as second argument" - - static core_apply_not_function, db "Error: apply expects function as first argument" - static core_apply_missing_args, db "Error: apply missing arguments" - static core_apply_not_seq, db "Error: apply last argument must be list or vector" - - static core_symbol_not_string, db "Error: symbol expects a string argument" - - static core_keyword_not_string, db "Error: keyword expects a string or keyword argument" - - static core_list_not_seq, db "Error: list expects a list or vector" - - static core_assoc_not_map, db "Error: assoc expects a map as first argument" - static core_assoc_missing_value, db "Error: assoc missing value" - - static core_dissoc_not_map, db "dissoc expects a map as first argument" - static core_dissoc_missing_value, db "Missing value in map passed to dissoc" - - static core_with_meta_no_function, db "with-meta expects a function as first argument" - static core_with_meta_no_value, db "with-meta expects a value as second argument" - - static core_seq_missing_arg, db "seq missing argument" - static core_seq_wrong_type, db "seq expects a list, vector, string or nil" - -section .text - -;; Add a native function to the core environment -;; This is used in core_environment -%macro core_env_native 2 - push rsi ; environment - mov rsi, %1 - mov edx, %1.len - call raw_to_symbol ; Symbol in RAX - push rax - - mov rsi, %2 - call native_function ; Function in RAX - - mov rcx, rax ; value (function) - pop rdi ; key (symbol) - pop rsi ; environment - call env_set -%endmacro - - -;; Create an Environment with core functions -;; -;; Returns Environment in RAX -;; -;; -core_environment: - ; Create the top-level environment - xor rsi, rsi ; Set outer to nil - call env_new - mov rsi, rax ; Environment in RSI - - core_env_native core_cons_symbol, core_cons - core_env_native core_concat_symbol, core_concat - core_env_native core_vec_symbol, core_vec - - core_env_native core_first_symbol, core_first - core_env_native core_rest_symbol, core_rest - core_env_native core_nth_symbol, core_nth - - core_env_native core_add_symbol, core_add - core_env_native core_sub_symbol, core_sub - core_env_native core_mul_symbol, core_mul - core_env_native core_div_symbol, core_div - - core_env_native core_listp_symbol, core_listp - core_env_native core_emptyp_symbol, core_emptyp - core_env_native core_count_symbol, core_count - - core_env_native core_equal_symbol, core_equalp - core_env_native core_gt_symbol, core_gt - core_env_native core_lt_symbol, core_lt - core_env_native core_ge_symbol, core_ge - core_env_native core_le_symbol, core_le - - core_env_native core_keys_symbol, core_keys - core_env_native core_vals_symbol, core_vals - - core_env_native core_list_symbol, core_list - - core_env_native core_pr_str_symbol, core_pr_str - core_env_native core_prn_symbol, core_prn - core_env_native core_str_symbol, core_str - core_env_native core_println_symbol, core_println - - core_env_native core_read_string_symbol, core_read_string - core_env_native core_slurp_symbol, core_slurp - core_env_native core_eval_symbol, core_eval - - core_env_native core_atom_symbol, core_atom - core_env_native core_deref_symbol, core_deref - core_env_native core_atomp_symbol, core_atomp - core_env_native core_reset_symbol, core_reset - core_env_native core_swap_symbol, core_swap - - core_env_native core_nilp_symbol, core_nilp - core_env_native core_truep_symbol, core_truep - core_env_native core_falsep_symbol, core_falsep - core_env_native core_numberp_symbol, core_numberp - - core_env_native core_symbolp_symbol, core_symbolp - core_env_native core_stringp_symbol, core_stringp - core_env_native core_fnp_symbol, core_fnp - core_env_native core_macrop_symbol, core_macrop - core_env_native core_keywordp_symbol, core_keywordp - - core_env_native core_containsp_symbol, core_containsp - core_env_native core_get_symbol, core_get - - core_env_native core_vectorp_symbol, core_vectorp - core_env_native core_mapp_symbol, core_mapp - core_env_native core_sequentialp_symbol, core_sequentialp - - core_env_native core_throw_symbol, core_throw - - core_env_native core_map_symbol, core_map - core_env_native core_apply_symbol, core_apply - - core_env_native core_symbol_symbol, core_symbol - core_env_native core_vector_symbol, core_vector - core_env_native core_hashmap_symbol, core_hashmap - core_env_native core_keyword_symbol, core_keyword - - core_env_native core_assoc_symbol, core_assoc - core_env_native core_dissoc_symbol, core_dissoc - - core_env_native core_readline_symbol, core_readline - - core_env_native core_meta_symbol, core_meta - core_env_native core_with_meta_symbol, core_with_meta - - core_env_native core_time_ms_symbol, core_time_ms - - core_env_native core_seq_symbol, core_seq - - ; ----------------- - ; Put the environment in RAX - mov rax, rsi - ret - -;; ---------------------------------------------------- - -;; Jumped to from many core functions, with -;; string address in RSI and length in EDX -core_throw_str: - call raw_to_string - mov rsi, rax - jmp error_throw - -;; ---------------------------------------------------- - - - -;; Integer arithmetic operations -;; -;; Adds a list of numbers, address in RSI -;; Returns the sum as a number object with address in RAX -;; Since most of the code is common to all operators, -;; RBX is used to jump to the required instruction -core_add: - mov rbx, core_arithmetic.do_addition - jmp core_arithmetic -core_sub: - mov rbx, core_arithmetic.do_subtraction - jmp core_arithmetic -core_mul: - mov rbx, core_arithmetic.do_multiply - jmp core_arithmetic -core_div: - mov rbx, core_arithmetic.do_division - ; Fall through to core_arithmetic -core_arithmetic: - ; Check that the first object is a number - mov cl, BYTE [rsi] - mov ch, cl - and ch, block_mask - cmp ch, block_cons - jne .missing_args - - mov ch, cl - and ch, content_mask - cmp ch, content_empty - je .missing_args - - cmp ch, content_int - jne .not_int - - ; Put the starting value in rax - mov rax, [rsi + Cons.car] - -.add_loop: - ; Fetch the next value - mov cl, [rsi + Cons.typecdr] - cmp cl, content_pointer - jne .finished ; Nothing let - - mov rsi, [rsi + Cons.cdr] ; Get next cons - - ; Check that it is an integer - mov cl, BYTE [rsi] - and cl, content_mask - cmp cl, content_int - jne .not_int - - ; Jump to the required operation, address in RBX - jmp rbx - -.do_addition: - add rax, [rsi + Cons.car] - jmp .add_loop -.do_subtraction: - sub rax, [rsi + Cons.car] - jmp .add_loop -.do_multiply: - imul rax, [rsi + Cons.car] - jmp .add_loop -.do_division: - cqo ; Sign extend RAX into RDX - mov rcx, [rsi + Cons.car] - idiv rcx - jmp .add_loop - -.finished: - ; Value in rbx - push rax - ; Get a Cons object to put the result into - call alloc_cons - pop rbx - mov [rax], BYTE maltype_integer - mov [rax + Cons.car], rbx - ret - -.missing_args: - load_static core_arith_missing_args - jmp core_throw_str -.not_int: - load_static core_arith_not_int - jmp core_throw_str - -;; compare objects for equality -core_equalp: - ; Check that rsi contains a list - mov cl, BYTE [rsi] - cmp cl, maltype_empty_list - je .error - - and cl, block_mask + container_mask - cmp cl, block_cons + container_list - jne .error - - ; Check that the list has a second pointer - mov cl, BYTE [rsi + Cons.typecdr] - cmp cl, content_pointer - jne .error - - ; move second pointer into rdi - mov rdi, [rsi + Cons.cdr] - - ; Remove next pointers - mov cl, BYTE [rsi + Cons.typecdr] - mov [rsi + Cons.typecdr], BYTE 0 - - mov bl, BYTE [rdi + Cons.typecdr] - mov [rdi + Cons.typecdr], BYTE 0 - - push rbx - push rcx - - ; Compare the objects recursively - call compare_objects_rec - - ; Restore next pointers - pop rcx - pop rbx - mov [rsi + Cons.typecdr], BYTE cl - mov [rdi + Cons.typecdr], BYTE bl - - je .true - - -.false: - call alloc_cons - mov [rax], BYTE maltype_false - ret -.true: - call alloc_cons - mov [rax], BYTE maltype_true - ret -.error: - push rsi - print_str_mac error_string ; print 'Error: ' - pop rsi - jmp error_throw - -;; ----------------------------------------------------------------- -;; Numerical comparisons - - -core_gt: - mov rcx, core_compare_num.gt - jmp core_compare_num -core_lt: - mov rcx, core_compare_num.lt - jmp core_compare_num -core_ge: - mov rcx, core_compare_num.ge - jmp core_compare_num -core_le: - mov rcx, core_compare_num.le - ;jmp core_compare_num -core_compare_num: - ; The first argument should be an int - mov al, BYTE [rsi] - and al, content_mask - cmp al, maltype_integer - jne .error - - ; Check that there's a second argument - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .error - mov rax, [rsi + Cons.car] - mov rdi, [rsi + Cons.cdr] - - ; The second arg should also be an int - mov bl, BYTE [rdi] - and bl, content_mask - cmp bl, maltype_integer - jne .error - - mov rbx, [rdi + Cons.car] - - cmp rax, rbx - jmp rcx ; Address set above -.gt: - jg .true - jmp .false -.lt: - jl .true - jmp .false -.ge: - jge .true - jmp .false -.le: - jle .true - ;jmp .false -.false: - call alloc_cons - mov [rax], BYTE maltype_false - ret -.true: - call alloc_cons - mov [rax], BYTE maltype_true - ret -.error: - push rsi - print_str_mac error_string ; print 'Error: ' - print_str_mac core_numeric_expect_ints - pop rsi - jmp error_throw - -;; Test if a given object is a list -;; Input list in RSI -;; Returns true or false in RAX -core_listp: - mov bl, (block_cons + container_list) - jmp core_container_p -core_vectorp: - mov bl, (block_cons + container_vector) - jmp core_container_p -core_mapp: - mov bl, (block_cons + container_map) - ;jmp core_container_p -core_container_p: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .false ; Should be a pointer to a list - - mov rax, [rsi + Cons.car] - mov al, BYTE [rax] - and al, (block_mask + container_mask) - cmp al, bl - jne .false - - ; Is a list, return true - call alloc_cons - mov [rax], BYTE maltype_true - ret - -.false: - call alloc_cons - mov [rax], BYTE maltype_false - ret - -;; Return true if vector or list -core_sequentialp: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .false ; Should be a pointer - - mov rax, [rsi + Cons.car] - mov al, BYTE [rax] - and al, (block_mask + container_mask) - cmp al, container_list - je .true - cmp al, container_vector - jne .false -.true: - ; Is a list or vector, return true - call alloc_cons - mov [rax], BYTE maltype_true - ret - -.false: - call alloc_cons - mov [rax], BYTE maltype_false - ret - - - -;; Test if the given list, vector or map is empty -core_emptyp: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .error ; Expected a container - mov rax, [rsi + Cons.car] - mov al, BYTE [rax] - cmp al, maltype_empty_list - je .true - cmp al, maltype_empty_vector - je .true - cmp al, maltype_empty_map - je .true - - ; false - call alloc_cons - mov [rax], BYTE maltype_false - ret -.true: - call alloc_cons - mov [rax], BYTE maltype_true - ret -.error: - push rsi - print_str_mac error_string - print_str_mac core_emptyp_error_string - pop rsi - jmp error_throw - -;; Count the number of elements in given list or vector -core_count: - mov al, BYTE [rsi] - and al, content_mask - - cmp al, content_nil - je .zero - - cmp al, content_pointer - jne .error ; Expected a container - - mov rsi, [rsi + Cons.car] - mov al, BYTE [rsi] - - mov ah, al - and ah, (block_mask + container_mask) - cmp ah, (block_cons + container_list) - je .start_count - cmp ah, (block_cons + container_vector) - je .start_count - - jmp .error ; Not a list or vector - -.start_count: - - xor rbx,rbx - mov ah, al - and ah, content_mask - cmp ah, content_empty - je .done ; Empty list or vector - -.loop: - inc rbx - - ; Check if there's another - mov al, [rsi + Cons.typecdr] - cmp al, content_pointer - jne .done - - mov rsi, [rsi + Cons.cdr] - jmp .loop - -.zero: ; Return zero count - mov rbx, 0 -.done: ; Count is in RBX - - push rbx - call alloc_cons - pop rbx - mov [rax], BYTE maltype_integer - mov [rax + Cons.car], rbx - ret - -.error: - push rsi - print_str_mac error_string - print_str_mac core_count_error_string - pop rsi - jmp error_throw - - -;; Given a map, returns a list of keys -;; Input: List in RSI with one Map element -;; Returns: List in RAX -core_keys: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .not_map - - mov rsi, [rsi + Cons.car] - call map_keys - ret -.not_map: - load_static core_keys_not_map - jmp core_throw_str - -;; Get a list of values from a map -core_vals: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .not_map - - mov rsi, [rsi + Cons.car] - call map_vals - ret -.not_map: - load_static core_vals_not_map - jmp core_throw_str - -;; Given a map and a key, return true if the key is in the map -;; -core_containsp: - ; Check the type of the first argument - mov bl, BYTE [rsi] - and bl, content_mask - cmp bl, content_pointer - jne .not_map - - mov rcx, [rsi + Cons.car] ; Map in RCX - mov bl, BYTE [rcx] - and bl, (block_mask + container_mask) - cmp bl, container_map - jne .not_map - - ; Check second argument - mov bl, BYTE [rsi + Cons.typecdr] - cmp bl, content_pointer - jne .no_key - mov rsi, [rsi + Cons.cdr] - mov dl, BYTE [rsi] - and dl, content_mask - cmp dl, content_pointer - jne .key_value - - ; Pointer, so put into RDI - mov rdi, [rsi + Cons.car] - jmp .find - -.key_value: - ; A value - mov [rsi], BYTE dl - mov rdi, rsi ; Value in RDI - -.find: - mov rsi, rcx ; Map - call map_find - je .true - - ; false - call alloc_cons - mov [rax], BYTE maltype_false - ret -.true: - call alloc_cons - mov [rax], BYTE maltype_true - ret - -.not_map: - load_static core_containsp_not_map - jmp core_throw_str -.no_key: - load_static core_containsp_no_key - jmp core_throw_str - - -;; Given a map and a key, return the value in the map -;; or nil if not found -;; -core_get: - ; Check the type of the first argument - mov bl, BYTE [rsi] - - and bl, content_mask - - cmp bl, content_nil - je .not_found - - cmp bl, content_pointer - jne .not_map - - mov rcx, [rsi + Cons.car] ; Map in RCX - mov bl, BYTE [rcx] - and bl, (block_mask + container_mask) - cmp bl, container_map - jne .not_map - - ; Check second argument - mov bl, BYTE [rsi + Cons.typecdr] - cmp bl, content_pointer - jne .no_key - mov rsi, [rsi + Cons.cdr] - - mov dl, BYTE [rsi] - and dl, content_mask - cmp dl, content_pointer - jne .key_value - - ; Pointer, so put into RDI - mov rdi, [rsi + Cons.car] - jmp .find - -.key_value: - ; A value - mov [rsi], BYTE dl - mov rdi, rsi ; Value in RDI - -.find: - mov rsi, rcx ; Map - call map_get ; Value in RAX - je .found - -.not_found: - ; Not found - call alloc_cons - mov [rax], BYTE maltype_nil - ret -.found: - ret - -.not_map: - load_static core_get_not_map - jmp core_throw_str -.no_key: - load_static core_get_no_key - jmp core_throw_str - - -;; Return arguments as a list -;; -core_list: - call incref_object - mov rax, rsi - ret - -;; Convert arguments into a vector -core_vector: - ; Copy first element and mark as vector - call alloc_cons ; in RAX - mov bl, BYTE [rsi] - and bl, content_mask - mov bh, bl ; store content for comparison - or bl, container_vector - mov [rax], BYTE bl ; Set type - - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx ; Set content - - ; Check if the first element is a pointer - cmp bh, content_pointer - jne .done_car - - ; A pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.done_car: - ; Copy the CDR type and content - mov bl, [rsi + Cons.typecdr] - mov [rax + Cons.typecdr], bl - - mov rdx, [rsi + Cons.cdr] - mov [rax + Cons.cdr], rdx - - cmp bl, content_pointer - jne .done - - ; A pointer - mov bx, WORD [rdx + Cons.refcount] - inc bx - mov [rdx + Cons.refcount], WORD bx - -.done: - ret - - -;; Convert arguments into a map -core_hashmap: - ; Copy first element and mark as map - call alloc_cons ; in RAX - mov bl, BYTE [rsi] - and bl, content_mask - mov bh, bl ; store content for comparison - or bl, container_map - mov [rax], BYTE bl ; Set type - - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx ; Set content - - ; Check if the first element is a pointer - cmp bh, content_pointer - jne .done_car - - ; A pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.done_car: - ; Copy the CDR type and content - mov bl, [rsi + Cons.typecdr] - mov [rax + Cons.typecdr], bl - - mov rdx, [rsi + Cons.cdr] - mov [rax + Cons.cdr], rdx - - cmp bl, content_pointer - jne .done - - ; A pointer - mov bx, WORD [rdx + Cons.refcount] - inc bx - mov [rdx + Cons.refcount], WORD bx - -.done: - ret - -;; ------------------------------------------------ -;; String functions - -;; Convert arguments to a readable string, separated by a space -;; -core_pr_str: - mov rdi, 3 ; print_readably & separator - jmp core_str_functions -core_str: - xor rdi, rdi - jmp core_str_functions -core_str_sep: - mov rdi, 2 ; separator - -core_str_functions: - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_empty - je .empty ; Nothing to print - - xor r8, r8 ; Return string in r8 - -.loop: - cmp ah, content_pointer - je .got_pointer - - ; A value. Remove list container - xchg ah, al - mov [rsi], BYTE al - xchg ah, al - push rsi - push rax - push r8 - call pr_str - pop r8 - pop rbx - pop rsi - mov [rsi], BYTE bl ; restore type - jmp .got_string - -.got_pointer: - push rsi - push r8 - mov rsi, [rsi + Cons.car] ; Address pointed to - call pr_str - pop r8 - pop rsi - -.got_string: - ; String now in rax - - cmp r8, 0 - jne .append - - ; first string. Since this string will be - ; appended to, it needs to be a copy - push rsi ; input - - push rax ; string to copy - mov rsi, rax - call string_copy ; New string in RAX - pop rsi ; copied string - - push rax ; the copy - call release_object ; release the copied string - pop r8 ; the copy - - pop rsi ; input - - jmp .next - -.append: - push r8 - push rsi - push rax - - mov rsi, r8 ; Output string - mov rdx, rax ; String to be copied - call string_append_string - - pop rsi ; Was in rax, temporary string - call release_array ; Release the string - - pop rsi ; Restore input - pop r8 ; Output string -.next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .done - - ; More inputs - mov rsi, [rsi + Cons.cdr] ; pointer - - test rdi, 2 ; print_readably - jz .end_append_char ; No separator - - ; Add separator - push r8 - push rsi - mov rsi, r8 - mov cl, ' ' - call string_append_char - pop rsi - pop r8 -.end_append_char: - - ; Get the type in ah for comparison at start of loop - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - - jmp .loop -.done: - ; No more input, so return - mov rax, r8 - ret - -.empty: - call string_new ; An empty string - ret - -;; Print arguments readably, return nil -core_prn: - call core_pr_str - jmp core_prn_functions -core_println: - call core_str_sep -core_prn_functions: - mov rsi, rax - - ; Put newline at the end - push rsi - mov cl, 10 ; newline - call string_append_char - pop rsi - - ; print the string - push rsi ; Save the string address - call print_string - pop rsi - call release_array ; Release the string - - ; Return nil - call alloc_cons - mov [rax], BYTE maltype_nil - ret - -;; Given a string, calls read_str to get an AST -core_read_string: - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - jne .no_string - - mov rsi, [rsi + Cons.car] - mov al, BYTE [rsi] - cmp al, maltype_string - jne .no_string - - call read_str - ret - -.no_string: - ; Didn't get a string input - call alloc_cons - mov [rax], BYTE maltype_nil - ret - - -;; Reads a file into a string -core_slurp: - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - jne .no_string - - mov rsi, [rsi + Cons.car] - mov al, BYTE [rsi] - cmp al, maltype_string - jne .no_string - - call read_file - ret - -.no_string: - ; Didn't get a string input - call alloc_cons - mov [rax], BYTE maltype_nil - ret - -;; Evaluate an expression in the REPL environment -;; -core_eval: - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .pointer - - ; Just a value, so return it - call incref_object - - mov al, BYTE [rsi] - and al, content_mask - mov [rsi], BYTE al ; Removes list - mov rax, rsi - ret - -.pointer: - ; A pointer, so need to eval - mov rdi, [rsi + Cons.car] - - mov rsi, [repl_env] ; Environment - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call incref_object ; AST increment refs - - call eval - ret - -;; Create an atom -core_atom: - push rsi - call alloc_cons ; To hold the pointer - pop rsi - mov [rax], BYTE maltype_atom - - ; Check the type of the first argument - mov bl, BYTE [rsi] - mov bh, bl - and bh, content_mask - cmp bh, content_pointer - je .pointer - - ; A value - - ; make a copy - push rax - push rsi - push rbx - call alloc_cons - pop rbx - - mov bl, bh - mov [rax], BYTE bl ; Set type - - mov rbx, rax - pop rsi - pop rax - - mov rcx, [rsi + Cons.car] - mov [rbx + Cons.car], rcx ; Set value - - ; Set the atom to point to it - mov [rax + Cons.car], rbx - - ret - -.pointer: - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx - - push rax - mov rsi, rbx - call incref_object ; Storing in atom - pop rax - ret - -;; Get the value from the atom -core_deref: - ; Check the type of the first argument - mov bl, BYTE [rsi] - mov bh, bl - and bh, content_mask - cmp bh, content_pointer - jne .not_atom - - ; Get the atom - mov rsi, [rsi + Cons.car] - mov bl, BYTE [rsi] - cmp bl, maltype_atom - jne .not_atom - - ; Return what it points to - mov rsi, [rsi + Cons.car] - call incref_object - mov rax, rsi - ret - -.not_atom: - ; Not an atom, so throw an error - mov rsi, core_deref_not_atom - mov edx, core_deref_not_atom.len - call raw_to_symbol - mov rsi, rax - jmp error_throw - -;; Test if given object is an atom -core_atomp: - mov al, maltype_atom - jmp core_pointer_type_p -core_symbolp: - mov al, maltype_symbol - jmp core_pointer_type_p -core_stringp: - mov al, maltype_string - jmp core_pointer_type_p -core_fnp: - mov al, maltype_function - jmp core_pointer_type_p -core_macrop: - mov al, maltype_macro - jmp core_pointer_type_p - -core_pointer_type_p: - mov bl, BYTE [rsi] - mov bh, bl - and bh, content_mask - cmp bh, content_pointer - jne .false - - mov rsi, [rsi + Cons.car] - mov bl, BYTE [rsi] - cmp bl, al - jne .false - - ; Check for keyword (not symbol) - cmp al, maltype_symbol - jne .true - - mov al, BYTE [rsi + Array.data] - cmp al, ':' - je .false ; a keyword - -.true: - ; Return true - call alloc_cons - mov [rax], BYTE maltype_true - ret - -.false: - call alloc_cons - mov [rax], BYTE maltype_false - ret - -;; Tests if argument is a keyword -core_keywordp: - mov bl, BYTE [rsi] - mov bh, bl - and bh, content_mask - cmp bh, content_pointer - jne .false - - mov rsi, [rsi + Cons.car] - mov bl, BYTE [rsi] - cmp bl, maltype_symbol - jne .false - - ; Check if first character is ':' - mov bl, BYTE [rsi + Array.data] - cmp bl, ':' - jne .false - - ; Return true - call alloc_cons - mov [rax], BYTE maltype_true - ret - -.false: - call alloc_cons - mov [rax], BYTE maltype_false - ret - -;; Change the value of an atom -core_reset: - ; Check the type of the first argument - mov bl, BYTE [rsi] - mov bh, bl - and bh, content_mask - cmp bh, content_pointer - jne .not_atom - - ; Get the atom - mov rax, [rsi + Cons.car] ; Atom in RAX - mov bl, BYTE [rax] - cmp bl, maltype_atom - jne .not_atom - - ; Get the next argument - mov bl, BYTE [rsi + Cons.typecdr] - cmp bl, content_pointer - jne .no_value - - mov rsi, [rsi + Cons.cdr] - - ; Got something in RSI - ; release the current value of the atom - push rax - push rsi - - mov rsi, [rax + Cons.car] ; The value the atom points to - call release_object - - pop rsi - pop rax - - ; Check the type of the first argument - mov bl, BYTE [rsi] - mov bh, bl - and bh, content_mask - cmp bh, content_pointer - je .pointer - - ; A value - - ; make a copy - push rax - push rsi - push rbx - call alloc_cons - pop rbx - - mov bl, bh - mov [rax], BYTE bl ; Set type - - mov rbx, rax - pop rsi - pop rax - - mov rcx, [rsi + Cons.car] - mov [rbx + Cons.car], rcx ; Set value - - ; Set the atom to point to it - mov [rax + Cons.car], rbx - - ; Increment refcount since return value will be released - mov rsi, rbx - call incref_object - mov rax, rsi - ret - -.pointer: - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx - - mov rsi, rbx - call incref_object ; Storing in atom - call incref_object ; Returning - mov rax, rsi - ret - -.not_atom: - ; Not an atom, so throw an error - mov rsi, core_reset_not_atom - mov edx, core_reset_not_atom.len - call raw_to_symbol - mov rsi, rax - jmp error_throw - -.no_value: - ; No value given - mov rsi, core_reset_no_value - mov edx, core_reset_no_value.len - call raw_to_symbol - mov rsi, rax - jmp error_throw - -;; Applies a function to an atom, along with optional arguments -;; -;; In RSI should be a list consisting of -;; [ atom, pointer->Function , args...] -;; -;; The atom is dereferenced, and inserted into the list: -;; -;; [ pointer->Function , atom value , args...] -;; -;; This is then passed to eval.list_exec -;; which executes the function -;; -core_swap: - ; Check the type of the first argument (an atom) - mov bl, BYTE [rsi] - mov bh, bl - and bh, content_mask - cmp bh, content_pointer - jne .not_atom - - ; Get the atom - mov r9, [rsi + Cons.car] ; Atom in R9 - mov bl, BYTE [r9] - cmp bl, maltype_atom - jne .not_atom - - ; Get the second argument (a function) - mov bl, BYTE [rsi + Cons.typecdr] - cmp bl, content_pointer - jne .no_function - - mov rsi, [rsi + Cons.cdr] ; List with function first - - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .no_function - - mov r8, [rsi + Cons.car] ; Function in R8 - mov al, BYTE [r8] - cmp al, maltype_function - jne .no_function - - ; Get a new Cons - ; containing the value in the atom - call alloc_cons ; In RAX - - ; Prepend to the list - mov bl, BYTE [rsi + Cons.typecdr] - mov [rax + Cons.typecdr], bl - cmp bl, content_pointer - jne .done_prepend - - ; A pointer to more args, - - mov rcx, [rsi + Cons.cdr] - mov [rax + Cons.cdr], rcx - - ; increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.done_prepend: - - ; Now get the value in the atom - mov rdx, [r9 + Cons.car] ; The object pointed to - - ; Check what it is - mov bl, BYTE [rdx] - mov bh, bl - and bh, (block_mask + container_mask) - jz .atom_value ; Just a value - - ; Not a simple value, so point to it - mov [rax + Cons.car], rdx - mov [rax], BYTE (container_list + content_pointer) - - ; Since the list will be released after eval - ; we need to increment the reference count - mov bx, WORD [rdx + Cons.refcount] - inc bx - mov [rdx + Cons.refcount], WORD bx - - jmp .run - -.atom_value: - ; Copy the value - mov rcx, [rdx + Cons.car] - mov [rax + Cons.car], rcx - and bl, content_mask ; keep just the content - or bl, container_list ; mark as part of a list - mov [rax], BYTE bl - -.run: - mov rsi, rax - - ; Here have function in R8, args in RSI - ; Check whether the function is built-in or user - mov rax, [r8 + Cons.car] - cmp rax, apply_fn - je .user_function - - ; A built-in function - push r9 ; atom - push rsi ; Args - - call rax - ; Result in RAX - - pop rsi - pop r9 - - push rax - call release_object ; Release arguments - pop rax - - jmp .got_return - -.user_function: - ; a user-defined function, so need to evaluate - ; RSI - Args - - mov rdi, r8 ; Function in RDI - mov rdx, rsi ; Release args after binding - - mov rsi, r15 ; Environment - call incref_object ; Released by eval - call incref_object ; also released from R13 - mov r13, r15 - - mov rsi, rdx - - push r9 - call apply_fn ; Result in RAX - pop r9 - -.got_return: - ; Have a return result in RAX - - ; release the current value of the atom - push rax ; The result - mov rsi, [r9 + Cons.car] - call release_object - pop rax - - ; Put into atom - mov [r9 + Cons.car], rax - - ; Increase reference of new object - ; because when it is returned it will be released - mov bx, WORD [rax + Cons.refcount] - inc bx - mov [rax + Cons.refcount], WORD bx - - ret - -.not_atom: - load_static core_swap_not_atom - jmp core_throw_str -.no_function: - load_static core_swap_no_function - jmp core_throw_str - - -;; Takes two arguments, and prepends the first argument onto the second -;; The second argument can be a list or a vector, but the return is always -;; a list -core_cons: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_empty - je .missing_args - - mov r8, rsi ; The object to prepend - - ; Check if there's a second argument - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .missing_args - - mov rsi, [rsi + Cons.cdr] - - ; Check that the second argument is a list or vector - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .not_vector - - mov r9, [rsi + Cons.car] ; Should be a list or vector - mov al, BYTE [r9] - and al, container_mask - cmp al, container_list - je .got_args - cmp al, container_vector - je .got_args - jmp .not_vector - -.got_args: - ; Got an object in R8 and list/vector in R9 - - call alloc_cons ; new Cons in RAX - - ; Mark as the same content in a list container - mov bl, BYTE [r8] - and bl, content_mask - mov bh, bl ; Save content in BH for checking if pointer later - or bl, block_cons + container_list - mov [rax], BYTE bl - - ; Copy the content - mov rcx, [r8 + Cons.car] ; Content in RCX - mov [rax + Cons.car], rcx - - ; Check if R9 is empty - mov dl, BYTE [r9] - and dl, content_mask - cmp dl, content_empty - je .end_append ; Don't append the list - - ; Put the list into CDR - mov [rax + Cons.cdr], r9 - ; mark CDR as a pointer - mov [rax + Cons.typecdr], BYTE content_pointer - - ; Increment reference count - push rax - mov rsi, r9 - call incref_object - pop rax - -.end_append: - ; Check if the new Cons contains a pointer - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .done - - ; A pointer, so increment number of references - push rax - mov rsi, rcx - call incref_object - pop rax -.done: - ret - -.missing_args: - load_static core_cons_missing_arg - jmp core_throw_str - -.not_vector: - load_static core_cons_not_vector - jmp core_throw_str - - -;; Concatenate lists, returning a new list -;; -;; Notes: -;; * The last list does not need to be copied, but all others do -;; -core_concat: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_empty - je .missing_args - - cmp al, content_pointer - jne .not_list - - ; Check if there is only one argument - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - je .start_loop ; Start copy loop - - ; Only one input. - mov rsi, [rsi + Cons.car] - - ; Check if it's a list or vector - mov al, BYTE [rsi] - mov cl, al - and al, container_mask - cmp al, (block_cons + container_list) - je .single_list - - cmp al, (block_cons + container_vector) - jne .not_list ; not a list or vector - - ; A vector. Need to create a new Cons - ; for the first element, to mark it as a list - - call alloc_cons - and cl, content_mask - or cl, container_list - mov [rax], BYTE cl ; Set type - - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; Set content - - ; Check if CAR is a pointer - cmp cl, (container_list + content_pointer) - jne .single_done_car - - ; a pointer, so increment reference count - mov cx, WORD [rbx + Cons.refcount] - inc cx - mov [rbx + Cons.refcount], WORD cx - -.single_done_car: - mov dl, BYTE [rsi + Cons.typecdr] - mov [rax + Cons.typecdr], BYTE dl ; CDR type - - mov rbx, [rsi + Cons.cdr] - mov [rax + Cons.cdr], rbx ; Set CDR content - - ; Check if CDR is a pointer - cmp dl, content_pointer - je .single_vector_incref - ; not a pointer, just return - ret - -.single_vector_incref: - ; increment the reference count of object pointed to - mov r12, rax ; The return Cons - mov rsi, rbx ; The object address - call incref_object - mov rax, r12 - ret - -.single_list: - ; Just increment reference count and return - - call incref_object - mov rax, rsi - ret - -.start_loop: ; Have at least two inputs - xor r11, r11 ; Head of list. Start in R12 - -.loop: - - ; Check the type - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .not_list - - ; Check if this is the last - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .last - - ; Check if the list is empty - mov rbx, [rsi + Cons.car] ; The list - mov al, BYTE [rbx] - and al, content_mask - cmp al, content_empty ; If empty list or vector - je .next ; Skip to next - - ; not the last list, so need to copy - - push rsi - mov rsi, rbx ; The list - call cons_seq_copy ; Copy in RAX, last Cons in RBX - pop rsi - - ; Check if this is the first - test r11, r11 - jnz .append - - ; First list - mov r11, rbx ; Last Cons in list - mov r12, rax ; Output list - jmp .next -.append: - ; End of previous list points to start of new list - mov [r11 + Cons.cdr], rax - mov [r11 + Cons.typecdr], BYTE content_pointer - ; Put end of new list into R11 - mov r11, rbx - -.next: - mov rsi, [rsi + Cons.cdr] - jmp .loop - -.last: - ; last list, so can just append - mov rsi, [rsi + Cons.car] - - ; Check if the list is empty - mov al, BYTE [rsi] - mov ah, al - and al, content_mask - cmp al, content_empty ; If empty list or vector - je .done ; Omit the empty list - - call incref_object - - mov [r11 + Cons.cdr], rsi - mov [r11 + Cons.typecdr], BYTE content_pointer -.done: - ; Check there is anything to return - test r11, r11 - jz .empty_list - - ; Make sure that return is a list - mov bl, BYTE [r12] - and bl, content_mask - or bl, container_list - mov [r12], BYTE bl - mov rax, r12 ; output list - - ret - -.empty_list: - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - -.missing_args: - ; Return empty list - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - -.not_list: - ; Got an argument which is not a list - mov rsi, core_concat_not_list - mov edx, core_concat_not_list.len - -.throw: - call raw_to_string - mov rsi, rax - jmp error_throw - -;; Convert a sequence to vector -core_vec: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .error - mov rsi, [rsi + Cons.car] - - mov al, BYTE [rsi] - and al, block_mask + container_mask - - ;; delegate lists to `vector` built-in - cmp al, container_list - je core_vector - - ;; expect a sequence - cmp al, container_vector - jne .error - - ;; return vectors unchanged - call incref_object - mov rax, rsi - ret - -.error - push rsi - print_str_mac error_string - print_str_mac core_vec_wrong_arg - pop rsi - jmp error_throw - -;; Returns the first element of a list -;; -core_first: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_empty - je .missing_args - - cmp al, content_nil - je .return_nil - - cmp al, content_pointer - jne .not_list - - ; Get the list - mov rsi, [rsi + Cons.car] - - mov al, BYTE [rsi] - - ; Check for nil - cmp al, maltype_nil - je .return_nil - - mov ah, al - and ah, (block_mask + container_mask) - cmp ah, container_list - je .got_list - cmp ah, container_vector - jne .not_list ; Not a list or vector - -.got_list: - ; Check if list is empty - and al, content_mask - cmp al, content_empty - je .return_nil - - cmp al, content_pointer - je .return_pointer - - ; Returning a value, so need to copy - mov cl, al - call alloc_cons - mov [rax], BYTE cl ; Set type - - ; Copy value - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - ret - -.return_pointer: - mov rsi, [rsi + Cons.car] - call incref_object - mov rax, rsi - ret - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - ret - -.missing_args: - mov rsi, core_first_missing_arg - mov edx, core_first_missing_arg.len - jmp .throw - -.not_list: - mov rsi, core_first_not_list - mov edx, core_first_not_list.len -.throw: - call raw_to_string - mov rsi, rax - jmp error_throw - - -;; Return a list with the first element removed -core_rest: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_empty - je .missing_args - - cmp al, content_nil - je .empty_list - - cmp al, content_pointer - jne .not_list - - ; Get the list - mov rsi, [rsi + Cons.car] - - mov al, BYTE [rsi] - - ; Check for nil - cmp al, maltype_nil - je .return_nil - - mov ah, al - and ah, (block_mask + container_mask) - cmp ah, container_list - je .got_list - cmp ah, container_vector - jne .not_list ; Not a list or vector - -.got_list: - ; Check if list or vector is empty - and al, content_mask - cmp al, content_empty - je .empty_list - - ; Check if there is more in the list - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - je .return_rest - - ; No more list, so return empty list -.empty_list: - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - -.return_rest: - - mov rsi, [rsi + Cons.cdr] - - - - ; Check if this is a list or a vector - mov cl, BYTE [rsi] - mov ch, cl - and ch, container_mask - cmp ch, container_list - je .return_list - - ; Need to allocate a new Cons to replace this first element - call alloc_cons - and cl, content_mask - mov ch, cl ; Save CAR content type in ch - or cl, container_list ; Keep content type, set container type to list - mov [rax], BYTE cl - - mov dl, BYTE [rsi + Cons.typecdr] ; CDR type in DL - mov [rax + Cons.typecdr], BYTE dl - - ; Copy content of CAR - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx - - ; Check if car contains a pointer - cmp ch, content_pointer - jne .check_cdr - - ; CAR contains a pointer, so increment reference count - - mov r8, rax ; Save return Cons - mov r9, rsi ; Save input list - mov rsi, rbx ; Content of CAR - call incref_object - mov rax, r8 ; Restore return Cons - mov rsi, r9 ; Restore input list - -.check_cdr: - ; Copy content of CDR - - mov rcx, [rsi + Cons.cdr] - mov [rax + Cons.cdr], rcx ; Note: Might be pointer - - ; Check if cdr contains a pointer - cmp dl, content_pointer - jne .return ; Not a pointer, so just return - - ; A pointer, so increment its reference count - mov rbx, rax ; Save the return Cons - mov rsi, rcx ; The pointer in CDR - call incref_object - mov rax, rbx ; Restore the return Cons - ret - -.return_list: - call incref_object - mov rax, rsi -.return: - ret - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - ret - -.missing_args: - mov rsi, core_rest_missing_arg - mov edx, core_rest_missing_arg.len - jmp .throw - -.not_list: - mov rsi, core_rest_not_list - mov edx, core_rest_not_list.len -.throw: - call raw_to_string - mov rsi, rax - jmp error_throw - - -;; Return the nth element of a list or vector -core_nth: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_empty - je .missing_args - - cmp al, content_nil - je .return_nil - - cmp al, content_pointer - jne .not_list - - ; Get the list into R8 - mov r8, [rsi + Cons.car] - - ; Check if we have a second argument - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .missing_args - - mov r9, [rsi + Cons.cdr] - - ; Check that it is a number - mov al, BYTE [r9] - and al, content_mask - cmp al, content_int - jne .not_int - - ; Get the number in RBX - mov rbx, [r9 + Cons.car] - - ; Now loop through the list, moving along n elements -.loop: - test rbx, rbx ; Test if zero - jz .done - - ; Move along next element - - mov al, BYTE [r8 + Cons.typecdr] - cmp al, content_pointer - jne .out_of_range ; No element - - mov r8, [r8 + Cons.cdr] - dec rbx - jmp .loop - -.done: - ; Take the head of the list in R8 - mov al, BYTE [r8] - and al, content_mask - cmp al, content_pointer - je .return_pointer - - ; Copy a value - mov cl, al - call alloc_cons - mov [rax], BYTE cl - mov rcx, [r8 + Cons.car] - mov [rax + Cons.car], rcx - ret - -.return_pointer: - mov rsi, [r8 + Cons.car] - call incref_object - mov rax, rsi - ret - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - ret - -.missing_args: - mov rsi, core_nth_missing_arg - mov edx, core_nth_missing_arg.len - jmp .throw - -.not_list: - mov rsi, core_nth_not_list - mov edx, core_nth_not_list.len - jmp .throw - -.not_int: - mov rsi, core_nth_not_int - mov edx, core_nth_not_int.len - jmp .throw - -.out_of_range: - mov rsi, core_nth_out_of_range - mov edx, core_nth_out_of_range.len - -.throw: - call raw_to_string - mov rsi, rax - jmp error_throw - -;; Check if the argument is a given value type -core_nilp: - mov al, BYTE content_nil - jmp core_value_type_p -core_truep: - mov al, BYTE content_true - jmp core_value_type_p -core_falsep: - mov al, BYTE content_false - jmp core_value_type_p -core_numberp: - mov al, BYTE content_int -;; predicates for nil, true, false and number jump here -core_value_type_p: - mov bl, BYTE [rsi] - and bl, content_mask - cmp bl, content_empty - je .missing_args - - cmp al, bl - je .true - - ; false - call alloc_cons - mov [rax], BYTE maltype_false - ret -.true: - call alloc_cons - mov [rax], BYTE maltype_true - ret - -.missing_args: - mov rsi, core_value_p_missing_args - mov edx, core_value_p_missing_args.len - - call raw_to_string - mov rsi, rax - jmp error_throw - -;; Throws an exception -core_throw: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_empty - je .throw_nil ; No arguments - - cmp al, content_pointer - je .throw_pointer - - ; A value. Remove list content type - mov [rsi], BYTE al - jmp error_throw - -.throw_pointer: - mov rsi, [rsi + Cons.car] - jmp error_throw - -.throw_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - mov rsi, rax - jmp error_throw - -;; Applies a function to a list or vector -;; -;; Uses registers -;; R8 - function -;; R9 - Input list/vector -;; R10 - Current end of return list (for appending) -core_map: - xor r10,r10 ; Zero, signal no list - - ; First argument should be a function - mov bl, BYTE [rsi] - and bl, content_mask - cmp bl, content_empty - je .missing_args - - ; Check the first argument is a pointer - cmp bl, content_pointer - jne .not_function - - mov r8, [rsi + Cons.car] ; Function in R8 - mov bl, BYTE [r8] - cmp bl, maltype_function - jne .not_function - - ; Check for second argument - mov bl, BYTE [rsi + Cons.typecdr] - cmp bl, content_pointer - jne .missing_args - - mov rsi, [rsi + Cons.cdr] - - ; Should be a pointer to a list or vector - mov bl, BYTE [rsi] - and bl, content_mask - cmp bl, content_pointer - jne .not_seq - - mov r9, [rsi + Cons.car] ; List or vector in R9 - - mov bl, BYTE [r9] - - mov bh, bl - and bh, content_mask - cmp bh, content_empty - je .empty_list - - and bl, (block_mask + container_mask) - cmp bl, container_list - je .start - cmp bl, container_vector - je .start - - ; not list or vector - jmp .not_seq - -.start: - ; Got function in R8, list or vector in R9 - - mov cl, BYTE [r9] - and cl, content_mask - mov ch, cl - or cl, container_list - - call alloc_cons - mov [rax], BYTE cl ; set content type - mov rbx, [r9 + Cons.car] - mov [rax + Cons.car], rbx ; Copy content - mov rsi, rax - - cmp ch, content_pointer - jne .run - - ; A pointer, so increment ref count - - mov rcx, rsi - mov rsi, rbx - call incref_object - mov rsi, rcx - -.run: - ; Here have function in R8, args in RSI - ; Check whether the function is built-in or user - mov rax, [r8 + Cons.car] - cmp rax, apply_fn - je .user_function - - ; A built-in function - push r8 ; function - push r9 ; input list/vector - push r10 ; End of return list - push rsi - - call rax - ; Result in RAX - - pop rsi - pop r10 - pop r9 - pop r8 - - push rax - call release_object ; Release arguments - pop rax - - jmp .got_return - -.user_function: - ; a user-defined function, so need to evaluate - ; RSI - Args - - mov rdi, r8 ; Function in RDI - mov rdx, rsi ; Release args after binding - - mov rsi, r15 ; Environment - call incref_object ; Released by eval - call incref_object ; also released from R13 - mov r13, r15 - - mov rsi, rdx - - push r8 - push r9 - push r10 - push r15 - call apply_fn ; Result in RAX - pop r15 - pop r10 - pop r9 - pop r8 - -.got_return: - ; Have a return result in RAX - - ; Check if it's a value type - mov bl, BYTE [rax] - mov bh, bl - and bl, (block_mask + container_mask) - jz .return_value - - ; A more complicated type, point to it - mov rcx, rax - call alloc_cons ; Create a Cons for address - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.car], rcx - jmp .update_return - -.return_value: - ; Check if this value is shared (e.g. in an atom) - mov cx, WORD [rax + Cons.refcount] - dec cx - jz .return_value_modify ; If reference count is 1 - - ; Need to copy to avoid modifying - push rsi - mov rsi, rax ; Original in RSI - - mov cl, bh ; Type - call alloc_cons - and cl, content_mask - or cl, container_list - mov [rax], BYTE cl ; mark as a list - - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy content - - ; Release original - push rax - call release_object - pop rax - pop rsi - - jmp .update_return - -.return_value_modify: - ; Only one reference, - ; so can change the container type to list. - ; Original type in bh - mov bl, bh - and bl, content_mask - or bl, container_list - mov [rax], BYTE bl - -.update_return: - ; Now append to result list - test r10,r10 - jnz .append - - ; First value - mov r10, rax ; End of list - push r10 ; popped before return - jmp .next -.append: - mov [r10 + Cons.cdr], rax ; Point to new Cons - mov [r10 + Cons.typecdr], BYTE content_pointer - mov r10, rax -.next: - ; Check if there is another value - mov al, [r9 + Cons.typecdr] - cmp al, content_pointer - jne .done ; no more - - mov r9, [r9 + Cons.cdr] ; next - jmp .start - -.done: - pop rax ; Pushed in .update_return - ret - -.empty_list: - ; Got an empty list, so return an empty list - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - -.missing_args: - ; Either zero or one args, expect two - load_static core_map_missing_args - jmp core_throw_str -.not_function: - ; First argument not a function - load_static core_map_not_function - jmp core_throw_str -.not_seq: - ; Second argument not list or vector - load_static core_map_not_seq - jmp core_throw_str - - -;; Applies a function to a list of arguments, concatenated with -;; a final list of args -;; (function, ..., []) -core_apply: - ; First argument should be a function - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .not_function - - mov r8, [rsi + Cons.car] ; function in R8 - mov al, BYTE [r8] - cmp al, maltype_function - jne .not_function - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .missing_args - - xor r9,r9 - ; Optional args, followed by final list/vector -.loop: - mov rsi, [rsi + Cons.cdr] - - ; Check if this is the last - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .last - - ; Not the last, so copy - call alloc_cons ; New Cons in RAX - mov bl, BYTE [rsi] - mov [rax], BYTE bl - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - - and bl, content_mask - cmp bl, content_pointer - jne .got_value - - ; A pointer, so increment reference - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.got_value: - ; Now append this Cons to the list - test r9,r9 - jnz .append - - ; First - mov r9, rax ; Start of the list - mov r10, rax ; End of the list - jmp .loop - -.append: - mov [r10 + Cons.typecdr], BYTE content_pointer - mov [r10 + Cons.cdr], rax - mov r10, rax - jmp .loop - -.last: - ; Check that it's a list or vector - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .not_seq - - mov rsi, [rsi + Cons.car] ; Vector/list in RSI - mov al, BYTE [rsi] - and al, container_mask - cmp al, container_list - je .last_seq - cmp al, container_vector - jne .not_seq - -.last_seq: - ; Check if there were any previous args - test r9, r9 - jnz .last_append - - ; R9 is zero, so no previous args - - ; check that this is a list - ; and convert vector to list - - mov r9, rsi - - ; Check if R9 is a list - mov al, BYTE [r9] - mov cl, al - and al, container_mask - cmp al, container_list - jne .last_convert_to_list - - ; Already a list, just increment reference count - mov rsi, r9 - call incref_object - jmp .run - -.last_convert_to_list: - ; Convert vector to list by copying first element - - call alloc_cons - and cl, content_mask - or cl, container_list - mov [rax], BYTE cl - mov rdx, [r9 + Cons.car] - mov [rax + Cons.car], rdx - - ; check if contains a pointer - cmp cl, (container_list + content_pointer) - jne .copy_cdr - - ; A pointer, so increment reference - mov bx, WORD [rdx + Cons.refcount] - inc bx - mov [rdx + Cons.refcount], WORD bx - -.copy_cdr: - mov bl, BYTE [r9 + Cons.typecdr] - mov rcx, [r9 + Cons.cdr] - mov [rax + Cons.typecdr], BYTE bl - mov [rax + Cons.cdr], rcx - - ; Replace R9 with this new element - mov r9, rax - - cmp bl, content_pointer - jne .run - - ; A pointer, so increment reference - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - - jmp .run - -.last_append: - ; Append RSI to the end of the list [R9]...[R10] - mov [r10 + Cons.typecdr], BYTE content_pointer - mov [r10 + Cons.cdr], rsi - call incref_object - -.run: - ; Have arguments list in R9 - mov rsi, r9 - ; Here have function in R8, args in RSI - ; Check whether the function is built-in or user - mov rax, [r8 + Cons.car] - cmp rax, apply_fn - je .user_function - - ; A built-in function - push r8 ; function - push r9 ; input list/vector - push r10 ; End of return list - push rsi - - call rax - ; Result in RAX - - pop rsi - pop r10 - pop r9 - pop r8 - - push rax - call release_object ; Release arguments - pop rax - - ret - -.user_function: - ; a user-defined function, so need to evaluate - ; RSI - Args - - mov rdi, r8 ; Function in RDI - mov rdx, rsi ; Release args after binding - - mov rsi, r15 ; Environment - call incref_object ; Released by eval - call incref_object ; also released from R13 - mov r13, r15 - - mov rsi, rdx - - push r8 - push r9 - push r10 - call apply_fn ; Result in RAX - pop r10 - pop r9 - pop r8 - - ret - -.not_function: - load_static core_apply_not_function - jmp core_throw_str - -.missing_args: - load_static core_apply_missing_args - jmp core_throw_str - -.not_seq: - load_static core_apply_not_seq - jmp core_throw_str - -;; Converts a string to a symbol -core_symbol: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .not_string - - mov rsi, [rsi + Cons.car] - mov al, BYTE [rsi] - cmp al, maltype_string - jne .not_string - - ; Copy the string - call string_copy ; result in RAX - - mov [rax], BYTE maltype_symbol - ret - -.not_string: - load_static core_symbol_not_string - jmp core_throw_str - -;; Converts a string to a keyword -core_keyword: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .error - - mov r8, [rsi + Cons.car] ; String in R8 - mov al, BYTE [r8] - cmp al, maltype_string - jne .not_string - - call string_new ; String in RAX - mov rsi, rax - mov cl, ':' - call string_append_char ; Puts ':' first - - mov rdx, r8 - call string_append_string ; append - - ; Mark as keyword - mov [rsi], BYTE maltype_symbol - - mov rax, rsi - ret - -.not_string: - cmp al, maltype_symbol - jne .error - ; Check if first character is ':' - mov al, BYTE [r8 + Array.data] - cmp al, ':' - jne .error - ;; This is already a keyword, return it unchanged. - mov rsi, r8 - call incref_object - mov rax, rsi - ret -.error: - load_static core_keyword_not_string - jmp core_throw_str - -;; Sets values in a map -core_assoc: - ; check first arg - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .not_map - - mov r8, [rsi + Cons.car] ; map in R8 - mov al, BYTE [r8] - and al, container_mask - cmp al, container_map - jne .not_map - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - je .start - - ; No keys to set, so just increment and return - mov rsi, r8 - call incref_object - mov rax, rsi - ret - -.start: - mov r11, [rsi + Cons.cdr] ; List of keys/values in R11 - - ; Copy the original list - mov rsi, r8 - call map_copy - mov rsi, rax ; new map in RSI - -.loop: - ; Get key then value from R11 list - - mov cl, BYTE [r11] - and cl, content_mask - cmp cl, content_pointer - je .key_pointer - - ; Key is a value, so copy into a Cons - call alloc_cons - mov [rax], BYTE cl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - mov rdi, rax ; Key in RDI - jmp .get_value - -.key_pointer: - mov rdi, [r11 + Cons.car] - ; increment reference count because the key will be - ; released after setting (to allow value Cons to be - ; freed) - - mov bx, WORD [rdi + Cons.refcount] - inc bx - mov [rdi + Cons.refcount], WORD bx - -.get_value: - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .missing_value - - mov r11, [r11 + Cons.cdr] - - ; Check if value is a pointer - mov cl, BYTE [r11] - and cl, content_mask - cmp cl, content_pointer - je .value_pointer - - ; Value is a value, so copy into a Cons - call alloc_cons - mov [rax], BYTE cl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - mov rcx, rax ; Key in RCX - jmp .set_pair - -.value_pointer: - mov rcx, [r11 + Cons.car] - ; increment reference count because the value will be - ; released after setting (to allow value Cons to be - ; freed) - - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.set_pair: - ; Here have: - ; map in RSI - ; key in RDI - ; value in RCX - - call map_set - - mov r8, rsi ; map - mov rsi, rdi ; key - call release_object - mov rsi, rcx ; value - call release_object - mov rsi, r8 ; map - - ; Check if there's another pair - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .done - - ; got another pair - mov r11, [r11 + Cons.cdr] - jmp .loop - -.done: - mov rax, rsi ; new map - ret - -.not_map: - load_static core_assoc_not_map - jmp core_throw_str - -.missing_value: - load_static core_assoc_missing_value - jmp core_throw_str - - -;; Removes keys from a map by making -;; a copy of a map without the given keys -core_dissoc: - ; Check that the first argument is a map - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .not_map - - mov r8, [rsi + Cons.car] ; Map in R8 - mov al, BYTE [r8] - mov ah, al - and al, container_mask - cmp al, container_map - jne .not_map - - ; Check if the map is empty - cmp ah, maltype_empty_map - je .inc_and_return - - ; Now check if there are other arguments - - mov al, [rsi + Cons.typecdr] - cmp al, content_pointer - je .start - -.inc_and_return: - ; No keys to remove - ; just increment the map reference count and return - mov rsi, r8 - call incref_object - mov rax, rsi - ret - -.start: - ; Some keys to remove - mov r9, [rsi + Cons.cdr] - - ; R9 now contains a list of keys - ; R8 contains the map to copy - - xor r11, r11 ; Head of list to return - ; R12 contains tail - -.loop: - ; Check the key in R8 against the list in R9 - mov r10, r9 ; point in list being searched - - ; loop through the list in R10 - ; comparing each element against R8 -.search_loop: - mov rsi, r8 - mov rdi, r10 - call compare_objects - test rax, rax - jz .found ; objects are equal - - ; Not found so check next in list - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .not_found ; End of list - - mov r10, [r10 + Cons.cdr] ; next - jmp .search_loop - -.found: - ; Removing this key, so skip - mov al, BYTE [r8 + Cons.typecdr] - cmp al, content_pointer - jne .missing_value - - mov r8, [r8 + Cons.cdr] ; now a value - jmp .next - -.not_found: - ; Key not in list, so keeping - ; Create a Cons to copy - call alloc_cons - mov bl, [r8] - mov rcx, [r8 + Cons.car] - - mov [rax], BYTE bl - mov [rax + Cons.car], rcx - - ; Check if a pointer or value - and bl, content_mask - cmp bl, content_pointer - jne .done_key ; A value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.done_key: - ; append to list - - test r11, r11 - jnz .key_append - - ; First one - mov r11, rax - mov r12, rax - jmp .copy_value -.key_append: - - mov [r12 + Cons.typecdr], BYTE content_pointer - mov [r12 + Cons.cdr], rax - mov r12, rax - -.copy_value: - - ; Check there is a value - mov al, BYTE [r8 + Cons.typecdr] - cmp al, content_pointer - jne .missing_value - - mov r8, [r8 + Cons.cdr] ; Value - - ; Same as for key; create a Cons and copy - call alloc_cons - mov bl, [r8] - mov rcx, [r8 + Cons.car] - - mov [rax], BYTE bl - mov [rax + Cons.car], rcx - - ; Check if a pointer or value - and bl, content_mask - cmp bl, content_pointer - jne .done_value ; A value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.done_value: - ; append to list - mov [r12 + Cons.typecdr], BYTE content_pointer - mov [r12 + Cons.cdr], rax - mov r12, rax - -.next: - ; Here R8 contains a value - - ; Check if there's another key - mov al, [r8 + Cons.typecdr] - cmp al, content_pointer - jne .done - - ; Still more - - mov r8, [r8 + Cons.cdr] - jmp .loop - -.done: - ; Check if the map is empty - test r11, r11 - jz .return_empty - - ; not empty, so return - mov rax, r11 - ret - -.return_empty: - call alloc_cons - mov [rax], BYTE maltype_empty_map - ret - -.not_map: - load_static core_dissoc_not_map - jmp core_throw_str - -.missing_value: - load_static core_dissoc_missing_value - jmp core_throw_str - - -;; Takes a string prompt for the user, and returns -;; a string or nil -core_readline: - ; Check the input - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .no_prompt - - mov rsi, [rsi + Cons.car] - mov al, BYTE [rsi] - cmp al, maltype_string - jne .no_prompt - - ; Got a string in RSI - call print_string - -.no_prompt: - - ; Get string from user - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .return_nil - - ; return the string in RAX - ret - -.return_nil: - ; release string in RAX - mov rsi, rax - call release_array - - call alloc_cons - mov [rax], BYTE maltype_nil - ret - - -;; Return the meta data associated with a given function -core_meta: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .return_nil - - mov rsi, [rsi + Cons.car] - mov al, BYTE [rsi] - cmp al, (block_cons + container_function + content_function) - jne .return_nil - - ; Here got a function - mov rsi, [rsi + Cons.cdr] - - ; RSI should now contain the meta data - mov cl, BYTE [rsi] - and cl, content_mask - cmp cl, content_pointer - je .pointer - - ; A value, so copy - call alloc_cons - mov [rax], BYTE cl - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx - ret - -.pointer: - ; A pointer, so increment reference count and return - mov rsi, [rsi + Cons.car] - call incref_object - mov rax, rsi - ret - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - ret - - -;; Associates a value with a function (native or user) -core_with_meta: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .no_function - - mov r8, [rsi + Cons.car] ; Function in R8 - mov al, BYTE [r8] - cmp al, (block_cons + container_function + content_function) - jne .no_function - - mov bl, BYTE [rsi + Cons.typecdr] - cmp bl, content_pointer - jne .no_value - - mov rsi, [rsi + Cons.cdr] - - ; Function in R8, new value in RSI - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_function) ; Type - mov rbx, [r8 + Cons.car] - mov [rax + Cons.car], rbx ; Function address - - mov r10, rax ; Return address - - ; Copy the meta data - - mov r8, [r8 + Cons.cdr] ; R8 now old meta data (not used) - - call alloc_cons - - mov cl, BYTE [rsi] - and cl, content_mask - mov ch, cl - or cl, container_function - mov [rax], BYTE cl ; Set type - - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; Copy value - - ; append to function - mov [r10 + Cons.typecdr], BYTE content_pointer - mov [r10 + Cons.cdr], rax - mov r11, rax - - ; Check if meta is a value or pointer - cmp ch, content_pointer - jne .copy_rest - - ; increment reference count of meta - mov cx, WORD [rbx + Cons.refcount] - inc cx - mov [rbx + Cons.refcount], WORD cx - -.copy_rest: - ; Copy remainder of function (if any) - ; If a user function, has (env binds body) - mov al, [r8 + Cons.typecdr] - cmp al, content_pointer - jne .done - - ; Still more to copy - mov r8, [r8 + Cons.cdr] - - call alloc_cons - mov bl, BYTE [r8] - mov [rax], BYTE bl ; Copy type - mov rcx, [r8 + Cons.car] - mov [rax + Cons.car], rcx ; Copy value - - ; append - mov [r11 + Cons.typecdr], BYTE content_pointer - mov [r11 + Cons.cdr], rax - mov r11, rax - - ; Check if it's a pointer - and bl, content_mask - cmp bl, content_pointer - jne .copy_rest - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - jmp .copy_rest - -.done: - mov rax, r10 - ret - -.no_function: - load_static core_with_meta_no_function - jmp core_throw_str - -.no_value: - load_static core_with_meta_no_value - jmp core_throw_str - - -;; Returns the current time in ms -core_time_ms: - call clock_time_ms - mov rsi, rax - - call alloc_cons - mov [rax], BYTE maltype_integer - mov [rax + Cons.car], rsi - ret - -;; Convert sequences, including strings, into lists -core_seq: - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - je .pointer - - cmp al, content_empty - je .missing_arg - - cmp al, content_nil - jne .wrong_type - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - ret - -.pointer: - mov r8, [rsi + Cons.car] - mov al, BYTE [r8] - - cmp al, maltype_string - je .string - - mov ah, al - and ah, (block_mask + content_mask) - cmp ah, (block_cons + content_empty) - je .return_nil - - and al, (block_mask + container_mask) - - cmp al, (block_cons + container_list) - je .list - - cmp al, (block_cons + container_vector) - jne .wrong_type - - ; Convert vector to list by replacing the first Cons - call alloc_cons - mov bl, BYTE [r8] - and bl, content_mask - or bl, container_list - mov [rax], BYTE bl ; Set type - - mov rcx, [r8 + Cons.car] - mov [rax + Cons.car], rcx - - ; Check if it's a pointer - cmp bl, (container_list + content_pointer) - jne .copy_cdr - - ; Increment reference count - mov bx, WORD [rcx + Cons.refcount] ; Same for Array - inc bx - mov [rcx + Cons.refcount], WORD bx - -.copy_cdr: - mov rcx, [r8 + Cons.cdr] - mov [rax + Cons.cdr], rcx - - mov bl, [r8 + Cons.typecdr] - mov [rax + Cons.typecdr], bl - - cmp bl, content_pointer - jne .return - - ; Increment reference count - mov bx, WORD [rcx + Cons.refcount] ; Same for Array - inc bx - mov [rcx + Cons.refcount], WORD bx - -.return: - ret - -.list: - ; Return list unchanged - mov rsi, r8 - call incref_object - mov rax, r8 - ret - -.string: - ; Split a string into characters - ; Input string in R8 - - mov ebx, DWORD [r8 + Array.length] - test ebx,ebx - jz .return_nil ; empty string - - ; Not empty, so allocate first Cons - call alloc_cons - mov r9, rax ; Return Cons in R9 - mov r10, rax ; End of list in R10 - -.loop: - mov ebx, DWORD [r8 + Array.length] - mov r11, r8 - add r11, Array.data ; Start of string data in R11 - mov r12, r11 - add r12, rbx ; End of string data in R12 - -.inner_loop: - ; Get a new string - call string_new ; in RAX - mov bl, BYTE [r11] ; Get the next character - mov [rax + Array.data], BYTE bl - mov [rax + Array.length], DWORD 1 - - ; Put string into Cons at end of list - mov [r10 + Cons.car], rax - - ; Set type - mov [r10], BYTE (container_list + content_pointer) - - inc r11 - cmp r11, r12 - je .inner_done - - ; more characters, so allocate another Cons - call alloc_cons - - mov [r10 + Cons.typecdr], BYTE content_pointer - mov [r10 + Cons.cdr], rax - mov r10, rax - jmp .inner_loop - -.inner_done: - ; No more characters in this Array - ; check if there are more - mov r8, QWORD [r8 + Array.next] ; Get the next Array address - test r8, r8 ; Test if it's null - jz .string_finished - - ; Another chunk in the string - - call alloc_cons - mov [r10 + Cons.typecdr], BYTE content_pointer - mov [r10 + Cons.cdr], rax - mov r10, rax - jmp .loop - -.string_finished: - mov rax, r9 - ret - -.missing_arg: - ; No arguments - load_static core_seq_missing_arg - jmp core_throw_str - -.wrong_type: - ; Not a list, vector, string or nil - load_static core_seq_wrong_type - jmp core_throw_str - +;; Core functions +;; +;; + +%include "macros.mac" + +section .data + +;; Symbols for comparison + static core_add_symbol, db "+" + static core_sub_symbol, db "-" + static core_mul_symbol, db "*" + static core_div_symbol, db "/" + + static core_listp_symbol, db "list?" + static core_emptyp_symbol, db "empty?" + + static core_equal_symbol, db "=" + static core_gt_symbol, db ">" + static core_lt_symbol, db "<" + static core_ge_symbol, db ">=" + static core_le_symbol, db "<=" + + static core_count_symbol, db "count" + static core_keys_symbol, db "keys" + static core_vals_symbol, db "vals" + + static core_list_symbol, db "list" + + static core_pr_str_symbol, db "pr-str" + static core_prn_symbol, db "prn" + static core_str_symbol, db "str" + static core_println_symbol, db "println" + + static core_read_string_symbol, db "read-string" + static core_slurp_symbol, db "slurp" + static core_eval_symbol, db "eval" + + static core_atom_symbol, db "atom" + static core_deref_symbol, db "deref" + static core_atomp_symbol, db "atom?" + static core_reset_symbol, db "reset!" + static core_swap_symbol, db "swap!" + + static core_cons_symbol, db "cons" + static core_concat_symbol, db "concat" + static core_vec_symbol, db "vec" + + static core_first_symbol, db "first" + static core_rest_symbol, db "rest" + static core_nth_symbol, db "nth" + + static core_nilp_symbol, db "nil?" + static core_truep_symbol, db "true?" + static core_falsep_symbol, db "false?" + static core_numberp_symbol, db "number?" + + static core_symbolp_symbol, db "symbol?" + static core_stringp_symbol, db "string?" + static core_fnp_symbol, db "fn?" + static core_macrop_symbol, db "macro?" + static core_keywordp_symbol, db "keyword?" + + static core_containsp_symbol, db "contains?" + static core_get_symbol, db "get" + static core_vectorp_symbol, db "vector?" + static core_mapp_symbol, db "map?" + static core_sequentialp_symbol, db "sequential?" + + static core_throw_symbol, db "throw" + + static core_map_symbol, db "map" + static core_apply_symbol, db "apply" + + static core_symbol_symbol, db "symbol" + static core_vector_symbol, db "vector" + static core_hashmap_symbol, db "hash-map" + static core_keyword_symbol, db "keyword" + + static core_assoc_symbol, db "assoc" + static core_dissoc_symbol, db "dissoc" + + static core_readline_symbol, db "readline" + + static core_meta_symbol, db "meta" + static core_with_meta_symbol, db "with-meta" + + static core_time_ms_symbol, db "time-ms" + + static core_seq_symbol, db "seq" + +;; Strings + + static core_arith_missing_args, db "integer arithmetic missing arguments" + static core_arith_not_int, db "non-integer argument to integer arithmetic" + + static core_emptyp_error_string, db "empty? expects a list, vector or map",10 + static core_count_error_string, db "count expects a list or vector",10 + + static core_keys_not_map, db "keys expects a map as first argument" + static core_vals_not_map, db "vals expects a map as first argument" + + static core_numeric_expect_ints, db "comparison operator expected two numbers",10 + + static core_deref_not_atom, db "Error: argument to deref is not an atom" + static core_reset_not_atom, db "Error: argument to reset is not an atom" + static core_reset_no_value, db "Error: missing value argument to reset" + + static core_swap_not_atom, db "Error: swap! expects atom as first argument" + static core_swap_no_function, db "Error: swap! expects function as second argument" + + static core_cons_missing_arg, db "Error: missing argument to cons" + static core_cons_not_vector, db "Error: cons expects a list or vector" + + static core_concat_not_list, db "Error: concat expects lists or vectors" + + static core_vec_wrong_arg, db "Error: vec expects a list or vector " + + static core_first_missing_arg, db "Error: missing argument to first" + static core_first_not_list, db "Error: first expects a list or vector" + + static core_rest_missing_arg, db "Error: missing argument to rest" + static core_rest_not_list, db "Error: rest expects a list or vector" + + static core_nth_missing_arg, db "Error: missing argument to nth" + static core_nth_not_list, db "Error: nth expects a list or vector as first argument" + static core_nth_not_int, db "Error: nth expects an integer as second argument" + static core_nth_out_of_range, db "Error: nth index out of range" + + static core_value_p_missing_args, db "Error: value predicate (nil/true/false) missing args" + + static core_containsp_not_map, db "Error: contains? expects map as first argument" + static core_containsp_no_key, db "Error: contains? missing key argument" + + static core_get_not_map, db "Error: get expects map as first argument" + static core_get_no_key, db "Error: get missing key argument" + + static core_map_missing_args, db "Error: map expects two arguments (function, list/vector)" + static core_map_not_function, db "Error: map expects a ufunction for first argument" + static core_map_not_seq, db "Error: map expects a list or vector as second argument" + + static core_apply_not_function, db "Error: apply expects function as first argument" + static core_apply_missing_args, db "Error: apply missing arguments" + static core_apply_not_seq, db "Error: apply last argument must be list or vector" + + static core_symbol_not_string, db "Error: symbol expects a string argument" + + static core_keyword_not_string, db "Error: keyword expects a string or keyword argument" + + static core_list_not_seq, db "Error: list expects a list or vector" + + static core_assoc_not_map, db "Error: assoc expects a map as first argument" + static core_assoc_missing_value, db "Error: assoc missing value" + + static core_dissoc_not_map, db "dissoc expects a map as first argument" + static core_dissoc_missing_value, db "Missing value in map passed to dissoc" + + static core_with_meta_no_function, db "with-meta expects a function as first argument" + static core_with_meta_no_value, db "with-meta expects a value as second argument" + + static core_seq_missing_arg, db "seq missing argument" + static core_seq_wrong_type, db "seq expects a list, vector, string or nil" + +section .text + +;; Add a native function to the core environment +;; This is used in core_environment +%macro core_env_native 2 + push rsi ; environment + mov rsi, %1 + mov edx, %1.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, %2 + call native_function ; Function in RAX + + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call env_set +%endmacro + + +;; Create an Environment with core functions +;; +;; Returns Environment in RAX +;; +;; +core_environment: + ; Create the top-level environment + xor rsi, rsi ; Set outer to nil + call env_new + mov rsi, rax ; Environment in RSI + + core_env_native core_cons_symbol, core_cons + core_env_native core_concat_symbol, core_concat + core_env_native core_vec_symbol, core_vec + + core_env_native core_first_symbol, core_first + core_env_native core_rest_symbol, core_rest + core_env_native core_nth_symbol, core_nth + + core_env_native core_add_symbol, core_add + core_env_native core_sub_symbol, core_sub + core_env_native core_mul_symbol, core_mul + core_env_native core_div_symbol, core_div + + core_env_native core_listp_symbol, core_listp + core_env_native core_emptyp_symbol, core_emptyp + core_env_native core_count_symbol, core_count + + core_env_native core_equal_symbol, core_equalp + core_env_native core_gt_symbol, core_gt + core_env_native core_lt_symbol, core_lt + core_env_native core_ge_symbol, core_ge + core_env_native core_le_symbol, core_le + + core_env_native core_keys_symbol, core_keys + core_env_native core_vals_symbol, core_vals + + core_env_native core_list_symbol, core_list + + core_env_native core_pr_str_symbol, core_pr_str + core_env_native core_prn_symbol, core_prn + core_env_native core_str_symbol, core_str + core_env_native core_println_symbol, core_println + + core_env_native core_read_string_symbol, core_read_string + core_env_native core_slurp_symbol, core_slurp + core_env_native core_eval_symbol, core_eval + + core_env_native core_atom_symbol, core_atom + core_env_native core_deref_symbol, core_deref + core_env_native core_atomp_symbol, core_atomp + core_env_native core_reset_symbol, core_reset + core_env_native core_swap_symbol, core_swap + + core_env_native core_nilp_symbol, core_nilp + core_env_native core_truep_symbol, core_truep + core_env_native core_falsep_symbol, core_falsep + core_env_native core_numberp_symbol, core_numberp + + core_env_native core_symbolp_symbol, core_symbolp + core_env_native core_stringp_symbol, core_stringp + core_env_native core_fnp_symbol, core_fnp + core_env_native core_macrop_symbol, core_macrop + core_env_native core_keywordp_symbol, core_keywordp + + core_env_native core_containsp_symbol, core_containsp + core_env_native core_get_symbol, core_get + + core_env_native core_vectorp_symbol, core_vectorp + core_env_native core_mapp_symbol, core_mapp + core_env_native core_sequentialp_symbol, core_sequentialp + + core_env_native core_throw_symbol, core_throw + + core_env_native core_map_symbol, core_map + core_env_native core_apply_symbol, core_apply + + core_env_native core_symbol_symbol, core_symbol + core_env_native core_vector_symbol, core_vector + core_env_native core_hashmap_symbol, core_hashmap + core_env_native core_keyword_symbol, core_keyword + + core_env_native core_assoc_symbol, core_assoc + core_env_native core_dissoc_symbol, core_dissoc + + core_env_native core_readline_symbol, core_readline + + core_env_native core_meta_symbol, core_meta + core_env_native core_with_meta_symbol, core_with_meta + + core_env_native core_time_ms_symbol, core_time_ms + + core_env_native core_seq_symbol, core_seq + + ; ----------------- + ; Put the environment in RAX + mov rax, rsi + ret + +;; ---------------------------------------------------- + +;; Jumped to from many core functions, with +;; string address in RSI and length in EDX +core_throw_str: + call raw_to_string + mov rsi, rax + jmp error_throw + +;; ---------------------------------------------------- + + + +;; Integer arithmetic operations +;; +;; Adds a list of numbers, address in RSI +;; Returns the sum as a number object with address in RAX +;; Since most of the code is common to all operators, +;; RBX is used to jump to the required instruction +core_add: + mov rbx, core_arithmetic.do_addition + jmp core_arithmetic +core_sub: + mov rbx, core_arithmetic.do_subtraction + jmp core_arithmetic +core_mul: + mov rbx, core_arithmetic.do_multiply + jmp core_arithmetic +core_div: + mov rbx, core_arithmetic.do_division + ; Fall through to core_arithmetic +core_arithmetic: + ; Check that the first object is a number + mov cl, BYTE [rsi] + mov ch, cl + and ch, block_mask + cmp ch, block_cons + jne .missing_args + + mov ch, cl + and ch, content_mask + cmp ch, content_empty + je .missing_args + + cmp ch, content_int + jne .not_int + + ; Put the starting value in rax + mov rax, [rsi + Cons.car] + +.add_loop: + ; Fetch the next value + mov cl, [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .finished ; Nothing let + + mov rsi, [rsi + Cons.cdr] ; Get next cons + + ; Check that it is an integer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_int + jne .not_int + + ; Jump to the required operation, address in RBX + jmp rbx + +.do_addition: + add rax, [rsi + Cons.car] + jmp .add_loop +.do_subtraction: + sub rax, [rsi + Cons.car] + jmp .add_loop +.do_multiply: + imul rax, [rsi + Cons.car] + jmp .add_loop +.do_division: + cqo ; Sign extend RAX into RDX + mov rcx, [rsi + Cons.car] + idiv rcx + jmp .add_loop + +.finished: + ; Value in rbx + push rax + ; Get a Cons object to put the result into + call alloc_cons + pop rbx + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rbx + ret + +.missing_args: + load_static core_arith_missing_args + jmp core_throw_str +.not_int: + load_static core_arith_not_int + jmp core_throw_str + +;; compare objects for equality +core_equalp: + ; Check that rsi contains a list + mov cl, BYTE [rsi] + cmp cl, maltype_empty_list + je .error + + and cl, block_mask + container_mask + cmp cl, block_cons + container_list + jne .error + + ; Check that the list has a second pointer + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .error + + ; move second pointer into rdi + mov rdi, [rsi + Cons.cdr] + + ; Remove next pointers + mov cl, BYTE [rsi + Cons.typecdr] + mov [rsi + Cons.typecdr], BYTE 0 + + mov bl, BYTE [rdi + Cons.typecdr] + mov [rdi + Cons.typecdr], BYTE 0 + + push rbx + push rcx + + ; Compare the objects recursively + call compare_objects_rec + + ; Restore next pointers + pop rcx + pop rbx + mov [rsi + Cons.typecdr], BYTE cl + mov [rdi + Cons.typecdr], BYTE bl + + je .true + + +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret +.true: + call alloc_cons + mov [rax], BYTE maltype_true + ret +.error: + push rsi + print_str_mac error_string ; print 'Error: ' + pop rsi + jmp error_throw + +;; ----------------------------------------------------------------- +;; Numerical comparisons + + +core_gt: + mov rcx, core_compare_num.gt + jmp core_compare_num +core_lt: + mov rcx, core_compare_num.lt + jmp core_compare_num +core_ge: + mov rcx, core_compare_num.ge + jmp core_compare_num +core_le: + mov rcx, core_compare_num.le + ;jmp core_compare_num +core_compare_num: + ; The first argument should be an int + mov al, BYTE [rsi] + and al, content_mask + cmp al, maltype_integer + jne .error + + ; Check that there's a second argument + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .error + mov rax, [rsi + Cons.car] + mov rdi, [rsi + Cons.cdr] + + ; The second arg should also be an int + mov bl, BYTE [rdi] + and bl, content_mask + cmp bl, maltype_integer + jne .error + + mov rbx, [rdi + Cons.car] + + cmp rax, rbx + jmp rcx ; Address set above +.gt: + jg .true + jmp .false +.lt: + jl .true + jmp .false +.ge: + jge .true + jmp .false +.le: + jle .true + ;jmp .false +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret +.true: + call alloc_cons + mov [rax], BYTE maltype_true + ret +.error: + push rsi + print_str_mac error_string ; print 'Error: ' + print_str_mac core_numeric_expect_ints + pop rsi + jmp error_throw + +;; Test if a given object is a list +;; Input list in RSI +;; Returns true or false in RAX +core_listp: + mov bl, (block_cons + container_list) + jmp core_container_p +core_vectorp: + mov bl, (block_cons + container_vector) + jmp core_container_p +core_mapp: + mov bl, (block_cons + container_map) + ;jmp core_container_p +core_container_p: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .false ; Should be a pointer to a list + + mov rax, [rsi + Cons.car] + mov al, BYTE [rax] + and al, (block_mask + container_mask) + cmp al, bl + jne .false + + ; Is a list, return true + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret + +;; Return true if vector or list +core_sequentialp: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .false ; Should be a pointer + + mov rax, [rsi + Cons.car] + mov al, BYTE [rax] + and al, (block_mask + container_mask) + cmp al, container_list + je .true + cmp al, container_vector + jne .false +.true: + ; Is a list or vector, return true + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret + + + +;; Test if the given list, vector or map is empty +core_emptyp: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .error ; Expected a container + mov rax, [rsi + Cons.car] + mov al, BYTE [rax] + cmp al, maltype_empty_list + je .true + cmp al, maltype_empty_vector + je .true + cmp al, maltype_empty_map + je .true + + ; false + call alloc_cons + mov [rax], BYTE maltype_false + ret +.true: + call alloc_cons + mov [rax], BYTE maltype_true + ret +.error: + push rsi + print_str_mac error_string + print_str_mac core_emptyp_error_string + pop rsi + jmp error_throw + +;; Count the number of elements in given list or vector +core_count: + mov al, BYTE [rsi] + and al, content_mask + + cmp al, content_nil + je .zero + + cmp al, content_pointer + jne .error ; Expected a container + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + + mov ah, al + and ah, (block_mask + container_mask) + cmp ah, (block_cons + container_list) + je .start_count + cmp ah, (block_cons + container_vector) + je .start_count + + jmp .error ; Not a list or vector + +.start_count: + + xor rbx,rbx + mov ah, al + and ah, content_mask + cmp ah, content_empty + je .done ; Empty list or vector + +.loop: + inc rbx + + ; Check if there's another + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done + + mov rsi, [rsi + Cons.cdr] + jmp .loop + +.zero: ; Return zero count + mov rbx, 0 +.done: ; Count is in RBX + + push rbx + call alloc_cons + pop rbx + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rbx + ret + +.error: + push rsi + print_str_mac error_string + print_str_mac core_count_error_string + pop rsi + jmp error_throw + + +;; Given a map, returns a list of keys +;; Input: List in RSI with one Map element +;; Returns: List in RAX +core_keys: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_map + + mov rsi, [rsi + Cons.car] + call map_keys + ret +.not_map: + load_static core_keys_not_map + jmp core_throw_str + +;; Get a list of values from a map +core_vals: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_map + + mov rsi, [rsi + Cons.car] + call map_vals + ret +.not_map: + load_static core_vals_not_map + jmp core_throw_str + +;; Given a map and a key, return true if the key is in the map +;; +core_containsp: + ; Check the type of the first argument + mov bl, BYTE [rsi] + and bl, content_mask + cmp bl, content_pointer + jne .not_map + + mov rcx, [rsi + Cons.car] ; Map in RCX + mov bl, BYTE [rcx] + and bl, (block_mask + container_mask) + cmp bl, container_map + jne .not_map + + ; Check second argument + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_key + mov rsi, [rsi + Cons.cdr] + mov dl, BYTE [rsi] + and dl, content_mask + cmp dl, content_pointer + jne .key_value + + ; Pointer, so put into RDI + mov rdi, [rsi + Cons.car] + jmp .find + +.key_value: + ; A value + mov [rsi], BYTE dl + mov rdi, rsi ; Value in RDI + +.find: + mov rsi, rcx ; Map + call map_find + je .true + + ; false + call alloc_cons + mov [rax], BYTE maltype_false + ret +.true: + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.not_map: + load_static core_containsp_not_map + jmp core_throw_str +.no_key: + load_static core_containsp_no_key + jmp core_throw_str + + +;; Given a map and a key, return the value in the map +;; or nil if not found +;; +core_get: + ; Check the type of the first argument + mov bl, BYTE [rsi] + + and bl, content_mask + + cmp bl, content_nil + je .not_found + + cmp bl, content_pointer + jne .not_map + + mov rcx, [rsi + Cons.car] ; Map in RCX + mov bl, BYTE [rcx] + and bl, (block_mask + container_mask) + cmp bl, container_map + jne .not_map + + ; Check second argument + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_key + mov rsi, [rsi + Cons.cdr] + + mov dl, BYTE [rsi] + and dl, content_mask + cmp dl, content_pointer + jne .key_value + + ; Pointer, so put into RDI + mov rdi, [rsi + Cons.car] + jmp .find + +.key_value: + ; A value + mov [rsi], BYTE dl + mov rdi, rsi ; Value in RDI + +.find: + mov rsi, rcx ; Map + call map_get ; Value in RAX + je .found + +.not_found: + ; Not found + call alloc_cons + mov [rax], BYTE maltype_nil + ret +.found: + ret + +.not_map: + load_static core_get_not_map + jmp core_throw_str +.no_key: + load_static core_get_no_key + jmp core_throw_str + + +;; Return arguments as a list +;; +core_list: + call incref_object + mov rax, rsi + ret + +;; Convert arguments into a vector +core_vector: + ; Copy first element and mark as vector + call alloc_cons ; in RAX + mov bl, BYTE [rsi] + and bl, content_mask + mov bh, bl ; store content for comparison + or bl, container_vector + mov [rax], BYTE bl ; Set type + + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx ; Set content + + ; Check if the first element is a pointer + cmp bh, content_pointer + jne .done_car + + ; A pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_car: + ; Copy the CDR type and content + mov bl, [rsi + Cons.typecdr] + mov [rax + Cons.typecdr], bl + + mov rdx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rdx + + cmp bl, content_pointer + jne .done + + ; A pointer + mov bx, WORD [rdx + Cons.refcount] + inc bx + mov [rdx + Cons.refcount], WORD bx + +.done: + ret + + +;; Convert arguments into a map +core_hashmap: + ; Copy first element and mark as map + call alloc_cons ; in RAX + mov bl, BYTE [rsi] + and bl, content_mask + mov bh, bl ; store content for comparison + or bl, container_map + mov [rax], BYTE bl ; Set type + + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx ; Set content + + ; Check if the first element is a pointer + cmp bh, content_pointer + jne .done_car + + ; A pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_car: + ; Copy the CDR type and content + mov bl, [rsi + Cons.typecdr] + mov [rax + Cons.typecdr], bl + + mov rdx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rdx + + cmp bl, content_pointer + jne .done + + ; A pointer + mov bx, WORD [rdx + Cons.refcount] + inc bx + mov [rdx + Cons.refcount], WORD bx + +.done: + ret + +;; ------------------------------------------------ +;; String functions + +;; Convert arguments to a readable string, separated by a space +;; +core_pr_str: + mov rdi, 3 ; print_readably & separator + jmp core_str_functions +core_str: + xor rdi, rdi + jmp core_str_functions +core_str_sep: + mov rdi, 2 ; separator + +core_str_functions: + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_empty + je .empty ; Nothing to print + + xor r8, r8 ; Return string in r8 + +.loop: + cmp ah, content_pointer + je .got_pointer + + ; A value. Remove list container + xchg ah, al + mov [rsi], BYTE al + xchg ah, al + push rsi + push rax + push r8 + call pr_str + pop r8 + pop rbx + pop rsi + mov [rsi], BYTE bl ; restore type + jmp .got_string + +.got_pointer: + push rsi + push r8 + mov rsi, [rsi + Cons.car] ; Address pointed to + call pr_str + pop r8 + pop rsi + +.got_string: + ; String now in rax + + cmp r8, 0 + jne .append + + ; first string. Since this string will be + ; appended to, it needs to be a copy + push rsi ; input + + push rax ; string to copy + mov rsi, rax + call string_copy ; New string in RAX + pop rsi ; copied string + + push rax ; the copy + call release_object ; release the copied string + pop r8 ; the copy + + pop rsi ; input + + jmp .next + +.append: + push r8 + push rsi + push rax + + mov rsi, r8 ; Output string + mov rdx, rax ; String to be copied + call string_append_string + + pop rsi ; Was in rax, temporary string + call release_array ; Release the string + + pop rsi ; Restore input + pop r8 ; Output string +.next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done + + ; More inputs + mov rsi, [rsi + Cons.cdr] ; pointer + + test rdi, 2 ; print_readably + jz .end_append_char ; No separator + + ; Add separator + push r8 + push rsi + mov rsi, r8 + mov cl, ' ' + call string_append_char + pop rsi + pop r8 +.end_append_char: + + ; Get the type in ah for comparison at start of loop + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + + jmp .loop +.done: + ; No more input, so return + mov rax, r8 + ret + +.empty: + call string_new ; An empty string + ret + +;; Print arguments readably, return nil +core_prn: + call core_pr_str + jmp core_prn_functions +core_println: + call core_str_sep +core_prn_functions: + mov rsi, rax + + ; Put newline at the end + push rsi + mov cl, 10 ; newline + call string_append_char + pop rsi + + ; print the string + push rsi ; Save the string address + call print_string + pop rsi + call release_array ; Release the string + + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +;; Given a string, calls read_str to get an AST +core_read_string: + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + jne .no_string + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, maltype_string + jne .no_string + + call read_str + ret + +.no_string: + ; Didn't get a string input + call alloc_cons + mov [rax], BYTE maltype_nil + ret + + +;; Reads a file into a string +core_slurp: + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + jne .no_string + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, maltype_string + jne .no_string + + call read_file + ret + +.no_string: + ; Didn't get a string input + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +;; Evaluate an expression in the REPL environment +;; +core_eval: + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .pointer + + ; Just a value, so return it + call incref_object + + mov al, BYTE [rsi] + and al, content_mask + mov [rsi], BYTE al ; Removes list + mov rax, rsi + ret + +.pointer: + ; A pointer, so need to eval + mov rdi, [rsi + Cons.car] + + mov rsi, [repl_env] ; Environment + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval + ret + +;; Create an atom +core_atom: + push rsi + call alloc_cons ; To hold the pointer + pop rsi + mov [rax], BYTE maltype_atom + + ; Check the type of the first argument + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + je .pointer + + ; A value + + ; make a copy + push rax + push rsi + push rbx + call alloc_cons + pop rbx + + mov bl, bh + mov [rax], BYTE bl ; Set type + + mov rbx, rax + pop rsi + pop rax + + mov rcx, [rsi + Cons.car] + mov [rbx + Cons.car], rcx ; Set value + + ; Set the atom to point to it + mov [rax + Cons.car], rbx + + ret + +.pointer: + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + + push rax + mov rsi, rbx + call incref_object ; Storing in atom + pop rax + ret + +;; Get the value from the atom +core_deref: + ; Check the type of the first argument + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .not_atom + + ; Get the atom + mov rsi, [rsi + Cons.car] + mov bl, BYTE [rsi] + cmp bl, maltype_atom + jne .not_atom + + ; Return what it points to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + +.not_atom: + ; Not an atom, so throw an error + mov rsi, core_deref_not_atom + mov edx, core_deref_not_atom.len + call raw_to_symbol + mov rsi, rax + jmp error_throw + +;; Test if given object is an atom +core_atomp: + mov al, maltype_atom + jmp core_pointer_type_p +core_symbolp: + mov al, maltype_symbol + jmp core_pointer_type_p +core_stringp: + mov al, maltype_string + jmp core_pointer_type_p +core_fnp: + mov al, maltype_function + jmp core_pointer_type_p +core_macrop: + mov al, maltype_macro + jmp core_pointer_type_p + +core_pointer_type_p: + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .false + + mov rsi, [rsi + Cons.car] + mov bl, BYTE [rsi] + cmp bl, al + jne .false + + ; Check for keyword (not symbol) + cmp al, maltype_symbol + jne .true + + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .false ; a keyword + +.true: + ; Return true + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret + +;; Tests if argument is a keyword +core_keywordp: + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .false + + mov rsi, [rsi + Cons.car] + mov bl, BYTE [rsi] + cmp bl, maltype_symbol + jne .false + + ; Check if first character is ':' + mov bl, BYTE [rsi + Array.data] + cmp bl, ':' + jne .false + + ; Return true + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.false: + call alloc_cons + mov [rax], BYTE maltype_false + ret + +;; Change the value of an atom +core_reset: + ; Check the type of the first argument + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .not_atom + + ; Get the atom + mov rax, [rsi + Cons.car] ; Atom in RAX + mov bl, BYTE [rax] + cmp bl, maltype_atom + jne .not_atom + + ; Get the next argument + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_value + + mov rsi, [rsi + Cons.cdr] + + ; Got something in RSI + ; release the current value of the atom + push rax + push rsi + + mov rsi, [rax + Cons.car] ; The value the atom points to + call release_object + + pop rsi + pop rax + + ; Check the type of the first argument + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + je .pointer + + ; A value + + ; make a copy + push rax + push rsi + push rbx + call alloc_cons + pop rbx + + mov bl, bh + mov [rax], BYTE bl ; Set type + + mov rbx, rax + pop rsi + pop rax + + mov rcx, [rsi + Cons.car] + mov [rbx + Cons.car], rcx ; Set value + + ; Set the atom to point to it + mov [rax + Cons.car], rbx + + ; Increment refcount since return value will be released + mov rsi, rbx + call incref_object + mov rax, rsi + ret + +.pointer: + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + + mov rsi, rbx + call incref_object ; Storing in atom + call incref_object ; Returning + mov rax, rsi + ret + +.not_atom: + ; Not an atom, so throw an error + mov rsi, core_reset_not_atom + mov edx, core_reset_not_atom.len + call raw_to_symbol + mov rsi, rax + jmp error_throw + +.no_value: + ; No value given + mov rsi, core_reset_no_value + mov edx, core_reset_no_value.len + call raw_to_symbol + mov rsi, rax + jmp error_throw + +;; Applies a function to an atom, along with optional arguments +;; +;; In RSI should be a list consisting of +;; [ atom, pointer->Function , args...] +;; +;; The atom is dereferenced, and inserted into the list: +;; +;; [ pointer->Function , atom value , args...] +;; +;; This is then passed to eval.list_exec +;; which executes the function +;; +core_swap: + ; Check the type of the first argument (an atom) + mov bl, BYTE [rsi] + mov bh, bl + and bh, content_mask + cmp bh, content_pointer + jne .not_atom + + ; Get the atom + mov r9, [rsi + Cons.car] ; Atom in R9 + mov bl, BYTE [r9] + cmp bl, maltype_atom + jne .not_atom + + ; Get the second argument (a function) + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_function + + mov rsi, [rsi + Cons.cdr] ; List with function first + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .no_function + + mov r8, [rsi + Cons.car] ; Function in R8 + mov al, BYTE [r8] + cmp al, maltype_function + jne .no_function + + ; Get a new Cons + ; containing the value in the atom + call alloc_cons ; In RAX + + ; Prepend to the list + mov bl, BYTE [rsi + Cons.typecdr] + mov [rax + Cons.typecdr], bl + cmp bl, content_pointer + jne .done_prepend + + ; A pointer to more args, + + mov rcx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rcx + + ; increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_prepend: + + ; Now get the value in the atom + mov rdx, [r9 + Cons.car] ; The object pointed to + + ; Check what it is + mov bl, BYTE [rdx] + mov bh, bl + and bh, (block_mask + container_mask) + jz .atom_value ; Just a value + + ; Not a simple value, so point to it + mov [rax + Cons.car], rdx + mov [rax], BYTE (container_list + content_pointer) + + ; Since the list will be released after eval + ; we need to increment the reference count + mov bx, WORD [rdx + Cons.refcount] + inc bx + mov [rdx + Cons.refcount], WORD bx + + jmp .run + +.atom_value: + ; Copy the value + mov rcx, [rdx + Cons.car] + mov [rax + Cons.car], rcx + and bl, content_mask ; keep just the content + or bl, container_list ; mark as part of a list + mov [rax], BYTE bl + +.run: + mov rsi, rax + + ; Here have function in R8, args in RSI + ; Check whether the function is built-in or user + mov rax, [r8 + Cons.car] + cmp rax, apply_fn + je .user_function + + ; A built-in function + push r9 ; atom + push rsi ; Args + + call rax + ; Result in RAX + + pop rsi + pop r9 + + push rax + call release_object ; Release arguments + pop rax + + jmp .got_return + +.user_function: + ; a user-defined function, so need to evaluate + ; RSI - Args + + mov rdi, r8 ; Function in RDI + mov rdx, rsi ; Release args after binding + + mov rsi, r15 ; Environment + call incref_object ; Released by eval + call incref_object ; also released from R13 + mov r13, r15 + + mov rsi, rdx + + push r9 + call apply_fn ; Result in RAX + pop r9 + +.got_return: + ; Have a return result in RAX + + ; release the current value of the atom + push rax ; The result + mov rsi, [r9 + Cons.car] + call release_object + pop rax + + ; Put into atom + mov [r9 + Cons.car], rax + + ; Increase reference of new object + ; because when it is returned it will be released + mov bx, WORD [rax + Cons.refcount] + inc bx + mov [rax + Cons.refcount], WORD bx + + ret + +.not_atom: + load_static core_swap_not_atom + jmp core_throw_str +.no_function: + load_static core_swap_no_function + jmp core_throw_str + + +;; Takes two arguments, and prepends the first argument onto the second +;; The second argument can be a list or a vector, but the return is always +;; a list +core_cons: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + mov r8, rsi ; The object to prepend + + ; Check if there's a second argument + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .missing_args + + mov rsi, [rsi + Cons.cdr] + + ; Check that the second argument is a list or vector + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_vector + + mov r9, [rsi + Cons.car] ; Should be a list or vector + mov al, BYTE [r9] + and al, container_mask + cmp al, container_list + je .got_args + cmp al, container_vector + je .got_args + jmp .not_vector + +.got_args: + ; Got an object in R8 and list/vector in R9 + + call alloc_cons ; new Cons in RAX + + ; Mark as the same content in a list container + mov bl, BYTE [r8] + and bl, content_mask + mov bh, bl ; Save content in BH for checking if pointer later + or bl, block_cons + container_list + mov [rax], BYTE bl + + ; Copy the content + mov rcx, [r8 + Cons.car] ; Content in RCX + mov [rax + Cons.car], rcx + + ; Check if R9 is empty + mov dl, BYTE [r9] + and dl, content_mask + cmp dl, content_empty + je .end_append ; Don't append the list + + ; Put the list into CDR + mov [rax + Cons.cdr], r9 + ; mark CDR as a pointer + mov [rax + Cons.typecdr], BYTE content_pointer + + ; Increment reference count + push rax + mov rsi, r9 + call incref_object + pop rax + +.end_append: + ; Check if the new Cons contains a pointer + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .done + + ; A pointer, so increment number of references + push rax + mov rsi, rcx + call incref_object + pop rax +.done: + ret + +.missing_args: + load_static core_cons_missing_arg + jmp core_throw_str + +.not_vector: + load_static core_cons_not_vector + jmp core_throw_str + + +;; Concatenate lists, returning a new list +;; +;; Notes: +;; * The last list does not need to be copied, but all others do +;; +core_concat: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + cmp al, content_pointer + jne .not_list + + ; Check if there is only one argument + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + je .start_loop ; Start copy loop + + ; Only one input. + mov rsi, [rsi + Cons.car] + + ; Check if it's a list or vector + mov al, BYTE [rsi] + mov cl, al + and al, container_mask + cmp al, (block_cons + container_list) + je .single_list + + cmp al, (block_cons + container_vector) + jne .not_list ; not a list or vector + + ; A vector. Need to create a new Cons + ; for the first element, to mark it as a list + + call alloc_cons + and cl, content_mask + or cl, container_list + mov [rax], BYTE cl ; Set type + + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Set content + + ; Check if CAR is a pointer + cmp cl, (container_list + content_pointer) + jne .single_done_car + + ; a pointer, so increment reference count + mov cx, WORD [rbx + Cons.refcount] + inc cx + mov [rbx + Cons.refcount], WORD cx + +.single_done_car: + mov dl, BYTE [rsi + Cons.typecdr] + mov [rax + Cons.typecdr], BYTE dl ; CDR type + + mov rbx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rbx ; Set CDR content + + ; Check if CDR is a pointer + cmp dl, content_pointer + je .single_vector_incref + ; not a pointer, just return + ret + +.single_vector_incref: + ; increment the reference count of object pointed to + mov r12, rax ; The return Cons + mov rsi, rbx ; The object address + call incref_object + mov rax, r12 + ret + +.single_list: + ; Just increment reference count and return + + call incref_object + mov rax, rsi + ret + +.start_loop: ; Have at least two inputs + xor r11, r11 ; Head of list. Start in R12 + +.loop: + + ; Check the type + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_list + + ; Check if this is the last + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .last + + ; Check if the list is empty + mov rbx, [rsi + Cons.car] ; The list + mov al, BYTE [rbx] + and al, content_mask + cmp al, content_empty ; If empty list or vector + je .next ; Skip to next + + ; not the last list, so need to copy + + push rsi + mov rsi, rbx ; The list + call cons_seq_copy ; Copy in RAX, last Cons in RBX + pop rsi + + ; Check if this is the first + test r11, r11 + jnz .append + + ; First list + mov r11, rbx ; Last Cons in list + mov r12, rax ; Output list + jmp .next +.append: + ; End of previous list points to start of new list + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + ; Put end of new list into R11 + mov r11, rbx + +.next: + mov rsi, [rsi + Cons.cdr] + jmp .loop + +.last: + ; last list, so can just append + mov rsi, [rsi + Cons.car] + + ; Check if the list is empty + mov al, BYTE [rsi] + mov ah, al + and al, content_mask + cmp al, content_empty ; If empty list or vector + je .done ; Omit the empty list + + call incref_object + + mov [r11 + Cons.cdr], rsi + mov [r11 + Cons.typecdr], BYTE content_pointer +.done: + ; Check there is anything to return + test r11, r11 + jz .empty_list + + ; Make sure that return is a list + mov bl, BYTE [r12] + and bl, content_mask + or bl, container_list + mov [r12], BYTE bl + mov rax, r12 ; output list + + ret + +.empty_list: + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + +.missing_args: + ; Return empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + +.not_list: + ; Got an argument which is not a list + mov rsi, core_concat_not_list + mov edx, core_concat_not_list.len + +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw + +;; Convert a sequence to vector +core_vec: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .error + mov rsi, [rsi + Cons.car] + + mov al, BYTE [rsi] + and al, block_mask + container_mask + + ;; delegate lists to `vector` built-in + cmp al, container_list + je core_vector + + ;; expect a sequence + cmp al, container_vector + jne .error + + ;; return vectors unchanged + call incref_object + mov rax, rsi + ret + +.error + push rsi + print_str_mac error_string + print_str_mac core_vec_wrong_arg + pop rsi + jmp error_throw + +;; Returns the first element of a list +;; +core_first: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + cmp al, content_nil + je .return_nil + + cmp al, content_pointer + jne .not_list + + ; Get the list + mov rsi, [rsi + Cons.car] + + mov al, BYTE [rsi] + + ; Check for nil + cmp al, maltype_nil + je .return_nil + + mov ah, al + and ah, (block_mask + container_mask) + cmp ah, container_list + je .got_list + cmp ah, container_vector + jne .not_list ; Not a list or vector + +.got_list: + ; Check if list is empty + and al, content_mask + cmp al, content_empty + je .return_nil + + cmp al, content_pointer + je .return_pointer + + ; Returning a value, so need to copy + mov cl, al + call alloc_cons + mov [rax], BYTE cl ; Set type + + ; Copy value + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + ret + +.return_pointer: + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.missing_args: + mov rsi, core_first_missing_arg + mov edx, core_first_missing_arg.len + jmp .throw + +.not_list: + mov rsi, core_first_not_list + mov edx, core_first_not_list.len +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw + + +;; Return a list with the first element removed +core_rest: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + cmp al, content_nil + je .empty_list + + cmp al, content_pointer + jne .not_list + + ; Get the list + mov rsi, [rsi + Cons.car] + + mov al, BYTE [rsi] + + ; Check for nil + cmp al, maltype_nil + je .return_nil + + mov ah, al + and ah, (block_mask + container_mask) + cmp ah, container_list + je .got_list + cmp ah, container_vector + jne .not_list ; Not a list or vector + +.got_list: + ; Check if list or vector is empty + and al, content_mask + cmp al, content_empty + je .empty_list + + ; Check if there is more in the list + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + je .return_rest + + ; No more list, so return empty list +.empty_list: + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + +.return_rest: + + mov rsi, [rsi + Cons.cdr] + + + + ; Check if this is a list or a vector + mov cl, BYTE [rsi] + mov ch, cl + and ch, container_mask + cmp ch, container_list + je .return_list + + ; Need to allocate a new Cons to replace this first element + call alloc_cons + and cl, content_mask + mov ch, cl ; Save CAR content type in ch + or cl, container_list ; Keep content type, set container type to list + mov [rax], BYTE cl + + mov dl, BYTE [rsi + Cons.typecdr] ; CDR type in DL + mov [rax + Cons.typecdr], BYTE dl + + ; Copy content of CAR + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + + ; Check if car contains a pointer + cmp ch, content_pointer + jne .check_cdr + + ; CAR contains a pointer, so increment reference count + + mov r8, rax ; Save return Cons + mov r9, rsi ; Save input list + mov rsi, rbx ; Content of CAR + call incref_object + mov rax, r8 ; Restore return Cons + mov rsi, r9 ; Restore input list + +.check_cdr: + ; Copy content of CDR + + mov rcx, [rsi + Cons.cdr] + mov [rax + Cons.cdr], rcx ; Note: Might be pointer + + ; Check if cdr contains a pointer + cmp dl, content_pointer + jne .return ; Not a pointer, so just return + + ; A pointer, so increment its reference count + mov rbx, rax ; Save the return Cons + mov rsi, rcx ; The pointer in CDR + call incref_object + mov rax, rbx ; Restore the return Cons + ret + +.return_list: + call incref_object + mov rax, rsi +.return: + ret + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.missing_args: + mov rsi, core_rest_missing_arg + mov edx, core_rest_missing_arg.len + jmp .throw + +.not_list: + mov rsi, core_rest_not_list + mov edx, core_rest_not_list.len +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw + + +;; Return the nth element of a list or vector +core_nth: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .missing_args + + cmp al, content_nil + je .return_nil + + cmp al, content_pointer + jne .not_list + + ; Get the list into R8 + mov r8, [rsi + Cons.car] + + ; Check if we have a second argument + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .missing_args + + mov r9, [rsi + Cons.cdr] + + ; Check that it is a number + mov al, BYTE [r9] + and al, content_mask + cmp al, content_int + jne .not_int + + ; Get the number in RBX + mov rbx, [r9 + Cons.car] + + ; Now loop through the list, moving along n elements +.loop: + test rbx, rbx ; Test if zero + jz .done + + ; Move along next element + + mov al, BYTE [r8 + Cons.typecdr] + cmp al, content_pointer + jne .out_of_range ; No element + + mov r8, [r8 + Cons.cdr] + dec rbx + jmp .loop + +.done: + ; Take the head of the list in R8 + mov al, BYTE [r8] + and al, content_mask + cmp al, content_pointer + je .return_pointer + + ; Copy a value + mov cl, al + call alloc_cons + mov [rax], BYTE cl + mov rcx, [r8 + Cons.car] + mov [rax + Cons.car], rcx + ret + +.return_pointer: + mov rsi, [r8 + Cons.car] + call incref_object + mov rax, rsi + ret + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.missing_args: + mov rsi, core_nth_missing_arg + mov edx, core_nth_missing_arg.len + jmp .throw + +.not_list: + mov rsi, core_nth_not_list + mov edx, core_nth_not_list.len + jmp .throw + +.not_int: + mov rsi, core_nth_not_int + mov edx, core_nth_not_int.len + jmp .throw + +.out_of_range: + mov rsi, core_nth_out_of_range + mov edx, core_nth_out_of_range.len + +.throw: + call raw_to_string + mov rsi, rax + jmp error_throw + +;; Check if the argument is a given value type +core_nilp: + mov al, BYTE content_nil + jmp core_value_type_p +core_truep: + mov al, BYTE content_true + jmp core_value_type_p +core_falsep: + mov al, BYTE content_false + jmp core_value_type_p +core_numberp: + mov al, BYTE content_int +;; predicates for nil, true, false and number jump here +core_value_type_p: + mov bl, BYTE [rsi] + and bl, content_mask + cmp bl, content_empty + je .missing_args + + cmp al, bl + je .true + + ; false + call alloc_cons + mov [rax], BYTE maltype_false + ret +.true: + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.missing_args: + mov rsi, core_value_p_missing_args + mov edx, core_value_p_missing_args.len + + call raw_to_string + mov rsi, rax + jmp error_throw + +;; Throws an exception +core_throw: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_empty + je .throw_nil ; No arguments + + cmp al, content_pointer + je .throw_pointer + + ; A value. Remove list content type + mov [rsi], BYTE al + jmp error_throw + +.throw_pointer: + mov rsi, [rsi + Cons.car] + jmp error_throw + +.throw_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov rsi, rax + jmp error_throw + +;; Applies a function to a list or vector +;; +;; Uses registers +;; R8 - function +;; R9 - Input list/vector +;; R10 - Current end of return list (for appending) +core_map: + xor r10,r10 ; Zero, signal no list + + ; First argument should be a function + mov bl, BYTE [rsi] + and bl, content_mask + cmp bl, content_empty + je .missing_args + + ; Check the first argument is a pointer + cmp bl, content_pointer + jne .not_function + + mov r8, [rsi + Cons.car] ; Function in R8 + mov bl, BYTE [r8] + cmp bl, maltype_function + jne .not_function + + ; Check for second argument + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .missing_args + + mov rsi, [rsi + Cons.cdr] + + ; Should be a pointer to a list or vector + mov bl, BYTE [rsi] + and bl, content_mask + cmp bl, content_pointer + jne .not_seq + + mov r9, [rsi + Cons.car] ; List or vector in R9 + + mov bl, BYTE [r9] + + mov bh, bl + and bh, content_mask + cmp bh, content_empty + je .empty_list + + and bl, (block_mask + container_mask) + cmp bl, container_list + je .start + cmp bl, container_vector + je .start + + ; not list or vector + jmp .not_seq + +.start: + ; Got function in R8, list or vector in R9 + + mov cl, BYTE [r9] + and cl, content_mask + mov ch, cl + or cl, container_list + + call alloc_cons + mov [rax], BYTE cl ; set content type + mov rbx, [r9 + Cons.car] + mov [rax + Cons.car], rbx ; Copy content + mov rsi, rax + + cmp ch, content_pointer + jne .run + + ; A pointer, so increment ref count + + mov rcx, rsi + mov rsi, rbx + call incref_object + mov rsi, rcx + +.run: + ; Here have function in R8, args in RSI + ; Check whether the function is built-in or user + mov rax, [r8 + Cons.car] + cmp rax, apply_fn + je .user_function + + ; A built-in function + push r8 ; function + push r9 ; input list/vector + push r10 ; End of return list + push rsi + + call rax + ; Result in RAX + + pop rsi + pop r10 + pop r9 + pop r8 + + push rax + call release_object ; Release arguments + pop rax + + jmp .got_return + +.user_function: + ; a user-defined function, so need to evaluate + ; RSI - Args + + mov rdi, r8 ; Function in RDI + mov rdx, rsi ; Release args after binding + + mov rsi, r15 ; Environment + call incref_object ; Released by eval + call incref_object ; also released from R13 + mov r13, r15 + + mov rsi, rdx + + push r8 + push r9 + push r10 + push r15 + call apply_fn ; Result in RAX + pop r15 + pop r10 + pop r9 + pop r8 + +.got_return: + ; Have a return result in RAX + + ; Check if it's a value type + mov bl, BYTE [rax] + mov bh, bl + and bl, (block_mask + container_mask) + jz .return_value + + ; A more complicated type, point to it + mov rcx, rax + call alloc_cons ; Create a Cons for address + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], rcx + jmp .update_return + +.return_value: + ; Check if this value is shared (e.g. in an atom) + mov cx, WORD [rax + Cons.refcount] + dec cx + jz .return_value_modify ; If reference count is 1 + + ; Need to copy to avoid modifying + push rsi + mov rsi, rax ; Original in RSI + + mov cl, bh ; Type + call alloc_cons + and cl, content_mask + or cl, container_list + mov [rax], BYTE cl ; mark as a list + + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy content + + ; Release original + push rax + call release_object + pop rax + pop rsi + + jmp .update_return + +.return_value_modify: + ; Only one reference, + ; so can change the container type to list. + ; Original type in bh + mov bl, bh + and bl, content_mask + or bl, container_list + mov [rax], BYTE bl + +.update_return: + ; Now append to result list + test r10,r10 + jnz .append + + ; First value + mov r10, rax ; End of list + push r10 ; popped before return + jmp .next +.append: + mov [r10 + Cons.cdr], rax ; Point to new Cons + mov [r10 + Cons.typecdr], BYTE content_pointer + mov r10, rax +.next: + ; Check if there is another value + mov al, [r9 + Cons.typecdr] + cmp al, content_pointer + jne .done ; no more + + mov r9, [r9 + Cons.cdr] ; next + jmp .start + +.done: + pop rax ; Pushed in .update_return + ret + +.empty_list: + ; Got an empty list, so return an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + +.missing_args: + ; Either zero or one args, expect two + load_static core_map_missing_args + jmp core_throw_str +.not_function: + ; First argument not a function + load_static core_map_not_function + jmp core_throw_str +.not_seq: + ; Second argument not list or vector + load_static core_map_not_seq + jmp core_throw_str + + +;; Applies a function to a list of arguments, concatenated with +;; a final list of args +;; (function, ..., []) +core_apply: + ; First argument should be a function + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_function + + mov r8, [rsi + Cons.car] ; function in R8 + mov al, BYTE [r8] + cmp al, maltype_function + jne .not_function + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .missing_args + + xor r9,r9 + ; Optional args, followed by final list/vector +.loop: + mov rsi, [rsi + Cons.cdr] + + ; Check if this is the last + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .last + + ; Not the last, so copy + call alloc_cons ; New Cons in RAX + mov bl, BYTE [rsi] + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + + and bl, content_mask + cmp bl, content_pointer + jne .got_value + + ; A pointer, so increment reference + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.got_value: + ; Now append this Cons to the list + test r9,r9 + jnz .append + + ; First + mov r9, rax ; Start of the list + mov r10, rax ; End of the list + jmp .loop + +.append: + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rax + mov r10, rax + jmp .loop + +.last: + ; Check that it's a list or vector + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_seq + + mov rsi, [rsi + Cons.car] ; Vector/list in RSI + mov al, BYTE [rsi] + and al, container_mask + cmp al, container_list + je .last_seq + cmp al, container_vector + jne .not_seq + +.last_seq: + ; Check if there were any previous args + test r9, r9 + jnz .last_append + + ; R9 is zero, so no previous args + + ; check that this is a list + ; and convert vector to list + + mov r9, rsi + + ; Check if R9 is a list + mov al, BYTE [r9] + mov cl, al + and al, container_mask + cmp al, container_list + jne .last_convert_to_list + + ; Already a list, just increment reference count + mov rsi, r9 + call incref_object + jmp .run + +.last_convert_to_list: + ; Convert vector to list by copying first element + + call alloc_cons + and cl, content_mask + or cl, container_list + mov [rax], BYTE cl + mov rdx, [r9 + Cons.car] + mov [rax + Cons.car], rdx + + ; check if contains a pointer + cmp cl, (container_list + content_pointer) + jne .copy_cdr + + ; A pointer, so increment reference + mov bx, WORD [rdx + Cons.refcount] + inc bx + mov [rdx + Cons.refcount], WORD bx + +.copy_cdr: + mov bl, BYTE [r9 + Cons.typecdr] + mov rcx, [r9 + Cons.cdr] + mov [rax + Cons.typecdr], BYTE bl + mov [rax + Cons.cdr], rcx + + ; Replace R9 with this new element + mov r9, rax + + cmp bl, content_pointer + jne .run + + ; A pointer, so increment reference + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + + jmp .run + +.last_append: + ; Append RSI to the end of the list [R9]...[R10] + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rsi + call incref_object + +.run: + ; Have arguments list in R9 + mov rsi, r9 + ; Here have function in R8, args in RSI + ; Check whether the function is built-in or user + mov rax, [r8 + Cons.car] + cmp rax, apply_fn + je .user_function + + ; A built-in function + push r8 ; function + push r9 ; input list/vector + push r10 ; End of return list + push rsi + + call rax + ; Result in RAX + + pop rsi + pop r10 + pop r9 + pop r8 + + push rax + call release_object ; Release arguments + pop rax + + ret + +.user_function: + ; a user-defined function, so need to evaluate + ; RSI - Args + + mov rdi, r8 ; Function in RDI + mov rdx, rsi ; Release args after binding + + mov rsi, r15 ; Environment + call incref_object ; Released by eval + call incref_object ; also released from R13 + mov r13, r15 + + mov rsi, rdx + + push r8 + push r9 + push r10 + call apply_fn ; Result in RAX + pop r10 + pop r9 + pop r8 + + ret + +.not_function: + load_static core_apply_not_function + jmp core_throw_str + +.missing_args: + load_static core_apply_missing_args + jmp core_throw_str + +.not_seq: + load_static core_apply_not_seq + jmp core_throw_str + +;; Converts a string to a symbol +core_symbol: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_string + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, maltype_string + jne .not_string + + ; Copy the string + call string_copy ; result in RAX + + mov [rax], BYTE maltype_symbol + ret + +.not_string: + load_static core_symbol_not_string + jmp core_throw_str + +;; Converts a string to a keyword +core_keyword: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .error + + mov r8, [rsi + Cons.car] ; String in R8 + mov al, BYTE [r8] + cmp al, maltype_string + jne .not_string + + call string_new ; String in RAX + mov rsi, rax + mov cl, ':' + call string_append_char ; Puts ':' first + + mov rdx, r8 + call string_append_string ; append + + ; Mark as keyword + mov [rsi], BYTE maltype_symbol + + mov rax, rsi + ret + +.not_string: + cmp al, maltype_symbol + jne .error + ; Check if first character is ':' + mov al, BYTE [r8 + Array.data] + cmp al, ':' + jne .error + ;; This is already a keyword, return it unchanged. + mov rsi, r8 + call incref_object + mov rax, rsi + ret +.error: + load_static core_keyword_not_string + jmp core_throw_str + +;; Sets values in a map +core_assoc: + ; check first arg + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_map + + mov r8, [rsi + Cons.car] ; map in R8 + mov al, BYTE [r8] + and al, container_mask + cmp al, container_map + jne .not_map + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + je .start + + ; No keys to set, so just increment and return + mov rsi, r8 + call incref_object + mov rax, rsi + ret + +.start: + mov r11, [rsi + Cons.cdr] ; List of keys/values in R11 + + ; Copy the original list + mov rsi, r8 + call map_copy + mov rsi, rax ; new map in RSI + +.loop: + ; Get key then value from R11 list + + mov cl, BYTE [r11] + and cl, content_mask + cmp cl, content_pointer + je .key_pointer + + ; Key is a value, so copy into a Cons + call alloc_cons + mov [rax], BYTE cl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + mov rdi, rax ; Key in RDI + jmp .get_value + +.key_pointer: + mov rdi, [r11 + Cons.car] + ; increment reference count because the key will be + ; released after setting (to allow value Cons to be + ; freed) + + mov bx, WORD [rdi + Cons.refcount] + inc bx + mov [rdi + Cons.refcount], WORD bx + +.get_value: + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .missing_value + + mov r11, [r11 + Cons.cdr] + + ; Check if value is a pointer + mov cl, BYTE [r11] + and cl, content_mask + cmp cl, content_pointer + je .value_pointer + + ; Value is a value, so copy into a Cons + call alloc_cons + mov [rax], BYTE cl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + mov rcx, rax ; Key in RCX + jmp .set_pair + +.value_pointer: + mov rcx, [r11 + Cons.car] + ; increment reference count because the value will be + ; released after setting (to allow value Cons to be + ; freed) + + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.set_pair: + ; Here have: + ; map in RSI + ; key in RDI + ; value in RCX + + call map_set + + mov r8, rsi ; map + mov rsi, rdi ; key + call release_object + mov rsi, rcx ; value + call release_object + mov rsi, r8 ; map + + ; Check if there's another pair + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .done + + ; got another pair + mov r11, [r11 + Cons.cdr] + jmp .loop + +.done: + mov rax, rsi ; new map + ret + +.not_map: + load_static core_assoc_not_map + jmp core_throw_str + +.missing_value: + load_static core_assoc_missing_value + jmp core_throw_str + + +;; Removes keys from a map by making +;; a copy of a map without the given keys +core_dissoc: + ; Check that the first argument is a map + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .not_map + + mov r8, [rsi + Cons.car] ; Map in R8 + mov al, BYTE [r8] + mov ah, al + and al, container_mask + cmp al, container_map + jne .not_map + + ; Check if the map is empty + cmp ah, maltype_empty_map + je .inc_and_return + + ; Now check if there are other arguments + + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + je .start + +.inc_and_return: + ; No keys to remove + ; just increment the map reference count and return + mov rsi, r8 + call incref_object + mov rax, rsi + ret + +.start: + ; Some keys to remove + mov r9, [rsi + Cons.cdr] + + ; R9 now contains a list of keys + ; R8 contains the map to copy + + xor r11, r11 ; Head of list to return + ; R12 contains tail + +.loop: + ; Check the key in R8 against the list in R9 + mov r10, r9 ; point in list being searched + + ; loop through the list in R10 + ; comparing each element against R8 +.search_loop: + mov rsi, r8 + mov rdi, r10 + call compare_objects + test rax, rax + jz .found ; objects are equal + + ; Not found so check next in list + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .not_found ; End of list + + mov r10, [r10 + Cons.cdr] ; next + jmp .search_loop + +.found: + ; Removing this key, so skip + mov al, BYTE [r8 + Cons.typecdr] + cmp al, content_pointer + jne .missing_value + + mov r8, [r8 + Cons.cdr] ; now a value + jmp .next + +.not_found: + ; Key not in list, so keeping + ; Create a Cons to copy + call alloc_cons + mov bl, [r8] + mov rcx, [r8 + Cons.car] + + mov [rax], BYTE bl + mov [rax + Cons.car], rcx + + ; Check if a pointer or value + and bl, content_mask + cmp bl, content_pointer + jne .done_key ; A value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_key: + ; append to list + + test r11, r11 + jnz .key_append + + ; First one + mov r11, rax + mov r12, rax + jmp .copy_value +.key_append: + + mov [r12 + Cons.typecdr], BYTE content_pointer + mov [r12 + Cons.cdr], rax + mov r12, rax + +.copy_value: + + ; Check there is a value + mov al, BYTE [r8 + Cons.typecdr] + cmp al, content_pointer + jne .missing_value + + mov r8, [r8 + Cons.cdr] ; Value + + ; Same as for key; create a Cons and copy + call alloc_cons + mov bl, [r8] + mov rcx, [r8 + Cons.car] + + mov [rax], BYTE bl + mov [rax + Cons.car], rcx + + ; Check if a pointer or value + and bl, content_mask + cmp bl, content_pointer + jne .done_value ; A value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.done_value: + ; append to list + mov [r12 + Cons.typecdr], BYTE content_pointer + mov [r12 + Cons.cdr], rax + mov r12, rax + +.next: + ; Here R8 contains a value + + ; Check if there's another key + mov al, [r8 + Cons.typecdr] + cmp al, content_pointer + jne .done + + ; Still more + + mov r8, [r8 + Cons.cdr] + jmp .loop + +.done: + ; Check if the map is empty + test r11, r11 + jz .return_empty + + ; not empty, so return + mov rax, r11 + ret + +.return_empty: + call alloc_cons + mov [rax], BYTE maltype_empty_map + ret + +.not_map: + load_static core_dissoc_not_map + jmp core_throw_str + +.missing_value: + load_static core_dissoc_missing_value + jmp core_throw_str + + +;; Takes a string prompt for the user, and returns +;; a string or nil +core_readline: + ; Check the input + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .no_prompt + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, maltype_string + jne .no_prompt + + ; Got a string in RSI + call print_string + +.no_prompt: + + ; Get string from user + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .return_nil + + ; return the string in RAX + ret + +.return_nil: + ; release string in RAX + mov rsi, rax + call release_array + + call alloc_cons + mov [rax], BYTE maltype_nil + ret + + +;; Return the meta data associated with a given function +core_meta: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .return_nil + + mov rsi, [rsi + Cons.car] + mov al, BYTE [rsi] + cmp al, (block_cons + container_function + content_function) + jne .return_nil + + ; Here got a function + mov rsi, [rsi + Cons.cdr] + + ; RSI should now contain the meta data + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_pointer + je .pointer + + ; A value, so copy + call alloc_cons + mov [rax], BYTE cl + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + ret + +.pointer: + ; A pointer, so increment reference count and return + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + ret + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + + +;; Associates a value with a function (native or user) +core_with_meta: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .no_function + + mov r8, [rsi + Cons.car] ; Function in R8 + mov al, BYTE [r8] + cmp al, (block_cons + container_function + content_function) + jne .no_function + + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .no_value + + mov rsi, [rsi + Cons.cdr] + + ; Function in R8, new value in RSI + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) ; Type + mov rbx, [r8 + Cons.car] + mov [rax + Cons.car], rbx ; Function address + + mov r10, rax ; Return address + + ; Copy the meta data + + mov r8, [r8 + Cons.cdr] ; R8 now old meta data (not used) + + call alloc_cons + + mov cl, BYTE [rsi] + and cl, content_mask + mov ch, cl + or cl, container_function + mov [rax], BYTE cl ; Set type + + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Copy value + + ; append to function + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rax + mov r11, rax + + ; Check if meta is a value or pointer + cmp ch, content_pointer + jne .copy_rest + + ; increment reference count of meta + mov cx, WORD [rbx + Cons.refcount] + inc cx + mov [rbx + Cons.refcount], WORD cx + +.copy_rest: + ; Copy remainder of function (if any) + ; If a user function, has (env binds body) + mov al, [r8 + Cons.typecdr] + cmp al, content_pointer + jne .done + + ; Still more to copy + mov r8, [r8 + Cons.cdr] + + call alloc_cons + mov bl, BYTE [r8] + mov [rax], BYTE bl ; Copy type + mov rcx, [r8 + Cons.car] + mov [rax + Cons.car], rcx ; Copy value + + ; append + mov [r11 + Cons.typecdr], BYTE content_pointer + mov [r11 + Cons.cdr], rax + mov r11, rax + + ; Check if it's a pointer + and bl, content_mask + cmp bl, content_pointer + jne .copy_rest + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + jmp .copy_rest + +.done: + mov rax, r10 + ret + +.no_function: + load_static core_with_meta_no_function + jmp core_throw_str + +.no_value: + load_static core_with_meta_no_value + jmp core_throw_str + + +;; Returns the current time in ms +core_time_ms: + call clock_time_ms + mov rsi, rax + + call alloc_cons + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rsi + ret + +;; Convert sequences, including strings, into lists +core_seq: + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + je .pointer + + cmp al, content_empty + je .missing_arg + + cmp al, content_nil + jne .wrong_type + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + ret + +.pointer: + mov r8, [rsi + Cons.car] + mov al, BYTE [r8] + + cmp al, maltype_string + je .string + + mov ah, al + and ah, (block_mask + content_mask) + cmp ah, (block_cons + content_empty) + je .return_nil + + and al, (block_mask + container_mask) + + cmp al, (block_cons + container_list) + je .list + + cmp al, (block_cons + container_vector) + jne .wrong_type + + ; Convert vector to list by replacing the first Cons + call alloc_cons + mov bl, BYTE [r8] + and bl, content_mask + or bl, container_list + mov [rax], BYTE bl ; Set type + + mov rcx, [r8 + Cons.car] + mov [rax + Cons.car], rcx + + ; Check if it's a pointer + cmp bl, (container_list + content_pointer) + jne .copy_cdr + + ; Increment reference count + mov bx, WORD [rcx + Cons.refcount] ; Same for Array + inc bx + mov [rcx + Cons.refcount], WORD bx + +.copy_cdr: + mov rcx, [r8 + Cons.cdr] + mov [rax + Cons.cdr], rcx + + mov bl, [r8 + Cons.typecdr] + mov [rax + Cons.typecdr], bl + + cmp bl, content_pointer + jne .return + + ; Increment reference count + mov bx, WORD [rcx + Cons.refcount] ; Same for Array + inc bx + mov [rcx + Cons.refcount], WORD bx + +.return: + ret + +.list: + ; Return list unchanged + mov rsi, r8 + call incref_object + mov rax, r8 + ret + +.string: + ; Split a string into characters + ; Input string in R8 + + mov ebx, DWORD [r8 + Array.length] + test ebx,ebx + jz .return_nil ; empty string + + ; Not empty, so allocate first Cons + call alloc_cons + mov r9, rax ; Return Cons in R9 + mov r10, rax ; End of list in R10 + +.loop: + mov ebx, DWORD [r8 + Array.length] + mov r11, r8 + add r11, Array.data ; Start of string data in R11 + mov r12, r11 + add r12, rbx ; End of string data in R12 + +.inner_loop: + ; Get a new string + call string_new ; in RAX + mov bl, BYTE [r11] ; Get the next character + mov [rax + Array.data], BYTE bl + mov [rax + Array.length], DWORD 1 + + ; Put string into Cons at end of list + mov [r10 + Cons.car], rax + + ; Set type + mov [r10], BYTE (container_list + content_pointer) + + inc r11 + cmp r11, r12 + je .inner_done + + ; more characters, so allocate another Cons + call alloc_cons + + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rax + mov r10, rax + jmp .inner_loop + +.inner_done: + ; No more characters in this Array + ; check if there are more + mov r8, QWORD [r8 + Array.next] ; Get the next Array address + test r8, r8 ; Test if it's null + jz .string_finished + + ; Another chunk in the string + + call alloc_cons + mov [r10 + Cons.typecdr], BYTE content_pointer + mov [r10 + Cons.cdr], rax + mov r10, rax + jmp .loop + +.string_finished: + mov rax, r9 + ret + +.missing_arg: + ; No arguments + load_static core_seq_missing_arg + jmp core_throw_str + +.wrong_type: + ; Not a list, vector, string or nil + load_static core_seq_wrong_type + jmp core_throw_str + diff --git a/impls/nasm/env.asm b/impls/nasm/env.asm index 95c96deb9d..ce4d53e39a 100644 --- a/impls/nasm/env.asm +++ b/impls/nasm/env.asm @@ -1,309 +1,309 @@ - -%include "macros.mac" - -;; ------------------------------------------------------------ -;; Environment type -;; -;; These are lists of maps. The head of the list is the -;; current environment, and CDR points to the outer environment -;; -;; ( {} {} ... ) - -section .data - -;; Symbols used for comparison - static_symbol env_symbol, '*env*' - static_symbol ampersand_symbol, '&' - -;; Error message strings - - static env_binds_error_string, db "Env expecting symbol in binds list",10 - static env_binds_missing_string, db "Env missing expression in bind",10 - static env_missing_symbol_after_amp_string, db "Env missing symbol after &",10 - -section .text - -;; Create a new Environment -;; -;; Input: outer Environment in RSI. -;; - If zero, then nil outer. -;; - If not zero, increments reference count -;; -;; Return a new Environment type in RAX -;; -;; Modifies registers: -;; RAX -;; RBX -env_new: - call map_new ; map in RAX - push rax - call alloc_cons ; Cons in RAX - pop rbx ; map in RBX - - mov [rax], BYTE (block_cons + container_list + content_pointer) - ; CDR type already set to nil in alloc_cons - mov [rax + Cons.car], rbx - - cmp rsi, 0 - jne .set_outer - ret ; No outer, just return -.set_outer: - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rsi - - ; increment reference counter of outer - mov rbx, rax ; because incref_object modifies rax - call incref_object - mov rax, rbx - ret - -;; Create a new environment using a binding list -;; -;; Input: RSI - Outer environment -;; RDI - Binds, a list of symbols -;; RCX - Exprs, a list of values to bind each symbol to -;; -;; Modifies registers -;; RBX -;; RDX -;; R8 -;; R9 -;; R10 -;; R11 -;; R12 -;; R13 -env_new_bind: - mov r11, rdi ; binds list in R11 - mov r12, rcx ; expr list in R12 - - call env_new - mov r13, rax ; New environment in R13 - -.bind_loop: - ; Check the type in the bind list - mov bl, BYTE [r11] - and bl, content_mask - cmp bl, content_empty - je .done ; No bindings - - cmp bl, content_pointer - jne .bind_not_symbol - - mov rdi, [r11 + Cons.car] ; Symbol object? - mov bl, BYTE [rdi] - cmp bl, maltype_symbol - jne .bind_not_symbol - - ; RDI now contains a symbol - - ; Check if it is '&' - mov rsi, ampersand_symbol - push rdi - call compare_char_array ; Compares RSI and RDI - pop rdi - cmp rax, 0 - je .variadic ; Bind rest of args to following symbol - - ; Check the type in expr - - mov bl, BYTE [r12] - mov bh, bl - and bh, content_mask - - cmp bh, content_empty - je .bind_missing_expr ; No expression - - cmp bh, content_pointer - je .value_pointer - - ; A value. Need to remove the container type - xchg bl,bh - mov [r12], BYTE bl - xchg bl,bh - mov rcx, r12 ; Value - mov rsi, r13 ; Env - push rbx - call env_set - pop rbx - ; Restore original type - mov [r12], BYTE bl - jmp .next - -.value_pointer: - ; A pointer to something, so just pass address to env_set - mov rcx, [r12 + Cons.car] - mov rsi, r13 - call env_set - ; Fall through to next -.next: - ; Check if there is a next symbol - mov bl, BYTE [r11 + Cons.typecdr] - cmp bl, content_pointer - jne .done - - ; Got another symbol - mov r11, [r11 + Cons.cdr] ; Next symbol - - ; Check if there's an expression to bind to - mov bl, BYTE [r12 + Cons.typecdr] - cmp bl, content_pointer - jne .next_no_expr ; No expr, but symbol could be & - - mov r12, [r12 + Cons.cdr] ; Next expression - jmp .bind_loop - -.next_no_expr: - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov r12, rax - - jmp .bind_loop -.done: - mov rax, r13 ; Env - ret - -.variadic: - ; R11 Cons contains '&' symbol - ; Bind next symbol to the rest of the list in R12 - mov bl, BYTE [r11 + Cons.typecdr] - cmp bl, content_pointer - jne .missing_symbol_after_amp - - mov r11, [r11 + Cons.cdr] - - mov bl, BYTE [r11] - and bl, content_mask - cmp bl, content_pointer - jne .bind_not_symbol - - mov rdi, [r11 + Cons.car] ; Symbol object? - mov bl, BYTE [rdi] - cmp bl, maltype_symbol - jne .bind_not_symbol - - ; Bind symbol in RDI to R12 - mov rcx, r12 ; Value - mov rsi, r13 ; Env - call env_set - jmp .done - -.missing_symbol_after_amp: - push r12 - - ; Release the environment - mov rsi, r13 - call release_object - - print_str_mac error_string ; print 'Error: ' - print_str_mac env_missing_symbol_after_amp_string - pop rsi - jmp error_throw - -.bind_not_symbol: ; Expecting a symbol - push r11 ; Binds list - - ; Release the environment - mov rsi, r13 - call release_object - - print_str_mac error_string ; print 'Error: ' - - print_str_mac env_binds_error_string - - pop rsi ; Throw binds list - jmp error_throw - -.bind_missing_expr: - ; Have a symbol, but no expression. - - push r11 ; Binds list - - ; Release the environment - mov rsi, r13 - call release_object - - print_str_mac error_string ; print 'Error: ' - - print_str_mac env_binds_missing_string - - pop rsi ; Throw binds list - jmp error_throw - - -;; Environment set -;; -;; Sets a key-value pair in an environment -;; -;; Inputs: RSI - env [not modified] -;; RDI - key [not modified] -;; RCX - value [not modified] -;; -;; Increments reference counts of key and value -;; if pointers to them are created -;; -;; Modifies registers: -;; R8 -;; R9 -;; R10 -env_set: - push rsi - ; Get the first CAR, which should be a map - mov rsi, [rsi + Cons.car] - call map_set - pop rsi - ret - -;; Environment get -;; -;; Get a value from an environment, incrementing the reference count -;; of the object returned -;; -;; Inputs: RSI - environment -;; RDI - key -;; -;; Returns: If found, Zero Flag is set and address in RAX -;; If not found, Zero Flag cleared -env_get: - push rsi - - ; Check special variable *env* - mov rsi, env_symbol - call compare_char_array - pop rsi - cmp rax, 0 - jne .not_env_symbol - - ; Env symbol, so return this environment - call incref_object - lahf ; flags in AH - or ah, 64 ; set zero flag - sahf - mov rax, rsi - ret - -.not_env_symbol: - push rsi - ; Get the map in CAR - mov rsi, [rsi + Cons.car] - call map_get - pop rsi - je .found - - ; Not found, so try outer - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .not_found - - mov rsi, [rsi + Cons.cdr] ; outer - jmp env_get -.found: - ret - -.not_found: - lahf ; flags in AH - and ah, 255-64 ; clear zero flag - sahf - ret - - + +%include "macros.mac" + +;; ------------------------------------------------------------ +;; Environment type +;; +;; These are lists of maps. The head of the list is the +;; current environment, and CDR points to the outer environment +;; +;; ( {} {} ... ) + +section .data + +;; Symbols used for comparison + static_symbol env_symbol, '*env*' + static_symbol ampersand_symbol, '&' + +;; Error message strings + + static env_binds_error_string, db "Env expecting symbol in binds list",10 + static env_binds_missing_string, db "Env missing expression in bind",10 + static env_missing_symbol_after_amp_string, db "Env missing symbol after &",10 + +section .text + +;; Create a new Environment +;; +;; Input: outer Environment in RSI. +;; - If zero, then nil outer. +;; - If not zero, increments reference count +;; +;; Return a new Environment type in RAX +;; +;; Modifies registers: +;; RAX +;; RBX +env_new: + call map_new ; map in RAX + push rax + call alloc_cons ; Cons in RAX + pop rbx ; map in RBX + + mov [rax], BYTE (block_cons + container_list + content_pointer) + ; CDR type already set to nil in alloc_cons + mov [rax + Cons.car], rbx + + cmp rsi, 0 + jne .set_outer + ret ; No outer, just return +.set_outer: + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rsi + + ; increment reference counter of outer + mov rbx, rax ; because incref_object modifies rax + call incref_object + mov rax, rbx + ret + +;; Create a new environment using a binding list +;; +;; Input: RSI - Outer environment +;; RDI - Binds, a list of symbols +;; RCX - Exprs, a list of values to bind each symbol to +;; +;; Modifies registers +;; RBX +;; RDX +;; R8 +;; R9 +;; R10 +;; R11 +;; R12 +;; R13 +env_new_bind: + mov r11, rdi ; binds list in R11 + mov r12, rcx ; expr list in R12 + + call env_new + mov r13, rax ; New environment in R13 + +.bind_loop: + ; Check the type in the bind list + mov bl, BYTE [r11] + and bl, content_mask + cmp bl, content_empty + je .done ; No bindings + + cmp bl, content_pointer + jne .bind_not_symbol + + mov rdi, [r11 + Cons.car] ; Symbol object? + mov bl, BYTE [rdi] + cmp bl, maltype_symbol + jne .bind_not_symbol + + ; RDI now contains a symbol + + ; Check if it is '&' + mov rsi, ampersand_symbol + push rdi + call compare_char_array ; Compares RSI and RDI + pop rdi + cmp rax, 0 + je .variadic ; Bind rest of args to following symbol + + ; Check the type in expr + + mov bl, BYTE [r12] + mov bh, bl + and bh, content_mask + + cmp bh, content_empty + je .bind_missing_expr ; No expression + + cmp bh, content_pointer + je .value_pointer + + ; A value. Need to remove the container type + xchg bl,bh + mov [r12], BYTE bl + xchg bl,bh + mov rcx, r12 ; Value + mov rsi, r13 ; Env + push rbx + call env_set + pop rbx + ; Restore original type + mov [r12], BYTE bl + jmp .next + +.value_pointer: + ; A pointer to something, so just pass address to env_set + mov rcx, [r12 + Cons.car] + mov rsi, r13 + call env_set + ; Fall through to next +.next: + ; Check if there is a next symbol + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .done + + ; Got another symbol + mov r11, [r11 + Cons.cdr] ; Next symbol + + ; Check if there's an expression to bind to + mov bl, BYTE [r12 + Cons.typecdr] + cmp bl, content_pointer + jne .next_no_expr ; No expr, but symbol could be & + + mov r12, [r12 + Cons.cdr] ; Next expression + jmp .bind_loop + +.next_no_expr: + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov r12, rax + + jmp .bind_loop +.done: + mov rax, r13 ; Env + ret + +.variadic: + ; R11 Cons contains '&' symbol + ; Bind next symbol to the rest of the list in R12 + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .missing_symbol_after_amp + + mov r11, [r11 + Cons.cdr] + + mov bl, BYTE [r11] + and bl, content_mask + cmp bl, content_pointer + jne .bind_not_symbol + + mov rdi, [r11 + Cons.car] ; Symbol object? + mov bl, BYTE [rdi] + cmp bl, maltype_symbol + jne .bind_not_symbol + + ; Bind symbol in RDI to R12 + mov rcx, r12 ; Value + mov rsi, r13 ; Env + call env_set + jmp .done + +.missing_symbol_after_amp: + push r12 + + ; Release the environment + mov rsi, r13 + call release_object + + print_str_mac error_string ; print 'Error: ' + print_str_mac env_missing_symbol_after_amp_string + pop rsi + jmp error_throw + +.bind_not_symbol: ; Expecting a symbol + push r11 ; Binds list + + ; Release the environment + mov rsi, r13 + call release_object + + print_str_mac error_string ; print 'Error: ' + + print_str_mac env_binds_error_string + + pop rsi ; Throw binds list + jmp error_throw + +.bind_missing_expr: + ; Have a symbol, but no expression. + + push r11 ; Binds list + + ; Release the environment + mov rsi, r13 + call release_object + + print_str_mac error_string ; print 'Error: ' + + print_str_mac env_binds_missing_string + + pop rsi ; Throw binds list + jmp error_throw + + +;; Environment set +;; +;; Sets a key-value pair in an environment +;; +;; Inputs: RSI - env [not modified] +;; RDI - key [not modified] +;; RCX - value [not modified] +;; +;; Increments reference counts of key and value +;; if pointers to them are created +;; +;; Modifies registers: +;; R8 +;; R9 +;; R10 +env_set: + push rsi + ; Get the first CAR, which should be a map + mov rsi, [rsi + Cons.car] + call map_set + pop rsi + ret + +;; Environment get +;; +;; Get a value from an environment, incrementing the reference count +;; of the object returned +;; +;; Inputs: RSI - environment +;; RDI - key +;; +;; Returns: If found, Zero Flag is set and address in RAX +;; If not found, Zero Flag cleared +env_get: + push rsi + + ; Check special variable *env* + mov rsi, env_symbol + call compare_char_array + pop rsi + cmp rax, 0 + jne .not_env_symbol + + ; Env symbol, so return this environment + call incref_object + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rsi + ret + +.not_env_symbol: + push rsi + ; Get the map in CAR + mov rsi, [rsi + Cons.car] + call map_get + pop rsi + je .found + + ; Not found, so try outer + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .not_found + + mov rsi, [rsi + Cons.cdr] ; outer + jmp env_get +.found: + ret + +.not_found: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret + + diff --git a/impls/nasm/exceptions.asm b/impls/nasm/exceptions.asm index 8630761c11..e1fb28dc78 100644 --- a/impls/nasm/exceptions.asm +++ b/impls/nasm/exceptions.asm @@ -1,138 +1,138 @@ - -;; ---------------------------------------------- -;; -;; Error handling -;; -;; A handler consists of: -;; - A stack pointer address to reset to -;; - An address to jump to -;; - An optional data structure to pass -;; -;; When jumped to, an error handler will be given: -;; - the object thrown in RSI -;; - the optional data structure in RDI -;; - -section .bss - -;; Error handler list -error_handler: resq 1 - -section .text - -;; Add an error handler to the front of the list -;; -;; Input: RSI - Stack pointer -;; RDI - Address to jump to -;; RCX - Data structure. Set to zero for none. -;; If not zero, reference count incremented -;; -;; Modifies registers: -;; RAX -;; RBX -error_handler_push: - call alloc_cons - ; car will point to a list (stack, addr, data) - ; cdr will point to the previous handler - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov rbx, [error_handler] - cmp rbx, 0 ; Check if previous handler was zero - je .create_handler ; Zero, so leave null - ; Not zero, so create pointer to it - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rbx - - ; note: not incrementing reference count, since - ; we're replacing one reference with another -.create_handler: - mov [error_handler], rax ; new error handler - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.car], rax - ; Store stack pointer - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rsi ; stack pointer - - mov rdx, rax - call alloc_cons - mov [rdx + Cons.typecdr], BYTE content_pointer - mov [rdx + Cons.cdr], rax - ; Store function pointer to jump to - ; Note: This can't use content_pointer or release - ; will try to release this memory address - mov [rax], BYTE (block_cons + container_list + content_function) - mov [rax + Cons.car], rdi - - ; Check if there is an object to pass to handler - cmp rcx, 0 - je .done - - ; Set the final CDR to point to the object - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rcx - - mov rsi, rcx - call incref_object - -.done: - ret - - -;; Removes an error handler from the list -;; -;; Modifies registers: -;; RSI -;; RAX -;; RCX -error_handler_pop: - ; get the address - mov rsi, [error_handler] - cmp rsi, 0 - je .done ; Nothing to remove - - push rsi - mov rsi, [rsi + Cons.cdr] ; next handler - mov [error_handler], rsi - ;call incref_object ; needed because releasing soon - - pop rsi ; handler being removed - mov [rsi + Cons.typecdr], BYTE 0 - call release_cons - -.done: - ret - - -;; Throw an error -;; Object to pass to handler should be in RSI -error_throw: - ; Get the next error handler - mov rax, [error_handler] - cmp rax, 0 - je .no_handler - - ; Got a handler - mov rax, [rax + Cons.car] ; handler - mov rbx, [rax + Cons.car] ; stack pointer - mov rax, [rax + Cons.cdr] - mov rcx, [rax + Cons.car] ; function - mov rdi, [rax + Cons.cdr] ; data structure - - ; Reset stack - mov rsp, rbx - - ; Jump to the handler - jmp rcx - -.no_handler: - ; Print the object in RSI then quit - cmp rsi, 0 - je .done ; nothing to print - mov rdi, 1 ; print_readably - call pr_str - mov rsi, rax - call print_string -.done: - jmp quit_error - + +;; ---------------------------------------------- +;; +;; Error handling +;; +;; A handler consists of: +;; - A stack pointer address to reset to +;; - An address to jump to +;; - An optional data structure to pass +;; +;; When jumped to, an error handler will be given: +;; - the object thrown in RSI +;; - the optional data structure in RDI +;; + +section .bss + +;; Error handler list +error_handler: resq 1 + +section .text + +;; Add an error handler to the front of the list +;; +;; Input: RSI - Stack pointer +;; RDI - Address to jump to +;; RCX - Data structure. Set to zero for none. +;; If not zero, reference count incremented +;; +;; Modifies registers: +;; RAX +;; RBX +error_handler_push: + call alloc_cons + ; car will point to a list (stack, addr, data) + ; cdr will point to the previous handler + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov rbx, [error_handler] + cmp rbx, 0 ; Check if previous handler was zero + je .create_handler ; Zero, so leave null + ; Not zero, so create pointer to it + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rbx + + ; note: not incrementing reference count, since + ; we're replacing one reference with another +.create_handler: + mov [error_handler], rax ; new error handler + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.car], rax + ; Store stack pointer + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rsi ; stack pointer + + mov rdx, rax + call alloc_cons + mov [rdx + Cons.typecdr], BYTE content_pointer + mov [rdx + Cons.cdr], rax + ; Store function pointer to jump to + ; Note: This can't use content_pointer or release + ; will try to release this memory address + mov [rax], BYTE (block_cons + container_list + content_function) + mov [rax + Cons.car], rdi + + ; Check if there is an object to pass to handler + cmp rcx, 0 + je .done + + ; Set the final CDR to point to the object + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rcx + + mov rsi, rcx + call incref_object + +.done: + ret + + +;; Removes an error handler from the list +;; +;; Modifies registers: +;; RSI +;; RAX +;; RCX +error_handler_pop: + ; get the address + mov rsi, [error_handler] + cmp rsi, 0 + je .done ; Nothing to remove + + push rsi + mov rsi, [rsi + Cons.cdr] ; next handler + mov [error_handler], rsi + ;call incref_object ; needed because releasing soon + + pop rsi ; handler being removed + mov [rsi + Cons.typecdr], BYTE 0 + call release_cons + +.done: + ret + + +;; Throw an error +;; Object to pass to handler should be in RSI +error_throw: + ; Get the next error handler + mov rax, [error_handler] + cmp rax, 0 + je .no_handler + + ; Got a handler + mov rax, [rax + Cons.car] ; handler + mov rbx, [rax + Cons.car] ; stack pointer + mov rax, [rax + Cons.cdr] + mov rcx, [rax + Cons.car] ; function + mov rdi, [rax + Cons.cdr] ; data structure + + ; Reset stack + mov rsp, rbx + + ; Jump to the handler + jmp rcx + +.no_handler: + ; Print the object in RSI then quit + cmp rsi, 0 + je .done ; nothing to print + mov rdi, 1 ; print_readably + call pr_str + mov rsi, rax + call print_string +.done: + jmp quit_error + diff --git a/impls/nasm/macros.mac b/impls/nasm/macros.mac index 8adac59e30..ea1fa480dd 100644 --- a/impls/nasm/macros.mac +++ b/impls/nasm/macros.mac @@ -1,49 +1,49 @@ -;; Some useful macros - -%ifndef MACROS_MAC -%define MACROS_MAC - -;; Define a static data value -;; -;; static label value -;; -%macro static 2+ - %1: %2 - %1.len: equ $ - %1 -%endmacro - -;; Puts address of data in RSI, length in EDX -%macro load_static 1 - mov rsi, %1 - mov edx, %1.len -%endmacro - -;; Define a symbol which can be compared against -;; -;; static_symbol name, string -;; -;; Example: -;; -;; static_symbol def_symbol, 'def!' -;; -%macro static_symbol 2 - %strlen slen %2 ; length of string - - %1: ISTRUC Array - AT Array.type, db maltype_symbol - AT Array.refcount, dw 1 - AT Array.length, dd slen - AT Array.data, db %2 - IEND -%endmacro - -;; Macro for printing raw string -;; -%macro print_str_mac 1 - mov rsi, %1 ; String address - mov rdx, %1.len ; Length of string - call print_rawstring -%endmacro - -%endif - +;; Some useful macros + +%ifndef MACROS_MAC +%define MACROS_MAC + +;; Define a static data value +;; +;; static label value +;; +%macro static 2+ + %1: %2 + %1.len: equ $ - %1 +%endmacro + +;; Puts address of data in RSI, length in EDX +%macro load_static 1 + mov rsi, %1 + mov edx, %1.len +%endmacro + +;; Define a symbol which can be compared against +;; +;; static_symbol name, string +;; +;; Example: +;; +;; static_symbol def_symbol, 'def!' +;; +%macro static_symbol 2 + %strlen slen %2 ; length of string + + %1: ISTRUC Array + AT Array.type, db maltype_symbol + AT Array.refcount, dw 1 + AT Array.length, dd slen + AT Array.data, db %2 + IEND +%endmacro + +;; Macro for printing raw string +;; +%macro print_str_mac 1 + mov rsi, %1 ; String address + mov rdx, %1.len ; Length of string + call print_rawstring +%endmacro + +%endif + diff --git a/impls/nasm/printer.asm b/impls/nasm/printer.asm index 8973f908b3..66fbef2fc6 100644 --- a/impls/nasm/printer.asm +++ b/impls/nasm/printer.asm @@ -1,544 +1,544 @@ -;;; Turns forms (lists, values/atoms) into strings -;;; -;;; - -%include "macros.mac" - -section .data - - ; Constant strings for printing - static unknown_type_string, db "#" - static unknown_value_string, db "#" - static function_type_string, db "#" - static macro_type_string, db "#" - static nil_value_string, db "nil" - static true_value_string, db "true" - static false_value_string, db "false" - -section .text - -;; Input: Address of object in RSI -;; print_readably in RDI. First bit set to zero for false -;; -;; Output: Address of string in RAX -;; -;; Modifies: -;; RCX -;; R8 -;; R12 -;; R13 -;; R14 -;; Calls: raw_to_string, -;; -;; -pr_str: - - ; Get the type - mov cl, BYTE [rsi] - - ; Check if it's already a string - cmp cl, maltype_string - - jne .not_string - - ; --------------------------- - ; Handle string - - test rdi, 1 - jz .string_not_readable - - ; printing readably, so escape characters - - call string_new ; Output string in rax - - mov r12, rax - add r12, Array.data ; Output data - mov r13, rsi - add r13, Array.data ; Input data - mov r14d, DWORD [rsi + Array.length] - add r14, Array.data - add r14, rsi ; End of input data - - ; Put " at start of output string - mov [r12], BYTE '"' - inc r12 - - ; Loop through the input string, escaping characters - -.string_loop: - cmp r13, r14 - je .string_finished - - mov cl, BYTE [r13] ; Get next character - inc r13 - - cmp cl, '"' ; - je .string_escape_char - - cmp cl, 92 ; Escape '\' - je .string_escape_char - - cmp cl, 10 ; Newline - je .string_newline - - ; No special case, just copy the byte - mov [r12], BYTE cl - inc r12 - jmp .string_loop - -.string_newline: - mov cl, 'n' - ;jmp .string_escape_char - -.string_escape_char: ; Add a '\' before char in cl - mov [r12], BYTE 92 ; Escape '\' - inc r12 - mov [r12], BYTE cl - inc r12 - jmp .string_loop - -.string_finished: - - - - mov [r12], BYTE '"' ; At the end - inc r12 - ; Calculate length of string - sub r12, rax - sub r12, Array.data - - mov [rax + Array.length], DWORD r12d - - ret - -.string_not_readable: - ; Just return the string - call incref_object - mov rax, rsi - ret - - ; ---------------------------- -.not_string: - ; Now test the container type (value, list, map, vector) - - mov ch, cl - - and ch, container_mask - jz .value - - cmp ch, container_list - je .list - - cmp ch, container_symbol - je .symbol - - cmp ch, container_map - je .map - - cmp ch, container_vector - je .vector - - cmp ch, container_function - je .function_or_macro - - cmp ch, container_atom - je .atom - - ; Unknown - mov rsi, unknown_type_string - mov edx, unknown_type_string.len - call raw_to_string ; Puts a String in RAX - ret - - ; -------------------------------- -.value: - mov ch, cl - and ch, content_mask - jz .value_nil - - cmp ch, content_int - je .value_int - - cmp ch, content_true - je .value_true - - cmp ch, content_false - je .value_false - - mov rsi, unknown_value_string - mov edx, unknown_value_string.len - call raw_to_string ; Puts a String in RAX - ret - - ; -------------------------------- -.value_nil: - mov rsi, nil_value_string - mov edx, nil_value_string.len - call raw_to_string - ret - -.value_true: - mov rsi, true_value_string - mov edx, true_value_string.len - call raw_to_string - ret - -.value_false: - mov rsi, false_value_string - mov edx, false_value_string.len - call raw_to_string - ret - - ; -------------------------------- -.value_int: - mov rax, [rsi + Cons.car] - call itostring - ret - - ; -------------------------------- -.list: - - mov r12, rsi ; Input list - - call string_new ; String in rax - mov r13, rax ; Output string in r13 - - ; Put '(' onto string - mov rsi, rax - mov cl, '(' - call string_append_char - - ; loop through list -.list_loop: - - ; Extract values and print - - mov rsi, r12 - mov cl, BYTE [rsi] ; Get type - - ; Check if it's a pointer (address) - mov ch, cl - and ch, content_mask - cmp ch, content_pointer - je .list_loop_pointer - - cmp ch, content_empty - je .list_check_end - - ; A value (nil, int etc. or function) - mov ch, cl ; Save type, container - and cl, content_mask ; Remove list type -> value - mov BYTE [rsi], cl - - push rcx - push r13 - push r12 - call pr_str ; String in rax - pop r12 - pop r13 - pop rcx - - mov cl, ch ; Restore list type - mov BYTE [r12], cl - jmp .list_loop_got_str -.list_loop_pointer: - mov rsi, [rsi + Cons.car] ; Address of object - push r13 - push r12 - call pr_str ; String in rax - pop r12 - pop r13 - -.list_loop_got_str: - ; concatenate strings in rax and rsi - mov rsi, r13 ; Output string - mov rdx, rax ; String to be copied - - push rsi ; Save output string - push rax ; save temporary string - call string_append_string - - ; Release the string - pop rsi ; Was in rax, temporary string - call release_array - - pop rsi ; restore output string -.list_check_end: - ; Check if this is the end of the list - mov cl, BYTE [r12 + Cons.typecdr] - cmp cl, content_pointer - jne .list_finished - - ; More left in the list - - ; Add space between values - mov cl, ' ' - mov rsi, r13 - call string_append_char - - ; Get next Cons - mov r12, [r12 + Cons.cdr] - jmp .list_loop - -.list_finished: - ; put ')' at the end of the string - mov cl, ')' - mov rsi, r13 - call string_append_char - - mov rax, rsi - ret - - ; -------------------------------- -.symbol: - ; Make a copy of the string - call string_new ; in rax - mov ebx, DWORD [rsi + Array.length] - mov [rax + Array.length], ebx - mov rcx, rsi - add rcx, Array.data ; Start of input data - mov rdx, rsi - add rdx, Array.size ; End of input data - mov r12, rax - add r12, Array.data ; Start of output data -.symbol_copy_loop: - ; Copy [rax] -> [r12] - mov rbx, [rcx] - mov [r12], rbx - add rcx, 8 ; Next 64 bits of input - cmp rcx, rdx - je .symbol_finished - - add r12, 8 ; Next 64 bits of output - jmp .symbol_copy_loop -.symbol_finished: - ret - - ; -------------------------------- -.map: - - mov r12, rsi ; Input map - - call string_new ; String in rax - mov r13, rax ; Output string in r13 - - ; Put '{' onto string - mov rsi, rax - mov cl, '{' - call string_append_char - - ; loop through map -.map_loop: - - ; Extract values and print - - mov rsi, r12 - mov cl, BYTE [rsi] ; Get type - - ; Check if it's a pointer (address) - mov ch, cl - and ch, content_mask - cmp ch, content_pointer - je .map_loop_pointer - - cmp ch, content_empty - je .map_check_end - - ; A value (nil, int etc. or function) - xchg ch, cl - mov [rsi], BYTE cl ; Remove map type -> value - xchg ch, cl - - push rcx - push r13 - push r12 - call pr_str ; String in rax - pop r12 - pop r13 - pop rcx - - mov cl, BYTE [r12] ; Restore map type - - jmp .map_loop_got_str -.map_loop_pointer: - mov rsi, [rsi + Cons.car] ; Address of object - push r13 - push r12 - call pr_str ; String in rax - pop r12 - pop r13 - -.map_loop_got_str: - ; concatenate strings in rax and rsi - mov rsi, r13 ; Output string - mov rdx, rax ; String to be copied - - push rsi ; Save output string - push rax ; save temporary string - call string_append_string - - ; Release the string - pop rsi ; Was in rax, temporary string - call release_array - - pop rsi ; restore output string -.map_check_end: - ; Check if this is the end of the map - mov cl, BYTE [r12 + Cons.typecdr] - cmp cl, content_nil - je .map_finished - - ; More left in the map - - ; Add space between values - mov cl, ' ' - mov rsi, r13 - call string_append_char - - ; Get next Cons - mov r12, [r12 + Cons.cdr] - jmp .map_loop - -.map_finished: - ; put '}' at the end of the string - mov cl, '}' - mov rsi, r13 - call string_append_char - - mov rax, rsi - ret - - ; -------------------------------- -.vector: - - mov r12, rsi ; Input vector - - call string_new ; String in rax - mov r13, rax ; Output string in r13 - - ; Put '[' onto string - mov rsi, rax - mov cl, '[' - call string_append_char - - ; loop through vector -.vector_loop: - - ; Extract values and print - - mov rsi, r12 - mov cl, BYTE [rsi] ; Get type - - ; Check if it's a pointer (address) - mov ch, cl - and ch, content_mask - cmp ch, content_pointer - je .vector_loop_pointer - - cmp ch, content_empty - je .vector_check_end - - ; A value (nil, int etc. or function) - mov ch, cl ; Save type, container - and cl, content_mask ; Remove vector type -> value - mov BYTE [rsi], cl - - push rcx - push r13 - push r12 - call pr_str ; String in rax - pop r12 - pop r13 - pop rcx - - mov cl, ch ; Restore vector type - mov BYTE [r12], cl - jmp .vector_loop_got_str -.vector_loop_pointer: - mov rsi, [rsi + Cons.car] ; Address of object - push r13 - push r12 - call pr_str ; String in rax - pop r12 - pop r13 - -.vector_loop_got_str: - ; concatenate strings in rax and rsi - mov rsi, r13 ; Output string - mov rdx, rax ; String to be copied - - push rsi ; Save output string - push rax ; save temporary string - call string_append_string - - ; Release the string - pop rsi ; Was in rax, temporary string - call release_array - - pop rsi ; restore output string -.vector_check_end: - ; Check if this is the end of the vector - mov cl, BYTE [r12 + Cons.typecdr] - cmp cl, content_pointer - jne .vector_finished - - ; More left in the vector - - ; Add space between values - mov cl, ' ' - mov rsi, r13 - call string_append_char - - ; Get next Cons - mov r12, [r12 + Cons.cdr] - jmp .vector_loop - -.vector_finished: - ; put ']' at the end of the string - mov cl, ']' - mov rsi, r13 - call string_append_char - - mov rax, rsi - ret - - ; -------------------------------- -.function_or_macro: - cmp cl, maltype_macro - je .macro - - ; a function - mov rsi, function_type_string - mov edx, function_type_string.len - call raw_to_string ; Puts a String in RAX - ret - -.macro: - mov rsi, macro_type_string - mov edx, macro_type_string.len - call raw_to_string ; Puts a String in RAX - ret - - ; -------------------------------- -.atom: - mov rsi, [rsi + Cons.car] ; What the atom points to - - call string_new ; String in rax - - ; Start string with '(atom' - mov rbx, '(atom ' - mov [rax + Array.data], rbx - mov [rax + Array.length], DWORD 6 - - push rax - call pr_str - mov rdx, rax ; string to be copied - pop rsi ; Output string - - call string_append_string - - ; closing bracket - mov cl, ')' - call string_append_char - mov rax, rsi - ret +;;; Turns forms (lists, values/atoms) into strings +;;; +;;; + +%include "macros.mac" + +section .data + + ; Constant strings for printing + static unknown_type_string, db "#" + static unknown_value_string, db "#" + static function_type_string, db "#" + static macro_type_string, db "#" + static nil_value_string, db "nil" + static true_value_string, db "true" + static false_value_string, db "false" + +section .text + +;; Input: Address of object in RSI +;; print_readably in RDI. First bit set to zero for false +;; +;; Output: Address of string in RAX +;; +;; Modifies: +;; RCX +;; R8 +;; R12 +;; R13 +;; R14 +;; Calls: raw_to_string, +;; +;; +pr_str: + + ; Get the type + mov cl, BYTE [rsi] + + ; Check if it's already a string + cmp cl, maltype_string + + jne .not_string + + ; --------------------------- + ; Handle string + + test rdi, 1 + jz .string_not_readable + + ; printing readably, so escape characters + + call string_new ; Output string in rax + + mov r12, rax + add r12, Array.data ; Output data + mov r13, rsi + add r13, Array.data ; Input data + mov r14d, DWORD [rsi + Array.length] + add r14, Array.data + add r14, rsi ; End of input data + + ; Put " at start of output string + mov [r12], BYTE '"' + inc r12 + + ; Loop through the input string, escaping characters + +.string_loop: + cmp r13, r14 + je .string_finished + + mov cl, BYTE [r13] ; Get next character + inc r13 + + cmp cl, '"' ; + je .string_escape_char + + cmp cl, 92 ; Escape '\' + je .string_escape_char + + cmp cl, 10 ; Newline + je .string_newline + + ; No special case, just copy the byte + mov [r12], BYTE cl + inc r12 + jmp .string_loop + +.string_newline: + mov cl, 'n' + ;jmp .string_escape_char + +.string_escape_char: ; Add a '\' before char in cl + mov [r12], BYTE 92 ; Escape '\' + inc r12 + mov [r12], BYTE cl + inc r12 + jmp .string_loop + +.string_finished: + + + + mov [r12], BYTE '"' ; At the end + inc r12 + ; Calculate length of string + sub r12, rax + sub r12, Array.data + + mov [rax + Array.length], DWORD r12d + + ret + +.string_not_readable: + ; Just return the string + call incref_object + mov rax, rsi + ret + + ; ---------------------------- +.not_string: + ; Now test the container type (value, list, map, vector) + + mov ch, cl + + and ch, container_mask + jz .value + + cmp ch, container_list + je .list + + cmp ch, container_symbol + je .symbol + + cmp ch, container_map + je .map + + cmp ch, container_vector + je .vector + + cmp ch, container_function + je .function_or_macro + + cmp ch, container_atom + je .atom + + ; Unknown + mov rsi, unknown_type_string + mov edx, unknown_type_string.len + call raw_to_string ; Puts a String in RAX + ret + + ; -------------------------------- +.value: + mov ch, cl + and ch, content_mask + jz .value_nil + + cmp ch, content_int + je .value_int + + cmp ch, content_true + je .value_true + + cmp ch, content_false + je .value_false + + mov rsi, unknown_value_string + mov edx, unknown_value_string.len + call raw_to_string ; Puts a String in RAX + ret + + ; -------------------------------- +.value_nil: + mov rsi, nil_value_string + mov edx, nil_value_string.len + call raw_to_string + ret + +.value_true: + mov rsi, true_value_string + mov edx, true_value_string.len + call raw_to_string + ret + +.value_false: + mov rsi, false_value_string + mov edx, false_value_string.len + call raw_to_string + ret + + ; -------------------------------- +.value_int: + mov rax, [rsi + Cons.car] + call itostring + ret + + ; -------------------------------- +.list: + + mov r12, rsi ; Input list + + call string_new ; String in rax + mov r13, rax ; Output string in r13 + + ; Put '(' onto string + mov rsi, rax + mov cl, '(' + call string_append_char + + ; loop through list +.list_loop: + + ; Extract values and print + + mov rsi, r12 + mov cl, BYTE [rsi] ; Get type + + ; Check if it's a pointer (address) + mov ch, cl + and ch, content_mask + cmp ch, content_pointer + je .list_loop_pointer + + cmp ch, content_empty + je .list_check_end + + ; A value (nil, int etc. or function) + mov ch, cl ; Save type, container + and cl, content_mask ; Remove list type -> value + mov BYTE [rsi], cl + + push rcx + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + pop rcx + + mov cl, ch ; Restore list type + mov BYTE [r12], cl + jmp .list_loop_got_str +.list_loop_pointer: + mov rsi, [rsi + Cons.car] ; Address of object + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + +.list_loop_got_str: + ; concatenate strings in rax and rsi + mov rsi, r13 ; Output string + mov rdx, rax ; String to be copied + + push rsi ; Save output string + push rax ; save temporary string + call string_append_string + + ; Release the string + pop rsi ; Was in rax, temporary string + call release_array + + pop rsi ; restore output string +.list_check_end: + ; Check if this is the end of the list + mov cl, BYTE [r12 + Cons.typecdr] + cmp cl, content_pointer + jne .list_finished + + ; More left in the list + + ; Add space between values + mov cl, ' ' + mov rsi, r13 + call string_append_char + + ; Get next Cons + mov r12, [r12 + Cons.cdr] + jmp .list_loop + +.list_finished: + ; put ')' at the end of the string + mov cl, ')' + mov rsi, r13 + call string_append_char + + mov rax, rsi + ret + + ; -------------------------------- +.symbol: + ; Make a copy of the string + call string_new ; in rax + mov ebx, DWORD [rsi + Array.length] + mov [rax + Array.length], ebx + mov rcx, rsi + add rcx, Array.data ; Start of input data + mov rdx, rsi + add rdx, Array.size ; End of input data + mov r12, rax + add r12, Array.data ; Start of output data +.symbol_copy_loop: + ; Copy [rax] -> [r12] + mov rbx, [rcx] + mov [r12], rbx + add rcx, 8 ; Next 64 bits of input + cmp rcx, rdx + je .symbol_finished + + add r12, 8 ; Next 64 bits of output + jmp .symbol_copy_loop +.symbol_finished: + ret + + ; -------------------------------- +.map: + + mov r12, rsi ; Input map + + call string_new ; String in rax + mov r13, rax ; Output string in r13 + + ; Put '{' onto string + mov rsi, rax + mov cl, '{' + call string_append_char + + ; loop through map +.map_loop: + + ; Extract values and print + + mov rsi, r12 + mov cl, BYTE [rsi] ; Get type + + ; Check if it's a pointer (address) + mov ch, cl + and ch, content_mask + cmp ch, content_pointer + je .map_loop_pointer + + cmp ch, content_empty + je .map_check_end + + ; A value (nil, int etc. or function) + xchg ch, cl + mov [rsi], BYTE cl ; Remove map type -> value + xchg ch, cl + + push rcx + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + pop rcx + + mov cl, BYTE [r12] ; Restore map type + + jmp .map_loop_got_str +.map_loop_pointer: + mov rsi, [rsi + Cons.car] ; Address of object + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + +.map_loop_got_str: + ; concatenate strings in rax and rsi + mov rsi, r13 ; Output string + mov rdx, rax ; String to be copied + + push rsi ; Save output string + push rax ; save temporary string + call string_append_string + + ; Release the string + pop rsi ; Was in rax, temporary string + call release_array + + pop rsi ; restore output string +.map_check_end: + ; Check if this is the end of the map + mov cl, BYTE [r12 + Cons.typecdr] + cmp cl, content_nil + je .map_finished + + ; More left in the map + + ; Add space between values + mov cl, ' ' + mov rsi, r13 + call string_append_char + + ; Get next Cons + mov r12, [r12 + Cons.cdr] + jmp .map_loop + +.map_finished: + ; put '}' at the end of the string + mov cl, '}' + mov rsi, r13 + call string_append_char + + mov rax, rsi + ret + + ; -------------------------------- +.vector: + + mov r12, rsi ; Input vector + + call string_new ; String in rax + mov r13, rax ; Output string in r13 + + ; Put '[' onto string + mov rsi, rax + mov cl, '[' + call string_append_char + + ; loop through vector +.vector_loop: + + ; Extract values and print + + mov rsi, r12 + mov cl, BYTE [rsi] ; Get type + + ; Check if it's a pointer (address) + mov ch, cl + and ch, content_mask + cmp ch, content_pointer + je .vector_loop_pointer + + cmp ch, content_empty + je .vector_check_end + + ; A value (nil, int etc. or function) + mov ch, cl ; Save type, container + and cl, content_mask ; Remove vector type -> value + mov BYTE [rsi], cl + + push rcx + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + pop rcx + + mov cl, ch ; Restore vector type + mov BYTE [r12], cl + jmp .vector_loop_got_str +.vector_loop_pointer: + mov rsi, [rsi + Cons.car] ; Address of object + push r13 + push r12 + call pr_str ; String in rax + pop r12 + pop r13 + +.vector_loop_got_str: + ; concatenate strings in rax and rsi + mov rsi, r13 ; Output string + mov rdx, rax ; String to be copied + + push rsi ; Save output string + push rax ; save temporary string + call string_append_string + + ; Release the string + pop rsi ; Was in rax, temporary string + call release_array + + pop rsi ; restore output string +.vector_check_end: + ; Check if this is the end of the vector + mov cl, BYTE [r12 + Cons.typecdr] + cmp cl, content_pointer + jne .vector_finished + + ; More left in the vector + + ; Add space between values + mov cl, ' ' + mov rsi, r13 + call string_append_char + + ; Get next Cons + mov r12, [r12 + Cons.cdr] + jmp .vector_loop + +.vector_finished: + ; put ']' at the end of the string + mov cl, ']' + mov rsi, r13 + call string_append_char + + mov rax, rsi + ret + + ; -------------------------------- +.function_or_macro: + cmp cl, maltype_macro + je .macro + + ; a function + mov rsi, function_type_string + mov edx, function_type_string.len + call raw_to_string ; Puts a String in RAX + ret + +.macro: + mov rsi, macro_type_string + mov edx, macro_type_string.len + call raw_to_string ; Puts a String in RAX + ret + + ; -------------------------------- +.atom: + mov rsi, [rsi + Cons.car] ; What the atom points to + + call string_new ; String in rax + + ; Start string with '(atom' + mov rbx, '(atom ' + mov [rax + Array.data], rbx + mov [rax + Array.length], DWORD 6 + + push rax + call pr_str + mov rdx, rax ; string to be copied + pop rsi ; Output string + + call string_append_string + + ; closing bracket + mov cl, ')' + call string_append_char + mov rax, rsi + ret diff --git a/impls/nasm/reader.asm b/impls/nasm/reader.asm index d0dfe20966..dd02a2acd7 100644 --- a/impls/nasm/reader.asm +++ b/impls/nasm/reader.asm @@ -1,1118 +1,1118 @@ -%include "macros.mac" - -section .data - -;; Reader macro strings - - static quote_symbol_string, db "quote" - static quasiquote_symbol_string, db "quasiquote" - static unquote_symbol_string, db "unquote" - static splice_unquote_symbol_string, db "splice-unquote" - static deref_symbol_string, db "deref" - static with_meta_symbol_string, db "with-meta" - -;; Error message strings - - static error_string_unexpected_end, db "Error: Unexpected end of input (EOF). Could be a missing ) or ]", 10 - static error_string_bracket_not_brace, db "Error: Expecting '}' but got ')'" - -;; Symbols for comparison - - static_symbol nil_symbol, 'nil' - static_symbol true_symbol, 'true' - static_symbol false_symbol, 'false' - -section .text - -;; Read a string into memory as a form (nested lists and atoms) -;; Note: In this implementation the tokenizer is not done separately -;; -;; Input: Address of string (char array) in RSI -;; -;; Output: Address of object in RAX -;; -;; Uses registers: -;; R12 Address of the start of the current list (starts 0) -;; R13 Address of the current list tail -;; R14 Stack pointer at start. Used for unwinding on error -;; R15 Address of first list. Used for unwinding on error -;; -;; In addition, the tokenizer uses -;; -;; RAX (object return) -;; RBX -;; RCX (character return in CL) -;; RDX -;; R8 ** State must be preserved -;; R9 ** -;; R10 ** -;; R12 -;; R13 -;; R14 Original stack pointer on call -;; R15 Top-level list, so all can be released on error -;; -read_str: - ; Initialise tokenizer - call tokenizer_init - - ; Set current list to zero - mov r12, 0 - - ; Set first list to zero - mov r15, 0 - - ; Save stack pointer for unwinding - mov r14, rsp - -.read_loop: - - call tokenizer_next - cmp cl, 0 - jne .got_token - - ; Unexpected end of tokens - mov rdx, error_string_unexpected_end.len - mov rsi, error_string_unexpected_end - jmp .error - -.got_token: - - cmp cl, 'i' ; An integer. Cons object in RAX - je .finished - cmp cl, '"' ; A string. Array object in RAX - je .finished - cmp cl, 's' ; A symbol - je .symbol - - cmp cl, '(' - je .list_start - - cmp cl, ')' - je .return_nil ; Note: if reading a list, cl will be tested in the list reader - - cmp cl, '{' - je .map_start - - cmp cl, '}' ; cl tested in map reader - je .return_nil - - cmp cl, '[' - je .vector_start - - cmp cl, ']' ; cl tested in vector reader - je .return_nil - - cmp cl, 39 ; quote ' - je .handle_quote - cmp cl, '`' - je .handle_quasiquote - cmp cl, '~' - je .handle_unquote - cmp cl, 1 - je .handle_splice_unquote - cmp cl, '@' - je .handle_deref - - cmp cl, '^' - je .handle_with_meta - - ; Unknown - jmp .return_nil - - ; -------------------------------- - -.list_start: - - ; Get the first value - ; Note that we call rather than jmp because the first - ; value needs to be treated differently. There's nothing - ; to append to yet... - call .read_loop - - ; rax now contains the first object - cmp cl, ')' ; Check if it was end of list - jne .list_has_contents - mov cl, 0 ; so ')' doesn't propagate to nested lists - ; Set list to empty - mov [rax], BYTE maltype_empty_list - ret ; Returns 'nil' given "()" -.list_has_contents: - ; If this is a Cons then use it - ; If not, then need to allocate a Cons - mov cl, BYTE [rax] - mov ch, cl - and ch, (block_mask + container_mask) ; Tests block and container type - jz .list_is_value - - ; If here then not a simple value, so need to allocate - ; a Cons object - - ; Start new list - push rax - call alloc_cons ; Address in rax - pop rbx - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rbx - ; Now have Cons in RAX, containing pointer to object as car - -.list_is_value: - ; Cons in RAX - ; Make sure it's marked as a list - mov cl, BYTE [rax] - or cl, container_list - mov [rax], BYTE cl - - mov r12, rax ; Start of current list - mov r13, rax ; Set current list - cmp r15, 0 ; Test if first list - jne .list_read_loop - mov r15, rax ; Save the first, for unwinding - -.list_read_loop: - ; Repeatedly get the next value in the list - ; (which may be other lists) - ; until we get a ')' token - - push r12 - push r13 - call .read_loop ; object in rax - pop r13 - pop r12 - - cmp cl, ')' ; Check if it was end of list - je .list_done ; Have nil object in rax - - ; Test if this is a Cons value - mov cl, BYTE [rax] - mov ch, cl - and ch, (block_mask + container_mask) ; Tests block and container type - jz .list_loop_is_value - - ; If here then not a simple value, so need to allocate - ; a Cons object - - ; Start new list - push rax - call alloc_cons ; Address in rax - pop rbx - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rbx - ; Now have Cons in RAX, containing pointer to object as car - -.list_loop_is_value: - ; Cons in RAX - - ; Make sure it's marked as a list - mov cl, BYTE [rax] - or cl, container_list - mov [rax], BYTE cl - - ; Append to r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax ; Set current list - - jmp .list_read_loop - -.list_done: - ; Release nil object in rax - mov rsi, rax - call release_cons - - ; Terminate the list - mov [r13 + Cons.typecdr], BYTE content_nil - mov QWORD [r13 + Cons.cdr], QWORD 0 - mov rax, r12 ; Start of current list - - ret - - ; -------------------------------- - -.map_start: - - ; Get the first value - ; Note that we call rather than jmp because the first - ; value needs to be treated differently. There's nothing - ; to append to yet... - call .read_loop - - ; rax now contains the first object - cmp cl, '}' ; Check if it was end of map - jne .map_has_contents - mov cl, 0 ; so '}' doesn't propagate to nested maps - ; Set map to empty - mov [rax], BYTE maltype_empty_map - ret ; Returns 'nil' given "()" -.map_has_contents: - ; If this is a Cons then use it - ; If not, then need to allocate a Cons - mov cl, BYTE [rax] - mov ch, cl - and ch, (block_mask + container_mask) ; Tests block and container type - jz .map_is_value - - ; If here then not a simple value, so need to allocate - ; a Cons object - - ; Start new map - push rax - call alloc_cons ; Address in rax - pop rbx - mov [rax], BYTE (block_cons + container_map + content_pointer) - mov [rax + Cons.car], rbx - ; Now have Cons in RAX, containing pointer to object as car - -.map_is_value: - ; Cons in RAX - ; Make sure it's marked as a map - mov cl, BYTE [rax] - or cl, container_map - mov [rax], BYTE cl - - mov r12, rax ; Start of current map - mov r13, rax ; Set current map - cmp r15, 0 ; Test if first map - jne .map_read_loop - mov r15, rax ; Save the first, for unwinding - -.map_read_loop: - ; Repeatedly get the next value in the map - ; (which may be other maps) - ; until we get a '}' token - - push r12 - push r13 - call .read_loop ; object in rax - pop r13 - pop r12 - - cmp cl, '}' ; Check if it was end of map - je .map_done ; Have nil object in rax - - ; Test if this is a Cons value - mov cl, BYTE [rax] - mov ch, cl - and ch, (block_mask + container_mask) ; Tests block and container type - jz .map_loop_is_value - - ; If here then not a simple value, so need to allocate - ; a Cons object - - ; Start new map - push rax - call alloc_cons ; Address in rax - pop rbx - mov [rax], BYTE (block_cons + container_map + content_pointer) - mov [rax + Cons.car], rbx - ; Now have Cons in RAX, containing pointer to object as car - -.map_loop_is_value: - ; Cons in RAX - - ; Make sure it's marked as a map - mov cl, BYTE [rax] - or cl, container_map - mov [rax], BYTE cl - - ; Append to r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax ; Set current map - - jmp .map_read_loop - -.map_done: - ; Release nil object in rax - mov rsi, rax - call release_cons - - ; Terminate the map - mov [r13 + Cons.typecdr], BYTE content_nil - mov QWORD [r13 + Cons.cdr], QWORD 0 - mov rax, r12 ; Start of current map - - ret - - ; -------------------------------- - -.vector_start: - - ; Get the first value - ; Note that we call rather than jmp because the first - ; value needs to be treated differently. There's nothing - ; to append to yet... - call .read_loop - - ; rax now contains the first object - cmp cl, ']' ; Check if it was end of vector - jne .vector_has_contents - mov cl, 0 ; so ']' doesn't propagate to nested vectors - ; Set vector to empty - mov [rax], BYTE maltype_empty_vector - ret ; Returns 'nil' given "()" -.vector_has_contents: - ; If this is a Cons then use it - ; If not, then need to allocate a Cons - mov cl, BYTE [rax] - mov ch, cl - and ch, (block_mask + container_mask) ; Tests block and container type - jz .vector_is_value - - ; If here then not a simple value, so need to allocate - ; a Cons object - - ; Start new vector - push rax - call alloc_cons ; Address in rax - pop rbx - mov [rax], BYTE (block_cons + container_vector + content_pointer) - mov [rax + Cons.car], rbx - ; Now have Cons in RAX, containing pointer to object as car - -.vector_is_value: - ; Cons in RAX - ; Make sure it's marked as a vector - mov cl, BYTE [rax] - or cl, container_vector - mov [rax], BYTE cl - - mov r12, rax ; Start of current vector - mov r13, rax ; Set current vector - cmp r15, 0 ; Test if first vector - jne .vector_read_loop - mov r15, rax ; Save the first, for unwinding - -.vector_read_loop: - ; Repeatedly get the next value in the vector - ; (which may be other vectors) - ; until we get a ']' token - - push r12 - push r13 - call .read_loop ; object in rax - pop r13 - pop r12 - - cmp cl, ']' ; Check if it was end of vector - je .vector_done ; Have nil object in rax - - ; Test if this is a Cons value - mov cl, BYTE [rax] - mov ch, cl - and ch, (block_mask + container_mask) ; Tests block and container type - jz .vector_loop_is_value - - ; If here then not a simple value, so need to allocate - ; a Cons object - - ; Start new vector - push rax - call alloc_cons ; Address in rax - pop rbx - mov [rax], BYTE (block_cons + container_vector + content_pointer) - mov [rax + Cons.car], rbx - ; Now have Cons in RAX, containing pointer to object as car - -.vector_loop_is_value: - ; Cons in RAX - - ; Make sure it's marked as a vector - mov cl, BYTE [rax] - or cl, container_vector - mov [rax], BYTE cl - - ; Append to r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax ; Set current vector - - jmp .vector_read_loop - -.vector_done: - ; Release nil object in rax - mov rsi, rax - call release_cons - - ; Terminate the vector - mov [r13 + Cons.typecdr], BYTE content_nil - mov QWORD [r13 + Cons.cdr], QWORD 0 - mov rax, r12 ; Start of current vector - - ret - - ; -------------------------------- -.handle_quote: - ; Turn 'a into (quote a) - call alloc_cons ; Address in rax - mov r12, rax - - ; Get a symbol "quote" - push r8 - push r9 - mov rsi, quote_symbol_string - mov edx, quote_symbol_string.len - call raw_to_string ; Address in rax - pop r9 - pop r8 - -.wrap_next_object: - mov [rax], BYTE maltype_symbol - mov [r12], BYTE (block_cons + container_list + content_pointer) - mov [r12 + Cons.car], rax - - ; Get the next object - push r12 - call .read_loop ; object in rax - pop r12 - - mov r13, rax ; Put object to be quoted in r13 - - call alloc_cons ; Address in rax - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], r13 - mov [rax + Cons.typecdr], BYTE content_nil - - ; Cons object in rax. Append to object in r12 - mov [r12 + Cons.typecdr], BYTE content_pointer - mov [r12 + Cons.cdr], rax - - mov rax, r12 - ret - - ; -------------------------------- -.handle_quasiquote: - ; Turn `a into (quasiquote a) - call alloc_cons ; Address in rax - mov r12, rax - - ; Get a symbol "quasiquote" - push r8 - push r9 - mov rsi, quasiquote_symbol_string - mov edx, quasiquote_symbol_string.len - call raw_to_string ; Address in rax - pop r9 - pop r8 - jmp .wrap_next_object ; From there the same as handle_quote - - ; -------------------------------- -.handle_unquote: - ; Turn ~a into (unquote a) - call alloc_cons ; Address in rax - mov r12, rax - - ; Get a symbol "unquote" - push r8 - push r9 - mov rsi, unquote_symbol_string - mov edx, unquote_symbol_string.len - call raw_to_string ; Address in rax - pop r9 - pop r8 - jmp .wrap_next_object ; From there the same as handle_quote - - ; -------------------------------- -.handle_splice_unquote: - ; Turn ~@a into (unquote a) - call alloc_cons ; Address in rax - mov r12, rax - - ; Get a symbol "unquote" - push r8 - push r9 - mov rsi, splice_unquote_symbol_string - mov edx, splice_unquote_symbol_string.len - call raw_to_string ; Address in rax - pop r9 - pop r8 - jmp .wrap_next_object ; From there the same as handle_quote - - ; -------------------------------- - -.handle_deref: - ; Turn @a into (deref a) - - call alloc_cons ; Address in rax - mov r12, rax - - ; Get a symbol "deref" - push r8 - push r9 - mov rsi, deref_symbol_string - mov edx, deref_symbol_string.len - call raw_to_string ; Address in rax - pop r9 - pop r8 - jmp .wrap_next_object ; From there the same as handle_quote - - ; -------------------------------- - -.handle_with_meta: - ; Turn ^ a b into (with-meta b a) - - call alloc_cons ; Address in rax - mov r12, rax - - ; Get a symbol "with-meta" - push r8 - push r9 - mov rsi, with_meta_symbol_string - mov edx, with_meta_symbol_string.len - call raw_to_string ; Address in rax - pop r9 - pop r8 - - mov [rax], BYTE maltype_symbol - mov [r12], BYTE (block_cons + container_list + content_pointer) - mov [r12 + Cons.car], rax - - ; Get the next two objects - push r12 - call .read_loop ; object in rax - pop r12 - push rax - push r12 - call .read_loop ; in RAX - pop r12 - - mov r13, rax - - call alloc_cons ; Address in rax - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], r13 - - ; Cons object in rax. Append to object in r12 - mov [r12 + Cons.typecdr], BYTE content_pointer - mov [r12 + Cons.cdr], rax - - mov r13, rax - - call alloc_cons ; Address in rax - mov [rax], BYTE (block_cons + container_list + content_pointer) - - pop rdi ; First object - mov [rax + Cons.car], rdi - - ; Append to object in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - - mov rax, r12 - ret - - ; -------------------------------- -.symbol: - ; symbol is in RAX - ; Some symbols are have their own type - ; - nil, true, false - ; - - mov rsi, rax - mov rdi, nil_symbol - push rsi - call compare_char_array - pop rsi - cmp rax, 0 - je .symbol_nil - - mov rdi, true_symbol - push rsi - call compare_char_array - pop rsi - cmp rax, 0 - je .symbol_true - - mov rdi, false_symbol - push rsi - call compare_char_array - pop rsi - cmp rax, 0 - je .symbol_false - - ; not a special symbol, so return - mov rax, rsi - ret - -.symbol_nil: - ; symbol in rsi not needed - call release_array - - call alloc_cons - mov [rax], BYTE maltype_nil ; a nil type - ret - -.symbol_true: - call release_array - - call alloc_cons - mov [rax], BYTE maltype_true - ret - -.symbol_false: - call release_array - - call alloc_cons - mov [rax], BYTE maltype_false - ret - - ; -------------------------------- -.finished: - ret - -.error: - ; Jump here on error with raw string in RSI - ; and string length in rdx - push r14 - push r15 - call print_rawstring - pop r15 - pop r14 - - ; fall through to unwind -.unwind: - ; Jump to here cleans up - - mov rsp, r14 ; Rewind stack pointer - cmp r15, 0 ; Check if there is a list - je .return_nil - mov rsi, r15 - call release_cons ; releases everything recursively - ; fall through to return_nil -.return_nil: - ; Allocates a new Cons object with nil and returns - ; Cleanup should happen before jumping here - push rcx - call alloc_cons - pop rcx - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - - -;; Initialise the tokenizer -;; -;; Input: Address of string in RSI -;; -;; NOTE: This uses RSI, RAX and RBX, and expects these to be preserved -;; between calls to tokenizer_next_char -;; -;; R9 Address of string -;; R10 Position in data array -;; R11 End of data array -;; -tokenizer_init: - ; Save string to r9 - mov r9, rsi - ; Put start of data array into r10 - mov r10, rsi - add r10, Array.data - ; Put end of data array into r11 - mov r11d, [rsi + Array.length] ; Length of array, zero-extended - add r11, r10 - - ret - -;; Move onto the next chunk of the array -;; This is needed because strings are not stored in one -;; contiguous block of memory, but may use multiple Array -;; objects in a linked list -;; -;; If no chunks are left, then R10 = R11 -tokenizer_next_chunk: - mov r10, [r9 + Array.next] - cmp r10, 0 - je .no_more - ; More chunks left - push rsi ; Because symbol reading uses RSI (tokenizer_next.handle_symbol) - mov rsi, r10 - call tokenizer_init - pop rsi - ret -.no_more: - ; No more chunks left. R10 is zero - mov r11, r10 - ret - -;; Moves the next char into CL -;; If no more, puts 0 into CL -tokenizer_next_char: - ; Check if we have reached the end of this chunk - cmp r10, r11 - jne .chars_remain - - ; Hit the end. See if there is another chunk - call tokenizer_next_chunk - cmp r10, r11 - jne .chars_remain ; Success, got another - - ; No more chunks - mov cl, 0 ; Null char signals end - ret - -.chars_remain: - mov cl, BYTE [r10] - inc r10 ; point to next byte - ret - -;; Get the next token -;; Token code is in CL register. Could be: -;; - 0 : Nil, finished -;; - Characters ()[]()'`~^@ -;; - Pair '~@', represented by code 1 -;; - A string: " in CL, and address in RAX -;; - An integer: 'i' in CL -;; - A symbol: 's' in CL, address in RAX -;; -;; Address of object in RAX -;; -;; May use registers: -;; RBX -;; RCX -;; RDX -;; -tokenizer_next: - -.next_char: - ; Fetch the next char into CL - call tokenizer_next_char - - cmp cl, 0 - je .found ; End, no more tokens - - ; Here expect to have: - ; - The current character in CL - ; - Address of next data in r10 - ; - Address of data end in r11 - - ; Skip whitespace or commas - cmp cl, ' ' ; Space - je .next_char - cmp cl, ',' ; Comma - je .next_char - cmp cl, 9 ; Tab - je .next_char - cmp cl, 10 ; Line Feed - je .next_char - cmp cl, 13 ; Carriage Return - je .next_char - - ; Special characters. These are returned in CL as-is - cmp cl, '(' - je .found - cmp cl, ')' - je .found - cmp cl, '[' - je .found - cmp cl, ']' - je .found - cmp cl, '{' - je .found - cmp cl, '}' - je .found - cmp cl, 39 ; character ' - je .found - cmp cl, 96 ; character ` - je .found - cmp cl, '^' - je .found - cmp cl, '@' - je .found - cmp cl, '~' ; Could be followed by '@' - je .handle_tilde - - cmp cl, ';' ; Start of a comment - je .comment - - cmp cl, 34 ; Opening string quotes - je .handle_string - - ; Could be number or symbol - - cmp cl, '-' ; Minus sign - je .handle_minus - mov ch, 0 - - ; Check for a character 0-9 - cmp cl, '0' - jl .handle_symbol - cmp cl, '9' - jg .handle_symbol - - ; Here an integer - jmp .handle_integer - -.comment: - ; Start of a comment. Keep reading until a new line or end - - ; Fetch the next char into CL - call tokenizer_next_char - - cmp cl, 0 - je .found ; End, no more tokens - - cmp cl, 10 - je .next_char ; Next line, start reading again - - jmp .comment - -.handle_minus: - - ; Push current state of the tokenizer - push r9 - push r10 - push r11 - - ; Get the next character - call tokenizer_next_char - - ; Check if it is a number - cmp cl, '0' - jl .minus_not_number - cmp cl, '9' - jg .minus_not_number - - ; Here is a number - mov ch, '-' ; Put '-' in ch for later - - ; Discard old state by moving stack pointer - add rsp, 24 ; 3 * 8 bytes - - jmp .handle_integer - -.minus_not_number: - - ; Restore state - pop r11 - pop r10 - pop r9 - - mov cl, '-' ; Put back - - jmp .handle_symbol - -.handle_integer: - ; Start integer - ; accumulate in EDX - xor edx, edx - -.integer_loop: - ; Here have a char 0-9 in CL - sub cl, '0' ; Convert to number between 0 and 9 - movzx ebx, cl - add edx, ebx - - ; Push current state of the tokenizer - push r9 - push r10 - push r11 - - ; Peek at next character - call tokenizer_next_char ; Next char in CL - - cmp cl, '0' - jl .integer_finished - cmp cl, '9' - jg .integer_finished - - ; Discard old state by moving stack pointer - add rsp, 24 ; 3 * 8 bytes - - imul edx, 10 - - jmp .integer_loop - -.integer_finished: - ; Next char not an int - - ; Restore state of the tokenizer - pop r11 - pop r10 - pop r9 - - push rdx ; Save the integer - ; Get a Cons object to put the result into - call alloc_cons - - pop rdx ; Restore integer - - ; Check if the number should be negative - cmp ch, '-' - jne .integer_store - neg rdx - -.integer_store: - ; Address of Cons now in RAX - mov [rax], BYTE maltype_integer - - mov [rax + Cons.car], rdx - - mov cl, 'i' ; Mark as an integer - ret - - ; ------------------------------------------- -.handle_symbol: - ; Read characters until reaching whitespace, special character or end - - call string_new - mov rsi, rax ; Output string in rsi - -.symbol_loop: - ; Put the current character into the array - call string_append_char - - ; Push current state of the tokenizer - push r9 - push r10 - push r11 - - call tokenizer_next_char - cmp cl, 0 ; End of characters - je .symbol_finished - - cmp cl, ' ' ; Space - je .symbol_finished - cmp cl, ',' ; Comma - je .symbol_finished - cmp cl, 9 ; Tab - je .symbol_finished - cmp cl, 10 ; Line Feed - je .symbol_finished - cmp cl, 13 ; Carriage Return - je .symbol_finished - - cmp cl, '(' - je .symbol_finished - cmp cl, ')' - je .symbol_finished - cmp cl, '[' - je .symbol_finished - cmp cl, ']' - je .symbol_finished - cmp cl, '{' - je .symbol_finished - cmp cl, '}' - je .symbol_finished - cmp cl, 39 ; character ' - je .symbol_finished - cmp cl, 96 ; character ` - je .symbol_finished - cmp cl, '^' - je .symbol_finished - cmp cl, '@' - je .symbol_finished - cmp cl, '~' - je .symbol_finished - cmp cl, ';' ; Start of a comment - je .symbol_finished - cmp cl, 34 ; Opening string quotes - je .symbol_finished - - ; Keeping current character - ; Discard old state by moving stack pointer - add rsp, 24 ; 3 * 8 bytes - - jmp .symbol_loop ; Append to array - -.symbol_finished: - ; Not keeping current character - ; Restore state of the tokenizer - pop r11 - pop r10 - pop r9 - - mov rax, rsi - mov [rax], BYTE maltype_symbol ; Mark as a symbol - mov cl, 's' ; used by read_str - ret - - ; -------------------------------------------- -.handle_string: - ; Get an array to put the string into - - call string_new ; Array in RAX - - ; Put start of data array into rbx - mov rbx, rax - add rbx, Array.data - ; Put end of data array into rdx - mov edx, DWORD [rax + Array.length] ; Length of array, zero-extended - add rdx, rbx - - ; Now read chars from input string and push into output -.string_loop: - - call tokenizer_next_char - cmp cl, 0 ; End of characters - je .error - - cmp cl, 34 ; Finishing '"' - je .string_done ; Leave '"' in CL - - cmp cl, 92 ; Escape '\' - jne .end_string_escape - - ; Current character is a '\' - call tokenizer_next_char - cmp cl, 0 ; End of characters - je .error - - cmp cl, 'n' ; \n, newline - je .insert_newline - - ; Whatever is in cl is now put into string - ; including '"' - jmp .end_string_escape - -.insert_newline: - mov cl, 10 - jmp .end_string_escape - -.end_string_escape: - - ; Put CL onto result array - ; NOTE: this doesn't handle long strings (multiple memory blocks) - mov [rbx], cl - inc rbx - - jmp .string_loop - -.string_done: - ; Calculate the length from rbx - sub rbx, Array.data - sub rbx, rax - mov [rax+Array.length], DWORD ebx - ret - - ; --------------------------------- - -.handle_tilde: - ; Could have '~' or '~@'. Need to peek at the next char - - ; Push current state of the tokenizer - push r9 - push r10 - push r11 - call tokenizer_next_char ; Next char in CL - cmp cl, '@' - jne .tilde_no_amp ; Just '~', not '~@' - ; Got '~@' - mov cl, 1 ; Signals '~@' - - ; Discard old state by moving stack pointer - add rsp, 24 ; 3 * 8 bytes - ret - -.tilde_no_amp: - mov cl, '~' - ; Restore state of the tokenizer - pop r11 - pop r10 - pop r9 - ; fall through to .found -.found: - ret - -.error: - ret - +%include "macros.mac" + +section .data + +;; Reader macro strings + + static quote_symbol_string, db "quote" + static quasiquote_symbol_string, db "quasiquote" + static unquote_symbol_string, db "unquote" + static splice_unquote_symbol_string, db "splice-unquote" + static deref_symbol_string, db "deref" + static with_meta_symbol_string, db "with-meta" + +;; Error message strings + + static error_string_unexpected_end, db "Error: Unexpected end of input (EOF). Could be a missing ) or ]", 10 + static error_string_bracket_not_brace, db "Error: Expecting '}' but got ')'" + +;; Symbols for comparison + + static_symbol nil_symbol, 'nil' + static_symbol true_symbol, 'true' + static_symbol false_symbol, 'false' + +section .text + +;; Read a string into memory as a form (nested lists and atoms) +;; Note: In this implementation the tokenizer is not done separately +;; +;; Input: Address of string (char array) in RSI +;; +;; Output: Address of object in RAX +;; +;; Uses registers: +;; R12 Address of the start of the current list (starts 0) +;; R13 Address of the current list tail +;; R14 Stack pointer at start. Used for unwinding on error +;; R15 Address of first list. Used for unwinding on error +;; +;; In addition, the tokenizer uses +;; +;; RAX (object return) +;; RBX +;; RCX (character return in CL) +;; RDX +;; R8 ** State must be preserved +;; R9 ** +;; R10 ** +;; R12 +;; R13 +;; R14 Original stack pointer on call +;; R15 Top-level list, so all can be released on error +;; +read_str: + ; Initialise tokenizer + call tokenizer_init + + ; Set current list to zero + mov r12, 0 + + ; Set first list to zero + mov r15, 0 + + ; Save stack pointer for unwinding + mov r14, rsp + +.read_loop: + + call tokenizer_next + cmp cl, 0 + jne .got_token + + ; Unexpected end of tokens + mov rdx, error_string_unexpected_end.len + mov rsi, error_string_unexpected_end + jmp .error + +.got_token: + + cmp cl, 'i' ; An integer. Cons object in RAX + je .finished + cmp cl, '"' ; A string. Array object in RAX + je .finished + cmp cl, 's' ; A symbol + je .symbol + + cmp cl, '(' + je .list_start + + cmp cl, ')' + je .return_nil ; Note: if reading a list, cl will be tested in the list reader + + cmp cl, '{' + je .map_start + + cmp cl, '}' ; cl tested in map reader + je .return_nil + + cmp cl, '[' + je .vector_start + + cmp cl, ']' ; cl tested in vector reader + je .return_nil + + cmp cl, 39 ; quote ' + je .handle_quote + cmp cl, '`' + je .handle_quasiquote + cmp cl, '~' + je .handle_unquote + cmp cl, 1 + je .handle_splice_unquote + cmp cl, '@' + je .handle_deref + + cmp cl, '^' + je .handle_with_meta + + ; Unknown + jmp .return_nil + + ; -------------------------------- + +.list_start: + + ; Get the first value + ; Note that we call rather than jmp because the first + ; value needs to be treated differently. There's nothing + ; to append to yet... + call .read_loop + + ; rax now contains the first object + cmp cl, ')' ; Check if it was end of list + jne .list_has_contents + mov cl, 0 ; so ')' doesn't propagate to nested lists + ; Set list to empty + mov [rax], BYTE maltype_empty_list + ret ; Returns 'nil' given "()" +.list_has_contents: + ; If this is a Cons then use it + ; If not, then need to allocate a Cons + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .list_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new list + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.list_is_value: + ; Cons in RAX + ; Make sure it's marked as a list + mov cl, BYTE [rax] + or cl, container_list + mov [rax], BYTE cl + + mov r12, rax ; Start of current list + mov r13, rax ; Set current list + cmp r15, 0 ; Test if first list + jne .list_read_loop + mov r15, rax ; Save the first, for unwinding + +.list_read_loop: + ; Repeatedly get the next value in the list + ; (which may be other lists) + ; until we get a ')' token + + push r12 + push r13 + call .read_loop ; object in rax + pop r13 + pop r12 + + cmp cl, ')' ; Check if it was end of list + je .list_done ; Have nil object in rax + + ; Test if this is a Cons value + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .list_loop_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new list + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.list_loop_is_value: + ; Cons in RAX + + ; Make sure it's marked as a list + mov cl, BYTE [rax] + or cl, container_list + mov [rax], BYTE cl + + ; Append to r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax ; Set current list + + jmp .list_read_loop + +.list_done: + ; Release nil object in rax + mov rsi, rax + call release_cons + + ; Terminate the list + mov [r13 + Cons.typecdr], BYTE content_nil + mov QWORD [r13 + Cons.cdr], QWORD 0 + mov rax, r12 ; Start of current list + + ret + + ; -------------------------------- + +.map_start: + + ; Get the first value + ; Note that we call rather than jmp because the first + ; value needs to be treated differently. There's nothing + ; to append to yet... + call .read_loop + + ; rax now contains the first object + cmp cl, '}' ; Check if it was end of map + jne .map_has_contents + mov cl, 0 ; so '}' doesn't propagate to nested maps + ; Set map to empty + mov [rax], BYTE maltype_empty_map + ret ; Returns 'nil' given "()" +.map_has_contents: + ; If this is a Cons then use it + ; If not, then need to allocate a Cons + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .map_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new map + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_map + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.map_is_value: + ; Cons in RAX + ; Make sure it's marked as a map + mov cl, BYTE [rax] + or cl, container_map + mov [rax], BYTE cl + + mov r12, rax ; Start of current map + mov r13, rax ; Set current map + cmp r15, 0 ; Test if first map + jne .map_read_loop + mov r15, rax ; Save the first, for unwinding + +.map_read_loop: + ; Repeatedly get the next value in the map + ; (which may be other maps) + ; until we get a '}' token + + push r12 + push r13 + call .read_loop ; object in rax + pop r13 + pop r12 + + cmp cl, '}' ; Check if it was end of map + je .map_done ; Have nil object in rax + + ; Test if this is a Cons value + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .map_loop_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new map + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_map + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.map_loop_is_value: + ; Cons in RAX + + ; Make sure it's marked as a map + mov cl, BYTE [rax] + or cl, container_map + mov [rax], BYTE cl + + ; Append to r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax ; Set current map + + jmp .map_read_loop + +.map_done: + ; Release nil object in rax + mov rsi, rax + call release_cons + + ; Terminate the map + mov [r13 + Cons.typecdr], BYTE content_nil + mov QWORD [r13 + Cons.cdr], QWORD 0 + mov rax, r12 ; Start of current map + + ret + + ; -------------------------------- + +.vector_start: + + ; Get the first value + ; Note that we call rather than jmp because the first + ; value needs to be treated differently. There's nothing + ; to append to yet... + call .read_loop + + ; rax now contains the first object + cmp cl, ']' ; Check if it was end of vector + jne .vector_has_contents + mov cl, 0 ; so ']' doesn't propagate to nested vectors + ; Set vector to empty + mov [rax], BYTE maltype_empty_vector + ret ; Returns 'nil' given "()" +.vector_has_contents: + ; If this is a Cons then use it + ; If not, then need to allocate a Cons + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .vector_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new vector + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_vector + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.vector_is_value: + ; Cons in RAX + ; Make sure it's marked as a vector + mov cl, BYTE [rax] + or cl, container_vector + mov [rax], BYTE cl + + mov r12, rax ; Start of current vector + mov r13, rax ; Set current vector + cmp r15, 0 ; Test if first vector + jne .vector_read_loop + mov r15, rax ; Save the first, for unwinding + +.vector_read_loop: + ; Repeatedly get the next value in the vector + ; (which may be other vectors) + ; until we get a ']' token + + push r12 + push r13 + call .read_loop ; object in rax + pop r13 + pop r12 + + cmp cl, ']' ; Check if it was end of vector + je .vector_done ; Have nil object in rax + + ; Test if this is a Cons value + mov cl, BYTE [rax] + mov ch, cl + and ch, (block_mask + container_mask) ; Tests block and container type + jz .vector_loop_is_value + + ; If here then not a simple value, so need to allocate + ; a Cons object + + ; Start new vector + push rax + call alloc_cons ; Address in rax + pop rbx + mov [rax], BYTE (block_cons + container_vector + content_pointer) + mov [rax + Cons.car], rbx + ; Now have Cons in RAX, containing pointer to object as car + +.vector_loop_is_value: + ; Cons in RAX + + ; Make sure it's marked as a vector + mov cl, BYTE [rax] + or cl, container_vector + mov [rax], BYTE cl + + ; Append to r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax ; Set current vector + + jmp .vector_read_loop + +.vector_done: + ; Release nil object in rax + mov rsi, rax + call release_cons + + ; Terminate the vector + mov [r13 + Cons.typecdr], BYTE content_nil + mov QWORD [r13 + Cons.cdr], QWORD 0 + mov rax, r12 ; Start of current vector + + ret + + ; -------------------------------- +.handle_quote: + ; Turn 'a into (quote a) + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "quote" + push r8 + push r9 + mov rsi, quote_symbol_string + mov edx, quote_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + +.wrap_next_object: + mov [rax], BYTE maltype_symbol + mov [r12], BYTE (block_cons + container_list + content_pointer) + mov [r12 + Cons.car], rax + + ; Get the next object + push r12 + call .read_loop ; object in rax + pop r12 + + mov r13, rax ; Put object to be quoted in r13 + + call alloc_cons ; Address in rax + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r13 + mov [rax + Cons.typecdr], BYTE content_nil + + ; Cons object in rax. Append to object in r12 + mov [r12 + Cons.typecdr], BYTE content_pointer + mov [r12 + Cons.cdr], rax + + mov rax, r12 + ret + + ; -------------------------------- +.handle_quasiquote: + ; Turn `a into (quasiquote a) + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "quasiquote" + push r8 + push r9 + mov rsi, quasiquote_symbol_string + mov edx, quasiquote_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + jmp .wrap_next_object ; From there the same as handle_quote + + ; -------------------------------- +.handle_unquote: + ; Turn ~a into (unquote a) + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "unquote" + push r8 + push r9 + mov rsi, unquote_symbol_string + mov edx, unquote_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + jmp .wrap_next_object ; From there the same as handle_quote + + ; -------------------------------- +.handle_splice_unquote: + ; Turn ~@a into (unquote a) + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "unquote" + push r8 + push r9 + mov rsi, splice_unquote_symbol_string + mov edx, splice_unquote_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + jmp .wrap_next_object ; From there the same as handle_quote + + ; -------------------------------- + +.handle_deref: + ; Turn @a into (deref a) + + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "deref" + push r8 + push r9 + mov rsi, deref_symbol_string + mov edx, deref_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + jmp .wrap_next_object ; From there the same as handle_quote + + ; -------------------------------- + +.handle_with_meta: + ; Turn ^ a b into (with-meta b a) + + call alloc_cons ; Address in rax + mov r12, rax + + ; Get a symbol "with-meta" + push r8 + push r9 + mov rsi, with_meta_symbol_string + mov edx, with_meta_symbol_string.len + call raw_to_string ; Address in rax + pop r9 + pop r8 + + mov [rax], BYTE maltype_symbol + mov [r12], BYTE (block_cons + container_list + content_pointer) + mov [r12 + Cons.car], rax + + ; Get the next two objects + push r12 + call .read_loop ; object in rax + pop r12 + push rax + push r12 + call .read_loop ; in RAX + pop r12 + + mov r13, rax + + call alloc_cons ; Address in rax + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r13 + + ; Cons object in rax. Append to object in r12 + mov [r12 + Cons.typecdr], BYTE content_pointer + mov [r12 + Cons.cdr], rax + + mov r13, rax + + call alloc_cons ; Address in rax + mov [rax], BYTE (block_cons + container_list + content_pointer) + + pop rdi ; First object + mov [rax + Cons.car], rdi + + ; Append to object in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + + mov rax, r12 + ret + + ; -------------------------------- +.symbol: + ; symbol is in RAX + ; Some symbols are have their own type + ; - nil, true, false + ; + + mov rsi, rax + mov rdi, nil_symbol + push rsi + call compare_char_array + pop rsi + cmp rax, 0 + je .symbol_nil + + mov rdi, true_symbol + push rsi + call compare_char_array + pop rsi + cmp rax, 0 + je .symbol_true + + mov rdi, false_symbol + push rsi + call compare_char_array + pop rsi + cmp rax, 0 + je .symbol_false + + ; not a special symbol, so return + mov rax, rsi + ret + +.symbol_nil: + ; symbol in rsi not needed + call release_array + + call alloc_cons + mov [rax], BYTE maltype_nil ; a nil type + ret + +.symbol_true: + call release_array + + call alloc_cons + mov [rax], BYTE maltype_true + ret + +.symbol_false: + call release_array + + call alloc_cons + mov [rax], BYTE maltype_false + ret + + ; -------------------------------- +.finished: + ret + +.error: + ; Jump here on error with raw string in RSI + ; and string length in rdx + push r14 + push r15 + call print_rawstring + pop r15 + pop r14 + + ; fall through to unwind +.unwind: + ; Jump to here cleans up + + mov rsp, r14 ; Rewind stack pointer + cmp r15, 0 ; Check if there is a list + je .return_nil + mov rsi, r15 + call release_cons ; releases everything recursively + ; fall through to return_nil +.return_nil: + ; Allocates a new Cons object with nil and returns + ; Cleanup should happen before jumping here + push rcx + call alloc_cons + pop rcx + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + + +;; Initialise the tokenizer +;; +;; Input: Address of string in RSI +;; +;; NOTE: This uses RSI, RAX and RBX, and expects these to be preserved +;; between calls to tokenizer_next_char +;; +;; R9 Address of string +;; R10 Position in data array +;; R11 End of data array +;; +tokenizer_init: + ; Save string to r9 + mov r9, rsi + ; Put start of data array into r10 + mov r10, rsi + add r10, Array.data + ; Put end of data array into r11 + mov r11d, [rsi + Array.length] ; Length of array, zero-extended + add r11, r10 + + ret + +;; Move onto the next chunk of the array +;; This is needed because strings are not stored in one +;; contiguous block of memory, but may use multiple Array +;; objects in a linked list +;; +;; If no chunks are left, then R10 = R11 +tokenizer_next_chunk: + mov r10, [r9 + Array.next] + cmp r10, 0 + je .no_more + ; More chunks left + push rsi ; Because symbol reading uses RSI (tokenizer_next.handle_symbol) + mov rsi, r10 + call tokenizer_init + pop rsi + ret +.no_more: + ; No more chunks left. R10 is zero + mov r11, r10 + ret + +;; Moves the next char into CL +;; If no more, puts 0 into CL +tokenizer_next_char: + ; Check if we have reached the end of this chunk + cmp r10, r11 + jne .chars_remain + + ; Hit the end. See if there is another chunk + call tokenizer_next_chunk + cmp r10, r11 + jne .chars_remain ; Success, got another + + ; No more chunks + mov cl, 0 ; Null char signals end + ret + +.chars_remain: + mov cl, BYTE [r10] + inc r10 ; point to next byte + ret + +;; Get the next token +;; Token code is in CL register. Could be: +;; - 0 : Nil, finished +;; - Characters ()[]()'`~^@ +;; - Pair '~@', represented by code 1 +;; - A string: " in CL, and address in RAX +;; - An integer: 'i' in CL +;; - A symbol: 's' in CL, address in RAX +;; +;; Address of object in RAX +;; +;; May use registers: +;; RBX +;; RCX +;; RDX +;; +tokenizer_next: + +.next_char: + ; Fetch the next char into CL + call tokenizer_next_char + + cmp cl, 0 + je .found ; End, no more tokens + + ; Here expect to have: + ; - The current character in CL + ; - Address of next data in r10 + ; - Address of data end in r11 + + ; Skip whitespace or commas + cmp cl, ' ' ; Space + je .next_char + cmp cl, ',' ; Comma + je .next_char + cmp cl, 9 ; Tab + je .next_char + cmp cl, 10 ; Line Feed + je .next_char + cmp cl, 13 ; Carriage Return + je .next_char + + ; Special characters. These are returned in CL as-is + cmp cl, '(' + je .found + cmp cl, ')' + je .found + cmp cl, '[' + je .found + cmp cl, ']' + je .found + cmp cl, '{' + je .found + cmp cl, '}' + je .found + cmp cl, 39 ; character ' + je .found + cmp cl, 96 ; character ` + je .found + cmp cl, '^' + je .found + cmp cl, '@' + je .found + cmp cl, '~' ; Could be followed by '@' + je .handle_tilde + + cmp cl, ';' ; Start of a comment + je .comment + + cmp cl, 34 ; Opening string quotes + je .handle_string + + ; Could be number or symbol + + cmp cl, '-' ; Minus sign + je .handle_minus + mov ch, 0 + + ; Check for a character 0-9 + cmp cl, '0' + jl .handle_symbol + cmp cl, '9' + jg .handle_symbol + + ; Here an integer + jmp .handle_integer + +.comment: + ; Start of a comment. Keep reading until a new line or end + + ; Fetch the next char into CL + call tokenizer_next_char + + cmp cl, 0 + je .found ; End, no more tokens + + cmp cl, 10 + je .next_char ; Next line, start reading again + + jmp .comment + +.handle_minus: + + ; Push current state of the tokenizer + push r9 + push r10 + push r11 + + ; Get the next character + call tokenizer_next_char + + ; Check if it is a number + cmp cl, '0' + jl .minus_not_number + cmp cl, '9' + jg .minus_not_number + + ; Here is a number + mov ch, '-' ; Put '-' in ch for later + + ; Discard old state by moving stack pointer + add rsp, 24 ; 3 * 8 bytes + + jmp .handle_integer + +.minus_not_number: + + ; Restore state + pop r11 + pop r10 + pop r9 + + mov cl, '-' ; Put back + + jmp .handle_symbol + +.handle_integer: + ; Start integer + ; accumulate in EDX + xor edx, edx + +.integer_loop: + ; Here have a char 0-9 in CL + sub cl, '0' ; Convert to number between 0 and 9 + movzx ebx, cl + add edx, ebx + + ; Push current state of the tokenizer + push r9 + push r10 + push r11 + + ; Peek at next character + call tokenizer_next_char ; Next char in CL + + cmp cl, '0' + jl .integer_finished + cmp cl, '9' + jg .integer_finished + + ; Discard old state by moving stack pointer + add rsp, 24 ; 3 * 8 bytes + + imul edx, 10 + + jmp .integer_loop + +.integer_finished: + ; Next char not an int + + ; Restore state of the tokenizer + pop r11 + pop r10 + pop r9 + + push rdx ; Save the integer + ; Get a Cons object to put the result into + call alloc_cons + + pop rdx ; Restore integer + + ; Check if the number should be negative + cmp ch, '-' + jne .integer_store + neg rdx + +.integer_store: + ; Address of Cons now in RAX + mov [rax], BYTE maltype_integer + + mov [rax + Cons.car], rdx + + mov cl, 'i' ; Mark as an integer + ret + + ; ------------------------------------------- +.handle_symbol: + ; Read characters until reaching whitespace, special character or end + + call string_new + mov rsi, rax ; Output string in rsi + +.symbol_loop: + ; Put the current character into the array + call string_append_char + + ; Push current state of the tokenizer + push r9 + push r10 + push r11 + + call tokenizer_next_char + cmp cl, 0 ; End of characters + je .symbol_finished + + cmp cl, ' ' ; Space + je .symbol_finished + cmp cl, ',' ; Comma + je .symbol_finished + cmp cl, 9 ; Tab + je .symbol_finished + cmp cl, 10 ; Line Feed + je .symbol_finished + cmp cl, 13 ; Carriage Return + je .symbol_finished + + cmp cl, '(' + je .symbol_finished + cmp cl, ')' + je .symbol_finished + cmp cl, '[' + je .symbol_finished + cmp cl, ']' + je .symbol_finished + cmp cl, '{' + je .symbol_finished + cmp cl, '}' + je .symbol_finished + cmp cl, 39 ; character ' + je .symbol_finished + cmp cl, 96 ; character ` + je .symbol_finished + cmp cl, '^' + je .symbol_finished + cmp cl, '@' + je .symbol_finished + cmp cl, '~' + je .symbol_finished + cmp cl, ';' ; Start of a comment + je .symbol_finished + cmp cl, 34 ; Opening string quotes + je .symbol_finished + + ; Keeping current character + ; Discard old state by moving stack pointer + add rsp, 24 ; 3 * 8 bytes + + jmp .symbol_loop ; Append to array + +.symbol_finished: + ; Not keeping current character + ; Restore state of the tokenizer + pop r11 + pop r10 + pop r9 + + mov rax, rsi + mov [rax], BYTE maltype_symbol ; Mark as a symbol + mov cl, 's' ; used by read_str + ret + + ; -------------------------------------------- +.handle_string: + ; Get an array to put the string into + + call string_new ; Array in RAX + + ; Put start of data array into rbx + mov rbx, rax + add rbx, Array.data + ; Put end of data array into rdx + mov edx, DWORD [rax + Array.length] ; Length of array, zero-extended + add rdx, rbx + + ; Now read chars from input string and push into output +.string_loop: + + call tokenizer_next_char + cmp cl, 0 ; End of characters + je .error + + cmp cl, 34 ; Finishing '"' + je .string_done ; Leave '"' in CL + + cmp cl, 92 ; Escape '\' + jne .end_string_escape + + ; Current character is a '\' + call tokenizer_next_char + cmp cl, 0 ; End of characters + je .error + + cmp cl, 'n' ; \n, newline + je .insert_newline + + ; Whatever is in cl is now put into string + ; including '"' + jmp .end_string_escape + +.insert_newline: + mov cl, 10 + jmp .end_string_escape + +.end_string_escape: + + ; Put CL onto result array + ; NOTE: this doesn't handle long strings (multiple memory blocks) + mov [rbx], cl + inc rbx + + jmp .string_loop + +.string_done: + ; Calculate the length from rbx + sub rbx, Array.data + sub rbx, rax + mov [rax+Array.length], DWORD ebx + ret + + ; --------------------------------- + +.handle_tilde: + ; Could have '~' or '~@'. Need to peek at the next char + + ; Push current state of the tokenizer + push r9 + push r10 + push r11 + call tokenizer_next_char ; Next char in CL + cmp cl, '@' + jne .tilde_no_amp ; Just '~', not '~@' + ; Got '~@' + mov cl, 1 ; Signals '~@' + + ; Discard old state by moving stack pointer + add rsp, 24 ; 3 * 8 bytes + ret + +.tilde_no_amp: + mov cl, '~' + ; Restore state of the tokenizer + pop r11 + pop r10 + pop r9 + ; fall through to .found +.found: + ret + +.error: + ret + diff --git a/impls/nasm/run b/impls/nasm/run index 0ecd249cae..e5743789fa 100755 --- a/impls/nasm/run +++ b/impls/nasm/run @@ -1,3 +1,3 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" - +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" + diff --git a/impls/nasm/step0_repl.asm b/impls/nasm/step0_repl.asm index 850f69ee81..0062e05632 100644 --- a/impls/nasm/step0_repl.asm +++ b/impls/nasm/step0_repl.asm @@ -1,82 +1,82 @@ -;; -;; nasm -felf64 step0_repl.asm && ld step0_repl.o && ./a.out - -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "system.asm" ; System calls -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - -section .text - -;; Takes a string as input and processes it into a form -read: - mov rax, rsi ; Return the input - ret - -;; ---------------------------------------------- -;; Evaluates a form -eval: - mov rax, rsi ; Return the input - ret - -;; Prints the result -print: - mov rax, rsi ; Return the input - ret - -;; Read-Eval-Print in sequence -rep_seq: - ; ------------- - ; Read - call read - - ; ------------- - ; Eval - mov rsi, rax ; Output of read into input of eval - call eval - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - call print - - ret - - -_start: - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - mov rsi, rax ; Put into input of print_string - call print_string - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - +;; +;; nasm -felf64 step0_repl.asm && ld step0_repl.o && ./a.out + +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "system.asm" ; System calls +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + +section .text + +;; Takes a string as input and processes it into a form +read: + mov rax, rsi ; Return the input + ret + +;; ---------------------------------------------- +;; Evaluates a form +eval: + mov rax, rsi ; Return the input + ret + +;; Prints the result +print: + mov rax, rsi ; Return the input + ret + +;; Read-Eval-Print in sequence +rep_seq: + ; ------------- + ; Read + call read + + ; ------------- + ; Eval + mov rsi, rax ; Output of read into input of eval + call eval + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + call print + + ret + + +_start: + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + mov rsi, rax ; Put into input of print_string + call print_string + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + diff --git a/impls/nasm/step1_read_print.asm b/impls/nasm/step1_read_print.asm index e02ebee968..84b690ef2a 100644 --- a/impls/nasm/step1_read_print.asm +++ b/impls/nasm/step1_read_print.asm @@ -1,106 +1,106 @@ -;; -;; nasm -felf64 step1_read_print.asm && ld step1_read_print.o && ./a.out - -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - -section .text - -;; Takes a string as input and processes it into a form -read: - jmp read_str ; In reader.asm - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; -eval: - mov rax, rsi ; Return the input - ret - -;; Prints the result -print: - mov rdi, 1 ; print readably - jmp pr_str - -;; Read-Eval-Print in sequence -rep_seq: - ; ------------- - ; Read - call read - push rax ; Save form - - ; ------------- - ; Eval - mov rsi, rax ; Output of read into input of eval - call eval - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - call print ; String in RAX - - mov r8, rax ; Save output - pop rsi ; Form returned by read - call release_object - mov rax, r8 - - ret - - -_start: - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - +;; +;; nasm -felf64 step1_read_print.asm && ld step1_read_print.o && ./a.out + +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + +section .text + +;; Takes a string as input and processes it into a form +read: + jmp read_str ; In reader.asm + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; +eval: + mov rax, rsi ; Return the input + ret + +;; Prints the result +print: + mov rdi, 1 ; print readably + jmp pr_str + +;; Read-Eval-Print in sequence +rep_seq: + ; ------------- + ; Read + call read + push rax ; Save form + + ; ------------- + ; Eval + mov rsi, rax ; Output of read into input of eval + call eval + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + call print ; String in RAX + + mov r8, rax ; Save output + pop rsi ; Form returned by read + call release_object + mov rax, r8 + + ret + + +_start: + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + diff --git a/impls/nasm/step2_eval.asm b/impls/nasm/step2_eval.asm index 119871bbaa..d69a5f9e84 100644 --- a/impls/nasm/step2_eval.asm +++ b/impls/nasm/step2_eval.asm @@ -1,683 +1,683 @@ -;; -;; nasm -felf64 step2_eval.asm && ld step2_eval.o && ./a.out - -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .bss - -;; Top-level (REPL) environment -repl_env:resq 1 - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - - static error_string, db 27,'[31m',"Error",27,'[0m',": " - - -;; Symbols used for comparison - - static_symbol def_symbol, 'def!' - static_symbol let_symbol, 'let*' - - static core_add_symbol, db "+" - static core_sub_symbol, db "-" - static core_mul_symbol, db "*" - static core_div_symbol, db "/" - -section .text - -;; Integer arithmetic operations -;; -;; Adds a list of numbers, address in RSI -;; Returns the sum as a number object with address in RAX -;; Since most of the code is common to all operators, -;; RBX is used to jump to the required instruction -core_add: - mov rbx, core_arithmetic.do_addition - jmp core_arithmetic -core_sub: - mov rbx, core_arithmetic.do_subtraction - jmp core_arithmetic -core_mul: - mov rbx, core_arithmetic.do_multiply - jmp core_arithmetic -core_div: - mov rbx, core_arithmetic.do_division - ; Fall through to core_arithmetic -core_arithmetic: - ; Check that the first object is a number - mov cl, BYTE [rsi] - mov ch, cl - and ch, block_mask - cmp ch, block_cons - jne .missing_args - - mov ch, cl - and ch, content_mask - cmp ch, content_empty - je .missing_args - - cmp ch, content_int - jne .not_int - - ; Put the starting value in rax - mov rax, [rsi + Cons.car] - -.add_loop: - ; Fetch the next value - mov cl, [rsi + Cons.typecdr] - cmp cl, content_pointer - jne .finished ; Nothing let - - mov rsi, [rsi + Cons.cdr] ; Get next cons - - ; Check that it is an integer - mov cl, BYTE [rsi] - and cl, content_mask - cmp cl, content_int - jne .not_int - - ; Jump to the required operation, address in RBX - jmp rbx - -.do_addition: - add rax, [rsi + Cons.car] - jmp .add_loop -.do_subtraction: - sub rax, [rsi + Cons.car] - jmp .add_loop -.do_multiply: - imul rax, [rsi + Cons.car] - jmp .add_loop -.do_division: - cqo ; Sign extend RAX into RDX - mov rcx, [rsi + Cons.car] - idiv rcx - jmp .add_loop - -.finished: - ; Value in rbx - push rax - ; Get a Cons object to put the result into - call alloc_cons - pop rbx - mov [rax], BYTE maltype_integer - mov [rax + Cons.car], rbx - ret - -.missing_args: -.not_int: - jmp quit - -;; Add a native function to the core environment -;; This is used in core_environment -%macro core_env_native 2 - push rsi ; environment - mov rsi, %1 - mov edx, %1.len - call raw_to_symbol ; Symbol in RAX - push rax - - mov rsi, %2 - call native_function ; Function in RAX - - mov rcx, rax ; value (function) - pop rdi ; key (symbol) - pop rsi ; environment - call map_set -%endmacro - - - -;; Takes a string as input and processes it into a form -read: - jmp read_str ; In reader.asm - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; -eval_ast: - ; Check the type - mov al, BYTE [rsi] - - ; Check if this is a list - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list - - cmp ah, container_map - je .map - - cmp ah, container_vector - je .vector - - ; Not a list, map or vector - cmp ah, container_symbol - je .symbol - - ; Not a symbol, list, map or vector - call incref_object ; Increment reference count - - mov rax, rsi - ret - -.symbol: - ; look in environment - mov rdi, rsi ; symbol is the key - mov rsi, [repl_env] ; Environment - call map_get - je .done ; result in RAX - - ; Not found, should raise an error - - ; Return nil - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - -.list: - ; Evaluate each element of the list - ; - xor r8, r8 ; The list to return - ; r9 contains head of list - -.list_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .list_pointer - - ; A value in RSI, so copy - - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_list) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .list_append - -.list_pointer: - ; List element is a pointer to something - push rsi - push r8 - push r9 - mov rsi, [rsi + Cons.car] ; Get the address - call eval ; Evaluate it, result in rax - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .list_append - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_list + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - ; Fall through to .list_append - -.list_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .list_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .list_next - -.list_first: - mov r8, rax - mov r9, rax - ; fall through to .list_next - -.list_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .list_done ; finished list - mov rsi, [rsi + Cons.cdr] ; next in list - jmp .list_loop - -.list_done: - mov rax, r8 ; Return the list - ret - - ; --------------------- -.map: - ; Create a new map, evaluating all the values - - ; Check if the map is empty - cmp al, maltype_empty_map - jne .map_not_empty - - ; map empty. Just return it - call incref_object - mov rax, rsi - ret - -.map_not_empty: - - mov r10, rsi ; input in R10 - xor r12, r12 ; New map in r12 - - ; Now loop through each key-value pair - ; NOTE: This method relies on the implementation - ; of map as a list - -.map_loop: - ; Copy the key - call alloc_cons ; New Cons in RAX - - mov bl, [r10 + Cons.typecar] ; Type in BL - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] ; Value in RCX - mov [rax + Cons.car], rcx - - ; Check the type of the key - and bl, content_mask - cmp bl, content_pointer - jne .map_got_key ; a value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.map_got_key: - cmp r12,0 - jne .append_key - - ; First key - mov r12, rax - mov r13, rax - jmp .map_value - -.append_key: - ; Appending to previous value in r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - -.map_value: - ; Check that we have a value - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_error_missing_value - mov r10, [r10 + Cons.cdr] - - ; Now got value in r10 - - ; Check the type of the value - mov bl, [r10 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .map_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r10 + Cons.typecar] - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .map_got_value -.map_value_pointer: - ; A pointer, so need to evaluate - push r10 ; Input - push r12 ; start of result - push r13 ; Current head of result - mov rsi, [r10 + Cons.car] ; Get the address - call eval ; Evaluate it, result in rax - pop r13 - pop r12 - pop r10 - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - - jne .map_eval_pointer - - ; A value, so just change the type to a map - and bl, content_mask - add bl, (block_cons + container_map) - mov [rax], BYTE bl - jmp .map_got_value - -.map_eval_pointer: - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - -.map_got_value: - ; Append RAX to list in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - - ; Check if there's another key - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_done ; finished map - mov r10, [r10 + Cons.cdr] ; next in map - jmp .map_loop - -.map_done: - mov rax, r12 - ret - -.map_error_missing_value: - mov rax, r12 - ret - - ; ------------------------------ -.vector: - ; Evaluate each element of the vector - ; - xor r8, r8 ; The vector to return - ; r9 contains head of vector - -.vector_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .vector_pointer - - ; A value, so copy - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_vector) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .vector_append - -.vector_pointer: - ; Vector element is a pointer to something - push rsi - push r8 - push r9 - mov rsi, [rsi + Cons.car] ; Get the address - call eval ; Evaluate it, result in rax - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .vector_append_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_vector + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .vector_append - -.vector_append_value: - or bl, container_vector - mov [rax], BYTE bl - -.vector_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .vector_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .vector_next - -.vector_first: - mov r8, rax - mov r9, rax - ; fall through to .vector_next - -.vector_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .vector_done ; finished vector - mov rsi, [rsi + Cons.cdr] ; next in vector - jmp .vector_loop - -.vector_done: - mov rax, r8 ; Return the vector - ret - - ; --------------------- -.done: - ret - -;; ---------------------------------------------------- -;; Evaluates a form -;; -;; Input: RSI AST to evaluate -;; -;; Returns: Result in RAX -;; -eval: - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - and al, container_mask - cmp al, container_list - je .list - - ; Not a list. Evaluate and return - call eval_ast - ret - - ; -------------------- -.list: - ; A list - - ; Check if the first element is a symbol - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .list_eval - - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .list_eval - - ; Is a symbol, address in RBX - push rsi - - ; Compare against def! - mov rsi, rbx - mov rdi, def_symbol - call compare_char_array - pop rsi - cmp rax, 0 - je .def_symbol - - push rsi - mov rdi, let_symbol - call compare_char_array - pop rsi - cmp rax, 0 - je .let_symbol - - ; Unrecognised - jmp .list_eval - -.def_symbol: - ; Define a new symbol in current environment - - jmp .list_not_function -.let_symbol: - ; Create a new environment - - jmp .list_not_function -.list_eval: - - call eval_ast - - ; Check that the first element of the return is a function - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .list_not_function - - mov rbx, [rax + Cons.car] ; Get the address - mov cl, BYTE [rbx] - cmp cl, maltype_function - jne .list_not_function - - ; Call the function with the rest of the list in RSI - push rax - mov rsi, [rax + Cons.cdr] ; Rest of list - mov rdi, rbx ; Function object in RDI - call [rbx + Cons.car] ; Call function - ; Result in rax - pop rsi ; eval'ed list - push rax - call release_cons - pop rax - ret - -.list_not_function: - ; Not a function. Probably an error - ret - -.empty_list: - mov rax, rsi - ret - -;; Prints the result -print: - mov rdi, 1 ; print readably - jmp pr_str - -;; Read-Eval-Print in sequence -rep_seq: - ; ------------- - ; Read - call read - push rax ; Save form - - ; ------------- - ; Eval - mov rsi, rax ; Output of read into input of eval - call eval - push rax ; Save result - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - call print ; String in RAX - - mov r8, rax ; Save output - - pop rsi ; Result from eval - call release_object - pop rsi ; Form returned by read - call release_object - mov rax, r8 - - ret - - -_start: - ; Create and print the core environment - call map_new ; Environment in RAX - - mov [repl_env], rax ; store in memory - - mov rsi, rax ; Environment - - ; Add +,-,*,/ to environment - core_env_native core_add_symbol, core_add - core_env_native core_sub_symbol, core_sub - core_env_native core_mul_symbol, core_mul - core_env_native core_div_symbol, core_div - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - +;; +;; nasm -felf64 step2_eval.asm && ld step2_eval.o && ./a.out + +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + + static core_add_symbol, db "+" + static core_sub_symbol, db "-" + static core_mul_symbol, db "*" + static core_div_symbol, db "/" + +section .text + +;; Integer arithmetic operations +;; +;; Adds a list of numbers, address in RSI +;; Returns the sum as a number object with address in RAX +;; Since most of the code is common to all operators, +;; RBX is used to jump to the required instruction +core_add: + mov rbx, core_arithmetic.do_addition + jmp core_arithmetic +core_sub: + mov rbx, core_arithmetic.do_subtraction + jmp core_arithmetic +core_mul: + mov rbx, core_arithmetic.do_multiply + jmp core_arithmetic +core_div: + mov rbx, core_arithmetic.do_division + ; Fall through to core_arithmetic +core_arithmetic: + ; Check that the first object is a number + mov cl, BYTE [rsi] + mov ch, cl + and ch, block_mask + cmp ch, block_cons + jne .missing_args + + mov ch, cl + and ch, content_mask + cmp ch, content_empty + je .missing_args + + cmp ch, content_int + jne .not_int + + ; Put the starting value in rax + mov rax, [rsi + Cons.car] + +.add_loop: + ; Fetch the next value + mov cl, [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .finished ; Nothing let + + mov rsi, [rsi + Cons.cdr] ; Get next cons + + ; Check that it is an integer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_int + jne .not_int + + ; Jump to the required operation, address in RBX + jmp rbx + +.do_addition: + add rax, [rsi + Cons.car] + jmp .add_loop +.do_subtraction: + sub rax, [rsi + Cons.car] + jmp .add_loop +.do_multiply: + imul rax, [rsi + Cons.car] + jmp .add_loop +.do_division: + cqo ; Sign extend RAX into RDX + mov rcx, [rsi + Cons.car] + idiv rcx + jmp .add_loop + +.finished: + ; Value in rbx + push rax + ; Get a Cons object to put the result into + call alloc_cons + pop rbx + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rbx + ret + +.missing_args: +.not_int: + jmp quit + +;; Add a native function to the core environment +;; This is used in core_environment +%macro core_env_native 2 + push rsi ; environment + mov rsi, %1 + mov edx, %1.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, %2 + call native_function ; Function in RAX + + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call map_set +%endmacro + + + +;; Takes a string as input and processes it into a form +read: + jmp read_str ; In reader.asm + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; +eval_ast: + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; look in environment + mov rdi, rsi ; symbol is the key + mov rsi, [repl_env] ; Environment + call map_get + je .done ; result in RAX + + ; Not found, should raise an error + + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + mov rsi, [rsi + Cons.car] ; Get the address + call eval ; Evaluate it, result in rax + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_append + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + ; Fall through to .list_append + +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + mov rsi, [r10 + Cons.car] ; Get the address + call eval ; Evaluate it, result in rax + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + mov rsi, [rsi + Cons.car] ; Get the address + call eval ; Evaluate it, result in rax + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_append_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_append_value: + or bl, container_vector + mov [rax], BYTE bl + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate +;; +;; Returns: Result in RAX +;; +eval: + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + ret + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + push rsi + + ; Compare against def! + mov rsi, rbx + mov rdi, def_symbol + call compare_char_array + pop rsi + cmp rax, 0 + je .def_symbol + + push rsi + mov rdi, let_symbol + call compare_char_array + pop rsi + cmp rax, 0 + je .let_symbol + + ; Unrecognised + jmp .list_eval + +.def_symbol: + ; Define a new symbol in current environment + + jmp .list_not_function +.let_symbol: + ; Create a new environment + + jmp .list_not_function +.list_eval: + + call eval_ast + + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Call the function with the rest of the list in RSI + push rax + mov rsi, [rax + Cons.cdr] ; Rest of list + mov rdi, rbx ; Function object in RDI + call [rbx + Cons.car] ; Call function + ; Result in rax + pop rsi ; eval'ed list + push rax + call release_cons + pop rax + ret + +.list_not_function: + ; Not a function. Probably an error + ret + +.empty_list: + mov rax, rsi + ret + +;; Prints the result +print: + mov rdi, 1 ; print readably + jmp pr_str + +;; Read-Eval-Print in sequence +rep_seq: + ; ------------- + ; Read + call read + push rax ; Save form + + ; ------------- + ; Eval + mov rsi, rax ; Output of read into input of eval + call eval + push rax ; Save result + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + call print ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + pop rsi ; Form returned by read + call release_object + mov rax, r8 + + ret + + +_start: + ; Create and print the core environment + call map_new ; Environment in RAX + + mov [repl_env], rax ; store in memory + + mov rsi, rax ; Environment + + ; Add +,-,*,/ to environment + core_env_native core_add_symbol, core_add + core_env_native core_sub_symbol, core_sub + core_env_native core_mul_symbol, core_mul + core_env_native core_div_symbol, core_div + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + diff --git a/impls/nasm/step3_env.asm b/impls/nasm/step3_env.asm index 70460bafae..4c9573b9b8 100644 --- a/impls/nasm/step3_env.asm +++ b/impls/nasm/step3_env.asm @@ -1,1078 +1,1078 @@ -;; -;; nasm -felf64 step3_env.asm && ld step3_env.o && ./a.out -;; -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "env.asm" ; Environment type -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .bss - -;; Top-level (REPL) environment -repl_env:resq 1 - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - - static error_string, db 27,'[31m',"Error",27,'[0m',": " - - static not_found_string, db " not found" - - static def_missing_arg_string, db "missing argument to def!",10 - - static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 - - static let_missing_bindings_string, db "let* missing bindings",10 - - static let_bindings_list_string, db "let* expected a list or vector of bindings",10 - - static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 - - static let_bind_value_string, db "let* missing value in bindings list",10 - - static let_missing_body_string, db "let* missing body",10 - - -;; Symbols used for comparison - - static_symbol def_symbol, 'def!' - static_symbol let_symbol, 'let*' - - static core_add_symbol, db "+" - static core_sub_symbol, db "-" - static core_mul_symbol, db "*" - static core_div_symbol, db "/" - -section .text - -;; Integer arithmetic operations -;; -;; Adds a list of numbers, address in RSI -;; Returns the sum as a number object with address in RAX -;; Since most of the code is common to all operators, -;; RBX is used to jump to the required instruction -core_add: - mov rbx, core_arithmetic.do_addition - jmp core_arithmetic -core_sub: - mov rbx, core_arithmetic.do_subtraction - jmp core_arithmetic -core_mul: - mov rbx, core_arithmetic.do_multiply - jmp core_arithmetic -core_div: - mov rbx, core_arithmetic.do_division - ; Fall through to core_arithmetic -core_arithmetic: - ; Check that the first object is a number - mov cl, BYTE [rsi] - mov ch, cl - and ch, block_mask - cmp ch, block_cons - jne .missing_args - - mov ch, cl - and ch, content_mask - cmp ch, content_empty - je .missing_args - - cmp ch, content_int - jne .not_int - - ; Put the starting value in rax - mov rax, [rsi + Cons.car] - -.add_loop: - ; Fetch the next value - mov cl, [rsi + Cons.typecdr] - cmp cl, content_pointer - jne .finished ; Nothing let - - mov rsi, [rsi + Cons.cdr] ; Get next cons - - ; Check that it is an integer - mov cl, BYTE [rsi] - and cl, content_mask - cmp cl, content_int - jne .not_int - - ; Jump to the required operation, address in RBX - jmp rbx - -.do_addition: - add rax, [rsi + Cons.car] - jmp .add_loop -.do_subtraction: - sub rax, [rsi + Cons.car] - jmp .add_loop -.do_multiply: - imul rax, [rsi + Cons.car] - jmp .add_loop -.do_division: - cqo ; Sign extend RAX into RDX - mov rcx, [rsi + Cons.car] - idiv rcx - jmp .add_loop - -.finished: - ; Value in rbx - push rax - ; Get a Cons object to put the result into - call alloc_cons - pop rbx - mov [rax], BYTE maltype_integer - mov [rax + Cons.car], rbx - ret - -.missing_args: -.not_int: - jmp quit - -;; Add a native function to the core environment -;; This is used in core_environment -%macro core_env_native 2 - push rsi ; environment - mov rsi, %1 - mov edx, %1.len - call raw_to_symbol ; Symbol in RAX - push rax - - mov rsi, %2 - call native_function ; Function in RAX - - mov rcx, rax ; value (function) - pop rdi ; key (symbol) - pop rsi ; environment - call env_set -%endmacro - - - -;; Takes a string as input and processes it into a form -read: - jmp read_str ; In reader.asm - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; RDI Environment -;; -eval_ast: - mov r15, rdi ; Save Env in r15 - - ; Check the type - mov al, BYTE [rsi] - - ; Check if this is a list - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list - - cmp ah, container_map - je .map - - cmp ah, container_vector - je .vector - - ; Not a list, map or vector - cmp ah, container_symbol - je .symbol - - ; Not a symbol, list, map or vector - call incref_object ; Increment reference count - - mov rax, rsi - ret - -.symbol: - ; look in environment - push rsi - xchg rsi, rdi - ; symbol is the key in rdi - ; Environment in rsi - call env_get - pop rsi - je .done ; result in RAX - - ; Not found, throw an error - push rsi - print_str_mac error_string ; print 'Error: ' - - pop rsi - push rsi - mov edx, [rsi + Array.length] - add rsi, Array.data - call print_rawstring ; print symbol - - print_str_mac not_found_string ; print ' not found' - pop rsi - - jmp error_throw - - ; ------------------------------ -.list: - ; Evaluate each element of the list - ; - xor r8, r8 ; The list to return - ; r9 contains head of list - -.list_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .list_pointer - - ; A value in RSI, so copy - - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_list) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .list_append - -.list_pointer: - ; List element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .list_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_list + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .list_append - -.list_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_list) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - - ; Fall through to .list_append -.list_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .list_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .list_next - -.list_first: - mov r8, rax - mov r9, rax - ; fall through to .list_next - -.list_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .list_done ; finished list - mov rsi, [rsi + Cons.cdr] ; next in list - jmp .list_loop - -.list_done: - mov rax, r8 ; Return the list - ret - - ; --------------------- -.map: - ; Create a new map, evaluating all the values - - ; Check if the map is empty - cmp al, maltype_empty_map - jne .map_not_empty - - ; map empty. Just return it - call incref_object - mov rax, rsi - ret - -.map_not_empty: - - mov r10, rsi ; input in R10 - xor r12, r12 ; New map in r12 - - ; Now loop through each key-value pair - ; NOTE: This method relies on the implementation - ; of map as a list - -.map_loop: - ; Copy the key - call alloc_cons ; New Cons in RAX - - mov bl, [r10 + Cons.typecar] ; Type in BL - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] ; Value in RCX - mov [rax + Cons.car], rcx - - ; Check the type of the key - and bl, content_mask - cmp bl, content_pointer - jne .map_got_key ; a value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.map_got_key: - cmp r12,0 - jne .append_key - - ; First key - mov r12, rax - mov r13, rax - jmp .map_value - -.append_key: - ; Appending to previous value in r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - -.map_value: - ; Check that we have a value - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_error_missing_value - mov r10, [r10 + Cons.cdr] - - ; Now got value in r10 - - ; Check the type of the value - mov bl, [r10 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .map_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r10 + Cons.typecar] - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .map_got_value -.map_value_pointer: - ; A pointer, so need to evaluate - push r10 ; Input - push r12 ; start of result - push r13 ; Current head of result - push r15 ; Env - mov rsi, [r10 + Cons.car] ; Get the address - mov rdi, r15 - call eval ; Evaluate it, result in rax - pop r15 - pop r13 - pop r12 - pop r10 - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - - jne .map_eval_pointer - - ; A value, so just change the type to a map - and bl, content_mask - add bl, (block_cons + container_map) - mov [rax], BYTE bl - jmp .map_got_value - -.map_eval_pointer: - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - -.map_got_value: - ; Append RAX to list in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - - ; Check if there's another key - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_done ; finished map - mov r10, [r10 + Cons.cdr] ; next in map - jmp .map_loop - -.map_done: - mov rax, r12 - ret - -.map_error_missing_value: - mov rax, r12 - ret - - ; ------------------------------ -.vector: - ; Evaluate each element of the vector - ; - xor r8, r8 ; The vector to return - ; r9 contains head of vector - -.vector_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .vector_pointer - - ; A value, so copy - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_vector) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .vector_append - -.vector_pointer: - ; Vector element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .vector_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_vector + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .vector_append - -.vector_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_vector) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - -.vector_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .vector_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .vector_next - -.vector_first: - mov r8, rax - mov r9, rax - ; fall through to .vector_next - -.vector_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .vector_done ; finished vector - mov rsi, [rsi + Cons.cdr] ; next in vector - jmp .vector_loop - -.vector_done: - mov rax, r8 ; Return the vector - ret - - ; --------------------- -.done: - ret - - - -;; Comparison of symbols for eval function -;; Compares the symbol in RSI with specified symbol -;; Preserves RSI and RBX -;; Modifies RDI -%macro eval_cmp_symbol 1 - push rsi - push rbx - mov rsi, rbx - mov rdi, %1 - call compare_char_array - pop rbx - pop rsi - test rax, rax ; ZF set if rax = 0 (equal) -%endmacro - -;; ---------------------------------------------------- -;; Evaluates a form -;; -;; Input: RSI AST to evaluate -;; RDI Environment -;; -;; Returns: Result in RAX -;; -eval: - mov r15, rdi ; Env - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - and al, container_mask - cmp al, container_list - je .list - - ; Not a list. Evaluate and return - call eval_ast - ret - - ; -------------------- -.list: - ; A list - - ; Check if the first element is a symbol - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .list_eval - - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .list_eval - - ; Is a symbol, address in RBX - - ; Compare against special form symbols - - eval_cmp_symbol def_symbol ; def! - je .def_symbol - - eval_cmp_symbol let_symbol ; let* - je .let_symbol - - ; Unrecognised - jmp .list_eval - -.def_symbol: - ; Define a new symbol in current environment - - ; Next item should be a symbol - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Now should have a symbol - - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - jne .def_error_expecting_symbol - mov r8, [rsi + Cons.car] ; Symbol (?) - - mov al, BYTE [r8] - cmp al, maltype_symbol - jne .def_error_expecting_symbol - - ; R8 now contains a symbol - - ; expecting a value or pointer next - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a pointer - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .def_pointer - - ; A value, so copy - push rax - call alloc_cons - pop rbx ; BL now contains type - and bl, content_mask - add bl, (block_cons + container_value) - mov [rax], BYTE bl - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - mov rsi, rax - - jmp .def_got_value - -.def_pointer: - ; A pointer, so evaluate - - ; This may throw an error, so define a handler - - - push r8 ; the symbol - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Pointer - mov rdi, r15 - call eval - mov rsi, rax - pop r15 - pop r8 - -.def_got_value: - ; Symbol in R8, value in RSI - mov rdi, r8 ; key (symbol) - mov rcx, rsi ; Value - mov rsi, r15 ; Environment - call env_set - - mov rax, rcx ; Return the value - ret - -.def_error_missing_arg: - mov rsi, def_missing_arg_string - mov rdx, def_missing_arg_string.len - jmp .def_handle_error - -.def_error_expecting_symbol: - mov rsi, def_expecting_symbol_string - mov rdx, def_expecting_symbol_string.len - jmp .def_handle_error - -.def_handle_error: - push rsi - push rdx - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - xor rsi, rsi ; no object to throw - jmp error_throw ; No return - - ; ----------------------------- -.let_symbol: - ; Create a new environment - - mov r11, rsi ; Let form in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - mov r14, rax ; New environment in R14 - - ; Second element should be the bindings - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_bindings - mov r11, [r11 + Cons.cdr] - - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .let_error_bindings_list - - mov r12, [r11 + Cons.car] ; should be bindings list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - ; Can be either a list or vector - cmp al, block_cons + container_list - je .let_bind_loop - cmp al, block_cons + container_vector - je .let_bind_loop - - ; Not a list or vector - jmp .let_error_bindings_list - -.let_bind_loop: - ; R12 now contains a list with an even number of items - ; The first should be a symbol, then a value to evaluate - - ; Get the symbol - mov al, BYTE [r12] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_symbol - - mov r13, [r12 + Cons.car] ; Symbol (?) - mov al, BYTE [r13] - cmp al, maltype_symbol - jne .let_error_bind_symbol - - ; R13 now contains a symbol to bind - ; The next item in the bindings list (R12) - ; should be a value or expression to evaluate - - mov al, BYTE [r12 + Cons.typecdr] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_value - mov r12, [r12 + Cons.cdr] - - ; got value in R12 - - ; Check the type of the value - mov bl, [r12 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .let_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r12 + Cons.typecar] - and bl, content_mask - ;or bl, (block_cons + container_value) ; 0 - mov [rax + Cons.typecar], bl - mov rcx, [r12 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .let_got_value - -.let_value_pointer: - ; A pointer, so need to evaluate - push r11 ; let* form list - push r12 ; Position in bindings list - push r13 ; symbol to bind - push r14 ; new environment - mov rsi, [r12 + Cons.car] ; Get the address - mov rdi, r14 - call eval ; Evaluate it, result in rax - pop r14 - pop r13 - pop r12 - pop r11 - -.let_got_value: - - mov rsi, r14 ; Env - mov rdi, r13 ; key - mov rcx, rax ; value - call env_set - - ; Release the value - mov rsi, rcx ; The value - call release_object - - ; Check if there are more bindings - mov al, BYTE [r12 + Cons.typecdr] - cmp al, content_pointer - jne .let_done_binding - mov r12, [r12 + Cons.cdr] ; Next - jmp .let_bind_loop - -.let_done_binding: - ; Done bindings. - ; Evaluate next item in let* form in new environment - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_body - mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate - ; Check type of the value - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - je .body_pointer - - ; Just a value, so copy - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl ; set type - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx ; copy value - jmp .let_done - -.body_pointer: - ; Evaluate using new environment - - mov rsi, [r11 + Cons.car] ; Object pointed to - mov rdi, r14 ; New environment - push r14 - call eval - pop r14 - -.let_done: - ; Release the environment - mov rsi, r14 - push rax - call release_object - pop rax - ret - -.let_error_missing_bindings: - mov rsi, let_missing_bindings_string - mov rdx, let_missing_bindings_string.len - jmp .let_handle_error - -.let_error_bindings_list: ; expected a list or vector, got something else - mov rsi, let_bindings_list_string - mov rdx, let_bindings_list_string.len - jmp .let_handle_error - -.let_error_bind_symbol: ; expected a symbol, got something else - mov rsi, let_bind_symbol_string - mov rdx, let_bind_symbol_string.len - jmp .let_handle_error - -.let_error_bind_value: ; Missing value in binding list - mov rsi, let_bind_value_string - mov rdx, let_bind_value_string.len - jmp .let_handle_error - -.let_error_missing_body: ; Missing body to evaluate - mov rsi, let_missing_body_string - mov rdx, let_missing_body_string.len - jmp .let_handle_error - -.let_handle_error: - push r11 ; For printing later - - push rsi - push rdx - - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - pop rsi ; let* form - jmp error_throw ; No return - - ; ----------------------------- - -.list_eval: - push rsi - mov rdi, r15 ; Environment - push r15 - call eval_ast ; List of evaluated forms in RAX - pop r15 - pop rsi - - ; Check that the first element of the return is a function - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .list_not_function - - mov rbx, [rax + Cons.car] ; Get the address - mov cl, BYTE [rbx] - cmp cl, maltype_function - jne .list_not_function - - ; Call the function with the rest of the list in RSI - push rax - push r15 - mov rsi, [rax + Cons.cdr] ; Rest of list - mov rdi, rbx ; Function object in RDI - call [rbx + Cons.car] ; Call function - ; Result in rax - pop r15 - pop rsi ; eval'ed list - push rax - call release_cons - pop rax - ret - -.list_not_function: - ; Not a function. Probably an error - ret - -.empty_list: - mov rax, rsi - ret - -;; Prints the result -print: - mov rdi, 1 ; print readably - jmp pr_str - -;; Read-Eval-Print in sequence -rep_seq: - ; ------------- - ; Read - call read - push rax ; Save form - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - call eval - push rax ; Save result - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - call print ; String in RAX - - mov r8, rax ; Save output - - pop rsi ; Result from eval - call release_object - pop rsi ; Form returned by read - call release_object - mov rax, r8 - - ret - - -_start: - ; Create and print the core environment - call env_new ; Environment in RAX - - mov [repl_env], rax ; store in memory - - mov rsi, rax ; Environment - - ; Add +,-,*,/ to environment - core_env_native core_add_symbol, core_add - core_env_native core_sub_symbol, core_sub - core_env_native core_mul_symbol, core_mul - core_env_native core_div_symbol, core_div - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - -.catch: - ; Jumps here on error - - ; Check if an object was thrown - cmp rsi, 0 - je .catch_done_print ; nothing to print - mov rdi, 1 - call pr_str - mov rsi, rax - call print_string -.catch_done_print: - jmp .mainLoop ; Go back to the prompt - +;; +;; nasm -felf64 step3_env.asm && ld step3_env.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + + static core_add_symbol, db "+" + static core_sub_symbol, db "-" + static core_mul_symbol, db "*" + static core_div_symbol, db "/" + +section .text + +;; Integer arithmetic operations +;; +;; Adds a list of numbers, address in RSI +;; Returns the sum as a number object with address in RAX +;; Since most of the code is common to all operators, +;; RBX is used to jump to the required instruction +core_add: + mov rbx, core_arithmetic.do_addition + jmp core_arithmetic +core_sub: + mov rbx, core_arithmetic.do_subtraction + jmp core_arithmetic +core_mul: + mov rbx, core_arithmetic.do_multiply + jmp core_arithmetic +core_div: + mov rbx, core_arithmetic.do_division + ; Fall through to core_arithmetic +core_arithmetic: + ; Check that the first object is a number + mov cl, BYTE [rsi] + mov ch, cl + and ch, block_mask + cmp ch, block_cons + jne .missing_args + + mov ch, cl + and ch, content_mask + cmp ch, content_empty + je .missing_args + + cmp ch, content_int + jne .not_int + + ; Put the starting value in rax + mov rax, [rsi + Cons.car] + +.add_loop: + ; Fetch the next value + mov cl, [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .finished ; Nothing let + + mov rsi, [rsi + Cons.cdr] ; Get next cons + + ; Check that it is an integer + mov cl, BYTE [rsi] + and cl, content_mask + cmp cl, content_int + jne .not_int + + ; Jump to the required operation, address in RBX + jmp rbx + +.do_addition: + add rax, [rsi + Cons.car] + jmp .add_loop +.do_subtraction: + sub rax, [rsi + Cons.car] + jmp .add_loop +.do_multiply: + imul rax, [rsi + Cons.car] + jmp .add_loop +.do_division: + cqo ; Sign extend RAX into RDX + mov rcx, [rsi + Cons.car] + idiv rcx + jmp .add_loop + +.finished: + ; Value in rbx + push rax + ; Get a Cons object to put the result into + call alloc_cons + pop rbx + mov [rax], BYTE maltype_integer + mov [rax + Cons.car], rbx + ret + +.missing_args: +.not_int: + jmp quit + +;; Add a native function to the core environment +;; This is used in core_environment +%macro core_env_native 2 + push rsi ; environment + mov rsi, %1 + mov edx, %1.len + call raw_to_symbol ; Symbol in RAX + push rax + + mov rsi, %2 + call native_function ; Function in RAX + + mov rcx, rax ; value (function) + pop rdi ; key (symbol) + pop rsi ; environment + call env_set +%endmacro + + + +;; Takes a string as input and processes it into a form +read: + jmp read_str ; In reader.asm + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate +;; RDI Environment +;; +;; Returns: Result in RAX +;; +eval: + mov r15, rdi ; Env + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + ret + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + ; Unrecognised + jmp .list_eval + +.def_symbol: + ; Define a new symbol in current environment + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + + push r8 ; the symbol + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + call eval + mov rsi, rax + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx ; Return the value + ret + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + mov rsi, [r12 + Cons.car] ; Get the address + mov rdi, r14 + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + mov rdi, r14 ; New environment + push r14 + call eval + pop r14 + +.let_done: + ; Release the environment + mov rsi, r14 + push rax + call release_object + pop rax + ret + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Call the function with the rest of the list in RSI + push rax + push r15 + mov rsi, [rax + Cons.cdr] ; Rest of list + mov rdi, rbx ; Function object in RDI + call [rbx + Cons.car] ; Call function + ; Result in rax + pop r15 + pop rsi ; eval'ed list + push rax + call release_cons + pop rax + ret + +.list_not_function: + ; Not a function. Probably an error + ret + +.empty_list: + mov rax, rsi + ret + +;; Prints the result +print: + mov rdi, 1 ; print readably + jmp pr_str + +;; Read-Eval-Print in sequence +rep_seq: + ; ------------- + ; Read + call read + push rax ; Save form + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + call eval + push rax ; Save result + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + call print ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + pop rsi ; Form returned by read + call release_object + mov rax, r8 + + ret + + +_start: + ; Create and print the core environment + call env_new ; Environment in RAX + + mov [repl_env], rax ; store in memory + + mov rsi, rax ; Environment + + ; Add +,-,*,/ to environment + core_env_native core_add_symbol, core_add + core_env_native core_sub_symbol, core_sub + core_env_native core_mul_symbol, core_mul + core_env_native core_div_symbol, core_div + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + diff --git a/impls/nasm/step4_if_fn_do.asm b/impls/nasm/step4_if_fn_do.asm index 46507d7096..b2c60d6add 100644 --- a/impls/nasm/step4_if_fn_do.asm +++ b/impls/nasm/step4_if_fn_do.asm @@ -1,1382 +1,1382 @@ -;; -;; nasm -felf64 step4_if_fn_do.asm && ld step4_if_fn_do.o && ./a.out -;; -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "env.asm" ; Environment type -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "core.asm" ; Core functions -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .bss - -;; Top-level (REPL) environment -repl_env:resq 1 - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - - static error_string, db 27,'[31m',"Error",27,'[0m',": " - - static not_found_string, db " not found" - - static def_missing_arg_string, db "missing argument to def!",10 - - static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 - - static let_missing_bindings_string, db "let* missing bindings",10 - - static let_bindings_list_string, db "let* expected a list or vector of bindings",10 - - static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 - - static let_bind_value_string, db "let* missing value in bindings list",10 - - static let_missing_body_string, db "let* missing body",10 - static eval_list_not_function, db "list does not begin with a function",10 - - -;; Symbols used for comparison - - static_symbol def_symbol, 'def!' - static_symbol let_symbol, 'let*' - static_symbol do_symbol, 'do' - static_symbol if_symbol, 'if' - static_symbol fn_symbol, 'fn*' - -;; Startup string. This is evaluated on startup - static mal_startup_string, db "(def! not (fn* (a) (if a false true)))" - - -section .text - - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; RDI Environment -;; -eval_ast: - mov r15, rdi ; Save Env in r15 - - ; Check the type - mov al, BYTE [rsi] - - ; Check if this is a list - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list - - cmp ah, container_map - je .map - - cmp ah, container_vector - je .vector - - ; Not a list, map or vector - cmp ah, container_symbol - je .symbol - - ; Not a symbol, list, map or vector - call incref_object ; Increment reference count - - mov rax, rsi - ret - -.symbol: - ; Check if first character of symbol is ':' - mov al, BYTE [rsi + Array.data] - cmp al, ':' - je .keyword - - ; look in environment - push rsi - xchg rsi, rdi - ; symbol is the key in rdi - ; Environment in rsi - call env_get - pop rsi - je .done ; result in RAX - - ; Not found, throw an error - push rsi - print_str_mac error_string ; print 'Error: ' - - pop rsi - push rsi - mov edx, [rsi + Array.length] - add rsi, Array.data - call print_rawstring ; print symbol - - print_str_mac not_found_string ; print ' not found' - pop rsi - - jmp error_throw - - ; ------------------------------ - -.keyword: - ; Just return keywords unaltered - call incref_object - mov rax, rsi - ret - - ; ------------------------------ -.list: - ; Evaluate each element of the list - ; - xor r8, r8 ; The list to return - ; r9 contains head of list - -.list_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .list_pointer - - ; A value in RSI, so copy - - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_list) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .list_append - -.list_pointer: - ; List element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .list_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_list + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .list_append - -.list_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_list) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - - ; Fall through to .list_append -.list_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .list_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .list_next - -.list_first: - mov r8, rax - mov r9, rax - ; fall through to .list_next - -.list_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .list_done ; finished list - mov rsi, [rsi + Cons.cdr] ; next in list - jmp .list_loop - -.list_done: - mov rax, r8 ; Return the list - ret - - ; --------------------- -.map: - ; Create a new map, evaluating all the values - - ; Check if the map is empty - cmp al, maltype_empty_map - jne .map_not_empty - - ; map empty. Just return it - call incref_object - mov rax, rsi - ret - -.map_not_empty: - - mov r10, rsi ; input in R10 - xor r12, r12 ; New map in r12 - - ; Now loop through each key-value pair - ; NOTE: This method relies on the implementation - ; of map as a list - -.map_loop: - ; Copy the key - call alloc_cons ; New Cons in RAX - - mov bl, [r10 + Cons.typecar] ; Type in BL - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] ; Value in RCX - mov [rax + Cons.car], rcx - - ; Check the type of the key - and bl, content_mask - cmp bl, content_pointer - jne .map_got_key ; a value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.map_got_key: - cmp r12,0 - jne .append_key - - ; First key - mov r12, rax - mov r13, rax - jmp .map_value - -.append_key: - ; Appending to previous value in r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - -.map_value: - ; Check that we have a value - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_error_missing_value - mov r10, [r10 + Cons.cdr] - - ; Now got value in r10 - - ; Check the type of the value - mov bl, [r10 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .map_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r10 + Cons.typecar] - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .map_got_value -.map_value_pointer: - ; A pointer, so need to evaluate - push r10 ; Input - push r12 ; start of result - push r13 ; Current head of result - push r15 ; Env - mov rsi, [r10 + Cons.car] ; Get the address - mov rdi, r15 - call eval ; Evaluate it, result in rax - pop r15 - pop r13 - pop r12 - pop r10 - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - - jne .map_eval_pointer - - ; A value, so just change the type to a map - and bl, content_mask - add bl, (block_cons + container_map) - mov [rax], BYTE bl - jmp .map_got_value - -.map_eval_pointer: - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - -.map_got_value: - ; Append RAX to list in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - - ; Check if there's another key - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_done ; finished map - mov r10, [r10 + Cons.cdr] ; next in map - jmp .map_loop - -.map_done: - mov rax, r12 - ret - -.map_error_missing_value: - mov rax, r12 - ret - - ; ------------------------------ -.vector: - ; Evaluate each element of the vector - ; - xor r8, r8 ; The vector to return - ; r9 contains head of vector - -.vector_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .vector_pointer - - ; A value, so copy - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_vector) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .vector_append - -.vector_pointer: - ; Vector element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .vector_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_vector + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .vector_append - -.vector_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_vector) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - -.vector_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .vector_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .vector_next - -.vector_first: - mov r8, rax - mov r9, rax - ; fall through to .vector_next - -.vector_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .vector_done ; finished vector - mov rsi, [rsi + Cons.cdr] ; next in vector - jmp .vector_loop - -.vector_done: - mov rax, r8 ; Return the vector - ret - - ; --------------------- -.done: - ret - - - -;; Comparison of symbols for eval function -;; Compares the symbol in RSI with specified symbol -;; Preserves RSI and RBX -;; Modifies RDI -%macro eval_cmp_symbol 1 - push rsi - push rbx - mov rsi, rbx - mov rdi, %1 - call compare_char_array - pop rbx - pop rsi - test rax, rax ; ZF set if rax = 0 (equal) -%endmacro - -;; ---------------------------------------------------- -;; Evaluates a form -;; -;; Input: RSI AST to evaluate -;; RDI Environment -;; -;; Returns: Result in RAX -;; -eval: - mov r15, rdi ; Env - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - and al, container_mask - cmp al, container_list - je .list - - ; Not a list. Evaluate and return - call eval_ast - ret - - ; -------------------- -.list: - ; A list - - ; Check if the first element is a symbol - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .list_eval - - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .list_eval - - ; Is a symbol, address in RBX - - ; Compare against special form symbols - - eval_cmp_symbol def_symbol ; def! - je .def_symbol - - eval_cmp_symbol let_symbol ; let* - je .let_symbol - - eval_cmp_symbol do_symbol ; do - je .do_symbol - - eval_cmp_symbol if_symbol ; if - je .if_symbol - - eval_cmp_symbol fn_symbol ; fn - je .fn_symbol - - ; Unrecognised - jmp .list_eval - - - ; ----------------------------- - -.def_symbol: - ; Define a new symbol in current environment - - ; Next item should be a symbol - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Now should have a symbol - - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - jne .def_error_expecting_symbol - mov r8, [rsi + Cons.car] ; Symbol (?) - - mov al, BYTE [r8] - cmp al, maltype_symbol - jne .def_error_expecting_symbol - - ; R8 now contains a symbol - - ; expecting a value or pointer next - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a pointer - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .def_pointer - - ; A value, so copy - push rax - call alloc_cons - pop rbx ; BL now contains type - and bl, content_mask - add bl, (block_cons + container_value) - mov [rax], BYTE bl - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - mov rsi, rax - - jmp .def_got_value - -.def_pointer: - ; A pointer, so evaluate - - ; This may throw an error, so define a handler - - push r8 ; the symbol - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Pointer - mov rdi, r15 - call eval - mov rsi, rax - - pop r15 - pop r8 - -.def_got_value: - ; Symbol in R8, value in RSI - mov rdi, r8 ; key (symbol) - mov rcx, rsi ; Value - mov rsi, r15 ; Environment - call env_set - - mov rax, rcx ; Return the value - ret - -.def_error_missing_arg: - mov rsi, def_missing_arg_string - mov rdx, def_missing_arg_string.len - jmp .def_handle_error - -.def_error_expecting_symbol: - mov rsi, def_expecting_symbol_string - mov rdx, def_expecting_symbol_string.len - jmp .def_handle_error - -.def_handle_error: - push rsi - push rdx - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - xor rsi, rsi ; no object to throw - jmp error_throw ; No return - - ; ----------------------------- -.let_symbol: - ; Create a new environment - - mov r11, rsi ; Let form in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - mov r14, rax ; New environment in R14 - - ; Second element should be the bindings - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_bindings - mov r11, [r11 + Cons.cdr] - - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .let_error_bindings_list - - mov r12, [r11 + Cons.car] ; should be bindings list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - ; Can be either a list or vector - cmp al, block_cons + container_list - je .let_bind_loop - cmp al, block_cons + container_vector - je .let_bind_loop - - ; Not a list or vector - jmp .let_error_bindings_list - -.let_bind_loop: - ; R12 now contains a list with an even number of items - ; The first should be a symbol, then a value to evaluate - - ; Get the symbol - mov al, BYTE [r12] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_symbol - - mov r13, [r12 + Cons.car] ; Symbol (?) - mov al, BYTE [r13] - cmp al, maltype_symbol - jne .let_error_bind_symbol - - ; R13 now contains a symbol to bind - ; The next item in the bindings list (R12) - ; should be a value or expression to evaluate - - mov al, BYTE [r12 + Cons.typecdr] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_value - mov r12, [r12 + Cons.cdr] - - ; got value in R12 - - ; Check the type of the value - mov bl, [r12 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .let_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r12 + Cons.typecar] - and bl, content_mask - ;or bl, (block_cons + container_value) ; 0 - mov [rax + Cons.typecar], bl - mov rcx, [r12 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .let_got_value - -.let_value_pointer: - ; A pointer, so need to evaluate - push r11 ; let* form list - push r12 ; Position in bindings list - push r13 ; symbol to bind - push r14 ; new environment - mov rsi, [r12 + Cons.car] ; Get the address - mov rdi, r14 - call eval ; Evaluate it, result in rax - pop r14 - pop r13 - pop r12 - pop r11 - -.let_got_value: - - mov rsi, r14 ; Env - mov rdi, r13 ; key - mov rcx, rax ; value - call env_set - - ; Release the value - mov rsi, rcx ; The value - call release_object - - ; Check if there are more bindings - mov al, BYTE [r12 + Cons.typecdr] - cmp al, content_pointer - jne .let_done_binding - mov r12, [r12 + Cons.cdr] ; Next - jmp .let_bind_loop - -.let_done_binding: - ; Done bindings. - ; Evaluate next item in let* form in new environment - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_body - mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate - ; Check type of the value - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - je .body_pointer - - ; Just a value, so copy - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl ; set type - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx ; copy value - jmp .let_done - -.body_pointer: - ; Evaluate using new environment - - mov rsi, [r11 + Cons.car] ; Object pointed to - mov rdi, r14 ; New environment - push r14 - call eval - pop r14 - -.let_done: - ; Release the environment - mov rsi, r14 - push rax - call release_object - pop rax - ret - -.let_error_missing_bindings: - mov rsi, let_missing_bindings_string - mov rdx, let_missing_bindings_string.len - jmp .let_handle_error - -.let_error_bindings_list: ; expected a list or vector, got something else - mov rsi, let_bindings_list_string - mov rdx, let_bindings_list_string.len - jmp .let_handle_error - -.let_error_bind_symbol: ; expected a symbol, got something else - mov rsi, let_bind_symbol_string - mov rdx, let_bind_symbol_string.len - jmp .let_handle_error - -.let_error_bind_value: ; Missing value in binding list - mov rsi, let_bind_value_string - mov rdx, let_bind_value_string.len - jmp .let_handle_error - -.let_error_missing_body: ; Missing body to evaluate - mov rsi, let_missing_body_string - mov rdx, let_missing_body_string.len - jmp .let_handle_error - -.let_handle_error: - push r11 ; For printing later - - push rsi - push rdx - - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - pop rsi ; let* form - jmp error_throw ; No return - - ; ----------------------------- - -.do_symbol: - mov r11, rsi ; do form in RSI - ; Environment in R15 - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .do_no_body - mov r11, [r11 + Cons.cdr] - -.do_symbol_loop: - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_body_value - - ; A pointer, so evaluate - push r15 - push r11 - mov rsi, [r11 + Cons.car] ; Form - mov rdi, r15 ; Env - call eval ; Result in RAX - pop r11 - pop r15 - - ; Check if there is another form - mov bl, BYTE [r11 + Cons.typecdr] - cmp bl, content_pointer - jne .do_done ; No more, so finished - - ; Another form. Discard the result of the last eval - mov rsi, rax - call release_object -.do_next: - mov r11, [r11 + Cons.cdr] ; Next in list - - jmp .do_symbol_loop - -.do_done: - ret ; Return result in RAX - -.do_body_value: - - ; Got a value in R11. - ; If this is the last form then return, - ; but if not then can ignore - - mov bl, BYTE [r11 + Cons.typecdr] - and bl, block_mask + content_mask - cmp bl, content_pointer - jne .do_body_value_return - - ; Not the last, so ignore - jmp .do_next - -.do_body_value_return: - ; Got a value as last form. Copy and return - - push rax - call alloc_cons - pop rbx ; type in BL - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - ret - -.do_no_body: - ; No expressions to evaluate. Return nil - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - ; ----------------------------- - -.if_symbol: - mov r11, rsi ; if form in R11 - ; Environment in R15 - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .if_no_condition - - mov r11, [r11 + Cons.cdr] ; Should be a condition - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .if_cond_value - - ; A pointer, so evaluate - - push r15 - push r11 - mov rsi, [r11 + Cons.car] ; Form - mov rdi, r15 ; Env - call eval ; Result in RAX - pop r11 - pop r15 - - ; Get type of result - mov bl, BYTE [rax] - - ; release value - push rbx - mov rsi, rax - call release_object - pop rbx - - ; Check type - cmp bl, maltype_nil - je .if_false - cmp bl, maltype_false - je .if_false - - jmp .if_true - -.if_cond_value: - - ; A value - cmp al, content_nil - je .if_false - cmp al, content_false - je .if_false - - jmp .if_true - -.if_false: - ; Skip the next item - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil - - mov r11, [r11 + Cons.cdr] - -.if_true: - ; Get the next item in the list and evaluate it - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; Nothing to return - - mov r11, [r11 + Cons.cdr] - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - je .if_got_pointer - -.if_got_value: - ; copy value in r11 - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - ret - -.if_got_pointer: - mov rsi, [r11 + Cons.car] ; Form - mov rdi, r15 ; Env - call eval - ret - -.if_no_condition: ; just (if) without a condition - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - ; ----------------------------- - -.fn_symbol: - mov r11, rsi ; fn form in R11 - ; Environment in R15 - - ; Get the binds and body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_empty - - mov r11, [r11 + Cons.cdr] - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_binds_not_list - - mov r12, [r11 + Cons.car] ; Should be binds list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - cmp al, (block_cons + container_list) - je .fn_got_binds ; Can be list - cmp al, (block_cons + container_vector) - je .fn_got_binds ; or vector - jmp .fn_binds_not_list - -.fn_got_binds: - - ; Next get the body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_no_body - - mov r11, [r11 + Cons.cdr] - ; Check value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_is_value ; Body in r11 - mov r11, [r11 + Cons.car] - jmp .fn_got_body - -.fn_is_value: - ; Body is just a value, no expression - mov [r11], BYTE al ; Mark as value, not list - -.fn_got_body: - - ; Now put into function type - ; Addr is "apply_fn", the address to call - ; Env in R15 - ; Binds in R12 - ; Body in R11 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_function) - mov rbx, apply_fn - mov [rax + Cons.car], rbx ; Address of apply function - mov [rax + Cons.typecdr], BYTE content_pointer - - mov r13, rax ; Return list in R13 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r15 ; Environment - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r13 + Cons.cdr], rax ; Append to list - mov r14, rax - - push rax - mov rsi, r15 - call incref_object - pop rax - - ; Binds - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r12 ; Binds list - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r14 + Cons.cdr], rax ; Append to list - mov r14, rax - - push rax - mov rsi, r12 - call incref_object - pop rax - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r11 ; Body of function - - mov [r14 + Cons.cdr], rax - - mov rsi, r11 - call incref_object - - mov rax, r13 - ret - -.fn_empty: -.fn_binds_not_list: -.fn_no_body: - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - - ; ----------------------------- - -.list_eval: - push rsi - mov rdi, r15 ; Environment - push r15 - call eval_ast ; List of evaluated forms in RAX - pop r15 - pop rsi - - ; Check that the first element of the return is a function - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .list_not_function - - mov rbx, [rax + Cons.car] ; Get the address - mov cl, BYTE [rbx] - cmp cl, maltype_function - jne .list_not_function - - ; Check the rest of the args - mov cl, BYTE [rax + Cons.typecdr] - cmp cl, content_pointer - je .list_got_args - - ; No arguments - push rbx - call alloc_cons - mov [rax], BYTE maltype_empty_list - pop rbx - mov rsi, rax - jmp .list_function_call -.list_got_args: - mov rsi, [rax + Cons.cdr] ; Rest of list -.list_function_call: - ; Call the function with the rest of the list in RSI - push rax - push r15 - mov rdi, rbx ; Function object in RDI - call [rbx + Cons.car] ; Call function - ; Result in rax - pop r15 - pop rsi ; eval'ed list - push rax - call release_cons - pop rax - ret - -.list_not_function: - ; Not a function. Probably an error - push rsi - - mov rsi, rax - call release_object - - print_str_mac error_string - print_str_mac eval_list_not_function - pop rsi - jmp error_throw - -.empty_list: - mov rax, rsi - ret - - -;; Applies a user-defined function -;; -;; Input: RSI - Arguments to bind -;; RDI - Function object -;; -;; -;; Output: Result in RAX -;; -apply_fn: - push rsi - ; Extract values from the list in RDI - mov rax, [rdi + Cons.cdr] - mov rsi, [rax + Cons.car] ; Env - mov rax, [rax + Cons.cdr] - mov rdi, [rax + Cons.car] ; Binds - mov rax, [rax + Cons.cdr] - mov rax, [rax + Cons.car] ; Body - pop rcx ; Exprs - - ; Check the type of the body - mov bl, BYTE [rax] - and bl, block_mask + container_mask - jnz .bind - ; Just a value (in RAX). No eval needed - - push rax - mov rsi, rax - call incref_object - pop rax - ret -.bind: - ; Create a new environment, binding arguments - push rax - call env_new_bind - mov rdi, rax ; New environment in RDI - pop rsi ; Body - - ; Evaluate the function body - push rdi ; Environment - call eval - pop rsi - - ; Release the environment - push rax - call release_object - pop rax - - ret - - -;; Read-Eval-Print in sequence -;; -;; Input string in RSI -rep_seq: - ; ------------- - ; Read - call read_str - push rax ; Save form - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - call eval - push rax ; Save result - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - mov rdi, 1 ; print readably - call pr_str ; String in RAX - - mov r8, rax ; Save output - - pop rsi ; Result from eval - call release_object - pop rsi ; Form returned by read - call release_object - mov rax, r8 - - ret - - -_start: - ; Create and print the core environment - call core_environment ; Environment in RAX - - mov [repl_env], rax ; store in memory - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; Evaluate the startup string - - mov rsi, mal_startup_string - mov edx, mal_startup_string.len - call raw_to_string ; String in RAX - - push rax - mov rsi, rax - call read_str ; AST in RAX - pop rsi ; string - - push rax ; AST - call release_array ; string - pop rsi ; AST - - push rsi - mov rdi, [repl_env] ; Environment - call eval - pop rsi - - push rax - call release_object ; AST - pop rsi - call release_object ; Return from eval - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - -.catch: - ; Jumps here on error - - ; Check if an object was thrown - cmp rsi, 0 - je .catch_done_print ; nothing to print - mov rdi, 1 - call pr_str - mov rsi, rax - call print_string -.catch_done_print: - jmp .mainLoop ; Go back to the prompt - +;; +;; nasm -felf64 step4_if_fn_do.asm && ld step4_if_fn_do.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(def! not (fn* (a) (if a false true)))" + + +section .text + + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate +;; RDI Environment +;; +;; Returns: Result in RAX +;; +eval: + mov r15, rdi ; Env + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + ret + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.def_symbol: + ; Define a new symbol in current environment + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + call eval + mov rsi, rax + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx ; Return the value + ret + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + mov rsi, [r12 + Cons.car] ; Get the address + mov rdi, r14 + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + mov rdi, r14 ; New environment + push r14 + call eval + pop r14 + +.let_done: + ; Release the environment + mov rsi, r14 + push rax + call release_object + pop rax + ret + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body + mov r11, [r11 + Cons.cdr] + +.do_symbol_loop: + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value + + ; A pointer, so evaluate + push r15 + push r11 + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Check if there is another form + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_done ; No more, so finished + + ; Another form. Discard the result of the last eval + mov rsi, rax + call release_object +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_done: + ret ; Return result in RAX + +.do_body_value: + + ; Got a value in R11. + ; If this is the last form then return, + ; but if not then can ignore + + mov bl, BYTE [r11 + Cons.typecdr] + and bl, block_mask + content_mask + cmp bl, content_pointer + jne .do_body_value_return + + ; Not the last, so ignore + jmp .do_next + +.do_body_value_return: + ; Got a value as last form. Copy and return + + push rax + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + ret + +.do_no_body: + ; No expressions to evaluate. Return nil + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + ret + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + mov rdi, r15 ; Env + call eval + ret + +.if_no_condition: ; just (if) without a condition + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r15 + call incref_object + pop rax + + ; Binds + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + ret + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx + call alloc_cons + mov [rax], BYTE maltype_empty_list + pop rbx + mov rsi, rax + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + push rax + push r15 + mov rdi, rbx ; Function object in RDI + call [rbx + Cons.car] ; Call function + ; Result in rax + pop r15 + pop rsi ; eval'ed list + push rax + call release_cons + pop rax + ret + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + +.empty_list: + mov rax, rsi + ret + + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; +;; +;; Output: Result in RAX +;; +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + push rax + mov rsi, rax + call incref_object + pop rax + ret +.bind: + ; Create a new environment, binding arguments + push rax + call env_new_bind + mov rdi, rax ; New environment in RDI + pop rsi ; Body + + ; Evaluate the function body + push rdi ; Environment + call eval + pop rsi + + ; Release the environment + push rax + call release_object + pop rax + + ret + + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + push rax ; Save form + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + call eval + push rax ; Save result + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + pop rsi ; Form returned by read + call release_object + mov rax, r8 + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rsi ; AST + + push rsi + mov rdi, [repl_env] ; Environment + call eval + pop rsi + + push rax + call release_object ; AST + pop rsi + call release_object ; Return from eval + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + diff --git a/impls/nasm/step5_tco.asm b/impls/nasm/step5_tco.asm index 5162c83b38..fc83244e42 100644 --- a/impls/nasm/step5_tco.asm +++ b/impls/nasm/step5_tco.asm @@ -1,1587 +1,1587 @@ -;; -;; nasm -felf64 step5_tco.asm && ld step5_tco.o && ./a.out -;; -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "env.asm" ; Environment type -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "core.asm" ; Core functions -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .bss - -;; Top-level (REPL) environment -repl_env:resq 1 - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - - static error_string, db 27,'[31m',"Error",27,'[0m',": " - - static not_found_string, db " not found" - - static def_missing_arg_string, db "missing argument to def!",10 - - static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 - - static let_missing_bindings_string, db "let* missing bindings",10 - - static let_bindings_list_string, db "let* expected a list or vector of bindings",10 - - static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 - - static let_bind_value_string, db "let* missing value in bindings list",10 - - static let_missing_body_string, db "let* missing body",10 - static eval_list_not_function, db "list does not begin with a function",10 - - static if_missing_condition_string, db "missing condition in if expression",10 - -;; Symbols used for comparison - - static_symbol def_symbol, 'def!' - static_symbol let_symbol, 'let*' - static_symbol do_symbol, 'do' - static_symbol if_symbol, 'if' - static_symbol fn_symbol, 'fn*' - -;; Startup string. This is evaluated on startup - static mal_startup_string, db "(def! not (fn* (a) (if a false true)))" - - -section .text - - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; RDI Environment -;; -eval_ast: - mov r15, rdi ; Save Env in r15 - - ; Check the type - mov al, BYTE [rsi] - - ; Check if this is a list - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list - - cmp ah, container_map - je .map - - cmp ah, container_vector - je .vector - - ; Not a list, map or vector - cmp ah, container_symbol - je .symbol - - ; Not a symbol, list, map or vector - call incref_object ; Increment reference count - - mov rax, rsi - ret - -.symbol: - ; Check if first character of symbol is ':' - mov al, BYTE [rsi + Array.data] - cmp al, ':' - je .keyword - - ; look in environment - push rsi - xchg rsi, rdi - ; symbol is the key in rdi - ; Environment in rsi - call env_get - pop rsi - je .done ; result in RAX - - ; Not found, throw an error - push rsi - print_str_mac error_string ; print 'Error: ' - - pop rsi - push rsi - mov edx, [rsi + Array.length] - add rsi, Array.data - call print_rawstring ; print symbol - - print_str_mac not_found_string ; print ' not found' - pop rsi - - jmp error_throw - - ; ------------------------------ - -.keyword: - ; Just return keywords unaltered - call incref_object - mov rax, rsi - ret - - ; ------------------------------ -.list: - ; Evaluate each element of the list - ; - xor r8, r8 ; The list to return - ; r9 contains head of list - -.list_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .list_pointer - - ; A value in RSI, so copy - - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_list) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .list_append - -.list_pointer: - ; List element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rdi, [rsi + Cons.car] ; Get the address - mov rsi, r15 - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call incref_object ; AST increment refs - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .list_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_list + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .list_append - -.list_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_list) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - - ; Fall through to .list_append -.list_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .list_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .list_next - -.list_first: - mov r8, rax - mov r9, rax - ; fall through to .list_next - -.list_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .list_done ; finished list - mov rsi, [rsi + Cons.cdr] ; next in list - jmp .list_loop - -.list_done: - mov rax, r8 ; Return the list - ret - - ; --------------------- -.map: - ; Create a new map, evaluating all the values - - ; Check if the map is empty - cmp al, maltype_empty_map - jne .map_not_empty - - ; map empty. Just return it - call incref_object - mov rax, rsi - ret - -.map_not_empty: - - mov r10, rsi ; input in R10 - xor r12, r12 ; New map in r12 - - ; Now loop through each key-value pair - ; NOTE: This method relies on the implementation - ; of map as a list - -.map_loop: - ; Copy the key - call alloc_cons ; New Cons in RAX - - mov bl, [r10 + Cons.typecar] ; Type in BL - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] ; Value in RCX - mov [rax + Cons.car], rcx - - ; Check the type of the key - and bl, content_mask - cmp bl, content_pointer - jne .map_got_key ; a value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.map_got_key: - cmp r12,0 - jne .append_key - - ; First key - mov r12, rax - mov r13, rax - jmp .map_value - -.append_key: - ; Appending to previous value in r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - -.map_value: - ; Check that we have a value - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_error_missing_value - mov r10, [r10 + Cons.cdr] - - ; Now got value in r10 - - ; Check the type of the value - mov bl, [r10 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .map_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r10 + Cons.typecar] - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .map_got_value -.map_value_pointer: - ; A pointer, so need to evaluate - push r10 ; Input - push r12 ; start of result - push r13 ; Current head of result - push r15 ; Env - mov rsi, [r10 + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r13 - pop r12 - pop r10 - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - - jne .map_eval_pointer - - ; A value, so just change the type to a map - and bl, content_mask - add bl, (block_cons + container_map) - mov [rax], BYTE bl - jmp .map_got_value - -.map_eval_pointer: - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - -.map_got_value: - ; Append RAX to list in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - - ; Check if there's another key - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_done ; finished map - mov r10, [r10 + Cons.cdr] ; next in map - jmp .map_loop - -.map_done: - mov rax, r12 - ret - -.map_error_missing_value: - mov rax, r12 - ret - - ; ------------------------------ -.vector: - ; Evaluate each element of the vector - ; - xor r8, r8 ; The vector to return - ; r9 contains head of vector - -.vector_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .vector_pointer - - ; A value, so copy - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_vector) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .vector_append - -.vector_pointer: - ; Vector element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .vector_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_vector + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .vector_append - -.vector_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_vector) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - -.vector_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .vector_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .vector_next - -.vector_first: - mov r8, rax - mov r9, rax - ; fall through to .vector_next - -.vector_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .vector_done ; finished vector - mov rsi, [rsi + Cons.cdr] ; next in vector - jmp .vector_loop - -.vector_done: - mov rax, r8 ; Return the vector - ret - - ; --------------------- -.done: - ret - - - -;; Comparison of symbols for eval function -;; Compares the symbol in RSI with specified symbol -;; Preserves RSI and RBX -;; Modifies RDI -%macro eval_cmp_symbol 1 - push rsi - push rbx - mov rsi, rbx - mov rdi, %1 - call compare_char_array - pop rbx - pop rsi - test rax, rax ; ZF set if rax = 0 (equal) -%endmacro - -;; ---------------------------------------------------- -;; Evaluates a form -;; -;; Input: RSI AST to evaluate [ Released ] -;; RDI Environment [ Released ] -;; -;; Returns: Result in RAX -;; -;; Note: Both the form and environment will have their reference count -;; reduced by one (released). This is for tail call optimisation (Env), -;; quasiquote and macroexpand (AST) -;; -eval: - mov r15, rdi ; Env - - push rsi ; AST pushed, must be popped before return - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - and al, container_mask - cmp al, container_list - je .list - - ; Not a list. Evaluate and return - call eval_ast - jmp .return ; Releases Env - - ; -------------------- -.list: - ; A list - - ; Check if the first element is a symbol - mov al, BYTE [rsi] - - and al, content_mask - cmp al, content_pointer - jne .list_eval - - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .list_eval - - ; Is a symbol, address in RBX - - ; Compare against special form symbols - - eval_cmp_symbol def_symbol ; def! - je .def_symbol - - eval_cmp_symbol let_symbol ; let* - je .let_symbol - - eval_cmp_symbol do_symbol ; do - je .do_symbol - - eval_cmp_symbol if_symbol ; if - je .if_symbol - - eval_cmp_symbol fn_symbol ; fn - je .fn_symbol - - ; Unrecognised - jmp .list_eval - - - ; ----------------------------- - -.def_symbol: - ; Define a new symbol in current environment - - ; Next item should be a symbol - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Now should have a symbol - - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - jne .def_error_expecting_symbol - mov r8, [rsi + Cons.car] ; Symbol (?) - - mov al, BYTE [r8] - cmp al, maltype_symbol - jne .def_error_expecting_symbol - - ; R8 now contains a symbol - - ; expecting a value or pointer next - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a pointer - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .def_pointer - - ; A value, so copy - push rax - call alloc_cons - pop rbx ; BL now contains type - and bl, content_mask - add bl, (block_cons + container_value) - mov [rax], BYTE bl - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - mov rsi, rax - - jmp .def_got_value - -.def_pointer: - ; A pointer, so evaluate - - ; This may throw an error, so define a handler - - push r8 ; the symbol - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Pointer - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call incref_object ; AST increment refs - - call eval - mov rsi, rax - - pop r15 - pop r8 - -.def_got_value: - ; Symbol in R8, value in RSI - mov rdi, r8 ; key (symbol) - mov rcx, rsi ; Value - mov rsi, r15 ; Environment - call env_set - - mov rax, rcx - jmp .return - -.def_error_missing_arg: - mov rsi, def_missing_arg_string - mov rdx, def_missing_arg_string.len - jmp .def_handle_error - -.def_error_expecting_symbol: - mov rsi, def_expecting_symbol_string - mov rdx, def_expecting_symbol_string.len - jmp .def_handle_error - -.def_handle_error: - push rsi - push rdx - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - xor rsi, rsi ; no object to throw - jmp error_throw ; No return - - ; ----------------------------- -.let_symbol: - ; Create a new environment - - mov r11, rsi ; Let form in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - mov r14, rax ; New environment in R14 - - mov rsi, r15 - call release_object ; Decrement R15 ref count - - ; Second element should be the bindings - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_bindings - mov r11, [r11 + Cons.cdr] - - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .let_error_bindings_list - - mov r12, [r11 + Cons.car] ; should be bindings list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - ; Can be either a list or vector - cmp al, block_cons + container_list - je .let_bind_loop - cmp al, block_cons + container_vector - je .let_bind_loop - - ; Not a list or vector - jmp .let_error_bindings_list - -.let_bind_loop: - ; R12 now contains a list with an even number of items - ; The first should be a symbol, then a value to evaluate - - ; Get the symbol - mov al, BYTE [r12] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_symbol - - mov r13, [r12 + Cons.car] ; Symbol (?) - mov al, BYTE [r13] - cmp al, maltype_symbol - jne .let_error_bind_symbol - - ; R13 now contains a symbol to bind - ; The next item in the bindings list (R12) - ; should be a value or expression to evaluate - - mov al, BYTE [r12 + Cons.typecdr] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_value - mov r12, [r12 + Cons.cdr] - - ; got value in R12 - - ; Check the type of the value - mov bl, [r12 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .let_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r12 + Cons.typecar] - and bl, content_mask - ;or bl, (block_cons + container_value) ; 0 - mov [rax + Cons.typecar], bl - mov rcx, [r12 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .let_got_value - -.let_value_pointer: - ; A pointer, so need to evaluate - push r11 ; let* form list - push r12 ; Position in bindings list - push r13 ; symbol to bind - push r14 ; new environment - - mov rsi, r14 - call incref_object - mov rdi, r14 - - mov rsi, [r12 + Cons.car] ; Get the address - - call incref_object ; Increment ref count of AST - - call eval ; Evaluate it, result in rax - pop r14 - pop r13 - pop r12 - pop r11 - -.let_got_value: - - mov rsi, r14 ; Env - mov rdi, r13 ; key - mov rcx, rax ; value - call env_set - - ; Release the value - mov rsi, rcx ; The value - call release_object - - ; Check if there are more bindings - mov al, BYTE [r12 + Cons.typecdr] - cmp al, content_pointer - jne .let_done_binding - mov r12, [r12 + Cons.cdr] ; Next - jmp .let_bind_loop - -.let_done_binding: - ; Done bindings. - ; Evaluate next item in let* form in new environment - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_body - mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate - ; Check type of the value - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - je .body_pointer - - ; Just a value, so copy - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl ; set type - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx ; copy value - jmp .let_done - -.body_pointer: - ; Evaluate using new environment - - mov rsi, [r11 + Cons.car] ; Object pointed to - call incref_object ; will be released by eval - - mov r11, rsi ; save new AST - pop rsi ; Old AST - call release_object - mov rsi, r11 ; New AST - - mov rdi, r14 ; New environment - - jmp eval ; Tail call - ; Note: eval will release the new environment on return - -.let_done: - ; Release the new environment - push rax - mov rsi, r14 - call release_object - pop rax - - ; Release the AST - pop rsi - push rax - call release_object - pop rax - ret ; already released env - -.let_error_missing_bindings: - mov rsi, let_missing_bindings_string - mov rdx, let_missing_bindings_string.len - jmp .let_handle_error - -.let_error_bindings_list: ; expected a list or vector, got something else - mov rsi, let_bindings_list_string - mov rdx, let_bindings_list_string.len - jmp .let_handle_error - -.let_error_bind_symbol: ; expected a symbol, got something else - mov rsi, let_bind_symbol_string - mov rdx, let_bind_symbol_string.len - jmp .let_handle_error - -.let_error_bind_value: ; Missing value in binding list - mov rsi, let_bind_value_string - mov rdx, let_bind_value_string.len - jmp .let_handle_error - -.let_error_missing_body: ; Missing body to evaluate - mov rsi, let_missing_body_string - mov rdx, let_missing_body_string.len - jmp .let_handle_error - -.let_handle_error: - push r11 ; For printing later - - push rsi - push rdx - - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - pop rsi ; let* form - jmp error_throw ; No return - - ; ----------------------------- - -.do_symbol: - mov r11, rsi ; do form in RSI - ; Environment in R15 - - ; Check if there is a body - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .do_no_body ; error - - mov r11, [r11 + Cons.cdr] ; Body in R11 - -.do_symbol_loop: - - ; Need to test if this is the last form - ; so we can handle tail call - - mov bl, BYTE [r11 + Cons.typecdr] - cmp bl, content_pointer - jne .do_body_last ; Last expression - - ; not the last expression - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_next ; A value, so skip - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - ; since eval will release Env - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increment ref count since eval will release - - mov rdi, r15 ; Env - call eval ; Result in RAX - - ; Another form after this. - ; Discard the result of the last eval - mov rsi, rax - call release_object - - pop r11 - pop r15 - -.do_next: - mov r11, [r11 + Cons.cdr] ; Next in list - - jmp .do_symbol_loop - -.do_body_last: - ; The last form is in R11, which will be returned - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_body_value_return - jmp .do_body_expr_return - -.do_body_value_return: - ; Got a value as last form (in R11). - ; Copy and return - - push rax ; Type of value to return - - ; release Env - mov rsi, r15 - call release_object - - ; Allocate a Cons object to hold value - call alloc_cons - pop rbx ; type in BL - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - ; release the AST - pop rsi - mov r15, rax ; not modified by release - call release_object - mov rax, r15 - - ret - -.do_body_expr_return: - ; An expression to evaluate as the last form - ; Tail call optimise, jumping to eval - ; Don't increment Env reference count - - mov rsi, [r11 + Cons.car] ; new AST form - call incref_object ; This will be released by eval - - mov r11, rsi ; Save new AST - pop rsi ; Remove old AST from stack - call release_object - mov rsi, r11 - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.do_no_body: - ; No expressions to evaluate. Return nil - - mov rsi, r15 - call release_object ; Release Env - - ; release the AST - pop rsi - call release_object - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - ; ----------------------------- - -.if_symbol: - mov r11, rsi ; if form in R11 - ; Environment in R15 - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .if_no_condition - - mov r11, [r11 + Cons.cdr] ; Should be a condition - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .if_cond_value - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increase Form/AST ref count - - mov rdi, r15 ; Env - call eval ; Result in RAX - pop r11 - pop r15 - - ; Get type of result - mov bl, BYTE [rax] - - ; release value - push rbx - mov rsi, rax - call release_object - pop rbx - - ; Check type - cmp bl, maltype_nil - je .if_false - cmp bl, maltype_false - je .if_false - - jmp .if_true - -.if_cond_value: - - ; A value - cmp al, content_nil - je .if_false - cmp al, content_false - je .if_false - - jmp .if_true - -.if_false: - ; Skip the next item - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil - - mov r11, [r11 + Cons.cdr] - -.if_true: - ; Get the next item in the list and evaluate it - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; Nothing to return - - mov r11, [r11 + Cons.cdr] - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - je .if_got_pointer - -.if_got_value: - ; copy value in r11 - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - jmp .return - -.if_got_pointer: - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Will be released by eval - - mov r11, rsi - pop rsi - call release_object ; Release old AST - mov rsi, r11 ; New AST - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.if_no_condition: ; just (if) without a condition - - print_str_mac error_string - print_str_mac if_missing_condition_string - - ; Release environment - mov rsi, r15 - call release_object - xor rsi, rsi ; No object to throw - jmp error_throw - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - -.return: - ; Release environment - mov rsi, r15 - mov r15, rax ; Save RAX (return value) - call release_object - - ; Release the AST - pop rsi ; Pushed at start of eval - call release_object - - mov rax, r15 ; return value - ret - - ; ----------------------------- - -.fn_symbol: - mov r11, rsi ; fn form in R11 - ; Environment in R15 - - ; Get the binds and body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_empty - - mov r11, [r11 + Cons.cdr] - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_binds_not_list - - mov r12, [r11 + Cons.car] ; Should be binds list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - cmp al, (block_cons + container_list) - je .fn_got_binds ; Can be list - cmp al, (block_cons + container_vector) - je .fn_got_binds ; or vector - jmp .fn_binds_not_list - -.fn_got_binds: - - ; Next get the body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_no_body - - mov r11, [r11 + Cons.cdr] - ; Check value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_is_value ; Body in r11 - mov r11, [r11 + Cons.car] - jmp .fn_got_body - -.fn_is_value: - ; Body is just a value, no expression - mov [r11], BYTE al ; Mark as value, not list - -.fn_got_body: - - ; Now put into function type - ; Addr is "apply_fn", the address to call - ; Env in R15 - ; Binds in R12 - ; Body in R11 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_function) - mov rbx, apply_fn - mov [rax + Cons.car], rbx ; Address of apply function - mov [rax + Cons.typecdr], BYTE content_pointer - - mov r13, rax ; Return list in R13 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r15 ; Environment - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r13 + Cons.cdr], rax ; Append to list - mov r14, rax ; R14 contains last cons in list - - push rax - mov rsi, r15 - call incref_object - pop rax - - ; Binds - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r12 ; Binds list - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r14 + Cons.cdr], rax ; Append to list - mov r14, rax - - push rax - mov rsi, r12 - call incref_object - pop rax - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r11 ; Body of function - - mov [r14 + Cons.cdr], rax - - mov rsi, r11 - call incref_object - - mov rax, r13 - jmp .return - -.fn_empty: -.fn_binds_not_list: -.fn_no_body: - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - jmp .return - - - ; ----------------------------- - -.list_eval: - push rsi - mov rdi, r15 ; Environment - push r15 - call eval_ast ; List of evaluated forms in RAX - pop r15 - pop rsi - -.list_exec: - ; This point can be called to run a function - ; used by swap! - ; - ; Inputs: RAX - List with function as first element - ; NOTE: This list is released - ; - ; Check that the first element of the return is a function - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .list_not_function - - mov rbx, [rax + Cons.car] ; Get the address - mov cl, BYTE [rbx] - cmp cl, maltype_function - jne .list_not_function - - ; Check the rest of the args - mov cl, BYTE [rax + Cons.typecdr] - cmp cl, content_pointer - je .list_got_args - - ; No arguments - push rbx ; Function object - push rax ; List with function first - - ; Create an empty list for the arguments - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax ; Argument list into RSI - - pop rax ; list, function first - ;; Put new empty list onto end of original list - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rsi - - pop rbx - jmp .list_function_call -.list_got_args: - mov rsi, [rax + Cons.cdr] ; Rest of list -.list_function_call: - ; Call the function with the rest of the list in RSI - - mov rdx, rax ; List to release - mov rdi, rbx ; Function object in RDI - - mov rbx, [rbx + Cons.car] ; Call function - cmp rbx, apply_fn - je apply_fn_jmp ; Jump to user function apply - - ; A built-in function, so call (no recursion) - push rax - push r15 - - call rbx - - ; Result in rax - pop r15 - pop rsi ; eval'ed list - - push rax - call release_cons - pop rax - jmp .return ; Releases Env - -.list_not_function: - ; Not a function. Probably an error - push rsi - - mov rsi, rax - call release_object - - print_str_mac error_string - print_str_mac eval_list_not_function - pop rsi - jmp error_throw - -.empty_list: - mov rax, rsi - jmp .return - -;; Applies a user-defined function -;; -;; Input: RSI - Arguments to bind -;; RDI - Function object -;; RDX - list to release after binding -;; R15 - Env (will be released) -;; R13 - AST released before return -;; -;; -;; Output: Result in RAX -;; -;; This is jumped to from eval, so if it returns -;; then it will return to the caller of eval, not to eval -apply_fn_jmp: - ; This is jumped to from eval with AST on the stack - pop r13 -apply_fn: - push rsi - ; Extract values from the list in RDI - mov rax, [rdi + Cons.cdr] - mov rsi, [rax + Cons.car] ; Env - mov rax, [rax + Cons.cdr] - mov rdi, [rax + Cons.car] ; Binds - mov rax, [rax + Cons.cdr] - mov rax, [rax + Cons.car] ; Body - pop rcx ; Exprs - - ; Check the type of the body - mov bl, BYTE [rax] - and bl, block_mask + container_mask - jnz .bind - ; Just a value (in RAX). No eval needed - - mov r14, rax ; Save return value in R14 - - mov rsi, rax - call incref_object - - ; Release the list passed in RDX - mov rsi, rdx - call release_object - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the AST - mov rsi, r13 - call release_object - - mov rax, r14 - ret -.bind: - ; Create a new environment, binding arguments - push rax ; Body - - mov r14, r13 ; Old AST. R13 used by env_new_bind - - push rdx - call env_new_bind - pop rdx - - mov rdi, rax ; New environment in RDI - - ; Note: Need to increment the reference count - ; of the function body before releasing anything, - ; since if the function was defined in-place (lambda) - ; then the body may be released early - - pop rsi ; Body - call incref_object ; Will be released by eval - mov r8, rsi ; Body in R8 - - ; Release the list passed in RDX - mov rsi, rdx - call release_cons - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the old AST - mov rsi, r14 - call release_object - - mov rsi, r8 ; Body - - jmp eval ; Tail call - ; The new environment (in RDI) will be released by eval - - -;; Read-Eval-Print in sequence -;; -;; Input string in RSI -rep_seq: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call eval ; This releases Env and Form/AST - push rax ; Save result of eval - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - mov rdi, 1 ; print readably - call pr_str ; String in RAX - - mov r8, rax ; Save output - - pop rsi ; Result from eval - call release_object - mov rax, r8 - - ret - - -_start: - ; Create and print the core environment - call core_environment ; Environment in RAX - - mov [repl_env], rax ; store in memory - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; Evaluate the startup string - - mov rsi, mal_startup_string - mov edx, mal_startup_string.len - call raw_to_string ; String in RAX - - push rax - mov rsi, rax - call read_str ; AST in RAX - pop rsi ; string - - push rax ; AST - call release_array ; string - pop rdi ; AST in RDI - - mov rsi, [repl_env] ; Environment in RSI - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call eval - - mov rsi, rax - call release_object ; Return from eval - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - -.catch: - ; Jumps here on error - - ; Check if an object was thrown - cmp rsi, 0 - je .catch_done_print ; nothing to print - mov rdi, 1 - call pr_str - mov rsi, rax - call print_string -.catch_done_print: - jmp .mainLoop ; Go back to the prompt - +;; +;; nasm -felf64 step5_tco.asm && ld step5_tco.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(def! not (fn* (a) (if a false true)))" + + +section .text + + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] +;; +;; Returns: Result in RAX +;; +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) +;; +eval: + mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.def_symbol: + ; Define a new symbol in current environment + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs + + call eval + mov rsi, rax + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + ; release the AST + pop rsi + call release_object + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + ; Release environment + mov rsi, r15 + mov r15, rax ; Save RAX (return value) + call release_object + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax ; R14 contains last cons in list + + push rax + mov rsi, r15 + call incref_object + pop rax + + ; Binds + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx ; Function object + push rax ; List with function first + + ; Create an empty list for the arguments + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax ; Argument list into RSI + + pop rax ; list, function first + ;; Put new empty list onto end of original list + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rsi + + pop rbx + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn_jmp ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + +.empty_list: + mov rax, rsi + jmp .return + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; R13 - AST released before return +;; +;; +;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + mov r14, rax ; Save return value in R14 + + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the AST + mov rsi, r13 + call release_object + + mov rax, r14 + ret +.bind: + ; Create a new environment, binding arguments + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + + ; Release the list passed in RDX + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + mov rax, r8 + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call eval + + mov rsi, rax + call release_object ; Return from eval + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + diff --git a/impls/nasm/step6_file.asm b/impls/nasm/step6_file.asm index 3b7156165d..41b684cb08 100644 --- a/impls/nasm/step6_file.asm +++ b/impls/nasm/step6_file.asm @@ -1,1701 +1,1701 @@ -;; -;; nasm -felf64 step6_file.asm && ld step6_file.o && ./a.out -;; -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "env.asm" ; Environment type -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "core.asm" ; Core functions -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .bss - -;; Top-level (REPL) environment -repl_env:resq 1 - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - - static error_string, db 27,'[31m',"Error",27,'[0m',": " - - static not_found_string, db " not found" - - static def_missing_arg_string, db "missing argument to def!",10 - - static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 - - static let_missing_bindings_string, db "let* missing bindings",10 - - static let_bindings_list_string, db "let* expected a list or vector of bindings",10 - - static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 - - static let_bind_value_string, db "let* missing value in bindings list",10 - - static let_missing_body_string, db "let* missing body",10 - static eval_list_not_function, db "list does not begin with a function",10 - - static if_missing_condition_string, db "missing condition in if expression",10 - -;; Symbols used for comparison - - static_symbol def_symbol, 'def!' - static_symbol let_symbol, 'let*' - static_symbol do_symbol, 'do' - static_symbol if_symbol, 'if' - static_symbol fn_symbol, 'fn*' - - static_symbol argv_symbol, '*ARGV*' - -;; Startup string. This is evaluated on startup - static mal_startup_string, db "(do \ -(def! not (fn* (a) (if a false true))) \ -(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ -)" - -;; Command to run, appending the name of the script to run - static run_script_string, db "(load-file ",34 -section .text - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; RDI Environment -;; -eval_ast: - mov r15, rdi ; Save Env in r15 - - ; Check the type - mov al, BYTE [rsi] - - ; Check if this is a list - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list - - cmp ah, container_map - je .map - - cmp ah, container_vector - je .vector - - ; Not a list, map or vector - cmp ah, container_symbol - je .symbol - - ; Not a symbol, list, map or vector - call incref_object ; Increment reference count - - mov rax, rsi - ret - -.symbol: - ; Check if first character of symbol is ':' - mov al, BYTE [rsi + Array.data] - cmp al, ':' - je .keyword - - ; look in environment - push rsi - xchg rsi, rdi - ; symbol is the key in rdi - ; Environment in rsi - call env_get - pop rsi - je .done ; result in RAX - - ; Not found, throw an error - push rsi - print_str_mac error_string ; print 'Error: ' - - pop rsi - push rsi - mov edx, [rsi + Array.length] - add rsi, Array.data - call print_rawstring ; print symbol - - print_str_mac not_found_string ; print ' not found' - pop rsi - - jmp error_throw - - ; ------------------------------ - -.keyword: - ; Just return keywords unaltered - call incref_object - mov rax, rsi - ret - - ; ------------------------------ -.list: - ; Evaluate each element of the list - ; - xor r8, r8 ; The list to return - ; r9 contains head of list - -.list_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .list_pointer - - ; A value in RSI, so copy - - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_list) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .list_append - -.list_pointer: - ; List element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rdi, [rsi + Cons.car] ; Get the address - mov rsi, r15 - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call incref_object ; AST increment refs - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .list_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_list + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .list_append - -.list_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_list) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - - ; Fall through to .list_append -.list_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .list_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .list_next - -.list_first: - mov r8, rax - mov r9, rax - ; fall through to .list_next - -.list_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .list_done ; finished list - mov rsi, [rsi + Cons.cdr] ; next in list - jmp .list_loop - -.list_done: - mov rax, r8 ; Return the list - ret - - ; --------------------- -.map: - ; Create a new map, evaluating all the values - - ; Check if the map is empty - cmp al, maltype_empty_map - jne .map_not_empty - - ; map empty. Just return it - call incref_object - mov rax, rsi - ret - -.map_not_empty: - - mov r10, rsi ; input in R10 - xor r12, r12 ; New map in r12 - - ; Now loop through each key-value pair - ; NOTE: This method relies on the implementation - ; of map as a list - -.map_loop: - ; Copy the key - call alloc_cons ; New Cons in RAX - - mov bl, [r10 + Cons.typecar] ; Type in BL - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] ; Value in RCX - mov [rax + Cons.car], rcx - - ; Check the type of the key - and bl, content_mask - cmp bl, content_pointer - jne .map_got_key ; a value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.map_got_key: - cmp r12,0 - jne .append_key - - ; First key - mov r12, rax - mov r13, rax - jmp .map_value - -.append_key: - ; Appending to previous value in r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - -.map_value: - ; Check that we have a value - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_error_missing_value - mov r10, [r10 + Cons.cdr] - - ; Now got value in r10 - - ; Check the type of the value - mov bl, [r10 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .map_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r10 + Cons.typecar] - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .map_got_value -.map_value_pointer: - ; A pointer, so need to evaluate - push r10 ; Input - push r12 ; start of result - push r13 ; Current head of result - push r15 ; Env - mov rsi, [r10 + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r13 - pop r12 - pop r10 - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - - jne .map_eval_pointer - - ; A value, so just change the type to a map - and bl, content_mask - add bl, (block_cons + container_map) - mov [rax], BYTE bl - jmp .map_got_value - -.map_eval_pointer: - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - -.map_got_value: - ; Append RAX to list in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - - ; Check if there's another key - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_done ; finished map - mov r10, [r10 + Cons.cdr] ; next in map - jmp .map_loop - -.map_done: - mov rax, r12 - ret - -.map_error_missing_value: - mov rax, r12 - ret - - ; ------------------------------ -.vector: - ; Evaluate each element of the vector - ; - xor r8, r8 ; The vector to return - ; r9 contains head of vector - -.vector_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .vector_pointer - - ; A value, so copy - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_vector) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .vector_append - -.vector_pointer: - ; Vector element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .vector_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_vector + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .vector_append - -.vector_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_vector) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - -.vector_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .vector_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .vector_next - -.vector_first: - mov r8, rax - mov r9, rax - ; fall through to .vector_next - -.vector_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .vector_done ; finished vector - mov rsi, [rsi + Cons.cdr] ; next in vector - jmp .vector_loop - -.vector_done: - mov rax, r8 ; Return the vector - ret - - ; --------------------- -.done: - ret - - - -;; Comparison of symbols for eval function -;; Compares the symbol in RSI with specified symbol -;; Preserves RSI and RBX -;; Modifies RDI -%macro eval_cmp_symbol 1 - push rsi - push rbx - mov rsi, rbx - mov rdi, %1 - call compare_char_array - pop rbx - pop rsi - test rax, rax ; ZF set if rax = 0 (equal) -%endmacro - -;; ---------------------------------------------------- -;; Evaluates a form -;; -;; Input: RSI AST to evaluate [ Released ] -;; RDI Environment [ Released ] -;; -;; Returns: Result in RAX -;; -;; Note: Both the form and environment will have their reference count -;; reduced by one (released). This is for tail call optimisation (Env), -;; quasiquote and macroexpand (AST) -;; -eval: - mov r15, rdi ; Env - - push rsi ; AST pushed, must be popped before return - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - and al, container_mask - cmp al, container_list - je .list - - ; Not a list. Evaluate and return - call eval_ast - jmp .return ; Releases Env - - ; -------------------- -.list: - ; A list - - ; Check if the first element is a symbol - mov al, BYTE [rsi] - - and al, content_mask - cmp al, content_pointer - jne .list_eval - - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .list_eval - - ; Is a symbol, address in RBX - - ; Compare against special form symbols - - eval_cmp_symbol def_symbol ; def! - je .def_symbol - - eval_cmp_symbol let_symbol ; let* - je .let_symbol - - eval_cmp_symbol do_symbol ; do - je .do_symbol - - eval_cmp_symbol if_symbol ; if - je .if_symbol - - eval_cmp_symbol fn_symbol ; fn - je .fn_symbol - - ; Unrecognised - jmp .list_eval - - - ; ----------------------------- - -.def_symbol: - ; Define a new symbol in current environment - - ; Next item should be a symbol - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Now should have a symbol - - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - jne .def_error_expecting_symbol - mov r8, [rsi + Cons.car] ; Symbol (?) - - mov al, BYTE [r8] - cmp al, maltype_symbol - jne .def_error_expecting_symbol - - ; R8 now contains a symbol - - ; expecting a value or pointer next - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a pointer - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .def_pointer - - ; A value, so copy - push rax - call alloc_cons - pop rbx ; BL now contains type - and bl, content_mask - add bl, (block_cons + container_value) - mov [rax], BYTE bl - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - mov rsi, rax - - jmp .def_got_value - -.def_pointer: - ; A pointer, so evaluate - - ; This may throw an error, so define a handler - - push r8 ; the symbol - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Pointer - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call incref_object ; AST increment refs - - call eval - mov rsi, rax - - pop r15 - pop r8 - -.def_got_value: - ; Symbol in R8, value in RSI - mov rdi, r8 ; key (symbol) - mov rcx, rsi ; Value - mov rsi, r15 ; Environment - call env_set - - mov rax, rcx - jmp .return - -.def_error_missing_arg: - mov rsi, def_missing_arg_string - mov rdx, def_missing_arg_string.len - jmp .def_handle_error - -.def_error_expecting_symbol: - mov rsi, def_expecting_symbol_string - mov rdx, def_expecting_symbol_string.len - jmp .def_handle_error - -.def_handle_error: - push rsi - push rdx - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - xor rsi, rsi ; no object to throw - jmp error_throw ; No return - - ; ----------------------------- -.let_symbol: - ; Create a new environment - - mov r11, rsi ; Let form in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - mov r14, rax ; New environment in R14 - - mov rsi, r15 - call release_object ; Decrement R15 ref count - - ; Second element should be the bindings - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_bindings - mov r11, [r11 + Cons.cdr] - - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .let_error_bindings_list - - mov r12, [r11 + Cons.car] ; should be bindings list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - ; Can be either a list or vector - cmp al, block_cons + container_list - je .let_bind_loop - cmp al, block_cons + container_vector - je .let_bind_loop - - ; Not a list or vector - jmp .let_error_bindings_list - -.let_bind_loop: - ; R12 now contains a list with an even number of items - ; The first should be a symbol, then a value to evaluate - - ; Get the symbol - mov al, BYTE [r12] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_symbol - - mov r13, [r12 + Cons.car] ; Symbol (?) - mov al, BYTE [r13] - cmp al, maltype_symbol - jne .let_error_bind_symbol - - ; R13 now contains a symbol to bind - ; The next item in the bindings list (R12) - ; should be a value or expression to evaluate - - mov al, BYTE [r12 + Cons.typecdr] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_value - mov r12, [r12 + Cons.cdr] - - ; got value in R12 - - ; Check the type of the value - mov bl, [r12 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .let_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r12 + Cons.typecar] - and bl, content_mask - ;or bl, (block_cons + container_value) ; 0 - mov [rax + Cons.typecar], bl - mov rcx, [r12 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .let_got_value - -.let_value_pointer: - ; A pointer, so need to evaluate - push r11 ; let* form list - push r12 ; Position in bindings list - push r13 ; symbol to bind - push r14 ; new environment - - mov rsi, r14 - call incref_object - mov rdi, r14 - - mov rsi, [r12 + Cons.car] ; Get the address - - call incref_object ; Increment ref count of AST - - call eval ; Evaluate it, result in rax - pop r14 - pop r13 - pop r12 - pop r11 - -.let_got_value: - - mov rsi, r14 ; Env - mov rdi, r13 ; key - mov rcx, rax ; value - call env_set - - ; Release the value - mov rsi, rcx ; The value - call release_object - - ; Check if there are more bindings - mov al, BYTE [r12 + Cons.typecdr] - cmp al, content_pointer - jne .let_done_binding - mov r12, [r12 + Cons.cdr] ; Next - jmp .let_bind_loop - -.let_done_binding: - ; Done bindings. - ; Evaluate next item in let* form in new environment - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_body - mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate - ; Check type of the value - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - je .body_pointer - - ; Just a value, so copy - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl ; set type - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx ; copy value - jmp .let_done - -.body_pointer: - ; Evaluate using new environment - - mov rsi, [r11 + Cons.car] ; Object pointed to - call incref_object ; will be released by eval - - mov r11, rsi ; save new AST - pop rsi ; Old AST - call release_object - mov rsi, r11 ; New AST - - mov rdi, r14 ; New environment - - jmp eval ; Tail call - ; Note: eval will release the new environment on return - -.let_done: - ; Release the new environment - push rax - mov rsi, r14 - call release_object - pop rax - - ; Release the AST - pop rsi - push rax - call release_object - pop rax - ret ; already released env - -.let_error_missing_bindings: - mov rsi, let_missing_bindings_string - mov rdx, let_missing_bindings_string.len - jmp .let_handle_error - -.let_error_bindings_list: ; expected a list or vector, got something else - mov rsi, let_bindings_list_string - mov rdx, let_bindings_list_string.len - jmp .let_handle_error - -.let_error_bind_symbol: ; expected a symbol, got something else - mov rsi, let_bind_symbol_string - mov rdx, let_bind_symbol_string.len - jmp .let_handle_error - -.let_error_bind_value: ; Missing value in binding list - mov rsi, let_bind_value_string - mov rdx, let_bind_value_string.len - jmp .let_handle_error - -.let_error_missing_body: ; Missing body to evaluate - mov rsi, let_missing_body_string - mov rdx, let_missing_body_string.len - jmp .let_handle_error - -.let_handle_error: - push r11 ; For printing later - - push rsi - push rdx - - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - pop rsi ; let* form - jmp error_throw ; No return - - ; ----------------------------- - -.do_symbol: - mov r11, rsi ; do form in RSI - ; Environment in R15 - - ; Check if there is a body - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .do_no_body ; error - - mov r11, [r11 + Cons.cdr] ; Body in R11 - -.do_symbol_loop: - - ; Need to test if this is the last form - ; so we can handle tail call - - mov bl, BYTE [r11 + Cons.typecdr] - cmp bl, content_pointer - jne .do_body_last ; Last expression - - ; not the last expression - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_next ; A value, so skip - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - ; since eval will release Env - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increment ref count since eval will release - - mov rdi, r15 ; Env - call eval ; Result in RAX - - ; Another form after this. - ; Discard the result of the last eval - mov rsi, rax - call release_object - - pop r11 - pop r15 - -.do_next: - mov r11, [r11 + Cons.cdr] ; Next in list - - jmp .do_symbol_loop - -.do_body_last: - ; The last form is in R11, which will be returned - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_body_value_return - jmp .do_body_expr_return - -.do_body_value_return: - ; Got a value as last form (in R11). - ; Copy and return - - push rax ; Type of value to return - - ; release Env - mov rsi, r15 - call release_object - - ; Allocate a Cons object to hold value - call alloc_cons - pop rbx ; type in BL - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - ; release the AST - pop rsi - mov r15, rax ; not modified by release - call release_object - mov rax, r15 - - ret - -.do_body_expr_return: - ; An expression to evaluate as the last form - ; Tail call optimise, jumping to eval - ; Don't increment Env reference count - - mov rsi, [r11 + Cons.car] ; new AST form - call incref_object ; This will be released by eval - - mov r11, rsi ; Save new AST - pop rsi ; Remove old AST from stack - call release_object - mov rsi, r11 - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.do_no_body: - ; No expressions to evaluate. Return nil - - mov rsi, r15 - call release_object ; Release Env - - ; release the AST - pop rsi - call release_object - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - ; ----------------------------- - -.if_symbol: - mov r11, rsi ; if form in R11 - ; Environment in R15 - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .if_no_condition - - mov r11, [r11 + Cons.cdr] ; Should be a condition - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .if_cond_value - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increase Form/AST ref count - - mov rdi, r15 ; Env - call eval ; Result in RAX - pop r11 - pop r15 - - ; Get type of result - mov bl, BYTE [rax] - - ; release value - push rbx - mov rsi, rax - call release_object - pop rbx - - ; Check type - cmp bl, maltype_nil - je .if_false - cmp bl, maltype_false - je .if_false - - jmp .if_true - -.if_cond_value: - - ; A value - cmp al, content_nil - je .if_false - cmp al, content_false - je .if_false - - jmp .if_true - -.if_false: - ; Skip the next item - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil - - mov r11, [r11 + Cons.cdr] - -.if_true: - ; Get the next item in the list and evaluate it - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; Nothing to return - - mov r11, [r11 + Cons.cdr] - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - je .if_got_pointer - -.if_got_value: - ; copy value in r11 - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - jmp .return - -.if_got_pointer: - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Will be released by eval - - mov r11, rsi - pop rsi - call release_object ; Release old AST - mov rsi, r11 ; New AST - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.if_no_condition: ; just (if) without a condition - - print_str_mac error_string - print_str_mac if_missing_condition_string - - ; Release environment - mov rsi, r15 - call release_object - xor rsi, rsi ; No object to throw - jmp error_throw - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - -.return: - ; Release environment - mov rsi, r15 - mov r15, rax ; Save RAX (return value) - call release_object - - ; Release the AST - pop rsi ; Pushed at start of eval - call release_object - - mov rax, r15 ; return value - ret - - ; ----------------------------- - -.fn_symbol: - mov r11, rsi ; fn form in R11 - ; Environment in R15 - - ; Get the binds and body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_empty - - mov r11, [r11 + Cons.cdr] - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_binds_not_list - - mov r12, [r11 + Cons.car] ; Should be binds list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - cmp al, (block_cons + container_list) - je .fn_got_binds ; Can be list - cmp al, (block_cons + container_vector) - je .fn_got_binds ; or vector - jmp .fn_binds_not_list - -.fn_got_binds: - - ; Next get the body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_no_body - - mov r11, [r11 + Cons.cdr] - ; Check value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_is_value ; Body in r11 - mov r11, [r11 + Cons.car] - jmp .fn_got_body - -.fn_is_value: - ; Body is just a value, no expression - mov [r11], BYTE al ; Mark as value, not list - -.fn_got_body: - - ; Now put into function type - ; Addr is "apply_fn", the address to call - ; Env in R15 - ; Binds in R12 - ; Body in R11 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_function) - mov rbx, apply_fn - mov [rax + Cons.car], rbx ; Address of apply function - mov [rax + Cons.typecdr], BYTE content_pointer - - mov r13, rax ; Return list in R13 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r15 ; Environment - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r13 + Cons.cdr], rax ; Append to list - mov r14, rax ; R14 contains last cons in list - - push rax - mov rsi, r15 - call incref_object - pop rax - - ; Binds - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r12 ; Binds list - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r14 + Cons.cdr], rax ; Append to list - mov r14, rax - - push rax - mov rsi, r12 - call incref_object - pop rax - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r11 ; Body of function - - mov [r14 + Cons.cdr], rax - - mov rsi, r11 - call incref_object - - mov rax, r13 - jmp .return - -.fn_empty: -.fn_binds_not_list: -.fn_no_body: - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - jmp .return - - - ; ----------------------------- - -.list_eval: - push rsi - mov rdi, r15 ; Environment - push r15 - call eval_ast ; List of evaluated forms in RAX - pop r15 - pop rsi - -.list_exec: - ; This point can be called to run a function - ; used by swap! - ; - ; Inputs: RAX - List with function as first element - ; NOTE: This list is released - ; - ; Check that the first element of the return is a function - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .list_not_function - - mov rbx, [rax + Cons.car] ; Get the address - mov cl, BYTE [rbx] - cmp cl, maltype_function - jne .list_not_function - - ; Check the rest of the args - mov cl, BYTE [rax + Cons.typecdr] - cmp cl, content_pointer - je .list_got_args - - ; No arguments - push rbx ; Function object - push rax ; List with function first - - ; Create an empty list for the arguments - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax ; Argument list into RSI - - pop rax ; list, function first - ;; Put new empty list onto end of original list - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rsi - - pop rbx - jmp .list_function_call -.list_got_args: - mov rsi, [rax + Cons.cdr] ; Rest of list -.list_function_call: - ; Call the function with the rest of the list in RSI - - mov rdx, rax ; List to release - mov rdi, rbx ; Function object in RDI - - mov rbx, [rbx + Cons.car] ; Call function - cmp rbx, apply_fn - je apply_fn_jmp ; Jump to user function apply - - ; A built-in function, so call (no recursion) - push rax - push r15 - - call rbx - - ; Result in rax - pop r15 - pop rsi ; eval'ed list - - push rax - call release_cons - pop rax - jmp .return ; Releases Env - -.list_not_function: - ; Not a function. Probably an error - push rsi - - mov rsi, rax - call release_object - - print_str_mac error_string - print_str_mac eval_list_not_function - pop rsi - jmp error_throw - -.empty_list: - mov rax, rsi - jmp .return - -;; Applies a user-defined function -;; -;; Input: RSI - Arguments to bind -;; RDI - Function object -;; RDX - list to release after binding -;; R15 - Env (will be released) -;; R13 - AST released before return -;; -;; -;; Output: Result in RAX -;; -;; This is jumped to from eval, so if it returns -;; then it will return to the caller of eval, not to eval -apply_fn_jmp: - ; This is jumped to from eval with AST on the stack - pop r13 -apply_fn: - push rsi - ; Extract values from the list in RDI - mov rax, [rdi + Cons.cdr] - mov rsi, [rax + Cons.car] ; Env - mov rax, [rax + Cons.cdr] - mov rdi, [rax + Cons.car] ; Binds - mov rax, [rax + Cons.cdr] - mov rax, [rax + Cons.car] ; Body - pop rcx ; Exprs - - ; Check the type of the body - mov bl, BYTE [rax] - and bl, block_mask + container_mask - jnz .bind - ; Just a value (in RAX). No eval needed - - mov r14, rax ; Save return value in R14 - - mov rsi, rax - call incref_object - - ; Release the list passed in RDX - mov rsi, rdx - call release_object - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the AST - mov rsi, r13 - call release_object - - mov rax, r14 - ret -.bind: - ; Create a new environment, binding arguments - push rax ; Body - - mov r14, r13 ; Old AST. R13 used by env_new_bind - - push rdx - call env_new_bind - pop rdx - - mov rdi, rax ; New environment in RDI - - ; Note: Need to increment the reference count - ; of the function body before releasing anything, - ; since if the function was defined in-place (lambda) - ; then the body may be released early - - pop rsi ; Body - call incref_object ; Will be released by eval - mov r8, rsi ; Body in R8 - - ; Release the list passed in RDX - mov rsi, rdx - call release_cons - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the old AST - mov rsi, r14 - call release_object - - mov rsi, r8 ; Body - - jmp eval ; Tail call - ; The new environment (in RDI) will be released by eval - -;; Read and eval -read_eval: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - jmp eval ; This releases Env and Form/AST - - -;; Read-Eval-Print in sequence -;; -;; Input string in RSI -rep_seq: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call eval ; This releases Env and Form/AST - push rax ; Save result of eval - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - mov rdi, 1 ; print readably - call pr_str ; String in RAX - - mov r8, rax ; Save output - - pop rsi ; Result from eval - call release_object - mov rax, r8 - - ret - - -_start: - ; Create and print the core environment - call core_environment ; Environment in RAX - - mov [repl_env], rax ; store in memory - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; Evaluate the startup string - - mov rsi, mal_startup_string - mov edx, mal_startup_string.len - call raw_to_string ; String in RAX - - push rax - mov rsi, rax - call read_str ; AST in RAX - pop rsi ; string - - push rax ; AST - call release_array ; string - pop rdi ; AST in RDI - - mov rsi, [repl_env] ; Environment in RSI - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call eval - - mov rsi, rax - call release_object ; Return from eval - - ; ----------------------------- - ; Check command-line arguments - - pop rax ; Number of arguments - cmp rax, 1 ; Always have at least one, the path to executable - jg run_script - - ; No extra arguments, so just set *ARGV* to an empty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov rcx, rax ; value (empty list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - -.catch: - ; Jumps here on error - - ; Check if an object was thrown - cmp rsi, 0 - je .catch_done_print ; nothing to print - mov rdi, 1 - call pr_str - mov rsi, rax - call print_string -.catch_done_print: - jmp .mainLoop ; Go back to the prompt - - - -run_script: - ; Called with number of command-line arguments in RAX - mov r8, rax - pop rbx ; executable - dec r8 - - pop rsi ; Address of first arg - call cstring_to_string ; string in RAX - mov r9, rax - - ; get the rest of the args - xor r10, r10 ; Zero - dec r8 - jz .no_args - - ; Got some arguments -.arg_loop: - ; Got an argument left. - pop rsi ; Address of C string - call cstring_to_string ; String in RAX - mov r12, rax - - ;Make a Cons to point to the string - call alloc_cons ; in RAX - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], r12 - - test r10, r10 - jnz .append - - ; R10 zero, so first arg - mov r10, rax ; Head of list - mov r11, rax ; Tail of list - jmp .next -.append: - ; R10 not zero, so append to list tail - mov [r11 + Cons.cdr], rax - mov [r11 + Cons.typecdr], BYTE content_pointer - mov r11, rax -.next: - dec r8 - jnz .arg_loop - jmp .got_args - -.no_args: - ; No arguments. Create an emoty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov r10, rax - -.got_args: - push r9 ; File name string - - mov rcx, r10 ; value (list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - mov rsi, run_script_string ; load-file function - mov edx, run_script_string.len - call raw_to_string ; String in RAX - - mov rsi, rax - pop rdx ; File name string - call string_append_string - - mov cl, 34 ; " - call string_append_char - mov cl, ')' - call string_append_char ; closing brace - - ; Read-Eval "(load-file )" - call read_eval - - jmp quit +;; +;; nasm -felf64 step6_file.asm && ld step6_file.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + + static_symbol argv_symbol, '*ARGV*' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do \ +(def! not (fn* (a) (if a false true))) \ +(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ +)" + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 +section .text + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] +;; +;; Returns: Result in RAX +;; +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) +;; +eval: + mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.def_symbol: + ; Define a new symbol in current environment + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs + + call eval + mov rsi, rax + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + ; release the AST + pop rsi + call release_object + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + ; Release environment + mov rsi, r15 + mov r15, rax ; Save RAX (return value) + call release_object + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax ; R14 contains last cons in list + + push rax + mov rsi, r15 + call incref_object + pop rax + + ; Binds + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx ; Function object + push rax ; List with function first + + ; Create an empty list for the arguments + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax ; Argument list into RSI + + pop rax ; list, function first + ;; Put new empty list onto end of original list + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rsi + + pop rbx + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn_jmp ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + +.empty_list: + mov rax, rsi + jmp .return + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; R13 - AST released before return +;; +;; +;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + mov r14, rax ; Save return value in R14 + + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the AST + mov rsi, r13 + call release_object + + mov rax, r14 + ret +.bind: + ; Create a new environment, binding arguments + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + + ; Release the list passed in RDX + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + mov rax, r8 + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call eval + + mov rsi, rax + call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval "(load-file )" + call read_eval + + jmp quit diff --git a/impls/nasm/step7_quote.asm b/impls/nasm/step7_quote.asm index d65b4a5e55..e91aad7cff 100644 --- a/impls/nasm/step7_quote.asm +++ b/impls/nasm/step7_quote.asm @@ -1,2076 +1,2076 @@ -;; -;; nasm -felf64 step7_quote.asm && ld step7_quote.o && ./a.out -;; -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "env.asm" ; Environment type -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "core.asm" ; Core functions -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .bss - -;; Top-level (REPL) environment -repl_env:resq 1 - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - - static error_string, db 27,'[31m',"Error",27,'[0m',": " - - static not_found_string, db " not found" - - static def_missing_arg_string, db "missing argument to def!",10 - - static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 - - static let_missing_bindings_string, db "let* missing bindings",10 - - static let_bindings_list_string, db "let* expected a list or vector of bindings",10 - - static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 - - static let_bind_value_string, db "let* missing value in bindings list",10 - - static let_missing_body_string, db "let* missing body",10 - static eval_list_not_function, db "list does not begin with a function",10 - - static if_missing_condition_string, db "missing condition in if expression",10 - -;; Symbols used for comparison - - static_symbol def_symbol, 'def!' - static_symbol let_symbol, 'let*' - static_symbol do_symbol, 'do' - static_symbol if_symbol, 'if' - static_symbol fn_symbol, 'fn*' - - static_symbol argv_symbol, '*ARGV*' - - static_symbol quote_symbol, 'quote' - static_symbol quasiquote_symbol, 'quasiquote' - static_symbol quasiquoteexpand_symbol, 'quasiquoteexpand' - static_symbol unquote_symbol, 'unquote' - static_symbol splice_unquote_symbol, 'splice-unquote' - static_symbol concat_symbol, 'concat' - static_symbol cons_symbol, 'cons' - static_symbol vec_symbol, 'vec' - -;; Startup string. This is evaluated on startup - static mal_startup_string, db "(do \ -(def! not (fn* (a) (if a false true))) \ -(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ -)" - -;; Command to run, appending the name of the script to run - static run_script_string, db "(load-file ",34 -section .text - - -;;; Extract the car of a Cons and increment its reference count. -;;; If it was value, create a fresh copy. -;;; in : rsi (which must be a pointer!) -;;; out : rsi -;;; modified: : cl, rax, rbx -car_and_incref: - mov cl, BYTE [rsi + Cons.typecar] - and cl, content_mask - - mov rsi, [rsi + Cons.car] - - cmp cl, content_pointer - je incref_object - - call alloc_cons - mov [rax + Cons.typecar], BYTE cl ; masked above - mov [rax + Cons.car], rsi - mov rsi, rax - ret - - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; RDI Environment -;; -eval_ast: - mov r15, rdi ; Save Env in r15 - - ; Check the type - mov al, BYTE [rsi] - - ; Check if this is a list - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list - - cmp ah, container_map - je .map - - cmp ah, container_vector - je .vector - - ; Not a list, map or vector - cmp ah, container_symbol - je .symbol - - ; Not a symbol, list, map or vector - call incref_object ; Increment reference count - - mov rax, rsi - ret - -.symbol: - ; Check if first character of symbol is ':' - mov al, BYTE [rsi + Array.data] - cmp al, ':' - je .keyword - - ; look in environment - push rsi - xchg rsi, rdi - ; symbol is the key in rdi - ; Environment in rsi - call env_get - pop rsi - je .done ; result in RAX - - ; Not found, throw an error - push rsi - print_str_mac error_string ; print 'Error: ' - - pop rsi - push rsi - mov edx, [rsi + Array.length] - add rsi, Array.data - call print_rawstring ; print symbol - - print_str_mac not_found_string ; print ' not found' - pop rsi - - jmp error_throw - - ; ------------------------------ - -.keyword: - ; Just return keywords unaltered - call incref_object - mov rax, rsi - ret - - ; ------------------------------ -.list: - ; Evaluate each element of the list - ; - xor r8, r8 ; The list to return - ; r9 contains head of list - -.list_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .list_pointer - - ; A value in RSI, so copy - - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_list) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .list_append - -.list_pointer: - ; List element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rdi, [rsi + Cons.car] ; Get the address - mov rsi, r15 - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call incref_object ; AST increment refs - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .list_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_list + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .list_append - -.list_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_list) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - - ; Fall through to .list_append -.list_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .list_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .list_next - -.list_first: - mov r8, rax - mov r9, rax - ; fall through to .list_next - -.list_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .list_done ; finished list - mov rsi, [rsi + Cons.cdr] ; next in list - jmp .list_loop - -.list_done: - mov rax, r8 ; Return the list - ret - - ; --------------------- -.map: - ; Create a new map, evaluating all the values - - ; Check if the map is empty - cmp al, maltype_empty_map - jne .map_not_empty - - ; map empty. Just return it - call incref_object - mov rax, rsi - ret - -.map_not_empty: - - mov r10, rsi ; input in R10 - xor r12, r12 ; New map in r12 - - ; Now loop through each key-value pair - ; NOTE: This method relies on the implementation - ; of map as a list - -.map_loop: - ; Copy the key - call alloc_cons ; New Cons in RAX - - mov bl, [r10 + Cons.typecar] ; Type in BL - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] ; Value in RCX - mov [rax + Cons.car], rcx - - ; Check the type of the key - and bl, content_mask - cmp bl, content_pointer - jne .map_got_key ; a value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.map_got_key: - cmp r12,0 - jne .append_key - - ; First key - mov r12, rax - mov r13, rax - jmp .map_value - -.append_key: - ; Appending to previous value in r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - -.map_value: - ; Check that we have a value - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_error_missing_value - mov r10, [r10 + Cons.cdr] - - ; Now got value in r10 - - ; Check the type of the value - mov bl, [r10 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .map_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r10 + Cons.typecar] - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .map_got_value -.map_value_pointer: - ; A pointer, so need to evaluate - push r10 ; Input - push r12 ; start of result - push r13 ; Current head of result - push r15 ; Env - mov rsi, [r10 + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r13 - pop r12 - pop r10 - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - - jne .map_eval_pointer - - ; A value, so just change the type to a map - and bl, content_mask - add bl, (block_cons + container_map) - mov [rax], BYTE bl - jmp .map_got_value - -.map_eval_pointer: - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - -.map_got_value: - ; Append RAX to list in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - - ; Check if there's another key - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_done ; finished map - mov r10, [r10 + Cons.cdr] ; next in map - jmp .map_loop - -.map_done: - mov rax, r12 - ret - -.map_error_missing_value: - mov rax, r12 - ret - - ; ------------------------------ -.vector: - ; Evaluate each element of the vector - ; - xor r8, r8 ; The vector to return - ; r9 contains head of vector - -.vector_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .vector_pointer - - ; A value, so copy - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_vector) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .vector_append - -.vector_pointer: - ; Vector element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .vector_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_vector + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .vector_append - -.vector_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_vector) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - -.vector_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .vector_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .vector_next - -.vector_first: - mov r8, rax - mov r9, rax - ; fall through to .vector_next - -.vector_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .vector_done ; finished vector - mov rsi, [rsi + Cons.cdr] ; next in vector - jmp .vector_loop - -.vector_done: - mov rax, r8 ; Return the vector - ret - - ; --------------------- -.done: - ret - - - -;; Comparison of symbols for eval function -;; Compares the symbol in RSI with specified symbol -;; Preserves RSI and RBX -;; Modifies RDI -%macro eval_cmp_symbol 1 - push rsi - push rbx - mov rsi, rbx - mov rdi, %1 - call compare_char_array - pop rbx - pop rsi - test rax, rax ; ZF set if rax = 0 (equal) -%endmacro - -;; ---------------------------------------------------- -;; Evaluates a form -;; -;; Input: RSI AST to evaluate [ Released ] -;; RDI Environment [ Released ] -;; -;; Returns: Result in RAX -;; -;; Note: Both the form and environment will have their reference count -;; reduced by one (released). This is for tail call optimisation (Env), -;; quasiquote and macroexpand (AST) -;; -eval: - mov r15, rdi ; Env - - push rsi ; AST pushed, must be popped before return - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - and al, container_mask - cmp al, container_list - je .list - - ; Not a list. Evaluate and return - call eval_ast - jmp .return ; Releases Env - - ; -------------------- -.list: - ; A list - - ; Check if the first element is a symbol - mov al, BYTE [rsi] - - and al, content_mask - cmp al, content_pointer - jne .list_eval - - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .list_eval - - ; Is a symbol, address in RBX - - ; Compare against special form symbols - - eval_cmp_symbol def_symbol ; def! - je .def_symbol - - eval_cmp_symbol let_symbol ; let* - je .let_symbol - - eval_cmp_symbol do_symbol ; do - je .do_symbol - - eval_cmp_symbol if_symbol ; if - je .if_symbol - - eval_cmp_symbol fn_symbol ; fn - je .fn_symbol - - eval_cmp_symbol quote_symbol ; quote - je .quote_symbol - - eval_cmp_symbol quasiquoteexpand_symbol - je .quasiquoteexpand_symbol - - eval_cmp_symbol quasiquote_symbol ; quasiquote - je .quasiquote_symbol - - ; Unrecognised - jmp .list_eval - - - ; ----------------------------- - -.def_symbol: - ; Define a new symbol in current environment - - ; Next item should be a symbol - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Now should have a symbol - - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - jne .def_error_expecting_symbol - mov r8, [rsi + Cons.car] ; Symbol (?) - - mov al, BYTE [r8] - cmp al, maltype_symbol - jne .def_error_expecting_symbol - - ; R8 now contains a symbol - - ; expecting a value or pointer next - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a pointer - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .def_pointer - - ; A value, so copy - push rax - call alloc_cons - pop rbx ; BL now contains type - and bl, content_mask - add bl, (block_cons + container_value) - mov [rax], BYTE bl - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - mov rsi, rax - - jmp .def_got_value - -.def_pointer: - ; A pointer, so evaluate - - ; This may throw an error, so define a handler - - push r8 ; the symbol - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Pointer - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call incref_object ; AST increment refs - - call eval - mov rsi, rax - - pop r15 - pop r8 - -.def_got_value: - ; Symbol in R8, value in RSI - mov rdi, r8 ; key (symbol) - mov rcx, rsi ; Value - mov rsi, r15 ; Environment - call env_set - - mov rax, rcx - jmp .return - -.def_error_missing_arg: - mov rsi, def_missing_arg_string - mov rdx, def_missing_arg_string.len - jmp .def_handle_error - -.def_error_expecting_symbol: - mov rsi, def_expecting_symbol_string - mov rdx, def_expecting_symbol_string.len - jmp .def_handle_error - -.def_handle_error: - push rsi - push rdx - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - xor rsi, rsi ; no object to throw - jmp error_throw ; No return - - ; ----------------------------- -.let_symbol: - ; Create a new environment - - mov r11, rsi ; Let form in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - mov r14, rax ; New environment in R14 - - mov rsi, r15 - call release_object ; Decrement R15 ref count - - ; Second element should be the bindings - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_bindings - mov r11, [r11 + Cons.cdr] - - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .let_error_bindings_list - - mov r12, [r11 + Cons.car] ; should be bindings list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - ; Can be either a list or vector - cmp al, block_cons + container_list - je .let_bind_loop - cmp al, block_cons + container_vector - je .let_bind_loop - - ; Not a list or vector - jmp .let_error_bindings_list - -.let_bind_loop: - ; R12 now contains a list with an even number of items - ; The first should be a symbol, then a value to evaluate - - ; Get the symbol - mov al, BYTE [r12] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_symbol - - mov r13, [r12 + Cons.car] ; Symbol (?) - mov al, BYTE [r13] - cmp al, maltype_symbol - jne .let_error_bind_symbol - - ; R13 now contains a symbol to bind - ; The next item in the bindings list (R12) - ; should be a value or expression to evaluate - - mov al, BYTE [r12 + Cons.typecdr] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_value - mov r12, [r12 + Cons.cdr] - - ; got value in R12 - - ; Check the type of the value - mov bl, [r12 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .let_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r12 + Cons.typecar] - and bl, content_mask - ;or bl, (block_cons + container_value) ; 0 - mov [rax + Cons.typecar], bl - mov rcx, [r12 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .let_got_value - -.let_value_pointer: - ; A pointer, so need to evaluate - push r11 ; let* form list - push r12 ; Position in bindings list - push r13 ; symbol to bind - push r14 ; new environment - - mov rsi, r14 - call incref_object - mov rdi, r14 - - mov rsi, [r12 + Cons.car] ; Get the address - - call incref_object ; Increment ref count of AST - - call eval ; Evaluate it, result in rax - pop r14 - pop r13 - pop r12 - pop r11 - -.let_got_value: - - mov rsi, r14 ; Env - mov rdi, r13 ; key - mov rcx, rax ; value - call env_set - - ; Release the value - mov rsi, rcx ; The value - call release_object - - ; Check if there are more bindings - mov al, BYTE [r12 + Cons.typecdr] - cmp al, content_pointer - jne .let_done_binding - mov r12, [r12 + Cons.cdr] ; Next - jmp .let_bind_loop - -.let_done_binding: - ; Done bindings. - ; Evaluate next item in let* form in new environment - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_body - mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate - ; Check type of the value - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - je .body_pointer - - ; Just a value, so copy - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl ; set type - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx ; copy value - jmp .let_done - -.body_pointer: - ; Evaluate using new environment - - mov rsi, [r11 + Cons.car] ; Object pointed to - call incref_object ; will be released by eval - - mov r11, rsi ; save new AST - pop rsi ; Old AST - call release_object - mov rsi, r11 ; New AST - - mov rdi, r14 ; New environment - - jmp eval ; Tail call - ; Note: eval will release the new environment on return - -.let_done: - ; Release the new environment - push rax - mov rsi, r14 - call release_object - pop rax - - ; Release the AST - pop rsi - push rax - call release_object - pop rax - ret ; already released env - -.let_error_missing_bindings: - mov rsi, let_missing_bindings_string - mov rdx, let_missing_bindings_string.len - jmp .let_handle_error - -.let_error_bindings_list: ; expected a list or vector, got something else - mov rsi, let_bindings_list_string - mov rdx, let_bindings_list_string.len - jmp .let_handle_error - -.let_error_bind_symbol: ; expected a symbol, got something else - mov rsi, let_bind_symbol_string - mov rdx, let_bind_symbol_string.len - jmp .let_handle_error - -.let_error_bind_value: ; Missing value in binding list - mov rsi, let_bind_value_string - mov rdx, let_bind_value_string.len - jmp .let_handle_error - -.let_error_missing_body: ; Missing body to evaluate - mov rsi, let_missing_body_string - mov rdx, let_missing_body_string.len - jmp .let_handle_error - -.let_handle_error: - push r11 ; For printing later - - push rsi - push rdx - - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - pop rsi ; let* form - jmp error_throw ; No return - - ; ----------------------------- - -.do_symbol: - mov r11, rsi ; do form in RSI - ; Environment in R15 - - ; Check if there is a body - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .do_no_body ; error - - mov r11, [r11 + Cons.cdr] ; Body in R11 - -.do_symbol_loop: - - ; Need to test if this is the last form - ; so we can handle tail call - - mov bl, BYTE [r11 + Cons.typecdr] - cmp bl, content_pointer - jne .do_body_last ; Last expression - - ; not the last expression - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_next ; A value, so skip - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - ; since eval will release Env - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increment ref count since eval will release - - mov rdi, r15 ; Env - call eval ; Result in RAX - - ; Another form after this. - ; Discard the result of the last eval - mov rsi, rax - call release_object - - pop r11 - pop r15 - -.do_next: - mov r11, [r11 + Cons.cdr] ; Next in list - - jmp .do_symbol_loop - -.do_body_last: - ; The last form is in R11, which will be returned - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_body_value_return - jmp .do_body_expr_return - -.do_body_value_return: - ; Got a value as last form (in R11). - ; Copy and return - - push rax ; Type of value to return - - ; release Env - mov rsi, r15 - call release_object - - ; Allocate a Cons object to hold value - call alloc_cons - pop rbx ; type in BL - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - ; release the AST - pop rsi - mov r15, rax ; not modified by release - call release_object - mov rax, r15 - - ret - -.do_body_expr_return: - ; An expression to evaluate as the last form - ; Tail call optimise, jumping to eval - ; Don't increment Env reference count - - mov rsi, [r11 + Cons.car] ; new AST form - call incref_object ; This will be released by eval - - mov r11, rsi ; Save new AST - pop rsi ; Remove old AST from stack - call release_object - mov rsi, r11 - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.do_no_body: - ; No expressions to evaluate. Return nil - - mov rsi, r15 - call release_object ; Release Env - - ; release the AST - pop rsi - call release_object - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - ; ----------------------------- - -.if_symbol: - mov r11, rsi ; if form in R11 - ; Environment in R15 - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .if_no_condition - - mov r11, [r11 + Cons.cdr] ; Should be a condition - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .if_cond_value - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increase Form/AST ref count - - mov rdi, r15 ; Env - call eval ; Result in RAX - pop r11 - pop r15 - - ; Get type of result - mov bl, BYTE [rax] - - ; release value - push rbx - mov rsi, rax - call release_object - pop rbx - - ; Check type - cmp bl, maltype_nil - je .if_false - cmp bl, maltype_false - je .if_false - - jmp .if_true - -.if_cond_value: - - ; A value - cmp al, content_nil - je .if_false - cmp al, content_false - je .if_false - - jmp .if_true - -.if_false: - ; Skip the next item - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil - - mov r11, [r11 + Cons.cdr] - -.if_true: - ; Get the next item in the list and evaluate it - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; Nothing to return - - mov r11, [r11 + Cons.cdr] - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - je .if_got_pointer - -.if_got_value: - ; copy value in r11 - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - jmp .return - -.if_got_pointer: - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Will be released by eval - - mov r11, rsi - pop rsi - call release_object ; Release old AST - mov rsi, r11 ; New AST - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.if_no_condition: ; just (if) without a condition - - print_str_mac error_string - print_str_mac if_missing_condition_string - - ; Release environment - mov rsi, r15 - call release_object - xor rsi, rsi ; No object to throw - jmp error_throw - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - -.return: - ; Release environment - mov rsi, r15 - mov r15, rax ; Save RAX (return value) - call release_object - - ; Release the AST - pop rsi ; Pushed at start of eval - call release_object - - mov rax, r15 ; return value - ret - - ; ----------------------------- - -.fn_symbol: - mov r11, rsi ; fn form in R11 - ; Environment in R15 - - ; Get the binds and body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_empty - - mov r11, [r11 + Cons.cdr] - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_binds_not_list - - mov r12, [r11 + Cons.car] ; Should be binds list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - cmp al, (block_cons + container_list) - je .fn_got_binds ; Can be list - cmp al, (block_cons + container_vector) - je .fn_got_binds ; or vector - jmp .fn_binds_not_list - -.fn_got_binds: - - ; Next get the body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_no_body - - mov r11, [r11 + Cons.cdr] - ; Check value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_is_value ; Body in r11 - mov r11, [r11 + Cons.car] - jmp .fn_got_body - -.fn_is_value: - ; Body is just a value, no expression - mov [r11], BYTE al ; Mark as value, not list - -.fn_got_body: - - ; Now put into function type - ; Addr is "apply_fn", the address to call - ; Env in R15 - ; Binds in R12 - ; Body in R11 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_function) - mov rbx, apply_fn - mov [rax + Cons.car], rbx ; Address of apply function - mov [rax + Cons.typecdr], BYTE content_pointer - - mov r13, rax ; Return list in R13 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r15 ; Environment - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r13 + Cons.cdr], rax ; Append to list - mov r14, rax ; R14 contains last cons in list - - push rax - mov rsi, r15 - call incref_object - pop rax - - ; Binds - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r12 ; Binds list - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r14 + Cons.cdr], rax ; Append to list - mov r14, rax - - push rax - mov rsi, r12 - call incref_object - pop rax - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r11 ; Body of function - - mov [r14 + Cons.cdr], rax - - mov rsi, r11 - call incref_object - - mov rax, r13 - jmp .return - -.fn_empty: -.fn_binds_not_list: -.fn_no_body: - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - jmp .return - - ; ----------------------------- - -.quote_symbol: - ; Just return the arguments in rsi cdr - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; quote empty, so return nil - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .quote_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.quote_pointer: - ; RSI contains a pointer, so get the object pointed to - mov rsi, [rsi + Cons.car] - call incref_object - mov rax, rsi - jmp .return - - ; ----------------------------- - -;;; Like quasiquote, but do not evaluate the result. -.quasiquoteexpand_symbol: - ;; Return nil if no cdr - mov cl, BYTE [rsi + Cons.typecdr] - cmp cl, content_pointer - jne .return_nil - - mov rsi, [rsi + Cons.cdr] - call car_and_incref - call quasiquote - jmp .return - - ; ----------------------------- - -.quasiquote_symbol: - ; call quasiquote function with first argument - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; quasiquote empty, so return nil - - mov r11, rsi ; Save original AST in R11 - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .quasiquote_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.quasiquote_pointer: - ; RSI contains a pointer, so get the object pointed to - mov rsi, [rsi + Cons.car] - - push r15 ; Environment - ; Original AST already on stack - - call quasiquote - ; New AST in RAX - pop rdi ; Environment - pop rsi ; Old AST - - mov r11, rax ; New AST - call release_object ; Release old AST - mov rsi, r11 ; New AST in RSI - - jmp eval ; Tail call - - ; ----------------------------- - -.list_eval: - push rsi - mov rdi, r15 ; Environment - push r15 - call eval_ast ; List of evaluated forms in RAX - pop r15 - pop rsi - -.list_exec: - ; This point can be called to run a function - ; used by swap! - ; - ; Inputs: RAX - List with function as first element - ; NOTE: This list is released - ; - ; Check that the first element of the return is a function - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .list_not_function - - mov rbx, [rax + Cons.car] ; Get the address - mov cl, BYTE [rbx] - cmp cl, maltype_function - jne .list_not_function - - ; Check the rest of the args - mov cl, BYTE [rax + Cons.typecdr] - cmp cl, content_pointer - je .list_got_args - - ; No arguments - push rbx ; Function object - push rax ; List with function first - - ; Create an empty list for the arguments - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax ; Argument list into RSI - - pop rax ; list, function first - ;; Put new empty list onto end of original list - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rsi - - pop rbx - jmp .list_function_call -.list_got_args: - mov rsi, [rax + Cons.cdr] ; Rest of list -.list_function_call: - ; Call the function with the rest of the list in RSI - - mov rdx, rax ; List to release - mov rdi, rbx ; Function object in RDI - - mov rbx, [rbx + Cons.car] ; Call function - cmp rbx, apply_fn - je apply_fn_jmp ; Jump to user function apply - - ; A built-in function, so call (no recursion) - push rax - push r15 - - call rbx - - ; Result in rax - pop r15 - pop rsi ; eval'ed list - - push rax - call release_cons - pop rax - jmp .return ; Releases Env - -.list_not_function: - ; Not a function. Probably an error - push rsi - - mov rsi, rax - call release_object - - print_str_mac error_string - print_str_mac eval_list_not_function - pop rsi - jmp error_throw - -.empty_list: - mov rax, rsi - jmp .return - -;; Applies a user-defined function -;; -;; Input: RSI - Arguments to bind -;; RDI - Function object -;; RDX - list to release after binding -;; R15 - Env (will be released) -;; R13 - AST released before return -;; -;; -;; Output: Result in RAX -;; -;; This is jumped to from eval, so if it returns -;; then it will return to the caller of eval, not to eval -apply_fn_jmp: - ; This is jumped to from eval with AST on the stack - pop r13 -apply_fn: - push rsi - ; Extract values from the list in RDI - mov rax, [rdi + Cons.cdr] - mov rsi, [rax + Cons.car] ; Env - mov rax, [rax + Cons.cdr] - mov rdi, [rax + Cons.car] ; Binds - mov rax, [rax + Cons.cdr] - mov rax, [rax + Cons.car] ; Body - pop rcx ; Exprs - - ; Check the type of the body - mov bl, BYTE [rax] - and bl, block_mask + container_mask - jnz .bind - ; Just a value (in RAX). No eval needed - - mov r14, rax ; Save return value in R14 - - mov rsi, rax - call incref_object - - ; Release the list passed in RDX - mov rsi, rdx - call release_object - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the AST - mov rsi, r13 - call release_object - - mov rax, r14 - ret -.bind: - ; Create a new environment, binding arguments - push rax ; Body - - mov r14, r13 ; Old AST. R13 used by env_new_bind - - push rdx - call env_new_bind - pop rdx - - mov rdi, rax ; New environment in RDI - - ; Note: Need to increment the reference count - ; of the function body before releasing anything, - ; since if the function was defined in-place (lambda) - ; then the body may be released early - - pop rsi ; Body - call incref_object ; Will be released by eval - mov r8, rsi ; Body in R8 - - ; Release the list passed in RDX - mov rsi, rdx - call release_cons - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the old AST - mov rsi, r14 - call release_object - - mov rsi, r8 ; Body - - jmp eval ; Tail call - ; The new environment (in RDI) will be released by eval - - -;;; Called by eval -;;; Original AST in RSI. -;;; Returns new AST in RAX -quasiquote: - ;; Dispatch on the type. - mov al, BYTE [rsi + Cons.typecar] - mov cl, al ; keep full al for .list - and cl, container_mask - cmp cl, container_list - je .list - cmp cl, container_map - je .map - cmp cl, container_symbol - je .symbol - cmp cl, container_vector - je .vector - ;; return other types unchanged - call incref_object - mov rax, rsi - ret - -.list: - ;; AST is a list, process it with qq_foldr unless.. - mov cl, al ; it is not empty, - and cl, content_mask - cmp cl, content_empty - je qq_foldr - - cmp cl, content_pointer ; and it is a pointer, - jne qq_foldr - - mov rdi, [rsi + Cons.car] ; and the first element is a symbol, - mov cl, BYTE [rdi + Cons.typecar] - cmp cl, maltype_symbol - jne qq_foldr - - mov r8, rsi ; and the symbol is 'unquote, - mov rsi, unquote_symbol - call compare_char_array - test rax, rax - mov rsi, r8 - jne qq_foldr - - mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. - cmp cl, content_pointer - jne qq_foldr - - ;; If so, return the argument. - mov rsi, [rsi + Cons.cdr] - call car_and_incref - mov rax, rsi - ret - -.map: -.symbol: - call incref_object - - ;; rdx := (ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rsi - mov rdx, rax - - mov rsi, quote_symbol - call incref_object - - ;; rax := ('quote ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - -.vector: - ;; rdx := ast processed like a list - call qq_foldr - mov rdx, rax - - ;; rdx := (processed_ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdx - mov rdx, rax - - mov rsi, vec_symbol - call incref_object - - ;; rax := ('vec processed_ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - - -;;; Helper for quasiquote. -;;; RSI must contain a list or vector, which may be empty. -;;; The result in RAX is always a list. -;;; Iterate on the elements in the right fold/reduce style. -qq_foldr: - mov cl, BYTE [rsi + Cons.typecar] - - cmp cl, maltype_empty_list - je .empty_list - - cmp cl, maltype_empty_vector - je .empty_vector - - ;; Extract first element and store it into the stack during - ;; the recursion. - mov rdx, rsi - call car_and_incref - push rsi - mov rsi, rdx - - ;; Extract the rest of the list. - mov al, BYTE [rsi + Cons.typecdr] - -;;; If the rest is not empty - cmp al, content_pointer - jne .else -;;; then - mov rsi, [rsi + Cons.cdr] - jmp .endif -.else: - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax -.endif: - call qq_foldr ; recursive call - pop rsi - jmp qq_loop - -.empty_list: ;; () -> () - call incref_object - mov rax, rsi - ret - -.empty_vector: ;; [] -> () - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - - -;; Helper for quasiquote -;; The transition function starts here. -;; Current element is in rsi, accumulator in rax. -qq_loop: - mov r9, rax - - ;; Process with the element with .default, unless.. - mov cl, BYTE [rsi + Cons.typecar] ; it is a list - mov al, cl - and al, container_mask - cmp al, container_list - jne .default - - cmp cl, maltype_empty_list ; it is not empty, - je .default - - and cl, content_mask ; and it is a pointer, - cmp cl, content_pointer - jne .default - - mov rdi, [rsi + Cons.car] ; and the first element is a symbol, - mov cl, BYTE [rdi + Cons.typecar] - cmp cl, maltype_symbol - jne .default - - mov r8, rsi ; and the symbol is 'splice-unquote, - mov rsi, splice_unquote_symbol - call compare_char_array - test rax, rax - mov rsi, r8 - jne .default - - mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. - cmp cl, content_pointer - jne .default - - ;; If so, return ('concat elt acc). - mov rsi, [rsi + Cons.cdr] - call car_and_incref - - ;; rdx := (acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.car], r9 - mov rdx, rax - - ;; rdx := (elt acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - mov rdx, rax - - mov rsi, concat_symbol - call incref_object - - ;; rax := ('concat elt acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - -.default: - ;; rax := (accumulator) - call alloc_cons - mov [rax + Cons.typecar], BYTE (container_list + content_pointer) - mov [rax + Cons.car], r9 - - ;; rcx := quasiquoted_element - ;; rdx := (accumulator) - push rax - call quasiquote - mov rcx, rax - pop rdx - - ;; rdx := (quasiquoted_element accumulator) - call alloc_cons - mov [rax + Cons.typecar], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rcx - mov [rax + Cons.cdr], rdx - mov rdx, rax - - mov rsi, cons_symbol - call incref_object - - ;; rax := ('cons quasiquoted_elt accumulator) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - - -;; Read and eval -read_eval: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - jmp eval ; This releases Env and Form/AST - - -;; Read-Eval-Print in sequence -;; -;; Input string in RSI -rep_seq: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call eval ; This releases Env and Form/AST - push rax ; Save result of eval - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - mov rdi, 1 ; print readably - call pr_str ; String in RAX - - mov r8, rax ; Save output - - pop rsi ; Result from eval - call release_object - mov rax, r8 - - ret - - -_start: - ; Create and print the core environment - call core_environment ; Environment in RAX - - mov [repl_env], rax ; store in memory - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; Evaluate the startup string - - mov rsi, mal_startup_string - mov edx, mal_startup_string.len - call raw_to_string ; String in RAX - - push rax - mov rsi, rax - call read_str ; AST in RAX - pop rsi ; string - - push rax ; AST - call release_array ; string - pop rdi ; AST in RDI - - mov rsi, [repl_env] ; Environment in RSI - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call eval - - mov rsi, rax - call release_object ; Return from eval - - ; ----------------------------- - ; Check command-line arguments - - pop rax ; Number of arguments - cmp rax, 1 ; Always have at least one, the path to executable - jg run_script - - ; No extra arguments, so just set *ARGV* to an empty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov rcx, rax ; value (empty list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - -.catch: - ; Jumps here on error - - ; Check if an object was thrown - cmp rsi, 0 - je .catch_done_print ; nothing to print - mov rdi, 1 - call pr_str - mov rsi, rax - call print_string -.catch_done_print: - jmp .mainLoop ; Go back to the prompt - - - -run_script: - ; Called with number of command-line arguments in RAX - mov r8, rax - pop rbx ; executable - dec r8 - - pop rsi ; Address of first arg - call cstring_to_string ; string in RAX - mov r9, rax - - ; get the rest of the args - xor r10, r10 ; Zero - dec r8 - jz .no_args - - ; Got some arguments -.arg_loop: - ; Got an argument left. - pop rsi ; Address of C string - call cstring_to_string ; String in RAX - mov r12, rax - - ;Make a Cons to point to the string - call alloc_cons ; in RAX - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], r12 - - test r10, r10 - jnz .append - - ; R10 zero, so first arg - mov r10, rax ; Head of list - mov r11, rax ; Tail of list - jmp .next -.append: - ; R10 not zero, so append to list tail - mov [r11 + Cons.cdr], rax - mov [r11 + Cons.typecdr], BYTE content_pointer - mov r11, rax -.next: - dec r8 - jnz .arg_loop - jmp .got_args - -.no_args: - ; No arguments. Create an emoty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov r10, rax - -.got_args: - push r9 ; File name string - - mov rcx, r10 ; value (list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - mov rsi, run_script_string ; load-file function - mov edx, run_script_string.len - call raw_to_string ; String in RAX - - mov rsi, rax - pop rdx ; File name string - call string_append_string - - mov cl, 34 ; " - call string_append_char - mov cl, ')' - call string_append_char ; closing brace - - ; Read-Eval "(load-file )" - call read_eval - - jmp quit +;; +;; nasm -felf64 step7_quote.asm && ld step7_quote.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + + static_symbol argv_symbol, '*ARGV*' + + static_symbol quote_symbol, 'quote' + static_symbol quasiquote_symbol, 'quasiquote' + static_symbol quasiquoteexpand_symbol, 'quasiquoteexpand' + static_symbol unquote_symbol, 'unquote' + static_symbol splice_unquote_symbol, 'splice-unquote' + static_symbol concat_symbol, 'concat' + static_symbol cons_symbol, 'cons' + static_symbol vec_symbol, 'vec' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do \ +(def! not (fn* (a) (if a false true))) \ +(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ +)" + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 +section .text + + +;;; Extract the car of a Cons and increment its reference count. +;;; If it was value, create a fresh copy. +;;; in : rsi (which must be a pointer!) +;;; out : rsi +;;; modified: : cl, rax, rbx +car_and_incref: + mov cl, BYTE [rsi + Cons.typecar] + and cl, content_mask + + mov rsi, [rsi + Cons.car] + + cmp cl, content_pointer + je incref_object + + call alloc_cons + mov [rax + Cons.typecar], BYTE cl ; masked above + mov [rax + Cons.car], rsi + mov rsi, rax + ret + + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] +;; +;; Returns: Result in RAX +;; +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) +;; +eval: + mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Check if the first element is a symbol + mov al, BYTE [rsi] + + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + eval_cmp_symbol quote_symbol ; quote + je .quote_symbol + + eval_cmp_symbol quasiquoteexpand_symbol + je .quasiquoteexpand_symbol + + eval_cmp_symbol quasiquote_symbol ; quasiquote + je .quasiquote_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.def_symbol: + ; Define a new symbol in current environment + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs + + call eval + mov rsi, rax + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + ; release the AST + pop rsi + call release_object + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + ; Release environment + mov rsi, r15 + mov r15, rax ; Save RAX (return value) + call release_object + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax ; R14 contains last cons in list + + push rax + mov rsi, r15 + call incref_object + pop rax + + ; Binds + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + ; ----------------------------- + +.quote_symbol: + ; Just return the arguments in rsi cdr + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quote empty, so return nil + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + jmp .return + + ; ----------------------------- + +;;; Like quasiquote, but do not evaluate the result. +.quasiquoteexpand_symbol: + ;; Return nil if no cdr + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .return_nil + + mov rsi, [rsi + Cons.cdr] + call car_and_incref + call quasiquote + jmp .return + + ; ----------------------------- + +.quasiquote_symbol: + ; call quasiquote function with first argument + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quasiquote empty, so return nil + + mov r11, rsi ; Save original AST in R11 + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quasiquote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quasiquote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + + push r15 ; Environment + ; Original AST already on stack + + call quasiquote + ; New AST in RAX + pop rdi ; Environment + pop rsi ; Old AST + + mov r11, rax ; New AST + call release_object ; Release old AST + mov rsi, r11 ; New AST in RSI + + jmp eval ; Tail call + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx ; Function object + push rax ; List with function first + + ; Create an empty list for the arguments + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax ; Argument list into RSI + + pop rax ; list, function first + ;; Put new empty list onto end of original list + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rsi + + pop rbx + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn_jmp ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + +.empty_list: + mov rax, rsi + jmp .return + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; R13 - AST released before return +;; +;; +;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + mov r14, rax ; Save return value in R14 + + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the AST + mov rsi, r13 + call release_object + + mov rax, r14 + ret +.bind: + ; Create a new environment, binding arguments + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + + ; Release the list passed in RDX + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;;; Called by eval +;;; Original AST in RSI. +;;; Returns new AST in RAX +quasiquote: + ;; Dispatch on the type. + mov al, BYTE [rsi + Cons.typecar] + mov cl, al ; keep full al for .list + and cl, container_mask + cmp cl, container_list + je .list + cmp cl, container_map + je .map + cmp cl, container_symbol + je .symbol + cmp cl, container_vector + je .vector + ;; return other types unchanged + call incref_object + mov rax, rsi + ret + +.list: + ;; AST is a list, process it with qq_foldr unless.. + mov cl, al ; it is not empty, + and cl, content_mask + cmp cl, content_empty + je qq_foldr + + cmp cl, content_pointer ; and it is a pointer, + jne qq_foldr + + mov rdi, [rsi + Cons.car] ; and the first element is a symbol, + mov cl, BYTE [rdi + Cons.typecar] + cmp cl, maltype_symbol + jne qq_foldr + + mov r8, rsi ; and the symbol is 'unquote, + mov rsi, unquote_symbol + call compare_char_array + test rax, rax + mov rsi, r8 + jne qq_foldr + + mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. + cmp cl, content_pointer + jne qq_foldr + + ;; If so, return the argument. + mov rsi, [rsi + Cons.cdr] + call car_and_incref + mov rax, rsi + ret + +.map: +.symbol: + call incref_object + + ;; rdx := (ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rsi + mov rdx, rax + + mov rsi, quote_symbol + call incref_object + + ;; rax := ('quote ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + +.vector: + ;; rdx := ast processed like a list + call qq_foldr + mov rdx, rax + + ;; rdx := (processed_ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdx + mov rdx, rax + + mov rsi, vec_symbol + call incref_object + + ;; rax := ('vec processed_ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + + +;;; Helper for quasiquote. +;;; RSI must contain a list or vector, which may be empty. +;;; The result in RAX is always a list. +;;; Iterate on the elements in the right fold/reduce style. +qq_foldr: + mov cl, BYTE [rsi + Cons.typecar] + + cmp cl, maltype_empty_list + je .empty_list + + cmp cl, maltype_empty_vector + je .empty_vector + + ;; Extract first element and store it into the stack during + ;; the recursion. + mov rdx, rsi + call car_and_incref + push rsi + mov rsi, rdx + + ;; Extract the rest of the list. + mov al, BYTE [rsi + Cons.typecdr] + +;;; If the rest is not empty + cmp al, content_pointer + jne .else +;;; then + mov rsi, [rsi + Cons.cdr] + jmp .endif +.else: + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax +.endif: + call qq_foldr ; recursive call + pop rsi + jmp qq_loop + +.empty_list: ;; () -> () + call incref_object + mov rax, rsi + ret + +.empty_vector: ;; [] -> () + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + + +;; Helper for quasiquote +;; The transition function starts here. +;; Current element is in rsi, accumulator in rax. +qq_loop: + mov r9, rax + + ;; Process with the element with .default, unless.. + mov cl, BYTE [rsi + Cons.typecar] ; it is a list + mov al, cl + and al, container_mask + cmp al, container_list + jne .default + + cmp cl, maltype_empty_list ; it is not empty, + je .default + + and cl, content_mask ; and it is a pointer, + cmp cl, content_pointer + jne .default + + mov rdi, [rsi + Cons.car] ; and the first element is a symbol, + mov cl, BYTE [rdi + Cons.typecar] + cmp cl, maltype_symbol + jne .default + + mov r8, rsi ; and the symbol is 'splice-unquote, + mov rsi, splice_unquote_symbol + call compare_char_array + test rax, rax + mov rsi, r8 + jne .default + + mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. + cmp cl, content_pointer + jne .default + + ;; If so, return ('concat elt acc). + mov rsi, [rsi + Cons.cdr] + call car_and_incref + + ;; rdx := (acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], r9 + mov rdx, rax + + ;; rdx := (elt acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + mov rdx, rax + + mov rsi, concat_symbol + call incref_object + + ;; rax := ('concat elt acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + +.default: + ;; rax := (accumulator) + call alloc_cons + mov [rax + Cons.typecar], BYTE (container_list + content_pointer) + mov [rax + Cons.car], r9 + + ;; rcx := quasiquoted_element + ;; rdx := (accumulator) + push rax + call quasiquote + mov rcx, rax + pop rdx + + ;; rdx := (quasiquoted_element accumulator) + call alloc_cons + mov [rax + Cons.typecar], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rcx + mov [rax + Cons.cdr], rdx + mov rdx, rax + + mov rsi, cons_symbol + call incref_object + + ;; rax := ('cons quasiquoted_elt accumulator) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + + +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + mov rax, r8 + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call eval + + mov rsi, rax + call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval "(load-file )" + call read_eval + + jmp quit diff --git a/impls/nasm/step8_macros.asm b/impls/nasm/step8_macros.asm index ba4ee89705..98e3887a81 100644 --- a/impls/nasm/step8_macros.asm +++ b/impls/nasm/step8_macros.asm @@ -1,2295 +1,2295 @@ -;; -;; nasm -felf64 step8_macros.asm && ld step8_macros.o && ./a.out -;; -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "env.asm" ; Environment type -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "core.asm" ; Core functions -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .bss - -;; Top-level (REPL) environment -repl_env:resq 1 - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - - static error_string, db 27,'[31m',"Error",27,'[0m',": " - - static not_found_string, db " not found" - - static def_missing_arg_string, db "missing argument to def!",10 - - static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 - - static defmacro_expecting_function_string, db "defmacro expects function",10 - - static let_missing_bindings_string, db "let* missing bindings",10 - - static let_bindings_list_string, db "let* expected a list or vector of bindings",10 - - static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 - - static let_bind_value_string, db "let* missing value in bindings list",10 - - static let_missing_body_string, db "let* missing body",10 - static eval_list_not_function, db "list does not begin with a function",10 - - static if_missing_condition_string, db "missing condition in if expression",10 - -;; Symbols used for comparison - - static_symbol def_symbol, 'def!' - static_symbol let_symbol, 'let*' - static_symbol do_symbol, 'do' - static_symbol if_symbol, 'if' - static_symbol fn_symbol, 'fn*' - static_symbol defmacro_symbol, 'defmacro!' - static_symbol macroexpand_symbol, 'macroexpand' - - static_symbol argv_symbol, '*ARGV*' - - static_symbol quote_symbol, 'quote' - static_symbol quasiquote_symbol, 'quasiquote' - static_symbol quasiquoteexpand_symbol, 'quasiquoteexpand' - static_symbol unquote_symbol, 'unquote' - static_symbol splice_unquote_symbol, 'splice-unquote' - static_symbol concat_symbol, 'concat' - static_symbol cons_symbol, 'cons' - static_symbol vec_symbol, 'vec' - -;; Startup string. This is evaluated on startup - static mal_startup_string, db "(do \ -(def! not (fn* (a) (if a false true))) \ -(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ -(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) \ -)" - -;; Command to run, appending the name of the script to run - static run_script_string, db "(load-file ",34 -section .text - - -;;; Extract the car of a Cons and increment its reference count. -;;; If it was value, create a fresh copy. -;;; in : rsi (which must be a pointer!) -;;; out : rsi -;;; modified: : cl, rax, rbx -car_and_incref: - mov cl, BYTE [rsi + Cons.typecar] - and cl, content_mask - - mov rsi, [rsi + Cons.car] - - cmp cl, content_pointer - je incref_object - - call alloc_cons - mov [rax + Cons.typecar], BYTE cl ; masked above - mov [rax + Cons.car], rsi - mov rsi, rax - ret - - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; RDI Environment -;; -eval_ast: - mov r15, rdi ; Save Env in r15 - - ; Check the type - mov al, BYTE [rsi] - - ; Check if this is a list - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list - - cmp ah, container_map - je .map - - cmp ah, container_vector - je .vector - - ; Not a list, map or vector - cmp ah, container_symbol - je .symbol - - ; Not a symbol, list, map or vector - call incref_object ; Increment reference count - - mov rax, rsi - ret - -.symbol: - ; Check if first character of symbol is ':' - mov al, BYTE [rsi + Array.data] - cmp al, ':' - je .keyword - - ; look in environment - push rsi - xchg rsi, rdi - ; symbol is the key in rdi - ; Environment in rsi - call env_get - pop rsi - je .done ; result in RAX - - ; Not found, throw an error - push rsi - print_str_mac error_string ; print 'Error: ' - - pop rsi - push rsi - mov edx, [rsi + Array.length] - add rsi, Array.data - call print_rawstring ; print symbol - - print_str_mac not_found_string ; print ' not found' - pop rsi - - jmp error_throw - - ; ------------------------------ - -.keyword: - ; Just return keywords unaltered - call incref_object - mov rax, rsi - ret - - ; ------------------------------ -.list: - ; Evaluate each element of the list - ; - xor r8, r8 ; The list to return - ; r9 contains head of list - -.list_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .list_pointer - - ; A value in RSI, so copy - - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_list) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .list_append - -.list_pointer: - ; List element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rdi, [rsi + Cons.car] ; Get the address - mov rsi, r15 - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call incref_object ; AST increment refs - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .list_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_list + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .list_append - -.list_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_list) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - - ; Fall through to .list_append -.list_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .list_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .list_next - -.list_first: - mov r8, rax - mov r9, rax - ; fall through to .list_next - -.list_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .list_done ; finished list - mov rsi, [rsi + Cons.cdr] ; next in list - jmp .list_loop - -.list_done: - mov rax, r8 ; Return the list - ret - - ; --------------------- -.map: - ; Create a new map, evaluating all the values - - ; Check if the map is empty - cmp al, maltype_empty_map - jne .map_not_empty - - ; map empty. Just return it - call incref_object - mov rax, rsi - ret - -.map_not_empty: - - mov r10, rsi ; input in R10 - xor r12, r12 ; New map in r12 - - ; Now loop through each key-value pair - ; NOTE: This method relies on the implementation - ; of map as a list - -.map_loop: - ; Copy the key - call alloc_cons ; New Cons in RAX - - mov bl, [r10 + Cons.typecar] ; Type in BL - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] ; Value in RCX - mov [rax + Cons.car], rcx - - ; Check the type of the key - and bl, content_mask - cmp bl, content_pointer - jne .map_got_key ; a value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.map_got_key: - cmp r12,0 - jne .append_key - - ; First key - mov r12, rax - mov r13, rax - jmp .map_value - -.append_key: - ; Appending to previous value in r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - -.map_value: - ; Check that we have a value - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_error_missing_value - mov r10, [r10 + Cons.cdr] - - ; Now got value in r10 - - ; Check the type of the value - mov bl, [r10 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .map_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r10 + Cons.typecar] - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .map_got_value -.map_value_pointer: - ; A pointer, so need to evaluate - push r10 ; Input - push r12 ; start of result - push r13 ; Current head of result - push r15 ; Env - mov rsi, [r10 + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r13 - pop r12 - pop r10 - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - - jne .map_eval_pointer - - ; A value, so just change the type to a map - and bl, content_mask - add bl, (block_cons + container_map) - mov [rax], BYTE bl - jmp .map_got_value - -.map_eval_pointer: - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - -.map_got_value: - ; Append RAX to list in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - - ; Check if there's another key - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_done ; finished map - mov r10, [r10 + Cons.cdr] ; next in map - jmp .map_loop - -.map_done: - mov rax, r12 - ret - -.map_error_missing_value: - mov rax, r12 - ret - - ; ------------------------------ -.vector: - ; Evaluate each element of the vector - ; - xor r8, r8 ; The vector to return - ; r9 contains head of vector - -.vector_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .vector_pointer - - ; A value, so copy - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_vector) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .vector_append - -.vector_pointer: - ; Vector element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .vector_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_vector + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .vector_append - -.vector_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_vector) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - -.vector_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .vector_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .vector_next - -.vector_first: - mov r8, rax - mov r9, rax - ; fall through to .vector_next - -.vector_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .vector_done ; finished vector - mov rsi, [rsi + Cons.cdr] ; next in vector - jmp .vector_loop - -.vector_done: - mov rax, r8 ; Return the vector - ret - - ; --------------------- -.done: - ret - - - -;; Comparison of symbols for eval function -;; Compares the symbol in RSI with specified symbol -;; Preserves RSI and RBX -;; Modifies RDI -%macro eval_cmp_symbol 1 - push rsi - push rbx - mov rsi, rbx - mov rdi, %1 - call compare_char_array - pop rbx - pop rsi - test rax, rax ; ZF set if rax = 0 (equal) -%endmacro - -;; ---------------------------------------------------- -;; Evaluates a form -;; -;; Input: RSI AST to evaluate [ Released ] -;; RDI Environment [ Released ] -;; -;; Returns: Result in RAX -;; -;; Note: Both the form and environment will have their reference count -;; reduced by one (released). This is for tail call optimisation (Env), -;; quasiquote and macroexpand (AST) -;; -eval: - mov r15, rdi ; Env - - push rsi ; AST pushed, must be popped before return - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - and al, container_mask - cmp al, container_list - je .list - - ; Not a list. Evaluate and return - call eval_ast - jmp .return ; Releases Env - - ; -------------------- -.list: - ; A list - - ; Macro expand - pop rax ; Old AST, discard from stack - call macroexpand ; Replaces RSI - push rsi ; New AST - - ; Check if RSI is a list, and if - ; the first element is a symbol - mov al, BYTE [rsi] - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list_still_list - - ; Not a list, so call eval_ast on it - mov rdi, r15 ; Environment - call eval_ast - jmp .return - -.list_still_list: - and al, content_mask - cmp al, content_pointer - jne .list_eval - - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .list_eval - - ; Is a symbol, address in RBX - - ; Compare against special form symbols - - eval_cmp_symbol def_symbol ; def! - je .def_symbol - - eval_cmp_symbol let_symbol ; let* - je .let_symbol - - eval_cmp_symbol do_symbol ; do - je .do_symbol - - eval_cmp_symbol if_symbol ; if - je .if_symbol - - eval_cmp_symbol fn_symbol ; fn - je .fn_symbol - - eval_cmp_symbol quote_symbol ; quote - je .quote_symbol - - eval_cmp_symbol quasiquoteexpand_symbol - je .quasiquoteexpand_symbol - - eval_cmp_symbol quasiquote_symbol ; quasiquote - je .quasiquote_symbol - - eval_cmp_symbol defmacro_symbol ; defmacro! - je .defmacro_symbol - - eval_cmp_symbol macroexpand_symbol ; macroexpand - je .macroexpand_symbol - - ; Unrecognised - jmp .list_eval - - - ; ----------------------------- - -.defmacro_symbol: - mov r9, 1 - jmp .def_common -.def_symbol: - xor r9, r9 ; Set R9 to 0 -.def_common: - ; Define a new symbol in current environment - ; If R9 is set to 1 then defmacro - - ; Next item should be a symbol - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Now should have a symbol - - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - jne .def_error_expecting_symbol - mov r8, [rsi + Cons.car] ; Symbol (?) - - mov al, BYTE [r8] - cmp al, maltype_symbol - jne .def_error_expecting_symbol - - ; R8 now contains a symbol - - ; expecting a value or pointer next - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a pointer - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .def_pointer - - ; A value, so copy - - ; Test if this is defmacro! - test r9, r9 - jnz .defmacro_not_function - - push rax - call alloc_cons - pop rbx ; BL now contains type - and bl, content_mask - add bl, (block_cons + container_value) - mov [rax], BYTE bl - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - mov rsi, rax - - jmp .def_got_value - -.def_pointer: - ; A pointer, so evaluate - - ; This may throw an error, so define a handler - - push r8 ; the symbol - push r15 ; Env - push r9 - mov rsi, [rsi + Cons.car] ; Pointer - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call incref_object ; AST increment refs - - call eval - mov rsi, rax - - pop r9 - - ; If this is defmacro, and the object in RSI is a function, - ; then change to a macro - test r9, r9 - jz .def_not_macro ; Not defmacro - - ; Check RSI - mov al, BYTE [rsi] - cmp al, maltype_function - jne .defmacro_not_function - - ; Got a function, change to macro - mov [rsi], BYTE maltype_macro - -.def_not_macro: - - pop r15 - pop r8 - -.def_got_value: - ; Symbol in R8, value in RSI - mov rdi, r8 ; key (symbol) - mov rcx, rsi ; Value - mov rsi, r15 ; Environment - call env_set - - mov rax, rcx - jmp .return - -.def_error_missing_arg: - mov rsi, def_missing_arg_string - mov rdx, def_missing_arg_string.len - jmp .def_handle_error - -.def_error_expecting_symbol: - mov rsi, def_expecting_symbol_string - mov rdx, def_expecting_symbol_string.len - jmp .def_handle_error - -.defmacro_not_function: - mov rsi, defmacro_expecting_function_string - mov rdx, defmacro_expecting_function_string.len - jmp .def_handle_error - -.def_handle_error: - push rsi - push rdx - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - xor rsi, rsi ; no object to throw - jmp error_throw ; No return - - ; ----------------------------- -.let_symbol: - ; Create a new environment - - mov r11, rsi ; Let form in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - mov r14, rax ; New environment in R14 - - mov rsi, r15 - call release_object ; Decrement R15 ref count - - ; Second element should be the bindings - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_bindings - mov r11, [r11 + Cons.cdr] - - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .let_error_bindings_list - - mov r12, [r11 + Cons.car] ; should be bindings list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - ; Can be either a list or vector - cmp al, block_cons + container_list - je .let_bind_loop - cmp al, block_cons + container_vector - je .let_bind_loop - - ; Not a list or vector - jmp .let_error_bindings_list - -.let_bind_loop: - ; R12 now contains a list with an even number of items - ; The first should be a symbol, then a value to evaluate - - ; Get the symbol - mov al, BYTE [r12] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_symbol - - mov r13, [r12 + Cons.car] ; Symbol (?) - mov al, BYTE [r13] - cmp al, maltype_symbol - jne .let_error_bind_symbol - - ; R13 now contains a symbol to bind - ; The next item in the bindings list (R12) - ; should be a value or expression to evaluate - - mov al, BYTE [r12 + Cons.typecdr] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_value - mov r12, [r12 + Cons.cdr] - - ; got value in R12 - - ; Check the type of the value - mov bl, [r12 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .let_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r12 + Cons.typecar] - and bl, content_mask - ;or bl, (block_cons + container_value) ; 0 - mov [rax + Cons.typecar], bl - mov rcx, [r12 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .let_got_value - -.let_value_pointer: - ; A pointer, so need to evaluate - push r11 ; let* form list - push r12 ; Position in bindings list - push r13 ; symbol to bind - push r14 ; new environment - - mov rsi, r14 - call incref_object - mov rdi, r14 - - mov rsi, [r12 + Cons.car] ; Get the address - - call incref_object ; Increment ref count of AST - - call eval ; Evaluate it, result in rax - pop r14 - pop r13 - pop r12 - pop r11 - -.let_got_value: - - mov rsi, r14 ; Env - mov rdi, r13 ; key - mov rcx, rax ; value - call env_set - - ; Release the value - mov rsi, rcx ; The value - call release_object - - ; Check if there are more bindings - mov al, BYTE [r12 + Cons.typecdr] - cmp al, content_pointer - jne .let_done_binding - mov r12, [r12 + Cons.cdr] ; Next - jmp .let_bind_loop - -.let_done_binding: - ; Done bindings. - ; Evaluate next item in let* form in new environment - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_body - mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate - ; Check type of the value - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - je .body_pointer - - ; Just a value, so copy - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl ; set type - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx ; copy value - jmp .let_done - -.body_pointer: - ; Evaluate using new environment - - mov rsi, [r11 + Cons.car] ; Object pointed to - call incref_object ; will be released by eval - - mov r11, rsi ; save new AST - pop rsi ; Old AST - call release_object - mov rsi, r11 ; New AST - - mov rdi, r14 ; New environment - - jmp eval ; Tail call - ; Note: eval will release the new environment on return - -.let_done: - ; Release the new environment - push rax - mov rsi, r14 - call release_object - pop rax - - ; Release the AST - pop rsi - push rax - call release_object - pop rax - ret ; already released env - -.let_error_missing_bindings: - mov rsi, let_missing_bindings_string - mov rdx, let_missing_bindings_string.len - jmp .let_handle_error - -.let_error_bindings_list: ; expected a list or vector, got something else - mov rsi, let_bindings_list_string - mov rdx, let_bindings_list_string.len - jmp .let_handle_error - -.let_error_bind_symbol: ; expected a symbol, got something else - mov rsi, let_bind_symbol_string - mov rdx, let_bind_symbol_string.len - jmp .let_handle_error - -.let_error_bind_value: ; Missing value in binding list - mov rsi, let_bind_value_string - mov rdx, let_bind_value_string.len - jmp .let_handle_error - -.let_error_missing_body: ; Missing body to evaluate - mov rsi, let_missing_body_string - mov rdx, let_missing_body_string.len - jmp .let_handle_error - -.let_handle_error: - push r11 ; For printing later - - push rsi - push rdx - - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - pop rsi ; let* form - jmp error_throw ; No return - - ; ----------------------------- - -.do_symbol: - mov r11, rsi ; do form in RSI - ; Environment in R15 - - ; Check if there is a body - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .do_no_body ; error - - mov r11, [r11 + Cons.cdr] ; Body in R11 - -.do_symbol_loop: - - ; Need to test if this is the last form - ; so we can handle tail call - - mov bl, BYTE [r11 + Cons.typecdr] - cmp bl, content_pointer - jne .do_body_last ; Last expression - - ; not the last expression - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_next ; A value, so skip - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - ; since eval will release Env - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increment ref count since eval will release - - mov rdi, r15 ; Env - call eval ; Result in RAX - - ; Another form after this. - ; Discard the result of the last eval - mov rsi, rax - call release_object - - pop r11 - pop r15 - -.do_next: - mov r11, [r11 + Cons.cdr] ; Next in list - - jmp .do_symbol_loop - -.do_body_last: - ; The last form is in R11, which will be returned - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_body_value_return - jmp .do_body_expr_return - -.do_body_value_return: - ; Got a value as last form (in R11). - ; Copy and return - - push rax ; Type of value to return - - ; release Env - mov rsi, r15 - call release_object - - ; Allocate a Cons object to hold value - call alloc_cons - pop rbx ; type in BL - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - ; release the AST - pop rsi - mov r15, rax ; not modified by release - call release_object - mov rax, r15 - - ret - -.do_body_expr_return: - ; An expression to evaluate as the last form - ; Tail call optimise, jumping to eval - ; Don't increment Env reference count - - mov rsi, [r11 + Cons.car] ; new AST form - call incref_object ; This will be released by eval - - mov r11, rsi ; Save new AST - pop rsi ; Remove old AST from stack - call release_object - mov rsi, r11 - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.do_no_body: - ; No expressions to evaluate. Return nil - - mov rsi, r15 - call release_object ; Release Env - - ; release the AST - pop rsi - call release_object - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - ; ----------------------------- - -.if_symbol: - mov r11, rsi ; if form in R11 - ; Environment in R15 - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .if_no_condition - - mov r11, [r11 + Cons.cdr] ; Should be a condition - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .if_cond_value - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increase Form/AST ref count - - mov rdi, r15 ; Env - call eval ; Result in RAX - pop r11 - pop r15 - - ; Get type of result - mov bl, BYTE [rax] - - ; release value - push rbx - mov rsi, rax - call release_object - pop rbx - - ; Check type - cmp bl, maltype_nil - je .if_false - cmp bl, maltype_false - je .if_false - - jmp .if_true - -.if_cond_value: - - ; A value - cmp al, content_nil - je .if_false - cmp al, content_false - je .if_false - - jmp .if_true - -.if_false: - ; Skip the next item - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil - - mov r11, [r11 + Cons.cdr] - -.if_true: - ; Get the next item in the list and evaluate it - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; Nothing to return - - mov r11, [r11 + Cons.cdr] - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - je .if_got_pointer - -.if_got_value: - ; copy value in r11 - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - jmp .return - -.if_got_pointer: - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Will be released by eval - - mov r11, rsi - pop rsi - call release_object ; Release old AST - mov rsi, r11 ; New AST - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.if_no_condition: ; just (if) without a condition - - print_str_mac error_string - print_str_mac if_missing_condition_string - - ; Release environment - mov rsi, r15 - call release_object - xor rsi, rsi ; No object to throw - jmp error_throw - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - -.return: - ; Release environment - mov rsi, r15 - mov r15, rax ; Save RAX (return value) - call release_object - - ; Release the AST - pop rsi ; Pushed at start of eval - call release_object - - mov rax, r15 ; return value - ret - - ; ----------------------------- - -.fn_symbol: - mov r11, rsi ; fn form in R11 - ; Environment in R15 - - ; Get the binds and body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_empty - - mov r11, [r11 + Cons.cdr] - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_binds_not_list - - mov r12, [r11 + Cons.car] ; Should be binds list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - cmp al, (block_cons + container_list) - je .fn_got_binds ; Can be list - cmp al, (block_cons + container_vector) - je .fn_got_binds ; or vector - jmp .fn_binds_not_list - -.fn_got_binds: - - ; Next get the body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_no_body - - mov r11, [r11 + Cons.cdr] - ; Check value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_is_value ; Body in r11 - mov r11, [r11 + Cons.car] - jmp .fn_got_body - -.fn_is_value: - ; Body is just a value, no expression - mov [r11], BYTE al ; Mark as value, not list - -.fn_got_body: - - ; Now put into function type - ; Addr is "apply_fn", the address to call - ; Env in R15 - ; Binds in R12 - ; Body in R11 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_function) - mov rbx, apply_fn - mov [rax + Cons.car], rbx ; Address of apply function - mov [rax + Cons.typecdr], BYTE content_pointer - - mov r13, rax ; Return list in R13 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r15 ; Environment - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r13 + Cons.cdr], rax ; Append to list - mov r14, rax ; R14 contains last cons in list - - push rax - mov rsi, r15 - call incref_object - pop rax - - ; Binds - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r12 ; Binds list - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r14 + Cons.cdr], rax ; Append to list - mov r14, rax - - push rax - mov rsi, r12 - call incref_object - pop rax - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r11 ; Body of function - - mov [r14 + Cons.cdr], rax - - mov rsi, r11 - call incref_object - - mov rax, r13 - jmp .return - -.fn_empty: -.fn_binds_not_list: -.fn_no_body: - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - jmp .return - - ; ----------------------------- - -.quote_symbol: - ; Just return the arguments in rsi cdr - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; quote empty, so return nil - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .quote_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.quote_pointer: - ; RSI contains a pointer, so get the object pointed to - mov rsi, [rsi + Cons.car] - call incref_object - mov rax, rsi - jmp .return - - ; ----------------------------- - -;;; Like quasiquote, but do not evaluate the result. -.quasiquoteexpand_symbol: - ;; Return nil if no cdr - mov cl, BYTE [rsi + Cons.typecdr] - cmp cl, content_pointer - jne .return_nil - - mov rsi, [rsi + Cons.cdr] - call car_and_incref - call quasiquote - jmp .return - - ; ----------------------------- - -.quasiquote_symbol: - ; call quasiquote function with first argument - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; quasiquote empty, so return nil - - mov r11, rsi ; Save original AST in R11 - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .quasiquote_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.quasiquote_pointer: - ; RSI contains a pointer, so get the object pointed to - mov rsi, [rsi + Cons.car] - - push r15 ; Environment - ; Original AST already on stack - - call quasiquote - ; New AST in RAX - pop rdi ; Environment - pop rsi ; Old AST - - mov r11, rax ; New AST - call release_object ; Release old AST - mov rsi, r11 ; New AST in RSI - - jmp eval ; Tail call - - ; ----------------------------- -.macroexpand_symbol: - ; Check if we have a second list element - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; No argument - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .macroexpand_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.macroexpand_pointer: - mov rsi, [rsi + Cons.car] - call incref_object ; Since RSI will be released - - call macroexpand ; May release and replace RSI - - mov rax, rsi - jmp .return ; Releases original AST - - ; ----------------------------- - -.list_eval: - push rsi - mov rdi, r15 ; Environment - push r15 - call eval_ast ; List of evaluated forms in RAX - pop r15 - pop rsi - -.list_exec: - ; This point can be called to run a function - ; used by swap! - ; - ; Inputs: RAX - List with function as first element - ; NOTE: This list is released - ; - ; Check that the first element of the return is a function - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .list_not_function - - mov rbx, [rax + Cons.car] ; Get the address - mov cl, BYTE [rbx] - cmp cl, maltype_function - jne .list_not_function - - ; Check the rest of the args - mov cl, BYTE [rax + Cons.typecdr] - cmp cl, content_pointer - je .list_got_args - - ; No arguments - push rbx ; Function object - push rax ; List with function first - - ; Create an empty list for the arguments - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax ; Argument list into RSI - - pop rax ; list, function first - ;; Put new empty list onto end of original list - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rsi - - pop rbx - jmp .list_function_call -.list_got_args: - mov rsi, [rax + Cons.cdr] ; Rest of list -.list_function_call: - ; Call the function with the rest of the list in RSI - - mov rdx, rax ; List to release - mov rdi, rbx ; Function object in RDI - - mov rbx, [rbx + Cons.car] ; Call function - cmp rbx, apply_fn - je apply_fn_jmp ; Jump to user function apply - - ; A built-in function, so call (no recursion) - push rax - push r15 - - call rbx - - ; Result in rax - pop r15 - pop rsi ; eval'ed list - - push rax - call release_cons - pop rax - jmp .return ; Releases Env - -.list_not_function: - ; Not a function. Probably an error - push rsi - - mov rsi, rax - call release_object - - print_str_mac error_string - print_str_mac eval_list_not_function - pop rsi - jmp error_throw - -.empty_list: - mov rax, rsi - jmp .return - -;; Applies a user-defined function -;; -;; Input: RSI - Arguments to bind -;; RDI - Function object -;; RDX - list to release after binding -;; R15 - Env (will be released) -;; R13 - AST released before return -;; -;; -;; Output: Result in RAX -;; -;; This is jumped to from eval, so if it returns -;; then it will return to the caller of eval, not to eval -apply_fn_jmp: - ; This is jumped to from eval with AST on the stack - pop r13 -apply_fn: - push rsi - ; Extract values from the list in RDI - mov rax, [rdi + Cons.cdr] - mov rsi, [rax + Cons.car] ; Env - mov rax, [rax + Cons.cdr] - mov rdi, [rax + Cons.car] ; Binds - mov rax, [rax + Cons.cdr] - mov rax, [rax + Cons.car] ; Body - pop rcx ; Exprs - - ; Check the type of the body - mov bl, BYTE [rax] - and bl, block_mask + container_mask - jnz .bind - ; Just a value (in RAX). No eval needed - - mov r14, rax ; Save return value in R14 - - mov rsi, rax - call incref_object - - ; Release the list passed in RDX - mov rsi, rdx - call release_object - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the AST - mov rsi, r13 - call release_object - - mov rax, r14 - ret -.bind: - ; Create a new environment, binding arguments - push rax ; Body - - mov r14, r13 ; Old AST. R13 used by env_new_bind - - push rdx - call env_new_bind - pop rdx - - mov rdi, rax ; New environment in RDI - - ; Note: Need to increment the reference count - ; of the function body before releasing anything, - ; since if the function was defined in-place (lambda) - ; then the body may be released early - - pop rsi ; Body - call incref_object ; Will be released by eval - mov r8, rsi ; Body in R8 - - ; Release the list passed in RDX - mov rsi, rdx - call release_cons - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the old AST - mov rsi, r14 - call release_object - - mov rsi, r8 ; Body - - jmp eval ; Tail call - ; The new environment (in RDI) will be released by eval - - -;;; Called by eval -;;; Original AST in RSI. -;;; Returns new AST in RAX -quasiquote: - ;; Dispatch on the type. - mov al, BYTE [rsi + Cons.typecar] - mov cl, al ; keep full al for .list - and cl, container_mask - cmp cl, container_list - je .list - cmp cl, container_map - je .map - cmp cl, container_symbol - je .symbol - cmp cl, container_vector - je .vector - ;; return other types unchanged - call incref_object - mov rax, rsi - ret - -.list: - ;; AST is a list, process it with qq_foldr unless.. - mov cl, al ; it is not empty, - and cl, content_mask - cmp cl, content_empty - je qq_foldr - - cmp cl, content_pointer ; and it is a pointer, - jne qq_foldr - - mov rdi, [rsi + Cons.car] ; and the first element is a symbol, - mov cl, BYTE [rdi + Cons.typecar] - cmp cl, maltype_symbol - jne qq_foldr - - mov r8, rsi ; and the symbol is 'unquote, - mov rsi, unquote_symbol - call compare_char_array - test rax, rax - mov rsi, r8 - jne qq_foldr - - mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. - cmp cl, content_pointer - jne qq_foldr - - ;; If so, return the argument. - mov rsi, [rsi + Cons.cdr] - call car_and_incref - mov rax, rsi - ret - -.map: -.symbol: - call incref_object - - ;; rdx := (ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rsi - mov rdx, rax - - mov rsi, quote_symbol - call incref_object - - ;; rax := ('quote ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - -.vector: - ;; rdx := ast processed like a list - call qq_foldr - mov rdx, rax - - ;; rdx := (processed_ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdx - mov rdx, rax - - mov rsi, vec_symbol - call incref_object - - ;; rax := ('vec processed_ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - - -;;; Helper for quasiquote. -;;; RSI must contain a list or vector, which may be empty. -;;; The result in RAX is always a list. -;;; Iterate on the elements in the right fold/reduce style. -qq_foldr: - mov cl, BYTE [rsi + Cons.typecar] - - cmp cl, maltype_empty_list - je .empty_list - - cmp cl, maltype_empty_vector - je .empty_vector - - ;; Extract first element and store it into the stack during - ;; the recursion. - mov rdx, rsi - call car_and_incref - push rsi - mov rsi, rdx - - ;; Extract the rest of the list. - mov al, BYTE [rsi + Cons.typecdr] - -;;; If the rest is not empty - cmp al, content_pointer - jne .else -;;; then - mov rsi, [rsi + Cons.cdr] - jmp .endif -.else: - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax -.endif: - call qq_foldr ; recursive call - pop rsi - jmp qq_loop - -.empty_list: ;; () -> () - call incref_object - mov rax, rsi - ret - -.empty_vector: ;; [] -> () - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - - -;; Helper for quasiquote -;; The transition function starts here. -;; Current element is in rsi, accumulator in rax. -qq_loop: - mov r9, rax - - ;; Process with the element with .default, unless.. - mov cl, BYTE [rsi + Cons.typecar] ; it is a list - mov al, cl - and al, container_mask - cmp al, container_list - jne .default - - cmp cl, maltype_empty_list ; it is not empty, - je .default - - and cl, content_mask ; and it is a pointer, - cmp cl, content_pointer - jne .default - - mov rdi, [rsi + Cons.car] ; and the first element is a symbol, - mov cl, BYTE [rdi + Cons.typecar] - cmp cl, maltype_symbol - jne .default - - mov r8, rsi ; and the symbol is 'splice-unquote, - mov rsi, splice_unquote_symbol - call compare_char_array - test rax, rax - mov rsi, r8 - jne .default - - mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. - cmp cl, content_pointer - jne .default - - ;; If so, return ('concat elt acc). - mov rsi, [rsi + Cons.cdr] - call car_and_incref - - ;; rdx := (acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.car], r9 - mov rdx, rax - - ;; rdx := (elt acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - mov rdx, rax - - mov rsi, concat_symbol - call incref_object - - ;; rax := ('concat elt acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - -.default: - ;; rax := (accumulator) - call alloc_cons - mov [rax + Cons.typecar], BYTE (container_list + content_pointer) - mov [rax + Cons.car], r9 - - ;; rcx := quasiquoted_element - ;; rdx := (accumulator) - push rax - call quasiquote - mov rcx, rax - pop rdx - - ;; rdx := (quasiquoted_element accumulator) - call alloc_cons - mov [rax + Cons.typecar], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rcx - mov [rax + Cons.cdr], rdx - mov rdx, rax - - mov rsi, cons_symbol - call incref_object - - ;; rax := ('cons quasiquoted_elt accumulator) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - - -;; Tests if an AST in RSI is a list containing -;; a macro defined in the ENV in R15 -;; -;; Inputs: AST in RSI (not modified) -;; ENV in R15 (not modified) -;; -;; Returns: Sets ZF if macro call. If set (true), -;; then the macro object is in RAX -;; -;; Modifies: -;; RAX -;; RBX -;; RCX -;; RDX -;; R8 -;; R9 -is_macro_call: - ; Test if RSI is a list which contains a pointer - mov al, BYTE [rsi] - cmp al, (block_cons + container_list + content_pointer) - jne .false - - ; Test if this is a symbol - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .false - - ; Look up symbol in Env - push rsi - push r15 - mov rdi, rbx ; symbol in RDI - mov rsi, r15 ; Environment in RSI - call env_get - pop r15 - pop rsi - jne .false ; Not in environment - - ; Object in RAX - ; If this is not a macro then needs to be released - mov dl, BYTE [rax] - - cmp dl, maltype_macro - je .true - - ; Not a macro, so release - mov r8, rsi - mov rsi, rax - call release_object - mov rsi, r8 - -.false: - lahf ; flags in AH - and ah, 255-64 ; clear zero flag - sahf - ret -.true: - mov rbx, rax ; Returning Macro object - lahf ; flags in AH - or ah, 64 ; set zero flag - sahf - mov rax, rbx - ret - -;; Expands macro calls -;; -;; Input: AST in RSI (released and replaced) -;; Env in R15 (not modified) -;; -;; Result: New AST in RSI -macroexpand: - push r15 - - call is_macro_call - jne .done - - mov r13, rsi - - mov rdi, rax ; Macro in RDI - - ; Check the rest of the args - mov cl, BYTE [rsi + Cons.typecdr] - cmp cl, content_pointer - je .got_args - - ; No arguments. Create an empty list - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rdx, rax - - mov rsi, rdx ; Arguments (empty list) - call incref_object - jmp .macro_call -.got_args: - mov rsi, [rsi + Cons.cdr] ; Rest of list - call incref_object - mov rdx, rsi ; Released -.macro_call: - ; Here have: - ; RSI - Arguments - ; RDI - Macro object - ; RDX - List to release - ; R15 - Environment - ; R13 - AST - - ; Increment reference for Environment - ; since this will be released by apply_fn - xchg rsi, r15 - call incref_object - xchg rsi, r15 - - call apply_fn - - mov rsi, rax ; Result in RSI - - pop r15 - jmp macroexpand -.done: - pop r15 - ret - -;; Read and eval -read_eval: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - jmp eval ; This releases Env and Form/AST - - -;; Read-Eval-Print in sequence -;; -;; Input string in RSI -rep_seq: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call eval ; This releases Env and Form/AST - push rax ; Save result of eval - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - mov rdi, 1 ; print readably - call pr_str ; String in RAX - - mov r8, rax ; Save output - - pop rsi ; Result from eval - call release_object - mov rax, r8 - - ret - - -_start: - ; Create and print the core environment - call core_environment ; Environment in RAX - - mov [repl_env], rax ; store in memory - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; Evaluate the startup string - - mov rsi, mal_startup_string - mov edx, mal_startup_string.len - call raw_to_string ; String in RAX - - push rax - mov rsi, rax - call read_str ; AST in RAX - pop rsi ; string - - push rax ; AST - call release_array ; string - pop rdi ; AST in RDI - - mov rsi, [repl_env] ; Environment in RSI - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call eval - - mov rsi, rax - call release_object ; Return from eval - - ; ----------------------------- - ; Check command-line arguments - - pop rax ; Number of arguments - cmp rax, 1 ; Always have at least one, the path to executable - jg run_script - - ; No extra arguments, so just set *ARGV* to an empty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov rcx, rax ; value (empty list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - -.catch: - ; Jumps here on error - - ; Check if an object was thrown - cmp rsi, 0 - je .catch_done_print ; nothing to print - mov rdi, 1 - call pr_str - mov rsi, rax - call print_string -.catch_done_print: - jmp .mainLoop ; Go back to the prompt - - - -run_script: - ; Called with number of command-line arguments in RAX - mov r8, rax - pop rbx ; executable - dec r8 - - pop rsi ; Address of first arg - call cstring_to_string ; string in RAX - mov r9, rax - - ; get the rest of the args - xor r10, r10 ; Zero - dec r8 - jz .no_args - - ; Got some arguments -.arg_loop: - ; Got an argument left. - pop rsi ; Address of C string - call cstring_to_string ; String in RAX - mov r12, rax - - ;Make a Cons to point to the string - call alloc_cons ; in RAX - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], r12 - - test r10, r10 - jnz .append - - ; R10 zero, so first arg - mov r10, rax ; Head of list - mov r11, rax ; Tail of list - jmp .next -.append: - ; R10 not zero, so append to list tail - mov [r11 + Cons.cdr], rax - mov [r11 + Cons.typecdr], BYTE content_pointer - mov r11, rax -.next: - dec r8 - jnz .arg_loop - jmp .got_args - -.no_args: - ; No arguments. Create an emoty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov r10, rax - -.got_args: - push r9 ; File name string - - mov rcx, r10 ; value (list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - mov rsi, run_script_string ; load-file function - mov edx, run_script_string.len - call raw_to_string ; String in RAX - - mov rsi, rax - pop rdx ; File name string - call string_append_string - - mov cl, 34 ; " - call string_append_char - mov cl, ')' - call string_append_char ; closing brace - - ; Read-Eval "(load-file )" - call read_eval - - jmp quit +;; +;; nasm -felf64 step8_macros.asm && ld step8_macros.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static defmacro_expecting_function_string, db "defmacro expects function",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + static_symbol defmacro_symbol, 'defmacro!' + static_symbol macroexpand_symbol, 'macroexpand' + + static_symbol argv_symbol, '*ARGV*' + + static_symbol quote_symbol, 'quote' + static_symbol quasiquote_symbol, 'quasiquote' + static_symbol quasiquoteexpand_symbol, 'quasiquoteexpand' + static_symbol unquote_symbol, 'unquote' + static_symbol splice_unquote_symbol, 'splice-unquote' + static_symbol concat_symbol, 'concat' + static_symbol cons_symbol, 'cons' + static_symbol vec_symbol, 'vec' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do \ +(def! not (fn* (a) (if a false true))) \ +(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ +(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) \ +)" + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 +section .text + + +;;; Extract the car of a Cons and increment its reference count. +;;; If it was value, create a fresh copy. +;;; in : rsi (which must be a pointer!) +;;; out : rsi +;;; modified: : cl, rax, rbx +car_and_incref: + mov cl, BYTE [rsi + Cons.typecar] + and cl, content_mask + + mov rsi, [rsi + Cons.car] + + cmp cl, content_pointer + je incref_object + + call alloc_cons + mov [rax + Cons.typecar], BYTE cl ; masked above + mov [rax + Cons.car], rsi + mov rsi, rax + ret + + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + push rsi + print_str_mac error_string ; print 'Error: ' + + pop rsi + push rsi + mov edx, [rsi + Array.length] + add rsi, Array.data + call print_rawstring ; print symbol + + print_str_mac not_found_string ; print ' not found' + pop rsi + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] +;; +;; Returns: Result in RAX +;; +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) +;; +eval: + mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Macro expand + pop rax ; Old AST, discard from stack + call macroexpand ; Replaces RSI + push rsi ; New AST + + ; Check if RSI is a list, and if + ; the first element is a symbol + mov al, BYTE [rsi] + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list_still_list + + ; Not a list, so call eval_ast on it + mov rdi, r15 ; Environment + call eval_ast + jmp .return + +.list_still_list: + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + eval_cmp_symbol quote_symbol ; quote + je .quote_symbol + + eval_cmp_symbol quasiquoteexpand_symbol + je .quasiquoteexpand_symbol + + eval_cmp_symbol quasiquote_symbol ; quasiquote + je .quasiquote_symbol + + eval_cmp_symbol defmacro_symbol ; defmacro! + je .defmacro_symbol + + eval_cmp_symbol macroexpand_symbol ; macroexpand + je .macroexpand_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.defmacro_symbol: + mov r9, 1 + jmp .def_common +.def_symbol: + xor r9, r9 ; Set R9 to 0 +.def_common: + ; Define a new symbol in current environment + ; If R9 is set to 1 then defmacro + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + + ; Test if this is defmacro! + test r9, r9 + jnz .defmacro_not_function + + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + push r9 + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs + + call eval + mov rsi, rax + + pop r9 + + ; If this is defmacro, and the object in RSI is a function, + ; then change to a macro + test r9, r9 + jz .def_not_macro ; Not defmacro + + ; Check RSI + mov al, BYTE [rsi] + cmp al, maltype_function + jne .defmacro_not_function + + ; Got a function, change to macro + mov [rsi], BYTE maltype_macro + +.def_not_macro: + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.defmacro_not_function: + mov rsi, defmacro_expecting_function_string + mov rdx, defmacro_expecting_function_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + ; release the AST + pop rsi + call release_object + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + ; Release environment + mov rsi, r15 + mov r15, rax ; Save RAX (return value) + call release_object + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax ; R14 contains last cons in list + + push rax + mov rsi, r15 + call incref_object + pop rax + + ; Binds + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + ; ----------------------------- + +.quote_symbol: + ; Just return the arguments in rsi cdr + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quote empty, so return nil + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + jmp .return + + ; ----------------------------- + +;;; Like quasiquote, but do not evaluate the result. +.quasiquoteexpand_symbol: + ;; Return nil if no cdr + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .return_nil + + mov rsi, [rsi + Cons.cdr] + call car_and_incref + call quasiquote + jmp .return + + ; ----------------------------- + +.quasiquote_symbol: + ; call quasiquote function with first argument + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quasiquote empty, so return nil + + mov r11, rsi ; Save original AST in R11 + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quasiquote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quasiquote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + + push r15 ; Environment + ; Original AST already on stack + + call quasiquote + ; New AST in RAX + pop rdi ; Environment + pop rsi ; Old AST + + mov r11, rax ; New AST + call release_object ; Release old AST + mov rsi, r11 ; New AST in RSI + + jmp eval ; Tail call + + ; ----------------------------- +.macroexpand_symbol: + ; Check if we have a second list element + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .macroexpand_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.macroexpand_pointer: + mov rsi, [rsi + Cons.car] + call incref_object ; Since RSI will be released + + call macroexpand ; May release and replace RSI + + mov rax, rsi + jmp .return ; Releases original AST + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx ; Function object + push rax ; List with function first + + ; Create an empty list for the arguments + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax ; Argument list into RSI + + pop rax ; list, function first + ;; Put new empty list onto end of original list + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rsi + + pop rbx + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn_jmp ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + +.empty_list: + mov rax, rsi + jmp .return + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; R13 - AST released before return +;; +;; +;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + mov r14, rax ; Save return value in R14 + + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the AST + mov rsi, r13 + call release_object + + mov rax, r14 + ret +.bind: + ; Create a new environment, binding arguments + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + + ; Release the list passed in RDX + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;;; Called by eval +;;; Original AST in RSI. +;;; Returns new AST in RAX +quasiquote: + ;; Dispatch on the type. + mov al, BYTE [rsi + Cons.typecar] + mov cl, al ; keep full al for .list + and cl, container_mask + cmp cl, container_list + je .list + cmp cl, container_map + je .map + cmp cl, container_symbol + je .symbol + cmp cl, container_vector + je .vector + ;; return other types unchanged + call incref_object + mov rax, rsi + ret + +.list: + ;; AST is a list, process it with qq_foldr unless.. + mov cl, al ; it is not empty, + and cl, content_mask + cmp cl, content_empty + je qq_foldr + + cmp cl, content_pointer ; and it is a pointer, + jne qq_foldr + + mov rdi, [rsi + Cons.car] ; and the first element is a symbol, + mov cl, BYTE [rdi + Cons.typecar] + cmp cl, maltype_symbol + jne qq_foldr + + mov r8, rsi ; and the symbol is 'unquote, + mov rsi, unquote_symbol + call compare_char_array + test rax, rax + mov rsi, r8 + jne qq_foldr + + mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. + cmp cl, content_pointer + jne qq_foldr + + ;; If so, return the argument. + mov rsi, [rsi + Cons.cdr] + call car_and_incref + mov rax, rsi + ret + +.map: +.symbol: + call incref_object + + ;; rdx := (ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rsi + mov rdx, rax + + mov rsi, quote_symbol + call incref_object + + ;; rax := ('quote ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + +.vector: + ;; rdx := ast processed like a list + call qq_foldr + mov rdx, rax + + ;; rdx := (processed_ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdx + mov rdx, rax + + mov rsi, vec_symbol + call incref_object + + ;; rax := ('vec processed_ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + + +;;; Helper for quasiquote. +;;; RSI must contain a list or vector, which may be empty. +;;; The result in RAX is always a list. +;;; Iterate on the elements in the right fold/reduce style. +qq_foldr: + mov cl, BYTE [rsi + Cons.typecar] + + cmp cl, maltype_empty_list + je .empty_list + + cmp cl, maltype_empty_vector + je .empty_vector + + ;; Extract first element and store it into the stack during + ;; the recursion. + mov rdx, rsi + call car_and_incref + push rsi + mov rsi, rdx + + ;; Extract the rest of the list. + mov al, BYTE [rsi + Cons.typecdr] + +;;; If the rest is not empty + cmp al, content_pointer + jne .else +;;; then + mov rsi, [rsi + Cons.cdr] + jmp .endif +.else: + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax +.endif: + call qq_foldr ; recursive call + pop rsi + jmp qq_loop + +.empty_list: ;; () -> () + call incref_object + mov rax, rsi + ret + +.empty_vector: ;; [] -> () + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + + +;; Helper for quasiquote +;; The transition function starts here. +;; Current element is in rsi, accumulator in rax. +qq_loop: + mov r9, rax + + ;; Process with the element with .default, unless.. + mov cl, BYTE [rsi + Cons.typecar] ; it is a list + mov al, cl + and al, container_mask + cmp al, container_list + jne .default + + cmp cl, maltype_empty_list ; it is not empty, + je .default + + and cl, content_mask ; and it is a pointer, + cmp cl, content_pointer + jne .default + + mov rdi, [rsi + Cons.car] ; and the first element is a symbol, + mov cl, BYTE [rdi + Cons.typecar] + cmp cl, maltype_symbol + jne .default + + mov r8, rsi ; and the symbol is 'splice-unquote, + mov rsi, splice_unquote_symbol + call compare_char_array + test rax, rax + mov rsi, r8 + jne .default + + mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. + cmp cl, content_pointer + jne .default + + ;; If so, return ('concat elt acc). + mov rsi, [rsi + Cons.cdr] + call car_and_incref + + ;; rdx := (acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], r9 + mov rdx, rax + + ;; rdx := (elt acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + mov rdx, rax + + mov rsi, concat_symbol + call incref_object + + ;; rax := ('concat elt acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + +.default: + ;; rax := (accumulator) + call alloc_cons + mov [rax + Cons.typecar], BYTE (container_list + content_pointer) + mov [rax + Cons.car], r9 + + ;; rcx := quasiquoted_element + ;; rdx := (accumulator) + push rax + call quasiquote + mov rcx, rax + pop rdx + + ;; rdx := (quasiquoted_element accumulator) + call alloc_cons + mov [rax + Cons.typecar], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rcx + mov [rax + Cons.cdr], rdx + mov rdx, rax + + mov rsi, cons_symbol + call incref_object + + ;; rax := ('cons quasiquoted_elt accumulator) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + + +;; Tests if an AST in RSI is a list containing +;; a macro defined in the ENV in R15 +;; +;; Inputs: AST in RSI (not modified) +;; ENV in R15 (not modified) +;; +;; Returns: Sets ZF if macro call. If set (true), +;; then the macro object is in RAX +;; +;; Modifies: +;; RAX +;; RBX +;; RCX +;; RDX +;; R8 +;; R9 +is_macro_call: + ; Test if RSI is a list which contains a pointer + mov al, BYTE [rsi] + cmp al, (block_cons + container_list + content_pointer) + jne .false + + ; Test if this is a symbol + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .false + + ; Look up symbol in Env + push rsi + push r15 + mov rdi, rbx ; symbol in RDI + mov rsi, r15 ; Environment in RSI + call env_get + pop r15 + pop rsi + jne .false ; Not in environment + + ; Object in RAX + ; If this is not a macro then needs to be released + mov dl, BYTE [rax] + + cmp dl, maltype_macro + je .true + + ; Not a macro, so release + mov r8, rsi + mov rsi, rax + call release_object + mov rsi, r8 + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + mov rbx, rax ; Returning Macro object + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rbx + ret + +;; Expands macro calls +;; +;; Input: AST in RSI (released and replaced) +;; Env in R15 (not modified) +;; +;; Result: New AST in RSI +macroexpand: + push r15 + + call is_macro_call + jne .done + + mov r13, rsi + + mov rdi, rax ; Macro in RDI + + ; Check the rest of the args + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + je .got_args + + ; No arguments. Create an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rdx, rax + + mov rsi, rdx ; Arguments (empty list) + call incref_object + jmp .macro_call +.got_args: + mov rsi, [rsi + Cons.cdr] ; Rest of list + call incref_object + mov rdx, rsi ; Released +.macro_call: + ; Here have: + ; RSI - Arguments + ; RDI - Macro object + ; RDX - List to release + ; R15 - Environment + ; R13 - AST + + ; Increment reference for Environment + ; since this will be released by apply_fn + xchg rsi, r15 + call incref_object + xchg rsi, r15 + + call apply_fn + + mov rsi, rax ; Result in RSI + + pop r15 + jmp macroexpand +.done: + pop r15 + ret + +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + mov rax, r8 + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call eval + + mov rsi, rax + call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval "(load-file )" + call read_eval + + jmp quit diff --git a/impls/nasm/step9_try.asm b/impls/nasm/step9_try.asm index 54a3318946..7c391c7d6d 100644 --- a/impls/nasm/step9_try.asm +++ b/impls/nasm/step9_try.asm @@ -1,2541 +1,2541 @@ -;; -;; nasm -felf64 step9_try.asm && ld step9_try.o && ./a.out -;; -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "env.asm" ; Environment type -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "core.asm" ; Core functions -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .bss - -;; Top-level (REPL) environment -repl_env:resq 1 - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - - static error_string, db 27,'[31m',"Error",27,'[0m',": " - - static not_found_string, db " not found" - - static def_missing_arg_string, db "missing argument to def!",10 - - static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 - - static defmacro_expecting_function_string, db "defmacro expects function",10 - - static let_missing_bindings_string, db "let* missing bindings",10 - - static let_bindings_list_string, db "let* expected a list or vector of bindings",10 - - static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 - - static let_bind_value_string, db "let* missing value in bindings list",10 - - static let_missing_body_string, db "let* missing body",10 - static eval_list_not_function, db "list does not begin with a function",10 - - static if_missing_condition_string, db "missing condition in if expression",10 - - static try_missing_catch, db "try* missing catch*" - static catch_missing_symbol, db "catch* missing symbol" - static catch_missing_form, db "catch* missing form" - -;; Symbols used for comparison - - static_symbol def_symbol, 'def!' - static_symbol let_symbol, 'let*' - static_symbol do_symbol, 'do' - static_symbol if_symbol, 'if' - static_symbol fn_symbol, 'fn*' - static_symbol defmacro_symbol, 'defmacro!' - static_symbol macroexpand_symbol, 'macroexpand' - static_symbol try_symbol, 'try*' - static_symbol catch_symbol, 'catch*' - - static_symbol argv_symbol, '*ARGV*' - - static_symbol quote_symbol, 'quote' - static_symbol quasiquote_symbol, 'quasiquote' - static_symbol quasiquoteexpand_symbol, 'quasiquoteexpand' - static_symbol unquote_symbol, 'unquote' - static_symbol splice_unquote_symbol, 'splice-unquote' - static_symbol concat_symbol, 'concat' - static_symbol cons_symbol, 'cons' - static_symbol vec_symbol, 'vec' - -;; Startup string. This is evaluated on startup - static mal_startup_string, db "(do \ -(def! not (fn* (a) (if a false true))) \ -(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ -(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) \ -)" - -;; Command to run, appending the name of the script to run - static run_script_string, db "(load-file ",34 -section .text - - -;;; Extract the car of a Cons and increment its reference count. -;;; If it was value, create a fresh copy. -;;; in : rsi (which must be a pointer!) -;;; out : rsi -;;; modified: : cl, rax, rbx -car_and_incref: - mov cl, BYTE [rsi + Cons.typecar] - and cl, content_mask - - mov rsi, [rsi + Cons.car] - - cmp cl, content_pointer - je incref_object - - call alloc_cons - mov [rax + Cons.typecar], BYTE cl ; masked above - mov [rax + Cons.car], rsi - mov rsi, rax - ret - - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; RDI Environment -;; -eval_ast: - mov r15, rdi ; Save Env in r15 - - ; Check the type - mov al, BYTE [rsi] - - ; Check if this is a list - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list - - cmp ah, container_map - je .map - - cmp ah, container_vector - je .vector - - ; Not a list, map or vector - cmp ah, container_symbol - je .symbol - - ; Not a symbol, list, map or vector - call incref_object ; Increment reference count - - mov rax, rsi - ret - -.symbol: - ; Check if first character of symbol is ':' - mov al, BYTE [rsi + Array.data] - cmp al, ':' - je .keyword - - ; look in environment - push rsi - xchg rsi, rdi - ; symbol is the key in rdi - ; Environment in rsi - call env_get - pop rsi - je .done ; result in RAX - - ; Not found, throw an error - mov r11, rsi ; Symbol in R11 - - call string_new - mov rsi, rax ; New string in RSI - - mov cl, 39 ; quote ' - call string_append_char - - mov rdx, r11 ; symbol - call string_append_string - - mov cl, 39 - call string_append_char - - mov r11, rsi - - mov rsi, not_found_string - mov edx, not_found_string.len - call raw_to_string ; ' not found' - - mov r12, rax - - mov rdx, rax - mov rsi, r11 - call string_append_string - - mov r11, rsi - mov rsi, r12 - call release_array - mov rsi, r11 - - jmp error_throw - - ; ------------------------------ - -.keyword: - ; Just return keywords unaltered - call incref_object - mov rax, rsi - ret - - ; ------------------------------ -.list: - ; Evaluate each element of the list - ; - xor r8, r8 ; The list to return - ; r9 contains head of list - -.list_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .list_pointer - - ; A value in RSI, so copy - - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_list) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .list_append - -.list_pointer: - ; List element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rdi, [rsi + Cons.car] ; Get the address - mov rsi, r15 - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call incref_object ; AST increment refs - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .list_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_list + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .list_append - -.list_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_list) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - - ; Fall through to .list_append -.list_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .list_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .list_next - -.list_first: - mov r8, rax - mov r9, rax - ; fall through to .list_next - -.list_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .list_done ; finished list - mov rsi, [rsi + Cons.cdr] ; next in list - jmp .list_loop - -.list_done: - mov rax, r8 ; Return the list - ret - - ; --------------------- -.map: - ; Create a new map, evaluating all the values - - ; Check if the map is empty - cmp al, maltype_empty_map - jne .map_not_empty - - ; map empty. Just return it - call incref_object - mov rax, rsi - ret - -.map_not_empty: - - mov r10, rsi ; input in R10 - xor r12, r12 ; New map in r12 - - ; Now loop through each key-value pair - ; NOTE: This method relies on the implementation - ; of map as a list - -.map_loop: - ; Copy the key - call alloc_cons ; New Cons in RAX - - mov bl, [r10 + Cons.typecar] ; Type in BL - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] ; Value in RCX - mov [rax + Cons.car], rcx - - ; Check the type of the key - and bl, content_mask - cmp bl, content_pointer - jne .map_got_key ; a value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.map_got_key: - cmp r12,0 - jne .append_key - - ; First key - mov r12, rax - mov r13, rax - jmp .map_value - -.append_key: - ; Appending to previous value in r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - -.map_value: - ; Check that we have a value - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_error_missing_value - mov r10, [r10 + Cons.cdr] - - ; Now got value in r10 - - ; Check the type of the value - mov bl, [r10 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .map_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r10 + Cons.typecar] - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .map_got_value -.map_value_pointer: - ; A pointer, so need to evaluate - push r10 ; Input - push r12 ; start of result - push r13 ; Current head of result - push r15 ; Env - mov rsi, [r10 + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r13 - pop r12 - pop r10 - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - - jne .map_eval_pointer - - ; A value, so just change the type to a map - and bl, content_mask - add bl, (block_cons + container_map) - mov [rax], BYTE bl - jmp .map_got_value - -.map_eval_pointer: - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - -.map_got_value: - ; Append RAX to list in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - - ; Check if there's another key - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_done ; finished map - mov r10, [r10 + Cons.cdr] ; next in map - jmp .map_loop - -.map_done: - mov rax, r12 - ret - -.map_error_missing_value: - mov rax, r12 - ret - - ; ------------------------------ -.vector: - ; Evaluate each element of the vector - ; - xor r8, r8 ; The vector to return - ; r9 contains head of vector - -.vector_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .vector_pointer - - ; A value, so copy - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_vector) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .vector_append - -.vector_pointer: - ; Vector element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .vector_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_vector + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .vector_append - -.vector_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_vector) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - -.vector_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .vector_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .vector_next - -.vector_first: - mov r8, rax - mov r9, rax - ; fall through to .vector_next - -.vector_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .vector_done ; finished vector - mov rsi, [rsi + Cons.cdr] ; next in vector - jmp .vector_loop - -.vector_done: - mov rax, r8 ; Return the vector - ret - - ; --------------------- -.done: - ret - - - -;; Comparison of symbols for eval function -;; Compares the symbol in RSI with specified symbol -;; Preserves RSI and RBX -;; Modifies RDI -%macro eval_cmp_symbol 1 - push rsi - push rbx - mov rsi, rbx - mov rdi, %1 - call compare_char_array - pop rbx - pop rsi - test rax, rax ; ZF set if rax = 0 (equal) -%endmacro - -;; ---------------------------------------------------- -;; Evaluates a form -;; -;; Input: RSI AST to evaluate [ Released ] -;; RDI Environment [ Released ] -;; -;; Returns: Result in RAX -;; -;; Note: Both the form and environment will have their reference count -;; reduced by one (released). This is for tail call optimisation (Env), -;; quasiquote and macroexpand (AST) -;; -eval: - mov r15, rdi ; Env - - push rsi ; AST pushed, must be popped before return - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - and al, container_mask - cmp al, container_list - je .list - - ; Not a list. Evaluate and return - call eval_ast - jmp .return ; Releases Env - - ; -------------------- -.list: - ; A list - - ; Macro expand - pop rax ; Old AST, discard from stack - call macroexpand ; Replaces RSI - push rsi ; New AST - - ; Check if RSI is a list, and if - ; the first element is a symbol - mov al, BYTE [rsi] - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list_still_list - - ; Not a list, so call eval_ast on it - mov rdi, r15 ; Environment - call eval_ast - jmp .return - -.list_still_list: - and al, content_mask - cmp al, content_pointer - jne .list_eval - - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .list_eval - - ; Is a symbol, address in RBX - - ; Compare against special form symbols - - eval_cmp_symbol def_symbol ; def! - je .def_symbol - - eval_cmp_symbol let_symbol ; let* - je .let_symbol - - eval_cmp_symbol do_symbol ; do - je .do_symbol - - eval_cmp_symbol if_symbol ; if - je .if_symbol - - eval_cmp_symbol fn_symbol ; fn - je .fn_symbol - - eval_cmp_symbol quote_symbol ; quote - je .quote_symbol - - eval_cmp_symbol quasiquoteexpand_symbol - je .quasiquoteexpand_symbol - - eval_cmp_symbol quasiquote_symbol ; quasiquote - je .quasiquote_symbol - - eval_cmp_symbol defmacro_symbol ; defmacro! - je .defmacro_symbol - - eval_cmp_symbol macroexpand_symbol ; macroexpand - je .macroexpand_symbol - - eval_cmp_symbol try_symbol ; try* - je .try_symbol - - ; Unrecognised - jmp .list_eval - - - ; ----------------------------- - -.defmacro_symbol: - mov r9, 1 - jmp .def_common -.def_symbol: - xor r9, r9 ; Set R9 to 0 -.def_common: - ; Define a new symbol in current environment - ; If R9 is set to 1 then defmacro - - ; Next item should be a symbol - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Now should have a symbol - - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - jne .def_error_expecting_symbol - mov r8, [rsi + Cons.car] ; Symbol (?) - - mov al, BYTE [r8] - cmp al, maltype_symbol - jne .def_error_expecting_symbol - - ; R8 now contains a symbol - - ; expecting a value or pointer next - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a pointer - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .def_pointer - - ; A value, so copy - - ; Test if this is defmacro! - test r9, r9 - jnz .defmacro_not_function - - push rax - call alloc_cons - pop rbx ; BL now contains type - and bl, content_mask - add bl, (block_cons + container_value) - mov [rax], BYTE bl - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - mov rsi, rax - - jmp .def_got_value - -.def_pointer: - ; A pointer, so evaluate - - ; This may throw an error, so define a handler - - push r8 ; the symbol - push r15 ; Env - push r9 - mov rsi, [rsi + Cons.car] ; Pointer - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call incref_object ; AST increment refs - - call eval - mov rsi, rax - - pop r9 - - ; If this is defmacro, and the object in RSI is a function, - ; then change to a macro - test r9, r9 - jz .def_not_macro ; Not defmacro - - ; Check RSI - mov al, BYTE [rsi] - cmp al, maltype_function - jne .defmacro_not_function - - ; Got a function, change to macro - mov [rsi], BYTE maltype_macro - -.def_not_macro: - - pop r15 - pop r8 - -.def_got_value: - ; Symbol in R8, value in RSI - mov rdi, r8 ; key (symbol) - mov rcx, rsi ; Value - mov rsi, r15 ; Environment - call env_set - - mov rax, rcx - jmp .return - -.def_error_missing_arg: - mov rsi, def_missing_arg_string - mov rdx, def_missing_arg_string.len - jmp .def_handle_error - -.def_error_expecting_symbol: - mov rsi, def_expecting_symbol_string - mov rdx, def_expecting_symbol_string.len - jmp .def_handle_error - -.defmacro_not_function: - mov rsi, defmacro_expecting_function_string - mov rdx, defmacro_expecting_function_string.len - jmp .def_handle_error - -.def_handle_error: - push rsi - push rdx - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - xor rsi, rsi ; no object to throw - jmp error_throw ; No return - - ; ----------------------------- -.let_symbol: - ; Create a new environment - - mov r11, rsi ; Let form in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - mov r14, rax ; New environment in R14 - - mov rsi, r15 - call release_object ; Decrement R15 ref count - - ; Second element should be the bindings - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_bindings - mov r11, [r11 + Cons.cdr] - - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .let_error_bindings_list - - mov r12, [r11 + Cons.car] ; should be bindings list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - ; Can be either a list or vector - cmp al, block_cons + container_list - je .let_bind_loop - cmp al, block_cons + container_vector - je .let_bind_loop - - ; Not a list or vector - jmp .let_error_bindings_list - -.let_bind_loop: - ; R12 now contains a list with an even number of items - ; The first should be a symbol, then a value to evaluate - - ; Get the symbol - mov al, BYTE [r12] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_symbol - - mov r13, [r12 + Cons.car] ; Symbol (?) - mov al, BYTE [r13] - cmp al, maltype_symbol - jne .let_error_bind_symbol - - ; R13 now contains a symbol to bind - ; The next item in the bindings list (R12) - ; should be a value or expression to evaluate - - mov al, BYTE [r12 + Cons.typecdr] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_value - mov r12, [r12 + Cons.cdr] - - ; got value in R12 - - ; Check the type of the value - mov bl, [r12 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .let_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r12 + Cons.typecar] - and bl, content_mask - ;or bl, (block_cons + container_value) ; 0 - mov [rax + Cons.typecar], bl - mov rcx, [r12 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .let_got_value - -.let_value_pointer: - ; A pointer, so need to evaluate - push r11 ; let* form list - push r12 ; Position in bindings list - push r13 ; symbol to bind - push r14 ; new environment - - mov rsi, r14 - call incref_object - mov rdi, r14 - - mov rsi, [r12 + Cons.car] ; Get the address - - call incref_object ; Increment ref count of AST - - call eval ; Evaluate it, result in rax - pop r14 - pop r13 - pop r12 - pop r11 - -.let_got_value: - - mov rsi, r14 ; Env - mov rdi, r13 ; key - mov rcx, rax ; value - call env_set - - ; Release the value - mov rsi, rcx ; The value - call release_object - - ; Check if there are more bindings - mov al, BYTE [r12 + Cons.typecdr] - cmp al, content_pointer - jne .let_done_binding - mov r12, [r12 + Cons.cdr] ; Next - jmp .let_bind_loop - -.let_done_binding: - ; Done bindings. - ; Evaluate next item in let* form in new environment - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_body - mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate - ; Check type of the value - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - je .body_pointer - - ; Just a value, so copy - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl ; set type - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx ; copy value - jmp .let_done - -.body_pointer: - ; Evaluate using new environment - - mov rsi, [r11 + Cons.car] ; Object pointed to - call incref_object ; will be released by eval - - mov r11, rsi ; save new AST - pop rsi ; Old AST - call release_object - mov rsi, r11 ; New AST - - mov rdi, r14 ; New environment - - jmp eval ; Tail call - ; Note: eval will release the new environment on return - -.let_done: - ; Release the new environment - push rax - mov rsi, r14 - call release_object - pop rax - - ; Release the AST - pop rsi - push rax - call release_object - pop rax - ret ; already released env - -.let_error_missing_bindings: - mov rsi, let_missing_bindings_string - mov rdx, let_missing_bindings_string.len - jmp .let_handle_error - -.let_error_bindings_list: ; expected a list or vector, got something else - mov rsi, let_bindings_list_string - mov rdx, let_bindings_list_string.len - jmp .let_handle_error - -.let_error_bind_symbol: ; expected a symbol, got something else - mov rsi, let_bind_symbol_string - mov rdx, let_bind_symbol_string.len - jmp .let_handle_error - -.let_error_bind_value: ; Missing value in binding list - mov rsi, let_bind_value_string - mov rdx, let_bind_value_string.len - jmp .let_handle_error - -.let_error_missing_body: ; Missing body to evaluate - mov rsi, let_missing_body_string - mov rdx, let_missing_body_string.len - jmp .let_handle_error - -.let_handle_error: - push r11 ; For printing later - - push rsi - push rdx - - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - pop rsi ; let* form - jmp error_throw ; No return - - ; ----------------------------- - -.do_symbol: - mov r11, rsi ; do form in RSI - ; Environment in R15 - - ; Check if there is a body - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .do_no_body ; error - - mov r11, [r11 + Cons.cdr] ; Body in R11 - -.do_symbol_loop: - - ; Need to test if this is the last form - ; so we can handle tail call - - mov bl, BYTE [r11 + Cons.typecdr] - cmp bl, content_pointer - jne .do_body_last ; Last expression - - ; not the last expression - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_next ; A value, so skip - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - ; since eval will release Env - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increment ref count since eval will release - - mov rdi, r15 ; Env - call eval ; Result in RAX - - ; Another form after this. - ; Discard the result of the last eval - mov rsi, rax - call release_object - - pop r11 - pop r15 - -.do_next: - mov r11, [r11 + Cons.cdr] ; Next in list - - jmp .do_symbol_loop - -.do_body_last: - ; The last form is in R11, which will be returned - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_body_value_return - jmp .do_body_expr_return - -.do_body_value_return: - ; Got a value as last form (in R11). - ; Copy and return - - push rax ; Type of value to return - - ; release Env - mov rsi, r15 - call release_object - - ; Allocate a Cons object to hold value - call alloc_cons - pop rbx ; type in BL - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - ; release the AST - pop rsi - mov r15, rax ; not modified by release - call release_object - mov rax, r15 - - ret - -.do_body_expr_return: - ; An expression to evaluate as the last form - ; Tail call optimise, jumping to eval - ; Don't increment Env reference count - - mov rsi, [r11 + Cons.car] ; new AST form - call incref_object ; This will be released by eval - - mov r11, rsi ; Save new AST - pop rsi ; Remove old AST from stack - call release_object - mov rsi, r11 - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.do_no_body: - ; No expressions to evaluate. Return nil - - mov rsi, r15 - call release_object ; Release Env - - ; release the AST - pop rsi - call release_object - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - ; ----------------------------- - -.if_symbol: - mov r11, rsi ; if form in R11 - ; Environment in R15 - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .if_no_condition - - mov r11, [r11 + Cons.cdr] ; Should be a condition - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .if_cond_value - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increase Form/AST ref count - - mov rdi, r15 ; Env - call eval ; Result in RAX - pop r11 - pop r15 - - ; Get type of result - mov bl, BYTE [rax] - - ; release value - push rbx - mov rsi, rax - call release_object - pop rbx - - ; Check type - cmp bl, maltype_nil - je .if_false - cmp bl, maltype_false - je .if_false - - jmp .if_true - -.if_cond_value: - - ; A value - cmp al, content_nil - je .if_false - cmp al, content_false - je .if_false - - jmp .if_true - -.if_false: - ; Skip the next item - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil - - mov r11, [r11 + Cons.cdr] - -.if_true: - ; Get the next item in the list and evaluate it - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; Nothing to return - - mov r11, [r11 + Cons.cdr] - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - je .if_got_pointer - -.if_got_value: - ; copy value in r11 - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - jmp .return - -.if_got_pointer: - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Will be released by eval - - mov r11, rsi - pop rsi - call release_object ; Release old AST - mov rsi, r11 ; New AST - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.if_no_condition: ; just (if) without a condition - - print_str_mac error_string - print_str_mac if_missing_condition_string - - ; Release environment - mov rsi, r15 - call release_object - xor rsi, rsi ; No object to throw - jmp error_throw - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - -.return: - ; Release environment - mov rsi, r15 - mov r15, rax ; Save RAX (return value) - call release_object - - ; Release the AST - pop rsi ; Pushed at start of eval - call release_object - - mov rax, r15 ; return value - ret - - ; ----------------------------- - -.fn_symbol: - mov r11, rsi ; fn form in R11 - ; Environment in R15 - - ; Get the binds and body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_empty - - mov r11, [r11 + Cons.cdr] - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_binds_not_list - - mov r12, [r11 + Cons.car] ; Should be binds list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - cmp al, (block_cons + container_list) - je .fn_got_binds ; Can be list - cmp al, (block_cons + container_vector) - je .fn_got_binds ; or vector - jmp .fn_binds_not_list - -.fn_got_binds: - - ; Next get the body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_no_body - - mov r11, [r11 + Cons.cdr] - ; Check value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_is_value ; Body in r11 - mov r11, [r11 + Cons.car] - jmp .fn_got_body - -.fn_is_value: - ; Body is just a value, no expression - mov [r11], BYTE al ; Mark as value, not list - -.fn_got_body: - - ; Now put into function type - ; Addr is "apply_fn", the address to call - ; Env in R15 - ; Binds in R12 - ; Body in R11 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_function) - mov rbx, apply_fn - mov [rax + Cons.car], rbx ; Address of apply function - mov [rax + Cons.typecdr], BYTE content_pointer - - mov r13, rax ; Return list in R13 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r15 ; Environment - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r13 + Cons.cdr], rax ; Append to list - mov r14, rax ; R14 contains last cons in list - - push rax - mov rsi, r15 - call incref_object - pop rax - - ; Binds - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r12 ; Binds list - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r14 + Cons.cdr], rax ; Append to list - mov r14, rax - - push rax - mov rsi, r12 - call incref_object - pop rax - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r11 ; Body of function - - mov [r14 + Cons.cdr], rax - - mov rsi, r11 - call incref_object - - mov rax, r13 - jmp .return - -.fn_empty: -.fn_binds_not_list: -.fn_no_body: - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - jmp .return - - ; ----------------------------- - -.quote_symbol: - ; Just return the arguments in rsi cdr - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; quote empty, so return nil - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .quote_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.quote_pointer: - ; RSI contains a pointer, so get the object pointed to - mov rsi, [rsi + Cons.car] - call incref_object - mov rax, rsi - jmp .return - - ; ----------------------------- - -;;; Like quasiquote, but do not evaluate the result. -.quasiquoteexpand_symbol: - ;; Return nil if no cdr - mov cl, BYTE [rsi + Cons.typecdr] - cmp cl, content_pointer - jne .return_nil - - mov rsi, [rsi + Cons.cdr] - call car_and_incref - call quasiquote - jmp .return - - ; ----------------------------- - -.quasiquote_symbol: - ; call quasiquote function with first argument - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; quasiquote empty, so return nil - - mov r11, rsi ; Save original AST in R11 - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .quasiquote_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.quasiquote_pointer: - ; RSI contains a pointer, so get the object pointed to - mov rsi, [rsi + Cons.car] - - push r15 ; Environment - ; Original AST already on stack - - call quasiquote - ; New AST in RAX - pop rdi ; Environment - pop rsi ; Old AST - - mov r11, rax ; New AST - call release_object ; Release old AST - mov rsi, r11 ; New AST in RSI - - jmp eval ; Tail call - - ; ----------------------------- -.macroexpand_symbol: - ; Check if we have a second list element - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; No argument - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .macroexpand_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.macroexpand_pointer: - mov rsi, [rsi + Cons.car] - call incref_object ; Since RSI will be released - - call macroexpand ; May release and replace RSI - - mov rax, rsi - jmp .return ; Releases original AST - - ; ----------------------------- - -.try_symbol: - ; Should have the form - ; - ; (try* A (catch* B C)) - ; - ; where B is a symbol, A and C are forms to evaluate - - ; Check first arg A - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; No argument - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .try_pointer - - ; RSI contains a value. Copy and return - mov cl, al - call alloc_cons - mov [rax], BYTE cl ; Set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx - jmp .return - -.try_pointer: - - mov r8, [rsi + Cons.car] ; form A in R8 - - ; Check second arg B - - mov al, BYTE [rsi + Cons.typecdr] - ; If nil (catchless try) - cmp al, content_nil - je .catchless_try - - cmp al, content_pointer - jne .try_missing_catch - - mov rsi, [rsi + Cons.cdr] - - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .try_missing_catch - - mov r9, [rsi + Cons.car] ; (catch* B C) in R9 - - mov al, BYTE [r9] - cmp al, (container_list + content_pointer) - jne .try_missing_catch - - mov rsi, [r9 + Cons.car] ; Should be catch* symbol - mov al, BYTE [rsi] - cmp al, maltype_symbol - jne .try_missing_catch - - mov rdi, catch_symbol - call compare_char_array - test rax, rax ; ZF set if rax = 0 (equal) - jnz .try_missing_catch - - ; Check that B is a symbol - mov al, [r9 + Cons.typecdr] - cmp al, content_pointer - jne .catch_missing_symbol - - mov r9, [r9 + Cons.cdr] ; (B C) in R9 - - mov al, BYTE [r9] - and al, content_mask - cmp al, content_pointer - jne .catch_missing_symbol - - mov r10, [r9 + Cons.car] ; B in R10 - mov al, BYTE [r10] - cmp al, maltype_symbol - jne .catch_missing_symbol - - mov al, BYTE [r9 + Cons.typecdr] - cmp al, content_pointer - jne .catch_missing_form - mov r9, [r9 + Cons.cdr] ; C in R9 - - ; Now have extracted from (try* A (catch* B C)) - ; A in R8 - ; B in R10 - ; C in R9 - - push R9 - push R10 - push r15 ; Env - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; Evaluate the form in R8 - mov rsi, r15 - call incref_object ; Env released by eval - mov rdi, r15 ; Env in RDI - - mov rsi, r8 ; The form to evaluate (A) - - call incref_object ; AST released by eval - - call eval - - mov r8, rax ; Result in R8 - - pop r15 ; Environment - ; Discard B and C - ;add rsi, 8 ; pop R10 and R9 - pop r10 - pop r9 - - ; Remove error handler - call error_handler_pop - mov rax, r8 - jmp .return - -.catchless_try: - ;; Evaluate the form in R8 - push r15 ; Environment - - mov rsi, r15 - call incref_object ; Env released by eval - mov rdi, r15 ; Env in RDI - - mov rsi, r8 ; The form to evaluate (A) - - call incref_object ; AST released by eval - - call eval ; Result in RAX - - pop r15 ; Environment - - jmp .return -.catch: - ; Jumps here on error - ; Value thrown in RSI - ; - - push rsi - call error_handler_pop - pop rsi - - pop r15 ; Env - pop r12 ; B (symbol to bind) - pop r13 ; C (form to evaluate) - - ; Check if C is a value or pointer - - mov cl, BYTE [r13] - and cl, content_mask - cmp cl, content_pointer - je .catch_C_pointer - - ; A value, so copy and return - call alloc_cons - mov [rax], BYTE cl ; Set type - mov rbx, [r13 + Cons.car] - mov [rax + Cons.car], rbx ; Set value - - jmp .return - -.catch_C_pointer: - - mov r11, rsi ; Value thrown in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - - mov rsi, rax ; New environment in RSI - mov rdi, r12 ; key (symbol) - mov rcx, r11 ; value - call env_set - - mov rdi, rsi ; Env in RDI (will be released) - mov rsi, [r13 + Cons.car] ; Form to evaluate - call incref_object ; will be released - - push r15 - call eval - pop r15 - - jmp .return - -.try_missing_catch: - load_static try_missing_catch - call raw_to_string - mov rsi, rax - jmp error_throw - -.catch_missing_symbol: - load_static catch_missing_symbol - call raw_to_string - mov rsi, rax - jmp error_throw - -.catch_missing_form: - load_static catch_missing_form - call raw_to_string - mov rsi, rax - jmp error_throw - - ; ----------------------------- - -.list_eval: - push rsi - mov rdi, r15 ; Environment - push r15 - call eval_ast ; List of evaluated forms in RAX - pop r15 - pop rsi - -.list_exec: - ; This point can be called to run a function - ; used by swap! - ; - ; Inputs: RAX - List with function as first element - ; NOTE: This list is released - ; - ; Check that the first element of the return is a function - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .list_not_function - - mov rbx, [rax + Cons.car] ; Get the address - mov cl, BYTE [rbx] - cmp cl, maltype_function - jne .list_not_function - - ; Check the rest of the args - mov cl, BYTE [rax + Cons.typecdr] - cmp cl, content_pointer - je .list_got_args - - ; No arguments - push rbx ; Function object - push rax ; List with function first - - ; Create an empty list for the arguments - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax ; Argument list into RSI - - pop rax ; list, function first - ;; Put new empty list onto end of original list - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rsi - - pop rbx - jmp .list_function_call -.list_got_args: - mov rsi, [rax + Cons.cdr] ; Rest of list -.list_function_call: - ; Call the function with the rest of the list in RSI - - mov rdx, rax ; List to release - mov rdi, rbx ; Function object in RDI - - mov rbx, [rbx + Cons.car] ; Call function - cmp rbx, apply_fn - je apply_fn_jmp ; Jump to user function apply - - ; A built-in function, so call (no recursion) - push rax - push r15 - - call rbx - - ; Result in rax - pop r15 - pop rsi ; eval'ed list - - push rax - call release_cons - pop rax - jmp .return ; Releases Env - -.list_not_function: - ; Not a function. Probably an error - push rsi - - mov rsi, rax - call release_object - - print_str_mac error_string - print_str_mac eval_list_not_function - pop rsi - jmp error_throw - -.empty_list: - mov rax, rsi - jmp .return - -;; Applies a user-defined function -;; -;; Input: RSI - Arguments to bind -;; RDI - Function object -;; RDX - list to release after binding -;; R15 - Env (will be released) -;; R13 - AST released before return -;; -;; -;; Output: Result in RAX -;; -;; This is jumped to from eval, so if it returns -;; then it will return to the caller of eval, not to eval -apply_fn_jmp: - ; This is jumped to from eval with AST on the stack - pop r13 -apply_fn: - push rsi - ; Extract values from the list in RDI - mov rax, [rdi + Cons.cdr] - mov rsi, [rax + Cons.car] ; Env - mov rax, [rax + Cons.cdr] - mov rdi, [rax + Cons.car] ; Binds - mov rax, [rax + Cons.cdr] - mov rax, [rax + Cons.car] ; Body - pop rcx ; Exprs - - ; Check the type of the body - mov bl, BYTE [rax] - and bl, block_mask + container_mask - jnz .bind - ; Just a value (in RAX). No eval needed - - mov r14, rax ; Save return value in R14 - - mov rsi, rax - call incref_object - - ; Release the list passed in RDX - mov rsi, rdx - call release_object - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the AST - mov rsi, r13 - call release_object - - mov rax, r14 - ret -.bind: - ; Create a new environment, binding arguments - push rax ; Body - - mov r14, r13 ; Old AST. R13 used by env_new_bind - - push rdx - call env_new_bind - pop rdx - - mov rdi, rax ; New environment in RDI - - ; Note: Need to increment the reference count - ; of the function body before releasing anything, - ; since if the function was defined in-place (lambda) - ; then the body may be released early - - pop rsi ; Body - call incref_object ; Will be released by eval - mov r8, rsi ; Body in R8 - - ; Release the list passed in RDX - mov rsi, rdx - call release_cons - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the old AST - mov rsi, r14 - call release_object - - mov rsi, r8 ; Body - - jmp eval ; Tail call - ; The new environment (in RDI) will be released by eval - - -;;; Called by eval -;;; Original AST in RSI. -;;; Returns new AST in RAX -quasiquote: - ;; Dispatch on the type. - mov al, BYTE [rsi + Cons.typecar] - mov cl, al ; keep full al for .list - and cl, container_mask - cmp cl, container_list - je .list - cmp cl, container_map - je .map - cmp cl, container_symbol - je .symbol - cmp cl, container_vector - je .vector - ;; return other types unchanged - call incref_object - mov rax, rsi - ret - -.list: - ;; AST is a list, process it with qq_foldr unless.. - mov cl, al ; it is not empty, - and cl, content_mask - cmp cl, content_empty - je qq_foldr - - cmp cl, content_pointer ; and it is a pointer, - jne qq_foldr - - mov rdi, [rsi + Cons.car] ; and the first element is a symbol, - mov cl, BYTE [rdi + Cons.typecar] - cmp cl, maltype_symbol - jne qq_foldr - - mov r8, rsi ; and the symbol is 'unquote, - mov rsi, unquote_symbol - call compare_char_array - test rax, rax - mov rsi, r8 - jne qq_foldr - - mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. - cmp cl, content_pointer - jne qq_foldr - - ;; If so, return the argument. - mov rsi, [rsi + Cons.cdr] - call car_and_incref - mov rax, rsi - ret - -.map: -.symbol: - call incref_object - - ;; rdx := (ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rsi - mov rdx, rax - - mov rsi, quote_symbol - call incref_object - - ;; rax := ('quote ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - -.vector: - ;; rdx := ast processed like a list - call qq_foldr - mov rdx, rax - - ;; rdx := (processed_ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdx - mov rdx, rax - - mov rsi, vec_symbol - call incref_object - - ;; rax := ('vec processed_ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - - -;;; Helper for quasiquote. -;;; RSI must contain a list or vector, which may be empty. -;;; The result in RAX is always a list. -;;; Iterate on the elements in the right fold/reduce style. -qq_foldr: - mov cl, BYTE [rsi + Cons.typecar] - - cmp cl, maltype_empty_list - je .empty_list - - cmp cl, maltype_empty_vector - je .empty_vector - - ;; Extract first element and store it into the stack during - ;; the recursion. - mov rdx, rsi - call car_and_incref - push rsi - mov rsi, rdx - - ;; Extract the rest of the list. - mov al, BYTE [rsi + Cons.typecdr] - -;;; If the rest is not empty - cmp al, content_pointer - jne .else -;;; then - mov rsi, [rsi + Cons.cdr] - jmp .endif -.else: - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax -.endif: - call qq_foldr ; recursive call - pop rsi - jmp qq_loop - -.empty_list: ;; () -> () - call incref_object - mov rax, rsi - ret - -.empty_vector: ;; [] -> () - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - - -;; Helper for quasiquote -;; The transition function starts here. -;; Current element is in rsi, accumulator in rax. -qq_loop: - mov r9, rax - - ;; Process with the element with .default, unless.. - mov cl, BYTE [rsi + Cons.typecar] ; it is a list - mov al, cl - and al, container_mask - cmp al, container_list - jne .default - - cmp cl, maltype_empty_list ; it is not empty, - je .default - - and cl, content_mask ; and it is a pointer, - cmp cl, content_pointer - jne .default - - mov rdi, [rsi + Cons.car] ; and the first element is a symbol, - mov cl, BYTE [rdi + Cons.typecar] - cmp cl, maltype_symbol - jne .default - - mov r8, rsi ; and the symbol is 'splice-unquote, - mov rsi, splice_unquote_symbol - call compare_char_array - test rax, rax - mov rsi, r8 - jne .default - - mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. - cmp cl, content_pointer - jne .default - - ;; If so, return ('concat elt acc). - mov rsi, [rsi + Cons.cdr] - call car_and_incref - - ;; rdx := (acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.car], r9 - mov rdx, rax - - ;; rdx := (elt acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - mov rdx, rax - - mov rsi, concat_symbol - call incref_object - - ;; rax := ('concat elt acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - -.default: - ;; rax := (accumulator) - call alloc_cons - mov [rax + Cons.typecar], BYTE (container_list + content_pointer) - mov [rax + Cons.car], r9 - - ;; rcx := quasiquoted_element - ;; rdx := (accumulator) - push rax - call quasiquote - mov rcx, rax - pop rdx - - ;; rdx := (quasiquoted_element accumulator) - call alloc_cons - mov [rax + Cons.typecar], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rcx - mov [rax + Cons.cdr], rdx - mov rdx, rax - - mov rsi, cons_symbol - call incref_object - - ;; rax := ('cons quasiquoted_elt accumulator) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - - -;; Tests if an AST in RSI is a list containing -;; a macro defined in the ENV in R15 -;; -;; Inputs: AST in RSI (not modified) -;; ENV in R15 (not modified) -;; -;; Returns: Sets ZF if macro call. If set (true), -;; then the macro object is in RAX -;; -;; Modifies: -;; RAX -;; RBX -;; RCX -;; RDX -;; R8 -;; R9 -is_macro_call: - ; Test if RSI is a list which contains a pointer - mov al, BYTE [rsi] - cmp al, (block_cons + container_list + content_pointer) - jne .false - - ; Test if this is a symbol - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .false - - ; Look up symbol in Env - push rsi - push r15 - mov rdi, rbx ; symbol in RDI - mov rsi, r15 ; Environment in RSI - call env_get - pop r15 - pop rsi - jne .false ; Not in environment - - ; Object in RAX - ; If this is not a macro then needs to be released - mov dl, BYTE [rax] - - cmp dl, maltype_macro - je .true - - ; Not a macro, so release - mov r8, rsi - mov rsi, rax - call release_object - mov rsi, r8 - -.false: - lahf ; flags in AH - and ah, 255-64 ; clear zero flag - sahf - ret -.true: - mov rbx, rax ; Returning Macro object - lahf ; flags in AH - or ah, 64 ; set zero flag - sahf - mov rax, rbx - ret - -;; Expands macro calls -;; -;; Input: AST in RSI (released and replaced) -;; Env in R15 (not modified) -;; -;; Result: New AST in RSI -macroexpand: - push r15 - - call is_macro_call - jne .done - - mov r13, rsi - - mov rdi, rax ; Macro in RDI - - ; Check the rest of the args - mov cl, BYTE [rsi + Cons.typecdr] - cmp cl, content_pointer - je .got_args - - ; No arguments. Create an empty list - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rdx, rax - - mov rsi, rdx ; Arguments (empty list) - call incref_object - jmp .macro_call -.got_args: - mov rsi, [rsi + Cons.cdr] ; Rest of list - call incref_object - mov rdx, rsi ; Released -.macro_call: - ; Here have: - ; RSI - Arguments - ; RDI - Macro object - ; RDX - List to release - ; R15 - Environment - ; R13 - AST - - ; Increment reference for Environment - ; since this will be released by apply_fn - xchg rsi, r15 - call incref_object - xchg rsi, r15 - - call apply_fn - - mov rsi, rax ; Result in RSI - - pop r15 - jmp macroexpand -.done: - pop r15 - ret - -;; Read and eval -read_eval: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - jmp eval ; This releases Env and Form/AST - - -;; Read-Eval-Print in sequence -;; -;; Input string in RSI -rep_seq: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call eval ; This releases Env and Form/AST - push rax ; Save result of eval - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - mov rdi, 1 ; print readably - call pr_str ; String in RAX - - mov r8, rax ; Save output - - pop rsi ; Result from eval - call release_object - mov rax, r8 - - ret - - -_start: - ; Create and print the core environment - call core_environment ; Environment in RAX - - mov [repl_env], rax ; store in memory - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; Evaluate the startup string - - mov rsi, mal_startup_string - mov edx, mal_startup_string.len - call raw_to_string ; String in RAX - - push rax - mov rsi, rax - call read_str ; AST in RAX - pop rsi ; string - - push rax ; AST - call release_array ; string - pop rdi ; AST in RDI - - mov rsi, [repl_env] ; Environment in RSI - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call eval - - mov rsi, rax - call release_object ; Return from eval - - ; ----------------------------- - ; Check command-line arguments - - pop rax ; Number of arguments - cmp rax, 1 ; Always have at least one, the path to executable - jg run_script - - ; No extra arguments, so just set *ARGV* to an empty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov rcx, rax ; value (empty list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - -.catch: - ; Jumps here on error - - ; Check if an object was thrown - cmp rsi, 0 - je .catch_done_print ; nothing to print - - push rsi - print_str_mac error_string ; print 'Error: ' - pop rsi - - mov rdi, 1 - call pr_str - mov rsi, rax - call print_string -.catch_done_print: - jmp .mainLoop ; Go back to the prompt - - - -run_script: - ; Called with number of command-line arguments in RAX - mov r8, rax - pop rbx ; executable - dec r8 - - pop rsi ; Address of first arg - call cstring_to_string ; string in RAX - mov r9, rax - - ; get the rest of the args - xor r10, r10 ; Zero - dec r8 - jz .no_args - - ; Got some arguments -.arg_loop: - ; Got an argument left. - pop rsi ; Address of C string - call cstring_to_string ; String in RAX - mov r12, rax - - ;Make a Cons to point to the string - call alloc_cons ; in RAX - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], r12 - - test r10, r10 - jnz .append - - ; R10 zero, so first arg - mov r10, rax ; Head of list - mov r11, rax ; Tail of list - jmp .next -.append: - ; R10 not zero, so append to list tail - mov [r11 + Cons.cdr], rax - mov [r11 + Cons.typecdr], BYTE content_pointer - mov r11, rax -.next: - dec r8 - jnz .arg_loop - jmp .got_args - -.no_args: - ; No arguments. Create an emoty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov r10, rax - -.got_args: - push r9 ; File name string - - mov rcx, r10 ; value (list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - mov rsi, run_script_string ; load-file function - mov edx, run_script_string.len - call raw_to_string ; String in RAX - - mov rsi, rax - pop rdx ; File name string - call string_append_string - - mov cl, 34 ; " - call string_append_char - mov cl, ')' - call string_append_char ; closing brace - - ; Read-Eval "(load-file )" - call read_eval - - jmp quit +;; +;; nasm -felf64 step9_try.asm && ld step9_try.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static defmacro_expecting_function_string, db "defmacro expects function",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + + static try_missing_catch, db "try* missing catch*" + static catch_missing_symbol, db "catch* missing symbol" + static catch_missing_form, db "catch* missing form" + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + static_symbol defmacro_symbol, 'defmacro!' + static_symbol macroexpand_symbol, 'macroexpand' + static_symbol try_symbol, 'try*' + static_symbol catch_symbol, 'catch*' + + static_symbol argv_symbol, '*ARGV*' + + static_symbol quote_symbol, 'quote' + static_symbol quasiquote_symbol, 'quasiquote' + static_symbol quasiquoteexpand_symbol, 'quasiquoteexpand' + static_symbol unquote_symbol, 'unquote' + static_symbol splice_unquote_symbol, 'splice-unquote' + static_symbol concat_symbol, 'concat' + static_symbol cons_symbol, 'cons' + static_symbol vec_symbol, 'vec' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do \ +(def! not (fn* (a) (if a false true))) \ +(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ +(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) \ +)" + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 +section .text + + +;;; Extract the car of a Cons and increment its reference count. +;;; If it was value, create a fresh copy. +;;; in : rsi (which must be a pointer!) +;;; out : rsi +;;; modified: : cl, rax, rbx +car_and_incref: + mov cl, BYTE [rsi + Cons.typecar] + and cl, content_mask + + mov rsi, [rsi + Cons.car] + + cmp cl, content_pointer + je incref_object + + call alloc_cons + mov [rax + Cons.typecar], BYTE cl ; masked above + mov [rax + Cons.car], rsi + mov rsi, rax + ret + + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + mov r11, rsi ; Symbol in R11 + + call string_new + mov rsi, rax ; New string in RSI + + mov cl, 39 ; quote ' + call string_append_char + + mov rdx, r11 ; symbol + call string_append_string + + mov cl, 39 + call string_append_char + + mov r11, rsi + + mov rsi, not_found_string + mov edx, not_found_string.len + call raw_to_string ; ' not found' + + mov r12, rax + + mov rdx, rax + mov rsi, r11 + call string_append_string + + mov r11, rsi + mov rsi, r12 + call release_array + mov rsi, r11 + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] +;; +;; Returns: Result in RAX +;; +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) +;; +eval: + mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Macro expand + pop rax ; Old AST, discard from stack + call macroexpand ; Replaces RSI + push rsi ; New AST + + ; Check if RSI is a list, and if + ; the first element is a symbol + mov al, BYTE [rsi] + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list_still_list + + ; Not a list, so call eval_ast on it + mov rdi, r15 ; Environment + call eval_ast + jmp .return + +.list_still_list: + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + eval_cmp_symbol quote_symbol ; quote + je .quote_symbol + + eval_cmp_symbol quasiquoteexpand_symbol + je .quasiquoteexpand_symbol + + eval_cmp_symbol quasiquote_symbol ; quasiquote + je .quasiquote_symbol + + eval_cmp_symbol defmacro_symbol ; defmacro! + je .defmacro_symbol + + eval_cmp_symbol macroexpand_symbol ; macroexpand + je .macroexpand_symbol + + eval_cmp_symbol try_symbol ; try* + je .try_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.defmacro_symbol: + mov r9, 1 + jmp .def_common +.def_symbol: + xor r9, r9 ; Set R9 to 0 +.def_common: + ; Define a new symbol in current environment + ; If R9 is set to 1 then defmacro + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + + ; Test if this is defmacro! + test r9, r9 + jnz .defmacro_not_function + + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + push r9 + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs + + call eval + mov rsi, rax + + pop r9 + + ; If this is defmacro, and the object in RSI is a function, + ; then change to a macro + test r9, r9 + jz .def_not_macro ; Not defmacro + + ; Check RSI + mov al, BYTE [rsi] + cmp al, maltype_function + jne .defmacro_not_function + + ; Got a function, change to macro + mov [rsi], BYTE maltype_macro + +.def_not_macro: + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.defmacro_not_function: + mov rsi, defmacro_expecting_function_string + mov rdx, defmacro_expecting_function_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + ; release the AST + pop rsi + call release_object + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + ; Release environment + mov rsi, r15 + mov r15, rax ; Save RAX (return value) + call release_object + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append to list + mov r14, rax ; R14 contains last cons in list + + push rax + mov rsi, r15 + call incref_object + pop rax + + ; Binds + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + ; ----------------------------- + +.quote_symbol: + ; Just return the arguments in rsi cdr + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quote empty, so return nil + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + jmp .return + + ; ----------------------------- + +;;; Like quasiquote, but do not evaluate the result. +.quasiquoteexpand_symbol: + ;; Return nil if no cdr + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .return_nil + + mov rsi, [rsi + Cons.cdr] + call car_and_incref + call quasiquote + jmp .return + + ; ----------------------------- + +.quasiquote_symbol: + ; call quasiquote function with first argument + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quasiquote empty, so return nil + + mov r11, rsi ; Save original AST in R11 + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quasiquote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quasiquote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + + push r15 ; Environment + ; Original AST already on stack + + call quasiquote + ; New AST in RAX + pop rdi ; Environment + pop rsi ; Old AST + + mov r11, rax ; New AST + call release_object ; Release old AST + mov rsi, r11 ; New AST in RSI + + jmp eval ; Tail call + + ; ----------------------------- +.macroexpand_symbol: + ; Check if we have a second list element + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .macroexpand_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.macroexpand_pointer: + mov rsi, [rsi + Cons.car] + call incref_object ; Since RSI will be released + + call macroexpand ; May release and replace RSI + + mov rax, rsi + jmp .return ; Releases original AST + + ; ----------------------------- + +.try_symbol: + ; Should have the form + ; + ; (try* A (catch* B C)) + ; + ; where B is a symbol, A and C are forms to evaluate + + ; Check first arg A + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .try_pointer + + ; RSI contains a value. Copy and return + mov cl, al + call alloc_cons + mov [rax], BYTE cl ; Set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + jmp .return + +.try_pointer: + + mov r8, [rsi + Cons.car] ; form A in R8 + + ; Check second arg B + + mov al, BYTE [rsi + Cons.typecdr] + ; If nil (catchless try) + cmp al, content_nil + je .catchless_try + + cmp al, content_pointer + jne .try_missing_catch + + mov rsi, [rsi + Cons.cdr] + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .try_missing_catch + + mov r9, [rsi + Cons.car] ; (catch* B C) in R9 + + mov al, BYTE [r9] + cmp al, (container_list + content_pointer) + jne .try_missing_catch + + mov rsi, [r9 + Cons.car] ; Should be catch* symbol + mov al, BYTE [rsi] + cmp al, maltype_symbol + jne .try_missing_catch + + mov rdi, catch_symbol + call compare_char_array + test rax, rax ; ZF set if rax = 0 (equal) + jnz .try_missing_catch + + ; Check that B is a symbol + mov al, [r9 + Cons.typecdr] + cmp al, content_pointer + jne .catch_missing_symbol + + mov r9, [r9 + Cons.cdr] ; (B C) in R9 + + mov al, BYTE [r9] + and al, content_mask + cmp al, content_pointer + jne .catch_missing_symbol + + mov r10, [r9 + Cons.car] ; B in R10 + mov al, BYTE [r10] + cmp al, maltype_symbol + jne .catch_missing_symbol + + mov al, BYTE [r9 + Cons.typecdr] + cmp al, content_pointer + jne .catch_missing_form + mov r9, [r9 + Cons.cdr] ; C in R9 + + ; Now have extracted from (try* A (catch* B C)) + ; A in R8 + ; B in R10 + ; C in R9 + + push R9 + push R10 + push r15 ; Env + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the form in R8 + mov rsi, r15 + call incref_object ; Env released by eval + mov rdi, r15 ; Env in RDI + + mov rsi, r8 ; The form to evaluate (A) + + call incref_object ; AST released by eval + + call eval + + mov r8, rax ; Result in R8 + + pop r15 ; Environment + ; Discard B and C + ;add rsi, 8 ; pop R10 and R9 + pop r10 + pop r9 + + ; Remove error handler + call error_handler_pop + mov rax, r8 + jmp .return + +.catchless_try: + ;; Evaluate the form in R8 + push r15 ; Environment + + mov rsi, r15 + call incref_object ; Env released by eval + mov rdi, r15 ; Env in RDI + + mov rsi, r8 ; The form to evaluate (A) + + call incref_object ; AST released by eval + + call eval ; Result in RAX + + pop r15 ; Environment + + jmp .return +.catch: + ; Jumps here on error + ; Value thrown in RSI + ; + + push rsi + call error_handler_pop + pop rsi + + pop r15 ; Env + pop r12 ; B (symbol to bind) + pop r13 ; C (form to evaluate) + + ; Check if C is a value or pointer + + mov cl, BYTE [r13] + and cl, content_mask + cmp cl, content_pointer + je .catch_C_pointer + + ; A value, so copy and return + call alloc_cons + mov [rax], BYTE cl ; Set type + mov rbx, [r13 + Cons.car] + mov [rax + Cons.car], rbx ; Set value + + jmp .return + +.catch_C_pointer: + + mov r11, rsi ; Value thrown in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + + mov rsi, rax ; New environment in RSI + mov rdi, r12 ; key (symbol) + mov rcx, r11 ; value + call env_set + + mov rdi, rsi ; Env in RDI (will be released) + mov rsi, [r13 + Cons.car] ; Form to evaluate + call incref_object ; will be released + + push r15 + call eval + pop r15 + + jmp .return + +.try_missing_catch: + load_static try_missing_catch + call raw_to_string + mov rsi, rax + jmp error_throw + +.catch_missing_symbol: + load_static catch_missing_symbol + call raw_to_string + mov rsi, rax + jmp error_throw + +.catch_missing_form: + load_static catch_missing_form + call raw_to_string + mov rsi, rax + jmp error_throw + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx ; Function object + push rax ; List with function first + + ; Create an empty list for the arguments + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax ; Argument list into RSI + + pop rax ; list, function first + ;; Put new empty list onto end of original list + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rsi + + pop rbx + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn_jmp ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + +.empty_list: + mov rax, rsi + jmp .return + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; R13 - AST released before return +;; +;; +;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + mov r14, rax ; Save return value in R14 + + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the AST + mov rsi, r13 + call release_object + + mov rax, r14 + ret +.bind: + ; Create a new environment, binding arguments + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + + ; Release the list passed in RDX + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;;; Called by eval +;;; Original AST in RSI. +;;; Returns new AST in RAX +quasiquote: + ;; Dispatch on the type. + mov al, BYTE [rsi + Cons.typecar] + mov cl, al ; keep full al for .list + and cl, container_mask + cmp cl, container_list + je .list + cmp cl, container_map + je .map + cmp cl, container_symbol + je .symbol + cmp cl, container_vector + je .vector + ;; return other types unchanged + call incref_object + mov rax, rsi + ret + +.list: + ;; AST is a list, process it with qq_foldr unless.. + mov cl, al ; it is not empty, + and cl, content_mask + cmp cl, content_empty + je qq_foldr + + cmp cl, content_pointer ; and it is a pointer, + jne qq_foldr + + mov rdi, [rsi + Cons.car] ; and the first element is a symbol, + mov cl, BYTE [rdi + Cons.typecar] + cmp cl, maltype_symbol + jne qq_foldr + + mov r8, rsi ; and the symbol is 'unquote, + mov rsi, unquote_symbol + call compare_char_array + test rax, rax + mov rsi, r8 + jne qq_foldr + + mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. + cmp cl, content_pointer + jne qq_foldr + + ;; If so, return the argument. + mov rsi, [rsi + Cons.cdr] + call car_and_incref + mov rax, rsi + ret + +.map: +.symbol: + call incref_object + + ;; rdx := (ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rsi + mov rdx, rax + + mov rsi, quote_symbol + call incref_object + + ;; rax := ('quote ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + +.vector: + ;; rdx := ast processed like a list + call qq_foldr + mov rdx, rax + + ;; rdx := (processed_ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdx + mov rdx, rax + + mov rsi, vec_symbol + call incref_object + + ;; rax := ('vec processed_ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + + +;;; Helper for quasiquote. +;;; RSI must contain a list or vector, which may be empty. +;;; The result in RAX is always a list. +;;; Iterate on the elements in the right fold/reduce style. +qq_foldr: + mov cl, BYTE [rsi + Cons.typecar] + + cmp cl, maltype_empty_list + je .empty_list + + cmp cl, maltype_empty_vector + je .empty_vector + + ;; Extract first element and store it into the stack during + ;; the recursion. + mov rdx, rsi + call car_and_incref + push rsi + mov rsi, rdx + + ;; Extract the rest of the list. + mov al, BYTE [rsi + Cons.typecdr] + +;;; If the rest is not empty + cmp al, content_pointer + jne .else +;;; then + mov rsi, [rsi + Cons.cdr] + jmp .endif +.else: + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax +.endif: + call qq_foldr ; recursive call + pop rsi + jmp qq_loop + +.empty_list: ;; () -> () + call incref_object + mov rax, rsi + ret + +.empty_vector: ;; [] -> () + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + + +;; Helper for quasiquote +;; The transition function starts here. +;; Current element is in rsi, accumulator in rax. +qq_loop: + mov r9, rax + + ;; Process with the element with .default, unless.. + mov cl, BYTE [rsi + Cons.typecar] ; it is a list + mov al, cl + and al, container_mask + cmp al, container_list + jne .default + + cmp cl, maltype_empty_list ; it is not empty, + je .default + + and cl, content_mask ; and it is a pointer, + cmp cl, content_pointer + jne .default + + mov rdi, [rsi + Cons.car] ; and the first element is a symbol, + mov cl, BYTE [rdi + Cons.typecar] + cmp cl, maltype_symbol + jne .default + + mov r8, rsi ; and the symbol is 'splice-unquote, + mov rsi, splice_unquote_symbol + call compare_char_array + test rax, rax + mov rsi, r8 + jne .default + + mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. + cmp cl, content_pointer + jne .default + + ;; If so, return ('concat elt acc). + mov rsi, [rsi + Cons.cdr] + call car_and_incref + + ;; rdx := (acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], r9 + mov rdx, rax + + ;; rdx := (elt acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + mov rdx, rax + + mov rsi, concat_symbol + call incref_object + + ;; rax := ('concat elt acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + +.default: + ;; rax := (accumulator) + call alloc_cons + mov [rax + Cons.typecar], BYTE (container_list + content_pointer) + mov [rax + Cons.car], r9 + + ;; rcx := quasiquoted_element + ;; rdx := (accumulator) + push rax + call quasiquote + mov rcx, rax + pop rdx + + ;; rdx := (quasiquoted_element accumulator) + call alloc_cons + mov [rax + Cons.typecar], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rcx + mov [rax + Cons.cdr], rdx + mov rdx, rax + + mov rsi, cons_symbol + call incref_object + + ;; rax := ('cons quasiquoted_elt accumulator) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + + +;; Tests if an AST in RSI is a list containing +;; a macro defined in the ENV in R15 +;; +;; Inputs: AST in RSI (not modified) +;; ENV in R15 (not modified) +;; +;; Returns: Sets ZF if macro call. If set (true), +;; then the macro object is in RAX +;; +;; Modifies: +;; RAX +;; RBX +;; RCX +;; RDX +;; R8 +;; R9 +is_macro_call: + ; Test if RSI is a list which contains a pointer + mov al, BYTE [rsi] + cmp al, (block_cons + container_list + content_pointer) + jne .false + + ; Test if this is a symbol + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .false + + ; Look up symbol in Env + push rsi + push r15 + mov rdi, rbx ; symbol in RDI + mov rsi, r15 ; Environment in RSI + call env_get + pop r15 + pop rsi + jne .false ; Not in environment + + ; Object in RAX + ; If this is not a macro then needs to be released + mov dl, BYTE [rax] + + cmp dl, maltype_macro + je .true + + ; Not a macro, so release + mov r8, rsi + mov rsi, rax + call release_object + mov rsi, r8 + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + mov rbx, rax ; Returning Macro object + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rbx + ret + +;; Expands macro calls +;; +;; Input: AST in RSI (released and replaced) +;; Env in R15 (not modified) +;; +;; Result: New AST in RSI +macroexpand: + push r15 + + call is_macro_call + jne .done + + mov r13, rsi + + mov rdi, rax ; Macro in RDI + + ; Check the rest of the args + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + je .got_args + + ; No arguments. Create an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rdx, rax + + mov rsi, rdx ; Arguments (empty list) + call incref_object + jmp .macro_call +.got_args: + mov rsi, [rsi + Cons.cdr] ; Rest of list + call incref_object + mov rdx, rsi ; Released +.macro_call: + ; Here have: + ; RSI - Arguments + ; RDI - Macro object + ; RDX - List to release + ; R15 - Environment + ; R13 - AST + + ; Increment reference for Environment + ; since this will be released by apply_fn + xchg rsi, r15 + call incref_object + xchg rsi, r15 + + call apply_fn + + mov rsi, rax ; Result in RSI + + pop r15 + jmp macroexpand +.done: + pop r15 + ret + +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + mov rax, r8 + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call eval + + mov rsi, rax + call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + + push rsi + print_str_mac error_string ; print 'Error: ' + pop rsi + + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval "(load-file )" + call read_eval + + jmp quit diff --git a/impls/nasm/stepA_mal.asm b/impls/nasm/stepA_mal.asm index 571f14cda4..18da6fcf8e 100644 --- a/impls/nasm/stepA_mal.asm +++ b/impls/nasm/stepA_mal.asm @@ -1,2575 +1,2575 @@ -;; -;; nasm -felf64 stepA_mal.asm && ld stepA_mal.o && ./a.out -;; -;; Calling convention: Address of input is in RSI -;; Address of return value is in RAX -;; - -global _start - -%include "types.asm" ; Data types, memory -%include "env.asm" ; Environment type -%include "system.asm" ; System calls -%include "reader.asm" ; String -> Data structures -%include "core.asm" ; Core functions -%include "printer.asm" ; Data structures -> String -%include "exceptions.asm" ; Error handling - -section .bss - -;; Top-level (REPL) environment -repl_env:resq 1 - -section .data - -;; ------------------------------------------ -;; Fixed strings for printing - - static prompt_string, db 10,"user> " ; The string to print at the prompt - - static error_string, db 27,'[31m',"Error",27,'[0m',": " - - static not_found_string, db " not found" - - static def_missing_arg_string, db "missing argument to def!",10 - - static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 - - static defmacro_expecting_function_string, db "defmacro expects function",10 - - static let_missing_bindings_string, db "let* missing bindings",10 - - static let_bindings_list_string, db "let* expected a list or vector of bindings",10 - - static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 - - static let_bind_value_string, db "let* missing value in bindings list",10 - - static let_missing_body_string, db "let* missing body",10 - static eval_list_not_function, db "list does not begin with a function",10 - - static if_missing_condition_string, db "missing condition in if expression",10 - - static try_missing_catch, db "try* missing catch*" - static catch_missing_symbol, db "catch* missing symbol" - static catch_missing_form, db "catch* missing form" - -;; Symbols used for comparison - - static_symbol def_symbol, 'def!' - static_symbol let_symbol, 'let*' - static_symbol do_symbol, 'do' - static_symbol if_symbol, 'if' - static_symbol fn_symbol, 'fn*' - static_symbol defmacro_symbol, 'defmacro!' - static_symbol macroexpand_symbol, 'macroexpand' - static_symbol try_symbol, 'try*' - static_symbol catch_symbol, 'catch*' - - static_symbol argv_symbol, '*ARGV*' - - static_symbol quote_symbol, 'quote' - static_symbol quasiquote_symbol, 'quasiquote' - static_symbol quasiquoteexpand_symbol, 'quasiquoteexpand' - static_symbol unquote_symbol, 'unquote' - static_symbol splice_unquote_symbol, 'splice-unquote' - static_symbol concat_symbol, 'concat' - static_symbol cons_symbol, 'cons' - static_symbol vec_symbol, 'vec' - -;; Startup string. This is evaluated on startup - static mal_startup_string, db "(do \ -(def! not (fn* (a) (if a false true))) \ -(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ -(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) \ -(def! *host-language* ",34,"nasm",34,")\ -(def! conj nil)\ -)" - -;; Command to run, appending the name of the script to run - static run_script_string, db "(load-file ",34 - -;; Command to run at start of REPL - static mal_startup_header, db "(println (str ",34,"Mal [",34," *host-language* ",34,"]",34,"))" - -section .text - - -;;; Extract the car of a Cons and increment its reference count. -;;; If it was value, create a fresh copy. -;;; in : rsi (which must be a pointer!) -;;; out : rsi -;;; modified: : cl, rax, rbx -car_and_incref: - mov cl, BYTE [rsi + Cons.typecar] - and cl, content_mask - - mov rsi, [rsi + Cons.car] - - cmp cl, content_pointer - je incref_object - - call alloc_cons - mov [rax + Cons.typecar], BYTE cl ; masked above - mov [rax + Cons.car], rsi - mov rsi, rax - ret - - -;; ---------------------------------------------- -;; Evaluates a form -;; -;; Inputs: RSI Form to evaluate -;; RDI Environment -;; -eval_ast: - mov r15, rdi ; Save Env in r15 - - ; Check the type - mov al, BYTE [rsi] - - ; Check if this is a list - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list - - cmp ah, container_map - je .map - - cmp ah, container_vector - je .vector - - ; Not a list, map or vector - cmp ah, container_symbol - je .symbol - - ; Not a symbol, list, map or vector - call incref_object ; Increment reference count - - mov rax, rsi - ret - -.symbol: - ; Check if first character of symbol is ':' - mov al, BYTE [rsi + Array.data] - cmp al, ':' - je .keyword - - ; look in environment - push rsi - xchg rsi, rdi - ; symbol is the key in rdi - ; Environment in rsi - call env_get - pop rsi - je .done ; result in RAX - - ; Not found, throw an error - mov r11, rsi ; Symbol in R11 - - call string_new - mov rsi, rax ; New string in RSI - - mov cl, 39 ; quote ' - call string_append_char - - mov rdx, r11 ; symbol - call string_append_string - - mov cl, 39 - call string_append_char - - mov r11, rsi - - mov rsi, not_found_string - mov edx, not_found_string.len - call raw_to_string ; ' not found' - - mov r12, rax - - mov rdx, rax - mov rsi, r11 - call string_append_string - - mov r11, rsi - mov rsi, r12 - call release_array - mov rsi, r11 - - jmp error_throw - - ; ------------------------------ - -.keyword: - ; Just return keywords unaltered - call incref_object - mov rax, rsi - ret - - ; ------------------------------ -.list: - ; Evaluate each element of the list - ; - xor r8, r8 ; The list to return - ; r9 contains head of list - -.list_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .list_pointer - - ; A value in RSI, so copy - - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_list) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .list_append - -.list_pointer: - ; List element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rdi, [rsi + Cons.car] ; Get the address - mov rsi, r15 - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call incref_object ; AST increment refs - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .list_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_list + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .list_append - -.list_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_list) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - - ; Fall through to .list_append -.list_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .list_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .list_next - -.list_first: - mov r8, rax - mov r9, rax - ; fall through to .list_next - -.list_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .list_done ; finished list - mov rsi, [rsi + Cons.cdr] ; next in list - jmp .list_loop - -.list_done: - mov rax, r8 ; Return the list - ret - - ; --------------------- -.map: - ; Create a new map, evaluating all the values - - ; Check if the map is empty - cmp al, maltype_empty_map - jne .map_not_empty - - ; map empty. Just return it - call incref_object - mov rax, rsi - ret - -.map_not_empty: - - mov r10, rsi ; input in R10 - xor r12, r12 ; New map in r12 - - ; Now loop through each key-value pair - ; NOTE: This method relies on the implementation - ; of map as a list - -.map_loop: - ; Copy the key - call alloc_cons ; New Cons in RAX - - mov bl, [r10 + Cons.typecar] ; Type in BL - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] ; Value in RCX - mov [rax + Cons.car], rcx - - ; Check the type of the key - and bl, content_mask - cmp bl, content_pointer - jne .map_got_key ; a value - - ; a pointer, so increment reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.map_got_key: - cmp r12,0 - jne .append_key - - ; First key - mov r12, rax - mov r13, rax - jmp .map_value - -.append_key: - ; Appending to previous value in r13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - -.map_value: - ; Check that we have a value - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_error_missing_value - mov r10, [r10 + Cons.cdr] - - ; Now got value in r10 - - ; Check the type of the value - mov bl, [r10 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .map_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r10 + Cons.typecar] - mov [rax + Cons.typecar], bl - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .map_got_value -.map_value_pointer: - ; A pointer, so need to evaluate - push r10 ; Input - push r12 ; start of result - push r13 ; Current head of result - push r15 ; Env - mov rsi, [r10 + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r13 - pop r12 - pop r10 - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - - jne .map_eval_pointer - - ; A value, so just change the type to a map - and bl, content_mask - add bl, (block_cons + container_map) - mov [rax], BYTE bl - jmp .map_got_value - -.map_eval_pointer: - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - -.map_got_value: - ; Append RAX to list in R13 - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax - mov r13, rax - - ; Check if there's another key - mov al, BYTE [r10 + Cons.typecdr] - cmp al, content_pointer - jne .map_done ; finished map - mov r10, [r10 + Cons.cdr] ; next in map - jmp .map_loop - -.map_done: - mov rax, r12 - ret - -.map_error_missing_value: - mov rax, r12 - ret - - ; ------------------------------ -.vector: - ; Evaluate each element of the vector - ; - xor r8, r8 ; The vector to return - ; r9 contains head of vector - -.vector_loop: - mov al, BYTE [rsi] ; Check type - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .vector_pointer - - ; A value, so copy - call alloc_cons - mov bl, BYTE [rsi] - and bl, content_mask - add bl, (block_cons + container_vector) - mov [rax], BYTE bl ; set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; copy value - - ; Result in RAX - jmp .vector_append - -.vector_pointer: - ; Vector element is a pointer to something - push rsi - push r8 - push r9 - push r15 ; Env - mov rsi, [rsi + Cons.car] ; Get the address - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi - - call incref_object - - call eval ; Evaluate it, result in rax - pop r15 - pop r9 - pop r8 - pop rsi - - ; Check the type it's evaluated to - mov bl, BYTE [rax] - mov bh, bl - and bh, (block_mask + container_mask) - cmp bh, (block_cons + container_value) - je .vector_eval_value - - ; Not a value, so need a pointer to it - push rax - call alloc_cons - mov [rax], BYTE (block_cons + container_vector + content_pointer) - pop rbx ; Address to point to - mov [rax + Cons.car], rbx - jmp .vector_append - -.vector_eval_value: - ; Got value in RAX, so copy - push rax - call alloc_cons ; Copy in RAX - pop rbx ; Value to copy in RBX - mov cl, BYTE [rbx] - and cl, content_mask - or cl, (block_cons + container_vector) - mov [rax], BYTE cl ; set type - mov rcx, [rbx + Cons.car] - mov [rax + Cons.car], rcx ; copy value - - ; Release the value in RBX - push rsi - push rax - mov rsi, rbx - call release_cons - pop rax - pop rsi - -.vector_append: - ; In RAX - - cmp r8, 0 ; Check if this is the first - je .vector_first - - ; append to r9 - mov [r9 + Cons.cdr], rax - mov [r9 + Cons.typecdr], BYTE content_pointer - mov r9, rax - jmp .vector_next - -.vector_first: - mov r8, rax - mov r9, rax - ; fall through to .vector_next - -.vector_next: - ; Check if there's another - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .vector_done ; finished vector - mov rsi, [rsi + Cons.cdr] ; next in vector - jmp .vector_loop - -.vector_done: - mov rax, r8 ; Return the vector - ret - - ; --------------------- -.done: - ret - - - -;; Comparison of symbols for eval function -;; Compares the symbol in RSI with specified symbol -;; Preserves RSI and RBX -;; Modifies RDI -%macro eval_cmp_symbol 1 - push rsi - push rbx - mov rsi, rbx - mov rdi, %1 - call compare_char_array - pop rbx - pop rsi - test rax, rax ; ZF set if rax = 0 (equal) -%endmacro - -;; ---------------------------------------------------- -;; Evaluates a form -;; -;; Input: RSI AST to evaluate [ Released ] -;; RDI Environment [ Released ] -;; -;; Returns: Result in RAX -;; -;; Note: Both the form and environment will have their reference count -;; reduced by one (released). This is for tail call optimisation (Env), -;; quasiquote and macroexpand (AST) -;; -eval: - mov r15, rdi ; Env - - push rsi ; AST pushed, must be popped before return - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - and al, container_mask - cmp al, container_list - je .list - - ; Not a list. Evaluate and return - call eval_ast - jmp .return ; Releases Env - - ; -------------------- -.list: - ; A list - - ; Macro expand - pop rax ; Old AST, discard from stack - call macroexpand ; Replaces RSI - push rsi ; New AST - - ; Check if RSI is a list, and if - ; the first element is a symbol - mov al, BYTE [rsi] - - ; Check type - mov al, BYTE [rsi] - cmp al, maltype_empty_list - je .empty_list ; empty list, return unchanged - - mov ah, al - and ah, container_mask - cmp ah, container_list - je .list_still_list - - ; Not a list, so call eval_ast on it - mov rdi, r15 ; Environment - call eval_ast - jmp .return - -.list_still_list: - and al, content_mask - cmp al, content_pointer - jne .list_eval - - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .list_eval - - ; Is a symbol, address in RBX - - ; Compare against special form symbols - - eval_cmp_symbol def_symbol ; def! - je .def_symbol - - eval_cmp_symbol let_symbol ; let* - je .let_symbol - - eval_cmp_symbol do_symbol ; do - je .do_symbol - - eval_cmp_symbol if_symbol ; if - je .if_symbol - - eval_cmp_symbol fn_symbol ; fn - je .fn_symbol - - eval_cmp_symbol quote_symbol ; quote - je .quote_symbol - - eval_cmp_symbol quasiquoteexpand_symbol - je .quasiquoteexpand_symbol - - eval_cmp_symbol quasiquote_symbol ; quasiquote - je .quasiquote_symbol - - eval_cmp_symbol defmacro_symbol ; defmacro! - je .defmacro_symbol - - eval_cmp_symbol macroexpand_symbol ; macroexpand - je .macroexpand_symbol - - eval_cmp_symbol try_symbol ; try* - je .try_symbol - - ; Unrecognised - jmp .list_eval - - - ; ----------------------------- - -.defmacro_symbol: - mov r9, 1 - jmp .def_common -.def_symbol: - xor r9, r9 ; Set R9 to 0 -.def_common: - ; Define a new symbol in current environment - ; If R9 is set to 1 then defmacro - - ; Next item should be a symbol - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Now should have a symbol - - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - jne .def_error_expecting_symbol - mov r8, [rsi + Cons.car] ; Symbol (?) - - mov al, BYTE [r8] - cmp al, maltype_symbol - jne .def_error_expecting_symbol - - ; R8 now contains a symbol - - ; expecting a value or pointer next - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .def_error_missing_arg - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a pointer - mov al, BYTE [rsi] - mov ah, al - and ah, content_mask - cmp ah, content_pointer - je .def_pointer - - ; A value, so copy - - ; Test if this is defmacro! - test r9, r9 - jnz .defmacro_not_function - - push rax - call alloc_cons - pop rbx ; BL now contains type - and bl, content_mask - add bl, (block_cons + container_value) - mov [rax], BYTE bl - mov rcx, [rsi + Cons.car] - mov [rax + Cons.car], rcx - mov rsi, rax - - jmp .def_got_value - -.def_pointer: - ; A pointer, so evaluate - - ; This may throw an error, so define a handler - - push r8 ; the symbol - push r15 ; Env - push r9 - mov rsi, [rsi + Cons.car] ; Pointer - mov rdi, r15 - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call incref_object ; AST increment refs - - call eval - mov rsi, rax - - pop r9 - - ; If this is defmacro, and the object in RSI is a function, - ; then change to a macro - test r9, r9 - jz .def_not_macro ; Not defmacro - - ; Check RSI - mov al, BYTE [rsi] - cmp al, maltype_function - jne .defmacro_not_function - - ; Got a function, change to macro - mov [rsi], BYTE maltype_macro - -.def_not_macro: - - pop r15 - pop r8 - -.def_got_value: - ; Symbol in R8, value in RSI - mov rdi, r8 ; key (symbol) - mov rcx, rsi ; Value - mov rsi, r15 ; Environment - call env_set - - mov rax, rcx - jmp .return - -.def_error_missing_arg: - mov rsi, def_missing_arg_string - mov rdx, def_missing_arg_string.len - jmp .def_handle_error - -.def_error_expecting_symbol: - mov rsi, def_expecting_symbol_string - mov rdx, def_expecting_symbol_string.len - jmp .def_handle_error - -.defmacro_not_function: - mov rsi, defmacro_expecting_function_string - mov rdx, defmacro_expecting_function_string.len - jmp .def_handle_error - -.def_handle_error: - push rsi - push rdx - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - xor rsi, rsi ; no object to throw - jmp error_throw ; No return - - ; ----------------------------- -.let_symbol: - ; Create a new environment - - mov r11, rsi ; Let form in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - mov r14, rax ; New environment in R14 - - mov rsi, r15 - call release_object ; Decrement R15 ref count - - ; Second element should be the bindings - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_bindings - mov r11, [r11 + Cons.cdr] - - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .let_error_bindings_list - - mov r12, [r11 + Cons.car] ; should be bindings list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - ; Can be either a list or vector - cmp al, block_cons + container_list - je .let_bind_loop - cmp al, block_cons + container_vector - je .let_bind_loop - - ; Not a list or vector - jmp .let_error_bindings_list - -.let_bind_loop: - ; R12 now contains a list with an even number of items - ; The first should be a symbol, then a value to evaluate - - ; Get the symbol - mov al, BYTE [r12] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_symbol - - mov r13, [r12 + Cons.car] ; Symbol (?) - mov al, BYTE [r13] - cmp al, maltype_symbol - jne .let_error_bind_symbol - - ; R13 now contains a symbol to bind - ; The next item in the bindings list (R12) - ; should be a value or expression to evaluate - - mov al, BYTE [r12 + Cons.typecdr] - and al, content_mask - cmp al, content_pointer - jne .let_error_bind_value - mov r12, [r12 + Cons.cdr] - - ; got value in R12 - - ; Check the type of the value - mov bl, [r12 + Cons.typecar] ; Type in BL - and bl, content_mask - cmp bl, content_pointer - je .let_value_pointer - - ; Not a pointer, so make a copy - call alloc_cons - mov bl, [r12 + Cons.typecar] - and bl, content_mask - ;or bl, (block_cons + container_value) ; 0 - mov [rax + Cons.typecar], bl - mov rcx, [r12 + Cons.car] - mov [rax + Cons.car], rcx - - jmp .let_got_value - -.let_value_pointer: - ; A pointer, so need to evaluate - push r11 ; let* form list - push r12 ; Position in bindings list - push r13 ; symbol to bind - push r14 ; new environment - - mov rsi, r14 - call incref_object - mov rdi, r14 - - mov rsi, [r12 + Cons.car] ; Get the address - - call incref_object ; Increment ref count of AST - - call eval ; Evaluate it, result in rax - pop r14 - pop r13 - pop r12 - pop r11 - -.let_got_value: - - mov rsi, r14 ; Env - mov rdi, r13 ; key - mov rcx, rax ; value - call env_set - - ; Release the value - mov rsi, rcx ; The value - call release_object - - ; Check if there are more bindings - mov al, BYTE [r12 + Cons.typecdr] - cmp al, content_pointer - jne .let_done_binding - mov r12, [r12 + Cons.cdr] ; Next - jmp .let_bind_loop - -.let_done_binding: - ; Done bindings. - ; Evaluate next item in let* form in new environment - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .let_error_missing_body - mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate - ; Check type of the value - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - je .body_pointer - - ; Just a value, so copy - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl ; set type - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx ; copy value - jmp .let_done - -.body_pointer: - ; Evaluate using new environment - - mov rsi, [r11 + Cons.car] ; Object pointed to - call incref_object ; will be released by eval - - mov r11, rsi ; save new AST - pop rsi ; Old AST - call release_object - mov rsi, r11 ; New AST - - mov rdi, r14 ; New environment - - jmp eval ; Tail call - ; Note: eval will release the new environment on return - -.let_done: - ; Release the new environment - push rax - mov rsi, r14 - call release_object - pop rax - - ; Release the AST - pop rsi - push rax - call release_object - pop rax - ret ; already released env - -.let_error_missing_bindings: - mov rsi, let_missing_bindings_string - mov rdx, let_missing_bindings_string.len - jmp .let_handle_error - -.let_error_bindings_list: ; expected a list or vector, got something else - mov rsi, let_bindings_list_string - mov rdx, let_bindings_list_string.len - jmp .let_handle_error - -.let_error_bind_symbol: ; expected a symbol, got something else - mov rsi, let_bind_symbol_string - mov rdx, let_bind_symbol_string.len - jmp .let_handle_error - -.let_error_bind_value: ; Missing value in binding list - mov rsi, let_bind_value_string - mov rdx, let_bind_value_string.len - jmp .let_handle_error - -.let_error_missing_body: ; Missing body to evaluate - mov rsi, let_missing_body_string - mov rdx, let_missing_body_string.len - jmp .let_handle_error - -.let_handle_error: - push r11 ; For printing later - - push rsi - push rdx - - print_str_mac error_string ; print 'Error: ' - - pop rdx - pop rsi - call print_rawstring ; print message - - pop rsi ; let* form - jmp error_throw ; No return - - ; ----------------------------- - -.do_symbol: - mov r11, rsi ; do form in RSI - ; Environment in R15 - - ; Check if there is a body - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .do_no_body ; error - - mov r11, [r11 + Cons.cdr] ; Body in R11 - -.do_symbol_loop: - - ; Need to test if this is the last form - ; so we can handle tail call - - mov bl, BYTE [r11 + Cons.typecdr] - cmp bl, content_pointer - jne .do_body_last ; Last expression - - ; not the last expression - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_next ; A value, so skip - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - ; since eval will release Env - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increment ref count since eval will release - - mov rdi, r15 ; Env - call eval ; Result in RAX - - ; Another form after this. - ; Discard the result of the last eval - mov rsi, rax - call release_object - - pop r11 - pop r15 - -.do_next: - mov r11, [r11 + Cons.cdr] ; Next in list - - jmp .do_symbol_loop - -.do_body_last: - ; The last form is in R11, which will be returned - - ; Check if this is a value or pointer - mov al, BYTE [r11] - and al, block_mask + content_mask - cmp al, content_pointer - jne .do_body_value_return - jmp .do_body_expr_return - -.do_body_value_return: - ; Got a value as last form (in R11). - ; Copy and return - - push rax ; Type of value to return - - ; release Env - mov rsi, r15 - call release_object - - ; Allocate a Cons object to hold value - call alloc_cons - pop rbx ; type in BL - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - ; release the AST - pop rsi - mov r15, rax ; not modified by release - call release_object - mov rax, r15 - - ret - -.do_body_expr_return: - ; An expression to evaluate as the last form - ; Tail call optimise, jumping to eval - ; Don't increment Env reference count - - mov rsi, [r11 + Cons.car] ; new AST form - call incref_object ; This will be released by eval - - mov r11, rsi ; Save new AST - pop rsi ; Remove old AST from stack - call release_object - mov rsi, r11 - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.do_no_body: - ; No expressions to evaluate. Return nil - - mov rsi, r15 - call release_object ; Release Env - - ; release the AST - pop rsi - call release_object - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - - ; ----------------------------- - -.if_symbol: - mov r11, rsi ; if form in R11 - ; Environment in R15 - - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .if_no_condition - - mov r11, [r11 + Cons.cdr] ; Should be a condition - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .if_cond_value - - ; A pointer, so evaluate - - push r15 - push r11 - - mov rsi, r15 - call incref_object ; Increase Env reference - - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Increase Form/AST ref count - - mov rdi, r15 ; Env - call eval ; Result in RAX - pop r11 - pop r15 - - ; Get type of result - mov bl, BYTE [rax] - - ; release value - push rbx - mov rsi, rax - call release_object - pop rbx - - ; Check type - cmp bl, maltype_nil - je .if_false - cmp bl, maltype_false - je .if_false - - jmp .if_true - -.if_cond_value: - - ; A value - cmp al, content_nil - je .if_false - cmp al, content_false - je .if_false - - jmp .if_true - -.if_false: - ; Skip the next item - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil - - mov r11, [r11 + Cons.cdr] - -.if_true: - ; Get the next item in the list and evaluate it - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; Nothing to return - - mov r11, [r11 + Cons.cdr] - - ; Check if value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - je .if_got_pointer - -.if_got_value: - ; copy value in r11 - call alloc_cons - mov bl, BYTE [r11] - and bl, content_mask - mov [rax], BYTE bl - mov rbx, [r11 + Cons.car] - mov [rax + Cons.car], rbx - - jmp .return - -.if_got_pointer: - mov rsi, [r11 + Cons.car] ; Form - call incref_object ; Will be released by eval - - mov r11, rsi - pop rsi - call release_object ; Release old AST - mov rsi, r11 ; New AST - - mov rdi, r15 ; Env - jmp eval ; Tail call - -.if_no_condition: ; just (if) without a condition - - print_str_mac error_string - print_str_mac if_missing_condition_string - - ; Release environment - mov rsi, r15 - call release_object - xor rsi, rsi ; No object to throw - jmp error_throw - -.return_nil: - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - -.return: - ; Release environment - mov rsi, r15 - mov r15, rax ; Save RAX (return value) - call release_object - - ; Release the AST - pop rsi ; Pushed at start of eval - call release_object - - mov rax, r15 ; return value - ret - - ; ----------------------------- - -.fn_symbol: - mov r11, rsi ; fn form in R11 - ; Environment in R15 - - ; Get the binds and body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_empty - - mov r11, [r11 + Cons.cdr] - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_binds_not_list - - mov r12, [r11 + Cons.car] ; Should be binds list - mov al, BYTE [r12] - and al, (block_mask + container_mask) - cmp al, (block_cons + container_list) - je .fn_got_binds ; Can be list - cmp al, (block_cons + container_vector) - je .fn_got_binds ; or vector - jmp .fn_binds_not_list - -.fn_got_binds: - - ; Next get the body of the function - mov al, BYTE [r11 + Cons.typecdr] - cmp al, content_pointer - jne .fn_no_body - - mov r11, [r11 + Cons.cdr] - ; Check value or pointer - mov al, BYTE [r11] - and al, content_mask - cmp al, content_pointer - jne .fn_is_value ; Body in r11 - mov r11, [r11 + Cons.car] - jmp .fn_got_body - -.fn_is_value: - ; Body is just a value, no expression - mov [r11], BYTE al ; Mark as value, not list - -.fn_got_body: - - ; Now put into function type - ; Addr is "apply_fn", the address to call - ; Env in R15 - ; Binds in R12 - ; Body in R11 - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_function) - mov rbx, apply_fn - mov [rax + Cons.car], rbx ; Address of apply function - mov [rax + Cons.typecdr], BYTE content_pointer - - mov r13, rax ; Return list in R13 - - ; Meta - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r13 + Cons.cdr], rax ; Append - mov r14, rax - - ; Env - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r15 ; Environment - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r14 + Cons.cdr], rax ; Append to list - mov r14, rax ; R14 contains last cons in list - - push rax - mov rsi, r15 - call incref_object - pop rax - - ; Binds - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r12 ; Binds list - mov [rax + Cons.typecdr], BYTE content_pointer - - mov [r14 + Cons.cdr], rax ; Append to list - mov r14, rax - - push rax - mov rsi, r12 - call incref_object - pop rax - - call alloc_cons - mov [rax], BYTE (block_cons + container_function + content_pointer) - mov [rax + Cons.car], r11 ; Body of function - - mov [r14 + Cons.cdr], rax - - mov rsi, r11 - call incref_object - - mov rax, r13 - jmp .return - -.fn_empty: -.fn_binds_not_list: -.fn_no_body: - - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - jmp .return - - ; ----------------------------- - -.quote_symbol: - ; Just return the arguments in rsi cdr - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; quote empty, so return nil - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .quote_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.quote_pointer: - ; RSI contains a pointer, so get the object pointed to - mov rsi, [rsi + Cons.car] - call incref_object - mov rax, rsi - jmp .return - - ; ----------------------------- - -;;; Like quasiquote, but do not evaluate the result. -.quasiquoteexpand_symbol: - ;; Return nil if no cdr - mov cl, BYTE [rsi + Cons.typecdr] - cmp cl, content_pointer - jne .return_nil - - mov rsi, [rsi + Cons.cdr] - call car_and_incref - call quasiquote - jmp .return - - ; ----------------------------- - -.quasiquote_symbol: - ; call quasiquote function with first argument - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; quasiquote empty, so return nil - - mov r11, rsi ; Save original AST in R11 - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .quasiquote_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.quasiquote_pointer: - ; RSI contains a pointer, so get the object pointed to - mov rsi, [rsi + Cons.car] - - push r15 ; Environment - ; Original AST already on stack - - call quasiquote - ; New AST in RAX - pop rdi ; Environment - pop rsi ; Old AST - - mov r11, rax ; New AST - call release_object ; Release old AST - mov rsi, r11 ; New AST in RSI - - jmp eval ; Tail call - - ; ----------------------------- -.macroexpand_symbol: - ; Check if we have a second list element - - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; No argument - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .macroexpand_pointer - - ; RSI contains a value. Remove the list container - mov [rsi + Cons.typecar], BYTE al - call incref_object - mov rax, rsi - jmp .return - -.macroexpand_pointer: - mov rsi, [rsi + Cons.car] - call incref_object ; Since RSI will be released - - call macroexpand ; May release and replace RSI - - mov rax, rsi - jmp .return ; Releases original AST - - ; ----------------------------- - -.try_symbol: - ; Should have the form - ; - ; (try* A (catch* B C)) - ; - ; where B is a symbol, A and C are forms to evaluate - - ; Check first arg A - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .return_nil ; No argument - - mov rsi, [rsi + Cons.cdr] - - ; Check if this is a value or pointer - mov al, BYTE [rsi + Cons.typecar] - and al, content_mask - cmp al, content_pointer - je .try_pointer - - ; RSI contains a value. Copy and return - mov cl, al - call alloc_cons - mov [rax], BYTE cl ; Set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx - jmp .return - -.try_pointer: - - mov r8, [rsi + Cons.car] ; form A in R8 - - ; Check second arg B - - mov al, BYTE [rsi + Cons.typecdr] - ; If nil (catchless try) - cmp al, content_nil - je .catchless_try - - cmp al, content_pointer - jne .try_missing_catch - - mov rsi, [rsi + Cons.cdr] - - mov al, BYTE [rsi] - and al, content_mask - cmp al, content_pointer - jne .try_missing_catch - - mov r9, [rsi + Cons.car] ; (catch* B C) in R9 - - mov al, BYTE [r9] - cmp al, (container_list + content_pointer) - jne .try_missing_catch - - mov rsi, [r9 + Cons.car] ; Should be catch* symbol - mov al, BYTE [rsi] - cmp al, maltype_symbol - jne .try_missing_catch - - mov rdi, catch_symbol - call compare_char_array - test rax, rax ; ZF set if rax = 0 (equal) - jnz .try_missing_catch - - ; Check that B is a symbol - mov al, [r9 + Cons.typecdr] - cmp al, content_pointer - jne .catch_missing_symbol - - mov r9, [r9 + Cons.cdr] ; (B C) in R9 - - mov al, BYTE [r9] - and al, content_mask - cmp al, content_pointer - jne .catch_missing_symbol - - mov r10, [r9 + Cons.car] ; B in R10 - mov al, BYTE [r10] - cmp al, maltype_symbol - jne .catch_missing_symbol - - mov al, BYTE [r9 + Cons.typecdr] - cmp al, content_pointer - jne .catch_missing_form - mov r9, [r9 + Cons.cdr] ; C in R9 - - ; Now have extracted from (try* A (catch* B C)) - ; A in R8 - ; B in R10 - ; C in R9 - - push R9 - push R10 - push r15 ; Env - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; Evaluate the form in R8 - mov rsi, r15 - call incref_object ; Env released by eval - mov rdi, r15 ; Env in RDI - - mov rsi, r8 ; The form to evaluate (A) - - call incref_object ; AST released by eval - - call eval - - mov r8, rax ; Result in R8 - - pop r15 ; Environment - ; Discard B and C - ;add rsi, 8 ; pop R10 and R9 - pop r10 - pop r9 - - ; Remove error handler - call error_handler_pop - mov rax, r8 - jmp .return - -.catchless_try: - ;; Evaluate the form in R8 - push r15 ; Environment - - mov rsi, r15 - call incref_object ; Env released by eval - mov rdi, r15 ; Env in RDI - - mov rsi, r8 ; The form to evaluate (A) - - call incref_object ; AST released by eval - - call eval ; Result in RAX - - pop r15 ; Environment - - jmp .return -.catch: - ; Jumps here on error - ; Value thrown in RSI - ; - - push rsi - call error_handler_pop - pop rsi - - pop r15 ; Env - pop r12 ; B (symbol to bind) - pop r13 ; C (form to evaluate) - - ; Check if C is a value or pointer - - mov cl, BYTE [r13] - and cl, content_mask - cmp cl, content_pointer - je .catch_C_pointer - - ; A value, so copy and return - call alloc_cons - mov [rax], BYTE cl ; Set type - mov rbx, [r13 + Cons.car] - mov [rax + Cons.car], rbx ; Set value - - jmp .return - -.catch_C_pointer: - - mov r11, rsi ; Value thrown in R11 - - mov rsi, r15 ; Outer env - call env_new ; Increments R15's ref count - - mov rsi, rax ; New environment in RSI - mov rdi, r12 ; key (symbol) - mov rcx, r11 ; value - call env_set - - mov rdi, rsi ; Env in RDI (will be released) - mov rsi, [r13 + Cons.car] ; Form to evaluate - call incref_object ; will be released - - push r15 - call eval - pop r15 - - jmp .return - -.try_missing_catch: - load_static try_missing_catch - call raw_to_string - mov rsi, rax - jmp error_throw - -.catch_missing_symbol: - load_static catch_missing_symbol - call raw_to_string - mov rsi, rax - jmp error_throw - -.catch_missing_form: - load_static catch_missing_form - call raw_to_string - mov rsi, rax - jmp error_throw - - ; ----------------------------- - -.list_eval: - push rsi - mov rdi, r15 ; Environment - push r15 - call eval_ast ; List of evaluated forms in RAX - pop r15 - pop rsi - -.list_exec: - ; This point can be called to run a function - ; used by swap! - ; - ; Inputs: RAX - List with function as first element - ; NOTE: This list is released - ; - ; Check that the first element of the return is a function - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .list_not_function - - mov rbx, [rax + Cons.car] ; Get the address - mov cl, BYTE [rbx] - cmp cl, maltype_function - jne .list_not_function - - ; Check the rest of the args - mov cl, BYTE [rax + Cons.typecdr] - cmp cl, content_pointer - je .list_got_args - - ; No arguments - push rbx ; Function object - push rax ; List with function first - - ; Create an empty list for the arguments - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax ; Argument list into RSI - - pop rax ; list, function first - ;; Put new empty list onto end of original list - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.cdr], rsi - - pop rbx - jmp .list_function_call -.list_got_args: - mov rsi, [rax + Cons.cdr] ; Rest of list -.list_function_call: - ; Call the function with the rest of the list in RSI - - mov rdx, rax ; List to release - mov rdi, rbx ; Function object in RDI - - mov rbx, [rbx + Cons.car] ; Call function - cmp rbx, apply_fn - je apply_fn_jmp ; Jump to user function apply - - ; A built-in function, so call (no recursion) - push rax - push r15 - - call rbx - - ; Result in rax - pop r15 - pop rsi ; eval'ed list - - push rax - call release_cons - pop rax - jmp .return ; Releases Env - -.list_not_function: - ; Not a function. Probably an error - push rsi - - mov rsi, rax - call release_object - - print_str_mac error_string - print_str_mac eval_list_not_function - pop rsi - jmp error_throw - -.empty_list: - mov rax, rsi - jmp .return - -;; Applies a user-defined function -;; -;; Input: RSI - Arguments to bind -;; RDI - Function object -;; RDX - list to release after binding -;; R15 - Env (will be released) -;; R13 - AST released before return -;; -;; -;; Output: Result in RAX -;; -;; This is jumped to from eval, so if it returns -;; then it will return to the caller of eval, not to eval -apply_fn_jmp: - ; This is jumped to from eval with AST on the stack - pop r13 -apply_fn: - push rsi - ; Extract values from the list in RDI - mov rax, [rdi + Cons.cdr] - mov rax, [rax + Cons.cdr] ; Meta (don't need) - mov rsi, [rax + Cons.car] ; Env - mov rax, [rax + Cons.cdr] - mov rdi, [rax + Cons.car] ; Binds - mov rax, [rax + Cons.cdr] - mov rax, [rax + Cons.car] ; Body - pop rcx ; Exprs - - ; Check the type of the body - mov bl, BYTE [rax] - and bl, block_mask + container_mask - jnz .bind - ; Just a value (in RAX). No eval needed - - mov r14, rax ; Save return value in R14 - - mov rsi, rax - call incref_object - - ; Release the list passed in RDX - mov rsi, rdx - call release_object - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the AST - mov rsi, r13 - call release_object - - mov rax, r14 - ret -.bind: - ; Create a new environment, binding arguments - push rax ; Body - - mov r14, r13 ; Old AST. R13 used by env_new_bind - - push rdx - call env_new_bind - pop rdx - - mov rdi, rax ; New environment in RDI - - ; Note: Need to increment the reference count - ; of the function body before releasing anything, - ; since if the function was defined in-place (lambda) - ; then the body may be released early - - pop rsi ; Body - call incref_object ; Will be released by eval - mov r8, rsi ; Body in R8 - - ; Release the list passed in RDX - mov rsi, rdx - call release_cons - - ; Release the environment - mov rsi, r15 - call release_object - - ; Release the old AST - mov rsi, r14 - call release_object - - mov rsi, r8 ; Body - - jmp eval ; Tail call - ; The new environment (in RDI) will be released by eval - - -;;; Called by eval -;;; Original AST in RSI. -;;; Returns new AST in RAX -quasiquote: - ;; Dispatch on the type. - mov al, BYTE [rsi + Cons.typecar] - mov cl, al ; keep full al for .list - and cl, container_mask - cmp cl, container_list - je .list - cmp cl, container_map - je .map - cmp cl, container_symbol - je .symbol - cmp cl, container_vector - je .vector - ;; return other types unchanged - call incref_object - mov rax, rsi - ret - -.list: - ;; AST is a list, process it with qq_foldr unless.. - mov cl, al ; it is not empty, - and cl, content_mask - cmp cl, content_empty - je qq_foldr - - cmp cl, content_pointer ; and it is a pointer, - jne qq_foldr - - mov rdi, [rsi + Cons.car] ; and the first element is a symbol, - mov cl, BYTE [rdi + Cons.typecar] - cmp cl, maltype_symbol - jne qq_foldr - - mov r8, rsi ; and the symbol is 'unquote, - mov rsi, unquote_symbol - call compare_char_array - test rax, rax - mov rsi, r8 - jne qq_foldr - - mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. - cmp cl, content_pointer - jne qq_foldr - - ;; If so, return the argument. - mov rsi, [rsi + Cons.cdr] - call car_and_incref - mov rax, rsi - ret - -.map: -.symbol: - call incref_object - - ;; rdx := (ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rsi - mov rdx, rax - - mov rsi, quote_symbol - call incref_object - - ;; rax := ('quote ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - -.vector: - ;; rdx := ast processed like a list - call qq_foldr - mov rdx, rax - - ;; rdx := (processed_ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], rdx - mov rdx, rax - - mov rsi, vec_symbol - call incref_object - - ;; rax := ('vec processed_ast) - call alloc_cons - mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - - -;;; Helper for quasiquote. -;;; RSI must contain a list or vector, which may be empty. -;;; The result in RAX is always a list. -;;; Iterate on the elements in the right fold/reduce style. -qq_foldr: - mov cl, BYTE [rsi + Cons.typecar] - - cmp cl, maltype_empty_list - je .empty_list - - cmp cl, maltype_empty_vector - je .empty_vector - - ;; Extract first element and store it into the stack during - ;; the recursion. - mov rdx, rsi - call car_and_incref - push rsi - mov rsi, rdx - - ;; Extract the rest of the list. - mov al, BYTE [rsi + Cons.typecdr] - -;;; If the rest is not empty - cmp al, content_pointer - jne .else -;;; then - mov rsi, [rsi + Cons.cdr] - jmp .endif -.else: - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rsi, rax -.endif: - call qq_foldr ; recursive call - pop rsi - jmp qq_loop - -.empty_list: ;; () -> () - call incref_object - mov rax, rsi - ret - -.empty_vector: ;; [] -> () - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - - -;; Helper for quasiquote -;; The transition function starts here. -;; Current element is in rsi, accumulator in rax. -qq_loop: - mov r9, rax - - ;; Process with the element with .default, unless.. - mov cl, BYTE [rsi + Cons.typecar] ; it is a list - mov al, cl - and al, container_mask - cmp al, container_list - jne .default - - cmp cl, maltype_empty_list ; it is not empty, - je .default - - and cl, content_mask ; and it is a pointer, - cmp cl, content_pointer - jne .default - - mov rdi, [rsi + Cons.car] ; and the first element is a symbol, - mov cl, BYTE [rdi + Cons.typecar] - cmp cl, maltype_symbol - jne .default - - mov r8, rsi ; and the symbol is 'splice-unquote, - mov rsi, splice_unquote_symbol - call compare_char_array - test rax, rax - mov rsi, r8 - jne .default - - mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. - cmp cl, content_pointer - jne .default - - ;; If so, return ('concat elt acc). - mov rsi, [rsi + Cons.cdr] - call car_and_incref - - ;; rdx := (acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.car], r9 - mov rdx, rax - - ;; rdx := (elt acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - mov rdx, rax - - mov rsi, concat_symbol - call incref_object - - ;; rax := ('concat elt acc) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - -.default: - ;; rax := (accumulator) - call alloc_cons - mov [rax + Cons.typecar], BYTE (container_list + content_pointer) - mov [rax + Cons.car], r9 - - ;; rcx := quasiquoted_element - ;; rdx := (accumulator) - push rax - call quasiquote - mov rcx, rax - pop rdx - - ;; rdx := (quasiquoted_element accumulator) - call alloc_cons - mov [rax + Cons.typecar], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rcx - mov [rax + Cons.cdr], rdx - mov rdx, rax - - mov rsi, cons_symbol - call incref_object - - ;; rax := ('cons quasiquoted_elt accumulator) - call alloc_cons - mov [rax], BYTE (container_list + content_pointer) - mov [rax + Cons.typecdr], BYTE content_pointer - mov [rax + Cons.car], rsi - mov [rax + Cons.cdr], rdx - - ret - - -;; Tests if an AST in RSI is a list containing -;; a macro defined in the ENV in R15 -;; -;; Inputs: AST in RSI (not modified) -;; ENV in R15 (not modified) -;; -;; Returns: Sets ZF if macro call. If set (true), -;; then the macro object is in RAX -;; -;; Modifies: -;; RAX -;; RBX -;; RCX -;; RDX -;; R8 -;; R9 -is_macro_call: - ; Test if RSI is a list which contains a pointer - mov al, BYTE [rsi] - cmp al, (block_cons + container_list + content_pointer) - jne .false - - ; Test if this is a symbol - mov rbx, [rsi + Cons.car] - mov al, BYTE [rbx] - cmp al, maltype_symbol - jne .false - - ; Look up symbol in Env - push rsi - push r15 - mov rdi, rbx ; symbol in RDI - mov rsi, r15 ; Environment in RSI - call env_get - pop r15 - pop rsi - jne .false ; Not in environment - - ; Object in RAX - ; If this is not a macro then needs to be released - mov dl, BYTE [rax] - - cmp dl, maltype_macro - je .true - - ; Not a macro, so release - mov r8, rsi - mov rsi, rax - call release_object - mov rsi, r8 - -.false: - lahf ; flags in AH - and ah, 255-64 ; clear zero flag - sahf - ret -.true: - mov rbx, rax ; Returning Macro object - lahf ; flags in AH - or ah, 64 ; set zero flag - sahf - mov rax, rbx - ret - -;; Expands macro calls -;; -;; Input: AST in RSI (released and replaced) -;; Env in R15 (not modified) -;; -;; Result: New AST in RSI -macroexpand: - push r15 - - call is_macro_call - jne .done - - mov r13, rsi - - mov rdi, rax ; Macro in RDI - - ; Check the rest of the args - mov cl, BYTE [rsi + Cons.typecdr] - cmp cl, content_pointer - je .got_args - - ; No arguments. Create an empty list - call alloc_cons - mov [rax], BYTE maltype_empty_list - mov rdx, rax - - mov rsi, rdx ; Arguments (empty list) - call incref_object - jmp .macro_call -.got_args: - mov rsi, [rsi + Cons.cdr] ; Rest of list - call incref_object - mov rdx, rsi ; Released -.macro_call: - ; Here have: - ; RSI - Arguments - ; RDI - Macro object - ; RDX - List to release - ; R15 - Environment - ; R13 - AST - - ; Increment reference for Environment - ; since this will be released by apply_fn - xchg rsi, r15 - call incref_object - xchg rsi, r15 - - call apply_fn - - mov rsi, rax ; Result in RSI - - pop r15 - jmp macroexpand -.done: - pop r15 - ret - -;; Read and eval -read_eval: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - jmp eval ; This releases Env and Form/AST - - -;; Read-Eval-Print in sequence -;; -;; Input string in RSI -rep_seq: - ; ------------- - ; Read - call read_str - - ; ------------- - ; Eval - mov rsi, rax ; Form to evaluate - mov rdi, [repl_env] ; Environment - - xchg rsi, rdi - call incref_object ; Environment increment refs - xchg rsi, rdi ; since it will be decremented by eval - - call eval ; This releases Env and Form/AST - push rax ; Save result of eval - - ; ------------- - ; Print - - mov rsi, rax ; Output of eval into input of print - mov rdi, 1 ; print readably - call pr_str ; String in RAX - - mov r8, rax ; Save output - - pop rsi ; Result from eval - call release_object - mov rax, r8 - - ret - - -_start: - ; Create and print the core environment - call core_environment ; Environment in RAX - - mov [repl_env], rax ; store in memory - - ; Set the error handler - mov rsi, rsp ; Stack pointer - mov rdi, .catch ; Address to jump to - xor rcx, rcx ; No data - call error_handler_push - - ; Evaluate the startup string - - mov rsi, mal_startup_string - mov edx, mal_startup_string.len - call raw_to_string ; String in RAX - - push rax - mov rsi, rax - call read_str ; AST in RAX - pop rsi ; string - - push rax ; AST - call release_array ; string - pop rdi ; AST in RDI - - mov rsi, [repl_env] ; Environment in RSI - - call incref_object ; Environment increment refs - xchg rsi, rdi ; Env in RDI, AST in RSI - - call eval - - mov rsi, rax - call release_object ; Return from eval - - ; ----------------------------- - ; Check command-line arguments - - pop rax ; Number of arguments - cmp rax, 1 ; Always have at least one, the path to executable - jg run_script - - ; No extra arguments, so just set *ARGV* to an empty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov rcx, rax ; value (empty list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - ; ----------------------------- - ; Header - - load_static mal_startup_header - call raw_to_string - push rax - - mov rsi, rax - call read_eval ; no print ('nil') - mov rsi, rax - call release_object ; Release result of eval - - ; Release the input string - pop rsi - call release_array - - ; ----------------------------- - ; Main loop - -.mainLoop: - ; print the prompt - print_str_mac prompt_string - - call read_line - - ; Check if we have a zero-length string - cmp DWORD [rax+Array.length], 0 - je .mainLoopEnd - - push rax ; Save address of the string - - mov rsi, rax - call rep_seq ; Read-Eval-Print - - push rax ; Save returned string - - mov rsi, rax ; Put into input of print_string - call print_string - - ; Release string from rep_seq - pop rsi - call release_array - - ; Release the input string - pop rsi - call release_array - - jmp .mainLoop -.mainLoopEnd: - - jmp quit - -.catch: - ; Jumps here on error - - ; Check if an object was thrown - cmp rsi, 0 - je .catch_done_print ; nothing to print - - push rsi - print_str_mac error_string ; print 'Error: ' - pop rsi - - mov rdi, 1 - call pr_str - mov rsi, rax - call print_string -.catch_done_print: - jmp .mainLoop ; Go back to the prompt - - - -run_script: - ; Called with number of command-line arguments in RAX - mov r8, rax - pop rbx ; executable - dec r8 - - pop rsi ; Address of first arg - call cstring_to_string ; string in RAX - mov r9, rax - - ; get the rest of the args - xor r10, r10 ; Zero - dec r8 - jz .no_args - - ; Got some arguments -.arg_loop: - ; Got an argument left. - pop rsi ; Address of C string - call cstring_to_string ; String in RAX - mov r12, rax - - ;Make a Cons to point to the string - call alloc_cons ; in RAX - mov [rax], BYTE (block_cons + container_list + content_pointer) - mov [rax + Cons.car], r12 - - test r10, r10 - jnz .append - - ; R10 zero, so first arg - mov r10, rax ; Head of list - mov r11, rax ; Tail of list - jmp .next -.append: - ; R10 not zero, so append to list tail - mov [r11 + Cons.cdr], rax - mov [r11 + Cons.typecdr], BYTE content_pointer - mov r11, rax -.next: - dec r8 - jnz .arg_loop - jmp .got_args - -.no_args: - ; No arguments. Create an emoty list - call alloc_cons ; in RAX - mov [rax], BYTE maltype_empty_list - mov r10, rax - -.got_args: - push r9 ; File name string - - mov rcx, r10 ; value (list) - mov rdi, argv_symbol ; symbol (*ARGV*) - mov rsi, [repl_env] ; environment - call env_set - - mov rsi, run_script_string ; load-file function - mov edx, run_script_string.len - call raw_to_string ; String in RAX - - mov rsi, rax - pop rdx ; File name string - call string_append_string - - mov cl, 34 ; " - call string_append_char - mov cl, ')' - call string_append_char ; closing brace - - ; Read-Eval "(load-file )" - call read_eval - - jmp quit +;; +;; nasm -felf64 stepA_mal.asm && ld stepA_mal.o && ./a.out +;; +;; Calling convention: Address of input is in RSI +;; Address of return value is in RAX +;; + +global _start + +%include "types.asm" ; Data types, memory +%include "env.asm" ; Environment type +%include "system.asm" ; System calls +%include "reader.asm" ; String -> Data structures +%include "core.asm" ; Core functions +%include "printer.asm" ; Data structures -> String +%include "exceptions.asm" ; Error handling + +section .bss + +;; Top-level (REPL) environment +repl_env:resq 1 + +section .data + +;; ------------------------------------------ +;; Fixed strings for printing + + static prompt_string, db 10,"user> " ; The string to print at the prompt + + static error_string, db 27,'[31m',"Error",27,'[0m',": " + + static not_found_string, db " not found" + + static def_missing_arg_string, db "missing argument to def!",10 + + static def_expecting_symbol_string, db "expecting symbol as first argument to def!",10 + + static defmacro_expecting_function_string, db "defmacro expects function",10 + + static let_missing_bindings_string, db "let* missing bindings",10 + + static let_bindings_list_string, db "let* expected a list or vector of bindings",10 + + static let_bind_symbol_string, db "let* expected a symbol in bindings list",10 + + static let_bind_value_string, db "let* missing value in bindings list",10 + + static let_missing_body_string, db "let* missing body",10 + static eval_list_not_function, db "list does not begin with a function",10 + + static if_missing_condition_string, db "missing condition in if expression",10 + + static try_missing_catch, db "try* missing catch*" + static catch_missing_symbol, db "catch* missing symbol" + static catch_missing_form, db "catch* missing form" + +;; Symbols used for comparison + + static_symbol def_symbol, 'def!' + static_symbol let_symbol, 'let*' + static_symbol do_symbol, 'do' + static_symbol if_symbol, 'if' + static_symbol fn_symbol, 'fn*' + static_symbol defmacro_symbol, 'defmacro!' + static_symbol macroexpand_symbol, 'macroexpand' + static_symbol try_symbol, 'try*' + static_symbol catch_symbol, 'catch*' + + static_symbol argv_symbol, '*ARGV*' + + static_symbol quote_symbol, 'quote' + static_symbol quasiquote_symbol, 'quasiquote' + static_symbol quasiquoteexpand_symbol, 'quasiquoteexpand' + static_symbol unquote_symbol, 'unquote' + static_symbol splice_unquote_symbol, 'splice-unquote' + static_symbol concat_symbol, 'concat' + static_symbol cons_symbol, 'cons' + static_symbol vec_symbol, 'vec' + +;; Startup string. This is evaluated on startup + static mal_startup_string, db "(do \ +(def! not (fn* (a) (if a false true))) \ +(def! load-file (fn* (f) (eval (read-string (str ",34,"(do",34," (slurp f) ",34,10,"nil)",34," ))))) \ +(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ",34,"odd number of forms to cond",34,")) (cons 'cond (rest (rest xs))))))) \ +(def! *host-language* ",34,"nasm",34,")\ +(def! conj nil)\ +)" + +;; Command to run, appending the name of the script to run + static run_script_string, db "(load-file ",34 + +;; Command to run at start of REPL + static mal_startup_header, db "(println (str ",34,"Mal [",34," *host-language* ",34,"]",34,"))" + +section .text + + +;;; Extract the car of a Cons and increment its reference count. +;;; If it was value, create a fresh copy. +;;; in : rsi (which must be a pointer!) +;;; out : rsi +;;; modified: : cl, rax, rbx +car_and_incref: + mov cl, BYTE [rsi + Cons.typecar] + and cl, content_mask + + mov rsi, [rsi + Cons.car] + + cmp cl, content_pointer + je incref_object + + call alloc_cons + mov [rax + Cons.typecar], BYTE cl ; masked above + mov [rax + Cons.car], rsi + mov rsi, rax + ret + + +;; ---------------------------------------------- +;; Evaluates a form +;; +;; Inputs: RSI Form to evaluate +;; RDI Environment +;; +eval_ast: + mov r15, rdi ; Save Env in r15 + + ; Check the type + mov al, BYTE [rsi] + + ; Check if this is a list + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list + + cmp ah, container_map + je .map + + cmp ah, container_vector + je .vector + + ; Not a list, map or vector + cmp ah, container_symbol + je .symbol + + ; Not a symbol, list, map or vector + call incref_object ; Increment reference count + + mov rax, rsi + ret + +.symbol: + ; Check if first character of symbol is ':' + mov al, BYTE [rsi + Array.data] + cmp al, ':' + je .keyword + + ; look in environment + push rsi + xchg rsi, rdi + ; symbol is the key in rdi + ; Environment in rsi + call env_get + pop rsi + je .done ; result in RAX + + ; Not found, throw an error + mov r11, rsi ; Symbol in R11 + + call string_new + mov rsi, rax ; New string in RSI + + mov cl, 39 ; quote ' + call string_append_char + + mov rdx, r11 ; symbol + call string_append_string + + mov cl, 39 + call string_append_char + + mov r11, rsi + + mov rsi, not_found_string + mov edx, not_found_string.len + call raw_to_string ; ' not found' + + mov r12, rax + + mov rdx, rax + mov rsi, r11 + call string_append_string + + mov r11, rsi + mov rsi, r12 + call release_array + mov rsi, r11 + + jmp error_throw + + ; ------------------------------ + +.keyword: + ; Just return keywords unaltered + call incref_object + mov rax, rsi + ret + + ; ------------------------------ +.list: + ; Evaluate each element of the list + ; + xor r8, r8 ; The list to return + ; r9 contains head of list + +.list_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .list_pointer + + ; A value in RSI, so copy + + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_list) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .list_append + +.list_pointer: + ; List element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rdi, [rsi + Cons.car] ; Get the address + mov rsi, r15 + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call incref_object ; AST increment refs + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .list_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_list + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .list_append + +.list_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_list) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + + ; Fall through to .list_append +.list_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .list_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .list_next + +.list_first: + mov r8, rax + mov r9, rax + ; fall through to .list_next + +.list_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .list_done ; finished list + mov rsi, [rsi + Cons.cdr] ; next in list + jmp .list_loop + +.list_done: + mov rax, r8 ; Return the list + ret + + ; --------------------- +.map: + ; Create a new map, evaluating all the values + + ; Check if the map is empty + cmp al, maltype_empty_map + jne .map_not_empty + + ; map empty. Just return it + call incref_object + mov rax, rsi + ret + +.map_not_empty: + + mov r10, rsi ; input in R10 + xor r12, r12 ; New map in r12 + + ; Now loop through each key-value pair + ; NOTE: This method relies on the implementation + ; of map as a list + +.map_loop: + ; Copy the key + call alloc_cons ; New Cons in RAX + + mov bl, [r10 + Cons.typecar] ; Type in BL + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] ; Value in RCX + mov [rax + Cons.car], rcx + + ; Check the type of the key + and bl, content_mask + cmp bl, content_pointer + jne .map_got_key ; a value + + ; a pointer, so increment reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.map_got_key: + cmp r12,0 + jne .append_key + + ; First key + mov r12, rax + mov r13, rax + jmp .map_value + +.append_key: + ; Appending to previous value in r13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + +.map_value: + ; Check that we have a value + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_error_missing_value + mov r10, [r10 + Cons.cdr] + + ; Now got value in r10 + + ; Check the type of the value + mov bl, [r10 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .map_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r10 + Cons.typecar] + mov [rax + Cons.typecar], bl + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .map_got_value +.map_value_pointer: + ; A pointer, so need to evaluate + push r10 ; Input + push r12 ; start of result + push r13 ; Current head of result + push r15 ; Env + mov rsi, [r10 + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r13 + pop r12 + pop r10 + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + + jne .map_eval_pointer + + ; A value, so just change the type to a map + and bl, content_mask + add bl, (block_cons + container_map) + mov [rax], BYTE bl + jmp .map_got_value + +.map_eval_pointer: + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + +.map_got_value: + ; Append RAX to list in R13 + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax + mov r13, rax + + ; Check if there's another key + mov al, BYTE [r10 + Cons.typecdr] + cmp al, content_pointer + jne .map_done ; finished map + mov r10, [r10 + Cons.cdr] ; next in map + jmp .map_loop + +.map_done: + mov rax, r12 + ret + +.map_error_missing_value: + mov rax, r12 + ret + + ; ------------------------------ +.vector: + ; Evaluate each element of the vector + ; + xor r8, r8 ; The vector to return + ; r9 contains head of vector + +.vector_loop: + mov al, BYTE [rsi] ; Check type + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .vector_pointer + + ; A value, so copy + call alloc_cons + mov bl, BYTE [rsi] + and bl, content_mask + add bl, (block_cons + container_vector) + mov [rax], BYTE bl ; set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; copy value + + ; Result in RAX + jmp .vector_append + +.vector_pointer: + ; Vector element is a pointer to something + push rsi + push r8 + push r9 + push r15 ; Env + mov rsi, [rsi + Cons.car] ; Get the address + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi + + call incref_object + + call eval ; Evaluate it, result in rax + pop r15 + pop r9 + pop r8 + pop rsi + + ; Check the type it's evaluated to + mov bl, BYTE [rax] + mov bh, bl + and bh, (block_mask + container_mask) + cmp bh, (block_cons + container_value) + je .vector_eval_value + + ; Not a value, so need a pointer to it + push rax + call alloc_cons + mov [rax], BYTE (block_cons + container_vector + content_pointer) + pop rbx ; Address to point to + mov [rax + Cons.car], rbx + jmp .vector_append + +.vector_eval_value: + ; Got value in RAX, so copy + push rax + call alloc_cons ; Copy in RAX + pop rbx ; Value to copy in RBX + mov cl, BYTE [rbx] + and cl, content_mask + or cl, (block_cons + container_vector) + mov [rax], BYTE cl ; set type + mov rcx, [rbx + Cons.car] + mov [rax + Cons.car], rcx ; copy value + + ; Release the value in RBX + push rsi + push rax + mov rsi, rbx + call release_cons + pop rax + pop rsi + +.vector_append: + ; In RAX + + cmp r8, 0 ; Check if this is the first + je .vector_first + + ; append to r9 + mov [r9 + Cons.cdr], rax + mov [r9 + Cons.typecdr], BYTE content_pointer + mov r9, rax + jmp .vector_next + +.vector_first: + mov r8, rax + mov r9, rax + ; fall through to .vector_next + +.vector_next: + ; Check if there's another + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .vector_done ; finished vector + mov rsi, [rsi + Cons.cdr] ; next in vector + jmp .vector_loop + +.vector_done: + mov rax, r8 ; Return the vector + ret + + ; --------------------- +.done: + ret + + + +;; Comparison of symbols for eval function +;; Compares the symbol in RSI with specified symbol +;; Preserves RSI and RBX +;; Modifies RDI +%macro eval_cmp_symbol 1 + push rsi + push rbx + mov rsi, rbx + mov rdi, %1 + call compare_char_array + pop rbx + pop rsi + test rax, rax ; ZF set if rax = 0 (equal) +%endmacro + +;; ---------------------------------------------------- +;; Evaluates a form +;; +;; Input: RSI AST to evaluate [ Released ] +;; RDI Environment [ Released ] +;; +;; Returns: Result in RAX +;; +;; Note: Both the form and environment will have their reference count +;; reduced by one (released). This is for tail call optimisation (Env), +;; quasiquote and macroexpand (AST) +;; +eval: + mov r15, rdi ; Env + + push rsi ; AST pushed, must be popped before return + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + and al, container_mask + cmp al, container_list + je .list + + ; Not a list. Evaluate and return + call eval_ast + jmp .return ; Releases Env + + ; -------------------- +.list: + ; A list + + ; Macro expand + pop rax ; Old AST, discard from stack + call macroexpand ; Replaces RSI + push rsi ; New AST + + ; Check if RSI is a list, and if + ; the first element is a symbol + mov al, BYTE [rsi] + + ; Check type + mov al, BYTE [rsi] + cmp al, maltype_empty_list + je .empty_list ; empty list, return unchanged + + mov ah, al + and ah, container_mask + cmp ah, container_list + je .list_still_list + + ; Not a list, so call eval_ast on it + mov rdi, r15 ; Environment + call eval_ast + jmp .return + +.list_still_list: + and al, content_mask + cmp al, content_pointer + jne .list_eval + + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .list_eval + + ; Is a symbol, address in RBX + + ; Compare against special form symbols + + eval_cmp_symbol def_symbol ; def! + je .def_symbol + + eval_cmp_symbol let_symbol ; let* + je .let_symbol + + eval_cmp_symbol do_symbol ; do + je .do_symbol + + eval_cmp_symbol if_symbol ; if + je .if_symbol + + eval_cmp_symbol fn_symbol ; fn + je .fn_symbol + + eval_cmp_symbol quote_symbol ; quote + je .quote_symbol + + eval_cmp_symbol quasiquoteexpand_symbol + je .quasiquoteexpand_symbol + + eval_cmp_symbol quasiquote_symbol ; quasiquote + je .quasiquote_symbol + + eval_cmp_symbol defmacro_symbol ; defmacro! + je .defmacro_symbol + + eval_cmp_symbol macroexpand_symbol ; macroexpand + je .macroexpand_symbol + + eval_cmp_symbol try_symbol ; try* + je .try_symbol + + ; Unrecognised + jmp .list_eval + + + ; ----------------------------- + +.defmacro_symbol: + mov r9, 1 + jmp .def_common +.def_symbol: + xor r9, r9 ; Set R9 to 0 +.def_common: + ; Define a new symbol in current environment + ; If R9 is set to 1 then defmacro + + ; Next item should be a symbol + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Now should have a symbol + + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + jne .def_error_expecting_symbol + mov r8, [rsi + Cons.car] ; Symbol (?) + + mov al, BYTE [r8] + cmp al, maltype_symbol + jne .def_error_expecting_symbol + + ; R8 now contains a symbol + + ; expecting a value or pointer next + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .def_error_missing_arg + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a pointer + mov al, BYTE [rsi] + mov ah, al + and ah, content_mask + cmp ah, content_pointer + je .def_pointer + + ; A value, so copy + + ; Test if this is defmacro! + test r9, r9 + jnz .defmacro_not_function + + push rax + call alloc_cons + pop rbx ; BL now contains type + and bl, content_mask + add bl, (block_cons + container_value) + mov [rax], BYTE bl + mov rcx, [rsi + Cons.car] + mov [rax + Cons.car], rcx + mov rsi, rax + + jmp .def_got_value + +.def_pointer: + ; A pointer, so evaluate + + ; This may throw an error, so define a handler + + push r8 ; the symbol + push r15 ; Env + push r9 + mov rsi, [rsi + Cons.car] ; Pointer + mov rdi, r15 + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call incref_object ; AST increment refs + + call eval + mov rsi, rax + + pop r9 + + ; If this is defmacro, and the object in RSI is a function, + ; then change to a macro + test r9, r9 + jz .def_not_macro ; Not defmacro + + ; Check RSI + mov al, BYTE [rsi] + cmp al, maltype_function + jne .defmacro_not_function + + ; Got a function, change to macro + mov [rsi], BYTE maltype_macro + +.def_not_macro: + + pop r15 + pop r8 + +.def_got_value: + ; Symbol in R8, value in RSI + mov rdi, r8 ; key (symbol) + mov rcx, rsi ; Value + mov rsi, r15 ; Environment + call env_set + + mov rax, rcx + jmp .return + +.def_error_missing_arg: + mov rsi, def_missing_arg_string + mov rdx, def_missing_arg_string.len + jmp .def_handle_error + +.def_error_expecting_symbol: + mov rsi, def_expecting_symbol_string + mov rdx, def_expecting_symbol_string.len + jmp .def_handle_error + +.defmacro_not_function: + mov rsi, defmacro_expecting_function_string + mov rdx, defmacro_expecting_function_string.len + jmp .def_handle_error + +.def_handle_error: + push rsi + push rdx + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + xor rsi, rsi ; no object to throw + jmp error_throw ; No return + + ; ----------------------------- +.let_symbol: + ; Create a new environment + + mov r11, rsi ; Let form in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + mov r14, rax ; New environment in R14 + + mov rsi, r15 + call release_object ; Decrement R15 ref count + + ; Second element should be the bindings + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_bindings + mov r11, [r11 + Cons.cdr] + + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .let_error_bindings_list + + mov r12, [r11 + Cons.car] ; should be bindings list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + ; Can be either a list or vector + cmp al, block_cons + container_list + je .let_bind_loop + cmp al, block_cons + container_vector + je .let_bind_loop + + ; Not a list or vector + jmp .let_error_bindings_list + +.let_bind_loop: + ; R12 now contains a list with an even number of items + ; The first should be a symbol, then a value to evaluate + + ; Get the symbol + mov al, BYTE [r12] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_symbol + + mov r13, [r12 + Cons.car] ; Symbol (?) + mov al, BYTE [r13] + cmp al, maltype_symbol + jne .let_error_bind_symbol + + ; R13 now contains a symbol to bind + ; The next item in the bindings list (R12) + ; should be a value or expression to evaluate + + mov al, BYTE [r12 + Cons.typecdr] + and al, content_mask + cmp al, content_pointer + jne .let_error_bind_value + mov r12, [r12 + Cons.cdr] + + ; got value in R12 + + ; Check the type of the value + mov bl, [r12 + Cons.typecar] ; Type in BL + and bl, content_mask + cmp bl, content_pointer + je .let_value_pointer + + ; Not a pointer, so make a copy + call alloc_cons + mov bl, [r12 + Cons.typecar] + and bl, content_mask + ;or bl, (block_cons + container_value) ; 0 + mov [rax + Cons.typecar], bl + mov rcx, [r12 + Cons.car] + mov [rax + Cons.car], rcx + + jmp .let_got_value + +.let_value_pointer: + ; A pointer, so need to evaluate + push r11 ; let* form list + push r12 ; Position in bindings list + push r13 ; symbol to bind + push r14 ; new environment + + mov rsi, r14 + call incref_object + mov rdi, r14 + + mov rsi, [r12 + Cons.car] ; Get the address + + call incref_object ; Increment ref count of AST + + call eval ; Evaluate it, result in rax + pop r14 + pop r13 + pop r12 + pop r11 + +.let_got_value: + + mov rsi, r14 ; Env + mov rdi, r13 ; key + mov rcx, rax ; value + call env_set + + ; Release the value + mov rsi, rcx ; The value + call release_object + + ; Check if there are more bindings + mov al, BYTE [r12 + Cons.typecdr] + cmp al, content_pointer + jne .let_done_binding + mov r12, [r12 + Cons.cdr] ; Next + jmp .let_bind_loop + +.let_done_binding: + ; Done bindings. + ; Evaluate next item in let* form in new environment + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .let_error_missing_body + mov r11, [r11 + Cons.cdr] ; Now contains value to evaluate + ; Check type of the value + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + je .body_pointer + + ; Just a value, so copy + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl ; set type + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx ; copy value + jmp .let_done + +.body_pointer: + ; Evaluate using new environment + + mov rsi, [r11 + Cons.car] ; Object pointed to + call incref_object ; will be released by eval + + mov r11, rsi ; save new AST + pop rsi ; Old AST + call release_object + mov rsi, r11 ; New AST + + mov rdi, r14 ; New environment + + jmp eval ; Tail call + ; Note: eval will release the new environment on return + +.let_done: + ; Release the new environment + push rax + mov rsi, r14 + call release_object + pop rax + + ; Release the AST + pop rsi + push rax + call release_object + pop rax + ret ; already released env + +.let_error_missing_bindings: + mov rsi, let_missing_bindings_string + mov rdx, let_missing_bindings_string.len + jmp .let_handle_error + +.let_error_bindings_list: ; expected a list or vector, got something else + mov rsi, let_bindings_list_string + mov rdx, let_bindings_list_string.len + jmp .let_handle_error + +.let_error_bind_symbol: ; expected a symbol, got something else + mov rsi, let_bind_symbol_string + mov rdx, let_bind_symbol_string.len + jmp .let_handle_error + +.let_error_bind_value: ; Missing value in binding list + mov rsi, let_bind_value_string + mov rdx, let_bind_value_string.len + jmp .let_handle_error + +.let_error_missing_body: ; Missing body to evaluate + mov rsi, let_missing_body_string + mov rdx, let_missing_body_string.len + jmp .let_handle_error + +.let_handle_error: + push r11 ; For printing later + + push rsi + push rdx + + print_str_mac error_string ; print 'Error: ' + + pop rdx + pop rsi + call print_rawstring ; print message + + pop rsi ; let* form + jmp error_throw ; No return + + ; ----------------------------- + +.do_symbol: + mov r11, rsi ; do form in RSI + ; Environment in R15 + + ; Check if there is a body + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .do_no_body ; error + + mov r11, [r11 + Cons.cdr] ; Body in R11 + +.do_symbol_loop: + + ; Need to test if this is the last form + ; so we can handle tail call + + mov bl, BYTE [r11 + Cons.typecdr] + cmp bl, content_pointer + jne .do_body_last ; Last expression + + ; not the last expression + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_next ; A value, so skip + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + ; since eval will release Env + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increment ref count since eval will release + + mov rdi, r15 ; Env + call eval ; Result in RAX + + ; Another form after this. + ; Discard the result of the last eval + mov rsi, rax + call release_object + + pop r11 + pop r15 + +.do_next: + mov r11, [r11 + Cons.cdr] ; Next in list + + jmp .do_symbol_loop + +.do_body_last: + ; The last form is in R11, which will be returned + + ; Check if this is a value or pointer + mov al, BYTE [r11] + and al, block_mask + content_mask + cmp al, content_pointer + jne .do_body_value_return + jmp .do_body_expr_return + +.do_body_value_return: + ; Got a value as last form (in R11). + ; Copy and return + + push rax ; Type of value to return + + ; release Env + mov rsi, r15 + call release_object + + ; Allocate a Cons object to hold value + call alloc_cons + pop rbx ; type in BL + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + ; release the AST + pop rsi + mov r15, rax ; not modified by release + call release_object + mov rax, r15 + + ret + +.do_body_expr_return: + ; An expression to evaluate as the last form + ; Tail call optimise, jumping to eval + ; Don't increment Env reference count + + mov rsi, [r11 + Cons.car] ; new AST form + call incref_object ; This will be released by eval + + mov r11, rsi ; Save new AST + pop rsi ; Remove old AST from stack + call release_object + mov rsi, r11 + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.do_no_body: + ; No expressions to evaluate. Return nil + + mov rsi, r15 + call release_object ; Release Env + + ; release the AST + pop rsi + call release_object + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + + ; ----------------------------- + +.if_symbol: + mov r11, rsi ; if form in R11 + ; Environment in R15 + + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .if_no_condition + + mov r11, [r11 + Cons.cdr] ; Should be a condition + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .if_cond_value + + ; A pointer, so evaluate + + push r15 + push r11 + + mov rsi, r15 + call incref_object ; Increase Env reference + + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Increase Form/AST ref count + + mov rdi, r15 ; Env + call eval ; Result in RAX + pop r11 + pop r15 + + ; Get type of result + mov bl, BYTE [rax] + + ; release value + push rbx + mov rsi, rax + call release_object + pop rbx + + ; Check type + cmp bl, maltype_nil + je .if_false + cmp bl, maltype_false + je .if_false + + jmp .if_true + +.if_cond_value: + + ; A value + cmp al, content_nil + je .if_false + cmp al, content_false + je .if_false + + jmp .if_true + +.if_false: + ; Skip the next item + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil + + mov r11, [r11 + Cons.cdr] + +.if_true: + ; Get the next item in the list and evaluate it + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; Nothing to return + + mov r11, [r11 + Cons.cdr] + + ; Check if value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + je .if_got_pointer + +.if_got_value: + ; copy value in r11 + call alloc_cons + mov bl, BYTE [r11] + and bl, content_mask + mov [rax], BYTE bl + mov rbx, [r11 + Cons.car] + mov [rax + Cons.car], rbx + + jmp .return + +.if_got_pointer: + mov rsi, [r11 + Cons.car] ; Form + call incref_object ; Will be released by eval + + mov r11, rsi + pop rsi + call release_object ; Release old AST + mov rsi, r11 ; New AST + + mov rdi, r15 ; Env + jmp eval ; Tail call + +.if_no_condition: ; just (if) without a condition + + print_str_mac error_string + print_str_mac if_missing_condition_string + + ; Release environment + mov rsi, r15 + call release_object + xor rsi, rsi ; No object to throw + jmp error_throw + +.return_nil: + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + +.return: + ; Release environment + mov rsi, r15 + mov r15, rax ; Save RAX (return value) + call release_object + + ; Release the AST + pop rsi ; Pushed at start of eval + call release_object + + mov rax, r15 ; return value + ret + + ; ----------------------------- + +.fn_symbol: + mov r11, rsi ; fn form in R11 + ; Environment in R15 + + ; Get the binds and body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_empty + + mov r11, [r11 + Cons.cdr] + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_binds_not_list + + mov r12, [r11 + Cons.car] ; Should be binds list + mov al, BYTE [r12] + and al, (block_mask + container_mask) + cmp al, (block_cons + container_list) + je .fn_got_binds ; Can be list + cmp al, (block_cons + container_vector) + je .fn_got_binds ; or vector + jmp .fn_binds_not_list + +.fn_got_binds: + + ; Next get the body of the function + mov al, BYTE [r11 + Cons.typecdr] + cmp al, content_pointer + jne .fn_no_body + + mov r11, [r11 + Cons.cdr] + ; Check value or pointer + mov al, BYTE [r11] + and al, content_mask + cmp al, content_pointer + jne .fn_is_value ; Body in r11 + mov r11, [r11 + Cons.car] + jmp .fn_got_body + +.fn_is_value: + ; Body is just a value, no expression + mov [r11], BYTE al ; Mark as value, not list + +.fn_got_body: + + ; Now put into function type + ; Addr is "apply_fn", the address to call + ; Env in R15 + ; Binds in R12 + ; Body in R11 + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_function) + mov rbx, apply_fn + mov [rax + Cons.car], rbx ; Address of apply function + mov [rax + Cons.typecdr], BYTE content_pointer + + mov r13, rax ; Return list in R13 + + ; Meta + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r13 + Cons.cdr], rax ; Append + mov r14, rax + + ; Env + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r15 ; Environment + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax ; R14 contains last cons in list + + push rax + mov rsi, r15 + call incref_object + pop rax + + ; Binds + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r12 ; Binds list + mov [rax + Cons.typecdr], BYTE content_pointer + + mov [r14 + Cons.cdr], rax ; Append to list + mov r14, rax + + push rax + mov rsi, r12 + call incref_object + pop rax + + call alloc_cons + mov [rax], BYTE (block_cons + container_function + content_pointer) + mov [rax + Cons.car], r11 ; Body of function + + mov [r14 + Cons.cdr], rax + + mov rsi, r11 + call incref_object + + mov rax, r13 + jmp .return + +.fn_empty: +.fn_binds_not_list: +.fn_no_body: + + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + jmp .return + + ; ----------------------------- + +.quote_symbol: + ; Just return the arguments in rsi cdr + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quote empty, so return nil + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + call incref_object + mov rax, rsi + jmp .return + + ; ----------------------------- + +;;; Like quasiquote, but do not evaluate the result. +.quasiquoteexpand_symbol: + ;; Return nil if no cdr + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + jne .return_nil + + mov rsi, [rsi + Cons.cdr] + call car_and_incref + call quasiquote + jmp .return + + ; ----------------------------- + +.quasiquote_symbol: + ; call quasiquote function with first argument + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; quasiquote empty, so return nil + + mov r11, rsi ; Save original AST in R11 + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .quasiquote_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.quasiquote_pointer: + ; RSI contains a pointer, so get the object pointed to + mov rsi, [rsi + Cons.car] + + push r15 ; Environment + ; Original AST already on stack + + call quasiquote + ; New AST in RAX + pop rdi ; Environment + pop rsi ; Old AST + + mov r11, rax ; New AST + call release_object ; Release old AST + mov rsi, r11 ; New AST in RSI + + jmp eval ; Tail call + + ; ----------------------------- +.macroexpand_symbol: + ; Check if we have a second list element + + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .macroexpand_pointer + + ; RSI contains a value. Remove the list container + mov [rsi + Cons.typecar], BYTE al + call incref_object + mov rax, rsi + jmp .return + +.macroexpand_pointer: + mov rsi, [rsi + Cons.car] + call incref_object ; Since RSI will be released + + call macroexpand ; May release and replace RSI + + mov rax, rsi + jmp .return ; Releases original AST + + ; ----------------------------- + +.try_symbol: + ; Should have the form + ; + ; (try* A (catch* B C)) + ; + ; where B is a symbol, A and C are forms to evaluate + + ; Check first arg A + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .return_nil ; No argument + + mov rsi, [rsi + Cons.cdr] + + ; Check if this is a value or pointer + mov al, BYTE [rsi + Cons.typecar] + and al, content_mask + cmp al, content_pointer + je .try_pointer + + ; RSI contains a value. Copy and return + mov cl, al + call alloc_cons + mov [rax], BYTE cl ; Set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx + jmp .return + +.try_pointer: + + mov r8, [rsi + Cons.car] ; form A in R8 + + ; Check second arg B + + mov al, BYTE [rsi + Cons.typecdr] + ; If nil (catchless try) + cmp al, content_nil + je .catchless_try + + cmp al, content_pointer + jne .try_missing_catch + + mov rsi, [rsi + Cons.cdr] + + mov al, BYTE [rsi] + and al, content_mask + cmp al, content_pointer + jne .try_missing_catch + + mov r9, [rsi + Cons.car] ; (catch* B C) in R9 + + mov al, BYTE [r9] + cmp al, (container_list + content_pointer) + jne .try_missing_catch + + mov rsi, [r9 + Cons.car] ; Should be catch* symbol + mov al, BYTE [rsi] + cmp al, maltype_symbol + jne .try_missing_catch + + mov rdi, catch_symbol + call compare_char_array + test rax, rax ; ZF set if rax = 0 (equal) + jnz .try_missing_catch + + ; Check that B is a symbol + mov al, [r9 + Cons.typecdr] + cmp al, content_pointer + jne .catch_missing_symbol + + mov r9, [r9 + Cons.cdr] ; (B C) in R9 + + mov al, BYTE [r9] + and al, content_mask + cmp al, content_pointer + jne .catch_missing_symbol + + mov r10, [r9 + Cons.car] ; B in R10 + mov al, BYTE [r10] + cmp al, maltype_symbol + jne .catch_missing_symbol + + mov al, BYTE [r9 + Cons.typecdr] + cmp al, content_pointer + jne .catch_missing_form + mov r9, [r9 + Cons.cdr] ; C in R9 + + ; Now have extracted from (try* A (catch* B C)) + ; A in R8 + ; B in R10 + ; C in R9 + + push R9 + push R10 + push r15 ; Env + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the form in R8 + mov rsi, r15 + call incref_object ; Env released by eval + mov rdi, r15 ; Env in RDI + + mov rsi, r8 ; The form to evaluate (A) + + call incref_object ; AST released by eval + + call eval + + mov r8, rax ; Result in R8 + + pop r15 ; Environment + ; Discard B and C + ;add rsi, 8 ; pop R10 and R9 + pop r10 + pop r9 + + ; Remove error handler + call error_handler_pop + mov rax, r8 + jmp .return + +.catchless_try: + ;; Evaluate the form in R8 + push r15 ; Environment + + mov rsi, r15 + call incref_object ; Env released by eval + mov rdi, r15 ; Env in RDI + + mov rsi, r8 ; The form to evaluate (A) + + call incref_object ; AST released by eval + + call eval ; Result in RAX + + pop r15 ; Environment + + jmp .return +.catch: + ; Jumps here on error + ; Value thrown in RSI + ; + + push rsi + call error_handler_pop + pop rsi + + pop r15 ; Env + pop r12 ; B (symbol to bind) + pop r13 ; C (form to evaluate) + + ; Check if C is a value or pointer + + mov cl, BYTE [r13] + and cl, content_mask + cmp cl, content_pointer + je .catch_C_pointer + + ; A value, so copy and return + call alloc_cons + mov [rax], BYTE cl ; Set type + mov rbx, [r13 + Cons.car] + mov [rax + Cons.car], rbx ; Set value + + jmp .return + +.catch_C_pointer: + + mov r11, rsi ; Value thrown in R11 + + mov rsi, r15 ; Outer env + call env_new ; Increments R15's ref count + + mov rsi, rax ; New environment in RSI + mov rdi, r12 ; key (symbol) + mov rcx, r11 ; value + call env_set + + mov rdi, rsi ; Env in RDI (will be released) + mov rsi, [r13 + Cons.car] ; Form to evaluate + call incref_object ; will be released + + push r15 + call eval + pop r15 + + jmp .return + +.try_missing_catch: + load_static try_missing_catch + call raw_to_string + mov rsi, rax + jmp error_throw + +.catch_missing_symbol: + load_static catch_missing_symbol + call raw_to_string + mov rsi, rax + jmp error_throw + +.catch_missing_form: + load_static catch_missing_form + call raw_to_string + mov rsi, rax + jmp error_throw + + ; ----------------------------- + +.list_eval: + push rsi + mov rdi, r15 ; Environment + push r15 + call eval_ast ; List of evaluated forms in RAX + pop r15 + pop rsi + +.list_exec: + ; This point can be called to run a function + ; used by swap! + ; + ; Inputs: RAX - List with function as first element + ; NOTE: This list is released + ; + ; Check that the first element of the return is a function + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .list_not_function + + mov rbx, [rax + Cons.car] ; Get the address + mov cl, BYTE [rbx] + cmp cl, maltype_function + jne .list_not_function + + ; Check the rest of the args + mov cl, BYTE [rax + Cons.typecdr] + cmp cl, content_pointer + je .list_got_args + + ; No arguments + push rbx ; Function object + push rax ; List with function first + + ; Create an empty list for the arguments + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax ; Argument list into RSI + + pop rax ; list, function first + ;; Put new empty list onto end of original list + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.cdr], rsi + + pop rbx + jmp .list_function_call +.list_got_args: + mov rsi, [rax + Cons.cdr] ; Rest of list +.list_function_call: + ; Call the function with the rest of the list in RSI + + mov rdx, rax ; List to release + mov rdi, rbx ; Function object in RDI + + mov rbx, [rbx + Cons.car] ; Call function + cmp rbx, apply_fn + je apply_fn_jmp ; Jump to user function apply + + ; A built-in function, so call (no recursion) + push rax + push r15 + + call rbx + + ; Result in rax + pop r15 + pop rsi ; eval'ed list + + push rax + call release_cons + pop rax + jmp .return ; Releases Env + +.list_not_function: + ; Not a function. Probably an error + push rsi + + mov rsi, rax + call release_object + + print_str_mac error_string + print_str_mac eval_list_not_function + pop rsi + jmp error_throw + +.empty_list: + mov rax, rsi + jmp .return + +;; Applies a user-defined function +;; +;; Input: RSI - Arguments to bind +;; RDI - Function object +;; RDX - list to release after binding +;; R15 - Env (will be released) +;; R13 - AST released before return +;; +;; +;; Output: Result in RAX +;; +;; This is jumped to from eval, so if it returns +;; then it will return to the caller of eval, not to eval +apply_fn_jmp: + ; This is jumped to from eval with AST on the stack + pop r13 +apply_fn: + push rsi + ; Extract values from the list in RDI + mov rax, [rdi + Cons.cdr] + mov rax, [rax + Cons.cdr] ; Meta (don't need) + mov rsi, [rax + Cons.car] ; Env + mov rax, [rax + Cons.cdr] + mov rdi, [rax + Cons.car] ; Binds + mov rax, [rax + Cons.cdr] + mov rax, [rax + Cons.car] ; Body + pop rcx ; Exprs + + ; Check the type of the body + mov bl, BYTE [rax] + and bl, block_mask + container_mask + jnz .bind + ; Just a value (in RAX). No eval needed + + mov r14, rax ; Save return value in R14 + + mov rsi, rax + call incref_object + + ; Release the list passed in RDX + mov rsi, rdx + call release_object + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the AST + mov rsi, r13 + call release_object + + mov rax, r14 + ret +.bind: + ; Create a new environment, binding arguments + push rax ; Body + + mov r14, r13 ; Old AST. R13 used by env_new_bind + + push rdx + call env_new_bind + pop rdx + + mov rdi, rax ; New environment in RDI + + ; Note: Need to increment the reference count + ; of the function body before releasing anything, + ; since if the function was defined in-place (lambda) + ; then the body may be released early + + pop rsi ; Body + call incref_object ; Will be released by eval + mov r8, rsi ; Body in R8 + + ; Release the list passed in RDX + mov rsi, rdx + call release_cons + + ; Release the environment + mov rsi, r15 + call release_object + + ; Release the old AST + mov rsi, r14 + call release_object + + mov rsi, r8 ; Body + + jmp eval ; Tail call + ; The new environment (in RDI) will be released by eval + + +;;; Called by eval +;;; Original AST in RSI. +;;; Returns new AST in RAX +quasiquote: + ;; Dispatch on the type. + mov al, BYTE [rsi + Cons.typecar] + mov cl, al ; keep full al for .list + and cl, container_mask + cmp cl, container_list + je .list + cmp cl, container_map + je .map + cmp cl, container_symbol + je .symbol + cmp cl, container_vector + je .vector + ;; return other types unchanged + call incref_object + mov rax, rsi + ret + +.list: + ;; AST is a list, process it with qq_foldr unless.. + mov cl, al ; it is not empty, + and cl, content_mask + cmp cl, content_empty + je qq_foldr + + cmp cl, content_pointer ; and it is a pointer, + jne qq_foldr + + mov rdi, [rsi + Cons.car] ; and the first element is a symbol, + mov cl, BYTE [rdi + Cons.typecar] + cmp cl, maltype_symbol + jne qq_foldr + + mov r8, rsi ; and the symbol is 'unquote, + mov rsi, unquote_symbol + call compare_char_array + test rax, rax + mov rsi, r8 + jne qq_foldr + + mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. + cmp cl, content_pointer + jne qq_foldr + + ;; If so, return the argument. + mov rsi, [rsi + Cons.cdr] + call car_and_incref + mov rax, rsi + ret + +.map: +.symbol: + call incref_object + + ;; rdx := (ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rsi + mov rdx, rax + + mov rsi, quote_symbol + call incref_object + + ;; rax := ('quote ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + +.vector: + ;; rdx := ast processed like a list + call qq_foldr + mov rdx, rax + + ;; rdx := (processed_ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], rdx + mov rdx, rax + + mov rsi, vec_symbol + call incref_object + + ;; rax := ('vec processed_ast) + call alloc_cons + mov [rax + Cons.typecar], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + + +;;; Helper for quasiquote. +;;; RSI must contain a list or vector, which may be empty. +;;; The result in RAX is always a list. +;;; Iterate on the elements in the right fold/reduce style. +qq_foldr: + mov cl, BYTE [rsi + Cons.typecar] + + cmp cl, maltype_empty_list + je .empty_list + + cmp cl, maltype_empty_vector + je .empty_vector + + ;; Extract first element and store it into the stack during + ;; the recursion. + mov rdx, rsi + call car_and_incref + push rsi + mov rsi, rdx + + ;; Extract the rest of the list. + mov al, BYTE [rsi + Cons.typecdr] + +;;; If the rest is not empty + cmp al, content_pointer + jne .else +;;; then + mov rsi, [rsi + Cons.cdr] + jmp .endif +.else: + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rsi, rax +.endif: + call qq_foldr ; recursive call + pop rsi + jmp qq_loop + +.empty_list: ;; () -> () + call incref_object + mov rax, rsi + ret + +.empty_vector: ;; [] -> () + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + + +;; Helper for quasiquote +;; The transition function starts here. +;; Current element is in rsi, accumulator in rax. +qq_loop: + mov r9, rax + + ;; Process with the element with .default, unless.. + mov cl, BYTE [rsi + Cons.typecar] ; it is a list + mov al, cl + and al, container_mask + cmp al, container_list + jne .default + + cmp cl, maltype_empty_list ; it is not empty, + je .default + + and cl, content_mask ; and it is a pointer, + cmp cl, content_pointer + jne .default + + mov rdi, [rsi + Cons.car] ; and the first element is a symbol, + mov cl, BYTE [rdi + Cons.typecar] + cmp cl, maltype_symbol + jne .default + + mov r8, rsi ; and the symbol is 'splice-unquote, + mov rsi, splice_unquote_symbol + call compare_char_array + test rax, rax + mov rsi, r8 + jne .default + + mov cl, BYTE [rsi + Cons.typecdr] ; and there is a second element. + cmp cl, content_pointer + jne .default + + ;; If so, return ('concat elt acc). + mov rsi, [rsi + Cons.cdr] + call car_and_incref + + ;; rdx := (acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.car], r9 + mov rdx, rax + + ;; rdx := (elt acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + mov rdx, rax + + mov rsi, concat_symbol + call incref_object + + ;; rax := ('concat elt acc) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + +.default: + ;; rax := (accumulator) + call alloc_cons + mov [rax + Cons.typecar], BYTE (container_list + content_pointer) + mov [rax + Cons.car], r9 + + ;; rcx := quasiquoted_element + ;; rdx := (accumulator) + push rax + call quasiquote + mov rcx, rax + pop rdx + + ;; rdx := (quasiquoted_element accumulator) + call alloc_cons + mov [rax + Cons.typecar], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rcx + mov [rax + Cons.cdr], rdx + mov rdx, rax + + mov rsi, cons_symbol + call incref_object + + ;; rax := ('cons quasiquoted_elt accumulator) + call alloc_cons + mov [rax], BYTE (container_list + content_pointer) + mov [rax + Cons.typecdr], BYTE content_pointer + mov [rax + Cons.car], rsi + mov [rax + Cons.cdr], rdx + + ret + + +;; Tests if an AST in RSI is a list containing +;; a macro defined in the ENV in R15 +;; +;; Inputs: AST in RSI (not modified) +;; ENV in R15 (not modified) +;; +;; Returns: Sets ZF if macro call. If set (true), +;; then the macro object is in RAX +;; +;; Modifies: +;; RAX +;; RBX +;; RCX +;; RDX +;; R8 +;; R9 +is_macro_call: + ; Test if RSI is a list which contains a pointer + mov al, BYTE [rsi] + cmp al, (block_cons + container_list + content_pointer) + jne .false + + ; Test if this is a symbol + mov rbx, [rsi + Cons.car] + mov al, BYTE [rbx] + cmp al, maltype_symbol + jne .false + + ; Look up symbol in Env + push rsi + push r15 + mov rdi, rbx ; symbol in RDI + mov rsi, r15 ; Environment in RSI + call env_get + pop r15 + pop rsi + jne .false ; Not in environment + + ; Object in RAX + ; If this is not a macro then needs to be released + mov dl, BYTE [rax] + + cmp dl, maltype_macro + je .true + + ; Not a macro, so release + mov r8, rsi + mov rsi, rax + call release_object + mov rsi, r8 + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + mov rbx, rax ; Returning Macro object + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rbx + ret + +;; Expands macro calls +;; +;; Input: AST in RSI (released and replaced) +;; Env in R15 (not modified) +;; +;; Result: New AST in RSI +macroexpand: + push r15 + + call is_macro_call + jne .done + + mov r13, rsi + + mov rdi, rax ; Macro in RDI + + ; Check the rest of the args + mov cl, BYTE [rsi + Cons.typecdr] + cmp cl, content_pointer + je .got_args + + ; No arguments. Create an empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + mov rdx, rax + + mov rsi, rdx ; Arguments (empty list) + call incref_object + jmp .macro_call +.got_args: + mov rsi, [rsi + Cons.cdr] ; Rest of list + call incref_object + mov rdx, rsi ; Released +.macro_call: + ; Here have: + ; RSI - Arguments + ; RDI - Macro object + ; RDX - List to release + ; R15 - Environment + ; R13 - AST + + ; Increment reference for Environment + ; since this will be released by apply_fn + xchg rsi, r15 + call incref_object + xchg rsi, r15 + + call apply_fn + + mov rsi, rax ; Result in RSI + + pop r15 + jmp macroexpand +.done: + pop r15 + ret + +;; Read and eval +read_eval: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + jmp eval ; This releases Env and Form/AST + + +;; Read-Eval-Print in sequence +;; +;; Input string in RSI +rep_seq: + ; ------------- + ; Read + call read_str + + ; ------------- + ; Eval + mov rsi, rax ; Form to evaluate + mov rdi, [repl_env] ; Environment + + xchg rsi, rdi + call incref_object ; Environment increment refs + xchg rsi, rdi ; since it will be decremented by eval + + call eval ; This releases Env and Form/AST + push rax ; Save result of eval + + ; ------------- + ; Print + + mov rsi, rax ; Output of eval into input of print + mov rdi, 1 ; print readably + call pr_str ; String in RAX + + mov r8, rax ; Save output + + pop rsi ; Result from eval + call release_object + mov rax, r8 + + ret + + +_start: + ; Create and print the core environment + call core_environment ; Environment in RAX + + mov [repl_env], rax ; store in memory + + ; Set the error handler + mov rsi, rsp ; Stack pointer + mov rdi, .catch ; Address to jump to + xor rcx, rcx ; No data + call error_handler_push + + ; Evaluate the startup string + + mov rsi, mal_startup_string + mov edx, mal_startup_string.len + call raw_to_string ; String in RAX + + push rax + mov rsi, rax + call read_str ; AST in RAX + pop rsi ; string + + push rax ; AST + call release_array ; string + pop rdi ; AST in RDI + + mov rsi, [repl_env] ; Environment in RSI + + call incref_object ; Environment increment refs + xchg rsi, rdi ; Env in RDI, AST in RSI + + call eval + + mov rsi, rax + call release_object ; Return from eval + + ; ----------------------------- + ; Check command-line arguments + + pop rax ; Number of arguments + cmp rax, 1 ; Always have at least one, the path to executable + jg run_script + + ; No extra arguments, so just set *ARGV* to an empty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov rcx, rax ; value (empty list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + ; ----------------------------- + ; Header + + load_static mal_startup_header + call raw_to_string + push rax + + mov rsi, rax + call read_eval ; no print ('nil') + mov rsi, rax + call release_object ; Release result of eval + + ; Release the input string + pop rsi + call release_array + + ; ----------------------------- + ; Main loop + +.mainLoop: + ; print the prompt + print_str_mac prompt_string + + call read_line + + ; Check if we have a zero-length string + cmp DWORD [rax+Array.length], 0 + je .mainLoopEnd + + push rax ; Save address of the string + + mov rsi, rax + call rep_seq ; Read-Eval-Print + + push rax ; Save returned string + + mov rsi, rax ; Put into input of print_string + call print_string + + ; Release string from rep_seq + pop rsi + call release_array + + ; Release the input string + pop rsi + call release_array + + jmp .mainLoop +.mainLoopEnd: + + jmp quit + +.catch: + ; Jumps here on error + + ; Check if an object was thrown + cmp rsi, 0 + je .catch_done_print ; nothing to print + + push rsi + print_str_mac error_string ; print 'Error: ' + pop rsi + + mov rdi, 1 + call pr_str + mov rsi, rax + call print_string +.catch_done_print: + jmp .mainLoop ; Go back to the prompt + + + +run_script: + ; Called with number of command-line arguments in RAX + mov r8, rax + pop rbx ; executable + dec r8 + + pop rsi ; Address of first arg + call cstring_to_string ; string in RAX + mov r9, rax + + ; get the rest of the args + xor r10, r10 ; Zero + dec r8 + jz .no_args + + ; Got some arguments +.arg_loop: + ; Got an argument left. + pop rsi ; Address of C string + call cstring_to_string ; String in RAX + mov r12, rax + + ;Make a Cons to point to the string + call alloc_cons ; in RAX + mov [rax], BYTE (block_cons + container_list + content_pointer) + mov [rax + Cons.car], r12 + + test r10, r10 + jnz .append + + ; R10 zero, so first arg + mov r10, rax ; Head of list + mov r11, rax ; Tail of list + jmp .next +.append: + ; R10 not zero, so append to list tail + mov [r11 + Cons.cdr], rax + mov [r11 + Cons.typecdr], BYTE content_pointer + mov r11, rax +.next: + dec r8 + jnz .arg_loop + jmp .got_args + +.no_args: + ; No arguments. Create an emoty list + call alloc_cons ; in RAX + mov [rax], BYTE maltype_empty_list + mov r10, rax + +.got_args: + push r9 ; File name string + + mov rcx, r10 ; value (list) + mov rdi, argv_symbol ; symbol (*ARGV*) + mov rsi, [repl_env] ; environment + call env_set + + mov rsi, run_script_string ; load-file function + mov edx, run_script_string.len + call raw_to_string ; String in RAX + + mov rsi, rax + pop rdx ; File name string + call string_append_string + + mov cl, 34 ; " + call string_append_char + mov cl, ')' + call string_append_char ; closing brace + + ; Read-Eval "(load-file )" + call read_eval + + jmp quit diff --git a/impls/nasm/system.asm b/impls/nasm/system.asm index e22ae13750..69720b7835 100644 --- a/impls/nasm/system.asm +++ b/impls/nasm/system.asm @@ -1,233 +1,233 @@ -;;; System call functions -;;; -;;; This file contains system-specific functions, -;;; which use calls to the operating system (Linux) - -section .data - static error_open_file_string, db "Error opening file " - static error_read_file_string, db "Error reading file " - -section .bss - -timespec: RESQ 2 - -section .text - -;; ------------------------------------------- -;; Prints a raw string to stdout -;; String address in rsi, string length in rdx -print_rawstring: - push rax - push rdi - - ; write(1, string, length) - mov rax, 1 ; system call 1 is write - mov rdi, 1 ; file handle 1 is stdout - syscall - - pop rdi - pop rax - - ret - -;------------------------------------------ -; void exit() -; Exit program and restore resources -quit: - mov eax, 60 ; system call 60 is exit - xor rdi, rdi ; exit code 0 - syscall ; invoke operating system to exit - -quit_error: - mov eax, 60 ; system call 60 is exit - mov rdi, 1 ; exit code 1 - syscall - - -;; Read a line from stdin -;; Gets a new string array, fills it until a newline or EOF is reached -;; Returns pointer to string in RAX -read_line: - ; Get an array to put the string into - ; Address in rax - call alloc_array - ; Mark it as a character array (string) - mov BYTE [rax + Array.type], maltype_string - - push rax ; Save pointer to string - - ; Read character by character until either newline or end of input - mov ebx, 0 ; Count how many characters read - mov rsi, rax - add rsi, Array.data ; Point to the data -.readLoop: - mov rax, 0 ; sys_read - mov rdi, 0 ; stdin - mov rdx, 1 ; count - syscall - - ; Characters read in RAX - cmp rax, 0 ; end loop if read <= 0 - jle .readLoopEnd - - mov cl, BYTE [rsi] - - cmp cl, 10 ; End if we read a newline - je .readLoopEnd - - cmp cl, 8 ; Backspace? - je .handleBackspace - - cmp cl, 31 ; Below space - jle .readLoop ; Ignore, keep going - - cmp cl, 127 ; DEL or above - jge .readLoop ; Ignore, keep going - - inc ebx - inc rsi ; Move to next point in the array - jmp .readLoop ; Get another character - -.handleBackspace: - ; Check if we've read any characters - cmp ebx, 0 - je .readLoop ; If not, carry on the loop - ; Characters have been read. Remove one - dec ebx - dec rsi - jmp .readLoop -.readLoopEnd: - pop rax ; Restore pointer to string - mov DWORD [rax + Array.length], ebx ; Set string length - ret - -;; Reads a file into a string -;; -;; Input: RSI - File name string (char Array) -;; -;; Returns: string in RAX -;; -;; Pieces from https://stackoverflow.com/questions/20133698/how-to-read-from-and-write-to-files-using-nasm-for-x86-64bit -read_file: - - mov rdi, rsi ; Filename - - ; Need to add null terminator - mov eax, DWORD [rdi + Array.length] - cmp eax, (array_chunk_len * 8) - je .error_filename ; File name too long - - ; Insert a null terminator - add rax, rdi - mov [rax + Array.data], BYTE 0 - - ; Open the file - mov rax, 2 - add rdi, Array.data; filename in RDI - xor rsi, rsi ; O_RDONLY in RSI - syscall - - ; Check for error (return -1) - cmp eax, 0 - jl .error_open - - mov rdi, rax ; File handle in RDI - - ; Create a string - push rdi - call string_new ; In RAX - pop rdi - - mov r9, rax ; Current Array - push rax ; This is popped in .done -.loop: - ; Read next chunk - push r9 - - mov rsi, r9 - add rsi, Array.data ; address - - mov rax, 0 ; sys_read - ; file handle in RDI - mov rdx, (array_chunk_len * 8) ; count - syscall - - pop r9 - - ; Characters read in RAX - - cmp rax, 0 - jl .error_read - - cmp rax, (array_chunk_len * 8) - jg .error_read - - mov [r9 + Array.length], DWORD eax - - jl .done - - ; May still be more to read. - ; Allocate another - call string_new - mov [r9 + Array.next], rax - mov r9, rax - jmp .loop - -.done: - ; Close the file - mov rax, 3 - ;rdi = file handle - syscall - - pop rax - ret - -.error_filename: -.error_open: - ; File name in RDI - sub rdi, Array.data - - ; Make the error message - mov rsi, error_open_file_string - mov edx, error_open_file_string.len - call raw_to_string - mov rsi, rax - mov cl, 39 ; (') - call string_append_char - mov rdx, rdi ; file name - call string_append_string - mov cl, 39 - call string_append_char - - ; Error message in RSI - jmp error_throw - -.error_read: - mov rsi, error_read_file_string - mov edx, error_read_file_string.len - call raw_to_string - mov rsi, rax - jmp error_throw - - - -;; Returns the time in ms in RAX -clock_time_ms: - mov rax, 228 ; clock_gettime - mov rdi, 0 ; CLOCK_REALTIME - mov rsi, timespec - syscall - - mov rax, [timespec + 8] ; nanoseconds - cqo ; Sign extend RAX into RDX - mov rcx, 1000000 - idiv rcx ; Divide RAX by 1e6 -> ms - mov rbx, rax - ; -> ms in RBX - - mov rax, [timespec] ; Seconds - mov rcx, 1000 - imul rcx ; Convert to ms - add rax, rbx ; Add RBX - - ret +;;; System call functions +;;; +;;; This file contains system-specific functions, +;;; which use calls to the operating system (Linux) + +section .data + static error_open_file_string, db "Error opening file " + static error_read_file_string, db "Error reading file " + +section .bss + +timespec: RESQ 2 + +section .text + +;; ------------------------------------------- +;; Prints a raw string to stdout +;; String address in rsi, string length in rdx +print_rawstring: + push rax + push rdi + + ; write(1, string, length) + mov rax, 1 ; system call 1 is write + mov rdi, 1 ; file handle 1 is stdout + syscall + + pop rdi + pop rax + + ret + +;------------------------------------------ +; void exit() +; Exit program and restore resources +quit: + mov eax, 60 ; system call 60 is exit + xor rdi, rdi ; exit code 0 + syscall ; invoke operating system to exit + +quit_error: + mov eax, 60 ; system call 60 is exit + mov rdi, 1 ; exit code 1 + syscall + + +;; Read a line from stdin +;; Gets a new string array, fills it until a newline or EOF is reached +;; Returns pointer to string in RAX +read_line: + ; Get an array to put the string into + ; Address in rax + call alloc_array + ; Mark it as a character array (string) + mov BYTE [rax + Array.type], maltype_string + + push rax ; Save pointer to string + + ; Read character by character until either newline or end of input + mov ebx, 0 ; Count how many characters read + mov rsi, rax + add rsi, Array.data ; Point to the data +.readLoop: + mov rax, 0 ; sys_read + mov rdi, 0 ; stdin + mov rdx, 1 ; count + syscall + + ; Characters read in RAX + cmp rax, 0 ; end loop if read <= 0 + jle .readLoopEnd + + mov cl, BYTE [rsi] + + cmp cl, 10 ; End if we read a newline + je .readLoopEnd + + cmp cl, 8 ; Backspace? + je .handleBackspace + + cmp cl, 31 ; Below space + jle .readLoop ; Ignore, keep going + + cmp cl, 127 ; DEL or above + jge .readLoop ; Ignore, keep going + + inc ebx + inc rsi ; Move to next point in the array + jmp .readLoop ; Get another character + +.handleBackspace: + ; Check if we've read any characters + cmp ebx, 0 + je .readLoop ; If not, carry on the loop + ; Characters have been read. Remove one + dec ebx + dec rsi + jmp .readLoop +.readLoopEnd: + pop rax ; Restore pointer to string + mov DWORD [rax + Array.length], ebx ; Set string length + ret + +;; Reads a file into a string +;; +;; Input: RSI - File name string (char Array) +;; +;; Returns: string in RAX +;; +;; Pieces from https://stackoverflow.com/questions/20133698/how-to-read-from-and-write-to-files-using-nasm-for-x86-64bit +read_file: + + mov rdi, rsi ; Filename + + ; Need to add null terminator + mov eax, DWORD [rdi + Array.length] + cmp eax, (array_chunk_len * 8) + je .error_filename ; File name too long + + ; Insert a null terminator + add rax, rdi + mov [rax + Array.data], BYTE 0 + + ; Open the file + mov rax, 2 + add rdi, Array.data; filename in RDI + xor rsi, rsi ; O_RDONLY in RSI + syscall + + ; Check for error (return -1) + cmp eax, 0 + jl .error_open + + mov rdi, rax ; File handle in RDI + + ; Create a string + push rdi + call string_new ; In RAX + pop rdi + + mov r9, rax ; Current Array + push rax ; This is popped in .done +.loop: + ; Read next chunk + push r9 + + mov rsi, r9 + add rsi, Array.data ; address + + mov rax, 0 ; sys_read + ; file handle in RDI + mov rdx, (array_chunk_len * 8) ; count + syscall + + pop r9 + + ; Characters read in RAX + + cmp rax, 0 + jl .error_read + + cmp rax, (array_chunk_len * 8) + jg .error_read + + mov [r9 + Array.length], DWORD eax + + jl .done + + ; May still be more to read. + ; Allocate another + call string_new + mov [r9 + Array.next], rax + mov r9, rax + jmp .loop + +.done: + ; Close the file + mov rax, 3 + ;rdi = file handle + syscall + + pop rax + ret + +.error_filename: +.error_open: + ; File name in RDI + sub rdi, Array.data + + ; Make the error message + mov rsi, error_open_file_string + mov edx, error_open_file_string.len + call raw_to_string + mov rsi, rax + mov cl, 39 ; (') + call string_append_char + mov rdx, rdi ; file name + call string_append_string + mov cl, 39 + call string_append_char + + ; Error message in RSI + jmp error_throw + +.error_read: + mov rsi, error_read_file_string + mov edx, error_read_file_string.len + call raw_to_string + mov rsi, rax + jmp error_throw + + + +;; Returns the time in ms in RAX +clock_time_ms: + mov rax, 228 ; clock_gettime + mov rdi, 0 ; CLOCK_REALTIME + mov rsi, timespec + syscall + + mov rax, [timespec + 8] ; nanoseconds + cqo ; Sign extend RAX into RDX + mov rcx, 1000000 + idiv rcx ; Divide RAX by 1e6 -> ms + mov rbx, rax + ; -> ms in RBX + + mov rax, [timespec] ; Seconds + mov rcx, 1000 + imul rcx ; Convert to ms + add rax, rbx ; Add RBX + + ret diff --git a/impls/nasm/types.asm b/impls/nasm/types.asm index 56de3cb1f0..5bcf2bfead 100644 --- a/impls/nasm/types.asm +++ b/impls/nasm/types.asm @@ -1,1964 +1,1964 @@ -;; Data structures -;; =============== -;; -;; Memory management is done by having two fixed-size datatypes, -;; Cons and Array. -;; -;; Both Cons and Array have the following in common: -;; a type field at the start, a reference count, followed by data -;; [ type (8) | (8) | refs (16) | data ] -;; -;; -;; Type bit fields -;; --------------- -;; -;; The 8-bit type fields describe the Block, Container and Content type. -;; -;; The Block type is used for memory management, to determine the kind of memory block -;; The Container type indicates the data structure that the Cons or Array block is being used to represent -;; The Content type indicates the raw type of the data in the content -;; -;; Block type [1 bit]: -;; 0 0 - Cons memory block -;; 1 1 - Array memory block -;; -;; Container type [3 bits]: -;; 0 0 - Value (single boxed value for Cons blocks, multiple values for Array blocks). -;; 2 1 - List (value followed by pointer). Only for Cons blocks -;; 4 2 - Symbol (special char array). Only for Array blocks -;; 6 3 - Keyword. Only for Array blocks -;; 8 4 - Map -;; 10 5 - Function -;; 12 6 - Atom -;; 14 7 - Vector -;; -;; Content type [4 bits]: -;; 0 0 - Nil -;; 16 1 - True -;; 32 2 - Char -;; 48 3 - Int -;; 64 4 - Float -;; 80 5 - Pointer (memory address) -;; 96 6 - Function (instruction address) -;; 112 7 - Empty (distinct from Nil) -;; 208 8 - False -;; 224 9 - Macro -;; -;; -;; These represent MAL data types as follows: -;; -;; MAL type Block Container Content -;; --------- | -------- | ---------- | --------- -;; integer Cons Value Int -;; symbol Array Symbol Char -;; list Cons List Any -;; vector Cons Vector Any -;; nil Cons Value Nil -;; true Cons Value True -;; false Cons Value False -;; string Array Value Char -;; keyword Array Keyword Char -;; hash-map Cons Map Alternate key, values -;; atom Cons Atom Pointer -;; - -%include "macros.mac" - -;; Cons type. -;; Used to store either a single value with type information -;; or a pair of (value, Pointer or Nil) to represent a list -STRUC Cons -.typecar: RESB 1 ; Type information for car (8 bit) -.typecdr: RESB 1 ; Type information for cdr (8 bits) -.refcount: RESW 1 ; Number of references to this Cons (16 bit) -.car: RESQ 1 ; First value (64 bit) -.cdr: RESQ 1 ; Second value (64 bit) -.size: ; Total size of struc -ENDSTRUC - - -%define array_chunk_len 32 ; Number of 64-bit values which can be stored in a single chunk - -STRUC Array -.type: RESB 1 ; Type information (8 bits) -.control: RESB 1 ; Control data (8 bits) -.refcount: RESW 1 ; Number of references to this Array (16 bit) -.length: RESD 1 ; Number of elements in this part of the array (32 bit) -.next RESQ 1 ; Pointer to the next chunk (64 bit) -.data: RESQ array_chunk_len ; Data storage -.size: ; Total size of struc -ENDSTRUC - -;; Type information - -%define block_mask 1 ; LSB for block type -%define container_mask 2 + 4 + 8 ; Next three bits for container type -%define content_mask 16 + 32 + 64 + 128 ; Four bits for content type - -;; Block types -%define block_cons 0 ; Note: This must be zero -%define block_array 1 - -;; Container types -%define container_value 0 ; Note: This must be zero -%define container_list 2 -%define container_symbol 4 -%define container_keyword 6 -%define container_map 8 -%define container_function 10 -%define container_atom 12 -%define container_vector 14 - -;; Content type -%define content_nil 0 -%define content_true 16 -%define content_char 32 -%define content_int 48 -%define content_float 64 -%define content_pointer 80 ; Memory pointer (to Cons or Array) -%define content_function 96 ; Function pointer -%define content_empty 112 -%define content_false 208 -%define content_macro 224 - -;; Common combinations for MAL types -%define maltype_integer (block_cons + container_value + content_int) -%define maltype_string (block_array + container_value + content_char) -%define maltype_symbol (block_array + container_symbol + content_char) -%define maltype_nil (block_cons + container_value + content_nil) -%define maltype_empty_list (block_cons + container_list + content_empty) -%define maltype_empty_map (block_cons + container_map + content_empty) -%define maltype_empty_vector (block_cons + container_vector + content_empty) -%define maltype_function (block_cons + container_function + content_function) -%define maltype_macro (block_cons + container_function + content_macro) -%define maltype_true (block_cons + container_value + content_true) -%define maltype_false (block_cons + container_value + content_false) -%define maltype_atom (block_cons + container_atom + content_pointer) - -;; ------------------------------------------ - -section .data - -;; Fixed strings for printing - - static error_msg_print_string, db "Error in print string",10 - static error_array_memory_limit, db "Error: Run out of memory for Array objects. Increase heap_array_limit.",10 - static error_cons_memory_limit, db "Error: Run out of memory for Cons objects. Increase heap_cons_limit.",10 - - static error_cons_double_free, db "Error: double free error releasing Cons" - static error_array_double_free, db "Error: double free error releasing Array" - -;; ------------------------------------------ -;; Memory management -;; -;; For each object (Cons or Array), there is a block of memory (in BSS). -;; When an object is requested it is first taken from the free list -;; If the free list is empty (address 0) then the next object in the block -;; is used, and the heap_x_number counter is incremented. When an object -;; is free'd it is pushed onto the heap_x_free list. - - -%define heap_cons_limit 5000 ; Number of cons objects which can be created - -heap_cons_next: dq heap_cons_store ; Address of next cons in memory -heap_cons_free: dq 0 ; Address of start of free list - -%define heap_array_limit 2000 ; Number of array objects which can be created - -heap_array_next: dq heap_array_store -heap_array_free: dq 0 - -section .bss - -;; Reserve space to store Cons and Array objects -heap_cons_store: resb heap_cons_limit * Cons.size -.end: ; Address of end of the store - -heap_array_store: resb heap_array_limit * Array.size -.end: - -section .text - -;; ------------------------------------------ -;; Array alloc_array() -;; -;; Returns the address of an Array object in RAX -;; -;; Working registers: rbx -alloc_array: - - ; Get the address of a free array - mov rax, [heap_array_free] ; Address of the array - - ; Check if it's null - cmp rax, 0 - je .create_array - - mov rbx, [rax + Array.next] ; Get the address of the next array in the linked list - mov [heap_array_free], rbx ; Put this address at the front of the list - jmp .initialise_array - -.create_array: - - ; Get the address of the next Array - mov rax, [heap_array_next] - ; Check if we've reached the end - cmp rax, heap_array_store.end - je .out_of_memory - - mov rbx, rax - add rbx, Array.size ; Address of the next array - mov [heap_array_next], rbx ; for next time - -.initialise_array: - ; Address of Array now in rax - mov BYTE [rax + Array.type], block_array - mov WORD [rax + Array.refcount], 1 ; Only one reference - mov DWORD [rax + Array.length], 0 - mov QWORD [rax + Array.next], 0 ; null next address - - ret - -.out_of_memory: - mov rsi, error_array_memory_limit - mov rdx, error_array_memory_limit.len - call print_rawstring - jmp quit_error - - -;; ------------------------------------------- -;; Decrements the reference count of the array in RSI -;; If the count reaches zero then push the array -;; onto the free list -release_array: - mov ax, WORD [rsi + Array.refcount] - - ; Check if reference count is already zero - test ax,ax - jz .double_free - - dec ax - mov WORD [rsi + Array.refcount], ax - jz .free ; If the count reaches zero then put on free list - ret - -.free: - ; Get the next field - mov rbx, [rsi + Array.next] - - mov rax, [heap_array_free] ; Get the current head - mov [rsi + Array.next], rax ; Put current head into the "next" field - mov [heap_array_free], rsi ; Push Array onto free list - - cmp rbx, 0 - jne .release_next ; If there is another array, then need to release it - - ret - -.release_next: - ; release the next array - mov rsi, rbx - call release_array - ret - -.double_free: - ret - load_static error_cons_double_free - call raw_to_string - mov rsi, rax - jmp error_throw - -;; ------------------------------------------ -;; Cons alloc_cons() -;; -;; Returns the address of a Cons object in RAX -;; -;; Modifies: -;; RBX -alloc_cons: - - ; Get the address of a free cons - mov rax, [heap_cons_free] ; Address of the cons - - ; Check if it's null - cmp rax, 0 - je .create_cons - - mov rbx, [rax + Cons.cdr] ; Get the address of the next cons in the linked list - mov [heap_cons_free], rbx ; Put this address at the front of the list - jmp .initialise_cons - -.create_cons: - - ; Get the address of the next Cons - mov rax, [heap_cons_next] - ; Check if we've reached the end - cmp rax, heap_cons_store.end - je .out_of_memory - - mov rbx, rax - add rbx, Cons.size ; Address of the next cons - mov [heap_cons_next], rbx ; for next time - -.initialise_cons: - ; Address of Cons now in rax - mov BYTE [rax + Cons.typecar], 0 - mov BYTE [rax + Cons.typecdr], 0 - mov WORD [rax + Cons.refcount], 1 ; Only one reference - mov QWORD [rax + Cons.car], 0 - mov QWORD [rax + Cons.cdr], 0 - ret - -.out_of_memory: - mov rsi, error_cons_memory_limit - mov rdx, error_cons_memory_limit.len - call print_rawstring - jmp quit_error - - -;; ------------------------------------------- -;; Decrements the reference count of the cons in RSI -;; If the count reaches zero then push the cons -;; onto the free list -;; -;; Modifies registers: -;; RAX -;; RBX -;; RCX -;; -release_cons: - mov ax, WORD [rsi + Cons.refcount] - - ; Check if already released - test ax,ax - jz .double_free - - dec ax - mov WORD [rsi + Cons.refcount], ax - jz .free ; If the count reaches zero then put on free list - ret - -.free: - ; Get and push cdr onto stack - mov rcx, [rsi + Cons.cdr] - push rcx ; Content of CDR - push rsi ; Original Cons object being released - - mov rax, [heap_cons_free] ; Get the current head - mov [rsi + Cons.cdr], rax ; Put current head into the "cdr" field - mov [heap_cons_free], rsi ; Push Cons onto free list - - ; Check if the CAR needs to be released - - mov al, BYTE [rsi+Cons.typecar] - and al, content_mask ; Test content type - cmp al, content_pointer - jne .free_cdr ; Jump if CAR not pointer - - ; CAR is a pointer to either a Cons or Array - ; Get the address stored in CAR - mov rsi, [rsi + Cons.car] - call release_object -.free_cdr: - pop rcx ; This was rsi, the original Cons - pop rsi ; This was rcx, the original Cons.cdr - - ; Get the type from the original Cons - mov al, BYTE [rcx+Cons.typecdr] - and al, content_mask ; Test content type - cmp al, content_pointer - jne .done - - call release_object -.done: - ret - -.double_free: ; Already released - ret - load_static error_cons_double_free - call raw_to_string - mov rsi, rax - jmp error_throw - -;; Releases either a Cons or Array -;; Address of object in RSI -;; -;; May modify: -;; RAX -;; RBX -;; RCX -;; -release_object: - mov al, BYTE [rsi] ; Get first byte - and al, block_mask ; Test block type - cmp al, block_array ; Test if it's an array - je release_array - jmp release_cons - -;; Increment reference count of Cons or Array -;; Address of object in RSI -;; -;; This code makes use of the fact that the reference -;; count is in the same place in Cons and Array types -;; -;; Modifies -;; RAX -incref_object: - mov ax, WORD [rsi + Cons.refcount] ; Same for Array - inc ax - ; Check for overflow? - mov [rsi + Cons.refcount], WORD ax - ret - -;; ------------------------------------------- -;; Copying lists/vectors -;; This does a shallow copy, copying only the -;; top level of objects. Any objects pointed to are not copied -;; -;; Input: RSI - address of list/vector -;; -;; Returns: New list/vector in RAX, last Cons in RBX -;; -;; Modifies: -;; RBX -;; RCX -;; RDX -;; R8 -;; R9 -;; R10 -;; -cons_seq_copy: - push rsi ; Restored at the end - - mov r8, rsi ; Input in R8 - xor r9, r9 ; Head of list in R9, start in R10 -.loop: - ; Check the type - mov cl, BYTE [r8] - mov ch, cl - and ch, block_mask - jnz .not_seq ; Not a Cons object - - call alloc_cons - mov rdx, rax ; New Cons in RDX - mov [rdx], BYTE cl ; Copy type in RCX - mov rbx, [r8 + Cons.car] ; Value in RBX - mov [rdx + Cons.car], rbx ; Copy value - - and cl, content_mask - cmp cl, content_pointer - jne .copied - - ; A pointer, so increment the reference count - mov rsi, rbx - call incref_object - -.copied: - ; Check if this is the first - test r9,r9 - jnz .append - - ; First Cons - mov r9, rdx - mov r10, rdx ; Start of the list, will be returned - jmp .next - -.append: - ; Appending to last Cons - mov [r9 + Cons.cdr], rdx - mov [r9 + Cons.typecdr], BYTE content_pointer - ; Replace - mov r9, rdx - -.next: - ; Check if there's another - mov al, BYTE [r8 + Cons.typecdr] - cmp al, content_pointer - jne .done ; No more - ; Got another - mov r8, [r8 + Cons.cdr] - jmp .loop - -.done: - pop rsi ; Restore input - mov rax, r10 ; Output list - mov rbx, r9 ; Last Cons - ret - -.not_seq: - xor rsi,rsi - jmp error_throw - -;; ------------------------------------------- -;; String type -;; -;; Create a new string, address in RAX -;; -;; Modifies registers -;; RBX -;; -string_new: - call alloc_array - mov [rax], BYTE maltype_string - mov DWORD [rax + Array.length], 0 - mov QWORD [rax + Array.next], 0 - ret - -;; Convert a raw string to a String type -;; -;; Input: Address of raw string in RSI, length in EDX -;; Output: Address of string in RAX -;; -;; Modifies registers: R8,R9,RCX -;; -raw_to_string: - ; Save registers to restore at the end - push r10 - push r11 - - push rsi - push rdx - call string_new ; String now in RAX - pop rdx - pop rsi - - mov r8, rax - add r8, Array.data ; Address of string data - mov r10, rax - add r10, Array.size ; End of the destination data - mov r11, rax ; First Array to return - - mov r9, rsi ; Address of raw data - mov ecx, edx ; Count - -.copy_loop: - test ecx, ecx ; Check if count is zero - jz .done - - ; Copy one byte - mov bl, BYTE [r9] - mov [r8], BYTE bl - - ; Move the destination - inc r8 - cmp r8, r10 - jne .dest_ok - - ; Hit the end. Set the length of the array - mov [rax + Array.length], DWORD (array_chunk_len * 8) - - push rax ; Last Array - push rsi - push rdx - call string_new ; String now in RAX - pop rdx - pop rsi - pop rbx ; Last Array - mov [rbx + Array.next], rax ; Point to new Array - - mov r8, rax - add r8, Array.data ; Address of string data - mov r10, rax - add r10, Array.size ; End of the destination data - -.dest_ok: - - inc r9 - dec ecx - jmp .copy_loop -.done: - ; Set the length of the destination array - sub r8, Array.data - sub r8, rax - mov [rax + Array.length], DWORD r8d - - ; Move first Array into RAX - mov rax, r11 - - ; Restore registers - pop r11 - pop r10 - - ret - -;; Convert a raw string to a symbol -;; -;; Input: Address of raw string in RSI, length in EDX -;; Output: Address of string in RAX -;; -;; Modifies registers: R8,R9,RCX -raw_to_symbol: - call raw_to_string - ; set the content type - mov [rax], BYTE (block_array + container_symbol + content_char) - ret - -;; Convert a NUL terminated C string to string -;; -;; Input: RSI - Address of string -;; -;; Returns: String in RAX -;; -;; Modifies: -;; RBX -;; RCX -;; RDX - -cstring_to_string: - push rsi - call string_new ; in RAX - pop rsi - - mov rbx, rax - add rbx, Array.data ; Start of output - mov rcx, rax - add rcx, Array.size ; End of output -.loop: - mov dl, BYTE [rsi] - test dl, dl ; Check if NUL (0) - jz .done - mov [rbx], BYTE dl - inc rbx - inc rsi - jmp .loop -.done: - sub rbx, rax - sub rbx, Array.data - ; rbx now contains the length - mov [rax + Array.length], DWORD ebx - ret - -;; Appends a character to a string -;; Input: Address of string in RSI, character in CL -;; -;; Modifies -;; RAX -string_append_char: - push rsi - ; Get the end of the string -.get_end: - mov rax, [rsi + Array.next] - test rax, rax - jz .got_dest_end - mov rsi, rax - jmp .get_end -.got_dest_end: - - ; Check if this chunk is full - mov eax, DWORD [rsi + Array.length] - cmp eax, (array_chunk_len*8) - jne .append - - ; full, need to allocate another - call alloc_array - mov [rsi + Array.next], rax - mov rsi, rax - xor eax, eax ; Set length to zero -.append: - inc eax - mov DWORD [rsi + Array.length], eax - dec eax - add rax, rsi - add rax, Array.data ; End of data - mov [rax], BYTE cl - - pop rsi ; Restore original value - ret - -;; Appends a string to the end of a string -;; -;; Input: String to be modified in RSI -;; String to be copied in RDX -;; -;; Output: Modified string in RSI -;; -;; Working registers: -;; rax Array chunk for output (copied to) -;; rbx Array chunk for input (copied from) -;; cl Character being copied -;; r8 Address of destination -;; r9 Destination end address -;; r10 Address of source -;; r11 Source end address -string_append_string: - ; copy source Array address to rbx - mov rbx, rdx - - ; source data address in r10 - mov r10, rbx - add r10, Array.data ; Start of the data - - ; source data end address in r11 - mov r11, r10 - mov r8d, DWORD [rbx + Array.length] - add r11, r8 - - test r8d, r8d - jz .return ; Appending zero-size array - - ; Find the end of the string in RSI - ; and put the address of the Array object into rax - mov rax, rsi -.find_string_end: - mov r8, QWORD [rax + Array.next] - test r8, r8 ; Next chunk is 0 - je .got_dest_end ; so reached end - - mov rax, r8 ; Go to next chunk - jmp .find_string_end -.got_dest_end: - - ; destination data address into r8 - mov r8, rax - add r8, Array.data - add r8d, DWORD [rax + Array.length] - - ; destination data end into r9 - mov r9, rax - add r9, Array.size - - ; Check if we are at the end of the destination - cmp r8, r9 - je .alloc_dest - -.copy_loop: - ; Copy one byte from source to destination - mov cl, BYTE [r10] - mov BYTE [r8], cl - - ; move source to next byte - inc r10 - ; Check if we've reached the end of this Array - cmp r10, r11 - jne .source_ok - - ; have reached the end of the source Array - mov rbx, QWORD [rbx + Array.next] ; Get the next Array address - test rbx, rbx ; Test if it's null - je .finished ; No more, so we're done - ; Move on to next Array object - - ; Get source address into r10 - mov r10, rbx - add r10, Array.data ; Start of the data - - ; Source end address - mov r11d, DWORD [rbx + Array.length] ; Length of the array - add r11, r10 - - ; Check if the next array is empty - cmp r10, r11 - je .finished - -.source_ok: - - ; Move destination to next byte - inc r8 - ; Check if we've reached end of the Array - cmp r8, r9 - jne .copy_loop ; Next byte - -.alloc_dest: - ; Reached the end of the destination - ; Need to allocate another Array - push rax - push rbx - call alloc_array ; New Array in rax - mov r8, rax ; copy to r8 - pop rbx - pop rax - - ; Previous Array in rax. - ; Add a reference to the new array and set length - mov QWORD [rax + Array.next], r8 - mov DWORD [rax + Array.length], (Array.size - Array.data) - mov rax, r8 ; new array - add r8, Array.data ; Start of data - - mov r9, rax - add r9, Array.size - jmp .copy_loop - -.finished: - ; Compare r8 (destination) with data start - ; to get length of string - sub r8, rax - sub r8, Array.data - inc r8 - ; r8 now contains length - mov DWORD [rax + Array.length], r8d -.return: - ret - -;; ------------------------------------------ -;; void print_string(char array) -;; Address of the char Array should be in RSI -print_string: - ; Push registers we're going to use - push rax - push rdi - push rdx - push rsi - - ; Check that we have a char array - mov al, [rsi] - cmp al, maltype_string - jne .error - -.print_chunk: - ; write(1, string, length) - push rsi - mov edx, [rsi + Array.length] ; number of bytes - add rsi, Array.data ; address of raw string to output - call print_rawstring - pop rsi - - ; Check if this is the end - mov rsi, QWORD [rsi + Array.next] - cmp rsi, 0 - jne .print_chunk ; next chunk - - ; Restore registers - pop rsi - pop rdx - pop rdi - pop rax - - ret -.error: - ; An error occurred - mov rdx, error_msg_print_string.len ; number of bytes - mov rsi, error_msg_print_string ; address of raw string to output - call print_rawstring - ; exit - jmp quit_error - -;; Copy a string -;; -;; Input: RSI - String to copy -;; -;; Output: New string in RAX -;; -;; Modifies: -;; RBX -;; RCX -;; RDX -;; RSI -;; -string_copy: - call string_new ; new string in RAX - - push rsi - push rax - - ; Get lengths - mov ebx, DWORD [rsi + Array.length] - mov [rax + Array.length], ebx - - ; Copy the whole block of data - ; Not sure if this is quicker than copying byte-by-byte - ; Could divide ebx by 8 (rounded up) to get the number - ; of blocks needed - - add rsi, Array.data ; Start of input data - add rax, Array.data ; Start of output data - mov ecx, array_chunk_len ; Number of 64-bit chunks - -.loop: - mov rbx, QWORD [rsi] - mov [rax], QWORD rbx - add rsi, 8 - add rax, 8 - dec ecx - jnz .loop - - pop rax - pop rsi - ; Now check if there's another block - mov rsi, [rsi + Array.next] - cmp rsi, 0 - jz .done ; Result in RAX - - ; Another array chunk - push rax ; Save output - - call string_copy ; Copy next chunk - mov rbx, rax ; The copy in RBX - - pop rax - ; append - mov [rax + Array.next], rbx -.done: - ret - -;; ------------------------------------------ -;; String itostring(Integer number) -;; -;; Converts an integer to a string (array of chars) -;; -;; Input in RAX -;; Return string address in RAX -itostring: - ; Save registers to restore afterwards - push rbx - push rcx - push rdx - push rsi - push rdi - - mov rcx, 0 ; counter of how many bytes we need to print in the end - - mov rbx, rax ; Original input - - ; Check if the number is negative - cmp rax, 0 - jge .divideLoop - - ; a negative number. To get the '-' sign - ; at the front the test is done again at the end - ; using the value stored in rbx - - neg rax ; Make it positive - -.divideLoop: - inc rcx ; count each byte to print - number of characters - xor rdx, rdx - mov rsi, 10 - idiv rsi ; divide rax by rsi - add rdx, 48 ; convert rdx to it's ascii representation - rdx holds the remainder after a divide instruction - ; Character is now in DL - dec rsp - mov BYTE [rsp], dl ; Put onto stack - - cmp rax, 0 ; can the integer be divided anymore? - jnz .divideLoop ; jump if not zero to the label divideLoop - - ; Check if the value was negative (in rbx) - cmp rbx, 0 - jge .create_string - - ; a negative number - dec rsp - mov BYTE [rsp], '-' - inc rcx - -.create_string: - ; Get an Array object to put the string into - call string_new ; Address in RAX - - ; put length into string - mov [rax + Array.length], ecx - - ; copy data from stack into string - ; Note: Currently this does not handle long strings - mov rdi, rax - add rdi, Array.data ; Address where raw string will go -.copyLoop: - mov BYTE dl, [rsp] ; Copy one byte at a time. Could be more efficient - mov [rdi], BYTE dl - inc rsp - inc rdi - dec rcx - cmp rcx, 0 - jnz .copyLoop - - ; Restore registers - pop rdi - pop rsi - pop rdx - pop rcx - pop rbx - - ret - - -;; ------------------------------------------------------------ -;; Object comparison -;; -;; These comparison functions take two objects -;; in RSI and RDI -;; and return a code (not an object) in RAX -;; -;; RAX = 0 Objects are equal -;; 1 RSI object is greater than RDI -;; 2 RSI object is less than RDI -;; -1 Different object types, or no ordering -;; -;; Note that the ordering of objects depends on the type -;; strings - Alphabetical -;; -;; -;; - -;; Given an object in RSI, follows pointers -;; to return the value object in RAX -;; -;; Modifies registers: -;; RCX -compare_get_value: - mov cl, BYTE [rsi] - mov ch, cl - and ch, block_mask - jnz .nop ; Got an Array - - ; Here got Cons - mov ch, cl - and ch, content_mask - cmp ch, content_pointer - jne .nop ; Not a pointer - - ; Got a pointer, so follow and return - mov rax, [rsi + Cons.car] - ret -.nop: - mov rax, rsi - ret - -;; Compare two objects in RSI and RDI. -;; Note that this does not compare lists -;; but will just compare the first element -;; -;; Modifies registers -;; RAX, RBX, RCX, RDX -;; -compare_objects: - ; Get the value that RSI points to - call compare_get_value - mov rbx, rax ; Save in RBX - ; Get the value that RDI points to - mov rsi, rdi - call compare_get_value - mov rdi, rax - mov rsi, rbx - - ; now get types - mov cl, BYTE [rsi] ; Type of RSI - mov bl, BYTE [rdi] ; Type of RDI - - mov ch, cl - mov bh, bl - - ; Don't care about container type - and cl, block_mask + content_mask - and bl, block_mask + content_mask - - cmp bl, cl ; compare block and content - jne .different_types - - ; Here the same block, content type - ; May be different container (value/list, string/symbol) - - ; Need to distinguish between map and vector/list - and ch, (block_mask + container_mask) - and bh, (block_mask + container_mask) - cmp ch, bh - je .same_container - ; if either is a map, then different types - cmp ch, container_map - je .different_types - cmp bh, container_map - je .different_types - -.same_container: - cmp bl, block_cons + content_nil - je .objects_equal ; nil - - cmp bl, block_array + content_char - je compare_char_array ; strings, symbols - - cmp bl, block_cons + content_int - je .integers - - ; Unknown - jmp .different_types - -.integers: - ; two Cons objects, both containing integers - mov rbx, [rsi + Cons.car] - cmp rbx, [rdi + Cons.car] - je .objects_equal - jl .rdi_greater - jmp .rsi_greater - -.objects_equal: - mov rax, 0 - ret - -.rsi_greater: ; rsi > rdi - mov rax, 1 - ret - -.rdi_greater: ; rdi > rsi - mov rax, 2 - ret - -.different_types: - mov rax, -1 - ret - - -;; Recursively check objects, including lists -;; -;; Inputs: Objects in RSI and RDI -;; -;; Sets ZF if equal, clears flag otherwise -compare_objects_rec: - ; Compare rsi and rdi objects - - ; Check type - mov al, BYTE [rsi] - mov bl, BYTE [rdi] - - mov ah, al - mov bh, bl - - ; Don't distinguish between [] and () - and ah, (block_mask + content_mask) - and bh, (block_mask + content_mask) - - cmp ah, bh - jne .false - - ; Need to distinguish between map and vector/list - mov ah, al - mov bh, bl - - and ah, (block_mask + container_mask) - and bh, (block_mask + container_mask) - cmp ah, bh - je .same_container - ; if either is a map, then different types - cmp ah, container_map - je .false - cmp bh, container_map - je .false - -.same_container: - - ; Check the container type - and bh, block_mask - jnz .array - - ; Check if a pointer to something - and al, content_mask - cmp al, content_pointer - je .pointer - - ; Get the values - - mov rbx, [rsi + Cons.car] - mov rcx, [rdi + Cons.car] - cmp rbx, rcx - jne .false - - ; Value is the same, so get next - jmp .next - -.array: - ; Comparing arrays - - ; Container type (symbol/string) does matter - cmp al, bl - jne .false - - call compare_char_array - cmp rax, 0 - ret ; Array has no next - -.pointer: - - mov rbx, [rsi + Cons.car] - mov rcx, [rdi + Cons.car] - cmp rbx, rcx - je .next ; Equal pointers - - push rsi - push rdi - ; Put the addresses to compare into RSI and RDI - mov rsi, rbx - mov rdi, rcx - call compare_objects_rec - pop rdi - pop rsi - jne .false - ; fall through to .next - -.next: - ; Check if both have a 'cdr' pointer - mov al, BYTE [rsi + Cons.typecdr] - mov bl, BYTE [rdi + Cons.typecdr] - - cmp al, content_pointer - je .rsi_has_next - - ; No next pointer in RSI - cmp bl, content_pointer - je .false ; RDI has a next pointer - - ; Neither have a next pointer, so done - jmp .true - -.rsi_has_next: - cmp bl, content_pointer - jne .false ; RDI has no next pointer - - ; Both have a next pointer, so keep going - mov rsi, [rsi + Cons.cdr] - mov rdi, [rdi + Cons.cdr] - jmp compare_objects_rec - -.false: - lahf ; flags in AH - and ah, 255-64 ; clear zero flag - sahf - ret -.true: - lahf ; flags in AH - or ah, 64 ; set zero flag - sahf - ret - -;; Char array objects (strings, symbols, keywords) in RSI and RDI -;; Return code in RAX -;; -;; Modifies registers: -;; RBX -;; RCX -;; RDX -compare_char_array: - ; Check length - mov eax, DWORD [rsi + Array.length] - mov ebx, DWORD [rdi + Array.length] - cmp eax, ebx - jne .different - - ; same length - - cmp eax, 0 - je .equal ; Both zero length - - mov rbx, rsi - add rbx, Array.data - mov rcx, rdi - add rcx, Array.data -.compare_loop: - ; get next character - mov dl, BYTE [rbx] - cmp dl, BYTE [rcx] - jl .rdi_greater - jg .rsi_greater - - ; this character is equal - inc rbx - inc rcx - dec eax - jnz .compare_loop ; Next character - -.equal: - mov rax, 0 - ret - -.rsi_greater: ; rsi > rdi - mov rax, 1 - ret - -.rdi_greater: ; rdi > rsi - mov rax, 2 - ret - -.different: - mov rax, -1 - ret - -;; ------------------------------------------------------------ -;; Map type -;; -;; This uses a list (Cons type) to represent key-value pairs in -;; a single chain. The only map which consists of an odd number of Cons -;; objects is the empty map, created by map_new -map_new: - call alloc_cons - mov [rax], BYTE (block_cons + container_map + content_empty) - mov [rax + Cons.typecdr], BYTE content_nil - ret - -;; Copy map -;; -;; Input: RSI - map -;; -;; Returns: new map in RAX -;; -;; Modifies: -;; RAX, RBX, RCX, R13, R14, R15 -;; -map_copy: - mov r14, rsi - - call alloc_cons - mov r15, rax ; start of new map - xor r13, r13 -.loop: - mov bl, BYTE [rsi] - mov rcx, [rsi + Cons.car] - mov [rax], BYTE bl ; copy type - mov [rax + Cons.car], rcx ; copy value - - and bl, content_mask - cmp bl, content_pointer - jne .set_cdr - - ; A pointer in CAR. Increase reference count - mov bx, WORD [rcx + Cons.refcount] - inc bx - mov [rcx + Cons.refcount], WORD bx - -.set_cdr: - test r13,r13 - jz .next - - ; R13 contains last Cons - mov [r13 + Cons.typecdr], BYTE content_pointer - mov [r13 + Cons.cdr], rax -.next: - mov r13, rax - - ; Check if there's another Cons - mov bl, BYTE [rsi + Cons.typecdr] - cmp bl, content_pointer - jne .done ; no more - - mov rsi, [rsi + Cons.cdr] ; next - call alloc_cons - jmp .loop -.done: - mov rax, r15 - mov rsi, r14 - ret - - -;; Add to map. Input is a list with an even number of values -;; as (key, value, key, value, ...) -;; -;; Inputs: -;; RSI - Map to append to. This is not modified -;; RDI - List to add to the map -;; Outputs: -;; RAX - New map -;; -;; Modifies: -;; RCX -map_add: - ; Check type of input - mov cl, BYTE [rsi] - mov cl, ch - and ch, block_mask + container_mask - cmp ch, block_cons + container_map - jne .error - - mov cl, BYTE [rdi] - and cl, block_mask + container_mask - cmp cl, block_cons + container_list - jne .error - - xor r8, r8 ; Zero r8 - -.copy_input: - ; Copy input list, changing container type - call alloc_cons - - mov cl, BYTE [rdi] - and cl, content_mask ; Keep the content - add cl, block_cons + container_map - mov [rax], BYTE cl ; Set type - mov rcx, [rdi+Cons.car] ; Copy data - mov [rax+Cons.car], rcx - - cmp cl, (block_cons + container_map + content_pointer) - jne .copy_not_pointer - - ; Copying a pointer to data - ; so need to increase the reference count - mov bx, WORD [rcx + Cons.refcount] ; Same offset for Array - inc bx - mov [rcx + Cons.refcount], WORD bx - -.copy_not_pointer: - - ; Check if this is the first object - cmp r8, 0 - jnz .copy_not_first - mov r8, rax ; Save start of map to R8 - mov r9, rax ; Last cons in R9 - jmp .copy_next - -.copy_not_first: - ; Append to R9 - mov [r9+Cons.cdr], rax - mov [r9+Cons.typecdr], BYTE content_pointer - - ; Put new Cons in R9 as the latest in the list - mov r9, rax - -.copy_next: - ; Check if we've reached the end - mov cl, BYTE [rdi + Cons.typecdr] - cmp cl, content_nil - je .copy_finished - - ; Not yet. Get next Cons and keep going - mov rdi, [rdi + Cons.cdr] - jmp .copy_input - -.copy_finished: - ; Start of map in r8, end in r9 - - ; Check if the original map is empty - mov cl, [rsi] - and cl, content_mask - cmp cl, content_empty - je .return - - ; Put old map on the end of the new map - ; For now this avoids the need to overwrite - ; values in the map, since a search will find - ; the new values first. - - mov [r9 + Cons.cdr], rsi - mov [r9 + Cons.typecdr], BYTE content_pointer - - ; Increment reference count - mov bx, WORD [rsi + Cons.refcount] - inc bx - mov [rsi + Cons.refcount], WORD bx - -.return: - mov rax, r8 - ret - -.error: - ; Return nil - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - -;; Find a key in a map -;; -;; Inputs: RSI - map [ Modified ] -;; RDI - key [ Modified ] -;; -;; Outputs: RAX - Cons object containing value in CAR -;; -;; Modifies registers: -;; RBX [compare_objects, alloc_cons] -;; RCX [compare_objects] -;; -;; -;; If value is found then the Zero Flag is set -;; -;; Examples: -;; {a 1 b 2} find a -> {1 b 2} -;; {1 2 3 4} find a -> {4} -map_find: - mov al, BYTE [rsi] - cmp al, maltype_empty_map - je .not_found - -.map_loop: - ; compare RSI and RDI, ignoring differences in container - push rsi - push rdi - call compare_objects - pop rdi - pop rsi - - ; rax is now zero if objects are equal - cmp rax, 0 - je .found - - ; Move along two cons to the next key - mov al, [rsi + Cons.typecdr] - cmp al, content_pointer - jne .error ; Expecting value after key - - mov rsi, [rsi + Cons.cdr] ; Get value - mov al, [rsi + Cons.typecdr] - cmp al, content_pointer - jne .not_found - - mov rsi, [rsi + Cons.cdr] ; Get next key - - jmp .map_loop ; Test next key - -.found: - - lahf ; flags in AH - or ah, 64 ; set zero flag - sahf - - ; key in rsi. Get next value - mov al, [rsi + Cons.typecdr] - cmp al, content_pointer - jne .error ; Expecting value after key - - mov rsi, [rsi + Cons.cdr] - - ; ; increment reference count - ; mov ax, WORD [rsi + Cons.refcount] - ; inc ax - ; mov [rsi + Cons.refcount], WORD ax - ; Put address in rax - mov rax, rsi - ret - -.not_found: - lahf ; flags in AH - and ah, 255-64 ; clear zero flag - sahf - - ; last cons in rsi - ; increment reference count - ; mov ax, WORD [rsi + Cons.refcount] - ; inc ax - ; mov [rsi + Cons.refcount], WORD ax - ; Put address in rax - mov rax, rsi - - ret - -.error: - - lahf ; flags in AH - and ah, 255-64 ; clear zero flag - sahf - - ; return nil - call alloc_cons - mov [rax], BYTE maltype_nil - mov [rax + Cons.typecdr], BYTE content_nil - ret - -;; Map set -;; -;; Sets a key-value pair in a map -;; -;; Inputs: RSI - map [not modified] -;; RDI - key [not modified] -;; RCX - value [not modified] -;; -;; If references are added to key or value, -;; then reference counts are incremented. -;; -;; Modifies registers: -;; R8 -;; R9 -;; R10 -map_set: - ; Save inputs in less volatile registers - mov r8, rsi ; map - mov r9, rdi ; key - mov r10, rcx ; value - - ; Find the key, to see if it already exists in the map - call map_find ; Cons object in RAX - je .found_key - - ; Key not in map. RAX should be address of the last - ; value in the map, or empty - mov bl, BYTE [rax] - cmp bl, maltype_empty_map - je .set_key - - ; Append key - push rax - call alloc_cons ; New Cons in rax - pop rbx ; Last Cons in map - - ; append rax to rbx - mov [rbx + Cons.typecdr], BYTE content_pointer - mov [rbx + Cons.cdr], rax - jmp .set_key ; Put key into rax - -.found_key: - ; Key already in map, so replace value - ; address in RAX - - ; check type of value already there - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - jne .set_value ; Not a pointer, just overwrite - - ; A pointer, so need to release - mov rsi, [rax + Cons.car] ; Address of object - push rax - call release_object - pop rax - - jmp .set_value ; put value into Cons - -.set_key: - ; Put key (R9) in RAX - - ; Check the type of object - mov bl, BYTE [r9] - mov bh, bl - and bh, block_mask - jnz .set_key_pointer ; Array, so point to it - - ; Here a Cons object - mov bh, bl - and bh, container_mask - cmp bh, container_value - jne .set_key_pointer ; Not a simple value, so point to it - - ; A value, so copy - mov rcx, [r9 + Cons.car] - mov [rax + Cons.car], rcx - - ; Set the type - and bl, content_mask - or bl, (block_cons + container_map) - mov [rax], BYTE bl - - jmp .set_key_done - -.set_key_pointer: - ; The key is a pointer - - mov [rax + Cons.car], r9 - mov [rax], BYTE (block_cons + container_map + content_pointer) - ; Increment reference count - mov bx, WORD [r9 + Cons.refcount] - inc bx - mov [r9 + Cons.refcount], bx - ; fall through to .set_key_done - -.set_key_done: - ; Key in RAX. allocate and append a Cons for the value - push rax - call alloc_cons ; value Cons in rax - pop rbx ; key Cons - ; append rax to rbx - mov [rbx + Cons.typecdr], BYTE content_pointer - mov [rbx + Cons.cdr], rax - - ; fall through to .set_value - - ; -------------------------------- -.set_value: - ; Set the value into the Cons at [rax] - - ; Check the type of object - mov bl, BYTE [r10] - mov bh, bl - and bh, block_mask - jnz .set_value_pointer ; Array, so point to it - - ; Here a Cons object - mov bh, bl - and bh, container_mask - cmp bh, container_value - jne .set_value_pointer ; Not a simple value, so point to it - ; A value, so copy - mov rcx, [r10 + Cons.car] - mov [rax + Cons.car], rcx - - ; Set the type - and bl, content_mask - or bl, (block_cons + container_map) - mov [rax], BYTE bl - - jmp .finished - -.set_value_pointer: - mov [rax + Cons.car], r10 ; Put address into CAR - mov [rax], BYTE (block_cons + container_map + content_pointer) ; Mark as a pointer - ; Increment reference count - mov bx, WORD [r10 + Cons.refcount] - inc bx - mov [r10 + Cons.refcount], bx - ; fall through to .finished - -.finished: - ; Restore inputs - mov rsi, r8 - mov rdi, r9 - mov rcx, r10 - ret - -;; Get a value from a map, incrementing the reference count -;; of the object returned -;; -;; Inputs: RSI - map -;; RDI - key -;; -;; Returns: If found, Zero Flag is set and address in RAX -;; If not found, Zero Flag cleared -;; -;; Modifies registers: -;; RAX -;; RBX -;; RCX -;; R8 -;; R9 -map_get: - ; Save inputs - mov r8, rsi ; map - mov r9, rdi ; key - - call map_find ; Cons object in RAX - je .found_key - - ; Not found - - mov rsi, r8 - mov rdi, r9 - - lahf ; flags in AH - and ah, 255-64 ; clear zero flag - sahf - - ret - ; --------------- -.found_key: - - ; Check if the object in RAX is a value or pointer - mov bl, BYTE [rax] - and bl, content_mask - cmp bl, content_pointer - je .got_pointer - - ; A value, so copy - - push rax - push rbx - call alloc_cons ; cons in rax - pop rbx ; content type in bl - pop rcx ; Object to copy - - add bl, block_cons + container_value - mov [rax], BYTE bl ; set type - mov [rax + Cons.typecdr], BYTE content_nil - - ; Copy value - mov rbx, [rcx + Cons.car] - mov [rax + Cons.car], rbx - - jmp .finished_found - -.got_pointer: - ; A pointer, so get the address - mov rax, [rax + Cons.car] - - ; increment reference count - mov bx, WORD [rax + Cons.refcount] - inc bx - mov [rax + Cons.refcount], bx - - ; Fall through to .finished_found -.finished_found: - mov rsi, r8 - mov rdi, r9 - - mov rbx, rax - lahf ; flags in AH - or ah, 64 ; set zero flag - sahf - mov rax, rbx - ret - -;; Get a list of keys -;; -;; Input: Map in RSI -;; -;; Returns: List in RAX -;; -;; Modifies registers: -;; RAX -;; RBX -;; RCX -;; R8 -;; R9 -map_keys: - ; check type - mov al, BYTE [rsi] - cmp al, maltype_empty_map - je .empty_map - - and al, container_mask - cmp al, container_map - jne .empty_map ; error - - xor r8, r8 ; Return list - - ; Take the current value -.loop: - ; Create a new Cons for this key - call alloc_cons - mov cl, BYTE [rsi] - and cl, content_mask - add cl, block_cons + container_list - mov [rax], BYTE cl ; Set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; Set value - - and cl, content_mask - cmp cl, content_pointer - jne .append - - ; A pointer, so increment reference count - mov cx, WORD [rbx + Cons.refcount] - inc cx - mov [rbx + Cons.refcount], WORD cx - -.append: - cmp r8, 0 - je .first - - ; appending - mov [r9 + Cons.typecdr], BYTE content_pointer - mov [r9 + Cons.cdr], rax - mov r9, rax - jmp .next -.first: - ; First key, so put into r8 - mov r8, rax - mov r9, rax -.next: - ; First get the value - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .done ; error. Should be a value - mov rsi, [rsi + Cons.cdr] - - ; Get the next key - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .done - mov rsi, [rsi + Cons.cdr] - jmp .loop -.done: - ; Finished, return the list - mov rax, r8 - ret - -.empty_map: - ; return empty list - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - -;; Get a list of values -;; -;; Input: Map in RSI -;; -;; Returns: List in RAX -;; -;; Modifies registers: -;; RAX -;; RBX -;; RCX -;; R8 -;; R9 -map_vals: - ; check type - mov al, BYTE [rsi] - cmp al, maltype_empty_map - je .empty_map - - and al, container_mask - cmp al, container_map - jne .empty_map ; error - - xor r8, r8 ; Return list - -.loop: - ; Here should have a key in RSI - - ; First get the value - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .done ; error. Should be a value - - mov rsi, [rsi + Cons.cdr] ; Now have value in RSI - - ; Create a new Cons for this value - call alloc_cons - mov cl, BYTE [rsi] - and cl, content_mask - add cl, block_cons + container_list - mov [rax], BYTE cl ; Set type - mov rbx, [rsi + Cons.car] - mov [rax + Cons.car], rbx ; Set value - - and cl, content_mask - cmp cl, content_pointer - jne .append - - ; A pointer, so increment reference count - mov cx, WORD [rbx + Cons.refcount] - inc cx - mov [rbx + Cons.refcount], WORD cx - -.append: - cmp r8, 0 - je .first - - ; appending - mov [r9 + Cons.typecdr], BYTE content_pointer - mov [r9 + Cons.cdr], rax - mov r9, rax - jmp .next -.first: - ; First key, so put into r8 - mov r8, rax - mov r9, rax -.next: - ; Get the next key - mov al, BYTE [rsi + Cons.typecdr] - cmp al, content_pointer - jne .done - mov rsi, [rsi + Cons.cdr] - jmp .loop -.done: - ; Finished, return the list - mov rax, r8 - ret - -.empty_map: - ; return empty list - call alloc_cons - mov [rax], BYTE maltype_empty_list - ret - - -;; ------------------------------------------------------------ -;; Function type -;; -;; Functions are consist of a list -;; - First car is the function address to call -;; - Second is the Meta data (nil by default) -;; - Third is the environment -;; - Fourth is the binds list -;; - Fifth is the body of the function -;; -;; ( addr meta env binds body ) -;; -;; - -;; Address of native function in RSI -;; returns Function object in RAX -native_function: - call alloc_cons ; for meta - mov [rax], BYTE maltype_nil - push rax - - call alloc_cons ; For function address - mov [rax], BYTE (block_cons + container_function + content_function) - mov [rax + Cons.car], rsi - - mov [rax + Cons.typecdr], BYTE content_pointer - pop rbx ; meta - mov [rax + Cons.cdr], rbx - ret +;; Data structures +;; =============== +;; +;; Memory management is done by having two fixed-size datatypes, +;; Cons and Array. +;; +;; Both Cons and Array have the following in common: +;; a type field at the start, a reference count, followed by data +;; [ type (8) | (8) | refs (16) | data ] +;; +;; +;; Type bit fields +;; --------------- +;; +;; The 8-bit type fields describe the Block, Container and Content type. +;; +;; The Block type is used for memory management, to determine the kind of memory block +;; The Container type indicates the data structure that the Cons or Array block is being used to represent +;; The Content type indicates the raw type of the data in the content +;; +;; Block type [1 bit]: +;; 0 0 - Cons memory block +;; 1 1 - Array memory block +;; +;; Container type [3 bits]: +;; 0 0 - Value (single boxed value for Cons blocks, multiple values for Array blocks). +;; 2 1 - List (value followed by pointer). Only for Cons blocks +;; 4 2 - Symbol (special char array). Only for Array blocks +;; 6 3 - Keyword. Only for Array blocks +;; 8 4 - Map +;; 10 5 - Function +;; 12 6 - Atom +;; 14 7 - Vector +;; +;; Content type [4 bits]: +;; 0 0 - Nil +;; 16 1 - True +;; 32 2 - Char +;; 48 3 - Int +;; 64 4 - Float +;; 80 5 - Pointer (memory address) +;; 96 6 - Function (instruction address) +;; 112 7 - Empty (distinct from Nil) +;; 208 8 - False +;; 224 9 - Macro +;; +;; +;; These represent MAL data types as follows: +;; +;; MAL type Block Container Content +;; --------- | -------- | ---------- | --------- +;; integer Cons Value Int +;; symbol Array Symbol Char +;; list Cons List Any +;; vector Cons Vector Any +;; nil Cons Value Nil +;; true Cons Value True +;; false Cons Value False +;; string Array Value Char +;; keyword Array Keyword Char +;; hash-map Cons Map Alternate key, values +;; atom Cons Atom Pointer +;; + +%include "macros.mac" + +;; Cons type. +;; Used to store either a single value with type information +;; or a pair of (value, Pointer or Nil) to represent a list +STRUC Cons +.typecar: RESB 1 ; Type information for car (8 bit) +.typecdr: RESB 1 ; Type information for cdr (8 bits) +.refcount: RESW 1 ; Number of references to this Cons (16 bit) +.car: RESQ 1 ; First value (64 bit) +.cdr: RESQ 1 ; Second value (64 bit) +.size: ; Total size of struc +ENDSTRUC + + +%define array_chunk_len 32 ; Number of 64-bit values which can be stored in a single chunk + +STRUC Array +.type: RESB 1 ; Type information (8 bits) +.control: RESB 1 ; Control data (8 bits) +.refcount: RESW 1 ; Number of references to this Array (16 bit) +.length: RESD 1 ; Number of elements in this part of the array (32 bit) +.next RESQ 1 ; Pointer to the next chunk (64 bit) +.data: RESQ array_chunk_len ; Data storage +.size: ; Total size of struc +ENDSTRUC + +;; Type information + +%define block_mask 1 ; LSB for block type +%define container_mask 2 + 4 + 8 ; Next three bits for container type +%define content_mask 16 + 32 + 64 + 128 ; Four bits for content type + +;; Block types +%define block_cons 0 ; Note: This must be zero +%define block_array 1 + +;; Container types +%define container_value 0 ; Note: This must be zero +%define container_list 2 +%define container_symbol 4 +%define container_keyword 6 +%define container_map 8 +%define container_function 10 +%define container_atom 12 +%define container_vector 14 + +;; Content type +%define content_nil 0 +%define content_true 16 +%define content_char 32 +%define content_int 48 +%define content_float 64 +%define content_pointer 80 ; Memory pointer (to Cons or Array) +%define content_function 96 ; Function pointer +%define content_empty 112 +%define content_false 208 +%define content_macro 224 + +;; Common combinations for MAL types +%define maltype_integer (block_cons + container_value + content_int) +%define maltype_string (block_array + container_value + content_char) +%define maltype_symbol (block_array + container_symbol + content_char) +%define maltype_nil (block_cons + container_value + content_nil) +%define maltype_empty_list (block_cons + container_list + content_empty) +%define maltype_empty_map (block_cons + container_map + content_empty) +%define maltype_empty_vector (block_cons + container_vector + content_empty) +%define maltype_function (block_cons + container_function + content_function) +%define maltype_macro (block_cons + container_function + content_macro) +%define maltype_true (block_cons + container_value + content_true) +%define maltype_false (block_cons + container_value + content_false) +%define maltype_atom (block_cons + container_atom + content_pointer) + +;; ------------------------------------------ + +section .data + +;; Fixed strings for printing + + static error_msg_print_string, db "Error in print string",10 + static error_array_memory_limit, db "Error: Run out of memory for Array objects. Increase heap_array_limit.",10 + static error_cons_memory_limit, db "Error: Run out of memory for Cons objects. Increase heap_cons_limit.",10 + + static error_cons_double_free, db "Error: double free error releasing Cons" + static error_array_double_free, db "Error: double free error releasing Array" + +;; ------------------------------------------ +;; Memory management +;; +;; For each object (Cons or Array), there is a block of memory (in BSS). +;; When an object is requested it is first taken from the free list +;; If the free list is empty (address 0) then the next object in the block +;; is used, and the heap_x_number counter is incremented. When an object +;; is free'd it is pushed onto the heap_x_free list. + + +%define heap_cons_limit 5000 ; Number of cons objects which can be created + +heap_cons_next: dq heap_cons_store ; Address of next cons in memory +heap_cons_free: dq 0 ; Address of start of free list + +%define heap_array_limit 2000 ; Number of array objects which can be created + +heap_array_next: dq heap_array_store +heap_array_free: dq 0 + +section .bss + +;; Reserve space to store Cons and Array objects +heap_cons_store: resb heap_cons_limit * Cons.size +.end: ; Address of end of the store + +heap_array_store: resb heap_array_limit * Array.size +.end: + +section .text + +;; ------------------------------------------ +;; Array alloc_array() +;; +;; Returns the address of an Array object in RAX +;; +;; Working registers: rbx +alloc_array: + + ; Get the address of a free array + mov rax, [heap_array_free] ; Address of the array + + ; Check if it's null + cmp rax, 0 + je .create_array + + mov rbx, [rax + Array.next] ; Get the address of the next array in the linked list + mov [heap_array_free], rbx ; Put this address at the front of the list + jmp .initialise_array + +.create_array: + + ; Get the address of the next Array + mov rax, [heap_array_next] + ; Check if we've reached the end + cmp rax, heap_array_store.end + je .out_of_memory + + mov rbx, rax + add rbx, Array.size ; Address of the next array + mov [heap_array_next], rbx ; for next time + +.initialise_array: + ; Address of Array now in rax + mov BYTE [rax + Array.type], block_array + mov WORD [rax + Array.refcount], 1 ; Only one reference + mov DWORD [rax + Array.length], 0 + mov QWORD [rax + Array.next], 0 ; null next address + + ret + +.out_of_memory: + mov rsi, error_array_memory_limit + mov rdx, error_array_memory_limit.len + call print_rawstring + jmp quit_error + + +;; ------------------------------------------- +;; Decrements the reference count of the array in RSI +;; If the count reaches zero then push the array +;; onto the free list +release_array: + mov ax, WORD [rsi + Array.refcount] + + ; Check if reference count is already zero + test ax,ax + jz .double_free + + dec ax + mov WORD [rsi + Array.refcount], ax + jz .free ; If the count reaches zero then put on free list + ret + +.free: + ; Get the next field + mov rbx, [rsi + Array.next] + + mov rax, [heap_array_free] ; Get the current head + mov [rsi + Array.next], rax ; Put current head into the "next" field + mov [heap_array_free], rsi ; Push Array onto free list + + cmp rbx, 0 + jne .release_next ; If there is another array, then need to release it + + ret + +.release_next: + ; release the next array + mov rsi, rbx + call release_array + ret + +.double_free: + ret + load_static error_cons_double_free + call raw_to_string + mov rsi, rax + jmp error_throw + +;; ------------------------------------------ +;; Cons alloc_cons() +;; +;; Returns the address of a Cons object in RAX +;; +;; Modifies: +;; RBX +alloc_cons: + + ; Get the address of a free cons + mov rax, [heap_cons_free] ; Address of the cons + + ; Check if it's null + cmp rax, 0 + je .create_cons + + mov rbx, [rax + Cons.cdr] ; Get the address of the next cons in the linked list + mov [heap_cons_free], rbx ; Put this address at the front of the list + jmp .initialise_cons + +.create_cons: + + ; Get the address of the next Cons + mov rax, [heap_cons_next] + ; Check if we've reached the end + cmp rax, heap_cons_store.end + je .out_of_memory + + mov rbx, rax + add rbx, Cons.size ; Address of the next cons + mov [heap_cons_next], rbx ; for next time + +.initialise_cons: + ; Address of Cons now in rax + mov BYTE [rax + Cons.typecar], 0 + mov BYTE [rax + Cons.typecdr], 0 + mov WORD [rax + Cons.refcount], 1 ; Only one reference + mov QWORD [rax + Cons.car], 0 + mov QWORD [rax + Cons.cdr], 0 + ret + +.out_of_memory: + mov rsi, error_cons_memory_limit + mov rdx, error_cons_memory_limit.len + call print_rawstring + jmp quit_error + + +;; ------------------------------------------- +;; Decrements the reference count of the cons in RSI +;; If the count reaches zero then push the cons +;; onto the free list +;; +;; Modifies registers: +;; RAX +;; RBX +;; RCX +;; +release_cons: + mov ax, WORD [rsi + Cons.refcount] + + ; Check if already released + test ax,ax + jz .double_free + + dec ax + mov WORD [rsi + Cons.refcount], ax + jz .free ; If the count reaches zero then put on free list + ret + +.free: + ; Get and push cdr onto stack + mov rcx, [rsi + Cons.cdr] + push rcx ; Content of CDR + push rsi ; Original Cons object being released + + mov rax, [heap_cons_free] ; Get the current head + mov [rsi + Cons.cdr], rax ; Put current head into the "cdr" field + mov [heap_cons_free], rsi ; Push Cons onto free list + + ; Check if the CAR needs to be released + + mov al, BYTE [rsi+Cons.typecar] + and al, content_mask ; Test content type + cmp al, content_pointer + jne .free_cdr ; Jump if CAR not pointer + + ; CAR is a pointer to either a Cons or Array + ; Get the address stored in CAR + mov rsi, [rsi + Cons.car] + call release_object +.free_cdr: + pop rcx ; This was rsi, the original Cons + pop rsi ; This was rcx, the original Cons.cdr + + ; Get the type from the original Cons + mov al, BYTE [rcx+Cons.typecdr] + and al, content_mask ; Test content type + cmp al, content_pointer + jne .done + + call release_object +.done: + ret + +.double_free: ; Already released + ret + load_static error_cons_double_free + call raw_to_string + mov rsi, rax + jmp error_throw + +;; Releases either a Cons or Array +;; Address of object in RSI +;; +;; May modify: +;; RAX +;; RBX +;; RCX +;; +release_object: + mov al, BYTE [rsi] ; Get first byte + and al, block_mask ; Test block type + cmp al, block_array ; Test if it's an array + je release_array + jmp release_cons + +;; Increment reference count of Cons or Array +;; Address of object in RSI +;; +;; This code makes use of the fact that the reference +;; count is in the same place in Cons and Array types +;; +;; Modifies +;; RAX +incref_object: + mov ax, WORD [rsi + Cons.refcount] ; Same for Array + inc ax + ; Check for overflow? + mov [rsi + Cons.refcount], WORD ax + ret + +;; ------------------------------------------- +;; Copying lists/vectors +;; This does a shallow copy, copying only the +;; top level of objects. Any objects pointed to are not copied +;; +;; Input: RSI - address of list/vector +;; +;; Returns: New list/vector in RAX, last Cons in RBX +;; +;; Modifies: +;; RBX +;; RCX +;; RDX +;; R8 +;; R9 +;; R10 +;; +cons_seq_copy: + push rsi ; Restored at the end + + mov r8, rsi ; Input in R8 + xor r9, r9 ; Head of list in R9, start in R10 +.loop: + ; Check the type + mov cl, BYTE [r8] + mov ch, cl + and ch, block_mask + jnz .not_seq ; Not a Cons object + + call alloc_cons + mov rdx, rax ; New Cons in RDX + mov [rdx], BYTE cl ; Copy type in RCX + mov rbx, [r8 + Cons.car] ; Value in RBX + mov [rdx + Cons.car], rbx ; Copy value + + and cl, content_mask + cmp cl, content_pointer + jne .copied + + ; A pointer, so increment the reference count + mov rsi, rbx + call incref_object + +.copied: + ; Check if this is the first + test r9,r9 + jnz .append + + ; First Cons + mov r9, rdx + mov r10, rdx ; Start of the list, will be returned + jmp .next + +.append: + ; Appending to last Cons + mov [r9 + Cons.cdr], rdx + mov [r9 + Cons.typecdr], BYTE content_pointer + ; Replace + mov r9, rdx + +.next: + ; Check if there's another + mov al, BYTE [r8 + Cons.typecdr] + cmp al, content_pointer + jne .done ; No more + ; Got another + mov r8, [r8 + Cons.cdr] + jmp .loop + +.done: + pop rsi ; Restore input + mov rax, r10 ; Output list + mov rbx, r9 ; Last Cons + ret + +.not_seq: + xor rsi,rsi + jmp error_throw + +;; ------------------------------------------- +;; String type +;; +;; Create a new string, address in RAX +;; +;; Modifies registers +;; RBX +;; +string_new: + call alloc_array + mov [rax], BYTE maltype_string + mov DWORD [rax + Array.length], 0 + mov QWORD [rax + Array.next], 0 + ret + +;; Convert a raw string to a String type +;; +;; Input: Address of raw string in RSI, length in EDX +;; Output: Address of string in RAX +;; +;; Modifies registers: R8,R9,RCX +;; +raw_to_string: + ; Save registers to restore at the end + push r10 + push r11 + + push rsi + push rdx + call string_new ; String now in RAX + pop rdx + pop rsi + + mov r8, rax + add r8, Array.data ; Address of string data + mov r10, rax + add r10, Array.size ; End of the destination data + mov r11, rax ; First Array to return + + mov r9, rsi ; Address of raw data + mov ecx, edx ; Count + +.copy_loop: + test ecx, ecx ; Check if count is zero + jz .done + + ; Copy one byte + mov bl, BYTE [r9] + mov [r8], BYTE bl + + ; Move the destination + inc r8 + cmp r8, r10 + jne .dest_ok + + ; Hit the end. Set the length of the array + mov [rax + Array.length], DWORD (array_chunk_len * 8) + + push rax ; Last Array + push rsi + push rdx + call string_new ; String now in RAX + pop rdx + pop rsi + pop rbx ; Last Array + mov [rbx + Array.next], rax ; Point to new Array + + mov r8, rax + add r8, Array.data ; Address of string data + mov r10, rax + add r10, Array.size ; End of the destination data + +.dest_ok: + + inc r9 + dec ecx + jmp .copy_loop +.done: + ; Set the length of the destination array + sub r8, Array.data + sub r8, rax + mov [rax + Array.length], DWORD r8d + + ; Move first Array into RAX + mov rax, r11 + + ; Restore registers + pop r11 + pop r10 + + ret + +;; Convert a raw string to a symbol +;; +;; Input: Address of raw string in RSI, length in EDX +;; Output: Address of string in RAX +;; +;; Modifies registers: R8,R9,RCX +raw_to_symbol: + call raw_to_string + ; set the content type + mov [rax], BYTE (block_array + container_symbol + content_char) + ret + +;; Convert a NUL terminated C string to string +;; +;; Input: RSI - Address of string +;; +;; Returns: String in RAX +;; +;; Modifies: +;; RBX +;; RCX +;; RDX + +cstring_to_string: + push rsi + call string_new ; in RAX + pop rsi + + mov rbx, rax + add rbx, Array.data ; Start of output + mov rcx, rax + add rcx, Array.size ; End of output +.loop: + mov dl, BYTE [rsi] + test dl, dl ; Check if NUL (0) + jz .done + mov [rbx], BYTE dl + inc rbx + inc rsi + jmp .loop +.done: + sub rbx, rax + sub rbx, Array.data + ; rbx now contains the length + mov [rax + Array.length], DWORD ebx + ret + +;; Appends a character to a string +;; Input: Address of string in RSI, character in CL +;; +;; Modifies +;; RAX +string_append_char: + push rsi + ; Get the end of the string +.get_end: + mov rax, [rsi + Array.next] + test rax, rax + jz .got_dest_end + mov rsi, rax + jmp .get_end +.got_dest_end: + + ; Check if this chunk is full + mov eax, DWORD [rsi + Array.length] + cmp eax, (array_chunk_len*8) + jne .append + + ; full, need to allocate another + call alloc_array + mov [rsi + Array.next], rax + mov rsi, rax + xor eax, eax ; Set length to zero +.append: + inc eax + mov DWORD [rsi + Array.length], eax + dec eax + add rax, rsi + add rax, Array.data ; End of data + mov [rax], BYTE cl + + pop rsi ; Restore original value + ret + +;; Appends a string to the end of a string +;; +;; Input: String to be modified in RSI +;; String to be copied in RDX +;; +;; Output: Modified string in RSI +;; +;; Working registers: +;; rax Array chunk for output (copied to) +;; rbx Array chunk for input (copied from) +;; cl Character being copied +;; r8 Address of destination +;; r9 Destination end address +;; r10 Address of source +;; r11 Source end address +string_append_string: + ; copy source Array address to rbx + mov rbx, rdx + + ; source data address in r10 + mov r10, rbx + add r10, Array.data ; Start of the data + + ; source data end address in r11 + mov r11, r10 + mov r8d, DWORD [rbx + Array.length] + add r11, r8 + + test r8d, r8d + jz .return ; Appending zero-size array + + ; Find the end of the string in RSI + ; and put the address of the Array object into rax + mov rax, rsi +.find_string_end: + mov r8, QWORD [rax + Array.next] + test r8, r8 ; Next chunk is 0 + je .got_dest_end ; so reached end + + mov rax, r8 ; Go to next chunk + jmp .find_string_end +.got_dest_end: + + ; destination data address into r8 + mov r8, rax + add r8, Array.data + add r8d, DWORD [rax + Array.length] + + ; destination data end into r9 + mov r9, rax + add r9, Array.size + + ; Check if we are at the end of the destination + cmp r8, r9 + je .alloc_dest + +.copy_loop: + ; Copy one byte from source to destination + mov cl, BYTE [r10] + mov BYTE [r8], cl + + ; move source to next byte + inc r10 + ; Check if we've reached the end of this Array + cmp r10, r11 + jne .source_ok + + ; have reached the end of the source Array + mov rbx, QWORD [rbx + Array.next] ; Get the next Array address + test rbx, rbx ; Test if it's null + je .finished ; No more, so we're done + ; Move on to next Array object + + ; Get source address into r10 + mov r10, rbx + add r10, Array.data ; Start of the data + + ; Source end address + mov r11d, DWORD [rbx + Array.length] ; Length of the array + add r11, r10 + + ; Check if the next array is empty + cmp r10, r11 + je .finished + +.source_ok: + + ; Move destination to next byte + inc r8 + ; Check if we've reached end of the Array + cmp r8, r9 + jne .copy_loop ; Next byte + +.alloc_dest: + ; Reached the end of the destination + ; Need to allocate another Array + push rax + push rbx + call alloc_array ; New Array in rax + mov r8, rax ; copy to r8 + pop rbx + pop rax + + ; Previous Array in rax. + ; Add a reference to the new array and set length + mov QWORD [rax + Array.next], r8 + mov DWORD [rax + Array.length], (Array.size - Array.data) + mov rax, r8 ; new array + add r8, Array.data ; Start of data + + mov r9, rax + add r9, Array.size + jmp .copy_loop + +.finished: + ; Compare r8 (destination) with data start + ; to get length of string + sub r8, rax + sub r8, Array.data + inc r8 + ; r8 now contains length + mov DWORD [rax + Array.length], r8d +.return: + ret + +;; ------------------------------------------ +;; void print_string(char array) +;; Address of the char Array should be in RSI +print_string: + ; Push registers we're going to use + push rax + push rdi + push rdx + push rsi + + ; Check that we have a char array + mov al, [rsi] + cmp al, maltype_string + jne .error + +.print_chunk: + ; write(1, string, length) + push rsi + mov edx, [rsi + Array.length] ; number of bytes + add rsi, Array.data ; address of raw string to output + call print_rawstring + pop rsi + + ; Check if this is the end + mov rsi, QWORD [rsi + Array.next] + cmp rsi, 0 + jne .print_chunk ; next chunk + + ; Restore registers + pop rsi + pop rdx + pop rdi + pop rax + + ret +.error: + ; An error occurred + mov rdx, error_msg_print_string.len ; number of bytes + mov rsi, error_msg_print_string ; address of raw string to output + call print_rawstring + ; exit + jmp quit_error + +;; Copy a string +;; +;; Input: RSI - String to copy +;; +;; Output: New string in RAX +;; +;; Modifies: +;; RBX +;; RCX +;; RDX +;; RSI +;; +string_copy: + call string_new ; new string in RAX + + push rsi + push rax + + ; Get lengths + mov ebx, DWORD [rsi + Array.length] + mov [rax + Array.length], ebx + + ; Copy the whole block of data + ; Not sure if this is quicker than copying byte-by-byte + ; Could divide ebx by 8 (rounded up) to get the number + ; of blocks needed + + add rsi, Array.data ; Start of input data + add rax, Array.data ; Start of output data + mov ecx, array_chunk_len ; Number of 64-bit chunks + +.loop: + mov rbx, QWORD [rsi] + mov [rax], QWORD rbx + add rsi, 8 + add rax, 8 + dec ecx + jnz .loop + + pop rax + pop rsi + ; Now check if there's another block + mov rsi, [rsi + Array.next] + cmp rsi, 0 + jz .done ; Result in RAX + + ; Another array chunk + push rax ; Save output + + call string_copy ; Copy next chunk + mov rbx, rax ; The copy in RBX + + pop rax + ; append + mov [rax + Array.next], rbx +.done: + ret + +;; ------------------------------------------ +;; String itostring(Integer number) +;; +;; Converts an integer to a string (array of chars) +;; +;; Input in RAX +;; Return string address in RAX +itostring: + ; Save registers to restore afterwards + push rbx + push rcx + push rdx + push rsi + push rdi + + mov rcx, 0 ; counter of how many bytes we need to print in the end + + mov rbx, rax ; Original input + + ; Check if the number is negative + cmp rax, 0 + jge .divideLoop + + ; a negative number. To get the '-' sign + ; at the front the test is done again at the end + ; using the value stored in rbx + + neg rax ; Make it positive + +.divideLoop: + inc rcx ; count each byte to print - number of characters + xor rdx, rdx + mov rsi, 10 + idiv rsi ; divide rax by rsi + add rdx, 48 ; convert rdx to it's ascii representation - rdx holds the remainder after a divide instruction + ; Character is now in DL + dec rsp + mov BYTE [rsp], dl ; Put onto stack + + cmp rax, 0 ; can the integer be divided anymore? + jnz .divideLoop ; jump if not zero to the label divideLoop + + ; Check if the value was negative (in rbx) + cmp rbx, 0 + jge .create_string + + ; a negative number + dec rsp + mov BYTE [rsp], '-' + inc rcx + +.create_string: + ; Get an Array object to put the string into + call string_new ; Address in RAX + + ; put length into string + mov [rax + Array.length], ecx + + ; copy data from stack into string + ; Note: Currently this does not handle long strings + mov rdi, rax + add rdi, Array.data ; Address where raw string will go +.copyLoop: + mov BYTE dl, [rsp] ; Copy one byte at a time. Could be more efficient + mov [rdi], BYTE dl + inc rsp + inc rdi + dec rcx + cmp rcx, 0 + jnz .copyLoop + + ; Restore registers + pop rdi + pop rsi + pop rdx + pop rcx + pop rbx + + ret + + +;; ------------------------------------------------------------ +;; Object comparison +;; +;; These comparison functions take two objects +;; in RSI and RDI +;; and return a code (not an object) in RAX +;; +;; RAX = 0 Objects are equal +;; 1 RSI object is greater than RDI +;; 2 RSI object is less than RDI +;; -1 Different object types, or no ordering +;; +;; Note that the ordering of objects depends on the type +;; strings - Alphabetical +;; +;; +;; + +;; Given an object in RSI, follows pointers +;; to return the value object in RAX +;; +;; Modifies registers: +;; RCX +compare_get_value: + mov cl, BYTE [rsi] + mov ch, cl + and ch, block_mask + jnz .nop ; Got an Array + + ; Here got Cons + mov ch, cl + and ch, content_mask + cmp ch, content_pointer + jne .nop ; Not a pointer + + ; Got a pointer, so follow and return + mov rax, [rsi + Cons.car] + ret +.nop: + mov rax, rsi + ret + +;; Compare two objects in RSI and RDI. +;; Note that this does not compare lists +;; but will just compare the first element +;; +;; Modifies registers +;; RAX, RBX, RCX, RDX +;; +compare_objects: + ; Get the value that RSI points to + call compare_get_value + mov rbx, rax ; Save in RBX + ; Get the value that RDI points to + mov rsi, rdi + call compare_get_value + mov rdi, rax + mov rsi, rbx + + ; now get types + mov cl, BYTE [rsi] ; Type of RSI + mov bl, BYTE [rdi] ; Type of RDI + + mov ch, cl + mov bh, bl + + ; Don't care about container type + and cl, block_mask + content_mask + and bl, block_mask + content_mask + + cmp bl, cl ; compare block and content + jne .different_types + + ; Here the same block, content type + ; May be different container (value/list, string/symbol) + + ; Need to distinguish between map and vector/list + and ch, (block_mask + container_mask) + and bh, (block_mask + container_mask) + cmp ch, bh + je .same_container + ; if either is a map, then different types + cmp ch, container_map + je .different_types + cmp bh, container_map + je .different_types + +.same_container: + cmp bl, block_cons + content_nil + je .objects_equal ; nil + + cmp bl, block_array + content_char + je compare_char_array ; strings, symbols + + cmp bl, block_cons + content_int + je .integers + + ; Unknown + jmp .different_types + +.integers: + ; two Cons objects, both containing integers + mov rbx, [rsi + Cons.car] + cmp rbx, [rdi + Cons.car] + je .objects_equal + jl .rdi_greater + jmp .rsi_greater + +.objects_equal: + mov rax, 0 + ret + +.rsi_greater: ; rsi > rdi + mov rax, 1 + ret + +.rdi_greater: ; rdi > rsi + mov rax, 2 + ret + +.different_types: + mov rax, -1 + ret + + +;; Recursively check objects, including lists +;; +;; Inputs: Objects in RSI and RDI +;; +;; Sets ZF if equal, clears flag otherwise +compare_objects_rec: + ; Compare rsi and rdi objects + + ; Check type + mov al, BYTE [rsi] + mov bl, BYTE [rdi] + + mov ah, al + mov bh, bl + + ; Don't distinguish between [] and () + and ah, (block_mask + content_mask) + and bh, (block_mask + content_mask) + + cmp ah, bh + jne .false + + ; Need to distinguish between map and vector/list + mov ah, al + mov bh, bl + + and ah, (block_mask + container_mask) + and bh, (block_mask + container_mask) + cmp ah, bh + je .same_container + ; if either is a map, then different types + cmp ah, container_map + je .false + cmp bh, container_map + je .false + +.same_container: + + ; Check the container type + and bh, block_mask + jnz .array + + ; Check if a pointer to something + and al, content_mask + cmp al, content_pointer + je .pointer + + ; Get the values + + mov rbx, [rsi + Cons.car] + mov rcx, [rdi + Cons.car] + cmp rbx, rcx + jne .false + + ; Value is the same, so get next + jmp .next + +.array: + ; Comparing arrays + + ; Container type (symbol/string) does matter + cmp al, bl + jne .false + + call compare_char_array + cmp rax, 0 + ret ; Array has no next + +.pointer: + + mov rbx, [rsi + Cons.car] + mov rcx, [rdi + Cons.car] + cmp rbx, rcx + je .next ; Equal pointers + + push rsi + push rdi + ; Put the addresses to compare into RSI and RDI + mov rsi, rbx + mov rdi, rcx + call compare_objects_rec + pop rdi + pop rsi + jne .false + ; fall through to .next + +.next: + ; Check if both have a 'cdr' pointer + mov al, BYTE [rsi + Cons.typecdr] + mov bl, BYTE [rdi + Cons.typecdr] + + cmp al, content_pointer + je .rsi_has_next + + ; No next pointer in RSI + cmp bl, content_pointer + je .false ; RDI has a next pointer + + ; Neither have a next pointer, so done + jmp .true + +.rsi_has_next: + cmp bl, content_pointer + jne .false ; RDI has no next pointer + + ; Both have a next pointer, so keep going + mov rsi, [rsi + Cons.cdr] + mov rdi, [rdi + Cons.cdr] + jmp compare_objects_rec + +.false: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + ret +.true: + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + ret + +;; Char array objects (strings, symbols, keywords) in RSI and RDI +;; Return code in RAX +;; +;; Modifies registers: +;; RBX +;; RCX +;; RDX +compare_char_array: + ; Check length + mov eax, DWORD [rsi + Array.length] + mov ebx, DWORD [rdi + Array.length] + cmp eax, ebx + jne .different + + ; same length + + cmp eax, 0 + je .equal ; Both zero length + + mov rbx, rsi + add rbx, Array.data + mov rcx, rdi + add rcx, Array.data +.compare_loop: + ; get next character + mov dl, BYTE [rbx] + cmp dl, BYTE [rcx] + jl .rdi_greater + jg .rsi_greater + + ; this character is equal + inc rbx + inc rcx + dec eax + jnz .compare_loop ; Next character + +.equal: + mov rax, 0 + ret + +.rsi_greater: ; rsi > rdi + mov rax, 1 + ret + +.rdi_greater: ; rdi > rsi + mov rax, 2 + ret + +.different: + mov rax, -1 + ret + +;; ------------------------------------------------------------ +;; Map type +;; +;; This uses a list (Cons type) to represent key-value pairs in +;; a single chain. The only map which consists of an odd number of Cons +;; objects is the empty map, created by map_new +map_new: + call alloc_cons + mov [rax], BYTE (block_cons + container_map + content_empty) + mov [rax + Cons.typecdr], BYTE content_nil + ret + +;; Copy map +;; +;; Input: RSI - map +;; +;; Returns: new map in RAX +;; +;; Modifies: +;; RAX, RBX, RCX, R13, R14, R15 +;; +map_copy: + mov r14, rsi + + call alloc_cons + mov r15, rax ; start of new map + xor r13, r13 +.loop: + mov bl, BYTE [rsi] + mov rcx, [rsi + Cons.car] + mov [rax], BYTE bl ; copy type + mov [rax + Cons.car], rcx ; copy value + + and bl, content_mask + cmp bl, content_pointer + jne .set_cdr + + ; A pointer in CAR. Increase reference count + mov bx, WORD [rcx + Cons.refcount] + inc bx + mov [rcx + Cons.refcount], WORD bx + +.set_cdr: + test r13,r13 + jz .next + + ; R13 contains last Cons + mov [r13 + Cons.typecdr], BYTE content_pointer + mov [r13 + Cons.cdr], rax +.next: + mov r13, rax + + ; Check if there's another Cons + mov bl, BYTE [rsi + Cons.typecdr] + cmp bl, content_pointer + jne .done ; no more + + mov rsi, [rsi + Cons.cdr] ; next + call alloc_cons + jmp .loop +.done: + mov rax, r15 + mov rsi, r14 + ret + + +;; Add to map. Input is a list with an even number of values +;; as (key, value, key, value, ...) +;; +;; Inputs: +;; RSI - Map to append to. This is not modified +;; RDI - List to add to the map +;; Outputs: +;; RAX - New map +;; +;; Modifies: +;; RCX +map_add: + ; Check type of input + mov cl, BYTE [rsi] + mov cl, ch + and ch, block_mask + container_mask + cmp ch, block_cons + container_map + jne .error + + mov cl, BYTE [rdi] + and cl, block_mask + container_mask + cmp cl, block_cons + container_list + jne .error + + xor r8, r8 ; Zero r8 + +.copy_input: + ; Copy input list, changing container type + call alloc_cons + + mov cl, BYTE [rdi] + and cl, content_mask ; Keep the content + add cl, block_cons + container_map + mov [rax], BYTE cl ; Set type + mov rcx, [rdi+Cons.car] ; Copy data + mov [rax+Cons.car], rcx + + cmp cl, (block_cons + container_map + content_pointer) + jne .copy_not_pointer + + ; Copying a pointer to data + ; so need to increase the reference count + mov bx, WORD [rcx + Cons.refcount] ; Same offset for Array + inc bx + mov [rcx + Cons.refcount], WORD bx + +.copy_not_pointer: + + ; Check if this is the first object + cmp r8, 0 + jnz .copy_not_first + mov r8, rax ; Save start of map to R8 + mov r9, rax ; Last cons in R9 + jmp .copy_next + +.copy_not_first: + ; Append to R9 + mov [r9+Cons.cdr], rax + mov [r9+Cons.typecdr], BYTE content_pointer + + ; Put new Cons in R9 as the latest in the list + mov r9, rax + +.copy_next: + ; Check if we've reached the end + mov cl, BYTE [rdi + Cons.typecdr] + cmp cl, content_nil + je .copy_finished + + ; Not yet. Get next Cons and keep going + mov rdi, [rdi + Cons.cdr] + jmp .copy_input + +.copy_finished: + ; Start of map in r8, end in r9 + + ; Check if the original map is empty + mov cl, [rsi] + and cl, content_mask + cmp cl, content_empty + je .return + + ; Put old map on the end of the new map + ; For now this avoids the need to overwrite + ; values in the map, since a search will find + ; the new values first. + + mov [r9 + Cons.cdr], rsi + mov [r9 + Cons.typecdr], BYTE content_pointer + + ; Increment reference count + mov bx, WORD [rsi + Cons.refcount] + inc bx + mov [rsi + Cons.refcount], WORD bx + +.return: + mov rax, r8 + ret + +.error: + ; Return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + +;; Find a key in a map +;; +;; Inputs: RSI - map [ Modified ] +;; RDI - key [ Modified ] +;; +;; Outputs: RAX - Cons object containing value in CAR +;; +;; Modifies registers: +;; RBX [compare_objects, alloc_cons] +;; RCX [compare_objects] +;; +;; +;; If value is found then the Zero Flag is set +;; +;; Examples: +;; {a 1 b 2} find a -> {1 b 2} +;; {1 2 3 4} find a -> {4} +map_find: + mov al, BYTE [rsi] + cmp al, maltype_empty_map + je .not_found + +.map_loop: + ; compare RSI and RDI, ignoring differences in container + push rsi + push rdi + call compare_objects + pop rdi + pop rsi + + ; rax is now zero if objects are equal + cmp rax, 0 + je .found + + ; Move along two cons to the next key + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + jne .error ; Expecting value after key + + mov rsi, [rsi + Cons.cdr] ; Get value + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + jne .not_found + + mov rsi, [rsi + Cons.cdr] ; Get next key + + jmp .map_loop ; Test next key + +.found: + + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + + ; key in rsi. Get next value + mov al, [rsi + Cons.typecdr] + cmp al, content_pointer + jne .error ; Expecting value after key + + mov rsi, [rsi + Cons.cdr] + + ; ; increment reference count + ; mov ax, WORD [rsi + Cons.refcount] + ; inc ax + ; mov [rsi + Cons.refcount], WORD ax + ; Put address in rax + mov rax, rsi + ret + +.not_found: + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + + ; last cons in rsi + ; increment reference count + ; mov ax, WORD [rsi + Cons.refcount] + ; inc ax + ; mov [rsi + Cons.refcount], WORD ax + ; Put address in rax + mov rax, rsi + + ret + +.error: + + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + + ; return nil + call alloc_cons + mov [rax], BYTE maltype_nil + mov [rax + Cons.typecdr], BYTE content_nil + ret + +;; Map set +;; +;; Sets a key-value pair in a map +;; +;; Inputs: RSI - map [not modified] +;; RDI - key [not modified] +;; RCX - value [not modified] +;; +;; If references are added to key or value, +;; then reference counts are incremented. +;; +;; Modifies registers: +;; R8 +;; R9 +;; R10 +map_set: + ; Save inputs in less volatile registers + mov r8, rsi ; map + mov r9, rdi ; key + mov r10, rcx ; value + + ; Find the key, to see if it already exists in the map + call map_find ; Cons object in RAX + je .found_key + + ; Key not in map. RAX should be address of the last + ; value in the map, or empty + mov bl, BYTE [rax] + cmp bl, maltype_empty_map + je .set_key + + ; Append key + push rax + call alloc_cons ; New Cons in rax + pop rbx ; Last Cons in map + + ; append rax to rbx + mov [rbx + Cons.typecdr], BYTE content_pointer + mov [rbx + Cons.cdr], rax + jmp .set_key ; Put key into rax + +.found_key: + ; Key already in map, so replace value + ; address in RAX + + ; check type of value already there + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + jne .set_value ; Not a pointer, just overwrite + + ; A pointer, so need to release + mov rsi, [rax + Cons.car] ; Address of object + push rax + call release_object + pop rax + + jmp .set_value ; put value into Cons + +.set_key: + ; Put key (R9) in RAX + + ; Check the type of object + mov bl, BYTE [r9] + mov bh, bl + and bh, block_mask + jnz .set_key_pointer ; Array, so point to it + + ; Here a Cons object + mov bh, bl + and bh, container_mask + cmp bh, container_value + jne .set_key_pointer ; Not a simple value, so point to it + + ; A value, so copy + mov rcx, [r9 + Cons.car] + mov [rax + Cons.car], rcx + + ; Set the type + and bl, content_mask + or bl, (block_cons + container_map) + mov [rax], BYTE bl + + jmp .set_key_done + +.set_key_pointer: + ; The key is a pointer + + mov [rax + Cons.car], r9 + mov [rax], BYTE (block_cons + container_map + content_pointer) + ; Increment reference count + mov bx, WORD [r9 + Cons.refcount] + inc bx + mov [r9 + Cons.refcount], bx + ; fall through to .set_key_done + +.set_key_done: + ; Key in RAX. allocate and append a Cons for the value + push rax + call alloc_cons ; value Cons in rax + pop rbx ; key Cons + ; append rax to rbx + mov [rbx + Cons.typecdr], BYTE content_pointer + mov [rbx + Cons.cdr], rax + + ; fall through to .set_value + + ; -------------------------------- +.set_value: + ; Set the value into the Cons at [rax] + + ; Check the type of object + mov bl, BYTE [r10] + mov bh, bl + and bh, block_mask + jnz .set_value_pointer ; Array, so point to it + + ; Here a Cons object + mov bh, bl + and bh, container_mask + cmp bh, container_value + jne .set_value_pointer ; Not a simple value, so point to it + ; A value, so copy + mov rcx, [r10 + Cons.car] + mov [rax + Cons.car], rcx + + ; Set the type + and bl, content_mask + or bl, (block_cons + container_map) + mov [rax], BYTE bl + + jmp .finished + +.set_value_pointer: + mov [rax + Cons.car], r10 ; Put address into CAR + mov [rax], BYTE (block_cons + container_map + content_pointer) ; Mark as a pointer + ; Increment reference count + mov bx, WORD [r10 + Cons.refcount] + inc bx + mov [r10 + Cons.refcount], bx + ; fall through to .finished + +.finished: + ; Restore inputs + mov rsi, r8 + mov rdi, r9 + mov rcx, r10 + ret + +;; Get a value from a map, incrementing the reference count +;; of the object returned +;; +;; Inputs: RSI - map +;; RDI - key +;; +;; Returns: If found, Zero Flag is set and address in RAX +;; If not found, Zero Flag cleared +;; +;; Modifies registers: +;; RAX +;; RBX +;; RCX +;; R8 +;; R9 +map_get: + ; Save inputs + mov r8, rsi ; map + mov r9, rdi ; key + + call map_find ; Cons object in RAX + je .found_key + + ; Not found + + mov rsi, r8 + mov rdi, r9 + + lahf ; flags in AH + and ah, 255-64 ; clear zero flag + sahf + + ret + ; --------------- +.found_key: + + ; Check if the object in RAX is a value or pointer + mov bl, BYTE [rax] + and bl, content_mask + cmp bl, content_pointer + je .got_pointer + + ; A value, so copy + + push rax + push rbx + call alloc_cons ; cons in rax + pop rbx ; content type in bl + pop rcx ; Object to copy + + add bl, block_cons + container_value + mov [rax], BYTE bl ; set type + mov [rax + Cons.typecdr], BYTE content_nil + + ; Copy value + mov rbx, [rcx + Cons.car] + mov [rax + Cons.car], rbx + + jmp .finished_found + +.got_pointer: + ; A pointer, so get the address + mov rax, [rax + Cons.car] + + ; increment reference count + mov bx, WORD [rax + Cons.refcount] + inc bx + mov [rax + Cons.refcount], bx + + ; Fall through to .finished_found +.finished_found: + mov rsi, r8 + mov rdi, r9 + + mov rbx, rax + lahf ; flags in AH + or ah, 64 ; set zero flag + sahf + mov rax, rbx + ret + +;; Get a list of keys +;; +;; Input: Map in RSI +;; +;; Returns: List in RAX +;; +;; Modifies registers: +;; RAX +;; RBX +;; RCX +;; R8 +;; R9 +map_keys: + ; check type + mov al, BYTE [rsi] + cmp al, maltype_empty_map + je .empty_map + + and al, container_mask + cmp al, container_map + jne .empty_map ; error + + xor r8, r8 ; Return list + + ; Take the current value +.loop: + ; Create a new Cons for this key + call alloc_cons + mov cl, BYTE [rsi] + and cl, content_mask + add cl, block_cons + container_list + mov [rax], BYTE cl ; Set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Set value + + and cl, content_mask + cmp cl, content_pointer + jne .append + + ; A pointer, so increment reference count + mov cx, WORD [rbx + Cons.refcount] + inc cx + mov [rbx + Cons.refcount], WORD cx + +.append: + cmp r8, 0 + je .first + + ; appending + mov [r9 + Cons.typecdr], BYTE content_pointer + mov [r9 + Cons.cdr], rax + mov r9, rax + jmp .next +.first: + ; First key, so put into r8 + mov r8, rax + mov r9, rax +.next: + ; First get the value + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done ; error. Should be a value + mov rsi, [rsi + Cons.cdr] + + ; Get the next key + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done + mov rsi, [rsi + Cons.cdr] + jmp .loop +.done: + ; Finished, return the list + mov rax, r8 + ret + +.empty_map: + ; return empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + +;; Get a list of values +;; +;; Input: Map in RSI +;; +;; Returns: List in RAX +;; +;; Modifies registers: +;; RAX +;; RBX +;; RCX +;; R8 +;; R9 +map_vals: + ; check type + mov al, BYTE [rsi] + cmp al, maltype_empty_map + je .empty_map + + and al, container_mask + cmp al, container_map + jne .empty_map ; error + + xor r8, r8 ; Return list + +.loop: + ; Here should have a key in RSI + + ; First get the value + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done ; error. Should be a value + + mov rsi, [rsi + Cons.cdr] ; Now have value in RSI + + ; Create a new Cons for this value + call alloc_cons + mov cl, BYTE [rsi] + and cl, content_mask + add cl, block_cons + container_list + mov [rax], BYTE cl ; Set type + mov rbx, [rsi + Cons.car] + mov [rax + Cons.car], rbx ; Set value + + and cl, content_mask + cmp cl, content_pointer + jne .append + + ; A pointer, so increment reference count + mov cx, WORD [rbx + Cons.refcount] + inc cx + mov [rbx + Cons.refcount], WORD cx + +.append: + cmp r8, 0 + je .first + + ; appending + mov [r9 + Cons.typecdr], BYTE content_pointer + mov [r9 + Cons.cdr], rax + mov r9, rax + jmp .next +.first: + ; First key, so put into r8 + mov r8, rax + mov r9, rax +.next: + ; Get the next key + mov al, BYTE [rsi + Cons.typecdr] + cmp al, content_pointer + jne .done + mov rsi, [rsi + Cons.cdr] + jmp .loop +.done: + ; Finished, return the list + mov rax, r8 + ret + +.empty_map: + ; return empty list + call alloc_cons + mov [rax], BYTE maltype_empty_list + ret + + +;; ------------------------------------------------------------ +;; Function type +;; +;; Functions are consist of a list +;; - First car is the function address to call +;; - Second is the Meta data (nil by default) +;; - Third is the environment +;; - Fourth is the binds list +;; - Fifth is the body of the function +;; +;; ( addr meta env binds body ) +;; +;; + +;; Address of native function in RSI +;; returns Function object in RAX +native_function: + call alloc_cons ; for meta + mov [rax], BYTE maltype_nil + push rax + + call alloc_cons ; For function address + mov [rax], BYTE (block_cons + container_function + content_function) + mov [rax + Cons.car], rsi + + mov [rax + Cons.typecdr], BYTE content_pointer + pop rbx ; meta + mov [rax + Cons.cdr], rbx + ret diff --git a/impls/nim/Dockerfile b/impls/nim/Dockerfile index 6b30bad9a5..b936e0a405 100644 --- a/impls/nim/Dockerfile +++ b/impls/nim/Dockerfile @@ -1,35 +1,35 @@ -FROM ubuntu:bionic -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Install g++ for any C/C++ based implementations -RUN apt-get -y install g++ - -# Nim -RUN apt-get -y install xz-utils -RUN cd /tmp && curl -O https://nim-lang.org/download/nim-1.0.4.tar.xz \ - && tar xvJf /tmp/nim-1.0.4.tar.xz && cd nim-1.0.4 \ - && make && sh install.sh /usr/local/bin \ - && cp bin/nim /usr/local/bin/ \ - && rm -r /tmp/nim-1.0.4 - -ENV HOME /mal +FROM ubuntu:bionic +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Install g++ for any C/C++ based implementations +RUN apt-get -y install g++ + +# Nim +RUN apt-get -y install xz-utils +RUN cd /tmp && curl -O https://nim-lang.org/download/nim-1.0.4.tar.xz \ + && tar xvJf /tmp/nim-1.0.4.tar.xz && cd nim-1.0.4 \ + && make && sh install.sh /usr/local/bin \ + && cp bin/nim /usr/local/bin/ \ + && rm -r /tmp/nim-1.0.4 + +ENV HOME /mal diff --git a/impls/nim/Makefile b/impls/nim/Makefile index 11fd6cb91f..6ba336d404 100644 --- a/impls/nim/Makefile +++ b/impls/nim/Makefile @@ -1,27 +1,27 @@ -##################### - -SOURCES_BASE = types.nim reader.nim printer.nim -SOURCES_REBUILD = $(SOURCES_BASE) env.nim core.nim - -##################### - -SRCS = step0_repl.nim step1_read_print.nim step2_eval.nim step3_env.nim \ - step4_if_fn_do.nim step5_tco.nim step6_file.nim step7_quote.nim \ - step8_macros.nim step9_try.nim stepA_mal.nim -BINS = $(SRCS:%.nim=%) - -##################### - -all: $(BINS) - -dist: mal - -mal: $(word $(words $(BINS)),$(BINS)) - cp $< $@ - -$(BINS): %: %.nim $(SOURCES_REBUILD) - nim -d:release --nimcache:nimcache-$@ c $@ - -clean: - rm -rf nimcache-*/ $(BINS) - rm -f mal +##################### + +SOURCES_BASE = types.nim reader.nim printer.nim +SOURCES_REBUILD = $(SOURCES_BASE) env.nim core.nim + +##################### + +SRCS = step0_repl.nim step1_read_print.nim step2_eval.nim step3_env.nim \ + step4_if_fn_do.nim step5_tco.nim step6_file.nim step7_quote.nim \ + step8_macros.nim step9_try.nim stepA_mal.nim +BINS = $(SRCS:%.nim=%) + +##################### + +all: $(BINS) + +dist: mal + +mal: $(word $(words $(BINS)),$(BINS)) + cp $< $@ + +$(BINS): %: %.nim $(SOURCES_REBUILD) + nim -d:release --nimcache:nimcache-$@ c $@ + +clean: + rm -rf nimcache-*/ $(BINS) + rm -f mal diff --git a/impls/nim/core.nim b/impls/nim/core.nim index 37f37034de..feca205967 100644 --- a/impls/nim/core.nim +++ b/impls/nim/core.nim @@ -1,246 +1,246 @@ -import strutils, rdstdin, tables, times, sequtils, types, printer, reader - -type MalError* = object of Exception - t*: MalType - -# String functions -proc pr_str(xs: varargs[MalType]): MalType = - str(xs.map(proc(x: MalType): string = x.pr_str(true)).join(" ")) - -proc do_str(xs: varargs[MalType]): MalType = - str(xs.map(proc(x: MalType): string = x.pr_str(false)).join) - -proc prn(xs: varargs[MalType]): MalType = - echo xs.map(proc(x: MalType): string = x.pr_str(true)).join(" ") - result = nilObj - -proc println(xs: varargs[MalType]): MalType = - echo xs.map(proc(x: MalType): string = x.pr_str(false)).join(" ") - result = nilObj - -proc read_str(xs: varargs[MalType]): MalType = - read_str(xs[0].str) - -proc readline(xs: varargs[MalType]): MalType = - str readLineFromStdin(xs[0].str) - -proc slurp(xs: varargs[MalType]): MalType = - str readFile(xs[0].str) - -proc cons(xs: varargs[MalType]): MalType = - result = list(xs[0]) - for x in xs[1].list: result.list.add x - -proc concat(xs: varargs[MalType]): MalType = - result = list() - for x in xs: - for i in x.list: - result.list.add i - -proc vec(xs: varargs[MalType]): MalType = - result = MalType(kind: Vector, list: newSeq[MalType](xs[0].list.len)) - for i, x in xs[0].list: - result.list[i] = x - -proc nth(xs: varargs[MalType]): MalType = - if xs[1].number < xs[0].list.len: return xs[0].list[xs[1].number] - else: raise newException(ValueError, "nth: index out of range") - -proc first(xs: varargs[MalType]): MalType = - if xs[0].kind in {List, Vector} and xs[0].list.len > 0: - xs[0].list[0] - else: nilObj - -proc rest(xs: varargs[MalType]): MalType = - if xs[0].kind in {List, Vector} and xs[0].list.len > 0: - list xs[0].list[1 .. ^1] - else: list() - -proc throw(xs: varargs[MalType]): MalType = - raise (ref MalError)(t: list xs) - -proc assoc(xs: varargs[MalType]): MalType = - result = hash_map() - result.hash_map = xs[0].hash_map - for i in countup(1, xs.high, 2): - result.hash_map[xs[i].str] = xs[i+1] - -proc dissoc(xs: varargs[MalType]): MalType = - result = hash_map() - result.hash_map = xs[0].hash_map - for i in 1 .. xs.high: - if result.hash_map.hasKey(xs[i].str): result.hash_map.del(xs[i].str) - -proc get(xs: varargs[MalType]): MalType = - if xs[0].kind == HashMap: - if xs[1].str in xs[0].hash_map: - result = xs[0].hash_map[xs[1].str] - if not result.isNil: return - - result = nilObj - -proc contains_q(xs: varargs[MalType]): MalType = - boolObj xs[0].hash_map.hasKey(xs[1].str) - -proc keys(xs: varargs[MalType]): MalType = - result = list() - for key in xs[0].hash_map.keys: - result.list.add str(key) - -proc vals(xs: varargs[MalType]): MalType = - result = list() - for value in xs[0].hash_map.values: - result.list.add value - -proc apply(xs: varargs[MalType]): MalType = - var s = newSeq[MalType]() - if xs.len > 2: - for j in 1 .. xs.high-1: - s.add xs[j] - s.add xs[xs.high].list - xs[0].getFun()(s) - -proc map(xs: varargs[MalType]): MalType = - result = list() - for i in 0 .. xs[1].list.high: - result.list.add xs[0].getFun()(xs[1].list[i]) - -proc conj(xs: varargs[MalType]): MalType = - if xs[0].kind == List: - result = list() - for i in countdown(xs.high, 1): - result.list.add xs[i] - result.list.add xs[0].list - else: - result = vector() - result.list.add xs[0].list - for i in 1..xs.high: - result.list.add xs[i] - result.meta = xs[0].meta - -proc seq(xs: varargs[MalType]): MalType = - if xs[0].kind == List: - if len(xs[0].list) == 0: return nilObj - result = xs[0] - elif xs[0].kind == Vector: - if len(xs[0].list) == 0: return nilObj - result = list() - result.list.add xs[0].list - elif xs[0].kind == String: - if len(xs[0].str) == 0: return nilObj - result = list() - for i in countup(0, len(xs[0].str) - 1): - result.list.add(str xs[0].str.substr(i,i)) - elif xs[0] == nilObj: - result = nilObj - else: - raise newException(ValueError, "seq: called on non-sequence") - -proc with_meta(xs: varargs[MalType]): MalType = - new result - result[] = xs[0][] - result.meta = xs[1] - -proc meta(xs: varargs[MalType]): MalType = - if not xs[0].meta.isNil: xs[0].meta - else: nilObj - -proc deref(xs: varargs[MalType]): MalType = - xs[0].val - -proc reset_bang(xs: varargs[MalType]): MalType = - xs[0].val = xs[1] - result = xs[0].val - -proc swap_bang(xs: varargs[MalType]): MalType = - var args = @[xs[0].val] - for i in 2 .. xs.high: - args.add xs[i] - xs[0].val = xs[1].getFun()(args) - result = xs[0].val - -proc time_ms(xs: varargs[MalType]): MalType = - number int(epochTime() * 1000) - -template wrapNumberFun(op): untyped = - fun proc(xs: varargs[MalType]): MalType = - number op(xs[0].number, xs[1].number) - -template wrapBoolFun(op): untyped = - fun proc(xs: varargs[MalType]): MalType = - if op(xs[0].number, xs[1].number): trueObj else: falseObj - -let ns* = { - "+": wrapNumberFun(`+`), - "-": wrapNumberFun(`-`), - "*": wrapNumberFun(`*`), - "/": wrapNumberFun(`div`), - - "<": wrapBoolFun(`<`), - "<=": wrapBoolFun(`<=`), - ">": wrapBoolFun(`>`), - ">=": wrapBoolFun(`>=`), - - "list": fun list, - "list?": fun list_q, - "vector": fun vector, - "vector?": fun vector_q, - "hash-map": fun hash_map, - "map?": fun hash_map_q, - "empty?": fun empty_q, - "assoc": fun assoc, - "dissoc": fun dissoc, - "get": fun get, - "contains?": fun contains_q, - "keys": fun keys, - "vals": fun vals, - - "=": fun equal, - - "pr-str": fun pr_str, - "str": fun do_str, - "prn": fun prn, - "println": fun println, - - "read-string": fun read_str, - "readline": fun readline, - "slurp": fun slurp, - - "sequential?": fun seq_q, - "cons": fun cons, - "concat": fun concat, - "vec": fun vec, - "count": fun count, - "nth": fun nth, - "first": fun first, - "rest": fun rest, - "apply": fun apply, - "map": fun map, - - "conj": fun conj, - "seq": fun seq, - - "throw": fun throw, - - "nil?": fun nil_q, - "true?": fun true_q, - "false?": fun false_q, - "string?": fun string_q, - "symbol": fun symbol, - "symbol?": fun symbol_q, - "keyword": fun keyword, - "keyword?": fun keyword_q, - "number?": fun number_q, - "fn?": fun fn_q, - "macro?": fun macro_q, - - "with-meta": fun with_meta, - "meta": fun meta, - "atom": fun atom, - "atom?": fun atom_q, - "deref": fun deref, - "reset!": fun reset_bang, - "swap!": fun swap_bang, - - "time-ms": fun time_ms, -} +import strutils, rdstdin, tables, times, sequtils, types, printer, reader + +type MalError* = object of Exception + t*: MalType + +# String functions +proc pr_str(xs: varargs[MalType]): MalType = + str(xs.map(proc(x: MalType): string = x.pr_str(true)).join(" ")) + +proc do_str(xs: varargs[MalType]): MalType = + str(xs.map(proc(x: MalType): string = x.pr_str(false)).join) + +proc prn(xs: varargs[MalType]): MalType = + echo xs.map(proc(x: MalType): string = x.pr_str(true)).join(" ") + result = nilObj + +proc println(xs: varargs[MalType]): MalType = + echo xs.map(proc(x: MalType): string = x.pr_str(false)).join(" ") + result = nilObj + +proc read_str(xs: varargs[MalType]): MalType = + read_str(xs[0].str) + +proc readline(xs: varargs[MalType]): MalType = + str readLineFromStdin(xs[0].str) + +proc slurp(xs: varargs[MalType]): MalType = + str readFile(xs[0].str) + +proc cons(xs: varargs[MalType]): MalType = + result = list(xs[0]) + for x in xs[1].list: result.list.add x + +proc concat(xs: varargs[MalType]): MalType = + result = list() + for x in xs: + for i in x.list: + result.list.add i + +proc vec(xs: varargs[MalType]): MalType = + result = MalType(kind: Vector, list: newSeq[MalType](xs[0].list.len)) + for i, x in xs[0].list: + result.list[i] = x + +proc nth(xs: varargs[MalType]): MalType = + if xs[1].number < xs[0].list.len: return xs[0].list[xs[1].number] + else: raise newException(ValueError, "nth: index out of range") + +proc first(xs: varargs[MalType]): MalType = + if xs[0].kind in {List, Vector} and xs[0].list.len > 0: + xs[0].list[0] + else: nilObj + +proc rest(xs: varargs[MalType]): MalType = + if xs[0].kind in {List, Vector} and xs[0].list.len > 0: + list xs[0].list[1 .. ^1] + else: list() + +proc throw(xs: varargs[MalType]): MalType = + raise (ref MalError)(t: list xs) + +proc assoc(xs: varargs[MalType]): MalType = + result = hash_map() + result.hash_map = xs[0].hash_map + for i in countup(1, xs.high, 2): + result.hash_map[xs[i].str] = xs[i+1] + +proc dissoc(xs: varargs[MalType]): MalType = + result = hash_map() + result.hash_map = xs[0].hash_map + for i in 1 .. xs.high: + if result.hash_map.hasKey(xs[i].str): result.hash_map.del(xs[i].str) + +proc get(xs: varargs[MalType]): MalType = + if xs[0].kind == HashMap: + if xs[1].str in xs[0].hash_map: + result = xs[0].hash_map[xs[1].str] + if not result.isNil: return + + result = nilObj + +proc contains_q(xs: varargs[MalType]): MalType = + boolObj xs[0].hash_map.hasKey(xs[1].str) + +proc keys(xs: varargs[MalType]): MalType = + result = list() + for key in xs[0].hash_map.keys: + result.list.add str(key) + +proc vals(xs: varargs[MalType]): MalType = + result = list() + for value in xs[0].hash_map.values: + result.list.add value + +proc apply(xs: varargs[MalType]): MalType = + var s = newSeq[MalType]() + if xs.len > 2: + for j in 1 .. xs.high-1: + s.add xs[j] + s.add xs[xs.high].list + xs[0].getFun()(s) + +proc map(xs: varargs[MalType]): MalType = + result = list() + for i in 0 .. xs[1].list.high: + result.list.add xs[0].getFun()(xs[1].list[i]) + +proc conj(xs: varargs[MalType]): MalType = + if xs[0].kind == List: + result = list() + for i in countdown(xs.high, 1): + result.list.add xs[i] + result.list.add xs[0].list + else: + result = vector() + result.list.add xs[0].list + for i in 1..xs.high: + result.list.add xs[i] + result.meta = xs[0].meta + +proc seq(xs: varargs[MalType]): MalType = + if xs[0].kind == List: + if len(xs[0].list) == 0: return nilObj + result = xs[0] + elif xs[0].kind == Vector: + if len(xs[0].list) == 0: return nilObj + result = list() + result.list.add xs[0].list + elif xs[0].kind == String: + if len(xs[0].str) == 0: return nilObj + result = list() + for i in countup(0, len(xs[0].str) - 1): + result.list.add(str xs[0].str.substr(i,i)) + elif xs[0] == nilObj: + result = nilObj + else: + raise newException(ValueError, "seq: called on non-sequence") + +proc with_meta(xs: varargs[MalType]): MalType = + new result + result[] = xs[0][] + result.meta = xs[1] + +proc meta(xs: varargs[MalType]): MalType = + if not xs[0].meta.isNil: xs[0].meta + else: nilObj + +proc deref(xs: varargs[MalType]): MalType = + xs[0].val + +proc reset_bang(xs: varargs[MalType]): MalType = + xs[0].val = xs[1] + result = xs[0].val + +proc swap_bang(xs: varargs[MalType]): MalType = + var args = @[xs[0].val] + for i in 2 .. xs.high: + args.add xs[i] + xs[0].val = xs[1].getFun()(args) + result = xs[0].val + +proc time_ms(xs: varargs[MalType]): MalType = + number int(epochTime() * 1000) + +template wrapNumberFun(op): untyped = + fun proc(xs: varargs[MalType]): MalType = + number op(xs[0].number, xs[1].number) + +template wrapBoolFun(op): untyped = + fun proc(xs: varargs[MalType]): MalType = + if op(xs[0].number, xs[1].number): trueObj else: falseObj + +let ns* = { + "+": wrapNumberFun(`+`), + "-": wrapNumberFun(`-`), + "*": wrapNumberFun(`*`), + "/": wrapNumberFun(`div`), + + "<": wrapBoolFun(`<`), + "<=": wrapBoolFun(`<=`), + ">": wrapBoolFun(`>`), + ">=": wrapBoolFun(`>=`), + + "list": fun list, + "list?": fun list_q, + "vector": fun vector, + "vector?": fun vector_q, + "hash-map": fun hash_map, + "map?": fun hash_map_q, + "empty?": fun empty_q, + "assoc": fun assoc, + "dissoc": fun dissoc, + "get": fun get, + "contains?": fun contains_q, + "keys": fun keys, + "vals": fun vals, + + "=": fun equal, + + "pr-str": fun pr_str, + "str": fun do_str, + "prn": fun prn, + "println": fun println, + + "read-string": fun read_str, + "readline": fun readline, + "slurp": fun slurp, + + "sequential?": fun seq_q, + "cons": fun cons, + "concat": fun concat, + "vec": fun vec, + "count": fun count, + "nth": fun nth, + "first": fun first, + "rest": fun rest, + "apply": fun apply, + "map": fun map, + + "conj": fun conj, + "seq": fun seq, + + "throw": fun throw, + + "nil?": fun nil_q, + "true?": fun true_q, + "false?": fun false_q, + "string?": fun string_q, + "symbol": fun symbol, + "symbol?": fun symbol_q, + "keyword": fun keyword, + "keyword?": fun keyword_q, + "number?": fun number_q, + "fn?": fun fn_q, + "macro?": fun macro_q, + + "with-meta": fun with_meta, + "meta": fun meta, + "atom": fun atom, + "atom?": fun atom_q, + "deref": fun deref, + "reset!": fun reset_bang, + "swap!": fun swap_bang, + + "time-ms": fun time_ms, +} diff --git a/impls/nim/env.nim b/impls/nim/env.nim index dcb64f7da8..cad626ce93 100644 --- a/impls/nim/env.nim +++ b/impls/nim/env.nim @@ -1,25 +1,25 @@ -import tables, types - -proc initEnv*(outer: Env = nil, binds, exprs: MalType = nilObj): Env = - result = Env(data: initTable[string, MalType](), outer: outer) - - if binds.kind in {List, Vector}: - for i, e in binds.list: - if e.str == "&": - result.data[binds.list[i+1].str] = list(exprs.list[i .. ^1]) - break - else: - result.data[e.str] = exprs.list[i] - -proc set*(e: var Env, key: string, value: MalType): MalType {.discardable.} = - e.data[key] = value - value - -proc find*(e: Env, key: string): Env = - if e.data.hasKey(key): return e - if e.outer != nil: return e.outer.find(key) - -proc get*(e: Env, key: string): MalType = - let env = e.find(key) - if env == nil: raise newException(ValueError, "'" & key & "' not found") - env.data[key] +import tables, types + +proc initEnv*(outer: Env = nil, binds, exprs: MalType = nilObj): Env = + result = Env(data: initTable[string, MalType](), outer: outer) + + if binds.kind in {List, Vector}: + for i, e in binds.list: + if e.str == "&": + result.data[binds.list[i+1].str] = list(exprs.list[i .. ^1]) + break + else: + result.data[e.str] = exprs.list[i] + +proc set*(e: var Env, key: string, value: MalType): MalType {.discardable.} = + e.data[key] = value + value + +proc find*(e: Env, key: string): Env = + if e.data.hasKey(key): return e + if e.outer != nil: return e.outer.find(key) + +proc get*(e: Env, key: string): MalType = + let env = e.find(key) + if env == nil: raise newException(ValueError, "'" & key & "' not found") + env.data[key] diff --git a/impls/nim/mal.nimble b/impls/nim/mal.nimble index 571ea349be..105463012f 100644 --- a/impls/nim/mal.nimble +++ b/impls/nim/mal.nimble @@ -1,11 +1,11 @@ -[Package] -name = "mal" -version = "1.1" -author = "Dennis Felsing" -description = "Mal code in Nim" -license = "MIT" - -bin = "step0_repl, step1_read_print, step2_eval, step3_env, step4_if_fn_do, step5_tco, step6_file, step7_quote, step8_macros, step9_try, stepA_mal" - -[Deps] -Requires = "nim >= 0.10.3" +[Package] +name = "mal" +version = "1.1" +author = "Dennis Felsing" +description = "Mal code in Nim" +license = "MIT" + +bin = "step0_repl, step1_read_print, step2_eval, step3_env, step4_if_fn_do, step5_tco, step6_file, step7_quote, step8_macros, step9_try, stepA_mal" + +[Deps] +Requires = "nim >= 0.10.3" diff --git a/impls/nim/nim.cfg b/impls/nim/nim.cfg index a9663a6b63..cc78d4ed36 100644 --- a/impls/nim/nim.cfg +++ b/impls/nim/nim.cfg @@ -1 +1 @@ -gc: markandsweep +gc: markandsweep diff --git a/impls/nim/printer.nim b/impls/nim/printer.nim index e6edf9cc84..f2e7467257 100644 --- a/impls/nim/printer.nim +++ b/impls/nim/printer.nim @@ -1,27 +1,27 @@ -import strutils, sequtils, tables, types - -proc str_handle(x: string, pr = true): string = - if x.len > 0 and x[0] == '\xff': - result = ":" & x[1 .. x.high] - elif pr: result = "\"" & x.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n") & "\"" - else: result = x - -proc pr_str*(m: MalType, pr = true): string = - case m.kind - of Nil: result = "nil" - of True: result = "true" - of False: result = "false" - of Fun: result = "#" - of MalFun: result = "#" - of Atom: result = "(atom " & m.val.pr_str & ")" - of Symbol: result = m.str - of String: result = m.str.str_handle(pr) - of Number: result = $m.number - of List: result = "(" & m.list.mapIt(it.pr_str(pr)).join(" ") & ")" - of Vector: result = "[" & m.list.mapIt(it.pr_str(pr)).join(" ") & "]" - of HashMap: - result = "{" - for key, val in m.hash_map.pairs: - if result.len > 1: result.add " " - result.add key.str_handle & " " & val.pr_str(pr) - result.add "}" +import strutils, sequtils, tables, types + +proc str_handle(x: string, pr = true): string = + if x.len > 0 and x[0] == '\xff': + result = ":" & x[1 .. x.high] + elif pr: result = "\"" & x.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n") & "\"" + else: result = x + +proc pr_str*(m: MalType, pr = true): string = + case m.kind + of Nil: result = "nil" + of True: result = "true" + of False: result = "false" + of Fun: result = "#" + of MalFun: result = "#" + of Atom: result = "(atom " & m.val.pr_str & ")" + of Symbol: result = m.str + of String: result = m.str.str_handle(pr) + of Number: result = $m.number + of List: result = "(" & m.list.mapIt(it.pr_str(pr)).join(" ") & ")" + of Vector: result = "[" & m.list.mapIt(it.pr_str(pr)).join(" ") & "]" + of HashMap: + result = "{" + for key, val in m.hash_map.pairs: + if result.len > 1: result.add " " + result.add key.str_handle & " " & val.pr_str(pr) + result.add "}" diff --git a/impls/nim/reader.nim b/impls/nim/reader.nim index 04f4739bf2..e1d4676260 100644 --- a/impls/nim/reader.nim +++ b/impls/nim/reader.nim @@ -1,116 +1,116 @@ -import options, re, strutils, types - -let - tokenRE = re"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)""" - intRE = re"-?[0-9]+$" - strRE = re"""^"(?:\\.|[^\\"])*"$""" - -type - Blank* = object of Exception - - Reader = object - tokens: seq[string] - position: int - -proc next(r: var Reader): Option[string] = - if r.position < r.tokens.len: - result = r.tokens[r.position].some - inc r.position - -proc peek(r: Reader): Option[string] = - if r.position < r.tokens.len: return r.tokens[r.position].some - -proc tokenize(str: string): seq[string] = - result = @[] - var pos = 0 - while pos < str.len: - var matches: array[2, string] - var len = str.findBounds(tokenRE, matches, pos) - if len.first != -1 and len.last != -1 and len.last >= len.first: - pos = len.last + 1 - if matches[0].len > 0 and matches[0][0] != ';': - result.add matches[0] - else: - inc pos - -proc read_form(r: var Reader): MalType - -proc read_seq(r: var Reader, fr, to: string): seq[MalType] = - result = @[] - var t = r.next - if t.get("") != fr: raise newException(ValueError, "expected '" & fr & "'") - - t = r.peek - while t.get("") != to: - if t.get("") == "": raise newException(ValueError, "expected '" & to & "', got EOF") - result.add r.read_form - t = r.peek - discard r.next - -proc read_list(r: var Reader): MalType = - result = list r.read_seq("(", ")") - -proc read_vector(r: var Reader): MalType = - result = vector r.read_seq("[", "]") - -proc read_hash_map(r: var Reader): MalType = - result = hash_map r.read_seq("{", "}") - -proc read_atom(r: var Reader): MalType = - let t = r.next.get("") - if t.match(intRE): number t.parseInt - elif t[0] == '"': - if not t.match(strRE): - raise newException(ValueError, "expected '\"', got EOF") - str t[1 ..< t.high].multiReplace(("\\\"", "\""), ("\\n", "\n"), ("\\\\", "\\")) - elif t[0] == ':': keyword t[1 .. t.high] - elif t == "nil": nilObj - elif t == "true": trueObj - elif t == "false": falseObj - else: symbol t - -proc read_form(r: var Reader): MalType = - if r.peek.get("")[0] == ';': - discard r.next - return nilObj - case r.peek.get("") - of "'": - discard r.next - result = list(symbol "quote", r.read_form) - of "`": - discard r.next - result = list(symbol "quasiquote", r.read_form) - of "~": - discard r.next - result = list(symbol "unquote", r.read_form) - of "~@": - discard r.next - result = list(symbol "splice-unquote", r.read_form) - of "^": - discard r.next - let meta = r.read_form - result = list(symbol "with-meta", r.read_form, meta) - of "@": - discard r.next - result = list(symbol "deref", r.read_form) - - # list - of "(": result = r.read_list - of ")": raise newException(ValueError, "unexpected ')'") - - # vector - of "[": result = r.read_vector - of "]": raise newException(ValueError, "unexpected ']'") - - # hash-map - of "{": result = r.read_hash_map - of "}": raise newException(ValueError, "unexpected '}'") - - # atom - else: result = r.read_atom - -proc read_str*(str: string): MalType = - var r = Reader(tokens: str.tokenize) - if r.tokens.len == 0: - raise newException(Blank, "Blank line") - r.read_form +import options, re, strutils, types + +let + tokenRE = re"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)""" + intRE = re"-?[0-9]+$" + strRE = re"""^"(?:\\.|[^\\"])*"$""" + +type + Blank* = object of Exception + + Reader = object + tokens: seq[string] + position: int + +proc next(r: var Reader): Option[string] = + if r.position < r.tokens.len: + result = r.tokens[r.position].some + inc r.position + +proc peek(r: Reader): Option[string] = + if r.position < r.tokens.len: return r.tokens[r.position].some + +proc tokenize(str: string): seq[string] = + result = @[] + var pos = 0 + while pos < str.len: + var matches: array[2, string] + var len = str.findBounds(tokenRE, matches, pos) + if len.first != -1 and len.last != -1 and len.last >= len.first: + pos = len.last + 1 + if matches[0].len > 0 and matches[0][0] != ';': + result.add matches[0] + else: + inc pos + +proc read_form(r: var Reader): MalType + +proc read_seq(r: var Reader, fr, to: string): seq[MalType] = + result = @[] + var t = r.next + if t.get("") != fr: raise newException(ValueError, "expected '" & fr & "'") + + t = r.peek + while t.get("") != to: + if t.get("") == "": raise newException(ValueError, "expected '" & to & "', got EOF") + result.add r.read_form + t = r.peek + discard r.next + +proc read_list(r: var Reader): MalType = + result = list r.read_seq("(", ")") + +proc read_vector(r: var Reader): MalType = + result = vector r.read_seq("[", "]") + +proc read_hash_map(r: var Reader): MalType = + result = hash_map r.read_seq("{", "}") + +proc read_atom(r: var Reader): MalType = + let t = r.next.get("") + if t.match(intRE): number t.parseInt + elif t[0] == '"': + if not t.match(strRE): + raise newException(ValueError, "expected '\"', got EOF") + str t[1 ..< t.high].multiReplace(("\\\"", "\""), ("\\n", "\n"), ("\\\\", "\\")) + elif t[0] == ':': keyword t[1 .. t.high] + elif t == "nil": nilObj + elif t == "true": trueObj + elif t == "false": falseObj + else: symbol t + +proc read_form(r: var Reader): MalType = + if r.peek.get("")[0] == ';': + discard r.next + return nilObj + case r.peek.get("") + of "'": + discard r.next + result = list(symbol "quote", r.read_form) + of "`": + discard r.next + result = list(symbol "quasiquote", r.read_form) + of "~": + discard r.next + result = list(symbol "unquote", r.read_form) + of "~@": + discard r.next + result = list(symbol "splice-unquote", r.read_form) + of "^": + discard r.next + let meta = r.read_form + result = list(symbol "with-meta", r.read_form, meta) + of "@": + discard r.next + result = list(symbol "deref", r.read_form) + + # list + of "(": result = r.read_list + of ")": raise newException(ValueError, "unexpected ')'") + + # vector + of "[": result = r.read_vector + of "]": raise newException(ValueError, "unexpected ']'") + + # hash-map + of "{": result = r.read_hash_map + of "}": raise newException(ValueError, "unexpected '}'") + + # atom + else: result = r.read_atom + +proc read_str*(str: string): MalType = + var r = Reader(tokens: str.tokenize) + if r.tokens.len == 0: + raise newException(Blank, "Blank line") + r.read_form diff --git a/impls/nim/run b/impls/nim/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/nim/run +++ b/impls/nim/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/nim/step0_repl.nim b/impls/nim/step0_repl.nim index 6ae7d895a0..e48a97dd61 100644 --- a/impls/nim/step0_repl.nim +++ b/impls/nim/step0_repl.nim @@ -1,11 +1,11 @@ -import rdstdin - -proc read(str: string): string = str - -proc eval(ast: string): string = ast - -proc print(exp: string): string = exp - -while true: - let line = readLineFromStdin("user> ") - echo line.read.eval.print +import rdstdin + +proc read(str: string): string = str + +proc eval(ast: string): string = ast + +proc print(exp: string): string = exp + +while true: + let line = readLineFromStdin("user> ") + echo line.read.eval.print diff --git a/impls/nim/step1_read_print.nim b/impls/nim/step1_read_print.nim index 4be58984a4..0d19240a5a 100644 --- a/impls/nim/step1_read_print.nim +++ b/impls/nim/step1_read_print.nim @@ -1,14 +1,14 @@ -import rdstdin, types, reader, printer - -proc read(str: string): MalType = str.read_str - -proc eval(ast: MalType): MalType = ast - -proc print(exp: MalType): string = exp.pr_str - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.read.eval.print - except: - echo getCurrentExceptionMsg() +import rdstdin, types, reader, printer + +proc read(str: string): MalType = str.read_str + +proc eval(ast: MalType): MalType = ast + +proc print(exp: MalType): string = exp.pr_str + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.read.eval.print + except: + echo getCurrentExceptionMsg() diff --git a/impls/nim/step2_eval.nim b/impls/nim/step2_eval.nim index b6b840fffe..24e91bb3ae 100644 --- a/impls/nim/step2_eval.nim +++ b/impls/nim/step2_eval.nim @@ -1,53 +1,53 @@ -import rdstdin, tables, sequtils, types, reader, printer - -proc read(str: string): MalType = str.read_str - -proc eval(ast: MalType, env: Table[string, MalType]): MalType - -proc eval_ast(ast: MalType, env: Table[string, MalType]): MalType = - case ast.kind - of Symbol: - if not env.hasKey(ast.str): - raise newException(ValueError, "'" & ast.str & "' not found") - result = env[ast.str] - of List: - result = list ast.list.mapIt(it.eval(env)) - of Vector: - result = vector ast.list.mapIt(it.eval(env)) - of HashMap: - result = hash_map() - for k, v in ast.hash_map.pairs: - result.hash_map[k] = v.eval(env) - else: - result = ast - -proc eval(ast: MalType, env: Table[string, MalType]): MalType = - case ast.kind - of List: - if ast.list.len == 0: return ast - let el = ast.eval_ast(env) - el.list[0].fun(el.list[1 .. ^1]) - else: - ast.eval_ast(env) - -proc print(exp: MalType): string = exp.pr_str - -template wrapNumberFun(op): untyped = - fun proc(xs: varargs[MalType]): MalType = number op(xs[0].number, xs[1].number) - -let repl_env = toTable({ - "+": wrapNumberFun `+`, - "-": wrapNumberFun `-`, - "*": wrapNumberFun `*`, - "/": wrapNumberFun `div`, -}) - -proc rep(str: string): string = - str.read.eval(repl_env).print - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.rep - except: - echo getCurrentExceptionMsg() +import rdstdin, tables, sequtils, types, reader, printer + +proc read(str: string): MalType = str.read_str + +proc eval(ast: MalType, env: Table[string, MalType]): MalType + +proc eval_ast(ast: MalType, env: Table[string, MalType]): MalType = + case ast.kind + of Symbol: + if not env.hasKey(ast.str): + raise newException(ValueError, "'" & ast.str & "' not found") + result = env[ast.str] + of List: + result = list ast.list.mapIt(it.eval(env)) + of Vector: + result = vector ast.list.mapIt(it.eval(env)) + of HashMap: + result = hash_map() + for k, v in ast.hash_map.pairs: + result.hash_map[k] = v.eval(env) + else: + result = ast + +proc eval(ast: MalType, env: Table[string, MalType]): MalType = + case ast.kind + of List: + if ast.list.len == 0: return ast + let el = ast.eval_ast(env) + el.list[0].fun(el.list[1 .. ^1]) + else: + ast.eval_ast(env) + +proc print(exp: MalType): string = exp.pr_str + +template wrapNumberFun(op): untyped = + fun proc(xs: varargs[MalType]): MalType = number op(xs[0].number, xs[1].number) + +let repl_env = toTable({ + "+": wrapNumberFun `+`, + "-": wrapNumberFun `-`, + "*": wrapNumberFun `*`, + "/": wrapNumberFun `div`, +}) + +proc rep(str: string): string = + str.read.eval(repl_env).print + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.rep + except: + echo getCurrentExceptionMsg() diff --git a/impls/nim/step3_env.nim b/impls/nim/step3_env.nim index 0a9827885f..24da9d76c8 100644 --- a/impls/nim/step3_env.nim +++ b/impls/nim/step3_env.nim @@ -1,71 +1,71 @@ -import rdstdin, tables, sequtils, types, reader, printer, env - -proc read(str: string): MalType = str.read_str - -proc eval(ast: MalType, env: var Env): MalType - -proc eval_ast(ast: MalType, env: var Env): MalType = - case ast.kind - of Symbol: - result = env.get(ast.str) - of List: - result = list ast.list.mapIt(it.eval(env)) - of Vector: - result = vector ast.list.mapIt(it.eval(env)) - of HashMap: - result = hash_map() - for k, v in ast.hash_map.pairs: - result.hash_map[k] = v.eval(env) - else: - result = ast - -proc eval(ast: MalType, env: var Env): MalType = - case ast.kind - of List: - if ast.list.len == 0: return ast - let - a0 = ast.list[0] - a1 = ast.list[1] - a2 = ast.list[2] - - case a0.str - of "def!": - result = env.set(a1.str, a2.eval(env)) - of "let*": - var letEnv: Env - letEnv.deepCopy(env) - case a1.kind - of List, Vector: - for i in countup(0, a1.list.high, 2): - letEnv.set(a1.list[i].str, a1.list[i+1].eval(letEnv)) - else: discard - result = a2.eval(letEnv) - else: - let el = ast.eval_ast(env) - result = el.list[0].fun(el.list[1 .. ^1]) - else: - result = ast.eval_ast(env) - -proc print(exp: MalType): string = exp.pr_str - -template wrapNumberFun(op): untyped = - fun proc(xs: varargs[MalType]): MalType = number op(xs[0].number, xs[1].number) - -var repl_env = initEnv() - -repl_env.set("+", wrapNumberFun(`+`)) -repl_env.set("-", wrapNumberFun(`-`)) -repl_env.set("*", wrapNumberFun(`*`)) -repl_env.set("/", wrapNumberFun(`div`)) -#repl_env.set("/", wrapNumberFun(proc(x,y: int): int = int(x.float / y.float))) - -proc rep(str: string): string = - str.read.eval(repl_env).print - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.rep - except: - echo getCurrentExceptionMsg() - echo getCurrentException().getStackTrace() +import rdstdin, tables, sequtils, types, reader, printer, env + +proc read(str: string): MalType = str.read_str + +proc eval(ast: MalType, env: var Env): MalType + +proc eval_ast(ast: MalType, env: var Env): MalType = + case ast.kind + of Symbol: + result = env.get(ast.str) + of List: + result = list ast.list.mapIt(it.eval(env)) + of Vector: + result = vector ast.list.mapIt(it.eval(env)) + of HashMap: + result = hash_map() + for k, v in ast.hash_map.pairs: + result.hash_map[k] = v.eval(env) + else: + result = ast + +proc eval(ast: MalType, env: var Env): MalType = + case ast.kind + of List: + if ast.list.len == 0: return ast + let + a0 = ast.list[0] + a1 = ast.list[1] + a2 = ast.list[2] + + case a0.str + of "def!": + result = env.set(a1.str, a2.eval(env)) + of "let*": + var letEnv: Env + letEnv.deepCopy(env) + case a1.kind + of List, Vector: + for i in countup(0, a1.list.high, 2): + letEnv.set(a1.list[i].str, a1.list[i+1].eval(letEnv)) + else: discard + result = a2.eval(letEnv) + else: + let el = ast.eval_ast(env) + result = el.list[0].fun(el.list[1 .. ^1]) + else: + result = ast.eval_ast(env) + +proc print(exp: MalType): string = exp.pr_str + +template wrapNumberFun(op): untyped = + fun proc(xs: varargs[MalType]): MalType = number op(xs[0].number, xs[1].number) + +var repl_env = initEnv() + +repl_env.set("+", wrapNumberFun(`+`)) +repl_env.set("-", wrapNumberFun(`-`)) +repl_env.set("*", wrapNumberFun(`*`)) +repl_env.set("/", wrapNumberFun(`div`)) +#repl_env.set("/", wrapNumberFun(proc(x,y: int): int = int(x.float / y.float))) + +proc rep(str: string): string = + str.read.eval(repl_env).print + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.rep + except: + echo getCurrentExceptionMsg() + echo getCurrentException().getStackTrace() diff --git a/impls/nim/step4_if_fn_do.nim b/impls/nim/step4_if_fn_do.nim index e7c965aec2..d23335de38 100644 --- a/impls/nim/step4_if_fn_do.nim +++ b/impls/nim/step4_if_fn_do.nim @@ -1,105 +1,105 @@ -import rdstdin, tables, sequtils, types, reader, printer, env, core - -proc read(str: string): MalType = str.read_str - -proc eval(ast: MalType, env: var Env): MalType - -proc eval_ast(ast: MalType, env: var Env): MalType = - case ast.kind - of Symbol: - result = env.get(ast.str) - of List: - result = list ast.list.mapIt(it.eval(env)) - of Vector: - result = vector ast.list.mapIt(it.eval(env)) - of HashMap: - result = hash_map() - for k, v in ast.hash_map.pairs: - result.hash_map[k] = v.eval(env) - else: - result = ast - -proc eval(ast: MalType, env: var Env): MalType = - case ast.kind - of List: - if ast.list.len == 0: return ast - let a0 = ast.list[0] - case a0.kind - of Symbol: - case a0.str - of "def!": - let - a1 = ast.list[1] - a2 = ast.list[2] - result = env.set(a1.str, a2.eval(env)) - - of "let*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var letEnv: Env - letEnv.deepCopy(env) - - case a1.kind - of List, Vector: - for i in countup(0, a1.list.high, 2): - letEnv.set(a1.list[i].str, a1.list[i+1].eval(letEnv)) - else: discard - result = a2.eval(letEnv) - - of "do": - let el = (list ast.list[1 .. ^1]).eval_ast(env) - result = el.list[el.list.high] - - of "if": - let - a1 = ast.list[1] - a2 = ast.list[2] - cond = a1.eval(env) - - if cond.kind in {Nil, False}: - if ast.list.len > 3: result = ast.list[3].eval(env) - else: result = nilObj - else: result = a2.eval(env) - - of "fn*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var env2 = env - result = fun(proc(a: varargs[MalType]): MalType = - var newEnv = initEnv(env2, a1, list(a)) - a2.eval(newEnv)) - - else: - let el = ast.eval_ast(env) - result = el.list[0].fun(el.list[1 .. ^1]) - - else: - let el = ast.eval_ast(env) - result = el.list[0].fun(el.list[1 .. ^1]) - - else: - result = ast.eval_ast(env) - -proc print(exp: MalType): string = exp.pr_str - -var repl_env = initEnv() - -for k, v in ns.items: - repl_env.set(k, v) - -# core.nim: defined using nim -proc rep(str: string): string = - str.read.eval(repl_env).print - -# core.mal: defined using mal itself -discard rep "(def! not (fn* (a) (if a false true)))" - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.rep - except: - echo getCurrentExceptionMsg() - echo getCurrentException().getStackTrace() +import rdstdin, tables, sequtils, types, reader, printer, env, core + +proc read(str: string): MalType = str.read_str + +proc eval(ast: MalType, env: var Env): MalType + +proc eval_ast(ast: MalType, env: var Env): MalType = + case ast.kind + of Symbol: + result = env.get(ast.str) + of List: + result = list ast.list.mapIt(it.eval(env)) + of Vector: + result = vector ast.list.mapIt(it.eval(env)) + of HashMap: + result = hash_map() + for k, v in ast.hash_map.pairs: + result.hash_map[k] = v.eval(env) + else: + result = ast + +proc eval(ast: MalType, env: var Env): MalType = + case ast.kind + of List: + if ast.list.len == 0: return ast + let a0 = ast.list[0] + case a0.kind + of Symbol: + case a0.str + of "def!": + let + a1 = ast.list[1] + a2 = ast.list[2] + result = env.set(a1.str, a2.eval(env)) + + of "let*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var letEnv: Env + letEnv.deepCopy(env) + + case a1.kind + of List, Vector: + for i in countup(0, a1.list.high, 2): + letEnv.set(a1.list[i].str, a1.list[i+1].eval(letEnv)) + else: discard + result = a2.eval(letEnv) + + of "do": + let el = (list ast.list[1 .. ^1]).eval_ast(env) + result = el.list[el.list.high] + + of "if": + let + a1 = ast.list[1] + a2 = ast.list[2] + cond = a1.eval(env) + + if cond.kind in {Nil, False}: + if ast.list.len > 3: result = ast.list[3].eval(env) + else: result = nilObj + else: result = a2.eval(env) + + of "fn*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var env2 = env + result = fun(proc(a: varargs[MalType]): MalType = + var newEnv = initEnv(env2, a1, list(a)) + a2.eval(newEnv)) + + else: + let el = ast.eval_ast(env) + result = el.list[0].fun(el.list[1 .. ^1]) + + else: + let el = ast.eval_ast(env) + result = el.list[0].fun(el.list[1 .. ^1]) + + else: + result = ast.eval_ast(env) + +proc print(exp: MalType): string = exp.pr_str + +var repl_env = initEnv() + +for k, v in ns.items: + repl_env.set(k, v) + +# core.nim: defined using nim +proc rep(str: string): string = + str.read.eval(repl_env).print + +# core.mal: defined using mal itself +discard rep "(def! not (fn* (a) (if a false true)))" + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.rep + except: + echo getCurrentExceptionMsg() + echo getCurrentException().getStackTrace() diff --git a/impls/nim/step5_tco.nim b/impls/nim/step5_tco.nim index 5b93141e02..af83f8c1ca 100644 --- a/impls/nim/step5_tco.nim +++ b/impls/nim/step5_tco.nim @@ -1,117 +1,117 @@ -import rdstdin, tables, sequtils, types, reader, printer, env, core - -proc read(str: string): MalType = str.read_str - -proc eval(ast: MalType, env: Env): MalType - -proc eval_ast(ast: MalType, env: var Env): MalType = - case ast.kind - of Symbol: - result = env.get(ast.str) - of List: - result = list ast.list.mapIt(it.eval(env)) - of Vector: - result = vector ast.list.mapIt(it.eval(env)) - of HashMap: - result = hash_map() - for k, v in ast.hash_map.pairs: - result.hash_map[k] = v.eval(env) - else: - result = ast - -proc eval(ast: MalType, env: Env): MalType = - var ast = ast - var env = env - - template defaultApply = - let el = ast.eval_ast(env) - let f = el.list[0] - case f.kind - of MalFun: - ast = f.malfun.ast - env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) - else: - return f.fun(el.list[1 .. ^1]) - - while true: - if ast.kind != List: return ast.eval_ast(env) - if ast.list.len == 0: return ast - - let a0 = ast.list[0] - case a0.kind - of Symbol: - case a0.str - of "def!": - let - a1 = ast.list[1] - a2 = ast.list[2] - return env.set(a1.str, a2.eval(env)) - - of "let*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var let_env = initEnv(env) - case a1.kind - of List, Vector: - for i in countup(0, a1.list.high, 2): - let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) - else: raise newException(ValueError, "Illegal kind in let*") - ast = a2 - env = let_env - # Continue loop (TCO) - - of "do": - let last = ast.list.high - discard (list ast.list[1 ..< last]).eval_ast(env) - ast = ast.list[last] - # Continue loop (TCO) - - of "if": - let - a1 = ast.list[1] - a2 = ast.list[2] - cond = a1.eval(env) - - if cond.kind in {Nil, False}: - if ast.list.len > 3: ast = ast.list[3] - else: ast = nilObj - else: ast = a2 - - of "fn*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var env2 = env - let fn = proc(a: varargs[MalType]): MalType = - var newEnv = initEnv(env2, a1, list(a)) - a2.eval(newEnv) - return malfun(fn, a2, a1, env) - - else: - defaultApply() - - else: - defaultApply() - -proc print(exp: MalType): string = exp.pr_str - -var repl_env = initEnv() - -for k, v in ns.items: - repl_env.set(k, v) - -# core.nim: defined using nim -proc rep(str: string): string = - str.read.eval(repl_env).print - -# core.mal: defined using mal itself -discard rep "(def! not (fn* (a) (if a false true)))" - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.rep - except: - echo getCurrentExceptionMsg() - echo getCurrentException().getStackTrace() +import rdstdin, tables, sequtils, types, reader, printer, env, core + +proc read(str: string): MalType = str.read_str + +proc eval(ast: MalType, env: Env): MalType + +proc eval_ast(ast: MalType, env: var Env): MalType = + case ast.kind + of Symbol: + result = env.get(ast.str) + of List: + result = list ast.list.mapIt(it.eval(env)) + of Vector: + result = vector ast.list.mapIt(it.eval(env)) + of HashMap: + result = hash_map() + for k, v in ast.hash_map.pairs: + result.hash_map[k] = v.eval(env) + else: + result = ast + +proc eval(ast: MalType, env: Env): MalType = + var ast = ast + var env = env + + template defaultApply = + let el = ast.eval_ast(env) + let f = el.list[0] + case f.kind + of MalFun: + ast = f.malfun.ast + env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) + else: + return f.fun(el.list[1 .. ^1]) + + while true: + if ast.kind != List: return ast.eval_ast(env) + if ast.list.len == 0: return ast + + let a0 = ast.list[0] + case a0.kind + of Symbol: + case a0.str + of "def!": + let + a1 = ast.list[1] + a2 = ast.list[2] + return env.set(a1.str, a2.eval(env)) + + of "let*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var let_env = initEnv(env) + case a1.kind + of List, Vector: + for i in countup(0, a1.list.high, 2): + let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) + else: raise newException(ValueError, "Illegal kind in let*") + ast = a2 + env = let_env + # Continue loop (TCO) + + of "do": + let last = ast.list.high + discard (list ast.list[1 ..< last]).eval_ast(env) + ast = ast.list[last] + # Continue loop (TCO) + + of "if": + let + a1 = ast.list[1] + a2 = ast.list[2] + cond = a1.eval(env) + + if cond.kind in {Nil, False}: + if ast.list.len > 3: ast = ast.list[3] + else: ast = nilObj + else: ast = a2 + + of "fn*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var env2 = env + let fn = proc(a: varargs[MalType]): MalType = + var newEnv = initEnv(env2, a1, list(a)) + a2.eval(newEnv) + return malfun(fn, a2, a1, env) + + else: + defaultApply() + + else: + defaultApply() + +proc print(exp: MalType): string = exp.pr_str + +var repl_env = initEnv() + +for k, v in ns.items: + repl_env.set(k, v) + +# core.nim: defined using nim +proc rep(str: string): string = + str.read.eval(repl_env).print + +# core.mal: defined using mal itself +discard rep "(def! not (fn* (a) (if a false true)))" + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.rep + except: + echo getCurrentExceptionMsg() + echo getCurrentException().getStackTrace() diff --git a/impls/nim/step6_file.nim b/impls/nim/step6_file.nim index f42c7f9afb..f76e3b3781 100644 --- a/impls/nim/step6_file.nim +++ b/impls/nim/step6_file.nim @@ -1,127 +1,127 @@ -import rdstdin, tables, sequtils, os, types, reader, printer, env, core - -proc read(str: string): MalType = str.read_str - -proc eval(ast: MalType, env: Env): MalType - -proc eval_ast(ast: MalType, env: var Env): MalType = - case ast.kind - of Symbol: - result = env.get(ast.str) - of List: - result = list ast.list.mapIt(it.eval(env)) - of Vector: - result = vector ast.list.mapIt(it.eval(env)) - of HashMap: - result = hash_map() - for k, v in ast.hash_map.pairs: - result.hash_map[k] = v.eval(env) - else: - result = ast - -proc eval(ast: MalType, env: Env): MalType = - var ast = ast - var env = env - - template defaultApply = - let el = ast.eval_ast(env) - let f = el.list[0] - case f.kind - of MalFun: - ast = f.malfun.ast - env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) - else: - return f.fun(el.list[1 .. ^1]) - - while true: - if ast.kind != List: return ast.eval_ast(env) - if ast.list.len == 0: return ast - - let a0 = ast.list[0] - case a0.kind - of Symbol: - case a0.str - of "def!": - let - a1 = ast.list[1] - a2 = ast.list[2] - return env.set(a1.str, a2.eval(env)) - - of "let*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var let_env = initEnv(env) - case a1.kind - of List, Vector: - for i in countup(0, a1.list.high, 2): - let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) - else: raise newException(ValueError, "Illegal kind in let*") - ast = a2 - env = let_env - # Continue loop (TCO) - - of "do": - let last = ast.list.high - discard (list ast.list[1 ..< last]).eval_ast(env) - ast = ast.list[last] - # Continue loop (TCO) - - of "if": - let - a1 = ast.list[1] - a2 = ast.list[2] - cond = a1.eval(env) - - if cond.kind in {Nil, False}: - if ast.list.len > 3: ast = ast.list[3] - else: ast = nilObj - else: ast = a2 - - of "fn*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var env2 = env - let fn = proc(a: varargs[MalType]): MalType = - var newEnv = initEnv(env2, a1, list(a)) - a2.eval(newEnv) - return malfun(fn, a2, a1, env) - - else: - defaultApply() - - else: - defaultApply() - -proc print(exp: MalType): string = exp.pr_str - -var repl_env = initEnv() - -for k, v in ns.items: - repl_env.set(k, v) -repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) -var ps = commandLineParams() -repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) - - -# core.nim: defined using nim -proc rep(str: string): string {.discardable.} = - str.read.eval(repl_env).print - -# core.mal: defined using mal itself -rep "(def! not (fn* (a) (if a false true)))" -rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - -if paramCount() >= 1: - rep "(load-file \"" & paramStr(1) & "\")" - quit() - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.rep - except Blank: discard - except: - echo getCurrentExceptionMsg() - echo getCurrentException().getStackTrace() +import rdstdin, tables, sequtils, os, types, reader, printer, env, core + +proc read(str: string): MalType = str.read_str + +proc eval(ast: MalType, env: Env): MalType + +proc eval_ast(ast: MalType, env: var Env): MalType = + case ast.kind + of Symbol: + result = env.get(ast.str) + of List: + result = list ast.list.mapIt(it.eval(env)) + of Vector: + result = vector ast.list.mapIt(it.eval(env)) + of HashMap: + result = hash_map() + for k, v in ast.hash_map.pairs: + result.hash_map[k] = v.eval(env) + else: + result = ast + +proc eval(ast: MalType, env: Env): MalType = + var ast = ast + var env = env + + template defaultApply = + let el = ast.eval_ast(env) + let f = el.list[0] + case f.kind + of MalFun: + ast = f.malfun.ast + env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) + else: + return f.fun(el.list[1 .. ^1]) + + while true: + if ast.kind != List: return ast.eval_ast(env) + if ast.list.len == 0: return ast + + let a0 = ast.list[0] + case a0.kind + of Symbol: + case a0.str + of "def!": + let + a1 = ast.list[1] + a2 = ast.list[2] + return env.set(a1.str, a2.eval(env)) + + of "let*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var let_env = initEnv(env) + case a1.kind + of List, Vector: + for i in countup(0, a1.list.high, 2): + let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) + else: raise newException(ValueError, "Illegal kind in let*") + ast = a2 + env = let_env + # Continue loop (TCO) + + of "do": + let last = ast.list.high + discard (list ast.list[1 ..< last]).eval_ast(env) + ast = ast.list[last] + # Continue loop (TCO) + + of "if": + let + a1 = ast.list[1] + a2 = ast.list[2] + cond = a1.eval(env) + + if cond.kind in {Nil, False}: + if ast.list.len > 3: ast = ast.list[3] + else: ast = nilObj + else: ast = a2 + + of "fn*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var env2 = env + let fn = proc(a: varargs[MalType]): MalType = + var newEnv = initEnv(env2, a1, list(a)) + a2.eval(newEnv) + return malfun(fn, a2, a1, env) + + else: + defaultApply() + + else: + defaultApply() + +proc print(exp: MalType): string = exp.pr_str + +var repl_env = initEnv() + +for k, v in ns.items: + repl_env.set(k, v) +repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) +var ps = commandLineParams() +repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) + + +# core.nim: defined using nim +proc rep(str: string): string {.discardable.} = + str.read.eval(repl_env).print + +# core.mal: defined using mal itself +rep "(def! not (fn* (a) (if a false true)))" +rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + +if paramCount() >= 1: + rep "(load-file \"" & paramStr(1) & "\")" + quit() + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.rep + except Blank: discard + except: + echo getCurrentExceptionMsg() + echo getCurrentException().getStackTrace() diff --git a/impls/nim/step7_quote.nim b/impls/nim/step7_quote.nim index 528a0c47e4..81d6b5976a 100644 --- a/impls/nim/step7_quote.nim +++ b/impls/nim/step7_quote.nim @@ -1,164 +1,164 @@ -import rdstdin, tables, sequtils, os, types, reader, printer, env, core - -proc read(str: string): MalType = str.read_str - -proc quasiquote(ast: MalType): MalType - -proc quasiquote_loop(xs: seq[MalType]): MalType = - result = list() - for i in countdown(xs.high, 0): - var elt = xs[i] - if elt.kind == List and 0 < elt.list.len and elt.list[0] == symbol "splice-unquote": - result = list(symbol "concat", elt.list[1], result) - else: - result = list(symbol "cons", quasiquote(elt), result) - -proc quasiquote(ast: MalType): MalType = - case ast.kind - of List: - if ast.list.len == 2 and ast.list[0] == symbol "unquote": - result = ast.list[1] - else: - result = quasiquote_loop(ast.list) - of Vector: - result = list(symbol "vec", quasiquote_loop(ast.list)) - of Symbol: - result = list(symbol "quote", ast) - of HashMap: - result = list(symbol "quote", ast) - else: - result = ast - -proc eval(ast: MalType, env: Env): MalType - -proc eval_ast(ast: MalType, env: var Env): MalType = - case ast.kind - of Symbol: - result = env.get(ast.str) - of List: - result = list ast.list.mapIt(it.eval(env)) - of Vector: - result = vector ast.list.mapIt(it.eval(env)) - of HashMap: - result = hash_map() - for k, v in ast.hash_map.pairs: - result.hash_map[k] = v.eval(env) - else: - result = ast - -proc eval(ast: MalType, env: Env): MalType = - var ast = ast - var env = env - - template defaultApply = - let el = ast.eval_ast(env) - let f = el.list[0] - case f.kind - of MalFun: - ast = f.malfun.ast - env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) - else: - return f.fun(el.list[1 .. ^1]) - - while true: - if ast.kind != List: return ast.eval_ast(env) - if ast.list.len == 0: return ast - - let a0 = ast.list[0] - case a0.kind - of Symbol: - case a0.str - of "def!": - let - a1 = ast.list[1] - a2 = ast.list[2] - return env.set(a1.str, a2.eval(env)) - - of "let*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var let_env = initEnv(env) - case a1.kind - of List, Vector: - for i in countup(0, a1.list.high, 2): - let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) - else: raise newException(ValueError, "Illegal kind in let*") - ast = a2 - env = let_env - # Continue loop (TCO) - - of "quote": - return ast.list[1] - - of "quasiquoteexpand": - return ast.list[1].quasiquote - - of "quasiquote": - ast = ast.list[1].quasiquote - # Continue loop (TCO) - - of "do": - let last = ast.list.high - discard (list ast.list[1 ..< last]).eval_ast(env) - ast = ast.list[last] - # Continue loop (TCO) - - of "if": - let - a1 = ast.list[1] - a2 = ast.list[2] - cond = a1.eval(env) - - if cond.kind in {Nil, False}: - if ast.list.len > 3: ast = ast.list[3] - else: ast = nilObj - else: ast = a2 - - of "fn*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var env2 = env - let fn = proc(a: varargs[MalType]): MalType = - var newEnv = initEnv(env2, a1, list(a)) - a2.eval(newEnv) - return malfun(fn, a2, a1, env) - - else: - defaultApply() - - else: - defaultApply() - -proc print(exp: MalType): string = exp.pr_str - -var repl_env = initEnv() - -for k, v in ns.items: - repl_env.set(k, v) -repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) -var ps = commandLineParams() -repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) - - -# core.nim: defined using nim -proc rep(str: string): string {.discardable.} = - str.read.eval(repl_env).print - -# core.mal: defined using mal itself -rep "(def! not (fn* (a) (if a false true)))" -rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - -if paramCount() >= 1: - rep "(load-file \"" & paramStr(1) & "\")" - quit() - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.rep - except Blank: discard - except: - echo getCurrentExceptionMsg() - echo getCurrentException().getStackTrace() +import rdstdin, tables, sequtils, os, types, reader, printer, env, core + +proc read(str: string): MalType = str.read_str + +proc quasiquote(ast: MalType): MalType + +proc quasiquote_loop(xs: seq[MalType]): MalType = + result = list() + for i in countdown(xs.high, 0): + var elt = xs[i] + if elt.kind == List and 0 < elt.list.len and elt.list[0] == symbol "splice-unquote": + result = list(symbol "concat", elt.list[1], result) + else: + result = list(symbol "cons", quasiquote(elt), result) + +proc quasiquote(ast: MalType): MalType = + case ast.kind + of List: + if ast.list.len == 2 and ast.list[0] == symbol "unquote": + result = ast.list[1] + else: + result = quasiquote_loop(ast.list) + of Vector: + result = list(symbol "vec", quasiquote_loop(ast.list)) + of Symbol: + result = list(symbol "quote", ast) + of HashMap: + result = list(symbol "quote", ast) + else: + result = ast + +proc eval(ast: MalType, env: Env): MalType + +proc eval_ast(ast: MalType, env: var Env): MalType = + case ast.kind + of Symbol: + result = env.get(ast.str) + of List: + result = list ast.list.mapIt(it.eval(env)) + of Vector: + result = vector ast.list.mapIt(it.eval(env)) + of HashMap: + result = hash_map() + for k, v in ast.hash_map.pairs: + result.hash_map[k] = v.eval(env) + else: + result = ast + +proc eval(ast: MalType, env: Env): MalType = + var ast = ast + var env = env + + template defaultApply = + let el = ast.eval_ast(env) + let f = el.list[0] + case f.kind + of MalFun: + ast = f.malfun.ast + env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) + else: + return f.fun(el.list[1 .. ^1]) + + while true: + if ast.kind != List: return ast.eval_ast(env) + if ast.list.len == 0: return ast + + let a0 = ast.list[0] + case a0.kind + of Symbol: + case a0.str + of "def!": + let + a1 = ast.list[1] + a2 = ast.list[2] + return env.set(a1.str, a2.eval(env)) + + of "let*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var let_env = initEnv(env) + case a1.kind + of List, Vector: + for i in countup(0, a1.list.high, 2): + let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) + else: raise newException(ValueError, "Illegal kind in let*") + ast = a2 + env = let_env + # Continue loop (TCO) + + of "quote": + return ast.list[1] + + of "quasiquoteexpand": + return ast.list[1].quasiquote + + of "quasiquote": + ast = ast.list[1].quasiquote + # Continue loop (TCO) + + of "do": + let last = ast.list.high + discard (list ast.list[1 ..< last]).eval_ast(env) + ast = ast.list[last] + # Continue loop (TCO) + + of "if": + let + a1 = ast.list[1] + a2 = ast.list[2] + cond = a1.eval(env) + + if cond.kind in {Nil, False}: + if ast.list.len > 3: ast = ast.list[3] + else: ast = nilObj + else: ast = a2 + + of "fn*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var env2 = env + let fn = proc(a: varargs[MalType]): MalType = + var newEnv = initEnv(env2, a1, list(a)) + a2.eval(newEnv) + return malfun(fn, a2, a1, env) + + else: + defaultApply() + + else: + defaultApply() + +proc print(exp: MalType): string = exp.pr_str + +var repl_env = initEnv() + +for k, v in ns.items: + repl_env.set(k, v) +repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) +var ps = commandLineParams() +repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) + + +# core.nim: defined using nim +proc rep(str: string): string {.discardable.} = + str.read.eval(repl_env).print + +# core.mal: defined using mal itself +rep "(def! not (fn* (a) (if a false true)))" +rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + +if paramCount() >= 1: + rep "(load-file \"" & paramStr(1) & "\")" + quit() + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.rep + except Blank: discard + except: + echo getCurrentExceptionMsg() + echo getCurrentException().getStackTrace() diff --git a/impls/nim/step8_macros.nim b/impls/nim/step8_macros.nim index bd74ecf146..85aec00cce 100644 --- a/impls/nim/step8_macros.nim +++ b/impls/nim/step8_macros.nim @@ -1,186 +1,186 @@ -import rdstdin, tables, sequtils, os, types, reader, printer, env, core - -proc read(str: string): MalType = str.read_str - -proc quasiquote(ast: MalType): MalType - -proc quasiquote_loop(xs: seq[MalType]): MalType = - result = list() - for i in countdown(xs.high, 0): - var elt = xs[i] - if elt.kind == List and 0 < elt.list.len and elt.list[0] == symbol "splice-unquote": - result = list(symbol "concat", elt.list[1], result) - else: - result = list(symbol "cons", quasiquote(elt), result) - -proc quasiquote(ast: MalType): MalType = - case ast.kind - of List: - if ast.list.len == 2 and ast.list[0] == symbol "unquote": - result = ast.list[1] - else: - result = quasiquote_loop(ast.list) - of Vector: - result = list(symbol "vec", quasiquote_loop(ast.list)) - of Symbol: - result = list(symbol "quote", ast) - of HashMap: - result = list(symbol "quote", ast) - else: - result = ast - -proc is_macro_call(ast: MalType, env: Env): bool = - ast.kind == List and ast.list.len > 0 and ast.list[0].kind == Symbol and - env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro - -proc macroexpand(ast: MalType, env: Env): MalType = - result = ast - while result.is_macro_call(env): - let mac = env.get(result.list[0].str) - result = mac.malfun.fn(result.list[1 .. ^1]).macroexpand(env) - -proc eval(ast: MalType, env: Env): MalType - -proc eval_ast(ast: MalType, env: var Env): MalType = - case ast.kind - of Symbol: - result = env.get(ast.str) - of List: - result = list ast.list.mapIt(it.eval(env)) - of Vector: - result = vector ast.list.mapIt(it.eval(env)) - of HashMap: - result = hash_map() - for k, v in ast.hash_map.pairs: - result.hash_map[k] = v.eval(env) - else: - result = ast - -proc eval(ast: MalType, env: Env): MalType = - var ast = ast - var env = env - - template defaultApply = - let el = ast.eval_ast(env) - let f = el.list[0] - case f.kind - of MalFun: - ast = f.malfun.ast - env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) - else: - return f.fun(el.list[1 .. ^1]) - - while true: - if ast.kind != List: return ast.eval_ast(env) - - ast = ast.macroexpand(env) - if ast.kind != List: return ast.eval_ast(env) - if ast.list.len == 0: return ast - - let a0 = ast.list[0] - case a0.kind - of Symbol: - case a0.str - of "def!": - let - a1 = ast.list[1] - a2 = ast.list[2] - return env.set(a1.str, a2.eval(env)) - - of "let*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var let_env = initEnv(env) - case a1.kind - of List, Vector: - for i in countup(0, a1.list.high, 2): - let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) - else: raise newException(ValueError, "Illegal kind in let*") - ast = a2 - env = let_env - # Continue loop (TCO) - - of "quote": - return ast.list[1] - - of "quasiquoteexpand": - return ast.list[1].quasiquote - - of "quasiquote": - ast = ast.list[1].quasiquote - # Continue loop (TCO) - - of "defmacro!": - var fun = ast.list[2].eval(env) - fun = malfun(fun.malfun.fn, fun.malfun.ast, fun.malfun.params, fun.malfun.env, true) - return env.set(ast.list[1].str, fun) - - of "macroexpand": - return ast.list[1].macroexpand(env) - - of "do": - let last = ast.list.high - discard (list ast.list[1 ..< last]).eval_ast(env) - ast = ast.list[last] - # Continue loop (TCO) - - of "if": - let - a1 = ast.list[1] - a2 = ast.list[2] - cond = a1.eval(env) - - if cond.kind in {Nil, False}: - if ast.list.len > 3: ast = ast.list[3] - else: ast = nilObj - else: ast = a2 - - of "fn*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var env2 = env - let fn = proc(a: varargs[MalType]): MalType = - var newEnv = initEnv(env2, a1, list(a)) - a2.eval(newEnv) - return malfun(fn, a2, a1, env) - - else: - defaultApply() - - else: - defaultApply() - -proc print(exp: MalType): string = exp.pr_str - -var repl_env = initEnv() - -for k, v in ns.items: - repl_env.set(k, v) -repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) -var ps = commandLineParams() -repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) - - -# core.nim: defined using nim -proc rep(str: string): string {.discardable.} = - str.read.eval(repl_env).print - -# core.mal: defined using mal itself -rep "(def! not (fn* (a) (if a false true)))" -rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -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)))))))" - -if paramCount() >= 1: - rep "(load-file \"" & paramStr(1) & "\")" - quit() - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.rep - except Blank: discard - except: - echo getCurrentExceptionMsg() - echo getCurrentException().getStackTrace() +import rdstdin, tables, sequtils, os, types, reader, printer, env, core + +proc read(str: string): MalType = str.read_str + +proc quasiquote(ast: MalType): MalType + +proc quasiquote_loop(xs: seq[MalType]): MalType = + result = list() + for i in countdown(xs.high, 0): + var elt = xs[i] + if elt.kind == List and 0 < elt.list.len and elt.list[0] == symbol "splice-unquote": + result = list(symbol "concat", elt.list[1], result) + else: + result = list(symbol "cons", quasiquote(elt), result) + +proc quasiquote(ast: MalType): MalType = + case ast.kind + of List: + if ast.list.len == 2 and ast.list[0] == symbol "unquote": + result = ast.list[1] + else: + result = quasiquote_loop(ast.list) + of Vector: + result = list(symbol "vec", quasiquote_loop(ast.list)) + of Symbol: + result = list(symbol "quote", ast) + of HashMap: + result = list(symbol "quote", ast) + else: + result = ast + +proc is_macro_call(ast: MalType, env: Env): bool = + ast.kind == List and ast.list.len > 0 and ast.list[0].kind == Symbol and + env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro + +proc macroexpand(ast: MalType, env: Env): MalType = + result = ast + while result.is_macro_call(env): + let mac = env.get(result.list[0].str) + result = mac.malfun.fn(result.list[1 .. ^1]).macroexpand(env) + +proc eval(ast: MalType, env: Env): MalType + +proc eval_ast(ast: MalType, env: var Env): MalType = + case ast.kind + of Symbol: + result = env.get(ast.str) + of List: + result = list ast.list.mapIt(it.eval(env)) + of Vector: + result = vector ast.list.mapIt(it.eval(env)) + of HashMap: + result = hash_map() + for k, v in ast.hash_map.pairs: + result.hash_map[k] = v.eval(env) + else: + result = ast + +proc eval(ast: MalType, env: Env): MalType = + var ast = ast + var env = env + + template defaultApply = + let el = ast.eval_ast(env) + let f = el.list[0] + case f.kind + of MalFun: + ast = f.malfun.ast + env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) + else: + return f.fun(el.list[1 .. ^1]) + + while true: + if ast.kind != List: return ast.eval_ast(env) + + ast = ast.macroexpand(env) + if ast.kind != List: return ast.eval_ast(env) + if ast.list.len == 0: return ast + + let a0 = ast.list[0] + case a0.kind + of Symbol: + case a0.str + of "def!": + let + a1 = ast.list[1] + a2 = ast.list[2] + return env.set(a1.str, a2.eval(env)) + + of "let*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var let_env = initEnv(env) + case a1.kind + of List, Vector: + for i in countup(0, a1.list.high, 2): + let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) + else: raise newException(ValueError, "Illegal kind in let*") + ast = a2 + env = let_env + # Continue loop (TCO) + + of "quote": + return ast.list[1] + + of "quasiquoteexpand": + return ast.list[1].quasiquote + + of "quasiquote": + ast = ast.list[1].quasiquote + # Continue loop (TCO) + + of "defmacro!": + var fun = ast.list[2].eval(env) + fun = malfun(fun.malfun.fn, fun.malfun.ast, fun.malfun.params, fun.malfun.env, true) + return env.set(ast.list[1].str, fun) + + of "macroexpand": + return ast.list[1].macroexpand(env) + + of "do": + let last = ast.list.high + discard (list ast.list[1 ..< last]).eval_ast(env) + ast = ast.list[last] + # Continue loop (TCO) + + of "if": + let + a1 = ast.list[1] + a2 = ast.list[2] + cond = a1.eval(env) + + if cond.kind in {Nil, False}: + if ast.list.len > 3: ast = ast.list[3] + else: ast = nilObj + else: ast = a2 + + of "fn*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var env2 = env + let fn = proc(a: varargs[MalType]): MalType = + var newEnv = initEnv(env2, a1, list(a)) + a2.eval(newEnv) + return malfun(fn, a2, a1, env) + + else: + defaultApply() + + else: + defaultApply() + +proc print(exp: MalType): string = exp.pr_str + +var repl_env = initEnv() + +for k, v in ns.items: + repl_env.set(k, v) +repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) +var ps = commandLineParams() +repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) + + +# core.nim: defined using nim +proc rep(str: string): string {.discardable.} = + str.read.eval(repl_env).print + +# core.mal: defined using mal itself +rep "(def! not (fn* (a) (if a false true)))" +rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +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)))))))" + +if paramCount() >= 1: + rep "(load-file \"" & paramStr(1) & "\")" + quit() + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.rep + except Blank: discard + except: + echo getCurrentExceptionMsg() + echo getCurrentException().getStackTrace() diff --git a/impls/nim/step9_try.nim b/impls/nim/step9_try.nim index 71dbbb0cda..c421778a46 100644 --- a/impls/nim/step9_try.nim +++ b/impls/nim/step9_try.nim @@ -1,209 +1,209 @@ -import rdstdin, tables, sequtils, os, types, reader, printer, env, core - -proc read(str: string): MalType = str.read_str - -proc quasiquote(ast: MalType): MalType - -proc quasiquote_loop(xs: seq[MalType]): MalType = - result = list() - for i in countdown(xs.high, 0): - var elt = xs[i] - if elt.kind == List and 0 < elt.list.len and elt.list[0] == symbol "splice-unquote": - result = list(symbol "concat", elt.list[1], result) - else: - result = list(symbol "cons", quasiquote(elt), result) - -proc quasiquote(ast: MalType): MalType = - case ast.kind - of List: - if ast.list.len == 2 and ast.list[0] == symbol "unquote": - result = ast.list[1] - else: - result = quasiquote_loop(ast.list) - of Vector: - result = list(symbol "vec", quasiquote_loop(ast.list)) - of Symbol: - result = list(symbol "quote", ast) - of HashMap: - result = list(symbol "quote", ast) - else: - result = ast - -proc is_macro_call(ast: MalType, env: Env): bool = - ast.kind == List and ast.list.len > 0 and ast.list[0].kind == Symbol and - env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro - -proc macroexpand(ast: MalType, env: Env): MalType = - result = ast - while result.is_macro_call(env): - let mac = env.get(result.list[0].str) - result = mac.malfun.fn(result.list[1 .. ^1]).macroexpand(env) - -proc eval(ast: MalType, env: Env): MalType - -proc eval_ast(ast: MalType, env: var Env): MalType = - case ast.kind - of Symbol: - result = env.get(ast.str) - of List: - result = list ast.list.mapIt(it.eval(env)) - of Vector: - result = vector ast.list.mapIt(it.eval(env)) - of HashMap: - result = hash_map() - for k, v in ast.hash_map.pairs: - result.hash_map[k] = v.eval(env) - else: - result = ast - -proc eval(ast: MalType, env: Env): MalType = - var ast = ast - var env = env - - template defaultApply = - let el = ast.eval_ast(env) - let f = el.list[0] - case f.kind - of MalFun: - ast = f.malfun.ast - env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) - else: - return f.fun(el.list[1 .. ^1]) - - while true: - if ast.kind != List: return ast.eval_ast(env) - - ast = ast.macroexpand(env) - if ast.kind != List: return ast.eval_ast(env) - if ast.list.len == 0: return ast - - let a0 = ast.list[0] - case a0.kind - of Symbol: - case a0.str - of "def!": - let - a1 = ast.list[1] - a2 = ast.list[2] - res = a2.eval(env) - return env.set(a1.str, res) - - of "let*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var let_env = initEnv(env) - case a1.kind - of List, Vector: - for i in countup(0, a1.list.high, 2): - let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) - else: raise newException(ValueError, "Illegal kind in let*") - ast = a2 - env = let_env - # Continue loop (TCO) - - of "quote": - return ast.list[1] - - of "quasiquoteexpand": - return ast.list[1].quasiquote - - of "quasiquote": - ast = ast.list[1].quasiquote - # Continue loop (TCO) - - of "defmacro!": - var fun = ast.list[2].eval(env) - fun = malfun(fun.malfun.fn, fun.malfun.ast, fun.malfun.params, fun.malfun.env, true) - return env.set(ast.list[1].str, fun) - - of "macroexpand": - return ast.list[1].macroexpand(env) - - of "try*": - let a1 = ast.list[1] - if ast.list.len <= 2: - return a1.eval(env) - let a2 = ast.list[2] - if a2.list[0].str == "catch*": - try: - return a1.eval(env) - except MalError: - let exc = (ref MalError) getCurrentException() - var catchEnv = initEnv(env, list a2.list[1], exc.t) - return a2.list[2].eval(catchEnv) - except: - let exc = getCurrentExceptionMsg() - var catchEnv = initEnv(env, list a2.list[1], list str(exc)) - return a2.list[2].eval(catchEnv) - else: - return a1.eval(env) - - of "do": - let last = ast.list.high - discard (list ast.list[1 ..< last]).eval_ast(env) - ast = ast.list[last] - # Continue loop (TCO) - - of "if": - let - a1 = ast.list[1] - a2 = ast.list[2] - cond = a1.eval(env) - - if cond.kind in {Nil, False}: - if ast.list.len > 3: ast = ast.list[3] - else: ast = nilObj - else: ast = a2 - - of "fn*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var env2 = env - let fn = proc(a: varargs[MalType]): MalType = - var newEnv = initEnv(env2, a1, list(a)) - a2.eval(newEnv) - return malfun(fn, a2, a1, env) - - else: defaultApply() - - else: defaultApply() - -proc print(exp: MalType): string = exp.pr_str - -var repl_env = initEnv() - -for k, v in ns.items: - repl_env.set(k, v) -repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) -var ps = commandLineParams() -repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) - - -# core.nim: defined using nim -proc rep(str: string): string {.discardable.} = - str.read.eval(repl_env).print - -# core.mal: defined using mal itself -rep "(def! not (fn* (a) (if a false true)))" -rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -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)))))))" - -if paramCount() >= 1: - rep "(load-file \"" & paramStr(1) & "\")" - quit() - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.rep - except Blank: discard - except IOError: quit() - except MalError: - let exc = (ref MalError) getCurrentException() - echo "Error: " & exc.t.list[0].pr_str - except: - stdout.write "Error: " - echo getCurrentExceptionMsg() - echo getCurrentException().getStackTrace() +import rdstdin, tables, sequtils, os, types, reader, printer, env, core + +proc read(str: string): MalType = str.read_str + +proc quasiquote(ast: MalType): MalType + +proc quasiquote_loop(xs: seq[MalType]): MalType = + result = list() + for i in countdown(xs.high, 0): + var elt = xs[i] + if elt.kind == List and 0 < elt.list.len and elt.list[0] == symbol "splice-unquote": + result = list(symbol "concat", elt.list[1], result) + else: + result = list(symbol "cons", quasiquote(elt), result) + +proc quasiquote(ast: MalType): MalType = + case ast.kind + of List: + if ast.list.len == 2 and ast.list[0] == symbol "unquote": + result = ast.list[1] + else: + result = quasiquote_loop(ast.list) + of Vector: + result = list(symbol "vec", quasiquote_loop(ast.list)) + of Symbol: + result = list(symbol "quote", ast) + of HashMap: + result = list(symbol "quote", ast) + else: + result = ast + +proc is_macro_call(ast: MalType, env: Env): bool = + ast.kind == List and ast.list.len > 0 and ast.list[0].kind == Symbol and + env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro + +proc macroexpand(ast: MalType, env: Env): MalType = + result = ast + while result.is_macro_call(env): + let mac = env.get(result.list[0].str) + result = mac.malfun.fn(result.list[1 .. ^1]).macroexpand(env) + +proc eval(ast: MalType, env: Env): MalType + +proc eval_ast(ast: MalType, env: var Env): MalType = + case ast.kind + of Symbol: + result = env.get(ast.str) + of List: + result = list ast.list.mapIt(it.eval(env)) + of Vector: + result = vector ast.list.mapIt(it.eval(env)) + of HashMap: + result = hash_map() + for k, v in ast.hash_map.pairs: + result.hash_map[k] = v.eval(env) + else: + result = ast + +proc eval(ast: MalType, env: Env): MalType = + var ast = ast + var env = env + + template defaultApply = + let el = ast.eval_ast(env) + let f = el.list[0] + case f.kind + of MalFun: + ast = f.malfun.ast + env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) + else: + return f.fun(el.list[1 .. ^1]) + + while true: + if ast.kind != List: return ast.eval_ast(env) + + ast = ast.macroexpand(env) + if ast.kind != List: return ast.eval_ast(env) + if ast.list.len == 0: return ast + + let a0 = ast.list[0] + case a0.kind + of Symbol: + case a0.str + of "def!": + let + a1 = ast.list[1] + a2 = ast.list[2] + res = a2.eval(env) + return env.set(a1.str, res) + + of "let*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var let_env = initEnv(env) + case a1.kind + of List, Vector: + for i in countup(0, a1.list.high, 2): + let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) + else: raise newException(ValueError, "Illegal kind in let*") + ast = a2 + env = let_env + # Continue loop (TCO) + + of "quote": + return ast.list[1] + + of "quasiquoteexpand": + return ast.list[1].quasiquote + + of "quasiquote": + ast = ast.list[1].quasiquote + # Continue loop (TCO) + + of "defmacro!": + var fun = ast.list[2].eval(env) + fun = malfun(fun.malfun.fn, fun.malfun.ast, fun.malfun.params, fun.malfun.env, true) + return env.set(ast.list[1].str, fun) + + of "macroexpand": + return ast.list[1].macroexpand(env) + + of "try*": + let a1 = ast.list[1] + if ast.list.len <= 2: + return a1.eval(env) + let a2 = ast.list[2] + if a2.list[0].str == "catch*": + try: + return a1.eval(env) + except MalError: + let exc = (ref MalError) getCurrentException() + var catchEnv = initEnv(env, list a2.list[1], exc.t) + return a2.list[2].eval(catchEnv) + except: + let exc = getCurrentExceptionMsg() + var catchEnv = initEnv(env, list a2.list[1], list str(exc)) + return a2.list[2].eval(catchEnv) + else: + return a1.eval(env) + + of "do": + let last = ast.list.high + discard (list ast.list[1 ..< last]).eval_ast(env) + ast = ast.list[last] + # Continue loop (TCO) + + of "if": + let + a1 = ast.list[1] + a2 = ast.list[2] + cond = a1.eval(env) + + if cond.kind in {Nil, False}: + if ast.list.len > 3: ast = ast.list[3] + else: ast = nilObj + else: ast = a2 + + of "fn*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var env2 = env + let fn = proc(a: varargs[MalType]): MalType = + var newEnv = initEnv(env2, a1, list(a)) + a2.eval(newEnv) + return malfun(fn, a2, a1, env) + + else: defaultApply() + + else: defaultApply() + +proc print(exp: MalType): string = exp.pr_str + +var repl_env = initEnv() + +for k, v in ns.items: + repl_env.set(k, v) +repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) +var ps = commandLineParams() +repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) + + +# core.nim: defined using nim +proc rep(str: string): string {.discardable.} = + str.read.eval(repl_env).print + +# core.mal: defined using mal itself +rep "(def! not (fn* (a) (if a false true)))" +rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +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)))))))" + +if paramCount() >= 1: + rep "(load-file \"" & paramStr(1) & "\")" + quit() + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.rep + except Blank: discard + except IOError: quit() + except MalError: + let exc = (ref MalError) getCurrentException() + echo "Error: " & exc.t.list[0].pr_str + except: + stdout.write "Error: " + echo getCurrentExceptionMsg() + echo getCurrentException().getStackTrace() diff --git a/impls/nim/stepA_mal.nim b/impls/nim/stepA_mal.nim index 76a648e3eb..d89c24a8ba 100644 --- a/impls/nim/stepA_mal.nim +++ b/impls/nim/stepA_mal.nim @@ -1,212 +1,212 @@ -import rdstdin, tables, sequtils, os, types, reader, printer, env, core - -proc read(str: string): MalType = str.read_str - -proc quasiquote(ast: MalType): MalType - -proc quasiquote_loop(xs: seq[MalType]): MalType = - result = list() - for i in countdown(xs.high, 0): - var elt = xs[i] - if elt.kind == List and 0 < elt.list.len and elt.list[0] == symbol "splice-unquote": - result = list(symbol "concat", elt.list[1], result) - else: - result = list(symbol "cons", quasiquote(elt), result) - -proc quasiquote(ast: MalType): MalType = - case ast.kind - of List: - if ast.list.len == 2 and ast.list[0] == symbol "unquote": - result = ast.list[1] - else: - result = quasiquote_loop(ast.list) - of Vector: - result = list(symbol "vec", quasiquote_loop(ast.list)) - of Symbol: - result = list(symbol "quote", ast) - of HashMap: - result = list(symbol "quote", ast) - else: - result = ast - -proc is_macro_call(ast: MalType, env: Env): bool = - ast.kind == List and ast.list.len > 0 and ast.list[0].kind == Symbol and - env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro - -proc macroexpand(ast: MalType, env: Env): MalType = - result = ast - while result.is_macro_call(env): - let mac = env.get(result.list[0].str) - result = mac.malfun.fn(result.list[1 .. ^1]).macroexpand(env) - -proc eval(ast: MalType, env: Env): MalType - -proc eval_ast(ast: MalType, env: var Env): MalType = - case ast.kind - of Symbol: - result = env.get(ast.str) - of List: - result = list ast.list.mapIt(it.eval(env)) - of Vector: - result = vector ast.list.mapIt(it.eval(env)) - of HashMap: - result = hash_map() - for k, v in ast.hash_map.pairs: - result.hash_map[k] = v.eval(env) - else: - result = ast - -proc eval(ast: MalType, env: Env): MalType = - var ast = ast - var env = env - - template defaultApply = - let el = ast.eval_ast(env) - let f = el.list[0] - case f.kind - of MalFun: - ast = f.malfun.ast - env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) - else: - return f.fun(el.list[1 .. ^1]) - - while true: - if ast.kind != List: return ast.eval_ast(env) - - ast = ast.macroexpand(env) - if ast.kind != List: return ast.eval_ast(env) - if ast.list.len == 0: return ast - - let a0 = ast.list[0] - case a0.kind - of Symbol: - case a0.str - of "def!": - let - a1 = ast.list[1] - a2 = ast.list[2] - res = a2.eval(env) - return env.set(a1.str, res) - - of "let*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var let_env = initEnv(env) - case a1.kind - of List, Vector: - for i in countup(0, a1.list.high, 2): - let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) - else: raise newException(ValueError, "Illegal kind in let*") - ast = a2 - env = let_env - # Continue loop (TCO) - - of "quote": - return ast.list[1] - - of "quasiquoteexpand": - return ast.list[1].quasiquote - - of "quasiquote": - ast = ast.list[1].quasiquote - # Continue loop (TCO) - - of "defmacro!": - var fun = ast.list[2].eval(env) - fun = malfun(fun.malfun.fn, fun.malfun.ast, fun.malfun.params, fun.malfun.env, true) - return env.set(ast.list[1].str, fun) - - of "macroexpand": - return ast.list[1].macroexpand(env) - - of "try*": - let a1 = ast.list[1] - if ast.list.len <= 2: - return a1.eval(env) - let a2 = ast.list[2] - if a2.list[0].str == "catch*": - try: - return a1.eval(env) - except MalError: - let exc = (ref MalError) getCurrentException() - var catchEnv = initEnv(env, list a2.list[1], exc.t) - return a2.list[2].eval(catchEnv) - except: - let exc = getCurrentExceptionMsg() - var catchEnv = initEnv(env, list a2.list[1], list str(exc)) - return a2.list[2].eval(catchEnv) - else: - return a1.eval(env) - - of "do": - let last = ast.list.high - discard (list ast.list[1 ..< last]).eval_ast(env) - ast = ast.list[last] - # Continue loop (TCO) - - of "if": - let - a1 = ast.list[1] - a2 = ast.list[2] - cond = a1.eval(env) - - if cond.kind in {Nil, False}: - if ast.list.len > 3: ast = ast.list[3] - else: ast = nilObj - else: ast = a2 - - of "fn*": - let - a1 = ast.list[1] - a2 = ast.list[2] - var env2 = env - let fn = proc(a: varargs[MalType]): MalType = - var newEnv = initEnv(env2, a1, list(a)) - a2.eval(newEnv) - return malfun(fn, a2, a1, env) - - else: defaultApply() - - else: defaultApply() - -proc print(exp: MalType): string = exp.pr_str - -var repl_env = initEnv() - -for k, v in ns.items: - repl_env.set(k, v) -repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) -var ps = commandLineParams() -repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) - - -# core.nim: defined using nim -proc rep(str: string): string {.discardable.} = - str.read.eval(repl_env).print - -# core.mal: defined using mal itself -rep "(def! not (fn* (a) (if a false true)))" -rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -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 "(def! *host-language* \"nim\")" - -if paramCount() >= 1: - rep "(load-file \"" & paramStr(1) & "\")" - quit() - -rep "(println (str \"Mal [\" *host-language* \"]\"))" - -while true: - try: - let line = readLineFromStdin("user> ") - echo line.rep - except Blank: discard - except IOError: quit() - except MalError: - let exc = (ref MalError) getCurrentException() - echo "Error: " & exc.t.list[0].pr_str - except: - stdout.write "Error: " - echo getCurrentExceptionMsg() - echo getCurrentException().getStackTrace() +import rdstdin, tables, sequtils, os, types, reader, printer, env, core + +proc read(str: string): MalType = str.read_str + +proc quasiquote(ast: MalType): MalType + +proc quasiquote_loop(xs: seq[MalType]): MalType = + result = list() + for i in countdown(xs.high, 0): + var elt = xs[i] + if elt.kind == List and 0 < elt.list.len and elt.list[0] == symbol "splice-unquote": + result = list(symbol "concat", elt.list[1], result) + else: + result = list(symbol "cons", quasiquote(elt), result) + +proc quasiquote(ast: MalType): MalType = + case ast.kind + of List: + if ast.list.len == 2 and ast.list[0] == symbol "unquote": + result = ast.list[1] + else: + result = quasiquote_loop(ast.list) + of Vector: + result = list(symbol "vec", quasiquote_loop(ast.list)) + of Symbol: + result = list(symbol "quote", ast) + of HashMap: + result = list(symbol "quote", ast) + else: + result = ast + +proc is_macro_call(ast: MalType, env: Env): bool = + ast.kind == List and ast.list.len > 0 and ast.list[0].kind == Symbol and + env.find(ast.list[0].str) != nil and env.get(ast.list[0].str).fun_is_macro + +proc macroexpand(ast: MalType, env: Env): MalType = + result = ast + while result.is_macro_call(env): + let mac = env.get(result.list[0].str) + result = mac.malfun.fn(result.list[1 .. ^1]).macroexpand(env) + +proc eval(ast: MalType, env: Env): MalType + +proc eval_ast(ast: MalType, env: var Env): MalType = + case ast.kind + of Symbol: + result = env.get(ast.str) + of List: + result = list ast.list.mapIt(it.eval(env)) + of Vector: + result = vector ast.list.mapIt(it.eval(env)) + of HashMap: + result = hash_map() + for k, v in ast.hash_map.pairs: + result.hash_map[k] = v.eval(env) + else: + result = ast + +proc eval(ast: MalType, env: Env): MalType = + var ast = ast + var env = env + + template defaultApply = + let el = ast.eval_ast(env) + let f = el.list[0] + case f.kind + of MalFun: + ast = f.malfun.ast + env = initEnv(f.malfun.env, f.malfun.params, list(el.list[1 .. ^1])) + else: + return f.fun(el.list[1 .. ^1]) + + while true: + if ast.kind != List: return ast.eval_ast(env) + + ast = ast.macroexpand(env) + if ast.kind != List: return ast.eval_ast(env) + if ast.list.len == 0: return ast + + let a0 = ast.list[0] + case a0.kind + of Symbol: + case a0.str + of "def!": + let + a1 = ast.list[1] + a2 = ast.list[2] + res = a2.eval(env) + return env.set(a1.str, res) + + of "let*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var let_env = initEnv(env) + case a1.kind + of List, Vector: + for i in countup(0, a1.list.high, 2): + let_env.set(a1.list[i].str, a1.list[i+1].eval(let_env)) + else: raise newException(ValueError, "Illegal kind in let*") + ast = a2 + env = let_env + # Continue loop (TCO) + + of "quote": + return ast.list[1] + + of "quasiquoteexpand": + return ast.list[1].quasiquote + + of "quasiquote": + ast = ast.list[1].quasiquote + # Continue loop (TCO) + + of "defmacro!": + var fun = ast.list[2].eval(env) + fun = malfun(fun.malfun.fn, fun.malfun.ast, fun.malfun.params, fun.malfun.env, true) + return env.set(ast.list[1].str, fun) + + of "macroexpand": + return ast.list[1].macroexpand(env) + + of "try*": + let a1 = ast.list[1] + if ast.list.len <= 2: + return a1.eval(env) + let a2 = ast.list[2] + if a2.list[0].str == "catch*": + try: + return a1.eval(env) + except MalError: + let exc = (ref MalError) getCurrentException() + var catchEnv = initEnv(env, list a2.list[1], exc.t) + return a2.list[2].eval(catchEnv) + except: + let exc = getCurrentExceptionMsg() + var catchEnv = initEnv(env, list a2.list[1], list str(exc)) + return a2.list[2].eval(catchEnv) + else: + return a1.eval(env) + + of "do": + let last = ast.list.high + discard (list ast.list[1 ..< last]).eval_ast(env) + ast = ast.list[last] + # Continue loop (TCO) + + of "if": + let + a1 = ast.list[1] + a2 = ast.list[2] + cond = a1.eval(env) + + if cond.kind in {Nil, False}: + if ast.list.len > 3: ast = ast.list[3] + else: ast = nilObj + else: ast = a2 + + of "fn*": + let + a1 = ast.list[1] + a2 = ast.list[2] + var env2 = env + let fn = proc(a: varargs[MalType]): MalType = + var newEnv = initEnv(env2, a1, list(a)) + a2.eval(newEnv) + return malfun(fn, a2, a1, env) + + else: defaultApply() + + else: defaultApply() + +proc print(exp: MalType): string = exp.pr_str + +var repl_env = initEnv() + +for k, v in ns.items: + repl_env.set(k, v) +repl_env.set("eval", fun(proc(xs: varargs[MalType]): MalType = eval(xs[0], repl_env))) +var ps = commandLineParams() +repl_env.set("*ARGV*", list((if paramCount() > 1: ps[1..ps.high] else: @[]).map(str))) + + +# core.nim: defined using nim +proc rep(str: string): string {.discardable.} = + str.read.eval(repl_env).print + +# core.mal: defined using mal itself +rep "(def! not (fn* (a) (if a false true)))" +rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" +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 "(def! *host-language* \"nim\")" + +if paramCount() >= 1: + rep "(load-file \"" & paramStr(1) & "\")" + quit() + +rep "(println (str \"Mal [\" *host-language* \"]\"))" + +while true: + try: + let line = readLineFromStdin("user> ") + echo line.rep + except Blank: discard + except IOError: quit() + except MalError: + let exc = (ref MalError) getCurrentException() + echo "Error: " & exc.t.list[0].pr_str + except: + stdout.write "Error: " + echo getCurrentExceptionMsg() + echo getCurrentException().getStackTrace() diff --git a/impls/nim/tests/step5_tco.mal b/impls/nim/tests/step5_tco.mal index 522de3e30e..0b510e2546 100644 --- a/impls/nim/tests/step5_tco.mal +++ b/impls/nim/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Nim: skipping non-TCO recursion -;; Reason: completes at 10,000, unrecoverable segfault 20,000 +;; Nim: skipping non-TCO recursion +;; Reason: completes at 10,000, unrecoverable segfault 20,000 diff --git a/impls/nim/types.nim b/impls/nim/types.nim index 5deae49224..5cd5f0c973 100644 --- a/impls/nim/types.nim +++ b/impls/nim/types.nim @@ -1,161 +1,161 @@ -import tables - -type - MalTypeKind* = enum Nil, True, False, Number, Symbol, String, - List, Vector, HashMap, Fun, MalFun, Atom - - FunType = proc(a: varargs[MalType]): MalType - - MalFunType* = ref object - fn*: FunType - ast*: MalType - params*: MalType - env*: Env - is_macro*: bool - - MalType* = ref object - case kind*: MalTypeKind - of Nil, True, False: nil - of Number: number*: int - of String, Symbol: str*: string - of List, Vector: list*: seq[MalType] - of HashMap: hash_map*: Table[string, MalType] - of Fun: - fun*: FunType - is_macro*: bool - of MalFun: malfun*: MalFunType - of Atom: val*: MalType - - meta*: MalType - - Env* = ref object - data*: Table[string, MalType] - outer*: Env - -let nilObj* = MalType(kind: Nil) -let trueObj* = MalType(kind: True) -let falseObj* = MalType(kind: False) - -proc number*(x: int): MalType = MalType(kind: Number, number: x) - -proc symbol*(x: string): MalType = MalType(kind: Symbol, str: x) - -proc str*(x: string): MalType {.procvar.} = MalType(kind: String, str: x) - -proc keyword*(x: string): MalType = MalType(kind: String, str: "\xff" & x) - -proc atom*(x: MalType): MalType = - result = MalType(kind: Atom) - result.val = x - -proc list*(xs: varargs[MalType]): MalType {.procvar.} = - result = MalType(kind: List, list: newSeq[MalType](xs.len)) - for i, x in xs: result.list[i] = x - -proc vector*(xs: varargs[MalType]): MalType {.procvar.} = - result = MalType(kind: Vector, list: newSeq[MalType](xs.len)) - for i, x in xs: result.list[i] = x - -proc hash_map*(xs: varargs[MalType]): MalType {.procvar.} = - result = MalType(kind: HashMap, hash_map: initTable[string, MalType]()) - for i in countup(0, xs.high, 2): - let s = case xs[i].kind - of String: xs[i].str - else: xs[i].str - result.hash_map[s] = xs[i+1] - -proc fun_is_macro*(x: MalType): bool = - if x.kind == Fun: result = x.is_macro - elif x.kind == MalFun: result = x.malfun.is_macro - else: raise newException(ValueError, "no function") - -proc getFun*(x: MalType): FunType = - if x.kind == Fun: result = x.fun - elif x.kind == MalFun: result = x.malfun.fn - else: raise newException(ValueError, "no function") - -proc fun*(x: proc(xs: varargs[MalType]): MalType, is_macro = false): MalType = - MalType(kind: Fun, fun: x, is_macro: is_macro) - -proc malfun*(fn: auto, ast, params: MalType, - env: Env, is_macro = false): MalType = - MalType(kind: MalFun, malfun: MalFunType(fn: fn, ast: ast, params: params, - env: env, is_macro: is_macro)) - -proc boolObj*(b: bool): MalType = - if b: trueObj else: falseObj - -proc list_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind == List - -proc vector_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind == Vector - -proc seq_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind in {List, Vector} - -proc hash_map_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind == HashMap - -proc empty_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].list.len == 0 - -proc nil_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind == Nil - -proc true_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind == True - -proc false_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind == False - -proc string_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj(xs[0].kind == String and (xs[0].str.len == 0 or xs[0].str[0] != '\xff')) - -proc symbol*(xs: varargs[MalType]): MalType {.procvar.} = - symbol(xs[0].str) - -proc symbol_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind == Symbol - -proc keyword*(xs: varargs[MalType]): MalType {.procvar.} = - if 0 < xs[0].str.len and xs[0].str[0] == '\xff': xs[0] - else: keyword(xs[0].str) - -proc keyword_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj(xs[0].kind == String and xs[0].str.len > 0 and xs[0].str[0] == '\xff') - -proc number_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind == Number - -proc fn_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj((xs[0].kind == MalFun or xs[0].kind == Fun) and not xs[0].fun_is_macro) - -proc macro_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj((xs[0].kind == MalFun or xs[0].kind == Fun) and xs[0].fun_is_macro) - -proc atom*(xs: varargs[MalType]): MalType {.procvar.} = - atom(xs[0]) - -proc atom_q*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0].kind == Atom - -proc count*(xs: varargs[MalType]): MalType {.procvar.} = - number if xs[0].kind == Nil: 0 else: xs[0].list.len - -proc `==`*(x, y: MalType): bool = - if not (x.kind in {List, Vector} and y.kind in {List, Vector}): - if x.kind != y.kind: return false - result = case x.kind - of Nil, True, False: true - of Number: x.number == y.number - of Symbol, String: x.str == y.str - of List, Vector: x.list == y.list - of HashMap: x.hash_map == y.hash_map - of Fun: x.fun == y.fun and - x.is_macro == y.is_macro - of MalFun: x.malfun == y.malfun - of Atom: x.val == y.val - -proc equal*(xs: varargs[MalType]): MalType {.procvar.} = - boolObj xs[0] == xs[1] +import tables + +type + MalTypeKind* = enum Nil, True, False, Number, Symbol, String, + List, Vector, HashMap, Fun, MalFun, Atom + + FunType = proc(a: varargs[MalType]): MalType + + MalFunType* = ref object + fn*: FunType + ast*: MalType + params*: MalType + env*: Env + is_macro*: bool + + MalType* = ref object + case kind*: MalTypeKind + of Nil, True, False: nil + of Number: number*: int + of String, Symbol: str*: string + of List, Vector: list*: seq[MalType] + of HashMap: hash_map*: Table[string, MalType] + of Fun: + fun*: FunType + is_macro*: bool + of MalFun: malfun*: MalFunType + of Atom: val*: MalType + + meta*: MalType + + Env* = ref object + data*: Table[string, MalType] + outer*: Env + +let nilObj* = MalType(kind: Nil) +let trueObj* = MalType(kind: True) +let falseObj* = MalType(kind: False) + +proc number*(x: int): MalType = MalType(kind: Number, number: x) + +proc symbol*(x: string): MalType = MalType(kind: Symbol, str: x) + +proc str*(x: string): MalType {.procvar.} = MalType(kind: String, str: x) + +proc keyword*(x: string): MalType = MalType(kind: String, str: "\xff" & x) + +proc atom*(x: MalType): MalType = + result = MalType(kind: Atom) + result.val = x + +proc list*(xs: varargs[MalType]): MalType {.procvar.} = + result = MalType(kind: List, list: newSeq[MalType](xs.len)) + for i, x in xs: result.list[i] = x + +proc vector*(xs: varargs[MalType]): MalType {.procvar.} = + result = MalType(kind: Vector, list: newSeq[MalType](xs.len)) + for i, x in xs: result.list[i] = x + +proc hash_map*(xs: varargs[MalType]): MalType {.procvar.} = + result = MalType(kind: HashMap, hash_map: initTable[string, MalType]()) + for i in countup(0, xs.high, 2): + let s = case xs[i].kind + of String: xs[i].str + else: xs[i].str + result.hash_map[s] = xs[i+1] + +proc fun_is_macro*(x: MalType): bool = + if x.kind == Fun: result = x.is_macro + elif x.kind == MalFun: result = x.malfun.is_macro + else: raise newException(ValueError, "no function") + +proc getFun*(x: MalType): FunType = + if x.kind == Fun: result = x.fun + elif x.kind == MalFun: result = x.malfun.fn + else: raise newException(ValueError, "no function") + +proc fun*(x: proc(xs: varargs[MalType]): MalType, is_macro = false): MalType = + MalType(kind: Fun, fun: x, is_macro: is_macro) + +proc malfun*(fn: auto, ast, params: MalType, + env: Env, is_macro = false): MalType = + MalType(kind: MalFun, malfun: MalFunType(fn: fn, ast: ast, params: params, + env: env, is_macro: is_macro)) + +proc boolObj*(b: bool): MalType = + if b: trueObj else: falseObj + +proc list_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == List + +proc vector_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == Vector + +proc seq_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind in {List, Vector} + +proc hash_map_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == HashMap + +proc empty_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].list.len == 0 + +proc nil_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == Nil + +proc true_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == True + +proc false_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == False + +proc string_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj(xs[0].kind == String and (xs[0].str.len == 0 or xs[0].str[0] != '\xff')) + +proc symbol*(xs: varargs[MalType]): MalType {.procvar.} = + symbol(xs[0].str) + +proc symbol_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == Symbol + +proc keyword*(xs: varargs[MalType]): MalType {.procvar.} = + if 0 < xs[0].str.len and xs[0].str[0] == '\xff': xs[0] + else: keyword(xs[0].str) + +proc keyword_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj(xs[0].kind == String and xs[0].str.len > 0 and xs[0].str[0] == '\xff') + +proc number_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == Number + +proc fn_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj((xs[0].kind == MalFun or xs[0].kind == Fun) and not xs[0].fun_is_macro) + +proc macro_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj((xs[0].kind == MalFun or xs[0].kind == Fun) and xs[0].fun_is_macro) + +proc atom*(xs: varargs[MalType]): MalType {.procvar.} = + atom(xs[0]) + +proc atom_q*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0].kind == Atom + +proc count*(xs: varargs[MalType]): MalType {.procvar.} = + number if xs[0].kind == Nil: 0 else: xs[0].list.len + +proc `==`*(x, y: MalType): bool = + if not (x.kind in {List, Vector} and y.kind in {List, Vector}): + if x.kind != y.kind: return false + result = case x.kind + of Nil, True, False: true + of Number: x.number == y.number + of Symbol, String: x.str == y.str + of List, Vector: x.list == y.list + of HashMap: x.hash_map == y.hash_map + of Fun: x.fun == y.fun and + x.is_macro == y.is_macro + of MalFun: x.malfun == y.malfun + of Atom: x.val == y.val + +proc equal*(xs: varargs[MalType]): MalType {.procvar.} = + boolObj xs[0] == xs[1] diff --git a/impls/objc/Dockerfile b/impls/objc/Dockerfile index fa7e6788f1..6c96298d93 100644 --- a/impls/objc/Dockerfile +++ b/impls/objc/Dockerfile @@ -1,62 +1,62 @@ -M ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Based on: -# https://blog.tlensing.org/2013/02/24/objective-c-on-linux-setting-up-gnustep-clang-llvm-objective-c-2-0-blocks-runtime-gcd-on-ubuntu-12-04/ - -RUN apt-get -y install build-essential clang libblocksruntime-dev \ - libkqueue-dev libpthread-workqueue-dev gobjc libxml2-dev \ - libjpeg-dev libtiff-dev libpng12-dev libcups2-dev \ - libfreetype6-dev libcairo2-dev libxt-dev libgl1-mesa-dev - -RUN mkdir -p /root/gnustep-dev -RUN cd /root/gnustep-dev && \ - curl http://download.gna.org/gnustep/libobjc2-1.7.tar.bz2 \ - | tar xjf - -RUN cd /root/gnustep-dev && \ - curl ftp://ftp.gnustep.org/pub/gnustep/core/gnustep-make-2.6.7.tar.gz \ - | tar xzf - -RUN cd /root/gnustep-dev && \ - curl ftp://ftp.gnustep.org/pub/gnustep/core/gnustep-base-1.24.8.tar.gz \ - | tar xzf - -RUN cd /root/gnustep-dev && \ - curl ftp://ftp.gnustep.org/pub/gnustep/core/gnustep-gui-0.24.1.tar.gz \ - | tar xzf - -RUN cd /root/gnustep-dev && \ - curl ftp://ftp.gnustep.org/pub/gnustep/core/gnustep-back-0.24.1.tar.gz \ - | tar xzf - - - -# TODO move up -RUN apt-get -y install gnutls-dev libxslt-dev libffi-dev openssl - -ENV CC clang -RUN cd /root/gnustep-dev/libobjc2-1.7 && make && make install -RUN cd /root/gnustep-dev/gnustep-make-2.6.7 && ./configure && make && make install -RUN cd /root/gnustep-dev/gnustep-base-1.24.8 && ./configure && make && make install && ldconfig -RUN cd /root/gnustep-dev/gnustep-gui-0.24.1 && ./configure && make && make install -RUN cd /root/gnustep-dev/gnustep-back-0.24.1 && ./configure && make && make install - -RUN apt-get -y install libdispatch-dev - -ENV HOME /mal +M ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Based on: +# https://blog.tlensing.org/2013/02/24/objective-c-on-linux-setting-up-gnustep-clang-llvm-objective-c-2-0-blocks-runtime-gcd-on-ubuntu-12-04/ + +RUN apt-get -y install build-essential clang libblocksruntime-dev \ + libkqueue-dev libpthread-workqueue-dev gobjc libxml2-dev \ + libjpeg-dev libtiff-dev libpng12-dev libcups2-dev \ + libfreetype6-dev libcairo2-dev libxt-dev libgl1-mesa-dev + +RUN mkdir -p /root/gnustep-dev +RUN cd /root/gnustep-dev && \ + curl http://download.gna.org/gnustep/libobjc2-1.7.tar.bz2 \ + | tar xjf - +RUN cd /root/gnustep-dev && \ + curl ftp://ftp.gnustep.org/pub/gnustep/core/gnustep-make-2.6.7.tar.gz \ + | tar xzf - +RUN cd /root/gnustep-dev && \ + curl ftp://ftp.gnustep.org/pub/gnustep/core/gnustep-base-1.24.8.tar.gz \ + | tar xzf - +RUN cd /root/gnustep-dev && \ + curl ftp://ftp.gnustep.org/pub/gnustep/core/gnustep-gui-0.24.1.tar.gz \ + | tar xzf - +RUN cd /root/gnustep-dev && \ + curl ftp://ftp.gnustep.org/pub/gnustep/core/gnustep-back-0.24.1.tar.gz \ + | tar xzf - + + +# TODO move up +RUN apt-get -y install gnutls-dev libxslt-dev libffi-dev openssl + +ENV CC clang +RUN cd /root/gnustep-dev/libobjc2-1.7 && make && make install +RUN cd /root/gnustep-dev/gnustep-make-2.6.7 && ./configure && make && make install +RUN cd /root/gnustep-dev/gnustep-base-1.24.8 && ./configure && make && make install && ldconfig +RUN cd /root/gnustep-dev/gnustep-gui-0.24.1 && ./configure && make && make install +RUN cd /root/gnustep-dev/gnustep-back-0.24.1 && ./configure && make && make install + +RUN apt-get -y install libdispatch-dev + +ENV HOME /mal diff --git a/impls/objc/Makefile b/impls/objc/Makefile index 7e6fa2a07c..3539015b22 100644 --- a/impls/objc/Makefile +++ b/impls/objc/Makefile @@ -1,50 +1,50 @@ -STEP0_DEPS = mal_readline.c mal_readline.h -STEP1_DEPS = $(STEP0_DEPS) types.h types.m reader.h reader.m printer.h printer.m -STEP2_DEPS = $(STEP1_DEPS) -STEP3_DEPS = $(STEP2_DEPS) env.m -STEP4_DEPS = $(STEP3_DEPS) malfunc.h malfunc.m core.h core.m - -STEPS = step0_repl step1_read_print step2_eval step3_env \ - step4_if_fn_do step5_tco step6_file step7_quote \ - step8_macros step9_try stepA_mal - -# From: https://blog.tlensing.org/2013/02/24/objective-c-on-linux-setting-up-gnustep-clang-llvm-objective-c-2-0-blocks-runtime-gcd-on-ubuntu-12-04/: -# clang `gnustep-config --objc-flags` -o main -x objective-c main.m -fconstant-string-class=NSConstantString -fobjc-nonfragile-abi -fblocks -lgnustep-base -lgnustep-gui -ldispatch -I/usr/local/include/GNUstep -L/usr/local/lib/GNUstep - -OS := $(shell uname) - -## Bizzare gnustep-config/make interaction causes make to get run -## during gnustep-config so we need to remove make output -ifeq ($(OS),Darwin) -CC = clang -framework Foundation -OBJC_LIBS := -lobjc -lreadline -else -#CC = clang -fblocks -fobjc-nonfragile-abi -fobjc-arc -CC = clang -fblocks -fobjc-nonfragile-abi -OBJC_FLAGS := $(shell gnustep-config --objc-flags 2>/dev/null | egrep -v "Entering|Leaving") -OBJC_LIBS := $(filter-out -shared-libgcc,$(shell gnustep-config --base-libs 2>/dev/null | egrep -v "Entering|Leaving")) -ldispatch -lreadline -endif - -all: $(STEPS) - -dist: mal - -mal: stepA_mal - cp $< $@ - -step0_repl: $(STEP0_DEPS) -step1_read_print: $(STEP1_DEPS) -step2_eval: $(STEP2_DEPS) -step3_env: $(STEP3_DEPS) -step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) - -step%: step%.m - $(CC) \ - -xobjective-c $(filter-out %.h mal_readline%,$+) \ - -xc mal_readline.c \ - -o $@ \ - $(OBJC_FLAGS) \ - $(OBJC_LIBS) - -clean: - rm -f $(STEPS) *.o *.d mal +STEP0_DEPS = mal_readline.c mal_readline.h +STEP1_DEPS = $(STEP0_DEPS) types.h types.m reader.h reader.m printer.h printer.m +STEP2_DEPS = $(STEP1_DEPS) +STEP3_DEPS = $(STEP2_DEPS) env.m +STEP4_DEPS = $(STEP3_DEPS) malfunc.h malfunc.m core.h core.m + +STEPS = step0_repl step1_read_print step2_eval step3_env \ + step4_if_fn_do step5_tco step6_file step7_quote \ + step8_macros step9_try stepA_mal + +# From: https://blog.tlensing.org/2013/02/24/objective-c-on-linux-setting-up-gnustep-clang-llvm-objective-c-2-0-blocks-runtime-gcd-on-ubuntu-12-04/: +# clang `gnustep-config --objc-flags` -o main -x objective-c main.m -fconstant-string-class=NSConstantString -fobjc-nonfragile-abi -fblocks -lgnustep-base -lgnustep-gui -ldispatch -I/usr/local/include/GNUstep -L/usr/local/lib/GNUstep + +OS := $(shell uname) + +## Bizzare gnustep-config/make interaction causes make to get run +## during gnustep-config so we need to remove make output +ifeq ($(OS),Darwin) +CC = clang -framework Foundation +OBJC_LIBS := -lobjc -lreadline +else +#CC = clang -fblocks -fobjc-nonfragile-abi -fobjc-arc +CC = clang -fblocks -fobjc-nonfragile-abi +OBJC_FLAGS := $(shell gnustep-config --objc-flags 2>/dev/null | egrep -v "Entering|Leaving") +OBJC_LIBS := $(filter-out -shared-libgcc,$(shell gnustep-config --base-libs 2>/dev/null | egrep -v "Entering|Leaving")) -ldispatch -lreadline +endif + +all: $(STEPS) + +dist: mal + +mal: stepA_mal + cp $< $@ + +step0_repl: $(STEP0_DEPS) +step1_read_print: $(STEP1_DEPS) +step2_eval: $(STEP2_DEPS) +step3_env: $(STEP3_DEPS) +step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) + +step%: step%.m + $(CC) \ + -xobjective-c $(filter-out %.h mal_readline%,$+) \ + -xc mal_readline.c \ + -o $@ \ + $(OBJC_FLAGS) \ + $(OBJC_LIBS) + +clean: + rm -f $(STEPS) *.o *.d mal diff --git a/impls/objc/core.h b/impls/objc/core.h index de078bd8a3..9dd9d09134 100644 --- a/impls/objc/core.h +++ b/impls/objc/core.h @@ -1,7 +1,7 @@ -#import - -@interface Core : NSObject - -+ (NSDictionary *)ns; - -@end +#import + +@interface Core : NSObject + ++ (NSDictionary *)ns; + +@end diff --git a/impls/objc/core.m b/impls/objc/core.m index 913b42f823..9754b59701 100644 --- a/impls/objc/core.m +++ b/impls/objc/core.m @@ -1,358 +1,358 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" -#import "malfunc.h" -#import "core.h" -#import - -NSObject * wrap_tf(BOOL val) { - return val ? [MalTrue alloc] : [MalFalse alloc]; -} - -@implementation Core - -+ (NSDictionary *)ns { - return @{ - @"=": ^(NSArray *args){ - return wrap_tf(equal_Q(args[0], args[1])); - }, - @"throw": ^(NSArray *args){ - @throw args[0]; - }, - - @"nil?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[NSNull class]]); - }, - @"true?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[MalTrue class]]); - }, - @"false?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[MalFalse class]]); - }, - @"string?": ^(NSArray *args){ - return wrap_tf(string_Q(args[0])); - }, - @"symbol": ^(NSArray *args){ - return [MalSymbol stringWithString:args[0]]; - }, - @"symbol?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[MalSymbol class]]); - }, - @"keyword": ^(NSArray *args){ - return [NSString stringWithFormat:@"\u029e%@", args[0]]; - }, - @"keyword?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[NSString class]] && - ![args[0] isKindOfClass:[MalSymbol class]] && - !string_Q(args[0])); - }, - @"number?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[NSNumber class]]); - }, - @"fn?": ^(NSArray *args){ - return wrap_tf(block_Q(args[0]) || - ([args[0] isKindOfClass:[MalFunc class]] && ![(MalFunc *)args[0] isMacro])); - }, - @"macro?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[MalFunc class]] && [(MalFunc *)args[0] isMacro]); - }, - - @"pr-str": ^(NSArray *args){ - NSMutableArray * res = [NSMutableArray array]; - for (id e in args) { [res addObject:_pr_str(e,true)]; } - return [res componentsJoinedByString:@" "]; - }, - @"str": ^(NSArray *args){ - NSMutableArray * res = [NSMutableArray array]; - for (id e in args) { [res addObject:_pr_str(e,false)]; } - return [res componentsJoinedByString:@""]; - }, - @"prn": ^(NSArray *args){ - NSMutableArray * res = [NSMutableArray array]; - for (id e in args) { [res addObject:_pr_str(e,true)]; } - printf("%s\n", [[res componentsJoinedByString:@" "] UTF8String]); - fflush(stdout); - return [NSNull alloc]; - }, - @"println": ^(NSArray *args){ - NSMutableArray * res = [NSMutableArray array]; - for (id e in args) { [res addObject:_pr_str(e,false)]; } - printf("%s\n", [[res componentsJoinedByString:@" "] UTF8String]); - fflush(stdout); - return [NSNull alloc]; - }, - @"read-string": ^(NSArray *args){ - return read_str(args[0]); - }, - @"readline": ^(NSArray *args){ - char * rawline = _readline((char *)[(NSString *)args[0] UTF8String]); - if (rawline) { - return (NSObject *)[NSString stringWithUTF8String:rawline]; - } else { - return (NSObject *)[NSNull alloc]; - } - }, - @"slurp": ^(NSArray *args){ - return [NSString stringWithContentsOfFile:args[0] - encoding: NSUTF8StringEncoding - error: NULL]; - }, - - @"<": ^(NSArray *args){ - return wrap_tf([args[0] intValue] < [args[1] intValue]); - }, - @"<=": ^(NSArray *args){ - return wrap_tf([args[0] intValue] <= [args[1] intValue]); - }, - @">": ^(NSArray *args){ - return wrap_tf([args[0] intValue] > [args[1] intValue]); - }, - @">=": ^(NSArray *args){ - return wrap_tf([args[0] intValue] >= [args[1] intValue]); - }, - @"+": ^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] + [args[1] intValue]]; - }, - @"-": ^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] - [args[1] intValue]]; - }, - @"*": ^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] * [args[1] intValue]]; - }, - @"/": ^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] / [args[1] intValue]]; - }, - @"time-ms": ^(NSArray *args){ - long long ms = [[NSDate date] timeIntervalSince1970] * 1000; - return [NSNumber numberWithUnsignedInteger:ms]; - }, - - @"list": ^(NSArray *args){ - return args; - }, - @"list?": ^(NSArray *args){ - return wrap_tf(list_Q(args[0])); - }, - @"vector": ^(NSArray *args){ - return [MalVector fromArray:args]; - }, - @"vector?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[MalVector class]]); - }, - @"hash-map": ^(NSArray *args){ - return hash_map(args); - }, - @"map?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[NSDictionary class]]); - }, - @"assoc": ^(NSArray *args){ - NSDictionary * dict = args[0]; - NSMutableDictionary * new_dict = [[NSMutableDictionary alloc] - initWithDictionary:dict - copyItems:NO]; - return assoc_BANG(new_dict, _rest(args)); - }, - @"dissoc": ^(NSArray *args){ - NSDictionary * dict = args[0]; - NSMutableDictionary * new_dict = [[NSMutableDictionary alloc] - initWithDictionary:dict - copyItems:NO]; - for (NSString * key in _rest(args)) { - [new_dict removeObjectForKey:key]; - } - return new_dict; - }, - @"get": ^(NSArray *args){ - if ([args[0] isKindOfClass:[NSNull class]]) { - return (NSObject *)[NSNull alloc]; - } - NSObject * res = ((NSDictionary *)args[0])[args[1]]; - return res ? res : [NSNull alloc]; - }, - @"contains?": ^(NSArray *args){ - if ([args[0] isKindOfClass:[NSNull class]]) { - return wrap_tf(false); - } - return wrap_tf(((NSDictionary *)args[0])[args[1]] != nil); - }, - @"keys": ^(NSArray *args){ - return [(NSDictionary *)args[0] allKeys]; - }, - @"vals": ^(NSArray *args){ - return [(NSDictionary *)args[0] allValues]; - }, - - @"sequential?": ^(NSArray *args){ - return wrap_tf([args[0] isKindOfClass:[NSArray class]]); - }, - @"cons": ^(NSArray *args){ - NSMutableArray * res = [NSMutableArray array]; - [res addObject:args[0]]; - [res addObjectsFromArray:args[1]]; - return res; - }, - @"concat": ^(NSArray *args){ - NSMutableArray * res = [NSMutableArray array]; - for (NSArray * arr in args) { - [res addObjectsFromArray:arr]; - } - return res; - }, - @"vec": ^(NSArray *args){ - return [MalVector fromArray:args[0]]; - }, - @"nth": ^(NSArray *args){ - NSArray * lst = (NSArray *)args[0]; - int idx = [(NSNumber *)args[1] intValue]; - if (idx < [lst count]) { - return lst[idx]; - } else { - @throw @"nth: index out of range"; - } - }, - @"first": ^(NSArray *args){ - if ([args[0] isKindOfClass:[NSNull class]]) { - return (NSObject *)[NSNull alloc]; - } - NSArray * lst = (NSArray *)args[0]; - if ([lst count] > 0) { - return (NSObject *)lst[0]; - } else { - return (NSObject *)[NSNull alloc]; - } - }, - @"rest": ^(NSArray *args){ - if ([args[0] isKindOfClass:[NSNull class]]) { - return @[]; - } - NSArray * lst = (NSArray *)args[0]; - if ([lst count] > 1) { - return _rest(lst); - } else { - return @[]; - } - }, - @"empty?": ^(NSArray *args){ - if ([args[0] isKindOfClass:[NSNull class]]) { - return wrap_tf(true); - } else { - return wrap_tf([args[0] count] == 0); - } - }, - @"count": ^(NSArray *args){ - if ([args[0] isKindOfClass:[NSNull class]]) { - return @0; - } else { - return [NSNumber numberWithInt:[args[0] count]]; - } - }, - @"apply": ^(NSArray *args){ - NSObject * (^ f)(NSArray *) = args[0]; - NSMutableArray * fargs = [NSMutableArray array]; - if ([args count] > 1) { - NSRange r = NSMakeRange(1, [args count]-2); - [fargs addObjectsFromArray:[args subarrayWithRange:r]]; - } - [fargs addObjectsFromArray:(NSArray *)[args lastObject]]; - return apply(f, fargs); - }, - @"map": ^(NSArray *args){ - NSObject * (^ f)(NSArray *) = args[0]; - NSMutableArray * res = [NSMutableArray array]; - for (NSObject * x in (NSArray *)args[1]) { - [res addObject:apply(f, @[x])]; - } - return res; - }, - @"conj": ^(NSArray *args){ - NSMutableArray * res = [NSMutableArray array]; - if ([args[0] isKindOfClass:[MalVector class]]) { - [res addObjectsFromArray:args[0]]; - [res addObjectsFromArray:_rest(args)]; - return (NSObject *)[MalVector fromArray:res]; - } else { - [res addObjectsFromArray:[[_rest(args) reverseObjectEnumerator] - allObjects]]; - [res addObjectsFromArray:args[0]]; - return (NSObject *)res; - } - }, - @"seq": ^(NSArray *args){ - if (list_Q(args[0])) { - if ([args[0] count] == 0) { return (NSObject *)[NSNull alloc]; } - return (NSObject *)args[0]; - } else if ([args[0] isKindOfClass:[MalVector class]]) { - if ([args[0] count] == 0) { return (NSObject *)[NSNull alloc]; } - return (NSObject *)[NSArray arrayWithArray:args[0]]; - } else if (string_Q(args[0])) { - NSString * str = args[0]; - if ([str length] == 0) { return (NSObject *)[NSNull alloc]; } - NSMutableArray * res = [NSMutableArray array]; - for (int i=0; i < [str length]; i++) { - char c = [str characterAtIndex:i]; - [res addObject:[NSString stringWithFormat:@"%c", c]]; - } - return (NSObject *)res; - } else if ([args[0] isKindOfClass:[NSNull class]]) { - return (NSObject *)args[0]; - } else { - @throw @"seq: called on non-sequence"; - } - }, - - @"meta": ^id (NSArray *args){ - if ([args[0] isKindOfClass:[MalFunc class]]) { - return [(MalFunc *)args[0] meta]; - } else { - id res = objc_getAssociatedObject(args[0], @"meta"); - return res ? res : (NSObject *)[NSNull alloc]; - } - }, - @"with-meta": ^id (NSArray *args){ - if ([args[0] isKindOfClass:[MalFunc class]]) { - MalFunc * cmf = [(MalFunc *)args[0] copy]; - cmf.meta = args[1]; - return cmf; - } else if (!block_Q(args[0])) { - id res = [args[0] copy]; - objc_setAssociatedObject(res, @"meta", args[1], OBJC_ASSOCIATION_RETAIN_NONATOMIC); - return res; - } else { - id (^blk)(NSArray *args) = args[0]; - id (^wrapBlock)(NSArray *args) = ^id (NSArray *args) { return blk(args); }; - id (^res)(NSArray *args) = [wrapBlock copy]; // under mrc: copy to get a malloc block instead of a stack block. - objc_setAssociatedObject(res, @"meta", args[1], OBJC_ASSOCIATION_RETAIN_NONATOMIC); - return res; - } - }, - @"atom": ^(NSArray *args){ - return [MalAtom fromObject:args[0]]; - }, - @"atom?": ^(NSArray *args){ - return wrap_tf(atom_Q(args[0])); - }, - @"deref": ^(NSArray *args){ - return [(MalAtom *)args[0] val]; - }, - @"reset!": ^(NSArray *args){ - MalAtom * atm = (MalAtom *)args[0]; - return atm.val = args[1]; - }, - @"swap!": ^(NSArray *args){ - MalAtom * atm = (MalAtom *)args[0]; - NSObject * (^ f)(NSArray *) = args[1]; - NSMutableArray * fargs = [NSMutableArray array]; - [fargs addObject:atm.val]; - if ([args count] > 2) { - NSRange r = NSMakeRange(2, [args count]-2); - [fargs addObjectsFromArray:[args subarrayWithRange:r]]; - } - return atm.val = apply(f, fargs); - }, - }; -} - -@end +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" +#import "malfunc.h" +#import "core.h" +#import + +NSObject * wrap_tf(BOOL val) { + return val ? [MalTrue alloc] : [MalFalse alloc]; +} + +@implementation Core + ++ (NSDictionary *)ns { + return @{ + @"=": ^(NSArray *args){ + return wrap_tf(equal_Q(args[0], args[1])); + }, + @"throw": ^(NSArray *args){ + @throw args[0]; + }, + + @"nil?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[NSNull class]]); + }, + @"true?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[MalTrue class]]); + }, + @"false?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[MalFalse class]]); + }, + @"string?": ^(NSArray *args){ + return wrap_tf(string_Q(args[0])); + }, + @"symbol": ^(NSArray *args){ + return [MalSymbol stringWithString:args[0]]; + }, + @"symbol?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[MalSymbol class]]); + }, + @"keyword": ^(NSArray *args){ + return [NSString stringWithFormat:@"\u029e%@", args[0]]; + }, + @"keyword?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[NSString class]] && + ![args[0] isKindOfClass:[MalSymbol class]] && + !string_Q(args[0])); + }, + @"number?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[NSNumber class]]); + }, + @"fn?": ^(NSArray *args){ + return wrap_tf(block_Q(args[0]) || + ([args[0] isKindOfClass:[MalFunc class]] && ![(MalFunc *)args[0] isMacro])); + }, + @"macro?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[MalFunc class]] && [(MalFunc *)args[0] isMacro]); + }, + + @"pr-str": ^(NSArray *args){ + NSMutableArray * res = [NSMutableArray array]; + for (id e in args) { [res addObject:_pr_str(e,true)]; } + return [res componentsJoinedByString:@" "]; + }, + @"str": ^(NSArray *args){ + NSMutableArray * res = [NSMutableArray array]; + for (id e in args) { [res addObject:_pr_str(e,false)]; } + return [res componentsJoinedByString:@""]; + }, + @"prn": ^(NSArray *args){ + NSMutableArray * res = [NSMutableArray array]; + for (id e in args) { [res addObject:_pr_str(e,true)]; } + printf("%s\n", [[res componentsJoinedByString:@" "] UTF8String]); + fflush(stdout); + return [NSNull alloc]; + }, + @"println": ^(NSArray *args){ + NSMutableArray * res = [NSMutableArray array]; + for (id e in args) { [res addObject:_pr_str(e,false)]; } + printf("%s\n", [[res componentsJoinedByString:@" "] UTF8String]); + fflush(stdout); + return [NSNull alloc]; + }, + @"read-string": ^(NSArray *args){ + return read_str(args[0]); + }, + @"readline": ^(NSArray *args){ + char * rawline = _readline((char *)[(NSString *)args[0] UTF8String]); + if (rawline) { + return (NSObject *)[NSString stringWithUTF8String:rawline]; + } else { + return (NSObject *)[NSNull alloc]; + } + }, + @"slurp": ^(NSArray *args){ + return [NSString stringWithContentsOfFile:args[0] + encoding: NSUTF8StringEncoding + error: NULL]; + }, + + @"<": ^(NSArray *args){ + return wrap_tf([args[0] intValue] < [args[1] intValue]); + }, + @"<=": ^(NSArray *args){ + return wrap_tf([args[0] intValue] <= [args[1] intValue]); + }, + @">": ^(NSArray *args){ + return wrap_tf([args[0] intValue] > [args[1] intValue]); + }, + @">=": ^(NSArray *args){ + return wrap_tf([args[0] intValue] >= [args[1] intValue]); + }, + @"+": ^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] + [args[1] intValue]]; + }, + @"-": ^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] - [args[1] intValue]]; + }, + @"*": ^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] * [args[1] intValue]]; + }, + @"/": ^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] / [args[1] intValue]]; + }, + @"time-ms": ^(NSArray *args){ + long long ms = [[NSDate date] timeIntervalSince1970] * 1000; + return [NSNumber numberWithUnsignedInteger:ms]; + }, + + @"list": ^(NSArray *args){ + return args; + }, + @"list?": ^(NSArray *args){ + return wrap_tf(list_Q(args[0])); + }, + @"vector": ^(NSArray *args){ + return [MalVector fromArray:args]; + }, + @"vector?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[MalVector class]]); + }, + @"hash-map": ^(NSArray *args){ + return hash_map(args); + }, + @"map?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[NSDictionary class]]); + }, + @"assoc": ^(NSArray *args){ + NSDictionary * dict = args[0]; + NSMutableDictionary * new_dict = [[NSMutableDictionary alloc] + initWithDictionary:dict + copyItems:NO]; + return assoc_BANG(new_dict, _rest(args)); + }, + @"dissoc": ^(NSArray *args){ + NSDictionary * dict = args[0]; + NSMutableDictionary * new_dict = [[NSMutableDictionary alloc] + initWithDictionary:dict + copyItems:NO]; + for (NSString * key in _rest(args)) { + [new_dict removeObjectForKey:key]; + } + return new_dict; + }, + @"get": ^(NSArray *args){ + if ([args[0] isKindOfClass:[NSNull class]]) { + return (NSObject *)[NSNull alloc]; + } + NSObject * res = ((NSDictionary *)args[0])[args[1]]; + return res ? res : [NSNull alloc]; + }, + @"contains?": ^(NSArray *args){ + if ([args[0] isKindOfClass:[NSNull class]]) { + return wrap_tf(false); + } + return wrap_tf(((NSDictionary *)args[0])[args[1]] != nil); + }, + @"keys": ^(NSArray *args){ + return [(NSDictionary *)args[0] allKeys]; + }, + @"vals": ^(NSArray *args){ + return [(NSDictionary *)args[0] allValues]; + }, + + @"sequential?": ^(NSArray *args){ + return wrap_tf([args[0] isKindOfClass:[NSArray class]]); + }, + @"cons": ^(NSArray *args){ + NSMutableArray * res = [NSMutableArray array]; + [res addObject:args[0]]; + [res addObjectsFromArray:args[1]]; + return res; + }, + @"concat": ^(NSArray *args){ + NSMutableArray * res = [NSMutableArray array]; + for (NSArray * arr in args) { + [res addObjectsFromArray:arr]; + } + return res; + }, + @"vec": ^(NSArray *args){ + return [MalVector fromArray:args[0]]; + }, + @"nth": ^(NSArray *args){ + NSArray * lst = (NSArray *)args[0]; + int idx = [(NSNumber *)args[1] intValue]; + if (idx < [lst count]) { + return lst[idx]; + } else { + @throw @"nth: index out of range"; + } + }, + @"first": ^(NSArray *args){ + if ([args[0] isKindOfClass:[NSNull class]]) { + return (NSObject *)[NSNull alloc]; + } + NSArray * lst = (NSArray *)args[0]; + if ([lst count] > 0) { + return (NSObject *)lst[0]; + } else { + return (NSObject *)[NSNull alloc]; + } + }, + @"rest": ^(NSArray *args){ + if ([args[0] isKindOfClass:[NSNull class]]) { + return @[]; + } + NSArray * lst = (NSArray *)args[0]; + if ([lst count] > 1) { + return _rest(lst); + } else { + return @[]; + } + }, + @"empty?": ^(NSArray *args){ + if ([args[0] isKindOfClass:[NSNull class]]) { + return wrap_tf(true); + } else { + return wrap_tf([args[0] count] == 0); + } + }, + @"count": ^(NSArray *args){ + if ([args[0] isKindOfClass:[NSNull class]]) { + return @0; + } else { + return [NSNumber numberWithInt:[args[0] count]]; + } + }, + @"apply": ^(NSArray *args){ + NSObject * (^ f)(NSArray *) = args[0]; + NSMutableArray * fargs = [NSMutableArray array]; + if ([args count] > 1) { + NSRange r = NSMakeRange(1, [args count]-2); + [fargs addObjectsFromArray:[args subarrayWithRange:r]]; + } + [fargs addObjectsFromArray:(NSArray *)[args lastObject]]; + return apply(f, fargs); + }, + @"map": ^(NSArray *args){ + NSObject * (^ f)(NSArray *) = args[0]; + NSMutableArray * res = [NSMutableArray array]; + for (NSObject * x in (NSArray *)args[1]) { + [res addObject:apply(f, @[x])]; + } + return res; + }, + @"conj": ^(NSArray *args){ + NSMutableArray * res = [NSMutableArray array]; + if ([args[0] isKindOfClass:[MalVector class]]) { + [res addObjectsFromArray:args[0]]; + [res addObjectsFromArray:_rest(args)]; + return (NSObject *)[MalVector fromArray:res]; + } else { + [res addObjectsFromArray:[[_rest(args) reverseObjectEnumerator] + allObjects]]; + [res addObjectsFromArray:args[0]]; + return (NSObject *)res; + } + }, + @"seq": ^(NSArray *args){ + if (list_Q(args[0])) { + if ([args[0] count] == 0) { return (NSObject *)[NSNull alloc]; } + return (NSObject *)args[0]; + } else if ([args[0] isKindOfClass:[MalVector class]]) { + if ([args[0] count] == 0) { return (NSObject *)[NSNull alloc]; } + return (NSObject *)[NSArray arrayWithArray:args[0]]; + } else if (string_Q(args[0])) { + NSString * str = args[0]; + if ([str length] == 0) { return (NSObject *)[NSNull alloc]; } + NSMutableArray * res = [NSMutableArray array]; + for (int i=0; i < [str length]; i++) { + char c = [str characterAtIndex:i]; + [res addObject:[NSString stringWithFormat:@"%c", c]]; + } + return (NSObject *)res; + } else if ([args[0] isKindOfClass:[NSNull class]]) { + return (NSObject *)args[0]; + } else { + @throw @"seq: called on non-sequence"; + } + }, + + @"meta": ^id (NSArray *args){ + if ([args[0] isKindOfClass:[MalFunc class]]) { + return [(MalFunc *)args[0] meta]; + } else { + id res = objc_getAssociatedObject(args[0], @"meta"); + return res ? res : (NSObject *)[NSNull alloc]; + } + }, + @"with-meta": ^id (NSArray *args){ + if ([args[0] isKindOfClass:[MalFunc class]]) { + MalFunc * cmf = [(MalFunc *)args[0] copy]; + cmf.meta = args[1]; + return cmf; + } else if (!block_Q(args[0])) { + id res = [args[0] copy]; + objc_setAssociatedObject(res, @"meta", args[1], OBJC_ASSOCIATION_RETAIN_NONATOMIC); + return res; + } else { + id (^blk)(NSArray *args) = args[0]; + id (^wrapBlock)(NSArray *args) = ^id (NSArray *args) { return blk(args); }; + id (^res)(NSArray *args) = [wrapBlock copy]; // under mrc: copy to get a malloc block instead of a stack block. + objc_setAssociatedObject(res, @"meta", args[1], OBJC_ASSOCIATION_RETAIN_NONATOMIC); + return res; + } + }, + @"atom": ^(NSArray *args){ + return [MalAtom fromObject:args[0]]; + }, + @"atom?": ^(NSArray *args){ + return wrap_tf(atom_Q(args[0])); + }, + @"deref": ^(NSArray *args){ + return [(MalAtom *)args[0] val]; + }, + @"reset!": ^(NSArray *args){ + MalAtom * atm = (MalAtom *)args[0]; + return atm.val = args[1]; + }, + @"swap!": ^(NSArray *args){ + MalAtom * atm = (MalAtom *)args[0]; + NSObject * (^ f)(NSArray *) = args[1]; + NSMutableArray * fargs = [NSMutableArray array]; + [fargs addObject:atm.val]; + if ([args count] > 2) { + NSRange r = NSMakeRange(2, [args count]-2); + [fargs addObjectsFromArray:[args subarrayWithRange:r]]; + } + return atm.val = apply(f, fargs); + }, + }; +} + +@end diff --git a/impls/objc/env.h b/impls/objc/env.h index 58437c58d7..e43a5cdd40 100644 --- a/impls/objc/env.h +++ b/impls/objc/env.h @@ -1,3 +1,3 @@ -#import - -// See types.h for Env interface definition +#import + +// See types.h for Env interface definition diff --git a/impls/objc/env.m b/impls/objc/env.m index 3acf102035..04382c3f9c 100644 --- a/impls/objc/env.m +++ b/impls/objc/env.m @@ -1,75 +1,75 @@ -#import - -#import "types.h" -//#import "env.h" - -@implementation Env - -@synthesize data = _data; -@synthesize outer = _outer; - -- (id)initWithBindings:(Env *)outer binds:(NSArray *)binds exprs:(NSArray *)exprs { - self = [super init]; - if (self) { - _outer = outer; - _data = [NSMutableDictionary dictionary]; - - for (int i=0; i < [binds count]; i++) { - if ([(NSString *)binds[i] isEqualTo:@"&"]) { - if ([exprs count] > i) { - NSRange r = NSMakeRange(i, [exprs count] - i); - _data[binds[i+1]] = [exprs subarrayWithRange:r]; - } else { - _data[binds[i+1]] = @[]; - } - break; - } else { - _data[binds[i]] = exprs[i]; - } - } - } - return self; -} - -- (id)initWithOuter:(Env *)outer { - return [self initWithBindings:outer binds:@[] exprs:@[]]; -} - -- (id)init { - return [self initWithBindings:nil binds:@[] exprs:@[]]; -} - -+ (id)fromOuter:(Env *)outer { - return [[Env alloc] initWithOuter:outer]; -} - -+ (id)fromBindings:(Env *)outer binds:(NSArray *)binds exprs:(NSArray *)exprs { - return [[Env alloc] initWithBindings:outer binds:binds exprs:exprs]; -} - -- (NSObject *) set:(MalSymbol *)key val:(NSObject *)val { - _data[key] = val; - return val; -} - -- (Env *) find:(MalSymbol *)key { - if (_data[key]) { - return self; - } else if (_outer) { - Env * e = _outer; - return [e find:key]; - } else { - return nil; - } -} - -- (NSObject *) get:(MalSymbol *)key { - Env * e = [self find:key]; - if (e) { - return e.data[key]; - } else { - @throw [NSString stringWithFormat:@"'%@' not found", key]; - } -} - -@end +#import + +#import "types.h" +//#import "env.h" + +@implementation Env + +@synthesize data = _data; +@synthesize outer = _outer; + +- (id)initWithBindings:(Env *)outer binds:(NSArray *)binds exprs:(NSArray *)exprs { + self = [super init]; + if (self) { + _outer = outer; + _data = [NSMutableDictionary dictionary]; + + for (int i=0; i < [binds count]; i++) { + if ([(NSString *)binds[i] isEqualTo:@"&"]) { + if ([exprs count] > i) { + NSRange r = NSMakeRange(i, [exprs count] - i); + _data[binds[i+1]] = [exprs subarrayWithRange:r]; + } else { + _data[binds[i+1]] = @[]; + } + break; + } else { + _data[binds[i]] = exprs[i]; + } + } + } + return self; +} + +- (id)initWithOuter:(Env *)outer { + return [self initWithBindings:outer binds:@[] exprs:@[]]; +} + +- (id)init { + return [self initWithBindings:nil binds:@[] exprs:@[]]; +} + ++ (id)fromOuter:(Env *)outer { + return [[Env alloc] initWithOuter:outer]; +} + ++ (id)fromBindings:(Env *)outer binds:(NSArray *)binds exprs:(NSArray *)exprs { + return [[Env alloc] initWithBindings:outer binds:binds exprs:exprs]; +} + +- (NSObject *) set:(MalSymbol *)key val:(NSObject *)val { + _data[key] = val; + return val; +} + +- (Env *) find:(MalSymbol *)key { + if (_data[key]) { + return self; + } else if (_outer) { + Env * e = _outer; + return [e find:key]; + } else { + return nil; + } +} + +- (NSObject *) get:(MalSymbol *)key { + Env * e = [self find:key]; + if (e) { + return e.data[key]; + } else { + @throw [NSString stringWithFormat:@"'%@' not found", key]; + } +} + +@end diff --git a/impls/objc/mal_readline.c b/impls/objc/mal_readline.c index 3594a1a0db..162ca7ec20 100644 --- a/impls/objc/mal_readline.c +++ b/impls/objc/mal_readline.c @@ -1,75 +1,75 @@ -#include -#include -#include - -#if USE_READLINE - #include - #include - #include -#else - #include -#endif - -int history_loaded = 0; - -char HISTORY_FILE[] = "~/.mal-history"; - -void load_history() { - if (history_loaded) { return; } - int ret; - char *hf = tilde_expand(HISTORY_FILE); - if (access(hf, F_OK) != -1) { - // TODO: check if file exists first, use non-static path -#if USE_READLINE - ret = read_history(hf); -#else - FILE *fp = fopen(hf, "r"); - char *line = malloc(80); // getline reallocs as necessary - size_t sz = 80; - while ((ret = getline(&line, &sz, fp)) > 0) { - add_history(line); // Add line to in-memory history - } - free(line); - fclose(fp); -#endif - history_loaded = 1; - } - free(hf); -} - -void append_to_history() { - char *hf = tilde_expand(HISTORY_FILE); -#ifdef USE_READLINE - append_history(1, hf); -#else -#if defined(RL_READLINE_VERSION) - HIST_ENTRY *he = history_get(history_base+history_length-1); -#else - // libedit-2 segfaults if we add history_base - HIST_ENTRY *he = history_get(history_length-1); -#endif - FILE *fp = fopen(hf, "a"); - if (fp) { - fprintf(fp, "%s\n", he->line); - fclose(fp); - } -#endif - free(hf); -} - - -// line must be freed by caller -char *_readline (char prompt[]) { - char *line; - - load_history(); - - line = readline(prompt); - if (!line) return NULL; // EOF - add_history(line); // Add input to in-memory history - - append_to_history(); // Flush new line of history to disk - - return line; -} - +#include +#include +#include + +#if USE_READLINE + #include + #include + #include +#else + #include +#endif + +int history_loaded = 0; + +char HISTORY_FILE[] = "~/.mal-history"; + +void load_history() { + if (history_loaded) { return; } + int ret; + char *hf = tilde_expand(HISTORY_FILE); + if (access(hf, F_OK) != -1) { + // TODO: check if file exists first, use non-static path +#if USE_READLINE + ret = read_history(hf); +#else + FILE *fp = fopen(hf, "r"); + char *line = malloc(80); // getline reallocs as necessary + size_t sz = 80; + while ((ret = getline(&line, &sz, fp)) > 0) { + add_history(line); // Add line to in-memory history + } + free(line); + fclose(fp); +#endif + history_loaded = 1; + } + free(hf); +} + +void append_to_history() { + char *hf = tilde_expand(HISTORY_FILE); +#ifdef USE_READLINE + append_history(1, hf); +#else +#if defined(RL_READLINE_VERSION) + HIST_ENTRY *he = history_get(history_base+history_length-1); +#else + // libedit-2 segfaults if we add history_base + HIST_ENTRY *he = history_get(history_length-1); +#endif + FILE *fp = fopen(hf, "a"); + if (fp) { + fprintf(fp, "%s\n", he->line); + fclose(fp); + } +#endif + free(hf); +} + + +// line must be freed by caller +char *_readline (char prompt[]) { + char *line; + + load_history(); + + line = readline(prompt); + if (!line) return NULL; // EOF + add_history(line); // Add input to in-memory history + + append_to_history(); // Flush new line of history to disk + + return line; +} + diff --git a/impls/objc/mal_readline.h b/impls/objc/mal_readline.h index d524f4a0f0..aec67c24ca 100644 --- a/impls/objc/mal_readline.h +++ b/impls/objc/mal_readline.h @@ -1,6 +1,6 @@ -#ifndef __MAL_READLINE__ -#define __MAL_READLINE__ - -char *_readline (char prompt[]); - -#endif +#ifndef __MAL_READLINE__ +#define __MAL_READLINE__ + +char *_readline (char prompt[]); + +#endif diff --git a/impls/objc/malfunc.h b/impls/objc/malfunc.h index 79f772c26a..4307668072 100644 --- a/impls/objc/malfunc.h +++ b/impls/objc/malfunc.h @@ -1,24 +1,24 @@ -#import - -/* -// Forward declaration of Env (see env.h for full interface) -@class Env; -*/ -// Forward declaration of EVAL function -NSObject *EVAL(id ast, id env); - -@interface MalFunc : NSObject - -@property (copy) NSArray * ast; -@property (copy) Env * env; -@property (copy) NSArray * params; -@property BOOL isMacro; -@property (copy) NSObject * meta; - -- (id)init:(NSArray *)ast env:(Env *)env params:(NSArray *)params; - -- (id)apply:(NSArray *)args; - -@end - -NSObject * apply(id f, NSArray *args); +#import + +/* +// Forward declaration of Env (see env.h for full interface) +@class Env; +*/ +// Forward declaration of EVAL function +NSObject *EVAL(id ast, id env); + +@interface MalFunc : NSObject + +@property (copy) NSArray * ast; +@property (copy) Env * env; +@property (copy) NSArray * params; +@property BOOL isMacro; +@property (copy) NSObject * meta; + +- (id)init:(NSArray *)ast env:(Env *)env params:(NSArray *)params; + +- (id)apply:(NSArray *)args; + +@end + +NSObject * apply(id f, NSArray *args); diff --git a/impls/objc/malfunc.m b/impls/objc/malfunc.m index 060c63d72b..df91d0012f 100644 --- a/impls/objc/malfunc.m +++ b/impls/objc/malfunc.m @@ -1,49 +1,49 @@ -#import "types.h" - -#import "malfunc.h" - -@implementation MalFunc - -@synthesize ast = _ast; -@synthesize env = _env; -@synthesize params = _params; -@synthesize isMacro = _isMacro; -@synthesize meta = _meta; - -- (id)init:(NSArray *)ast env:(Env *)env params:(NSArray *)params { - self = [super init]; - if (self) { - _ast = ast; - _env = env; - _params = params; - _isMacro = false; - _meta = [NSNull alloc]; - } - return self; -} - -- (id)apply:(NSArray *)args { - return EVAL(_ast, [Env fromBindings:_env binds:_params exprs:args]); -} - -- (id)copyWithZone:(NSZone *)zone -{ - MalFunc * copy = [[[self class] alloc] init:_ast env:_env params:_params]; - if (copy) { - copy.isMacro = _isMacro; - copy.meta = _meta; - } - return copy; -} - -@end - - -NSObject * apply(id f, NSArray *args) { - if ([f isKindOfClass:[MalFunc class]]) { - return [f apply:args]; - } else { - NSObject * (^ fn)(NSArray *) = f; - return fn(args); - } -} +#import "types.h" + +#import "malfunc.h" + +@implementation MalFunc + +@synthesize ast = _ast; +@synthesize env = _env; +@synthesize params = _params; +@synthesize isMacro = _isMacro; +@synthesize meta = _meta; + +- (id)init:(NSArray *)ast env:(Env *)env params:(NSArray *)params { + self = [super init]; + if (self) { + _ast = ast; + _env = env; + _params = params; + _isMacro = false; + _meta = [NSNull alloc]; + } + return self; +} + +- (id)apply:(NSArray *)args { + return EVAL(_ast, [Env fromBindings:_env binds:_params exprs:args]); +} + +- (id)copyWithZone:(NSZone *)zone +{ + MalFunc * copy = [[[self class] alloc] init:_ast env:_env params:_params]; + if (copy) { + copy.isMacro = _isMacro; + copy.meta = _meta; + } + return copy; +} + +@end + + +NSObject * apply(id f, NSArray *args) { + if ([f isKindOfClass:[MalFunc class]]) { + return [f apply:args]; + } else { + NSObject * (^ fn)(NSArray *) = f; + return fn(args); + } +} diff --git a/impls/objc/printer.h b/impls/objc/printer.h index 19d785dfd9..85317b3e49 100644 --- a/impls/objc/printer.h +++ b/impls/objc/printer.h @@ -1,3 +1,3 @@ -#import - -NSString * _pr_str(NSObject * obj, BOOL print_readably); +#import + +NSString * _pr_str(NSObject * obj, BOOL print_readably); diff --git a/impls/objc/printer.m b/impls/objc/printer.m index c3b93ea3de..582d4af4c7 100644 --- a/impls/objc/printer.m +++ b/impls/objc/printer.m @@ -1,58 +1,58 @@ -#import - -#import "types.h" - -NSString * _pr_str(NSObject * obj, BOOL print_readably) { - //NSLog(@"class: %@", [obj class]); - if ([obj isMemberOfClass:[NSNull class]]) { - return @"nil"; - } else if ([obj isMemberOfClass:[MalTrue class]]) { - return @"true"; - } else if ([obj isMemberOfClass:[MalFalse class]]) { - return @"false"; - } else if ([obj isKindOfClass:[MalSymbol class]]) { - return (NSString *) obj; - } else if ([obj isKindOfClass:[NSString class]]) { - NSString * str = (NSString *)obj; - if ([str length] > 0 && ([str hasPrefix:@"\u029e"])) { - return [NSString stringWithFormat:@":%@", - [str substringWithRange:NSMakeRange(1, [str length]-1)]]; - } else if (print_readably) { - str = [[[(NSString *)obj - stringByReplacingOccurrencesOfString:@"\\" withString:@"\\\\"] - stringByReplacingOccurrencesOfString:@"\"" withString:@"\\\""] - stringByReplacingOccurrencesOfString:@"\n" withString:@"\\n"]; - return [NSString stringWithFormat:@"\"%@\"", str]; - } else { - return [NSString stringWithString:str]; - } - } else if ([obj isKindOfClass:[NSArray class]]) { - NSMutableArray * elems = [NSMutableArray array]; - for (NSObject * elem in (NSArray *)obj) { - [elems addObject:_pr_str(elem, print_readably)]; - } - if ([obj isKindOfClass:[MalVector class]]) { - return [NSString stringWithFormat:@"[%@]", - [elems componentsJoinedByString:@" "]]; - } else { - return [NSString stringWithFormat:@"(%@)", - [elems componentsJoinedByString:@" "]]; - } - } else if ([obj isKindOfClass:[NSDictionary class]]) { - NSDictionary * dict = (NSDictionary *)obj; - NSMutableArray * elems = [NSMutableArray array]; - for (NSString * key in dict) { - [elems addObject:_pr_str(key, print_readably)]; - [elems addObject:_pr_str(dict[key], print_readably)]; - } - return [NSString stringWithFormat:@"{%@}", - [elems componentsJoinedByString:@" "]]; - } else if (block_Q(obj)) { - return @"#"; - } else if (atom_Q(obj)) { - return [NSString stringWithFormat:@"(atom %@)", - _pr_str([(MalAtom *)obj val], print_readably)]; - } else { - return [obj description]; - } -} +#import + +#import "types.h" + +NSString * _pr_str(NSObject * obj, BOOL print_readably) { + //NSLog(@"class: %@", [obj class]); + if ([obj isMemberOfClass:[NSNull class]]) { + return @"nil"; + } else if ([obj isMemberOfClass:[MalTrue class]]) { + return @"true"; + } else if ([obj isMemberOfClass:[MalFalse class]]) { + return @"false"; + } else if ([obj isKindOfClass:[MalSymbol class]]) { + return (NSString *) obj; + } else if ([obj isKindOfClass:[NSString class]]) { + NSString * str = (NSString *)obj; + if ([str length] > 0 && ([str hasPrefix:@"\u029e"])) { + return [NSString stringWithFormat:@":%@", + [str substringWithRange:NSMakeRange(1, [str length]-1)]]; + } else if (print_readably) { + str = [[[(NSString *)obj + stringByReplacingOccurrencesOfString:@"\\" withString:@"\\\\"] + stringByReplacingOccurrencesOfString:@"\"" withString:@"\\\""] + stringByReplacingOccurrencesOfString:@"\n" withString:@"\\n"]; + return [NSString stringWithFormat:@"\"%@\"", str]; + } else { + return [NSString stringWithString:str]; + } + } else if ([obj isKindOfClass:[NSArray class]]) { + NSMutableArray * elems = [NSMutableArray array]; + for (NSObject * elem in (NSArray *)obj) { + [elems addObject:_pr_str(elem, print_readably)]; + } + if ([obj isKindOfClass:[MalVector class]]) { + return [NSString stringWithFormat:@"[%@]", + [elems componentsJoinedByString:@" "]]; + } else { + return [NSString stringWithFormat:@"(%@)", + [elems componentsJoinedByString:@" "]]; + } + } else if ([obj isKindOfClass:[NSDictionary class]]) { + NSDictionary * dict = (NSDictionary *)obj; + NSMutableArray * elems = [NSMutableArray array]; + for (NSString * key in dict) { + [elems addObject:_pr_str(key, print_readably)]; + [elems addObject:_pr_str(dict[key], print_readably)]; + } + return [NSString stringWithFormat:@"{%@}", + [elems componentsJoinedByString:@" "]]; + } else if (block_Q(obj)) { + return @"#"; + } else if (atom_Q(obj)) { + return [NSString stringWithFormat:@"(atom %@)", + _pr_str([(MalAtom *)obj val], print_readably)]; + } else { + return [obj description]; + } +} diff --git a/impls/objc/reader.h b/impls/objc/reader.h index 5e737b047d..ed12a04a59 100644 --- a/impls/objc/reader.h +++ b/impls/objc/reader.h @@ -1,2 +1,2 @@ -NSArray * tokenize(NSString *str); -NSObject * read_str(NSString *str); +NSArray * tokenize(NSString *str); +NSObject * read_str(NSString *str); diff --git a/impls/objc/reader.m b/impls/objc/reader.m index f187b064e4..dc3fe9538a 100644 --- a/impls/objc/reader.m +++ b/impls/objc/reader.m @@ -1,194 +1,194 @@ -#import - -#import "types.h" - -// Only used here, so define interface locally -@interface Reader : NSObject - -- (id)initWithTokens:(NSArray *)toks; -- (id)init; - -- (NSString *) next; -- (NSString *) peek; - -@end - - -@implementation Reader - -NSArray *_tokens; -int _position; - -- (id)initWithTokens:(NSArray *)toks { - self = [super init]; - if (self) { - _tokens = toks; - _position = 0; - } - return self; -} - -- (id)init { - return [self initWithTokens:@[]]; -} - -- (NSString *)next { - _position++; - return _tokens[_position-1]; -} - -- (NSString *)peek { - if ([_tokens count] > _position) { - return _tokens[_position]; - } else { - return nil; - } -} - -@end - - -NSArray * tokenize(NSString *str) { - NSRegularExpression *regex = [NSRegularExpression - regularExpressionWithPattern:@"[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}()'\"`@,;]+)" - options:0 - error:NULL]; - - NSArray *matches = [regex - matchesInString:str - options:0 - range:NSMakeRange(0, [str length])]; - - NSMutableArray * tokens = [NSMutableArray array]; - for (NSTextCheckingResult *match in matches) { - NSString * mstr = [str substringWithRange:[match rangeAtIndex:1]]; - if ([mstr characterAtIndex:0] == ';') { continue; } - [tokens addObject:mstr]; - } - return tokens; -} - -NSObject * read_atom(Reader * rdr) { - NSRegularExpression *regex = [NSRegularExpression - regularExpressionWithPattern:@"(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"((?:[\\\\].|[^\\\\\"])*)\"$|^\"(.*)$|:(.*)|(^[^\"]*$)" - options:0 - error:NULL]; - NSNumberFormatter *numf = [[NSNumberFormatter alloc] init]; - numf.numberStyle = NSNumberFormatterDecimalStyle; - - NSString *token = [rdr next]; - - NSArray *matches = [regex - matchesInString:token - options:0 - range:NSMakeRange(0, [token length])]; - - if ([matches count] > 0) { - - NSTextCheckingResult *match = matches[0]; - if ([match rangeAtIndex:1].location < -1ULL/2) { // integer - return [numf numberFromString:token]; - } else if ([match rangeAtIndex:2].location < -1ULL/2) { // float - return [numf numberFromString:token]; - } else if ([match rangeAtIndex:3].location < -1ULL/2) { // nil - return [NSNull alloc]; - } else if ([match rangeAtIndex:4].location < -1ULL/2) { // true - return [MalTrue alloc]; // TODO: intern - } else if ([match rangeAtIndex:5].location < -1ULL/2) { // false - return [MalFalse alloc]; // TODO: intern - } else if ([match rangeAtIndex:6].location < -1ULL/2) { // string - NSString * str = [token substringWithRange:[match rangeAtIndex:6]]; - return [[[[str - stringByReplacingOccurrencesOfString:@"\\\\" withString:@"\u029e"] - stringByReplacingOccurrencesOfString:@"\\\"" withString:@"\""] - stringByReplacingOccurrencesOfString:@"\\n" withString:@"\n"] - stringByReplacingOccurrencesOfString:@"\u029e" withString:@"\\"]; - } else if ([match rangeAtIndex:7].location < -1ULL/2) { // string - @throw @"read_atom: expected '\"', got EOF"; - } else if ([match rangeAtIndex:8].location < -1ULL/2) { // keyword - return [NSString stringWithFormat:@"\u029e%@", - [token substringWithRange:[match rangeAtIndex:8]]]; - } else if ([match rangeAtIndex:9].location < -1ULL/2) { // symbol - return [MalSymbol stringWithString:token]; - } - } - - @throw @"read_atom: invalid token"; -} - -// Only used locally, so declare here -NSObject * read_form(Reader * rdr); - -NSArray * read_list(Reader * rdr, char start, char end) { - NSString * token = [rdr next]; - NSMutableArray * ast = [NSMutableArray array]; - - if ([token characterAtIndex:0] != start) { - @throw [NSString stringWithFormat:@"expected '%c'", start]; - } - while ((token = [rdr peek]) && ([token characterAtIndex:0] != end)) { - [ast addObject:read_form(rdr)]; - } - if (!token) { - @throw [NSString stringWithFormat:@"expected '%c', got EOF", end]; - } - [rdr next]; - return ast; -} - -NSObject * read_form(Reader * rdr) { - NSString *token = [rdr peek]; - switch ([token characterAtIndex:0]) { - case '\'': [rdr next]; - return @[[MalSymbol stringWithString:@"quote"], - read_form(rdr)]; - case '`': [rdr next]; - return @[[MalSymbol stringWithString:@"quasiquote"], - read_form(rdr)]; - case '~': [rdr next]; - if ([token isEqualToString:@"~@"]) { - return @[[MalSymbol stringWithString:@"splice-unquote"], - read_form(rdr)]; - } else { - return @[[MalSymbol stringWithString:@"unquote"], - read_form(rdr)]; - } - case '^': [rdr next]; - NSObject * meta = read_form(rdr); - return @[[MalSymbol stringWithString:@"with-meta"], - read_form(rdr), - meta]; - case '@': [rdr next]; - return @[[MalSymbol stringWithString:@"deref"], - read_form(rdr)]; - - // lists - case ')': - @throw @"unexpected ')'"; - case '(': - return read_list(rdr, '(', ')'); - - // vectors - case ']': - @throw @"unexpected ']'"; - case '[': - return [MalVector fromArray:read_list(rdr, '[', ']')]; - - // hash maps - case '}': - @throw @"unexpected '}'"; - case '{': - return hash_map(read_list(rdr, '{', '}')); - default: - return read_atom(rdr); - } -} - -NSObject * read_str(NSString *str) { - NSArray * tokens = tokenize(str); - if ([tokens count] == 0) { @throw [NSException exceptionWithName:@"ReaderContinue" - reason:@"empty token" - userInfo:nil]; } - //if ([tokens count] == 0) { @throw [[MalContinue alloc] init]; } - return read_form([[Reader alloc] initWithTokens:tokens]); -} +#import + +#import "types.h" + +// Only used here, so define interface locally +@interface Reader : NSObject + +- (id)initWithTokens:(NSArray *)toks; +- (id)init; + +- (NSString *) next; +- (NSString *) peek; + +@end + + +@implementation Reader + +NSArray *_tokens; +int _position; + +- (id)initWithTokens:(NSArray *)toks { + self = [super init]; + if (self) { + _tokens = toks; + _position = 0; + } + return self; +} + +- (id)init { + return [self initWithTokens:@[]]; +} + +- (NSString *)next { + _position++; + return _tokens[_position-1]; +} + +- (NSString *)peek { + if ([_tokens count] > _position) { + return _tokens[_position]; + } else { + return nil; + } +} + +@end + + +NSArray * tokenize(NSString *str) { + NSRegularExpression *regex = [NSRegularExpression + regularExpressionWithPattern:@"[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}()'\"`@,;]+)" + options:0 + error:NULL]; + + NSArray *matches = [regex + matchesInString:str + options:0 + range:NSMakeRange(0, [str length])]; + + NSMutableArray * tokens = [NSMutableArray array]; + for (NSTextCheckingResult *match in matches) { + NSString * mstr = [str substringWithRange:[match rangeAtIndex:1]]; + if ([mstr characterAtIndex:0] == ';') { continue; } + [tokens addObject:mstr]; + } + return tokens; +} + +NSObject * read_atom(Reader * rdr) { + NSRegularExpression *regex = [NSRegularExpression + regularExpressionWithPattern:@"(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^\"((?:[\\\\].|[^\\\\\"])*)\"$|^\"(.*)$|:(.*)|(^[^\"]*$)" + options:0 + error:NULL]; + NSNumberFormatter *numf = [[NSNumberFormatter alloc] init]; + numf.numberStyle = NSNumberFormatterDecimalStyle; + + NSString *token = [rdr next]; + + NSArray *matches = [regex + matchesInString:token + options:0 + range:NSMakeRange(0, [token length])]; + + if ([matches count] > 0) { + + NSTextCheckingResult *match = matches[0]; + if ([match rangeAtIndex:1].location < -1ULL/2) { // integer + return [numf numberFromString:token]; + } else if ([match rangeAtIndex:2].location < -1ULL/2) { // float + return [numf numberFromString:token]; + } else if ([match rangeAtIndex:3].location < -1ULL/2) { // nil + return [NSNull alloc]; + } else if ([match rangeAtIndex:4].location < -1ULL/2) { // true + return [MalTrue alloc]; // TODO: intern + } else if ([match rangeAtIndex:5].location < -1ULL/2) { // false + return [MalFalse alloc]; // TODO: intern + } else if ([match rangeAtIndex:6].location < -1ULL/2) { // string + NSString * str = [token substringWithRange:[match rangeAtIndex:6]]; + return [[[[str + stringByReplacingOccurrencesOfString:@"\\\\" withString:@"\u029e"] + stringByReplacingOccurrencesOfString:@"\\\"" withString:@"\""] + stringByReplacingOccurrencesOfString:@"\\n" withString:@"\n"] + stringByReplacingOccurrencesOfString:@"\u029e" withString:@"\\"]; + } else if ([match rangeAtIndex:7].location < -1ULL/2) { // string + @throw @"read_atom: expected '\"', got EOF"; + } else if ([match rangeAtIndex:8].location < -1ULL/2) { // keyword + return [NSString stringWithFormat:@"\u029e%@", + [token substringWithRange:[match rangeAtIndex:8]]]; + } else if ([match rangeAtIndex:9].location < -1ULL/2) { // symbol + return [MalSymbol stringWithString:token]; + } + } + + @throw @"read_atom: invalid token"; +} + +// Only used locally, so declare here +NSObject * read_form(Reader * rdr); + +NSArray * read_list(Reader * rdr, char start, char end) { + NSString * token = [rdr next]; + NSMutableArray * ast = [NSMutableArray array]; + + if ([token characterAtIndex:0] != start) { + @throw [NSString stringWithFormat:@"expected '%c'", start]; + } + while ((token = [rdr peek]) && ([token characterAtIndex:0] != end)) { + [ast addObject:read_form(rdr)]; + } + if (!token) { + @throw [NSString stringWithFormat:@"expected '%c', got EOF", end]; + } + [rdr next]; + return ast; +} + +NSObject * read_form(Reader * rdr) { + NSString *token = [rdr peek]; + switch ([token characterAtIndex:0]) { + case '\'': [rdr next]; + return @[[MalSymbol stringWithString:@"quote"], + read_form(rdr)]; + case '`': [rdr next]; + return @[[MalSymbol stringWithString:@"quasiquote"], + read_form(rdr)]; + case '~': [rdr next]; + if ([token isEqualToString:@"~@"]) { + return @[[MalSymbol stringWithString:@"splice-unquote"], + read_form(rdr)]; + } else { + return @[[MalSymbol stringWithString:@"unquote"], + read_form(rdr)]; + } + case '^': [rdr next]; + NSObject * meta = read_form(rdr); + return @[[MalSymbol stringWithString:@"with-meta"], + read_form(rdr), + meta]; + case '@': [rdr next]; + return @[[MalSymbol stringWithString:@"deref"], + read_form(rdr)]; + + // lists + case ')': + @throw @"unexpected ')'"; + case '(': + return read_list(rdr, '(', ')'); + + // vectors + case ']': + @throw @"unexpected ']'"; + case '[': + return [MalVector fromArray:read_list(rdr, '[', ']')]; + + // hash maps + case '}': + @throw @"unexpected '}'"; + case '{': + return hash_map(read_list(rdr, '{', '}')); + default: + return read_atom(rdr); + } +} + +NSObject * read_str(NSString *str) { + NSArray * tokens = tokenize(str); + if ([tokens count] == 0) { @throw [NSException exceptionWithName:@"ReaderContinue" + reason:@"empty token" + userInfo:nil]; } + //if ([tokens count] == 0) { @throw [[MalContinue alloc] init]; } + return read_form([[Reader alloc] initWithTokens:tokens]); +} diff --git a/impls/objc/run b/impls/objc/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/objc/run +++ b/impls/objc/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/objc/step0_repl.m b/impls/objc/step0_repl.m index 16de667c87..709adf23b9 100644 --- a/impls/objc/step0_repl.m +++ b/impls/objc/step0_repl.m @@ -1,38 +1,38 @@ -#import - -#import "mal_readline.h" - -NSString *READ(NSString *str) { - return str; -} - -NSString *EVAL(NSString *ast, NSString *env) { - return ast; -} - -NSString *PRINT(NSString *exp) { - return exp; -} - -NSString *REP(NSString *line) { - return PRINT(EVAL(READ(line), @"")); -} - -int main () { - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - printf("%s\n", [[REP(line) description] UTF8String]); - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" + +NSString *READ(NSString *str) { + return str; +} + +NSString *EVAL(NSString *ast, NSString *env) { + return ast; +} + +NSString *PRINT(NSString *exp) { + return exp; +} + +NSString *REP(NSString *line) { + return PRINT(EVAL(READ(line), @"")); +} + +int main () { + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + printf("%s\n", [[REP(line) description] UTF8String]); + } + + [pool drain]; + +// } +} diff --git a/impls/objc/step1_read_print.m b/impls/objc/step1_read_print.m index 028b9b7f2b..392b332426 100644 --- a/impls/objc/step1_read_print.m +++ b/impls/objc/step1_read_print.m @@ -1,48 +1,48 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" - -NSObject *READ(NSString *str) { - return read_str(str); -} - -NSObject *EVAL(NSObject *ast, NSString *env) { - return ast; -} - -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -NSString *REP(NSString *line) { - return PRINT(EVAL(READ(line), @"")); -} - -int main () { - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" + +NSObject *READ(NSString *str) { + return read_str(str); +} + +NSObject *EVAL(NSObject *ast, NSString *env) { + return ast; +} + +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +NSString *REP(NSString *line) { + return PRINT(EVAL(READ(line), @"")); +} + +int main () { + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/step2_eval.m b/impls/objc/step2_eval.m index e07934ddac..c85d486aca 100644 --- a/impls/objc/step2_eval.m +++ b/impls/objc/step2_eval.m @@ -1,111 +1,111 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" - -// read -NSObject *READ(NSString *str) { - return read_str(str); -} - -// eval - -// forward declaration -NSObject *EVAL(NSObject *ast, NSDictionary *env); - -NSObject *eval_ast(NSObject *ast, NSDictionary *env) { - if ([ast isMemberOfClass:[MalSymbol class]]) { - if ([env objectForKey:ast]) { - return env[ast]; - } else { - @throw [NSString stringWithFormat:@"'%@' not found", ast]; - } - } else if ([ast isKindOfClass:[NSArray class]]) { - NSMutableArray *newLst = [NSMutableArray array]; - for (NSObject * x in (NSArray *)ast) { - [newLst addObject:EVAL(x, env)]; - } - if ([ast isKindOfClass:[MalVector class]]) { - return [MalVector fromArray:newLst]; - } else { - return newLst; - } - } else if ([ast isKindOfClass:[NSDictionary class]]) { - NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; - for (NSString * k in (NSDictionary *)ast) { - newDict[k] = EVAL(((NSDictionary *)ast)[k], env); - } - return newDict; - } else { - return ast; - } -} - -NSObject *EVAL(NSObject *ast, NSDictionary *env) { - //NSLog(@"EVAL: %@", ast); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - if ([(NSArray *)ast count] == 0) { - return ast; - } - NSArray * el = (NSArray *) eval_ast(ast, env); - NSObject * (^ f)(NSArray *) = el[0]; - NSArray * args = _rest(el); - return f(args); -} - -// print -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -// REPL -NSString *REP(NSString *line, NSDictionary *env) { - return PRINT(EVAL(READ(line), env)); -} - -int main () { - NSDictionary * repl_env = @{ - @"+": ^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] + [args[1] intValue]]; - }, - @"-": ^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] - [args[1] intValue]]; - }, - @"*": ^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] * [args[1] intValue]]; - }, - @"/": ^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] / [args[1] intValue]]; - }, - }; - - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line, repl_env) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" + +// read +NSObject *READ(NSString *str) { + return read_str(str); +} + +// eval + +// forward declaration +NSObject *EVAL(NSObject *ast, NSDictionary *env); + +NSObject *eval_ast(NSObject *ast, NSDictionary *env) { + if ([ast isMemberOfClass:[MalSymbol class]]) { + if ([env objectForKey:ast]) { + return env[ast]; + } else { + @throw [NSString stringWithFormat:@"'%@' not found", ast]; + } + } else if ([ast isKindOfClass:[NSArray class]]) { + NSMutableArray *newLst = [NSMutableArray array]; + for (NSObject * x in (NSArray *)ast) { + [newLst addObject:EVAL(x, env)]; + } + if ([ast isKindOfClass:[MalVector class]]) { + return [MalVector fromArray:newLst]; + } else { + return newLst; + } + } else if ([ast isKindOfClass:[NSDictionary class]]) { + NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; + for (NSString * k in (NSDictionary *)ast) { + newDict[k] = EVAL(((NSDictionary *)ast)[k], env); + } + return newDict; + } else { + return ast; + } +} + +NSObject *EVAL(NSObject *ast, NSDictionary *env) { + //NSLog(@"EVAL: %@", ast); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + if ([(NSArray *)ast count] == 0) { + return ast; + } + NSArray * el = (NSArray *) eval_ast(ast, env); + NSObject * (^ f)(NSArray *) = el[0]; + NSArray * args = _rest(el); + return f(args); +} + +// print +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +// REPL +NSString *REP(NSString *line, NSDictionary *env) { + return PRINT(EVAL(READ(line), env)); +} + +int main () { + NSDictionary * repl_env = @{ + @"+": ^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] + [args[1] intValue]]; + }, + @"-": ^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] - [args[1] intValue]]; + }, + @"*": ^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] * [args[1] intValue]]; + }, + @"/": ^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] / [args[1] intValue]]; + }, + }; + + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line, repl_env) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/step3_env.m b/impls/objc/step3_env.m index 8ee4286eef..3bacf73475 100644 --- a/impls/objc/step3_env.m +++ b/impls/objc/step3_env.m @@ -1,124 +1,124 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" -#import "env.h" - -// read -NSObject *READ(NSString *str) { - return read_str(str); -} - -// eval - -// forward declaration -NSObject *EVAL(NSObject *ast, Env *env); - -NSObject *eval_ast(NSObject *ast, Env *env) { - if ([ast isMemberOfClass:[MalSymbol class]]) { - return [env get:(MalSymbol *)ast]; - } else if ([ast isKindOfClass:[NSArray class]]) { - NSMutableArray *newLst = [NSMutableArray array]; - for (NSObject * x in (NSArray *)ast) { - [newLst addObject:EVAL(x, env)]; - } - if ([ast isKindOfClass:[MalVector class]]) { - return [MalVector fromArray:newLst]; - } else { - return newLst; - } - } else if ([ast isKindOfClass:[NSDictionary class]]) { - NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; - for (NSString * k in (NSDictionary *)ast) { - newDict[k] = EVAL(((NSDictionary *)ast)[k], env); - } - return newDict; - } else { - return ast; - } -} - -NSObject *EVAL(NSObject *ast, Env *env) { - //NSLog(@"EVAL: %@", ast); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - if ([(NSArray *)ast count] == 0) { - return ast; - } - NSArray * alst = (NSArray *)ast; - id a0 = alst[0]; - if (![a0 isKindOfClass:[MalSymbol class]]) { - @throw @"attempt to apply on non-symbol"; - } - if ([(NSString *)a0 isEqualTo:@"def!"]) { - return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; - } else if ([(NSString *)a0 isEqualTo:@"let*"]) { - Env *let_env = [Env fromOuter:env]; - NSArray * binds = (NSArray *)alst[1]; - for (int i=0; i < [binds count]; i+=2) { - [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; - } - return EVAL(alst[2], let_env); - } else { - NSArray * el = (NSArray *) eval_ast(ast, env); - NSObject * (^ f)(NSArray *) = el[0]; - NSArray * args = _rest(el); - return f(args); - } -} - -// print -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -// REPL -NSString *REP(NSString *line, Env *env) { - return PRINT(EVAL(READ(line), env)); -} - -int main () { - Env * repl_env = [[Env alloc] init]; - - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - [repl_env set:(MalSymbol *)@"+" val:^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] + [args[1] intValue]]; - }]; - [repl_env set:(MalSymbol *)@"-" val:^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] - [args[1] intValue]]; - }]; - [repl_env set:(MalSymbol *)@"*" val:^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] * [args[1] intValue]]; - }]; - [repl_env set:(MalSymbol *)@"/" val:^(NSArray *args){ - return [NSNumber numberWithInt:[args[0] intValue] / [args[1] intValue]]; - }]; - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line, repl_env) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" +#import "env.h" + +// read +NSObject *READ(NSString *str) { + return read_str(str); +} + +// eval + +// forward declaration +NSObject *EVAL(NSObject *ast, Env *env); + +NSObject *eval_ast(NSObject *ast, Env *env) { + if ([ast isMemberOfClass:[MalSymbol class]]) { + return [env get:(MalSymbol *)ast]; + } else if ([ast isKindOfClass:[NSArray class]]) { + NSMutableArray *newLst = [NSMutableArray array]; + for (NSObject * x in (NSArray *)ast) { + [newLst addObject:EVAL(x, env)]; + } + if ([ast isKindOfClass:[MalVector class]]) { + return [MalVector fromArray:newLst]; + } else { + return newLst; + } + } else if ([ast isKindOfClass:[NSDictionary class]]) { + NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; + for (NSString * k in (NSDictionary *)ast) { + newDict[k] = EVAL(((NSDictionary *)ast)[k], env); + } + return newDict; + } else { + return ast; + } +} + +NSObject *EVAL(NSObject *ast, Env *env) { + //NSLog(@"EVAL: %@", ast); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + if ([(NSArray *)ast count] == 0) { + return ast; + } + NSArray * alst = (NSArray *)ast; + id a0 = alst[0]; + if (![a0 isKindOfClass:[MalSymbol class]]) { + @throw @"attempt to apply on non-symbol"; + } + if ([(NSString *)a0 isEqualTo:@"def!"]) { + return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; + } else if ([(NSString *)a0 isEqualTo:@"let*"]) { + Env *let_env = [Env fromOuter:env]; + NSArray * binds = (NSArray *)alst[1]; + for (int i=0; i < [binds count]; i+=2) { + [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; + } + return EVAL(alst[2], let_env); + } else { + NSArray * el = (NSArray *) eval_ast(ast, env); + NSObject * (^ f)(NSArray *) = el[0]; + NSArray * args = _rest(el); + return f(args); + } +} + +// print +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +// REPL +NSString *REP(NSString *line, Env *env) { + return PRINT(EVAL(READ(line), env)); +} + +int main () { + Env * repl_env = [[Env alloc] init]; + + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + [repl_env set:(MalSymbol *)@"+" val:^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] + [args[1] intValue]]; + }]; + [repl_env set:(MalSymbol *)@"-" val:^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] - [args[1] intValue]]; + }]; + [repl_env set:(MalSymbol *)@"*" val:^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] * [args[1] intValue]]; + }]; + [repl_env set:(MalSymbol *)@"/" val:^(NSArray *args){ + return [NSNumber numberWithInt:[args[0] intValue] / [args[1] intValue]]; + }]; + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line, repl_env) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/step4_if_fn_do.m b/impls/objc/step4_if_fn_do.m index a33ce66381..d8b225e719 100644 --- a/impls/objc/step4_if_fn_do.m +++ b/impls/objc/step4_if_fn_do.m @@ -1,149 +1,149 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" -#import "env.h" -#import "malfunc.h" -#import "core.h" - -// read -NSObject *READ(NSString *str) { - return read_str(str); -} - -// eval -NSObject *eval_ast(NSObject *ast, Env *env) { - if ([ast isMemberOfClass:[MalSymbol class]]) { - return [env get:(MalSymbol *)ast]; - } else if ([ast isKindOfClass:[NSArray class]]) { - NSMutableArray *newLst = [NSMutableArray array]; - for (NSObject * x in (NSArray *)ast) { - [newLst addObject:EVAL(x, env)]; - } - if ([ast isKindOfClass:[MalVector class]]) { - return [MalVector fromArray:newLst]; - } else { - return newLst; - } - } else if ([ast isKindOfClass:[NSDictionary class]]) { - NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; - for (NSString * k in (NSDictionary *)ast) { - newDict[k] = EVAL(((NSDictionary *)ast)[k], env); - } - return newDict; - } else { - return ast; - } -} - -NSObject *EVAL(NSObject *ast, Env *env) { - //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - if ([(NSArray *)ast count] == 0) { - return ast; - } - NSArray * alst = (NSArray *)ast; - id a0 = alst[0]; - NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 - : @"__<*fn*>__"; - - if ([a0sym isEqualTo:@"def!"]) { - return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; - } else if ([(NSString *)a0 isEqualTo:@"let*"]) { - Env *let_env = [Env fromOuter:env]; - NSArray * binds = (NSArray *)alst[1]; - for (int i=0; i < [binds count]; i+=2) { - [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; - } - return EVAL(alst[2], let_env); - } else if ([a0sym isEqualTo:@"do"]) { - NSArray * el = (NSArray *)eval_ast(_rest(alst), env); - return [el lastObject]; - } else if ([a0sym isEqualTo:@"if"]) { - NSObject * cond = EVAL(alst[1], env); - if ([cond isKindOfClass:[NSNull class]] || - [cond isKindOfClass:[MalFalse class]]) { - if ([alst count] > 3) { - return EVAL(alst[3], env); - } else { - return [NSNull alloc]; - } - } else { - return EVAL(alst[2], env); - } - } else if ([a0sym isEqualTo:@"fn*"]) { - return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; - } else { - NSArray * el = (NSArray *) eval_ast(ast, env); - NSArray * args = @[]; - if ([el count] > 1) { - args = _rest(el); - } - return apply(el[0], args); - /* - if ([el[0] isKindOfClass:[MalFunc class]]) { - MalFunc * mf = el[0]; - return [mf apply:args]; - } else { - NSObject * (^ f)(NSArray *) = el[0]; - return f(args); - } - */ - } -} - -// print -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -// REPL -NSString *REP(NSString *line, Env *env) { - return PRINT(EVAL(READ(line), env)); -} - -int main () { - Env * repl_env = [[Env alloc] init]; - - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - // core.m: defined using Objective-C - NSDictionary * core_ns = [Core ns]; - for (NSString* key in core_ns) { - [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; - } - - // core.mal: defined using the language itself - REP(@"(def! not (fn* (a) (if a false true)))", repl_env); - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line, repl_env) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSObject *e) { - NSObject * exc = e; - printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" +#import "env.h" +#import "malfunc.h" +#import "core.h" + +// read +NSObject *READ(NSString *str) { + return read_str(str); +} + +// eval +NSObject *eval_ast(NSObject *ast, Env *env) { + if ([ast isMemberOfClass:[MalSymbol class]]) { + return [env get:(MalSymbol *)ast]; + } else if ([ast isKindOfClass:[NSArray class]]) { + NSMutableArray *newLst = [NSMutableArray array]; + for (NSObject * x in (NSArray *)ast) { + [newLst addObject:EVAL(x, env)]; + } + if ([ast isKindOfClass:[MalVector class]]) { + return [MalVector fromArray:newLst]; + } else { + return newLst; + } + } else if ([ast isKindOfClass:[NSDictionary class]]) { + NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; + for (NSString * k in (NSDictionary *)ast) { + newDict[k] = EVAL(((NSDictionary *)ast)[k], env); + } + return newDict; + } else { + return ast; + } +} + +NSObject *EVAL(NSObject *ast, Env *env) { + //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + if ([(NSArray *)ast count] == 0) { + return ast; + } + NSArray * alst = (NSArray *)ast; + id a0 = alst[0]; + NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 + : @"__<*fn*>__"; + + if ([a0sym isEqualTo:@"def!"]) { + return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; + } else if ([(NSString *)a0 isEqualTo:@"let*"]) { + Env *let_env = [Env fromOuter:env]; + NSArray * binds = (NSArray *)alst[1]; + for (int i=0; i < [binds count]; i+=2) { + [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; + } + return EVAL(alst[2], let_env); + } else if ([a0sym isEqualTo:@"do"]) { + NSArray * el = (NSArray *)eval_ast(_rest(alst), env); + return [el lastObject]; + } else if ([a0sym isEqualTo:@"if"]) { + NSObject * cond = EVAL(alst[1], env); + if ([cond isKindOfClass:[NSNull class]] || + [cond isKindOfClass:[MalFalse class]]) { + if ([alst count] > 3) { + return EVAL(alst[3], env); + } else { + return [NSNull alloc]; + } + } else { + return EVAL(alst[2], env); + } + } else if ([a0sym isEqualTo:@"fn*"]) { + return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; + } else { + NSArray * el = (NSArray *) eval_ast(ast, env); + NSArray * args = @[]; + if ([el count] > 1) { + args = _rest(el); + } + return apply(el[0], args); + /* + if ([el[0] isKindOfClass:[MalFunc class]]) { + MalFunc * mf = el[0]; + return [mf apply:args]; + } else { + NSObject * (^ f)(NSArray *) = el[0]; + return f(args); + } + */ + } +} + +// print +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +// REPL +NSString *REP(NSString *line, Env *env) { + return PRINT(EVAL(READ(line), env)); +} + +int main () { + Env * repl_env = [[Env alloc] init]; + + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + // core.m: defined using Objective-C + NSDictionary * core_ns = [Core ns]; + for (NSString* key in core_ns) { + [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; + } + + // core.mal: defined using the language itself + REP(@"(def! not (fn* (a) (if a false true)))", repl_env); + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line, repl_env) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/step5_tco.m b/impls/objc/step5_tco.m index b5f61e7c5d..966b5563c5 100644 --- a/impls/objc/step5_tco.m +++ b/impls/objc/step5_tco.m @@ -1,151 +1,151 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" -#import "env.h" -#import "malfunc.h" -#import "core.h" - -// read -NSObject *READ(NSString *str) { - return read_str(str); -} - -// eval -NSObject *eval_ast(NSObject *ast, Env *env) { - if ([ast isMemberOfClass:[MalSymbol class]]) { - return [env get:(MalSymbol *)ast]; - } else if ([ast isKindOfClass:[NSArray class]]) { - NSMutableArray *newLst = [NSMutableArray array]; - for (NSObject * x in (NSArray *)ast) { - [newLst addObject:EVAL(x, env)]; - } - if ([ast isKindOfClass:[MalVector class]]) { - return [MalVector fromArray:newLst]; - } else { - return newLst; - } - } else if ([ast isKindOfClass:[NSDictionary class]]) { - NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; - for (NSString * k in (NSDictionary *)ast) { - newDict[k] = EVAL(((NSDictionary *)ast)[k], env); - } - return newDict; - } else { - return ast; - } -} - -NSObject *EVAL(NSObject *ast, Env *env) { - while (true) { - //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - if ([(NSArray *)ast count] == 0) { - return ast; - } - NSArray * alst = (NSArray *)ast; - id a0 = alst[0]; - NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 - : @"__<*fn*>__"; - - if ([a0sym isEqualTo:@"def!"]) { - return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; - } else if ([(NSString *)a0 isEqualTo:@"let*"]) { - Env *let_env = [Env fromOuter:env]; - NSArray * binds = (NSArray *)alst[1]; - for (int i=0; i < [binds count]; i+=2) { - [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; - } - env = let_env; - ast = alst[2]; // TCO - } else if ([a0sym isEqualTo:@"do"]) { - NSRange r = NSMakeRange(1, [alst count] - 2); - eval_ast([alst subarrayWithRange:r], env); - ast = [alst lastObject]; // TCO - } else if ([a0sym isEqualTo:@"if"]) { - NSObject * cond = EVAL(alst[1], env); - if ([cond isKindOfClass:[NSNull class]] || - [cond isKindOfClass:[MalFalse class]]) { - if ([alst count] > 3) { - ast = alst[3]; // TCO - } else { - return [NSNull alloc]; - } - } else { - ast = alst[2]; // TCO - } - } else if ([a0sym isEqualTo:@"fn*"]) { - return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; - } else { - NSArray * el = (NSArray *) eval_ast(ast, env); - NSArray * args = @[]; - if ([el count] > 1) { - args = _rest(el); - } - if ([el[0] isKindOfClass:[MalFunc class]]) { - MalFunc * mf = el[0]; - env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; - ast = [mf ast]; // TCO - } else { - NSObject * (^ f)(NSArray *) = el[0]; - return f(args); - } - } - } -} - -// print -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -// REPL -NSString *REP(NSString *line, Env *env) { - return PRINT(EVAL(READ(line), env)); -} - -int main () { - Env * repl_env = [[Env alloc] init]; - - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - // core.m: defined using Objective-C - NSDictionary * core_ns = [Core ns]; - for (NSString* key in core_ns) { - [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; - } - - // core.mal: defined using the language itself - REP(@"(def! not (fn* (a) (if a false true)))", repl_env); - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line, repl_env) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSObject *e) { - NSObject * exc = e; - printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" +#import "env.h" +#import "malfunc.h" +#import "core.h" + +// read +NSObject *READ(NSString *str) { + return read_str(str); +} + +// eval +NSObject *eval_ast(NSObject *ast, Env *env) { + if ([ast isMemberOfClass:[MalSymbol class]]) { + return [env get:(MalSymbol *)ast]; + } else if ([ast isKindOfClass:[NSArray class]]) { + NSMutableArray *newLst = [NSMutableArray array]; + for (NSObject * x in (NSArray *)ast) { + [newLst addObject:EVAL(x, env)]; + } + if ([ast isKindOfClass:[MalVector class]]) { + return [MalVector fromArray:newLst]; + } else { + return newLst; + } + } else if ([ast isKindOfClass:[NSDictionary class]]) { + NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; + for (NSString * k in (NSDictionary *)ast) { + newDict[k] = EVAL(((NSDictionary *)ast)[k], env); + } + return newDict; + } else { + return ast; + } +} + +NSObject *EVAL(NSObject *ast, Env *env) { + while (true) { + //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + if ([(NSArray *)ast count] == 0) { + return ast; + } + NSArray * alst = (NSArray *)ast; + id a0 = alst[0]; + NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 + : @"__<*fn*>__"; + + if ([a0sym isEqualTo:@"def!"]) { + return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; + } else if ([(NSString *)a0 isEqualTo:@"let*"]) { + Env *let_env = [Env fromOuter:env]; + NSArray * binds = (NSArray *)alst[1]; + for (int i=0; i < [binds count]; i+=2) { + [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; + } + env = let_env; + ast = alst[2]; // TCO + } else if ([a0sym isEqualTo:@"do"]) { + NSRange r = NSMakeRange(1, [alst count] - 2); + eval_ast([alst subarrayWithRange:r], env); + ast = [alst lastObject]; // TCO + } else if ([a0sym isEqualTo:@"if"]) { + NSObject * cond = EVAL(alst[1], env); + if ([cond isKindOfClass:[NSNull class]] || + [cond isKindOfClass:[MalFalse class]]) { + if ([alst count] > 3) { + ast = alst[3]; // TCO + } else { + return [NSNull alloc]; + } + } else { + ast = alst[2]; // TCO + } + } else if ([a0sym isEqualTo:@"fn*"]) { + return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; + } else { + NSArray * el = (NSArray *) eval_ast(ast, env); + NSArray * args = @[]; + if ([el count] > 1) { + args = _rest(el); + } + if ([el[0] isKindOfClass:[MalFunc class]]) { + MalFunc * mf = el[0]; + env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; + ast = [mf ast]; // TCO + } else { + NSObject * (^ f)(NSArray *) = el[0]; + return f(args); + } + } + } +} + +// print +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +// REPL +NSString *REP(NSString *line, Env *env) { + return PRINT(EVAL(READ(line), env)); +} + +int main () { + Env * repl_env = [[Env alloc] init]; + + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + // core.m: defined using Objective-C + NSDictionary * core_ns = [Core ns]; + for (NSString* key in core_ns) { + [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; + } + + // core.mal: defined using the language itself + REP(@"(def! not (fn* (a) (if a false true)))", repl_env); + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line, repl_env) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/step6_file.m b/impls/objc/step6_file.m index eee91c1ef8..ffbfe84f30 100644 --- a/impls/objc/step6_file.m +++ b/impls/objc/step6_file.m @@ -1,172 +1,172 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" -#import "env.h" -#import "malfunc.h" -#import "core.h" - -// read -NSObject *READ(NSString *str) { - return read_str(str); -} - -// eval -NSObject *eval_ast(NSObject *ast, Env *env) { - if ([ast isMemberOfClass:[MalSymbol class]]) { - return [env get:(MalSymbol *)ast]; - } else if ([ast isKindOfClass:[NSArray class]]) { - NSMutableArray *newLst = [NSMutableArray array]; - for (NSObject * x in (NSArray *)ast) { - [newLst addObject:EVAL(x, env)]; - } - if ([ast isKindOfClass:[MalVector class]]) { - return [MalVector fromArray:newLst]; - } else { - return newLst; - } - } else if ([ast isKindOfClass:[NSDictionary class]]) { - NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; - for (NSString * k in (NSDictionary *)ast) { - newDict[k] = EVAL(((NSDictionary *)ast)[k], env); - } - return newDict; - } else { - return ast; - } -} - -NSObject *EVAL(NSObject *ast, Env *env) { - while (true) { - //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - if ([(NSArray *)ast count] == 0) { - return ast; - } - NSArray * alst = (NSArray *)ast; - id a0 = alst[0]; - NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 - : @"__<*fn*>__"; - - if ([a0sym isEqualTo:@"def!"]) { - return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; - } else if ([(NSString *)a0 isEqualTo:@"let*"]) { - Env *let_env = [Env fromOuter:env]; - NSArray * binds = (NSArray *)alst[1]; - for (int i=0; i < [binds count]; i+=2) { - [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; - } - env = let_env; - ast = alst[2]; // TCO - } else if ([a0sym isEqualTo:@"do"]) { - NSRange r = NSMakeRange(1, [alst count] - 2); - eval_ast([alst subarrayWithRange:r], env); - ast = [alst lastObject]; // TCO - } else if ([a0sym isEqualTo:@"if"]) { - NSObject * cond = EVAL(alst[1], env); - if ([cond isKindOfClass:[NSNull class]] || - [cond isKindOfClass:[MalFalse class]]) { - if ([alst count] > 3) { - ast = alst[3]; // TCO - } else { - return [NSNull alloc]; - } - } else { - ast = alst[2]; // TCO - } - } else if ([a0sym isEqualTo:@"fn*"]) { - return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; - } else { - NSArray * el = (NSArray *) eval_ast(ast, env); - NSArray * args = @[]; - if ([el count] > 1) { - args = _rest(el); - } - if ([el[0] isKindOfClass:[MalFunc class]]) { - MalFunc * mf = el[0]; - env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; - ast = [mf ast]; // TCO - } else { - NSObject * (^ f)(NSArray *) = el[0]; - return f(args); - } - } - } -} - -// print -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -// REPL -NSString *REP(NSString *line, Env *env) { - return PRINT(EVAL(READ(line), env)); -} - -int main () { - // Outside of pool to prevent "Block_release called upon - // a stack..." message on exit - Env * repl_env = [[Env alloc] init]; - NSArray *args = [[NSProcessInfo processInfo] arguments]; - - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - // core.m: defined using Objective-C - NSDictionary * core_ns = [Core ns]; - for (NSString* key in core_ns) { - [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; - } - [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { - return EVAL(args[0], repl_env); - }]; - NSArray *argv = @[]; - if ([args count] > 2) { - argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; - } - [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; - - // core.mal: defined using the language itself - REP(@"(def! not (fn* (a) (if a false true)))", repl_env); - REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - - if ([args count] > 1) { - @try { - REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } - return 0; - } - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line, repl_env) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSObject *e) { - NSObject * exc = e; - printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" +#import "env.h" +#import "malfunc.h" +#import "core.h" + +// read +NSObject *READ(NSString *str) { + return read_str(str); +} + +// eval +NSObject *eval_ast(NSObject *ast, Env *env) { + if ([ast isMemberOfClass:[MalSymbol class]]) { + return [env get:(MalSymbol *)ast]; + } else if ([ast isKindOfClass:[NSArray class]]) { + NSMutableArray *newLst = [NSMutableArray array]; + for (NSObject * x in (NSArray *)ast) { + [newLst addObject:EVAL(x, env)]; + } + if ([ast isKindOfClass:[MalVector class]]) { + return [MalVector fromArray:newLst]; + } else { + return newLst; + } + } else if ([ast isKindOfClass:[NSDictionary class]]) { + NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; + for (NSString * k in (NSDictionary *)ast) { + newDict[k] = EVAL(((NSDictionary *)ast)[k], env); + } + return newDict; + } else { + return ast; + } +} + +NSObject *EVAL(NSObject *ast, Env *env) { + while (true) { + //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + if ([(NSArray *)ast count] == 0) { + return ast; + } + NSArray * alst = (NSArray *)ast; + id a0 = alst[0]; + NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 + : @"__<*fn*>__"; + + if ([a0sym isEqualTo:@"def!"]) { + return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; + } else if ([(NSString *)a0 isEqualTo:@"let*"]) { + Env *let_env = [Env fromOuter:env]; + NSArray * binds = (NSArray *)alst[1]; + for (int i=0; i < [binds count]; i+=2) { + [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; + } + env = let_env; + ast = alst[2]; // TCO + } else if ([a0sym isEqualTo:@"do"]) { + NSRange r = NSMakeRange(1, [alst count] - 2); + eval_ast([alst subarrayWithRange:r], env); + ast = [alst lastObject]; // TCO + } else if ([a0sym isEqualTo:@"if"]) { + NSObject * cond = EVAL(alst[1], env); + if ([cond isKindOfClass:[NSNull class]] || + [cond isKindOfClass:[MalFalse class]]) { + if ([alst count] > 3) { + ast = alst[3]; // TCO + } else { + return [NSNull alloc]; + } + } else { + ast = alst[2]; // TCO + } + } else if ([a0sym isEqualTo:@"fn*"]) { + return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; + } else { + NSArray * el = (NSArray *) eval_ast(ast, env); + NSArray * args = @[]; + if ([el count] > 1) { + args = _rest(el); + } + if ([el[0] isKindOfClass:[MalFunc class]]) { + MalFunc * mf = el[0]; + env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; + ast = [mf ast]; // TCO + } else { + NSObject * (^ f)(NSArray *) = el[0]; + return f(args); + } + } + } +} + +// print +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +// REPL +NSString *REP(NSString *line, Env *env) { + return PRINT(EVAL(READ(line), env)); +} + +int main () { + // Outside of pool to prevent "Block_release called upon + // a stack..." message on exit + Env * repl_env = [[Env alloc] init]; + NSArray *args = [[NSProcessInfo processInfo] arguments]; + + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + // core.m: defined using Objective-C + NSDictionary * core_ns = [Core ns]; + for (NSString* key in core_ns) { + [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; + } + [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { + return EVAL(args[0], repl_env); + }]; + NSArray *argv = @[]; + if ([args count] > 2) { + argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; + } + [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; + + // core.mal: defined using the language itself + REP(@"(def! not (fn* (a) (if a false true)))", repl_env); + REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + + if ([args count] > 1) { + @try { + REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } + return 0; + } + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line, repl_env) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/step7_quote.m b/impls/objc/step7_quote.m index 56bf78ba57..9f070fe9bd 100644 --- a/impls/objc/step7_quote.m +++ b/impls/objc/step7_quote.m @@ -1,214 +1,214 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" -#import "env.h" -#import "malfunc.h" -#import "core.h" - -// read -NSObject *READ(NSString *str) { - return read_str(str); -} - -// eval -BOOL starts_with(NSObject *ast, NSString *sym) { - if (!list_Q(ast)) - return 0; - NSArray *alst = (NSArray *)ast; - if (![alst count]) - return 0; - NSObject *a0 = alst[0]; - return [a0 isKindOfClass:[MalSymbol class]] && - [(NSString *)a0 isEqualTo:sym]; -} - -NSObject * quasiquote(NSObject *ast) { - if ([ast isMemberOfClass:[MalSymbol class]] || - [ast isKindOfClass:[NSDictionary class]]) - return @[[MalSymbol stringWithString:@"quote"], ast]; - - if (![ast isKindOfClass:[NSArray class]]) - return ast; - - NSArray * alst = (NSArray *)ast; - if (starts_with(alst, @"unquote")) - return alst[1]; - - NSObject *res = @[]; - for (int i= [alst count] - 1; 0<=i; i--) { - NSObject *elt = alst[i]; - if (starts_with(elt, @"splice-unquote")) - res = @[[MalSymbol stringWithString:@"concat"], ((NSArray *)elt)[1], res]; - else - res = @[[MalSymbol stringWithString:@"cons"], quasiquote(elt), res]; - } - if ([ast isKindOfClass:[MalVector class]]) - res = @[[MalSymbol stringWithString:@"vec"], res]; - return res; -} - -NSObject *eval_ast(NSObject *ast, Env *env) { - if ([ast isMemberOfClass:[MalSymbol class]]) { - return [env get:(MalSymbol *)ast]; - } else if ([ast isKindOfClass:[NSArray class]]) { - NSMutableArray *newLst = [NSMutableArray array]; - for (NSObject * x in (NSArray *)ast) { - [newLst addObject:EVAL(x, env)]; - } - if ([ast isKindOfClass:[MalVector class]]) { - return [MalVector fromArray:newLst]; - } else { - return newLst; - } - } else if ([ast isKindOfClass:[NSDictionary class]]) { - NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; - for (NSString * k in (NSDictionary *)ast) { - newDict[k] = EVAL(((NSDictionary *)ast)[k], env); - } - return newDict; - } else { - return ast; - } -} - -NSObject *EVAL(NSObject *ast, Env *env) { - while (true) { - //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - if ([(NSArray *)ast count] == 0) { - return ast; - } - NSArray * alst = (NSArray *)ast; - id a0 = alst[0]; - NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 - : @"__<*fn*>__"; - - if ([a0sym isEqualTo:@"def!"]) { - return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; - } else if ([(NSString *)a0 isEqualTo:@"let*"]) { - Env *let_env = [Env fromOuter:env]; - NSArray * binds = (NSArray *)alst[1]; - for (int i=0; i < [binds count]; i+=2) { - [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; - } - env = let_env; - ast = alst[2]; // TCO - } else if ([(NSString *)a0 isEqualTo:@"quote"]) { - return alst[1]; - } else if ([(NSString *)a0 isEqualTo:@"quasiquoteexpand"]) { - return quasiquote(alst[1]); - } else if ([(NSString *)a0 isEqualTo:@"quasiquote"]) { - ast = quasiquote(alst[1]); // TCO - } else if ([a0sym isEqualTo:@"do"]) { - NSRange r = NSMakeRange(1, [alst count] - 2); - eval_ast([alst subarrayWithRange:r], env); - ast = [alst lastObject]; // TCO - } else if ([a0sym isEqualTo:@"if"]) { - NSObject * cond = EVAL(alst[1], env); - if ([cond isKindOfClass:[NSNull class]] || - [cond isKindOfClass:[MalFalse class]]) { - if ([alst count] > 3) { - ast = alst[3]; // TCO - } else { - return [NSNull alloc]; - } - } else { - ast = alst[2]; // TCO - } - } else if ([a0sym isEqualTo:@"fn*"]) { - return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; - } else { - NSArray * el = (NSArray *) eval_ast(ast, env); - NSArray * args = @[]; - if ([el count] > 1) { - args = _rest(el); - } - if ([el[0] isKindOfClass:[MalFunc class]]) { - MalFunc * mf = el[0]; - env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; - ast = [mf ast]; // TCO - } else { - NSObject * (^ f)(NSArray *) = el[0]; - return f(args); - } - } - } -} - -// print -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -// REPL -NSString *REP(NSString *line, Env *env) { - return PRINT(EVAL(READ(line), env)); -} - -int main () { - // Outside of pool to prevent "Block_release called upon - // a stack..." message on exit - Env * repl_env = [[Env alloc] init]; - NSArray *args = [[NSProcessInfo processInfo] arguments]; - - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - // core.m: defined using Objective-C - NSDictionary * core_ns = [Core ns]; - for (NSString* key in core_ns) { - [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; - } - [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { - return EVAL(args[0], repl_env); - }]; - NSArray *argv = @[]; - if ([args count] > 2) { - argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; - } - [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; - - // core.mal: defined using the language itself - REP(@"(def! not (fn* (a) (if a false true)))", repl_env); - REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - - if ([args count] > 1) { - @try { - REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } - return 0; - } - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line, repl_env) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSObject *e) { - NSObject * exc = e; - printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" +#import "env.h" +#import "malfunc.h" +#import "core.h" + +// read +NSObject *READ(NSString *str) { + return read_str(str); +} + +// eval +BOOL starts_with(NSObject *ast, NSString *sym) { + if (!list_Q(ast)) + return 0; + NSArray *alst = (NSArray *)ast; + if (![alst count]) + return 0; + NSObject *a0 = alst[0]; + return [a0 isKindOfClass:[MalSymbol class]] && + [(NSString *)a0 isEqualTo:sym]; +} + +NSObject * quasiquote(NSObject *ast) { + if ([ast isMemberOfClass:[MalSymbol class]] || + [ast isKindOfClass:[NSDictionary class]]) + return @[[MalSymbol stringWithString:@"quote"], ast]; + + if (![ast isKindOfClass:[NSArray class]]) + return ast; + + NSArray * alst = (NSArray *)ast; + if (starts_with(alst, @"unquote")) + return alst[1]; + + NSObject *res = @[]; + for (int i= [alst count] - 1; 0<=i; i--) { + NSObject *elt = alst[i]; + if (starts_with(elt, @"splice-unquote")) + res = @[[MalSymbol stringWithString:@"concat"], ((NSArray *)elt)[1], res]; + else + res = @[[MalSymbol stringWithString:@"cons"], quasiquote(elt), res]; + } + if ([ast isKindOfClass:[MalVector class]]) + res = @[[MalSymbol stringWithString:@"vec"], res]; + return res; +} + +NSObject *eval_ast(NSObject *ast, Env *env) { + if ([ast isMemberOfClass:[MalSymbol class]]) { + return [env get:(MalSymbol *)ast]; + } else if ([ast isKindOfClass:[NSArray class]]) { + NSMutableArray *newLst = [NSMutableArray array]; + for (NSObject * x in (NSArray *)ast) { + [newLst addObject:EVAL(x, env)]; + } + if ([ast isKindOfClass:[MalVector class]]) { + return [MalVector fromArray:newLst]; + } else { + return newLst; + } + } else if ([ast isKindOfClass:[NSDictionary class]]) { + NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; + for (NSString * k in (NSDictionary *)ast) { + newDict[k] = EVAL(((NSDictionary *)ast)[k], env); + } + return newDict; + } else { + return ast; + } +} + +NSObject *EVAL(NSObject *ast, Env *env) { + while (true) { + //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + if ([(NSArray *)ast count] == 0) { + return ast; + } + NSArray * alst = (NSArray *)ast; + id a0 = alst[0]; + NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 + : @"__<*fn*>__"; + + if ([a0sym isEqualTo:@"def!"]) { + return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; + } else if ([(NSString *)a0 isEqualTo:@"let*"]) { + Env *let_env = [Env fromOuter:env]; + NSArray * binds = (NSArray *)alst[1]; + for (int i=0; i < [binds count]; i+=2) { + [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; + } + env = let_env; + ast = alst[2]; // TCO + } else if ([(NSString *)a0 isEqualTo:@"quote"]) { + return alst[1]; + } else if ([(NSString *)a0 isEqualTo:@"quasiquoteexpand"]) { + return quasiquote(alst[1]); + } else if ([(NSString *)a0 isEqualTo:@"quasiquote"]) { + ast = quasiquote(alst[1]); // TCO + } else if ([a0sym isEqualTo:@"do"]) { + NSRange r = NSMakeRange(1, [alst count] - 2); + eval_ast([alst subarrayWithRange:r], env); + ast = [alst lastObject]; // TCO + } else if ([a0sym isEqualTo:@"if"]) { + NSObject * cond = EVAL(alst[1], env); + if ([cond isKindOfClass:[NSNull class]] || + [cond isKindOfClass:[MalFalse class]]) { + if ([alst count] > 3) { + ast = alst[3]; // TCO + } else { + return [NSNull alloc]; + } + } else { + ast = alst[2]; // TCO + } + } else if ([a0sym isEqualTo:@"fn*"]) { + return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; + } else { + NSArray * el = (NSArray *) eval_ast(ast, env); + NSArray * args = @[]; + if ([el count] > 1) { + args = _rest(el); + } + if ([el[0] isKindOfClass:[MalFunc class]]) { + MalFunc * mf = el[0]; + env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; + ast = [mf ast]; // TCO + } else { + NSObject * (^ f)(NSArray *) = el[0]; + return f(args); + } + } + } +} + +// print +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +// REPL +NSString *REP(NSString *line, Env *env) { + return PRINT(EVAL(READ(line), env)); +} + +int main () { + // Outside of pool to prevent "Block_release called upon + // a stack..." message on exit + Env * repl_env = [[Env alloc] init]; + NSArray *args = [[NSProcessInfo processInfo] arguments]; + + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + // core.m: defined using Objective-C + NSDictionary * core_ns = [Core ns]; + for (NSString* key in core_ns) { + [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; + } + [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { + return EVAL(args[0], repl_env); + }]; + NSArray *argv = @[]; + if ([args count] > 2) { + argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; + } + [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; + + // core.mal: defined using the language itself + REP(@"(def! not (fn* (a) (if a false true)))", repl_env); + REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + + if ([args count] > 1) { + @try { + REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } + return 0; + } + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line, repl_env) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/step8_macros.m b/impls/objc/step8_macros.m index ebc2d380ec..501927554d 100644 --- a/impls/objc/step8_macros.m +++ b/impls/objc/step8_macros.m @@ -1,249 +1,249 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" -#import "env.h" -#import "malfunc.h" -#import "core.h" - -// read -NSObject *READ(NSString *str) { - return read_str(str); -} - -// eval -BOOL starts_with(NSObject *ast, NSString *sym) { - if (!list_Q(ast)) - return 0; - NSArray *alst = (NSArray *)ast; - if (![alst count]) - return 0; - NSObject *a0 = alst[0]; - return [a0 isKindOfClass:[MalSymbol class]] && - [(NSString *)a0 isEqualTo:sym]; -} - -NSObject * quasiquote(NSObject *ast) { - if ([ast isMemberOfClass:[MalSymbol class]] || - [ast isKindOfClass:[NSDictionary class]]) - return @[[MalSymbol stringWithString:@"quote"], ast]; - - if (![ast isKindOfClass:[NSArray class]]) - return ast; - - NSArray * alst = (NSArray *)ast; - if (starts_with(alst, @"unquote")) - return alst[1]; - - NSObject *res = @[]; - for (int i= [alst count] - 1; 0<=i; i--) { - NSObject *elt = alst[i]; - if (starts_with(elt, @"splice-unquote")) - res = @[[MalSymbol stringWithString:@"concat"], ((NSArray *)elt)[1], res]; - else - res = @[[MalSymbol stringWithString:@"cons"], quasiquote(elt), res]; - } - if ([ast isKindOfClass:[MalVector class]]) - res = @[[MalSymbol stringWithString:@"vec"], res]; - return res; -} - -BOOL is_macro_call(NSObject *ast, Env *env) { - if (list_Q(ast)) { - NSArray * alst = (NSArray *)ast; - if ([alst[0] isKindOfClass:[MalSymbol class]] && [env find:alst[0]]) { - id mf = [env get:alst[0]]; - if ([mf isKindOfClass:[MalFunc class]]) { - return [(MalFunc *)mf isMacro]; - } - } - } - return false; -} - -NSObject *macroexpand(NSObject *ast, Env *env) { - while(is_macro_call(ast, env)) { - NSArray * alst = (NSArray *)ast; - MalFunc * mf = (MalFunc *)[env get:alst[0]]; - ast = [mf apply:_rest(alst)]; - } - return ast; -} - -NSObject *eval_ast(NSObject *ast, Env *env) { - if ([ast isMemberOfClass:[MalSymbol class]]) { - return [env get:(MalSymbol *)ast]; - } else if ([ast isKindOfClass:[NSArray class]]) { - NSMutableArray *newLst = [NSMutableArray array]; - for (NSObject * x in (NSArray *)ast) { - [newLst addObject:EVAL(x, env)]; - } - if ([ast isKindOfClass:[MalVector class]]) { - return [MalVector fromArray:newLst]; - } else { - return newLst; - } - } else if ([ast isKindOfClass:[NSDictionary class]]) { - NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; - for (NSString * k in (NSDictionary *)ast) { - newDict[k] = EVAL(((NSDictionary *)ast)[k], env); - } - return newDict; - } else { - return ast; - } -} - -NSObject *EVAL(NSObject *ast, Env *env) { - while (true) { - //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - if ([(NSArray *)ast count] == 0) { - return ast; - } - ast = macroexpand(ast, env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - NSArray * alst = (NSArray *)ast; - id a0 = alst[0]; - NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 - : @"__<*fn*>__"; - - if ([a0sym isEqualTo:@"def!"]) { - return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; - } else if ([(NSString *)a0 isEqualTo:@"let*"]) { - Env *let_env = [Env fromOuter:env]; - NSArray * binds = (NSArray *)alst[1]; - for (int i=0; i < [binds count]; i+=2) { - [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; - } - env = let_env; - ast = alst[2]; // TCO - } else if ([(NSString *)a0 isEqualTo:@"quote"]) { - return alst[1]; - } else if ([(NSString *)a0 isEqualTo:@"quasiquoteexpand"]) { - return quasiquote(alst[1]); - } else if ([(NSString *)a0 isEqualTo:@"quasiquote"]) { - ast = quasiquote(alst[1]); // TCO - } else if ([a0sym isEqualTo:@"defmacro!"]) { - MalFunc * f = (MalFunc *)EVAL(alst[2], env); - f.isMacro = true; - return [env set:alst[1] val:f]; - } else if ([a0sym isEqualTo:@"macroexpand"]) { - return macroexpand(alst[1], env); - } else if ([a0sym isEqualTo:@"do"]) { - NSRange r = NSMakeRange(1, [alst count] - 2); - eval_ast([alst subarrayWithRange:r], env); - ast = [alst lastObject]; // TCO - } else if ([a0sym isEqualTo:@"if"]) { - NSObject * cond = EVAL(alst[1], env); - if ([cond isKindOfClass:[NSNull class]] || - [cond isKindOfClass:[MalFalse class]]) { - if ([alst count] > 3) { - ast = alst[3]; // TCO - } else { - return [NSNull alloc]; - } - } else { - ast = alst[2]; // TCO - } - } else if ([a0sym isEqualTo:@"fn*"]) { - return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; - } else { - NSArray * el = (NSArray *) eval_ast(ast, env); - NSArray * args = @[]; - if ([el count] > 1) { - args = _rest(el); - } - if ([el[0] isKindOfClass:[MalFunc class]]) { - MalFunc * mf = el[0]; - env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; - ast = [mf ast]; // TCO - } else { - NSObject * (^ f)(NSArray *) = el[0]; - return f(args); - } - } - } -} - -// print -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -// REPL -NSString *REP(NSString *line, Env *env) { - return PRINT(EVAL(READ(line), env)); -} - -int main () { - // Outside of pool to prevent "Block_release called upon - // a stack..." message on exit - Env * repl_env = [[Env alloc] init]; - NSArray *args = [[NSProcessInfo processInfo] arguments]; - - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - // core.m: defined using Objective-C - NSDictionary * core_ns = [Core ns]; - for (NSString* key in core_ns) { - [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; - } - [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { - return EVAL(args[0], repl_env); - }]; - NSArray *argv = @[]; - if ([args count] > 2) { - argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; - } - [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; - - // core.mal: defined using the language itself - REP(@"(def! not (fn* (a) (if a false true)))", repl_env); - REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - 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)))))))", repl_env); - - - if ([args count] > 1) { - @try { - REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } - return 0; - } - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line, repl_env) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSObject *e) { - NSObject * exc = e; - printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" +#import "env.h" +#import "malfunc.h" +#import "core.h" + +// read +NSObject *READ(NSString *str) { + return read_str(str); +} + +// eval +BOOL starts_with(NSObject *ast, NSString *sym) { + if (!list_Q(ast)) + return 0; + NSArray *alst = (NSArray *)ast; + if (![alst count]) + return 0; + NSObject *a0 = alst[0]; + return [a0 isKindOfClass:[MalSymbol class]] && + [(NSString *)a0 isEqualTo:sym]; +} + +NSObject * quasiquote(NSObject *ast) { + if ([ast isMemberOfClass:[MalSymbol class]] || + [ast isKindOfClass:[NSDictionary class]]) + return @[[MalSymbol stringWithString:@"quote"], ast]; + + if (![ast isKindOfClass:[NSArray class]]) + return ast; + + NSArray * alst = (NSArray *)ast; + if (starts_with(alst, @"unquote")) + return alst[1]; + + NSObject *res = @[]; + for (int i= [alst count] - 1; 0<=i; i--) { + NSObject *elt = alst[i]; + if (starts_with(elt, @"splice-unquote")) + res = @[[MalSymbol stringWithString:@"concat"], ((NSArray *)elt)[1], res]; + else + res = @[[MalSymbol stringWithString:@"cons"], quasiquote(elt), res]; + } + if ([ast isKindOfClass:[MalVector class]]) + res = @[[MalSymbol stringWithString:@"vec"], res]; + return res; +} + +BOOL is_macro_call(NSObject *ast, Env *env) { + if (list_Q(ast)) { + NSArray * alst = (NSArray *)ast; + if ([alst[0] isKindOfClass:[MalSymbol class]] && [env find:alst[0]]) { + id mf = [env get:alst[0]]; + if ([mf isKindOfClass:[MalFunc class]]) { + return [(MalFunc *)mf isMacro]; + } + } + } + return false; +} + +NSObject *macroexpand(NSObject *ast, Env *env) { + while(is_macro_call(ast, env)) { + NSArray * alst = (NSArray *)ast; + MalFunc * mf = (MalFunc *)[env get:alst[0]]; + ast = [mf apply:_rest(alst)]; + } + return ast; +} + +NSObject *eval_ast(NSObject *ast, Env *env) { + if ([ast isMemberOfClass:[MalSymbol class]]) { + return [env get:(MalSymbol *)ast]; + } else if ([ast isKindOfClass:[NSArray class]]) { + NSMutableArray *newLst = [NSMutableArray array]; + for (NSObject * x in (NSArray *)ast) { + [newLst addObject:EVAL(x, env)]; + } + if ([ast isKindOfClass:[MalVector class]]) { + return [MalVector fromArray:newLst]; + } else { + return newLst; + } + } else if ([ast isKindOfClass:[NSDictionary class]]) { + NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; + for (NSString * k in (NSDictionary *)ast) { + newDict[k] = EVAL(((NSDictionary *)ast)[k], env); + } + return newDict; + } else { + return ast; + } +} + +NSObject *EVAL(NSObject *ast, Env *env) { + while (true) { + //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + if ([(NSArray *)ast count] == 0) { + return ast; + } + ast = macroexpand(ast, env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + NSArray * alst = (NSArray *)ast; + id a0 = alst[0]; + NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 + : @"__<*fn*>__"; + + if ([a0sym isEqualTo:@"def!"]) { + return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; + } else if ([(NSString *)a0 isEqualTo:@"let*"]) { + Env *let_env = [Env fromOuter:env]; + NSArray * binds = (NSArray *)alst[1]; + for (int i=0; i < [binds count]; i+=2) { + [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; + } + env = let_env; + ast = alst[2]; // TCO + } else if ([(NSString *)a0 isEqualTo:@"quote"]) { + return alst[1]; + } else if ([(NSString *)a0 isEqualTo:@"quasiquoteexpand"]) { + return quasiquote(alst[1]); + } else if ([(NSString *)a0 isEqualTo:@"quasiquote"]) { + ast = quasiquote(alst[1]); // TCO + } else if ([a0sym isEqualTo:@"defmacro!"]) { + MalFunc * f = (MalFunc *)EVAL(alst[2], env); + f.isMacro = true; + return [env set:alst[1] val:f]; + } else if ([a0sym isEqualTo:@"macroexpand"]) { + return macroexpand(alst[1], env); + } else if ([a0sym isEqualTo:@"do"]) { + NSRange r = NSMakeRange(1, [alst count] - 2); + eval_ast([alst subarrayWithRange:r], env); + ast = [alst lastObject]; // TCO + } else if ([a0sym isEqualTo:@"if"]) { + NSObject * cond = EVAL(alst[1], env); + if ([cond isKindOfClass:[NSNull class]] || + [cond isKindOfClass:[MalFalse class]]) { + if ([alst count] > 3) { + ast = alst[3]; // TCO + } else { + return [NSNull alloc]; + } + } else { + ast = alst[2]; // TCO + } + } else if ([a0sym isEqualTo:@"fn*"]) { + return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; + } else { + NSArray * el = (NSArray *) eval_ast(ast, env); + NSArray * args = @[]; + if ([el count] > 1) { + args = _rest(el); + } + if ([el[0] isKindOfClass:[MalFunc class]]) { + MalFunc * mf = el[0]; + env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; + ast = [mf ast]; // TCO + } else { + NSObject * (^ f)(NSArray *) = el[0]; + return f(args); + } + } + } +} + +// print +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +// REPL +NSString *REP(NSString *line, Env *env) { + return PRINT(EVAL(READ(line), env)); +} + +int main () { + // Outside of pool to prevent "Block_release called upon + // a stack..." message on exit + Env * repl_env = [[Env alloc] init]; + NSArray *args = [[NSProcessInfo processInfo] arguments]; + + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + // core.m: defined using Objective-C + NSDictionary * core_ns = [Core ns]; + for (NSString* key in core_ns) { + [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; + } + [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { + return EVAL(args[0], repl_env); + }]; + NSArray *argv = @[]; + if ([args count] > 2) { + argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; + } + [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; + + // core.mal: defined using the language itself + REP(@"(def! not (fn* (a) (if a false true)))", repl_env); + REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + 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)))))))", repl_env); + + + if ([args count] > 1) { + @try { + REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } + return 0; + } + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line, repl_env) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/step9_try.m b/impls/objc/step9_try.m index a50d1f5866..92e17c139d 100644 --- a/impls/objc/step9_try.m +++ b/impls/objc/step9_try.m @@ -1,268 +1,268 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" -#import "env.h" -#import "malfunc.h" -#import "core.h" - -// read -NSObject *READ(NSString *str) { - return read_str(str); -} - -// eval -BOOL starts_with(NSObject *ast, NSString *sym) { - if (!list_Q(ast)) - return 0; - NSArray *alst = (NSArray *)ast; - if (![alst count]) - return 0; - NSObject *a0 = alst[0]; - return [a0 isKindOfClass:[MalSymbol class]] && - [(NSString *)a0 isEqualTo:sym]; -} - -NSObject * quasiquote(NSObject *ast) { - if ([ast isMemberOfClass:[MalSymbol class]] || - [ast isKindOfClass:[NSDictionary class]]) - return @[[MalSymbol stringWithString:@"quote"], ast]; - - if (![ast isKindOfClass:[NSArray class]]) - return ast; - - NSArray * alst = (NSArray *)ast; - if (starts_with(alst, @"unquote")) - return alst[1]; - - NSObject *res = @[]; - for (int i= [alst count] - 1; 0<=i; i--) { - NSObject *elt = alst[i]; - if (starts_with(elt, @"splice-unquote")) - res = @[[MalSymbol stringWithString:@"concat"], ((NSArray *)elt)[1], res]; - else - res = @[[MalSymbol stringWithString:@"cons"], quasiquote(elt), res]; - } - if ([ast isKindOfClass:[MalVector class]]) - res = @[[MalSymbol stringWithString:@"vec"], res]; - return res; -} - -BOOL is_macro_call(NSObject *ast, Env *env) { - if (list_Q(ast)) { - NSArray * alst = (NSArray *)ast; - if ([alst[0] isKindOfClass:[MalSymbol class]] && [env find:alst[0]]) { - id mf = [env get:alst[0]]; - if ([mf isKindOfClass:[MalFunc class]]) { - return [(MalFunc *)mf isMacro]; - } - } - } - return false; -} - -NSObject *macroexpand(NSObject *ast, Env *env) { - while(is_macro_call(ast, env)) { - NSArray * alst = (NSArray *)ast; - MalFunc * mf = (MalFunc *)[env get:alst[0]]; - ast = [mf apply:_rest(alst)]; - } - return ast; -} - -NSObject *eval_ast(NSObject *ast, Env *env) { - if ([ast isMemberOfClass:[MalSymbol class]]) { - return [env get:(MalSymbol *)ast]; - } else if ([ast isKindOfClass:[NSArray class]]) { - NSMutableArray *newLst = [NSMutableArray array]; - for (NSObject * x in (NSArray *)ast) { - [newLst addObject:EVAL(x, env)]; - } - if ([ast isKindOfClass:[MalVector class]]) { - return [MalVector fromArray:newLst]; - } else { - return newLst; - } - } else if ([ast isKindOfClass:[NSDictionary class]]) { - NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; - for (NSString * k in (NSDictionary *)ast) { - newDict[k] = EVAL(((NSDictionary *)ast)[k], env); - } - return newDict; - } else { - return ast; - } -} - -NSObject *EVAL(NSObject *ast, Env *env) { - while (true) { - //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - if ([(NSArray *)ast count] == 0) { - return ast; - } - ast = macroexpand(ast, env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - NSArray * alst = (NSArray *)ast; - id a0 = alst[0]; - NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 - : @"__<*fn*>__"; - - if ([a0sym isEqualTo:@"def!"]) { - return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; - } else if ([(NSString *)a0 isEqualTo:@"let*"]) { - Env *let_env = [Env fromOuter:env]; - NSArray * binds = (NSArray *)alst[1]; - for (int i=0; i < [binds count]; i+=2) { - [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; - } - env = let_env; - ast = alst[2]; // TCO - } else if ([(NSString *)a0 isEqualTo:@"quote"]) { - return alst[1]; - } else if ([(NSString *)a0 isEqualTo:@"quasiquoteexpand"]) { - return quasiquote(alst[1]); - } else if ([(NSString *)a0 isEqualTo:@"quasiquote"]) { - ast = quasiquote(alst[1]); // TCO - } else if ([a0sym isEqualTo:@"defmacro!"]) { - MalFunc * f = (MalFunc *)EVAL(alst[2], env); - f.isMacro = true; - return [env set:alst[1] val:f]; - } else if ([a0sym isEqualTo:@"macroexpand"]) { - return macroexpand(alst[1], env); - } else if ([a0sym isEqualTo:@"try*"]) { - @try { - return EVAL(alst[1], env); - } @catch(NSObject *e) { - if ([alst count] > 2 && [alst[2] isKindOfClass:[NSArray class]]) { - NSArray * a2lst = alst[2]; - if ([a2lst[0] isKindOfClass:[MalSymbol class]] && - [(MalSymbol *)a2lst[0] isEqualTo:@"catch*"]) { - NSObject * exc = e; - if ([e isKindOfClass:[NSException class]]) { - exc = [e description]; - } - return EVAL(a2lst[2], [Env fromBindings:env - binds:@[a2lst[1]] - exprs:@[exc]]); - } - } - @throw e; - } - } else if ([a0sym isEqualTo:@"do"]) { - NSRange r = NSMakeRange(1, [alst count] - 2); - eval_ast([alst subarrayWithRange:r], env); - ast = [alst lastObject]; // TCO - } else if ([a0sym isEqualTo:@"if"]) { - NSObject * cond = EVAL(alst[1], env); - if ([cond isKindOfClass:[NSNull class]] || - [cond isKindOfClass:[MalFalse class]]) { - if ([alst count] > 3) { - ast = alst[3]; // TCO - } else { - return [NSNull alloc]; - } - } else { - ast = alst[2]; // TCO - } - } else if ([a0sym isEqualTo:@"fn*"]) { - return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; - } else { - NSArray * el = (NSArray *) eval_ast(ast, env); - NSArray * args = @[]; - if ([el count] > 1) { - args = _rest(el); - } - if ([el[0] isKindOfClass:[MalFunc class]]) { - MalFunc * mf = el[0]; - env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; - ast = [mf ast]; // TCO - } else { - NSObject * (^ f)(NSArray *) = el[0]; - return f(args); - } - } - } -} - -// print -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -// REPL -NSString *REP(NSString *line, Env *env) { - return PRINT(EVAL(READ(line), env)); -} - -int main () { - // Outside of pool to prevent "Block_release called upon - // a stack..." message on exit - Env * repl_env = [[Env alloc] init]; - NSArray *args = [[NSProcessInfo processInfo] arguments]; - - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - // core.m: defined using Objective-C - NSDictionary * core_ns = [Core ns]; - for (NSString* key in core_ns) { - [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; - } - [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { - return EVAL(args[0], repl_env); - }]; - NSArray *argv = @[]; - if ([args count] > 2) { - argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; - } - [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; - - // core.mal: defined using the language itself - REP(@"(def! not (fn* (a) (if a false true)))", repl_env); - REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - 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)))))))", repl_env); - - - if ([args count] > 1) { - @try { - REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } - return 0; - } - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line, repl_env) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSObject *e) { - NSObject * exc = e; - printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" +#import "env.h" +#import "malfunc.h" +#import "core.h" + +// read +NSObject *READ(NSString *str) { + return read_str(str); +} + +// eval +BOOL starts_with(NSObject *ast, NSString *sym) { + if (!list_Q(ast)) + return 0; + NSArray *alst = (NSArray *)ast; + if (![alst count]) + return 0; + NSObject *a0 = alst[0]; + return [a0 isKindOfClass:[MalSymbol class]] && + [(NSString *)a0 isEqualTo:sym]; +} + +NSObject * quasiquote(NSObject *ast) { + if ([ast isMemberOfClass:[MalSymbol class]] || + [ast isKindOfClass:[NSDictionary class]]) + return @[[MalSymbol stringWithString:@"quote"], ast]; + + if (![ast isKindOfClass:[NSArray class]]) + return ast; + + NSArray * alst = (NSArray *)ast; + if (starts_with(alst, @"unquote")) + return alst[1]; + + NSObject *res = @[]; + for (int i= [alst count] - 1; 0<=i; i--) { + NSObject *elt = alst[i]; + if (starts_with(elt, @"splice-unquote")) + res = @[[MalSymbol stringWithString:@"concat"], ((NSArray *)elt)[1], res]; + else + res = @[[MalSymbol stringWithString:@"cons"], quasiquote(elt), res]; + } + if ([ast isKindOfClass:[MalVector class]]) + res = @[[MalSymbol stringWithString:@"vec"], res]; + return res; +} + +BOOL is_macro_call(NSObject *ast, Env *env) { + if (list_Q(ast)) { + NSArray * alst = (NSArray *)ast; + if ([alst[0] isKindOfClass:[MalSymbol class]] && [env find:alst[0]]) { + id mf = [env get:alst[0]]; + if ([mf isKindOfClass:[MalFunc class]]) { + return [(MalFunc *)mf isMacro]; + } + } + } + return false; +} + +NSObject *macroexpand(NSObject *ast, Env *env) { + while(is_macro_call(ast, env)) { + NSArray * alst = (NSArray *)ast; + MalFunc * mf = (MalFunc *)[env get:alst[0]]; + ast = [mf apply:_rest(alst)]; + } + return ast; +} + +NSObject *eval_ast(NSObject *ast, Env *env) { + if ([ast isMemberOfClass:[MalSymbol class]]) { + return [env get:(MalSymbol *)ast]; + } else if ([ast isKindOfClass:[NSArray class]]) { + NSMutableArray *newLst = [NSMutableArray array]; + for (NSObject * x in (NSArray *)ast) { + [newLst addObject:EVAL(x, env)]; + } + if ([ast isKindOfClass:[MalVector class]]) { + return [MalVector fromArray:newLst]; + } else { + return newLst; + } + } else if ([ast isKindOfClass:[NSDictionary class]]) { + NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; + for (NSString * k in (NSDictionary *)ast) { + newDict[k] = EVAL(((NSDictionary *)ast)[k], env); + } + return newDict; + } else { + return ast; + } +} + +NSObject *EVAL(NSObject *ast, Env *env) { + while (true) { + //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + if ([(NSArray *)ast count] == 0) { + return ast; + } + ast = macroexpand(ast, env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + NSArray * alst = (NSArray *)ast; + id a0 = alst[0]; + NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 + : @"__<*fn*>__"; + + if ([a0sym isEqualTo:@"def!"]) { + return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; + } else if ([(NSString *)a0 isEqualTo:@"let*"]) { + Env *let_env = [Env fromOuter:env]; + NSArray * binds = (NSArray *)alst[1]; + for (int i=0; i < [binds count]; i+=2) { + [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; + } + env = let_env; + ast = alst[2]; // TCO + } else if ([(NSString *)a0 isEqualTo:@"quote"]) { + return alst[1]; + } else if ([(NSString *)a0 isEqualTo:@"quasiquoteexpand"]) { + return quasiquote(alst[1]); + } else if ([(NSString *)a0 isEqualTo:@"quasiquote"]) { + ast = quasiquote(alst[1]); // TCO + } else if ([a0sym isEqualTo:@"defmacro!"]) { + MalFunc * f = (MalFunc *)EVAL(alst[2], env); + f.isMacro = true; + return [env set:alst[1] val:f]; + } else if ([a0sym isEqualTo:@"macroexpand"]) { + return macroexpand(alst[1], env); + } else if ([a0sym isEqualTo:@"try*"]) { + @try { + return EVAL(alst[1], env); + } @catch(NSObject *e) { + if ([alst count] > 2 && [alst[2] isKindOfClass:[NSArray class]]) { + NSArray * a2lst = alst[2]; + if ([a2lst[0] isKindOfClass:[MalSymbol class]] && + [(MalSymbol *)a2lst[0] isEqualTo:@"catch*"]) { + NSObject * exc = e; + if ([e isKindOfClass:[NSException class]]) { + exc = [e description]; + } + return EVAL(a2lst[2], [Env fromBindings:env + binds:@[a2lst[1]] + exprs:@[exc]]); + } + } + @throw e; + } + } else if ([a0sym isEqualTo:@"do"]) { + NSRange r = NSMakeRange(1, [alst count] - 2); + eval_ast([alst subarrayWithRange:r], env); + ast = [alst lastObject]; // TCO + } else if ([a0sym isEqualTo:@"if"]) { + NSObject * cond = EVAL(alst[1], env); + if ([cond isKindOfClass:[NSNull class]] || + [cond isKindOfClass:[MalFalse class]]) { + if ([alst count] > 3) { + ast = alst[3]; // TCO + } else { + return [NSNull alloc]; + } + } else { + ast = alst[2]; // TCO + } + } else if ([a0sym isEqualTo:@"fn*"]) { + return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; + } else { + NSArray * el = (NSArray *) eval_ast(ast, env); + NSArray * args = @[]; + if ([el count] > 1) { + args = _rest(el); + } + if ([el[0] isKindOfClass:[MalFunc class]]) { + MalFunc * mf = el[0]; + env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; + ast = [mf ast]; // TCO + } else { + NSObject * (^ f)(NSArray *) = el[0]; + return f(args); + } + } + } +} + +// print +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +// REPL +NSString *REP(NSString *line, Env *env) { + return PRINT(EVAL(READ(line), env)); +} + +int main () { + // Outside of pool to prevent "Block_release called upon + // a stack..." message on exit + Env * repl_env = [[Env alloc] init]; + NSArray *args = [[NSProcessInfo processInfo] arguments]; + + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + // core.m: defined using Objective-C + NSDictionary * core_ns = [Core ns]; + for (NSString* key in core_ns) { + [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; + } + [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { + return EVAL(args[0], repl_env); + }]; + NSArray *argv = @[]; + if ([args count] > 2) { + argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; + } + [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; + + // core.mal: defined using the language itself + REP(@"(def! not (fn* (a) (if a false true)))", repl_env); + REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + 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)))))))", repl_env); + + + if ([args count] > 1) { + @try { + REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } + return 0; + } + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line, repl_env) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/stepA_mal.m b/impls/objc/stepA_mal.m index 7004395ed9..ef0aa52849 100644 --- a/impls/objc/stepA_mal.m +++ b/impls/objc/stepA_mal.m @@ -1,269 +1,269 @@ -#import - -#import "mal_readline.h" -#import "types.h" -#import "reader.h" -#import "printer.h" -#import "env.h" -#import "malfunc.h" -#import "core.h" - -// read -NSObject *READ(NSString *str) { - return read_str(str); -} - -// eval -BOOL starts_with(NSObject *ast, NSString *sym) { - if (!list_Q(ast)) - return 0; - NSArray *alst = (NSArray *)ast; - if (![alst count]) - return 0; - NSObject *a0 = alst[0]; - return [a0 isKindOfClass:[MalSymbol class]] && - [(NSString *)a0 isEqualTo:sym]; -} - -NSObject * quasiquote(NSObject *ast) { - if ([ast isMemberOfClass:[MalSymbol class]] || - [ast isKindOfClass:[NSDictionary class]]) - return @[[MalSymbol stringWithString:@"quote"], ast]; - - if (![ast isKindOfClass:[NSArray class]]) - return ast; - - NSArray * alst = (NSArray *)ast; - if (starts_with(alst, @"unquote")) - return alst[1]; - - NSObject *res = @[]; - for (int i= [alst count] - 1; 0<=i; i--) { - NSObject *elt = alst[i]; - if (starts_with(elt, @"splice-unquote")) - res = @[[MalSymbol stringWithString:@"concat"], ((NSArray *)elt)[1], res]; - else - res = @[[MalSymbol stringWithString:@"cons"], quasiquote(elt), res]; - } - if ([ast isKindOfClass:[MalVector class]]) - res = @[[MalSymbol stringWithString:@"vec"], res]; - return res; -} - -BOOL is_macro_call(NSObject *ast, Env *env) { - if (list_Q(ast)) { - NSArray * alst = (NSArray *)ast; - if ([alst[0] isKindOfClass:[MalSymbol class]] && [env find:alst[0]]) { - id mf = [env get:alst[0]]; - if ([mf isKindOfClass:[MalFunc class]]) { - return [(MalFunc *)mf isMacro]; - } - } - } - return false; -} - -NSObject *macroexpand(NSObject *ast, Env *env) { - while(is_macro_call(ast, env)) { - NSArray * alst = (NSArray *)ast; - MalFunc * mf = (MalFunc *)[env get:alst[0]]; - ast = [mf apply:_rest(alst)]; - } - return ast; -} - -NSObject *eval_ast(NSObject *ast, Env *env) { - if ([ast isMemberOfClass:[MalSymbol class]]) { - return [env get:(MalSymbol *)ast]; - } else if ([ast isKindOfClass:[NSArray class]]) { - NSMutableArray *newLst = [NSMutableArray array]; - for (NSObject * x in (NSArray *)ast) { - [newLst addObject:EVAL(x, env)]; - } - if ([ast isKindOfClass:[MalVector class]]) { - return [MalVector fromArray:newLst]; - } else { - return newLst; - } - } else if ([ast isKindOfClass:[NSDictionary class]]) { - NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; - for (NSString * k in (NSDictionary *)ast) { - newDict[k] = EVAL(((NSDictionary *)ast)[k], env); - } - return newDict; - } else { - return ast; - } -} - -NSObject *EVAL(NSObject *ast, Env *env) { - while (true) { - //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - // apply list - if ([(NSArray *)ast count] == 0) { - return ast; - } - ast = macroexpand(ast, env); - if (!list_Q(ast)) { - return eval_ast(ast, env); - } - - NSArray * alst = (NSArray *)ast; - id a0 = alst[0]; - NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 - : @"__<*fn*>__"; - - if ([a0sym isEqualTo:@"def!"]) { - return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; - } else if ([(NSString *)a0 isEqualTo:@"let*"]) { - Env *let_env = [Env fromOuter:env]; - NSArray * binds = (NSArray *)alst[1]; - for (int i=0; i < [binds count]; i+=2) { - [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; - } - env = let_env; - ast = alst[2]; // TCO - } else if ([(NSString *)a0 isEqualTo:@"quote"]) { - return alst[1]; - } else if ([(NSString *)a0 isEqualTo:@"quasiquoteexpand"]) { - return quasiquote(alst[1]); - } else if ([(NSString *)a0 isEqualTo:@"quasiquote"]) { - ast = quasiquote(alst[1]); // TCO - } else if ([a0sym isEqualTo:@"defmacro!"]) { - MalFunc * f = (MalFunc *)EVAL(alst[2], env); - f.isMacro = true; - return [env set:alst[1] val:f]; - } else if ([a0sym isEqualTo:@"macroexpand"]) { - return macroexpand(alst[1], env); - } else if ([a0sym isEqualTo:@"try*"]) { - @try { - return EVAL(alst[1], env); - } @catch(NSObject *e) { - if ([alst count] > 2 && [alst[2] isKindOfClass:[NSArray class]]) { - NSArray * a2lst = alst[2]; - if ([a2lst[0] isKindOfClass:[MalSymbol class]] && - [(MalSymbol *)a2lst[0] isEqualTo:@"catch*"]) { - NSObject * exc = e; - if ([e isKindOfClass:[NSException class]]) { - exc = [e description]; - } - return EVAL(a2lst[2], [Env fromBindings:env - binds:@[a2lst[1]] - exprs:@[exc]]); - } - } - @throw e; - } - } else if ([a0sym isEqualTo:@"do"]) { - NSRange r = NSMakeRange(1, [alst count] - 2); - eval_ast([alst subarrayWithRange:r], env); - ast = [alst lastObject]; // TCO - } else if ([a0sym isEqualTo:@"if"]) { - NSObject * cond = EVAL(alst[1], env); - if ([cond isKindOfClass:[NSNull class]] || - [cond isKindOfClass:[MalFalse class]]) { - if ([alst count] > 3) { - ast = alst[3]; // TCO - } else { - return [NSNull alloc]; - } - } else { - ast = alst[2]; // TCO - } - } else if ([a0sym isEqualTo:@"fn*"]) { - return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; - } else { - NSArray * el = (NSArray *) eval_ast(ast, env); - NSArray * args = @[]; - if ([el count] > 1) { - args = _rest(el); - } - if ([el[0] isKindOfClass:[MalFunc class]]) { - MalFunc * mf = el[0]; - env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; - ast = [mf ast]; // TCO - } else { - NSObject * (^ f)(NSArray *) = el[0]; - return f(args); - } - } - } -} - -// print -NSString *PRINT(NSObject *exp) { - return _pr_str(exp, true); -} - -// REPL -NSString *REP(NSString *line, Env *env) { - return PRINT(EVAL(READ(line), env)); -} - -int main () { - // Outside of pool to prevent "Block_release called upon - // a stack..." message on exit - Env * repl_env = [[Env alloc] init]; - NSArray *args = [[NSProcessInfo processInfo] arguments]; - - // Create an autorelease pool to manage the memory into the program - NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; - // If using automatic reference counting (ARC), use @autoreleasepool instead: -// @autoreleasepool { - - // core.m: defined using Objective-C - NSDictionary * core_ns = [Core ns]; - for (NSString* key in core_ns) { - [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; - } - [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { - return EVAL(args[0], repl_env); - }]; - NSArray *argv = @[]; - if ([args count] > 2) { - argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; - } - [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; - - // core.mal: defined using the language itself - REP(@"(def! *host-language* \"Objective-C\")", repl_env); - REP(@"(def! not (fn* (a) (if a false true)))", repl_env); - REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - 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)))))))", repl_env); - - - if ([args count] > 1) { - @try { - REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } - return 0; - } - - while (true) { - char *rawline = _readline("user> "); - if (!rawline) { break; } - NSString *line = [NSString stringWithUTF8String:rawline]; - if ([line length] == 0) { continue; } - @try { - printf("%s\n", [[REP(line, repl_env) description] UTF8String]); - } @catch(NSString *e) { - printf("Error: %s\n", [e UTF8String]); - } @catch(NSObject *e) { - NSObject * exc = e; - printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); - } @catch(NSException *e) { - if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } - printf("Exception: %s\n", [[e reason] UTF8String]); - } - } - - [pool drain]; - -// } -} +#import + +#import "mal_readline.h" +#import "types.h" +#import "reader.h" +#import "printer.h" +#import "env.h" +#import "malfunc.h" +#import "core.h" + +// read +NSObject *READ(NSString *str) { + return read_str(str); +} + +// eval +BOOL starts_with(NSObject *ast, NSString *sym) { + if (!list_Q(ast)) + return 0; + NSArray *alst = (NSArray *)ast; + if (![alst count]) + return 0; + NSObject *a0 = alst[0]; + return [a0 isKindOfClass:[MalSymbol class]] && + [(NSString *)a0 isEqualTo:sym]; +} + +NSObject * quasiquote(NSObject *ast) { + if ([ast isMemberOfClass:[MalSymbol class]] || + [ast isKindOfClass:[NSDictionary class]]) + return @[[MalSymbol stringWithString:@"quote"], ast]; + + if (![ast isKindOfClass:[NSArray class]]) + return ast; + + NSArray * alst = (NSArray *)ast; + if (starts_with(alst, @"unquote")) + return alst[1]; + + NSObject *res = @[]; + for (int i= [alst count] - 1; 0<=i; i--) { + NSObject *elt = alst[i]; + if (starts_with(elt, @"splice-unquote")) + res = @[[MalSymbol stringWithString:@"concat"], ((NSArray *)elt)[1], res]; + else + res = @[[MalSymbol stringWithString:@"cons"], quasiquote(elt), res]; + } + if ([ast isKindOfClass:[MalVector class]]) + res = @[[MalSymbol stringWithString:@"vec"], res]; + return res; +} + +BOOL is_macro_call(NSObject *ast, Env *env) { + if (list_Q(ast)) { + NSArray * alst = (NSArray *)ast; + if ([alst[0] isKindOfClass:[MalSymbol class]] && [env find:alst[0]]) { + id mf = [env get:alst[0]]; + if ([mf isKindOfClass:[MalFunc class]]) { + return [(MalFunc *)mf isMacro]; + } + } + } + return false; +} + +NSObject *macroexpand(NSObject *ast, Env *env) { + while(is_macro_call(ast, env)) { + NSArray * alst = (NSArray *)ast; + MalFunc * mf = (MalFunc *)[env get:alst[0]]; + ast = [mf apply:_rest(alst)]; + } + return ast; +} + +NSObject *eval_ast(NSObject *ast, Env *env) { + if ([ast isMemberOfClass:[MalSymbol class]]) { + return [env get:(MalSymbol *)ast]; + } else if ([ast isKindOfClass:[NSArray class]]) { + NSMutableArray *newLst = [NSMutableArray array]; + for (NSObject * x in (NSArray *)ast) { + [newLst addObject:EVAL(x, env)]; + } + if ([ast isKindOfClass:[MalVector class]]) { + return [MalVector fromArray:newLst]; + } else { + return newLst; + } + } else if ([ast isKindOfClass:[NSDictionary class]]) { + NSMutableDictionary *newDict = [NSMutableDictionary dictionary]; + for (NSString * k in (NSDictionary *)ast) { + newDict[k] = EVAL(((NSDictionary *)ast)[k], env); + } + return newDict; + } else { + return ast; + } +} + +NSObject *EVAL(NSObject *ast, Env *env) { + while (true) { + //NSLog(@"EVAL: %@ (%@)", _pr_str(ast, true), env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + // apply list + if ([(NSArray *)ast count] == 0) { + return ast; + } + ast = macroexpand(ast, env); + if (!list_Q(ast)) { + return eval_ast(ast, env); + } + + NSArray * alst = (NSArray *)ast; + id a0 = alst[0]; + NSString * a0sym = [a0 isKindOfClass:[MalSymbol class]] ? (NSString *)a0 + : @"__<*fn*>__"; + + if ([a0sym isEqualTo:@"def!"]) { + return [env set:((MalSymbol *)alst[1]) val:EVAL(alst[2], env)]; + } else if ([(NSString *)a0 isEqualTo:@"let*"]) { + Env *let_env = [Env fromOuter:env]; + NSArray * binds = (NSArray *)alst[1]; + for (int i=0; i < [binds count]; i+=2) { + [let_env set:binds[i] val:EVAL(binds[i+1], let_env)]; + } + env = let_env; + ast = alst[2]; // TCO + } else if ([(NSString *)a0 isEqualTo:@"quote"]) { + return alst[1]; + } else if ([(NSString *)a0 isEqualTo:@"quasiquoteexpand"]) { + return quasiquote(alst[1]); + } else if ([(NSString *)a0 isEqualTo:@"quasiquote"]) { + ast = quasiquote(alst[1]); // TCO + } else if ([a0sym isEqualTo:@"defmacro!"]) { + MalFunc * f = (MalFunc *)EVAL(alst[2], env); + f.isMacro = true; + return [env set:alst[1] val:f]; + } else if ([a0sym isEqualTo:@"macroexpand"]) { + return macroexpand(alst[1], env); + } else if ([a0sym isEqualTo:@"try*"]) { + @try { + return EVAL(alst[1], env); + } @catch(NSObject *e) { + if ([alst count] > 2 && [alst[2] isKindOfClass:[NSArray class]]) { + NSArray * a2lst = alst[2]; + if ([a2lst[0] isKindOfClass:[MalSymbol class]] && + [(MalSymbol *)a2lst[0] isEqualTo:@"catch*"]) { + NSObject * exc = e; + if ([e isKindOfClass:[NSException class]]) { + exc = [e description]; + } + return EVAL(a2lst[2], [Env fromBindings:env + binds:@[a2lst[1]] + exprs:@[exc]]); + } + } + @throw e; + } + } else if ([a0sym isEqualTo:@"do"]) { + NSRange r = NSMakeRange(1, [alst count] - 2); + eval_ast([alst subarrayWithRange:r], env); + ast = [alst lastObject]; // TCO + } else if ([a0sym isEqualTo:@"if"]) { + NSObject * cond = EVAL(alst[1], env); + if ([cond isKindOfClass:[NSNull class]] || + [cond isKindOfClass:[MalFalse class]]) { + if ([alst count] > 3) { + ast = alst[3]; // TCO + } else { + return [NSNull alloc]; + } + } else { + ast = alst[2]; // TCO + } + } else if ([a0sym isEqualTo:@"fn*"]) { + return [[MalFunc alloc] init:alst[2] env:env params:alst[1]]; + } else { + NSArray * el = (NSArray *) eval_ast(ast, env); + NSArray * args = @[]; + if ([el count] > 1) { + args = _rest(el); + } + if ([el[0] isKindOfClass:[MalFunc class]]) { + MalFunc * mf = el[0]; + env = [Env fromBindings:[mf env] binds:[mf params] exprs:args]; + ast = [mf ast]; // TCO + } else { + NSObject * (^ f)(NSArray *) = el[0]; + return f(args); + } + } + } +} + +// print +NSString *PRINT(NSObject *exp) { + return _pr_str(exp, true); +} + +// REPL +NSString *REP(NSString *line, Env *env) { + return PRINT(EVAL(READ(line), env)); +} + +int main () { + // Outside of pool to prevent "Block_release called upon + // a stack..." message on exit + Env * repl_env = [[Env alloc] init]; + NSArray *args = [[NSProcessInfo processInfo] arguments]; + + // Create an autorelease pool to manage the memory into the program + NSAutoreleasePool * pool = [[NSAutoreleasePool alloc] init]; + // If using automatic reference counting (ARC), use @autoreleasepool instead: +// @autoreleasepool { + + // core.m: defined using Objective-C + NSDictionary * core_ns = [Core ns]; + for (NSString* key in core_ns) { + [repl_env set:(MalSymbol *)key val:[core_ns objectForKey:key]]; + } + [repl_env set:(MalSymbol *)@"eval" val:^(NSArray *args) { + return EVAL(args[0], repl_env); + }]; + NSArray *argv = @[]; + if ([args count] > 2) { + argv = [args subarrayWithRange:NSMakeRange(2, [args count] - 2)]; + } + [repl_env set:(MalSymbol *)@"*ARGV*" val:argv]; + + // core.mal: defined using the language itself + REP(@"(def! *host-language* \"Objective-C\")", repl_env); + REP(@"(def! not (fn* (a) (if a false true)))", repl_env); + REP(@"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + 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)))))))", repl_env); + + + if ([args count] > 1) { + @try { + REP([NSString stringWithFormat:@"(load-file \"%@\")", args[1]], repl_env); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } + return 0; + } + + while (true) { + char *rawline = _readline("user> "); + if (!rawline) { break; } + NSString *line = [NSString stringWithUTF8String:rawline]; + if ([line length] == 0) { continue; } + @try { + printf("%s\n", [[REP(line, repl_env) description] UTF8String]); + } @catch(NSString *e) { + printf("Error: %s\n", [e UTF8String]); + } @catch(NSObject *e) { + NSObject * exc = e; + printf("Exception: %s\n", [_pr_str(exc, true) UTF8String]); + } @catch(NSException *e) { + if ([[e name] isEqualTo:@"ReaderContinue"]) { continue; } + printf("Exception: %s\n", [[e reason] UTF8String]); + } + } + + [pool drain]; + +// } +} diff --git a/impls/objc/tests/step5_tco.mal b/impls/objc/tests/step5_tco.mal index 0a7e00560c..33b2cc2f85 100644 --- a/impls/objc/tests/step5_tco.mal +++ b/impls/objc/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Objective C: skipping non-TCO recursion -;; Reason: completes at 10,000, unrecoverable segfault at 20,000 +;; Objective C: skipping non-TCO recursion +;; Reason: completes at 10,000, unrecoverable segfault at 20,000 diff --git a/impls/objc/types.h b/impls/objc/types.h index 22b18c6730..aef7df0ee9 100644 --- a/impls/objc/types.h +++ b/impls/objc/types.h @@ -1,94 +1,94 @@ -#import - -// -// Env definition -// - -@class MalSymbol; - -@interface Env : NSObject - -@property (copy) NSMutableDictionary * data; -@property (copy) Env * outer; - -- (id)initWithBindings:(Env *)outer binds:(NSArray *)binds exprs:(NSArray *)exprs; -- (id)initWithOuter:(Env *)outer; -- (id)init; - -+ (id)fromOuter:(Env *)outer; -+ (id)fromBindings:(Env *)outer binds:(NSArray *)binds exprs:(NSArray *)exprs; - -- (NSObject *) set:(MalSymbol *)key val:(NSObject *)val; -- (Env *) find:(MalSymbol *)key; -- (NSObject *) get:(MalSymbol *)key; - -@end - -// -// Mal Types -// - -@interface MalTrue : NSObject -@end - -@interface MalFalse : NSObject -@end - -@interface MalSymbol: NSString -@end - -BOOL string_Q(NSObject * obj); - -// Lists - -BOOL list_Q(id obj); - -NSArray * _rest(NSArray * obj); - - -// Vectors - -@interface MalVector : NSArray - -@property (copy) NSArray * array; -@property(readonly) NSUInteger count; - -- (id)initWithArray:(NSArray *)arr; -- (id)init; - -+ (id)fromArray:(NSArray *)arr; - -- (id)objectAtIndex:(NSUInteger)index; - -@end - - -// Hash Maps - -NSDictionary * assoc_BANG(NSMutableDictionary * d, NSArray * kvs); -NSDictionary * hash_map(NSArray *kvs); - - -// Mal Functions - -BOOL block_Q(id obj); - - -// Atoms - -@interface MalAtom : NSObject - -@property (copy) NSObject * val; - -- (id)init:(NSObject *)val; - -+ (id)fromObject:(NSObject *)val; - -@end - -BOOL atom_Q(id obj); - - -// General functions - -BOOL equal_Q(NSObject * a, NSObject * b); +#import + +// +// Env definition +// + +@class MalSymbol; + +@interface Env : NSObject + +@property (copy) NSMutableDictionary * data; +@property (copy) Env * outer; + +- (id)initWithBindings:(Env *)outer binds:(NSArray *)binds exprs:(NSArray *)exprs; +- (id)initWithOuter:(Env *)outer; +- (id)init; + ++ (id)fromOuter:(Env *)outer; ++ (id)fromBindings:(Env *)outer binds:(NSArray *)binds exprs:(NSArray *)exprs; + +- (NSObject *) set:(MalSymbol *)key val:(NSObject *)val; +- (Env *) find:(MalSymbol *)key; +- (NSObject *) get:(MalSymbol *)key; + +@end + +// +// Mal Types +// + +@interface MalTrue : NSObject +@end + +@interface MalFalse : NSObject +@end + +@interface MalSymbol: NSString +@end + +BOOL string_Q(NSObject * obj); + +// Lists + +BOOL list_Q(id obj); + +NSArray * _rest(NSArray * obj); + + +// Vectors + +@interface MalVector : NSArray + +@property (copy) NSArray * array; +@property(readonly) NSUInteger count; + +- (id)initWithArray:(NSArray *)arr; +- (id)init; + ++ (id)fromArray:(NSArray *)arr; + +- (id)objectAtIndex:(NSUInteger)index; + +@end + + +// Hash Maps + +NSDictionary * assoc_BANG(NSMutableDictionary * d, NSArray * kvs); +NSDictionary * hash_map(NSArray *kvs); + + +// Mal Functions + +BOOL block_Q(id obj); + + +// Atoms + +@interface MalAtom : NSObject + +@property (copy) NSObject * val; + +- (id)init:(NSObject *)val; + ++ (id)fromObject:(NSObject *)val; + +@end + +BOOL atom_Q(id obj); + + +// General functions + +BOOL equal_Q(NSObject * a, NSObject * b); diff --git a/impls/objc/types.m b/impls/objc/types.m index 356c746223..24e00457f3 100644 --- a/impls/objc/types.m +++ b/impls/objc/types.m @@ -1,175 +1,175 @@ -#import "types.h" - -@implementation MalTrue -@end - -@implementation MalFalse -@end - - -// NSString subclassing based on: -// http://stackoverflow.com/a/21331422/471795 - -// Symbols - -@interface MalSymbol () -@property (nonatomic, strong) NSString *stringHolder; -@end - -@implementation MalSymbol - -- (instancetype)initWithCharactersNoCopy:(unichar *)characters length:(NSUInteger)length freeWhenDone:(BOOL)freeBuffer { - self = [super init]; - if (self) { - self.stringHolder = [[NSString alloc] initWithCharactersNoCopy:characters length:length freeWhenDone:freeBuffer]; - } - return self; -} - -- (NSUInteger)length { - return self.stringHolder.length; -} - -- (unichar)characterAtIndex:(NSUInteger)index { - return [self.stringHolder characterAtIndex:index]; -} - -@end - - -BOOL string_Q(id obj) { - if ([obj isKindOfClass:[NSString class]]) { - NSString * s = obj; - if (![s isKindOfClass:[MalSymbol class]]) { - return ![s hasPrefix:@"\u029e"]; - } - } - return false; -} - -// Lists - -BOOL list_Q(id obj) { - return ([obj isKindOfClass:[NSArray class]] && - ![obj isKindOfClass:[MalVector class]]); -} - -NSArray * _rest(NSArray * obj) { - return [obj subarrayWithRange:NSMakeRange(1, [obj count]-1)]; -} - -// Vectors - -@implementation MalVector - -@synthesize array = _array; -@synthesize count = _count; - -- (id)initWithArray:(NSArray *)arr { - self = [self init]; - if (self) { - _array = arr; - _count = [arr count]; - } - return self; -} - -- (id)init { - self = [super init]; - if (self) { - _array = @[]; - _count = 0; - } - return self; -} - -+ (id)fromArray:(NSArray *)arr { - return [[MalVector alloc] initWithArray:arr]; -} - -- (id)objectAtIndex:(NSUInteger)index { - return _array[index]; -} - -- (id)copyWithZone:(NSZone *)zone { - return [[MalVector alloc] initWithArray:[_array copy]]; -} - -@end - - -// Hash Maps - -NSDictionary * assoc_BANG(NSMutableDictionary * d, NSArray * kvs) { - for (int i=0; i < [kvs count]; i+=2) { - d[kvs[i]] = kvs[i+1]; - } - return d; -} - -NSDictionary * hash_map(NSArray *kvs) { - return assoc_BANG([NSMutableDictionary dictionary], kvs); -} - - -// Mal Functions - -BOOL block_Q(id obj) { - id block = ^{}; - Class blockClass = [block class]; - while ([blockClass superclass] != [NSObject class]) { - blockClass = [blockClass superclass]; - } - return [obj isKindOfClass:blockClass]; -} - - - -@implementation MalAtom - -@synthesize val = _val; - -- (id)init:(NSObject *)val { - self = [super init]; - if (self) { - _val = val; - } - return self; -} - -+ (id)fromObject:(NSObject *)val { - return [[MalAtom alloc] init:val]; -} - -@end - -BOOL atom_Q(id obj) { - return [obj isKindOfClass:[MalAtom class]]; -} - -// General functions - -BOOL sequential_Q(NSObject * obj) { - return [obj isKindOfClass:[NSArray class]]; -} - -BOOL equal_Q(NSObject * a, NSObject * b) { - //NSLog(@"= %@ (%@), %@ (%@)", a, [a class], b, [b class]); - if (!(([a class] == [b class]) || - ([a isKindOfClass:[NSArray class]] && - [b isKindOfClass:[NSArray class]]) || - ([a isKindOfClass:[NSNumber class]] && - [b isKindOfClass:[NSNumber class]]) || - (string_Q(a) && string_Q(b)))) { - return false; - } - if ([a isKindOfClass:[MalTrue class]]) { - return true; - } else if ([a isKindOfClass:[MalFalse class]]) { - return true; - } else if ([a isKindOfClass:[NSNumber class]]) { - return [(NSNumber *)a intValue] == [(NSNumber *)b intValue]; - } else { - return [a isEqual:b]; - } -} +#import "types.h" + +@implementation MalTrue +@end + +@implementation MalFalse +@end + + +// NSString subclassing based on: +// http://stackoverflow.com/a/21331422/471795 + +// Symbols + +@interface MalSymbol () +@property (nonatomic, strong) NSString *stringHolder; +@end + +@implementation MalSymbol + +- (instancetype)initWithCharactersNoCopy:(unichar *)characters length:(NSUInteger)length freeWhenDone:(BOOL)freeBuffer { + self = [super init]; + if (self) { + self.stringHolder = [[NSString alloc] initWithCharactersNoCopy:characters length:length freeWhenDone:freeBuffer]; + } + return self; +} + +- (NSUInteger)length { + return self.stringHolder.length; +} + +- (unichar)characterAtIndex:(NSUInteger)index { + return [self.stringHolder characterAtIndex:index]; +} + +@end + + +BOOL string_Q(id obj) { + if ([obj isKindOfClass:[NSString class]]) { + NSString * s = obj; + if (![s isKindOfClass:[MalSymbol class]]) { + return ![s hasPrefix:@"\u029e"]; + } + } + return false; +} + +// Lists + +BOOL list_Q(id obj) { + return ([obj isKindOfClass:[NSArray class]] && + ![obj isKindOfClass:[MalVector class]]); +} + +NSArray * _rest(NSArray * obj) { + return [obj subarrayWithRange:NSMakeRange(1, [obj count]-1)]; +} + +// Vectors + +@implementation MalVector + +@synthesize array = _array; +@synthesize count = _count; + +- (id)initWithArray:(NSArray *)arr { + self = [self init]; + if (self) { + _array = arr; + _count = [arr count]; + } + return self; +} + +- (id)init { + self = [super init]; + if (self) { + _array = @[]; + _count = 0; + } + return self; +} + ++ (id)fromArray:(NSArray *)arr { + return [[MalVector alloc] initWithArray:arr]; +} + +- (id)objectAtIndex:(NSUInteger)index { + return _array[index]; +} + +- (id)copyWithZone:(NSZone *)zone { + return [[MalVector alloc] initWithArray:[_array copy]]; +} + +@end + + +// Hash Maps + +NSDictionary * assoc_BANG(NSMutableDictionary * d, NSArray * kvs) { + for (int i=0; i < [kvs count]; i+=2) { + d[kvs[i]] = kvs[i+1]; + } + return d; +} + +NSDictionary * hash_map(NSArray *kvs) { + return assoc_BANG([NSMutableDictionary dictionary], kvs); +} + + +// Mal Functions + +BOOL block_Q(id obj) { + id block = ^{}; + Class blockClass = [block class]; + while ([blockClass superclass] != [NSObject class]) { + blockClass = [blockClass superclass]; + } + return [obj isKindOfClass:blockClass]; +} + + + +@implementation MalAtom + +@synthesize val = _val; + +- (id)init:(NSObject *)val { + self = [super init]; + if (self) { + _val = val; + } + return self; +} + ++ (id)fromObject:(NSObject *)val { + return [[MalAtom alloc] init:val]; +} + +@end + +BOOL atom_Q(id obj) { + return [obj isKindOfClass:[MalAtom class]]; +} + +// General functions + +BOOL sequential_Q(NSObject * obj) { + return [obj isKindOfClass:[NSArray class]]; +} + +BOOL equal_Q(NSObject * a, NSObject * b) { + //NSLog(@"= %@ (%@), %@ (%@)", a, [a class], b, [b class]); + if (!(([a class] == [b class]) || + ([a isKindOfClass:[NSArray class]] && + [b isKindOfClass:[NSArray class]]) || + ([a isKindOfClass:[NSNumber class]] && + [b isKindOfClass:[NSNumber class]]) || + (string_Q(a) && string_Q(b)))) { + return false; + } + if ([a isKindOfClass:[MalTrue class]]) { + return true; + } else if ([a isKindOfClass:[MalFalse class]]) { + return true; + } else if ([a isKindOfClass:[NSNumber class]]) { + return [(NSNumber *)a intValue] == [(NSNumber *)b intValue]; + } else { + return [a isEqual:b]; + } +} diff --git a/impls/objpascal/Dockerfile b/impls/objpascal/Dockerfile index 31bb193b10..0494b800b4 100644 --- a/impls/objpascal/Dockerfile +++ b/impls/objpascal/Dockerfile @@ -1,25 +1,25 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Free Pascal -RUN apt-get -y install libc6-dev fp-compiler +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Free Pascal +RUN apt-get -y install libc6-dev fp-compiler diff --git a/impls/objpascal/Makefile b/impls/objpascal/Makefile index b8efc48c43..5f61efd236 100644 --- a/impls/objpascal/Makefile +++ b/impls/objpascal/Makefile @@ -1,31 +1,31 @@ -STEPS = step0_repl.pas step1_read_print.pas step2_eval.pas \ - step3_env.pas step4_if_fn_do.pas step5_tco.pas \ - step6_file.pas step7_quote.pas step8_macros.pas \ - step9_try.pas stepA_mal.pas - -STEP0_DEPS = mal_readline.pas -STEP1_DEPS = $(STEP0_DEPS) mal_types.pas reader.pas printer.pas -STEP3_DEPS = $(STEP1_DEPS) mal_env.pas -STEP4_DEPS = $(STEP3_DEPS) core.pas - -##################### - -DEBUG = -gl - -# Set this to link with libreadline instead of libedit -USE_READLINE = - -FPC = fpc -MOBJFPC -ve -Furegexpr/Source $(DEBUG) $(if $(strip $(USE_READLINE)),-dUSE_READLINE,) - -all: $(patsubst %.pas,%,$(STEPS)) - -step%: step%.pas - $(FPC) $< - -step0_repl: $(STEP0_DEPS) -step1_read_print step2_eval: $(STEP1_DEPS) -step3_env: $(STEP3_DEPS) -step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) - -clean: - rm -f $(STEPS:%.pas=%) *.o *.ppu regexpr/Source/*.o regexpr/Source/*.ppu mal +STEPS = step0_repl.pas step1_read_print.pas step2_eval.pas \ + step3_env.pas step4_if_fn_do.pas step5_tco.pas \ + step6_file.pas step7_quote.pas step8_macros.pas \ + step9_try.pas stepA_mal.pas + +STEP0_DEPS = mal_readline.pas +STEP1_DEPS = $(STEP0_DEPS) mal_types.pas reader.pas printer.pas +STEP3_DEPS = $(STEP1_DEPS) mal_env.pas +STEP4_DEPS = $(STEP3_DEPS) core.pas + +##################### + +DEBUG = -gl + +# Set this to link with libreadline instead of libedit +USE_READLINE = + +FPC = fpc -MOBJFPC -ve -Furegexpr/Source $(DEBUG) $(if $(strip $(USE_READLINE)),-dUSE_READLINE,) + +all: $(patsubst %.pas,%,$(STEPS)) + +step%: step%.pas + $(FPC) $< + +step0_repl: $(STEP0_DEPS) +step1_read_print step2_eval: $(STEP1_DEPS) +step3_env: $(STEP3_DEPS) +step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) + +clean: + rm -f $(STEPS:%.pas=%) *.o *.ppu regexpr/Source/*.o regexpr/Source/*.ppu mal diff --git a/impls/objpascal/core.pas b/impls/objpascal/core.pas index d51374c57f..1d7c6f128c 100644 --- a/impls/objpascal/core.pas +++ b/impls/objpascal/core.pas @@ -1,632 +1,632 @@ -unit core; - -{$H+} // Use AnsiString - -interface - -uses Classes, - sysutils, - fgl, - mal_readline, - mal_types, - mal_func, - mal_env, - reader, - printer; - -type - TCoreDict = specialize TFPGMap; - -var - EVAL : function (A: TMal; E: TEnv) : TMal; - NS : TCoreDict; - -//////////////////////////////////////////////////////////// - -implementation - -// General functions - -function equal_Q(Args: TMalArray) : TMal; -begin - equal_Q := wrap_tf(_equal_Q(Args[0], Args[1])); -end; - -function throw(Args: TMalArray) : TMal; -begin - raise TMalException.Create(Args[0]); - throw := TMalNil.Create; // Not reached -end; - -// Scalar functions - -function nil_Q(Args: TMalArray) : TMal; -begin - nil_Q := wrap_tf(Args[0] is TMalNil); -end; -function true_Q(Args: TMalArray) : TMal; -begin - true_Q := wrap_tf(Args[0] is TMalTrue); -end; -function false_Q(Args: TMalArray) : TMal; -begin - false_Q := wrap_tf(Args[0] is TMalFalse); -end; -function number_Q(Args: TMalArray) : TMal; -begin - number_Q := wrap_tf(Args[0] is TMalInt); -end; -function string_Q(Args: TMalArray) : TMal; -begin - string_Q := wrap_tf(_string_Q(Args[0])); -end; -function symbol(Args: TMalArray) : TMal; -begin - if Args[0] is TMalSymbol then - symbol := Args[0] - else if Args[0] is TMalString then - symbol := TMalSymbol.Create((Args[0] as TMalString).Val) - else - raise Exception.Create('Invalid symbol call'); -end; -function symbol_Q(Args: TMalArray) : TMal; -begin - symbol_Q := wrap_tf(Args[0] is TMalSymbol); -end; -function keyword(Args: TMalArray) : TMal; -begin - if ((Args[0] is TMalString) and not _string_Q(Args[0])) then - keyword := Args[0] - else if Args[0] is TMalString then - keyword := TMalString.Create(#127 + (Args[0] as TMalString).Val) - else - raise Exception.Create('Invalid keyword call'); -end; -function keyword_Q(Args: TMalArray) : TMal; -begin - keyword_Q := wrap_tf((Args[0] is TMalString) and not _string_Q(Args[0])); -end; -function fn_Q(Args: TMalArray) : TMal; -begin - if Args[0] is TMalFunc then - fn_Q := wrap_tf(not (Args[0] as TMalFunc).isMacro) - else - fn_Q := TMalFalse.Create; -end; - -function macro_Q(Args: TMalArray) : TMal; -begin - if Args[0] is TMalFunc then - macro_Q := wrap_tf((Args[0] as TMalFunc).isMacro) - else - macro_Q := TMalFalse.Create; -end; - - -// String functions - -function do_pr_str(Args: TMalArray) : TMal; -begin - do_pr_str := TMalString.Create(pr_str_array(Args, true, ' ')); -end; -function str(Args: TMalArray) : TMal; -begin - str := TMalString.Create(pr_str_array(Args, false, '')); -end; -function prn(Args: TMalArray) : TMal; -begin - WriteLn(pr_str_array(Args, true, ' ')); - prn := TMalNil.Create; -end; -function println(Args: TMalArray) : TMal; -begin - WriteLn(pr_str_array(Args, false, ' ')); - println := TMalNil.Create; -end; - -function read_string(Args: TMalArray) : TMal; -begin - read_string := read_str((Args[0] as TMalString).Val); -end; -function do_readline(Args: TMalArray) : TMal; -var - Prompt : string; - Line : string; -begin - Prompt := (Args[0] as TMalString).Val; - try - Line := _readline(Prompt); - do_readline := TMalString.Create(Line); - except - On E : MalEOF do do_readline := TMalNil.Create; - end; -end; -function slurp(Args: TMalArray) : TMal; -var - StrL : TStringList; -begin - StrL := TStringList.Create; - StrL.LoadFromFile((Args[0] as TMalString).Val); - slurp := TMalString.Create(StrL.Text); -end; - -// Math functions - -function lt(Args: TMalArray) : TMal; -begin - lt := wrap_tf((Args[0] as TMalInt).Val < (Args[1] as TMalInt).Val); -end; -function lte(Args: TMalArray) : TMal; -begin - lte := wrap_tf((Args[0] as TMalInt).Val <= (Args[1] as TMalInt).Val); -end; -function gt(Args: TMalArray) : TMal; -begin - gt := wrap_tf((Args[0] as TMalInt).Val > (Args[1] as TMalInt).Val); -end; -function gte(Args: TMalArray) : TMal; -begin - gte := wrap_tf((Args[0] as TMalInt).Val >= (Args[1] as TMalInt).Val); -end; - -function add(Args: TMalArray) : TMal; -begin - add := TMalInt.Create((Args[0] as TMalInt).Val + - (Args[1] as TMalInt).Val); -end; -function subtract(Args: TMalArray) : TMal; -begin - subtract := TMalInt.Create((Args[0] as TMalInt).Val - - (Args[1] as TMalInt).Val); -end; -function multiply(Args: TMalArray) : TMal; -begin - multiply := TMalInt.Create((Args[0] as TMalInt).Val * - (Args[1] as TMalInt).Val); -end; -function divide(Args: TMalArray) : TMal; -begin - divide := TMalInt.Create((Args[0] as TMalInt).Val div - (Args[1] as TMalInt).Val); -end; -function time_ms(Args: TMalArray) : TMal; -begin - time_ms := TMalInt.Create(Trunc(TimeStampToMSecs(DateTimeToTimeStamp(Now)))); -end; - -// Collection functions - -function list(Args: TMalArray) : TMal; -begin - list := TMalList.Create(Args); -end; -function list_Q(Args: TMalArray) : TMal; -begin - list_Q := wrap_tf(Args[0].ClassType = TMalList); -end; -function vec(Args: TMalArray) : TMal; -begin - vec := TMalVector.Create((Args[0] as TMalList).Val); -end; -function vector(Args: TMalArray) : TMal; -begin - vector := TMalVector.Create(Args); -end; -function vector_Q(Args: TMalArray) : TMal; -begin - vector_Q := wrap_tf(Args[0].ClassType = TMalVector); -end; -function hash_map(Args: TMalArray) : TMal; -begin - hash_map := TMalHashMap.Create(Args); -end; -function map_Q(Args: TMalArray) : TMal; -begin - map_Q := wrap_tf(Args[0].ClassType = TMalHashMap); -end; -function assoc(Args: TMalArray) : TMal; -var - OrigHM, NewHM : TMalHashMap; -begin - OrigHM := (Args[0] as TMalHashMap); - NewHM := TMalHashMap.Clone(OrigHM); - assoc := NewHM.assoc_BANG(copy(Args, 1, Length(Args))); -end; -function dissoc(Args: TMalArray) : TMal; -var - OrigHM, NewHM : TMalHashMap; -begin - OrigHM := (Args[0] as TMalHashMap); - NewHM := TMalHashMap.Clone(OrigHM); - dissoc := NewHM.dissoc_BANG(copy(Args, 1, Length(Args))); -end; -function get(Args: TMalArray) : TMal; -var - HM : TMalHashMap; -begin - if Args[0] is TMalNil then Exit(TMalNil.Create); - HM := (Args[0] as TMalHashMap); - if HM.Val.IndexOf((Args[1] as TMalString).Val) >= 0 then - get := HM.Val[(Args[1] as TMalString).Val] - else - get := TMalNil.Create; -end; -function contains_Q(Args: TMalArray) : TMal; -var - HM : TMalHashMap; -begin - if Args[0] is TMalNil then Exit(TMalFalse.Create); - HM := (Args[0] as TMalHashMap); - contains_Q := wrap_tf(HM.Val.IndexOf((Args[1] as TMalString).Val) >= 0); -end; -function keys(Args: TMalArray) : TMal; -var - Dict : TMalDict; - Arr : TMalArray; - I : longint; -begin - Dict := (Args[0] as TMalHashMap).Val; - SetLength(Arr, Dict.Count); - for I := 0 to Dict.Count-1 do - Arr[I] := TMalString.Create(Dict.Keys[I]); - keys := TMalList.Create(Arr); -end; -function vals(Args: TMalArray) : TMal; -var - Dict : TMalDict; - Arr : TMalArray; - I : longint; -begin - Dict := (Args[0] as TMalHashMap).Val; - SetLength(Arr, Dict.Count); - for I := 0 to Dict.Count-1 do - Arr[I] := Dict[Dict.Keys[I]]; - vals := TMalList.Create(Arr); -end; - - -// Sequence functions - -function sequential_Q(Args: TMalArray) : TMal; -begin - sequential_Q := wrap_tf(_sequential_Q(Args[0])); -end; -function cons(Args: TMalArray) : TMal; -var - Res, Src : TMalArray; - I : longint; -begin - Src := (Args[1] as TMalList).Val; - SetLength(Res, 1 + Length(Src)); - Res[0] := Args[0]; - for I := 1 to Length(Src) do - Res[I] := Src[I-1]; - cons := TMalList.Create(Res); -end; -function do_concat(Args: TMalArray) : TMal; -var - Res : TMalArray; - I : longint; -begin - SetLength(Res, 0); - for I := 0 to Length(Args)-1 do - begin - Res := _concat(Res, (Args[I] as TMalList).Val); - end; - do_concat := TMalList.Create(Res); -end; -function nth(Args: TMalArray) : TMal; -var - Arr : TMalArray; - Idx : longint; -begin - Arr := (Args[0] as TMalList).Val; - Idx := (Args[1] as TMalInt).Val; - if Idx >= Length(Arr) then - raise Exception.Create('nth: index out of range') - else - nth := Arr[Idx]; -end; -function first(Args: TMalArray) : TMal; -var - Arr : TMalArray; -begin - if Args[0] is TMalNil then Exit(TMalNil.Create); - Arr := (Args[0] as TMalList).Val; - if Length(Arr) = 0 then - first := TMalNil.Create - else - first := (Args[0] as TMalList).Val[0]; -end; -function rest(Args: TMalArray) : TMal; -begin - if Args[0] is TMalNil then Exit(_list()); - rest := (Args[0] as TMalList).Rest(); -end; - -function empty_Q(Args: TMalArray) : TMal; -begin - if Args[0] is TMalNil then - empty_Q := TMalTrue.Create - else if Args[0] is TMalList then - empty_Q := wrap_tf(Length((Args[0] as TMalList).Val) = 0) - else raise Exception.Create('invalid empty? call'); -end; -function count(Args: TMalArray) : TMal; -begin - if Args[0] is TMalNil then - count := TMalInt.Create(0) - else if Args[0] is TMalList then - count := TMalInt.Create(Length((Args[0] as TMalList).Val)) - else raise Exception.Create('invalid count call'); -end; - -function map(Args: TMalArray) : TMal; -var - Fn : TMalFunc; - FArgs : TMalArray; - Src, Res : TMalArray; - I : longint; -begin - Fn := (Args[0] as TMalFunc); - Src := (Args[1] as TMalList).Val; - SetLength(FArgs, 1); - SetLength(Res, Length(Src)); - if Fn.Ast = nil then - for I := 0 to Length(Src)-1 do - begin - FArgs[0] := Src[I]; - Res[I] := Fn.Val(FArgs); - end - else - for I := 0 to Length(Src)-1 do - begin - FArgs[0] := Src[I]; - Res[I] := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs)); - end; - map := TMalList.Create(Res); -end; -function apply(Args: TMalArray) : TMal; -var - Fn : TMalFunc; - LastArgs : TMalArray; - FArgs : TMalArray; - I : longint; -begin - Fn := (Args[0] as TMalFunc); - LastArgs := (Args[Length(Args)-1] as TMalList).Val; - SetLength(FArgs, Length(LastArgs) + Length(Args) - 2); - for I := 0 to Length(Args)-3 do - FArgs[I] := Args[I+1]; - for I := 0 to Length(LastArgs)-1 do - FArgs[Length(Args)-2 + I] := LastArgs[I]; - if Fn.Ast = nil then - apply := Fn.Val(FArgs) - else - apply := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs)); -end; - -function conj(Args: TMalArray) : TMal; -var - I : longint; - Vals : TMalArray; -begin - if Args[0] is TMalVector then - conj := TMalVector.Create(_concat((Args[0] as TMalList).Val, - copy(Args, 1, Length(Args)))) - else if Args[0] is TMalList then - begin - SetLength(Vals, Length(Args)-1); - for I := 1 to Length(Args)-1 do - Vals[I-1] := Args[Length(Args) - I]; - conj := TMalList.Create(_concat(Vals, (Args[0] as TMalList).Val)); - end - else - raise Exception.Create('conj: called on non-sequence'); -end; -function seq(Args: TMalArray) : TMal; -var - Str : string; - Arr : TMalArray; - I : longint; -begin - if Args[0] is TMalVector then - begin - if Length((Args[0] as TMalVector).Val) = 0 then - Exit(TMalNil.Create); - seq := TMalList.Create((Args[0] as TMalVector).Val); - end - else if Args[0] is TMalList then - begin - if Length((Args[0] as TMalList).Val) = 0 then - Exit(TMalNil.Create); - seq := Args[0] - end - else if _string_Q(Args[0]) then - begin - Str := (Args[0] as TMalString).Val; - if Length(Str) = 0 then - Exit(TMalNil.Create); - SetLength(Arr, Length(Str)); - for I := 0 to Length(Str) do - Arr[I] := TMalString.Create(Str[I+1]); - seq := TMalList.Create(Arr); - end - else if Args[0] is TMalNil then - begin - seq := Args[0]; - end - else - raise Exception.Create('seq: called on non-sequence'); -end; - - -// Metadata functions - -function meta(Args: TMalArray) : TMal; -begin - if Args[0] is TMalFunc then - meta := (Args[0] as TMalFunc).Meta - else if Args[0] is TMalList then - meta := (Args[0] as TMalList).Meta - else if Args[0] is TMalHashMap then - meta := (Args[0] as TMalHashMap).Meta - else - raise Exception.Create('meta not supported on ' + Args[0].ClassName); - - if meta = nil then - meta := TMalNil.Create; -end; -function with_meta(Args: TMalArray) : TMal; -var - Fn : TMalFunc; - Vec : TMalVector; - Lst : TMalList; - HM : TMalHashMap; -begin - if Args[0] is TMalFunc then - begin - Fn := TMalFunc.Clone(Args[0] as TMalFunc); - Fn.Meta := Args[1]; - with_meta := Fn; - end - else if Args[0] is TMalVector then - begin - Vec := TMalVector.Clone(Args[0] as TMalVector); - Vec.Meta := Args[1]; - with_meta := Vec; - end - else if Args[0] is TMalList then - begin - Lst := TMalList.Clone(Args[0] as TMalList); - Lst.Meta := Args[1]; - with_meta := Lst; - end - else if Args[0] is TMalHashMap then - begin - HM := TMalHashMap.Clone(Args[0] as TMalHashMap); - HM.Meta := Args[1]; - with_meta := HM; - end - else - raise Exception.Create('with-meta call on non-mal function'); -end; - -// Atom functions - -function atom(Args: TMalArray) : TMal; -begin - atom := TMalAtom.Create(Args[0]); -end; -function atom_Q(Args: TMalArray) : TMal; -begin - atom_Q := wrap_tf(Args[0] is TMalAtom); -end; -function deref(Args: TMalArray) : TMal; -begin - deref := (Args[0] as TMalAtom).Val; -end; -function reset_BANG(Args: TMalArray) : TMal; -begin - (Args[0] as TMalAtom).Val := Args[1]; - reset_BANG := Args[1]; -end; - -function swap_BANG(Args: TMalArray) : TMal; -var - Atm : TMalAtom; - Fn : TMalFunc; - FArgs : TMalArray; - I : longint; -begin - Atm := (Args[0] as TMalAtom); - Fn := (Args[1] as TMalFunc); - SetLength(FArgs, Length(Args)-1); - FArgs[0] := Atm.Val; - for I := 1 to Length(Args)-2 do - FArgs[I] := Args[I+1]; - - if Fn.Ast = nil then - Atm.Val := Fn.Val(FArgs) - else - Atm.Val := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs)); - swap_BANG := Atm.Val; -end; - - -//////////////////////////////////////////////////////////// - -initialization -begin - NS := TCoreDict.Create; - NS['='] := @equal_Q; - NS['throw'] := @throw; - - NS['nil?'] := @nil_Q; - NS['true?'] := @true_Q; - NS['false?'] := @false_Q; - NS['number?'] := @number_Q; - NS['string?'] := @string_Q; - NS['symbol'] := @symbol; - NS['symbol?'] := @symbol_Q; - NS['keyword'] := @keyword; - NS['keyword?'] := @keyword_Q; - NS['fn?'] := @fn_Q; - NS['macro?'] := @macro_Q; - - NS['pr-str'] := @do_pr_str; - NS['str'] := @str; - NS['prn'] := @prn; - NS['println'] := @println; - NS['read-string'] := @read_string; - NS['readline'] := @do_readline; - NS['slurp'] := @slurp; - - NS['<'] := @lt; - NS['<='] := @lte; - NS['>'] := @gt; - NS['>='] := @gte; - NS['+'] := @add; - NS['-'] := @subtract; - NS['*'] := @multiply; - NS['/'] := @divide; - NS['time-ms'] := @time_ms; - - NS['list'] := @list; - NS['list?'] := @list_Q; - NS['vector'] := @vector; - NS['vector?'] := @vector_Q; - NS['hash-map'] := @hash_map; - NS['map?'] := @map_Q; - NS['assoc'] := @assoc; - NS['dissoc'] := @dissoc; - NS['get'] := @get; - NS['contains?'] := @contains_Q; - NS['keys'] := @keys; - NS['vals'] := @vals; - - NS['sequential?'] := @sequential_Q; - NS['cons'] := @cons; - NS['concat'] := @do_concat; - NS['vec'] := @vec; - NS['nth'] := @nth; - NS['first'] := @first; - NS['rest'] := @rest; - NS['empty?'] := @empty_Q; - NS['count'] := @count; - NS['apply'] := @apply; - NS['map'] := @map; - - NS['conj'] := @conj; - NS['seq'] := @seq; - - NS['meta'] := @meta; - NS['with-meta'] := @with_meta; - NS['atom'] := @atom; - NS['atom?'] := @atom_Q; - NS['deref'] := @deref; - NS['reset!'] := @reset_BANG; - NS['swap!'] := @swap_BANG; -end - -end. +unit core; + +{$H+} // Use AnsiString + +interface + +uses Classes, + sysutils, + fgl, + mal_readline, + mal_types, + mal_func, + mal_env, + reader, + printer; + +type + TCoreDict = specialize TFPGMap; + +var + EVAL : function (A: TMal; E: TEnv) : TMal; + NS : TCoreDict; + +//////////////////////////////////////////////////////////// + +implementation + +// General functions + +function equal_Q(Args: TMalArray) : TMal; +begin + equal_Q := wrap_tf(_equal_Q(Args[0], Args[1])); +end; + +function throw(Args: TMalArray) : TMal; +begin + raise TMalException.Create(Args[0]); + throw := TMalNil.Create; // Not reached +end; + +// Scalar functions + +function nil_Q(Args: TMalArray) : TMal; +begin + nil_Q := wrap_tf(Args[0] is TMalNil); +end; +function true_Q(Args: TMalArray) : TMal; +begin + true_Q := wrap_tf(Args[0] is TMalTrue); +end; +function false_Q(Args: TMalArray) : TMal; +begin + false_Q := wrap_tf(Args[0] is TMalFalse); +end; +function number_Q(Args: TMalArray) : TMal; +begin + number_Q := wrap_tf(Args[0] is TMalInt); +end; +function string_Q(Args: TMalArray) : TMal; +begin + string_Q := wrap_tf(_string_Q(Args[0])); +end; +function symbol(Args: TMalArray) : TMal; +begin + if Args[0] is TMalSymbol then + symbol := Args[0] + else if Args[0] is TMalString then + symbol := TMalSymbol.Create((Args[0] as TMalString).Val) + else + raise Exception.Create('Invalid symbol call'); +end; +function symbol_Q(Args: TMalArray) : TMal; +begin + symbol_Q := wrap_tf(Args[0] is TMalSymbol); +end; +function keyword(Args: TMalArray) : TMal; +begin + if ((Args[0] is TMalString) and not _string_Q(Args[0])) then + keyword := Args[0] + else if Args[0] is TMalString then + keyword := TMalString.Create(#127 + (Args[0] as TMalString).Val) + else + raise Exception.Create('Invalid keyword call'); +end; +function keyword_Q(Args: TMalArray) : TMal; +begin + keyword_Q := wrap_tf((Args[0] is TMalString) and not _string_Q(Args[0])); +end; +function fn_Q(Args: TMalArray) : TMal; +begin + if Args[0] is TMalFunc then + fn_Q := wrap_tf(not (Args[0] as TMalFunc).isMacro) + else + fn_Q := TMalFalse.Create; +end; + +function macro_Q(Args: TMalArray) : TMal; +begin + if Args[0] is TMalFunc then + macro_Q := wrap_tf((Args[0] as TMalFunc).isMacro) + else + macro_Q := TMalFalse.Create; +end; + + +// String functions + +function do_pr_str(Args: TMalArray) : TMal; +begin + do_pr_str := TMalString.Create(pr_str_array(Args, true, ' ')); +end; +function str(Args: TMalArray) : TMal; +begin + str := TMalString.Create(pr_str_array(Args, false, '')); +end; +function prn(Args: TMalArray) : TMal; +begin + WriteLn(pr_str_array(Args, true, ' ')); + prn := TMalNil.Create; +end; +function println(Args: TMalArray) : TMal; +begin + WriteLn(pr_str_array(Args, false, ' ')); + println := TMalNil.Create; +end; + +function read_string(Args: TMalArray) : TMal; +begin + read_string := read_str((Args[0] as TMalString).Val); +end; +function do_readline(Args: TMalArray) : TMal; +var + Prompt : string; + Line : string; +begin + Prompt := (Args[0] as TMalString).Val; + try + Line := _readline(Prompt); + do_readline := TMalString.Create(Line); + except + On E : MalEOF do do_readline := TMalNil.Create; + end; +end; +function slurp(Args: TMalArray) : TMal; +var + StrL : TStringList; +begin + StrL := TStringList.Create; + StrL.LoadFromFile((Args[0] as TMalString).Val); + slurp := TMalString.Create(StrL.Text); +end; + +// Math functions + +function lt(Args: TMalArray) : TMal; +begin + lt := wrap_tf((Args[0] as TMalInt).Val < (Args[1] as TMalInt).Val); +end; +function lte(Args: TMalArray) : TMal; +begin + lte := wrap_tf((Args[0] as TMalInt).Val <= (Args[1] as TMalInt).Val); +end; +function gt(Args: TMalArray) : TMal; +begin + gt := wrap_tf((Args[0] as TMalInt).Val > (Args[1] as TMalInt).Val); +end; +function gte(Args: TMalArray) : TMal; +begin + gte := wrap_tf((Args[0] as TMalInt).Val >= (Args[1] as TMalInt).Val); +end; + +function add(Args: TMalArray) : TMal; +begin + add := TMalInt.Create((Args[0] as TMalInt).Val + + (Args[1] as TMalInt).Val); +end; +function subtract(Args: TMalArray) : TMal; +begin + subtract := TMalInt.Create((Args[0] as TMalInt).Val - + (Args[1] as TMalInt).Val); +end; +function multiply(Args: TMalArray) : TMal; +begin + multiply := TMalInt.Create((Args[0] as TMalInt).Val * + (Args[1] as TMalInt).Val); +end; +function divide(Args: TMalArray) : TMal; +begin + divide := TMalInt.Create((Args[0] as TMalInt).Val div + (Args[1] as TMalInt).Val); +end; +function time_ms(Args: TMalArray) : TMal; +begin + time_ms := TMalInt.Create(Trunc(TimeStampToMSecs(DateTimeToTimeStamp(Now)))); +end; + +// Collection functions + +function list(Args: TMalArray) : TMal; +begin + list := TMalList.Create(Args); +end; +function list_Q(Args: TMalArray) : TMal; +begin + list_Q := wrap_tf(Args[0].ClassType = TMalList); +end; +function vec(Args: TMalArray) : TMal; +begin + vec := TMalVector.Create((Args[0] as TMalList).Val); +end; +function vector(Args: TMalArray) : TMal; +begin + vector := TMalVector.Create(Args); +end; +function vector_Q(Args: TMalArray) : TMal; +begin + vector_Q := wrap_tf(Args[0].ClassType = TMalVector); +end; +function hash_map(Args: TMalArray) : TMal; +begin + hash_map := TMalHashMap.Create(Args); +end; +function map_Q(Args: TMalArray) : TMal; +begin + map_Q := wrap_tf(Args[0].ClassType = TMalHashMap); +end; +function assoc(Args: TMalArray) : TMal; +var + OrigHM, NewHM : TMalHashMap; +begin + OrigHM := (Args[0] as TMalHashMap); + NewHM := TMalHashMap.Clone(OrigHM); + assoc := NewHM.assoc_BANG(copy(Args, 1, Length(Args))); +end; +function dissoc(Args: TMalArray) : TMal; +var + OrigHM, NewHM : TMalHashMap; +begin + OrigHM := (Args[0] as TMalHashMap); + NewHM := TMalHashMap.Clone(OrigHM); + dissoc := NewHM.dissoc_BANG(copy(Args, 1, Length(Args))); +end; +function get(Args: TMalArray) : TMal; +var + HM : TMalHashMap; +begin + if Args[0] is TMalNil then Exit(TMalNil.Create); + HM := (Args[0] as TMalHashMap); + if HM.Val.IndexOf((Args[1] as TMalString).Val) >= 0 then + get := HM.Val[(Args[1] as TMalString).Val] + else + get := TMalNil.Create; +end; +function contains_Q(Args: TMalArray) : TMal; +var + HM : TMalHashMap; +begin + if Args[0] is TMalNil then Exit(TMalFalse.Create); + HM := (Args[0] as TMalHashMap); + contains_Q := wrap_tf(HM.Val.IndexOf((Args[1] as TMalString).Val) >= 0); +end; +function keys(Args: TMalArray) : TMal; +var + Dict : TMalDict; + Arr : TMalArray; + I : longint; +begin + Dict := (Args[0] as TMalHashMap).Val; + SetLength(Arr, Dict.Count); + for I := 0 to Dict.Count-1 do + Arr[I] := TMalString.Create(Dict.Keys[I]); + keys := TMalList.Create(Arr); +end; +function vals(Args: TMalArray) : TMal; +var + Dict : TMalDict; + Arr : TMalArray; + I : longint; +begin + Dict := (Args[0] as TMalHashMap).Val; + SetLength(Arr, Dict.Count); + for I := 0 to Dict.Count-1 do + Arr[I] := Dict[Dict.Keys[I]]; + vals := TMalList.Create(Arr); +end; + + +// Sequence functions + +function sequential_Q(Args: TMalArray) : TMal; +begin + sequential_Q := wrap_tf(_sequential_Q(Args[0])); +end; +function cons(Args: TMalArray) : TMal; +var + Res, Src : TMalArray; + I : longint; +begin + Src := (Args[1] as TMalList).Val; + SetLength(Res, 1 + Length(Src)); + Res[0] := Args[0]; + for I := 1 to Length(Src) do + Res[I] := Src[I-1]; + cons := TMalList.Create(Res); +end; +function do_concat(Args: TMalArray) : TMal; +var + Res : TMalArray; + I : longint; +begin + SetLength(Res, 0); + for I := 0 to Length(Args)-1 do + begin + Res := _concat(Res, (Args[I] as TMalList).Val); + end; + do_concat := TMalList.Create(Res); +end; +function nth(Args: TMalArray) : TMal; +var + Arr : TMalArray; + Idx : longint; +begin + Arr := (Args[0] as TMalList).Val; + Idx := (Args[1] as TMalInt).Val; + if Idx >= Length(Arr) then + raise Exception.Create('nth: index out of range') + else + nth := Arr[Idx]; +end; +function first(Args: TMalArray) : TMal; +var + Arr : TMalArray; +begin + if Args[0] is TMalNil then Exit(TMalNil.Create); + Arr := (Args[0] as TMalList).Val; + if Length(Arr) = 0 then + first := TMalNil.Create + else + first := (Args[0] as TMalList).Val[0]; +end; +function rest(Args: TMalArray) : TMal; +begin + if Args[0] is TMalNil then Exit(_list()); + rest := (Args[0] as TMalList).Rest(); +end; + +function empty_Q(Args: TMalArray) : TMal; +begin + if Args[0] is TMalNil then + empty_Q := TMalTrue.Create + else if Args[0] is TMalList then + empty_Q := wrap_tf(Length((Args[0] as TMalList).Val) = 0) + else raise Exception.Create('invalid empty? call'); +end; +function count(Args: TMalArray) : TMal; +begin + if Args[0] is TMalNil then + count := TMalInt.Create(0) + else if Args[0] is TMalList then + count := TMalInt.Create(Length((Args[0] as TMalList).Val)) + else raise Exception.Create('invalid count call'); +end; + +function map(Args: TMalArray) : TMal; +var + Fn : TMalFunc; + FArgs : TMalArray; + Src, Res : TMalArray; + I : longint; +begin + Fn := (Args[0] as TMalFunc); + Src := (Args[1] as TMalList).Val; + SetLength(FArgs, 1); + SetLength(Res, Length(Src)); + if Fn.Ast = nil then + for I := 0 to Length(Src)-1 do + begin + FArgs[0] := Src[I]; + Res[I] := Fn.Val(FArgs); + end + else + for I := 0 to Length(Src)-1 do + begin + FArgs[0] := Src[I]; + Res[I] := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs)); + end; + map := TMalList.Create(Res); +end; +function apply(Args: TMalArray) : TMal; +var + Fn : TMalFunc; + LastArgs : TMalArray; + FArgs : TMalArray; + I : longint; +begin + Fn := (Args[0] as TMalFunc); + LastArgs := (Args[Length(Args)-1] as TMalList).Val; + SetLength(FArgs, Length(LastArgs) + Length(Args) - 2); + for I := 0 to Length(Args)-3 do + FArgs[I] := Args[I+1]; + for I := 0 to Length(LastArgs)-1 do + FArgs[Length(Args)-2 + I] := LastArgs[I]; + if Fn.Ast = nil then + apply := Fn.Val(FArgs) + else + apply := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs)); +end; + +function conj(Args: TMalArray) : TMal; +var + I : longint; + Vals : TMalArray; +begin + if Args[0] is TMalVector then + conj := TMalVector.Create(_concat((Args[0] as TMalList).Val, + copy(Args, 1, Length(Args)))) + else if Args[0] is TMalList then + begin + SetLength(Vals, Length(Args)-1); + for I := 1 to Length(Args)-1 do + Vals[I-1] := Args[Length(Args) - I]; + conj := TMalList.Create(_concat(Vals, (Args[0] as TMalList).Val)); + end + else + raise Exception.Create('conj: called on non-sequence'); +end; +function seq(Args: TMalArray) : TMal; +var + Str : string; + Arr : TMalArray; + I : longint; +begin + if Args[0] is TMalVector then + begin + if Length((Args[0] as TMalVector).Val) = 0 then + Exit(TMalNil.Create); + seq := TMalList.Create((Args[0] as TMalVector).Val); + end + else if Args[0] is TMalList then + begin + if Length((Args[0] as TMalList).Val) = 0 then + Exit(TMalNil.Create); + seq := Args[0] + end + else if _string_Q(Args[0]) then + begin + Str := (Args[0] as TMalString).Val; + if Length(Str) = 0 then + Exit(TMalNil.Create); + SetLength(Arr, Length(Str)); + for I := 0 to Length(Str) do + Arr[I] := TMalString.Create(Str[I+1]); + seq := TMalList.Create(Arr); + end + else if Args[0] is TMalNil then + begin + seq := Args[0]; + end + else + raise Exception.Create('seq: called on non-sequence'); +end; + + +// Metadata functions + +function meta(Args: TMalArray) : TMal; +begin + if Args[0] is TMalFunc then + meta := (Args[0] as TMalFunc).Meta + else if Args[0] is TMalList then + meta := (Args[0] as TMalList).Meta + else if Args[0] is TMalHashMap then + meta := (Args[0] as TMalHashMap).Meta + else + raise Exception.Create('meta not supported on ' + Args[0].ClassName); + + if meta = nil then + meta := TMalNil.Create; +end; +function with_meta(Args: TMalArray) : TMal; +var + Fn : TMalFunc; + Vec : TMalVector; + Lst : TMalList; + HM : TMalHashMap; +begin + if Args[0] is TMalFunc then + begin + Fn := TMalFunc.Clone(Args[0] as TMalFunc); + Fn.Meta := Args[1]; + with_meta := Fn; + end + else if Args[0] is TMalVector then + begin + Vec := TMalVector.Clone(Args[0] as TMalVector); + Vec.Meta := Args[1]; + with_meta := Vec; + end + else if Args[0] is TMalList then + begin + Lst := TMalList.Clone(Args[0] as TMalList); + Lst.Meta := Args[1]; + with_meta := Lst; + end + else if Args[0] is TMalHashMap then + begin + HM := TMalHashMap.Clone(Args[0] as TMalHashMap); + HM.Meta := Args[1]; + with_meta := HM; + end + else + raise Exception.Create('with-meta call on non-mal function'); +end; + +// Atom functions + +function atom(Args: TMalArray) : TMal; +begin + atom := TMalAtom.Create(Args[0]); +end; +function atom_Q(Args: TMalArray) : TMal; +begin + atom_Q := wrap_tf(Args[0] is TMalAtom); +end; +function deref(Args: TMalArray) : TMal; +begin + deref := (Args[0] as TMalAtom).Val; +end; +function reset_BANG(Args: TMalArray) : TMal; +begin + (Args[0] as TMalAtom).Val := Args[1]; + reset_BANG := Args[1]; +end; + +function swap_BANG(Args: TMalArray) : TMal; +var + Atm : TMalAtom; + Fn : TMalFunc; + FArgs : TMalArray; + I : longint; +begin + Atm := (Args[0] as TMalAtom); + Fn := (Args[1] as TMalFunc); + SetLength(FArgs, Length(Args)-1); + FArgs[0] := Atm.Val; + for I := 1 to Length(Args)-2 do + FArgs[I] := Args[I+1]; + + if Fn.Ast = nil then + Atm.Val := Fn.Val(FArgs) + else + Atm.Val := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs)); + swap_BANG := Atm.Val; +end; + + +//////////////////////////////////////////////////////////// + +initialization +begin + NS := TCoreDict.Create; + NS['='] := @equal_Q; + NS['throw'] := @throw; + + NS['nil?'] := @nil_Q; + NS['true?'] := @true_Q; + NS['false?'] := @false_Q; + NS['number?'] := @number_Q; + NS['string?'] := @string_Q; + NS['symbol'] := @symbol; + NS['symbol?'] := @symbol_Q; + NS['keyword'] := @keyword; + NS['keyword?'] := @keyword_Q; + NS['fn?'] := @fn_Q; + NS['macro?'] := @macro_Q; + + NS['pr-str'] := @do_pr_str; + NS['str'] := @str; + NS['prn'] := @prn; + NS['println'] := @println; + NS['read-string'] := @read_string; + NS['readline'] := @do_readline; + NS['slurp'] := @slurp; + + NS['<'] := @lt; + NS['<='] := @lte; + NS['>'] := @gt; + NS['>='] := @gte; + NS['+'] := @add; + NS['-'] := @subtract; + NS['*'] := @multiply; + NS['/'] := @divide; + NS['time-ms'] := @time_ms; + + NS['list'] := @list; + NS['list?'] := @list_Q; + NS['vector'] := @vector; + NS['vector?'] := @vector_Q; + NS['hash-map'] := @hash_map; + NS['map?'] := @map_Q; + NS['assoc'] := @assoc; + NS['dissoc'] := @dissoc; + NS['get'] := @get; + NS['contains?'] := @contains_Q; + NS['keys'] := @keys; + NS['vals'] := @vals; + + NS['sequential?'] := @sequential_Q; + NS['cons'] := @cons; + NS['concat'] := @do_concat; + NS['vec'] := @vec; + NS['nth'] := @nth; + NS['first'] := @first; + NS['rest'] := @rest; + NS['empty?'] := @empty_Q; + NS['count'] := @count; + NS['apply'] := @apply; + NS['map'] := @map; + + NS['conj'] := @conj; + NS['seq'] := @seq; + + NS['meta'] := @meta; + NS['with-meta'] := @with_meta; + NS['atom'] := @atom; + NS['atom?'] := @atom_Q; + NS['deref'] := @deref; + NS['reset!'] := @reset_BANG; + NS['swap!'] := @swap_BANG; +end + +end. diff --git a/impls/objpascal/mal_env.pas b/impls/objpascal/mal_env.pas index 9bbe2ebd61..617a701d81 100644 --- a/impls/objpascal/mal_env.pas +++ b/impls/objpascal/mal_env.pas @@ -1,101 +1,101 @@ -unit mal_env; - -{$H+} // Use AnsiString - -interface - -Uses sysutils, - fgl, - mal_types; - -type TEnv = class(TObject) - public - Data : TMalDict; - Outer : TEnv; - - constructor Create; - constructor Create(_Outer : TEnv); - constructor Create(_Outer : TEnv; - Binds : TMalList; - Exprs : TMalArray); - - function Add(Key : TMalSymbol; Val : TMal) : TMal; - function Find(Key : TMalSymbol) : TEnv; - function Get(Key : TMalSymbol) : TMal; -end; - -//////////////////////////////////////////////////////////// - -implementation - -constructor TEnv.Create(); -begin - inherited Create(); - Self.Data := TMalDict.Create; - Self.Outer := nil; -end; - -constructor TEnv.Create(_Outer: TEnv); -begin - Self.Create(); - Self.Outer := _Outer; -end; - -constructor TEnv.Create(_Outer : TEnv; - Binds : TMalList; - Exprs : TMalArray); -var - I : longint; - Bind : TMalSymbol; - Rest : TMalList; -begin - Self.Create(_Outer); - for I := 0 to Length(Binds.Val)-1 do - begin - Bind := (Binds.Val[I] as TMalSymbol); - if Bind.Val = '&' then - begin - if I < Length(Exprs) then - Rest := TMalList.Create(copy(Exprs, I, Length(Exprs)-I)) - else - Rest := TMalList.Create; - Self.Data[(Binds.Val[I+1] as TMalSymbol).Val] := Rest; - break; - end; - Self.Data[Bind.Val] := Exprs[I]; - end; -end; - -function TEnv.Add(Key : TMalSymbol; Val : TMal) : TMal; -begin - Self.Data[Key.Val] := Val; - Add := Val; -end; - -function TEnv.Find(Key : TMalSymbol) : TEnv; -var - Sym : string; -begin - Sym := (Key as TMalSymbol).Val; - if Data.IndexOf(Sym) >= 0 then - Find := Self - else if Outer <> nil then - Find := Outer.Find(Key) - else - Find := nil; -end; - -function TEnv.Get(Key : TMalSymbol) : TMal; -var - Sym : string; - Env : TEnv; -begin - Sym := (Key as TMalSymbol).Val; - Env := Self.Find(Key); - if Env <> nil then - Get := Env.Data[Sym] - else - raise Exception.Create('''' + Sym + ''' not found'); -end; - -end. +unit mal_env; + +{$H+} // Use AnsiString + +interface + +Uses sysutils, + fgl, + mal_types; + +type TEnv = class(TObject) + public + Data : TMalDict; + Outer : TEnv; + + constructor Create; + constructor Create(_Outer : TEnv); + constructor Create(_Outer : TEnv; + Binds : TMalList; + Exprs : TMalArray); + + function Add(Key : TMalSymbol; Val : TMal) : TMal; + function Find(Key : TMalSymbol) : TEnv; + function Get(Key : TMalSymbol) : TMal; +end; + +//////////////////////////////////////////////////////////// + +implementation + +constructor TEnv.Create(); +begin + inherited Create(); + Self.Data := TMalDict.Create; + Self.Outer := nil; +end; + +constructor TEnv.Create(_Outer: TEnv); +begin + Self.Create(); + Self.Outer := _Outer; +end; + +constructor TEnv.Create(_Outer : TEnv; + Binds : TMalList; + Exprs : TMalArray); +var + I : longint; + Bind : TMalSymbol; + Rest : TMalList; +begin + Self.Create(_Outer); + for I := 0 to Length(Binds.Val)-1 do + begin + Bind := (Binds.Val[I] as TMalSymbol); + if Bind.Val = '&' then + begin + if I < Length(Exprs) then + Rest := TMalList.Create(copy(Exprs, I, Length(Exprs)-I)) + else + Rest := TMalList.Create; + Self.Data[(Binds.Val[I+1] as TMalSymbol).Val] := Rest; + break; + end; + Self.Data[Bind.Val] := Exprs[I]; + end; +end; + +function TEnv.Add(Key : TMalSymbol; Val : TMal) : TMal; +begin + Self.Data[Key.Val] := Val; + Add := Val; +end; + +function TEnv.Find(Key : TMalSymbol) : TEnv; +var + Sym : string; +begin + Sym := (Key as TMalSymbol).Val; + if Data.IndexOf(Sym) >= 0 then + Find := Self + else if Outer <> nil then + Find := Outer.Find(Key) + else + Find := nil; +end; + +function TEnv.Get(Key : TMalSymbol) : TMal; +var + Sym : string; + Env : TEnv; +begin + Sym := (Key as TMalSymbol).Val; + Env := Self.Find(Key); + if Env <> nil then + Get := Env.Data[Sym] + else + raise Exception.Create('''' + Sym + ''' not found'); +end; + +end. diff --git a/impls/objpascal/mal_func.pas b/impls/objpascal/mal_func.pas index 402be8f9f6..440420a1e4 100644 --- a/impls/objpascal/mal_func.pas +++ b/impls/objpascal/mal_func.pas @@ -1,57 +1,57 @@ -unit mal_func; - -interface - -uses mal_types, - mal_env; - -// Some general type definitions - -type - TMalCallable = function (Args : TMalArray) : TMal; - -type TMalFunc = class(TMal) - public - Val : TMalCallable; - Ast : TMal; - Env : TEnv; - Params : TMalList; - isMacro : Boolean; - Meta : TMal; - - constructor Create(V : TMalCallable); - constructor Create(A : TMal; - E : TEnv; - P : TMalList); - - constructor Clone(F : TMalFunc); -end; - -//////////////////////////////////////////////////////////// - -implementation - -constructor TMalFunc.Create(V : TMalCallable); -begin - inherited Create(); - Self.Val := V; -end; - -constructor TMalFunc.Create(A : TMal; - E : TEnv; - P : TMalList); -begin - inherited Create(); - Self.Ast := A; - Self.Env := E; - Self.Params := P; -end; - -constructor TMalFunc.Clone(F : TMalFunc); -begin - Self.Create(F.Ast, F.Env, F.Params); - Self.isMacro := F.isMacro; - Self.Meta := F.Meta; -end; - -end. +unit mal_func; + +interface + +uses mal_types, + mal_env; + +// Some general type definitions + +type + TMalCallable = function (Args : TMalArray) : TMal; + +type TMalFunc = class(TMal) + public + Val : TMalCallable; + Ast : TMal; + Env : TEnv; + Params : TMalList; + isMacro : Boolean; + Meta : TMal; + + constructor Create(V : TMalCallable); + constructor Create(A : TMal; + E : TEnv; + P : TMalList); + + constructor Clone(F : TMalFunc); +end; + +//////////////////////////////////////////////////////////// + +implementation + +constructor TMalFunc.Create(V : TMalCallable); +begin + inherited Create(); + Self.Val := V; +end; + +constructor TMalFunc.Create(A : TMal; + E : TEnv; + P : TMalList); +begin + inherited Create(); + Self.Ast := A; + Self.Env := E; + Self.Params := P; +end; + +constructor TMalFunc.Clone(F : TMalFunc); +begin + Self.Create(F.Ast, F.Env, F.Params); + Self.isMacro := F.isMacro; + Self.Meta := F.Meta; +end; + +end. diff --git a/impls/objpascal/mal_readline.pas b/impls/objpascal/mal_readline.pas index ff6dcd0d05..7f7f9b5a4f 100644 --- a/impls/objpascal/mal_readline.pas +++ b/impls/objpascal/mal_readline.pas @@ -1,49 +1,49 @@ -unit mal_readline; - -{$H+} // Use AnsiString - -interface - -uses sysutils, - CTypes; - -{$IFDEF USE_READLINE} - -{$LINKLIB readline} - -{$ELSE} - -{$LINKLIB libedit} - -{$ENDIF} - - -// External libedit/readline functions - -function readline(Prompt: PChar) : PChar; cdecl; external; -procedure add_history(Line: PChar); cdecl; external; - -// API - -type MalEOF = class(Exception); - -function _readline(Prompt: string) : string; - -//////////////////////////////////////////////////////////// - -implementation - -function _readline(Prompt: string) : string; -var - Line : PChar; -begin - Line := readline(PChar(Prompt)); - if Line = Nil then - raise MalEOF.Create('MalEOF'); - if Line <> '' then - add_history(Line); - - _readline := Line; -end; - -end. +unit mal_readline; + +{$H+} // Use AnsiString + +interface + +uses sysutils, + CTypes; + +{$IFDEF USE_READLINE} + +{$LINKLIB readline} + +{$ELSE} + +{$LINKLIB libedit} + +{$ENDIF} + + +// External libedit/readline functions + +function readline(Prompt: PChar) : PChar; cdecl; external; +procedure add_history(Line: PChar); cdecl; external; + +// API + +type MalEOF = class(Exception); + +function _readline(Prompt: string) : string; + +//////////////////////////////////////////////////////////// + +implementation + +function _readline(Prompt: string) : string; +var + Line : PChar; +begin + Line := readline(PChar(Prompt)); + if Line = Nil then + raise MalEOF.Create('MalEOF'); + if Line <> '' then + add_history(Line); + + _readline := Line; +end; + +end. diff --git a/impls/objpascal/mal_types.pas b/impls/objpascal/mal_types.pas index a7aacdea52..29f909c882 100644 --- a/impls/objpascal/mal_types.pas +++ b/impls/objpascal/mal_types.pas @@ -1,387 +1,387 @@ -unit mal_types; - -{$H+} // Use AnsiString - -interface - -uses sysutils, - fgl; - -// Ancestor of all Mal types - -type TMal = class(TObject); - - -// Some general type definitions - -type - TMalArray = array of TMal; - // TODO: use http://bugs.freepascal.org/view.php?id=27206 when - // incorporated into FPC - TMalDict = specialize TFPGMap; - -type TMalException = class(Exception) - public - Val: TMal; - - constructor Create(V : TMal); -end; - - -// Mal types - -type TMalNil = class(TMal); -type TMalTrue = class(TMal); -type TMalFalse = class(TMal); - -type TMalInt = class(TMal) - public - Val: int64; - - constructor Create(V : int64); -end; - -type TMalString = class(TMal) - public - Val: string; - - constructor Create(V : string); -end; - -type TMalSymbol = class(TMal) - public - Val: string; - - constructor Create(V : string); -end; - - -type TMalList = class(TMal) - public - Val: TMalArray; - Meta: TMal; - - constructor Create(); - constructor Create(V : TMalArray); - function Rest() : TMalList; - - constructor Clone(L : TMalList); -end; - -type TMalVector = class(TMalList) -end; - -type TMalAtom = class(TMal) - public - Val: TMal; - - constructor Create(V : TMal); -end; - -type TMalHashMap = class(TMal) - public - Val: TMalDict; - Meta: TMal; - - constructor Create(); - constructor Create(V : TMalDict); - constructor Create(V : TMalArray); - - constructor Clone(HM : TMalHashMap); - - function assoc_BANG(KVs: TMalArray) : TMal; - function dissoc_BANG(Ks: TMalArray) : TMal; -end; - - -// General type functions - -function GetBacktrace(E: Exception) : string; - -function wrap_tf(x : Boolean) : TMal; - -function _equal_Q(A : TMal; B : TMal) : Boolean; - -function _sequential_Q(Obj: TMal) : Boolean; - -function _list() : TMalList; -function _list(A: TMal) : TMalList; -function _list(A: TMal; B: TMal) : TMalList; -function _list(A: TMal; B: TMal; C: TMal) : TMalList; - -function _concat(A: TMalArray; B: TMalArray) : TMalArray; - -function _string_Q(Obj: TMal) : Boolean; - -//////////////////////////////////////////////////////////// - -implementation - -constructor TMalException.Create(V : TMal); -begin - inherited Create('MalException'); - Self.Val := V; -end; - -// -// Mal types -// - -constructor TMalInt.Create(V : int64); -begin - inherited Create(); - Self.Val := V; -end; - -constructor TMalString.Create(V : string); -begin - inherited Create(); - Self.Val := V; -end; - -constructor TMalSymbol.Create(V : string); -begin - inherited Create(); - Self.Val := V; -end; - -constructor TMalList.Create(); -begin - inherited Create(); - SetLength(Self.Val, 0); -end; - -constructor TMalList.Create(V : TMalArray); -begin - inherited Create(); - Self.Val := V; -end; - -constructor TMalList.Clone(L : TMalList); -begin - inherited Create(); - Self.Val := copy(L.Val, 0, Length(L.Val)); -end; - - -function TMalList.Rest() : TMalList; -begin - if Length(Val) <= 1 then - Rest := (_list() as TMalList) - else - Rest := TMalList.Create(copy(Val, 1, Length(Val)-1)); -end; - -// Hash Maps - -constructor TMalHashMap.Create(); -begin - inherited Create(); - Self.Val := TMalDict.Create; -end; - -constructor TMalHashMap.Create(V : TMalDict); -begin - inherited Create(); - Self.Val := V; -end; - -function TMalHashMap.assoc_BANG(KVs: TMalArray) : TMal; -var - I : longint; -begin - I := 0; - while I < Length(KVs) do - begin - Self.Val[(KVs[I] as TMalString).Val] := KVs[I+1]; - I := I + 2; - end; - assoc_BANG := Self; -end; - -function TMalHashMap.dissoc_BANG(Ks: TMalArray) : TMal; -var - I : longint; -begin - for I := 0 to Length(Ks)-1 do - Self.Val.Remove((Ks[I] as TMalString).Val); - dissoc_BANG := Self; -end; - - -constructor TMalHashMap.Create(V : TMalArray); -begin - Self.Create(); - Self.assoc_BANG(V); -end; - -constructor TMalHashMap.Clone(HM : TMalHashMap); -var - I : longint; -begin - Self.Create(); - I := 0; - while I < HM.Val.Count do - begin - Self.Val[HM.Val.Keys[I]] := HM.Val[HM.Val.Keys[I]]; - I := I + 1; - end; -end; - - -// Atoms - -constructor TMalAtom.Create(V : TMal); -begin - inherited Create(); - Self.Val := V; -end; - -// -// General type functions -// - -function GetBacktrace(E: Exception) : string; -var - I: Integer; - Frames: PPointer; -begin - GetBacktrace := BackTraceStrFunc(ExceptAddr); - Frames := ExceptFrames; - for I := 0 to ExceptFrameCount - 1 do - GetBacktrace := GetBacktrace + #10 + BackTraceStrFunc(Frames[I]); -end; - -function wrap_tf(x : Boolean) : TMal; -begin - if x = true then wrap_tf := TMalTrue.Create - else wrap_tf := TMalFalse.Create; -end; - -function _equal_Q(A : TMal; B : TMal) : Boolean; -var - I : longint; - ArrA, ArrB : TMalArray; - DictA, DictB : TMalDict; - Key : string; -begin - if not ((A.ClassType = B.ClassType) or - ((A is TMalList) and (B is TMalList))) then - _equal_Q := false - else - begin - if A is TMalList then - begin - ArrA := (A as TMalList).Val; - ArrB := (B as TMalList).Val; - if Length(ArrA) <> Length(ArrB) then - Exit(false); - for I := 0 to Length(ArrA)-1 do - if not _equal_Q(ArrA[I], ArrB[I]) then - Exit(false); - _equal_Q := true; - end - else if A is TMalHashMap then - begin - DictA := (A as TMalHashMap).Val; - DictB := (B as TMalHashMap).Val; - if DictA.Count <> DictB.Count then - Exit(false); - for I := 0 to DictA.Count-1 do - begin - Key := DictA.Keys[I]; - if DictB.IndexOf(Key) < 0 then - Exit(false); - if not _equal_Q(DictA[Key], DictB[Key]) then - Exit(false); - end; - _equal_Q := true; - end - else if A is TMalString then - _equal_Q := (A as TMalString).Val = (B as TMalString).Val - else if A is TMalSymbol then - _equal_Q := (A as TMalSymbol).Val = (B as TMalSymbol).Val - else if A is TMalInt then - _equal_Q := (A as TMalInt).Val = (B as TMalInt).Val - else if A is TMalNil then - _equal_Q := B is TMalNil - else if A is TMalTrue then - _equal_Q := B is TMalTrue - else if A is TMalFalse then - _equal_Q := B is TMalFalse - else - _equal_Q := A = B; - end -end; - -function _sequential_Q(Obj: TMal) : Boolean; -begin - _sequential_Q := Obj is TMalList; -end; - - -function _list() : TMalList; -var - Arr: TMalArray; -begin - SetLength(Arr, 0); - _list := TMalList.Create(Arr); -end; - -function _list(A: TMal) : TMalList; -var - Arr: TMalArray; -begin - SetLength(Arr, 1); - Arr[0] := A; - _list := TMalList.Create(Arr); -end; - -function _list(A: TMal; B: TMal) : TMalList; -var - Arr: TMalArray; -begin - SetLength(Arr, 2); - Arr[0] := A; - Arr[1] := B; - _list := TMalList.Create(Arr); -end; - -function _list(A: TMal; B: TMal; C: TMal) : TMalList; -var - Arr: TMalArray; -begin - SetLength(Arr, 3); - Arr[0] := A; - Arr[1] := B; - Arr[2] := C; - _list := TMalList.Create(Arr); -end; - -function _concat(A: TMalArray; B: TMalArray) : TMalArray; -var - Res : TMalArray; - I : longint; -begin - SetLength(Res, Length(A) + Length(B)); - for I := 0 to Length(A)-1 do - Res[I] := A[I]; - for I := 0 to Length(B)-1 do - Res[I+Length(A)] := B[I]; - _concat := Res; -end; - -function _string_Q(Obj: TMal) : Boolean; -var - Str : string; -begin - if (Obj is TMalString) then - begin - Str := (Obj as TMalString).Val; - _string_Q := (Length(Str) = 0) or (Str[1] <> #127) - end - else - _string_Q := false; -end; - -end. +unit mal_types; + +{$H+} // Use AnsiString + +interface + +uses sysutils, + fgl; + +// Ancestor of all Mal types + +type TMal = class(TObject); + + +// Some general type definitions + +type + TMalArray = array of TMal; + // TODO: use http://bugs.freepascal.org/view.php?id=27206 when + // incorporated into FPC + TMalDict = specialize TFPGMap; + +type TMalException = class(Exception) + public + Val: TMal; + + constructor Create(V : TMal); +end; + + +// Mal types + +type TMalNil = class(TMal); +type TMalTrue = class(TMal); +type TMalFalse = class(TMal); + +type TMalInt = class(TMal) + public + Val: int64; + + constructor Create(V : int64); +end; + +type TMalString = class(TMal) + public + Val: string; + + constructor Create(V : string); +end; + +type TMalSymbol = class(TMal) + public + Val: string; + + constructor Create(V : string); +end; + + +type TMalList = class(TMal) + public + Val: TMalArray; + Meta: TMal; + + constructor Create(); + constructor Create(V : TMalArray); + function Rest() : TMalList; + + constructor Clone(L : TMalList); +end; + +type TMalVector = class(TMalList) +end; + +type TMalAtom = class(TMal) + public + Val: TMal; + + constructor Create(V : TMal); +end; + +type TMalHashMap = class(TMal) + public + Val: TMalDict; + Meta: TMal; + + constructor Create(); + constructor Create(V : TMalDict); + constructor Create(V : TMalArray); + + constructor Clone(HM : TMalHashMap); + + function assoc_BANG(KVs: TMalArray) : TMal; + function dissoc_BANG(Ks: TMalArray) : TMal; +end; + + +// General type functions + +function GetBacktrace(E: Exception) : string; + +function wrap_tf(x : Boolean) : TMal; + +function _equal_Q(A : TMal; B : TMal) : Boolean; + +function _sequential_Q(Obj: TMal) : Boolean; + +function _list() : TMalList; +function _list(A: TMal) : TMalList; +function _list(A: TMal; B: TMal) : TMalList; +function _list(A: TMal; B: TMal; C: TMal) : TMalList; + +function _concat(A: TMalArray; B: TMalArray) : TMalArray; + +function _string_Q(Obj: TMal) : Boolean; + +//////////////////////////////////////////////////////////// + +implementation + +constructor TMalException.Create(V : TMal); +begin + inherited Create('MalException'); + Self.Val := V; +end; + +// +// Mal types +// + +constructor TMalInt.Create(V : int64); +begin + inherited Create(); + Self.Val := V; +end; + +constructor TMalString.Create(V : string); +begin + inherited Create(); + Self.Val := V; +end; + +constructor TMalSymbol.Create(V : string); +begin + inherited Create(); + Self.Val := V; +end; + +constructor TMalList.Create(); +begin + inherited Create(); + SetLength(Self.Val, 0); +end; + +constructor TMalList.Create(V : TMalArray); +begin + inherited Create(); + Self.Val := V; +end; + +constructor TMalList.Clone(L : TMalList); +begin + inherited Create(); + Self.Val := copy(L.Val, 0, Length(L.Val)); +end; + + +function TMalList.Rest() : TMalList; +begin + if Length(Val) <= 1 then + Rest := (_list() as TMalList) + else + Rest := TMalList.Create(copy(Val, 1, Length(Val)-1)); +end; + +// Hash Maps + +constructor TMalHashMap.Create(); +begin + inherited Create(); + Self.Val := TMalDict.Create; +end; + +constructor TMalHashMap.Create(V : TMalDict); +begin + inherited Create(); + Self.Val := V; +end; + +function TMalHashMap.assoc_BANG(KVs: TMalArray) : TMal; +var + I : longint; +begin + I := 0; + while I < Length(KVs) do + begin + Self.Val[(KVs[I] as TMalString).Val] := KVs[I+1]; + I := I + 2; + end; + assoc_BANG := Self; +end; + +function TMalHashMap.dissoc_BANG(Ks: TMalArray) : TMal; +var + I : longint; +begin + for I := 0 to Length(Ks)-1 do + Self.Val.Remove((Ks[I] as TMalString).Val); + dissoc_BANG := Self; +end; + + +constructor TMalHashMap.Create(V : TMalArray); +begin + Self.Create(); + Self.assoc_BANG(V); +end; + +constructor TMalHashMap.Clone(HM : TMalHashMap); +var + I : longint; +begin + Self.Create(); + I := 0; + while I < HM.Val.Count do + begin + Self.Val[HM.Val.Keys[I]] := HM.Val[HM.Val.Keys[I]]; + I := I + 1; + end; +end; + + +// Atoms + +constructor TMalAtom.Create(V : TMal); +begin + inherited Create(); + Self.Val := V; +end; + +// +// General type functions +// + +function GetBacktrace(E: Exception) : string; +var + I: Integer; + Frames: PPointer; +begin + GetBacktrace := BackTraceStrFunc(ExceptAddr); + Frames := ExceptFrames; + for I := 0 to ExceptFrameCount - 1 do + GetBacktrace := GetBacktrace + #10 + BackTraceStrFunc(Frames[I]); +end; + +function wrap_tf(x : Boolean) : TMal; +begin + if x = true then wrap_tf := TMalTrue.Create + else wrap_tf := TMalFalse.Create; +end; + +function _equal_Q(A : TMal; B : TMal) : Boolean; +var + I : longint; + ArrA, ArrB : TMalArray; + DictA, DictB : TMalDict; + Key : string; +begin + if not ((A.ClassType = B.ClassType) or + ((A is TMalList) and (B is TMalList))) then + _equal_Q := false + else + begin + if A is TMalList then + begin + ArrA := (A as TMalList).Val; + ArrB := (B as TMalList).Val; + if Length(ArrA) <> Length(ArrB) then + Exit(false); + for I := 0 to Length(ArrA)-1 do + if not _equal_Q(ArrA[I], ArrB[I]) then + Exit(false); + _equal_Q := true; + end + else if A is TMalHashMap then + begin + DictA := (A as TMalHashMap).Val; + DictB := (B as TMalHashMap).Val; + if DictA.Count <> DictB.Count then + Exit(false); + for I := 0 to DictA.Count-1 do + begin + Key := DictA.Keys[I]; + if DictB.IndexOf(Key) < 0 then + Exit(false); + if not _equal_Q(DictA[Key], DictB[Key]) then + Exit(false); + end; + _equal_Q := true; + end + else if A is TMalString then + _equal_Q := (A as TMalString).Val = (B as TMalString).Val + else if A is TMalSymbol then + _equal_Q := (A as TMalSymbol).Val = (B as TMalSymbol).Val + else if A is TMalInt then + _equal_Q := (A as TMalInt).Val = (B as TMalInt).Val + else if A is TMalNil then + _equal_Q := B is TMalNil + else if A is TMalTrue then + _equal_Q := B is TMalTrue + else if A is TMalFalse then + _equal_Q := B is TMalFalse + else + _equal_Q := A = B; + end +end; + +function _sequential_Q(Obj: TMal) : Boolean; +begin + _sequential_Q := Obj is TMalList; +end; + + +function _list() : TMalList; +var + Arr: TMalArray; +begin + SetLength(Arr, 0); + _list := TMalList.Create(Arr); +end; + +function _list(A: TMal) : TMalList; +var + Arr: TMalArray; +begin + SetLength(Arr, 1); + Arr[0] := A; + _list := TMalList.Create(Arr); +end; + +function _list(A: TMal; B: TMal) : TMalList; +var + Arr: TMalArray; +begin + SetLength(Arr, 2); + Arr[0] := A; + Arr[1] := B; + _list := TMalList.Create(Arr); +end; + +function _list(A: TMal; B: TMal; C: TMal) : TMalList; +var + Arr: TMalArray; +begin + SetLength(Arr, 3); + Arr[0] := A; + Arr[1] := B; + Arr[2] := C; + _list := TMalList.Create(Arr); +end; + +function _concat(A: TMalArray; B: TMalArray) : TMalArray; +var + Res : TMalArray; + I : longint; +begin + SetLength(Res, Length(A) + Length(B)); + for I := 0 to Length(A)-1 do + Res[I] := A[I]; + for I := 0 to Length(B)-1 do + Res[I+Length(A)] := B[I]; + _concat := Res; +end; + +function _string_Q(Obj: TMal) : Boolean; +var + Str : string; +begin + if (Obj is TMalString) then + begin + Str := (Obj as TMalString).Val; + _string_Q := (Length(Str) = 0) or (Str[1] <> #127) + end + else + _string_Q := false; +end; + +end. diff --git a/impls/objpascal/printer.pas b/impls/objpascal/printer.pas index 4f1ddaf356..9cda743bf6 100644 --- a/impls/objpascal/printer.pas +++ b/impls/objpascal/printer.pas @@ -1,114 +1,114 @@ -unit printer; - -{$H+} // Use AnsiString - -interface - -Uses sysutils, - mal_types, - mal_func; - -function pr_str_array(Args : TMalArray; - print_readably : Boolean; - Separator : string) : string; - -function pr_str(Obj : TMal; print_readably : Boolean) : string; - -implementation - -function pr_str_array(Args : TMalArray; - print_readably : Boolean; - Separator : string) : string; -var - Str : string; - I : longint; -begin - Str := ''; - for I := 0 to Length(Args)-1 do - begin - Str := Str + pr_str(Args[I], print_readably); - if I <> Length(Args)-1 then - Str := Str + Separator; - end; - pr_str_array := Str; -end; - -function pr_str_dict(Dict : TMalDict; - print_readably : Boolean; - Separator : string) : string; -var - I : longint; - Arr : TMalArray; -begin - SetLength(Arr, Dict.Count * 2); - I := 0; - while I < Dict.Count do - begin - Arr[I*2] := TMalString.Create(Dict.Keys[I]); - Arr[I*2+1] := Dict[Dict.Keys[I]]; - I := I + 1; - end; - pr_str_dict := pr_str_array(Arr, print_readably, ' '); -end; - - -function pr_str(Obj : TMal; print_readably : Boolean) : string; -var - Str : string; - Fn : TMalFunc; -begin - if Obj.ClassType = TMalList then - pr_str := '(' + pr_str_array((Obj as TMalList).Val, - print_readably, - ' ') + ')' - else if Obj.ClassType = TMalVector then - pr_str := '[' + pr_str_array((Obj as TMalList).Val, - print_readably, - ' ') + ']' - else if Obj is TMalHashMap then - pr_str := '{' + pr_str_dict((Obj as TMalHashMap).Val, - print_readably, - ' ') + '}' - else if Obj is TMalString then - begin - Str := (Obj as TMalString).Val; - if (Length(Str) > 0) and (Str[1] = #127) then - pr_str := ':' + copy(Str, 2, Length(Str)) - else if print_readably then - begin - Str := StringReplace(Str, '\', '\\', [rfReplaceAll]); - Str := StringReplace(Str, '"', '\"', [rfReplaceAll]); - Str := StringReplace(Str, #10, '\n', [rfReplaceAll]); - pr_str := Format('"%s"', [Str]) - end - else - pr_str := Str; - end - else if Obj is TMalNil then - pr_str := 'nil' - else if Obj is TMalTrue then - pr_str := 'true' - else if Obj is TMalFalse then - pr_str := 'false' - else if Obj is TMalInt then - pr_str := IntToStr((Obj as TMalInt).Val) - else if Obj is TMalSymbol then - pr_str := (Obj as TMalSymbol).Val - else if Obj is TMalAtom then - pr_str := '(atom ' + - pr_str((Obj as TMalAtom).Val, print_readably) + - ')' - else if Obj is TMalFunc then - begin - Fn := (Obj as TMalFunc); - if Fn.Ast = nil then - pr_str := '#' - else - pr_str := '(fn* ' + pr_str(Fn.Params,true) + - ' ' + pr_str(Fn.Ast,true) + ')' - end - else - pr_str := '#unknown'; -end; - -end. +unit printer; + +{$H+} // Use AnsiString + +interface + +Uses sysutils, + mal_types, + mal_func; + +function pr_str_array(Args : TMalArray; + print_readably : Boolean; + Separator : string) : string; + +function pr_str(Obj : TMal; print_readably : Boolean) : string; + +implementation + +function pr_str_array(Args : TMalArray; + print_readably : Boolean; + Separator : string) : string; +var + Str : string; + I : longint; +begin + Str := ''; + for I := 0 to Length(Args)-1 do + begin + Str := Str + pr_str(Args[I], print_readably); + if I <> Length(Args)-1 then + Str := Str + Separator; + end; + pr_str_array := Str; +end; + +function pr_str_dict(Dict : TMalDict; + print_readably : Boolean; + Separator : string) : string; +var + I : longint; + Arr : TMalArray; +begin + SetLength(Arr, Dict.Count * 2); + I := 0; + while I < Dict.Count do + begin + Arr[I*2] := TMalString.Create(Dict.Keys[I]); + Arr[I*2+1] := Dict[Dict.Keys[I]]; + I := I + 1; + end; + pr_str_dict := pr_str_array(Arr, print_readably, ' '); +end; + + +function pr_str(Obj : TMal; print_readably : Boolean) : string; +var + Str : string; + Fn : TMalFunc; +begin + if Obj.ClassType = TMalList then + pr_str := '(' + pr_str_array((Obj as TMalList).Val, + print_readably, + ' ') + ')' + else if Obj.ClassType = TMalVector then + pr_str := '[' + pr_str_array((Obj as TMalList).Val, + print_readably, + ' ') + ']' + else if Obj is TMalHashMap then + pr_str := '{' + pr_str_dict((Obj as TMalHashMap).Val, + print_readably, + ' ') + '}' + else if Obj is TMalString then + begin + Str := (Obj as TMalString).Val; + if (Length(Str) > 0) and (Str[1] = #127) then + pr_str := ':' + copy(Str, 2, Length(Str)) + else if print_readably then + begin + Str := StringReplace(Str, '\', '\\', [rfReplaceAll]); + Str := StringReplace(Str, '"', '\"', [rfReplaceAll]); + Str := StringReplace(Str, #10, '\n', [rfReplaceAll]); + pr_str := Format('"%s"', [Str]) + end + else + pr_str := Str; + end + else if Obj is TMalNil then + pr_str := 'nil' + else if Obj is TMalTrue then + pr_str := 'true' + else if Obj is TMalFalse then + pr_str := 'false' + else if Obj is TMalInt then + pr_str := IntToStr((Obj as TMalInt).Val) + else if Obj is TMalSymbol then + pr_str := (Obj as TMalSymbol).Val + else if Obj is TMalAtom then + pr_str := '(atom ' + + pr_str((Obj as TMalAtom).Val, print_readably) + + ')' + else if Obj is TMalFunc then + begin + Fn := (Obj as TMalFunc); + if Fn.Ast = nil then + pr_str := '#' + else + pr_str := '(fn* ' + pr_str(Fn.Params,true) + + ' ' + pr_str(Fn.Ast,true) + ')' + end + else + pr_str := '#unknown'; +end; + +end. diff --git a/impls/objpascal/reader.pas b/impls/objpascal/reader.pas index d77ebf90b4..9cf2b626c5 100644 --- a/impls/objpascal/reader.pas +++ b/impls/objpascal/reader.pas @@ -1,235 +1,235 @@ -unit reader; - -{$H+} // Use AnsiString - -interface - -Uses sysutils, - Classes, - RegExpr in 'regexpr/Source/RegExpr.pas', - mal_types; - -// -// Reader class -// - -type TReader = class(TObject) - public - Tokens : TStringList; - Position : Integer; - - constructor Create(Toks: TStringList); - - function Peek() : string; - function Next() : string; -end; - -// -// reader functions -// - -function read_str(const Str: string): TMal; - - -implementation - -// -// Reader class -// - -constructor TReader.Create(Toks: TStringList); -begin - inherited Create(); - Self.Tokens := Toks; - Self.Position := 0; -end; - -function TReader.Peek() : string; -begin - if Position >= Tokens.Count then - Peek := #0 - else - Peek := Tokens[Position]; -end; - -function TReader.Next() : string; -begin - Next := Tokens[Position]; - Position := Position + 1; -end; - - -// -// reader functions -// - -function tokenize(const Str: string) : TStringList; -var - RE : TRegExpr; - Tokens : TStringList; -begin - RE := TRegExpr.Create; - RE.Expression := '[\s,]*(~@|[\[\]{}()''`~^@]|"(([\\].|[^\\"])*)"?|;[^\r\n]*|[^\s\[\]{}()''"`@,;]+)'; - Tokens := TStringList.Create; - if RE.Exec(Str) then - begin - repeat - if RE.Match[1][1] <> ';' then - Tokens.Add(RE.Match[1]); - until not RE.ExecNext; - end; - RE.Free; - - tokenize := Tokens; -end; - - -function read_atom(Reader : TReader) : TMal; -var - RE : TRegExpr; - Token : string; - Str : string; -begin - RE := TRegExpr.Create; - RE.Expression := '(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^("([\\].|[^\\"])*)"$|^(\".*)$|:(.*)|(^[^\"]*$)'; - Token := Reader.Next(); - //WriteLn('token: ' + Token); - if RE.Exec(Token) then - begin - if RE.Match[1] <> '' then - read_atom := TMalInt.Create(StrToInt(RE.Match[1])) - else if RE.Match[2] <> '' then - // TODO - read_atom := TMalNil.Create - else if RE.Match[3] <> '' then - read_atom := TMalNil.Create - else if RE.Match[4] <> '' then - read_atom := TMalTrue.Create - else if RE.Match[5] <> '' then - read_atom := TMalFalse.Create - else if RE.Match[6] <> '' then - begin - Str := copy(Token, 2, Length(Token)-2); - Str := StringReplace(Str, '\\', #127, [rfReplaceAll]); - Str := StringReplace(Str, '\"', '"', [rfReplaceAll]); - Str := StringReplace(Str, '\n', #10, [rfReplaceAll]); - Str := StringReplace(Str, #127, '\', [rfReplaceAll]); - read_atom := TMalString.Create(Str) - end - else if RE.Match[8] <> '' then - raise Exception.Create('expected ''"'', got EOF') - else if RE.Match[9] <> '' then - read_atom := TMalString.Create(#127 + RE.Match[9]) - else if RE.Match[10] <> '' then - read_atom := TMalSymbol.Create(Token); - end - else - begin - RE.Free; - raise Exception.Create('Invalid token in read_atom'); - end; - RE.Free; -end; - -// Forward declaration since read_seq calls it -function read_form(Reader : TReader) : TMal; forward; - -function read_seq(Reader : TReader; start: string; last: string) : TMalArray; -var - Token : string; - Ast : TMalArray; -begin - SetLength(Ast, 0); - - Token := Reader.Next(); - if Token <> start then - raise Exception.Create('expected ''' + start + ''''); - - Token := Reader.Peek(); - while Token <> last do - begin - if Token = #0 then - raise Exception.Create('expected ''' + last + ''', got EOF'); - SetLength(Ast, Length(Ast)+1); - Ast[Length(Ast)-1] := read_form(Reader); - Token := Reader.Peek(); - end; - - Token := Reader.Next(); - read_seq := Ast; -end; - -function read_form(Reader : TReader) : TMal; -var - Token : string; - Meta : TMal; -begin - Token := Reader.Peek(); - case Token of - // reader macros/transforms - '''': - begin - Reader.Next(); - read_form := _list(TMalSymbol.Create('quote'), - read_form(Reader)); - end; - '`': - begin - Reader.Next(); - read_form := _list(TMalSymbol.Create('quasiquote'), - read_form(Reader)); - end; - '~': - begin - Reader.Next(); - read_form := _list(TMalSymbol.Create('unquote'), - read_form(Reader)); - end; - '~@': - begin - Reader.Next(); - read_form := _list(TMalSymbol.Create('splice-unquote'), - read_form(Reader)); - end; - '^': - begin - Reader.Next(); - Meta := read_form(Reader); - read_form := _list(TMalSymbol.Create('with-meta'), - read_form(Reader), - Meta); - end; - '@': - begin - Reader.Next(); - read_form := _list(TMalSymbol.Create('deref'), read_form(Reader)); - end; - - // list - ')': raise Exception.Create('unexpected '')'''); - '(': read_form := TMalList.Create(read_seq(Reader, '(', ')')); - - // vector - ']': raise Exception.Create('unexpected '']'''); - '[': read_form := TMalVector.Create(read_seq(Reader, '[', ']')); - - // hash-map - '}': raise Exception.Create('unexpected ''}'''); - '{': read_form := TMalHashMap.Create(read_seq(Reader, '{', '}')); - else - read_form := read_atom(Reader); - end; -end; - - -function read_str(const Str: string): TMal; -var - Tokens : TStringList; - //Dict : TObjectDictionary; -begin - Tokens := tokenize(Str); - // TODO: check for empty list - read_str := read_form(TReader.Create(Tokens)); -end; - -end. +unit reader; + +{$H+} // Use AnsiString + +interface + +Uses sysutils, + Classes, + RegExpr in 'regexpr/Source/RegExpr.pas', + mal_types; + +// +// Reader class +// + +type TReader = class(TObject) + public + Tokens : TStringList; + Position : Integer; + + constructor Create(Toks: TStringList); + + function Peek() : string; + function Next() : string; +end; + +// +// reader functions +// + +function read_str(const Str: string): TMal; + + +implementation + +// +// Reader class +// + +constructor TReader.Create(Toks: TStringList); +begin + inherited Create(); + Self.Tokens := Toks; + Self.Position := 0; +end; + +function TReader.Peek() : string; +begin + if Position >= Tokens.Count then + Peek := #0 + else + Peek := Tokens[Position]; +end; + +function TReader.Next() : string; +begin + Next := Tokens[Position]; + Position := Position + 1; +end; + + +// +// reader functions +// + +function tokenize(const Str: string) : TStringList; +var + RE : TRegExpr; + Tokens : TStringList; +begin + RE := TRegExpr.Create; + RE.Expression := '[\s,]*(~@|[\[\]{}()''`~^@]|"(([\\].|[^\\"])*)"?|;[^\r\n]*|[^\s\[\]{}()''"`@,;]+)'; + Tokens := TStringList.Create; + if RE.Exec(Str) then + begin + repeat + if RE.Match[1][1] <> ';' then + Tokens.Add(RE.Match[1]); + until not RE.ExecNext; + end; + RE.Free; + + tokenize := Tokens; +end; + + +function read_atom(Reader : TReader) : TMal; +var + RE : TRegExpr; + Token : string; + Str : string; +begin + RE := TRegExpr.Create; + RE.Expression := '(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^("([\\].|[^\\"])*)"$|^(\".*)$|:(.*)|(^[^\"]*$)'; + Token := Reader.Next(); + //WriteLn('token: ' + Token); + if RE.Exec(Token) then + begin + if RE.Match[1] <> '' then + read_atom := TMalInt.Create(StrToInt(RE.Match[1])) + else if RE.Match[2] <> '' then + // TODO + read_atom := TMalNil.Create + else if RE.Match[3] <> '' then + read_atom := TMalNil.Create + else if RE.Match[4] <> '' then + read_atom := TMalTrue.Create + else if RE.Match[5] <> '' then + read_atom := TMalFalse.Create + else if RE.Match[6] <> '' then + begin + Str := copy(Token, 2, Length(Token)-2); + Str := StringReplace(Str, '\\', #127, [rfReplaceAll]); + Str := StringReplace(Str, '\"', '"', [rfReplaceAll]); + Str := StringReplace(Str, '\n', #10, [rfReplaceAll]); + Str := StringReplace(Str, #127, '\', [rfReplaceAll]); + read_atom := TMalString.Create(Str) + end + else if RE.Match[8] <> '' then + raise Exception.Create('expected ''"'', got EOF') + else if RE.Match[9] <> '' then + read_atom := TMalString.Create(#127 + RE.Match[9]) + else if RE.Match[10] <> '' then + read_atom := TMalSymbol.Create(Token); + end + else + begin + RE.Free; + raise Exception.Create('Invalid token in read_atom'); + end; + RE.Free; +end; + +// Forward declaration since read_seq calls it +function read_form(Reader : TReader) : TMal; forward; + +function read_seq(Reader : TReader; start: string; last: string) : TMalArray; +var + Token : string; + Ast : TMalArray; +begin + SetLength(Ast, 0); + + Token := Reader.Next(); + if Token <> start then + raise Exception.Create('expected ''' + start + ''''); + + Token := Reader.Peek(); + while Token <> last do + begin + if Token = #0 then + raise Exception.Create('expected ''' + last + ''', got EOF'); + SetLength(Ast, Length(Ast)+1); + Ast[Length(Ast)-1] := read_form(Reader); + Token := Reader.Peek(); + end; + + Token := Reader.Next(); + read_seq := Ast; +end; + +function read_form(Reader : TReader) : TMal; +var + Token : string; + Meta : TMal; +begin + Token := Reader.Peek(); + case Token of + // reader macros/transforms + '''': + begin + Reader.Next(); + read_form := _list(TMalSymbol.Create('quote'), + read_form(Reader)); + end; + '`': + begin + Reader.Next(); + read_form := _list(TMalSymbol.Create('quasiquote'), + read_form(Reader)); + end; + '~': + begin + Reader.Next(); + read_form := _list(TMalSymbol.Create('unquote'), + read_form(Reader)); + end; + '~@': + begin + Reader.Next(); + read_form := _list(TMalSymbol.Create('splice-unquote'), + read_form(Reader)); + end; + '^': + begin + Reader.Next(); + Meta := read_form(Reader); + read_form := _list(TMalSymbol.Create('with-meta'), + read_form(Reader), + Meta); + end; + '@': + begin + Reader.Next(); + read_form := _list(TMalSymbol.Create('deref'), read_form(Reader)); + end; + + // list + ')': raise Exception.Create('unexpected '')'''); + '(': read_form := TMalList.Create(read_seq(Reader, '(', ')')); + + // vector + ']': raise Exception.Create('unexpected '']'''); + '[': read_form := TMalVector.Create(read_seq(Reader, '[', ']')); + + // hash-map + '}': raise Exception.Create('unexpected ''}'''); + '{': read_form := TMalHashMap.Create(read_seq(Reader, '{', '}')); + else + read_form := read_atom(Reader); + end; +end; + + +function read_str(const Str: string): TMal; +var + Tokens : TStringList; + //Dict : TObjectDictionary; +begin + Tokens := tokenize(Str); + // TODO: check for empty list + read_str := read_form(TReader.Create(Tokens)); +end; + +end. diff --git a/impls/objpascal/run b/impls/objpascal/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/objpascal/run +++ b/impls/objpascal/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/objpascal/step0_repl.pas b/impls/objpascal/step0_repl.pas index 47ed09e150..8b72cb4f1a 100644 --- a/impls/objpascal/step0_repl.pas +++ b/impls/objpascal/step0_repl.pas @@ -1,47 +1,47 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses CMem, - mal_readline; - -var - Repl_Env: string = ''; - Line : string; - -// read -function READ(const Str: string) : string; -begin - READ := Str; -end; - -// eval -function EVAL(Ast: string; Env: string) : string; -begin - EVAL := Ast; -end; - -// print -function PRINT(Exp: string) : string; -begin - PRINT := Exp; -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -begin - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses CMem, + mal_readline; + +var + Repl_Env: string = ''; + Line : string; + +// read +function READ(const Str: string) : string; +begin + READ := Str; +end; + +// eval +function EVAL(Ast: string; Env: string) : string; +begin + EVAL := Ast; +end; + +// print +function PRINT(Exp: string) : string; +begin + PRINT := Exp; +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +begin + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + end; + end; +end. diff --git a/impls/objpascal/step1_read_print.pas b/impls/objpascal/step1_read_print.pas index 6d0a0a728a..805593e241 100644 --- a/impls/objpascal/step1_read_print.pas +++ b/impls/objpascal/step1_read_print.pas @@ -1,57 +1,57 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - mal_readline, - mal_types, - reader, - printer; - -var - Repl_Env : string = ''; - Line : string; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval -function EVAL(Ast: TMal; Env: string) : TMal; -begin - EVAL := Ast; -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -begin - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + mal_readline, + mal_types, + reader, + printer; + +var + Repl_Env : string = ''; + Line : string; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval +function EVAL(Ast: TMal; Env: string) : TMal; +begin + EVAL := Ast; +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +begin + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/step2_eval.pas b/impls/objpascal/step2_eval.pas index 9da3bcbad6..d694c0b172 100644 --- a/impls/objpascal/step2_eval.pas +++ b/impls/objpascal/step2_eval.pas @@ -1,151 +1,151 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - fgl, - mal_readline, - mal_types, - mal_func, - reader, - printer; - -type - TEnv = specialize TFPGMap; - -var - Repl_Env : TEnv; - Line : string; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval -// Forward declation since eval_ast call it -function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; - -function eval_ast(Ast: TMal; Env: TEnv) : TMal; -var - Sym : string; - OldArr, NewArr : TMalArray; - OldDict, NewDict : TMalDict; - I : longint; -begin - if Ast is TMalSymbol then - begin - Sym := (Ast as TMalSymbol).Val; - if Env.IndexOf(Sym) < 0 then - raise Exception.Create('''' + Sym + ''' not found') - else - eval_ast := Env[Sym]; - end - else if Ast is TMalList then - begin - OldArr := (Ast as TMalList).Val; - SetLength(NewArr, Length(OldArr)); - for I := 0 to Length(OldArr)-1 do - begin - NewArr[I] := EVAL(OldArr[I], Env); - end; - if Ast is TMalVector then - eval_ast := TMalVector.Create(NewArr) - else - eval_ast := TMalList.Create(NewArr); - end - else if Ast is TMalHashMap then - begin - OldDict := (Ast as TMalHashMap).Val; - NewDict := TMalDict.Create; - I := 0; - while I < OldDict.Count do - begin - NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); - I := I + 1; - end; - eval_ast := TMalHashMap.Create(NewDict); - end - else - eval_ast := Ast; -end; - -function EVAL(Ast: TMal; Env: TEnv) : TMal; -var - Arr : TMalArray; - Fn : TMalCallable; -begin - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - // Apply list - Arr := (eval_ast(Ast, Env) as TMalList).Val; - if Length(Arr) = 0 then - Exit(Ast); - if Arr[0] is TMalFunc then - begin - Fn := (Arr[0] as TMalFunc).Val; - EVAL := Fn(copy(Arr, 1, Length(Arr)-1)); - end - else - raise Exception.Create('invalid apply'); -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -function add(Args: TMalArray) : TMal; -begin - add := TMalInt.Create((Args[0] as TMalInt).Val + - (Args[1] as TMalInt).Val); -end; -function subtract(Args: TMalArray) : TMal; -begin - subtract := TMalInt.Create((Args[0] as TMalInt).Val - - (Args[1] as TMalInt).Val); -end; -function multiply(Args: TMalArray) : TMal; -begin - multiply := TMalInt.Create((Args[0] as TMalInt).Val * - (Args[1] as TMalInt).Val); -end; -function divide(Args: TMalArray) : TMal; -begin - divide := TMalInt.Create((Args[0] as TMalInt).Val div - (Args[1] as TMalInt).Val); -end; - -begin - Repl_Env := TEnv.Create; - Repl_Env.Add('+', TMalFunc.Create(@add)); - Repl_Env.Add('-', TMalFunc.Create(@subtract)); - Repl_Env.Add('*', TMalFunc.Create(@multiply)); - Repl_Env.Add('/', TMalFunc.Create(@divide)); - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + fgl, + mal_readline, + mal_types, + mal_func, + reader, + printer; + +type + TEnv = specialize TFPGMap; + +var + Repl_Env : TEnv; + Line : string; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval +// Forward declation since eval_ast call it +function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; + +function eval_ast(Ast: TMal; Env: TEnv) : TMal; +var + Sym : string; + OldArr, NewArr : TMalArray; + OldDict, NewDict : TMalDict; + I : longint; +begin + if Ast is TMalSymbol then + begin + Sym := (Ast as TMalSymbol).Val; + if Env.IndexOf(Sym) < 0 then + raise Exception.Create('''' + Sym + ''' not found') + else + eval_ast := Env[Sym]; + end + else if Ast is TMalList then + begin + OldArr := (Ast as TMalList).Val; + SetLength(NewArr, Length(OldArr)); + for I := 0 to Length(OldArr)-1 do + begin + NewArr[I] := EVAL(OldArr[I], Env); + end; + if Ast is TMalVector then + eval_ast := TMalVector.Create(NewArr) + else + eval_ast := TMalList.Create(NewArr); + end + else if Ast is TMalHashMap then + begin + OldDict := (Ast as TMalHashMap).Val; + NewDict := TMalDict.Create; + I := 0; + while I < OldDict.Count do + begin + NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); + I := I + 1; + end; + eval_ast := TMalHashMap.Create(NewDict); + end + else + eval_ast := Ast; +end; + +function EVAL(Ast: TMal; Env: TEnv) : TMal; +var + Arr : TMalArray; + Fn : TMalCallable; +begin + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + // Apply list + Arr := (eval_ast(Ast, Env) as TMalList).Val; + if Length(Arr) = 0 then + Exit(Ast); + if Arr[0] is TMalFunc then + begin + Fn := (Arr[0] as TMalFunc).Val; + EVAL := Fn(copy(Arr, 1, Length(Arr)-1)); + end + else + raise Exception.Create('invalid apply'); +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +function add(Args: TMalArray) : TMal; +begin + add := TMalInt.Create((Args[0] as TMalInt).Val + + (Args[1] as TMalInt).Val); +end; +function subtract(Args: TMalArray) : TMal; +begin + subtract := TMalInt.Create((Args[0] as TMalInt).Val - + (Args[1] as TMalInt).Val); +end; +function multiply(Args: TMalArray) : TMal; +begin + multiply := TMalInt.Create((Args[0] as TMalInt).Val * + (Args[1] as TMalInt).Val); +end; +function divide(Args: TMalArray) : TMal; +begin + divide := TMalInt.Create((Args[0] as TMalInt).Val div + (Args[1] as TMalInt).Val); +end; + +begin + Repl_Env := TEnv.Create; + Repl_Env.Add('+', TMalFunc.Create(@add)); + Repl_Env.Add('-', TMalFunc.Create(@subtract)); + Repl_Env.Add('*', TMalFunc.Create(@multiply)); + Repl_Env.Add('/', TMalFunc.Create(@divide)); + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/step3_env.pas b/impls/objpascal/step3_env.pas index f51e318beb..8cb77e4e71 100644 --- a/impls/objpascal/step3_env.pas +++ b/impls/objpascal/step3_env.pas @@ -1,173 +1,173 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - fgl, - mal_readline, - mal_types, - mal_func, - reader, - printer, - mal_env; - -var - Repl_Env : TEnv; - Line : string; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval -// Forward declation since eval_ast call it -function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; - -function eval_ast(Ast: TMal; Env: TEnv) : TMal; -var - OldArr, NewArr : TMalArray; - OldDict, NewDict : TMalDict; - I : longint; -begin - if Ast is TMalSymbol then - begin - eval_ast := Env.Get((Ast as TMalSymbol)); - end - else if Ast is TMalList then - begin - OldArr := (Ast as TMalList).Val; - SetLength(NewArr, Length(OldArr)); - for I := 0 to Length(OldArr)-1 do - begin - NewArr[I] := EVAL(OldArr[I], Env); - end; - if Ast is TMalVector then - eval_ast := TMalVector.Create(NewArr) - else - eval_ast := TMalList.Create(NewArr); - end - else if Ast is TMalHashMap then - begin - OldDict := (Ast as TMalHashMap).Val; - NewDict := TMalDict.Create; - I := 0; - while I < OldDict.Count do - begin - NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); - I := I + 1; - end; - eval_ast := TMalHashMap.Create(NewDict); - end - else - eval_ast := Ast; -end; - -function EVAL(Ast: TMal; Env: TEnv) : TMal; -var - Arr : TMalArray; - Arr1 : TMalArray; - A0Sym : string; - LetEnv : TEnv; - I : longint; - Fn : TMalCallable; -begin - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - // Apply list - Arr := (Ast as TMalList).Val; - if Length(Arr) = 0 then - Exit(Ast); - if Arr[0] is TMalSymbol then - A0Sym := (Arr[0] as TMalSymbol).Val - else - A0Sym := '__<*fn*>__'; - - case A0Sym of - 'def!': - EVAL := Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV)); - 'let*': - begin - LetEnv := TEnv.Create(Env); - Arr1 := (Arr[1] as TMalList).Val; - I := 0; - while I < Length(Arr1) do - begin - LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); - Inc(I,2); - end; - EVAL := EVAL(Arr[2], LetEnv); - end; - else - begin - Arr := (eval_ast(Ast, Env) as TMalList).Val; - if Arr[0] is TMalFunc then - begin - Fn := (Arr[0] as TMalFunc).Val; - EVAL := Fn(copy(Arr, 1, Length(Arr)-1)); - end - else - raise Exception.Create('invalid apply'); - end; - end; -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -function add(Args: TMalArray) : TMal; -begin - add := TMalInt.Create((Args[0] as TMalInt).Val + - (Args[1] as TMalInt).Val); -end; -function subtract(Args: TMalArray) : TMal; -begin - subtract := TMalInt.Create((Args[0] as TMalInt).Val - - (Args[1] as TMalInt).Val); -end; -function multiply(Args: TMalArray) : TMal; -begin - multiply := TMalInt.Create((Args[0] as TMalInt).Val * - (Args[1] as TMalInt).Val); -end; -function divide(Args: TMalArray) : TMal; -begin - divide := TMalInt.Create((Args[0] as TMalInt).Val div - (Args[1] as TMalInt).Val); -end; - -begin - Repl_Env := TEnv.Create; - Repl_Env.Add(TMalSymbol.Create('+'), TMalFunc.Create(@add)); - Repl_Env.Add(TMalSymbol.Create('-'), TMalFunc.Create(@subtract)); - Repl_Env.Add(TMalSymbol.Create('*'), TMalFunc.Create(@multiply)); - Repl_Env.Add(TMalSymbol.Create('/'), TMalFunc.Create(@divide)); - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + fgl, + mal_readline, + mal_types, + mal_func, + reader, + printer, + mal_env; + +var + Repl_Env : TEnv; + Line : string; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval +// Forward declation since eval_ast call it +function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; + +function eval_ast(Ast: TMal; Env: TEnv) : TMal; +var + OldArr, NewArr : TMalArray; + OldDict, NewDict : TMalDict; + I : longint; +begin + if Ast is TMalSymbol then + begin + eval_ast := Env.Get((Ast as TMalSymbol)); + end + else if Ast is TMalList then + begin + OldArr := (Ast as TMalList).Val; + SetLength(NewArr, Length(OldArr)); + for I := 0 to Length(OldArr)-1 do + begin + NewArr[I] := EVAL(OldArr[I], Env); + end; + if Ast is TMalVector then + eval_ast := TMalVector.Create(NewArr) + else + eval_ast := TMalList.Create(NewArr); + end + else if Ast is TMalHashMap then + begin + OldDict := (Ast as TMalHashMap).Val; + NewDict := TMalDict.Create; + I := 0; + while I < OldDict.Count do + begin + NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); + I := I + 1; + end; + eval_ast := TMalHashMap.Create(NewDict); + end + else + eval_ast := Ast; +end; + +function EVAL(Ast: TMal; Env: TEnv) : TMal; +var + Arr : TMalArray; + Arr1 : TMalArray; + A0Sym : string; + LetEnv : TEnv; + I : longint; + Fn : TMalCallable; +begin + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + // Apply list + Arr := (Ast as TMalList).Val; + if Length(Arr) = 0 then + Exit(Ast); + if Arr[0] is TMalSymbol then + A0Sym := (Arr[0] as TMalSymbol).Val + else + A0Sym := '__<*fn*>__'; + + case A0Sym of + 'def!': + EVAL := Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV)); + 'let*': + begin + LetEnv := TEnv.Create(Env); + Arr1 := (Arr[1] as TMalList).Val; + I := 0; + while I < Length(Arr1) do + begin + LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); + Inc(I,2); + end; + EVAL := EVAL(Arr[2], LetEnv); + end; + else + begin + Arr := (eval_ast(Ast, Env) as TMalList).Val; + if Arr[0] is TMalFunc then + begin + Fn := (Arr[0] as TMalFunc).Val; + EVAL := Fn(copy(Arr, 1, Length(Arr)-1)); + end + else + raise Exception.Create('invalid apply'); + end; + end; +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +function add(Args: TMalArray) : TMal; +begin + add := TMalInt.Create((Args[0] as TMalInt).Val + + (Args[1] as TMalInt).Val); +end; +function subtract(Args: TMalArray) : TMal; +begin + subtract := TMalInt.Create((Args[0] as TMalInt).Val - + (Args[1] as TMalInt).Val); +end; +function multiply(Args: TMalArray) : TMal; +begin + multiply := TMalInt.Create((Args[0] as TMalInt).Val * + (Args[1] as TMalInt).Val); +end; +function divide(Args: TMalArray) : TMal; +begin + divide := TMalInt.Create((Args[0] as TMalInt).Val div + (Args[1] as TMalInt).Val); +end; + +begin + Repl_Env := TEnv.Create; + Repl_Env.Add(TMalSymbol.Create('+'), TMalFunc.Create(@add)); + Repl_Env.Add(TMalSymbol.Create('-'), TMalFunc.Create(@subtract)); + Repl_Env.Add(TMalSymbol.Create('*'), TMalFunc.Create(@multiply)); + Repl_Env.Add(TMalSymbol.Create('/'), TMalFunc.Create(@divide)); + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/step4_if_fn_do.pas b/impls/objpascal/step4_if_fn_do.pas index f1204b7160..05a69a7981 100644 --- a/impls/objpascal/step4_if_fn_do.pas +++ b/impls/objpascal/step4_if_fn_do.pas @@ -1,199 +1,199 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - fgl, - mal_readline, - mal_types, - mal_func, - reader, - printer, - mal_env, - core; - -var - Repl_Env : TEnv; - Line : string; - I : longint; - Key : string; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval -// Forward declation since eval_ast call it -function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; - -function eval_ast(Ast: TMal; Env: TEnv) : TMal; -var - OldArr, NewArr : TMalArray; - OldDict, NewDict : TMalDict; - I : longint; -begin - if Ast is TMalSymbol then - begin - eval_ast := Env.Get((Ast as TMalSymbol)); - end - else if Ast is TMalList then - begin - OldArr := (Ast as TMalList).Val; - SetLength(NewArr, Length(OldArr)); - for I := 0 to Length(OldArr)-1 do - begin - NewArr[I] := EVAL(OldArr[I], Env); - end; - if Ast is TMalVector then - eval_ast := TMalVector.Create(NewArr) - else - eval_ast := TMalList.Create(NewArr); - end - else if Ast is TMalHashMap then - begin - OldDict := (Ast as TMalHashMap).Val; - NewDict := TMalDict.Create; - I := 0; - while I < OldDict.Count do - begin - NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); - I := I + 1; - end; - eval_ast := TMalHashMap.Create(NewDict); - end - else - eval_ast := Ast; -end; - -function EVAL(Ast: TMal; Env: TEnv) : TMal; -var - Lst : TMalList; - Arr : TMalArray; - Arr1 : TMalArray; - A0Sym : string; - LetEnv : TEnv; - FnEnv : TEnv; - Cond : TMal; - I : longint; - Fn : TMalFunc; - Args : TMalArray; -begin - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - // Apply list - Lst := (Ast as TMalList); - Arr := Lst.Val; - if Length(Arr) = 0 then - Exit(Ast); - if Arr[0] is TMalSymbol then - A0Sym := (Arr[0] as TMalSymbol).Val - else - A0Sym := '__<*fn*>__'; - - case A0Sym of - 'def!': - EVAL := Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV)); - 'let*': - begin - LetEnv := TEnv.Create(Env); - Arr1 := (Arr[1] as TMalList).Val; - I := 0; - while I < Length(Arr1) do - begin - LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); - Inc(I,2); - end; - EVAL := EVAL(Arr[2], LetEnv); - end; - 'do': - begin - Arr := (eval_ast(Lst.Rest, Env) as TMalList).Val; - EVAL := Arr[Length(Arr)-1]; - end; - 'if': - begin - Cond := EVAL(Arr[1], Env); - if (Cond is TMalNil) or (Cond is TMalFalse) then - if Length(Arr) > 3 then - EVAL := EVAL(Arr[3], Env) - else - EVAL := TMalNil.Create - else - EVAL := EVAL(Arr[2], Env); - end; - 'fn*': - begin - EVAL := TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList)) - end; - else - begin - Arr := (eval_ast(Ast, Env) as TMalList).Val; - if Arr[0] is TMalFunc then - begin - Fn := Arr[0] as TMalFunc; - if Length(Arr) < 2 then - SetLength(Args, 0) - else - Args := copy(Arr, 1, Length(Arr)-1); - if Fn.Ast = nil then - EVAL := Fn.Val(Args) - else - begin - FnEnv := TEnv.Create(Fn.Env, Fn.Params, Args); - EVAL := EVAL(Fn.Ast, FnEnv); - end - - end - else - raise Exception.Create('invalid apply'); - end; - end; -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -begin - Repl_Env := TEnv.Create; - - // core.pas: defined using Pascal - for I := 0 to core.NS.Count-1 do - begin - Key := core.NS.Keys[I]; - Repl_Env.Add(TMalSymbol.Create(Key), - TMalFunc.Create(core.NS[Key])); - end; - - // core.mal: defined using language itself - REP('(def! not (fn* (a) (if a false true)))'); - - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + fgl, + mal_readline, + mal_types, + mal_func, + reader, + printer, + mal_env, + core; + +var + Repl_Env : TEnv; + Line : string; + I : longint; + Key : string; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval +// Forward declation since eval_ast call it +function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; + +function eval_ast(Ast: TMal; Env: TEnv) : TMal; +var + OldArr, NewArr : TMalArray; + OldDict, NewDict : TMalDict; + I : longint; +begin + if Ast is TMalSymbol then + begin + eval_ast := Env.Get((Ast as TMalSymbol)); + end + else if Ast is TMalList then + begin + OldArr := (Ast as TMalList).Val; + SetLength(NewArr, Length(OldArr)); + for I := 0 to Length(OldArr)-1 do + begin + NewArr[I] := EVAL(OldArr[I], Env); + end; + if Ast is TMalVector then + eval_ast := TMalVector.Create(NewArr) + else + eval_ast := TMalList.Create(NewArr); + end + else if Ast is TMalHashMap then + begin + OldDict := (Ast as TMalHashMap).Val; + NewDict := TMalDict.Create; + I := 0; + while I < OldDict.Count do + begin + NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); + I := I + 1; + end; + eval_ast := TMalHashMap.Create(NewDict); + end + else + eval_ast := Ast; +end; + +function EVAL(Ast: TMal; Env: TEnv) : TMal; +var + Lst : TMalList; + Arr : TMalArray; + Arr1 : TMalArray; + A0Sym : string; + LetEnv : TEnv; + FnEnv : TEnv; + Cond : TMal; + I : longint; + Fn : TMalFunc; + Args : TMalArray; +begin + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + // Apply list + Lst := (Ast as TMalList); + Arr := Lst.Val; + if Length(Arr) = 0 then + Exit(Ast); + if Arr[0] is TMalSymbol then + A0Sym := (Arr[0] as TMalSymbol).Val + else + A0Sym := '__<*fn*>__'; + + case A0Sym of + 'def!': + EVAL := Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV)); + 'let*': + begin + LetEnv := TEnv.Create(Env); + Arr1 := (Arr[1] as TMalList).Val; + I := 0; + while I < Length(Arr1) do + begin + LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); + Inc(I,2); + end; + EVAL := EVAL(Arr[2], LetEnv); + end; + 'do': + begin + Arr := (eval_ast(Lst.Rest, Env) as TMalList).Val; + EVAL := Arr[Length(Arr)-1]; + end; + 'if': + begin + Cond := EVAL(Arr[1], Env); + if (Cond is TMalNil) or (Cond is TMalFalse) then + if Length(Arr) > 3 then + EVAL := EVAL(Arr[3], Env) + else + EVAL := TMalNil.Create + else + EVAL := EVAL(Arr[2], Env); + end; + 'fn*': + begin + EVAL := TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList)) + end; + else + begin + Arr := (eval_ast(Ast, Env) as TMalList).Val; + if Arr[0] is TMalFunc then + begin + Fn := Arr[0] as TMalFunc; + if Length(Arr) < 2 then + SetLength(Args, 0) + else + Args := copy(Arr, 1, Length(Arr)-1); + if Fn.Ast = nil then + EVAL := Fn.Val(Args) + else + begin + FnEnv := TEnv.Create(Fn.Env, Fn.Params, Args); + EVAL := EVAL(Fn.Ast, FnEnv); + end + + end + else + raise Exception.Create('invalid apply'); + end; + end; +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +begin + Repl_Env := TEnv.Create; + + // core.pas: defined using Pascal + for I := 0 to core.NS.Count-1 do + begin + Key := core.NS.Keys[I]; + Repl_Env.Add(TMalSymbol.Create(Key), + TMalFunc.Create(core.NS[Key])); + end; + + // core.mal: defined using language itself + REP('(def! not (fn* (a) (if a false true)))'); + + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/step5_tco.pas b/impls/objpascal/step5_tco.pas index 6771931079..550e8138f0 100644 --- a/impls/objpascal/step5_tco.pas +++ b/impls/objpascal/step5_tco.pas @@ -1,202 +1,202 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - fgl, - mal_readline, - mal_types, - mal_func, - reader, - printer, - mal_env, - core; - -var - Repl_Env : TEnv; - Line : string; - I : longint; - Key : string; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval -// Forward declation since eval_ast call it -function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; - -function eval_ast(Ast: TMal; Env: TEnv) : TMal; -var - OldArr, NewArr : TMalArray; - OldDict, NewDict : TMalDict; - I : longint; -begin - if Ast is TMalSymbol then - begin - eval_ast := Env.Get((Ast as TMalSymbol)); - end - else if Ast is TMalList then - begin - OldArr := (Ast as TMalList).Val; - SetLength(NewArr, Length(OldArr)); - for I := 0 to Length(OldArr)-1 do - begin - NewArr[I] := EVAL(OldArr[I], Env); - end; - if Ast is TMalVector then - eval_ast := TMalVector.Create(NewArr) - else - eval_ast := TMalList.Create(NewArr); - end - else if Ast is TMalHashMap then - begin - OldDict := (Ast as TMalHashMap).Val; - NewDict := TMalDict.Create; - I := 0; - while I < OldDict.Count do - begin - NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); - I := I + 1; - end; - eval_ast := TMalHashMap.Create(NewDict); - end - else - eval_ast := Ast; -end; - -function EVAL(Ast: TMal; Env: TEnv) : TMal; -var - Lst : TMalList; - Arr : TMalArray; - Arr1 : TMalArray; - A0Sym : string; - LetEnv : TEnv; - Cond : TMal; - I : longint; - Fn : TMalFunc; - Args : TMalArray; -begin - while true do - begin - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - // Apply list - Lst := (Ast as TMalList); - Arr := Lst.Val; - if Length(Arr) = 0 then - Exit(Ast); - if Arr[0] is TMalSymbol then - A0Sym := (Arr[0] as TMalSymbol).Val - else - A0Sym := '__<*fn*>__'; - - case A0Sym of - 'def!': - Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); - 'let*': - begin - LetEnv := TEnv.Create(Env); - Arr1 := (Arr[1] as TMalList).Val; - I := 0; - while I < Length(Arr1) do - begin - LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); - Inc(I,2); - end; - Env := LetEnv; - Ast := Arr[2]; // TCO - end; - 'do': - begin - eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); - Ast := Arr[Length(Arr)-1]; // TCO - end; - 'if': - begin - Cond := EVAL(Arr[1], Env); - if (Cond is TMalNil) or (Cond is TMalFalse) then - if Length(Arr) > 3 then - Ast := Arr[3] // TCO - else - Exit(TMalNil.Create) - else - Ast := Arr[2]; // TCO - end; - 'fn*': - begin - Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); - end; - else - begin - Arr := (eval_ast(Ast, Env) as TMalList).Val; - if Arr[0] is TMalFunc then - begin - Fn := Arr[0] as TMalFunc; - if Length(Arr) < 2 then - SetLength(Args, 0) - else - Args := copy(Arr, 1, Length(Arr)-1); - if Fn.Ast = nil then - Exit(Fn.Val(Args)) - else - begin - Env := TEnv.Create(Fn.Env, Fn.Params, Args); - Ast := Fn.Ast; // TCO - end - - end - else - raise Exception.Create('invalid apply'); - end; - end; - end; -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -begin - Repl_Env := TEnv.Create; - - // core.pas: defined using Pascal - for I := 0 to core.NS.Count-1 do - begin - Key := core.NS.Keys[I]; - Repl_Env.Add(TMalSymbol.Create(Key), - TMalFunc.Create(core.NS[Key])); - end; - - // core.mal: defined using language itself - REP('(def! not (fn* (a) (if a false true)))'); - - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + fgl, + mal_readline, + mal_types, + mal_func, + reader, + printer, + mal_env, + core; + +var + Repl_Env : TEnv; + Line : string; + I : longint; + Key : string; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval +// Forward declation since eval_ast call it +function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; + +function eval_ast(Ast: TMal; Env: TEnv) : TMal; +var + OldArr, NewArr : TMalArray; + OldDict, NewDict : TMalDict; + I : longint; +begin + if Ast is TMalSymbol then + begin + eval_ast := Env.Get((Ast as TMalSymbol)); + end + else if Ast is TMalList then + begin + OldArr := (Ast as TMalList).Val; + SetLength(NewArr, Length(OldArr)); + for I := 0 to Length(OldArr)-1 do + begin + NewArr[I] := EVAL(OldArr[I], Env); + end; + if Ast is TMalVector then + eval_ast := TMalVector.Create(NewArr) + else + eval_ast := TMalList.Create(NewArr); + end + else if Ast is TMalHashMap then + begin + OldDict := (Ast as TMalHashMap).Val; + NewDict := TMalDict.Create; + I := 0; + while I < OldDict.Count do + begin + NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); + I := I + 1; + end; + eval_ast := TMalHashMap.Create(NewDict); + end + else + eval_ast := Ast; +end; + +function EVAL(Ast: TMal; Env: TEnv) : TMal; +var + Lst : TMalList; + Arr : TMalArray; + Arr1 : TMalArray; + A0Sym : string; + LetEnv : TEnv; + Cond : TMal; + I : longint; + Fn : TMalFunc; + Args : TMalArray; +begin + while true do + begin + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + // Apply list + Lst := (Ast as TMalList); + Arr := Lst.Val; + if Length(Arr) = 0 then + Exit(Ast); + if Arr[0] is TMalSymbol then + A0Sym := (Arr[0] as TMalSymbol).Val + else + A0Sym := '__<*fn*>__'; + + case A0Sym of + 'def!': + Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); + 'let*': + begin + LetEnv := TEnv.Create(Env); + Arr1 := (Arr[1] as TMalList).Val; + I := 0; + while I < Length(Arr1) do + begin + LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); + Inc(I,2); + end; + Env := LetEnv; + Ast := Arr[2]; // TCO + end; + 'do': + begin + eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); + Ast := Arr[Length(Arr)-1]; // TCO + end; + 'if': + begin + Cond := EVAL(Arr[1], Env); + if (Cond is TMalNil) or (Cond is TMalFalse) then + if Length(Arr) > 3 then + Ast := Arr[3] // TCO + else + Exit(TMalNil.Create) + else + Ast := Arr[2]; // TCO + end; + 'fn*': + begin + Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); + end; + else + begin + Arr := (eval_ast(Ast, Env) as TMalList).Val; + if Arr[0] is TMalFunc then + begin + Fn := Arr[0] as TMalFunc; + if Length(Arr) < 2 then + SetLength(Args, 0) + else + Args := copy(Arr, 1, Length(Arr)-1); + if Fn.Ast = nil then + Exit(Fn.Val(Args)) + else + begin + Env := TEnv.Create(Fn.Env, Fn.Params, Args); + Ast := Fn.Ast; // TCO + end + + end + else + raise Exception.Create('invalid apply'); + end; + end; + end; +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +begin + Repl_Env := TEnv.Create; + + // core.pas: defined using Pascal + for I := 0 to core.NS.Count-1 do + begin + Key := core.NS.Keys[I]; + Repl_Env.Add(TMalSymbol.Create(Key), + TMalFunc.Create(core.NS[Key])); + end; + + // core.mal: defined using language itself + REP('(def! not (fn* (a) (if a false true)))'); + + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/step6_file.pas b/impls/objpascal/step6_file.pas index dfc53f16cd..b7f71e0398 100644 --- a/impls/objpascal/step6_file.pas +++ b/impls/objpascal/step6_file.pas @@ -1,223 +1,223 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - fgl, - math, - mal_readline, - mal_types, - mal_func, - reader, - printer, - mal_env, - core; - -var - Repl_Env : TEnv; - Line : string; - I : longint; - Key : string; - CmdArgs : TMalArray; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval -// Forward declation since eval_ast call it -function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; - -function eval_ast(Ast: TMal; Env: TEnv) : TMal; -var - OldArr, NewArr : TMalArray; - OldDict, NewDict : TMalDict; - I : longint; -begin - if Ast is TMalSymbol then - begin - eval_ast := Env.Get((Ast as TMalSymbol)); - end - else if Ast is TMalList then - begin - OldArr := (Ast as TMalList).Val; - SetLength(NewArr, Length(OldArr)); - for I := 0 to Length(OldArr)-1 do - begin - NewArr[I] := EVAL(OldArr[I], Env); - end; - if Ast is TMalVector then - eval_ast := TMalVector.Create(NewArr) - else - eval_ast := TMalList.Create(NewArr); - end - else if Ast is TMalHashMap then - begin - OldDict := (Ast as TMalHashMap).Val; - NewDict := TMalDict.Create; - I := 0; - while I < OldDict.Count do - begin - NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); - I := I + 1; - end; - eval_ast := TMalHashMap.Create(NewDict); - end - else - eval_ast := Ast; -end; - -function EVAL(Ast: TMal; Env: TEnv) : TMal; -var - Lst : TMalList; - Arr : TMalArray; - Arr1 : TMalArray; - A0Sym : string; - LetEnv : TEnv; - Cond : TMal; - I : longint; - Fn : TMalFunc; - Args : TMalArray; -begin - while true do - begin - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - // Apply list - Lst := (Ast as TMalList); - Arr := Lst.Val; - if Length(Arr) = 0 then - Exit(Ast); - if Arr[0] is TMalSymbol then - A0Sym := (Arr[0] as TMalSymbol).Val - else - A0Sym := '__<*fn*>__'; - - case A0Sym of - 'def!': - Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); - 'let*': - begin - LetEnv := TEnv.Create(Env); - Arr1 := (Arr[1] as TMalList).Val; - I := 0; - while I < Length(Arr1) do - begin - LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); - Inc(I,2); - end; - Env := LetEnv; - Ast := Arr[2]; // TCO - end; - 'do': - begin - eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); - Ast := Arr[Length(Arr)-1]; // TCO - end; - 'if': - begin - Cond := EVAL(Arr[1], Env); - if (Cond is TMalNil) or (Cond is TMalFalse) then - if Length(Arr) > 3 then - Ast := Arr[3] // TCO - else - Exit(TMalNil.Create) - else - Ast := Arr[2]; // TCO - end; - 'fn*': - begin - Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); - end; - else - begin - Arr := (eval_ast(Ast, Env) as TMalList).Val; - if Arr[0] is TMalFunc then - begin - Fn := Arr[0] as TMalFunc; - if Length(Arr) < 2 then - SetLength(Args, 0) - else - Args := copy(Arr, 1, Length(Arr)-1); - if Fn.Ast = nil then - Exit(Fn.Val(Args)) - else - begin - Env := TEnv.Create(Fn.Env, Fn.Params, Args); - Ast := Fn.Ast; // TCO - end - - end - else - raise Exception.Create('invalid apply'); - end; - end; - end; -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -function do_eval(Args : TMalArray) : TMal; -begin - do_eval := EVAL(Args[0], Repl_Env); -end; - -begin - Repl_Env := TEnv.Create; - core.EVAL := @EVAL; - - // core.pas: defined using Pascal - for I := 0 to core.NS.Count-1 do - begin - Key := core.NS.Keys[I]; - Repl_Env.Add(TMalSymbol.Create(Key), - TMalFunc.Create(core.NS[Key])); - end; - Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); - SetLength(CmdArgs, Max(0, ParamCount-1)); - for I := 2 to ParamCount do - CmdArgs[I-2] := TMalString.Create(ParamStr(I)); - Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); - - // core.mal: defined using language itself - REP('(def! not (fn* (a) (if a false true)))'); - REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - - if ParamCount >= 1 then - begin - REP('(load-file "' + ParamStr(1) + '")'); - ExitCode := 0; - Exit; - end; - - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + fgl, + math, + mal_readline, + mal_types, + mal_func, + reader, + printer, + mal_env, + core; + +var + Repl_Env : TEnv; + Line : string; + I : longint; + Key : string; + CmdArgs : TMalArray; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval +// Forward declation since eval_ast call it +function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; + +function eval_ast(Ast: TMal; Env: TEnv) : TMal; +var + OldArr, NewArr : TMalArray; + OldDict, NewDict : TMalDict; + I : longint; +begin + if Ast is TMalSymbol then + begin + eval_ast := Env.Get((Ast as TMalSymbol)); + end + else if Ast is TMalList then + begin + OldArr := (Ast as TMalList).Val; + SetLength(NewArr, Length(OldArr)); + for I := 0 to Length(OldArr)-1 do + begin + NewArr[I] := EVAL(OldArr[I], Env); + end; + if Ast is TMalVector then + eval_ast := TMalVector.Create(NewArr) + else + eval_ast := TMalList.Create(NewArr); + end + else if Ast is TMalHashMap then + begin + OldDict := (Ast as TMalHashMap).Val; + NewDict := TMalDict.Create; + I := 0; + while I < OldDict.Count do + begin + NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); + I := I + 1; + end; + eval_ast := TMalHashMap.Create(NewDict); + end + else + eval_ast := Ast; +end; + +function EVAL(Ast: TMal; Env: TEnv) : TMal; +var + Lst : TMalList; + Arr : TMalArray; + Arr1 : TMalArray; + A0Sym : string; + LetEnv : TEnv; + Cond : TMal; + I : longint; + Fn : TMalFunc; + Args : TMalArray; +begin + while true do + begin + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + // Apply list + Lst := (Ast as TMalList); + Arr := Lst.Val; + if Length(Arr) = 0 then + Exit(Ast); + if Arr[0] is TMalSymbol then + A0Sym := (Arr[0] as TMalSymbol).Val + else + A0Sym := '__<*fn*>__'; + + case A0Sym of + 'def!': + Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); + 'let*': + begin + LetEnv := TEnv.Create(Env); + Arr1 := (Arr[1] as TMalList).Val; + I := 0; + while I < Length(Arr1) do + begin + LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); + Inc(I,2); + end; + Env := LetEnv; + Ast := Arr[2]; // TCO + end; + 'do': + begin + eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); + Ast := Arr[Length(Arr)-1]; // TCO + end; + 'if': + begin + Cond := EVAL(Arr[1], Env); + if (Cond is TMalNil) or (Cond is TMalFalse) then + if Length(Arr) > 3 then + Ast := Arr[3] // TCO + else + Exit(TMalNil.Create) + else + Ast := Arr[2]; // TCO + end; + 'fn*': + begin + Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); + end; + else + begin + Arr := (eval_ast(Ast, Env) as TMalList).Val; + if Arr[0] is TMalFunc then + begin + Fn := Arr[0] as TMalFunc; + if Length(Arr) < 2 then + SetLength(Args, 0) + else + Args := copy(Arr, 1, Length(Arr)-1); + if Fn.Ast = nil then + Exit(Fn.Val(Args)) + else + begin + Env := TEnv.Create(Fn.Env, Fn.Params, Args); + Ast := Fn.Ast; // TCO + end + + end + else + raise Exception.Create('invalid apply'); + end; + end; + end; +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +function do_eval(Args : TMalArray) : TMal; +begin + do_eval := EVAL(Args[0], Repl_Env); +end; + +begin + Repl_Env := TEnv.Create; + core.EVAL := @EVAL; + + // core.pas: defined using Pascal + for I := 0 to core.NS.Count-1 do + begin + Key := core.NS.Keys[I]; + Repl_Env.Add(TMalSymbol.Create(Key), + TMalFunc.Create(core.NS[Key])); + end; + Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); + SetLength(CmdArgs, Max(0, ParamCount-1)); + for I := 2 to ParamCount do + CmdArgs[I-2] := TMalString.Create(ParamStr(I)); + Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); + + // core.mal: defined using language itself + REP('(def! not (fn* (a) (if a false true)))'); + REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + + if ParamCount >= 1 then + begin + REP('(load-file "' + ParamStr(1) + '")'); + ExitCode := 0; + Exit; + end; + + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/step7_quote.pas b/impls/objpascal/step7_quote.pas index c960b1e5db..f1087e4e1f 100644 --- a/impls/objpascal/step7_quote.pas +++ b/impls/objpascal/step7_quote.pas @@ -1,274 +1,274 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - fgl, - math, - mal_readline, - mal_types, - mal_func, - reader, - printer, - mal_env, - core; - -var - Repl_Env : TEnv; - Line : string; - I : longint; - Key : string; - CmdArgs : TMalArray; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval - -function starts_with(Ast: TMal; Sym: String) : Boolean; -var - Arr : TMalArray; - A0 : TMal; -begin - if Ast.ClassType <> TMalList then Exit (False); - Arr := (Ast as TMalList).Val; - if Length (Arr) = 0 then Exit (False); - A0 := Arr [0]; - starts_with := (A0.ClassType = TMalSymbol) and ((A0 as TMalSymbol).Val = Sym); -end; - -function quasiquote(Ast: TMal) : TMal; -var - Arr : TMalArray; - Res, Elt : TMal; - I : longint; -begin - if Ast is TMalSymbol or Ast is TMalHashMap then - Exit(_list(TMalSymbol.Create('quote'), Ast)); - - if not (Ast is TMalList) then - Exit(Ast); - - Arr := (Ast as TMalList).Val; - if starts_with (Ast, 'unquote') then Exit(Arr[1]); - - Res := _list(); - for I := 1 to Length(Arr) do - begin - Elt := Arr [Length(Arr) - I]; - if starts_with (Elt, 'splice-unquote') then - Res := _list(TMalSymbol.Create('concat'), (Elt as TMalList).Val[1], Res) - else - Res := _list(TMalSymbol.Create('cons'), quasiquote (Elt), Res); - end; - if Ast.ClassType <> TMalList then - Exit(_list(TMalSymbol.Create('vec'), Res)) - else - Exit(Res); -end; - - - -// Forward declation since eval_ast call it -function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; - -function eval_ast(Ast: TMal; Env: TEnv) : TMal; -var - OldArr, NewArr : TMalArray; - OldDict, NewDict : TMalDict; - I : longint; -begin - if Ast is TMalSymbol then - begin - eval_ast := Env.Get((Ast as TMalSymbol)); - end - else if Ast is TMalList then - begin - OldArr := (Ast as TMalList).Val; - SetLength(NewArr, Length(OldArr)); - for I := 0 to Length(OldArr)-1 do - begin - NewArr[I] := EVAL(OldArr[I], Env); - end; - if Ast is TMalVector then - eval_ast := TMalVector.Create(NewArr) - else - eval_ast := TMalList.Create(NewArr); - end - else if Ast is TMalHashMap then - begin - OldDict := (Ast as TMalHashMap).Val; - NewDict := TMalDict.Create; - I := 0; - while I < OldDict.Count do - begin - NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); - I := I + 1; - end; - eval_ast := TMalHashMap.Create(NewDict); - end - else - eval_ast := Ast; -end; - -function EVAL(Ast: TMal; Env: TEnv) : TMal; -var - Lst : TMalList; - Arr : TMalArray; - Arr1 : TMalArray; - A0Sym : string; - LetEnv : TEnv; - Cond : TMal; - I : longint; - Fn : TMalFunc; - Args : TMalArray; -begin - while true do - begin - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - // Apply list - Lst := (Ast as TMalList); - Arr := Lst.Val; - if Length(Arr) = 0 then - Exit(Ast); - if Arr[0] is TMalSymbol then - A0Sym := (Arr[0] as TMalSymbol).Val - else - A0Sym := '__<*fn*>__'; - - case A0Sym of - 'def!': - Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); - 'let*': - begin - LetEnv := TEnv.Create(Env); - Arr1 := (Arr[1] as TMalList).Val; - I := 0; - while I < Length(Arr1) do - begin - LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); - Inc(I,2); - end; - Env := LetEnv; - Ast := Arr[2]; // TCO - end; - 'quote': - Exit(Arr[1]); - 'quasiquoteexpand': - Exit(quasiquote(Arr[1])); - 'quasiquote': - Ast := quasiquote(Arr[1]); - 'do': - begin - eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); - Ast := Arr[Length(Arr)-1]; // TCO - end; - 'if': - begin - Cond := EVAL(Arr[1], Env); - if (Cond is TMalNil) or (Cond is TMalFalse) then - if Length(Arr) > 3 then - Ast := Arr[3] // TCO - else - Exit(TMalNil.Create) - else - Ast := Arr[2]; // TCO - end; - 'fn*': - begin - Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); - end; - else - begin - Arr := (eval_ast(Ast, Env) as TMalList).Val; - if Arr[0] is TMalFunc then - begin - Fn := Arr[0] as TMalFunc; - if Length(Arr) < 2 then - SetLength(Args, 0) - else - Args := copy(Arr, 1, Length(Arr)-1); - if Fn.Ast = nil then - Exit(Fn.Val(Args)) - else - begin - Env := TEnv.Create(Fn.Env, Fn.Params, Args); - Ast := Fn.Ast; // TCO - end - - end - else - raise Exception.Create('invalid apply'); - end; - end; - end; -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -function do_eval(Args : TMalArray) : TMal; -begin - do_eval := EVAL(Args[0], Repl_Env); -end; - -begin - Repl_Env := TEnv.Create; - core.EVAL := @EVAL; - - // core.pas: defined using Pascal - for I := 0 to core.NS.Count-1 do - begin - Key := core.NS.Keys[I]; - Repl_Env.Add(TMalSymbol.Create(Key), - TMalFunc.Create(core.NS[Key])); - end; - Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); - SetLength(CmdArgs, Max(0, ParamCount-1)); - for I := 2 to ParamCount do - CmdArgs[I-2] := TMalString.Create(ParamStr(I)); - Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); - - // core.mal: defined using language itself - REP('(def! not (fn* (a) (if a false true)))'); - REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - - if ParamCount >= 1 then - begin - REP('(load-file "' + ParamStr(1) + '")'); - ExitCode := 0; - Exit; - end; - - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + fgl, + math, + mal_readline, + mal_types, + mal_func, + reader, + printer, + mal_env, + core; + +var + Repl_Env : TEnv; + Line : string; + I : longint; + Key : string; + CmdArgs : TMalArray; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval + +function starts_with(Ast: TMal; Sym: String) : Boolean; +var + Arr : TMalArray; + A0 : TMal; +begin + if Ast.ClassType <> TMalList then Exit (False); + Arr := (Ast as TMalList).Val; + if Length (Arr) = 0 then Exit (False); + A0 := Arr [0]; + starts_with := (A0.ClassType = TMalSymbol) and ((A0 as TMalSymbol).Val = Sym); +end; + +function quasiquote(Ast: TMal) : TMal; +var + Arr : TMalArray; + Res, Elt : TMal; + I : longint; +begin + if Ast is TMalSymbol or Ast is TMalHashMap then + Exit(_list(TMalSymbol.Create('quote'), Ast)); + + if not (Ast is TMalList) then + Exit(Ast); + + Arr := (Ast as TMalList).Val; + if starts_with (Ast, 'unquote') then Exit(Arr[1]); + + Res := _list(); + for I := 1 to Length(Arr) do + begin + Elt := Arr [Length(Arr) - I]; + if starts_with (Elt, 'splice-unquote') then + Res := _list(TMalSymbol.Create('concat'), (Elt as TMalList).Val[1], Res) + else + Res := _list(TMalSymbol.Create('cons'), quasiquote (Elt), Res); + end; + if Ast.ClassType <> TMalList then + Exit(_list(TMalSymbol.Create('vec'), Res)) + else + Exit(Res); +end; + + + +// Forward declation since eval_ast call it +function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; + +function eval_ast(Ast: TMal; Env: TEnv) : TMal; +var + OldArr, NewArr : TMalArray; + OldDict, NewDict : TMalDict; + I : longint; +begin + if Ast is TMalSymbol then + begin + eval_ast := Env.Get((Ast as TMalSymbol)); + end + else if Ast is TMalList then + begin + OldArr := (Ast as TMalList).Val; + SetLength(NewArr, Length(OldArr)); + for I := 0 to Length(OldArr)-1 do + begin + NewArr[I] := EVAL(OldArr[I], Env); + end; + if Ast is TMalVector then + eval_ast := TMalVector.Create(NewArr) + else + eval_ast := TMalList.Create(NewArr); + end + else if Ast is TMalHashMap then + begin + OldDict := (Ast as TMalHashMap).Val; + NewDict := TMalDict.Create; + I := 0; + while I < OldDict.Count do + begin + NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); + I := I + 1; + end; + eval_ast := TMalHashMap.Create(NewDict); + end + else + eval_ast := Ast; +end; + +function EVAL(Ast: TMal; Env: TEnv) : TMal; +var + Lst : TMalList; + Arr : TMalArray; + Arr1 : TMalArray; + A0Sym : string; + LetEnv : TEnv; + Cond : TMal; + I : longint; + Fn : TMalFunc; + Args : TMalArray; +begin + while true do + begin + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + // Apply list + Lst := (Ast as TMalList); + Arr := Lst.Val; + if Length(Arr) = 0 then + Exit(Ast); + if Arr[0] is TMalSymbol then + A0Sym := (Arr[0] as TMalSymbol).Val + else + A0Sym := '__<*fn*>__'; + + case A0Sym of + 'def!': + Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); + 'let*': + begin + LetEnv := TEnv.Create(Env); + Arr1 := (Arr[1] as TMalList).Val; + I := 0; + while I < Length(Arr1) do + begin + LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); + Inc(I,2); + end; + Env := LetEnv; + Ast := Arr[2]; // TCO + end; + 'quote': + Exit(Arr[1]); + 'quasiquoteexpand': + Exit(quasiquote(Arr[1])); + 'quasiquote': + Ast := quasiquote(Arr[1]); + 'do': + begin + eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); + Ast := Arr[Length(Arr)-1]; // TCO + end; + 'if': + begin + Cond := EVAL(Arr[1], Env); + if (Cond is TMalNil) or (Cond is TMalFalse) then + if Length(Arr) > 3 then + Ast := Arr[3] // TCO + else + Exit(TMalNil.Create) + else + Ast := Arr[2]; // TCO + end; + 'fn*': + begin + Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); + end; + else + begin + Arr := (eval_ast(Ast, Env) as TMalList).Val; + if Arr[0] is TMalFunc then + begin + Fn := Arr[0] as TMalFunc; + if Length(Arr) < 2 then + SetLength(Args, 0) + else + Args := copy(Arr, 1, Length(Arr)-1); + if Fn.Ast = nil then + Exit(Fn.Val(Args)) + else + begin + Env := TEnv.Create(Fn.Env, Fn.Params, Args); + Ast := Fn.Ast; // TCO + end + + end + else + raise Exception.Create('invalid apply'); + end; + end; + end; +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +function do_eval(Args : TMalArray) : TMal; +begin + do_eval := EVAL(Args[0], Repl_Env); +end; + +begin + Repl_Env := TEnv.Create; + core.EVAL := @EVAL; + + // core.pas: defined using Pascal + for I := 0 to core.NS.Count-1 do + begin + Key := core.NS.Keys[I]; + Repl_Env.Add(TMalSymbol.Create(Key), + TMalFunc.Create(core.NS[Key])); + end; + Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); + SetLength(CmdArgs, Max(0, ParamCount-1)); + for I := 2 to ParamCount do + CmdArgs[I-2] := TMalString.Create(ParamStr(I)); + Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); + + // core.mal: defined using language itself + REP('(def! not (fn* (a) (if a false true)))'); + REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + + if ParamCount >= 1 then + begin + REP('(load-file "' + ParamStr(1) + '")'); + ExitCode := 0; + Exit; + end; + + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/step8_macros.pas b/impls/objpascal/step8_macros.pas index 1efe3ff2e5..e187a041f7 100644 --- a/impls/objpascal/step8_macros.pas +++ b/impls/objpascal/step8_macros.pas @@ -1,330 +1,330 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - fgl, - math, - mal_readline, - mal_types, - mal_func, - reader, - printer, - mal_env, - core; - -var - Repl_Env : TEnv; - Line : string; - I : longint; - Key : string; - CmdArgs : TMalArray; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval - -function starts_with(Ast: TMal; Sym: String) : Boolean; -var - Arr : TMalArray; - A0 : TMal; -begin - if Ast.ClassType <> TMalList then Exit (False); - Arr := (Ast as TMalList).Val; - if Length (Arr) = 0 then Exit (False); - A0 := Arr [0]; - starts_with := (A0.ClassType = TMalSymbol) and ((A0 as TMalSymbol).Val = Sym); -end; - -function quasiquote(Ast: TMal) : TMal; -var - Arr : TMalArray; - Res, Elt : TMal; - I : longint; -begin - if Ast is TMalSymbol or Ast is TMalHashMap then - Exit(_list(TMalSymbol.Create('quote'), Ast)); - - if not (Ast is TMalList) then - Exit(Ast); - - Arr := (Ast as TMalList).Val; - if starts_with (Ast, 'unquote') then Exit(Arr[1]); - - Res := _list(); - for I := 1 to Length(Arr) do - begin - Elt := Arr [Length(Arr) - I]; - if starts_with (Elt, 'splice-unquote') then - Res := _list(TMalSymbol.Create('concat'), (Elt as TMalList).Val[1], Res) - else - Res := _list(TMalSymbol.Create('cons'), quasiquote (Elt), Res); - end; - if Ast.ClassType <> TMalList then - Exit(_list(TMalSymbol.Create('vec'), Res)) - else - Exit(Res); -end; - -function is_macro_call(Ast: TMal; Env: TEnv): Boolean; -var - A0 : TMal; - Mac : TMal; -begin - is_macro_call := false; - if (Ast.ClassType = TMalList) and - (Length((Ast as TMalList).Val) > 0) then - begin - A0 := (Ast as TMalList).Val[0]; - if (A0 is TMalSymbol) and - (Env.Find(A0 as TMalSymbol) <> nil) then - begin - Mac := Env.Get((A0 as TMalSymbol)); - if Mac is TMalFunc then - is_macro_call := (Mac as TMalFunc).isMacro; - end; - end; - -end; - -// Forward declation since eval_ast call it -function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; - -function macroexpand(Ast: TMal; Env: TEnv): TMal; -var - A0 : TMal; - Arr : TMalArray; - Args : TMalArray; - Mac : TMalFunc; -begin - while is_macro_call(Ast, Env) do - begin - Arr := (Ast as TMalList).Val; - A0 := Arr[0]; - Mac := Env.Get((A0 as TMalSymbol)) as TMalFunc; - Args := (Ast as TMalList).Rest.Val; - if Mac.Ast = nil then - Ast := Mac.Val(Args) - else - Ast := EVAL(Mac.Ast, - TEnv.Create(Mac.Env, Mac.Params, Args)); - end; - macroexpand := Ast; -end; - -function eval_ast(Ast: TMal; Env: TEnv) : TMal; -var - OldArr, NewArr : TMalArray; - OldDict, NewDict : TMalDict; - I : longint; -begin - if Ast is TMalSymbol then - begin - eval_ast := Env.Get((Ast as TMalSymbol)); - end - else if Ast is TMalList then - begin - OldArr := (Ast as TMalList).Val; - SetLength(NewArr, Length(OldArr)); - for I := 0 to Length(OldArr)-1 do - begin - NewArr[I] := EVAL(OldArr[I], Env); - end; - if Ast is TMalVector then - eval_ast := TMalVector.Create(NewArr) - else - eval_ast := TMalList.Create(NewArr); - end - else if Ast is TMalHashMap then - begin - OldDict := (Ast as TMalHashMap).Val; - NewDict := TMalDict.Create; - I := 0; - while I < OldDict.Count do - begin - NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); - I := I + 1; - end; - eval_ast := TMalHashMap.Create(NewDict); - end - else - eval_ast := Ast; -end; - -function EVAL(Ast: TMal; Env: TEnv) : TMal; -var - Lst : TMalList; - Arr : TMalArray; - Arr1 : TMalArray; - A0Sym : string; - LetEnv : TEnv; - Cond : TMal; - I : longint; - Fn : TMalFunc; - Args : TMalArray; -begin - while true do - begin - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - Ast := macroexpand(Ast, Env); - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - // Apply list - Lst := (Ast as TMalList); - Arr := Lst.Val; - if Length(Arr) = 0 then - Exit(Ast); - if Arr[0] is TMalSymbol then - A0Sym := (Arr[0] as TMalSymbol).Val - else - A0Sym := '__<*fn*>__'; - - case A0Sym of - 'def!': - Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); - 'let*': - begin - LetEnv := TEnv.Create(Env); - Arr1 := (Arr[1] as TMalList).Val; - I := 0; - while I < Length(Arr1) do - begin - LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); - Inc(I,2); - end; - Env := LetEnv; - Ast := Arr[2]; // TCO - end; - 'quote': - Exit(Arr[1]); - 'quasiquoteexpand': - Exit(quasiquote(Arr[1])); - 'quasiquote': - Ast := quasiquote(Arr[1]); - 'defmacro!': - begin - Fn := EVAL(Arr[2], ENV) as TMalFunc; - Fn := TMalFunc.Clone(Fn); - Fn.isMacro := true; - Exit(Env.Add((Arr[1] as TMalSymbol), Fn)); - end; - 'macroexpand': - Exit(macroexpand(Arr[1], Env)); - 'do': - begin - eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); - Ast := Arr[Length(Arr)-1]; // TCO - end; - 'if': - begin - Cond := EVAL(Arr[1], Env); - if (Cond is TMalNil) or (Cond is TMalFalse) then - if Length(Arr) > 3 then - Ast := Arr[3] // TCO - else - Exit(TMalNil.Create) - else - Ast := Arr[2]; // TCO - end; - 'fn*': - begin - Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); - end; - else - begin - Arr := (eval_ast(Ast, Env) as TMalList).Val; - if Arr[0] is TMalFunc then - begin - Fn := Arr[0] as TMalFunc; - if Length(Arr) < 2 then - SetLength(Args, 0) - else - Args := copy(Arr, 1, Length(Arr)-1); - if Fn.Ast = nil then - Exit(Fn.Val(Args)) - else - begin - Env := TEnv.Create(Fn.Env, Fn.Params, Args); - Ast := Fn.Ast; // TCO - end - - end - else - raise Exception.Create('invalid apply'); - end; - end; - end; -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -function do_eval(Args : TMalArray) : TMal; -begin - do_eval := EVAL(Args[0], Repl_Env); -end; - -begin - Repl_Env := TEnv.Create; - core.EVAL := @EVAL; - - // core.pas: defined using Pascal - for I := 0 to core.NS.Count-1 do - begin - Key := core.NS.Keys[I]; - Repl_Env.Add(TMalSymbol.Create(Key), - TMalFunc.Create(core.NS[Key])); - end; - Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); - SetLength(CmdArgs, Max(0, ParamCount-1)); - for I := 2 to ParamCount do - CmdArgs[I-2] := TMalString.Create(ParamStr(I)); - Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); - - // core.mal: defined using language itself - REP('(def! not (fn* (a) (if a false true)))'); - REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - 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)))))))'); - - - if ParamCount >= 1 then - begin - REP('(load-file "' + ParamStr(1) + '")'); - ExitCode := 0; - Exit; - end; - - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + fgl, + math, + mal_readline, + mal_types, + mal_func, + reader, + printer, + mal_env, + core; + +var + Repl_Env : TEnv; + Line : string; + I : longint; + Key : string; + CmdArgs : TMalArray; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval + +function starts_with(Ast: TMal; Sym: String) : Boolean; +var + Arr : TMalArray; + A0 : TMal; +begin + if Ast.ClassType <> TMalList then Exit (False); + Arr := (Ast as TMalList).Val; + if Length (Arr) = 0 then Exit (False); + A0 := Arr [0]; + starts_with := (A0.ClassType = TMalSymbol) and ((A0 as TMalSymbol).Val = Sym); +end; + +function quasiquote(Ast: TMal) : TMal; +var + Arr : TMalArray; + Res, Elt : TMal; + I : longint; +begin + if Ast is TMalSymbol or Ast is TMalHashMap then + Exit(_list(TMalSymbol.Create('quote'), Ast)); + + if not (Ast is TMalList) then + Exit(Ast); + + Arr := (Ast as TMalList).Val; + if starts_with (Ast, 'unquote') then Exit(Arr[1]); + + Res := _list(); + for I := 1 to Length(Arr) do + begin + Elt := Arr [Length(Arr) - I]; + if starts_with (Elt, 'splice-unquote') then + Res := _list(TMalSymbol.Create('concat'), (Elt as TMalList).Val[1], Res) + else + Res := _list(TMalSymbol.Create('cons'), quasiquote (Elt), Res); + end; + if Ast.ClassType <> TMalList then + Exit(_list(TMalSymbol.Create('vec'), Res)) + else + Exit(Res); +end; + +function is_macro_call(Ast: TMal; Env: TEnv): Boolean; +var + A0 : TMal; + Mac : TMal; +begin + is_macro_call := false; + if (Ast.ClassType = TMalList) and + (Length((Ast as TMalList).Val) > 0) then + begin + A0 := (Ast as TMalList).Val[0]; + if (A0 is TMalSymbol) and + (Env.Find(A0 as TMalSymbol) <> nil) then + begin + Mac := Env.Get((A0 as TMalSymbol)); + if Mac is TMalFunc then + is_macro_call := (Mac as TMalFunc).isMacro; + end; + end; + +end; + +// Forward declation since eval_ast call it +function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; + +function macroexpand(Ast: TMal; Env: TEnv): TMal; +var + A0 : TMal; + Arr : TMalArray; + Args : TMalArray; + Mac : TMalFunc; +begin + while is_macro_call(Ast, Env) do + begin + Arr := (Ast as TMalList).Val; + A0 := Arr[0]; + Mac := Env.Get((A0 as TMalSymbol)) as TMalFunc; + Args := (Ast as TMalList).Rest.Val; + if Mac.Ast = nil then + Ast := Mac.Val(Args) + else + Ast := EVAL(Mac.Ast, + TEnv.Create(Mac.Env, Mac.Params, Args)); + end; + macroexpand := Ast; +end; + +function eval_ast(Ast: TMal; Env: TEnv) : TMal; +var + OldArr, NewArr : TMalArray; + OldDict, NewDict : TMalDict; + I : longint; +begin + if Ast is TMalSymbol then + begin + eval_ast := Env.Get((Ast as TMalSymbol)); + end + else if Ast is TMalList then + begin + OldArr := (Ast as TMalList).Val; + SetLength(NewArr, Length(OldArr)); + for I := 0 to Length(OldArr)-1 do + begin + NewArr[I] := EVAL(OldArr[I], Env); + end; + if Ast is TMalVector then + eval_ast := TMalVector.Create(NewArr) + else + eval_ast := TMalList.Create(NewArr); + end + else if Ast is TMalHashMap then + begin + OldDict := (Ast as TMalHashMap).Val; + NewDict := TMalDict.Create; + I := 0; + while I < OldDict.Count do + begin + NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); + I := I + 1; + end; + eval_ast := TMalHashMap.Create(NewDict); + end + else + eval_ast := Ast; +end; + +function EVAL(Ast: TMal; Env: TEnv) : TMal; +var + Lst : TMalList; + Arr : TMalArray; + Arr1 : TMalArray; + A0Sym : string; + LetEnv : TEnv; + Cond : TMal; + I : longint; + Fn : TMalFunc; + Args : TMalArray; +begin + while true do + begin + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + Ast := macroexpand(Ast, Env); + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + // Apply list + Lst := (Ast as TMalList); + Arr := Lst.Val; + if Length(Arr) = 0 then + Exit(Ast); + if Arr[0] is TMalSymbol then + A0Sym := (Arr[0] as TMalSymbol).Val + else + A0Sym := '__<*fn*>__'; + + case A0Sym of + 'def!': + Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); + 'let*': + begin + LetEnv := TEnv.Create(Env); + Arr1 := (Arr[1] as TMalList).Val; + I := 0; + while I < Length(Arr1) do + begin + LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); + Inc(I,2); + end; + Env := LetEnv; + Ast := Arr[2]; // TCO + end; + 'quote': + Exit(Arr[1]); + 'quasiquoteexpand': + Exit(quasiquote(Arr[1])); + 'quasiquote': + Ast := quasiquote(Arr[1]); + 'defmacro!': + begin + Fn := EVAL(Arr[2], ENV) as TMalFunc; + Fn := TMalFunc.Clone(Fn); + Fn.isMacro := true; + Exit(Env.Add((Arr[1] as TMalSymbol), Fn)); + end; + 'macroexpand': + Exit(macroexpand(Arr[1], Env)); + 'do': + begin + eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); + Ast := Arr[Length(Arr)-1]; // TCO + end; + 'if': + begin + Cond := EVAL(Arr[1], Env); + if (Cond is TMalNil) or (Cond is TMalFalse) then + if Length(Arr) > 3 then + Ast := Arr[3] // TCO + else + Exit(TMalNil.Create) + else + Ast := Arr[2]; // TCO + end; + 'fn*': + begin + Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); + end; + else + begin + Arr := (eval_ast(Ast, Env) as TMalList).Val; + if Arr[0] is TMalFunc then + begin + Fn := Arr[0] as TMalFunc; + if Length(Arr) < 2 then + SetLength(Args, 0) + else + Args := copy(Arr, 1, Length(Arr)-1); + if Fn.Ast = nil then + Exit(Fn.Val(Args)) + else + begin + Env := TEnv.Create(Fn.Env, Fn.Params, Args); + Ast := Fn.Ast; // TCO + end + + end + else + raise Exception.Create('invalid apply'); + end; + end; + end; +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +function do_eval(Args : TMalArray) : TMal; +begin + do_eval := EVAL(Args[0], Repl_Env); +end; + +begin + Repl_Env := TEnv.Create; + core.EVAL := @EVAL; + + // core.pas: defined using Pascal + for I := 0 to core.NS.Count-1 do + begin + Key := core.NS.Keys[I]; + Repl_Env.Add(TMalSymbol.Create(Key), + TMalFunc.Create(core.NS[Key])); + end; + Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); + SetLength(CmdArgs, Max(0, ParamCount-1)); + for I := 2 to ParamCount do + CmdArgs[I-2] := TMalString.Create(ParamStr(I)); + Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); + + // core.mal: defined using language itself + REP('(def! not (fn* (a) (if a false true)))'); + REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + 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)))))))'); + + + if ParamCount >= 1 then + begin + REP('(load-file "' + ParamStr(1) + '")'); + ExitCode := 0; + Exit; + end; + + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/step9_try.pas b/impls/objpascal/step9_try.pas index 3ce8c89159..2d7204c830 100644 --- a/impls/objpascal/step9_try.pas +++ b/impls/objpascal/step9_try.pas @@ -1,355 +1,355 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - fgl, - math, - mal_readline, - mal_types, - mal_func, - reader, - printer, - mal_env, - core; - -var - Repl_Env : TEnv; - Line : string; - I : longint; - Key : string; - CmdArgs : TMalArray; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval - -function starts_with(Ast: TMal; Sym: String) : Boolean; -var - Arr : TMalArray; - A0 : TMal; -begin - if Ast.ClassType <> TMalList then Exit (False); - Arr := (Ast as TMalList).Val; - if Length (Arr) = 0 then Exit (False); - A0 := Arr [0]; - starts_with := (A0.ClassType = TMalSymbol) and ((A0 as TMalSymbol).Val = Sym); -end; - -function quasiquote(Ast: TMal) : TMal; -var - Arr : TMalArray; - Res, Elt : TMal; - I : longint; -begin - if Ast is TMalSymbol or Ast is TMalHashMap then - Exit(_list(TMalSymbol.Create('quote'), Ast)); - - if not (Ast is TMalList) then - Exit(Ast); - - Arr := (Ast as TMalList).Val; - if starts_with (Ast, 'unquote') then Exit(Arr[1]); - - Res := _list(); - for I := 1 to Length(Arr) do - begin - Elt := Arr [Length(Arr) - I]; - if starts_with (Elt, 'splice-unquote') then - Res := _list(TMalSymbol.Create('concat'), (Elt as TMalList).Val[1], Res) - else - Res := _list(TMalSymbol.Create('cons'), quasiquote (Elt), Res); - end; - if Ast.ClassType <> TMalList then - Exit(_list(TMalSymbol.Create('vec'), Res)) - else - Exit(Res); -end; - -function is_macro_call(Ast: TMal; Env: TEnv): Boolean; -var - A0 : TMal; - Mac : TMal; -begin - is_macro_call := false; - if (Ast.ClassType = TMalList) and - (Length((Ast as TMalList).Val) > 0) then - begin - A0 := (Ast as TMalList).Val[0]; - if (A0 is TMalSymbol) and - (Env.Find(A0 as TMalSymbol) <> nil) then - begin - Mac := Env.Get((A0 as TMalSymbol)); - if Mac is TMalFunc then - is_macro_call := (Mac as TMalFunc).isMacro; - end; - end; - -end; - -// Forward declation since eval_ast call it -function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; - -function macroexpand(Ast: TMal; Env: TEnv): TMal; -var - A0 : TMal; - Arr : TMalArray; - Args : TMalArray; - Mac : TMalFunc; -begin - while is_macro_call(Ast, Env) do - begin - Arr := (Ast as TMalList).Val; - A0 := Arr[0]; - Mac := Env.Get((A0 as TMalSymbol)) as TMalFunc; - Args := (Ast as TMalList).Rest.Val; - if Mac.Ast = nil then - Ast := Mac.Val(Args) - else - Ast := EVAL(Mac.Ast, - TEnv.Create(Mac.Env, Mac.Params, Args)); - end; - macroexpand := Ast; -end; - -function eval_ast(Ast: TMal; Env: TEnv) : TMal; -var - OldArr, NewArr : TMalArray; - OldDict, NewDict : TMalDict; - I : longint; -begin - if Ast is TMalSymbol then - begin - eval_ast := Env.Get((Ast as TMalSymbol)); - end - else if Ast is TMalList then - begin - OldArr := (Ast as TMalList).Val; - SetLength(NewArr, Length(OldArr)); - for I := 0 to Length(OldArr)-1 do - begin - NewArr[I] := EVAL(OldArr[I], Env); - end; - if Ast is TMalVector then - eval_ast := TMalVector.Create(NewArr) - else - eval_ast := TMalList.Create(NewArr); - end - else if Ast is TMalHashMap then - begin - OldDict := (Ast as TMalHashMap).Val; - NewDict := TMalDict.Create; - I := 0; - while I < OldDict.Count do - begin - NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); - I := I + 1; - end; - eval_ast := TMalHashMap.Create(NewDict); - end - else - eval_ast := Ast; -end; - -function EVAL(Ast: TMal; Env: TEnv) : TMal; -var - Lst : TMalList; - Arr : TMalArray; - Arr1 : TMalArray; - A0Sym : string; - LetEnv : TEnv; - Cond : TMal; - I : longint; - Fn : TMalFunc; - Args : TMalArray; - Err : TMalArray; -begin - while true do - begin - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - Ast := macroexpand(Ast, Env); - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - // Apply list - Lst := (Ast as TMalList); - Arr := Lst.Val; - if Length(Arr) = 0 then - Exit(Ast); - if Arr[0] is TMalSymbol then - A0Sym := (Arr[0] as TMalSymbol).Val - else - A0Sym := '__<*fn*>__'; - - case A0Sym of - 'def!': - Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); - 'let*': - begin - LetEnv := TEnv.Create(Env); - Arr1 := (Arr[1] as TMalList).Val; - I := 0; - while I < Length(Arr1) do - begin - LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); - Inc(I,2); - end; - Env := LetEnv; - Ast := Arr[2]; // TCO - end; - 'quote': - Exit(Arr[1]); - 'quasiquoteexpand': - Exit(quasiquote(Arr[1])); - 'quasiquote': - Ast := quasiquote(Arr[1]); - 'defmacro!': - begin - Fn := EVAL(Arr[2], ENV) as TMalFunc; - Fn := TMalFunc.Clone(Fn); - Fn.isMacro := true; - Exit(Env.Add((Arr[1] as TMalSymbol), Fn)); - end; - 'macroexpand': - Exit(macroexpand(Arr[1], Env)); - 'try*': - begin - try - Exit(EVAL(Arr[1], Env)); - except - On E : Exception do - begin - if Length(Arr) < 3 then - raise; - SetLength(Err, 1); - if E.ClassType = TMalException then - Err[0] := (E as TMalException).Val - else - Err[0] := TMalString.Create(E.message); - Arr := (Arr[2] as TMalList).Val; - Exit(EVAL(Arr[2], TEnv.Create(Env, - _list(Arr[1]), - Err))); - end; - end; - end; - 'do': - begin - eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); - Ast := Arr[Length(Arr)-1]; // TCO - end; - 'if': - begin - Cond := EVAL(Arr[1], Env); - if (Cond is TMalNil) or (Cond is TMalFalse) then - if Length(Arr) > 3 then - Ast := Arr[3] // TCO - else - Exit(TMalNil.Create) - else - Ast := Arr[2]; // TCO - end; - 'fn*': - begin - Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); - end; - else - begin - Arr := (eval_ast(Ast, Env) as TMalList).Val; - if Arr[0] is TMalFunc then - begin - Fn := Arr[0] as TMalFunc; - if Length(Arr) < 2 then - SetLength(Args, 0) - else - Args := copy(Arr, 1, Length(Arr)-1); - if Fn.Ast = nil then - Exit(Fn.Val(Args)) - else - begin - Env := TEnv.Create(Fn.Env, Fn.Params, Args); - Ast := Fn.Ast; // TCO - end - - end - else - raise Exception.Create('invalid apply'); - end; - end; - end; -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -function do_eval(Args : TMalArray) : TMal; -begin - do_eval := EVAL(Args[0], Repl_Env); -end; - -begin - Repl_Env := TEnv.Create; - core.EVAL := @EVAL; - - // core.pas: defined using Pascal - for I := 0 to core.NS.Count-1 do - begin - Key := core.NS.Keys[I]; - Repl_Env.Add(TMalSymbol.Create(Key), - TMalFunc.Create(core.NS[Key])); - end; - Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); - SetLength(CmdArgs, Max(0, ParamCount-1)); - for I := 2 to ParamCount do - CmdArgs[I-2] := TMalString.Create(ParamStr(I)); - Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); - - // core.mal: defined using language itself - REP('(def! not (fn* (a) (if a false true)))'); - REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - 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)))))))'); - - - if ParamCount >= 1 then - begin - REP('(load-file "' + ParamStr(1) + '")'); - ExitCode := 0; - Exit; - end; - - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - if E.ClassType = TMalException then - WriteLn('Error: ' + pr_str((E as TMalException).Val, True)) - else - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + fgl, + math, + mal_readline, + mal_types, + mal_func, + reader, + printer, + mal_env, + core; + +var + Repl_Env : TEnv; + Line : string; + I : longint; + Key : string; + CmdArgs : TMalArray; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval + +function starts_with(Ast: TMal; Sym: String) : Boolean; +var + Arr : TMalArray; + A0 : TMal; +begin + if Ast.ClassType <> TMalList then Exit (False); + Arr := (Ast as TMalList).Val; + if Length (Arr) = 0 then Exit (False); + A0 := Arr [0]; + starts_with := (A0.ClassType = TMalSymbol) and ((A0 as TMalSymbol).Val = Sym); +end; + +function quasiquote(Ast: TMal) : TMal; +var + Arr : TMalArray; + Res, Elt : TMal; + I : longint; +begin + if Ast is TMalSymbol or Ast is TMalHashMap then + Exit(_list(TMalSymbol.Create('quote'), Ast)); + + if not (Ast is TMalList) then + Exit(Ast); + + Arr := (Ast as TMalList).Val; + if starts_with (Ast, 'unquote') then Exit(Arr[1]); + + Res := _list(); + for I := 1 to Length(Arr) do + begin + Elt := Arr [Length(Arr) - I]; + if starts_with (Elt, 'splice-unquote') then + Res := _list(TMalSymbol.Create('concat'), (Elt as TMalList).Val[1], Res) + else + Res := _list(TMalSymbol.Create('cons'), quasiquote (Elt), Res); + end; + if Ast.ClassType <> TMalList then + Exit(_list(TMalSymbol.Create('vec'), Res)) + else + Exit(Res); +end; + +function is_macro_call(Ast: TMal; Env: TEnv): Boolean; +var + A0 : TMal; + Mac : TMal; +begin + is_macro_call := false; + if (Ast.ClassType = TMalList) and + (Length((Ast as TMalList).Val) > 0) then + begin + A0 := (Ast as TMalList).Val[0]; + if (A0 is TMalSymbol) and + (Env.Find(A0 as TMalSymbol) <> nil) then + begin + Mac := Env.Get((A0 as TMalSymbol)); + if Mac is TMalFunc then + is_macro_call := (Mac as TMalFunc).isMacro; + end; + end; + +end; + +// Forward declation since eval_ast call it +function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; + +function macroexpand(Ast: TMal; Env: TEnv): TMal; +var + A0 : TMal; + Arr : TMalArray; + Args : TMalArray; + Mac : TMalFunc; +begin + while is_macro_call(Ast, Env) do + begin + Arr := (Ast as TMalList).Val; + A0 := Arr[0]; + Mac := Env.Get((A0 as TMalSymbol)) as TMalFunc; + Args := (Ast as TMalList).Rest.Val; + if Mac.Ast = nil then + Ast := Mac.Val(Args) + else + Ast := EVAL(Mac.Ast, + TEnv.Create(Mac.Env, Mac.Params, Args)); + end; + macroexpand := Ast; +end; + +function eval_ast(Ast: TMal; Env: TEnv) : TMal; +var + OldArr, NewArr : TMalArray; + OldDict, NewDict : TMalDict; + I : longint; +begin + if Ast is TMalSymbol then + begin + eval_ast := Env.Get((Ast as TMalSymbol)); + end + else if Ast is TMalList then + begin + OldArr := (Ast as TMalList).Val; + SetLength(NewArr, Length(OldArr)); + for I := 0 to Length(OldArr)-1 do + begin + NewArr[I] := EVAL(OldArr[I], Env); + end; + if Ast is TMalVector then + eval_ast := TMalVector.Create(NewArr) + else + eval_ast := TMalList.Create(NewArr); + end + else if Ast is TMalHashMap then + begin + OldDict := (Ast as TMalHashMap).Val; + NewDict := TMalDict.Create; + I := 0; + while I < OldDict.Count do + begin + NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); + I := I + 1; + end; + eval_ast := TMalHashMap.Create(NewDict); + end + else + eval_ast := Ast; +end; + +function EVAL(Ast: TMal; Env: TEnv) : TMal; +var + Lst : TMalList; + Arr : TMalArray; + Arr1 : TMalArray; + A0Sym : string; + LetEnv : TEnv; + Cond : TMal; + I : longint; + Fn : TMalFunc; + Args : TMalArray; + Err : TMalArray; +begin + while true do + begin + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + Ast := macroexpand(Ast, Env); + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + // Apply list + Lst := (Ast as TMalList); + Arr := Lst.Val; + if Length(Arr) = 0 then + Exit(Ast); + if Arr[0] is TMalSymbol then + A0Sym := (Arr[0] as TMalSymbol).Val + else + A0Sym := '__<*fn*>__'; + + case A0Sym of + 'def!': + Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); + 'let*': + begin + LetEnv := TEnv.Create(Env); + Arr1 := (Arr[1] as TMalList).Val; + I := 0; + while I < Length(Arr1) do + begin + LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); + Inc(I,2); + end; + Env := LetEnv; + Ast := Arr[2]; // TCO + end; + 'quote': + Exit(Arr[1]); + 'quasiquoteexpand': + Exit(quasiquote(Arr[1])); + 'quasiquote': + Ast := quasiquote(Arr[1]); + 'defmacro!': + begin + Fn := EVAL(Arr[2], ENV) as TMalFunc; + Fn := TMalFunc.Clone(Fn); + Fn.isMacro := true; + Exit(Env.Add((Arr[1] as TMalSymbol), Fn)); + end; + 'macroexpand': + Exit(macroexpand(Arr[1], Env)); + 'try*': + begin + try + Exit(EVAL(Arr[1], Env)); + except + On E : Exception do + begin + if Length(Arr) < 3 then + raise; + SetLength(Err, 1); + if E.ClassType = TMalException then + Err[0] := (E as TMalException).Val + else + Err[0] := TMalString.Create(E.message); + Arr := (Arr[2] as TMalList).Val; + Exit(EVAL(Arr[2], TEnv.Create(Env, + _list(Arr[1]), + Err))); + end; + end; + end; + 'do': + begin + eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); + Ast := Arr[Length(Arr)-1]; // TCO + end; + 'if': + begin + Cond := EVAL(Arr[1], Env); + if (Cond is TMalNil) or (Cond is TMalFalse) then + if Length(Arr) > 3 then + Ast := Arr[3] // TCO + else + Exit(TMalNil.Create) + else + Ast := Arr[2]; // TCO + end; + 'fn*': + begin + Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); + end; + else + begin + Arr := (eval_ast(Ast, Env) as TMalList).Val; + if Arr[0] is TMalFunc then + begin + Fn := Arr[0] as TMalFunc; + if Length(Arr) < 2 then + SetLength(Args, 0) + else + Args := copy(Arr, 1, Length(Arr)-1); + if Fn.Ast = nil then + Exit(Fn.Val(Args)) + else + begin + Env := TEnv.Create(Fn.Env, Fn.Params, Args); + Ast := Fn.Ast; // TCO + end + + end + else + raise Exception.Create('invalid apply'); + end; + end; + end; +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +function do_eval(Args : TMalArray) : TMal; +begin + do_eval := EVAL(Args[0], Repl_Env); +end; + +begin + Repl_Env := TEnv.Create; + core.EVAL := @EVAL; + + // core.pas: defined using Pascal + for I := 0 to core.NS.Count-1 do + begin + Key := core.NS.Keys[I]; + Repl_Env.Add(TMalSymbol.Create(Key), + TMalFunc.Create(core.NS[Key])); + end; + Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); + SetLength(CmdArgs, Max(0, ParamCount-1)); + for I := 2 to ParamCount do + CmdArgs[I-2] := TMalString.Create(ParamStr(I)); + Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); + + // core.mal: defined using language itself + REP('(def! not (fn* (a) (if a false true)))'); + REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + 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)))))))'); + + + if ParamCount >= 1 then + begin + REP('(load-file "' + ParamStr(1) + '")'); + ExitCode := 0; + Exit; + end; + + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + if E.ClassType = TMalException then + WriteLn('Error: ' + pr_str((E as TMalException).Val, True)) + else + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/stepA_mal.pas b/impls/objpascal/stepA_mal.pas index 51174c9934..7d82ae6214 100644 --- a/impls/objpascal/stepA_mal.pas +++ b/impls/objpascal/stepA_mal.pas @@ -1,358 +1,358 @@ -program Mal; - -{$H+} // Use AnsiString - -Uses sysutils, - CMem, - fgl, - math, - mal_readline, - mal_types, - mal_func, - reader, - printer, - mal_env, - core; - -var - Repl_Env : TEnv; - Line : string; - I : longint; - Key : string; - CmdArgs : TMalArray; - -// read -function READ(const Str: string) : TMal; -begin - READ := read_str(Str); -end; - -// eval - -function starts_with(Ast: TMal; Sym: String) : Boolean; -var - Arr : TMalArray; - A0 : TMal; -begin - if Ast.ClassType <> TMalList then Exit (False); - Arr := (Ast as TMalList).Val; - if Length (Arr) = 0 then Exit (False); - A0 := Arr [0]; - starts_with := (A0.ClassType = TMalSymbol) and ((A0 as TMalSymbol).Val = Sym); -end; - -function quasiquote(Ast: TMal) : TMal; -var - Arr : TMalArray; - Res, Elt : TMal; - I : longint; -begin - if Ast is TMalSymbol or Ast is TMalHashMap then - Exit(_list(TMalSymbol.Create('quote'), Ast)); - - if not (Ast is TMalList) then - Exit(Ast); - - Arr := (Ast as TMalList).Val; - if starts_with (Ast, 'unquote') then Exit(Arr[1]); - - Res := _list(); - for I := 1 to Length(Arr) do - begin - Elt := Arr [Length(Arr) - I]; - if starts_with (Elt, 'splice-unquote') then - Res := _list(TMalSymbol.Create('concat'), (Elt as TMalList).Val[1], Res) - else - Res := _list(TMalSymbol.Create('cons'), quasiquote (Elt), Res); - end; - if Ast.ClassType <> TMalList then - Exit(_list(TMalSymbol.Create('vec'), Res)) - else - Exit(Res); -end; - -function is_macro_call(Ast: TMal; Env: TEnv): Boolean; -var - A0 : TMal; - Mac : TMal; -begin - is_macro_call := false; - if (Ast.ClassType = TMalList) and - (Length((Ast as TMalList).Val) > 0) then - begin - A0 := (Ast as TMalList).Val[0]; - if (A0 is TMalSymbol) and - (Env.Find(A0 as TMalSymbol) <> nil) then - begin - Mac := Env.Get((A0 as TMalSymbol)); - if Mac is TMalFunc then - is_macro_call := (Mac as TMalFunc).isMacro; - end; - end; - -end; - -// Forward declation since eval_ast call it -function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; - -function macroexpand(Ast: TMal; Env: TEnv): TMal; -var - A0 : TMal; - Arr : TMalArray; - Args : TMalArray; - Mac : TMalFunc; -begin - while is_macro_call(Ast, Env) do - begin - Arr := (Ast as TMalList).Val; - A0 := Arr[0]; - Mac := Env.Get((A0 as TMalSymbol)) as TMalFunc; - Args := (Ast as TMalList).Rest.Val; - if Mac.Ast = nil then - Ast := Mac.Val(Args) - else - Ast := EVAL(Mac.Ast, - TEnv.Create(Mac.Env, Mac.Params, Args)); - end; - macroexpand := Ast; -end; - -function eval_ast(Ast: TMal; Env: TEnv) : TMal; -var - OldArr, NewArr : TMalArray; - OldDict, NewDict : TMalDict; - I : longint; -begin - if Ast is TMalSymbol then - begin - eval_ast := Env.Get((Ast as TMalSymbol)); - end - else if Ast is TMalList then - begin - OldArr := (Ast as TMalList).Val; - SetLength(NewArr, Length(OldArr)); - for I := 0 to Length(OldArr)-1 do - begin - NewArr[I] := EVAL(OldArr[I], Env); - end; - if Ast is TMalVector then - eval_ast := TMalVector.Create(NewArr) - else - eval_ast := TMalList.Create(NewArr); - end - else if Ast is TMalHashMap then - begin - OldDict := (Ast as TMalHashMap).Val; - NewDict := TMalDict.Create; - I := 0; - while I < OldDict.Count do - begin - NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); - I := I + 1; - end; - eval_ast := TMalHashMap.Create(NewDict); - end - else - eval_ast := Ast; -end; - -function EVAL(Ast: TMal; Env: TEnv) : TMal; -var - Lst : TMalList; - Arr : TMalArray; - Arr1 : TMalArray; - A0Sym : string; - LetEnv : TEnv; - Cond : TMal; - I : longint; - Fn : TMalFunc; - Args : TMalArray; - Err : TMalArray; -begin - while true do - begin - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - Ast := macroexpand(Ast, Env); - if Ast.ClassType <> TMalList then - Exit(eval_ast(Ast, Env)); - - // Apply list - Lst := (Ast as TMalList); - Arr := Lst.Val; - if Length(Arr) = 0 then - Exit(Ast); - if Arr[0] is TMalSymbol then - A0Sym := (Arr[0] as TMalSymbol).Val - else - A0Sym := '__<*fn*>__'; - - case A0Sym of - 'def!': - Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); - 'let*': - begin - LetEnv := TEnv.Create(Env); - Arr1 := (Arr[1] as TMalList).Val; - I := 0; - while I < Length(Arr1) do - begin - LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); - Inc(I,2); - end; - Env := LetEnv; - Ast := Arr[2]; // TCO - end; - 'quote': - Exit(Arr[1]); - 'quasiquoteexpand': - Exit(quasiquote(Arr[1])); - 'quasiquote': - Ast := quasiquote(Arr[1]); - 'defmacro!': - begin - Fn := EVAL(Arr[2], ENV) as TMalFunc; - Fn := TMalFunc.Clone(Fn); - Fn.isMacro := true; - Exit(Env.Add((Arr[1] as TMalSymbol), Fn)); - end; - 'macroexpand': - Exit(macroexpand(Arr[1], Env)); - 'try*': - begin - try - Exit(EVAL(Arr[1], Env)); - except - On E : Exception do - begin - if Length(Arr) < 3 then - raise; - SetLength(Err, 1); - if E.ClassType = TMalException then - Err[0] := (E as TMalException).Val - else - Err[0] := TMalString.Create(E.message); - Arr := (Arr[2] as TMalList).Val; - Exit(EVAL(Arr[2], TEnv.Create(Env, - _list(Arr[1]), - Err))); - end; - end; - end; - 'do': - begin - eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); - Ast := Arr[Length(Arr)-1]; // TCO - end; - 'if': - begin - Cond := EVAL(Arr[1], Env); - if (Cond is TMalNil) or (Cond is TMalFalse) then - if Length(Arr) > 3 then - Ast := Arr[3] // TCO - else - Exit(TMalNil.Create) - else - Ast := Arr[2]; // TCO - end; - 'fn*': - begin - Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); - end; - else - begin - Arr := (eval_ast(Ast, Env) as TMalList).Val; - if Arr[0] is TMalFunc then - begin - Fn := Arr[0] as TMalFunc; - if Length(Arr) < 2 then - SetLength(Args, 0) - else - Args := copy(Arr, 1, Length(Arr)-1); - if Fn.Ast = nil then - Exit(Fn.Val(Args)) - else - begin - Env := TEnv.Create(Fn.Env, Fn.Params, Args); - Ast := Fn.Ast; // TCO - end - - end - else - raise Exception.Create('invalid apply'); - end; - end; - end; -end; - -// print -function PRINT(Exp: TMal) : string; -begin - PRINT := pr_str(Exp, True); -end; - -// repl -function REP(Str: string) : string; -begin - REP := PRINT(EVAL(READ(Str), Repl_Env)); -end; - -function do_eval(Args : TMalArray) : TMal; -begin - do_eval := EVAL(Args[0], Repl_Env); -end; - -begin - Repl_Env := TEnv.Create; - core.EVAL := @EVAL; - - // core.pas: defined using Pascal - for I := 0 to core.NS.Count-1 do - begin - Key := core.NS.Keys[I]; - Repl_Env.Add(TMalSymbol.Create(Key), - TMalFunc.Create(core.NS[Key])); - end; - Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); - SetLength(CmdArgs, Max(0, ParamCount-1)); - for I := 2 to ParamCount do - CmdArgs[I-2] := TMalString.Create(ParamStr(I)); - Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); - Repl_Env.Add(TMalSymbol.Create('*host-language*'), - TMalString.Create('Object Pascal')); - - // core.mal: defined using language itself - REP('(def! not (fn* (a) (if a false true)))'); - REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - 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)))))))'); - - - if ParamCount >= 1 then - begin - REP('(load-file "' + ParamStr(1) + '")'); - ExitCode := 0; - Exit; - end; - - REP('(println (str "Mal [" *host-language* "]"))'); - while True do - begin - try - Line := _readline('user> '); - if Line = '' then continue; - WriteLn(REP(Line)) - except - On E : MalEOF do Halt(0); - On E : Exception do - begin - if E.ClassType = TMalException then - WriteLn('Error: ' + pr_str((E as TMalException).Val, True)) - else - WriteLn('Error: ' + E.message); - WriteLn('Backtrace:'); - WriteLn(GetBacktrace(E)); - end; - end; - end; -end. +program Mal; + +{$H+} // Use AnsiString + +Uses sysutils, + CMem, + fgl, + math, + mal_readline, + mal_types, + mal_func, + reader, + printer, + mal_env, + core; + +var + Repl_Env : TEnv; + Line : string; + I : longint; + Key : string; + CmdArgs : TMalArray; + +// read +function READ(const Str: string) : TMal; +begin + READ := read_str(Str); +end; + +// eval + +function starts_with(Ast: TMal; Sym: String) : Boolean; +var + Arr : TMalArray; + A0 : TMal; +begin + if Ast.ClassType <> TMalList then Exit (False); + Arr := (Ast as TMalList).Val; + if Length (Arr) = 0 then Exit (False); + A0 := Arr [0]; + starts_with := (A0.ClassType = TMalSymbol) and ((A0 as TMalSymbol).Val = Sym); +end; + +function quasiquote(Ast: TMal) : TMal; +var + Arr : TMalArray; + Res, Elt : TMal; + I : longint; +begin + if Ast is TMalSymbol or Ast is TMalHashMap then + Exit(_list(TMalSymbol.Create('quote'), Ast)); + + if not (Ast is TMalList) then + Exit(Ast); + + Arr := (Ast as TMalList).Val; + if starts_with (Ast, 'unquote') then Exit(Arr[1]); + + Res := _list(); + for I := 1 to Length(Arr) do + begin + Elt := Arr [Length(Arr) - I]; + if starts_with (Elt, 'splice-unquote') then + Res := _list(TMalSymbol.Create('concat'), (Elt as TMalList).Val[1], Res) + else + Res := _list(TMalSymbol.Create('cons'), quasiquote (Elt), Res); + end; + if Ast.ClassType <> TMalList then + Exit(_list(TMalSymbol.Create('vec'), Res)) + else + Exit(Res); +end; + +function is_macro_call(Ast: TMal; Env: TEnv): Boolean; +var + A0 : TMal; + Mac : TMal; +begin + is_macro_call := false; + if (Ast.ClassType = TMalList) and + (Length((Ast as TMalList).Val) > 0) then + begin + A0 := (Ast as TMalList).Val[0]; + if (A0 is TMalSymbol) and + (Env.Find(A0 as TMalSymbol) <> nil) then + begin + Mac := Env.Get((A0 as TMalSymbol)); + if Mac is TMalFunc then + is_macro_call := (Mac as TMalFunc).isMacro; + end; + end; + +end; + +// Forward declation since eval_ast call it +function EVAL(Ast: TMal; Env: TEnv) : TMal; forward; + +function macroexpand(Ast: TMal; Env: TEnv): TMal; +var + A0 : TMal; + Arr : TMalArray; + Args : TMalArray; + Mac : TMalFunc; +begin + while is_macro_call(Ast, Env) do + begin + Arr := (Ast as TMalList).Val; + A0 := Arr[0]; + Mac := Env.Get((A0 as TMalSymbol)) as TMalFunc; + Args := (Ast as TMalList).Rest.Val; + if Mac.Ast = nil then + Ast := Mac.Val(Args) + else + Ast := EVAL(Mac.Ast, + TEnv.Create(Mac.Env, Mac.Params, Args)); + end; + macroexpand := Ast; +end; + +function eval_ast(Ast: TMal; Env: TEnv) : TMal; +var + OldArr, NewArr : TMalArray; + OldDict, NewDict : TMalDict; + I : longint; +begin + if Ast is TMalSymbol then + begin + eval_ast := Env.Get((Ast as TMalSymbol)); + end + else if Ast is TMalList then + begin + OldArr := (Ast as TMalList).Val; + SetLength(NewArr, Length(OldArr)); + for I := 0 to Length(OldArr)-1 do + begin + NewArr[I] := EVAL(OldArr[I], Env); + end; + if Ast is TMalVector then + eval_ast := TMalVector.Create(NewArr) + else + eval_ast := TMalList.Create(NewArr); + end + else if Ast is TMalHashMap then + begin + OldDict := (Ast as TMalHashMap).Val; + NewDict := TMalDict.Create; + I := 0; + while I < OldDict.Count do + begin + NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env); + I := I + 1; + end; + eval_ast := TMalHashMap.Create(NewDict); + end + else + eval_ast := Ast; +end; + +function EVAL(Ast: TMal; Env: TEnv) : TMal; +var + Lst : TMalList; + Arr : TMalArray; + Arr1 : TMalArray; + A0Sym : string; + LetEnv : TEnv; + Cond : TMal; + I : longint; + Fn : TMalFunc; + Args : TMalArray; + Err : TMalArray; +begin + while true do + begin + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + Ast := macroexpand(Ast, Env); + if Ast.ClassType <> TMalList then + Exit(eval_ast(Ast, Env)); + + // Apply list + Lst := (Ast as TMalList); + Arr := Lst.Val; + if Length(Arr) = 0 then + Exit(Ast); + if Arr[0] is TMalSymbol then + A0Sym := (Arr[0] as TMalSymbol).Val + else + A0Sym := '__<*fn*>__'; + + case A0Sym of + 'def!': + Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV))); + 'let*': + begin + LetEnv := TEnv.Create(Env); + Arr1 := (Arr[1] as TMalList).Val; + I := 0; + while I < Length(Arr1) do + begin + LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv)); + Inc(I,2); + end; + Env := LetEnv; + Ast := Arr[2]; // TCO + end; + 'quote': + Exit(Arr[1]); + 'quasiquoteexpand': + Exit(quasiquote(Arr[1])); + 'quasiquote': + Ast := quasiquote(Arr[1]); + 'defmacro!': + begin + Fn := EVAL(Arr[2], ENV) as TMalFunc; + Fn := TMalFunc.Clone(Fn); + Fn.isMacro := true; + Exit(Env.Add((Arr[1] as TMalSymbol), Fn)); + end; + 'macroexpand': + Exit(macroexpand(Arr[1], Env)); + 'try*': + begin + try + Exit(EVAL(Arr[1], Env)); + except + On E : Exception do + begin + if Length(Arr) < 3 then + raise; + SetLength(Err, 1); + if E.ClassType = TMalException then + Err[0] := (E as TMalException).Val + else + Err[0] := TMalString.Create(E.message); + Arr := (Arr[2] as TMalList).Val; + Exit(EVAL(Arr[2], TEnv.Create(Env, + _list(Arr[1]), + Err))); + end; + end; + end; + 'do': + begin + eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env); + Ast := Arr[Length(Arr)-1]; // TCO + end; + 'if': + begin + Cond := EVAL(Arr[1], Env); + if (Cond is TMalNil) or (Cond is TMalFalse) then + if Length(Arr) > 3 then + Ast := Arr[3] // TCO + else + Exit(TMalNil.Create) + else + Ast := Arr[2]; // TCO + end; + 'fn*': + begin + Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))); + end; + else + begin + Arr := (eval_ast(Ast, Env) as TMalList).Val; + if Arr[0] is TMalFunc then + begin + Fn := Arr[0] as TMalFunc; + if Length(Arr) < 2 then + SetLength(Args, 0) + else + Args := copy(Arr, 1, Length(Arr)-1); + if Fn.Ast = nil then + Exit(Fn.Val(Args)) + else + begin + Env := TEnv.Create(Fn.Env, Fn.Params, Args); + Ast := Fn.Ast; // TCO + end + + end + else + raise Exception.Create('invalid apply'); + end; + end; + end; +end; + +// print +function PRINT(Exp: TMal) : string; +begin + PRINT := pr_str(Exp, True); +end; + +// repl +function REP(Str: string) : string; +begin + REP := PRINT(EVAL(READ(Str), Repl_Env)); +end; + +function do_eval(Args : TMalArray) : TMal; +begin + do_eval := EVAL(Args[0], Repl_Env); +end; + +begin + Repl_Env := TEnv.Create; + core.EVAL := @EVAL; + + // core.pas: defined using Pascal + for I := 0 to core.NS.Count-1 do + begin + Key := core.NS.Keys[I]; + Repl_Env.Add(TMalSymbol.Create(Key), + TMalFunc.Create(core.NS[Key])); + end; + Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval)); + SetLength(CmdArgs, Max(0, ParamCount-1)); + for I := 2 to ParamCount do + CmdArgs[I-2] := TMalString.Create(ParamStr(I)); + Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs)); + Repl_Env.Add(TMalSymbol.Create('*host-language*'), + TMalString.Create('Object Pascal')); + + // core.mal: defined using language itself + REP('(def! not (fn* (a) (if a false true)))'); + REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + 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)))))))'); + + + if ParamCount >= 1 then + begin + REP('(load-file "' + ParamStr(1) + '")'); + ExitCode := 0; + Exit; + end; + + REP('(println (str "Mal [" *host-language* "]"))'); + while True do + begin + try + Line := _readline('user> '); + if Line = '' then continue; + WriteLn(REP(Line)) + except + On E : MalEOF do Halt(0); + On E : Exception do + begin + if E.ClassType = TMalException then + WriteLn('Error: ' + pr_str((E as TMalException).Val, True)) + else + WriteLn('Error: ' + E.message); + WriteLn('Backtrace:'); + WriteLn(GetBacktrace(E)); + end; + end; + end; +end. diff --git a/impls/objpascal/tests/step5_tco.mal b/impls/objpascal/tests/step5_tco.mal index 9a24ee4d02..36c6012fcb 100644 --- a/impls/objpascal/tests/step5_tco.mal +++ b/impls/objpascal/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Object Pascal: skipping non-TCO recursion -;; Reason: completes at 10,000, unrecoverable segfault at 20,000 +;; Object Pascal: skipping non-TCO recursion +;; Reason: completes at 10,000, unrecoverable segfault at 20,000 diff --git a/impls/ocaml/Dockerfile b/impls/ocaml/Dockerfile index 399553dbc3..d32c4e9570 100644 --- a/impls/ocaml/Dockerfile +++ b/impls/ocaml/Dockerfile @@ -1,25 +1,25 @@ -[FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install ocaml-batteries-included - +[FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install ocaml-batteries-included + diff --git a/impls/ocaml/Makefile b/impls/ocaml/Makefile index a12f3fc162..613d7ffeb5 100644 --- a/impls/ocaml/Makefile +++ b/impls/ocaml/Makefile @@ -1,33 +1,33 @@ -STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ - step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml \ - step8_macros.ml step9_try.ml stepA_mal.ml -MODULES = types.ml reader.ml printer.ml env.ml core.ml -LIBS = str.cmxa unix.cmxa -MAL_LIB = mal_lib.cmxa - -STEP_BINS = $(STEPS:%.ml=%) -LAST_STEP_BIN = $(word $(words $(STEP_BINS)),$(STEP_BINS)) - -all: $(STEP_BINS) - -dist: mal - -mal: $(LAST_STEP_BIN) - cp $< $@ - -# ocaml repl apparently needs bytecode, not native, compilation. -# Just do it all right here: -repl: - ocamlc -c $(LIBS:%.cmxa=%.cma) $(MODULES) $(STEPS) - rlwrap ocaml $(LIBS:%.cmxa=%.cma) $(MODULES:%.ml=%.cmo) - -$(MAL_LIB): $(MODULES) - ocamlopt -a $(MODULES) -o $@ - -$(STEP_BINS): %: %.ml $(MAL_LIB) - ocamlopt $(LIBS) $(MAL_LIB) $< -o $@ - -clean: - rm -f $(STEP_BINS) mal mal_lib.* *.cmo *.cmx *.cmi *.o - -.PHONY: all repl clean +STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ + step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml \ + step8_macros.ml step9_try.ml stepA_mal.ml +MODULES = types.ml reader.ml printer.ml env.ml core.ml +LIBS = str.cmxa unix.cmxa +MAL_LIB = mal_lib.cmxa + +STEP_BINS = $(STEPS:%.ml=%) +LAST_STEP_BIN = $(word $(words $(STEP_BINS)),$(STEP_BINS)) + +all: $(STEP_BINS) + +dist: mal + +mal: $(LAST_STEP_BIN) + cp $< $@ + +# ocaml repl apparently needs bytecode, not native, compilation. +# Just do it all right here: +repl: + ocamlc -c $(LIBS:%.cmxa=%.cma) $(MODULES) $(STEPS) + rlwrap ocaml $(LIBS:%.cmxa=%.cma) $(MODULES:%.ml=%.cmo) + +$(MAL_LIB): $(MODULES) + ocamlopt -a $(MODULES) -o $@ + +$(STEP_BINS): %: %.ml $(MAL_LIB) + ocamlopt $(LIBS) $(MAL_LIB) $< -o $@ + +clean: + rm -f $(STEP_BINS) mal mal_lib.* *.cmo *.cmx *.cmi *.o + +.PHONY: all repl clean diff --git a/impls/ocaml/core.ml b/impls/ocaml/core.ml index da2041e94b..2fbbdec3d0 100644 --- a/impls/ocaml/core.ml +++ b/impls/ocaml/core.ml @@ -1,242 +1,242 @@ -module T = Types.Types -let ns = Env.make None - -let kw_macro = T.Keyword "macro" - -let num_fun t f = Types.fn - (function - | [(T.Int a); (T.Int b)] -> t (f a b) - | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) - -let mk_int x = T.Int x -let mk_bool x = T.Bool x - -let seq = function - | T.List { T.value = xs } -> xs - | T.Vector { T.value = xs } -> xs - | T.Map { T.value = xs } -> - Types.MalMap.fold (fun k v list -> k :: v :: list) xs [] - | _ -> [] - -let mal_seq = function - | [T.Nil] -> T.Nil - | [T.List {T.value = []}] - | [T.Vector {T.value = []}] -> T.Nil - | [T.List _ as lst] -> lst - | [T.Vector {T.value = xs}] -> Types.list xs - | [T.String ""] -> T.Nil - | [T.String s] -> Types.list (List.map (fun x -> T.String x) (Str.split (Str.regexp "") s)) - | _ -> T.Nil - -let rec assoc = function - | c :: k :: v :: (_ :: _ as xs) -> assoc ((assoc [c; k; v]) :: xs) - | [T.Nil; k; v] -> Types.map (Types.MalMap.add k v Types.MalMap.empty) - | [T.Map { T.value = m; T.meta = meta }; k; v] - -> T.Map { T.value = (Types.MalMap.add k v m); - T.meta = meta } - | _ -> T.Nil - -let rec dissoc = function - | c :: x :: (_ :: _ as xs) -> dissoc ((dissoc [c; x]) :: xs) - | [T.Map { T.value = m; T.meta = meta }; k] - -> T.Map { T.value = (Types.MalMap.remove k m); - T.meta = meta } - | _ -> T.Nil - -let rec conj = function - | c :: x :: (_ :: _ as xs) -> conj ((conj [c; x]) :: xs) - | [T.Map { T.value = c; T.meta = meta }; T.Vector { T.value = [k; v] }] - -> T.Map { T.value = (Types.MalMap.add k v c); - T.meta = meta } - | [T.List { T.value = c; T.meta = meta }; x ] - -> T.List { T.value = x :: c; - T.meta = meta } - | [T.Vector { T.value = c; T.meta = meta }; x ] - -> T.Vector { T.value = c @ [x]; - T.meta = meta } - | _ -> T.Nil - -let init env = begin - Env.set env (Types.symbol "throw") - (Types.fn (function [ast] -> raise (Types.MalExn ast) | _ -> T.Nil)); - - Env.set env (Types.symbol "+") (num_fun mk_int ( + )); - Env.set env (Types.symbol "-") (num_fun mk_int ( - )); - Env.set env (Types.symbol "*") (num_fun mk_int ( * )); - Env.set env (Types.symbol "/") (num_fun mk_int ( / )); - Env.set env (Types.symbol "<") (num_fun mk_bool ( < )); - Env.set env (Types.symbol "<=") (num_fun mk_bool ( <= )); - Env.set env (Types.symbol ">") (num_fun mk_bool ( > )); - Env.set env (Types.symbol ">=") (num_fun mk_bool ( >= )); - - Env.set env (Types.symbol "list") (Types.fn (function xs -> Types.list xs)); - Env.set env (Types.symbol "list?") - (Types.fn (function [T.List _] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "vector") (Types.fn (function xs -> Types.vector xs)); - Env.set env (Types.symbol "vector?") - (Types.fn (function [T.Vector _] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "empty?") - (Types.fn (function - | [T.List {T.value = []}] -> T.Bool true - | [T.Vector {T.value = []}] -> T.Bool true - | _ -> T.Bool false)); - Env.set env (Types.symbol "count") - (Types.fn (function - | [T.List {T.value = xs}] - | [T.Vector {T.value = xs}] -> T.Int (List.length xs) - | _ -> T.Int 0)); - Env.set env (Types.symbol "=") - (Types.fn (function - | [a; b] -> T.Bool (Types.mal_equal a b) - | _ -> T.Bool false)); - - Env.set env (Types.symbol "pr-str") - (Types.fn (function xs -> - T.String (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs)))); - Env.set env (Types.symbol "str") - (Types.fn (function xs -> - T.String (String.concat "" (List.map (fun s -> Printer.pr_str s false) xs)))); - Env.set env (Types.symbol "prn") - (Types.fn (function xs -> - print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs)); - T.Nil)); - Env.set env (Types.symbol "println") - (Types.fn (function xs -> - print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s false) xs)); - T.Nil)); - - Env.set env (Types.symbol "compare") - (Types.fn (function [a; b] -> T.Int (compare a b) | _ -> T.Nil)); - Env.set env (Types.symbol "with-meta") - (Types.fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil)); - Env.set env (Types.symbol "meta") - (Types.fn (function [x] -> Printer.meta x | _ -> T.Nil)); - - Env.set env (Types.symbol "read-string") - (Types.fn (function [T.String x] -> Reader.read_str x | _ -> T.Nil)); - Env.set env (Types.symbol "slurp") - (Types.fn (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil)); - - Env.set env (Types.symbol "cons") - (Types.fn (function [x; xs] -> Types.list (x :: (seq xs)) | _ -> T.Nil)); - Env.set env (Types.symbol "concat") - (Types.fn (let rec concat = - function - | x :: y :: more -> concat ((Types.list ((seq x) @ (seq y))) :: more) - | [T.List _ as x] -> x - | [x] -> Types.list (seq x) - | [] -> Types.list [] - in concat)); - Env.set env (Types.symbol "vec") (Types.fn (function - | [T.List {T.value = xs}] -> Types.vector xs - | [T.Vector {T.value = xs}] -> Types.vector xs - | [_] -> raise (Invalid_argument "vec: expects a sequence") - | _ -> raise (Invalid_argument "vec: arg count"))); - - Env.set env (Types.symbol "nth") - (Types.fn (function [xs; T.Int i] -> - (try List.nth (seq xs) i with _ -> raise (Invalid_argument "nth: index out of range")) | _ -> T.Nil)); - Env.set env (Types.symbol "first") - (Types.fn (function - | [xs] -> (match seq xs with x :: _ -> x | _ -> T.Nil) - | _ -> T.Nil)); - Env.set env (Types.symbol "rest") - (Types.fn (function - | [xs] -> Types.list (match seq xs with _ :: xs -> xs | _ -> []) - | _ -> T.Nil)); - - Env.set env (Types.symbol "string?") - (Types.fn (function [T.String _] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "symbol") - (Types.fn (function [T.String x] -> Types.symbol x | _ -> T.Nil)); - Env.set env (Types.symbol "symbol?") - (Types.fn (function [T.Symbol _] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "keyword") - (Types.fn (function - | [T.String x] -> T.Keyword x - | [T.Keyword x] -> T.Keyword x - | _ -> T.Nil)); - Env.set env (Types.symbol "keyword?") - (Types.fn (function [T.Keyword _] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "number?") - (Types.fn (function [T.Int _] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "fn?") - (Types.fn (function - | [T.Fn { T.meta = T.Map { T.value = meta } }] - -> mk_bool (not (Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta))) - | [T.Fn _] -> T.Bool true - | _ -> T.Bool false)); - Env.set env (Types.symbol "macro?") - (Types.fn (function - | [T.Fn { T.meta = T.Map { T.value = meta } }] - -> mk_bool (Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta)) - | _ -> T.Bool false)); - Env.set env (Types.symbol "nil?") - (Types.fn (function [T.Nil] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "true?") - (Types.fn (function [T.Bool true] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "false?") - (Types.fn (function [T.Bool false] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "sequential?") - (Types.fn (function [T.List _] | [T.Vector _] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "apply") - (Types.fn (function - | (T.Fn { T.value = f } :: apply_args) -> - (match List.rev apply_args with - | last_arg :: rev_args -> - f ((List.rev rev_args) @ (seq last_arg)) - | [] -> f []) - | _ -> raise (Invalid_argument "First arg to apply must be a fn"))); - Env.set env (Types.symbol "map") - (Types.fn (function - | [T.Fn { T.value = f }; xs] -> - Types.list (List.map (fun x -> f [x]) (seq xs)) - | _ -> T.Nil)); - Env.set env (Types.symbol "readline") - (Types.fn (function - | [T.String x] -> print_string x; T.String (read_line ()) - | _ -> T.String (read_line ()))); - - Env.set env (Types.symbol "map?") - (Types.fn (function [T.Map _] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "hash-map") - (Types.fn (function xs -> Types.list_into_map Types.MalMap.empty xs)); - Env.set env (Types.symbol "assoc") (Types.fn assoc); - Env.set env (Types.symbol "dissoc") (Types.fn dissoc); - Env.set env (Types.symbol "get") - (Types.fn (function - | [T.Map { T.value = m }; k] - -> (try Types.MalMap.find k m with _ -> T.Nil) - | _ -> T.Nil)); - Env.set env (Types.symbol "keys") - (Types.fn (function - | [T.Map { T.value = m }] - -> Types.list (Types.MalMap.fold (fun k _ c -> k :: c) m []) - | _ -> T.Nil)); - Env.set env (Types.symbol "vals") - (Types.fn (function - | [T.Map { T.value = m }] - -> Types.list (Types.MalMap.fold (fun _ v c -> v :: c) m []) - | _ -> T.Nil)); - Env.set env (Types.symbol "contains?") - (Types.fn (function - | [T.Map { T.value = m }; k] -> T.Bool (Types.MalMap.mem k m) - | _ -> T.Bool false)); - Env.set env (Types.symbol "conj") (Types.fn conj); - Env.set env (Types.symbol "seq") (Types.fn mal_seq); - - Env.set env (Types.symbol "atom?") - (Types.fn (function [T.Atom _] -> T.Bool true | _ -> T.Bool false)); - Env.set env (Types.symbol "atom") - (Types.fn (function [x] -> T.Atom (ref x) | _ -> T.Nil)); - Env.set env (Types.symbol "deref") - (Types.fn (function [T.Atom x] -> !x | _ -> T.Nil)); - Env.set env (Types.symbol "reset!") - (Types.fn (function [T.Atom x; v] -> x := v; v | _ -> T.Nil)); - Env.set env (Types.symbol "swap!") - (Types.fn (function T.Atom x :: T.Fn { T.value = f } :: args - -> let v = f (!x :: args) in x := v; v | _ -> T.Nil)); - - Env.set env (Types.symbol "time-ms") - (Types.fn (function _ -> T.Int (truncate (1000.0 *. Unix.gettimeofday ())))); -end +module T = Types.Types +let ns = Env.make None + +let kw_macro = T.Keyword "macro" + +let num_fun t f = Types.fn + (function + | [(T.Int a); (T.Int b)] -> t (f a b) + | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) + +let mk_int x = T.Int x +let mk_bool x = T.Bool x + +let seq = function + | T.List { T.value = xs } -> xs + | T.Vector { T.value = xs } -> xs + | T.Map { T.value = xs } -> + Types.MalMap.fold (fun k v list -> k :: v :: list) xs [] + | _ -> [] + +let mal_seq = function + | [T.Nil] -> T.Nil + | [T.List {T.value = []}] + | [T.Vector {T.value = []}] -> T.Nil + | [T.List _ as lst] -> lst + | [T.Vector {T.value = xs}] -> Types.list xs + | [T.String ""] -> T.Nil + | [T.String s] -> Types.list (List.map (fun x -> T.String x) (Str.split (Str.regexp "") s)) + | _ -> T.Nil + +let rec assoc = function + | c :: k :: v :: (_ :: _ as xs) -> assoc ((assoc [c; k; v]) :: xs) + | [T.Nil; k; v] -> Types.map (Types.MalMap.add k v Types.MalMap.empty) + | [T.Map { T.value = m; T.meta = meta }; k; v] + -> T.Map { T.value = (Types.MalMap.add k v m); + T.meta = meta } + | _ -> T.Nil + +let rec dissoc = function + | c :: x :: (_ :: _ as xs) -> dissoc ((dissoc [c; x]) :: xs) + | [T.Map { T.value = m; T.meta = meta }; k] + -> T.Map { T.value = (Types.MalMap.remove k m); + T.meta = meta } + | _ -> T.Nil + +let rec conj = function + | c :: x :: (_ :: _ as xs) -> conj ((conj [c; x]) :: xs) + | [T.Map { T.value = c; T.meta = meta }; T.Vector { T.value = [k; v] }] + -> T.Map { T.value = (Types.MalMap.add k v c); + T.meta = meta } + | [T.List { T.value = c; T.meta = meta }; x ] + -> T.List { T.value = x :: c; + T.meta = meta } + | [T.Vector { T.value = c; T.meta = meta }; x ] + -> T.Vector { T.value = c @ [x]; + T.meta = meta } + | _ -> T.Nil + +let init env = begin + Env.set env (Types.symbol "throw") + (Types.fn (function [ast] -> raise (Types.MalExn ast) | _ -> T.Nil)); + + Env.set env (Types.symbol "+") (num_fun mk_int ( + )); + Env.set env (Types.symbol "-") (num_fun mk_int ( - )); + Env.set env (Types.symbol "*") (num_fun mk_int ( * )); + Env.set env (Types.symbol "/") (num_fun mk_int ( / )); + Env.set env (Types.symbol "<") (num_fun mk_bool ( < )); + Env.set env (Types.symbol "<=") (num_fun mk_bool ( <= )); + Env.set env (Types.symbol ">") (num_fun mk_bool ( > )); + Env.set env (Types.symbol ">=") (num_fun mk_bool ( >= )); + + Env.set env (Types.symbol "list") (Types.fn (function xs -> Types.list xs)); + Env.set env (Types.symbol "list?") + (Types.fn (function [T.List _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "vector") (Types.fn (function xs -> Types.vector xs)); + Env.set env (Types.symbol "vector?") + (Types.fn (function [T.Vector _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "empty?") + (Types.fn (function + | [T.List {T.value = []}] -> T.Bool true + | [T.Vector {T.value = []}] -> T.Bool true + | _ -> T.Bool false)); + Env.set env (Types.symbol "count") + (Types.fn (function + | [T.List {T.value = xs}] + | [T.Vector {T.value = xs}] -> T.Int (List.length xs) + | _ -> T.Int 0)); + Env.set env (Types.symbol "=") + (Types.fn (function + | [a; b] -> T.Bool (Types.mal_equal a b) + | _ -> T.Bool false)); + + Env.set env (Types.symbol "pr-str") + (Types.fn (function xs -> + T.String (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs)))); + Env.set env (Types.symbol "str") + (Types.fn (function xs -> + T.String (String.concat "" (List.map (fun s -> Printer.pr_str s false) xs)))); + Env.set env (Types.symbol "prn") + (Types.fn (function xs -> + print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs)); + T.Nil)); + Env.set env (Types.symbol "println") + (Types.fn (function xs -> + print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s false) xs)); + T.Nil)); + + Env.set env (Types.symbol "compare") + (Types.fn (function [a; b] -> T.Int (compare a b) | _ -> T.Nil)); + Env.set env (Types.symbol "with-meta") + (Types.fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil)); + Env.set env (Types.symbol "meta") + (Types.fn (function [x] -> Printer.meta x | _ -> T.Nil)); + + Env.set env (Types.symbol "read-string") + (Types.fn (function [T.String x] -> Reader.read_str x | _ -> T.Nil)); + Env.set env (Types.symbol "slurp") + (Types.fn (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil)); + + Env.set env (Types.symbol "cons") + (Types.fn (function [x; xs] -> Types.list (x :: (seq xs)) | _ -> T.Nil)); + Env.set env (Types.symbol "concat") + (Types.fn (let rec concat = + function + | x :: y :: more -> concat ((Types.list ((seq x) @ (seq y))) :: more) + | [T.List _ as x] -> x + | [x] -> Types.list (seq x) + | [] -> Types.list [] + in concat)); + Env.set env (Types.symbol "vec") (Types.fn (function + | [T.List {T.value = xs}] -> Types.vector xs + | [T.Vector {T.value = xs}] -> Types.vector xs + | [_] -> raise (Invalid_argument "vec: expects a sequence") + | _ -> raise (Invalid_argument "vec: arg count"))); + + Env.set env (Types.symbol "nth") + (Types.fn (function [xs; T.Int i] -> + (try List.nth (seq xs) i with _ -> raise (Invalid_argument "nth: index out of range")) | _ -> T.Nil)); + Env.set env (Types.symbol "first") + (Types.fn (function + | [xs] -> (match seq xs with x :: _ -> x | _ -> T.Nil) + | _ -> T.Nil)); + Env.set env (Types.symbol "rest") + (Types.fn (function + | [xs] -> Types.list (match seq xs with _ :: xs -> xs | _ -> []) + | _ -> T.Nil)); + + Env.set env (Types.symbol "string?") + (Types.fn (function [T.String _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "symbol") + (Types.fn (function [T.String x] -> Types.symbol x | _ -> T.Nil)); + Env.set env (Types.symbol "symbol?") + (Types.fn (function [T.Symbol _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "keyword") + (Types.fn (function + | [T.String x] -> T.Keyword x + | [T.Keyword x] -> T.Keyword x + | _ -> T.Nil)); + Env.set env (Types.symbol "keyword?") + (Types.fn (function [T.Keyword _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "number?") + (Types.fn (function [T.Int _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "fn?") + (Types.fn (function + | [T.Fn { T.meta = T.Map { T.value = meta } }] + -> mk_bool (not (Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta))) + | [T.Fn _] -> T.Bool true + | _ -> T.Bool false)); + Env.set env (Types.symbol "macro?") + (Types.fn (function + | [T.Fn { T.meta = T.Map { T.value = meta } }] + -> mk_bool (Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta)) + | _ -> T.Bool false)); + Env.set env (Types.symbol "nil?") + (Types.fn (function [T.Nil] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "true?") + (Types.fn (function [T.Bool true] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "false?") + (Types.fn (function [T.Bool false] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "sequential?") + (Types.fn (function [T.List _] | [T.Vector _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "apply") + (Types.fn (function + | (T.Fn { T.value = f } :: apply_args) -> + (match List.rev apply_args with + | last_arg :: rev_args -> + f ((List.rev rev_args) @ (seq last_arg)) + | [] -> f []) + | _ -> raise (Invalid_argument "First arg to apply must be a fn"))); + Env.set env (Types.symbol "map") + (Types.fn (function + | [T.Fn { T.value = f }; xs] -> + Types.list (List.map (fun x -> f [x]) (seq xs)) + | _ -> T.Nil)); + Env.set env (Types.symbol "readline") + (Types.fn (function + | [T.String x] -> print_string x; T.String (read_line ()) + | _ -> T.String (read_line ()))); + + Env.set env (Types.symbol "map?") + (Types.fn (function [T.Map _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "hash-map") + (Types.fn (function xs -> Types.list_into_map Types.MalMap.empty xs)); + Env.set env (Types.symbol "assoc") (Types.fn assoc); + Env.set env (Types.symbol "dissoc") (Types.fn dissoc); + Env.set env (Types.symbol "get") + (Types.fn (function + | [T.Map { T.value = m }; k] + -> (try Types.MalMap.find k m with _ -> T.Nil) + | _ -> T.Nil)); + Env.set env (Types.symbol "keys") + (Types.fn (function + | [T.Map { T.value = m }] + -> Types.list (Types.MalMap.fold (fun k _ c -> k :: c) m []) + | _ -> T.Nil)); + Env.set env (Types.symbol "vals") + (Types.fn (function + | [T.Map { T.value = m }] + -> Types.list (Types.MalMap.fold (fun _ v c -> v :: c) m []) + | _ -> T.Nil)); + Env.set env (Types.symbol "contains?") + (Types.fn (function + | [T.Map { T.value = m }; k] -> T.Bool (Types.MalMap.mem k m) + | _ -> T.Bool false)); + Env.set env (Types.symbol "conj") (Types.fn conj); + Env.set env (Types.symbol "seq") (Types.fn mal_seq); + + Env.set env (Types.symbol "atom?") + (Types.fn (function [T.Atom _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "atom") + (Types.fn (function [x] -> T.Atom (ref x) | _ -> T.Nil)); + Env.set env (Types.symbol "deref") + (Types.fn (function [T.Atom x] -> !x | _ -> T.Nil)); + Env.set env (Types.symbol "reset!") + (Types.fn (function [T.Atom x; v] -> x := v; v | _ -> T.Nil)); + Env.set env (Types.symbol "swap!") + (Types.fn (function T.Atom x :: T.Fn { T.value = f } :: args + -> let v = f (!x :: args) in x := v; v | _ -> T.Nil)); + + Env.set env (Types.symbol "time-ms") + (Types.fn (function _ -> T.Int (truncate (1000.0 *. Unix.gettimeofday ())))); +end diff --git a/impls/ocaml/env.ml b/impls/ocaml/env.ml index cb32360eb0..e47c380888 100644 --- a/impls/ocaml/env.ml +++ b/impls/ocaml/env.ml @@ -1,33 +1,33 @@ -module T = Types.Types -module Data = Map.Make (String) - -type env = { - outer : env option; - data : Types.mal_type Data.t ref; -} - -let make outer = { outer = outer; data = ref Data.empty } - -let set env sym value = - match sym with - | T.Symbol { T.value = key } -> env.data := Data.add key value !(env.data) - | _ -> raise (Invalid_argument "set requires a Symbol for its key") - -let rec find env sym = - match sym with - | T.Symbol { T.value = key } -> - (if Data.mem key !(env.data) then - Some env - else - match env.outer with - | Some outer -> find outer sym - | None -> None) - | _ -> raise (Invalid_argument "find requires a Symbol for its key") - -let get env sym = - match sym with - | T.Symbol { T.value = key } -> - (match find env sym with - | Some found_env -> Data.find key !(found_env.data) - | None -> raise (Invalid_argument ("'" ^ key ^ "' not found"))) - | _ -> raise (Invalid_argument "get requires a Symbol for its key") +module T = Types.Types +module Data = Map.Make (String) + +type env = { + outer : env option; + data : Types.mal_type Data.t ref; +} + +let make outer = { outer = outer; data = ref Data.empty } + +let set env sym value = + match sym with + | T.Symbol { T.value = key } -> env.data := Data.add key value !(env.data) + | _ -> raise (Invalid_argument "set requires a Symbol for its key") + +let rec find env sym = + match sym with + | T.Symbol { T.value = key } -> + (if Data.mem key !(env.data) then + Some env + else + match env.outer with + | Some outer -> find outer sym + | None -> None) + | _ -> raise (Invalid_argument "find requires a Symbol for its key") + +let get env sym = + match sym with + | T.Symbol { T.value = key } -> + (match find env sym with + | Some found_env -> Data.find key !(found_env.data) + | None -> raise (Invalid_argument ("'" ^ key ^ "' not found"))) + | _ -> raise (Invalid_argument "get requires a Symbol for its key") diff --git a/impls/ocaml/printer.ml b/impls/ocaml/printer.ml index 74a8c64502..f81278c7e8 100644 --- a/impls/ocaml/printer.ml +++ b/impls/ocaml/printer.ml @@ -1,38 +1,38 @@ -module T = Types.Types - -let meta obj = - match obj with - | T.List { T.meta = meta } -> meta - | T.Map { T.meta = meta } -> meta - | T.Vector { T.meta = meta } -> meta - | T.Symbol { T.meta = meta } -> meta - | T.Fn { T.meta = meta } -> meta - | _ -> T.Nil - -let rec pr_str mal_obj print_readably = - let r = print_readably in - match mal_obj with - | T.Int i -> string_of_int i - | T.Symbol { T.value = s } -> s - | T.Keyword s -> ":" ^ s - | T.Nil -> "nil" - | T.Bool true -> "true" - | T.Bool false -> "false" - | T.String s -> - if r - then "\"" ^ (Reader.gsub (Str.regexp "\\([\"\\\n]\\)") - (function - | "\n" -> "\\n" - | x -> "\\" ^ x) - s) ^ "\"" - else s - | T.List { T.value = xs } -> - "(" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ ")" - | T.Vector { T.value = xs } -> - "[" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ "]" - | T.Map { T.value = xs } -> - "{" ^ (Types.MalMap.fold (fun k v s -> s ^ (if s = "" then "" else " ") ^ (pr_str k r) - ^ " " ^ (pr_str v r)) xs "") - ^ "}" - | T.Fn f -> "#" - | T.Atom x -> "(atom " ^ (pr_str !x r) ^ ")" +module T = Types.Types + +let meta obj = + match obj with + | T.List { T.meta = meta } -> meta + | T.Map { T.meta = meta } -> meta + | T.Vector { T.meta = meta } -> meta + | T.Symbol { T.meta = meta } -> meta + | T.Fn { T.meta = meta } -> meta + | _ -> T.Nil + +let rec pr_str mal_obj print_readably = + let r = print_readably in + match mal_obj with + | T.Int i -> string_of_int i + | T.Symbol { T.value = s } -> s + | T.Keyword s -> ":" ^ s + | T.Nil -> "nil" + | T.Bool true -> "true" + | T.Bool false -> "false" + | T.String s -> + if r + then "\"" ^ (Reader.gsub (Str.regexp "\\([\"\\\n]\\)") + (function + | "\n" -> "\\n" + | x -> "\\" ^ x) + s) ^ "\"" + else s + | T.List { T.value = xs } -> + "(" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ ")" + | T.Vector { T.value = xs } -> + "[" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ "]" + | T.Map { T.value = xs } -> + "{" ^ (Types.MalMap.fold (fun k v s -> s ^ (if s = "" then "" else " ") ^ (pr_str k r) + ^ " " ^ (pr_str v r)) xs "") + ^ "}" + | T.Fn f -> "#" + | T.Atom x -> "(atom " ^ (pr_str !x r) ^ ")" diff --git a/impls/ocaml/reader.ml b/impls/ocaml/reader.ml index b9e2bce753..54bef1aacc 100644 --- a/impls/ocaml/reader.ml +++ b/impls/ocaml/reader.ml @@ -1,125 +1,125 @@ -module T = Types.Types - (* ^file ^module *) - -let slurp filename = - let chan = open_in filename in - let b = Buffer.create 27 in - Buffer.add_channel b chan (in_channel_length chan) ; - close_in chan ; - Buffer.contents b - -let find_re re str = - List.map (function | Str.Delim x -> x | Str.Text x -> "impossible!") - (List.filter (function | Str.Delim x -> true | Str.Text x -> false) - (Str.full_split re str)) - -let gsub re f str = - String.concat - "" (List.map (function | Str.Delim x -> f x | Str.Text x -> x) - (Str.full_split re str)) - -let token_re = (Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"?\\|;.*\\|[^][ \n{}('\"`,;)]*") -let string_re = (Str.regexp "\"\\(\\\\.\\|[^\\\\\"]\\)*\"") - -type reader = { - form : Types.mal_type; - tokens : string list; -} - -type list_reader = { - list_form : Types.mal_type list; - tokens : string list; -} - -let unescape_string token = - if Str.string_match string_re token 0 - then - let without_quotes = String.sub token 1 ((String.length token) - 2) in - gsub (Str.regexp "\\\\.") - (function | "\\n" -> "\n" | x -> String.sub x 1 1) - without_quotes - else - (output_string stderr ("expected '\"', got EOF\n"); - flush stderr; - raise End_of_file) - -let read_atom token = - match token with - | "nil" -> T.Nil - | "true" -> T.Bool true - | "false" -> T.Bool false - | _ -> - match token.[0] with - | '0'..'9' -> T.Int (int_of_string token) - | '-' -> (match String.length token with - | 1 -> Types.symbol token - | _ -> (match token.[1] with - | '0'..'9' -> T.Int (int_of_string token) - | _ -> Types.symbol token)) - | '"' -> T.String (unescape_string token) - | ':' -> T.Keyword (Str.replace_first (Str.regexp "^:") "" token) - | _ -> Types.symbol token - -let with_meta obj meta = - match obj with - | T.List { T.value = v } - -> T.List { T.value = v; T.meta = meta }; | T.Map { T.value = v } - -> T.Map { T.value = v; T.meta = meta }; | T.Vector { T.value = v } - -> T.Vector { T.value = v; T.meta = meta }; | T.Symbol { T.value = v } - -> T.Symbol { T.value = v; T.meta = meta }; | T.Fn { T.value = v } - -> T.Fn { T.value = v; T.meta = meta }; - | _ -> raise (Invalid_argument "metadata not supported on this type") - -let rec read_list eol list_reader = - match list_reader.tokens with - | [] -> output_string stderr ("expected '" ^ eol ^ "', got EOF\n"); - flush stderr; - raise End_of_file; - | token :: tokens -> - if Str.string_match (Str.regexp eol) token 0 then - {list_form = list_reader.list_form; tokens = tokens} - else if token.[0] = ';' then - read_list eol { list_form = list_reader.list_form; - tokens = tokens } - else - let reader = read_form list_reader.tokens in - read_list eol {list_form = list_reader.list_form @ [reader.form]; - tokens = reader.tokens} -and read_quote sym tokens = - let reader = read_form tokens in - {form = Types.list [ Types.symbol sym; reader.form ]; - tokens = reader.tokens} -and read_form all_tokens = - match all_tokens with - | [] -> raise End_of_file; - | token :: tokens -> - match token with - | "'" -> read_quote "quote" tokens - | "`" -> read_quote "quasiquote" tokens - | "~" -> read_quote "unquote" tokens - | "~@" -> read_quote "splice-unquote" tokens - | "@" -> read_quote "deref" tokens - | "^" -> - let meta = read_form tokens in - let value = read_form meta.tokens in - {(*form = with_meta value.form meta.form;*) - form = Types.list [Types.symbol "with-meta"; value.form; meta.form]; - tokens = value.tokens} - | "(" -> - let list_reader = read_list ")" {list_form = []; tokens = tokens} in - {form = Types.list list_reader.list_form; - tokens = list_reader.tokens} - | "{" -> - let list_reader = read_list "}" {list_form = []; tokens = tokens} in - {form = Types.list_into_map Types.MalMap.empty list_reader.list_form; - tokens = list_reader.tokens} - | "[" -> - let list_reader = read_list "]" {list_form = []; tokens = tokens} in - {form = Types.vector list_reader.list_form; - tokens = list_reader.tokens} - | _ -> if token.[0] = ';' - then read_form tokens - else {form = read_atom token; tokens = tokens} - -let read_str str = (read_form (List.filter ((<>) "") (find_re token_re str))).form - +module T = Types.Types + (* ^file ^module *) + +let slurp filename = + let chan = open_in filename in + let b = Buffer.create 27 in + Buffer.add_channel b chan (in_channel_length chan) ; + close_in chan ; + Buffer.contents b + +let find_re re str = + List.map (function | Str.Delim x -> x | Str.Text x -> "impossible!") + (List.filter (function | Str.Delim x -> true | Str.Text x -> false) + (Str.full_split re str)) + +let gsub re f str = + String.concat + "" (List.map (function | Str.Delim x -> f x | Str.Text x -> x) + (Str.full_split re str)) + +let token_re = (Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"?\\|;.*\\|[^][ \n{}('\"`,;)]*") +let string_re = (Str.regexp "\"\\(\\\\.\\|[^\\\\\"]\\)*\"") + +type reader = { + form : Types.mal_type; + tokens : string list; +} + +type list_reader = { + list_form : Types.mal_type list; + tokens : string list; +} + +let unescape_string token = + if Str.string_match string_re token 0 + then + let without_quotes = String.sub token 1 ((String.length token) - 2) in + gsub (Str.regexp "\\\\.") + (function | "\\n" -> "\n" | x -> String.sub x 1 1) + without_quotes + else + (output_string stderr ("expected '\"', got EOF\n"); + flush stderr; + raise End_of_file) + +let read_atom token = + match token with + | "nil" -> T.Nil + | "true" -> T.Bool true + | "false" -> T.Bool false + | _ -> + match token.[0] with + | '0'..'9' -> T.Int (int_of_string token) + | '-' -> (match String.length token with + | 1 -> Types.symbol token + | _ -> (match token.[1] with + | '0'..'9' -> T.Int (int_of_string token) + | _ -> Types.symbol token)) + | '"' -> T.String (unescape_string token) + | ':' -> T.Keyword (Str.replace_first (Str.regexp "^:") "" token) + | _ -> Types.symbol token + +let with_meta obj meta = + match obj with + | T.List { T.value = v } + -> T.List { T.value = v; T.meta = meta }; | T.Map { T.value = v } + -> T.Map { T.value = v; T.meta = meta }; | T.Vector { T.value = v } + -> T.Vector { T.value = v; T.meta = meta }; | T.Symbol { T.value = v } + -> T.Symbol { T.value = v; T.meta = meta }; | T.Fn { T.value = v } + -> T.Fn { T.value = v; T.meta = meta }; + | _ -> raise (Invalid_argument "metadata not supported on this type") + +let rec read_list eol list_reader = + match list_reader.tokens with + | [] -> output_string stderr ("expected '" ^ eol ^ "', got EOF\n"); + flush stderr; + raise End_of_file; + | token :: tokens -> + if Str.string_match (Str.regexp eol) token 0 then + {list_form = list_reader.list_form; tokens = tokens} + else if token.[0] = ';' then + read_list eol { list_form = list_reader.list_form; + tokens = tokens } + else + let reader = read_form list_reader.tokens in + read_list eol {list_form = list_reader.list_form @ [reader.form]; + tokens = reader.tokens} +and read_quote sym tokens = + let reader = read_form tokens in + {form = Types.list [ Types.symbol sym; reader.form ]; + tokens = reader.tokens} +and read_form all_tokens = + match all_tokens with + | [] -> raise End_of_file; + | token :: tokens -> + match token with + | "'" -> read_quote "quote" tokens + | "`" -> read_quote "quasiquote" tokens + | "~" -> read_quote "unquote" tokens + | "~@" -> read_quote "splice-unquote" tokens + | "@" -> read_quote "deref" tokens + | "^" -> + let meta = read_form tokens in + let value = read_form meta.tokens in + {(*form = with_meta value.form meta.form;*) + form = Types.list [Types.symbol "with-meta"; value.form; meta.form]; + tokens = value.tokens} + | "(" -> + let list_reader = read_list ")" {list_form = []; tokens = tokens} in + {form = Types.list list_reader.list_form; + tokens = list_reader.tokens} + | "{" -> + let list_reader = read_list "}" {list_form = []; tokens = tokens} in + {form = Types.list_into_map Types.MalMap.empty list_reader.list_form; + tokens = list_reader.tokens} + | "[" -> + let list_reader = read_list "]" {list_form = []; tokens = tokens} in + {form = Types.vector list_reader.list_form; + tokens = list_reader.tokens} + | _ -> if token.[0] = ';' + then read_form tokens + else {form = read_atom token; tokens = tokens} + +let read_str str = (read_form (List.filter ((<>) "") (find_re token_re str))).form + diff --git a/impls/ocaml/run b/impls/ocaml/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/ocaml/run +++ b/impls/ocaml/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/ocaml/step0_repl.ml b/impls/ocaml/step0_repl.ml index e3478f726b..f5112dfd86 100644 --- a/impls/ocaml/step0_repl.ml +++ b/impls/ocaml/step0_repl.ml @@ -1,23 +1,23 @@ -(* - To try things at the ocaml repl: - rlwrap ocaml - - To see type signatures of all functions: - ocamlc -i step0_repl.ml - - To run the program: - ocaml step0_repl.ml -*) - -let read str = str -let eval ast any = ast -let print exp = exp -let rep str = print (eval (read str) "") - -let rec main = - try - while true do - print_string "user> "; - print_endline (rep (read_line ())); - done - with End_of_file -> () +(* + To try things at the ocaml repl: + rlwrap ocaml + + To see type signatures of all functions: + ocamlc -i step0_repl.ml + + To run the program: + ocaml step0_repl.ml +*) + +let read str = str +let eval ast any = ast +let print exp = exp +let rep str = print (eval (read str) "") + +let rec main = + try + while true do + print_string "user> "; + print_endline (rep (read_line ())); + done + with End_of_file -> () diff --git a/impls/ocaml/step1_read_print.ml b/impls/ocaml/step1_read_print.ml index 1735e11974..dbacdb1ee4 100644 --- a/impls/ocaml/step1_read_print.ml +++ b/impls/ocaml/step1_read_print.ml @@ -1,15 +1,15 @@ -let read str = Reader.read_str str -let eval ast any = ast -let print exp = Printer.pr_str exp true -let rep str = print (eval (read str) "") - -let rec main = - try - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line); - with End_of_file -> () - done - with End_of_file -> () +let read str = Reader.read_str str +let eval ast any = ast +let print exp = Printer.pr_str exp true +let rep str = print (eval (read str) "") + +let rec main = + try + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line); + with End_of_file -> () + done + with End_of_file -> () diff --git a/impls/ocaml/step2_eval.ml b/impls/ocaml/step2_eval.ml index ce4b5dcff2..6599ab71dc 100644 --- a/impls/ocaml/step2_eval.ml +++ b/impls/ocaml/step2_eval.ml @@ -1,64 +1,64 @@ -module T = Types.Types - -module Env = - Map.Make ( - String - (*(struct - type t = Types.Symbol - let compare (Types.Symbol a) (Types.Symbol b) = compare a b - end)*) - ) - -let num_fun f = Types.fn - (function - | [(T.Int a); (T.Int b)] -> T.Int (f a b) - | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) - -let repl_env = ref (List.fold_left (fun a b -> b a) Env.empty - [ Env.add "+" (num_fun ( + )); - Env.add "-" (num_fun ( - )); - Env.add "*" (num_fun ( * )); - Env.add "/" (num_fun ( / )) ]) - -let rec eval_ast ast env = - match ast with - | T.Symbol { T.value = s } -> - (try Env.find s !env - with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) - | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Map { T.value = xs; T.meta = meta } - -> T.Map {T.meta = meta; - T.value = (Types.MalMap.fold - (fun k v m - -> Types.MalMap.add k (eval v env) m) - xs - Types.MalMap.empty)} - | _ -> ast -and eval ast env = - let result = eval_ast ast env in - match result with - | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> (f args) - | _ -> result - -let read str = Reader.read_str str -let print exp = Printer.pr_str exp true -let rep str env = print (eval (read str) env) - -let rec main = - try - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line repl_env); - with End_of_file -> () - | Invalid_argument x -> - output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); - flush stderr - done - with End_of_file -> () +module T = Types.Types + +module Env = + Map.Make ( + String + (*(struct + type t = Types.Symbol + let compare (Types.Symbol a) (Types.Symbol b) = compare a b + end)*) + ) + +let num_fun f = Types.fn + (function + | [(T.Int a); (T.Int b)] -> T.Int (f a b) + | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) + +let repl_env = ref (List.fold_left (fun a b -> b a) Env.empty + [ Env.add "+" (num_fun ( + )); + Env.add "-" (num_fun ( - )); + Env.add "*" (num_fun ( * )); + Env.add "/" (num_fun ( / )) ]) + +let rec eval_ast ast env = + match ast with + | T.Symbol { T.value = s } -> + (try Env.find s !env + with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add k (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + let result = eval_ast ast env in + match result with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> (f args) + | _ -> result + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () diff --git a/impls/ocaml/step3_env.ml b/impls/ocaml/step3_env.ml index dde04dc133..02affb070b 100644 --- a/impls/ocaml/step3_env.ml +++ b/impls/ocaml/step3_env.ml @@ -1,74 +1,74 @@ -module T = Types.Types - -let num_fun f = Types.fn - (function - | [(T.Int a); (T.Int b)] -> T.Int (f a b) - | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) - -let repl_env = Env.make None - -let init_repl env = begin - Env.set env (Types.symbol "+") (num_fun ( + )); - Env.set env (Types.symbol "-") (num_fun ( - )); - Env.set env (Types.symbol "*") (num_fun ( * )); - Env.set env (Types.symbol "/") (num_fun ( / )); -end - -let rec eval_ast ast env = - match ast with - | T.Symbol s -> Env.get env ast - | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Map { T.value = xs; T.meta = meta } - -> T.Map {T.meta = meta; - T.value = (Types.MalMap.fold - (fun k v m - -> Types.MalMap.add k (eval v env) m) - xs - Types.MalMap.empty)} - | _ -> ast -and eval ast env = - match ast with - | T.List { T.value = [] } -> ast - | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> - let value = (eval expr env) in - Env.set env key value; value - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> - (let sub_env = Env.make (Some env) in - let rec bind_pairs = (function - | sym :: expr :: more -> - Env.set sub_env sym (eval expr sub_env); - bind_pairs more - | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") - | [] -> ()) - in bind_pairs bindings; - eval body sub_env) - | T.List _ -> - (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args - | _ -> raise (Invalid_argument "Cannot invoke non-function")) - | _ -> eval_ast ast env - -let read str = Reader.read_str str -let print exp = Printer.pr_str exp true -let rep str env = print (eval (read str) env) - -let rec main = - try - init_repl repl_env; - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line repl_env); - with End_of_file -> () - | Invalid_argument x -> - output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); - flush stderr - done - with End_of_file -> () +module T = Types.Types + +let num_fun f = Types.fn + (function + | [(T.Int a); (T.Int b)] -> T.Int (f a b) + | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) + +let repl_env = Env.make None + +let init_repl env = begin + Env.set env (Types.symbol "+") (num_fun ( + )); + Env.set env (Types.symbol "-") (num_fun ( - )); + Env.set env (Types.symbol "*") (num_fun ( * )); + Env.set env (Types.symbol "/") (num_fun ( / )); +end + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add k (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match ast with + | T.List { T.value = [] } -> ast + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List _ -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | _ -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + init_repl repl_env; + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () diff --git a/impls/ocaml/step4_if_fn_do.ml b/impls/ocaml/step4_if_fn_do.ml index a425ffc8cb..288e12b762 100644 --- a/impls/ocaml/step4_if_fn_do.ml +++ b/impls/ocaml/step4_if_fn_do.ml @@ -1,84 +1,84 @@ -module T = Types.Types - -let repl_env = Env.make (Some Core.ns) - -let rec eval_ast ast env = - match ast with - | T.Symbol s -> Env.get env ast - | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Map { T.value = xs; T.meta = meta } - -> T.Map {T.meta = meta; - T.value = (Types.MalMap.fold - (fun k v m - -> Types.MalMap.add k (eval v env) m) - xs - Types.MalMap.empty)} - | _ -> ast -and eval ast env = - match ast with - | T.List { T.value = [] } -> ast - | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> - let value = (eval expr env) in - Env.set env key value; value - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> - (let sub_env = Env.make (Some env) in - let rec bind_pairs = (function - | sym :: expr :: more -> - Env.set sub_env sym (eval expr sub_env); - bind_pairs more - | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") - | [] -> ()) - in bind_pairs bindings; - eval body sub_env) - | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> - List.fold_left (fun x expr -> eval expr env) T.Nil body - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> - Types.fn - (function args -> - let sub_env = Env.make (Some env) in - let rec bind_args a b = - (match a, b with - | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); - | (name :: names), (arg :: args) -> - Env.set sub_env name arg; - bind_args names args; - | [], [] -> () - | _ -> raise (Invalid_argument "Bad param count in fn call")) - in bind_args arg_names args; - eval expr sub_env) - | T.List _ -> - (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args - | _ -> raise (Invalid_argument "Cannot invoke non-function")) - | _ -> eval_ast ast env - -let read str = Reader.read_str str -let print exp = Printer.pr_str exp true -let rep str env = print (eval (read str) env) - -let rec main = - try - Core.init Core.ns; - ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line repl_env); - with End_of_file -> () - | Invalid_argument x -> - output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); - flush stderr - done - with End_of_file -> () +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add k (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match ast with + | T.List { T.value = [] } -> ast + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + Types.fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List _ -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | _ -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () diff --git a/impls/ocaml/step6_file.ml b/impls/ocaml/step6_file.ml index 0df1c3010f..afe5751f2b 100644 --- a/impls/ocaml/step6_file.ml +++ b/impls/ocaml/step6_file.ml @@ -1,95 +1,95 @@ -module T = Types.Types - -let repl_env = Env.make (Some Core.ns) - -let rec eval_ast ast env = - match ast with - | T.Symbol s -> Env.get env ast - | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Map { T.value = xs; T.meta = meta } - -> T.Map {T.meta = meta; - T.value = (Types.MalMap.fold - (fun k v m - -> Types.MalMap.add k (eval v env) m) - xs - Types.MalMap.empty)} - | _ -> ast -and eval ast env = - match ast with - | T.List { T.value = [] } -> ast - | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> - let value = (eval expr env) in - Env.set env key value; value - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> - (let sub_env = Env.make (Some env) in - let rec bind_pairs = (function - | sym :: expr :: more -> - Env.set sub_env sym (eval expr sub_env); - bind_pairs more - | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") - | [] -> ()) - in bind_pairs bindings; - eval body sub_env) - | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> - List.fold_left (fun x expr -> eval expr env) T.Nil body - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> - Types.fn - (function args -> - let sub_env = Env.make (Some env) in - let rec bind_args a b = - (match a, b with - | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); - | (name :: names), (arg :: args) -> - Env.set sub_env name arg; - bind_args names args; - | [], [] -> () - | _ -> raise (Invalid_argument "Bad param count in fn call")) - in bind_args arg_names args; - eval expr sub_env) - | T.List _ -> - (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args - | _ -> raise (Invalid_argument "Cannot invoke non-function")) - | _ -> eval_ast ast env - -let read str = Reader.read_str str -let print exp = Printer.pr_str exp true -let rep str env = print (eval (read str) env) - -let rec main = - try - Core.init Core.ns; - Env.set repl_env (Types.symbol "*ARGV*") - (Types.list (if Array.length Sys.argv > 1 - then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) - else [])); - Env.set repl_env (Types.symbol "eval") - (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); - ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); - ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); - - if Array.length Sys.argv > 1 then - ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) - else - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line repl_env); - with End_of_file -> () - | Invalid_argument x -> - output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); - flush stderr - done - with End_of_file -> () +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add k (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match ast with + | T.List { T.value = [] } -> ast + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + Types.fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List _ -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | _ -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + + if Array.length Sys.argv > 1 then + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) + else + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () diff --git a/impls/ocaml/step7_quote.ml b/impls/ocaml/step7_quote.ml index dcad28fe54..485d6a46f4 100644 --- a/impls/ocaml/step7_quote.ml +++ b/impls/ocaml/step7_quote.ml @@ -1,114 +1,114 @@ -module T = Types.Types - -let repl_env = Env.make (Some Core.ns) - -let rec quasiquote ast = - match ast with - | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast - | T.List {T.value = xs} -> List.fold_right qq_folder xs (Types.list []) - | T.Vector {T.value = xs} -> Types.list [Types.symbol "vec"; - List.fold_right qq_folder xs (Types.list [])] - | T.Map _ -> Types.list [Types.symbol "quote"; ast] - | T.Symbol _ -> Types.list [Types.symbol "quote"; ast] - | _ -> ast -and qq_folder elt acc = - match elt with - | T.List {T.value = [T.Symbol {T.value = "splice-unquote"}; x]} -> Types.list [Types.symbol "concat"; x; acc] - | _ -> Types.list [Types.symbol "cons"; quasiquote elt; acc] - -let rec eval_ast ast env = - match ast with - | T.Symbol s -> Env.get env ast - | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Map { T.value = xs; T.meta = meta } - -> T.Map {T.meta = meta; - T.value = (Types.MalMap.fold - (fun k v m - -> Types.MalMap.add k (eval v env) m) - xs - Types.MalMap.empty)} - | _ -> ast -and eval ast env = - match ast with - | T.List { T.value = [] } -> ast - | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> - let value = (eval expr env) in - Env.set env key value; value - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> - (let sub_env = Env.make (Some env) in - let rec bind_pairs = (function - | sym :: expr :: more -> - Env.set sub_env sym (eval expr sub_env); - bind_pairs more - | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") - | [] -> ()) - in bind_pairs bindings; - eval body sub_env) - | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> - List.fold_left (fun x expr -> eval expr env) T.Nil body - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> - Types.fn - (function args -> - let sub_env = Env.make (Some env) in - let rec bind_args a b = - (match a, b with - | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); - | (name :: names), (arg :: args) -> - Env.set sub_env name arg; - bind_args names args; - | [], [] -> () - | _ -> raise (Invalid_argument "Bad param count in fn call")) - in bind_args arg_names args; - eval expr sub_env) - | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast - | T.List { T.value = [T.Symbol { T.value = "quasiquoteexpand" }; ast] } -> - quasiquote ast - | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> - eval (quasiquote ast) env - | T.List _ -> - (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args - | _ -> raise (Invalid_argument "Cannot invoke non-function")) - | _ -> eval_ast ast env - -let read str = Reader.read_str str -let print exp = Printer.pr_str exp true -let rep str env = print (eval (read str) env) - -let rec main = - try - Core.init Core.ns; - Env.set repl_env (Types.symbol "*ARGV*") - (Types.list (if Array.length Sys.argv > 1 - then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) - else [])); - Env.set repl_env (Types.symbol "eval") - (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); - ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); - ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); - - if Array.length Sys.argv > 1 then - ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) - else - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line repl_env); - with End_of_file -> () - | Invalid_argument x -> - output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); - flush stderr - done - with End_of_file -> () +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec quasiquote ast = + match ast with + | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.List {T.value = xs} -> List.fold_right qq_folder xs (Types.list []) + | T.Vector {T.value = xs} -> Types.list [Types.symbol "vec"; + List.fold_right qq_folder xs (Types.list [])] + | T.Map _ -> Types.list [Types.symbol "quote"; ast] + | T.Symbol _ -> Types.list [Types.symbol "quote"; ast] + | _ -> ast +and qq_folder elt acc = + match elt with + | T.List {T.value = [T.Symbol {T.value = "splice-unquote"}; x]} -> Types.list [Types.symbol "concat"; x; acc] + | _ -> Types.list [Types.symbol "cons"; quasiquote elt; acc] + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add k (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match ast with + | T.List { T.value = [] } -> ast + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + Types.fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast + | T.List { T.value = [T.Symbol { T.value = "quasiquoteexpand" }; ast] } -> + quasiquote ast + | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> + eval (quasiquote ast) env + | T.List _ -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | _ -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + + if Array.length Sys.argv > 1 then + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) + else + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () diff --git a/impls/ocaml/step8_macros.ml b/impls/ocaml/step8_macros.ml index b9f35df5ed..cf0e8b62ae 100644 --- a/impls/ocaml/step8_macros.ml +++ b/impls/ocaml/step8_macros.ml @@ -1,146 +1,146 @@ -module T = Types.Types - -let repl_env = Env.make (Some Core.ns) - -let rec quasiquote ast = - match ast with - | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast - | T.List {T.value = xs} -> List.fold_right qq_folder xs (Types.list []) - | T.Vector {T.value = xs} -> Types.list [Types.symbol "vec"; - List.fold_right qq_folder xs (Types.list [])] - | T.Map _ -> Types.list [Types.symbol "quote"; ast] - | T.Symbol _ -> Types.list [Types.symbol "quote"; ast] - | _ -> ast -and qq_folder elt acc = - match elt with - | T.List {T.value = [T.Symbol {T.value = "splice-unquote"}; x]} -> Types.list [Types.symbol "concat"; x; acc] - | _ -> Types.list [Types.symbol "cons"; quasiquote elt; acc] - -let is_macro_call ast env = - match ast with - | T.List { T.value = s :: args } -> - (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.meta = T.Map { T.value = meta } } - -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) - | _ -> false) - | _ -> false - -let rec macroexpand ast env = - if is_macro_call ast env - then match ast with - | T.List { T.value = s :: args } -> - (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.value = f } -> macroexpand (f args) env - | _ -> ast) - | _ -> ast - else ast - -let rec eval_ast ast env = - match ast with - | T.Symbol s -> Env.get env ast - | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Map { T.value = xs; T.meta = meta } - -> T.Map {T.meta = meta; - T.value = (Types.MalMap.fold - (fun k v m - -> Types.MalMap.add k (eval v env) m) - xs - Types.MalMap.empty)} - | _ -> ast -and eval ast env = - match macroexpand ast env with - | T.List { T.value = [] } -> ast - | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> - let value = (eval expr env) in - Env.set env key value; value - | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> - (match (eval expr env) with - | T.Fn { T.value = f; T.meta = meta } -> - let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} - in Env.set env key fn; fn - | _ -> raise (Invalid_argument "defmacro! value must be a fn")) - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> - (let sub_env = Env.make (Some env) in - let rec bind_pairs = (function - | sym :: expr :: more -> - Env.set sub_env sym (eval expr sub_env); - bind_pairs more - | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") - | [] -> ()) - in bind_pairs bindings; - eval body sub_env) - | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> - List.fold_left (fun x expr -> eval expr env) T.Nil body - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> - Types.fn - (function args -> - let sub_env = Env.make (Some env) in - let rec bind_args a b = - (match a, b with - | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); - | (name :: names), (arg :: args) -> - Env.set sub_env name arg; - bind_args names args; - | [], [] -> () - | _ -> raise (Invalid_argument "Bad param count in fn call")) - in bind_args arg_names args; - eval expr sub_env) - | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast - | T.List { T.value = [T.Symbol { T.value = "quasiquoteexpand" }; ast] } -> - quasiquote ast - | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> - eval (quasiquote ast) env - | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> - macroexpand ast env - | T.List _ as ast -> - (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args - | _ -> raise (Invalid_argument "Cannot invoke non-function")) - | ast -> eval_ast ast env - -let read str = Reader.read_str str -let print exp = Printer.pr_str exp true -let rep str env = print (eval (read str) env) - -let rec main = - try - Core.init Core.ns; - Env.set repl_env (Types.symbol "*ARGV*") - (Types.list (if Array.length Sys.argv > 1 - then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) - else [])); - Env.set repl_env (Types.symbol "eval") - (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); - - ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); - ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); - ignore (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)))))))" repl_env); - - if Array.length Sys.argv > 1 then - ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) - else - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line repl_env); - with End_of_file -> () - | Invalid_argument x -> - output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); - flush stderr - | _ -> - output_string stderr ("Erroringness!\n"); - flush stderr - done - with End_of_file -> () +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec quasiquote ast = + match ast with + | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.List {T.value = xs} -> List.fold_right qq_folder xs (Types.list []) + | T.Vector {T.value = xs} -> Types.list [Types.symbol "vec"; + List.fold_right qq_folder xs (Types.list [])] + | T.Map _ -> Types.list [Types.symbol "quote"; ast] + | T.Symbol _ -> Types.list [Types.symbol "quote"; ast] + | _ -> ast +and qq_folder elt acc = + match elt with + | T.List {T.value = [T.Symbol {T.value = "splice-unquote"}; x]} -> Types.list [Types.symbol "concat"; x; acc] + | _ -> Types.list [Types.symbol "cons"; quasiquote elt; acc] + +let is_macro_call ast env = + match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.meta = T.Map { T.value = meta } } + -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) + | _ -> false) + | _ -> false + +let rec macroexpand ast env = + if is_macro_call ast env + then match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + else ast + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add k (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match macroexpand ast env with + | T.List { T.value = [] } -> ast + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> + (match (eval expr env) with + | T.Fn { T.value = f; T.meta = meta } -> + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} + in Env.set env key fn; fn + | _ -> raise (Invalid_argument "defmacro! value must be a fn")) + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + Types.fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast + | T.List { T.value = [T.Symbol { T.value = "quasiquoteexpand" }; ast] } -> + quasiquote ast + | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> + eval (quasiquote ast) env + | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> + macroexpand ast env + | T.List _ as ast -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | ast -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + + ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + ignore (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)))))))" repl_env); + + if Array.length Sys.argv > 1 then + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) + else + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + | _ -> + output_string stderr ("Erroringness!\n"); + flush stderr + done + with End_of_file -> () diff --git a/impls/ocaml/step9_try.ml b/impls/ocaml/step9_try.ml index ba68aab346..4517ee5904 100644 --- a/impls/ocaml/step9_try.ml +++ b/impls/ocaml/step9_try.ml @@ -1,168 +1,168 @@ -module T = Types.Types - -let repl_env = Env.make (Some Core.ns) - -let rec quasiquote ast = - match ast with - | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast - | T.List {T.value = xs} -> List.fold_right qq_folder xs (Types.list []) - | T.Vector {T.value = xs} -> Types.list [Types.symbol "vec"; - List.fold_right qq_folder xs (Types.list [])] - | T.Map _ -> Types.list [Types.symbol "quote"; ast] - | T.Symbol _ -> Types.list [Types.symbol "quote"; ast] - | _ -> ast -and qq_folder elt acc = - match elt with - | T.List {T.value = [T.Symbol {T.value = "splice-unquote"}; x]} -> Types.list [Types.symbol "concat"; x; acc] - | _ -> Types.list [Types.symbol "cons"; quasiquote elt; acc] - -let is_macro_call ast env = - match ast with - | T.List { T.value = s :: args } -> - (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.meta = T.Map { T.value = meta } } - -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) - | _ -> false) - | _ -> false - -let rec macroexpand ast env = - if is_macro_call ast env - then match ast with - | T.List { T.value = s :: args } -> - (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.value = f } -> macroexpand (f args) env - | _ -> ast) - | _ -> ast - else ast - -let rec eval_ast ast env = - match ast with - | T.Symbol s -> Env.get env ast - | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Map { T.value = xs; T.meta = meta } - -> T.Map {T.meta = meta; - T.value = (Types.MalMap.fold - (fun k v m - -> Types.MalMap.add k (eval v env) m) - xs - Types.MalMap.empty)} - | _ -> ast -and eval ast env = - match macroexpand ast env with - | T.List { T.value = [] } -> ast - | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> - let value = (eval expr env) in - Env.set env key value; value - | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> - (match (eval expr env) with - | T.Fn { T.value = f; T.meta = meta } -> - let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} - in Env.set env key fn; fn - | _ -> raise (Invalid_argument "defmacro! value must be a fn")) - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> - (let sub_env = Env.make (Some env) in - let rec bind_pairs = (function - | sym :: expr :: more -> - Env.set sub_env sym (eval expr sub_env); - bind_pairs more - | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") - | [] -> ()) - in bind_pairs bindings; - eval body sub_env) - | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> - List.fold_left (fun x expr -> eval expr env) T.Nil body - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> - Types.fn - (function args -> - let sub_env = Env.make (Some env) in - let rec bind_args a b = - (match a, b with - | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); - | (name :: names), (arg :: args) -> - Env.set sub_env name arg; - bind_args names args; - | [], [] -> () - | _ -> raise (Invalid_argument "Bad param count in fn call")) - in bind_args arg_names args; - eval expr sub_env) - | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast - | T.List { T.value = [T.Symbol { T.value = "quasiquoteexpand" }; ast] } -> - quasiquote ast - | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> - eval (quasiquote ast) env - | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> - macroexpand ast env - | T.List { T.value = [T.Symbol { T.value = "try*" }; scary]} -> - (eval scary env) - | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; - T.List { T.value = [T.Symbol { T.value = "catch*" }; - local ; handler]}]} -> - (try (eval scary env) - with exn -> - let value = match exn with - | Types.MalExn value -> value - | Invalid_argument msg -> T.String msg - | e -> (T.String (Printexc.to_string e)) in - let sub_env = Env.make (Some env) in - Env.set sub_env local value; - eval handler sub_env) - | T.List _ as ast -> - (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args - | _ -> raise (Invalid_argument "Cannot invoke non-function")) - | ast -> eval_ast ast env - -let read str = Reader.read_str str -let print exp = Printer.pr_str exp true -let rep str env = print (eval (read str) env) - -let rec main = - try - Core.init Core.ns; - Env.set repl_env (Types.symbol "*ARGV*") - (Types.list (if Array.length Sys.argv > 1 - then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) - else [])); - Env.set repl_env (Types.symbol "eval") - (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); - - ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); - ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); - ignore (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)))))))" repl_env); - - if Array.length Sys.argv > 1 then - try - ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env); - with - | Types.MalExn exc -> - output_string stderr ("Exception: " ^ (print exc) ^ "\n"); - flush stderr - else - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line repl_env); - with End_of_file -> () - | Types.MalExn exc -> - output_string stderr ("Exception: " ^ (print exc) ^ "\n"); - flush stderr - | Invalid_argument x -> - output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); - flush stderr - | e -> - output_string stderr ((Printexc.to_string e) ^ "\n"); - flush stderr - done - with End_of_file -> () +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec quasiquote ast = + match ast with + | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.List {T.value = xs} -> List.fold_right qq_folder xs (Types.list []) + | T.Vector {T.value = xs} -> Types.list [Types.symbol "vec"; + List.fold_right qq_folder xs (Types.list [])] + | T.Map _ -> Types.list [Types.symbol "quote"; ast] + | T.Symbol _ -> Types.list [Types.symbol "quote"; ast] + | _ -> ast +and qq_folder elt acc = + match elt with + | T.List {T.value = [T.Symbol {T.value = "splice-unquote"}; x]} -> Types.list [Types.symbol "concat"; x; acc] + | _ -> Types.list [Types.symbol "cons"; quasiquote elt; acc] + +let is_macro_call ast env = + match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.meta = T.Map { T.value = meta } } + -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) + | _ -> false) + | _ -> false + +let rec macroexpand ast env = + if is_macro_call ast env + then match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + else ast + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add k (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match macroexpand ast env with + | T.List { T.value = [] } -> ast + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> + (match (eval expr env) with + | T.Fn { T.value = f; T.meta = meta } -> + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} + in Env.set env key fn; fn + | _ -> raise (Invalid_argument "defmacro! value must be a fn")) + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + Types.fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast + | T.List { T.value = [T.Symbol { T.value = "quasiquoteexpand" }; ast] } -> + quasiquote ast + | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> + eval (quasiquote ast) env + | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> + macroexpand ast env + | T.List { T.value = [T.Symbol { T.value = "try*" }; scary]} -> + (eval scary env) + | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; + T.List { T.value = [T.Symbol { T.value = "catch*" }; + local ; handler]}]} -> + (try (eval scary env) + with exn -> + let value = match exn with + | Types.MalExn value -> value + | Invalid_argument msg -> T.String msg + | e -> (T.String (Printexc.to_string e)) in + let sub_env = Env.make (Some env) in + Env.set sub_env local value; + eval handler sub_env) + | T.List _ as ast -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | ast -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + + ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + ignore (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)))))))" repl_env); + + if Array.length Sys.argv > 1 then + try + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env); + with + | Types.MalExn exc -> + output_string stderr ("Exception: " ^ (print exc) ^ "\n"); + flush stderr + else + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Types.MalExn exc -> + output_string stderr ("Exception: " ^ (print exc) ^ "\n"); + flush stderr + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + | e -> + output_string stderr ((Printexc.to_string e) ^ "\n"); + flush stderr + done + with End_of_file -> () diff --git a/impls/ocaml/stepA_mal.ml b/impls/ocaml/stepA_mal.ml index d9f56be6f4..fa8da7bd4e 100644 --- a/impls/ocaml/stepA_mal.ml +++ b/impls/ocaml/stepA_mal.ml @@ -1,171 +1,171 @@ -module T = Types.Types - -let repl_env = Env.make (Some Core.ns) - -let rec quasiquote ast = - match ast with - | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast - | T.List {T.value = xs} -> List.fold_right qq_folder xs (Types.list []) - | T.Vector {T.value = xs} -> Types.list [Types.symbol "vec"; - List.fold_right qq_folder xs (Types.list [])] - | T.Map _ -> Types.list [Types.symbol "quote"; ast] - | T.Symbol _ -> Types.list [Types.symbol "quote"; ast] - | _ -> ast -and qq_folder elt acc = - match elt with - | T.List {T.value = [T.Symbol {T.value = "splice-unquote"}; x]} -> Types.list [Types.symbol "concat"; x; acc] - | _ -> Types.list [Types.symbol "cons"; quasiquote elt; acc] - -let is_macro_call ast env = - match ast with - | T.List { T.value = s :: args } -> - (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.meta = T.Map { T.value = meta } } - -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) - | _ -> false) - | _ -> false - -let rec macroexpand ast env = - if is_macro_call ast env - then match ast with - | T.List { T.value = s :: args } -> - (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.value = f } -> macroexpand (f args) env - | _ -> ast) - | _ -> ast - else ast - -let rec eval_ast ast env = - match ast with - | T.Symbol s -> Env.get env ast - | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta } - | T.Map { T.value = xs; T.meta = meta } - -> T.Map {T.meta = meta; - T.value = (Types.MalMap.fold - (fun k v m - -> Types.MalMap.add k (eval v env) m) - xs - Types.MalMap.empty)} - | _ -> ast -and eval ast env = - match macroexpand ast env with - | T.List { T.value = [] } -> ast - | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> - let value = (eval expr env) in - Env.set env key value; value - | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> - (match (eval expr env) with - | T.Fn { T.value = f; T.meta = meta } -> - let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} - in Env.set env key fn; fn - | _ -> raise (Invalid_argument "defmacro! value must be a fn")) - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> - (let sub_env = Env.make (Some env) in - let rec bind_pairs = (function - | sym :: expr :: more -> - Env.set sub_env sym (eval expr sub_env); - bind_pairs more - | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") - | [] -> ()) - in bind_pairs bindings; - eval body sub_env) - | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> - List.fold_left (fun x expr -> eval expr env) T.Nil body - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) - | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> - if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> - Types.fn - (function args -> - let sub_env = Env.make (Some env) in - let rec bind_args a b = - (match a, b with - | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); - | (name :: names), (arg :: args) -> - Env.set sub_env name arg; - bind_args names args; - | [], [] -> () - | _ -> raise (Invalid_argument "Bad param count in fn call")) - in bind_args arg_names args; - eval expr sub_env) - | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast - | T.List { T.value = [T.Symbol { T.value = "quasiquoteexpand" }; ast] } -> - quasiquote ast - | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> - eval (quasiquote ast) env - | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> - macroexpand ast env - | T.List { T.value = [T.Symbol { T.value = "try*" }; scary]} -> - (eval scary env) - | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; - T.List { T.value = [T.Symbol { T.value = "catch*" }; - local ; handler]}]} -> - (try (eval scary env) - with exn -> - let value = match exn with - | Types.MalExn value -> value - | Invalid_argument msg -> T.String msg - | e -> (T.String (Printexc.to_string e)) in - let sub_env = Env.make (Some env) in - Env.set sub_env local value; - eval handler sub_env) - | T.List _ as ast -> - (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args - | _ -> raise (Invalid_argument "Cannot invoke non-function")) - | ast -> eval_ast ast env - -let read str = Reader.read_str str -let print exp = Printer.pr_str exp true -let rep str env = print (eval (read str) env) - -let rec main = - try - Core.init Core.ns; - Env.set repl_env (Types.symbol "*ARGV*") - (Types.list (if Array.length Sys.argv > 1 - then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) - else [])); - Env.set repl_env (Types.symbol "eval") - (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); - - ignore (rep "(def! *host-language* \"ocaml\")" repl_env); - ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); - ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); - ignore (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)))))))" repl_env); - - if Array.length Sys.argv > 1 then - try - ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env); - with - | Types.MalExn exc -> - output_string stderr ("Exception: " ^ (print exc) ^ "\n"); - flush stderr - else begin - ignore (rep "(println (str \"Mal [\" *host-language* \"]\"))" repl_env); - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line repl_env); - with End_of_file -> () - | Types.MalExn exc -> - output_string stderr ("Exception: " ^ (print exc) ^ "\n"); - flush stderr - | Invalid_argument x -> - output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); - flush stderr - | e -> - output_string stderr ((Printexc.to_string e) ^ "\n"); - flush stderr - done - end - with End_of_file -> () +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec quasiquote ast = + match ast with + | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.List {T.value = xs} -> List.fold_right qq_folder xs (Types.list []) + | T.Vector {T.value = xs} -> Types.list [Types.symbol "vec"; + List.fold_right qq_folder xs (Types.list [])] + | T.Map _ -> Types.list [Types.symbol "quote"; ast] + | T.Symbol _ -> Types.list [Types.symbol "quote"; ast] + | _ -> ast +and qq_folder elt acc = + match elt with + | T.List {T.value = [T.Symbol {T.value = "splice-unquote"}; x]} -> Types.list [Types.symbol "concat"; x; acc] + | _ -> Types.list [Types.symbol "cons"; quasiquote elt; acc] + +let is_macro_call ast env = + match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.meta = T.Map { T.value = meta } } + -> Types.MalMap.mem Core.kw_macro meta && Types.to_bool (Types.MalMap.find Core.kw_macro meta) + | _ -> false) + | _ -> false + +let rec macroexpand ast env = + if is_macro_call ast env + then match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + else ast + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add k (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match macroexpand ast env with + | T.List { T.value = [] } -> ast + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> + (match (eval expr env) with + | T.Fn { T.value = f; T.meta = meta } -> + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; Core.kw_macro; (T.Bool true)]} + in Env.set env key fn; fn + | _ -> raise (Invalid_argument "defmacro! value must be a fn")) + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + Types.fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast + | T.List { T.value = [T.Symbol { T.value = "quasiquoteexpand" }; ast] } -> + quasiquote ast + | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> + eval (quasiquote ast) env + | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> + macroexpand ast env + | T.List { T.value = [T.Symbol { T.value = "try*" }; scary]} -> + (eval scary env) + | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; + T.List { T.value = [T.Symbol { T.value = "catch*" }; + local ; handler]}]} -> + (try (eval scary env) + with exn -> + let value = match exn with + | Types.MalExn value -> value + | Invalid_argument msg -> T.String msg + | e -> (T.String (Printexc.to_string e)) in + let sub_env = Env.make (Some env) in + Env.set sub_env local value; + eval handler sub_env) + | T.List _ as ast -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | ast -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + + ignore (rep "(def! *host-language* \"ocaml\")" repl_env); + ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + ignore (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)))))))" repl_env); + + if Array.length Sys.argv > 1 then + try + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env); + with + | Types.MalExn exc -> + output_string stderr ("Exception: " ^ (print exc) ^ "\n"); + flush stderr + else begin + ignore (rep "(println (str \"Mal [\" *host-language* \"]\"))" repl_env); + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Types.MalExn exc -> + output_string stderr ("Exception: " ^ (print exc) ^ "\n"); + flush stderr + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + | e -> + output_string stderr ((Printexc.to_string e) ^ "\n"); + flush stderr + done + end + with End_of_file -> () diff --git a/impls/ocaml/tests/step5_tco.mal b/impls/ocaml/tests/step5_tco.mal index 193f7b66fd..8174f60dd9 100644 --- a/impls/ocaml/tests/step5_tco.mal +++ b/impls/ocaml/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Ocaml skipping non-TCO recursion -;; Reason: completes at 50,000, unrecoverable segfaul at 100,000 +;; Ocaml skipping non-TCO recursion +;; Reason: completes at 50,000, unrecoverable segfaul at 100,000 diff --git a/impls/ocaml/types.ml b/impls/ocaml/types.ml index 45d10bdb30..fb7b219ff9 100644 --- a/impls/ocaml/types.ml +++ b/impls/ocaml/types.ml @@ -1,69 +1,69 @@ -module rec Types - : sig - type 'a with_meta = { value : 'a; meta : t } - and t = - | List of t list with_meta - | Vector of t list with_meta - | Map of t MalMap.t with_meta - | Int of int - | Symbol of string with_meta - | Keyword of string - | Nil - | Bool of bool - | String of string - | Fn of (t list -> t) with_meta - | Atom of t ref - end = Types - -and MalValue - : sig - type t = Types.t - val compare : t -> t -> int - end - = struct - type t = Types.t - let compare = Pervasives.compare - end - -and MalMap - : Map.S with type key = MalValue.t - = Map.Make(MalValue) - -exception MalExn of Types.t - -let to_bool x = match x with - | Types.Nil | Types.Bool false -> false - | _ -> true - -type mal_type = MalValue.t - -let list x = Types.List { Types.value = x; meta = Types.Nil } -let map x = Types.Map { Types.value = x; meta = Types.Nil } -let vector x = Types.Vector { Types.value = x; meta = Types.Nil } -let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil } -let fn f = Types.Fn { Types.value = f; meta = Types.Nil } - -let rec list_into_map target source = - match source with - | k :: v :: more -> list_into_map (MalMap.add k v target) more - | [] -> map target - | _ :: [] -> raise (Invalid_argument "Literal maps must contain an even number of forms") - -let rec mal_list_equal a b = - List.length a = List.length b && List.for_all2 mal_equal a b - -and mal_hash_equal a b = - if MalMap.cardinal a = MalMap.cardinal b - then - let identical_to_b k v = MalMap.mem k b && mal_equal v (MalMap.find k b) in - MalMap.for_all identical_to_b a - else false - -and mal_equal a b = - match (a, b) with - | (Types.List a, Types.List b) - | (Types.List a, Types.Vector b) - | (Types.Vector a, Types.List b) - | (Types.Vector a, Types.Vector b) -> mal_list_equal a.Types.value b.Types.value - | (Types.Map a, Types.Map b) -> mal_hash_equal a.Types.value b.Types.value - | _ -> a = b +module rec Types + : sig + type 'a with_meta = { value : 'a; meta : t } + and t = + | List of t list with_meta + | Vector of t list with_meta + | Map of t MalMap.t with_meta + | Int of int + | Symbol of string with_meta + | Keyword of string + | Nil + | Bool of bool + | String of string + | Fn of (t list -> t) with_meta + | Atom of t ref + end = Types + +and MalValue + : sig + type t = Types.t + val compare : t -> t -> int + end + = struct + type t = Types.t + let compare = Pervasives.compare + end + +and MalMap + : Map.S with type key = MalValue.t + = Map.Make(MalValue) + +exception MalExn of Types.t + +let to_bool x = match x with + | Types.Nil | Types.Bool false -> false + | _ -> true + +type mal_type = MalValue.t + +let list x = Types.List { Types.value = x; meta = Types.Nil } +let map x = Types.Map { Types.value = x; meta = Types.Nil } +let vector x = Types.Vector { Types.value = x; meta = Types.Nil } +let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil } +let fn f = Types.Fn { Types.value = f; meta = Types.Nil } + +let rec list_into_map target source = + match source with + | k :: v :: more -> list_into_map (MalMap.add k v target) more + | [] -> map target + | _ :: [] -> raise (Invalid_argument "Literal maps must contain an even number of forms") + +let rec mal_list_equal a b = + List.length a = List.length b && List.for_all2 mal_equal a b + +and mal_hash_equal a b = + if MalMap.cardinal a = MalMap.cardinal b + then + let identical_to_b k v = MalMap.mem k b && mal_equal v (MalMap.find k b) in + MalMap.for_all identical_to_b a + else false + +and mal_equal a b = + match (a, b) with + | (Types.List a, Types.List b) + | (Types.List a, Types.Vector b) + | (Types.Vector a, Types.List b) + | (Types.Vector a, Types.Vector b) -> mal_list_equal a.Types.value b.Types.value + | (Types.Map a, Types.Map b) -> mal_hash_equal a.Types.value b.Types.value + | _ -> a = b diff --git a/impls/perl/Dockerfile b/impls/perl/Dockerfile index b36833e072..4ce27dc76b 100644 --- a/impls/perl/Dockerfile +++ b/impls/perl/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install perl libapp-fatpacker-perl +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install perl libapp-fatpacker-perl diff --git a/impls/perl/Makefile b/impls/perl/Makefile index ec18d485f0..8a2c37e6f1 100644 --- a/impls/perl/Makefile +++ b/impls/perl/Makefile @@ -1,25 +1,25 @@ -SOURCES_BASE = readline.pm types.pm reader.pm printer.pm \ - interop.pm -SOURCES_LISP = env.pm core.pm stepA_mal.pl -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - -dist: mal.pl mal - -mal.pl: $(SOURCES) - #fatpack pack ./stepA_mal.pl > $@ - fatpack trace ./stepA_mal.pl - fatpack packlists-for `cat fatpacker.trace` > packlists - fatpack tree `cat packlists` - cp $+ fatlib/ - (fatpack file; cat ./stepA_mal.pl) > mal.pl - -mal: mal.pl - echo "#!/usr/bin/env perl" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.pl mal fatpacker.trace packlists fatlib/* - [ -d fatlib ] && rmdir fatlib || true +SOURCES_BASE = readline.pm types.pm reader.pm printer.pm \ + interop.pm +SOURCES_LISP = env.pm core.pm stepA_mal.pl +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + +dist: mal.pl mal + +mal.pl: $(SOURCES) + #fatpack pack ./stepA_mal.pl > $@ + fatpack trace ./stepA_mal.pl + fatpack packlists-for `cat fatpacker.trace` > packlists + fatpack tree `cat packlists` + cp $+ fatlib/ + (fatpack file; cat ./stepA_mal.pl) > mal.pl + +mal: mal.pl + echo "#!/usr/bin/env perl" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.pl mal fatpacker.trace packlists fatlib/* + [ -d fatlib ] && rmdir fatlib || true diff --git a/impls/perl/README.md b/impls/perl/README.md index 60d30f5561..814b7ec3b1 100644 --- a/impls/perl/README.md +++ b/impls/perl/README.md @@ -1,28 +1,28 @@ -# Notes on the mal implementation in Perl5. - -This implementation should work in any perl from 5.19.3 onwards. -Earlier versions are likely to work too as long as you install a new -List::Util. The implementation uses the experimental `switch` -feature, which may make it vulnerable to future changes in perl. - -Mal objects are all in subclasses of `Mal::Type`, and can be treated -as scalar, array, or hash references as appropriate. - -Metadata support uses `Hash::Util::FieldHash` to attach external -metadata to objects. This means that in the metadata system imposes -no overhead on the normal use of objects. - -Hash-maps are slightly magical. They're keyed by the stringified -versions of mal objects, and `Mal::Scalar` overloads stringification -so that this works properly. - -Tail-call optimisation uses Perl's built-in `goto &NAME` syntax for -explicit tail calls. This allows functions defined by `fn*` to be -implemented as functions at the Perl layer. - -Perl's garbage-collection is based on reference counting. This means -that reference loops will cause memory leaks, and in particular using -`def!` to define a function will cause that function to have a -reference to the environment it's defined in, making a small reference -loop and hence a memory leak. This can be avoided by carefully -undefining any function before it goes out of scope. +# Notes on the mal implementation in Perl5. + +This implementation should work in any perl from 5.19.3 onwards. +Earlier versions are likely to work too as long as you install a new +List::Util. The implementation uses the experimental `switch` +feature, which may make it vulnerable to future changes in perl. + +Mal objects are all in subclasses of `Mal::Type`, and can be treated +as scalar, array, or hash references as appropriate. + +Metadata support uses `Hash::Util::FieldHash` to attach external +metadata to objects. This means that in the metadata system imposes +no overhead on the normal use of objects. + +Hash-maps are slightly magical. They're keyed by the stringified +versions of mal objects, and `Mal::Scalar` overloads stringification +so that this works properly. + +Tail-call optimisation uses Perl's built-in `goto &NAME` syntax for +explicit tail calls. This allows functions defined by `fn*` to be +implemented as functions at the Perl layer. + +Perl's garbage-collection is based on reference counting. This means +that reference loops will cause memory leaks, and in particular using +`def!` to define a function will cause that function to have a +reference to the environment it's defined in, making a small reference +loop and hence a memory leak. This can be avoided by carefully +undefining any function before it goes out of scope. diff --git a/impls/perl/core.pm b/impls/perl/core.pm index 5287d0eab1..deb2edfb88 100644 --- a/impls/perl/core.pm +++ b/impls/perl/core.pm @@ -1,243 +1,243 @@ -package core; -use strict; -use warnings; - -use Data::Dumper; -use Hash::Util qw(fieldhash); -use List::Util qw(pairmap); -use Time::HiRes qw(time); - -use readline; -use types qw(_equal_Q thaw_key $nil $true $false); -use reader qw(read_str); -use printer qw(_pr_str); -use interop qw(pl_to_mal); - -# String functions - -sub pr_str { - return Mal::String->new(join(" ", map {_pr_str($_, 1)} @_)); -} - -sub str { - return Mal::String->new(join("", map {_pr_str($_, 0)} @_)); -} - -sub prn { - print join(" ", map {_pr_str($_, 1)} @_) . "\n"; - return $nil -} - -sub println { - print join(" ", map {_pr_str($_, 0)} @_) . "\n"; - return $nil -} - -sub mal_readline { - my $line = readline::mal_readline(${$_[0]}); - return defined $line ? Mal::String->new($line) : $nil; -} - -sub slurp { - use autodie; - open(my $fh, '<', ${$_[0]}); - my $data = do { local $/; <$fh> }; - Mal::String->new($data) -} - -# Hash Map functions - -sub assoc { - my $src_hsh = shift; - return Mal::HashMap->new( { %$src_hsh, @_ } ); -} - -sub dissoc { - my $new_hsh = { %{shift @_} }; - delete @{$new_hsh}{@_}; - return Mal::HashMap->new($new_hsh); -} - - -sub get { - my ($hsh, $key) = @_; - return $hsh->{$key} // $nil; -} - -sub contains_Q { - my ($hsh, $key) = @_; - return (exists $hsh->{$key}) ? $true : $false; -} - -sub mal_keys { - my @ks = map { thaw_key($_) } keys %{$_[0]}; - return Mal::List->new(\@ks); -} - -sub mal_vals { - my @vs = values %{$_[0]}; - return Mal::List->new(\@vs); -} - - -# Sequence functions - -sub cons { - my ($a, $b) = @_; - Mal::List->new([$a, @$b]); -} - -sub nth { - my ($seq,$i) = @_; - return $seq->[$i] // die "nth: index out of bounds"; -} - -sub first { - my ($seq) = @_; - return $seq->[0] // $nil; -} - -sub apply { - my $f = shift; - push @_, @{pop @_}; - goto &$f; -} - -sub mal_map { - my $f = shift; - my @arr = map { &$f($_) } @{$_[0]}; - return Mal::List->new(\@arr); -} - -sub conj { - my $seq = shift; - my $new_seq = $seq->clone; - if ($new_seq->isa('Mal::List')) { - unshift @$new_seq, reverse @_; - } else { - push @$new_seq, @_; - } - return $new_seq; -} - -sub seq { - my ($arg) = @_; - if ($arg eq $nil) { - return $nil; - } elsif ($arg->isa('Mal::List')) { - return $nil unless @$arg; - return $arg; - } elsif ($arg->isa('Mal::Vector')) { - return $nil unless @$arg; - return Mal::List->new([@$arg]); - } elsif ($arg->isa('Mal::String')) { - return $nil if length($$arg) == 0; - my @chars = map { Mal::String->new($_) } split(//, $$arg); - return Mal::List->new(\@chars); - } else { - die "seq requires list or vector or string or nil"; - } -} - -fieldhash my %meta; - -# Metadata functions -sub with_meta { - my $new_obj = $_[0]->clone; - $meta{$new_obj} = $_[1]; - return $new_obj; -} - - -# Atom functions -sub swap_BANG { - my ($atm,$f,@args) = @_; - return $$atm = &$f($$atm, @args); -} - - -# Interop - -sub pl_STAR { - my $result = eval(${$_[0]}); - die $@ if $@; - return pl_to_mal($result); -} - - - -%core::ns = ( - '=' => sub { _equal_Q($_[0], $_[1]) ? $true : $false }, - 'throw' => sub { die $_[0] }, - 'nil?' => sub { $_[0] eq $nil ? $true : $false }, - 'true?' => sub { $_[0] eq $true ? $true : $false }, - 'false?' => sub { $_[0] eq $false ? $true : $false }, - 'number?' => sub { $_[0]->isa('Mal::Integer') ? $true : $false }, - 'symbol' => sub { Mal::Symbol->new(${$_[0]}) }, - 'symbol?' => sub { $_[0]->isa('Mal::Symbol') ? $true : $false }, - 'string?' => sub { $_[0]->isa('Mal::String') ? $true : $false }, - 'keyword' => sub { Mal::Keyword->new(${$_[0]}) }, - 'keyword?' => sub { $_[0]->isa('Mal::Keyword') ? $true : $false }, - 'fn?' => sub { $_[0]->isa('Mal::Function') ? $true : $false }, - 'macro?' => sub { $_[0]->isa('Mal::Macro') ? $true : $false }, - - 'pr-str' => \&pr_str, - 'str' => \&str, - 'prn' => \&prn, - 'println' => \&println, - 'readline' => \&mal_readline, - 'read-string' => sub { read_str(${$_[0]}) }, - 'slurp' => \&slurp, - '<' => sub { ${$_[0]} < ${$_[1]} ? $true : $false }, - '<=' => sub { ${$_[0]} <= ${$_[1]} ? $true : $false }, - '>' => sub { ${$_[0]} > ${$_[1]} ? $true : $false }, - '>=' => sub { ${$_[0]} >= ${$_[1]} ? $true : $false }, - '+' => sub { Mal::Integer->new(${$_[0]} + ${$_[1]}) }, - '-' => sub { Mal::Integer->new(${$_[0]} - ${$_[1]}) }, - '*' => sub { Mal::Integer->new(${$_[0]} * ${$_[1]}) }, - '/' => sub { Mal::Integer->new(${$_[0]} / ${$_[1]}) }, - 'time-ms' => sub { Mal::Integer->new(int(time()*1000)) }, - - 'list' => sub { Mal::List->new(\@_) }, - 'list?' => sub { $_[0]->isa('Mal::List') ? $true : $false }, - 'vector' => sub { Mal::Vector->new(\@_) }, - 'vector?' => sub { $_[0]->isa('Mal::Vector') ? $true : $false }, - 'hash-map' => sub { Mal::HashMap->new(\@_) }, - 'map?' => sub { $_[0]->isa('Mal::HashMap') ? $true : $false }, - 'assoc' => \&assoc, - 'dissoc' => \&dissoc, - 'get' => \&get, - 'contains?' => \&contains_Q, - 'keys' => \&mal_keys, - 'vals' => \&mal_vals, - - 'sequential?' => sub { $_[0]->isa('Mal::Sequence') ? $true : $false }, - 'nth' => sub { nth($_[0], ${$_[1]}) }, - 'first' => \&first, - 'rest' => sub { $_[0]->rest() }, - 'cons' => \&cons, - 'concat' => sub { Mal::List->new([map @$_, @_]) }, - 'vec' => sub { Mal::Vector->new([@{$_[0]}]) }, - 'empty?' => sub { @{$_[0]} ? $false : $true }, - 'count' => sub { Mal::Integer->new(scalar(@{$_[0]})) }, - 'apply' => \&apply, - 'map' => \&mal_map, - 'conj' => \&conj, - 'seq' => \&seq, - - 'with-meta' => \&with_meta, - 'meta' => sub { $meta{$_[0]} // $nil }, - 'atom' => sub { Mal::Atom->new($_[0]) }, - 'atom?' => sub { $_[0]->isa('Mal::Atom') ? $true : $false }, - 'deref' => sub { ${$_[0]} }, - 'reset!' => sub { ${$_[0]} = $_[1] }, - 'swap!' => \&swap_BANG, - - 'pl*' => \&pl_STAR, -); - -foreach my $f (values %core::ns) { - $f = Mal::Function->new($f); -} - -1; +package core; +use strict; +use warnings; + +use Data::Dumper; +use Hash::Util qw(fieldhash); +use List::Util qw(pairmap); +use Time::HiRes qw(time); + +use readline; +use types qw(_equal_Q thaw_key $nil $true $false); +use reader qw(read_str); +use printer qw(_pr_str); +use interop qw(pl_to_mal); + +# String functions + +sub pr_str { + return Mal::String->new(join(" ", map {_pr_str($_, 1)} @_)); +} + +sub str { + return Mal::String->new(join("", map {_pr_str($_, 0)} @_)); +} + +sub prn { + print join(" ", map {_pr_str($_, 1)} @_) . "\n"; + return $nil +} + +sub println { + print join(" ", map {_pr_str($_, 0)} @_) . "\n"; + return $nil +} + +sub mal_readline { + my $line = readline::mal_readline(${$_[0]}); + return defined $line ? Mal::String->new($line) : $nil; +} + +sub slurp { + use autodie; + open(my $fh, '<', ${$_[0]}); + my $data = do { local $/; <$fh> }; + Mal::String->new($data) +} + +# Hash Map functions + +sub assoc { + my $src_hsh = shift; + return Mal::HashMap->new( { %$src_hsh, @_ } ); +} + +sub dissoc { + my $new_hsh = { %{shift @_} }; + delete @{$new_hsh}{@_}; + return Mal::HashMap->new($new_hsh); +} + + +sub get { + my ($hsh, $key) = @_; + return $hsh->{$key} // $nil; +} + +sub contains_Q { + my ($hsh, $key) = @_; + return (exists $hsh->{$key}) ? $true : $false; +} + +sub mal_keys { + my @ks = map { thaw_key($_) } keys %{$_[0]}; + return Mal::List->new(\@ks); +} + +sub mal_vals { + my @vs = values %{$_[0]}; + return Mal::List->new(\@vs); +} + + +# Sequence functions + +sub cons { + my ($a, $b) = @_; + Mal::List->new([$a, @$b]); +} + +sub nth { + my ($seq,$i) = @_; + return $seq->[$i] // die "nth: index out of bounds"; +} + +sub first { + my ($seq) = @_; + return $seq->[0] // $nil; +} + +sub apply { + my $f = shift; + push @_, @{pop @_}; + goto &$f; +} + +sub mal_map { + my $f = shift; + my @arr = map { &$f($_) } @{$_[0]}; + return Mal::List->new(\@arr); +} + +sub conj { + my $seq = shift; + my $new_seq = $seq->clone; + if ($new_seq->isa('Mal::List')) { + unshift @$new_seq, reverse @_; + } else { + push @$new_seq, @_; + } + return $new_seq; +} + +sub seq { + my ($arg) = @_; + if ($arg eq $nil) { + return $nil; + } elsif ($arg->isa('Mal::List')) { + return $nil unless @$arg; + return $arg; + } elsif ($arg->isa('Mal::Vector')) { + return $nil unless @$arg; + return Mal::List->new([@$arg]); + } elsif ($arg->isa('Mal::String')) { + return $nil if length($$arg) == 0; + my @chars = map { Mal::String->new($_) } split(//, $$arg); + return Mal::List->new(\@chars); + } else { + die "seq requires list or vector or string or nil"; + } +} + +fieldhash my %meta; + +# Metadata functions +sub with_meta { + my $new_obj = $_[0]->clone; + $meta{$new_obj} = $_[1]; + return $new_obj; +} + + +# Atom functions +sub swap_BANG { + my ($atm,$f,@args) = @_; + return $$atm = &$f($$atm, @args); +} + + +# Interop + +sub pl_STAR { + my $result = eval(${$_[0]}); + die $@ if $@; + return pl_to_mal($result); +} + + + +%core::ns = ( + '=' => sub { _equal_Q($_[0], $_[1]) ? $true : $false }, + 'throw' => sub { die $_[0] }, + 'nil?' => sub { $_[0] eq $nil ? $true : $false }, + 'true?' => sub { $_[0] eq $true ? $true : $false }, + 'false?' => sub { $_[0] eq $false ? $true : $false }, + 'number?' => sub { $_[0]->isa('Mal::Integer') ? $true : $false }, + 'symbol' => sub { Mal::Symbol->new(${$_[0]}) }, + 'symbol?' => sub { $_[0]->isa('Mal::Symbol') ? $true : $false }, + 'string?' => sub { $_[0]->isa('Mal::String') ? $true : $false }, + 'keyword' => sub { Mal::Keyword->new(${$_[0]}) }, + 'keyword?' => sub { $_[0]->isa('Mal::Keyword') ? $true : $false }, + 'fn?' => sub { $_[0]->isa('Mal::Function') ? $true : $false }, + 'macro?' => sub { $_[0]->isa('Mal::Macro') ? $true : $false }, + + 'pr-str' => \&pr_str, + 'str' => \&str, + 'prn' => \&prn, + 'println' => \&println, + 'readline' => \&mal_readline, + 'read-string' => sub { read_str(${$_[0]}) }, + 'slurp' => \&slurp, + '<' => sub { ${$_[0]} < ${$_[1]} ? $true : $false }, + '<=' => sub { ${$_[0]} <= ${$_[1]} ? $true : $false }, + '>' => sub { ${$_[0]} > ${$_[1]} ? $true : $false }, + '>=' => sub { ${$_[0]} >= ${$_[1]} ? $true : $false }, + '+' => sub { Mal::Integer->new(${$_[0]} + ${$_[1]}) }, + '-' => sub { Mal::Integer->new(${$_[0]} - ${$_[1]}) }, + '*' => sub { Mal::Integer->new(${$_[0]} * ${$_[1]}) }, + '/' => sub { Mal::Integer->new(${$_[0]} / ${$_[1]}) }, + 'time-ms' => sub { Mal::Integer->new(int(time()*1000)) }, + + 'list' => sub { Mal::List->new(\@_) }, + 'list?' => sub { $_[0]->isa('Mal::List') ? $true : $false }, + 'vector' => sub { Mal::Vector->new(\@_) }, + 'vector?' => sub { $_[0]->isa('Mal::Vector') ? $true : $false }, + 'hash-map' => sub { Mal::HashMap->new(\@_) }, + 'map?' => sub { $_[0]->isa('Mal::HashMap') ? $true : $false }, + 'assoc' => \&assoc, + 'dissoc' => \&dissoc, + 'get' => \&get, + 'contains?' => \&contains_Q, + 'keys' => \&mal_keys, + 'vals' => \&mal_vals, + + 'sequential?' => sub { $_[0]->isa('Mal::Sequence') ? $true : $false }, + 'nth' => sub { nth($_[0], ${$_[1]}) }, + 'first' => \&first, + 'rest' => sub { $_[0]->rest() }, + 'cons' => \&cons, + 'concat' => sub { Mal::List->new([map @$_, @_]) }, + 'vec' => sub { Mal::Vector->new([@{$_[0]}]) }, + 'empty?' => sub { @{$_[0]} ? $false : $true }, + 'count' => sub { Mal::Integer->new(scalar(@{$_[0]})) }, + 'apply' => \&apply, + 'map' => \&mal_map, + 'conj' => \&conj, + 'seq' => \&seq, + + 'with-meta' => \&with_meta, + 'meta' => sub { $meta{$_[0]} // $nil }, + 'atom' => sub { Mal::Atom->new($_[0]) }, + 'atom?' => sub { $_[0]->isa('Mal::Atom') ? $true : $false }, + 'deref' => sub { ${$_[0]} }, + 'reset!' => sub { ${$_[0]} = $_[1] }, + 'swap!' => \&swap_BANG, + + 'pl*' => \&pl_STAR, +); + +foreach my $f (values %core::ns) { + $f = Mal::Function->new($f); +} + +1; diff --git a/impls/perl/env.pm b/impls/perl/env.pm index 5614b2eb87..e9023332df 100644 --- a/impls/perl/env.pm +++ b/impls/perl/env.pm @@ -1,63 +1,63 @@ -use strict; -use warnings; - -use Exporter 'import'; - - -{ - package Mal::Env; - use Data::Dumper; - sub new { - my ($class,$outer,$binds,$exprs) = @_; - my $data = { __outer__ => $outer }; - if ($binds) { - my @expr = @$exprs; - foreach my $bind (@$binds) { - if ($$bind eq "&") { - # variable length arguments - @expr = (Mal::List->new([@expr])); - next; - } - $data->{$$bind} = shift @expr; - } - } - bless $data => $class - } - sub find { - my ($self, $key) = @_; - if (exists $self->{$$key}) { return $self; } - elsif ($self->{__outer__}) { return $self->{__outer__}->find($key); } - else { return undef; } - } - sub set { - my ($self, $key, $value) = @_; - $self->{$$key} = $value; - return $value - } - sub get { - my ($self, $key) = @_; - my $env = $self->find($key); - die "'$$key' not found\n" unless $env; - return $env->{$$key}; - } -} - -#my $e1 = Mal::Env->new(); -#print Dumper($e1); -# -#my $e2 = Mal::Env->new(); -#$e2->set('abc', 123); -#$e2->set('def', 456); -#print Dumper($e2); -# -#my $e3 = Mal::Env->new($e2); -#$e3->set('abc', 789); -#$e3->set('ghi', 1024); -#print Dumper($e3); -# -#print Dumper($e3->find('abc')); -#print Dumper($e3->get('abc')); -#print Dumper($e3->find('def')); -#print Dumper($e3->get('def')); - -1; +use strict; +use warnings; + +use Exporter 'import'; + + +{ + package Mal::Env; + use Data::Dumper; + sub new { + my ($class,$outer,$binds,$exprs) = @_; + my $data = { __outer__ => $outer }; + if ($binds) { + my @expr = @$exprs; + foreach my $bind (@$binds) { + if ($$bind eq "&") { + # variable length arguments + @expr = (Mal::List->new([@expr])); + next; + } + $data->{$$bind} = shift @expr; + } + } + bless $data => $class + } + sub find { + my ($self, $key) = @_; + if (exists $self->{$$key}) { return $self; } + elsif ($self->{__outer__}) { return $self->{__outer__}->find($key); } + else { return undef; } + } + sub set { + my ($self, $key, $value) = @_; + $self->{$$key} = $value; + return $value + } + sub get { + my ($self, $key) = @_; + my $env = $self->find($key); + die "'$$key' not found\n" unless $env; + return $env->{$$key}; + } +} + +#my $e1 = Mal::Env->new(); +#print Dumper($e1); +# +#my $e2 = Mal::Env->new(); +#$e2->set('abc', 123); +#$e2->set('def', 456); +#print Dumper($e2); +# +#my $e3 = Mal::Env->new($e2); +#$e3->set('abc', 789); +#$e3->set('ghi', 1024); +#print Dumper($e3); +# +#print Dumper($e3->find('abc')); +#print Dumper($e3->get('abc')); +#print Dumper($e3->find('def')); +#print Dumper($e3->get('def')); + +1; diff --git a/impls/perl/interop.pm b/impls/perl/interop.pm index 3c068f908a..0022a91138 100644 --- a/impls/perl/interop.pm +++ b/impls/perl/interop.pm @@ -1,33 +1,33 @@ -package interop; -use strict; -use warnings; - -use Exporter 'import'; -our @EXPORT_OK = qw( pl_to_mal ); -use List::Util qw(pairmap); -use Scalar::Util qw(looks_like_number); - -use types qw($nil); - -sub pl_to_mal { - my($obj) = @_; - for (ref $obj) { - if (/^ARRAY/) { - my @arr = map {pl_to_mal($_)} @$obj; - return Mal::List->new(\@arr); - } elsif (/^HASH/) { - my %hsh = map { pl_to_mal($_) } %$obj; - return Mal::HashMap->new(\%hsh) - } else { - if (!defined($obj)) { - return $nil; - } elsif (looks_like_number($obj)) { - return Mal::Integer->new($obj); - } else { - return Mal::String->new($obj); - } - } - } -} - -1; +package interop; +use strict; +use warnings; + +use Exporter 'import'; +our @EXPORT_OK = qw( pl_to_mal ); +use List::Util qw(pairmap); +use Scalar::Util qw(looks_like_number); + +use types qw($nil); + +sub pl_to_mal { + my($obj) = @_; + for (ref $obj) { + if (/^ARRAY/) { + my @arr = map {pl_to_mal($_)} @$obj; + return Mal::List->new(\@arr); + } elsif (/^HASH/) { + my %hsh = map { pl_to_mal($_) } %$obj; + return Mal::HashMap->new(\%hsh) + } else { + if (!defined($obj)) { + return $nil; + } elsif (looks_like_number($obj)) { + return Mal::Integer->new($obj); + } else { + return Mal::String->new($obj); + } + } + } +} + +1; diff --git a/impls/perl/printer.pm b/impls/perl/printer.pm index 3397065541..26ecc29824 100644 --- a/impls/perl/printer.pm +++ b/impls/perl/printer.pm @@ -1,46 +1,46 @@ -package printer; -use strict; -use warnings; - -use Exporter 'import'; -our @EXPORT_OK = qw( _pr_str ); - -use types qw(thaw_key $nil $true $false); - -use Data::Dumper; -use List::Util qw(pairmap); - -sub _pr_str { - my($obj, $print_readably) = @_; - my($_r) = $print_readably // 1; - if ($obj->isa('Mal::List')) { - return '(' . join(' ', map { _pr_str($_, $_r) } @$obj) . ')'; - } elsif ($obj->isa('Mal::Vector')) { - return '[' . join(' ', map { _pr_str($_, $_r) } @$obj) . ']'; - } elsif ($obj->isa('Mal::HashMap')) { - return '{' . join(' ', pairmap { _pr_str(thaw_key($a), $_r) => - _pr_str($b, $_r) } %$obj) . '}'; - } elsif ($obj->isa('Mal::Keyword')) { - return ":$$obj"; - } elsif ($obj->isa('Mal::String')) { - if ($_r) { - my $str = $$obj; - $str =~ s/\\/\\\\/g; - $str =~ s/"/\\"/g; - $str =~ s/\n/\\n/g; - return qq'"$str"'; - } else { - return $$obj; - } - } elsif ($obj->isa('Mal::Atom')) { - return '(atom ' . _pr_str($$obj) . ")"; - } elsif ($obj->isa('Mal::Function')) { - return ""; - } elsif ($obj->isa('Mal::Macro')) { - return ""; - } else { - return $$obj; - } -} - -1; +package printer; +use strict; +use warnings; + +use Exporter 'import'; +our @EXPORT_OK = qw( _pr_str ); + +use types qw(thaw_key $nil $true $false); + +use Data::Dumper; +use List::Util qw(pairmap); + +sub _pr_str { + my($obj, $print_readably) = @_; + my($_r) = $print_readably // 1; + if ($obj->isa('Mal::List')) { + return '(' . join(' ', map { _pr_str($_, $_r) } @$obj) . ')'; + } elsif ($obj->isa('Mal::Vector')) { + return '[' . join(' ', map { _pr_str($_, $_r) } @$obj) . ']'; + } elsif ($obj->isa('Mal::HashMap')) { + return '{' . join(' ', pairmap { _pr_str(thaw_key($a), $_r) => + _pr_str($b, $_r) } %$obj) . '}'; + } elsif ($obj->isa('Mal::Keyword')) { + return ":$$obj"; + } elsif ($obj->isa('Mal::String')) { + if ($_r) { + my $str = $$obj; + $str =~ s/\\/\\\\/g; + $str =~ s/"/\\"/g; + $str =~ s/\n/\\n/g; + return qq'"$str"'; + } else { + return $$obj; + } + } elsif ($obj->isa('Mal::Atom')) { + return '(atom ' . _pr_str($$obj) . ")"; + } elsif ($obj->isa('Mal::Function')) { + return ""; + } elsif ($obj->isa('Mal::Macro')) { + return ""; + } else { + return $$obj; + } +} + +1; diff --git a/impls/perl/reader.pm b/impls/perl/reader.pm index 2e5c36f95e..9056b74d2f 100644 --- a/impls/perl/reader.pm +++ b/impls/perl/reader.pm @@ -1,118 +1,118 @@ -package reader; -use strict; -use warnings; -no if $] >= 5.018, warnings => "experimental::smartmatch"; -use feature qw(switch); - -use Exporter 'import'; -our @EXPORT_OK = qw( read_str ); - -use types qw($nil $true $false); - -use Data::Dumper; - -{ - package Mal::Reader; - sub new { - my $class = shift; - bless { position => 0, tokens => shift } => $class - } - sub next { my $self = shift; return $self->{tokens}[$self->{position}++] } - sub peek { my $self = shift; return $self->{tokens}[$self->{position}] } -} - -sub tokenize { - my($str) = @_; - my @tokens = $str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; - return grep {! /^;|^$/} @tokens; -} - -sub read_atom { - my($rdr) = @_; - my $token = $rdr->next(); - given ($token) { - when(/^-?[0-9]+$/) { return Mal::Integer->new($token) } - when(/^"((?:\\.|[^\\"])*)"$/) { - return Mal::String->new($1 =~ s/\\(.)/$1 =~ tr|n|\n|r/ger); - } - when(/^"/) { - die "expected '\"', got EOF"; - } - when(/^:/) { return Mal::Keyword->new($') } - when('nil') { return $nil } - when('true') { return $true } - when('false') { return $false } - default { return Mal::Symbol->new($token) } - } -} - -sub read_list { - my($rdr,$class,$start,$end) = @_; - $start = $start // '('; - $end = $end // ')'; - - my $token = $rdr->next(); - my @lst = (); - if ($token ne $start) { - die "expected '$start'"; - } - while (1) { - $token = $rdr->peek(); - if (! defined($token)) { - die "expected '$end', got EOF"; - } - last if ($token eq $end); - push(@lst, read_form($rdr)); - } - $rdr->next(); - return $class->new(\@lst); -} - -sub read_form { - my($rdr) = @_; - my $token = $rdr->peek(); - given ($token) { - when("'") { $rdr->next(); Mal::List->new([Mal::Symbol->new('quote'), - read_form($rdr)]) } - when('`') { $rdr->next(); - Mal::List->new([Mal::Symbol->new('quasiquote'), - read_form($rdr)]) } - when('~') { $rdr->next(); Mal::List->new([Mal::Symbol->new('unquote'), - read_form($rdr)]) } - when('~@') { $rdr->next(); - Mal::List->new([Mal::Symbol->new('splice-unquote'), - read_form($rdr)]) } - when('^') { $rdr->next(); my $meta = read_form($rdr); - Mal::List->new([Mal::Symbol->new('with-meta'), - read_form($rdr), $meta]) } - when('@') { $rdr->next(); Mal::List->new([Mal::Symbol->new('deref'), - read_form($rdr)]) } - - when(')') { die "unexpected ')'" } - when('(') { return read_list($rdr, 'Mal::List') } - when(']') { die "unexpected ']'" } - when('[') { return read_list($rdr, 'Mal::Vector', '[', ']') } - when('}') { die "unexpected '}'" } - when('{') { return read_list($rdr, 'Mal::HashMap', '{', '}') } - default { return read_atom($rdr) } - } -} - -sub read_str { - my($str) = @_; - my @tokens = tokenize($str); - #print "tokens: " . Dumper(\@tokens); - if (scalar(@tokens) == 0) { die Mal::BlankException->new(); } - return read_form(Mal::Reader->new(\@tokens)); -} - -#print Dumper(read_str("123")); -#print Dumper(read_str("+")); -#print Dumper(read_str("\"abc\"")); -#print Dumper(read_str("nil")); -#print Dumper(read_str("true")); -#print Dumper(read_str("false")); -#print Dumper(read_str("(+ 2 3)")); -#print Dumper(read_str("(foo 2 (3 4))")); - -1; +package reader; +use strict; +use warnings; +no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch); + +use Exporter 'import'; +our @EXPORT_OK = qw( read_str ); + +use types qw($nil $true $false); + +use Data::Dumper; + +{ + package Mal::Reader; + sub new { + my $class = shift; + bless { position => 0, tokens => shift } => $class + } + sub next { my $self = shift; return $self->{tokens}[$self->{position}++] } + sub peek { my $self = shift; return $self->{tokens}[$self->{position}] } +} + +sub tokenize { + my($str) = @_; + my @tokens = $str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; + return grep {! /^;|^$/} @tokens; +} + +sub read_atom { + my($rdr) = @_; + my $token = $rdr->next(); + given ($token) { + when(/^-?[0-9]+$/) { return Mal::Integer->new($token) } + when(/^"((?:\\.|[^\\"])*)"$/) { + return Mal::String->new($1 =~ s/\\(.)/$1 =~ tr|n|\n|r/ger); + } + when(/^"/) { + die "expected '\"', got EOF"; + } + when(/^:/) { return Mal::Keyword->new($') } + when('nil') { return $nil } + when('true') { return $true } + when('false') { return $false } + default { return Mal::Symbol->new($token) } + } +} + +sub read_list { + my($rdr,$class,$start,$end) = @_; + $start = $start // '('; + $end = $end // ')'; + + my $token = $rdr->next(); + my @lst = (); + if ($token ne $start) { + die "expected '$start'"; + } + while (1) { + $token = $rdr->peek(); + if (! defined($token)) { + die "expected '$end', got EOF"; + } + last if ($token eq $end); + push(@lst, read_form($rdr)); + } + $rdr->next(); + return $class->new(\@lst); +} + +sub read_form { + my($rdr) = @_; + my $token = $rdr->peek(); + given ($token) { + when("'") { $rdr->next(); Mal::List->new([Mal::Symbol->new('quote'), + read_form($rdr)]) } + when('`') { $rdr->next(); + Mal::List->new([Mal::Symbol->new('quasiquote'), + read_form($rdr)]) } + when('~') { $rdr->next(); Mal::List->new([Mal::Symbol->new('unquote'), + read_form($rdr)]) } + when('~@') { $rdr->next(); + Mal::List->new([Mal::Symbol->new('splice-unquote'), + read_form($rdr)]) } + when('^') { $rdr->next(); my $meta = read_form($rdr); + Mal::List->new([Mal::Symbol->new('with-meta'), + read_form($rdr), $meta]) } + when('@') { $rdr->next(); Mal::List->new([Mal::Symbol->new('deref'), + read_form($rdr)]) } + + when(')') { die "unexpected ')'" } + when('(') { return read_list($rdr, 'Mal::List') } + when(']') { die "unexpected ']'" } + when('[') { return read_list($rdr, 'Mal::Vector', '[', ']') } + when('}') { die "unexpected '}'" } + when('{') { return read_list($rdr, 'Mal::HashMap', '{', '}') } + default { return read_atom($rdr) } + } +} + +sub read_str { + my($str) = @_; + my @tokens = tokenize($str); + #print "tokens: " . Dumper(\@tokens); + if (scalar(@tokens) == 0) { die Mal::BlankException->new(); } + return read_form(Mal::Reader->new(\@tokens)); +} + +#print Dumper(read_str("123")); +#print Dumper(read_str("+")); +#print Dumper(read_str("\"abc\"")); +#print Dumper(read_str("nil")); +#print Dumper(read_str("true")); +#print Dumper(read_str("false")); +#print Dumper(read_str("(+ 2 3)")); +#print Dumper(read_str("(foo 2 (3 4))")); + +1; diff --git a/impls/perl/readline.pm b/impls/perl/readline.pm index cb4c287e4e..f868bec54a 100644 --- a/impls/perl/readline.pm +++ b/impls/perl/readline.pm @@ -1,73 +1,73 @@ -# To get readline line editing functionality, please install -# Term::ReadKey and either Term::ReadLine::Gnu (GPL) or -# Term::ReadLine::Perl (GPL, Artistic) from CPAN. - -package readline; -use strict; -use warnings; - -use Exporter 'import'; -our @EXPORT_OK = qw( mal_readline set_rl_mode ); -use Term::ReadLine; - -my $_rl = Term::ReadLine->new('Mal'); -$_rl->ornaments(0); -#print "Using ReadLine implementation: " . $_rl->ReadLine() . "\n"; -my $OUT = $_rl->OUT || \*STDOUT; -my $_history_loaded = 0; - -my $history_file = $ENV{"HOME"} . "/.mal-history"; - -sub save_line { - my ($line) = @_; - open(my $fh, '>>', $history_file) or return; - say $fh $line; - close $fh; -} - -sub load_history { - open my $fh, $history_file or return; - - while(my $line = <$fh>) { - chomp $line; - $_rl->addhistory($line) if $line =~ /\S/; - } - - close $fh; -} - -my $rl_mode = "terminal"; - -sub set_rl_mode { - my($mode) = @_; - $rl_mode = $mode; -} - -sub mal_readline { - my($prompt) = @_; - my $line = undef; - if (! $_history_loaded) { - $_history_loaded = 1; - load_history(); - } - - if ($rl_mode eq "terminal") { - if (defined ($line = $_rl->readline($prompt))) { - save_line($line); - chomp $line; - return $line; - } else { - return undef; - } - } else { - print "$prompt"; - if (defined ($line = readline(*STDIN))) { - save_line($line); - chomp($line); - return $line; - } else { - return undef; - } - } -} -1; +# To get readline line editing functionality, please install +# Term::ReadKey and either Term::ReadLine::Gnu (GPL) or +# Term::ReadLine::Perl (GPL, Artistic) from CPAN. + +package readline; +use strict; +use warnings; + +use Exporter 'import'; +our @EXPORT_OK = qw( mal_readline set_rl_mode ); +use Term::ReadLine; + +my $_rl = Term::ReadLine->new('Mal'); +$_rl->ornaments(0); +#print "Using ReadLine implementation: " . $_rl->ReadLine() . "\n"; +my $OUT = $_rl->OUT || \*STDOUT; +my $_history_loaded = 0; + +my $history_file = $ENV{"HOME"} . "/.mal-history"; + +sub save_line { + my ($line) = @_; + open(my $fh, '>>', $history_file) or return; + say $fh $line; + close $fh; +} + +sub load_history { + open my $fh, $history_file or return; + + while(my $line = <$fh>) { + chomp $line; + $_rl->addhistory($line) if $line =~ /\S/; + } + + close $fh; +} + +my $rl_mode = "terminal"; + +sub set_rl_mode { + my($mode) = @_; + $rl_mode = $mode; +} + +sub mal_readline { + my($prompt) = @_; + my $line = undef; + if (! $_history_loaded) { + $_history_loaded = 1; + load_history(); + } + + if ($rl_mode eq "terminal") { + if (defined ($line = $_rl->readline($prompt))) { + save_line($line); + chomp $line; + return $line; + } else { + return undef; + } + } else { + print "$prompt"; + if (defined ($line = readline(*STDIN))) { + save_line($line); + chomp($line); + return $line; + } else { + return undef; + } + } +} +1; diff --git a/impls/perl/run b/impls/perl/run index 05a286f8af..13548332e3 100755 --- a/impls/perl/run +++ b/impls/perl/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec perl $(dirname $0)/${STEP:-stepA_mal}.pl "${@}" +#!/bin/bash +exec perl $(dirname $0)/${STEP:-stepA_mal}.pl "${@}" diff --git a/impls/perl/step0_repl.pl b/impls/perl/step0_repl.pl index 77936339a7..d1f481e14f 100644 --- a/impls/perl/step0_repl.pl +++ b/impls/perl/step0_repl.pl @@ -1,39 +1,39 @@ -use strict; -use warnings; -use File::Basename; -use lib dirname (__FILE__); - -use readline qw(mal_readline set_rl_mode); - -# read -sub READ { - my $str = shift; - return $str; -} - -# eval -sub EVAL { - my($ast, $env) = @_; - return $ast; -} - -# print -sub PRINT { - my $exp = shift; - return $exp; -} - -# repl -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), {})); -} - -if (scalar(@ARGV) > 0 && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - print(REP($line), "\n"); -} +use strict; +use warnings; +use File::Basename; +use lib dirname (__FILE__); + +use readline qw(mal_readline set_rl_mode); + +# read +sub READ { + my $str = shift; + return $str; +} + +# eval +sub EVAL { + my($ast, $env) = @_; + return $ast; +} + +# print +sub PRINT { + my $exp = shift; + return $exp; +} + +# repl +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), {})); +} + +if (scalar(@ARGV) > 0 && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + print(REP($line), "\n"); +} diff --git a/impls/perl/step1_read_print.pl b/impls/perl/step1_read_print.pl index 9717d7e51c..084276d0b1 100644 --- a/impls/perl/step1_read_print.pl +++ b/impls/perl/step1_read_print.pl @@ -1,58 +1,58 @@ -use strict; -use warnings; -use File::Basename; -use lib dirname (__FILE__); - -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use reader; -use printer; - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub EVAL { - my($ast, $env) = @_; - return $ast; -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), {})); -} - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings; +use File::Basename; +use lib dirname (__FILE__); + +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use reader; +use printer; + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub EVAL { + my($ast, $env) = @_; + return $ast; +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), {})); +} + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/step2_eval.pl b/impls/perl/step2_eval.pl index 8fe002e97a..9619757c03 100644 --- a/impls/perl/step2_eval.pl +++ b/impls/perl/step2_eval.pl @@ -1,90 +1,90 @@ -use strict; -use warnings; -use File::Basename; -use lib dirname (__FILE__); - -use Data::Dumper; -use List::Util qw(pairmap); -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use types; -use reader; -use printer; - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub eval_ast { - my($ast, $env) = @_; - if ($ast->isa('Mal::Symbol')) { - return $env->{$$ast} // die "'$$ast' not found\n"; - } elsif ($ast->isa('Mal::Sequence')) { - return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); - } elsif ($ast->isa('Mal::HashMap')) { - return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); - } else { - return $ast; - } -} - -sub EVAL { - my($ast, $env) = @_; - #print "EVAL: " . printer::_pr_str($ast) . "\n"; - if (! $ast->isa('Mal::List')) { - return eval_ast($ast, $env); - } - - # apply list - unless (@$ast) { return $ast; } - my @el = @{eval_ast($ast, $env)}; - my $f = shift @el; - return &$f(@el); -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -my $repl_env = { - '+' => sub { Mal::Integer->new(${$_[0]} + ${$_[1]}) }, - '-' => sub { Mal::Integer->new(${$_[0]} - ${$_[1]}) }, - '*' => sub { Mal::Integer->new(${$_[0]} * ${$_[1]}) }, - '/' => sub { Mal::Integer->new(${$_[0]} / ${$_[1]}) }, -}; - -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), $repl_env)); -} - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings; +use File::Basename; +use lib dirname (__FILE__); + +use Data::Dumper; +use List::Util qw(pairmap); +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use types; +use reader; +use printer; + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub eval_ast { + my($ast, $env) = @_; + if ($ast->isa('Mal::Symbol')) { + return $env->{$$ast} // die "'$$ast' not found\n"; + } elsif ($ast->isa('Mal::Sequence')) { + return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); + } elsif ($ast->isa('Mal::HashMap')) { + return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); + } else { + return $ast; + } +} + +sub EVAL { + my($ast, $env) = @_; + #print "EVAL: " . printer::_pr_str($ast) . "\n"; + if (! $ast->isa('Mal::List')) { + return eval_ast($ast, $env); + } + + # apply list + unless (@$ast) { return $ast; } + my @el = @{eval_ast($ast, $env)}; + my $f = shift @el; + return &$f(@el); +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +my $repl_env = { + '+' => sub { Mal::Integer->new(${$_[0]} + ${$_[1]}) }, + '-' => sub { Mal::Integer->new(${$_[0]} - ${$_[1]}) }, + '*' => sub { Mal::Integer->new(${$_[0]} * ${$_[1]}) }, + '/' => sub { Mal::Integer->new(${$_[0]} / ${$_[1]}) }, +}; + +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), $repl_env)); +} + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/step3_env.pl b/impls/perl/step3_env.pl index 478c1e9ad2..265384afe3 100644 --- a/impls/perl/step3_env.pl +++ b/impls/perl/step3_env.pl @@ -1,113 +1,113 @@ -use strict; -use warnings; -no if $] >= 5.018, warnings => "experimental::smartmatch"; -use feature qw(switch); -use File::Basename; -use lib dirname (__FILE__); - -use Data::Dumper; -use List::Util qw(pairs pairmap); -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use types; -use reader; -use printer; -use env; - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub eval_ast { - my($ast, $env) = @_; - if ($ast->isa('Mal::Symbol')) { - return $env->get($ast); - } elsif ($ast->isa('Mal::Sequence')) { - return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); - } elsif ($ast->isa('Mal::HashMap')) { - return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); - } else { - return $ast; - } -} - -sub EVAL { - my($ast, $env) = @_; - #print "EVAL: " . printer::_pr_str($ast) . "\n"; - if (! $ast->isa('Mal::List')) { - return eval_ast($ast, $env); - } - - # apply list - unless (@$ast) { return $ast; } - given (${$ast->[0]}) { - when ('def!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, EVAL($val, $env)); - } - when ('let*') { - my (undef, $bindings, $body) = @$ast; - my $let_env = Mal::Env->new($env); - foreach my $pair (pairs @$bindings) { - my ($k, $v) = @$pair; - $let_env->set($k, EVAL($v, $let_env)); - } - return EVAL($body, $let_env); - } - default { - my @el = @{eval_ast($ast, $env)}; - my $f = shift @el; - return &$f(@el); - } - } -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -my $repl_env = Mal::Env->new(); -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), $repl_env)); -} - -$repl_env->set(Mal::Symbol->new('+'), - sub { Mal::Integer->new(${$_[0]} + ${$_[1]}) } ); -$repl_env->set(Mal::Symbol->new('-'), - sub { Mal::Integer->new(${$_[0]} - ${$_[1]}) } ); -$repl_env->set(Mal::Symbol->new('*'), - sub { Mal::Integer->new(${$_[0]} * ${$_[1]}) } ); -$repl_env->set(Mal::Symbol->new('/'), - sub { Mal::Integer->new(${$_[0]} / ${$_[1]}) } ); - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings; +no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch); +use File::Basename; +use lib dirname (__FILE__); + +use Data::Dumper; +use List::Util qw(pairs pairmap); +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use types; +use reader; +use printer; +use env; + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub eval_ast { + my($ast, $env) = @_; + if ($ast->isa('Mal::Symbol')) { + return $env->get($ast); + } elsif ($ast->isa('Mal::Sequence')) { + return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); + } elsif ($ast->isa('Mal::HashMap')) { + return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); + } else { + return $ast; + } +} + +sub EVAL { + my($ast, $env) = @_; + #print "EVAL: " . printer::_pr_str($ast) . "\n"; + if (! $ast->isa('Mal::List')) { + return eval_ast($ast, $env); + } + + # apply list + unless (@$ast) { return $ast; } + given (${$ast->[0]}) { + when ('def!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, EVAL($val, $env)); + } + when ('let*') { + my (undef, $bindings, $body) = @$ast; + my $let_env = Mal::Env->new($env); + foreach my $pair (pairs @$bindings) { + my ($k, $v) = @$pair; + $let_env->set($k, EVAL($v, $let_env)); + } + return EVAL($body, $let_env); + } + default { + my @el = @{eval_ast($ast, $env)}; + my $f = shift @el; + return &$f(@el); + } + } +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +my $repl_env = Mal::Env->new(); +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), $repl_env)); +} + +$repl_env->set(Mal::Symbol->new('+'), + sub { Mal::Integer->new(${$_[0]} + ${$_[1]}) } ); +$repl_env->set(Mal::Symbol->new('-'), + sub { Mal::Integer->new(${$_[0]} - ${$_[1]}) } ); +$repl_env->set(Mal::Symbol->new('*'), + sub { Mal::Integer->new(${$_[0]} * ${$_[1]}) } ); +$repl_env->set(Mal::Symbol->new('/'), + sub { Mal::Integer->new(${$_[0]} / ${$_[1]}) } ); + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/step4_if_fn_do.pl b/impls/perl/step4_if_fn_do.pl index be0611bd5e..b886f5f9c4 100644 --- a/impls/perl/step4_if_fn_do.pl +++ b/impls/perl/step4_if_fn_do.pl @@ -1,135 +1,135 @@ -use strict; -use warnings; -no if $] >= 5.018, warnings => "experimental::smartmatch"; -use feature qw(switch); -use File::Basename; -use lib dirname (__FILE__); - -use Data::Dumper; -use List::Util qw(pairs pairmap); -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use types qw($nil $true $false); -use reader; -use printer; -use env; -use core; - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub eval_ast { - my($ast, $env) = @_; - if ($ast->isa('Mal::Symbol')) { - return $env->get($ast); - } elsif ($ast->isa('Mal::Sequence')) { - return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); - } elsif ($ast->isa('Mal::HashMap')) { - return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); - } else { - return $ast; - } -} - -sub EVAL { - my($ast, $env) = @_; - #print "EVAL: " . printer::_pr_str($ast) . "\n"; - if (! $ast->isa('Mal::List')) { - return eval_ast($ast, $env); - } - - # apply list - unless (@$ast) { return $ast; } - my ($a0) = @$ast; - given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { - when ('def!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, EVAL($val, $env)); - } - when ('let*') { - my (undef, $bindings, $body) = @$ast; - my $let_env = Mal::Env->new($env); - foreach my $pair (pairs @$bindings) { - my ($k, $v) = @$pair; - $let_env->set($k, EVAL($v, $let_env)); - } - return EVAL($body, $let_env); - } - when ('do') { - my (undef, @todo) = @$ast; - my $el = eval_ast(Mal::List->new(\@todo), $env); - return pop @$el; - } - when ('if') { - my (undef, $if, $then, $else) = @$ast; - my $cond = EVAL($if, $env); - if ($cond eq $nil || $cond eq $false) { - return $else ? EVAL($else, $env) : $nil; - } else { - return EVAL($then, $env); - } - } - when ('fn*') { - my (undef, $params, $body) = @$ast; - return Mal::Function->new(sub { - #print "running fn*\n"; - return EVAL($body, Mal::Env->new($env, $params, \@_)); - }); - } - default { - my @el = @{eval_ast($ast, $env)}; - my $f = shift @el; - return &$f(@el); - } - } -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -my $repl_env = Mal::Env->new(); -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), $repl_env)); -} - -# core.pl: defined using perl -foreach my $n (keys %core::ns) { - $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); -} - -# core.mal: defined using the language itself -REP(q[(def! not (fn* (a) (if a false true)))]); - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings; +no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch); +use File::Basename; +use lib dirname (__FILE__); + +use Data::Dumper; +use List::Util qw(pairs pairmap); +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use types qw($nil $true $false); +use reader; +use printer; +use env; +use core; + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub eval_ast { + my($ast, $env) = @_; + if ($ast->isa('Mal::Symbol')) { + return $env->get($ast); + } elsif ($ast->isa('Mal::Sequence')) { + return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); + } elsif ($ast->isa('Mal::HashMap')) { + return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); + } else { + return $ast; + } +} + +sub EVAL { + my($ast, $env) = @_; + #print "EVAL: " . printer::_pr_str($ast) . "\n"; + if (! $ast->isa('Mal::List')) { + return eval_ast($ast, $env); + } + + # apply list + unless (@$ast) { return $ast; } + my ($a0) = @$ast; + given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { + when ('def!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, EVAL($val, $env)); + } + when ('let*') { + my (undef, $bindings, $body) = @$ast; + my $let_env = Mal::Env->new($env); + foreach my $pair (pairs @$bindings) { + my ($k, $v) = @$pair; + $let_env->set($k, EVAL($v, $let_env)); + } + return EVAL($body, $let_env); + } + when ('do') { + my (undef, @todo) = @$ast; + my $el = eval_ast(Mal::List->new(\@todo), $env); + return pop @$el; + } + when ('if') { + my (undef, $if, $then, $else) = @$ast; + my $cond = EVAL($if, $env); + if ($cond eq $nil || $cond eq $false) { + return $else ? EVAL($else, $env) : $nil; + } else { + return EVAL($then, $env); + } + } + when ('fn*') { + my (undef, $params, $body) = @$ast; + return Mal::Function->new(sub { + #print "running fn*\n"; + return EVAL($body, Mal::Env->new($env, $params, \@_)); + }); + } + default { + my @el = @{eval_ast($ast, $env)}; + my $f = shift @el; + return &$f(@el); + } + } +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +my $repl_env = Mal::Env->new(); +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), $repl_env)); +} + +# core.pl: defined using perl +foreach my $n (keys %core::ns) { + $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); +} + +# core.mal: defined using the language itself +REP(q[(def! not (fn* (a) (if a false true)))]); + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/step5_tco.pl b/impls/perl/step5_tco.pl index 2c726ecaa3..f2aeaefdf2 100644 --- a/impls/perl/step5_tco.pl +++ b/impls/perl/step5_tco.pl @@ -1,141 +1,141 @@ -use strict; -use warnings FATAL => "recursion"; -no if $] >= 5.018, warnings => "experimental::smartmatch"; -use feature qw(switch); -use File::Basename; -use lib dirname (__FILE__); - -use Data::Dumper; -use List::Util qw(pairs pairmap); -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use types qw($nil $true $false); -use reader; -use printer; -use env; -use core; - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub eval_ast { - my($ast, $env) = @_; - if ($ast->isa('Mal::Symbol')) { - return $env->get($ast); - } elsif ($ast->isa('Mal::Sequence')) { - return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); - } elsif ($ast->isa('Mal::HashMap')) { - return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); - } else { - return $ast; - } -} - -sub EVAL { - my($ast, $env) = @_; - - #print "EVAL: " . printer::_pr_str($ast) . "\n"; - if (! $ast->isa('Mal::List')) { - goto &eval_ast; - } - - # apply list - unless (@$ast) { return $ast; } - my ($a0) = @$ast; - given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { - when ('def!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, EVAL($val, $env)); - } - when ('let*') { - my (undef, $bindings, $body) = @$ast; - my $let_env = Mal::Env->new($env); - foreach my $pair (pairs @$bindings) { - my ($k, $v) = @$pair; - $let_env->set($k, EVAL($v, $let_env)); - } - @_ = ($body, $let_env); - goto &EVAL; - } - when ('do') { - my (undef, @todo) = @$ast; - my $last = pop @todo; - eval_ast(Mal::List->new(\@todo), $env); - @_ = ($last, $env); - goto &EVAL; - } - when ('if') { - my (undef, $if, $then, $else) = @$ast; - my $cond = EVAL($if, $env); - if ($cond eq $nil || $cond eq $false) { - @_ = ($else // $nil, $env); - } else { - @_ = ($then, $env); - } - goto &EVAL; - } - when ('fn*') { - my (undef, $params, $body) = @$ast; - return Mal::Function->new(sub { - #print "running fn*\n"; - @_ = ($body, Mal::Env->new($env, $params, \@_)); - goto &EVAL; - }); - } - default { - @_ = @{eval_ast($ast, $env)}; - my $f = shift; - goto &$f; - } - } -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -my $repl_env = Mal::Env->new(); -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), $repl_env)); -} - -# core.pl: defined using perl -foreach my $n (keys %core::ns) { - $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); -} - -# core.mal: defined using the language itself -REP(q[(def! not (fn* (a) (if a false true)))]); - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings FATAL => "recursion"; +no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch); +use File::Basename; +use lib dirname (__FILE__); + +use Data::Dumper; +use List::Util qw(pairs pairmap); +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use types qw($nil $true $false); +use reader; +use printer; +use env; +use core; + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub eval_ast { + my($ast, $env) = @_; + if ($ast->isa('Mal::Symbol')) { + return $env->get($ast); + } elsif ($ast->isa('Mal::Sequence')) { + return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); + } elsif ($ast->isa('Mal::HashMap')) { + return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); + } else { + return $ast; + } +} + +sub EVAL { + my($ast, $env) = @_; + + #print "EVAL: " . printer::_pr_str($ast) . "\n"; + if (! $ast->isa('Mal::List')) { + goto &eval_ast; + } + + # apply list + unless (@$ast) { return $ast; } + my ($a0) = @$ast; + given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { + when ('def!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, EVAL($val, $env)); + } + when ('let*') { + my (undef, $bindings, $body) = @$ast; + my $let_env = Mal::Env->new($env); + foreach my $pair (pairs @$bindings) { + my ($k, $v) = @$pair; + $let_env->set($k, EVAL($v, $let_env)); + } + @_ = ($body, $let_env); + goto &EVAL; + } + when ('do') { + my (undef, @todo) = @$ast; + my $last = pop @todo; + eval_ast(Mal::List->new(\@todo), $env); + @_ = ($last, $env); + goto &EVAL; + } + when ('if') { + my (undef, $if, $then, $else) = @$ast; + my $cond = EVAL($if, $env); + if ($cond eq $nil || $cond eq $false) { + @_ = ($else // $nil, $env); + } else { + @_ = ($then, $env); + } + goto &EVAL; + } + when ('fn*') { + my (undef, $params, $body) = @$ast; + return Mal::Function->new(sub { + #print "running fn*\n"; + @_ = ($body, Mal::Env->new($env, $params, \@_)); + goto &EVAL; + }); + } + default { + @_ = @{eval_ast($ast, $env)}; + my $f = shift; + goto &$f; + } + } +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +my $repl_env = Mal::Env->new(); +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), $repl_env)); +} + +# core.pl: defined using perl +foreach my $n (keys %core::ns) { + $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); +} + +# core.mal: defined using the language itself +REP(q[(def! not (fn* (a) (if a false true)))]); + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/step6_file.pl b/impls/perl/step6_file.pl index 631d4c59ae..fbad4510cb 100644 --- a/impls/perl/step6_file.pl +++ b/impls/perl/step6_file.pl @@ -1,151 +1,151 @@ -use strict; -use warnings FATAL => "recursion"; -no if $] >= 5.018, warnings => "experimental::smartmatch"; -use feature qw(switch); -use File::Basename; -use lib dirname (__FILE__); - -use Data::Dumper; -use List::Util qw(pairs pairmap); -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use types qw($nil $true $false); -use reader; -use printer; -use env; -use core; - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub eval_ast { - my($ast, $env) = @_; - if ($ast->isa('Mal::Symbol')) { - return $env->get($ast); - } elsif ($ast->isa('Mal::Sequence')) { - return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); - } elsif ($ast->isa('Mal::HashMap')) { - return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); - } else { - return $ast; - } -} - -sub EVAL { - my($ast, $env) = @_; - - #print "EVAL: " . printer::_pr_str($ast) . "\n"; - if (! $ast->isa('Mal::List')) { - goto &eval_ast; - } - - # apply list - unless (@$ast) { return $ast; } - my ($a0) = @$ast; - given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { - when ('def!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, EVAL($val, $env)); - } - when ('let*') { - my (undef, $bindings, $body) = @$ast; - my $let_env = Mal::Env->new($env); - foreach my $pair (pairs @$bindings) { - my ($k, $v) = @$pair; - $let_env->set($k, EVAL($v, $let_env)); - } - @_ = ($body, $let_env); - goto &EVAL; - } - when ('do') { - my (undef, @todo) = @$ast; - my $last = pop @todo; - eval_ast(Mal::List->new(\@todo), $env); - @_ = ($last, $env); - goto &EVAL; - } - when ('if') { - my (undef, $if, $then, $else) = @$ast; - my $cond = EVAL($if, $env); - if ($cond eq $nil || $cond eq $false) { - @_ = ($else // $nil, $env); - } else { - @_ = ($then, $env); - } - goto &EVAL; - } - when ('fn*') { - my (undef, $params, $body) = @$ast; - return Mal::Function->new(sub { - #print "running fn*\n"; - @_ = ($body, Mal::Env->new($env, $params, \@_)); - goto &EVAL; - }); - } - default { - @_ = @{eval_ast($ast, $env)}; - my $f = shift; - goto &$f; - } - } -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -my $repl_env = Mal::Env->new(); -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), $repl_env)); -} - -# core.pl: defined using perl -foreach my $n (keys %core::ns) { - $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); -} -$repl_env->set(Mal::Symbol->new('eval'), - Mal::Function->new(sub { EVAL($_[0], $repl_env) })); -my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; -$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); - -# core.mal: defined using the language itself -REP(q[(def! not (fn* (a) (if a false true)))]); -REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); - shift @ARGV; -} -if (@ARGV) { - REP(qq[(load-file "$ARGV[0]")]); - exit 0; -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings FATAL => "recursion"; +no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch); +use File::Basename; +use lib dirname (__FILE__); + +use Data::Dumper; +use List::Util qw(pairs pairmap); +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use types qw($nil $true $false); +use reader; +use printer; +use env; +use core; + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub eval_ast { + my($ast, $env) = @_; + if ($ast->isa('Mal::Symbol')) { + return $env->get($ast); + } elsif ($ast->isa('Mal::Sequence')) { + return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); + } elsif ($ast->isa('Mal::HashMap')) { + return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); + } else { + return $ast; + } +} + +sub EVAL { + my($ast, $env) = @_; + + #print "EVAL: " . printer::_pr_str($ast) . "\n"; + if (! $ast->isa('Mal::List')) { + goto &eval_ast; + } + + # apply list + unless (@$ast) { return $ast; } + my ($a0) = @$ast; + given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { + when ('def!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, EVAL($val, $env)); + } + when ('let*') { + my (undef, $bindings, $body) = @$ast; + my $let_env = Mal::Env->new($env); + foreach my $pair (pairs @$bindings) { + my ($k, $v) = @$pair; + $let_env->set($k, EVAL($v, $let_env)); + } + @_ = ($body, $let_env); + goto &EVAL; + } + when ('do') { + my (undef, @todo) = @$ast; + my $last = pop @todo; + eval_ast(Mal::List->new(\@todo), $env); + @_ = ($last, $env); + goto &EVAL; + } + when ('if') { + my (undef, $if, $then, $else) = @$ast; + my $cond = EVAL($if, $env); + if ($cond eq $nil || $cond eq $false) { + @_ = ($else // $nil, $env); + } else { + @_ = ($then, $env); + } + goto &EVAL; + } + when ('fn*') { + my (undef, $params, $body) = @$ast; + return Mal::Function->new(sub { + #print "running fn*\n"; + @_ = ($body, Mal::Env->new($env, $params, \@_)); + goto &EVAL; + }); + } + default { + @_ = @{eval_ast($ast, $env)}; + my $f = shift; + goto &$f; + } + } +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +my $repl_env = Mal::Env->new(); +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), $repl_env)); +} + +# core.pl: defined using perl +foreach my $n (keys %core::ns) { + $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); +} +$repl_env->set(Mal::Symbol->new('eval'), + Mal::Function->new(sub { EVAL($_[0], $repl_env) })); +my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; +$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); + +# core.mal: defined using the language itself +REP(q[(def! not (fn* (a) (if a false true)))]); +REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); + shift @ARGV; +} +if (@ARGV) { + REP(qq[(load-file "$ARGV[0]")]); + exit 0; +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/step7_quote.pl b/impls/perl/step7_quote.pl index af87a29391..ea08043008 100644 --- a/impls/perl/step7_quote.pl +++ b/impls/perl/step7_quote.pl @@ -1,192 +1,192 @@ -use strict; -use warnings FATAL => "recursion"; -no if $] >= 5.018, warnings => "experimental::smartmatch"; -use feature qw(switch); -use File::Basename; -use lib dirname (__FILE__); - -use Data::Dumper; -use List::Util qw(pairs pairmap); -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use types qw($nil $true $false); -use reader; -use printer; -use env; -use core; - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub starts_with { - my ($ast, $sym) = @_; - return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym; -} -sub quasiquote_loop { - my ($ast) = @_; - my $res = Mal::List->new([]); - foreach my $elt (reverse @$ast) { - if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) { - $res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]); - } else { - $res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]); - } - } - return $res; -} -sub quasiquote { - my ($ast) = @_; - if ($ast->isa('Mal::Vector')) { - return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]); - } elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) { - return Mal::List->new([Mal::Symbol->new("quote"), $ast]); - } elsif (!$ast->isa('Mal::List')) { - return $ast; - } elsif (starts_with($ast, 'unquote')) { - return $ast->[1]; - } else { - return quasiquote_loop($ast); - } -} - -sub eval_ast { - my($ast, $env) = @_; - if ($ast->isa('Mal::Symbol')) { - return $env->get($ast); - } elsif ($ast->isa('Mal::Sequence')) { - return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); - } elsif ($ast->isa('Mal::HashMap')) { - return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); - } else { - return $ast; - } -} - -sub EVAL { - my($ast, $env) = @_; - - #print "EVAL: " . printer::_pr_str($ast) . "\n"; - if (! $ast->isa('Mal::List')) { - goto &eval_ast; - } - - # apply list - unless (@$ast) { return $ast; } - my ($a0) = @$ast; - given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { - when ('def!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, EVAL($val, $env)); - } - when ('let*') { - my (undef, $bindings, $body) = @$ast; - my $let_env = Mal::Env->new($env); - foreach my $pair (pairs @$bindings) { - my ($k, $v) = @$pair; - $let_env->set($k, EVAL($v, $let_env)); - } - @_ = ($body, $let_env); - goto &EVAL; - } - when ('quote') { - return $ast->[1]; - } - when ('quasiquoteexpand') { - return quasiquote($ast->[1]); - } - when ('quasiquote') { - @_ = (quasiquote($ast->[1]), $env); - goto &EVAL; - } - when ('do') { - my (undef, @todo) = @$ast; - my $last = pop @todo; - eval_ast(Mal::List->new(\@todo), $env); - @_ = ($last, $env); - goto &EVAL; - } - when ('if') { - my (undef, $if, $then, $else) = @$ast; - my $cond = EVAL($if, $env); - if ($cond eq $nil || $cond eq $false) { - @_ = ($else // $nil, $env); - } else { - @_ = ($then, $env); - } - goto &EVAL; - } - when ('fn*') { - my (undef, $params, $body) = @$ast; - return Mal::Function->new(sub { - #print "running fn*\n"; - @_ = ($body, Mal::Env->new($env, $params, \@_)); - goto &EVAL; - }); - } - default { - @_ = @{eval_ast($ast, $env)}; - my $f = shift; - goto &$f; - } - } -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -my $repl_env = Mal::Env->new(); -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), $repl_env)); -} - -# core.pl: defined using perl -foreach my $n (keys %core::ns) { - $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); -} -$repl_env->set(Mal::Symbol->new('eval'), - Mal::Function->new(sub { EVAL($_[0], $repl_env) })); -my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; -$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); - -# core.mal: defined using the language itself -REP(q[(def! not (fn* (a) (if a false true)))]); -REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); - shift @ARGV; -} -if (@ARGV) { - REP(qq[(load-file "$ARGV[0]")]); - exit 0; -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings FATAL => "recursion"; +no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch); +use File::Basename; +use lib dirname (__FILE__); + +use Data::Dumper; +use List::Util qw(pairs pairmap); +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use types qw($nil $true $false); +use reader; +use printer; +use env; +use core; + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub starts_with { + my ($ast, $sym) = @_; + return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym; +} +sub quasiquote_loop { + my ($ast) = @_; + my $res = Mal::List->new([]); + foreach my $elt (reverse @$ast) { + if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) { + $res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]); + } else { + $res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]); + } + } + return $res; +} +sub quasiquote { + my ($ast) = @_; + if ($ast->isa('Mal::Vector')) { + return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]); + } elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) { + return Mal::List->new([Mal::Symbol->new("quote"), $ast]); + } elsif (!$ast->isa('Mal::List')) { + return $ast; + } elsif (starts_with($ast, 'unquote')) { + return $ast->[1]; + } else { + return quasiquote_loop($ast); + } +} + +sub eval_ast { + my($ast, $env) = @_; + if ($ast->isa('Mal::Symbol')) { + return $env->get($ast); + } elsif ($ast->isa('Mal::Sequence')) { + return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); + } elsif ($ast->isa('Mal::HashMap')) { + return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); + } else { + return $ast; + } +} + +sub EVAL { + my($ast, $env) = @_; + + #print "EVAL: " . printer::_pr_str($ast) . "\n"; + if (! $ast->isa('Mal::List')) { + goto &eval_ast; + } + + # apply list + unless (@$ast) { return $ast; } + my ($a0) = @$ast; + given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { + when ('def!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, EVAL($val, $env)); + } + when ('let*') { + my (undef, $bindings, $body) = @$ast; + my $let_env = Mal::Env->new($env); + foreach my $pair (pairs @$bindings) { + my ($k, $v) = @$pair; + $let_env->set($k, EVAL($v, $let_env)); + } + @_ = ($body, $let_env); + goto &EVAL; + } + when ('quote') { + return $ast->[1]; + } + when ('quasiquoteexpand') { + return quasiquote($ast->[1]); + } + when ('quasiquote') { + @_ = (quasiquote($ast->[1]), $env); + goto &EVAL; + } + when ('do') { + my (undef, @todo) = @$ast; + my $last = pop @todo; + eval_ast(Mal::List->new(\@todo), $env); + @_ = ($last, $env); + goto &EVAL; + } + when ('if') { + my (undef, $if, $then, $else) = @$ast; + my $cond = EVAL($if, $env); + if ($cond eq $nil || $cond eq $false) { + @_ = ($else // $nil, $env); + } else { + @_ = ($then, $env); + } + goto &EVAL; + } + when ('fn*') { + my (undef, $params, $body) = @$ast; + return Mal::Function->new(sub { + #print "running fn*\n"; + @_ = ($body, Mal::Env->new($env, $params, \@_)); + goto &EVAL; + }); + } + default { + @_ = @{eval_ast($ast, $env)}; + my $f = shift; + goto &$f; + } + } +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +my $repl_env = Mal::Env->new(); +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), $repl_env)); +} + +# core.pl: defined using perl +foreach my $n (keys %core::ns) { + $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); +} +$repl_env->set(Mal::Symbol->new('eval'), + Mal::Function->new(sub { EVAL($_[0], $repl_env) })); +my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; +$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); + +# core.mal: defined using the language itself +REP(q[(def! not (fn* (a) (if a false true)))]); +REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); + shift @ARGV; +} +if (@ARGV) { + REP(qq[(load-file "$ARGV[0]")]); + exit 0; +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/step8_macros.pl b/impls/perl/step8_macros.pl index 727d2eec7f..368dd59d60 100644 --- a/impls/perl/step8_macros.pl +++ b/impls/perl/step8_macros.pl @@ -1,230 +1,230 @@ -use strict; -use warnings FATAL => "recursion"; -no if $] >= 5.018, warnings => "experimental::smartmatch"; -use feature qw(switch); -use File::Basename; -use lib dirname (__FILE__); - -use Data::Dumper; -use List::Util qw(pairs pairmap); -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use types qw($nil $true $false); -use reader; -use printer; -use env; -use core; - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub starts_with { - my ($ast, $sym) = @_; - return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym; -} -sub quasiquote_loop { - my ($ast) = @_; - my $res = Mal::List->new([]); - foreach my $elt (reverse @$ast) { - if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) { - $res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]); - } else { - $res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]); - } - } - return $res; -} -sub quasiquote { - my ($ast) = @_; - if ($ast->isa('Mal::Vector')) { - return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]); - } elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) { - return Mal::List->new([Mal::Symbol->new("quote"), $ast]); - } elsif (!$ast->isa('Mal::List')) { - return $ast; - } elsif (starts_with($ast, 'unquote')) { - return $ast->[1]; - } else { - return quasiquote_loop($ast); - } -} - -sub is_macro_call { - my ($ast, $env) = @_; - if ($ast->isa('Mal::List') && - $ast->[0]->isa("Mal::Symbol") && - $env->find($ast->[0])) { - my ($f) = $env->get($ast->[0]); - return $f->isa('Mal::Macro'); - } - return 0; -} - -sub macroexpand { - my ($ast, $env) = @_; - while (is_macro_call($ast, $env)) { - my @args = @$ast; - my $mac = $env->get(shift @args); - $ast = &$mac(@args); - } - return $ast; -} - - -sub eval_ast { - my($ast, $env) = @_; - if ($ast->isa('Mal::Symbol')) { - return $env->get($ast); - } elsif ($ast->isa('Mal::Sequence')) { - return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); - } elsif ($ast->isa('Mal::HashMap')) { - return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); - } else { - return $ast; - } -} - -sub EVAL { - my($ast, $env) = @_; - - #print "EVAL: " . printer::_pr_str($ast) . "\n"; - if (! $ast->isa('Mal::List')) { - goto &eval_ast; - } - @$ast or return $ast; - - # apply list - $ast = macroexpand($ast, $env); - if (! $ast->isa('Mal::List')) { - @_ = ($ast, $env); - goto &eval_ast; - } - - unless (@$ast) { return $ast; } - my ($a0) = @$ast; - given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { - when ('def!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, EVAL($val, $env)); - } - when ('let*') { - my (undef, $bindings, $body) = @$ast; - my $let_env = Mal::Env->new($env); - foreach my $pair (pairs @$bindings) { - my ($k, $v) = @$pair; - $let_env->set($k, EVAL($v, $let_env)); - } - @_ = ($body, $let_env); - goto &EVAL; - } - when ('quote') { - return $ast->[1]; - } - when ('quasiquoteexpand') { - return quasiquote($ast->[1]); - } - when ('quasiquote') { - @_ = (quasiquote($ast->[1]), $env); - goto &EVAL; - } - when ('defmacro!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, Mal::Macro->new(EVAL($val, $env)->clone)); - } - when ('macroexpand') { - @_ = ($ast->[1], $env); - goto ¯oexpand; - } - when ('do') { - my (undef, @todo) = @$ast; - my $last = pop @todo; - eval_ast(Mal::List->new(\@todo), $env); - @_ = ($last, $env); - goto &EVAL; - } - when ('if') { - my (undef, $if, $then, $else) = @$ast; - my $cond = EVAL($if, $env); - if ($cond eq $nil || $cond eq $false) { - @_ = ($else // $nil, $env); - } else { - @_ = ($then, $env); - } - goto &EVAL; - } - when ('fn*') { - my (undef, $params, $body) = @$ast; - return Mal::Function->new(sub { - #print "running fn*\n"; - @_ = ($body, Mal::Env->new($env, $params, \@_)); - goto &EVAL; - }); - } - default { - @_ = @{eval_ast($ast, $env)}; - my $f = shift; - goto &$f; - } - } -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -my $repl_env = Mal::Env->new(); -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), $repl_env)); -} - -# core.pl: defined using perl -foreach my $n (keys %core::ns) { - $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); -} -$repl_env->set(Mal::Symbol->new('eval'), - Mal::Function->new(sub { EVAL($_[0], $repl_env) })); -my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; -$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); - -# core.mal: defined using the language itself -REP(q[(def! not (fn* (a) (if a false true)))]); -REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); -REP(q[(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)))))))]); - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); - shift @ARGV; -} -if (@ARGV) { - REP(qq[(load-file "$ARGV[0]")]); - exit 0; -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings FATAL => "recursion"; +no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch); +use File::Basename; +use lib dirname (__FILE__); + +use Data::Dumper; +use List::Util qw(pairs pairmap); +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use types qw($nil $true $false); +use reader; +use printer; +use env; +use core; + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub starts_with { + my ($ast, $sym) = @_; + return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym; +} +sub quasiquote_loop { + my ($ast) = @_; + my $res = Mal::List->new([]); + foreach my $elt (reverse @$ast) { + if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) { + $res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]); + } else { + $res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]); + } + } + return $res; +} +sub quasiquote { + my ($ast) = @_; + if ($ast->isa('Mal::Vector')) { + return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]); + } elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) { + return Mal::List->new([Mal::Symbol->new("quote"), $ast]); + } elsif (!$ast->isa('Mal::List')) { + return $ast; + } elsif (starts_with($ast, 'unquote')) { + return $ast->[1]; + } else { + return quasiquote_loop($ast); + } +} + +sub is_macro_call { + my ($ast, $env) = @_; + if ($ast->isa('Mal::List') && + $ast->[0]->isa("Mal::Symbol") && + $env->find($ast->[0])) { + my ($f) = $env->get($ast->[0]); + return $f->isa('Mal::Macro'); + } + return 0; +} + +sub macroexpand { + my ($ast, $env) = @_; + while (is_macro_call($ast, $env)) { + my @args = @$ast; + my $mac = $env->get(shift @args); + $ast = &$mac(@args); + } + return $ast; +} + + +sub eval_ast { + my($ast, $env) = @_; + if ($ast->isa('Mal::Symbol')) { + return $env->get($ast); + } elsif ($ast->isa('Mal::Sequence')) { + return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); + } elsif ($ast->isa('Mal::HashMap')) { + return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); + } else { + return $ast; + } +} + +sub EVAL { + my($ast, $env) = @_; + + #print "EVAL: " . printer::_pr_str($ast) . "\n"; + if (! $ast->isa('Mal::List')) { + goto &eval_ast; + } + @$ast or return $ast; + + # apply list + $ast = macroexpand($ast, $env); + if (! $ast->isa('Mal::List')) { + @_ = ($ast, $env); + goto &eval_ast; + } + + unless (@$ast) { return $ast; } + my ($a0) = @$ast; + given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { + when ('def!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, EVAL($val, $env)); + } + when ('let*') { + my (undef, $bindings, $body) = @$ast; + my $let_env = Mal::Env->new($env); + foreach my $pair (pairs @$bindings) { + my ($k, $v) = @$pair; + $let_env->set($k, EVAL($v, $let_env)); + } + @_ = ($body, $let_env); + goto &EVAL; + } + when ('quote') { + return $ast->[1]; + } + when ('quasiquoteexpand') { + return quasiquote($ast->[1]); + } + when ('quasiquote') { + @_ = (quasiquote($ast->[1]), $env); + goto &EVAL; + } + when ('defmacro!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, Mal::Macro->new(EVAL($val, $env)->clone)); + } + when ('macroexpand') { + @_ = ($ast->[1], $env); + goto ¯oexpand; + } + when ('do') { + my (undef, @todo) = @$ast; + my $last = pop @todo; + eval_ast(Mal::List->new(\@todo), $env); + @_ = ($last, $env); + goto &EVAL; + } + when ('if') { + my (undef, $if, $then, $else) = @$ast; + my $cond = EVAL($if, $env); + if ($cond eq $nil || $cond eq $false) { + @_ = ($else // $nil, $env); + } else { + @_ = ($then, $env); + } + goto &EVAL; + } + when ('fn*') { + my (undef, $params, $body) = @$ast; + return Mal::Function->new(sub { + #print "running fn*\n"; + @_ = ($body, Mal::Env->new($env, $params, \@_)); + goto &EVAL; + }); + } + default { + @_ = @{eval_ast($ast, $env)}; + my $f = shift; + goto &$f; + } + } +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +my $repl_env = Mal::Env->new(); +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), $repl_env)); +} + +# core.pl: defined using perl +foreach my $n (keys %core::ns) { + $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); +} +$repl_env->set(Mal::Symbol->new('eval'), + Mal::Function->new(sub { EVAL($_[0], $repl_env) })); +my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; +$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); + +# core.mal: defined using the language itself +REP(q[(def! not (fn* (a) (if a false true)))]); +REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); +REP(q[(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)))))))]); + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); + shift @ARGV; +} +if (@ARGV) { + REP(qq[(load-file "$ARGV[0]")]); + exit 0; +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/step9_try.pl b/impls/perl/step9_try.pl index dd1ca1430c..86dbe0b92a 100644 --- a/impls/perl/step9_try.pl +++ b/impls/perl/step9_try.pl @@ -1,254 +1,254 @@ -use strict; -use warnings FATAL => "recursion"; -no if $] >= 5.018, warnings => "experimental::smartmatch"; -use feature qw(switch); -use File::Basename; -use lib dirname (__FILE__); - -use Data::Dumper; -use List::Util qw(pairs pairmap); -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use types qw($nil $true $false); -use reader; -use printer; -use env; -use core; -use interop qw(pl_to_mal); - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub starts_with { - my ($ast, $sym) = @_; - return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym; -} -sub quasiquote_loop { - my ($ast) = @_; - my $res = Mal::List->new([]); - foreach my $elt (reverse @$ast) { - if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) { - $res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]); - } else { - $res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]); - } - } - return $res; -} -sub quasiquote { - my ($ast) = @_; - if ($ast->isa('Mal::Vector')) { - return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]); - } elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) { - return Mal::List->new([Mal::Symbol->new("quote"), $ast]); - } elsif (!$ast->isa('Mal::List')) { - return $ast; - } elsif (starts_with($ast, 'unquote')) { - return $ast->[1]; - } else { - return quasiquote_loop($ast); - } -} - -sub is_macro_call { - my ($ast, $env) = @_; - if ($ast->isa('Mal::List') && - $ast->[0]->isa('Mal::Symbol') && - $env->find($ast->[0])) { - my ($f) = $env->get($ast->[0]); - return $f->isa('Mal::Macro'); - } - return 0; -} - -sub macroexpand { - my ($ast, $env) = @_; - while (is_macro_call($ast, $env)) { - my @args = @$ast; - my $mac = $env->get(shift @args); - $ast = &$mac(@args); - } - return $ast; -} - - -sub eval_ast { - my($ast, $env) = @_; - if ($ast->isa('Mal::Symbol')) { - return $env->get($ast); - } elsif ($ast->isa('Mal::Sequence')) { - return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); - } elsif ($ast->isa('Mal::HashMap')) { - return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); - } else { - return $ast; - } -} - -sub EVAL { - my($ast, $env) = @_; - - #print "EVAL: " . printer::_pr_str($ast) . "\n"; - if (! $ast->isa('Mal::List')) { - goto &eval_ast; - } - @$ast or return $ast; - - # apply list - $ast = macroexpand($ast, $env); - if (! $ast->isa('Mal::List')) { - @_ = ($ast, $env); - goto &eval_ast; - } - - unless (@$ast) { return $ast; } - my ($a0) = @$ast; - given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { - when ('def!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, EVAL($val, $env)); - } - when ('let*') { - my (undef, $bindings, $body) = @$ast; - my $let_env = Mal::Env->new($env); - foreach my $pair (pairs @$bindings) { - my ($k, $v) = @$pair; - $let_env->set($k, EVAL($v, $let_env)); - } - @_ = ($body, $let_env); - goto &EVAL; - } - when ('quote') { - return $ast->[1]; - } - when ('quasiquoteexpand') { - return quasiquote($ast->[1]); - } - when ('quasiquote') { - @_ = (quasiquote($ast->[1]), $env); - goto &EVAL; - } - when ('defmacro!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, Mal::Macro->new(EVAL($val, $env)->clone)); - } - when ('macroexpand') { - @_ = ($ast->[1], $env); - goto ¯oexpand; - } - when ('try*') { - my (undef, $try, $catch) = @$ast; - local $@; - my $ret = eval { EVAL($try, $env) }; - return $ret unless $@; - if ($catch && ${$catch->[0]} eq 'catch*') { - my (undef, $binding, $body) = @$catch; - my $exc; - if (defined(blessed $@) && $@->isa('Mal::Type')) { - $exc = $@; - } else { - chomp(my $msg = $@); - $exc = Mal::String->new($msg); - } - my $catch_env = Mal::Env->new($env, [$binding], [$exc]); - @_ = ($body, $catch_env); - goto &EVAL; - } else { - die $@; - } - } - when ('do') { - my (undef, @todo) = @$ast; - my $last = pop @todo; - eval_ast(Mal::List->new(\@todo), $env); - @_ = ($last, $env); - goto &EVAL; - } - when ('if') { - my (undef, $if, $then, $else) = @$ast; - my $cond = EVAL($if, $env); - if ($cond eq $nil || $cond eq $false) { - @_ = ($else // $nil, $env); - } else { - @_ = ($then, $env); - } - goto &EVAL; - } - when ('fn*') { - my (undef, $params, $body) = @$ast; - return Mal::Function->new(sub { - #print "running fn*\n"; - @_ = ($body, Mal::Env->new($env, $params, \@_)); - goto &EVAL; - }); - } - default { - @_ = @{eval_ast($ast, $env)}; - my $f = shift; - goto &$f; - } - } -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -my $repl_env = Mal::Env->new(); -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), $repl_env)); -} - -# core.pl: defined using perl -foreach my $n (keys %core::ns) { - $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); -} -$repl_env->set(Mal::Symbol->new('eval'), - Mal::Function->new(sub { EVAL($_[0], $repl_env) })); -my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; -$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); - -# core.mal: defined using the language itself -REP(q[(def! not (fn* (a) (if a false true)))]); -REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); -REP(q[(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)))))))]); - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); - shift @ARGV; -} -if (@ARGV) { - REP(qq[(load-file "$ARGV[0]")]); - exit 0; -} -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } elsif (defined(blessed $err) && $err->isa('Mal::Type')) { - print "Error: ".printer::_pr_str($err)."\n"; - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings FATAL => "recursion"; +no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch); +use File::Basename; +use lib dirname (__FILE__); + +use Data::Dumper; +use List::Util qw(pairs pairmap); +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use types qw($nil $true $false); +use reader; +use printer; +use env; +use core; +use interop qw(pl_to_mal); + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub starts_with { + my ($ast, $sym) = @_; + return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym; +} +sub quasiquote_loop { + my ($ast) = @_; + my $res = Mal::List->new([]); + foreach my $elt (reverse @$ast) { + if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) { + $res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]); + } else { + $res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]); + } + } + return $res; +} +sub quasiquote { + my ($ast) = @_; + if ($ast->isa('Mal::Vector')) { + return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]); + } elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) { + return Mal::List->new([Mal::Symbol->new("quote"), $ast]); + } elsif (!$ast->isa('Mal::List')) { + return $ast; + } elsif (starts_with($ast, 'unquote')) { + return $ast->[1]; + } else { + return quasiquote_loop($ast); + } +} + +sub is_macro_call { + my ($ast, $env) = @_; + if ($ast->isa('Mal::List') && + $ast->[0]->isa('Mal::Symbol') && + $env->find($ast->[0])) { + my ($f) = $env->get($ast->[0]); + return $f->isa('Mal::Macro'); + } + return 0; +} + +sub macroexpand { + my ($ast, $env) = @_; + while (is_macro_call($ast, $env)) { + my @args = @$ast; + my $mac = $env->get(shift @args); + $ast = &$mac(@args); + } + return $ast; +} + + +sub eval_ast { + my($ast, $env) = @_; + if ($ast->isa('Mal::Symbol')) { + return $env->get($ast); + } elsif ($ast->isa('Mal::Sequence')) { + return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); + } elsif ($ast->isa('Mal::HashMap')) { + return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); + } else { + return $ast; + } +} + +sub EVAL { + my($ast, $env) = @_; + + #print "EVAL: " . printer::_pr_str($ast) . "\n"; + if (! $ast->isa('Mal::List')) { + goto &eval_ast; + } + @$ast or return $ast; + + # apply list + $ast = macroexpand($ast, $env); + if (! $ast->isa('Mal::List')) { + @_ = ($ast, $env); + goto &eval_ast; + } + + unless (@$ast) { return $ast; } + my ($a0) = @$ast; + given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { + when ('def!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, EVAL($val, $env)); + } + when ('let*') { + my (undef, $bindings, $body) = @$ast; + my $let_env = Mal::Env->new($env); + foreach my $pair (pairs @$bindings) { + my ($k, $v) = @$pair; + $let_env->set($k, EVAL($v, $let_env)); + } + @_ = ($body, $let_env); + goto &EVAL; + } + when ('quote') { + return $ast->[1]; + } + when ('quasiquoteexpand') { + return quasiquote($ast->[1]); + } + when ('quasiquote') { + @_ = (quasiquote($ast->[1]), $env); + goto &EVAL; + } + when ('defmacro!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, Mal::Macro->new(EVAL($val, $env)->clone)); + } + when ('macroexpand') { + @_ = ($ast->[1], $env); + goto ¯oexpand; + } + when ('try*') { + my (undef, $try, $catch) = @$ast; + local $@; + my $ret = eval { EVAL($try, $env) }; + return $ret unless $@; + if ($catch && ${$catch->[0]} eq 'catch*') { + my (undef, $binding, $body) = @$catch; + my $exc; + if (defined(blessed $@) && $@->isa('Mal::Type')) { + $exc = $@; + } else { + chomp(my $msg = $@); + $exc = Mal::String->new($msg); + } + my $catch_env = Mal::Env->new($env, [$binding], [$exc]); + @_ = ($body, $catch_env); + goto &EVAL; + } else { + die $@; + } + } + when ('do') { + my (undef, @todo) = @$ast; + my $last = pop @todo; + eval_ast(Mal::List->new(\@todo), $env); + @_ = ($last, $env); + goto &EVAL; + } + when ('if') { + my (undef, $if, $then, $else) = @$ast; + my $cond = EVAL($if, $env); + if ($cond eq $nil || $cond eq $false) { + @_ = ($else // $nil, $env); + } else { + @_ = ($then, $env); + } + goto &EVAL; + } + when ('fn*') { + my (undef, $params, $body) = @$ast; + return Mal::Function->new(sub { + #print "running fn*\n"; + @_ = ($body, Mal::Env->new($env, $params, \@_)); + goto &EVAL; + }); + } + default { + @_ = @{eval_ast($ast, $env)}; + my $f = shift; + goto &$f; + } + } +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +my $repl_env = Mal::Env->new(); +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), $repl_env)); +} + +# core.pl: defined using perl +foreach my $n (keys %core::ns) { + $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); +} +$repl_env->set(Mal::Symbol->new('eval'), + Mal::Function->new(sub { EVAL($_[0], $repl_env) })); +my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; +$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); + +# core.mal: defined using the language itself +REP(q[(def! not (fn* (a) (if a false true)))]); +REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); +REP(q[(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)))))))]); + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); + shift @ARGV; +} +if (@ARGV) { + REP(qq[(load-file "$ARGV[0]")]); + exit 0; +} +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } elsif (defined(blessed $err) && $err->isa('Mal::Type')) { + print "Error: ".printer::_pr_str($err)."\n"; + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/stepA_mal.pl b/impls/perl/stepA_mal.pl index f62aa5a7d8..ae30fe2daf 100644 --- a/impls/perl/stepA_mal.pl +++ b/impls/perl/stepA_mal.pl @@ -1,255 +1,255 @@ -use strict; -use warnings FATAL => "recursion"; -no if $] >= 5.018, warnings => "experimental::smartmatch"; -use feature qw(switch); -use File::Basename; -use lib dirname (__FILE__); - -use Data::Dumper; -use List::Util qw(pairs pairmap); -use Scalar::Util qw(blessed); - -use readline qw(mal_readline set_rl_mode); -use types qw($nil $true $false); -use reader; -use printer; -use env; -use core; - -# read -sub READ { - my $str = shift; - return reader::read_str($str); -} - -# eval -sub starts_with { - my ($ast, $sym) = @_; - return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym; -} -sub quasiquote_loop { - my ($ast) = @_; - my $res = Mal::List->new([]); - foreach my $elt (reverse @$ast) { - if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) { - $res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]); - } else { - $res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]); - } - } - return $res; -} -sub quasiquote { - my ($ast) = @_; - if ($ast->isa('Mal::Vector')) { - return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]); - } elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) { - return Mal::List->new([Mal::Symbol->new("quote"), $ast]); - } elsif (!$ast->isa('Mal::List')) { - return $ast; - } elsif (starts_with($ast, 'unquote')) { - return $ast->[1]; - } else { - return quasiquote_loop($ast); - } -} - -sub is_macro_call { - my ($ast, $env) = @_; - if ($ast->isa('Mal::List') && - $ast->[0]->isa('Mal::Symbol') && - $env->find($ast->[0])) { - my ($f) = $env->get($ast->[0]); - return $f->isa('Mal::Macro'); - } - return 0; -} - -sub macroexpand { - my ($ast, $env) = @_; - while (is_macro_call($ast, $env)) { - my @args = @$ast; - my $mac = $env->get(shift @args); - $ast = &$mac(@args); - } - return $ast; -} - - -sub eval_ast { - my($ast, $env) = @_; - if ($ast->isa('Mal::Symbol')) { - return $env->get($ast); - } elsif ($ast->isa('Mal::Sequence')) { - return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); - } elsif ($ast->isa('Mal::HashMap')) { - return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); - } else { - return $ast; - } -} - -sub EVAL { - my($ast, $env) = @_; - - #print "EVAL: " . printer::_pr_str($ast) . "\n"; - if (! $ast->isa('Mal::List')) { - goto &eval_ast; - } - @$ast or return $ast; - - # apply list - $ast = macroexpand($ast, $env); - if (! $ast->isa('Mal::List')) { - @_ = ($ast, $env); - goto &eval_ast; - } - - unless (@$ast) { return $ast; } - my ($a0) = @$ast; - given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { - when ('def!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, EVAL($val, $env)); - } - when ('let*') { - my (undef, $bindings, $body) = @$ast; - my $let_env = Mal::Env->new($env); - foreach my $pair (pairs @$bindings) { - my ($k, $v) = @$pair; - $let_env->set($k, EVAL($v, $let_env)); - } - @_ = ($body, $let_env); - goto &EVAL; - } - when ('quote') { - return $ast->[1]; - } - when ('quasiquoteexpand') { - return quasiquote($ast->[1]); - } - when ('quasiquote') { - @_ = (quasiquote($ast->[1]), $env); - goto &EVAL; - } - when ('defmacro!') { - my (undef, $sym, $val) = @$ast; - return $env->set($sym, Mal::Macro->new(EVAL($val, $env)->clone)); - } - when ('macroexpand') { - @_ = ($ast->[1], $env); - goto ¯oexpand; - } - when ('try*') { - my (undef, $try, $catch) = @$ast; - local $@; - my $ret = eval { EVAL($try, $env) }; - return $ret unless $@; - if ($catch && ${$catch->[0]} eq 'catch*') { - my (undef, $binding, $body) = @$catch; - my $exc; - if (defined(blessed $@) && $@->isa('Mal::Type')) { - $exc = $@; - } else { - chomp(my $msg = $@); - $exc = Mal::String->new($msg); - } - my $catch_env = Mal::Env->new($env, [$binding], [$exc]); - @_ = ($body, $catch_env); - goto &EVAL; - } else { - die $@; - } - } - when ('do') { - my (undef, @todo) = @$ast; - my $last = pop @todo; - eval_ast(Mal::List->new(\@todo), $env); - @_ = ($last, $env); - goto &EVAL; - } - when ('if') { - my (undef, $if, $then, $else) = @$ast; - my $cond = EVAL($if, $env); - if ($cond eq $nil || $cond eq $false) { - @_ = ($else // $nil, $env); - } else { - @_ = ($then, $env); - } - goto &EVAL; - } - when ('fn*') { - my (undef, $params, $body) = @$ast; - return Mal::Function->new(sub { - #print "running fn*\n"; - @_ = ($body, Mal::Env->new($env, $params, \@_)); - goto &EVAL; - }); - } - default { - @_ = @{eval_ast($ast, $env)}; - my $f = shift; - goto &$f; - } - } -} - -# print -sub PRINT { - my $exp = shift; - return printer::_pr_str($exp); -} - -# repl -my $repl_env = Mal::Env->new(); -sub REP { - my $str = shift; - return PRINT(EVAL(READ($str), $repl_env)); -} - -# core.pl: defined using perl -foreach my $n (keys %core::ns) { - $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); -} -$repl_env->set(Mal::Symbol->new('eval'), - Mal::Function->new(sub { EVAL($_[0], $repl_env) })); -my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; -$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); - -# core.mal: defined using the language itself -REP(q[(def! *host-language* "perl")]); -REP(q[(def! not (fn* (a) (if a false true)))]); -REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); -REP(q[(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)))))))]); - -if (@ARGV && $ARGV[0] eq "--raw") { - set_rl_mode("raw"); - shift @ARGV; -} -if (@ARGV) { - REP(qq[(load-file "$ARGV[0]")]); - exit 0; -} -REP(q[(println (str "Mal [" *host-language* "]"))]); -while (1) { - my $line = mal_readline("user> "); - if (! defined $line) { last; } - do { - local $@; - my $ret; - eval { - print(REP($line), "\n"); - 1; - } or do { - my $err = $@; - if (defined(blessed $err) && $err->isa('Mal::BlankException')) { - # ignore and continue - } elsif (defined(blessed $err) && $err->isa('Mal::Type')) { - print "Error: ".printer::_pr_str($err)."\n"; - } else { - chomp $err; - print "Error: $err\n"; - } - }; - }; -} +use strict; +use warnings FATAL => "recursion"; +no if $] >= 5.018, warnings => "experimental::smartmatch"; +use feature qw(switch); +use File::Basename; +use lib dirname (__FILE__); + +use Data::Dumper; +use List::Util qw(pairs pairmap); +use Scalar::Util qw(blessed); + +use readline qw(mal_readline set_rl_mode); +use types qw($nil $true $false); +use reader; +use printer; +use env; +use core; + +# read +sub READ { + my $str = shift; + return reader::read_str($str); +} + +# eval +sub starts_with { + my ($ast, $sym) = @_; + return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym; +} +sub quasiquote_loop { + my ($ast) = @_; + my $res = Mal::List->new([]); + foreach my $elt (reverse @$ast) { + if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) { + $res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]); + } else { + $res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]); + } + } + return $res; +} +sub quasiquote { + my ($ast) = @_; + if ($ast->isa('Mal::Vector')) { + return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]); + } elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) { + return Mal::List->new([Mal::Symbol->new("quote"), $ast]); + } elsif (!$ast->isa('Mal::List')) { + return $ast; + } elsif (starts_with($ast, 'unquote')) { + return $ast->[1]; + } else { + return quasiquote_loop($ast); + } +} + +sub is_macro_call { + my ($ast, $env) = @_; + if ($ast->isa('Mal::List') && + $ast->[0]->isa('Mal::Symbol') && + $env->find($ast->[0])) { + my ($f) = $env->get($ast->[0]); + return $f->isa('Mal::Macro'); + } + return 0; +} + +sub macroexpand { + my ($ast, $env) = @_; + while (is_macro_call($ast, $env)) { + my @args = @$ast; + my $mac = $env->get(shift @args); + $ast = &$mac(@args); + } + return $ast; +} + + +sub eval_ast { + my($ast, $env) = @_; + if ($ast->isa('Mal::Symbol')) { + return $env->get($ast); + } elsif ($ast->isa('Mal::Sequence')) { + return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]); + } elsif ($ast->isa('Mal::HashMap')) { + return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast }); + } else { + return $ast; + } +} + +sub EVAL { + my($ast, $env) = @_; + + #print "EVAL: " . printer::_pr_str($ast) . "\n"; + if (! $ast->isa('Mal::List')) { + goto &eval_ast; + } + @$ast or return $ast; + + # apply list + $ast = macroexpand($ast, $env); + if (! $ast->isa('Mal::List')) { + @_ = ($ast, $env); + goto &eval_ast; + } + + unless (@$ast) { return $ast; } + my ($a0) = @$ast; + given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) { + when ('def!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, EVAL($val, $env)); + } + when ('let*') { + my (undef, $bindings, $body) = @$ast; + my $let_env = Mal::Env->new($env); + foreach my $pair (pairs @$bindings) { + my ($k, $v) = @$pair; + $let_env->set($k, EVAL($v, $let_env)); + } + @_ = ($body, $let_env); + goto &EVAL; + } + when ('quote') { + return $ast->[1]; + } + when ('quasiquoteexpand') { + return quasiquote($ast->[1]); + } + when ('quasiquote') { + @_ = (quasiquote($ast->[1]), $env); + goto &EVAL; + } + when ('defmacro!') { + my (undef, $sym, $val) = @$ast; + return $env->set($sym, Mal::Macro->new(EVAL($val, $env)->clone)); + } + when ('macroexpand') { + @_ = ($ast->[1], $env); + goto ¯oexpand; + } + when ('try*') { + my (undef, $try, $catch) = @$ast; + local $@; + my $ret = eval { EVAL($try, $env) }; + return $ret unless $@; + if ($catch && ${$catch->[0]} eq 'catch*') { + my (undef, $binding, $body) = @$catch; + my $exc; + if (defined(blessed $@) && $@->isa('Mal::Type')) { + $exc = $@; + } else { + chomp(my $msg = $@); + $exc = Mal::String->new($msg); + } + my $catch_env = Mal::Env->new($env, [$binding], [$exc]); + @_ = ($body, $catch_env); + goto &EVAL; + } else { + die $@; + } + } + when ('do') { + my (undef, @todo) = @$ast; + my $last = pop @todo; + eval_ast(Mal::List->new(\@todo), $env); + @_ = ($last, $env); + goto &EVAL; + } + when ('if') { + my (undef, $if, $then, $else) = @$ast; + my $cond = EVAL($if, $env); + if ($cond eq $nil || $cond eq $false) { + @_ = ($else // $nil, $env); + } else { + @_ = ($then, $env); + } + goto &EVAL; + } + when ('fn*') { + my (undef, $params, $body) = @$ast; + return Mal::Function->new(sub { + #print "running fn*\n"; + @_ = ($body, Mal::Env->new($env, $params, \@_)); + goto &EVAL; + }); + } + default { + @_ = @{eval_ast($ast, $env)}; + my $f = shift; + goto &$f; + } + } +} + +# print +sub PRINT { + my $exp = shift; + return printer::_pr_str($exp); +} + +# repl +my $repl_env = Mal::Env->new(); +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), $repl_env)); +} + +# core.pl: defined using perl +foreach my $n (keys %core::ns) { + $repl_env->set(Mal::Symbol->new($n), $core::ns{$n}); +} +$repl_env->set(Mal::Symbol->new('eval'), + Mal::Function->new(sub { EVAL($_[0], $repl_env) })); +my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV]; +$repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv)); + +# core.mal: defined using the language itself +REP(q[(def! *host-language* "perl")]); +REP(q[(def! not (fn* (a) (if a false true)))]); +REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]); +REP(q[(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)))))))]); + +if (@ARGV && $ARGV[0] eq "--raw") { + set_rl_mode("raw"); + shift @ARGV; +} +if (@ARGV) { + REP(qq[(load-file "$ARGV[0]")]); + exit 0; +} +REP(q[(println (str "Mal [" *host-language* "]"))]); +while (1) { + my $line = mal_readline("user> "); + if (! defined $line) { last; } + do { + local $@; + my $ret; + eval { + print(REP($line), "\n"); + 1; + } or do { + my $err = $@; + if (defined(blessed $err) && $err->isa('Mal::BlankException')) { + # ignore and continue + } elsif (defined(blessed $err) && $err->isa('Mal::Type')) { + print "Error: ".printer::_pr_str($err)."\n"; + } else { + chomp $err; + print "Error: $err\n"; + } + }; + }; +} diff --git a/impls/perl/tests/step5_tco.mal b/impls/perl/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/perl/tests/step5_tco.mal +++ b/impls/perl/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/perl/tests/stepA_mal.mal b/impls/perl/tests/stepA_mal.mal index 4d2b80c541..dd4d15b273 100644 --- a/impls/perl/tests/stepA_mal.mal +++ b/impls/perl/tests/stepA_mal.mal @@ -1,30 +1,30 @@ -;; Testing types returned from pl* - -(pl* "123") -;=>123 - -(pl* "\"abc\"") -;=>"abc" - -(pl* "{'abc'=>123}") -;=>{"abc" 123} - -(pl* "['abc', 123]") -;=>("abc" 123) - -(pl* "2+3") -;=>5 - -(pl* "undef") -;=>nil - -;; Testing eval of print statement - -(pl* "print 'hello\n';") -;/hello -;=>1 - -;; Testing exceptions passing through pl* - -(try* (pl* "die \"pop!\\n\"") (catch* e e)) -;=>"pop!" +;; Testing types returned from pl* + +(pl* "123") +;=>123 + +(pl* "\"abc\"") +;=>"abc" + +(pl* "{'abc'=>123}") +;=>{"abc" 123} + +(pl* "['abc', 123]") +;=>("abc" 123) + +(pl* "2+3") +;=>5 + +(pl* "undef") +;=>nil + +;; Testing eval of print statement + +(pl* "print 'hello\n';") +;/hello +;=>1 + +;; Testing exceptions passing through pl* + +(try* (pl* "die \"pop!\\n\"") (catch* e e)) +;=>"pop!" diff --git a/impls/perl/types.pm b/impls/perl/types.pm index 4418244523..6e7977650d 100644 --- a/impls/perl/types.pm +++ b/impls/perl/types.pm @@ -1,197 +1,197 @@ -package types; -use strict; -use warnings; - -use Data::Dumper; -use Exporter 'import'; -our @EXPORT_OK = qw(_equal_Q thaw_key - $nil $true $false); - -# General functions - -sub _equal_Q { - my ($a, $b) = @_; - unless ((ref $a eq ref $b) || - ($a->isa('Mal::Sequence') && $b->isa('Mal::Sequence'))) { - return 0; - } - if ($a->isa('Mal::Sequence')) { - unless (scalar(@$a) == scalar(@$b)) { - return 0; - } - for (my $i=0; $i[$i], $b->[$i])) { - return 0; - } - } - return 1; - } elsif ($a->isa('Mal::HashMap')) { - unless (scalar(keys %$a) == scalar(keys %$b)) { - return 0; - } - foreach my $k (keys %$a) { - unless (_equal_Q($a->{$k}, $b->{$k})) { - return 0; - } - } - return 1; - } else { - return $$a eq $$b; - } - return 0; -} - - -# Errors/Exceptions - -{ - package Mal::BlankException; - sub new { my $class = shift; bless Mal::String->new("Blank Line") => $class } -} - -# Superclass for all kinds of mal value - -{ - package Mal::Type; -} - -# Scalars - -{ - package Mal::Scalar; - use parent -norequire, 'Mal::Type'; - # Overload stringification so that its result is something - # suitable for use as a hash-map key. The important thing here is - # that strings and keywords are distinct: support for other kinds - # of scalar is a bonus. - use overload '""' => sub { my $self = shift; ref($self) . " " . $$self }, - fallback => 1; - sub new { my ($class, $value) = @_; bless \$value, $class } -} - -# This function converts hash-map keys back into full objects - -sub thaw_key ($) { - my ($class, $value) = split(/ /, $_[0], 2); - return $class->new($value); -} - -{ - package Mal::Nil; - use parent -norequire, 'Mal::Scalar'; - # Allow nil to be treated as an empty list or hash-map. - use overload '@{}' => sub { [] }, '%{}' => sub { {} }, fallback => 1; - sub rest { Mal::List->new([]) } -} -{ - package Mal::True; - use parent -norequire, 'Mal::Scalar'; -} -{ - package Mal::False; - use parent -norequire, 'Mal::Scalar'; -} - -our $nil = Mal::Nil->new('nil'); -our $true = Mal::True->new('true'); -our $false = Mal::False->new('false'); - - -{ - package Mal::Integer; - use parent -norequire, 'Mal::Scalar'; -} - - -{ - package Mal::Symbol; - use parent -norequire, 'Mal::Scalar'; -} - - -{ - package Mal::String; - use parent -norequire, 'Mal::Scalar'; -} - - -{ - package Mal::Keyword; - use parent -norequire, 'Mal::Scalar'; -} - - -# Sequences - -{ - package Mal::Sequence; - use parent -norequire, 'Mal::Type'; - sub new { my $class = shift; bless $_[0], $class } - sub rest { my $arr = $_[0]; Mal::List->new([@$arr[1..$#$arr]]); } - sub clone { my $self = shift; ref($self)->new([@$self]) } -} - -# Lists - -{ - package Mal::List; - use parent -norequire, 'Mal::Sequence'; -} - - -# Vectors - -{ - package Mal::Vector; - use parent -norequire, 'Mal::Sequence'; -} - - -# Hash-maps - -{ - package Mal::HashMap; - use parent -norequire, 'Mal::Type'; - use List::Util qw(pairmap); - use Scalar::Util qw(reftype); - sub new { - my ($class, $src) = @_; - if (reftype($src) eq 'ARRAY') { - $src = {@$src}; - } - return bless $src, $class; - } - sub clone { my $self = shift; ref($self)->new({%$self}) } -} - - -# Functions - -{ - package Mal::Callable; - use parent -norequire, 'Mal::Type'; - sub new { my $class = shift; bless $_[0], $class } - sub clone { my $self = shift; bless sub { goto &$self }, ref($self) } -} - -{ - package Mal::Function; - use parent -norequire, 'Mal::Callable'; -} - -{ - package Mal::Macro; - use parent -norequire, 'Mal::Callable'; -} - - -# Atoms - -{ - package Mal::Atom; - use parent -norequire, 'Mal::Type'; - sub new { my ($class, $val) = @_; bless \$val, $class } - sub clone { my $self = shift; ref($self)->new($$self) } -} - -1; +package types; +use strict; +use warnings; + +use Data::Dumper; +use Exporter 'import'; +our @EXPORT_OK = qw(_equal_Q thaw_key + $nil $true $false); + +# General functions + +sub _equal_Q { + my ($a, $b) = @_; + unless ((ref $a eq ref $b) || + ($a->isa('Mal::Sequence') && $b->isa('Mal::Sequence'))) { + return 0; + } + if ($a->isa('Mal::Sequence')) { + unless (scalar(@$a) == scalar(@$b)) { + return 0; + } + for (my $i=0; $i[$i], $b->[$i])) { + return 0; + } + } + return 1; + } elsif ($a->isa('Mal::HashMap')) { + unless (scalar(keys %$a) == scalar(keys %$b)) { + return 0; + } + foreach my $k (keys %$a) { + unless (_equal_Q($a->{$k}, $b->{$k})) { + return 0; + } + } + return 1; + } else { + return $$a eq $$b; + } + return 0; +} + + +# Errors/Exceptions + +{ + package Mal::BlankException; + sub new { my $class = shift; bless Mal::String->new("Blank Line") => $class } +} + +# Superclass for all kinds of mal value + +{ + package Mal::Type; +} + +# Scalars + +{ + package Mal::Scalar; + use parent -norequire, 'Mal::Type'; + # Overload stringification so that its result is something + # suitable for use as a hash-map key. The important thing here is + # that strings and keywords are distinct: support for other kinds + # of scalar is a bonus. + use overload '""' => sub { my $self = shift; ref($self) . " " . $$self }, + fallback => 1; + sub new { my ($class, $value) = @_; bless \$value, $class } +} + +# This function converts hash-map keys back into full objects + +sub thaw_key ($) { + my ($class, $value) = split(/ /, $_[0], 2); + return $class->new($value); +} + +{ + package Mal::Nil; + use parent -norequire, 'Mal::Scalar'; + # Allow nil to be treated as an empty list or hash-map. + use overload '@{}' => sub { [] }, '%{}' => sub { {} }, fallback => 1; + sub rest { Mal::List->new([]) } +} +{ + package Mal::True; + use parent -norequire, 'Mal::Scalar'; +} +{ + package Mal::False; + use parent -norequire, 'Mal::Scalar'; +} + +our $nil = Mal::Nil->new('nil'); +our $true = Mal::True->new('true'); +our $false = Mal::False->new('false'); + + +{ + package Mal::Integer; + use parent -norequire, 'Mal::Scalar'; +} + + +{ + package Mal::Symbol; + use parent -norequire, 'Mal::Scalar'; +} + + +{ + package Mal::String; + use parent -norequire, 'Mal::Scalar'; +} + + +{ + package Mal::Keyword; + use parent -norequire, 'Mal::Scalar'; +} + + +# Sequences + +{ + package Mal::Sequence; + use parent -norequire, 'Mal::Type'; + sub new { my $class = shift; bless $_[0], $class } + sub rest { my $arr = $_[0]; Mal::List->new([@$arr[1..$#$arr]]); } + sub clone { my $self = shift; ref($self)->new([@$self]) } +} + +# Lists + +{ + package Mal::List; + use parent -norequire, 'Mal::Sequence'; +} + + +# Vectors + +{ + package Mal::Vector; + use parent -norequire, 'Mal::Sequence'; +} + + +# Hash-maps + +{ + package Mal::HashMap; + use parent -norequire, 'Mal::Type'; + use List::Util qw(pairmap); + use Scalar::Util qw(reftype); + sub new { + my ($class, $src) = @_; + if (reftype($src) eq 'ARRAY') { + $src = {@$src}; + } + return bless $src, $class; + } + sub clone { my $self = shift; ref($self)->new({%$self}) } +} + + +# Functions + +{ + package Mal::Callable; + use parent -norequire, 'Mal::Type'; + sub new { my $class = shift; bless $_[0], $class } + sub clone { my $self = shift; bless sub { goto &$self }, ref($self) } +} + +{ + package Mal::Function; + use parent -norequire, 'Mal::Callable'; +} + +{ + package Mal::Macro; + use parent -norequire, 'Mal::Callable'; +} + + +# Atoms + +{ + package Mal::Atom; + use parent -norequire, 'Mal::Type'; + sub new { my ($class, $val) = @_; bless \$val, $class } + sub clone { my $self = shift; ref($self)->new($$self) } +} + +1; diff --git a/impls/perl6/Dockerfile b/impls/perl6/Dockerfile index ea081e882a..bd09347af3 100644 --- a/impls/perl6/Dockerfile +++ b/impls/perl6/Dockerfile @@ -1,34 +1,34 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Perl6 build deps -RUN apt-get -y install libfile-copy-recursive-perl build-essential git - -RUN curl -O http://rakudo.org/downloads/star/rakudo-star-2016.07.tar.gz && \ - tar xzf rakudo-star-2016.07.tar.gz && \ - cd rakudo-star-2016.07 && \ - perl Configure.pl --prefix=/usr --gen-moar --gen-nqp --backends=moar && \ - make && \ - make install && \ - cd .. && \ - rm -rf rakudo-star-2016.07* +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Perl6 build deps +RUN apt-get -y install libfile-copy-recursive-perl build-essential git + +RUN curl -O http://rakudo.org/downloads/star/rakudo-star-2016.07.tar.gz && \ + tar xzf rakudo-star-2016.07.tar.gz && \ + cd rakudo-star-2016.07 && \ + perl Configure.pl --prefix=/usr --gen-moar --gen-nqp --backends=moar && \ + make && \ + make install && \ + cd .. && \ + rm -rf rakudo-star-2016.07* diff --git a/impls/perl6/Makefile b/impls/perl6/Makefile index d2e469ecd4..919ca2d085 100644 --- a/impls/perl6/Makefile +++ b/impls/perl6/Makefile @@ -1,4 +1,4 @@ -all: - @true - -clean: +all: + @true + +clean: diff --git a/impls/perl6/core.pm b/impls/perl6/core.pm index f5cc5d1cc4..c2c8467c2a 100644 --- a/impls/perl6/core.pm +++ b/impls/perl6/core.pm @@ -1,105 +1,105 @@ -unit module core; -use types; -use printer; -use reader; - -sub equal ($a, $b) { - if $a ~~ MalSequence && $b ~~ MalSequence { - return $FALSE if $a.elems != $b.elems; - for |$a Z |$b -> ($a_el, $b_el) { - return $FALSE if equal($a_el, $b_el) ~~ $FALSE; - } - return $TRUE; - } - elsif $a ~~ MalHashMap && $b ~~ MalHashMap { - return $FALSE if $a.elems != $b.elems; - for $a.pairs { - return $FALSE if !$b{.key} || equal(.value, $b{.key}) ~~ $FALSE; - } - return $TRUE; - } - else { - return $a.^name eq $b.^name && $a.val ~~ $b.val ?? $TRUE !! $FALSE; - } -} - -sub perl6-eval ($code) { - my &convert = -> $data { - given $data { - when Array|List { MalList($_.map({&convert($_)}).Array) } - when Hash { MalHashMap($_.map({.key => &convert(.value)}).Hash) } - when Bool { $_ ?? $TRUE !! $FALSE } - when Int { MalNumber($_) } - when Nil { $NIL } - default { $_.^name eq 'Any' ?? $NIL !! MalString($_.gist) } - } - }; - - use MONKEY-SEE-NO-EVAL; - return &convert(EVAL($code)); -} - -our %ns = ( - '+' => MalCode({ MalNumber($^a.val + $^b.val) }), - '-' => MalCode({ MalNumber($^a.val - $^b.val) }), - '*' => MalCode({ MalNumber($^a.val * $^b.val) }), - '/' => MalCode({ MalNumber(($^a.val / $^b.val).Int) }), - '<' => MalCode({ $^a.val < $^b.val ?? $TRUE !! $FALSE }), - '<=' => MalCode({ $^a.val <= $^b.val ?? $TRUE !! $FALSE }), - '>' => MalCode({ $^a.val > $^b.val ?? $TRUE !! $FALSE }), - '>=' => MalCode({ $^a.val >= $^b.val ?? $TRUE !! $FALSE }), - '=' => MalCode({ equal($^a, $^b) }), - prn => MalCode({ say @_.map({ pr_str($_, True) }).join(' '); $NIL }), - println => MalCode({ say @_.map({ pr_str($_) }).join(' '); $NIL }), - pr-str => MalCode({ MalString(@_.map({ pr_str($_, True) }).join(' ') ) }), - str => MalCode({ MalString(@_.map({ pr_str($_) }).join) }), - read-string => MalCode({ read_str($^a.val) }), - slurp => MalCode({ MalString($^a.val.IO.slurp) }), - list => MalCode({ MalList(@_) }), - 'list?' => MalCode({ $^a ~~ MalList ?? $TRUE !! $FALSE }), - 'empty?' => MalCode({ $^a.elems ?? $FALSE !! $TRUE }), - count => MalCode({ MalNumber($^a ~~ $NIL ?? 0 !! $^a.elems) }), - atom => MalCode({ MalAtom($^a) }), - 'atom?' => MalCode({ $^a ~~ MalAtom ?? $TRUE !! $FALSE }), - deref => MalCode({ $^a.val }), - 'reset!' => MalCode({ $^a.val = $^b }), - 'swap!' => MalCode(-> $atom, $func, *@args { $atom.val = $func.apply($atom.val, |@args) }), - cons => MalCode({ MalList([$^a, |$^b.val]) }), - concat => MalCode({ MalList([@_.map({|$_.val})]) }), - vec => MalCode({ MalVector([|$^a.val]) }), - nth => MalCode({ $^a[$^b.val] // die X::MalOutOfRange.new }), - first => MalCode({ $^a[0] // $NIL }), - rest => MalCode({ MalList([$^a[1..*]]) }), - throw => MalCode({ die X::MalThrow.new(value => $^a) }), - apply => MalCode(-> $func, *@args { $func.apply(|@args[0..*-2], |@args[*-1].val) }), - map => MalCode(-> $func, $list { MalList([$list.map({ $func.apply($_) })]) }), - 'nil?' => MalCode({ $^a ~~ MalNil ?? $TRUE !! $FALSE }), - 'true?' => MalCode({ $^a ~~ MalTrue ?? $TRUE !! $FALSE }), - 'false?' => MalCode({ $^a ~~ MalFalse ?? $TRUE !! $FALSE }), - 'symbol?' => MalCode({ $^a ~~ MalSymbol ?? $TRUE !! $FALSE }), - symbol => MalCode({ MalSymbol($^a.val) }), - keyword => MalCode({ $^a.val ~~ /^\x29E/ ?? $^a !! MalString("\x29E" ~ $^a.val) }), - 'keyword?' => MalCode({ $^a.val ~~ /^\x29E/ ?? $TRUE !! $FALSE }), - 'number?' => MalCode({ $^a ~~ MalNumber ?? $TRUE !! $FALSE }), - 'fn?' => MalCode({ ($^a ~~ MalCallable && !$^a.?is_macro) ?? $TRUE !! $FALSE }), - 'macro?' => MalCode({ $^a.?is_macro ?? $TRUE !! $FALSE }), - vector => MalCode({ MalVector(@_) }), - 'vector?' => MalCode({ $^a ~~ MalVector ?? $TRUE !! $FALSE }), - hash-map => MalCode({ MalHashMap(@_.map({ $^a.val => $^b }).Hash) }), - 'map?' => MalCode({ $^a ~~ MalHashMap ?? $TRUE !! $FALSE }), - assoc => MalCode(-> $map, *@kv { MalHashMap(Hash.new(|$map.kv, |@kv.map({$^a.val, $^b}))) }), - dissoc => MalCode(-> $map, *@keys { my %h = $map.val.clone; %h{@keys.map(*.val)}:delete; MalHashMap(%h) }), - get => MalCode({ $^a.val{$^b.val} // $NIL }), - 'contains?' => MalCode({ $^a.val{$^b.val}:exists ?? $TRUE !! $FALSE }), - keys => MalCode({ MalList([$^a.keys.map({ MalString($_) })]) }), - vals => MalCode({ MalList([$^a.values]) }), - 'sequential?' => MalCode({ $^a ~~ MalList|MalVector ?? $TRUE !! $FALSE }), - readline => MalCode({ with prompt($^a.val) { MalString($_) } else { $NIL } }), - time-ms => MalCode({ MalNumber((now * 1000).Int) }), - conj => MalCode(-> $seq, *@args { $seq.conj(@args) }), - 'string?' => MalCode({ $^a ~~ MalString && $^a.val !~~ /^\x29E/ ?? $TRUE !! $FALSE }), - seq => MalCode({ $^a.seq }), - with-meta => MalCode({ return $NIL if !$^a.can('meta'); my $x = $^a.clone; $x.meta = $^b; $x }), - meta => MalCode({ $^a.?meta // $NIL }), - perl6-eval => MalCode({ perl6-eval($^a.val) }), -); +unit module core; +use types; +use printer; +use reader; + +sub equal ($a, $b) { + if $a ~~ MalSequence && $b ~~ MalSequence { + return $FALSE if $a.elems != $b.elems; + for |$a Z |$b -> ($a_el, $b_el) { + return $FALSE if equal($a_el, $b_el) ~~ $FALSE; + } + return $TRUE; + } + elsif $a ~~ MalHashMap && $b ~~ MalHashMap { + return $FALSE if $a.elems != $b.elems; + for $a.pairs { + return $FALSE if !$b{.key} || equal(.value, $b{.key}) ~~ $FALSE; + } + return $TRUE; + } + else { + return $a.^name eq $b.^name && $a.val ~~ $b.val ?? $TRUE !! $FALSE; + } +} + +sub perl6-eval ($code) { + my &convert = -> $data { + given $data { + when Array|List { MalList($_.map({&convert($_)}).Array) } + when Hash { MalHashMap($_.map({.key => &convert(.value)}).Hash) } + when Bool { $_ ?? $TRUE !! $FALSE } + when Int { MalNumber($_) } + when Nil { $NIL } + default { $_.^name eq 'Any' ?? $NIL !! MalString($_.gist) } + } + }; + + use MONKEY-SEE-NO-EVAL; + return &convert(EVAL($code)); +} + +our %ns = ( + '+' => MalCode({ MalNumber($^a.val + $^b.val) }), + '-' => MalCode({ MalNumber($^a.val - $^b.val) }), + '*' => MalCode({ MalNumber($^a.val * $^b.val) }), + '/' => MalCode({ MalNumber(($^a.val / $^b.val).Int) }), + '<' => MalCode({ $^a.val < $^b.val ?? $TRUE !! $FALSE }), + '<=' => MalCode({ $^a.val <= $^b.val ?? $TRUE !! $FALSE }), + '>' => MalCode({ $^a.val > $^b.val ?? $TRUE !! $FALSE }), + '>=' => MalCode({ $^a.val >= $^b.val ?? $TRUE !! $FALSE }), + '=' => MalCode({ equal($^a, $^b) }), + prn => MalCode({ say @_.map({ pr_str($_, True) }).join(' '); $NIL }), + println => MalCode({ say @_.map({ pr_str($_) }).join(' '); $NIL }), + pr-str => MalCode({ MalString(@_.map({ pr_str($_, True) }).join(' ') ) }), + str => MalCode({ MalString(@_.map({ pr_str($_) }).join) }), + read-string => MalCode({ read_str($^a.val) }), + slurp => MalCode({ MalString($^a.val.IO.slurp) }), + list => MalCode({ MalList(@_) }), + 'list?' => MalCode({ $^a ~~ MalList ?? $TRUE !! $FALSE }), + 'empty?' => MalCode({ $^a.elems ?? $FALSE !! $TRUE }), + count => MalCode({ MalNumber($^a ~~ $NIL ?? 0 !! $^a.elems) }), + atom => MalCode({ MalAtom($^a) }), + 'atom?' => MalCode({ $^a ~~ MalAtom ?? $TRUE !! $FALSE }), + deref => MalCode({ $^a.val }), + 'reset!' => MalCode({ $^a.val = $^b }), + 'swap!' => MalCode(-> $atom, $func, *@args { $atom.val = $func.apply($atom.val, |@args) }), + cons => MalCode({ MalList([$^a, |$^b.val]) }), + concat => MalCode({ MalList([@_.map({|$_.val})]) }), + vec => MalCode({ MalVector([|$^a.val]) }), + nth => MalCode({ $^a[$^b.val] // die X::MalOutOfRange.new }), + first => MalCode({ $^a[0] // $NIL }), + rest => MalCode({ MalList([$^a[1..*]]) }), + throw => MalCode({ die X::MalThrow.new(value => $^a) }), + apply => MalCode(-> $func, *@args { $func.apply(|@args[0..*-2], |@args[*-1].val) }), + map => MalCode(-> $func, $list { MalList([$list.map({ $func.apply($_) })]) }), + 'nil?' => MalCode({ $^a ~~ MalNil ?? $TRUE !! $FALSE }), + 'true?' => MalCode({ $^a ~~ MalTrue ?? $TRUE !! $FALSE }), + 'false?' => MalCode({ $^a ~~ MalFalse ?? $TRUE !! $FALSE }), + 'symbol?' => MalCode({ $^a ~~ MalSymbol ?? $TRUE !! $FALSE }), + symbol => MalCode({ MalSymbol($^a.val) }), + keyword => MalCode({ $^a.val ~~ /^\x29E/ ?? $^a !! MalString("\x29E" ~ $^a.val) }), + 'keyword?' => MalCode({ $^a.val ~~ /^\x29E/ ?? $TRUE !! $FALSE }), + 'number?' => MalCode({ $^a ~~ MalNumber ?? $TRUE !! $FALSE }), + 'fn?' => MalCode({ ($^a ~~ MalCallable && !$^a.?is_macro) ?? $TRUE !! $FALSE }), + 'macro?' => MalCode({ $^a.?is_macro ?? $TRUE !! $FALSE }), + vector => MalCode({ MalVector(@_) }), + 'vector?' => MalCode({ $^a ~~ MalVector ?? $TRUE !! $FALSE }), + hash-map => MalCode({ MalHashMap(@_.map({ $^a.val => $^b }).Hash) }), + 'map?' => MalCode({ $^a ~~ MalHashMap ?? $TRUE !! $FALSE }), + assoc => MalCode(-> $map, *@kv { MalHashMap(Hash.new(|$map.kv, |@kv.map({$^a.val, $^b}))) }), + dissoc => MalCode(-> $map, *@keys { my %h = $map.val.clone; %h{@keys.map(*.val)}:delete; MalHashMap(%h) }), + get => MalCode({ $^a.val{$^b.val} // $NIL }), + 'contains?' => MalCode({ $^a.val{$^b.val}:exists ?? $TRUE !! $FALSE }), + keys => MalCode({ MalList([$^a.keys.map({ MalString($_) })]) }), + vals => MalCode({ MalList([$^a.values]) }), + 'sequential?' => MalCode({ $^a ~~ MalList|MalVector ?? $TRUE !! $FALSE }), + readline => MalCode({ with prompt($^a.val) { MalString($_) } else { $NIL } }), + time-ms => MalCode({ MalNumber((now * 1000).Int) }), + conj => MalCode(-> $seq, *@args { $seq.conj(@args) }), + 'string?' => MalCode({ $^a ~~ MalString && $^a.val !~~ /^\x29E/ ?? $TRUE !! $FALSE }), + seq => MalCode({ $^a.seq }), + with-meta => MalCode({ return $NIL if !$^a.can('meta'); my $x = $^a.clone; $x.meta = $^b; $x }), + meta => MalCode({ $^a.?meta // $NIL }), + perl6-eval => MalCode({ perl6-eval($^a.val) }), +); diff --git a/impls/perl6/env.pm b/impls/perl6/env.pm index c0f483726c..ae98e30026 100644 --- a/impls/perl6/env.pm +++ b/impls/perl6/env.pm @@ -1,36 +1,36 @@ -unit class MalEnv; -use types; - -has $.outer; -has %.data; -has @.binds; -has @.exprs; - -method new ($outer?, @binds?, @exprs?) { - self.bless(:$outer, :@binds, :@exprs); -} - -submethod BUILD (:@!binds, :@!exprs, :$!outer, :%!data) { - for @!binds.kv -> $idx, $key { - if $key eq '&' { - my $value = MalList([@!exprs[$idx..*]]); - self.set(@!binds[$idx+1], $value); - last; - } - my $value = @!exprs[$idx]; - self.set($key, $value); - } -} - -method set ($key, $value) { - %.data{$key} = $value; -} - -method find ($key) { - return %.data{$key} ?? self !! $.outer && $.outer.find($key); -} - -method get ($key) { - my $env = self.find($key) or die X::MalNotFound.new(name => $key); - return $env.data{$key}; -} +unit class MalEnv; +use types; + +has $.outer; +has %.data; +has @.binds; +has @.exprs; + +method new ($outer?, @binds?, @exprs?) { + self.bless(:$outer, :@binds, :@exprs); +} + +submethod BUILD (:@!binds, :@!exprs, :$!outer, :%!data) { + for @!binds.kv -> $idx, $key { + if $key eq '&' { + my $value = MalList([@!exprs[$idx..*]]); + self.set(@!binds[$idx+1], $value); + last; + } + my $value = @!exprs[$idx]; + self.set($key, $value); + } +} + +method set ($key, $value) { + %.data{$key} = $value; +} + +method find ($key) { + return %.data{$key} ?? self !! $.outer && $.outer.find($key); +} + +method get ($key) { + my $env = self.find($key) or die X::MalNotFound.new(name => $key); + return $env.data{$key}; +} diff --git a/impls/perl6/printer.pm b/impls/perl6/printer.pm index 0872f860a3..7fdae12666 100644 --- a/impls/perl6/printer.pm +++ b/impls/perl6/printer.pm @@ -1,29 +1,29 @@ -unit module printer; -use types; - -sub pr_str ($exp, $print_readably = False) is export { - given $exp { - when MalFunction { "#" } - when MalCode { "#" } - when MalList { - '(' ~ join(' ', |$exp.map({ pr_str($_, $print_readably) })) ~ ')'; - } - when MalVector { - '[' ~ join(' ', |$exp.map({ pr_str($_, $print_readably) })) ~ ']'; - } - when MalHashMap { - '{' ~ $exp.kv.flatmap({ MalString($^a), $^b }).map({ pr_str($_, $print_readably) }) ~ '}' - } - when MalString { - my $str = $exp.val; - if $str ~~ s/^\x29E/:/ || !$print_readably { - $str; - } - else { - '"' ~ $str.trans(/\\/ => '\\\\', /\"/ => '\\"', /\n/ => '\\n') ~ '"'; - } - } - when MalAtom { "(atom {pr_str($exp.val, $print_readably)})" } - when MalValue { $exp.val } - } -} +unit module printer; +use types; + +sub pr_str ($exp, $print_readably = False) is export { + given $exp { + when MalFunction { "#" } + when MalCode { "#" } + when MalList { + '(' ~ join(' ', |$exp.map({ pr_str($_, $print_readably) })) ~ ')'; + } + when MalVector { + '[' ~ join(' ', |$exp.map({ pr_str($_, $print_readably) })) ~ ']'; + } + when MalHashMap { + '{' ~ $exp.kv.flatmap({ MalString($^a), $^b }).map({ pr_str($_, $print_readably) }) ~ '}' + } + when MalString { + my $str = $exp.val; + if $str ~~ s/^\x29E/:/ || !$print_readably { + $str; + } + else { + '"' ~ $str.trans(/\\/ => '\\\\', /\"/ => '\\"', /\n/ => '\\n') ~ '"'; + } + } + when MalAtom { "(atom {pr_str($exp.val, $print_readably)})" } + when MalValue { $exp.val } + } +} diff --git a/impls/perl6/reader.pm b/impls/perl6/reader.pm index 70d83a3447..9c48f08f3f 100644 --- a/impls/perl6/reader.pm +++ b/impls/perl6/reader.pm @@ -1,87 +1,87 @@ -unit module reader; -use types; - -class Reader { - has @.tokens; - has $!position = 0; - method peek { @.tokens[$!position] } - method next { @.tokens[$!position++] } -} - -sub read_form ($rdr) { - given $rdr.peek { - when "'" { $rdr.next; MalList([MalSymbol('quote'), read_form($rdr)]) } - when '`' { $rdr.next; MalList([MalSymbol('quasiquote'), read_form($rdr)]) } - when '~' { $rdr.next; MalList([MalSymbol('unquote'), read_form($rdr)]) } - when '~@' { $rdr.next; MalList([MalSymbol('splice-unquote'), read_form($rdr)]) } - when '@' { $rdr.next; MalList([MalSymbol('deref'), read_form($rdr)]) } - when '^' { - $rdr.next; - my $meta = read_form($rdr); - MalList([MalSymbol('with-meta'), read_form($rdr), $meta]); - } - when ')'|']'|'}' { die X::MalUnexpected.new(token => $_) } - when '(' { MalList(read_list($rdr, ')')) } - when '[' { MalVector(read_list($rdr, ']')) } - when '{' { MalHashMap(read_list($rdr, '}').map({ $^a.val => $^b }).Hash) } - default { read_atom($rdr) } - } -} - -sub read_list ($rdr, $end) { - my @list; - my $token = $rdr.next; - - loop { - $token = $rdr.peek; - die X::MalIncomplete.new(end => $end) if !$token.defined; - last if $token eq $end; - @list.push(read_form($rdr)); - } - $rdr.next; - - return @list; -} - -sub read_atom ($rdr) { - my $atom = $rdr.next; - given $atom { - when /^'"' [ \\. || <-[\"\\]> ]* '"'$/ { - s:g/^\"|\"$//; - MalString(.trans(/\\\"/ => '"', /\\n/ => "\n", /\\\\/ => '\\')); - } - when /^\"/ { - die X::MalIncomplete.new(end => '"'); - } - when /^\:(.*)/ { MalString("\x29E$0") } - when /^'-'? <[0..9]>+$/ { MalNumber($_) } - when 'nil' { $NIL } - when 'true' { $TRUE } - when 'false' { $FALSE } - default { MalSymbol($_) } - } -} - -my regex mal { - [ - <[\s,]>* # whitespace/commas - $=( - || '~@' # ~@ - || <[\[\]{}()'`~^@]> # special single-char tokens - || '"' [ \\. || <-[\"\\]> ]* '"'? # double-quoted strings - || ';'<-[\n]>* # comments - || <-[\s\[\]{}('"`,;)]>+ # symbols - ) - ]+ -} - -sub tokenizer ($str) { - return [] if !$str.match(/^/); - return grep { ! /^\;/ }, $.map({~$_}); -} - -sub read_str ($str) is export { - my @tokens = tokenizer($str); - die X::MalNoTokens.new if !@tokens; - return read_form(Reader.new(tokens => @tokens)); -} +unit module reader; +use types; + +class Reader { + has @.tokens; + has $!position = 0; + method peek { @.tokens[$!position] } + method next { @.tokens[$!position++] } +} + +sub read_form ($rdr) { + given $rdr.peek { + when "'" { $rdr.next; MalList([MalSymbol('quote'), read_form($rdr)]) } + when '`' { $rdr.next; MalList([MalSymbol('quasiquote'), read_form($rdr)]) } + when '~' { $rdr.next; MalList([MalSymbol('unquote'), read_form($rdr)]) } + when '~@' { $rdr.next; MalList([MalSymbol('splice-unquote'), read_form($rdr)]) } + when '@' { $rdr.next; MalList([MalSymbol('deref'), read_form($rdr)]) } + when '^' { + $rdr.next; + my $meta = read_form($rdr); + MalList([MalSymbol('with-meta'), read_form($rdr), $meta]); + } + when ')'|']'|'}' { die X::MalUnexpected.new(token => $_) } + when '(' { MalList(read_list($rdr, ')')) } + when '[' { MalVector(read_list($rdr, ']')) } + when '{' { MalHashMap(read_list($rdr, '}').map({ $^a.val => $^b }).Hash) } + default { read_atom($rdr) } + } +} + +sub read_list ($rdr, $end) { + my @list; + my $token = $rdr.next; + + loop { + $token = $rdr.peek; + die X::MalIncomplete.new(end => $end) if !$token.defined; + last if $token eq $end; + @list.push(read_form($rdr)); + } + $rdr.next; + + return @list; +} + +sub read_atom ($rdr) { + my $atom = $rdr.next; + given $atom { + when /^'"' [ \\. || <-[\"\\]> ]* '"'$/ { + s:g/^\"|\"$//; + MalString(.trans(/\\\"/ => '"', /\\n/ => "\n", /\\\\/ => '\\')); + } + when /^\"/ { + die X::MalIncomplete.new(end => '"'); + } + when /^\:(.*)/ { MalString("\x29E$0") } + when /^'-'? <[0..9]>+$/ { MalNumber($_) } + when 'nil' { $NIL } + when 'true' { $TRUE } + when 'false' { $FALSE } + default { MalSymbol($_) } + } +} + +my regex mal { + [ + <[\s,]>* # whitespace/commas + $=( + || '~@' # ~@ + || <[\[\]{}()'`~^@]> # special single-char tokens + || '"' [ \\. || <-[\"\\]> ]* '"'? # double-quoted strings + || ';'<-[\n]>* # comments + || <-[\s\[\]{}('"`,;)]>+ # symbols + ) + ]+ +} + +sub tokenizer ($str) { + return [] if !$str.match(/^/); + return grep { ! /^\;/ }, $.map({~$_}); +} + +sub read_str ($str) is export { + my @tokens = tokenizer($str); + die X::MalNoTokens.new if !@tokens; + return read_form(Reader.new(tokens => @tokens)); +} diff --git a/impls/perl6/run b/impls/perl6/run index d22ca7b7cf..61e9d0a9a7 100755 --- a/impls/perl6/run +++ b/impls/perl6/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec perl6 $(dirname $0)/${STEP:-stepA_mal}.pl "${@}" +#!/bin/bash +exec perl6 $(dirname $0)/${STEP:-stepA_mal}.pl "${@}" diff --git a/impls/perl6/step0_repl.pl b/impls/perl6/step0_repl.pl index b502b5835c..74b7a36f2f 100644 --- a/impls/perl6/step0_repl.pl +++ b/impls/perl6/step0_repl.pl @@ -1,27 +1,27 @@ -use v6; -#use Linenoise; - -sub read ($str) { - return $str; -} - -sub eval ($ast) { - return $ast; -} - -sub print ($exp) { - return $exp; -} - -sub rep ($str) { - return print(eval(read($str))); -} - -sub MAIN { - #while (my $line = linenoise('user> ')).defined { - # say rep($line); - #} - while (my $line = prompt 'user> ').defined { - say rep($line); - } -} +use v6; +#use Linenoise; + +sub read ($str) { + return $str; +} + +sub eval ($ast) { + return $ast; +} + +sub print ($exp) { + return $exp; +} + +sub rep ($str) { + return print(eval(read($str))); +} + +sub MAIN { + #while (my $line = linenoise('user> ')).defined { + # say rep($line); + #} + while (my $line = prompt 'user> ').defined { + say rep($line); + } +} diff --git a/impls/perl6/step1_read_print.pl b/impls/perl6/step1_read_print.pl index f8f6deb46e..6e533a239b 100644 --- a/impls/perl6/step1_read_print.pl +++ b/impls/perl6/step1_read_print.pl @@ -1,30 +1,30 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; - -sub read ($str) { - return read_str($str); -} - -sub eval ($ast) { - return $ast; -} - -sub print ($exp) { - return pr_str($exp, True); -} - -sub rep ($str) { - return print(eval(read($str))); -} - -sub MAIN { - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalException { .Str.say } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; + +sub read ($str) { + return read_str($str); +} + +sub eval ($ast) { + return $ast; +} + +sub print ($exp) { + return pr_str($exp, True); +} + +sub rep ($str) { + return print(eval(read($str))); +} + +sub MAIN { + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalException { .Str.say } + } + } +} diff --git a/impls/perl6/step2_eval.pl b/impls/perl6/step2_eval.pl index a2d010f91b..61054125c2 100644 --- a/impls/perl6/step2_eval.pl +++ b/impls/perl6/step2_eval.pl @@ -1,52 +1,52 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; - -sub read ($str) { - return read_str($str); -} - -sub eval_ast ($ast, $env) { - given $ast { - when MalSymbol { $env{$ast.val} || die X::MalNotFound.new(name => $ast.val) } - when MalList { MalList([$ast.map({ eval($_, $env) })]) } - when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } - when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } - default { $ast // $NIL } - } -} - -sub eval ($ast, $env) { - return eval_ast($ast, $env) if $ast !~~ MalList; - return $ast if !$ast.elems; - - my ($func, @args) = eval_ast($ast, $env).val; - my $arglist = MalList(@args); - return $func.apply($arglist); -} - -sub print ($exp) { - return pr_str($exp, True); -} - -my $repl_env; - -sub rep ($str) { - return print(eval(read($str), $repl_env)); -} - -sub MAIN { - $repl_env<+> = MalCode({ MalNumber($^a[0].val + $^a[1].val) }); - $repl_env<-> = MalCode({ MalNumber($^a[0].val - $^a[1].val) }); - $repl_env<*> = MalCode({ MalNumber($^a[0].val * $^a[1].val) }); - $repl_env = MalCode({ MalNumber(($^a[0].val / $^a[1].val).Int) }); - - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalException { .Str.say } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; + +sub read ($str) { + return read_str($str); +} + +sub eval_ast ($ast, $env) { + given $ast { + when MalSymbol { $env{$ast.val} || die X::MalNotFound.new(name => $ast.val) } + when MalList { MalList([$ast.map({ eval($_, $env) })]) } + when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } + when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } + default { $ast // $NIL } + } +} + +sub eval ($ast, $env) { + return eval_ast($ast, $env) if $ast !~~ MalList; + return $ast if !$ast.elems; + + my ($func, @args) = eval_ast($ast, $env).val; + my $arglist = MalList(@args); + return $func.apply($arglist); +} + +sub print ($exp) { + return pr_str($exp, True); +} + +my $repl_env; + +sub rep ($str) { + return print(eval(read($str), $repl_env)); +} + +sub MAIN { + $repl_env<+> = MalCode({ MalNumber($^a[0].val + $^a[1].val) }); + $repl_env<-> = MalCode({ MalNumber($^a[0].val - $^a[1].val) }); + $repl_env<*> = MalCode({ MalNumber($^a[0].val * $^a[1].val) }); + $repl_env = MalCode({ MalNumber(($^a[0].val / $^a[1].val).Int) }); + + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalException { .Str.say } + } + } +} diff --git a/impls/perl6/step3_env.pl b/impls/perl6/step3_env.pl index 2730211ced..b3ab2d5a61 100644 --- a/impls/perl6/step3_env.pl +++ b/impls/perl6/step3_env.pl @@ -1,67 +1,67 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; -use env; - -sub read ($str) { - return read_str($str); -} - -sub eval_ast ($ast, $env) { - given $ast { - when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } - when MalList { MalList([$ast.map({ eval($_, $env) })]) } - when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } - when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } - default { $ast // $NIL } - } -} - -sub eval ($ast, $env) { - return eval_ast($ast, $env) if $ast !~~ MalList; - return $ast if !$ast.elems; - - my ($a0, $a1, $a2, $a3) = $ast.val; - given $a0.val { - when 'def!' { - return $env.set($a1.val, eval($a2, $env)); - } - when 'let*' { - my $new_env = MalEnv.new($env); - for |$a1.val -> $key, $value { - $new_env.set($key.val, eval($value, $new_env)); - } - return eval($a2, $new_env); - } - default { - my ($func, @args) = eval_ast($ast, $env).val; - return $func.apply(|@args); - } - } -} - -sub print ($exp) { - return pr_str($exp, True); -} - -my $repl_env = MalEnv.new; - -sub rep ($str) { - return print(eval(read($str), $repl_env)); -} - -sub MAIN { - $repl_env.set('+', MalCode({ MalNumber($^a.val + $^b.val) })); - $repl_env.set('-', MalCode({ MalNumber($^a.val - $^b.val) })); - $repl_env.set('*', MalCode({ MalNumber($^a.val * $^b.val) })); - $repl_env.set('/', MalCode({ MalNumber(($^a.val / $^b.val).Int) })); - - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalException { .Str.say } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; +use env; + +sub read ($str) { + return read_str($str); +} + +sub eval_ast ($ast, $env) { + given $ast { + when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } + when MalList { MalList([$ast.map({ eval($_, $env) })]) } + when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } + when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } + default { $ast // $NIL } + } +} + +sub eval ($ast, $env) { + return eval_ast($ast, $env) if $ast !~~ MalList; + return $ast if !$ast.elems; + + my ($a0, $a1, $a2, $a3) = $ast.val; + given $a0.val { + when 'def!' { + return $env.set($a1.val, eval($a2, $env)); + } + when 'let*' { + my $new_env = MalEnv.new($env); + for |$a1.val -> $key, $value { + $new_env.set($key.val, eval($value, $new_env)); + } + return eval($a2, $new_env); + } + default { + my ($func, @args) = eval_ast($ast, $env).val; + return $func.apply(|@args); + } + } +} + +sub print ($exp) { + return pr_str($exp, True); +} + +my $repl_env = MalEnv.new; + +sub rep ($str) { + return print(eval(read($str), $repl_env)); +} + +sub MAIN { + $repl_env.set('+', MalCode({ MalNumber($^a.val + $^b.val) })); + $repl_env.set('-', MalCode({ MalNumber($^a.val - $^b.val) })); + $repl_env.set('*', MalCode({ MalNumber($^a.val * $^b.val) })); + $repl_env.set('/', MalCode({ MalNumber(($^a.val / $^b.val).Int) })); + + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalException { .Str.say } + } + } +} diff --git a/impls/perl6/step4_if_fn_do.pl b/impls/perl6/step4_if_fn_do.pl index 0aa8d61598..6179413d16 100644 --- a/impls/perl6/step4_if_fn_do.pl +++ b/impls/perl6/step4_if_fn_do.pl @@ -1,80 +1,80 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; -use env; -use core; - -sub read ($str) { - return read_str($str); -} - -sub eval_ast ($ast, $env) { - given $ast { - when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } - when MalList { MalList([$ast.map({ eval($_, $env) })]) } - when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } - when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } - default { $ast // $NIL } - } -} - -sub eval ($ast, $env) { - return eval_ast($ast, $env) if $ast !~~ MalList; - return $ast if !$ast.elems; - - my ($a0, $a1, $a2, $a3) = $ast.val; - given $a0.val { - when 'def!' { - return $env.set($a1.val, eval($a2, $env)); - } - when 'let*' { - my $new_env = MalEnv.new($env); - for |$a1.val -> $key, $value { - $new_env.set($key.val, eval($value, $new_env)); - } - return eval($a2, $new_env); - } - when 'do' { - return eval_ast(MalList([$ast[1..*]]), $env)[*-1]; - } - when 'if' { - return eval($a1, $env) !~~ MalNil|MalFalse - ?? return eval($a2, $env) - !! return $a3 ?? eval($a3, $env) !! $NIL; - } - when 'fn*' { - return MalCode(-> *@args { - my @binds = $a1 ?? $a1.map(*.val) !! (); - eval($a2, MalEnv.new($env, @binds, @args)); - }); - } - default { - my ($func, @args) = eval_ast($ast, $env).val; - return $func.apply(|@args); - } - } -} - -sub print ($exp) { - return pr_str($exp, True); -} - -my $repl_env = MalEnv.new; - -sub rep ($str) { - return print(eval(read($str), $repl_env)); -} - -sub MAIN { - $repl_env.set(.key, .value) for %core::ns; - rep(q{(def! not (fn* (a) (if a false true)))}); - - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalException { .Str.say } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; +use env; +use core; + +sub read ($str) { + return read_str($str); +} + +sub eval_ast ($ast, $env) { + given $ast { + when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } + when MalList { MalList([$ast.map({ eval($_, $env) })]) } + when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } + when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } + default { $ast // $NIL } + } +} + +sub eval ($ast, $env) { + return eval_ast($ast, $env) if $ast !~~ MalList; + return $ast if !$ast.elems; + + my ($a0, $a1, $a2, $a3) = $ast.val; + given $a0.val { + when 'def!' { + return $env.set($a1.val, eval($a2, $env)); + } + when 'let*' { + my $new_env = MalEnv.new($env); + for |$a1.val -> $key, $value { + $new_env.set($key.val, eval($value, $new_env)); + } + return eval($a2, $new_env); + } + when 'do' { + return eval_ast(MalList([$ast[1..*]]), $env)[*-1]; + } + when 'if' { + return eval($a1, $env) !~~ MalNil|MalFalse + ?? return eval($a2, $env) + !! return $a3 ?? eval($a3, $env) !! $NIL; + } + when 'fn*' { + return MalCode(-> *@args { + my @binds = $a1 ?? $a1.map(*.val) !! (); + eval($a2, MalEnv.new($env, @binds, @args)); + }); + } + default { + my ($func, @args) = eval_ast($ast, $env).val; + return $func.apply(|@args); + } + } +} + +sub print ($exp) { + return pr_str($exp, True); +} + +my $repl_env = MalEnv.new; + +sub rep ($str) { + return print(eval(read($str), $repl_env)); +} + +sub MAIN { + $repl_env.set(.key, .value) for %core::ns; + rep(q{(def! not (fn* (a) (if a false true)))}); + + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalException { .Str.say } + } + } +} diff --git a/impls/perl6/step5_tco.pl b/impls/perl6/step5_tco.pl index 7e7cbb7eed..ddf88a4805 100644 --- a/impls/perl6/step5_tco.pl +++ b/impls/perl6/step5_tco.pl @@ -1,91 +1,91 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; -use env; -use core; - -sub read ($str) { - return read_str($str); -} - -sub eval_ast ($ast, $env) { - given $ast { - when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } - when MalList { MalList([$ast.map({ eval($_, $env) })]) } - when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } - when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } - default { $ast // $NIL } - } -} - -sub eval ($ast is copy, $env is copy) { - loop { - return eval_ast($ast, $env) if $ast !~~ MalList; - return $ast if !$ast.elems; - - my ($a0, $a1, $a2, $a3) = $ast.val; - given $a0.val { - when 'def!' { - return $env.set($a1.val, eval($a2, $env)); - } - when 'let*' { - my $new_env = MalEnv.new($env); - for |$a1.val -> $key, $value { - $new_env.set($key.val, eval($value, $new_env)); - } - $env = $new_env; - $ast = $a2; - } - when 'do' { - eval_ast(MalList([$ast[1..*-2]]), $env); - $ast = $ast[*-1]; - } - when 'if' { - if eval($a1, $env) ~~ MalNil|MalFalse { - return $NIL if $a3 ~~ $NIL; - $ast = $a3; - } - else { - $ast = $a2; - } - } - when 'fn*' { - my @binds = $a1 ?? $a1.map(*.val) !! (); - my &fn = -> *@args { - eval($a2, MalEnv.new($env, @binds, @args)); - }; - return MalFunction($a2, $env, @binds, &fn); - } - default { - my ($func, @args) = eval_ast($ast, $env).val; - return $func.apply(|@args) if $func !~~ MalFunction; - $ast = $func.ast; - $env = MalEnv.new($func.env, $func.params, @args); - } - } - } -} - -sub print ($exp) { - return pr_str($exp, True); -} - -my $repl_env = MalEnv.new; - -sub rep ($str) { - return print(eval(read($str), $repl_env)); -} - -sub MAIN { - $repl_env.set(.key, .value) for %core::ns; - rep(q{(def! not (fn* (a) (if a false true)))}); - - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalException { .Str.say } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; +use env; +use core; + +sub read ($str) { + return read_str($str); +} + +sub eval_ast ($ast, $env) { + given $ast { + when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } + when MalList { MalList([$ast.map({ eval($_, $env) })]) } + when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } + when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } + default { $ast // $NIL } + } +} + +sub eval ($ast is copy, $env is copy) { + loop { + return eval_ast($ast, $env) if $ast !~~ MalList; + return $ast if !$ast.elems; + + my ($a0, $a1, $a2, $a3) = $ast.val; + given $a0.val { + when 'def!' { + return $env.set($a1.val, eval($a2, $env)); + } + when 'let*' { + my $new_env = MalEnv.new($env); + for |$a1.val -> $key, $value { + $new_env.set($key.val, eval($value, $new_env)); + } + $env = $new_env; + $ast = $a2; + } + when 'do' { + eval_ast(MalList([$ast[1..*-2]]), $env); + $ast = $ast[*-1]; + } + when 'if' { + if eval($a1, $env) ~~ MalNil|MalFalse { + return $NIL if $a3 ~~ $NIL; + $ast = $a3; + } + else { + $ast = $a2; + } + } + when 'fn*' { + my @binds = $a1 ?? $a1.map(*.val) !! (); + my &fn = -> *@args { + eval($a2, MalEnv.new($env, @binds, @args)); + }; + return MalFunction($a2, $env, @binds, &fn); + } + default { + my ($func, @args) = eval_ast($ast, $env).val; + return $func.apply(|@args) if $func !~~ MalFunction; + $ast = $func.ast; + $env = MalEnv.new($func.env, $func.params, @args); + } + } + } +} + +sub print ($exp) { + return pr_str($exp, True); +} + +my $repl_env = MalEnv.new; + +sub rep ($str) { + return print(eval(read($str), $repl_env)); +} + +sub MAIN { + $repl_env.set(.key, .value) for %core::ns; + rep(q{(def! not (fn* (a) (if a false true)))}); + + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalException { .Str.say } + } + } +} diff --git a/impls/perl6/step6_file.pl b/impls/perl6/step6_file.pl index 8d97c1754f..fb8e1d6e91 100644 --- a/impls/perl6/step6_file.pl +++ b/impls/perl6/step6_file.pl @@ -1,99 +1,99 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; -use env; -use core; - -sub read ($str) { - return read_str($str); -} - -sub eval_ast ($ast, $env) { - given $ast { - when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } - when MalList { MalList([$ast.map({ eval($_, $env) })]) } - when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } - when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } - default { $ast // $NIL } - } -} - -sub eval ($ast is copy, $env is copy) { - loop { - return eval_ast($ast, $env) if $ast !~~ MalList; - return $ast if !$ast.elems; - - my ($a0, $a1, $a2, $a3) = $ast.val; - given $a0.val { - when 'def!' { - return $env.set($a1.val, eval($a2, $env)); - } - when 'let*' { - my $new_env = MalEnv.new($env); - for |$a1.val -> $key, $value { - $new_env.set($key.val, eval($value, $new_env)); - } - $env = $new_env; - $ast = $a2; - } - when 'do' { - eval_ast(MalList([$ast[1..*-2]]), $env); - $ast = $ast[*-1]; - } - when 'if' { - if eval($a1, $env) ~~ MalNil|MalFalse { - return $NIL if $a3 ~~ $NIL; - $ast = $a3; - } - else { - $ast = $a2; - } - } - when 'fn*' { - my @binds = $a1 ?? $a1.map(*.val) !! (); - my &fn = -> *@args { - eval($a2, MalEnv.new($env, @binds, @args)); - }; - return MalFunction($a2, $env, @binds, &fn); - } - default { - my ($func, @args) = eval_ast($ast, $env).val; - return $func.apply(|@args) if $func !~~ MalFunction; - $ast = $func.ast; - $env = MalEnv.new($func.env, $func.params, @args); - } - } - } -} - -sub print ($exp) { - return pr_str($exp, True); -} - -my $repl_env = MalEnv.new; - -sub rep ($str) { - return print(eval(read($str), $repl_env)); -} - -sub MAIN ($source_file?, *@args) { - $repl_env.set(.key, .value) for %core::ns; - $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); - $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); - rep(q{(def! not (fn* (a) (if a false true)))}); - rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); - - if ($source_file.defined) { - rep("(load-file \"$source_file\")"); - exit; - } - - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalException { .Str.say } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; +use env; +use core; + +sub read ($str) { + return read_str($str); +} + +sub eval_ast ($ast, $env) { + given $ast { + when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } + when MalList { MalList([$ast.map({ eval($_, $env) })]) } + when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } + when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } + default { $ast // $NIL } + } +} + +sub eval ($ast is copy, $env is copy) { + loop { + return eval_ast($ast, $env) if $ast !~~ MalList; + return $ast if !$ast.elems; + + my ($a0, $a1, $a2, $a3) = $ast.val; + given $a0.val { + when 'def!' { + return $env.set($a1.val, eval($a2, $env)); + } + when 'let*' { + my $new_env = MalEnv.new($env); + for |$a1.val -> $key, $value { + $new_env.set($key.val, eval($value, $new_env)); + } + $env = $new_env; + $ast = $a2; + } + when 'do' { + eval_ast(MalList([$ast[1..*-2]]), $env); + $ast = $ast[*-1]; + } + when 'if' { + if eval($a1, $env) ~~ MalNil|MalFalse { + return $NIL if $a3 ~~ $NIL; + $ast = $a3; + } + else { + $ast = $a2; + } + } + when 'fn*' { + my @binds = $a1 ?? $a1.map(*.val) !! (); + my &fn = -> *@args { + eval($a2, MalEnv.new($env, @binds, @args)); + }; + return MalFunction($a2, $env, @binds, &fn); + } + default { + my ($func, @args) = eval_ast($ast, $env).val; + return $func.apply(|@args) if $func !~~ MalFunction; + $ast = $func.ast; + $env = MalEnv.new($func.env, $func.params, @args); + } + } + } +} + +sub print ($exp) { + return pr_str($exp, True); +} + +my $repl_env = MalEnv.new; + +sub rep ($str) { + return print(eval(read($str), $repl_env)); +} + +sub MAIN ($source_file?, *@args) { + $repl_env.set(.key, .value) for %core::ns; + $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); + $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); + rep(q{(def! not (fn* (a) (if a false true)))}); + rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); + + if ($source_file.defined) { + rep("(load-file \"$source_file\")"); + exit; + } + + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalException { .Str.say } + } + } +} diff --git a/impls/perl6/step7_quote.pl b/impls/perl6/step7_quote.pl index 8b8379f161..4c404c8104 100644 --- a/impls/perl6/step7_quote.pl +++ b/impls/perl6/step7_quote.pl @@ -1,132 +1,132 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; -use env; -use core; - -sub read ($str) { - return read_str($str); -} - -sub eval_ast ($ast, $env) { - given $ast { - when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } - when MalList { MalList([$ast.map({ eval($_, $env) })]) } - when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } - when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } - default { $ast // $NIL } - } -} - -sub qqLoop ($ast) { - my $acc = MalList([]); - for |$ast.val.reverse -> $elt { - if $elt ~~ MalList && $elt.elems == 2 && $elt[0] ~~ MalSymbol - && $elt[0].val eq 'splice-unquote' - { - $acc = MalList([MalSymbol('concat'), $elt[1], $acc]); - } - else { - $acc = MalList([MalSymbol('cons'), quasiquote($elt), $acc]); - } - } - return $acc; -} - -sub quasiquote ($ast) { - given $ast { - when MalList { - if $ast.elems == 2 && $ast[0] ~~ MalSymbol && $ast[0].val eq 'unquote' { - $ast[1] - } else { - qqLoop($ast); - } - } - when MalVector { MalList([MalSymbol('vec'), qqLoop($ast)]) } - when MalSymbol|MalHashMap { MalList([MalSymbol('quote'), $ast]) } - default { $ast } - } -} - -sub eval ($ast is copy, $env is copy) { - loop { - return eval_ast($ast, $env) if $ast !~~ MalList; - return $ast if !$ast.elems; - - my ($a0, $a1, $a2, $a3) = $ast.val; - given $a0.val { - when 'def!' { - return $env.set($a1.val, eval($a2, $env)); - } - when 'let*' { - my $new_env = MalEnv.new($env); - for |$a1.val -> $key, $value { - $new_env.set($key.val, eval($value, $new_env)); - } - $env = $new_env; - $ast = $a2; - } - when 'do' { - eval_ast(MalList([$ast[1..*-2]]), $env); - $ast = $ast[*-1]; - } - when 'if' { - if eval($a1, $env) ~~ MalNil|MalFalse { - return $NIL if $a3 ~~ $NIL; - $ast = $a3; - } - else { - $ast = $a2; - } - } - when 'fn*' { - my @binds = $a1 ?? $a1.map(*.val) !! (); - my &fn = -> *@args { - eval($a2, MalEnv.new($env, @binds, @args)); - }; - return MalFunction($a2, $env, @binds, &fn); - } - when 'quote' { return $a1 } - when 'quasiquoteexpand' { return quasiquote($a1) } - when 'quasiquote' { $ast = quasiquote($a1) } - default { - my ($func, @args) = eval_ast($ast, $env).val; - return $func.apply(|@args) if $func !~~ MalFunction; - $ast = $func.ast; - $env = MalEnv.new($func.env, $func.params, @args); - } - } - } -} - -sub print ($exp) { - return pr_str($exp, True); -} - -my $repl_env = MalEnv.new; - -sub rep ($str) { - return print(eval(read($str), $repl_env)); -} - -sub MAIN ($source_file?, *@args) { - $repl_env.set(.key, .value) for %core::ns; - $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); - $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); - rep(q{(def! not (fn* (a) (if a false true)))}); - rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); - - if ($source_file.defined) { - rep("(load-file \"$source_file\")"); - exit; - } - - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalException { .Str.say } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; +use env; +use core; + +sub read ($str) { + return read_str($str); +} + +sub eval_ast ($ast, $env) { + given $ast { + when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } + when MalList { MalList([$ast.map({ eval($_, $env) })]) } + when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } + when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } + default { $ast // $NIL } + } +} + +sub qqLoop ($ast) { + my $acc = MalList([]); + for |$ast.val.reverse -> $elt { + if $elt ~~ MalList && $elt.elems == 2 && $elt[0] ~~ MalSymbol + && $elt[0].val eq 'splice-unquote' + { + $acc = MalList([MalSymbol('concat'), $elt[1], $acc]); + } + else { + $acc = MalList([MalSymbol('cons'), quasiquote($elt), $acc]); + } + } + return $acc; +} + +sub quasiquote ($ast) { + given $ast { + when MalList { + if $ast.elems == 2 && $ast[0] ~~ MalSymbol && $ast[0].val eq 'unquote' { + $ast[1] + } else { + qqLoop($ast); + } + } + when MalVector { MalList([MalSymbol('vec'), qqLoop($ast)]) } + when MalSymbol|MalHashMap { MalList([MalSymbol('quote'), $ast]) } + default { $ast } + } +} + +sub eval ($ast is copy, $env is copy) { + loop { + return eval_ast($ast, $env) if $ast !~~ MalList; + return $ast if !$ast.elems; + + my ($a0, $a1, $a2, $a3) = $ast.val; + given $a0.val { + when 'def!' { + return $env.set($a1.val, eval($a2, $env)); + } + when 'let*' { + my $new_env = MalEnv.new($env); + for |$a1.val -> $key, $value { + $new_env.set($key.val, eval($value, $new_env)); + } + $env = $new_env; + $ast = $a2; + } + when 'do' { + eval_ast(MalList([$ast[1..*-2]]), $env); + $ast = $ast[*-1]; + } + when 'if' { + if eval($a1, $env) ~~ MalNil|MalFalse { + return $NIL if $a3 ~~ $NIL; + $ast = $a3; + } + else { + $ast = $a2; + } + } + when 'fn*' { + my @binds = $a1 ?? $a1.map(*.val) !! (); + my &fn = -> *@args { + eval($a2, MalEnv.new($env, @binds, @args)); + }; + return MalFunction($a2, $env, @binds, &fn); + } + when 'quote' { return $a1 } + when 'quasiquoteexpand' { return quasiquote($a1) } + when 'quasiquote' { $ast = quasiquote($a1) } + default { + my ($func, @args) = eval_ast($ast, $env).val; + return $func.apply(|@args) if $func !~~ MalFunction; + $ast = $func.ast; + $env = MalEnv.new($func.env, $func.params, @args); + } + } + } +} + +sub print ($exp) { + return pr_str($exp, True); +} + +my $repl_env = MalEnv.new; + +sub rep ($str) { + return print(eval(read($str), $repl_env)); +} + +sub MAIN ($source_file?, *@args) { + $repl_env.set(.key, .value) for %core::ns; + $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); + $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); + rep(q{(def! not (fn* (a) (if a false true)))}); + rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); + + if ($source_file.defined) { + rep("(load-file \"$source_file\")"); + exit; + } + + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalException { .Str.say } + } + } +} diff --git a/impls/perl6/step8_macros.pl b/impls/perl6/step8_macros.pl index 432d1d2e91..69057bdabc 100644 --- a/impls/perl6/step8_macros.pl +++ b/impls/perl6/step8_macros.pl @@ -1,155 +1,155 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; -use env; -use core; - -sub read ($str) { - return read_str($str); -} - -sub eval_ast ($ast, $env) { - given $ast { - when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } - when MalList { MalList([$ast.map({ eval($_, $env) })]) } - when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } - when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } - default { $ast // $NIL } - } -} - -sub qqLoop ($ast) { - my $acc = MalList([]); - for |$ast.val.reverse -> $elt { - if $elt ~~ MalList && $elt.elems == 2 && $elt[0] ~~ MalSymbol - && $elt[0].val eq 'splice-unquote' - { - $acc = MalList([MalSymbol('concat'), $elt[1], $acc]); - } - else { - $acc = MalList([MalSymbol('cons'), quasiquote($elt), $acc]); - } - } - return $acc; -} - -sub quasiquote ($ast) { - given $ast { - when MalList { - if $ast.elems == 2 && $ast[0] ~~ MalSymbol && $ast[0].val eq 'unquote' { - $ast[1] - } else { - qqLoop($ast); - } - } - when MalVector { MalList([MalSymbol('vec'), qqLoop($ast)]) } - when MalSymbol|MalHashMap { MalList([MalSymbol('quote'), $ast]) } - default { $ast } - } -} - -sub is_macro_call ($ast, $env) { - return so $ast ~~ MalList && $ast[0] ~~ MalSymbol - && $env.find($ast[0].val).?get($ast[0].val).?is_macro; -} - -sub macroexpand ($ast is copy, $env is copy) { - while is_macro_call($ast, $env) { - my $func = $env.get($ast[0].val); - $ast = $func.apply($ast[1..*]); - } - return $ast; -} - -sub eval ($ast is copy, $env is copy) { - loop { - return eval_ast($ast, $env) if $ast !~~ MalList; - $ast = macroexpand($ast, $env); - return eval_ast($ast, $env) if $ast !~~ MalList; - return $ast if !$ast.elems; - - my ($a0, $a1, $a2, $a3) = $ast.val; - given $a0.val { - when 'def!' { - return $env.set($a1.val, eval($a2, $env)); - } - when 'let*' { - my $new_env = MalEnv.new($env); - for |$a1.val -> $key, $value { - $new_env.set($key.val, eval($value, $new_env)); - } - $env = $new_env; - $ast = $a2; - } - when 'do' { - eval_ast(MalList([$ast[1..*-2]]), $env); - $ast = $ast[*-1]; - } - when 'if' { - if eval($a1, $env) ~~ MalNil|MalFalse { - return $NIL if $a3 ~~ $NIL; - $ast = $a3; - } - else { - $ast = $a2; - } - } - when 'fn*' { - my @binds = $a1 ?? $a1.map(*.val) !! (); - my &fn = -> *@args { - eval($a2, MalEnv.new($env, @binds, @args)); - }; - return MalFunction($a2, $env, @binds, &fn); - } - when 'quote' { return $a1 } - when 'quasiquoteexpand' { return quasiquote($a1) } - when 'quasiquote' { $ast = quasiquote($a1) } - when 'defmacro!' { - my $func = eval($a2, $env); - $func = MalFunction($func.ast, $func.env, $func.params, $func.fn); - $func.is_macro = True; - return $env.set($a1.val, $func); - } - when 'macroexpand' { return macroexpand($a1, $env) } - default { - my ($func, @args) = eval_ast($ast, $env).val; - return $func.apply(|@args) if $func !~~ MalFunction; - $ast = $func.ast; - $env = MalEnv.new($func.env, $func.params, @args); - } - } - } -} - -sub print ($exp) { - return pr_str($exp, True); -} - -my $repl_env = MalEnv.new; - -sub rep ($str) { - return print(eval(read($str), $repl_env)); -} - -sub MAIN ($source_file?, *@args) { - $repl_env.set(.key, .value) for %core::ns; - $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); - $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); - rep(q{(def! not (fn* (a) (if a false true)))}); - rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); - rep(q{(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)))))))}); - - if ($source_file.defined) { - rep("(load-file \"$source_file\")"); - exit; - } - - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalException { .Str.say } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; +use env; +use core; + +sub read ($str) { + return read_str($str); +} + +sub eval_ast ($ast, $env) { + given $ast { + when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } + when MalList { MalList([$ast.map({ eval($_, $env) })]) } + when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } + when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } + default { $ast // $NIL } + } +} + +sub qqLoop ($ast) { + my $acc = MalList([]); + for |$ast.val.reverse -> $elt { + if $elt ~~ MalList && $elt.elems == 2 && $elt[0] ~~ MalSymbol + && $elt[0].val eq 'splice-unquote' + { + $acc = MalList([MalSymbol('concat'), $elt[1], $acc]); + } + else { + $acc = MalList([MalSymbol('cons'), quasiquote($elt), $acc]); + } + } + return $acc; +} + +sub quasiquote ($ast) { + given $ast { + when MalList { + if $ast.elems == 2 && $ast[0] ~~ MalSymbol && $ast[0].val eq 'unquote' { + $ast[1] + } else { + qqLoop($ast); + } + } + when MalVector { MalList([MalSymbol('vec'), qqLoop($ast)]) } + when MalSymbol|MalHashMap { MalList([MalSymbol('quote'), $ast]) } + default { $ast } + } +} + +sub is_macro_call ($ast, $env) { + return so $ast ~~ MalList && $ast[0] ~~ MalSymbol + && $env.find($ast[0].val).?get($ast[0].val).?is_macro; +} + +sub macroexpand ($ast is copy, $env is copy) { + while is_macro_call($ast, $env) { + my $func = $env.get($ast[0].val); + $ast = $func.apply($ast[1..*]); + } + return $ast; +} + +sub eval ($ast is copy, $env is copy) { + loop { + return eval_ast($ast, $env) if $ast !~~ MalList; + $ast = macroexpand($ast, $env); + return eval_ast($ast, $env) if $ast !~~ MalList; + return $ast if !$ast.elems; + + my ($a0, $a1, $a2, $a3) = $ast.val; + given $a0.val { + when 'def!' { + return $env.set($a1.val, eval($a2, $env)); + } + when 'let*' { + my $new_env = MalEnv.new($env); + for |$a1.val -> $key, $value { + $new_env.set($key.val, eval($value, $new_env)); + } + $env = $new_env; + $ast = $a2; + } + when 'do' { + eval_ast(MalList([$ast[1..*-2]]), $env); + $ast = $ast[*-1]; + } + when 'if' { + if eval($a1, $env) ~~ MalNil|MalFalse { + return $NIL if $a3 ~~ $NIL; + $ast = $a3; + } + else { + $ast = $a2; + } + } + when 'fn*' { + my @binds = $a1 ?? $a1.map(*.val) !! (); + my &fn = -> *@args { + eval($a2, MalEnv.new($env, @binds, @args)); + }; + return MalFunction($a2, $env, @binds, &fn); + } + when 'quote' { return $a1 } + when 'quasiquoteexpand' { return quasiquote($a1) } + when 'quasiquote' { $ast = quasiquote($a1) } + when 'defmacro!' { + my $func = eval($a2, $env); + $func = MalFunction($func.ast, $func.env, $func.params, $func.fn); + $func.is_macro = True; + return $env.set($a1.val, $func); + } + when 'macroexpand' { return macroexpand($a1, $env) } + default { + my ($func, @args) = eval_ast($ast, $env).val; + return $func.apply(|@args) if $func !~~ MalFunction; + $ast = $func.ast; + $env = MalEnv.new($func.env, $func.params, @args); + } + } + } +} + +sub print ($exp) { + return pr_str($exp, True); +} + +my $repl_env = MalEnv.new; + +sub rep ($str) { + return print(eval(read($str), $repl_env)); +} + +sub MAIN ($source_file?, *@args) { + $repl_env.set(.key, .value) for %core::ns; + $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); + $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); + rep(q{(def! not (fn* (a) (if a false true)))}); + rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); + rep(q{(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)))))))}); + + if ($source_file.defined) { + rep("(load-file \"$source_file\")"); + exit; + } + + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalException { .Str.say } + } + } +} diff --git a/impls/perl6/step9_try.pl b/impls/perl6/step9_try.pl index bd77f2ca20..162f5ff3e6 100644 --- a/impls/perl6/step9_try.pl +++ b/impls/perl6/step9_try.pl @@ -1,166 +1,166 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; -use env; -use core; - -sub read ($str) { - return read_str($str); -} - -sub eval_ast ($ast, $env) { - given $ast { - when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } - when MalList { MalList([$ast.map({ eval($_, $env) })]) } - when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } - when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } - default { $ast // $NIL } - } -} - -sub qqLoop ($ast) { - my $acc = MalList([]); - for |$ast.val.reverse -> $elt { - if $elt ~~ MalList && $elt.elems == 2 && $elt[0] ~~ MalSymbol - && $elt[0].val eq 'splice-unquote' - { - $acc = MalList([MalSymbol('concat'), $elt[1], $acc]); - } - else { - $acc = MalList([MalSymbol('cons'), quasiquote($elt), $acc]); - } - } - return $acc; -} - -sub quasiquote ($ast) { - given $ast { - when MalList { - if $ast.elems == 2 && $ast[0] ~~ MalSymbol && $ast[0].val eq 'unquote' { - $ast[1] - } else { - qqLoop($ast); - } - } - when MalVector { MalList([MalSymbol('vec'), qqLoop($ast)]) } - when MalSymbol|MalHashMap { MalList([MalSymbol('quote'), $ast]) } - default { $ast } - } -} - -sub is_macro_call ($ast, $env) { - return so $ast ~~ MalList && $ast[0] ~~ MalSymbol - && $env.find($ast[0].val).?get($ast[0].val).?is_macro; -} - -sub macroexpand ($ast is copy, $env is copy) { - while is_macro_call($ast, $env) { - my $func = $env.get($ast[0].val); - $ast = $func.apply($ast[1..*]); - } - return $ast; -} - -sub eval ($ast is copy, $env is copy) { - loop { - return eval_ast($ast, $env) if $ast !~~ MalList; - $ast = macroexpand($ast, $env); - return eval_ast($ast, $env) if $ast !~~ MalList; - return $ast if !$ast.elems; - - my ($a0, $a1, $a2, $a3) = $ast.val; - given $a0.val { - when 'def!' { - return $env.set($a1.val, eval($a2, $env)); - } - when 'let*' { - my $new_env = MalEnv.new($env); - for |$a1.val -> $key, $value { - $new_env.set($key.val, eval($value, $new_env)); - } - $env = $new_env; - $ast = $a2; - } - when 'do' { - eval_ast(MalList([$ast[1..*-2]]), $env); - $ast = $ast[*-1]; - } - when 'if' { - if eval($a1, $env) ~~ MalNil|MalFalse { - return $NIL if $a3 ~~ $NIL; - $ast = $a3; - } - else { - $ast = $a2; - } - } - when 'fn*' { - my @binds = $a1 ?? $a1.map(*.val) !! (); - my &fn = -> *@args { - eval($a2, MalEnv.new($env, @binds, @args)); - }; - return MalFunction($a2, $env, @binds, &fn); - } - when 'quote' { return $a1 } - when 'quasiquoteexpand' { return quasiquote($a1) } - when 'quasiquote' { $ast = quasiquote($a1) } - when 'defmacro!' { - my $func = eval($a2, $env); - $func = MalFunction($func.ast, $func.env, $func.params, $func.fn); - $func.is_macro = True; - return $env.set($a1.val, $func); - } - when 'macroexpand' { return macroexpand($a1, $env) } - when 'try*' { - return eval($a1, $env); - CATCH { - .rethrow if !$a2; - my $ex = $_ ~~ X::MalThrow ?? .value !! MalString(.Str); - my $new_env = $env; - $env.set($a2[1].val, $ex); - return eval($a2[2], $new_env); - } - } - default { - my ($func, @args) = eval_ast($ast, $env).val; - return $func.apply(|@args) if $func !~~ MalFunction; - $ast = $func.ast; - $env = MalEnv.new($func.env, $func.params, @args); - } - } - } -} - -sub print ($exp) { - return pr_str($exp, True); -} - -my $repl_env = MalEnv.new; - -sub rep ($str) { - return print(eval(read($str), $repl_env)); -} - -sub MAIN ($source_file?, *@args) { - $repl_env.set(.key, .value) for %core::ns; - $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); - $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); - rep(q{(def! not (fn* (a) (if a false true)))}); - rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); - rep(q{(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)))))))}); - - if ($source_file.defined) { - rep("(load-file \"$source_file\")"); - exit; - } - - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalThrow { say "Error: " ~ pr_str(.value, True) } - when X::MalException { say "Error: " ~ .Str } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; +use env; +use core; + +sub read ($str) { + return read_str($str); +} + +sub eval_ast ($ast, $env) { + given $ast { + when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } + when MalList { MalList([$ast.map({ eval($_, $env) })]) } + when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } + when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } + default { $ast // $NIL } + } +} + +sub qqLoop ($ast) { + my $acc = MalList([]); + for |$ast.val.reverse -> $elt { + if $elt ~~ MalList && $elt.elems == 2 && $elt[0] ~~ MalSymbol + && $elt[0].val eq 'splice-unquote' + { + $acc = MalList([MalSymbol('concat'), $elt[1], $acc]); + } + else { + $acc = MalList([MalSymbol('cons'), quasiquote($elt), $acc]); + } + } + return $acc; +} + +sub quasiquote ($ast) { + given $ast { + when MalList { + if $ast.elems == 2 && $ast[0] ~~ MalSymbol && $ast[0].val eq 'unquote' { + $ast[1] + } else { + qqLoop($ast); + } + } + when MalVector { MalList([MalSymbol('vec'), qqLoop($ast)]) } + when MalSymbol|MalHashMap { MalList([MalSymbol('quote'), $ast]) } + default { $ast } + } +} + +sub is_macro_call ($ast, $env) { + return so $ast ~~ MalList && $ast[0] ~~ MalSymbol + && $env.find($ast[0].val).?get($ast[0].val).?is_macro; +} + +sub macroexpand ($ast is copy, $env is copy) { + while is_macro_call($ast, $env) { + my $func = $env.get($ast[0].val); + $ast = $func.apply($ast[1..*]); + } + return $ast; +} + +sub eval ($ast is copy, $env is copy) { + loop { + return eval_ast($ast, $env) if $ast !~~ MalList; + $ast = macroexpand($ast, $env); + return eval_ast($ast, $env) if $ast !~~ MalList; + return $ast if !$ast.elems; + + my ($a0, $a1, $a2, $a3) = $ast.val; + given $a0.val { + when 'def!' { + return $env.set($a1.val, eval($a2, $env)); + } + when 'let*' { + my $new_env = MalEnv.new($env); + for |$a1.val -> $key, $value { + $new_env.set($key.val, eval($value, $new_env)); + } + $env = $new_env; + $ast = $a2; + } + when 'do' { + eval_ast(MalList([$ast[1..*-2]]), $env); + $ast = $ast[*-1]; + } + when 'if' { + if eval($a1, $env) ~~ MalNil|MalFalse { + return $NIL if $a3 ~~ $NIL; + $ast = $a3; + } + else { + $ast = $a2; + } + } + when 'fn*' { + my @binds = $a1 ?? $a1.map(*.val) !! (); + my &fn = -> *@args { + eval($a2, MalEnv.new($env, @binds, @args)); + }; + return MalFunction($a2, $env, @binds, &fn); + } + when 'quote' { return $a1 } + when 'quasiquoteexpand' { return quasiquote($a1) } + when 'quasiquote' { $ast = quasiquote($a1) } + when 'defmacro!' { + my $func = eval($a2, $env); + $func = MalFunction($func.ast, $func.env, $func.params, $func.fn); + $func.is_macro = True; + return $env.set($a1.val, $func); + } + when 'macroexpand' { return macroexpand($a1, $env) } + when 'try*' { + return eval($a1, $env); + CATCH { + .rethrow if !$a2; + my $ex = $_ ~~ X::MalThrow ?? .value !! MalString(.Str); + my $new_env = $env; + $env.set($a2[1].val, $ex); + return eval($a2[2], $new_env); + } + } + default { + my ($func, @args) = eval_ast($ast, $env).val; + return $func.apply(|@args) if $func !~~ MalFunction; + $ast = $func.ast; + $env = MalEnv.new($func.env, $func.params, @args); + } + } + } +} + +sub print ($exp) { + return pr_str($exp, True); +} + +my $repl_env = MalEnv.new; + +sub rep ($str) { + return print(eval(read($str), $repl_env)); +} + +sub MAIN ($source_file?, *@args) { + $repl_env.set(.key, .value) for %core::ns; + $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); + $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); + rep(q{(def! not (fn* (a) (if a false true)))}); + rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); + rep(q{(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)))))))}); + + if ($source_file.defined) { + rep("(load-file \"$source_file\")"); + exit; + } + + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalThrow { say "Error: " ~ pr_str(.value, True) } + when X::MalException { say "Error: " ~ .Str } + } + } +} diff --git a/impls/perl6/stepA_mal.pl b/impls/perl6/stepA_mal.pl index e7beec30d9..a4560155dc 100644 --- a/impls/perl6/stepA_mal.pl +++ b/impls/perl6/stepA_mal.pl @@ -1,168 +1,168 @@ -use v6; -use lib IO::Path.new($?FILE).dirname; -use reader; -use printer; -use types; -use env; -use core; - -sub read ($str) { - return read_str($str); -} - -sub eval_ast ($ast, $env) { - given $ast { - when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } - when MalList { MalList([$ast.map({ eval($_, $env) })]) } - when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } - when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } - default { $ast // $NIL } - } -} - -sub qqLoop ($ast) { - my $acc = MalList([]); - for |$ast.val.reverse -> $elt { - if $elt ~~ MalList && $elt.elems == 2 && $elt[0] ~~ MalSymbol - && $elt[0].val eq 'splice-unquote' - { - $acc = MalList([MalSymbol('concat'), $elt[1], $acc]); - } - else { - $acc = MalList([MalSymbol('cons'), quasiquote($elt), $acc]); - } - } - return $acc; -} - -sub quasiquote ($ast) { - given $ast { - when MalList { - if $ast.elems == 2 && $ast[0] ~~ MalSymbol && $ast[0].val eq 'unquote' { - $ast[1] - } else { - qqLoop($ast); - } - } - when MalVector { MalList([MalSymbol('vec'), qqLoop($ast)]) } - when MalSymbol|MalHashMap { MalList([MalSymbol('quote'), $ast]) } - default { $ast } - } -} - -sub is_macro_call ($ast, $env) { - return so $ast ~~ MalList && $ast[0] ~~ MalSymbol - && $env.find($ast[0].val).?get($ast[0].val).?is_macro; -} - -sub macroexpand ($ast is copy, $env is copy) { - while is_macro_call($ast, $env) { - my $func = $env.get($ast[0].val); - $ast = $func.apply($ast[1..*]); - } - return $ast; -} - -sub eval ($ast is copy, $env is copy) { - loop { - return eval_ast($ast, $env) if $ast !~~ MalList; - $ast = macroexpand($ast, $env); - return eval_ast($ast, $env) if $ast !~~ MalList; - return $ast if !$ast.elems; - - my ($a0, $a1, $a2, $a3) = $ast.val; - given $a0.val { - when 'def!' { - return $env.set($a1.val, eval($a2, $env)); - } - when 'let*' { - my $new_env = MalEnv.new($env); - for |$a1.val -> $key, $value { - $new_env.set($key.val, eval($value, $new_env)); - } - $env = $new_env; - $ast = $a2; - } - when 'do' { - eval_ast(MalList([$ast[1..*-2]]), $env); - $ast = $ast[*-1]; - } - when 'if' { - if eval($a1, $env) ~~ MalNil|MalFalse { - return $NIL if $a3 ~~ $NIL; - $ast = $a3; - } - else { - $ast = $a2; - } - } - when 'fn*' { - my @binds = $a1 ?? $a1.map(*.val) !! (); - my &fn = -> *@args { - eval($a2, MalEnv.new($env, @binds, @args)); - }; - return MalFunction($a2, $env, @binds, &fn); - } - when 'quote' { return $a1 } - when 'quasiquoteexpand' { return quasiquote($a1) } - when 'quasiquote' { $ast = quasiquote($a1) } - when 'defmacro!' { - my $func = eval($a2, $env); - $func = MalFunction($func.ast, $func.env, $func.params, $func.fn); - $func.is_macro = True; - return $env.set($a1.val, $func); - } - when 'macroexpand' { return macroexpand($a1, $env) } - when 'try*' { - return eval($a1, $env); - CATCH { - .rethrow if !$a2; - my $ex = $_ ~~ X::MalThrow ?? .value !! MalString(.Str); - my $new_env = $env; - $env.set($a2[1].val, $ex); - return eval($a2[2], $new_env); - } - } - default { - my ($func, @args) = eval_ast($ast, $env).val; - return $func.apply(|@args) if $func !~~ MalFunction; - $ast = $func.ast; - $env = MalEnv.new($func.env, $func.params, @args); - } - } - } -} - -sub print ($exp) { - return pr_str($exp, True); -} - -my $repl_env = MalEnv.new; - -sub rep ($str) { - return print(eval(read($str), $repl_env)); -} - -sub MAIN ($source_file?, *@args) { - $repl_env.set(.key, .value) for %core::ns; - $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); - $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); - $repl_env.set('*host-language*', MalString('perl6')); - rep(q{(def! not (fn* (a) (if a false true)))}); - rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); - rep(q{(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)))))))}); - - if ($source_file.defined) { - rep("(load-file \"$source_file\")"); - exit; - } - rep(q{(println (str "Mal [" *host-language* "]"))}); - - while (my $line = prompt 'user> ').defined { - say rep($line); - CATCH { - when X::MalThrow { say "Error: " ~ pr_str(.value, True) } - when X::MalException { say "Error: " ~ .Str } - } - } -} +use v6; +use lib IO::Path.new($?FILE).dirname; +use reader; +use printer; +use types; +use env; +use core; + +sub read ($str) { + return read_str($str); +} + +sub eval_ast ($ast, $env) { + given $ast { + when MalSymbol { $env.get($ast.val) || die X::MalNotFound.new(name => $ast.val) } + when MalList { MalList([$ast.map({ eval($_, $env) })]) } + when MalVector { MalVector([$ast.map({ eval($_, $env) })]) } + when MalHashMap { MalHashMap($ast.kv.map({ $^a => eval($^b, $env) }).Hash) } + default { $ast // $NIL } + } +} + +sub qqLoop ($ast) { + my $acc = MalList([]); + for |$ast.val.reverse -> $elt { + if $elt ~~ MalList && $elt.elems == 2 && $elt[0] ~~ MalSymbol + && $elt[0].val eq 'splice-unquote' + { + $acc = MalList([MalSymbol('concat'), $elt[1], $acc]); + } + else { + $acc = MalList([MalSymbol('cons'), quasiquote($elt), $acc]); + } + } + return $acc; +} + +sub quasiquote ($ast) { + given $ast { + when MalList { + if $ast.elems == 2 && $ast[0] ~~ MalSymbol && $ast[0].val eq 'unquote' { + $ast[1] + } else { + qqLoop($ast); + } + } + when MalVector { MalList([MalSymbol('vec'), qqLoop($ast)]) } + when MalSymbol|MalHashMap { MalList([MalSymbol('quote'), $ast]) } + default { $ast } + } +} + +sub is_macro_call ($ast, $env) { + return so $ast ~~ MalList && $ast[0] ~~ MalSymbol + && $env.find($ast[0].val).?get($ast[0].val).?is_macro; +} + +sub macroexpand ($ast is copy, $env is copy) { + while is_macro_call($ast, $env) { + my $func = $env.get($ast[0].val); + $ast = $func.apply($ast[1..*]); + } + return $ast; +} + +sub eval ($ast is copy, $env is copy) { + loop { + return eval_ast($ast, $env) if $ast !~~ MalList; + $ast = macroexpand($ast, $env); + return eval_ast($ast, $env) if $ast !~~ MalList; + return $ast if !$ast.elems; + + my ($a0, $a1, $a2, $a3) = $ast.val; + given $a0.val { + when 'def!' { + return $env.set($a1.val, eval($a2, $env)); + } + when 'let*' { + my $new_env = MalEnv.new($env); + for |$a1.val -> $key, $value { + $new_env.set($key.val, eval($value, $new_env)); + } + $env = $new_env; + $ast = $a2; + } + when 'do' { + eval_ast(MalList([$ast[1..*-2]]), $env); + $ast = $ast[*-1]; + } + when 'if' { + if eval($a1, $env) ~~ MalNil|MalFalse { + return $NIL if $a3 ~~ $NIL; + $ast = $a3; + } + else { + $ast = $a2; + } + } + when 'fn*' { + my @binds = $a1 ?? $a1.map(*.val) !! (); + my &fn = -> *@args { + eval($a2, MalEnv.new($env, @binds, @args)); + }; + return MalFunction($a2, $env, @binds, &fn); + } + when 'quote' { return $a1 } + when 'quasiquoteexpand' { return quasiquote($a1) } + when 'quasiquote' { $ast = quasiquote($a1) } + when 'defmacro!' { + my $func = eval($a2, $env); + $func = MalFunction($func.ast, $func.env, $func.params, $func.fn); + $func.is_macro = True; + return $env.set($a1.val, $func); + } + when 'macroexpand' { return macroexpand($a1, $env) } + when 'try*' { + return eval($a1, $env); + CATCH { + .rethrow if !$a2; + my $ex = $_ ~~ X::MalThrow ?? .value !! MalString(.Str); + my $new_env = $env; + $env.set($a2[1].val, $ex); + return eval($a2[2], $new_env); + } + } + default { + my ($func, @args) = eval_ast($ast, $env).val; + return $func.apply(|@args) if $func !~~ MalFunction; + $ast = $func.ast; + $env = MalEnv.new($func.env, $func.params, @args); + } + } + } +} + +sub print ($exp) { + return pr_str($exp, True); +} + +my $repl_env = MalEnv.new; + +sub rep ($str) { + return print(eval(read($str), $repl_env)); +} + +sub MAIN ($source_file?, *@args) { + $repl_env.set(.key, .value) for %core::ns; + $repl_env.set('eval', MalCode({ eval($^a, $repl_env) })); + $repl_env.set('*ARGV*', MalList([@args.map({ MalString($_) })])); + $repl_env.set('*host-language*', MalString('perl6')); + rep(q{(def! not (fn* (a) (if a false true)))}); + rep(q{(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))}); + rep(q{(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)))))))}); + + if ($source_file.defined) { + rep("(load-file \"$source_file\")"); + exit; + } + rep(q{(println (str "Mal [" *host-language* "]"))}); + + while (my $line = prompt 'user> ').defined { + say rep($line); + CATCH { + when X::MalThrow { say "Error: " ~ pr_str(.value, True) } + when X::MalException { say "Error: " ~ .Str } + } + } +} diff --git a/impls/perl6/tests/stepA_mal.mal b/impls/perl6/tests/stepA_mal.mal index 0a586b4c20..bacfa672fc 100644 --- a/impls/perl6/tests/stepA_mal.mal +++ b/impls/perl6/tests/stepA_mal.mal @@ -1,48 +1,48 @@ -;; Testing basic Perl 6 interop - -(perl6-eval "7") -;=>7 - -(perl6-eval "'7'") -;=>"7" - -(perl6-eval "123 == 123") -;=>true - -(perl6-eval "123 == 456") -;=>false - -(perl6-eval "(7,8,9)") -;=>(7 8 9) - -(perl6-eval "[7,8,9]") -;=>(7 8 9) - -(perl6-eval "{abc => 789}") -;=>{"abc" 789} - -(perl6-eval "Nil") -;=>nil - -(perl6-eval "True") -;=>true - -(perl6-eval "False") -;=>false - -(perl6-eval "my $foo") -;=>nil - -(perl6-eval "say 'hello' ") -;/hello -;=>true - -(perl6-eval "sub { my $foo = 8 }()") -;=>8 - -(perl6-eval "'This sentence has five words'.subst(/\w+/, :g, {'*' ~ $^a.chars ~ '*'})") -;=>"*4* *8* *3* *4* *5*" - -(perl6-eval "<3 a 45 b>.join: '|'") -;=>"3|a|45|b" - +;; Testing basic Perl 6 interop + +(perl6-eval "7") +;=>7 + +(perl6-eval "'7'") +;=>"7" + +(perl6-eval "123 == 123") +;=>true + +(perl6-eval "123 == 456") +;=>false + +(perl6-eval "(7,8,9)") +;=>(7 8 9) + +(perl6-eval "[7,8,9]") +;=>(7 8 9) + +(perl6-eval "{abc => 789}") +;=>{"abc" 789} + +(perl6-eval "Nil") +;=>nil + +(perl6-eval "True") +;=>true + +(perl6-eval "False") +;=>false + +(perl6-eval "my $foo") +;=>nil + +(perl6-eval "say 'hello' ") +;/hello +;=>true + +(perl6-eval "sub { my $foo = 8 }()") +;=>8 + +(perl6-eval "'This sentence has five words'.subst(/\w+/, :g, {'*' ~ $^a.chars ~ '*'})") +;=>"*4* *8* *3* *4* *5*" + +(perl6-eval "<3 a 45 b>.join: '|'") +;=>"3|a|45|b" + diff --git a/impls/perl6/types.pm b/impls/perl6/types.pm index 95695c4787..cfcc1e7bd6 100644 --- a/impls/perl6/types.pm +++ b/impls/perl6/types.pm @@ -1,94 +1,94 @@ -unit module types; - -class X::MalException is Exception is export {} -class X::MalNoTokens is X::MalException is export { - method message() { "got no tokens" } -} -class X::MalIncomplete is X::MalException is export { - has $.end; - method message() { "expected '$.end', got EOF" } -} -class X::MalUnexpected is X::MalException is export { - has $.token; - method message() { "unexpected '$.token'" } -} -class X::MalNotFound is X::MalException is export { - has $.name; - method message() { "'$.name' not found" } -} -class X::MalOutOfRange is X::MalException is export { - method message() { "nth: index out of range" } -} -class X::MalThrow is X::MalException is export { - has $.value; -} - -role MalValue is export { - has $.val is rw; - method CALL-ME ($val) { self.new(:$val) } -} -role MalSequence is export { - has $.val handles ; - has $.meta is rw; - method CALL-ME ($val) { self.new(:$val) } -} -role MalCallable is export { - has &.fn; - method apply (*@_) { &!fn(|@_) } -} -role MalMeta is export { - has $.meta is rw; -} - -class MalNil does MalValue is export { - method seq { self } -} -class MalTrue does MalValue is export {} -class MalFalse does MalValue is export {} - -our $NIL is export = MalNil('nil'); -our $TRUE is export = MalTrue('true'); -our $FALSE is export = MalFalse('false'); - -class MalSymbol does MalValue does MalMeta is export {} - -class MalList does MalSequence is export { - method conj (@args) { return self.new(val => [|@args.reverse, |$.val]) } - method seq { return self.elems ?? self !! $NIL } -} - -class MalVector does MalSequence is export { - method conj (@args) { return self.new(val => [|$.val, |@args]) } - method seq { return self.elems ?? MalList(self.val) !! $NIL } -} - -class MalHashMap does MalMeta is export { - has $.val handles ; - method CALL-ME ($val) { self.new(:$val) } -} - -class MalNumber does MalValue is export {} - -class MalString does MalValue is export { - method seq { - return self.val.chars - ?? MalList(self.val.comb.map({MalString($_)})) - !! $NIL; - } -} - -class MalCode does MalCallable does MalMeta is export { - method CALL-ME (&fn) { self.new(:&fn) } -} - -class MalFunction does MalCallable does MalMeta is export { - has $.ast; - has @.params; - has $.env; - has $.is_macro is rw = False; - method CALL-ME ($ast, $env, @params, &fn) { - self.bless(:$ast, :$env, :@params, :&fn); - } -} - -class MalAtom does MalValue does MalMeta is export {} +unit module types; + +class X::MalException is Exception is export {} +class X::MalNoTokens is X::MalException is export { + method message() { "got no tokens" } +} +class X::MalIncomplete is X::MalException is export { + has $.end; + method message() { "expected '$.end', got EOF" } +} +class X::MalUnexpected is X::MalException is export { + has $.token; + method message() { "unexpected '$.token'" } +} +class X::MalNotFound is X::MalException is export { + has $.name; + method message() { "'$.name' not found" } +} +class X::MalOutOfRange is X::MalException is export { + method message() { "nth: index out of range" } +} +class X::MalThrow is X::MalException is export { + has $.value; +} + +role MalValue is export { + has $.val is rw; + method CALL-ME ($val) { self.new(:$val) } +} +role MalSequence is export { + has $.val handles ; + has $.meta is rw; + method CALL-ME ($val) { self.new(:$val) } +} +role MalCallable is export { + has &.fn; + method apply (*@_) { &!fn(|@_) } +} +role MalMeta is export { + has $.meta is rw; +} + +class MalNil does MalValue is export { + method seq { self } +} +class MalTrue does MalValue is export {} +class MalFalse does MalValue is export {} + +our $NIL is export = MalNil('nil'); +our $TRUE is export = MalTrue('true'); +our $FALSE is export = MalFalse('false'); + +class MalSymbol does MalValue does MalMeta is export {} + +class MalList does MalSequence is export { + method conj (@args) { return self.new(val => [|@args.reverse, |$.val]) } + method seq { return self.elems ?? self !! $NIL } +} + +class MalVector does MalSequence is export { + method conj (@args) { return self.new(val => [|$.val, |@args]) } + method seq { return self.elems ?? MalList(self.val) !! $NIL } +} + +class MalHashMap does MalMeta is export { + has $.val handles ; + method CALL-ME ($val) { self.new(:$val) } +} + +class MalNumber does MalValue is export {} + +class MalString does MalValue is export { + method seq { + return self.val.chars + ?? MalList(self.val.comb.map({MalString($_)})) + !! $NIL; + } +} + +class MalCode does MalCallable does MalMeta is export { + method CALL-ME (&fn) { self.new(:&fn) } +} + +class MalFunction does MalCallable does MalMeta is export { + has $.ast; + has @.params; + has $.env; + has $.is_macro is rw = False; + method CALL-ME ($ast, $env, @params, &fn) { + self.bless(:$ast, :$env, :@params, :&fn); + } +} + +class MalAtom does MalValue does MalMeta is export {} diff --git a/impls/php/Dockerfile b/impls/php/Dockerfile index 87709d4d9a..70b1a42bc5 100644 --- a/impls/php/Dockerfile +++ b/impls/php/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install php5-cli +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install php5-cli diff --git a/impls/php/Makefile b/impls/php/Makefile index 1682d6c40f..9d04a21655 100644 --- a/impls/php/Makefile +++ b/impls/php/Makefile @@ -1,21 +1,21 @@ -SOURCES_BASE = readline.php types.php reader.php printer.php interop.php -SOURCES_LISP = env.php core.php stepA_mal.php -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - -dist: mal.php mal - -mal.php: $(SOURCES) - cat $+ | grep -v "^require_once" > $@ - -mal: mal.php - echo "#!/usr/bin/env php" > $@ - cat $< >> $@ - chmod +x $@ - -mal-web.php: mal.php - cat $< | ( IFS="NON-MATCHING-IFS"; while read -r line; do if [ "$$line" = "// run mal file" ]; then echo "?>"; cat webrunner.php; echo " $@ - -clean: - rm -f mal.php mal mal-web.php +SOURCES_BASE = readline.php types.php reader.php printer.php interop.php +SOURCES_LISP = env.php core.php stepA_mal.php +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + +dist: mal.php mal + +mal.php: $(SOURCES) + cat $+ | grep -v "^require_once" > $@ + +mal: mal.php + echo "#!/usr/bin/env php" > $@ + cat $< >> $@ + chmod +x $@ + +mal-web.php: mal.php + cat $< | ( IFS="NON-MATCHING-IFS"; while read -r line; do if [ "$$line" = "// run mal file" ]; then echo "?>"; cat webrunner.php; echo " $@ + +clean: + rm -f mal.php mal mal-web.php diff --git a/impls/php/README.md b/impls/php/README.md index 24500da82e..f2590362bc 100644 --- a/impls/php/README.md +++ b/impls/php/README.md @@ -1,42 +1,42 @@ -### Running .mal scripts on PHP hosting ### - -Create a symlink to `mal-web.php` with the same name as your `.mal` script and your script will be executed as if it was PHP. - -Here's an example using local dev. - -First build `mal-web.php`: - - cd mal/php - make mal-web.php - -Now you can create a web runnable mal script: - - echo '(println "Hello world!")' > myscript.mal - ln -s mal-web.php myscript.php - -Start a development server with `php -S 0.0.0.0:8000` and then browse to http://localhost:8000/myscript.php and you should see "Hello world!" in your browser as `myscript.mal` is run. - -You can do the same thing on live PHP web hosting by copying `mal.php` up and creating a symlink for each `.mal` file you want to be web-executable. - -### PHP interop ### - -In [stepA_mal.mal](./tests/stepA_mal.mal) you can find some examples of PHP interop. - -Eval PHP code: - - (php* "return 7;") - 7 - - (php* "return array(7,8,9);") - (7 8 9) - -Native function call: - - (php/date "Y-m-d" 0) - "1970-01-01" - -Accessing PHP "superglobal" variables: - - (get php/_SERVER "PHP_SELF") - "./mal" - +### Running .mal scripts on PHP hosting ### + +Create a symlink to `mal-web.php` with the same name as your `.mal` script and your script will be executed as if it was PHP. + +Here's an example using local dev. + +First build `mal-web.php`: + + cd mal/php + make mal-web.php + +Now you can create a web runnable mal script: + + echo '(println "Hello world!")' > myscript.mal + ln -s mal-web.php myscript.php + +Start a development server with `php -S 0.0.0.0:8000` and then browse to http://localhost:8000/myscript.php and you should see "Hello world!" in your browser as `myscript.mal` is run. + +You can do the same thing on live PHP web hosting by copying `mal.php` up and creating a symlink for each `.mal` file you want to be web-executable. + +### PHP interop ### + +In [stepA_mal.mal](./tests/stepA_mal.mal) you can find some examples of PHP interop. + +Eval PHP code: + + (php* "return 7;") + 7 + + (php* "return array(7,8,9);") + (7 8 9) + +Native function call: + + (php/date "Y-m-d" 0) + "1970-01-01" + +Accessing PHP "superglobal" variables: + + (get php/_SERVER "PHP_SELF") + "./mal" + diff --git a/impls/php/core.php b/impls/php/core.php index 6e87e0c186..adf76847be 100644 --- a/impls/php/core.php +++ b/impls/php/core.php @@ -1,287 +1,287 @@ -offsetExists($k)) { - return $hm[$k]; - } else { - return NULL; - } -} - -function contains_Q($hm, $k) { return array_key_exists($k, $hm); } - -function keys($hm) { - return call_user_func_array('_list', - array_map('strval', array_keys($hm->getArrayCopy()))); -} -function vals($hm) { - return call_user_func_array('_list', array_values($hm->getArrayCopy())); -} - - -// Sequence functions -function cons($a, $b) { - $tmp = $b->getArrayCopy(); - array_unshift($tmp, $a); - $l = new ListClass(); - $l->exchangeArray($tmp); - return $l; -} - -function concat() { - $args = func_get_args(); - $tmp = array(); - foreach ($args as $arg) { - $tmp = array_merge($tmp, $arg->getArrayCopy()); - } - $l = new ListClass(); - $l->exchangeArray($tmp); - return $l; -} - -function vec($a) { - if (_vector_Q($a)) { - return $a; - } else { - $v = new VectorClass(); - $v->exchangeArray($a->getArrayCopy()); - return $v; - } -} - -function nth($seq, $idx) { - if ($idx < $seq->count()) { - return $seq[$idx]; - } else { - throw new Exception("nth: index out of range"); - } -} - -function first($seq) { - if ($seq === NULL || count($seq) === 0) { - return NULL; - } else { - return $seq[0]; - } -} - -function rest($seq) { - if ($seq === NULL) { - return new ListClass(); - } else { - $l = new ListClass(); - $l->exchangeArray(array_slice($seq->getArrayCopy(), 1)); - return $l; - } -} - -function empty_Q($seq) { return $seq->count() === 0; } - -function scount($seq) { return ($seq === NULL ? 0 : $seq->count()); } - -function apply($f) { - $args = array_slice(func_get_args(), 1); - $last_arg = array_pop($args)->getArrayCopy(); - return $f->apply(array_merge($args, $last_arg)); -} - -function map($f, $seq) { - $l = new ListClass(); - # @ to surpress warning if $f throws an exception - @$l->exchangeArray(array_map($f, $seq->getArrayCopy())); - return $l; -} - -function conj($src) { - $args = array_slice(func_get_args(), 1); - $tmp = $src->getArrayCopy(); - if (_list_Q($src)) { - foreach ($args as $arg) { array_unshift($tmp, $arg); } - $s = new ListClass(); - } else { - foreach ($args as $arg) { $tmp[] = $arg; } - $s = new VectorClass(); - } - $s->exchangeArray($tmp); - return $s; -} - -function seq($src) { - if (_list_Q($src)) { - if (count($src) == 0) { return NULL; } - return $src; - } elseif (_vector_Q($src)) { - if (count($src) == 0) { return NULL; } - $tmp = $src->getArrayCopy(); - $s = new ListClass(); - $s->exchangeArray($tmp); - return $s; - } elseif (_string_Q($src)) { - if (strlen($src) == 0) { return NULL; } - $tmp = str_split($src); - $s = new ListClass(); - $s->exchangeArray($tmp); - return $s; - } elseif (_nil_Q($src)) { - return NULL; - } else { - throw new Exception("seq: called on non-sequence"); - } - return $s; -} - - - -// Metadata functions -function with_meta($obj, $m) { - $new_obj = clone $obj; - $new_obj->meta = $m; - return $new_obj; -} - -function meta($obj) { - return $obj->meta; -} - - -// Atom functions -function deref($atm) { return $atm->value; } -function reset_BANG($atm, $val) { return $atm->value = $val; } -function swap_BANG($atm, $f) { - $args = array_slice(func_get_args(),2); - array_unshift($args, $atm->value); - $atm->value = call_user_func_array($f, $args); - return $atm->value; -} - - -// core_ns is namespace of type functions -$core_ns = array( - '='=> function ($a, $b) { return _equal_Q($a, $b); }, - 'throw'=> function ($a) { return mal_throw($a); }, - 'nil?'=> function ($a) { return _nil_Q($a); }, - 'true?'=> function ($a) { return _true_Q($a); }, - 'false?'=> function ($a) { return _false_Q($a); }, - 'number?'=> function ($a) { return _number_Q($a); }, - 'symbol'=> function () { return call_user_func_array('_symbol', func_get_args()); }, - 'symbol?'=> function ($a) { return _symbol_Q($a); }, - 'keyword'=> function () { return call_user_func_array('_keyword', func_get_args()); }, - 'keyword?'=> function ($a) { return _keyword_Q($a); }, - - 'string?'=> function ($a) { return _string_Q($a); }, - 'fn?'=> function($a) { return _fn_Q($a) || (_function_Q($a) && !$a->ismacro ); }, - 'macro?'=> function($a) { return _function_Q($a) && $a->ismacro; }, - 'pr-str'=> function () { return call_user_func_array('pr_str', func_get_args()); }, - 'str'=> function () { return call_user_func_array('str', func_get_args()); }, - 'prn'=> function () { return call_user_func_array('prn', func_get_args()); }, - 'println'=>function () { return call_user_func_array('println', func_get_args()); }, - 'readline'=>function ($a) { return mal_readline($a); }, - 'read-string'=>function ($a) { return read_str($a); }, - 'slurp'=> function ($a) { return file_get_contents($a); }, - '<'=> function ($a, $b) { return $a < $b; }, - '<='=> function ($a, $b) { return $a <= $b; }, - '>'=> function ($a, $b) { return $a > $b; }, - '>='=> function ($a, $b) { return $a >= $b; }, - '+'=> function ($a, $b) { return intval($a + $b,10); }, - '-'=> function ($a, $b) { return intval($a - $b,10); }, - '*'=> function ($a, $b) { return intval($a * $b,10); }, - '/'=> function ($a, $b) { return intval($a / $b,10); }, - 'time-ms'=>function () { return time_ms(); }, - - 'list'=> function () { return call_user_func_array('_list', func_get_args()); }, - 'list?'=> function ($a) { return _list_Q($a); }, - 'vector'=> function () { return call_user_func_array('_vector', func_get_args()); }, - 'vector?'=> function ($a) { return _vector_Q($a); }, - 'hash-map' => function () { return call_user_func_array('_hash_map', func_get_args()); }, - 'map?'=> function ($a) { return _hash_map_Q($a); }, - 'assoc' => function () { return call_user_func_array('assoc', func_get_args()); }, - 'dissoc' => function () { return call_user_func_array('dissoc', func_get_args()); }, - 'get' => function ($a, $b) { return get($a, $b); }, - 'contains?' => function ($a, $b) { return contains_Q($a, $b); }, - 'keys' => function ($a) { return keys($a); }, - 'vals' => function ($a) { return vals($a); }, - - 'sequential?'=> function ($a) { return _sequential_Q($a); }, - 'cons'=> function ($a, $b) { return cons($a, $b); }, - 'concat'=> function () { return call_user_func_array('concat', func_get_args()); }, - 'vec'=> function ($a) { return vec($a, $b); }, - 'nth'=> function ($a, $b) { return nth($a, $b); }, - 'first'=> function ($a) { return first($a); }, - 'rest'=> function ($a) { return rest($a); }, - 'empty?'=> function ($a) { return empty_Q($a); }, - 'count'=> function ($a) { return scount($a); }, - 'apply'=> function () { return call_user_func_array('apply', func_get_args()); }, - 'map'=> function ($a, $b) { return map($a, $b); }, - - 'conj'=> function () { return call_user_func_array('conj', func_get_args()); }, - 'seq'=> function ($a) { return seq($a); }, - - 'with-meta'=> function ($a, $b) { return with_meta($a, $b); }, - 'meta'=> function ($a) { return meta($a); }, - 'atom'=> function ($a) { return _atom($a); }, - 'atom?'=> function ($a) { return _atom_Q($a); }, - 'deref'=> function ($a) { return deref($a); }, - 'reset!'=> function ($a, $b) { return reset_BANG($a, $b); }, - 'swap!'=> function () { return call_user_func_array('swap_BANG', func_get_args()); }, -); - - -?> +offsetExists($k)) { + return $hm[$k]; + } else { + return NULL; + } +} + +function contains_Q($hm, $k) { return array_key_exists($k, $hm); } + +function keys($hm) { + return call_user_func_array('_list', + array_map('strval', array_keys($hm->getArrayCopy()))); +} +function vals($hm) { + return call_user_func_array('_list', array_values($hm->getArrayCopy())); +} + + +// Sequence functions +function cons($a, $b) { + $tmp = $b->getArrayCopy(); + array_unshift($tmp, $a); + $l = new ListClass(); + $l->exchangeArray($tmp); + return $l; +} + +function concat() { + $args = func_get_args(); + $tmp = array(); + foreach ($args as $arg) { + $tmp = array_merge($tmp, $arg->getArrayCopy()); + } + $l = new ListClass(); + $l->exchangeArray($tmp); + return $l; +} + +function vec($a) { + if (_vector_Q($a)) { + return $a; + } else { + $v = new VectorClass(); + $v->exchangeArray($a->getArrayCopy()); + return $v; + } +} + +function nth($seq, $idx) { + if ($idx < $seq->count()) { + return $seq[$idx]; + } else { + throw new Exception("nth: index out of range"); + } +} + +function first($seq) { + if ($seq === NULL || count($seq) === 0) { + return NULL; + } else { + return $seq[0]; + } +} + +function rest($seq) { + if ($seq === NULL) { + return new ListClass(); + } else { + $l = new ListClass(); + $l->exchangeArray(array_slice($seq->getArrayCopy(), 1)); + return $l; + } +} + +function empty_Q($seq) { return $seq->count() === 0; } + +function scount($seq) { return ($seq === NULL ? 0 : $seq->count()); } + +function apply($f) { + $args = array_slice(func_get_args(), 1); + $last_arg = array_pop($args)->getArrayCopy(); + return $f->apply(array_merge($args, $last_arg)); +} + +function map($f, $seq) { + $l = new ListClass(); + # @ to surpress warning if $f throws an exception + @$l->exchangeArray(array_map($f, $seq->getArrayCopy())); + return $l; +} + +function conj($src) { + $args = array_slice(func_get_args(), 1); + $tmp = $src->getArrayCopy(); + if (_list_Q($src)) { + foreach ($args as $arg) { array_unshift($tmp, $arg); } + $s = new ListClass(); + } else { + foreach ($args as $arg) { $tmp[] = $arg; } + $s = new VectorClass(); + } + $s->exchangeArray($tmp); + return $s; +} + +function seq($src) { + if (_list_Q($src)) { + if (count($src) == 0) { return NULL; } + return $src; + } elseif (_vector_Q($src)) { + if (count($src) == 0) { return NULL; } + $tmp = $src->getArrayCopy(); + $s = new ListClass(); + $s->exchangeArray($tmp); + return $s; + } elseif (_string_Q($src)) { + if (strlen($src) == 0) { return NULL; } + $tmp = str_split($src); + $s = new ListClass(); + $s->exchangeArray($tmp); + return $s; + } elseif (_nil_Q($src)) { + return NULL; + } else { + throw new Exception("seq: called on non-sequence"); + } + return $s; +} + + + +// Metadata functions +function with_meta($obj, $m) { + $new_obj = clone $obj; + $new_obj->meta = $m; + return $new_obj; +} + +function meta($obj) { + return $obj->meta; +} + + +// Atom functions +function deref($atm) { return $atm->value; } +function reset_BANG($atm, $val) { return $atm->value = $val; } +function swap_BANG($atm, $f) { + $args = array_slice(func_get_args(),2); + array_unshift($args, $atm->value); + $atm->value = call_user_func_array($f, $args); + return $atm->value; +} + + +// core_ns is namespace of type functions +$core_ns = array( + '='=> function ($a, $b) { return _equal_Q($a, $b); }, + 'throw'=> function ($a) { return mal_throw($a); }, + 'nil?'=> function ($a) { return _nil_Q($a); }, + 'true?'=> function ($a) { return _true_Q($a); }, + 'false?'=> function ($a) { return _false_Q($a); }, + 'number?'=> function ($a) { return _number_Q($a); }, + 'symbol'=> function () { return call_user_func_array('_symbol', func_get_args()); }, + 'symbol?'=> function ($a) { return _symbol_Q($a); }, + 'keyword'=> function () { return call_user_func_array('_keyword', func_get_args()); }, + 'keyword?'=> function ($a) { return _keyword_Q($a); }, + + 'string?'=> function ($a) { return _string_Q($a); }, + 'fn?'=> function($a) { return _fn_Q($a) || (_function_Q($a) && !$a->ismacro ); }, + 'macro?'=> function($a) { return _function_Q($a) && $a->ismacro; }, + 'pr-str'=> function () { return call_user_func_array('pr_str', func_get_args()); }, + 'str'=> function () { return call_user_func_array('str', func_get_args()); }, + 'prn'=> function () { return call_user_func_array('prn', func_get_args()); }, + 'println'=>function () { return call_user_func_array('println', func_get_args()); }, + 'readline'=>function ($a) { return mal_readline($a); }, + 'read-string'=>function ($a) { return read_str($a); }, + 'slurp'=> function ($a) { return file_get_contents($a); }, + '<'=> function ($a, $b) { return $a < $b; }, + '<='=> function ($a, $b) { return $a <= $b; }, + '>'=> function ($a, $b) { return $a > $b; }, + '>='=> function ($a, $b) { return $a >= $b; }, + '+'=> function ($a, $b) { return intval($a + $b,10); }, + '-'=> function ($a, $b) { return intval($a - $b,10); }, + '*'=> function ($a, $b) { return intval($a * $b,10); }, + '/'=> function ($a, $b) { return intval($a / $b,10); }, + 'time-ms'=>function () { return time_ms(); }, + + 'list'=> function () { return call_user_func_array('_list', func_get_args()); }, + 'list?'=> function ($a) { return _list_Q($a); }, + 'vector'=> function () { return call_user_func_array('_vector', func_get_args()); }, + 'vector?'=> function ($a) { return _vector_Q($a); }, + 'hash-map' => function () { return call_user_func_array('_hash_map', func_get_args()); }, + 'map?'=> function ($a) { return _hash_map_Q($a); }, + 'assoc' => function () { return call_user_func_array('assoc', func_get_args()); }, + 'dissoc' => function () { return call_user_func_array('dissoc', func_get_args()); }, + 'get' => function ($a, $b) { return get($a, $b); }, + 'contains?' => function ($a, $b) { return contains_Q($a, $b); }, + 'keys' => function ($a) { return keys($a); }, + 'vals' => function ($a) { return vals($a); }, + + 'sequential?'=> function ($a) { return _sequential_Q($a); }, + 'cons'=> function ($a, $b) { return cons($a, $b); }, + 'concat'=> function () { return call_user_func_array('concat', func_get_args()); }, + 'vec'=> function ($a) { return vec($a, $b); }, + 'nth'=> function ($a, $b) { return nth($a, $b); }, + 'first'=> function ($a) { return first($a); }, + 'rest'=> function ($a) { return rest($a); }, + 'empty?'=> function ($a) { return empty_Q($a); }, + 'count'=> function ($a) { return scount($a); }, + 'apply'=> function () { return call_user_func_array('apply', func_get_args()); }, + 'map'=> function ($a, $b) { return map($a, $b); }, + + 'conj'=> function () { return call_user_func_array('conj', func_get_args()); }, + 'seq'=> function ($a) { return seq($a); }, + + 'with-meta'=> function ($a, $b) { return with_meta($a, $b); }, + 'meta'=> function ($a) { return meta($a); }, + 'atom'=> function ($a) { return _atom($a); }, + 'atom?'=> function ($a) { return _atom_Q($a); }, + 'deref'=> function ($a) { return deref($a); }, + 'reset!'=> function ($a, $b) { return reset_BANG($a, $b); }, + 'swap!'=> function () { return call_user_func_array('swap_BANG', func_get_args()); }, +); + + +?> diff --git a/impls/php/env.php b/impls/php/env.php index a660d3b9d4..ed86d26ced 100644 --- a/impls/php/env.php +++ b/impls/php/env.php @@ -1,56 +1,56 @@ -outer = $outer; - if ($binds) { - if (_sequential_Q($exprs)) { - $exprs = $exprs->getArrayCopy(); - } - for ($i=0; $ivalue === "&") { - if ($exprs !== NULL && $i < count($exprs)) { - $lst = call_user_func_array('_list', array_slice($exprs, $i)); - } else { - $lst = _list(); - } - $this->data[$binds[$i+1]->value] = $lst; - break; - } else { - if ($exprs !== NULL && $i < count($exprs)) { - $this->data[$binds[$i]->value] = $exprs[$i]; - } else { - $this->data[$binds[$i]->value] = NULL; - } - } - } - } - } - public function find($key) { - if (array_key_exists($key->value, $this->data)) { - return $this; - } elseif ($this->outer) { - return $this->outer->find($key); - } else { - return NULL; - } - } - public function set($key, $value) { - $this->data[$key->value] = $value; - return $value; - } - public function get($key) { - $env = $this->find($key); - if (!$env) { - throw new Exception("'" . $key->value . "' not found"); - } else { - return $env->data[$key->value]; - } - } -} - -?> +outer = $outer; + if ($binds) { + if (_sequential_Q($exprs)) { + $exprs = $exprs->getArrayCopy(); + } + for ($i=0; $ivalue === "&") { + if ($exprs !== NULL && $i < count($exprs)) { + $lst = call_user_func_array('_list', array_slice($exprs, $i)); + } else { + $lst = _list(); + } + $this->data[$binds[$i+1]->value] = $lst; + break; + } else { + if ($exprs !== NULL && $i < count($exprs)) { + $this->data[$binds[$i]->value] = $exprs[$i]; + } else { + $this->data[$binds[$i]->value] = NULL; + } + } + } + } + } + public function find($key) { + if (array_key_exists($key->value, $this->data)) { + return $this; + } elseif ($this->outer) { + return $this->outer->find($key); + } else { + return NULL; + } + } + public function set($key, $value) { + $this->data[$key->value] = $value; + return $value; + } + public function get($key) { + $env = $this->find($key); + if (!$env) { + throw new Exception("'" . $key->value . "' not found"); + } else { + return $env->data[$key->value]; + } + } +} + +?> diff --git a/impls/php/interop.php b/impls/php/interop.php index bb14d880ed..7e524ec9ea 100644 --- a/impls/php/interop.php +++ b/impls/php/interop.php @@ -1,80 +1,80 @@ - $v) { - $ret[_to_php($k)] = _to_php($v); - } - return $ret; - } elseif (is_string($obj)) { - if (strpos($obj, chr(0x7f)) === 0) { - return ":".substr($obj,1); - } else { - return $obj; - } - } elseif (_symbol_Q($obj)) { - return ${$obj->value}; - } elseif (_atom_Q($obj)) { - return $obj->value; - } else { - return $obj; - } -} - -function _to_mal($obj) { - switch (gettype($obj)) { - case "object": - return _to_mal(get_object_vars($obj)); - case "array": - $obj_conv = array(); - foreach ($obj as $k => $v) { - $obj_conv[_to_mal($k)] = _to_mal($v); - } - if ($obj_conv !== array_values($obj_conv)) { - $new_obj = _hash_map(); - $new_obj->exchangeArray($obj_conv); - return $new_obj; - } else { - return call_user_func_array('_list', $obj_conv); - } - default: - return $obj; - } -} - -function _to_native($name, $env) { - if (is_callable($name)) { - return _function(function() use ($name) { - $args = array_map("_to_php", func_get_args()); - $res = call_user_func_array($name, $args); - return _to_mal($res); - }); - // special case for language constructs - } else if ($name == "print") { - return _function(function($value) { - print(_to_php($value)); - return null; - }); - } else if ($name == "exit") { - return _function(function($value) { - exit(_to_php($value)); - return null; - }); - } else if ($name == "require") { - return _function(function($value) { - require(_to_php($value)); - return null; - }); - } else if (in_array($name, ["_SERVER", "_GET", "_POST", "_FILES", "_REQUEST", "_SESSION", "_ENV", "_COOKIE"])) { - $val = $GLOBALS[$name]; - } else if (defined($name)) { - $val = constant($name); - } else { - $val = ${$name}; - } - return _to_mal($val); -} -?> + $v) { + $ret[_to_php($k)] = _to_php($v); + } + return $ret; + } elseif (is_string($obj)) { + if (strpos($obj, chr(0x7f)) === 0) { + return ":".substr($obj,1); + } else { + return $obj; + } + } elseif (_symbol_Q($obj)) { + return ${$obj->value}; + } elseif (_atom_Q($obj)) { + return $obj->value; + } else { + return $obj; + } +} + +function _to_mal($obj) { + switch (gettype($obj)) { + case "object": + return _to_mal(get_object_vars($obj)); + case "array": + $obj_conv = array(); + foreach ($obj as $k => $v) { + $obj_conv[_to_mal($k)] = _to_mal($v); + } + if ($obj_conv !== array_values($obj_conv)) { + $new_obj = _hash_map(); + $new_obj->exchangeArray($obj_conv); + return $new_obj; + } else { + return call_user_func_array('_list', $obj_conv); + } + default: + return $obj; + } +} + +function _to_native($name, $env) { + if (is_callable($name)) { + return _function(function() use ($name) { + $args = array_map("_to_php", func_get_args()); + $res = call_user_func_array($name, $args); + return _to_mal($res); + }); + // special case for language constructs + } else if ($name == "print") { + return _function(function($value) { + print(_to_php($value)); + return null; + }); + } else if ($name == "exit") { + return _function(function($value) { + exit(_to_php($value)); + return null; + }); + } else if ($name == "require") { + return _function(function($value) { + require(_to_php($value)); + return null; + }); + } else if (in_array($name, ["_SERVER", "_GET", "_POST", "_FILES", "_REQUEST", "_SESSION", "_ENV", "_COOKIE"])) { + $val = $GLOBALS[$name]; + } else if (defined($name)) { + $val = constant($name); + } else { + $val = ${$name}; + } + return _to_mal($val); +} +?> diff --git a/impls/php/printer.php b/impls/php/printer.php index d70d4ed7a4..3deeef80e8 100644 --- a/impls/php/printer.php +++ b/impls/php/printer.php @@ -1,61 +1,61 @@ -getArrayCopy()) as $k) { - $ret[] = _pr_str("$k", $print_readably); - $ret[] = _pr_str($obj[$k], $print_readably); - } - return "{" . implode(" ", $ret) . "}"; - } elseif (is_string($obj)) { - if (strpos($obj, chr(0x7f)) === 0) { - return ":".substr($obj,1); - } elseif ($print_readably) { - $obj = preg_replace('/\n/', '\\n', preg_replace('/"/', '\\"', preg_replace('/\\\\/', '\\\\\\\\', $obj))); - return '"' . $obj . '"'; - } else { - return $obj; - } - } elseif (is_double($obj)) { - return $obj; - } elseif (is_integer($obj)) { - return $obj; - } elseif ($obj === NULL) { - return "nil"; - } elseif ($obj === true) { - return "true"; - } elseif ($obj === false) { - return "false"; - } elseif (_symbol_Q($obj)) { - return $obj->value; - } elseif (_atom_Q($obj)) { - return "(atom " . _pr_str($obj->value, $print_readably) . ")"; - } elseif (_function_Q($obj)) { - return "(fn* [...] ...)"; - } elseif (is_callable($obj)) { // only step4 and below - return "#"; - } elseif (is_object($obj)) { - return "#"; - } elseif (is_array($obj)) { - return "#"; - } else { - throw new Exception("_pr_str unknown type: " . gettype($obj)); - } -} - -?> +getArrayCopy()) as $k) { + $ret[] = _pr_str("$k", $print_readably); + $ret[] = _pr_str($obj[$k], $print_readably); + } + return "{" . implode(" ", $ret) . "}"; + } elseif (is_string($obj)) { + if (strpos($obj, chr(0x7f)) === 0) { + return ":".substr($obj,1); + } elseif ($print_readably) { + $obj = preg_replace('/\n/', '\\n', preg_replace('/"/', '\\"', preg_replace('/\\\\/', '\\\\\\\\', $obj))); + return '"' . $obj . '"'; + } else { + return $obj; + } + } elseif (is_double($obj)) { + return $obj; + } elseif (is_integer($obj)) { + return $obj; + } elseif ($obj === NULL) { + return "nil"; + } elseif ($obj === true) { + return "true"; + } elseif ($obj === false) { + return "false"; + } elseif (_symbol_Q($obj)) { + return $obj->value; + } elseif (_atom_Q($obj)) { + return "(atom " . _pr_str($obj->value, $print_readably) . ")"; + } elseif (_function_Q($obj)) { + return "(fn* [...] ...)"; + } elseif (is_callable($obj)) { // only step4 and below + return "#"; + } elseif (is_object($obj)) { + return "#"; + } elseif (is_array($obj)) { + return "#"; + } else { + throw new Exception("_pr_str unknown type: " . gettype($obj)); + } +} + +?> diff --git a/impls/php/reader.php b/impls/php/reader.php index 53e404d336..1ba10b677c 100644 --- a/impls/php/reader.php +++ b/impls/php/reader.php @@ -1,128 +1,128 @@ -tokens = $tokens; - $this->position = 0; - } - public function next() { - if ($this->position >= count($this->tokens)) { return null; } - return $this->tokens[$this->position++]; - } - public function peek() { - if ($this->position >= count($this->tokens)) { return null; } - return $this->tokens[$this->position]; - } -} - -class BlankException extends Exception { -} - -function _real_token($s) { - return $s !== '' && $s[0] !== ';'; -} - -function tokenize($str) { - $pat = "/[\s,]*(php\/|~@|[\[\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\s\[\]{}('\"`,;)]*)/"; - preg_match_all($pat, $str, $matches); - return array_values(array_filter($matches[1], '_real_token')); -} - -function read_atom($reader) { - $token = $reader->next(); - if (preg_match("/^-?[0-9]+$/", $token)) { - return intval($token, 10); - } elseif (preg_match("/^\"(?:\\\\.|[^\\\\\"])*\"$/", $token)) { - $str = substr($token, 1, -1); - $str = str_replace('\\\\', chr(0x7f), $str); - $str = str_replace('\\"', '"', $str); - $str = str_replace('\\n', "\n", $str); - $str = str_replace(chr(0x7f), "\\", $str); - return $str; - } elseif ($token[0] === "\"") { - throw new Exception("expected '\"', got EOF"); - } elseif ($token[0] === ":") { - return _keyword(substr($token,1)); - } elseif ($token === "nil") { - return NULL; - } elseif ($token === "true") { - return true; - } elseif ($token === "false") { - return false; - } else { - return _symbol($token); - } -} - -function read_list($reader, $constr='_list', $start='(', $end=')') { - $ast = $constr(); - $token = $reader->next(); - if ($token !== $start) { - throw new Exception("expected '" . $start . "'"); - } - while (($token = $reader->peek()) !== $end) { - if ($token === "" || $token === null) { - throw new Exception("expected '" . $end . "', got EOF"); - } - $ast[] = read_form($reader); - } - $reader->next(); - return $ast; -} - -function read_hash_map($reader) { - $lst = read_list($reader, '_list', '{', '}'); - return call_user_func_array('_hash_map', $lst->getArrayCopy()); -} - -function read_form($reader) { - $token = $reader->peek(); - switch ($token) { - case '\'': $reader->next(); - return _list(_symbol('quote'), - read_form($reader)); - case '`': $reader->next(); - return _list(_symbol('quasiquote'), - read_form($reader)); - case '~': $reader->next(); - return _list(_symbol('unquote'), - read_form($reader)); - case '~@': $reader->next(); - return _list(_symbol('splice-unquote'), - read_form($reader)); - case '^': $reader->next(); - $meta = read_form($reader); - return _list(_symbol('with-meta'), - read_form($reader), - $meta); - - case '@': $reader->next(); - return _list(_symbol('deref'), - read_form($reader)); - - case 'php/': $reader->next(); - return _list(_symbol('to-native'), - read_form($reader)); - - case ')': throw new Exception("unexpected ')'"); - case '(': return read_list($reader); - case ']': throw new Exception("unexpected ']'"); - case '[': return read_list($reader, '_vector', '[', ']'); - case '}': throw new Exception("unexpected '}'"); - case '{': return read_hash_map($reader); - - default: return read_atom($reader); - } -} - -function read_str($str) { - $tokens = tokenize($str); - if (count($tokens) === 0) { throw new BlankException(); } - return read_form(new Reader($tokens)); -} - -?> +tokens = $tokens; + $this->position = 0; + } + public function next() { + if ($this->position >= count($this->tokens)) { return null; } + return $this->tokens[$this->position++]; + } + public function peek() { + if ($this->position >= count($this->tokens)) { return null; } + return $this->tokens[$this->position]; + } +} + +class BlankException extends Exception { +} + +function _real_token($s) { + return $s !== '' && $s[0] !== ';'; +} + +function tokenize($str) { + $pat = "/[\s,]*(php\/|~@|[\[\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\s\[\]{}('\"`,;)]*)/"; + preg_match_all($pat, $str, $matches); + return array_values(array_filter($matches[1], '_real_token')); +} + +function read_atom($reader) { + $token = $reader->next(); + if (preg_match("/^-?[0-9]+$/", $token)) { + return intval($token, 10); + } elseif (preg_match("/^\"(?:\\\\.|[^\\\\\"])*\"$/", $token)) { + $str = substr($token, 1, -1); + $str = str_replace('\\\\', chr(0x7f), $str); + $str = str_replace('\\"', '"', $str); + $str = str_replace('\\n', "\n", $str); + $str = str_replace(chr(0x7f), "\\", $str); + return $str; + } elseif ($token[0] === "\"") { + throw new Exception("expected '\"', got EOF"); + } elseif ($token[0] === ":") { + return _keyword(substr($token,1)); + } elseif ($token === "nil") { + return NULL; + } elseif ($token === "true") { + return true; + } elseif ($token === "false") { + return false; + } else { + return _symbol($token); + } +} + +function read_list($reader, $constr='_list', $start='(', $end=')') { + $ast = $constr(); + $token = $reader->next(); + if ($token !== $start) { + throw new Exception("expected '" . $start . "'"); + } + while (($token = $reader->peek()) !== $end) { + if ($token === "" || $token === null) { + throw new Exception("expected '" . $end . "', got EOF"); + } + $ast[] = read_form($reader); + } + $reader->next(); + return $ast; +} + +function read_hash_map($reader) { + $lst = read_list($reader, '_list', '{', '}'); + return call_user_func_array('_hash_map', $lst->getArrayCopy()); +} + +function read_form($reader) { + $token = $reader->peek(); + switch ($token) { + case '\'': $reader->next(); + return _list(_symbol('quote'), + read_form($reader)); + case '`': $reader->next(); + return _list(_symbol('quasiquote'), + read_form($reader)); + case '~': $reader->next(); + return _list(_symbol('unquote'), + read_form($reader)); + case '~@': $reader->next(); + return _list(_symbol('splice-unquote'), + read_form($reader)); + case '^': $reader->next(); + $meta = read_form($reader); + return _list(_symbol('with-meta'), + read_form($reader), + $meta); + + case '@': $reader->next(); + return _list(_symbol('deref'), + read_form($reader)); + + case 'php/': $reader->next(); + return _list(_symbol('to-native'), + read_form($reader)); + + case ')': throw new Exception("unexpected ')'"); + case '(': return read_list($reader); + case ']': throw new Exception("unexpected ']'"); + case '[': return read_list($reader, '_vector', '[', ']'); + case '}': throw new Exception("unexpected '}'"); + case '{': return read_hash_map($reader); + + default: return read_atom($reader); + } +} + +function read_str($str) { + $tokens = tokenize($str); + if (count($tokens) === 0) { throw new BlankException(); } + return read_form(new Reader($tokens)); +} + +?> diff --git a/impls/php/readline.php b/impls/php/readline.php index 8b3d28b9cb..48b3e9c25b 100644 --- a/impls/php/readline.php +++ b/impls/php/readline.php @@ -1,41 +1,41 @@ - + diff --git a/impls/php/run b/impls/php/run index 1b090b61ba..ed27ee8ac2 100755 --- a/impls/php/run +++ b/impls/php/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec php $(dirname $0)/${STEP:-stepA_mal}.php "${@}" +#!/bin/bash +exec php $(dirname $0)/${STEP:-stepA_mal}.php "${@}" diff --git a/impls/php/step0_repl.php b/impls/php/step0_repl.php index 421173c1d3..c2e7b686de 100644 --- a/impls/php/step0_repl.php +++ b/impls/php/step0_repl.php @@ -1,34 +1,34 @@ - "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } -} while (true); - -?> + "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } +} while (true); + +?> diff --git a/impls/php/step1_read_print.php b/impls/php/step1_read_print.php index b1f18a8adb..9ea23b6c38 100644 --- a/impls/php/step1_read_print.php +++ b/impls/php/step1_read_print.php @@ -1,44 +1,44 @@ - "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> + "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/step2_eval.php b/impls/php/step2_eval.php index 7d5a822359..628595f593 100644 --- a/impls/php/step2_eval.php +++ b/impls/php/step2_eval.php @@ -1,83 +1,83 @@ -value]; - } elseif (_sequential_Q($ast)) { - if (_list_Q($ast)) { - $el = _list(); - } else { - $el = _vector(); - } - foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } - return $el; - } elseif (_hash_map_Q($ast)) { - $new_hm = _hash_map(); - foreach (array_keys($ast->getArrayCopy()) as $key) { - $new_hm[$key] = MAL_EVAL($ast[$key], $env); - } - return $new_hm; - } else { - return $ast; - } -} - -function MAL_EVAL($ast, $env) { - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - if ($ast->count() === 0) { - return $ast; - } - - // apply list - $el = eval_ast($ast, $env); - $f = $el[0]; - return call_user_func_array($f, array_slice($el->getArrayCopy(), 1)); -} - -// print -function MAL_PRINT($exp) { - return _pr_str($exp, True); -} - -// repl -$repl_env = array(); -function rep($str) { - global $repl_env; - return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); -} - -$repl_env['+'] = function ($a, $b) { return intval($a + $b,10); }; -$repl_env['-'] = function ($a, $b) { return intval($a - $b,10); }; -$repl_env['*'] = function ($a, $b) { return intval($a * $b,10); }; -$repl_env['/'] = function ($a, $b) { return intval($a / $b,10); }; - -// repl loop -do { - try { - $line = mal_readline("user> "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> +value]; + } elseif (_sequential_Q($ast)) { + if (_list_Q($ast)) { + $el = _list(); + } else { + $el = _vector(); + } + foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } + return $el; + } elseif (_hash_map_Q($ast)) { + $new_hm = _hash_map(); + foreach (array_keys($ast->getArrayCopy()) as $key) { + $new_hm[$key] = MAL_EVAL($ast[$key], $env); + } + return $new_hm; + } else { + return $ast; + } +} + +function MAL_EVAL($ast, $env) { + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + if ($ast->count() === 0) { + return $ast; + } + + // apply list + $el = eval_ast($ast, $env); + $f = $el[0]; + return call_user_func_array($f, array_slice($el->getArrayCopy(), 1)); +} + +// print +function MAL_PRINT($exp) { + return _pr_str($exp, True); +} + +// repl +$repl_env = array(); +function rep($str) { + global $repl_env; + return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); +} + +$repl_env['+'] = function ($a, $b) { return intval($a + $b,10); }; +$repl_env['-'] = function ($a, $b) { return intval($a - $b,10); }; +$repl_env['*'] = function ($a, $b) { return intval($a * $b,10); }; +$repl_env['/'] = function ($a, $b) { return intval($a / $b,10); }; + +// repl loop +do { + try { + $line = mal_readline("user> "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/step3_env.php b/impls/php/step3_env.php index 4fb25bd632..54d049a8cb 100644 --- a/impls/php/step3_env.php +++ b/impls/php/step3_env.php @@ -1,100 +1,100 @@ -get($ast); - } elseif (_sequential_Q($ast)) { - if (_list_Q($ast)) { - $el = _list(); - } else { - $el = _vector(); - } - foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } - return $el; - } elseif (_hash_map_Q($ast)) { - $new_hm = _hash_map(); - foreach (array_keys($ast->getArrayCopy()) as $key) { - $new_hm[$key] = MAL_EVAL($ast[$key], $env); - } - return $new_hm; - } else { - return $ast; - } -} - -function MAL_EVAL($ast, $env) { - #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - if ($ast->count() === 0) { - return $ast; - } - - // apply list - $a0 = $ast[0]; - $a0v = (_symbol_Q($a0) ? $a0->value : $a0); - switch ($a0v) { - case "def!": - $res = MAL_EVAL($ast[2], $env); - return $env->set($ast[1], $res); - case "let*": - $a1 = $ast[1]; - $let_env = new Env($env); - for ($i=0; $i < count($a1); $i+=2) { - $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); - } - return MAL_EVAL($ast[2], $let_env); - default: - $el = eval_ast($ast, $env); - $f = $el[0]; - return call_user_func_array($f, array_slice($el->getArrayCopy(), 1)); - } -} - -// print -function MAL_PRINT($exp) { - return _pr_str($exp, True); -} - -// repl -$repl_env = new Env(NULL); -function rep($str) { - global $repl_env; - return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); -} - -$repl_env->set(_symbol('+'), function ($a, $b) { return intval($a + $b,10); }); -$repl_env->set(_symbol('-'), function ($a, $b) { return intval($a - $b,10); }); -$repl_env->set(_symbol('*'), function ($a, $b) { return intval($a * $b,10); }); -$repl_env->set(_symbol('/'), function ($a, $b) { return intval($a / $b,10); }); - -// repl loop -do { - try { - $line = mal_readline("user> "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> +get($ast); + } elseif (_sequential_Q($ast)) { + if (_list_Q($ast)) { + $el = _list(); + } else { + $el = _vector(); + } + foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } + return $el; + } elseif (_hash_map_Q($ast)) { + $new_hm = _hash_map(); + foreach (array_keys($ast->getArrayCopy()) as $key) { + $new_hm[$key] = MAL_EVAL($ast[$key], $env); + } + return $new_hm; + } else { + return $ast; + } +} + +function MAL_EVAL($ast, $env) { + #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + if ($ast->count() === 0) { + return $ast; + } + + // apply list + $a0 = $ast[0]; + $a0v = (_symbol_Q($a0) ? $a0->value : $a0); + switch ($a0v) { + case "def!": + $res = MAL_EVAL($ast[2], $env); + return $env->set($ast[1], $res); + case "let*": + $a1 = $ast[1]; + $let_env = new Env($env); + for ($i=0; $i < count($a1); $i+=2) { + $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); + } + return MAL_EVAL($ast[2], $let_env); + default: + $el = eval_ast($ast, $env); + $f = $el[0]; + return call_user_func_array($f, array_slice($el->getArrayCopy(), 1)); + } +} + +// print +function MAL_PRINT($exp) { + return _pr_str($exp, True); +} + +// repl +$repl_env = new Env(NULL); +function rep($str) { + global $repl_env; + return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); +} + +$repl_env->set(_symbol('+'), function ($a, $b) { return intval($a + $b,10); }); +$repl_env->set(_symbol('-'), function ($a, $b) { return intval($a - $b,10); }); +$repl_env->set(_symbol('*'), function ($a, $b) { return intval($a * $b,10); }); +$repl_env->set(_symbol('/'), function ($a, $b) { return intval($a / $b,10); }); + +// repl loop +do { + try { + $line = mal_readline("user> "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/step4_if_fn_do.php b/impls/php/step4_if_fn_do.php index 2d2ab1ec01..e761129174 100644 --- a/impls/php/step4_if_fn_do.php +++ b/impls/php/step4_if_fn_do.php @@ -1,121 +1,121 @@ -get($ast); - } elseif (_sequential_Q($ast)) { - if (_list_Q($ast)) { - $el = _list(); - } else { - $el = _vector(); - } - foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } - return $el; - } elseif (_hash_map_Q($ast)) { - $new_hm = _hash_map(); - foreach (array_keys($ast->getArrayCopy()) as $key) { - $new_hm[$key] = MAL_EVAL($ast[$key], $env); - } - return $new_hm; - } else { - return $ast; - } -} - -function MAL_EVAL($ast, $env) { - #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - if ($ast->count() === 0) { - return $ast; - } - - // apply list - $a0 = $ast[0]; - $a0v = (_symbol_Q($a0) ? $a0->value : $a0); - switch ($a0v) { - case "def!": - $res = MAL_EVAL($ast[2], $env); - return $env->set($ast[1], $res); - case "let*": - $a1 = $ast[1]; - $let_env = new Env($env); - for ($i=0; $i < count($a1); $i+=2) { - $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); - } - return MAL_EVAL($ast[2], $let_env); - case "do": - #$el = eval_ast(array_slice($ast->getArrayCopy(), 1), $env); - $el = eval_ast($ast->slice(1), $env); - return $el[count($el)-1]; - case "if": - $cond = MAL_EVAL($ast[1], $env); - if ($cond === NULL || $cond === false) { - if (count($ast) === 4) { return MAL_EVAL($ast[3], $env); } - else { return NULL; } - } else { - return MAL_EVAL($ast[2], $env); - } - case "fn*": - return function() use ($env, $ast) { - $fn_env = new Env($env, $ast[1], func_get_args()); - return MAL_EVAL($ast[2], $fn_env); - }; - default: - $el = eval_ast($ast, $env); - $f = $el[0]; - return call_user_func_array($f, array_slice($el->getArrayCopy(), 1)); - } -} - -// print -function MAL_PRINT($exp) { - return _pr_str($exp, True); -} - -// repl -$repl_env = new Env(NULL); -function rep($str) { - global $repl_env; - return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); -} - -// core.php: defined using PHP -foreach ($core_ns as $k=>$v) { - $repl_env->set(_symbol($k), _function($v)); -} - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); - -// repl loop -do { - try { - $line = mal_readline("user> "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> +get($ast); + } elseif (_sequential_Q($ast)) { + if (_list_Q($ast)) { + $el = _list(); + } else { + $el = _vector(); + } + foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } + return $el; + } elseif (_hash_map_Q($ast)) { + $new_hm = _hash_map(); + foreach (array_keys($ast->getArrayCopy()) as $key) { + $new_hm[$key] = MAL_EVAL($ast[$key], $env); + } + return $new_hm; + } else { + return $ast; + } +} + +function MAL_EVAL($ast, $env) { + #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + if ($ast->count() === 0) { + return $ast; + } + + // apply list + $a0 = $ast[0]; + $a0v = (_symbol_Q($a0) ? $a0->value : $a0); + switch ($a0v) { + case "def!": + $res = MAL_EVAL($ast[2], $env); + return $env->set($ast[1], $res); + case "let*": + $a1 = $ast[1]; + $let_env = new Env($env); + for ($i=0; $i < count($a1); $i+=2) { + $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); + } + return MAL_EVAL($ast[2], $let_env); + case "do": + #$el = eval_ast(array_slice($ast->getArrayCopy(), 1), $env); + $el = eval_ast($ast->slice(1), $env); + return $el[count($el)-1]; + case "if": + $cond = MAL_EVAL($ast[1], $env); + if ($cond === NULL || $cond === false) { + if (count($ast) === 4) { return MAL_EVAL($ast[3], $env); } + else { return NULL; } + } else { + return MAL_EVAL($ast[2], $env); + } + case "fn*": + return function() use ($env, $ast) { + $fn_env = new Env($env, $ast[1], func_get_args()); + return MAL_EVAL($ast[2], $fn_env); + }; + default: + $el = eval_ast($ast, $env); + $f = $el[0]; + return call_user_func_array($f, array_slice($el->getArrayCopy(), 1)); + } +} + +// print +function MAL_PRINT($exp) { + return _pr_str($exp, True); +} + +// repl +$repl_env = new Env(NULL); +function rep($str) { + global $repl_env; + return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); +} + +// core.php: defined using PHP +foreach ($core_ns as $k=>$v) { + $repl_env->set(_symbol($k), _function($v)); +} + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); + +// repl loop +do { + try { + $line = mal_readline("user> "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/step5_tco.php b/impls/php/step5_tco.php index 65051fc34e..e4aea0f6c2 100644 --- a/impls/php/step5_tco.php +++ b/impls/php/step5_tco.php @@ -1,133 +1,133 @@ -get($ast); - } elseif (_sequential_Q($ast)) { - if (_list_Q($ast)) { - $el = _list(); - } else { - $el = _vector(); - } - foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } - return $el; - } elseif (_hash_map_Q($ast)) { - $new_hm = _hash_map(); - foreach (array_keys($ast->getArrayCopy()) as $key) { - $new_hm[$key] = MAL_EVAL($ast[$key], $env); - } - return $new_hm; - } else { - return $ast; - } -} - -function MAL_EVAL($ast, $env) { - while (true) { - - #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - if ($ast->count() === 0) { - return $ast; - } - - // apply list - $a0 = $ast[0]; - $a0v = (_symbol_Q($a0) ? $a0->value : $a0); - switch ($a0v) { - case "def!": - $res = MAL_EVAL($ast[2], $env); - return $env->set($ast[1], $res); - case "let*": - $a1 = $ast[1]; - $let_env = new Env($env); - for ($i=0; $i < count($a1); $i+=2) { - $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); - } - $ast = $ast[2]; - $env = $let_env; - break; // Continue loop (TCO) - case "do": - eval_ast($ast->slice(1, -1), $env); - $ast = $ast[count($ast)-1]; - break; // Continue loop (TCO) - case "if": - $cond = MAL_EVAL($ast[1], $env); - if ($cond === NULL || $cond === false) { - if (count($ast) === 4) { $ast = $ast[3]; } - else { $ast = NULL; } - } else { - $ast = $ast[2]; - } - break; // Continue loop (TCO) - case "fn*": - return _function('MAL_EVAL', 'native', - $ast[2], $env, $ast[1]); - default: - $el = eval_ast($ast, $env); - $f = $el[0]; - $args = array_slice($el->getArrayCopy(), 1); - if ($f->type === 'native') { - $ast = $f->ast; - $env = $f->gen_env($args); - // Continue loop (TCO) - } else { - return $f->apply($args); - } - } - - } -} - -// print -function MAL_PRINT($exp) { - return _pr_str($exp, True); -} - -// repl -$repl_env = new Env(NULL); -function rep($str) { - global $repl_env; - return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); -} - -// core.php: defined using PHP -foreach ($core_ns as $k=>$v) { - $repl_env->set(_symbol($k), _function($v)); -} - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); - -// repl loop -do { - try { - $line = mal_readline("user> "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> +get($ast); + } elseif (_sequential_Q($ast)) { + if (_list_Q($ast)) { + $el = _list(); + } else { + $el = _vector(); + } + foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } + return $el; + } elseif (_hash_map_Q($ast)) { + $new_hm = _hash_map(); + foreach (array_keys($ast->getArrayCopy()) as $key) { + $new_hm[$key] = MAL_EVAL($ast[$key], $env); + } + return $new_hm; + } else { + return $ast; + } +} + +function MAL_EVAL($ast, $env) { + while (true) { + + #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + if ($ast->count() === 0) { + return $ast; + } + + // apply list + $a0 = $ast[0]; + $a0v = (_symbol_Q($a0) ? $a0->value : $a0); + switch ($a0v) { + case "def!": + $res = MAL_EVAL($ast[2], $env); + return $env->set($ast[1], $res); + case "let*": + $a1 = $ast[1]; + $let_env = new Env($env); + for ($i=0; $i < count($a1); $i+=2) { + $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); + } + $ast = $ast[2]; + $env = $let_env; + break; // Continue loop (TCO) + case "do": + eval_ast($ast->slice(1, -1), $env); + $ast = $ast[count($ast)-1]; + break; // Continue loop (TCO) + case "if": + $cond = MAL_EVAL($ast[1], $env); + if ($cond === NULL || $cond === false) { + if (count($ast) === 4) { $ast = $ast[3]; } + else { $ast = NULL; } + } else { + $ast = $ast[2]; + } + break; // Continue loop (TCO) + case "fn*": + return _function('MAL_EVAL', 'native', + $ast[2], $env, $ast[1]); + default: + $el = eval_ast($ast, $env); + $f = $el[0]; + $args = array_slice($el->getArrayCopy(), 1); + if ($f->type === 'native') { + $ast = $f->ast; + $env = $f->gen_env($args); + // Continue loop (TCO) + } else { + return $f->apply($args); + } + } + + } +} + +// print +function MAL_PRINT($exp) { + return _pr_str($exp, True); +} + +// repl +$repl_env = new Env(NULL); +function rep($str) { + global $repl_env; + return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); +} + +// core.php: defined using PHP +foreach ($core_ns as $k=>$v) { + $repl_env->set(_symbol($k), _function($v)); +} + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); + +// repl loop +do { + try { + $line = mal_readline("user> "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/step6_file.php b/impls/php/step6_file.php index 97536767ab..5fac724242 100644 --- a/impls/php/step6_file.php +++ b/impls/php/step6_file.php @@ -1,147 +1,147 @@ -get($ast); - } elseif (_sequential_Q($ast)) { - if (_list_Q($ast)) { - $el = _list(); - } else { - $el = _vector(); - } - foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } - return $el; - } elseif (_hash_map_Q($ast)) { - $new_hm = _hash_map(); - foreach (array_keys($ast->getArrayCopy()) as $key) { - $new_hm[$key] = MAL_EVAL($ast[$key], $env); - } - return $new_hm; - } else { - return $ast; - } -} - -function MAL_EVAL($ast, $env) { - while (true) { - - #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - if ($ast->count() === 0) { - return $ast; - } - - // apply list - $a0 = $ast[0]; - $a0v = (_symbol_Q($a0) ? $a0->value : $a0); - switch ($a0v) { - case "def!": - $res = MAL_EVAL($ast[2], $env); - return $env->set($ast[1], $res); - case "let*": - $a1 = $ast[1]; - $let_env = new Env($env); - for ($i=0; $i < count($a1); $i+=2) { - $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); - } - $ast = $ast[2]; - $env = $let_env; - break; // Continue loop (TCO) - case "do": - eval_ast($ast->slice(1, -1), $env); - $ast = $ast[count($ast)-1]; - break; // Continue loop (TCO) - case "if": - $cond = MAL_EVAL($ast[1], $env); - if ($cond === NULL || $cond === false) { - if (count($ast) === 4) { $ast = $ast[3]; } - else { $ast = NULL; } - } else { - $ast = $ast[2]; - } - break; // Continue loop (TCO) - case "fn*": - return _function('MAL_EVAL', 'native', - $ast[2], $env, $ast[1]); - default: - $el = eval_ast($ast, $env); - $f = $el[0]; - $args = array_slice($el->getArrayCopy(), 1); - if ($f->type === 'native') { - $ast = $f->ast; - $env = $f->gen_env($args); - // Continue loop (TCO) - } else { - return $f->apply($args); - } - } - - } -} - -// print -function MAL_PRINT($exp) { - return _pr_str($exp, True); -} - -// repl -$repl_env = new Env(NULL); -function rep($str) { - global $repl_env; - return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); -} - -// core.php: defined using PHP -foreach ($core_ns as $k=>$v) { - $repl_env->set(_symbol($k), _function($v)); -} -$repl_env->set(_symbol('eval'), _function(function($ast) { - global $repl_env; return MAL_EVAL($ast, $repl_env); -})); -$_argv = _list(); -for ($i=2; $i < count($argv); $i++) { - $_argv->append($argv[$i]); -} -$repl_env->set(_symbol('*ARGV*'), $_argv); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - -if (count($argv) > 1) { - rep('(load-file "' . $argv[1] . '")'); - exit(0); -} - -// repl loop -do { - try { - $line = mal_readline("user> "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> +get($ast); + } elseif (_sequential_Q($ast)) { + if (_list_Q($ast)) { + $el = _list(); + } else { + $el = _vector(); + } + foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } + return $el; + } elseif (_hash_map_Q($ast)) { + $new_hm = _hash_map(); + foreach (array_keys($ast->getArrayCopy()) as $key) { + $new_hm[$key] = MAL_EVAL($ast[$key], $env); + } + return $new_hm; + } else { + return $ast; + } +} + +function MAL_EVAL($ast, $env) { + while (true) { + + #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + if ($ast->count() === 0) { + return $ast; + } + + // apply list + $a0 = $ast[0]; + $a0v = (_symbol_Q($a0) ? $a0->value : $a0); + switch ($a0v) { + case "def!": + $res = MAL_EVAL($ast[2], $env); + return $env->set($ast[1], $res); + case "let*": + $a1 = $ast[1]; + $let_env = new Env($env); + for ($i=0; $i < count($a1); $i+=2) { + $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); + } + $ast = $ast[2]; + $env = $let_env; + break; // Continue loop (TCO) + case "do": + eval_ast($ast->slice(1, -1), $env); + $ast = $ast[count($ast)-1]; + break; // Continue loop (TCO) + case "if": + $cond = MAL_EVAL($ast[1], $env); + if ($cond === NULL || $cond === false) { + if (count($ast) === 4) { $ast = $ast[3]; } + else { $ast = NULL; } + } else { + $ast = $ast[2]; + } + break; // Continue loop (TCO) + case "fn*": + return _function('MAL_EVAL', 'native', + $ast[2], $env, $ast[1]); + default: + $el = eval_ast($ast, $env); + $f = $el[0]; + $args = array_slice($el->getArrayCopy(), 1); + if ($f->type === 'native') { + $ast = $f->ast; + $env = $f->gen_env($args); + // Continue loop (TCO) + } else { + return $f->apply($args); + } + } + + } +} + +// print +function MAL_PRINT($exp) { + return _pr_str($exp, True); +} + +// repl +$repl_env = new Env(NULL); +function rep($str) { + global $repl_env; + return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); +} + +// core.php: defined using PHP +foreach ($core_ns as $k=>$v) { + $repl_env->set(_symbol($k), _function($v)); +} +$repl_env->set(_symbol('eval'), _function(function($ast) { + global $repl_env; return MAL_EVAL($ast, $repl_env); +})); +$_argv = _list(); +for ($i=2; $i < count($argv); $i++) { + $_argv->append($argv[$i]); +} +$repl_env->set(_symbol('*ARGV*'), $_argv); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + +if (count($argv) > 1) { + rep('(load-file "' . $argv[1] . '")'); + exit(0); +} + +// repl loop +do { + try { + $line = mal_readline("user> "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/step7_quote.php b/impls/php/step7_quote.php index a3f2b1f59d..834fa2ab1b 100644 --- a/impls/php/step7_quote.php +++ b/impls/php/step7_quote.php @@ -1,187 +1,187 @@ -value === 'splice-unquote') { - return _list(_symbol("concat"), $elt[1], $acc); - } else { - return _list(_symbol("cons"), quasiquote($elt), $acc); - } -} - -function qq_foldr($xs) { - $acc = _list(); - for ($i=count($xs)-1; 0<=$i; $i-=1) { - $acc = qq_loop($xs[$i], $acc); - } - return $acc; -} - -function quasiquote($ast) { - if (_vector_Q($ast)) { - return _list(_symbol("vec"), qq_foldr($ast)); - } elseif (_symbol_Q($ast) or _hash_map_Q($ast)) { - return _list(_symbol("quote"), $ast); - } elseif (!_list_Q($ast)) { - return $ast; - } elseif (count($ast) == 2 and _symbol_Q($ast[0]) and $ast[0]->value === 'unquote') { - return $ast[1]; - } else { - return qq_foldr($ast); - } -} - -function eval_ast($ast, $env) { - if (_symbol_Q($ast)) { - return $env->get($ast); - } elseif (_sequential_Q($ast)) { - if (_list_Q($ast)) { - $el = _list(); - } else { - $el = _vector(); - } - foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } - return $el; - } elseif (_hash_map_Q($ast)) { - $new_hm = _hash_map(); - foreach (array_keys($ast->getArrayCopy()) as $key) { - $new_hm[$key] = MAL_EVAL($ast[$key], $env); - } - return $new_hm; - } else { - return $ast; - } -} - -function MAL_EVAL($ast, $env) { - while (true) { - - #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - if ($ast->count() === 0) { - return $ast; - } - - // apply list - $a0 = $ast[0]; - $a0v = (_symbol_Q($a0) ? $a0->value : $a0); - switch ($a0v) { - case "def!": - $res = MAL_EVAL($ast[2], $env); - return $env->set($ast[1], $res); - case "let*": - $a1 = $ast[1]; - $let_env = new Env($env); - for ($i=0; $i < count($a1); $i+=2) { - $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); - } - $ast = $ast[2]; - $env = $let_env; - break; // Continue loop (TCO) - case "quote": - return $ast[1]; - case "quasiquoteexpand": - return quasiquote($ast[1]); - case "quasiquote": - $ast = quasiquote($ast[1]); - break; // Continue loop (TCO) - case "do": - eval_ast($ast->slice(1, -1), $env); - $ast = $ast[count($ast)-1]; - break; // Continue loop (TCO) - case "if": - $cond = MAL_EVAL($ast[1], $env); - if ($cond === NULL || $cond === false) { - if (count($ast) === 4) { $ast = $ast[3]; } - else { $ast = NULL; } - } else { - $ast = $ast[2]; - } - break; // Continue loop (TCO) - case "fn*": - return _function('MAL_EVAL', 'native', - $ast[2], $env, $ast[1]); - default: - $el = eval_ast($ast, $env); - $f = $el[0]; - $args = array_slice($el->getArrayCopy(), 1); - if ($f->type === 'native') { - $ast = $f->ast; - $env = $f->gen_env($args); - // Continue loop (TCO) - } else { - return $f->apply($args); - } - } - - } -} - -// print -function MAL_PRINT($exp) { - return _pr_str($exp, True); -} - -// repl -$repl_env = new Env(NULL); -function rep($str) { - global $repl_env; - return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); -} - -// core.php: defined using PHP -foreach ($core_ns as $k=>$v) { - $repl_env->set(_symbol($k), _function($v)); -} -$repl_env->set(_symbol('eval'), _function(function($ast) { - global $repl_env; return MAL_EVAL($ast, $repl_env); -})); -$_argv = _list(); -for ($i=2; $i < count($argv); $i++) { - $_argv->append($argv[$i]); -} -$repl_env->set(_symbol('*ARGV*'), $_argv); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); - -if (count($argv) > 1) { - rep('(load-file "' . $argv[1] . '")'); - exit(0); -} - -// repl loop -do { - try { - $line = mal_readline("user> "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> +value === 'splice-unquote') { + return _list(_symbol("concat"), $elt[1], $acc); + } else { + return _list(_symbol("cons"), quasiquote($elt), $acc); + } +} + +function qq_foldr($xs) { + $acc = _list(); + for ($i=count($xs)-1; 0<=$i; $i-=1) { + $acc = qq_loop($xs[$i], $acc); + } + return $acc; +} + +function quasiquote($ast) { + if (_vector_Q($ast)) { + return _list(_symbol("vec"), qq_foldr($ast)); + } elseif (_symbol_Q($ast) or _hash_map_Q($ast)) { + return _list(_symbol("quote"), $ast); + } elseif (!_list_Q($ast)) { + return $ast; + } elseif (count($ast) == 2 and _symbol_Q($ast[0]) and $ast[0]->value === 'unquote') { + return $ast[1]; + } else { + return qq_foldr($ast); + } +} + +function eval_ast($ast, $env) { + if (_symbol_Q($ast)) { + return $env->get($ast); + } elseif (_sequential_Q($ast)) { + if (_list_Q($ast)) { + $el = _list(); + } else { + $el = _vector(); + } + foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } + return $el; + } elseif (_hash_map_Q($ast)) { + $new_hm = _hash_map(); + foreach (array_keys($ast->getArrayCopy()) as $key) { + $new_hm[$key] = MAL_EVAL($ast[$key], $env); + } + return $new_hm; + } else { + return $ast; + } +} + +function MAL_EVAL($ast, $env) { + while (true) { + + #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + if ($ast->count() === 0) { + return $ast; + } + + // apply list + $a0 = $ast[0]; + $a0v = (_symbol_Q($a0) ? $a0->value : $a0); + switch ($a0v) { + case "def!": + $res = MAL_EVAL($ast[2], $env); + return $env->set($ast[1], $res); + case "let*": + $a1 = $ast[1]; + $let_env = new Env($env); + for ($i=0; $i < count($a1); $i+=2) { + $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); + } + $ast = $ast[2]; + $env = $let_env; + break; // Continue loop (TCO) + case "quote": + return $ast[1]; + case "quasiquoteexpand": + return quasiquote($ast[1]); + case "quasiquote": + $ast = quasiquote($ast[1]); + break; // Continue loop (TCO) + case "do": + eval_ast($ast->slice(1, -1), $env); + $ast = $ast[count($ast)-1]; + break; // Continue loop (TCO) + case "if": + $cond = MAL_EVAL($ast[1], $env); + if ($cond === NULL || $cond === false) { + if (count($ast) === 4) { $ast = $ast[3]; } + else { $ast = NULL; } + } else { + $ast = $ast[2]; + } + break; // Continue loop (TCO) + case "fn*": + return _function('MAL_EVAL', 'native', + $ast[2], $env, $ast[1]); + default: + $el = eval_ast($ast, $env); + $f = $el[0]; + $args = array_slice($el->getArrayCopy(), 1); + if ($f->type === 'native') { + $ast = $f->ast; + $env = $f->gen_env($args); + // Continue loop (TCO) + } else { + return $f->apply($args); + } + } + + } +} + +// print +function MAL_PRINT($exp) { + return _pr_str($exp, True); +} + +// repl +$repl_env = new Env(NULL); +function rep($str) { + global $repl_env; + return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); +} + +// core.php: defined using PHP +foreach ($core_ns as $k=>$v) { + $repl_env->set(_symbol($k), _function($v)); +} +$repl_env->set(_symbol('eval'), _function(function($ast) { + global $repl_env; return MAL_EVAL($ast, $repl_env); +})); +$_argv = _list(); +for ($i=2; $i < count($argv); $i++) { + $_argv->append($argv[$i]); +} +$repl_env->set(_symbol('*ARGV*'), $_argv); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); + +if (count($argv) > 1) { + rep('(load-file "' . $argv[1] . '")'); + exit(0); +} + +// repl loop +do { + try { + $line = mal_readline("user> "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/step8_macros.php b/impls/php/step8_macros.php index 1ada35f4b9..336cdd382b 100644 --- a/impls/php/step8_macros.php +++ b/impls/php/step8_macros.php @@ -1,217 +1,217 @@ -value === 'splice-unquote') { - return _list(_symbol("concat"), $elt[1], $acc); - } else { - return _list(_symbol("cons"), quasiquote($elt), $acc); - } -} - -function qq_foldr($xs) { - $acc = _list(); - for ($i=count($xs)-1; 0<=$i; $i-=1) { - $acc = qq_loop($xs[$i], $acc); - } - return $acc; -} - -function quasiquote($ast) { - if (_vector_Q($ast)) { - return _list(_symbol("vec"), qq_foldr($ast)); - } elseif (_symbol_Q($ast) or _hash_map_Q($ast)) { - return _list(_symbol("quote"), $ast); - } elseif (!_list_Q($ast)) { - return $ast; - } elseif (count($ast) == 2 and _symbol_Q($ast[0]) and $ast[0]->value === 'unquote') { - return $ast[1]; - } else { - return qq_foldr($ast); - } -} - -function is_macro_call($ast, $env) { - return _list_Q($ast) && - count($ast) >0 && - _symbol_Q($ast[0]) && - $env->find($ast[0]) && - $env->get($ast[0])->ismacro; -} - -function macroexpand($ast, $env) { - while (is_macro_call($ast, $env)) { - $mac = $env->get($ast[0]); - $args = array_slice($ast->getArrayCopy(),1); - $ast = $mac->apply($args); - } - return $ast; -} - -function eval_ast($ast, $env) { - if (_symbol_Q($ast)) { - return $env->get($ast); - } elseif (_sequential_Q($ast)) { - if (_list_Q($ast)) { - $el = _list(); - } else { - $el = _vector(); - } - foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } - return $el; - } elseif (_hash_map_Q($ast)) { - $new_hm = _hash_map(); - foreach (array_keys($ast->getArrayCopy()) as $key) { - $new_hm[$key] = MAL_EVAL($ast[$key], $env); - } - return $new_hm; - } else { - return $ast; - } -} - -function MAL_EVAL($ast, $env) { - while (true) { - - #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - - // apply list - $ast = macroexpand($ast, $env); - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - if ($ast->count() === 0) { - return $ast; - } - - $a0 = $ast[0]; - $a0v = (_symbol_Q($a0) ? $a0->value : $a0); - switch ($a0v) { - case "def!": - $res = MAL_EVAL($ast[2], $env); - return $env->set($ast[1], $res); - case "let*": - $a1 = $ast[1]; - $let_env = new Env($env); - for ($i=0; $i < count($a1); $i+=2) { - $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); - } - $ast = $ast[2]; - $env = $let_env; - break; // Continue loop (TCO) - case "quote": - return $ast[1]; - case "quasiquoteexpand": - return quasiquote($ast[1]); - case "quasiquote": - $ast = quasiquote($ast[1]); - break; // Continue loop (TCO) - case "defmacro!": - $func = MAL_EVAL($ast[2], $env); - $func = _function('MAL_EVAL', 'native', $func->ast, $func->env, $func->params); - $func->ismacro = true; - return $env->set($ast[1], $func); - case "macroexpand": - return macroexpand($ast[1], $env); - case "do": - eval_ast($ast->slice(1, -1), $env); - $ast = $ast[count($ast)-1]; - break; // Continue loop (TCO) - case "if": - $cond = MAL_EVAL($ast[1], $env); - if ($cond === NULL || $cond === false) { - if (count($ast) === 4) { $ast = $ast[3]; } - else { $ast = NULL; } - } else { - $ast = $ast[2]; - } - break; // Continue loop (TCO) - case "fn*": - return _function('MAL_EVAL', 'native', - $ast[2], $env, $ast[1]); - default: - $el = eval_ast($ast, $env); - $f = $el[0]; - $args = array_slice($el->getArrayCopy(), 1); - if ($f->type === 'native') { - $ast = $f->ast; - $env = $f->gen_env($args); - // Continue loop (TCO) - } else { - return $f->apply($args); - } - } - - } -} - -// print -function MAL_PRINT($exp) { - return _pr_str($exp, True); -} - -// repl -$repl_env = new Env(NULL); -function rep($str) { - global $repl_env; - return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); -} - -// core.php: defined using PHP -foreach ($core_ns as $k=>$v) { - $repl_env->set(_symbol($k), _function($v)); -} -$repl_env->set(_symbol('eval'), _function(function($ast) { - global $repl_env; return MAL_EVAL($ast, $repl_env); -})); -$_argv = _list(); -for ($i=2; $i < count($argv); $i++) { - $_argv->append($argv[$i]); -} -$repl_env->set(_symbol('*ARGV*'), $_argv); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -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)))))))"); - -if (count($argv) > 1) { - rep('(load-file "' . $argv[1] . '")'); - exit(0); -} - -// repl loop -do { - try { - $line = mal_readline("user> "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> +value === 'splice-unquote') { + return _list(_symbol("concat"), $elt[1], $acc); + } else { + return _list(_symbol("cons"), quasiquote($elt), $acc); + } +} + +function qq_foldr($xs) { + $acc = _list(); + for ($i=count($xs)-1; 0<=$i; $i-=1) { + $acc = qq_loop($xs[$i], $acc); + } + return $acc; +} + +function quasiquote($ast) { + if (_vector_Q($ast)) { + return _list(_symbol("vec"), qq_foldr($ast)); + } elseif (_symbol_Q($ast) or _hash_map_Q($ast)) { + return _list(_symbol("quote"), $ast); + } elseif (!_list_Q($ast)) { + return $ast; + } elseif (count($ast) == 2 and _symbol_Q($ast[0]) and $ast[0]->value === 'unquote') { + return $ast[1]; + } else { + return qq_foldr($ast); + } +} + +function is_macro_call($ast, $env) { + return _list_Q($ast) && + count($ast) >0 && + _symbol_Q($ast[0]) && + $env->find($ast[0]) && + $env->get($ast[0])->ismacro; +} + +function macroexpand($ast, $env) { + while (is_macro_call($ast, $env)) { + $mac = $env->get($ast[0]); + $args = array_slice($ast->getArrayCopy(),1); + $ast = $mac->apply($args); + } + return $ast; +} + +function eval_ast($ast, $env) { + if (_symbol_Q($ast)) { + return $env->get($ast); + } elseif (_sequential_Q($ast)) { + if (_list_Q($ast)) { + $el = _list(); + } else { + $el = _vector(); + } + foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } + return $el; + } elseif (_hash_map_Q($ast)) { + $new_hm = _hash_map(); + foreach (array_keys($ast->getArrayCopy()) as $key) { + $new_hm[$key] = MAL_EVAL($ast[$key], $env); + } + return $new_hm; + } else { + return $ast; + } +} + +function MAL_EVAL($ast, $env) { + while (true) { + + #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + + // apply list + $ast = macroexpand($ast, $env); + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + if ($ast->count() === 0) { + return $ast; + } + + $a0 = $ast[0]; + $a0v = (_symbol_Q($a0) ? $a0->value : $a0); + switch ($a0v) { + case "def!": + $res = MAL_EVAL($ast[2], $env); + return $env->set($ast[1], $res); + case "let*": + $a1 = $ast[1]; + $let_env = new Env($env); + for ($i=0; $i < count($a1); $i+=2) { + $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); + } + $ast = $ast[2]; + $env = $let_env; + break; // Continue loop (TCO) + case "quote": + return $ast[1]; + case "quasiquoteexpand": + return quasiquote($ast[1]); + case "quasiquote": + $ast = quasiquote($ast[1]); + break; // Continue loop (TCO) + case "defmacro!": + $func = MAL_EVAL($ast[2], $env); + $func = _function('MAL_EVAL', 'native', $func->ast, $func->env, $func->params); + $func->ismacro = true; + return $env->set($ast[1], $func); + case "macroexpand": + return macroexpand($ast[1], $env); + case "do": + eval_ast($ast->slice(1, -1), $env); + $ast = $ast[count($ast)-1]; + break; // Continue loop (TCO) + case "if": + $cond = MAL_EVAL($ast[1], $env); + if ($cond === NULL || $cond === false) { + if (count($ast) === 4) { $ast = $ast[3]; } + else { $ast = NULL; } + } else { + $ast = $ast[2]; + } + break; // Continue loop (TCO) + case "fn*": + return _function('MAL_EVAL', 'native', + $ast[2], $env, $ast[1]); + default: + $el = eval_ast($ast, $env); + $f = $el[0]; + $args = array_slice($el->getArrayCopy(), 1); + if ($f->type === 'native') { + $ast = $f->ast; + $env = $f->gen_env($args); + // Continue loop (TCO) + } else { + return $f->apply($args); + } + } + + } +} + +// print +function MAL_PRINT($exp) { + return _pr_str($exp, True); +} + +// repl +$repl_env = new Env(NULL); +function rep($str) { + global $repl_env; + return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); +} + +// core.php: defined using PHP +foreach ($core_ns as $k=>$v) { + $repl_env->set(_symbol($k), _function($v)); +} +$repl_env->set(_symbol('eval'), _function(function($ast) { + global $repl_env; return MAL_EVAL($ast, $repl_env); +})); +$_argv = _list(); +for ($i=2; $i < count($argv); $i++) { + $_argv->append($argv[$i]); +} +$repl_env->set(_symbol('*ARGV*'), $_argv); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +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)))))))"); + +if (count($argv) > 1) { + rep('(load-file "' . $argv[1] . '")'); + exit(0); +} + +// repl loop +do { + try { + $line = mal_readline("user> "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/step9_try.php b/impls/php/step9_try.php index 16927a60f1..c156fb94f3 100644 --- a/impls/php/step9_try.php +++ b/impls/php/step9_try.php @@ -1,237 +1,237 @@ -value === 'splice-unquote') { - return _list(_symbol("concat"), $elt[1], $acc); - } else { - return _list(_symbol("cons"), quasiquote($elt), $acc); - } -} - -function qq_foldr($xs) { - $acc = _list(); - for ($i=count($xs)-1; 0<=$i; $i-=1) { - $acc = qq_loop($xs[$i], $acc); - } - return $acc; -} - -function quasiquote($ast) { - if (_vector_Q($ast)) { - return _list(_symbol("vec"), qq_foldr($ast)); - } elseif (_symbol_Q($ast) or _hash_map_Q($ast)) { - return _list(_symbol("quote"), $ast); - } elseif (!_list_Q($ast)) { - return $ast; - } elseif (count($ast) == 2 and _symbol_Q($ast[0]) and $ast[0]->value === 'unquote') { - return $ast[1]; - } else { - return qq_foldr($ast); - } -} - -function is_macro_call($ast, $env) { - return _list_Q($ast) && - count($ast) >0 && - _symbol_Q($ast[0]) && - $env->find($ast[0]) && - $env->get($ast[0])->ismacro; -} - -function macroexpand($ast, $env) { - while (is_macro_call($ast, $env)) { - $mac = $env->get($ast[0]); - $args = array_slice($ast->getArrayCopy(),1); - $ast = $mac->apply($args); - } - return $ast; -} - -function eval_ast($ast, $env) { - if (_symbol_Q($ast)) { - return $env->get($ast); - } elseif (_sequential_Q($ast)) { - if (_list_Q($ast)) { - $el = _list(); - } else { - $el = _vector(); - } - foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } - return $el; - } elseif (_hash_map_Q($ast)) { - $new_hm = _hash_map(); - foreach (array_keys($ast->getArrayCopy()) as $key) { - $new_hm[$key] = MAL_EVAL($ast[$key], $env); - } - return $new_hm; - } else { - return $ast; - } -} - -function MAL_EVAL($ast, $env) { - while (true) { - - #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - - // apply list - $ast = macroexpand($ast, $env); - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - if ($ast->count() === 0) { - return $ast; - } - - $a0 = $ast[0]; - $a0v = (_symbol_Q($a0) ? $a0->value : $a0); - switch ($a0v) { - case "def!": - $res = MAL_EVAL($ast[2], $env); - return $env->set($ast[1], $res); - case "let*": - $a1 = $ast[1]; - $let_env = new Env($env); - for ($i=0; $i < count($a1); $i+=2) { - $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); - } - $ast = $ast[2]; - $env = $let_env; - break; // Continue loop (TCO) - case "quote": - return $ast[1]; - case "quasiquoteexpand": - return quasiquote($ast[1]); - case "quasiquote": - $ast = quasiquote($ast[1]); - break; // Continue loop (TCO) - case "defmacro!": - $func = MAL_EVAL($ast[2], $env); - $func = _function('MAL_EVAL', 'native', $func->ast, $func->env, $func->params); - $func->ismacro = true; - return $env->set($ast[1], $func); - case "macroexpand": - return macroexpand($ast[1], $env); - case "try*": - $a1 = $ast[1]; - $a2 = $ast[2]; - if ($a2[0]->value === "catch*") { - try { - return MAL_EVAL($a1, $env); - } catch (_Error $e) { - $catch_env = new Env($env, array($a2[1]), - array($e->obj)); - return MAL_EVAL($a2[2], $catch_env); - } catch (Exception $e) { - $catch_env = new Env($env, array($a2[1]), - array($e->getMessage())); - return MAL_EVAL($a2[2], $catch_env); - } - } else { - return MAL_EVAL($a1, $env); - } - case "do": - eval_ast($ast->slice(1, -1), $env); - $ast = $ast[count($ast)-1]; - break; // Continue loop (TCO) - case "if": - $cond = MAL_EVAL($ast[1], $env); - if ($cond === NULL || $cond === false) { - if (count($ast) === 4) { $ast = $ast[3]; } - else { $ast = NULL; } - } else { - $ast = $ast[2]; - } - break; // Continue loop (TCO) - case "fn*": - return _function('MAL_EVAL', 'native', - $ast[2], $env, $ast[1]); - default: - $el = eval_ast($ast, $env); - $f = $el[0]; - $args = array_slice($el->getArrayCopy(), 1); - if ($f->type === 'native') { - $ast = $f->ast; - $env = $f->gen_env($args); - // Continue loop (TCO) - } else { - return $f->apply($args); - } - } - - } -} - -// print -function MAL_PRINT($exp) { - return _pr_str($exp, True); -} - -// repl -$repl_env = new Env(NULL); -function rep($str) { - global $repl_env; - return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); -} - -// core.php: defined using PHP -foreach ($core_ns as $k=>$v) { - $repl_env->set(_symbol($k), _function($v)); -} -$repl_env->set(_symbol('eval'), _function(function($ast) { - global $repl_env; return MAL_EVAL($ast, $repl_env); -})); -$_argv = _list(); -for ($i=2; $i < count($argv); $i++) { - $_argv->append($argv[$i]); -} -$repl_env->set(_symbol('*ARGV*'), $_argv); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -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)))))))"); - -if (count($argv) > 1) { - rep('(load-file "' . $argv[1] . '")'); - exit(0); -} - -// repl loop -do { - try { - $line = mal_readline("user> "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (_Error $e) { - echo "Error: " . _pr_str($e->obj, True) . "\n"; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> +value === 'splice-unquote') { + return _list(_symbol("concat"), $elt[1], $acc); + } else { + return _list(_symbol("cons"), quasiquote($elt), $acc); + } +} + +function qq_foldr($xs) { + $acc = _list(); + for ($i=count($xs)-1; 0<=$i; $i-=1) { + $acc = qq_loop($xs[$i], $acc); + } + return $acc; +} + +function quasiquote($ast) { + if (_vector_Q($ast)) { + return _list(_symbol("vec"), qq_foldr($ast)); + } elseif (_symbol_Q($ast) or _hash_map_Q($ast)) { + return _list(_symbol("quote"), $ast); + } elseif (!_list_Q($ast)) { + return $ast; + } elseif (count($ast) == 2 and _symbol_Q($ast[0]) and $ast[0]->value === 'unquote') { + return $ast[1]; + } else { + return qq_foldr($ast); + } +} + +function is_macro_call($ast, $env) { + return _list_Q($ast) && + count($ast) >0 && + _symbol_Q($ast[0]) && + $env->find($ast[0]) && + $env->get($ast[0])->ismacro; +} + +function macroexpand($ast, $env) { + while (is_macro_call($ast, $env)) { + $mac = $env->get($ast[0]); + $args = array_slice($ast->getArrayCopy(),1); + $ast = $mac->apply($args); + } + return $ast; +} + +function eval_ast($ast, $env) { + if (_symbol_Q($ast)) { + return $env->get($ast); + } elseif (_sequential_Q($ast)) { + if (_list_Q($ast)) { + $el = _list(); + } else { + $el = _vector(); + } + foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } + return $el; + } elseif (_hash_map_Q($ast)) { + $new_hm = _hash_map(); + foreach (array_keys($ast->getArrayCopy()) as $key) { + $new_hm[$key] = MAL_EVAL($ast[$key], $env); + } + return $new_hm; + } else { + return $ast; + } +} + +function MAL_EVAL($ast, $env) { + while (true) { + + #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + + // apply list + $ast = macroexpand($ast, $env); + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + if ($ast->count() === 0) { + return $ast; + } + + $a0 = $ast[0]; + $a0v = (_symbol_Q($a0) ? $a0->value : $a0); + switch ($a0v) { + case "def!": + $res = MAL_EVAL($ast[2], $env); + return $env->set($ast[1], $res); + case "let*": + $a1 = $ast[1]; + $let_env = new Env($env); + for ($i=0; $i < count($a1); $i+=2) { + $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); + } + $ast = $ast[2]; + $env = $let_env; + break; // Continue loop (TCO) + case "quote": + return $ast[1]; + case "quasiquoteexpand": + return quasiquote($ast[1]); + case "quasiquote": + $ast = quasiquote($ast[1]); + break; // Continue loop (TCO) + case "defmacro!": + $func = MAL_EVAL($ast[2], $env); + $func = _function('MAL_EVAL', 'native', $func->ast, $func->env, $func->params); + $func->ismacro = true; + return $env->set($ast[1], $func); + case "macroexpand": + return macroexpand($ast[1], $env); + case "try*": + $a1 = $ast[1]; + $a2 = $ast[2]; + if ($a2[0]->value === "catch*") { + try { + return MAL_EVAL($a1, $env); + } catch (_Error $e) { + $catch_env = new Env($env, array($a2[1]), + array($e->obj)); + return MAL_EVAL($a2[2], $catch_env); + } catch (Exception $e) { + $catch_env = new Env($env, array($a2[1]), + array($e->getMessage())); + return MAL_EVAL($a2[2], $catch_env); + } + } else { + return MAL_EVAL($a1, $env); + } + case "do": + eval_ast($ast->slice(1, -1), $env); + $ast = $ast[count($ast)-1]; + break; // Continue loop (TCO) + case "if": + $cond = MAL_EVAL($ast[1], $env); + if ($cond === NULL || $cond === false) { + if (count($ast) === 4) { $ast = $ast[3]; } + else { $ast = NULL; } + } else { + $ast = $ast[2]; + } + break; // Continue loop (TCO) + case "fn*": + return _function('MAL_EVAL', 'native', + $ast[2], $env, $ast[1]); + default: + $el = eval_ast($ast, $env); + $f = $el[0]; + $args = array_slice($el->getArrayCopy(), 1); + if ($f->type === 'native') { + $ast = $f->ast; + $env = $f->gen_env($args); + // Continue loop (TCO) + } else { + return $f->apply($args); + } + } + + } +} + +// print +function MAL_PRINT($exp) { + return _pr_str($exp, True); +} + +// repl +$repl_env = new Env(NULL); +function rep($str) { + global $repl_env; + return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); +} + +// core.php: defined using PHP +foreach ($core_ns as $k=>$v) { + $repl_env->set(_symbol($k), _function($v)); +} +$repl_env->set(_symbol('eval'), _function(function($ast) { + global $repl_env; return MAL_EVAL($ast, $repl_env); +})); +$_argv = _list(); +for ($i=2; $i < count($argv); $i++) { + $_argv->append($argv[$i]); +} +$repl_env->set(_symbol('*ARGV*'), $_argv); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +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)))))))"); + +if (count($argv) > 1) { + rep('(load-file "' . $argv[1] . '")'); + exit(0); +} + +// repl loop +do { + try { + $line = mal_readline("user> "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (_Error $e) { + echo "Error: " . _pr_str($e->obj, True) . "\n"; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/stepA_mal.php b/impls/php/stepA_mal.php index 6e57ab6445..8a419a32ea 100644 --- a/impls/php/stepA_mal.php +++ b/impls/php/stepA_mal.php @@ -1,248 +1,248 @@ -value === 'splice-unquote') { - return _list(_symbol("concat"), $elt[1], $acc); - } else { - return _list(_symbol("cons"), quasiquote($elt), $acc); - } -} - -function qq_foldr($xs) { - $acc = _list(); - for ($i=count($xs)-1; 0<=$i; $i-=1) { - $acc = qq_loop($xs[$i], $acc); - } - return $acc; -} - -function quasiquote($ast) { - if (_vector_Q($ast)) { - return _list(_symbol("vec"), qq_foldr($ast)); - } elseif (_symbol_Q($ast) or _hash_map_Q($ast)) { - return _list(_symbol("quote"), $ast); - } elseif (!_list_Q($ast)) { - return $ast; - } elseif (count($ast) == 2 and _symbol_Q($ast[0]) and $ast[0]->value === 'unquote') { - return $ast[1]; - } else { - return qq_foldr($ast); - } -} - -function is_macro_call($ast, $env) { - return _list_Q($ast) && - count($ast) >0 && - _symbol_Q($ast[0]) && - $env->find($ast[0]) && - $env->get($ast[0])->ismacro; -} - -function macroexpand($ast, $env) { - while (is_macro_call($ast, $env)) { - $mac = $env->get($ast[0]); - $args = array_slice($ast->getArrayCopy(),1); - $ast = $mac->apply($args); - } - return $ast; -} - -function eval_ast($ast, $env) { - if (_symbol_Q($ast)) { - return $env->get($ast); - } elseif (_sequential_Q($ast)) { - if (_list_Q($ast)) { - $el = _list(); - } else { - $el = _vector(); - } - foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } - return $el; - } elseif (_hash_map_Q($ast)) { - $new_hm = _hash_map(); - foreach (array_keys($ast->getArrayCopy()) as $key) { - $new_hm[$key] = MAL_EVAL($ast[$key], $env); - } - return $new_hm; - } else { - return $ast; - } -} - -function MAL_EVAL($ast, $env) { - while (true) { - - #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - - // apply list - $ast = macroexpand($ast, $env); - if (!_list_Q($ast)) { - return eval_ast($ast, $env); - } - if ($ast->count() === 0) { - return $ast; - } - - $a0 = $ast[0]; - $a0v = (_symbol_Q($a0) ? $a0->value : $a0); - switch ($a0v) { - case "def!": - $res = MAL_EVAL($ast[2], $env); - return $env->set($ast[1], $res); - case "let*": - $a1 = $ast[1]; - $let_env = new Env($env); - for ($i=0; $i < count($a1); $i+=2) { - $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); - } - $ast = $ast[2]; - $env = $let_env; - break; // Continue loop (TCO) - case "quote": - return $ast[1]; - case "quasiquoteexpand": - return quasiquote($ast[1]); - case "quasiquote": - $ast = quasiquote($ast[1]); - break; // Continue loop (TCO) - case "defmacro!": - $func = MAL_EVAL($ast[2], $env); - $func = _function('MAL_EVAL', 'native', $func->ast, $func->env, $func->params); - $func->ismacro = true; - return $env->set($ast[1], $func); - case "macroexpand": - return macroexpand($ast[1], $env); - case "php*": - $res = eval($ast[1]); - return _to_mal($res); - case "try*": - $a1 = $ast[1]; - $a2 = $ast[2]; - if ($a2[0]->value === "catch*") { - try { - return MAL_EVAL($a1, $env); - } catch (_Error $e) { - $catch_env = new Env($env, array($a2[1]), - array($e->obj)); - return MAL_EVAL($a2[2], $catch_env); - } catch (Exception $e) { - $catch_env = new Env($env, array($a2[1]), - array($e->getMessage())); - return MAL_EVAL($a2[2], $catch_env); - } - } else { - return MAL_EVAL($a1, $env); - } - case "do": - eval_ast($ast->slice(1, -1), $env); - $ast = $ast[count($ast)-1]; - break; // Continue loop (TCO) - case "if": - $cond = MAL_EVAL($ast[1], $env); - if ($cond === NULL || $cond === false) { - if (count($ast) === 4) { $ast = $ast[3]; } - else { $ast = NULL; } - } else { - $ast = $ast[2]; - } - break; // Continue loop (TCO) - case "fn*": - return _function('MAL_EVAL', 'native', - $ast[2], $env, $ast[1]); - case "to-native": - return _to_native($ast[1]->value, $env); - default: - $el = eval_ast($ast, $env); - $f = $el[0]; - $args = array_slice($el->getArrayCopy(), 1); - if ($f->type === 'native') { - $ast = $f->ast; - $env = $f->gen_env($args); - // Continue loop (TCO) - } else { - return $f->apply($args); - } - } - - } -} - -// print -function MAL_PRINT($exp) { - return _pr_str($exp, True); -} - -// repl -$repl_env = new Env(NULL); -function rep($str) { - global $repl_env; - return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); -} - -// core.php: defined using PHP -foreach ($core_ns as $k=>$v) { - $repl_env->set(_symbol($k), _function($v)); -} -$repl_env->set(_symbol('eval'), _function(function($ast) { - global $repl_env; return MAL_EVAL($ast, $repl_env); -})); -$_argv = _list(); -if (isset($argv)) { - for ($i=2; $i < count($argv); $i++) { - $_argv->append($argv[$i]); - } -} -$repl_env->set(_symbol('*ARGV*'), $_argv); - -// core.mal: defined using the language itself -rep("(def! *host-language* \"php\")"); -rep("(def! not (fn* (a) (if a false true)))"); -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); -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)))))))"); - -// run mal file -if (count($argv) > 1) { - rep('(load-file "' . $argv[1] . '")'); - exit(0); -} - -// repl loop -rep("(println (str \"Mal [\" *host-language* \"]\"))"); -do { - try { - $line = mal_readline("user> "); - if ($line === NULL) { break; } - if ($line !== "") { - print(rep($line) . "\n"); - } - } catch (BlankException $e) { - continue; - } catch (_Error $e) { - echo "Error: " . _pr_str($e->obj, True) . "\n"; - } catch (Exception $e) { - echo "Error: " . $e->getMessage() . "\n"; - echo $e->getTraceAsString() . "\n"; - } -} while (true); - -?> +value === 'splice-unquote') { + return _list(_symbol("concat"), $elt[1], $acc); + } else { + return _list(_symbol("cons"), quasiquote($elt), $acc); + } +} + +function qq_foldr($xs) { + $acc = _list(); + for ($i=count($xs)-1; 0<=$i; $i-=1) { + $acc = qq_loop($xs[$i], $acc); + } + return $acc; +} + +function quasiquote($ast) { + if (_vector_Q($ast)) { + return _list(_symbol("vec"), qq_foldr($ast)); + } elseif (_symbol_Q($ast) or _hash_map_Q($ast)) { + return _list(_symbol("quote"), $ast); + } elseif (!_list_Q($ast)) { + return $ast; + } elseif (count($ast) == 2 and _symbol_Q($ast[0]) and $ast[0]->value === 'unquote') { + return $ast[1]; + } else { + return qq_foldr($ast); + } +} + +function is_macro_call($ast, $env) { + return _list_Q($ast) && + count($ast) >0 && + _symbol_Q($ast[0]) && + $env->find($ast[0]) && + $env->get($ast[0])->ismacro; +} + +function macroexpand($ast, $env) { + while (is_macro_call($ast, $env)) { + $mac = $env->get($ast[0]); + $args = array_slice($ast->getArrayCopy(),1); + $ast = $mac->apply($args); + } + return $ast; +} + +function eval_ast($ast, $env) { + if (_symbol_Q($ast)) { + return $env->get($ast); + } elseif (_sequential_Q($ast)) { + if (_list_Q($ast)) { + $el = _list(); + } else { + $el = _vector(); + } + foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); } + return $el; + } elseif (_hash_map_Q($ast)) { + $new_hm = _hash_map(); + foreach (array_keys($ast->getArrayCopy()) as $key) { + $new_hm[$key] = MAL_EVAL($ast[$key], $env); + } + return $new_hm; + } else { + return $ast; + } +} + +function MAL_EVAL($ast, $env) { + while (true) { + + #echo "MAL_EVAL: " . _pr_str($ast) . "\n"; + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + + // apply list + $ast = macroexpand($ast, $env); + if (!_list_Q($ast)) { + return eval_ast($ast, $env); + } + if ($ast->count() === 0) { + return $ast; + } + + $a0 = $ast[0]; + $a0v = (_symbol_Q($a0) ? $a0->value : $a0); + switch ($a0v) { + case "def!": + $res = MAL_EVAL($ast[2], $env); + return $env->set($ast[1], $res); + case "let*": + $a1 = $ast[1]; + $let_env = new Env($env); + for ($i=0; $i < count($a1); $i+=2) { + $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env)); + } + $ast = $ast[2]; + $env = $let_env; + break; // Continue loop (TCO) + case "quote": + return $ast[1]; + case "quasiquoteexpand": + return quasiquote($ast[1]); + case "quasiquote": + $ast = quasiquote($ast[1]); + break; // Continue loop (TCO) + case "defmacro!": + $func = MAL_EVAL($ast[2], $env); + $func = _function('MAL_EVAL', 'native', $func->ast, $func->env, $func->params); + $func->ismacro = true; + return $env->set($ast[1], $func); + case "macroexpand": + return macroexpand($ast[1], $env); + case "php*": + $res = eval($ast[1]); + return _to_mal($res); + case "try*": + $a1 = $ast[1]; + $a2 = $ast[2]; + if ($a2[0]->value === "catch*") { + try { + return MAL_EVAL($a1, $env); + } catch (_Error $e) { + $catch_env = new Env($env, array($a2[1]), + array($e->obj)); + return MAL_EVAL($a2[2], $catch_env); + } catch (Exception $e) { + $catch_env = new Env($env, array($a2[1]), + array($e->getMessage())); + return MAL_EVAL($a2[2], $catch_env); + } + } else { + return MAL_EVAL($a1, $env); + } + case "do": + eval_ast($ast->slice(1, -1), $env); + $ast = $ast[count($ast)-1]; + break; // Continue loop (TCO) + case "if": + $cond = MAL_EVAL($ast[1], $env); + if ($cond === NULL || $cond === false) { + if (count($ast) === 4) { $ast = $ast[3]; } + else { $ast = NULL; } + } else { + $ast = $ast[2]; + } + break; // Continue loop (TCO) + case "fn*": + return _function('MAL_EVAL', 'native', + $ast[2], $env, $ast[1]); + case "to-native": + return _to_native($ast[1]->value, $env); + default: + $el = eval_ast($ast, $env); + $f = $el[0]; + $args = array_slice($el->getArrayCopy(), 1); + if ($f->type === 'native') { + $ast = $f->ast; + $env = $f->gen_env($args); + // Continue loop (TCO) + } else { + return $f->apply($args); + } + } + + } +} + +// print +function MAL_PRINT($exp) { + return _pr_str($exp, True); +} + +// repl +$repl_env = new Env(NULL); +function rep($str) { + global $repl_env; + return MAL_PRINT(MAL_EVAL(READ($str), $repl_env)); +} + +// core.php: defined using PHP +foreach ($core_ns as $k=>$v) { + $repl_env->set(_symbol($k), _function($v)); +} +$repl_env->set(_symbol('eval'), _function(function($ast) { + global $repl_env; return MAL_EVAL($ast, $repl_env); +})); +$_argv = _list(); +if (isset($argv)) { + for ($i=2; $i < count($argv); $i++) { + $_argv->append($argv[$i]); + } +} +$repl_env->set(_symbol('*ARGV*'), $_argv); + +// core.mal: defined using the language itself +rep("(def! *host-language* \"php\")"); +rep("(def! not (fn* (a) (if a false true)))"); +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"); +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)))))))"); + +// run mal file +if (count($argv) > 1) { + rep('(load-file "' . $argv[1] . '")'); + exit(0); +} + +// repl loop +rep("(println (str \"Mal [\" *host-language* \"]\"))"); +do { + try { + $line = mal_readline("user> "); + if ($line === NULL) { break; } + if ($line !== "") { + print(rep($line) . "\n"); + } + } catch (BlankException $e) { + continue; + } catch (_Error $e) { + echo "Error: " . _pr_str($e->obj, True) . "\n"; + } catch (Exception $e) { + echo "Error: " . $e->getMessage() . "\n"; + echo $e->getTraceAsString() . "\n"; + } +} while (true); + +?> diff --git a/impls/php/tests/step5_tco.mal b/impls/php/tests/step5_tco.mal index d04796d469..086cb2e753 100644 --- a/impls/php/tests/step5_tco.mal +++ b/impls/php/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; PHP: skipping non-TCO recursion -;; Reason: completes at 10,000, unrecoverable segfault at 20,000 +;; PHP: skipping non-TCO recursion +;; Reason: completes at 10,000, unrecoverable segfault at 20,000 diff --git a/impls/php/tests/stepA_mal.mal b/impls/php/tests/stepA_mal.mal index de459cdbcf..3970676439 100644 --- a/impls/php/tests/stepA_mal.mal +++ b/impls/php/tests/stepA_mal.mal @@ -1,45 +1,45 @@ -;; Testing basic php interop - -(php* "return 7;") -;=>7 - -(php* "return '7';") -;=>"7" - -(php* "return array(7,8,9);") -;=>(7 8 9) - -(php* "return array(\"abc\" => 789);") -;=>{"abc" 789} - -(php* "print \"hello\n\";") -;/hello -;=>nil - -(php* "global $foo; $foo=8;") -(php* "global $foo; return $foo;") -;=>8 - -(php* "global $f; $f = function($v) { return 1+$v; };") -(php* "global $f; return array_map($f, array(1,2,3));") -;=>(2 3 4) - -;; testing native function calling - -(php/date "Y-m-d" 0) -;=>"1970-01-01" - -;; testing native function with mal callback - -(php/array_map (fn* [t] (if (> t 3) t)) [1 2 3 4 5 6]) -;=>(nil nil nil 4 5 6) - -;; testing superglobal variable access - -(get php/_SERVER "PHP_SELF") -;=>"../php/stepA_mal.php" - -;; testing PHP constants access - -php/FILE_APPEND -;=>8 +;; Testing basic php interop + +(php* "return 7;") +;=>7 + +(php* "return '7';") +;=>"7" + +(php* "return array(7,8,9);") +;=>(7 8 9) + +(php* "return array(\"abc\" => 789);") +;=>{"abc" 789} + +(php* "print \"hello\n\";") +;/hello +;=>nil + +(php* "global $foo; $foo=8;") +(php* "global $foo; return $foo;") +;=>8 + +(php* "global $f; $f = function($v) { return 1+$v; };") +(php* "global $f; return array_map($f, array(1,2,3));") +;=>(2 3 4) + +;; testing native function calling + +(php/date "Y-m-d" 0) +;=>"1970-01-01" + +;; testing native function with mal callback + +(php/array_map (fn* [t] (if (> t 3) t)) [1 2 3 4 5 6]) +;=>(nil nil nil 4 5 6) + +;; testing superglobal variable access + +(get php/_SERVER "PHP_SELF") +;=>"../php/stepA_mal.php" + +;; testing PHP constants access + +php/FILE_APPEND +;=>8 diff --git a/impls/php/types.php b/impls/php/types.php index 006bcc9f2c..341df3c1ad 100644 --- a/impls/php/types.php +++ b/impls/php/types.php @@ -1,225 +1,225 @@ -obj = $obj; - } -} - - -// General functions - -function _equal_Q($a, $b) { - $ota = gettype($a) === "object" ? get_class($a) : gettype($a); - $otb = gettype($b) === "object" ? get_class($b) : gettype($b); - if (!($ota === $otb or (_sequential_Q($a) and _sequential_Q($b)))) { - return false; - } elseif (_symbol_Q($a)) { - #print "ota: $ota, otb: $otb\n"; - return $a->value === $b->value; - } elseif (_list_Q($a) or _vector_Q($a)) { - if ($a->count() !== $b->count()) { return false; } - for ($i=0; $i<$a->count(); $i++) { - if (!_equal_Q($a[$i], $b[$i])) { return false; } - } - return true; - } elseif (_hash_map_Q($a)) { - if ($a->count() !== $b->count()) { return false; } - $hm1 = $a->getArrayCopy(); - $hm2 = $b->getArrayCopy(); - foreach (array_keys($hm1) as $k) { - if (!_equal_Q($hm1[$k], $hm2[$k])) { return false; } - } - return true; - } else { - return $a === $b; - } -} - -function _sequential_Q($seq) { return _list_Q($seq) or _vector_Q($seq); } - - -// Scalars -function _nil_Q($obj) { return $obj === NULL; } -function _true_Q($obj) { return $obj === true; } -function _false_Q($obj) { return $obj === false; } -function _string_Q($obj) { - return is_string($obj) && strpos($obj, chr(0x7f)) !== 0; -} -function _number_Q($obj) { return is_int($obj); } - - -// Symbols -class SymbolClass { - public $value = NULL; - public $meta = NULL; - public function __construct($value) { - $this->value = $value; - } -} -function _symbol($name) { return new SymbolClass($name); } -function _symbol_Q($obj) { return ($obj instanceof SymbolClass); } - -// Keywords -function _keyword($name) { - if (_keyword_Q($name)) { - return $name; - } else { - return chr(0x7f).$name; - } -} -function _keyword_Q($obj) { - return is_string($obj) && strpos($obj, chr(0x7f)) === 0; -} - - - -// Functions -class FunctionClass { - public $func = NULL; - public $type = 'native'; // 'native' or 'platform' - public $meta = NULL; - public $ast = NULL; - public $env = NULL; - public $params = NULL; - public $ismacro = False; - public function __construct($func, $type, - $ast, $env, $params, $ismacro=False) { - $this->func = $func; - $this->type = $type; - $this->ast = $ast; - #print_r($ast); - $this->env = $env; - $this->params = $params; - $this->ismacro = $ismacro; - } - public function __invoke() { - $args = func_get_args(); - if ($this->type === 'native') { - $fn_env = new Env($this->env, - $this->params, $args); - $evalf = $this->func; - return $evalf($this->ast, $fn_env); - } else { - return call_user_func_array($this->func, $args); - } - } - public function gen_env($args) { - return new Env($this->env, $this->params, $args); - } - public function apply($args) { - return call_user_func_array(array(&$this, '__invoke'),$args); - } -} - -function _function($func, $type='platform', - $ast=NULL, $env=NULL, $params=NULL, $ismacro=False) { - return new FunctionClass($func, $type, $ast, $env, $params, $ismacro); -} -function _function_Q($obj) { return $obj instanceof FunctionClass; } -function _fn_Q($obj) { return $obj instanceof Closure; } - - -// Parent class of list, vector -// http://www.php.net/manual/en/class.arrayobject.php -class SeqClass extends ArrayObject { - public function slice($start, $length=NULL) { - $sc = new $this(); - if ($start >= count($this)) { - $arr = array(); - } else { - $arr = array_slice($this->getArrayCopy(), $start, $length); - } - $sc->exchangeArray($arr); - return $sc; - } -} - - -// Lists -class ListClass extends SeqClass { - public $meta = NULL; -} - -function _list() { - $v = new ListClass(); - $v->exchangeArray(func_get_args()); - return $v; -} -function _list_Q($obj) { return $obj instanceof ListClass; } - - -// Vectors -class VectorClass extends SeqClass { - public $meta = NULL; -} - -function _vector() { - $v = new VectorClass(); - $v->exchangeArray(func_get_args()); - return $v; -} -function _vector_Q($obj) { return $obj instanceof VectorClass; } - - -// Hash Maps -class HashMapClass extends ArrayObject { - public $meta = NULL; -} - -function _hash_map() { - $args = func_get_args(); - if (count($args) % 2 === 1) { - throw new Exception("Odd number of hash map arguments"); - } - $hm = new HashMapClass(); - array_unshift($args, $hm); - return call_user_func_array('_assoc_BANG', $args); -} -function _hash_map_Q($obj) { return $obj instanceof HashMapClass; } - -function _assoc_BANG($hm) { - $args = func_get_args(); - if (count($args) % 2 !== 1) { - throw new Exception("Odd number of assoc arguments"); - } - for ($i=1; $ioffsetExists($ktoken)) { - unset($hm[$ktoken]); - } - } - return $hm; -} - - -// Atoms -class Atom { - public $value = NULL; - public $meta = NULL; - public function __construct($value) { - $this->value = $value; - } -} -function _atom($val) { return new Atom($val); } -function _atom_Q($atm) { return $atm instanceof Atom; } - -?> +obj = $obj; + } +} + + +// General functions + +function _equal_Q($a, $b) { + $ota = gettype($a) === "object" ? get_class($a) : gettype($a); + $otb = gettype($b) === "object" ? get_class($b) : gettype($b); + if (!($ota === $otb or (_sequential_Q($a) and _sequential_Q($b)))) { + return false; + } elseif (_symbol_Q($a)) { + #print "ota: $ota, otb: $otb\n"; + return $a->value === $b->value; + } elseif (_list_Q($a) or _vector_Q($a)) { + if ($a->count() !== $b->count()) { return false; } + for ($i=0; $i<$a->count(); $i++) { + if (!_equal_Q($a[$i], $b[$i])) { return false; } + } + return true; + } elseif (_hash_map_Q($a)) { + if ($a->count() !== $b->count()) { return false; } + $hm1 = $a->getArrayCopy(); + $hm2 = $b->getArrayCopy(); + foreach (array_keys($hm1) as $k) { + if (!_equal_Q($hm1[$k], $hm2[$k])) { return false; } + } + return true; + } else { + return $a === $b; + } +} + +function _sequential_Q($seq) { return _list_Q($seq) or _vector_Q($seq); } + + +// Scalars +function _nil_Q($obj) { return $obj === NULL; } +function _true_Q($obj) { return $obj === true; } +function _false_Q($obj) { return $obj === false; } +function _string_Q($obj) { + return is_string($obj) && strpos($obj, chr(0x7f)) !== 0; +} +function _number_Q($obj) { return is_int($obj); } + + +// Symbols +class SymbolClass { + public $value = NULL; + public $meta = NULL; + public function __construct($value) { + $this->value = $value; + } +} +function _symbol($name) { return new SymbolClass($name); } +function _symbol_Q($obj) { return ($obj instanceof SymbolClass); } + +// Keywords +function _keyword($name) { + if (_keyword_Q($name)) { + return $name; + } else { + return chr(0x7f).$name; + } +} +function _keyword_Q($obj) { + return is_string($obj) && strpos($obj, chr(0x7f)) === 0; +} + + + +// Functions +class FunctionClass { + public $func = NULL; + public $type = 'native'; // 'native' or 'platform' + public $meta = NULL; + public $ast = NULL; + public $env = NULL; + public $params = NULL; + public $ismacro = False; + public function __construct($func, $type, + $ast, $env, $params, $ismacro=False) { + $this->func = $func; + $this->type = $type; + $this->ast = $ast; + #print_r($ast); + $this->env = $env; + $this->params = $params; + $this->ismacro = $ismacro; + } + public function __invoke() { + $args = func_get_args(); + if ($this->type === 'native') { + $fn_env = new Env($this->env, + $this->params, $args); + $evalf = $this->func; + return $evalf($this->ast, $fn_env); + } else { + return call_user_func_array($this->func, $args); + } + } + public function gen_env($args) { + return new Env($this->env, $this->params, $args); + } + public function apply($args) { + return call_user_func_array(array(&$this, '__invoke'),$args); + } +} + +function _function($func, $type='platform', + $ast=NULL, $env=NULL, $params=NULL, $ismacro=False) { + return new FunctionClass($func, $type, $ast, $env, $params, $ismacro); +} +function _function_Q($obj) { return $obj instanceof FunctionClass; } +function _fn_Q($obj) { return $obj instanceof Closure; } + + +// Parent class of list, vector +// http://www.php.net/manual/en/class.arrayobject.php +class SeqClass extends ArrayObject { + public function slice($start, $length=NULL) { + $sc = new $this(); + if ($start >= count($this)) { + $arr = array(); + } else { + $arr = array_slice($this->getArrayCopy(), $start, $length); + } + $sc->exchangeArray($arr); + return $sc; + } +} + + +// Lists +class ListClass extends SeqClass { + public $meta = NULL; +} + +function _list() { + $v = new ListClass(); + $v->exchangeArray(func_get_args()); + return $v; +} +function _list_Q($obj) { return $obj instanceof ListClass; } + + +// Vectors +class VectorClass extends SeqClass { + public $meta = NULL; +} + +function _vector() { + $v = new VectorClass(); + $v->exchangeArray(func_get_args()); + return $v; +} +function _vector_Q($obj) { return $obj instanceof VectorClass; } + + +// Hash Maps +class HashMapClass extends ArrayObject { + public $meta = NULL; +} + +function _hash_map() { + $args = func_get_args(); + if (count($args) % 2 === 1) { + throw new Exception("Odd number of hash map arguments"); + } + $hm = new HashMapClass(); + array_unshift($args, $hm); + return call_user_func_array('_assoc_BANG', $args); +} +function _hash_map_Q($obj) { return $obj instanceof HashMapClass; } + +function _assoc_BANG($hm) { + $args = func_get_args(); + if (count($args) % 2 !== 1) { + throw new Exception("Odd number of assoc arguments"); + } + for ($i=1; $ioffsetExists($ktoken)) { + unset($hm[$ktoken]); + } + } + return $hm; +} + + +// Atoms +class Atom { + public $value = NULL; + public $meta = NULL; + public function __construct($value) { + $this->value = $value; + } +} +function _atom($val) { return new Atom($val); } +function _atom_Q($atm) { return $atm instanceof Atom; } + +?> diff --git a/impls/php/webrunner.php b/impls/php/webrunner.php index ce720a7f20..ae8f3b005f 100644 --- a/impls/php/webrunner.php +++ b/impls/php/webrunner.php @@ -1,8 +1,8 @@ - + diff --git a/impls/picolisp/Dockerfile b/impls/picolisp/Dockerfile index 36282ddb5e..ab4665090d 100644 --- a/impls/picolisp/Dockerfile +++ b/impls/picolisp/Dockerfile @@ -1,26 +1,26 @@ -FROM ubuntu:wily -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# picolisp -RUN apt-get -y install picolisp - +FROM ubuntu:wily +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# picolisp +RUN apt-get -y install picolisp + diff --git a/impls/picolisp/Makefile b/impls/picolisp/Makefile index 7af3113c71..14414a8c2b 100644 --- a/impls/picolisp/Makefile +++ b/impls/picolisp/Makefile @@ -1,3 +1,3 @@ -all: - -clean: +all: + +clean: diff --git a/impls/picolisp/core.l b/impls/picolisp/core.l index a549d782b7..f40940de46 100644 --- a/impls/picolisp/core.l +++ b/impls/picolisp/core.l @@ -1,180 +1,180 @@ -(de MAL-= (A B) - (let (A* (MAL-type A) - B* (MAL-type B)) - (cond - ((and (= A* 'map) (= B* 'map)) - (MAL-map-= (MAL-value A) (MAL-value B)) ) - ((and (memq A* '(list vector)) (memq B* '(list vector))) - (MAL-seq-= (MAL-value A) (MAL-value B)) ) - ((= A* B*) - (= (MAL-value A) (MAL-value B)) ) - (T NIL) ) ) ) - -(de MAL-map-= (As Bs) - (when (= (length As) (length Bs)) - (let (As* (chunk As) Bs* (chunk Bs)) - (catch 'result - (while As* - (let (A (pop 'As*) Key (MAL-value (car A)) Val (cdr A) - B (find '((X) (= Key (MAL-value (car X)))) Bs*) ) - (when (or (not B) (not (MAL-= Val (cdr B)))) - (throw 'result NIL) ) ) ) - T ) ) ) ) - -(de MAL-seq-= (As Bs) - (when (= (length As) (length Bs)) - (catch 'result - (while As - (ifn (MAL-= (pop 'As) (pop 'Bs)) - (throw 'result NIL) ) ) - T ) ) ) - -(de MAL-seq? (X) - (memq (MAL-type X) '(list vector)) ) - -(de MAL-f (X) - (MAL-value (if (isa '+Func X) (get X 'fn) X)) ) - -(de MAL-swap! @ - (let (X (next) Fn (next) Args (rest)) - (put X 'value (apply (MAL-f Fn) Args (MAL-value X))) ) ) - -(de MAL-nth (Seq N) - (let (Seq* (MAL-value Seq) N* (MAL-value N)) - (if (< N* (length Seq*)) - (nth Seq* (inc N*) 1) - (throw 'err (MAL-error (MAL-string "out of bounds"))) ) ) ) - -(de chunk (List) - (make - (for (L List L (cddr L)) - (link (cons (car L) (cadr L))) ) ) ) - -(de join (List) - (mapcan '((X) (list (car X) (cdr X))) List) ) - -(de MAL-assoc @ - (let (Map (next) Args (rest)) - (MAL-map - (append Args - (join - (filter '((X) (not (find '((Y) (MAL-= (car Y) (car X))) - (chunk Args) ) ) ) - (chunk (MAL-value Map)) ) ) ) ) ) ) - -(de MAL-dissoc @ - (let (Map (next) Args (rest)) - (MAL-map - (make - (for (L (MAL-value Map) L (cddr L)) - (unless (find '((X) (MAL-= (car L) X)) Args) - (link (car L) (cadr L)) ) ) ) ) ) ) - -(de MAL-seq (X) - (if (or (= (MAL-type X) 'nil) (not (MAL-value X))) - *MAL-nil - (case (MAL-type X) - (list X) - (vector (MAL-list (MAL-value X))) - (string (MAL-list (mapcar MAL-string (chop (MAL-value X))))) ) ) ) - -(de MAL-conj @ - (let (Seq (next) Args (rest)) - (if (= (MAL-type Seq) 'vector) - (MAL-vector (append (MAL-value Seq) Args)) - (MAL-list (append (reverse Args) (MAL-value Seq))) ) ) ) - -(de clone (X) - (let X* (new (val X)) - (maps '((C) (put X* (cdr C) (car C))) X) - X* ) ) - -(de pil-to-mal (X) - (cond - ((not X) *MAL-nil) - ((=T X) *MAL-true) - ((num? X) (MAL-number X)) - ((str? X) (MAL-string X)) - ((sym? X) (MAL-symbol X)) - ((lst? X) (MAL-list (mapcar pil-to-mal X))) - (T (MAL-string (sym X))) ) ) - -(def '*Ns - '((+ . `(MAL-fn '((A B) (MAL-number (+ (MAL-value A) (MAL-value B)))))) - (- . `(MAL-fn '((A B) (MAL-number (- (MAL-value A) (MAL-value B)))))) - (* . `(MAL-fn '((A B) (MAL-number (* (MAL-value A) (MAL-value B)))))) - (/ . `(MAL-fn '((A B) (MAL-number (/ (MAL-value A) (MAL-value B)))))) - - (< . `(MAL-fn '((A B) (if (< (MAL-value A) (MAL-value B)) *MAL-true *MAL-false)))) - (<= . `(MAL-fn '((A B) (if (<= (MAL-value A) (MAL-value B)) *MAL-true *MAL-false)))) - (> . `(MAL-fn '((A B) (if (> (MAL-value A) (MAL-value B)) *MAL-true *MAL-false)))) - (>= . `(MAL-fn '((A B) (if (>= (MAL-value A) (MAL-value B)) *MAL-true *MAL-false)))) - - (= . `(MAL-fn '((A B) (if (MAL-= A B) *MAL-true *MAL-false)))) - - (list . `(MAL-fn '(@ (MAL-list (rest))))) - (list? . `(MAL-fn '((X) (if (= (MAL-type X) 'list) *MAL-true *MAL-false)))) - (empty? . `(MAL-fn '((X) (if (and (MAL-seq? X) (not (MAL-value X))) *MAL-true *MAL-false)))) - (count . `(MAL-fn '((X) (if (MAL-seq? X) (MAL-number (length (MAL-value X))) (MAL-number 0))))) - - (pr-str . `(MAL-fn '(@ (MAL-string (glue " " (mapcar '((X) (pr-str X T)) (rest))))))) - (str . `(MAL-fn '(@ (MAL-string (pack (mapcar pr-str (rest))))))) - (prn . `(MAL-fn '(@ (prinl (glue " " (mapcar '((X) (pr-str X T)) (rest)))) *MAL-nil))) - (println . `(MAL-fn '(@ (prinl (glue " " (mapcar pr-str (rest)))) *MAL-nil))) - - (read-string . `(MAL-fn '((X) (read-str (MAL-value X))))) - (slurp . `(MAL-fn '((X) (MAL-string (in (MAL-value X) (till NIL T)))))) - - (atom . `(MAL-fn '((X) (MAL-atom X)))) - (atom? . `(MAL-fn '((X) (if (= (MAL-type X) 'atom) *MAL-true *MAL-false)))) - (deref . `(MAL-fn '((X) (MAL-value X)))) - (reset! . `(MAL-fn '((X Value) (put X 'value Value)))) - (swap! . `(MAL-fn MAL-swap!)) - - (cons . `(MAL-fn '((X Seq) (MAL-list (cons X (MAL-value Seq)))))) - (concat . `(MAL-fn '(@ (MAL-list (apply append (mapcar MAL-value (rest))))))) - (vec . `(MAL-fn '((Seq) (MAL-vector (MAL-value Seq))))) - - (nth . `(MAL-fn MAL-nth)) - (first . `(MAL-fn '((X) (if (MAL-seq? X) (or (car (MAL-value X)) *MAL-nil) *MAL-nil)))) - (rest . `(MAL-fn '((X) (if (MAL-seq? X) (MAL-list (cdr (MAL-value X))) (MAL-list NIL))))) - - (throw . `(MAL-fn '((X) (throw 'err (MAL-error X))))) - - (apply . `(MAL-fn '(@ (let (Fn (next) X (rest)) (apply (MAL-f Fn) (append (head -1 X) (MAL-value (last X)))))))) - (map . `(MAL-fn '((Fn Seq) (MAL-list (mapcar (MAL-f Fn) (MAL-value Seq)))))) - - (nil? . `(MAL-fn '((X) (if (= (MAL-type X) 'nil) *MAL-true *MAL-false)))) - (true? . `(MAL-fn '((X) (if (= (MAL-type X) 'true) *MAL-true *MAL-false)))) - (false? . `(MAL-fn '((X) (if (= (MAL-type X) 'false) *MAL-true *MAL-false)))) - (number? . `(MAL-fn '((X) (if (= (MAL-type X) 'number) *MAL-true *MAL-false)))) - (symbol? . `(MAL-fn '((X) (if (= (MAL-type X) 'symbol) *MAL-true *MAL-false)))) - (keyword? . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) *MAL-true *MAL-false)))) - (string? . `(MAL-fn '((X) (if (= (MAL-type X) 'string) *MAL-true *MAL-false)))) - (vector? . `(MAL-fn '((X) (if (= (MAL-type X) 'vector) *MAL-true *MAL-false)))) - (map? . `(MAL-fn '((X) (if (= (MAL-type X) 'map) *MAL-true *MAL-false)))) - (sequential? . `(MAL-fn '((X) (if (MAL-seq? X) *MAL-true *MAL-false)))) - (fn? . `(MAL-fn '((X) (if (or (= (MAL-type X) 'fn) (and (= (MAL-type X) 'func) (not (get X 'is-macro)))) *MAL-true *MAL-false)))) - (macro? . `(MAL-fn '((X) (if (and (= (MAL-type X) 'func) (get X 'is-macro)) *MAL-true *MAL-false)))) - - (symbol . `(MAL-fn '((Name) (MAL-symbol (MAL-value Name))))) - (keyword . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) X (MAL-keyword (MAL-value X)))))) - (vector . `(MAL-fn '(@ (MAL-vector (rest))))) - (hash-map . `(MAL-fn '(@ (MAL-map (rest))))) - - (assoc . `(MAL-fn MAL-assoc)) - (dissoc . `(MAL-fn MAL-dissoc)) - (get . `(MAL-fn '((Map Key) (or (and (<> (MAL-type Map) 'nil) (cdr (find '((X) (MAL-= (car X) Key)) (chunk (MAL-value Map))))) *MAL-nil)))) - (contains? . `(MAL-fn '((Map Key) (if (find '((X) (MAL-= (car X) Key)) (chunk (MAL-value Map))) *MAL-true *MAL-false)))) - (keys . `(MAL-fn '((Map) (MAL-list (mapcar car (chunk (MAL-value Map))))))) - (vals . `(MAL-fn '((Map) (MAL-list (extract cdr (chunk (MAL-value Map))))))) - - (with-meta . `(MAL-fn '((X Meta) (let X* (clone X) (put X* 'meta Meta) X*)))) - (meta . `(MAL-fn '((X) (or (MAL-meta X) *MAL-nil)))) - - (readline . `(MAL-fn '((Prompt) (let Output (readline (MAL-value Prompt)) (if (=0 Output) NIL (MAL-string Output)))))) - (time-ms . `(MAL-fn '(() (MAL-number (/ (usec) 1000))))) - (conj . `(MAL-fn MAL-conj)) - (seq . `(MAL-fn MAL-seq)) - - (pil-eval . `(MAL-fn '((Input) (pil-to-mal (run (str (MAL-value Input))))))) ) ) +(de MAL-= (A B) + (let (A* (MAL-type A) + B* (MAL-type B)) + (cond + ((and (= A* 'map) (= B* 'map)) + (MAL-map-= (MAL-value A) (MAL-value B)) ) + ((and (memq A* '(list vector)) (memq B* '(list vector))) + (MAL-seq-= (MAL-value A) (MAL-value B)) ) + ((= A* B*) + (= (MAL-value A) (MAL-value B)) ) + (T NIL) ) ) ) + +(de MAL-map-= (As Bs) + (when (= (length As) (length Bs)) + (let (As* (chunk As) Bs* (chunk Bs)) + (catch 'result + (while As* + (let (A (pop 'As*) Key (MAL-value (car A)) Val (cdr A) + B (find '((X) (= Key (MAL-value (car X)))) Bs*) ) + (when (or (not B) (not (MAL-= Val (cdr B)))) + (throw 'result NIL) ) ) ) + T ) ) ) ) + +(de MAL-seq-= (As Bs) + (when (= (length As) (length Bs)) + (catch 'result + (while As + (ifn (MAL-= (pop 'As) (pop 'Bs)) + (throw 'result NIL) ) ) + T ) ) ) + +(de MAL-seq? (X) + (memq (MAL-type X) '(list vector)) ) + +(de MAL-f (X) + (MAL-value (if (isa '+Func X) (get X 'fn) X)) ) + +(de MAL-swap! @ + (let (X (next) Fn (next) Args (rest)) + (put X 'value (apply (MAL-f Fn) Args (MAL-value X))) ) ) + +(de MAL-nth (Seq N) + (let (Seq* (MAL-value Seq) N* (MAL-value N)) + (if (< N* (length Seq*)) + (nth Seq* (inc N*) 1) + (throw 'err (MAL-error (MAL-string "out of bounds"))) ) ) ) + +(de chunk (List) + (make + (for (L List L (cddr L)) + (link (cons (car L) (cadr L))) ) ) ) + +(de join (List) + (mapcan '((X) (list (car X) (cdr X))) List) ) + +(de MAL-assoc @ + (let (Map (next) Args (rest)) + (MAL-map + (append Args + (join + (filter '((X) (not (find '((Y) (MAL-= (car Y) (car X))) + (chunk Args) ) ) ) + (chunk (MAL-value Map)) ) ) ) ) ) ) + +(de MAL-dissoc @ + (let (Map (next) Args (rest)) + (MAL-map + (make + (for (L (MAL-value Map) L (cddr L)) + (unless (find '((X) (MAL-= (car L) X)) Args) + (link (car L) (cadr L)) ) ) ) ) ) ) + +(de MAL-seq (X) + (if (or (= (MAL-type X) 'nil) (not (MAL-value X))) + *MAL-nil + (case (MAL-type X) + (list X) + (vector (MAL-list (MAL-value X))) + (string (MAL-list (mapcar MAL-string (chop (MAL-value X))))) ) ) ) + +(de MAL-conj @ + (let (Seq (next) Args (rest)) + (if (= (MAL-type Seq) 'vector) + (MAL-vector (append (MAL-value Seq) Args)) + (MAL-list (append (reverse Args) (MAL-value Seq))) ) ) ) + +(de clone (X) + (let X* (new (val X)) + (maps '((C) (put X* (cdr C) (car C))) X) + X* ) ) + +(de pil-to-mal (X) + (cond + ((not X) *MAL-nil) + ((=T X) *MAL-true) + ((num? X) (MAL-number X)) + ((str? X) (MAL-string X)) + ((sym? X) (MAL-symbol X)) + ((lst? X) (MAL-list (mapcar pil-to-mal X))) + (T (MAL-string (sym X))) ) ) + +(def '*Ns + '((+ . `(MAL-fn '((A B) (MAL-number (+ (MAL-value A) (MAL-value B)))))) + (- . `(MAL-fn '((A B) (MAL-number (- (MAL-value A) (MAL-value B)))))) + (* . `(MAL-fn '((A B) (MAL-number (* (MAL-value A) (MAL-value B)))))) + (/ . `(MAL-fn '((A B) (MAL-number (/ (MAL-value A) (MAL-value B)))))) + + (< . `(MAL-fn '((A B) (if (< (MAL-value A) (MAL-value B)) *MAL-true *MAL-false)))) + (<= . `(MAL-fn '((A B) (if (<= (MAL-value A) (MAL-value B)) *MAL-true *MAL-false)))) + (> . `(MAL-fn '((A B) (if (> (MAL-value A) (MAL-value B)) *MAL-true *MAL-false)))) + (>= . `(MAL-fn '((A B) (if (>= (MAL-value A) (MAL-value B)) *MAL-true *MAL-false)))) + + (= . `(MAL-fn '((A B) (if (MAL-= A B) *MAL-true *MAL-false)))) + + (list . `(MAL-fn '(@ (MAL-list (rest))))) + (list? . `(MAL-fn '((X) (if (= (MAL-type X) 'list) *MAL-true *MAL-false)))) + (empty? . `(MAL-fn '((X) (if (and (MAL-seq? X) (not (MAL-value X))) *MAL-true *MAL-false)))) + (count . `(MAL-fn '((X) (if (MAL-seq? X) (MAL-number (length (MAL-value X))) (MAL-number 0))))) + + (pr-str . `(MAL-fn '(@ (MAL-string (glue " " (mapcar '((X) (pr-str X T)) (rest))))))) + (str . `(MAL-fn '(@ (MAL-string (pack (mapcar pr-str (rest))))))) + (prn . `(MAL-fn '(@ (prinl (glue " " (mapcar '((X) (pr-str X T)) (rest)))) *MAL-nil))) + (println . `(MAL-fn '(@ (prinl (glue " " (mapcar pr-str (rest)))) *MAL-nil))) + + (read-string . `(MAL-fn '((X) (read-str (MAL-value X))))) + (slurp . `(MAL-fn '((X) (MAL-string (in (MAL-value X) (till NIL T)))))) + + (atom . `(MAL-fn '((X) (MAL-atom X)))) + (atom? . `(MAL-fn '((X) (if (= (MAL-type X) 'atom) *MAL-true *MAL-false)))) + (deref . `(MAL-fn '((X) (MAL-value X)))) + (reset! . `(MAL-fn '((X Value) (put X 'value Value)))) + (swap! . `(MAL-fn MAL-swap!)) + + (cons . `(MAL-fn '((X Seq) (MAL-list (cons X (MAL-value Seq)))))) + (concat . `(MAL-fn '(@ (MAL-list (apply append (mapcar MAL-value (rest))))))) + (vec . `(MAL-fn '((Seq) (MAL-vector (MAL-value Seq))))) + + (nth . `(MAL-fn MAL-nth)) + (first . `(MAL-fn '((X) (if (MAL-seq? X) (or (car (MAL-value X)) *MAL-nil) *MAL-nil)))) + (rest . `(MAL-fn '((X) (if (MAL-seq? X) (MAL-list (cdr (MAL-value X))) (MAL-list NIL))))) + + (throw . `(MAL-fn '((X) (throw 'err (MAL-error X))))) + + (apply . `(MAL-fn '(@ (let (Fn (next) X (rest)) (apply (MAL-f Fn) (append (head -1 X) (MAL-value (last X)))))))) + (map . `(MAL-fn '((Fn Seq) (MAL-list (mapcar (MAL-f Fn) (MAL-value Seq)))))) + + (nil? . `(MAL-fn '((X) (if (= (MAL-type X) 'nil) *MAL-true *MAL-false)))) + (true? . `(MAL-fn '((X) (if (= (MAL-type X) 'true) *MAL-true *MAL-false)))) + (false? . `(MAL-fn '((X) (if (= (MAL-type X) 'false) *MAL-true *MAL-false)))) + (number? . `(MAL-fn '((X) (if (= (MAL-type X) 'number) *MAL-true *MAL-false)))) + (symbol? . `(MAL-fn '((X) (if (= (MAL-type X) 'symbol) *MAL-true *MAL-false)))) + (keyword? . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) *MAL-true *MAL-false)))) + (string? . `(MAL-fn '((X) (if (= (MAL-type X) 'string) *MAL-true *MAL-false)))) + (vector? . `(MAL-fn '((X) (if (= (MAL-type X) 'vector) *MAL-true *MAL-false)))) + (map? . `(MAL-fn '((X) (if (= (MAL-type X) 'map) *MAL-true *MAL-false)))) + (sequential? . `(MAL-fn '((X) (if (MAL-seq? X) *MAL-true *MAL-false)))) + (fn? . `(MAL-fn '((X) (if (or (= (MAL-type X) 'fn) (and (= (MAL-type X) 'func) (not (get X 'is-macro)))) *MAL-true *MAL-false)))) + (macro? . `(MAL-fn '((X) (if (and (= (MAL-type X) 'func) (get X 'is-macro)) *MAL-true *MAL-false)))) + + (symbol . `(MAL-fn '((Name) (MAL-symbol (MAL-value Name))))) + (keyword . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) X (MAL-keyword (MAL-value X)))))) + (vector . `(MAL-fn '(@ (MAL-vector (rest))))) + (hash-map . `(MAL-fn '(@ (MAL-map (rest))))) + + (assoc . `(MAL-fn MAL-assoc)) + (dissoc . `(MAL-fn MAL-dissoc)) + (get . `(MAL-fn '((Map Key) (or (and (<> (MAL-type Map) 'nil) (cdr (find '((X) (MAL-= (car X) Key)) (chunk (MAL-value Map))))) *MAL-nil)))) + (contains? . `(MAL-fn '((Map Key) (if (find '((X) (MAL-= (car X) Key)) (chunk (MAL-value Map))) *MAL-true *MAL-false)))) + (keys . `(MAL-fn '((Map) (MAL-list (mapcar car (chunk (MAL-value Map))))))) + (vals . `(MAL-fn '((Map) (MAL-list (extract cdr (chunk (MAL-value Map))))))) + + (with-meta . `(MAL-fn '((X Meta) (let X* (clone X) (put X* 'meta Meta) X*)))) + (meta . `(MAL-fn '((X) (or (MAL-meta X) *MAL-nil)))) + + (readline . `(MAL-fn '((Prompt) (let Output (readline (MAL-value Prompt)) (if (=0 Output) NIL (MAL-string Output)))))) + (time-ms . `(MAL-fn '(() (MAL-number (/ (usec) 1000))))) + (conj . `(MAL-fn MAL-conj)) + (seq . `(MAL-fn MAL-seq)) + + (pil-eval . `(MAL-fn '((Input) (pil-to-mal (run (str (MAL-value Input))))))) ) ) diff --git a/impls/picolisp/env.l b/impls/picolisp/env.l index 97581cf1c3..19760a667d 100644 --- a/impls/picolisp/env.l +++ b/impls/picolisp/env.l @@ -1,24 +1,24 @@ -(class +Env) -# data outer -(dm T (Outer Binds Exprs) - (=: data (new)) - (=: outer Outer) - (for (Binds Binds Binds) - (if (<> (car Binds) '&) - (set> This (pop 'Binds) (pop 'Exprs)) - (pop 'Binds) - (set> This (pop 'Binds) (MAL-list Exprs)) ) ) ) - -(de MAL-env (Outer Binds Exprs) - (new '(+Env) Outer Binds Exprs) ) - -(dm set> (Key Value) - (put (: data) Key Value) ) - -(dm find> (Key) - (or (get (: data) Key) - (and (: outer) (find> @ Key)) ) ) - -(dm get> (Key) - (or (find> This Key) - (throw 'err (MAL-error (MAL-string (pack "'" Key "' not found")))) ) ) +(class +Env) +# data outer +(dm T (Outer Binds Exprs) + (=: data (new)) + (=: outer Outer) + (for (Binds Binds Binds) + (if (<> (car Binds) '&) + (set> This (pop 'Binds) (pop 'Exprs)) + (pop 'Binds) + (set> This (pop 'Binds) (MAL-list Exprs)) ) ) ) + +(de MAL-env (Outer Binds Exprs) + (new '(+Env) Outer Binds Exprs) ) + +(dm set> (Key Value) + (put (: data) Key Value) ) + +(dm find> (Key) + (or (get (: data) Key) + (and (: outer) (find> @ Key)) ) ) + +(dm get> (Key) + (or (find> This Key) + (throw 'err (MAL-error (MAL-string (pack "'" Key "' not found")))) ) ) diff --git a/impls/picolisp/func.l b/impls/picolisp/func.l index fe329a522d..9a911a4523 100644 --- a/impls/picolisp/func.l +++ b/impls/picolisp/func.l @@ -1,20 +1,20 @@ -(class +Func) -# env ast params fn -(dm T (Env Ast Params Fn) - (=: type 'func) # HACK - (=: env Env) - (=: ast Ast) - (=: params Params) - (=: fn Fn) ) - -(de MAL-func (Env Ast Params Fn) - (new '(+Func) Env Ast Params Fn) ) - -(de MAL-macro (MalFn) - (let (env (get MalFn 'env) - ast (get MalFn 'ast) - params (get MalFn 'params) - fn (get MalFn 'fn) - clone (MAL-func env ast params fn)) - (put clone 'is-macro T) - clone)) +(class +Func) +# env ast params fn +(dm T (Env Ast Params Fn) + (=: type 'func) # HACK + (=: env Env) + (=: ast Ast) + (=: params Params) + (=: fn Fn) ) + +(de MAL-func (Env Ast Params Fn) + (new '(+Func) Env Ast Params Fn) ) + +(de MAL-macro (MalFn) + (let (env (get MalFn 'env) + ast (get MalFn 'ast) + params (get MalFn 'params) + fn (get MalFn 'fn) + clone (MAL-func env ast params fn)) + (put clone 'is-macro T) + clone)) diff --git a/impls/picolisp/printer.l b/impls/picolisp/printer.l index 81ad6f8396..3f28b8ec70 100644 --- a/impls/picolisp/printer.l +++ b/impls/picolisp/printer.l @@ -1,28 +1,28 @@ -(de pr-str (Ast PrintReadably) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - ((true false nil) - (sym @) ) - (string (if PrintReadably (repr Value) Value)) - (keyword (pack ":" Value)) - ((number symbol) Value) - (fn "#") - (func "#") - (list (pr-list Value PrintReadably "(" ")")) - (vector (pr-list Value PrintReadably "[" "]")) - (map (pr-list Value PrintReadably "{" "}")) - (atom (pack "(atom " (pr-str Value PrintReadably) ")")) - (T (pretty Value) (throw 'err (MAL-error (MAL-string "[pr-str] unimplemented type")))) ) ) ) - -(de repr (X) - (let Chars (chop X) - (if (not X) - "\"\"" - (setq Chars (replace Chars "\\" "\\\\")) - (setq Chars (replace Chars "\"" "\\\"")) - (setq Chars (replace Chars "\n" "\\n")) - (pack "\"" Chars "\"") ) ) ) - -(de pr-list (Forms PrintReadably Starter Ender) - (let Values (mapcar '((Form) (pr-str Form PrintReadably)) Forms) - (pack Starter (glue " " Values) Ender) ) ) +(de pr-str (Ast PrintReadably) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + ((true false nil) + (sym @) ) + (string (if PrintReadably (repr Value) Value)) + (keyword (pack ":" Value)) + ((number symbol) Value) + (fn "#") + (func "#") + (list (pr-list Value PrintReadably "(" ")")) + (vector (pr-list Value PrintReadably "[" "]")) + (map (pr-list Value PrintReadably "{" "}")) + (atom (pack "(atom " (pr-str Value PrintReadably) ")")) + (T (pretty Value) (throw 'err (MAL-error (MAL-string "[pr-str] unimplemented type")))) ) ) ) + +(de repr (X) + (let Chars (chop X) + (if (not X) + "\"\"" + (setq Chars (replace Chars "\\" "\\\\")) + (setq Chars (replace Chars "\"" "\\\"")) + (setq Chars (replace Chars "\n" "\\n")) + (pack "\"" Chars "\"") ) ) ) + +(de pr-list (Forms PrintReadably Starter Ender) + (let Values (mapcar '((Form) (pr-str Form PrintReadably)) Forms) + (pack Starter (glue " " Values) Ender) ) ) diff --git a/impls/picolisp/reader.l b/impls/picolisp/reader.l index f6df3ee3f7..3feb913387 100644 --- a/impls/picolisp/reader.l +++ b/impls/picolisp/reader.l @@ -1,126 +1,126 @@ -(class +Reader) -# tokens -(dm T (Tokens) - (=: tokens Tokens) ) - -(dm next> () - (pop (:: tokens)) ) - -(dm peek> () - (car (: tokens)) ) - -(de read-str (String) - (let (Tokens (tokenizer String) - Reader (new '(+Reader) Tokens) ) - (read-form Reader) ) ) - -(de tokenizer (String) - # [\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*) - (let (Special " []{}()'\"`,;" ) - (make - (for (Chars (chop String) Chars) - (let Char (pop 'Chars) - (cond - ((or (sp? Char) (= Char ",")) - # do nothing, whitespace - ) - ((and (= Char "~") (= (car Chars) "@")) - (link "~@") - (pop 'Chars) ) # remove @ token - ((index Char (chop "[]{}()'`~^\@")) - (link Char) ) - ((= Char "\"") - (link - (pack - (make - (link Char) # HACK - (use Done - (while (and Chars (not Done)) - (let Char (pop 'Chars) - (cond - ((= Char "\\") - (if Chars - (let Char (pop 'Chars) - (if (= Char "n") - (link "\n") - (link Char) ) ) - (throw 'err (MAL-error (MAL-string "expected '\"', got EOF"))) ) ) - ((<> Char "\"") - (link Char) ) - ((= Char "\"") - (setq Done T) ) ) ) ) - (unless Done - (throw 'err (MAL-error (MAL-string "expected '\"', got EOF"))) ) ) ) ) ) ) - ((= Char ";") - (while (and Chars (<> Char "\n")) - (setq Char (pop 'Chars)) ) ) - ((and (not (index Char (chop Special))) (not (sp? Char))) - (link - (pack - (make - (link Char) - (let Char (car Chars) - (while (and Chars (not (index Char (chop Special))) (not (sp? Char))) - (link (pop 'Chars)) - (setq Char (car Chars)) ) ) ) ) ) ) ) ) ) ) ) ) - -(de read-form (Reader) - (case (peek> Reader) - ("'" (read-macro Reader 'quote)) - ("`" (read-macro Reader 'quasiquote)) - ("~" (read-macro Reader 'unquote)) - ("~@" (read-macro Reader 'splice-unquote)) - ("@" (read-macro Reader 'deref)) - ("\^" (read-meta Reader)) - ("(" (read-list Reader 'list ")")) - ("[" (read-list Reader 'vector "]")) - ("{" (read-list Reader 'map "}")) - (T (read-atom Reader)) ) ) - -(de read-macro (Reader symbol) - (next> Reader) # pop reader macro token - (MAL-list (list (MAL-symbol symbol) (read-form Reader))) ) - -(de read-meta (Reader) - (next> Reader) # pop reader macro token - (let Form (read-form Reader) - (MAL-list (list (MAL-symbol 'with-meta) (read-form Reader) Form) ) ) ) - -(de read-list (Reader Type Ender) - (next> Reader) # pop list start - (new (list (case Type - (list '+MALList) - (vector '+MALVector) - (map '+MALMap) ) ) - (make - (use Done - (while (not Done) - (let Token (peek> Reader) - (cond - ((= Token Ender) - (next> Reader) # pop list end - (setq Done T) ) - ((not Token) - (let Msg (pack "expected '" Ender "', got EOF") - (throw 'err (MAL-error (MAL-string Msg))) ) ) - (T (link (read-form Reader))) ) ) ) ) ) ) ) - -(de read-atom (Reader) - (let (Token (next> Reader) - Chars (chop Token)) - (cond - ((= Token "true") - *MAL-true) - ((= Token "false") - *MAL-false) - ((= Token "nil") - *MAL-nil) - ((format Token) - (MAL-number @) ) - ((= (car Chars) "\"") - (MAL-string (pack (cdr Chars))) ) - ((= (car Chars) ":") - (MAL-keyword (intern (pack (cdr Chars)))) ) - ((not Token) - (throw 'err (MAL-error (MAL-string "end of token stream"))) ) - (T (MAL-symbol (intern Token))) ) ) ) +(class +Reader) +# tokens +(dm T (Tokens) + (=: tokens Tokens) ) + +(dm next> () + (pop (:: tokens)) ) + +(dm peek> () + (car (: tokens)) ) + +(de read-str (String) + (let (Tokens (tokenizer String) + Reader (new '(+Reader) Tokens) ) + (read-form Reader) ) ) + +(de tokenizer (String) + # [\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*) + (let (Special " []{}()'\"`,;" ) + (make + (for (Chars (chop String) Chars) + (let Char (pop 'Chars) + (cond + ((or (sp? Char) (= Char ",")) + # do nothing, whitespace + ) + ((and (= Char "~") (= (car Chars) "@")) + (link "~@") + (pop 'Chars) ) # remove @ token + ((index Char (chop "[]{}()'`~^\@")) + (link Char) ) + ((= Char "\"") + (link + (pack + (make + (link Char) # HACK + (use Done + (while (and Chars (not Done)) + (let Char (pop 'Chars) + (cond + ((= Char "\\") + (if Chars + (let Char (pop 'Chars) + (if (= Char "n") + (link "\n") + (link Char) ) ) + (throw 'err (MAL-error (MAL-string "expected '\"', got EOF"))) ) ) + ((<> Char "\"") + (link Char) ) + ((= Char "\"") + (setq Done T) ) ) ) ) + (unless Done + (throw 'err (MAL-error (MAL-string "expected '\"', got EOF"))) ) ) ) ) ) ) + ((= Char ";") + (while (and Chars (<> Char "\n")) + (setq Char (pop 'Chars)) ) ) + ((and (not (index Char (chop Special))) (not (sp? Char))) + (link + (pack + (make + (link Char) + (let Char (car Chars) + (while (and Chars (not (index Char (chop Special))) (not (sp? Char))) + (link (pop 'Chars)) + (setq Char (car Chars)) ) ) ) ) ) ) ) ) ) ) ) ) + +(de read-form (Reader) + (case (peek> Reader) + ("'" (read-macro Reader 'quote)) + ("`" (read-macro Reader 'quasiquote)) + ("~" (read-macro Reader 'unquote)) + ("~@" (read-macro Reader 'splice-unquote)) + ("@" (read-macro Reader 'deref)) + ("\^" (read-meta Reader)) + ("(" (read-list Reader 'list ")")) + ("[" (read-list Reader 'vector "]")) + ("{" (read-list Reader 'map "}")) + (T (read-atom Reader)) ) ) + +(de read-macro (Reader symbol) + (next> Reader) # pop reader macro token + (MAL-list (list (MAL-symbol symbol) (read-form Reader))) ) + +(de read-meta (Reader) + (next> Reader) # pop reader macro token + (let Form (read-form Reader) + (MAL-list (list (MAL-symbol 'with-meta) (read-form Reader) Form) ) ) ) + +(de read-list (Reader Type Ender) + (next> Reader) # pop list start + (new (list (case Type + (list '+MALList) + (vector '+MALVector) + (map '+MALMap) ) ) + (make + (use Done + (while (not Done) + (let Token (peek> Reader) + (cond + ((= Token Ender) + (next> Reader) # pop list end + (setq Done T) ) + ((not Token) + (let Msg (pack "expected '" Ender "', got EOF") + (throw 'err (MAL-error (MAL-string Msg))) ) ) + (T (link (read-form Reader))) ) ) ) ) ) ) ) + +(de read-atom (Reader) + (let (Token (next> Reader) + Chars (chop Token)) + (cond + ((= Token "true") + *MAL-true) + ((= Token "false") + *MAL-false) + ((= Token "nil") + *MAL-nil) + ((format Token) + (MAL-number @) ) + ((= (car Chars) "\"") + (MAL-string (pack (cdr Chars))) ) + ((= (car Chars) ":") + (MAL-keyword (intern (pack (cdr Chars)))) ) + ((not Token) + (throw 'err (MAL-error (MAL-string "end of token stream"))) ) + (T (MAL-symbol (intern Token))) ) ) ) diff --git a/impls/picolisp/readline.l b/impls/picolisp/readline.l index 777e7d3e98..6eeefa51b0 100644 --- a/impls/picolisp/readline.l +++ b/impls/picolisp/readline.l @@ -1,19 +1,19 @@ -(de load-history (File) - (when (info File) - (in File - (until (eof) - (native "libreadline.so" "add_history" NIL (line T)) ) ) ) ) - -(de save-to-history (Input) - (when Input - (native "libreadline.so" "add_history" NIL Input) - (out "+.mal_history" - (prinl Input) ) ) ) - -(de readline (Prompt) - (let Input (native "libreadline.so" "readline" 'N Prompt) - (if (=0 Input) - 0 - (prog1 - (struct Input 'S) - (save-to-history @) ) ) ) ) +(de load-history (File) + (when (info File) + (in File + (until (eof) + (native "libreadline.so" "add_history" NIL (line T)) ) ) ) ) + +(de save-to-history (Input) + (when Input + (native "libreadline.so" "add_history" NIL Input) + (out "+.mal_history" + (prinl Input) ) ) ) + +(de readline (Prompt) + (let Input (native "libreadline.so" "readline" 'N Prompt) + (if (=0 Input) + 0 + (prog1 + (struct Input 'S) + (save-to-history @) ) ) ) ) diff --git a/impls/picolisp/run b/impls/picolisp/run index e759e20f21..a105642db4 100755 --- a/impls/picolisp/run +++ b/impls/picolisp/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec pil $(dirname $0)/${STEP:-stepA_mal}.l - "${@}" +#!/bin/bash +exec pil $(dirname $0)/${STEP:-stepA_mal}.l - "${@}" diff --git a/impls/picolisp/step0_repl.l b/impls/picolisp/step0_repl.l index 0f40e9bd0f..8cbdd0060c 100644 --- a/impls/picolisp/step0_repl.l +++ b/impls/picolisp/step0_repl.l @@ -1,28 +1,28 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") - -(de READ (String) - String) - -(de EVAL (Ast) - Ast) - -(de PRINT (Ast) - Ast) - -(de rep (String) - (PRINT (EVAL (READ String))) ) - -(load-history ".mal_history") - -(use Eof - (until Eof - (let Input (readline "user> ") - (if (=0 Input) - (setq Eof T) - (prinl (rep Input)) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") + +(de READ (String) + String) + +(de EVAL (Ast) + Ast) + +(de PRINT (Ast) + Ast) + +(de rep (String) + (PRINT (EVAL (READ String))) ) + +(load-history ".mal_history") + +(use Eof + (until Eof + (let Input (readline "user> ") + (if (=0 Input) + (setq Eof T) + (prinl (rep Input)) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/step1_read_print.l b/impls/picolisp/step1_read_print.l index 5e4008801a..b90420ca98 100644 --- a/impls/picolisp/step1_read_print.l +++ b/impls/picolisp/step1_read_print.l @@ -1,36 +1,36 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") - -(de READ (String) - (read-str String) ) - -(de EVAL (Ast) - Ast) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String))) ) - -(load-history ".mal_history") - -(use Eof - (until Eof - (let Input (readline "user> ") - (if (=0 Input) - (setq Eof T) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") + +(de READ (String) + (read-str String) ) + +(de EVAL (Ast) + Ast) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String))) ) + +(load-history ".mal_history") + +(use Eof + (until Eof + (let Input (readline "user> ") + (if (=0 Input) + (setq Eof T) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/step2_eval.l b/impls/picolisp/step2_eval.l index 424f4b2ddf..7817d24e2c 100644 --- a/impls/picolisp/step2_eval.l +++ b/impls/picolisp/step2_eval.l @@ -1,59 +1,59 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") - -(de READ (String) - (read-str String) ) - -(def '*ReplEnv - '((+ . ((A B) (MAL-number (+ (MAL-value A) (MAL-value B))))) - (- . ((A B) (MAL-number (- (MAL-value A) (MAL-value B))))) - (* . ((A B) (MAL-number (* (MAL-value A) (MAL-value B))))) - (/ . ((A B) (MAL-number (/ (MAL-value A) (MAL-value B))))) ) ) - -(de EVAL (Ast Env) - (if (= (MAL-type Ast) 'list) - (if (not (MAL-value Ast)) - Ast - (let Value (MAL-value (eval-ast Ast Env)) - (apply (car Value) (cdr Value)) ) ) - (eval-ast Ast Env) ) ) - -(de eval-ast (Ast Env) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - (symbol - (if (assoc Value Env) - (cdr @) - (throw 'err (MAL-error (MAL-string (pack "'" Value "' not found")))) ) ) - (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) - (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) - (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) - (T Ast) ) ) ) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String) *ReplEnv)) ) - -(load-history ".mal_history") - -(use Eof - (until Eof - (let Input (readline "user> ") - (if (=0 Input) - (setq Eof T) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") + +(de READ (String) + (read-str String) ) + +(def '*ReplEnv + '((+ . ((A B) (MAL-number (+ (MAL-value A) (MAL-value B))))) + (- . ((A B) (MAL-number (- (MAL-value A) (MAL-value B))))) + (* . ((A B) (MAL-number (* (MAL-value A) (MAL-value B))))) + (/ . ((A B) (MAL-number (/ (MAL-value A) (MAL-value B))))) ) ) + +(de EVAL (Ast Env) + (if (= (MAL-type Ast) 'list) + (if (not (MAL-value Ast)) + Ast + (let Value (MAL-value (eval-ast Ast Env)) + (apply (car Value) (cdr Value)) ) ) + (eval-ast Ast Env) ) ) + +(de eval-ast (Ast Env) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + (symbol + (if (assoc Value Env) + (cdr @) + (throw 'err (MAL-error (MAL-string (pack "'" Value "' not found")))) ) ) + (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) + (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) + (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) + (T Ast) ) ) ) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String) *ReplEnv)) ) + +(load-history ".mal_history") + +(use Eof + (until Eof + (let Input (readline "user> ") + (if (=0 Input) + (setq Eof T) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/step3_env.l b/impls/picolisp/step3_env.l index af3cb206f4..87846761f4 100644 --- a/impls/picolisp/step3_env.l +++ b/impls/picolisp/step3_env.l @@ -1,71 +1,71 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") -(load-relative "env.l") - -(de READ (String) - (read-str String) ) - -(def '*ReplEnv (MAL-env NIL)) -(set> *ReplEnv '+ '((A B) (MAL-number (+ (MAL-value A) (MAL-value B))))) -(set> *ReplEnv '- '((A B) (MAL-number (- (MAL-value A) (MAL-value B))))) -(set> *ReplEnv '* '((A B) (MAL-number (* (MAL-value A) (MAL-value B))))) -(set> *ReplEnv '/ '((A B) (MAL-number (/ (MAL-value A) (MAL-value B))))) - -(de EVAL (Ast Env) - (if (= (MAL-type Ast) 'list) - (if (not (MAL-value Ast)) - Ast - (let (Ast* (MAL-value Ast) - A0* (MAL-value (car Ast*)) - A1* (MAL-value (cadr Ast*)) - A2 (caddr Ast*)) - (cond - ((= A0* 'def!) - (set> Env A1* (EVAL A2 Env)) ) - ((= A0* 'let*) - (let Env* (MAL-env Env) - (for (Bindings A1* Bindings) - (let (Key (MAL-value (pop 'Bindings)) - Value (EVAL (pop 'Bindings) Env*)) - (set> Env* Key Value) ) ) - (EVAL A2 Env*) ) ) - (T (let Value (MAL-value (eval-ast Ast Env)) - (apply (car Value) (cdr Value)) ) ) ) ) ) - (eval-ast Ast Env) ) ) - -(de eval-ast (Ast Env) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - (symbol (get> Env Value)) - (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) - (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) - (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) - (T Ast) ) ) ) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String) *ReplEnv)) ) - -(load-history ".mal_history") - -(use Eof - (until Eof - (let Input (readline "user> ") - (if (=0 Input) - (setq Eof T) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") +(load-relative "env.l") + +(de READ (String) + (read-str String) ) + +(def '*ReplEnv (MAL-env NIL)) +(set> *ReplEnv '+ '((A B) (MAL-number (+ (MAL-value A) (MAL-value B))))) +(set> *ReplEnv '- '((A B) (MAL-number (- (MAL-value A) (MAL-value B))))) +(set> *ReplEnv '* '((A B) (MAL-number (* (MAL-value A) (MAL-value B))))) +(set> *ReplEnv '/ '((A B) (MAL-number (/ (MAL-value A) (MAL-value B))))) + +(de EVAL (Ast Env) + (if (= (MAL-type Ast) 'list) + (if (not (MAL-value Ast)) + Ast + (let (Ast* (MAL-value Ast) + A0* (MAL-value (car Ast*)) + A1* (MAL-value (cadr Ast*)) + A2 (caddr Ast*)) + (cond + ((= A0* 'def!) + (set> Env A1* (EVAL A2 Env)) ) + ((= A0* 'let*) + (let Env* (MAL-env Env) + (for (Bindings A1* Bindings) + (let (Key (MAL-value (pop 'Bindings)) + Value (EVAL (pop 'Bindings) Env*)) + (set> Env* Key Value) ) ) + (EVAL A2 Env*) ) ) + (T (let Value (MAL-value (eval-ast Ast Env)) + (apply (car Value) (cdr Value)) ) ) ) ) ) + (eval-ast Ast Env) ) ) + +(de eval-ast (Ast Env) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + (symbol (get> Env Value)) + (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) + (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) + (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) + (T Ast) ) ) ) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String) *ReplEnv)) ) + +(load-history ".mal_history") + +(use Eof + (until Eof + (let Input (readline "user> ") + (if (=0 Input) + (setq Eof T) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/step4_if_fn_do.l b/impls/picolisp/step4_if_fn_do.l index 8d70fdef5b..ce3e5794f8 100644 --- a/impls/picolisp/step4_if_fn_do.l +++ b/impls/picolisp/step4_if_fn_do.l @@ -1,90 +1,90 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") -(load-relative "env.l") -(load-relative "func.l") -(load-relative "core.l") - -(de READ (String) - (read-str String) ) - -(def '*ReplEnv (MAL-env NIL)) -(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) - -(de EVAL (Ast Env) - (if (= (MAL-type Ast) 'list) - (if (not (MAL-value Ast)) - Ast - (let (Ast* (MAL-value Ast) - A0* (MAL-value (car Ast*)) - A1 (cadr Ast*) - A1* (MAL-value A1) - A2 (caddr Ast*) - A3 (cadddr Ast*) ) - (cond - ((= A0* 'def!) - (set> Env A1* (EVAL A2 Env)) ) - ((= A0* 'let*) - (let Env* (MAL-env Env) - (for (Bindings A1* Bindings) - (let (Key (MAL-value (pop 'Bindings)) - Value (EVAL (pop 'Bindings) Env*)) - (set> Env* Key Value) ) ) - (EVAL A2 Env*) ) ) - ((= A0* 'do) - (for Form (cdr Ast*) - (EVAL Form Env) ) ) - ((= A0* 'if) - (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) - (EVAL A2 Env) - (if A3 - (EVAL A3 Env) - *MAL-nil ) ) ) - ((= A0* 'fn*) - (let (Binds (mapcar MAL-value A1*) - Body A2) - (MAL-fn - (curry (Env Binds Body) @ - (let Env* (MAL-env Env Binds (rest)) - (EVAL Body Env*) ) ) ) ) ) - (T - (let (Ast* (MAL-value (eval-ast Ast Env)) - Fn (MAL-value (car Ast*)) - Args (cdr Ast*)) - (apply Fn Args) ) ) ) ) ) - (eval-ast Ast Env) ) ) - -(de eval-ast (Ast Env) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - (symbol (get> Env Value)) - (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) - (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) - (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) - (T Ast) ) ) ) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String) *ReplEnv)) ) - -(rep "(def! not (fn* (a) (if a false true)))") - -(load-history ".mal_history") - -(use Input - (until (=0 (setq Input (readline "user> "))) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") +(load-relative "env.l") +(load-relative "func.l") +(load-relative "core.l") + +(de READ (String) + (read-str String) ) + +(def '*ReplEnv (MAL-env NIL)) +(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) + +(de EVAL (Ast Env) + (if (= (MAL-type Ast) 'list) + (if (not (MAL-value Ast)) + Ast + (let (Ast* (MAL-value Ast) + A0* (MAL-value (car Ast*)) + A1 (cadr Ast*) + A1* (MAL-value A1) + A2 (caddr Ast*) + A3 (cadddr Ast*) ) + (cond + ((= A0* 'def!) + (set> Env A1* (EVAL A2 Env)) ) + ((= A0* 'let*) + (let Env* (MAL-env Env) + (for (Bindings A1* Bindings) + (let (Key (MAL-value (pop 'Bindings)) + Value (EVAL (pop 'Bindings) Env*)) + (set> Env* Key Value) ) ) + (EVAL A2 Env*) ) ) + ((= A0* 'do) + (for Form (cdr Ast*) + (EVAL Form Env) ) ) + ((= A0* 'if) + (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) + (EVAL A2 Env) + (if A3 + (EVAL A3 Env) + *MAL-nil ) ) ) + ((= A0* 'fn*) + (let (Binds (mapcar MAL-value A1*) + Body A2) + (MAL-fn + (curry (Env Binds Body) @ + (let Env* (MAL-env Env Binds (rest)) + (EVAL Body Env*) ) ) ) ) ) + (T + (let (Ast* (MAL-value (eval-ast Ast Env)) + Fn (MAL-value (car Ast*)) + Args (cdr Ast*)) + (apply Fn Args) ) ) ) ) ) + (eval-ast Ast Env) ) ) + +(de eval-ast (Ast Env) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + (symbol (get> Env Value)) + (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) + (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) + (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) + (T Ast) ) ) ) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String) *ReplEnv)) ) + +(rep "(def! not (fn* (a) (if a false true)))") + +(load-history ".mal_history") + +(use Input + (until (=0 (setq Input (readline "user> "))) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/step5_tco.l b/impls/picolisp/step5_tco.l index 5ae8bdc58e..a1e58a9afd 100644 --- a/impls/picolisp/step5_tco.l +++ b/impls/picolisp/step5_tco.l @@ -1,94 +1,94 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") -(load-relative "env.l") -(load-relative "func.l") -(load-relative "core.l") - -(de READ (String) - (read-str String) ) - -(def '*ReplEnv (MAL-env NIL)) -(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) - -(de EVAL (Ast Env) - (catch 'done - (while t - (if (and (= (MAL-type Ast) 'list) (MAL-value Ast)) - (let (Ast* (MAL-value Ast) - A0* (MAL-value (car Ast*)) - A1 (cadr Ast*) - A1* (MAL-value A1) - A2 (caddr Ast*) - A3 (cadddr Ast*) ) - (cond - ((= A0* 'def!) - (throw 'done (set> Env A1* (EVAL A2 Env))) ) - ((= A0* 'let*) - (let Env* (MAL-env Env) - (for (Bindings A1* Bindings) - (let (Key (MAL-value (pop 'Bindings)) - Value (EVAL (pop 'Bindings) Env*) ) - (set> Env* Key Value) ) ) - (setq Env Env* Ast A2) ) ) # TCO - ((= A0* 'do) - (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) - (setq Ast (last Ast*)) ) # TCO - ((= A0* 'if) - (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) - (setq Ast A2) # TCO - (if A3 - (setq Ast A3) # TCO - (throw 'done *MAL-nil) ) ) ) - ((= A0* 'fn*) - (let (Binds (mapcar MAL-value A1*) - Body A2 - Fn (MAL-fn - (curry (Env Binds Body) @ - (let Env* (MAL-env Env Binds (rest)) - (EVAL Body Env*) ) ) ) ) - (throw 'done (MAL-func Env Body Binds Fn)) ) ) - (T - (let (Ast* (MAL-value (eval-ast Ast Env)) - Fn (car Ast*) - Args (cdr Ast*) ) - (if (isa '+MALFn Fn) - (throw 'done (apply (MAL-value Fn) Args)) - (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) - (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) - (throw 'done (eval-ast Ast Env)) ) ) ) ) - -(de eval-ast (Ast Env) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - (symbol (get> Env Value)) - (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) - (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) - (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) - (T Ast) ) ) ) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String) *ReplEnv)) ) - -(rep "(def! not (fn* (a) (if a false true)))") - -(load-history ".mal_history") - -(use Input - (until (=0 (setq Input (readline "user> "))) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") +(load-relative "env.l") +(load-relative "func.l") +(load-relative "core.l") + +(de READ (String) + (read-str String) ) + +(def '*ReplEnv (MAL-env NIL)) +(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) + +(de EVAL (Ast Env) + (catch 'done + (while t + (if (and (= (MAL-type Ast) 'list) (MAL-value Ast)) + (let (Ast* (MAL-value Ast) + A0* (MAL-value (car Ast*)) + A1 (cadr Ast*) + A1* (MAL-value A1) + A2 (caddr Ast*) + A3 (cadddr Ast*) ) + (cond + ((= A0* 'def!) + (throw 'done (set> Env A1* (EVAL A2 Env))) ) + ((= A0* 'let*) + (let Env* (MAL-env Env) + (for (Bindings A1* Bindings) + (let (Key (MAL-value (pop 'Bindings)) + Value (EVAL (pop 'Bindings) Env*) ) + (set> Env* Key Value) ) ) + (setq Env Env* Ast A2) ) ) # TCO + ((= A0* 'do) + (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) + (setq Ast (last Ast*)) ) # TCO + ((= A0* 'if) + (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) + (setq Ast A2) # TCO + (if A3 + (setq Ast A3) # TCO + (throw 'done *MAL-nil) ) ) ) + ((= A0* 'fn*) + (let (Binds (mapcar MAL-value A1*) + Body A2 + Fn (MAL-fn + (curry (Env Binds Body) @ + (let Env* (MAL-env Env Binds (rest)) + (EVAL Body Env*) ) ) ) ) + (throw 'done (MAL-func Env Body Binds Fn)) ) ) + (T + (let (Ast* (MAL-value (eval-ast Ast Env)) + Fn (car Ast*) + Args (cdr Ast*) ) + (if (isa '+MALFn Fn) + (throw 'done (apply (MAL-value Fn) Args)) + (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) + (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) + (throw 'done (eval-ast Ast Env)) ) ) ) ) + +(de eval-ast (Ast Env) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + (symbol (get> Env Value)) + (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) + (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) + (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) + (T Ast) ) ) ) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String) *ReplEnv)) ) + +(rep "(def! not (fn* (a) (if a false true)))") + +(load-history ".mal_history") + +(use Input + (until (=0 (setq Input (readline "user> "))) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/step6_file.l b/impls/picolisp/step6_file.l index 93254a9feb..328a6f4a44 100644 --- a/impls/picolisp/step6_file.l +++ b/impls/picolisp/step6_file.l @@ -1,100 +1,100 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") -(load-relative "env.l") -(load-relative "func.l") -(load-relative "core.l") - -(de READ (String) - (read-str String) ) - -(def '*ReplEnv (MAL-env NIL)) -(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) - -(de EVAL (Ast Env) - (catch 'done - (while t - (if (and (= (MAL-type Ast) 'list) (MAL-value Ast)) - (let (Ast* (MAL-value Ast) - A0* (MAL-value (car Ast*)) - A1 (cadr Ast*) - A1* (MAL-value A1) - A2 (caddr Ast*) - A3 (cadddr Ast*) ) - (cond - ((= A0* 'def!) - (throw 'done (set> Env A1* (EVAL A2 Env))) ) - ((= A0* 'let*) - (let Env* (MAL-env Env) - (for (Bindings A1* Bindings) - (let (Key (MAL-value (pop 'Bindings)) - Value (EVAL (pop 'Bindings) Env*) ) - (set> Env* Key Value) ) ) - (setq Env Env* Ast A2) ) ) # TCO - ((= A0* 'do) - (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) - (setq Ast (last Ast*)) ) # TCO - ((= A0* 'if) - (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) - (setq Ast A2) # TCO - (if A3 - (setq Ast A3) # TCO - (throw 'done *MAL-nil) ) ) ) - ((= A0* 'fn*) - (let (Binds (mapcar MAL-value A1*) - Body A2 - Fn (MAL-fn - (curry (Env Binds Body) @ - (let Env* (MAL-env Env Binds (rest)) - (EVAL Body Env*) ) ) ) ) - (throw 'done (MAL-func Env Body Binds Fn)) ) ) - (T - (let (Ast* (MAL-value (eval-ast Ast Env)) - Fn (car Ast*) - Args (cdr Ast*) ) - (if (isa '+MALFn Fn) - (throw 'done (apply (MAL-value Fn) Args)) - (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) - (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) - (throw 'done (eval-ast Ast Env)) ) ) ) ) - -(de eval-ast (Ast Env) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - (symbol (get> Env Value)) - (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) - (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) - (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) - (T Ast) ) ) ) - -(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) -(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String) *ReplEnv)) ) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(load-history ".mal_history") - -(if (argv) - (rep (pack "(load-file \"" (car (argv)) "\")")) - (use Input - (until (=0 (setq Input (readline "user> "))) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") +(load-relative "env.l") +(load-relative "func.l") +(load-relative "core.l") + +(de READ (String) + (read-str String) ) + +(def '*ReplEnv (MAL-env NIL)) +(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) + +(de EVAL (Ast Env) + (catch 'done + (while t + (if (and (= (MAL-type Ast) 'list) (MAL-value Ast)) + (let (Ast* (MAL-value Ast) + A0* (MAL-value (car Ast*)) + A1 (cadr Ast*) + A1* (MAL-value A1) + A2 (caddr Ast*) + A3 (cadddr Ast*) ) + (cond + ((= A0* 'def!) + (throw 'done (set> Env A1* (EVAL A2 Env))) ) + ((= A0* 'let*) + (let Env* (MAL-env Env) + (for (Bindings A1* Bindings) + (let (Key (MAL-value (pop 'Bindings)) + Value (EVAL (pop 'Bindings) Env*) ) + (set> Env* Key Value) ) ) + (setq Env Env* Ast A2) ) ) # TCO + ((= A0* 'do) + (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) + (setq Ast (last Ast*)) ) # TCO + ((= A0* 'if) + (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) + (setq Ast A2) # TCO + (if A3 + (setq Ast A3) # TCO + (throw 'done *MAL-nil) ) ) ) + ((= A0* 'fn*) + (let (Binds (mapcar MAL-value A1*) + Body A2 + Fn (MAL-fn + (curry (Env Binds Body) @ + (let Env* (MAL-env Env Binds (rest)) + (EVAL Body Env*) ) ) ) ) + (throw 'done (MAL-func Env Body Binds Fn)) ) ) + (T + (let (Ast* (MAL-value (eval-ast Ast Env)) + Fn (car Ast*) + Args (cdr Ast*) ) + (if (isa '+MALFn Fn) + (throw 'done (apply (MAL-value Fn) Args)) + (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) + (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) + (throw 'done (eval-ast Ast Env)) ) ) ) ) + +(de eval-ast (Ast Env) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + (symbol (get> Env Value)) + (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) + (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) + (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) + (T Ast) ) ) ) + +(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) +(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String) *ReplEnv)) ) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(load-history ".mal_history") + +(if (argv) + (rep (pack "(load-file \"" (car (argv)) "\")")) + (use Input + (until (=0 (setq Input (readline "user> "))) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/step7_quote.l b/impls/picolisp/step7_quote.l index 72fa6450ff..10932d5eb1 100644 --- a/impls/picolisp/step7_quote.l +++ b/impls/picolisp/step7_quote.l @@ -1,132 +1,132 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") -(load-relative "env.l") -(load-relative "func.l") -(load-relative "core.l") - -(de READ (String) - (read-str String) ) - -(def '*ReplEnv (MAL-env NIL)) -(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) - -(de starts-with (Ast Sym) ;; MAL list, symbol -> nil or second element of Ast - (let (L (MAL-value Ast) - A0 (car L)) - (and (= (MAL-type A0) 'symbol) - (= (MAL-value A0) Sym) - (cadr L)))) - -(de quasiquote-loop (Xs) ;; list -> MAL list - (MAL-list - (when Xs - (let (Elt (car Xs) - Unq (when (= (MAL-type Elt) 'list) - (starts-with Elt 'splice-unquote)) - Acc (quasiquote-loop (cdr Xs))) - (if Unq - (list (MAL-symbol 'concat) Unq Acc) - (list (MAL-symbol 'cons) (quasiquote Elt) Acc)))))) - -(de quasiquote (Ast) - (case (MAL-type Ast) - (list (or (starts-with Ast 'unquote) - (quasiquote-loop (MAL-value Ast)))) - (vector (MAL-list (list (MAL-symbol 'vec) (quasiquote-loop (MAL-value Ast))))) - ((map symbol) (MAL-list (list (MAL-symbol 'quote) Ast))) - (T Ast))) - -(de EVAL (Ast Env) - (catch 'done - (while t - (if (and (= (MAL-type Ast) 'list) (MAL-value Ast)) - (let (Ast* (MAL-value Ast) - A0* (MAL-value (car Ast*)) - A1 (cadr Ast*) - A1* (MAL-value A1) - A2 (caddr Ast*) - A3 (cadddr Ast*) ) - (cond - ((= A0* 'def!) - (throw 'done (set> Env A1* (EVAL A2 Env))) ) - ((= A0* 'quote) - (throw 'done A1) ) - ((= A0* 'quasiquoteexpand) - (throw 'done (quasiquote A1))) - ((= A0* 'quasiquote) - (setq Ast (quasiquote A1)) ) # TCO - ((= A0* 'let*) - (let Env* (MAL-env Env) - (for (Bindings A1* Bindings) - (let (Key (MAL-value (pop 'Bindings)) - Value (EVAL (pop 'Bindings) Env*) ) - (set> Env* Key Value) ) ) - (setq Env Env* Ast A2) ) ) # TCO - ((= A0* 'do) - (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) - (setq Ast (last Ast*)) ) # TCO - ((= A0* 'if) - (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) - (setq Ast A2) # TCO - (if A3 - (setq Ast A3) # TCO - (throw 'done *MAL-nil) ) ) ) - ((= A0* 'fn*) - (let (Binds (mapcar MAL-value A1*) - Body A2 - Fn (MAL-fn - (curry (Env Binds Body) @ - (let Env* (MAL-env Env Binds (rest)) - (EVAL Body Env*) ) ) ) ) - (throw 'done (MAL-func Env Body Binds Fn)) ) ) - (T - (let (Ast* (MAL-value (eval-ast Ast Env)) - Fn (car Ast*) - Args (cdr Ast*) ) - (if (isa '+MALFn Fn) - (throw 'done (apply (MAL-value Fn) Args)) - (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) - (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) - (throw 'done (eval-ast Ast Env)) ) ) ) ) - -(de eval-ast (Ast Env) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - (symbol (get> Env Value)) - (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) - (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) - (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) - (T Ast) ) ) ) - -(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) -(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String) *ReplEnv)) ) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(load-history ".mal_history") - -(if (argv) - (rep (pack "(load-file \"" (car (argv)) "\")")) - (use Input - (until (=0 (setq Input (readline "user> "))) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") +(load-relative "env.l") +(load-relative "func.l") +(load-relative "core.l") + +(de READ (String) + (read-str String) ) + +(def '*ReplEnv (MAL-env NIL)) +(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) + +(de starts-with (Ast Sym) ;; MAL list, symbol -> nil or second element of Ast + (let (L (MAL-value Ast) + A0 (car L)) + (and (= (MAL-type A0) 'symbol) + (= (MAL-value A0) Sym) + (cadr L)))) + +(de quasiquote-loop (Xs) ;; list -> MAL list + (MAL-list + (when Xs + (let (Elt (car Xs) + Unq (when (= (MAL-type Elt) 'list) + (starts-with Elt 'splice-unquote)) + Acc (quasiquote-loop (cdr Xs))) + (if Unq + (list (MAL-symbol 'concat) Unq Acc) + (list (MAL-symbol 'cons) (quasiquote Elt) Acc)))))) + +(de quasiquote (Ast) + (case (MAL-type Ast) + (list (or (starts-with Ast 'unquote) + (quasiquote-loop (MAL-value Ast)))) + (vector (MAL-list (list (MAL-symbol 'vec) (quasiquote-loop (MAL-value Ast))))) + ((map symbol) (MAL-list (list (MAL-symbol 'quote) Ast))) + (T Ast))) + +(de EVAL (Ast Env) + (catch 'done + (while t + (if (and (= (MAL-type Ast) 'list) (MAL-value Ast)) + (let (Ast* (MAL-value Ast) + A0* (MAL-value (car Ast*)) + A1 (cadr Ast*) + A1* (MAL-value A1) + A2 (caddr Ast*) + A3 (cadddr Ast*) ) + (cond + ((= A0* 'def!) + (throw 'done (set> Env A1* (EVAL A2 Env))) ) + ((= A0* 'quote) + (throw 'done A1) ) + ((= A0* 'quasiquoteexpand) + (throw 'done (quasiquote A1))) + ((= A0* 'quasiquote) + (setq Ast (quasiquote A1)) ) # TCO + ((= A0* 'let*) + (let Env* (MAL-env Env) + (for (Bindings A1* Bindings) + (let (Key (MAL-value (pop 'Bindings)) + Value (EVAL (pop 'Bindings) Env*) ) + (set> Env* Key Value) ) ) + (setq Env Env* Ast A2) ) ) # TCO + ((= A0* 'do) + (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) + (setq Ast (last Ast*)) ) # TCO + ((= A0* 'if) + (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) + (setq Ast A2) # TCO + (if A3 + (setq Ast A3) # TCO + (throw 'done *MAL-nil) ) ) ) + ((= A0* 'fn*) + (let (Binds (mapcar MAL-value A1*) + Body A2 + Fn (MAL-fn + (curry (Env Binds Body) @ + (let Env* (MAL-env Env Binds (rest)) + (EVAL Body Env*) ) ) ) ) + (throw 'done (MAL-func Env Body Binds Fn)) ) ) + (T + (let (Ast* (MAL-value (eval-ast Ast Env)) + Fn (car Ast*) + Args (cdr Ast*) ) + (if (isa '+MALFn Fn) + (throw 'done (apply (MAL-value Fn) Args)) + (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) + (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) + (throw 'done (eval-ast Ast Env)) ) ) ) ) + +(de eval-ast (Ast Env) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + (symbol (get> Env Value)) + (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) + (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) + (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) + (T Ast) ) ) ) + +(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) +(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String) *ReplEnv)) ) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(load-history ".mal_history") + +(if (argv) + (rep (pack "(load-file \"" (car (argv)) "\")")) + (use Input + (until (=0 (setq Input (readline "user> "))) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/step8_macros.l b/impls/picolisp/step8_macros.l index e5a2572c0f..a5da3c16a6 100644 --- a/impls/picolisp/step8_macros.l +++ b/impls/picolisp/step8_macros.l @@ -1,156 +1,156 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") -(load-relative "env.l") -(load-relative "func.l") -(load-relative "core.l") - -(de READ (String) - (read-str String) ) - -(def '*ReplEnv (MAL-env NIL)) -(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) - -(de starts-with (Ast Sym) ;; MAL list, symbol -> nil or second element of Ast - (let (L (MAL-value Ast) - A0 (car L)) - (and (= (MAL-type A0) 'symbol) - (= (MAL-value A0) Sym) - (cadr L)))) - -(de quasiquote-loop (Xs) ;; list -> MAL list - (MAL-list - (when Xs - (let (Elt (car Xs) - Unq (when (= (MAL-type Elt) 'list) - (starts-with Elt 'splice-unquote)) - Acc (quasiquote-loop (cdr Xs))) - (if Unq - (list (MAL-symbol 'concat) Unq Acc) - (list (MAL-symbol 'cons) (quasiquote Elt) Acc)))))) - -(de quasiquote (Ast) - (case (MAL-type Ast) - (list (or (starts-with Ast 'unquote) - (quasiquote-loop (MAL-value Ast)))) - (vector (MAL-list (list (MAL-symbol 'vec) (quasiquote-loop (MAL-value Ast))))) - ((map symbol) (MAL-list (list (MAL-symbol 'quote) Ast))) - (T Ast))) - -(de is-macro-call (Ast Env) - (when (= (MAL-type Ast) 'list) - (let A0 (car (MAL-value Ast)) - (when (= (MAL-type A0) 'symbol) - (let Value (find> Env (MAL-value A0)) - (and (isa '+Func Value) (get Value 'is-macro) T) ) ) ) ) ) - -(de macroexpand (Ast Env) - (while (is-macro-call Ast Env) - (let (Ast* (MAL-value Ast) - Macro (get (find> Env (MAL-value (car Ast*))) 'fn) - Args (cdr Ast*) ) - (setq Ast (apply (MAL-value Macro) Args)) ) ) - Ast ) - -(de EVAL (Ast Env) - (catch 'done - (while t - (when (not (= (MAL-type Ast) 'list)) - (throw 'done (eval-ast Ast Env)) ) - (setq Ast (macroexpand Ast Env)) - (when (or (not (= (MAL-type Ast) 'list)) (not (MAL-value Ast))) - (throw 'done (eval-ast Ast Env)) ) - (let (Ast* (MAL-value Ast) - A0* (MAL-value (car Ast*)) - A1 (cadr Ast*) - A1* (MAL-value A1) - A2 (caddr Ast*) - A3 (cadddr Ast*) ) - (cond - ((= A0* 'def!) - (throw 'done (set> Env A1* (EVAL A2 Env))) ) - ((= A0* 'quote) - (throw 'done A1) ) - ((= A0* 'quasiquoteexpand) - (throw 'done (quasiquote A1))) - ((= A0* 'quasiquote) - (setq Ast (quasiquote A1)) ) # TCO - ((= A0* 'defmacro!) - (throw 'done (set> Env A1* (MAL-macro (EVAL A2 Env))))) - ((= A0* 'macroexpand) - (throw 'done (macroexpand A1 Env)) ) - ((= A0* 'let*) - (let Env* (MAL-env Env) - (for (Bindings A1* Bindings) - (let (Key (MAL-value (pop 'Bindings)) - Value (EVAL (pop 'Bindings) Env*) ) - (set> Env* Key Value) ) ) - (setq Env Env* Ast A2) ) ) # TCO - ((= A0* 'do) - (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) - (setq Ast (last Ast*)) ) # TCO - ((= A0* 'if) - (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) - (setq Ast A2) # TCO - (if A3 - (setq Ast A3) # TCO - (throw 'done *MAL-nil) ) ) ) - ((= A0* 'fn*) - (let (Binds (mapcar MAL-value A1*) - Body A2 - Fn (MAL-fn - (curry (Env Binds Body) @ - (let Env* (MAL-env Env Binds (rest)) - (EVAL Body Env*) ) ) ) ) - (throw 'done (MAL-func Env Body Binds Fn)) ) ) - (T - (let (Ast* (MAL-value (eval-ast Ast Env)) - Fn (car Ast*) - Args (cdr Ast*) ) - (if (isa '+MALFn Fn) - (throw 'done (apply (MAL-value Fn) Args)) - (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) - (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) ) ) ) - -(de eval-ast (Ast Env) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - (symbol (get> Env Value)) - (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) - (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) - (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) - (T Ast) ) ) ) - -(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) -(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String) *ReplEnv)) ) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - - -(load-history ".mal_history") - -(if (argv) - (rep (pack "(load-file \"" (car (argv)) "\")")) - (use Input - (until (=0 (setq Input (readline "user> "))) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") +(load-relative "env.l") +(load-relative "func.l") +(load-relative "core.l") + +(de READ (String) + (read-str String) ) + +(def '*ReplEnv (MAL-env NIL)) +(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) + +(de starts-with (Ast Sym) ;; MAL list, symbol -> nil or second element of Ast + (let (L (MAL-value Ast) + A0 (car L)) + (and (= (MAL-type A0) 'symbol) + (= (MAL-value A0) Sym) + (cadr L)))) + +(de quasiquote-loop (Xs) ;; list -> MAL list + (MAL-list + (when Xs + (let (Elt (car Xs) + Unq (when (= (MAL-type Elt) 'list) + (starts-with Elt 'splice-unquote)) + Acc (quasiquote-loop (cdr Xs))) + (if Unq + (list (MAL-symbol 'concat) Unq Acc) + (list (MAL-symbol 'cons) (quasiquote Elt) Acc)))))) + +(de quasiquote (Ast) + (case (MAL-type Ast) + (list (or (starts-with Ast 'unquote) + (quasiquote-loop (MAL-value Ast)))) + (vector (MAL-list (list (MAL-symbol 'vec) (quasiquote-loop (MAL-value Ast))))) + ((map symbol) (MAL-list (list (MAL-symbol 'quote) Ast))) + (T Ast))) + +(de is-macro-call (Ast Env) + (when (= (MAL-type Ast) 'list) + (let A0 (car (MAL-value Ast)) + (when (= (MAL-type A0) 'symbol) + (let Value (find> Env (MAL-value A0)) + (and (isa '+Func Value) (get Value 'is-macro) T) ) ) ) ) ) + +(de macroexpand (Ast Env) + (while (is-macro-call Ast Env) + (let (Ast* (MAL-value Ast) + Macro (get (find> Env (MAL-value (car Ast*))) 'fn) + Args (cdr Ast*) ) + (setq Ast (apply (MAL-value Macro) Args)) ) ) + Ast ) + +(de EVAL (Ast Env) + (catch 'done + (while t + (when (not (= (MAL-type Ast) 'list)) + (throw 'done (eval-ast Ast Env)) ) + (setq Ast (macroexpand Ast Env)) + (when (or (not (= (MAL-type Ast) 'list)) (not (MAL-value Ast))) + (throw 'done (eval-ast Ast Env)) ) + (let (Ast* (MAL-value Ast) + A0* (MAL-value (car Ast*)) + A1 (cadr Ast*) + A1* (MAL-value A1) + A2 (caddr Ast*) + A3 (cadddr Ast*) ) + (cond + ((= A0* 'def!) + (throw 'done (set> Env A1* (EVAL A2 Env))) ) + ((= A0* 'quote) + (throw 'done A1) ) + ((= A0* 'quasiquoteexpand) + (throw 'done (quasiquote A1))) + ((= A0* 'quasiquote) + (setq Ast (quasiquote A1)) ) # TCO + ((= A0* 'defmacro!) + (throw 'done (set> Env A1* (MAL-macro (EVAL A2 Env))))) + ((= A0* 'macroexpand) + (throw 'done (macroexpand A1 Env)) ) + ((= A0* 'let*) + (let Env* (MAL-env Env) + (for (Bindings A1* Bindings) + (let (Key (MAL-value (pop 'Bindings)) + Value (EVAL (pop 'Bindings) Env*) ) + (set> Env* Key Value) ) ) + (setq Env Env* Ast A2) ) ) # TCO + ((= A0* 'do) + (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) + (setq Ast (last Ast*)) ) # TCO + ((= A0* 'if) + (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) + (setq Ast A2) # TCO + (if A3 + (setq Ast A3) # TCO + (throw 'done *MAL-nil) ) ) ) + ((= A0* 'fn*) + (let (Binds (mapcar MAL-value A1*) + Body A2 + Fn (MAL-fn + (curry (Env Binds Body) @ + (let Env* (MAL-env Env Binds (rest)) + (EVAL Body Env*) ) ) ) ) + (throw 'done (MAL-func Env Body Binds Fn)) ) ) + (T + (let (Ast* (MAL-value (eval-ast Ast Env)) + Fn (car Ast*) + Args (cdr Ast*) ) + (if (isa '+MALFn Fn) + (throw 'done (apply (MAL-value Fn) Args)) + (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) + (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) ) ) ) + +(de eval-ast (Ast Env) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + (symbol (get> Env Value)) + (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) + (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) + (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) + (T Ast) ) ) ) + +(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) +(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String) *ReplEnv)) ) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + + +(load-history ".mal_history") + +(if (argv) + (rep (pack "(load-file \"" (car (argv)) "\")")) + (use Input + (until (=0 (setq Input (readline "user> "))) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/step9_try.l b/impls/picolisp/step9_try.l index 7101379a4a..f045aced73 100644 --- a/impls/picolisp/step9_try.l +++ b/impls/picolisp/step9_try.l @@ -1,168 +1,168 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") -(load-relative "env.l") -(load-relative "func.l") -(load-relative "core.l") - -(de READ (String) - (read-str String) ) - -(def '*ReplEnv (MAL-env NIL)) -(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) - -(de starts-with (Ast Sym) ;; MAL list, symbol -> nil or second element of Ast - (let (L (MAL-value Ast) - A0 (car L)) - (and (= (MAL-type A0) 'symbol) - (= (MAL-value A0) Sym) - (cadr L)))) - -(de quasiquote-loop (Xs) ;; list -> MAL list - (MAL-list - (when Xs - (let (Elt (car Xs) - Unq (when (= (MAL-type Elt) 'list) - (starts-with Elt 'splice-unquote)) - Acc (quasiquote-loop (cdr Xs))) - (if Unq - (list (MAL-symbol 'concat) Unq Acc) - (list (MAL-symbol 'cons) (quasiquote Elt) Acc)))))) - -(de quasiquote (Ast) - (case (MAL-type Ast) - (list (or (starts-with Ast 'unquote) - (quasiquote-loop (MAL-value Ast)))) - (vector (MAL-list (list (MAL-symbol 'vec) (quasiquote-loop (MAL-value Ast))))) - ((map symbol) (MAL-list (list (MAL-symbol 'quote) Ast))) - (T Ast))) - -(de is-macro-call (Ast Env) - (when (= (MAL-type Ast) 'list) - (let A0 (car (MAL-value Ast)) - (when (= (MAL-type A0) 'symbol) - (let Value (find> Env (MAL-value A0)) - (and (isa '+Func Value) (get Value 'is-macro) T) ) ) ) ) ) - -(de macroexpand (Ast Env) - (while (is-macro-call Ast Env) - (let (Ast* (MAL-value Ast) - Macro (get (find> Env (MAL-value (car Ast*))) 'fn) - Args (cdr Ast*) ) - (setq Ast (apply (MAL-value Macro) Args)) ) ) - Ast ) - -(de EVAL (Ast Env) - (catch 'done - (while t - (when (not (= (MAL-type Ast) 'list)) - (throw 'done (eval-ast Ast Env)) ) - (setq Ast (macroexpand Ast Env)) - (when (or (not (= (MAL-type Ast) 'list)) (not (MAL-value Ast))) - (throw 'done (eval-ast Ast Env)) ) - (let (Ast* (MAL-value Ast) - A0* (MAL-value (car Ast*)) - A1 (cadr Ast*) - A1* (MAL-value A1) - A2 (caddr Ast*) - A3 (cadddr Ast*) ) - (cond - ((= A0* 'def!) - (throw 'done (set> Env A1* (EVAL A2 Env))) ) - ((= A0* 'quote) - (throw 'done A1) ) - ((= A0* 'quasiquoteexpand) - (throw 'done (quasiquote A1))) - ((= A0* 'quasiquote) - (setq Ast (quasiquote A1)) ) # TCO - ((= A0* 'defmacro!) - (throw 'done (set> Env A1* (MAL-macro (EVAL A2 Env))))) - ((= A0* 'macroexpand) - (throw 'done (macroexpand A1 Env)) ) - ((= A0* 'try*) - (let Result (catch 'err (throw 'done (EVAL A1 Env))) - (if (isa '+MALError Result) - (let A (MAL-value A2) - (if (and (= (MAL-type A2) 'list) - (= (MAL-value (car A)) 'catch*) ) - (let (Bind (MAL-value (cadr A)) - Exc (MAL-value Result) - Form (caddr A) - Env* (MAL-env Env (list Bind) (list Exc)) ) - (throw 'done (EVAL Form Env*)) ) - (throw 'err Result) ) ) - (throw 'done Result) ) ) ) - ((= A0* 'let*) - (let Env* (MAL-env Env) - (for (Bindings A1* Bindings) - (let (Key (MAL-value (pop 'Bindings)) - Value (EVAL (pop 'Bindings) Env*) ) - (set> Env* Key Value) ) ) - (setq Env Env* Ast A2) ) ) # TCO - ((= A0* 'do) - (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) - (setq Ast (last Ast*)) ) # TCO - ((= A0* 'if) - (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) - (setq Ast A2) # TCO - (if A3 - (setq Ast A3) # TCO - (throw 'done *MAL-nil) ) ) ) - ((= A0* 'fn*) - (let (Binds (mapcar MAL-value A1*) - Body A2 - Fn (MAL-fn - (curry (Env Binds Body) @ - (let Env* (MAL-env Env Binds (rest)) - (EVAL Body Env*) ) ) ) ) - (throw 'done (MAL-func Env Body Binds Fn)) ) ) - (T - (let (Ast* (MAL-value (eval-ast Ast Env)) - Fn (car Ast*) - Args (cdr Ast*) ) - (if (isa '+MALFn Fn) - (throw 'done (apply (MAL-value Fn) Args)) - (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) - (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) ) ) ) - -(de eval-ast (Ast Env) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - (symbol (get> Env Value)) - (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) - (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) - (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) - (T Ast) ) ) ) - -(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) -(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String) *ReplEnv)) ) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(load-history ".mal_history") - -(if (argv) - (rep (pack "(load-file \"" (car (argv)) "\")")) - (use Input - (until (=0 (setq Input (readline "user> "))) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") +(load-relative "env.l") +(load-relative "func.l") +(load-relative "core.l") + +(de READ (String) + (read-str String) ) + +(def '*ReplEnv (MAL-env NIL)) +(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) + +(de starts-with (Ast Sym) ;; MAL list, symbol -> nil or second element of Ast + (let (L (MAL-value Ast) + A0 (car L)) + (and (= (MAL-type A0) 'symbol) + (= (MAL-value A0) Sym) + (cadr L)))) + +(de quasiquote-loop (Xs) ;; list -> MAL list + (MAL-list + (when Xs + (let (Elt (car Xs) + Unq (when (= (MAL-type Elt) 'list) + (starts-with Elt 'splice-unquote)) + Acc (quasiquote-loop (cdr Xs))) + (if Unq + (list (MAL-symbol 'concat) Unq Acc) + (list (MAL-symbol 'cons) (quasiquote Elt) Acc)))))) + +(de quasiquote (Ast) + (case (MAL-type Ast) + (list (or (starts-with Ast 'unquote) + (quasiquote-loop (MAL-value Ast)))) + (vector (MAL-list (list (MAL-symbol 'vec) (quasiquote-loop (MAL-value Ast))))) + ((map symbol) (MAL-list (list (MAL-symbol 'quote) Ast))) + (T Ast))) + +(de is-macro-call (Ast Env) + (when (= (MAL-type Ast) 'list) + (let A0 (car (MAL-value Ast)) + (when (= (MAL-type A0) 'symbol) + (let Value (find> Env (MAL-value A0)) + (and (isa '+Func Value) (get Value 'is-macro) T) ) ) ) ) ) + +(de macroexpand (Ast Env) + (while (is-macro-call Ast Env) + (let (Ast* (MAL-value Ast) + Macro (get (find> Env (MAL-value (car Ast*))) 'fn) + Args (cdr Ast*) ) + (setq Ast (apply (MAL-value Macro) Args)) ) ) + Ast ) + +(de EVAL (Ast Env) + (catch 'done + (while t + (when (not (= (MAL-type Ast) 'list)) + (throw 'done (eval-ast Ast Env)) ) + (setq Ast (macroexpand Ast Env)) + (when (or (not (= (MAL-type Ast) 'list)) (not (MAL-value Ast))) + (throw 'done (eval-ast Ast Env)) ) + (let (Ast* (MAL-value Ast) + A0* (MAL-value (car Ast*)) + A1 (cadr Ast*) + A1* (MAL-value A1) + A2 (caddr Ast*) + A3 (cadddr Ast*) ) + (cond + ((= A0* 'def!) + (throw 'done (set> Env A1* (EVAL A2 Env))) ) + ((= A0* 'quote) + (throw 'done A1) ) + ((= A0* 'quasiquoteexpand) + (throw 'done (quasiquote A1))) + ((= A0* 'quasiquote) + (setq Ast (quasiquote A1)) ) # TCO + ((= A0* 'defmacro!) + (throw 'done (set> Env A1* (MAL-macro (EVAL A2 Env))))) + ((= A0* 'macroexpand) + (throw 'done (macroexpand A1 Env)) ) + ((= A0* 'try*) + (let Result (catch 'err (throw 'done (EVAL A1 Env))) + (if (isa '+MALError Result) + (let A (MAL-value A2) + (if (and (= (MAL-type A2) 'list) + (= (MAL-value (car A)) 'catch*) ) + (let (Bind (MAL-value (cadr A)) + Exc (MAL-value Result) + Form (caddr A) + Env* (MAL-env Env (list Bind) (list Exc)) ) + (throw 'done (EVAL Form Env*)) ) + (throw 'err Result) ) ) + (throw 'done Result) ) ) ) + ((= A0* 'let*) + (let Env* (MAL-env Env) + (for (Bindings A1* Bindings) + (let (Key (MAL-value (pop 'Bindings)) + Value (EVAL (pop 'Bindings) Env*) ) + (set> Env* Key Value) ) ) + (setq Env Env* Ast A2) ) ) # TCO + ((= A0* 'do) + (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) + (setq Ast (last Ast*)) ) # TCO + ((= A0* 'if) + (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) + (setq Ast A2) # TCO + (if A3 + (setq Ast A3) # TCO + (throw 'done *MAL-nil) ) ) ) + ((= A0* 'fn*) + (let (Binds (mapcar MAL-value A1*) + Body A2 + Fn (MAL-fn + (curry (Env Binds Body) @ + (let Env* (MAL-env Env Binds (rest)) + (EVAL Body Env*) ) ) ) ) + (throw 'done (MAL-func Env Body Binds Fn)) ) ) + (T + (let (Ast* (MAL-value (eval-ast Ast Env)) + Fn (car Ast*) + Args (cdr Ast*) ) + (if (isa '+MALFn Fn) + (throw 'done (apply (MAL-value Fn) Args)) + (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) + (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) ) ) ) + +(de eval-ast (Ast Env) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + (symbol (get> Env Value)) + (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) + (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) + (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) + (T Ast) ) ) ) + +(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) +(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String) *ReplEnv)) ) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(load-history ".mal_history") + +(if (argv) + (rep (pack "(load-file \"" (car (argv)) "\")")) + (use Input + (until (=0 (setq Input (readline "user> "))) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/stepA_mal.l b/impls/picolisp/stepA_mal.l index 6e587d58ff..ce458bca24 100644 --- a/impls/picolisp/stepA_mal.l +++ b/impls/picolisp/stepA_mal.l @@ -1,170 +1,170 @@ -(de load-relative (Path) - (load (pack (car (file)) Path)) ) - -(load-relative "readline.l") -(load-relative "types.l") -(load-relative "reader.l") -(load-relative "printer.l") -(load-relative "env.l") -(load-relative "func.l") -(load-relative "core.l") - -(de READ (String) - (read-str String) ) - -(def '*ReplEnv (MAL-env NIL)) -(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) - -(de starts-with (Ast Sym) ;; MAL list, symbol -> nil or second element of Ast - (let (L (MAL-value Ast) - A0 (car L)) - (and (= (MAL-type A0) 'symbol) - (= (MAL-value A0) Sym) - (cadr L)))) - -(de quasiquote-loop (Xs) ;; list -> MAL list - (MAL-list - (when Xs - (let (Elt (car Xs) - Unq (when (= (MAL-type Elt) 'list) - (starts-with Elt 'splice-unquote)) - Acc (quasiquote-loop (cdr Xs))) - (if Unq - (list (MAL-symbol 'concat) Unq Acc) - (list (MAL-symbol 'cons) (quasiquote Elt) Acc)))))) - -(de quasiquote (Ast) - (case (MAL-type Ast) - (list (or (starts-with Ast 'unquote) - (quasiquote-loop (MAL-value Ast)))) - (vector (MAL-list (list (MAL-symbol 'vec) (quasiquote-loop (MAL-value Ast))))) - ((map symbol) (MAL-list (list (MAL-symbol 'quote) Ast))) - (T Ast))) - -(de is-macro-call (Ast Env) - (when (= (MAL-type Ast) 'list) - (let A0 (car (MAL-value Ast)) - (when (= (MAL-type A0) 'symbol) - (let Value (find> Env (MAL-value A0)) - (and (isa '+Func Value) (get Value 'is-macro) T) ) ) ) ) ) - -(de macroexpand (Ast Env) - (while (is-macro-call Ast Env) - (let (Ast* (MAL-value Ast) - Macro (get (find> Env (MAL-value (car Ast*))) 'fn) - Args (cdr Ast*) ) - (setq Ast (apply (MAL-value Macro) Args)) ) ) - Ast ) - -(de EVAL (Ast Env) - (catch 'done - (while t - (when (not (= (MAL-type Ast) 'list)) - (throw 'done (eval-ast Ast Env)) ) - (setq Ast (macroexpand Ast Env)) - (when (or (not (= (MAL-type Ast) 'list)) (not (MAL-value Ast))) - (throw 'done (eval-ast Ast Env)) ) - (let (Ast* (MAL-value Ast) - A0* (MAL-value (car Ast*)) - A1 (cadr Ast*) - A1* (MAL-value A1) - A2 (caddr Ast*) - A3 (cadddr Ast*) ) - (cond - ((= A0* 'def!) - (throw 'done (set> Env A1* (EVAL A2 Env))) ) - ((= A0* 'quote) - (throw 'done A1) ) - ((= A0* 'quasiquoteexpand) - (throw 'done (quasiquote A1))) - ((= A0* 'quasiquote) - (setq Ast (quasiquote A1)) ) # TCO - ((= A0* 'defmacro!) - (throw 'done (set> Env A1* (MAL-macro (EVAL A2 Env))))) - ((= A0* 'macroexpand) - (throw 'done (macroexpand A1 Env)) ) - ((= A0* 'try*) - (let Result (catch 'err (throw 'done (EVAL A1 Env))) - (if (isa '+MALError Result) - (let A (MAL-value A2) - (if (and (= (MAL-type A2) 'list) - (= (MAL-value (car A)) 'catch*) ) - (let (Bind (MAL-value (cadr A)) - Exc (MAL-value Result) - Form (caddr A) - Env* (MAL-env Env (list Bind) (list Exc)) ) - (throw 'done (EVAL Form Env*)) ) - (throw 'err Result) ) ) - (throw 'done Result) ) ) ) - ((= A0* 'let*) - (let Env* (MAL-env Env) - (for (Bindings A1* Bindings) - (let (Key (MAL-value (pop 'Bindings)) - Value (EVAL (pop 'Bindings) Env*) ) - (set> Env* Key Value) ) ) - (setq Env Env* Ast A2) ) ) # TCO - ((= A0* 'do) - (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) - (setq Ast (last Ast*)) ) # TCO - ((= A0* 'if) - (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) - (setq Ast A2) # TCO - (if A3 - (setq Ast A3) # TCO - (throw 'done *MAL-nil) ) ) ) - ((= A0* 'fn*) - (let (Binds (mapcar MAL-value A1*) - Body A2 - Fn (MAL-fn - (curry (Env Binds Body) @ - (let Env* (MAL-env Env Binds (rest)) - (EVAL Body Env*) ) ) ) ) - (throw 'done (MAL-func Env Body Binds Fn)) ) ) - (T - (let (Ast* (MAL-value (eval-ast Ast Env)) - Fn (car Ast*) - Args (cdr Ast*) ) - (if (isa '+MALFn Fn) - (throw 'done (apply (MAL-value Fn) Args)) - (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) - (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) ) ) ) - -(de eval-ast (Ast Env) - (let Value (MAL-value Ast) - (case (MAL-type Ast) - (symbol (get> Env Value)) - (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) - (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) - (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) - (T Ast) ) ) ) - -(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) -(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) -(set> *ReplEnv '*host-language* (MAL-string "pil")) - -(de PRINT (Ast) - (pr-str Ast T) ) - -(de rep (String) - (PRINT (EVAL (READ String) *ReplEnv)) ) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(load-history ".mal_history") - -(if (argv) - (rep (pack "(load-file \"" (car (argv)) "\")")) - (use Input - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (until (=0 (setq Input (readline "user> "))) - (let Output (catch 'err (rep Input)) - (if (isa '+MALError Output) - (let Message (MAL-value Output) - (unless (= (MAL-value Message) "end of token stream") - (prinl "[error] " (pr-str Message)) ) ) - (prinl Output) ) ) ) ) ) - -(prinl) -(bye) +(de load-relative (Path) + (load (pack (car (file)) Path)) ) + +(load-relative "readline.l") +(load-relative "types.l") +(load-relative "reader.l") +(load-relative "printer.l") +(load-relative "env.l") +(load-relative "func.l") +(load-relative "core.l") + +(de READ (String) + (read-str String) ) + +(def '*ReplEnv (MAL-env NIL)) +(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind))) + +(de starts-with (Ast Sym) ;; MAL list, symbol -> nil or second element of Ast + (let (L (MAL-value Ast) + A0 (car L)) + (and (= (MAL-type A0) 'symbol) + (= (MAL-value A0) Sym) + (cadr L)))) + +(de quasiquote-loop (Xs) ;; list -> MAL list + (MAL-list + (when Xs + (let (Elt (car Xs) + Unq (when (= (MAL-type Elt) 'list) + (starts-with Elt 'splice-unquote)) + Acc (quasiquote-loop (cdr Xs))) + (if Unq + (list (MAL-symbol 'concat) Unq Acc) + (list (MAL-symbol 'cons) (quasiquote Elt) Acc)))))) + +(de quasiquote (Ast) + (case (MAL-type Ast) + (list (or (starts-with Ast 'unquote) + (quasiquote-loop (MAL-value Ast)))) + (vector (MAL-list (list (MAL-symbol 'vec) (quasiquote-loop (MAL-value Ast))))) + ((map symbol) (MAL-list (list (MAL-symbol 'quote) Ast))) + (T Ast))) + +(de is-macro-call (Ast Env) + (when (= (MAL-type Ast) 'list) + (let A0 (car (MAL-value Ast)) + (when (= (MAL-type A0) 'symbol) + (let Value (find> Env (MAL-value A0)) + (and (isa '+Func Value) (get Value 'is-macro) T) ) ) ) ) ) + +(de macroexpand (Ast Env) + (while (is-macro-call Ast Env) + (let (Ast* (MAL-value Ast) + Macro (get (find> Env (MAL-value (car Ast*))) 'fn) + Args (cdr Ast*) ) + (setq Ast (apply (MAL-value Macro) Args)) ) ) + Ast ) + +(de EVAL (Ast Env) + (catch 'done + (while t + (when (not (= (MAL-type Ast) 'list)) + (throw 'done (eval-ast Ast Env)) ) + (setq Ast (macroexpand Ast Env)) + (when (or (not (= (MAL-type Ast) 'list)) (not (MAL-value Ast))) + (throw 'done (eval-ast Ast Env)) ) + (let (Ast* (MAL-value Ast) + A0* (MAL-value (car Ast*)) + A1 (cadr Ast*) + A1* (MAL-value A1) + A2 (caddr Ast*) + A3 (cadddr Ast*) ) + (cond + ((= A0* 'def!) + (throw 'done (set> Env A1* (EVAL A2 Env))) ) + ((= A0* 'quote) + (throw 'done A1) ) + ((= A0* 'quasiquoteexpand) + (throw 'done (quasiquote A1))) + ((= A0* 'quasiquote) + (setq Ast (quasiquote A1)) ) # TCO + ((= A0* 'defmacro!) + (throw 'done (set> Env A1* (MAL-macro (EVAL A2 Env))))) + ((= A0* 'macroexpand) + (throw 'done (macroexpand A1 Env)) ) + ((= A0* 'try*) + (let Result (catch 'err (throw 'done (EVAL A1 Env))) + (if (isa '+MALError Result) + (let A (MAL-value A2) + (if (and (= (MAL-type A2) 'list) + (= (MAL-value (car A)) 'catch*) ) + (let (Bind (MAL-value (cadr A)) + Exc (MAL-value Result) + Form (caddr A) + Env* (MAL-env Env (list Bind) (list Exc)) ) + (throw 'done (EVAL Form Env*)) ) + (throw 'err Result) ) ) + (throw 'done Result) ) ) ) + ((= A0* 'let*) + (let Env* (MAL-env Env) + (for (Bindings A1* Bindings) + (let (Key (MAL-value (pop 'Bindings)) + Value (EVAL (pop 'Bindings) Env*) ) + (set> Env* Key Value) ) ) + (setq Env Env* Ast A2) ) ) # TCO + ((= A0* 'do) + (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*))) + (setq Ast (last Ast*)) ) # TCO + ((= A0* 'if) + (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false))) + (setq Ast A2) # TCO + (if A3 + (setq Ast A3) # TCO + (throw 'done *MAL-nil) ) ) ) + ((= A0* 'fn*) + (let (Binds (mapcar MAL-value A1*) + Body A2 + Fn (MAL-fn + (curry (Env Binds Body) @ + (let Env* (MAL-env Env Binds (rest)) + (EVAL Body Env*) ) ) ) ) + (throw 'done (MAL-func Env Body Binds Fn)) ) ) + (T + (let (Ast* (MAL-value (eval-ast Ast Env)) + Fn (car Ast*) + Args (cdr Ast*) ) + (if (isa '+MALFn Fn) + (throw 'done (apply (MAL-value Fn) Args)) + (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args) + (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) ) ) ) + +(de eval-ast (Ast Env) + (let Value (MAL-value Ast) + (case (MAL-type Ast) + (symbol (get> Env Value)) + (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value))) + (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value))) + (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value))) + (T Ast) ) ) ) + +(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv)))) +(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv))))) +(set> *ReplEnv '*host-language* (MAL-string "pil")) + +(de PRINT (Ast) + (pr-str Ast T) ) + +(de rep (String) + (PRINT (EVAL (READ String) *ReplEnv)) ) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(load-history ".mal_history") + +(if (argv) + (rep (pack "(load-file \"" (car (argv)) "\")")) + (use Input + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (until (=0 (setq Input (readline "user> "))) + (let Output (catch 'err (rep Input)) + (if (isa '+MALError Output) + (let Message (MAL-value Output) + (unless (= (MAL-value Message) "end of token stream") + (prinl "[error] " (pr-str Message)) ) ) + (prinl Output) ) ) ) ) ) + +(prinl) +(bye) diff --git a/impls/picolisp/tests/step5_tco.mal b/impls/picolisp/tests/step5_tco.mal index 901069482d..0095b64026 100644 --- a/impls/picolisp/tests/step5_tco.mal +++ b/impls/picolisp/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; PIL: skipping non-TCO recursion -;; Reason: segfault (unrecoverable) +;; PIL: skipping non-TCO recursion +;; Reason: segfault (unrecoverable) diff --git a/impls/picolisp/tests/stepA_mal.mal b/impls/picolisp/tests/stepA_mal.mal index 562c5703ea..caab803e2f 100644 --- a/impls/picolisp/tests/stepA_mal.mal +++ b/impls/picolisp/tests/stepA_mal.mal @@ -1,17 +1,17 @@ -;; Testing basic pil interop - -(pil-eval "T") -;=>true - -(pil-eval "NIL") -;=>nil - -(pil-eval "(+ 1 1)") -;=>2 - -(pil-eval "(cons 1 2 3 NIL)") -;=>(1 2 3) - -(pil-eval "(use (@A @O) (match '(@A and @O) '(Alpha and Omega)) (prinl @A) (prinl @O))") -Alpha -Omega +;; Testing basic pil interop + +(pil-eval "T") +;=>true + +(pil-eval "NIL") +;=>nil + +(pil-eval "(+ 1 1)") +;=>2 + +(pil-eval "(cons 1 2 3 NIL)") +;=>(1 2 3) + +(pil-eval "(use (@A @O) (match '(@A and @O) '(Alpha and Omega)) (prinl @A) (prinl @O))") +Alpha +Omega diff --git a/impls/picolisp/types.l b/impls/picolisp/types.l index 299a071531..6b073ae09f 100644 --- a/impls/picolisp/types.l +++ b/impls/picolisp/types.l @@ -1,101 +1,101 @@ -(class +MAL) -# type value meta -(dm T (Type Value Meta) - (=: type Type) - (=: value Value) - (=: meta Meta) ) - -(de MAL-type (MAL) - (get MAL 'type) ) - -(de MAL-value (MAL) - (get MAL 'value) ) - -(de MAL-meta (MAL) - (get MAL 'meta) ) - -(class +MALTrue +MAL) -(dm T () - (super 'true 'true NIL) ) - -(class +MALFalse +MAL) -(dm T () - (super 'false 'false NIL) ) - -(class +MALNil +MAL) -(dm T () - (super 'nil 'nil NIL) ) - -(def '*MAL-true (new '(+MALTrue))) -(def '*MAL-false (new '(+MALFalse))) -(def '*MAL-nil (new '(+MALNil))) - -(class +MALNumber +MAL) -(dm T (Number) - (super 'number Number NIL) ) - -(de MAL-number (N) - (new '(+MALNumber) N) ) - -(class +MALString +MAL) -(dm T (String) - (super 'string String NIL) ) - -(de MAL-string (N) - (new '(+MALString) N) ) - -(class +MALSymbol +MAL) -(dm T (String) - (super 'symbol String NIL) ) - -(de MAL-symbol (N) - (new '(+MALSymbol) N) ) - -(class +MALKeyword +MAL) -(dm T (String) - (super 'keyword String NIL) ) - -(de MAL-keyword (N) - (new '(+MALKeyword) N) ) - -(class +MALList +MAL) -(dm T (Values) - (super 'list Values NIL) ) - -(de MAL-list (N) - (new '(+MALList) N) ) - -(class +MALVector +MAL) -(dm T (Values) - (super 'vector Values NIL) ) - -(de MAL-vector (N) - (new '(+MALVector) N) ) - -(class +MALMap +MAL) -(dm T (Values) - (super 'map Values NIL) ) - -(de MAL-map (N) - (new '(+MALMap) N) ) - -(class +MALAtom +MAL) -(dm T (Value) - (super 'atom Value NIL) ) - -(de MAL-atom (N) - (new '(+MALAtom) N) ) - -(class +MALFn +MAL) -(dm T (Fn) - (super 'fn Fn NIL) ) - -(de MAL-fn (Fn) - (new '(+MALFn) Fn) ) - -(class +MALError +MAL) -(dm T (Value) - (super 'error Value NIL) ) - -(de MAL-error (Value) - (new '(+MALError) Value) ) +(class +MAL) +# type value meta +(dm T (Type Value Meta) + (=: type Type) + (=: value Value) + (=: meta Meta) ) + +(de MAL-type (MAL) + (get MAL 'type) ) + +(de MAL-value (MAL) + (get MAL 'value) ) + +(de MAL-meta (MAL) + (get MAL 'meta) ) + +(class +MALTrue +MAL) +(dm T () + (super 'true 'true NIL) ) + +(class +MALFalse +MAL) +(dm T () + (super 'false 'false NIL) ) + +(class +MALNil +MAL) +(dm T () + (super 'nil 'nil NIL) ) + +(def '*MAL-true (new '(+MALTrue))) +(def '*MAL-false (new '(+MALFalse))) +(def '*MAL-nil (new '(+MALNil))) + +(class +MALNumber +MAL) +(dm T (Number) + (super 'number Number NIL) ) + +(de MAL-number (N) + (new '(+MALNumber) N) ) + +(class +MALString +MAL) +(dm T (String) + (super 'string String NIL) ) + +(de MAL-string (N) + (new '(+MALString) N) ) + +(class +MALSymbol +MAL) +(dm T (String) + (super 'symbol String NIL) ) + +(de MAL-symbol (N) + (new '(+MALSymbol) N) ) + +(class +MALKeyword +MAL) +(dm T (String) + (super 'keyword String NIL) ) + +(de MAL-keyword (N) + (new '(+MALKeyword) N) ) + +(class +MALList +MAL) +(dm T (Values) + (super 'list Values NIL) ) + +(de MAL-list (N) + (new '(+MALList) N) ) + +(class +MALVector +MAL) +(dm T (Values) + (super 'vector Values NIL) ) + +(de MAL-vector (N) + (new '(+MALVector) N) ) + +(class +MALMap +MAL) +(dm T (Values) + (super 'map Values NIL) ) + +(de MAL-map (N) + (new '(+MALMap) N) ) + +(class +MALAtom +MAL) +(dm T (Value) + (super 'atom Value NIL) ) + +(de MAL-atom (N) + (new '(+MALAtom) N) ) + +(class +MALFn +MAL) +(dm T (Fn) + (super 'fn Fn NIL) ) + +(de MAL-fn (Fn) + (new '(+MALFn) Fn) ) + +(class +MALError +MAL) +(dm T (Value) + (super 'error Value NIL) ) + +(de MAL-error (Value) + (new '(+MALError) Value) ) diff --git a/impls/pike/Core.pmod b/impls/pike/Core.pmod index 74b6d9c3c5..0de5a6d07a 100644 --- a/impls/pike/Core.pmod +++ b/impls/pike/Core.pmod @@ -1,98 +1,98 @@ -import .Interop; -import .Printer; -import .Reader; -import .Readline; -import .Types; - -private Val apply(mixed f, Val ... args) -{ - if(sizeof(args) == 1) return f(@args[0].data); - array(Val) mid_args = args[0..(sizeof(args) - 2)]; - return f(@(mid_args + args[-1].data)); -} - -private Val swap_bang(Val atom, mixed f, Val ... args) -{ - atom.data = f(@(({ atom.data }) + args)); - return atom.data; -} - -private mapping(string:function) builtins = ([ - "=": lambda(Val a, Val b) { return to_bool(a == b); }, - "throw": lambda(Val a) { throw(a); }, - - "nil?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_NIL); }, - "true?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_TRUE); }, - "false?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_FALSE); }, - "string?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_STRING); }, - "symbol": lambda(Val a) { return a.mal_type == MALTYPE_SYMBOL ? a : Symbol(a.value); }, - "symbol?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_SYMBOL); }, - "keyword": lambda(Val a) { return a.mal_type == MALTYPE_KEYWORD ? a : Keyword(a.value); }, - "keyword?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_KEYWORD); }, - "number?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_NUMBER); }, - "fn?": lambda(Val a) { return to_bool(a.is_fn && !a.macro); }, - "macro?": lambda(Val a) { return to_bool(a.macro); }, - - "pr-str": lambda(Val ... a) { return String(map(a, lambda(Val e) { return pr_str(e, true); }) * " "); }, - "str": lambda(Val ... a) { return String(map(a, lambda(Val e) { return pr_str(e, false); }) * ""); }, - "prn": lambda(Val ... a) { write(({ map(a, lambda(Val e) { return pr_str(e, true); }) * " ", "\n" })); return MAL_NIL; }, - "println": lambda(Val ... a) { write(({ map(a, lambda(Val e) { return pr_str(e, false); }) * " ", "\n" })); return MAL_NIL; }, - "read-string": lambda(Val a) { return read_str(a.value); }, - "readline": lambda(Val a) { string line = readline(a.value); return line ? String(line) : MAL_NIL; }, - "slurp": lambda(Val a) { return String(Stdio.read_file(a.value)); }, - - "<": lambda(Val a, Val b) { return to_bool(a.value < b.value); }, - "<=": lambda(Val a, Val b) { return to_bool(a.value <= b.value); }, - ">": lambda(Val a, Val b) { return to_bool(a.value > b.value); }, - ">=": lambda(Val a, Val b) { return to_bool(a.value >= b.value); }, - "+": lambda(Val a, Val b) { return Number(a.value + b.value); }, - "-": lambda(Val a, Val b) { return Number(a.value - b.value); }, - "*": lambda(Val a, Val b) { return Number(a.value * b.value); }, - "/": lambda(Val a, Val b) { return Number(a.value / b.value); }, - "time-ms": lambda() { array(int) t = System.gettimeofday(); return Number(t[0] * 1000 + t[1] / 1000); }, - - "list": lambda(Val ... a) { return List(a); }, - "list?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_LIST); }, - "vector": lambda(Val ... a) { return Vector(a); }, - "vector?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_VECTOR); }, - "hash-map": lambda(Val ... a) { return Map(a); }, - "map?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_MAP); }, - "assoc": lambda(Val a, Val ... b) { return a.assoc(b); }, - "dissoc": lambda(Val a, Val ... b) { return a.dissoc(b); }, - "get": lambda(Val a, Val b) { return a.mal_type != MALTYPE_NIL ? (a.data[b] || MAL_NIL) : MAL_NIL; }, - "contains?": lambda(Val a, Val b) { return to_bool(a.data[b]); }, - "keys": lambda(Val a) { return List(indices(a.data)); }, - "vals": lambda(Val a) { return List(values(a.data)); }, - - "sequential?": lambda(Val a) { return to_bool(a.is_sequence); }, - "cons": lambda(Val a, Val b) { return List(({ a }) + b.data); }, - "concat": lambda(Val ... a) { return List(`+(({ }), @map(a, lambda(Val e) { return e.data; }))); }, - "vec": lambda(Val a) { return Vector(a.data); }, - "nth": lambda(Val a, Val b) { return a.nth(b.value); }, - "first": lambda(Val a) { return a.first(); }, - "rest": lambda(Val a) { return a.rest(); }, - "empty?": lambda(Val a) { return to_bool(a.emptyp()); }, - "count": lambda(Val a) { return Number(a.count()); }, - "apply": apply, - "map": lambda(mixed f, Val a) { return List(map(a.data, f)); }, - - "conj": lambda(Val a, Val ... b) { return a.conj(b); }, - "seq": lambda(Val a) { return a.seq(); }, - - "meta": lambda(Val a) { return a.meta || MAL_NIL; }, - "with-meta": lambda(Val a, Val b) { Val new_a = a.clone(); new_a.meta = b; return new_a; }, - "atom": lambda(Val a) { return Atom(a); }, - "atom?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_ATOM); }, - "deref": lambda(Val a) { return a.data; }, - "reset!": lambda(Val a, Val b) { a.data = b; return a.data; }, - "swap!": swap_bang, - - "pike-eval": lambda(Val a) { return pike_eval(a.value); }, -]); - -mapping(Val:Val) NS() -{ - mapping(Val:Val) ns = ([ ]); - foreach(builtins; string name; function f) { ns[Symbol(name)] = BuiltinFn(name, f); } - return ns; -} +import .Interop; +import .Printer; +import .Reader; +import .Readline; +import .Types; + +private Val apply(mixed f, Val ... args) +{ + if(sizeof(args) == 1) return f(@args[0].data); + array(Val) mid_args = args[0..(sizeof(args) - 2)]; + return f(@(mid_args + args[-1].data)); +} + +private Val swap_bang(Val atom, mixed f, Val ... args) +{ + atom.data = f(@(({ atom.data }) + args)); + return atom.data; +} + +private mapping(string:function) builtins = ([ + "=": lambda(Val a, Val b) { return to_bool(a == b); }, + "throw": lambda(Val a) { throw(a); }, + + "nil?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_NIL); }, + "true?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_TRUE); }, + "false?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_FALSE); }, + "string?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_STRING); }, + "symbol": lambda(Val a) { return a.mal_type == MALTYPE_SYMBOL ? a : Symbol(a.value); }, + "symbol?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_SYMBOL); }, + "keyword": lambda(Val a) { return a.mal_type == MALTYPE_KEYWORD ? a : Keyword(a.value); }, + "keyword?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_KEYWORD); }, + "number?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_NUMBER); }, + "fn?": lambda(Val a) { return to_bool(a.is_fn && !a.macro); }, + "macro?": lambda(Val a) { return to_bool(a.macro); }, + + "pr-str": lambda(Val ... a) { return String(map(a, lambda(Val e) { return pr_str(e, true); }) * " "); }, + "str": lambda(Val ... a) { return String(map(a, lambda(Val e) { return pr_str(e, false); }) * ""); }, + "prn": lambda(Val ... a) { write(({ map(a, lambda(Val e) { return pr_str(e, true); }) * " ", "\n" })); return MAL_NIL; }, + "println": lambda(Val ... a) { write(({ map(a, lambda(Val e) { return pr_str(e, false); }) * " ", "\n" })); return MAL_NIL; }, + "read-string": lambda(Val a) { return read_str(a.value); }, + "readline": lambda(Val a) { string line = readline(a.value); return line ? String(line) : MAL_NIL; }, + "slurp": lambda(Val a) { return String(Stdio.read_file(a.value)); }, + + "<": lambda(Val a, Val b) { return to_bool(a.value < b.value); }, + "<=": lambda(Val a, Val b) { return to_bool(a.value <= b.value); }, + ">": lambda(Val a, Val b) { return to_bool(a.value > b.value); }, + ">=": lambda(Val a, Val b) { return to_bool(a.value >= b.value); }, + "+": lambda(Val a, Val b) { return Number(a.value + b.value); }, + "-": lambda(Val a, Val b) { return Number(a.value - b.value); }, + "*": lambda(Val a, Val b) { return Number(a.value * b.value); }, + "/": lambda(Val a, Val b) { return Number(a.value / b.value); }, + "time-ms": lambda() { array(int) t = System.gettimeofday(); return Number(t[0] * 1000 + t[1] / 1000); }, + + "list": lambda(Val ... a) { return List(a); }, + "list?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_LIST); }, + "vector": lambda(Val ... a) { return Vector(a); }, + "vector?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_VECTOR); }, + "hash-map": lambda(Val ... a) { return Map(a); }, + "map?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_MAP); }, + "assoc": lambda(Val a, Val ... b) { return a.assoc(b); }, + "dissoc": lambda(Val a, Val ... b) { return a.dissoc(b); }, + "get": lambda(Val a, Val b) { return a.mal_type != MALTYPE_NIL ? (a.data[b] || MAL_NIL) : MAL_NIL; }, + "contains?": lambda(Val a, Val b) { return to_bool(a.data[b]); }, + "keys": lambda(Val a) { return List(indices(a.data)); }, + "vals": lambda(Val a) { return List(values(a.data)); }, + + "sequential?": lambda(Val a) { return to_bool(a.is_sequence); }, + "cons": lambda(Val a, Val b) { return List(({ a }) + b.data); }, + "concat": lambda(Val ... a) { return List(`+(({ }), @map(a, lambda(Val e) { return e.data; }))); }, + "vec": lambda(Val a) { return Vector(a.data); }, + "nth": lambda(Val a, Val b) { return a.nth(b.value); }, + "first": lambda(Val a) { return a.first(); }, + "rest": lambda(Val a) { return a.rest(); }, + "empty?": lambda(Val a) { return to_bool(a.emptyp()); }, + "count": lambda(Val a) { return Number(a.count()); }, + "apply": apply, + "map": lambda(mixed f, Val a) { return List(map(a.data, f)); }, + + "conj": lambda(Val a, Val ... b) { return a.conj(b); }, + "seq": lambda(Val a) { return a.seq(); }, + + "meta": lambda(Val a) { return a.meta || MAL_NIL; }, + "with-meta": lambda(Val a, Val b) { Val new_a = a.clone(); new_a.meta = b; return new_a; }, + "atom": lambda(Val a) { return Atom(a); }, + "atom?": lambda(Val a) { return to_bool(a.mal_type == MALTYPE_ATOM); }, + "deref": lambda(Val a) { return a.data; }, + "reset!": lambda(Val a, Val b) { a.data = b; return a.data; }, + "swap!": swap_bang, + + "pike-eval": lambda(Val a) { return pike_eval(a.value); }, +]); + +mapping(Val:Val) NS() +{ + mapping(Val:Val) ns = ([ ]); + foreach(builtins; string name; function f) { ns[Symbol(name)] = BuiltinFn(name, f); } + return ns; +} diff --git a/impls/pike/Dockerfile b/impls/pike/Dockerfile index 121d2e8b73..f183b109a2 100644 --- a/impls/pike/Dockerfile +++ b/impls/pike/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install pike8.0 pike8.0-pcre +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install pike8.0 pike8.0-pcre diff --git a/impls/pike/Env.pmod b/impls/pike/Env.pmod index 93fcb45066..970187032b 100644 --- a/impls/pike/Env.pmod +++ b/impls/pike/Env.pmod @@ -1,45 +1,45 @@ -import .Types; - -class Env -{ - Env outer; - mapping(string:Val) data; - - void create(Env the_outer, List|void binds, List|void exprs) - { - outer = the_outer; - data = ([ ]); - if(binds) - { - for(int i = 0; i < binds.count(); i++) - { - if(binds.data[i].value == "&") - { - set(binds.data[i + 1], List(exprs.data[i..])); - break; - } - set(binds.data[i], exprs.data[i]); - } - } - } - - Val set(Val key, Val val) - { - data[key.value] = val; - return val; - } - - Env find(Val key) - { - if(data[key.value]) return this_object(); - if(outer) return outer.find(key); - return 0; - } - - Val get(Val key) - { - Env found_env = find(key); - if(!found_env) throw("'" + key.value + "' not found"); - return found_env.data[key.value]; - } -} +import .Types; + +class Env +{ + Env outer; + mapping(string:Val) data; + + void create(Env the_outer, List|void binds, List|void exprs) + { + outer = the_outer; + data = ([ ]); + if(binds) + { + for(int i = 0; i < binds.count(); i++) + { + if(binds.data[i].value == "&") + { + set(binds.data[i + 1], List(exprs.data[i..])); + break; + } + set(binds.data[i], exprs.data[i]); + } + } + } + + Val set(Val key, Val val) + { + data[key.value] = val; + return val; + } + + Env find(Val key) + { + if(data[key.value]) return this_object(); + if(outer) return outer.find(key); + return 0; + } + + Val get(Val key) + { + Env found_env = find(key); + if(!found_env) throw("'" + key.value + "' not found"); + return found_env.data[key.value]; + } +} diff --git a/impls/pike/Interop.pmod b/impls/pike/Interop.pmod index df09694579..7d35e26da8 100644 --- a/impls/pike/Interop.pmod +++ b/impls/pike/Interop.pmod @@ -1,33 +1,33 @@ -import .Types; - -Val pike_eval(string expr_str) -{ - program prog = compile_string("mixed tmp_func() { return (" + expr_str + "); }", "pike-eval"); - mixed v = prog()->tmp_func(); - return pike2mal(v); -} - -private Val pike2mal(mixed v) -{ - if(stringp(v)) return String(v); - if(intp(v)) return Number(v); - if(arrayp(v)) - { - array(Val) res = ({ }); - foreach(v, mixed e) - { - res += ({ pike2mal(e) }); - } - return List(res); - } - if(mappingp(v)) - { - array(Val) res = ({ }); - foreach(v; mixed k; mixed v) - { - res += ({ pike2mal(k), pike2mal(v) }); - } - return Map(res); - } - return MAL_NIL; -} +import .Types; + +Val pike_eval(string expr_str) +{ + program prog = compile_string("mixed tmp_func() { return (" + expr_str + "); }", "pike-eval"); + mixed v = prog()->tmp_func(); + return pike2mal(v); +} + +private Val pike2mal(mixed v) +{ + if(stringp(v)) return String(v); + if(intp(v)) return Number(v); + if(arrayp(v)) + { + array(Val) res = ({ }); + foreach(v, mixed e) + { + res += ({ pike2mal(e) }); + } + return List(res); + } + if(mappingp(v)) + { + array(Val) res = ({ }); + foreach(v; mixed k; mixed v) + { + res += ({ pike2mal(k), pike2mal(v) }); + } + return Map(res); + } + return MAL_NIL; +} diff --git a/impls/pike/Makefile b/impls/pike/Makefile index 862751b0fc..477ba9b849 100644 --- a/impls/pike/Makefile +++ b/impls/pike/Makefile @@ -1,19 +1,19 @@ -SOURCES_BASE = readline.pike types.pike reader.pike printer.pike -SOURCES_LISP = env.pike core.pike stepA_mal.pike -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.pike mal - -mal.pike: $(SOURCES) - cat $+ | grep -v "^#include" > $@ - -mal: mal.pike - echo "#!/usr/bin/env pike" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.pike mal +SOURCES_BASE = readline.pike types.pike reader.pike printer.pike +SOURCES_LISP = env.pike core.pike stepA_mal.pike +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.pike mal + +mal.pike: $(SOURCES) + cat $+ | grep -v "^#include" > $@ + +mal: mal.pike + echo "#!/usr/bin/env pike" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.pike mal diff --git a/impls/pike/Printer.pmod b/impls/pike/Printer.pmod index 74760b0f4d..edfa23bb1d 100644 --- a/impls/pike/Printer.pmod +++ b/impls/pike/Printer.pmod @@ -1,7 +1,7 @@ -import .Types; - -string pr_str(Val ast, bool print_readably) -{ - if(functionp(ast)) return "#"; - return ast->to_string(print_readably); -} +import .Types; + +string pr_str(Val ast, bool print_readably) +{ + if(functionp(ast)) return "#"; + return ast->to_string(print_readably); +} diff --git a/impls/pike/Reader.pmod b/impls/pike/Reader.pmod index 312f0bb1d0..a799a328d5 100644 --- a/impls/pike/Reader.pmod +++ b/impls/pike/Reader.pmod @@ -1,122 +1,122 @@ -import .Types; - -Regexp.PCRE tokenizer_regexp = Regexp.PCRE.Studied("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"([\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)"); -Regexp.PCRE string_regexp = Regexp.PCRE.Studied("^\"(?:[\\\\].|[^\\\\\"])*\"$"); -Regexp.PCRE number_regexp = Regexp.PCRE.Studied("^-?[0-9]+$"); - -private class Reader(private array(string) tokens, private void|int position) -{ - string next() - { - if(position >= sizeof(tokens)) return 0; - string token = tokens[position]; - position++; - return token; - } - - string peek() - { - if(position >= sizeof(tokens)) return 0; - return tokens[position]; - } -} - -private array(string) tokenize(string str) -{ - array(string) tokens = ({ }); - tokenizer_regexp.matchall(str, lambda(mixed m) { - if(sizeof(m[1]) > 0 && m[1][0] != ';') tokens += ({ m[1] }); - }); - return tokens; -} - -private string unescape_string(string token) -{ - if(!string_regexp.match(token)) throw("expected '\"', got EOF"); - string s = token[1..(sizeof(token) - 2)]; - s = replace(s, "\\\\", "\u029e"); - s = replace(s, "\\\"", "\""); - s = replace(s, "\\n", "\n"); - s = replace(s, "\u029e", "\\"); - return s; -} - -private Val read_atom(Reader reader) -{ - string token = reader->next(); - if(number_regexp.match(token)) return Number((int)token); - if(token[0] == '"') return String(unescape_string(token)); - if(token[0] == ':') return Keyword(token[1..]); - switch(token) - { - case "nil": return MAL_NIL; - case "true": return MAL_TRUE; - case "false": return MAL_FALSE; - } - return Symbol(token); -} - -private array(Val) read_seq(Reader reader, string start, string end) -{ - string token = reader->next(); - if(token != start) throw("expected '" + start + "'"); - token = reader->peek(); - array(Val) elements = ({ }); - while(token != end) - { - if(!token) throw("expected '" + end + "', got EOF"); - elements += ({ read_form(reader) }); - token = reader->peek(); - } - reader->next(); - return elements; -} - -private Val reader_macro(Reader reader, string symbol) -{ - reader->next(); - return List(({ Symbol(symbol), read_form(reader) })); -} - -private Val read_form(Reader reader) -{ - string token = reader->peek(); - switch(token) - { - case "'": - return reader_macro(reader, "quote"); - case "`": - return reader_macro(reader, "quasiquote"); - case "~": - return reader_macro(reader, "unquote"); - case "~@": - return reader_macro(reader, "splice-unquote"); - case "@": - return reader_macro(reader, "deref"); - case "^": - reader->next(); - Val meta = read_form(reader); - return List(({ Symbol("with-meta"), read_form(reader), meta })); - case "(": - return List(read_seq(reader, "(", ")")); - case ")": - throw("unexpected ')'"); - case "[": - return Vector(read_seq(reader, "[", "]")); - case "]": - throw("unexpected ']'"); - case "{": - return Map(read_seq(reader, "{", "}")); - case "}": - throw("unexpected '}'"); - default: - return read_atom(reader); - } -} - -Val read_str(string str) -{ - array(string) tokens = tokenize(str); - if(sizeof(tokens) == 0) return MAL_NIL; - return read_form(Reader(tokens)); -} +import .Types; + +Regexp.PCRE tokenizer_regexp = Regexp.PCRE.Studied("[\\s ,]*(~@|[\\[\\]{}()'`~@]|\"([\\\\].|[^\\\\\"])*\"?|;.*|[^\\s \\[\\]{}()'\"`~@,;]*)"); +Regexp.PCRE string_regexp = Regexp.PCRE.Studied("^\"(?:[\\\\].|[^\\\\\"])*\"$"); +Regexp.PCRE number_regexp = Regexp.PCRE.Studied("^-?[0-9]+$"); + +private class Reader(private array(string) tokens, private void|int position) +{ + string next() + { + if(position >= sizeof(tokens)) return 0; + string token = tokens[position]; + position++; + return token; + } + + string peek() + { + if(position >= sizeof(tokens)) return 0; + return tokens[position]; + } +} + +private array(string) tokenize(string str) +{ + array(string) tokens = ({ }); + tokenizer_regexp.matchall(str, lambda(mixed m) { + if(sizeof(m[1]) > 0 && m[1][0] != ';') tokens += ({ m[1] }); + }); + return tokens; +} + +private string unescape_string(string token) +{ + if(!string_regexp.match(token)) throw("expected '\"', got EOF"); + string s = token[1..(sizeof(token) - 2)]; + s = replace(s, "\\\\", "\u029e"); + s = replace(s, "\\\"", "\""); + s = replace(s, "\\n", "\n"); + s = replace(s, "\u029e", "\\"); + return s; +} + +private Val read_atom(Reader reader) +{ + string token = reader->next(); + if(number_regexp.match(token)) return Number((int)token); + if(token[0] == '"') return String(unescape_string(token)); + if(token[0] == ':') return Keyword(token[1..]); + switch(token) + { + case "nil": return MAL_NIL; + case "true": return MAL_TRUE; + case "false": return MAL_FALSE; + } + return Symbol(token); +} + +private array(Val) read_seq(Reader reader, string start, string end) +{ + string token = reader->next(); + if(token != start) throw("expected '" + start + "'"); + token = reader->peek(); + array(Val) elements = ({ }); + while(token != end) + { + if(!token) throw("expected '" + end + "', got EOF"); + elements += ({ read_form(reader) }); + token = reader->peek(); + } + reader->next(); + return elements; +} + +private Val reader_macro(Reader reader, string symbol) +{ + reader->next(); + return List(({ Symbol(symbol), read_form(reader) })); +} + +private Val read_form(Reader reader) +{ + string token = reader->peek(); + switch(token) + { + case "'": + return reader_macro(reader, "quote"); + case "`": + return reader_macro(reader, "quasiquote"); + case "~": + return reader_macro(reader, "unquote"); + case "~@": + return reader_macro(reader, "splice-unquote"); + case "@": + return reader_macro(reader, "deref"); + case "^": + reader->next(); + Val meta = read_form(reader); + return List(({ Symbol("with-meta"), read_form(reader), meta })); + case "(": + return List(read_seq(reader, "(", ")")); + case ")": + throw("unexpected ')'"); + case "[": + return Vector(read_seq(reader, "[", "]")); + case "]": + throw("unexpected ']'"); + case "{": + return Map(read_seq(reader, "{", "}")); + case "}": + throw("unexpected '}'"); + default: + return read_atom(reader); + } +} + +Val read_str(string str) +{ + array(string) tokens = tokenize(str); + if(sizeof(tokens) == 0) return MAL_NIL; + return read_form(Reader(tokens)); +} diff --git a/impls/pike/Readline.pmod b/impls/pike/Readline.pmod index be93884913..596c67a6ad 100644 --- a/impls/pike/Readline.pmod +++ b/impls/pike/Readline.pmod @@ -1,4 +1,4 @@ -string readline(string prompt) { - write(prompt); - return Stdio.stdin->gets(); -} +string readline(string prompt) { + write(prompt); + return Stdio.stdin->gets(); +} diff --git a/impls/pike/Types.pmod b/impls/pike/Types.pmod index b76d6a7000..dcfbe7496f 100644 --- a/impls/pike/Types.pmod +++ b/impls/pike/Types.pmod @@ -1,460 +1,460 @@ -enum MalType { - MALTYPE_UNDEFINED, - MALTYPE_NIL, - MALTYPE_TRUE, - MALTYPE_FALSE, - MALTYPE_NUMBER, - MALTYPE_SYMBOL, - MALTYPE_STRING, - MALTYPE_KEYWORD, - MALTYPE_LIST, - MALTYPE_VECTOR, - MALTYPE_MAP, - MALTYPE_FN, - MALTYPE_BUILTINFN, - MALTYPE_ATOM, -}; - -class Val -{ - constant mal_type = MALTYPE_UNDEFINED; - Val meta; - string to_string(bool print_readably); - Val clone(); - - bool `==(mixed other) - { - return objectp(other) && other.mal_type == mal_type; - } -} - -class Nil -{ - inherit Val; - constant mal_type = MALTYPE_NIL; - - string to_string(bool print_readably) - { - return "nil"; - } - - int count() - { - return 0; - } - - Val first() - { - return MAL_NIL; - } - - Val rest() - { - return List(({ })); - } - - Val clone() - { - return this_object(); - } - - Val seq() - { - return MAL_NIL; - } -} - -Nil MAL_NIL = Nil(); - -class True -{ - inherit Val; - constant mal_type = MALTYPE_TRUE; - string to_string(bool print_readably) - { - return "true"; - } - - Val clone() - { - return this_object(); - } -} - -True MAL_TRUE = True(); - -class False -{ - inherit Val; - constant mal_type = MALTYPE_FALSE; - string to_string(bool print_readably) - { - return "false"; - } - - Val clone() - { - return this_object(); - } -} - -False MAL_FALSE = False(); - -Val to_bool(bool b) -{ - if(b) return MAL_TRUE; - return MAL_FALSE; -} - -class Number(int value) -{ - constant mal_type = MALTYPE_NUMBER; - inherit Val; - - string to_string(bool print_readably) - { - return (string)value; - } - - bool `==(mixed other) - { - return ::`==(other) && other.value == value; - } - - Val clone() - { - return this_object(); - } -} - -class Symbol(string value) -{ - constant mal_type = MALTYPE_SYMBOL; - inherit Val; - - string to_string(bool print_readably) - { - return value; - } - - bool `==(mixed other) - { - return ::`==(other) && other.value == value; - } - - int __hash() - { - return hash((string)mal_type) ^ hash(value); - } - - Val clone() - { - return Symbol(value); - } -} - -class String(string value) -{ - constant mal_type = MALTYPE_STRING; - inherit Val; - - string to_string(bool print_readably) - { - if(print_readably) { - string s = replace(value, "\\", "\\\\"); - s = replace(s, "\"", "\\\""); - s = replace(s, "\n", "\\n"); - return "\"" + s + "\""; - } - return value; - } - - bool `==(mixed other) - { - return ::`==(other) && other.value == value; - } - - int __hash() - { - return hash((string)mal_type) ^ hash(value); - } - - Val clone() - { - return String(value); - } - - Val seq() - { - if(sizeof(value) == 0) return MAL_NIL; - array(Val) parts = ({ }); - for(int i = 0; i < sizeof(value); i++) - { - parts += ({ String(value[i..i]) }); - } - return List(parts); - } -} - -class Keyword(string value) -{ - constant mal_type = MALTYPE_KEYWORD; - inherit Val; - - string to_string(bool print_readably) - { - return ":" + value; - } - - bool `==(mixed other) - { - return ::`==(other) && other.value == value; - } - - int __hash() - { - return hash((string)mal_type) ^ hash(value); - } - - Val clone() - { - return Keyword(value); - } -} - -class Sequence(array(Val) data) -{ - inherit Val; - constant is_sequence = true; - - string to_string(bool print_readably) - { - return map(data, lambda(Val e) { return e.to_string(print_readably); }) * " "; - } - - bool emptyp() - { - return sizeof(data) == 0; - } - - int count() - { - return sizeof(data); - } - - Val nth(int index) - { - if(index >= count()) throw("nth: index out of range"); - return data[index]; - } - - Val first() - { - if(emptyp()) return MAL_NIL; - return data[0]; - } - - Val rest() - { - return List(data[1..]); - } - - bool `==(mixed other) - { - if(!objectp(other)) return 0; - if(!other.is_sequence) return 0; - if(other.count() != count()) return 0; - for(int i = 0; i < count(); i++) - { - if(other.data[i] != data[i]) return 0; - } - return 1; - } - - Val seq() - { - if(emptyp()) return MAL_NIL; - return List(data); - } -} - -class List -{ - inherit Sequence; - constant mal_type = MALTYPE_LIST; - - string to_string(bool print_readably) - { - return "(" + ::to_string(print_readably) + ")"; - } - - Val clone() - { - return List(data); - } - - Val conj(array(Val) other) - { - return List(reverse(other) + data); - } -} - -class Vector -{ - inherit Sequence; - constant mal_type = MALTYPE_VECTOR; - - string to_string(bool print_readably) - { - return "[" + ::to_string(print_readably) + "]"; - } - - Val clone() - { - return Vector(data); - } - - Val conj(array(Val) other) - { - return Vector(data + other); - } -} - -class Map -{ - inherit Val; - constant mal_type = MALTYPE_MAP; - mapping(Val:Val) data; - - void create(array(Val) list) - { - array(Val) keys = Array.everynth(list, 2, 0); - array(Val) vals = Array.everynth(list, 2, 1); - data = mkmapping(keys, vals); - } - - string to_string(bool print_readably) - { - array(string) strs = ({ }); - foreach(data; Val k; Val v) - { - strs += ({ k.to_string(print_readably), v.to_string(print_readably) }); - } - return "{" + (strs * " ") + "}"; - } - - int count() - { - return sizeof(data); - } - - bool `==(mixed other) - { - if(!::`==(other)) return 0; - if(other.count() != count()) return 0; - foreach(data; Val k; Val v) - { - if(other.data[k] != v) return 0; - } - return 1; - } - - Val assoc(array(Val) list) - { - array(Val) keys = Array.everynth(list, 2, 0); - array(Val) vals = Array.everynth(list, 2, 1); - Map result = Map(({ })); - result.data = copy_value(data); - for(int i = 0; i < sizeof(keys); i++) - { - result.data[keys[i]] = vals[i]; - } - return result; - } - - Val dissoc(array(Val) list) - { - Map result = Map(({ })); - result.data = copy_value(data); - foreach(list, Val key) m_delete(result.data, key); - return result; - } - - Val clone() - { - Map m = Map(({ })); - m.data = data; - return m; - } -} - -class Fn(Val ast, Val params, .Env.Env env, function func, void|bool macro) -{ - inherit Val; - constant mal_type = MALTYPE_FN; - constant is_fn = true; - - void set_macro() - { - macro = true; - } - - string to_string(bool print_readably) - { - string tag = macro ? "Macro" : "Fn"; - return "#<" + tag + " params=" + params.to_string(true) + ">"; - } - - mixed `()(mixed ... args) - { - return func(@args); - } - - Val clone() - { - return Fn(ast, params, env, func); - } - - Val clone_as_macro() - { - return Fn(ast, params, env, func, true); - } -} - -class BuiltinFn(string name, function func) -{ - inherit Val; - constant mal_type = MALTYPE_BUILTINFN; - constant is_fn = true; - - string to_string(bool print_readably) - { - return "#"; - } - - mixed `()(mixed ... args) - { - return func(@args); - } - - Val clone() - { - return BuiltinFn(name, func); - } -} - -class Atom(Val data) -{ - inherit Val; - constant mal_type = MALTYPE_ATOM; - - string to_string(bool print_readably) - { - return "(atom " + data.to_string(print_readably) + ")"; - } - - Val clone() - { - return Atom(data); - } -} +enum MalType { + MALTYPE_UNDEFINED, + MALTYPE_NIL, + MALTYPE_TRUE, + MALTYPE_FALSE, + MALTYPE_NUMBER, + MALTYPE_SYMBOL, + MALTYPE_STRING, + MALTYPE_KEYWORD, + MALTYPE_LIST, + MALTYPE_VECTOR, + MALTYPE_MAP, + MALTYPE_FN, + MALTYPE_BUILTINFN, + MALTYPE_ATOM, +}; + +class Val +{ + constant mal_type = MALTYPE_UNDEFINED; + Val meta; + string to_string(bool print_readably); + Val clone(); + + bool `==(mixed other) + { + return objectp(other) && other.mal_type == mal_type; + } +} + +class Nil +{ + inherit Val; + constant mal_type = MALTYPE_NIL; + + string to_string(bool print_readably) + { + return "nil"; + } + + int count() + { + return 0; + } + + Val first() + { + return MAL_NIL; + } + + Val rest() + { + return List(({ })); + } + + Val clone() + { + return this_object(); + } + + Val seq() + { + return MAL_NIL; + } +} + +Nil MAL_NIL = Nil(); + +class True +{ + inherit Val; + constant mal_type = MALTYPE_TRUE; + string to_string(bool print_readably) + { + return "true"; + } + + Val clone() + { + return this_object(); + } +} + +True MAL_TRUE = True(); + +class False +{ + inherit Val; + constant mal_type = MALTYPE_FALSE; + string to_string(bool print_readably) + { + return "false"; + } + + Val clone() + { + return this_object(); + } +} + +False MAL_FALSE = False(); + +Val to_bool(bool b) +{ + if(b) return MAL_TRUE; + return MAL_FALSE; +} + +class Number(int value) +{ + constant mal_type = MALTYPE_NUMBER; + inherit Val; + + string to_string(bool print_readably) + { + return (string)value; + } + + bool `==(mixed other) + { + return ::`==(other) && other.value == value; + } + + Val clone() + { + return this_object(); + } +} + +class Symbol(string value) +{ + constant mal_type = MALTYPE_SYMBOL; + inherit Val; + + string to_string(bool print_readably) + { + return value; + } + + bool `==(mixed other) + { + return ::`==(other) && other.value == value; + } + + int __hash() + { + return hash((string)mal_type) ^ hash(value); + } + + Val clone() + { + return Symbol(value); + } +} + +class String(string value) +{ + constant mal_type = MALTYPE_STRING; + inherit Val; + + string to_string(bool print_readably) + { + if(print_readably) { + string s = replace(value, "\\", "\\\\"); + s = replace(s, "\"", "\\\""); + s = replace(s, "\n", "\\n"); + return "\"" + s + "\""; + } + return value; + } + + bool `==(mixed other) + { + return ::`==(other) && other.value == value; + } + + int __hash() + { + return hash((string)mal_type) ^ hash(value); + } + + Val clone() + { + return String(value); + } + + Val seq() + { + if(sizeof(value) == 0) return MAL_NIL; + array(Val) parts = ({ }); + for(int i = 0; i < sizeof(value); i++) + { + parts += ({ String(value[i..i]) }); + } + return List(parts); + } +} + +class Keyword(string value) +{ + constant mal_type = MALTYPE_KEYWORD; + inherit Val; + + string to_string(bool print_readably) + { + return ":" + value; + } + + bool `==(mixed other) + { + return ::`==(other) && other.value == value; + } + + int __hash() + { + return hash((string)mal_type) ^ hash(value); + } + + Val clone() + { + return Keyword(value); + } +} + +class Sequence(array(Val) data) +{ + inherit Val; + constant is_sequence = true; + + string to_string(bool print_readably) + { + return map(data, lambda(Val e) { return e.to_string(print_readably); }) * " "; + } + + bool emptyp() + { + return sizeof(data) == 0; + } + + int count() + { + return sizeof(data); + } + + Val nth(int index) + { + if(index >= count()) throw("nth: index out of range"); + return data[index]; + } + + Val first() + { + if(emptyp()) return MAL_NIL; + return data[0]; + } + + Val rest() + { + return List(data[1..]); + } + + bool `==(mixed other) + { + if(!objectp(other)) return 0; + if(!other.is_sequence) return 0; + if(other.count() != count()) return 0; + for(int i = 0; i < count(); i++) + { + if(other.data[i] != data[i]) return 0; + } + return 1; + } + + Val seq() + { + if(emptyp()) return MAL_NIL; + return List(data); + } +} + +class List +{ + inherit Sequence; + constant mal_type = MALTYPE_LIST; + + string to_string(bool print_readably) + { + return "(" + ::to_string(print_readably) + ")"; + } + + Val clone() + { + return List(data); + } + + Val conj(array(Val) other) + { + return List(reverse(other) + data); + } +} + +class Vector +{ + inherit Sequence; + constant mal_type = MALTYPE_VECTOR; + + string to_string(bool print_readably) + { + return "[" + ::to_string(print_readably) + "]"; + } + + Val clone() + { + return Vector(data); + } + + Val conj(array(Val) other) + { + return Vector(data + other); + } +} + +class Map +{ + inherit Val; + constant mal_type = MALTYPE_MAP; + mapping(Val:Val) data; + + void create(array(Val) list) + { + array(Val) keys = Array.everynth(list, 2, 0); + array(Val) vals = Array.everynth(list, 2, 1); + data = mkmapping(keys, vals); + } + + string to_string(bool print_readably) + { + array(string) strs = ({ }); + foreach(data; Val k; Val v) + { + strs += ({ k.to_string(print_readably), v.to_string(print_readably) }); + } + return "{" + (strs * " ") + "}"; + } + + int count() + { + return sizeof(data); + } + + bool `==(mixed other) + { + if(!::`==(other)) return 0; + if(other.count() != count()) return 0; + foreach(data; Val k; Val v) + { + if(other.data[k] != v) return 0; + } + return 1; + } + + Val assoc(array(Val) list) + { + array(Val) keys = Array.everynth(list, 2, 0); + array(Val) vals = Array.everynth(list, 2, 1); + Map result = Map(({ })); + result.data = copy_value(data); + for(int i = 0; i < sizeof(keys); i++) + { + result.data[keys[i]] = vals[i]; + } + return result; + } + + Val dissoc(array(Val) list) + { + Map result = Map(({ })); + result.data = copy_value(data); + foreach(list, Val key) m_delete(result.data, key); + return result; + } + + Val clone() + { + Map m = Map(({ })); + m.data = data; + return m; + } +} + +class Fn(Val ast, Val params, .Env.Env env, function func, void|bool macro) +{ + inherit Val; + constant mal_type = MALTYPE_FN; + constant is_fn = true; + + void set_macro() + { + macro = true; + } + + string to_string(bool print_readably) + { + string tag = macro ? "Macro" : "Fn"; + return "#<" + tag + " params=" + params.to_string(true) + ">"; + } + + mixed `()(mixed ... args) + { + return func(@args); + } + + Val clone() + { + return Fn(ast, params, env, func); + } + + Val clone_as_macro() + { + return Fn(ast, params, env, func, true); + } +} + +class BuiltinFn(string name, function func) +{ + inherit Val; + constant mal_type = MALTYPE_BUILTINFN; + constant is_fn = true; + + string to_string(bool print_readably) + { + return "#"; + } + + mixed `()(mixed ... args) + { + return func(@args); + } + + Val clone() + { + return BuiltinFn(name, func); + } +} + +class Atom(Val data) +{ + inherit Val; + constant mal_type = MALTYPE_ATOM; + + string to_string(bool print_readably) + { + return "(atom " + data.to_string(print_readably) + ")"; + } + + Val clone() + { + return Atom(data); + } +} diff --git a/impls/pike/run b/impls/pike/run index ede1d3a234..7107418adc 100755 --- a/impls/pike/run +++ b/impls/pike/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec pike $(dirname $0)/${STEP:-stepA_mal}.pike "${@}" +#!/bin/bash +exec pike $(dirname $0)/${STEP:-stepA_mal}.pike "${@}" diff --git a/impls/pike/step0_repl.pike b/impls/pike/step0_repl.pike index 65150a31e1..ad4709f06d 100644 --- a/impls/pike/step0_repl.pike +++ b/impls/pike/step0_repl.pike @@ -1,34 +1,34 @@ -import .Readline; - -string READ(string str) -{ - return str; -} - -string EVAL(string ast, string env) -{ - return ast; -} - -string PRINT(string exp) -{ - return exp; -} - -string rep(string str) -{ - return PRINT(EVAL(READ(str), "")); -} - -int main() -{ - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - write(({ rep(line), "\n" })); - } - write("\n"); - return 0; -} +import .Readline; + +string READ(string str) +{ + return str; +} + +string EVAL(string ast, string env) +{ + return ast; +} + +string PRINT(string exp) +{ + return exp; +} + +string rep(string str) +{ + return PRINT(EVAL(READ(str), "")); +} + +int main() +{ + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + write(({ rep(line), "\n" })); + } + write("\n"); + return 0; +} diff --git a/impls/pike/step1_read_print.pike b/impls/pike/step1_read_print.pike index 15cdfc8de2..90002c8743 100644 --- a/impls/pike/step1_read_print.pike +++ b/impls/pike/step1_read_print.pike @@ -1,41 +1,41 @@ -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -Val EVAL(Val ast, string env) -{ - return ast; -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str) -{ - return PRINT(EVAL(READ(str), "")); -} - -int main() -{ - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line), "\n" })); } ) - { - if(arrayp(err)) err = err[0]; - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +Val EVAL(Val ast, string env) +{ + return ast; +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str) +{ + return PRINT(EVAL(READ(str), "")); +} + +int main() +{ + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line), "\n" })); } ) + { + if(arrayp(err)) err = err[0]; + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/step2_eval.pike b/impls/pike/step2_eval.pike index 822b224d35..4e025bd964 100644 --- a/impls/pike/step2_eval.pike +++ b/impls/pike/step2_eval.pike @@ -1,75 +1,75 @@ -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -Val eval_ast(Val ast, mapping(string:function) env) -{ - switch(ast.mal_type) - { - case MALTYPE_SYMBOL: - function f = env[ast.value]; - if(!f) throw("'" + ast.value + "' not found"); - return f; - case MALTYPE_LIST: - return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_VECTOR: - return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_MAP: - array(Val) elements = ({ }); - foreach(ast.data; Val k; Val v) - { - elements += ({ k, EVAL(v, env) }); - } - return Map(elements); - default: - return ast; - } -} - -Val EVAL(Val ast, mapping(string:function) env) -{ - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - if(ast.emptyp()) return ast; - Val evaled_ast = eval_ast(ast, env); - function f = evaled_ast.data[0]; - return f(@evaled_ast.data[1..]); -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str, mapping(string:function) env) -{ - return PRINT(EVAL(READ(str), env)); -} - -int main() -{ - mapping(string:function) repl_env = ([ - "+": lambda(Val a, Val b) { return Number(a.value + b.value); }, - "-": lambda(Val a, Val b) { return Number(a.value - b.value); }, - "*": lambda(Val a, Val b) { return Number(a.value * b.value); }, - "/": lambda(Val a, Val b) { return Number(a.value / b.value); } - ]); - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) - { - if(arrayp(err)) err = err[0]; - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +Val eval_ast(Val ast, mapping(string:function) env) +{ + switch(ast.mal_type) + { + case MALTYPE_SYMBOL: + function f = env[ast.value]; + if(!f) throw("'" + ast.value + "' not found"); + return f; + case MALTYPE_LIST: + return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_VECTOR: + return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_MAP: + array(Val) elements = ({ }); + foreach(ast.data; Val k; Val v) + { + elements += ({ k, EVAL(v, env) }); + } + return Map(elements); + default: + return ast; + } +} + +Val EVAL(Val ast, mapping(string:function) env) +{ + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + if(ast.emptyp()) return ast; + Val evaled_ast = eval_ast(ast, env); + function f = evaled_ast.data[0]; + return f(@evaled_ast.data[1..]); +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str, mapping(string:function) env) +{ + return PRINT(EVAL(READ(str), env)); +} + +int main() +{ + mapping(string:function) repl_env = ([ + "+": lambda(Val a, Val b) { return Number(a.value + b.value); }, + "-": lambda(Val a, Val b) { return Number(a.value - b.value); }, + "*": lambda(Val a, Val b) { return Number(a.value * b.value); }, + "/": lambda(Val a, Val b) { return Number(a.value / b.value); } + ]); + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) + { + if(arrayp(err)) err = err[0]; + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/step3_env.pike b/impls/pike/step3_env.pike index 29488866b9..917f32c06b 100644 --- a/impls/pike/step3_env.pike +++ b/impls/pike/step3_env.pike @@ -1,88 +1,88 @@ -import .Env; -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -Val eval_ast(Val ast, Env env) -{ - switch(ast.mal_type) - { - case MALTYPE_SYMBOL: - return env.get(ast); - case MALTYPE_LIST: - return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_VECTOR: - return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_MAP: - array(Val) elements = ({ }); - foreach(ast.data; Val k; Val v) - { - elements += ({ k, EVAL(v, env) }); - } - return Map(elements); - default: - return ast; - } -} - -Val EVAL(Val ast, Env env) -{ - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - if(ast.emptyp()) return ast; - if(ast.data[0].mal_type == MALTYPE_SYMBOL) { - switch(ast.data[0].value) - { - case "def!": - return env.set(ast.data[1], EVAL(ast.data[2], env)); - case "let*": - Env let_env = Env(env); - Val ast1 = ast.data[1]; - for(int i = 0; i < sizeof(ast1.data); i += 2) - { - let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); - } - return EVAL(ast.data[2], let_env); - } - } - Val evaled_ast = eval_ast(ast, env); - function f = evaled_ast.data[0]; - return f(@evaled_ast.data[1..]); -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -int main() -{ - Env repl_env = Env(0); - repl_env.set(Symbol("+"), lambda(Val a, Val b) { return Number(a.value + b.value); }); - repl_env.set(Symbol("-"), lambda(Val a, Val b) { return Number(a.value - b.value); }); - repl_env.set(Symbol("*"), lambda(Val a, Val b) { return Number(a.value * b.value); }); - repl_env.set(Symbol("/"), lambda(Val a, Val b) { return Number(a.value / b.value); }); - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) - { - if(arrayp(err)) err = err[0]; - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Env; +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +Val eval_ast(Val ast, Env env) +{ + switch(ast.mal_type) + { + case MALTYPE_SYMBOL: + return env.get(ast); + case MALTYPE_LIST: + return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_VECTOR: + return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_MAP: + array(Val) elements = ({ }); + foreach(ast.data; Val k; Val v) + { + elements += ({ k, EVAL(v, env) }); + } + return Map(elements); + default: + return ast; + } +} + +Val EVAL(Val ast, Env env) +{ + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + if(ast.emptyp()) return ast; + if(ast.data[0].mal_type == MALTYPE_SYMBOL) { + switch(ast.data[0].value) + { + case "def!": + return env.set(ast.data[1], EVAL(ast.data[2], env)); + case "let*": + Env let_env = Env(env); + Val ast1 = ast.data[1]; + for(int i = 0; i < sizeof(ast1.data); i += 2) + { + let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); + } + return EVAL(ast.data[2], let_env); + } + } + Val evaled_ast = eval_ast(ast, env); + function f = evaled_ast.data[0]; + return f(@evaled_ast.data[1..]); +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +int main() +{ + Env repl_env = Env(0); + repl_env.set(Symbol("+"), lambda(Val a, Val b) { return Number(a.value + b.value); }); + repl_env.set(Symbol("-"), lambda(Val a, Val b) { return Number(a.value - b.value); }); + repl_env.set(Symbol("*"), lambda(Val a, Val b) { return Number(a.value * b.value); }); + repl_env.set(Symbol("/"), lambda(Val a, Val b) { return Number(a.value / b.value); }); + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) + { + if(arrayp(err)) err = err[0]; + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/step4_if_fn_do.pike b/impls/pike/step4_if_fn_do.pike index 18144d7de1..2c9f18e991 100644 --- a/impls/pike/step4_if_fn_do.pike +++ b/impls/pike/step4_if_fn_do.pike @@ -1,106 +1,106 @@ -import .Env; -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -Val eval_ast(Val ast, Env env) -{ - switch(ast.mal_type) - { - case MALTYPE_SYMBOL: - return env.get(ast); - case MALTYPE_LIST: - return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_VECTOR: - return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_MAP: - array(Val) elements = ({ }); - foreach(ast.data; Val k; Val v) - { - elements += ({ k, EVAL(v, env) }); - } - return Map(elements); - default: - return ast; - } -} - -Val EVAL(Val ast, Env env) -{ - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - if(ast.emptyp()) return ast; - if(ast.data[0].mal_type == MALTYPE_SYMBOL) { - switch(ast.data[0].value) - { - case "def!": - return env.set(ast.data[1], EVAL(ast.data[2], env)); - case "let*": - Env let_env = Env(env); - Val ast1 = ast.data[1]; - for(int i = 0; i < sizeof(ast1.data); i += 2) - { - let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); - } - return EVAL(ast.data[2], let_env); - case "do": - Val result; - foreach(ast.data[1..], Val element) - { - result = EVAL(element, env); - } - return result; - case "if": - Val cond = EVAL(ast.data[1], env); - if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) - { - if(sizeof(ast.data) > 3) - return EVAL(ast.data[3], env); - else - return MAL_NIL; - } - else - return EVAL(ast.data[2], env); - case "fn*": - return lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }; - } - } - Val evaled_ast = eval_ast(ast, env); - Val f = evaled_ast.data[0]; - return f(@evaled_ast.data[1..]); -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -int main() -{ - Env repl_env = Env(0); - foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); - rep("(def! not (fn* (a) (if a false true)))", repl_env); - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) - { - if(arrayp(err)) err = err[0]; - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Env; +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +Val eval_ast(Val ast, Env env) +{ + switch(ast.mal_type) + { + case MALTYPE_SYMBOL: + return env.get(ast); + case MALTYPE_LIST: + return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_VECTOR: + return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_MAP: + array(Val) elements = ({ }); + foreach(ast.data; Val k; Val v) + { + elements += ({ k, EVAL(v, env) }); + } + return Map(elements); + default: + return ast; + } +} + +Val EVAL(Val ast, Env env) +{ + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + if(ast.emptyp()) return ast; + if(ast.data[0].mal_type == MALTYPE_SYMBOL) { + switch(ast.data[0].value) + { + case "def!": + return env.set(ast.data[1], EVAL(ast.data[2], env)); + case "let*": + Env let_env = Env(env); + Val ast1 = ast.data[1]; + for(int i = 0; i < sizeof(ast1.data); i += 2) + { + let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); + } + return EVAL(ast.data[2], let_env); + case "do": + Val result; + foreach(ast.data[1..], Val element) + { + result = EVAL(element, env); + } + return result; + case "if": + Val cond = EVAL(ast.data[1], env); + if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) + { + if(sizeof(ast.data) > 3) + return EVAL(ast.data[3], env); + else + return MAL_NIL; + } + else + return EVAL(ast.data[2], env); + case "fn*": + return lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }; + } + } + Val evaled_ast = eval_ast(ast, env); + Val f = evaled_ast.data[0]; + return f(@evaled_ast.data[1..]); +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +int main() +{ + Env repl_env = Env(0); + foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); + rep("(def! not (fn* (a) (if a false true)))", repl_env); + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) + { + if(arrayp(err)) err = err[0]; + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/step5_tco.pike b/impls/pike/step5_tco.pike index e155262de1..74e224f689 100644 --- a/impls/pike/step5_tco.pike +++ b/impls/pike/step5_tco.pike @@ -1,124 +1,124 @@ -import .Env; -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -Val eval_ast(Val ast, Env env) -{ - switch(ast.mal_type) - { - case MALTYPE_SYMBOL: - return env.get(ast); - case MALTYPE_LIST: - return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_VECTOR: - return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_MAP: - array(Val) elements = ({ }); - foreach(ast.data; Val k; Val v) - { - elements += ({ k, EVAL(v, env) }); - } - return Map(elements); - default: - return ast; - } -} - -Val EVAL(Val ast, Env env) -{ - while(true) - { - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - if(ast.emptyp()) return ast; - if(ast.data[0].mal_type == MALTYPE_SYMBOL) { - switch(ast.data[0].value) - { - case "def!": - return env.set(ast.data[1], EVAL(ast.data[2], env)); - case "let*": - Env let_env = Env(env); - Val ast1 = ast.data[1]; - for(int i = 0; i < sizeof(ast1.data); i += 2) - { - let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); - } - env = let_env; - ast = ast.data[2]; - continue; // TCO - case "do": - Val result; - foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) - { - result = EVAL(element, env); - } - ast = ast.data[-1]; - continue; // TCO - case "if": - Val cond = EVAL(ast.data[1], env); - if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) - { - if(sizeof(ast.data) > 3) - ast = ast.data[3]; - else - return MAL_NIL; - } - else - ast = ast.data[2]; - continue; // TCO - case "fn*": - return Fn(ast.data[2], ast.data[1], env, - lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); - } - } - Val evaled_ast = eval_ast(ast, env); - Val f = evaled_ast.data[0]; - switch(f.mal_type) - { - case MALTYPE_BUILTINFN: - return f(@evaled_ast.data[1..]); - case MALTYPE_FN: - ast = f.ast; - env = Env(f.env, f.params, List(evaled_ast.data[1..])); - continue; // TCO - default: - throw("Unknown function type"); - } - } -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -int main() -{ - Env repl_env = Env(0); - foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); - rep("(def! not (fn* (a) (if a false true)))", repl_env); - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) - { - if(arrayp(err)) err = err[0]; - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Env; +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +Val eval_ast(Val ast, Env env) +{ + switch(ast.mal_type) + { + case MALTYPE_SYMBOL: + return env.get(ast); + case MALTYPE_LIST: + return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_VECTOR: + return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_MAP: + array(Val) elements = ({ }); + foreach(ast.data; Val k; Val v) + { + elements += ({ k, EVAL(v, env) }); + } + return Map(elements); + default: + return ast; + } +} + +Val EVAL(Val ast, Env env) +{ + while(true) + { + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + if(ast.emptyp()) return ast; + if(ast.data[0].mal_type == MALTYPE_SYMBOL) { + switch(ast.data[0].value) + { + case "def!": + return env.set(ast.data[1], EVAL(ast.data[2], env)); + case "let*": + Env let_env = Env(env); + Val ast1 = ast.data[1]; + for(int i = 0; i < sizeof(ast1.data); i += 2) + { + let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); + } + env = let_env; + ast = ast.data[2]; + continue; // TCO + case "do": + Val result; + foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) + { + result = EVAL(element, env); + } + ast = ast.data[-1]; + continue; // TCO + case "if": + Val cond = EVAL(ast.data[1], env); + if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) + { + if(sizeof(ast.data) > 3) + ast = ast.data[3]; + else + return MAL_NIL; + } + else + ast = ast.data[2]; + continue; // TCO + case "fn*": + return Fn(ast.data[2], ast.data[1], env, + lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); + } + } + Val evaled_ast = eval_ast(ast, env); + Val f = evaled_ast.data[0]; + switch(f.mal_type) + { + case MALTYPE_BUILTINFN: + return f(@evaled_ast.data[1..]); + case MALTYPE_FN: + ast = f.ast; + env = Env(f.env, f.params, List(evaled_ast.data[1..])); + continue; // TCO + default: + throw("Unknown function type"); + } + } +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +int main() +{ + Env repl_env = Env(0); + foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); + rep("(def! not (fn* (a) (if a false true)))", repl_env); + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) + { + if(arrayp(err)) err = err[0]; + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/step6_file.pike b/impls/pike/step6_file.pike index dcec472e1e..06977889b9 100644 --- a/impls/pike/step6_file.pike +++ b/impls/pike/step6_file.pike @@ -1,132 +1,132 @@ -import .Env; -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -Val eval_ast(Val ast, Env env) -{ - switch(ast.mal_type) - { - case MALTYPE_SYMBOL: - return env.get(ast); - case MALTYPE_LIST: - return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_VECTOR: - return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_MAP: - array(Val) elements = ({ }); - foreach(ast.data; Val k; Val v) - { - elements += ({ k, EVAL(v, env) }); - } - return Map(elements); - default: - return ast; - } -} - -Val EVAL(Val ast, Env env) -{ - while(true) - { - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - if(ast.emptyp()) return ast; - if(ast.data[0].mal_type == MALTYPE_SYMBOL) { - switch(ast.data[0].value) - { - case "def!": - return env.set(ast.data[1], EVAL(ast.data[2], env)); - case "let*": - Env let_env = Env(env); - Val ast1 = ast.data[1]; - for(int i = 0; i < sizeof(ast1.data); i += 2) - { - let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); - } - env = let_env; - ast = ast.data[2]; - continue; // TCO - case "do": - Val result; - foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) - { - result = EVAL(element, env); - } - ast = ast.data[-1]; - continue; // TCO - case "if": - Val cond = EVAL(ast.data[1], env); - if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) - { - if(sizeof(ast.data) > 3) - ast = ast.data[3]; - else - return MAL_NIL; - } - else - ast = ast.data[2]; - continue; // TCO - case "fn*": - return Fn(ast.data[2], ast.data[1], env, - lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); - } - } - Val evaled_ast = eval_ast(ast, env); - Val f = evaled_ast.data[0]; - switch(f.mal_type) - { - case MALTYPE_BUILTINFN: - return f(@evaled_ast.data[1..]); - case MALTYPE_FN: - ast = f.ast; - env = Env(f.env, f.params, List(evaled_ast.data[1..])); - continue; // TCO - default: - throw("Unknown function type"); - } - } -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -int main(int argc, array argv) -{ - Env repl_env = Env(0); - foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); - repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); - repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); - rep("(def! not (fn* (a) (if a false true)))", repl_env); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - if(argc >= 2) - { - rep("(load-file \"" + argv[1] + "\")", repl_env); - return 0; - } - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) - { - if(arrayp(err)) err = err[0]; - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Env; +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +Val eval_ast(Val ast, Env env) +{ + switch(ast.mal_type) + { + case MALTYPE_SYMBOL: + return env.get(ast); + case MALTYPE_LIST: + return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_VECTOR: + return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_MAP: + array(Val) elements = ({ }); + foreach(ast.data; Val k; Val v) + { + elements += ({ k, EVAL(v, env) }); + } + return Map(elements); + default: + return ast; + } +} + +Val EVAL(Val ast, Env env) +{ + while(true) + { + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + if(ast.emptyp()) return ast; + if(ast.data[0].mal_type == MALTYPE_SYMBOL) { + switch(ast.data[0].value) + { + case "def!": + return env.set(ast.data[1], EVAL(ast.data[2], env)); + case "let*": + Env let_env = Env(env); + Val ast1 = ast.data[1]; + for(int i = 0; i < sizeof(ast1.data); i += 2) + { + let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); + } + env = let_env; + ast = ast.data[2]; + continue; // TCO + case "do": + Val result; + foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) + { + result = EVAL(element, env); + } + ast = ast.data[-1]; + continue; // TCO + case "if": + Val cond = EVAL(ast.data[1], env); + if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) + { + if(sizeof(ast.data) > 3) + ast = ast.data[3]; + else + return MAL_NIL; + } + else + ast = ast.data[2]; + continue; // TCO + case "fn*": + return Fn(ast.data[2], ast.data[1], env, + lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); + } + } + Val evaled_ast = eval_ast(ast, env); + Val f = evaled_ast.data[0]; + switch(f.mal_type) + { + case MALTYPE_BUILTINFN: + return f(@evaled_ast.data[1..]); + case MALTYPE_FN: + ast = f.ast; + env = Env(f.env, f.params, List(evaled_ast.data[1..])); + continue; // TCO + default: + throw("Unknown function type"); + } + } +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +int main(int argc, array argv) +{ + Env repl_env = Env(0); + foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); + repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); + repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); + rep("(def! not (fn* (a) (if a false true)))", repl_env); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + if(argc >= 2) + { + rep("(load-file \"" + argv[1] + "\")", repl_env); + return 0; + } + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) + { + if(arrayp(err)) err = err[0]; + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/step7_quote.pike b/impls/pike/step7_quote.pike index 55cba4f6bd..0bd68d4a62 100644 --- a/impls/pike/step7_quote.pike +++ b/impls/pike/step7_quote.pike @@ -1,180 +1,180 @@ -import .Env; -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -bool starts_with(Val ast, string sym) -{ - return ast.mal_type == MALTYPE_LIST && - !ast.emptyp() && - ast.data[0].mal_type == MALTYPE_SYMBOL && - ast.data[0].value == sym; -} - -Val quasiquote_list(array(Val) elts) -{ - Val acc = List(({ })); - for(int i=sizeof(elts)-1; 0<=i; i-=1) - { - Val elt = elts[i]; - if(starts_with(elt, "splice-unquote")) - acc = List(({ Symbol("concat"), elt.data[1], acc })); - else - acc = List(({ Symbol("cons"), quasiquote(elt), acc })); - } - return acc; -} - -Val quasiquote(Val ast) -{ - switch(ast.mal_type) - { - case MALTYPE_LIST: - if(starts_with(ast, "unquote")) - return ast.data[1]; - else - return quasiquote_list(ast.data); - case MALTYPE_VECTOR: - return List(({ Symbol("vec"), quasiquote_list(ast.data) })); - case MALTYPE_SYMBOL: - case MALTYPE_MAP: - return List(({ Symbol("quote"), ast })); - default: - return ast; - } -} - -Val eval_ast(Val ast, Env env) -{ - switch(ast.mal_type) - { - case MALTYPE_SYMBOL: - return env.get(ast); - case MALTYPE_LIST: - return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_VECTOR: - return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_MAP: - array(Val) elements = ({ }); - foreach(ast.data; Val k; Val v) - { - elements += ({ k, EVAL(v, env) }); - } - return Map(elements); - default: - return ast; - } -} - -Val EVAL(Val ast, Env env) -{ - while(true) - { - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - if(ast.emptyp()) return ast; - if(ast.data[0].mal_type == MALTYPE_SYMBOL) { - switch(ast.data[0].value) - { - case "def!": - return env.set(ast.data[1], EVAL(ast.data[2], env)); - case "let*": - Env let_env = Env(env); - Val ast1 = ast.data[1]; - for(int i = 0; i < sizeof(ast1.data); i += 2) - { - let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); - } - env = let_env; - ast = ast.data[2]; - continue; // TCO - case "quote": - return ast.data[1]; - case "quasiquoteexpand": - return quasiquote(ast.data[1]); - case "quasiquote": - ast = quasiquote(ast.data[1]); - continue; // TCO - case "do": - Val result; - foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) - { - result = EVAL(element, env); - } - ast = ast.data[-1]; - continue; // TCO - case "if": - Val cond = EVAL(ast.data[1], env); - if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) - { - if(sizeof(ast.data) > 3) - ast = ast.data[3]; - else - return MAL_NIL; - } - else - ast = ast.data[2]; - continue; // TCO - case "fn*": - return Fn(ast.data[2], ast.data[1], env, - lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); - } - } - Val evaled_ast = eval_ast(ast, env); - Val f = evaled_ast.data[0]; - switch(f.mal_type) - { - case MALTYPE_BUILTINFN: - return f(@evaled_ast.data[1..]); - case MALTYPE_FN: - ast = f.ast; - env = Env(f.env, f.params, List(evaled_ast.data[1..])); - continue; // TCO - default: - throw("Unknown function type"); - } - } -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -int main(int argc, array argv) -{ - Env repl_env = Env(0); - foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); - repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); - repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); - rep("(def! not (fn* (a) (if a false true)))", repl_env); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - if(argc >= 2) - { - rep("(load-file \"" + argv[1] + "\")", repl_env); - return 0; - } - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) - { - if(arrayp(err)) err = err[0]; - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Env; +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +bool starts_with(Val ast, string sym) +{ + return ast.mal_type == MALTYPE_LIST && + !ast.emptyp() && + ast.data[0].mal_type == MALTYPE_SYMBOL && + ast.data[0].value == sym; +} + +Val quasiquote_list(array(Val) elts) +{ + Val acc = List(({ })); + for(int i=sizeof(elts)-1; 0<=i; i-=1) + { + Val elt = elts[i]; + if(starts_with(elt, "splice-unquote")) + acc = List(({ Symbol("concat"), elt.data[1], acc })); + else + acc = List(({ Symbol("cons"), quasiquote(elt), acc })); + } + return acc; +} + +Val quasiquote(Val ast) +{ + switch(ast.mal_type) + { + case MALTYPE_LIST: + if(starts_with(ast, "unquote")) + return ast.data[1]; + else + return quasiquote_list(ast.data); + case MALTYPE_VECTOR: + return List(({ Symbol("vec"), quasiquote_list(ast.data) })); + case MALTYPE_SYMBOL: + case MALTYPE_MAP: + return List(({ Symbol("quote"), ast })); + default: + return ast; + } +} + +Val eval_ast(Val ast, Env env) +{ + switch(ast.mal_type) + { + case MALTYPE_SYMBOL: + return env.get(ast); + case MALTYPE_LIST: + return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_VECTOR: + return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_MAP: + array(Val) elements = ({ }); + foreach(ast.data; Val k; Val v) + { + elements += ({ k, EVAL(v, env) }); + } + return Map(elements); + default: + return ast; + } +} + +Val EVAL(Val ast, Env env) +{ + while(true) + { + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + if(ast.emptyp()) return ast; + if(ast.data[0].mal_type == MALTYPE_SYMBOL) { + switch(ast.data[0].value) + { + case "def!": + return env.set(ast.data[1], EVAL(ast.data[2], env)); + case "let*": + Env let_env = Env(env); + Val ast1 = ast.data[1]; + for(int i = 0; i < sizeof(ast1.data); i += 2) + { + let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); + } + env = let_env; + ast = ast.data[2]; + continue; // TCO + case "quote": + return ast.data[1]; + case "quasiquoteexpand": + return quasiquote(ast.data[1]); + case "quasiquote": + ast = quasiquote(ast.data[1]); + continue; // TCO + case "do": + Val result; + foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) + { + result = EVAL(element, env); + } + ast = ast.data[-1]; + continue; // TCO + case "if": + Val cond = EVAL(ast.data[1], env); + if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) + { + if(sizeof(ast.data) > 3) + ast = ast.data[3]; + else + return MAL_NIL; + } + else + ast = ast.data[2]; + continue; // TCO + case "fn*": + return Fn(ast.data[2], ast.data[1], env, + lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); + } + } + Val evaled_ast = eval_ast(ast, env); + Val f = evaled_ast.data[0]; + switch(f.mal_type) + { + case MALTYPE_BUILTINFN: + return f(@evaled_ast.data[1..]); + case MALTYPE_FN: + ast = f.ast; + env = Env(f.env, f.params, List(evaled_ast.data[1..])); + continue; // TCO + default: + throw("Unknown function type"); + } + } +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +int main(int argc, array argv) +{ + Env repl_env = Env(0); + foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); + repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); + repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); + rep("(def! not (fn* (a) (if a false true)))", repl_env); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + if(argc >= 2) + { + rep("(load-file \"" + argv[1] + "\")", repl_env); + return 0; + } + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) + { + if(arrayp(err)) err = err[0]; + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/step8_macros.pike b/impls/pike/step8_macros.pike index 4e051d455c..897661fadc 100644 --- a/impls/pike/step8_macros.pike +++ b/impls/pike/step8_macros.pike @@ -1,211 +1,211 @@ -import .Env; -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -bool starts_with(Val ast, string sym) -{ - return ast.mal_type == MALTYPE_LIST && - !ast.emptyp() && - ast.data[0].mal_type == MALTYPE_SYMBOL && - ast.data[0].value == sym; -} - -Val quasiquote_list(array(Val) elts) -{ - Val acc = List(({ })); - for(int i=sizeof(elts)-1; 0<=i; i-=1) - { - Val elt = elts[i]; - if(starts_with(elt, "splice-unquote")) - acc = List(({ Symbol("concat"), elt.data[1], acc })); - else - acc = List(({ Symbol("cons"), quasiquote(elt), acc })); - } - return acc; -} - -Val quasiquote(Val ast) -{ - switch(ast.mal_type) - { - case MALTYPE_LIST: - if(starts_with(ast, "unquote")) - return ast.data[1]; - else - return quasiquote_list(ast.data); - case MALTYPE_VECTOR: - return List(({ Symbol("vec"), quasiquote_list(ast.data) })); - case MALTYPE_SYMBOL: - case MALTYPE_MAP: - return List(({ Symbol("quote"), ast })); - default: - return ast; - } -} - -bool is_macro_call(Val ast, Env env) -{ - if(ast.mal_type == MALTYPE_LIST && - !ast.emptyp() && - ast.data[0].mal_type == MALTYPE_SYMBOL && - env.find(ast.data[0])) - { - Val v = env.get(ast.data[0]); - if(objectp(v) && v.macro) return true; - } - return false; -} - -Val macroexpand(Val ast, Env env) -{ - while(is_macro_call(ast, env)) - { - Val macro = env.get(ast.data[0]); - ast = macro(@ast.data[1..]); - } - return ast; -} - -Val eval_ast(Val ast, Env env) -{ - switch(ast.mal_type) - { - case MALTYPE_SYMBOL: - return env.get(ast); - case MALTYPE_LIST: - return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_VECTOR: - return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_MAP: - array(Val) elements = ({ }); - foreach(ast.data; Val k; Val v) - { - elements += ({ k, EVAL(v, env) }); - } - return Map(elements); - default: - return ast; - } -} - -Val EVAL(Val ast, Env env) -{ - while(true) - { - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - ast = macroexpand(ast, env); - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - if(ast.emptyp()) return ast; - if(ast.data[0].mal_type == MALTYPE_SYMBOL) { - switch(ast.data[0].value) - { - case "def!": - return env.set(ast.data[1], EVAL(ast.data[2], env)); - case "let*": - Env let_env = Env(env); - Val ast1 = ast.data[1]; - for(int i = 0; i < sizeof(ast1.data); i += 2) - { - let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); - } - env = let_env; - ast = ast.data[2]; - continue; // TCO - case "quote": - return ast.data[1]; - case "quasiquoteexpand": - return quasiquote(ast.data[1]); - case "quasiquote": - ast = quasiquote(ast.data[1]); - continue; // TCO - case "defmacro!": - Val macro = EVAL(ast.data[2], env).clone_as_macro(); - return env.set(ast.data[1], macro); - case "macroexpand": - return macroexpand(ast.data[1], env); - case "do": - Val result; - foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) - { - result = EVAL(element, env); - } - ast = ast.data[-1]; - continue; // TCO - case "if": - Val cond = EVAL(ast.data[1], env); - if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) - { - if(sizeof(ast.data) > 3) - ast = ast.data[3]; - else - return MAL_NIL; - } - else - ast = ast.data[2]; - continue; // TCO - case "fn*": - return Fn(ast.data[2], ast.data[1], env, - lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); - } - } - Val evaled_ast = eval_ast(ast, env); - Val f = evaled_ast.data[0]; - switch(f.mal_type) - { - case MALTYPE_BUILTINFN: - return f(@evaled_ast.data[1..]); - case MALTYPE_FN: - ast = f.ast; - env = Env(f.env, f.params, List(evaled_ast.data[1..])); - continue; // TCO - default: - throw("Unknown function type"); - } - } -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -int main(int argc, array argv) -{ - Env repl_env = Env(0); - foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); - repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); - repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); - rep("(def! not (fn* (a) (if a false true)))", repl_env); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - 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)))))))", repl_env); - if(argc >= 2) - { - rep("(load-file \"" + argv[1] + "\")", repl_env); - return 0; - } - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) - { - if(arrayp(err)) err = err[0]; - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Env; +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +bool starts_with(Val ast, string sym) +{ + return ast.mal_type == MALTYPE_LIST && + !ast.emptyp() && + ast.data[0].mal_type == MALTYPE_SYMBOL && + ast.data[0].value == sym; +} + +Val quasiquote_list(array(Val) elts) +{ + Val acc = List(({ })); + for(int i=sizeof(elts)-1; 0<=i; i-=1) + { + Val elt = elts[i]; + if(starts_with(elt, "splice-unquote")) + acc = List(({ Symbol("concat"), elt.data[1], acc })); + else + acc = List(({ Symbol("cons"), quasiquote(elt), acc })); + } + return acc; +} + +Val quasiquote(Val ast) +{ + switch(ast.mal_type) + { + case MALTYPE_LIST: + if(starts_with(ast, "unquote")) + return ast.data[1]; + else + return quasiquote_list(ast.data); + case MALTYPE_VECTOR: + return List(({ Symbol("vec"), quasiquote_list(ast.data) })); + case MALTYPE_SYMBOL: + case MALTYPE_MAP: + return List(({ Symbol("quote"), ast })); + default: + return ast; + } +} + +bool is_macro_call(Val ast, Env env) +{ + if(ast.mal_type == MALTYPE_LIST && + !ast.emptyp() && + ast.data[0].mal_type == MALTYPE_SYMBOL && + env.find(ast.data[0])) + { + Val v = env.get(ast.data[0]); + if(objectp(v) && v.macro) return true; + } + return false; +} + +Val macroexpand(Val ast, Env env) +{ + while(is_macro_call(ast, env)) + { + Val macro = env.get(ast.data[0]); + ast = macro(@ast.data[1..]); + } + return ast; +} + +Val eval_ast(Val ast, Env env) +{ + switch(ast.mal_type) + { + case MALTYPE_SYMBOL: + return env.get(ast); + case MALTYPE_LIST: + return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_VECTOR: + return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_MAP: + array(Val) elements = ({ }); + foreach(ast.data; Val k; Val v) + { + elements += ({ k, EVAL(v, env) }); + } + return Map(elements); + default: + return ast; + } +} + +Val EVAL(Val ast, Env env) +{ + while(true) + { + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + ast = macroexpand(ast, env); + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + if(ast.emptyp()) return ast; + if(ast.data[0].mal_type == MALTYPE_SYMBOL) { + switch(ast.data[0].value) + { + case "def!": + return env.set(ast.data[1], EVAL(ast.data[2], env)); + case "let*": + Env let_env = Env(env); + Val ast1 = ast.data[1]; + for(int i = 0; i < sizeof(ast1.data); i += 2) + { + let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); + } + env = let_env; + ast = ast.data[2]; + continue; // TCO + case "quote": + return ast.data[1]; + case "quasiquoteexpand": + return quasiquote(ast.data[1]); + case "quasiquote": + ast = quasiquote(ast.data[1]); + continue; // TCO + case "defmacro!": + Val macro = EVAL(ast.data[2], env).clone_as_macro(); + return env.set(ast.data[1], macro); + case "macroexpand": + return macroexpand(ast.data[1], env); + case "do": + Val result; + foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) + { + result = EVAL(element, env); + } + ast = ast.data[-1]; + continue; // TCO + case "if": + Val cond = EVAL(ast.data[1], env); + if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) + { + if(sizeof(ast.data) > 3) + ast = ast.data[3]; + else + return MAL_NIL; + } + else + ast = ast.data[2]; + continue; // TCO + case "fn*": + return Fn(ast.data[2], ast.data[1], env, + lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); + } + } + Val evaled_ast = eval_ast(ast, env); + Val f = evaled_ast.data[0]; + switch(f.mal_type) + { + case MALTYPE_BUILTINFN: + return f(@evaled_ast.data[1..]); + case MALTYPE_FN: + ast = f.ast; + env = Env(f.env, f.params, List(evaled_ast.data[1..])); + continue; // TCO + default: + throw("Unknown function type"); + } + } +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +int main(int argc, array argv) +{ + Env repl_env = Env(0); + foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); + repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); + repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); + rep("(def! not (fn* (a) (if a false true)))", repl_env); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + 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)))))))", repl_env); + if(argc >= 2) + { + rep("(load-file \"" + argv[1] + "\")", repl_env); + return 0; + } + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) + { + if(arrayp(err)) err = err[0]; + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/step9_try.pike b/impls/pike/step9_try.pike index 63d6bd9d27..7aabe6e6a0 100644 --- a/impls/pike/step9_try.pike +++ b/impls/pike/step9_try.pike @@ -1,231 +1,231 @@ -import .Env; -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -bool starts_with(Val ast, string sym) -{ - return ast.mal_type == MALTYPE_LIST && - !ast.emptyp() && - ast.data[0].mal_type == MALTYPE_SYMBOL && - ast.data[0].value == sym; -} - -Val quasiquote_list(array(Val) elts) -{ - Val acc = List(({ })); - for(int i=sizeof(elts)-1; 0<=i; i-=1) - { - Val elt = elts[i]; - if(starts_with(elt, "splice-unquote")) - acc = List(({ Symbol("concat"), elt.data[1], acc })); - else - acc = List(({ Symbol("cons"), quasiquote(elt), acc })); - } - return acc; -} - -Val quasiquote(Val ast) -{ - switch(ast.mal_type) - { - case MALTYPE_LIST: - if(starts_with(ast, "unquote")) - return ast.data[1]; - else - return quasiquote_list(ast.data); - case MALTYPE_VECTOR: - return List(({ Symbol("vec"), quasiquote_list(ast.data) })); - case MALTYPE_SYMBOL: - case MALTYPE_MAP: - return List(({ Symbol("quote"), ast })); - default: - return ast; - } -} - -bool is_macro_call(Val ast, Env env) -{ - if(ast.mal_type == MALTYPE_LIST && - !ast.emptyp() && - ast.data[0].mal_type == MALTYPE_SYMBOL && - env.find(ast.data[0])) - { - Val v = env.get(ast.data[0]); - if(objectp(v) && v.macro) return true; - } - return false; -} - -Val macroexpand(Val ast, Env env) -{ - while(is_macro_call(ast, env)) - { - Val macro = env.get(ast.data[0]); - ast = macro(@ast.data[1..]); - } - return ast; -} - -Val eval_ast(Val ast, Env env) -{ - switch(ast.mal_type) - { - case MALTYPE_SYMBOL: - return env.get(ast); - case MALTYPE_LIST: - return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_VECTOR: - return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_MAP: - array(Val) elements = ({ }); - foreach(ast.data; Val k; Val v) - { - elements += ({ k, EVAL(v, env) }); - } - return Map(elements); - default: - return ast; - } -} - -Val EVAL(Val ast, Env env) -{ - while(true) - { - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - ast = macroexpand(ast, env); - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - if(ast.emptyp()) return ast; - if(ast.data[0].mal_type == MALTYPE_SYMBOL) { - switch(ast.data[0].value) - { - case "def!": - return env.set(ast.data[1], EVAL(ast.data[2], env)); - case "let*": - Env let_env = Env(env); - Val ast1 = ast.data[1]; - for(int i = 0; i < sizeof(ast1.data); i += 2) - { - let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); - } - env = let_env; - ast = ast.data[2]; - continue; // TCO - case "quote": - return ast.data[1]; - case "quasiquoteexpand": - return quasiquote(ast.data[1]); - case "quasiquote": - ast = quasiquote(ast.data[1]); - continue; // TCO - case "defmacro!": - Val macro = EVAL(ast.data[2], env).clone_as_macro(); - return env.set(ast.data[1], macro); - case "macroexpand": - return macroexpand(ast.data[1], env); - case "try*": - if(ast.count() < 3) return EVAL(ast.data[1], env); - if(mixed err = catch { return EVAL(ast.data[1], env); } ) - { - Val err_val; - if(objectp(err)) err_val = err; - else if(stringp(err)) err_val = String(err); - else if(arrayp(err)) err_val = String(err[0]); - Val catch_clause = ast.data[2]; - Env catch_env = Env(env); - catch_env.set(catch_clause.data[1], err_val); - return EVAL(catch_clause.data[2], catch_env); - } - case "do": - Val result; - foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) - { - result = EVAL(element, env); - } - ast = ast.data[-1]; - continue; // TCO - case "if": - Val cond = EVAL(ast.data[1], env); - if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) - { - if(sizeof(ast.data) > 3) - ast = ast.data[3]; - else - return MAL_NIL; - } - else - ast = ast.data[2]; - continue; // TCO - case "fn*": - return Fn(ast.data[2], ast.data[1], env, - lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); - } - } - Val evaled_ast = eval_ast(ast, env); - Val f = evaled_ast.data[0]; - switch(f.mal_type) - { - case MALTYPE_BUILTINFN: - return f(@evaled_ast.data[1..]); - case MALTYPE_FN: - ast = f.ast; - env = Env(f.env, f.params, List(evaled_ast.data[1..])); - continue; // TCO - default: - throw("Unknown function type"); - } - } -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -int main(int argc, array argv) -{ - Env repl_env = Env(0); - foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); - repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); - repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); - rep("(def! not (fn* (a) (if a false true)))", repl_env); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - 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)))))))", repl_env); - if(argc >= 2) - { - rep("(load-file \"" + argv[1] + "\")", repl_env); - return 0; - } - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) - { - if(objectp(err)) - { - err = err.to_string(true); - } - else if(arrayp(err)) - { - err = err[0]; - } - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Env; +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +bool starts_with(Val ast, string sym) +{ + return ast.mal_type == MALTYPE_LIST && + !ast.emptyp() && + ast.data[0].mal_type == MALTYPE_SYMBOL && + ast.data[0].value == sym; +} + +Val quasiquote_list(array(Val) elts) +{ + Val acc = List(({ })); + for(int i=sizeof(elts)-1; 0<=i; i-=1) + { + Val elt = elts[i]; + if(starts_with(elt, "splice-unquote")) + acc = List(({ Symbol("concat"), elt.data[1], acc })); + else + acc = List(({ Symbol("cons"), quasiquote(elt), acc })); + } + return acc; +} + +Val quasiquote(Val ast) +{ + switch(ast.mal_type) + { + case MALTYPE_LIST: + if(starts_with(ast, "unquote")) + return ast.data[1]; + else + return quasiquote_list(ast.data); + case MALTYPE_VECTOR: + return List(({ Symbol("vec"), quasiquote_list(ast.data) })); + case MALTYPE_SYMBOL: + case MALTYPE_MAP: + return List(({ Symbol("quote"), ast })); + default: + return ast; + } +} + +bool is_macro_call(Val ast, Env env) +{ + if(ast.mal_type == MALTYPE_LIST && + !ast.emptyp() && + ast.data[0].mal_type == MALTYPE_SYMBOL && + env.find(ast.data[0])) + { + Val v = env.get(ast.data[0]); + if(objectp(v) && v.macro) return true; + } + return false; +} + +Val macroexpand(Val ast, Env env) +{ + while(is_macro_call(ast, env)) + { + Val macro = env.get(ast.data[0]); + ast = macro(@ast.data[1..]); + } + return ast; +} + +Val eval_ast(Val ast, Env env) +{ + switch(ast.mal_type) + { + case MALTYPE_SYMBOL: + return env.get(ast); + case MALTYPE_LIST: + return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_VECTOR: + return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_MAP: + array(Val) elements = ({ }); + foreach(ast.data; Val k; Val v) + { + elements += ({ k, EVAL(v, env) }); + } + return Map(elements); + default: + return ast; + } +} + +Val EVAL(Val ast, Env env) +{ + while(true) + { + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + ast = macroexpand(ast, env); + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + if(ast.emptyp()) return ast; + if(ast.data[0].mal_type == MALTYPE_SYMBOL) { + switch(ast.data[0].value) + { + case "def!": + return env.set(ast.data[1], EVAL(ast.data[2], env)); + case "let*": + Env let_env = Env(env); + Val ast1 = ast.data[1]; + for(int i = 0; i < sizeof(ast1.data); i += 2) + { + let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); + } + env = let_env; + ast = ast.data[2]; + continue; // TCO + case "quote": + return ast.data[1]; + case "quasiquoteexpand": + return quasiquote(ast.data[1]); + case "quasiquote": + ast = quasiquote(ast.data[1]); + continue; // TCO + case "defmacro!": + Val macro = EVAL(ast.data[2], env).clone_as_macro(); + return env.set(ast.data[1], macro); + case "macroexpand": + return macroexpand(ast.data[1], env); + case "try*": + if(ast.count() < 3) return EVAL(ast.data[1], env); + if(mixed err = catch { return EVAL(ast.data[1], env); } ) + { + Val err_val; + if(objectp(err)) err_val = err; + else if(stringp(err)) err_val = String(err); + else if(arrayp(err)) err_val = String(err[0]); + Val catch_clause = ast.data[2]; + Env catch_env = Env(env); + catch_env.set(catch_clause.data[1], err_val); + return EVAL(catch_clause.data[2], catch_env); + } + case "do": + Val result; + foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) + { + result = EVAL(element, env); + } + ast = ast.data[-1]; + continue; // TCO + case "if": + Val cond = EVAL(ast.data[1], env); + if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) + { + if(sizeof(ast.data) > 3) + ast = ast.data[3]; + else + return MAL_NIL; + } + else + ast = ast.data[2]; + continue; // TCO + case "fn*": + return Fn(ast.data[2], ast.data[1], env, + lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); + } + } + Val evaled_ast = eval_ast(ast, env); + Val f = evaled_ast.data[0]; + switch(f.mal_type) + { + case MALTYPE_BUILTINFN: + return f(@evaled_ast.data[1..]); + case MALTYPE_FN: + ast = f.ast; + env = Env(f.env, f.params, List(evaled_ast.data[1..])); + continue; // TCO + default: + throw("Unknown function type"); + } + } +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +int main(int argc, array argv) +{ + Env repl_env = Env(0); + foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); + repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); + repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); + rep("(def! not (fn* (a) (if a false true)))", repl_env); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + 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)))))))", repl_env); + if(argc >= 2) + { + rep("(load-file \"" + argv[1] + "\")", repl_env); + return 0; + } + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) + { + if(objectp(err)) + { + err = err.to_string(true); + } + else if(arrayp(err)) + { + err = err[0]; + } + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/stepA_mal.pike b/impls/pike/stepA_mal.pike index f2a9c64a63..cd4f0e2c61 100644 --- a/impls/pike/stepA_mal.pike +++ b/impls/pike/stepA_mal.pike @@ -1,233 +1,233 @@ -import .Env; -import .Printer; -import .Reader; -import .Readline; -import .Types; - -Val READ(string str) -{ - return read_str(str); -} - -bool starts_with(Val ast, string sym) -{ - return ast.mal_type == MALTYPE_LIST && - !ast.emptyp() && - ast.data[0].mal_type == MALTYPE_SYMBOL && - ast.data[0].value == sym; -} - -Val quasiquote_list(array(Val) elts) -{ - Val acc = List(({ })); - for(int i=sizeof(elts)-1; 0<=i; i-=1) - { - Val elt = elts[i]; - if(starts_with(elt, "splice-unquote")) - acc = List(({ Symbol("concat"), elt.data[1], acc })); - else - acc = List(({ Symbol("cons"), quasiquote(elt), acc })); - } - return acc; -} - -Val quasiquote(Val ast) -{ - switch(ast.mal_type) - { - case MALTYPE_LIST: - if(starts_with(ast, "unquote")) - return ast.data[1]; - else - return quasiquote_list(ast.data); - case MALTYPE_VECTOR: - return List(({ Symbol("vec"), quasiquote_list(ast.data) })); - case MALTYPE_SYMBOL: - case MALTYPE_MAP: - return List(({ Symbol("quote"), ast })); - default: - return ast; - } -} - -bool is_macro_call(Val ast, Env env) -{ - if(ast.mal_type == MALTYPE_LIST && - !ast.emptyp() && - ast.data[0].mal_type == MALTYPE_SYMBOL && - env.find(ast.data[0])) - { - Val v = env.get(ast.data[0]); - if(objectp(v) && v.macro) return true; - } - return false; -} - -Val macroexpand(Val ast, Env env) -{ - while(is_macro_call(ast, env)) - { - Val macro = env.get(ast.data[0]); - ast = macro(@ast.data[1..]); - } - return ast; -} - -Val eval_ast(Val ast, Env env) -{ - switch(ast.mal_type) - { - case MALTYPE_SYMBOL: - return env.get(ast); - case MALTYPE_LIST: - return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_VECTOR: - return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); - case MALTYPE_MAP: - array(Val) elements = ({ }); - foreach(ast.data; Val k; Val v) - { - elements += ({ k, EVAL(v, env) }); - } - return Map(elements); - default: - return ast; - } -} - -Val EVAL(Val ast, Env env) -{ - while(true) - { - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - ast = macroexpand(ast, env); - if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); - if(ast.emptyp()) return ast; - if(ast.data[0].mal_type == MALTYPE_SYMBOL) { - switch(ast.data[0].value) - { - case "def!": - return env.set(ast.data[1], EVAL(ast.data[2], env)); - case "let*": - Env let_env = Env(env); - Val ast1 = ast.data[1]; - for(int i = 0; i < sizeof(ast1.data); i += 2) - { - let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); - } - env = let_env; - ast = ast.data[2]; - continue; // TCO - case "quote": - return ast.data[1]; - case "quasiquoteexpand": - return quasiquote(ast.data[1]); - case "quasiquote": - ast = quasiquote(ast.data[1]); - continue; // TCO - case "defmacro!": - Val macro = EVAL(ast.data[2], env).clone_as_macro(); - return env.set(ast.data[1], macro); - case "macroexpand": - return macroexpand(ast.data[1], env); - case "try*": - if(ast.count() < 3) return EVAL(ast.data[1], env); - if(mixed err = catch { return EVAL(ast.data[1], env); } ) - { - Val err_val; - if(objectp(err)) err_val = err; - else if(stringp(err)) err_val = String(err); - else if(arrayp(err)) err_val = String(err[0]); - Val catch_clause = ast.data[2]; - Env catch_env = Env(env); - catch_env.set(catch_clause.data[1], err_val); - return EVAL(catch_clause.data[2], catch_env); - } - case "do": - Val result; - foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) - { - result = EVAL(element, env); - } - ast = ast.data[-1]; - continue; // TCO - case "if": - Val cond = EVAL(ast.data[1], env); - if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) - { - if(sizeof(ast.data) > 3) - ast = ast.data[3]; - else - return MAL_NIL; - } - else - ast = ast.data[2]; - continue; // TCO - case "fn*": - return Fn(ast.data[2], ast.data[1], env, - lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); - } - } - Val evaled_ast = eval_ast(ast, env); - Val f = evaled_ast.data[0]; - switch(f.mal_type) - { - case MALTYPE_BUILTINFN: - return f(@evaled_ast.data[1..]); - case MALTYPE_FN: - ast = f.ast; - env = Env(f.env, f.params, List(evaled_ast.data[1..])); - continue; // TCO - default: - throw("Unknown function type"); - } - } -} - -string PRINT(Val exp) -{ - return pr_str(exp, true); -} - -string rep(string str, Env env) -{ - return PRINT(EVAL(READ(str), env)); -} - -int main(int argc, array argv) -{ - Env repl_env = Env(0); - foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); - repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); - repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); - rep("(def! *host-language* \"pike\")", repl_env); - rep("(def! not (fn* (a) (if a false true)))", repl_env); - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); - 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)))))))", repl_env); - if(argc >= 2) - { - rep("(load-file \"" + argv[1] + "\")", repl_env); - return 0; - } - rep("(println (str \"Mal [\" \*host-language\* \"]\"))", repl_env); - while(1) - { - string line = readline("user> "); - if(!line) break; - if(strlen(line) == 0) continue; - if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) - { - if(arrayp(err)) - { - err = err[0]; - } - else if(objectp(err)) - { - err = err.to_string(true); - } - write(({ "Error: ", err, "\n" })); - } - } - write("\n"); - return 0; -} +import .Env; +import .Printer; +import .Reader; +import .Readline; +import .Types; + +Val READ(string str) +{ + return read_str(str); +} + +bool starts_with(Val ast, string sym) +{ + return ast.mal_type == MALTYPE_LIST && + !ast.emptyp() && + ast.data[0].mal_type == MALTYPE_SYMBOL && + ast.data[0].value == sym; +} + +Val quasiquote_list(array(Val) elts) +{ + Val acc = List(({ })); + for(int i=sizeof(elts)-1; 0<=i; i-=1) + { + Val elt = elts[i]; + if(starts_with(elt, "splice-unquote")) + acc = List(({ Symbol("concat"), elt.data[1], acc })); + else + acc = List(({ Symbol("cons"), quasiquote(elt), acc })); + } + return acc; +} + +Val quasiquote(Val ast) +{ + switch(ast.mal_type) + { + case MALTYPE_LIST: + if(starts_with(ast, "unquote")) + return ast.data[1]; + else + return quasiquote_list(ast.data); + case MALTYPE_VECTOR: + return List(({ Symbol("vec"), quasiquote_list(ast.data) })); + case MALTYPE_SYMBOL: + case MALTYPE_MAP: + return List(({ Symbol("quote"), ast })); + default: + return ast; + } +} + +bool is_macro_call(Val ast, Env env) +{ + if(ast.mal_type == MALTYPE_LIST && + !ast.emptyp() && + ast.data[0].mal_type == MALTYPE_SYMBOL && + env.find(ast.data[0])) + { + Val v = env.get(ast.data[0]); + if(objectp(v) && v.macro) return true; + } + return false; +} + +Val macroexpand(Val ast, Env env) +{ + while(is_macro_call(ast, env)) + { + Val macro = env.get(ast.data[0]); + ast = macro(@ast.data[1..]); + } + return ast; +} + +Val eval_ast(Val ast, Env env) +{ + switch(ast.mal_type) + { + case MALTYPE_SYMBOL: + return env.get(ast); + case MALTYPE_LIST: + return List(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_VECTOR: + return Vector(map(ast.data, lambda(Val e) { return EVAL(e, env); })); + case MALTYPE_MAP: + array(Val) elements = ({ }); + foreach(ast.data; Val k; Val v) + { + elements += ({ k, EVAL(v, env) }); + } + return Map(elements); + default: + return ast; + } +} + +Val EVAL(Val ast, Env env) +{ + while(true) + { + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + ast = macroexpand(ast, env); + if(ast.mal_type != MALTYPE_LIST) return eval_ast(ast, env); + if(ast.emptyp()) return ast; + if(ast.data[0].mal_type == MALTYPE_SYMBOL) { + switch(ast.data[0].value) + { + case "def!": + return env.set(ast.data[1], EVAL(ast.data[2], env)); + case "let*": + Env let_env = Env(env); + Val ast1 = ast.data[1]; + for(int i = 0; i < sizeof(ast1.data); i += 2) + { + let_env.set(ast1.data[i], EVAL(ast1.data[i + 1], let_env)); + } + env = let_env; + ast = ast.data[2]; + continue; // TCO + case "quote": + return ast.data[1]; + case "quasiquoteexpand": + return quasiquote(ast.data[1]); + case "quasiquote": + ast = quasiquote(ast.data[1]); + continue; // TCO + case "defmacro!": + Val macro = EVAL(ast.data[2], env).clone_as_macro(); + return env.set(ast.data[1], macro); + case "macroexpand": + return macroexpand(ast.data[1], env); + case "try*": + if(ast.count() < 3) return EVAL(ast.data[1], env); + if(mixed err = catch { return EVAL(ast.data[1], env); } ) + { + Val err_val; + if(objectp(err)) err_val = err; + else if(stringp(err)) err_val = String(err); + else if(arrayp(err)) err_val = String(err[0]); + Val catch_clause = ast.data[2]; + Env catch_env = Env(env); + catch_env.set(catch_clause.data[1], err_val); + return EVAL(catch_clause.data[2], catch_env); + } + case "do": + Val result; + foreach(ast.data[1..(sizeof(ast.data) - 2)], Val element) + { + result = EVAL(element, env); + } + ast = ast.data[-1]; + continue; // TCO + case "if": + Val cond = EVAL(ast.data[1], env); + if(cond.mal_type == MALTYPE_FALSE || cond.mal_type == MALTYPE_NIL) + { + if(sizeof(ast.data) > 3) + ast = ast.data[3]; + else + return MAL_NIL; + } + else + ast = ast.data[2]; + continue; // TCO + case "fn*": + return Fn(ast.data[2], ast.data[1], env, + lambda(Val ... a) { return EVAL(ast.data[2], Env(env, ast.data[1], List(a))); }); + } + } + Val evaled_ast = eval_ast(ast, env); + Val f = evaled_ast.data[0]; + switch(f.mal_type) + { + case MALTYPE_BUILTINFN: + return f(@evaled_ast.data[1..]); + case MALTYPE_FN: + ast = f.ast; + env = Env(f.env, f.params, List(evaled_ast.data[1..])); + continue; // TCO + default: + throw("Unknown function type"); + } + } +} + +string PRINT(Val exp) +{ + return pr_str(exp, true); +} + +string rep(string str, Env env) +{ + return PRINT(EVAL(READ(str), env)); +} + +int main(int argc, array argv) +{ + Env repl_env = Env(0); + foreach(.Core.NS(); Val k; Val v) repl_env.set(k, v); + repl_env.set(Symbol("eval"), BuiltinFn("eval", lambda(Val a) { return EVAL(a, repl_env); })); + repl_env.set(Symbol("*ARGV*"), List(map(argv[2..], String))); + rep("(def! *host-language* \"pike\")", repl_env); + rep("(def! not (fn* (a) (if a false true)))", repl_env); + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env); + 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)))))))", repl_env); + if(argc >= 2) + { + rep("(load-file \"" + argv[1] + "\")", repl_env); + return 0; + } + rep("(println (str \"Mal [\" \*host-language\* \"]\"))", repl_env); + while(1) + { + string line = readline("user> "); + if(!line) break; + if(strlen(line) == 0) continue; + if(mixed err = catch { write(({ rep(line, repl_env), "\n" })); } ) + { + if(arrayp(err)) + { + err = err[0]; + } + else if(objectp(err)) + { + err = err.to_string(true); + } + write(({ "Error: ", err, "\n" })); + } + } + write("\n"); + return 0; +} diff --git a/impls/pike/tests/step5_tco.mal b/impls/pike/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/pike/tests/step5_tco.mal +++ b/impls/pike/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/pike/tests/stepA_mal.mal b/impls/pike/tests/stepA_mal.mal index 3d69497c5e..3b5c36ed1a 100644 --- a/impls/pike/tests/stepA_mal.mal +++ b/impls/pike/tests/stepA_mal.mal @@ -1,36 +1,36 @@ -;; Testing basic Pike interop - -;;; pike-eval compiles the given string inside a temporary function after a -;;; "return " keyword. To evaluate complex statements, you may use an anonymous -;;; lambda and call it immediately (see the last example). - -(pike-eval "7") -;=>7 - -(pike-eval "'A'") -;=>65 - -(pike-eval "\"7\"") -;=>"7" - -(pike-eval "({ 7,8,9 })") -;=>(7 8 9) - -(pike-eval "([ \"abc\": 789 ])") -;=>{"abc" 789} - -(pike-eval "write(\"hello\\n\")") -;/hello -;=>6 - -(pike-eval "map(({ \"a\", \"b\", \"c\" }), lambda(string x) { return \"X\" + x + \"Y\"; }) * \" \"") -;=>"XaY XbY XcY" - -(pike-eval "map(({ 1,2,3 }), lambda(int x) { return 1 + x; })") -;=>(2 3 4) - -(pike-eval "throw(upper_case(\"aaa\" + \"bbb\"))") -;/Error: AAABBB - -(pike-eval "(lambda() { int a = 5; int b = a * 3; return a + b; })()") -;=>20 +;; Testing basic Pike interop + +;;; pike-eval compiles the given string inside a temporary function after a +;;; "return " keyword. To evaluate complex statements, you may use an anonymous +;;; lambda and call it immediately (see the last example). + +(pike-eval "7") +;=>7 + +(pike-eval "'A'") +;=>65 + +(pike-eval "\"7\"") +;=>"7" + +(pike-eval "({ 7,8,9 })") +;=>(7 8 9) + +(pike-eval "([ \"abc\": 789 ])") +;=>{"abc" 789} + +(pike-eval "write(\"hello\\n\")") +;/hello +;=>6 + +(pike-eval "map(({ \"a\", \"b\", \"c\" }), lambda(string x) { return \"X\" + x + \"Y\"; }) * \" \"") +;=>"XaY XbY XcY" + +(pike-eval "map(({ 1,2,3 }), lambda(int x) { return 1 + x; })") +;=>(2 3 4) + +(pike-eval "throw(upper_case(\"aaa\" + \"bbb\"))") +;/Error: AAABBB + +(pike-eval "(lambda() { int a = 5; int b = a * 3; return a + b; })()") +;=>20 diff --git a/impls/plpgsql/Dockerfile b/impls/plpgsql/Dockerfile index eb64c1ae34..3a18e909df 100644 --- a/impls/plpgsql/Dockerfile +++ b/impls/plpgsql/Dockerfile @@ -1,37 +1,37 @@ -FROM ubuntu:14.04 - -RUN apt-get -y update -RUN apt-get -y install make cpp python - -RUN apt-get -y install curl -RUN useradd -u 1000 -m -s /bin/bash -G sudo postgres - -ENV PG_VERSION=9.4 -RUN curl https://www.postgresql.org/media/keys/ACCC4CF8.asc | apt-key add - && \ - echo 'deb http://apt.postgresql.org/pub/repos/apt/ trusty-pgdg main' > /etc/apt/sources.list.d/pgdg.list && \ - apt-get update && \ - DEBIAN_FRONTEND=noninteractive apt-get -y install acl \ - postgresql-${PG_VERSION} postgresql-client-${PG_VERSION} postgresql-contrib-${PG_VERSION} && \ - mkdir -p /var/run/postgresql/9.4-main.pg_stat_tmp/ && \ - chown -R postgres.postgres /var/run/postgresql - -ENV HOME=/var/run/postgresql - -WORKDIR /mal - -# Travis runs as a couple of different users so add them -RUN useradd -ou 1001 -m -s /bin/bash -G sudo,postgres travis -RUN useradd -ou 2000 -m -s /bin/bash -G sudo,postgres travis2 - -# Enable postgres and travis users to sudo for postgres startup -RUN echo "%sudo ALL=(ALL:ALL) NOPASSWD: ALL" >> /etc/sudoers - -# Allow both travis and postgres user to connect to DB as 'postgres' -RUN sed -i 's/peer$/peer map=mal/' /etc/postgresql/9.4/main/pg_hba.conf -RUN echo "mal postgres postgres" >> /etc/postgresql/9.4/main/pg_ident.conf -RUN echo "mal travis postgres" >> /etc/postgresql/9.4/main/pg_ident.conf -RUN echo "mal travis2 postgres" >> /etc/postgresql/9.4/main/pg_ident.conf - -# Add entrypoint.sh which starts postgres then run bash/command -ADD entrypoint.sh /entrypoint.sh -ENTRYPOINT ["/entrypoint.sh"] +FROM ubuntu:14.04 + +RUN apt-get -y update +RUN apt-get -y install make cpp python + +RUN apt-get -y install curl +RUN useradd -u 1000 -m -s /bin/bash -G sudo postgres + +ENV PG_VERSION=9.4 +RUN curl https://www.postgresql.org/media/keys/ACCC4CF8.asc | apt-key add - && \ + echo 'deb http://apt.postgresql.org/pub/repos/apt/ trusty-pgdg main' > /etc/apt/sources.list.d/pgdg.list && \ + apt-get update && \ + DEBIAN_FRONTEND=noninteractive apt-get -y install acl \ + postgresql-${PG_VERSION} postgresql-client-${PG_VERSION} postgresql-contrib-${PG_VERSION} && \ + mkdir -p /var/run/postgresql/9.4-main.pg_stat_tmp/ && \ + chown -R postgres.postgres /var/run/postgresql + +ENV HOME=/var/run/postgresql + +WORKDIR /mal + +# Travis runs as a couple of different users so add them +RUN useradd -ou 1001 -m -s /bin/bash -G sudo,postgres travis +RUN useradd -ou 2000 -m -s /bin/bash -G sudo,postgres travis2 + +# Enable postgres and travis users to sudo for postgres startup +RUN echo "%sudo ALL=(ALL:ALL) NOPASSWD: ALL" >> /etc/sudoers + +# Allow both travis and postgres user to connect to DB as 'postgres' +RUN sed -i 's/peer$/peer map=mal/' /etc/postgresql/9.4/main/pg_hba.conf +RUN echo "mal postgres postgres" >> /etc/postgresql/9.4/main/pg_ident.conf +RUN echo "mal travis postgres" >> /etc/postgresql/9.4/main/pg_ident.conf +RUN echo "mal travis2 postgres" >> /etc/postgresql/9.4/main/pg_ident.conf + +# Add entrypoint.sh which starts postgres then run bash/command +ADD entrypoint.sh /entrypoint.sh +ENTRYPOINT ["/entrypoint.sh"] diff --git a/impls/plpgsql/Makefile b/impls/plpgsql/Makefile index 7af3113c71..14414a8c2b 100644 --- a/impls/plpgsql/Makefile +++ b/impls/plpgsql/Makefile @@ -1,3 +1,3 @@ -all: - -clean: +all: + +clean: diff --git a/impls/plpgsql/core.sql b/impls/plpgsql/core.sql index eb9f0b7176..f3669b4eea 100644 --- a/impls/plpgsql/core.sql +++ b/impls/plpgsql/core.sql @@ -1,584 +1,584 @@ -CREATE SCHEMA core; - --- general functions - -CREATE FUNCTION core.equal(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._equal_Q(args[1], args[2])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.throw(args integer[]) RETURNS integer AS $$ -BEGIN - -- TODO: Only throws strings. Without subtransactions, all changes - -- to DB up to this point get rolled back so the object being - -- thrown dissapears. - RAISE EXCEPTION '%', printer.pr_str(args[1], false); -END; $$ LANGUAGE plpgsql; - - --- scalar functions - -CREATE FUNCTION core.nil_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._nil_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.true_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._true_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.false_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._false_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.number_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._number_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.string_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._string_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.symbol(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._symbolv(types._valueToString(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.symbol_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._symbol_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.keyword(args integer[]) RETURNS integer AS $$ -BEGIN - IF types._keyword_Q(args[1]) THEN - RETURN args[1]; - ELSE - RETURN types._keywordv(types._valueToString(args[1])); - END IF; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.keyword_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._keyword_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.fn_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._fn_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.macro_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._macro_Q(args[1])); -END; $$ LANGUAGE plpgsql; - - --- string functions - -CREATE FUNCTION core.pr_str(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._stringv(printer.pr_str_array(args, ' ', true)); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.str(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._stringv(printer.pr_str_array(args, '', false)); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.prn(args integer[]) RETURNS integer AS $$ -BEGIN - PERFORM io.writeline(printer.pr_str_array(args, ' ', true)); - RETURN 0; -- nil -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.println(args integer[]) RETURNS integer AS $$ -BEGIN - PERFORM io.writeline(printer.pr_str_array(args, ' ', false)); - RETURN 0; -- nil -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.read_string(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(types._valueToString(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.readline(args integer[]) RETURNS integer AS $$ -DECLARE - input varchar; -BEGIN - input := io.readline(types._valueToString(args[1])); - IF input IS NULL THEN - RETURN 0; -- nil - END IF; - RETURN types._stringv(rtrim(input, E'\n')); -END; $$ LANGUAGE plpgsql; - - --- See: --- http://shuber.io/reading-from-the-filesystem-with-postgres/ -CREATE FUNCTION core.slurp(args integer[]) RETURNS integer AS $$ -DECLARE - fname varchar; - tmp varchar; - cmd varchar; - lines varchar[]; - content varchar; -BEGIN - fname := types._valueToString(args[1]); - IF fname NOT LIKE '/%' THEN - fname := types._valueToString(envs.vget(0, '*PWD*')) || '/' || fname; - END IF; - - tmp := CAST(round(random()*1000000) AS varchar); - - EXECUTE format('CREATE TEMP TABLE %I (content text)', tmp); - cmd := format('sed ''s/\\/\\\\/g'' %L', fname); - EXECUTE format('COPY %I FROM PROGRAM %L', tmp, cmd); - EXECUTE format('SELECT ARRAY(SELECT content FROM %I)', tmp) INTO lines; - EXECUTE format('DROP TABLE %I', tmp); - - content := array_to_string(lines, E'\n') || E'\n'; - RETURN types._stringv(content); -END; $$ LANGUAGE plpgsql; - - --- number functions - --- integer comparison -CREATE FUNCTION core.intcmp(op varchar, args integer[]) RETURNS integer AS $$ -DECLARE a bigint; b bigint; result boolean; -BEGIN - SELECT val_int INTO a FROM types.value WHERE value_id = args[1]; - SELECT val_int INTO b FROM types.value WHERE value_id = args[2]; - EXECUTE format('SELECT $1 %s $2;', op) INTO result USING a, b; - RETURN types._wraptf(result); -END; $$ LANGUAGE plpgsql; - --- integer operation -CREATE FUNCTION core.intop(op varchar, args integer[]) RETURNS integer AS $$ -DECLARE a bigint; b bigint; result bigint; -BEGIN - SELECT val_int INTO a FROM types.value WHERE value_id = args[1]; - SELECT val_int INTO b FROM types.value WHERE value_id = args[2]; - EXECUTE format('SELECT $1 %s $2;', op) INTO result USING a, b; - RETURN types._numToValue(result); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.lt(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN core.intcmp('<', args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.lte(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN core.intcmp('<=', args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.gt(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN core.intcmp('>', args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.gte(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN core.intcmp('>=', args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.add(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN core.intop('+', args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.subtract(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN core.intop('-', args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.multiply(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN core.intop('*', args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.divide(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN core.intop('/', args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.time_ms(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._numToValue( - CAST(date_part('epoch', clock_timestamp()) * 1000 AS bigint)); -END; $$ LANGUAGE plpgsql; - - --- collection functions - -CREATE FUNCTION core.list(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._list(args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.list_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._list_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.vector(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._vector(args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.vector_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._vector_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.hash_map(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._hash_map(args); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.map_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._hash_map_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.assoc(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._assoc_BANG(types._clone(args[1]), - args[2:array_length(args, 1)]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.dissoc(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._dissoc_BANG(types._clone(args[1]), - args[2:array_length(args, 1)]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.get(args integer[]) RETURNS integer AS $$ -DECLARE - result integer; -BEGIN - IF types._type(args[1]) = 0 THEN -- nil - RETURN 0; - ELSE - result := types._get(args[1], types._valueToString(args[2])); - IF result IS NULL THEN RETURN 0; END IF; - RETURN result; - END IF; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.contains_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._contains_Q(args[1], - types._valueToString(args[2]))); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.keys(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._list(types._keys(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.vals(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._list(types._vals(args[1])); -END; $$ LANGUAGE plpgsql; - - - --- sequence functions - -CREATE FUNCTION core.sequential_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._sequential_Q(args[1])); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.cons(args integer[]) RETURNS integer AS $$ -DECLARE - lst integer[]; -BEGIN - lst := array_prepend(args[1], types._valueToArray(args[2])); - RETURN types._list(lst); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.concat(args integer[]) RETURNS integer AS $$ -DECLARE - lst integer; - result integer[] = ARRAY[]::integer[]; -BEGIN - FOREACH lst IN ARRAY args LOOP - result := array_cat(result, types._valueToArray(lst)); - END LOOP; - RETURN types._list(result); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.vec(args integer[]) RETURNS integer AS $$ -BEGIN - IF types._vector_Q(args[1]) THEN - RETURN args[1]; - ELSE - RETURN types._vector(types._valueToArray(args[1])); - END IF; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.nth(args integer[]) RETURNS integer AS $$ -DECLARE - idx integer; -BEGIN - SELECT val_int INTO idx FROM types.value WHERE value_id = args[2]; - IF idx >= types._count(args[1]) THEN - RAISE EXCEPTION 'nth: index out of range'; - END IF; - RETURN types._nth(args[1], idx); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.first(args integer[]) RETURNS integer AS $$ -BEGIN - IF types._nil_Q(args[1]) THEN - RETURN 0; -- nil - ELSIF types._count(args[1]) = 0 THEN - RETURN 0; -- nil - ELSE - RETURN types._first(args[1]); - END IF; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.rest(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._rest(args[1]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.empty_Q(args integer[]) RETURNS integer AS $$ -BEGIN - IF types._sequential_Q(args[1]) AND types._count(args[1]) = 0 THEN - RETURN 2; - ELSE - RETURN 1; - END IF; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.count(args integer[]) RETURNS integer AS $$ -BEGIN - IF types._sequential_Q(args[1]) THEN - RETURN types._numToValue(types._count(args[1])); - ELSIF types._nil_Q(args[1]) THEN - RETURN types._numToValue(0); - ELSE - RAISE EXCEPTION 'count called on non-sequence'; - END IF; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.apply(args integer[]) RETURNS integer AS $$ -DECLARE - alen integer; - fargs integer[]; -BEGIN - alen := array_length(args, 1); - fargs := array_cat(args[2:alen-1], types._valueToArray(args[alen])); - RETURN types._apply(args[1], fargs); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.map(args integer[]) RETURNS integer AS $$ -DECLARE - x integer; - result integer[]; -BEGIN - FOREACH x IN ARRAY types._valueToArray(args[2]) - LOOP - result := array_append(result, types._apply(args[1], ARRAY[x])); - END LOOP; - return types._list(result); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.conj(args integer[]) RETURNS integer AS $$ -DECLARE - type integer; -BEGIN - type := types._type(args[1]); - CASE - WHEN type = 8 THEN -- list - RETURN types._list(array_cat( - types.array_reverse(args[2:array_length(args, 1)]), - types._valueToArray(args[1]))); - WHEN type = 9 THEN -- vector - RETURN types._vector(array_cat( - types._valueToArray(args[1]), - args[2:array_length(args, 1)])); - ELSE - RAISE EXCEPTION 'conj: called on non-sequence'; - END CASE; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.seq(args integer[]) RETURNS integer AS $$ -DECLARE - type integer; - vid integer; - str varchar; - chr varchar; - seq integer[]; -BEGIN - type := types._type(args[1]); - CASE - WHEN type = 8 THEN -- list - IF types._count(args[1]) = 0 THEN RETURN 0; END IF; -- nil - RETURN args[1]; - WHEN type = 9 THEN -- vector - IF types._count(args[1]) = 0 THEN RETURN 0; END IF; -- nil - -- clone and modify to a list - vid := types._clone(args[1]); - UPDATE types.value SET type_id = 8 WHERE value_id = vid; - RETURN vid; - WHEN type = 5 THEN -- string - str := types._valueToString(args[1]); - IF char_length(str) = 0 THEN RETURN 0; END IF; -- nil - FOREACH chr IN ARRAY regexp_split_to_array(str, '') LOOP - seq := array_append(seq, types._stringv(chr)); - END LOOP; - RETURN types._list(seq); - WHEN type = 0 THEN -- nil - RETURN 0; -- nil - ELSE - RAISE EXCEPTION 'seq: called on non-sequence'; - END CASE; -END; $$ LANGUAGE plpgsql; - - --- meta functions - -CREATE FUNCTION core.meta(args integer[]) RETURNS integer AS $$ -DECLARE - m integer; -BEGIN - SELECT meta_id INTO m FROM types.value WHERE value_id = args[1]; - IF m IS NULL THEN - RETURN 0; - ELSE - RETURN m; - END IF; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.with_meta(args integer[]) RETURNS integer AS $$ -DECLARE - vid integer; -BEGIN - vid := types._clone(args[1]); - UPDATE types.value SET meta_id = args[2] - WHERE value_id = vid; - RETURN vid; -END; $$ LANGUAGE plpgsql; - - - --- atom functions - -CREATE FUNCTION core.atom(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._atom(args[1]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.atom_Q(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._wraptf(types._atom_Q(args[1])); -END; $$ LANGUAGE plpgsql; - - -CREATE FUNCTION core.deref(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._deref(args[1]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.reset_BANG(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._reset_BANG(args[1], args[2]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION core.swap_BANG(args integer[]) RETURNS integer AS $$ -DECLARE - atm integer; - fargs integer[]; -BEGIN - atm := args[1]; - fargs := array_cat(ARRAY[types._deref(atm)], args[3:array_length(args, 1)]); - RETURN types._reset_BANG(atm, types._apply(args[2], fargs)); -END; $$ LANGUAGE plpgsql; - --- --------------------------------------------------------- - --- repl_env is environment 0 - -INSERT INTO envs.env (env_id, outer_id, data) - VALUES (0, NULL, hstore(ARRAY[ - '=', types._function('core.equal'), - 'throw', types._function('core.throw'), - - 'nil?', types._function('core.nil_Q'), - 'true?', types._function('core.true_Q'), - 'false?', types._function('core.false_Q'), - 'number?', types._function('core.number_Q'), - 'string?', types._function('core.string_Q'), - 'symbol', types._function('core.symbol'), - 'symbol?', types._function('core.symbol_Q'), - 'keyword', types._function('core.keyword'), - 'keyword?', types._function('core.keyword_Q'), - 'fn?', types._function('core.fn_Q'), - 'macro?', types._function('core.macro_Q'), - - 'pr-str', types._function('core.pr_str'), - 'str', types._function('core.str'), - 'prn', types._function('core.prn'), - 'println', types._function('core.println'), - 'read-string', types._function('core.read_string'), - 'readline', types._function('core.readline'), - 'slurp', types._function('core.slurp'), - - '<', types._function('core.lt'), - '<=', types._function('core.lte'), - '>', types._function('core.gt'), - '>=', types._function('core.gte'), - '+', types._function('core.add'), - '-', types._function('core.subtract'), - '*', types._function('core.multiply'), - '/', types._function('core.divide'), - 'time-ms', types._function('core.time_ms'), - - 'list', types._function('core.list'), - 'list?', types._function('core.list_Q'), - 'vector', types._function('core.vector'), - 'vector?', types._function('core.vector_Q'), - 'hash-map', types._function('core.hash_map'), - 'map?', types._function('core.map_Q'), - 'assoc', types._function('core.assoc'), - 'dissoc', types._function('core.dissoc'), - 'get', types._function('core.get'), - 'contains?', types._function('core.contains_Q'), - 'keys', types._function('core.keys'), - 'vals', types._function('core.vals'), - - 'sequential?', types._function('core.sequential_Q'), - 'cons', types._function('core.cons'), - 'concat', types._function('core.concat'), - 'vec', types._function('core.vec'), - 'nth', types._function('core.nth'), - 'first', types._function('core.first'), - 'rest', types._function('core.rest'), - 'empty?', types._function('core.empty_Q'), - 'count', types._function('core.count'), - 'apply', types._function('core.apply'), - 'map', types._function('core.map'), - - 'conj', types._function('core.conj'), - 'seq', types._function('core.seq'), - - 'meta', types._function('core.meta'), - 'with-meta', types._function('core.with_meta'), - 'atom', types._function('core.atom'), - 'atom?', types._function('core.atom_Q'), - 'deref', types._function('core.deref'), - 'reset!', types._function('core.reset_BANG'), - 'swap!', types._function('core.swap_BANG') - ])); +CREATE SCHEMA core; + +-- general functions + +CREATE FUNCTION core.equal(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._equal_Q(args[1], args[2])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.throw(args integer[]) RETURNS integer AS $$ +BEGIN + -- TODO: Only throws strings. Without subtransactions, all changes + -- to DB up to this point get rolled back so the object being + -- thrown dissapears. + RAISE EXCEPTION '%', printer.pr_str(args[1], false); +END; $$ LANGUAGE plpgsql; + + +-- scalar functions + +CREATE FUNCTION core.nil_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._nil_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.true_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._true_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.false_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._false_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.number_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._number_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.string_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._string_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.symbol(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._symbolv(types._valueToString(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.symbol_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._symbol_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.keyword(args integer[]) RETURNS integer AS $$ +BEGIN + IF types._keyword_Q(args[1]) THEN + RETURN args[1]; + ELSE + RETURN types._keywordv(types._valueToString(args[1])); + END IF; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.keyword_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._keyword_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.fn_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._fn_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.macro_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._macro_Q(args[1])); +END; $$ LANGUAGE plpgsql; + + +-- string functions + +CREATE FUNCTION core.pr_str(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._stringv(printer.pr_str_array(args, ' ', true)); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.str(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._stringv(printer.pr_str_array(args, '', false)); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.prn(args integer[]) RETURNS integer AS $$ +BEGIN + PERFORM io.writeline(printer.pr_str_array(args, ' ', true)); + RETURN 0; -- nil +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.println(args integer[]) RETURNS integer AS $$ +BEGIN + PERFORM io.writeline(printer.pr_str_array(args, ' ', false)); + RETURN 0; -- nil +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.read_string(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(types._valueToString(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.readline(args integer[]) RETURNS integer AS $$ +DECLARE + input varchar; +BEGIN + input := io.readline(types._valueToString(args[1])); + IF input IS NULL THEN + RETURN 0; -- nil + END IF; + RETURN types._stringv(rtrim(input, E'\n')); +END; $$ LANGUAGE plpgsql; + + +-- See: +-- http://shuber.io/reading-from-the-filesystem-with-postgres/ +CREATE FUNCTION core.slurp(args integer[]) RETURNS integer AS $$ +DECLARE + fname varchar; + tmp varchar; + cmd varchar; + lines varchar[]; + content varchar; +BEGIN + fname := types._valueToString(args[1]); + IF fname NOT LIKE '/%' THEN + fname := types._valueToString(envs.vget(0, '*PWD*')) || '/' || fname; + END IF; + + tmp := CAST(round(random()*1000000) AS varchar); + + EXECUTE format('CREATE TEMP TABLE %I (content text)', tmp); + cmd := format('sed ''s/\\/\\\\/g'' %L', fname); + EXECUTE format('COPY %I FROM PROGRAM %L', tmp, cmd); + EXECUTE format('SELECT ARRAY(SELECT content FROM %I)', tmp) INTO lines; + EXECUTE format('DROP TABLE %I', tmp); + + content := array_to_string(lines, E'\n') || E'\n'; + RETURN types._stringv(content); +END; $$ LANGUAGE plpgsql; + + +-- number functions + +-- integer comparison +CREATE FUNCTION core.intcmp(op varchar, args integer[]) RETURNS integer AS $$ +DECLARE a bigint; b bigint; result boolean; +BEGIN + SELECT val_int INTO a FROM types.value WHERE value_id = args[1]; + SELECT val_int INTO b FROM types.value WHERE value_id = args[2]; + EXECUTE format('SELECT $1 %s $2;', op) INTO result USING a, b; + RETURN types._wraptf(result); +END; $$ LANGUAGE plpgsql; + +-- integer operation +CREATE FUNCTION core.intop(op varchar, args integer[]) RETURNS integer AS $$ +DECLARE a bigint; b bigint; result bigint; +BEGIN + SELECT val_int INTO a FROM types.value WHERE value_id = args[1]; + SELECT val_int INTO b FROM types.value WHERE value_id = args[2]; + EXECUTE format('SELECT $1 %s $2;', op) INTO result USING a, b; + RETURN types._numToValue(result); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.lt(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN core.intcmp('<', args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.lte(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN core.intcmp('<=', args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.gt(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN core.intcmp('>', args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.gte(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN core.intcmp('>=', args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.add(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN core.intop('+', args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.subtract(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN core.intop('-', args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.multiply(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN core.intop('*', args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.divide(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN core.intop('/', args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.time_ms(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._numToValue( + CAST(date_part('epoch', clock_timestamp()) * 1000 AS bigint)); +END; $$ LANGUAGE plpgsql; + + +-- collection functions + +CREATE FUNCTION core.list(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._list(args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.list_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._list_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.vector(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._vector(args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.vector_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._vector_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.hash_map(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._hash_map(args); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.map_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._hash_map_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.assoc(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._assoc_BANG(types._clone(args[1]), + args[2:array_length(args, 1)]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.dissoc(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._dissoc_BANG(types._clone(args[1]), + args[2:array_length(args, 1)]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.get(args integer[]) RETURNS integer AS $$ +DECLARE + result integer; +BEGIN + IF types._type(args[1]) = 0 THEN -- nil + RETURN 0; + ELSE + result := types._get(args[1], types._valueToString(args[2])); + IF result IS NULL THEN RETURN 0; END IF; + RETURN result; + END IF; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.contains_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._contains_Q(args[1], + types._valueToString(args[2]))); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.keys(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._list(types._keys(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.vals(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._list(types._vals(args[1])); +END; $$ LANGUAGE plpgsql; + + + +-- sequence functions + +CREATE FUNCTION core.sequential_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._sequential_Q(args[1])); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.cons(args integer[]) RETURNS integer AS $$ +DECLARE + lst integer[]; +BEGIN + lst := array_prepend(args[1], types._valueToArray(args[2])); + RETURN types._list(lst); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.concat(args integer[]) RETURNS integer AS $$ +DECLARE + lst integer; + result integer[] = ARRAY[]::integer[]; +BEGIN + FOREACH lst IN ARRAY args LOOP + result := array_cat(result, types._valueToArray(lst)); + END LOOP; + RETURN types._list(result); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.vec(args integer[]) RETURNS integer AS $$ +BEGIN + IF types._vector_Q(args[1]) THEN + RETURN args[1]; + ELSE + RETURN types._vector(types._valueToArray(args[1])); + END IF; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.nth(args integer[]) RETURNS integer AS $$ +DECLARE + idx integer; +BEGIN + SELECT val_int INTO idx FROM types.value WHERE value_id = args[2]; + IF idx >= types._count(args[1]) THEN + RAISE EXCEPTION 'nth: index out of range'; + END IF; + RETURN types._nth(args[1], idx); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.first(args integer[]) RETURNS integer AS $$ +BEGIN + IF types._nil_Q(args[1]) THEN + RETURN 0; -- nil + ELSIF types._count(args[1]) = 0 THEN + RETURN 0; -- nil + ELSE + RETURN types._first(args[1]); + END IF; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.rest(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._rest(args[1]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.empty_Q(args integer[]) RETURNS integer AS $$ +BEGIN + IF types._sequential_Q(args[1]) AND types._count(args[1]) = 0 THEN + RETURN 2; + ELSE + RETURN 1; + END IF; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.count(args integer[]) RETURNS integer AS $$ +BEGIN + IF types._sequential_Q(args[1]) THEN + RETURN types._numToValue(types._count(args[1])); + ELSIF types._nil_Q(args[1]) THEN + RETURN types._numToValue(0); + ELSE + RAISE EXCEPTION 'count called on non-sequence'; + END IF; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.apply(args integer[]) RETURNS integer AS $$ +DECLARE + alen integer; + fargs integer[]; +BEGIN + alen := array_length(args, 1); + fargs := array_cat(args[2:alen-1], types._valueToArray(args[alen])); + RETURN types._apply(args[1], fargs); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.map(args integer[]) RETURNS integer AS $$ +DECLARE + x integer; + result integer[]; +BEGIN + FOREACH x IN ARRAY types._valueToArray(args[2]) + LOOP + result := array_append(result, types._apply(args[1], ARRAY[x])); + END LOOP; + return types._list(result); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.conj(args integer[]) RETURNS integer AS $$ +DECLARE + type integer; +BEGIN + type := types._type(args[1]); + CASE + WHEN type = 8 THEN -- list + RETURN types._list(array_cat( + types.array_reverse(args[2:array_length(args, 1)]), + types._valueToArray(args[1]))); + WHEN type = 9 THEN -- vector + RETURN types._vector(array_cat( + types._valueToArray(args[1]), + args[2:array_length(args, 1)])); + ELSE + RAISE EXCEPTION 'conj: called on non-sequence'; + END CASE; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.seq(args integer[]) RETURNS integer AS $$ +DECLARE + type integer; + vid integer; + str varchar; + chr varchar; + seq integer[]; +BEGIN + type := types._type(args[1]); + CASE + WHEN type = 8 THEN -- list + IF types._count(args[1]) = 0 THEN RETURN 0; END IF; -- nil + RETURN args[1]; + WHEN type = 9 THEN -- vector + IF types._count(args[1]) = 0 THEN RETURN 0; END IF; -- nil + -- clone and modify to a list + vid := types._clone(args[1]); + UPDATE types.value SET type_id = 8 WHERE value_id = vid; + RETURN vid; + WHEN type = 5 THEN -- string + str := types._valueToString(args[1]); + IF char_length(str) = 0 THEN RETURN 0; END IF; -- nil + FOREACH chr IN ARRAY regexp_split_to_array(str, '') LOOP + seq := array_append(seq, types._stringv(chr)); + END LOOP; + RETURN types._list(seq); + WHEN type = 0 THEN -- nil + RETURN 0; -- nil + ELSE + RAISE EXCEPTION 'seq: called on non-sequence'; + END CASE; +END; $$ LANGUAGE plpgsql; + + +-- meta functions + +CREATE FUNCTION core.meta(args integer[]) RETURNS integer AS $$ +DECLARE + m integer; +BEGIN + SELECT meta_id INTO m FROM types.value WHERE value_id = args[1]; + IF m IS NULL THEN + RETURN 0; + ELSE + RETURN m; + END IF; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.with_meta(args integer[]) RETURNS integer AS $$ +DECLARE + vid integer; +BEGIN + vid := types._clone(args[1]); + UPDATE types.value SET meta_id = args[2] + WHERE value_id = vid; + RETURN vid; +END; $$ LANGUAGE plpgsql; + + + +-- atom functions + +CREATE FUNCTION core.atom(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._atom(args[1]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.atom_Q(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._wraptf(types._atom_Q(args[1])); +END; $$ LANGUAGE plpgsql; + + +CREATE FUNCTION core.deref(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._deref(args[1]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.reset_BANG(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._reset_BANG(args[1], args[2]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION core.swap_BANG(args integer[]) RETURNS integer AS $$ +DECLARE + atm integer; + fargs integer[]; +BEGIN + atm := args[1]; + fargs := array_cat(ARRAY[types._deref(atm)], args[3:array_length(args, 1)]); + RETURN types._reset_BANG(atm, types._apply(args[2], fargs)); +END; $$ LANGUAGE plpgsql; + +-- --------------------------------------------------------- + +-- repl_env is environment 0 + +INSERT INTO envs.env (env_id, outer_id, data) + VALUES (0, NULL, hstore(ARRAY[ + '=', types._function('core.equal'), + 'throw', types._function('core.throw'), + + 'nil?', types._function('core.nil_Q'), + 'true?', types._function('core.true_Q'), + 'false?', types._function('core.false_Q'), + 'number?', types._function('core.number_Q'), + 'string?', types._function('core.string_Q'), + 'symbol', types._function('core.symbol'), + 'symbol?', types._function('core.symbol_Q'), + 'keyword', types._function('core.keyword'), + 'keyword?', types._function('core.keyword_Q'), + 'fn?', types._function('core.fn_Q'), + 'macro?', types._function('core.macro_Q'), + + 'pr-str', types._function('core.pr_str'), + 'str', types._function('core.str'), + 'prn', types._function('core.prn'), + 'println', types._function('core.println'), + 'read-string', types._function('core.read_string'), + 'readline', types._function('core.readline'), + 'slurp', types._function('core.slurp'), + + '<', types._function('core.lt'), + '<=', types._function('core.lte'), + '>', types._function('core.gt'), + '>=', types._function('core.gte'), + '+', types._function('core.add'), + '-', types._function('core.subtract'), + '*', types._function('core.multiply'), + '/', types._function('core.divide'), + 'time-ms', types._function('core.time_ms'), + + 'list', types._function('core.list'), + 'list?', types._function('core.list_Q'), + 'vector', types._function('core.vector'), + 'vector?', types._function('core.vector_Q'), + 'hash-map', types._function('core.hash_map'), + 'map?', types._function('core.map_Q'), + 'assoc', types._function('core.assoc'), + 'dissoc', types._function('core.dissoc'), + 'get', types._function('core.get'), + 'contains?', types._function('core.contains_Q'), + 'keys', types._function('core.keys'), + 'vals', types._function('core.vals'), + + 'sequential?', types._function('core.sequential_Q'), + 'cons', types._function('core.cons'), + 'concat', types._function('core.concat'), + 'vec', types._function('core.vec'), + 'nth', types._function('core.nth'), + 'first', types._function('core.first'), + 'rest', types._function('core.rest'), + 'empty?', types._function('core.empty_Q'), + 'count', types._function('core.count'), + 'apply', types._function('core.apply'), + 'map', types._function('core.map'), + + 'conj', types._function('core.conj'), + 'seq', types._function('core.seq'), + + 'meta', types._function('core.meta'), + 'with-meta', types._function('core.with_meta'), + 'atom', types._function('core.atom'), + 'atom?', types._function('core.atom_Q'), + 'deref', types._function('core.deref'), + 'reset!', types._function('core.reset_BANG'), + 'swap!', types._function('core.swap_BANG') + ])); diff --git a/impls/plpgsql/entrypoint.sh b/impls/plpgsql/entrypoint.sh index 6eaf5164b7..cff8645eab 100755 --- a/impls/plpgsql/entrypoint.sh +++ b/impls/plpgsql/entrypoint.sh @@ -1,25 +1,25 @@ -#!/bin/bash - -POSTGRES_SUDO_USER=${POSTGRES_SUDO_USER:-postgres} - -POPTS="" -while [[ ${1:0:1} = '-' ]]; do - POPTS="${POPTS}$1 $2" - shift; shift -done - -sudo --user=${POSTGRES_SUDO_USER} \ - bash -c "/usr/lib/postgresql/9.4/bin/postgres \ - -c config_file=/etc/postgresql/9.4/main/postgresql.conf \ - ${POPTS} >/var/log/postgresql/output.log 2>&1" & disown -h - -while ! ( echo "" > /dev/tcp/localhost/5432) 2>/dev/null; do - echo "Waiting for postgres to start" - sleep 1 -done - -if [ "${*}" ]; then - exec "${@}" -else - exec bash -fi +#!/bin/bash + +POSTGRES_SUDO_USER=${POSTGRES_SUDO_USER:-postgres} + +POPTS="" +while [[ ${1:0:1} = '-' ]]; do + POPTS="${POPTS}$1 $2" + shift; shift +done + +sudo --user=${POSTGRES_SUDO_USER} \ + bash -c "/usr/lib/postgresql/9.4/bin/postgres \ + -c config_file=/etc/postgresql/9.4/main/postgresql.conf \ + ${POPTS} >/var/log/postgresql/output.log 2>&1" & disown -h + +while ! ( echo "" > /dev/tcp/localhost/5432) 2>/dev/null; do + echo "Waiting for postgres to start" + sleep 1 +done + +if [ "${*}" ]; then + exec "${@}" +else + exec bash +fi diff --git a/impls/plpgsql/envs.sql b/impls/plpgsql/envs.sql index b856ba2071..917aef5311 100644 --- a/impls/plpgsql/envs.sql +++ b/impls/plpgsql/envs.sql @@ -1,133 +1,133 @@ --- --------------------------------------------------------- --- envs.sql - -CREATE SCHEMA envs - -- env table - CREATE SEQUENCE env_id_seq - CREATE TABLE env ( - env_id integer NOT NULL DEFAULT nextval('envs.env_id_seq'), - outer_id integer, - data hstore - ); - -ALTER TABLE envs.env ADD CONSTRAINT pk_env_id - PRIMARY KEY (env_id); --- drop sequence when table dropped -ALTER SEQUENCE envs.env_id_seq OWNED BY envs.env.env_id; -ALTER TABLE envs.env ADD CONSTRAINT fk_env_outer_id - FOREIGN KEY (outer_id) REFERENCES envs.env(env_id); - --- ----------------------- - --- envs.new -CREATE FUNCTION envs.new(outer_env integer) RETURNS integer AS $$ -DECLARE - e integer; -BEGIN - INSERT INTO envs.env (outer_id) VALUES (outer_env) - RETURNING env_id INTO e; - --RAISE NOTICE 'env_new: e: %, outer_env: %', e, outer_env; - RETURN e; -END; $$ LANGUAGE plpgsql; - --- envs.new with bindings -CREATE FUNCTION envs.new(outer_env integer, - binds integer, - exprs integer[]) - RETURNS integer AS $$ -DECLARE - bseq integer[]; - env integer; - i integer; - bind integer; - bsym varchar; - expr integer; -BEGIN - env := envs.new(outer_env); - bseq := types._valueToArray(binds); - FOR i IN 1 .. COALESCE(array_length(bseq, 1), 0) LOOP - bind := bseq[i]; - bsym := types._valueToString(bind); - expr := exprs[i]; - --RAISE NOTICE 'i: %, bind: %, expr: %', i, bind, expr; - IF bsym = '&' THEN - bind := bseq[i+1]; - PERFORM envs.set(env, bind, - types._list(exprs[i:array_length(exprs, 1)])); - RETURN env; - END IF; - PERFORM envs.vset(env, bsym, expr); - END LOOP; - RETURN env; -END; $$ LANGUAGE plpgsql; - - --- envs.vset --- like envs.set but takes a varchar key instead of value_id -CREATE FUNCTION envs.vset(env integer, name varchar, val integer) - RETURNS integer AS $$ -DECLARE - e integer = env; - d hstore; -BEGIN - SELECT data INTO d FROM envs.env WHERE env_id=e; - IF d IS NULL THEN - d := hstore(name, CAST(val AS varchar)); - ELSE - d := d || hstore(name, CAST(val AS varchar)); - END IF; - UPDATE envs.env SET data = d WHERE env_id=e; - RETURN val; -END; $$ LANGUAGE plpgsql; - - --- envs.set -CREATE FUNCTION envs.set(env integer, key integer, val integer) - RETURNS integer AS $$ -DECLARE - symkey varchar; -BEGIN - symkey := types._valueToString(key); - RETURN envs.vset(env, symkey, val); -END; $$ LANGUAGE plpgsql; - --- envs.find -CREATE FUNCTION envs.find(env integer, symkey varchar) RETURNS integer AS $$ -DECLARE - outer_id integer; - d hstore; - val integer; -BEGIN - SELECT e.data, e.outer_id INTO d, outer_id FROM envs.env e - WHERE e.env_id = env; - IF d ? symkey THEN - RETURN env; - ELSIF outer_id IS NOT NULL THEN - RETURN envs.find(outer_id, symkey); - ELSE - RETURN NULL; - END IF; -END; $$ LANGUAGE plpgsql; - - --- envs.vget -CREATE FUNCTION envs.vget(env integer, symkey varchar) RETURNS integer AS $$ -DECLARE - result integer; - e integer; -BEGIN - e := envs.find(env, symkey); - --RAISE NOTICE 'envs.find env: %, symkey: % -> e: %', env, symkey, e; - IF e IS NULL THEN - RAISE EXCEPTION '''%'' not found', symkey; - ELSE - SELECT data -> symkey INTO result FROM envs.env WHERE env_id = e; - END IF; - RETURN result; -END; $$ LANGUAGE plpgsql; - --- envs.get -CREATE FUNCTION envs.get(env integer, key integer) RETURNS integer AS $$ -BEGIN - RETURN envs.vget(env, types._valueToString(key)); -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- envs.sql + +CREATE SCHEMA envs + -- env table + CREATE SEQUENCE env_id_seq + CREATE TABLE env ( + env_id integer NOT NULL DEFAULT nextval('envs.env_id_seq'), + outer_id integer, + data hstore + ); + +ALTER TABLE envs.env ADD CONSTRAINT pk_env_id + PRIMARY KEY (env_id); +-- drop sequence when table dropped +ALTER SEQUENCE envs.env_id_seq OWNED BY envs.env.env_id; +ALTER TABLE envs.env ADD CONSTRAINT fk_env_outer_id + FOREIGN KEY (outer_id) REFERENCES envs.env(env_id); + +-- ----------------------- + +-- envs.new +CREATE FUNCTION envs.new(outer_env integer) RETURNS integer AS $$ +DECLARE + e integer; +BEGIN + INSERT INTO envs.env (outer_id) VALUES (outer_env) + RETURNING env_id INTO e; + --RAISE NOTICE 'env_new: e: %, outer_env: %', e, outer_env; + RETURN e; +END; $$ LANGUAGE plpgsql; + +-- envs.new with bindings +CREATE FUNCTION envs.new(outer_env integer, + binds integer, + exprs integer[]) + RETURNS integer AS $$ +DECLARE + bseq integer[]; + env integer; + i integer; + bind integer; + bsym varchar; + expr integer; +BEGIN + env := envs.new(outer_env); + bseq := types._valueToArray(binds); + FOR i IN 1 .. COALESCE(array_length(bseq, 1), 0) LOOP + bind := bseq[i]; + bsym := types._valueToString(bind); + expr := exprs[i]; + --RAISE NOTICE 'i: %, bind: %, expr: %', i, bind, expr; + IF bsym = '&' THEN + bind := bseq[i+1]; + PERFORM envs.set(env, bind, + types._list(exprs[i:array_length(exprs, 1)])); + RETURN env; + END IF; + PERFORM envs.vset(env, bsym, expr); + END LOOP; + RETURN env; +END; $$ LANGUAGE plpgsql; + + +-- envs.vset +-- like envs.set but takes a varchar key instead of value_id +CREATE FUNCTION envs.vset(env integer, name varchar, val integer) + RETURNS integer AS $$ +DECLARE + e integer = env; + d hstore; +BEGIN + SELECT data INTO d FROM envs.env WHERE env_id=e; + IF d IS NULL THEN + d := hstore(name, CAST(val AS varchar)); + ELSE + d := d || hstore(name, CAST(val AS varchar)); + END IF; + UPDATE envs.env SET data = d WHERE env_id=e; + RETURN val; +END; $$ LANGUAGE plpgsql; + + +-- envs.set +CREATE FUNCTION envs.set(env integer, key integer, val integer) + RETURNS integer AS $$ +DECLARE + symkey varchar; +BEGIN + symkey := types._valueToString(key); + RETURN envs.vset(env, symkey, val); +END; $$ LANGUAGE plpgsql; + +-- envs.find +CREATE FUNCTION envs.find(env integer, symkey varchar) RETURNS integer AS $$ +DECLARE + outer_id integer; + d hstore; + val integer; +BEGIN + SELECT e.data, e.outer_id INTO d, outer_id FROM envs.env e + WHERE e.env_id = env; + IF d ? symkey THEN + RETURN env; + ELSIF outer_id IS NOT NULL THEN + RETURN envs.find(outer_id, symkey); + ELSE + RETURN NULL; + END IF; +END; $$ LANGUAGE plpgsql; + + +-- envs.vget +CREATE FUNCTION envs.vget(env integer, symkey varchar) RETURNS integer AS $$ +DECLARE + result integer; + e integer; +BEGIN + e := envs.find(env, symkey); + --RAISE NOTICE 'envs.find env: %, symkey: % -> e: %', env, symkey, e; + IF e IS NULL THEN + RAISE EXCEPTION '''%'' not found', symkey; + ELSE + SELECT data -> symkey INTO result FROM envs.env WHERE env_id = e; + END IF; + RETURN result; +END; $$ LANGUAGE plpgsql; + +-- envs.get +CREATE FUNCTION envs.get(env integer, key integer) RETURNS integer AS $$ +BEGIN + RETURN envs.vget(env, types._valueToString(key)); +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/init.sql b/impls/plpgsql/init.sql index 07188d529c..3777f5b1df 100755 --- a/impls/plpgsql/init.sql +++ b/impls/plpgsql/init.sql @@ -1,13 +1,13 @@ --- --------------------------------------------------------- --- init.sql - --- Drop pre-existing schemas -DROP SCHEMA IF EXISTS io, types, reader, printer, envs, core, mal CASCADE; - --- Drop and recreate extensions -DROP EXTENSION IF EXISTS hstore; -CREATE EXTENSION hstore; - -DROP EXTENSION IF EXISTS dblink; -CREATE EXTENSION dblink; - +-- --------------------------------------------------------- +-- init.sql + +-- Drop pre-existing schemas +DROP SCHEMA IF EXISTS io, types, reader, printer, envs, core, mal CASCADE; + +-- Drop and recreate extensions +DROP EXTENSION IF EXISTS hstore; +CREATE EXTENSION hstore; + +DROP EXTENSION IF EXISTS dblink; +CREATE EXTENSION dblink; + diff --git a/impls/plpgsql/io.sql b/impls/plpgsql/io.sql index 4134956e7e..642a8892c6 100644 --- a/impls/plpgsql/io.sql +++ b/impls/plpgsql/io.sql @@ -1,224 +1,224 @@ --- dblink is necessary to be able to sub-transactions (autonomous --- transactions) to the stream table. This is necessary to be able to --- modify the stream table from the perspective of outside callers --- because actual code can be long-lived and it's direct updates will --- not be seen until the process completes. - -CREATE SCHEMA io - - CREATE TABLE stream ( - stream_id integer, - open boolean, - data varchar, - rl_prompt varchar -- prompt for readline input - ); - --- stdin -INSERT INTO io.stream (stream_id, open, data, rl_prompt) - VALUES (0, false, '', ''); --- stdout -INSERT INTO io.stream (stream_id, open, data, rl_prompt) - VALUES (1, false, '', ''); - --- --------------------------------------------------------- - -CREATE FUNCTION io.open(sid integer) RETURNS void AS $$ -DECLARE - query varchar; -BEGIN - --RAISE NOTICE 'io.open start'; - query := format('UPDATE io.stream - SET data = '''', rl_prompt = '''', open = true - WHERE stream_id = %L', sid); - PERFORM dblink('dbname=mal', query); - --RAISE NOTICE 'io.open done'; -END; $$ LANGUAGE 'plpgsql' STRICT; - -CREATE FUNCTION io.close(sid integer) RETURNS void AS $$ -DECLARE - query varchar; -BEGIN - --RAISE NOTICE 'io.close start'; - query := format('UPDATE io.stream - SET rl_prompt = '''', open = false - WHERE stream_id = %L', sid); - PERFORM dblink('dbname=mal', query); - --RAISE NOTICE 'io.close done'; -END; $$ LANGUAGE 'plpgsql' STRICT; - - --- called from read via dblink -CREATE FUNCTION io.__read(sid integer) RETURNS varchar AS $$ -DECLARE - input varchar; - isopen boolean; -BEGIN - LOCK io.stream; - SELECT data, open INTO input, isopen FROM io.stream - WHERE stream_id = sid; - IF input <> '' THEN - UPDATE io.stream SET data = '' WHERE stream_id = sid; - RETURN input; - END IF; - IF isopen = false THEN - RETURN NULL; - END IF; - RETURN input; -END; $$ LANGUAGE 'plpgsql' STRICT; - --- read: --- read from stream stream_id in stream table. Waits until there is --- either data to return or the stream closes (NULL data). Returns --- NULL when stream is closed. -CREATE FUNCTION io.read(sid integer DEFAULT 0) RETURNS varchar AS $$ -DECLARE - query varchar; - input varchar; - sleep real = 0.05; -BEGIN - -- poll / wait for input - query := format('SELECT io.__read(%L);', sid); - - WHILE true - LOOP - -- atomic get and set to empty - SELECT cur_data INTO input FROM dblink('dbname=mal', query) - AS t1(cur_data varchar); - IF input <> '' OR input IS NULL THEN - RETURN input; - END IF; - PERFORM pg_sleep(sleep); - IF sleep < 0.5 THEN - sleep := sleep * 1.1; -- backoff - END IF; - END LOOP; -END; $$ LANGUAGE 'plpgsql' STRICT; - --- read_or_error: --- similar to read, but throws exception when stream is closed -CREATE FUNCTION io.read_or_error(sid integer DEFAULT 0) RETURNS varchar AS $$ -DECLARE - input varchar; -BEGIN - input := io.read(sid); - IF input IS NULL THEN - raise EXCEPTION 'Stream ''%'' is closed', sid; - ELSE - RETURN input; - END IF; -END; $$ LANGUAGE 'plpgsql' STRICT; - - --- readline: --- set prompt and wait for readline style input on the stream -CREATE FUNCTION io.readline(prompt varchar, sid integer DEFAULT 0) - RETURNS varchar AS $$ -DECLARE - query varchar; -BEGIN - -- set prompt / request readline style input - IF sid = 0 THEN - PERFORM io.wait_flushed(1); - ELSIF sid = 1 THEN - PERFORM io.wait_flushed(0); - END IF; - query := format('LOCK io.stream; UPDATE io.stream SET rl_prompt = %L', - prompt); - PERFORM dblink('dbname=mal', query); - - RETURN io.read(sid); -END; $$ LANGUAGE 'plpgsql' STRICT; - -CREATE FUNCTION io.write(data varchar, sid integer DEFAULT 1) -RETURNS void AS $$ -DECLARE - query varchar; -BEGIN - query := format('LOCK io.stream; - UPDATE io.stream SET data = data || %L WHERE stream_id = %L', - data, sid); - --RAISE NOTICE 'write query: %', query; - PERFORM dblink('dbname=mal', query); -END; $$ LANGUAGE 'plpgsql' STRICT; - -CREATE FUNCTION io.writeline(data varchar, sid integer DEFAULT 1) -RETURNS void AS $$ -BEGIN - PERFORM io.write(data || E'\n', sid); -END; $$ LANGUAGE 'plpgsql' STRICT; - --- --------------------------------------------------------- - --- called from wait_rl_prompt via dblink -CREATE FUNCTION io.__wait_rl_prompt(sid integer) RETURNS varchar AS $$ -DECLARE - isopen boolean; - prompt varchar; - datas integer; -BEGIN - LOCK io.stream; - SELECT open, rl_prompt INTO isopen, prompt FROM io.stream - WHERE stream_id = sid; - SELECT count(stream_id) INTO datas FROM io.stream WHERE data <> ''; - - IF isopen = false THEN - return NULL; - --raise EXCEPTION 'Stream ''%'' is closed', sid; - END IF; - - IF datas = 0 AND prompt <> '' THEN - UPDATE io.stream SET rl_prompt = '' WHERE stream_id = sid; - -- There is pending data on some stream - RETURN prompt; - END IF; - RETURN ''; -- '' -> no input -END; $$ LANGUAGE 'plpgsql' STRICT; - --- wait_rl_prompt: --- wait for rl_prompt to be set on the given stream and return the --- rl_prompt value. Errors if stream is already closed. -CREATE FUNCTION io.wait_rl_prompt(sid integer DEFAULT 0) RETURNS varchar AS $$ -DECLARE - query varchar; - prompt varchar; - sleep real = 0.05; -BEGIN - query := format('SELECT io.__wait_rl_prompt(%L);', sid); - WHILE true - LOOP - SELECT rl_prompt INTO prompt FROM dblink('dbname=mal', query) - AS t1(rl_prompt varchar); - IF prompt IS NULL THEN - raise EXCEPTION 'Stream ''%'' is closed', sid; - END IF; - IF prompt <> '' THEN - sleep := 0.05; -- reset sleep timer - RETURN prompt; - END IF; - PERFORM pg_sleep(sleep); - IF sleep < 0.5 THEN - sleep := sleep * 1.1; -- backoff - END IF; - END LOOP; -END; $$ LANGUAGE 'plpgsql' STRICT; - -CREATE FUNCTION io.wait_flushed(sid integer DEFAULT 1) RETURNS void AS $$ -DECLARE - query varchar; - pending integer; - sleep real = 0.05; -BEGIN - query := format('SELECT count(stream_id) FROM io.stream - WHERE stream_id = %L AND data <> ''''', sid); - WHILE true - LOOP - SELECT p INTO pending FROM dblink('dbname=mal', query) - AS t1(p integer); - IF pending = 0 THEN RETURN; END IF; - PERFORM pg_sleep(sleep); - IF sleep < 0.5 THEN - sleep := sleep * 1.1; -- backoff - END IF; - END LOOP; -END; $$ LANGUAGE 'plpgsql' STRICT; - +-- dblink is necessary to be able to sub-transactions (autonomous +-- transactions) to the stream table. This is necessary to be able to +-- modify the stream table from the perspective of outside callers +-- because actual code can be long-lived and it's direct updates will +-- not be seen until the process completes. + +CREATE SCHEMA io + + CREATE TABLE stream ( + stream_id integer, + open boolean, + data varchar, + rl_prompt varchar -- prompt for readline input + ); + +-- stdin +INSERT INTO io.stream (stream_id, open, data, rl_prompt) + VALUES (0, false, '', ''); +-- stdout +INSERT INTO io.stream (stream_id, open, data, rl_prompt) + VALUES (1, false, '', ''); + +-- --------------------------------------------------------- + +CREATE FUNCTION io.open(sid integer) RETURNS void AS $$ +DECLARE + query varchar; +BEGIN + --RAISE NOTICE 'io.open start'; + query := format('UPDATE io.stream + SET data = '''', rl_prompt = '''', open = true + WHERE stream_id = %L', sid); + PERFORM dblink('dbname=mal', query); + --RAISE NOTICE 'io.open done'; +END; $$ LANGUAGE 'plpgsql' STRICT; + +CREATE FUNCTION io.close(sid integer) RETURNS void AS $$ +DECLARE + query varchar; +BEGIN + --RAISE NOTICE 'io.close start'; + query := format('UPDATE io.stream + SET rl_prompt = '''', open = false + WHERE stream_id = %L', sid); + PERFORM dblink('dbname=mal', query); + --RAISE NOTICE 'io.close done'; +END; $$ LANGUAGE 'plpgsql' STRICT; + + +-- called from read via dblink +CREATE FUNCTION io.__read(sid integer) RETURNS varchar AS $$ +DECLARE + input varchar; + isopen boolean; +BEGIN + LOCK io.stream; + SELECT data, open INTO input, isopen FROM io.stream + WHERE stream_id = sid; + IF input <> '' THEN + UPDATE io.stream SET data = '' WHERE stream_id = sid; + RETURN input; + END IF; + IF isopen = false THEN + RETURN NULL; + END IF; + RETURN input; +END; $$ LANGUAGE 'plpgsql' STRICT; + +-- read: +-- read from stream stream_id in stream table. Waits until there is +-- either data to return or the stream closes (NULL data). Returns +-- NULL when stream is closed. +CREATE FUNCTION io.read(sid integer DEFAULT 0) RETURNS varchar AS $$ +DECLARE + query varchar; + input varchar; + sleep real = 0.05; +BEGIN + -- poll / wait for input + query := format('SELECT io.__read(%L);', sid); + + WHILE true + LOOP + -- atomic get and set to empty + SELECT cur_data INTO input FROM dblink('dbname=mal', query) + AS t1(cur_data varchar); + IF input <> '' OR input IS NULL THEN + RETURN input; + END IF; + PERFORM pg_sleep(sleep); + IF sleep < 0.5 THEN + sleep := sleep * 1.1; -- backoff + END IF; + END LOOP; +END; $$ LANGUAGE 'plpgsql' STRICT; + +-- read_or_error: +-- similar to read, but throws exception when stream is closed +CREATE FUNCTION io.read_or_error(sid integer DEFAULT 0) RETURNS varchar AS $$ +DECLARE + input varchar; +BEGIN + input := io.read(sid); + IF input IS NULL THEN + raise EXCEPTION 'Stream ''%'' is closed', sid; + ELSE + RETURN input; + END IF; +END; $$ LANGUAGE 'plpgsql' STRICT; + + +-- readline: +-- set prompt and wait for readline style input on the stream +CREATE FUNCTION io.readline(prompt varchar, sid integer DEFAULT 0) + RETURNS varchar AS $$ +DECLARE + query varchar; +BEGIN + -- set prompt / request readline style input + IF sid = 0 THEN + PERFORM io.wait_flushed(1); + ELSIF sid = 1 THEN + PERFORM io.wait_flushed(0); + END IF; + query := format('LOCK io.stream; UPDATE io.stream SET rl_prompt = %L', + prompt); + PERFORM dblink('dbname=mal', query); + + RETURN io.read(sid); +END; $$ LANGUAGE 'plpgsql' STRICT; + +CREATE FUNCTION io.write(data varchar, sid integer DEFAULT 1) +RETURNS void AS $$ +DECLARE + query varchar; +BEGIN + query := format('LOCK io.stream; + UPDATE io.stream SET data = data || %L WHERE stream_id = %L', + data, sid); + --RAISE NOTICE 'write query: %', query; + PERFORM dblink('dbname=mal', query); +END; $$ LANGUAGE 'plpgsql' STRICT; + +CREATE FUNCTION io.writeline(data varchar, sid integer DEFAULT 1) +RETURNS void AS $$ +BEGIN + PERFORM io.write(data || E'\n', sid); +END; $$ LANGUAGE 'plpgsql' STRICT; + +-- --------------------------------------------------------- + +-- called from wait_rl_prompt via dblink +CREATE FUNCTION io.__wait_rl_prompt(sid integer) RETURNS varchar AS $$ +DECLARE + isopen boolean; + prompt varchar; + datas integer; +BEGIN + LOCK io.stream; + SELECT open, rl_prompt INTO isopen, prompt FROM io.stream + WHERE stream_id = sid; + SELECT count(stream_id) INTO datas FROM io.stream WHERE data <> ''; + + IF isopen = false THEN + return NULL; + --raise EXCEPTION 'Stream ''%'' is closed', sid; + END IF; + + IF datas = 0 AND prompt <> '' THEN + UPDATE io.stream SET rl_prompt = '' WHERE stream_id = sid; + -- There is pending data on some stream + RETURN prompt; + END IF; + RETURN ''; -- '' -> no input +END; $$ LANGUAGE 'plpgsql' STRICT; + +-- wait_rl_prompt: +-- wait for rl_prompt to be set on the given stream and return the +-- rl_prompt value. Errors if stream is already closed. +CREATE FUNCTION io.wait_rl_prompt(sid integer DEFAULT 0) RETURNS varchar AS $$ +DECLARE + query varchar; + prompt varchar; + sleep real = 0.05; +BEGIN + query := format('SELECT io.__wait_rl_prompt(%L);', sid); + WHILE true + LOOP + SELECT rl_prompt INTO prompt FROM dblink('dbname=mal', query) + AS t1(rl_prompt varchar); + IF prompt IS NULL THEN + raise EXCEPTION 'Stream ''%'' is closed', sid; + END IF; + IF prompt <> '' THEN + sleep := 0.05; -- reset sleep timer + RETURN prompt; + END IF; + PERFORM pg_sleep(sleep); + IF sleep < 0.5 THEN + sleep := sleep * 1.1; -- backoff + END IF; + END LOOP; +END; $$ LANGUAGE 'plpgsql' STRICT; + +CREATE FUNCTION io.wait_flushed(sid integer DEFAULT 1) RETURNS void AS $$ +DECLARE + query varchar; + pending integer; + sleep real = 0.05; +BEGIN + query := format('SELECT count(stream_id) FROM io.stream + WHERE stream_id = %L AND data <> ''''', sid); + WHILE true + LOOP + SELECT p INTO pending FROM dblink('dbname=mal', query) + AS t1(p integer); + IF pending = 0 THEN RETURN; END IF; + PERFORM pg_sleep(sleep); + IF sleep < 0.5 THEN + sleep := sleep * 1.1; -- backoff + END IF; + END LOOP; +END; $$ LANGUAGE 'plpgsql' STRICT; + diff --git a/impls/plpgsql/printer.sql b/impls/plpgsql/printer.sql index 83c423aed4..de39bd7aa2 100644 --- a/impls/plpgsql/printer.sql +++ b/impls/plpgsql/printer.sql @@ -1,111 +1,111 @@ --- --------------------------------------------------------- --- printer.sql - -CREATE SCHEMA printer; - -CREATE FUNCTION printer.pr_str_array(arr integer[], - sep varchar, print_readably boolean) - RETURNS varchar AS $$ -DECLARE - i integer; - res varchar[]; -BEGIN - IF array_length(arr, 1) > 0 THEN - FOR i IN array_lower(arr, 1) .. array_upper(arr, 1) - LOOP - res := array_append(res, printer.pr_str(arr[i], print_readably)); - END LOOP; - RETURN array_to_string(res, sep); - ELSE - RETURN ''; - END IF; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION printer.pr_str(ast integer, - print_readably boolean DEFAULT true) - RETURNS varchar AS $$ -DECLARE - type integer; - seq integer[]; - hash hstore; - cid integer; - vid integer; - pid integer; - str varchar; -BEGIN - -- RAISE NOTICE 'pr_str ast: %', ast; - SELECT type_id FROM types.value WHERE value_id = ast INTO type; - -- RAISE NOTICE 'pr_str type: %', type; - CASE - WHEN type = 0 THEN RETURN 'nil'; - WHEN type = 1 THEN RETURN 'false'; - WHEN type = 2 THEN RETURN 'true'; - WHEN type = 3 THEN -- integer - RETURN CAST((SELECT val_int - FROM types.value WHERE value_id = ast) as varchar); - WHEN type = 5 THEN -- string - str := types._valueToString(ast); - IF chr(CAST(x'7f' AS integer)) = substring(str FROM 1 FOR 1) THEN - RETURN ':' || substring(str FROM 2 FOR (char_length(str)-1)); - ELSIF print_readably THEN - str := replace(str, E'\\', '\\'); - str := replace(str, '"', '\"'); - str := replace(str, E'\n', '\n'); - RETURN '"' || str || '"'; - ELSE - RETURN str; - END IF; - WHEN type = 7 THEN -- symbol - RETURN types._valueToString(ast); - WHEN type = 8 THEN -- list - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - RETURN '(' || - array_to_string(array( - SELECT printer.pr_str(x, print_readably) - FROM unnest(seq) AS x), ' ') || - ')'; - END; - WHEN type = 9 THEN -- vector - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - RETURN '[' || - array_to_string(array( - SELECT printer.pr_str(x, print_readably) - FROM unnest(seq) AS x), ' ') || - ']'; - END; - WHEN type = 10 THEN -- hash-map - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - RETURN '{' || - array_to_string(array( - SELECT printer.pr_str(CAST(key AS integer), - print_readably) || ' ' || - printer.pr_str(CAST(value AS integer), - print_readably) - FROM each(hash)), ' ') || - '}'; - END; - WHEN type = 11 THEN -- native function - RETURN '#'; - WHEN type = 12 THEN -- mal function - BEGIN - SELECT ast_id, params_id - INTO vid, pid - FROM types.value WHERE value_id = ast; - RETURN '(fn* ' || printer.pr_str(pid, print_readably) || - ' ' || printer.pr_str(vid, print_readably) || ')'; - END; - WHEN type = 13 THEN -- atom - BEGIN - SELECT val_seq[1] INTO vid - FROM types.value WHERE value_id = ast; - RETURN '(atom ' || printer.pr_str(vid, print_readably) || ')'; - END; - ELSE - RETURN 'unknown'; - END CASE; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- printer.sql + +CREATE SCHEMA printer; + +CREATE FUNCTION printer.pr_str_array(arr integer[], + sep varchar, print_readably boolean) + RETURNS varchar AS $$ +DECLARE + i integer; + res varchar[]; +BEGIN + IF array_length(arr, 1) > 0 THEN + FOR i IN array_lower(arr, 1) .. array_upper(arr, 1) + LOOP + res := array_append(res, printer.pr_str(arr[i], print_readably)); + END LOOP; + RETURN array_to_string(res, sep); + ELSE + RETURN ''; + END IF; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION printer.pr_str(ast integer, + print_readably boolean DEFAULT true) + RETURNS varchar AS $$ +DECLARE + type integer; + seq integer[]; + hash hstore; + cid integer; + vid integer; + pid integer; + str varchar; +BEGIN + -- RAISE NOTICE 'pr_str ast: %', ast; + SELECT type_id FROM types.value WHERE value_id = ast INTO type; + -- RAISE NOTICE 'pr_str type: %', type; + CASE + WHEN type = 0 THEN RETURN 'nil'; + WHEN type = 1 THEN RETURN 'false'; + WHEN type = 2 THEN RETURN 'true'; + WHEN type = 3 THEN -- integer + RETURN CAST((SELECT val_int + FROM types.value WHERE value_id = ast) as varchar); + WHEN type = 5 THEN -- string + str := types._valueToString(ast); + IF chr(CAST(x'7f' AS integer)) = substring(str FROM 1 FOR 1) THEN + RETURN ':' || substring(str FROM 2 FOR (char_length(str)-1)); + ELSIF print_readably THEN + str := replace(str, E'\\', '\\'); + str := replace(str, '"', '\"'); + str := replace(str, E'\n', '\n'); + RETURN '"' || str || '"'; + ELSE + RETURN str; + END IF; + WHEN type = 7 THEN -- symbol + RETURN types._valueToString(ast); + WHEN type = 8 THEN -- list + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + RETURN '(' || + array_to_string(array( + SELECT printer.pr_str(x, print_readably) + FROM unnest(seq) AS x), ' ') || + ')'; + END; + WHEN type = 9 THEN -- vector + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + RETURN '[' || + array_to_string(array( + SELECT printer.pr_str(x, print_readably) + FROM unnest(seq) AS x), ' ') || + ']'; + END; + WHEN type = 10 THEN -- hash-map + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + RETURN '{' || + array_to_string(array( + SELECT printer.pr_str(CAST(key AS integer), + print_readably) || ' ' || + printer.pr_str(CAST(value AS integer), + print_readably) + FROM each(hash)), ' ') || + '}'; + END; + WHEN type = 11 THEN -- native function + RETURN '#'; + WHEN type = 12 THEN -- mal function + BEGIN + SELECT ast_id, params_id + INTO vid, pid + FROM types.value WHERE value_id = ast; + RETURN '(fn* ' || printer.pr_str(pid, print_readably) || + ' ' || printer.pr_str(vid, print_readably) || ')'; + END; + WHEN type = 13 THEN -- atom + BEGIN + SELECT val_seq[1] INTO vid + FROM types.value WHERE value_id = ast; + RETURN '(atom ' || printer.pr_str(vid, print_readably) || ')'; + END; + ELSE + RETURN 'unknown'; + END CASE; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/reader.sql b/impls/plpgsql/reader.sql index 1ac54b3f10..b4065e933a 100644 --- a/impls/plpgsql/reader.sql +++ b/impls/plpgsql/reader.sql @@ -1,188 +1,188 @@ --- --------------------------------------------------------- --- reader.sql - -CREATE SCHEMA reader; - -CREATE FUNCTION reader.tokenize(str varchar) RETURNS varchar[] AS $$ -DECLARE - re varchar = E'[[:space:] ,]*(~@|[\\[\\]{}()\'`~@]|"(?:[\\\\].|[^\\\\"])*"?|;[^\n]*|[^\\s \\[\\]{}()\'"`~@,;]*)'; -BEGIN - RETURN ARRAY(SELECT tok FROM - (SELECT (regexp_matches(str, re, 'g'))[1] AS tok) AS x - WHERE tok <> '' AND tok NOT LIKE ';%'); -END; $$ LANGUAGE plpgsql IMMUTABLE; - --- read_atom: --- takes a tokens array and position --- returns new position and value_id -CREATE FUNCTION reader.read_atom(tokens varchar[], - INOUT pos integer, OUT result integer) AS $$ -DECLARE - str_id integer; - str varchar; - token varchar; -BEGIN - token := tokens[pos]; - pos := pos + 1; - -- RAISE NOTICE 'read_atom: %', token; - IF token = 'nil' THEN -- nil - result := 0; - ELSIF token = 'false' THEN -- false - result := 1; - ELSIF token = 'true' THEN -- true - result := 2; - ELSIF token ~ '^-?[0-9][0-9]*$' THEN -- integer - -- integer - INSERT INTO types.value (type_id, val_int) - VALUES (3, CAST(token AS integer)) - RETURNING value_id INTO result; - ELSIF token ~ '^"(?:[\\\\].|[^\\\\"])*"' THEN -- string - -- string - str := substring(token FROM 2 FOR (char_length(token)-2)); - str := replace(str, '\\', chr(CAST(x'7f' AS integer))); - str := replace(str, '\"', '"'); - str := replace(str, '\n', E'\n'); - str := replace(str, chr(CAST(x'7f' AS integer)), E'\\'); - result := types._stringv(str); - ELSIF token ~ '^".*' THEN -- unclosed string - RAISE EXCEPTION 'expected ''"'', got EOF'; - ELSIF token ~ '^:.*' THEN -- keyword - -- keyword - result := types._keywordv(substring(token FROM 2 FOR (char_length(token)-1))); - ELSE - -- symbol - result := types._symbolv(token); - END IF; -END; $$ LANGUAGE plpgsql; - --- read_seq: --- takes a tokens array, type (8, 9, 10), first and last characters --- and position --- returns new position and value_id for a list (8), vector (9) or --- hash-map (10) -CREATE FUNCTION reader.read_seq(tokens varchar[], first varchar, last varchar, - INOUT p integer, OUT items integer[]) AS $$ -DECLARE - token varchar; - key varchar = NULL; - item_id integer; -BEGIN - token := tokens[p]; - p := p + 1; - IF token <> first THEN - RAISE EXCEPTION 'expected ''%'', got EOF', first; - END IF; - items := ARRAY[]::integer[]; - LOOP - IF p > array_length(tokens, 1) THEN - RAISE EXCEPTION 'expected ''%'', got EOF', last; - END IF; - token := tokens[p]; - IF token = last THEN EXIT; END IF; - SELECT * FROM reader.read_form(tokens, p) INTO p, item_id; - items := array_append(items, item_id); - END LOOP; - - p := p + 1; -END; $$ LANGUAGE plpgsql; - --- read_form: --- takes a tokens array and position --- returns new position and value_id -CREATE FUNCTION reader.read_form(tokens varchar[], - INOUT pos integer, OUT result integer) AS $$ -DECLARE - vid integer; - meta integer; - token varchar; -BEGIN - token := tokens[pos]; -- peek - CASE - WHEN token = '''' THEN - BEGIN - pos := pos + 1; - SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; - result := types._list(ARRAY[types._symbolv('quote'), vid]); - END; - WHEN token = '`' THEN - BEGIN - pos := pos + 1; - SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; - result := types._list(ARRAY[types._symbolv('quasiquote'), vid]); - END; - WHEN token = '~' THEN - BEGIN - pos := pos + 1; - SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; - result := types._list(ARRAY[types._symbolv('unquote'), vid]); - END; - WHEN token = '~@' THEN - BEGIN - pos := pos + 1; - SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; - result := types._list(ARRAY[types._symbolv('splice-unquote'), vid]); - END; - WHEN token = '^' THEN - BEGIN - pos := pos + 1; - SELECT * FROM reader.read_form(tokens, pos) INTO pos, meta; - SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; - result := types._list(ARRAY[types._symbolv('with-meta'), vid, meta]); - END; - WHEN token = '@' THEN - BEGIN - pos := pos + 1; - SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; - result := types._list(ARRAY[types._symbolv('deref'), vid]); - END; - - -- list - WHEN token = ')' THEN - RAISE EXCEPTION 'unexpected '')'''; - WHEN token = '(' THEN - BEGIN - SELECT p, types._list(items) - FROM reader.read_seq(tokens, '(', ')', pos) INTO pos, result; - END; - - -- vector - WHEN token = ']' THEN - RAISE EXCEPTION 'unexpected '']'''; - WHEN token = '[' THEN - BEGIN - SELECT p, types._vector(items) - FROM reader.read_seq(tokens, '[', ']', pos) INTO pos, result; - END; - - -- hash-map - WHEN token = '}' THEN - RAISE EXCEPTION 'unexpected ''}'''; - WHEN token = '{' THEN - BEGIN - SELECT p, types._hash_map(items) - FROM reader.read_seq(tokens, '{', '}', pos) INTO pos, result; - END; - - -- - ELSE - SELECT * FROM reader.read_atom(tokens, pos) INTO pos, result; - END CASE; -END; $$ LANGUAGE plpgsql; - --- read_str: --- takes a string --- returns a new value_id -CREATE FUNCTION reader.read_str(str varchar) RETURNS integer AS $$ -DECLARE - tokens varchar[]; - pos integer; - ast integer; -BEGIN - tokens := reader.tokenize(str); - -- RAISE NOTICE 'read_str first: %', tokens[1]; - pos := 1; - SELECT * FROM reader.read_form(tokens, pos) INTO pos, ast; - -- RAISE NOTICE 'pos after read_atom: %', pos; - RETURN ast; -END; $$ LANGUAGE plpgsql; - +-- --------------------------------------------------------- +-- reader.sql + +CREATE SCHEMA reader; + +CREATE FUNCTION reader.tokenize(str varchar) RETURNS varchar[] AS $$ +DECLARE + re varchar = E'[[:space:] ,]*(~@|[\\[\\]{}()\'`~@]|"(?:[\\\\].|[^\\\\"])*"?|;[^\n]*|[^\\s \\[\\]{}()\'"`~@,;]*)'; +BEGIN + RETURN ARRAY(SELECT tok FROM + (SELECT (regexp_matches(str, re, 'g'))[1] AS tok) AS x + WHERE tok <> '' AND tok NOT LIKE ';%'); +END; $$ LANGUAGE plpgsql IMMUTABLE; + +-- read_atom: +-- takes a tokens array and position +-- returns new position and value_id +CREATE FUNCTION reader.read_atom(tokens varchar[], + INOUT pos integer, OUT result integer) AS $$ +DECLARE + str_id integer; + str varchar; + token varchar; +BEGIN + token := tokens[pos]; + pos := pos + 1; + -- RAISE NOTICE 'read_atom: %', token; + IF token = 'nil' THEN -- nil + result := 0; + ELSIF token = 'false' THEN -- false + result := 1; + ELSIF token = 'true' THEN -- true + result := 2; + ELSIF token ~ '^-?[0-9][0-9]*$' THEN -- integer + -- integer + INSERT INTO types.value (type_id, val_int) + VALUES (3, CAST(token AS integer)) + RETURNING value_id INTO result; + ELSIF token ~ '^"(?:[\\\\].|[^\\\\"])*"' THEN -- string + -- string + str := substring(token FROM 2 FOR (char_length(token)-2)); + str := replace(str, '\\', chr(CAST(x'7f' AS integer))); + str := replace(str, '\"', '"'); + str := replace(str, '\n', E'\n'); + str := replace(str, chr(CAST(x'7f' AS integer)), E'\\'); + result := types._stringv(str); + ELSIF token ~ '^".*' THEN -- unclosed string + RAISE EXCEPTION 'expected ''"'', got EOF'; + ELSIF token ~ '^:.*' THEN -- keyword + -- keyword + result := types._keywordv(substring(token FROM 2 FOR (char_length(token)-1))); + ELSE + -- symbol + result := types._symbolv(token); + END IF; +END; $$ LANGUAGE plpgsql; + +-- read_seq: +-- takes a tokens array, type (8, 9, 10), first and last characters +-- and position +-- returns new position and value_id for a list (8), vector (9) or +-- hash-map (10) +CREATE FUNCTION reader.read_seq(tokens varchar[], first varchar, last varchar, + INOUT p integer, OUT items integer[]) AS $$ +DECLARE + token varchar; + key varchar = NULL; + item_id integer; +BEGIN + token := tokens[p]; + p := p + 1; + IF token <> first THEN + RAISE EXCEPTION 'expected ''%'', got EOF', first; + END IF; + items := ARRAY[]::integer[]; + LOOP + IF p > array_length(tokens, 1) THEN + RAISE EXCEPTION 'expected ''%'', got EOF', last; + END IF; + token := tokens[p]; + IF token = last THEN EXIT; END IF; + SELECT * FROM reader.read_form(tokens, p) INTO p, item_id; + items := array_append(items, item_id); + END LOOP; + + p := p + 1; +END; $$ LANGUAGE plpgsql; + +-- read_form: +-- takes a tokens array and position +-- returns new position and value_id +CREATE FUNCTION reader.read_form(tokens varchar[], + INOUT pos integer, OUT result integer) AS $$ +DECLARE + vid integer; + meta integer; + token varchar; +BEGIN + token := tokens[pos]; -- peek + CASE + WHEN token = '''' THEN + BEGIN + pos := pos + 1; + SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; + result := types._list(ARRAY[types._symbolv('quote'), vid]); + END; + WHEN token = '`' THEN + BEGIN + pos := pos + 1; + SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; + result := types._list(ARRAY[types._symbolv('quasiquote'), vid]); + END; + WHEN token = '~' THEN + BEGIN + pos := pos + 1; + SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; + result := types._list(ARRAY[types._symbolv('unquote'), vid]); + END; + WHEN token = '~@' THEN + BEGIN + pos := pos + 1; + SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; + result := types._list(ARRAY[types._symbolv('splice-unquote'), vid]); + END; + WHEN token = '^' THEN + BEGIN + pos := pos + 1; + SELECT * FROM reader.read_form(tokens, pos) INTO pos, meta; + SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; + result := types._list(ARRAY[types._symbolv('with-meta'), vid, meta]); + END; + WHEN token = '@' THEN + BEGIN + pos := pos + 1; + SELECT * FROM reader.read_form(tokens, pos) INTO pos, vid; + result := types._list(ARRAY[types._symbolv('deref'), vid]); + END; + + -- list + WHEN token = ')' THEN + RAISE EXCEPTION 'unexpected '')'''; + WHEN token = '(' THEN + BEGIN + SELECT p, types._list(items) + FROM reader.read_seq(tokens, '(', ')', pos) INTO pos, result; + END; + + -- vector + WHEN token = ']' THEN + RAISE EXCEPTION 'unexpected '']'''; + WHEN token = '[' THEN + BEGIN + SELECT p, types._vector(items) + FROM reader.read_seq(tokens, '[', ']', pos) INTO pos, result; + END; + + -- hash-map + WHEN token = '}' THEN + RAISE EXCEPTION 'unexpected ''}'''; + WHEN token = '{' THEN + BEGIN + SELECT p, types._hash_map(items) + FROM reader.read_seq(tokens, '{', '}', pos) INTO pos, result; + END; + + -- + ELSE + SELECT * FROM reader.read_atom(tokens, pos) INTO pos, result; + END CASE; +END; $$ LANGUAGE plpgsql; + +-- read_str: +-- takes a string +-- returns a new value_id +CREATE FUNCTION reader.read_str(str varchar) RETURNS integer AS $$ +DECLARE + tokens varchar[]; + pos integer; + ast integer; +BEGIN + tokens := reader.tokenize(str); + -- RAISE NOTICE 'read_str first: %', tokens[1]; + pos := 1; + SELECT * FROM reader.read_form(tokens, pos) INTO pos, ast; + -- RAISE NOTICE 'pos after read_atom: %', pos; + RETURN ast; +END; $$ LANGUAGE plpgsql; + diff --git a/impls/plpgsql/run b/impls/plpgsql/run index 8613ff915a..0ce19c2bcf 100755 --- a/impls/plpgsql/run +++ b/impls/plpgsql/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/wrap.sh $(dirname $0)/${STEP:-stepA_mal}.sql "${@}" +#!/bin/bash +exec $(dirname $0)/wrap.sh $(dirname $0)/${STEP:-stepA_mal}.sql "${@}" diff --git a/impls/plpgsql/step0_repl.sql b/impls/plpgsql/step0_repl.sql index 2c8e8747ee..1fb8567fd6 100644 --- a/impls/plpgsql/step0_repl.sql +++ b/impls/plpgsql/step0_repl.sql @@ -1,59 +1,59 @@ --- --------------------------------------------------------- --- step0_repl.sql - -\i init.sql -\i io.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN line; -END; $$ LANGUAGE plpgsql; - --- eval -CREATE FUNCTION mal.EVAL(ast varchar, env varchar) RETURNS varchar AS $$ -BEGIN - RETURN ast; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp varchar) RETURNS varchar AS $$ -BEGIN - RETURN exp; -END; $$ LANGUAGE plpgsql; - - --- repl - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), '')); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; -BEGIN - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step0_repl.sql + +\i init.sql +\i io.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN line; +END; $$ LANGUAGE plpgsql; + +-- eval +CREATE FUNCTION mal.EVAL(ast varchar, env varchar) RETURNS varchar AS $$ +BEGIN + RETURN ast; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp varchar) RETURNS varchar AS $$ +BEGIN + RETURN exp; +END; $$ LANGUAGE plpgsql; + + +-- repl + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), '')); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; +BEGIN + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/step1_read_print.sql b/impls/plpgsql/step1_read_print.sql index 5138fa8980..40797b72f9 100644 --- a/impls/plpgsql/step1_read_print.sql +++ b/impls/plpgsql/step1_read_print.sql @@ -1,62 +1,62 @@ --- --------------------------------------------------------- --- step1_read_print.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval -CREATE FUNCTION mal.EVAL(ast integer, env varchar) RETURNS integer AS $$ -BEGIN - RETURN ast; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), '')); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; -BEGIN - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step1_read_print.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval +CREATE FUNCTION mal.EVAL(ast integer, env varchar) RETURNS integer AS $$ +BEGIN + RETURN ast; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), '')); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; +BEGIN + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/step2_eval.sql b/impls/plpgsql/step2_eval.sql index ba818ec27f..e20938ee4c 100644 --- a/impls/plpgsql/step2_eval.sql +++ b/impls/plpgsql/step2_eval.sql @@ -1,162 +1,162 @@ --- --------------------------------------------------------- --- step2_eval.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval -CREATE FUNCTION mal.eval_ast(ast integer, env hstore) RETURNS integer AS $$ -DECLARE - type integer; - symkey varchar; - seq integer[]; - eseq integer[]; - hash hstore; - ehash hstore; - kv RECORD; - e integer; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 7 THEN - BEGIN - symkey := types._valueToString(ast); - IF env ? symkey THEN - result := env -> symkey; - ELSE - RAISE EXCEPTION '''%'' not found', symkey; - END IF; - END; - WHEN type IN (8, 9) THEN - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - -- Evaluate each entry creating a new sequence - FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP - eseq[i] := mal.EVAL(seq[i], env); - END LOOP; - INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) - RETURNING value_id INTO result; - END; - WHEN type = 10 THEN - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - -- Evaluate each value for every key/value - FOR kv IN SELECT * FROM each(hash) LOOP - e := mal.EVAL(CAST(kv.value AS integer), env); - IF ehash IS NULL THEN - ehash := hstore(kv.key, CAST(e AS varchar)); - ELSE - ehash := ehash || hstore(kv.key, CAST(e AS varchar)); - END IF; - END LOOP; - INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) - RETURNING value_id INTO result; - END; - ELSE - result := ast; - END CASE; - - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.EVAL(ast integer, env hstore) RETURNS integer AS $$ -DECLARE - type integer; - el integer; - fname varchar; - args integer[]; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - IF types._count(ast) = 0 THEN - RETURN ast; - END IF; - - el := mal.eval_ast(ast, env); - SELECT val_string INTO fname FROM types.value - WHERE value_id = types._first(el); - args := types._restArray(el); - EXECUTE format('SELECT %s($1);', fname) INTO result USING args; - RETURN result; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - -CREATE FUNCTION mal.intop(op varchar, args integer[]) RETURNS integer AS $$ -DECLARE a integer; b integer; result integer; -BEGIN - SELECT val_int INTO a FROM types.value WHERE value_id = args[1]; - SELECT val_int INTO b FROM types.value WHERE value_id = args[2]; - EXECUTE format('INSERT INTO types.value (type_id, val_int) - VALUES (3, $1 %s $2) - RETURNING value_id;', op) INTO result USING a, b; - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.add(args integer[]) RETURNS integer AS $$ -BEGIN RETURN mal.intop('+', args); END; $$ LANGUAGE plpgsql; -CREATE FUNCTION mal.subtract(args integer[]) RETURNS integer AS $$ -BEGIN RETURN mal.intop('-', args); END; $$ LANGUAGE plpgsql; -CREATE FUNCTION mal.multiply(args integer[]) RETURNS integer AS $$ -BEGIN RETURN mal.intop('*', args); END; $$ LANGUAGE plpgsql; -CREATE FUNCTION mal.divide(args integer[]) RETURNS integer AS $$ -BEGIN RETURN mal.intop('/', args); END; $$ LANGUAGE plpgsql; - - -CREATE FUNCTION mal.REP(env hstore, line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), env)); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ -DECLARE - repl_env hstore; - line varchar; - output varchar; -BEGIN - repl_env := hstore(ARRAY[ - '+', types._function('mal.add'), - '-', types._function('mal.subtract'), - '*', types._function('mal.multiply'), - '/', types._function('mal.divide')]); - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(repl_env, line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step2_eval.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval +CREATE FUNCTION mal.eval_ast(ast integer, env hstore) RETURNS integer AS $$ +DECLARE + type integer; + symkey varchar; + seq integer[]; + eseq integer[]; + hash hstore; + ehash hstore; + kv RECORD; + e integer; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 7 THEN + BEGIN + symkey := types._valueToString(ast); + IF env ? symkey THEN + result := env -> symkey; + ELSE + RAISE EXCEPTION '''%'' not found', symkey; + END IF; + END; + WHEN type IN (8, 9) THEN + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + -- Evaluate each entry creating a new sequence + FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP + eseq[i] := mal.EVAL(seq[i], env); + END LOOP; + INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) + RETURNING value_id INTO result; + END; + WHEN type = 10 THEN + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + -- Evaluate each value for every key/value + FOR kv IN SELECT * FROM each(hash) LOOP + e := mal.EVAL(CAST(kv.value AS integer), env); + IF ehash IS NULL THEN + ehash := hstore(kv.key, CAST(e AS varchar)); + ELSE + ehash := ehash || hstore(kv.key, CAST(e AS varchar)); + END IF; + END LOOP; + INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) + RETURNING value_id INTO result; + END; + ELSE + result := ast; + END CASE; + + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.EVAL(ast integer, env hstore) RETURNS integer AS $$ +DECLARE + type integer; + el integer; + fname varchar; + args integer[]; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + IF types._count(ast) = 0 THEN + RETURN ast; + END IF; + + el := mal.eval_ast(ast, env); + SELECT val_string INTO fname FROM types.value + WHERE value_id = types._first(el); + args := types._restArray(el); + EXECUTE format('SELECT %s($1);', fname) INTO result USING args; + RETURN result; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +CREATE FUNCTION mal.intop(op varchar, args integer[]) RETURNS integer AS $$ +DECLARE a integer; b integer; result integer; +BEGIN + SELECT val_int INTO a FROM types.value WHERE value_id = args[1]; + SELECT val_int INTO b FROM types.value WHERE value_id = args[2]; + EXECUTE format('INSERT INTO types.value (type_id, val_int) + VALUES (3, $1 %s $2) + RETURNING value_id;', op) INTO result USING a, b; + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.add(args integer[]) RETURNS integer AS $$ +BEGIN RETURN mal.intop('+', args); END; $$ LANGUAGE plpgsql; +CREATE FUNCTION mal.subtract(args integer[]) RETURNS integer AS $$ +BEGIN RETURN mal.intop('-', args); END; $$ LANGUAGE plpgsql; +CREATE FUNCTION mal.multiply(args integer[]) RETURNS integer AS $$ +BEGIN RETURN mal.intop('*', args); END; $$ LANGUAGE plpgsql; +CREATE FUNCTION mal.divide(args integer[]) RETURNS integer AS $$ +BEGIN RETURN mal.intop('/', args); END; $$ LANGUAGE plpgsql; + + +CREATE FUNCTION mal.REP(env hstore, line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), env)); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ +DECLARE + repl_env hstore; + line varchar; + output varchar; +BEGIN + repl_env := hstore(ARRAY[ + '+', types._function('mal.add'), + '-', types._function('mal.subtract'), + '*', types._function('mal.multiply'), + '/', types._function('mal.divide')]); + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(repl_env, line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/step3_env.sql b/impls/plpgsql/step3_env.sql index 085c41b598..b88317a6ef 100644 --- a/impls/plpgsql/step3_env.sql +++ b/impls/plpgsql/step3_env.sql @@ -1,196 +1,196 @@ --- --------------------------------------------------------- --- step3_env.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql -\i envs.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval -CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - seq integer[]; - eseq integer[]; - hash hstore; - ehash hstore; - kv RECORD; - e integer; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 7 THEN - BEGIN - result := envs.get(env, ast); - END; - WHEN type IN (8, 9) THEN - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - -- Evaluate each entry creating a new sequence - FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP - eseq[i] := mal.EVAL(seq[i], env); - END LOOP; - INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) - RETURNING value_id INTO result; - END; - WHEN type = 10 THEN - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - -- Evaluate each value for every key/value - FOR kv IN SELECT * FROM each(hash) LOOP - e := mal.EVAL(CAST(kv.value AS integer), env); - IF ehash IS NULL THEN - ehash := hstore(kv.key, CAST(e AS varchar)); - ELSE - ehash := ehash || hstore(kv.key, CAST(e AS varchar)); - END IF; - END LOOP; - INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) - RETURNING value_id INTO result; - END; - ELSE - result := ast; - END CASE; - - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; - a0sym varchar; - a1 integer; - let_env integer; - idx integer; - binds integer[]; - el integer; - fname varchar; - args integer[]; - result integer; -BEGIN - -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - IF types._count(ast) = 0 THEN - RETURN ast; - END IF; - - a0 := types._first(ast); - IF types._symbol_Q(a0) THEN - a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - BEGIN - RETURN envs.set(env, types._nth(ast, 1), - mal.EVAL(types._nth(ast, 2), env)); - END; - WHEN a0sym = 'let*' THEN - BEGIN - let_env := envs.new(env); - a1 := types._nth(ast, 1); - binds := (SELECT val_seq FROM types.value WHERE value_id = a1); - idx := 1; - WHILE idx < array_length(binds, 1) LOOP - PERFORM envs.set(let_env, binds[idx], - mal.EVAL(binds[idx+1], let_env)); - idx := idx + 2; - END LOOP; - RETURN mal.EVAL(types._nth(ast, 2), let_env); - END; - ELSE - BEGIN - el := mal.eval_ast(ast, env); - SELECT val_string INTO fname FROM types.value - WHERE value_id = types._first(el); - args := types._restArray(el); - EXECUTE format('SELECT %s($1);', fname) - INTO result USING args; - RETURN result; - END; - END CASE; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - -CREATE FUNCTION mal.intop(op varchar, args integer[]) RETURNS integer AS $$ -DECLARE a integer; b integer; result integer; -BEGIN - SELECT val_int INTO a FROM types.value WHERE value_id = args[1]; - SELECT val_int INTO b FROM types.value WHERE value_id = args[2]; - EXECUTE format('INSERT INTO types.value (type_id, val_int) - VALUES (3, $1 %s $2) - RETURNING value_id;', op) INTO result USING a, b; - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.add(args integer[]) RETURNS integer AS $$ -BEGIN RETURN mal.intop('+', args); END; $$ LANGUAGE plpgsql; -CREATE FUNCTION mal.subtract(args integer[]) RETURNS integer AS $$ -BEGIN RETURN mal.intop('-', args); END; $$ LANGUAGE plpgsql; -CREATE FUNCTION mal.multiply(args integer[]) RETURNS integer AS $$ -BEGIN RETURN mal.intop('*', args); END; $$ LANGUAGE plpgsql; -CREATE FUNCTION mal.divide(args integer[]) RETURNS integer AS $$ -BEGIN RETURN mal.intop('/', args); END; $$ LANGUAGE plpgsql; - --- repl_env is environment 0 -INSERT INTO envs.env (env_id, outer_id, data) - VALUES (0, NULL, hstore(ARRAY['+', types._function('mal.add'), - '-', types._function('mal.subtract'), - '*', types._function('mal.multiply'), - '/', types._function('mal.divide')])); - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; -BEGIN - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step3_env.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql +\i envs.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval +CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + seq integer[]; + eseq integer[]; + hash hstore; + ehash hstore; + kv RECORD; + e integer; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 7 THEN + BEGIN + result := envs.get(env, ast); + END; + WHEN type IN (8, 9) THEN + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + -- Evaluate each entry creating a new sequence + FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP + eseq[i] := mal.EVAL(seq[i], env); + END LOOP; + INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) + RETURNING value_id INTO result; + END; + WHEN type = 10 THEN + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + -- Evaluate each value for every key/value + FOR kv IN SELECT * FROM each(hash) LOOP + e := mal.EVAL(CAST(kv.value AS integer), env); + IF ehash IS NULL THEN + ehash := hstore(kv.key, CAST(e AS varchar)); + ELSE + ehash := ehash || hstore(kv.key, CAST(e AS varchar)); + END IF; + END LOOP; + INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) + RETURNING value_id INTO result; + END; + ELSE + result := ast; + END CASE; + + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; + a0sym varchar; + a1 integer; + let_env integer; + idx integer; + binds integer[]; + el integer; + fname varchar; + args integer[]; + result integer; +BEGIN + -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + IF types._count(ast) = 0 THEN + RETURN ast; + END IF; + + a0 := types._first(ast); + IF types._symbol_Q(a0) THEN + a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + BEGIN + RETURN envs.set(env, types._nth(ast, 1), + mal.EVAL(types._nth(ast, 2), env)); + END; + WHEN a0sym = 'let*' THEN + BEGIN + let_env := envs.new(env); + a1 := types._nth(ast, 1); + binds := (SELECT val_seq FROM types.value WHERE value_id = a1); + idx := 1; + WHILE idx < array_length(binds, 1) LOOP + PERFORM envs.set(let_env, binds[idx], + mal.EVAL(binds[idx+1], let_env)); + idx := idx + 2; + END LOOP; + RETURN mal.EVAL(types._nth(ast, 2), let_env); + END; + ELSE + BEGIN + el := mal.eval_ast(ast, env); + SELECT val_string INTO fname FROM types.value + WHERE value_id = types._first(el); + args := types._restArray(el); + EXECUTE format('SELECT %s($1);', fname) + INTO result USING args; + RETURN result; + END; + END CASE; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +CREATE FUNCTION mal.intop(op varchar, args integer[]) RETURNS integer AS $$ +DECLARE a integer; b integer; result integer; +BEGIN + SELECT val_int INTO a FROM types.value WHERE value_id = args[1]; + SELECT val_int INTO b FROM types.value WHERE value_id = args[2]; + EXECUTE format('INSERT INTO types.value (type_id, val_int) + VALUES (3, $1 %s $2) + RETURNING value_id;', op) INTO result USING a, b; + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.add(args integer[]) RETURNS integer AS $$ +BEGIN RETURN mal.intop('+', args); END; $$ LANGUAGE plpgsql; +CREATE FUNCTION mal.subtract(args integer[]) RETURNS integer AS $$ +BEGIN RETURN mal.intop('-', args); END; $$ LANGUAGE plpgsql; +CREATE FUNCTION mal.multiply(args integer[]) RETURNS integer AS $$ +BEGIN RETURN mal.intop('*', args); END; $$ LANGUAGE plpgsql; +CREATE FUNCTION mal.divide(args integer[]) RETURNS integer AS $$ +BEGIN RETURN mal.intop('/', args); END; $$ LANGUAGE plpgsql; + +-- repl_env is environment 0 +INSERT INTO envs.env (env_id, outer_id, data) + VALUES (0, NULL, hstore(ARRAY['+', types._function('mal.add'), + '-', types._function('mal.subtract'), + '*', types._function('mal.multiply'), + '/', types._function('mal.divide')])); + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; +BEGIN + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/step4_if_fn_do.sql b/impls/plpgsql/step4_if_fn_do.sql index 904e44126e..aa9216b6c5 100644 --- a/impls/plpgsql/step4_if_fn_do.sql +++ b/impls/plpgsql/step4_if_fn_do.sql @@ -1,213 +1,213 @@ --- --------------------------------------------------------- --- step4_if_fn_do.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql -\i envs.sql -\i core.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval -CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - seq integer[]; - eseq integer[]; - hash hstore; - ehash hstore; - kv RECORD; - e integer; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 7 THEN - BEGIN - result := envs.get(env, ast); - END; - WHEN type IN (8, 9) THEN - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - -- Evaluate each entry creating a new sequence - FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP - eseq[i] := mal.EVAL(seq[i], env); - END LOOP; - INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) - RETURNING value_id INTO result; - END; - WHEN type = 10 THEN - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - -- Evaluate each value for every key/value - FOR kv IN SELECT * FROM each(hash) LOOP - e := mal.EVAL(CAST(kv.value AS integer), env); - IF ehash IS NULL THEN - ehash := hstore(kv.key, CAST(e AS varchar)); - ELSE - ehash := ehash || hstore(kv.key, CAST(e AS varchar)); - END IF; - END LOOP; - INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) - RETURNING value_id INTO result; - END; - ELSE - result := ast; - END CASE; - - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; - a0sym varchar; - a1 integer; - let_env integer; - idx integer; - binds integer[]; - el integer; - fn integer; - fname varchar; - args integer[]; - cond integer; - fast integer; - fparams integer; - fenv integer; - result integer; -BEGIN - -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - IF types._count(ast) = 0 THEN - RETURN ast; - END IF; - - a0 := types._first(ast); - IF types._symbol_Q(a0) THEN - a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - BEGIN - RETURN envs.set(env, types._nth(ast, 1), - mal.EVAL(types._nth(ast, 2), env)); - END; - WHEN a0sym = 'let*' THEN - BEGIN - let_env := envs.new(env); - a1 := types._nth(ast, 1); - binds := (SELECT val_seq FROM types.value WHERE value_id = a1); - idx := 1; - WHILE idx < array_length(binds, 1) LOOP - PERFORM envs.set(let_env, binds[idx], - mal.EVAL(binds[idx+1], let_env)); - idx := idx + 2; - END LOOP; - RETURN mal.EVAL(types._nth(ast, 2), let_env); - END; - WHEN a0sym = 'do' THEN - BEGIN - el := mal.eval_ast(types._rest(ast), env); - RETURN types._nth(el, types._count(el)-1); - END; - WHEN a0sym = 'if' THEN - BEGIN - cond := mal.EVAL(types._nth(ast, 1), env); - SELECT type_id INTO type FROM types.value WHERE value_id = cond; - IF type = 0 OR type = 1 THEN -- nil or false - IF types._count(ast) > 3 THEN - RETURN mal.EVAL(types._nth(ast, 3), env); - ELSE - RETURN 0; -- nil - END IF; - ELSE - RETURN mal.EVAL(types._nth(ast, 2), env); - END IF; - END; - WHEN a0sym = 'fn*' THEN - BEGIN - RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); - END; - ELSE - BEGIN - el := mal.eval_ast(ast, env); - SELECT type_id, val_string, ast_id, params_id, env_id - INTO type, fname, fast, fparams, fenv - FROM types.value WHERE value_id = types._first(el); - args := types._restArray(el); - IF type = 11 THEN - EXECUTE format('SELECT %s($1);', fname) - INTO result USING args; - RETURN result; - ELSIF type = 12 THEN - RETURN mal.EVAL(fast, envs.new(fenv, fparams, args)); - ELSE - RAISE EXCEPTION 'Invalid function call'; - END IF; - END; - END CASE; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - --- repl_env is environment 0 - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); -END; $$ LANGUAGE plpgsql; - --- core.sql: defined using SQL (in core.sql) --- repl_env is created and populated with core functions in by core.sql - --- core.mal: defined using the language itself -SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' - -CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; -BEGIN - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step4_if_fn_do.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql +\i envs.sql +\i core.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval +CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + seq integer[]; + eseq integer[]; + hash hstore; + ehash hstore; + kv RECORD; + e integer; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 7 THEN + BEGIN + result := envs.get(env, ast); + END; + WHEN type IN (8, 9) THEN + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + -- Evaluate each entry creating a new sequence + FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP + eseq[i] := mal.EVAL(seq[i], env); + END LOOP; + INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) + RETURNING value_id INTO result; + END; + WHEN type = 10 THEN + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + -- Evaluate each value for every key/value + FOR kv IN SELECT * FROM each(hash) LOOP + e := mal.EVAL(CAST(kv.value AS integer), env); + IF ehash IS NULL THEN + ehash := hstore(kv.key, CAST(e AS varchar)); + ELSE + ehash := ehash || hstore(kv.key, CAST(e AS varchar)); + END IF; + END LOOP; + INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) + RETURNING value_id INTO result; + END; + ELSE + result := ast; + END CASE; + + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; + a0sym varchar; + a1 integer; + let_env integer; + idx integer; + binds integer[]; + el integer; + fn integer; + fname varchar; + args integer[]; + cond integer; + fast integer; + fparams integer; + fenv integer; + result integer; +BEGIN + -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + IF types._count(ast) = 0 THEN + RETURN ast; + END IF; + + a0 := types._first(ast); + IF types._symbol_Q(a0) THEN + a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + BEGIN + RETURN envs.set(env, types._nth(ast, 1), + mal.EVAL(types._nth(ast, 2), env)); + END; + WHEN a0sym = 'let*' THEN + BEGIN + let_env := envs.new(env); + a1 := types._nth(ast, 1); + binds := (SELECT val_seq FROM types.value WHERE value_id = a1); + idx := 1; + WHILE idx < array_length(binds, 1) LOOP + PERFORM envs.set(let_env, binds[idx], + mal.EVAL(binds[idx+1], let_env)); + idx := idx + 2; + END LOOP; + RETURN mal.EVAL(types._nth(ast, 2), let_env); + END; + WHEN a0sym = 'do' THEN + BEGIN + el := mal.eval_ast(types._rest(ast), env); + RETURN types._nth(el, types._count(el)-1); + END; + WHEN a0sym = 'if' THEN + BEGIN + cond := mal.EVAL(types._nth(ast, 1), env); + SELECT type_id INTO type FROM types.value WHERE value_id = cond; + IF type = 0 OR type = 1 THEN -- nil or false + IF types._count(ast) > 3 THEN + RETURN mal.EVAL(types._nth(ast, 3), env); + ELSE + RETURN 0; -- nil + END IF; + ELSE + RETURN mal.EVAL(types._nth(ast, 2), env); + END IF; + END; + WHEN a0sym = 'fn*' THEN + BEGIN + RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); + END; + ELSE + BEGIN + el := mal.eval_ast(ast, env); + SELECT type_id, val_string, ast_id, params_id, env_id + INTO type, fname, fast, fparams, fenv + FROM types.value WHERE value_id = types._first(el); + args := types._restArray(el); + IF type = 11 THEN + EXECUTE format('SELECT %s($1);', fname) + INTO result USING args; + RETURN result; + ELSIF type = 12 THEN + RETURN mal.EVAL(fast, envs.new(fenv, fparams, args)); + ELSE + RAISE EXCEPTION 'Invalid function call'; + END IF; + END; + END CASE; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +-- repl_env is environment 0 + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); +END; $$ LANGUAGE plpgsql; + +-- core.sql: defined using SQL (in core.sql) +-- repl_env is created and populated with core functions in by core.sql + +-- core.mal: defined using the language itself +SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' + +CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; +BEGIN + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/step5_tco.sql b/impls/plpgsql/step5_tco.sql index 20737be2c2..8222d06938 100644 --- a/impls/plpgsql/step5_tco.sql +++ b/impls/plpgsql/step5_tco.sql @@ -1,222 +1,222 @@ --- --------------------------------------------------------- --- step5_tco.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql -\i envs.sql -\i core.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval -CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - seq integer[]; - eseq integer[]; - hash hstore; - ehash hstore; - kv RECORD; - e integer; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 7 THEN - BEGIN - result := envs.get(env, ast); - END; - WHEN type IN (8, 9) THEN - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - -- Evaluate each entry creating a new sequence - FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP - eseq[i] := mal.EVAL(seq[i], env); - END LOOP; - INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) - RETURNING value_id INTO result; - END; - WHEN type = 10 THEN - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - -- Evaluate each value for every key/value - FOR kv IN SELECT * FROM each(hash) LOOP - e := mal.EVAL(CAST(kv.value AS integer), env); - IF ehash IS NULL THEN - ehash := hstore(kv.key, CAST(e AS varchar)); - ELSE - ehash := ehash || hstore(kv.key, CAST(e AS varchar)); - END IF; - END LOOP; - INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) - RETURNING value_id INTO result; - END; - ELSE - result := ast; - END CASE; - - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; - a0sym varchar; - a1 integer; - let_env integer; - idx integer; - binds integer[]; - el integer; - fn integer; - fname varchar; - args integer[]; - cond integer; - fast integer; - fparams integer; - fenv integer; - result integer; -BEGIN - LOOP - -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - IF types._count(ast) = 0 THEN - RETURN ast; - END IF; - - a0 := types._first(ast); - IF types._symbol_Q(a0) THEN - a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - BEGIN - RETURN envs.set(env, types._nth(ast, 1), - mal.EVAL(types._nth(ast, 2), env)); - END; - WHEN a0sym = 'let*' THEN - BEGIN - let_env := envs.new(env); - a1 := types._nth(ast, 1); - binds := (SELECT val_seq FROM types.value WHERE value_id = a1); - idx := 1; - WHILE idx < array_length(binds, 1) LOOP - PERFORM envs.set(let_env, binds[idx], - mal.EVAL(binds[idx+1], let_env)); - idx := idx + 2; - END LOOP; - env := let_env; - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END; - WHEN a0sym = 'do' THEN - BEGIN - PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); - ast := types._nth(ast, types._count(ast)-1); - CONTINUE; -- TCO - END; - WHEN a0sym = 'if' THEN - BEGIN - cond := mal.EVAL(types._nth(ast, 1), env); - SELECT type_id INTO type FROM types.value WHERE value_id = cond; - IF type = 0 OR type = 1 THEN -- nil or false - IF types._count(ast) > 3 THEN - ast := types._nth(ast, 3); - CONTINUE; -- TCO - ELSE - RETURN 0; -- nil - END IF; - ELSE - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END IF; - END; - WHEN a0sym = 'fn*' THEN - BEGIN - RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); - END; - ELSE - BEGIN - el := mal.eval_ast(ast, env); - SELECT type_id, val_string, ast_id, params_id, env_id - INTO type, fname, fast, fparams, fenv - FROM types.value WHERE value_id = types._first(el); - args := types._restArray(el); - IF type = 11 THEN - EXECUTE format('SELECT %s($1);', fname) - INTO result USING args; - RETURN result; - ELSIF type = 12 THEN - env := envs.new(fenv, fparams, args); - ast := fast; - CONTINUE; -- TCO - ELSE - RAISE EXCEPTION 'Invalid function call'; - END IF; - END; - END CASE; - END LOOP; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - --- repl_env is environment 0 - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); -END; $$ LANGUAGE plpgsql; - --- core.sql: defined using SQL (in core.sql) --- repl_env is created and populated with core functions in by core.sql - --- core.mal: defined using the language itself -SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' - -CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; -BEGIN - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step5_tco.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql +\i envs.sql +\i core.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval +CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + seq integer[]; + eseq integer[]; + hash hstore; + ehash hstore; + kv RECORD; + e integer; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 7 THEN + BEGIN + result := envs.get(env, ast); + END; + WHEN type IN (8, 9) THEN + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + -- Evaluate each entry creating a new sequence + FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP + eseq[i] := mal.EVAL(seq[i], env); + END LOOP; + INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) + RETURNING value_id INTO result; + END; + WHEN type = 10 THEN + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + -- Evaluate each value for every key/value + FOR kv IN SELECT * FROM each(hash) LOOP + e := mal.EVAL(CAST(kv.value AS integer), env); + IF ehash IS NULL THEN + ehash := hstore(kv.key, CAST(e AS varchar)); + ELSE + ehash := ehash || hstore(kv.key, CAST(e AS varchar)); + END IF; + END LOOP; + INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) + RETURNING value_id INTO result; + END; + ELSE + result := ast; + END CASE; + + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; + a0sym varchar; + a1 integer; + let_env integer; + idx integer; + binds integer[]; + el integer; + fn integer; + fname varchar; + args integer[]; + cond integer; + fast integer; + fparams integer; + fenv integer; + result integer; +BEGIN + LOOP + -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + IF types._count(ast) = 0 THEN + RETURN ast; + END IF; + + a0 := types._first(ast); + IF types._symbol_Q(a0) THEN + a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + BEGIN + RETURN envs.set(env, types._nth(ast, 1), + mal.EVAL(types._nth(ast, 2), env)); + END; + WHEN a0sym = 'let*' THEN + BEGIN + let_env := envs.new(env); + a1 := types._nth(ast, 1); + binds := (SELECT val_seq FROM types.value WHERE value_id = a1); + idx := 1; + WHILE idx < array_length(binds, 1) LOOP + PERFORM envs.set(let_env, binds[idx], + mal.EVAL(binds[idx+1], let_env)); + idx := idx + 2; + END LOOP; + env := let_env; + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END; + WHEN a0sym = 'do' THEN + BEGIN + PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); + ast := types._nth(ast, types._count(ast)-1); + CONTINUE; -- TCO + END; + WHEN a0sym = 'if' THEN + BEGIN + cond := mal.EVAL(types._nth(ast, 1), env); + SELECT type_id INTO type FROM types.value WHERE value_id = cond; + IF type = 0 OR type = 1 THEN -- nil or false + IF types._count(ast) > 3 THEN + ast := types._nth(ast, 3); + CONTINUE; -- TCO + ELSE + RETURN 0; -- nil + END IF; + ELSE + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END IF; + END; + WHEN a0sym = 'fn*' THEN + BEGIN + RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); + END; + ELSE + BEGIN + el := mal.eval_ast(ast, env); + SELECT type_id, val_string, ast_id, params_id, env_id + INTO type, fname, fast, fparams, fenv + FROM types.value WHERE value_id = types._first(el); + args := types._restArray(el); + IF type = 11 THEN + EXECUTE format('SELECT %s($1);', fname) + INTO result USING args; + RETURN result; + ELSIF type = 12 THEN + env := envs.new(fenv, fparams, args); + ast := fast; + CONTINUE; -- TCO + ELSE + RAISE EXCEPTION 'Invalid function call'; + END IF; + END; + END CASE; + END LOOP; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +-- repl_env is environment 0 + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); +END; $$ LANGUAGE plpgsql; + +-- core.sql: defined using SQL (in core.sql) +-- repl_env is created and populated with core functions in by core.sql + +-- core.mal: defined using the language itself +SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' + +CREATE FUNCTION mal.MAIN(pwd varchar) RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; +BEGIN + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/step6_file.sql b/impls/plpgsql/step6_file.sql index 3115021b3b..701de23aa2 100644 --- a/impls/plpgsql/step6_file.sql +++ b/impls/plpgsql/step6_file.sql @@ -1,249 +1,249 @@ --- --------------------------------------------------------- --- step6_file.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql -\i envs.sql -\i core.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval -CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - seq integer[]; - eseq integer[]; - hash hstore; - ehash hstore; - kv RECORD; - e integer; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 7 THEN - BEGIN - result := envs.get(env, ast); - END; - WHEN type IN (8, 9) THEN - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - -- Evaluate each entry creating a new sequence - FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP - eseq[i] := mal.EVAL(seq[i], env); - END LOOP; - INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) - RETURNING value_id INTO result; - END; - WHEN type = 10 THEN - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - -- Evaluate each value for every key/value - FOR kv IN SELECT * FROM each(hash) LOOP - e := mal.EVAL(CAST(kv.value AS integer), env); - IF ehash IS NULL THEN - ehash := hstore(kv.key, CAST(e AS varchar)); - ELSE - ehash := ehash || hstore(kv.key, CAST(e AS varchar)); - END IF; - END LOOP; - INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) - RETURNING value_id INTO result; - END; - ELSE - result := ast; - END CASE; - - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; - a0sym varchar; - a1 integer; - let_env integer; - idx integer; - binds integer[]; - el integer; - fn integer; - fname varchar; - args integer[]; - cond integer; - fast integer; - fparams integer; - fenv integer; - result integer; -BEGIN - LOOP - -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - IF types._count(ast) = 0 THEN - RETURN ast; - END IF; - - a0 := types._first(ast); - IF types._symbol_Q(a0) THEN - a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - BEGIN - RETURN envs.set(env, types._nth(ast, 1), - mal.EVAL(types._nth(ast, 2), env)); - END; - WHEN a0sym = 'let*' THEN - BEGIN - let_env := envs.new(env); - a1 := types._nth(ast, 1); - binds := (SELECT val_seq FROM types.value WHERE value_id = a1); - idx := 1; - WHILE idx < array_length(binds, 1) LOOP - PERFORM envs.set(let_env, binds[idx], - mal.EVAL(binds[idx+1], let_env)); - idx := idx + 2; - END LOOP; - env := let_env; - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END; - WHEN a0sym = 'do' THEN - BEGIN - PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); - ast := types._nth(ast, types._count(ast)-1); - CONTINUE; -- TCO - END; - WHEN a0sym = 'if' THEN - BEGIN - cond := mal.EVAL(types._nth(ast, 1), env); - SELECT type_id INTO type FROM types.value WHERE value_id = cond; - IF type = 0 OR type = 1 THEN -- nil or false - IF types._count(ast) > 3 THEN - ast := types._nth(ast, 3); - CONTINUE; -- TCO - ELSE - RETURN 0; -- nil - END IF; - ELSE - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END IF; - END; - WHEN a0sym = 'fn*' THEN - BEGIN - RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); - END; - ELSE - BEGIN - el := mal.eval_ast(ast, env); - SELECT type_id, val_string, ast_id, params_id, env_id - INTO type, fname, fast, fparams, fenv - FROM types.value WHERE value_id = types._first(el); - args := types._restArray(el); - IF type = 11 THEN - EXECUTE format('SELECT %s($1);', fname) - INTO result USING args; - RETURN result; - ELSIF type = 12 THEN - env := envs.new(fenv, fparams, args); - ast := fast; - CONTINUE; -- TCO - ELSE - RAISE EXCEPTION 'Invalid function call'; - END IF; - END; - END CASE; - END LOOP; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - --- repl_env is environment 0 - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); -END; $$ LANGUAGE plpgsql; - --- core.sql: defined using SQL (in core.sql) --- repl_env is created and populated with core functions in by core.sql -CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN mal.EVAL(args[1], 0); -END; $$ LANGUAGE plpgsql; -INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); - -SELECT envs.vset(0, 'eval', - (SELECT value_id FROM types.value - WHERE val_string = 'mal.mal_eval')) \g '/dev/null' --- *ARGV* values are set by RUN -SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' - - --- core.mal: defined using the language itself -SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' -SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' - -CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) - RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; - allargs integer; -BEGIN - PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); - - IF argstring IS NOT NULL THEN - allargs := mal.READ(argstring); - PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); - PERFORM mal.REP('(load-file ' || - printer.pr_str(types._first(allargs)) || ')'); - PERFORM io.close(1); - PERFORM io.wait_flushed(1); - RETURN 0; - END IF; - - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step6_file.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql +\i envs.sql +\i core.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval +CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + seq integer[]; + eseq integer[]; + hash hstore; + ehash hstore; + kv RECORD; + e integer; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 7 THEN + BEGIN + result := envs.get(env, ast); + END; + WHEN type IN (8, 9) THEN + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + -- Evaluate each entry creating a new sequence + FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP + eseq[i] := mal.EVAL(seq[i], env); + END LOOP; + INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) + RETURNING value_id INTO result; + END; + WHEN type = 10 THEN + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + -- Evaluate each value for every key/value + FOR kv IN SELECT * FROM each(hash) LOOP + e := mal.EVAL(CAST(kv.value AS integer), env); + IF ehash IS NULL THEN + ehash := hstore(kv.key, CAST(e AS varchar)); + ELSE + ehash := ehash || hstore(kv.key, CAST(e AS varchar)); + END IF; + END LOOP; + INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) + RETURNING value_id INTO result; + END; + ELSE + result := ast; + END CASE; + + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; + a0sym varchar; + a1 integer; + let_env integer; + idx integer; + binds integer[]; + el integer; + fn integer; + fname varchar; + args integer[]; + cond integer; + fast integer; + fparams integer; + fenv integer; + result integer; +BEGIN + LOOP + -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + IF types._count(ast) = 0 THEN + RETURN ast; + END IF; + + a0 := types._first(ast); + IF types._symbol_Q(a0) THEN + a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + BEGIN + RETURN envs.set(env, types._nth(ast, 1), + mal.EVAL(types._nth(ast, 2), env)); + END; + WHEN a0sym = 'let*' THEN + BEGIN + let_env := envs.new(env); + a1 := types._nth(ast, 1); + binds := (SELECT val_seq FROM types.value WHERE value_id = a1); + idx := 1; + WHILE idx < array_length(binds, 1) LOOP + PERFORM envs.set(let_env, binds[idx], + mal.EVAL(binds[idx+1], let_env)); + idx := idx + 2; + END LOOP; + env := let_env; + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END; + WHEN a0sym = 'do' THEN + BEGIN + PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); + ast := types._nth(ast, types._count(ast)-1); + CONTINUE; -- TCO + END; + WHEN a0sym = 'if' THEN + BEGIN + cond := mal.EVAL(types._nth(ast, 1), env); + SELECT type_id INTO type FROM types.value WHERE value_id = cond; + IF type = 0 OR type = 1 THEN -- nil or false + IF types._count(ast) > 3 THEN + ast := types._nth(ast, 3); + CONTINUE; -- TCO + ELSE + RETURN 0; -- nil + END IF; + ELSE + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END IF; + END; + WHEN a0sym = 'fn*' THEN + BEGIN + RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); + END; + ELSE + BEGIN + el := mal.eval_ast(ast, env); + SELECT type_id, val_string, ast_id, params_id, env_id + INTO type, fname, fast, fparams, fenv + FROM types.value WHERE value_id = types._first(el); + args := types._restArray(el); + IF type = 11 THEN + EXECUTE format('SELECT %s($1);', fname) + INTO result USING args; + RETURN result; + ELSIF type = 12 THEN + env := envs.new(fenv, fparams, args); + ast := fast; + CONTINUE; -- TCO + ELSE + RAISE EXCEPTION 'Invalid function call'; + END IF; + END; + END CASE; + END LOOP; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +-- repl_env is environment 0 + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); +END; $$ LANGUAGE plpgsql; + +-- core.sql: defined using SQL (in core.sql) +-- repl_env is created and populated with core functions in by core.sql +CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN mal.EVAL(args[1], 0); +END; $$ LANGUAGE plpgsql; +INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); + +SELECT envs.vset(0, 'eval', + (SELECT value_id FROM types.value + WHERE val_string = 'mal.mal_eval')) \g '/dev/null' +-- *ARGV* values are set by RUN +SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' + + +-- core.mal: defined using the language itself +SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' +SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' + +CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) + RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; + allargs integer; +BEGIN + PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); + + IF argstring IS NOT NULL THEN + allargs := mal.READ(argstring); + PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); + PERFORM mal.REP('(load-file ' || + printer.pr_str(types._first(allargs)) || ')'); + PERFORM io.close(1); + PERFORM io.wait_flushed(1); + RETURN 0; + END IF; + + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/step7_quote.sql b/impls/plpgsql/step7_quote.sql index 3bd6e913d5..b56ac6c745 100644 --- a/impls/plpgsql/step7_quote.sql +++ b/impls/plpgsql/step7_quote.sql @@ -1,317 +1,317 @@ --- --------------------------------------------------------- --- step7_quote.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql -\i envs.sql -\i core.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval - -CREATE FUNCTION mal.qq_loop(elt integer, acc integer) RETURNS integer AS $$ -DECLARE - a0 integer; -BEGIN - IF types._list_Q(elt) AND types._count(elt) = 2 THEN - a0 := types._first(elt); - IF types._symbol_Q(a0) AND a0 = types._symbolv('splice-unquote') THEN - RETURN types._list(ARRAY[types._symbolv('concat'), types._nth(elt, 1), acc]); - END IF; - END IF; - RETURN types._list(ARRAY[types._symbolv('cons'), mal.quasiquote(elt), acc]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.qq_foldr(xs integer) RETURNS integer AS $$ -DECLARE - elt integer; - acc integer := types._list(ARRAY[]::integer[]); -BEGIN - FOREACH elt IN ARRAY types.array_reverse(types._valueToArray(xs)) LOOP - acc := mal.qq_loop(elt, acc); - END LOOP; - RETURN acc; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.quasiquote(ast integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 8 THEN -- list - BEGIN - IF types._count(ast) = 2 THEN - a0 := types._first(ast); - IF types._symbol_Q(a0) AND a0 = types._symbolv('unquote') THEN - RETURN types._nth(ast, 1); - END IF; - END IF; - RETURN mal.qq_foldr(ast); - END; - WHEN type = 9 THEN -- vector - BEGIN - RETURN types._list(ARRAY[types._symbolv('vec'), mal.qq_foldr(ast)]); - END; - WHEN type in (7, 10) THEN -- symbol or map - BEGIN - RETURN types._list(ARRAY[types._symbolv('quote'), ast]); - END; - ELSE - BEGIN - RETURN ast; - END; - END CASE; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - seq integer[]; - eseq integer[]; - hash hstore; - ehash hstore; - kv RECORD; - e integer; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 7 THEN - BEGIN - result := envs.get(env, ast); - END; - WHEN type IN (8, 9) THEN - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - -- Evaluate each entry creating a new sequence - FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP - eseq[i] := mal.EVAL(seq[i], env); - END LOOP; - INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) - RETURNING value_id INTO result; - END; - WHEN type = 10 THEN - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - -- Evaluate each value for every key/value - FOR kv IN SELECT * FROM each(hash) LOOP - e := mal.EVAL(CAST(kv.value AS integer), env); - IF ehash IS NULL THEN - ehash := hstore(kv.key, CAST(e AS varchar)); - ELSE - ehash := ehash || hstore(kv.key, CAST(e AS varchar)); - END IF; - END LOOP; - INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) - RETURNING value_id INTO result; - END; - ELSE - result := ast; - END CASE; - - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; - a0sym varchar; - a1 integer; - let_env integer; - idx integer; - binds integer[]; - el integer; - fn integer; - fname varchar; - args integer[]; - cond integer; - fast integer; - fparams integer; - fenv integer; - result integer; -BEGIN - LOOP - -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - IF types._count(ast) = 0 THEN - RETURN ast; - END IF; - - a0 := types._first(ast); - IF types._symbol_Q(a0) THEN - a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - BEGIN - RETURN envs.set(env, types._nth(ast, 1), - mal.EVAL(types._nth(ast, 2), env)); - END; - WHEN a0sym = 'let*' THEN - BEGIN - let_env := envs.new(env); - a1 := types._nth(ast, 1); - binds := (SELECT val_seq FROM types.value WHERE value_id = a1); - idx := 1; - WHILE idx < array_length(binds, 1) LOOP - PERFORM envs.set(let_env, binds[idx], - mal.EVAL(binds[idx+1], let_env)); - idx := idx + 2; - END LOOP; - env := let_env; - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END; - WHEN a0sym = 'quote' THEN - BEGIN - RETURN types._nth(ast, 1); - END; - WHEN a0sym = 'quasiquoteexpand' THEN - RETURN mal.quasiquote(types._nth(ast, 1)); - WHEN a0sym = 'quasiquote' THEN - BEGIN - ast := mal.quasiquote(types._nth(ast, 1)); - CONTINUE; -- TCO - END; - WHEN a0sym = 'do' THEN - BEGIN - PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); - ast := types._nth(ast, types._count(ast)-1); - CONTINUE; -- TCO - END; - WHEN a0sym = 'if' THEN - BEGIN - cond := mal.EVAL(types._nth(ast, 1), env); - SELECT type_id INTO type FROM types.value WHERE value_id = cond; - IF type = 0 OR type = 1 THEN -- nil or false - IF types._count(ast) > 3 THEN - ast := types._nth(ast, 3); - CONTINUE; -- TCO - ELSE - RETURN 0; -- nil - END IF; - ELSE - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END IF; - END; - WHEN a0sym = 'fn*' THEN - BEGIN - RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); - END; - ELSE - BEGIN - el := mal.eval_ast(ast, env); - SELECT type_id, val_string, ast_id, params_id, env_id - INTO type, fname, fast, fparams, fenv - FROM types.value WHERE value_id = types._first(el); - args := types._restArray(el); - IF type = 11 THEN - EXECUTE format('SELECT %s($1);', fname) - INTO result USING args; - RETURN result; - ELSIF type = 12 THEN - env := envs.new(fenv, fparams, args); - ast := fast; - CONTINUE; -- TCO - ELSE - RAISE EXCEPTION 'Invalid function call'; - END IF; - END; - END CASE; - END LOOP; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - --- repl_env is environment 0 - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); -END; $$ LANGUAGE plpgsql; - --- core.sql: defined using SQL (in core.sql) --- repl_env is created and populated with core functions in by core.sql -CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN mal.EVAL(args[1], 0); -END; $$ LANGUAGE plpgsql; -INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); - -SELECT envs.vset(0, 'eval', - (SELECT value_id FROM types.value - WHERE val_string = 'mal.mal_eval')) \g '/dev/null' --- *ARGV* values are set by RUN -SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' - - --- core.mal: defined using the language itself -SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' -SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' - -CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) - RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; - allargs integer; -BEGIN - PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); - - IF argstring IS NOT NULL THEN - allargs := mal.READ(argstring); - PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); - PERFORM mal.REP('(load-file ' || - printer.pr_str(types._first(allargs)) || ')'); - PERFORM io.close(1); - PERFORM io.wait_flushed(1); - RETURN 0; - END IF; - - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step7_quote.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql +\i envs.sql +\i core.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval + +CREATE FUNCTION mal.qq_loop(elt integer, acc integer) RETURNS integer AS $$ +DECLARE + a0 integer; +BEGIN + IF types._list_Q(elt) AND types._count(elt) = 2 THEN + a0 := types._first(elt); + IF types._symbol_Q(a0) AND a0 = types._symbolv('splice-unquote') THEN + RETURN types._list(ARRAY[types._symbolv('concat'), types._nth(elt, 1), acc]); + END IF; + END IF; + RETURN types._list(ARRAY[types._symbolv('cons'), mal.quasiquote(elt), acc]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.qq_foldr(xs integer) RETURNS integer AS $$ +DECLARE + elt integer; + acc integer := types._list(ARRAY[]::integer[]); +BEGIN + FOREACH elt IN ARRAY types.array_reverse(types._valueToArray(xs)) LOOP + acc := mal.qq_loop(elt, acc); + END LOOP; + RETURN acc; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.quasiquote(ast integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 8 THEN -- list + BEGIN + IF types._count(ast) = 2 THEN + a0 := types._first(ast); + IF types._symbol_Q(a0) AND a0 = types._symbolv('unquote') THEN + RETURN types._nth(ast, 1); + END IF; + END IF; + RETURN mal.qq_foldr(ast); + END; + WHEN type = 9 THEN -- vector + BEGIN + RETURN types._list(ARRAY[types._symbolv('vec'), mal.qq_foldr(ast)]); + END; + WHEN type in (7, 10) THEN -- symbol or map + BEGIN + RETURN types._list(ARRAY[types._symbolv('quote'), ast]); + END; + ELSE + BEGIN + RETURN ast; + END; + END CASE; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + seq integer[]; + eseq integer[]; + hash hstore; + ehash hstore; + kv RECORD; + e integer; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 7 THEN + BEGIN + result := envs.get(env, ast); + END; + WHEN type IN (8, 9) THEN + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + -- Evaluate each entry creating a new sequence + FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP + eseq[i] := mal.EVAL(seq[i], env); + END LOOP; + INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) + RETURNING value_id INTO result; + END; + WHEN type = 10 THEN + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + -- Evaluate each value for every key/value + FOR kv IN SELECT * FROM each(hash) LOOP + e := mal.EVAL(CAST(kv.value AS integer), env); + IF ehash IS NULL THEN + ehash := hstore(kv.key, CAST(e AS varchar)); + ELSE + ehash := ehash || hstore(kv.key, CAST(e AS varchar)); + END IF; + END LOOP; + INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) + RETURNING value_id INTO result; + END; + ELSE + result := ast; + END CASE; + + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; + a0sym varchar; + a1 integer; + let_env integer; + idx integer; + binds integer[]; + el integer; + fn integer; + fname varchar; + args integer[]; + cond integer; + fast integer; + fparams integer; + fenv integer; + result integer; +BEGIN + LOOP + -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + IF types._count(ast) = 0 THEN + RETURN ast; + END IF; + + a0 := types._first(ast); + IF types._symbol_Q(a0) THEN + a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + BEGIN + RETURN envs.set(env, types._nth(ast, 1), + mal.EVAL(types._nth(ast, 2), env)); + END; + WHEN a0sym = 'let*' THEN + BEGIN + let_env := envs.new(env); + a1 := types._nth(ast, 1); + binds := (SELECT val_seq FROM types.value WHERE value_id = a1); + idx := 1; + WHILE idx < array_length(binds, 1) LOOP + PERFORM envs.set(let_env, binds[idx], + mal.EVAL(binds[idx+1], let_env)); + idx := idx + 2; + END LOOP; + env := let_env; + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END; + WHEN a0sym = 'quote' THEN + BEGIN + RETURN types._nth(ast, 1); + END; + WHEN a0sym = 'quasiquoteexpand' THEN + RETURN mal.quasiquote(types._nth(ast, 1)); + WHEN a0sym = 'quasiquote' THEN + BEGIN + ast := mal.quasiquote(types._nth(ast, 1)); + CONTINUE; -- TCO + END; + WHEN a0sym = 'do' THEN + BEGIN + PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); + ast := types._nth(ast, types._count(ast)-1); + CONTINUE; -- TCO + END; + WHEN a0sym = 'if' THEN + BEGIN + cond := mal.EVAL(types._nth(ast, 1), env); + SELECT type_id INTO type FROM types.value WHERE value_id = cond; + IF type = 0 OR type = 1 THEN -- nil or false + IF types._count(ast) > 3 THEN + ast := types._nth(ast, 3); + CONTINUE; -- TCO + ELSE + RETURN 0; -- nil + END IF; + ELSE + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END IF; + END; + WHEN a0sym = 'fn*' THEN + BEGIN + RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); + END; + ELSE + BEGIN + el := mal.eval_ast(ast, env); + SELECT type_id, val_string, ast_id, params_id, env_id + INTO type, fname, fast, fparams, fenv + FROM types.value WHERE value_id = types._first(el); + args := types._restArray(el); + IF type = 11 THEN + EXECUTE format('SELECT %s($1);', fname) + INTO result USING args; + RETURN result; + ELSIF type = 12 THEN + env := envs.new(fenv, fparams, args); + ast := fast; + CONTINUE; -- TCO + ELSE + RAISE EXCEPTION 'Invalid function call'; + END IF; + END; + END CASE; + END LOOP; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +-- repl_env is environment 0 + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); +END; $$ LANGUAGE plpgsql; + +-- core.sql: defined using SQL (in core.sql) +-- repl_env is created and populated with core functions in by core.sql +CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN mal.EVAL(args[1], 0); +END; $$ LANGUAGE plpgsql; +INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); + +SELECT envs.vset(0, 'eval', + (SELECT value_id FROM types.value + WHERE val_string = 'mal.mal_eval')) \g '/dev/null' +-- *ARGV* values are set by RUN +SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' + + +-- core.mal: defined using the language itself +SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' +SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' + +CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) + RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; + allargs integer; +BEGIN + PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); + + IF argstring IS NOT NULL THEN + allargs := mal.READ(argstring); + PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); + PERFORM mal.REP('(load-file ' || + printer.pr_str(types._first(allargs)) || ')'); + PERFORM io.close(1); + PERFORM io.wait_flushed(1); + RETURN 0; + END IF; + + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/step8_macros.sql b/impls/plpgsql/step8_macros.sql index c5a5d110dc..99d120a215 100644 --- a/impls/plpgsql/step8_macros.sql +++ b/impls/plpgsql/step8_macros.sql @@ -1,363 +1,363 @@ --- --------------------------------------------------------- --- step8_macros.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql -\i envs.sql -\i core.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval - -CREATE FUNCTION mal.qq_loop(elt integer, acc integer) RETURNS integer AS $$ -DECLARE - a0 integer; -BEGIN - IF types._list_Q(elt) AND types._count(elt) = 2 THEN - a0 := types._first(elt); - IF types._symbol_Q(a0) AND a0 = types._symbolv('splice-unquote') THEN - RETURN types._list(ARRAY[types._symbolv('concat'), types._nth(elt, 1), acc]); - END IF; - END IF; - RETURN types._list(ARRAY[types._symbolv('cons'), mal.quasiquote(elt), acc]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.qq_foldr(xs integer) RETURNS integer AS $$ -DECLARE - elt integer; - acc integer := types._list(ARRAY[]::integer[]); -BEGIN - FOREACH elt IN ARRAY types.array_reverse(types._valueToArray(xs)) LOOP - acc := mal.qq_loop(elt, acc); - END LOOP; - RETURN acc; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.quasiquote(ast integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 8 THEN -- list - BEGIN - IF types._count(ast) = 2 THEN - a0 := types._first(ast); - IF types._symbol_Q(a0) AND a0 = types._symbolv('unquote') THEN - RETURN types._nth(ast, 1); - END IF; - END IF; - RETURN mal.qq_foldr(ast); - END; - WHEN type = 9 THEN -- vector - BEGIN - RETURN types._list(ARRAY[types._symbolv('vec'), mal.qq_foldr(ast)]); - END; - WHEN type in (7, 10) THEN -- symbol or map - BEGIN - RETURN types._list(ARRAY[types._symbolv('quote'), ast]); - END; - ELSE - BEGIN - RETURN ast; - END; - END CASE; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.is_macro_call(ast integer, env integer) RETURNS boolean AS $$ -DECLARE - a0 integer; - f integer; - result boolean = false; -BEGIN - IF types._list_Q(ast) THEN - a0 = types._first(ast); - IF types._symbol_Q(a0) AND - envs.find(env, types._valueToString(a0)) IS NOT NULL THEN - f := envs.get(env, a0); - SELECT macro INTO result FROM types.value WHERE value_id = f; - END IF; - END IF; - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.macroexpand(ast integer, env integer) RETURNS integer AS $$ -DECLARE - mac integer; -BEGIN - WHILE mal.is_macro_call(ast, env) - LOOP - mac := envs.get(env, types._first(ast)); - ast := types._apply(mac, types._valueToArray(types._rest(ast))); - END LOOP; - RETURN ast; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - seq integer[]; - eseq integer[]; - hash hstore; - ehash hstore; - kv RECORD; - e integer; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 7 THEN - BEGIN - result := envs.get(env, ast); - END; - WHEN type IN (8, 9) THEN - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - -- Evaluate each entry creating a new sequence - FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP - eseq[i] := mal.EVAL(seq[i], env); - END LOOP; - INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) - RETURNING value_id INTO result; - END; - WHEN type = 10 THEN - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - -- Evaluate each value for every key/value - FOR kv IN SELECT * FROM each(hash) LOOP - e := mal.EVAL(CAST(kv.value AS integer), env); - IF ehash IS NULL THEN - ehash := hstore(kv.key, CAST(e AS varchar)); - ELSE - ehash := ehash || hstore(kv.key, CAST(e AS varchar)); - END IF; - END LOOP; - INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) - RETURNING value_id INTO result; - END; - ELSE - result := ast; - END CASE; - - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; - a0sym varchar; - a1 integer; - let_env integer; - idx integer; - binds integer[]; - el integer; - fn integer; - fname varchar; - args integer[]; - cond integer; - fast integer; - fparams integer; - fenv integer; - result integer; -BEGIN - LOOP - -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - - ast := mal.macroexpand(ast, env); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - IF types._count(ast) = 0 THEN - RETURN ast; - END IF; - - a0 := types._first(ast); - IF types._symbol_Q(a0) THEN - a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - BEGIN - RETURN envs.set(env, types._nth(ast, 1), - mal.EVAL(types._nth(ast, 2), env)); - END; - WHEN a0sym = 'let*' THEN - BEGIN - let_env := envs.new(env); - a1 := types._nth(ast, 1); - binds := (SELECT val_seq FROM types.value WHERE value_id = a1); - idx := 1; - WHILE idx < array_length(binds, 1) LOOP - PERFORM envs.set(let_env, binds[idx], - mal.EVAL(binds[idx+1], let_env)); - idx := idx + 2; - END LOOP; - env := let_env; - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END; - WHEN a0sym = 'quote' THEN - BEGIN - RETURN types._nth(ast, 1); - END; - WHEN a0sym = 'quasiquoteexpand' THEN - RETURN mal.quasiquote(types._nth(ast, 1)); - WHEN a0sym = 'quasiquote' THEN - BEGIN - ast := mal.quasiquote(types._nth(ast, 1)); - CONTINUE; -- TCO - END; - WHEN a0sym = 'defmacro!' THEN - BEGIN - fn := mal.EVAL(types._nth(ast, 2), env); - fn := types._macro(fn); - RETURN envs.set(env, types._nth(ast, 1), fn); - END; - WHEN a0sym = 'macroexpand' THEN - BEGIN - RETURN mal.macroexpand(types._nth(ast, 1), env); - END; - WHEN a0sym = 'do' THEN - BEGIN - PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); - ast := types._nth(ast, types._count(ast)-1); - CONTINUE; -- TCO - END; - WHEN a0sym = 'if' THEN - BEGIN - cond := mal.EVAL(types._nth(ast, 1), env); - SELECT type_id INTO type FROM types.value WHERE value_id = cond; - IF type = 0 OR type = 1 THEN -- nil or false - IF types._count(ast) > 3 THEN - ast := types._nth(ast, 3); - CONTINUE; -- TCO - ELSE - RETURN 0; -- nil - END IF; - ELSE - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END IF; - END; - WHEN a0sym = 'fn*' THEN - BEGIN - RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); - END; - ELSE - BEGIN - el := mal.eval_ast(ast, env); - SELECT type_id, val_string, ast_id, params_id, env_id - INTO type, fname, fast, fparams, fenv - FROM types.value WHERE value_id = types._first(el); - args := types._restArray(el); - IF type = 11 THEN - EXECUTE format('SELECT %s($1);', fname) - INTO result USING args; - RETURN result; - ELSIF type = 12 THEN - env := envs.new(fenv, fparams, args); - ast := fast; - CONTINUE; -- TCO - ELSE - RAISE EXCEPTION 'Invalid function call'; - END IF; - END; - END CASE; - END LOOP; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - --- repl_env is environment 0 - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); -END; $$ LANGUAGE plpgsql; - --- core.sql: defined using SQL (in core.sql) --- repl_env is created and populated with core functions in by core.sql -CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN mal.EVAL(args[1], 0); -END; $$ LANGUAGE plpgsql; -INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); - -SELECT envs.vset(0, 'eval', - (SELECT value_id FROM types.value - WHERE val_string = 'mal.mal_eval')) \g '/dev/null' --- *ARGV* values are set by RUN -SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' - - --- core.mal: defined using the language itself -SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' -SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' -SELECT mal.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)))))))') \g '/dev/null' - -CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) - RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; - allargs integer; -BEGIN - PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); - - IF argstring IS NOT NULL THEN - allargs := mal.READ(argstring); - PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); - PERFORM mal.REP('(load-file ' || - printer.pr_str(types._first(allargs)) || ')'); - PERFORM io.close(1); - PERFORM io.wait_flushed(1); - RETURN 0; - END IF; - - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step8_macros.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql +\i envs.sql +\i core.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval + +CREATE FUNCTION mal.qq_loop(elt integer, acc integer) RETURNS integer AS $$ +DECLARE + a0 integer; +BEGIN + IF types._list_Q(elt) AND types._count(elt) = 2 THEN + a0 := types._first(elt); + IF types._symbol_Q(a0) AND a0 = types._symbolv('splice-unquote') THEN + RETURN types._list(ARRAY[types._symbolv('concat'), types._nth(elt, 1), acc]); + END IF; + END IF; + RETURN types._list(ARRAY[types._symbolv('cons'), mal.quasiquote(elt), acc]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.qq_foldr(xs integer) RETURNS integer AS $$ +DECLARE + elt integer; + acc integer := types._list(ARRAY[]::integer[]); +BEGIN + FOREACH elt IN ARRAY types.array_reverse(types._valueToArray(xs)) LOOP + acc := mal.qq_loop(elt, acc); + END LOOP; + RETURN acc; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.quasiquote(ast integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 8 THEN -- list + BEGIN + IF types._count(ast) = 2 THEN + a0 := types._first(ast); + IF types._symbol_Q(a0) AND a0 = types._symbolv('unquote') THEN + RETURN types._nth(ast, 1); + END IF; + END IF; + RETURN mal.qq_foldr(ast); + END; + WHEN type = 9 THEN -- vector + BEGIN + RETURN types._list(ARRAY[types._symbolv('vec'), mal.qq_foldr(ast)]); + END; + WHEN type in (7, 10) THEN -- symbol or map + BEGIN + RETURN types._list(ARRAY[types._symbolv('quote'), ast]); + END; + ELSE + BEGIN + RETURN ast; + END; + END CASE; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.is_macro_call(ast integer, env integer) RETURNS boolean AS $$ +DECLARE + a0 integer; + f integer; + result boolean = false; +BEGIN + IF types._list_Q(ast) THEN + a0 = types._first(ast); + IF types._symbol_Q(a0) AND + envs.find(env, types._valueToString(a0)) IS NOT NULL THEN + f := envs.get(env, a0); + SELECT macro INTO result FROM types.value WHERE value_id = f; + END IF; + END IF; + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.macroexpand(ast integer, env integer) RETURNS integer AS $$ +DECLARE + mac integer; +BEGIN + WHILE mal.is_macro_call(ast, env) + LOOP + mac := envs.get(env, types._first(ast)); + ast := types._apply(mac, types._valueToArray(types._rest(ast))); + END LOOP; + RETURN ast; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + seq integer[]; + eseq integer[]; + hash hstore; + ehash hstore; + kv RECORD; + e integer; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 7 THEN + BEGIN + result := envs.get(env, ast); + END; + WHEN type IN (8, 9) THEN + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + -- Evaluate each entry creating a new sequence + FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP + eseq[i] := mal.EVAL(seq[i], env); + END LOOP; + INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) + RETURNING value_id INTO result; + END; + WHEN type = 10 THEN + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + -- Evaluate each value for every key/value + FOR kv IN SELECT * FROM each(hash) LOOP + e := mal.EVAL(CAST(kv.value AS integer), env); + IF ehash IS NULL THEN + ehash := hstore(kv.key, CAST(e AS varchar)); + ELSE + ehash := ehash || hstore(kv.key, CAST(e AS varchar)); + END IF; + END LOOP; + INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) + RETURNING value_id INTO result; + END; + ELSE + result := ast; + END CASE; + + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; + a0sym varchar; + a1 integer; + let_env integer; + idx integer; + binds integer[]; + el integer; + fn integer; + fname varchar; + args integer[]; + cond integer; + fast integer; + fparams integer; + fenv integer; + result integer; +BEGIN + LOOP + -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + + ast := mal.macroexpand(ast, env); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + IF types._count(ast) = 0 THEN + RETURN ast; + END IF; + + a0 := types._first(ast); + IF types._symbol_Q(a0) THEN + a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + BEGIN + RETURN envs.set(env, types._nth(ast, 1), + mal.EVAL(types._nth(ast, 2), env)); + END; + WHEN a0sym = 'let*' THEN + BEGIN + let_env := envs.new(env); + a1 := types._nth(ast, 1); + binds := (SELECT val_seq FROM types.value WHERE value_id = a1); + idx := 1; + WHILE idx < array_length(binds, 1) LOOP + PERFORM envs.set(let_env, binds[idx], + mal.EVAL(binds[idx+1], let_env)); + idx := idx + 2; + END LOOP; + env := let_env; + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END; + WHEN a0sym = 'quote' THEN + BEGIN + RETURN types._nth(ast, 1); + END; + WHEN a0sym = 'quasiquoteexpand' THEN + RETURN mal.quasiquote(types._nth(ast, 1)); + WHEN a0sym = 'quasiquote' THEN + BEGIN + ast := mal.quasiquote(types._nth(ast, 1)); + CONTINUE; -- TCO + END; + WHEN a0sym = 'defmacro!' THEN + BEGIN + fn := mal.EVAL(types._nth(ast, 2), env); + fn := types._macro(fn); + RETURN envs.set(env, types._nth(ast, 1), fn); + END; + WHEN a0sym = 'macroexpand' THEN + BEGIN + RETURN mal.macroexpand(types._nth(ast, 1), env); + END; + WHEN a0sym = 'do' THEN + BEGIN + PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); + ast := types._nth(ast, types._count(ast)-1); + CONTINUE; -- TCO + END; + WHEN a0sym = 'if' THEN + BEGIN + cond := mal.EVAL(types._nth(ast, 1), env); + SELECT type_id INTO type FROM types.value WHERE value_id = cond; + IF type = 0 OR type = 1 THEN -- nil or false + IF types._count(ast) > 3 THEN + ast := types._nth(ast, 3); + CONTINUE; -- TCO + ELSE + RETURN 0; -- nil + END IF; + ELSE + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END IF; + END; + WHEN a0sym = 'fn*' THEN + BEGIN + RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); + END; + ELSE + BEGIN + el := mal.eval_ast(ast, env); + SELECT type_id, val_string, ast_id, params_id, env_id + INTO type, fname, fast, fparams, fenv + FROM types.value WHERE value_id = types._first(el); + args := types._restArray(el); + IF type = 11 THEN + EXECUTE format('SELECT %s($1);', fname) + INTO result USING args; + RETURN result; + ELSIF type = 12 THEN + env := envs.new(fenv, fparams, args); + ast := fast; + CONTINUE; -- TCO + ELSE + RAISE EXCEPTION 'Invalid function call'; + END IF; + END; + END CASE; + END LOOP; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +-- repl_env is environment 0 + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); +END; $$ LANGUAGE plpgsql; + +-- core.sql: defined using SQL (in core.sql) +-- repl_env is created and populated with core functions in by core.sql +CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN mal.EVAL(args[1], 0); +END; $$ LANGUAGE plpgsql; +INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); + +SELECT envs.vset(0, 'eval', + (SELECT value_id FROM types.value + WHERE val_string = 'mal.mal_eval')) \g '/dev/null' +-- *ARGV* values are set by RUN +SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' + + +-- core.mal: defined using the language itself +SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' +SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' +SELECT mal.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)))))))') \g '/dev/null' + +CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) + RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; + allargs integer; +BEGIN + PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); + + IF argstring IS NOT NULL THEN + allargs := mal.READ(argstring); + PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); + PERFORM mal.REP('(load-file ' || + printer.pr_str(types._first(allargs)) || ')'); + PERFORM io.close(1); + PERFORM io.wait_flushed(1); + RETURN 0; + END IF; + + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/step9_try.sql b/impls/plpgsql/step9_try.sql index b4dce3a5a3..db21abc839 100644 --- a/impls/plpgsql/step9_try.sql +++ b/impls/plpgsql/step9_try.sql @@ -1,382 +1,382 @@ --- --------------------------------------------------------- --- step9_try.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql -\i envs.sql -\i core.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval - -CREATE FUNCTION mal.qq_loop(elt integer, acc integer) RETURNS integer AS $$ -DECLARE - a0 integer; -BEGIN - IF types._list_Q(elt) AND types._count(elt) = 2 THEN - a0 := types._first(elt); - IF types._symbol_Q(a0) AND a0 = types._symbolv('splice-unquote') THEN - RETURN types._list(ARRAY[types._symbolv('concat'), types._nth(elt, 1), acc]); - END IF; - END IF; - RETURN types._list(ARRAY[types._symbolv('cons'), mal.quasiquote(elt), acc]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.qq_foldr(xs integer) RETURNS integer AS $$ -DECLARE - elt integer; - acc integer := types._list(ARRAY[]::integer[]); -BEGIN - FOREACH elt IN ARRAY types.array_reverse(types._valueToArray(xs)) LOOP - acc := mal.qq_loop(elt, acc); - END LOOP; - RETURN acc; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.quasiquote(ast integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 8 THEN -- list - BEGIN - IF types._count(ast) = 2 THEN - a0 := types._first(ast); - IF types._symbol_Q(a0) AND a0 = types._symbolv('unquote') THEN - RETURN types._nth(ast, 1); - END IF; - END IF; - RETURN mal.qq_foldr(ast); - END; - WHEN type = 9 THEN -- vector - BEGIN - RETURN types._list(ARRAY[types._symbolv('vec'), mal.qq_foldr(ast)]); - END; - WHEN type in (7, 10) THEN -- symbol or map - BEGIN - RETURN types._list(ARRAY[types._symbolv('quote'), ast]); - END; - ELSE - BEGIN - RETURN ast; - END; - END CASE; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.is_macro_call(ast integer, env integer) RETURNS boolean AS $$ -DECLARE - a0 integer; - f integer; - result boolean = false; -BEGIN - IF types._list_Q(ast) THEN - a0 = types._first(ast); - IF types._symbol_Q(a0) AND - envs.find(env, types._valueToString(a0)) IS NOT NULL THEN - f := envs.get(env, a0); - SELECT macro INTO result FROM types.value WHERE value_id = f; - END IF; - END IF; - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.macroexpand(ast integer, env integer) RETURNS integer AS $$ -DECLARE - mac integer; -BEGIN - WHILE mal.is_macro_call(ast, env) - LOOP - mac := envs.get(env, types._first(ast)); - ast := types._apply(mac, types._valueToArray(types._rest(ast))); - END LOOP; - RETURN ast; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - seq integer[]; - eseq integer[]; - hash hstore; - ehash hstore; - kv RECORD; - e integer; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 7 THEN - BEGIN - result := envs.get(env, ast); - END; - WHEN type IN (8, 9) THEN - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - -- Evaluate each entry creating a new sequence - FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP - eseq[i] := mal.EVAL(seq[i], env); - END LOOP; - INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) - RETURNING value_id INTO result; - END; - WHEN type = 10 THEN - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - -- Evaluate each value for every key/value - FOR kv IN SELECT * FROM each(hash) LOOP - e := mal.EVAL(CAST(kv.value AS integer), env); - IF ehash IS NULL THEN - ehash := hstore(kv.key, CAST(e AS varchar)); - ELSE - ehash := ehash || hstore(kv.key, CAST(e AS varchar)); - END IF; - END LOOP; - INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) - RETURNING value_id INTO result; - END; - ELSE - result := ast; - END CASE; - - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; - a0sym varchar; - a1 integer; - a2 integer; - let_env integer; - idx integer; - binds integer[]; - exprs integer[]; - el integer; - fn integer; - fname varchar; - args integer[]; - cond integer; - fast integer; - fparams integer; - fenv integer; - result integer; -BEGIN - LOOP - -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - - ast := mal.macroexpand(ast, env); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - IF types._count(ast) = 0 THEN - RETURN ast; - END IF; - - a0 := types._first(ast); - IF types._symbol_Q(a0) THEN - a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - BEGIN - RETURN envs.set(env, types._nth(ast, 1), - mal.EVAL(types._nth(ast, 2), env)); - END; - WHEN a0sym = 'let*' THEN - BEGIN - let_env := envs.new(env); - a1 := types._nth(ast, 1); - binds := (SELECT val_seq FROM types.value WHERE value_id = a1); - idx := 1; - WHILE idx < array_length(binds, 1) LOOP - PERFORM envs.set(let_env, binds[idx], - mal.EVAL(binds[idx+1], let_env)); - idx := idx + 2; - END LOOP; - env := let_env; - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END; - WHEN a0sym = 'quote' THEN - BEGIN - RETURN types._nth(ast, 1); - END; - WHEN a0sym = 'quasiquoteexpand' THEN - RETURN mal.quasiquote(types._nth(ast, 1)); - WHEN a0sym = 'quasiquote' THEN - BEGIN - ast := mal.quasiquote(types._nth(ast, 1)); - CONTINUE; -- TCO - END; - WHEN a0sym = 'defmacro!' THEN - BEGIN - fn := mal.EVAL(types._nth(ast, 2), env); - fn := types._macro(fn); - RETURN envs.set(env, types._nth(ast, 1), fn); - END; - WHEN a0sym = 'macroexpand' THEN - BEGIN - RETURN mal.macroexpand(types._nth(ast, 1), env); - END; - WHEN a0sym = 'try*' THEN - BEGIN - BEGIN - RETURN mal.EVAL(types._nth(ast, 1), env); - EXCEPTION WHEN OTHERS THEN - IF types._count(ast) >= 3 THEN - a2 = types._nth(ast, 2); - IF types._valueToString(types._nth(a2, 0)) = 'catch*' THEN - binds := ARRAY[types._nth(a2, 1)]; - exprs := ARRAY[types._stringv(SQLERRM)]; - env := envs.new(env, types._list(binds), exprs); - RETURN mal.EVAL(types._nth(a2, 2), env); - END IF; - END IF; - RAISE; - END; - END; - WHEN a0sym = 'do' THEN - BEGIN - PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); - ast := types._nth(ast, types._count(ast)-1); - CONTINUE; -- TCO - END; - WHEN a0sym = 'if' THEN - BEGIN - cond := mal.EVAL(types._nth(ast, 1), env); - SELECT type_id INTO type FROM types.value WHERE value_id = cond; - IF type = 0 OR type = 1 THEN -- nil or false - IF types._count(ast) > 3 THEN - ast := types._nth(ast, 3); - CONTINUE; -- TCO - ELSE - RETURN 0; -- nil - END IF; - ELSE - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END IF; - END; - WHEN a0sym = 'fn*' THEN - BEGIN - RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); - END; - ELSE - BEGIN - el := mal.eval_ast(ast, env); - SELECT type_id, val_string, ast_id, params_id, env_id - INTO type, fname, fast, fparams, fenv - FROM types.value WHERE value_id = types._first(el); - args := types._restArray(el); - IF type = 11 THEN - EXECUTE format('SELECT %s($1);', fname) - INTO result USING args; - RETURN result; - ELSIF type = 12 THEN - env := envs.new(fenv, fparams, args); - ast := fast; - CONTINUE; -- TCO - ELSE - RAISE EXCEPTION 'Invalid function call'; - END IF; - END; - END CASE; - END LOOP; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - --- repl_env is environment 0 - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); -END; $$ LANGUAGE plpgsql; - --- core.sql: defined using SQL (in core.sql) --- repl_env is created and populated with core functions in by core.sql -CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN mal.EVAL(args[1], 0); -END; $$ LANGUAGE plpgsql; -INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); - -SELECT envs.vset(0, 'eval', - (SELECT value_id FROM types.value - WHERE val_string = 'mal.mal_eval')) \g '/dev/null' --- *ARGV* values are set by RUN -SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' - - --- core.mal: defined using the language itself -SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' -SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' -SELECT mal.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)))))))') \g '/dev/null' - -CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) - RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; - allargs integer; -BEGIN - PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); - - IF argstring IS NOT NULL THEN - allargs := mal.READ(argstring); - PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); - PERFORM mal.REP('(load-file ' || - printer.pr_str(types._first(allargs)) || ')'); - PERFORM io.close(1); - PERFORM io.wait_flushed(1); - RETURN 0; - END IF; - - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- step9_try.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql +\i envs.sql +\i core.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval + +CREATE FUNCTION mal.qq_loop(elt integer, acc integer) RETURNS integer AS $$ +DECLARE + a0 integer; +BEGIN + IF types._list_Q(elt) AND types._count(elt) = 2 THEN + a0 := types._first(elt); + IF types._symbol_Q(a0) AND a0 = types._symbolv('splice-unquote') THEN + RETURN types._list(ARRAY[types._symbolv('concat'), types._nth(elt, 1), acc]); + END IF; + END IF; + RETURN types._list(ARRAY[types._symbolv('cons'), mal.quasiquote(elt), acc]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.qq_foldr(xs integer) RETURNS integer AS $$ +DECLARE + elt integer; + acc integer := types._list(ARRAY[]::integer[]); +BEGIN + FOREACH elt IN ARRAY types.array_reverse(types._valueToArray(xs)) LOOP + acc := mal.qq_loop(elt, acc); + END LOOP; + RETURN acc; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.quasiquote(ast integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 8 THEN -- list + BEGIN + IF types._count(ast) = 2 THEN + a0 := types._first(ast); + IF types._symbol_Q(a0) AND a0 = types._symbolv('unquote') THEN + RETURN types._nth(ast, 1); + END IF; + END IF; + RETURN mal.qq_foldr(ast); + END; + WHEN type = 9 THEN -- vector + BEGIN + RETURN types._list(ARRAY[types._symbolv('vec'), mal.qq_foldr(ast)]); + END; + WHEN type in (7, 10) THEN -- symbol or map + BEGIN + RETURN types._list(ARRAY[types._symbolv('quote'), ast]); + END; + ELSE + BEGIN + RETURN ast; + END; + END CASE; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.is_macro_call(ast integer, env integer) RETURNS boolean AS $$ +DECLARE + a0 integer; + f integer; + result boolean = false; +BEGIN + IF types._list_Q(ast) THEN + a0 = types._first(ast); + IF types._symbol_Q(a0) AND + envs.find(env, types._valueToString(a0)) IS NOT NULL THEN + f := envs.get(env, a0); + SELECT macro INTO result FROM types.value WHERE value_id = f; + END IF; + END IF; + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.macroexpand(ast integer, env integer) RETURNS integer AS $$ +DECLARE + mac integer; +BEGIN + WHILE mal.is_macro_call(ast, env) + LOOP + mac := envs.get(env, types._first(ast)); + ast := types._apply(mac, types._valueToArray(types._rest(ast))); + END LOOP; + RETURN ast; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + seq integer[]; + eseq integer[]; + hash hstore; + ehash hstore; + kv RECORD; + e integer; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 7 THEN + BEGIN + result := envs.get(env, ast); + END; + WHEN type IN (8, 9) THEN + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + -- Evaluate each entry creating a new sequence + FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP + eseq[i] := mal.EVAL(seq[i], env); + END LOOP; + INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) + RETURNING value_id INTO result; + END; + WHEN type = 10 THEN + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + -- Evaluate each value for every key/value + FOR kv IN SELECT * FROM each(hash) LOOP + e := mal.EVAL(CAST(kv.value AS integer), env); + IF ehash IS NULL THEN + ehash := hstore(kv.key, CAST(e AS varchar)); + ELSE + ehash := ehash || hstore(kv.key, CAST(e AS varchar)); + END IF; + END LOOP; + INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) + RETURNING value_id INTO result; + END; + ELSE + result := ast; + END CASE; + + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; + a0sym varchar; + a1 integer; + a2 integer; + let_env integer; + idx integer; + binds integer[]; + exprs integer[]; + el integer; + fn integer; + fname varchar; + args integer[]; + cond integer; + fast integer; + fparams integer; + fenv integer; + result integer; +BEGIN + LOOP + -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + + ast := mal.macroexpand(ast, env); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + IF types._count(ast) = 0 THEN + RETURN ast; + END IF; + + a0 := types._first(ast); + IF types._symbol_Q(a0) THEN + a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + BEGIN + RETURN envs.set(env, types._nth(ast, 1), + mal.EVAL(types._nth(ast, 2), env)); + END; + WHEN a0sym = 'let*' THEN + BEGIN + let_env := envs.new(env); + a1 := types._nth(ast, 1); + binds := (SELECT val_seq FROM types.value WHERE value_id = a1); + idx := 1; + WHILE idx < array_length(binds, 1) LOOP + PERFORM envs.set(let_env, binds[idx], + mal.EVAL(binds[idx+1], let_env)); + idx := idx + 2; + END LOOP; + env := let_env; + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END; + WHEN a0sym = 'quote' THEN + BEGIN + RETURN types._nth(ast, 1); + END; + WHEN a0sym = 'quasiquoteexpand' THEN + RETURN mal.quasiquote(types._nth(ast, 1)); + WHEN a0sym = 'quasiquote' THEN + BEGIN + ast := mal.quasiquote(types._nth(ast, 1)); + CONTINUE; -- TCO + END; + WHEN a0sym = 'defmacro!' THEN + BEGIN + fn := mal.EVAL(types._nth(ast, 2), env); + fn := types._macro(fn); + RETURN envs.set(env, types._nth(ast, 1), fn); + END; + WHEN a0sym = 'macroexpand' THEN + BEGIN + RETURN mal.macroexpand(types._nth(ast, 1), env); + END; + WHEN a0sym = 'try*' THEN + BEGIN + BEGIN + RETURN mal.EVAL(types._nth(ast, 1), env); + EXCEPTION WHEN OTHERS THEN + IF types._count(ast) >= 3 THEN + a2 = types._nth(ast, 2); + IF types._valueToString(types._nth(a2, 0)) = 'catch*' THEN + binds := ARRAY[types._nth(a2, 1)]; + exprs := ARRAY[types._stringv(SQLERRM)]; + env := envs.new(env, types._list(binds), exprs); + RETURN mal.EVAL(types._nth(a2, 2), env); + END IF; + END IF; + RAISE; + END; + END; + WHEN a0sym = 'do' THEN + BEGIN + PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); + ast := types._nth(ast, types._count(ast)-1); + CONTINUE; -- TCO + END; + WHEN a0sym = 'if' THEN + BEGIN + cond := mal.EVAL(types._nth(ast, 1), env); + SELECT type_id INTO type FROM types.value WHERE value_id = cond; + IF type = 0 OR type = 1 THEN -- nil or false + IF types._count(ast) > 3 THEN + ast := types._nth(ast, 3); + CONTINUE; -- TCO + ELSE + RETURN 0; -- nil + END IF; + ELSE + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END IF; + END; + WHEN a0sym = 'fn*' THEN + BEGIN + RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); + END; + ELSE + BEGIN + el := mal.eval_ast(ast, env); + SELECT type_id, val_string, ast_id, params_id, env_id + INTO type, fname, fast, fparams, fenv + FROM types.value WHERE value_id = types._first(el); + args := types._restArray(el); + IF type = 11 THEN + EXECUTE format('SELECT %s($1);', fname) + INTO result USING args; + RETURN result; + ELSIF type = 12 THEN + env := envs.new(fenv, fparams, args); + ast := fast; + CONTINUE; -- TCO + ELSE + RAISE EXCEPTION 'Invalid function call'; + END IF; + END; + END CASE; + END LOOP; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +-- repl_env is environment 0 + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); +END; $$ LANGUAGE plpgsql; + +-- core.sql: defined using SQL (in core.sql) +-- repl_env is created and populated with core functions in by core.sql +CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN mal.EVAL(args[1], 0); +END; $$ LANGUAGE plpgsql; +INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); + +SELECT envs.vset(0, 'eval', + (SELECT value_id FROM types.value + WHERE val_string = 'mal.mal_eval')) \g '/dev/null' +-- *ARGV* values are set by RUN +SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' + + +-- core.mal: defined using the language itself +SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' +SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' +SELECT mal.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)))))))') \g '/dev/null' + +CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) + RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; + allargs integer; +BEGIN + PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); + + IF argstring IS NOT NULL THEN + allargs := mal.READ(argstring); + PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); + PERFORM mal.REP('(load-file ' || + printer.pr_str(types._first(allargs)) || ')'); + PERFORM io.close(1); + PERFORM io.wait_flushed(1); + RETURN 0; + END IF; + + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/stepA_mal.sql b/impls/plpgsql/stepA_mal.sql index fc1e593829..287c48d6e8 100644 --- a/impls/plpgsql/stepA_mal.sql +++ b/impls/plpgsql/stepA_mal.sql @@ -1,384 +1,384 @@ --- --------------------------------------------------------- --- stepA_mal.sql - -\i init.sql -\i io.sql -\i types.sql -\i reader.sql -\i printer.sql -\i envs.sql -\i core.sql - --- --------------------------------------------------------- - -CREATE SCHEMA mal; - --- read -CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ -BEGIN - RETURN reader.read_str(line); -END; $$ LANGUAGE plpgsql; - --- eval - -CREATE FUNCTION mal.qq_loop(elt integer, acc integer) RETURNS integer AS $$ -DECLARE - a0 integer; -BEGIN - IF types._list_Q(elt) AND types._count(elt) = 2 THEN - a0 := types._first(elt); - IF types._symbol_Q(a0) AND a0 = types._symbolv('splice-unquote') THEN - RETURN types._list(ARRAY[types._symbolv('concat'), types._nth(elt, 1), acc]); - END IF; - END IF; - RETURN types._list(ARRAY[types._symbolv('cons'), mal.quasiquote(elt), acc]); -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.qq_foldr(xs integer) RETURNS integer AS $$ -DECLARE - elt integer; - acc integer := types._list(ARRAY[]::integer[]); -BEGIN - FOREACH elt IN ARRAY types.array_reverse(types._valueToArray(xs)) LOOP - acc := mal.qq_loop(elt, acc); - END LOOP; - RETURN acc; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.quasiquote(ast integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 8 THEN -- list - BEGIN - IF types._count(ast) = 2 THEN - a0 := types._first(ast); - IF types._symbol_Q(a0) AND a0 = types._symbolv('unquote') THEN - RETURN types._nth(ast, 1); - END IF; - END IF; - RETURN mal.qq_foldr(ast); - END; - WHEN type = 9 THEN -- vector - BEGIN - RETURN types._list(ARRAY[types._symbolv('vec'), mal.qq_foldr(ast)]); - END; - WHEN type in (7, 10) THEN -- symbol or map - BEGIN - RETURN types._list(ARRAY[types._symbolv('quote'), ast]); - END; - ELSE - BEGIN - RETURN ast; - END; - END CASE; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.is_macro_call(ast integer, env integer) RETURNS boolean AS $$ -DECLARE - a0 integer; - f integer; - result boolean = false; -BEGIN - IF types._list_Q(ast) THEN - a0 = types._first(ast); - IF types._symbol_Q(a0) AND - envs.find(env, types._valueToString(a0)) IS NOT NULL THEN - f := envs.get(env, a0); - SELECT macro INTO result FROM types.value WHERE value_id = f; - END IF; - END IF; - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.macroexpand(ast integer, env integer) RETURNS integer AS $$ -DECLARE - mac integer; -BEGIN - WHILE mal.is_macro_call(ast, env) - LOOP - mac := envs.get(env, types._first(ast)); - ast := types._apply(mac, types._valueToArray(types._rest(ast))); - END LOOP; - RETURN ast; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - seq integer[]; - eseq integer[]; - hash hstore; - ehash hstore; - kv RECORD; - e integer; - result integer; -BEGIN - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - CASE - WHEN type = 7 THEN - BEGIN - result := envs.get(env, ast); - END; - WHEN type IN (8, 9) THEN - BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; - -- Evaluate each entry creating a new sequence - FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP - eseq[i] := mal.EVAL(seq[i], env); - END LOOP; - INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) - RETURNING value_id INTO result; - END; - WHEN type = 10 THEN - BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; - -- Evaluate each value for every key/value - FOR kv IN SELECT * FROM each(hash) LOOP - e := mal.EVAL(CAST(kv.value AS integer), env); - IF ehash IS NULL THEN - ehash := hstore(kv.key, CAST(e AS varchar)); - ELSE - ehash := ehash || hstore(kv.key, CAST(e AS varchar)); - END IF; - END LOOP; - INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) - RETURNING value_id INTO result; - END; - ELSE - result := ast; - END CASE; - - RETURN result; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ -DECLARE - type integer; - a0 integer; - a0sym varchar; - a1 integer; - a2 integer; - let_env integer; - idx integer; - binds integer[]; - exprs integer[]; - el integer; - fn integer; - fname varchar; - args integer[]; - cond integer; - fast integer; - fparams integer; - fenv integer; - result integer; -BEGIN - LOOP - -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - - ast := mal.macroexpand(ast, env); - SELECT type_id INTO type FROM types.value WHERE value_id = ast; - IF type <> 8 THEN - RETURN mal.eval_ast(ast, env); - END IF; - IF types._count(ast) = 0 THEN - RETURN ast; - END IF; - - a0 := types._first(ast); - IF types._symbol_Q(a0) THEN - a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - BEGIN - RETURN envs.set(env, types._nth(ast, 1), - mal.EVAL(types._nth(ast, 2), env)); - END; - WHEN a0sym = 'let*' THEN - BEGIN - let_env := envs.new(env); - a1 := types._nth(ast, 1); - binds := (SELECT val_seq FROM types.value WHERE value_id = a1); - idx := 1; - WHILE idx < array_length(binds, 1) LOOP - PERFORM envs.set(let_env, binds[idx], - mal.EVAL(binds[idx+1], let_env)); - idx := idx + 2; - END LOOP; - env := let_env; - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END; - WHEN a0sym = 'quote' THEN - BEGIN - RETURN types._nth(ast, 1); - END; - WHEN a0sym = 'quasiquoteexpand' THEN - RETURN mal.quasiquote(types._nth(ast, 1)); - WHEN a0sym = 'quasiquote' THEN - BEGIN - ast := mal.quasiquote(types._nth(ast, 1)); - CONTINUE; -- TCO - END; - WHEN a0sym = 'defmacro!' THEN - BEGIN - fn := mal.EVAL(types._nth(ast, 2), env); - fn := types._macro(fn); - RETURN envs.set(env, types._nth(ast, 1), fn); - END; - WHEN a0sym = 'macroexpand' THEN - BEGIN - RETURN mal.macroexpand(types._nth(ast, 1), env); - END; - WHEN a0sym = 'try*' THEN - BEGIN - BEGIN - RETURN mal.EVAL(types._nth(ast, 1), env); - EXCEPTION WHEN OTHERS THEN - IF types._count(ast) >= 3 THEN - a2 = types._nth(ast, 2); - IF types._valueToString(types._nth(a2, 0)) = 'catch*' THEN - binds := ARRAY[types._nth(a2, 1)]; - exprs := ARRAY[types._stringv(SQLERRM)]; - env := envs.new(env, types._list(binds), exprs); - RETURN mal.EVAL(types._nth(a2, 2), env); - END IF; - END IF; - RAISE; - END; - END; - WHEN a0sym = 'do' THEN - BEGIN - PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); - ast := types._nth(ast, types._count(ast)-1); - CONTINUE; -- TCO - END; - WHEN a0sym = 'if' THEN - BEGIN - cond := mal.EVAL(types._nth(ast, 1), env); - SELECT type_id INTO type FROM types.value WHERE value_id = cond; - IF type = 0 OR type = 1 THEN -- nil or false - IF types._count(ast) > 3 THEN - ast := types._nth(ast, 3); - CONTINUE; -- TCO - ELSE - RETURN 0; -- nil - END IF; - ELSE - ast := types._nth(ast, 2); - CONTINUE; -- TCO - END IF; - END; - WHEN a0sym = 'fn*' THEN - BEGIN - RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); - END; - ELSE - BEGIN - el := mal.eval_ast(ast, env); - SELECT type_id, val_string, ast_id, params_id, env_id - INTO type, fname, fast, fparams, fenv - FROM types.value WHERE value_id = types._first(el); - args := types._restArray(el); - IF type = 11 THEN - EXECUTE format('SELECT %s($1);', fname) - INTO result USING args; - RETURN result; - ELSIF type = 12 THEN - env := envs.new(fenv, fparams, args); - ast := fast; - CONTINUE; -- TCO - ELSE - RAISE EXCEPTION 'Invalid function call'; - END IF; - END; - END CASE; - END LOOP; -END; $$ LANGUAGE plpgsql; - --- print -CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ -BEGIN - RETURN printer.pr_str(exp); -END; $$ LANGUAGE plpgsql; - - --- repl - --- repl_env is environment 0 - -CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ -BEGIN - RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); -END; $$ LANGUAGE plpgsql; - --- core.sql: defined using SQL (in core.sql) --- repl_env is created and populated with core functions in by core.sql -CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ -BEGIN - RETURN mal.EVAL(args[1], 0); -END; $$ LANGUAGE plpgsql; -INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); - -SELECT envs.vset(0, 'eval', - (SELECT value_id FROM types.value - WHERE val_string = 'mal.mal_eval')) \g '/dev/null' --- *ARGV* values are set by RUN -SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' - - --- core.mal: defined using the language itself -SELECT mal.REP('(def! *host-language* "plpqsql")') \g '/dev/null' -SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' -SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' -SELECT mal.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)))))))') \g '/dev/null' - -CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) - RETURNS integer AS $$ -DECLARE - line varchar; - output varchar; - allargs integer; -BEGIN - PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); - - IF argstring IS NOT NULL THEN - allargs := mal.READ(argstring); - PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); - PERFORM mal.REP('(load-file ' || - printer.pr_str(types._first(allargs)) || ')'); - PERFORM io.close(1); - PERFORM io.wait_flushed(1); - RETURN 0; - END IF; - - PERFORM mal.REP('(println (str "Mal [" *host-language* "]"))'); - WHILE true - LOOP - BEGIN - line := io.readline('user> ', 0); - IF line IS NULL THEN - PERFORM io.close(1); - RETURN 0; - END IF; - IF line NOT IN ('', E'\n') THEN - output := mal.REP(line); - PERFORM io.writeline(output); - END IF; - - EXCEPTION WHEN OTHERS THEN - PERFORM io.writeline('Error: ' || SQLERRM); - END; - END LOOP; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- stepA_mal.sql + +\i init.sql +\i io.sql +\i types.sql +\i reader.sql +\i printer.sql +\i envs.sql +\i core.sql + +-- --------------------------------------------------------- + +CREATE SCHEMA mal; + +-- read +CREATE FUNCTION mal.READ(line varchar) RETURNS integer AS $$ +BEGIN + RETURN reader.read_str(line); +END; $$ LANGUAGE plpgsql; + +-- eval + +CREATE FUNCTION mal.qq_loop(elt integer, acc integer) RETURNS integer AS $$ +DECLARE + a0 integer; +BEGIN + IF types._list_Q(elt) AND types._count(elt) = 2 THEN + a0 := types._first(elt); + IF types._symbol_Q(a0) AND a0 = types._symbolv('splice-unquote') THEN + RETURN types._list(ARRAY[types._symbolv('concat'), types._nth(elt, 1), acc]); + END IF; + END IF; + RETURN types._list(ARRAY[types._symbolv('cons'), mal.quasiquote(elt), acc]); +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.qq_foldr(xs integer) RETURNS integer AS $$ +DECLARE + elt integer; + acc integer := types._list(ARRAY[]::integer[]); +BEGIN + FOREACH elt IN ARRAY types.array_reverse(types._valueToArray(xs)) LOOP + acc := mal.qq_loop(elt, acc); + END LOOP; + RETURN acc; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.quasiquote(ast integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 8 THEN -- list + BEGIN + IF types._count(ast) = 2 THEN + a0 := types._first(ast); + IF types._symbol_Q(a0) AND a0 = types._symbolv('unquote') THEN + RETURN types._nth(ast, 1); + END IF; + END IF; + RETURN mal.qq_foldr(ast); + END; + WHEN type = 9 THEN -- vector + BEGIN + RETURN types._list(ARRAY[types._symbolv('vec'), mal.qq_foldr(ast)]); + END; + WHEN type in (7, 10) THEN -- symbol or map + BEGIN + RETURN types._list(ARRAY[types._symbolv('quote'), ast]); + END; + ELSE + BEGIN + RETURN ast; + END; + END CASE; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.is_macro_call(ast integer, env integer) RETURNS boolean AS $$ +DECLARE + a0 integer; + f integer; + result boolean = false; +BEGIN + IF types._list_Q(ast) THEN + a0 = types._first(ast); + IF types._symbol_Q(a0) AND + envs.find(env, types._valueToString(a0)) IS NOT NULL THEN + f := envs.get(env, a0); + SELECT macro INTO result FROM types.value WHERE value_id = f; + END IF; + END IF; + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.macroexpand(ast integer, env integer) RETURNS integer AS $$ +DECLARE + mac integer; +BEGIN + WHILE mal.is_macro_call(ast, env) + LOOP + mac := envs.get(env, types._first(ast)); + ast := types._apply(mac, types._valueToArray(types._rest(ast))); + END LOOP; + RETURN ast; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.eval_ast(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + seq integer[]; + eseq integer[]; + hash hstore; + ehash hstore; + kv RECORD; + e integer; + result integer; +BEGIN + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + CASE + WHEN type = 7 THEN + BEGIN + result := envs.get(env, ast); + END; + WHEN type IN (8, 9) THEN + BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = ast; + -- Evaluate each entry creating a new sequence + FOR i IN 1 .. COALESCE(array_length(seq, 1), 0) LOOP + eseq[i] := mal.EVAL(seq[i], env); + END LOOP; + INSERT INTO types.value (type_id, val_seq) VALUES (type, eseq) + RETURNING value_id INTO result; + END; + WHEN type = 10 THEN + BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = ast; + -- Evaluate each value for every key/value + FOR kv IN SELECT * FROM each(hash) LOOP + e := mal.EVAL(CAST(kv.value AS integer), env); + IF ehash IS NULL THEN + ehash := hstore(kv.key, CAST(e AS varchar)); + ELSE + ehash := ehash || hstore(kv.key, CAST(e AS varchar)); + END IF; + END LOOP; + INSERT INTO types.value (type_id, val_hash) VALUES (type, ehash) + RETURNING value_id INTO result; + END; + ELSE + result := ast; + END CASE; + + RETURN result; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION mal.EVAL(ast integer, env integer) RETURNS integer AS $$ +DECLARE + type integer; + a0 integer; + a0sym varchar; + a1 integer; + a2 integer; + let_env integer; + idx integer; + binds integer[]; + exprs integer[]; + el integer; + fn integer; + fname varchar; + args integer[]; + cond integer; + fast integer; + fparams integer; + fenv integer; + result integer; +BEGIN + LOOP + -- PERFORM writeline(format('EVAL: %s [%s]', pr_str(ast), ast)); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + + ast := mal.macroexpand(ast, env); + SELECT type_id INTO type FROM types.value WHERE value_id = ast; + IF type <> 8 THEN + RETURN mal.eval_ast(ast, env); + END IF; + IF types._count(ast) = 0 THEN + RETURN ast; + END IF; + + a0 := types._first(ast); + IF types._symbol_Q(a0) THEN + a0sym := (SELECT val_string FROM types.value WHERE value_id = a0); + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + BEGIN + RETURN envs.set(env, types._nth(ast, 1), + mal.EVAL(types._nth(ast, 2), env)); + END; + WHEN a0sym = 'let*' THEN + BEGIN + let_env := envs.new(env); + a1 := types._nth(ast, 1); + binds := (SELECT val_seq FROM types.value WHERE value_id = a1); + idx := 1; + WHILE idx < array_length(binds, 1) LOOP + PERFORM envs.set(let_env, binds[idx], + mal.EVAL(binds[idx+1], let_env)); + idx := idx + 2; + END LOOP; + env := let_env; + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END; + WHEN a0sym = 'quote' THEN + BEGIN + RETURN types._nth(ast, 1); + END; + WHEN a0sym = 'quasiquoteexpand' THEN + RETURN mal.quasiquote(types._nth(ast, 1)); + WHEN a0sym = 'quasiquote' THEN + BEGIN + ast := mal.quasiquote(types._nth(ast, 1)); + CONTINUE; -- TCO + END; + WHEN a0sym = 'defmacro!' THEN + BEGIN + fn := mal.EVAL(types._nth(ast, 2), env); + fn := types._macro(fn); + RETURN envs.set(env, types._nth(ast, 1), fn); + END; + WHEN a0sym = 'macroexpand' THEN + BEGIN + RETURN mal.macroexpand(types._nth(ast, 1), env); + END; + WHEN a0sym = 'try*' THEN + BEGIN + BEGIN + RETURN mal.EVAL(types._nth(ast, 1), env); + EXCEPTION WHEN OTHERS THEN + IF types._count(ast) >= 3 THEN + a2 = types._nth(ast, 2); + IF types._valueToString(types._nth(a2, 0)) = 'catch*' THEN + binds := ARRAY[types._nth(a2, 1)]; + exprs := ARRAY[types._stringv(SQLERRM)]; + env := envs.new(env, types._list(binds), exprs); + RETURN mal.EVAL(types._nth(a2, 2), env); + END IF; + END IF; + RAISE; + END; + END; + WHEN a0sym = 'do' THEN + BEGIN + PERFORM mal.eval_ast(types._slice(ast, 1, types._count(ast)-1), env); + ast := types._nth(ast, types._count(ast)-1); + CONTINUE; -- TCO + END; + WHEN a0sym = 'if' THEN + BEGIN + cond := mal.EVAL(types._nth(ast, 1), env); + SELECT type_id INTO type FROM types.value WHERE value_id = cond; + IF type = 0 OR type = 1 THEN -- nil or false + IF types._count(ast) > 3 THEN + ast := types._nth(ast, 3); + CONTINUE; -- TCO + ELSE + RETURN 0; -- nil + END IF; + ELSE + ast := types._nth(ast, 2); + CONTINUE; -- TCO + END IF; + END; + WHEN a0sym = 'fn*' THEN + BEGIN + RETURN types._malfunc(types._nth(ast, 2), types._nth(ast, 1), env); + END; + ELSE + BEGIN + el := mal.eval_ast(ast, env); + SELECT type_id, val_string, ast_id, params_id, env_id + INTO type, fname, fast, fparams, fenv + FROM types.value WHERE value_id = types._first(el); + args := types._restArray(el); + IF type = 11 THEN + EXECUTE format('SELECT %s($1);', fname) + INTO result USING args; + RETURN result; + ELSIF type = 12 THEN + env := envs.new(fenv, fparams, args); + ast := fast; + CONTINUE; -- TCO + ELSE + RAISE EXCEPTION 'Invalid function call'; + END IF; + END; + END CASE; + END LOOP; +END; $$ LANGUAGE plpgsql; + +-- print +CREATE FUNCTION mal.PRINT(exp integer) RETURNS varchar AS $$ +BEGIN + RETURN printer.pr_str(exp); +END; $$ LANGUAGE plpgsql; + + +-- repl + +-- repl_env is environment 0 + +CREATE FUNCTION mal.REP(line varchar) RETURNS varchar AS $$ +BEGIN + RETURN mal.PRINT(mal.EVAL(mal.READ(line), 0)); +END; $$ LANGUAGE plpgsql; + +-- core.sql: defined using SQL (in core.sql) +-- repl_env is created and populated with core functions in by core.sql +CREATE FUNCTION mal.mal_eval(args integer[]) RETURNS integer AS $$ +BEGIN + RETURN mal.EVAL(args[1], 0); +END; $$ LANGUAGE plpgsql; +INSERT INTO types.value (type_id, val_string) VALUES (11, 'mal.mal_eval'); + +SELECT envs.vset(0, 'eval', + (SELECT value_id FROM types.value + WHERE val_string = 'mal.mal_eval')) \g '/dev/null' +-- *ARGV* values are set by RUN +SELECT envs.vset(0, '*ARGV*', mal.READ('()')) \g '/dev/null' + + +-- core.mal: defined using the language itself +SELECT mal.REP('(def! *host-language* "plpqsql")') \g '/dev/null' +SELECT mal.REP('(def! not (fn* (a) (if a false true)))') \g '/dev/null' +SELECT mal.REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') \g '/dev/null' +SELECT mal.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)))))))') \g '/dev/null' + +CREATE FUNCTION mal.MAIN(pwd varchar, argstring varchar DEFAULT NULL) + RETURNS integer AS $$ +DECLARE + line varchar; + output varchar; + allargs integer; +BEGIN + PERFORM envs.vset(0, '*PWD*', types._stringv(pwd)); + + IF argstring IS NOT NULL THEN + allargs := mal.READ(argstring); + PERFORM envs.vset(0, '*ARGV*', types._rest(allargs)); + PERFORM mal.REP('(load-file ' || + printer.pr_str(types._first(allargs)) || ')'); + PERFORM io.close(1); + PERFORM io.wait_flushed(1); + RETURN 0; + END IF; + + PERFORM mal.REP('(println (str "Mal [" *host-language* "]"))'); + WHILE true + LOOP + BEGIN + line := io.readline('user> ', 0); + IF line IS NULL THEN + PERFORM io.close(1); + RETURN 0; + END IF; + IF line NOT IN ('', E'\n') THEN + output := mal.REP(line); + PERFORM io.writeline(output); + END IF; + + EXCEPTION WHEN OTHERS THEN + PERFORM io.writeline('Error: ' || SQLERRM); + END; + END LOOP; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/types.sql b/impls/plpgsql/types.sql index a6cb67d1e6..935c4683e8 100644 --- a/impls/plpgsql/types.sql +++ b/impls/plpgsql/types.sql @@ -1,703 +1,703 @@ --- --------------------------------------------------------- --- persistent values - --- list of types for type_id --- 0: nil --- 1: false --- 2: true --- 3: integer --- 4: float --- 5: string --- 6: keyword (not used, uses prefixed string) --- 7: symbol --- 8: list --- 9: vector --- 10: hashmap --- 11: function --- 12: malfunc --- 13: atom - -CREATE SCHEMA types - - CREATE SEQUENCE value_id_seq START WITH 3 -- skip nil, false, true - - CREATE TABLE value ( - value_id integer NOT NULL DEFAULT nextval('value_id_seq'), - type_id integer NOT NULL, - val_int bigint, -- set for integers - val_string varchar, -- set for strings, keywords, symbols, - -- and native functions (function name) - val_seq integer[], -- set for lists and vectors - val_hash hstore, -- set for hash-maps - ast_id integer, -- set for malfunc - params_id integer, -- set for malfunc - env_id integer, -- set for malfunc - macro boolean, -- set for malfunc - meta_id integer -- can be set for any collection - ); - -ALTER TABLE types.value ADD CONSTRAINT pk_value_id - PRIMARY KEY (value_id); --- drop sequence when table dropped -ALTER SEQUENCE types.value_id_seq OWNED BY types.value.value_id; -ALTER TABLE types.value ADD CONSTRAINT fk_meta_id - FOREIGN KEY (meta_id) REFERENCES types.value(value_id); -ALTER TABLE types.value ADD CONSTRAINT fk_params_id - FOREIGN KEY (params_id) REFERENCES types.value(value_id); - -CREATE INDEX ON types.value (value_id, type_id); - -INSERT INTO types.value (value_id, type_id) VALUES (0, 0); -- nil -INSERT INTO types.value (value_id, type_id) VALUES (1, 1); -- false -INSERT INTO types.value (value_id, type_id) VALUES (2, 2); -- true - - --- --------------------------------------------------------- --- general functions - -CREATE FUNCTION types._wraptf(val boolean) RETURNS integer AS $$ -BEGIN - IF val THEN - RETURN 2; - ELSE - RETURN 1; - END IF; -END; $$ LANGUAGE plpgsql IMMUTABLE; - --- pun both NULL and false to false -CREATE FUNCTION types._tf(val boolean) RETURNS boolean AS $$ -BEGIN - IF val IS NULL OR val = false THEN - RETURN false; - END IF; - RETURN true; -END; $$ LANGUAGE plpgsql IMMUTABLE; - --- pun both NULL and 0 to false -CREATE FUNCTION types._tf(val integer) RETURNS boolean AS $$ -BEGIN - IF val IS NULL OR val = 0 THEN - RETURN false; - END IF; - RETURN true; -END; $$ LANGUAGE plpgsql IMMUTABLE; - --- return the type of the given value_id -CREATE FUNCTION types._type(obj integer) RETURNS integer AS $$ -BEGIN - RETURN (SELECT type_id FROM types.value WHERE value_id = obj); -END; $$ LANGUAGE plpgsql; - - -CREATE FUNCTION types._equal_Q(a integer, b integer) RETURNS boolean AS $$ -DECLARE - atype integer; - btype integer; - anum bigint; - bnum bigint; - avid integer; - bvid integer; - aseq integer[]; - bseq integer[]; - ahash hstore; - bhash hstore; - kv RECORD; - i integer; -BEGIN - atype := types._type(a); - btype := types._type(b); - IF NOT ((atype = btype) OR - (types._sequential_Q(a) AND types._sequential_Q(b))) THEN - RETURN false; - END IF; - CASE - WHEN atype = 3 THEN -- integer - SELECT val_int FROM types.value INTO anum WHERE value_id = a; - SELECT val_int FROM types.value INTO bnum WHERE value_id = b; - RETURN anum = bnum; - WHEN atype = 5 OR atype = 7 THEN -- string/symbol - RETURN types._valueToString(a) = types._valueToString(b); - WHEN atype IN (8, 9) THEN -- list/vector - IF types._count(a) <> types._count(b) THEN - RETURN false; - END IF; - SELECT val_seq INTO aseq FROM types.value WHERE value_id = a; - SELECT val_seq INTO bseq FROM types.value WHERE value_id = b; - FOR i IN 1 .. types._count(a) - LOOP - IF NOT types._equal_Q(aseq[i], bseq[i]) THEN - return false; - END IF; - END LOOP; - RETURN true; - WHEN atype = 10 THEN -- hash-map - SELECT val_hash INTO ahash FROM types.value WHERE value_id = a; - SELECT val_hash INTO bhash FROM types.value WHERE value_id = b; - IF array_length(akeys(ahash), 1) <> array_length(akeys(bhash), 1) THEN - RETURN false; - END IF; - FOR kv IN SELECT * FROM each(ahash) LOOP - avid := CAST((ahash -> kv.key) AS integer); - bvid := CAST((bhash -> kv.key) AS integer); - IF bvid IS NULL OR NOT types._equal_Q(avid, bvid) THEN - return false; - END IF; - END LOOP; - RETURN true; - ELSE - RETURN a = b; - END CASE; -END; $$ LANGUAGE plpgsql; - - --- _clone: --- take a value_id of a collection --- returns a new value_id of a cloned collection -CREATE FUNCTION types._clone(id integer) RETURNS integer AS $$ -DECLARE - result integer; -BEGIN - INSERT INTO types.value (type_id,val_int,val_string,val_seq,val_hash, - ast_id,params_id,env_id,meta_id) - (SELECT type_id,val_int,val_string,val_seq,val_hash, - ast_id,params_id,env_id,meta_id - FROM types.value - WHERE value_id = id) - RETURNING value_id INTO result; - RETURN result; -END; $$ LANGUAGE plpgsql; - - --- --------------------------------------------------------- --- scalar functions - - --- _nil_Q: --- takes a value_id --- returns the whether value_id is nil -CREATE FUNCTION types._nil_Q(id integer) RETURNS boolean AS $$ -BEGIN - RETURN id = 0; -END; $$ LANGUAGE plpgsql IMMUTABLE; - --- _true_Q: --- takes a value_id --- returns the whether value_id is true -CREATE FUNCTION types._true_Q(id integer) RETURNS boolean AS $$ -BEGIN - RETURN id = 2; -END; $$ LANGUAGE plpgsql IMMUTABLE; - --- _false_Q: --- takes a value_id --- returns the whether value_id is false -CREATE FUNCTION types._false_Q(id integer) RETURNS boolean AS $$ -BEGIN - RETURN id = 1; -END; $$ LANGUAGE plpgsql IMMUTABLE; - --- _string_Q: --- takes a value_id --- returns the whether value_id is string type -CREATE FUNCTION types._string_Q(id integer) RETURNS boolean AS $$ -BEGIN - IF (SELECT 1 FROM types.value WHERE type_id = 5 AND value_id = id) THEN - RETURN NOT types._keyword_Q(id); - END IF; - RETURN false; -END; $$ LANGUAGE plpgsql; - --- _number_Q: --- takes a value_id --- returns the whether value_id is integer or float type -CREATE FUNCTION types._number_Q(id integer) RETURNS boolean AS $$ -BEGIN - RETURN types._tf((SELECT 1 FROM types.value - WHERE (type_id = 3 OR type_id = 4) - AND value_id = id)); -END; $$ LANGUAGE plpgsql; - --- _valueToString: --- takes a value_id for a string --- returns the varchar value of the string -CREATE FUNCTION types._valueToString(sid integer) RETURNS varchar AS $$ -BEGIN - RETURN (SELECT val_string FROM types.value WHERE value_id = sid); -END; $$ LANGUAGE plpgsql; - --- _stringish: --- takes a varchar string --- returns the value_id of a stringish type (string, symbol, keyword) -CREATE FUNCTION types._stringish(str varchar, type integer) RETURNS integer AS $$ -DECLARE - result integer; -BEGIN - -- TODO: share string data between string types - -- lookup if it exists - SELECT value_id FROM types.value INTO result - WHERE val_string = str AND type_id = type; - IF result IS NULL THEN - -- Create string entry - INSERT INTO types.value (type_id, val_string) - VALUES (type, str) - RETURNING value_id INTO result; - END IF; - RETURN result; -END; $$ LANGUAGE plpgsql; - --- _stringv: --- takes a varchar string --- returns the value_id of a string (new or existing) -CREATE FUNCTION types._stringv(str varchar) RETURNS integer AS $$ -BEGIN - RETURN types._stringish(str, 5); -END; $$ LANGUAGE plpgsql; - --- _keywordv: --- takes a varchar string --- returns the value_id of a keyword (new or existing) -CREATE FUNCTION types._keywordv(name varchar) RETURNS integer AS $$ -BEGIN - RETURN types._stringish(chr(CAST(x'7f' AS integer)) || name, 5); -END; $$ LANGUAGE plpgsql; - --- _keyword_Q: --- takes a value_id --- returns the whether value_id is keyword type -CREATE FUNCTION types._keyword_Q(id integer) RETURNS boolean AS $$ -DECLARE - str varchar; -BEGIN - IF (SELECT 1 FROM types.value WHERE type_id = 5 AND value_id = id) THEN - str := types._valueToString(id); - IF char_length(str) > 0 AND - chr(CAST(x'7f' AS integer)) = substring(str FROM 1 FOR 1) THEN - RETURN true; - END IF; - END IF; - RETURN false; -END; $$ LANGUAGE plpgsql; - --- _symbolv: --- takes a varchar string --- returns the value_id of a symbol (new or existing) -CREATE FUNCTION types._symbolv(name varchar) RETURNS integer AS $$ -BEGIN - RETURN types._stringish(name, 7); -END; $$ LANGUAGE plpgsql; - --- _symbol_Q: --- takes a value_id --- returns the whether value_id is symbol type -CREATE FUNCTION types._symbol_Q(id integer) RETURNS boolean AS $$ -BEGIN - RETURN types._tf((SELECT 1 FROM types.value - WHERE type_id = 7 AND value_id = id)); -END; $$ LANGUAGE plpgsql; - --- _numToValue: --- takes an bigint number --- returns the value_id for the number -CREATE FUNCTION types._numToValue(num bigint) RETURNS integer AS $$ -DECLARE - result integer; -BEGIN - SELECT value_id FROM types.value INTO result - WHERE val_int = num AND type_id = 3; - IF result IS NULL THEN - -- Create an integer entry - INSERT INTO types.value (type_id, val_int) - VALUES (3, num) - RETURNING value_id INTO result; - END IF; - RETURN result; -END; $$ LANGUAGE plpgsql; - --- _fn_Q: --- takes a value_id --- returns the whether value_id is a function -CREATE FUNCTION types._fn_Q(id integer) RETURNS boolean AS $$ -BEGIN - RETURN types._tf((SELECT 1 FROM types.value - WHERE (type_id = 11 OR type_id = 12) - AND macro IS NULL - AND value_id = id)); -END; $$ LANGUAGE plpgsql; - --- _macro_Q: --- takes a value_id --- returns the whether value_id is a macro -CREATE FUNCTION types._macro_Q(id integer) RETURNS boolean AS $$ -BEGIN - RETURN types._tf((SELECT 1 FROM types.value - WHERE type_id = 12 - AND macro IS TRUE - AND value_id = id)); -END; $$ LANGUAGE plpgsql; - --- --------------------------------------------------------- --- sequence functions - --- _sequential_Q: --- return true if obj value_id is a list or vector -CREATE FUNCTION types._sequential_Q(obj integer) RETURNS boolean AS $$ -BEGIN - RETURN types._tf((SELECT 1 FROM types.value - WHERE value_id = obj AND (type_id = 8 OR type_id = 9))); -END; $$ LANGUAGE plpgsql; - --- _collection: --- takes a array of value_id integers --- returns the value_id of a new list (8), vector (9) or hash-map (10) -CREATE FUNCTION types._collection(items integer[], type integer) RETURNS integer AS $$ -DECLARE - vid integer; -BEGIN - IF type IN (8, 9) THEN - INSERT INTO types.value (type_id, val_seq) - VALUES (type, items) - RETURNING value_id INTO vid; - ELSIF type = 10 THEN - IF (array_length(items, 1) % 2) = 1 THEN - RAISE EXCEPTION 'hash-map: odd number of arguments'; - END IF; - INSERT INTO types.value (type_id, val_hash) - VALUES (type, hstore(CAST(items AS varchar[]))) - RETURNING value_id INTO vid; - END IF; - RETURN vid; -END; $$ LANGUAGE plpgsql; - - --- _list: --- takes a array of value_id integers --- returns the value_id of a new list -CREATE FUNCTION types._list(items integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._collection(items, 8); -END; $$ LANGUAGE plpgsql; - --- _vector: --- takes a array of value_id integers --- returns the value_id of a new list -CREATE FUNCTION types._vector(items integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._collection(items, 9); -END; $$ LANGUAGE plpgsql; - --- _list_Q: --- return true if obj value_id is a list -CREATE FUNCTION types._list_Q(obj integer) RETURNS boolean AS $$ -BEGIN - RETURN types._tf((SELECT 1 FROM types.value - WHERE value_id = obj and type_id = 8)); -END; $$ LANGUAGE plpgsql; - --- _vector_Q: --- return true if obj value_id is a list -CREATE FUNCTION types._vector_Q(obj integer) RETURNS boolean AS $$ -BEGIN - RETURN types._tf((SELECT 1 FROM types.value - WHERE value_id = obj and type_id = 9)); -END; $$ LANGUAGE plpgsql; - - --- _valueToArray: --- takes an value_id referring to a list or vector --- returns an array of the value_ids from the list/vector -CREATE FUNCTION types._valueToArray(seq integer) RETURNS integer[] AS $$ -DECLARE - result integer[]; -BEGIN - result := (SELECT val_seq FROM types.value WHERE value_id = seq); - IF result IS NULL THEN - result := ARRAY[]::integer[]; - END IF; - RETURN result; -END; $$ LANGUAGE plpgsql; - --- From: https://wiki.postgresql.org/wiki/Array_reverse -CREATE FUNCTION types.array_reverse(a integer[]) RETURNS integer[] AS $$ -SELECT ARRAY( - SELECT a[i] - FROM generate_subscripts(a,1) AS s(i) - ORDER BY i DESC -); -$$ LANGUAGE 'sql' STRICT IMMUTABLE; - - --- _nth: --- takes value_id and an index --- returns the value_id of nth element in list/vector -CREATE FUNCTION types._nth(seq_id integer, indx integer) RETURNS integer AS $$ -DECLARE - result integer; -BEGIN - RETURN (SELECT val_seq[indx+1] FROM types.value WHERE value_id = seq_id); -END; $$ LANGUAGE plpgsql; - --- _first: --- takes value_id --- returns the value_id of first element in list/vector -CREATE FUNCTION types._first(seq_id integer) RETURNS integer AS $$ -BEGIN - RETURN types._nth(seq_id, 0); -END; $$ LANGUAGE plpgsql; - - --- _restArray: --- takes value_id --- returns the array of value_ids -CREATE FUNCTION types._restArray(seq_id integer) RETURNS integer[] AS $$ -DECLARE - result integer[]; -BEGIN - result := (SELECT val_seq FROM types.value WHERE value_id = seq_id); - RETURN result[2:array_length(result, 1)]; -END; $$ LANGUAGE plpgsql; - --- _slice: --- takes value_id, a first index and an last index --- returns the value_id of new list from first (inclusive) to last (exclusive) -CREATE FUNCTION types._slice(seq_id integer, first integer, last integer) -RETURNS integer AS $$ -DECLARE - seq integer[]; - vid integer; - i integer; - result integer; -BEGIN - SELECT val_seq INTO seq FROM types.value WHERE value_id = seq_id; - INSERT INTO types.value (type_id, val_seq) - VALUES (8, seq[first+1:last]) - RETURNING value_id INTO result; - RETURN result; -END; $$ LANGUAGE plpgsql; - --- _rest: --- takes value_id --- returns the value_id of new list -CREATE FUNCTION types._rest(seq_id integer) RETURNS integer AS $$ -BEGIN - RETURN types._slice(seq_id, 1, types._count(seq_id)); -END; $$ LANGUAGE plpgsql; - --- _count: --- takes value_id --- returns a count (not value_id) -CREATE FUNCTION types._count(seq_id integer) RETURNS integer AS $$ -DECLARE - result integer[]; -BEGIN - result := (SELECT val_seq FROM types.value - WHERE value_id = seq_id); - RETURN COALESCE(array_length(result, 1), 0); -END; $$ LANGUAGE plpgsql; - - --- --------------------------------------------------------- --- hash-map functions - --- _hash_map: --- return value_id of a new hash-map -CREATE FUNCTION types._hash_map(items integer[]) RETURNS integer AS $$ -BEGIN - RETURN types._collection(items, 10); -END; $$ LANGUAGE plpgsql; - --- _hash_map_Q: --- return true if obj value_id is a list -CREATE FUNCTION types._hash_map_Q(obj integer) RETURNS boolean AS $$ -BEGIN - RETURN types._tf((SELECT 1 FROM types.value - WHERE value_id = obj and type_id = 10)); -END; $$ LANGUAGE plpgsql; - --- _assoc_BANG: --- return value_id of the hash-map with new elements appended -CREATE FUNCTION types._assoc_BANG(hm integer, items integer[]) RETURNS integer AS $$ -DECLARE - hash hstore; -BEGIN - IF (array_length(items, 1) % 2) = 1 THEN - RAISE EXCEPTION 'hash-map: odd number of arguments'; - END IF; - SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; - IF hash IS NULL THEN - UPDATE types.value SET val_hash = hstore(CAST(items AS varchar[])) - WHERE value_id = hm; - ELSE - UPDATE types.value - SET val_hash = hash || hstore(CAST(items AS varchar[])) - WHERE value_id = hm; - END IF; - RETURN hm; -END; $$ LANGUAGE plpgsql; - --- _dissoc_BANG: --- return value_id of the hash-map with elements removed -CREATE FUNCTION types._dissoc_BANG(hm integer, items integer[]) RETURNS integer AS $$ -DECLARE - hash hstore; -BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; - UPDATE types.value SET val_hash = hash - CAST(items AS varchar[]) - WHERE value_id = hm; - RETURN hm; -END; $$ LANGUAGE plpgsql; - --- _get: --- return value_id of the hash-map entry matching key -CREATE FUNCTION types._get(hm integer, key varchar) RETURNS integer AS $$ -DECLARE - hash hstore; -BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; - RETURN hash -> CAST(types._stringv(key) AS varchar); -END; $$ LANGUAGE plpgsql; - --- _contains_Q: --- return true if hash-map contains entry matching key -CREATE FUNCTION types._contains_Q(hm integer, key varchar) RETURNS boolean AS $$ -DECLARE - hash hstore; -BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; - RETURN types._tf(hash ? CAST(types._stringv(key) AS varchar)); -END; $$ LANGUAGE plpgsql; - --- _keys: --- return array of key value_ids from hash-map -CREATE FUNCTION types._keys(hm integer) RETURNS integer[] AS $$ -DECLARE - hash hstore; -BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; - RETURN CAST(akeys(hash) AS integer[]); -END; $$ LANGUAGE plpgsql; - --- _vals: --- return array of value value_ids from hash-map -CREATE FUNCTION types._vals(hm integer) RETURNS integer[] AS $$ -DECLARE - hash hstore; -BEGIN - SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; - RETURN CAST(avals(hash) AS integer[]); -END; $$ LANGUAGE plpgsql; - - --- --------------------------------------------------------- --- function functions - --- _function: --- takes a function name --- returns the value_id of a new -CREATE FUNCTION types._function(fname varchar) -RETURNS varchar AS $$ -DECLARE - result integer; -BEGIN - INSERT INTO types.value (type_id, val_string) - VALUES (11, fname) - RETURNING value_id INTO result; - RETURN CAST(result AS varchar); -END; $$ LANGUAGE plpgsql; - --- _malfunc: --- takes a ast value_id, params value_id and env_id --- returns the value_id of a new function -CREATE FUNCTION types._malfunc(ast integer, params integer, env integer) -RETURNS integer AS $$ -DECLARE - cid integer = NULL; - result integer; -BEGIN - -- Create function entry - INSERT INTO types.value (type_id, ast_id, params_id, env_id) - VALUES (12, ast, params, env) - RETURNING value_id into result; - RETURN result; -END; $$ LANGUAGE plpgsql; - --- _macro: -CREATE FUNCTION types._macro(func integer) RETURNS integer AS $$ -DECLARE - newfunc integer; - cid integer; -BEGIN - newfunc := types._clone(func); - UPDATE types.value SET macro = true WHERE value_id = newfunc; - RETURN newfunc; -END; $$ LANGUAGE plpgsql; - -CREATE FUNCTION types._apply(func integer, args integer[]) RETURNS integer AS $$ -DECLARE - type integer; - fcid integer; - fname varchar; - fast integer; - fparams integer; - fenv integer; - result integer; -BEGIN - SELECT type_id, val_string, ast_id, params_id, env_id - INTO type, fname, fast, fparams, fenv - FROM types.value WHERE value_id = func; - IF type = 11 THEN - EXECUTE format('SELECT %s($1);', fname) - INTO result USING args; - RETURN result; - ELSIF type = 12 THEN - -- NOTE: forward reference to current step EVAL function - RETURN mal.EVAL(fast, envs.new(fenv, fparams, args)); - ELSE - RAISE EXCEPTION 'Invalid function call'; - END IF; -END; $$ LANGUAGE plpgsql; - --- --------------------------------------------------------- --- atom functions - --- _atom: --- takes an ast value_id --- returns a new atom value_id -CREATE FUNCTION types._atom(val integer) RETURNS integer AS $$ -DECLARE - cid integer = NULL; - result integer; -BEGIN - -- Create atom - INSERT INTO types.value (type_id, val_seq) - VALUES (13, ARRAY[val]) - RETURNING value_id INTO result; - RETURN result; -END; $$ LANGUAGE plpgsql; - --- _atom_Q: --- takes a value_id --- returns the whether value_id is an atom -CREATE FUNCTION types._atom_Q(id integer) RETURNS boolean AS $$ -BEGIN - RETURN EXISTS(SELECT 1 FROM types.value - WHERE type_id = 13 AND value_id = id); -END; $$ LANGUAGE plpgsql; - --- _deref: --- takes an atom value_id --- returns a atom value value_id -CREATE FUNCTION types._deref(atm integer) RETURNS integer AS $$ -DECLARE - result integer; -BEGIN - RETURN (SELECT val_seq[1] FROM types.value WHERE value_id = atm); -END; $$ LANGUAGE plpgsql; - --- _reset_BANG: --- takes an atom value_id and new value value_id --- returns a new value value_id -CREATE FUNCTION types._reset_BANG(atm integer, newval integer) RETURNS integer AS $$ -BEGIN - UPDATE types.value SET val_seq = ARRAY[newval] WHERE value_id = atm; - RETURN newval; -END; $$ LANGUAGE plpgsql; +-- --------------------------------------------------------- +-- persistent values + +-- list of types for type_id +-- 0: nil +-- 1: false +-- 2: true +-- 3: integer +-- 4: float +-- 5: string +-- 6: keyword (not used, uses prefixed string) +-- 7: symbol +-- 8: list +-- 9: vector +-- 10: hashmap +-- 11: function +-- 12: malfunc +-- 13: atom + +CREATE SCHEMA types + + CREATE SEQUENCE value_id_seq START WITH 3 -- skip nil, false, true + + CREATE TABLE value ( + value_id integer NOT NULL DEFAULT nextval('value_id_seq'), + type_id integer NOT NULL, + val_int bigint, -- set for integers + val_string varchar, -- set for strings, keywords, symbols, + -- and native functions (function name) + val_seq integer[], -- set for lists and vectors + val_hash hstore, -- set for hash-maps + ast_id integer, -- set for malfunc + params_id integer, -- set for malfunc + env_id integer, -- set for malfunc + macro boolean, -- set for malfunc + meta_id integer -- can be set for any collection + ); + +ALTER TABLE types.value ADD CONSTRAINT pk_value_id + PRIMARY KEY (value_id); +-- drop sequence when table dropped +ALTER SEQUENCE types.value_id_seq OWNED BY types.value.value_id; +ALTER TABLE types.value ADD CONSTRAINT fk_meta_id + FOREIGN KEY (meta_id) REFERENCES types.value(value_id); +ALTER TABLE types.value ADD CONSTRAINT fk_params_id + FOREIGN KEY (params_id) REFERENCES types.value(value_id); + +CREATE INDEX ON types.value (value_id, type_id); + +INSERT INTO types.value (value_id, type_id) VALUES (0, 0); -- nil +INSERT INTO types.value (value_id, type_id) VALUES (1, 1); -- false +INSERT INTO types.value (value_id, type_id) VALUES (2, 2); -- true + + +-- --------------------------------------------------------- +-- general functions + +CREATE FUNCTION types._wraptf(val boolean) RETURNS integer AS $$ +BEGIN + IF val THEN + RETURN 2; + ELSE + RETURN 1; + END IF; +END; $$ LANGUAGE plpgsql IMMUTABLE; + +-- pun both NULL and false to false +CREATE FUNCTION types._tf(val boolean) RETURNS boolean AS $$ +BEGIN + IF val IS NULL OR val = false THEN + RETURN false; + END IF; + RETURN true; +END; $$ LANGUAGE plpgsql IMMUTABLE; + +-- pun both NULL and 0 to false +CREATE FUNCTION types._tf(val integer) RETURNS boolean AS $$ +BEGIN + IF val IS NULL OR val = 0 THEN + RETURN false; + END IF; + RETURN true; +END; $$ LANGUAGE plpgsql IMMUTABLE; + +-- return the type of the given value_id +CREATE FUNCTION types._type(obj integer) RETURNS integer AS $$ +BEGIN + RETURN (SELECT type_id FROM types.value WHERE value_id = obj); +END; $$ LANGUAGE plpgsql; + + +CREATE FUNCTION types._equal_Q(a integer, b integer) RETURNS boolean AS $$ +DECLARE + atype integer; + btype integer; + anum bigint; + bnum bigint; + avid integer; + bvid integer; + aseq integer[]; + bseq integer[]; + ahash hstore; + bhash hstore; + kv RECORD; + i integer; +BEGIN + atype := types._type(a); + btype := types._type(b); + IF NOT ((atype = btype) OR + (types._sequential_Q(a) AND types._sequential_Q(b))) THEN + RETURN false; + END IF; + CASE + WHEN atype = 3 THEN -- integer + SELECT val_int FROM types.value INTO anum WHERE value_id = a; + SELECT val_int FROM types.value INTO bnum WHERE value_id = b; + RETURN anum = bnum; + WHEN atype = 5 OR atype = 7 THEN -- string/symbol + RETURN types._valueToString(a) = types._valueToString(b); + WHEN atype IN (8, 9) THEN -- list/vector + IF types._count(a) <> types._count(b) THEN + RETURN false; + END IF; + SELECT val_seq INTO aseq FROM types.value WHERE value_id = a; + SELECT val_seq INTO bseq FROM types.value WHERE value_id = b; + FOR i IN 1 .. types._count(a) + LOOP + IF NOT types._equal_Q(aseq[i], bseq[i]) THEN + return false; + END IF; + END LOOP; + RETURN true; + WHEN atype = 10 THEN -- hash-map + SELECT val_hash INTO ahash FROM types.value WHERE value_id = a; + SELECT val_hash INTO bhash FROM types.value WHERE value_id = b; + IF array_length(akeys(ahash), 1) <> array_length(akeys(bhash), 1) THEN + RETURN false; + END IF; + FOR kv IN SELECT * FROM each(ahash) LOOP + avid := CAST((ahash -> kv.key) AS integer); + bvid := CAST((bhash -> kv.key) AS integer); + IF bvid IS NULL OR NOT types._equal_Q(avid, bvid) THEN + return false; + END IF; + END LOOP; + RETURN true; + ELSE + RETURN a = b; + END CASE; +END; $$ LANGUAGE plpgsql; + + +-- _clone: +-- take a value_id of a collection +-- returns a new value_id of a cloned collection +CREATE FUNCTION types._clone(id integer) RETURNS integer AS $$ +DECLARE + result integer; +BEGIN + INSERT INTO types.value (type_id,val_int,val_string,val_seq,val_hash, + ast_id,params_id,env_id,meta_id) + (SELECT type_id,val_int,val_string,val_seq,val_hash, + ast_id,params_id,env_id,meta_id + FROM types.value + WHERE value_id = id) + RETURNING value_id INTO result; + RETURN result; +END; $$ LANGUAGE plpgsql; + + +-- --------------------------------------------------------- +-- scalar functions + + +-- _nil_Q: +-- takes a value_id +-- returns the whether value_id is nil +CREATE FUNCTION types._nil_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN id = 0; +END; $$ LANGUAGE plpgsql IMMUTABLE; + +-- _true_Q: +-- takes a value_id +-- returns the whether value_id is true +CREATE FUNCTION types._true_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN id = 2; +END; $$ LANGUAGE plpgsql IMMUTABLE; + +-- _false_Q: +-- takes a value_id +-- returns the whether value_id is false +CREATE FUNCTION types._false_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN id = 1; +END; $$ LANGUAGE plpgsql IMMUTABLE; + +-- _string_Q: +-- takes a value_id +-- returns the whether value_id is string type +CREATE FUNCTION types._string_Q(id integer) RETURNS boolean AS $$ +BEGIN + IF (SELECT 1 FROM types.value WHERE type_id = 5 AND value_id = id) THEN + RETURN NOT types._keyword_Q(id); + END IF; + RETURN false; +END; $$ LANGUAGE plpgsql; + +-- _number_Q: +-- takes a value_id +-- returns the whether value_id is integer or float type +CREATE FUNCTION types._number_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE (type_id = 3 OR type_id = 4) + AND value_id = id)); +END; $$ LANGUAGE plpgsql; + +-- _valueToString: +-- takes a value_id for a string +-- returns the varchar value of the string +CREATE FUNCTION types._valueToString(sid integer) RETURNS varchar AS $$ +BEGIN + RETURN (SELECT val_string FROM types.value WHERE value_id = sid); +END; $$ LANGUAGE plpgsql; + +-- _stringish: +-- takes a varchar string +-- returns the value_id of a stringish type (string, symbol, keyword) +CREATE FUNCTION types._stringish(str varchar, type integer) RETURNS integer AS $$ +DECLARE + result integer; +BEGIN + -- TODO: share string data between string types + -- lookup if it exists + SELECT value_id FROM types.value INTO result + WHERE val_string = str AND type_id = type; + IF result IS NULL THEN + -- Create string entry + INSERT INTO types.value (type_id, val_string) + VALUES (type, str) + RETURNING value_id INTO result; + END IF; + RETURN result; +END; $$ LANGUAGE plpgsql; + +-- _stringv: +-- takes a varchar string +-- returns the value_id of a string (new or existing) +CREATE FUNCTION types._stringv(str varchar) RETURNS integer AS $$ +BEGIN + RETURN types._stringish(str, 5); +END; $$ LANGUAGE plpgsql; + +-- _keywordv: +-- takes a varchar string +-- returns the value_id of a keyword (new or existing) +CREATE FUNCTION types._keywordv(name varchar) RETURNS integer AS $$ +BEGIN + RETURN types._stringish(chr(CAST(x'7f' AS integer)) || name, 5); +END; $$ LANGUAGE plpgsql; + +-- _keyword_Q: +-- takes a value_id +-- returns the whether value_id is keyword type +CREATE FUNCTION types._keyword_Q(id integer) RETURNS boolean AS $$ +DECLARE + str varchar; +BEGIN + IF (SELECT 1 FROM types.value WHERE type_id = 5 AND value_id = id) THEN + str := types._valueToString(id); + IF char_length(str) > 0 AND + chr(CAST(x'7f' AS integer)) = substring(str FROM 1 FOR 1) THEN + RETURN true; + END IF; + END IF; + RETURN false; +END; $$ LANGUAGE plpgsql; + +-- _symbolv: +-- takes a varchar string +-- returns the value_id of a symbol (new or existing) +CREATE FUNCTION types._symbolv(name varchar) RETURNS integer AS $$ +BEGIN + RETURN types._stringish(name, 7); +END; $$ LANGUAGE plpgsql; + +-- _symbol_Q: +-- takes a value_id +-- returns the whether value_id is symbol type +CREATE FUNCTION types._symbol_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE type_id = 7 AND value_id = id)); +END; $$ LANGUAGE plpgsql; + +-- _numToValue: +-- takes an bigint number +-- returns the value_id for the number +CREATE FUNCTION types._numToValue(num bigint) RETURNS integer AS $$ +DECLARE + result integer; +BEGIN + SELECT value_id FROM types.value INTO result + WHERE val_int = num AND type_id = 3; + IF result IS NULL THEN + -- Create an integer entry + INSERT INTO types.value (type_id, val_int) + VALUES (3, num) + RETURNING value_id INTO result; + END IF; + RETURN result; +END; $$ LANGUAGE plpgsql; + +-- _fn_Q: +-- takes a value_id +-- returns the whether value_id is a function +CREATE FUNCTION types._fn_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE (type_id = 11 OR type_id = 12) + AND macro IS NULL + AND value_id = id)); +END; $$ LANGUAGE plpgsql; + +-- _macro_Q: +-- takes a value_id +-- returns the whether value_id is a macro +CREATE FUNCTION types._macro_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE type_id = 12 + AND macro IS TRUE + AND value_id = id)); +END; $$ LANGUAGE plpgsql; + +-- --------------------------------------------------------- +-- sequence functions + +-- _sequential_Q: +-- return true if obj value_id is a list or vector +CREATE FUNCTION types._sequential_Q(obj integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE value_id = obj AND (type_id = 8 OR type_id = 9))); +END; $$ LANGUAGE plpgsql; + +-- _collection: +-- takes a array of value_id integers +-- returns the value_id of a new list (8), vector (9) or hash-map (10) +CREATE FUNCTION types._collection(items integer[], type integer) RETURNS integer AS $$ +DECLARE + vid integer; +BEGIN + IF type IN (8, 9) THEN + INSERT INTO types.value (type_id, val_seq) + VALUES (type, items) + RETURNING value_id INTO vid; + ELSIF type = 10 THEN + IF (array_length(items, 1) % 2) = 1 THEN + RAISE EXCEPTION 'hash-map: odd number of arguments'; + END IF; + INSERT INTO types.value (type_id, val_hash) + VALUES (type, hstore(CAST(items AS varchar[]))) + RETURNING value_id INTO vid; + END IF; + RETURN vid; +END; $$ LANGUAGE plpgsql; + + +-- _list: +-- takes a array of value_id integers +-- returns the value_id of a new list +CREATE FUNCTION types._list(items integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._collection(items, 8); +END; $$ LANGUAGE plpgsql; + +-- _vector: +-- takes a array of value_id integers +-- returns the value_id of a new list +CREATE FUNCTION types._vector(items integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._collection(items, 9); +END; $$ LANGUAGE plpgsql; + +-- _list_Q: +-- return true if obj value_id is a list +CREATE FUNCTION types._list_Q(obj integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE value_id = obj and type_id = 8)); +END; $$ LANGUAGE plpgsql; + +-- _vector_Q: +-- return true if obj value_id is a list +CREATE FUNCTION types._vector_Q(obj integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE value_id = obj and type_id = 9)); +END; $$ LANGUAGE plpgsql; + + +-- _valueToArray: +-- takes an value_id referring to a list or vector +-- returns an array of the value_ids from the list/vector +CREATE FUNCTION types._valueToArray(seq integer) RETURNS integer[] AS $$ +DECLARE + result integer[]; +BEGIN + result := (SELECT val_seq FROM types.value WHERE value_id = seq); + IF result IS NULL THEN + result := ARRAY[]::integer[]; + END IF; + RETURN result; +END; $$ LANGUAGE plpgsql; + +-- From: https://wiki.postgresql.org/wiki/Array_reverse +CREATE FUNCTION types.array_reverse(a integer[]) RETURNS integer[] AS $$ +SELECT ARRAY( + SELECT a[i] + FROM generate_subscripts(a,1) AS s(i) + ORDER BY i DESC +); +$$ LANGUAGE 'sql' STRICT IMMUTABLE; + + +-- _nth: +-- takes value_id and an index +-- returns the value_id of nth element in list/vector +CREATE FUNCTION types._nth(seq_id integer, indx integer) RETURNS integer AS $$ +DECLARE + result integer; +BEGIN + RETURN (SELECT val_seq[indx+1] FROM types.value WHERE value_id = seq_id); +END; $$ LANGUAGE plpgsql; + +-- _first: +-- takes value_id +-- returns the value_id of first element in list/vector +CREATE FUNCTION types._first(seq_id integer) RETURNS integer AS $$ +BEGIN + RETURN types._nth(seq_id, 0); +END; $$ LANGUAGE plpgsql; + + +-- _restArray: +-- takes value_id +-- returns the array of value_ids +CREATE FUNCTION types._restArray(seq_id integer) RETURNS integer[] AS $$ +DECLARE + result integer[]; +BEGIN + result := (SELECT val_seq FROM types.value WHERE value_id = seq_id); + RETURN result[2:array_length(result, 1)]; +END; $$ LANGUAGE plpgsql; + +-- _slice: +-- takes value_id, a first index and an last index +-- returns the value_id of new list from first (inclusive) to last (exclusive) +CREATE FUNCTION types._slice(seq_id integer, first integer, last integer) +RETURNS integer AS $$ +DECLARE + seq integer[]; + vid integer; + i integer; + result integer; +BEGIN + SELECT val_seq INTO seq FROM types.value WHERE value_id = seq_id; + INSERT INTO types.value (type_id, val_seq) + VALUES (8, seq[first+1:last]) + RETURNING value_id INTO result; + RETURN result; +END; $$ LANGUAGE plpgsql; + +-- _rest: +-- takes value_id +-- returns the value_id of new list +CREATE FUNCTION types._rest(seq_id integer) RETURNS integer AS $$ +BEGIN + RETURN types._slice(seq_id, 1, types._count(seq_id)); +END; $$ LANGUAGE plpgsql; + +-- _count: +-- takes value_id +-- returns a count (not value_id) +CREATE FUNCTION types._count(seq_id integer) RETURNS integer AS $$ +DECLARE + result integer[]; +BEGIN + result := (SELECT val_seq FROM types.value + WHERE value_id = seq_id); + RETURN COALESCE(array_length(result, 1), 0); +END; $$ LANGUAGE plpgsql; + + +-- --------------------------------------------------------- +-- hash-map functions + +-- _hash_map: +-- return value_id of a new hash-map +CREATE FUNCTION types._hash_map(items integer[]) RETURNS integer AS $$ +BEGIN + RETURN types._collection(items, 10); +END; $$ LANGUAGE plpgsql; + +-- _hash_map_Q: +-- return true if obj value_id is a list +CREATE FUNCTION types._hash_map_Q(obj integer) RETURNS boolean AS $$ +BEGIN + RETURN types._tf((SELECT 1 FROM types.value + WHERE value_id = obj and type_id = 10)); +END; $$ LANGUAGE plpgsql; + +-- _assoc_BANG: +-- return value_id of the hash-map with new elements appended +CREATE FUNCTION types._assoc_BANG(hm integer, items integer[]) RETURNS integer AS $$ +DECLARE + hash hstore; +BEGIN + IF (array_length(items, 1) % 2) = 1 THEN + RAISE EXCEPTION 'hash-map: odd number of arguments'; + END IF; + SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; + IF hash IS NULL THEN + UPDATE types.value SET val_hash = hstore(CAST(items AS varchar[])) + WHERE value_id = hm; + ELSE + UPDATE types.value + SET val_hash = hash || hstore(CAST(items AS varchar[])) + WHERE value_id = hm; + END IF; + RETURN hm; +END; $$ LANGUAGE plpgsql; + +-- _dissoc_BANG: +-- return value_id of the hash-map with elements removed +CREATE FUNCTION types._dissoc_BANG(hm integer, items integer[]) RETURNS integer AS $$ +DECLARE + hash hstore; +BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; + UPDATE types.value SET val_hash = hash - CAST(items AS varchar[]) + WHERE value_id = hm; + RETURN hm; +END; $$ LANGUAGE plpgsql; + +-- _get: +-- return value_id of the hash-map entry matching key +CREATE FUNCTION types._get(hm integer, key varchar) RETURNS integer AS $$ +DECLARE + hash hstore; +BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; + RETURN hash -> CAST(types._stringv(key) AS varchar); +END; $$ LANGUAGE plpgsql; + +-- _contains_Q: +-- return true if hash-map contains entry matching key +CREATE FUNCTION types._contains_Q(hm integer, key varchar) RETURNS boolean AS $$ +DECLARE + hash hstore; +BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; + RETURN types._tf(hash ? CAST(types._stringv(key) AS varchar)); +END; $$ LANGUAGE plpgsql; + +-- _keys: +-- return array of key value_ids from hash-map +CREATE FUNCTION types._keys(hm integer) RETURNS integer[] AS $$ +DECLARE + hash hstore; +BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; + RETURN CAST(akeys(hash) AS integer[]); +END; $$ LANGUAGE plpgsql; + +-- _vals: +-- return array of value value_ids from hash-map +CREATE FUNCTION types._vals(hm integer) RETURNS integer[] AS $$ +DECLARE + hash hstore; +BEGIN + SELECT val_hash INTO hash FROM types.value WHERE value_id = hm; + RETURN CAST(avals(hash) AS integer[]); +END; $$ LANGUAGE plpgsql; + + +-- --------------------------------------------------------- +-- function functions + +-- _function: +-- takes a function name +-- returns the value_id of a new +CREATE FUNCTION types._function(fname varchar) +RETURNS varchar AS $$ +DECLARE + result integer; +BEGIN + INSERT INTO types.value (type_id, val_string) + VALUES (11, fname) + RETURNING value_id INTO result; + RETURN CAST(result AS varchar); +END; $$ LANGUAGE plpgsql; + +-- _malfunc: +-- takes a ast value_id, params value_id and env_id +-- returns the value_id of a new function +CREATE FUNCTION types._malfunc(ast integer, params integer, env integer) +RETURNS integer AS $$ +DECLARE + cid integer = NULL; + result integer; +BEGIN + -- Create function entry + INSERT INTO types.value (type_id, ast_id, params_id, env_id) + VALUES (12, ast, params, env) + RETURNING value_id into result; + RETURN result; +END; $$ LANGUAGE plpgsql; + +-- _macro: +CREATE FUNCTION types._macro(func integer) RETURNS integer AS $$ +DECLARE + newfunc integer; + cid integer; +BEGIN + newfunc := types._clone(func); + UPDATE types.value SET macro = true WHERE value_id = newfunc; + RETURN newfunc; +END; $$ LANGUAGE plpgsql; + +CREATE FUNCTION types._apply(func integer, args integer[]) RETURNS integer AS $$ +DECLARE + type integer; + fcid integer; + fname varchar; + fast integer; + fparams integer; + fenv integer; + result integer; +BEGIN + SELECT type_id, val_string, ast_id, params_id, env_id + INTO type, fname, fast, fparams, fenv + FROM types.value WHERE value_id = func; + IF type = 11 THEN + EXECUTE format('SELECT %s($1);', fname) + INTO result USING args; + RETURN result; + ELSIF type = 12 THEN + -- NOTE: forward reference to current step EVAL function + RETURN mal.EVAL(fast, envs.new(fenv, fparams, args)); + ELSE + RAISE EXCEPTION 'Invalid function call'; + END IF; +END; $$ LANGUAGE plpgsql; + +-- --------------------------------------------------------- +-- atom functions + +-- _atom: +-- takes an ast value_id +-- returns a new atom value_id +CREATE FUNCTION types._atom(val integer) RETURNS integer AS $$ +DECLARE + cid integer = NULL; + result integer; +BEGIN + -- Create atom + INSERT INTO types.value (type_id, val_seq) + VALUES (13, ARRAY[val]) + RETURNING value_id INTO result; + RETURN result; +END; $$ LANGUAGE plpgsql; + +-- _atom_Q: +-- takes a value_id +-- returns the whether value_id is an atom +CREATE FUNCTION types._atom_Q(id integer) RETURNS boolean AS $$ +BEGIN + RETURN EXISTS(SELECT 1 FROM types.value + WHERE type_id = 13 AND value_id = id); +END; $$ LANGUAGE plpgsql; + +-- _deref: +-- takes an atom value_id +-- returns a atom value value_id +CREATE FUNCTION types._deref(atm integer) RETURNS integer AS $$ +DECLARE + result integer; +BEGIN + RETURN (SELECT val_seq[1] FROM types.value WHERE value_id = atm); +END; $$ LANGUAGE plpgsql; + +-- _reset_BANG: +-- takes an atom value_id and new value value_id +-- returns a new value value_id +CREATE FUNCTION types._reset_BANG(atm integer, newval integer) RETURNS integer AS $$ +BEGIN + UPDATE types.value SET val_seq = ARRAY[newval] WHERE value_id = atm; + RETURN newval; +END; $$ LANGUAGE plpgsql; diff --git a/impls/plpgsql/wrap.sh b/impls/plpgsql/wrap.sh index 3e7c921a80..36742d4ef3 100755 --- a/impls/plpgsql/wrap.sh +++ b/impls/plpgsql/wrap.sh @@ -1,75 +1,75 @@ -#!/bin/bash - -RL_HISTORY_FILE=${HOME}/.mal-history -SKIP_INIT="${SKIP_INIT:-}" -PSQL_USER="${PSQL_USER:-postgres}" - -PSQL="psql -q -t -A -v ON_ERROR_STOP=1 ${PSQL_USER:+-U ${PSQL_USER}}" -[ "${DEBUG}" ] || PSQL="${PSQL} -v VERBOSITY=terse" - -# If mal DB is not there, force create of it -dbcheck=$(${PSQL} -c "select 1 from pg_database where datname='mal'") -[ -z "${dbcheck}" ] && SKIP_INIT= - -STDOUT_PID= STDIN_PID= -cleanup () { - trap - TERM QUIT INT EXIT - # Make sure input stream is closed. Input subprocess will do this - # for normal terminal input but in the runtest.py case it does not - # get a chance. - ${PSQL} -dmal -c "SELECT io.close(0);" > /dev/null - [ "${STDIN_PID}" ] && kill ${STDIN_PID} 2>/dev/null -} - -# Load the SQL code -trap "cleanup" TERM QUIT INT EXIT -${PSQL} -tc "SELECT 1 FROM pg_database WHERE datname = 'mal'" \ - | grep -q 1 || ${PSQL} -c "CREATE DATABASE mal" -#[ "${SKIP_INIT}" ] || ${PSQL} -dmal -f $1 > /dev/null -[ "${SKIP_INIT}" ] || ${PSQL} -dmal -f $1 - -${PSQL} -dmal -c "SELECT io.open(0); SELECT io.open(1);" > /dev/null - -# Stream from table to stdout -( -while true; do - out="$(${PSQL} -dmal -c "SELECT io.read_or_error(1)" 2>/dev/null)" || break - echo "${out}" -done -) & -STDOUT_PID=$! - -# Perform readline input into stream table when requested -( -[ -r ${RL_HISTORY_FILE} ] && history -r ${RL_HISTORY_FILE} -while true; do - prompt=$(${PSQL} -dmal \ - -c "SELECT io.wait_rl_prompt(0);" 2>/dev/null) || break - IFS= read -u 0 -r -e -p "${prompt}" line || break - if [ "${line}" ]; then - history -s -- "${line}" # add to history - history -a ${RL_HISTORY_FILE} # save history to file - fi - - ${PSQL} -dmal -v arg="${line}" \ - -f <(echo "SELECT io.writeline(:'arg', 0);") >/dev/null || break -done -${PSQL} -dmal -c "SELECT io.close(0);" > /dev/null -) <&0 >&1 & -STDIN_PID=$! - -res=0 -shift -if [ $# -gt 0 ]; then - # If there are command line arguments then run a command and exit - args=$(for a in "$@"; do echo -n "\"$a\" "; done) - ${PSQL} -dmal -v args="(${args})" \ - -f <(echo "SELECT mal.MAIN('$(pwd)', :'args');") > /dev/null - res=$? -else - # Start main loop in the background - ${PSQL} -dmal -c "SELECT mal.MAIN('$(pwd)');" > /dev/null - res=$? -fi -wait ${STDOUT_PID} -exit ${res} +#!/bin/bash + +RL_HISTORY_FILE=${HOME}/.mal-history +SKIP_INIT="${SKIP_INIT:-}" +PSQL_USER="${PSQL_USER:-postgres}" + +PSQL="psql -q -t -A -v ON_ERROR_STOP=1 ${PSQL_USER:+-U ${PSQL_USER}}" +[ "${DEBUG}" ] || PSQL="${PSQL} -v VERBOSITY=terse" + +# If mal DB is not there, force create of it +dbcheck=$(${PSQL} -c "select 1 from pg_database where datname='mal'") +[ -z "${dbcheck}" ] && SKIP_INIT= + +STDOUT_PID= STDIN_PID= +cleanup () { + trap - TERM QUIT INT EXIT + # Make sure input stream is closed. Input subprocess will do this + # for normal terminal input but in the runtest.py case it does not + # get a chance. + ${PSQL} -dmal -c "SELECT io.close(0);" > /dev/null + [ "${STDIN_PID}" ] && kill ${STDIN_PID} 2>/dev/null +} + +# Load the SQL code +trap "cleanup" TERM QUIT INT EXIT +${PSQL} -tc "SELECT 1 FROM pg_database WHERE datname = 'mal'" \ + | grep -q 1 || ${PSQL} -c "CREATE DATABASE mal" +#[ "${SKIP_INIT}" ] || ${PSQL} -dmal -f $1 > /dev/null +[ "${SKIP_INIT}" ] || ${PSQL} -dmal -f $1 + +${PSQL} -dmal -c "SELECT io.open(0); SELECT io.open(1);" > /dev/null + +# Stream from table to stdout +( +while true; do + out="$(${PSQL} -dmal -c "SELECT io.read_or_error(1)" 2>/dev/null)" || break + echo "${out}" +done +) & +STDOUT_PID=$! + +# Perform readline input into stream table when requested +( +[ -r ${RL_HISTORY_FILE} ] && history -r ${RL_HISTORY_FILE} +while true; do + prompt=$(${PSQL} -dmal \ + -c "SELECT io.wait_rl_prompt(0);" 2>/dev/null) || break + IFS= read -u 0 -r -e -p "${prompt}" line || break + if [ "${line}" ]; then + history -s -- "${line}" # add to history + history -a ${RL_HISTORY_FILE} # save history to file + fi + + ${PSQL} -dmal -v arg="${line}" \ + -f <(echo "SELECT io.writeline(:'arg', 0);") >/dev/null || break +done +${PSQL} -dmal -c "SELECT io.close(0);" > /dev/null +) <&0 >&1 & +STDIN_PID=$! + +res=0 +shift +if [ $# -gt 0 ]; then + # If there are command line arguments then run a command and exit + args=$(for a in "$@"; do echo -n "\"$a\" "; done) + ${PSQL} -dmal -v args="(${args})" \ + -f <(echo "SELECT mal.MAIN('$(pwd)', :'args');") > /dev/null + res=$? +else + # Start main loop in the background + ${PSQL} -dmal -c "SELECT mal.MAIN('$(pwd)');" > /dev/null + res=$? +fi +wait ${STDOUT_PID} +exit ${res} diff --git a/impls/plsql/Dockerfile b/impls/plsql/Dockerfile index 420f5ee184..6cb3906806 100644 --- a/impls/plsql/Dockerfile +++ b/impls/plsql/Dockerfile @@ -1,34 +1,34 @@ -FROM wnameless/oracle-xe-11g - -RUN apt-get -y update -RUN apt-get -y install make cpp python - -RUN apt-get -y install rlwrap - -ENV ORACLE_HOME /u01/app/oracle/product/11.2.0/xe -ENV PATH ${ORACLE_HOME}/bin:${PATH} -ENV ORACLE_SID=XE - -# Enable use of DMBS_LOCK.sleep and make sure there are no password -# expiry messages that may interfere with communication. -RUN /usr/sbin/startup.sh && \ - echo "GRANT EXECUTE ON DBMS_LOCK TO system;" | sqlplus -S sys/oracle AS sysdba && \ - echo "ALTER PROFILE default LIMIT PASSWORD_LIFE_TIME UNLIMITED;" | sqlplus -S system/oracle && \ - echo "ALTER USER system IDENTIFIED BY oracle ACCOUNT UNLOCK;" | sqlplus -S system/oracle - -WORKDIR /mal - -# Add oracle user -RUN usermod -a -G sudo oracle - -# Travis runs as user ID 1001 so add that user -RUN useradd -ou 1001 -m -s /bin/bash -G sudo travis - -# Enable oracle and travis users to sudo for oracle startup -RUN echo "%sudo ALL=(ALL:ALL) NOPASSWD: ALL" >> /etc/sudoers - -ADD entrypoint.sh /entrypoint.sh -ENTRYPOINT ["/entrypoint.sh"] -CMD [] - - +FROM wnameless/oracle-xe-11g + +RUN apt-get -y update +RUN apt-get -y install make cpp python + +RUN apt-get -y install rlwrap + +ENV ORACLE_HOME /u01/app/oracle/product/11.2.0/xe +ENV PATH ${ORACLE_HOME}/bin:${PATH} +ENV ORACLE_SID=XE + +# Enable use of DMBS_LOCK.sleep and make sure there are no password +# expiry messages that may interfere with communication. +RUN /usr/sbin/startup.sh && \ + echo "GRANT EXECUTE ON DBMS_LOCK TO system;" | sqlplus -S sys/oracle AS sysdba && \ + echo "ALTER PROFILE default LIMIT PASSWORD_LIFE_TIME UNLIMITED;" | sqlplus -S system/oracle && \ + echo "ALTER USER system IDENTIFIED BY oracle ACCOUNT UNLOCK;" | sqlplus -S system/oracle + +WORKDIR /mal + +# Add oracle user +RUN usermod -a -G sudo oracle + +# Travis runs as user ID 1001 so add that user +RUN useradd -ou 1001 -m -s /bin/bash -G sudo travis + +# Enable oracle and travis users to sudo for oracle startup +RUN echo "%sudo ALL=(ALL:ALL) NOPASSWD: ALL" >> /etc/sudoers + +ADD entrypoint.sh /entrypoint.sh +ENTRYPOINT ["/entrypoint.sh"] +CMD [] + + diff --git a/impls/plsql/Dockerfile-oracle b/impls/plsql/Dockerfile-oracle index 6956e833cc..72403677bf 100644 --- a/impls/plsql/Dockerfile-oracle +++ b/impls/plsql/Dockerfile-oracle @@ -1,6 +1,6 @@ -FROM wnameless/oracle-xe-11g - -RUN apt-get -y update -RUN apt-get -y install make cpp python - -RUN apt-get -y install rlwrap +FROM wnameless/oracle-xe-11g + +RUN apt-get -y update +RUN apt-get -y install make cpp python + +RUN apt-get -y install rlwrap diff --git a/impls/plsql/Dockerfile-postgres b/impls/plsql/Dockerfile-postgres index e6aa498fea..e5e6b686fe 100644 --- a/impls/plsql/Dockerfile-postgres +++ b/impls/plsql/Dockerfile-postgres @@ -1,22 +1,22 @@ -FROM ubuntu:14.04 - -RUN apt-get -y update -RUN apt-get -y install make cpp python - -RUN apt-get -y install curl -RUN useradd -u 1000 -m -s /bin/bash -G sudo postgres - -ENV PG_VERSION=9.4 -RUN curl https://www.postgresql.org/media/keys/ACCC4CF8.asc | apt-key add - && \ - echo 'deb http://apt.postgresql.org/pub/repos/apt/ trusty-pgdg main' > /etc/apt/sources.list.d/pgdg.list && \ - apt-get update && \ - DEBIAN_FRONTEND=noninteractive apt-get -y install acl \ - postgresql-${PG_VERSION} postgresql-client-${PG_VERSION} postgresql-contrib-${PG_VERSION} && \ - mkdir -p /var/run/postgresql/9.4-main.pg_stat_tmp/ && \ - chown -R postgres /var/run/postgresql - -ENV HOME=/var/run/postgresql - -# Add entrypoint.sh which starts postgres then run bash/command -ADD entrypoint.sh /entrypoint.sh -ENTRYPOINT ["/entrypoint.sh"] +FROM ubuntu:14.04 + +RUN apt-get -y update +RUN apt-get -y install make cpp python + +RUN apt-get -y install curl +RUN useradd -u 1000 -m -s /bin/bash -G sudo postgres + +ENV PG_VERSION=9.4 +RUN curl https://www.postgresql.org/media/keys/ACCC4CF8.asc | apt-key add - && \ + echo 'deb http://apt.postgresql.org/pub/repos/apt/ trusty-pgdg main' > /etc/apt/sources.list.d/pgdg.list && \ + apt-get update && \ + DEBIAN_FRONTEND=noninteractive apt-get -y install acl \ + postgresql-${PG_VERSION} postgresql-client-${PG_VERSION} postgresql-contrib-${PG_VERSION} && \ + mkdir -p /var/run/postgresql/9.4-main.pg_stat_tmp/ && \ + chown -R postgres /var/run/postgresql + +ENV HOME=/var/run/postgresql + +# Add entrypoint.sh which starts postgres then run bash/command +ADD entrypoint.sh /entrypoint.sh +ENTRYPOINT ["/entrypoint.sh"] diff --git a/impls/plsql/Makefile b/impls/plsql/Makefile index 7af3113c71..14414a8c2b 100644 --- a/impls/plsql/Makefile +++ b/impls/plsql/Makefile @@ -1,3 +1,3 @@ -all: - -clean: +all: + +clean: diff --git a/impls/plsql/core.sql b/impls/plsql/core.sql index 02cf30f8b5..2d95e590ef 100644 --- a/impls/plsql/core.sql +++ b/impls/plsql/core.sql @@ -1,632 +1,632 @@ -CREATE OR REPLACE TYPE core_ns_T IS TABLE OF varchar2(100); -/ - -CREATE OR REPLACE PACKAGE core IS - FUNCTION do_core_func(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - fn integer, - a mal_vals) RETURN integer; - - FUNCTION get_core_ns RETURN core_ns_T; -END core; -/ -show errors; - - -CREATE OR REPLACE PACKAGE BODY core AS - --- general functions -FUNCTION equal_Q(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.tf(types.equal_Q(M, H, args(1), args(2))); -END; - --- scalar functiosn -FUNCTION symbol(M IN OUT NOCOPY types.mal_table, - val integer) RETURN integer IS -BEGIN - RETURN types.symbol(M, TREAT(M(val) AS mal_str_T).val_str); -END; - -FUNCTION keyword(M IN OUT NOCOPY types.mal_table, - val integer) RETURN integer IS -BEGIN - IF types.string_Q(M, val) THEN - RETURN types.keyword(M, TREAT(M(val) AS mal_str_T).val_str); - ELSIF types.keyword_Q(M, val) THEN - RETURN val; - ELSE - raise_application_error(-20009, - 'invalid keyword call', TRUE); - END IF; -END; - - --- string functions -FUNCTION pr_str(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.string(M, printer.pr_str_seq(M, H, args, ' ', TRUE)); -END; - -FUNCTION str(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.string(M, printer.pr_str_seq(M, H, args, '', FALSE)); -END; - -FUNCTION prn(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - args mal_vals) RETURN integer IS -BEGIN - io.writeline(printer.pr_str_seq(M, H, args, ' ', TRUE)); - RETURN 1; -- nil -END; - -FUNCTION println(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - args mal_vals) RETURN integer IS -BEGIN - io.writeline(printer.pr_str_seq(M, H, args, ' ', FALSE)); - RETURN 1; -- nil -END; - -FUNCTION read_string(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - args mal_vals) RETURN integer IS -BEGIN - IF M(args(1)).type_id = 5 THEN - RETURN reader.read_str(M, H, - TREAT(M(args(1)) AS mal_str_T).val_str); - ELSE - RETURN reader.read_str(M, H, - TREAT(M(args(1)) AS mal_long_str_T).val_long_str); - END IF; -END; - -FUNCTION readline(M IN OUT NOCOPY types.mal_table, - prompt integer) RETURN integer IS - input CLOB; -BEGIN - input := io.readline(TREAT(M(prompt) AS mal_str_T).val_str, 0); - RETURN types.string(M, input); -EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io streams closed - RETURN 1; -- nil - ELSE - RAISE; - END IF; -END; - -FUNCTION slurp(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS - content CLOB; -BEGIN - content := io.file_open_and_read(TREAT(M(args(1)) AS mal_str_T).val_str); - content := REPLACE(content, '\n', chr(10)); - RETURN types.string(M, content); -END; - - --- numeric functions -FUNCTION lt(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.tf(TREAT(M(args(1)) AS mal_int_T).val_int < - TREAT(M(args(2)) AS mal_int_T).val_int); -END; - -FUNCTION lte(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.tf(TREAT(M(args(1)) AS mal_int_T).val_int <= - TREAT(M(args(2)) AS mal_int_T).val_int); -END; - -FUNCTION gt(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.tf(TREAT(M(args(1)) AS mal_int_T).val_int > - TREAT(M(args(2)) AS mal_int_T).val_int); -END; - -FUNCTION gte(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.tf(TREAT(M(args(1)) AS mal_int_T).val_int >= - TREAT(M(args(2)) AS mal_int_T).val_int); -END; - -FUNCTION add(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int + - TREAT(M(args(2)) AS mal_int_T).val_int); -END; - -FUNCTION subtract(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int - - TREAT(M(args(2)) AS mal_int_T).val_int); -END; - -FUNCTION multiply(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int * - TREAT(M(args(2)) AS mal_int_T).val_int); -END; - -FUNCTION divide(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS -BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int / - TREAT(M(args(2)) AS mal_int_T).val_int); -END; - -FUNCTION time_ms(M IN OUT NOCOPY types.mal_table) RETURN integer IS - now integer; -BEGIN - SELECT extract(day from(sys_extract_utc(systimestamp) - - to_timestamp('1970-01-01', 'YYYY-MM-DD'))) * 86400000 + - to_number(to_char(sys_extract_utc(systimestamp), 'SSSSSFF3')) - INTO now - FROM dual; - RETURN types.int(M, now); -END; - --- hash-map functions -FUNCTION assoc(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - hm integer, - kvs mal_vals) RETURN integer IS - new_hm integer; - midx integer; -BEGIN - new_hm := types.clone(M, H, hm); - midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - -- Add the new key/values - midx := types.assoc_BANG(M, H, midx, kvs); - RETURN new_hm; -END; - -FUNCTION dissoc(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - hm integer, - ks mal_vals) RETURN integer IS - new_hm integer; - midx integer; -BEGIN - new_hm := types.clone(M, H, hm); - midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - -- Remove the keys - midx := types.dissoc_BANG(M, H, midx, ks); - RETURN new_hm; -END; - - -FUNCTION get(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - hm integer, key integer) RETURN integer IS - midx integer; - k varchar2(256); - val integer; -BEGIN - IF M(hm).type_id = 0 THEN - RETURN 1; -- nil - END IF; - midx := TREAT(M(hm) AS mal_map_T).map_idx; - k := TREAT(M(key) AS mal_str_T).val_str; - IF H(midx).EXISTS(k) THEN - RETURN H(midx)(k); - ELSE - RETURN 1; -- nil - END IF; -END; - -FUNCTION contains_Q(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - hm integer, key integer) RETURN integer IS - midx integer; - k varchar2(256); - val integer; -BEGIN - midx := TREAT(M(hm) AS mal_map_T).map_idx; - k := TREAT(M(key) AS mal_str_T).val_str; - RETURN types.tf(H(midx).EXISTS(k)); -END; - -FUNCTION keys(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - hm integer) RETURN integer IS - midx integer; - k varchar2(256); - ks mal_vals; - val integer; -BEGIN - midx := TREAT(M(hm) AS mal_map_T).map_idx; - ks := mal_vals(); - - k := H(midx).FIRST(); - WHILE k IS NOT NULL LOOP - ks.EXTEND(); - ks(ks.COUNT()) := types.string(M, k); - k := H(midx).NEXT(k); - END LOOP; - - RETURN types.seq(M, 8, ks); -END; - -FUNCTION vals(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - hm integer) RETURN integer IS - midx integer; - k varchar2(256); - ks mal_vals; - val integer; -BEGIN - midx := TREAT(M(hm) AS mal_map_T).map_idx; - ks := mal_vals(); - - k := H(midx).FIRST(); - WHILE k IS NOT NULL LOOP - ks.EXTEND(); - ks(ks.COUNT()) := H(midx)(k); - k := H(midx).NEXT(k); - END LOOP; - - RETURN types.seq(M, 8, ks); -END; - - --- sequence functions -FUNCTION cons(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS - new_items mal_vals; - len integer; - i integer; -BEGIN - new_items := mal_vals(); - len := types.count(M, args(2)); - new_items.EXTEND(len+1); - new_items(1) := args(1); - FOR i IN 1..len LOOP - new_items(i+1) := TREAT(M(args(2)) AS mal_seq_T).val_seq(i); - END LOOP; - RETURN types.seq(M, 8, new_items); -END; - -FUNCTION concat(M IN OUT NOCOPY types.mal_table, - args mal_vals) RETURN integer IS - new_items mal_vals; - cur_len integer; - seq_len integer; - i integer; - j integer; -BEGIN - new_items := mal_vals(); - cur_len := 0; - FOR i IN 1..args.COUNT() LOOP - seq_len := types.count(M, args(i)); - new_items.EXTEND(seq_len); - FOR j IN 1..seq_len LOOP - new_items(cur_len + j) := types.nth(M, args(i), j-1); - END LOOP; - cur_len := cur_len + seq_len; - END LOOP; - RETURN types.seq(M, 8, new_items); -END; - -FUNCTION vec(M IN OUT NOCOPY types.mal_table, - seq integer) RETURN integer IS -BEGIN - type_id := M(seq).type_id; - CASE - WHEN type_id = 8 THEN - RETURN types.seq(M, 9, TREAT(M(seq) AS mal_seq_T).val_seq); - WHEN type_id = 9 THEN - RETURN seq; - ELSE - raise_application_error(-20009, - 'vec: not supported on type ' || type_id, TRUE); - END CASE; -END; - -FUNCTION nth(M IN OUT NOCOPY types.mal_table, - val integer, - ival integer) RETURN integer IS - idx integer; -BEGIN - idx := TREAT(M(ival) AS mal_int_T).val_int; - RETURN types.nth(M, val, idx); -END; - -FUNCTION first(M IN OUT NOCOPY types.mal_table, - val integer) RETURN integer IS -BEGIN - IF val = 1 OR types.count(M, val) = 0 THEN - RETURN 1; -- nil - ELSE - RETURN types.first(M, val); - END IF; -END; - -FUNCTION rest(M IN OUT NOCOPY types.mal_table, - val integer) RETURN integer IS -BEGIN - IF val = 1 OR types.count(M, val) = 0 THEN - RETURN types.list(M); - ELSE - RETURN types.slice(M, val, 1); - END IF; -END; - -FUNCTION do_count(M IN OUT NOCOPY types.mal_table, - val integer) RETURN integer IS -BEGIN - IF M(val).type_id = 0 THEN - RETURN types.int(M, 0); - ELSE - RETURN types.int(M, types.count(M, val)); - END IF; -END; - - -FUNCTION conj(M IN OUT NOCOPY types.mal_table, - seq integer, - vals mal_vals) RETURN integer IS - type_id integer; - slen integer; - items mal_vals; -BEGIN - type_id := M(seq).type_id; - slen := types.count(M, seq); - items := mal_vals(); - items.EXTEND(slen + vals.COUNT()); - CASE - WHEN type_id = 8 THEN - FOR i IN 1..vals.COUNT() LOOP - items(i) := vals(vals.COUNT + 1 - i); - END LOOP; - FOR i IN 1..slen LOOP - items(vals.COUNT() + i) := types.nth(M, seq, i-1); - END LOOP; - WHEN type_id = 9 THEN - FOR i IN 1..slen LOOP - items(i) := types.nth(M, seq, i-1); - END LOOP; - FOR i IN 1..vals.COUNT() LOOP - items(slen + i) := vals(i); - END LOOP; - ELSE - raise_application_error(-20009, - 'conj: not supported on type ' || type_id, TRUE); - END CASE; - RETURN types.seq(M, type_id, items); -END; - -FUNCTION seq(M IN OUT NOCOPY types.mal_table, - val integer) RETURN integer IS - type_id integer; - new_val integer; - str CLOB; - str_items mal_vals; -BEGIN - type_id := M(val).type_id; - CASE - WHEN type_id = 8 THEN - IF types.count(M, val) = 0 THEN - RETURN 1; -- nil - END IF; - RETURN val; - WHEN type_id = 9 THEN - IF types.count(M, val) = 0 THEN - RETURN 1; -- nil - END IF; - RETURN types.seq(M, 8, TREAT(M(val) AS mal_seq_T).val_seq); - WHEN types.string_Q(M, val) THEN - str := TREAT(M(val) AS mal_str_T).val_str; - IF str IS NULL THEN - RETURN 1; -- nil - END IF; - str_items := mal_vals(); - str_items.EXTEND(LENGTH(str)); - FOR i IN 1..LENGTH(str) LOOP - str_items(i) := types.string(M, SUBSTR(str, i, 1)); - END LOOP; - RETURN types.seq(M, 8, str_items); - WHEN type_id = 0 THEN - RETURN 1; -- nil - ELSE - raise_application_error(-20009, - 'seq: not supported on type ' || type_id, TRUE); - END CASE; -END; - --- metadata functions -FUNCTION meta(M IN OUT NOCOPY types.mal_table, - val integer) RETURN integer IS - type_id integer; -BEGIN - type_id := M(val).type_id; - IF type_id IN (8,9) THEN -- list/vector - RETURN TREAT(M(val) AS mal_seq_T).meta; - ELSIF type_id = 10 THEN -- hash-map - RETURN TREAT(M(val) AS mal_map_T).meta; - ELSIF type_id = 11 THEN -- native function - RETURN 1; -- nil - ELSIF type_id = 12 THEN -- mal function - RETURN TREAT(M(val) AS mal_func_T).meta; - ELSE - raise_application_error(-20006, - 'meta: metadata not supported on type', TRUE); - END IF; -END; - --- general native function case/switch -FUNCTION do_core_func(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - fn integer, - a mal_vals) RETURN integer IS - fname varchar(256); - idx integer; -BEGIN - IF M(fn).type_id <> 11 THEN - raise_application_error(-20004, - 'Invalid function call', TRUE); - END IF; - - fname := TREAT(M(fn) AS mal_str_T).val_str; - - CASE - WHEN fname = '=' THEN RETURN equal_Q(M, H, a); - - WHEN fname = 'nil?' THEN RETURN types.tf(a(1) = 1); - WHEN fname = 'false?' THEN RETURN types.tf(a(1) = 2); - WHEN fname = 'true?' THEN RETURN types.tf(a(1) = 3); - WHEN fname = 'string?' THEN RETURN types.tf(types.string_Q(M, a(1))); - WHEN fname = 'symbol' THEN RETURN symbol(M, a(1)); - WHEN fname = 'symbol?' THEN RETURN types.tf(M(a(1)).type_id = 7); - WHEN fname = 'keyword' THEN RETURN keyword(M, a(1)); - WHEN fname = 'keyword?' THEN RETURN types.tf(types.keyword_Q(M, a(1))); - WHEN fname = 'number?' THEN RETURN types.tf(types.number_Q(M, a(1))); - WHEN fname = 'fn?' THEN RETURN types.tf(types.function_Q(M, a(1))); - WHEN fname = 'macro?' THEN RETURN types.tf(types.macro_Q(M, a(1))); - - WHEN fname = 'pr-str' THEN RETURN pr_str(M, H, a); - WHEN fname = 'str' THEN RETURN str(M, H, a); - WHEN fname = 'prn' THEN RETURN prn(M, H, a); - WHEN fname = 'println' THEN RETURN println(M, H, a); - WHEN fname = 'read-string' THEN RETURN read_string(M, H, a); - WHEN fname = 'readline' THEN RETURN readline(M, a(1)); - WHEN fname = 'slurp' THEN RETURN slurp(M, a); - - WHEN fname = '<' THEN RETURN lt(M, a); - WHEN fname = '<=' THEN RETURN lte(M, a); - WHEN fname = '>' THEN RETURN gt(M, a); - WHEN fname = '>=' THEN RETURN gte(M, a); - WHEN fname = '+' THEN RETURN add(M, a); - WHEN fname = '-' THEN RETURN subtract(M, a); - WHEN fname = '*' THEN RETURN multiply(M, a); - WHEN fname = '/' THEN RETURN divide(M, a); - WHEN fname = 'time-ms' THEN RETURN time_ms(M); - - WHEN fname = 'list' THEN RETURN types.seq(M, 8, a); - WHEN fname = 'list?' THEN RETURN types.tf(M(a(1)).type_id = 8); - WHEN fname = 'vector' THEN RETURN types.seq(M, 9, a); - WHEN fname = 'vector?' THEN RETURN types.tf(M(a(1)).type_id = 9); - WHEN fname = 'hash-map' THEN RETURN types.hash_map(M, H, a); - WHEN fname = 'assoc' THEN RETURN assoc(M, H, a(1), types.islice(a, 1)); - WHEN fname = 'dissoc' THEN RETURN dissoc(M, H, a(1), types.islice(a, 1)); - WHEN fname = 'map?' THEN RETURN types.tf(M(a(1)).type_id = 10); - WHEN fname = 'get' THEN RETURN get(M, H, a(1), a(2)); - WHEN fname = 'contains?' THEN RETURN contains_Q(M, H, a(1), a(2)); - WHEN fname = 'keys' THEN RETURN keys(M, H, a(1)); - WHEN fname = 'vals' THEN RETURN vals(M, H, a(1)); - - WHEN fname = 'sequential?' THEN RETURN types.tf(M(a(1)).type_id IN (8,9)); - WHEN fname = 'cons' THEN RETURN cons(M, a); - WHEN fname = 'concat' THEN RETURN concat(M, a); - WHEN fname = 'vec' THEN RETURN vec(M, a(1)); - WHEN fname = 'nth' THEN RETURN nth(M, a(1), a(2)); - WHEN fname = 'first' THEN RETURN first(M, a(1)); - WHEN fname = 'rest' THEN RETURN rest(M, a(1)); - WHEN fname = 'empty?' THEN RETURN types.tf(0 = types.count(M, a(1))); - WHEN fname = 'count' THEN RETURN do_count(M, a(1)); - - WHEN fname = 'conj' THEN RETURN conj(M, a(1), types.islice(a, 1)); - WHEN fname = 'seq' THEN RETURN seq(M, a(1)); - - WHEN fname = 'meta' THEN RETURN meta(M, a(1)); - WHEN fname = 'with-meta' THEN RETURN types.clone(M, H, a(1), a(2)); - WHEN fname = 'atom' THEN RETURN types.atom_new(M, a(1)); - WHEN fname = 'atom?' THEN RETURN types.tf(M(a(1)).type_id = 13); - WHEN fname = 'deref' THEN RETURN TREAT(M(a(1)) AS mal_atom_T).val; - WHEN fname = 'reset!' THEN RETURN types.atom_reset(M, a(1), a(2)); - - ELSE raise_application_error(-20004, 'Invalid function call', TRUE); - END CASE; -END; - -FUNCTION get_core_ns RETURN core_ns_T IS -BEGIN - RETURN core_ns_T( - '=', - 'throw', - - 'nil?', - 'true?', - 'false?', - 'string?', - 'symbol', - 'symbol?', - 'keyword', - 'keyword?', - 'number?', - 'fn?', - 'macro?', - - 'pr-str', - 'str', - 'prn', - 'println', - 'read-string', - 'readline', - 'slurp', - - '<', - '<=', - '>', - '>=', - '+', - '-', - '*', - '/', - 'time-ms', - - 'list', - 'list?', - 'vector', - 'vector?', - 'hash-map', - 'assoc', - 'dissoc', - 'map?', - 'get', - 'contains?', - 'keys', - 'vals', - - 'sequential?', - 'cons', - 'concat', - 'vec', - 'nth', - 'first', - 'rest', - 'empty?', - 'count', - 'apply', -- defined in step do_builtin function - 'map', -- defined in step do_builtin function - - 'conj', - 'seq', - - 'meta', - 'with-meta', - 'atom', - 'atom?', - 'deref', - 'reset!', - 'swap!' -- defined in step do_builtin function - ); -END; - -END core; -/ -show errors; +CREATE OR REPLACE TYPE core_ns_T IS TABLE OF varchar2(100); +/ + +CREATE OR REPLACE PACKAGE core IS + FUNCTION do_core_func(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + fn integer, + a mal_vals) RETURN integer; + + FUNCTION get_core_ns RETURN core_ns_T; +END core; +/ +show errors; + + +CREATE OR REPLACE PACKAGE BODY core AS + +-- general functions +FUNCTION equal_Q(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.tf(types.equal_Q(M, H, args(1), args(2))); +END; + +-- scalar functiosn +FUNCTION symbol(M IN OUT NOCOPY types.mal_table, + val integer) RETURN integer IS +BEGIN + RETURN types.symbol(M, TREAT(M(val) AS mal_str_T).val_str); +END; + +FUNCTION keyword(M IN OUT NOCOPY types.mal_table, + val integer) RETURN integer IS +BEGIN + IF types.string_Q(M, val) THEN + RETURN types.keyword(M, TREAT(M(val) AS mal_str_T).val_str); + ELSIF types.keyword_Q(M, val) THEN + RETURN val; + ELSE + raise_application_error(-20009, + 'invalid keyword call', TRUE); + END IF; +END; + + +-- string functions +FUNCTION pr_str(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.string(M, printer.pr_str_seq(M, H, args, ' ', TRUE)); +END; + +FUNCTION str(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.string(M, printer.pr_str_seq(M, H, args, '', FALSE)); +END; + +FUNCTION prn(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + args mal_vals) RETURN integer IS +BEGIN + io.writeline(printer.pr_str_seq(M, H, args, ' ', TRUE)); + RETURN 1; -- nil +END; + +FUNCTION println(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + args mal_vals) RETURN integer IS +BEGIN + io.writeline(printer.pr_str_seq(M, H, args, ' ', FALSE)); + RETURN 1; -- nil +END; + +FUNCTION read_string(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + args mal_vals) RETURN integer IS +BEGIN + IF M(args(1)).type_id = 5 THEN + RETURN reader.read_str(M, H, + TREAT(M(args(1)) AS mal_str_T).val_str); + ELSE + RETURN reader.read_str(M, H, + TREAT(M(args(1)) AS mal_long_str_T).val_long_str); + END IF; +END; + +FUNCTION readline(M IN OUT NOCOPY types.mal_table, + prompt integer) RETURN integer IS + input CLOB; +BEGIN + input := io.readline(TREAT(M(prompt) AS mal_str_T).val_str, 0); + RETURN types.string(M, input); +EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io streams closed + RETURN 1; -- nil + ELSE + RAISE; + END IF; +END; + +FUNCTION slurp(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS + content CLOB; +BEGIN + content := io.file_open_and_read(TREAT(M(args(1)) AS mal_str_T).val_str); + content := REPLACE(content, '\n', chr(10)); + RETURN types.string(M, content); +END; + + +-- numeric functions +FUNCTION lt(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.tf(TREAT(M(args(1)) AS mal_int_T).val_int < + TREAT(M(args(2)) AS mal_int_T).val_int); +END; + +FUNCTION lte(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.tf(TREAT(M(args(1)) AS mal_int_T).val_int <= + TREAT(M(args(2)) AS mal_int_T).val_int); +END; + +FUNCTION gt(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.tf(TREAT(M(args(1)) AS mal_int_T).val_int > + TREAT(M(args(2)) AS mal_int_T).val_int); +END; + +FUNCTION gte(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.tf(TREAT(M(args(1)) AS mal_int_T).val_int >= + TREAT(M(args(2)) AS mal_int_T).val_int); +END; + +FUNCTION add(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int + + TREAT(M(args(2)) AS mal_int_T).val_int); +END; + +FUNCTION subtract(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int - + TREAT(M(args(2)) AS mal_int_T).val_int); +END; + +FUNCTION multiply(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int * + TREAT(M(args(2)) AS mal_int_T).val_int); +END; + +FUNCTION divide(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS +BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int / + TREAT(M(args(2)) AS mal_int_T).val_int); +END; + +FUNCTION time_ms(M IN OUT NOCOPY types.mal_table) RETURN integer IS + now integer; +BEGIN + SELECT extract(day from(sys_extract_utc(systimestamp) - + to_timestamp('1970-01-01', 'YYYY-MM-DD'))) * 86400000 + + to_number(to_char(sys_extract_utc(systimestamp), 'SSSSSFF3')) + INTO now + FROM dual; + RETURN types.int(M, now); +END; + +-- hash-map functions +FUNCTION assoc(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + hm integer, + kvs mal_vals) RETURN integer IS + new_hm integer; + midx integer; +BEGIN + new_hm := types.clone(M, H, hm); + midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + -- Add the new key/values + midx := types.assoc_BANG(M, H, midx, kvs); + RETURN new_hm; +END; + +FUNCTION dissoc(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + hm integer, + ks mal_vals) RETURN integer IS + new_hm integer; + midx integer; +BEGIN + new_hm := types.clone(M, H, hm); + midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + -- Remove the keys + midx := types.dissoc_BANG(M, H, midx, ks); + RETURN new_hm; +END; + + +FUNCTION get(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + hm integer, key integer) RETURN integer IS + midx integer; + k varchar2(256); + val integer; +BEGIN + IF M(hm).type_id = 0 THEN + RETURN 1; -- nil + END IF; + midx := TREAT(M(hm) AS mal_map_T).map_idx; + k := TREAT(M(key) AS mal_str_T).val_str; + IF H(midx).EXISTS(k) THEN + RETURN H(midx)(k); + ELSE + RETURN 1; -- nil + END IF; +END; + +FUNCTION contains_Q(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + hm integer, key integer) RETURN integer IS + midx integer; + k varchar2(256); + val integer; +BEGIN + midx := TREAT(M(hm) AS mal_map_T).map_idx; + k := TREAT(M(key) AS mal_str_T).val_str; + RETURN types.tf(H(midx).EXISTS(k)); +END; + +FUNCTION keys(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + hm integer) RETURN integer IS + midx integer; + k varchar2(256); + ks mal_vals; + val integer; +BEGIN + midx := TREAT(M(hm) AS mal_map_T).map_idx; + ks := mal_vals(); + + k := H(midx).FIRST(); + WHILE k IS NOT NULL LOOP + ks.EXTEND(); + ks(ks.COUNT()) := types.string(M, k); + k := H(midx).NEXT(k); + END LOOP; + + RETURN types.seq(M, 8, ks); +END; + +FUNCTION vals(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + hm integer) RETURN integer IS + midx integer; + k varchar2(256); + ks mal_vals; + val integer; +BEGIN + midx := TREAT(M(hm) AS mal_map_T).map_idx; + ks := mal_vals(); + + k := H(midx).FIRST(); + WHILE k IS NOT NULL LOOP + ks.EXTEND(); + ks(ks.COUNT()) := H(midx)(k); + k := H(midx).NEXT(k); + END LOOP; + + RETURN types.seq(M, 8, ks); +END; + + +-- sequence functions +FUNCTION cons(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS + new_items mal_vals; + len integer; + i integer; +BEGIN + new_items := mal_vals(); + len := types.count(M, args(2)); + new_items.EXTEND(len+1); + new_items(1) := args(1); + FOR i IN 1..len LOOP + new_items(i+1) := TREAT(M(args(2)) AS mal_seq_T).val_seq(i); + END LOOP; + RETURN types.seq(M, 8, new_items); +END; + +FUNCTION concat(M IN OUT NOCOPY types.mal_table, + args mal_vals) RETURN integer IS + new_items mal_vals; + cur_len integer; + seq_len integer; + i integer; + j integer; +BEGIN + new_items := mal_vals(); + cur_len := 0; + FOR i IN 1..args.COUNT() LOOP + seq_len := types.count(M, args(i)); + new_items.EXTEND(seq_len); + FOR j IN 1..seq_len LOOP + new_items(cur_len + j) := types.nth(M, args(i), j-1); + END LOOP; + cur_len := cur_len + seq_len; + END LOOP; + RETURN types.seq(M, 8, new_items); +END; + +FUNCTION vec(M IN OUT NOCOPY types.mal_table, + seq integer) RETURN integer IS +BEGIN + type_id := M(seq).type_id; + CASE + WHEN type_id = 8 THEN + RETURN types.seq(M, 9, TREAT(M(seq) AS mal_seq_T).val_seq); + WHEN type_id = 9 THEN + RETURN seq; + ELSE + raise_application_error(-20009, + 'vec: not supported on type ' || type_id, TRUE); + END CASE; +END; + +FUNCTION nth(M IN OUT NOCOPY types.mal_table, + val integer, + ival integer) RETURN integer IS + idx integer; +BEGIN + idx := TREAT(M(ival) AS mal_int_T).val_int; + RETURN types.nth(M, val, idx); +END; + +FUNCTION first(M IN OUT NOCOPY types.mal_table, + val integer) RETURN integer IS +BEGIN + IF val = 1 OR types.count(M, val) = 0 THEN + RETURN 1; -- nil + ELSE + RETURN types.first(M, val); + END IF; +END; + +FUNCTION rest(M IN OUT NOCOPY types.mal_table, + val integer) RETURN integer IS +BEGIN + IF val = 1 OR types.count(M, val) = 0 THEN + RETURN types.list(M); + ELSE + RETURN types.slice(M, val, 1); + END IF; +END; + +FUNCTION do_count(M IN OUT NOCOPY types.mal_table, + val integer) RETURN integer IS +BEGIN + IF M(val).type_id = 0 THEN + RETURN types.int(M, 0); + ELSE + RETURN types.int(M, types.count(M, val)); + END IF; +END; + + +FUNCTION conj(M IN OUT NOCOPY types.mal_table, + seq integer, + vals mal_vals) RETURN integer IS + type_id integer; + slen integer; + items mal_vals; +BEGIN + type_id := M(seq).type_id; + slen := types.count(M, seq); + items := mal_vals(); + items.EXTEND(slen + vals.COUNT()); + CASE + WHEN type_id = 8 THEN + FOR i IN 1..vals.COUNT() LOOP + items(i) := vals(vals.COUNT + 1 - i); + END LOOP; + FOR i IN 1..slen LOOP + items(vals.COUNT() + i) := types.nth(M, seq, i-1); + END LOOP; + WHEN type_id = 9 THEN + FOR i IN 1..slen LOOP + items(i) := types.nth(M, seq, i-1); + END LOOP; + FOR i IN 1..vals.COUNT() LOOP + items(slen + i) := vals(i); + END LOOP; + ELSE + raise_application_error(-20009, + 'conj: not supported on type ' || type_id, TRUE); + END CASE; + RETURN types.seq(M, type_id, items); +END; + +FUNCTION seq(M IN OUT NOCOPY types.mal_table, + val integer) RETURN integer IS + type_id integer; + new_val integer; + str CLOB; + str_items mal_vals; +BEGIN + type_id := M(val).type_id; + CASE + WHEN type_id = 8 THEN + IF types.count(M, val) = 0 THEN + RETURN 1; -- nil + END IF; + RETURN val; + WHEN type_id = 9 THEN + IF types.count(M, val) = 0 THEN + RETURN 1; -- nil + END IF; + RETURN types.seq(M, 8, TREAT(M(val) AS mal_seq_T).val_seq); + WHEN types.string_Q(M, val) THEN + str := TREAT(M(val) AS mal_str_T).val_str; + IF str IS NULL THEN + RETURN 1; -- nil + END IF; + str_items := mal_vals(); + str_items.EXTEND(LENGTH(str)); + FOR i IN 1..LENGTH(str) LOOP + str_items(i) := types.string(M, SUBSTR(str, i, 1)); + END LOOP; + RETURN types.seq(M, 8, str_items); + WHEN type_id = 0 THEN + RETURN 1; -- nil + ELSE + raise_application_error(-20009, + 'seq: not supported on type ' || type_id, TRUE); + END CASE; +END; + +-- metadata functions +FUNCTION meta(M IN OUT NOCOPY types.mal_table, + val integer) RETURN integer IS + type_id integer; +BEGIN + type_id := M(val).type_id; + IF type_id IN (8,9) THEN -- list/vector + RETURN TREAT(M(val) AS mal_seq_T).meta; + ELSIF type_id = 10 THEN -- hash-map + RETURN TREAT(M(val) AS mal_map_T).meta; + ELSIF type_id = 11 THEN -- native function + RETURN 1; -- nil + ELSIF type_id = 12 THEN -- mal function + RETURN TREAT(M(val) AS mal_func_T).meta; + ELSE + raise_application_error(-20006, + 'meta: metadata not supported on type', TRUE); + END IF; +END; + +-- general native function case/switch +FUNCTION do_core_func(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + fn integer, + a mal_vals) RETURN integer IS + fname varchar(256); + idx integer; +BEGIN + IF M(fn).type_id <> 11 THEN + raise_application_error(-20004, + 'Invalid function call', TRUE); + END IF; + + fname := TREAT(M(fn) AS mal_str_T).val_str; + + CASE + WHEN fname = '=' THEN RETURN equal_Q(M, H, a); + + WHEN fname = 'nil?' THEN RETURN types.tf(a(1) = 1); + WHEN fname = 'false?' THEN RETURN types.tf(a(1) = 2); + WHEN fname = 'true?' THEN RETURN types.tf(a(1) = 3); + WHEN fname = 'string?' THEN RETURN types.tf(types.string_Q(M, a(1))); + WHEN fname = 'symbol' THEN RETURN symbol(M, a(1)); + WHEN fname = 'symbol?' THEN RETURN types.tf(M(a(1)).type_id = 7); + WHEN fname = 'keyword' THEN RETURN keyword(M, a(1)); + WHEN fname = 'keyword?' THEN RETURN types.tf(types.keyword_Q(M, a(1))); + WHEN fname = 'number?' THEN RETURN types.tf(types.number_Q(M, a(1))); + WHEN fname = 'fn?' THEN RETURN types.tf(types.function_Q(M, a(1))); + WHEN fname = 'macro?' THEN RETURN types.tf(types.macro_Q(M, a(1))); + + WHEN fname = 'pr-str' THEN RETURN pr_str(M, H, a); + WHEN fname = 'str' THEN RETURN str(M, H, a); + WHEN fname = 'prn' THEN RETURN prn(M, H, a); + WHEN fname = 'println' THEN RETURN println(M, H, a); + WHEN fname = 'read-string' THEN RETURN read_string(M, H, a); + WHEN fname = 'readline' THEN RETURN readline(M, a(1)); + WHEN fname = 'slurp' THEN RETURN slurp(M, a); + + WHEN fname = '<' THEN RETURN lt(M, a); + WHEN fname = '<=' THEN RETURN lte(M, a); + WHEN fname = '>' THEN RETURN gt(M, a); + WHEN fname = '>=' THEN RETURN gte(M, a); + WHEN fname = '+' THEN RETURN add(M, a); + WHEN fname = '-' THEN RETURN subtract(M, a); + WHEN fname = '*' THEN RETURN multiply(M, a); + WHEN fname = '/' THEN RETURN divide(M, a); + WHEN fname = 'time-ms' THEN RETURN time_ms(M); + + WHEN fname = 'list' THEN RETURN types.seq(M, 8, a); + WHEN fname = 'list?' THEN RETURN types.tf(M(a(1)).type_id = 8); + WHEN fname = 'vector' THEN RETURN types.seq(M, 9, a); + WHEN fname = 'vector?' THEN RETURN types.tf(M(a(1)).type_id = 9); + WHEN fname = 'hash-map' THEN RETURN types.hash_map(M, H, a); + WHEN fname = 'assoc' THEN RETURN assoc(M, H, a(1), types.islice(a, 1)); + WHEN fname = 'dissoc' THEN RETURN dissoc(M, H, a(1), types.islice(a, 1)); + WHEN fname = 'map?' THEN RETURN types.tf(M(a(1)).type_id = 10); + WHEN fname = 'get' THEN RETURN get(M, H, a(1), a(2)); + WHEN fname = 'contains?' THEN RETURN contains_Q(M, H, a(1), a(2)); + WHEN fname = 'keys' THEN RETURN keys(M, H, a(1)); + WHEN fname = 'vals' THEN RETURN vals(M, H, a(1)); + + WHEN fname = 'sequential?' THEN RETURN types.tf(M(a(1)).type_id IN (8,9)); + WHEN fname = 'cons' THEN RETURN cons(M, a); + WHEN fname = 'concat' THEN RETURN concat(M, a); + WHEN fname = 'vec' THEN RETURN vec(M, a(1)); + WHEN fname = 'nth' THEN RETURN nth(M, a(1), a(2)); + WHEN fname = 'first' THEN RETURN first(M, a(1)); + WHEN fname = 'rest' THEN RETURN rest(M, a(1)); + WHEN fname = 'empty?' THEN RETURN types.tf(0 = types.count(M, a(1))); + WHEN fname = 'count' THEN RETURN do_count(M, a(1)); + + WHEN fname = 'conj' THEN RETURN conj(M, a(1), types.islice(a, 1)); + WHEN fname = 'seq' THEN RETURN seq(M, a(1)); + + WHEN fname = 'meta' THEN RETURN meta(M, a(1)); + WHEN fname = 'with-meta' THEN RETURN types.clone(M, H, a(1), a(2)); + WHEN fname = 'atom' THEN RETURN types.atom_new(M, a(1)); + WHEN fname = 'atom?' THEN RETURN types.tf(M(a(1)).type_id = 13); + WHEN fname = 'deref' THEN RETURN TREAT(M(a(1)) AS mal_atom_T).val; + WHEN fname = 'reset!' THEN RETURN types.atom_reset(M, a(1), a(2)); + + ELSE raise_application_error(-20004, 'Invalid function call', TRUE); + END CASE; +END; + +FUNCTION get_core_ns RETURN core_ns_T IS +BEGIN + RETURN core_ns_T( + '=', + 'throw', + + 'nil?', + 'true?', + 'false?', + 'string?', + 'symbol', + 'symbol?', + 'keyword', + 'keyword?', + 'number?', + 'fn?', + 'macro?', + + 'pr-str', + 'str', + 'prn', + 'println', + 'read-string', + 'readline', + 'slurp', + + '<', + '<=', + '>', + '>=', + '+', + '-', + '*', + '/', + 'time-ms', + + 'list', + 'list?', + 'vector', + 'vector?', + 'hash-map', + 'assoc', + 'dissoc', + 'map?', + 'get', + 'contains?', + 'keys', + 'vals', + + 'sequential?', + 'cons', + 'concat', + 'vec', + 'nth', + 'first', + 'rest', + 'empty?', + 'count', + 'apply', -- defined in step do_builtin function + 'map', -- defined in step do_builtin function + + 'conj', + 'seq', + + 'meta', + 'with-meta', + 'atom', + 'atom?', + 'deref', + 'reset!', + 'swap!' -- defined in step do_builtin function + ); +END; + +END core; +/ +show errors; diff --git a/impls/plsql/entrypoint.sh b/impls/plsql/entrypoint.sh index 549e7ce80c..be1bd96e17 100755 --- a/impls/plsql/entrypoint.sh +++ b/impls/plsql/entrypoint.sh @@ -1,17 +1,17 @@ -#!/bin/bash - -case ${1} in -make*) - echo "Skipping Oracle XE startup" - ;; -*) - echo "Starting Oracle XE" - sudo /usr/sbin/startup.sh - ;; -esac - -if [ "${*}" ]; then - exec "${@}" -else - exec bash -fi +#!/bin/bash + +case ${1} in +make*) + echo "Skipping Oracle XE startup" + ;; +*) + echo "Starting Oracle XE" + sudo /usr/sbin/startup.sh + ;; +esac + +if [ "${*}" ]; then + exec "${@}" +else + exec bash +fi diff --git a/impls/plsql/env.sql b/impls/plsql/env.sql index 6fdc2ee0b7..0affe225c5 100644 --- a/impls/plsql/env.sql +++ b/impls/plsql/env.sql @@ -1,148 +1,148 @@ --- --------------------------------------------------------- --- env.sql - -CREATE OR REPLACE TYPE env_item FORCE AS OBJECT ( - key varchar2(256), - val integer -) FINAL; -/ - -CREATE OR REPLACE TYPE env_data FORCE IS TABLE OF env_item; -/ - -CREATE OR REPLACE TYPE env_T FORCE AS OBJECT ( - idx integer, - outer_idx integer, - data env_data -); -/ - -CREATE OR REPLACE TYPE env_mem_T FORCE IS TABLE OF env_T; -/ - -CREATE OR REPLACE PACKAGE env_pkg IS - TYPE env_entry IS TABLE OF integer INDEX BY varchar2(256); - TYPE env_entry_table IS TABLE OF env_entry; - - FUNCTION env_new(M IN OUT NOCOPY types.mal_table, - eeT IN OUT NOCOPY env_entry_table, - outer_idx integer DEFAULT NULL) - RETURN integer; - FUNCTION env_new(M IN OUT NOCOPY types.mal_table, - eeT IN OUT NOCOPY env_entry_table, - outer_idx integer, - binds integer, - exprs mal_vals) - RETURN integer; - FUNCTION env_set(M IN OUT NOCOPY types.mal_table, - eeT IN OUT NOCOPY env_entry_table, - eidx integer, - key integer, - val integer) RETURN integer; - FUNCTION env_find(M IN OUT NOCOPY types.mal_table, - eeT env_entry_table, - eidx integer, - key integer) RETURN integer; - FUNCTION env_get(M IN OUT NOCOPY types.mal_table, - eeT env_entry_table, - eidx integer, - key integer) RETURN integer; -END env_pkg; -/ -show errors; - - -CREATE OR REPLACE PACKAGE BODY env_pkg IS - -FUNCTION env_new(M IN OUT NOCOPY types.mal_table, - eeT IN OUT NOCOPY env_entry_table, - outer_idx integer DEFAULT NULL) - RETURN integer IS - eidx integer; -BEGIN - eeT.EXTEND(); - eidx := eeT.COUNT(); - eeT(eidx)('**OUTER**') := outer_idx; - RETURN eidx; -END; - -FUNCTION env_new(M IN OUT NOCOPY types.mal_table, - eeT IN OUT NOCOPY env_entry_table, - outer_idx integer, - binds integer, - exprs mal_vals) - RETURN integer IS - eidx integer; - i integer; - bs mal_vals; -BEGIN - eeT.EXTEND(); - eidx := eeT.COUNT(); - eeT(eidx)('**OUTER**') := outer_idx; - IF binds IS NOT NULL THEN - bs := TREAT(M(binds) AS mal_seq_T).val_seq; - FOR i IN 1..bs.COUNT LOOP - IF TREAT(M(bs(i)) AS mal_str_T).val_str = '&' THEN - eeT(eidx)(TREAT(M(bs(i+1)) AS mal_str_T).val_str) := - types.slice(M, exprs, i-1); - EXIT; - ELSE - eeT(eidx)(TREAT(M(bs(i)) AS mal_str_T).val_str) := - exprs(i); - END IF; - END LOOP; - END IF; - RETURN eidx; -END; - -FUNCTION env_set(M IN OUT NOCOPY types.mal_table, - eeT IN OUT NOCOPY env_entry_table, - eidx integer, - key integer, - val integer) RETURN integer IS - k varchar2(256); - i integer; - cnt integer; -BEGIN - k := TREAT(M(key) AS mal_str_T).val_str; - eeT(eidx)(k) := val; - RETURN val; -END; - -FUNCTION env_find(M IN OUT NOCOPY types.mal_table, - eeT env_entry_table, - eidx integer, - key integer) RETURN integer IS - k varchar2(256); - cnt integer; -BEGIN - k := TREAT(M(key) AS mal_str_T).val_str; - IF eeT(eidx).EXISTS(k) THEN - RETURN eidx; - ELSIF eeT(eidx)('**OUTER**') IS NOT NULL THEN - RETURN env_find(M, eeT, eeT(eidx)('**OUTER**'), key); - ELSE - RETURN NULL; - END IF; -END; - -FUNCTION env_get(M IN OUT NOCOPY types.mal_table, - eeT env_entry_table, - eidx integer, - key integer) RETURN integer IS - found integer; - k varchar2(256); -BEGIN - found := env_find(M, eeT, eidx, key); - k := TREAT(M(key) AS mal_str_T).val_str; - IF found IS NOT NULL THEN - RETURN eeT(found)(k); - ELSE - raise_application_error(-20005, - '''' || k || ''' not found', TRUE); - END IF; -END; - -END env_pkg; -/ -show errors; +-- --------------------------------------------------------- +-- env.sql + +CREATE OR REPLACE TYPE env_item FORCE AS OBJECT ( + key varchar2(256), + val integer +) FINAL; +/ + +CREATE OR REPLACE TYPE env_data FORCE IS TABLE OF env_item; +/ + +CREATE OR REPLACE TYPE env_T FORCE AS OBJECT ( + idx integer, + outer_idx integer, + data env_data +); +/ + +CREATE OR REPLACE TYPE env_mem_T FORCE IS TABLE OF env_T; +/ + +CREATE OR REPLACE PACKAGE env_pkg IS + TYPE env_entry IS TABLE OF integer INDEX BY varchar2(256); + TYPE env_entry_table IS TABLE OF env_entry; + + FUNCTION env_new(M IN OUT NOCOPY types.mal_table, + eeT IN OUT NOCOPY env_entry_table, + outer_idx integer DEFAULT NULL) + RETURN integer; + FUNCTION env_new(M IN OUT NOCOPY types.mal_table, + eeT IN OUT NOCOPY env_entry_table, + outer_idx integer, + binds integer, + exprs mal_vals) + RETURN integer; + FUNCTION env_set(M IN OUT NOCOPY types.mal_table, + eeT IN OUT NOCOPY env_entry_table, + eidx integer, + key integer, + val integer) RETURN integer; + FUNCTION env_find(M IN OUT NOCOPY types.mal_table, + eeT env_entry_table, + eidx integer, + key integer) RETURN integer; + FUNCTION env_get(M IN OUT NOCOPY types.mal_table, + eeT env_entry_table, + eidx integer, + key integer) RETURN integer; +END env_pkg; +/ +show errors; + + +CREATE OR REPLACE PACKAGE BODY env_pkg IS + +FUNCTION env_new(M IN OUT NOCOPY types.mal_table, + eeT IN OUT NOCOPY env_entry_table, + outer_idx integer DEFAULT NULL) + RETURN integer IS + eidx integer; +BEGIN + eeT.EXTEND(); + eidx := eeT.COUNT(); + eeT(eidx)('**OUTER**') := outer_idx; + RETURN eidx; +END; + +FUNCTION env_new(M IN OUT NOCOPY types.mal_table, + eeT IN OUT NOCOPY env_entry_table, + outer_idx integer, + binds integer, + exprs mal_vals) + RETURN integer IS + eidx integer; + i integer; + bs mal_vals; +BEGIN + eeT.EXTEND(); + eidx := eeT.COUNT(); + eeT(eidx)('**OUTER**') := outer_idx; + IF binds IS NOT NULL THEN + bs := TREAT(M(binds) AS mal_seq_T).val_seq; + FOR i IN 1..bs.COUNT LOOP + IF TREAT(M(bs(i)) AS mal_str_T).val_str = '&' THEN + eeT(eidx)(TREAT(M(bs(i+1)) AS mal_str_T).val_str) := + types.slice(M, exprs, i-1); + EXIT; + ELSE + eeT(eidx)(TREAT(M(bs(i)) AS mal_str_T).val_str) := + exprs(i); + END IF; + END LOOP; + END IF; + RETURN eidx; +END; + +FUNCTION env_set(M IN OUT NOCOPY types.mal_table, + eeT IN OUT NOCOPY env_entry_table, + eidx integer, + key integer, + val integer) RETURN integer IS + k varchar2(256); + i integer; + cnt integer; +BEGIN + k := TREAT(M(key) AS mal_str_T).val_str; + eeT(eidx)(k) := val; + RETURN val; +END; + +FUNCTION env_find(M IN OUT NOCOPY types.mal_table, + eeT env_entry_table, + eidx integer, + key integer) RETURN integer IS + k varchar2(256); + cnt integer; +BEGIN + k := TREAT(M(key) AS mal_str_T).val_str; + IF eeT(eidx).EXISTS(k) THEN + RETURN eidx; + ELSIF eeT(eidx)('**OUTER**') IS NOT NULL THEN + RETURN env_find(M, eeT, eeT(eidx)('**OUTER**'), key); + ELSE + RETURN NULL; + END IF; +END; + +FUNCTION env_get(M IN OUT NOCOPY types.mal_table, + eeT env_entry_table, + eidx integer, + key integer) RETURN integer IS + found integer; + k varchar2(256); +BEGIN + found := env_find(M, eeT, eidx, key); + k := TREAT(M(key) AS mal_str_T).val_str; + IF found IS NOT NULL THEN + RETURN eeT(found)(k); + ELSE + raise_application_error(-20005, + '''' || k || ''' not found', TRUE); + END IF; +END; + +END env_pkg; +/ +show errors; diff --git a/impls/plsql/io.sql b/impls/plsql/io.sql index 527dde2cb5..389821dd43 100644 --- a/impls/plsql/io.sql +++ b/impls/plsql/io.sql @@ -1,250 +1,250 @@ -BEGIN - EXECUTE IMMEDIATE 'DROP TABLE stream'; -EXCEPTION - WHEN OTHERS THEN IF SQLCODE != -942 THEN RAISE; END IF; -END; -/ - -CREATE TABLE stream ( - stream_id integer, - open number(1,0), -- stream open (1) or closed (0) - data CLOB, -- queued stream data - rl_prompt varchar2(256) -- prompt for readline input -); - --- stdin -INSERT INTO stream (stream_id, open, data, rl_prompt) - VALUES (0, 0, '', ''); --- stdout -INSERT INTO stream (stream_id, open, data, rl_prompt) - VALUES (1, 0, '', ''); - --- --------------------------------------------------------- - -BEGIN - EXECUTE IMMEDIATE 'DROP TABLE file_io'; -EXCEPTION - WHEN OTHERS THEN IF SQLCODE != -942 THEN RAISE; END IF; -END; -/ - -CREATE TABLE file_io ( - path varchar2(1024), -- file to read/write - data CLOB, -- file data - error varchar2(1024), -- any errors during read - in_or_out varchar2(4) -- input ('in') or output ('out') -); - --- --------------------------------------------------------- - -CREATE OR REPLACE PACKAGE io IS - PROCEDURE open(sid integer); - PROCEDURE close(sid integer); - FUNCTION read(sid integer DEFAULT 0) RETURN CLOB; - FUNCTION readline(prompt varchar, sid integer DEFAULT 0) RETURN CLOB; - PROCEDURE write(input CLOB, sid integer DEFAULT 1); - PROCEDURE writeline(data CLOB, sid integer DEFAULT 1); - FUNCTION wait_rl_prompt(sid integer DEFAULT 0) RETURN varchar; - PROCEDURE wait_flushed(sid integer DEFAULT 1); -FUNCTION file_open_and_read(path varchar) RETURN varchar; -END io; -/ -show errors; - -CREATE OR REPLACE PACKAGE BODY io AS - -PROCEDURE open(sid integer) AS - PRAGMA AUTONOMOUS_TRANSACTION; -BEGIN - -- DBMS_OUTPUT.PUT_LINE('io.open(' || sid || ') start'); - UPDATE stream SET data = '', rl_prompt = '', open = 1 - WHERE stream_id = sid; - COMMIT; - -- DBMS_OUTPUT.PUT_LINE('io.open(' || sid || ') done'); -END; - -PROCEDURE close(sid integer) AS - PRAGMA AUTONOMOUS_TRANSACTION; -BEGIN - -- DBMS_OUTPUT.PUT_LINE('io.close(' || sid || ') start'); - UPDATE stream SET rl_prompt = '', open = 0 - WHERE stream_id = sid; - COMMIT; - -- DBMS_OUTPUT.PUT_LINE('io.close(' || sid || ') done'); -END; - --- read: --- read from stream stream_id in stream table. Waits until there is --- either data to return or the stream closes (NULL data). Returns --- NULL when stream is closed. -FUNCTION read(sid integer DEFAULT 0) RETURN CLOB IS - PRAGMA AUTONOMOUS_TRANSACTION; - input CLOB; - isopen integer; - sleep real; -BEGIN - sleep := 0.05; - -- poll / wait for input - WHILE true - LOOP - -- atomic get and set to empty - -- LOCK TABLE stream IN EXCLUSIVE MODE; - SELECT data, open INTO input, isopen FROM stream - WHERE stream_id = sid; - IF input IS NOT NULL THEN - UPDATE stream SET data = '' WHERE stream_id = sid; - COMMIT; - RETURN trim(TRAILING chr(10) FROM input); - END IF; - -- '' -> no input, NULL -> stream closed - --RAISE NOTICE 'read input: [%] %', input, stream_id; - IF isopen = 0 THEN - raise_application_error(-20001, - 'io.read: stream ''' || sid || ''' is closed', TRUE); - END IF; - SYS.DBMS_LOCK.SLEEP(sleep); - IF sleep < 0.5 THEN - sleep := sleep * 1.1; -- backoff - END IF; - END LOOP; -END; - --- readline: --- set prompt and wait for readline style input on the stream -FUNCTION readline(prompt varchar, sid integer DEFAULT 0) RETURN CLOB IS - PRAGMA AUTONOMOUS_TRANSACTION; -BEGIN - -- set prompt / request readline style input - -- LOCK TABLE stream IN EXCLUSIVE MODE; - IF sid = 0 THEN - wait_flushed(1); - ELSIF sid = 1 THEN - wait_flushed(0); - END IF; - UPDATE stream SET rl_prompt = prompt WHERE stream_id = sid; - COMMIT; - - RETURN read(sid); -END; - -PROCEDURE write(input CLOB, sid integer DEFAULT 1) AS - PRAGMA AUTONOMOUS_TRANSACTION; -BEGIN - -- LOCK TABLE stream IN EXCLUSIVE MODE; - UPDATE stream SET data = data || input WHERE stream_id = sid; - COMMIT; -END; - -PROCEDURE writeline(data CLOB, sid integer DEFAULT 1) AS - PRAGMA AUTONOMOUS_TRANSACTION; -BEGIN - write(data || TO_CLOB(chr(10)), sid); -END; - --- --------------------------------------------------------- - --- wait_rl_prompt: --- wait for rl_prompt to be set on the given stream and return the --- rl_prompt value. Errors if stream is already closed. -FUNCTION wait_rl_prompt(sid integer DEFAULT 0) RETURN varchar IS - PRAGMA AUTONOMOUS_TRANSACTION; - isopen integer; - prompt CLOB; - sleep real; - datas integer; -BEGIN - sleep := 0.05; - WHILE true - LOOP - LOCK TABLE stream IN EXCLUSIVE MODE; - SELECT open, rl_prompt INTO isopen, prompt - FROM stream WHERE stream_id = sid; - SELECT count(stream_id) INTO datas FROM stream WHERE data IS NOT NULL; - - IF isopen = 0 THEN - raise_application_error(-20001, - 'io.wait_rl_prompt: stream ''' || sid || ''' is closed', TRUE); - END IF; - - -- wait until all channels have flushed - IF datas = 0 AND prompt IS NOT NULL THEN - UPDATE stream SET rl_prompt = '' WHERE stream_id = sid; - COMMIT; - -- Prompt is returned single-quoted because sqlplus trims - -- trailing whitespace in select output. - RETURN '''' || prompt || ''''; - END IF; - COMMIT; - - DBMS_LOCK.SLEEP(sleep); - IF sleep < 0.5 THEN - sleep := sleep * 1.1; -- backoff - END IF; - END LOOP; -END; - -PROCEDURE wait_flushed(sid integer DEFAULT 1) AS - PRAGMA AUTONOMOUS_TRANSACTION; - pending integer; - sleep real; -BEGIN - sleep := 0.05; - WHILE true - LOOP - SELECT count(stream_id) INTO pending FROM stream - WHERE stream_id = sid AND data IS NOT NULL; - IF pending = 0 THEN RETURN; END IF; - DBMS_LOCK.SLEEP(sleep); - IF sleep < 0.5 THEN - sleep := sleep * 1.1; -- backoff - END IF; - END LOOP; -END; - --- --------------------------------------------------------- - -FUNCTION file_open_and_read(path varchar) RETURN varchar IS - PRAGMA AUTONOMOUS_TRANSACTION; - sleep real; - content CLOB; - error_msg varchar2(1024); -BEGIN - sleep := 0.05; - -- TODO: use unique ID instead of path - INSERT INTO file_io (path, data, error, in_or_out) - VALUES (path, NULL, NULL, 'in'); - WHILE true - LOOP - LOCK TABLE file_io IN EXCLUSIVE MODE; - SELECT data, error INTO content, error_msg - FROM file_io WHERE path = path AND ROWNUM = 1; - - IF error_msg IS NOT NULL THEN - raise_application_error(-20010, - 'open_and_read error: ''' || error_msg || '''', TRUE); - END IF; - - IF content IS NOT NULL THEN - DELETE FROM file_io WHERE path = path; - COMMIT; - RETURN content; - END IF; - COMMIT; - - -- keep waiting - DBMS_LOCK.SLEEP(sleep); - IF sleep < 0.5 THEN - sleep := sleep * 1.1; -- backoff - END IF; - END LOOP; -END; - -PROCEDURE file_read_response(path varchar, data varchar) AS - PRAGMA AUTONOMOUS_TRANSACTION; -BEGIN - UPDATE file_io SET data = data WHERE path = path; -END; - -END io; -/ -show errors; +BEGIN + EXECUTE IMMEDIATE 'DROP TABLE stream'; +EXCEPTION + WHEN OTHERS THEN IF SQLCODE != -942 THEN RAISE; END IF; +END; +/ + +CREATE TABLE stream ( + stream_id integer, + open number(1,0), -- stream open (1) or closed (0) + data CLOB, -- queued stream data + rl_prompt varchar2(256) -- prompt for readline input +); + +-- stdin +INSERT INTO stream (stream_id, open, data, rl_prompt) + VALUES (0, 0, '', ''); +-- stdout +INSERT INTO stream (stream_id, open, data, rl_prompt) + VALUES (1, 0, '', ''); + +-- --------------------------------------------------------- + +BEGIN + EXECUTE IMMEDIATE 'DROP TABLE file_io'; +EXCEPTION + WHEN OTHERS THEN IF SQLCODE != -942 THEN RAISE; END IF; +END; +/ + +CREATE TABLE file_io ( + path varchar2(1024), -- file to read/write + data CLOB, -- file data + error varchar2(1024), -- any errors during read + in_or_out varchar2(4) -- input ('in') or output ('out') +); + +-- --------------------------------------------------------- + +CREATE OR REPLACE PACKAGE io IS + PROCEDURE open(sid integer); + PROCEDURE close(sid integer); + FUNCTION read(sid integer DEFAULT 0) RETURN CLOB; + FUNCTION readline(prompt varchar, sid integer DEFAULT 0) RETURN CLOB; + PROCEDURE write(input CLOB, sid integer DEFAULT 1); + PROCEDURE writeline(data CLOB, sid integer DEFAULT 1); + FUNCTION wait_rl_prompt(sid integer DEFAULT 0) RETURN varchar; + PROCEDURE wait_flushed(sid integer DEFAULT 1); +FUNCTION file_open_and_read(path varchar) RETURN varchar; +END io; +/ +show errors; + +CREATE OR REPLACE PACKAGE BODY io AS + +PROCEDURE open(sid integer) AS + PRAGMA AUTONOMOUS_TRANSACTION; +BEGIN + -- DBMS_OUTPUT.PUT_LINE('io.open(' || sid || ') start'); + UPDATE stream SET data = '', rl_prompt = '', open = 1 + WHERE stream_id = sid; + COMMIT; + -- DBMS_OUTPUT.PUT_LINE('io.open(' || sid || ') done'); +END; + +PROCEDURE close(sid integer) AS + PRAGMA AUTONOMOUS_TRANSACTION; +BEGIN + -- DBMS_OUTPUT.PUT_LINE('io.close(' || sid || ') start'); + UPDATE stream SET rl_prompt = '', open = 0 + WHERE stream_id = sid; + COMMIT; + -- DBMS_OUTPUT.PUT_LINE('io.close(' || sid || ') done'); +END; + +-- read: +-- read from stream stream_id in stream table. Waits until there is +-- either data to return or the stream closes (NULL data). Returns +-- NULL when stream is closed. +FUNCTION read(sid integer DEFAULT 0) RETURN CLOB IS + PRAGMA AUTONOMOUS_TRANSACTION; + input CLOB; + isopen integer; + sleep real; +BEGIN + sleep := 0.05; + -- poll / wait for input + WHILE true + LOOP + -- atomic get and set to empty + -- LOCK TABLE stream IN EXCLUSIVE MODE; + SELECT data, open INTO input, isopen FROM stream + WHERE stream_id = sid; + IF input IS NOT NULL THEN + UPDATE stream SET data = '' WHERE stream_id = sid; + COMMIT; + RETURN trim(TRAILING chr(10) FROM input); + END IF; + -- '' -> no input, NULL -> stream closed + --RAISE NOTICE 'read input: [%] %', input, stream_id; + IF isopen = 0 THEN + raise_application_error(-20001, + 'io.read: stream ''' || sid || ''' is closed', TRUE); + END IF; + SYS.DBMS_LOCK.SLEEP(sleep); + IF sleep < 0.5 THEN + sleep := sleep * 1.1; -- backoff + END IF; + END LOOP; +END; + +-- readline: +-- set prompt and wait for readline style input on the stream +FUNCTION readline(prompt varchar, sid integer DEFAULT 0) RETURN CLOB IS + PRAGMA AUTONOMOUS_TRANSACTION; +BEGIN + -- set prompt / request readline style input + -- LOCK TABLE stream IN EXCLUSIVE MODE; + IF sid = 0 THEN + wait_flushed(1); + ELSIF sid = 1 THEN + wait_flushed(0); + END IF; + UPDATE stream SET rl_prompt = prompt WHERE stream_id = sid; + COMMIT; + + RETURN read(sid); +END; + +PROCEDURE write(input CLOB, sid integer DEFAULT 1) AS + PRAGMA AUTONOMOUS_TRANSACTION; +BEGIN + -- LOCK TABLE stream IN EXCLUSIVE MODE; + UPDATE stream SET data = data || input WHERE stream_id = sid; + COMMIT; +END; + +PROCEDURE writeline(data CLOB, sid integer DEFAULT 1) AS + PRAGMA AUTONOMOUS_TRANSACTION; +BEGIN + write(data || TO_CLOB(chr(10)), sid); +END; + +-- --------------------------------------------------------- + +-- wait_rl_prompt: +-- wait for rl_prompt to be set on the given stream and return the +-- rl_prompt value. Errors if stream is already closed. +FUNCTION wait_rl_prompt(sid integer DEFAULT 0) RETURN varchar IS + PRAGMA AUTONOMOUS_TRANSACTION; + isopen integer; + prompt CLOB; + sleep real; + datas integer; +BEGIN + sleep := 0.05; + WHILE true + LOOP + LOCK TABLE stream IN EXCLUSIVE MODE; + SELECT open, rl_prompt INTO isopen, prompt + FROM stream WHERE stream_id = sid; + SELECT count(stream_id) INTO datas FROM stream WHERE data IS NOT NULL; + + IF isopen = 0 THEN + raise_application_error(-20001, + 'io.wait_rl_prompt: stream ''' || sid || ''' is closed', TRUE); + END IF; + + -- wait until all channels have flushed + IF datas = 0 AND prompt IS NOT NULL THEN + UPDATE stream SET rl_prompt = '' WHERE stream_id = sid; + COMMIT; + -- Prompt is returned single-quoted because sqlplus trims + -- trailing whitespace in select output. + RETURN '''' || prompt || ''''; + END IF; + COMMIT; + + DBMS_LOCK.SLEEP(sleep); + IF sleep < 0.5 THEN + sleep := sleep * 1.1; -- backoff + END IF; + END LOOP; +END; + +PROCEDURE wait_flushed(sid integer DEFAULT 1) AS + PRAGMA AUTONOMOUS_TRANSACTION; + pending integer; + sleep real; +BEGIN + sleep := 0.05; + WHILE true + LOOP + SELECT count(stream_id) INTO pending FROM stream + WHERE stream_id = sid AND data IS NOT NULL; + IF pending = 0 THEN RETURN; END IF; + DBMS_LOCK.SLEEP(sleep); + IF sleep < 0.5 THEN + sleep := sleep * 1.1; -- backoff + END IF; + END LOOP; +END; + +-- --------------------------------------------------------- + +FUNCTION file_open_and_read(path varchar) RETURN varchar IS + PRAGMA AUTONOMOUS_TRANSACTION; + sleep real; + content CLOB; + error_msg varchar2(1024); +BEGIN + sleep := 0.05; + -- TODO: use unique ID instead of path + INSERT INTO file_io (path, data, error, in_or_out) + VALUES (path, NULL, NULL, 'in'); + WHILE true + LOOP + LOCK TABLE file_io IN EXCLUSIVE MODE; + SELECT data, error INTO content, error_msg + FROM file_io WHERE path = path AND ROWNUM = 1; + + IF error_msg IS NOT NULL THEN + raise_application_error(-20010, + 'open_and_read error: ''' || error_msg || '''', TRUE); + END IF; + + IF content IS NOT NULL THEN + DELETE FROM file_io WHERE path = path; + COMMIT; + RETURN content; + END IF; + COMMIT; + + -- keep waiting + DBMS_LOCK.SLEEP(sleep); + IF sleep < 0.5 THEN + sleep := sleep * 1.1; -- backoff + END IF; + END LOOP; +END; + +PROCEDURE file_read_response(path varchar, data varchar) AS + PRAGMA AUTONOMOUS_TRANSACTION; +BEGIN + UPDATE file_io SET data = data WHERE path = path; +END; + +END io; +/ +show errors; diff --git a/impls/plsql/login.sql b/impls/plsql/login.sql index 0cf9f6b7ca..2f1bd4f3bc 100644 --- a/impls/plsql/login.sql +++ b/impls/plsql/login.sql @@ -1,25 +1,25 @@ --- PROMPT 'Start login.sql'; -whenever sqlerror exit SQL.SQLCODE; -whenever oserror exit 1; - -SET ECHO OFF; -SET LINESIZE 32767; --- SET TRIMOUT ON; --- SET WRAP OFF; -SET PAGESIZE 0; - --- Do not format whitespace in terminaml output -SET TAB OFF; - --- Allow literal & in strings -SET DEFINE OFF; - --- Print DBMS_OUTPUT.PUT_LINE debugcommands -SET SERVEROUTPUT ON SIZE 30000; - --- Do not truncate or wrap CLOB output -SET LONG 32767; -SET LONGCHUNKSIZE 32767; - --- PROMPT 'Finish login.sql'; - +-- PROMPT 'Start login.sql'; +whenever sqlerror exit SQL.SQLCODE; +whenever oserror exit 1; + +SET ECHO OFF; +SET LINESIZE 32767; +-- SET TRIMOUT ON; +-- SET WRAP OFF; +SET PAGESIZE 0; + +-- Do not format whitespace in terminaml output +SET TAB OFF; + +-- Allow literal & in strings +SET DEFINE OFF; + +-- Print DBMS_OUTPUT.PUT_LINE debugcommands +SET SERVEROUTPUT ON SIZE 30000; + +-- Do not truncate or wrap CLOB output +SET LONG 32767; +SET LONGCHUNKSIZE 32767; + +-- PROMPT 'Finish login.sql'; + diff --git a/impls/plsql/printer.sql b/impls/plsql/printer.sql index f64e272c48..e10214c1e1 100644 --- a/impls/plsql/printer.sql +++ b/impls/plsql/printer.sql @@ -1,128 +1,128 @@ --- --------------------------------------------------------- --- printer.sql - -CREATE OR REPLACE PACKAGE printer IS - FUNCTION pr_str_seq(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - seq mal_vals, sep varchar2, - print_readably boolean DEFAULT TRUE) RETURN varchar; - FUNCTION pr_str(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - ast integer, - print_readably boolean DEFAULT TRUE) RETURN varchar; -END printer; -/ -show errors; - -CREATE OR REPLACE PACKAGE BODY printer AS - -FUNCTION pr_str_seq(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - seq mal_vals, sep varchar2, - print_readably boolean DEFAULT TRUE) RETURN varchar IS - first integer := 1; - str CLOB; -BEGIN - FOR i IN 1..seq.COUNT LOOP - IF first = 1 THEN - first := 0; - ELSE - str := str || sep; - END IF; - str := str || pr_str(M, H, seq(i), print_readably); - END LOOP; - RETURN str; -END; - -FUNCTION pr_str_map(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - midx integer, sep varchar2, - print_readably boolean DEFAULT TRUE) RETURN varchar IS - key varchar2(256); - first integer := 1; - str CLOB; -BEGIN - key := H(midx).FIRST(); - WHILE key IS NOT NULL LOOP - IF first = 1 THEN - first := 0; - ELSE - str := str || sep; - END IF; - str := str || pr_str(M, H, types.string(M, key), print_readably); - str := str || ' ' || pr_str(M, H, H(midx)(key), print_readably); - key := H(midx).NEXT(key); - END LOOP; - RETURN str; -END; - - -FUNCTION pr_str(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - ast integer, - print_readably boolean DEFAULT TRUE) RETURN varchar IS - type_id integer; - first integer := 1; - i integer; - str CLOB; - malfn mal_func_T; -BEGIN - type_id := M(ast).type_id; - -- io.writeline('pr_str type: ' || type_id); - CASE - WHEN type_id = 0 THEN RETURN 'nil'; - WHEN type_id = 1 THEN RETURN 'false'; - WHEN type_id = 2 THEN RETURN 'true'; - WHEN type_id = 3 THEN -- integer - RETURN CAST(TREAT(M(ast) AS mal_int_T).val_int as varchar); - WHEN type_id IN (5,6) THEN -- string - IF type_id = 5 THEN - str := TREAT(M(ast) as mal_str_T).val_str; - ELSE - str := TREAT(M(ast) as mal_long_str_T).val_long_str; - END IF; - IF chr(127) = SUBSTR(str, 1, 1) THEN - RETURN ':' || SUBSTR(str, 2, LENGTH(str)-1); - ELSIF print_readably THEN - str := REPLACE(str, chr(92), '\\'); - str := REPLACE(str, '"', '\"'); - str := REPLACE(str, chr(10), '\n'); - RETURN '"' || str || '"'; - ELSE - RETURN str; - END IF; - RETURN TREAT(M(ast) AS mal_str_T).val_str; - WHEN type_id = 7 THEN -- symbol - RETURN TREAT(M(ast) AS mal_str_T).val_str; - WHEN type_id = 8 THEN -- list - RETURN '(' || pr_str_seq(M, H, - TREAT(M(ast) AS mal_seq_T).val_seq, ' ', - print_readably) || ')'; - WHEN type_id = 9 THEN -- vector - RETURN '[' || pr_str_seq(M, H, - TREAT(M(ast) AS mal_seq_T).val_seq, ' ', - print_readably) || ']'; - WHEN type_id = 10 THEN -- hash-map - RETURN '{' || pr_str_map(M, H, - TREAT(M(ast) AS mal_map_T).map_idx, ' ', - print_readably) || '}'; - WHEN type_id = 11 THEN -- native function - RETURN '#'; - WHEN type_id = 12 THEN -- mal function - malfn := TREAT(M(ast) AS mal_func_T); - RETURN '(fn* ' || pr_str(M, H, malfn.params, print_readably) || - ' ' || pr_str(M, H, malfn.ast, print_readably) || ')'; - WHEN type_id = 13 THEN -- atom - RETURN '(atom ' || - pr_str(M, H, TREAT(M(ast) AS mal_atom_T).val, print_readably) || - ')'; - ELSE - RETURN 'unknown'; - END CASE; -END; - -END printer; -/ -show errors; +-- --------------------------------------------------------- +-- printer.sql + +CREATE OR REPLACE PACKAGE printer IS + FUNCTION pr_str_seq(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + seq mal_vals, sep varchar2, + print_readably boolean DEFAULT TRUE) RETURN varchar; + FUNCTION pr_str(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + ast integer, + print_readably boolean DEFAULT TRUE) RETURN varchar; +END printer; +/ +show errors; + +CREATE OR REPLACE PACKAGE BODY printer AS + +FUNCTION pr_str_seq(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + seq mal_vals, sep varchar2, + print_readably boolean DEFAULT TRUE) RETURN varchar IS + first integer := 1; + str CLOB; +BEGIN + FOR i IN 1..seq.COUNT LOOP + IF first = 1 THEN + first := 0; + ELSE + str := str || sep; + END IF; + str := str || pr_str(M, H, seq(i), print_readably); + END LOOP; + RETURN str; +END; + +FUNCTION pr_str_map(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + midx integer, sep varchar2, + print_readably boolean DEFAULT TRUE) RETURN varchar IS + key varchar2(256); + first integer := 1; + str CLOB; +BEGIN + key := H(midx).FIRST(); + WHILE key IS NOT NULL LOOP + IF first = 1 THEN + first := 0; + ELSE + str := str || sep; + END IF; + str := str || pr_str(M, H, types.string(M, key), print_readably); + str := str || ' ' || pr_str(M, H, H(midx)(key), print_readably); + key := H(midx).NEXT(key); + END LOOP; + RETURN str; +END; + + +FUNCTION pr_str(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + ast integer, + print_readably boolean DEFAULT TRUE) RETURN varchar IS + type_id integer; + first integer := 1; + i integer; + str CLOB; + malfn mal_func_T; +BEGIN + type_id := M(ast).type_id; + -- io.writeline('pr_str type: ' || type_id); + CASE + WHEN type_id = 0 THEN RETURN 'nil'; + WHEN type_id = 1 THEN RETURN 'false'; + WHEN type_id = 2 THEN RETURN 'true'; + WHEN type_id = 3 THEN -- integer + RETURN CAST(TREAT(M(ast) AS mal_int_T).val_int as varchar); + WHEN type_id IN (5,6) THEN -- string + IF type_id = 5 THEN + str := TREAT(M(ast) as mal_str_T).val_str; + ELSE + str := TREAT(M(ast) as mal_long_str_T).val_long_str; + END IF; + IF chr(127) = SUBSTR(str, 1, 1) THEN + RETURN ':' || SUBSTR(str, 2, LENGTH(str)-1); + ELSIF print_readably THEN + str := REPLACE(str, chr(92), '\\'); + str := REPLACE(str, '"', '\"'); + str := REPLACE(str, chr(10), '\n'); + RETURN '"' || str || '"'; + ELSE + RETURN str; + END IF; + RETURN TREAT(M(ast) AS mal_str_T).val_str; + WHEN type_id = 7 THEN -- symbol + RETURN TREAT(M(ast) AS mal_str_T).val_str; + WHEN type_id = 8 THEN -- list + RETURN '(' || pr_str_seq(M, H, + TREAT(M(ast) AS mal_seq_T).val_seq, ' ', + print_readably) || ')'; + WHEN type_id = 9 THEN -- vector + RETURN '[' || pr_str_seq(M, H, + TREAT(M(ast) AS mal_seq_T).val_seq, ' ', + print_readably) || ']'; + WHEN type_id = 10 THEN -- hash-map + RETURN '{' || pr_str_map(M, H, + TREAT(M(ast) AS mal_map_T).map_idx, ' ', + print_readably) || '}'; + WHEN type_id = 11 THEN -- native function + RETURN '#'; + WHEN type_id = 12 THEN -- mal function + malfn := TREAT(M(ast) AS mal_func_T); + RETURN '(fn* ' || pr_str(M, H, malfn.params, print_readably) || + ' ' || pr_str(M, H, malfn.ast, print_readably) || ')'; + WHEN type_id = 13 THEN -- atom + RETURN '(atom ' || + pr_str(M, H, TREAT(M(ast) AS mal_atom_T).val, print_readably) || + ')'; + ELSE + RETURN 'unknown'; + END CASE; +END; + +END printer; +/ +show errors; diff --git a/impls/plsql/reader.sql b/impls/plsql/reader.sql index e5e37cf389..71e72b4717 100644 --- a/impls/plsql/reader.sql +++ b/impls/plsql/reader.sql @@ -1,236 +1,236 @@ --- --------------------------------------------------------- --- reader.sql - -CREATE OR REPLACE TYPE tokens FORCE AS TABLE OF CLOB; -/ - -CREATE OR REPLACE TYPE reader_T FORCE AS OBJECT ( - position integer, - toks tokens, - MEMBER FUNCTION peek (SELF IN OUT NOCOPY reader_T) RETURN varchar, - MEMBER FUNCTION next (SELF IN OUT NOCOPY reader_T) RETURN varchar -); -/ - - -CREATE OR REPLACE TYPE BODY reader_T AS - MEMBER FUNCTION peek (SELF IN OUT NOCOPY reader_T) RETURN varchar IS - BEGIN - IF position > toks.COUNT THEN - RETURN NULL; - END IF; - RETURN toks(position); - END; - MEMBER FUNCTION next (SELF IN OUT NOCOPY reader_T) RETURN varchar IS - BEGIN - position := position + 1; - RETURN toks(position-1); - END; -END; -/ - - -CREATE OR REPLACE PACKAGE reader IS - FUNCTION read_str(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - str varchar) RETURN integer; -END reader; -/ -show errors; - - -CREATE OR REPLACE PACKAGE BODY reader AS - --- tokenize: --- takes a string and returns a nested table of token strings -FUNCTION tokenize(str varchar) RETURN tokens IS - re varchar2(100) := '[[:space:] ,]*(~@|[][{}()''`~@]|"(([\].|[^\"])*)"?|;[^' || chr(10) || ']*|[^][[:space:] {}()''"`~@,;]*)'; - tok CLOB; - toks tokens := tokens(); - cnt integer; -BEGIN - cnt := REGEXP_COUNT(str, re); - FOR I IN 1..cnt LOOP - tok := REGEXP_SUBSTR(str, re, 1, I, 'm', 1); - IF tok IS NOT NULL AND SUBSTR(tok, 1, 1) <> ';' THEN - toks.extend(); - toks(toks.COUNT) := tok; - -- io.writeline('tok: [' || tok || ']'); - END IF; - END LOOP; - RETURN toks; -END; - --- read_atom: --- takes a reader_T --- updates reader_T and returns a single scalar mal value -FUNCTION read_atom(M IN OUT NOCOPY types.mal_table, - rdr IN OUT NOCOPY reader_T) RETURN integer IS - str_id integer; - str CLOB; - token CLOB; - istr varchar2(256); - result integer; -BEGIN - token := rdr.next(); - -- io.writeline('read_atom: ' || token); - IF token = 'nil' THEN -- nil - result := 1; - ELSIF token = 'false' THEN -- false - result := 2; - ELSIF token = 'true' THEN -- true - result := 3; - ELSIF REGEXP_LIKE(token, '^-?[0-9][0-9]*$') THEN -- integer - istr := token; - result := types.int(M, CAST(istr AS integer)); - ELSIF REGEXP_LIKE(token, '^".*"') THEN -- string - -- string - str := SUBSTR(token, 2, LENGTH(token)-2); - str := REPLACE(str, '\"', '"'); - str := REPLACE(str, '\n', chr(10)); - str := REPLACE(str, '\\', chr(92)); - result := types.string(M, str); - ELSIF REGEXP_LIKE(token, '^".*') THEN -- unclosed string - raise_application_error(-20003, - 'expected ''"'', got EOF', TRUE); - ELSIF REGEXP_LIKE(token, '^:.*') THEN -- keyword - -- keyword - result := types.keyword(M, SUBSTR(token, 2, LENGTH(token)-1)); - ELSE - -- symbol - result := types.symbol(M, token); - END IF; - return result; -END; - --- forward declaration of read_form -FUNCTION read_form(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - rdr IN OUT NOCOPY reader_T) RETURN integer; - --- read_seq: --- takes a reader_T --- updates reader_T and returns new mal_list/vector/hash-map -FUNCTION read_seq(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - rdr IN OUT NOCOPY reader_T, - type_id integer, - first varchar, last varchar) - RETURN integer IS - token CLOB; - items mal_vals; -BEGIN - token := rdr.next(); - IF token <> first THEN - raise_application_error(-20003, - 'expected ''' || first || '''', TRUE); - END IF; - items := mal_vals(); - LOOP - token := rdr.peek(); - IF token IS NULL THEN - raise_application_error(-20003, - 'expected ''' || last || ''', got EOF', TRUE); - END IF; - IF token = last THEN EXIT; END IF; - items.EXTEND(); - items(items.COUNT) := read_form(M, H, rdr); - END LOOP; - token := rdr.next(); - IF type_id IN (8,9) THEN - RETURN types.seq(M, type_id, items); - ELSE - RETURN types.hash_map(M, H, items); - END IF; -END; - --- read_form: --- takes a reader_T --- updates the reader_T and returns new mal value -FUNCTION read_form(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - rdr IN OUT NOCOPY reader_T) RETURN integer IS - token CLOB; - meta integer; - midx integer; -BEGIN - token := rdr.peek(); -- peek - CASE - WHEN token = '''' THEN - token := rdr.next(); - RETURN types.list(M, - types.symbol(M, 'quote'), - read_form(M, H, rdr)); - WHEN token = '`' THEN - token := rdr.next(); - RETURN types.list(M, - types.symbol(M, 'quasiquote'), - read_form(M, H, rdr)); - WHEN token = '~' THEN - token := rdr.next(); - RETURN types.list(M, - types.symbol(M, 'unquote'), - read_form(M, H, rdr)); - WHEN token = '~@' THEN - token := rdr.next(); - RETURN types.list(M, - types.symbol(M, 'splice-unquote'), - read_form(M, H, rdr)); - WHEN token = '^' THEN - token := rdr.next(); - meta := read_form(M, H, rdr); - RETURN types.list(M, - types.symbol(M, 'with-meta'), - read_form(M, H, rdr), - meta); - WHEN token = '@' THEN - token := rdr.next(); - RETURN types.list(M, - types.symbol(M, 'deref'), - read_form(M, H, rdr)); - - -- list - WHEN token = ')' THEN - raise_application_error(-20002, - 'unexpected '')''', TRUE); - WHEN token = '(' THEN - RETURN read_seq(M, H, rdr, 8, '(', ')'); - - -- vector - WHEN token = ']' THEN - raise_application_error(-20002, - 'unexpected '']''', TRUE); - WHEN token = '[' THEN - RETURN read_seq(M, H, rdr, 9, '[', ']'); - - -- hash-map - WHEN token = '}' THEN - raise_application_error(-20002, - 'unexpected ''}''', TRUE); - WHEN token = '{' THEN - RETURN read_seq(M, H, rdr, 10, '{', '}'); - - -- atom/scalar - ELSE - RETURN read_atom(M, rdr); - END CASE; -END; - --- read_str: --- takes a string --- returns a new mal value -FUNCTION read_str(M IN OUT NOCOPY types.mal_table, - H IN OUT NOCOPY types.map_entry_table, - str varchar) RETURN integer IS - toks tokens; - rdr reader_T; -BEGIN - toks := tokenize(str); - rdr := reader_T(1, toks); - -- io.writeline('token 1: ' || rdr.peek()); - RETURN read_form(M, H, rdr); -END; - -END reader; -/ -show errors; +-- --------------------------------------------------------- +-- reader.sql + +CREATE OR REPLACE TYPE tokens FORCE AS TABLE OF CLOB; +/ + +CREATE OR REPLACE TYPE reader_T FORCE AS OBJECT ( + position integer, + toks tokens, + MEMBER FUNCTION peek (SELF IN OUT NOCOPY reader_T) RETURN varchar, + MEMBER FUNCTION next (SELF IN OUT NOCOPY reader_T) RETURN varchar +); +/ + + +CREATE OR REPLACE TYPE BODY reader_T AS + MEMBER FUNCTION peek (SELF IN OUT NOCOPY reader_T) RETURN varchar IS + BEGIN + IF position > toks.COUNT THEN + RETURN NULL; + END IF; + RETURN toks(position); + END; + MEMBER FUNCTION next (SELF IN OUT NOCOPY reader_T) RETURN varchar IS + BEGIN + position := position + 1; + RETURN toks(position-1); + END; +END; +/ + + +CREATE OR REPLACE PACKAGE reader IS + FUNCTION read_str(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + str varchar) RETURN integer; +END reader; +/ +show errors; + + +CREATE OR REPLACE PACKAGE BODY reader AS + +-- tokenize: +-- takes a string and returns a nested table of token strings +FUNCTION tokenize(str varchar) RETURN tokens IS + re varchar2(100) := '[[:space:] ,]*(~@|[][{}()''`~@]|"(([\].|[^\"])*)"?|;[^' || chr(10) || ']*|[^][[:space:] {}()''"`~@,;]*)'; + tok CLOB; + toks tokens := tokens(); + cnt integer; +BEGIN + cnt := REGEXP_COUNT(str, re); + FOR I IN 1..cnt LOOP + tok := REGEXP_SUBSTR(str, re, 1, I, 'm', 1); + IF tok IS NOT NULL AND SUBSTR(tok, 1, 1) <> ';' THEN + toks.extend(); + toks(toks.COUNT) := tok; + -- io.writeline('tok: [' || tok || ']'); + END IF; + END LOOP; + RETURN toks; +END; + +-- read_atom: +-- takes a reader_T +-- updates reader_T and returns a single scalar mal value +FUNCTION read_atom(M IN OUT NOCOPY types.mal_table, + rdr IN OUT NOCOPY reader_T) RETURN integer IS + str_id integer; + str CLOB; + token CLOB; + istr varchar2(256); + result integer; +BEGIN + token := rdr.next(); + -- io.writeline('read_atom: ' || token); + IF token = 'nil' THEN -- nil + result := 1; + ELSIF token = 'false' THEN -- false + result := 2; + ELSIF token = 'true' THEN -- true + result := 3; + ELSIF REGEXP_LIKE(token, '^-?[0-9][0-9]*$') THEN -- integer + istr := token; + result := types.int(M, CAST(istr AS integer)); + ELSIF REGEXP_LIKE(token, '^".*"') THEN -- string + -- string + str := SUBSTR(token, 2, LENGTH(token)-2); + str := REPLACE(str, '\"', '"'); + str := REPLACE(str, '\n', chr(10)); + str := REPLACE(str, '\\', chr(92)); + result := types.string(M, str); + ELSIF REGEXP_LIKE(token, '^".*') THEN -- unclosed string + raise_application_error(-20003, + 'expected ''"'', got EOF', TRUE); + ELSIF REGEXP_LIKE(token, '^:.*') THEN -- keyword + -- keyword + result := types.keyword(M, SUBSTR(token, 2, LENGTH(token)-1)); + ELSE + -- symbol + result := types.symbol(M, token); + END IF; + return result; +END; + +-- forward declaration of read_form +FUNCTION read_form(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + rdr IN OUT NOCOPY reader_T) RETURN integer; + +-- read_seq: +-- takes a reader_T +-- updates reader_T and returns new mal_list/vector/hash-map +FUNCTION read_seq(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + rdr IN OUT NOCOPY reader_T, + type_id integer, + first varchar, last varchar) + RETURN integer IS + token CLOB; + items mal_vals; +BEGIN + token := rdr.next(); + IF token <> first THEN + raise_application_error(-20003, + 'expected ''' || first || '''', TRUE); + END IF; + items := mal_vals(); + LOOP + token := rdr.peek(); + IF token IS NULL THEN + raise_application_error(-20003, + 'expected ''' || last || ''', got EOF', TRUE); + END IF; + IF token = last THEN EXIT; END IF; + items.EXTEND(); + items(items.COUNT) := read_form(M, H, rdr); + END LOOP; + token := rdr.next(); + IF type_id IN (8,9) THEN + RETURN types.seq(M, type_id, items); + ELSE + RETURN types.hash_map(M, H, items); + END IF; +END; + +-- read_form: +-- takes a reader_T +-- updates the reader_T and returns new mal value +FUNCTION read_form(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + rdr IN OUT NOCOPY reader_T) RETURN integer IS + token CLOB; + meta integer; + midx integer; +BEGIN + token := rdr.peek(); -- peek + CASE + WHEN token = '''' THEN + token := rdr.next(); + RETURN types.list(M, + types.symbol(M, 'quote'), + read_form(M, H, rdr)); + WHEN token = '`' THEN + token := rdr.next(); + RETURN types.list(M, + types.symbol(M, 'quasiquote'), + read_form(M, H, rdr)); + WHEN token = '~' THEN + token := rdr.next(); + RETURN types.list(M, + types.symbol(M, 'unquote'), + read_form(M, H, rdr)); + WHEN token = '~@' THEN + token := rdr.next(); + RETURN types.list(M, + types.symbol(M, 'splice-unquote'), + read_form(M, H, rdr)); + WHEN token = '^' THEN + token := rdr.next(); + meta := read_form(M, H, rdr); + RETURN types.list(M, + types.symbol(M, 'with-meta'), + read_form(M, H, rdr), + meta); + WHEN token = '@' THEN + token := rdr.next(); + RETURN types.list(M, + types.symbol(M, 'deref'), + read_form(M, H, rdr)); + + -- list + WHEN token = ')' THEN + raise_application_error(-20002, + 'unexpected '')''', TRUE); + WHEN token = '(' THEN + RETURN read_seq(M, H, rdr, 8, '(', ')'); + + -- vector + WHEN token = ']' THEN + raise_application_error(-20002, + 'unexpected '']''', TRUE); + WHEN token = '[' THEN + RETURN read_seq(M, H, rdr, 9, '[', ']'); + + -- hash-map + WHEN token = '}' THEN + raise_application_error(-20002, + 'unexpected ''}''', TRUE); + WHEN token = '{' THEN + RETURN read_seq(M, H, rdr, 10, '{', '}'); + + -- atom/scalar + ELSE + RETURN read_atom(M, rdr); + END CASE; +END; + +-- read_str: +-- takes a string +-- returns a new mal value +FUNCTION read_str(M IN OUT NOCOPY types.mal_table, + H IN OUT NOCOPY types.map_entry_table, + str varchar) RETURN integer IS + toks tokens; + rdr reader_T; +BEGIN + toks := tokenize(str); + rdr := reader_T(1, toks); + -- io.writeline('token 1: ' || rdr.peek()); + RETURN read_form(M, H, rdr); +END; + +END reader; +/ +show errors; diff --git a/impls/plsql/run b/impls/plsql/run index 8613ff915a..0ce19c2bcf 100755 --- a/impls/plsql/run +++ b/impls/plsql/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/wrap.sh $(dirname $0)/${STEP:-stepA_mal}.sql "${@}" +#!/bin/bash +exec $(dirname $0)/wrap.sh $(dirname $0)/${STEP:-stepA_mal}.sql "${@}" diff --git a/impls/plsql/step0_repl.sql b/impls/plsql/step0_repl.sql index 7da8032968..755cb20cdb 100644 --- a/impls/plsql/step0_repl.sql +++ b/impls/plsql/step0_repl.sql @@ -1,64 +1,64 @@ ---\i init.sql -@io.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - line CLOB; - - -- read - FUNCTION READ(line varchar) RETURN varchar IS - BEGIN - RETURN line; - END; - - -- eval - FUNCTION EVAL(ast varchar, env varchar) RETURN varchar IS - BEGIN - RETURN ast; - END; - - -- print - FUNCTION PRINT(exp varchar) RETURN varchar IS - BEGIN - RETURN exp; - END; - - -- repl - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), '')); - END; - -BEGIN - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +--\i init.sql +@io.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + line CLOB; + + -- read + FUNCTION READ(line varchar) RETURN varchar IS + BEGIN + RETURN line; + END; + + -- eval + FUNCTION EVAL(ast varchar, env varchar) RETURN varchar IS + BEGIN + RETURN ast; + END; + + -- print + FUNCTION PRINT(exp varchar) RETURN varchar IS + BEGIN + RETURN exp; + END; + + -- repl + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), '')); + END; + +BEGIN + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/step1_read_print.sql b/impls/plsql/step1_read_print.sql index 54ed647562..d98260c3ec 100644 --- a/impls/plsql/step1_read_print.sql +++ b/impls/plsql/step1_read_print.sql @@ -1,73 +1,73 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - line CLOB; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - FUNCTION EVAL(ast integer, env varchar) RETURN integer IS - BEGIN - RETURN ast; - END; - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), '')); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.writeline('closing stream 1'); - io.close(1); -- close output stream - RETURN 0; - END IF; - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + line CLOB; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + FUNCTION EVAL(ast integer, env varchar) RETURN integer IS + BEGIN + RETURN ast; + END; + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), '')); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.writeline('closing stream 1'); + io.close(1); -- close output stream + RETURN 0; + END IF; + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/step2_eval.sql b/impls/plsql/step2_eval.sql index 3ade3ff6e5..091b378766 100644 --- a/impls/plsql/step2_eval.sql +++ b/impls/plsql/step2_eval.sql @@ -1,178 +1,178 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - TYPE env_T IS TABLE OF integer INDEX BY varchar2(100); - repl_env env_T; - line CLOB; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - - -- forward declarations - FUNCTION EVAL(ast integer, env env_T) RETURN integer; - FUNCTION do_core_func(fn integer, args mal_vals) - RETURN integer; - - FUNCTION eval_ast(ast integer, env env_T) RETURN integer IS - i integer; - old_seq mal_vals; - new_seq mal_vals; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - BEGIN - IF M(ast).type_id = 7 THEN - RETURN env(TREAT(M(ast) AS mal_str_T).val_str); - ELSIF M(ast).type_id IN (8,9) THEN - old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; - new_seq := mal_vals(); - new_seq.EXTEND(old_seq.COUNT); - FOR i IN 1..old_seq.COUNT LOOP - new_seq(i) := EVAL(old_seq(i), env); - END LOOP; - RETURN types.seq(M, M(ast).type_id, new_seq); - ELSIF M(ast).type_id IN (10) THEN - new_hm := types.hash_map(M, H, mal_vals()); - old_midx := TREAT(M(ast) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := EVAL(H(old_midx)(k), env); - k := H(old_midx).NEXT(k); - END LOOP; - RETURN new_hm; - ELSE - RETURN ast; - END IF; - END; - - FUNCTION EVAL(ast integer, env env_T) RETURN integer IS - el integer; - f integer; - args mal_vals; - BEGIN - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - IF types.count(M, ast) = 0 THEN - RETURN ast; -- empty list just returned - END IF; - - -- apply - el := eval_ast(ast, env); - f := types.first(M, el); - args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; - RETURN do_core_func(f, args); - END; - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION mal_add(args mal_vals) RETURN integer IS - BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int + - TREAT(M(args(2)) AS mal_int_T).val_int); - END; - - FUNCTION mal_subtract(args mal_vals) RETURN integer IS - BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int - - TREAT(M(args(2)) AS mal_int_T).val_int); - END; - - FUNCTION mal_multiply(args mal_vals) RETURN integer IS - BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int * - TREAT(M(args(2)) AS mal_int_T).val_int); - END; - - FUNCTION mal_divide(args mal_vals) RETURN integer IS - BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int / - TREAT(M(args(2)) AS mal_int_T).val_int); - END; - - FUNCTION do_core_func(fn integer, args mal_vals) - RETURN integer IS - fname varchar(256); - BEGIN - IF M(fn).type_id <> 11 THEN - raise_application_error(-20004, - 'Invalid function call', TRUE); - END IF; - - fname := TREAT(M(fn) AS mal_str_T).val_str; - CASE - WHEN fname = '+' THEN RETURN mal_add(args); - WHEN fname = '-' THEN RETURN mal_subtract(args); - WHEN fname = '*' THEN RETURN mal_multiply(args); - WHEN fname = '/' THEN RETURN mal_divide(args); - ELSE raise_application_error(-20004, - 'Invalid function call', TRUE); - END CASE; - END; - - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), repl_env)); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - - repl_env('+') := types.func(M, '+'); - repl_env('-') := types.func(M, '-'); - repl_env('*') := types.func(M, '*'); - repl_env('/') := types.func(M, '/'); - - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + TYPE env_T IS TABLE OF integer INDEX BY varchar2(100); + repl_env env_T; + line CLOB; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + + -- forward declarations + FUNCTION EVAL(ast integer, env env_T) RETURN integer; + FUNCTION do_core_func(fn integer, args mal_vals) + RETURN integer; + + FUNCTION eval_ast(ast integer, env env_T) RETURN integer IS + i integer; + old_seq mal_vals; + new_seq mal_vals; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + BEGIN + IF M(ast).type_id = 7 THEN + RETURN env(TREAT(M(ast) AS mal_str_T).val_str); + ELSIF M(ast).type_id IN (8,9) THEN + old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; + new_seq := mal_vals(); + new_seq.EXTEND(old_seq.COUNT); + FOR i IN 1..old_seq.COUNT LOOP + new_seq(i) := EVAL(old_seq(i), env); + END LOOP; + RETURN types.seq(M, M(ast).type_id, new_seq); + ELSIF M(ast).type_id IN (10) THEN + new_hm := types.hash_map(M, H, mal_vals()); + old_midx := TREAT(M(ast) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := EVAL(H(old_midx)(k), env); + k := H(old_midx).NEXT(k); + END LOOP; + RETURN new_hm; + ELSE + RETURN ast; + END IF; + END; + + FUNCTION EVAL(ast integer, env env_T) RETURN integer IS + el integer; + f integer; + args mal_vals; + BEGIN + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + IF types.count(M, ast) = 0 THEN + RETURN ast; -- empty list just returned + END IF; + + -- apply + el := eval_ast(ast, env); + f := types.first(M, el); + args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; + RETURN do_core_func(f, args); + END; + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION mal_add(args mal_vals) RETURN integer IS + BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int + + TREAT(M(args(2)) AS mal_int_T).val_int); + END; + + FUNCTION mal_subtract(args mal_vals) RETURN integer IS + BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int - + TREAT(M(args(2)) AS mal_int_T).val_int); + END; + + FUNCTION mal_multiply(args mal_vals) RETURN integer IS + BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int * + TREAT(M(args(2)) AS mal_int_T).val_int); + END; + + FUNCTION mal_divide(args mal_vals) RETURN integer IS + BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int / + TREAT(M(args(2)) AS mal_int_T).val_int); + END; + + FUNCTION do_core_func(fn integer, args mal_vals) + RETURN integer IS + fname varchar(256); + BEGIN + IF M(fn).type_id <> 11 THEN + raise_application_error(-20004, + 'Invalid function call', TRUE); + END IF; + + fname := TREAT(M(fn) AS mal_str_T).val_str; + CASE + WHEN fname = '+' THEN RETURN mal_add(args); + WHEN fname = '-' THEN RETURN mal_subtract(args); + WHEN fname = '*' THEN RETURN mal_multiply(args); + WHEN fname = '/' THEN RETURN mal_divide(args); + ELSE raise_application_error(-20004, + 'Invalid function call', TRUE); + END CASE; + END; + + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), repl_env)); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + + repl_env('+') := types.func(M, '+'); + repl_env('-') := types.func(M, '-'); + repl_env('*') := types.func(M, '*'); + repl_env('/') := types.func(M, '/'); + + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/step3_env.sql b/impls/plsql/step3_env.sql index 171333598b..0293d6e944 100644 --- a/impls/plsql/step3_env.sql +++ b/impls/plsql/step3_env.sql @@ -1,215 +1,215 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql -@env.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - E env_pkg.env_entry_table; -- mal env memory pool - repl_env integer; - x integer; - line CLOB; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - - -- forward declarations - FUNCTION EVAL(ast integer, env integer) RETURN integer; - FUNCTION do_core_func(fn integer, args mal_vals) - RETURN integer; - - FUNCTION eval_ast(ast integer, env integer) RETURN integer IS - i integer; - old_seq mal_vals; - new_seq mal_vals; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - BEGIN - IF M(ast).type_id = 7 THEN - RETURN env_pkg.env_get(M, E, env, ast); - ELSIF M(ast).type_id IN (8,9) THEN - old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; - new_seq := mal_vals(); - new_seq.EXTEND(old_seq.COUNT); - FOR i IN 1..old_seq.COUNT LOOP - new_seq(i) := EVAL(old_seq(i), env); - END LOOP; - RETURN types.seq(M, M(ast).type_id, new_seq); - ELSIF M(ast).type_id IN (10) THEN - new_hm := types.hash_map(M, H, mal_vals()); - old_midx := TREAT(M(ast) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := EVAL(H(old_midx)(k), env); - k := H(old_midx).NEXT(k); - END LOOP; - RETURN new_hm; - ELSE - RETURN ast; - END IF; - END; - - FUNCTION EVAL(ast integer, env integer) RETURN integer IS - el integer; - a0 integer; - a0sym varchar2(256); - seq mal_vals; - let_env integer; - i integer; - f integer; - args mal_vals; - BEGIN - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - IF types.count(M, ast) = 0 THEN - RETURN ast; -- empty list just returned - END IF; - - -- apply - a0 := types.first(M, ast); - if M(a0).type_id = 7 THEN -- symbol - a0sym := TREAT(M(a0) AS mal_str_T).val_str; - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); - WHEN a0sym = 'let*' THEN - let_env := env_pkg.env_new(M, E, env); - seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; - i := 1; - WHILE i <= seq.COUNT LOOP - x := env_pkg.env_set(M, E, let_env, - seq(i), EVAL(seq(i+1), let_env)); - i := i + 2; - END LOOP; - RETURN EVAL(types.nth(M, ast, 2), let_env); - ELSE - el := eval_ast(ast, env); - f := types.first(M, el); - args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; - RETURN do_core_func(f, args); - END CASE; - - END; - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION mal_add(args mal_vals) RETURN integer IS - BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int + - TREAT(M(args(2)) AS mal_int_T).val_int); - END; - - FUNCTION mal_subtract(args mal_vals) RETURN integer IS - BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int - - TREAT(M(args(2)) AS mal_int_T).val_int); - END; - - FUNCTION mal_multiply(args mal_vals) RETURN integer IS - BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int * - TREAT(M(args(2)) AS mal_int_T).val_int); - END; - - FUNCTION mal_divide(args mal_vals) RETURN integer IS - BEGIN - RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int / - TREAT(M(args(2)) AS mal_int_T).val_int); - END; - - FUNCTION do_core_func(fn integer, args mal_vals) - RETURN integer IS - fname varchar(256); - BEGIN - IF M(fn).type_id <> 11 THEN - raise_application_error(-20004, - 'Invalid function call', TRUE); - END IF; - - fname := TREAT(M(fn) AS mal_str_T).val_str; - CASE - WHEN fname = '+' THEN RETURN mal_add(args); - WHEN fname = '-' THEN RETURN mal_subtract(args); - WHEN fname = '*' THEN RETURN mal_multiply(args); - WHEN fname = '/' THEN RETURN mal_divide(args); - ELSE raise_application_error(-20004, - 'Invalid function call', TRUE); - END CASE; - END; - - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), repl_env)); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - E := env_pkg.env_entry_table(); - - repl_env := env_pkg.env_new(M, E, NULL); - x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '+'), - types.func(M, '+')); - x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '-'), - types.func(M, '-')); - x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '*'), - types.func(M, '*')); - x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '/'), - types.func(M, '/')); - - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql +@env.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + E env_pkg.env_entry_table; -- mal env memory pool + repl_env integer; + x integer; + line CLOB; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + + -- forward declarations + FUNCTION EVAL(ast integer, env integer) RETURN integer; + FUNCTION do_core_func(fn integer, args mal_vals) + RETURN integer; + + FUNCTION eval_ast(ast integer, env integer) RETURN integer IS + i integer; + old_seq mal_vals; + new_seq mal_vals; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + BEGIN + IF M(ast).type_id = 7 THEN + RETURN env_pkg.env_get(M, E, env, ast); + ELSIF M(ast).type_id IN (8,9) THEN + old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; + new_seq := mal_vals(); + new_seq.EXTEND(old_seq.COUNT); + FOR i IN 1..old_seq.COUNT LOOP + new_seq(i) := EVAL(old_seq(i), env); + END LOOP; + RETURN types.seq(M, M(ast).type_id, new_seq); + ELSIF M(ast).type_id IN (10) THEN + new_hm := types.hash_map(M, H, mal_vals()); + old_midx := TREAT(M(ast) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := EVAL(H(old_midx)(k), env); + k := H(old_midx).NEXT(k); + END LOOP; + RETURN new_hm; + ELSE + RETURN ast; + END IF; + END; + + FUNCTION EVAL(ast integer, env integer) RETURN integer IS + el integer; + a0 integer; + a0sym varchar2(256); + seq mal_vals; + let_env integer; + i integer; + f integer; + args mal_vals; + BEGIN + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + IF types.count(M, ast) = 0 THEN + RETURN ast; -- empty list just returned + END IF; + + -- apply + a0 := types.first(M, ast); + if M(a0).type_id = 7 THEN -- symbol + a0sym := TREAT(M(a0) AS mal_str_T).val_str; + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); + WHEN a0sym = 'let*' THEN + let_env := env_pkg.env_new(M, E, env); + seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; + i := 1; + WHILE i <= seq.COUNT LOOP + x := env_pkg.env_set(M, E, let_env, + seq(i), EVAL(seq(i+1), let_env)); + i := i + 2; + END LOOP; + RETURN EVAL(types.nth(M, ast, 2), let_env); + ELSE + el := eval_ast(ast, env); + f := types.first(M, el); + args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; + RETURN do_core_func(f, args); + END CASE; + + END; + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION mal_add(args mal_vals) RETURN integer IS + BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int + + TREAT(M(args(2)) AS mal_int_T).val_int); + END; + + FUNCTION mal_subtract(args mal_vals) RETURN integer IS + BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int - + TREAT(M(args(2)) AS mal_int_T).val_int); + END; + + FUNCTION mal_multiply(args mal_vals) RETURN integer IS + BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int * + TREAT(M(args(2)) AS mal_int_T).val_int); + END; + + FUNCTION mal_divide(args mal_vals) RETURN integer IS + BEGIN + RETURN types.int(M, TREAT(M(args(1)) AS mal_int_T).val_int / + TREAT(M(args(2)) AS mal_int_T).val_int); + END; + + FUNCTION do_core_func(fn integer, args mal_vals) + RETURN integer IS + fname varchar(256); + BEGIN + IF M(fn).type_id <> 11 THEN + raise_application_error(-20004, + 'Invalid function call', TRUE); + END IF; + + fname := TREAT(M(fn) AS mal_str_T).val_str; + CASE + WHEN fname = '+' THEN RETURN mal_add(args); + WHEN fname = '-' THEN RETURN mal_subtract(args); + WHEN fname = '*' THEN RETURN mal_multiply(args); + WHEN fname = '/' THEN RETURN mal_divide(args); + ELSE raise_application_error(-20004, + 'Invalid function call', TRUE); + END CASE; + END; + + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), repl_env)); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + E := env_pkg.env_entry_table(); + + repl_env := env_pkg.env_new(M, E, NULL); + x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '+'), + types.func(M, '+')); + x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '-'), + types.func(M, '-')); + x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '*'), + types.func(M, '*')); + x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '/'), + types.func(M, '/')); + + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/step4_if_fn_do.sql b/impls/plsql/step4_if_fn_do.sql index 814731c2ef..4c40374884 100644 --- a/impls/plsql/step4_if_fn_do.sql +++ b/impls/plsql/step4_if_fn_do.sql @@ -1,203 +1,203 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql -@env.sql -@core.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - E env_pkg.env_entry_table; -- mal env memory pool - repl_env integer; - x integer; - line CLOB; - core_ns core_ns_T; - cidx integer; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - - -- forward declarations - FUNCTION EVAL(ast integer, env integer) RETURN integer; - - FUNCTION eval_ast(ast integer, env integer) RETURN integer IS - i integer; - old_seq mal_vals; - new_seq mal_vals; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - BEGIN - IF M(ast).type_id = 7 THEN - RETURN env_pkg.env_get(M, E, env, ast); - ELSIF M(ast).type_id IN (8,9) THEN - old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; - new_seq := mal_vals(); - new_seq.EXTEND(old_seq.COUNT); - FOR i IN 1..old_seq.COUNT LOOP - new_seq(i) := EVAL(old_seq(i), env); - END LOOP; - RETURN types.seq(M, M(ast).type_id, new_seq); - ELSIF M(ast).type_id IN (10) THEN - new_hm := types.hash_map(M, H, mal_vals()); - old_midx := TREAT(M(ast) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := EVAL(H(old_midx)(k), env); - k := H(old_midx).NEXT(k); - END LOOP; - RETURN new_hm; - ELSE - RETURN ast; - END IF; - END; - - FUNCTION EVAL(ast integer, env integer) RETURN integer IS - el integer; - a0 integer; - a0sym varchar2(100); - seq mal_vals; - let_env integer; - i integer; - f integer; - fn_env integer; - cond integer; - malfn mal_func_T; - args mal_vals; - BEGIN - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - IF types.count(M, ast) = 0 THEN - RETURN ast; -- empty list just returned - END IF; - - -- apply - a0 := types.first(M, ast); - if M(a0).type_id = 7 THEN -- symbol - a0sym := TREAT(M(a0) AS mal_str_T).val_str; - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); - WHEN a0sym = 'let*' THEN - let_env := env_pkg.env_new(M, E, env); - seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; - i := 1; - WHILE i <= seq.COUNT LOOP - x := env_pkg.env_set(M, E, let_env, - seq(i), EVAL(seq(i+1), let_env)); - i := i + 2; - END LOOP; - RETURN EVAL(types.nth(M, ast, 2), let_env); - WHEN a0sym = 'do' THEN - el := eval_ast(types.slice(M, ast, 1), env); - RETURN types.nth(M, el, types.count(M, el)-1); - WHEN a0sym = 'if' THEN - cond := EVAL(types.nth(M, ast, 1), env); - IF cond = 1 OR cond = 2 THEN -- nil or false - IF types.count(M, ast) > 3 THEN - RETURN EVAL(types.nth(M, ast, 3), env); - ELSE - RETURN 1; -- nil - END IF; - ELSE - RETURN EVAL(types.nth(M, ast, 2), env); - END IF; - WHEN a0sym = 'fn*' THEN - RETURN types.malfunc(M, types.nth(M, ast, 2), - types.nth(M, ast, 1), - env); - ELSE - el := eval_ast(ast, env); - f := types.first(M, el); - args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, args); - RETURN EVAL(malfn.ast, fn_env); - ELSE - RETURN core.do_core_func(M, H, f, args); - END IF; - END CASE; - - END; - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), repl_env)); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - E := env_pkg.env_entry_table(); - - repl_env := env_pkg.env_new(M, E, NULL); - - -- core.EXT: defined using PL/SQL - core_ns := core.get_core_ns(); - FOR cidx IN 1..core_ns.COUNT LOOP - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, core_ns(cidx)), - types.func(M, core_ns(cidx))); - END LOOP; - - -- core.mal: defined using the language itself - line := REP('(def! not (fn* (a) (if a false true)))'); - - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql +@env.sql +@core.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + E env_pkg.env_entry_table; -- mal env memory pool + repl_env integer; + x integer; + line CLOB; + core_ns core_ns_T; + cidx integer; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + + -- forward declarations + FUNCTION EVAL(ast integer, env integer) RETURN integer; + + FUNCTION eval_ast(ast integer, env integer) RETURN integer IS + i integer; + old_seq mal_vals; + new_seq mal_vals; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + BEGIN + IF M(ast).type_id = 7 THEN + RETURN env_pkg.env_get(M, E, env, ast); + ELSIF M(ast).type_id IN (8,9) THEN + old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; + new_seq := mal_vals(); + new_seq.EXTEND(old_seq.COUNT); + FOR i IN 1..old_seq.COUNT LOOP + new_seq(i) := EVAL(old_seq(i), env); + END LOOP; + RETURN types.seq(M, M(ast).type_id, new_seq); + ELSIF M(ast).type_id IN (10) THEN + new_hm := types.hash_map(M, H, mal_vals()); + old_midx := TREAT(M(ast) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := EVAL(H(old_midx)(k), env); + k := H(old_midx).NEXT(k); + END LOOP; + RETURN new_hm; + ELSE + RETURN ast; + END IF; + END; + + FUNCTION EVAL(ast integer, env integer) RETURN integer IS + el integer; + a0 integer; + a0sym varchar2(100); + seq mal_vals; + let_env integer; + i integer; + f integer; + fn_env integer; + cond integer; + malfn mal_func_T; + args mal_vals; + BEGIN + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + IF types.count(M, ast) = 0 THEN + RETURN ast; -- empty list just returned + END IF; + + -- apply + a0 := types.first(M, ast); + if M(a0).type_id = 7 THEN -- symbol + a0sym := TREAT(M(a0) AS mal_str_T).val_str; + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); + WHEN a0sym = 'let*' THEN + let_env := env_pkg.env_new(M, E, env); + seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; + i := 1; + WHILE i <= seq.COUNT LOOP + x := env_pkg.env_set(M, E, let_env, + seq(i), EVAL(seq(i+1), let_env)); + i := i + 2; + END LOOP; + RETURN EVAL(types.nth(M, ast, 2), let_env); + WHEN a0sym = 'do' THEN + el := eval_ast(types.slice(M, ast, 1), env); + RETURN types.nth(M, el, types.count(M, el)-1); + WHEN a0sym = 'if' THEN + cond := EVAL(types.nth(M, ast, 1), env); + IF cond = 1 OR cond = 2 THEN -- nil or false + IF types.count(M, ast) > 3 THEN + RETURN EVAL(types.nth(M, ast, 3), env); + ELSE + RETURN 1; -- nil + END IF; + ELSE + RETURN EVAL(types.nth(M, ast, 2), env); + END IF; + WHEN a0sym = 'fn*' THEN + RETURN types.malfunc(M, types.nth(M, ast, 2), + types.nth(M, ast, 1), + env); + ELSE + el := eval_ast(ast, env); + f := types.first(M, el); + args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, args); + RETURN EVAL(malfn.ast, fn_env); + ELSE + RETURN core.do_core_func(M, H, f, args); + END IF; + END CASE; + + END; + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), repl_env)); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + E := env_pkg.env_entry_table(); + + repl_env := env_pkg.env_new(M, E, NULL); + + -- core.EXT: defined using PL/SQL + core_ns := core.get_core_ns(); + FOR cidx IN 1..core_ns.COUNT LOOP + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, core_ns(cidx)), + types.func(M, core_ns(cidx))); + END LOOP; + + -- core.mal: defined using the language itself + line := REP('(def! not (fn* (a) (if a false true)))'); + + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/step5_tco.sql b/impls/plsql/step5_tco.sql index 6209aba488..8f77fb6991 100644 --- a/impls/plsql/step5_tco.sql +++ b/impls/plsql/step5_tco.sql @@ -1,210 +1,210 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql -@env.sql -@core.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - E env_pkg.env_entry_table; -- mal env memory pool - repl_env integer; - x integer; - line CLOB; - core_ns core_ns_T; - cidx integer; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - - -- forward declarations - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; - - FUNCTION eval_ast(ast integer, env integer) RETURN integer IS - i integer; - old_seq mal_vals; - new_seq mal_vals; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - BEGIN - IF M(ast).type_id = 7 THEN - RETURN env_pkg.env_get(M, E, env, ast); - ELSIF M(ast).type_id IN (8,9) THEN - old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; - new_seq := mal_vals(); - new_seq.EXTEND(old_seq.COUNT); - FOR i IN 1..old_seq.COUNT LOOP - new_seq(i) := EVAL(old_seq(i), env); - END LOOP; - RETURN types.seq(M, M(ast).type_id, new_seq); - ELSIF M(ast).type_id IN (10) THEN - new_hm := types.hash_map(M, H, mal_vals()); - old_midx := TREAT(M(ast) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := EVAL(H(old_midx)(k), env); - k := H(old_midx).NEXT(k); - END LOOP; - RETURN new_hm; - ELSE - RETURN ast; - END IF; - END; - - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS - ast integer := orig_ast; - env integer := orig_env; - el integer; - a0 integer; - a0sym varchar2(100); - seq mal_vals; - let_env integer; - i integer; - f integer; - cond integer; - malfn mal_func_T; - args mal_vals; - BEGIN - WHILE TRUE LOOP - -- io.writeline('EVAL: ' || printer.pr_str(M, ast)); - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - IF types.count(M, ast) = 0 THEN - RETURN ast; -- empty list just returned - END IF; - - -- apply - a0 := types.first(M, ast); - if M(a0).type_id = 7 THEN -- symbol - a0sym := TREAT(M(a0) AS mal_str_T).val_str; - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); - WHEN a0sym = 'let*' THEN - let_env := env_pkg.env_new(M, E, env); - seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; - i := 1; - WHILE i <= seq.COUNT LOOP - x := env_pkg.env_set(M, E, let_env, - seq(i), EVAL(seq(i+1), let_env)); - i := i + 2; - END LOOP; - env := let_env; - ast := types.nth(M, ast, 2); -- TCO - WHEN a0sym = 'do' THEN - x := types.slice(M, ast, 1, types.count(M, ast)-2); - x := eval_ast(x, env); - ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO - WHEN a0sym = 'if' THEN - cond := EVAL(types.nth(M, ast, 1), env); - IF cond = 1 OR cond = 2 THEN -- nil or false - IF types.count(M, ast) > 3 THEN - ast := types.nth(M, ast, 3); -- TCO - ELSE - RETURN 1; -- nil - END IF; - ELSE - ast := types.nth(M, ast, 2); -- TCO - END IF; - WHEN a0sym = 'fn*' THEN - RETURN types.malfunc(M, types.nth(M, ast, 2), - types.nth(M, ast, 1), - env); - ELSE - el := eval_ast(ast, env); - f := types.first(M, el); - args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - env := env_pkg.env_new(M, E, malfn.env, - malfn.params, args); - ast := malfn.ast; -- TCO - ELSE - RETURN core.do_core_func(M, H, f, args); - END IF; - END CASE; - - END LOOP; - - END; - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), repl_env)); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - E := env_pkg.env_entry_table(); - - repl_env := env_pkg.env_new(M, E, NULL); - - -- core.EXT: defined using PL/SQL - core_ns := core.get_core_ns(); - FOR cidx IN 1..core_ns.COUNT LOOP - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, core_ns(cidx)), - types.func(M, core_ns(cidx))); - END LOOP; - - -- core.mal: defined using the language itself - line := REP('(def! not (fn* (a) (if a false true)))'); - - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql +@env.sql +@core.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + E env_pkg.env_entry_table; -- mal env memory pool + repl_env integer; + x integer; + line CLOB; + core_ns core_ns_T; + cidx integer; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + + -- forward declarations + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; + + FUNCTION eval_ast(ast integer, env integer) RETURN integer IS + i integer; + old_seq mal_vals; + new_seq mal_vals; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + BEGIN + IF M(ast).type_id = 7 THEN + RETURN env_pkg.env_get(M, E, env, ast); + ELSIF M(ast).type_id IN (8,9) THEN + old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; + new_seq := mal_vals(); + new_seq.EXTEND(old_seq.COUNT); + FOR i IN 1..old_seq.COUNT LOOP + new_seq(i) := EVAL(old_seq(i), env); + END LOOP; + RETURN types.seq(M, M(ast).type_id, new_seq); + ELSIF M(ast).type_id IN (10) THEN + new_hm := types.hash_map(M, H, mal_vals()); + old_midx := TREAT(M(ast) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := EVAL(H(old_midx)(k), env); + k := H(old_midx).NEXT(k); + END LOOP; + RETURN new_hm; + ELSE + RETURN ast; + END IF; + END; + + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS + ast integer := orig_ast; + env integer := orig_env; + el integer; + a0 integer; + a0sym varchar2(100); + seq mal_vals; + let_env integer; + i integer; + f integer; + cond integer; + malfn mal_func_T; + args mal_vals; + BEGIN + WHILE TRUE LOOP + -- io.writeline('EVAL: ' || printer.pr_str(M, ast)); + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + IF types.count(M, ast) = 0 THEN + RETURN ast; -- empty list just returned + END IF; + + -- apply + a0 := types.first(M, ast); + if M(a0).type_id = 7 THEN -- symbol + a0sym := TREAT(M(a0) AS mal_str_T).val_str; + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); + WHEN a0sym = 'let*' THEN + let_env := env_pkg.env_new(M, E, env); + seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; + i := 1; + WHILE i <= seq.COUNT LOOP + x := env_pkg.env_set(M, E, let_env, + seq(i), EVAL(seq(i+1), let_env)); + i := i + 2; + END LOOP; + env := let_env; + ast := types.nth(M, ast, 2); -- TCO + WHEN a0sym = 'do' THEN + x := types.slice(M, ast, 1, types.count(M, ast)-2); + x := eval_ast(x, env); + ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO + WHEN a0sym = 'if' THEN + cond := EVAL(types.nth(M, ast, 1), env); + IF cond = 1 OR cond = 2 THEN -- nil or false + IF types.count(M, ast) > 3 THEN + ast := types.nth(M, ast, 3); -- TCO + ELSE + RETURN 1; -- nil + END IF; + ELSE + ast := types.nth(M, ast, 2); -- TCO + END IF; + WHEN a0sym = 'fn*' THEN + RETURN types.malfunc(M, types.nth(M, ast, 2), + types.nth(M, ast, 1), + env); + ELSE + el := eval_ast(ast, env); + f := types.first(M, el); + args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + env := env_pkg.env_new(M, E, malfn.env, + malfn.params, args); + ast := malfn.ast; -- TCO + ELSE + RETURN core.do_core_func(M, H, f, args); + END IF; + END CASE; + + END LOOP; + + END; + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), repl_env)); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + E := env_pkg.env_entry_table(); + + repl_env := env_pkg.env_new(M, E, NULL); + + -- core.EXT: defined using PL/SQL + core_ns := core.get_core_ns(); + FOR cidx IN 1..core_ns.COUNT LOOP + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, core_ns(cidx)), + types.func(M, core_ns(cidx))); + END LOOP; + + -- core.mal: defined using the language itself + line := REP('(def! not (fn* (a) (if a false true)))'); + + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/step6_file.sql b/impls/plsql/step6_file.sql index 5ef9e59bcc..033bf47279 100644 --- a/impls/plsql/step6_file.sql +++ b/impls/plsql/step6_file.sql @@ -1,274 +1,274 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql -@env.sql -@core.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - E env_pkg.env_entry_table; -- mal env memory pool - repl_env integer; - x integer; - line CLOB; - core_ns core_ns_T; - cidx integer; - argv mal_vals; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - - -- forward declarations - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; - - FUNCTION eval_ast(ast integer, env integer) RETURN integer IS - i integer; - old_seq mal_vals; - new_seq mal_vals; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - BEGIN - IF M(ast).type_id = 7 THEN - RETURN env_pkg.env_get(M, E, env, ast); - ELSIF M(ast).type_id IN (8,9) THEN - old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; - new_seq := mal_vals(); - new_seq.EXTEND(old_seq.COUNT); - FOR i IN 1..old_seq.COUNT LOOP - new_seq(i) := EVAL(old_seq(i), env); - END LOOP; - RETURN types.seq(M, M(ast).type_id, new_seq); - ELSIF M(ast).type_id IN (10) THEN - new_hm := types.hash_map(M, H, mal_vals()); - old_midx := TREAT(M(ast) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := EVAL(H(old_midx)(k), env); - k := H(old_midx).NEXT(k); - END LOOP; - RETURN new_hm; - ELSE - RETURN ast; - END IF; - END; - - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS - ast integer := orig_ast; - env integer := orig_env; - el integer; - a0 integer; - a0sym varchar2(100); - seq mal_vals; - let_env integer; - i integer; - f integer; - cond integer; - malfn mal_func_T; - args mal_vals; - BEGIN - WHILE TRUE LOOP - -- io.writeline('EVAL: ' || printer.pr_str(M, ast)); - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - IF types.count(M, ast) = 0 THEN - RETURN ast; -- empty list just returned - END IF; - - -- apply - a0 := types.first(M, ast); - if M(a0).type_id = 7 THEN -- symbol - a0sym := TREAT(M(a0) AS mal_str_T).val_str; - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); - WHEN a0sym = 'let*' THEN - let_env := env_pkg.env_new(M, E, env); - seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; - i := 1; - WHILE i <= seq.COUNT LOOP - x := env_pkg.env_set(M, E, let_env, - seq(i), EVAL(seq(i+1), let_env)); - i := i + 2; - END LOOP; - env := let_env; - ast := types.nth(M, ast, 2); -- TCO - WHEN a0sym = 'do' THEN - x := types.slice(M, ast, 1, types.count(M, ast)-2); - x := eval_ast(x, env); - ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO - WHEN a0sym = 'if' THEN - cond := EVAL(types.nth(M, ast, 1), env); - IF cond = 1 OR cond = 2 THEN -- nil or false - IF types.count(M, ast) > 3 THEN - ast := types.nth(M, ast, 3); -- TCO - ELSE - RETURN 1; -- nil - END IF; - ELSE - ast := types.nth(M, ast, 2); -- TCO - END IF; - WHEN a0sym = 'fn*' THEN - RETURN types.malfunc(M, types.nth(M, ast, 2), - types.nth(M, ast, 1), - env); - ELSE - el := eval_ast(ast, env); - f := types.first(M, el); - args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - env := env_pkg.env_new(M, E, malfn.env, - malfn.params, args); - ast := malfn.ast; -- TCO - ELSE - RETURN do_builtin(f, args); - END IF; - END CASE; - - END LOOP; - - END; - - -- hack to get around lack of function references - -- functions that require special access to repl_env or EVAL - -- are implemented directly here, otherwise, core.do_core_fn - -- is called. - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS - fname varchar2(100); - val integer; - f integer; - malfn mal_func_T; - fargs mal_vals; - fn_env integer; - BEGIN - fname := TREAT(M(fn) AS mal_str_T).val_str; - CASE - WHEN fname = 'do_eval' THEN - RETURN EVAL(args(1), repl_env); - WHEN fname = 'swap!' THEN - val := TREAT(M(args(1)) AS mal_atom_T).val; - f := args(2); - -- slice one extra at the beginning that will be changed - -- to the value of the atom - fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; - fargs(1) := val; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, fargs); - val := EVAL(malfn.ast, fn_env); - ELSE - val := do_builtin(f, fargs); - END IF; - RETURN types.atom_reset(M, args(1), val); - ELSE - RETURN core.do_core_func(M, H, fn, args); - END CASE; - END; - - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), repl_env)); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - E := env_pkg.env_entry_table(); - - repl_env := env_pkg.env_new(M, E, NULL); - - argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; - - -- core.EXT: defined using PL/SQL - core_ns := core.get_core_ns(); - FOR cidx IN 1..core_ns.COUNT LOOP - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, core_ns(cidx)), - types.func(M, core_ns(cidx))); - END LOOP; - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, 'eval'), - types.func(M, 'do_eval')); - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, '*ARGV*'), - types.slice(M, argv, 1)); - - -- core.mal: defined using the language itself - line := REP('(def! not (fn* (a) (if a false true)))'); - line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - - IF argv.COUNT() > 0 THEN - BEGIN - line := REP('(load-file "' || - TREAT(M(argv(1)) AS mal_str_T).val_str || - '")'); - io.close(1); -- close output stream - RETURN 0; - EXCEPTION WHEN OTHERS THEN - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - io.close(1); -- close output stream - RAISE; - END; - END IF; - - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql +@env.sql +@core.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + E env_pkg.env_entry_table; -- mal env memory pool + repl_env integer; + x integer; + line CLOB; + core_ns core_ns_T; + cidx integer; + argv mal_vals; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + + -- forward declarations + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; + + FUNCTION eval_ast(ast integer, env integer) RETURN integer IS + i integer; + old_seq mal_vals; + new_seq mal_vals; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + BEGIN + IF M(ast).type_id = 7 THEN + RETURN env_pkg.env_get(M, E, env, ast); + ELSIF M(ast).type_id IN (8,9) THEN + old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; + new_seq := mal_vals(); + new_seq.EXTEND(old_seq.COUNT); + FOR i IN 1..old_seq.COUNT LOOP + new_seq(i) := EVAL(old_seq(i), env); + END LOOP; + RETURN types.seq(M, M(ast).type_id, new_seq); + ELSIF M(ast).type_id IN (10) THEN + new_hm := types.hash_map(M, H, mal_vals()); + old_midx := TREAT(M(ast) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := EVAL(H(old_midx)(k), env); + k := H(old_midx).NEXT(k); + END LOOP; + RETURN new_hm; + ELSE + RETURN ast; + END IF; + END; + + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS + ast integer := orig_ast; + env integer := orig_env; + el integer; + a0 integer; + a0sym varchar2(100); + seq mal_vals; + let_env integer; + i integer; + f integer; + cond integer; + malfn mal_func_T; + args mal_vals; + BEGIN + WHILE TRUE LOOP + -- io.writeline('EVAL: ' || printer.pr_str(M, ast)); + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + IF types.count(M, ast) = 0 THEN + RETURN ast; -- empty list just returned + END IF; + + -- apply + a0 := types.first(M, ast); + if M(a0).type_id = 7 THEN -- symbol + a0sym := TREAT(M(a0) AS mal_str_T).val_str; + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); + WHEN a0sym = 'let*' THEN + let_env := env_pkg.env_new(M, E, env); + seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; + i := 1; + WHILE i <= seq.COUNT LOOP + x := env_pkg.env_set(M, E, let_env, + seq(i), EVAL(seq(i+1), let_env)); + i := i + 2; + END LOOP; + env := let_env; + ast := types.nth(M, ast, 2); -- TCO + WHEN a0sym = 'do' THEN + x := types.slice(M, ast, 1, types.count(M, ast)-2); + x := eval_ast(x, env); + ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO + WHEN a0sym = 'if' THEN + cond := EVAL(types.nth(M, ast, 1), env); + IF cond = 1 OR cond = 2 THEN -- nil or false + IF types.count(M, ast) > 3 THEN + ast := types.nth(M, ast, 3); -- TCO + ELSE + RETURN 1; -- nil + END IF; + ELSE + ast := types.nth(M, ast, 2); -- TCO + END IF; + WHEN a0sym = 'fn*' THEN + RETURN types.malfunc(M, types.nth(M, ast, 2), + types.nth(M, ast, 1), + env); + ELSE + el := eval_ast(ast, env); + f := types.first(M, el); + args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + env := env_pkg.env_new(M, E, malfn.env, + malfn.params, args); + ast := malfn.ast; -- TCO + ELSE + RETURN do_builtin(f, args); + END IF; + END CASE; + + END LOOP; + + END; + + -- hack to get around lack of function references + -- functions that require special access to repl_env or EVAL + -- are implemented directly here, otherwise, core.do_core_fn + -- is called. + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS + fname varchar2(100); + val integer; + f integer; + malfn mal_func_T; + fargs mal_vals; + fn_env integer; + BEGIN + fname := TREAT(M(fn) AS mal_str_T).val_str; + CASE + WHEN fname = 'do_eval' THEN + RETURN EVAL(args(1), repl_env); + WHEN fname = 'swap!' THEN + val := TREAT(M(args(1)) AS mal_atom_T).val; + f := args(2); + -- slice one extra at the beginning that will be changed + -- to the value of the atom + fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; + fargs(1) := val; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, fargs); + val := EVAL(malfn.ast, fn_env); + ELSE + val := do_builtin(f, fargs); + END IF; + RETURN types.atom_reset(M, args(1), val); + ELSE + RETURN core.do_core_func(M, H, fn, args); + END CASE; + END; + + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), repl_env)); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + E := env_pkg.env_entry_table(); + + repl_env := env_pkg.env_new(M, E, NULL); + + argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; + + -- core.EXT: defined using PL/SQL + core_ns := core.get_core_ns(); + FOR cidx IN 1..core_ns.COUNT LOOP + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, core_ns(cidx)), + types.func(M, core_ns(cidx))); + END LOOP; + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, 'eval'), + types.func(M, 'do_eval')); + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, '*ARGV*'), + types.slice(M, argv, 1)); + + -- core.mal: defined using the language itself + line := REP('(def! not (fn* (a) (if a false true)))'); + line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + + IF argv.COUNT() > 0 THEN + BEGIN + line := REP('(load-file "' || + TREAT(M(argv(1)) AS mal_str_T).val_str || + '")'); + io.close(1); -- close output stream + RETURN 0; + EXCEPTION WHEN OTHERS THEN + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + io.close(1); -- close output stream + RAISE; + END; + END IF; + + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/step7_quote.sql b/impls/plsql/step7_quote.sql index 98b5c80a13..8d75e7f703 100644 --- a/impls/plsql/step7_quote.sql +++ b/impls/plsql/step7_quote.sql @@ -1,323 +1,323 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql -@env.sql -@core.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - E env_pkg.env_entry_table; -- mal env memory pool - repl_env integer; - x integer; - line CLOB; - core_ns core_ns_T; - cidx integer; - argv mal_vals; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - - -- forward declarations - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; - - FUNCTION starts_with(lst integer, sym varchar) RETURNS BOOLEAN IS - a0 integer; - BEGIN - IF TREAT(M(lst) AS mal_seq_T).val_seq.COUNT = 2 THEN - a0 := types.nth(M, ast, 0) - RETURN M(a0).type_id = 7 AND TREAT(M(a0) AS mal_str_T).val_str = sym; - END IF; - RETURN FALSE; - END; - - FUNCTION qq_loop(elt integer, acc integer) RETURNS integer IS - BEGIN - IF M(elt).type_id = 8 AND starts_with(elt, 'splice-unquote') THEN - RETURN types._list(M, types.symbol('concat'), types.nth(M, a0, 1), acc); - END IF; - RETURN types.list(M, types.symbol('cons'), quasiquote(elt), acc); - END; - - FUNCTION qq_foldr(xs integer[]) RETURNS integer IS - acc integer := types.list(M); - BEGIN - FOR i IN REVERSE 0 .. types._count(xs) - 1 LOOP - acc := qq_loop(types.nth(M, xs, i), acc); - END LOOP; - RETURN acc; - END; - - FUNCTION quasiquote(ast integer) RETURNS integer IS - BEGIN - CASE - WHEN M(ast).type_id IN (7, 10) THEN - RETURN types.list(M, types.symbol('quote'), ast); - WHEN M(ast).type_id = 9 THEN - RETURN types._list(types.symbol('vec'), qq_folr(ast)); - WHEN M(ast).type_id /= 8 THEN - RETURN ast; - WHEN starts_with(ast, 'unquote') THEN - RETURN types.nth(M, ast, 1); - ELSE - RETURN qq_foldr(ast); - END CASE; - END; $$ LANGUAGE plpgsql; - - FUNCTION eval_ast(ast integer, env integer) RETURN integer IS - i integer; - old_seq mal_vals; - new_seq mal_vals; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - BEGIN - IF M(ast).type_id = 7 THEN - RETURN env_pkg.env_get(M, E, env, ast); - ELSIF M(ast).type_id IN (8,9) THEN - old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; - new_seq := mal_vals(); - new_seq.EXTEND(old_seq.COUNT); - FOR i IN 1..old_seq.COUNT LOOP - new_seq(i) := EVAL(old_seq(i), env); - END LOOP; - RETURN types.seq(M, M(ast).type_id, new_seq); - ELSIF M(ast).type_id IN (10) THEN - new_hm := types.hash_map(M, H, mal_vals()); - old_midx := TREAT(M(ast) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := EVAL(H(old_midx)(k), env); - k := H(old_midx).NEXT(k); - END LOOP; - RETURN new_hm; - ELSE - RETURN ast; - END IF; - END; - - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS - ast integer := orig_ast; - env integer := orig_env; - el integer; - a0 integer; - a0sym varchar2(100); - seq mal_vals; - let_env integer; - i integer; - f integer; - cond integer; - malfn mal_func_T; - args mal_vals; - BEGIN - WHILE TRUE LOOP - -- io.writeline('EVAL: ' || printer.pr_str(M, ast)); - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - IF types.count(M, ast) = 0 THEN - RETURN ast; -- empty list just returned - END IF; - - -- apply - a0 := types.first(M, ast); - if M(a0).type_id = 7 THEN -- symbol - a0sym := TREAT(M(a0) AS mal_str_T).val_str; - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); - WHEN a0sym = 'let*' THEN - let_env := env_pkg.env_new(M, E, env); - seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; - i := 1; - WHILE i <= seq.COUNT LOOP - x := env_pkg.env_set(M, E, let_env, - seq(i), EVAL(seq(i+1), let_env)); - i := i + 2; - END LOOP; - env := let_env; - ast := types.nth(M, ast, 2); -- TCO - WHEN a0sym = 'quote' THEN - RETURN types.nth(M, ast, 1); - WHEN a0sym = 'quasiquoteexpand' THEN - RETURN quasiquote(types.nth(M, ast, 1)); - WHEN a0sym = 'quasiquote' THEN - RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env); - WHEN a0sym = 'do' THEN - x := types.slice(M, ast, 1, types.count(M, ast)-2); - x := eval_ast(x, env); - ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO - WHEN a0sym = 'if' THEN - cond := EVAL(types.nth(M, ast, 1), env); - IF cond = 1 OR cond = 2 THEN -- nil or false - IF types.count(M, ast) > 3 THEN - ast := types.nth(M, ast, 3); -- TCO - ELSE - RETURN 1; -- nil - END IF; - ELSE - ast := types.nth(M, ast, 2); -- TCO - END IF; - WHEN a0sym = 'fn*' THEN - RETURN types.malfunc(M, types.nth(M, ast, 2), - types.nth(M, ast, 1), - env); - ELSE - el := eval_ast(ast, env); - f := types.first(M, el); - args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - env := env_pkg.env_new(M, E, malfn.env, - malfn.params, args); - ast := malfn.ast; -- TCO - ELSE - RETURN do_builtin(f, args); - END IF; - END CASE; - - END LOOP; - - END; - - -- hack to get around lack of function references - -- functions that require special access to repl_env or EVAL - -- are implemented directly here, otherwise, core.do_core_fn - -- is called. - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS - fname varchar2(100); - val integer; - f integer; - malfn mal_func_T; - fargs mal_vals; - fn_env integer; - BEGIN - fname := TREAT(M(fn) AS mal_str_T).val_str; - CASE - WHEN fname = 'do_eval' THEN - RETURN EVAL(args(1), repl_env); - WHEN fname = 'swap!' THEN - val := TREAT(M(args(1)) AS mal_atom_T).val; - f := args(2); - -- slice one extra at the beginning that will be changed - -- to the value of the atom - fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; - fargs(1) := val; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, fargs); - val := EVAL(malfn.ast, fn_env); - ELSE - val := do_builtin(f, fargs); - END IF; - RETURN types.atom_reset(M, args(1), val); - ELSE - RETURN core.do_core_func(M, H, fn, args); - END CASE; - END; - - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), repl_env)); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - E := env_pkg.env_entry_table(); - - repl_env := env_pkg.env_new(M, E, NULL); - - argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; - - -- core.EXT: defined using PL/SQL - core_ns := core.get_core_ns(); - FOR cidx IN 1..core_ns.COUNT LOOP - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, core_ns(cidx)), - types.func(M, core_ns(cidx))); - END LOOP; - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, 'eval'), - types.func(M, 'do_eval')); - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, '*ARGV*'), - types.slice(M, argv, 1)); - - -- core.mal: defined using the language itself - line := REP('(def! not (fn* (a) (if a false true)))'); - line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - - IF argv.COUNT() > 0 THEN - BEGIN - line := REP('(load-file "' || - TREAT(M(argv(1)) AS mal_str_T).val_str || - '")'); - io.close(1); -- close output stream - RETURN 0; - EXCEPTION WHEN OTHERS THEN - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - io.close(1); -- close output stream - RAISE; - END; - END IF; - - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql +@env.sql +@core.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + E env_pkg.env_entry_table; -- mal env memory pool + repl_env integer; + x integer; + line CLOB; + core_ns core_ns_T; + cidx integer; + argv mal_vals; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + + -- forward declarations + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; + + FUNCTION starts_with(lst integer, sym varchar) RETURNS BOOLEAN IS + a0 integer; + BEGIN + IF TREAT(M(lst) AS mal_seq_T).val_seq.COUNT = 2 THEN + a0 := types.nth(M, ast, 0) + RETURN M(a0).type_id = 7 AND TREAT(M(a0) AS mal_str_T).val_str = sym; + END IF; + RETURN FALSE; + END; + + FUNCTION qq_loop(elt integer, acc integer) RETURNS integer IS + BEGIN + IF M(elt).type_id = 8 AND starts_with(elt, 'splice-unquote') THEN + RETURN types._list(M, types.symbol('concat'), types.nth(M, a0, 1), acc); + END IF; + RETURN types.list(M, types.symbol('cons'), quasiquote(elt), acc); + END; + + FUNCTION qq_foldr(xs integer[]) RETURNS integer IS + acc integer := types.list(M); + BEGIN + FOR i IN REVERSE 0 .. types._count(xs) - 1 LOOP + acc := qq_loop(types.nth(M, xs, i), acc); + END LOOP; + RETURN acc; + END; + + FUNCTION quasiquote(ast integer) RETURNS integer IS + BEGIN + CASE + WHEN M(ast).type_id IN (7, 10) THEN + RETURN types.list(M, types.symbol('quote'), ast); + WHEN M(ast).type_id = 9 THEN + RETURN types._list(types.symbol('vec'), qq_folr(ast)); + WHEN M(ast).type_id /= 8 THEN + RETURN ast; + WHEN starts_with(ast, 'unquote') THEN + RETURN types.nth(M, ast, 1); + ELSE + RETURN qq_foldr(ast); + END CASE; + END; $$ LANGUAGE plpgsql; + + FUNCTION eval_ast(ast integer, env integer) RETURN integer IS + i integer; + old_seq mal_vals; + new_seq mal_vals; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + BEGIN + IF M(ast).type_id = 7 THEN + RETURN env_pkg.env_get(M, E, env, ast); + ELSIF M(ast).type_id IN (8,9) THEN + old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; + new_seq := mal_vals(); + new_seq.EXTEND(old_seq.COUNT); + FOR i IN 1..old_seq.COUNT LOOP + new_seq(i) := EVAL(old_seq(i), env); + END LOOP; + RETURN types.seq(M, M(ast).type_id, new_seq); + ELSIF M(ast).type_id IN (10) THEN + new_hm := types.hash_map(M, H, mal_vals()); + old_midx := TREAT(M(ast) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := EVAL(H(old_midx)(k), env); + k := H(old_midx).NEXT(k); + END LOOP; + RETURN new_hm; + ELSE + RETURN ast; + END IF; + END; + + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS + ast integer := orig_ast; + env integer := orig_env; + el integer; + a0 integer; + a0sym varchar2(100); + seq mal_vals; + let_env integer; + i integer; + f integer; + cond integer; + malfn mal_func_T; + args mal_vals; + BEGIN + WHILE TRUE LOOP + -- io.writeline('EVAL: ' || printer.pr_str(M, ast)); + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + IF types.count(M, ast) = 0 THEN + RETURN ast; -- empty list just returned + END IF; + + -- apply + a0 := types.first(M, ast); + if M(a0).type_id = 7 THEN -- symbol + a0sym := TREAT(M(a0) AS mal_str_T).val_str; + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); + WHEN a0sym = 'let*' THEN + let_env := env_pkg.env_new(M, E, env); + seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; + i := 1; + WHILE i <= seq.COUNT LOOP + x := env_pkg.env_set(M, E, let_env, + seq(i), EVAL(seq(i+1), let_env)); + i := i + 2; + END LOOP; + env := let_env; + ast := types.nth(M, ast, 2); -- TCO + WHEN a0sym = 'quote' THEN + RETURN types.nth(M, ast, 1); + WHEN a0sym = 'quasiquoteexpand' THEN + RETURN quasiquote(types.nth(M, ast, 1)); + WHEN a0sym = 'quasiquote' THEN + RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env); + WHEN a0sym = 'do' THEN + x := types.slice(M, ast, 1, types.count(M, ast)-2); + x := eval_ast(x, env); + ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO + WHEN a0sym = 'if' THEN + cond := EVAL(types.nth(M, ast, 1), env); + IF cond = 1 OR cond = 2 THEN -- nil or false + IF types.count(M, ast) > 3 THEN + ast := types.nth(M, ast, 3); -- TCO + ELSE + RETURN 1; -- nil + END IF; + ELSE + ast := types.nth(M, ast, 2); -- TCO + END IF; + WHEN a0sym = 'fn*' THEN + RETURN types.malfunc(M, types.nth(M, ast, 2), + types.nth(M, ast, 1), + env); + ELSE + el := eval_ast(ast, env); + f := types.first(M, el); + args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + env := env_pkg.env_new(M, E, malfn.env, + malfn.params, args); + ast := malfn.ast; -- TCO + ELSE + RETURN do_builtin(f, args); + END IF; + END CASE; + + END LOOP; + + END; + + -- hack to get around lack of function references + -- functions that require special access to repl_env or EVAL + -- are implemented directly here, otherwise, core.do_core_fn + -- is called. + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS + fname varchar2(100); + val integer; + f integer; + malfn mal_func_T; + fargs mal_vals; + fn_env integer; + BEGIN + fname := TREAT(M(fn) AS mal_str_T).val_str; + CASE + WHEN fname = 'do_eval' THEN + RETURN EVAL(args(1), repl_env); + WHEN fname = 'swap!' THEN + val := TREAT(M(args(1)) AS mal_atom_T).val; + f := args(2); + -- slice one extra at the beginning that will be changed + -- to the value of the atom + fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; + fargs(1) := val; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, fargs); + val := EVAL(malfn.ast, fn_env); + ELSE + val := do_builtin(f, fargs); + END IF; + RETURN types.atom_reset(M, args(1), val); + ELSE + RETURN core.do_core_func(M, H, fn, args); + END CASE; + END; + + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), repl_env)); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + E := env_pkg.env_entry_table(); + + repl_env := env_pkg.env_new(M, E, NULL); + + argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; + + -- core.EXT: defined using PL/SQL + core_ns := core.get_core_ns(); + FOR cidx IN 1..core_ns.COUNT LOOP + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, core_ns(cidx)), + types.func(M, core_ns(cidx))); + END LOOP; + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, 'eval'), + types.func(M, 'do_eval')); + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, '*ARGV*'), + types.slice(M, argv, 1)); + + -- core.mal: defined using the language itself + line := REP('(def! not (fn* (a) (if a false true)))'); + line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + + IF argv.COUNT() > 0 THEN + BEGIN + line := REP('(load-file "' || + TREAT(M(argv(1)) AS mal_str_T).val_str || + '")'); + io.close(1); -- close output stream + RETURN 0; + EXCEPTION WHEN OTHERS THEN + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + io.close(1); -- close output stream + RAISE; + END; + END IF; + + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/step8_macros.sql b/impls/plsql/step8_macros.sql index ff77f1ff57..bafceff80a 100644 --- a/impls/plsql/step8_macros.sql +++ b/impls/plsql/step8_macros.sql @@ -1,380 +1,380 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql -@env.sql -@core.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - E env_pkg.env_entry_table; -- mal env memory pool - repl_env integer; - x integer; - line CLOB; - core_ns core_ns_T; - cidx integer; - argv mal_vals; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - - -- forward declarations - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; - - FUNCTION starts_with(lst integer, sym varchar) RETURNS BOOLEAN IS - a0 integer; - BEGIN - IF TREAT(M(lst) AS mal_seq_T).val_seq.COUNT = 2 THEN - a0 := types.nth(M, ast, 0) - RETURN M(a0).type_id = 7 AND TREAT(M(a0) AS mal_str_T).val_str = sym; - END IF; - RETURN FALSE; - END; - - FUNCTION qq_loop(elt integer, acc integer) RETURNS integer IS - BEGIN - IF M(elt).type_id = 8 AND starts_with(elt, 'splice-unquote') THEN - RETURN types._list(M, types.symbol('concat'), types.nth(M, a0, 1), acc); - END IF; - RETURN types.list(M, types.symbol('cons'), quasiquote(elt), acc); - END; - - FUNCTION qq_foldr(xs integer[]) RETURNS integer IS - acc integer := types.list(M); - BEGIN - FOR i IN REVERSE 0 .. types._count(xs) - 1 LOOP - acc := qq_loop(types.nth(M, xs, i), acc); - END LOOP; - RETURN acc; - END; - - FUNCTION quasiquote(ast integer) RETURNS integer IS - BEGIN - CASE - WHEN M(ast).type_id IN (7, 10) THEN - RETURN types.list(M, types.symbol('quote'), ast); - WHEN M(ast).type_id = 9 THEN - RETURN types._list(types.symbol('vec'), qq_folr(ast)); - WHEN M(ast).type_id /= 8 THEN - RETURN ast; - WHEN starts_with(ast, 'unquote') THEN - RETURN types.nth(M, ast, 1); - ELSE - RETURN qq_foldr(ast); - END CASE; - END; $$ LANGUAGE plpgsql; - - FUNCTION is_macro_call(ast integer, env integer) RETURN BOOLEAN IS - a0 integer; - mac integer; - BEGIN - IF M(ast).type_id = 8 THEN - a0 := types.nth(M, ast, 0); - IF M(a0).type_id = 7 AND - env_pkg.env_find(M, E, env, a0) IS NOT NULL THEN - mac := env_pkg.env_get(M, E, env, a0); - IF M(mac).type_id = 12 THEN - RETURN TREAT(M(mac) AS mal_func_T).is_macro > 0; - END IF; - END IF; - END IF; - RETURN FALSE; - END; - - FUNCTION macroexpand(orig_ast integer, env integer) RETURN integer IS - ast integer; - mac integer; - malfn mal_func_T; - fargs mal_vals; - fn_env integer; - BEGIN - ast := orig_ast; - WHILE is_macro_call(ast, env) LOOP - mac := env_pkg.env_get(M, E, env, types.nth(M, ast, 0)); - fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_T).val_seq; - if M(mac).type_id = 12 THEN - malfn := TREAT(M(mac) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, - fargs); - ast := EVAL(malfn.ast, fn_env); - ELSE - ast := do_builtin(mac, fargs); - END IF; - END LOOP; - RETURN ast; - END; - - FUNCTION eval_ast(ast integer, env integer) RETURN integer IS - i integer; - old_seq mal_vals; - new_seq mal_vals; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - BEGIN - IF M(ast).type_id = 7 THEN - RETURN env_pkg.env_get(M, E, env, ast); - ELSIF M(ast).type_id IN (8,9) THEN - old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; - new_seq := mal_vals(); - new_seq.EXTEND(old_seq.COUNT); - FOR i IN 1..old_seq.COUNT LOOP - new_seq(i) := EVAL(old_seq(i), env); - END LOOP; - RETURN types.seq(M, M(ast).type_id, new_seq); - ELSIF M(ast).type_id IN (10) THEN - new_hm := types.hash_map(M, H, mal_vals()); - old_midx := TREAT(M(ast) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := EVAL(H(old_midx)(k), env); - k := H(old_midx).NEXT(k); - END LOOP; - RETURN new_hm; - ELSE - RETURN ast; - END IF; - END; - - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS - ast integer := orig_ast; - env integer := orig_env; - el integer; - a0 integer; - a0sym varchar2(100); - seq mal_vals; - let_env integer; - i integer; - f integer; - cond integer; - malfn mal_func_T; - args mal_vals; - BEGIN - WHILE TRUE LOOP - -- io.writeline('EVAL: ' || printer.pr_str(M, H, ast)); - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - - -- apply - ast := macroexpand(ast, env); - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - IF types.count(M, ast) = 0 THEN - RETURN ast; -- empty list just returned - END IF; - - -- apply - a0 := types.first(M, ast); - if M(a0).type_id = 7 THEN -- symbol - a0sym := TREAT(M(a0) AS mal_str_T).val_str; - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); - WHEN a0sym = 'let*' THEN - let_env := env_pkg.env_new(M, E, env); - seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; - i := 1; - WHILE i <= seq.COUNT LOOP - x := env_pkg.env_set(M, E, let_env, - seq(i), EVAL(seq(i+1), let_env)); - i := i + 2; - END LOOP; - env := let_env; - ast := types.nth(M, ast, 2); -- TCO - WHEN a0sym = 'quote' THEN - RETURN types.nth(M, ast, 1); - WHEN a0sym = 'quasiquoteexpand' THEN - RETURN quasiquote(types.nth(M, ast, 1)); - WHEN a0sym = 'quasiquote' THEN - RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env); - WHEN a0sym = 'defmacro!' THEN - x := EVAL(types.nth(M, ast, 2), env); - malfn := TREAT(M(x) as mal_func_T); - malfn.is_macro := 1; - M(x) := malfn; - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), x); - WHEN a0sym = 'macroexpand' THEN - RETURN macroexpand(types.nth(M, ast, 1), env); - WHEN a0sym = 'do' THEN - x := types.slice(M, ast, 1, types.count(M, ast)-2); - x := eval_ast(x, env); - ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO - WHEN a0sym = 'if' THEN - cond := EVAL(types.nth(M, ast, 1), env); - IF cond = 1 OR cond = 2 THEN -- nil or false - IF types.count(M, ast) > 3 THEN - ast := types.nth(M, ast, 3); -- TCO - ELSE - RETURN 1; -- nil - END IF; - ELSE - ast := types.nth(M, ast, 2); -- TCO - END IF; - WHEN a0sym = 'fn*' THEN - RETURN types.malfunc(M, types.nth(M, ast, 2), - types.nth(M, ast, 1), - env); - ELSE - el := eval_ast(ast, env); - f := types.first(M, el); - args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - env := env_pkg.env_new(M, E, malfn.env, - malfn.params, args); - ast := malfn.ast; -- TCO - ELSE - RETURN do_builtin(f, args); - END IF; - END CASE; - - END LOOP; - - END; - - -- hack to get around lack of function references - -- functions that require special access to repl_env or EVAL - -- are implemented directly here, otherwise, core.do_core_fn - -- is called. - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS - fname varchar2(100); - val integer; - f integer; - malfn mal_func_T; - fargs mal_vals; - fn_env integer; - BEGIN - fname := TREAT(M(fn) AS mal_str_T).val_str; - CASE - WHEN fname = 'do_eval' THEN - RETURN EVAL(args(1), repl_env); - WHEN fname = 'swap!' THEN - val := TREAT(M(args(1)) AS mal_atom_T).val; - f := args(2); - -- slice one extra at the beginning that will be changed - -- to the value of the atom - fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; - fargs(1) := val; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, fargs); - val := EVAL(malfn.ast, fn_env); - ELSE - val := do_builtin(f, fargs); - END IF; - RETURN types.atom_reset(M, args(1), val); - ELSE - RETURN core.do_core_func(M, H, fn, args); - END CASE; - END; - - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), repl_env)); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - E := env_pkg.env_entry_table(); - - repl_env := env_pkg.env_new(M, E, NULL); - - argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; - - -- core.EXT: defined using PL/SQL - core_ns := core.get_core_ns(); - FOR cidx IN 1..core_ns.COUNT LOOP - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, core_ns(cidx)), - types.func(M, core_ns(cidx))); - END LOOP; - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, 'eval'), - types.func(M, 'do_eval')); - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, '*ARGV*'), - types.slice(M, argv, 1)); - - -- core.mal: defined using the language itself - line := REP('(def! not (fn* (a) (if a false true)))'); - line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - line := 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)))))))'); - - IF argv.COUNT() > 0 THEN - BEGIN - line := REP('(load-file "' || - TREAT(M(argv(1)) AS mal_str_T).val_str || - '")'); - io.close(1); -- close output stream - RETURN 0; - EXCEPTION WHEN OTHERS THEN - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - io.close(1); -- close output stream - RAISE; - END; - END IF; - - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql +@env.sql +@core.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + E env_pkg.env_entry_table; -- mal env memory pool + repl_env integer; + x integer; + line CLOB; + core_ns core_ns_T; + cidx integer; + argv mal_vals; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + + -- forward declarations + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; + + FUNCTION starts_with(lst integer, sym varchar) RETURNS BOOLEAN IS + a0 integer; + BEGIN + IF TREAT(M(lst) AS mal_seq_T).val_seq.COUNT = 2 THEN + a0 := types.nth(M, ast, 0) + RETURN M(a0).type_id = 7 AND TREAT(M(a0) AS mal_str_T).val_str = sym; + END IF; + RETURN FALSE; + END; + + FUNCTION qq_loop(elt integer, acc integer) RETURNS integer IS + BEGIN + IF M(elt).type_id = 8 AND starts_with(elt, 'splice-unquote') THEN + RETURN types._list(M, types.symbol('concat'), types.nth(M, a0, 1), acc); + END IF; + RETURN types.list(M, types.symbol('cons'), quasiquote(elt), acc); + END; + + FUNCTION qq_foldr(xs integer[]) RETURNS integer IS + acc integer := types.list(M); + BEGIN + FOR i IN REVERSE 0 .. types._count(xs) - 1 LOOP + acc := qq_loop(types.nth(M, xs, i), acc); + END LOOP; + RETURN acc; + END; + + FUNCTION quasiquote(ast integer) RETURNS integer IS + BEGIN + CASE + WHEN M(ast).type_id IN (7, 10) THEN + RETURN types.list(M, types.symbol('quote'), ast); + WHEN M(ast).type_id = 9 THEN + RETURN types._list(types.symbol('vec'), qq_folr(ast)); + WHEN M(ast).type_id /= 8 THEN + RETURN ast; + WHEN starts_with(ast, 'unquote') THEN + RETURN types.nth(M, ast, 1); + ELSE + RETURN qq_foldr(ast); + END CASE; + END; $$ LANGUAGE plpgsql; + + FUNCTION is_macro_call(ast integer, env integer) RETURN BOOLEAN IS + a0 integer; + mac integer; + BEGIN + IF M(ast).type_id = 8 THEN + a0 := types.nth(M, ast, 0); + IF M(a0).type_id = 7 AND + env_pkg.env_find(M, E, env, a0) IS NOT NULL THEN + mac := env_pkg.env_get(M, E, env, a0); + IF M(mac).type_id = 12 THEN + RETURN TREAT(M(mac) AS mal_func_T).is_macro > 0; + END IF; + END IF; + END IF; + RETURN FALSE; + END; + + FUNCTION macroexpand(orig_ast integer, env integer) RETURN integer IS + ast integer; + mac integer; + malfn mal_func_T; + fargs mal_vals; + fn_env integer; + BEGIN + ast := orig_ast; + WHILE is_macro_call(ast, env) LOOP + mac := env_pkg.env_get(M, E, env, types.nth(M, ast, 0)); + fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_T).val_seq; + if M(mac).type_id = 12 THEN + malfn := TREAT(M(mac) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, + fargs); + ast := EVAL(malfn.ast, fn_env); + ELSE + ast := do_builtin(mac, fargs); + END IF; + END LOOP; + RETURN ast; + END; + + FUNCTION eval_ast(ast integer, env integer) RETURN integer IS + i integer; + old_seq mal_vals; + new_seq mal_vals; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + BEGIN + IF M(ast).type_id = 7 THEN + RETURN env_pkg.env_get(M, E, env, ast); + ELSIF M(ast).type_id IN (8,9) THEN + old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; + new_seq := mal_vals(); + new_seq.EXTEND(old_seq.COUNT); + FOR i IN 1..old_seq.COUNT LOOP + new_seq(i) := EVAL(old_seq(i), env); + END LOOP; + RETURN types.seq(M, M(ast).type_id, new_seq); + ELSIF M(ast).type_id IN (10) THEN + new_hm := types.hash_map(M, H, mal_vals()); + old_midx := TREAT(M(ast) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := EVAL(H(old_midx)(k), env); + k := H(old_midx).NEXT(k); + END LOOP; + RETURN new_hm; + ELSE + RETURN ast; + END IF; + END; + + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS + ast integer := orig_ast; + env integer := orig_env; + el integer; + a0 integer; + a0sym varchar2(100); + seq mal_vals; + let_env integer; + i integer; + f integer; + cond integer; + malfn mal_func_T; + args mal_vals; + BEGIN + WHILE TRUE LOOP + -- io.writeline('EVAL: ' || printer.pr_str(M, H, ast)); + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + + -- apply + ast := macroexpand(ast, env); + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + IF types.count(M, ast) = 0 THEN + RETURN ast; -- empty list just returned + END IF; + + -- apply + a0 := types.first(M, ast); + if M(a0).type_id = 7 THEN -- symbol + a0sym := TREAT(M(a0) AS mal_str_T).val_str; + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); + WHEN a0sym = 'let*' THEN + let_env := env_pkg.env_new(M, E, env); + seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; + i := 1; + WHILE i <= seq.COUNT LOOP + x := env_pkg.env_set(M, E, let_env, + seq(i), EVAL(seq(i+1), let_env)); + i := i + 2; + END LOOP; + env := let_env; + ast := types.nth(M, ast, 2); -- TCO + WHEN a0sym = 'quote' THEN + RETURN types.nth(M, ast, 1); + WHEN a0sym = 'quasiquoteexpand' THEN + RETURN quasiquote(types.nth(M, ast, 1)); + WHEN a0sym = 'quasiquote' THEN + RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env); + WHEN a0sym = 'defmacro!' THEN + x := EVAL(types.nth(M, ast, 2), env); + malfn := TREAT(M(x) as mal_func_T); + malfn.is_macro := 1; + M(x) := malfn; + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), x); + WHEN a0sym = 'macroexpand' THEN + RETURN macroexpand(types.nth(M, ast, 1), env); + WHEN a0sym = 'do' THEN + x := types.slice(M, ast, 1, types.count(M, ast)-2); + x := eval_ast(x, env); + ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO + WHEN a0sym = 'if' THEN + cond := EVAL(types.nth(M, ast, 1), env); + IF cond = 1 OR cond = 2 THEN -- nil or false + IF types.count(M, ast) > 3 THEN + ast := types.nth(M, ast, 3); -- TCO + ELSE + RETURN 1; -- nil + END IF; + ELSE + ast := types.nth(M, ast, 2); -- TCO + END IF; + WHEN a0sym = 'fn*' THEN + RETURN types.malfunc(M, types.nth(M, ast, 2), + types.nth(M, ast, 1), + env); + ELSE + el := eval_ast(ast, env); + f := types.first(M, el); + args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + env := env_pkg.env_new(M, E, malfn.env, + malfn.params, args); + ast := malfn.ast; -- TCO + ELSE + RETURN do_builtin(f, args); + END IF; + END CASE; + + END LOOP; + + END; + + -- hack to get around lack of function references + -- functions that require special access to repl_env or EVAL + -- are implemented directly here, otherwise, core.do_core_fn + -- is called. + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS + fname varchar2(100); + val integer; + f integer; + malfn mal_func_T; + fargs mal_vals; + fn_env integer; + BEGIN + fname := TREAT(M(fn) AS mal_str_T).val_str; + CASE + WHEN fname = 'do_eval' THEN + RETURN EVAL(args(1), repl_env); + WHEN fname = 'swap!' THEN + val := TREAT(M(args(1)) AS mal_atom_T).val; + f := args(2); + -- slice one extra at the beginning that will be changed + -- to the value of the atom + fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; + fargs(1) := val; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, fargs); + val := EVAL(malfn.ast, fn_env); + ELSE + val := do_builtin(f, fargs); + END IF; + RETURN types.atom_reset(M, args(1), val); + ELSE + RETURN core.do_core_func(M, H, fn, args); + END CASE; + END; + + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), repl_env)); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + E := env_pkg.env_entry_table(); + + repl_env := env_pkg.env_new(M, E, NULL); + + argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; + + -- core.EXT: defined using PL/SQL + core_ns := core.get_core_ns(); + FOR cidx IN 1..core_ns.COUNT LOOP + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, core_ns(cidx)), + types.func(M, core_ns(cidx))); + END LOOP; + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, 'eval'), + types.func(M, 'do_eval')); + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, '*ARGV*'), + types.slice(M, argv, 1)); + + -- core.mal: defined using the language itself + line := REP('(def! not (fn* (a) (if a false true)))'); + line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + line := 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)))))))'); + + IF argv.COUNT() > 0 THEN + BEGIN + line := REP('(load-file "' || + TREAT(M(argv(1)) AS mal_str_T).val_str || + '")'); + io.close(1); -- close output stream + RETURN 0; + EXCEPTION WHEN OTHERS THEN + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + io.close(1); -- close output stream + RAISE; + END; + END IF; + + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/step9_try.sql b/impls/plsql/step9_try.sql index 29c948a45f..a33c1b4908 100644 --- a/impls/plsql/step9_try.sql +++ b/impls/plsql/step9_try.sql @@ -1,470 +1,470 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql -@env.sql -@core.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - E env_pkg.env_entry_table; -- mal env memory pool - repl_env integer; - x integer; - line CLOB; - core_ns core_ns_T; - cidx integer; - argv mal_vals; - err_val integer; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - - -- forward declarations - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; - - FUNCTION starts_with(lst integer, sym varchar) RETURNS BOOLEAN IS - a0 integer; - BEGIN - IF TREAT(M(lst) AS mal_seq_T).val_seq.COUNT = 2 THEN - a0 := types.nth(M, ast, 0) - RETURN M(a0).type_id = 7 AND TREAT(M(a0) AS mal_str_T).val_str = sym; - END IF; - RETURN FALSE; - END; - - FUNCTION qq_loop(elt integer, acc integer) RETURNS integer IS - BEGIN - IF M(elt).type_id = 8 AND starts_with(elt, 'splice-unquote') THEN - RETURN types._list(M, types.symbol('concat'), types.nth(M, a0, 1), acc); - END IF; - RETURN types.list(M, types.symbol('cons'), quasiquote(elt), acc); - END; - - FUNCTION qq_foldr(xs integer[]) RETURNS integer IS - acc integer := types.list(M); - BEGIN - FOR i IN REVERSE 0 .. types._count(xs) - 1 LOOP - acc := qq_loop(types.nth(M, xs, i), acc); - END LOOP; - RETURN acc; - END; - - FUNCTION quasiquote(ast integer) RETURNS integer IS - BEGIN - CASE - WHEN M(ast).type_id IN (7, 10) THEN - RETURN types.list(M, types.symbol('quote'), ast); - WHEN M(ast).type_id = 9 THEN - RETURN types._list(types.symbol('vec'), qq_folr(ast)); - WHEN M(ast).type_id /= 8 THEN - RETURN ast; - WHEN starts_with(ast, 'unquote') THEN - RETURN types.nth(M, ast, 1); - ELSE - RETURN qq_foldr(ast); - END CASE; - END; $$ LANGUAGE plpgsql; - - FUNCTION is_macro_call(ast integer, env integer) RETURN BOOLEAN IS - a0 integer; - mac integer; - BEGIN - IF M(ast).type_id = 8 THEN - a0 := types.nth(M, ast, 0); - IF M(a0).type_id = 7 AND - env_pkg.env_find(M, E, env, a0) IS NOT NULL THEN - mac := env_pkg.env_get(M, E, env, a0); - IF M(mac).type_id = 12 THEN - RETURN TREAT(M(mac) AS mal_func_T).is_macro > 0; - END IF; - END IF; - END IF; - RETURN FALSE; - END; - - FUNCTION macroexpand(orig_ast integer, env integer) RETURN integer IS - ast integer; - mac integer; - malfn mal_func_T; - fargs mal_vals; - fn_env integer; - BEGIN - ast := orig_ast; - WHILE is_macro_call(ast, env) LOOP - mac := env_pkg.env_get(M, E, env, types.nth(M, ast, 0)); - fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_T).val_seq; - if M(mac).type_id = 12 THEN - malfn := TREAT(M(mac) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, - fargs); - ast := EVAL(malfn.ast, fn_env); - ELSE - ast := do_builtin(mac, fargs); - END IF; - END LOOP; - RETURN ast; - END; - - FUNCTION eval_ast(ast integer, env integer) RETURN integer IS - i integer; - old_seq mal_vals; - new_seq mal_vals; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - BEGIN - IF M(ast).type_id = 7 THEN - RETURN env_pkg.env_get(M, E, env, ast); - ELSIF M(ast).type_id IN (8,9) THEN - old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; - new_seq := mal_vals(); - new_seq.EXTEND(old_seq.COUNT); - FOR i IN 1..old_seq.COUNT LOOP - new_seq(i) := EVAL(old_seq(i), env); - END LOOP; - RETURN types.seq(M, M(ast).type_id, new_seq); - ELSIF M(ast).type_id IN (10) THEN - new_hm := types.hash_map(M, H, mal_vals()); - old_midx := TREAT(M(ast) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := EVAL(H(old_midx)(k), env); - k := H(old_midx).NEXT(k); - END LOOP; - RETURN new_hm; - ELSE - RETURN ast; - END IF; - END; - - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS - ast integer := orig_ast; - env integer := orig_env; - el integer; - a0 integer; - a0sym varchar2(100); - seq mal_vals; - let_env integer; - try_env integer; - i integer; - f integer; - cond integer; - malfn mal_func_T; - args mal_vals; - BEGIN - WHILE TRUE LOOP - -- io.writeline('EVAL: ' || printer.pr_str(M, H, ast)); - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - - -- apply - ast := macroexpand(ast, env); - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - IF types.count(M, ast) = 0 THEN - RETURN ast; -- empty list just returned - END IF; - - -- apply - a0 := types.first(M, ast); - if M(a0).type_id = 7 THEN -- symbol - a0sym := TREAT(M(a0) AS mal_str_T).val_str; - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); - WHEN a0sym = 'let*' THEN - let_env := env_pkg.env_new(M, E, env); - seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; - i := 1; - WHILE i <= seq.COUNT LOOP - x := env_pkg.env_set(M, E, let_env, - seq(i), EVAL(seq(i+1), let_env)); - i := i + 2; - END LOOP; - env := let_env; - ast := types.nth(M, ast, 2); -- TCO - WHEN a0sym = 'quote' THEN - RETURN types.nth(M, ast, 1); - WHEN a0sym = 'quasiquoteexpand' THEN - RETURN quasiquote(types.nth(M, ast, 1)); - WHEN a0sym = 'quasiquote' THEN - RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env); - WHEN a0sym = 'defmacro!' THEN - x := EVAL(types.nth(M, ast, 2), env); - malfn := TREAT(M(x) as mal_func_T); - malfn.is_macro := 1; - M(x) := malfn; - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), x); - WHEN a0sym = 'macroexpand' THEN - RETURN macroexpand(types.nth(M, ast, 1), env); - WHEN a0sym = 'try*' THEN - DECLARE - exc integer; - a2 integer := -1; - a20 integer := -1; - a20sym varchar2(100); - BEGIN - RETURN EVAL(types.nth(M, ast, 1), env); - - EXCEPTION WHEN OTHERS THEN - IF types.count(M, ast) > 2 THEN - a2 := types.nth(M, ast, 2); - IF M(a2).type_id = 8 THEN - a20 := types.nth(M, a2, 0); - IF M(a20).type_id = 7 THEN - a20sym := TREAT(M(a20) AS mal_str_T).val_str; - END IF; - END IF; - END IF; - IF a20sym = 'catch*' THEN - IF SQLCODE <> -20000 THEN - IF SQLCODE < -20000 AND SQLCODE > -20100 THEN - exc := types.string(M, - REGEXP_REPLACE(SQLERRM, - '^ORA-200[0-9][0-9]: ')); - ELSE - exc := types.string(M, SQLERRM); - END IF; - ELSE -- mal throw - exc := err_val; - err_val := NULL; - END IF; - try_env := env_pkg.env_new(M, E, env, - types.list(M, types.nth(M, a2, 1)), - mal_vals(exc)); - RETURN EVAL(types.nth(M, a2, 2), try_env); - END IF; - RAISE; -- not handled, re-raise the exception - END; - WHEN a0sym = 'do' THEN - x := types.slice(M, ast, 1, types.count(M, ast)-2); - x := eval_ast(x, env); - ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO - WHEN a0sym = 'if' THEN - cond := EVAL(types.nth(M, ast, 1), env); - IF cond = 1 OR cond = 2 THEN -- nil or false - IF types.count(M, ast) > 3 THEN - ast := types.nth(M, ast, 3); -- TCO - ELSE - RETURN 1; -- nil - END IF; - ELSE - ast := types.nth(M, ast, 2); -- TCO - END IF; - WHEN a0sym = 'fn*' THEN - RETURN types.malfunc(M, types.nth(M, ast, 2), - types.nth(M, ast, 1), - env); - ELSE - el := eval_ast(ast, env); - f := types.first(M, el); - args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - env := env_pkg.env_new(M, E, malfn.env, - malfn.params, args); - ast := malfn.ast; -- TCO - ELSE - RETURN do_builtin(f, args); - END IF; - END CASE; - - END LOOP; - - END; - - -- hack to get around lack of function references - -- functions that require special access to repl_env or EVAL - -- are implemented directly here, otherwise, core.do_core_fn - -- is called. - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS - fname varchar2(100); - val integer; - f integer; - malfn mal_func_T; - fargs mal_vals; - fn_env integer; - i integer; - tseq mal_vals; - BEGIN - fname := TREAT(M(fn) AS mal_str_T).val_str; - CASE - WHEN fname = 'do_eval' THEN - RETURN EVAL(args(1), repl_env); - WHEN fname = 'swap!' THEN - val := TREAT(M(args(1)) AS mal_atom_T).val; - f := args(2); - -- slice one extra at the beginning that will be changed - -- to the value of the atom - fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; - fargs(1) := val; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, fargs); - val := EVAL(malfn.ast, fn_env); - ELSE - val := do_builtin(f, fargs); - END IF; - RETURN types.atom_reset(M, args(1), val); - WHEN fname = 'apply' THEN - f := args(1); - fargs := mal_vals(); - tseq := TREAT(M(args(args.COUNT())) AS mal_seq_T).val_seq; - fargs.EXTEND(args.COUNT()-2 + tseq.COUNT()); - FOR i IN 1..args.COUNT()-2 LOOP - fargs(i) := args(i+1); - END LOOP; - FOR i IN 1..tseq.COUNT() LOOP - fargs(args.COUNT()-2 + i) := tseq(i); - END LOOP; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, fargs); - val := EVAL(malfn.ast, fn_env); - ELSE - val := do_builtin(f, fargs); - END IF; - RETURN val; - WHEN fname = 'map' THEN - f := args(1); - fargs := TREAT(M(args(2)) AS mal_seq_T).val_seq; - tseq := mal_vals(); - tseq.EXTEND(fargs.COUNT()); - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - FOR i IN 1..fargs.COUNT() LOOP - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, - mal_vals(fargs(i))); - tseq(i) := EVAL(malfn.ast, fn_env); - END LOOP; - ELSE - FOR i IN 1..fargs.COUNT() LOOP - tseq(i) := do_builtin(f, - mal_vals(fargs(i))); - END LOOP; - END IF; - RETURN types.seq(M, 8, tseq); - WHEN fname = 'throw' THEN - err_val := args(1); - raise_application_error(-20000, 'MalException', TRUE); - ELSE - RETURN core.do_core_func(M, H, fn, args); - END CASE; - END; - - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), repl_env)); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - E := env_pkg.env_entry_table(); - - repl_env := env_pkg.env_new(M, E, NULL); - - argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; - - -- core.EXT: defined using PL/SQL - core_ns := core.get_core_ns(); - FOR cidx IN 1..core_ns.COUNT LOOP - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, core_ns(cidx)), - types.func(M, core_ns(cidx))); - END LOOP; - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, 'eval'), - types.func(M, 'do_eval')); - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, '*ARGV*'), - types.slice(M, argv, 1)); - - -- core.mal: defined using the language itself - line := REP('(def! not (fn* (a) (if a false true)))'); - line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - line := 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)))))))'); - - IF argv.COUNT() > 0 THEN - BEGIN - line := REP('(load-file "' || - TREAT(M(argv(1)) AS mal_str_T).val_str || - '")'); - io.close(1); -- close output stream - RETURN 0; - EXCEPTION WHEN OTHERS THEN - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - io.close(1); -- close output stream - RAISE; - END; - END IF; - - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - IF SQLCODE <> -20000 THEN - io.writeline('Error: ' || SQLERRM); - ELSE - io.writeline('Error: ' || printer.pr_str(M, H, err_val)); - END IF; - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql +@env.sql +@core.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + E env_pkg.env_entry_table; -- mal env memory pool + repl_env integer; + x integer; + line CLOB; + core_ns core_ns_T; + cidx integer; + argv mal_vals; + err_val integer; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + + -- forward declarations + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; + + FUNCTION starts_with(lst integer, sym varchar) RETURNS BOOLEAN IS + a0 integer; + BEGIN + IF TREAT(M(lst) AS mal_seq_T).val_seq.COUNT = 2 THEN + a0 := types.nth(M, ast, 0) + RETURN M(a0).type_id = 7 AND TREAT(M(a0) AS mal_str_T).val_str = sym; + END IF; + RETURN FALSE; + END; + + FUNCTION qq_loop(elt integer, acc integer) RETURNS integer IS + BEGIN + IF M(elt).type_id = 8 AND starts_with(elt, 'splice-unquote') THEN + RETURN types._list(M, types.symbol('concat'), types.nth(M, a0, 1), acc); + END IF; + RETURN types.list(M, types.symbol('cons'), quasiquote(elt), acc); + END; + + FUNCTION qq_foldr(xs integer[]) RETURNS integer IS + acc integer := types.list(M); + BEGIN + FOR i IN REVERSE 0 .. types._count(xs) - 1 LOOP + acc := qq_loop(types.nth(M, xs, i), acc); + END LOOP; + RETURN acc; + END; + + FUNCTION quasiquote(ast integer) RETURNS integer IS + BEGIN + CASE + WHEN M(ast).type_id IN (7, 10) THEN + RETURN types.list(M, types.symbol('quote'), ast); + WHEN M(ast).type_id = 9 THEN + RETURN types._list(types.symbol('vec'), qq_folr(ast)); + WHEN M(ast).type_id /= 8 THEN + RETURN ast; + WHEN starts_with(ast, 'unquote') THEN + RETURN types.nth(M, ast, 1); + ELSE + RETURN qq_foldr(ast); + END CASE; + END; $$ LANGUAGE plpgsql; + + FUNCTION is_macro_call(ast integer, env integer) RETURN BOOLEAN IS + a0 integer; + mac integer; + BEGIN + IF M(ast).type_id = 8 THEN + a0 := types.nth(M, ast, 0); + IF M(a0).type_id = 7 AND + env_pkg.env_find(M, E, env, a0) IS NOT NULL THEN + mac := env_pkg.env_get(M, E, env, a0); + IF M(mac).type_id = 12 THEN + RETURN TREAT(M(mac) AS mal_func_T).is_macro > 0; + END IF; + END IF; + END IF; + RETURN FALSE; + END; + + FUNCTION macroexpand(orig_ast integer, env integer) RETURN integer IS + ast integer; + mac integer; + malfn mal_func_T; + fargs mal_vals; + fn_env integer; + BEGIN + ast := orig_ast; + WHILE is_macro_call(ast, env) LOOP + mac := env_pkg.env_get(M, E, env, types.nth(M, ast, 0)); + fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_T).val_seq; + if M(mac).type_id = 12 THEN + malfn := TREAT(M(mac) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, + fargs); + ast := EVAL(malfn.ast, fn_env); + ELSE + ast := do_builtin(mac, fargs); + END IF; + END LOOP; + RETURN ast; + END; + + FUNCTION eval_ast(ast integer, env integer) RETURN integer IS + i integer; + old_seq mal_vals; + new_seq mal_vals; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + BEGIN + IF M(ast).type_id = 7 THEN + RETURN env_pkg.env_get(M, E, env, ast); + ELSIF M(ast).type_id IN (8,9) THEN + old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; + new_seq := mal_vals(); + new_seq.EXTEND(old_seq.COUNT); + FOR i IN 1..old_seq.COUNT LOOP + new_seq(i) := EVAL(old_seq(i), env); + END LOOP; + RETURN types.seq(M, M(ast).type_id, new_seq); + ELSIF M(ast).type_id IN (10) THEN + new_hm := types.hash_map(M, H, mal_vals()); + old_midx := TREAT(M(ast) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := EVAL(H(old_midx)(k), env); + k := H(old_midx).NEXT(k); + END LOOP; + RETURN new_hm; + ELSE + RETURN ast; + END IF; + END; + + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS + ast integer := orig_ast; + env integer := orig_env; + el integer; + a0 integer; + a0sym varchar2(100); + seq mal_vals; + let_env integer; + try_env integer; + i integer; + f integer; + cond integer; + malfn mal_func_T; + args mal_vals; + BEGIN + WHILE TRUE LOOP + -- io.writeline('EVAL: ' || printer.pr_str(M, H, ast)); + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + + -- apply + ast := macroexpand(ast, env); + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + IF types.count(M, ast) = 0 THEN + RETURN ast; -- empty list just returned + END IF; + + -- apply + a0 := types.first(M, ast); + if M(a0).type_id = 7 THEN -- symbol + a0sym := TREAT(M(a0) AS mal_str_T).val_str; + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); + WHEN a0sym = 'let*' THEN + let_env := env_pkg.env_new(M, E, env); + seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; + i := 1; + WHILE i <= seq.COUNT LOOP + x := env_pkg.env_set(M, E, let_env, + seq(i), EVAL(seq(i+1), let_env)); + i := i + 2; + END LOOP; + env := let_env; + ast := types.nth(M, ast, 2); -- TCO + WHEN a0sym = 'quote' THEN + RETURN types.nth(M, ast, 1); + WHEN a0sym = 'quasiquoteexpand' THEN + RETURN quasiquote(types.nth(M, ast, 1)); + WHEN a0sym = 'quasiquote' THEN + RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env); + WHEN a0sym = 'defmacro!' THEN + x := EVAL(types.nth(M, ast, 2), env); + malfn := TREAT(M(x) as mal_func_T); + malfn.is_macro := 1; + M(x) := malfn; + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), x); + WHEN a0sym = 'macroexpand' THEN + RETURN macroexpand(types.nth(M, ast, 1), env); + WHEN a0sym = 'try*' THEN + DECLARE + exc integer; + a2 integer := -1; + a20 integer := -1; + a20sym varchar2(100); + BEGIN + RETURN EVAL(types.nth(M, ast, 1), env); + + EXCEPTION WHEN OTHERS THEN + IF types.count(M, ast) > 2 THEN + a2 := types.nth(M, ast, 2); + IF M(a2).type_id = 8 THEN + a20 := types.nth(M, a2, 0); + IF M(a20).type_id = 7 THEN + a20sym := TREAT(M(a20) AS mal_str_T).val_str; + END IF; + END IF; + END IF; + IF a20sym = 'catch*' THEN + IF SQLCODE <> -20000 THEN + IF SQLCODE < -20000 AND SQLCODE > -20100 THEN + exc := types.string(M, + REGEXP_REPLACE(SQLERRM, + '^ORA-200[0-9][0-9]: ')); + ELSE + exc := types.string(M, SQLERRM); + END IF; + ELSE -- mal throw + exc := err_val; + err_val := NULL; + END IF; + try_env := env_pkg.env_new(M, E, env, + types.list(M, types.nth(M, a2, 1)), + mal_vals(exc)); + RETURN EVAL(types.nth(M, a2, 2), try_env); + END IF; + RAISE; -- not handled, re-raise the exception + END; + WHEN a0sym = 'do' THEN + x := types.slice(M, ast, 1, types.count(M, ast)-2); + x := eval_ast(x, env); + ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO + WHEN a0sym = 'if' THEN + cond := EVAL(types.nth(M, ast, 1), env); + IF cond = 1 OR cond = 2 THEN -- nil or false + IF types.count(M, ast) > 3 THEN + ast := types.nth(M, ast, 3); -- TCO + ELSE + RETURN 1; -- nil + END IF; + ELSE + ast := types.nth(M, ast, 2); -- TCO + END IF; + WHEN a0sym = 'fn*' THEN + RETURN types.malfunc(M, types.nth(M, ast, 2), + types.nth(M, ast, 1), + env); + ELSE + el := eval_ast(ast, env); + f := types.first(M, el); + args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + env := env_pkg.env_new(M, E, malfn.env, + malfn.params, args); + ast := malfn.ast; -- TCO + ELSE + RETURN do_builtin(f, args); + END IF; + END CASE; + + END LOOP; + + END; + + -- hack to get around lack of function references + -- functions that require special access to repl_env or EVAL + -- are implemented directly here, otherwise, core.do_core_fn + -- is called. + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS + fname varchar2(100); + val integer; + f integer; + malfn mal_func_T; + fargs mal_vals; + fn_env integer; + i integer; + tseq mal_vals; + BEGIN + fname := TREAT(M(fn) AS mal_str_T).val_str; + CASE + WHEN fname = 'do_eval' THEN + RETURN EVAL(args(1), repl_env); + WHEN fname = 'swap!' THEN + val := TREAT(M(args(1)) AS mal_atom_T).val; + f := args(2); + -- slice one extra at the beginning that will be changed + -- to the value of the atom + fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; + fargs(1) := val; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, fargs); + val := EVAL(malfn.ast, fn_env); + ELSE + val := do_builtin(f, fargs); + END IF; + RETURN types.atom_reset(M, args(1), val); + WHEN fname = 'apply' THEN + f := args(1); + fargs := mal_vals(); + tseq := TREAT(M(args(args.COUNT())) AS mal_seq_T).val_seq; + fargs.EXTEND(args.COUNT()-2 + tseq.COUNT()); + FOR i IN 1..args.COUNT()-2 LOOP + fargs(i) := args(i+1); + END LOOP; + FOR i IN 1..tseq.COUNT() LOOP + fargs(args.COUNT()-2 + i) := tseq(i); + END LOOP; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, fargs); + val := EVAL(malfn.ast, fn_env); + ELSE + val := do_builtin(f, fargs); + END IF; + RETURN val; + WHEN fname = 'map' THEN + f := args(1); + fargs := TREAT(M(args(2)) AS mal_seq_T).val_seq; + tseq := mal_vals(); + tseq.EXTEND(fargs.COUNT()); + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + FOR i IN 1..fargs.COUNT() LOOP + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, + mal_vals(fargs(i))); + tseq(i) := EVAL(malfn.ast, fn_env); + END LOOP; + ELSE + FOR i IN 1..fargs.COUNT() LOOP + tseq(i) := do_builtin(f, + mal_vals(fargs(i))); + END LOOP; + END IF; + RETURN types.seq(M, 8, tseq); + WHEN fname = 'throw' THEN + err_val := args(1); + raise_application_error(-20000, 'MalException', TRUE); + ELSE + RETURN core.do_core_func(M, H, fn, args); + END CASE; + END; + + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), repl_env)); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + E := env_pkg.env_entry_table(); + + repl_env := env_pkg.env_new(M, E, NULL); + + argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; + + -- core.EXT: defined using PL/SQL + core_ns := core.get_core_ns(); + FOR cidx IN 1..core_ns.COUNT LOOP + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, core_ns(cidx)), + types.func(M, core_ns(cidx))); + END LOOP; + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, 'eval'), + types.func(M, 'do_eval')); + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, '*ARGV*'), + types.slice(M, argv, 1)); + + -- core.mal: defined using the language itself + line := REP('(def! not (fn* (a) (if a false true)))'); + line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + line := 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)))))))'); + + IF argv.COUNT() > 0 THEN + BEGIN + line := REP('(load-file "' || + TREAT(M(argv(1)) AS mal_str_T).val_str || + '")'); + io.close(1); -- close output stream + RETURN 0; + EXCEPTION WHEN OTHERS THEN + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + io.close(1); -- close output stream + RAISE; + END; + END IF; + + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + IF SQLCODE <> -20000 THEN + io.writeline('Error: ' || SQLERRM); + ELSE + io.writeline('Error: ' || printer.pr_str(M, H, err_val)); + END IF; + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/stepA_mal.sql b/impls/plsql/stepA_mal.sql index dd07c15b25..d2c95a1f84 100644 --- a/impls/plsql/stepA_mal.sql +++ b/impls/plsql/stepA_mal.sql @@ -1,472 +1,472 @@ -@io.sql -@types.sql -@reader.sql -@printer.sql -@env.sql -@core.sql - -CREATE OR REPLACE PACKAGE mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; - -END mal; -/ - -CREATE OR REPLACE PACKAGE BODY mal IS - -FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS - M types.mal_table; -- general mal value memory pool - H types.map_entry_table; -- hashmap memory pool - E env_pkg.env_entry_table; -- mal env memory pool - repl_env integer; - x integer; - line CLOB; - core_ns core_ns_T; - cidx integer; - argv mal_vals; - err_val integer; - - -- read - FUNCTION READ(line varchar) RETURN integer IS - BEGIN - RETURN reader.read_str(M, H, line); - END; - - -- eval - - -- forward declarations - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; - - FUNCTION starts_with(lst integer, sym varchar) RETURNS BOOLEAN IS - a0 integer; - BEGIN - IF TREAT(M(lst) AS mal_seq_T).val_seq.COUNT = 2 THEN - a0 := types.nth(M, ast, 0) - RETURN M(a0).type_id = 7 AND TREAT(M(a0) AS mal_str_T).val_str = sym; - END IF; - RETURN FALSE; - END; - - FUNCTION qq_loop(elt integer, acc integer) RETURNS integer IS - BEGIN - IF M(elt).type_id = 8 AND starts_with(elt, 'splice-unquote') THEN - RETURN types._list(M, types.symbol('concat'), types.nth(M, a0, 1), acc); - END IF; - RETURN types.list(M, types.symbol('cons'), quasiquote(elt), acc); - END; - - FUNCTION qq_foldr(xs integer[]) RETURNS integer IS - acc integer := types.list(M); - BEGIN - FOR i IN REVERSE 0 .. types._count(xs) - 1 LOOP - acc := qq_loop(types.nth(M, xs, i), acc); - END LOOP; - RETURN acc; - END; - - FUNCTION quasiquote(ast integer) RETURNS integer IS - BEGIN - CASE - WHEN M(ast).type_id IN (7, 10) THEN - RETURN types.list(M, types.symbol('quote'), ast); - WHEN M(ast).type_id = 9 THEN - RETURN types._list(types.symbol('vec'), qq_folr(ast)); - WHEN M(ast).type_id /= 8 THEN - RETURN ast; - WHEN starts_with(ast, 'unquote') THEN - RETURN types.nth(M, ast, 1); - ELSE - RETURN qq_foldr(ast); - END CASE; - END; $$ LANGUAGE plpgsql; - - FUNCTION is_macro_call(ast integer, env integer) RETURN BOOLEAN IS - a0 integer; - mac integer; - BEGIN - IF M(ast).type_id = 8 THEN - a0 := types.nth(M, ast, 0); - IF M(a0).type_id = 7 AND - env_pkg.env_find(M, E, env, a0) IS NOT NULL THEN - mac := env_pkg.env_get(M, E, env, a0); - IF M(mac).type_id = 12 THEN - RETURN TREAT(M(mac) AS mal_func_T).is_macro > 0; - END IF; - END IF; - END IF; - RETURN FALSE; - END; - - FUNCTION macroexpand(orig_ast integer, env integer) RETURN integer IS - ast integer; - mac integer; - malfn mal_func_T; - fargs mal_vals; - fn_env integer; - BEGIN - ast := orig_ast; - WHILE is_macro_call(ast, env) LOOP - mac := env_pkg.env_get(M, E, env, types.nth(M, ast, 0)); - fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_T).val_seq; - if M(mac).type_id = 12 THEN - malfn := TREAT(M(mac) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, - fargs); - ast := EVAL(malfn.ast, fn_env); - ELSE - ast := do_builtin(mac, fargs); - END IF; - END LOOP; - RETURN ast; - END; - - FUNCTION eval_ast(ast integer, env integer) RETURN integer IS - i integer; - old_seq mal_vals; - new_seq mal_vals; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - BEGIN - IF M(ast).type_id = 7 THEN - RETURN env_pkg.env_get(M, E, env, ast); - ELSIF M(ast).type_id IN (8,9) THEN - old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; - new_seq := mal_vals(); - new_seq.EXTEND(old_seq.COUNT); - FOR i IN 1..old_seq.COUNT LOOP - new_seq(i) := EVAL(old_seq(i), env); - END LOOP; - RETURN types.seq(M, M(ast).type_id, new_seq); - ELSIF M(ast).type_id IN (10) THEN - new_hm := types.hash_map(M, H, mal_vals()); - old_midx := TREAT(M(ast) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := EVAL(H(old_midx)(k), env); - k := H(old_midx).NEXT(k); - END LOOP; - RETURN new_hm; - ELSE - RETURN ast; - END IF; - END; - - FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS - ast integer := orig_ast; - env integer := orig_env; - el integer; - a0 integer; - a0sym varchar2(100); - seq mal_vals; - let_env integer; - try_env integer; - i integer; - f integer; - cond integer; - malfn mal_func_T; - args mal_vals; - BEGIN - WHILE TRUE LOOP - -- io.writeline('EVAL: ' || printer.pr_str(M, H, ast)); - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - - -- apply - ast := macroexpand(ast, env); - IF M(ast).type_id <> 8 THEN - RETURN eval_ast(ast, env); - END IF; - IF types.count(M, ast) = 0 THEN - RETURN ast; -- empty list just returned - END IF; - - -- apply - a0 := types.first(M, ast); - if M(a0).type_id = 7 THEN -- symbol - a0sym := TREAT(M(a0) AS mal_str_T).val_str; - ELSE - a0sym := '__<*fn*>__'; - END IF; - - CASE - WHEN a0sym = 'def!' THEN - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); - WHEN a0sym = 'let*' THEN - let_env := env_pkg.env_new(M, E, env); - seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; - i := 1; - WHILE i <= seq.COUNT LOOP - x := env_pkg.env_set(M, E, let_env, - seq(i), EVAL(seq(i+1), let_env)); - i := i + 2; - END LOOP; - env := let_env; - ast := types.nth(M, ast, 2); -- TCO - WHEN a0sym = 'quote' THEN - RETURN types.nth(M, ast, 1); - WHEN a0sym = 'quasiquoteexpand' THEN - RETURN quasiquote(types.nth(M, ast, 1)); - WHEN a0sym = 'quasiquote' THEN - RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env); - WHEN a0sym = 'defmacro!' THEN - x := EVAL(types.nth(M, ast, 2), env); - malfn := TREAT(M(x) as mal_func_T); - malfn.is_macro := 1; - M(x) := malfn; - RETURN env_pkg.env_set(M, E, env, - types.nth(M, ast, 1), x); - WHEN a0sym = 'macroexpand' THEN - RETURN macroexpand(types.nth(M, ast, 1), env); - WHEN a0sym = 'try*' THEN - DECLARE - exc integer; - a2 integer := -1; - a20 integer := -1; - a20sym varchar2(100); - BEGIN - RETURN EVAL(types.nth(M, ast, 1), env); - - EXCEPTION WHEN OTHERS THEN - IF types.count(M, ast) > 2 THEN - a2 := types.nth(M, ast, 2); - IF M(a2).type_id = 8 THEN - a20 := types.nth(M, a2, 0); - IF M(a20).type_id = 7 THEN - a20sym := TREAT(M(a20) AS mal_str_T).val_str; - END IF; - END IF; - END IF; - IF a20sym = 'catch*' THEN - IF SQLCODE <> -20000 THEN - IF SQLCODE < -20000 AND SQLCODE > -20100 THEN - exc := types.string(M, - REGEXP_REPLACE(SQLERRM, - '^ORA-200[0-9][0-9]: ')); - ELSE - exc := types.string(M, SQLERRM); - END IF; - ELSE -- mal throw - exc := err_val; - err_val := NULL; - END IF; - try_env := env_pkg.env_new(M, E, env, - types.list(M, types.nth(M, a2, 1)), - mal_vals(exc)); - RETURN EVAL(types.nth(M, a2, 2), try_env); - END IF; - RAISE; -- not handled, re-raise the exception - END; - WHEN a0sym = 'do' THEN - x := types.slice(M, ast, 1, types.count(M, ast)-2); - x := eval_ast(x, env); - ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO - WHEN a0sym = 'if' THEN - cond := EVAL(types.nth(M, ast, 1), env); - IF cond = 1 OR cond = 2 THEN -- nil or false - IF types.count(M, ast) > 3 THEN - ast := types.nth(M, ast, 3); -- TCO - ELSE - RETURN 1; -- nil - END IF; - ELSE - ast := types.nth(M, ast, 2); -- TCO - END IF; - WHEN a0sym = 'fn*' THEN - RETURN types.malfunc(M, types.nth(M, ast, 2), - types.nth(M, ast, 1), - env); - ELSE - el := eval_ast(ast, env); - f := types.first(M, el); - args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - env := env_pkg.env_new(M, E, malfn.env, - malfn.params, args); - ast := malfn.ast; -- TCO - ELSE - RETURN do_builtin(f, args); - END IF; - END CASE; - - END LOOP; - - END; - - -- hack to get around lack of function references - -- functions that require special access to repl_env or EVAL - -- are implemented directly here, otherwise, core.do_core_fn - -- is called. - FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS - fname varchar2(100); - val integer; - f integer; - malfn mal_func_T; - fargs mal_vals; - fn_env integer; - i integer; - tseq mal_vals; - BEGIN - fname := TREAT(M(fn) AS mal_str_T).val_str; - CASE - WHEN fname = 'do_eval' THEN - RETURN EVAL(args(1), repl_env); - WHEN fname = 'swap!' THEN - val := TREAT(M(args(1)) AS mal_atom_T).val; - f := args(2); - -- slice one extra at the beginning that will be changed - -- to the value of the atom - fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; - fargs(1) := val; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, fargs); - val := EVAL(malfn.ast, fn_env); - ELSE - val := do_builtin(f, fargs); - END IF; - RETURN types.atom_reset(M, args(1), val); - WHEN fname = 'apply' THEN - f := args(1); - fargs := mal_vals(); - tseq := TREAT(M(args(args.COUNT())) AS mal_seq_T).val_seq; - fargs.EXTEND(args.COUNT()-2 + tseq.COUNT()); - FOR i IN 1..args.COUNT()-2 LOOP - fargs(i) := args(i+1); - END LOOP; - FOR i IN 1..tseq.COUNT() LOOP - fargs(args.COUNT()-2 + i) := tseq(i); - END LOOP; - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, fargs); - val := EVAL(malfn.ast, fn_env); - ELSE - val := do_builtin(f, fargs); - END IF; - RETURN val; - WHEN fname = 'map' THEN - f := args(1); - fargs := TREAT(M(args(2)) AS mal_seq_T).val_seq; - tseq := mal_vals(); - tseq.EXTEND(fargs.COUNT()); - IF M(f).type_id = 12 THEN - malfn := TREAT(M(f) AS mal_func_T); - FOR i IN 1..fargs.COUNT() LOOP - fn_env := env_pkg.env_new(M, E, malfn.env, - malfn.params, - mal_vals(fargs(i))); - tseq(i) := EVAL(malfn.ast, fn_env); - END LOOP; - ELSE - FOR i IN 1..fargs.COUNT() LOOP - tseq(i) := do_builtin(f, - mal_vals(fargs(i))); - END LOOP; - END IF; - RETURN types.seq(M, 8, tseq); - WHEN fname = 'throw' THEN - err_val := args(1); - raise_application_error(-20000, 'MalException', TRUE); - ELSE - RETURN core.do_core_func(M, H, fn, args); - END CASE; - END; - - - -- print - FUNCTION PRINT(exp integer) RETURN varchar IS - BEGIN - RETURN printer.pr_str(M, H, exp); - END; - - -- repl - FUNCTION REP(line varchar) RETURN varchar IS - BEGIN - RETURN PRINT(EVAL(READ(line), repl_env)); - END; - -BEGIN - -- initialize memory pools - M := types.mem_new(); - H := types.map_entry_table(); - E := env_pkg.env_entry_table(); - - repl_env := env_pkg.env_new(M, E, NULL); - - argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; - - -- core.EXT: defined using PL/SQL - core_ns := core.get_core_ns(); - FOR cidx IN 1..core_ns.COUNT LOOP - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, core_ns(cidx)), - types.func(M, core_ns(cidx))); - END LOOP; - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, 'eval'), - types.func(M, 'do_eval')); - x := env_pkg.env_set(M, E, repl_env, - types.symbol(M, '*ARGV*'), - types.slice(M, argv, 1)); - - -- core.mal: defined using the language itself - line := REP('(def! *host-language* "PL/SQL")'); - line := REP('(def! not (fn* (a) (if a false true)))'); - line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); - line := 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)))))))'); - - IF argv.COUNT() > 0 THEN - BEGIN - line := REP('(load-file "' || - TREAT(M(argv(1)) AS mal_str_T).val_str || - '")'); - io.close(1); -- close output stream - RETURN 0; - EXCEPTION WHEN OTHERS THEN - io.writeline('Error: ' || SQLERRM); - io.writeline(dbms_utility.format_error_backtrace); - io.close(1); -- close output stream - RAISE; - END; - END IF; - - line := REP('(println (str "Mal [" *host-language* "]"))'); - WHILE true LOOP - BEGIN - line := io.readline('user> ', 0); - IF line = EMPTY_CLOB() THEN CONTINUE; END IF; - IF line IS NOT NULL THEN - io.writeline(REP(line)); - END IF; - - EXCEPTION WHEN OTHERS THEN - IF SQLCODE = -20001 THEN -- io read stream closed - io.close(1); -- close output stream - RETURN 0; - END IF; - IF SQLCODE <> -20000 THEN - io.writeline('Error: ' || SQLERRM); - ELSE - io.writeline('Error: ' || printer.pr_str(M, H, err_val)); - END IF; - io.writeline(dbms_utility.format_error_backtrace); - END; - END LOOP; -END; - -END mal; -/ -show errors; - -quit; +@io.sql +@types.sql +@reader.sql +@printer.sql +@env.sql +@core.sql + +CREATE OR REPLACE PACKAGE mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer; + +END mal; +/ + +CREATE OR REPLACE PACKAGE BODY mal IS + +FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS + M types.mal_table; -- general mal value memory pool + H types.map_entry_table; -- hashmap memory pool + E env_pkg.env_entry_table; -- mal env memory pool + repl_env integer; + x integer; + line CLOB; + core_ns core_ns_T; + cidx integer; + argv mal_vals; + err_val integer; + + -- read + FUNCTION READ(line varchar) RETURN integer IS + BEGIN + RETURN reader.read_str(M, H, line); + END; + + -- eval + + -- forward declarations + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer; + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer; + + FUNCTION starts_with(lst integer, sym varchar) RETURNS BOOLEAN IS + a0 integer; + BEGIN + IF TREAT(M(lst) AS mal_seq_T).val_seq.COUNT = 2 THEN + a0 := types.nth(M, ast, 0) + RETURN M(a0).type_id = 7 AND TREAT(M(a0) AS mal_str_T).val_str = sym; + END IF; + RETURN FALSE; + END; + + FUNCTION qq_loop(elt integer, acc integer) RETURNS integer IS + BEGIN + IF M(elt).type_id = 8 AND starts_with(elt, 'splice-unquote') THEN + RETURN types._list(M, types.symbol('concat'), types.nth(M, a0, 1), acc); + END IF; + RETURN types.list(M, types.symbol('cons'), quasiquote(elt), acc); + END; + + FUNCTION qq_foldr(xs integer[]) RETURNS integer IS + acc integer := types.list(M); + BEGIN + FOR i IN REVERSE 0 .. types._count(xs) - 1 LOOP + acc := qq_loop(types.nth(M, xs, i), acc); + END LOOP; + RETURN acc; + END; + + FUNCTION quasiquote(ast integer) RETURNS integer IS + BEGIN + CASE + WHEN M(ast).type_id IN (7, 10) THEN + RETURN types.list(M, types.symbol('quote'), ast); + WHEN M(ast).type_id = 9 THEN + RETURN types._list(types.symbol('vec'), qq_folr(ast)); + WHEN M(ast).type_id /= 8 THEN + RETURN ast; + WHEN starts_with(ast, 'unquote') THEN + RETURN types.nth(M, ast, 1); + ELSE + RETURN qq_foldr(ast); + END CASE; + END; $$ LANGUAGE plpgsql; + + FUNCTION is_macro_call(ast integer, env integer) RETURN BOOLEAN IS + a0 integer; + mac integer; + BEGIN + IF M(ast).type_id = 8 THEN + a0 := types.nth(M, ast, 0); + IF M(a0).type_id = 7 AND + env_pkg.env_find(M, E, env, a0) IS NOT NULL THEN + mac := env_pkg.env_get(M, E, env, a0); + IF M(mac).type_id = 12 THEN + RETURN TREAT(M(mac) AS mal_func_T).is_macro > 0; + END IF; + END IF; + END IF; + RETURN FALSE; + END; + + FUNCTION macroexpand(orig_ast integer, env integer) RETURN integer IS + ast integer; + mac integer; + malfn mal_func_T; + fargs mal_vals; + fn_env integer; + BEGIN + ast := orig_ast; + WHILE is_macro_call(ast, env) LOOP + mac := env_pkg.env_get(M, E, env, types.nth(M, ast, 0)); + fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_T).val_seq; + if M(mac).type_id = 12 THEN + malfn := TREAT(M(mac) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, + fargs); + ast := EVAL(malfn.ast, fn_env); + ELSE + ast := do_builtin(mac, fargs); + END IF; + END LOOP; + RETURN ast; + END; + + FUNCTION eval_ast(ast integer, env integer) RETURN integer IS + i integer; + old_seq mal_vals; + new_seq mal_vals; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + BEGIN + IF M(ast).type_id = 7 THEN + RETURN env_pkg.env_get(M, E, env, ast); + ELSIF M(ast).type_id IN (8,9) THEN + old_seq := TREAT(M(ast) AS mal_seq_T).val_seq; + new_seq := mal_vals(); + new_seq.EXTEND(old_seq.COUNT); + FOR i IN 1..old_seq.COUNT LOOP + new_seq(i) := EVAL(old_seq(i), env); + END LOOP; + RETURN types.seq(M, M(ast).type_id, new_seq); + ELSIF M(ast).type_id IN (10) THEN + new_hm := types.hash_map(M, H, mal_vals()); + old_midx := TREAT(M(ast) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := EVAL(H(old_midx)(k), env); + k := H(old_midx).NEXT(k); + END LOOP; + RETURN new_hm; + ELSE + RETURN ast; + END IF; + END; + + FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS + ast integer := orig_ast; + env integer := orig_env; + el integer; + a0 integer; + a0sym varchar2(100); + seq mal_vals; + let_env integer; + try_env integer; + i integer; + f integer; + cond integer; + malfn mal_func_T; + args mal_vals; + BEGIN + WHILE TRUE LOOP + -- io.writeline('EVAL: ' || printer.pr_str(M, H, ast)); + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + + -- apply + ast := macroexpand(ast, env); + IF M(ast).type_id <> 8 THEN + RETURN eval_ast(ast, env); + END IF; + IF types.count(M, ast) = 0 THEN + RETURN ast; -- empty list just returned + END IF; + + -- apply + a0 := types.first(M, ast); + if M(a0).type_id = 7 THEN -- symbol + a0sym := TREAT(M(a0) AS mal_str_T).val_str; + ELSE + a0sym := '__<*fn*>__'; + END IF; + + CASE + WHEN a0sym = 'def!' THEN + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env)); + WHEN a0sym = 'let*' THEN + let_env := env_pkg.env_new(M, E, env); + seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq; + i := 1; + WHILE i <= seq.COUNT LOOP + x := env_pkg.env_set(M, E, let_env, + seq(i), EVAL(seq(i+1), let_env)); + i := i + 2; + END LOOP; + env := let_env; + ast := types.nth(M, ast, 2); -- TCO + WHEN a0sym = 'quote' THEN + RETURN types.nth(M, ast, 1); + WHEN a0sym = 'quasiquoteexpand' THEN + RETURN quasiquote(types.nth(M, ast, 1)); + WHEN a0sym = 'quasiquote' THEN + RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env); + WHEN a0sym = 'defmacro!' THEN + x := EVAL(types.nth(M, ast, 2), env); + malfn := TREAT(M(x) as mal_func_T); + malfn.is_macro := 1; + M(x) := malfn; + RETURN env_pkg.env_set(M, E, env, + types.nth(M, ast, 1), x); + WHEN a0sym = 'macroexpand' THEN + RETURN macroexpand(types.nth(M, ast, 1), env); + WHEN a0sym = 'try*' THEN + DECLARE + exc integer; + a2 integer := -1; + a20 integer := -1; + a20sym varchar2(100); + BEGIN + RETURN EVAL(types.nth(M, ast, 1), env); + + EXCEPTION WHEN OTHERS THEN + IF types.count(M, ast) > 2 THEN + a2 := types.nth(M, ast, 2); + IF M(a2).type_id = 8 THEN + a20 := types.nth(M, a2, 0); + IF M(a20).type_id = 7 THEN + a20sym := TREAT(M(a20) AS mal_str_T).val_str; + END IF; + END IF; + END IF; + IF a20sym = 'catch*' THEN + IF SQLCODE <> -20000 THEN + IF SQLCODE < -20000 AND SQLCODE > -20100 THEN + exc := types.string(M, + REGEXP_REPLACE(SQLERRM, + '^ORA-200[0-9][0-9]: ')); + ELSE + exc := types.string(M, SQLERRM); + END IF; + ELSE -- mal throw + exc := err_val; + err_val := NULL; + END IF; + try_env := env_pkg.env_new(M, E, env, + types.list(M, types.nth(M, a2, 1)), + mal_vals(exc)); + RETURN EVAL(types.nth(M, a2, 2), try_env); + END IF; + RAISE; -- not handled, re-raise the exception + END; + WHEN a0sym = 'do' THEN + x := types.slice(M, ast, 1, types.count(M, ast)-2); + x := eval_ast(x, env); + ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO + WHEN a0sym = 'if' THEN + cond := EVAL(types.nth(M, ast, 1), env); + IF cond = 1 OR cond = 2 THEN -- nil or false + IF types.count(M, ast) > 3 THEN + ast := types.nth(M, ast, 3); -- TCO + ELSE + RETURN 1; -- nil + END IF; + ELSE + ast := types.nth(M, ast, 2); -- TCO + END IF; + WHEN a0sym = 'fn*' THEN + RETURN types.malfunc(M, types.nth(M, ast, 2), + types.nth(M, ast, 1), + env); + ELSE + el := eval_ast(ast, env); + f := types.first(M, el); + args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + env := env_pkg.env_new(M, E, malfn.env, + malfn.params, args); + ast := malfn.ast; -- TCO + ELSE + RETURN do_builtin(f, args); + END IF; + END CASE; + + END LOOP; + + END; + + -- hack to get around lack of function references + -- functions that require special access to repl_env or EVAL + -- are implemented directly here, otherwise, core.do_core_fn + -- is called. + FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS + fname varchar2(100); + val integer; + f integer; + malfn mal_func_T; + fargs mal_vals; + fn_env integer; + i integer; + tseq mal_vals; + BEGIN + fname := TREAT(M(fn) AS mal_str_T).val_str; + CASE + WHEN fname = 'do_eval' THEN + RETURN EVAL(args(1), repl_env); + WHEN fname = 'swap!' THEN + val := TREAT(M(args(1)) AS mal_atom_T).val; + f := args(2); + -- slice one extra at the beginning that will be changed + -- to the value of the atom + fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq; + fargs(1) := val; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, fargs); + val := EVAL(malfn.ast, fn_env); + ELSE + val := do_builtin(f, fargs); + END IF; + RETURN types.atom_reset(M, args(1), val); + WHEN fname = 'apply' THEN + f := args(1); + fargs := mal_vals(); + tseq := TREAT(M(args(args.COUNT())) AS mal_seq_T).val_seq; + fargs.EXTEND(args.COUNT()-2 + tseq.COUNT()); + FOR i IN 1..args.COUNT()-2 LOOP + fargs(i) := args(i+1); + END LOOP; + FOR i IN 1..tseq.COUNT() LOOP + fargs(args.COUNT()-2 + i) := tseq(i); + END LOOP; + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, fargs); + val := EVAL(malfn.ast, fn_env); + ELSE + val := do_builtin(f, fargs); + END IF; + RETURN val; + WHEN fname = 'map' THEN + f := args(1); + fargs := TREAT(M(args(2)) AS mal_seq_T).val_seq; + tseq := mal_vals(); + tseq.EXTEND(fargs.COUNT()); + IF M(f).type_id = 12 THEN + malfn := TREAT(M(f) AS mal_func_T); + FOR i IN 1..fargs.COUNT() LOOP + fn_env := env_pkg.env_new(M, E, malfn.env, + malfn.params, + mal_vals(fargs(i))); + tseq(i) := EVAL(malfn.ast, fn_env); + END LOOP; + ELSE + FOR i IN 1..fargs.COUNT() LOOP + tseq(i) := do_builtin(f, + mal_vals(fargs(i))); + END LOOP; + END IF; + RETURN types.seq(M, 8, tseq); + WHEN fname = 'throw' THEN + err_val := args(1); + raise_application_error(-20000, 'MalException', TRUE); + ELSE + RETURN core.do_core_func(M, H, fn, args); + END CASE; + END; + + + -- print + FUNCTION PRINT(exp integer) RETURN varchar IS + BEGIN + RETURN printer.pr_str(M, H, exp); + END; + + -- repl + FUNCTION REP(line varchar) RETURN varchar IS + BEGIN + RETURN PRINT(EVAL(READ(line), repl_env)); + END; + +BEGIN + -- initialize memory pools + M := types.mem_new(); + H := types.map_entry_table(); + E := env_pkg.env_entry_table(); + + repl_env := env_pkg.env_new(M, E, NULL); + + argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq; + + -- core.EXT: defined using PL/SQL + core_ns := core.get_core_ns(); + FOR cidx IN 1..core_ns.COUNT LOOP + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, core_ns(cidx)), + types.func(M, core_ns(cidx))); + END LOOP; + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, 'eval'), + types.func(M, 'do_eval')); + x := env_pkg.env_set(M, E, repl_env, + types.symbol(M, '*ARGV*'), + types.slice(M, argv, 1)); + + -- core.mal: defined using the language itself + line := REP('(def! *host-language* "PL/SQL")'); + line := REP('(def! not (fn* (a) (if a false true)))'); + line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))'); + line := 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)))))))'); + + IF argv.COUNT() > 0 THEN + BEGIN + line := REP('(load-file "' || + TREAT(M(argv(1)) AS mal_str_T).val_str || + '")'); + io.close(1); -- close output stream + RETURN 0; + EXCEPTION WHEN OTHERS THEN + io.writeline('Error: ' || SQLERRM); + io.writeline(dbms_utility.format_error_backtrace); + io.close(1); -- close output stream + RAISE; + END; + END IF; + + line := REP('(println (str "Mal [" *host-language* "]"))'); + WHILE true LOOP + BEGIN + line := io.readline('user> ', 0); + IF line = EMPTY_CLOB() THEN CONTINUE; END IF; + IF line IS NOT NULL THEN + io.writeline(REP(line)); + END IF; + + EXCEPTION WHEN OTHERS THEN + IF SQLCODE = -20001 THEN -- io read stream closed + io.close(1); -- close output stream + RETURN 0; + END IF; + IF SQLCODE <> -20000 THEN + io.writeline('Error: ' || SQLERRM); + ELSE + io.writeline('Error: ' || printer.pr_str(M, H, err_val)); + END IF; + io.writeline(dbms_utility.format_error_backtrace); + END; + END LOOP; +END; + +END mal; +/ +show errors; + +quit; diff --git a/impls/plsql/types.sql b/impls/plsql/types.sql index fb142c79c4..c86c5bb621 100644 --- a/impls/plsql/types.sql +++ b/impls/plsql/types.sql @@ -1,638 +1,638 @@ --- --------------------------------------------------------- --- persistent values - -BEGIN - EXECUTE IMMEDIATE 'DROP TYPE mal_T FORCE'; -EXCEPTION - WHEN OTHERS THEN IF SQLCODE != -4043 THEN RAISE; END IF; -END; -/ - --- list of types for type_id --- 0: nil --- 1: false --- 2: true --- 3: integer --- 4: float --- 5: string --- 6: long string (CLOB) --- 7: symbol --- 8: list --- 9: vector --- 10: hashmap --- 11: function --- 12: malfunc --- 13: atom - --- nil (0), false (1), true (2) -CREATE OR REPLACE TYPE mal_T FORCE AS OBJECT ( - type_id integer -) NOT FINAL; -/ - --- general nested table of mal values (integers) --- used frequently for argument passing -CREATE OR REPLACE TYPE mal_vals FORCE AS TABLE OF integer; -/ - - --- integer (3) -CREATE OR REPLACE TYPE mal_int_T FORCE UNDER mal_T ( - val_int integer -) FINAL; -/ - --- string/keyword (5,6), symbol (7) -CREATE OR REPLACE TYPE mal_str_T FORCE UNDER mal_T ( - val_str varchar2(4000) -) NOT FINAL; -/ - -CREATE OR REPLACE TYPE mal_long_str_T FORCE UNDER mal_str_T ( - val_long_str CLOB -- long character object (for larger than 4000 chars) -) FINAL; -/ -show errors; - --- list (8), vector (9) -CREATE OR REPLACE TYPE mal_seq_T FORCE UNDER mal_T ( - val_seq mal_vals, - meta integer -) FINAL; -/ - -CREATE OR REPLACE TYPE mal_map_T FORCE UNDER mal_T ( - map_idx integer, -- index into map entry table - meta integer -) FINAL; -/ - --- malfunc (12) -CREATE OR REPLACE TYPE mal_func_T FORCE UNDER mal_T ( - ast integer, - params integer, - env integer, - is_macro integer, - meta integer -) FINAL; -/ - --- atom (13) -CREATE OR REPLACE TYPE mal_atom_T FORCE UNDER mal_T ( - val integer -- index into mal_table -); -/ - - --- --------------------------------------------------------- - -CREATE OR REPLACE PACKAGE types IS - -- memory pool for mal_objects (non-hash-map) - TYPE mal_table IS TABLE OF mal_T; - - -- memory pool for hash-map objects - TYPE map_entry IS TABLE OF integer INDEX BY varchar2(256); - TYPE map_entry_table IS TABLE OF map_entry; - - -- general functions - FUNCTION mem_new RETURN mal_table; - - FUNCTION tf(val boolean) RETURN integer; - FUNCTION equal_Q(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - a integer, b integer) RETURN boolean; - - FUNCTION clone(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - obj integer, - meta integer DEFAULT 1) RETURN integer; - - -- scalar functions - FUNCTION int(M IN OUT NOCOPY mal_table, num integer) RETURN integer; - FUNCTION string(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; - FUNCTION string_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; - FUNCTION symbol(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; - FUNCTION keyword(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; - FUNCTION keyword_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; - FUNCTION number_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; - FUNCTION function_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; - FUNCTION macro_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; - - -- sequence functions - FUNCTION seq(M IN OUT NOCOPY mal_table, - type_id integer, - items mal_vals, - meta integer DEFAULT 1) RETURN integer; - FUNCTION list(M IN OUT NOCOPY mal_table) RETURN integer; - FUNCTION list(M IN OUT NOCOPY mal_table, - a integer) RETURN integer; - FUNCTION list(M IN OUT NOCOPY mal_table, - a integer, b integer) RETURN integer; - FUNCTION list(M IN OUT NOCOPY mal_table, - a integer, b integer, c integer) RETURN integer; - - FUNCTION first(M IN OUT NOCOPY mal_table, - seq integer) RETURN integer; - FUNCTION slice(M IN OUT NOCOPY mal_table, - seq integer, - idx integer, - last integer DEFAULT NULL) RETURN integer; - FUNCTION slice(M IN OUT NOCOPY mal_table, - items mal_vals, - idx integer) RETURN integer; - FUNCTION islice(items mal_vals, - idx integer) RETURN mal_vals; - FUNCTION nth(M IN OUT NOCOPY mal_table, - seq integer, idx integer) RETURN integer; - - FUNCTION count(M IN OUT NOCOPY mal_table, - seq integer) RETURN integer; - - FUNCTION atom_new(M IN OUT NOCOPY mal_table, - val integer) RETURN integer; - FUNCTION atom_reset(M IN OUT NOCOPY mal_table, - atm integer, - val integer) RETURN integer; - - -- hash-map functions - FUNCTION assoc_BANG(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - midx integer, - kvs mal_vals) RETURN integer; - FUNCTION dissoc_BANG(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - midx integer, - ks mal_vals) RETURN integer; - FUNCTION hash_map(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - kvs mal_vals, - meta integer DEFAULT 1) RETURN integer; - - -- function functions - FUNCTION func(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; - FUNCTION malfunc(M IN OUT NOCOPY mal_table, - ast integer, - params integer, - env integer, - is_macro integer DEFAULT 0, - meta integer DEFAULT 1) RETURN integer; -END types; -/ -show errors; - - -CREATE OR REPLACE PACKAGE BODY types IS - --- --------------------------------------------------------- --- general functions - -FUNCTION mem_new RETURN mal_table IS -BEGIN - -- initialize mal type memory pool - -- 1 -> nil - -- 2 -> false - -- 3 -> true - RETURN mal_table(mal_T(0), mal_T(1), mal_T(2)); -END; - -FUNCTION tf(val boolean) RETURN integer IS -BEGIN - IF val THEN - RETURN 3; -- true - ELSE - RETURN 2; -- false - END IF; -END; - -FUNCTION equal_Q(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - a integer, b integer) RETURN boolean IS - atyp integer; - btyp integer; - aseq mal_vals; - bseq mal_vals; - amidx integer; - bmidx integer; - i integer; - k varchar2(256); -BEGIN - atyp := M(a).type_id; - btyp := M(b).type_id; - IF NOT (atyp = btyp OR (atyp IN (8,9) AND btyp IN (8,9))) THEN - RETURN FALSE; - END IF; - - CASE - WHEN atyp IN (0,1,2) THEN - RETURN TRUE; - WHEN atyp = 3 THEN - RETURN TREAT(M(a) AS mal_int_T).val_int = - TREAT(M(b) AS mal_int_T).val_int; - WHEN atyp IN (5,6,7) THEN - IF TREAT(M(a) AS mal_str_T).val_str IS NULL AND - TREAT(M(b) AS mal_str_T).val_str IS NULL THEN - RETURN TRUE; - ELSE - RETURN TREAT(M(a) AS mal_str_T).val_str = - TREAT(M(b) AS mal_str_T).val_str; - END IF; - WHEN atyp IN (8,9) THEN - aseq := TREAT(M(a) AS mal_seq_T).val_seq; - bseq := TREAT(M(b) AS mal_seq_T).val_seq; - IF aseq.COUNT <> bseq.COUNT THEN - RETURN FALSE; - END IF; - FOR i IN 1..aseq.COUNT LOOP - IF NOT equal_Q(M, H, aseq(i), bseq(i)) THEN - RETURN FALSE; - END IF; - END LOOP; - RETURN TRUE; - WHEN atyp = 10 THEN - amidx := TREAT(M(a) AS mal_map_T).map_idx; - bmidx := TREAT(M(b) AS mal_map_T).map_idx; - IF H(amidx).COUNT() <> H(bmidx).COUNT() THEN - RETURN FALSE; - END IF; - - k := H(amidx).FIRST(); - WHILE k IS NOT NULL LOOP - IF H(amidx)(k) IS NULL OR H(bmidx)(k) IS NULL THEN - RETURN FALSE; - END IF; - IF NOT equal_Q(M, H, H(amidx)(k), H(bmidx)(k)) THEN - RETURN FALSE; - END IF; - k := H(amidx).NEXT(k); - END LOOP; - RETURN TRUE; - ELSE - RETURN FALSE; - END CASE; -END; - -FUNCTION clone(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - obj integer, - meta integer DEFAULT 1) RETURN integer IS - type_id integer; - new_hm integer; - old_midx integer; - new_midx integer; - k varchar2(256); - malfn mal_func_T; -BEGIN - type_id := M(obj).type_id; - CASE - WHEN type_id IN (8,9) THEN -- list/vector - RETURN seq(M, type_id, - TREAT(M(obj) AS mal_seq_T).val_seq, - meta); - WHEN type_id = 10 THEN -- hash-map - new_hm := types.hash_map(M, H, mal_vals(), meta); - old_midx := TREAT(M(obj) AS mal_map_T).map_idx; - new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; - - k := H(old_midx).FIRST(); - WHILE k IS NOT NULL LOOP - H(new_midx)(k) := H(old_midx)(k); - k := H(old_midx).NEXT(k); - END LOOP; - - RETURN new_hm; - WHEN type_id = 12 THEN -- mal function - malfn := TREAT(M(obj) AS mal_func_T); - RETURN types.malfunc(M, - malfn.ast, - malfn.params, - malfn.env, - malfn.is_macro, - meta); - ELSE - raise_application_error(-20008, - 'clone not supported for type ' || type_id, TRUE); - END CASE; -END; - - --- --------------------------------------------------------- --- scalar functions - - -FUNCTION int(M IN OUT NOCOPY mal_table, num integer) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_int_T(3, num); - RETURN M.COUNT(); -END; - -FUNCTION string(M IN OUT NOCOPY mal_table, name varchar) RETURN integer IS -BEGIN - M.EXTEND(); - IF LENGTH(name) <= 4000 THEN - M(M.COUNT()) := mal_str_T(5, name); - ELSE - M(M.COUNT()) := mal_long_str_T(6, NULL, name); - END IF; - RETURN M.COUNT(); -END; - -FUNCTION string_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS - str CLOB; -BEGIN - IF M(val).type_id IN (5,6) THEN - IF M(val).type_id = 5 THEN - str := TREAT(M(val) AS mal_str_T).val_str; - ELSE - str := TREAT(M(val) AS mal_long_str_T).val_long_str; - END IF; - IF str IS NULL OR - str = EMPTY_CLOB() OR - SUBSTR(str, 1, 1) <> chr(127) THEN - RETURN TRUE; - ELSE - RETURN FALSE; - END IF; - ELSE - RETURN FALSE; - END IF; -END; - -FUNCTION symbol(M IN OUT NOCOPY mal_table, name varchar) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_str_T(7, name); - RETURN M.COUNT(); -END; - -FUNCTION keyword(M IN OUT NOCOPY mal_table, name varchar) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_str_T(5, chr(127) || name); - RETURN M.COUNT(); -END; - -FUNCTION keyword_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS - str CLOB; -BEGIN - IF M(val).type_id = 5 THEN - str := TREAT(M(val) AS mal_str_T).val_str; - IF LENGTH(str) > 0 AND SUBSTR(str, 1, 1) = chr(127) THEN - RETURN TRUE; - ELSE - RETURN FALSE; - END IF; - ELSE - RETURN FALSE; - END IF; -END; - -FUNCTION number_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS - str CLOB; -BEGIN - IF M(val).type_id IN (3,4) THEN - RETURN TRUE; - ELSE - RETURN FALSE; - END IF; -END; - -FUNCTION function_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS - str CLOB; -BEGIN - IF M(val).type_id = 11 THEN - RETURN TRUE; - ELSIF M(val).type_id = 12 THEN - RETURN TREAT(M(val) AS mal_func_T).is_macro = 0; - ELSE - RETURN FALSE; - END IF; -END; - -FUNCTION macro_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS - str CLOB; -BEGIN - IF M(val).type_id = 12 THEN - RETURN TREAT(M(val) AS mal_func_T).is_macro > 0; - ELSE - RETURN FALSE; - END IF; -END; - - --- --------------------------------------------------------- --- sequence functions - -FUNCTION seq(M IN OUT NOCOPY mal_table, - type_id integer, - items mal_vals, - meta integer DEFAULT 1) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_seq_T(type_id, items, meta); - RETURN M.COUNT(); -END; - --- list: --- return a mal list -FUNCTION list(M IN OUT NOCOPY mal_table) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_seq_T(8, mal_vals(), 1); - RETURN M.COUNT(); -END; - -FUNCTION list(M IN OUT NOCOPY mal_table, - a integer) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_seq_T(8, mal_vals(a), 1); - RETURN M.COUNT(); -END; - -FUNCTION list(M IN OUT NOCOPY mal_table, - a integer, b integer) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_seq_T(8, mal_vals(a, b), 1); - RETURN M.COUNT(); -END; - -FUNCTION list(M IN OUT NOCOPY mal_table, - a integer, b integer, c integer) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_seq_T(8, mal_vals(a, b, c), 1); - RETURN M.COUNT(); -END; - -FUNCTION first(M IN OUT NOCOPY mal_table, - seq integer) RETURN integer IS -BEGIN - RETURN TREAT(M(seq) AS mal_seq_T).val_seq(1); -END; - -FUNCTION slice(M IN OUT NOCOPY mal_table, - seq integer, - idx integer, - last integer DEFAULT NULL) RETURN integer IS - old_items mal_vals; - new_items mal_vals; - i integer; - final_idx integer; -BEGIN - old_items := TREAT(M(seq) AS mal_seq_T).val_seq; - new_items := mal_vals(); - IF last IS NULL THEN - final_idx := old_items.COUNT(); - ELSE - final_idx := last + 1; - END IF; - IF final_idx > idx THEN - new_items.EXTEND(final_idx - idx); - FOR i IN idx+1..final_idx LOOP - new_items(i-idx) := old_items(i); - END LOOP; - END IF; - M.EXTEND(); - M(M.COUNT()) := mal_seq_T(8, new_items, 1); - RETURN M.COUNT(); -END; - -FUNCTION slice(M IN OUT NOCOPY mal_table, - items mal_vals, - idx integer) RETURN integer IS - new_items mal_vals; -BEGIN - new_items := islice(items, idx); - M.EXTEND(); - M(M.COUNT()) := mal_seq_T(8, new_items, 1); - RETURN M.COUNT(); -END; - -FUNCTION islice(items mal_vals, - idx integer) RETURN mal_vals IS - new_items mal_vals; - i integer; -BEGIN - new_items := mal_vals(); - IF items.COUNT > idx THEN - new_items.EXTEND(items.COUNT - idx); - FOR i IN idx+1..items.COUNT LOOP - new_items(i-idx) := items(i); - END LOOP; - END IF; - RETURN new_items; -END; - - -FUNCTION nth(M IN OUT NOCOPY mal_table, - seq integer, idx integer) RETURN integer IS -BEGIN - RETURN TREAT(M(seq) AS mal_seq_T).val_seq(idx+1); -END; - -FUNCTION count(M IN OUT NOCOPY mal_table, - seq integer) RETURN integer IS -BEGIN - RETURN TREAT(M(seq) AS mal_seq_T).val_seq.COUNT; -END; - --- --------------------------------------------------------- --- hash-map functions - -FUNCTION assoc_BANG(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - midx integer, - kvs mal_vals) RETURN integer IS - i integer; -BEGIN - IF MOD(kvs.COUNT(), 2) = 1 THEN - raise_application_error(-20007, - 'odd number of arguments to assoc', TRUE); - END IF; - - i := 1; - WHILE i <= kvs.COUNT() LOOP - H(midx)(TREAT(M(kvs(i)) AS mal_str_T).val_str) := kvs(i+1); - i := i + 2; - END LOOP; - RETURN midx; -END; - -FUNCTION dissoc_BANG(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - midx integer, - ks mal_vals) RETURN integer IS - i integer; -BEGIN - FOR i IN 1..ks.COUNT() LOOP - H(midx).DELETE(TREAT(M(ks(i)) AS mal_str_T).val_str); - END LOOP; - RETURN midx; -END; - -FUNCTION hash_map(M IN OUT NOCOPY mal_table, - H IN OUT NOCOPY map_entry_table, - kvs mal_vals, - meta integer DEFAULT 1) RETURN integer IS - midx integer; -BEGIN - H.EXTEND(); - midx := H.COUNT(); - midx := assoc_BANG(M, H, midx, kvs); - - M.EXTEND(); - M(M.COUNT()) := mal_map_T(10, midx, meta); - RETURN M.COUNT(); -END; - - --- --------------------------------------------------------- --- function functions - -FUNCTION func(M IN OUT NOCOPY mal_table, name varchar) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_str_T(11, name); - RETURN M.COUNT(); -END; - -FUNCTION malfunc(M IN OUT NOCOPY mal_table, - ast integer, - params integer, - env integer, - is_macro integer DEFAULT 0, - meta integer DEFAULT 1) RETURN integer IS -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_func_T(12, ast, params, env, is_macro, meta); - RETURN M.COUNT(); -END; - - --- --------------------------------------------------------- --- atom functions - -FUNCTION atom_new(M IN OUT NOCOPY mal_table, - val integer) RETURN integer IS - aidx integer; -BEGIN - M.EXTEND(); - M(M.COUNT()) := mal_atom_T(13, val); - RETURN M.COUNT(); -END; - -FUNCTION atom_reset(M IN OUT NOCOPY mal_table, - atm integer, - val integer) RETURN integer IS -BEGIN - M(atm) := mal_atom_T(13, val); - RETURN val; -END; - - - -END types; -/ -show errors; +-- --------------------------------------------------------- +-- persistent values + +BEGIN + EXECUTE IMMEDIATE 'DROP TYPE mal_T FORCE'; +EXCEPTION + WHEN OTHERS THEN IF SQLCODE != -4043 THEN RAISE; END IF; +END; +/ + +-- list of types for type_id +-- 0: nil +-- 1: false +-- 2: true +-- 3: integer +-- 4: float +-- 5: string +-- 6: long string (CLOB) +-- 7: symbol +-- 8: list +-- 9: vector +-- 10: hashmap +-- 11: function +-- 12: malfunc +-- 13: atom + +-- nil (0), false (1), true (2) +CREATE OR REPLACE TYPE mal_T FORCE AS OBJECT ( + type_id integer +) NOT FINAL; +/ + +-- general nested table of mal values (integers) +-- used frequently for argument passing +CREATE OR REPLACE TYPE mal_vals FORCE AS TABLE OF integer; +/ + + +-- integer (3) +CREATE OR REPLACE TYPE mal_int_T FORCE UNDER mal_T ( + val_int integer +) FINAL; +/ + +-- string/keyword (5,6), symbol (7) +CREATE OR REPLACE TYPE mal_str_T FORCE UNDER mal_T ( + val_str varchar2(4000) +) NOT FINAL; +/ + +CREATE OR REPLACE TYPE mal_long_str_T FORCE UNDER mal_str_T ( + val_long_str CLOB -- long character object (for larger than 4000 chars) +) FINAL; +/ +show errors; + +-- list (8), vector (9) +CREATE OR REPLACE TYPE mal_seq_T FORCE UNDER mal_T ( + val_seq mal_vals, + meta integer +) FINAL; +/ + +CREATE OR REPLACE TYPE mal_map_T FORCE UNDER mal_T ( + map_idx integer, -- index into map entry table + meta integer +) FINAL; +/ + +-- malfunc (12) +CREATE OR REPLACE TYPE mal_func_T FORCE UNDER mal_T ( + ast integer, + params integer, + env integer, + is_macro integer, + meta integer +) FINAL; +/ + +-- atom (13) +CREATE OR REPLACE TYPE mal_atom_T FORCE UNDER mal_T ( + val integer -- index into mal_table +); +/ + + +-- --------------------------------------------------------- + +CREATE OR REPLACE PACKAGE types IS + -- memory pool for mal_objects (non-hash-map) + TYPE mal_table IS TABLE OF mal_T; + + -- memory pool for hash-map objects + TYPE map_entry IS TABLE OF integer INDEX BY varchar2(256); + TYPE map_entry_table IS TABLE OF map_entry; + + -- general functions + FUNCTION mem_new RETURN mal_table; + + FUNCTION tf(val boolean) RETURN integer; + FUNCTION equal_Q(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + a integer, b integer) RETURN boolean; + + FUNCTION clone(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + obj integer, + meta integer DEFAULT 1) RETURN integer; + + -- scalar functions + FUNCTION int(M IN OUT NOCOPY mal_table, num integer) RETURN integer; + FUNCTION string(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; + FUNCTION string_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; + FUNCTION symbol(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; + FUNCTION keyword(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; + FUNCTION keyword_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; + FUNCTION number_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; + FUNCTION function_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; + FUNCTION macro_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean; + + -- sequence functions + FUNCTION seq(M IN OUT NOCOPY mal_table, + type_id integer, + items mal_vals, + meta integer DEFAULT 1) RETURN integer; + FUNCTION list(M IN OUT NOCOPY mal_table) RETURN integer; + FUNCTION list(M IN OUT NOCOPY mal_table, + a integer) RETURN integer; + FUNCTION list(M IN OUT NOCOPY mal_table, + a integer, b integer) RETURN integer; + FUNCTION list(M IN OUT NOCOPY mal_table, + a integer, b integer, c integer) RETURN integer; + + FUNCTION first(M IN OUT NOCOPY mal_table, + seq integer) RETURN integer; + FUNCTION slice(M IN OUT NOCOPY mal_table, + seq integer, + idx integer, + last integer DEFAULT NULL) RETURN integer; + FUNCTION slice(M IN OUT NOCOPY mal_table, + items mal_vals, + idx integer) RETURN integer; + FUNCTION islice(items mal_vals, + idx integer) RETURN mal_vals; + FUNCTION nth(M IN OUT NOCOPY mal_table, + seq integer, idx integer) RETURN integer; + + FUNCTION count(M IN OUT NOCOPY mal_table, + seq integer) RETURN integer; + + FUNCTION atom_new(M IN OUT NOCOPY mal_table, + val integer) RETURN integer; + FUNCTION atom_reset(M IN OUT NOCOPY mal_table, + atm integer, + val integer) RETURN integer; + + -- hash-map functions + FUNCTION assoc_BANG(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + midx integer, + kvs mal_vals) RETURN integer; + FUNCTION dissoc_BANG(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + midx integer, + ks mal_vals) RETURN integer; + FUNCTION hash_map(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + kvs mal_vals, + meta integer DEFAULT 1) RETURN integer; + + -- function functions + FUNCTION func(M IN OUT NOCOPY mal_table, name varchar) RETURN integer; + FUNCTION malfunc(M IN OUT NOCOPY mal_table, + ast integer, + params integer, + env integer, + is_macro integer DEFAULT 0, + meta integer DEFAULT 1) RETURN integer; +END types; +/ +show errors; + + +CREATE OR REPLACE PACKAGE BODY types IS + +-- --------------------------------------------------------- +-- general functions + +FUNCTION mem_new RETURN mal_table IS +BEGIN + -- initialize mal type memory pool + -- 1 -> nil + -- 2 -> false + -- 3 -> true + RETURN mal_table(mal_T(0), mal_T(1), mal_T(2)); +END; + +FUNCTION tf(val boolean) RETURN integer IS +BEGIN + IF val THEN + RETURN 3; -- true + ELSE + RETURN 2; -- false + END IF; +END; + +FUNCTION equal_Q(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + a integer, b integer) RETURN boolean IS + atyp integer; + btyp integer; + aseq mal_vals; + bseq mal_vals; + amidx integer; + bmidx integer; + i integer; + k varchar2(256); +BEGIN + atyp := M(a).type_id; + btyp := M(b).type_id; + IF NOT (atyp = btyp OR (atyp IN (8,9) AND btyp IN (8,9))) THEN + RETURN FALSE; + END IF; + + CASE + WHEN atyp IN (0,1,2) THEN + RETURN TRUE; + WHEN atyp = 3 THEN + RETURN TREAT(M(a) AS mal_int_T).val_int = + TREAT(M(b) AS mal_int_T).val_int; + WHEN atyp IN (5,6,7) THEN + IF TREAT(M(a) AS mal_str_T).val_str IS NULL AND + TREAT(M(b) AS mal_str_T).val_str IS NULL THEN + RETURN TRUE; + ELSE + RETURN TREAT(M(a) AS mal_str_T).val_str = + TREAT(M(b) AS mal_str_T).val_str; + END IF; + WHEN atyp IN (8,9) THEN + aseq := TREAT(M(a) AS mal_seq_T).val_seq; + bseq := TREAT(M(b) AS mal_seq_T).val_seq; + IF aseq.COUNT <> bseq.COUNT THEN + RETURN FALSE; + END IF; + FOR i IN 1..aseq.COUNT LOOP + IF NOT equal_Q(M, H, aseq(i), bseq(i)) THEN + RETURN FALSE; + END IF; + END LOOP; + RETURN TRUE; + WHEN atyp = 10 THEN + amidx := TREAT(M(a) AS mal_map_T).map_idx; + bmidx := TREAT(M(b) AS mal_map_T).map_idx; + IF H(amidx).COUNT() <> H(bmidx).COUNT() THEN + RETURN FALSE; + END IF; + + k := H(amidx).FIRST(); + WHILE k IS NOT NULL LOOP + IF H(amidx)(k) IS NULL OR H(bmidx)(k) IS NULL THEN + RETURN FALSE; + END IF; + IF NOT equal_Q(M, H, H(amidx)(k), H(bmidx)(k)) THEN + RETURN FALSE; + END IF; + k := H(amidx).NEXT(k); + END LOOP; + RETURN TRUE; + ELSE + RETURN FALSE; + END CASE; +END; + +FUNCTION clone(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + obj integer, + meta integer DEFAULT 1) RETURN integer IS + type_id integer; + new_hm integer; + old_midx integer; + new_midx integer; + k varchar2(256); + malfn mal_func_T; +BEGIN + type_id := M(obj).type_id; + CASE + WHEN type_id IN (8,9) THEN -- list/vector + RETURN seq(M, type_id, + TREAT(M(obj) AS mal_seq_T).val_seq, + meta); + WHEN type_id = 10 THEN -- hash-map + new_hm := types.hash_map(M, H, mal_vals(), meta); + old_midx := TREAT(M(obj) AS mal_map_T).map_idx; + new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx; + + k := H(old_midx).FIRST(); + WHILE k IS NOT NULL LOOP + H(new_midx)(k) := H(old_midx)(k); + k := H(old_midx).NEXT(k); + END LOOP; + + RETURN new_hm; + WHEN type_id = 12 THEN -- mal function + malfn := TREAT(M(obj) AS mal_func_T); + RETURN types.malfunc(M, + malfn.ast, + malfn.params, + malfn.env, + malfn.is_macro, + meta); + ELSE + raise_application_error(-20008, + 'clone not supported for type ' || type_id, TRUE); + END CASE; +END; + + +-- --------------------------------------------------------- +-- scalar functions + + +FUNCTION int(M IN OUT NOCOPY mal_table, num integer) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_int_T(3, num); + RETURN M.COUNT(); +END; + +FUNCTION string(M IN OUT NOCOPY mal_table, name varchar) RETURN integer IS +BEGIN + M.EXTEND(); + IF LENGTH(name) <= 4000 THEN + M(M.COUNT()) := mal_str_T(5, name); + ELSE + M(M.COUNT()) := mal_long_str_T(6, NULL, name); + END IF; + RETURN M.COUNT(); +END; + +FUNCTION string_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS + str CLOB; +BEGIN + IF M(val).type_id IN (5,6) THEN + IF M(val).type_id = 5 THEN + str := TREAT(M(val) AS mal_str_T).val_str; + ELSE + str := TREAT(M(val) AS mal_long_str_T).val_long_str; + END IF; + IF str IS NULL OR + str = EMPTY_CLOB() OR + SUBSTR(str, 1, 1) <> chr(127) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + ELSE + RETURN FALSE; + END IF; +END; + +FUNCTION symbol(M IN OUT NOCOPY mal_table, name varchar) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_str_T(7, name); + RETURN M.COUNT(); +END; + +FUNCTION keyword(M IN OUT NOCOPY mal_table, name varchar) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_str_T(5, chr(127) || name); + RETURN M.COUNT(); +END; + +FUNCTION keyword_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS + str CLOB; +BEGIN + IF M(val).type_id = 5 THEN + str := TREAT(M(val) AS mal_str_T).val_str; + IF LENGTH(str) > 0 AND SUBSTR(str, 1, 1) = chr(127) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + ELSE + RETURN FALSE; + END IF; +END; + +FUNCTION number_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS + str CLOB; +BEGIN + IF M(val).type_id IN (3,4) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; +END; + +FUNCTION function_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS + str CLOB; +BEGIN + IF M(val).type_id = 11 THEN + RETURN TRUE; + ELSIF M(val).type_id = 12 THEN + RETURN TREAT(M(val) AS mal_func_T).is_macro = 0; + ELSE + RETURN FALSE; + END IF; +END; + +FUNCTION macro_Q(M IN OUT NOCOPY mal_table, val integer) RETURN boolean IS + str CLOB; +BEGIN + IF M(val).type_id = 12 THEN + RETURN TREAT(M(val) AS mal_func_T).is_macro > 0; + ELSE + RETURN FALSE; + END IF; +END; + + +-- --------------------------------------------------------- +-- sequence functions + +FUNCTION seq(M IN OUT NOCOPY mal_table, + type_id integer, + items mal_vals, + meta integer DEFAULT 1) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_seq_T(type_id, items, meta); + RETURN M.COUNT(); +END; + +-- list: +-- return a mal list +FUNCTION list(M IN OUT NOCOPY mal_table) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_seq_T(8, mal_vals(), 1); + RETURN M.COUNT(); +END; + +FUNCTION list(M IN OUT NOCOPY mal_table, + a integer) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_seq_T(8, mal_vals(a), 1); + RETURN M.COUNT(); +END; + +FUNCTION list(M IN OUT NOCOPY mal_table, + a integer, b integer) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_seq_T(8, mal_vals(a, b), 1); + RETURN M.COUNT(); +END; + +FUNCTION list(M IN OUT NOCOPY mal_table, + a integer, b integer, c integer) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_seq_T(8, mal_vals(a, b, c), 1); + RETURN M.COUNT(); +END; + +FUNCTION first(M IN OUT NOCOPY mal_table, + seq integer) RETURN integer IS +BEGIN + RETURN TREAT(M(seq) AS mal_seq_T).val_seq(1); +END; + +FUNCTION slice(M IN OUT NOCOPY mal_table, + seq integer, + idx integer, + last integer DEFAULT NULL) RETURN integer IS + old_items mal_vals; + new_items mal_vals; + i integer; + final_idx integer; +BEGIN + old_items := TREAT(M(seq) AS mal_seq_T).val_seq; + new_items := mal_vals(); + IF last IS NULL THEN + final_idx := old_items.COUNT(); + ELSE + final_idx := last + 1; + END IF; + IF final_idx > idx THEN + new_items.EXTEND(final_idx - idx); + FOR i IN idx+1..final_idx LOOP + new_items(i-idx) := old_items(i); + END LOOP; + END IF; + M.EXTEND(); + M(M.COUNT()) := mal_seq_T(8, new_items, 1); + RETURN M.COUNT(); +END; + +FUNCTION slice(M IN OUT NOCOPY mal_table, + items mal_vals, + idx integer) RETURN integer IS + new_items mal_vals; +BEGIN + new_items := islice(items, idx); + M.EXTEND(); + M(M.COUNT()) := mal_seq_T(8, new_items, 1); + RETURN M.COUNT(); +END; + +FUNCTION islice(items mal_vals, + idx integer) RETURN mal_vals IS + new_items mal_vals; + i integer; +BEGIN + new_items := mal_vals(); + IF items.COUNT > idx THEN + new_items.EXTEND(items.COUNT - idx); + FOR i IN idx+1..items.COUNT LOOP + new_items(i-idx) := items(i); + END LOOP; + END IF; + RETURN new_items; +END; + + +FUNCTION nth(M IN OUT NOCOPY mal_table, + seq integer, idx integer) RETURN integer IS +BEGIN + RETURN TREAT(M(seq) AS mal_seq_T).val_seq(idx+1); +END; + +FUNCTION count(M IN OUT NOCOPY mal_table, + seq integer) RETURN integer IS +BEGIN + RETURN TREAT(M(seq) AS mal_seq_T).val_seq.COUNT; +END; + +-- --------------------------------------------------------- +-- hash-map functions + +FUNCTION assoc_BANG(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + midx integer, + kvs mal_vals) RETURN integer IS + i integer; +BEGIN + IF MOD(kvs.COUNT(), 2) = 1 THEN + raise_application_error(-20007, + 'odd number of arguments to assoc', TRUE); + END IF; + + i := 1; + WHILE i <= kvs.COUNT() LOOP + H(midx)(TREAT(M(kvs(i)) AS mal_str_T).val_str) := kvs(i+1); + i := i + 2; + END LOOP; + RETURN midx; +END; + +FUNCTION dissoc_BANG(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + midx integer, + ks mal_vals) RETURN integer IS + i integer; +BEGIN + FOR i IN 1..ks.COUNT() LOOP + H(midx).DELETE(TREAT(M(ks(i)) AS mal_str_T).val_str); + END LOOP; + RETURN midx; +END; + +FUNCTION hash_map(M IN OUT NOCOPY mal_table, + H IN OUT NOCOPY map_entry_table, + kvs mal_vals, + meta integer DEFAULT 1) RETURN integer IS + midx integer; +BEGIN + H.EXTEND(); + midx := H.COUNT(); + midx := assoc_BANG(M, H, midx, kvs); + + M.EXTEND(); + M(M.COUNT()) := mal_map_T(10, midx, meta); + RETURN M.COUNT(); +END; + + +-- --------------------------------------------------------- +-- function functions + +FUNCTION func(M IN OUT NOCOPY mal_table, name varchar) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_str_T(11, name); + RETURN M.COUNT(); +END; + +FUNCTION malfunc(M IN OUT NOCOPY mal_table, + ast integer, + params integer, + env integer, + is_macro integer DEFAULT 0, + meta integer DEFAULT 1) RETURN integer IS +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_func_T(12, ast, params, env, is_macro, meta); + RETURN M.COUNT(); +END; + + +-- --------------------------------------------------------- +-- atom functions + +FUNCTION atom_new(M IN OUT NOCOPY mal_table, + val integer) RETURN integer IS + aidx integer; +BEGIN + M.EXTEND(); + M(M.COUNT()) := mal_atom_T(13, val); + RETURN M.COUNT(); +END; + +FUNCTION atom_reset(M IN OUT NOCOPY mal_table, + atm integer, + val integer) RETURN integer IS +BEGIN + M(atm) := mal_atom_T(13, val); + RETURN val; +END; + + + +END types; +/ +show errors; diff --git a/impls/plsql/wrap.sh b/impls/plsql/wrap.sh index 8822116bdf..a8dfba58da 100755 --- a/impls/plsql/wrap.sh +++ b/impls/plsql/wrap.sh @@ -1,122 +1,122 @@ -#!/bin/bash - -RL_HISTORY_FILE=${HOME}/.mal-history -SKIP_INIT="${SKIP_INIT:-}" - -ORACLE_LOGON=${ORACLE_LOGON:-system/oracle} -SQLPLUS="sqlplus -S ${ORACLE_LOGON}" - -FILE_PID= -cleanup() { - trap - TERM QUIT INT EXIT - #echo cleanup: ${FILE_PID} - [ "${FILE_PID}" ] && kill ${FILE_PID} -} -trap "cleanup" TERM QUIT INT EXIT - - -# Load the SQL code -if [ -z "${SKIP_INIT}" ]; then - out=$(echo "" | ${SQLPLUS} @$1) - if echo "${out}" | grep -vs "^No errors.$" \ - | grep -si error >/dev/null; then - #if echo "${out}" | grep -si error >/dev/null; then - echo "${out}" - exit 1 - fi -fi - -# open I/O streams -echo -e "BEGIN io.open(0); io.open(1); END;\n/" \ - | ${SQLPLUS} >/dev/null - -# Stream from table to stdout -( -while true; do - out="$(echo "SELECT io.read(1) FROM dual;" \ - | ${SQLPLUS} 2>/dev/null)" || break - #echo "out: [${out}] (${#out})" - echo "${out}" -done -) & -STDOUT_PID=$! - -# Perform readline input into stream table when requested -( -[ -r ${RL_HISTORY_FILE} ] && history -r ${RL_HISTORY_FILE} -while true; do - prompt=$(echo "SELECT io.wait_rl_prompt(0) FROM dual;" \ - | ${SQLPLUS} 2>/dev/null) || break - # Prompt is returned single-quoted because sqlplus trims trailing - # whitespace. Remove the single quotes from the beginning and end: - prompt=${prompt%\'} - prompt=${prompt#\'} - #echo "prompt: [${prompt}]" - - IFS= read -u 0 -r -e -p "${prompt}" line || break - if [ "${line}" ]; then - history -s -- "${line}" # add to history - history -a ${RL_HISTORY_FILE} # save history to file - fi - - # Escape (double) single quotes per SQL norm - line=${line//\'/\'\'} - #echo "line: [${line}]" - ( echo -n "BEGIN io.writeline('${line}', 0); END;"; - echo -en "\n/" ) \ - | ${SQLPLUS} >/dev/null || break -done -echo -e "BEGIN io.close(0); END;\n/" \ - | ${SQLPLUS} > /dev/null -) <&0 >&1 & - - -# File read if requested -( -while true; do - files="$(echo "SELECT path FROM file_io WHERE in_or_out = 'in';" \ - | ${SQLPLUS} 2>/dev/null \ - | grep -v "^no rows selected")" || break - for f in ${files}; do - if [ ! -r ${f} ]; then - echo "UPDATE file_io SET error = 'Cannot read ''${f}''' WHERE path = '${f}' AND in_or_out = 'in';" \ - | ${SQLPLUS} >/dev/null - continue; - fi - IFS= read -rd '' content < "${f}" - # sqlplus limits lines to 2499 characters so split the update - # into chunks of the file ORed together over multiple lines - query="UPDATE file_io SET data = TO_CLOB('')" - while [ -n "${content}" ]; do - chunk="${content:0:2000}" - content="${content:${#chunk}}" - chunk="${chunk//\'/\'\'}" - chunk="${chunk//$'\n'/\\n}" - query="${query}"$'\n'" || TO_CLOB('${chunk}')" - done - query="${query}"$'\n'" WHERE path = '${f}' AND in_or_out = 'in';" - echo "${query}" | ${SQLPLUS} > /dev/null - #echo "file read: ${f}: ${?}" - done - sleep 1 -done -) & -FILE_PID=$! - -res=0 -shift -if [ $# -gt 0 ]; then - # If there are command line arguments then run a command and exit - args=$(for a in "$@"; do echo -n "\"$a\" "; done) - echo -e "SELECT mal.MAIN('(${args})') FROM dual;" \ - | ${SQLPLUS} > /dev/null - res=$? -else - # Start main loop in the background - echo "SELECT mal.MAIN() FROM dual;" \ - | ${SQLPLUS} > /dev/null - res=$? -fi -# Wait for output to flush -wait ${STDOUT_PID} -exit ${res} +#!/bin/bash + +RL_HISTORY_FILE=${HOME}/.mal-history +SKIP_INIT="${SKIP_INIT:-}" + +ORACLE_LOGON=${ORACLE_LOGON:-system/oracle} +SQLPLUS="sqlplus -S ${ORACLE_LOGON}" + +FILE_PID= +cleanup() { + trap - TERM QUIT INT EXIT + #echo cleanup: ${FILE_PID} + [ "${FILE_PID}" ] && kill ${FILE_PID} +} +trap "cleanup" TERM QUIT INT EXIT + + +# Load the SQL code +if [ -z "${SKIP_INIT}" ]; then + out=$(echo "" | ${SQLPLUS} @$1) + if echo "${out}" | grep -vs "^No errors.$" \ + | grep -si error >/dev/null; then + #if echo "${out}" | grep -si error >/dev/null; then + echo "${out}" + exit 1 + fi +fi + +# open I/O streams +echo -e "BEGIN io.open(0); io.open(1); END;\n/" \ + | ${SQLPLUS} >/dev/null + +# Stream from table to stdout +( +while true; do + out="$(echo "SELECT io.read(1) FROM dual;" \ + | ${SQLPLUS} 2>/dev/null)" || break + #echo "out: [${out}] (${#out})" + echo "${out}" +done +) & +STDOUT_PID=$! + +# Perform readline input into stream table when requested +( +[ -r ${RL_HISTORY_FILE} ] && history -r ${RL_HISTORY_FILE} +while true; do + prompt=$(echo "SELECT io.wait_rl_prompt(0) FROM dual;" \ + | ${SQLPLUS} 2>/dev/null) || break + # Prompt is returned single-quoted because sqlplus trims trailing + # whitespace. Remove the single quotes from the beginning and end: + prompt=${prompt%\'} + prompt=${prompt#\'} + #echo "prompt: [${prompt}]" + + IFS= read -u 0 -r -e -p "${prompt}" line || break + if [ "${line}" ]; then + history -s -- "${line}" # add to history + history -a ${RL_HISTORY_FILE} # save history to file + fi + + # Escape (double) single quotes per SQL norm + line=${line//\'/\'\'} + #echo "line: [${line}]" + ( echo -n "BEGIN io.writeline('${line}', 0); END;"; + echo -en "\n/" ) \ + | ${SQLPLUS} >/dev/null || break +done +echo -e "BEGIN io.close(0); END;\n/" \ + | ${SQLPLUS} > /dev/null +) <&0 >&1 & + + +# File read if requested +( +while true; do + files="$(echo "SELECT path FROM file_io WHERE in_or_out = 'in';" \ + | ${SQLPLUS} 2>/dev/null \ + | grep -v "^no rows selected")" || break + for f in ${files}; do + if [ ! -r ${f} ]; then + echo "UPDATE file_io SET error = 'Cannot read ''${f}''' WHERE path = '${f}' AND in_or_out = 'in';" \ + | ${SQLPLUS} >/dev/null + continue; + fi + IFS= read -rd '' content < "${f}" + # sqlplus limits lines to 2499 characters so split the update + # into chunks of the file ORed together over multiple lines + query="UPDATE file_io SET data = TO_CLOB('')" + while [ -n "${content}" ]; do + chunk="${content:0:2000}" + content="${content:${#chunk}}" + chunk="${chunk//\'/\'\'}" + chunk="${chunk//$'\n'/\\n}" + query="${query}"$'\n'" || TO_CLOB('${chunk}')" + done + query="${query}"$'\n'" WHERE path = '${f}' AND in_or_out = 'in';" + echo "${query}" | ${SQLPLUS} > /dev/null + #echo "file read: ${f}: ${?}" + done + sleep 1 +done +) & +FILE_PID=$! + +res=0 +shift +if [ $# -gt 0 ]; then + # If there are command line arguments then run a command and exit + args=$(for a in "$@"; do echo -n "\"$a\" "; done) + echo -e "SELECT mal.MAIN('(${args})') FROM dual;" \ + | ${SQLPLUS} > /dev/null + res=$? +else + # Start main loop in the background + echo "SELECT mal.MAIN() FROM dual;" \ + | ${SQLPLUS} > /dev/null + res=$? +fi +# Wait for output to flush +wait ${STDOUT_PID} +exit ${res} diff --git a/impls/powershell/Dockerfile b/impls/powershell/Dockerfile index f4649a6172..a1a3adb92f 100644 --- a/impls/powershell/Dockerfile +++ b/impls/powershell/Dockerfile @@ -1,36 +1,36 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Nothing additional needed for python -RUN apt-get -y install libunwind8 libicu52 -#RUN apt-get -y install libunwind8 libicu55 - -# For dist packaging -RUN curl -L -O https://github.com/PowerShell/PowerShell/releases/download/v6.0.0-alpha.9/powershell_6.0.0-alpha.9-1ubuntu1.14.04.1_amd64.deb && \ - dpkg -i powershell_6.0.0-alpha.9-1ubuntu1.14.04.1_amd64.deb && \ - rm powershell_6.0.0-alpha.9-1ubuntu1.14.04.1_amd64.deb -#RUN curl -L -O https://github.com/PowerShell/PowerShell/releases/download/v6.0.0-alpha.9/powershell_6.0.0-alpha.9-1ubuntu1.16.04.1_amd64.deb && \ -# dpkg -i powershell_6.0.0-alpha.9-1ubuntu1.16.04.1_amd64.deb && \ -# rm powershell_6.0.0-alpha.9-1ubuntu1.16.04.1_amd64.deb - -ENV HOME=/mal +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Nothing additional needed for python +RUN apt-get -y install libunwind8 libicu52 +#RUN apt-get -y install libunwind8 libicu55 + +# For dist packaging +RUN curl -L -O https://github.com/PowerShell/PowerShell/releases/download/v6.0.0-alpha.9/powershell_6.0.0-alpha.9-1ubuntu1.14.04.1_amd64.deb && \ + dpkg -i powershell_6.0.0-alpha.9-1ubuntu1.14.04.1_amd64.deb && \ + rm powershell_6.0.0-alpha.9-1ubuntu1.14.04.1_amd64.deb +#RUN curl -L -O https://github.com/PowerShell/PowerShell/releases/download/v6.0.0-alpha.9/powershell_6.0.0-alpha.9-1ubuntu1.16.04.1_amd64.deb && \ +# dpkg -i powershell_6.0.0-alpha.9-1ubuntu1.16.04.1_amd64.deb && \ +# rm powershell_6.0.0-alpha.9-1ubuntu1.16.04.1_amd64.deb + +ENV HOME=/mal diff --git a/impls/powershell/Makefile b/impls/powershell/Makefile index b8722e6d92..9928089fff 100644 --- a/impls/powershell/Makefile +++ b/impls/powershell/Makefile @@ -1,4 +1,4 @@ -all: - true - -clean: +all: + true + +clean: diff --git a/impls/powershell/core.psm1 b/impls/powershell/core.psm1 index a8321824c7..c82b53ded5 100644 --- a/impls/powershell/core.psm1 +++ b/impls/powershell/core.psm1 @@ -1,179 +1,179 @@ -function time_ms { - $ms = [double]::Parse((Get-Date (get-date).ToUniversalTime() -UFormat %s)) - [int64] ($ms * 1000) -} - -function get($hm, $key) { - if ($hm -eq $null) { - $null - } else { - $hm.values.Item($key) - } -} - -function concat { - $res = @() - foreach($a in $args) { - $res = $res + $a.values - } - new-list $res -} - -function vec($seq) { - if(vector? $seq) { - return $seq - } else { - return new-vector($seq.values) - } -} - -function nth($lst, $idx) { - if ($idx -ge $lst.values.Count) { - throw "nth: index out of range" - } - $lst.nth($idx) -} - - -function do_map($f, $l) { - if (malfunc?($f)) { - $f = $f.fn - } - new-list ($l.values | foreach { &$f $_ }) -} - -function do_apply($f) { - if (malfunc?($f)) { - $f = $f.fn - } - if ($args.Count -gt 1) { - $fargs = $args[0..($args.Count-2)] + $args[-1].values - } else { - $fargs = $args[$args.Count-1].values - } - &$f @fargs -} - -function conj($lst) { - if (list? $lst) { - [Array]::Reverse($args) - return new-list ($args + $lst.values) - } else { - return new-vector ($lst.values + $args) - } -} - -function seq($obj) { - if ($obj -eq $null) { - return $null - } elseif (list? $obj) { - if ($obj.values.Count -gt 0) { - return $obj - } else { - return $null - } - } elseif (vector? $obj) { - if ($obj.values.Count -gt 0) { - return new-list $obj.values - } else { - return $null - } - } elseif (string? $obj) { - if ($obj.Length -gt 0) { - return new-list ($obj -split '')[1..$obj.Length] - } else { - return $null - } - return new-list $obj - } else { - throw "seq: called on non-sequence" - } -} - -function swap_BANG($a, $f) { - if (malfunc?($f)) { - $f = $f.fn - } - $fargs = @($a.value) + $args - if ($fargs.Count -eq 0) { - $a.value = &$f - } else { - $a.value = &$f @fargs - } - $a.value -} - - -$core_ns = @{ - "=" = { param($a, $b); equal? $a $b }; - "throw" = Get-Command mal_throw; - - "nil?" = { param($a); $a -eq $null }; - "true?" = { param($a); $a -eq $true }; - "false?" = { param($a); $a -eq $false }; - "number?" = { param($a); $a -is [int32] }; - "string?" = { param($a); string? $a }; - "symbol" = Get-Command new-symbol; - "symbol?" = { param($a); symbol? $a }; - "keyword" = Get-Command new-keyword; - "keyword?" = { param($a); keyword? $a }; - "fn?" = { param($a); (fn? $a) -or ((malfunc? $a) -and - (-not $a.macro)) }; - "macro?" = { param($a); (malfunc? $a) -and $a.macro }; - - "pr-str" = { pr_seq $args $true " " }; - "str" = { pr_seq $args $false "" }; - "prn" = { Write-Host (pr_seq $args $true " "); $null }; - "println" = { Write-Host (pr_seq $args $false " "); $null }; - "read-string" = { read_str $args[0] }; - "readline" = { Write-Host $args[0] -NoNewline; [Console]::Readline() }; - "slurp" = { Get-Content -Path $args[0] -Raw }; - - "<" = { param($a, $b); $a -lt $b }; - "<=" = { param($a, $b); $a -le $b }; - ">" = { param($a, $b); $a -gt $b }; - ">=" = { param($a, $b); $a -ge $b }; - "+" = { param($a, $b); $a + $b }; - "-" = { param($a, $b); $a - $b }; - "*" = { param($a, $b); $a * $b }; - "/" = { param($a, $b); $a / $b }; - "time-ms" = Get-Command time_ms; - - "list" = { new-list $args }; - "list?" = Get-Command list?; - "vector" = { new-vector $args }; - "vector?" = Get-Command vector?; - "hash-map" = { new-hashmap $args }; - "map?" = Get-Command hashmap?; - "assoc" = { param($a); assoc_BANG $a.copy() $args }; - "dissoc" = { param($a); dissoc_BANG $a.copy() $args }; - "get" = { param($a,$b); get $a $b }; - "contains?" = { param($a,$b); $a.values.Contains($b) }; - "keys" = Get-Command keys; - "vals" = Get-Command vals; - - "sequential?" = Get-Command sequential?; - "cons" = { param($a, $b); new-list (@($a) + $b.values) }; - "concat" = Get-Command concat; - "vec" = Get-Command vec; - "nth" = Get-Command nth; - "first" = { param($a); if ($a -eq $null) { $null } else { $a.first() } }; - "rest" = { param($a); if ($a -eq $null) { new-list @() } else { $a.rest() } }; - "empty?" = { param($a); $a -eq $null -or $a.values.Count -eq 0 }; - "count" = { param($a); $a.values.Count }; - "apply" = Get-Command do_apply; - "map" = Get-Command do_map; - - "conj" = Get-Command conj; - "seq" = Get-Command seq; - - "meta" = { param($a); $a.meta }; - "with-meta" = { param($a, $b); $c = $a.copy(); $c.meta = $b; $c }; - "atom" = { param($a); new-atom($a) }; - "atom?" = { param($a); atom?($a) }; - "deref" = { param($a); $a.value }; - "reset!" = { param($a, $b); $a.value = $b; $b }; - "swap!" = Get-Command swap_BANG; -} - -Export-ModuleMember -Variable core_ns +function time_ms { + $ms = [double]::Parse((Get-Date (get-date).ToUniversalTime() -UFormat %s)) + [int64] ($ms * 1000) +} + +function get($hm, $key) { + if ($hm -eq $null) { + $null + } else { + $hm.values.Item($key) + } +} + +function concat { + $res = @() + foreach($a in $args) { + $res = $res + $a.values + } + new-list $res +} + +function vec($seq) { + if(vector? $seq) { + return $seq + } else { + return new-vector($seq.values) + } +} + +function nth($lst, $idx) { + if ($idx -ge $lst.values.Count) { + throw "nth: index out of range" + } + $lst.nth($idx) +} + + +function do_map($f, $l) { + if (malfunc?($f)) { + $f = $f.fn + } + new-list ($l.values | foreach { &$f $_ }) +} + +function do_apply($f) { + if (malfunc?($f)) { + $f = $f.fn + } + if ($args.Count -gt 1) { + $fargs = $args[0..($args.Count-2)] + $args[-1].values + } else { + $fargs = $args[$args.Count-1].values + } + &$f @fargs +} + +function conj($lst) { + if (list? $lst) { + [Array]::Reverse($args) + return new-list ($args + $lst.values) + } else { + return new-vector ($lst.values + $args) + } +} + +function seq($obj) { + if ($obj -eq $null) { + return $null + } elseif (list? $obj) { + if ($obj.values.Count -gt 0) { + return $obj + } else { + return $null + } + } elseif (vector? $obj) { + if ($obj.values.Count -gt 0) { + return new-list $obj.values + } else { + return $null + } + } elseif (string? $obj) { + if ($obj.Length -gt 0) { + return new-list ($obj -split '')[1..$obj.Length] + } else { + return $null + } + return new-list $obj + } else { + throw "seq: called on non-sequence" + } +} + +function swap_BANG($a, $f) { + if (malfunc?($f)) { + $f = $f.fn + } + $fargs = @($a.value) + $args + if ($fargs.Count -eq 0) { + $a.value = &$f + } else { + $a.value = &$f @fargs + } + $a.value +} + + +$core_ns = @{ + "=" = { param($a, $b); equal? $a $b }; + "throw" = Get-Command mal_throw; + + "nil?" = { param($a); $a -eq $null }; + "true?" = { param($a); $a -eq $true }; + "false?" = { param($a); $a -eq $false }; + "number?" = { param($a); $a -is [int32] }; + "string?" = { param($a); string? $a }; + "symbol" = Get-Command new-symbol; + "symbol?" = { param($a); symbol? $a }; + "keyword" = Get-Command new-keyword; + "keyword?" = { param($a); keyword? $a }; + "fn?" = { param($a); (fn? $a) -or ((malfunc? $a) -and + (-not $a.macro)) }; + "macro?" = { param($a); (malfunc? $a) -and $a.macro }; + + "pr-str" = { pr_seq $args $true " " }; + "str" = { pr_seq $args $false "" }; + "prn" = { Write-Host (pr_seq $args $true " "); $null }; + "println" = { Write-Host (pr_seq $args $false " "); $null }; + "read-string" = { read_str $args[0] }; + "readline" = { Write-Host $args[0] -NoNewline; [Console]::Readline() }; + "slurp" = { Get-Content -Path $args[0] -Raw }; + + "<" = { param($a, $b); $a -lt $b }; + "<=" = { param($a, $b); $a -le $b }; + ">" = { param($a, $b); $a -gt $b }; + ">=" = { param($a, $b); $a -ge $b }; + "+" = { param($a, $b); $a + $b }; + "-" = { param($a, $b); $a - $b }; + "*" = { param($a, $b); $a * $b }; + "/" = { param($a, $b); $a / $b }; + "time-ms" = Get-Command time_ms; + + "list" = { new-list $args }; + "list?" = Get-Command list?; + "vector" = { new-vector $args }; + "vector?" = Get-Command vector?; + "hash-map" = { new-hashmap $args }; + "map?" = Get-Command hashmap?; + "assoc" = { param($a); assoc_BANG $a.copy() $args }; + "dissoc" = { param($a); dissoc_BANG $a.copy() $args }; + "get" = { param($a,$b); get $a $b }; + "contains?" = { param($a,$b); $a.values.Contains($b) }; + "keys" = Get-Command keys; + "vals" = Get-Command vals; + + "sequential?" = Get-Command sequential?; + "cons" = { param($a, $b); new-list (@($a) + $b.values) }; + "concat" = Get-Command concat; + "vec" = Get-Command vec; + "nth" = Get-Command nth; + "first" = { param($a); if ($a -eq $null) { $null } else { $a.first() } }; + "rest" = { param($a); if ($a -eq $null) { new-list @() } else { $a.rest() } }; + "empty?" = { param($a); $a -eq $null -or $a.values.Count -eq 0 }; + "count" = { param($a); $a.values.Count }; + "apply" = Get-Command do_apply; + "map" = Get-Command do_map; + + "conj" = Get-Command conj; + "seq" = Get-Command seq; + + "meta" = { param($a); $a.meta }; + "with-meta" = { param($a, $b); $c = $a.copy(); $c.meta = $b; $c }; + "atom" = { param($a); new-atom($a) }; + "atom?" = { param($a); atom?($a) }; + "deref" = { param($a); $a.value }; + "reset!" = { param($a, $b); $a.value = $b; $b }; + "swap!" = Get-Command swap_BANG; +} + +Export-ModuleMember -Variable core_ns diff --git a/impls/powershell/env.psm1 b/impls/powershell/env.psm1 index deb10fd563..87bc76979a 100644 --- a/impls/powershell/env.psm1 +++ b/impls/powershell/env.psm1 @@ -1,57 +1,57 @@ -Import-Module $PSScriptRoot/types.psm1 - -Class Env { - [HashTable] $data - [Env] $outer - - Env([Env] $out, $binds, $exprs) { - # Case-sensitive hash table - $this.data = New-Object System.Collections.HashTable - $this.outer = $out - - if ($binds -ne $null) { - for ($i = 0; $i -lt $binds.Length; $i++) { - if ($binds[$i].value -eq "&") { - if ($exprs.Length -gt $i) { - $rest = $exprs[$i..($exprs.Length-1)] - } else { - $rest = @() - } - $this.data[$binds[($i+1)].value] = new-list($rest) - break - } else { - $this.data[$binds[$i].value] = $exprs[$i] - } - } - } - } - - [Object] set($key, $value) { - $this.data[$key.value] = $value - return $value - } - - [Env] find($key) { - if ($this.data.Contains($key.value)) { - return $this - } elseif ($this.outer -ne $null) { - return $this.outer.find($key) - } else { - return $null - } - } - - [Object] get($key) { - $e = $this.find($key) - if ($e -ne $null) { - return $e.data[$key.value] - } else { - throw "'$($key.value)' not found" - } - } -} - -function new-env([Env] $out, $binds, $exprs) { - [Env]::new($out, $binds, $exprs) -} - +Import-Module $PSScriptRoot/types.psm1 + +Class Env { + [HashTable] $data + [Env] $outer + + Env([Env] $out, $binds, $exprs) { + # Case-sensitive hash table + $this.data = New-Object System.Collections.HashTable + $this.outer = $out + + if ($binds -ne $null) { + for ($i = 0; $i -lt $binds.Length; $i++) { + if ($binds[$i].value -eq "&") { + if ($exprs.Length -gt $i) { + $rest = $exprs[$i..($exprs.Length-1)] + } else { + $rest = @() + } + $this.data[$binds[($i+1)].value] = new-list($rest) + break + } else { + $this.data[$binds[$i].value] = $exprs[$i] + } + } + } + } + + [Object] set($key, $value) { + $this.data[$key.value] = $value + return $value + } + + [Env] find($key) { + if ($this.data.Contains($key.value)) { + return $this + } elseif ($this.outer -ne $null) { + return $this.outer.find($key) + } else { + return $null + } + } + + [Object] get($key) { + $e = $this.find($key) + if ($e -ne $null) { + return $e.data[$key.value] + } else { + throw "'$($key.value)' not found" + } + } +} + +function new-env([Env] $out, $binds, $exprs) { + [Env]::new($out, $binds, $exprs) +} + diff --git a/impls/powershell/printer.psm1 b/impls/powershell/printer.psm1 index 1c63a253ba..6752199cf2 100644 --- a/impls/powershell/printer.psm1 +++ b/impls/powershell/printer.psm1 @@ -1,59 +1,59 @@ - -function pr_str { - param($obj, $print_readably = $true) - if ($obj -eq $null) { - return "nil" - } - - switch ($obj.GetType().Name) { - "String" { - if ($obj[0] -eq "$([char]0x29e)") { - return ":$($obj.substring(1))" - } elseif ($print_readably) { - $s = $obj -replace "\\", "\\" - $s = $s -replace "`"", "\`"" - $s = $s -replace "`n", "\n" - return "`"$s`"" - } else { - return "$obj" - } - } - "Vector" { - $res = $obj.values | ForEach { (pr_str $_ $print_readably) } - return "[" + ($res -join " ") + "]" - } - "List" { - $res = $obj.values | ForEach { (pr_str $_ $print_readably) } - return "(" + ($res -join " ") + ")" - } - "HashMap" { - $res = @() - foreach ($k in $obj.values.Keys) { - $res += pr_str $k $print_readably - $res += pr_str $obj.values[$k] $print_readably - } - return "{" + ($res -join " ") + "}" - } - "Symbol" { - return $obj.value - } - "Boolean" { - return $obj.ToString().ToLower() - } - "Atom" { - return "(atom $(pr_str $obj.value $print_readably))" - } - "PSCustomObject" { - return "(fn* $(pr_str (new-list $obj.params) $print_readably) $(pr_str $obj.ast $print_readably))" - } - default { - return $obj.ToString() - } - } -} - -function pr_seq { - param($seq, $print_readably, $sep) - $lst = foreach($a in $seq) { pr_str $a $print_readably } - $lst -join $sep -} + +function pr_str { + param($obj, $print_readably = $true) + if ($obj -eq $null) { + return "nil" + } + + switch ($obj.GetType().Name) { + "String" { + if ($obj[0] -eq "$([char]0x29e)") { + return ":$($obj.substring(1))" + } elseif ($print_readably) { + $s = $obj -replace "\\", "\\" + $s = $s -replace "`"", "\`"" + $s = $s -replace "`n", "\n" + return "`"$s`"" + } else { + return "$obj" + } + } + "Vector" { + $res = $obj.values | ForEach { (pr_str $_ $print_readably) } + return "[" + ($res -join " ") + "]" + } + "List" { + $res = $obj.values | ForEach { (pr_str $_ $print_readably) } + return "(" + ($res -join " ") + ")" + } + "HashMap" { + $res = @() + foreach ($k in $obj.values.Keys) { + $res += pr_str $k $print_readably + $res += pr_str $obj.values[$k] $print_readably + } + return "{" + ($res -join " ") + "}" + } + "Symbol" { + return $obj.value + } + "Boolean" { + return $obj.ToString().ToLower() + } + "Atom" { + return "(atom $(pr_str $obj.value $print_readably))" + } + "PSCustomObject" { + return "(fn* $(pr_str (new-list $obj.params) $print_readably) $(pr_str $obj.ast $print_readably))" + } + default { + return $obj.ToString() + } + } +} + +function pr_seq { + param($seq, $print_readably, $sep) + $lst = foreach($a in $seq) { pr_str $a $print_readably } + $lst -join $sep +} diff --git a/impls/powershell/reader.psm1 b/impls/powershell/reader.psm1 index bd7f95c34b..8764bbf78e 100644 --- a/impls/powershell/reader.psm1 +++ b/impls/powershell/reader.psm1 @@ -1,130 +1,130 @@ -Import-Module $PSScriptRoot/types.psm1 - -Class Reader { - [String[]] $tokens - [int] $pos - - Reader([String[]] $toks) { - $this.tokens = $toks - $this.pos = 0 - } - - [String] peek() { - return $this.tokens[$this.pos] - } - - [String] next() { - return $this.tokens[$this.pos++] - } -} - - -function tokenize { - $r = [regex]"[\s,]*(~@|[\[\]{}()'``~^@]|`"(?:\\.|[^\\`"])*`"?|;.*|[^\s\[\]{}('`"``,;)]*)" - $r.Matches($args) | - Where-Object { $_.Groups.Item(1).Value.Length -gt 0 -and - $_.Groups.Item(1).Value[0] -ne ";" } | - Foreach-Object { $_.Groups.Item(1).Value } -} - -function read_atom([Reader] $rdr) { - $token = $rdr.next() - if ($token -match "^-?[0-9]+$") { - return [convert]::ToInt32($token, 10) - } elseif ($token -match "^`"(?:\\.|[^\\`"])*`"$") { - $s = $token.Substring(1,$token.Length-2) - $s = $s -replace "\\\\", "$([char]0x29e)" - $s = $s -replace "\\`"", "`"" - $s = $s -replace "\\n", "`n" - $s = $s -replace "$([char]0x29e)", "\" - return $s - } elseif ($token -match "^`".*") { - throw "expected '`"', got EOF" - } elseif ($token -match ":.*") { - return "$([char]0x29e)$($token.substring(1))" - } elseif ($token -eq "true") { - return $true - } elseif ($token -eq "false") { - return $false - } elseif ($token -eq "nil") { - return $null - } else { - return new-symbol($token) - } -} - -function read_seq([Reader] $rdr, $start, $end) { - $seq = @() - $token = $rdr.next() - if ($token -ne $start) { - throw "expected '$start'" - } - while (($token = $rdr.peek()) -ne $end) { - if ($token -eq "") { - throw "expected '$end', got EOF" - } - $form = read_form $rdr - $seq += $form - } - $token = $rdr.next() - return ,$seq -} - -function read_list([Reader] $rdr) { - return new-list (read_seq $rdr "(" ")") -} - -function read_vector([Reader] $rdr) { - return new-vector (read_seq $rdr "[" "]") -} - -function read_hash_map([Reader] $rdr) { - return new-hashmap (read_seq $rdr "{" "}") -} - -function read_form([Reader] $rdr) { - $token = $rdr.peek() - switch ($token) { - # reader macros/transforms - "'" { $_ = $rdr.next(); - return new-list @((new-symbol "quote"), - (read_form $rdr)) } - "``" { $_ = $rdr.next(); - return new-list @((new-symbol "quasiquote"), - (read_form $rdr)) } - "~" { $_ = $rdr.next(); - return (new-list @((new-symbol "unquote"), - (read_form $rdr))) } - "~@" { $_ = $rdr.next(); - return (new-list @((new-symbol "splice-unquote"), - (read_form $rdr))) } - "^" { $_ = $rdr.next(); - $meta = read_form $rdr - return (new-list @((new-symbol "with-meta"), - (read_form $rdr), - $meta)) } - "@" { $_ = $rdr.next(); - return (new-list @((new-symbol "deref"), - (read_form $rdr))) } - - # list - ")" { throw "unexpected ')'" } - "(" { return read_list $rdr } - - # vector - "]" { throw "unexpected ']'" } - "[" { return read_vector $rdr } - - # hashmap - "}" { throw "unexpected '}'" } - "{" { return read_hash_map $rdr } - - default { return read_atom $rdr } - } -} - -function read_str { - $toks = tokenize($args[0]) - if ($toks.Length -eq 0) { return $null } - read_form([Reader]::new($toks)) -} +Import-Module $PSScriptRoot/types.psm1 + +Class Reader { + [String[]] $tokens + [int] $pos + + Reader([String[]] $toks) { + $this.tokens = $toks + $this.pos = 0 + } + + [String] peek() { + return $this.tokens[$this.pos] + } + + [String] next() { + return $this.tokens[$this.pos++] + } +} + + +function tokenize { + $r = [regex]"[\s,]*(~@|[\[\]{}()'``~^@]|`"(?:\\.|[^\\`"])*`"?|;.*|[^\s\[\]{}('`"``,;)]*)" + $r.Matches($args) | + Where-Object { $_.Groups.Item(1).Value.Length -gt 0 -and + $_.Groups.Item(1).Value[0] -ne ";" } | + Foreach-Object { $_.Groups.Item(1).Value } +} + +function read_atom([Reader] $rdr) { + $token = $rdr.next() + if ($token -match "^-?[0-9]+$") { + return [convert]::ToInt32($token, 10) + } elseif ($token -match "^`"(?:\\.|[^\\`"])*`"$") { + $s = $token.Substring(1,$token.Length-2) + $s = $s -replace "\\\\", "$([char]0x29e)" + $s = $s -replace "\\`"", "`"" + $s = $s -replace "\\n", "`n" + $s = $s -replace "$([char]0x29e)", "\" + return $s + } elseif ($token -match "^`".*") { + throw "expected '`"', got EOF" + } elseif ($token -match ":.*") { + return "$([char]0x29e)$($token.substring(1))" + } elseif ($token -eq "true") { + return $true + } elseif ($token -eq "false") { + return $false + } elseif ($token -eq "nil") { + return $null + } else { + return new-symbol($token) + } +} + +function read_seq([Reader] $rdr, $start, $end) { + $seq = @() + $token = $rdr.next() + if ($token -ne $start) { + throw "expected '$start'" + } + while (($token = $rdr.peek()) -ne $end) { + if ($token -eq "") { + throw "expected '$end', got EOF" + } + $form = read_form $rdr + $seq += $form + } + $token = $rdr.next() + return ,$seq +} + +function read_list([Reader] $rdr) { + return new-list (read_seq $rdr "(" ")") +} + +function read_vector([Reader] $rdr) { + return new-vector (read_seq $rdr "[" "]") +} + +function read_hash_map([Reader] $rdr) { + return new-hashmap (read_seq $rdr "{" "}") +} + +function read_form([Reader] $rdr) { + $token = $rdr.peek() + switch ($token) { + # reader macros/transforms + "'" { $_ = $rdr.next(); + return new-list @((new-symbol "quote"), + (read_form $rdr)) } + "``" { $_ = $rdr.next(); + return new-list @((new-symbol "quasiquote"), + (read_form $rdr)) } + "~" { $_ = $rdr.next(); + return (new-list @((new-symbol "unquote"), + (read_form $rdr))) } + "~@" { $_ = $rdr.next(); + return (new-list @((new-symbol "splice-unquote"), + (read_form $rdr))) } + "^" { $_ = $rdr.next(); + $meta = read_form $rdr + return (new-list @((new-symbol "with-meta"), + (read_form $rdr), + $meta)) } + "@" { $_ = $rdr.next(); + return (new-list @((new-symbol "deref"), + (read_form $rdr))) } + + # list + ")" { throw "unexpected ')'" } + "(" { return read_list $rdr } + + # vector + "]" { throw "unexpected ']'" } + "[" { return read_vector $rdr } + + # hashmap + "}" { throw "unexpected '}'" } + "{" { return read_hash_map $rdr } + + default { return read_atom $rdr } + } +} + +function read_str { + $toks = tokenize($args[0]) + if ($toks.Length -eq 0) { return $null } + read_form([Reader]::new($toks)) +} diff --git a/impls/powershell/run b/impls/powershell/run index 4a52cc6ac3..1ee2d5921e 100755 --- a/impls/powershell/run +++ b/impls/powershell/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec powershell $(dirname $0)/${STEP:-stepA_mal}.ps1 "${@}" +#!/bin/bash +exec powershell $(dirname $0)/${STEP:-stepA_mal}.ps1 "${@}" diff --git a/impls/powershell/step0_repl.ps1 b/impls/powershell/step0_repl.ps1 index e02f371f13..a2377d2ba0 100644 --- a/impls/powershell/step0_repl.ps1 +++ b/impls/powershell/step0_repl.ps1 @@ -1,8 +1,8 @@ -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - "$line" -} +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + "$line" +} diff --git a/impls/powershell/step1_read_print.ps1 b/impls/powershell/step1_read_print.ps1 index b34ab774a1..473dcc55d2 100644 --- a/impls/powershell/step1_read_print.ps1 +++ b/impls/powershell/step1_read_print.ps1 @@ -1,37 +1,37 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function EVAL($ast, $env) { - return $ast -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -function REP([String] $str) { - return PRINT (EVAL (READ $str) @{}) -} - -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - Write-Host "Exception: $($_.Exception.Message)" - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function EVAL($ast, $env) { + return $ast +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +function REP([String] $str) { + return PRINT (EVAL (READ $str) @{}) +} + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + Write-Host "Exception: $($_.Exception.Message)" + } +} diff --git "a/impls/powershell/step2_eval - \345\211\257\346\234\254.ps1" "b/impls/powershell/step2_eval - \345\211\257\346\234\254.ps1" new file mode 100644 index 0000000000..e7f087e713 --- /dev/null +++ "b/impls/powershell/step2_eval - \345\211\257\346\234\254.ps1" @@ -0,0 +1,69 @@ +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function eval_ast($ast, $env) { + switch ($ast.GetType().Name) { + "Symbol" { return $env[$ast.value] } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + return &$f @fargs +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +# Case sensitive hashtable +$repl_env = New-Object System.Collections.HashTable +$repl_env["+"] = { param($a, $b); $a + $b } +$repl_env["-"] = { param($a, $b); $a - $b } +$repl_env["*"] = { param($a, $b); $a * $b } +$repl_env["/"] = { param($a, $b); $a / $b } + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + Write-Host "Exception: $($_.Exception.Message)" + } +} diff --git a/impls/powershell/step2_eval.ps1 b/impls/powershell/step2_eval.ps1 index 71db91499a..e7f087e713 100644 --- a/impls/powershell/step2_eval.ps1 +++ b/impls/powershell/step2_eval.ps1 @@ -1,69 +1,69 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/types.psm1 -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function eval_ast($ast, $env) { - switch ($ast.GetType().Name) { - "Symbol" { return $env[$ast.value] } - "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } - "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } - "HashMap" { - $hm = new-hashmap @() - foreach ($k in $ast.values.Keys) { - $hm.values[$k] = EVAL $ast.values[$k] $env - } - return $hm - } - default { return $ast } - } -} - -function EVAL($ast, $env) { - #Write-Host "EVAL $(pr_str $ast)" - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - if (empty? $ast) { return $ast } - - $el = (eval_ast $ast $env) - $f, $fargs = $el.first(), $el.rest().values - return &$f @fargs -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -# Case sensitive hashtable -$repl_env = New-Object System.Collections.HashTable -$repl_env["+"] = { param($a, $b); $a + $b } -$repl_env["-"] = { param($a, $b); $a - $b } -$repl_env["*"] = { param($a, $b); $a * $b } -$repl_env["/"] = { param($a, $b); $a / $b } - -function REP([String] $str) { - return PRINT (EVAL (READ $str) $repl_env) -} - -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - Write-Host "Exception: $($_.Exception.Message)" - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function eval_ast($ast, $env) { + switch ($ast.GetType().Name) { + "Symbol" { return $env[$ast.value] } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + return &$f @fargs +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +# Case sensitive hashtable +$repl_env = New-Object System.Collections.HashTable +$repl_env["+"] = { param($a, $b); $a + $b } +$repl_env["-"] = { param($a, $b); $a - $b } +$repl_env["*"] = { param($a, $b); $a * $b } +$repl_env["/"] = { param($a, $b); $a / $b } + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + Write-Host "Exception: $($_.Exception.Message)" + } +} diff --git a/impls/powershell/step3_env.ps1 b/impls/powershell/step3_env.ps1 index 6b045edb36..77ca3252f7 100644 --- a/impls/powershell/step3_env.ps1 +++ b/impls/powershell/step3_env.ps1 @@ -1,84 +1,84 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/types.psm1 -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 -Import-Module $PSScriptRoot/env.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function eval_ast($ast, $env) { - switch ($ast.GetType().Name) { - "Symbol" { return $env.get($ast) } - "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } - "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } - "HashMap" { - $hm = new-hashmap @() - foreach ($k in $ast.values.Keys) { - $hm.values[$k] = EVAL $ast.values[$k] $env - } - return $hm - } - default { return $ast } - } -} - -function EVAL($ast, $env) { - #Write-Host "EVAL $(pr_str $ast)" - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - if (empty? $ast) { return $ast } - - $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) - switch -casesensitive ($a0.value) { - "def!" { - return $env.set($a1, (EVAL $a2 $env)) - } - "let*" { - $let_env = new-env $env - for ($i=0; $i -lt $a1.values.Count; $i+=2) { - $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) - } - return EVAL $a2 $let_env - } - default { - $el = (eval_ast $ast $env) - $f, $fargs = $el.first(), $el.rest().values - return &$f @fargs - } - } -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -$repl_env = new-env -$_ = $repl_env.set((new-symbol "+"), { param($a, $b); $a + $b }) -$_ = $repl_env.set((new-symbol "-"), { param($a, $b); $a - $b }) -$_ = $repl_env.set((new-symbol "*"), { param($a, $b); $a * $b }) -$_ = $repl_env.set((new-symbol "/"), { param($a, $b); $a / $b }) - -function REP([String] $str) { - return PRINT (EVAL (READ $str) $repl_env) -} - -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - Write-Host "Exception: $($_.Exception.Message)" - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 +Import-Module $PSScriptRoot/env.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function eval_ast($ast, $env) { + switch ($ast.GetType().Name) { + "Symbol" { return $env.get($ast) } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) + switch -casesensitive ($a0.value) { + "def!" { + return $env.set($a1, (EVAL $a2 $env)) + } + "let*" { + $let_env = new-env $env + for ($i=0; $i -lt $a1.values.Count; $i+=2) { + $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) + } + return EVAL $a2 $let_env + } + default { + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + return &$f @fargs + } + } +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +$repl_env = new-env +$_ = $repl_env.set((new-symbol "+"), { param($a, $b); $a + $b }) +$_ = $repl_env.set((new-symbol "-"), { param($a, $b); $a - $b }) +$_ = $repl_env.set((new-symbol "*"), { param($a, $b); $a * $b }) +$_ = $repl_env.set((new-symbol "/"), { param($a, $b); $a / $b }) + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + Write-Host "Exception: $($_.Exception.Message)" + } +} diff --git a/impls/powershell/step4_if_fn_do.ps1 b/impls/powershell/step4_if_fn_do.ps1 index e21e4f7381..c7d4027049 100644 --- a/impls/powershell/step4_if_fn_do.ps1 +++ b/impls/powershell/step4_if_fn_do.ps1 @@ -1,109 +1,109 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/types.psm1 -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 -Import-Module $PSScriptRoot/env.psm1 -Import-Module $PSScriptRoot/core.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function eval_ast($ast, $env) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return $env.get($ast) } - "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } - "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } - "HashMap" { - $hm = new-hashmap @() - foreach ($k in $ast.values.Keys) { - $hm.values[$k] = EVAL $ast.values[$k] $env - } - return $hm - } - default { return $ast } - } -} - -function EVAL($ast, $env) { - #Write-Host "EVAL $(pr_str $ast)" - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - if (empty? $ast) { return $ast } - - $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) - switch -casesensitive ($a0.value) { - "def!" { - return $env.set($a1, (EVAL $a2 $env)) - } - "let*" { - $let_env = new-env $env - for ($i=0; $i -lt $a1.values.Count; $i+=2) { - $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) - } - return EVAL $a2 $let_env - } - "do" { - return (eval_ast $ast.rest() $env).last() - } - "if" { - $cond = (EVAL $a1 $env) - if ($cond -eq $null -or - ($cond -is [Boolean] -and $cond -eq $false)) { - return (EVAL $ast.nth(3) $env) - } else { - return (EVAL $a2 $env) - } - } - "fn*" { - # Save EVAL into a variable that will get closed over - $feval = Get-Command EVAL - return { - return (&$feval $a2 (new-env $env $a1.values $args)) - }.GetNewClosure() - } - default { - $el = (eval_ast $ast $env) - $f, $fargs = $el.first(), $el.rest().values - return &$f @fargs - } - } -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -$repl_env = new-env - -function REP([String] $str) { - return PRINT (EVAL (READ $str) $repl_env) -} - -# core.EXT: defined using PowerShell -foreach ($kv in $core_ns.GetEnumerator()) { - $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) -} - -# core.mal: defined using the language itself -$_ = REP('(def! not (fn* (a) (if a false true)))') - -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - Write-Host "Exception: $($_.Exception.Message)" - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 +Import-Module $PSScriptRoot/env.psm1 +Import-Module $PSScriptRoot/core.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function eval_ast($ast, $env) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return $env.get($ast) } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) + switch -casesensitive ($a0.value) { + "def!" { + return $env.set($a1, (EVAL $a2 $env)) + } + "let*" { + $let_env = new-env $env + for ($i=0; $i -lt $a1.values.Count; $i+=2) { + $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) + } + return EVAL $a2 $let_env + } + "do" { + return (eval_ast $ast.rest() $env).last() + } + "if" { + $cond = (EVAL $a1 $env) + if ($cond -eq $null -or + ($cond -is [Boolean] -and $cond -eq $false)) { + return (EVAL $ast.nth(3) $env) + } else { + return (EVAL $a2 $env) + } + } + "fn*" { + # Save EVAL into a variable that will get closed over + $feval = Get-Command EVAL + return { + return (&$feval $a2 (new-env $env $a1.values $args)) + }.GetNewClosure() + } + default { + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + return &$f @fargs + } + } +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +$repl_env = new-env + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +# core.EXT: defined using PowerShell +foreach ($kv in $core_ns.GetEnumerator()) { + $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) +} + +# core.mal: defined using the language itself +$_ = REP('(def! not (fn* (a) (if a false true)))') + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + Write-Host "Exception: $($_.Exception.Message)" + } +} diff --git a/impls/powershell/step5_tco.ps1 b/impls/powershell/step5_tco.ps1 index 476254955a..da0c326988 100644 --- a/impls/powershell/step5_tco.ps1 +++ b/impls/powershell/step5_tco.ps1 @@ -1,122 +1,122 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/types.psm1 -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 -Import-Module $PSScriptRoot/env.psm1 -Import-Module $PSScriptRoot/core.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function eval_ast($ast, $env) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return $env.get($ast) } - "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } - "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } - "HashMap" { - $hm = new-hashmap @() - foreach ($k in $ast.values.Keys) { - $hm.values[$k] = EVAL $ast.values[$k] $env - } - return $hm - } - default { return $ast } - } -} - -function EVAL($ast, $env) { - while ($true) { - #Write-Host "EVAL $(pr_str $ast)" - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - if (empty? $ast) { return $ast } - - $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) - switch -casesensitive ($a0.value) { - "def!" { - return $env.set($a1, (EVAL $a2 $env)) - } - "let*" { - $let_env = new-env $env - for ($i=0; $i -lt $a1.values.Count; $i+=2) { - $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) - } - $env = $let_env - $ast = $a2 # TCO - } - "do" { - if ($ast.values.Count -gt 2) { - $middle = new-list $ast.values[1..($ast.values.Count-2)] - $_ = eval_ast $middle $env - } - $ast = $ast.last() # TCO - } - "if" { - $cond = (EVAL $a1 $env) - if ($cond -eq $null -or - ($cond -is [Boolean] -and $cond -eq $false)) { - $ast = $ast.nth(3) # TCO - } else { - $ast = $a2 # TCO - } - } - "fn*" { - # Save EVAL into a variable that will get closed over - $feval = Get-Command EVAL - $fn = { - return (&$feval $a2 (new-env $env $a1.values $args)) - }.GetNewClosure() - return new-malfunc $a2 $a1.values $env $fn - } - default { - $el = (eval_ast $ast $env) - $f, $fargs = $el.first(), $el.rest().values - if (malfunc? $f) { - $env = (new-env $f.env $f.params $fargs) - $ast = $f.ast # TCO - } else { - return &$f @fargs - } - } - } - } -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -$repl_env = new-env - -function REP([String] $str) { - return PRINT (EVAL (READ $str) $repl_env) -} - -# core.EXT: defined using PowerShell -foreach ($kv in $core_ns.GetEnumerator()) { - $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) -} - -# core.mal: defined using the language itself -$_ = REP('(def! not (fn* (a) (if a false true)))') - -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - Write-Host "Exception: $($_.Exception.Message)" - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 +Import-Module $PSScriptRoot/env.psm1 +Import-Module $PSScriptRoot/core.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function eval_ast($ast, $env) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return $env.get($ast) } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + while ($true) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) + switch -casesensitive ($a0.value) { + "def!" { + return $env.set($a1, (EVAL $a2 $env)) + } + "let*" { + $let_env = new-env $env + for ($i=0; $i -lt $a1.values.Count; $i+=2) { + $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) + } + $env = $let_env + $ast = $a2 # TCO + } + "do" { + if ($ast.values.Count -gt 2) { + $middle = new-list $ast.values[1..($ast.values.Count-2)] + $_ = eval_ast $middle $env + } + $ast = $ast.last() # TCO + } + "if" { + $cond = (EVAL $a1 $env) + if ($cond -eq $null -or + ($cond -is [Boolean] -and $cond -eq $false)) { + $ast = $ast.nth(3) # TCO + } else { + $ast = $a2 # TCO + } + } + "fn*" { + # Save EVAL into a variable that will get closed over + $feval = Get-Command EVAL + $fn = { + return (&$feval $a2 (new-env $env $a1.values $args)) + }.GetNewClosure() + return new-malfunc $a2 $a1.values $env $fn + } + default { + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + if (malfunc? $f) { + $env = (new-env $f.env $f.params $fargs) + $ast = $f.ast # TCO + } else { + return &$f @fargs + } + } + } + } +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +$repl_env = new-env + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +# core.EXT: defined using PowerShell +foreach ($kv in $core_ns.GetEnumerator()) { + $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) +} + +# core.mal: defined using the language itself +$_ = REP('(def! not (fn* (a) (if a false true)))') + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + Write-Host "Exception: $($_.Exception.Message)" + } +} diff --git a/impls/powershell/step6_file.ps1 b/impls/powershell/step6_file.ps1 index dd52d46fe8..4c6f0f5511 100644 --- a/impls/powershell/step6_file.ps1 +++ b/impls/powershell/step6_file.ps1 @@ -1,131 +1,131 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/types.psm1 -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 -Import-Module $PSScriptRoot/env.psm1 -Import-Module $PSScriptRoot/core.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function eval_ast($ast, $env) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return $env.get($ast) } - "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } - "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } - "HashMap" { - $hm = new-hashmap @() - foreach ($k in $ast.values.Keys) { - $hm.values[$k] = EVAL $ast.values[$k] $env - } - return $hm - } - default { return $ast } - } -} - -function EVAL($ast, $env) { - while ($true) { - #Write-Host "EVAL $(pr_str $ast)" - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - if (empty? $ast) { return $ast } - - $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) - switch -casesensitive ($a0.value) { - "def!" { - return $env.set($a1, (EVAL $a2 $env)) - } - "let*" { - $let_env = new-env $env - for ($i=0; $i -lt $a1.values.Count; $i+=2) { - $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) - } - $env = $let_env - $ast = $a2 # TCO - } - "do" { - if ($ast.values.Count -gt 2) { - $middle = new-list $ast.values[1..($ast.values.Count-2)] - $_ = eval_ast $middle $env - } - $ast = $ast.last() # TCO - } - "if" { - $cond = (EVAL $a1 $env) - if ($cond -eq $null -or - ($cond -is [Boolean] -and $cond -eq $false)) { - $ast = $ast.nth(3) # TCO - } else { - $ast = $a2 # TCO - } - } - "fn*" { - # Save EVAL into a variable that will get closed over - $feval = Get-Command EVAL - $fn = { - return (&$feval $a2 (new-env $env $a1.values $args)) - }.GetNewClosure() - return new-malfunc $a2 $a1.values $env $fn - } - default { - $el = (eval_ast $ast $env) - $f, $fargs = $el.first(), $el.rest().values - if (malfunc? $f) { - $env = (new-env $f.env $f.params $fargs) - $ast = $f.ast # TCO - } else { - return &$f @fargs - } - } - } - } -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -$repl_env = new-env - -function REP([String] $str) { - return PRINT (EVAL (READ $str) $repl_env) -} - -# core.EXT: defined using PowerShell -foreach ($kv in $core_ns.GetEnumerator()) { - $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) -} -$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) -$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) - -# core.mal: defined using the language itself -$_ = REP('(def! not (fn* (a) (if a false true)))') -$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') - - -if ($args.Count -gt 0) { - $_ = REP('(load-file "' + $args[0] + '")') - exit 0 -} - -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - Write-Host "Exception: $($_.Exception.Message)" - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 +Import-Module $PSScriptRoot/env.psm1 +Import-Module $PSScriptRoot/core.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function eval_ast($ast, $env) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return $env.get($ast) } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + while ($true) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) + switch -casesensitive ($a0.value) { + "def!" { + return $env.set($a1, (EVAL $a2 $env)) + } + "let*" { + $let_env = new-env $env + for ($i=0; $i -lt $a1.values.Count; $i+=2) { + $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) + } + $env = $let_env + $ast = $a2 # TCO + } + "do" { + if ($ast.values.Count -gt 2) { + $middle = new-list $ast.values[1..($ast.values.Count-2)] + $_ = eval_ast $middle $env + } + $ast = $ast.last() # TCO + } + "if" { + $cond = (EVAL $a1 $env) + if ($cond -eq $null -or + ($cond -is [Boolean] -and $cond -eq $false)) { + $ast = $ast.nth(3) # TCO + } else { + $ast = $a2 # TCO + } + } + "fn*" { + # Save EVAL into a variable that will get closed over + $feval = Get-Command EVAL + $fn = { + return (&$feval $a2 (new-env $env $a1.values $args)) + }.GetNewClosure() + return new-malfunc $a2 $a1.values $env $fn + } + default { + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + if (malfunc? $f) { + $env = (new-env $f.env $f.params $fargs) + $ast = $f.ast # TCO + } else { + return &$f @fargs + } + } + } + } +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +$repl_env = new-env + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +# core.EXT: defined using PowerShell +foreach ($kv in $core_ns.GetEnumerator()) { + $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) +} +$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) +$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) + +# core.mal: defined using the language itself +$_ = REP('(def! not (fn* (a) (if a false true)))') +$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') + + +if ($args.Count -gt 0) { + $_ = REP('(load-file "' + $args[0] + '")') + exit 0 +} + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + Write-Host "Exception: $($_.Exception.Message)" + } +} diff --git a/impls/powershell/step7_quote.ps1 b/impls/powershell/step7_quote.ps1 index 3d21d98ad5..7155cdbda8 100644 --- a/impls/powershell/step7_quote.ps1 +++ b/impls/powershell/step7_quote.ps1 @@ -1,176 +1,176 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/types.psm1 -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 -Import-Module $PSScriptRoot/env.psm1 -Import-Module $PSScriptRoot/core.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function starts_with($lst, $sym) { - if ($lst.values.Count -ne 2) { return $false } - $a0 = $lst.nth(0) - return (symbol? $a0) -and ($a0.value -ceq $sym) -} -function qq_loop($elt, $acc) { - if ((list? $elt) -and (starts_with $elt "splice-unquote")) { - return (new-list @((new-symbol "concat"), $elt.nth(1), $acc)) - } else { - return (new-list @((new-symbol "cons"), (quasiquote $elt), $acc)) - } -} -function qq_foldr($xs) { - $acc = new-list @() - for ( $i = $xs.Count - 1; $i -ge 0; $i-- ) { - $acc = qq_loop $xs[$i] $acc - } - return $acc -} -function quasiquote($ast) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return (new-list @((new-symbol "quote"), $ast)) } - "HashMap" { return (new-list @((new-symbol "quote"), $ast)) } - "Vector" { return (new-list @((new-symbol "vec"), (qq_foldr $ast.values))) } - "List" { - if (starts_with $ast "unquote") { - return $ast.values[1] - } else { - return qq_foldr $ast.values - } - } - default { return $ast } - } -} - -function eval_ast($ast, $env) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return $env.get($ast) } - "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } - "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } - "HashMap" { - $hm = new-hashmap @() - foreach ($k in $ast.values.Keys) { - $hm.values[$k] = EVAL $ast.values[$k] $env - } - return $hm - } - default { return $ast } - } -} - -function EVAL($ast, $env) { - while ($true) { - #Write-Host "EVAL $(pr_str $ast)" - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - if (empty? $ast) { return $ast } - - $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) - switch -casesensitive ($a0.value) { - "def!" { - return $env.set($a1, (EVAL $a2 $env)) - } - "let*" { - $let_env = new-env $env - for ($i=0; $i -lt $a1.values.Count; $i+=2) { - $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) - } - $env = $let_env - $ast = $a2 # TCO - } - "quote" { - return $a1 - } - "quasiquoteexpand" { - return (quasiquote $a1) - } - "quasiquote" { - $ast = quasiquote $a1 - } - "do" { - if ($ast.values.Count -gt 2) { - $middle = new-list $ast.values[1..($ast.values.Count-2)] - $_ = eval_ast $middle $env - } - $ast = $ast.last() # TCO - } - "if" { - $cond = (EVAL $a1 $env) - if ($cond -eq $null -or - ($cond -is [Boolean] -and $cond -eq $false)) { - $ast = $ast.nth(3) # TCO - } else { - $ast = $a2 # TCO - } - } - "fn*" { - # Save EVAL into a variable that will get closed over - $feval = Get-Command EVAL - $fn = { - return (&$feval $a2 (new-env $env $a1.values $args)) - }.GetNewClosure() - return new-malfunc $a2 $a1.values $env $fn - } - default { - $el = (eval_ast $ast $env) - $f, $fargs = $el.first(), $el.rest().values - if (malfunc? $f) { - $env = (new-env $f.env $f.params $fargs) - $ast = $f.ast # TCO - } else { - return &$f @fargs - } - } - } - } -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -$repl_env = new-env - -function REP([String] $str) { - return PRINT (EVAL (READ $str) $repl_env) -} - -# core.EXT: defined using PowerShell -foreach ($kv in $core_ns.GetEnumerator()) { - $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) -} -$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) -$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) - -# core.mal: defined using the language itself -$_ = REP('(def! not (fn* (a) (if a false true)))') -$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') - - -if ($args.Count -gt 0) { - $_ = REP('(load-file "' + $args[0] + '")') - exit 0 -} - -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - Write-Host "Exception: $($_.Exception.Message)" - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 +Import-Module $PSScriptRoot/env.psm1 +Import-Module $PSScriptRoot/core.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function starts_with($lst, $sym) { + if ($lst.values.Count -ne 2) { return $false } + $a0 = $lst.nth(0) + return (symbol? $a0) -and ($a0.value -ceq $sym) +} +function qq_loop($elt, $acc) { + if ((list? $elt) -and (starts_with $elt "splice-unquote")) { + return (new-list @((new-symbol "concat"), $elt.nth(1), $acc)) + } else { + return (new-list @((new-symbol "cons"), (quasiquote $elt), $acc)) + } +} +function qq_foldr($xs) { + $acc = new-list @() + for ( $i = $xs.Count - 1; $i -ge 0; $i-- ) { + $acc = qq_loop $xs[$i] $acc + } + return $acc +} +function quasiquote($ast) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return (new-list @((new-symbol "quote"), $ast)) } + "HashMap" { return (new-list @((new-symbol "quote"), $ast)) } + "Vector" { return (new-list @((new-symbol "vec"), (qq_foldr $ast.values))) } + "List" { + if (starts_with $ast "unquote") { + return $ast.values[1] + } else { + return qq_foldr $ast.values + } + } + default { return $ast } + } +} + +function eval_ast($ast, $env) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return $env.get($ast) } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + while ($true) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) + switch -casesensitive ($a0.value) { + "def!" { + return $env.set($a1, (EVAL $a2 $env)) + } + "let*" { + $let_env = new-env $env + for ($i=0; $i -lt $a1.values.Count; $i+=2) { + $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) + } + $env = $let_env + $ast = $a2 # TCO + } + "quote" { + return $a1 + } + "quasiquoteexpand" { + return (quasiquote $a1) + } + "quasiquote" { + $ast = quasiquote $a1 + } + "do" { + if ($ast.values.Count -gt 2) { + $middle = new-list $ast.values[1..($ast.values.Count-2)] + $_ = eval_ast $middle $env + } + $ast = $ast.last() # TCO + } + "if" { + $cond = (EVAL $a1 $env) + if ($cond -eq $null -or + ($cond -is [Boolean] -and $cond -eq $false)) { + $ast = $ast.nth(3) # TCO + } else { + $ast = $a2 # TCO + } + } + "fn*" { + # Save EVAL into a variable that will get closed over + $feval = Get-Command EVAL + $fn = { + return (&$feval $a2 (new-env $env $a1.values $args)) + }.GetNewClosure() + return new-malfunc $a2 $a1.values $env $fn + } + default { + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + if (malfunc? $f) { + $env = (new-env $f.env $f.params $fargs) + $ast = $f.ast # TCO + } else { + return &$f @fargs + } + } + } + } +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +$repl_env = new-env + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +# core.EXT: defined using PowerShell +foreach ($kv in $core_ns.GetEnumerator()) { + $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) +} +$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) +$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) + +# core.mal: defined using the language itself +$_ = REP('(def! not (fn* (a) (if a false true)))') +$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') + + +if ($args.Count -gt 0) { + $_ = REP('(load-file "' + $args[0] + '")') + exit 0 +} + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + Write-Host "Exception: $($_.Exception.Message)" + } +} diff --git a/impls/powershell/step8_macros.ps1 b/impls/powershell/step8_macros.ps1 index a352636af6..66ec5acb65 100644 --- a/impls/powershell/step8_macros.ps1 +++ b/impls/powershell/step8_macros.ps1 @@ -1,206 +1,206 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/types.psm1 -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 -Import-Module $PSScriptRoot/env.psm1 -Import-Module $PSScriptRoot/core.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function starts_with($lst, $sym) { - if ($lst.values.Count -ne 2) { return $false } - $a0 = $lst.nth(0) - return (symbol? $a0) -and ($a0.value -ceq $sym) -} -function qq_loop($elt, $acc) { - if ((list? $elt) -and (starts_with $elt "splice-unquote")) { - return (new-list @((new-symbol "concat"), $elt.nth(1), $acc)) - } else { - return (new-list @((new-symbol "cons"), (quasiquote $elt), $acc)) - } -} -function qq_foldr($xs) { - $acc = new-list @() - for ( $i = $xs.Count - 1; $i -ge 0; $i-- ) { - $acc = qq_loop $xs[$i] $acc - } - return $acc -} -function quasiquote($ast) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return (new-list @((new-symbol "quote"), $ast)) } - "HashMap" { return (new-list @((new-symbol "quote"), $ast)) } - "Vector" { return (new-list @((new-symbol "vec"), (qq_foldr $ast.values))) } - "List" { - if (starts_with $ast "unquote") { - return $ast.values[1] - } else { - return qq_foldr $ast.values - } - } - default { return $ast } - } -} - -function macro?($ast, $env) { - return (list? $ast) -and - (symbol? $ast.nth(0)) -and - $env.find($ast.nth(0)) -and - $env.get($ast.nth(0)).macro -} - -function macroexpand($ast, $env) { - while (macro? $ast $env) { - $mac = $env.get($ast.nth(0)).fn - $margs = $ast.rest().values - $ast = &$mac @margs - } - return $ast -} - -function eval_ast($ast, $env) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return $env.get($ast) } - "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } - "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } - "HashMap" { - $hm = new-hashmap @() - foreach ($k in $ast.values.Keys) { - $hm.values[$k] = EVAL $ast.values[$k] $env - } - return $hm - } - default { return $ast } - } -} - -function EVAL($ast, $env) { - while ($true) { - #Write-Host "EVAL $(pr_str $ast)" - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - - $ast = (macroexpand $ast $env) - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - if (empty? $ast) { return $ast } - - $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) - switch -casesensitive ($a0.value) { - "def!" { - return $env.set($a1, (EVAL $a2 $env)) - } - "let*" { - $let_env = new-env $env - for ($i=0; $i -lt $a1.values.Count; $i+=2) { - $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) - } - $env = $let_env - $ast = $a2 # TCO - } - "quote" { - return $a1 - } - "quasiquoteexpand" { - return (quasiquote $a1) - } - "quasiquote" { - $ast = quasiquote $a1 - } - "defmacro!" { - $m = EVAL $a2 $env - $m.macro = $true - return $env.set($a1, $m) - } - "macroexpand" { - return (macroexpand $a1 $env) - } - "do" { - if ($ast.values.Count -gt 2) { - $middle = new-list $ast.values[1..($ast.values.Count-2)] - $_ = eval_ast $middle $env - } - $ast = $ast.last() # TCO - } - "if" { - $cond = (EVAL $a1 $env) - if ($cond -eq $null -or - ($cond -is [Boolean] -and $cond -eq $false)) { - $ast = $ast.nth(3) # TCO - } else { - $ast = $a2 # TCO - } - } - "fn*" { - # Save EVAL into a variable that will get closed over - $feval = Get-Command EVAL - $fn = { - return (&$feval $a2 (new-env $env $a1.values $args)) - }.GetNewClosure() - return new-malfunc $a2 $a1.values $env $fn - } - default { - $el = (eval_ast $ast $env) - $f, $fargs = $el.first(), $el.rest().values - if (malfunc? $f) { - $env = (new-env $f.env $f.params $fargs) - $ast = $f.ast # TCO - } else { - return &$f @fargs - } - } - } - } -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -$repl_env = new-env - -function REP([String] $str) { - return PRINT (EVAL (READ $str) $repl_env) -} - -# core.EXT: defined using PowerShell -foreach ($kv in $core_ns.GetEnumerator()) { - $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) -} -$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) -$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) - -# core.mal: defined using the language itself -$_ = REP('(def! not (fn* (a) (if a false true)))') -$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') -$_ = 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)))))))") - - -if ($args.Count -gt 0) { - $_ = REP('(load-file "' + $args[0] + '")') - exit 0 -} - -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - Write-Host "Exception: $($_.Exception.Message)" - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 +Import-Module $PSScriptRoot/env.psm1 +Import-Module $PSScriptRoot/core.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function starts_with($lst, $sym) { + if ($lst.values.Count -ne 2) { return $false } + $a0 = $lst.nth(0) + return (symbol? $a0) -and ($a0.value -ceq $sym) +} +function qq_loop($elt, $acc) { + if ((list? $elt) -and (starts_with $elt "splice-unquote")) { + return (new-list @((new-symbol "concat"), $elt.nth(1), $acc)) + } else { + return (new-list @((new-symbol "cons"), (quasiquote $elt), $acc)) + } +} +function qq_foldr($xs) { + $acc = new-list @() + for ( $i = $xs.Count - 1; $i -ge 0; $i-- ) { + $acc = qq_loop $xs[$i] $acc + } + return $acc +} +function quasiquote($ast) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return (new-list @((new-symbol "quote"), $ast)) } + "HashMap" { return (new-list @((new-symbol "quote"), $ast)) } + "Vector" { return (new-list @((new-symbol "vec"), (qq_foldr $ast.values))) } + "List" { + if (starts_with $ast "unquote") { + return $ast.values[1] + } else { + return qq_foldr $ast.values + } + } + default { return $ast } + } +} + +function macro?($ast, $env) { + return (list? $ast) -and + (symbol? $ast.nth(0)) -and + $env.find($ast.nth(0)) -and + $env.get($ast.nth(0)).macro +} + +function macroexpand($ast, $env) { + while (macro? $ast $env) { + $mac = $env.get($ast.nth(0)).fn + $margs = $ast.rest().values + $ast = &$mac @margs + } + return $ast +} + +function eval_ast($ast, $env) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return $env.get($ast) } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + while ($true) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + + $ast = (macroexpand $ast $env) + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) + switch -casesensitive ($a0.value) { + "def!" { + return $env.set($a1, (EVAL $a2 $env)) + } + "let*" { + $let_env = new-env $env + for ($i=0; $i -lt $a1.values.Count; $i+=2) { + $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) + } + $env = $let_env + $ast = $a2 # TCO + } + "quote" { + return $a1 + } + "quasiquoteexpand" { + return (quasiquote $a1) + } + "quasiquote" { + $ast = quasiquote $a1 + } + "defmacro!" { + $m = EVAL $a2 $env + $m.macro = $true + return $env.set($a1, $m) + } + "macroexpand" { + return (macroexpand $a1 $env) + } + "do" { + if ($ast.values.Count -gt 2) { + $middle = new-list $ast.values[1..($ast.values.Count-2)] + $_ = eval_ast $middle $env + } + $ast = $ast.last() # TCO + } + "if" { + $cond = (EVAL $a1 $env) + if ($cond -eq $null -or + ($cond -is [Boolean] -and $cond -eq $false)) { + $ast = $ast.nth(3) # TCO + } else { + $ast = $a2 # TCO + } + } + "fn*" { + # Save EVAL into a variable that will get closed over + $feval = Get-Command EVAL + $fn = { + return (&$feval $a2 (new-env $env $a1.values $args)) + }.GetNewClosure() + return new-malfunc $a2 $a1.values $env $fn + } + default { + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + if (malfunc? $f) { + $env = (new-env $f.env $f.params $fargs) + $ast = $f.ast # TCO + } else { + return &$f @fargs + } + } + } + } +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +$repl_env = new-env + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +# core.EXT: defined using PowerShell +foreach ($kv in $core_ns.GetEnumerator()) { + $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) +} +$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) +$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) + +# core.mal: defined using the language itself +$_ = REP('(def! not (fn* (a) (if a false true)))') +$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') +$_ = 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)))))))") + + +if ($args.Count -gt 0) { + $_ = REP('(load-file "' + $args[0] + '")') + exit 0 +} + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + Write-Host "Exception: $($_.Exception.Message)" + } +} diff --git a/impls/powershell/step9_try.ps1 b/impls/powershell/step9_try.ps1 index 4395688029..b01650bfbe 100644 --- a/impls/powershell/step9_try.ps1 +++ b/impls/powershell/step9_try.ps1 @@ -1,226 +1,226 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/types.psm1 -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 -Import-Module $PSScriptRoot/env.psm1 -Import-Module $PSScriptRoot/core.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function starts_with($lst, $sym) { - if ($lst.values.Count -ne 2) { return $false } - $a0 = $lst.nth(0) - return (symbol? $a0) -and ($a0.value -ceq $sym) -} -function qq_loop($elt, $acc) { - if ((list? $elt) -and (starts_with $elt "splice-unquote")) { - return (new-list @((new-symbol "concat"), $elt.nth(1), $acc)) - } else { - return (new-list @((new-symbol "cons"), (quasiquote $elt), $acc)) - } -} -function qq_foldr($xs) { - $acc = new-list @() - for ( $i = $xs.Count - 1; $i -ge 0; $i-- ) { - $acc = qq_loop $xs[$i] $acc - } - return $acc -} -function quasiquote($ast) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return (new-list @((new-symbol "quote"), $ast)) } - "HashMap" { return (new-list @((new-symbol "quote"), $ast)) } - "Vector" { return (new-list @((new-symbol "vec"), (qq_foldr $ast.values))) } - "List" { - if (starts_with $ast "unquote") { - return $ast.values[1] - } else { - return qq_foldr $ast.values - } - } - default { return $ast } - } -} - -function macro?($ast, $env) { - return (list? $ast) -and - (symbol? $ast.nth(0)) -and - $env.find($ast.nth(0)) -and - $env.get($ast.nth(0)).macro -} - -function macroexpand($ast, $env) { - while (macro? $ast $env) { - $mac = $env.get($ast.nth(0)).fn - $margs = $ast.rest().values - $ast = &$mac @margs - } - return $ast -} - -function eval_ast($ast, $env) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return $env.get($ast) } - "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } - "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } - "HashMap" { - $hm = new-hashmap @() - foreach ($k in $ast.values.Keys) { - $hm.values[$k] = EVAL $ast.values[$k] $env - } - return $hm - } - default { return $ast } - } -} - -function EVAL($ast, $env) { - while ($true) { - #Write-Host "EVAL $(pr_str $ast)" - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - - $ast = (macroexpand $ast $env) - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - if (empty? $ast) { return $ast } - - $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) - switch -casesensitive ($a0.value) { - "def!" { - return $env.set($a1, (EVAL $a2 $env)) - } - "let*" { - $let_env = new-env $env - for ($i=0; $i -lt $a1.values.Count; $i+=2) { - $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) - } - $env = $let_env - $ast = $a2 # TCO - } - "quote" { - return $a1 - } - "quasiquoteexpand" { - return (quasiquote $a1) - } - "quasiquote" { - $ast = quasiquote $a1 - } - "defmacro!" { - $m = EVAL $a2 $env - $m.macro = $true - return $env.set($a1, $m) - } - "macroexpand" { - return (macroexpand $a1 $env) - } - "try*" { - try { - return EVAL $a1 $env - } catch { - if ($a2 -and ($a2.nth(0).value -ceq "catch*")) { - if ($_.Exception.GetType().Name -eq "MalException") { - $e = @($_.Exception.object) - } else { - $e = @($_.Exception.Message) - } - return (EVAL $a2.nth(2) (new-env $env @($a2.nth(1)) $e)) - } else { - throw - } - } - } - "do" { - if ($ast.values.Count -gt 2) { - $middle = new-list $ast.values[1..($ast.values.Count-2)] - $_ = eval_ast $middle $env - } - $ast = $ast.last() # TCO - } - "if" { - $cond = (EVAL $a1 $env) - if ($cond -eq $null -or - ($cond -is [Boolean] -and $cond -eq $false)) { - $ast = $ast.nth(3) # TCO - } else { - $ast = $a2 # TCO - } - } - "fn*" { - # Save EVAL into a variable that will get closed over - $feval = Get-Command EVAL - $fn = { - return (&$feval $a2 (new-env $env $a1.values $args)) - }.GetNewClosure() - return new-malfunc $a2 $a1.values $env $fn - } - default { - $el = (eval_ast $ast $env) - $f, $fargs = $el.first(), $el.rest().values - if (malfunc? $f) { - $env = (new-env $f.env $f.params $fargs) - $ast = $f.ast # TCO - } else { - return &$f @fargs - } - } - } - } -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -$repl_env = new-env - -function REP([String] $str) { - return PRINT (EVAL (READ $str) $repl_env) -} - -# core.EXT: defined using PowerShell -foreach ($kv in $core_ns.GetEnumerator()) { - $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) -} -$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) -$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) - -# core.mal: defined using the language itself -$_ = REP('(def! not (fn* (a) (if a false true)))') -$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') -$_ = 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)))))))") - - -if ($args.Count -gt 0) { - $_ = REP('(load-file "' + $args[0] + '")') - exit 0 -} - -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - if ($_.Exception.GetType().Name -eq "MalException") { - Write-Host "Exception: $(pr_str $_.Exception.object)" - } else { - Write-Host "Exception: $($_.Exception.Message)" - } - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 +Import-Module $PSScriptRoot/env.psm1 +Import-Module $PSScriptRoot/core.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function starts_with($lst, $sym) { + if ($lst.values.Count -ne 2) { return $false } + $a0 = $lst.nth(0) + return (symbol? $a0) -and ($a0.value -ceq $sym) +} +function qq_loop($elt, $acc) { + if ((list? $elt) -and (starts_with $elt "splice-unquote")) { + return (new-list @((new-symbol "concat"), $elt.nth(1), $acc)) + } else { + return (new-list @((new-symbol "cons"), (quasiquote $elt), $acc)) + } +} +function qq_foldr($xs) { + $acc = new-list @() + for ( $i = $xs.Count - 1; $i -ge 0; $i-- ) { + $acc = qq_loop $xs[$i] $acc + } + return $acc +} +function quasiquote($ast) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return (new-list @((new-symbol "quote"), $ast)) } + "HashMap" { return (new-list @((new-symbol "quote"), $ast)) } + "Vector" { return (new-list @((new-symbol "vec"), (qq_foldr $ast.values))) } + "List" { + if (starts_with $ast "unquote") { + return $ast.values[1] + } else { + return qq_foldr $ast.values + } + } + default { return $ast } + } +} + +function macro?($ast, $env) { + return (list? $ast) -and + (symbol? $ast.nth(0)) -and + $env.find($ast.nth(0)) -and + $env.get($ast.nth(0)).macro +} + +function macroexpand($ast, $env) { + while (macro? $ast $env) { + $mac = $env.get($ast.nth(0)).fn + $margs = $ast.rest().values + $ast = &$mac @margs + } + return $ast +} + +function eval_ast($ast, $env) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return $env.get($ast) } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + while ($true) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + + $ast = (macroexpand $ast $env) + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) + switch -casesensitive ($a0.value) { + "def!" { + return $env.set($a1, (EVAL $a2 $env)) + } + "let*" { + $let_env = new-env $env + for ($i=0; $i -lt $a1.values.Count; $i+=2) { + $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) + } + $env = $let_env + $ast = $a2 # TCO + } + "quote" { + return $a1 + } + "quasiquoteexpand" { + return (quasiquote $a1) + } + "quasiquote" { + $ast = quasiquote $a1 + } + "defmacro!" { + $m = EVAL $a2 $env + $m.macro = $true + return $env.set($a1, $m) + } + "macroexpand" { + return (macroexpand $a1 $env) + } + "try*" { + try { + return EVAL $a1 $env + } catch { + if ($a2 -and ($a2.nth(0).value -ceq "catch*")) { + if ($_.Exception.GetType().Name -eq "MalException") { + $e = @($_.Exception.object) + } else { + $e = @($_.Exception.Message) + } + return (EVAL $a2.nth(2) (new-env $env @($a2.nth(1)) $e)) + } else { + throw + } + } + } + "do" { + if ($ast.values.Count -gt 2) { + $middle = new-list $ast.values[1..($ast.values.Count-2)] + $_ = eval_ast $middle $env + } + $ast = $ast.last() # TCO + } + "if" { + $cond = (EVAL $a1 $env) + if ($cond -eq $null -or + ($cond -is [Boolean] -and $cond -eq $false)) { + $ast = $ast.nth(3) # TCO + } else { + $ast = $a2 # TCO + } + } + "fn*" { + # Save EVAL into a variable that will get closed over + $feval = Get-Command EVAL + $fn = { + return (&$feval $a2 (new-env $env $a1.values $args)) + }.GetNewClosure() + return new-malfunc $a2 $a1.values $env $fn + } + default { + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + if (malfunc? $f) { + $env = (new-env $f.env $f.params $fargs) + $ast = $f.ast # TCO + } else { + return &$f @fargs + } + } + } + } +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +$repl_env = new-env + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +# core.EXT: defined using PowerShell +foreach ($kv in $core_ns.GetEnumerator()) { + $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) +} +$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) +$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) + +# core.mal: defined using the language itself +$_ = REP('(def! not (fn* (a) (if a false true)))') +$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') +$_ = 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)))))))") + + +if ($args.Count -gt 0) { + $_ = REP('(load-file "' + $args[0] + '")') + exit 0 +} + +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + if ($_.Exception.GetType().Name -eq "MalException") { + Write-Host "Exception: $(pr_str $_.Exception.object)" + } else { + Write-Host "Exception: $($_.Exception.Message)" + } + } +} diff --git a/impls/powershell/stepA_mal.ps1 b/impls/powershell/stepA_mal.ps1 index 24a9846d2a..4a405393a6 100644 --- a/impls/powershell/stepA_mal.ps1 +++ b/impls/powershell/stepA_mal.ps1 @@ -1,228 +1,228 @@ -$ErrorActionPreference = "Stop" - -Import-Module $PSScriptRoot/types.psm1 -Import-Module $PSScriptRoot/reader.psm1 -Import-Module $PSScriptRoot/printer.psm1 -Import-Module $PSScriptRoot/env.psm1 -Import-Module $PSScriptRoot/core.psm1 - -# READ -function READ([String] $str) { - return read_str($str) -} - -# EVAL -function starts_with($lst, $sym) { - if ($lst.values.Count -ne 2) { return $false } - $a0 = $lst.nth(0) - return (symbol? $a0) -and ($a0.value -ceq $sym) -} -function qq_loop($elt, $acc) { - if ((list? $elt) -and (starts_with $elt "splice-unquote")) { - return (new-list @((new-symbol "concat"), $elt.nth(1), $acc)) - } else { - return (new-list @((new-symbol "cons"), (quasiquote $elt), $acc)) - } -} -function qq_foldr($xs) { - $acc = new-list @() - for ( $i = $xs.Count - 1; $i -ge 0; $i-- ) { - $acc = qq_loop $xs[$i] $acc - } - return $acc -} -function quasiquote($ast) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return (new-list @((new-symbol "quote"), $ast)) } - "HashMap" { return (new-list @((new-symbol "quote"), $ast)) } - "Vector" { return (new-list @((new-symbol "vec"), (qq_foldr $ast.values))) } - "List" { - if (starts_with $ast "unquote") { - return $ast.values[1] - } else { - return qq_foldr $ast.values - } - } - default { return $ast } - } -} - -function macro?($ast, $env) { - return (list? $ast) -and - (symbol? $ast.nth(0)) -and - $env.find($ast.nth(0)) -and - $env.get($ast.nth(0)).macro -} - -function macroexpand($ast, $env) { - while (macro? $ast $env) { - $mac = $env.get($ast.nth(0)).fn - $margs = $ast.rest().values - $ast = &$mac @margs - } - return $ast -} - -function eval_ast($ast, $env) { - if ($ast -eq $null) { return $ast } - switch ($ast.GetType().Name) { - "Symbol" { return $env.get($ast) } - "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } - "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } - "HashMap" { - $hm = new-hashmap @() - foreach ($k in $ast.values.Keys) { - $hm.values[$k] = EVAL $ast.values[$k] $env - } - return $hm - } - default { return $ast } - } -} - -function EVAL($ast, $env) { - while ($true) { - #Write-Host "EVAL $(pr_str $ast)" - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - - $ast = (macroexpand $ast $env) - if (-not (list? $ast)) { - return (eval_ast $ast $env) - } - if (empty? $ast) { return $ast } - - $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) - switch -casesensitive ($a0.value) { - "def!" { - return $env.set($a1, (EVAL $a2 $env)) - } - "let*" { - $let_env = new-env $env - for ($i=0; $i -lt $a1.values.Count; $i+=2) { - $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) - } - $env = $let_env - $ast = $a2 # TCO - } - "quote" { - return $a1 - } - "quasiquoteexpand" { - return (quasiquote $a1) - } - "quasiquote" { - $ast = quasiquote $a1 - } - "defmacro!" { - $m = EVAL $a2 $env - $m.macro = $true - return $env.set($a1, $m) - } - "macroexpand" { - return (macroexpand $a1 $env) - } - "try*" { - try { - return EVAL $a1 $env - } catch { - if ($a2 -and ($a2.nth(0).value -ceq "catch*")) { - if ($_.Exception.GetType().Name -eq "MalException") { - $e = @($_.Exception.object) - } else { - $e = @($_.Exception.Message) - } - return (EVAL $a2.nth(2) (new-env $env @($a2.nth(1)) $e)) - } else { - throw - } - } - } - "do" { - if ($ast.values.Count -gt 2) { - $middle = new-list $ast.values[1..($ast.values.Count-2)] - $_ = eval_ast $middle $env - } - $ast = $ast.last() # TCO - } - "if" { - $cond = (EVAL $a1 $env) - if ($cond -eq $null -or - ($cond -is [Boolean] -and $cond -eq $false)) { - $ast = $ast.nth(3) # TCO - } else { - $ast = $a2 # TCO - } - } - "fn*" { - # Save EVAL into a variable that will get closed over - $feval = Get-Command EVAL - $fn = { - return (&$feval $a2 (new-env $env $a1.values $args)) - }.GetNewClosure() - return new-malfunc $a2 $a1.values $env $fn - } - default { - $el = (eval_ast $ast $env) - $f, $fargs = $el.first(), $el.rest().values - if (malfunc? $f) { - $env = (new-env $f.env $f.params $fargs) - $ast = $f.ast # TCO - } else { - return &$f @fargs - } - } - } - } -} - -# PRINT -function PRINT($exp) { - return pr_str $exp $true -} - -# REPL -$repl_env = new-env - -function REP([String] $str) { - return PRINT (EVAL (READ $str) $repl_env) -} - -# core.EXT: defined using PowerShell -foreach ($kv in $core_ns.GetEnumerator()) { - $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) -} -$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) -$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) - -# core.mal: defined using the language itself -$_ = REP('(def! *host-language* "powershell")') -$_ = REP('(def! not (fn* (a) (if a false true)))') -$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') -$_ = 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)))))))") - - -if ($args.Count -gt 0) { - $_ = REP('(load-file "' + $args[0] + '")') - exit 0 -} - -$_ = REP('(println (str "Mal [" *host-language* "]"))') -while ($true) { - Write-Host "user> " -NoNewline - $line = [Console]::ReadLine() - if ($line -eq $null) { - break - } - try { - Write-Host (REP($line)) - } catch { - if ($_.Exception.GetType().Name -eq "MalException") { - Write-Host "Exception: $(pr_str $_.Exception.object)" - } else { - Write-Host "Exception: $($_.Exception.Message)" - } - } -} +$ErrorActionPreference = "Stop" + +Import-Module $PSScriptRoot/types.psm1 +Import-Module $PSScriptRoot/reader.psm1 +Import-Module $PSScriptRoot/printer.psm1 +Import-Module $PSScriptRoot/env.psm1 +Import-Module $PSScriptRoot/core.psm1 + +# READ +function READ([String] $str) { + return read_str($str) +} + +# EVAL +function starts_with($lst, $sym) { + if ($lst.values.Count -ne 2) { return $false } + $a0 = $lst.nth(0) + return (symbol? $a0) -and ($a0.value -ceq $sym) +} +function qq_loop($elt, $acc) { + if ((list? $elt) -and (starts_with $elt "splice-unquote")) { + return (new-list @((new-symbol "concat"), $elt.nth(1), $acc)) + } else { + return (new-list @((new-symbol "cons"), (quasiquote $elt), $acc)) + } +} +function qq_foldr($xs) { + $acc = new-list @() + for ( $i = $xs.Count - 1; $i -ge 0; $i-- ) { + $acc = qq_loop $xs[$i] $acc + } + return $acc +} +function quasiquote($ast) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return (new-list @((new-symbol "quote"), $ast)) } + "HashMap" { return (new-list @((new-symbol "quote"), $ast)) } + "Vector" { return (new-list @((new-symbol "vec"), (qq_foldr $ast.values))) } + "List" { + if (starts_with $ast "unquote") { + return $ast.values[1] + } else { + return qq_foldr $ast.values + } + } + default { return $ast } + } +} + +function macro?($ast, $env) { + return (list? $ast) -and + (symbol? $ast.nth(0)) -and + $env.find($ast.nth(0)) -and + $env.get($ast.nth(0)).macro +} + +function macroexpand($ast, $env) { + while (macro? $ast $env) { + $mac = $env.get($ast.nth(0)).fn + $margs = $ast.rest().values + $ast = &$mac @margs + } + return $ast +} + +function eval_ast($ast, $env) { + if ($ast -eq $null) { return $ast } + switch ($ast.GetType().Name) { + "Symbol" { return $env.get($ast) } + "List" { return new-list ($ast.values | ForEach { EVAL $_ $env }) } + "Vector" { return new-vector ($ast.values | ForEach { EVAL $_ $env }) } + "HashMap" { + $hm = new-hashmap @() + foreach ($k in $ast.values.Keys) { + $hm.values[$k] = EVAL $ast.values[$k] $env + } + return $hm + } + default { return $ast } + } +} + +function EVAL($ast, $env) { + while ($true) { + #Write-Host "EVAL $(pr_str $ast)" + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + + $ast = (macroexpand $ast $env) + if (-not (list? $ast)) { + return (eval_ast $ast $env) + } + if (empty? $ast) { return $ast } + + $a0, $a1, $a2 = $ast.nth(0), $ast.nth(1), $ast.nth(2) + switch -casesensitive ($a0.value) { + "def!" { + return $env.set($a1, (EVAL $a2 $env)) + } + "let*" { + $let_env = new-env $env + for ($i=0; $i -lt $a1.values.Count; $i+=2) { + $_ = $let_env.set($a1.nth($i), (EVAL $a1.nth(($i+1)) $let_env)) + } + $env = $let_env + $ast = $a2 # TCO + } + "quote" { + return $a1 + } + "quasiquoteexpand" { + return (quasiquote $a1) + } + "quasiquote" { + $ast = quasiquote $a1 + } + "defmacro!" { + $m = EVAL $a2 $env + $m.macro = $true + return $env.set($a1, $m) + } + "macroexpand" { + return (macroexpand $a1 $env) + } + "try*" { + try { + return EVAL $a1 $env + } catch { + if ($a2 -and ($a2.nth(0).value -ceq "catch*")) { + if ($_.Exception.GetType().Name -eq "MalException") { + $e = @($_.Exception.object) + } else { + $e = @($_.Exception.Message) + } + return (EVAL $a2.nth(2) (new-env $env @($a2.nth(1)) $e)) + } else { + throw + } + } + } + "do" { + if ($ast.values.Count -gt 2) { + $middle = new-list $ast.values[1..($ast.values.Count-2)] + $_ = eval_ast $middle $env + } + $ast = $ast.last() # TCO + } + "if" { + $cond = (EVAL $a1 $env) + if ($cond -eq $null -or + ($cond -is [Boolean] -and $cond -eq $false)) { + $ast = $ast.nth(3) # TCO + } else { + $ast = $a2 # TCO + } + } + "fn*" { + # Save EVAL into a variable that will get closed over + $feval = Get-Command EVAL + $fn = { + return (&$feval $a2 (new-env $env $a1.values $args)) + }.GetNewClosure() + return new-malfunc $a2 $a1.values $env $fn + } + default { + $el = (eval_ast $ast $env) + $f, $fargs = $el.first(), $el.rest().values + if (malfunc? $f) { + $env = (new-env $f.env $f.params $fargs) + $ast = $f.ast # TCO + } else { + return &$f @fargs + } + } + } + } +} + +# PRINT +function PRINT($exp) { + return pr_str $exp $true +} + +# REPL +$repl_env = new-env + +function REP([String] $str) { + return PRINT (EVAL (READ $str) $repl_env) +} + +# core.EXT: defined using PowerShell +foreach ($kv in $core_ns.GetEnumerator()) { + $_ = $repl_env.set((new-symbol $kv.Key), $kv.Value) +} +$_ = $repl_env.set((new-symbol "eval"), { param($a); (EVAL $a $repl_env) }) +$_ = $repl_env.set((new-symbol "*ARGV*"), (new-list $args[1..$args.Count])) + +# core.mal: defined using the language itself +$_ = REP('(def! *host-language* "powershell")') +$_ = REP('(def! not (fn* (a) (if a false true)))') +$_ = REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') +$_ = 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)))))))") + + +if ($args.Count -gt 0) { + $_ = REP('(load-file "' + $args[0] + '")') + exit 0 +} + +$_ = REP('(println (str "Mal [" *host-language* "]"))') +while ($true) { + Write-Host "user> " -NoNewline + $line = [Console]::ReadLine() + if ($line -eq $null) { + break + } + try { + Write-Host (REP($line)) + } catch { + if ($_.Exception.GetType().Name -eq "MalException") { + Write-Host "Exception: $(pr_str $_.Exception.object)" + } else { + Write-Host "Exception: $($_.Exception.Message)" + } + } +} diff --git a/impls/powershell/types.psm1 b/impls/powershell/types.psm1 index 7eeaa37fc1..22e341595a 100644 --- a/impls/powershell/types.psm1 +++ b/impls/powershell/types.psm1 @@ -1,338 +1,338 @@ -# -# Exceptions -# -Class MalException : Exception { - [Object] $object - - MalException($obj) { - $this.object = $obj - } -} - -function mal_throw($obj) { - throw [MalException] $obj -} - -# -# Symbols -# - -Class Symbol { - [String] $value - - Symbol([String] $val) { - $this.value = $val - } - - copy() { $this } -} - -function new-symbol([String] $val) { - [Symbol]::new($val) -} - -function symbol?($obj) { - $obj -is [Symbol] -} - -# -# Strings -# - -function string?($obj) { - ($obj -is [String]) -and ($obj[0] -ne "$([char]0x29e)") -} - -# -# Keywords -# - -function new-keyword($obj) { - if (keyword? $obj) { - $obj - } else { - "$([char]0x29e)$obj" - } -} - -function keyword?($obj) { - ($obj -is [String]) -and ($obj[0] -eq "$([char]0x29e)") -} - - -# -# Lists -# - -Class List { - #[System.Collections.ArrayList] $values - [Object[]] $values - [Object] $meta - - List() { - $this.values = @() - #$this.values = New-Object System.Collections.ArrayList - } - - List([Object[]] $vals) { - #List([System.Collections.ArrayList] $vals) { - $this.values = $vals - } - - [List] copy() { - return [List]::new($this.values) - } - - [void] push([Object] $val) { - $this.values.Add($val) - } - - [Object] first() { - return $this.values[0] - } - - [List] rest() { - if ($this.values.Count -le 1) { - return [List]::new(@()) - } else { - return [List]::new($this.values[1..($this.values.Count)]) - } - } - - [Object] last() { - if ($this.values.Count -eq 0) { - return $null - } else { - return $this.values[$this.values.Count-1] - } - } - - [Object] nth([int64] $idx) { - return $this.values[$idx] - } -} - -function new-list([Object[]] $vals) { -#function new-list([System.Collections.ArrayList] $vals) { - if ($vals.Count -eq 0) { - return [List]::new() - } else { - return [List]::new($vals) - } -} - -function list?($obj) { - $obj -is [List] -and -not ($obj -is [Vector]) -} - - -# -# Vectors -# - -Class Vector : List { - Vector() { - $this.values = @() - #$this.values = New-Object System.Collections.ArrayList - } - - Vector([Object[]] $vals) { - #Vector([System.Collections.ArrayList] $vals) { - $this.values = $vals - } - - [Vector] copy() { - return [Vector]::new($this.values) - } - -} - -function new-vector([Object[]] $vals) { - if ($vals.Count -eq 0) { - return [Vector]::new() - } else { - return [Vector]::new($vals) - } -} - -function vector?($obj) { - $obj -is [Vector] -} - - -# -# HashMaps -# - -Class HashMap { - [Hashtable] $values - [Object] $meta - - HashMap() { - # Case-sensitive hashtable - $this.values = New-Object System.Collections.HashTable - } - - HashMap([Hashtable] $vals) { - $this.values = $vals - } - - [HashMap] copy() { - return [HashMap]::new($this.values.clone()) - } - -} - -function assoc_BANG($hm, $kvs) { - $ht = $hm.values - for ($i = 0; $i -lt $kvs.Count; $i+=2) { - $ht[$kvs[$i]] = $kvs[($i+1)] - } - return $hm -} - -function dissoc_BANG($hm, $ks) { - $ht = $hm.values - foreach ($k in $ks) { - $ht.Remove($k) - } - return $hm -} - - -function new-hashmap([Object[]] $vals) { - $hm = [HashMap]::new() - assoc_BANG $hm $vals -} - -function hashmap?($obj) { - $obj -is [HashMap] -} - -function keys($hm) { - return new-list ($hm.values.GetEnumerator() | ForEach { $_.Key }) -} - -function vals($hm) { - return new-list ($hm.values.GetEnumerator() | ForEach { $_.Value }) -} - - -# -# Atoms - -Class Atom { - [Object] $value - - Atom([Object] $val) { - $this.value = $val - } -} - -function new-atom([Object] $val) { - [Atom]::new($val) -} - -function atom?($obj) { - $obj -is [Atom] -} - - -# Functions - -Class MalFunc { - [Object] $ast - [Object[]] $params - [Object] $env - [scriptBlock] $fn - [Boolean] $macro - [Object] $meta - - MalFunc($ast, $params, $env, $fn, $macro, $meta){ - $this.ast = $ast - $this.params = $params - $this.env = $env - $this.fn = $fn - $this.macro = $macro - $this.meta = $meta - } - - [MalFunc] copy() { - return [MalFunc]::new($this.ast, $this.params, $this.env, $this.fn, - $this.macro, $this.meta) - } - -} - -function new-malfunc($ast, $params, $env, $fn, $macro, $meta) { - [MalFunc]::new($ast, $params, $env, $fn, $macro, $meta) -} - -function malfunc?($obj) { - $obj -is [MalFunc] -} - -function fn?($obj) { - $obj -is [System.Management.Automation.ScriptBlock] -} -# -# General functions -# -function equal?($a, $b) { - if ($a -eq $null -and $b -eq $null) { - return $true - } elseif ($a -eq $null -or $b -eq $null) { - return $false - } - $ta, $tb = $a.GetType().Name, $b.GetType().Name - if (-not (($ta -eq $tb) -or ((sequential?($a)) -and (sequential?($b))))) { - return $false - } - switch ($ta) { - { $_ -eq "List" -or $_ -eq "Vector" } { - if ($a.values.Count -ne $b.values.Count) { - return $false - } - for ($i = 0; $i -lt $a.value.Count; $i++) { - if (-not (equal? $a.values[$i] $b.values[$i])) { - return $false - } - } - return $true - } - "HashMap" { - $hta, $htb = $a.values, $b.values - $alen = ($hta.GetEnumerator | Measure-Object).Count - $blen = ($htb.GetEnumerator | Measure-Object).Count - if ($alen -ne $blen) { - return $false - } - foreach ($kv in $hta.GetEnumerator()) { - if (-not (equal? $kv.Value $htb[$kv.Key])) { - return $false - } - } - return $true - } - "Symbol" { - return $a.value -ceq $b.value - } - default { - return $a -ceq $b - } - } -} - - -# -# Sequence functions -# -function sequential?($obj) { - $obj -is [List] -} - -function empty?($obj) { - $obj.values.Count -eq 0 -} - - +# +# Exceptions +# +Class MalException : Exception { + [Object] $object + + MalException($obj) { + $this.object = $obj + } +} + +function mal_throw($obj) { + throw [MalException] $obj +} + +# +# Symbols +# + +Class Symbol { + [String] $value + + Symbol([String] $val) { + $this.value = $val + } + + copy() { $this } +} + +function new-symbol([String] $val) { + [Symbol]::new($val) +} + +function symbol?($obj) { + $obj -is [Symbol] +} + +# +# Strings +# + +function string?($obj) { + ($obj -is [String]) -and ($obj[0] -ne "$([char]0x29e)") +} + +# +# Keywords +# + +function new-keyword($obj) { + if (keyword? $obj) { + $obj + } else { + "$([char]0x29e)$obj" + } +} + +function keyword?($obj) { + ($obj -is [String]) -and ($obj[0] -eq "$([char]0x29e)") +} + + +# +# Lists +# + +Class List { + #[System.Collections.ArrayList] $values + [Object[]] $values + [Object] $meta + + List() { + $this.values = @() + #$this.values = New-Object System.Collections.ArrayList + } + + List([Object[]] $vals) { + #List([System.Collections.ArrayList] $vals) { + $this.values = $vals + } + + [List] copy() { + return [List]::new($this.values) + } + + [void] push([Object] $val) { + $this.values.Add($val) + } + + [Object] first() { + return $this.values[0] + } + + [List] rest() { + if ($this.values.Count -le 1) { + return [List]::new(@()) + } else { + return [List]::new($this.values[1..($this.values.Count)]) + } + } + + [Object] last() { + if ($this.values.Count -eq 0) { + return $null + } else { + return $this.values[$this.values.Count-1] + } + } + + [Object] nth([int64] $idx) { + return $this.values[$idx] + } +} + +function new-list([Object[]] $vals) { +#function new-list([System.Collections.ArrayList] $vals) { + if ($vals.Count -eq 0) { + return [List]::new() + } else { + return [List]::new($vals) + } +} + +function list?($obj) { + $obj -is [List] -and -not ($obj -is [Vector]) +} + + +# +# Vectors +# + +Class Vector : List { + Vector() { + $this.values = @() + #$this.values = New-Object System.Collections.ArrayList + } + + Vector([Object[]] $vals) { + #Vector([System.Collections.ArrayList] $vals) { + $this.values = $vals + } + + [Vector] copy() { + return [Vector]::new($this.values) + } + +} + +function new-vector([Object[]] $vals) { + if ($vals.Count -eq 0) { + return [Vector]::new() + } else { + return [Vector]::new($vals) + } +} + +function vector?($obj) { + $obj -is [Vector] +} + + +# +# HashMaps +# + +Class HashMap { + [Hashtable] $values + [Object] $meta + + HashMap() { + # Case-sensitive hashtable + $this.values = New-Object System.Collections.HashTable + } + + HashMap([Hashtable] $vals) { + $this.values = $vals + } + + [HashMap] copy() { + return [HashMap]::new($this.values.clone()) + } + +} + +function assoc_BANG($hm, $kvs) { + $ht = $hm.values + for ($i = 0; $i -lt $kvs.Count; $i+=2) { + $ht[$kvs[$i]] = $kvs[($i+1)] + } + return $hm +} + +function dissoc_BANG($hm, $ks) { + $ht = $hm.values + foreach ($k in $ks) { + $ht.Remove($k) + } + return $hm +} + + +function new-hashmap([Object[]] $vals) { + $hm = [HashMap]::new() + assoc_BANG $hm $vals +} + +function hashmap?($obj) { + $obj -is [HashMap] +} + +function keys($hm) { + return new-list ($hm.values.GetEnumerator() | ForEach { $_.Key }) +} + +function vals($hm) { + return new-list ($hm.values.GetEnumerator() | ForEach { $_.Value }) +} + + +# +# Atoms + +Class Atom { + [Object] $value + + Atom([Object] $val) { + $this.value = $val + } +} + +function new-atom([Object] $val) { + [Atom]::new($val) +} + +function atom?($obj) { + $obj -is [Atom] +} + + +# Functions + +Class MalFunc { + [Object] $ast + [Object[]] $params + [Object] $env + [scriptBlock] $fn + [Boolean] $macro + [Object] $meta + + MalFunc($ast, $params, $env, $fn, $macro, $meta){ + $this.ast = $ast + $this.params = $params + $this.env = $env + $this.fn = $fn + $this.macro = $macro + $this.meta = $meta + } + + [MalFunc] copy() { + return [MalFunc]::new($this.ast, $this.params, $this.env, $this.fn, + $this.macro, $this.meta) + } + +} + +function new-malfunc($ast, $params, $env, $fn, $macro, $meta) { + [MalFunc]::new($ast, $params, $env, $fn, $macro, $meta) +} + +function malfunc?($obj) { + $obj -is [MalFunc] +} + +function fn?($obj) { + $obj -is [System.Management.Automation.ScriptBlock] +} +# +# General functions +# +function equal?($a, $b) { + if ($a -eq $null -and $b -eq $null) { + return $true + } elseif ($a -eq $null -or $b -eq $null) { + return $false + } + $ta, $tb = $a.GetType().Name, $b.GetType().Name + if (-not (($ta -eq $tb) -or ((sequential?($a)) -and (sequential?($b))))) { + return $false + } + switch ($ta) { + { $_ -eq "List" -or $_ -eq "Vector" } { + if ($a.values.Count -ne $b.values.Count) { + return $false + } + for ($i = 0; $i -lt $a.value.Count; $i++) { + if (-not (equal? $a.values[$i] $b.values[$i])) { + return $false + } + } + return $true + } + "HashMap" { + $hta, $htb = $a.values, $b.values + $alen = ($hta.GetEnumerator | Measure-Object).Count + $blen = ($htb.GetEnumerator | Measure-Object).Count + if ($alen -ne $blen) { + return $false + } + foreach ($kv in $hta.GetEnumerator()) { + if (-not (equal? $kv.Value $htb[$kv.Key])) { + return $false + } + } + return $true + } + "Symbol" { + return $a.value -ceq $b.value + } + default { + return $a -ceq $b + } + } +} + + +# +# Sequence functions +# +function sequential?($obj) { + $obj -is [List] +} + +function empty?($obj) { + $obj.values.Count -eq 0 +} + + diff --git a/impls/prolog/Dockerfile b/impls/prolog/Dockerfile index ead962ed50..9aec386545 100644 --- a/impls/prolog/Dockerfile +++ b/impls/prolog/Dockerfile @@ -1,21 +1,21 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install swi-prolog-nox +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install swi-prolog-nox diff --git a/impls/prolog/Makefile b/impls/prolog/Makefile index 7f29186f04..2bb4dfbd7a 100644 --- a/impls/prolog/Makefile +++ b/impls/prolog/Makefile @@ -1,2 +1,2 @@ -# Stub Makefile to make Travis test mode happy. -all clean: +# Stub Makefile to make Travis test mode happy. +all clean: diff --git a/impls/prolog/core.pl b/impls/prolog/core.pl index 34cf66aa6a..e15f47a0ce 100644 --- a/impls/prolog/core.pl +++ b/impls/prolog/core.pl @@ -1,264 +1,264 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -wrap_failure(Goal, Args, Res) :- - check(call(Goal,Args, Res), - "~a: wrong arguments: ~L", [Goal, Args]). - -bool(Goal, true) :- call(Goal), !. -bool(_, false). - -'nil?'([X], R) :- bool(=(nil,X), R). - -'false?'([X], R) :- bool(=(false, X), R). - -'true?'([X], R) :- bool(=(true, X), R). - -% Numbers - -'number?'([X], R) :- bool(integer(X), R). - -add([X, Y], R) :- integer(X), integer(Y), R is X + Y. - -sub([X, Y], R) :- integer(X), integer(Y), R is X - Y. - -mul([X, Y], R) :- integer(X), integer(Y), R is X * Y. - -div([X, Y], R) :- integer(X), integer(Y), Y \= 0, R is X / Y. - -'<='([X, Y], R) :- integer(X), integer(Y), bool(=<(X, Y), R). - -ge( [X, Y], R) :- integer(X), integer(Y), bool(>=(X, Y), R). - -lt( [X, Y], R) :- integer(X), integer(Y), bool(<(X, Y), R). - -gt( [X, Y], R) :- integer(X), integer(Y), bool(>(X, Y), R). - -% Symbols - -'symbol?'([false], false). -'symbol?'([nil], false). -'symbol?'([true], false). -'symbol?'([X], R) :- bool(atom(X), R). - -symbol([X], R) :- string(X), atom_string(R, X). - -% Keywords - -'keyword?'([X], R) :- bool(=(X, mal_kwd(_)), R). - -keyword([X], mal_kwd(X)) :- string(X). -keyword([R], R) :- R = mal_kwd(_). - -% Sequences - -'list?'([X], R) :- bool(list(_, X), R). - -'vector?'([X], R) :- bool(vector(_, X), R). - -'sequential?'([X], R) :- bool(unbox_seq(X, _), R). - -'empty?'([X], R) :- bool(unbox_seq(X, []), R). - -count([X], R) :- unbox_seq(X, S), !, length(S, R). -count([nil], 0). - -vec([X], R) :- unbox_seq(X, S), vector(S, R). - -cons([X, Y], R) :- unbox_seq(Y, Ys), list([X | Ys], R). - -concat(Xs, Z) :- maplist(unbox_seq, Xs, Ys), append(Ys, Zs), list(Zs, Z). - -nth([Sequence, Index], Element) :- - unbox_seq(Sequence, Xs), - check(nth0(Index, Xs, Element), - "nth: index ~d out of bounds of ~F", [Index, Sequence]). - -first([X], Y) :- unbox_seq(X, Xs), !, - (Xs = [Y | _] -> true ; Y = nil). -first([nil], nil). - -rest([X], R) :- unbox_seq(X, Xs), !, - (Xs = [_ | Rs] -> true ; Rs = []), - list(Rs, R). -rest([nil], R) :- list([], R). - -map([Fn, Seq], R) :- - unbox_seq(Seq, Xs), - mal_fn(Goal, Fn), - maplist(enlist_apply(Goal), Xs, Rs), list(Rs, R). - -enlist_apply(Goal, X, R) :- call(Goal, [X], R). - -conj([Vector | Ys], R) :- vector(Xs, Vector), !, - append(Xs, Ys, Zs), - vector(Zs, R). -conj([List | Ys], R) :- list(Xs, List), - foldl(cons, Ys, Xs, Zs), list(Zs, R). - -cons(X, Xs, [X | Xs]). - -seq([X], nil) :- unbox_seq(X, []). -seq([X], X) :- list(_, X). -seq([X], R) :- vector(Xs, X), !, list(Xs, R). -seq([""], nil). -seq([S], R) :- string(S), !, - string_chars(S, Chars), - maplist(atom_string, Chars, Strings), - list(Strings, R). -seq([nil], nil). - -% Maps (there is little not much we can do out of types). - -'map?'([X], R) :- bool(is_map(X), R). - -get([Map, Key], R) :- get(Map, Key, R). -get([_, _], nil). - -'contains?'([Map, Key], R) :- bool(get(Map, Key, _), R). - -dissoc([Map | Keys], Res) :- foldl(dissoc, Keys, Map, Res). - -% Atoms - -'atom?'([X], R) :- bool(mal_atom(_, X), R). - -atom([A], R) :- mal_atom(A, R). - -deref([A], R) :- mal_atom(R, A). - -'reset!'([A, R], R) :- mal_atom(_, A), set_mal_atom_value(A, R). - -'swap!'([Atom, Function | Args], R) :- - mal_atom(Old, Atom), - mal_fn(Goal, Function), - call(Goal, [Old | Args], R), - set_mal_atom_value(Atom, R). - -apply([Fn | Xs], R) :- - flatten_last(Xs, Args), - mal_fn(Goal, Fn), - call(Goal, Args, R). - -flatten_last([X], Xs) :- unbox_seq(X, Xs). -flatten_last([X | Xs], [X | Ys]) :- flatten_last(Xs, Ys). - -% Strings - -'string?'([X], R) :- bool(string(X), R). - -'pr-str'(Args, R) :- with_output_to(string(R), print_list(t, " ", Args)). - -str( Args, R) :- with_output_to(string(R), print_list(f, "", Args)). - -prn( Args, nil) :- print_list(t, " ", Args), nl. - -println( Args, nil) :- print_list(f, " ", Args), nl. - -'read-string'([S], R) :- string(S), read_str(S, R). - -slurp([Path], R) :- - string(Path), - (read_file_to_string(Path, R, []) -> true ; R = nil). - -readline([Prompt], R) :- - string(Prompt), - write(Prompt), - read_line_to_string(current_input, R), - (R = end_of_file -> R = nil ; true). - -throw([X], nil) :- throw(mal_error(X)). - -'time-ms'([], Ms) :- get_time(S), Ms is round(1_000*S). - -eq([X, Y], R) :- bool(mal_equal(X, Y), R). - -'fn?'([X], R) :- bool(mal_fn(_, X), R). - -'macro?'([X], R) :- bool(mal_macro(_, X), R). - -'prolog-asserta'([String], nil) :- - string(String), - catch((read_term_from_atom(String, Term, []), - asserta(Term)), - Error, - throwf("prolog-asserta: ~w", [Error])). - -'prolog-call'([String], Res) :- - string(String), - catch((read_term_from_atom(String, Term, []), - call(Term, Res)), - Error, - throwf("prolog-call: ~w", [Error])), - check(valid_mal(Res), "prolog-call: invalid result: ~w", [Res]). - -core_ns([ - % naming exceptions - '+', add, - '-', sub, - '*', mul, - '/', div, - '=', eq, - '<', lt, - '>=', ge, - '>', gt, - % step 4 - '<=', '<=', - prn, prn, - list, list, - 'list?', 'list?', - 'empty?', 'empty?', - count, count, - 'pr-str', 'pr-str', - str, str, - println, println, - % step 6 - 'read-string', 'read-string', - slurp, slurp, - atom, atom, - 'atom?', 'atom?', - deref, deref, - 'reset!', 'reset!', - 'swap!', 'swap!', - % step 7 - cons, cons, - concat, concat, - vec, vec, - % step 8 - nth, nth, - first, first, - rest, rest, - % step 9 - throw, throw, - apply, apply, - map, map, - 'nil?', 'nil?', - 'true?', 'true?', - 'false?', 'false?', - 'symbol?', 'symbol?', - symbol, symbol, - keyword, keyword, - 'keyword?', 'keyword?', - vector, vector, - 'vector?', 'vector?', - 'sequential?', 'sequential?', - 'hash-map', 'hash-map', - 'map?', 'map?', - assoc, assoc, - dissoc, dissoc, - get, get, - 'contains?', 'contains?', - keys, keys, - vals, vals, - % step A - readline, readline, - meta, meta, - 'with-meta', 'with-meta', - 'time-ms', 'time-ms', - conj, conj, - 'string?', 'string?', - 'number?', 'number?', - 'fn?', 'fn?', - 'macro?', 'macro?', - seq, seq, - 'prolog-asserta', 'prolog-asserta', - 'prolog-call', 'prolog-call']). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +wrap_failure(Goal, Args, Res) :- + check(call(Goal,Args, Res), + "~a: wrong arguments: ~L", [Goal, Args]). + +bool(Goal, true) :- call(Goal), !. +bool(_, false). + +'nil?'([X], R) :- bool(=(nil,X), R). + +'false?'([X], R) :- bool(=(false, X), R). + +'true?'([X], R) :- bool(=(true, X), R). + +% Numbers + +'number?'([X], R) :- bool(integer(X), R). + +add([X, Y], R) :- integer(X), integer(Y), R is X + Y. + +sub([X, Y], R) :- integer(X), integer(Y), R is X - Y. + +mul([X, Y], R) :- integer(X), integer(Y), R is X * Y. + +div([X, Y], R) :- integer(X), integer(Y), Y \= 0, R is X / Y. + +'<='([X, Y], R) :- integer(X), integer(Y), bool(=<(X, Y), R). + +ge( [X, Y], R) :- integer(X), integer(Y), bool(>=(X, Y), R). + +lt( [X, Y], R) :- integer(X), integer(Y), bool(<(X, Y), R). + +gt( [X, Y], R) :- integer(X), integer(Y), bool(>(X, Y), R). + +% Symbols + +'symbol?'([false], false). +'symbol?'([nil], false). +'symbol?'([true], false). +'symbol?'([X], R) :- bool(atom(X), R). + +symbol([X], R) :- string(X), atom_string(R, X). + +% Keywords + +'keyword?'([X], R) :- bool(=(X, mal_kwd(_)), R). + +keyword([X], mal_kwd(X)) :- string(X). +keyword([R], R) :- R = mal_kwd(_). + +% Sequences + +'list?'([X], R) :- bool(list(_, X), R). + +'vector?'([X], R) :- bool(vector(_, X), R). + +'sequential?'([X], R) :- bool(unbox_seq(X, _), R). + +'empty?'([X], R) :- bool(unbox_seq(X, []), R). + +count([X], R) :- unbox_seq(X, S), !, length(S, R). +count([nil], 0). + +vec([X], R) :- unbox_seq(X, S), vector(S, R). + +cons([X, Y], R) :- unbox_seq(Y, Ys), list([X | Ys], R). + +concat(Xs, Z) :- maplist(unbox_seq, Xs, Ys), append(Ys, Zs), list(Zs, Z). + +nth([Sequence, Index], Element) :- + unbox_seq(Sequence, Xs), + check(nth0(Index, Xs, Element), + "nth: index ~d out of bounds of ~F", [Index, Sequence]). + +first([X], Y) :- unbox_seq(X, Xs), !, + (Xs = [Y | _] -> true ; Y = nil). +first([nil], nil). + +rest([X], R) :- unbox_seq(X, Xs), !, + (Xs = [_ | Rs] -> true ; Rs = []), + list(Rs, R). +rest([nil], R) :- list([], R). + +map([Fn, Seq], R) :- + unbox_seq(Seq, Xs), + mal_fn(Goal, Fn), + maplist(enlist_apply(Goal), Xs, Rs), list(Rs, R). + +enlist_apply(Goal, X, R) :- call(Goal, [X], R). + +conj([Vector | Ys], R) :- vector(Xs, Vector), !, + append(Xs, Ys, Zs), + vector(Zs, R). +conj([List | Ys], R) :- list(Xs, List), + foldl(cons, Ys, Xs, Zs), list(Zs, R). + +cons(X, Xs, [X | Xs]). + +seq([X], nil) :- unbox_seq(X, []). +seq([X], X) :- list(_, X). +seq([X], R) :- vector(Xs, X), !, list(Xs, R). +seq([""], nil). +seq([S], R) :- string(S), !, + string_chars(S, Chars), + maplist(atom_string, Chars, Strings), + list(Strings, R). +seq([nil], nil). + +% Maps (there is little not much we can do out of types). + +'map?'([X], R) :- bool(is_map(X), R). + +get([Map, Key], R) :- get(Map, Key, R). +get([_, _], nil). + +'contains?'([Map, Key], R) :- bool(get(Map, Key, _), R). + +dissoc([Map | Keys], Res) :- foldl(dissoc, Keys, Map, Res). + +% Atoms + +'atom?'([X], R) :- bool(mal_atom(_, X), R). + +atom([A], R) :- mal_atom(A, R). + +deref([A], R) :- mal_atom(R, A). + +'reset!'([A, R], R) :- mal_atom(_, A), set_mal_atom_value(A, R). + +'swap!'([Atom, Function | Args], R) :- + mal_atom(Old, Atom), + mal_fn(Goal, Function), + call(Goal, [Old | Args], R), + set_mal_atom_value(Atom, R). + +apply([Fn | Xs], R) :- + flatten_last(Xs, Args), + mal_fn(Goal, Fn), + call(Goal, Args, R). + +flatten_last([X], Xs) :- unbox_seq(X, Xs). +flatten_last([X | Xs], [X | Ys]) :- flatten_last(Xs, Ys). + +% Strings + +'string?'([X], R) :- bool(string(X), R). + +'pr-str'(Args, R) :- with_output_to(string(R), print_list(t, " ", Args)). + +str( Args, R) :- with_output_to(string(R), print_list(f, "", Args)). + +prn( Args, nil) :- print_list(t, " ", Args), nl. + +println( Args, nil) :- print_list(f, " ", Args), nl. + +'read-string'([S], R) :- string(S), read_str(S, R). + +slurp([Path], R) :- + string(Path), + (read_file_to_string(Path, R, []) -> true ; R = nil). + +readline([Prompt], R) :- + string(Prompt), + write(Prompt), + read_line_to_string(current_input, R), + (R = end_of_file -> R = nil ; true). + +throw([X], nil) :- throw(mal_error(X)). + +'time-ms'([], Ms) :- get_time(S), Ms is round(1_000*S). + +eq([X, Y], R) :- bool(mal_equal(X, Y), R). + +'fn?'([X], R) :- bool(mal_fn(_, X), R). + +'macro?'([X], R) :- bool(mal_macro(_, X), R). + +'prolog-asserta'([String], nil) :- + string(String), + catch((read_term_from_atom(String, Term, []), + asserta(Term)), + Error, + throwf("prolog-asserta: ~w", [Error])). + +'prolog-call'([String], Res) :- + string(String), + catch((read_term_from_atom(String, Term, []), + call(Term, Res)), + Error, + throwf("prolog-call: ~w", [Error])), + check(valid_mal(Res), "prolog-call: invalid result: ~w", [Res]). + +core_ns([ + % naming exceptions + '+', add, + '-', sub, + '*', mul, + '/', div, + '=', eq, + '<', lt, + '>=', ge, + '>', gt, + % step 4 + '<=', '<=', + prn, prn, + list, list, + 'list?', 'list?', + 'empty?', 'empty?', + count, count, + 'pr-str', 'pr-str', + str, str, + println, println, + % step 6 + 'read-string', 'read-string', + slurp, slurp, + atom, atom, + 'atom?', 'atom?', + deref, deref, + 'reset!', 'reset!', + 'swap!', 'swap!', + % step 7 + cons, cons, + concat, concat, + vec, vec, + % step 8 + nth, nth, + first, first, + rest, rest, + % step 9 + throw, throw, + apply, apply, + map, map, + 'nil?', 'nil?', + 'true?', 'true?', + 'false?', 'false?', + 'symbol?', 'symbol?', + symbol, symbol, + keyword, keyword, + 'keyword?', 'keyword?', + vector, vector, + 'vector?', 'vector?', + 'sequential?', 'sequential?', + 'hash-map', 'hash-map', + 'map?', 'map?', + assoc, assoc, + dissoc, dissoc, + get, get, + 'contains?', 'contains?', + keys, keys, + vals, vals, + % step A + readline, readline, + meta, meta, + 'with-meta', 'with-meta', + 'time-ms', 'time-ms', + conj, conj, + 'string?', 'string?', + 'number?', 'number?', + 'fn?', 'fn?', + 'macro?', 'macro?', + seq, seq, + 'prolog-asserta', 'prolog-asserta', + 'prolog-call', 'prolog-call']). diff --git a/impls/prolog/env.pl b/impls/prolog/env.pl index c12102ad4b..50d6eb6ff8 100644 --- a/impls/prolog/env.pl +++ b/impls/prolog/env.pl @@ -1,31 +1,31 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- format_predicate('V', env_format(_Arg,_Env)). - -env(mal_env(Assoc, t)) :- empty_assoc(Assoc). - -env(Outer, mal_env(Assoc, Outer)) :- empty_assoc(Assoc). - -env_get(mal_env(Assoc, _), Key, Value) :- get_assoc(Key, Assoc, Value). -env_get(mal_env(_, Outer), Key, Value) :- env_get(Outer, Key, Value). - -env_set(Env, Key, Value) :- - Env = mal_env(Old, _), - put_assoc(Key, Old, Value, New), - setarg(1, Env, New). - -env_format(_Arg, mal_env(Assoc, _Outer)) :- - assoc_to_list(Assoc, Pairs), - maplist(env_format_pair, Pairs). - -env_format_pair(K - V) :- format(" ~a:~F", [K, V]). - -% Does *not* check that the keys are symbols. This is done once when -% the fn* structure is created. -env_bind(_Env, [], []). -env_bind(Env, ['&', K], Vs) :- !, - list(Vs, List), - env_set(Env, K, List). -env_bind(Env, [K | Ks], [V | Vs]) :- - env_set(Env, K, V), - env_bind(Env, Ks, Vs). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- format_predicate('V', env_format(_Arg,_Env)). + +env(mal_env(Assoc, t)) :- empty_assoc(Assoc). + +env(Outer, mal_env(Assoc, Outer)) :- empty_assoc(Assoc). + +env_get(mal_env(Assoc, _), Key, Value) :- get_assoc(Key, Assoc, Value). +env_get(mal_env(_, Outer), Key, Value) :- env_get(Outer, Key, Value). + +env_set(Env, Key, Value) :- + Env = mal_env(Old, _), + put_assoc(Key, Old, Value, New), + setarg(1, Env, New). + +env_format(_Arg, mal_env(Assoc, _Outer)) :- + assoc_to_list(Assoc, Pairs), + maplist(env_format_pair, Pairs). + +env_format_pair(K - V) :- format(" ~a:~F", [K, V]). + +% Does *not* check that the keys are symbols. This is done once when +% the fn* structure is created. +env_bind(_Env, [], []). +env_bind(Env, ['&', K], Vs) :- !, + list(Vs, List), + env_set(Env, K, List). +env_bind(Env, [K | Ks], [V | Vs]) :- + env_set(Env, K, V), + env_bind(Env, Ks, Vs). diff --git a/impls/prolog/printer.pl b/impls/prolog/printer.pl index cc57e34327..52c4a69212 100644 --- a/impls/prolog/printer.pl +++ b/impls/prolog/printer.pl @@ -1,62 +1,62 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- format_predicate('F', format_mal_form(_Arg,_Form)). -:- format_predicate('L', format_mal_list(_Arg,_Forms)). -format_mal_list(_Arg, Forms) :- print_list(t, " ", Forms). -format_mal_form(_Arg, Form) :- pr_str(t, Form). - -pr_str(t, String) :- string(String), !, - write("\""), - string_codes(String, Codes), - maplist(pr_str_escape, Codes), - write("\""). - -pr_str(_, Atomic) :- atomic(Atomic), !, - % number, symbol, nil, true, false, unreadable string. - write(Atomic). - -pr_str(_, mal_kwd(Keyword)) :- !, - put_char(:), - write(Keyword). - -pr_str(Readably, Vector) :- vector(Elements, Vector), !, - write("["), - print_list(Readably, " ", Elements), - write("]"). - -pr_str(Readably, List) :- list(Elements, List), !, - write("("), - print_list(Readably, " ", Elements), - write(")"). - -pr_str(Readably, Map) :- map_to_key_value_list(Map, Key_Value_List), !, - write("{"), - print_list(Readably, " ", Key_Value_List), - write("}"). - -pr_str(_, Fn) :- mal_fn(_Goal, Fn), !, write(""). - -pr_str(_, Macro) :- mal_macro(_Fn, Macro), !, - write(""). - -pr_str(_, Atom) :- mal_atom(Value, Atom), !, - format("(atom ~F)", [Value]). - -pr_str(_, Invalid) :- - format(string(Msg), "pr_str detected an invalid form: ~w\n", [Invalid]), - print_message(warning, Msg), - abort. - -pr_str_escape(0'\n) :- write("\\n"). -pr_str_escape(0'") :- write("\\\""). -pr_str_escape(0'\\) :- write("\\\\"). -pr_str_escape(C) :- put_code(C). - -print_list(_, _, []). -print_list(Readably, Separator, [X | Xs]) :- - pr_str(Readably, X), - maplist(print_list_append(Readably, Separator), Xs). - -print_list_append(Readably, Separator, Element) :- - write(Separator), - pr_str(Readably, Element). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- format_predicate('F', format_mal_form(_Arg,_Form)). +:- format_predicate('L', format_mal_list(_Arg,_Forms)). +format_mal_list(_Arg, Forms) :- print_list(t, " ", Forms). +format_mal_form(_Arg, Form) :- pr_str(t, Form). + +pr_str(t, String) :- string(String), !, + write("\""), + string_codes(String, Codes), + maplist(pr_str_escape, Codes), + write("\""). + +pr_str(_, Atomic) :- atomic(Atomic), !, + % number, symbol, nil, true, false, unreadable string. + write(Atomic). + +pr_str(_, mal_kwd(Keyword)) :- !, + put_char(:), + write(Keyword). + +pr_str(Readably, Vector) :- vector(Elements, Vector), !, + write("["), + print_list(Readably, " ", Elements), + write("]"). + +pr_str(Readably, List) :- list(Elements, List), !, + write("("), + print_list(Readably, " ", Elements), + write(")"). + +pr_str(Readably, Map) :- map_to_key_value_list(Map, Key_Value_List), !, + write("{"), + print_list(Readably, " ", Key_Value_List), + write("}"). + +pr_str(_, Fn) :- mal_fn(_Goal, Fn), !, write(""). + +pr_str(_, Macro) :- mal_macro(_Fn, Macro), !, + write(""). + +pr_str(_, Atom) :- mal_atom(Value, Atom), !, + format("(atom ~F)", [Value]). + +pr_str(_, Invalid) :- + format(string(Msg), "pr_str detected an invalid form: ~w\n", [Invalid]), + print_message(warning, Msg), + abort. + +pr_str_escape(0'\n) :- write("\\n"). +pr_str_escape(0'") :- write("\\\""). +pr_str_escape(0'\\) :- write("\\\\"). +pr_str_escape(C) :- put_code(C). + +print_list(_, _, []). +print_list(Readably, Separator, [X | Xs]) :- + pr_str(Readably, X), + maplist(print_list_append(Readably, Separator), Xs). + +print_list_append(Readably, Separator, Element) :- + write(Separator), + pr_str(Readably, Element). diff --git a/impls/prolog/reader.pl b/impls/prolog/reader.pl index 515f67c69d..1e08f56c92 100644 --- a/impls/prolog/reader.pl +++ b/impls/prolog/reader.pl @@ -1,65 +1,65 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- use_module(library(dcg/basics)). - -read_str(String, Form) :- - string_codes(String, Codes), - check(phrase(read_form(Form), Codes, _Rest), - "unbalanced expression: '~s'", [String]). - -read_form(Res) --> zero_or_more_separators, ( - `(`, !, read_list(`)`, Forms), { list(Forms, Res) } - | `[`, !, read_list(`]`, Forms), { vector(Forms, Res) } - | `{`, !, read_list(`}`, Forms), { 'hash-map'(Forms, Res) } - | `\``, !, read_form(Form), { list([quasiquote, Form], Res) } - | `\'`, !, read_form(Form), { list([quote, Form], Res) } - | `^`, !, read_form(Meta), read_form(Data), { list(['with-meta', Data, Meta], Res) } - | `:`, !, at_least_one_symcode(Codes), { string_codes(String, Codes), - Res = mal_kwd(String) } - | `\"`, !, until_quotes(Codes), { string_codes(Res, Codes) } - | `@`, !, read_form(Form), { list([deref, Form], Res) } - | `~@`, !, read_form(Form), { list(['splice-unquote', Form], Res) } - | `~`, !, read_form(Form), { list([unquote, Form], Res) } - | integer(Res) - | at_least_one_symcode(Cs), { atom_codes(Res, Cs) }). - -read_list(Closing, [Form | Forms]) --> read_form(Form), !, read_list(Closing, Forms). -read_list(Closing, []) --> zero_or_more_separators, Closing. - -zero_or_more_separators --> separator, !, zero_or_more_separators - | []. - -separator --> [C], { sepcode(C) }, !. -separator --> `;`, string_without(`\n`, _Comment). - -at_least_one_symcode([C | Cs]) --> [C], { symcode(C) }, zero_or_more_symcodes(Cs). - -until_quotes([]) --> [0'"]. -until_quotes([0'\n | Cs]) --> `\\n`, !, until_quotes(Cs). -until_quotes([0'" | Cs]) --> `\\\"`, !, until_quotes(Cs). -until_quotes([0'\\ | Cs]) --> `\\\\`, !, until_quotes(Cs). -until_quotes([C | Cs]) --> [C], until_quotes(Cs). - -zero_or_more_symcodes(Cs) --> at_least_one_symcode(Cs), !. -zero_or_more_symcodes([]) --> []. - -sepcode(0',). -sepcode(0' ). -sepcode(0'\n). - -symcode(C) :- code_type(C, alnum). -symcode(0'!). -symcode(0'#). -symcode(0'$). -symcode(0'%). -symcode(0'&). -symcode(0'*). -symcode(0'+). -symcode(0'-). -symcode(0'/). -symcode(0'<). -symcode(0'=). -symcode(0'>). -symcode(0'?). -symcode(0'_). -symcode(0'|). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- use_module(library(dcg/basics)). + +read_str(String, Form) :- + string_codes(String, Codes), + check(phrase(read_form(Form), Codes, _Rest), + "unbalanced expression: '~s'", [String]). + +read_form(Res) --> zero_or_more_separators, ( + `(`, !, read_list(`)`, Forms), { list(Forms, Res) } + | `[`, !, read_list(`]`, Forms), { vector(Forms, Res) } + | `{`, !, read_list(`}`, Forms), { 'hash-map'(Forms, Res) } + | `\``, !, read_form(Form), { list([quasiquote, Form], Res) } + | `\'`, !, read_form(Form), { list([quote, Form], Res) } + | `^`, !, read_form(Meta), read_form(Data), { list(['with-meta', Data, Meta], Res) } + | `:`, !, at_least_one_symcode(Codes), { string_codes(String, Codes), + Res = mal_kwd(String) } + | `\"`, !, until_quotes(Codes), { string_codes(Res, Codes) } + | `@`, !, read_form(Form), { list([deref, Form], Res) } + | `~@`, !, read_form(Form), { list(['splice-unquote', Form], Res) } + | `~`, !, read_form(Form), { list([unquote, Form], Res) } + | integer(Res) + | at_least_one_symcode(Cs), { atom_codes(Res, Cs) }). + +read_list(Closing, [Form | Forms]) --> read_form(Form), !, read_list(Closing, Forms). +read_list(Closing, []) --> zero_or_more_separators, Closing. + +zero_or_more_separators --> separator, !, zero_or_more_separators + | []. + +separator --> [C], { sepcode(C) }, !. +separator --> `;`, string_without(`\n`, _Comment). + +at_least_one_symcode([C | Cs]) --> [C], { symcode(C) }, zero_or_more_symcodes(Cs). + +until_quotes([]) --> [0'"]. +until_quotes([0'\n | Cs]) --> `\\n`, !, until_quotes(Cs). +until_quotes([0'" | Cs]) --> `\\\"`, !, until_quotes(Cs). +until_quotes([0'\\ | Cs]) --> `\\\\`, !, until_quotes(Cs). +until_quotes([C | Cs]) --> [C], until_quotes(Cs). + +zero_or_more_symcodes(Cs) --> at_least_one_symcode(Cs), !. +zero_or_more_symcodes([]) --> []. + +sepcode(0',). +sepcode(0' ). +sepcode(0'\n). + +symcode(C) :- code_type(C, alnum). +symcode(0'!). +symcode(0'#). +symcode(0'$). +symcode(0'%). +symcode(0'&). +symcode(0'*). +symcode(0'+). +symcode(0'-). +symcode(0'/). +symcode(0'<). +symcode(0'=). +symcode(0'>). +symcode(0'?). +symcode(0'_). +symcode(0'|). diff --git a/impls/prolog/run b/impls/prolog/run index c71709be92..cd30284027 100755 --- a/impls/prolog/run +++ b/impls/prolog/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec swipl $(dirname $0)/${STEP:-stepA_mal}.pl "${@}" +#!/bin/bash +exec swipl $(dirname $0)/${STEP:-stepA_mal}.pl "${@}" diff --git a/impls/prolog/step0_repl.pl b/impls/prolog/step0_repl.pl index c05cb1ced9..ca6c5ea35d 100644 --- a/impls/prolog/step0_repl.pl +++ b/impls/prolog/step0_repl.pl @@ -1,41 +1,41 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -% Read - -mal_read(Line) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true). % fails for duplicate lines - -% Eval - -eval(Ast, Ast). - -% Print - -print(Ast) :- writeln(Ast). - -% REP - -rep :- - mal_read(Ast), - eval(Ast, Evaluated), - print(Evaluated). - -% Main program - -repl :- - rep, - repl. - -main(_Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - catch(repl, exit_repl, nl), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +% Read + +mal_read(Line) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true). % fails for duplicate lines + +% Eval + +eval(Ast, Ast). + +% Print + +print(Ast) :- writeln(Ast). + +% REP + +rep :- + mal_read(Ast), + eval(Ast, Evaluated), + print(Evaluated). + +% Main program + +repl :- + rep, + repl. + +main(_Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + catch(repl, exit_repl, nl), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/step1_read_print.pl b/impls/prolog/step1_read_print.pl index daff2e16d3..8e4c41fd63 100644 --- a/impls/prolog/step1_read_print.pl +++ b/impls/prolog/step1_read_print.pl @@ -1,44 +1,44 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -:- consult([printer, reader, types, utils]). - -% Read - -mal_read(Ast) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true), % fails for duplicate lines - read_str(Line, Ast). - -% Eval - -eval(Ast, Ast). - -% Print - -print(Ast) :- format("~F\n", [Ast]). - -% REP - -rep :- - mal_read(Ast), - eval(Ast, Evaluated), - print(Evaluated). - -% Main program - -repl :- - catch(rep, mal_error(Message), writeln(Message)), - repl. - -main(_Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - catch(repl, exit_repl, nl), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +:- consult([printer, reader, types, utils]). + +% Read + +mal_read(Ast) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true), % fails for duplicate lines + read_str(Line, Ast). + +% Eval + +eval(Ast, Ast). + +% Print + +print(Ast) :- format("~F\n", [Ast]). + +% REP + +rep :- + mal_read(Ast), + eval(Ast, Evaluated), + print(Evaluated). + +% Main program + +repl :- + catch(rep, mal_error(Message), writeln(Message)), + repl. + +main(_Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + catch(repl, exit_repl, nl), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/step2_eval.pl b/impls/prolog/step2_eval.pl index 598fe8c133..9a776dae4b 100644 --- a/impls/prolog/step2_eval.pl +++ b/impls/prolog/step2_eval.pl @@ -1,86 +1,86 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -:- consult([printer, reader, types, utils]). - -% Read - -mal_read(Ast) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true), % fails for duplicate lines - read_str(Line, Ast). - -% apply phase - -eval_list(Env, First, Rest, Res) :- - eval(Env, First, Fn), - check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), - maplist(eval(Env), Rest, Args), - call(Goal, Args, Res). - -% The eval function itself. - -% Uncomment this to get a trace. -%% eval(_, Ast, _) :- -%% format("EVAL: ~F\n", [Ast]), -%% fail. % Proceed with normal alternatives. - -eval(Env, List, Res) :- - list([First | Args], List), !, - eval_list(Env, First, Args, Res). - -eval(_, nil, nil). -eval(_, true, true). -eval(_, false, false). -eval(Env, Symbol, Res) :- - atom(Symbol), !, - check(get_assoc(Symbol, Env, Res), "'~F' not found", [Symbol]). - -eval(Env, Vector, Res) :- - vector(Xs, Vector), !, - maplist(eval(Env), Xs, Ys), - vector(Ys, Res). - -eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). - -eval(_, Anything_Else, Anything_Else). - -% Print - -print(Ast) :- format("~F\n", [Ast]). - -% REP - -rep(Env) :- - mal_read(Ast), - eval(Env, Ast, Evaluated), - print(Evaluated). - -% Main program - -repl(Env) :- - catch(rep(Env), mal_error(Message), writeln(Message)), - repl(Env). - -add([X, Y], Res) :- integer(X), integer(Y), Res is X + Y. -sub([X, Y], Res) :- integer(X), integer(Y), Res is X - Y. -mul([X, Y], Res) :- integer(X), integer(Y), Res is X * Y. -div([X, Y], Res) :- integer(X), integer(Y), Y \== 0, Res is X / Y. - -main(_Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - mal_fn(add, Add), - mal_fn(sub, Sub), - mal_fn(mul, Mul), - mal_fn(div, Div), - list_to_assoc(['+' - Add, '-' - Sub, '*' - Mul, '/' - Div], Env), - - catch(repl(Env), exit_repl, nl), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +:- consult([printer, reader, types, utils]). + +% Read + +mal_read(Ast) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true), % fails for duplicate lines + read_str(Line, Ast). + +% apply phase + +eval_list(Env, First, Rest, Res) :- + eval(Env, First, Fn), + check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), + maplist(eval(Env), Rest, Args), + call(Goal, Args, Res). + +% The eval function itself. + +% Uncomment this to get a trace. +%% eval(_, Ast, _) :- +%% format("EVAL: ~F\n", [Ast]), +%% fail. % Proceed with normal alternatives. + +eval(Env, List, Res) :- + list([First | Args], List), !, + eval_list(Env, First, Args, Res). + +eval(_, nil, nil). +eval(_, true, true). +eval(_, false, false). +eval(Env, Symbol, Res) :- + atom(Symbol), !, + check(get_assoc(Symbol, Env, Res), "'~F' not found", [Symbol]). + +eval(Env, Vector, Res) :- + vector(Xs, Vector), !, + maplist(eval(Env), Xs, Ys), + vector(Ys, Res). + +eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). + +eval(_, Anything_Else, Anything_Else). + +% Print + +print(Ast) :- format("~F\n", [Ast]). + +% REP + +rep(Env) :- + mal_read(Ast), + eval(Env, Ast, Evaluated), + print(Evaluated). + +% Main program + +repl(Env) :- + catch(rep(Env), mal_error(Message), writeln(Message)), + repl(Env). + +add([X, Y], Res) :- integer(X), integer(Y), Res is X + Y. +sub([X, Y], Res) :- integer(X), integer(Y), Res is X - Y. +mul([X, Y], Res) :- integer(X), integer(Y), Res is X * Y. +div([X, Y], Res) :- integer(X), integer(Y), Y \== 0, Res is X / Y. + +main(_Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + mal_fn(add, Add), + mal_fn(sub, Sub), + mal_fn(mul, Mul), + mal_fn(div, Div), + list_to_assoc(['+' - Add, '-' - Sub, '*' - Mul, '/' - Div], Env), + + catch(repl(Env), exit_repl, nl), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/step3_env.pl b/impls/prolog/step3_env.pl index b7518c9db5..d02ef99aca 100644 --- a/impls/prolog/step3_env.pl +++ b/impls/prolog/step3_env.pl @@ -1,107 +1,107 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -:- consult([env, printer, reader, types, utils]). - -% Read - -mal_read(Ast) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true), % fails for duplicate lines - read_str(Line, Ast). - -% Eval non-empty list depending on their first element. - -eval_list(Env, 'def!', Args, Res) :- !, - check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "def!: ~F is not a symbol", [Key]), - eval(Env, Form, Res), - env_set(Env, Key, Res). - -eval_list(Env, 'let*', Args, Res) :- !, - check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), - env(Env, Let_Env), - check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), - eval(Let_Env, Form, Res). - -let_loop(Env, Key, Form) :- !, - check(atom(Key), "let*: ~F is not a key", [Key]), - eval(Env, Form, Value), - env_set(Env, Key, Value). - -% apply phase - -eval_list(Env, First, Rest, Res) :- - eval(Env, First, Fn), - check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), - maplist(eval(Env), Rest, Args), - call(Goal, Args, Res). - -% The eval function itself. - -% Uncomment this to get a trace with environments. -%% eval(Env, Ast, _) :- -%% format("EVAL: ~F in ~V\n", [Ast, Env]), -%% fail. % Proceed with normal alternatives. - -eval(Env, List, Res) :- - list([First | Args], List), !, - eval_list(Env, First, Args, Res). - -eval(_, nil, nil). -eval(_, true, true). -eval(_, false, false). -eval(Env, Symbol, Res) :- - atom(Symbol), !, - check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). - -eval(Env, Vector, Res) :- - vector(Xs, Vector), !, - maplist(eval(Env), Xs, Ys), - vector(Ys, Res). - -eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). - -eval(_, Anything_Else, Anything_Else). - -% Print - -print(Ast) :- format("~F\n", [Ast]). - -% REP - -rep(Env) :- - mal_read(Ast), - eval(Env, Ast, Evaluated), - print(Evaluated). - -% Main program - -repl(Env) :- - catch(rep(Env), mal_error(Message), writeln(Message)), - repl(Env). - -add([X, Y], Res) :- integer(X), integer(Y), Res is X + Y. -sub([X, Y], Res) :- integer(X), integer(Y), Res is X - Y. -mul([X, Y], Res) :- integer(X), integer(Y), Res is X * Y. -div([X, Y], Res) :- integer(X), integer(Y), Y \== 0, Res is X / Y. - -define_core_function(Env, Symbol, Core_Function) :- - mal_fn(Core_Function, Form), - env_set(Env, Symbol, Form). - -main(_Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - env(Env), - map_keyvals(define_core_function(Env), ['+', add, '-', sub, '*', mul, '/', div]), - - catch(repl(Env), exit_repl, nl), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +:- consult([env, printer, reader, types, utils]). + +% Read + +mal_read(Ast) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true), % fails for duplicate lines + read_str(Line, Ast). + +% Eval non-empty list depending on their first element. + +eval_list(Env, 'def!', Args, Res) :- !, + check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "def!: ~F is not a symbol", [Key]), + eval(Env, Form, Res), + env_set(Env, Key, Res). + +eval_list(Env, 'let*', Args, Res) :- !, + check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), + env(Env, Let_Env), + check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), + eval(Let_Env, Form, Res). + +let_loop(Env, Key, Form) :- !, + check(atom(Key), "let*: ~F is not a key", [Key]), + eval(Env, Form, Value), + env_set(Env, Key, Value). + +% apply phase + +eval_list(Env, First, Rest, Res) :- + eval(Env, First, Fn), + check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), + maplist(eval(Env), Rest, Args), + call(Goal, Args, Res). + +% The eval function itself. + +% Uncomment this to get a trace with environments. +%% eval(Env, Ast, _) :- +%% format("EVAL: ~F in ~V\n", [Ast, Env]), +%% fail. % Proceed with normal alternatives. + +eval(Env, List, Res) :- + list([First | Args], List), !, + eval_list(Env, First, Args, Res). + +eval(_, nil, nil). +eval(_, true, true). +eval(_, false, false). +eval(Env, Symbol, Res) :- + atom(Symbol), !, + check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). + +eval(Env, Vector, Res) :- + vector(Xs, Vector), !, + maplist(eval(Env), Xs, Ys), + vector(Ys, Res). + +eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). + +eval(_, Anything_Else, Anything_Else). + +% Print + +print(Ast) :- format("~F\n", [Ast]). + +% REP + +rep(Env) :- + mal_read(Ast), + eval(Env, Ast, Evaluated), + print(Evaluated). + +% Main program + +repl(Env) :- + catch(rep(Env), mal_error(Message), writeln(Message)), + repl(Env). + +add([X, Y], Res) :- integer(X), integer(Y), Res is X + Y. +sub([X, Y], Res) :- integer(X), integer(Y), Res is X - Y. +mul([X, Y], Res) :- integer(X), integer(Y), Res is X * Y. +div([X, Y], Res) :- integer(X), integer(Y), Y \== 0, Res is X / Y. + +define_core_function(Env, Symbol, Core_Function) :- + mal_fn(Core_Function, Form), + env_set(Env, Symbol, Form). + +main(_Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + env(Env), + map_keyvals(define_core_function(Env), ['+', add, '-', sub, '*', mul, '/', div]), + + catch(repl(Env), exit_repl, nl), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/step4_if_fn_do.pl b/impls/prolog/step4_if_fn_do.pl index 38ce02c38c..4e2ea79e76 100644 --- a/impls/prolog/step4_if_fn_do.pl +++ b/impls/prolog/step4_if_fn_do.pl @@ -1,142 +1,142 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -:- consult([core, env, printer, reader, types, utils]). - -% Read - -mal_read(Ast) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true), % fails for duplicate lines - read_str(Line, Ast). - -% Eval non-empty list depending on their first element. -:- discontiguous eval_list/4. - -eval_list(Env, 'def!', Args, Res) :- !, - check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "def!: ~F is not a symbol", [Key]), - eval(Env, Form, Res), - env_set(Env, Key, Res). - -eval_list(Env, 'let*', Args, Res) :- !, - check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), - env(Env, Let_Env), - check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), - eval(Let_Env, Form, Res). - -let_loop(Env, Key, Form) :- !, - check(atom(Key), "let*: ~F is not a key", [Key]), - eval(Env, Form, Value), - env_set(Env, Key, Value). - -eval_list(Env, if, Args, Res) :- !, - check(if_assign_args(Args, Form, Then, Else), - "if: expects 2 or 3 arguments, got: ~L", [Args]), - eval(Env, Form, Test), - if_select(Test, Then, Else, Selected), - eval(Env, Selected, Res). - -if_assign_args([Form, Then, Else], Form, Then, Else). -if_assign_args([Form, Then], Form, Then, nil). - -if_select(false, _, Else, Else) :- !. -if_select(nil, _, Else, Else) :- !. -if_select(_, Then, _, Then). - -eval_list(Env, 'fn*', Args, Res) :- !, - check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), - check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), - mal_fn(apply_fn(Keys, Form, Env), Res). - -apply_fn(Keys, Form, Env, Args, Res) :- - env(Env, Apply_Env), - check(env_bind(Apply_Env, Keys, Args), - "cannot apply fn*[~L] to [~L]", [Keys, Args]), - eval(Apply_Env, Form, Res). - -eval_list(Env, do, Args, Res) :- !, - foldl(do_loop(Env), Args, nil, Res). - -do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). - -% apply phase - -eval_list(Env, First, Rest, Res) :- - eval(Env, First, Fn), - check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), - maplist(eval(Env), Rest, Args), - call(Goal, Args, Res). - -% The eval function itself. - -% Uncomment this to get a trace with environments. -%% eval(Env, Ast, _) :- -%% format("EVAL: ~F in ~V\n", [Ast, Env]), -%% fail. % Proceed with normal alternatives. - -eval(Env, List, Res) :- - list([First | Args], List), !, - eval_list(Env, First, Args, Res). - -eval(_, nil, nil). -eval(_, true, true). -eval(_, false, false). -eval(Env, Symbol, Res) :- - atom(Symbol), !, - check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). - -eval(Env, Vector, Res) :- - vector(Xs, Vector), !, - maplist(eval(Env), Xs, Ys), - vector(Ys, Res). - -eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). - -eval(_, Anything_Else, Anything_Else). - -% Print - -print(Ast) :- format("~F\n", [Ast]). - -% REP - -rep(Env) :- - mal_read(Ast), - eval(Env, Ast, Evaluated), - print(Evaluated). - -% Main program - -repl(Env) :- - catch(rep(Env), mal_error(Message), writeln(Message)), - repl(Env). - -re(Env, String) :- - read_str(String, Ast), - eval(Env, Ast, _). - -define_core_function(Env, Symbol, Core_Function) :- - mal_fn(wrap_failure(Core_Function), Form), - env_set(Env, Symbol, Form). - -main(_Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - env(Env), - core_ns(Core_Ns), - map_keyvals(define_core_function(Env), Core_Ns), - define_core_function(Env, eval, core_eval(Env)), - - re(Env, "(def! not (fn* [a] (if a false true)))"), - - catch(repl(Env), exit_repl, nl), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +:- consult([core, env, printer, reader, types, utils]). + +% Read + +mal_read(Ast) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true), % fails for duplicate lines + read_str(Line, Ast). + +% Eval non-empty list depending on their first element. +:- discontiguous eval_list/4. + +eval_list(Env, 'def!', Args, Res) :- !, + check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "def!: ~F is not a symbol", [Key]), + eval(Env, Form, Res), + env_set(Env, Key, Res). + +eval_list(Env, 'let*', Args, Res) :- !, + check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), + env(Env, Let_Env), + check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), + eval(Let_Env, Form, Res). + +let_loop(Env, Key, Form) :- !, + check(atom(Key), "let*: ~F is not a key", [Key]), + eval(Env, Form, Value), + env_set(Env, Key, Value). + +eval_list(Env, if, Args, Res) :- !, + check(if_assign_args(Args, Form, Then, Else), + "if: expects 2 or 3 arguments, got: ~L", [Args]), + eval(Env, Form, Test), + if_select(Test, Then, Else, Selected), + eval(Env, Selected, Res). + +if_assign_args([Form, Then, Else], Form, Then, Else). +if_assign_args([Form, Then], Form, Then, nil). + +if_select(false, _, Else, Else) :- !. +if_select(nil, _, Else, Else) :- !. +if_select(_, Then, _, Then). + +eval_list(Env, 'fn*', Args, Res) :- !, + check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), + check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), + mal_fn(apply_fn(Keys, Form, Env), Res). + +apply_fn(Keys, Form, Env, Args, Res) :- + env(Env, Apply_Env), + check(env_bind(Apply_Env, Keys, Args), + "cannot apply fn*[~L] to [~L]", [Keys, Args]), + eval(Apply_Env, Form, Res). + +eval_list(Env, do, Args, Res) :- !, + foldl(do_loop(Env), Args, nil, Res). + +do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). + +% apply phase + +eval_list(Env, First, Rest, Res) :- + eval(Env, First, Fn), + check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), + maplist(eval(Env), Rest, Args), + call(Goal, Args, Res). + +% The eval function itself. + +% Uncomment this to get a trace with environments. +%% eval(Env, Ast, _) :- +%% format("EVAL: ~F in ~V\n", [Ast, Env]), +%% fail. % Proceed with normal alternatives. + +eval(Env, List, Res) :- + list([First | Args], List), !, + eval_list(Env, First, Args, Res). + +eval(_, nil, nil). +eval(_, true, true). +eval(_, false, false). +eval(Env, Symbol, Res) :- + atom(Symbol), !, + check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). + +eval(Env, Vector, Res) :- + vector(Xs, Vector), !, + maplist(eval(Env), Xs, Ys), + vector(Ys, Res). + +eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). + +eval(_, Anything_Else, Anything_Else). + +% Print + +print(Ast) :- format("~F\n", [Ast]). + +% REP + +rep(Env) :- + mal_read(Ast), + eval(Env, Ast, Evaluated), + print(Evaluated). + +% Main program + +repl(Env) :- + catch(rep(Env), mal_error(Message), writeln(Message)), + repl(Env). + +re(Env, String) :- + read_str(String, Ast), + eval(Env, Ast, _). + +define_core_function(Env, Symbol, Core_Function) :- + mal_fn(wrap_failure(Core_Function), Form), + env_set(Env, Symbol, Form). + +main(_Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + env(Env), + core_ns(Core_Ns), + map_keyvals(define_core_function(Env), Core_Ns), + define_core_function(Env, eval, core_eval(Env)), + + re(Env, "(def! not (fn* [a] (if a false true)))"), + + catch(repl(Env), exit_repl, nl), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/step6_file.pl b/impls/prolog/step6_file.pl index 401ee76906..300e58b11b 100644 --- a/impls/prolog/step6_file.pl +++ b/impls/prolog/step6_file.pl @@ -1,159 +1,159 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -:- consult([core, env, printer, reader, types, utils]). - -% Read - -mal_read(Ast) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true), % fails for duplicate lines - read_str(Line, Ast). - -% Eval non-empty list depending on their first element. -:- discontiguous eval_list/4. - -eval_list(Env, 'def!', Args, Res) :- !, - check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "def!: ~F is not a symbol", [Key]), - eval(Env, Form, Res), - env_set(Env, Key, Res). - -eval_list(Env, 'let*', Args, Res) :- !, - check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), - env(Env, Let_Env), - check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), - eval(Let_Env, Form, Res). - -let_loop(Env, Key, Form) :- !, - check(atom(Key), "let*: ~F is not a key", [Key]), - eval(Env, Form, Value), - env_set(Env, Key, Value). - -eval_list(Env, if, Args, Res) :- !, - check(if_assign_args(Args, Form, Then, Else), - "if: expects 2 or 3 arguments, got: ~L", [Args]), - eval(Env, Form, Test), - if_select(Test, Then, Else, Selected), - eval(Env, Selected, Res). - -if_assign_args([Form, Then, Else], Form, Then, Else). -if_assign_args([Form, Then], Form, Then, nil). - -if_select(false, _, Else, Else) :- !. -if_select(nil, _, Else, Else) :- !. -if_select(_, Then, _, Then). - -eval_list(Env, 'fn*', Args, Res) :- !, - check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), - check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), - mal_fn(apply_fn(Keys, Form, Env), Res). - -apply_fn(Keys, Form, Env, Args, Res) :- - env(Env, Apply_Env), - check(env_bind(Apply_Env, Keys, Args), - "cannot apply fn*[~L] to [~L]", [Keys, Args]), - eval(Apply_Env, Form, Res). - -eval_list(Env, do, Args, Res) :- !, - foldl(do_loop(Env), Args, nil, Res). - -do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). - -% apply phase - -eval_list(Env, First, Rest, Res) :- - eval(Env, First, Fn), - check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), - maplist(eval(Env), Rest, Args), - call(Goal, Args, Res). - -% The eval function itself. - -% Uncomment this to get a trace with environments. -%% eval(Env, Ast, _) :- -%% format("EVAL: ~F in ~V\n", [Ast, Env]), -%% fail. % Proceed with normal alternatives. - -eval(Env, List, Res) :- - list([First | Args], List), !, - eval_list(Env, First, Args, Res). - -eval(_, nil, nil). -eval(_, true, true). -eval(_, false, false). -eval(Env, Symbol, Res) :- - atom(Symbol), !, - check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). - -eval(Env, Vector, Res) :- - vector(Xs, Vector), !, - maplist(eval(Env), Xs, Ys), - vector(Ys, Res). - -eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). - -eval(_, Anything_Else, Anything_Else). - -% Print - -print(Ast) :- format("~F\n", [Ast]). - -% REP - -rep(Env) :- - mal_read(Ast), - eval(Env, Ast, Evaluated), - print(Evaluated). - -% Main program - -repl(Env) :- - catch(rep(Env), mal_error(Message), writeln(Message)), - repl(Env). - -re(Env, String) :- - read_str(String, Ast), - eval(Env, Ast, _). - -define_core_function(Env, Symbol, Core_Function) :- - mal_fn(wrap_failure(Core_Function), Form), - env_set(Env, Symbol, Form). - -core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). - -main(Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - env(Env), - core_ns(Core_Ns), - map_keyvals(define_core_function(Env), Core_Ns), - define_core_function(Env, eval, core_eval(Env)), - - re(Env, "(def! not (fn* [a] (if a false true)))"), - re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), - - ( maplist(atom_string, Argv, [Script | Args]) - - -> % If Argv starts with a script, set arguments and load it. - list(Args, Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - format(string(Load_Script), "(load-file \"~s\")", [Script]), - re(Env, Load_Script) - - ; % else read from standard input. - list([], Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - catch(repl(Env), exit_repl, nl) - ), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +:- consult([core, env, printer, reader, types, utils]). + +% Read + +mal_read(Ast) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true), % fails for duplicate lines + read_str(Line, Ast). + +% Eval non-empty list depending on their first element. +:- discontiguous eval_list/4. + +eval_list(Env, 'def!', Args, Res) :- !, + check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "def!: ~F is not a symbol", [Key]), + eval(Env, Form, Res), + env_set(Env, Key, Res). + +eval_list(Env, 'let*', Args, Res) :- !, + check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), + env(Env, Let_Env), + check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), + eval(Let_Env, Form, Res). + +let_loop(Env, Key, Form) :- !, + check(atom(Key), "let*: ~F is not a key", [Key]), + eval(Env, Form, Value), + env_set(Env, Key, Value). + +eval_list(Env, if, Args, Res) :- !, + check(if_assign_args(Args, Form, Then, Else), + "if: expects 2 or 3 arguments, got: ~L", [Args]), + eval(Env, Form, Test), + if_select(Test, Then, Else, Selected), + eval(Env, Selected, Res). + +if_assign_args([Form, Then, Else], Form, Then, Else). +if_assign_args([Form, Then], Form, Then, nil). + +if_select(false, _, Else, Else) :- !. +if_select(nil, _, Else, Else) :- !. +if_select(_, Then, _, Then). + +eval_list(Env, 'fn*', Args, Res) :- !, + check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), + check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), + mal_fn(apply_fn(Keys, Form, Env), Res). + +apply_fn(Keys, Form, Env, Args, Res) :- + env(Env, Apply_Env), + check(env_bind(Apply_Env, Keys, Args), + "cannot apply fn*[~L] to [~L]", [Keys, Args]), + eval(Apply_Env, Form, Res). + +eval_list(Env, do, Args, Res) :- !, + foldl(do_loop(Env), Args, nil, Res). + +do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). + +% apply phase + +eval_list(Env, First, Rest, Res) :- + eval(Env, First, Fn), + check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), + maplist(eval(Env), Rest, Args), + call(Goal, Args, Res). + +% The eval function itself. + +% Uncomment this to get a trace with environments. +%% eval(Env, Ast, _) :- +%% format("EVAL: ~F in ~V\n", [Ast, Env]), +%% fail. % Proceed with normal alternatives. + +eval(Env, List, Res) :- + list([First | Args], List), !, + eval_list(Env, First, Args, Res). + +eval(_, nil, nil). +eval(_, true, true). +eval(_, false, false). +eval(Env, Symbol, Res) :- + atom(Symbol), !, + check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). + +eval(Env, Vector, Res) :- + vector(Xs, Vector), !, + maplist(eval(Env), Xs, Ys), + vector(Ys, Res). + +eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). + +eval(_, Anything_Else, Anything_Else). + +% Print + +print(Ast) :- format("~F\n", [Ast]). + +% REP + +rep(Env) :- + mal_read(Ast), + eval(Env, Ast, Evaluated), + print(Evaluated). + +% Main program + +repl(Env) :- + catch(rep(Env), mal_error(Message), writeln(Message)), + repl(Env). + +re(Env, String) :- + read_str(String, Ast), + eval(Env, Ast, _). + +define_core_function(Env, Symbol, Core_Function) :- + mal_fn(wrap_failure(Core_Function), Form), + env_set(Env, Symbol, Form). + +core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). + +main(Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + env(Env), + core_ns(Core_Ns), + map_keyvals(define_core_function(Env), Core_Ns), + define_core_function(Env, eval, core_eval(Env)), + + re(Env, "(def! not (fn* [a] (if a false true)))"), + re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), + + ( maplist(atom_string, Argv, [Script | Args]) + + -> % If Argv starts with a script, set arguments and load it. + list(Args, Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + format(string(Load_Script), "(load-file \"~s\")", [Script]), + re(Env, Load_Script) + + ; % else read from standard input. + list([], Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + catch(repl(Env), exit_repl, nl) + ), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/step7_quote.pl b/impls/prolog/step7_quote.pl index 2a0d61fcb6..49a472a5ca 100644 --- a/impls/prolog/step7_quote.pl +++ b/impls/prolog/step7_quote.pl @@ -1,198 +1,198 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -:- consult([core, env, printer, reader, types, utils]). - -% Read - -mal_read(Ast) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true), % fails for duplicate lines - read_str(Line, Ast). - -% Eval non-empty list depending on their first element. -:- discontiguous eval_list/4. - -eval_list(Env, 'def!', Args, Res) :- !, - check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "def!: ~F is not a symbol", [Key]), - eval(Env, Form, Res), - env_set(Env, Key, Res). - -eval_list(Env, 'let*', Args, Res) :- !, - check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), - env(Env, Let_Env), - check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), - eval(Let_Env, Form, Res). - -let_loop(Env, Key, Form) :- !, - check(atom(Key), "let*: ~F is not a key", [Key]), - eval(Env, Form, Value), - env_set(Env, Key, Value). - -eval_list(Env, if, Args, Res) :- !, - check(if_assign_args(Args, Form, Then, Else), - "if: expects 2 or 3 arguments, got: ~L", [Args]), - eval(Env, Form, Test), - if_select(Test, Then, Else, Selected), - eval(Env, Selected, Res). - -if_assign_args([Form, Then, Else], Form, Then, Else). -if_assign_args([Form, Then], Form, Then, nil). - -if_select(false, _, Else, Else) :- !. -if_select(nil, _, Else, Else) :- !. -if_select(_, Then, _, Then). - -eval_list(Env, 'fn*', Args, Res) :- !, - check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), - check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), - mal_fn(apply_fn(Keys, Form, Env), Res). - -apply_fn(Keys, Form, Env, Args, Res) :- - env(Env, Apply_Env), - check(env_bind(Apply_Env, Keys, Args), - "cannot apply fn*[~L] to [~L]", [Keys, Args]), - eval(Apply_Env, Form, Res). - -eval_list(Env, do, Args, Res) :- !, - foldl(do_loop(Env), Args, nil, Res). - -do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). - -eval_list(_, quote, Args, Res) :- !, - check(Args = [Res], "quote: expects 1 argument, got ~L", [Args]). - -eval_list(_, quasiquoteexpand, Args, Res) :- !, - check(Args = [X], "quasiquoteexpand: expects 1 argument, got: ~L", [Args]), - quasiquote(X, Res). - -eval_list(Env, quasiquote, Args, Res) :- !, - check(Args = [X], "quasiquote: expects 1 argument, got: ~L", [Args]), - quasiquote(X, Y), - eval(Env, Y, Res). - -quasiquote(List, Res) :- - list(Xs, List), !, - ( Xs = [unquote | Args] - -> check(Args = [Res], "unquote: expects 1 argument, got: ", [Args]) - ; list([], Empty), - foldr(qq_loop, Empty, Xs, Res)). -quasiquote(Vector, Res) :- - vector(Xs, Vector), !, - list([], Empty), - foldr(qq_loop, Empty, Xs, Y), - list([vec, Y], Res). -quasiquote(nil, nil). -quasiquote(true, true). -quasiquote(false, false). -quasiquote(Symbol_Or_Map, Res) :- - (atom(Symbol_Or_Map) -> true ; is_map(Symbol_Or_Map)), !, - list([quote, Symbol_Or_Map], Res). -quasiquote(Anything_Else, Anything_Else). - -qq_loop(Elt, Acc, Res) :- - list(['splice-unquote' | Args], Elt), !, - check(Args = [X], "splice-unquote: expects 1 argument, got:", [Args]), - list([concat, X, Acc], Res). -qq_loop(Elt, Acc, Res) :- - quasiquote(Elt, Quasiquoted), - list([cons, Quasiquoted, Acc], Res). - -% apply phase - -eval_list(Env, First, Rest, Res) :- - eval(Env, First, Fn), - check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), - maplist(eval(Env), Rest, Args), - call(Goal, Args, Res). - -% The eval function itself. - -% Uncomment this to get a trace with environments. -%% eval(Env, Ast, _) :- -%% format("EVAL: ~F in ~V\n", [Ast, Env]), -%% fail. % Proceed with normal alternatives. - -eval(Env, List, Res) :- - list([First | Args], List), !, - eval_list(Env, First, Args, Res). - -eval(_, nil, nil). -eval(_, true, true). -eval(_, false, false). -eval(Env, Symbol, Res) :- - atom(Symbol), !, - check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). - -eval(Env, Vector, Res) :- - vector(Xs, Vector), !, - maplist(eval(Env), Xs, Ys), - vector(Ys, Res). - -eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). - -eval(_, Anything_Else, Anything_Else). - -% Print - -print(Ast) :- format("~F\n", [Ast]). - -% REP - -rep(Env) :- - mal_read(Ast), - eval(Env, Ast, Evaluated), - print(Evaluated). - -% Main program - -repl(Env) :- - catch(rep(Env), mal_error(Message), writeln(Message)), - repl(Env). - -re(Env, String) :- - read_str(String, Ast), - eval(Env, Ast, _). - -define_core_function(Env, Symbol, Core_Function) :- - mal_fn(wrap_failure(Core_Function), Form), - env_set(Env, Symbol, Form). - -core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). - -main(Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - env(Env), - core_ns(Core_Ns), - map_keyvals(define_core_function(Env), Core_Ns), - define_core_function(Env, eval, core_eval(Env)), - - re(Env, "(def! not (fn* [a] (if a false true)))"), - re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), - - ( maplist(atom_string, Argv, [Script | Args]) - - -> % If Argv starts with a script, set arguments and load it. - list(Args, Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - format(string(Load_Script), "(load-file \"~s\")", [Script]), - re(Env, Load_Script) - - ; % else read from standard input. - list([], Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - catch(repl(Env), exit_repl, nl) - ), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +:- consult([core, env, printer, reader, types, utils]). + +% Read + +mal_read(Ast) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true), % fails for duplicate lines + read_str(Line, Ast). + +% Eval non-empty list depending on their first element. +:- discontiguous eval_list/4. + +eval_list(Env, 'def!', Args, Res) :- !, + check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "def!: ~F is not a symbol", [Key]), + eval(Env, Form, Res), + env_set(Env, Key, Res). + +eval_list(Env, 'let*', Args, Res) :- !, + check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), + env(Env, Let_Env), + check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), + eval(Let_Env, Form, Res). + +let_loop(Env, Key, Form) :- !, + check(atom(Key), "let*: ~F is not a key", [Key]), + eval(Env, Form, Value), + env_set(Env, Key, Value). + +eval_list(Env, if, Args, Res) :- !, + check(if_assign_args(Args, Form, Then, Else), + "if: expects 2 or 3 arguments, got: ~L", [Args]), + eval(Env, Form, Test), + if_select(Test, Then, Else, Selected), + eval(Env, Selected, Res). + +if_assign_args([Form, Then, Else], Form, Then, Else). +if_assign_args([Form, Then], Form, Then, nil). + +if_select(false, _, Else, Else) :- !. +if_select(nil, _, Else, Else) :- !. +if_select(_, Then, _, Then). + +eval_list(Env, 'fn*', Args, Res) :- !, + check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), + check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), + mal_fn(apply_fn(Keys, Form, Env), Res). + +apply_fn(Keys, Form, Env, Args, Res) :- + env(Env, Apply_Env), + check(env_bind(Apply_Env, Keys, Args), + "cannot apply fn*[~L] to [~L]", [Keys, Args]), + eval(Apply_Env, Form, Res). + +eval_list(Env, do, Args, Res) :- !, + foldl(do_loop(Env), Args, nil, Res). + +do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). + +eval_list(_, quote, Args, Res) :- !, + check(Args = [Res], "quote: expects 1 argument, got ~L", [Args]). + +eval_list(_, quasiquoteexpand, Args, Res) :- !, + check(Args = [X], "quasiquoteexpand: expects 1 argument, got: ~L", [Args]), + quasiquote(X, Res). + +eval_list(Env, quasiquote, Args, Res) :- !, + check(Args = [X], "quasiquote: expects 1 argument, got: ~L", [Args]), + quasiquote(X, Y), + eval(Env, Y, Res). + +quasiquote(List, Res) :- + list(Xs, List), !, + ( Xs = [unquote | Args] + -> check(Args = [Res], "unquote: expects 1 argument, got: ", [Args]) + ; list([], Empty), + foldr(qq_loop, Empty, Xs, Res)). +quasiquote(Vector, Res) :- + vector(Xs, Vector), !, + list([], Empty), + foldr(qq_loop, Empty, Xs, Y), + list([vec, Y], Res). +quasiquote(nil, nil). +quasiquote(true, true). +quasiquote(false, false). +quasiquote(Symbol_Or_Map, Res) :- + (atom(Symbol_Or_Map) -> true ; is_map(Symbol_Or_Map)), !, + list([quote, Symbol_Or_Map], Res). +quasiquote(Anything_Else, Anything_Else). + +qq_loop(Elt, Acc, Res) :- + list(['splice-unquote' | Args], Elt), !, + check(Args = [X], "splice-unquote: expects 1 argument, got:", [Args]), + list([concat, X, Acc], Res). +qq_loop(Elt, Acc, Res) :- + quasiquote(Elt, Quasiquoted), + list([cons, Quasiquoted, Acc], Res). + +% apply phase + +eval_list(Env, First, Rest, Res) :- + eval(Env, First, Fn), + check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), + maplist(eval(Env), Rest, Args), + call(Goal, Args, Res). + +% The eval function itself. + +% Uncomment this to get a trace with environments. +%% eval(Env, Ast, _) :- +%% format("EVAL: ~F in ~V\n", [Ast, Env]), +%% fail. % Proceed with normal alternatives. + +eval(Env, List, Res) :- + list([First | Args], List), !, + eval_list(Env, First, Args, Res). + +eval(_, nil, nil). +eval(_, true, true). +eval(_, false, false). +eval(Env, Symbol, Res) :- + atom(Symbol), !, + check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). + +eval(Env, Vector, Res) :- + vector(Xs, Vector), !, + maplist(eval(Env), Xs, Ys), + vector(Ys, Res). + +eval(Env, Map, Res) :- map_map(eval(Env), Map, Res). + +eval(_, Anything_Else, Anything_Else). + +% Print + +print(Ast) :- format("~F\n", [Ast]). + +% REP + +rep(Env) :- + mal_read(Ast), + eval(Env, Ast, Evaluated), + print(Evaluated). + +% Main program + +repl(Env) :- + catch(rep(Env), mal_error(Message), writeln(Message)), + repl(Env). + +re(Env, String) :- + read_str(String, Ast), + eval(Env, Ast, _). + +define_core_function(Env, Symbol, Core_Function) :- + mal_fn(wrap_failure(Core_Function), Form), + env_set(Env, Symbol, Form). + +core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). + +main(Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + env(Env), + core_ns(Core_Ns), + map_keyvals(define_core_function(Env), Core_Ns), + define_core_function(Env, eval, core_eval(Env)), + + re(Env, "(def! not (fn* [a] (if a false true)))"), + re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), + + ( maplist(atom_string, Argv, [Script | Args]) + + -> % If Argv starts with a script, set arguments and load it. + list(Args, Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + format(string(Load_Script), "(load-file \"~s\")", [Script]), + re(Env, Load_Script) + + ; % else read from standard input. + list([], Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + catch(repl(Env), exit_repl, nl) + ), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/step8_macros.pl b/impls/prolog/step8_macros.pl index ffb5de38e9..7fd66faf7f 100644 --- a/impls/prolog/step8_macros.pl +++ b/impls/prolog/step8_macros.pl @@ -1,228 +1,228 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -:- consult([core, env, printer, reader, types, utils]). - -% Read - -mal_read(Ast) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true), % fails for duplicate lines - read_str(Line, Ast). - -% Eval non-empty list depending on their first element. -:- discontiguous eval_list/4. - -eval_list(Env, 'def!', Args, Res) :- !, - check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "def!: ~F is not a symbol", [Key]), - eval(Env, Form, Res), - env_set(Env, Key, Res). - -eval_list(Env, 'let*', Args, Res) :- !, - check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), - env(Env, Let_Env), - check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), - eval(Let_Env, Form, Res). - -let_loop(Env, Key, Form) :- !, - check(atom(Key), "let*: ~F is not a key", [Key]), - eval(Env, Form, Value), - env_set(Env, Key, Value). - -eval_list(Env, if, Args, Res) :- !, - check(if_assign_args(Args, Form, Then, Else), - "if: expects 2 or 3 arguments, got: ~L", [Args]), - eval(Env, Form, Test), - if_select(Test, Then, Else, Selected), - eval(Env, Selected, Res). - -if_assign_args([Form, Then, Else], Form, Then, Else). -if_assign_args([Form, Then], Form, Then, nil). - -if_select(false, _, Else, Else) :- !. -if_select(nil, _, Else, Else) :- !. -if_select(_, Then, _, Then). - -eval_list(Env, 'fn*', Args, Res) :- !, - check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), - check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), - mal_fn(apply_fn(Keys, Form, Env), Res). - -apply_fn(Keys, Form, Env, Args, Res) :- - env(Env, Apply_Env), - check(env_bind(Apply_Env, Keys, Args), - "cannot apply fn*[~L] to [~L]", [Keys, Args]), - eval(Apply_Env, Form, Res). - -eval_list(Env, do, Args, Res) :- !, - foldl(do_loop(Env), Args, nil, Res). - -do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). - -eval_list(_, quote, Args, Res) :- !, - check(Args = [Res], "quote: expects 1 argument, got ~L", [Args]). - -eval_list(_, quasiquoteexpand, Args, Res) :- !, - check(Args = [X], "quasiquoteexpand: expects 1 argument, got: ~L", [Args]), - quasiquote(X, Res). - -eval_list(Env, quasiquote, Args, Res) :- !, - check(Args = [X], "quasiquote: expects 1 argument, got: ~L", [Args]), - quasiquote(X, Y), - eval(Env, Y, Res). - -quasiquote(List, Res) :- - list(Xs, List), !, - ( Xs = [unquote | Args] - -> check(Args = [Res], "unquote: expects 1 argument, got: ", [Args]) - ; list([], Empty), - foldr(qq_loop, Empty, Xs, Res)). -quasiquote(Vector, Res) :- - vector(Xs, Vector), !, - list([], Empty), - foldr(qq_loop, Empty, Xs, Y), - list([vec, Y], Res). -quasiquote(nil, nil). -quasiquote(true, true). -quasiquote(false, false). -quasiquote(Symbol_Or_Map, Res) :- - (atom(Symbol_Or_Map) -> true ; is_map(Symbol_Or_Map)), !, - list([quote, Symbol_Or_Map], Res). -quasiquote(Anything_Else, Anything_Else). - -qq_loop(Elt, Acc, Res) :- - list(['splice-unquote' | Args], Elt), !, - check(Args = [X], "splice-unquote: expects 1 argument, got:", [Args]), - list([concat, X, Acc], Res). -qq_loop(Elt, Acc, Res) :- - quasiquote(Elt, Quasiquoted), - list([cons, Quasiquoted, Acc], Res). - -eval_list(Env, 'defmacro!', Args, Res) :- !, - check(Args = [Key, Form], - "defmacro!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "defmacro!: ~F is not a key", [Key]), - eval(Env, Form, Fn), - check(mal_fn(_Goal, Fn), "defmacro!: ~F is not a function", [Fn]), - mal_macro(Fn, Res), - env_set(Env, Key, Res). - -eval_list(Env, macroexpand, Args, Res) :- !, - check(Args = [X], "macroexpand: expects 1 argument, got: ~L", [Args]), - macroexpand(Env, X, Res). - -macroexpand(Env, Ast, Res) :- - list([Key | Args], Ast), - env_get(Env, Key, Macro), - mal_macro(Fn, Macro), !, - mal_fn(Goal, Fn), - call(Goal, Args, New_Ast), - macroexpand(Env, New_Ast, Res). -macroexpand(_, Ast, Ast). - -% apply phase - -eval_list(Env, First, Rest, Res) :- - eval(Env, First, Fn), - ( mal_macro(F, Fn) - -> % If the Fn macro refers to F, apply F then evaluate, - mal_fn(Goal, F), - call(Goal, Rest, New_Ast), - eval(Env, New_Ast, Res) - ; % else evaluate arguments, apply Fn. - check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), - maplist(eval(Env), Rest, Args), - call(Goal, Args, Res)). - -% The eval function itself. - -% Uncomment this to get a trace with environments. -%% eval(Env, Ast, _) :- -%% format("EVAL: ~F in ~V\n", [Ast, Env]), -%% fail. % Proceed with normal alternatives. - -eval(Env, List, Res) :- - list([First | Args], List), !, - eval_list(Env, First, Args, Res). - -eval(_, nil, nil). -eval(_, true, true). -eval(_, false, false). -eval(Env, Symbol, Res) :- - atom(Symbol), !, - check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). - -eval(Env, Vector, Res) :- - vector(Xs, Vector), !, - maplist(eval(Env), Xs, Ys), - vector(Ys, Res). - -eval(Env, Map, Res) :- - map_map(eval(Env), Map, Res). - -eval(_, Anything_Else, Anything_Else). - -% Print - -print(Ast) :- format("~F\n", [Ast]). - -% REP - -rep(Env) :- - mal_read(Ast), - eval(Env, Ast, Evaluated), - print(Evaluated). - -% Main program - -repl(Env) :- - catch(rep(Env), mal_error(Message), writeln(Message)), - repl(Env). - -re(Env, String) :- - read_str(String, Ast), - eval(Env, Ast, _). - -define_core_function(Env, Symbol, Core_Function) :- - mal_fn(wrap_failure(Core_Function), Form), - env_set(Env, Symbol, Form). - -core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). - -main(Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - env(Env), - core_ns(Core_Ns), - map_keyvals(define_core_function(Env), Core_Ns), - define_core_function(Env, eval, core_eval(Env)), - - re(Env, "(def! not (fn* [a] (if a false true)))"), - re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), - re(Env, "(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)))))))"), - - ( maplist(atom_string, Argv, [Script | Args]) - - -> % If Argv starts with a script, set arguments and load it. - list(Args, Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - format(string(Load_Script), "(load-file \"~s\")", [Script]), - re(Env, Load_Script) - - ; % else read from standard input. - list([], Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - catch(repl(Env), exit_repl, nl) - ), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +:- consult([core, env, printer, reader, types, utils]). + +% Read + +mal_read(Ast) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true), % fails for duplicate lines + read_str(Line, Ast). + +% Eval non-empty list depending on their first element. +:- discontiguous eval_list/4. + +eval_list(Env, 'def!', Args, Res) :- !, + check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "def!: ~F is not a symbol", [Key]), + eval(Env, Form, Res), + env_set(Env, Key, Res). + +eval_list(Env, 'let*', Args, Res) :- !, + check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), + env(Env, Let_Env), + check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), + eval(Let_Env, Form, Res). + +let_loop(Env, Key, Form) :- !, + check(atom(Key), "let*: ~F is not a key", [Key]), + eval(Env, Form, Value), + env_set(Env, Key, Value). + +eval_list(Env, if, Args, Res) :- !, + check(if_assign_args(Args, Form, Then, Else), + "if: expects 2 or 3 arguments, got: ~L", [Args]), + eval(Env, Form, Test), + if_select(Test, Then, Else, Selected), + eval(Env, Selected, Res). + +if_assign_args([Form, Then, Else], Form, Then, Else). +if_assign_args([Form, Then], Form, Then, nil). + +if_select(false, _, Else, Else) :- !. +if_select(nil, _, Else, Else) :- !. +if_select(_, Then, _, Then). + +eval_list(Env, 'fn*', Args, Res) :- !, + check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), + check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), + mal_fn(apply_fn(Keys, Form, Env), Res). + +apply_fn(Keys, Form, Env, Args, Res) :- + env(Env, Apply_Env), + check(env_bind(Apply_Env, Keys, Args), + "cannot apply fn*[~L] to [~L]", [Keys, Args]), + eval(Apply_Env, Form, Res). + +eval_list(Env, do, Args, Res) :- !, + foldl(do_loop(Env), Args, nil, Res). + +do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). + +eval_list(_, quote, Args, Res) :- !, + check(Args = [Res], "quote: expects 1 argument, got ~L", [Args]). + +eval_list(_, quasiquoteexpand, Args, Res) :- !, + check(Args = [X], "quasiquoteexpand: expects 1 argument, got: ~L", [Args]), + quasiquote(X, Res). + +eval_list(Env, quasiquote, Args, Res) :- !, + check(Args = [X], "quasiquote: expects 1 argument, got: ~L", [Args]), + quasiquote(X, Y), + eval(Env, Y, Res). + +quasiquote(List, Res) :- + list(Xs, List), !, + ( Xs = [unquote | Args] + -> check(Args = [Res], "unquote: expects 1 argument, got: ", [Args]) + ; list([], Empty), + foldr(qq_loop, Empty, Xs, Res)). +quasiquote(Vector, Res) :- + vector(Xs, Vector), !, + list([], Empty), + foldr(qq_loop, Empty, Xs, Y), + list([vec, Y], Res). +quasiquote(nil, nil). +quasiquote(true, true). +quasiquote(false, false). +quasiquote(Symbol_Or_Map, Res) :- + (atom(Symbol_Or_Map) -> true ; is_map(Symbol_Or_Map)), !, + list([quote, Symbol_Or_Map], Res). +quasiquote(Anything_Else, Anything_Else). + +qq_loop(Elt, Acc, Res) :- + list(['splice-unquote' | Args], Elt), !, + check(Args = [X], "splice-unquote: expects 1 argument, got:", [Args]), + list([concat, X, Acc], Res). +qq_loop(Elt, Acc, Res) :- + quasiquote(Elt, Quasiquoted), + list([cons, Quasiquoted, Acc], Res). + +eval_list(Env, 'defmacro!', Args, Res) :- !, + check(Args = [Key, Form], + "defmacro!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "defmacro!: ~F is not a key", [Key]), + eval(Env, Form, Fn), + check(mal_fn(_Goal, Fn), "defmacro!: ~F is not a function", [Fn]), + mal_macro(Fn, Res), + env_set(Env, Key, Res). + +eval_list(Env, macroexpand, Args, Res) :- !, + check(Args = [X], "macroexpand: expects 1 argument, got: ~L", [Args]), + macroexpand(Env, X, Res). + +macroexpand(Env, Ast, Res) :- + list([Key | Args], Ast), + env_get(Env, Key, Macro), + mal_macro(Fn, Macro), !, + mal_fn(Goal, Fn), + call(Goal, Args, New_Ast), + macroexpand(Env, New_Ast, Res). +macroexpand(_, Ast, Ast). + +% apply phase + +eval_list(Env, First, Rest, Res) :- + eval(Env, First, Fn), + ( mal_macro(F, Fn) + -> % If the Fn macro refers to F, apply F then evaluate, + mal_fn(Goal, F), + call(Goal, Rest, New_Ast), + eval(Env, New_Ast, Res) + ; % else evaluate arguments, apply Fn. + check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), + maplist(eval(Env), Rest, Args), + call(Goal, Args, Res)). + +% The eval function itself. + +% Uncomment this to get a trace with environments. +%% eval(Env, Ast, _) :- +%% format("EVAL: ~F in ~V\n", [Ast, Env]), +%% fail. % Proceed with normal alternatives. + +eval(Env, List, Res) :- + list([First | Args], List), !, + eval_list(Env, First, Args, Res). + +eval(_, nil, nil). +eval(_, true, true). +eval(_, false, false). +eval(Env, Symbol, Res) :- + atom(Symbol), !, + check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). + +eval(Env, Vector, Res) :- + vector(Xs, Vector), !, + maplist(eval(Env), Xs, Ys), + vector(Ys, Res). + +eval(Env, Map, Res) :- + map_map(eval(Env), Map, Res). + +eval(_, Anything_Else, Anything_Else). + +% Print + +print(Ast) :- format("~F\n", [Ast]). + +% REP + +rep(Env) :- + mal_read(Ast), + eval(Env, Ast, Evaluated), + print(Evaluated). + +% Main program + +repl(Env) :- + catch(rep(Env), mal_error(Message), writeln(Message)), + repl(Env). + +re(Env, String) :- + read_str(String, Ast), + eval(Env, Ast, _). + +define_core_function(Env, Symbol, Core_Function) :- + mal_fn(wrap_failure(Core_Function), Form), + env_set(Env, Symbol, Form). + +core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). + +main(Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + env(Env), + core_ns(Core_Ns), + map_keyvals(define_core_function(Env), Core_Ns), + define_core_function(Env, eval, core_eval(Env)), + + re(Env, "(def! not (fn* [a] (if a false true)))"), + re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), + re(Env, "(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)))))))"), + + ( maplist(atom_string, Argv, [Script | Args]) + + -> % If Argv starts with a script, set arguments and load it. + list(Args, Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + format(string(Load_Script), "(load-file \"~s\")", [Script]), + re(Env, Load_Script) + + ; % else read from standard input. + list([], Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + catch(repl(Env), exit_repl, nl) + ), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/step9_try.pl b/impls/prolog/step9_try.pl index 3c396be101..78c888da6d 100644 --- a/impls/prolog/step9_try.pl +++ b/impls/prolog/step9_try.pl @@ -1,241 +1,241 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -:- consult([core, env, printer, reader, types, utils]). - -% Read - -mal_read(Ast) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true), % fails for duplicate lines - read_str(Line, Ast). - -% Eval non-empty list depending on their first element. -:- discontiguous eval_list/4. - -eval_list(Env, 'def!', Args, Res) :- !, - check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "def!: ~F is not a symbol", [Key]), - eval(Env, Form, Res), - env_set(Env, Key, Res). - -eval_list(Env, 'let*', Args, Res) :- !, - check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), - env(Env, Let_Env), - check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), - eval(Let_Env, Form, Res). - -let_loop(Env, Key, Form) :- !, - check(atom(Key), "let*: ~F is not a key", [Key]), - eval(Env, Form, Value), - env_set(Env, Key, Value). - -eval_list(Env, if, Args, Res) :- !, - check(if_assign_args(Args, Form, Then, Else), - "if: expects 2 or 3 arguments, got: ~L", [Args]), - eval(Env, Form, Test), - if_select(Test, Then, Else, Selected), - eval(Env, Selected, Res). - -if_assign_args([Form, Then, Else], Form, Then, Else). -if_assign_args([Form, Then], Form, Then, nil). - -if_select(false, _, Else, Else) :- !. -if_select(nil, _, Else, Else) :- !. -if_select(_, Then, _, Then). - -eval_list(Env, 'fn*', Args, Res) :- !, - check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), - check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), - mal_fn(apply_fn(Keys, Form, Env), Res). - -apply_fn(Keys, Form, Env, Args, Res) :- - env(Env, Apply_Env), - check(env_bind(Apply_Env, Keys, Args), - "cannot apply fn*[~L] to [~L]", [Keys, Args]), - eval(Apply_Env, Form, Res). - -eval_list(Env, do, Args, Res) :- !, - foldl(do_loop(Env), Args, nil, Res). - -do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). - -eval_list(_, quote, Args, Res) :- !, - check(Args = [Res], "quote: expects 1 argument, got ~L", [Args]). - -eval_list(_, quasiquoteexpand, Args, Res) :- !, - check(Args = [X], "quasiquoteexpand: expects 1 argument, got: ~L", [Args]), - quasiquote(X, Res). - -eval_list(Env, quasiquote, Args, Res) :- !, - check(Args = [X], "quasiquote: expects 1 argument, got: ~L", [Args]), - quasiquote(X, Y), - eval(Env, Y, Res). - -quasiquote(List, Res) :- - list(Xs, List), !, - ( Xs = [unquote | Args] - -> check(Args = [Res], "unquote: expects 1 argument, got: ", [Args]) - ; list([], Empty), - foldr(qq_loop, Empty, Xs, Res)). -quasiquote(Vector, Res) :- - vector(Xs, Vector), !, - list([], Empty), - foldr(qq_loop, Empty, Xs, Y), - list([vec, Y], Res). -quasiquote(nil, nil). -quasiquote(true, true). -quasiquote(false, false). -quasiquote(Symbol_Or_Map, Res) :- - (atom(Symbol_Or_Map) -> true ; is_map(Symbol_Or_Map)), !, - list([quote, Symbol_Or_Map], Res). -quasiquote(Anything_Else, Anything_Else). - -qq_loop(Elt, Acc, Res) :- - list(['splice-unquote' | Args], Elt), !, - check(Args = [X], "splice-unquote: expects 1 argument, got:", [Args]), - list([concat, X, Acc], Res). -qq_loop(Elt, Acc, Res) :- - quasiquote(Elt, Quasiquoted), - list([cons, Quasiquoted, Acc], Res). - -eval_list(Env, 'try*', Args, Res) :- !, - ( Args = [Test] - -> eval(Env, Test, Res) - ; check(Args = [Test, Catch], - "try*: expects 1 or 2 arguments, got: ~L", [Args]), - check(list(['catch*', Key, Form], Catch), - "try*: ~F is not a catch* list", [Catch]), - check(atom(Key), "catch*: ~F is not a key", [Key]), - catch(eval(Env, Test, Res), mal_error(Error), - (env(Env, Try_Env), - env_set(Try_Env, Key, Error), - eval(Try_Env, Form, Res)))). - -eval_list(Env, 'defmacro!', Args, Res) :- !, - check(Args = [Key, Form], - "defmacro!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "defmacro!: ~F is not a key", [Key]), - eval(Env, Form, Fn), - check(mal_fn(_Goal, Fn), "defmacro!: ~F is not a function", [Fn]), - mal_macro(Fn, Res), - env_set(Env, Key, Res). - -eval_list(Env, macroexpand, Args, Res) :- !, - check(Args = [X], "macroexpand: expects 1 argument, got: ~L", [Args]), - macroexpand(Env, X, Res). - -macroexpand(Env, Ast, Res) :- - list([Key | Args], Ast), - env_get(Env, Key, Macro), - mal_macro(Fn, Macro), !, - mal_fn(Goal, Fn), - call(Goal, Args, New_Ast), - macroexpand(Env, New_Ast, Res). -macroexpand(_, Ast, Ast). - -% apply phase - -eval_list(Env, First, Rest, Res) :- - eval(Env, First, Fn), - ( mal_macro(F, Fn) - -> % If the Fn macro refers to F, apply F then evaluate, - mal_fn(Goal, F), - call(Goal, Rest, New_Ast), - eval(Env, New_Ast, Res) - ; % else evaluate arguments, apply Fn. - check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), - maplist(eval(Env), Rest, Args), - call(Goal, Args, Res)). - -% The eval function itself. - -% Uncomment this to get a trace with environments. -%% eval(Env, Ast, _) :- -%% format("EVAL: ~F in ~V\n", [Ast, Env]), -%% fail. % Proceed with normal alternatives. - -eval(Env, List, Res) :- - list([First | Args], List), !, - eval_list(Env, First, Args, Res). - -eval(_, nil, nil). -eval(_, true, true). -eval(_, false, false). -eval(Env, Symbol, Res) :- - atom(Symbol), !, - check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). - -eval(Env, Vector, Res) :- - vector(Xs, Vector), !, - maplist(eval(Env), Xs, Ys), - vector(Ys, Res). - -eval(Env, Map, Res) :- - map_map(eval(Env), Map, Res). - -eval(_, Anything_Else, Anything_Else). - -% Print - -print(Ast) :- format("~F\n", [Ast]). - -% REP - -rep(Env) :- - mal_read(Ast), - eval(Env, Ast, Evaluated), - print(Evaluated). - -% Main program - -repl(Env) :- - catch(rep(Env), mal_error(X), format("Exception: ~F\n", [X])), - repl(Env). - -re(Env, String) :- - read_str(String, Ast), - eval(Env, Ast, _). - -define_core_function(Env, Symbol, Core_Function) :- - mal_fn(wrap_failure(Core_Function), Form), - env_set(Env, Symbol, Form). - -core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). - -main(Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - env(Env), - core_ns(Core_Ns), - map_keyvals(define_core_function(Env), Core_Ns), - define_core_function(Env, eval, core_eval(Env)), - - re(Env, "(def! not (fn* [a] (if a false true)))"), - re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), - re(Env, "(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)))))))"), - - ( maplist(atom_string, Argv, [Script | Args]) - - -> % If Argv starts with a script, set arguments and load it. - list(Args, Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - format(string(Load_Script), "(load-file \"~s\")", [Script]), - re(Env, Load_Script) - - ; % else read from standard input. - list([], Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - catch(repl(Env), exit_repl, nl) - ), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +:- consult([core, env, printer, reader, types, utils]). + +% Read + +mal_read(Ast) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true), % fails for duplicate lines + read_str(Line, Ast). + +% Eval non-empty list depending on their first element. +:- discontiguous eval_list/4. + +eval_list(Env, 'def!', Args, Res) :- !, + check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "def!: ~F is not a symbol", [Key]), + eval(Env, Form, Res), + env_set(Env, Key, Res). + +eval_list(Env, 'let*', Args, Res) :- !, + check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), + env(Env, Let_Env), + check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), + eval(Let_Env, Form, Res). + +let_loop(Env, Key, Form) :- !, + check(atom(Key), "let*: ~F is not a key", [Key]), + eval(Env, Form, Value), + env_set(Env, Key, Value). + +eval_list(Env, if, Args, Res) :- !, + check(if_assign_args(Args, Form, Then, Else), + "if: expects 2 or 3 arguments, got: ~L", [Args]), + eval(Env, Form, Test), + if_select(Test, Then, Else, Selected), + eval(Env, Selected, Res). + +if_assign_args([Form, Then, Else], Form, Then, Else). +if_assign_args([Form, Then], Form, Then, nil). + +if_select(false, _, Else, Else) :- !. +if_select(nil, _, Else, Else) :- !. +if_select(_, Then, _, Then). + +eval_list(Env, 'fn*', Args, Res) :- !, + check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), + check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), + mal_fn(apply_fn(Keys, Form, Env), Res). + +apply_fn(Keys, Form, Env, Args, Res) :- + env(Env, Apply_Env), + check(env_bind(Apply_Env, Keys, Args), + "cannot apply fn*[~L] to [~L]", [Keys, Args]), + eval(Apply_Env, Form, Res). + +eval_list(Env, do, Args, Res) :- !, + foldl(do_loop(Env), Args, nil, Res). + +do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). + +eval_list(_, quote, Args, Res) :- !, + check(Args = [Res], "quote: expects 1 argument, got ~L", [Args]). + +eval_list(_, quasiquoteexpand, Args, Res) :- !, + check(Args = [X], "quasiquoteexpand: expects 1 argument, got: ~L", [Args]), + quasiquote(X, Res). + +eval_list(Env, quasiquote, Args, Res) :- !, + check(Args = [X], "quasiquote: expects 1 argument, got: ~L", [Args]), + quasiquote(X, Y), + eval(Env, Y, Res). + +quasiquote(List, Res) :- + list(Xs, List), !, + ( Xs = [unquote | Args] + -> check(Args = [Res], "unquote: expects 1 argument, got: ", [Args]) + ; list([], Empty), + foldr(qq_loop, Empty, Xs, Res)). +quasiquote(Vector, Res) :- + vector(Xs, Vector), !, + list([], Empty), + foldr(qq_loop, Empty, Xs, Y), + list([vec, Y], Res). +quasiquote(nil, nil). +quasiquote(true, true). +quasiquote(false, false). +quasiquote(Symbol_Or_Map, Res) :- + (atom(Symbol_Or_Map) -> true ; is_map(Symbol_Or_Map)), !, + list([quote, Symbol_Or_Map], Res). +quasiquote(Anything_Else, Anything_Else). + +qq_loop(Elt, Acc, Res) :- + list(['splice-unquote' | Args], Elt), !, + check(Args = [X], "splice-unquote: expects 1 argument, got:", [Args]), + list([concat, X, Acc], Res). +qq_loop(Elt, Acc, Res) :- + quasiquote(Elt, Quasiquoted), + list([cons, Quasiquoted, Acc], Res). + +eval_list(Env, 'try*', Args, Res) :- !, + ( Args = [Test] + -> eval(Env, Test, Res) + ; check(Args = [Test, Catch], + "try*: expects 1 or 2 arguments, got: ~L", [Args]), + check(list(['catch*', Key, Form], Catch), + "try*: ~F is not a catch* list", [Catch]), + check(atom(Key), "catch*: ~F is not a key", [Key]), + catch(eval(Env, Test, Res), mal_error(Error), + (env(Env, Try_Env), + env_set(Try_Env, Key, Error), + eval(Try_Env, Form, Res)))). + +eval_list(Env, 'defmacro!', Args, Res) :- !, + check(Args = [Key, Form], + "defmacro!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "defmacro!: ~F is not a key", [Key]), + eval(Env, Form, Fn), + check(mal_fn(_Goal, Fn), "defmacro!: ~F is not a function", [Fn]), + mal_macro(Fn, Res), + env_set(Env, Key, Res). + +eval_list(Env, macroexpand, Args, Res) :- !, + check(Args = [X], "macroexpand: expects 1 argument, got: ~L", [Args]), + macroexpand(Env, X, Res). + +macroexpand(Env, Ast, Res) :- + list([Key | Args], Ast), + env_get(Env, Key, Macro), + mal_macro(Fn, Macro), !, + mal_fn(Goal, Fn), + call(Goal, Args, New_Ast), + macroexpand(Env, New_Ast, Res). +macroexpand(_, Ast, Ast). + +% apply phase + +eval_list(Env, First, Rest, Res) :- + eval(Env, First, Fn), + ( mal_macro(F, Fn) + -> % If the Fn macro refers to F, apply F then evaluate, + mal_fn(Goal, F), + call(Goal, Rest, New_Ast), + eval(Env, New_Ast, Res) + ; % else evaluate arguments, apply Fn. + check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), + maplist(eval(Env), Rest, Args), + call(Goal, Args, Res)). + +% The eval function itself. + +% Uncomment this to get a trace with environments. +%% eval(Env, Ast, _) :- +%% format("EVAL: ~F in ~V\n", [Ast, Env]), +%% fail. % Proceed with normal alternatives. + +eval(Env, List, Res) :- + list([First | Args], List), !, + eval_list(Env, First, Args, Res). + +eval(_, nil, nil). +eval(_, true, true). +eval(_, false, false). +eval(Env, Symbol, Res) :- + atom(Symbol), !, + check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). + +eval(Env, Vector, Res) :- + vector(Xs, Vector), !, + maplist(eval(Env), Xs, Ys), + vector(Ys, Res). + +eval(Env, Map, Res) :- + map_map(eval(Env), Map, Res). + +eval(_, Anything_Else, Anything_Else). + +% Print + +print(Ast) :- format("~F\n", [Ast]). + +% REP + +rep(Env) :- + mal_read(Ast), + eval(Env, Ast, Evaluated), + print(Evaluated). + +% Main program + +repl(Env) :- + catch(rep(Env), mal_error(X), format("Exception: ~F\n", [X])), + repl(Env). + +re(Env, String) :- + read_str(String, Ast), + eval(Env, Ast, _). + +define_core_function(Env, Symbol, Core_Function) :- + mal_fn(wrap_failure(Core_Function), Form), + env_set(Env, Symbol, Form). + +core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). + +main(Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + env(Env), + core_ns(Core_Ns), + map_keyvals(define_core_function(Env), Core_Ns), + define_core_function(Env, eval, core_eval(Env)), + + re(Env, "(def! not (fn* [a] (if a false true)))"), + re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), + re(Env, "(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)))))))"), + + ( maplist(atom_string, Argv, [Script | Args]) + + -> % If Argv starts with a script, set arguments and load it. + list(Args, Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + format(string(Load_Script), "(load-file \"~s\")", [Script]), + re(Env, Load_Script) + + ; % else read from standard input. + list([], Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + catch(repl(Env), exit_repl, nl) + ), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/stepA_mal.pl b/impls/prolog/stepA_mal.pl index 0f713d70f6..cf37e05a28 100644 --- a/impls/prolog/stepA_mal.pl +++ b/impls/prolog/stepA_mal.pl @@ -1,244 +1,244 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- initialization(main, main). - -:- consult([core, env, printer, reader, types, utils]). - -% Read - -mal_read(Ast) :- - write("user> "), - read_line_to_string(current_input, Line), - (Line = end_of_file -> throw(exit_repl) ; true), - (rl_add_history(Line) -> true ; true), % fails for duplicate lines - read_str(Line, Ast). - -% Eval non-empty list depending on their first element. -:- discontiguous eval_list/4. - -eval_list(Env, 'def!', Args, Res) :- !, - check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "def!: ~F is not a symbol", [Key]), - eval(Env, Form, Res), - env_set(Env, Key, Res). - -eval_list(Env, 'let*', Args, Res) :- !, - check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), - env(Env, Let_Env), - check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), - eval(Let_Env, Form, Res). - -let_loop(Env, Key, Form) :- !, - check(atom(Key), "let*: ~F is not a key", [Key]), - eval(Env, Form, Value), - env_set(Env, Key, Value). - -eval_list(Env, if, Args, Res) :- !, - check(if_assign_args(Args, Form, Then, Else), - "if: expects 2 or 3 arguments, got: ~L", [Args]), - eval(Env, Form, Test), - if_select(Test, Then, Else, Selected), - eval(Env, Selected, Res). - -if_assign_args([Form, Then, Else], Form, Then, Else). -if_assign_args([Form, Then], Form, Then, nil). - -if_select(false, _, Else, Else) :- !. -if_select(nil, _, Else, Else) :- !. -if_select(_, Then, _, Then). - -eval_list(Env, 'fn*', Args, Res) :- !, - check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), - check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), - check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), - mal_fn(apply_fn(Keys, Form, Env), Res). - -apply_fn(Keys, Form, Env, Args, Res) :- - env(Env, Apply_Env), - check(env_bind(Apply_Env, Keys, Args), - "cannot apply fn*[~L] to [~L]", [Keys, Args]), - eval(Apply_Env, Form, Res). - -eval_list(Env, do, Args, Res) :- !, - foldl(do_loop(Env), Args, nil, Res). - -do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). - -eval_list(_, quote, Args, Res) :- !, - check(Args = [Res], "quote: expects 1 argument, got ~L", [Args]). - -eval_list(_, quasiquoteexpand, Args, Res) :- !, - check(Args = [X], "quasiquoteexpand: expects 1 argument, got: ~L", [Args]), - quasiquote(X, Res). - -eval_list(Env, quasiquote, Args, Res) :- !, - check(Args = [X], "quasiquote: expects 1 argument, got: ~L", [Args]), - quasiquote(X, Y), - eval(Env, Y, Res). - -quasiquote(List, Res) :- - list(Xs, List), !, - ( Xs = [unquote | Args] - -> check(Args = [Res], "unquote: expects 1 argument, got: ", [Args]) - ; list([], Empty), - foldr(qq_loop, Empty, Xs, Res)). -quasiquote(Vector, Res) :- - vector(Xs, Vector), !, - list([], Empty), - foldr(qq_loop, Empty, Xs, Y), - list([vec, Y], Res). -quasiquote(nil, nil). -quasiquote(true, true). -quasiquote(false, false). -quasiquote(Symbol_Or_Map, Res) :- - (atom(Symbol_Or_Map) -> true ; is_map(Symbol_Or_Map)), !, - list([quote, Symbol_Or_Map], Res). -quasiquote(Anything_Else, Anything_Else). - -qq_loop(Elt, Acc, Res) :- - list(['splice-unquote' | Args], Elt), !, - check(Args = [X], "splice-unquote: expects 1 argument, got:", [Args]), - list([concat, X, Acc], Res). -qq_loop(Elt, Acc, Res) :- - quasiquote(Elt, Quasiquoted), - list([cons, Quasiquoted, Acc], Res). - -eval_list(Env, 'try*', Args, Res) :- !, - ( Args = [Test] - -> eval(Env, Test, Res) - ; check(Args = [Test, Catch], - "try*: expects 1 or 2 arguments, got: ~L", [Args]), - check(list(['catch*', Key, Form], Catch), - "try*: ~F is not a catch* list", [Catch]), - check(atom(Key), "catch*: ~F is not a key", [Key]), - catch(eval(Env, Test, Res), mal_error(Error), - (env(Env, Try_Env), - env_set(Try_Env, Key, Error), - eval(Try_Env, Form, Res)))). - -eval_list(Env, 'defmacro!', Args, Res) :- !, - check(Args = [Key, Form], - "defmacro!: expects 2 arguments, got: ~L", [Args]), - check(atom(Key), "defmacro!: ~F is not a key", [Key]), - eval(Env, Form, Fn), - check(mal_fn(_Goal, Fn), "defmacro!: ~F is not a function", [Fn]), - mal_macro(Fn, Res), - env_set(Env, Key, Res). - -eval_list(Env, macroexpand, Args, Res) :- !, - check(Args = [X], "macroexpand: expects 1 argument, got: ~L", [Args]), - macroexpand(Env, X, Res). - -macroexpand(Env, Ast, Res) :- - list([Key | Args], Ast), - env_get(Env, Key, Macro), - mal_macro(Fn, Macro), !, - mal_fn(Goal, Fn), - call(Goal, Args, New_Ast), - macroexpand(Env, New_Ast, Res). -macroexpand(_, Ast, Ast). - -% apply phase - -eval_list(Env, First, Rest, Res) :- - eval(Env, First, Fn), - ( mal_macro(F, Fn) - -> % If the Fn macro refers to F, apply F then evaluate, - mal_fn(Goal, F), - call(Goal, Rest, New_Ast), - eval(Env, New_Ast, Res) - ; % else evaluate arguments, apply Fn. - check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), - maplist(eval(Env), Rest, Args), - call(Goal, Args, Res)). - -% The eval function itself. - -% Uncomment this to get a trace with environments. -%% eval(Env, Ast, _) :- -%% format("EVAL: ~F in ~V\n", [Ast, Env]), -%% fail. % Proceed with normal alternatives. - -eval(Env, List, Res) :- - list([First | Args], List), !, - eval_list(Env, First, Args, Res). - -eval(_, nil, nil). -eval(_, true, true). -eval(_, false, false). -eval(Env, Symbol, Res) :- - atom(Symbol), !, - check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). - -eval(Env, Vector, Res) :- - vector(Xs, Vector), !, - maplist(eval(Env), Xs, Ys), - vector(Ys, Res). - -eval(Env, Map, Res) :- - map_map(eval(Env), Map, Res). - -eval(_, Anything_Else, Anything_Else). - -% Print - -print(Ast) :- format("~F\n", [Ast]). - -% REP - -rep(Env) :- - mal_read(Ast), - eval(Env, Ast, Evaluated), - print(Evaluated). - -% Main program - -repl(Env) :- - catch(rep(Env), mal_error(X), format("Exception: ~F\n", [X])), - repl(Env). - -re(Env, String) :- - read_str(String, Ast), - eval(Env, Ast, _). - -define_core_function(Env, Symbol, Core_Function) :- - mal_fn(wrap_failure(Core_Function), Form), - env_set(Env, Symbol, Form). - -core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). - -main(Argv) :- - getenv("HOME", Home), - string_concat(Home, "/.mal-history", History), - (exists_file(History) -> rl_read_history(History) ; true), - - env(Env), - core_ns(Core_Ns), - map_keyvals(define_core_function(Env), Core_Ns), - define_core_function(Env, eval, core_eval(Env)), - - env_set(Env, '*host-language*', "prolog"), - - re(Env, "(def! not (fn* [a] (if a false true)))"), - re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), - re(Env, "(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)))))))"), - - ( maplist(atom_string, Argv, [Script | Args]) - - -> % If Argv starts with a script, set arguments and load it. - list(Args, Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - format(string(Load_Script), "(load-file \"~s\")", [Script]), - re(Env, Load_Script) - - ; % else read from standard input. - list([], Mal_Argv), - env_set(Env, '*ARGV*', Mal_Argv), - - re(Env, "(println (str \"Mal [\" *host-language* \"]\"))"), - catch(repl(Env), exit_repl, nl) - ), - - (rl_write_history(History) -> true ; true). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- initialization(main, main). + +:- consult([core, env, printer, reader, types, utils]). + +% Read + +mal_read(Ast) :- + write("user> "), + read_line_to_string(current_input, Line), + (Line = end_of_file -> throw(exit_repl) ; true), + (rl_add_history(Line) -> true ; true), % fails for duplicate lines + read_str(Line, Ast). + +% Eval non-empty list depending on their first element. +:- discontiguous eval_list/4. + +eval_list(Env, 'def!', Args, Res) :- !, + check(Args = [Key, Form], "def!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "def!: ~F is not a symbol", [Key]), + eval(Env, Form, Res), + env_set(Env, Key, Res). + +eval_list(Env, 'let*', Args, Res) :- !, + check(Args = [Binds, Form], "let*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Binds, Xs), "let*: ~F is not a sequence", [Binds]), + env(Env, Let_Env), + check(map_keyvals(let_loop(Let_Env), Xs), "let*: odd length: ~L", [Binds]), + eval(Let_Env, Form, Res). + +let_loop(Env, Key, Form) :- !, + check(atom(Key), "let*: ~F is not a key", [Key]), + eval(Env, Form, Value), + env_set(Env, Key, Value). + +eval_list(Env, if, Args, Res) :- !, + check(if_assign_args(Args, Form, Then, Else), + "if: expects 2 or 3 arguments, got: ~L", [Args]), + eval(Env, Form, Test), + if_select(Test, Then, Else, Selected), + eval(Env, Selected, Res). + +if_assign_args([Form, Then, Else], Form, Then, Else). +if_assign_args([Form, Then], Form, Then, nil). + +if_select(false, _, Else, Else) :- !. +if_select(nil, _, Else, Else) :- !. +if_select(_, Then, _, Then). + +eval_list(Env, 'fn*', Args, Res) :- !, + check(Args = [Params, Form], "fn*: expects 2 arguments, got: ~L", [Args]), + check(unbox_seq(Params, Keys), "fn*: ~F is not a sequence", [Params]), + check(maplist(atom, Keys), "fn*: ~F should contains symbols", [Params]), + mal_fn(apply_fn(Keys, Form, Env), Res). + +apply_fn(Keys, Form, Env, Args, Res) :- + env(Env, Apply_Env), + check(env_bind(Apply_Env, Keys, Args), + "cannot apply fn*[~L] to [~L]", [Keys, Args]), + eval(Apply_Env, Form, Res). + +eval_list(Env, do, Args, Res) :- !, + foldl(do_loop(Env), Args, nil, Res). + +do_loop(Env, Elt, _Old_Acc, New_Acc) :- eval(Env, Elt, New_Acc). + +eval_list(_, quote, Args, Res) :- !, + check(Args = [Res], "quote: expects 1 argument, got ~L", [Args]). + +eval_list(_, quasiquoteexpand, Args, Res) :- !, + check(Args = [X], "quasiquoteexpand: expects 1 argument, got: ~L", [Args]), + quasiquote(X, Res). + +eval_list(Env, quasiquote, Args, Res) :- !, + check(Args = [X], "quasiquote: expects 1 argument, got: ~L", [Args]), + quasiquote(X, Y), + eval(Env, Y, Res). + +quasiquote(List, Res) :- + list(Xs, List), !, + ( Xs = [unquote | Args] + -> check(Args = [Res], "unquote: expects 1 argument, got: ", [Args]) + ; list([], Empty), + foldr(qq_loop, Empty, Xs, Res)). +quasiquote(Vector, Res) :- + vector(Xs, Vector), !, + list([], Empty), + foldr(qq_loop, Empty, Xs, Y), + list([vec, Y], Res). +quasiquote(nil, nil). +quasiquote(true, true). +quasiquote(false, false). +quasiquote(Symbol_Or_Map, Res) :- + (atom(Symbol_Or_Map) -> true ; is_map(Symbol_Or_Map)), !, + list([quote, Symbol_Or_Map], Res). +quasiquote(Anything_Else, Anything_Else). + +qq_loop(Elt, Acc, Res) :- + list(['splice-unquote' | Args], Elt), !, + check(Args = [X], "splice-unquote: expects 1 argument, got:", [Args]), + list([concat, X, Acc], Res). +qq_loop(Elt, Acc, Res) :- + quasiquote(Elt, Quasiquoted), + list([cons, Quasiquoted, Acc], Res). + +eval_list(Env, 'try*', Args, Res) :- !, + ( Args = [Test] + -> eval(Env, Test, Res) + ; check(Args = [Test, Catch], + "try*: expects 1 or 2 arguments, got: ~L", [Args]), + check(list(['catch*', Key, Form], Catch), + "try*: ~F is not a catch* list", [Catch]), + check(atom(Key), "catch*: ~F is not a key", [Key]), + catch(eval(Env, Test, Res), mal_error(Error), + (env(Env, Try_Env), + env_set(Try_Env, Key, Error), + eval(Try_Env, Form, Res)))). + +eval_list(Env, 'defmacro!', Args, Res) :- !, + check(Args = [Key, Form], + "defmacro!: expects 2 arguments, got: ~L", [Args]), + check(atom(Key), "defmacro!: ~F is not a key", [Key]), + eval(Env, Form, Fn), + check(mal_fn(_Goal, Fn), "defmacro!: ~F is not a function", [Fn]), + mal_macro(Fn, Res), + env_set(Env, Key, Res). + +eval_list(Env, macroexpand, Args, Res) :- !, + check(Args = [X], "macroexpand: expects 1 argument, got: ~L", [Args]), + macroexpand(Env, X, Res). + +macroexpand(Env, Ast, Res) :- + list([Key | Args], Ast), + env_get(Env, Key, Macro), + mal_macro(Fn, Macro), !, + mal_fn(Goal, Fn), + call(Goal, Args, New_Ast), + macroexpand(Env, New_Ast, Res). +macroexpand(_, Ast, Ast). + +% apply phase + +eval_list(Env, First, Rest, Res) :- + eval(Env, First, Fn), + ( mal_macro(F, Fn) + -> % If the Fn macro refers to F, apply F then evaluate, + mal_fn(Goal, F), + call(Goal, Rest, New_Ast), + eval(Env, New_Ast, Res) + ; % else evaluate arguments, apply Fn. + check(mal_fn(Goal, Fn), "cannot apply, ~F is not a function", [Fn]), + maplist(eval(Env), Rest, Args), + call(Goal, Args, Res)). + +% The eval function itself. + +% Uncomment this to get a trace with environments. +%% eval(Env, Ast, _) :- +%% format("EVAL: ~F in ~V\n", [Ast, Env]), +%% fail. % Proceed with normal alternatives. + +eval(Env, List, Res) :- + list([First | Args], List), !, + eval_list(Env, First, Args, Res). + +eval(_, nil, nil). +eval(_, true, true). +eval(_, false, false). +eval(Env, Symbol, Res) :- + atom(Symbol), !, + check(env_get(Env, Symbol, Res), "'~F' not found", [Symbol]). + +eval(Env, Vector, Res) :- + vector(Xs, Vector), !, + maplist(eval(Env), Xs, Ys), + vector(Ys, Res). + +eval(Env, Map, Res) :- + map_map(eval(Env), Map, Res). + +eval(_, Anything_Else, Anything_Else). + +% Print + +print(Ast) :- format("~F\n", [Ast]). + +% REP + +rep(Env) :- + mal_read(Ast), + eval(Env, Ast, Evaluated), + print(Evaluated). + +% Main program + +repl(Env) :- + catch(rep(Env), mal_error(X), format("Exception: ~F\n", [X])), + repl(Env). + +re(Env, String) :- + read_str(String, Ast), + eval(Env, Ast, _). + +define_core_function(Env, Symbol, Core_Function) :- + mal_fn(wrap_failure(Core_Function), Form), + env_set(Env, Symbol, Form). + +core_eval(Env, [Ast], Res) :- eval(Env, Ast, Res). + +main(Argv) :- + getenv("HOME", Home), + string_concat(Home, "/.mal-history", History), + (exists_file(History) -> rl_read_history(History) ; true), + + env(Env), + core_ns(Core_Ns), + map_keyvals(define_core_function(Env), Core_Ns), + define_core_function(Env, eval, core_eval(Env)), + + env_set(Env, '*host-language*', "prolog"), + + re(Env, "(def! not (fn* [a] (if a false true)))"), + re(Env, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), + re(Env, "(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)))))))"), + + ( maplist(atom_string, Argv, [Script | Args]) + + -> % If Argv starts with a script, set arguments and load it. + list(Args, Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + format(string(Load_Script), "(load-file \"~s\")", [Script]), + re(Env, Load_Script) + + ; % else read from standard input. + list([], Mal_Argv), + env_set(Env, '*ARGV*', Mal_Argv), + + re(Env, "(println (str \"Mal [\" *host-language* \"]\"))"), + catch(repl(Env), exit_repl, nl) + ), + + (rl_write_history(History) -> true ; true). diff --git a/impls/prolog/tests/stepA_mal.mal b/impls/prolog/tests/stepA_mal.mal index 9b4dabdd7a..949ff39e91 100644 --- a/impls/prolog/tests/stepA_mal.mal +++ b/impls/prolog/tests/stepA_mal.mal @@ -1,29 +1,29 @@ -;; Testing basic prolog interop - -(prolog-call "1+") -;/.*prolog-call: .*syntax_error.* -(prolog-call "atom_length(\"ab\")") -;=>2 -(prolog-call "atom_concat(\"ab\", \"cd\")") -;=>abcd -(prolog-call "number_string(42)") -;=>"42" -(prolog-call "=(mal_kwd(\"kw\"))") -;=>:kw -(prolog-call "list([a, b])") -;=>(a b) -(prolog-call "vector([a, b])") -;=>[a b] -(prolog-call "'hash-map'([\"a\", 1])") -;=>{"a" 1} -(meta (prolog-call "=(mal_vector([a, b], 12))")) -;=>12 -(prolog-call "=(mal_list([1, mal_formed(1)]))") -;/.*prolog-call: invalid result.* - -(prolog-asserta "(mal_setenv(Name, Value, nil) :- setenv(Name, Value))") -;=>nil -(prolog-call "mal_setenv(\"answer\", 42)") -;=>nil -(prolog-call "getenv(\"answer\")") -;=>42 +;; Testing basic prolog interop + +(prolog-call "1+") +;/.*prolog-call: .*syntax_error.* +(prolog-call "atom_length(\"ab\")") +;=>2 +(prolog-call "atom_concat(\"ab\", \"cd\")") +;=>abcd +(prolog-call "number_string(42)") +;=>"42" +(prolog-call "=(mal_kwd(\"kw\"))") +;=>:kw +(prolog-call "list([a, b])") +;=>(a b) +(prolog-call "vector([a, b])") +;=>[a b] +(prolog-call "'hash-map'([\"a\", 1])") +;=>{"a" 1} +(meta (prolog-call "=(mal_vector([a, b], 12))")) +;=>12 +(prolog-call "=(mal_list([1, mal_formed(1)]))") +;/.*prolog-call: invalid result.* + +(prolog-asserta "(mal_setenv(Name, Value, nil) :- setenv(Name, Value))") +;=>nil +(prolog-call "mal_setenv(\"answer\", 42)") +;=>nil +(prolog-call "getenv(\"answer\")") +;=>42 diff --git a/impls/prolog/types.pl b/impls/prolog/types.pl index 57312d12a3..c4e046bf07 100644 --- a/impls/prolog/types.pl +++ b/impls/prolog/types.pl @@ -1,181 +1,181 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -:- discontiguous mal_equal/2. -:- discontiguous 'with-meta'/2. -:- discontiguous meta/2. -:- discontiguous valid_mal/1. - -% A MAL number is represented by a Prolog integer. - -% A MAL symbol is represented by a Prolog atom, -% including `false`, `nil` and `true`. - -% A MAL string is represented by a Prolog string. - -% A MAL keyword is represented as mal_kwd(String), and there is no -% reason to encapsulate this information. - -% The remaining representations are encapsulated because they may have -% to evolve, and interfer directly with metadata. - -mal_equal(X, X) :- atomic(X), !. -mal_equal(mal_kwd(S), mal_kwd(S)) :- !. - -valid_mal(X) :- integer(X), !. -valid_mal(X) :- atom(X), !. -valid_mal(X) :- string(X), !. -valid_mal(mal_kwd(S)) :- !, string(S). - -% Sequences - -% list(?Forms, ?List) -% Bi-directional conversion between a list of MAL forms and a MAL list. -% At least one of the two arguments must be instantiated. -% Fails if the second argument is instantiated but not a MAL list. -% vector(?Forms, ?Vector) -% Similar for MAL vectors. - -list(Forms, mal_list(Forms)) :- !. -list(Forms, mal_list(Forms, _Meta)) :- !. - -vector(Forms, mal_vector(Forms)) :- !. -vector(Forms, mal_vector(Forms, _Meta)) :- !. - -mal_equal(S1, S2) :- - unbox_seq(S1, L1), !, - unbox_seq(S2, L2), - maplist(mal_equal, L1, L2). - -'with-meta'([X, Meta], mal_list( Forms, Meta)) :- list( Forms, X), !. -'with-meta'([X, Meta], mal_vector(Forms, Meta)) :- vector(Forms, X), !. - -meta([mal_list(_, Meta)], Meta) :- !. -meta([mal_vector(_, Meta)], Meta) :- !. - -valid_mal(mal_list(F)) :- !, maplist(valid_mal, F). -valid_mal(mal_list(F, M)) :- !, maplist(valid_mal, F), valid_mal(M). -valid_mal(mal_vector(F)) :- !, maplist(valid_mal, F). -valid_mal(mal_vector(F, M)) :- !, maplist(valid_mal, F), valid_mal(M). - -% Maps - -% Other files should not directly depend on Assoc, as there may be -% good reasons to change the map representation. - -'hash-map'(Key_Value_List, mal_map(Res)) :- - empty_assoc(Assoc), - check(foldl_keyvals(assoc, Assoc, Key_Value_List, Res), - "hash-map: odd count of key and values in ~L", [Key_Value_List]). - -is_map(mal_map(_Assoc)) :- !. -is_map(mal_map(_Assoc, _Meta)) :- !. - -is_key(Key) :- string(Key), !. -is_key(mal_kwd(_)) :- !. - -unbox_map(mal_map(Assoc), Assoc) :- !. -unbox_map(mal_map(Assoc, _Meta), Assoc) :- !. - -get(Map, Key, Res) :- - unbox_map(Map, Assoc), - is_key(Key), - get_assoc(Key, Assoc, Res). - -assoc([Map | Key_Value_List], mal_map(Res)) :- - unbox_map(Map, Assoc), - check(foldl_keyvals(assoc, Assoc, Key_Value_List, Res), - "assoc: odd count of key and values in [~L]", [Key_Value_List]). - -assoc(Assoc, Key, Value, Res) :- - check(is_key(Key), "map keys must be strings or symbol, not ~F", [Key]), - put_assoc(Key, Assoc, Value, Res). - -% This order of parameter is convenient with foldl. -dissoc(Key, Map, mal_map(Res)) :- - unbox_map(Map, Assoc), - is_key(Key), - % del_assoc fails if the key did previously exist, - % and we do not want to search twice. - (del_assoc(Key, Assoc, _Value, Res) -> true ; Res = Assoc). - -map_map(Goal, Map, mal_map(Res)) :- - unbox_map(Map, Assoc), - map_assoc(Goal, Assoc, Res). - -keys([Map], Res) :- - unbox_map(Map, Assoc), - assoc_to_keys(Assoc, Keys), - list(Keys, Res). - -vals([Map], Res) :- - unbox_map(Map, Assoc), - assoc_to_values(Assoc, Vals), - list(Vals, Res). - -% MAL map -> key/value Prolog list -% Fail if the form is not a map. -map_to_key_value_list(Map, Forms) :- - unbox_map(Map, Assoc), - assoc_to_list(Assoc, Pairs), - foldr(convert_pair, [], Pairs, Forms). - -convert_pair(Key - Value, Acc, [Key, Value | Acc]). - -mal_equal(Map1, Map2) :- - unbox_map(Map1, Assoc1), !, - unbox_map(Map2, Assoc2), - % map_assoc(mal_equal) does not work here because its result - % depends on the internal structure. - assoc_to_list(Assoc1, Pairs1), - assoc_to_list(Assoc2, Pairs2), - maplist(map_pair_equal, Pairs1, Pairs2). - -map_pair_equal(K1 - V1, K2 - V2) :- K1 = K2, mal_equal(V1, V2). - -'with-meta'([X, Meta], mal_map(Assoc, Meta)) :- unbox_map(X, Assoc), !. - -meta([mal_map(_, Meta)], Meta) :- !. - -valid_mal(mal_map(Assoc)) :- !, - is_assoc(Assoc), - assoc_to_list(Assoc, Pairs), - maplist(valid_mal_pair, Pairs). -valid_mal(mal_map(Assoc, Meta)) :- !, - is_assoc(Assoc), - assoc_to_list(Assoc, Pairs), - maplist(valid_mal_pair, Pairs), - valid_mal(Meta). - -valid_mal_pair(K - V) :- is_key(K), valid_mal(V). - -% Functions - -% Goal is called with call(Goal, [Arg1, Arg2..], Res). -% It should never fail, and use mal_error/1 to report problems. - -mal_fn(Goal, mal_fn(Goal)) :- !. -mal_fn(Goal, mal_fn(Goal, _Meta)) :- !. - -'with-meta'([mal_fn(Goal), Meta], mal_fn(Goal, Meta)) :- !. -'with-meta'([mal_fn(Goal, _Meta), Meta], mal_fn(Goal, Meta)) :- !. - -meta([mal_fn(_,Meta)], Meta) :- !. - -valid_mal(mal_fn(_)) :- !. -valid_mal(mal_fn(_, Meta)) :- !, valid_mal(Meta). - -% Macros - -mal_macro(Fn, mal_macro(Fn)). - -% Atoms - -mal_atom(Value, mal_atom(Value)). - -set_mal_atom_value(Atom, Value) :- setarg(1, Atom, Value). - -valid_mal(mal_atom(Value)) :- !, valid_mal(Value). - -% Catch-all clause for objects without metadata. - -meta([_], nil) :- !. +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +:- discontiguous mal_equal/2. +:- discontiguous 'with-meta'/2. +:- discontiguous meta/2. +:- discontiguous valid_mal/1. + +% A MAL number is represented by a Prolog integer. + +% A MAL symbol is represented by a Prolog atom, +% including `false`, `nil` and `true`. + +% A MAL string is represented by a Prolog string. + +% A MAL keyword is represented as mal_kwd(String), and there is no +% reason to encapsulate this information. + +% The remaining representations are encapsulated because they may have +% to evolve, and interfer directly with metadata. + +mal_equal(X, X) :- atomic(X), !. +mal_equal(mal_kwd(S), mal_kwd(S)) :- !. + +valid_mal(X) :- integer(X), !. +valid_mal(X) :- atom(X), !. +valid_mal(X) :- string(X), !. +valid_mal(mal_kwd(S)) :- !, string(S). + +% Sequences + +% list(?Forms, ?List) +% Bi-directional conversion between a list of MAL forms and a MAL list. +% At least one of the two arguments must be instantiated. +% Fails if the second argument is instantiated but not a MAL list. +% vector(?Forms, ?Vector) +% Similar for MAL vectors. + +list(Forms, mal_list(Forms)) :- !. +list(Forms, mal_list(Forms, _Meta)) :- !. + +vector(Forms, mal_vector(Forms)) :- !. +vector(Forms, mal_vector(Forms, _Meta)) :- !. + +mal_equal(S1, S2) :- + unbox_seq(S1, L1), !, + unbox_seq(S2, L2), + maplist(mal_equal, L1, L2). + +'with-meta'([X, Meta], mal_list( Forms, Meta)) :- list( Forms, X), !. +'with-meta'([X, Meta], mal_vector(Forms, Meta)) :- vector(Forms, X), !. + +meta([mal_list(_, Meta)], Meta) :- !. +meta([mal_vector(_, Meta)], Meta) :- !. + +valid_mal(mal_list(F)) :- !, maplist(valid_mal, F). +valid_mal(mal_list(F, M)) :- !, maplist(valid_mal, F), valid_mal(M). +valid_mal(mal_vector(F)) :- !, maplist(valid_mal, F). +valid_mal(mal_vector(F, M)) :- !, maplist(valid_mal, F), valid_mal(M). + +% Maps + +% Other files should not directly depend on Assoc, as there may be +% good reasons to change the map representation. + +'hash-map'(Key_Value_List, mal_map(Res)) :- + empty_assoc(Assoc), + check(foldl_keyvals(assoc, Assoc, Key_Value_List, Res), + "hash-map: odd count of key and values in ~L", [Key_Value_List]). + +is_map(mal_map(_Assoc)) :- !. +is_map(mal_map(_Assoc, _Meta)) :- !. + +is_key(Key) :- string(Key), !. +is_key(mal_kwd(_)) :- !. + +unbox_map(mal_map(Assoc), Assoc) :- !. +unbox_map(mal_map(Assoc, _Meta), Assoc) :- !. + +get(Map, Key, Res) :- + unbox_map(Map, Assoc), + is_key(Key), + get_assoc(Key, Assoc, Res). + +assoc([Map | Key_Value_List], mal_map(Res)) :- + unbox_map(Map, Assoc), + check(foldl_keyvals(assoc, Assoc, Key_Value_List, Res), + "assoc: odd count of key and values in [~L]", [Key_Value_List]). + +assoc(Assoc, Key, Value, Res) :- + check(is_key(Key), "map keys must be strings or symbol, not ~F", [Key]), + put_assoc(Key, Assoc, Value, Res). + +% This order of parameter is convenient with foldl. +dissoc(Key, Map, mal_map(Res)) :- + unbox_map(Map, Assoc), + is_key(Key), + % del_assoc fails if the key did previously exist, + % and we do not want to search twice. + (del_assoc(Key, Assoc, _Value, Res) -> true ; Res = Assoc). + +map_map(Goal, Map, mal_map(Res)) :- + unbox_map(Map, Assoc), + map_assoc(Goal, Assoc, Res). + +keys([Map], Res) :- + unbox_map(Map, Assoc), + assoc_to_keys(Assoc, Keys), + list(Keys, Res). + +vals([Map], Res) :- + unbox_map(Map, Assoc), + assoc_to_values(Assoc, Vals), + list(Vals, Res). + +% MAL map -> key/value Prolog list +% Fail if the form is not a map. +map_to_key_value_list(Map, Forms) :- + unbox_map(Map, Assoc), + assoc_to_list(Assoc, Pairs), + foldr(convert_pair, [], Pairs, Forms). + +convert_pair(Key - Value, Acc, [Key, Value | Acc]). + +mal_equal(Map1, Map2) :- + unbox_map(Map1, Assoc1), !, + unbox_map(Map2, Assoc2), + % map_assoc(mal_equal) does not work here because its result + % depends on the internal structure. + assoc_to_list(Assoc1, Pairs1), + assoc_to_list(Assoc2, Pairs2), + maplist(map_pair_equal, Pairs1, Pairs2). + +map_pair_equal(K1 - V1, K2 - V2) :- K1 = K2, mal_equal(V1, V2). + +'with-meta'([X, Meta], mal_map(Assoc, Meta)) :- unbox_map(X, Assoc), !. + +meta([mal_map(_, Meta)], Meta) :- !. + +valid_mal(mal_map(Assoc)) :- !, + is_assoc(Assoc), + assoc_to_list(Assoc, Pairs), + maplist(valid_mal_pair, Pairs). +valid_mal(mal_map(Assoc, Meta)) :- !, + is_assoc(Assoc), + assoc_to_list(Assoc, Pairs), + maplist(valid_mal_pair, Pairs), + valid_mal(Meta). + +valid_mal_pair(K - V) :- is_key(K), valid_mal(V). + +% Functions + +% Goal is called with call(Goal, [Arg1, Arg2..], Res). +% It should never fail, and use mal_error/1 to report problems. + +mal_fn(Goal, mal_fn(Goal)) :- !. +mal_fn(Goal, mal_fn(Goal, _Meta)) :- !. + +'with-meta'([mal_fn(Goal), Meta], mal_fn(Goal, Meta)) :- !. +'with-meta'([mal_fn(Goal, _Meta), Meta], mal_fn(Goal, Meta)) :- !. + +meta([mal_fn(_,Meta)], Meta) :- !. + +valid_mal(mal_fn(_)) :- !. +valid_mal(mal_fn(_, Meta)) :- !, valid_mal(Meta). + +% Macros + +mal_macro(Fn, mal_macro(Fn)). + +% Atoms + +mal_atom(Value, mal_atom(Value)). + +set_mal_atom_value(Atom, Value) :- setarg(1, Atom, Value). + +valid_mal(mal_atom(Value)) :- !, valid_mal(Value). + +% Catch-all clause for objects without metadata. + +meta([_], nil) :- !. diff --git a/impls/prolog/utils.pl b/impls/prolog/utils.pl index 854fe3551b..5bd69509e1 100644 --- a/impls/prolog/utils.pl +++ b/impls/prolog/utils.pl @@ -1,46 +1,46 @@ -% -*- mode: prolog; -*- select prolog mode in the emacs text editor - -% Convenient shortcuts, especially during steps 1 to 6. - -% Similar to "assert", but raise an non-fatal error. -check(Condition, _, _) :- call(Condition), !. -check(_, Format, Arguments) :- throwf(Format, Arguments). - -throwf(Format, Arguments) :- - format(string(Message), Format, Arguments), - throw(mal_error(Message)). - -% Convenient shortcut: unbox(+Sequence, -List). - -unbox_seq(Sequence, Forms) :- list(Forms, Sequence). -unbox_seq(Sequence, Forms) :- vector(Forms, Sequence). - -% Abstract some loops. - -% foldr(Goal, Vn, [X1, X2,...,Xn], V0) :- -% Goal(Xn, Vn, Vn-1), -% ... -% Goal(X2, V2, V1), -% Goal(X1, V1, V0), -foldr(_, Vn, [], Vn). -foldr(Goal, Vn, [X|Xs], V0) :- - foldr(Goal, Vn, Xs, V1), - call(Goal, X, V1, V0). - -% foldl_keyvals(Goal, Init, [K1, V1, K2, V2, K3, V3], Acc3) :- -% Goal(Init, K1, V1, Acc1), -% Goal(Acc1, K2, V2, Acc2), -% Goal(Acc2, K3, V3, Acc3). -foldl_keyvals(_, Init, [], Init). -foldl_keyvals(Goal, Init, [K, V | KVs], Res) :- - call(Goal, Init, K, V, Acc), - foldl_keyvals(Goal, Acc, KVs, Res). - -% map_keyvals(Goal, [K1, V1, K2, V2, K3, V3]) :- -% Goal(K1, V1), -% Goal(K2, V2), -% Goal(K3, V3). -map_keyvals(_, []). -map_keyvals(Goal, [K, V | KVs]) :- - call(Goal, K, V), - map_keyvals(Goal, KVs). +% -*- mode: prolog; -*- select prolog mode in the emacs text editor + +% Convenient shortcuts, especially during steps 1 to 6. + +% Similar to "assert", but raise an non-fatal error. +check(Condition, _, _) :- call(Condition), !. +check(_, Format, Arguments) :- throwf(Format, Arguments). + +throwf(Format, Arguments) :- + format(string(Message), Format, Arguments), + throw(mal_error(Message)). + +% Convenient shortcut: unbox(+Sequence, -List). + +unbox_seq(Sequence, Forms) :- list(Forms, Sequence). +unbox_seq(Sequence, Forms) :- vector(Forms, Sequence). + +% Abstract some loops. + +% foldr(Goal, Vn, [X1, X2,...,Xn], V0) :- +% Goal(Xn, Vn, Vn-1), +% ... +% Goal(X2, V2, V1), +% Goal(X1, V1, V0), +foldr(_, Vn, [], Vn). +foldr(Goal, Vn, [X|Xs], V0) :- + foldr(Goal, Vn, Xs, V1), + call(Goal, X, V1, V0). + +% foldl_keyvals(Goal, Init, [K1, V1, K2, V2, K3, V3], Acc3) :- +% Goal(Init, K1, V1, Acc1), +% Goal(Acc1, K2, V2, Acc2), +% Goal(Acc2, K3, V3, Acc3). +foldl_keyvals(_, Init, [], Init). +foldl_keyvals(Goal, Init, [K, V | KVs], Res) :- + call(Goal, Init, K, V, Acc), + foldl_keyvals(Goal, Acc, KVs, Res). + +% map_keyvals(Goal, [K1, V1, K2, V2, K3, V3]) :- +% Goal(K1, V1), +% Goal(K2, V2), +% Goal(K3, V3). +map_keyvals(_, []). +map_keyvals(Goal, [K, V | KVs]) :- + call(Goal, K, V), + map_keyvals(Goal, KVs). diff --git a/impls/ps/Dockerfile b/impls/ps/Dockerfile index d91f68e1ea..fa0b7cf0df 100644 --- a/impls/ps/Dockerfile +++ b/impls/ps/Dockerfile @@ -1,25 +1,25 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# PostScript/ghostscript -RUN apt-get -y install ghostscript +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# PostScript/ghostscript +RUN apt-get -y install ghostscript diff --git a/impls/ps/Makefile b/impls/ps/Makefile index 98a0d37408..4a14644e1f 100644 --- a/impls/ps/Makefile +++ b/impls/ps/Makefile @@ -1,20 +1,20 @@ -SOURCES_BASE = types.ps reader.ps printer.ps -SOURCES_LISP = env.ps core.ps stepA_mal.ps -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.ps mal - -mal.ps: $(SOURCES) - cat $+ | grep -v "runlibfile$$" > $@ - -mal: mal.ps - echo "#!/bin/sh" > $@ - echo "\":\" pop pop pop pop %#; exec gs -d'#!'=null -d'\":\"'=null -q -dNODISPLAY -- \"\$$0\" \"\$$@\"" >> $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.ps mal +SOURCES_BASE = types.ps reader.ps printer.ps +SOURCES_LISP = env.ps core.ps stepA_mal.ps +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.ps mal + +mal.ps: $(SOURCES) + cat $+ | grep -v "runlibfile$$" > $@ + +mal: mal.ps + echo "#!/bin/sh" > $@ + echo "\":\" pop pop pop pop %#; exec gs -d'#!'=null -d'\":\"'=null -q -dNODISPLAY -- \"\$$0\" \"\$$@\"" >> $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.ps mal diff --git a/impls/ps/core.ps b/impls/ps/core.ps index 2554110ed75f10c7b28c6a502ac7530490ac2ff1..ab7b68c3f8c24c092cfadc985108306b3833de98 100644 GIT binary patch literal 9208 zcmcgxOK%*x5k9W~{RieSfSf=cYrVM`j*ShlKrRd9kegyOs2PsbR!?_tcaLO2(0|YO zRk29+%vch#ixsfz>8fI}UaSYXa6|ZQR}W!y(?cJ|xBYl}a(c3GzYIe+jLToXtwKN5 zT^qq`KY4fl$xSyycaI+={g1!Jaz9+v)8K~(Cp5lYE79oc$$8*g7mV54)03rgcy#Yv z)lN6A((fm?4jYx=-$Pi}D?bIo?de^&Z>zit`YgZH!6mC&(TnQtg zbIYw?4c%vV9VRyoyWqlauI(nF=D%A%+=eyf6hba~lHFXvoUCmtp>XvkG-EhDNn+bR zua$H+hJh;AEp{(?9~W7bJ0hyvcnIR24kcQ+fBEso{p$O~Kl<|W28b=-x8cFv`Nq9{ z`}PZ+>&LNM@kbl(t4IWoDfrR-|8hO9>8o zLHsO)+(ig&g)${h|LEr?wATm|;Z?1=T|2o8H}0<7kFH+Vch0ZZZb5+~)R40w7HaOzSlE?nthbMCr6?%fFg6WlB3Hu_V1v2ShI zfbleQ^B-#MU7LLSN0?R)4bO?VgTalng9EigW?0VPno`67@jxuxIQiA>2UXdK)z^&s zcGomaR+`uh?`kAe*VavrxW4Nh|KoxfHCV&+`A1N7UQUuEIe! z?ykN%iedH=*?8QeY%te|FnIsE>>HY})tHKUq=;WOBSL@&Ec!fQh)9Qy2{p>k%*9xI z=Y%WL5;Ezg9zae&XroI=bK%G(yAQ;5JB5MuWr1b`NJ+h@z`7L0i2M(&wx7#rhM&bk z{}dCgJILCiL7)#W1&bV~1Wa~tXC^5kENTd4>{NZ-K`P~?!cZW(7N%3<6Y%t?4TlvU zUCslBwjfFZ)yBHLZUUN~u+7ZO2QW}|7gkd@SgWF6rzbyfi)^+-bNs;Ct{frB0_J1m z!Bzab{2~FF0hv`)UFpg_ROZm4#meg}nlt236tc2TBmF4C9EAr_&Vne8VtWS{A->@f ze!Mz}$weYH+Ak}WVpa<6(P(CIC4*RLnn~M7wL_GT{h(?ZyFJ04LC6oTMv?gDIs`ks zI{5ZFyop_ET#*vrEK+&KFQIFWQT8g(zuj%G0;;%1C4uuq!_!kCrN=f`<&-Eqlu%=M zUyhV#RD#sc=}}EC(9c(HUX~NxkAhXg&D37OPgICId2q=$YAqu%X zCy8~{5=qPuh!)``9`b$PJkUL0vujub6!M5nCe`GHHn$AV6{>*0!r@R>E zeX&?trBw^3aRY|RgMjRlt*Sk#3;@8WEVL;-$#s52q7R2=O%~m>+%3m77poe`1@FOU z=+IZp|Bftnn>dH*`mow_oQ8IyvJ~%BVx|~Y=52QuFcam7RkY|FW2;n4v4_QBmJE@I zSm31ATP8rneYIF1QW7R@@Lei35c|ci2${dX>Rc{4OhR6D=QH&~{2p3o^wIN97tRh9 zU}%bR>ETjtVJy@<2``q5JByvH=Fc5&Ty#3b_WPpnJi7!e8Y*=GonAUg$Kvw~gwKBI zKR%R_K^CH9B_$NQE6cbIfjXbMG@z12F-esi42B^*i;amR9{g*AA@ zykS=sgyfh*ry{vH8&UAu$;L)l22FI9#AInjb_JG=D;e&4?s=9uYwicccXk`60iCoQ z8SbW^a|NQ`RDq15%(-n*4d&Pd%idiWrpVS!9lXA}@q=GsR*BF!nUDehsNY_c5sYXN zN#leB);Gq$Fz@EObJb4{2UM~<^EoxOf8LS7;ey#wBL~akb5aT!%_4Tr*aM%6!$~i} zwV;t_7Yf;gGH=u^M!0${Ej5ncE{}bb<_sbFLHZlqV|Fd>R@-xcWYRs}HYc|q{@6Pt zED*nj$;;KDm4Ca#qyk$YrJ1|0C)~l{%T5xoI6fI1{ilO!?lIyyN~Kj;$Xe<~>S)t^ zUFA?SyiXn`5BWLVFFgeig zIz#Z6^x!m|_P|!lsEZ05&5`?#WS_mRbA`UU!gU#DuGVkE*n3>KVT>nyFPMz<<3|>qC^3;y)J=SWOcNNgT+`cqsXPgh*^7~jPV!D(K&!}h9cW=uu_?NMN#yp2+19dW68-wo@MB!Uu`_&sA|utcP{ASI2a zC62k*sL0Gw$V_G-y!wd&AsHV44Xm$uqEdX=115T-AI@O`!R0VNb8qzBuj+>iX!Py4 z05x_>FAgl0yorx$N0;XV2zLl;u4C6uO0WMi`%dMcfwIsQ?0-A zwcdd!Kg^YW9e=VGn8iP;@t!$kxUWmZb|k-hA|Zkie|nMgb>{r(Mb6im^WR?N%;~}8 zIDe6vbDdHD^+oFKu1VC(7pdh<)R<58Hk@xq`j$R`OB#a6E(RedQsG$!;bEg*P|LAQ zfe=Rx+fYXXFr2YF7>$xXiYb#q8a9k2-=ofPXEZ-2`8`S=L3IGPC7{;ik;SxEt(-~Z zQJbni#%FI^t?!|tLwp)F40<536_yykO8TN`9@IvC>!PgbBPolN2v?NHs3IugQ2-6k zpM{sSp`L2gp5mNV1voLmw#I}%OE_LkRIBuUVv4~Hrr3U0WzQDHV4Ha2w%nHScHg+k zjV}>M-SSps2=rYRZ2XxPgl#`P&|}$O#e{0B1*B}{d50J2hLfvX#px}sAtZ3r=Dc?V zIQ!}=7pSK&`9?TwDqz6zvsl1c;+!ovJ&*?rTc;S|Cw;lWJ-XPqPc&^sP}+|l60BKw m0VM+Ic~v!Se~q(tvA{g?3Y!hCVWef$CE7g#@#&M^U;Pgyo^w$E literal 8862 zcmcIpOK;pp5Vd#dj`1M;A`l;?(0dD-{ z-T5as-3;A5egN;^{uVp^a8*x(A0C{b_;#Z>qpK(9vEI61l-{li-T&y`xw4&ZT&dqr zZWFfT{jVWx>dH?6Op9&%**&gY#Kn)zzIWx$H|2KURum2EZe4F(4g;QZ#m-kl_t{;C z$xXvPxbVAcyGfAw@6HdmVMF-@5qqA<$z_yD*Z6SV)!WdFVHIUH4zCk%KZb!i)-AYZ zR8LE)DjiGcwjL53iL!S8^y7{D&G(74`0Vlq;2og1;lbVc#=U*}_6wcp$FZyUqYd|E zL|PRJeRMxNxL|Tu;ks_sn0~k(>BSpylh}70s#4HoEqb$%5TMQJPQfDw!Ltnl=92!= zrA=tB5eq`8th#+WxeGV$uiQ_r-qd%_Z#HgCStI5l2}-N$!l~OL0{wIvx$1gEYLxB* z9FDmnq_*AQf``7eT)p|0I2QO=T7qgMC6yX+B)aF%3sFLW{eBX9PY!J4SK2SmK!o?@ zcIb9uxK%(#rToZUYTn$`C*2vr|8IXvQbrGo`421%%^5ulzy1#`yl>5!f7YCm8B7MT zKZ6(vf~?txRj~j|p%ArW*st9<`RewAYHGORS%!DJZyMGgEmgMcYSc#8)=i47zUv+T zBfbU*cCh5Qd=IPFa-SsTg+^QwC2c_jCk}IXK|N)0P}SBhk1#Pw)wPqa+wn8)an*Ir zs+d7XwwOym5=H#a&=8I%rIo-jNpIWkzO^zt3naq8A7k`O+0^5-Dg>fp99ALWcd6<6 zsQ=Ku5-1)%`638HNAt}OgMTp2=td*jV`!^zP*%IEua3;kJR%WuSS5mWMmYQZYszS7 z!cM~`3UAR|G$Z`X%!!`01;SG@u`;UAEJF;ocTPy6#-Jo_>jBsVgjTIjlnX~1v!j4p zw^JC{A=VfPuqY)IO;dM{r|q;XOw|1sG0Q*1E}ITgwrJ&a*QKnYU?~DC*Q%H?<|vAq zK?}>5uY1U<c_FN-x4*Vs3svJ?dy+y+b!MbY2;9QI%P$gj>3b%l8Y@;#UWE-UCZM#-;xz$| zWFQ@zPtp&IV`LEGm|aZ#!l?@$K@6`7{(fbkl7xg~G}x?)1*WvdQxVH{$nCL7G?NT< zs(X}-bDF59Q<$usLAnpFMt%S0I)pPEIQaHDyop1j;#>X7f)R;(3H9bExBV58c#XmRHegB|=IYFrY6v2y?3^QYIg0!wBPIebD}LAR;y;6MqARdPnsQNbNCjjgZaSRI{c@ALdC@xG2#_aHNLX#LB-6MNlO&px_6R0qD&I5s4!&`zXf)nFgpb$07(Y~MG~`ce*20D`P(a!ui&{2 za;pEnU;M?-p>>8HJ?(VgB6R@6*pk`?canioP@~wgm@Bds>sWhUIM`_DQ4G8fnJ{)?Aq6%WPL_4NjI*hn>M-(gC5cHVL|8selH7r- zo+mh0!$bd{<~2?OW?M-O^3uyI5RD&XG{Nm(*WxC! zJqJk6mM6#AELdF?GgQ5$N5gqM zh^dl#qY&UuYDDB{#QD<4q3y++5J6^M<{RE8cantsr412Ra@m9zPKA(?T%~&#leTDQ zit*o-Vyi-j3gn{jz8j}HTuR6<^)MVv2=0|}ot?shsw!Ezm_Sw0FV2c^J-fZu0t84p z{V^ue2Q^J-xTx&JH5LdJ<`J}Rxo9V53d5)>ocznw?eaT_ViSh2U7lZ3$;eFPryXyw z#7vl2!t^5}01!D1@N;&3w3Zn9@G>dVNuED3MkPn`79q!1xlZ_xNL%SfHqDIpz847@ z3?ijMUU@_%L1}JL6&oQgMV@3I_eIAvL0#Ve>XD$7;eS5!i`vi4@q!@aqT#Y3Ief$8 z2&T4v=qkaJnVx=@(U{g+^dTytqDCX68NrOQ7zr!P!X>VoaPn#WE{wg$Z52++gfAk- z5I=qtDbD`>hBDw!uTD;QzeIuZI1WGQ26?FArpNdO6yZEF3$6K0M^4eU4UaFfJ}>h< zCXtmF4I<3z3NpU2wY|v@A}C=z?5?_IL1Glp5&=wR9*U5pz}4e@H*9i@2r?S+b3w#l zhNBk@If|AU9x$)bL|JoCX`*HDx+QjlRD9@)P<^)&W#SXo(@GuC59d%^R_0hfb8qy0 ztL%po%b28bWf*BGy0|Rc@g}|^o!Ze4t;v+_ILV_&JD%Lxf3QJ+Y7sP9vDjb<#WKAK zQC5AxTCjeW&=CBl!J}F38H34#-a!F2)rmuMVPwd*5=tu>*4XTao(iYHID>(=HSQN! z^{*cA4(acFtyd084hK8Gi9cD?qpd%x-JZ!O+XK7xLs!CxA$hPcrAYn^|VX{3at$etP~}+W85mCqs!e)Whzh~-rci8SbIpl9$j+5U z5x2{>i`U?hmRzzDj-o7&ClSu8PeFg=6=uq~ux@dM#c1VnS1)?tP)LEF37Z4{Ij3Tpe4h4=g)E4sGC`X}7&Rk{ xXw1@c`plLkBxi-WoT5<%Q&mW3)VNQlPb`T2IC;henecRj4tr0lPoLy+=)W#VVZQ(X diff --git a/impls/ps/env.ps b/impls/ps/env.ps index f6d5b88fe46378a0f561acff02d326f78ea512e2..18dfa459351462af1c0a93719bc7f4f612148626 100644 GIT binary patch literal 1494 zcmbtUO>f&U480rhf8fPkau~d>I}JtlL)t-bY&j9)$*wIY8I1h*@#({g>u#4BXd_YN z)8iwljM~x2p7u&t1IcUG5A=CQQlEvE7cBWl@HS2IV4UcQDpeZV%Y)KsLi}YLr9;%K z-cr{qZQN1rQ028eQZ;rY2KhEhZB)_xpo#LTFa;f?q1!}V+tCaCq#LPPHiM)})*dA= z{67?zt>Y4)pP$Lyfkbj4td9^*nRxPr9=%MB)CY6q?J(|XiXJvzRae##ECW8w_*@1! zN4A@XEy*_)AX7CxEJ2puk5p8ZjmhXFf3IDgzyKy+LeCH;a3n-?L1cd}8p??Ok8+J8 z8Z{VE_w6rH^nLN+P0Cjl6!D=_OQdC*A5e~Tp~H&Jjq0{{kh@))NL}$IR?IZX&|?rG zG-=I!>(~D{)nn862DSkceO+~M4%B7g(DCm~;rf$qFWMImfv)?b5bWnR+|-DW&2*s=0QCHh&E?Zp| jMr!_}yLEIB=GeCvx4+$SU9v$NE!ePbKE}V6v#@^vT^65S literal 1437 zcmbtU!EW0y488j+cyX5;2CwT*Ly>*RHVBR-Cqg{gwd5p&k$)ebB+GWvoob+sB$7{$ zc067#wcn={$Ns{3UJ;(Ai${gI0w|3amm>hhxmRBwx2u5t2;tSkiMw*+a zEvYxoJl8cntsvIU&s0k3LvlK)zYm_Fu7IW3w#W`g;717NHmLqwHk1?pAJhYkXtZ^r z?%O}2?ECV)dvxd|=;1?mRxs-XAKA`KQGk0QH>%s-+q0l6%BaIHc>eEDJ_{{a9IoOu8M diff --git a/impls/ps/interop.ps b/impls/ps/interop.ps index 8020ab0b0ef510bcf0f5521065dfefe3d7241637..5a92e57c89b50d4c9eb8b0fca2320a4e423dc4eb 100644 GIT binary patch delta 184 zcmeBSS;#U$n}?T6zo6JCH!(+{ns=h9HZL!i0uV$iq*f$n@J`HD5`_qW1VJFBv_Qeu zmUrR;RYu;)jf`RwZ*w#9PJE^a>Ua1pt&iDcAr2 delta 159 zcmZ3;(!(-An~O`opx7ukF-M_#qPaFVmjVz(E2LH=XH3jj5(aZYLLiV*TA*NSJ8_xn z9;8f|r2+RdLZ7EL>AgZ^@51(UzR!IKiX zJCnj#+=XIQ%<*SFhaMWX+svrZw9`TazS|X$`yx`vlK?Z$e5$EqImK9-aJT z`yoUMLn^u2BCpRRlsn^(j!?InNeN$*l&d{HbC4ol9OsukuX|Nm(JIQujFP+Qg|tFJ zJjks0yeh)!x>i3x9v+Hf@{%ehxaT8Qw%s0Glp@rOGwa$k7RQGy5t)mZy=s_TM+XMa zdaPM0f1$A1a*DBw75m%S5pK2%&U0+&VWeM?Wy@(8JfK3oU`@9*A^ zDbe|p>d&sOsJ3`_!IomRqU#KwIbQdjWaTJpksl%Xouk9wep<5Z8ACY53W z7bRq3DDW-h4XLf}Jsu@$+RDi3HPP3MJRgg9dl`p&Pb>??8h){d_RXfvtRu;9l=5z9 z%1qDaUOlV!MLo!SlGOwfi8vlF)gW8951#2LMvxD zN8@`>95}!Gi)lsbV;y9nx849RHll_v9rpng;H3EN_b-2trEX5YBP4ZU@^UlGDF8miQ8YQ> iiz>~r@ovE}-HAc7@m@;w#qhn9_U`ZfI)!Lxo4*0WH|qNU delta 1056 zcmZWoOK1~O6lL<6Brg+NZ4x7~?X@NPUOyRPs)+r#5V0E(mugFxCX+gL`cjjLABKPh z7lQbS7dOSNxa~slvvTQD5p?fXbm7XS?@j7Vq7NR!oO{l_=ia&V`0(@m6RMEz^i+=M zm91u_<05)MfZu1b!;#FcGHsDU!|w!489JgI5j5Z1d={DQtG&W{wSPrU;dGQ8>dQ-e6OxUJbhtkZvcdnfY5Wi^27dIGZE{rA z1w5;k1K(o0cuxg{w5`K(j@Nz7RTQP<^F-ZHhWl4GH1QR5R5YOUJd{{h> z;c|RtXn@#p1t*O=@iBZGA6E!o(((m&fYQq~5%eR0p6=)Xu_GpB+AY%u{{na=F&6Yl zxn(oFpBN9EP^Z~88NNvz8TQ4rZirkAzbB@JtqZa7$(t=N*a_^>g*M;djaz()0mvY3 zlVyBQ68$$xOkRVIx1#u!%#Zr3T``*LE%AxV|Lk|stE1OU+u9slZ{1T2Y&>OnH%W=_ z`zpRl7R6V|;P2!?9M&dB{E!@+JYskd&)}+-4K}715wX1?;v+2^BwfW_t%TpSizmEf zlGN7~DL~t?Y|FU=^)|0MR)Z6Lt7&nk;{CWT+Nn|1Q@YqqW$7eQ0rU PuS~tsG;EvnhDZJYW&s8B diff --git a/impls/ps/reader.ps b/impls/ps/reader.ps index f1d33a182006de851f09ed09ca74ef24f2a3afd8..9ed08fbb0fd4a5d11af5343afdef7e506de77e71 100644 GIT binary patch literal 9124 zcmeHNOK%%D5WXAme;@(~l7Kj}UUBRIMGs9+1#-zPa+S4~vbJ9BD*NyQg7Vw@4ToHk zD`_pEYJnCtU|UPhgERbQIGj~WWb%6%Wil7V%Sz_&R``&LJ1L@M7MGz6#XQRL;{5FV ztXHHDGMR=lj+UbH@$H*$Vv?*klg_03^|mWQIj?Ava(O2+(YfpohNJQOs}I)~n&AAb z1(iWKWs)29AOev`$$cz^W}Ii~QshO3!Cn+T6B9oPJc)~+ToLrB*)&ZepQehd=V%gZ zF&1GoD`4Dxl$@Ul{Iohz;>wyNU9o~z*h|x-Tgd0xf{jx{(6K!fWQAIp@_{0oC55=O zY-`aHahk4JE>VzZk`>G3zF3HRi3Q5%s1O?w%|ZR?^RI8k9SnG=G4`+=Vk80gvLGEW zM9j)8lTbQa1X(aEWM)-?Vf2AC;KTR|8by$VVl<{_`CX(LRJWj%y=eI=L&%uE2*S`B zL~|RmO2)bLS;z`ILgx51%B!^cN+iSpZkb$?0hnR#jW(R0$mF~rN7HIxICe>9k3lSE zj}ZhE3n`XCFCk?_fe4J5Q{nC36byELxDlt;y3FxA8a(_kqL zkZT~-M9m;&qJJAm``&IvA32teK8=f+N%$mf+rNfFYdDwk-tc->twEf!h&WO?Yow@=4c zE8FFPm4?INdO$UcJ|ZS|it>6BtD4_R^FU!=EYplo7VozLdWR#{>(*%PH*FE+f)Z~! z*AB5O+IOg!x`tLnyScln@xzIo&9XZa{B#j0{i~}kwqq3sGhKpV>P=UO4*t}~QQ3k8 ze`^y;2>5Cfv@rkFX+Zn#lP4(BWj)ep?7%Zeks``a=V{m4;O6jB6l*bRDC>!2Z)jDe z$c~^Q`*mqfZa~eAf1qM~C^VV$E?)D#Br`L3HN+F1BuynUD&SJp=`$m0uDjG2%~#kS~^^Ecm0(b)y_4{65#ega>o=_+9Fn>AM8zq zZYxkmu7|>9l$5!;!6?;MAQ^ptMiaJSm~|wQ!*V5T5fxHV)-YzE zrPhT9DD*C>x;W-7Yep3>qzt1ZIe7vPwhrAz9Sxp zsAx04PFAx*wjHq>cgBg#X|{iOn(a4HX^&)#c*$y4dZfgrZ#I+?RUxgCozp=;z*Dmt z*&EsFl>`~!IIrvFB&nn}r${2HB}nH;WUqM@q8=jC?Xj%AOPQ4>bcRxIC29=-a|Ws! z2U}J(40iFl1*LjlU`|}U2zC4&`Yxl@`R&uMUk0a2s)S-UWlq{o&fG>Pub9G^97M({ zH2`n{96zny#)K^`5vl>We7%Z~%s za(v!_^WW=^3f&^xKYn&pk&~M?faV)Efu_BU$X9VRlNV)jfE$PzyP|Fr;*S!M*>=4^ z)5oYjT&MS%LF2;p(C?0enw+z>I*U_8E3(q;;YOh48sL6_x>1u`2#>^o5v+iVjd+TR z#f4%p*oAkS;OuRzyRSzr+pfsl%TQ)`;dww%jr7^9;MH-QXB;#_Akv#?zTK$XEk(7> ziL}@BWAe@kOAgm0<;p1?9n&Dof){8sjZ+21XKdlNtB9%GKR{PZukk#s|OZN*G vQ4-2$>QeLln04^toC1Ld%v))SYy$=2NpL2~Z#x{u0J1W_g zWPTYi4!!9y%Yd-r)(S$e3^M#700DN~i77xKkuGdWag%QBj}I+_K9QsaiUzA&;AvIw zc|iEt1LdEL)1-z|HLn)lv>+;+YG44sD0#wwW(Q91|6n=EIO`gj=C%gj%tx zh5iSt0_?8}R==Q{nO9(Bz=q`po7!-6DK=#R*#7n9k1y9EPqB7a1lTybm!da&x)@!_ zzIaT_I3)UTD+{x>o2A(|(}sEFNFDNetsGXH)w&|UgB)m0{l_deMHh5qE9#ZZKG54; zjx+buNCWNNAPZi#>y?Ro+DPz#kouV1(DW#W`(j?Kvh>la&`xb1jwTq*ZQYKAGJiE9 zmZ6LN%=S=?Zc*g!M#%=?hGLy&1gLnQ|FAipD4Q;y>b~iUC>K;o)1^*?^=8lRpqU6c zgUsP)7ZLH-jLI+%+?(Ok$7&c}UiL8sn>bh~x`duLeIa`IRci+GgaUs1?K}ds{C4um z-#zw&ddChD6zRIYmZdvZ1IoX{O-8 zXBD_Ss>w6YB$}sU`{GRXk^H%4PpxXQYKLU7V!?riI*gxM9lNfOnK(6;!{TX>9TdL7 zq+w_Wr$-)83&Q9Qr-+_n!+p<5W7jzk*?tgu8g)u5N5`T}=!fd)K*tA|qI|>LI!el% zj}&a!jz{snZqKY#Gg_FIx3N6`UZw^15$L08wZxzVtW6ce^n3 zE#VAjzc!+ANF4Ri$2%wzZ}qfk=Nu$atbIe~@Zd?%7{qv!GLB8^JOPBqqZC;w{Sc|e z6E$P8sGbH-z>KvFFpd6T+~f(H(UkC>;dlxgYFgMbTt2a-88DjQ5T~*@pmUO^X#mfM zVVXw!#ft40@nyIA5Xy=b&*ti+;A88SQzP}=M41#(bry`Hyr>sP!6KNhbVEmP+G3Vz znS}mLh3!Vchxl{EQarf*ZPi*g6HhfU&n>Ky!9?5_(D%{tLko# z3L9NxMcBmx>^O^bO;=I5oqwQadR3L|?#Hg}BHczFsF6NRY70Bft1cz1e%JhGUUNta z%@{}XcB5!gIyzZO?Z|Y&15O%8i6m$z;t{uxpzmRt_ywOdkn7=v%C(K#%eJ$~jD=>N zJ&pg8)1&k0ouc?|i!P_CHLNl~p;;dh@_2*{>Dbkm$wapRd1xWJWqzEhWyffyU?Gc^+6KT3dA6vMxI@08?kr}ZGnqeI;oj$A)}9OTE*RRtM;udg%cbl3gydu4}G z+mdza-k*8u^|GID;%Fhy%jEU=Nf%SWlwbT)V)=EQ@TvC*y9XO|@98xV+|2x4C8i}Q z4aX`_VojpvEbgxbt}_Ghc+fp9Zt*%1BL!DRDboKK6{~ZWH$X*JTd?a*rZbnvxNN=g z<}Z{P-UYtCdM0|4WjOV!q?yc2u-@p!tU7@3iIdi@EqFA&^f8s?biBb0hf_GG{a_ws zS?~;lCc!p*Qb}%hX}O!?C8S%XM-pSd$K)t3XZ`2Fs$(eKc z&gIWxscEICKH^_1LpWlv%6N1-xIK#8`Bs?{g)Px3O}M_gxrOtb^O=fM(FrYeQZQ&! zukLY_0{rFp3eF?5?sH2OS#C^!jb}bcvod z&Sx{0%wd78IJ$7LXVEEb&#l&*$LH5ey=WXPIj4H_*KiybbWT~&Ee&yxO}*wrr&|@y zhb?&65^1}s?|J#0k34ATzGu`C`DDZ+6~U3cLy5C?(;TMv%%)L!oS?cWLwc}TzdS^d zVs)Hg61sS2dFQQ9*ecV`-K6*rMM|ekqhaVLNxr47w=|*I!cJ3TV#GNqzJubs{sM;N Bt5*O3 literal 566 zcmaKpPfNrw5XJBL6puooJypfCuwVs2bSdIVknVPBBO#6Xvlfj{*H<^UaGrBMlQxNFbkqw`HTC8m zM*&_rzJl|}Ecsw{20sv_Ho>prlvFVYH0_6^k1`I3l_qk~p;e-)-!@Mds9EcLw%|w~ z&T$pLokuuuVvuST)wX$je!XBpldyvO!HkODH`Rj2+9#w8MBhANzsHf3Gx?gx&4d zheRXkNl#BRt&2vhaaNjecOXYtVHby!yE1j?d*gW5Gngx|iodIujkXP>|c zlt`8Z7ut5$AF-AN_-i>0biX^u2-zhbY1Ok)78jT>q1!=of$qok7uMqnliCH0v{xoW zEBuN+VB;u6XEq22!e;Pcb81HB_F1!*qt9IIDGM@FmQ@%_>m(5OzS(~M`u)s4xJc-& zdx5GWD^$1L4Kqy>*FMA%Orb#(oSAh!?63E{qi8>0*#87ndRgca2ZdLmO=~Sq6ZO#O2G<(NG&4X%Kn*ZFr+b?Ey_~#5nOW7 zxAFnJ`UXCLNm`JaOEO<3Uw+@bFMrqHI@QU>CbSgA8L2&)w^0>>vt-0LRid#1&_s7x zRcC#GXwd7PVhLzhlxv0bl-^@TBd<8Y^$zU;re1c>X%cgYdNj_hb|arg3L}3u7anwjaogMt6*!**Hg^(SW3#U zG_OI!d<2K)GYHL35FYym=a_Pe)ner)lIu8qn7go%onFFhR?lH>myYW2STGI0{FQxC diff --git a/impls/ps/step2_eval.ps b/impls/ps/step2_eval.ps index 57bed6d92819c9b9ca44c1ed765349b766877539..300232bbaee6c698e8dd033fae61e95cd1c643d0 100644 GIT binary patch literal 2217 zcmbtW-*4MC5Pmn{|KT2LRPL~;zn+RVLxH(Kfnp1SVK41K(9$U;N|OpjB{2g3@4e%R zlH~;%un9Z^^82-852IJx*8_UHC*k`#Y72mCKDHVo8WBYCg#j1<7acd~T z8dAcqUcP<{T_ntPa!yVu$>o9qU2Q)81`o>x&{Yx)@V?qH1zF-1ew89)xftCz6TH=y z0`N`gE>cZiLv5-ETf8=Ih=}g?EMm#n`Ab$s4)PAxkk|vGK75cUY^(0D-+KEiy=G+^ zkSE#Z)cHLO`|kXm%Y1l)ue^DUaq>70qy+*{JYS~>jpk!hZD7i@3eHn;eede^cGI@z3l(mi; zh!R(%@j+V)CgQ%ELmAHeH-CNnGT%88EB2aJ|CZD^39hqZLp8zgl@384Sno|ZZwG)?_O84eJbb`EURd9%TAH>j4ij?*!zEO`SQ{0lKvS4HE8!6H87b&nO{B<&1==s}0;6QSgD8`zGDogE$zwV|Zt z<<;lk|I92;>wh)`1GYQ_`KFj(mU8janhv4vTPl}waVHb+mDsu_$w(^2&rjgGemmk` zJb~NycEpuW;7o098AxrA%AdynCFPku0waf{VJW~k@cF~jTCm=?%LR!=3_gXT?=W1@ z+#Wwk!c1g{_a>%h0Xn7hKvQn>$0u$U_NGuV9K`15tIg%`0XSFqk;LHJ7VCT}3@ C)Nxb* literal 2120 zcmbVNQES^U5PtWsxQB%~8=Kp1Po?cBtb@VWMj3nAhEVKtBdSQQEVm6M|9y9-$Vu7~ z*aAt;(s!r3(|4b%FgR;wt+5Dqa|{R%(D@El4^VAwJpetx3L0$b*R*JRgb5U7Tz1&M z?fNML)`5yLpl&ccS?+>y@#%Uo0d^=V#edc~NrJJ^+M%CAIq73#+!V?%1xfYr;OIT{ zkuX={D^8MLQB;=~=O5vr0Qyvf0lcs0oVl#<0w1HuDApd70N!d_RQ#)SAE^mP(3m>H z46lq!q0rs#hN>936MRzU2*)r5DHj-YdMY8^Y#NBF)=NqC)wqE`3y!~JAdca zHSjur^4=B35x+`hCICSBaw_hv=KE1y;3{bqoTpy;!8Oy-m3?aOY8}zhcgI$79{k-1 z%{ML!#Eeu2-VErX(Ww?@1l3~=W$y#rVjX=LBm5dIK9>EfMn?@)3pb+mL0bzZ;-cR{ zGMekY_<8u+O;oCuPOwb8i(JsttajbO?IMgjOl3oz*p$B}}etuKT%K=uYlv ze_bahV*>jMqdo&G;xw`nI&X}-L1ZVPlx8fBUlZY;Iy z-M_M3&X|Wq5C*%mC13$OFmM z#kWs|U?@xsOEEbT=kY9gS9IOJ>#*5kR(TPE591h&K}g&b@|F^<+ZE+!qw~=(#04sc zcgaeA-LO&p43T}~S`Tg@`P_!o7WGDc<%vZ@xGD)U--s|XLt-EeEH-1x9cqo!7AOgM Zwa$>_7E{~E0uD&8dxw2r+zcibe*tPeY-a!f diff --git a/impls/ps/step3_env.ps b/impls/ps/step3_env.ps index 0db73a2dfc53663892ab39afd7c5ba4383eb4474..28e2b33ec7ff8a14bad1e7cd78a79fe0a2f9b7f0 100644 GIT binary patch literal 2811 zcmb_e-;3im5PlEjf0#l8&Xv}iv=8OD+j7tp3Z-3^axd2+6nnf8Rb;O$XE!YQ-#at1 z?09!Cg|>N!Woc$KKfd|Kx$m4c+saskhaGx^Cur&hPEU}Z9X$cPzzIsM=-*UmTZ9G7 zXIVHl*nZQrOP1&@(Y8ljqJO#Hc;mur2j~tjr025*u%Y=ZSNycbiGOSZD%-U?$QErV zjax$ImmpEBuGZf{8%X9(ltoEApU=q9?dHRe@HC$R{c;imd@ObxSKQ(qzDm(zJ{#27 z6Fg{32Kb?L8z@n0C`}Pyi+9HL7AcHp7IT)JUb4uNk+-k}NeQsj`}ffbuT^{8Z)^Jl zU9&J1#J70NuJb)&*d5dzhIl|li>i3vp$kSwbuJc}u!hXm9u8Q9nu239{QER6`IRl? zr4Aa%F5h0&URw($;J%%TvN$`k`S{_N>B$MA*0}p;bd8X+PDRfq zyFJ#TofO|rw>!1hjU?wEqI>sl^x;x?lrL}aKLmJv4JtVnLttU45KfU=Kd_T z)6iFGF`uC;W77$AIn9*1@Banr;#G@`O-wNte21VK&w%ftnEgThB&dvPf~iD*qgs{VBYPr4=a9n|M;j9;>T)b(9HprIaZGAPz4dyIr z~1dtOxK*8>lw*AzNW*EQU7|XL#fP zb%yUyLORrkuA@GcKiW|aA4Xndm-u%@q($+oqV9-8SI~CbzQ+MI5n-dv88t*5N|`Ai zpK(|^;%D!}G_oW>x3M;t_M!k4r7UC0Q%o;;B^l-TCh1NG{N(wypeAVx?MuO%$Iy8P z#N6Fk3$m;b)zmMl>+24j`mw=!{L9e_P$d0nDh!h($`CRv(C{KsxN_d?04W8fJ{`~9jX(FDp z!L#w_vElK@4*}c=wwH*LIeSCEl4(1r2!X}>hRMp4y&}m$=vzXiuL;O~jpOG?L~{1k zl0?g{Ash==$Xx9knc;KdT+=AezP=#Hm>&e+ToBxMb`;Dn2%6Fy2Fdu<(pa!{-OOji zesRI2&AJx-H4XjYdnVQ?@+v->KxT+tsr2$f%gt{;G5fPNnF{_mqV;xj^BKxM5yI-G z!7>$AF5h@x`+@#PJ2dDO@|lvkUupijyF3%v-j|{SIT1}G<2pCt@k)I|q zg++ZvI`Yc1Q<@}t$w^^6ZVgSum`*D4FsC?Qm2sNb4yyJ5+HznPJx z#JfwNrGBtwX=XH<`Q{r{estDsT4NFJx9AZbq3?P)K0KL$j9WtK zmmu!1uGT-m5J=`$bVW&AE{f{&&4-WhSO7g0$pAjoTRx4<@C0w8Xi!WVI1 zJp>BO8X8jv*x;>k(G+<;H&wCZ%=n^A7T&@VBm}@h@863F9;)H6+jRCP+G1f^h<~!m z{_-AT)$P?S2AQYyL`A$C(FLQUGN*+MSVKlT4|}Xb=d+=|@`%l{e%0upfsFFbZRfSM zU;^%jnPhU}=Fbnm&K8akb@Jpt(JS7c52JXXTHo!I_Ff+tRVq3)o1Fk9X41*Fdf2L+ z?jeGz5EGB5B4bfupqWpU$`?03 zM)GGRek!yA42gMS_|y-g2r;h(YCpu2JZO!l(SkaRuD`q$<#u#+FkS2gS?K|55{spg zBp`I4{q2c-5)YiZX_}GK77@*i0FeZEw8qd?xX1gj%ygUQ*Jj zTg~^bi^R^>UWp1+L>+My_4+Y(rE?KkH?Hj>;hc-q7WIim+K% z)_WDL>L#;pts=ixvbXcIi|S*F~XhV{YpyDamQb&7bdoovys7z%|bP9ZaJU+*86qlKb*D z(cbGP!Y~PzO=dd;208uy_PX9Dx4IJNd|`KQ-;OrCwmtaETk{ngyuMaRZ&=s@!7&&P z{NNZyTj1tytq-yx+WNtAVO$nMQJ_mV!*xIW2h;^stB4||m}`7%R8n~YzJp@4K|Bd6 z1Djwf9Goi!5oWnznMz!95Q}nLoU}t2 zMC(yocbek_GZ_N;je|l*9TZzB?PHJL?IcjoduiR|#+^Sr%O0?`fV_dZFCk#NGV@->hmY z1WBE0p9$W)XCS=m%dyKC5CGG zfE53elMwu~=83rl1MkRY+JNXgM7ZrrSCINI@ST=OD>xRKCpl$inotBF-6{FVHTwWW z6$%LA896J=+gc$!IV%)XZ_px19szBaYS(9vAa3im1LhtqqF!Ild3*lL01McAn&vc4 z;Hr>xgK6qeo5L}FMj^L7S2O11-pzcA3dx{B_?(a1?-I#L^XI0|HSx@IH_asYo+|s= ztkz{S=7w7|IC<;R#+F@M6ZU$fu!H&+L5|jqu>h#&)?>6ncc#;St^^u$J=B%8)zpl> z4QgxSnbgn-X6iIA`SYUG*;Em-A@k&P52QVD0?)yKUjEQ#5cS*E7L9eUC?A_A^Jvnk zLIOr=A=>6$TWFTtGBsK2P28(HDsi+iO0|=MD;3n~#@-v@d^414b=TUiqaX*L9!bMs zv}Lw5(7ZAT>^lxw?AAkAnkG{!1Y%q>GYHuob)O<+|8|&A+h)L^?)Fb`- zz#-|Y>(bHMe>hDL>=~N*6;hYnHm(LJwKcB`RarN6>TLx_^2U)v+@R_b)zX(Jus{)O zPq;jV3QKv3t3f^ljuQT{52k-aEu!mKue3zk?OMGv=(B56Af-o}h`oz6TAPURzlro_ zjbG;fE~nACn>GK|@C;32r^pIY6{;xt3B-i~ArUcvu5sxY?o;7VLtkeeZ6oKem^t|Y zRX4x?Oqt|{sK!5yD5Ar|?d7;-d_jztRfQn!u3Dn}#{1F_?dK>57mdVlEs=XiC=Rdp zq?GrK@TeG}9Y%q%Y7gR|rx60{@-p;C6PmOz`k?8NPxkJTrh=6OJ;A%RD4oHbJfXf% jroWJrG`cVIAQ#T9!378flTO4)Q7A6W&eXVKgi!qiBmX)S delta 1210 zcmah}O=}ZT6eZ2~%ZE}(o7yz@ZywSed z*H5wrE0&otq1Q&KQP)&uv!bZ1t;KUB%e2NBJIR)+20Lpc87f%XpO>E!BCjni-lk1L z`6Jg%gR-5{HZ8M?Wf2AuTi^%Mvdo0TS)-^DS^O4?HIp{!BrPi?lWwvtMe9&;F-|I3 zL^{YbS-fz?@z#}$TNoihz^p*6QP^T8e!6nRc5Yy>XKcW}ig@t|%+jO9yI6F`(CAsg z*B&`!M=dOHR0fjUe*yBbTS{7}R+I7))f%%oxFT^zGCUX}Oe@n)D{$bBWvn3if^zZ4 zJ%edadiq~VOL(`5mP2F~iD^;S)m>_CGpZ^z6K&5R-g~ZGw$Y+&E(+g0!#MUxNO&bI zct=t3p570=GJbn=822Uf4xj+5%q(!t=j;}7jwgTDuH>t38c<Ef|6Z-Gs<;*$z)Elk zEGUgR(s%I=V~Z*k(LQ_(QoAj^Bz-yzttM`f3=}er*JK_)$au`b(51ytXb$Tk2|J-l zybH~aIHJ0F_!x8&cD;N+(zqV(U9}9h_jF>!^5}-5nMA(7cIV#1lf^TQI->>MIJ0I3 z(^b3*XIumaVF^d!5q=6r(wK-`#YSY9-=0M#@F9|q31SgW)oN8Ie2m0@#M*%Ns+v#RT?d?G^Bo?SAGsxe1LJ1Vgsoxx!=gc6av!S1>C>_omNtb#>6T^bOH;&H8aqQ}Nf}AG5c1#qeP=Yf zSYGc!>wqoIoZFl^-?=1qZIRpU&gMov+!|-pv#QEUy*#UUwDqj;qFz*HcKEhClh;PA z)N&CuPnD^EsOmK-I!Rb|MrX#&*DGg>=G2BM?&s8L>C9|(xmYQRUoPT=zqu{MYD!kS zysd9lw5prT7Hbu`wUV=4UTl6;bpx8cFbk8MXSsl&PuCxQR?o|Y!Y2lqGLPvkPwSVs zLRASKmW!T^mY92;LjZpgT{m#wMrAf_)Yj~6(MiPNjwHsUohn&HLC9;hR^li{s<&^w z6h0^Q(_vfY@1bU8cgnx{ZJJI!BDlCu_NMV0xJu7z?pjkcR(p0{Aw=XBVoRs)P1=+= z9L4bS*YLk$EUe=+ez_-R0FR>~KqY2`opSfBLuvR=wo-n}RVW z=XN?ZQH;~RQjllvI+Sr? zAR$kzFGbzu33YydBm0{#> zAb>V<^J>o$;8L>8yF8p}o`ix>o^Rsru)$xJz!d;hr`lx_Z_YHWD-^=A9pROCN>0&_~P-j1r6G56*)&8P(5M0E^uKcHwPrM z6Pb+EKAO85-N=n5b#7B5;Tg&jy)xC$oHSjbw2@UlIs}tAUfA54v^RD>B}APH4c9$g$hLg9gNr{u-wMq~+8Pvj@K!mnE#%;sDb zis@k}Zseb<;nuvktr+X&-v(yE=Qg`$=Op31#zS>-WAh)iTA1Auf_tB^2n}PAapsK8SsFf zZ`T%SW6Q47qa`n09~rEQO)df%TRoI!VnKv%7XIMF&N@7;(6H+CpVz`Y*F*VPTTRUf zonc!W$JCA9I8$-m1>olO-1l&l6*r;+yjWjuRZf~vj=BP_P9%^O>sv14d0&7(=D zx*0}N{4rGQ+g!89C{vTQ&cs38QB9}0QK}2+Fr;NDbYt(0aK7q$6Lr_xqwEucs-JQO zTV`85&6x+!9#}&U=9??u37JRRh=4#UJ=;p5X*+85IBs-3Rs6@NUw{7`CYEsnb~K(i zQ*k`ukJR{~zR!!i%t1(HG7R+`k`B9(2XoRNrwP10{baO4DwNUfbsvOn&DpCe>!wbf zt>AZ#Z##(VRb8PFxe^Ts;*Yi2Polm9p}eH1LEb}-fZ;eAh6?&e)B=~sdZlI5#lF>h zgQ2B1ISN;F69FQxq!GP|m^p4DeY3_l>q(aw>D-$&|JLw~uYrC9t@5s7BS44J9T9r( zFv0c1slV8x+g41!yn3j*{`gCX42Wvn(-3rYxE}?NTk02Nhq9^w?@_*quAM7g-<}V0 zFtsIydx;EjzSx}a*$JZWgh$0l3jWD6R_zEjfkp^yu`7N5IH5^%qeo4lymAnd1Q!CI wRr^J4ElRO>CvPas5%d?bnMQYN9%Opo8eBX&6gm-4ibC-ph{Dw9ay+vC1&8~Q?f?J) delta 1325 zcma)6O=}ZT6eZ19`;ttekfin_c{Z7lSnaeaEwwF%P+KWzE2UJyMaaiXJ21|qlWC~L z;4dgxF6ge{M%>n=ND*}7!av}mt^`*?H-g~8cW2T`Qw4o6;k`TeoOkY-dvkpGJ$-s( zKNpFTw9bkZrjOO?8LIE7id?G73fouvCrFy9jdO95E^9hFA0#40mi@O&PY99L7V|f0 zlTf~-x}j6HTi&7-Ry89Sz}y1gkd_%H9L^d=g-G~YDAo#%LXm6OaEhwNcn)1{^yki2d>b4E9{PWFIjf7h)DS^0y)H3`3*m z7990RK09lEo})yFJH7uv-gCxdCaTq>yhNqWY!0pn_b?wA^bw|3sAUDbb4FIoB#uxt ztwz)93#%DwDVF}j0trz$S}pS1Om|__H4PBWZZFB=8x>o0Gv7ha7&Q#Ou&858N(5XOJPQV3x-3_kgK2?TYNLgpRkt)3w8b_ z_#UF(*i_e*En3y|u1GQ4bv&h2y$Q=)yo(zwRWw>0r)--yk0@7ZMT0|c4opuC(;G9Z{naAi z$70lk3opa(4y$Asxk$D{ut#Y44`pWZ2SRPjMPIVhd95aF_(XW@n}XNAIr#1y1H`qF>DeyHQItT=WI9wA_e77Map($L2SHcKCeGEK2ooufoC6y~2xnP+ODWH%&}d8MRRJ zSy11Vruwn0mV{_2VcQzLHFmmR+BC0^9hm%j3LO{LOm^q9g(CU+ER6Wf(p;n_WtC)2 zb*X|yRd3ULsRFxHqTAW&>L*pzfY}MMAc;Qn83=v2c=L<8pU)INA;6TmjW4OK+u{yc zMOe&d9U3Ju*E$0MJ|bP!FyBgT)3{a}vrF@qB9uFz7!r2OWD$5G&(%_ip%kHBzI0T$ zj;g!;rpR7{%_2>ddvnJWoqU9FejV*h?GA924%J*WCa+WN(0PR*k)0Wz-7s>JjdoiPbacFam%6%)_PP|~d_%hzFM1gsQxEpCsre5IzIvr1FPKw-&d~`D z|G_o%vcSyknGdoq+WcZZGx^qqqPQ;24AY&RPuvc-log2O;N#ElmWWkHIs7hX42k(# zC7OXQap15Q0r`y`w6={=QE3?+t=|S~1fRIDLlXydx11N^KX5&+v^byx@)scjw(;an zaK#HrIl3&fJ5^tr1GG?|iYJ|_D6a>BDsw|C-xTh~mw91%2bJBQ+)CN*H?~s^;dj4=@;$m+qMfbwqm;&x) zyzxDDLN*yj?4eZOjMun8PKBE>3?!jS%A<+>M<85aTq${Rxe-|c)f4#%rf~Zy6iYMi z3dC3$k{j6PyuUR^Zew+h7`jQ3#q{|U*W;f%H=h{Gi+fU`JeoxvbfnG6WQIzZSxk>++CFdMA{ zy-zBW=>Z(U%L_U+5)uShZ&eQ=a97CU>(WWui0Xyy!a4ggb-?GM* zir^>f95raYJaJscoaQrT2N_aBSm5tJFW!FqOZ}4PQ8x~1oO28@~VPXV;N0JMl-{VzwXb7GHZJ`n6Gc*0-E_1W_d{I z{-$sO9mKt2A!ZVQ;V<6(>T?80)%LDefuZOA6gV8N9#AKWvP7aERG#3%+QN2&T2BXt zi44yo8RuQw@%Z#c6Z{}JDnxm3D~DJ%g9Pef1R%|m!c7t*m^d?fFdoP&T~SJ%lhWIF rlhOsHCuUsviIVn0T|+cL7V*%HK?*>xN+V*WNEH7?<)%Wv>vH_Rs7fq& delta 1455 zcma)6O=uHQ5T@#JbUma=tc0LAYOd)(r%h6=!0G6&CWOPn{Q{{XXSPF!Ljw( z{v9mma^2wW{)(3ecg?oUm9lB^b$eiv<+xql=4ZK*YW9s5u@f6e; zh^2bI3;b5;IvBhxJ>;NRO&F{$-AurFRkxT*Z%y}ns6hb?v*g1Hzh>HvRDw)vDwQHz zk}Em9-!_0x+J*-thA0qB2HI8a8u#&I+awDDoYcn0p&@(~8pIEwT|EIq(t$pP zJ4Z0znZ`5XF+1~!TlPOXRU8dZ;+60g!3jvq;=U#b>9zL?$ZL^hqt;%1=s$#=(Ynul~8|3_K#Q+KX(_TJ;6dv ziHQ>}I*k51o@cu$7b`Rq+-K1D2QwM`hCv{?63sR{uU^CDsDgK*2l07y8ox%zP-MaB z*io#;()ch|z_+m@qkqjBaM}DSdM}F$@!o`VY%*oI8sF7u!8*teR6w-gmL8>Xt+=M` zGxfsanT4f|QTN?74qC zU4#h`qYn77=fr$~U0pNf%t;}{)nk^a65=Q8WE&GF<8x~scaK4y^6Q3W+8mu!Ce|23 z5$L`1Ja%0)84~jCRzUm>5hgd diff --git a/impls/ps/step7_quote.ps b/impls/ps/step7_quote.ps index c26c78870ff514f53accca2c4ade6062cda71f8c..8cb6eece96a61a1945b3f556a6fbe48dc6d785aa 100644 GIT binary patch literal 6219 zcmb_gZExGQ7XBU}|A7r=KrYZJFZWZiwJ5f17_fCi*SjzCAkZ@H2$Lm+lF|f0{`;Qi zP&7r!ONZU-AhtxFcb+$%)b>?bthYsJ)TbL`je1l~-KeKWm5#O^6<*Yn+L$fAi>)bJ zqZaD)B})s@JRut%zb`C zZQT-A$ST9b>B#|&l9)SP^0$51E8TYL)f=$UwrjIbMR&v3bzK7jRKx1PY120v@y^xyq{U#xdr*xpmJ^0~XhKMEu`s9K^6a9Lq?)g_r2I*KKjz*PWq2mHCuGRLC@1 ze^gg$Q{kk|`C6Ey0znHMhN~x2+tmXs#!r_JQ)Ra?;hE2!*2vXaWMQ&bsJxSvk zJw3rRud7@i4Ct5LFKJAT;UT6*@#`em&c)+4$pvSc!}y#r-+{sBi&wErcmdS>NSt>j%*|`2)8V@%uRR;W+oqk;WvXPyA5P~hdK&wpfl5hgaiaa z7*^?OK{(DAyvAg&9=7Q zXWCl*z-pB_$)eRs%5X$NM*6&VUwsv1cuqYeLt7kkQ-+f;knKiyd<)hca`> z^Mf42p0CB;;SSaL^d$B?ni*bqG0*ZKU)HE4$;WSgUZSKs$|*&UbN>-%Oo{o{l_3|L z4ttT1U+kcr?TyMB%OX1XZL&g*78iDC;(+dyrLKtg@=1#WIv{@#BH$2DZikkV&O|p& z`JlQRGeJxBxj2CQU&=lzAS(WRpBjRM0+@Fsq*?@R>x0${Q=0B&Bn%h+zrv&-nTgFIRn;S?<%{B= zp_mJQjtmFkv%K!nmtCl~U(-+sZDll?t40^2JVHhINsG<>#O>UM`yOP7HS+-AM(ntI z@|*k}0B|UqjWfB|X`X~U-pt&7gTHLS7RcjmuI)zr&6=*am4aLLLtp0MC9B1P>&y84 zsCGk$N%XM&UMR*~K%_4Y{m;l5WhDSn2nN@*^F5xLh_Dt)JwHvb*A!MMN(FK+(K};x`IcW z((IA#kJK_}-iQ)iK5N;#N&Nb{O}B~pGkeD?q%)%B!bh?M&fjmYOoj7E}0F zcB0lJFPcjA*@T7;5&m-#($(P##iQd#AYA6SbuV&cTm?3*R~fvJBj96&Dn|2LMX;Szq`}aT|&nOT->c@wTt> zuBeBbCmBq;a@?IHB%q<(x}}ev`4@mN6@WeXuq`Z}a5?XE{^x7Kp7S9uxrvX(@NGcf z8q3;-8N)^$$0hz&?t&2`-m?G2VLUonJS&kydK!eqx-ZJEsGgA{^xo#)O%ZDG{fAlkpaq~Kwu((-NgHXog zpedz43cb<1L6T7uvYgDD4j9s#4^t(KqJB9J;N&?BpBBiHG97z;@Xx;Gc&n+~uFY-H z;7B+j+k)JI)fHL*Tcde{YqE`$7G|JHdRf&1{1A#iTq0Xj0wGx?h{zW*dRiq+RI5a< zmiT7*8uBm?Y_;Uy64rJl*CR4mU&&a|qi+SB1sYU1>3fAs3XQo+cw0FG$6B57t?Vtv zZU8@9RVYuZ<(cCWb2>d?;*fb-3Jd)Ar|b70e^q~0^`{EPV{?JZy=Su}gGg<6{iv-7 z7{hewJe0T4jNmF0qcOM+1`jkYRCpffxpo3qe;LL?>yRmAY%;z@yF(&vegY}T1osJu zFmABx+0r%f39PeZImaN%Aa|JP*`JFetww2t(abR8w~w)*?}hn71Dw#zZ!iaelx`C2 z1e(OXVvS}JfZ?xy{?6wJkm~G1P=TT61}f8w=@Uvw-885Hqakc^ZEbB2m)t-HhRF=~ zG8q=Sj^z29FHP`;;HVUp!#z2~rXS^24qSR ppxh@ISN=9md!ghZ8X${!=-MC!ppB&wd4(fUjQcCoq7`=O|1Unyg%tn* literal 5996 zcmb_gTW{Mo8@|`CV1pTu3v|k1SH;$%*s@{3_iaPh?PeYXTBaRgvZPQ_njpx3-}Af_ zB~fzQogBoL$oI_m$i#MKk#F~TVbuE@V~u)LbycgUN0m&r9u;2HliHa*zVp2)8lzS! zira_UG@sYangBhaD7HrLj9o0(HZR)~>!!S0z-E;-^TlYTNI6PU{uFsB(vqm!7hQ9s z;#Je`@^YXcNqv)*SLu zs3lY)(3=ZsV{SWBwz)1|tFmebiQVSIaa&bT2*!cgFT%f1i5r-_exH5 z!=_*KI#J~bMADTboux?$%@4U;gqEBTAw*(LLu1qa!wGYPAEGBa-D-6(tE5^ZG%Lca}9GzRg< z5CHPNvbrc#-kRg`NGZhiuW$Yrka$uKXIT8*N!6!3cZ})YR>xFZs~=cmQYTcf8m0nA zV@xui)a%PH2LV2&7?PXKPk8HJQ|;9&m3o<+@Jy@17+Rr7_+;IS;C6i7^qw_T(rD^p zG%VcfVv(vrxTsJH;&)&FxK@$SOek-VzL!3i5bL$8AQE+gxr)gs^upG5My0i7$?Kgn z-k_R_p9+@vnLAM_3*w@D(&A?VtS4x~_`{)!vv8DbeS0+^#4F2?9H5 znWN@_1bjMP51ghJ<};WiDB;f(P|R%)&xHUZ(HFwXCCq>oi6r_`wo$rJo)_EH3 z10ime(P({YosS8EI`EU^yZg|^+`9Yj1qgKV`(Q=fpu_Qd{O$K~61$x@`vAQO+yD`h_CzI!MydmJDBmf1guo#L z7=OVqyDDJ4s{#U&Rh&~^ssoEFwdN|4tU6*6z;Wsl-fIeTMCx9aBxlut5WPEX*kwtS z`oc>;3Ai&I2MeS!q2%I35&@3fZ*EOi9nn}Y&af5`_y-1}z7w~ZN%X07g+>kzb1`Nk zKg963_z?h?8*bf;3>3_eY}?_>5I}%(sFW969Y+pF!+lQ-b2XloqqeoWL>iGvNM8je z@g#_jj*wY(ZY2*gbEgFvxU{RVeMy^gE#YUU8B_TsscEy}`3rrCaz}ZAMIHLea7u@d z$?r@5K$G#gFT)~%_hFwxed_c-Uaa~e#k_w+^SbZKtj#Mo{gL{tYsM@i&JWFG)|GB| z?oNQg2o5vwVV_$(VI*#K_Qy*>UN9je8GxrE_-fuY#SLtqEff{oe{)mL*s=soQL_vd(qfHk`zCSoqxF^8hWCx<#gSo>;BAr-U^2vPWsc8 zLW4SOX>ncRI>_Xwx8MKpuD>OiHk7)(X3^R3{syT_E^!8U>7Lzf z4Yq$ez3;^6?{rqkdvewEa`3^f;dN16HEomGyv8L8ynPQ^1Dh+9a9g3@g8Q-Sljg$_ zB(=0`06oMSgN65I{eUDh;2HpZqdQRTg%9zf`1zZ+-~IZ0t$tI#FQ+Jyj$k)Y0?{?s zLb_~S9y)z680Q*O?4x)SBix?J&CVuf`q{*Kv&J{eP@h(LKAScF*08ZuO^?S&d?D9s z9(ym?EU_TMTeBA!A!x)+%vs_L3@dfUx1zJS%>ww@rbMCHtj`>ifKkMhAU9PBbpPf5 z*FU`bS^ZH~?@L&Xy#Z?Pkxi0Z=V^QB#;#yQ=0QcnZ>Tb-F z9z^!@a$mX8XbO@QMvwE3ywT^Rj){Q1Ik!1IjlDi1$B)Cb5GocN9zuv4ZVloay(Z1Z Qk%|OyC0?4Qi6n*p2}pGo$XVO=Z-hDvMG*J*sH1^{DWop47%{@i*O? ztTyUc9Ud&2htkylEbAp9I!aisjNX`Px?Wak-pp;7{B{bR6qT8*9v&Pkl0Q6%Vt!|7 zE?kqc+GcHitro|1vq|%%T2xCVvYnos{Y%viV0MBmNFvYS0SJA(`tWb{czB@ji2$a| zeR54{?GjgbRE&qigC32Xm|LCkyMEX!T{r681&+~GQ^$8{bIsRvQ2+u|{c3m8rY%*R zrFC=Z&gS_iD$bj0dobV4jeUOVu(-x6;{UD2MReQUwG8+>b{yTbx=wG}qA_GBH+L~u z1y6(ZM|G|?Y0{{**`>K98Bw566I_XFbJLoA*KRoMnq}w4K!bFv+c>%l>fBoFy zhZLfXZnWB&M(M238kF1jySgL)f5| z_jqZ}{Sc4J8Q{`OAa53L+dOH~BB#Wp(AK6RcZl2@N9BRS_#0E7805S%RYUDATMk`vo*6E-nB4d?n?~?{`HF<1btdHwL3PVP!eiLz-+wg zOhN7?=7sc0%~~>o4(W==z}y?^4_TC{wR)v?EFP{_^fAnH zFkBWrFkZG2Q$$R$$n$pYxxqJq<_v@!dckVi(S@Q}!pvRHogPs>{8 z`ZmhN+p5^dx~lX83%A&E7Oal4rzPT(^Xt-m^Nr`>CGk)fROwty|55=jE>!Fovm&r8 zv4=xAR9t<@)A7;mxw6!m;lR^F%M-hPRHxH|2js)#)z1gU62tc zv)IQAo);RZM6S53SWk9#yI7%I6%)2-Vu1FRrNojb$0scYXo1{C2!owJ*&S+1igaC; z*@J4XO@P+>JTZrXY7iZs;Q(%(?-0Jnd{~R0a>8P*Sg~1}shaGd%AYcSf>;aYqiAe5?B9-uP%;OA(}*3mG;WjM9RMz6v#~07GEKvw!<(qvZSb3Y(J?Yg zo#<*KmS35st#SniX}f00!ApD%8P{jw`>b@Gvx^_Y#Bd(H-y_l%yQTzXlru(I@jzsP zPByN?Ewby_x(b5j80gRoe4%ako})Mb^dKSez&t%&4<7P3OOYVBkPzof6a>Xd=$Uw| zT@49NPMFi2F2r*{dzJ;Nal&xu5Y0k(&e;8X(kAY`Bo92zz&%Ym*dv^hu02SPLmkZtY9#f>IB>X3W*A0UT{AI)PIWSHd&yEo4g| zBwWI$7(e5(U zOqAtdMoOC!f_2%ts4G8)2j{T5XU?VuW{3r~qT@l1ka%Z_Pw}XU&hcg?c~J^iw0W}h zm~9>=P`rBpa`vh%ypqhjB+isL>{I1X7}h@&#Z zf6r=E20m@gDSTPfO`TL}iIl-X{ubo=qs~zjRYh0HqOg{tuA@nMab5$wpDWSZ_``&2 zmSrxm1VlIe=;?MMgoyaL;_Ziz|NZ^#QvIR+oVL^?&R(z+1s*zMBfe#AgyI50>-IeFv;E5%Dyz$RdJ_|3RL}hyI-TDEVjJBeXW{8m=TucWZd@G zl8z}gf@$}~1Bd^-3J(uBVwB%AB3$inKVJRx=~wkRFYaO#BdF5H?Nl>IA}i&*H|z%@|8Q;F=>NfbY~=B7p$U^CzU0FTxSX#fBK literal 7362 zcmb_hZExE~68^4Vu`$k9DnO2Y>8GHz5#0F>2lUz^&Gk!F5G!dV5ur$VN%{qb|NA}9 z>@LYAWhXsUK_qf_W_D(F-ksXEEb`?hFO0h18Ee#&I#dVs{G`&s)|0}EdRA+*!FRqf zMQzlnnkCKS!PI{{)N=xOLbJpgy*75Te6V@h99cKz-2`@3Su`z{hQ?>-@H@8bdZpbDx31SvpvLQkQC- zuNt*9+q@KNDTRpS=0aAR+t!p#u8V6`R!zsT+kD(FD{RQiPS?9^uMgL%vK<)o=@=o% zg%jHgIgkyTVKK-=kp~cITlRFODkU^OJmoyrc{MJzeWYtF392 zE-JlNg(HGaLl0)%wmUn!Nta* zAk}ALi7q5W>cLKifFn)^i_A9)D|yWzgtbWHJRO_($u>C{FWaI(ETAEGXnD!~2#pFE zpwbT@XpwE&a@FKjNl{6lt&JsX2)%0+HYb#hP)kK^*WzJ~Z4E-55Zr6~8KiWr1Ykl6 zc}PNEmvthDmv@ivOjn1OD;$`IgNEMz&ztQ7H!YVM9a~JqKeZxIE(rOnm#fHl2O$?Z zdqpTARq+YfbVHRP@iAQ8{QBXC2zulT<{|H+MrYY1`>cuz`9;_Q<=Idn%ymp6(8k3i zaZtD@aZK&}Gzk>mtGSZwFWi6seK>Ax*CUG-lXQxtJ_HMQC>j{1C>SRz5*Vlicw{2@ zeN)*^*}rv9l$rQ_zz6cCvhZh>H)cN#U}S>&jYvEzhtnqNV{Qd!{1G0!4G4u(`Hi9%`OS#Ud{ zN(|Q4d+^Z2#BiU~`J^xbVKL0))8BuZtC`SDzryBHVqN>7LH`lV(}V}bRw!X8J6INY z-Z+y5YDckC!4f-jH!4MtL@YjOu`_`QY8TeLzsLqvBW1Ea9EwNP?933U^JL-;15fYr zFPsj4Ew_lmBOaVpPq<(?<@uQ?)7yEWaN))X~B-IzPjdBqs@noBlfq()OAH{C?gi>`7*}zC)nzs=nT=)|i;Q^WG z8Em-p${b5pP;*cCK11jP-`T2a(WacMx?NI1h#tylv>OMV_hE{9;3v)34{>mH>+ah# z5XltwaTIZ*t|IL5*YD#d)@!HeAkHMj1+=k}!#aQ2nw%mv)GKY*V&m2{tt}Nip>_RA z0GEgv@vJYR*JEONZx&aDLE$XAcZWv9^9=%Oo?v;h(!ub2y3(jNcBr9a@>!pi6R6PK z`|{WAy+CgO*FnUjBU|jLcF-|@$LJ9Pmk?omg<_yD2`m%0bgL1$G5I433w(P2bUb-K zRIC z%mBO9CEU~$W{*rctpFS!5h1#9RA0v*w6qnH@qCh_vIVJ4kvLcQIKq4WWM_ydXjyKK(;Iv>s z*3q*dqj0sKXHZMwGf>QBe^-v$(&`fNQpPO$GGbtej&_sjW2~hBGSb$B4D87jG`@lu zo?61rjvq|nr=*6pT{vIpOE`0sCs+||9V#T z*_a7#*e-S_jM@+kO2qgfnGDjTxfq)hU@+f<8u+luEuJuMYxL^#dqFveKoLt5SiMy288#=0<`514Oy#4U; zU%$SctKZb`)2^1JXV9An0rwkAAzhCyx2@h9wAZyMHnU`rK-4!fS6(EHPm4q^=J;lw z@^P2Er(Ix2CIu(vzGft5PpThUs~(gA+5 zD3OU4^AmT-k%L^7*jtn5afh53@*!2p=xnM9|J=Ds* zG&@_}tCI@VdD-rl=<})#Z*E_!rV?g^V>ubu{Eehl3XLe~e|X^VU#Gwsr*|^{PjRRJ z{m;#hpMFuF%j&*_HLxf`(Xr?7Oa4fr?Y8a9p&r3c#?Siv+}BW;U`ALHgn|L}B+ga; z?8&)02s0k}3lVP8hXPcV)aY<#A~r|L{Pcvt5ImtngSGUAax!<_R08GAsYMLY4dS7R zp1qwp!m5vqj6jGH`0^3LH6hSh*Nh}o?G=VxV9xzzN*Ec%DaG1?K?}OR`RSi-GyyV= zeeC#V*l?4w(JnF9T8|EGu+DL&l;|PdUe!6q5mQ%Dn;gV zPY&wkGLd5C zx7g{j)9O?mAFcYkMt6U1x-}szB@DMZ+v;{c-n2#4FHPv`^Bg*_TRj^+J~~w-e|(gr z{4R@1xF%(_D~Ik{txmgsTU2YcYS&6+J3qVli|Ts7TnVxui9E+gAoStg+rO#%<0FMn z0x+d-^J_|LhB(5dQal_VjcDXVf6hvNcXxZ0b-jA=8p~vD-=$xQ{+h3wx&{QO`cb>m zc4$;u7G3|wtx!G9?ll>z z^p_N@f~R2oUcFS?BJb5kUlo-hnNXlu6C6o9eKY8)FS7EDs_Nb|Z)WfIn;J9na-DV8 z={{@TsJiuVP_p5MFc(G#PT){XOpn8(c$7Z`N`}f4ThKD$`QcjU6WxY%2$QtB;|6e3 z{PuH(A5uuRS)ZvZ-K(suv#lz1b%lMthc~qPvu@!ReVg%tc46@R-$a*FjrvKm`~p(f zltr#zI5|n3n9o4r^TC&~ zNjL`7d`ljn^+r#nD%S?8eLP0iB~nadN8_%~f`P27|?Q*>~Kysgtb zE8!xGPKQW1ak|I+a27g}>`aW*gpgQUm`V|(#5G~9#ZF$~A zp)3(LXyqebQE@)TqjCaVdI{t$)7?Emngq)+eZ?RLrXQJF7>@T^7}2*)1_l1_8yy6FS~ayhHKJG& zYDmCLyt1Ys`;u})#-wH}89|41#baRZJ@tny%Fy=i=ePfg!KaR*Z;K$lc%vuj2UXU{ zP=+~>KR$}p!^Fun1l?TBGY{pAGtYt(oUR;^S8A=Kv=Bjl_+eaiYV%WT7i%?orFIM+ zwpR2J<~bNHiyj!S~>dY|k^w{#muJ6_Pyx;+OG1}F~zy7#}=^Dz(R~chM z%r`d3h?5!Y(-qf?4OAjm+O(`Et=+CJQLc&!8#FOMv&&LqNtEMLCI)DL+(rn4)}PD_ zH6=xQ)->gv>aTT#Hu^jI-%~z}#m_lmv1WPc`T`CxMSLo0RfS|q z=8e_b%N=b#U$9I9_Mb`Sy0Mvt12ImLos0FG>L-qGB$H$pGLNzpW%zua5`u&R7$3!$ z_=KuBjD=vP)cx~_84moh%y5lVbPiTbmS(CZJE-#K%%36Fg84MB2OO5pRX1#?Crr|k}h!9|VI0;U5 zr0(s66^XaTF)!2=>mqJ8N0AQI9<2}q6lS~jHFnXrcX8b0KukB_D$o`6gcEOm z{akIzI{y^oP)6t!#Ey@?`G#*{-3b@&8l9u3VTw_PMCpg%q@90KvM+Obq#{!UHINA( zb41s;d?jS~F&oXUQ2yy@Xv%977F22rMI!`in>k+(Xb{v*gA)-X7M09l$jzzBOAVVs zBZ?&gS;sLgYwy@#SW+O7&hax5+R5zmiKG*Rbg;n5<>iHi6)dq~Uyg8-Du@8n592!v zx>JetOfEcOarCK$tcm{aT5QU}Le_8~6NT1|ZpqyNZ5l&3H|Ao$MypuVrzLtwrBH^@ z@S-*cSRnJ%AAe)5e#KHiqMf-F#|>16Rph zjL4wjYD*b=iG~6yPJm-# zxkv3{Qj^RH`8}C0j9q$cZE9eFSk#Jfyvh=CoG?<&@dC?Tl;ofk%a*XK;yMfO@w!ji z!V_m@dq(DoGi(Fb~!qHT?p>dd|XgquGEEk5ju7Eh?&Sg^bj?B$NK+_r^m z{LXH)X^KV*AuI6o?d5UXd3ZDKmGI)&6h5R`1Gm@=McE@ZjNPR=*W01hiK95_p^#;S`$~FC(k!a7zCb1><};tpZ-%hfODtzpfvZkskv3*lT@BflMkBq`B@kAZ zD@goIN|MVJW7_2^yIkWhGo5Y7a>Fjy{8>ZW6w@Q}vg3vPmw-dx2|9%X6<++mK%*eY-NSgD2jGoDi z+&6p&S%4$4?f}NQU@+U=cFMe%y6dDycdZ)s8+2~#os?mn>QP}JnG4IZGIskr$;*@) zQPqBN!SKhc@c4*Vc|3Qi1Y7&xf4_VG@jvQQRez~q73^Q2Ik0DeF8^?mwO2#Xx$qeF z7X8fkJ$%0dSDG=JL@Z}Xp2oTI&z7F)Sm0hq{^4F8CK~!saMPjUvwE6L*z!Ut! zBf{Lg!JMqkxorgw<@EB|?3^r?{e;U*nPs zT$=xQF$_%t8V~dm-Jtk)KmOfaV1Sf#J>2??Ddx6pdg~DM4FZYZ@vJo-CH({x6CR>W zadh}vgDki+(xEezgIPL9IWgF}2)fnsN>dC@x=z0v-eMbd((m0>3-yIq2{#8XVxb$2 V*oICSQv{w&dxSF`x@~6Pegjgc*LeT{ delta 2809 zcma)8YiJx*6eh3T>}-Yd_d8?tFdK-ehSVzwZOjkd0L<~s!VC=o5$0>pJl5|Rw1 zLB5jv6fLl>{qRy(CgPH6Ndk0@!@C0!uT-hmDzb@mG^Lqr%pEL=(}y0Qa1RMLNE8lt z_k%1ZK<^Ge_mF{YmKP84Tcxou5fuxhD{?Dli%scj)qvmwE*NyAw`Ul>Nkm2*e$$n! z)emeT=rk?6XAZ(M(}xd!L;WHh8~CaJ=@^6Cx_*@ z<4NQHeNO`av)+hbSYz{9Z)(#c+gyhCyuW^^@K#-0sc99X}|6JY}_W<d%sf5)q_f1sVRLmu)-<^4n}t=MWN7*3~X-%>@8O>XLh3pqg zWN0rNVLB}MH^AHeg0<;r(M}ofK2!`R1`2`6x~^Sd=Dfn_@WQG;58=KoFpZn<#l95a zCbYH^N1}G5YS^GyQJrI@_A#*Sz>U5fgi=`;!(Xv~1djE$=O6b=@I(LDPA6-mM4zNq zm)s}A;#>ckVwSP;)C2tT7$aHgi8P0c0~s7soW3=XaYHw$OXh;$gTI+T;eOQwYJqX*bv9&})M^M99O}gF(1E7=s6c zyLhe+4lzDn7>e_8HQo(hBm#oq^HI{Vm0*J%g71cceEE1J00Uu*-X7l0d0WHXFctN{ z>*0_yzZRx)M1aJo%P!}V69I0<3Nr(1D(+)iq9VXh=ZbmJ4uSGX-iQl3k zA6d-OJ|0VAlF0IvWItSrWjRe=+>G@T-OY1F0;_R91mpbr;cmVV=g=+z&v8c+11c%NZXW&6urQVO`(1 zA08agYD={`wR*ZM@cL7&w@{PuMptCm>DKl}d=Ke{S~CUd_=zWup0po5rm?87vTnFu zP9A!B=^8wfEn*T@vRQa1OIf{{Ex@nYEs$h6*v}+bVDwM{HVQY`Zupa_pbXze&Qxv} zEai5>hq)Y6uQX~r<>25;6BKWs1TgfoRaTq@)z9FHoR iBDb3tpV9q^&&J9bE@XRpO2wxJC0Kyp3%fl6kK`XFKme2g diff --git a/impls/ps/stepA_mal.ps b/impls/ps/stepA_mal.ps index 53c087478f1e52fda4924d54c1cfbaa8af787e6e..6e5ebaf0fffc7f807e0d9d35c4b4e68227ee985e 100644 GIT binary patch literal 9974 zcmcIqZExJT5&nDz{2v&j+uJpe%69rGxJwYU>7hU`cSzIwk_`l{mTL>qO0r%Y8;1XT zpJzylq9m_lrUWDWUK4xcvWXbJ2#<=n<;c!)_O8}e6&y`e|!|h z{LZsNxF%(_%e&@EEf-C@&5D&;)+;5lou6I&Sv4(SE(KYTM4sa#5c>H3-Cx!H@sYwO z0+`ab=@q3lLmc5!F&>VOdNgvPZ<3tf&D~xlO{-qM!7@qRHu1Ntz2fVpECB(ke$=kC z?J5=LS<}9CYjgcG6&LN5S(xwo+B`p4ERJ!D_Q*IrnQT?Ai%abDJ-ngTH@b#jv~|J<+J(XMenL@-s+H zm1n7b>EtAh19CcoQCb#h(ksvnn{Uz>E5kvImEy)pu$i*QX_E8CG=*_7V>$zcPX}Lx zCgB)R(=B;`)+;@hk{dO3EJtRt>wpm$FVp8ZDU6VUR?yYi@Q&KbJB2nL4alp3j zG@_$W+$Z%{&`KI508?5>Xc8>@^c8{}n0{nxW;onyVMO0n2^9FBZ}cGO)2gZ6u@Qxm zP(uP{;*~W8*_W6b(kC@z$p|{6D;@)LZ>c|IQHHknzrFiM2tIZceVYy9i#K|beo%Rd z3}u)D`QxKdJxrWTL(t8|H1kl-F!Rhf!D8u%yjCkErG*IcFN^U?lLx5;YlmkwWpZz0;NWmuypzq2WPOq|7?`J|D8KJ^MA`i-7 z`OzCwDB|V#8T5I?A4gh)>Q>OZUSMo`*x?p)RPixtRW30pGk) zv181Lz_P?F4&hL7^(Bwx!_K*~)S2PH(?iP>yS`WF(}D-&#b}qG{_@KTrfVoi&oah{ zm~U;65hpX)izU|!4OAjmT-B^6t=%ryC|AXV4VoCB*<~rQB+BtA5d$rZBe znvxwTV>!$38N4v%mEw=OObzQ=qRi=T4BV$Jf>v>6;=jQCX2Dl*BG z%p1#Su?4Zh@GJl3x3+Cgr>~L5*S53E}q7Y=1 zPH^I>l57yss1AOjY(To?B5lzgN>D~Q zW0VmOL?-BD<2u|RyAzwOAXtup4!yt^+Gg%CiUU9o5)u#0)6@0fA&;{Z34#p?ah{_f zC{9Ap#AD59NN}>koaP+2)^`nK)DLtg85Tf<;AgO0dPBd|=^UA!$|Xyz1+pU#{;I5Wjf%8UWx+#a z`ZdJm0zAoz!z6_*c0$xChGD#4kx|7|Bj6P+oDgALL~=<9UH!U<_#>2{d?5n$xh(_p z-Hx`Fda{A;LK!7M2OLFtq4wYl!2u#7j^}!hx@D#+GrA5aQMkC_fn0XmRiF$zQ>Mca z(izY);a9Q@;)k2u=(OD9+{w+tSV&>w1<&!bw!RAuj{_my0apWEQBUX~q*teElb3U* z0>c8a7s11az$#zas98S(LPZ!kE|^&JOI zd2ImzmDOD?jGV{cO5J?3jfI>*0} z&`xHbpCvsbMS=xR&Mz-4EMbWi`<#RuRh0x7f0!>>ATK0yGFkJ)%F(A5vL^bwYuhmg zGg;Vyj1+34*CB11SafcJr~L{dlc{$G`m{t3sT9f(8eY^&-XF)I{`f!C>NA!C679^b z*l(aZw4&8uZ^2l$*8B2C2TnN8?LwL9p8FCvGhByPty;btc3pvI|cb+HXN9|%%lS~QuJ((_yU3zS7YG8)g zq&AeTqE_U1W~7?p4J>z7l7mvrTf(jg>nyy7>pp1qcyYsqtQW<1ry{Qn-Drb1iyZ)VF>i+Y_+%`L-UqAl+!zXt)JnW1PZnDjte+Bo)4Q-W6%geXBOlTbTyyQwBkx}mT zdkpE-+1qe=63p2op{Ml)~gki zOzAv4jbXiHFkCN_^$LHPB5h}!8@yie-xQIzPA}!>8V-FY=u`%%@D~^_(J`m;*Gsm} zPrzZRPWYC0HGU2O@RN0c6u4f2HTQ44lIbs*jOkYTqq=Pzuj}O-kTeGg89kF3x%l}W zvH(Yd(6(B6j%CL^_C81Mlgk$@~ z1&9B4{x&l%2q z!^AgAaJL+yNvLy{=V_cP|7_`*RtGNF0ahJRhKu{~X^BcUoUunl5$Kf@e9 zpG^JYi)^6Z6e!-eg_qo*H@K&SeC9_>MwC(LWDh~&D7NhVFMo4)P#`6Z7RNcGm$~p9 zUmOiu6$4$p=kcyTz4{5Lba-wv_1NK?DYD>>WrvP&4rcD?=EPvPWN_giuQcMp;o9xY qhCf6w>SU;Kw`J59qB3>_yohaYG@>Y)b4*5fG94MtG-&Xd9sf6@7%Q6juK1c%8&Q@&Ec~?AWQ(R@o$_Y15P@0g?cvDJli2AnI=IO=H;F?s}89 zL{$W%(x&(ho+|$>F`Y-<%^wsi|sTg7cAWW$Jnuu-(hY(f$nZGGC>*CMZe3#{!yINFvB+N7G20Bs|1wI}G5iq%R{){zdyRhr_YRIE=;k((hKY|2)%1O)G~!Js3Z9cf@ zY^iEalu8K=kV!b%k=n_nCER9KDGbi~;&6`5{!3jV-09c?F2^pIay*WqN8nw@4p?zy zS_HV|NZ|h+M-=~4&Y)XZXY+_NzV*IsF2g&{G<@Y8g1gSab6m~Hx<%4dIa6Ls)rO$e zYPH6i{;%^xkZ8XbD5zyN!b;_$&WEKj}=tN@p@+`9TTfDXT0MPAEEf zUBiO4_#Eyz5f)q?%vCTt{mj%8))Ehg%~v&9RpC9?EUdaDx3#)=FV~zEeE*~Qs*p-@ zt;RCLqfAGRkm*COh=wmx;yGIa$PWyDc*n-*5rU^JfB4~p1I!5Hes+jNS`%zuM)O8n zA^W*J8QQ}JSPf3P`{7M@*4T8kXr_!eA1a0w1BJlkT1`F6^aX{{;e}Oq9|XF#!xV15 z=ey#7o6y)w9ErM7S;hXua^-oJUpoe-9r&^<19Bn-FXJ!QJpc#0*XGx|CHSp-c+|=o zDbXjDOK0pS!{8hLs-hRL^3(&|@-QP=YKb(5S9+2-#yS0CPtp$Eppx5+$s@L@i7Y@* zLWCcBoiOLg@;(QzdB%tcgX9(956_@A@!0^-tu^JUcl+j5Y?^pJSEFIL|9$UKlf%3p$`%PFAN64Fca9tGYkR7$Jc!kK2FBk z!7F+M!R4Y-VFSXp+zSIiFJHbA^1xA(z7TwX^Uep`;bPbUD?y(%ZwpZogFtKJAuiX! zYiFVu<-Hjiv!rt2m_;86CoKA6I8C&v{ax5_w=L4oB_<*wA8Qdq`${B+Ng~UuVmI85 zq&Q7pM55h9xAR<)z+}t~$D;hw;%>el<QOYUB-M#_5t6iivG>f?Ns4p(b%`9@49c>{=_t3+`qj2lo;?VK6xkFC@2dog2wL zDcjbiYD+vAY{PhRl_L04BQTvBGj?Fg1#hPs2~%goZDGDvU@wc!aft@woiN9+6|Qfd z_+F}M<%%vyPab+~?y&hN(zQi}6>8dsmla;-DtyTB#J~zm!97O#OQ*9ilim*XbOzo^ zOYn6X-!brKdJx2n1p70);XclarM z;83`5J^RqwL+I3^c`s6w_yog0{!FZ?JSxcK#!`aW>^Wq9v94(Quu~W4eW;cz3N&(k zUB(T7g1UAVuH_P5Gc|R+TB|7~whX`KBJg)^6bAb#h|7`8xaDF|Rphl!$7gie;uEv@ XqKU(uJ6^_j2_;*AkNbB!1n&I5$5#Pj diff --git a/impls/ps/tests/step5_tco.mal b/impls/ps/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/ps/tests/step5_tco.mal +++ b/impls/ps/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/ps/tests/stepA_mal.mal b/impls/ps/tests/stepA_mal.mal index fd1ed03f5e..2065f25b7c 100644 --- a/impls/ps/tests/stepA_mal.mal +++ b/impls/ps/tests/stepA_mal.mal @@ -1,25 +1,25 @@ -;; Testing basic ps interop - -(ps* "7") -;=>(7) - -(ps* "(7)") -;=>("7") - -(ps* "7 8 9 3 array astore") -;=>((7 8 9)) - -(ps* "1 1 eq") -;=>(true) - -(ps* "/sym") -;=>(sym) - -(ps* "1 1 eq { (yep) }{ (nope) } ifelse") -;=>("yep") - -(ps* "1 0 eq { (yep) }{ (nope) } ifelse") -;=>("nope") - -(ps* "1 2 3 pop pop pop") -;=>nil +;; Testing basic ps interop + +(ps* "7") +;=>(7) + +(ps* "(7)") +;=>("7") + +(ps* "7 8 9 3 array astore") +;=>((7 8 9)) + +(ps* "1 1 eq") +;=>(true) + +(ps* "/sym") +;=>(sym) + +(ps* "1 1 eq { (yep) }{ (nope) } ifelse") +;=>("yep") + +(ps* "1 0 eq { (yep) }{ (nope) } ifelse") +;=>("nope") + +(ps* "1 2 3 pop pop pop") +;=>nil diff --git a/impls/ps/types.ps b/impls/ps/types.ps index ad07002b54d5491471eb0fa4b8f734c4e8aa11f1..1e6d24fddea07228abce193a960ccf50f12e09c9 100644 GIT binary patch literal 10311 zcmcIqYi}FJ75#3&|6v-GfP~swQnnk|NMfXo(*kvoA~y1+DTv{6C~igW(z{DNAn3pM zoO|cBBqiBOL&PC>=DuHZ=dMQPZ?1N&U75wUF8ivfyQfc{J{g&^sY~0t8vowp52n9t zOxL$neb$+#l}FpQ_8NF2^JCkr&BtX`pJU%twfR@m^&iT%+Vp1f`t{iS?5g=Q^X|&7 zH!Ei*lasHBcBBL+$KluM@qnjpzaXgan&{W*07!NKQ)Hr>8#9`_#nUGSpZRuU`sO&qEJml3UG8+<}1I<(u;ghJ3ux!ioHvl`Mlg>_I*h{5E&SUe^bJ%SAs_tETVOP5S5b8_w zd}7*WwF=^=g}Z49^IJ26zm3EJL#TBZuI&)kK9-(;7nTfu%Hk=)$b$uM{9C-Gvf5Q+ z=VoL!+is}{rm1`81(a71Z&b)UhSj{}w`PHqi4rK}f1Wvo$hsHRqn@l3zmr?5Khz{=HqMRqeYctojG zFyvI-^jg1_z`E+x-7KfvOJtH|7dF=B+{kvwWuK{Mw5qzkxNv3Pw27ufMC*Ffw_BHj zn#=rvc8NH}2@-yws3zHc(FoEH$r2x7(i@R`pLRHH%#kNkb*5iB)7iB<-X}FikVkPQ zrrXX!r6Z&KQ&jV-%whRf_-zegrZtMrEd2~Ykrd>ws(0%ygwVcRf#iLv1{i)1BRk(o zN8oT3HF(H&m<|CLrcPkdxYXcI&%>Te+bySSyOC&34|1%tzc67f(GCnncujkiqjDA$<6Fmc`um)|??eQNdwiXHjjzon4@U z9A-;01>yEfU*HhFtcVHx((EC<79FD{p zgrpGh9j4TfyCciOOrfR{jh}rk!3cNV;FE}yT^M6G;TMLW`LaEXZ5hhk8tZ=~~{ zGHc$dm#11b-|_+xPnp6;>5WODDJ4Duhrp;PU0Ij156g^}y2trO zavNR8P9v@4{^M@e9P@FQSUGS8n1G^}3kWb3(Wm0D5VmwY9RxLpQ*u4o;zwUcWw!X>4z@?m3|19#}DAh3#ZKKyNe7*$pl6 z{|$==Ow8o?fC#tbE5|{FyV8xi9S58D1)>)Y=Z3VH`G&ZVJ9@Lox3r{TPo-zElSx%R z$O3%knXDd;(R9$ij8lJ-fBUT&Cqpo@SSaofMLonPr(csC`tO9FtRXR)NkOXjN2ZwV zdOd4c8ECdn9)c>F8lkMS7?u}xo~|A#+DC1}c$8o48e%Gt;XmBY{6F_ zfBNC4H>PW#0_M19xa^!ebM))g`1G|qHkZwIHOKrD|Mi&Okvg5QGcb_TQ)T~s11EFw zZUpc-kDUKk)XKPrs_EGTzz3SwzasNQx%Al1di(D zt5hj}MjR`{yYw0WkIc5i0gN!NY8{SR&#q=hC%B2tOPD1ZTx$riWqdk|A+cqnGTRmQj&oeu*>Jd4UmnMdZUzecNn zwP$wHO;;yH*deOaATJ`Y_A#lngLkEEWxd*$C>P}cUPC@`rDsBKCk~=gCgEo?7!r@+ zBoTL*cpx0i2!}dcNf|>~q~O}va15>O$C%z`xG549PCfs?xL%$F8{YL0NA2Cp;a<#nalq!dEqB#3NsI2>gJQ--`6je{^7pssiVFbrCi5-O?^Sv?e20_02u;oR1)|OT^ zrXrPp0YrvJQDFW+M}e5CoBDYm{)b=dW4!%C`81!ldGCbN)XNB2M5J`Bh=qw=-+K%& zrE_Q0<1ZehP;si6jqSKbgK(K8Yj^ul=O^7lb|j9>S!?koY>Cra_=G&k>_boZZc$m$ z1pE}}+pY8}3eDr+YcVoz<<=)BC#Li>PNE)?I213>9z%-O-91fHEgxTpM2aw;{<2a? zxBMcn;PxD&Bjy9H39sx5KZVXgeh2picIuulbdVwk7X?y5^22UYs7$LE00HmuuJZCc z-dTUg)YbgcZoIqXHiDE%vrU1Ic4HO>P->|-X-#2R?uK4>0s%WvoZ=TfrO@GVUoeqxG jJu`4t!j%Y}!p}XX51bxv5Rvn-`Ac(rkUz-SdFA&%dva>e literal 9867 zcmcIqYj4}u8UF5HaaK%#jU}d}Br9yRF|sY)fMw{=1pTrW!Vz_3ai&Oxq%0YR|NEZj zJy+^tCk`gGA$j=T@8{41^>7uJW#^tM=q%pz^xPb!RI4f0;h0Zd0qaYl`Z+ zRdpkex@q)X3#6Z#dZ|7wis}ZhRZ*#b*KPMPZ;Dl?Mi&=D^@}NHFVy?3Uam@`Mx*oZ zfpu!hjn4et_^ij#zJ3KrVKlOraSuk`ygJDevDLjA%*^~m;Wt~aRCl*BY7D7nX6qmF zdUdBNL(sxP5_(my_`hKC*)&bv%!<5IQ*#ZiP7^L?LMmUF{6?8-CO8iuXUf(D0-04o zBmg(F%@-;Yk^PdcX6in`KZhxC9+cC9H$eg_Uz+N=TLkspqn^#wD6xnLkO*cz!!jbL zf=*TmVG?K$u&VQ$OF&)IG1p_5b0c)fcBo!E@~d@MRGn#Vbt!M3KzyxUj#N{ZrI$P| z9Hm6Y4{8brEBYPr(wJM*vvo#uP9byR;A7jZ!OeoX!48c)=j0f zUs9U_?$oePo#*SOF;#AmkMlqfVd{A}f-{g2EW3_m@tp4Ar5N5KFW&*qhN{n^tTJYX zyp{M3iwopF4YIS`n08%u>hw&U!RSO*sIpG-DquRgt@*d~lp$;=Ch#Nz z(nCMfQ?M_>r-Wu(M3H;x{t%69DW9M&A!{Wk5Ciq}zwh|ZUl?H%^LeeyE8b4)x;)AJ z!oB+QUQA4PT&&}>=%#I1o!X1}>=q|2n3$?7$Y`p1kEnYBg@mc<&emazzARenT9!t> zi&TOk=h|1<#H6~O$Sbq^Ewa2m-@*Wfh4nV=A z6#ba5Va0`R7n7x4Nod9gX~>)klwS*!JvY(xV4x5p(~}!>*V0jP_4U$Y^XfoiR0*Ve z^s%+amzYmjIY|dX`=8^N&2*>LHKGwE8HP0)6%?#Fv00FVJV_-Z*j_>N^!-%}wP4x_ zSxpbDeM_8)G{-Z_i{h_G~S#sh>?b%P;j%L)QO{^q+uRcFNwt8 z9*5pSc<9&m5B26{iJ_--)e>Vwy~1$s#`>&Rd+%i|o-jAAtWPJl9A0s-cMT(R(Ri<7 z)VLZIAm&AbMr@l}fD)4>qvudvGv07PFd#YEg{w6Nn4pTIht`bH$4Jq181Y$d*{9mF zurm>+JZgbXWtS{lOiph43IfE2ADX=#WfRgOBn0Y>recxF9DA9GAYgQp-f0D6y`(@a znYdyMo3JoK95%MpEJpy5Zz8T8W>tRMB9Lsd zs^3Mgr)6L*qYZspN}a+2_b6F^HSufkCefWb!tj8@3Bt)*-ivnwwhY{OFR!?n#ZL65 zsyCGzPe7T5k=HaSTp{;6F7P2@-}!Byi&#v1@40tvv-jKFtitAA>OVE_7EQf@4FLE_ z-(Ux!n`zNCx`Ej25$uB4Z?y<>HitjTPWUpDOHs}1bL{p_rE-)=?*H2k&cOx=6smS^ z8g9`$?Bck_LWTWFg&ChAOVE{>353~p=PKNXp3t{5@%5{0+!KeF?zGp9GJ`9gTFioYqKj7^#)pL^UU+FT|{4`E3<4&mnkY zSVJ(<v{5)+kqsPJ-NTkD%JZ9jJASzK9SlDs;a+O|zxW83dX zV1V{UVmqtLSd`yxK||*qj;dr(!a?K)^9TlclEPFW;U~1b-(fi>|r0}ryWVGc0Z z6TwJ8U9%G6(@SL!Y~@P`${kCO)IaWxPBKgGfP2GN2}DqcHS*k($~#kKJ_wHD65ud? z5-$Bv@9`$S>nS87oUt}x+1>l~FnKxyNFQ1-nDfh|ZhE1~M4)N(6d#muZ!5Try%?~t z;pEAwN9K7{>Yx{r0|m@(wkBV9Lc~(Y0?}yf9%BTV9P6g^L_sPR3X81Zl!}=UrU60a zr%w*&Ubf@7@(nl{8H)-B3x)mOL1w2xRNi13KnzuN_0m)R!*A6YK5U^Fs?Y0W+(A3E z;z10NCXDrQl>UH2J^7Ar+b9gYdmKWe(*`{LL;c|;IrDPKo{luqW287~ADJ=;n?P^L7?^Ye3+yJJ719gx(C=lEi$-ic5c`AjxB0=bvVQm)Pgq3n ziyes%`oqE`$^?(tH_!EnljIp*`3DXk)xY#g{35#nCPp~^lOtch%-ryAkRSfmsv|&8 zx#nOVcslXr(OihB>yZ*$dPn$Idm>uwBQhp=%}9uUT!9|+R8|wg{$&JvI}p~@il6^O zAqc9uS)2&T#DH(>_KRD9`|@(&Q6JI%U?_UL#DF0f{k!LeqsRa1$pdBLT~{w981X%x yI%z!f$~MY-cvY5;xG_}YXv(DI3IQ6QzhgFb9G` is: -- a tag (i.e. "v4.0.0") -- a branch (i.e. "master") -- commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") -------------------------------- -let upstream = -- -in upstream - with new-package-name = - { dependencies = - [ "dependency1" - , "dependency2" - ] - , repo = - "https://example.com/path/to/git/repo.git" - , version = - "" - } -------------------------------- - -Example: -------------------------------- -let upstream = -- -in upstream - with benchotron = - { dependencies = - [ "arrays" - , "exists" - , "profunctor" - , "strings" - , "quickcheck" - , "lcg" - , "transformers" - , "foldable-traversable" - , "exceptions" - , "node-fs" - , "node-buffer" - , "node-readline" - , "datetime" - , "now" - ] - , repo = - "https://github.com/hdgarrood/purescript-benchotron.git" - , version = - "v7.0.0" - } -------------------------------- --} -let upstream = - https://github.com/purescript/package-sets/releases/download/psc-0.14.2-20210713/packages.dhall sha256:654c3148cb995f642c73b4508d987d9896e2ad3ea1d325a1e826c034c0d3cd7b - -in upstream +{- +Welcome to your new Dhall package-set! + +Below are instructions for how to edit this file for most use +cases, so that you don't need to know Dhall to use it. + +## Use Cases + +Most will want to do one or both of these options: +1. Override/Patch a package's dependency +2. Add a package not already in the default package set + +This file will continue to work whether you use one or both options. +Instructions for each option are explained below. + +### Overriding/Patching a package + +Purpose: +- Change a package's dependency to a newer/older release than the + default package set's release +- Use your own modified version of some dependency that may + include new API, changed API, removed API by + using your custom git repo of the library rather than + the package set's repo + +Syntax: +where `entityName` is one of the following: +- dependencies +- repo +- version +------------------------------- +let upstream = -- +in upstream + with packageName.entityName = "new value" +------------------------------- + +Example: +------------------------------- +let upstream = -- +in upstream + with halogen.version = "master" + with halogen.repo = "https://example.com/path/to/git/repo.git" + + with halogen-vdom.version = "v4.0.0" + with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies +------------------------------- + +### Additions + +Purpose: +- Add packages that aren't already included in the default package set + +Syntax: +where `` is: +- a tag (i.e. "v4.0.0") +- a branch (i.e. "master") +- commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") +------------------------------- +let upstream = -- +in upstream + with new-package-name = + { dependencies = + [ "dependency1" + , "dependency2" + ] + , repo = + "https://example.com/path/to/git/repo.git" + , version = + "" + } +------------------------------- + +Example: +------------------------------- +let upstream = -- +in upstream + with benchotron = + { dependencies = + [ "arrays" + , "exists" + , "profunctor" + , "strings" + , "quickcheck" + , "lcg" + , "transformers" + , "foldable-traversable" + , "exceptions" + , "node-fs" + , "node-buffer" + , "node-readline" + , "datetime" + , "now" + ] + , repo = + "https://github.com/hdgarrood/purescript-benchotron.git" + , version = + "v7.0.0" + } +------------------------------- +-} +let upstream = + https://github.com/purescript/package-sets/releases/download/psc-0.14.2-20210713/packages.dhall sha256:654c3148cb995f642c73b4508d987d9896e2ad3ea1d325a1e826c034c0d3cd7b + +in upstream diff --git a/impls/purs/run b/impls/purs/run index 6a4a5dd75b..1369498770 100755 --- a/impls/purs/run +++ b/impls/purs/run @@ -1,2 +1,2 @@ -#!/bin/bash +#!/bin/bash exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" \ No newline at end of file diff --git a/impls/purs/spago.dhall b/impls/purs/spago.dhall index 2334ad7617..82adf5b2e5 100644 --- a/impls/purs/spago.dhall +++ b/impls/purs/spago.dhall @@ -1,43 +1,43 @@ -{- -Welcome to a Spago project! -You can edit this file as you like. - -Need help? See the following resources: -- Spago documentation: https://github.com/purescript/spago -- Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html - -When creating a new Spago project, you can use -`spago init --no-comments` or `spago init -C` -to generate this file without the comments in this block. --} -{ name = "mal-purescript" -, dependencies = - [ "arrays" - , "console" - , "control" - , "datetime" - , "effect" - , "either" - , "exceptions" - , "foldable-traversable" - , "freet" - , "identity" - , "integers" - , "lists" - , "maybe" - , "node-buffer" - , "node-fs" - , "now" - , "ordered-collections" - , "parsing" - , "prelude" - , "psci-support" - , "refs" - , "strings" - , "tailrec" - , "transformers" - , "tuples" - ] -, packages = ./packages.dhall -, sources = [ "src/**/*.purs", "test/**/*.purs" ] -} +{- +Welcome to a Spago project! +You can edit this file as you like. + +Need help? See the following resources: +- Spago documentation: https://github.com/purescript/spago +- Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html + +When creating a new Spago project, you can use +`spago init --no-comments` or `spago init -C` +to generate this file without the comments in this block. +-} +{ name = "mal-purescript" +, dependencies = + [ "arrays" + , "console" + , "control" + , "datetime" + , "effect" + , "either" + , "exceptions" + , "foldable-traversable" + , "freet" + , "identity" + , "integers" + , "lists" + , "maybe" + , "node-buffer" + , "node-fs" + , "now" + , "ordered-collections" + , "parsing" + , "prelude" + , "psci-support" + , "refs" + , "strings" + , "tailrec" + , "transformers" + , "tuples" + ] +, packages = ./packages.dhall +, sources = [ "src/**/*.purs", "test/**/*.purs" ] +} diff --git a/impls/purs/src/Core.purs b/impls/purs/src/Core.purs index b5060032f0..10a0495844 100644 --- a/impls/purs/src/Core.purs +++ b/impls/purs/src/Core.purs @@ -1,515 +1,515 @@ -module Core (ns) where - -import Prelude - -import Data.DateTime.Instant (unInstant) -import Data.Int (ceil, toNumber) -import Data.List (List(..), concat, drop, foldM, fromFoldable, length, reverse, (:)) -import Data.Map.Internal as Map -import Data.Maybe (Maybe(..)) -import Data.String (take) -import Data.String.CodeUnits (singleton) -import Data.Time.Duration (Milliseconds(..), toDuration) -import Data.Traversable (traverse) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Class (liftEffect) -import Effect.Console (log) -import Effect.Exception (throw) -import Effect.Now (now) -import Effect.Ref as Ref -import Reader (readStr) -import Node.Encoding (Encoding(..)) -import Node.FS.Sync (readTextFile) -import Printer (keyValuePairs, printList, printListReadably, printStrReadably) -import Readline (readLine) -import Types (Key(..), MalExpr(..), MalFn, Meta(..), keyToString, stringToCharList, toAtom, toHashMap, toList, toVector) - - - -ns :: List (Tuple String MalFn) -ns = fromFoldable - [ Tuple "throw" throw' - - , Tuple "true?" $ pred1 trueQ - , Tuple "false?" $ pred1 falseQ - - , Tuple "=" eqQ - , Tuple "+" $ numOp (+) - , Tuple "-" $ numOp (-) - , Tuple "*" $ numOp (*) - , Tuple "/" $ numOp (/) - , Tuple "<" $ cmpOp (<) - , Tuple "<=" $ cmpOp (<=) - , Tuple ">" $ cmpOp (>) - , Tuple ">=" $ cmpOp (>=) - , Tuple "number?" $ pred1 numberQ - - , Tuple "pr-str" prStr - , Tuple "str" str - , Tuple "string?" $ pred1 stringQ - , Tuple "prn" prn - , Tuple "println" println - , Tuple "slurp" slurp - , Tuple "readline" readline' - , Tuple "read-string" readString - , Tuple "time-ms" timeMs - - , Tuple "symbol?" $ pred1 symbolQ - , Tuple "symbol" symbol - , Tuple "keyword?" $ pred1 keywordQ - , Tuple "keyword" keyword - - , Tuple "list" list - , Tuple "list?" $ pred1 listQ - , Tuple "nil?" $ pred1 nilQ - , Tuple "empty?" $ pred1 emptyQ - , Tuple "count" count - , Tuple "sequential?" $ pred1 sequentialQ - , Tuple "cons" cons - , Tuple "concat" concat' - , Tuple "nth" nth - , Tuple "first" first - , Tuple "rest" rest - , Tuple "apply" apply' - , Tuple "map" map' - , Tuple "map?" $ pred1 mapQ - , Tuple "conj" conj' - , Tuple "seq" seq - - , Tuple "vec" vec - , Tuple "vector" vector - , Tuple "vector?" $ pred1 vectorQ - - , Tuple "hash-map" hashMap - , Tuple "assoc" assoc - , Tuple "dissoc" dissoc - , Tuple "get" get - , Tuple "contains?" containsQ - , Tuple "keys" keys - , Tuple "vals" vals - - , Tuple "meta" meta - , Tuple "with-meta" withMeta - - , Tuple "atom" atom - , Tuple "atom?" $ pred1 atomQ - , Tuple "deref" deref - , Tuple "reset!" resetB - , Tuple "swap!" swapB - - , Tuple "macro?" $ pred1 macroQ - - , Tuple "fn?" $ pred1 fnQ - ] - - - --- General functions - -eqQ :: MalFn -eqQ (a:b:Nil) = pure $ MalBoolean $ a == b -eqQ _ = throw "illegal arguments to =" - - - --- Error/Exception functions - -throw' :: MalFn -throw' (e:Nil) = throw =<< printStrReadably e -throw' _ = throw "illegal arguments to throw" - - - --- Boolean functions - -trueQ :: MalExpr -> Boolean -trueQ (MalBoolean true) = true -trueQ _ = false - - -falseQ :: MalExpr -> Boolean -falseQ (MalBoolean false) = true -falseQ _ = false - - --- Numeric functions - -numOp ∷ (Number → Number → Number) → MalFn -numOp op (MalInt n1 : MalInt n2 : Nil) = pure $ MalInt $ ceil $ op (toNumber n1) (toNumber n2) -numOp op (MalInt n1 : MalTime n2 : Nil) = pure $ MalInt $ ceil $ op (toNumber n1) n2 -numOp op (MalTime n1 : MalInt n2 : Nil) = pure $ MalInt $ ceil $ op n1 (toNumber n2) -numOp op (MalTime n1 : MalTime n2 : Nil) = pure $ MalTime $ op n1 n2 -numOp _ _ = throw "invalid operator" - - -cmpOp ∷ (Number → Number → Boolean) → List MalExpr → Effect MalExpr -cmpOp op (MalInt n1 : MalInt n2 : Nil) = pure $ MalBoolean $ op (toNumber n1) (toNumber n2) -cmpOp op (MalInt n1 : MalTime n2 : Nil) = pure $ MalBoolean $ op (toNumber n1) n2 -cmpOp op (MalTime n1 : MalInt n2 : Nil) = pure $ MalBoolean $ op n1 (toNumber n2) -cmpOp op (MalTime n1 : MalTime n2 : Nil) = pure $ MalBoolean $ op n1 n2 -cmpOp _ _ = throw "invalid operator" - - -numberQ :: MalExpr -> Boolean -numberQ (MalInt _) = true -numberQ (MalTime _) = true -numberQ _ = false - - - --- String functions - -prStr :: MalFn -prStr a = liftEffect $ MalString <$> printList a - - -str :: MalFn -str a = liftEffect $ MalString <$> printListReadably "" a - - -stringQ :: MalExpr -> Boolean -stringQ (MalString "") = true -stringQ (MalString s) = take 1 s /= ":" -stringQ _ = false - - -prn :: MalFn -prn args = liftEffect $ do - log =<< printList args - pure MalNil - - -println :: MalFn -println args = liftEffect $ do - log =<< printListReadably " " args - pure MalNil - - -slurp :: MalFn -slurp (MalString path : Nil) = MalString <$> liftEffect (readTextFile UTF8 path) -slurp _ = throw "invalid arguments to slurp" - - -readline' :: MalFn -readline' (MalString prompt : Nil) = MalString <$> readLine prompt -readline' _ = throw "invalid arguments to readline" - - -readString :: MalFn -readString (MalString s : Nil) = readStr s -readString _ = throw "invalid read-string" - - -timeMs :: MalFn -timeMs Nil = do - n <- now - pure $ MalTime $ (unwap <<< toDuration <<< unInstant) n - where - - unwap :: Milliseconds -> Number - unwap (Milliseconds n) = n - -timeMs _ = throw "invalid time-ms" - - - --- Scalar functions - -symbolQ :: MalExpr -> Boolean -symbolQ (MalSymbol _) = true -symbolQ _ = false - - -symbol :: MalFn -symbol (MalString s : Nil) = pure $ MalSymbol s -symbol _ = throw "symbol called with non-string" - - -keywordQ :: MalExpr -> Boolean -keywordQ (MalKeyword s) = take 1 s == ":" -keywordQ _ = false - - -keyword :: MalFn -keyword (kw@(MalString s) : Nil) | take 1 s == ":" = pure kw -keyword (MalString s : Nil) = pure $ MalKeyword (":" <> s) -keyword (kw@(MalKeyword s) : Nil) | take 1 s == ":" = pure kw -keyword (MalKeyword s : Nil) = pure $ MalKeyword (":" <> s) -keyword _ = throw "keyword called with non-string" - - - --- List functions - -list :: MalFn -list = pure <<< toList - - -listQ :: MalExpr -> Boolean -listQ (MalList _ _ ) = true -listQ _ = false - - -nilQ :: MalExpr -> Boolean -nilQ MalNil = true -nilQ _ = false - - -emptyQ :: MalExpr -> Boolean -emptyQ (MalList _ Nil) = true -emptyQ (MalVector _ Nil) = true -emptyQ _ = false - - -count :: MalFn -count (MalNil:Nil) = pure $ MalInt 0 -count (MalList _ ex : Nil) = pure $ MalInt $ length ex -count (MalVector _ ex : Nil) = pure $ MalInt $ length ex -count _ = throw "non-sequence passed to count" - - -sequentialQ :: MalExpr -> Boolean -sequentialQ (MalList _ _) = true -sequentialQ (MalVector _ _) = true -sequentialQ _ = false - - -cons :: MalFn -cons (x:Nil) = pure $ toList $ x:Nil -cons (x : MalList _ xs : Nil) = pure $ toList $ x:xs -cons (x : MalVector _ xs : Nil) = pure $ toList $ x:xs -cons _ = throw "illegal call to cons" - - -concat' :: MalFn -concat' args = toList <<< concat <$> traverse unwrapSeq args - where - - unwrapSeq :: MalExpr -> Effect (List MalExpr) - unwrapSeq (MalList _ xs) = pure xs - unwrapSeq (MalVector _ xs) = pure xs - unwrapSeq _ = throw "invalid concat" - - -nth :: MalFn -nth (MalList _ xs : MalInt n : Nil) = - case drop n xs of - x:_ -> pure x - Nil -> throw "nth: index out of range" -nth (MalVector _ xs : MalInt n : Nil) = - case drop n xs of - x:_ -> pure x - Nil -> throw "nth: index out of range" -nth _ = throw "invalid call to nth" - - -first :: MalFn -first (MalNil:Nil) = pure MalNil -first (MalList _ Nil : Nil) = pure MalNil -first (MalList _ (x:_) : Nil) = pure x -first (MalVector _ Nil : Nil) = pure MalNil -first (MalVector _ (x:_) : Nil) = pure x -first _ = throw "illegal call to first" - - -rest :: MalFn -rest (MalNil:Nil) = pure $ toList Nil -rest (MalList _ Nil : Nil) = pure $ toList Nil -rest (MalList _ (_:xs) : Nil) = pure $ toList xs -rest (MalVector _ Nil : Nil) = pure $ toList Nil -rest (MalVector _ (_:xs) : Nil) = pure $ toList xs -rest _ = throw "illegal call to rest" - - -apply' :: MalFn -apply' (MalFunction {fn:f} : as) = f =<< concatLast as - where - concatLast :: List MalExpr -> Effect (List MalExpr) - concatLast (MalList _ lst : Nil) = pure lst - concatLast (MalVector _ lst : Nil) = pure lst - concatLast (x:xs) = (:) x <$> concatLast xs - concatLast _ = throw "last argument of apply must be a sequence" -apply' _ = throw "Illegal call to apply" - - -map' :: MalFn -map' (MalFunction {fn:f} : MalList _ args : Nil) = toList <$> traverse (\x -> f (x:Nil)) args -map' (MalFunction {fn:f} : MalVector _ args : Nil) = toList <$> traverse (\x -> f (x:Nil)) args -map' _ = throw "Illegal call to map" - - -mapQ :: MalExpr -> Boolean -mapQ (MalHashMap _ _) = true -mapQ _ = false - - -conj' :: MalFn -conj' (MalList _ es : args) = pure $ toList $ reverse args <> es -conj' (MalVector _ es : args) = pure $ toVector $ es <> args -conj' _ = throw "illegal arguments to conj" - - -seq :: MalFn -seq (MalNil:Nil) = pure MalNil -seq (MalList _ Nil : Nil) = pure MalNil -seq (MalList _ es : Nil) = pure $ toList es -seq (MalVector _ Nil : Nil) = pure MalNil -seq (MalVector _ es : Nil) = pure $ toList es -seq (MalString "" : Nil) = pure MalNil -seq (MalString s : Nil) = pure $ toList $ map (MalString <<< singleton) (stringToCharList s) -seq _ = throw "seq: called on non-sequence" - - - --- Vector functions - -vec :: MalFn -vec (MalList _ xs : Nil) = pure $ toVector xs -vec (MalVector _ xs : Nil) = pure $ toVector xs -vec Nil = throw "vec: arg type" -vec _ = throw "vec: arg type" - - -vector :: MalFn -vector = pure <<< toVector - - -vectorQ :: MalExpr -> Boolean -vectorQ (MalVector _ _) = true -vectorQ _ = false - - - --- Hash Map functions - -hashMap :: MalFn -hashMap kvs = - case keyValuePairs kvs of - Just pairs -> pure $ toHashMap $ Map.fromFoldable pairs - Nothing -> throw "invalid call to hash-map" - - -assoc :: MalFn -assoc (MalHashMap _ hm : kvs) = - case keyValuePairs kvs of - Just pairs -> pure $ toHashMap $ Map.union (Map.fromFoldable pairs) hm - Nothing -> throw "invalid assoc" -assoc _ = throw "invalid call to assoc" - - -dissoc :: MalFn -dissoc (MalHashMap _ hm : ks) = toHashMap <$> foldM remover hm ks - where - remover :: Map.Map Key MalExpr -> MalExpr -> Effect (Map.Map Key MalExpr) - remover m (MalKeyword k) = pure $ Map.delete (KeywordKey k) m - remover m (MalString k) = pure $ Map.delete (StringKey k) m - remover _ _ = throw "invalid dissoc" -dissoc _ = throw "invalid call to dissoc" - - -get :: MalFn -get (MalHashMap _ hm : MalString k : Nil) = - pure case Map.lookup (StringKey k) hm of - Just mv -> mv - Nothing -> MalNil -get (MalHashMap _ hm : MalKeyword k : Nil) = - pure case Map.lookup (KeywordKey k) hm of - Just mv -> mv - Nothing -> MalNil -get (MalNil : MalString _ : Nil) = pure MalNil -get _ = throw "invalid call to get" - - -containsQ :: MalFn -containsQ (MalHashMap _ hm : MalString k : Nil) = pure $ MalBoolean $ Map.member (StringKey k) hm -containsQ (MalHashMap _ hm : MalKeyword k : Nil) = pure $ MalBoolean $ Map.member (KeywordKey k) hm -containsQ (MalNil : MalString _ : Nil) = pure $ MalBoolean false -containsQ _ = throw "invalid call to contains?" - - -keys :: MalFn -keys (MalHashMap _ hm : Nil) = pure $ toList $ keyToString <$> Map.keys hm -keys _ = throw "invalid call to keys" - - -vals :: MalFn -vals (MalHashMap _ hm : Nil) = pure $ toList $ Map.values hm -vals _ = throw "invalid call to vals" - - - --- Metadata functions - -meta :: MalFn -meta (MalList (Meta m) _ : Nil) = pure m -meta (MalVector (Meta m) _ : Nil) = pure m -meta (MalHashMap (Meta m) _ : Nil) = pure m -meta (MalAtom (Meta m) _ : Nil) = pure m -meta (MalFunction {meta:m} : Nil) = pure m -meta _ = throw "invalid meta call" - - -withMeta :: MalFn -withMeta (MalList _ es : m : Nil) = pure $ MalList (Meta m) es -withMeta (MalVector _ es : m : Nil) = pure $ MalVector (Meta m) es -withMeta (MalHashMap _ es : m : Nil) = pure $ MalHashMap (Meta m) es -withMeta (MalAtom _ es : m : Nil) = pure $ MalAtom (Meta m) es -withMeta ((MalFunction f) : m : Nil) = pure $ MalFunction $ f {meta = m} -withMeta _ = throw "invalid with-meta call" - - - --- Atom functions - -atom :: MalFn -atom (v:Nil) = toAtom <$> liftEffect (Ref.new v) -atom _ = throw "invalid atom call" - - -atomQ :: MalExpr -> Boolean -atomQ (MalAtom _ _) = true -atomQ _ = false - - -deref :: MalFn -deref (MalAtom _ ref : Nil) = liftEffect $ Ref.read ref -deref _ = throw "invalid deref call" - - -resetB :: MalFn -resetB (MalAtom _ ref : val : Nil) = liftEffect $ Ref.write val ref *> pure val -resetB _ = throw "invalid reset!" - - -swapB :: MalFn -swapB (MalAtom _ ref : MalFunction {fn:f} : args) = do - val <- liftEffect $ Ref.read ref - newVal <- f $ val:args - liftEffect $ Ref.write newVal ref - pure newVal -swapB _ = throw "Illegal swap!" - - - --- Macro - -macroQ :: MalExpr -> Boolean -macroQ (MalFunction {macro:true}) = true -macroQ _ = false - - - --- Function - -fnQ :: MalExpr -> Boolean -fnQ (MalFunction {macro:false}) = true -fnQ _ = false - - - --- Utils - -pred1 :: (MalExpr -> Boolean) -> MalFn -pred1 f (x:Nil) = pure $ MalBoolean $ f x +module Core (ns) where + +import Prelude + +import Data.DateTime.Instant (unInstant) +import Data.Int (ceil, toNumber) +import Data.List (List(..), concat, drop, foldM, fromFoldable, length, reverse, (:)) +import Data.Map.Internal as Map +import Data.Maybe (Maybe(..)) +import Data.String (take) +import Data.String.CodeUnits (singleton) +import Data.Time.Duration (Milliseconds(..), toDuration) +import Data.Traversable (traverse) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Class (liftEffect) +import Effect.Console (log) +import Effect.Exception (throw) +import Effect.Now (now) +import Effect.Ref as Ref +import Reader (readStr) +import Node.Encoding (Encoding(..)) +import Node.FS.Sync (readTextFile) +import Printer (keyValuePairs, printList, printListReadably, printStrReadably) +import Readline (readLine) +import Types (Key(..), MalExpr(..), MalFn, Meta(..), keyToString, stringToCharList, toAtom, toHashMap, toList, toVector) + + + +ns :: List (Tuple String MalFn) +ns = fromFoldable + [ Tuple "throw" throw' + + , Tuple "true?" $ pred1 trueQ + , Tuple "false?" $ pred1 falseQ + + , Tuple "=" eqQ + , Tuple "+" $ numOp (+) + , Tuple "-" $ numOp (-) + , Tuple "*" $ numOp (*) + , Tuple "/" $ numOp (/) + , Tuple "<" $ cmpOp (<) + , Tuple "<=" $ cmpOp (<=) + , Tuple ">" $ cmpOp (>) + , Tuple ">=" $ cmpOp (>=) + , Tuple "number?" $ pred1 numberQ + + , Tuple "pr-str" prStr + , Tuple "str" str + , Tuple "string?" $ pred1 stringQ + , Tuple "prn" prn + , Tuple "println" println + , Tuple "slurp" slurp + , Tuple "readline" readline' + , Tuple "read-string" readString + , Tuple "time-ms" timeMs + + , Tuple "symbol?" $ pred1 symbolQ + , Tuple "symbol" symbol + , Tuple "keyword?" $ pred1 keywordQ + , Tuple "keyword" keyword + + , Tuple "list" list + , Tuple "list?" $ pred1 listQ + , Tuple "nil?" $ pred1 nilQ + , Tuple "empty?" $ pred1 emptyQ + , Tuple "count" count + , Tuple "sequential?" $ pred1 sequentialQ + , Tuple "cons" cons + , Tuple "concat" concat' + , Tuple "nth" nth + , Tuple "first" first + , Tuple "rest" rest + , Tuple "apply" apply' + , Tuple "map" map' + , Tuple "map?" $ pred1 mapQ + , Tuple "conj" conj' + , Tuple "seq" seq + + , Tuple "vec" vec + , Tuple "vector" vector + , Tuple "vector?" $ pred1 vectorQ + + , Tuple "hash-map" hashMap + , Tuple "assoc" assoc + , Tuple "dissoc" dissoc + , Tuple "get" get + , Tuple "contains?" containsQ + , Tuple "keys" keys + , Tuple "vals" vals + + , Tuple "meta" meta + , Tuple "with-meta" withMeta + + , Tuple "atom" atom + , Tuple "atom?" $ pred1 atomQ + , Tuple "deref" deref + , Tuple "reset!" resetB + , Tuple "swap!" swapB + + , Tuple "macro?" $ pred1 macroQ + + , Tuple "fn?" $ pred1 fnQ + ] + + + +-- General functions + +eqQ :: MalFn +eqQ (a:b:Nil) = pure $ MalBoolean $ a == b +eqQ _ = throw "illegal arguments to =" + + + +-- Error/Exception functions + +throw' :: MalFn +throw' (e:Nil) = throw =<< printStrReadably e +throw' _ = throw "illegal arguments to throw" + + + +-- Boolean functions + +trueQ :: MalExpr -> Boolean +trueQ (MalBoolean true) = true +trueQ _ = false + + +falseQ :: MalExpr -> Boolean +falseQ (MalBoolean false) = true +falseQ _ = false + + +-- Numeric functions + +numOp ∷ (Number → Number → Number) → MalFn +numOp op (MalInt n1 : MalInt n2 : Nil) = pure $ MalInt $ ceil $ op (toNumber n1) (toNumber n2) +numOp op (MalInt n1 : MalTime n2 : Nil) = pure $ MalInt $ ceil $ op (toNumber n1) n2 +numOp op (MalTime n1 : MalInt n2 : Nil) = pure $ MalInt $ ceil $ op n1 (toNumber n2) +numOp op (MalTime n1 : MalTime n2 : Nil) = pure $ MalTime $ op n1 n2 +numOp _ _ = throw "invalid operator" + + +cmpOp ∷ (Number → Number → Boolean) → List MalExpr → Effect MalExpr +cmpOp op (MalInt n1 : MalInt n2 : Nil) = pure $ MalBoolean $ op (toNumber n1) (toNumber n2) +cmpOp op (MalInt n1 : MalTime n2 : Nil) = pure $ MalBoolean $ op (toNumber n1) n2 +cmpOp op (MalTime n1 : MalInt n2 : Nil) = pure $ MalBoolean $ op n1 (toNumber n2) +cmpOp op (MalTime n1 : MalTime n2 : Nil) = pure $ MalBoolean $ op n1 n2 +cmpOp _ _ = throw "invalid operator" + + +numberQ :: MalExpr -> Boolean +numberQ (MalInt _) = true +numberQ (MalTime _) = true +numberQ _ = false + + + +-- String functions + +prStr :: MalFn +prStr a = liftEffect $ MalString <$> printList a + + +str :: MalFn +str a = liftEffect $ MalString <$> printListReadably "" a + + +stringQ :: MalExpr -> Boolean +stringQ (MalString "") = true +stringQ (MalString s) = take 1 s /= ":" +stringQ _ = false + + +prn :: MalFn +prn args = liftEffect $ do + log =<< printList args + pure MalNil + + +println :: MalFn +println args = liftEffect $ do + log =<< printListReadably " " args + pure MalNil + + +slurp :: MalFn +slurp (MalString path : Nil) = MalString <$> liftEffect (readTextFile UTF8 path) +slurp _ = throw "invalid arguments to slurp" + + +readline' :: MalFn +readline' (MalString prompt : Nil) = MalString <$> readLine prompt +readline' _ = throw "invalid arguments to readline" + + +readString :: MalFn +readString (MalString s : Nil) = readStr s +readString _ = throw "invalid read-string" + + +timeMs :: MalFn +timeMs Nil = do + n <- now + pure $ MalTime $ (unwap <<< toDuration <<< unInstant) n + where + + unwap :: Milliseconds -> Number + unwap (Milliseconds n) = n + +timeMs _ = throw "invalid time-ms" + + + +-- Scalar functions + +symbolQ :: MalExpr -> Boolean +symbolQ (MalSymbol _) = true +symbolQ _ = false + + +symbol :: MalFn +symbol (MalString s : Nil) = pure $ MalSymbol s +symbol _ = throw "symbol called with non-string" + + +keywordQ :: MalExpr -> Boolean +keywordQ (MalKeyword s) = take 1 s == ":" +keywordQ _ = false + + +keyword :: MalFn +keyword (kw@(MalString s) : Nil) | take 1 s == ":" = pure kw +keyword (MalString s : Nil) = pure $ MalKeyword (":" <> s) +keyword (kw@(MalKeyword s) : Nil) | take 1 s == ":" = pure kw +keyword (MalKeyword s : Nil) = pure $ MalKeyword (":" <> s) +keyword _ = throw "keyword called with non-string" + + + +-- List functions + +list :: MalFn +list = pure <<< toList + + +listQ :: MalExpr -> Boolean +listQ (MalList _ _ ) = true +listQ _ = false + + +nilQ :: MalExpr -> Boolean +nilQ MalNil = true +nilQ _ = false + + +emptyQ :: MalExpr -> Boolean +emptyQ (MalList _ Nil) = true +emptyQ (MalVector _ Nil) = true +emptyQ _ = false + + +count :: MalFn +count (MalNil:Nil) = pure $ MalInt 0 +count (MalList _ ex : Nil) = pure $ MalInt $ length ex +count (MalVector _ ex : Nil) = pure $ MalInt $ length ex +count _ = throw "non-sequence passed to count" + + +sequentialQ :: MalExpr -> Boolean +sequentialQ (MalList _ _) = true +sequentialQ (MalVector _ _) = true +sequentialQ _ = false + + +cons :: MalFn +cons (x:Nil) = pure $ toList $ x:Nil +cons (x : MalList _ xs : Nil) = pure $ toList $ x:xs +cons (x : MalVector _ xs : Nil) = pure $ toList $ x:xs +cons _ = throw "illegal call to cons" + + +concat' :: MalFn +concat' args = toList <<< concat <$> traverse unwrapSeq args + where + + unwrapSeq :: MalExpr -> Effect (List MalExpr) + unwrapSeq (MalList _ xs) = pure xs + unwrapSeq (MalVector _ xs) = pure xs + unwrapSeq _ = throw "invalid concat" + + +nth :: MalFn +nth (MalList _ xs : MalInt n : Nil) = + case drop n xs of + x:_ -> pure x + Nil -> throw "nth: index out of range" +nth (MalVector _ xs : MalInt n : Nil) = + case drop n xs of + x:_ -> pure x + Nil -> throw "nth: index out of range" +nth _ = throw "invalid call to nth" + + +first :: MalFn +first (MalNil:Nil) = pure MalNil +first (MalList _ Nil : Nil) = pure MalNil +first (MalList _ (x:_) : Nil) = pure x +first (MalVector _ Nil : Nil) = pure MalNil +first (MalVector _ (x:_) : Nil) = pure x +first _ = throw "illegal call to first" + + +rest :: MalFn +rest (MalNil:Nil) = pure $ toList Nil +rest (MalList _ Nil : Nil) = pure $ toList Nil +rest (MalList _ (_:xs) : Nil) = pure $ toList xs +rest (MalVector _ Nil : Nil) = pure $ toList Nil +rest (MalVector _ (_:xs) : Nil) = pure $ toList xs +rest _ = throw "illegal call to rest" + + +apply' :: MalFn +apply' (MalFunction {fn:f} : as) = f =<< concatLast as + where + concatLast :: List MalExpr -> Effect (List MalExpr) + concatLast (MalList _ lst : Nil) = pure lst + concatLast (MalVector _ lst : Nil) = pure lst + concatLast (x:xs) = (:) x <$> concatLast xs + concatLast _ = throw "last argument of apply must be a sequence" +apply' _ = throw "Illegal call to apply" + + +map' :: MalFn +map' (MalFunction {fn:f} : MalList _ args : Nil) = toList <$> traverse (\x -> f (x:Nil)) args +map' (MalFunction {fn:f} : MalVector _ args : Nil) = toList <$> traverse (\x -> f (x:Nil)) args +map' _ = throw "Illegal call to map" + + +mapQ :: MalExpr -> Boolean +mapQ (MalHashMap _ _) = true +mapQ _ = false + + +conj' :: MalFn +conj' (MalList _ es : args) = pure $ toList $ reverse args <> es +conj' (MalVector _ es : args) = pure $ toVector $ es <> args +conj' _ = throw "illegal arguments to conj" + + +seq :: MalFn +seq (MalNil:Nil) = pure MalNil +seq (MalList _ Nil : Nil) = pure MalNil +seq (MalList _ es : Nil) = pure $ toList es +seq (MalVector _ Nil : Nil) = pure MalNil +seq (MalVector _ es : Nil) = pure $ toList es +seq (MalString "" : Nil) = pure MalNil +seq (MalString s : Nil) = pure $ toList $ map (MalString <<< singleton) (stringToCharList s) +seq _ = throw "seq: called on non-sequence" + + + +-- Vector functions + +vec :: MalFn +vec (MalList _ xs : Nil) = pure $ toVector xs +vec (MalVector _ xs : Nil) = pure $ toVector xs +vec Nil = throw "vec: arg type" +vec _ = throw "vec: arg type" + + +vector :: MalFn +vector = pure <<< toVector + + +vectorQ :: MalExpr -> Boolean +vectorQ (MalVector _ _) = true +vectorQ _ = false + + + +-- Hash Map functions + +hashMap :: MalFn +hashMap kvs = + case keyValuePairs kvs of + Just pairs -> pure $ toHashMap $ Map.fromFoldable pairs + Nothing -> throw "invalid call to hash-map" + + +assoc :: MalFn +assoc (MalHashMap _ hm : kvs) = + case keyValuePairs kvs of + Just pairs -> pure $ toHashMap $ Map.union (Map.fromFoldable pairs) hm + Nothing -> throw "invalid assoc" +assoc _ = throw "invalid call to assoc" + + +dissoc :: MalFn +dissoc (MalHashMap _ hm : ks) = toHashMap <$> foldM remover hm ks + where + remover :: Map.Map Key MalExpr -> MalExpr -> Effect (Map.Map Key MalExpr) + remover m (MalKeyword k) = pure $ Map.delete (KeywordKey k) m + remover m (MalString k) = pure $ Map.delete (StringKey k) m + remover _ _ = throw "invalid dissoc" +dissoc _ = throw "invalid call to dissoc" + + +get :: MalFn +get (MalHashMap _ hm : MalString k : Nil) = + pure case Map.lookup (StringKey k) hm of + Just mv -> mv + Nothing -> MalNil +get (MalHashMap _ hm : MalKeyword k : Nil) = + pure case Map.lookup (KeywordKey k) hm of + Just mv -> mv + Nothing -> MalNil +get (MalNil : MalString _ : Nil) = pure MalNil +get _ = throw "invalid call to get" + + +containsQ :: MalFn +containsQ (MalHashMap _ hm : MalString k : Nil) = pure $ MalBoolean $ Map.member (StringKey k) hm +containsQ (MalHashMap _ hm : MalKeyword k : Nil) = pure $ MalBoolean $ Map.member (KeywordKey k) hm +containsQ (MalNil : MalString _ : Nil) = pure $ MalBoolean false +containsQ _ = throw "invalid call to contains?" + + +keys :: MalFn +keys (MalHashMap _ hm : Nil) = pure $ toList $ keyToString <$> Map.keys hm +keys _ = throw "invalid call to keys" + + +vals :: MalFn +vals (MalHashMap _ hm : Nil) = pure $ toList $ Map.values hm +vals _ = throw "invalid call to vals" + + + +-- Metadata functions + +meta :: MalFn +meta (MalList (Meta m) _ : Nil) = pure m +meta (MalVector (Meta m) _ : Nil) = pure m +meta (MalHashMap (Meta m) _ : Nil) = pure m +meta (MalAtom (Meta m) _ : Nil) = pure m +meta (MalFunction {meta:m} : Nil) = pure m +meta _ = throw "invalid meta call" + + +withMeta :: MalFn +withMeta (MalList _ es : m : Nil) = pure $ MalList (Meta m) es +withMeta (MalVector _ es : m : Nil) = pure $ MalVector (Meta m) es +withMeta (MalHashMap _ es : m : Nil) = pure $ MalHashMap (Meta m) es +withMeta (MalAtom _ es : m : Nil) = pure $ MalAtom (Meta m) es +withMeta ((MalFunction f) : m : Nil) = pure $ MalFunction $ f {meta = m} +withMeta _ = throw "invalid with-meta call" + + + +-- Atom functions + +atom :: MalFn +atom (v:Nil) = toAtom <$> liftEffect (Ref.new v) +atom _ = throw "invalid atom call" + + +atomQ :: MalExpr -> Boolean +atomQ (MalAtom _ _) = true +atomQ _ = false + + +deref :: MalFn +deref (MalAtom _ ref : Nil) = liftEffect $ Ref.read ref +deref _ = throw "invalid deref call" + + +resetB :: MalFn +resetB (MalAtom _ ref : val : Nil) = liftEffect $ Ref.write val ref *> pure val +resetB _ = throw "invalid reset!" + + +swapB :: MalFn +swapB (MalAtom _ ref : MalFunction {fn:f} : args) = do + val <- liftEffect $ Ref.read ref + newVal <- f $ val:args + liftEffect $ Ref.write newVal ref + pure newVal +swapB _ = throw "Illegal swap!" + + + +-- Macro + +macroQ :: MalExpr -> Boolean +macroQ (MalFunction {macro:true}) = true +macroQ _ = false + + + +-- Function + +fnQ :: MalExpr -> Boolean +fnQ (MalFunction {macro:false}) = true +fnQ _ = false + + + +-- Utils + +pred1 :: (MalExpr -> Boolean) -> MalFn +pred1 f (x:Nil) = pure $ MalBoolean $ f x pred1 _ _ = throw "illegal call to unary predicate" \ No newline at end of file diff --git a/impls/purs/src/Env.purs b/impls/purs/src/Env.purs index b75e71e0b5..e929e03fe4 100644 --- a/impls/purs/src/Env.purs +++ b/impls/purs/src/Env.purs @@ -1,46 +1,46 @@ -module Env where - -import Prelude - -import Data.List (List(..), (:)) -import Data.Map (fromFoldable, insert, lookup) -import Data.Maybe (Maybe(..)) -import Effect (Effect) -import Effect.Console (error) -import Effect.Ref as Ref -import Types (Local, MalExpr, RefEnv, toList) - - - --- Environment - -initEnv :: Local -initEnv = fromFoldable Nil - - -newEnv :: RefEnv -> Effect RefEnv -newEnv re = flip (:) re <$> Ref.new initEnv - - - --- VARIABLE - -get :: RefEnv -> String -> Effect (Maybe MalExpr) -get Nil _ = pure Nothing -get (ref:outer) ky = do - envs <- Ref.read ref - case lookup ky envs of - Nothing -> get outer ky - ex -> pure ex - - -sets :: RefEnv -> List String -> List MalExpr -> Effect Boolean -sets _ Nil Nil = pure true -sets env ("&":k:Nil) exs = set env k (toList exs) *> pure true -sets env (ky:kys) (ex:exs) = set env ky ex *> sets env kys exs -sets _ _ _ = pure false - - -set :: RefEnv -> String -> MalExpr -> Effect Unit -set (re:_) ky ex = Ref.modify_ (insert ky ex) re +module Env where + +import Prelude + +import Data.List (List(..), (:)) +import Data.Map (fromFoldable, insert, lookup) +import Data.Maybe (Maybe(..)) +import Effect (Effect) +import Effect.Console (error) +import Effect.Ref as Ref +import Types (Local, MalExpr, RefEnv, toList) + + + +-- Environment + +initEnv :: Local +initEnv = fromFoldable Nil + + +newEnv :: RefEnv -> Effect RefEnv +newEnv re = flip (:) re <$> Ref.new initEnv + + + +-- VARIABLE + +get :: RefEnv -> String -> Effect (Maybe MalExpr) +get Nil _ = pure Nothing +get (ref:outer) ky = do + envs <- Ref.read ref + case lookup ky envs of + Nothing -> get outer ky + ex -> pure ex + + +sets :: RefEnv -> List String -> List MalExpr -> Effect Boolean +sets _ Nil Nil = pure true +sets env ("&":k:Nil) exs = set env k (toList exs) *> pure true +sets env (ky:kys) (ex:exs) = set env ky ex *> sets env kys exs +sets _ _ _ = pure false + + +set :: RefEnv -> String -> MalExpr -> Effect Unit +set (re:_) ky ex = Ref.modify_ (insert ky ex) re set Nil _ _ = error "assertion failed in env_set" \ No newline at end of file diff --git a/impls/purs/src/Printer.purs b/impls/purs/src/Printer.purs index d9011e05e9..ac9dd35ecc 100644 --- a/impls/purs/src/Printer.purs +++ b/impls/purs/src/Printer.purs @@ -1,82 +1,82 @@ -module Printer where - -import Prelude - -import Data.List (List(..), (:)) -import Data.Map (toUnfoldable) -import Data.Maybe (Maybe(..)) -import Data.String.CodeUnits (singleton) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Ref as Ref -import Types (Key(..), MalExpr(..), flatTuples, flatStrings, stringToCharList) - - - --- PRINT STRING - -printStr :: MalExpr -> Effect String -printStr MalNil = pure "nil" -printStr (MalBoolean b) = pure $ show b -printStr (MalInt n) = pure $ show n -printStr (MalTime n) = pure $ show n -printStr (MalString str) = pure $ "\"" <> (str # stringToCharList # map unescape # flatStrings) <> "\"" -printStr (MalKeyword key) = pure key -printStr (MalAtom _ r) = "(atom " <<> (Ref.read r >>= printStr) <>> ")" -printStr (MalSymbol name) = pure name -printStr (MalList _ xs) = "(" <<> printList xs <>> ")" -printStr (MalVector _ vs) = "[" <<> printList vs <>> "]" -printStr (MalHashMap _ hm) = "{" <<> (hm # toUnfoldable # flatTuples # printList) <>> "}" -printStr (MalFunction _) = pure "#" - - -printList :: List MalExpr -> Effect String -printList Nil = pure "" -printList (x:Nil) = printStr x -printList (x:xs) = printStr x <> pure " " <> printList xs - - - --- PRINT STRING READABLY - -printStrReadably :: MalExpr -> Effect String -printStrReadably (MalString str) = pure str -printStrReadably (MalList _ xs) = "(" <<> printListReadably " " xs <>> ")" -printStrReadably (MalVector _ vs) = "[" <<> printListReadably " " vs <>> "]" -printStrReadably (MalHashMap _ hm) = "{" <<> (hm # toUnfoldable # flatTuples # printListReadably " ") <>> "}" -printStrReadably ex = printStr ex - - -printListReadably :: String -> List MalExpr -> Effect String -printListReadably _ Nil = pure "" -printListReadably _ (x:Nil) = printStrReadably x -printListReadably sep (x:xs) = printStrReadably x <> pure sep <> printListReadably sep xs - - - --- UTILS - -unescape :: Char -> String -unescape '\n' = "\\n" -unescape '\\' = "\\\\" -unescape '"' = "\\\"" -unescape c = singleton c - - -keyValuePairs :: List MalExpr -> Maybe (List (Tuple Key MalExpr)) -keyValuePairs Nil = pure Nil -keyValuePairs (MalString k : v : kvs) = (:) (Tuple (StringKey k) v) <$> keyValuePairs kvs -keyValuePairs (MalKeyword k : v : kvs) = (:) (Tuple (KeywordKey k) v) <$> keyValuePairs kvs -keyValuePairs _ = Nothing - - -leftConcat :: forall m s. Bind m => Applicative m => Semigroup s => s -> m s -> m s -leftConcat op f = (<>) <$> pure op <*> f - -infixr 5 leftConcat as <<> - - -rightConcat :: forall m s. Apply m => Semigroup s => Applicative m => m s -> s -> m s -rightConcat f cl = (<>) <$> f <*> pure cl - +module Printer where + +import Prelude + +import Data.List (List(..), (:)) +import Data.Map (toUnfoldable) +import Data.Maybe (Maybe(..)) +import Data.String.CodeUnits (singleton) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Ref as Ref +import Types (Key(..), MalExpr(..), flatTuples, flatStrings, stringToCharList) + + + +-- PRINT STRING + +printStr :: MalExpr -> Effect String +printStr MalNil = pure "nil" +printStr (MalBoolean b) = pure $ show b +printStr (MalInt n) = pure $ show n +printStr (MalTime n) = pure $ show n +printStr (MalString str) = pure $ "\"" <> (str # stringToCharList # map unescape # flatStrings) <> "\"" +printStr (MalKeyword key) = pure key +printStr (MalAtom _ r) = "(atom " <<> (Ref.read r >>= printStr) <>> ")" +printStr (MalSymbol name) = pure name +printStr (MalList _ xs) = "(" <<> printList xs <>> ")" +printStr (MalVector _ vs) = "[" <<> printList vs <>> "]" +printStr (MalHashMap _ hm) = "{" <<> (hm # toUnfoldable # flatTuples # printList) <>> "}" +printStr (MalFunction _) = pure "#" + + +printList :: List MalExpr -> Effect String +printList Nil = pure "" +printList (x:Nil) = printStr x +printList (x:xs) = printStr x <> pure " " <> printList xs + + + +-- PRINT STRING READABLY + +printStrReadably :: MalExpr -> Effect String +printStrReadably (MalString str) = pure str +printStrReadably (MalList _ xs) = "(" <<> printListReadably " " xs <>> ")" +printStrReadably (MalVector _ vs) = "[" <<> printListReadably " " vs <>> "]" +printStrReadably (MalHashMap _ hm) = "{" <<> (hm # toUnfoldable # flatTuples # printListReadably " ") <>> "}" +printStrReadably ex = printStr ex + + +printListReadably :: String -> List MalExpr -> Effect String +printListReadably _ Nil = pure "" +printListReadably _ (x:Nil) = printStrReadably x +printListReadably sep (x:xs) = printStrReadably x <> pure sep <> printListReadably sep xs + + + +-- UTILS + +unescape :: Char -> String +unescape '\n' = "\\n" +unescape '\\' = "\\\\" +unescape '"' = "\\\"" +unescape c = singleton c + + +keyValuePairs :: List MalExpr -> Maybe (List (Tuple Key MalExpr)) +keyValuePairs Nil = pure Nil +keyValuePairs (MalString k : v : kvs) = (:) (Tuple (StringKey k) v) <$> keyValuePairs kvs +keyValuePairs (MalKeyword k : v : kvs) = (:) (Tuple (KeywordKey k) v) <$> keyValuePairs kvs +keyValuePairs _ = Nothing + + +leftConcat :: forall m s. Bind m => Applicative m => Semigroup s => s -> m s -> m s +leftConcat op f = (<>) <$> pure op <*> f + +infixr 5 leftConcat as <<> + + +rightConcat :: forall m s. Apply m => Semigroup s => Applicative m => m s -> s -> m s +rightConcat f cl = (<>) <$> f <*> pure cl + infixr 5 rightConcat as <>> \ No newline at end of file diff --git a/impls/purs/src/Reader.purs b/impls/purs/src/Reader.purs index 03e4795553..9f51d55fb6 100644 --- a/impls/purs/src/Reader.purs +++ b/impls/purs/src/Reader.purs @@ -1,173 +1,173 @@ -module Reader (readStr) where - -import Prelude - -import Control.Alt ((<|>)) -import Control.Lazy (fix) -import Data.Either (Either(..)) -import Data.Int (fromString) -import Data.List (List(..), many, (:)) -import Data.Maybe (Maybe(..), fromMaybe) -import Effect (Effect) -import Effect.Exception (throw) -import Printer (keyValuePairs) -import Text.Parsing.Parser (Parser, fail, runParser) -import Text.Parsing.Parser.Combinators (endBy, skipMany, skipMany1, try) -import Text.Parsing.Parser.String (char, noneOf, oneOf, string) -import Text.Parsing.Parser.Token (digit, letter) -import Types (MalExpr(..), charListToString, listToMap, toHashMap, toList, toVector) - - -spaces :: Parser String Unit -spaces = skipMany1 $ oneOf [',', ' ', '\n'] - - -comment :: Parser String Unit -comment = char ';' *> (skipMany $ noneOf [ '\r', '\n' ]) - - -ignored :: Parser String Unit -ignored = skipMany $ spaces <|> comment - - -symbol :: Parser String Char -symbol = oneOf ['!', '#', '$', '%', '&', '|', '*', '+', '-', '/', ':', '<', '=', '>', '?', '@', '^', '_', '~'] - - -nat :: Parser String Int -nat = do - first <- digit - rest <- many digit - pure <<< fromMaybe 0 <<< fromString <<< charListToString $ first : rest - - -escape :: Parser String Char -escape = char '\\' - *> oneOf ['\\', '\"', 'n'] - <#> case _ of - 'n' -> '\n' - x -> x - - -nonEscape :: Parser String Char -nonEscape = noneOf [ '\"', '\\' ] - - - --- ATOM - -readAtom :: Parser String MalExpr -readAtom = readNumber - <|> try readNegativeNumber - <|> readString - <|> readKeyword - <|> readSymbol - - -readNumber :: Parser String MalExpr -readNumber = MalInt <$> nat - - -readNegativeNumber :: Parser String MalExpr -readNegativeNumber = MalInt <<< negate <$> (char '-' *> nat) - - -readString :: Parser String MalExpr -readString = MalString <$> charListToString <$> (char '"' *> many (escape <|> nonEscape) <* char '"') - - -readKeyword :: Parser String MalExpr -readKeyword = - MalKeyword <$> charListToString - <$> ((:) ':') - <$> (char ':' *> many (letter <|> digit <|> symbol)) - - -readSymbol :: Parser String MalExpr -readSymbol = f <$> (letter <|> symbol) <*> many (letter <|> digit <|> symbol) - where - - f first rest = charListToString (first:rest) - # case _ of - "true" -> MalBoolean true - "false" -> MalBoolean false - "nil" -> MalNil - s -> MalSymbol s - - - --- - -readList :: Parser String MalExpr -readList = fix $ \_ -> - toList <$> (char '(' *> ignored *> endBy readForm ignored <* char ')') - - - --- - -readVector :: Parser String MalExpr -readVector = fix $ \_ -> - toVector <$> (char '[' *> ignored *> endBy readForm ignored <* char ']') - - - --- - -readHashMap :: Parser String MalExpr -readHashMap = fix $ \_ - -> char '{' *> ignored *> endBy readForm ignored <* char '}' - <#> keyValuePairs - >>= case _ of - Just ts -> pure $ toHashMap $ listToMap ts - Nothing -> fail "invalid contents inside map braces" - - - --- MACROS - -readMacro :: Parser String MalExpr -readMacro = fix $ \_ -> - macro "\'" "quote" - <|> macro "`" "quasiquote" - <|> try (macro "~@" "splice-unquote") - <|> macro "~" "unquote" - <|> macro "@" "deref" - <|> readWithMeta - - -macro :: String -> String -> Parser String MalExpr -macro tok sym = addPrefix sym <$> (string tok *> readForm) - where - - addPrefix :: String -> MalExpr -> MalExpr - addPrefix s x = toList $ MalSymbol s : x : Nil - - -readWithMeta :: Parser String MalExpr -readWithMeta = addPrefix <$> (char '^' *> readForm) <*> readForm - where - - addPrefix :: MalExpr -> MalExpr -> MalExpr - addPrefix m x = toList $ MalSymbol "with-meta" : x : m : Nil - - - --- - -readForm :: Parser String MalExpr -readForm = fix $ \_ -> ignored - *> ( readMacro - <|> readList - <|> readVector - <|> readHashMap - <|> readAtom) - - - --- - -readStr :: String -> Effect MalExpr -readStr str = case runParser str readForm of - Left _ -> throw "EOF" +module Reader (readStr) where + +import Prelude + +import Control.Alt ((<|>)) +import Control.Lazy (fix) +import Data.Either (Either(..)) +import Data.Int (fromString) +import Data.List (List(..), many, (:)) +import Data.Maybe (Maybe(..), fromMaybe) +import Effect (Effect) +import Effect.Exception (throw) +import Printer (keyValuePairs) +import Text.Parsing.Parser (Parser, fail, runParser) +import Text.Parsing.Parser.Combinators (endBy, skipMany, skipMany1, try) +import Text.Parsing.Parser.String (char, noneOf, oneOf, string) +import Text.Parsing.Parser.Token (digit, letter) +import Types (MalExpr(..), charListToString, listToMap, toHashMap, toList, toVector) + + +spaces :: Parser String Unit +spaces = skipMany1 $ oneOf [',', ' ', '\n'] + + +comment :: Parser String Unit +comment = char ';' *> (skipMany $ noneOf [ '\r', '\n' ]) + + +ignored :: Parser String Unit +ignored = skipMany $ spaces <|> comment + + +symbol :: Parser String Char +symbol = oneOf ['!', '#', '$', '%', '&', '|', '*', '+', '-', '/', ':', '<', '=', '>', '?', '@', '^', '_', '~'] + + +nat :: Parser String Int +nat = do + first <- digit + rest <- many digit + pure <<< fromMaybe 0 <<< fromString <<< charListToString $ first : rest + + +escape :: Parser String Char +escape = char '\\' + *> oneOf ['\\', '\"', 'n'] + <#> case _ of + 'n' -> '\n' + x -> x + + +nonEscape :: Parser String Char +nonEscape = noneOf [ '\"', '\\' ] + + + +-- ATOM + +readAtom :: Parser String MalExpr +readAtom = readNumber + <|> try readNegativeNumber + <|> readString + <|> readKeyword + <|> readSymbol + + +readNumber :: Parser String MalExpr +readNumber = MalInt <$> nat + + +readNegativeNumber :: Parser String MalExpr +readNegativeNumber = MalInt <<< negate <$> (char '-' *> nat) + + +readString :: Parser String MalExpr +readString = MalString <$> charListToString <$> (char '"' *> many (escape <|> nonEscape) <* char '"') + + +readKeyword :: Parser String MalExpr +readKeyword = + MalKeyword <$> charListToString + <$> ((:) ':') + <$> (char ':' *> many (letter <|> digit <|> symbol)) + + +readSymbol :: Parser String MalExpr +readSymbol = f <$> (letter <|> symbol) <*> many (letter <|> digit <|> symbol) + where + + f first rest = charListToString (first:rest) + # case _ of + "true" -> MalBoolean true + "false" -> MalBoolean false + "nil" -> MalNil + s -> MalSymbol s + + + +-- + +readList :: Parser String MalExpr +readList = fix $ \_ -> + toList <$> (char '(' *> ignored *> endBy readForm ignored <* char ')') + + + +-- + +readVector :: Parser String MalExpr +readVector = fix $ \_ -> + toVector <$> (char '[' *> ignored *> endBy readForm ignored <* char ']') + + + +-- + +readHashMap :: Parser String MalExpr +readHashMap = fix $ \_ + -> char '{' *> ignored *> endBy readForm ignored <* char '}' + <#> keyValuePairs + >>= case _ of + Just ts -> pure $ toHashMap $ listToMap ts + Nothing -> fail "invalid contents inside map braces" + + + +-- MACROS + +readMacro :: Parser String MalExpr +readMacro = fix $ \_ -> + macro "\'" "quote" + <|> macro "`" "quasiquote" + <|> try (macro "~@" "splice-unquote") + <|> macro "~" "unquote" + <|> macro "@" "deref" + <|> readWithMeta + + +macro :: String -> String -> Parser String MalExpr +macro tok sym = addPrefix sym <$> (string tok *> readForm) + where + + addPrefix :: String -> MalExpr -> MalExpr + addPrefix s x = toList $ MalSymbol s : x : Nil + + +readWithMeta :: Parser String MalExpr +readWithMeta = addPrefix <$> (char '^' *> readForm) <*> readForm + where + + addPrefix :: MalExpr -> MalExpr -> MalExpr + addPrefix m x = toList $ MalSymbol "with-meta" : x : m : Nil + + + +-- + +readForm :: Parser String MalExpr +readForm = fix $ \_ -> ignored + *> ( readMacro + <|> readList + <|> readVector + <|> readHashMap + <|> readAtom) + + + +-- + +readStr :: String -> Effect MalExpr +readStr str = case runParser str readForm of + Left _ -> throw "EOF" Right val -> pure val \ No newline at end of file diff --git a/impls/purs/src/Readline.js b/impls/purs/src/Readline.js index 34620123ed..7fffef73e4 100644 --- a/impls/purs/src/Readline.js +++ b/impls/purs/src/Readline.js @@ -1,17 +1,17 @@ -"use strict"; - -var readlineSync = require('readline-sync') - -exports.readLine = function (x) { - return function () { - const result = readlineSync.question(x); - - if(readlineSync.getRawInput() === String.fromCharCode(0)){ - return ":q" - } - return result; - } -} - - +"use strict"; + +var readlineSync = require('readline-sync') + +exports.readLine = function (x) { + return function () { + const result = readlineSync.question(x); + + if(readlineSync.getRawInput() === String.fromCharCode(0)){ + return ":q" + } + return result; + } +} + + exports.argv = process.argv; \ No newline at end of file diff --git a/impls/purs/src/Readline.purs b/impls/purs/src/Readline.purs index 960a7e5e99..f20a3f1418 100644 --- a/impls/purs/src/Readline.purs +++ b/impls/purs/src/Readline.purs @@ -1,16 +1,16 @@ -module Readline where - -import Prelude - -import Data.List (List, drop, fromFoldable) -import Effect (Effect) - - - -foreign import readLine :: String -> Effect String - - -foreign import argv :: Array String - -args :: List String +module Readline where + +import Prelude + +import Data.List (List, drop, fromFoldable) +import Effect (Effect) + + + +foreign import readLine :: String -> Effect String + + +foreign import argv :: Array String + +args :: List String args = drop 2 $ fromFoldable argv \ No newline at end of file diff --git a/impls/purs/src/Types.purs b/impls/purs/src/Types.purs index 32c184f969..ba451f7e6c 100644 --- a/impls/purs/src/Types.purs +++ b/impls/purs/src/Types.purs @@ -1,135 +1,135 @@ -module Types where - -import Prelude - -import Data.Array as Array -import Data.Foldable (class Foldable) -import Data.List (List(..), foldr, (:)) -import Data.List as List -import Data.Map (Map) -import Data.Map.Internal as Map -import Data.Maybe (Maybe(..)) -import Data.String.CodeUnits (fromCharArray, toCharArray) -import Data.Traversable (foldl) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Ref (Ref) -import Effect.Ref as Ref - - -data MalExpr - = MalNil - | MalBoolean Boolean - | MalInt Int - | MalTime Time - | MalString String - | MalKeyword String - | MalSymbol String - | MalAtom Meta (Ref MalExpr) - | MalList Meta (List MalExpr) - | MalVector Meta (List MalExpr) - | MalHashMap Meta (Map Key MalExpr) - | MalFunction { fn :: MalFn - , ast :: MalExpr - , env :: RefEnv - , params :: List String - , macro :: Boolean - , meta :: MalExpr - } - -type Time = Number - - -instance Eq MalExpr where - eq MalNil MalNil = true - eq (MalBoolean a) (MalBoolean b) = a == b - eq (MalInt a) (MalInt b) = a == b - eq (MalTime a) (MalTime b) = a == b - eq (MalString a) (MalString b) = a == b - eq (MalKeyword a) (MalKeyword b) = a == b - eq (MalSymbol a) (MalSymbol b) = a == b - - eq (MalList _ a) (MalList _ b) = a == b - eq (MalVector _ a) (MalList _ b) = a == b - eq (MalList _ a) (MalVector _ b) = a == b - - eq (MalVector _ a) (MalVector _ b) = a == b - eq (MalHashMap _ a) (MalHashMap _ b) = a == b - eq _ _ = false - - -data Key = StringKey String - | KeywordKey String - -derive instance Eq Key -derive instance Ord Key - - -type MalFn = List MalExpr -> Effect MalExpr - - -type Local = Map String MalExpr -type RefEnv = List (Ref.Ref Local) - - - --- Metas - -newtype Meta = Meta MalExpr - - -toList :: List MalExpr -> MalExpr -toList = MalList (Meta MalNil) - - -toVector :: List MalExpr -> MalExpr -toVector = MalVector (Meta MalNil) - - -toAtom :: Ref MalExpr -> MalExpr -toAtom = MalAtom (Meta MalNil) - - -toHashMap :: Map Key MalExpr -> MalExpr -toHashMap = MalHashMap (Meta MalNil) - - - --- Utils - -listToMap :: List (Tuple Key MalExpr) -> Map Key MalExpr -listToMap = Map.fromFoldable - - -charListToString :: List Char -> String -charListToString = fromCharArray <<< Array.fromFoldable - - -stringToCharList :: String -> List Char -stringToCharList = List.fromFoldable <<< toCharArray - - -flatStrings :: List String -> String -flatStrings = foldr (<>) "" - - -flatTuples :: List (Tuple Key MalExpr) -> List MalExpr -flatTuples ((Tuple (StringKey a) b) : xs) = MalString a : b : flatTuples xs -flatTuples ((Tuple (KeywordKey a) b) : xs) = MalKeyword a : b : flatTuples xs -flatTuples _ = Nil - - -foldrM :: forall a m b f. Foldable f => Monad m => (a -> b -> m b) -> b -> f a -> m b -foldrM f z0 xs = foldl c pure xs z0 - where c k x z = f x z >>= k - - -keyToString :: Key -> MalExpr -keyToString (StringKey k) = MalString k -keyToString (KeywordKey k) = MalKeyword k - - -keyValuePairs :: List MalExpr -> Maybe (List (Tuple String MalExpr)) -keyValuePairs Nil = pure Nil -keyValuePairs (MalString k : v : kvs) = (:) (Tuple k v) <$> keyValuePairs kvs +module Types where + +import Prelude + +import Data.Array as Array +import Data.Foldable (class Foldable) +import Data.List (List(..), foldr, (:)) +import Data.List as List +import Data.Map (Map) +import Data.Map.Internal as Map +import Data.Maybe (Maybe(..)) +import Data.String.CodeUnits (fromCharArray, toCharArray) +import Data.Traversable (foldl) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Ref (Ref) +import Effect.Ref as Ref + + +data MalExpr + = MalNil + | MalBoolean Boolean + | MalInt Int + | MalTime Time + | MalString String + | MalKeyword String + | MalSymbol String + | MalAtom Meta (Ref MalExpr) + | MalList Meta (List MalExpr) + | MalVector Meta (List MalExpr) + | MalHashMap Meta (Map Key MalExpr) + | MalFunction { fn :: MalFn + , ast :: MalExpr + , env :: RefEnv + , params :: List String + , macro :: Boolean + , meta :: MalExpr + } + +type Time = Number + + +instance Eq MalExpr where + eq MalNil MalNil = true + eq (MalBoolean a) (MalBoolean b) = a == b + eq (MalInt a) (MalInt b) = a == b + eq (MalTime a) (MalTime b) = a == b + eq (MalString a) (MalString b) = a == b + eq (MalKeyword a) (MalKeyword b) = a == b + eq (MalSymbol a) (MalSymbol b) = a == b + + eq (MalList _ a) (MalList _ b) = a == b + eq (MalVector _ a) (MalList _ b) = a == b + eq (MalList _ a) (MalVector _ b) = a == b + + eq (MalVector _ a) (MalVector _ b) = a == b + eq (MalHashMap _ a) (MalHashMap _ b) = a == b + eq _ _ = false + + +data Key = StringKey String + | KeywordKey String + +derive instance Eq Key +derive instance Ord Key + + +type MalFn = List MalExpr -> Effect MalExpr + + +type Local = Map String MalExpr +type RefEnv = List (Ref.Ref Local) + + + +-- Metas + +newtype Meta = Meta MalExpr + + +toList :: List MalExpr -> MalExpr +toList = MalList (Meta MalNil) + + +toVector :: List MalExpr -> MalExpr +toVector = MalVector (Meta MalNil) + + +toAtom :: Ref MalExpr -> MalExpr +toAtom = MalAtom (Meta MalNil) + + +toHashMap :: Map Key MalExpr -> MalExpr +toHashMap = MalHashMap (Meta MalNil) + + + +-- Utils + +listToMap :: List (Tuple Key MalExpr) -> Map Key MalExpr +listToMap = Map.fromFoldable + + +charListToString :: List Char -> String +charListToString = fromCharArray <<< Array.fromFoldable + + +stringToCharList :: String -> List Char +stringToCharList = List.fromFoldable <<< toCharArray + + +flatStrings :: List String -> String +flatStrings = foldr (<>) "" + + +flatTuples :: List (Tuple Key MalExpr) -> List MalExpr +flatTuples ((Tuple (StringKey a) b) : xs) = MalString a : b : flatTuples xs +flatTuples ((Tuple (KeywordKey a) b) : xs) = MalKeyword a : b : flatTuples xs +flatTuples _ = Nil + + +foldrM :: forall a m b f. Foldable f => Monad m => (a -> b -> m b) -> b -> f a -> m b +foldrM f z0 xs = foldl c pure xs z0 + where c k x z = f x z >>= k + + +keyToString :: Key -> MalExpr +keyToString (StringKey k) = MalString k +keyToString (KeywordKey k) = MalKeyword k + + +keyValuePairs :: List MalExpr -> Maybe (List (Tuple String MalExpr)) +keyValuePairs Nil = pure Nil +keyValuePairs (MalString k : v : kvs) = (:) (Tuple k v) <$> keyValuePairs kvs keyValuePairs _ = Nothing \ No newline at end of file diff --git a/impls/purs/src/step0_repl.purs b/impls/purs/src/step0_repl.purs index f9cc6be1de..d19d426bad 100644 --- a/impls/purs/src/step0_repl.purs +++ b/impls/purs/src/step0_repl.purs @@ -1,51 +1,51 @@ -module Mal.Step0 where - -import Prelude -import Effect (Effect) -import Effect.Console (log) -import Readline (readLine) - - --- MAIN - -main :: Effect Unit -main = loop - - - --- EVAL - -eval :: String -> String -eval s = s - - - --- REPL - -rep :: String -> String -rep = read >>> eval >>> print - -loop :: Effect Unit -loop = do - line <- readLine "user> " - case line of - "" -> loop - ":q" -> pure unit - _ -> do - log line - loop - - - --- READ - -read :: String -> String -read s = s - - - --- PRINT - -print :: String -> String -print s = s - +module Mal.Step0 where + +import Prelude +import Effect (Effect) +import Effect.Console (log) +import Readline (readLine) + + +-- MAIN + +main :: Effect Unit +main = loop + + + +-- EVAL + +eval :: String -> String +eval s = s + + + +-- REPL + +rep :: String -> String +rep = read >>> eval >>> print + +loop :: Effect Unit +loop = do + line <- readLine "user> " + case line of + "" -> loop + ":q" -> pure unit + _ -> do + log line + loop + + + +-- READ + +read :: String -> String +read s = s + + + +-- PRINT + +print :: String -> String +print s = s + diff --git a/impls/purs/src/step1_read_print.purs b/impls/purs/src/step1_read_print.purs index 13c104e893..d038665301 100644 --- a/impls/purs/src/step1_read_print.purs +++ b/impls/purs/src/step1_read_print.purs @@ -1,61 +1,61 @@ -module Mal.Step1 where - -import Prelude - -import Control.Monad.Error.Class (try) -import Data.Either (Either(..)) -import Effect (Effect) -import Effect.Console (error, log) -import Printer (printStr) -import Reader (readStr) -import Readline (readLine) -import Types (MalExpr) - - --- MAIN - -main :: Effect Unit -main = loop - - - --- EVAL - -eval :: MalExpr -> MalExpr -eval s = s - - - --- REPL - -rep :: String -> Effect Unit -rep str = do - result <- try $ read str - case result of - Left err -> error $ show err - Right exp -> print (eval exp) >>= log - - -loop :: Effect Unit -loop = do - line <- readLine "user> " - case line of - "" -> loop - ":q" -> pure unit - _ -> do - rep line - loop - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String +module Mal.Step1 where + +import Prelude + +import Control.Monad.Error.Class (try) +import Data.Either (Either(..)) +import Effect (Effect) +import Effect.Console (error, log) +import Printer (printStr) +import Reader (readStr) +import Readline (readLine) +import Types (MalExpr) + + +-- MAIN + +main :: Effect Unit +main = loop + + + +-- EVAL + +eval :: MalExpr -> MalExpr +eval s = s + + + +-- REPL + +rep :: String -> Effect Unit +rep str = do + result <- try $ read str + case result of + Left err -> error $ show err + Right exp -> print (eval exp) >>= log + + +loop :: Effect Unit +loop = do + line <- readLine "user> " + case line of + "" -> loop + ":q" -> pure unit + _ -> do + rep line + loop + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String print = printStr \ No newline at end of file diff --git a/impls/purs/src/step2_eval.purs b/impls/purs/src/step2_eval.purs index 3eb2ad1a2f..a9d5ba3eec 100644 --- a/impls/purs/src/step2_eval.purs +++ b/impls/purs/src/step2_eval.purs @@ -1,110 +1,110 @@ -module Mal.Step2 where - -import Prelude - -import Data.Either (Either(..)) -import Data.List (List(..), (:)) -import Data.Map (Map, lookup) -import Data.Map as Map -import Data.Maybe (Maybe(..)) -import Data.Traversable (traverse) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Console (error, log) -import Effect.Exception (throw, try) -import Reader (readStr) -import Printer (printStr) -import Readline (readLine) -import Types (MalExpr(..), MalFn, toHashMap, toList, toVector) - - --- MAIN - -main :: Effect Unit -main = loop - - - --- EVAL - -eval :: MalExpr -> Effect MalExpr -eval ast@(MalList _ Nil) = pure ast -eval (MalList _ ast) = do - es <- traverse evalAst ast - case es of - MalFunction {fn:f}: args -> f args - _ -> pure $ toList es -eval ast = evalAst ast - - -evalAst :: MalExpr -> Effect MalExpr -evalAst (MalSymbol s) = case lookup s replEnv of - Just f -> pure f - Nothing -> throw "invalid function" -evalAst ast@(MalList _ _ ) = eval ast -evalAst (MalVector _ es) = toVector <$> (traverse eval es) -evalAst (MalHashMap _ es) = toHashMap <$> (traverse eval es) -evalAst ast = pure ast - - - --- ENV - -type ReplEnv = Map String MalExpr - -replEnv :: ReplEnv -replEnv = Map.fromFoldable - [ (Tuple "+" (fn (+))) - , (Tuple "-" (fn (-))) - , (Tuple "*" (fn (*))) - , (Tuple "/" (fn (/))) - ] - -fn :: (Int -> Int -> Int) -> MalExpr -fn op = - MalFunction - { fn : g op - , ast : MalNil - , env : Nil - , params : Nil - , macro : false - , meta : MalNil - } - where - g :: (Int -> Int -> Int) -> MalFn - g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2 - g _ _ = throw "invalid operator" - - - --- REPL - -rep :: String -> Effect Unit -rep str = do - result <- try $ eval =<< read str - case result of - Left err -> error $ show err - Right exp -> print exp >>= log - - -loop :: Effect Unit -loop = do - line <- readLine "user> " - case line of - "" -> loop - ":q" -> pure unit - _ -> rep line *> loop - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String +module Mal.Step2 where + +import Prelude + +import Data.Either (Either(..)) +import Data.List (List(..), (:)) +import Data.Map (Map, lookup) +import Data.Map as Map +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Console (error, log) +import Effect.Exception (throw, try) +import Reader (readStr) +import Printer (printStr) +import Readline (readLine) +import Types (MalExpr(..), MalFn, toHashMap, toList, toVector) + + +-- MAIN + +main :: Effect Unit +main = loop + + + +-- EVAL + +eval :: MalExpr -> Effect MalExpr +eval ast@(MalList _ Nil) = pure ast +eval (MalList _ ast) = do + es <- traverse evalAst ast + case es of + MalFunction {fn:f}: args -> f args + _ -> pure $ toList es +eval ast = evalAst ast + + +evalAst :: MalExpr -> Effect MalExpr +evalAst (MalSymbol s) = case lookup s replEnv of + Just f -> pure f + Nothing -> throw "invalid function" +evalAst ast@(MalList _ _ ) = eval ast +evalAst (MalVector _ es) = toVector <$> (traverse eval es) +evalAst (MalHashMap _ es) = toHashMap <$> (traverse eval es) +evalAst ast = pure ast + + + +-- ENV + +type ReplEnv = Map String MalExpr + +replEnv :: ReplEnv +replEnv = Map.fromFoldable + [ (Tuple "+" (fn (+))) + , (Tuple "-" (fn (-))) + , (Tuple "*" (fn (*))) + , (Tuple "/" (fn (/))) + ] + +fn :: (Int -> Int -> Int) -> MalExpr +fn op = + MalFunction + { fn : g op + , ast : MalNil + , env : Nil + , params : Nil + , macro : false + , meta : MalNil + } + where + g :: (Int -> Int -> Int) -> MalFn + g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2 + g _ _ = throw "invalid operator" + + + +-- REPL + +rep :: String -> Effect Unit +rep str = do + result <- try $ eval =<< read str + case result of + Left err -> error $ show err + Right exp -> print exp >>= log + + +loop :: Effect Unit +loop = do + line <- readLine "user> " + case line of + "" -> loop + ":q" -> pure unit + _ -> rep line *> loop + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String print = printStr \ No newline at end of file diff --git a/impls/purs/src/step3_env.purs b/impls/purs/src/step3_env.purs index 12851a5d15..fe8f564897 100644 --- a/impls/purs/src/step3_env.purs +++ b/impls/purs/src/step3_env.purs @@ -1,143 +1,143 @@ -module Mal.Step3 where - -import Prelude - -import Control.Monad.Error.Class (try) -import Data.Either (Either(..)) -import Data.List (List(..), (:)) -import Data.Maybe (Maybe(..)) -import Data.Traversable (traverse) -import Effect (Effect) -import Effect.Console (error, log) -import Effect.Exception (throw) -import Env as Env -import Reader (readStr) -import Printer (printStr) -import Readline (readLine) -import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) - - --- MAIN - -main :: Effect Unit -main = do - re <- Env.newEnv Nil - setArithOp re - loop re - - - --- EVAL - -eval :: RefEnv -> MalExpr -> Effect MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - _ -> do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f} : args -> f args - _ -> throw "invalid function" -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Effect MalExpr -evalAst env (MalSymbol s) = do - result <- Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast - - -evalDef :: RefEnv -> List MalExpr -> Effect MalExpr -evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e - Env.set env v evd - pure evd -evalDef _ _ = throw "invalid def!" - - -evalLet :: RefEnv -> List MalExpr -> Effect MalExpr -evalLet env (MalList _ ps : e : Nil) = do - letEnv <- Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet env (MalVector _ ps : e : Nil) = do - letEnv <- Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet _ _ = throw "invalid let*" - - -letBind :: RefEnv -> List MalExpr -> Effect Unit -letBind _ Nil = pure unit -letBind env (MalSymbol ky : e : es) = do - Env.set env ky =<< evalAst env e - letBind env es -letBind _ _ = throw "invalid let*" - - - --- REPL - -rep :: RefEnv -> String -> Effect String -rep env str = print =<< evalAst env =<< read str - - -loop :: RefEnv -> Effect Unit -loop env = do - line <- readLine "user> " - case line of - "" -> loop env - ":q" -> pure unit - _ -> do - result <- try $ rep env line - case result of - Right exp -> log exp - Left err -> error $ show err - loop env - - -setArithOp :: RefEnv -> Effect Unit -setArithOp env = do - Env.set env "+" =<< fn (+) - Env.set env "-" =<< fn (-) - Env.set env "*" =<< fn (*) - Env.set env "/" =<< fn (/) - - -fn :: (Int -> Int -> Int) -> Effect MalExpr -fn op = do - newEnv <- Env.newEnv Nil - pure $ MalFunction - { fn : g op - , ast : MalNil - , env : newEnv - , params : Nil - , macro : false - , meta : MalNil - } - where - - g :: (Int -> Int -> Int) -> MalFn - g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2 - g _ _ = throw "invalid operator" - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String +module Mal.Step3 where + +import Prelude + +import Control.Monad.Error.Class (try) +import Data.Either (Either(..)) +import Data.List (List(..), (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse) +import Effect (Effect) +import Effect.Console (error, log) +import Effect.Exception (throw) +import Env as Env +import Reader (readStr) +import Printer (printStr) +import Readline (readLine) +import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) + + +-- MAIN + +main :: Effect Unit +main = do + re <- Env.newEnv Nil + setArithOp re + loop re + + + +-- EVAL + +eval :: RefEnv -> MalExpr -> Effect MalExpr +eval _ ast@(MalList _ Nil) = pure ast +eval env (MalList _ ast) = case ast of + MalSymbol "def!" : es -> evalDef env es + MalSymbol "let*" : es -> evalLet env es + _ -> do + es <- traverse (evalAst env) ast + case es of + MalFunction {fn:f} : args -> f args + _ -> throw "invalid function" +eval env ast = evalAst env ast + + +evalAst :: RefEnv -> MalExpr -> Effect MalExpr +evalAst env (MalSymbol s) = do + result <- Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" +evalAst env ast@(MalList _ _) = eval env ast +evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs +evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs +evalAst _ ast = pure ast + + +evalDef :: RefEnv -> List MalExpr -> Effect MalExpr +evalDef env (MalSymbol v : e : Nil) = do + evd <- evalAst env e + Env.set env v evd + pure evd +evalDef _ _ = throw "invalid def!" + + +evalLet :: RefEnv -> List MalExpr -> Effect MalExpr +evalLet env (MalList _ ps : e : Nil) = do + letEnv <- Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet env (MalVector _ ps : e : Nil) = do + letEnv <- Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet _ _ = throw "invalid let*" + + +letBind :: RefEnv -> List MalExpr -> Effect Unit +letBind _ Nil = pure unit +letBind env (MalSymbol ky : e : es) = do + Env.set env ky =<< evalAst env e + letBind env es +letBind _ _ = throw "invalid let*" + + + +-- REPL + +rep :: RefEnv -> String -> Effect String +rep env str = print =<< evalAst env =<< read str + + +loop :: RefEnv -> Effect Unit +loop env = do + line <- readLine "user> " + case line of + "" -> loop env + ":q" -> pure unit + _ -> do + result <- try $ rep env line + case result of + Right exp -> log exp + Left err -> error $ show err + loop env + + +setArithOp :: RefEnv -> Effect Unit +setArithOp env = do + Env.set env "+" =<< fn (+) + Env.set env "-" =<< fn (-) + Env.set env "*" =<< fn (*) + Env.set env "/" =<< fn (/) + + +fn :: (Int -> Int -> Int) -> Effect MalExpr +fn op = do + newEnv <- Env.newEnv Nil + pure $ MalFunction + { fn : g op + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } + where + + g :: (Int -> Int -> Int) -> MalFn + g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2 + g _ _ = throw "invalid operator" + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String print = printStr \ No newline at end of file diff --git a/impls/purs/src/step4_if_fn_do.purs b/impls/purs/src/step4_if_fn_do.purs index f048881862..6c068a0a4d 100644 --- a/impls/purs/src/step4_if_fn_do.purs +++ b/impls/purs/src/step4_if_fn_do.purs @@ -1,189 +1,189 @@ -module Mal.Step4 where - -import Prelude - -import Control.Monad.Error.Class (try) -import Core as Core -import Data.Either (Either(..)) -import Data.List (List(..), foldM, (:)) -import Data.Maybe (Maybe(..)) -import Data.Traversable (traverse) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Console (error, log) -import Effect.Exception (throw) -import Env as Env -import Reader (readStr) -import Printer (printStr) -import Readline (readLine) -import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) - - - --- MAIN - -main :: Effect Unit -main = do - re <- Env.newEnv Nil - _ <- traverse (setFn re) Core.ns - _ <- rep re "(def! not (fn* (a) (if a false true)))" - loop re - - - --- EVAL - -eval :: RefEnv -> MalExpr -> Effect MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - _ -> do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f} : args -> f args - _ -> throw "invalid function" -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Effect MalExpr -evalAst env (MalSymbol s) = do - result <- Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast - - -evalDef :: RefEnv -> List MalExpr -> Effect MalExpr -evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e - Env.set env v evd - pure evd -evalDef _ _ = throw "invalid def!" - - -evalLet :: RefEnv -> List MalExpr -> Effect MalExpr -evalLet env (MalList _ ps : e : Nil) = do - letEnv <- Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet env (MalVector _ ps : e : Nil) = do - letEnv <- Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet _ _ = throw "invalid let*" - - - -letBind :: RefEnv -> List MalExpr -> Effect Unit -letBind _ Nil = pure unit -letBind env (MalSymbol ky : e : es) = do - Env.set env ky =<< evalAst env e - letBind env es -letBind _ _ = throw "invalid let*" - - -evalIf :: RefEnv -> List MalExpr -> Effect MalExpr -evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> e - MalBoolean false -> e - _ -> t -evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> MalNil - MalBoolean false -> MalNil - _ -> t -evalIf _ _ = throw "invalid if" - - -evalDo :: RefEnv -> List MalExpr -> Effect MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es - - -evalFnMatch :: RefEnv -> List MalExpr -> Effect MalExpr -evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body -evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body -evalFnMatch _ _ = throw "invalid fn*" - - -evalFn :: RefEnv -> List MalExpr -> MalExpr -> Effect MalExpr -evalFn env params body = do - paramsStr <- traverse unwrapSymbol params - pure $ MalFunction { fn : fn paramsStr body - , ast : body - , env : env - , params : paramsStr - , macro : false - , meta : MalNil - } - where - - fn :: List String -> MalExpr -> MalFn - fn params' body' = \args -> do - fnEnv <- Env.newEnv env - ok <- Env.sets fnEnv params' args - if ok - then evalAst fnEnv body' - else throw "actual parameters do not match signature " - - unwrapSymbol :: MalExpr -> Effect String - unwrapSymbol (MalSymbol s) = pure s - unwrapSymbol _ = throw "fn* parameter must be symbols" - - - --- REPL - -rep :: RefEnv -> String -> Effect String -rep env str = print =<< evalAst env =<< read str - - -loop :: RefEnv -> Effect Unit -loop env = do - line <- readLine "user> " - case line of - "" -> loop env - ":q" -> pure unit - _ -> do - result <- try $ rep env line - case result of - Right exp -> log exp - Left err -> error $ show err - loop env - - -setFn :: RefEnv -> Tuple String MalFn -> Effect Unit -setFn env (Tuple sym f) = do - newEnv <- Env.newEnv Nil - Env.set env sym $ MalFunction - { fn : f - , ast : MalNil - , env : newEnv - , params : Nil - , macro : false - , meta : MalNil - } - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String +module Mal.Step4 where + +import Prelude + +import Control.Monad.Error.Class (try) +import Core as Core +import Data.Either (Either(..)) +import Data.List (List(..), foldM, (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Console (error, log) +import Effect.Exception (throw) +import Env as Env +import Reader (readStr) +import Printer (printStr) +import Readline (readLine) +import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) + + + +-- MAIN + +main :: Effect Unit +main = do + re <- Env.newEnv Nil + _ <- traverse (setFn re) Core.ns + _ <- rep re "(def! not (fn* (a) (if a false true)))" + loop re + + + +-- EVAL + +eval :: RefEnv -> MalExpr -> Effect MalExpr +eval _ ast@(MalList _ Nil) = pure ast +eval env (MalList _ ast) = case ast of + MalSymbol "def!" : es -> evalDef env es + MalSymbol "let*" : es -> evalLet env es + MalSymbol "if" : es -> evalIf env es + MalSymbol "do" : es -> evalDo env es + MalSymbol "fn*" : es -> evalFnMatch env es + _ -> do + es <- traverse (evalAst env) ast + case es of + MalFunction {fn:f} : args -> f args + _ -> throw "invalid function" +eval env ast = evalAst env ast + + +evalAst :: RefEnv -> MalExpr -> Effect MalExpr +evalAst env (MalSymbol s) = do + result <- Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" +evalAst env ast@(MalList _ _) = eval env ast +evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs +evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs +evalAst _ ast = pure ast + + +evalDef :: RefEnv -> List MalExpr -> Effect MalExpr +evalDef env (MalSymbol v : e : Nil) = do + evd <- evalAst env e + Env.set env v evd + pure evd +evalDef _ _ = throw "invalid def!" + + +evalLet :: RefEnv -> List MalExpr -> Effect MalExpr +evalLet env (MalList _ ps : e : Nil) = do + letEnv <- Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet env (MalVector _ ps : e : Nil) = do + letEnv <- Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet _ _ = throw "invalid let*" + + + +letBind :: RefEnv -> List MalExpr -> Effect Unit +letBind _ Nil = pure unit +letBind env (MalSymbol ky : e : es) = do + Env.set env ky =<< evalAst env e + letBind env es +letBind _ _ = throw "invalid let*" + + +evalIf :: RefEnv -> List MalExpr -> Effect MalExpr +evalIf env (b:t:e:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> e + MalBoolean false -> e + _ -> t +evalIf env (b:t:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> MalNil + MalBoolean false -> MalNil + _ -> t +evalIf _ _ = throw "invalid if" + + +evalDo :: RefEnv -> List MalExpr -> Effect MalExpr +evalDo env es = foldM (const $ evalAst env) MalNil es + + +evalFnMatch :: RefEnv -> List MalExpr -> Effect MalExpr +evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body +evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body +evalFnMatch _ _ = throw "invalid fn*" + + +evalFn :: RefEnv -> List MalExpr -> MalExpr -> Effect MalExpr +evalFn env params body = do + paramsStr <- traverse unwrapSymbol params + pure $ MalFunction { fn : fn paramsStr body + , ast : body + , env : env + , params : paramsStr + , macro : false + , meta : MalNil + } + where + + fn :: List String -> MalExpr -> MalFn + fn params' body' = \args -> do + fnEnv <- Env.newEnv env + ok <- Env.sets fnEnv params' args + if ok + then evalAst fnEnv body' + else throw "actual parameters do not match signature " + + unwrapSymbol :: MalExpr -> Effect String + unwrapSymbol (MalSymbol s) = pure s + unwrapSymbol _ = throw "fn* parameter must be symbols" + + + +-- REPL + +rep :: RefEnv -> String -> Effect String +rep env str = print =<< evalAst env =<< read str + + +loop :: RefEnv -> Effect Unit +loop env = do + line <- readLine "user> " + case line of + "" -> loop env + ":q" -> pure unit + _ -> do + result <- try $ rep env line + case result of + Right exp -> log exp + Left err -> error $ show err + loop env + + +setFn :: RefEnv -> Tuple String MalFn -> Effect Unit +setFn env (Tuple sym f) = do + newEnv <- Env.newEnv Nil + Env.set env sym $ MalFunction + { fn : f + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String print = printStr \ No newline at end of file diff --git a/impls/purs/src/step5_tco.purs b/impls/purs/src/step5_tco.purs index dcf3880da7..f0bacf1907 100644 --- a/impls/purs/src/step5_tco.purs +++ b/impls/purs/src/step5_tco.purs @@ -1,232 +1,232 @@ -module Mal.Step5 where - -import Prelude - -import Control.Monad.Error.Class (try) -import Control.Monad.Free.Trans (FreeT, runFreeT) -import Control.Monad.Rec.Class (class MonadRec) -import Core as Core -import Data.Either (Either(..)) -import Data.Identity (Identity(..)) -import Data.List (List(..), foldM, (:)) -import Data.Maybe (Maybe(..)) -import Data.Traversable (traverse, traverse_) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Console (error, log) -import Effect.Exception as Ex -import Env as Env -import Printer (printStr) -import Reader (readStr) -import Readline (readLine) -import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) - - --- TYPES - -type Eval a = FreeT Identity Effect a - - - --- MAIN - -main :: Effect Unit -main = do - re <- Env.newEnv Nil - traverse_ (setFn re) Core.ns - rep_ re "(def! not (fn* (a) (if a false true)))" - loop re - - - --- EVAL - -eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env (MalSymbol s) = do - result <- liftEffect $ Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast - - -evalDef :: RefEnv -> List MalExpr -> Eval MalExpr -evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e - liftEffect $ Env.set env v evd - pure evd -evalDef _ _ = throw "invalid def!" - - -evalLet :: RefEnv -> List MalExpr -> Eval MalExpr -evalLet env (MalList _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet env (MalVector _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet _ _ = throw "invalid let*" - - - -letBind :: RefEnv -> List MalExpr -> Eval Unit -letBind _ Nil = pure unit -letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e - liftEffect $ Env.set env ky ex - letBind env es -letBind _ _ = throw "invalid let*" - - -evalIf :: RefEnv -> List MalExpr -> Eval MalExpr -evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> e - MalBoolean false -> e - _ -> t -evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> MalNil - MalBoolean false -> MalNil - _ -> t -evalIf _ _ = throw "invalid if" - - -evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es - - -evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr -evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body -evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body -evalFnMatch _ _ = throw "invalid fn*" - - -evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr -evalFn env params body = do - paramsStr <- traverse unwrapSymbol params - pure $ MalFunction { fn : fn paramsStr body - , ast : body - , env : env - , params : paramsStr - , macro : false - , meta : MalNil - } - where - - fn :: List String -> MalExpr -> MalFn - fn params' body' = \args -> do - fnEnv <- Env.newEnv env - ok <- Env.sets fnEnv params' args - if ok - then runEval $ evalAst fnEnv body' - else throw "actual parameters do not match signature " - - unwrapSymbol :: MalExpr -> Eval String - unwrapSymbol (MalSymbol s) = pure s - unwrapSymbol _ = throw "fn* parameter must be symbols" - - - --- REPL - -rep_ :: RefEnv -> String -> Effect Unit -rep_ env str = rep env str *> pure unit - - -rep :: RefEnv -> String -> Effect String -rep env str = do - ast <- read str - result <- runEval $ evalAst env ast - print result - - -loop :: RefEnv -> Effect Unit -loop env = do - line <- readLine "user> " - case line of - "" -> loop env - ":q" -> pure unit - _ -> do - result <- try $ rep env line - case result of - Right exp -> log exp - Left err -> error $ show err - loop env - - -setFn :: RefEnv -> Tuple String MalFn -> Effect Unit -setFn env (Tuple sym f) = do - newEnv <- Env.newEnv Nil - Env.set env sym $ MalFunction - { fn : f - , ast : MalNil - , env : newEnv - , params : Nil - , macro : false - , meta : MalNil - } - - - --- CALL FUNCTION - -evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr -evalCallFn env ast = do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args - MalFunction {ast:ast', params:params', env:env'} : args -> do - newEnv <- liftEffect $ Env.newEnv env' - _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' - _ -> throw "invalid function" - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - --- Utils - -runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a -runEval = runFreeT $ pure <<< runIdentity - - -runIdentity :: ∀ a. Identity a -> a -runIdentity (Identity a) = a - - -throw :: ∀ m a. MonadEffect m => String -> m a +module Mal.Step5 where + +import Prelude + +import Control.Monad.Error.Class (try) +import Control.Monad.Free.Trans (FreeT, runFreeT) +import Control.Monad.Rec.Class (class MonadRec) +import Core as Core +import Data.Either (Either(..)) +import Data.Identity (Identity(..)) +import Data.List (List(..), foldM, (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse, traverse_) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Console (error, log) +import Effect.Exception as Ex +import Env as Env +import Printer (printStr) +import Reader (readStr) +import Readline (readLine) +import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) + + +-- TYPES + +type Eval a = FreeT Identity Effect a + + + +-- MAIN + +main :: Effect Unit +main = do + re <- Env.newEnv Nil + traverse_ (setFn re) Core.ns + rep_ re "(def! not (fn* (a) (if a false true)))" + loop re + + + +-- EVAL + +eval :: RefEnv -> MalExpr -> Eval MalExpr +eval _ ast@(MalList _ Nil) = pure ast +eval env (MalList _ ast) = case ast of + MalSymbol "def!" : es -> evalDef env es + MalSymbol "let*" : es -> evalLet env es + MalSymbol "if" : es -> evalIf env es + MalSymbol "do" : es -> evalDo env es + MalSymbol "fn*" : es -> evalFnMatch env es + _ -> evalCallFn env ast +eval env ast = evalAst env ast + + +evalAst :: RefEnv -> MalExpr -> Eval MalExpr +evalAst env (MalSymbol s) = do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" +evalAst env ast@(MalList _ _) = eval env ast +evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs +evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs +evalAst _ ast = pure ast + + +evalDef :: RefEnv -> List MalExpr -> Eval MalExpr +evalDef env (MalSymbol v : e : Nil) = do + evd <- evalAst env e + liftEffect $ Env.set env v evd + pure evd +evalDef _ _ = throw "invalid def!" + + +evalLet :: RefEnv -> List MalExpr -> Eval MalExpr +evalLet env (MalList _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet env (MalVector _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet _ _ = throw "invalid let*" + + + +letBind :: RefEnv -> List MalExpr -> Eval Unit +letBind _ Nil = pure unit +letBind env (MalSymbol ky : e : es) = do + ex <- evalAst env e + liftEffect $ Env.set env ky ex + letBind env es +letBind _ _ = throw "invalid let*" + + +evalIf :: RefEnv -> List MalExpr -> Eval MalExpr +evalIf env (b:t:e:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> e + MalBoolean false -> e + _ -> t +evalIf env (b:t:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> MalNil + MalBoolean false -> MalNil + _ -> t +evalIf _ _ = throw "invalid if" + + +evalDo :: RefEnv -> List MalExpr -> Eval MalExpr +evalDo env es = foldM (const $ evalAst env) MalNil es + + +evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr +evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body +evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body +evalFnMatch _ _ = throw "invalid fn*" + + +evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr +evalFn env params body = do + paramsStr <- traverse unwrapSymbol params + pure $ MalFunction { fn : fn paramsStr body + , ast : body + , env : env + , params : paramsStr + , macro : false + , meta : MalNil + } + where + + fn :: List String -> MalExpr -> MalFn + fn params' body' = \args -> do + fnEnv <- Env.newEnv env + ok <- Env.sets fnEnv params' args + if ok + then runEval $ evalAst fnEnv body' + else throw "actual parameters do not match signature " + + unwrapSymbol :: MalExpr -> Eval String + unwrapSymbol (MalSymbol s) = pure s + unwrapSymbol _ = throw "fn* parameter must be symbols" + + + +-- REPL + +rep_ :: RefEnv -> String -> Effect Unit +rep_ env str = rep env str *> pure unit + + +rep :: RefEnv -> String -> Effect String +rep env str = do + ast <- read str + result <- runEval $ evalAst env ast + print result + + +loop :: RefEnv -> Effect Unit +loop env = do + line <- readLine "user> " + case line of + "" -> loop env + ":q" -> pure unit + _ -> do + result <- try $ rep env line + case result of + Right exp -> log exp + Left err -> error $ show err + loop env + + +setFn :: RefEnv -> Tuple String MalFn -> Effect Unit +setFn env (Tuple sym f) = do + newEnv <- Env.newEnv Nil + Env.set env sym $ MalFunction + { fn : f + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } + + + +-- CALL FUNCTION + +evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr +evalCallFn env ast = do + es <- traverse (evalAst env) ast + case es of + MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args + MalFunction {ast:ast', params:params', env:env'} : args -> do + newEnv <- liftEffect $ Env.newEnv env' + _ <- liftEffect $ Env.sets newEnv params' args + evalAst newEnv ast' + _ -> throw "invalid function" + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr + + + +-- Utils + +runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a +runEval = runFreeT $ pure <<< runIdentity + + +runIdentity :: ∀ a. Identity a -> a +runIdentity (Identity a) = a + + +throw :: ∀ m a. MonadEffect m => String -> m a throw = liftEffect <<< Ex.throw \ No newline at end of file diff --git a/impls/purs/src/step6_file.purs b/impls/purs/src/step6_file.purs index 09978fffe7..e47cf366d0 100644 --- a/impls/purs/src/step6_file.purs +++ b/impls/purs/src/step6_file.purs @@ -1,245 +1,245 @@ -module Mal.Step6 where - -import Prelude - -import Control.Monad.Error.Class (try) -import Control.Monad.Free.Trans (FreeT, runFreeT) -import Control.Monad.Rec.Class (class MonadRec) -import Core as Core -import Data.Either (Either(..)) -import Data.Identity (Identity(..)) -import Data.List (List(..), foldM, (:)) -import Data.Maybe (Maybe(..)) -import Data.Traversable (traverse, traverse_) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Console (error, log) -import Effect.Exception as Ex -import Env as Env -import Printer (printStr) -import Reader (readStr) -import Readline (args, readLine) -import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toList, toVector) - - --- TYPES - -type Eval a = FreeT Identity Effect a - - - --- MAIN - -main :: Effect Unit -main = do - env <- Env.newEnv Nil - traverse_ (setFn env) Core.ns - setFn env $ Tuple "eval" $ setEval env - rep_ env "(def! not (fn* (a) (if a false true)))" - rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - case args of - Nil -> do - Env.set env "*ARGV*" $ toList Nil - loop env - script:scriptArgs -> do - Env.set env "*ARGV*" $ toList $ MalString <$> scriptArgs - rep_ env $ "(load-file \"" <> script <> "\")" - - - --- REPL - -rep_ :: RefEnv -> String -> Effect Unit -rep_ env str = rep env str *> pure unit - - -rep :: RefEnv -> String -> Effect String -rep env str = do - ast <- read str - result <- runEval $ evalAst env ast - print result - - -loop :: RefEnv -> Effect Unit -loop env = do - line <- readLine "user> " - case line of - "" -> loop env - ":q" -> pure unit - _ -> do - result <- try $ rep env line - case result of - Right exp -> log exp - Left err -> error $ show err - loop env - - -setFn :: RefEnv -> Tuple String MalFn -> Effect Unit -setFn env (Tuple sym f) = do - newEnv <- Env.newEnv Nil - Env.set env sym $ MalFunction - { fn : f - , ast : MalNil - , env : newEnv - , params : Nil - , macro : false - , meta : MalNil - } - - -setEval :: RefEnv -> MalFn -setEval env (ast:Nil) = runEval $ eval env ast -setEval _ _ = throw "illegal call of eval" - - - --- EVAL - -eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env (MalSymbol s) = do - result <- liftEffect $ Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast - - -evalDef :: RefEnv -> List MalExpr -> Eval MalExpr -evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e - liftEffect $ Env.set env v evd - pure evd -evalDef _ _ = throw "invalid def!" - - -evalLet :: RefEnv -> List MalExpr -> Eval MalExpr -evalLet env (MalList _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet env (MalVector _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet _ _ = throw "invalid let*" - - - -letBind :: RefEnv -> List MalExpr -> Eval Unit -letBind _ Nil = pure unit -letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e - liftEffect $ Env.set env ky ex - letBind env es -letBind _ _ = throw "invalid let*" - - -evalIf :: RefEnv -> List MalExpr -> Eval MalExpr -evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> e - MalBoolean false -> e - _ -> t -evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> MalNil - MalBoolean false -> MalNil - _ -> t -evalIf _ _ = throw "invalid if" - - -evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es - - -evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr -evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body -evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body -evalFnMatch _ _ = throw "invalid fn*" - - -evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr -evalFn env params body = do - paramsStr <- traverse unwrapSymbol params - pure $ MalFunction { fn : fn paramsStr body - , ast : body - , env : env - , params : paramsStr - , macro : false - , meta : MalNil - } - where - - fn :: List String -> MalExpr -> MalFn - fn params' body' = \args -> do - fnEnv <- Env.newEnv env - ok <- Env.sets fnEnv params' args - if ok - then runEval $ evalAst fnEnv body' - else throw "actual parameters do not match signature " - - unwrapSymbol :: MalExpr -> Eval String - unwrapSymbol (MalSymbol s) = pure s - unwrapSymbol _ = throw "fn* parameter must be symbols" - - - --- CALL FUNCTION - -evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr -evalCallFn env ast = do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args - MalFunction {ast:ast', params:params', env:env'} : args -> do - newEnv <- liftEffect $ Env.newEnv env' - _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' - _ -> throw "invalid function" - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - --- Utils - -runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a -runEval = runFreeT $ pure <<< runIdentity - - -runIdentity :: ∀ a. Identity a -> a -runIdentity (Identity a) = a - - -throw :: ∀ m a. MonadEffect m => String -> m a +module Mal.Step6 where + +import Prelude + +import Control.Monad.Error.Class (try) +import Control.Monad.Free.Trans (FreeT, runFreeT) +import Control.Monad.Rec.Class (class MonadRec) +import Core as Core +import Data.Either (Either(..)) +import Data.Identity (Identity(..)) +import Data.List (List(..), foldM, (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse, traverse_) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Console (error, log) +import Effect.Exception as Ex +import Env as Env +import Printer (printStr) +import Reader (readStr) +import Readline (args, readLine) +import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toList, toVector) + + +-- TYPES + +type Eval a = FreeT Identity Effect a + + + +-- MAIN + +main :: Effect Unit +main = do + env <- Env.newEnv Nil + traverse_ (setFn env) Core.ns + setFn env $ Tuple "eval" $ setEval env + rep_ env "(def! not (fn* (a) (if a false true)))" + rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + case args of + Nil -> do + Env.set env "*ARGV*" $ toList Nil + loop env + script:scriptArgs -> do + Env.set env "*ARGV*" $ toList $ MalString <$> scriptArgs + rep_ env $ "(load-file \"" <> script <> "\")" + + + +-- REPL + +rep_ :: RefEnv -> String -> Effect Unit +rep_ env str = rep env str *> pure unit + + +rep :: RefEnv -> String -> Effect String +rep env str = do + ast <- read str + result <- runEval $ evalAst env ast + print result + + +loop :: RefEnv -> Effect Unit +loop env = do + line <- readLine "user> " + case line of + "" -> loop env + ":q" -> pure unit + _ -> do + result <- try $ rep env line + case result of + Right exp -> log exp + Left err -> error $ show err + loop env + + +setFn :: RefEnv -> Tuple String MalFn -> Effect Unit +setFn env (Tuple sym f) = do + newEnv <- Env.newEnv Nil + Env.set env sym $ MalFunction + { fn : f + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } + + +setEval :: RefEnv -> MalFn +setEval env (ast:Nil) = runEval $ eval env ast +setEval _ _ = throw "illegal call of eval" + + + +-- EVAL + +eval :: RefEnv -> MalExpr -> Eval MalExpr +eval _ ast@(MalList _ Nil) = pure ast +eval env (MalList _ ast) = case ast of + MalSymbol "def!" : es -> evalDef env es + MalSymbol "let*" : es -> evalLet env es + MalSymbol "if" : es -> evalIf env es + MalSymbol "do" : es -> evalDo env es + MalSymbol "fn*" : es -> evalFnMatch env es + _ -> evalCallFn env ast +eval env ast = evalAst env ast + + +evalAst :: RefEnv -> MalExpr -> Eval MalExpr +evalAst env (MalSymbol s) = do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" +evalAst env ast@(MalList _ _) = eval env ast +evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs +evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs +evalAst _ ast = pure ast + + +evalDef :: RefEnv -> List MalExpr -> Eval MalExpr +evalDef env (MalSymbol v : e : Nil) = do + evd <- evalAst env e + liftEffect $ Env.set env v evd + pure evd +evalDef _ _ = throw "invalid def!" + + +evalLet :: RefEnv -> List MalExpr -> Eval MalExpr +evalLet env (MalList _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet env (MalVector _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet _ _ = throw "invalid let*" + + + +letBind :: RefEnv -> List MalExpr -> Eval Unit +letBind _ Nil = pure unit +letBind env (MalSymbol ky : e : es) = do + ex <- evalAst env e + liftEffect $ Env.set env ky ex + letBind env es +letBind _ _ = throw "invalid let*" + + +evalIf :: RefEnv -> List MalExpr -> Eval MalExpr +evalIf env (b:t:e:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> e + MalBoolean false -> e + _ -> t +evalIf env (b:t:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> MalNil + MalBoolean false -> MalNil + _ -> t +evalIf _ _ = throw "invalid if" + + +evalDo :: RefEnv -> List MalExpr -> Eval MalExpr +evalDo env es = foldM (const $ evalAst env) MalNil es + + +evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr +evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body +evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body +evalFnMatch _ _ = throw "invalid fn*" + + +evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr +evalFn env params body = do + paramsStr <- traverse unwrapSymbol params + pure $ MalFunction { fn : fn paramsStr body + , ast : body + , env : env + , params : paramsStr + , macro : false + , meta : MalNil + } + where + + fn :: List String -> MalExpr -> MalFn + fn params' body' = \args -> do + fnEnv <- Env.newEnv env + ok <- Env.sets fnEnv params' args + if ok + then runEval $ evalAst fnEnv body' + else throw "actual parameters do not match signature " + + unwrapSymbol :: MalExpr -> Eval String + unwrapSymbol (MalSymbol s) = pure s + unwrapSymbol _ = throw "fn* parameter must be symbols" + + + +-- CALL FUNCTION + +evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr +evalCallFn env ast = do + es <- traverse (evalAst env) ast + case es of + MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args + MalFunction {ast:ast', params:params', env:env'} : args -> do + newEnv <- liftEffect $ Env.newEnv env' + _ <- liftEffect $ Env.sets newEnv params' args + evalAst newEnv ast' + _ -> throw "invalid function" + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr + + + +-- Utils + +runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a +runEval = runFreeT $ pure <<< runIdentity + + +runIdentity :: ∀ a. Identity a -> a +runIdentity (Identity a) = a + + +throw :: ∀ m a. MonadEffect m => String -> m a throw = liftEffect <<< Ex.throw \ No newline at end of file diff --git a/impls/purs/src/step7_quote.purs b/impls/purs/src/step7_quote.purs index 8b4d90e16f..02e3c302fb 100644 --- a/impls/purs/src/step7_quote.purs +++ b/impls/purs/src/step7_quote.purs @@ -1,299 +1,299 @@ -module Mal.Step7 where - -import Prelude - -import Control.Monad.Error.Class (try) -import Control.Monad.Free.Trans (FreeT, runFreeT) -import Control.Monad.Rec.Class (class MonadRec) -import Core as Core -import Data.Either (Either(..)) -import Data.Identity (Identity(..)) -import Data.List (List(..), foldM, (:)) -import Data.Maybe (Maybe(..)) -import Data.Traversable (traverse, traverse_) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Console (error, log) -import Effect.Exception as Ex -import Env as Env -import Printer (printStr) -import Reader (readStr) -import Readline (args, readLine) -import Types (MalExpr(..), MalFn, RefEnv, foldrM, toHashMap, toList, toVector) - - --- TYPES - -type Eval a = FreeT Identity Effect a - - --- MAIN - -main :: Effect Unit -main = do - env <- Env.newEnv Nil - traverse_ (setFn env) Core.ns - setFn env $ Tuple "eval" $ setEval env - rep_ env "(def! not (fn* (a) (if a false true)))" - rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - case args of - Nil -> do - Env.set env "*ARGV*" $ toList Nil - loop env - script:scriptArgs -> do - Env.set env "*ARGV*" $ toList $ MalString <$> scriptArgs - rep_ env $ "(load-file \"" <> script <> "\")" - - - --- REPL - -rep_ :: RefEnv -> String -> Effect Unit -rep_ env str = rep env str *> pure unit - - -rep :: RefEnv -> String -> Effect String -rep env str = do - ast <- read str - result <- runEval $ evalAst env ast - print result - - -loop :: RefEnv -> Effect Unit -loop env = do - line <- readLine "user> " - case line of - "" -> loop env - ":q" -> pure unit - _ -> do - result <- try $ rep env line - case result of - Right exp -> log exp - Left err -> error $ show err - loop env - - -setFn :: RefEnv -> Tuple String MalFn -> Effect Unit -setFn env (Tuple sym f) = do - newEnv <- Env.newEnv Nil - Env.set env sym $ MalFunction - { fn : f - , ast : MalNil - , env : newEnv - , params : Nil - , macro : false - , meta : MalNil - } - - -setEval :: RefEnv -> MalFn -setEval env (ast:Nil) = runEval $ eval env ast -setEval _ _ = throw "illegal call of eval" - - - --- EVAL - -eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - MalSymbol "quote" : es -> evalQuote env es - MalSymbol "quasiquote" : es -> evalQuasiquote env es - MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env (MalSymbol s) = do - result <- liftEffect $ Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast - - - --- Def - -evalDef :: RefEnv -> List MalExpr -> Eval MalExpr -evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e - liftEffect $ Env.set env v evd - pure evd -evalDef _ _ = throw "invalid def!" - - - --- Let - -evalLet :: RefEnv -> List MalExpr -> Eval MalExpr -evalLet env (MalList _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet env (MalVector _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet _ _ = throw "invalid let*" - - -letBind :: RefEnv -> List MalExpr -> Eval Unit -letBind _ Nil = pure unit -letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e - liftEffect $ Env.set env ky ex - letBind env es -letBind _ _ = throw "invalid let*" - - - --- If - -evalIf :: RefEnv -> List MalExpr -> Eval MalExpr -evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> e - MalBoolean false -> e - _ -> t -evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> MalNil - MalBoolean false -> MalNil - _ -> t -evalIf _ _ = throw "invalid if" - - - --- Do - -evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es - - - --- Function - -evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr -evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body -evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body -evalFnMatch _ _ = throw "invalid fn*" - - -evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr -evalFn env params body = do - paramsStr <- traverse unwrapSymbol params - pure $ MalFunction { fn : fn paramsStr body - , ast : body - , env : env - , params : paramsStr - , macro : false - , meta : MalNil - } - where - - fn :: List String -> MalExpr -> MalFn - fn params' body' = \args -> do - fnEnv <- Env.newEnv env - ok <- Env.sets fnEnv params' args - if ok - then runEval $ evalAst fnEnv body' - else throw "actual parameters do not match signature " - - unwrapSymbol :: MalExpr -> Eval String - unwrapSymbol (MalSymbol s) = pure s - unwrapSymbol _ = throw "fn* parameter must be symbols" - - - --- Quote - -evalQuote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuote _ (e:Nil) = pure e -evalQuote _ _ = throw "invalid quote" - - -evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e -evalQuasiquote _ _ = throw "invalid quasiquote" - - -evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr -evalQuasiquoteexpand (e:Nil) = quasiquote e -evalQuasiquoteexpand _ = throw "invalid quasiquote" - - -quasiquote :: MalExpr -> Eval MalExpr -quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x -quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" -quasiquote (MalList _ xs) = foldrM qqIter (toList Nil) xs -quasiquote (MalVector _ xs) = do - lst <- foldrM qqIter (toList Nil) xs - pure $ toList $ MalSymbol "vec" : lst : Nil -quasiquote ast@(MalHashMap _ _) = pure $ toList $ MalSymbol "quote" : ast : Nil -quasiquote ast@(MalSymbol _) = pure $ toList $ MalSymbol "quote" : ast : Nil -quasiquote ast = pure ast - - -qqIter :: MalExpr -> MalExpr -> Eval MalExpr -qqIter (MalList _ (MalSymbol "splice-unquote" : x : Nil)) acc = pure $ toList $ MalSymbol "concat" : x : acc : Nil -qqIter (MalList _ (MalSymbol "splice-unquote" : _)) _ = throw "invalid splice-unquote" -qqIter elt acc = do - qqted <- quasiquote elt - pure $ toList $ MalSymbol "cons" : qqted : acc : Nil - - - --- CALL FUNCTION - -evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr -evalCallFn env ast = do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args - MalFunction {ast:ast', params:params', env:env'} : args -> do - newEnv <- liftEffect $ Env.newEnv env' - _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' - _ -> throw "invalid function" - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - --- Utils - -runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a -runEval = runFreeT $ pure <<< runIdentity - - -runIdentity :: ∀ a. Identity a -> a -runIdentity (Identity a) = a - - -throw :: ∀ m a. MonadEffect m => String -> m a +module Mal.Step7 where + +import Prelude + +import Control.Monad.Error.Class (try) +import Control.Monad.Free.Trans (FreeT, runFreeT) +import Control.Monad.Rec.Class (class MonadRec) +import Core as Core +import Data.Either (Either(..)) +import Data.Identity (Identity(..)) +import Data.List (List(..), foldM, (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse, traverse_) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Console (error, log) +import Effect.Exception as Ex +import Env as Env +import Printer (printStr) +import Reader (readStr) +import Readline (args, readLine) +import Types (MalExpr(..), MalFn, RefEnv, foldrM, toHashMap, toList, toVector) + + +-- TYPES + +type Eval a = FreeT Identity Effect a + + +-- MAIN + +main :: Effect Unit +main = do + env <- Env.newEnv Nil + traverse_ (setFn env) Core.ns + setFn env $ Tuple "eval" $ setEval env + rep_ env "(def! not (fn* (a) (if a false true)))" + rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + case args of + Nil -> do + Env.set env "*ARGV*" $ toList Nil + loop env + script:scriptArgs -> do + Env.set env "*ARGV*" $ toList $ MalString <$> scriptArgs + rep_ env $ "(load-file \"" <> script <> "\")" + + + +-- REPL + +rep_ :: RefEnv -> String -> Effect Unit +rep_ env str = rep env str *> pure unit + + +rep :: RefEnv -> String -> Effect String +rep env str = do + ast <- read str + result <- runEval $ evalAst env ast + print result + + +loop :: RefEnv -> Effect Unit +loop env = do + line <- readLine "user> " + case line of + "" -> loop env + ":q" -> pure unit + _ -> do + result <- try $ rep env line + case result of + Right exp -> log exp + Left err -> error $ show err + loop env + + +setFn :: RefEnv -> Tuple String MalFn -> Effect Unit +setFn env (Tuple sym f) = do + newEnv <- Env.newEnv Nil + Env.set env sym $ MalFunction + { fn : f + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } + + +setEval :: RefEnv -> MalFn +setEval env (ast:Nil) = runEval $ eval env ast +setEval _ _ = throw "illegal call of eval" + + + +-- EVAL + +eval :: RefEnv -> MalExpr -> Eval MalExpr +eval _ ast@(MalList _ Nil) = pure ast +eval env (MalList _ ast) = case ast of + MalSymbol "def!" : es -> evalDef env es + MalSymbol "let*" : es -> evalLet env es + MalSymbol "if" : es -> evalIf env es + MalSymbol "do" : es -> evalDo env es + MalSymbol "fn*" : es -> evalFnMatch env es + MalSymbol "quote" : es -> evalQuote env es + MalSymbol "quasiquote" : es -> evalQuasiquote env es + MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es + _ -> evalCallFn env ast +eval env ast = evalAst env ast + + +evalAst :: RefEnv -> MalExpr -> Eval MalExpr +evalAst env (MalSymbol s) = do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" +evalAst env ast@(MalList _ _) = eval env ast +evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs +evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs +evalAst _ ast = pure ast + + + +-- Def + +evalDef :: RefEnv -> List MalExpr -> Eval MalExpr +evalDef env (MalSymbol v : e : Nil) = do + evd <- evalAst env e + liftEffect $ Env.set env v evd + pure evd +evalDef _ _ = throw "invalid def!" + + + +-- Let + +evalLet :: RefEnv -> List MalExpr -> Eval MalExpr +evalLet env (MalList _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet env (MalVector _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet _ _ = throw "invalid let*" + + +letBind :: RefEnv -> List MalExpr -> Eval Unit +letBind _ Nil = pure unit +letBind env (MalSymbol ky : e : es) = do + ex <- evalAst env e + liftEffect $ Env.set env ky ex + letBind env es +letBind _ _ = throw "invalid let*" + + + +-- If + +evalIf :: RefEnv -> List MalExpr -> Eval MalExpr +evalIf env (b:t:e:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> e + MalBoolean false -> e + _ -> t +evalIf env (b:t:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> MalNil + MalBoolean false -> MalNil + _ -> t +evalIf _ _ = throw "invalid if" + + + +-- Do + +evalDo :: RefEnv -> List MalExpr -> Eval MalExpr +evalDo env es = foldM (const $ evalAst env) MalNil es + + + +-- Function + +evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr +evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body +evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body +evalFnMatch _ _ = throw "invalid fn*" + + +evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr +evalFn env params body = do + paramsStr <- traverse unwrapSymbol params + pure $ MalFunction { fn : fn paramsStr body + , ast : body + , env : env + , params : paramsStr + , macro : false + , meta : MalNil + } + where + + fn :: List String -> MalExpr -> MalFn + fn params' body' = \args -> do + fnEnv <- Env.newEnv env + ok <- Env.sets fnEnv params' args + if ok + then runEval $ evalAst fnEnv body' + else throw "actual parameters do not match signature " + + unwrapSymbol :: MalExpr -> Eval String + unwrapSymbol (MalSymbol s) = pure s + unwrapSymbol _ = throw "fn* parameter must be symbols" + + + +-- Quote + +evalQuote :: RefEnv -> List MalExpr -> Eval MalExpr +evalQuote _ (e:Nil) = pure e +evalQuote _ _ = throw "invalid quote" + + +evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr +evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e +evalQuasiquote _ _ = throw "invalid quasiquote" + + +evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr +evalQuasiquoteexpand (e:Nil) = quasiquote e +evalQuasiquoteexpand _ = throw "invalid quasiquote" + + +quasiquote :: MalExpr -> Eval MalExpr +quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x +quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" +quasiquote (MalList _ xs) = foldrM qqIter (toList Nil) xs +quasiquote (MalVector _ xs) = do + lst <- foldrM qqIter (toList Nil) xs + pure $ toList $ MalSymbol "vec" : lst : Nil +quasiquote ast@(MalHashMap _ _) = pure $ toList $ MalSymbol "quote" : ast : Nil +quasiquote ast@(MalSymbol _) = pure $ toList $ MalSymbol "quote" : ast : Nil +quasiquote ast = pure ast + + +qqIter :: MalExpr -> MalExpr -> Eval MalExpr +qqIter (MalList _ (MalSymbol "splice-unquote" : x : Nil)) acc = pure $ toList $ MalSymbol "concat" : x : acc : Nil +qqIter (MalList _ (MalSymbol "splice-unquote" : _)) _ = throw "invalid splice-unquote" +qqIter elt acc = do + qqted <- quasiquote elt + pure $ toList $ MalSymbol "cons" : qqted : acc : Nil + + + +-- CALL FUNCTION + +evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr +evalCallFn env ast = do + es <- traverse (evalAst env) ast + case es of + MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args + MalFunction {ast:ast', params:params', env:env'} : args -> do + newEnv <- liftEffect $ Env.newEnv env' + _ <- liftEffect $ Env.sets newEnv params' args + evalAst newEnv ast' + _ -> throw "invalid function" + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr + + + +-- Utils + +runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a +runEval = runFreeT $ pure <<< runIdentity + + +runIdentity :: ∀ a. Identity a -> a +runIdentity (Identity a) = a + + +throw :: ∀ m a. MonadEffect m => String -> m a throw = liftEffect <<< Ex.throw \ No newline at end of file diff --git a/impls/purs/src/step8_macros.purs b/impls/purs/src/step8_macros.purs index 3ffd77e392..adbfe76cf8 100644 --- a/impls/purs/src/step8_macros.purs +++ b/impls/purs/src/step8_macros.purs @@ -1,336 +1,336 @@ -module Mal.Step8 where - -import Prelude - -import Control.Monad.Error.Class (try) -import Control.Monad.Free.Trans (FreeT, runFreeT) -import Control.Monad.Rec.Class (class MonadRec) -import Core as Core -import Data.Either (Either(..)) -import Data.Identity (Identity(..)) -import Data.List (List(..), foldM, (:)) -import Data.Maybe (Maybe(..)) -import Data.Traversable (traverse, traverse_) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Console (error, log) -import Effect.Exception as Ex -import Env as Env -import Printer (printStr) -import Reader (readStr) -import Readline (args, readLine) -import Types (MalExpr(..), MalFn, RefEnv, foldrM, toHashMap, toList, toVector) - - --- TYPES - -type Eval a = FreeT Identity Effect a - - --- MAIN - -main :: Effect Unit -main = do - env <- Env.newEnv Nil - traverse_ (setFn env) Core.ns - setFn env $ Tuple "eval" $ setEval env - rep_ env "(def! not (fn* (a) (if a false true)))" - rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - rep_ env "(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)))))))" - case args of - Nil -> do - Env.set env "*ARGV*" $ toList Nil - loop env - script:scriptArgs -> do - Env.set env "*ARGV*" $ toList $ MalString <$> scriptArgs - rep_ env $ "(load-file \"" <> script <> "\")" - - - --- REPL - -rep_ :: RefEnv -> String -> Effect Unit -rep_ env str = rep env str *> pure unit - - -rep :: RefEnv -> String -> Effect String -rep env str = do - ast <- read str - result <- runEval $ evalAst env ast - print result - - -loop :: RefEnv -> Effect Unit -loop env = do - line <- readLine "user> " - case line of - "" -> loop env - ":q" -> pure unit - _ -> do - result <- try $ rep env line - case result of - Right exp -> log exp - Left err -> error $ show err - loop env - - -setFn :: RefEnv -> Tuple String MalFn -> Effect Unit -setFn env (Tuple sym f) = do - newEnv <- Env.newEnv Nil - Env.set env sym $ MalFunction - { fn : f - , ast : MalNil - , env : newEnv - , params : Nil - , macro : false - , meta : MalNil - } - - -setEval :: RefEnv -> MalFn -setEval env (ast:Nil) = runEval $ eval env ast -setEval _ _ = throw "illegal call of eval" - - - --- EVAL - -eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - - MalSymbol "quote" : es -> evalQuote env es - MalSymbol "quasiquote" : es -> evalQuasiquote env es - MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es - - MalSymbol "defmacro!" : es -> evalDefmacro env es - MalSymbol "macroexpand" : es -> evalMacroexpand env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env ast = do - newAst <- macroexpand env ast - case newAst of - MalSymbol s -> do - result <- liftEffect $ Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" - l@(MalList _ _ ) -> eval env l - MalVector _ es -> toVector <$> traverse (evalAst env) es - MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es - _ -> pure newAst - - - --- DEF - -evalDef :: RefEnv -> List MalExpr -> Eval MalExpr -evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e - liftEffect $ Env.set env v evd - pure evd -evalDef _ _ = throw "invalid def!" - - - --- LET - -evalLet :: RefEnv -> List MalExpr -> Eval MalExpr -evalLet env (MalList _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet env (MalVector _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet _ _ = throw "invalid let*" - - -letBind :: RefEnv -> List MalExpr -> Eval Unit -letBind _ Nil = pure unit -letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e - liftEffect $ Env.set env ky ex - letBind env es -letBind _ _ = throw "invalid let*" - - - --- IF - -evalIf :: RefEnv -> List MalExpr -> Eval MalExpr -evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> e - MalBoolean false -> e - _ -> t -evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> MalNil - MalBoolean false -> MalNil - _ -> t -evalIf _ _ = throw "invalid if" - - - --- DO - -evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es - - - --- FUNCTION - -evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr -evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body -evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body -evalFnMatch _ _ = throw "invalid fn*" - - -evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr -evalFn env params body = do - paramsStr <- traverse unwrapSymbol params - pure $ MalFunction { fn : fn paramsStr body - , ast : body - , env : env - , params : paramsStr - , macro : false - , meta : MalNil - } - where - - fn :: List String -> MalExpr -> MalFn - fn params' body' = \args -> do - fnEnv <- Env.newEnv env - ok <- Env.sets fnEnv params' args - if ok - then runEval $ evalAst fnEnv body' - else throw "actual parameters do not match signature " - - unwrapSymbol :: MalExpr -> Eval String - unwrapSymbol (MalSymbol s) = pure s - unwrapSymbol _ = throw "fn* parameter must be symbols" - - - --- QUOTE - -evalQuote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuote _ (e:Nil) = pure e -evalQuote _ _ = throw "invalid quote" - - -evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e -evalQuasiquote _ _ = throw "invalid quasiquote" - - -evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr -evalQuasiquoteexpand (e:Nil) = quasiquote e -evalQuasiquoteexpand _ = throw "invalid quasiquote" - - -quasiquote :: MalExpr -> Eval MalExpr -quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x -quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" -quasiquote (MalList _ xs) = foldrM qqIter (toList Nil) xs -quasiquote (MalVector _ xs) = do - lst <- foldrM qqIter (toList Nil) xs - pure $ toList $ MalSymbol "vec" : lst : Nil -quasiquote ast@(MalHashMap _ _) = pure $ toList $ MalSymbol "quote" : ast : Nil -quasiquote ast@(MalSymbol _) = pure $ toList $ MalSymbol "quote" : ast : Nil -quasiquote ast = pure ast - - -qqIter :: MalExpr -> MalExpr -> Eval MalExpr -qqIter (MalList _ (MalSymbol "splice-unquote" : x : Nil)) acc = pure $ toList $ MalSymbol "concat" : x : acc : Nil -qqIter (MalList _ (MalSymbol "splice-unquote" : _)) _ = throw "invalid splice-unquote" -qqIter elt acc = do - qqted <- quasiquote elt - pure $ toList $ MalSymbol "cons" : qqted : acc : Nil - - - --- MACRO - -evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr -evalDefmacro env (MalSymbol a : b : Nil) = do - f <- evalAst env b - case f of - MalFunction fn@{macro:false} -> do - let m = MalFunction $ fn {macro = true} - liftEffect $ Env.set env a m - pure m - _ -> throw "defmacro! on non-function" -evalDefmacro _ _ = throw "invalid defmacro!" - - -evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr -evalMacroexpand env (a:Nil) = macroexpand env a -evalMacroexpand _ _ = throw "invalid macroexpand" - - -macroexpand :: RefEnv -> MalExpr -> Eval MalExpr -macroexpand env ast@(MalList _ (MalSymbol a : args)) = do - maybeMacro <- liftEffect $ Env.get env a - case maybeMacro of - Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args) - _ -> pure ast -macroexpand _ ast = pure ast - - - --- CALL FUNCTION - -evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr -evalCallFn env ast = do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args - MalFunction {ast:ast', params:params', env:env'} : args -> do - newEnv <- liftEffect $ Env.newEnv env' - _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' - _ -> throw "invalid function" - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - --- Utils - -runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a -runEval = runFreeT $ pure <<< runIdentity - - -runIdentity :: ∀ a. Identity a -> a -runIdentity (Identity a) = a - - -throw :: ∀ m a. MonadEffect m => String -> m a +module Mal.Step8 where + +import Prelude + +import Control.Monad.Error.Class (try) +import Control.Monad.Free.Trans (FreeT, runFreeT) +import Control.Monad.Rec.Class (class MonadRec) +import Core as Core +import Data.Either (Either(..)) +import Data.Identity (Identity(..)) +import Data.List (List(..), foldM, (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse, traverse_) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Console (error, log) +import Effect.Exception as Ex +import Env as Env +import Printer (printStr) +import Reader (readStr) +import Readline (args, readLine) +import Types (MalExpr(..), MalFn, RefEnv, foldrM, toHashMap, toList, toVector) + + +-- TYPES + +type Eval a = FreeT Identity Effect a + + +-- MAIN + +main :: Effect Unit +main = do + env <- Env.newEnv Nil + traverse_ (setFn env) Core.ns + setFn env $ Tuple "eval" $ setEval env + rep_ env "(def! not (fn* (a) (if a false true)))" + rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + rep_ env "(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)))))))" + case args of + Nil -> do + Env.set env "*ARGV*" $ toList Nil + loop env + script:scriptArgs -> do + Env.set env "*ARGV*" $ toList $ MalString <$> scriptArgs + rep_ env $ "(load-file \"" <> script <> "\")" + + + +-- REPL + +rep_ :: RefEnv -> String -> Effect Unit +rep_ env str = rep env str *> pure unit + + +rep :: RefEnv -> String -> Effect String +rep env str = do + ast <- read str + result <- runEval $ evalAst env ast + print result + + +loop :: RefEnv -> Effect Unit +loop env = do + line <- readLine "user> " + case line of + "" -> loop env + ":q" -> pure unit + _ -> do + result <- try $ rep env line + case result of + Right exp -> log exp + Left err -> error $ show err + loop env + + +setFn :: RefEnv -> Tuple String MalFn -> Effect Unit +setFn env (Tuple sym f) = do + newEnv <- Env.newEnv Nil + Env.set env sym $ MalFunction + { fn : f + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } + + +setEval :: RefEnv -> MalFn +setEval env (ast:Nil) = runEval $ eval env ast +setEval _ _ = throw "illegal call of eval" + + + +-- EVAL + +eval :: RefEnv -> MalExpr -> Eval MalExpr +eval _ ast@(MalList _ Nil) = pure ast +eval env (MalList _ ast) = case ast of + MalSymbol "def!" : es -> evalDef env es + MalSymbol "let*" : es -> evalLet env es + MalSymbol "if" : es -> evalIf env es + MalSymbol "do" : es -> evalDo env es + MalSymbol "fn*" : es -> evalFnMatch env es + + MalSymbol "quote" : es -> evalQuote env es + MalSymbol "quasiquote" : es -> evalQuasiquote env es + MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es + + MalSymbol "defmacro!" : es -> evalDefmacro env es + MalSymbol "macroexpand" : es -> evalMacroexpand env es + _ -> evalCallFn env ast +eval env ast = evalAst env ast + + +evalAst :: RefEnv -> MalExpr -> Eval MalExpr +evalAst env ast = do + newAst <- macroexpand env ast + case newAst of + MalSymbol s -> do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" + l@(MalList _ _ ) -> eval env l + MalVector _ es -> toVector <$> traverse (evalAst env) es + MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es + _ -> pure newAst + + + +-- DEF + +evalDef :: RefEnv -> List MalExpr -> Eval MalExpr +evalDef env (MalSymbol v : e : Nil) = do + evd <- evalAst env e + liftEffect $ Env.set env v evd + pure evd +evalDef _ _ = throw "invalid def!" + + + +-- LET + +evalLet :: RefEnv -> List MalExpr -> Eval MalExpr +evalLet env (MalList _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet env (MalVector _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet _ _ = throw "invalid let*" + + +letBind :: RefEnv -> List MalExpr -> Eval Unit +letBind _ Nil = pure unit +letBind env (MalSymbol ky : e : es) = do + ex <- evalAst env e + liftEffect $ Env.set env ky ex + letBind env es +letBind _ _ = throw "invalid let*" + + + +-- IF + +evalIf :: RefEnv -> List MalExpr -> Eval MalExpr +evalIf env (b:t:e:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> e + MalBoolean false -> e + _ -> t +evalIf env (b:t:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> MalNil + MalBoolean false -> MalNil + _ -> t +evalIf _ _ = throw "invalid if" + + + +-- DO + +evalDo :: RefEnv -> List MalExpr -> Eval MalExpr +evalDo env es = foldM (const $ evalAst env) MalNil es + + + +-- FUNCTION + +evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr +evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body +evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body +evalFnMatch _ _ = throw "invalid fn*" + + +evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr +evalFn env params body = do + paramsStr <- traverse unwrapSymbol params + pure $ MalFunction { fn : fn paramsStr body + , ast : body + , env : env + , params : paramsStr + , macro : false + , meta : MalNil + } + where + + fn :: List String -> MalExpr -> MalFn + fn params' body' = \args -> do + fnEnv <- Env.newEnv env + ok <- Env.sets fnEnv params' args + if ok + then runEval $ evalAst fnEnv body' + else throw "actual parameters do not match signature " + + unwrapSymbol :: MalExpr -> Eval String + unwrapSymbol (MalSymbol s) = pure s + unwrapSymbol _ = throw "fn* parameter must be symbols" + + + +-- QUOTE + +evalQuote :: RefEnv -> List MalExpr -> Eval MalExpr +evalQuote _ (e:Nil) = pure e +evalQuote _ _ = throw "invalid quote" + + +evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr +evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e +evalQuasiquote _ _ = throw "invalid quasiquote" + + +evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr +evalQuasiquoteexpand (e:Nil) = quasiquote e +evalQuasiquoteexpand _ = throw "invalid quasiquote" + + +quasiquote :: MalExpr -> Eval MalExpr +quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x +quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" +quasiquote (MalList _ xs) = foldrM qqIter (toList Nil) xs +quasiquote (MalVector _ xs) = do + lst <- foldrM qqIter (toList Nil) xs + pure $ toList $ MalSymbol "vec" : lst : Nil +quasiquote ast@(MalHashMap _ _) = pure $ toList $ MalSymbol "quote" : ast : Nil +quasiquote ast@(MalSymbol _) = pure $ toList $ MalSymbol "quote" : ast : Nil +quasiquote ast = pure ast + + +qqIter :: MalExpr -> MalExpr -> Eval MalExpr +qqIter (MalList _ (MalSymbol "splice-unquote" : x : Nil)) acc = pure $ toList $ MalSymbol "concat" : x : acc : Nil +qqIter (MalList _ (MalSymbol "splice-unquote" : _)) _ = throw "invalid splice-unquote" +qqIter elt acc = do + qqted <- quasiquote elt + pure $ toList $ MalSymbol "cons" : qqted : acc : Nil + + + +-- MACRO + +evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr +evalDefmacro env (MalSymbol a : b : Nil) = do + f <- evalAst env b + case f of + MalFunction fn@{macro:false} -> do + let m = MalFunction $ fn {macro = true} + liftEffect $ Env.set env a m + pure m + _ -> throw "defmacro! on non-function" +evalDefmacro _ _ = throw "invalid defmacro!" + + +evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr +evalMacroexpand env (a:Nil) = macroexpand env a +evalMacroexpand _ _ = throw "invalid macroexpand" + + +macroexpand :: RefEnv -> MalExpr -> Eval MalExpr +macroexpand env ast@(MalList _ (MalSymbol a : args)) = do + maybeMacro <- liftEffect $ Env.get env a + case maybeMacro of + Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args) + _ -> pure ast +macroexpand _ ast = pure ast + + + +-- CALL FUNCTION + +evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr +evalCallFn env ast = do + es <- traverse (evalAst env) ast + case es of + MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args + MalFunction {ast:ast', params:params', env:env'} : args -> do + newEnv <- liftEffect $ Env.newEnv env' + _ <- liftEffect $ Env.sets newEnv params' args + evalAst newEnv ast' + _ -> throw "invalid function" + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr + + + +-- Utils + +runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a +runEval = runFreeT $ pure <<< runIdentity + + +runIdentity :: ∀ a. Identity a -> a +runIdentity (Identity a) = a + + +throw :: ∀ m a. MonadEffect m => String -> m a throw = liftEffect <<< Ex.throw \ No newline at end of file diff --git a/impls/purs/src/step9_try.purs b/impls/purs/src/step9_try.purs index 2d34bd99ff..70502d9866 100644 --- a/impls/purs/src/step9_try.purs +++ b/impls/purs/src/step9_try.purs @@ -1,356 +1,356 @@ -module Mal.Step9 where - -import Prelude - -import Control.Monad.Error.Class (try) -import Control.Monad.Free.Trans (FreeT, runFreeT) -import Control.Monad.Rec.Class (class MonadRec) -import Core as Core -import Data.Either (Either(..)) -import Data.Identity (Identity(..)) -import Data.List (List(..), foldM, (:)) -import Data.Maybe (Maybe(..)) -import Data.Traversable (traverse, traverse_) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Console (error, log) -import Effect.Exception as Ex -import Env as Env -import Printer (printStr) -import Reader (readStr) -import Readline (args, readLine) -import Types (MalExpr(..), MalFn, RefEnv, foldrM, toHashMap, toList, toVector) - - - --- TYPES - -type Eval a = FreeT Identity Effect a - - - --- MAIN - -main :: Effect Unit -main = do - env <- Env.newEnv Nil - traverse_ (setFn env) Core.ns - setFn env $ Tuple "eval" $ setEval env - rep_ env "(def! not (fn* (a) (if a false true)))" - rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - rep_ env "(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)))))))" - case args of - Nil -> do - Env.set env "*ARGV*" $ toList Nil - loop env - script:scriptArgs -> do - Env.set env "*ARGV*" $ toList $ MalString <$> scriptArgs - rep_ env $ "(load-file \"" <> script <> "\")" - - - --- REPL - -rep_ :: RefEnv -> String -> Effect Unit -rep_ env str = rep env str *> pure unit - - -rep :: RefEnv -> String -> Effect String -rep env str = do - ast <- read str - result <- runEval $ evalAst env ast - print result - - -loop :: RefEnv -> Effect Unit -loop env = do - line <- readLine "user> " - case line of - "" -> loop env - ":q" -> pure unit - _ -> do - result <- try $ rep env line - case result of - Right exp -> log exp - Left err -> error $ show err - loop env - - -setFn :: RefEnv -> Tuple String MalFn -> Effect Unit -setFn env (Tuple sym f) = do - newEnv <- Env.newEnv Nil - Env.set env sym $ MalFunction - { fn : f - , ast : MalNil - , env : newEnv - , params : Nil - , macro : false - , meta : MalNil - } - - -setEval :: RefEnv -> MalFn -setEval env (ast:Nil) = runEval $ eval env ast -setEval _ _ = throw "illegal call of eval" - - - --- EVAL - -eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - - MalSymbol "quote" : es -> evalQuote env es - MalSymbol "quasiquote" : es -> evalQuasiquote env es - MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es - - MalSymbol "defmacro!" : es -> evalDefmacro env es - MalSymbol "macroexpand" : es -> evalMacroexpand env es - - MalSymbol "try*" : es -> liftEffect $ evalTry env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env ast = do - newAst <- macroexpand env ast - case newAst of - MalSymbol s -> do - result <- liftEffect $ Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" - l@(MalList _ _ ) -> eval env l - MalVector _ es -> toVector <$> traverse (evalAst env) es - MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es - _ -> pure newAst - - - --- Def - -evalDef :: RefEnv -> List MalExpr -> Eval MalExpr -evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e - liftEffect $ Env.set env v evd - pure evd -evalDef _ _ = throw "invalid def!" - - - --- Let - -evalLet :: RefEnv -> List MalExpr -> Eval MalExpr -evalLet env (MalList _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet env (MalVector _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet _ _ = throw "invalid let*" - - -letBind :: RefEnv -> List MalExpr -> Eval Unit -letBind _ Nil = pure unit -letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e - liftEffect $ Env.set env ky ex - letBind env es -letBind _ _ = throw "invalid let*" - - - --- If - -evalIf :: RefEnv -> List MalExpr -> Eval MalExpr -evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> e - MalBoolean false -> e - _ -> t -evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> MalNil - MalBoolean false -> MalNil - _ -> t -evalIf _ _ = throw "invalid if" - - - --- Do - -evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es - - - --- Function - -evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr -evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body -evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body -evalFnMatch _ _ = throw "invalid fn*" - - -evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr -evalFn env params body = do - paramsStr <- traverse unwrapSymbol params - pure $ MalFunction { fn : fn paramsStr body - , ast : body - , env : env - , params : paramsStr - , macro : false - , meta : MalNil - } - where - - fn :: List String -> MalExpr -> MalFn - fn params' body' = \args -> do - fnEnv <- Env.newEnv env - ok <- Env.sets fnEnv params' args - if ok - then runEval $ evalAst fnEnv body' - else throw "actual parameters do not match signature " - - unwrapSymbol :: MalExpr -> Eval String - unwrapSymbol (MalSymbol s) = pure s - unwrapSymbol _ = throw "fn* parameter must be symbols" - - - --- Quote - -evalQuote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuote _ (e:Nil) = pure e -evalQuote _ _ = throw "invalid quote" - - -evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e -evalQuasiquote _ _ = throw "invalid quasiquote" - - -evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr -evalQuasiquoteexpand (e:Nil) = quasiquote e -evalQuasiquoteexpand _ = throw "invalid quasiquote" - - -quasiquote :: MalExpr -> Eval MalExpr -quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x -quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" -quasiquote (MalList _ xs) = foldrM qqIter (toList Nil) xs -quasiquote (MalVector _ xs) = do - lst <- foldrM qqIter (toList Nil) xs - pure $ toList $ MalSymbol "vec" : lst : Nil -quasiquote ast@(MalHashMap _ _) = pure $ toList $ MalSymbol "quote" : ast : Nil -quasiquote ast@(MalSymbol _) = pure $ toList $ MalSymbol "quote" : ast : Nil -quasiquote ast = pure ast - - -qqIter :: MalExpr -> MalExpr -> Eval MalExpr -qqIter (MalList _ (MalSymbol "splice-unquote" : x : Nil)) acc = pure $ toList $ MalSymbol "concat" : x : acc : Nil -qqIter (MalList _ (MalSymbol "splice-unquote" : _)) _ = throw "invalid splice-unquote" -qqIter elt acc = do - qqted <- quasiquote elt - pure $ toList $ MalSymbol "cons" : qqted : acc : Nil - - - --- Macro - -evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr -evalDefmacro env (MalSymbol a : b : Nil) = do - f <- evalAst env b - case f of - MalFunction fn@{macro:false} -> do - let m = MalFunction $ fn {macro = true} - liftEffect $ Env.set env a m - pure m - _ -> throw "defmacro! on non-function" -evalDefmacro _ _ = throw "invalid defmacro!" - - -evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr -evalMacroexpand env (a:Nil) = macroexpand env a -evalMacroexpand _ _ = throw "invalid macroexpand" - - -macroexpand :: RefEnv -> MalExpr -> Eval MalExpr -macroexpand env ast@(MalList _ (MalSymbol a : args)) = do - maybeMacro <- liftEffect $ Env.get env a - case maybeMacro of - Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args) - _ -> pure ast -macroexpand _ ast = pure ast - - - --- Try - -evalTry :: RefEnv -> List MalExpr -> Effect MalExpr -evalTry env (a:Nil) = runEval $ evalAst env a -evalTry env (thw : MalList _ (MalSymbol "catch*" : MalSymbol e : b : Nil) : Nil) = do - res <- try $ runEval $ evalAst env thw - case res of - Left err -> do - tryEnv <- Env.newEnv env - Env.set tryEnv e $ MalString $ Ex.message err -- FIXME: - runEval $ evalAst tryEnv b - Right v -> pure v -evalTry _ _ = Ex.throw "invalid try*" - - - --- CALL FUNCTION - -evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr -evalCallFn env ast = do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args - MalFunction {ast:ast', params:params', env:env'} : args -> do - newEnv <- liftEffect $ Env.newEnv env' - _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' - _ -> throw "invalid function" - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - --- Utils - -runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a -runEval = runFreeT $ pure <<< runIdentity - - -runIdentity :: ∀ a. Identity a -> a -runIdentity (Identity a) = a - - -throw :: ∀ m a. MonadEffect m => String -> m a +module Mal.Step9 where + +import Prelude + +import Control.Monad.Error.Class (try) +import Control.Monad.Free.Trans (FreeT, runFreeT) +import Control.Monad.Rec.Class (class MonadRec) +import Core as Core +import Data.Either (Either(..)) +import Data.Identity (Identity(..)) +import Data.List (List(..), foldM, (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse, traverse_) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Console (error, log) +import Effect.Exception as Ex +import Env as Env +import Printer (printStr) +import Reader (readStr) +import Readline (args, readLine) +import Types (MalExpr(..), MalFn, RefEnv, foldrM, toHashMap, toList, toVector) + + + +-- TYPES + +type Eval a = FreeT Identity Effect a + + + +-- MAIN + +main :: Effect Unit +main = do + env <- Env.newEnv Nil + traverse_ (setFn env) Core.ns + setFn env $ Tuple "eval" $ setEval env + rep_ env "(def! not (fn* (a) (if a false true)))" + rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + rep_ env "(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)))))))" + case args of + Nil -> do + Env.set env "*ARGV*" $ toList Nil + loop env + script:scriptArgs -> do + Env.set env "*ARGV*" $ toList $ MalString <$> scriptArgs + rep_ env $ "(load-file \"" <> script <> "\")" + + + +-- REPL + +rep_ :: RefEnv -> String -> Effect Unit +rep_ env str = rep env str *> pure unit + + +rep :: RefEnv -> String -> Effect String +rep env str = do + ast <- read str + result <- runEval $ evalAst env ast + print result + + +loop :: RefEnv -> Effect Unit +loop env = do + line <- readLine "user> " + case line of + "" -> loop env + ":q" -> pure unit + _ -> do + result <- try $ rep env line + case result of + Right exp -> log exp + Left err -> error $ show err + loop env + + +setFn :: RefEnv -> Tuple String MalFn -> Effect Unit +setFn env (Tuple sym f) = do + newEnv <- Env.newEnv Nil + Env.set env sym $ MalFunction + { fn : f + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } + + +setEval :: RefEnv -> MalFn +setEval env (ast:Nil) = runEval $ eval env ast +setEval _ _ = throw "illegal call of eval" + + + +-- EVAL + +eval :: RefEnv -> MalExpr -> Eval MalExpr +eval _ ast@(MalList _ Nil) = pure ast +eval env (MalList _ ast) = case ast of + MalSymbol "def!" : es -> evalDef env es + MalSymbol "let*" : es -> evalLet env es + MalSymbol "if" : es -> evalIf env es + MalSymbol "do" : es -> evalDo env es + MalSymbol "fn*" : es -> evalFnMatch env es + + MalSymbol "quote" : es -> evalQuote env es + MalSymbol "quasiquote" : es -> evalQuasiquote env es + MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es + + MalSymbol "defmacro!" : es -> evalDefmacro env es + MalSymbol "macroexpand" : es -> evalMacroexpand env es + + MalSymbol "try*" : es -> liftEffect $ evalTry env es + _ -> evalCallFn env ast +eval env ast = evalAst env ast + + +evalAst :: RefEnv -> MalExpr -> Eval MalExpr +evalAst env ast = do + newAst <- macroexpand env ast + case newAst of + MalSymbol s -> do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" + l@(MalList _ _ ) -> eval env l + MalVector _ es -> toVector <$> traverse (evalAst env) es + MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es + _ -> pure newAst + + + +-- Def + +evalDef :: RefEnv -> List MalExpr -> Eval MalExpr +evalDef env (MalSymbol v : e : Nil) = do + evd <- evalAst env e + liftEffect $ Env.set env v evd + pure evd +evalDef _ _ = throw "invalid def!" + + + +-- Let + +evalLet :: RefEnv -> List MalExpr -> Eval MalExpr +evalLet env (MalList _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet env (MalVector _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet _ _ = throw "invalid let*" + + +letBind :: RefEnv -> List MalExpr -> Eval Unit +letBind _ Nil = pure unit +letBind env (MalSymbol ky : e : es) = do + ex <- evalAst env e + liftEffect $ Env.set env ky ex + letBind env es +letBind _ _ = throw "invalid let*" + + + +-- If + +evalIf :: RefEnv -> List MalExpr -> Eval MalExpr +evalIf env (b:t:e:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> e + MalBoolean false -> e + _ -> t +evalIf env (b:t:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> MalNil + MalBoolean false -> MalNil + _ -> t +evalIf _ _ = throw "invalid if" + + + +-- Do + +evalDo :: RefEnv -> List MalExpr -> Eval MalExpr +evalDo env es = foldM (const $ evalAst env) MalNil es + + + +-- Function + +evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr +evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body +evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body +evalFnMatch _ _ = throw "invalid fn*" + + +evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr +evalFn env params body = do + paramsStr <- traverse unwrapSymbol params + pure $ MalFunction { fn : fn paramsStr body + , ast : body + , env : env + , params : paramsStr + , macro : false + , meta : MalNil + } + where + + fn :: List String -> MalExpr -> MalFn + fn params' body' = \args -> do + fnEnv <- Env.newEnv env + ok <- Env.sets fnEnv params' args + if ok + then runEval $ evalAst fnEnv body' + else throw "actual parameters do not match signature " + + unwrapSymbol :: MalExpr -> Eval String + unwrapSymbol (MalSymbol s) = pure s + unwrapSymbol _ = throw "fn* parameter must be symbols" + + + +-- Quote + +evalQuote :: RefEnv -> List MalExpr -> Eval MalExpr +evalQuote _ (e:Nil) = pure e +evalQuote _ _ = throw "invalid quote" + + +evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr +evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e +evalQuasiquote _ _ = throw "invalid quasiquote" + + +evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr +evalQuasiquoteexpand (e:Nil) = quasiquote e +evalQuasiquoteexpand _ = throw "invalid quasiquote" + + +quasiquote :: MalExpr -> Eval MalExpr +quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x +quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" +quasiquote (MalList _ xs) = foldrM qqIter (toList Nil) xs +quasiquote (MalVector _ xs) = do + lst <- foldrM qqIter (toList Nil) xs + pure $ toList $ MalSymbol "vec" : lst : Nil +quasiquote ast@(MalHashMap _ _) = pure $ toList $ MalSymbol "quote" : ast : Nil +quasiquote ast@(MalSymbol _) = pure $ toList $ MalSymbol "quote" : ast : Nil +quasiquote ast = pure ast + + +qqIter :: MalExpr -> MalExpr -> Eval MalExpr +qqIter (MalList _ (MalSymbol "splice-unquote" : x : Nil)) acc = pure $ toList $ MalSymbol "concat" : x : acc : Nil +qqIter (MalList _ (MalSymbol "splice-unquote" : _)) _ = throw "invalid splice-unquote" +qqIter elt acc = do + qqted <- quasiquote elt + pure $ toList $ MalSymbol "cons" : qqted : acc : Nil + + + +-- Macro + +evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr +evalDefmacro env (MalSymbol a : b : Nil) = do + f <- evalAst env b + case f of + MalFunction fn@{macro:false} -> do + let m = MalFunction $ fn {macro = true} + liftEffect $ Env.set env a m + pure m + _ -> throw "defmacro! on non-function" +evalDefmacro _ _ = throw "invalid defmacro!" + + +evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr +evalMacroexpand env (a:Nil) = macroexpand env a +evalMacroexpand _ _ = throw "invalid macroexpand" + + +macroexpand :: RefEnv -> MalExpr -> Eval MalExpr +macroexpand env ast@(MalList _ (MalSymbol a : args)) = do + maybeMacro <- liftEffect $ Env.get env a + case maybeMacro of + Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args) + _ -> pure ast +macroexpand _ ast = pure ast + + + +-- Try + +evalTry :: RefEnv -> List MalExpr -> Effect MalExpr +evalTry env (a:Nil) = runEval $ evalAst env a +evalTry env (thw : MalList _ (MalSymbol "catch*" : MalSymbol e : b : Nil) : Nil) = do + res <- try $ runEval $ evalAst env thw + case res of + Left err -> do + tryEnv <- Env.newEnv env + Env.set tryEnv e $ MalString $ Ex.message err -- FIXME: + runEval $ evalAst tryEnv b + Right v -> pure v +evalTry _ _ = Ex.throw "invalid try*" + + + +-- CALL FUNCTION + +evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr +evalCallFn env ast = do + es <- traverse (evalAst env) ast + case es of + MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args + MalFunction {ast:ast', params:params', env:env'} : args -> do + newEnv <- liftEffect $ Env.newEnv env' + _ <- liftEffect $ Env.sets newEnv params' args + evalAst newEnv ast' + _ -> throw "invalid function" + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr + + + +-- Utils + +runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a +runEval = runFreeT $ pure <<< runIdentity + + +runIdentity :: ∀ a. Identity a -> a +runIdentity (Identity a) = a + + +throw :: ∀ m a. MonadEffect m => String -> m a throw = liftEffect <<< Ex.throw \ No newline at end of file diff --git a/impls/purs/src/stepA_mal.purs b/impls/purs/src/stepA_mal.purs index e5fbbce002..0965d07518 100644 --- a/impls/purs/src/stepA_mal.purs +++ b/impls/purs/src/stepA_mal.purs @@ -1,359 +1,359 @@ -module Mal.StepA where - -import Prelude - -import Control.Monad.Error.Class (try) -import Control.Monad.Free.Trans (FreeT, runFreeT) -import Control.Monad.Rec.Class (class MonadRec) -import Core as Core -import Data.Either (Either(..)) -import Data.Identity (Identity(..)) -import Data.List (List(..), foldM, (:)) -import Data.Maybe (Maybe(..)) -import Data.Traversable (traverse, traverse_) -import Data.Tuple (Tuple(..)) -import Effect (Effect) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Console (error, log) -import Effect.Exception as Ex -import Env as Env -import Printer (printStr) -import Reader (readStr) -import Readline (args, readLine) -import Types (MalExpr(..), MalFn, RefEnv, foldrM, toHashMap, toList, toVector) - - - --- TYPES - -type Eval a = FreeT Identity Effect a - - - --- MAIN - -main :: Effect Unit -main = do - let as = args - env <- Env.newEnv Nil - traverse_ (setFn env) Core.ns - setFn env (Tuple "eval" $ setEval env) - rep_ env "(def! *host-language* \"purescript\")" - rep_ env "(def! not (fn* (a) (if a false true)))" - rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - rep_ env "(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)))))))" - case as of - Nil -> do - Env.set env "*ARGV*" $ toList Nil - rep_ env "(println (str \"Mal [\" *host-language* \"]\"))" - loop env - script:args -> do - Env.set env "*ARGV*" $ toList $ MalString <$> args - rep_ env $ "(load-file \"" <> script <> "\")" - - - --- REPL - -rep_ :: RefEnv -> String -> Effect Unit -rep_ env str = rep env str *> pure unit - - -rep :: RefEnv -> String -> Effect String -rep env str = do - ast <- read str - result <- runEval $ evalAst env ast - print result - - -loop :: RefEnv -> Effect Unit -loop env = do - line <- readLine "user> " - case line of - "" -> loop env - ":q" -> pure unit - _ -> do - result <- try $ rep env line - case result of - Right exp -> log exp - Left err -> error $ show err - loop env - - -setFn :: RefEnv -> Tuple String MalFn -> Effect Unit -setFn env (Tuple sym f) = do - newEnv <- Env.newEnv Nil - Env.set env sym $ MalFunction - { fn : f - , ast : MalNil - , env : newEnv - , params : Nil - , macro : false - , meta : MalNil - } - - -setEval :: RefEnv -> MalFn -setEval env (ast:Nil) = runEval $ eval env ast -setEval _ _ = throw "illegal call of eval" - - - --- EVAL - -eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - - MalSymbol "quote" : es -> evalQuote env es - MalSymbol "quasiquote" : es -> evalQuasiquote env es - MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es - - MalSymbol "defmacro!" : es -> evalDefmacro env es - MalSymbol "macroexpand" : es -> evalMacroexpand env es - - MalSymbol "try*" : es -> liftEffect $ evalTry env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env ast = do - newAst <- macroexpand env ast - case newAst of - MalSymbol s -> do - result <- liftEffect $ Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" - l@(MalList _ _ ) -> eval env l - MalVector _ es -> toVector <$> traverse (evalAst env) es - MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es - _ -> pure newAst - - - --- Def - -evalDef :: RefEnv -> List MalExpr -> Eval MalExpr -evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e - liftEffect $ Env.set env v evd - pure evd -evalDef _ _ = throw "invalid def!" - - - --- Let - -evalLet :: RefEnv -> List MalExpr -> Eval MalExpr -evalLet env (MalList _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet env (MalVector _ ps : e : Nil) = do - letEnv <- liftEffect $ Env.newEnv env - letBind letEnv ps - evalAst letEnv e -evalLet _ _ = throw "invalid let*" - - -letBind :: RefEnv -> List MalExpr -> Eval Unit -letBind _ Nil = pure unit -letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e - liftEffect $ Env.set env ky ex - letBind env es -letBind _ _ = throw "invalid let*" - - - --- If - -evalIf :: RefEnv -> List MalExpr -> Eval MalExpr -evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> e - MalBoolean false -> e - _ -> t -evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of - MalNil -> MalNil - MalBoolean false -> MalNil - _ -> t -evalIf _ _ = throw "invalid if" - - - --- Do - -evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es - - - --- Function - -evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr -evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body -evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body -evalFnMatch _ _ = throw "invalid fn*" - - -evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr -evalFn env params body = do - paramsStr <- traverse unwrapSymbol params - pure $ MalFunction { fn : fn paramsStr body - , ast : body - , env : env - , params : paramsStr - , macro : false - , meta : MalNil - } - where - - fn :: List String -> MalExpr -> MalFn - fn params' body' = \args -> do - fnEnv <- Env.newEnv env - ok <- Env.sets fnEnv params' args - if ok - then runEval $ evalAst fnEnv body' - else throw "actual parameters do not match signature " - - unwrapSymbol :: MalExpr -> Eval String - unwrapSymbol (MalSymbol s) = pure s - unwrapSymbol _ = throw "fn* parameter must be symbols" - - - --- Quote - -evalQuote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuote _ (e:Nil) = pure e -evalQuote _ _ = throw "invalid quote" - - -evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e -evalQuasiquote _ _ = throw "invalid quasiquote" - - -evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr -evalQuasiquoteexpand (e:Nil) = quasiquote e -evalQuasiquoteexpand _ = throw "invalid quasiquote" - - -quasiquote :: MalExpr -> Eval MalExpr -quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x -quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" -quasiquote (MalList _ xs) = foldrM qqIter (toList Nil) xs -quasiquote (MalVector _ xs) = do - lst <- foldrM qqIter (toList Nil) xs - pure $ toList $ MalSymbol "vec" : lst : Nil -quasiquote ast@(MalHashMap _ _) = pure $ toList $ MalSymbol "quote" : ast : Nil -quasiquote ast@(MalSymbol _) = pure $ toList $ MalSymbol "quote" : ast : Nil -quasiquote ast = pure ast - - -qqIter :: MalExpr -> MalExpr -> Eval MalExpr -qqIter (MalList _ (MalSymbol "splice-unquote" : x : Nil)) acc = pure $ toList $ MalSymbol "concat" : x : acc : Nil -qqIter (MalList _ (MalSymbol "splice-unquote" : _)) _ = throw "invalid splice-unquote" -qqIter elt acc = do - qqted <- quasiquote elt - pure $ toList $ MalSymbol "cons" : qqted : acc : Nil - - - --- Macro - -evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr -evalDefmacro env (MalSymbol a : b : Nil) = do - f <- evalAst env b - case f of - MalFunction fn@{macro:false} -> do - let m = MalFunction $ fn {macro = true} - liftEffect $ Env.set env a m - pure m - _ -> throw "defmacro! on non-function" -evalDefmacro _ _ = throw "invalid defmacro!" - - -evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr -evalMacroexpand env (a:Nil) = macroexpand env a -evalMacroexpand _ _ = throw "invalid macroexpand" - - -macroexpand :: RefEnv -> MalExpr -> Eval MalExpr -macroexpand env ast@(MalList _ (MalSymbol a : args)) = do - maybeMacro <- liftEffect $ Env.get env a - case maybeMacro of - Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args) - _ -> pure ast -macroexpand _ ast = pure ast - - - --- Try - -evalTry :: RefEnv -> List MalExpr -> Effect MalExpr -evalTry env (a:Nil) = runEval $ evalAst env a -evalTry env (thw : MalList _ (MalSymbol "catch*" : MalSymbol e : b : Nil) : Nil) = do - res <- try $ runEval $ evalAst env thw - case res of - Left err -> do - tryEnv <- Env.newEnv env - Env.set tryEnv e $ MalString $ Ex.message err -- FIXME: - runEval $ evalAst tryEnv b - Right v -> pure v -evalTry _ _ = Ex.throw "invalid try*" - - - --- CALL FUNCTION - -evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr -evalCallFn env ast = do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args - MalFunction {ast:ast', params:params', env:env'} : args -> do - newEnv <- liftEffect $ Env.newEnv env' - _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' - _ -> throw "invalid function" - - - --- READ - -read :: String -> Effect MalExpr -read = readStr - - - --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - --- Utils - -runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a -runEval = runFreeT $ pure <<< runIdentity - - -runIdentity :: ∀ a. Identity a -> a -runIdentity (Identity a) = a - - -throw :: ∀ m a. MonadEffect m => String -> m a +module Mal.StepA where + +import Prelude + +import Control.Monad.Error.Class (try) +import Control.Monad.Free.Trans (FreeT, runFreeT) +import Control.Monad.Rec.Class (class MonadRec) +import Core as Core +import Data.Either (Either(..)) +import Data.Identity (Identity(..)) +import Data.List (List(..), foldM, (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse, traverse_) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Console (error, log) +import Effect.Exception as Ex +import Env as Env +import Printer (printStr) +import Reader (readStr) +import Readline (args, readLine) +import Types (MalExpr(..), MalFn, RefEnv, foldrM, toHashMap, toList, toVector) + + + +-- TYPES + +type Eval a = FreeT Identity Effect a + + + +-- MAIN + +main :: Effect Unit +main = do + let as = args + env <- Env.newEnv Nil + traverse_ (setFn env) Core.ns + setFn env (Tuple "eval" $ setEval env) + rep_ env "(def! *host-language* \"purescript\")" + rep_ env "(def! not (fn* (a) (if a false true)))" + rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + rep_ env "(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)))))))" + case as of + Nil -> do + Env.set env "*ARGV*" $ toList Nil + rep_ env "(println (str \"Mal [\" *host-language* \"]\"))" + loop env + script:args -> do + Env.set env "*ARGV*" $ toList $ MalString <$> args + rep_ env $ "(load-file \"" <> script <> "\")" + + + +-- REPL + +rep_ :: RefEnv -> String -> Effect Unit +rep_ env str = rep env str *> pure unit + + +rep :: RefEnv -> String -> Effect String +rep env str = do + ast <- read str + result <- runEval $ evalAst env ast + print result + + +loop :: RefEnv -> Effect Unit +loop env = do + line <- readLine "user> " + case line of + "" -> loop env + ":q" -> pure unit + _ -> do + result <- try $ rep env line + case result of + Right exp -> log exp + Left err -> error $ show err + loop env + + +setFn :: RefEnv -> Tuple String MalFn -> Effect Unit +setFn env (Tuple sym f) = do + newEnv <- Env.newEnv Nil + Env.set env sym $ MalFunction + { fn : f + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } + + +setEval :: RefEnv -> MalFn +setEval env (ast:Nil) = runEval $ eval env ast +setEval _ _ = throw "illegal call of eval" + + + +-- EVAL + +eval :: RefEnv -> MalExpr -> Eval MalExpr +eval _ ast@(MalList _ Nil) = pure ast +eval env (MalList _ ast) = case ast of + MalSymbol "def!" : es -> evalDef env es + MalSymbol "let*" : es -> evalLet env es + MalSymbol "if" : es -> evalIf env es + MalSymbol "do" : es -> evalDo env es + MalSymbol "fn*" : es -> evalFnMatch env es + + MalSymbol "quote" : es -> evalQuote env es + MalSymbol "quasiquote" : es -> evalQuasiquote env es + MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es + + MalSymbol "defmacro!" : es -> evalDefmacro env es + MalSymbol "macroexpand" : es -> evalMacroexpand env es + + MalSymbol "try*" : es -> liftEffect $ evalTry env es + _ -> evalCallFn env ast +eval env ast = evalAst env ast + + +evalAst :: RefEnv -> MalExpr -> Eval MalExpr +evalAst env ast = do + newAst <- macroexpand env ast + case newAst of + MalSymbol s -> do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" + l@(MalList _ _ ) -> eval env l + MalVector _ es -> toVector <$> traverse (evalAst env) es + MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es + _ -> pure newAst + + + +-- Def + +evalDef :: RefEnv -> List MalExpr -> Eval MalExpr +evalDef env (MalSymbol v : e : Nil) = do + evd <- evalAst env e + liftEffect $ Env.set env v evd + pure evd +evalDef _ _ = throw "invalid def!" + + + +-- Let + +evalLet :: RefEnv -> List MalExpr -> Eval MalExpr +evalLet env (MalList _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet env (MalVector _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet _ _ = throw "invalid let*" + + +letBind :: RefEnv -> List MalExpr -> Eval Unit +letBind _ Nil = pure unit +letBind env (MalSymbol ky : e : es) = do + ex <- evalAst env e + liftEffect $ Env.set env ky ex + letBind env es +letBind _ _ = throw "invalid let*" + + + +-- If + +evalIf :: RefEnv -> List MalExpr -> Eval MalExpr +evalIf env (b:t:e:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> e + MalBoolean false -> e + _ -> t +evalIf env (b:t:Nil) = do + cond <- evalAst env b + evalAst env case cond of + MalNil -> MalNil + MalBoolean false -> MalNil + _ -> t +evalIf _ _ = throw "invalid if" + + + +-- Do + +evalDo :: RefEnv -> List MalExpr -> Eval MalExpr +evalDo env es = foldM (const $ evalAst env) MalNil es + + + +-- Function + +evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr +evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body +evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body +evalFnMatch _ _ = throw "invalid fn*" + + +evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr +evalFn env params body = do + paramsStr <- traverse unwrapSymbol params + pure $ MalFunction { fn : fn paramsStr body + , ast : body + , env : env + , params : paramsStr + , macro : false + , meta : MalNil + } + where + + fn :: List String -> MalExpr -> MalFn + fn params' body' = \args -> do + fnEnv <- Env.newEnv env + ok <- Env.sets fnEnv params' args + if ok + then runEval $ evalAst fnEnv body' + else throw "actual parameters do not match signature " + + unwrapSymbol :: MalExpr -> Eval String + unwrapSymbol (MalSymbol s) = pure s + unwrapSymbol _ = throw "fn* parameter must be symbols" + + + +-- Quote + +evalQuote :: RefEnv -> List MalExpr -> Eval MalExpr +evalQuote _ (e:Nil) = pure e +evalQuote _ _ = throw "invalid quote" + + +evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr +evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e +evalQuasiquote _ _ = throw "invalid quasiquote" + + +evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr +evalQuasiquoteexpand (e:Nil) = quasiquote e +evalQuasiquoteexpand _ = throw "invalid quasiquote" + + +quasiquote :: MalExpr -> Eval MalExpr +quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x +quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" +quasiquote (MalList _ xs) = foldrM qqIter (toList Nil) xs +quasiquote (MalVector _ xs) = do + lst <- foldrM qqIter (toList Nil) xs + pure $ toList $ MalSymbol "vec" : lst : Nil +quasiquote ast@(MalHashMap _ _) = pure $ toList $ MalSymbol "quote" : ast : Nil +quasiquote ast@(MalSymbol _) = pure $ toList $ MalSymbol "quote" : ast : Nil +quasiquote ast = pure ast + + +qqIter :: MalExpr -> MalExpr -> Eval MalExpr +qqIter (MalList _ (MalSymbol "splice-unquote" : x : Nil)) acc = pure $ toList $ MalSymbol "concat" : x : acc : Nil +qqIter (MalList _ (MalSymbol "splice-unquote" : _)) _ = throw "invalid splice-unquote" +qqIter elt acc = do + qqted <- quasiquote elt + pure $ toList $ MalSymbol "cons" : qqted : acc : Nil + + + +-- Macro + +evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr +evalDefmacro env (MalSymbol a : b : Nil) = do + f <- evalAst env b + case f of + MalFunction fn@{macro:false} -> do + let m = MalFunction $ fn {macro = true} + liftEffect $ Env.set env a m + pure m + _ -> throw "defmacro! on non-function" +evalDefmacro _ _ = throw "invalid defmacro!" + + +evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr +evalMacroexpand env (a:Nil) = macroexpand env a +evalMacroexpand _ _ = throw "invalid macroexpand" + + +macroexpand :: RefEnv -> MalExpr -> Eval MalExpr +macroexpand env ast@(MalList _ (MalSymbol a : args)) = do + maybeMacro <- liftEffect $ Env.get env a + case maybeMacro of + Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args) + _ -> pure ast +macroexpand _ ast = pure ast + + + +-- Try + +evalTry :: RefEnv -> List MalExpr -> Effect MalExpr +evalTry env (a:Nil) = runEval $ evalAst env a +evalTry env (thw : MalList _ (MalSymbol "catch*" : MalSymbol e : b : Nil) : Nil) = do + res <- try $ runEval $ evalAst env thw + case res of + Left err -> do + tryEnv <- Env.newEnv env + Env.set tryEnv e $ MalString $ Ex.message err -- FIXME: + runEval $ evalAst tryEnv b + Right v -> pure v +evalTry _ _ = Ex.throw "invalid try*" + + + +-- CALL FUNCTION + +evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr +evalCallFn env ast = do + es <- traverse (evalAst env) ast + case es of + MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args + MalFunction {ast:ast', params:params', env:env'} : args -> do + newEnv <- liftEffect $ Env.newEnv env' + _ <- liftEffect $ Env.sets newEnv params' args + evalAst newEnv ast' + _ -> throw "invalid function" + + + +-- READ + +read :: String -> Effect MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr + + + +-- Utils + +runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a +runEval = runFreeT $ pure <<< runIdentity + + +runIdentity :: ∀ a. Identity a -> a +runIdentity (Identity a) = a + + +throw :: ∀ m a. MonadEffect m => String -> m a throw = liftEffect <<< Ex.throw \ No newline at end of file diff --git a/impls/python.2/.gitignore b/impls/python.2/.gitignore index f604396b62..7d8cd0d88d 100644 --- a/impls/python.2/.gitignore +++ b/impls/python.2/.gitignore @@ -1,3 +1,3 @@ -.vscode/ -.mypy_cache/ -.idea/ +.vscode/ +.mypy_cache/ +.idea/ diff --git a/impls/python.2/Dockerfile b/impls/python.2/Dockerfile index 857c3eb25f..6a345ad827 100644 --- a/impls/python.2/Dockerfile +++ b/impls/python.2/Dockerfile @@ -1,31 +1,31 @@ -FROM ubuntu:bionic -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Nothing additional needed for python -RUN apt-get -y install python3 - -# For dist packaging -RUN apt-get -y install zip - -# Pypi modules -RUN apt-get -y install python3-pip && pip3 install Arpeggio==1.9.0 +FROM ubuntu:bionic +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Nothing additional needed for python +RUN apt-get -y install python3 + +# For dist packaging +RUN apt-get -y install zip + +# Pypi modules +RUN apt-get -y install python3-pip && pip3 install Arpeggio==1.9.0 diff --git a/impls/python.2/Makefile b/impls/python.2/Makefile index 6d1a45785b..b4c9fb4918 100644 --- a/impls/python.2/Makefile +++ b/impls/python.2/Makefile @@ -1,6 +1,6 @@ -all: - true - -.PHONY: clean - -clean: +all: + true + +.PHONY: clean + +clean: diff --git a/impls/python.2/core.py b/impls/python.2/core.py index 2bb1cb052d..7c727da367 100644 --- a/impls/python.2/core.py +++ b/impls/python.2/core.py @@ -1,427 +1,427 @@ -import time -from typing import List, Union, Dict - -import reader -from mal_types import ( - MalInt, - MalNil, - MalList, - MalBoolean, - MalExpression, - MalFunctionCompiled, - MalAtom, - MalFunctionRaw, - MalHash_map, - MalVector, -) -from mal_types import ( - MalInvalidArgumentException, - MalString, - MalException, - MalSymbol, - MalNotImplementedException, - MalIndexError, -) - - -def prn(args: List[MalExpression]) -> MalNil: - result_string = " ".join(map(lambda x: x.readable_str(), args)) - print(result_string) - return MalNil() - - -def pr_str(args: List[MalExpression]) -> MalString: - result_string = " ".join(map(lambda x: x.readable_str(), args)) - return MalString(result_string) - - -def println(args: List[MalExpression]) -> MalNil: - result_string = " ".join(map(lambda x: x.unreadable_str(), args)) - print(result_string) - return MalNil() - - -def list_q(x: MalExpression) -> MalBoolean: - if isinstance(x, MalList): - return MalBoolean(True) - return MalBoolean(False) - - -def empty_q(x: MalExpression) -> MalBoolean: - if sequential_q(x): - return MalBoolean(len(x.native()) == 0) - raise MalInvalidArgumentException(x, "not a list") - - -def count(x: MalExpression) -> MalInt: - if isinstance(x, MalList) or isinstance(x, MalVector): - return MalInt(len(x.native())) - elif isinstance(x, MalNil): - return MalInt(0) - raise MalInvalidArgumentException(x, "not a list") - - -def equal(a: MalExpression, b: MalExpression) -> MalBoolean: - if (isinstance(a, MalList) or isinstance(a, MalVector)) and ( - isinstance(b, MalList) or isinstance(b, MalVector) - ): - a_native = a.native() - b_native = b.native() - if len(a_native) != len(b_native): - return MalBoolean(False) - for x in range(0, len(a_native)): - if not equal(a_native[x], b_native[x]): - return MalBoolean(False) - return MalBoolean(True) - if type(a) == type(b) and a.native() == b.native(): - return MalBoolean(True) - return MalBoolean(False) - - -def less(a: MalExpression, b: MalExpression) -> MalBoolean: - if not isinstance(a, MalInt): - raise MalInvalidArgumentException(a, "not an int") - if not isinstance(b, MalInt): - raise MalInvalidArgumentException(b, "not an int") - return MalBoolean(a.native() < b.native()) - - -def less_equal(a: MalExpression, b: MalExpression) -> MalBoolean: - if not isinstance(a, MalInt): - raise MalInvalidArgumentException(a, "not an int") - if not isinstance(b, MalInt): - raise MalInvalidArgumentException(b, "not an int") - return MalBoolean(a.native() <= b.native()) - - -def read_string(a: MalExpression) -> MalExpression: - if isinstance(a, MalString): - result = reader.read(a.native()) - return result - raise MalInvalidArgumentException(a, "not a string") - - -def slurp(filename: MalExpression) -> MalString: - assert isinstance(filename, MalString) - with open(filename.native(), "r") as the_file: - contents = the_file.read() - return MalString(contents) - - -def core_str(args: List[MalExpression]) -> MalString: - result = "" - for a in args: - result += a.unreadable_str() - return MalString(result) - - -def deref_q(atom: MalExpression) -> MalExpression: - assert isinstance(atom, MalAtom) - return atom.native() - - -def reset(atom: MalExpression, val: MalExpression) -> MalExpression: - assert isinstance(atom, MalAtom) - atom.reset(val) - return val - - -def vec(arg: MalExpression) -> MalExpression: - assert isinstance(arg, MalList) or isinstance(arg, MalVector) - return MalVector(arg.native ()) - - -def cons(first: MalExpression, rest: MalExpression) -> MalExpression: - assert isinstance(rest, MalList) or isinstance(rest, MalVector) - return MalList([first] + rest.native()) - - -def concat(args: List[MalExpression]) -> MalExpression: - result_list: List[MalExpression] = [] - for x in args: - assert isinstance(x, MalList) or isinstance(x, MalVector) - result_list = result_list + x.native() - return MalList(result_list) - - -def not_(expr: MalExpression) -> MalExpression: - if isinstance(expr, MalNil) or ( - isinstance(expr, MalBoolean) and expr.native() is False - ): - return MalBoolean(True) - else: - return MalBoolean(False) - - -def nth(list_: MalExpression, index: MalExpression) -> MalExpression: - assert isinstance(list_, MalList) or isinstance(list_, MalVector) - assert isinstance(index, MalInt) - list_native = list_.native() - if index.native() > len(list_native) - 1: - raise MalIndexError(index.native()) - return list_native[index.native()] - - -def apply(args: List[MalExpression]) -> MalExpression: - func = args[0] - assert isinstance(func, MalFunctionCompiled) or isinstance(func, MalFunctionRaw) - rest_args: List[MalExpression] = [] - for i in range(1, len(args) - 1): - rest_args.append(args[i]) - last_arg = args[len(args) - 1] - assert isinstance(last_arg, MalList) or isinstance(last_arg, MalVector) - rest_args = rest_args + last_arg.native() - return func.call(rest_args) - - -def map_(func: MalExpression, map_list: MalExpression) -> MalExpression: - assert isinstance(func, MalFunctionCompiled) or isinstance(func, MalFunctionRaw) - assert isinstance(map_list, MalList) or isinstance(map_list, MalVector) - result_list: List[MalExpression] = [] - for i in range(len(map_list.native())): - elem = map_list.native()[i] - result_list.append(func.call([elem])) - return MalList(result_list) - - -def throw(exception: MalExpression) -> MalExpression: - raise MalException(exception) - - -def nil_q(arg: MalExpression) -> MalExpression: - return MalBoolean(isinstance(arg, MalNil)) - - -def true_q(arg: MalExpression) -> MalExpression: - return MalBoolean(isinstance(arg, MalBoolean) and arg.native()) - - -def false_q(arg: MalExpression) -> MalExpression: - return MalBoolean(isinstance(arg, MalBoolean) and not arg.native()) - - -def symbol_q(arg: MalExpression) -> MalExpression: - return MalBoolean(isinstance(arg, MalSymbol)) - - -def keyword_q(arg: MalExpression) -> MalExpression: - return MalBoolean(isinstance(arg, MalString) and arg.is_keyword()) - - -def keyword(arg: MalExpression) -> MalExpression: - assert isinstance(arg, MalString) - if arg.is_keyword(): - return arg - else: - return MalString(arg.unreadable_str(), keyword=True) - - -def symbol(arg: MalExpression) -> MalExpression: - assert isinstance(arg, MalString) - return MalSymbol(arg.unreadable_str()) - - -def readline(arg: MalExpression) -> Union[MalString, MalNil]: - try: - assert isinstance(arg, MalString) - line = input(arg.native()) - except EOFError: - return MalNil() - return MalString(line) - - -def not_implemented(func: str) -> MalExpression: - raise MalNotImplementedException(func) - - -def get(map: MalExpression, key: MalExpression) -> MalExpression: - if isinstance(map, MalNil): - return MalNil() - if not isinstance(map, MalHash_map): - raise MalInvalidArgumentException(map, "not a hash map") - if key.native() in map.native(): - return map.native()[key.native()] - else: - return MalNil() - - -def first(args: List[MalExpression]) -> MalExpression: - try: - if isinstance(args[0], MalNil): - return MalNil() - return args[0].native()[0] - except IndexError: - return MalNil() - except TypeError: - raise MalInvalidArgumentException(args[0], "not a list") - - -def rest(args: List[MalExpression]) -> MalExpression: - try: - if isinstance(args[0], MalNil): - return MalList([]) - return MalList(args[0].native()[1:]) - except TypeError: - raise MalInvalidArgumentException(args[0], "not a list or vector") - - -def vector_q(arg: MalExpression) -> MalExpression: - return MalBoolean(isinstance(arg, MalVector)) - - -def map_q(arg: MalExpression) -> MalExpression: - return MalBoolean(isinstance(arg, MalHash_map)) - - -def sequential_q(arg: MalExpression) -> MalExpression: - return MalBoolean(isinstance(arg, MalList) or isinstance(arg, MalVector)) - - -def vector(args: List[MalExpression]) -> MalExpression: - return MalVector(args) - - -def hash_map(args: List[MalExpression]) -> MalExpression: - assert len(args) % 2 == 0 - map_ = {} # type: Dict[str, MalExpression] - for i in range(0, len(args) - 1, 2): - assert isinstance(args[i], MalString) - map_[args[i].native()] = args[i + 1] - return MalHash_map(map_) - - -def assoc(args: List[MalExpression]) -> MalExpression: - if len(args) == 0: - raise MalInvalidArgumentException(MalNil(), "no arguments supplied to assoc") - elif len(args) == 1: - return args[0] - if not isinstance(args[0], MalHash_map): - raise MalInvalidArgumentException(args[0], "not a hash map") - dict_a_copy: Dict[str, MalExpression] = args[0].native().copy() - dict_b: Dict[str, MalExpression] = hash_map(args[1:]).native() - for key in dict_b: - dict_a_copy[key] = dict_b[key] - return MalHash_map(dict_a_copy) - - -def contains_q(args: List[MalExpression]) -> MalExpression: - if len(args) < 2: - raise MalInvalidArgumentException(MalNil(), "contains? requires two arguments") - if not isinstance(args[0], MalHash_map): - raise MalInvalidArgumentException(args[0], "not a hash-map") - if not isinstance(args[1], MalString): - return MalBoolean(False) - return MalBoolean(args[1].native() in args[0].native()) - - -def keys(args: List[MalExpression]) -> MalExpression: - if len(args) != 1: - raise MalInvalidArgumentException( - MalNil(), "keys requires exactly one argument" - ) - if not isinstance(args[0], MalHash_map): - raise MalInvalidArgumentException(args[0], "not a hash map") - return MalList([MalString(x, is_already_encoded=True) for x in args[0].native()]) - - -def vals(args: List[MalExpression]) -> MalExpression: - if len(args) != 1: - raise MalInvalidArgumentException( - MalNil(), "vals requires exactly one argument" - ) - if not isinstance(args[0], MalHash_map): - raise MalInvalidArgumentException(args[0], "not a hash map") - return MalList([args[0].native()[x] for x in args[0].native()]) - - -def dissoc(args: List[MalExpression]) -> MalExpression: - if len(args) == 0: - raise MalInvalidArgumentException(MalNil(), "no arguments supplied to dissoc") - elif len(args) == 1: - return args[0] - if not isinstance(args[0], MalHash_map): - raise MalInvalidArgumentException(args[0], "not a hash map") - dict_a_copy: Dict[str, MalExpression] = args[0].native().copy() - list_b: List[MalExpression] = MalList(args[1:]).native() - for key in list_b: - try: - del dict_a_copy[key.unreadable_str()] - except KeyError: - pass - return MalHash_map(dict_a_copy) - - -def swap(args: List[MalExpression]) -> MalExpression: - atom = args[0] - assert isinstance(atom, MalAtom) - func = args[1] - assert isinstance(func, MalFunctionCompiled) or isinstance(func, MalFunctionRaw) - atom.reset(func.call([atom.native()] + args[2:])) - return atom.native() - - -ns = { - "+": MalFunctionCompiled(lambda args: MalInt(args[0].native() + args[1].native())), - "-": MalFunctionCompiled(lambda args: MalInt(args[0].native() - args[1].native())), - "*": MalFunctionCompiled(lambda args: MalInt(args[0].native() * args[1].native())), - "/": MalFunctionCompiled( - lambda args: MalInt(int(args[0].native() / args[1].native())) - ), - "prn": MalFunctionCompiled(lambda args: prn(args)), - "pr-str": MalFunctionCompiled(lambda args: pr_str(args)), - "println": MalFunctionCompiled(lambda args: println(args)), - "list": MalFunctionCompiled(lambda args: MalList(args)), - "list?": MalFunctionCompiled(lambda args: list_q(args[0])), - "empty?": MalFunctionCompiled(lambda args: empty_q(args[0])), - "count": MalFunctionCompiled(lambda args: count(args[0])), - "=": MalFunctionCompiled(lambda args: equal(args[0], args[1])), - "<": MalFunctionCompiled(lambda args: less(args[0], args[1])), - "<=": MalFunctionCompiled(lambda args: less_equal(args[0], args[1])), - ">": MalFunctionCompiled(lambda args: less(args[1], args[0])), - ">=": MalFunctionCompiled(lambda args: less_equal(args[1], args[0])), - "read-string": MalFunctionCompiled(lambda args: read_string(args[0])), - "slurp": MalFunctionCompiled(lambda args: slurp(args[0])), - "str": MalFunctionCompiled(lambda args: core_str(args)), - "atom": MalFunctionCompiled(lambda args: MalAtom(args[0])), - "atom?": MalFunctionCompiled(lambda args: MalBoolean(isinstance(args[0], MalAtom))), - "deref": MalFunctionCompiled(lambda args: deref_q(args[0])), - "reset!": MalFunctionCompiled(lambda args: reset(args[0], args[1])), - "vec": MalFunctionCompiled(lambda args: vec(args[0])), - "cons": MalFunctionCompiled(lambda args: cons(args[0], args[1])), - "concat": MalFunctionCompiled(concat), - "not": MalFunctionCompiled(lambda args: not_(args[0])), - "nth": MalFunctionCompiled(lambda args: nth(args[0], args[1])), - "apply": MalFunctionCompiled(lambda args: apply(args)), - "map": MalFunctionCompiled(lambda args: map_(args[0], args[1])), - "throw": MalFunctionCompiled(lambda args: throw(args[0])), - "nil?": MalFunctionCompiled(lambda args: nil_q(args[0])), - "true?": MalFunctionCompiled(lambda args: true_q(args[0])), - "false?": MalFunctionCompiled(lambda args: false_q(args[0])), - "symbol": MalFunctionCompiled(lambda args: symbol(args[0])), - "symbol?": MalFunctionCompiled(lambda args: symbol_q(args[0])), - "readline": MalFunctionCompiled(lambda args: readline(args[0])), - "time-ms": MalFunctionCompiled(lambda args: MalInt(int(time.time() * 1000))), - "meta": MalFunctionCompiled(lambda args: not_implemented("meta")), - "with-meta": MalFunctionCompiled(lambda args: not_implemented("with-meta")), - "fn?": MalFunctionCompiled(lambda args: not_implemented("fn?")), - "string?": MalFunctionCompiled(lambda args: not_implemented("string?")), - "number?": MalFunctionCompiled(lambda args: not_implemented("number?")), - "seq": MalFunctionCompiled(lambda args: not_implemented("seq")), - "conj": MalFunctionCompiled(lambda args: not_implemented("conj")), - "get": MalFunctionCompiled(lambda args: get(args[0], args[1])), - "first": MalFunctionCompiled(lambda args: first(args)), - "rest": MalFunctionCompiled(lambda args: rest(args)), - "keyword?": MalFunctionCompiled(lambda args: keyword_q(args[0])), - "keyword": MalFunctionCompiled(lambda args: keyword(args[0])), - "vector?": MalFunctionCompiled(lambda args: vector_q(args[0])), - "map?": MalFunctionCompiled(lambda args: map_q(args[0])), - "sequential?": MalFunctionCompiled(lambda args: sequential_q(args[0])), - "vector": MalFunctionCompiled(lambda args: vector(args)), - "hash-map": MalFunctionCompiled(lambda args: hash_map(args)), - "assoc": MalFunctionCompiled(lambda args: assoc(args)), - "contains?": MalFunctionCompiled(lambda args: contains_q(args)), - "keys": MalFunctionCompiled(lambda args: keys(args)), - "vals": MalFunctionCompiled(lambda args: vals(args)), - "dissoc": MalFunctionCompiled(lambda args: dissoc(args)), - "swap!": MalFunctionCompiled(lambda args: swap(args)), -} +import time +from typing import List, Union, Dict + +import reader +from mal_types import ( + MalInt, + MalNil, + MalList, + MalBoolean, + MalExpression, + MalFunctionCompiled, + MalAtom, + MalFunctionRaw, + MalHash_map, + MalVector, +) +from mal_types import ( + MalInvalidArgumentException, + MalString, + MalException, + MalSymbol, + MalNotImplementedException, + MalIndexError, +) + + +def prn(args: List[MalExpression]) -> MalNil: + result_string = " ".join(map(lambda x: x.readable_str(), args)) + print(result_string) + return MalNil() + + +def pr_str(args: List[MalExpression]) -> MalString: + result_string = " ".join(map(lambda x: x.readable_str(), args)) + return MalString(result_string) + + +def println(args: List[MalExpression]) -> MalNil: + result_string = " ".join(map(lambda x: x.unreadable_str(), args)) + print(result_string) + return MalNil() + + +def list_q(x: MalExpression) -> MalBoolean: + if isinstance(x, MalList): + return MalBoolean(True) + return MalBoolean(False) + + +def empty_q(x: MalExpression) -> MalBoolean: + if sequential_q(x): + return MalBoolean(len(x.native()) == 0) + raise MalInvalidArgumentException(x, "not a list") + + +def count(x: MalExpression) -> MalInt: + if isinstance(x, MalList) or isinstance(x, MalVector): + return MalInt(len(x.native())) + elif isinstance(x, MalNil): + return MalInt(0) + raise MalInvalidArgumentException(x, "not a list") + + +def equal(a: MalExpression, b: MalExpression) -> MalBoolean: + if (isinstance(a, MalList) or isinstance(a, MalVector)) and ( + isinstance(b, MalList) or isinstance(b, MalVector) + ): + a_native = a.native() + b_native = b.native() + if len(a_native) != len(b_native): + return MalBoolean(False) + for x in range(0, len(a_native)): + if not equal(a_native[x], b_native[x]): + return MalBoolean(False) + return MalBoolean(True) + if type(a) == type(b) and a.native() == b.native(): + return MalBoolean(True) + return MalBoolean(False) + + +def less(a: MalExpression, b: MalExpression) -> MalBoolean: + if not isinstance(a, MalInt): + raise MalInvalidArgumentException(a, "not an int") + if not isinstance(b, MalInt): + raise MalInvalidArgumentException(b, "not an int") + return MalBoolean(a.native() < b.native()) + + +def less_equal(a: MalExpression, b: MalExpression) -> MalBoolean: + if not isinstance(a, MalInt): + raise MalInvalidArgumentException(a, "not an int") + if not isinstance(b, MalInt): + raise MalInvalidArgumentException(b, "not an int") + return MalBoolean(a.native() <= b.native()) + + +def read_string(a: MalExpression) -> MalExpression: + if isinstance(a, MalString): + result = reader.read(a.native()) + return result + raise MalInvalidArgumentException(a, "not a string") + + +def slurp(filename: MalExpression) -> MalString: + assert isinstance(filename, MalString) + with open(filename.native(), "r") as the_file: + contents = the_file.read() + return MalString(contents) + + +def core_str(args: List[MalExpression]) -> MalString: + result = "" + for a in args: + result += a.unreadable_str() + return MalString(result) + + +def deref_q(atom: MalExpression) -> MalExpression: + assert isinstance(atom, MalAtom) + return atom.native() + + +def reset(atom: MalExpression, val: MalExpression) -> MalExpression: + assert isinstance(atom, MalAtom) + atom.reset(val) + return val + + +def vec(arg: MalExpression) -> MalExpression: + assert isinstance(arg, MalList) or isinstance(arg, MalVector) + return MalVector(arg.native ()) + + +def cons(first: MalExpression, rest: MalExpression) -> MalExpression: + assert isinstance(rest, MalList) or isinstance(rest, MalVector) + return MalList([first] + rest.native()) + + +def concat(args: List[MalExpression]) -> MalExpression: + result_list: List[MalExpression] = [] + for x in args: + assert isinstance(x, MalList) or isinstance(x, MalVector) + result_list = result_list + x.native() + return MalList(result_list) + + +def not_(expr: MalExpression) -> MalExpression: + if isinstance(expr, MalNil) or ( + isinstance(expr, MalBoolean) and expr.native() is False + ): + return MalBoolean(True) + else: + return MalBoolean(False) + + +def nth(list_: MalExpression, index: MalExpression) -> MalExpression: + assert isinstance(list_, MalList) or isinstance(list_, MalVector) + assert isinstance(index, MalInt) + list_native = list_.native() + if index.native() > len(list_native) - 1: + raise MalIndexError(index.native()) + return list_native[index.native()] + + +def apply(args: List[MalExpression]) -> MalExpression: + func = args[0] + assert isinstance(func, MalFunctionCompiled) or isinstance(func, MalFunctionRaw) + rest_args: List[MalExpression] = [] + for i in range(1, len(args) - 1): + rest_args.append(args[i]) + last_arg = args[len(args) - 1] + assert isinstance(last_arg, MalList) or isinstance(last_arg, MalVector) + rest_args = rest_args + last_arg.native() + return func.call(rest_args) + + +def map_(func: MalExpression, map_list: MalExpression) -> MalExpression: + assert isinstance(func, MalFunctionCompiled) or isinstance(func, MalFunctionRaw) + assert isinstance(map_list, MalList) or isinstance(map_list, MalVector) + result_list: List[MalExpression] = [] + for i in range(len(map_list.native())): + elem = map_list.native()[i] + result_list.append(func.call([elem])) + return MalList(result_list) + + +def throw(exception: MalExpression) -> MalExpression: + raise MalException(exception) + + +def nil_q(arg: MalExpression) -> MalExpression: + return MalBoolean(isinstance(arg, MalNil)) + + +def true_q(arg: MalExpression) -> MalExpression: + return MalBoolean(isinstance(arg, MalBoolean) and arg.native()) + + +def false_q(arg: MalExpression) -> MalExpression: + return MalBoolean(isinstance(arg, MalBoolean) and not arg.native()) + + +def symbol_q(arg: MalExpression) -> MalExpression: + return MalBoolean(isinstance(arg, MalSymbol)) + + +def keyword_q(arg: MalExpression) -> MalExpression: + return MalBoolean(isinstance(arg, MalString) and arg.is_keyword()) + + +def keyword(arg: MalExpression) -> MalExpression: + assert isinstance(arg, MalString) + if arg.is_keyword(): + return arg + else: + return MalString(arg.unreadable_str(), keyword=True) + + +def symbol(arg: MalExpression) -> MalExpression: + assert isinstance(arg, MalString) + return MalSymbol(arg.unreadable_str()) + + +def readline(arg: MalExpression) -> Union[MalString, MalNil]: + try: + assert isinstance(arg, MalString) + line = input(arg.native()) + except EOFError: + return MalNil() + return MalString(line) + + +def not_implemented(func: str) -> MalExpression: + raise MalNotImplementedException(func) + + +def get(map: MalExpression, key: MalExpression) -> MalExpression: + if isinstance(map, MalNil): + return MalNil() + if not isinstance(map, MalHash_map): + raise MalInvalidArgumentException(map, "not a hash map") + if key.native() in map.native(): + return map.native()[key.native()] + else: + return MalNil() + + +def first(args: List[MalExpression]) -> MalExpression: + try: + if isinstance(args[0], MalNil): + return MalNil() + return args[0].native()[0] + except IndexError: + return MalNil() + except TypeError: + raise MalInvalidArgumentException(args[0], "not a list") + + +def rest(args: List[MalExpression]) -> MalExpression: + try: + if isinstance(args[0], MalNil): + return MalList([]) + return MalList(args[0].native()[1:]) + except TypeError: + raise MalInvalidArgumentException(args[0], "not a list or vector") + + +def vector_q(arg: MalExpression) -> MalExpression: + return MalBoolean(isinstance(arg, MalVector)) + + +def map_q(arg: MalExpression) -> MalExpression: + return MalBoolean(isinstance(arg, MalHash_map)) + + +def sequential_q(arg: MalExpression) -> MalExpression: + return MalBoolean(isinstance(arg, MalList) or isinstance(arg, MalVector)) + + +def vector(args: List[MalExpression]) -> MalExpression: + return MalVector(args) + + +def hash_map(args: List[MalExpression]) -> MalExpression: + assert len(args) % 2 == 0 + map_ = {} # type: Dict[str, MalExpression] + for i in range(0, len(args) - 1, 2): + assert isinstance(args[i], MalString) + map_[args[i].native()] = args[i + 1] + return MalHash_map(map_) + + +def assoc(args: List[MalExpression]) -> MalExpression: + if len(args) == 0: + raise MalInvalidArgumentException(MalNil(), "no arguments supplied to assoc") + elif len(args) == 1: + return args[0] + if not isinstance(args[0], MalHash_map): + raise MalInvalidArgumentException(args[0], "not a hash map") + dict_a_copy: Dict[str, MalExpression] = args[0].native().copy() + dict_b: Dict[str, MalExpression] = hash_map(args[1:]).native() + for key in dict_b: + dict_a_copy[key] = dict_b[key] + return MalHash_map(dict_a_copy) + + +def contains_q(args: List[MalExpression]) -> MalExpression: + if len(args) < 2: + raise MalInvalidArgumentException(MalNil(), "contains? requires two arguments") + if not isinstance(args[0], MalHash_map): + raise MalInvalidArgumentException(args[0], "not a hash-map") + if not isinstance(args[1], MalString): + return MalBoolean(False) + return MalBoolean(args[1].native() in args[0].native()) + + +def keys(args: List[MalExpression]) -> MalExpression: + if len(args) != 1: + raise MalInvalidArgumentException( + MalNil(), "keys requires exactly one argument" + ) + if not isinstance(args[0], MalHash_map): + raise MalInvalidArgumentException(args[0], "not a hash map") + return MalList([MalString(x, is_already_encoded=True) for x in args[0].native()]) + + +def vals(args: List[MalExpression]) -> MalExpression: + if len(args) != 1: + raise MalInvalidArgumentException( + MalNil(), "vals requires exactly one argument" + ) + if not isinstance(args[0], MalHash_map): + raise MalInvalidArgumentException(args[0], "not a hash map") + return MalList([args[0].native()[x] for x in args[0].native()]) + + +def dissoc(args: List[MalExpression]) -> MalExpression: + if len(args) == 0: + raise MalInvalidArgumentException(MalNil(), "no arguments supplied to dissoc") + elif len(args) == 1: + return args[0] + if not isinstance(args[0], MalHash_map): + raise MalInvalidArgumentException(args[0], "not a hash map") + dict_a_copy: Dict[str, MalExpression] = args[0].native().copy() + list_b: List[MalExpression] = MalList(args[1:]).native() + for key in list_b: + try: + del dict_a_copy[key.unreadable_str()] + except KeyError: + pass + return MalHash_map(dict_a_copy) + + +def swap(args: List[MalExpression]) -> MalExpression: + atom = args[0] + assert isinstance(atom, MalAtom) + func = args[1] + assert isinstance(func, MalFunctionCompiled) or isinstance(func, MalFunctionRaw) + atom.reset(func.call([atom.native()] + args[2:])) + return atom.native() + + +ns = { + "+": MalFunctionCompiled(lambda args: MalInt(args[0].native() + args[1].native())), + "-": MalFunctionCompiled(lambda args: MalInt(args[0].native() - args[1].native())), + "*": MalFunctionCompiled(lambda args: MalInt(args[0].native() * args[1].native())), + "/": MalFunctionCompiled( + lambda args: MalInt(int(args[0].native() / args[1].native())) + ), + "prn": MalFunctionCompiled(lambda args: prn(args)), + "pr-str": MalFunctionCompiled(lambda args: pr_str(args)), + "println": MalFunctionCompiled(lambda args: println(args)), + "list": MalFunctionCompiled(lambda args: MalList(args)), + "list?": MalFunctionCompiled(lambda args: list_q(args[0])), + "empty?": MalFunctionCompiled(lambda args: empty_q(args[0])), + "count": MalFunctionCompiled(lambda args: count(args[0])), + "=": MalFunctionCompiled(lambda args: equal(args[0], args[1])), + "<": MalFunctionCompiled(lambda args: less(args[0], args[1])), + "<=": MalFunctionCompiled(lambda args: less_equal(args[0], args[1])), + ">": MalFunctionCompiled(lambda args: less(args[1], args[0])), + ">=": MalFunctionCompiled(lambda args: less_equal(args[1], args[0])), + "read-string": MalFunctionCompiled(lambda args: read_string(args[0])), + "slurp": MalFunctionCompiled(lambda args: slurp(args[0])), + "str": MalFunctionCompiled(lambda args: core_str(args)), + "atom": MalFunctionCompiled(lambda args: MalAtom(args[0])), + "atom?": MalFunctionCompiled(lambda args: MalBoolean(isinstance(args[0], MalAtom))), + "deref": MalFunctionCompiled(lambda args: deref_q(args[0])), + "reset!": MalFunctionCompiled(lambda args: reset(args[0], args[1])), + "vec": MalFunctionCompiled(lambda args: vec(args[0])), + "cons": MalFunctionCompiled(lambda args: cons(args[0], args[1])), + "concat": MalFunctionCompiled(concat), + "not": MalFunctionCompiled(lambda args: not_(args[0])), + "nth": MalFunctionCompiled(lambda args: nth(args[0], args[1])), + "apply": MalFunctionCompiled(lambda args: apply(args)), + "map": MalFunctionCompiled(lambda args: map_(args[0], args[1])), + "throw": MalFunctionCompiled(lambda args: throw(args[0])), + "nil?": MalFunctionCompiled(lambda args: nil_q(args[0])), + "true?": MalFunctionCompiled(lambda args: true_q(args[0])), + "false?": MalFunctionCompiled(lambda args: false_q(args[0])), + "symbol": MalFunctionCompiled(lambda args: symbol(args[0])), + "symbol?": MalFunctionCompiled(lambda args: symbol_q(args[0])), + "readline": MalFunctionCompiled(lambda args: readline(args[0])), + "time-ms": MalFunctionCompiled(lambda args: MalInt(int(time.time() * 1000))), + "meta": MalFunctionCompiled(lambda args: not_implemented("meta")), + "with-meta": MalFunctionCompiled(lambda args: not_implemented("with-meta")), + "fn?": MalFunctionCompiled(lambda args: not_implemented("fn?")), + "string?": MalFunctionCompiled(lambda args: not_implemented("string?")), + "number?": MalFunctionCompiled(lambda args: not_implemented("number?")), + "seq": MalFunctionCompiled(lambda args: not_implemented("seq")), + "conj": MalFunctionCompiled(lambda args: not_implemented("conj")), + "get": MalFunctionCompiled(lambda args: get(args[0], args[1])), + "first": MalFunctionCompiled(lambda args: first(args)), + "rest": MalFunctionCompiled(lambda args: rest(args)), + "keyword?": MalFunctionCompiled(lambda args: keyword_q(args[0])), + "keyword": MalFunctionCompiled(lambda args: keyword(args[0])), + "vector?": MalFunctionCompiled(lambda args: vector_q(args[0])), + "map?": MalFunctionCompiled(lambda args: map_q(args[0])), + "sequential?": MalFunctionCompiled(lambda args: sequential_q(args[0])), + "vector": MalFunctionCompiled(lambda args: vector(args)), + "hash-map": MalFunctionCompiled(lambda args: hash_map(args)), + "assoc": MalFunctionCompiled(lambda args: assoc(args)), + "contains?": MalFunctionCompiled(lambda args: contains_q(args)), + "keys": MalFunctionCompiled(lambda args: keys(args)), + "vals": MalFunctionCompiled(lambda args: vals(args)), + "dissoc": MalFunctionCompiled(lambda args: dissoc(args)), + "swap!": MalFunctionCompiled(lambda args: swap(args)), +} diff --git a/impls/python.2/env.py b/impls/python.2/env.py index 6f0e20a761..3e45935b82 100644 --- a/impls/python.2/env.py +++ b/impls/python.2/env.py @@ -1,52 +1,52 @@ -from typing import Optional, Dict, List - -from mal_types import MalExpression, MalSymbol, MalList, MalUnknownSymbolException - - -class Env(object): - """MAL Environment""" - - def __init__( - self, - outer: Optional["Env"], - binds: Optional[List[MalExpression]] = None, - exprs: Optional[List[MalExpression]] = None, - ) -> None: - self._outer = outer - self._data: Dict[str, MalExpression] = {} - if binds is not None and exprs is not None: - for x in range(0, len(binds)): - assert isinstance(binds[x], MalSymbol) - if binds[x].native() == "&": - self.set(str(binds[x + 1]), MalList(exprs[x:])) - break - else: - self.set(str(binds[x]), exprs[x]) - - def set(self, key: str, value: MalExpression) -> MalExpression: - self._data[key] = value - return value - - def find(self, key: MalExpression) -> Optional["Env"]: - if str(key) in self._data: - return self - if self._outer is not None: - return self._outer.find(key) - return None - - def get(self, key: MalExpression) -> MalExpression: - strkey = str(key) - if strkey in self._data: - return self._data[strkey] - - location = self.find(key) - if location is None: - raise MalUnknownSymbolException(strkey) - return location.get(key) - - def __repr__(self) -> str: - env_str = "{" - for d in self._data: - env_str += str(d) + ": " + str(self._data[d]) + ", " - env_str += "}" - return f"environment: (data: {env_str} outer: {repr(self._outer) if self._outer is not None else 'None'})" +from typing import Optional, Dict, List + +from mal_types import MalExpression, MalSymbol, MalList, MalUnknownSymbolException + + +class Env(object): + """MAL Environment""" + + def __init__( + self, + outer: Optional["Env"], + binds: Optional[List[MalExpression]] = None, + exprs: Optional[List[MalExpression]] = None, + ) -> None: + self._outer = outer + self._data: Dict[str, MalExpression] = {} + if binds is not None and exprs is not None: + for x in range(0, len(binds)): + assert isinstance(binds[x], MalSymbol) + if binds[x].native() == "&": + self.set(str(binds[x + 1]), MalList(exprs[x:])) + break + else: + self.set(str(binds[x]), exprs[x]) + + def set(self, key: str, value: MalExpression) -> MalExpression: + self._data[key] = value + return value + + def find(self, key: MalExpression) -> Optional["Env"]: + if str(key) in self._data: + return self + if self._outer is not None: + return self._outer.find(key) + return None + + def get(self, key: MalExpression) -> MalExpression: + strkey = str(key) + if strkey in self._data: + return self._data[strkey] + + location = self.find(key) + if location is None: + raise MalUnknownSymbolException(strkey) + return location.get(key) + + def __repr__(self) -> str: + env_str = "{" + for d in self._data: + env_str += str(d) + ": " + str(self._data[d]) + ", " + env_str += "}" + return f"environment: (data: {env_str} outer: {repr(self._outer) if self._outer is not None else 'None'})" diff --git a/impls/python.2/mal_types.py b/impls/python.2/mal_types.py index b7f7cfd615..6cc8207359 100644 --- a/impls/python.2/mal_types.py +++ b/impls/python.2/mal_types.py @@ -1,289 +1,289 @@ -from typing import Callable, Dict, List, Any - - -class MalExpression(object): - def __init__(self): - assert False # cannot instantiate - - def native(self) -> Any: - """Return a shallow native Python equivalent for the expression. - - For example, (1 2 3) might become [MalInt(1), MalInt(2), MalInt(3)]""" - pass - - def __str__(self) -> str: - return self.readable_str() - - def readable_str(self) -> str: - """Return a human-readable (preferably Mal input format) form of the expression.""" - pass - - def unreadable_str(self) -> str: - """Returns an unescaped/raw str. Defaults to being the same as readable_str.""" - return self.readable_str() - - -class MalString(MalExpression): - def __init__( - self, input_value: str, is_already_encoded: bool = False, keyword: bool = False - ) -> None: - # print("STR: " + input_value) - if is_already_encoded: - self._value = input_value - if keyword: - self._value = "\u029e" + input_value - else: - self._value = input_value - - def readable_str(self) -> str: - if self.is_keyword(): - return ":" + self._value[1:] - else: - val = self._value - - val = val.replace("\\", "\\\\") # escape backslashes - val = val.replace("\n", "\\n") # escape newlines - val = val.replace('"', '\\"') # escape quotes - val = '"' + val + '"' # add surrounding quotes - return val - - def unreadable_str(self) -> str: - if self.is_keyword(): - return ":" + self._value[1:] - else: - return self._value - - def native(self) -> Any: - return self._value - - def is_keyword(self) -> bool: - return len(self._value) > 1 and self._value[0] == "\u029e" - - -class MalList(MalExpression): - def __init__(self, values: List[MalExpression]) -> None: - for x in values: - assert isinstance(x, MalExpression) - self._values = values - - def readable_str(self) -> str: - return "(" + " ".join(map(lambda x: x.readable_str(), self._values)) + ")" - - def unreadable_str(self) -> str: - return "(" + " ".join(map(lambda x: x.unreadable_str(), self._values)) + ")" - - def native(self) -> List[MalExpression]: - return self._values - - -class MalSymbol(MalExpression): - def __init__(self, value: str) -> None: - assert type(value) is str - - self._value = str(value) - - def readable_str(self) -> str: - return str(self._value) - - def eval(self, environment) -> MalExpression: - # print("Evaluating: " + repr(self)) - return environment.get(self) - - def native(self) -> str: - return self._value - - -class MalException(Exception, MalExpression): - def __init__(self, value: MalExpression) -> None: - self._value = value - - def readable_str(self) -> str: - return str(self._value) - - def native(self) -> MalExpression: - return self._value - - -class MalIndexError(MalException): - def __init__(self, index: int) -> None: - super().__init__(MalString("Index out of bounds: " + str(index))) - - -class MalSyntaxException(MalException): - def __init__(self, message) -> None: - super().__init__(MalString(message)) - - -class MalUnknownTypeException(MalException): - def __init__(self, message) -> None: - super().__init__(MalString(message)) - - -class MalInvalidArgumentException(MalException): - def __init__(self, arg: MalExpression, reason: str) -> None: - super().__init__( - MalString(arg.readable_str() + ": invalid argument: " + reason) - ) - - -class MalUnknownSymbolException(MalException): - def __init__(self, func: str) -> None: - super().__init__(MalString("'" + func + "' not found")) - self.func = func - - -class MalNotImplementedException(MalException): - def __init__(self, func: str) -> None: - super().__init__(MalString("not implemented: " + func)) - - -class MalFunctionCompiled(MalExpression): - def __init__( - self, native_function: Callable[[List[MalExpression]], MalExpression] - ) -> None: - self._native_function = native_function - self._is_macro = False - - def readable_str(self): - return "#" if self._is_macro else "#" - - def native(self) -> Callable[[List[MalExpression]], MalExpression]: - return self._native_function - - def call(self, args: List[MalExpression]) -> MalExpression: - # print("CALL: " + str([str(arg) for arg in args])) - return self._native_function(args) - - def is_macro(self) -> bool: - return self._is_macro - - def make_macro(self) -> None: - self._is_macro = True - - -class MalFunctionRaw(MalExpression): - def __init__( - self, - fn: Callable[[List[MalExpression]], MalExpression], - ast: MalExpression, - params: MalList, - env, - ) -> None: - self._ast = ast - self._params = params - self._env = env - self._native_function = fn - self._is_macro = False - - def readable_str(self): - return "#" if self._is_macro else "#" - - def ast(self) -> MalExpression: - return self._ast - - def params(self) -> MalList: - return self._params - - def env(self): - return self._env - - def native(self) -> Callable[[List[MalExpression]], MalExpression]: - return self._native_function - - def call(self, args: List[MalExpression]) -> MalExpression: - return self._native_function(args) - - def is_macro(self) -> bool: - return self._is_macro - - def make_macro(self) -> None: - self._is_macro = True - - -class MalInt(MalExpression): - def __init__(self, value: int) -> None: - assert type(value) is int - self._value = value - - def readable_str(self) -> str: - return str(self._value) - - def native(self) -> int: - return self._value - - -class MalVector(MalExpression): - def __init__(self, values: List[MalExpression]) -> None: - self._values = values - - def readable_str(self) -> str: - return "[" + " ".join(map(lambda x: x.readable_str(), self._values)) + "]" - - def unreadable_str(self) -> str: - return "[" + " ".join(map(lambda x: x.unreadable_str(), self._values)) + "]" - - def native(self) -> List[MalExpression]: - return self._values - - -class MalHash_map(MalExpression): - def __init__(self, values: Dict[str, MalExpression]) -> None: - self._dict = values.copy() - - def readable_str(self) -> str: - result_list: List[str] = [] - for x in self._dict: - result_list.append(MalString(x).readable_str()) - result_list.append(self._dict[x].readable_str()) - return "{" + " ".join(result_list) + "}" - - def unreadable_str(self) -> str: - result_list: List[str] = [] - for x in self._dict: - result_list.append(MalString(x, is_already_encoded=True).unreadable_str()) - result_list.append(self._dict[x].unreadable_str()) - return "{" + " ".join(result_list) + "}" - - def native(self) -> Dict[str, MalExpression]: - return self._dict - - -class MalNil(MalExpression): - def __init__(self) -> None: - pass - - def readable_str(self) -> str: - return "nil" - - def eval(self, environment) -> MalExpression: - return self - - def native(self) -> None: - return None - - -class MalBoolean(MalExpression): - def __init__(self, value: bool) -> None: - self._value = value - - def readable_str(self) -> str: - if self._value: - return "true" - return "false" - - def native(self) -> bool: - return self._value - - -class MalAtom(MalExpression): - def __init__(self, value: MalExpression) -> None: - self._value = value - - def native(self) -> MalExpression: - return self._value - - def readable_str(self) -> str: - return "(atom " + str(self._value) + ")" - - def reset(self, value: MalExpression) -> None: - self._value = value +from typing import Callable, Dict, List, Any + + +class MalExpression(object): + def __init__(self): + assert False # cannot instantiate + + def native(self) -> Any: + """Return a shallow native Python equivalent for the expression. + + For example, (1 2 3) might become [MalInt(1), MalInt(2), MalInt(3)]""" + pass + + def __str__(self) -> str: + return self.readable_str() + + def readable_str(self) -> str: + """Return a human-readable (preferably Mal input format) form of the expression.""" + pass + + def unreadable_str(self) -> str: + """Returns an unescaped/raw str. Defaults to being the same as readable_str.""" + return self.readable_str() + + +class MalString(MalExpression): + def __init__( + self, input_value: str, is_already_encoded: bool = False, keyword: bool = False + ) -> None: + # print("STR: " + input_value) + if is_already_encoded: + self._value = input_value + if keyword: + self._value = "\u029e" + input_value + else: + self._value = input_value + + def readable_str(self) -> str: + if self.is_keyword(): + return ":" + self._value[1:] + else: + val = self._value + + val = val.replace("\\", "\\\\") # escape backslashes + val = val.replace("\n", "\\n") # escape newlines + val = val.replace('"', '\\"') # escape quotes + val = '"' + val + '"' # add surrounding quotes + return val + + def unreadable_str(self) -> str: + if self.is_keyword(): + return ":" + self._value[1:] + else: + return self._value + + def native(self) -> Any: + return self._value + + def is_keyword(self) -> bool: + return len(self._value) > 1 and self._value[0] == "\u029e" + + +class MalList(MalExpression): + def __init__(self, values: List[MalExpression]) -> None: + for x in values: + assert isinstance(x, MalExpression) + self._values = values + + def readable_str(self) -> str: + return "(" + " ".join(map(lambda x: x.readable_str(), self._values)) + ")" + + def unreadable_str(self) -> str: + return "(" + " ".join(map(lambda x: x.unreadable_str(), self._values)) + ")" + + def native(self) -> List[MalExpression]: + return self._values + + +class MalSymbol(MalExpression): + def __init__(self, value: str) -> None: + assert type(value) is str + + self._value = str(value) + + def readable_str(self) -> str: + return str(self._value) + + def eval(self, environment) -> MalExpression: + # print("Evaluating: " + repr(self)) + return environment.get(self) + + def native(self) -> str: + return self._value + + +class MalException(Exception, MalExpression): + def __init__(self, value: MalExpression) -> None: + self._value = value + + def readable_str(self) -> str: + return str(self._value) + + def native(self) -> MalExpression: + return self._value + + +class MalIndexError(MalException): + def __init__(self, index: int) -> None: + super().__init__(MalString("Index out of bounds: " + str(index))) + + +class MalSyntaxException(MalException): + def __init__(self, message) -> None: + super().__init__(MalString(message)) + + +class MalUnknownTypeException(MalException): + def __init__(self, message) -> None: + super().__init__(MalString(message)) + + +class MalInvalidArgumentException(MalException): + def __init__(self, arg: MalExpression, reason: str) -> None: + super().__init__( + MalString(arg.readable_str() + ": invalid argument: " + reason) + ) + + +class MalUnknownSymbolException(MalException): + def __init__(self, func: str) -> None: + super().__init__(MalString("'" + func + "' not found")) + self.func = func + + +class MalNotImplementedException(MalException): + def __init__(self, func: str) -> None: + super().__init__(MalString("not implemented: " + func)) + + +class MalFunctionCompiled(MalExpression): + def __init__( + self, native_function: Callable[[List[MalExpression]], MalExpression] + ) -> None: + self._native_function = native_function + self._is_macro = False + + def readable_str(self): + return "#" if self._is_macro else "#" + + def native(self) -> Callable[[List[MalExpression]], MalExpression]: + return self._native_function + + def call(self, args: List[MalExpression]) -> MalExpression: + # print("CALL: " + str([str(arg) for arg in args])) + return self._native_function(args) + + def is_macro(self) -> bool: + return self._is_macro + + def make_macro(self) -> None: + self._is_macro = True + + +class MalFunctionRaw(MalExpression): + def __init__( + self, + fn: Callable[[List[MalExpression]], MalExpression], + ast: MalExpression, + params: MalList, + env, + ) -> None: + self._ast = ast + self._params = params + self._env = env + self._native_function = fn + self._is_macro = False + + def readable_str(self): + return "#" if self._is_macro else "#" + + def ast(self) -> MalExpression: + return self._ast + + def params(self) -> MalList: + return self._params + + def env(self): + return self._env + + def native(self) -> Callable[[List[MalExpression]], MalExpression]: + return self._native_function + + def call(self, args: List[MalExpression]) -> MalExpression: + return self._native_function(args) + + def is_macro(self) -> bool: + return self._is_macro + + def make_macro(self) -> None: + self._is_macro = True + + +class MalInt(MalExpression): + def __init__(self, value: int) -> None: + assert type(value) is int + self._value = value + + def readable_str(self) -> str: + return str(self._value) + + def native(self) -> int: + return self._value + + +class MalVector(MalExpression): + def __init__(self, values: List[MalExpression]) -> None: + self._values = values + + def readable_str(self) -> str: + return "[" + " ".join(map(lambda x: x.readable_str(), self._values)) + "]" + + def unreadable_str(self) -> str: + return "[" + " ".join(map(lambda x: x.unreadable_str(), self._values)) + "]" + + def native(self) -> List[MalExpression]: + return self._values + + +class MalHash_map(MalExpression): + def __init__(self, values: Dict[str, MalExpression]) -> None: + self._dict = values.copy() + + def readable_str(self) -> str: + result_list: List[str] = [] + for x in self._dict: + result_list.append(MalString(x).readable_str()) + result_list.append(self._dict[x].readable_str()) + return "{" + " ".join(result_list) + "}" + + def unreadable_str(self) -> str: + result_list: List[str] = [] + for x in self._dict: + result_list.append(MalString(x, is_already_encoded=True).unreadable_str()) + result_list.append(self._dict[x].unreadable_str()) + return "{" + " ".join(result_list) + "}" + + def native(self) -> Dict[str, MalExpression]: + return self._dict + + +class MalNil(MalExpression): + def __init__(self) -> None: + pass + + def readable_str(self) -> str: + return "nil" + + def eval(self, environment) -> MalExpression: + return self + + def native(self) -> None: + return None + + +class MalBoolean(MalExpression): + def __init__(self, value: bool) -> None: + self._value = value + + def readable_str(self) -> str: + if self._value: + return "true" + return "false" + + def native(self) -> bool: + return self._value + + +class MalAtom(MalExpression): + def __init__(self, value: MalExpression) -> None: + self._value = value + + def native(self) -> MalExpression: + return self._value + + def readable_str(self) -> str: + return "(atom " + str(self._value) + ")" + + def reset(self, value: MalExpression) -> None: + self._value = value diff --git a/impls/python.2/reader.py b/impls/python.2/reader.py index 98336d14bb..20c15037d6 100644 --- a/impls/python.2/reader.py +++ b/impls/python.2/reader.py @@ -1,201 +1,201 @@ -from typing import Dict - -from arpeggio import ( # type: ignore - ParserPython, - PTNodeVisitor, - visit_parse_tree, - ZeroOrMore, -) -from arpeggio import RegExMatch as _, NoMatch # type: ignore - -from mal_types import ( - MalExpression, - MalInt, - MalList, - MalBoolean, - MalNil, - MalVector, - MalHash_map, -) -from mal_types import MalSymbol, MalString, MalSyntaxException - - -# Arpeggio grammar -def mExpression(): - return [ - mQuotedExpression, - mQuasiQuotedExpression, - mSpliceUnquotedExpression, - mUnquotedExpression, - mDerefExpression, - mList, - mVector, - mHash_map, - mInt, - mString, - mKeyword, - mNil, - mBoolean, - mSymbol, - ] - - -def mQuotedExpression(): - return "'", mExpression - - -def mQuasiQuotedExpression(): - return "`", mExpression - - -def mSpliceUnquotedExpression(): - return "~@", mExpression - - -def mUnquotedExpression(): - return "~", mExpression - - -def mDerefExpression(): - return "@", mExpression - - -def mList(): - return "(", ZeroOrMore(mExpression), ")" - - -def mVector(): - return "[", ZeroOrMore(mExpression), "]" - - -def mHash_map(): - return ("{", ZeroOrMore(mExpression), "}") - - -def mInt(): - return _(r"-?[0123456789]+") - - -def mString(): - return _(r""""(?:\\.|[^\\"])*"?""") - - -def mKeyword(): - return _(r""":[^\s\[\]{}('"`,;)]*""") - - -def mSymbol(): - return _(r"""[^\s\[\]{}('"`,;)]*""") - - -def mNil(): - return _(r"""nil(?!\?)""") - - -def mBoolean(): - return _(r"""(true|false)(?!\?)""") - - -class ReadASTVisitor(PTNodeVisitor): - def visit_mExpression(self, node, children) -> MalExpression: - return children[0] # children should already be Mal types - - def visit_mInt(self, node, children) -> MalInt: - return MalInt(int(node.value)) - - def visit_mString(self, node, children) -> MalString: - # node.value will have quotes, escape sequences - assert type(node.value) is str - if node.value[0] != '"': - raise Exception("internal error: parsed a string with no start quote") - val: str = node.value - if len(val) < 2 or val[-1] != '"': - raise MalSyntaxException("unbalanced string") - val = val[1:-1] # remove outer quotes - - # handle escaped characters - i = 0 - result = "" - while i < len(val): - if val[i] == "\\": - if (i + 1) < len(val): - if val[i + 1] == "n": - result += "\n" - elif val[i + 1] == "\\": - result += "\\" - elif val[i + 1] == '"': - result += '"' - i += 2 - else: - raise MalSyntaxException( - "unbalanced string or invalid escape sequence" - ) - else: - result += val[i] - i += 1 - - return MalString(result) - - def visit_mKeyword(self, node, children) -> MalString: - assert type(node.value) is str - assert len(node.value) > 1 - return MalString(node.value[1:], keyword=True) - - def visit_mList(self, node, children) -> MalList: - return MalList(children) - - def visit_mVector(self, node, children) -> MalVector: - return MalVector(children) - - def visit_mHash_map(self, node, children): - assert len(children) % 2 == 0 - dict = {} # type: Dict[MalExpression, MalExpression] - for i in range(0, len(children), 2): - assert isinstance(children[i], MalString) - dict[children[i].native()] = children[i + 1] - return MalHash_map(dict) - - def visit_mSymbol(self, node, children) -> MalSymbol: - return MalSymbol(node.value) - - def visit_mBoolean(self, node, children) -> MalBoolean: - if node.value == "true": - return MalBoolean(True) - if node.value == "false": - return MalBoolean(False) - raise Exception("Internal reader error") - - def visit_mNil(self, node, children) -> MalNil: - return MalNil() - - def visit_mQuotedExpression(self, node, children) -> MalList: - return MalList([MalSymbol("quote"), children[0]]) - - def visit_mQuasiQuotedExpression(self, node, children) -> MalList: - return MalList([MalSymbol("quasiquote"), children[0]]) - - def visit_mSpliceUnquotedExpression(self, node, children) -> MalList: - return MalList([MalSymbol("splice-unquote"), children[0]]) - - def visit_mUnquotedExpression(self, node, children) -> MalList: - return MalList([MalSymbol("unquote"), children[0]]) - - def visit_mDerefExpression(self, node, children) -> MalList: - return MalList([MalSymbol("deref"), children[0]]) - - -def comment(): - return _(";.*") - - -def read(x: str) -> MalExpression: - """Parse a string into a MalExpression""" - reader = ParserPython(mExpression, comment_def=comment, ws="\t\n\r ,", debug=False) - - try: - parsed = visit_parse_tree(reader.parse(x), ReadASTVisitor()) - assert issubclass(type(parsed), MalExpression) - return parsed - except NoMatch as e: - # print(str(e)) - raise MalSyntaxException("invalid syntax or unexpected EOF") +from typing import Dict + +from arpeggio import ( # type: ignore + ParserPython, + PTNodeVisitor, + visit_parse_tree, + ZeroOrMore, +) +from arpeggio import RegExMatch as _, NoMatch # type: ignore + +from mal_types import ( + MalExpression, + MalInt, + MalList, + MalBoolean, + MalNil, + MalVector, + MalHash_map, +) +from mal_types import MalSymbol, MalString, MalSyntaxException + + +# Arpeggio grammar +def mExpression(): + return [ + mQuotedExpression, + mQuasiQuotedExpression, + mSpliceUnquotedExpression, + mUnquotedExpression, + mDerefExpression, + mList, + mVector, + mHash_map, + mInt, + mString, + mKeyword, + mNil, + mBoolean, + mSymbol, + ] + + +def mQuotedExpression(): + return "'", mExpression + + +def mQuasiQuotedExpression(): + return "`", mExpression + + +def mSpliceUnquotedExpression(): + return "~@", mExpression + + +def mUnquotedExpression(): + return "~", mExpression + + +def mDerefExpression(): + return "@", mExpression + + +def mList(): + return "(", ZeroOrMore(mExpression), ")" + + +def mVector(): + return "[", ZeroOrMore(mExpression), "]" + + +def mHash_map(): + return ("{", ZeroOrMore(mExpression), "}") + + +def mInt(): + return _(r"-?[0123456789]+") + + +def mString(): + return _(r""""(?:\\.|[^\\"])*"?""") + + +def mKeyword(): + return _(r""":[^\s\[\]{}('"`,;)]*""") + + +def mSymbol(): + return _(r"""[^\s\[\]{}('"`,;)]*""") + + +def mNil(): + return _(r"""nil(?!\?)""") + + +def mBoolean(): + return _(r"""(true|false)(?!\?)""") + + +class ReadASTVisitor(PTNodeVisitor): + def visit_mExpression(self, node, children) -> MalExpression: + return children[0] # children should already be Mal types + + def visit_mInt(self, node, children) -> MalInt: + return MalInt(int(node.value)) + + def visit_mString(self, node, children) -> MalString: + # node.value will have quotes, escape sequences + assert type(node.value) is str + if node.value[0] != '"': + raise Exception("internal error: parsed a string with no start quote") + val: str = node.value + if len(val) < 2 or val[-1] != '"': + raise MalSyntaxException("unbalanced string") + val = val[1:-1] # remove outer quotes + + # handle escaped characters + i = 0 + result = "" + while i < len(val): + if val[i] == "\\": + if (i + 1) < len(val): + if val[i + 1] == "n": + result += "\n" + elif val[i + 1] == "\\": + result += "\\" + elif val[i + 1] == '"': + result += '"' + i += 2 + else: + raise MalSyntaxException( + "unbalanced string or invalid escape sequence" + ) + else: + result += val[i] + i += 1 + + return MalString(result) + + def visit_mKeyword(self, node, children) -> MalString: + assert type(node.value) is str + assert len(node.value) > 1 + return MalString(node.value[1:], keyword=True) + + def visit_mList(self, node, children) -> MalList: + return MalList(children) + + def visit_mVector(self, node, children) -> MalVector: + return MalVector(children) + + def visit_mHash_map(self, node, children): + assert len(children) % 2 == 0 + dict = {} # type: Dict[MalExpression, MalExpression] + for i in range(0, len(children), 2): + assert isinstance(children[i], MalString) + dict[children[i].native()] = children[i + 1] + return MalHash_map(dict) + + def visit_mSymbol(self, node, children) -> MalSymbol: + return MalSymbol(node.value) + + def visit_mBoolean(self, node, children) -> MalBoolean: + if node.value == "true": + return MalBoolean(True) + if node.value == "false": + return MalBoolean(False) + raise Exception("Internal reader error") + + def visit_mNil(self, node, children) -> MalNil: + return MalNil() + + def visit_mQuotedExpression(self, node, children) -> MalList: + return MalList([MalSymbol("quote"), children[0]]) + + def visit_mQuasiQuotedExpression(self, node, children) -> MalList: + return MalList([MalSymbol("quasiquote"), children[0]]) + + def visit_mSpliceUnquotedExpression(self, node, children) -> MalList: + return MalList([MalSymbol("splice-unquote"), children[0]]) + + def visit_mUnquotedExpression(self, node, children) -> MalList: + return MalList([MalSymbol("unquote"), children[0]]) + + def visit_mDerefExpression(self, node, children) -> MalList: + return MalList([MalSymbol("deref"), children[0]]) + + +def comment(): + return _(";.*") + + +def read(x: str) -> MalExpression: + """Parse a string into a MalExpression""" + reader = ParserPython(mExpression, comment_def=comment, ws="\t\n\r ,", debug=False) + + try: + parsed = visit_parse_tree(reader.parse(x), ReadASTVisitor()) + assert issubclass(type(parsed), MalExpression) + return parsed + except NoMatch as e: + # print(str(e)) + raise MalSyntaxException("invalid syntax or unexpected EOF") diff --git a/impls/python.2/run b/impls/python.2/run index d5f8d5d146..b52a655f64 100755 --- a/impls/python.2/run +++ b/impls/python.2/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec python3 -O $(dirname $0)/${STEP:-stepA_mal}.py "${@}" +#!/bin/bash +exec python3 -O $(dirname $0)/${STEP:-stepA_mal}.py "${@}" diff --git a/impls/python.2/step0_repl.py b/impls/python.2/step0_repl.py index e323a6d861..50ce6e9264 100644 --- a/impls/python.2/step0_repl.py +++ b/impls/python.2/step0_repl.py @@ -1,28 +1,28 @@ -import readline - - -def READ(x: str) -> str: - return x - - -def EVAL(x: str) -> str: - return x - - -def PRINT(x: str) -> str: - return x - - -def rep(x: str) -> str: - return PRINT(EVAL(READ(x))) - - -# repl loop -eof: bool = False -while not eof: - try: - line = input("user> ") - readline.add_history(line) - print(rep(line)) - except EOFError: - eof = True +import readline + + +def READ(x: str) -> str: + return x + + +def EVAL(x: str) -> str: + return x + + +def PRINT(x: str) -> str: + return x + + +def rep(x: str) -> str: + return PRINT(EVAL(READ(x))) + + +# repl loop +eof: bool = False +while not eof: + try: + line = input("user> ") + readline.add_history(line) + print(rep(line)) + except EOFError: + eof = True diff --git a/impls/python.2/step1_read_print.py b/impls/python.2/step1_read_print.py index 1913c145d1..c361add1b1 100644 --- a/impls/python.2/step1_read_print.py +++ b/impls/python.2/step1_read_print.py @@ -1,38 +1,38 @@ -import readline - -import reader -from mal_types import MalExpression, MalSyntaxException - - -def READ(x: str) -> MalExpression: - return reader.read(x) - - -def EVAL(x: MalExpression) -> MalExpression: - return x - - -def PRINT(x: MalExpression) -> str: - return str(x) - - -def rep(x: str) -> str: - try: - return PRINT(EVAL(READ(x))) - except BaseException: - return "Expression is invalid or unbalanced: " + x - - -if __name__ == "__main__": - # repl loop - eof: bool = False - while not eof: - try: - line = input("user> ") - readline.add_history(line) - try: - print(rep(line)) - except MalSyntaxException as e: - print("ERROR: invalid syntax: " + str(e)) - except EOFError: - eof = True +import readline + +import reader +from mal_types import MalExpression, MalSyntaxException + + +def READ(x: str) -> MalExpression: + return reader.read(x) + + +def EVAL(x: MalExpression) -> MalExpression: + return x + + +def PRINT(x: MalExpression) -> str: + return str(x) + + +def rep(x: str) -> str: + try: + return PRINT(EVAL(READ(x))) + except BaseException: + return "Expression is invalid or unbalanced: " + x + + +if __name__ == "__main__": + # repl loop + eof: bool = False + while not eof: + try: + line = input("user> ") + readline.add_history(line) + try: + print(rep(line)) + except MalSyntaxException as e: + print("ERROR: invalid syntax: " + str(e)) + except EOFError: + eof = True diff --git a/impls/python.2/step2_eval.py b/impls/python.2/step2_eval.py index 142de22434..c8cca34aa1 100644 --- a/impls/python.2/step2_eval.py +++ b/impls/python.2/step2_eval.py @@ -1,73 +1,73 @@ -import readline -from typing import Dict - -import reader -from mal_types import MalExpression, MalSymbol -from mal_types import MalFunctionCompiled, MalInt -from mal_types import MalList, MalVector, MalHash_map -from mal_types import MalUnknownSymbolException, MalSyntaxException - -repl_env = { - "+": MalFunctionCompiled(lambda a: MalInt(a[0].native() + a[1].native())), - "-": MalFunctionCompiled(lambda a: MalInt(a[0].native() - a[1].native())), - "*": MalFunctionCompiled(lambda a: MalInt(a[0].native() * a[1].native())), - "/": MalFunctionCompiled(lambda a: MalInt(int(a[0].native() / a[1].native()))), -} - - -def READ(x: str) -> MalExpression: - return reader.read(x) - - -def eval_ast(ast: MalExpression, env: Dict[str, MalFunctionCompiled]) -> MalExpression: - if isinstance(ast, MalSymbol): - try: - return env[str(ast)] - except KeyError: - raise MalUnknownSymbolException(str(ast)) - if isinstance(ast, MalList): - return MalList([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalVector): - return MalVector([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalHash_map): - new_dict = {} # type: Dict[str, MalExpression] - for key in ast.native(): - new_dict[key] = EVAL(ast.native()[key], env) - return MalHash_map(new_dict) - return ast - - -def EVAL(ast: MalExpression, env: Dict[str, MalFunctionCompiled]) -> MalExpression: - if not isinstance(ast, MalList): - return eval_ast(ast, env) - if len(ast.native()) == 0: - return ast - eval_result = eval_ast(ast, env) - f = eval_result.native()[0] - args = eval_result.native()[1:] - return f.call(args) - - -def PRINT(exp: MalExpression) -> str: - return str(exp) - - -def rep(x: str) -> str: - return PRINT(EVAL(READ(x), repl_env)) - - -if __name__ == "__main__": - # repl loop - eof: bool = False - while not eof: - try: - line = input("user> ") - readline.add_history(line) - try: - print(rep(line)) - except MalUnknownSymbolException as e: - print("'" + e.func + "' not found") - except MalSyntaxException as e: - print("ERROR: invalid syntax: " + str(e)) - except EOFError: - eof = True +import readline +from typing import Dict + +import reader +from mal_types import MalExpression, MalSymbol +from mal_types import MalFunctionCompiled, MalInt +from mal_types import MalList, MalVector, MalHash_map +from mal_types import MalUnknownSymbolException, MalSyntaxException + +repl_env = { + "+": MalFunctionCompiled(lambda a: MalInt(a[0].native() + a[1].native())), + "-": MalFunctionCompiled(lambda a: MalInt(a[0].native() - a[1].native())), + "*": MalFunctionCompiled(lambda a: MalInt(a[0].native() * a[1].native())), + "/": MalFunctionCompiled(lambda a: MalInt(int(a[0].native() / a[1].native()))), +} + + +def READ(x: str) -> MalExpression: + return reader.read(x) + + +def eval_ast(ast: MalExpression, env: Dict[str, MalFunctionCompiled]) -> MalExpression: + if isinstance(ast, MalSymbol): + try: + return env[str(ast)] + except KeyError: + raise MalUnknownSymbolException(str(ast)) + if isinstance(ast, MalList): + return MalList([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalVector): + return MalVector([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalHash_map): + new_dict = {} # type: Dict[str, MalExpression] + for key in ast.native(): + new_dict[key] = EVAL(ast.native()[key], env) + return MalHash_map(new_dict) + return ast + + +def EVAL(ast: MalExpression, env: Dict[str, MalFunctionCompiled]) -> MalExpression: + if not isinstance(ast, MalList): + return eval_ast(ast, env) + if len(ast.native()) == 0: + return ast + eval_result = eval_ast(ast, env) + f = eval_result.native()[0] + args = eval_result.native()[1:] + return f.call(args) + + +def PRINT(exp: MalExpression) -> str: + return str(exp) + + +def rep(x: str) -> str: + return PRINT(EVAL(READ(x), repl_env)) + + +if __name__ == "__main__": + # repl loop + eof: bool = False + while not eof: + try: + line = input("user> ") + readline.add_history(line) + try: + print(rep(line)) + except MalUnknownSymbolException as e: + print("'" + e.func + "' not found") + except MalSyntaxException as e: + print("ERROR: invalid syntax: " + str(e)) + except EOFError: + eof = True diff --git a/impls/python.2/step3_env.py b/impls/python.2/step3_env.py index db828c930e..2c3f4a62b1 100644 --- a/impls/python.2/step3_env.py +++ b/impls/python.2/step3_env.py @@ -1,99 +1,99 @@ -import readline -from typing import Dict - -import reader -from env import Env -from mal_types import ( - MalExpression, - MalSymbol, - MalInvalidArgumentException, - MalUnknownSymbolException, - MalSyntaxException, -) -from mal_types import MalInt, MalList, MalFunctionCompiled, MalVector, MalHash_map - -repl_env = Env(None) -repl_env.set("+", MalFunctionCompiled(lambda a: MalInt(a[0].native() + a[1].native()))) -repl_env.set("-", MalFunctionCompiled(lambda a: MalInt(a[0].native() - a[1].native()))) -repl_env.set("*", MalFunctionCompiled(lambda a: MalInt(a[0].native() * a[1].native()))) -repl_env.set( - "/", MalFunctionCompiled(lambda a: MalInt(int(a[0].native() / a[1].native()))) -) - - -def READ(x: str) -> MalExpression: - return reader.read(x) - - -def eval_ast(ast: MalExpression, env: Env) -> MalExpression: - if isinstance(ast, MalSymbol): - return env.get(ast) - if isinstance(ast, MalList): - return MalList([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalVector): - return MalVector([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalHash_map): - new_dict = {} # type: Dict[str, MalExpression] - for key in ast.native(): - new_dict[key] = EVAL(ast.native()[key], env) - return MalHash_map(new_dict) - - return ast - - -def EVAL(ast: MalExpression, env: Env) -> MalExpression: - if not isinstance(ast, MalList): - return eval_ast(ast, env) - if len(ast.native()) == 0: - return ast - first = str(ast.native()[0]) - rest = ast.native()[1:] - if first == "def!": - key = str(ast.native()[1]) - value = EVAL(ast.native()[2], env) - return env.set(key, value) - if first == "let*": - assert len(rest) == 2 - let_env = Env(env) - bindings = rest[0] - assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) - bindings_list = bindings.native() - assert len(bindings_list) % 2 == 0 - for i in range(0, len(bindings_list), 2): - assert isinstance(bindings_list[i], MalSymbol) - assert isinstance(bindings_list[i + 1], MalExpression) - let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) - expr = rest[1] - return EVAL(expr, let_env) - evaled_ast = eval_ast(ast, env) - f = evaled_ast.native()[0] - args = evaled_ast.native()[1:] - try: - return f.call(args) - except AttributeError: - raise MalInvalidArgumentException(f, "attribute error") - - -def PRINT(x: MalExpression) -> str: - return str(x) - - -def rep(x: str) -> str: - return PRINT(EVAL(READ(x), repl_env)) - - -if __name__ == "__main__": - # repl loop - eof: bool = False - while not eof: - try: - line = input("user> ") - readline.add_history(line) - try: - print(rep(line)) - except MalUnknownSymbolException as e: - print("'" + e.func + "' not found") - except MalSyntaxException as e: - print("ERROR: invalid syntax: " + str(e)) - except EOFError: - eof = True +import readline +from typing import Dict + +import reader +from env import Env +from mal_types import ( + MalExpression, + MalSymbol, + MalInvalidArgumentException, + MalUnknownSymbolException, + MalSyntaxException, +) +from mal_types import MalInt, MalList, MalFunctionCompiled, MalVector, MalHash_map + +repl_env = Env(None) +repl_env.set("+", MalFunctionCompiled(lambda a: MalInt(a[0].native() + a[1].native()))) +repl_env.set("-", MalFunctionCompiled(lambda a: MalInt(a[0].native() - a[1].native()))) +repl_env.set("*", MalFunctionCompiled(lambda a: MalInt(a[0].native() * a[1].native()))) +repl_env.set( + "/", MalFunctionCompiled(lambda a: MalInt(int(a[0].native() / a[1].native()))) +) + + +def READ(x: str) -> MalExpression: + return reader.read(x) + + +def eval_ast(ast: MalExpression, env: Env) -> MalExpression: + if isinstance(ast, MalSymbol): + return env.get(ast) + if isinstance(ast, MalList): + return MalList([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalVector): + return MalVector([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalHash_map): + new_dict = {} # type: Dict[str, MalExpression] + for key in ast.native(): + new_dict[key] = EVAL(ast.native()[key], env) + return MalHash_map(new_dict) + + return ast + + +def EVAL(ast: MalExpression, env: Env) -> MalExpression: + if not isinstance(ast, MalList): + return eval_ast(ast, env) + if len(ast.native()) == 0: + return ast + first = str(ast.native()[0]) + rest = ast.native()[1:] + if first == "def!": + key = str(ast.native()[1]) + value = EVAL(ast.native()[2], env) + return env.set(key, value) + if first == "let*": + assert len(rest) == 2 + let_env = Env(env) + bindings = rest[0] + assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) + bindings_list = bindings.native() + assert len(bindings_list) % 2 == 0 + for i in range(0, len(bindings_list), 2): + assert isinstance(bindings_list[i], MalSymbol) + assert isinstance(bindings_list[i + 1], MalExpression) + let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) + expr = rest[1] + return EVAL(expr, let_env) + evaled_ast = eval_ast(ast, env) + f = evaled_ast.native()[0] + args = evaled_ast.native()[1:] + try: + return f.call(args) + except AttributeError: + raise MalInvalidArgumentException(f, "attribute error") + + +def PRINT(x: MalExpression) -> str: + return str(x) + + +def rep(x: str) -> str: + return PRINT(EVAL(READ(x), repl_env)) + + +if __name__ == "__main__": + # repl loop + eof: bool = False + while not eof: + try: + line = input("user> ") + readline.add_history(line) + try: + print(rep(line)) + except MalUnknownSymbolException as e: + print("'" + e.func + "' not found") + except MalSyntaxException as e: + print("ERROR: invalid syntax: " + str(e)) + except EOFError: + eof = True diff --git a/impls/python.2/step4_if_fn_do.py b/impls/python.2/step4_if_fn_do.py index ae4e0b55c4..036eb6c1a1 100644 --- a/impls/python.2/step4_if_fn_do.py +++ b/impls/python.2/step4_if_fn_do.py @@ -1,127 +1,127 @@ -import readline -from typing import Dict - -import core -import reader -from env import Env -from mal_types import ( - MalExpression, - MalSymbol, - MalInvalidArgumentException, - MalUnknownSymbolException, - MalSyntaxException, -) -from mal_types import ( - MalList, - MalNil, - MalBoolean, - MalFunctionCompiled, - MalVector, - MalHash_map, -) - -repl_env = Env(None) -for key in core.ns: - repl_env.set(key, core.ns[key]) - - -def READ(x: str) -> MalExpression: - return reader.read(x) - - -def eval_ast(ast: MalExpression, env: Env) -> MalExpression: - if isinstance(ast, MalSymbol): - return env.get(ast) - if isinstance(ast, MalList): - return MalList([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalVector): - return MalVector([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalHash_map): - new_dict = {} # type: Dict[str, MalExpression] - for key in ast.native(): - new_dict[key] = EVAL(ast.native()[key], env) - return MalHash_map(new_dict) - return ast - - -def EVAL(ast: MalExpression, env: Env) -> MalExpression: - # print("EVAL: " + str(ast)) - if not isinstance(ast, MalList): - return eval_ast(ast, env) - if len(ast.native()) == 0: - return ast - first = str(ast.native()[0]) - rest = ast.native()[1:] - if first == "def!": - key = str(ast.native()[1]) - value = EVAL(ast.native()[2], env) - return env.set(key, value) - if first == "let*": - assert len(rest) == 2 - let_env = Env(env) - bindings = rest[0] - assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) - bindings_list = bindings.native() - assert len(bindings_list) % 2 == 0 - for i in range(0, len(bindings_list), 2): - assert isinstance(bindings_list[i], MalSymbol) - assert isinstance(bindings_list[i + 1], MalExpression) - let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) - expr = rest[1] - return EVAL(expr, let_env) - if first == "do": - for x in range(0, len(rest) - 1): - EVAL(rest[x], env) - return EVAL(rest[len(rest) - 1], env) - if first == "if": - condition = EVAL(rest[0], env) - - if isinstance(condition, MalNil) or ( - isinstance(condition, MalBoolean) and condition.native() is False - ): - if len(rest) >= 3: - return EVAL(rest[2], env) - else: - return MalNil() - else: - return EVAL(rest[1], env) - if first == "fn*": - - def func_body(x): - func_env = Env(outer=env, binds=rest[0].native(), exprs=x) - return EVAL(rest[1], func_env) - - return MalFunctionCompiled(func_body) - - evaled_ast = eval_ast(ast, env) - f = evaled_ast.native()[0] - args = evaled_ast.native()[1:] - try: - return f.call(args) - except AttributeError: - raise MalInvalidArgumentException(f, "attribute error") - - -def PRINT(x: MalExpression) -> str: - return str(x) - - -def rep(x: str) -> str: - return PRINT(EVAL(READ(x), repl_env)) - - -if __name__ == "__main__": - # repl loop - eof: bool = False - while not eof: - try: - line = input("user> ") - readline.add_history(line) - try: - print(rep(line)) - except MalUnknownSymbolException as e: - print("'" + e.func + "' not found") - except MalSyntaxException as e: - print("ERROR: invalid syntax: " + str(e)) - except EOFError: - eof = True +import readline +from typing import Dict + +import core +import reader +from env import Env +from mal_types import ( + MalExpression, + MalSymbol, + MalInvalidArgumentException, + MalUnknownSymbolException, + MalSyntaxException, +) +from mal_types import ( + MalList, + MalNil, + MalBoolean, + MalFunctionCompiled, + MalVector, + MalHash_map, +) + +repl_env = Env(None) +for key in core.ns: + repl_env.set(key, core.ns[key]) + + +def READ(x: str) -> MalExpression: + return reader.read(x) + + +def eval_ast(ast: MalExpression, env: Env) -> MalExpression: + if isinstance(ast, MalSymbol): + return env.get(ast) + if isinstance(ast, MalList): + return MalList([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalVector): + return MalVector([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalHash_map): + new_dict = {} # type: Dict[str, MalExpression] + for key in ast.native(): + new_dict[key] = EVAL(ast.native()[key], env) + return MalHash_map(new_dict) + return ast + + +def EVAL(ast: MalExpression, env: Env) -> MalExpression: + # print("EVAL: " + str(ast)) + if not isinstance(ast, MalList): + return eval_ast(ast, env) + if len(ast.native()) == 0: + return ast + first = str(ast.native()[0]) + rest = ast.native()[1:] + if first == "def!": + key = str(ast.native()[1]) + value = EVAL(ast.native()[2], env) + return env.set(key, value) + if first == "let*": + assert len(rest) == 2 + let_env = Env(env) + bindings = rest[0] + assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) + bindings_list = bindings.native() + assert len(bindings_list) % 2 == 0 + for i in range(0, len(bindings_list), 2): + assert isinstance(bindings_list[i], MalSymbol) + assert isinstance(bindings_list[i + 1], MalExpression) + let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) + expr = rest[1] + return EVAL(expr, let_env) + if first == "do": + for x in range(0, len(rest) - 1): + EVAL(rest[x], env) + return EVAL(rest[len(rest) - 1], env) + if first == "if": + condition = EVAL(rest[0], env) + + if isinstance(condition, MalNil) or ( + isinstance(condition, MalBoolean) and condition.native() is False + ): + if len(rest) >= 3: + return EVAL(rest[2], env) + else: + return MalNil() + else: + return EVAL(rest[1], env) + if first == "fn*": + + def func_body(x): + func_env = Env(outer=env, binds=rest[0].native(), exprs=x) + return EVAL(rest[1], func_env) + + return MalFunctionCompiled(func_body) + + evaled_ast = eval_ast(ast, env) + f = evaled_ast.native()[0] + args = evaled_ast.native()[1:] + try: + return f.call(args) + except AttributeError: + raise MalInvalidArgumentException(f, "attribute error") + + +def PRINT(x: MalExpression) -> str: + return str(x) + + +def rep(x: str) -> str: + return PRINT(EVAL(READ(x), repl_env)) + + +if __name__ == "__main__": + # repl loop + eof: bool = False + while not eof: + try: + line = input("user> ") + readline.add_history(line) + try: + print(rep(line)) + except MalUnknownSymbolException as e: + print("'" + e.func + "' not found") + except MalSyntaxException as e: + print("ERROR: invalid syntax: " + str(e)) + except EOFError: + eof = True diff --git a/impls/python.2/step5_tco.py b/impls/python.2/step5_tco.py index 73337dd745..511ce47237 100644 --- a/impls/python.2/step5_tco.py +++ b/impls/python.2/step5_tco.py @@ -1,144 +1,144 @@ -import readline -from typing import List, Dict - -import core -import reader -from env import Env -from mal_types import MalExpression, MalSymbol -from mal_types import ( - MalList, - MalNil, - MalBoolean, - MalFunctionCompiled, - MalFunctionRaw, - MalVector, - MalHash_map, -) -from mal_types import ( - MalUnknownSymbolException, - MalSyntaxException, - MalInvalidArgumentException, -) - -repl_env = Env(None) -for key in core.ns: - repl_env.set(key, core.ns[key]) - - -def READ(x: str) -> MalExpression: - return reader.read(x) - - -def eval_ast(ast: MalExpression, env: Env) -> MalExpression: - if isinstance(ast, MalSymbol): - return env.get(ast) - if isinstance(ast, MalList): - return MalList([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalVector): - return MalVector([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalHash_map): - new_dict: Dict[str, MalExpression] = {} - for key in ast.native(): - new_dict[key] = EVAL(ast.native()[key], env) - return MalHash_map(new_dict) - return ast - - -def EVAL(ast: MalExpression, env: Env) -> MalExpression: - while True: - ast_native = ast.native() - if not isinstance(ast, MalList): - return eval_ast(ast, env) - elif len(ast_native) == 0: - return ast - - first_str = str(ast_native[0]) - if first_str == "def!": - name: str = str(ast_native[1]) - value: MalExpression = EVAL(ast_native[2], env) - return env.set(name, value) - elif first_str == "let*": - assert len(ast_native) == 3 - let_env = Env(env) - bindings: MalExpression = ast_native[1] - assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) - bindings_list: List[MalExpression] = bindings.native() - assert len(bindings_list) % 2 == 0 - for i in range(0, len(bindings_list), 2): - assert isinstance(bindings_list[i], MalSymbol) - assert isinstance(bindings_list[i + 1], MalExpression) - let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) - env = let_env - ast = ast_native[2] - continue - elif first_str == "do": - for x in range(1, len(ast_native) - 1): - EVAL(ast_native[x], env) - ast = ast_native[len(ast_native) - 1] - continue - elif first_str == "if": - condition = EVAL(ast_native[1], env) - - if isinstance(condition, MalNil) or ( - isinstance(condition, MalBoolean) and condition.native() is False - ): - if len(ast_native) >= 4: - ast = ast_native[3] - continue - else: - return MalNil() - else: - ast = ast_native[2] - continue - elif first_str == "fn*": - raw_ast = ast_native[2] - raw_params = ast_native[1] - - def fn(args: List[MalExpression]) -> MalExpression: - f_ast = raw_ast - f_env = Env(outer=env, binds=raw_params.native(), exprs=args) - return EVAL(f_ast, f_env) - - return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) - else: - evaled_ast = eval_ast(ast, env) - f = evaled_ast.native()[0] - args = evaled_ast.native()[1:] - if isinstance(f, MalFunctionRaw): - ast = f.ast() - - env = Env( - outer=f.env(), - binds=f.params().native(), - exprs=evaled_ast.native()[1:], - ) - continue - elif isinstance(f, MalFunctionCompiled): - return f.call(args) - else: - raise MalInvalidArgumentException(f, "not a function") - - -def PRINT(x: MalExpression) -> str: - return str(x) - - -def rep(x: str) -> str: - return PRINT(EVAL(READ(x), repl_env)) - - -if __name__ == "__main__": - # repl loop - eof: bool = False - while not eof: - try: - line = input("user> ") - readline.add_history(line) - try: - print(rep(line)) - except MalUnknownSymbolException as e: - print("'" + e.func + "' not found") - except MalSyntaxException as e: - print("ERROR: invalid syntax: " + str(e)) - except EOFError: - eof = True +import readline +from typing import List, Dict + +import core +import reader +from env import Env +from mal_types import MalExpression, MalSymbol +from mal_types import ( + MalList, + MalNil, + MalBoolean, + MalFunctionCompiled, + MalFunctionRaw, + MalVector, + MalHash_map, +) +from mal_types import ( + MalUnknownSymbolException, + MalSyntaxException, + MalInvalidArgumentException, +) + +repl_env = Env(None) +for key in core.ns: + repl_env.set(key, core.ns[key]) + + +def READ(x: str) -> MalExpression: + return reader.read(x) + + +def eval_ast(ast: MalExpression, env: Env) -> MalExpression: + if isinstance(ast, MalSymbol): + return env.get(ast) + if isinstance(ast, MalList): + return MalList([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalVector): + return MalVector([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalHash_map): + new_dict: Dict[str, MalExpression] = {} + for key in ast.native(): + new_dict[key] = EVAL(ast.native()[key], env) + return MalHash_map(new_dict) + return ast + + +def EVAL(ast: MalExpression, env: Env) -> MalExpression: + while True: + ast_native = ast.native() + if not isinstance(ast, MalList): + return eval_ast(ast, env) + elif len(ast_native) == 0: + return ast + + first_str = str(ast_native[0]) + if first_str == "def!": + name: str = str(ast_native[1]) + value: MalExpression = EVAL(ast_native[2], env) + return env.set(name, value) + elif first_str == "let*": + assert len(ast_native) == 3 + let_env = Env(env) + bindings: MalExpression = ast_native[1] + assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) + bindings_list: List[MalExpression] = bindings.native() + assert len(bindings_list) % 2 == 0 + for i in range(0, len(bindings_list), 2): + assert isinstance(bindings_list[i], MalSymbol) + assert isinstance(bindings_list[i + 1], MalExpression) + let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) + env = let_env + ast = ast_native[2] + continue + elif first_str == "do": + for x in range(1, len(ast_native) - 1): + EVAL(ast_native[x], env) + ast = ast_native[len(ast_native) - 1] + continue + elif first_str == "if": + condition = EVAL(ast_native[1], env) + + if isinstance(condition, MalNil) or ( + isinstance(condition, MalBoolean) and condition.native() is False + ): + if len(ast_native) >= 4: + ast = ast_native[3] + continue + else: + return MalNil() + else: + ast = ast_native[2] + continue + elif first_str == "fn*": + raw_ast = ast_native[2] + raw_params = ast_native[1] + + def fn(args: List[MalExpression]) -> MalExpression: + f_ast = raw_ast + f_env = Env(outer=env, binds=raw_params.native(), exprs=args) + return EVAL(f_ast, f_env) + + return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) + else: + evaled_ast = eval_ast(ast, env) + f = evaled_ast.native()[0] + args = evaled_ast.native()[1:] + if isinstance(f, MalFunctionRaw): + ast = f.ast() + + env = Env( + outer=f.env(), + binds=f.params().native(), + exprs=evaled_ast.native()[1:], + ) + continue + elif isinstance(f, MalFunctionCompiled): + return f.call(args) + else: + raise MalInvalidArgumentException(f, "not a function") + + +def PRINT(x: MalExpression) -> str: + return str(x) + + +def rep(x: str) -> str: + return PRINT(EVAL(READ(x), repl_env)) + + +if __name__ == "__main__": + # repl loop + eof: bool = False + while not eof: + try: + line = input("user> ") + readline.add_history(line) + try: + print(rep(line)) + except MalUnknownSymbolException as e: + print("'" + e.func + "' not found") + except MalSyntaxException as e: + print("ERROR: invalid syntax: " + str(e)) + except EOFError: + eof = True diff --git a/impls/python.2/step6_file.py b/impls/python.2/step6_file.py index 832a36a757..a337243290 100644 --- a/impls/python.2/step6_file.py +++ b/impls/python.2/step6_file.py @@ -1,175 +1,175 @@ -import readline -import sys -from typing import List, Dict - -import core -import reader -from env import Env -from mal_types import MalExpression, MalSymbol -from mal_types import ( - MalList, - MalNil, - MalBoolean, - MalFunctionCompiled, - MalFunctionRaw, - MalAtom, - MalVector, - MalHash_map, -) -from mal_types import ( - MalUnknownSymbolException, - MalSyntaxException, - MalInvalidArgumentException, - MalString, -) - -repl_env = Env(None) -for key in core.ns: - repl_env.set(key, core.ns[key]) - - -def eval_func(args: List[MalExpression]) -> MalExpression: - a0 = args[0] - assert isinstance(a0, MalExpression) - return EVAL(a0, repl_env) - - -repl_env.set("eval", MalFunctionCompiled(lambda args: eval_func(args))) - - -def swap(args: List[MalExpression]) -> MalExpression: - atom = args[0] - assert isinstance(atom, MalAtom) - func = args[1] - atom.reset(EVAL(MalList([func, atom.native()] + args[2:]), repl_env)) - return atom.native() - - -def READ(x: str) -> MalExpression: - return reader.read(x) - - -def eval_ast(ast: MalExpression, env: Env) -> MalExpression: - if isinstance(ast, MalSymbol): - return env.get(ast) - if isinstance(ast, MalList): - return MalList([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalVector): - return MalVector([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalHash_map): - new_dict = {} # type: Dict[str, MalExpression] - for key in ast.native(): - new_dict[key] = EVAL(ast.native()[key], env) - return MalHash_map(new_dict) - return ast - - -def EVAL(ast: MalExpression, env: Env) -> MalExpression: - while True: - ast_native = ast.native() - if not isinstance(ast, MalList): - return eval_ast(ast, env) - elif len(ast_native) == 0: - return ast - - first_str = str(ast_native[0]) - if first_str == "def!": - name: str = str(ast_native[1]) - value: MalExpression = EVAL(ast_native[2], env) - return env.set(name, value) - elif first_str == "let*": - assert len(ast_native) == 3 - let_env = Env(env) - bindings: MalExpression = ast_native[1] - assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) - bindings_list: List[MalExpression] = bindings.native() - assert len(bindings_list) % 2 == 0 - for i in range(0, len(bindings_list), 2): - assert isinstance(bindings_list[i], MalSymbol) - assert isinstance(bindings_list[i + 1], MalExpression) - let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) - env = let_env - ast = ast_native[2] - continue - elif first_str == "do": - for x in range(1, len(ast_native) - 1): - EVAL(ast_native[x], env) - ast = ast_native[len(ast_native) - 1] - continue - elif first_str == "if": - condition = EVAL(ast_native[1], env) - - if isinstance(condition, MalNil) or ( - isinstance(condition, MalBoolean) and condition.native() is False - ): - if len(ast_native) >= 4: - ast = ast_native[3] - continue - else: - return MalNil() - else: - ast = ast_native[2] - continue - elif first_str == "fn*": - raw_ast = ast_native[2] - raw_params = ast_native[1] - - def fn(args: List[MalExpression]) -> MalExpression: - f_ast = raw_ast - f_env = Env(outer=env, binds=raw_params.native(), exprs=args) - return EVAL(f_ast, f_env) - - return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) - else: - evaled_ast = eval_ast(ast, env) - f = evaled_ast.native()[0] - args = evaled_ast.native()[1:] - if isinstance(f, MalFunctionRaw): - ast = f.ast() - - env = Env( - outer=f.env(), - binds=f.params().native(), - exprs=evaled_ast.native()[1:], - ) - continue - elif isinstance(f, MalFunctionCompiled): - return f.call(args) - else: - raise MalInvalidArgumentException(f, "not a function") - - -def PRINT(x: MalExpression) -> str: - return str(x) - - -def rep(x: str) -> str: - return PRINT(EVAL(READ(x), repl_env)) - - -if __name__ == "__main__": - # repl loop - eof: bool = False - rep( - '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' - ) - mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) - repl_env.set("*ARGV*", mal_argv) - - if len(sys.argv) >= 2: - file_str = sys.argv[1] - rep('(load-file "' + file_str + '")') - exit(0) - - while not eof: - try: - line = input("user> ") - readline.add_history(line) - try: - print(rep(line)) - except MalUnknownSymbolException as e: - print("'" + e.func + "' not found") - except MalSyntaxException as e: - print("ERROR: invalid syntax: " + str(e)) - except EOFError: - eof = True +import readline +import sys +from typing import List, Dict + +import core +import reader +from env import Env +from mal_types import MalExpression, MalSymbol +from mal_types import ( + MalList, + MalNil, + MalBoolean, + MalFunctionCompiled, + MalFunctionRaw, + MalAtom, + MalVector, + MalHash_map, +) +from mal_types import ( + MalUnknownSymbolException, + MalSyntaxException, + MalInvalidArgumentException, + MalString, +) + +repl_env = Env(None) +for key in core.ns: + repl_env.set(key, core.ns[key]) + + +def eval_func(args: List[MalExpression]) -> MalExpression: + a0 = args[0] + assert isinstance(a0, MalExpression) + return EVAL(a0, repl_env) + + +repl_env.set("eval", MalFunctionCompiled(lambda args: eval_func(args))) + + +def swap(args: List[MalExpression]) -> MalExpression: + atom = args[0] + assert isinstance(atom, MalAtom) + func = args[1] + atom.reset(EVAL(MalList([func, atom.native()] + args[2:]), repl_env)) + return atom.native() + + +def READ(x: str) -> MalExpression: + return reader.read(x) + + +def eval_ast(ast: MalExpression, env: Env) -> MalExpression: + if isinstance(ast, MalSymbol): + return env.get(ast) + if isinstance(ast, MalList): + return MalList([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalVector): + return MalVector([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalHash_map): + new_dict = {} # type: Dict[str, MalExpression] + for key in ast.native(): + new_dict[key] = EVAL(ast.native()[key], env) + return MalHash_map(new_dict) + return ast + + +def EVAL(ast: MalExpression, env: Env) -> MalExpression: + while True: + ast_native = ast.native() + if not isinstance(ast, MalList): + return eval_ast(ast, env) + elif len(ast_native) == 0: + return ast + + first_str = str(ast_native[0]) + if first_str == "def!": + name: str = str(ast_native[1]) + value: MalExpression = EVAL(ast_native[2], env) + return env.set(name, value) + elif first_str == "let*": + assert len(ast_native) == 3 + let_env = Env(env) + bindings: MalExpression = ast_native[1] + assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) + bindings_list: List[MalExpression] = bindings.native() + assert len(bindings_list) % 2 == 0 + for i in range(0, len(bindings_list), 2): + assert isinstance(bindings_list[i], MalSymbol) + assert isinstance(bindings_list[i + 1], MalExpression) + let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) + env = let_env + ast = ast_native[2] + continue + elif first_str == "do": + for x in range(1, len(ast_native) - 1): + EVAL(ast_native[x], env) + ast = ast_native[len(ast_native) - 1] + continue + elif first_str == "if": + condition = EVAL(ast_native[1], env) + + if isinstance(condition, MalNil) or ( + isinstance(condition, MalBoolean) and condition.native() is False + ): + if len(ast_native) >= 4: + ast = ast_native[3] + continue + else: + return MalNil() + else: + ast = ast_native[2] + continue + elif first_str == "fn*": + raw_ast = ast_native[2] + raw_params = ast_native[1] + + def fn(args: List[MalExpression]) -> MalExpression: + f_ast = raw_ast + f_env = Env(outer=env, binds=raw_params.native(), exprs=args) + return EVAL(f_ast, f_env) + + return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) + else: + evaled_ast = eval_ast(ast, env) + f = evaled_ast.native()[0] + args = evaled_ast.native()[1:] + if isinstance(f, MalFunctionRaw): + ast = f.ast() + + env = Env( + outer=f.env(), + binds=f.params().native(), + exprs=evaled_ast.native()[1:], + ) + continue + elif isinstance(f, MalFunctionCompiled): + return f.call(args) + else: + raise MalInvalidArgumentException(f, "not a function") + + +def PRINT(x: MalExpression) -> str: + return str(x) + + +def rep(x: str) -> str: + return PRINT(EVAL(READ(x), repl_env)) + + +if __name__ == "__main__": + # repl loop + eof: bool = False + rep( + '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' + ) + mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) + repl_env.set("*ARGV*", mal_argv) + + if len(sys.argv) >= 2: + file_str = sys.argv[1] + rep('(load-file "' + file_str + '")') + exit(0) + + while not eof: + try: + line = input("user> ") + readline.add_history(line) + try: + print(rep(line)) + except MalUnknownSymbolException as e: + print("'" + e.func + "' not found") + except MalSyntaxException as e: + print("ERROR: invalid syntax: " + str(e)) + except EOFError: + eof = True diff --git a/impls/python.2/step7_quote.py b/impls/python.2/step7_quote.py index ad293715cd..256a007772 100644 --- a/impls/python.2/step7_quote.py +++ b/impls/python.2/step7_quote.py @@ -1,214 +1,214 @@ -import functools -import readline -import sys -from typing import List, Dict - -import core -import reader -from env import Env -from mal_types import MalExpression, MalSymbol -from mal_types import ( - MalList, - MalNil, - MalBoolean, - MalFunctionCompiled, - MalFunctionRaw, - MalAtom, - MalVector, - MalHash_map, -) -from mal_types import ( - MalUnknownSymbolException, - MalSyntaxException, - MalInvalidArgumentException, - MalString, -) - -repl_env = Env(None) -for key in core.ns: - repl_env.set(key, core.ns[key]) - - -def eval_func(args: List[MalExpression]) -> MalExpression: - a0 = args[0] - assert isinstance(a0, MalExpression) - return EVAL(a0, repl_env) - - -repl_env.set("eval", MalFunctionCompiled(lambda args: eval_func(args))) - - -def swap(args: List[MalExpression]) -> MalExpression: - atom = args[0] - assert isinstance(atom, MalAtom) - func = args[1] - atom.reset(EVAL(MalList([func, atom.native()] + args[2:]), repl_env)) - return atom.native() - - -def READ(x: str) -> MalExpression: - return reader.read(x) - -def eval_ast(ast: MalExpression, env: Env) -> MalExpression: - if isinstance(ast, MalSymbol): - return env.get(ast) - if isinstance(ast, MalList): - return MalList([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalVector): - return MalVector([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalHash_map): - new_dict = {} # type: Dict[str, MalExpression] - for key in ast.native(): - new_dict[key] = EVAL(ast.native()[key], env) - return MalHash_map(new_dict) - return ast - - -def qq_loop(acc: MalList, elt: MalExpression) -> MalList: - if isinstance(elt, MalList): - lst = elt.native() - if len(lst) == 2: - fst = lst[0] - if isinstance(fst, MalSymbol) and fst.native() == u"splice-unquote": - return MalList([MalSymbol(u"concat"), lst[1], acc]) - return MalList([MalSymbol(u"cons"), quasiquote(elt), acc]) - -def qq_foldr(xs: List[MalExpression]) -> MalList: - return functools.reduce(qq_loop, reversed(xs), MalList([])) - -def quasiquote(ast: MalExpression) -> MalExpression: - if isinstance(ast, MalList): - lst = ast.native() - if len(lst) == 2: - fst = lst[0] - if isinstance(fst, MalSymbol) and fst.native() == u'unquote': - return lst[1] - return qq_foldr(lst) - elif isinstance(ast, MalVector): - return MalList([MalSymbol("vec"), qq_foldr(ast.native())]) - elif isinstance(ast, MalSymbol) or isinstance(ast, MalHash_map): - return MalList([MalSymbol("quote"), ast]) - else: - return ast - - -def EVAL(ast: MalExpression, env: Env) -> MalExpression: - while True: - ast_native = ast.native() - if not isinstance(ast, MalList): - return eval_ast(ast, env) - elif len(ast_native) == 0: - return ast - - first_str = str(ast_native[0]) - if first_str == "def!": - name: str = str(ast_native[1]) - value: MalExpression = EVAL(ast_native[2], env) - return env.set(name, value) - elif first_str == "let*": - assert len(ast_native) == 3 - let_env = Env(env) - bindings: MalExpression = ast_native[1] - assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) - bindings_list: List[MalExpression] = bindings.native() - assert len(bindings_list) % 2 == 0 - for i in range(0, len(bindings_list), 2): - assert isinstance(bindings_list[i], MalSymbol) - assert isinstance(bindings_list[i + 1], MalExpression) - let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) - env = let_env - ast = ast_native[2] - continue - elif first_str == "do": - for x in range(1, len(ast_native) - 1): - EVAL(ast_native[x], env) - ast = ast_native[len(ast_native) - 1] - continue - elif first_str == "if": - condition = EVAL(ast_native[1], env) - - if isinstance(condition, MalNil) or ( - isinstance(condition, MalBoolean) and condition.native() is False - ): - if len(ast_native) >= 4: - ast = ast_native[3] - continue - else: - return MalNil() - else: - ast = ast_native[2] - continue - elif first_str == "fn*": - raw_ast = ast_native[2] - raw_params = ast_native[1] - - def fn(args: List[MalExpression]) -> MalExpression: - f_ast = raw_ast - f_env = Env(outer=env, binds=raw_params.native(), exprs=args) - return EVAL(f_ast, f_env) - - return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) - elif first_str == "quote": - return ( - MalList(ast_native[1].native()) - if isinstance(ast_native[1], MalVector) - else ast_native[1] - ) - elif first_str == "quasiquoteexpand": - return quasiquote(ast_native[1]) - elif first_str == "quasiquote": - ast = quasiquote(ast_native[1]) - continue - else: - evaled_ast = eval_ast(ast, env) - f = evaled_ast.native()[0] - args = evaled_ast.native()[1:] - if isinstance(f, MalFunctionRaw): - ast = f.ast() - - env = Env( - outer=f.env(), - binds=f.params().native(), - exprs=evaled_ast.native()[1:], - ) - continue - elif isinstance(f, MalFunctionCompiled): - return f.call(args) - else: - raise MalInvalidArgumentException(f, "not a function") - - -def PRINT(x: MalExpression) -> str: - return str(x) - - -def rep(x: str) -> str: - return PRINT(EVAL(READ(x), repl_env)) - - -if __name__ == "__main__": - # repl loop - eof: bool = False - rep( - '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' - ) - mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) - repl_env.set("*ARGV*", mal_argv) - - if len(sys.argv) >= 2: - file_str = sys.argv[1] - rep('(load-file "' + file_str + '")') - exit(0) - - while not eof: - try: - line = input("user> ") - readline.add_history(line) - try: - print(rep(line)) - except MalUnknownSymbolException as e: - print("'" + e.func + "' not found") - except MalSyntaxException as e: - print("ERROR: invalid syntax: " + str(e)) - except EOFError: - eof = True +import functools +import readline +import sys +from typing import List, Dict + +import core +import reader +from env import Env +from mal_types import MalExpression, MalSymbol +from mal_types import ( + MalList, + MalNil, + MalBoolean, + MalFunctionCompiled, + MalFunctionRaw, + MalAtom, + MalVector, + MalHash_map, +) +from mal_types import ( + MalUnknownSymbolException, + MalSyntaxException, + MalInvalidArgumentException, + MalString, +) + +repl_env = Env(None) +for key in core.ns: + repl_env.set(key, core.ns[key]) + + +def eval_func(args: List[MalExpression]) -> MalExpression: + a0 = args[0] + assert isinstance(a0, MalExpression) + return EVAL(a0, repl_env) + + +repl_env.set("eval", MalFunctionCompiled(lambda args: eval_func(args))) + + +def swap(args: List[MalExpression]) -> MalExpression: + atom = args[0] + assert isinstance(atom, MalAtom) + func = args[1] + atom.reset(EVAL(MalList([func, atom.native()] + args[2:]), repl_env)) + return atom.native() + + +def READ(x: str) -> MalExpression: + return reader.read(x) + +def eval_ast(ast: MalExpression, env: Env) -> MalExpression: + if isinstance(ast, MalSymbol): + return env.get(ast) + if isinstance(ast, MalList): + return MalList([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalVector): + return MalVector([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalHash_map): + new_dict = {} # type: Dict[str, MalExpression] + for key in ast.native(): + new_dict[key] = EVAL(ast.native()[key], env) + return MalHash_map(new_dict) + return ast + + +def qq_loop(acc: MalList, elt: MalExpression) -> MalList: + if isinstance(elt, MalList): + lst = elt.native() + if len(lst) == 2: + fst = lst[0] + if isinstance(fst, MalSymbol) and fst.native() == u"splice-unquote": + return MalList([MalSymbol(u"concat"), lst[1], acc]) + return MalList([MalSymbol(u"cons"), quasiquote(elt), acc]) + +def qq_foldr(xs: List[MalExpression]) -> MalList: + return functools.reduce(qq_loop, reversed(xs), MalList([])) + +def quasiquote(ast: MalExpression) -> MalExpression: + if isinstance(ast, MalList): + lst = ast.native() + if len(lst) == 2: + fst = lst[0] + if isinstance(fst, MalSymbol) and fst.native() == u'unquote': + return lst[1] + return qq_foldr(lst) + elif isinstance(ast, MalVector): + return MalList([MalSymbol("vec"), qq_foldr(ast.native())]) + elif isinstance(ast, MalSymbol) or isinstance(ast, MalHash_map): + return MalList([MalSymbol("quote"), ast]) + else: + return ast + + +def EVAL(ast: MalExpression, env: Env) -> MalExpression: + while True: + ast_native = ast.native() + if not isinstance(ast, MalList): + return eval_ast(ast, env) + elif len(ast_native) == 0: + return ast + + first_str = str(ast_native[0]) + if first_str == "def!": + name: str = str(ast_native[1]) + value: MalExpression = EVAL(ast_native[2], env) + return env.set(name, value) + elif first_str == "let*": + assert len(ast_native) == 3 + let_env = Env(env) + bindings: MalExpression = ast_native[1] + assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) + bindings_list: List[MalExpression] = bindings.native() + assert len(bindings_list) % 2 == 0 + for i in range(0, len(bindings_list), 2): + assert isinstance(bindings_list[i], MalSymbol) + assert isinstance(bindings_list[i + 1], MalExpression) + let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) + env = let_env + ast = ast_native[2] + continue + elif first_str == "do": + for x in range(1, len(ast_native) - 1): + EVAL(ast_native[x], env) + ast = ast_native[len(ast_native) - 1] + continue + elif first_str == "if": + condition = EVAL(ast_native[1], env) + + if isinstance(condition, MalNil) or ( + isinstance(condition, MalBoolean) and condition.native() is False + ): + if len(ast_native) >= 4: + ast = ast_native[3] + continue + else: + return MalNil() + else: + ast = ast_native[2] + continue + elif first_str == "fn*": + raw_ast = ast_native[2] + raw_params = ast_native[1] + + def fn(args: List[MalExpression]) -> MalExpression: + f_ast = raw_ast + f_env = Env(outer=env, binds=raw_params.native(), exprs=args) + return EVAL(f_ast, f_env) + + return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) + elif first_str == "quote": + return ( + MalList(ast_native[1].native()) + if isinstance(ast_native[1], MalVector) + else ast_native[1] + ) + elif first_str == "quasiquoteexpand": + return quasiquote(ast_native[1]) + elif first_str == "quasiquote": + ast = quasiquote(ast_native[1]) + continue + else: + evaled_ast = eval_ast(ast, env) + f = evaled_ast.native()[0] + args = evaled_ast.native()[1:] + if isinstance(f, MalFunctionRaw): + ast = f.ast() + + env = Env( + outer=f.env(), + binds=f.params().native(), + exprs=evaled_ast.native()[1:], + ) + continue + elif isinstance(f, MalFunctionCompiled): + return f.call(args) + else: + raise MalInvalidArgumentException(f, "not a function") + + +def PRINT(x: MalExpression) -> str: + return str(x) + + +def rep(x: str) -> str: + return PRINT(EVAL(READ(x), repl_env)) + + +if __name__ == "__main__": + # repl loop + eof: bool = False + rep( + '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' + ) + mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) + repl_env.set("*ARGV*", mal_argv) + + if len(sys.argv) >= 2: + file_str = sys.argv[1] + rep('(load-file "' + file_str + '")') + exit(0) + + while not eof: + try: + line = input("user> ") + readline.add_history(line) + try: + print(rep(line)) + except MalUnknownSymbolException as e: + print("'" + e.func + "' not found") + except MalSyntaxException as e: + print("ERROR: invalid syntax: " + str(e)) + except EOFError: + eof = True diff --git a/impls/python.2/step8_macros.py b/impls/python.2/step8_macros.py index 10bad332c6..3ac82d99d6 100644 --- a/impls/python.2/step8_macros.py +++ b/impls/python.2/step8_macros.py @@ -1,270 +1,270 @@ -import functools -import readline -import sys -from typing import List, Dict - -import core -import reader -from env import Env -from mal_types import MalExpression, MalSymbol -from mal_types import ( - MalList, - MalNil, - MalBoolean, - MalFunctionCompiled, - MalFunctionRaw, - MalAtom, - MalVector, - MalHash_map, -) -from mal_types import ( - MalUnknownSymbolException, - MalSyntaxException, - MalInvalidArgumentException, - MalString, - MalException, -) - - -def READ(x: str) -> MalExpression: - return reader.read(x) - - -def eval_ast(ast: MalExpression, env: Env) -> MalExpression: - if isinstance(ast, MalSymbol): - return env.get(ast) - if isinstance(ast, MalList): - return MalList([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalVector): - return MalVector([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalHash_map): - new_dict = {} # type: Dict[str, MalExpression] - for key in ast.native(): - new_dict[key] = EVAL(ast.native()[key], env) - return MalHash_map(new_dict) - return ast - - -def qq_loop(acc: MalList, elt: MalExpression) -> MalList: - if isinstance(elt, MalList): - lst = elt.native() - if len(lst) == 2: - fst = lst[0] - if isinstance(fst, MalSymbol) and fst.native() == u"splice-unquote": - return MalList([MalSymbol(u"concat"), lst[1], acc]) - return MalList([MalSymbol(u"cons"), quasiquote(elt), acc]) - -def qq_foldr(xs: List[MalExpression]) -> MalList: - return functools.reduce(qq_loop, reversed(xs), MalList([])) - -def quasiquote(ast: MalExpression) -> MalExpression: - if isinstance(ast, MalList): - lst = ast.native() - if len(lst) == 2: - fst = lst[0] - if isinstance(fst, MalSymbol) and fst.native() == u'unquote': - return lst[1] - return qq_foldr(lst) - elif isinstance(ast, MalVector): - return MalList([MalSymbol("vec"), qq_foldr(ast.native())]) - elif isinstance(ast, MalSymbol) or isinstance(ast, MalHash_map): - return MalList([MalSymbol("quote"), ast]) - else: - return ast - - -def EVAL(ast: MalExpression, env: Env) -> MalExpression: - while True: - ast = macroexpand(ast, env) - ast_native = ast.native() - if not isinstance(ast, MalList): - return eval_ast(ast, env) - elif len(ast_native) == 0: - return ast - - first_str = str(ast_native[0]) - if first_str == "macroexpand": - return macroexpand(ast.native()[1], env) - elif first_str == "def!": - name: str = str(ast_native[1]) - value: MalExpression = EVAL(ast_native[2], env) - return env.set(name, value) - if first_str == "defmacro!": - name = str(ast_native[1]) - value = EVAL(ast_native[2], env) - assert isinstance(value, MalFunctionCompiled) or isinstance( - value, MalFunctionRaw - ) - value.make_macro() - return env.set(name, value) - elif first_str == "let*": - assert len(ast_native) == 3 - let_env = Env(env) - bindings: MalExpression = ast_native[1] - assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) - bindings_list: List[MalExpression] = bindings.native() - assert len(bindings_list) % 2 == 0 - for i in range(0, len(bindings_list), 2): - assert isinstance(bindings_list[i], MalSymbol) - assert isinstance(bindings_list[i + 1], MalExpression) - let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) - env = let_env - ast = ast_native[2] - continue - elif first_str == "do": - for x in range(1, len(ast_native) - 1): - EVAL(ast_native[x], env) - ast = ast_native[len(ast_native) - 1] - continue - elif first_str == "if": - condition = EVAL(ast_native[1], env) - - if isinstance(condition, MalNil) or ( - isinstance(condition, MalBoolean) and condition.native() is False - ): - if len(ast_native) >= 4: - ast = ast_native[3] - continue - else: - return MalNil() - else: - ast = ast_native[2] - continue - elif first_str == "fn*": - raw_ast = ast_native[2] - raw_params = ast_native[1] - - def fn(args: List[MalExpression]) -> MalExpression: - f_ast = raw_ast - f_env = Env(outer=env, binds=raw_params.native(), exprs=args) - return EVAL(f_ast, f_env) - - return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) - elif first_str == "quote": - return ( - MalList(ast_native[1].native()) - if isinstance(ast_native[1], MalVector) - else ast_native[1] - ) - elif first_str == "quasiquoteexpand": - return quasiquote(ast_native[1]) - elif first_str == "quasiquote": - ast = quasiquote(ast_native[1]) - continue - else: - evaled_ast = eval_ast(ast, env) - f = evaled_ast.native()[0] - args = evaled_ast.native()[1:] - if isinstance(f, MalFunctionRaw): - ast = f.ast() - - env = Env( - outer=f.env(), - binds=f.params().native(), - exprs=evaled_ast.native()[1:], - ) - continue - elif isinstance(f, MalFunctionCompiled): - return f.call(args) - else: - raise MalInvalidArgumentException(f, "not a function") - - -def PRINT(x: MalExpression) -> str: - return str(x) - - -def rep(x: str, env: Env) -> str: - return PRINT(EVAL(READ(x), env)) - - -def init_repl_env() -> Env: - def eval_func(args: List[MalExpression], env: Env) -> MalExpression: - a0 = args[0] - assert isinstance(a0, MalExpression) - return EVAL(a0, env) - - def swap(args: List[MalExpression], env: Env) -> MalExpression: - atom = args[0] - assert isinstance(atom, MalAtom) - func = args[1] - atom.reset(EVAL(MalList([func, atom.native()] + args[2:]), env)) - return atom.native() - - repl_env = Env(None) - for key in core.ns: - repl_env.set(key, core.ns[key]) - - repl_env.set("eval", MalFunctionCompiled(lambda args: eval_func(args, repl_env))) - - rep( - '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))', - repl_env, - ) - mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) - repl_env.set("*ARGV*", mal_argv) - - 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)))))))", - repl_env, - ) - - return repl_env - - -def is_macro_call(ast: MalExpression, env: Env) -> bool: - try: - x = env.get(ast.native()[0].native()) - try: - assert isinstance(x, MalFunctionRaw) or isinstance(x, MalFunctionCompiled) - except AssertionError: - return False - return x.is_macro() # type: ignore - except TypeError: - return False - except MalUnknownSymbolException: - return False - except AttributeError: - return False - except IndexError: - return False - - -def macroexpand(ast: MalExpression, env: Env) -> MalExpression: - while True: - if not is_macro_call(ast, env): - return ast - assert isinstance(ast, MalList) - macro_func = env.get(ast.native()[0].native()) - assert isinstance(macro_func, MalFunctionRaw) or isinstance( - macro_func, MalFunctionCompiled - ) - ast = macro_func.call(ast.native()[1:]) - continue - - -if __name__ == "__main__": - # repl loop - eof: bool = False - repl_env = init_repl_env() - - if len(sys.argv) >= 2: - file_str = sys.argv[1] - rep('(load-file "' + file_str + '")', repl_env) - exit(0) - - while not eof: - try: - line = input("user> ") - readline.add_history(line) - try: - print(rep(line, repl_env)) - except MalUnknownSymbolException as e: - print("'" + e.func + "' not found") - except MalSyntaxException as e: - print("ERROR: invalid syntax: " + str(e)) - except MalException as e: - print("ERROR: " + str(e)) - - except EOFError: - eof = True +import functools +import readline +import sys +from typing import List, Dict + +import core +import reader +from env import Env +from mal_types import MalExpression, MalSymbol +from mal_types import ( + MalList, + MalNil, + MalBoolean, + MalFunctionCompiled, + MalFunctionRaw, + MalAtom, + MalVector, + MalHash_map, +) +from mal_types import ( + MalUnknownSymbolException, + MalSyntaxException, + MalInvalidArgumentException, + MalString, + MalException, +) + + +def READ(x: str) -> MalExpression: + return reader.read(x) + + +def eval_ast(ast: MalExpression, env: Env) -> MalExpression: + if isinstance(ast, MalSymbol): + return env.get(ast) + if isinstance(ast, MalList): + return MalList([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalVector): + return MalVector([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalHash_map): + new_dict = {} # type: Dict[str, MalExpression] + for key in ast.native(): + new_dict[key] = EVAL(ast.native()[key], env) + return MalHash_map(new_dict) + return ast + + +def qq_loop(acc: MalList, elt: MalExpression) -> MalList: + if isinstance(elt, MalList): + lst = elt.native() + if len(lst) == 2: + fst = lst[0] + if isinstance(fst, MalSymbol) and fst.native() == u"splice-unquote": + return MalList([MalSymbol(u"concat"), lst[1], acc]) + return MalList([MalSymbol(u"cons"), quasiquote(elt), acc]) + +def qq_foldr(xs: List[MalExpression]) -> MalList: + return functools.reduce(qq_loop, reversed(xs), MalList([])) + +def quasiquote(ast: MalExpression) -> MalExpression: + if isinstance(ast, MalList): + lst = ast.native() + if len(lst) == 2: + fst = lst[0] + if isinstance(fst, MalSymbol) and fst.native() == u'unquote': + return lst[1] + return qq_foldr(lst) + elif isinstance(ast, MalVector): + return MalList([MalSymbol("vec"), qq_foldr(ast.native())]) + elif isinstance(ast, MalSymbol) or isinstance(ast, MalHash_map): + return MalList([MalSymbol("quote"), ast]) + else: + return ast + + +def EVAL(ast: MalExpression, env: Env) -> MalExpression: + while True: + ast = macroexpand(ast, env) + ast_native = ast.native() + if not isinstance(ast, MalList): + return eval_ast(ast, env) + elif len(ast_native) == 0: + return ast + + first_str = str(ast_native[0]) + if first_str == "macroexpand": + return macroexpand(ast.native()[1], env) + elif first_str == "def!": + name: str = str(ast_native[1]) + value: MalExpression = EVAL(ast_native[2], env) + return env.set(name, value) + if first_str == "defmacro!": + name = str(ast_native[1]) + value = EVAL(ast_native[2], env) + assert isinstance(value, MalFunctionCompiled) or isinstance( + value, MalFunctionRaw + ) + value.make_macro() + return env.set(name, value) + elif first_str == "let*": + assert len(ast_native) == 3 + let_env = Env(env) + bindings: MalExpression = ast_native[1] + assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) + bindings_list: List[MalExpression] = bindings.native() + assert len(bindings_list) % 2 == 0 + for i in range(0, len(bindings_list), 2): + assert isinstance(bindings_list[i], MalSymbol) + assert isinstance(bindings_list[i + 1], MalExpression) + let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) + env = let_env + ast = ast_native[2] + continue + elif first_str == "do": + for x in range(1, len(ast_native) - 1): + EVAL(ast_native[x], env) + ast = ast_native[len(ast_native) - 1] + continue + elif first_str == "if": + condition = EVAL(ast_native[1], env) + + if isinstance(condition, MalNil) or ( + isinstance(condition, MalBoolean) and condition.native() is False + ): + if len(ast_native) >= 4: + ast = ast_native[3] + continue + else: + return MalNil() + else: + ast = ast_native[2] + continue + elif first_str == "fn*": + raw_ast = ast_native[2] + raw_params = ast_native[1] + + def fn(args: List[MalExpression]) -> MalExpression: + f_ast = raw_ast + f_env = Env(outer=env, binds=raw_params.native(), exprs=args) + return EVAL(f_ast, f_env) + + return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) + elif first_str == "quote": + return ( + MalList(ast_native[1].native()) + if isinstance(ast_native[1], MalVector) + else ast_native[1] + ) + elif first_str == "quasiquoteexpand": + return quasiquote(ast_native[1]) + elif first_str == "quasiquote": + ast = quasiquote(ast_native[1]) + continue + else: + evaled_ast = eval_ast(ast, env) + f = evaled_ast.native()[0] + args = evaled_ast.native()[1:] + if isinstance(f, MalFunctionRaw): + ast = f.ast() + + env = Env( + outer=f.env(), + binds=f.params().native(), + exprs=evaled_ast.native()[1:], + ) + continue + elif isinstance(f, MalFunctionCompiled): + return f.call(args) + else: + raise MalInvalidArgumentException(f, "not a function") + + +def PRINT(x: MalExpression) -> str: + return str(x) + + +def rep(x: str, env: Env) -> str: + return PRINT(EVAL(READ(x), env)) + + +def init_repl_env() -> Env: + def eval_func(args: List[MalExpression], env: Env) -> MalExpression: + a0 = args[0] + assert isinstance(a0, MalExpression) + return EVAL(a0, env) + + def swap(args: List[MalExpression], env: Env) -> MalExpression: + atom = args[0] + assert isinstance(atom, MalAtom) + func = args[1] + atom.reset(EVAL(MalList([func, atom.native()] + args[2:]), env)) + return atom.native() + + repl_env = Env(None) + for key in core.ns: + repl_env.set(key, core.ns[key]) + + repl_env.set("eval", MalFunctionCompiled(lambda args: eval_func(args, repl_env))) + + rep( + '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))', + repl_env, + ) + mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) + repl_env.set("*ARGV*", mal_argv) + + 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)))))))", + repl_env, + ) + + return repl_env + + +def is_macro_call(ast: MalExpression, env: Env) -> bool: + try: + x = env.get(ast.native()[0].native()) + try: + assert isinstance(x, MalFunctionRaw) or isinstance(x, MalFunctionCompiled) + except AssertionError: + return False + return x.is_macro() # type: ignore + except TypeError: + return False + except MalUnknownSymbolException: + return False + except AttributeError: + return False + except IndexError: + return False + + +def macroexpand(ast: MalExpression, env: Env) -> MalExpression: + while True: + if not is_macro_call(ast, env): + return ast + assert isinstance(ast, MalList) + macro_func = env.get(ast.native()[0].native()) + assert isinstance(macro_func, MalFunctionRaw) or isinstance( + macro_func, MalFunctionCompiled + ) + ast = macro_func.call(ast.native()[1:]) + continue + + +if __name__ == "__main__": + # repl loop + eof: bool = False + repl_env = init_repl_env() + + if len(sys.argv) >= 2: + file_str = sys.argv[1] + rep('(load-file "' + file_str + '")', repl_env) + exit(0) + + while not eof: + try: + line = input("user> ") + readline.add_history(line) + try: + print(rep(line, repl_env)) + except MalUnknownSymbolException as e: + print("'" + e.func + "' not found") + except MalSyntaxException as e: + print("ERROR: invalid syntax: " + str(e)) + except MalException as e: + print("ERROR: " + str(e)) + + except EOFError: + eof = True diff --git a/impls/python.2/step9_try.py b/impls/python.2/step9_try.py index c8ecac23f4..4c2eb2ecb2 100644 --- a/impls/python.2/step9_try.py +++ b/impls/python.2/step9_try.py @@ -1,279 +1,279 @@ -import functools -import readline -import sys -from typing import List, Dict - -import core -import reader -from env import Env -from mal_types import MalExpression, MalSymbol, MalException -from mal_types import ( - MalList, - MalNil, - MalBoolean, - MalFunctionCompiled, - MalFunctionRaw, - MalAtom, - MalVector, - MalHash_map, -) -from mal_types import MalUnknownSymbolException, MalInvalidArgumentException, MalString - - -def READ(x: str) -> MalExpression: - return reader.read(x) - - -def eval_ast(ast: MalExpression, env: Env) -> MalExpression: - if isinstance(ast, MalSymbol): - return env.get(ast) - if isinstance(ast, MalList): - return MalList([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalVector): - return MalVector([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalHash_map): - new_dict = {} # type: Dict[str, MalExpression] - for key in ast.native(): - new_dict[key] = EVAL(ast.native()[key], env) - return MalHash_map(new_dict) - return ast - - -def qq_loop(acc: MalList, elt: MalExpression) -> MalList: - if isinstance(elt, MalList): - lst = elt.native() - if len(lst) == 2: - fst = lst[0] - if isinstance(fst, MalSymbol) and fst.native() == u"splice-unquote": - return MalList([MalSymbol(u"concat"), lst[1], acc]) - return MalList([MalSymbol(u"cons"), quasiquote(elt), acc]) - -def qq_foldr(xs: List[MalExpression]) -> MalList: - return functools.reduce(qq_loop, reversed(xs), MalList([])) - -def quasiquote(ast: MalExpression) -> MalExpression: - if isinstance(ast, MalList): - lst = ast.native() - if len(lst) == 2: - fst = lst[0] - if isinstance(fst, MalSymbol) and fst.native() == u'unquote': - return lst[1] - return qq_foldr(lst) - elif isinstance(ast, MalVector): - return MalList([MalSymbol("vec"), qq_foldr(ast.native())]) - elif isinstance(ast, MalSymbol) or isinstance(ast, MalHash_map): - return MalList([MalSymbol("quote"), ast]) - else: - return ast - - -def EVAL(ast: MalExpression, env: Env) -> MalExpression: - while True: - ast = macroexpand(ast, env) - ast_native = ast.native() - if not isinstance(ast, MalList): - return eval_ast(ast, env) - elif len(ast_native) == 0: - return ast - - first_str = str(ast_native[0]) - if first_str == "macroexpand": - return macroexpand(ast.native()[1], env) - elif first_str == "def!": - name: str = str(ast_native[1]) - value: MalExpression = EVAL(ast_native[2], env) - return env.set(name, value) - if first_str == "defmacro!": - name = str(ast_native[1]) - value = EVAL(ast_native[2], env) - assert isinstance(value, MalFunctionCompiled) or isinstance( - value, MalFunctionRaw - ) - value.make_macro() - return env.set(name, value) - elif first_str == "let*": - assert len(ast_native) == 3 - let_env = Env(env) - bindings: MalExpression = ast_native[1] - assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) - bindings_list: List[MalExpression] = bindings.native() - assert len(bindings_list) % 2 == 0 - for i in range(0, len(bindings_list), 2): - assert isinstance(bindings_list[i], MalSymbol) - assert isinstance(bindings_list[i + 1], MalExpression) - let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) - env = let_env - ast = ast_native[2] - continue - elif first_str == "do": - for x in range(1, len(ast_native) - 1): - EVAL(ast_native[x], env) - ast = ast_native[len(ast_native) - 1] - continue - elif first_str == "if": - condition = EVAL(ast_native[1], env) - - if isinstance(condition, MalNil) or ( - isinstance(condition, MalBoolean) and condition.native() is False - ): - if len(ast_native) >= 4: - ast = ast_native[3] - continue - else: - return MalNil() - else: - ast = ast_native[2] - continue - elif first_str == "fn*": - raw_ast = ast_native[2] - raw_params = ast_native[1] - - def fn(args: List[MalExpression]) -> MalExpression: - f_ast = raw_ast - f_env = Env(outer=env, binds=raw_params.native(), exprs=args) - return EVAL(f_ast, f_env) - - return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) - elif first_str == "quote": - return ( - MalList(ast_native[1].native()) - if isinstance(ast_native[1], MalVector) - else ast_native[1] - ) - elif first_str == "quasiquoteexpand": - return quasiquote(ast_native[1]) - elif first_str == "quasiquote": - ast = quasiquote(ast_native[1]) - continue - elif first_str == "try*": - try: - return EVAL(ast_native[1], env) - except MalException as e: - if len(ast_native) < 3: - raise e - catch_block = ast_native[2] - assert ( - isinstance(catch_block, MalList) - and isinstance(catch_block.native()[0], MalSymbol) - and str(catch_block.native()[0]) == "catch*" - and len(catch_block.native()) == 3 - ) - exception_symbol = catch_block.native()[1] - assert isinstance(exception_symbol, MalSymbol) - env = Env(env) - env.set(str(exception_symbol), e.native()) - ast = catch_block.native()[2] - continue - else: - evaled_ast = eval_ast(ast, env) - f = evaled_ast.native()[0] - args = evaled_ast.native()[1:] - if isinstance(f, MalFunctionRaw): - ast = f.ast() - - env = Env( - outer=f.env(), - binds=f.params().native(), - exprs=evaled_ast.native()[1:], - ) - continue - elif isinstance(f, MalFunctionCompiled): - return f.call(args) - else: - raise MalInvalidArgumentException(f, "not a function") - - -def PRINT(x: MalExpression) -> str: - return str(x) - - -def rep(x: str, env: Env) -> str: - return PRINT(EVAL(READ(x), env)) - - -def init_repl_env() -> Env: - def eval_func(args: List[MalExpression], env: Env) -> MalExpression: - a0 = args[0] - assert isinstance(a0, MalExpression) - return EVAL(a0, env) - - def swap(args: List[MalExpression], env: Env) -> MalExpression: - atom = args[0] - assert isinstance(atom, MalAtom) - func = args[1] - atom.reset(EVAL(MalList([func, atom.native()] + args[2:]), env)) - return atom.native() - - repl_env = Env(None) - for key in core.ns: - repl_env.set(key, core.ns[key]) - - repl_env.set("eval", MalFunctionCompiled(lambda args: eval_func(args, repl_env))) - - rep( - '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))', - repl_env, - ) - - mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) - repl_env.set("*ARGV*", mal_argv) - - 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)))))))", - repl_env, - ) - - return repl_env - - -def is_macro_call(ast: MalExpression, env: Env) -> bool: - try: - x = env.get(ast.native()[0].native()) - try: - assert isinstance(x, MalFunctionRaw) or isinstance(x, MalFunctionCompiled) - except AssertionError: - return False - return x.is_macro() # type: ignore - except (TypeError, MalUnknownSymbolException, AttributeError, IndexError, KeyError): - return False - - -def macroexpand(ast: MalExpression, env: Env) -> MalExpression: - while True: - if not is_macro_call(ast, env): - return ast - assert isinstance(ast, MalList) - macro_func = env.get(ast.native()[0].native()) - assert isinstance(macro_func, MalFunctionRaw) or isinstance( - macro_func, MalFunctionCompiled - ) - ast = macro_func.call(ast.native()[1:]) - continue - - -def rep_handling_exceptions(line: str, repl_env: Env) -> str: - try: - return rep(line, repl_env) - except MalUnknownSymbolException as e: - return "'" + e.func + "' not found" - except MalException as e: - return "ERROR: " + str(e) - - -if __name__ == "__main__": - # repl loop - eof: bool = False - repl_env = init_repl_env() - - if len(sys.argv) >= 2: - file_str = sys.argv[1] - print(rep_handling_exceptions('(load-file "' + file_str + '")', repl_env)) - exit(0) - - while not eof: - try: - line = input("user> ") - readline.add_history(line) - print(rep_handling_exceptions(line, repl_env)) - except EOFError: - eof = True +import functools +import readline +import sys +from typing import List, Dict + +import core +import reader +from env import Env +from mal_types import MalExpression, MalSymbol, MalException +from mal_types import ( + MalList, + MalNil, + MalBoolean, + MalFunctionCompiled, + MalFunctionRaw, + MalAtom, + MalVector, + MalHash_map, +) +from mal_types import MalUnknownSymbolException, MalInvalidArgumentException, MalString + + +def READ(x: str) -> MalExpression: + return reader.read(x) + + +def eval_ast(ast: MalExpression, env: Env) -> MalExpression: + if isinstance(ast, MalSymbol): + return env.get(ast) + if isinstance(ast, MalList): + return MalList([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalVector): + return MalVector([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalHash_map): + new_dict = {} # type: Dict[str, MalExpression] + for key in ast.native(): + new_dict[key] = EVAL(ast.native()[key], env) + return MalHash_map(new_dict) + return ast + + +def qq_loop(acc: MalList, elt: MalExpression) -> MalList: + if isinstance(elt, MalList): + lst = elt.native() + if len(lst) == 2: + fst = lst[0] + if isinstance(fst, MalSymbol) and fst.native() == u"splice-unquote": + return MalList([MalSymbol(u"concat"), lst[1], acc]) + return MalList([MalSymbol(u"cons"), quasiquote(elt), acc]) + +def qq_foldr(xs: List[MalExpression]) -> MalList: + return functools.reduce(qq_loop, reversed(xs), MalList([])) + +def quasiquote(ast: MalExpression) -> MalExpression: + if isinstance(ast, MalList): + lst = ast.native() + if len(lst) == 2: + fst = lst[0] + if isinstance(fst, MalSymbol) and fst.native() == u'unquote': + return lst[1] + return qq_foldr(lst) + elif isinstance(ast, MalVector): + return MalList([MalSymbol("vec"), qq_foldr(ast.native())]) + elif isinstance(ast, MalSymbol) or isinstance(ast, MalHash_map): + return MalList([MalSymbol("quote"), ast]) + else: + return ast + + +def EVAL(ast: MalExpression, env: Env) -> MalExpression: + while True: + ast = macroexpand(ast, env) + ast_native = ast.native() + if not isinstance(ast, MalList): + return eval_ast(ast, env) + elif len(ast_native) == 0: + return ast + + first_str = str(ast_native[0]) + if first_str == "macroexpand": + return macroexpand(ast.native()[1], env) + elif first_str == "def!": + name: str = str(ast_native[1]) + value: MalExpression = EVAL(ast_native[2], env) + return env.set(name, value) + if first_str == "defmacro!": + name = str(ast_native[1]) + value = EVAL(ast_native[2], env) + assert isinstance(value, MalFunctionCompiled) or isinstance( + value, MalFunctionRaw + ) + value.make_macro() + return env.set(name, value) + elif first_str == "let*": + assert len(ast_native) == 3 + let_env = Env(env) + bindings: MalExpression = ast_native[1] + assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) + bindings_list: List[MalExpression] = bindings.native() + assert len(bindings_list) % 2 == 0 + for i in range(0, len(bindings_list), 2): + assert isinstance(bindings_list[i], MalSymbol) + assert isinstance(bindings_list[i + 1], MalExpression) + let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) + env = let_env + ast = ast_native[2] + continue + elif first_str == "do": + for x in range(1, len(ast_native) - 1): + EVAL(ast_native[x], env) + ast = ast_native[len(ast_native) - 1] + continue + elif first_str == "if": + condition = EVAL(ast_native[1], env) + + if isinstance(condition, MalNil) or ( + isinstance(condition, MalBoolean) and condition.native() is False + ): + if len(ast_native) >= 4: + ast = ast_native[3] + continue + else: + return MalNil() + else: + ast = ast_native[2] + continue + elif first_str == "fn*": + raw_ast = ast_native[2] + raw_params = ast_native[1] + + def fn(args: List[MalExpression]) -> MalExpression: + f_ast = raw_ast + f_env = Env(outer=env, binds=raw_params.native(), exprs=args) + return EVAL(f_ast, f_env) + + return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) + elif first_str == "quote": + return ( + MalList(ast_native[1].native()) + if isinstance(ast_native[1], MalVector) + else ast_native[1] + ) + elif first_str == "quasiquoteexpand": + return quasiquote(ast_native[1]) + elif first_str == "quasiquote": + ast = quasiquote(ast_native[1]) + continue + elif first_str == "try*": + try: + return EVAL(ast_native[1], env) + except MalException as e: + if len(ast_native) < 3: + raise e + catch_block = ast_native[2] + assert ( + isinstance(catch_block, MalList) + and isinstance(catch_block.native()[0], MalSymbol) + and str(catch_block.native()[0]) == "catch*" + and len(catch_block.native()) == 3 + ) + exception_symbol = catch_block.native()[1] + assert isinstance(exception_symbol, MalSymbol) + env = Env(env) + env.set(str(exception_symbol), e.native()) + ast = catch_block.native()[2] + continue + else: + evaled_ast = eval_ast(ast, env) + f = evaled_ast.native()[0] + args = evaled_ast.native()[1:] + if isinstance(f, MalFunctionRaw): + ast = f.ast() + + env = Env( + outer=f.env(), + binds=f.params().native(), + exprs=evaled_ast.native()[1:], + ) + continue + elif isinstance(f, MalFunctionCompiled): + return f.call(args) + else: + raise MalInvalidArgumentException(f, "not a function") + + +def PRINT(x: MalExpression) -> str: + return str(x) + + +def rep(x: str, env: Env) -> str: + return PRINT(EVAL(READ(x), env)) + + +def init_repl_env() -> Env: + def eval_func(args: List[MalExpression], env: Env) -> MalExpression: + a0 = args[0] + assert isinstance(a0, MalExpression) + return EVAL(a0, env) + + def swap(args: List[MalExpression], env: Env) -> MalExpression: + atom = args[0] + assert isinstance(atom, MalAtom) + func = args[1] + atom.reset(EVAL(MalList([func, atom.native()] + args[2:]), env)) + return atom.native() + + repl_env = Env(None) + for key in core.ns: + repl_env.set(key, core.ns[key]) + + repl_env.set("eval", MalFunctionCompiled(lambda args: eval_func(args, repl_env))) + + rep( + '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))', + repl_env, + ) + + mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) + repl_env.set("*ARGV*", mal_argv) + + 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)))))))", + repl_env, + ) + + return repl_env + + +def is_macro_call(ast: MalExpression, env: Env) -> bool: + try: + x = env.get(ast.native()[0].native()) + try: + assert isinstance(x, MalFunctionRaw) or isinstance(x, MalFunctionCompiled) + except AssertionError: + return False + return x.is_macro() # type: ignore + except (TypeError, MalUnknownSymbolException, AttributeError, IndexError, KeyError): + return False + + +def macroexpand(ast: MalExpression, env: Env) -> MalExpression: + while True: + if not is_macro_call(ast, env): + return ast + assert isinstance(ast, MalList) + macro_func = env.get(ast.native()[0].native()) + assert isinstance(macro_func, MalFunctionRaw) or isinstance( + macro_func, MalFunctionCompiled + ) + ast = macro_func.call(ast.native()[1:]) + continue + + +def rep_handling_exceptions(line: str, repl_env: Env) -> str: + try: + return rep(line, repl_env) + except MalUnknownSymbolException as e: + return "'" + e.func + "' not found" + except MalException as e: + return "ERROR: " + str(e) + + +if __name__ == "__main__": + # repl loop + eof: bool = False + repl_env = init_repl_env() + + if len(sys.argv) >= 2: + file_str = sys.argv[1] + print(rep_handling_exceptions('(load-file "' + file_str + '")', repl_env)) + exit(0) + + while not eof: + try: + line = input("user> ") + readline.add_history(line) + print(rep_handling_exceptions(line, repl_env)) + except EOFError: + eof = True diff --git a/impls/python.2/stepA_mal.py b/impls/python.2/stepA_mal.py index 0cbb09f4a3..4f46b0a206 100644 --- a/impls/python.2/stepA_mal.py +++ b/impls/python.2/stepA_mal.py @@ -1,287 +1,287 @@ -import functools -import readline -import sys -from typing import List, Dict - -import core -import reader -from env import Env -from mal_types import ( - MalExpression, - MalSymbol, - MalException, - MalList, - MalNil, - MalBoolean, - MalFunctionCompiled, - MalFunctionRaw, - MalVector, - MalHash_map, - MalUnknownSymbolException, - MalInvalidArgumentException, - MalString, -) - - -def READ(x: str) -> MalExpression: - return reader.read(x) - - -def eval_ast(ast: MalExpression, env: Env) -> MalExpression: - if isinstance(ast, MalSymbol): - return env.get(ast) - if isinstance(ast, MalList): - return MalList([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalVector): - return MalVector([EVAL(x, env) for x in ast.native()]) - if isinstance(ast, MalHash_map): - new_dict = {} # type: Dict[str, MalExpression] - for key in ast.native(): - new_dict[key] = EVAL(ast.native()[key], env) - return MalHash_map(new_dict) - return ast - - -def qq_loop(acc: MalList, elt: MalExpression) -> MalList: - if isinstance(elt, MalList): - lst = elt.native() - if len(lst) == 2: - fst = lst[0] - if isinstance(fst, MalSymbol) and fst.native() == u"splice-unquote": - return MalList([MalSymbol(u"concat"), lst[1], acc]) - return MalList([MalSymbol(u"cons"), quasiquote(elt), acc]) - -def qq_foldr(xs: List[MalExpression]) -> MalList: - return functools.reduce(qq_loop, reversed(xs), MalList([])) - -def quasiquote(ast: MalExpression) -> MalExpression: - if isinstance(ast, MalList): - lst = ast.native() - if len(lst) == 2: - fst = lst[0] - if isinstance(fst, MalSymbol) and fst.native() == u'unquote': - return lst[1] - return qq_foldr(lst) - elif isinstance(ast, MalVector): - return MalList([MalSymbol("vec"), qq_foldr(ast.native())]) - elif isinstance(ast, MalSymbol) or isinstance(ast, MalHash_map): - return MalList([MalSymbol("quote"), ast]) - else: - return ast - - -def EVAL(ast: MalExpression, env: Env) -> MalExpression: - while True: - # print("EVAL: " + str(ast)) - ast = macroexpand(ast, env) - ast_native = ast.native() - if not isinstance(ast, MalList): - return eval_ast(ast, env) - elif len(ast_native) == 0: - return ast - - first_str = str(ast_native[0]) - if first_str == "macroexpand": - return macroexpand(ast.native()[1], env) - elif first_str == "def!": - name: str = str(ast_native[1]) - value: MalExpression = EVAL(ast_native[2], env) - return env.set(name, value) - if first_str == "defmacro!": - name = str(ast_native[1]) - value = EVAL(ast_native[2], env) - assert isinstance(value, MalFunctionCompiled) or isinstance( - value, MalFunctionRaw - ) - value.make_macro() - return env.set(name, value) - elif first_str == "let*": - assert len(ast_native) == 3 - let_env = Env(env) - bindings: MalExpression = ast_native[1] - assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) - bindings_list: List[MalExpression] = bindings.native() - assert len(bindings_list) % 2 == 0 - for i in range(0, len(bindings_list), 2): - assert isinstance(bindings_list[i], MalSymbol) - assert isinstance(bindings_list[i + 1], MalExpression) - let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) - env = let_env - ast = ast_native[2] - continue - elif first_str == "do": - for x in range(1, len(ast_native) - 1): - EVAL(ast_native[x], env) - ast = ast_native[len(ast_native) - 1] - continue - elif first_str == "if": - condition = EVAL(ast_native[1], env) - - if isinstance(condition, MalNil) or ( - isinstance(condition, MalBoolean) and condition.native() is False - ): - if len(ast_native) >= 4: - ast = ast_native[3] - continue - else: - return MalNil() - else: - ast = ast_native[2] - continue - elif first_str == "fn*": - raw_ast = ast_native[2] - raw_params = ast_native[1] - - def fn(args: List[MalExpression]) -> MalExpression: - f_ast = raw_ast - f_env = Env(outer=env, binds=raw_params.native(), exprs=args) - return EVAL(f_ast, f_env) - - return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) - elif first_str == "quote": - return ( - MalList(ast_native[1].native()) - if isinstance(ast_native[1], MalVector) - else ast_native[1] - ) - elif first_str == "quasiquoteexpand": - return quasiquote(ast_native[1]) - elif first_str == "quasiquote": - ast = quasiquote(ast_native[1]) - continue - elif first_str == "try*": - try: - return EVAL(ast_native[1], env) - except MalException as e: - if len(ast_native) < 3: - raise e - catch_block = ast_native[2] - assert ( - isinstance(catch_block, MalList) - and isinstance(catch_block.native()[0], MalSymbol) - and str(catch_block.native()[0]) == "catch*" - and len(catch_block.native()) == 3 - ) - exception_symbol = catch_block.native()[1] - assert isinstance(exception_symbol, MalSymbol) - env = Env(env) - env.set(str(exception_symbol), e.native()) - ast = catch_block.native()[2] - continue - else: - evaled_ast = eval_ast(ast, env) - f = evaled_ast.native()[0] - args = evaled_ast.native()[1:] - if isinstance(f, MalFunctionRaw): - ast = f.ast() - - env = Env( - outer=f.env(), - binds=f.params().native(), - exprs=evaled_ast.native()[1:], - ) - continue - elif isinstance(f, MalFunctionCompiled): - return f.call(args) - else: - raise MalInvalidArgumentException(f, "not a function") - - -def PRINT(x: MalExpression) -> str: - return str(x) - - -def rep(x: str, env: Env) -> str: - return PRINT(EVAL(READ(x), env)) - - -def init_repl_env() -> Env: - def eval_func(args: List[MalExpression], env: Env) -> MalExpression: - a0 = args[0] - assert isinstance(a0, MalExpression) - return EVAL(a0, env) - - env = Env(None) - for key in core.ns: - env.set(key, core.ns[key]) - - env.set("eval", MalFunctionCompiled(lambda args: eval_func(args, env))) - rep('(def! *host-language* "python.2")', env) - - rep( - '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))', - env, - ) - - mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) - env.set("*ARGV*", mal_argv) - - 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)))))))", - env, - ) - - return env - - -def is_macro_call(ast: MalExpression, env: Env) -> bool: - try: - x = env.get(ast.native()[0].native()) - try: - assert isinstance(x, MalFunctionRaw) or isinstance(x, MalFunctionCompiled) - except AssertionError: - return False - return x.is_macro() # type: ignore - except TypeError: - return False - except MalUnknownSymbolException: - return False - except AttributeError: - return False - except IndexError: - return False - except KeyError: - return False - - -def macroexpand(ast: MalExpression, env: Env) -> MalExpression: - while True: - if not is_macro_call(ast, env): - return ast - assert isinstance(ast, MalList) - macro_func = env.get(ast.native()[0].native()) - assert isinstance(macro_func, MalFunctionRaw) or isinstance( - macro_func, MalFunctionCompiled - ) - ast = macro_func.call(ast.native()[1:]) - continue - - -def rep_handling_exceptions(line: str, repl_env: Env) -> str: - try: - return rep(line, repl_env) - except MalUnknownSymbolException as e: - return "'" + e.func + "' not found" - except MalException as e: - return "ERROR: " + str(e) - - -if __name__ == "__main__": - # repl loop - eof: bool = False - repl_env = init_repl_env() - - if len(sys.argv) >= 2: - file_str = sys.argv[1] - rep_handling_exceptions('(load-file "' + file_str + '")', repl_env) - exit(0) - - rep('(println (str "Mal [" *host-language* "]"))', repl_env) - - while not eof: - try: - line = input("user> ") - readline.add_history(line) - print(rep_handling_exceptions(line, repl_env)) - except EOFError: - eof = True +import functools +import readline +import sys +from typing import List, Dict + +import core +import reader +from env import Env +from mal_types import ( + MalExpression, + MalSymbol, + MalException, + MalList, + MalNil, + MalBoolean, + MalFunctionCompiled, + MalFunctionRaw, + MalVector, + MalHash_map, + MalUnknownSymbolException, + MalInvalidArgumentException, + MalString, +) + + +def READ(x: str) -> MalExpression: + return reader.read(x) + + +def eval_ast(ast: MalExpression, env: Env) -> MalExpression: + if isinstance(ast, MalSymbol): + return env.get(ast) + if isinstance(ast, MalList): + return MalList([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalVector): + return MalVector([EVAL(x, env) for x in ast.native()]) + if isinstance(ast, MalHash_map): + new_dict = {} # type: Dict[str, MalExpression] + for key in ast.native(): + new_dict[key] = EVAL(ast.native()[key], env) + return MalHash_map(new_dict) + return ast + + +def qq_loop(acc: MalList, elt: MalExpression) -> MalList: + if isinstance(elt, MalList): + lst = elt.native() + if len(lst) == 2: + fst = lst[0] + if isinstance(fst, MalSymbol) and fst.native() == u"splice-unquote": + return MalList([MalSymbol(u"concat"), lst[1], acc]) + return MalList([MalSymbol(u"cons"), quasiquote(elt), acc]) + +def qq_foldr(xs: List[MalExpression]) -> MalList: + return functools.reduce(qq_loop, reversed(xs), MalList([])) + +def quasiquote(ast: MalExpression) -> MalExpression: + if isinstance(ast, MalList): + lst = ast.native() + if len(lst) == 2: + fst = lst[0] + if isinstance(fst, MalSymbol) and fst.native() == u'unquote': + return lst[1] + return qq_foldr(lst) + elif isinstance(ast, MalVector): + return MalList([MalSymbol("vec"), qq_foldr(ast.native())]) + elif isinstance(ast, MalSymbol) or isinstance(ast, MalHash_map): + return MalList([MalSymbol("quote"), ast]) + else: + return ast + + +def EVAL(ast: MalExpression, env: Env) -> MalExpression: + while True: + # print("EVAL: " + str(ast)) + ast = macroexpand(ast, env) + ast_native = ast.native() + if not isinstance(ast, MalList): + return eval_ast(ast, env) + elif len(ast_native) == 0: + return ast + + first_str = str(ast_native[0]) + if first_str == "macroexpand": + return macroexpand(ast.native()[1], env) + elif first_str == "def!": + name: str = str(ast_native[1]) + value: MalExpression = EVAL(ast_native[2], env) + return env.set(name, value) + if first_str == "defmacro!": + name = str(ast_native[1]) + value = EVAL(ast_native[2], env) + assert isinstance(value, MalFunctionCompiled) or isinstance( + value, MalFunctionRaw + ) + value.make_macro() + return env.set(name, value) + elif first_str == "let*": + assert len(ast_native) == 3 + let_env = Env(env) + bindings: MalExpression = ast_native[1] + assert isinstance(bindings, MalList) or isinstance(bindings, MalVector) + bindings_list: List[MalExpression] = bindings.native() + assert len(bindings_list) % 2 == 0 + for i in range(0, len(bindings_list), 2): + assert isinstance(bindings_list[i], MalSymbol) + assert isinstance(bindings_list[i + 1], MalExpression) + let_env.set(str(bindings_list[i]), EVAL(bindings_list[i + 1], let_env)) + env = let_env + ast = ast_native[2] + continue + elif first_str == "do": + for x in range(1, len(ast_native) - 1): + EVAL(ast_native[x], env) + ast = ast_native[len(ast_native) - 1] + continue + elif first_str == "if": + condition = EVAL(ast_native[1], env) + + if isinstance(condition, MalNil) or ( + isinstance(condition, MalBoolean) and condition.native() is False + ): + if len(ast_native) >= 4: + ast = ast_native[3] + continue + else: + return MalNil() + else: + ast = ast_native[2] + continue + elif first_str == "fn*": + raw_ast = ast_native[2] + raw_params = ast_native[1] + + def fn(args: List[MalExpression]) -> MalExpression: + f_ast = raw_ast + f_env = Env(outer=env, binds=raw_params.native(), exprs=args) + return EVAL(f_ast, f_env) + + return MalFunctionRaw(fn=fn, ast=raw_ast, params=raw_params, env=env) + elif first_str == "quote": + return ( + MalList(ast_native[1].native()) + if isinstance(ast_native[1], MalVector) + else ast_native[1] + ) + elif first_str == "quasiquoteexpand": + return quasiquote(ast_native[1]) + elif first_str == "quasiquote": + ast = quasiquote(ast_native[1]) + continue + elif first_str == "try*": + try: + return EVAL(ast_native[1], env) + except MalException as e: + if len(ast_native) < 3: + raise e + catch_block = ast_native[2] + assert ( + isinstance(catch_block, MalList) + and isinstance(catch_block.native()[0], MalSymbol) + and str(catch_block.native()[0]) == "catch*" + and len(catch_block.native()) == 3 + ) + exception_symbol = catch_block.native()[1] + assert isinstance(exception_symbol, MalSymbol) + env = Env(env) + env.set(str(exception_symbol), e.native()) + ast = catch_block.native()[2] + continue + else: + evaled_ast = eval_ast(ast, env) + f = evaled_ast.native()[0] + args = evaled_ast.native()[1:] + if isinstance(f, MalFunctionRaw): + ast = f.ast() + + env = Env( + outer=f.env(), + binds=f.params().native(), + exprs=evaled_ast.native()[1:], + ) + continue + elif isinstance(f, MalFunctionCompiled): + return f.call(args) + else: + raise MalInvalidArgumentException(f, "not a function") + + +def PRINT(x: MalExpression) -> str: + return str(x) + + +def rep(x: str, env: Env) -> str: + return PRINT(EVAL(READ(x), env)) + + +def init_repl_env() -> Env: + def eval_func(args: List[MalExpression], env: Env) -> MalExpression: + a0 = args[0] + assert isinstance(a0, MalExpression) + return EVAL(a0, env) + + env = Env(None) + for key in core.ns: + env.set(key, core.ns[key]) + + env.set("eval", MalFunctionCompiled(lambda args: eval_func(args, env))) + rep('(def! *host-language* "python.2")', env) + + rep( + '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))', + env, + ) + + mal_argv = MalList([MalString(x) for x in sys.argv[2:]]) + env.set("*ARGV*", mal_argv) + + 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)))))))", + env, + ) + + return env + + +def is_macro_call(ast: MalExpression, env: Env) -> bool: + try: + x = env.get(ast.native()[0].native()) + try: + assert isinstance(x, MalFunctionRaw) or isinstance(x, MalFunctionCompiled) + except AssertionError: + return False + return x.is_macro() # type: ignore + except TypeError: + return False + except MalUnknownSymbolException: + return False + except AttributeError: + return False + except IndexError: + return False + except KeyError: + return False + + +def macroexpand(ast: MalExpression, env: Env) -> MalExpression: + while True: + if not is_macro_call(ast, env): + return ast + assert isinstance(ast, MalList) + macro_func = env.get(ast.native()[0].native()) + assert isinstance(macro_func, MalFunctionRaw) or isinstance( + macro_func, MalFunctionCompiled + ) + ast = macro_func.call(ast.native()[1:]) + continue + + +def rep_handling_exceptions(line: str, repl_env: Env) -> str: + try: + return rep(line, repl_env) + except MalUnknownSymbolException as e: + return "'" + e.func + "' not found" + except MalException as e: + return "ERROR: " + str(e) + + +if __name__ == "__main__": + # repl loop + eof: bool = False + repl_env = init_repl_env() + + if len(sys.argv) >= 2: + file_str = sys.argv[1] + rep_handling_exceptions('(load-file "' + file_str + '")', repl_env) + exit(0) + + rep('(println (str "Mal [" *host-language* "]"))', repl_env) + + while not eof: + try: + line = input("user> ") + readline.add_history(line) + print(rep_handling_exceptions(line, repl_env)) + except EOFError: + eof = True diff --git a/impls/python.2/tests/test_step2.py b/impls/python.2/tests/test_step2.py index 5afc6a4147..dcffcfd048 100644 --- a/impls/python.2/tests/test_step2.py +++ b/impls/python.2/tests/test_step2.py @@ -1,12 +1,12 @@ -import unittest - -import step2_eval - - -class TestStep3(unittest.TestCase): - def test_step3_let_multiple(self): - self.assertEqual('{"a" 15}', step2_eval.rep('{"a" (+ 7 8)} ')) - - -if __name__ == "__main__": - unittest.main() +import unittest + +import step2_eval + + +class TestStep3(unittest.TestCase): + def test_step3_let_multiple(self): + self.assertEqual('{"a" 15}', step2_eval.rep('{"a" (+ 7 8)} ')) + + +if __name__ == "__main__": + unittest.main() diff --git a/impls/python.2/tests/test_step3.py b/impls/python.2/tests/test_step3.py index ca5a709deb..1b217aab29 100644 --- a/impls/python.2/tests/test_step3.py +++ b/impls/python.2/tests/test_step3.py @@ -1,154 +1,154 @@ -import unittest - -import mal_types -import step3_env -from env import Env -from mal_types import MalList, MalInt -from mal_types import MalSymbol -from mal_types import MalUnknownSymbolException, MalInvalidArgumentException - - -class TestStep3(unittest.TestCase): - def test_env_find(self): - e = Env(None) - e.set("key", MalInt(1)) - result = e.find("key") - self.assertTrue(e is result) - - def test_env_find_outer(self): - outer = Env(None) - e = Env(outer) - outer.set("key", MalInt(1)) - result = e.find("key") - self.assertTrue(result is outer) - - def test_env_find_no_key(self): - e = Env(None) - self.assertEqual(None, e.find("key")) - - def test_env_get(self): - env = Env(None) - expression = MalInt(1) - env.set("key", expression) - self.assertTrue(env.get("key") is expression) - - def test_env_get_error(self): - env = Env(None) - try: - env.get("key") - self.fail("Expected an exeception") - except MalUnknownSymbolException: - pass - - def test_MalFunctionCompiled(self): - self.assertEqual( - "3", - str( - mal_types.MalFunctionCompiled( - lambda a: MalInt(a[0].native() + a[1].native()) - ).call([mal_types.MalInt(1), mal_types.MalInt(2)]) - ), - ) - - def test_eval_invalid(self): - with self.assertRaises(MalInvalidArgumentException): - step3_env.EVAL(MalList([MalInt(1), MalInt(2)]), Env(None)) - - def test_eval_1_plus_1(self): - env = Env(None) - env.set( - "+", - mal_types.MalFunctionCompiled( - lambda a: MalInt(a[0].native() + a[1].native()) - ), - ) - self.assertEqual( - 2, - step3_env.EVAL( - MalList([MalSymbol("+"), MalInt(1), MalInt(1)]), env - ).native(), - ) - - def test_def(self): - env = Env(None) - self.assertEqual( - 1, - step3_env.EVAL( - MalList([MalSymbol("def!"), MalSymbol("a"), MalInt(1)]), env - ).native(), - ) - self.assertEqual(1, env.get("a").native()) - - def test_mallist_native(self): - x = MalInt(1) - self.assertEqual([x], MalList([x]).native()) - - def test_let_basic(self): - env = Env(None) - self.assertEqual( - 2, - step3_env.EVAL( - MalList( - [ - MalSymbol("let*"), - MalList([MalSymbol("c"), MalInt(2)]), - MalSymbol("c"), - ] - ), - env, - ).native(), - ) - - def test_let_advanced(self): - env = Env(None) - env.set( - "+", - mal_types.MalFunctionCompiled( - lambda a: MalInt(a[0].native() + a[1].native()) - ), - ) - self.assertEqual( - 4, - step3_env.EVAL( - MalList( - [ - MalSymbol("let*"), - MalList([MalSymbol("c"), MalInt(2)]), - MalList([MalSymbol("+"), MalSymbol("c"), MalInt(2)]), - ] - ), - env, - ).native(), - ) - - def test_let_multiple(self): - env = Env(None) - env.set( - "+", - mal_types.MalFunctionCompiled( - lambda a: MalInt(a[0].native() + a[1].native()) - ), - ) - self.assertEqual( - 5, - step3_env.EVAL( - MalList( - [ - MalSymbol("let*"), - MalList([MalSymbol("c"), MalInt(2), MalSymbol("d"), MalInt(3)]), - MalList([MalSymbol("+"), MalSymbol("c"), MalSymbol("d")]), - ] - ), - env, - ).native(), - ) - - def test_step3_let_multiple(self): - self.assertEqual("5", step3_env.rep("(let* (c 2 d 3) (+ c d))")) - - def test_step3_let_nested_backref(self): - self.assertEqual("6", step3_env.rep("(let* (c 2 d c) (+ c (+ d 2)))")) - - -if __name__ == "__main__": - unittest.main() +import unittest + +import mal_types +import step3_env +from env import Env +from mal_types import MalList, MalInt +from mal_types import MalSymbol +from mal_types import MalUnknownSymbolException, MalInvalidArgumentException + + +class TestStep3(unittest.TestCase): + def test_env_find(self): + e = Env(None) + e.set("key", MalInt(1)) + result = e.find("key") + self.assertTrue(e is result) + + def test_env_find_outer(self): + outer = Env(None) + e = Env(outer) + outer.set("key", MalInt(1)) + result = e.find("key") + self.assertTrue(result is outer) + + def test_env_find_no_key(self): + e = Env(None) + self.assertEqual(None, e.find("key")) + + def test_env_get(self): + env = Env(None) + expression = MalInt(1) + env.set("key", expression) + self.assertTrue(env.get("key") is expression) + + def test_env_get_error(self): + env = Env(None) + try: + env.get("key") + self.fail("Expected an exeception") + except MalUnknownSymbolException: + pass + + def test_MalFunctionCompiled(self): + self.assertEqual( + "3", + str( + mal_types.MalFunctionCompiled( + lambda a: MalInt(a[0].native() + a[1].native()) + ).call([mal_types.MalInt(1), mal_types.MalInt(2)]) + ), + ) + + def test_eval_invalid(self): + with self.assertRaises(MalInvalidArgumentException): + step3_env.EVAL(MalList([MalInt(1), MalInt(2)]), Env(None)) + + def test_eval_1_plus_1(self): + env = Env(None) + env.set( + "+", + mal_types.MalFunctionCompiled( + lambda a: MalInt(a[0].native() + a[1].native()) + ), + ) + self.assertEqual( + 2, + step3_env.EVAL( + MalList([MalSymbol("+"), MalInt(1), MalInt(1)]), env + ).native(), + ) + + def test_def(self): + env = Env(None) + self.assertEqual( + 1, + step3_env.EVAL( + MalList([MalSymbol("def!"), MalSymbol("a"), MalInt(1)]), env + ).native(), + ) + self.assertEqual(1, env.get("a").native()) + + def test_mallist_native(self): + x = MalInt(1) + self.assertEqual([x], MalList([x]).native()) + + def test_let_basic(self): + env = Env(None) + self.assertEqual( + 2, + step3_env.EVAL( + MalList( + [ + MalSymbol("let*"), + MalList([MalSymbol("c"), MalInt(2)]), + MalSymbol("c"), + ] + ), + env, + ).native(), + ) + + def test_let_advanced(self): + env = Env(None) + env.set( + "+", + mal_types.MalFunctionCompiled( + lambda a: MalInt(a[0].native() + a[1].native()) + ), + ) + self.assertEqual( + 4, + step3_env.EVAL( + MalList( + [ + MalSymbol("let*"), + MalList([MalSymbol("c"), MalInt(2)]), + MalList([MalSymbol("+"), MalSymbol("c"), MalInt(2)]), + ] + ), + env, + ).native(), + ) + + def test_let_multiple(self): + env = Env(None) + env.set( + "+", + mal_types.MalFunctionCompiled( + lambda a: MalInt(a[0].native() + a[1].native()) + ), + ) + self.assertEqual( + 5, + step3_env.EVAL( + MalList( + [ + MalSymbol("let*"), + MalList([MalSymbol("c"), MalInt(2), MalSymbol("d"), MalInt(3)]), + MalList([MalSymbol("+"), MalSymbol("c"), MalSymbol("d")]), + ] + ), + env, + ).native(), + ) + + def test_step3_let_multiple(self): + self.assertEqual("5", step3_env.rep("(let* (c 2 d 3) (+ c d))")) + + def test_step3_let_nested_backref(self): + self.assertEqual("6", step3_env.rep("(let* (c 2 d c) (+ c (+ d 2)))")) + + +if __name__ == "__main__": + unittest.main() diff --git a/impls/python.2/tests/test_step4.py b/impls/python.2/tests/test_step4.py index 800f5598d1..7ef339e417 100644 --- a/impls/python.2/tests/test_step4.py +++ b/impls/python.2/tests/test_step4.py @@ -1,212 +1,212 @@ -import unittest - -import step4_if_fn_do -from env import Env -from mal_types import MalInvalidArgumentException -from mal_types import MalList, MalInt, MalFunctionCompiled, MalBoolean -from mal_types import MalSymbol - - -class TestStep4(unittest.TestCase): - def test_step4_nil(self): - self.assertEqual("nil", step4_if_fn_do.rep("nil")) - - def test_step4_boolean(self): - self.assertEqual("true", step4_if_fn_do.rep("true")) - self.assertEqual("false", step4_if_fn_do.rep("false")) - - def test_print_function(self): - self.assertEqual("#", str(MalFunctionCompiled(lambda x: MalInt(0)))) - - def test_if_basic_true(self): - env = Env(None) - self.assertEqual( - 4321, - step4_if_fn_do.EVAL( - MalList( - [MalSymbol("if"), MalBoolean(True), MalInt(4321), MalInt(1234)] - ), - env, - ).native(), - ) - - def test_if_basic_false(self): - env = Env(None) - self.assertEqual( - 1234, - step4_if_fn_do.EVAL( - MalList( - [MalSymbol("if"), MalBoolean(False), MalInt(4321), MalInt(1234)] - ), - env, - ).native(), - ) - - def test_if_basic_false_no_fourth_arg(self): - env = Env(None) - self.assertEqual( - "nil", - str( - step4_if_fn_do.EVAL( - MalList([MalSymbol("if"), MalBoolean(False), MalInt(4321)]), env - ) - ), - ) - - def test_env_constructor_binds(self): - env = Env(outer=None, binds=[MalSymbol("a")], exprs=[MalInt(3)]) - self.assertEqual(3, env.get("a").native()) - - def test_env_constructor_binds_multiple(self): - env = Env( - outer=None, - binds=[MalSymbol("a"), MalSymbol("b")], - exprs=[MalInt(44), MalInt(32)], - ) - self.assertEqual(44, env.get("a").native()) - self.assertEqual(32, env.get("b").native()) - - def test_step4_do(self): - self.assertEqual("44", step4_if_fn_do.rep("(do 1 2 3 44)")) - self.assertEqual("21", step4_if_fn_do.rep("(do 21)")) - - def test_step4_fn(self): - self.assertEqual("#", step4_if_fn_do.rep("(fn* (a) 0)")) - - def test_step4_use_fn(self): - self.assertEqual("7", step4_if_fn_do.rep("((fn* (a) a) 7)")) - - def test_step4_use_fn_multiple(self): - self.assertEqual("8", step4_if_fn_do.rep("((fn* (a b) a) 8 9)")) - - def test_step4_use_fn_multiple_nested(self): - self.assertEqual("10", step4_if_fn_do.rep("((fn* (a b) (+ a (+ b 1))) 4 5)")) - - def test_step4_use_fn_func_param(self): - self.assertEqual( - "8", step4_if_fn_do.rep("((fn* (f x) (f x)) (fn* (a) (+ 1 a)) 7)") - ) - - def test_step4_prn(self): - self.assertEqual("nil", step4_if_fn_do.rep("(prn 4)")) - - def test_step4_list(self): - self.assertEqual("(1 2 (3 4) 5)", step4_if_fn_do.rep("(list 1 2 (list 3 4) 5)")) - - def test_step4_listP(self): - self.assertEqual("true", step4_if_fn_do.rep("(list? (list 1 2))")) - self.assertEqual("false", step4_if_fn_do.rep("(list? 4)")) - - def test_step4_empty(self): - self.assertEqual("true", step4_if_fn_do.rep("(empty? (list))")) - - def test_step4_count(self): - self.assertEqual("0", step4_if_fn_do.rep("(count (list))")) - self.assertEqual("2", step4_if_fn_do.rep("(count (list 1 2))")) - self.assertEqual("0", step4_if_fn_do.rep("(count nil)")) - - def test_step4_equal(self): - self.assertEqual("true", step4_if_fn_do.rep("(= 0 0)")) - self.assertEqual("true", step4_if_fn_do.rep("(= (list 1) (list 1))")) - self.assertEqual("false", step4_if_fn_do.rep("(= (list 1) (list 1 2))")) - self.assertEqual( - "true", - step4_if_fn_do.rep("(= (list (list 1) (list 2)) (list (list 1) (list 2)))"), - ) - self.assertEqual("true", step4_if_fn_do.rep("(= nil nil)")) - - def test_step4_less(self): - self.assertEqual("true", step4_if_fn_do.rep("(< 1 2)")) - self.assertEqual("false", step4_if_fn_do.rep("(< 2 1)")) - self.assertEqual("false", step4_if_fn_do.rep("(< 1 1)")) - try: - step4_if_fn_do.rep("(< 1 nil)") - self.fail("Expected exception") - except MalInvalidArgumentException: - pass - try: - step4_if_fn_do.rep("(< nil 1)") - self.fail("Expected exception") - except MalInvalidArgumentException: - pass - - def test_step4_less_equal(self): - self.assertEqual("true", step4_if_fn_do.rep("(<= 1 2)")) - self.assertEqual("false", step4_if_fn_do.rep("(<= 2 1)")) - self.assertEqual("true", step4_if_fn_do.rep("(<= 1 1)")) - try: - step4_if_fn_do.rep("(<= 1 nil)") - self.fail("Expected exception") - except MalInvalidArgumentException: - pass - try: - step4_if_fn_do.rep("(<= nil 1)") - self.fail("Expected exception") - except MalInvalidArgumentException: - pass - - def test_step4_more(self): - self.assertEqual("false", step4_if_fn_do.rep("(> 1 2)")) - self.assertEqual("true", step4_if_fn_do.rep("(> 2 1)")) - self.assertEqual("false", step4_if_fn_do.rep("(> 1 1)")) - try: - step4_if_fn_do.rep("(> 1 nil)") - self.fail("Expected exception") - except MalInvalidArgumentException: - pass - try: - step4_if_fn_do.rep("(> nil 1)") - self.fail("Expected exception") - except MalInvalidArgumentException: - pass - - def test_step4_more_equal(self): - self.assertEqual("false", step4_if_fn_do.rep("(>= 1 2)")) - self.assertEqual("true", step4_if_fn_do.rep("(>= 2 1)")) - self.assertEqual("true", step4_if_fn_do.rep("(>= 1 1)")) - try: - step4_if_fn_do.rep("(>= 1 nil)") - self.fail("Expected exception") - except MalInvalidArgumentException: - pass - try: - step4_if_fn_do.rep("(>= nil 1)") - self.fail("Expected exception") - except MalInvalidArgumentException: - pass - - def test_step4_closures(self): - self.assertEqual( - "12", step4_if_fn_do.rep("(( (fn* (a) (fn* (b) (+ a b))) 5) 7)") - ) - self.assertEqual( - "#", - step4_if_fn_do.rep("(def! gen-plus5 (fn* () (fn* (b) (+ 5 b))))"), - ) - self.assertEqual( - "#", - step4_if_fn_do.rep("(def! gen-plus5 (fn* () (fn* (b) (+ 5 b))))"), - ) - self.assertEqual("#", step4_if_fn_do.rep("(def! plus5 (gen-plus5))")) - self.assertEqual("12", step4_if_fn_do.rep("(plus5 7)")) - - def test_step4_variadic_a(self): - self.assertEqual( - "3", step4_if_fn_do.rep("( (fn* (& more) (count more)) 1 2 3)") - ) - - def test_step4_variadic_b(self): - self.assertEqual("0", step4_if_fn_do.rep("((fn* (& more) (count more)))")) - - def test_step4_quoted_string(self): - self.assertEqual('"\\""', step4_if_fn_do.rep('"\\""')) - - def test_step4_str(self): - self.assertEqual('"(1 a 2 3)"', step4_if_fn_do.rep('(str (list 1 "a" 2 3))')) - - def test_step4_equal_vector_list(self): - self.assertEqual("true", step4_if_fn_do.rep("(=[] (list))")) - - -if __name__ == "__main__": - unittest.main() +import unittest + +import step4_if_fn_do +from env import Env +from mal_types import MalInvalidArgumentException +from mal_types import MalList, MalInt, MalFunctionCompiled, MalBoolean +from mal_types import MalSymbol + + +class TestStep4(unittest.TestCase): + def test_step4_nil(self): + self.assertEqual("nil", step4_if_fn_do.rep("nil")) + + def test_step4_boolean(self): + self.assertEqual("true", step4_if_fn_do.rep("true")) + self.assertEqual("false", step4_if_fn_do.rep("false")) + + def test_print_function(self): + self.assertEqual("#", str(MalFunctionCompiled(lambda x: MalInt(0)))) + + def test_if_basic_true(self): + env = Env(None) + self.assertEqual( + 4321, + step4_if_fn_do.EVAL( + MalList( + [MalSymbol("if"), MalBoolean(True), MalInt(4321), MalInt(1234)] + ), + env, + ).native(), + ) + + def test_if_basic_false(self): + env = Env(None) + self.assertEqual( + 1234, + step4_if_fn_do.EVAL( + MalList( + [MalSymbol("if"), MalBoolean(False), MalInt(4321), MalInt(1234)] + ), + env, + ).native(), + ) + + def test_if_basic_false_no_fourth_arg(self): + env = Env(None) + self.assertEqual( + "nil", + str( + step4_if_fn_do.EVAL( + MalList([MalSymbol("if"), MalBoolean(False), MalInt(4321)]), env + ) + ), + ) + + def test_env_constructor_binds(self): + env = Env(outer=None, binds=[MalSymbol("a")], exprs=[MalInt(3)]) + self.assertEqual(3, env.get("a").native()) + + def test_env_constructor_binds_multiple(self): + env = Env( + outer=None, + binds=[MalSymbol("a"), MalSymbol("b")], + exprs=[MalInt(44), MalInt(32)], + ) + self.assertEqual(44, env.get("a").native()) + self.assertEqual(32, env.get("b").native()) + + def test_step4_do(self): + self.assertEqual("44", step4_if_fn_do.rep("(do 1 2 3 44)")) + self.assertEqual("21", step4_if_fn_do.rep("(do 21)")) + + def test_step4_fn(self): + self.assertEqual("#", step4_if_fn_do.rep("(fn* (a) 0)")) + + def test_step4_use_fn(self): + self.assertEqual("7", step4_if_fn_do.rep("((fn* (a) a) 7)")) + + def test_step4_use_fn_multiple(self): + self.assertEqual("8", step4_if_fn_do.rep("((fn* (a b) a) 8 9)")) + + def test_step4_use_fn_multiple_nested(self): + self.assertEqual("10", step4_if_fn_do.rep("((fn* (a b) (+ a (+ b 1))) 4 5)")) + + def test_step4_use_fn_func_param(self): + self.assertEqual( + "8", step4_if_fn_do.rep("((fn* (f x) (f x)) (fn* (a) (+ 1 a)) 7)") + ) + + def test_step4_prn(self): + self.assertEqual("nil", step4_if_fn_do.rep("(prn 4)")) + + def test_step4_list(self): + self.assertEqual("(1 2 (3 4) 5)", step4_if_fn_do.rep("(list 1 2 (list 3 4) 5)")) + + def test_step4_listP(self): + self.assertEqual("true", step4_if_fn_do.rep("(list? (list 1 2))")) + self.assertEqual("false", step4_if_fn_do.rep("(list? 4)")) + + def test_step4_empty(self): + self.assertEqual("true", step4_if_fn_do.rep("(empty? (list))")) + + def test_step4_count(self): + self.assertEqual("0", step4_if_fn_do.rep("(count (list))")) + self.assertEqual("2", step4_if_fn_do.rep("(count (list 1 2))")) + self.assertEqual("0", step4_if_fn_do.rep("(count nil)")) + + def test_step4_equal(self): + self.assertEqual("true", step4_if_fn_do.rep("(= 0 0)")) + self.assertEqual("true", step4_if_fn_do.rep("(= (list 1) (list 1))")) + self.assertEqual("false", step4_if_fn_do.rep("(= (list 1) (list 1 2))")) + self.assertEqual( + "true", + step4_if_fn_do.rep("(= (list (list 1) (list 2)) (list (list 1) (list 2)))"), + ) + self.assertEqual("true", step4_if_fn_do.rep("(= nil nil)")) + + def test_step4_less(self): + self.assertEqual("true", step4_if_fn_do.rep("(< 1 2)")) + self.assertEqual("false", step4_if_fn_do.rep("(< 2 1)")) + self.assertEqual("false", step4_if_fn_do.rep("(< 1 1)")) + try: + step4_if_fn_do.rep("(< 1 nil)") + self.fail("Expected exception") + except MalInvalidArgumentException: + pass + try: + step4_if_fn_do.rep("(< nil 1)") + self.fail("Expected exception") + except MalInvalidArgumentException: + pass + + def test_step4_less_equal(self): + self.assertEqual("true", step4_if_fn_do.rep("(<= 1 2)")) + self.assertEqual("false", step4_if_fn_do.rep("(<= 2 1)")) + self.assertEqual("true", step4_if_fn_do.rep("(<= 1 1)")) + try: + step4_if_fn_do.rep("(<= 1 nil)") + self.fail("Expected exception") + except MalInvalidArgumentException: + pass + try: + step4_if_fn_do.rep("(<= nil 1)") + self.fail("Expected exception") + except MalInvalidArgumentException: + pass + + def test_step4_more(self): + self.assertEqual("false", step4_if_fn_do.rep("(> 1 2)")) + self.assertEqual("true", step4_if_fn_do.rep("(> 2 1)")) + self.assertEqual("false", step4_if_fn_do.rep("(> 1 1)")) + try: + step4_if_fn_do.rep("(> 1 nil)") + self.fail("Expected exception") + except MalInvalidArgumentException: + pass + try: + step4_if_fn_do.rep("(> nil 1)") + self.fail("Expected exception") + except MalInvalidArgumentException: + pass + + def test_step4_more_equal(self): + self.assertEqual("false", step4_if_fn_do.rep("(>= 1 2)")) + self.assertEqual("true", step4_if_fn_do.rep("(>= 2 1)")) + self.assertEqual("true", step4_if_fn_do.rep("(>= 1 1)")) + try: + step4_if_fn_do.rep("(>= 1 nil)") + self.fail("Expected exception") + except MalInvalidArgumentException: + pass + try: + step4_if_fn_do.rep("(>= nil 1)") + self.fail("Expected exception") + except MalInvalidArgumentException: + pass + + def test_step4_closures(self): + self.assertEqual( + "12", step4_if_fn_do.rep("(( (fn* (a) (fn* (b) (+ a b))) 5) 7)") + ) + self.assertEqual( + "#", + step4_if_fn_do.rep("(def! gen-plus5 (fn* () (fn* (b) (+ 5 b))))"), + ) + self.assertEqual( + "#", + step4_if_fn_do.rep("(def! gen-plus5 (fn* () (fn* (b) (+ 5 b))))"), + ) + self.assertEqual("#", step4_if_fn_do.rep("(def! plus5 (gen-plus5))")) + self.assertEqual("12", step4_if_fn_do.rep("(plus5 7)")) + + def test_step4_variadic_a(self): + self.assertEqual( + "3", step4_if_fn_do.rep("( (fn* (& more) (count more)) 1 2 3)") + ) + + def test_step4_variadic_b(self): + self.assertEqual("0", step4_if_fn_do.rep("((fn* (& more) (count more)))")) + + def test_step4_quoted_string(self): + self.assertEqual('"\\""', step4_if_fn_do.rep('"\\""')) + + def test_step4_str(self): + self.assertEqual('"(1 a 2 3)"', step4_if_fn_do.rep('(str (list 1 "a" 2 3))')) + + def test_step4_equal_vector_list(self): + self.assertEqual("true", step4_if_fn_do.rep("(=[] (list))")) + + +if __name__ == "__main__": + unittest.main() diff --git a/impls/python.2/tests/test_step5.py b/impls/python.2/tests/test_step5.py index 214cd150ab..94a492dc15 100644 --- a/impls/python.2/tests/test_step5.py +++ b/impls/python.2/tests/test_step5.py @@ -1,21 +1,21 @@ -import unittest - -import step5_tco - - -class TestStep5(unittest.TestCase): - def test_step5_tco(self): - self.assertEqual( - "#", - step5_tco.rep( - "(def! sum2 (fn* (n acc) (if (= n 0) acc (sum2 (- n 1) (+ n acc)))))" - ), - ) - self.assertEqual("55", step5_tco.rep("(sum2 10 0)")) - self.assertEqual("nil", step5_tco.rep("(def! res2 nil)")) - self.assertEqual("500500", step5_tco.rep("(def! res2 (sum2 1000 0))")) - self.assertEqual("500500", step5_tco.rep("res2")) - - -if __name__ == "__main__": - unittest.main() +import unittest + +import step5_tco + + +class TestStep5(unittest.TestCase): + def test_step5_tco(self): + self.assertEqual( + "#", + step5_tco.rep( + "(def! sum2 (fn* (n acc) (if (= n 0) acc (sum2 (- n 1) (+ n acc)))))" + ), + ) + self.assertEqual("55", step5_tco.rep("(sum2 10 0)")) + self.assertEqual("nil", step5_tco.rep("(def! res2 nil)")) + self.assertEqual("500500", step5_tco.rep("(def! res2 (sum2 1000 0))")) + self.assertEqual("500500", step5_tco.rep("res2")) + + +if __name__ == "__main__": + unittest.main() diff --git a/impls/python.2/tests/test_step6.py b/impls/python.2/tests/test_step6.py index 8a6425adfb..9b088d2504 100644 --- a/impls/python.2/tests/test_step6.py +++ b/impls/python.2/tests/test_step6.py @@ -1,72 +1,72 @@ -import unittest - -import reader -import step6_file -from env import Env -from mal_types import MalList, MalAtom, MalInt -from mal_types import MalSyntaxException, MalString - - -class TestStep6(unittest.TestCase): - def test_step6_string_unbalanced(self): - with self.assertRaises(MalSyntaxException): - step6_file.rep('"foo') - - def test_step6_standard_string(self): - self.assertEqual( - '"foo"', step6_file.EVAL(MalString('"foo"'), Env(None)).native() - ) - self.assertEqual('"foo"', step6_file.rep('"foo"').__str__()) - self.assertEqual('"foo"', MalString('"foo"').native()) - self.assertEqual('"\\"foo\\""', MalString('"foo"').__str__()) - - def test_step6_reader_read_string(self): - read = reader.read('(read-string "(1 2 (3 4) nil)")') - self.assertTrue(isinstance(read, MalList)) - arg = read.native()[1] - self.assertTrue(isinstance(arg, MalString)) - native_str = arg.native() - self.assertEqual("(1 2 (3 4) nil)", native_str) - - def test_step6_read_string_no_escapes(self): - self.assertEqual( - "(1 2 (3 4) nil)", step6_file.rep('(read-string "(1 2 (3 4) nil)")') - ) - - def test_step6_slurp(self): - self.assertEqual( - '"A line of text\\n"', step6_file.rep('(slurp "../../tests/test.txt")') - ) - - def test_step6_eval(self): - self.assertEqual("2", step6_file.rep('(eval (read-string "(+ 1 1)"))')) - - def test_step6_str(self): - self.assertEqual('"abc2def ghi"', step6_file.rep('(str "abc" 2 "def" " ghi")')) - - def test_step6_atom_type(self): - atom = step6_file.EVAL(MalAtom(MalInt(1)), Env(None)) - self.assertEqual(1, atom.native().native()) - - def test_step6_read_atom(self): - atom = step6_file.EVAL(step6_file.READ("(atom 1)"), step6_file.repl_env) - self.assertEqual(1, atom.native().native()) - - def test_step6_atom_deref(self): - self.assertEqual("1", step6_file.rep("(deref (atom 1))")) - - def test_step6_atom_p(self): - self.assertEqual("true", step6_file.rep("(atom? (atom 1))")) - self.assertEqual("false", step6_file.rep("(atom? (+ 1 2))")) - - def test_step6_reset(self): - self.assertEqual("3", step6_file.rep("(do (def! a (atom 2)) (reset! a 3))")) - - def test_step6_swap(self): - self.assertEqual("#", step6_file.rep("(def! inc3 (fn* (a) (+ 3 a)))")) - self.assertEqual("(atom 2)", step6_file.rep("(def! a (atom 2))")) - self.assertEqual("3", step6_file.rep("(swap! a + 1)")) - - -if __name__ == "__main__": - unittest.main() +import unittest + +import reader +import step6_file +from env import Env +from mal_types import MalList, MalAtom, MalInt +from mal_types import MalSyntaxException, MalString + + +class TestStep6(unittest.TestCase): + def test_step6_string_unbalanced(self): + with self.assertRaises(MalSyntaxException): + step6_file.rep('"foo') + + def test_step6_standard_string(self): + self.assertEqual( + '"foo"', step6_file.EVAL(MalString('"foo"'), Env(None)).native() + ) + self.assertEqual('"foo"', step6_file.rep('"foo"').__str__()) + self.assertEqual('"foo"', MalString('"foo"').native()) + self.assertEqual('"\\"foo\\""', MalString('"foo"').__str__()) + + def test_step6_reader_read_string(self): + read = reader.read('(read-string "(1 2 (3 4) nil)")') + self.assertTrue(isinstance(read, MalList)) + arg = read.native()[1] + self.assertTrue(isinstance(arg, MalString)) + native_str = arg.native() + self.assertEqual("(1 2 (3 4) nil)", native_str) + + def test_step6_read_string_no_escapes(self): + self.assertEqual( + "(1 2 (3 4) nil)", step6_file.rep('(read-string "(1 2 (3 4) nil)")') + ) + + def test_step6_slurp(self): + self.assertEqual( + '"A line of text\\n"', step6_file.rep('(slurp "../../tests/test.txt")') + ) + + def test_step6_eval(self): + self.assertEqual("2", step6_file.rep('(eval (read-string "(+ 1 1)"))')) + + def test_step6_str(self): + self.assertEqual('"abc2def ghi"', step6_file.rep('(str "abc" 2 "def" " ghi")')) + + def test_step6_atom_type(self): + atom = step6_file.EVAL(MalAtom(MalInt(1)), Env(None)) + self.assertEqual(1, atom.native().native()) + + def test_step6_read_atom(self): + atom = step6_file.EVAL(step6_file.READ("(atom 1)"), step6_file.repl_env) + self.assertEqual(1, atom.native().native()) + + def test_step6_atom_deref(self): + self.assertEqual("1", step6_file.rep("(deref (atom 1))")) + + def test_step6_atom_p(self): + self.assertEqual("true", step6_file.rep("(atom? (atom 1))")) + self.assertEqual("false", step6_file.rep("(atom? (+ 1 2))")) + + def test_step6_reset(self): + self.assertEqual("3", step6_file.rep("(do (def! a (atom 2)) (reset! a 3))")) + + def test_step6_swap(self): + self.assertEqual("#", step6_file.rep("(def! inc3 (fn* (a) (+ 3 a)))")) + self.assertEqual("(atom 2)", step6_file.rep("(def! a (atom 2))")) + self.assertEqual("3", step6_file.rep("(swap! a + 1)")) + + +if __name__ == "__main__": + unittest.main() diff --git a/impls/python.2/tests/test_step7.py b/impls/python.2/tests/test_step7.py index 192916a225..be9da86553 100644 --- a/impls/python.2/tests/test_step7.py +++ b/impls/python.2/tests/test_step7.py @@ -1,27 +1,27 @@ -import unittest - -import step7_quote - - -class TestStep7(unittest.TestCase): - def test_step7_cons(self): - self.assertEqual("(1)", step7_quote.rep("(cons 1 (list))")) - - def test_step7_concat(self): - self.assertEqual("()", step7_quote.rep("(concat)")) - - def test_step7_quote(self): - self.assertEqual("(+ 1 2)", step7_quote.rep("(quote (+ 1 2))")) - - def test_step7_quasiquote(self): - self.assertEqual( - "(+ 1 3)", step7_quote.rep("(quasiquote (+ 1 (unquote (+ 1 2))))") - ) - - def test_step7_quasiquote_advanced(self): - self.assertEqual("(2)", step7_quote.rep("(def! c '(2))")) - self.assertEqual("(1 2 3)", step7_quote.rep("`[1 ~@c 3]")) - - -if __name__ == "__main__": - unittest.main() +import unittest + +import step7_quote + + +class TestStep7(unittest.TestCase): + def test_step7_cons(self): + self.assertEqual("(1)", step7_quote.rep("(cons 1 (list))")) + + def test_step7_concat(self): + self.assertEqual("()", step7_quote.rep("(concat)")) + + def test_step7_quote(self): + self.assertEqual("(+ 1 2)", step7_quote.rep("(quote (+ 1 2))")) + + def test_step7_quasiquote(self): + self.assertEqual( + "(+ 1 3)", step7_quote.rep("(quasiquote (+ 1 (unquote (+ 1 2))))") + ) + + def test_step7_quasiquote_advanced(self): + self.assertEqual("(2)", step7_quote.rep("(def! c '(2))")) + self.assertEqual("(1 2 3)", step7_quote.rep("`[1 ~@c 3]")) + + +if __name__ == "__main__": + unittest.main() diff --git a/impls/python.2/tests/test_step8.py b/impls/python.2/tests/test_step8.py index 7bddaf4b82..b31dacffd3 100644 --- a/impls/python.2/tests/test_step8.py +++ b/impls/python.2/tests/test_step8.py @@ -1,100 +1,100 @@ -import unittest - -import core -import step8_macros -from env import Env -from mal_types import MalFunctionCompiled, MalInt, MalFunctionRaw, MalList -from mal_types import MalInvalidArgumentException, MalIndexError - - -class TestStep8(unittest.TestCase): - def setUp(self) -> None: - self._repl_env = step8_macros.init_repl_env() - - def rep(self, input: str) -> str: - return step8_macros.rep(input, self._repl_env) - - def test_step8_is_macro(self): - self.assertEqual(False, MalFunctionCompiled(lambda a: MalInt(1)).is_macro()) - self.assertEqual( - False, - MalFunctionRaw(core.ns["+"], MalInt(1), MalList([]), Env(None)).is_macro(), - ) - - def test_step8_defmacro(self): - self.assertEqual("#", self.rep("(defmacro! one (fn* () 1))")) - - def test_step8_quote_reader_macro(self): - self.assertEqual("(+ 1 2)", self.rep("'(+ 1 2)")) - - def test_step8_quasiquote_unquote_reader_macros(self): - self.assertEqual("(+ 1 3)", self.rep("`(+ 1 ~(+ 1 2))")) - - def test_step8_repl_env_isolation(self): - env1 = step8_macros.init_repl_env() - step8_macros.rep("(def! a 2)", env1) - env2 = step8_macros.init_repl_env() - step8_macros.rep("(def! a 3)", env2) - self.assertEqual("2", step8_macros.rep("a", env1)) - self.assertEqual("3", step8_macros.rep("a", env2)) - self.assertEqual("6", step8_macros.rep("(eval (list + a 3))", env2)) - - def test_step8_is_macro_call(self): - self.rep("(defmacro! macro (fn* () 1))") - self.rep("(def! func (fn* () 1))") - self.rep("(def! q 4)") - macro = step8_macros.READ("(macro)") - func = step8_macros.READ("(func)") - other1 = step8_macros.READ("(x)") - other2 = step8_macros.READ("(1)") - other3 = step8_macros.READ("(2)") - other4 = step8_macros.READ("(q)") - self.assertTrue(step8_macros.is_macro_call(macro, self._repl_env)) - self.assertFalse(step8_macros.is_macro_call(func, self._repl_env)) - self.assertFalse(step8_macros.is_macro_call(other1, self._repl_env)) - self.assertFalse(step8_macros.is_macro_call(other2, self._repl_env)) - self.assertFalse(step8_macros.is_macro_call(other3, self._repl_env)) - self.assertFalse(step8_macros.is_macro_call(other4, self._repl_env)) - - def test_step8_macroexpand(self): - self.rep("(def! func (fn* () 1))") - func = step8_macros.READ("(func)") - self.assertEqual("(func)", str(step8_macros.macroexpand(func, self._repl_env))) - self.rep("(defmacro! macro (fn* () 1))") - macro = step8_macros.READ("(macro)") - self.assertEqual("1", str(step8_macros.macroexpand(macro, self._repl_env))) - self.rep("(defmacro! unless (fn* (pred a b) `(if ~pred ~b ~a)))") - self.assertEqual("(if true 7 8)", self.rep("(macroexpand (unless true 8 7))")) - - def test_step8_not(self): - self.assertEqual("true", self.rep("(not (not true))")) - self.assertEqual("true", self.rep("(not nil)")) - self.assertEqual("false", self.rep("(not 1)")) - self.assertEqual("true", self.rep("(not false)")) - - def test_step8_let(self): - self.assertEqual("2", self.rep("(let* (a 1 b 2) b)")) - - def test_step8_first(self): - self.assertEqual("2", self.rep("(first (list 2 3 4))")) - self.assertEqual("nil", self.rep("(first (list))")) - self.assertEqual("nil", self.rep("(first nil)")) - with self.assertRaises(MalInvalidArgumentException): - self.rep("(first 1)") - - def test_step8_rest(self): - self.assertEqual("(2 3)", self.rep("(rest (list 1 2 3))")) - self.assertEqual("()", self.rep("(rest (list))")) - self.assertEqual("()", self.rep("(rest nil)")) - with self.assertRaises(MalInvalidArgumentException): - self.rep("(rest 1)") - - def test_step8_nth(self): - self.assertEqual("3", self.rep("(nth '(1 2 3) 2)")) - - with self.assertRaises(MalIndexError): - self.rep("(nth () 1)") - - -if __name__ == "__main__": - unittest.main() +import unittest + +import core +import step8_macros +from env import Env +from mal_types import MalFunctionCompiled, MalInt, MalFunctionRaw, MalList +from mal_types import MalInvalidArgumentException, MalIndexError + + +class TestStep8(unittest.TestCase): + def setUp(self) -> None: + self._repl_env = step8_macros.init_repl_env() + + def rep(self, input: str) -> str: + return step8_macros.rep(input, self._repl_env) + + def test_step8_is_macro(self): + self.assertEqual(False, MalFunctionCompiled(lambda a: MalInt(1)).is_macro()) + self.assertEqual( + False, + MalFunctionRaw(core.ns["+"], MalInt(1), MalList([]), Env(None)).is_macro(), + ) + + def test_step8_defmacro(self): + self.assertEqual("#", self.rep("(defmacro! one (fn* () 1))")) + + def test_step8_quote_reader_macro(self): + self.assertEqual("(+ 1 2)", self.rep("'(+ 1 2)")) + + def test_step8_quasiquote_unquote_reader_macros(self): + self.assertEqual("(+ 1 3)", self.rep("`(+ 1 ~(+ 1 2))")) + + def test_step8_repl_env_isolation(self): + env1 = step8_macros.init_repl_env() + step8_macros.rep("(def! a 2)", env1) + env2 = step8_macros.init_repl_env() + step8_macros.rep("(def! a 3)", env2) + self.assertEqual("2", step8_macros.rep("a", env1)) + self.assertEqual("3", step8_macros.rep("a", env2)) + self.assertEqual("6", step8_macros.rep("(eval (list + a 3))", env2)) + + def test_step8_is_macro_call(self): + self.rep("(defmacro! macro (fn* () 1))") + self.rep("(def! func (fn* () 1))") + self.rep("(def! q 4)") + macro = step8_macros.READ("(macro)") + func = step8_macros.READ("(func)") + other1 = step8_macros.READ("(x)") + other2 = step8_macros.READ("(1)") + other3 = step8_macros.READ("(2)") + other4 = step8_macros.READ("(q)") + self.assertTrue(step8_macros.is_macro_call(macro, self._repl_env)) + self.assertFalse(step8_macros.is_macro_call(func, self._repl_env)) + self.assertFalse(step8_macros.is_macro_call(other1, self._repl_env)) + self.assertFalse(step8_macros.is_macro_call(other2, self._repl_env)) + self.assertFalse(step8_macros.is_macro_call(other3, self._repl_env)) + self.assertFalse(step8_macros.is_macro_call(other4, self._repl_env)) + + def test_step8_macroexpand(self): + self.rep("(def! func (fn* () 1))") + func = step8_macros.READ("(func)") + self.assertEqual("(func)", str(step8_macros.macroexpand(func, self._repl_env))) + self.rep("(defmacro! macro (fn* () 1))") + macro = step8_macros.READ("(macro)") + self.assertEqual("1", str(step8_macros.macroexpand(macro, self._repl_env))) + self.rep("(defmacro! unless (fn* (pred a b) `(if ~pred ~b ~a)))") + self.assertEqual("(if true 7 8)", self.rep("(macroexpand (unless true 8 7))")) + + def test_step8_not(self): + self.assertEqual("true", self.rep("(not (not true))")) + self.assertEqual("true", self.rep("(not nil)")) + self.assertEqual("false", self.rep("(not 1)")) + self.assertEqual("true", self.rep("(not false)")) + + def test_step8_let(self): + self.assertEqual("2", self.rep("(let* (a 1 b 2) b)")) + + def test_step8_first(self): + self.assertEqual("2", self.rep("(first (list 2 3 4))")) + self.assertEqual("nil", self.rep("(first (list))")) + self.assertEqual("nil", self.rep("(first nil)")) + with self.assertRaises(MalInvalidArgumentException): + self.rep("(first 1)") + + def test_step8_rest(self): + self.assertEqual("(2 3)", self.rep("(rest (list 1 2 3))")) + self.assertEqual("()", self.rep("(rest (list))")) + self.assertEqual("()", self.rep("(rest nil)")) + with self.assertRaises(MalInvalidArgumentException): + self.rep("(rest 1)") + + def test_step8_nth(self): + self.assertEqual("3", self.rep("(nth '(1 2 3) 2)")) + + with self.assertRaises(MalIndexError): + self.rep("(nth () 1)") + + +if __name__ == "__main__": + unittest.main() diff --git a/impls/python.2/tests/test_step9.py b/impls/python.2/tests/test_step9.py index b216c85594..96d5a30081 100644 --- a/impls/python.2/tests/test_step9.py +++ b/impls/python.2/tests/test_step9.py @@ -1,143 +1,143 @@ -import unittest - -import step9_try -from mal_types import MalException, MalIndexError, MalInvalidArgumentException - - -class TestStep9(unittest.TestCase): - def setUp(self) -> None: - self._repl_env = step9_try.init_repl_env() - - def rep(self, input: str) -> str: - return step9_try.rep(input, self._repl_env) - - def test_step9_throw(self): - with self.assertRaises(MalException): - self.assertEqual("foo", self.rep('(throw "err1")')) - - def test_step9_try_catch(self): - self.assertEqual("123", self.rep("(try* 123 (catch* e 456))")) - self.assertEqual( - "nil", self.rep('(try* (abc 1 2) (catch* exc (prn "exc is:" exc)))') - ) - - def test_step9_nth(self): - self.assertEqual("3", self.rep("(nth '(1 2 3) 2)")) - - with self.assertRaises(MalIndexError): - self.rep("(nth () 1)") - - def test_step9_apply(self): - self.assertEqual("(1 1)", self.rep("(apply list '(1 1))")) - self.assertEqual("(1 2 1 2)", self.rep("(apply list 1 2 '(1 2))")) - - def test_step9_map(self): - self.assertEqual("((1) (2))", self.rep("(map list '(1 2))")) - - def test_step9_symbol_q(self): - self.assertEqual("true", self.rep("(symbol? 'x)")) - self.assertEqual("false", self.rep("(symbol? nil)")) - - def test_step9_nil(self): - self.assertEqual("true", self.rep("(nil? nil)")) - self.assertEqual("false", self.rep("(nil? 1)")) - - def test_step9_true(self): - self.assertEqual("true", self.rep("(true? true)")) - self.assertEqual("false", self.rep("(true? false)")) - self.assertEqual("false", self.rep("(true? nil)")) - self.assertEqual("false", self.rep("(true? 1)")) - - def test_step9_false(self): - self.assertEqual("true", self.rep("(false? false)")) - self.assertEqual("false", self.rep("(false? true)")) - self.assertEqual("false", self.rep("(false? nil)")) - self.assertEqual("false", self.rep("(false? 1)")) - - def test_step9_throw_hash_map(self): - with self.assertRaises(MalException): - self.rep('(throw {:msg "err2"})') - - def test_step9_symbol(self): - self.assertEqual("abc", self.rep('(symbol "abc")')) - - def test_step9_complex_apply(self): - self.assertEqual("9", self.rep("(apply + 4 [5])")) - - def test_step9_get(self): - self.assertEqual("nil", self.rep('(get nil "a")')) - self.assertEqual("nil", self.rep('(get (hash-map) "a")')) - - def test_step9_complex_str(self): - self.assertEqual('"A{:abc val}Z"', self.rep('(str "A" {:abc "val"} "Z")')) - - def test_step9_sequential_q(self): - self.assertEqual("true", self.rep("(sequential? (list 1 2 3))")) - self.assertEqual("true", self.rep("(sequential? ())")) - self.assertEqual("false", self.rep("(sequential? nil)")) - self.assertEqual("false", self.rep("(sequential? 1)")) - self.assertEqual("true", self.rep("(sequential? [1 2 3])")) - self.assertEqual("true", self.rep("(sequential? [])")) - self.assertEqual("false", self.rep("(sequential? {})")) - - def test_step9_vector(self): - self.assertEqual("[1 2 3]", self.rep("(vector 1 2 3)")) - self.assertEqual("[]", self.rep("(vector)")) - self.assertEqual("[[1 2]]", self.rep("(vector [1 2])")) - self.assertEqual("[nil]", self.rep("(vector nil)")) - - def test_step9_hash_map(self): - self.assertEqual("{}", self.rep("(hash-map)")) - self.assertEqual('{"a" 1}', self.rep('(hash-map "a" 1)')) - self.assertEqual('{"a" 1 "b" 2}', self.rep('(hash-map "a" 1 "b" 2)')) - - def test_step9_assoc(self): - with self.assertRaises(MalInvalidArgumentException): - self.rep("(assoc)") - self.assertEqual("1", self.rep("(assoc 1)")) - self.assertEqual("nil", self.rep("(assoc nil)")) - self.assertEqual("{}", self.rep("(assoc {})")) - self.assertEqual('{"a" 1}', self.rep('(assoc {} "a" 1)')) - self.assertEqual('{"b" 2 "a" 1}', self.rep('(assoc {"b" 2} "a" 1)')) - self.assertEqual('{"b" 2 "a" 1 "c" 3}', self.rep('(assoc {"b" 2} "a" 1 "c" 3)')) - self.assertEqual('{"b" 3}', self.rep('(assoc {"b" 2} "b" 3)')) - self.assertEqual("{:bcd 234}", self.rep("(assoc {} :bcd 234)")) - - def test_step9_contains_q(self): - with self.assertRaises(MalInvalidArgumentException): - self.rep("(contains?)") - with self.assertRaises(MalInvalidArgumentException): - self.rep("(contains? 1)") - with self.assertRaises(MalInvalidArgumentException): - self.rep("(contains? nil)") - with self.assertRaises(MalInvalidArgumentException): - self.rep("(contains? nil nil)") - self.assertEqual("false", self.rep("(contains? {} nil)")) - self.assertEqual("true", self.rep('(contains? {"a" 1} "a")')) - self.assertEqual("true", self.rep('(contains? {"a" 1 :b 2} :b)')) - - def test_step9_keys(self): - with self.assertRaises(MalInvalidArgumentException): - self.rep("(keys)") - with self.assertRaises(MalInvalidArgumentException): - self.rep("(keys 1)") - self.assertEqual('("a")', self.rep('(keys {"a" 1})')) - self.assertEqual('("a" :b)', self.rep('(keys {"a" 1 :b 2})')) - - def test_step9_vals(self): - with self.assertRaises(MalInvalidArgumentException): - self.rep("(vals)") - with self.assertRaises(MalInvalidArgumentException): - self.rep("(vals 1)") - self.assertEqual("(1)", self.rep('(vals {"a" 1})')) - self.assertEqual("(1 2)", self.rep('(vals {"a" 1 :b 2})')) - - def test_step9_dissoc(self): - self.assertEqual('{"c" 3}', self.rep('(dissoc {"a" 1 "b" 2 "c" 3} "a" "b")')) - self.assertEqual( - '{"c" 3}', self.rep('(dissoc {"a" 1 "b" 2 "c" 3} "a" "b" "d")') - ) - - -if __name__ == "__main__": - unittest.main() +import unittest + +import step9_try +from mal_types import MalException, MalIndexError, MalInvalidArgumentException + + +class TestStep9(unittest.TestCase): + def setUp(self) -> None: + self._repl_env = step9_try.init_repl_env() + + def rep(self, input: str) -> str: + return step9_try.rep(input, self._repl_env) + + def test_step9_throw(self): + with self.assertRaises(MalException): + self.assertEqual("foo", self.rep('(throw "err1")')) + + def test_step9_try_catch(self): + self.assertEqual("123", self.rep("(try* 123 (catch* e 456))")) + self.assertEqual( + "nil", self.rep('(try* (abc 1 2) (catch* exc (prn "exc is:" exc)))') + ) + + def test_step9_nth(self): + self.assertEqual("3", self.rep("(nth '(1 2 3) 2)")) + + with self.assertRaises(MalIndexError): + self.rep("(nth () 1)") + + def test_step9_apply(self): + self.assertEqual("(1 1)", self.rep("(apply list '(1 1))")) + self.assertEqual("(1 2 1 2)", self.rep("(apply list 1 2 '(1 2))")) + + def test_step9_map(self): + self.assertEqual("((1) (2))", self.rep("(map list '(1 2))")) + + def test_step9_symbol_q(self): + self.assertEqual("true", self.rep("(symbol? 'x)")) + self.assertEqual("false", self.rep("(symbol? nil)")) + + def test_step9_nil(self): + self.assertEqual("true", self.rep("(nil? nil)")) + self.assertEqual("false", self.rep("(nil? 1)")) + + def test_step9_true(self): + self.assertEqual("true", self.rep("(true? true)")) + self.assertEqual("false", self.rep("(true? false)")) + self.assertEqual("false", self.rep("(true? nil)")) + self.assertEqual("false", self.rep("(true? 1)")) + + def test_step9_false(self): + self.assertEqual("true", self.rep("(false? false)")) + self.assertEqual("false", self.rep("(false? true)")) + self.assertEqual("false", self.rep("(false? nil)")) + self.assertEqual("false", self.rep("(false? 1)")) + + def test_step9_throw_hash_map(self): + with self.assertRaises(MalException): + self.rep('(throw {:msg "err2"})') + + def test_step9_symbol(self): + self.assertEqual("abc", self.rep('(symbol "abc")')) + + def test_step9_complex_apply(self): + self.assertEqual("9", self.rep("(apply + 4 [5])")) + + def test_step9_get(self): + self.assertEqual("nil", self.rep('(get nil "a")')) + self.assertEqual("nil", self.rep('(get (hash-map) "a")')) + + def test_step9_complex_str(self): + self.assertEqual('"A{:abc val}Z"', self.rep('(str "A" {:abc "val"} "Z")')) + + def test_step9_sequential_q(self): + self.assertEqual("true", self.rep("(sequential? (list 1 2 3))")) + self.assertEqual("true", self.rep("(sequential? ())")) + self.assertEqual("false", self.rep("(sequential? nil)")) + self.assertEqual("false", self.rep("(sequential? 1)")) + self.assertEqual("true", self.rep("(sequential? [1 2 3])")) + self.assertEqual("true", self.rep("(sequential? [])")) + self.assertEqual("false", self.rep("(sequential? {})")) + + def test_step9_vector(self): + self.assertEqual("[1 2 3]", self.rep("(vector 1 2 3)")) + self.assertEqual("[]", self.rep("(vector)")) + self.assertEqual("[[1 2]]", self.rep("(vector [1 2])")) + self.assertEqual("[nil]", self.rep("(vector nil)")) + + def test_step9_hash_map(self): + self.assertEqual("{}", self.rep("(hash-map)")) + self.assertEqual('{"a" 1}', self.rep('(hash-map "a" 1)')) + self.assertEqual('{"a" 1 "b" 2}', self.rep('(hash-map "a" 1 "b" 2)')) + + def test_step9_assoc(self): + with self.assertRaises(MalInvalidArgumentException): + self.rep("(assoc)") + self.assertEqual("1", self.rep("(assoc 1)")) + self.assertEqual("nil", self.rep("(assoc nil)")) + self.assertEqual("{}", self.rep("(assoc {})")) + self.assertEqual('{"a" 1}', self.rep('(assoc {} "a" 1)')) + self.assertEqual('{"b" 2 "a" 1}', self.rep('(assoc {"b" 2} "a" 1)')) + self.assertEqual('{"b" 2 "a" 1 "c" 3}', self.rep('(assoc {"b" 2} "a" 1 "c" 3)')) + self.assertEqual('{"b" 3}', self.rep('(assoc {"b" 2} "b" 3)')) + self.assertEqual("{:bcd 234}", self.rep("(assoc {} :bcd 234)")) + + def test_step9_contains_q(self): + with self.assertRaises(MalInvalidArgumentException): + self.rep("(contains?)") + with self.assertRaises(MalInvalidArgumentException): + self.rep("(contains? 1)") + with self.assertRaises(MalInvalidArgumentException): + self.rep("(contains? nil)") + with self.assertRaises(MalInvalidArgumentException): + self.rep("(contains? nil nil)") + self.assertEqual("false", self.rep("(contains? {} nil)")) + self.assertEqual("true", self.rep('(contains? {"a" 1} "a")')) + self.assertEqual("true", self.rep('(contains? {"a" 1 :b 2} :b)')) + + def test_step9_keys(self): + with self.assertRaises(MalInvalidArgumentException): + self.rep("(keys)") + with self.assertRaises(MalInvalidArgumentException): + self.rep("(keys 1)") + self.assertEqual('("a")', self.rep('(keys {"a" 1})')) + self.assertEqual('("a" :b)', self.rep('(keys {"a" 1 :b 2})')) + + def test_step9_vals(self): + with self.assertRaises(MalInvalidArgumentException): + self.rep("(vals)") + with self.assertRaises(MalInvalidArgumentException): + self.rep("(vals 1)") + self.assertEqual("(1)", self.rep('(vals {"a" 1})')) + self.assertEqual("(1 2)", self.rep('(vals {"a" 1 :b 2})')) + + def test_step9_dissoc(self): + self.assertEqual('{"c" 3}', self.rep('(dissoc {"a" 1 "b" 2 "c" 3} "a" "b")')) + self.assertEqual( + '{"c" 3}', self.rep('(dissoc {"a" 1 "b" 2 "c" 3} "a" "b" "d")') + ) + + +if __name__ == "__main__": + unittest.main() diff --git a/impls/python.2/tests/test_stepA.py b/impls/python.2/tests/test_stepA.py index 8f67cda115..d611ca807f 100644 --- a/impls/python.2/tests/test_stepA.py +++ b/impls/python.2/tests/test_stepA.py @@ -1,67 +1,67 @@ -import unittest - -import stepA_mal - - -class TestStepA(unittest.TestCase): - def setUp(self) -> None: - self._repl_env = stepA_mal.init_repl_env() - - def rep(self, input: str) -> str: - return stepA_mal.rep(input, self._repl_env) - - def test_stepA_host_language(self): - self.assertEqual('"python.2"', self.rep("*host-language*")) - - def test_stepA_eval_vector(self): - self.assertEqual("[1 2 3]", self.rep("[1 2 (+ 1 2)]")) - - def test_reader_multiple_lines(self): - self.assertEqual("3", self.rep("(do\n1\n2\n3\n)")) - - def test_read_string_multiple_lines(self): - self.assertEqual( - "(do 2 nil)", - self.rep('(read-string (str "(do \n" ";; read\n" "2\n" "\n nil)"))'), - ) - - def test_read_hash_map(self): - self.assertEqual("{}", self.rep("{}")) - self.assertEqual('{"a" 1}', self.rep('{"a" 1}')) - self.assertEqual('{"1" 2 "3" 4}', self.rep('{"1" 2 "3" 4}')) - - def test_get(self): - self.assertEqual("1", self.rep('(get {"+" 1} "+")')) - - def test_keyword(self): - self.assertEqual(":keyword", self.rep(":keyword")) - - def test_deref_reader_macro(self): - self.assertEqual("1", self.rep("@(atom 1)")) - - def test_splice_unquote_reader_macro(self): - self.assertEqual("(splice-unquote (1 2 3))", str(stepA_mal.READ("~@(1 2 3)"))) - - def test_swap_assoc_get(self): - self.assertEqual( - '(atom {"+" #})', self.rep('(def! e (atom {"+" +}))') - ) - self.assertEqual( - '{"+" # "-" #}', self.rep('(swap! e assoc "-" -)') - ) - self.assertEqual("15", self.rep('( (get @e "+") 7 8)')) - self.assertEqual("3", self.rep('( (get @e "-") 11 8)')) - self.assertEqual( - '{"+" # "-" # "foo" ()}', - self.rep('(swap! e assoc "foo" (list))'), - ) - self.assertEqual("()", self.rep('(get @e "foo")')) - self.assertEqual( - '{"+" # "-" # "foo" () "bar" (1 2 3)}', - self.rep('(swap! e assoc "bar" \'(1 2 3))'), - ) - self.assertEqual("(1 2 3)", self.rep('(get @e "bar")')) - - -if __name__ == "__main__": - unittest.main() +import unittest + +import stepA_mal + + +class TestStepA(unittest.TestCase): + def setUp(self) -> None: + self._repl_env = stepA_mal.init_repl_env() + + def rep(self, input: str) -> str: + return stepA_mal.rep(input, self._repl_env) + + def test_stepA_host_language(self): + self.assertEqual('"python.2"', self.rep("*host-language*")) + + def test_stepA_eval_vector(self): + self.assertEqual("[1 2 3]", self.rep("[1 2 (+ 1 2)]")) + + def test_reader_multiple_lines(self): + self.assertEqual("3", self.rep("(do\n1\n2\n3\n)")) + + def test_read_string_multiple_lines(self): + self.assertEqual( + "(do 2 nil)", + self.rep('(read-string (str "(do \n" ";; read\n" "2\n" "\n nil)"))'), + ) + + def test_read_hash_map(self): + self.assertEqual("{}", self.rep("{}")) + self.assertEqual('{"a" 1}', self.rep('{"a" 1}')) + self.assertEqual('{"1" 2 "3" 4}', self.rep('{"1" 2 "3" 4}')) + + def test_get(self): + self.assertEqual("1", self.rep('(get {"+" 1} "+")')) + + def test_keyword(self): + self.assertEqual(":keyword", self.rep(":keyword")) + + def test_deref_reader_macro(self): + self.assertEqual("1", self.rep("@(atom 1)")) + + def test_splice_unquote_reader_macro(self): + self.assertEqual("(splice-unquote (1 2 3))", str(stepA_mal.READ("~@(1 2 3)"))) + + def test_swap_assoc_get(self): + self.assertEqual( + '(atom {"+" #})', self.rep('(def! e (atom {"+" +}))') + ) + self.assertEqual( + '{"+" # "-" #}', self.rep('(swap! e assoc "-" -)') + ) + self.assertEqual("15", self.rep('( (get @e "+") 7 8)')) + self.assertEqual("3", self.rep('( (get @e "-") 11 8)')) + self.assertEqual( + '{"+" # "-" # "foo" ()}', + self.rep('(swap! e assoc "foo" (list))'), + ) + self.assertEqual("()", self.rep('(get @e "foo")')) + self.assertEqual( + '{"+" # "-" # "foo" () "bar" (1 2 3)}', + self.rep('(swap! e assoc "bar" \'(1 2 3))'), + ) + self.assertEqual("(1 2 3)", self.rep('(get @e "bar")')) + + +if __name__ == "__main__": + unittest.main() diff --git a/impls/python/Dockerfile b/impls/python/Dockerfile index 3e64cc116c..f76963aa6d 100644 --- a/impls/python/Dockerfile +++ b/impls/python/Dockerfile @@ -1,28 +1,28 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Nothing additional needed for python -RUN apt-get -y install python3 - -# For dist packaging -RUN apt-get -y install zip +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Nothing additional needed for python +RUN apt-get -y install python3 + +# For dist packaging +RUN apt-get -y install zip diff --git a/impls/python/Makefile b/impls/python/Makefile index 2403ecd25f..99657e41b7 100644 --- a/impls/python/Makefile +++ b/impls/python/Makefile @@ -1,22 +1,22 @@ -SOURCES_BASE = mal_readline.py mal_types.py reader.py printer.py -SOURCES_LISP = env.py core.py stepA_mal.py -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.pyz mal - -SHELL := bash -mal.pyz: $(SOURCES) - cp stepA_mal.py __main__.py - zip -q - __main__.py $+ > $@ - rm __main__.py - -mal: mal.pyz - echo '#!/usr/bin/env python' > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.pyz mal +SOURCES_BASE = mal_readline.py mal_types.py reader.py printer.py +SOURCES_LISP = env.py core.py stepA_mal.py +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.pyz mal + +SHELL := bash +mal.pyz: $(SOURCES) + cp stepA_mal.py __main__.py + zip -q - __main__.py $+ > $@ + rm __main__.py + +mal: mal.pyz + echo '#!/usr/bin/env python' > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.pyz mal diff --git a/impls/python/core.py b/impls/python/core.py index cb351b2033..b941adf322 100644 --- a/impls/python/core.py +++ b/impls/python/core.py @@ -1,194 +1,194 @@ -import copy, time -from itertools import chain - -import mal_types as types -from mal_types import MalException, List, Vector -import mal_readline -import reader -import printer - -# Errors/Exceptions -def throw(obj): raise MalException(obj) - - -# String functions -def pr_str(*args): - return " ".join(map(lambda exp: printer._pr_str(exp, True), args)) - -def do_str(*args): - return "".join(map(lambda exp: printer._pr_str(exp, False), args)) - -def prn(*args): - print(" ".join(map(lambda exp: printer._pr_str(exp, True), args))) - return None - -def println(*args): - print(" ".join(map(lambda exp: printer._pr_str(exp, False), args))) - return None - - -# Hash map functions -def assoc(src_hm, *key_vals): - hm = copy.copy(src_hm) - for i in range(0,len(key_vals),2): hm[key_vals[i]] = key_vals[i+1] - return hm - -def dissoc(src_hm, *keys): - hm = copy.copy(src_hm) - for key in keys: - hm.pop(key, None) - return hm - -def get(hm, key): - if hm is not None: - return hm.get(key) - else: - return None - -def contains_Q(hm, key): return key in hm - -def keys(hm): return types._list(*hm.keys()) - -def vals(hm): return types._list(*hm.values()) - - -# Sequence functions -def coll_Q(coll): return sequential_Q(coll) or hash_map_Q(coll) - -def cons(x, seq): return List([x]) + List(seq) - -def concat(*lsts): return List(chain(*lsts)) - -def nth(lst, idx): - if idx < len(lst): return lst[idx] - else: throw("nth: index out of range") - -def first(lst): - if types._nil_Q(lst): return None - else: return lst[0] - -def rest(lst): - if types._nil_Q(lst): return List([]) - else: return List(lst[1:]) - -def empty_Q(lst): return len(lst) == 0 - -def count(lst): - if types._nil_Q(lst): return 0 - else: return len(lst) - -def apply(f, *args): return f(*(list(args[0:-1])+args[-1])) - -def mapf(f, lst): return List(map(f, lst)) - -# retains metadata -def conj(lst, *args): - if types._list_Q(lst): - new_lst = List(list(reversed(list(args))) + lst) - else: - new_lst = Vector(lst + list(args)) - if hasattr(lst, "__meta__"): - new_lst.__meta__ = lst.__meta__ - return new_lst - -def seq(obj): - if types._list_Q(obj): - return obj if len(obj) > 0 else None - elif types._vector_Q(obj): - return List(obj) if len(obj) > 0 else None - elif types._string_Q(obj): - return List([c for c in obj]) if len(obj) > 0 else None - elif obj == None: - return None - else: throw ("seq: called on non-sequence") - -# Metadata functions -def with_meta(obj, meta): - new_obj = types._clone(obj) - new_obj.__meta__ = meta - return new_obj - -def meta(obj): - return getattr(obj, "__meta__", None) - - -# Atoms functions -def deref(atm): return atm.val -def reset_BANG(atm,val): - atm.val = val - return atm.val -def swap_BANG(atm,f,*args): - atm.val = f(atm.val,*args) - return atm.val - - -ns = { - '=': types._equal_Q, - 'throw': throw, - 'nil?': types._nil_Q, - 'true?': types._true_Q, - 'false?': types._false_Q, - 'number?': types._number_Q, - 'string?': types._string_Q, - 'symbol': types._symbol, - 'symbol?': types._symbol_Q, - 'keyword': types._keyword, - 'keyword?': types._keyword_Q, - 'fn?': lambda x: (types._function_Q(x) and not hasattr(x, '_ismacro_')), - 'macro?': lambda x: (types._function_Q(x) and - hasattr(x, '_ismacro_') and - x._ismacro_), - - 'pr-str': pr_str, - 'str': do_str, - 'prn': prn, - 'println': println, - 'readline': lambda prompt: mal_readline.readline(prompt), - 'read-string': reader.read_str, - 'slurp': lambda file: open(file).read(), - '<': lambda a,b: a': lambda a,b: a>b, - '>=': lambda a,b: a>=b, - '+': lambda a,b: a+b, - '-': lambda a,b: a-b, - '*': lambda a,b: a*b, - '/': lambda a,b: int(a/b), - 'time-ms': lambda : int(time.time() * 1000), - - 'list': types._list, - 'list?': types._list_Q, - 'vector': types._vector, - 'vector?': types._vector_Q, - 'hash-map': types._hash_map, - 'map?': types._hash_map_Q, - 'assoc': assoc, - 'dissoc': dissoc, - 'get': get, - 'contains?': contains_Q, - 'keys': keys, - 'vals': vals, - - 'sequential?': types._sequential_Q, - 'cons': cons, - 'concat': concat, - 'vec': Vector, - 'nth': nth, - 'first': first, - 'rest': rest, - 'empty?': empty_Q, - 'count': count, - 'apply': apply, - 'map': mapf, - - 'conj': conj, - 'seq': seq, - - 'with-meta': with_meta, - 'meta': meta, - 'atom': types._atom, - 'atom?': types._atom_Q, - 'deref': deref, - 'reset!': reset_BANG, - 'swap!': swap_BANG} - +import copy, time +from itertools import chain + +import mal_types as types +from mal_types import MalException, List, Vector +import mal_readline +import reader +import printer + +# Errors/Exceptions +def throw(obj): raise MalException(obj) + + +# String functions +def pr_str(*args): + return " ".join(map(lambda exp: printer._pr_str(exp, True), args)) + +def do_str(*args): + return "".join(map(lambda exp: printer._pr_str(exp, False), args)) + +def prn(*args): + print(" ".join(map(lambda exp: printer._pr_str(exp, True), args))) + return None + +def println(*args): + print(" ".join(map(lambda exp: printer._pr_str(exp, False), args))) + return None + + +# Hash map functions +def assoc(src_hm, *key_vals): + hm = copy.copy(src_hm) + for i in range(0,len(key_vals),2): hm[key_vals[i]] = key_vals[i+1] + return hm + +def dissoc(src_hm, *keys): + hm = copy.copy(src_hm) + for key in keys: + hm.pop(key, None) + return hm + +def get(hm, key): + if hm is not None: + return hm.get(key) + else: + return None + +def contains_Q(hm, key): return key in hm + +def keys(hm): return types._list(*hm.keys()) + +def vals(hm): return types._list(*hm.values()) + + +# Sequence functions +def coll_Q(coll): return sequential_Q(coll) or hash_map_Q(coll) + +def cons(x, seq): return List([x]) + List(seq) + +def concat(*lsts): return List(chain(*lsts)) + +def nth(lst, idx): + if idx < len(lst): return lst[idx] + else: throw("nth: index out of range") + +def first(lst): + if types._nil_Q(lst): return None + else: return lst[0] + +def rest(lst): + if types._nil_Q(lst): return List([]) + else: return List(lst[1:]) + +def empty_Q(lst): return len(lst) == 0 + +def count(lst): + if types._nil_Q(lst): return 0 + else: return len(lst) + +def apply(f, *args): return f(*(list(args[0:-1])+args[-1])) + +def mapf(f, lst): return List(map(f, lst)) + +# retains metadata +def conj(lst, *args): + if types._list_Q(lst): + new_lst = List(list(reversed(list(args))) + lst) + else: + new_lst = Vector(lst + list(args)) + if hasattr(lst, "__meta__"): + new_lst.__meta__ = lst.__meta__ + return new_lst + +def seq(obj): + if types._list_Q(obj): + return obj if len(obj) > 0 else None + elif types._vector_Q(obj): + return List(obj) if len(obj) > 0 else None + elif types._string_Q(obj): + return List([c for c in obj]) if len(obj) > 0 else None + elif obj == None: + return None + else: throw ("seq: called on non-sequence") + +# Metadata functions +def with_meta(obj, meta): + new_obj = types._clone(obj) + new_obj.__meta__ = meta + return new_obj + +def meta(obj): + return getattr(obj, "__meta__", None) + + +# Atoms functions +def deref(atm): return atm.val +def reset_BANG(atm,val): + atm.val = val + return atm.val +def swap_BANG(atm,f,*args): + atm.val = f(atm.val,*args) + return atm.val + + +ns = { + '=': types._equal_Q, + 'throw': throw, + 'nil?': types._nil_Q, + 'true?': types._true_Q, + 'false?': types._false_Q, + 'number?': types._number_Q, + 'string?': types._string_Q, + 'symbol': types._symbol, + 'symbol?': types._symbol_Q, + 'keyword': types._keyword, + 'keyword?': types._keyword_Q, + 'fn?': lambda x: (types._function_Q(x) and not hasattr(x, '_ismacro_')), + 'macro?': lambda x: (types._function_Q(x) and + hasattr(x, '_ismacro_') and + x._ismacro_), + + 'pr-str': pr_str, + 'str': do_str, + 'prn': prn, + 'println': println, + 'readline': lambda prompt: mal_readline.readline(prompt), + 'read-string': reader.read_str, + 'slurp': lambda file: open(file).read(), + '<': lambda a,b: a': lambda a,b: a>b, + '>=': lambda a,b: a>=b, + '+': lambda a,b: a+b, + '-': lambda a,b: a-b, + '*': lambda a,b: a*b, + '/': lambda a,b: int(a/b), + 'time-ms': lambda : int(time.time() * 1000), + + 'list': types._list, + 'list?': types._list_Q, + 'vector': types._vector, + 'vector?': types._vector_Q, + 'hash-map': types._hash_map, + 'map?': types._hash_map_Q, + 'assoc': assoc, + 'dissoc': dissoc, + 'get': get, + 'contains?': contains_Q, + 'keys': keys, + 'vals': vals, + + 'sequential?': types._sequential_Q, + 'cons': cons, + 'concat': concat, + 'vec': Vector, + 'nth': nth, + 'first': first, + 'rest': rest, + 'empty?': empty_Q, + 'count': count, + 'apply': apply, + 'map': mapf, + + 'conj': conj, + 'seq': seq, + + 'with-meta': with_meta, + 'meta': meta, + 'atom': types._atom, + 'atom?': types._atom_Q, + 'deref': deref, + 'reset!': reset_BANG, + 'swap!': swap_BANG} + diff --git a/impls/python/env.py b/impls/python/env.py index 4cd8e0574d..0d11abbd8c 100644 --- a/impls/python/env.py +++ b/impls/python/env.py @@ -1,28 +1,28 @@ -# Environment - -class Env(): - def __init__(self, outer=None, binds=None, exprs=None): - self.data = {} - self.outer = outer or None - - if binds: - for i in range(len(binds)): - if binds[i] == "&": - self.data[binds[i+1]] = exprs[i:] - break - else: - self.data[binds[i]] = exprs[i] - - def find(self, key): - if key in self.data: return self - elif self.outer: return self.outer.find(key) - else: return None - - def set(self, key, value): - self.data[key] = value - return value - - def get(self, key): - env = self.find(key) - if not env: raise Exception("'" + key + "' not found") - return env.data[key] +# Environment + +class Env(): + def __init__(self, outer=None, binds=None, exprs=None): + self.data = {} + self.outer = outer or None + + if binds: + for i in range(len(binds)): + if binds[i] == "&": + self.data[binds[i+1]] = exprs[i:] + break + else: + self.data[binds[i]] = exprs[i] + + def find(self, key): + if key in self.data: return self + elif self.outer: return self.outer.find(key) + else: return None + + def set(self, key, value): + self.data[key] = value + return value + + def get(self, key): + env = self.find(key) + if not env: raise Exception("'" + key + "' not found") + return env.data[key] diff --git a/impls/python/mal_readline.py b/impls/python/mal_readline.py index 340f3f64d6..c4d8529487 100644 --- a/impls/python/mal_readline.py +++ b/impls/python/mal_readline.py @@ -1,32 +1,32 @@ -import os, sys, readline as pyreadline - -history_loaded = False -histfile = os.path.expanduser("~/.mal-history") -if sys.version_info[0] >= 3: - rl = input -else: - rl = raw_input - -def readline(prompt="user> "): - global history_loaded - if not history_loaded: - history_loaded = True - try: - with open(histfile, "r") as hf: - for line in hf.readlines(): - pyreadline.add_history(line.rstrip("\r\n")) - pass - except IOError: - #print("Could not open %s" % histfile) - pass - - try: - line = rl(prompt) - pyreadline.add_history(line) - with open(histfile, "a") as hf: - hf.write(line + "\n") - except IOError: - pass - except EOFError: - return None - return line +import os, sys, readline as pyreadline + +history_loaded = False +histfile = os.path.expanduser("~/.mal-history") +if sys.version_info[0] >= 3: + rl = input +else: + rl = raw_input + +def readline(prompt="user> "): + global history_loaded + if not history_loaded: + history_loaded = True + try: + with open(histfile, "r") as hf: + for line in hf.readlines(): + pyreadline.add_history(line.rstrip("\r\n")) + pass + except IOError: + #print("Could not open %s" % histfile) + pass + + try: + line = rl(prompt) + pyreadline.add_history(line) + with open(histfile, "a") as hf: + hf.write(line + "\n") + except IOError: + pass + except EOFError: + return None + return line diff --git a/impls/python/mal_types.py b/impls/python/mal_types.py index a4bf288b01..9d11e54d55 100644 --- a/impls/python/mal_types.py +++ b/impls/python/mal_types.py @@ -1,147 +1,147 @@ -import sys, copy, types as pytypes - -# python 3.0 differences -if sys.hexversion > 0x3000000: - _u = lambda x: x - _s2u = lambda x: x -else: - import codecs - _u = lambda x: codecs.unicode_escape_decode(x)[0] - _s2u = lambda x: unicode(x) - -if sys.version_info[0] >= 3: - str_types = [str] -else: - str_types = [str, unicode] - -# General functions - -def _equal_Q(a, b): - ota, otb = type(a), type(b) - if _string_Q(a) and _string_Q(b): - return a == b - if not (ota == otb or (_sequential_Q(a) and _sequential_Q(b))): - return False; - if _symbol_Q(a): - return a == b - elif _list_Q(a) or _vector_Q(a): - if len(a) != len(b): return False - for i in range(len(a)): - if not _equal_Q(a[i], b[i]): return False - return True - elif _hash_map_Q(a): - akeys = sorted(a.keys()) - bkeys = sorted(b.keys()) - if len(akeys) != len(bkeys): return False - for i in range(len(akeys)): - if akeys[i] != bkeys[i]: return False - if not _equal_Q(a[akeys[i]], b[bkeys[i]]): return False - return True - else: - return a == b - -def _sequential_Q(seq): return _list_Q(seq) or _vector_Q(seq) - -def _clone(obj): - #if type(obj) == type(lambda x:x): - if type(obj) == pytypes.FunctionType: - if obj.__code__: - return pytypes.FunctionType( - obj.__code__, obj.__globals__, name = obj.__name__, - argdefs = obj.__defaults__, closure = obj.__closure__) - else: - return pytypes.FunctionType( - obj.func_code, obj.func_globals, name = obj.func_name, - argdefs = obj.func_defaults, closure = obj.func_closure) - else: - return copy.copy(obj) - -# -# Exception type -# - -class MalException(Exception): - def __init__(self, object): - self.object = object - -# Scalars -def _nil_Q(exp): return exp is None -def _true_Q(exp): return exp is True -def _false_Q(exp): return exp is False -def _string_Q(exp): - if type(exp) in str_types: - return len(exp) == 0 or exp[0] != _u("\u029e") - else: - return False -def _number_Q(exp): return type(exp) == int - -# Symbols -class Symbol(str): pass -def _symbol(str): return Symbol(str) -def _symbol_Q(exp): return type(exp) == Symbol - -# Keywords -# A specially prefixed string -def _keyword(str): - if str[0] == _u("\u029e"): return str - else: return _u("\u029e") + str -def _keyword_Q(exp): - if type(exp) in str_types: - return len(exp) != 0 and exp[0] == _u("\u029e") - else: - return False - -# Functions -def _function(Eval, Env, ast, env, params): - def fn(*args): - return Eval(ast, Env(env, params, List(args))) - fn.__meta__ = None - fn.__ast__ = ast - fn.__gen_env__ = lambda args: Env(env, params, args) - return fn -def _function_Q(f): - return callable(f) - -# lists -class List(list): - def __add__(self, rhs): return List(list.__add__(self, rhs)) - def __getitem__(self, i): - if type(i) == slice: return List(list.__getitem__(self, i)) - elif i >= len(self): return None - else: return list.__getitem__(self, i) - def __getslice__(self, *a): return List(list.__getslice__(self, *a)) -def _list(*vals): return List(vals) -def _list_Q(exp): return type(exp) == List - - -# vectors -class Vector(list): - def __add__(self, rhs): return Vector(list.__add__(self, rhs)) - def __getitem__(self, i): - if type(i) == slice: return Vector(list.__getitem__(self, i)) - elif i >= len(self): return None - else: return list.__getitem__(self, i) - def __getslice__(self, *a): return Vector(list.__getslice__(self, *a)) -def _vector(*vals): return Vector(vals) -def _vector_Q(exp): return type(exp) == Vector - -# Hash maps -class Hash_Map(dict): pass -def _hash_map(*key_vals): - hm = Hash_Map() - for i in range(0,len(key_vals),2): hm[key_vals[i]] = key_vals[i+1] - return hm -def _hash_map_Q(exp): return type(exp) == Hash_Map - -# atoms -class Atom(object): - def __init__(self, val): - self.val = val -def _atom(val): return Atom(val) -def _atom_Q(exp): return type(exp) == Atom - -def py_to_mal(obj): - if type(obj) == list: return List(obj) - if type(obj) == tuple: return List(obj) - elif type(obj) == dict: return Hash_Map(obj) - else: return obj +import sys, copy, types as pytypes + +# python 3.0 differences +if sys.hexversion > 0x3000000: + _u = lambda x: x + _s2u = lambda x: x +else: + import codecs + _u = lambda x: codecs.unicode_escape_decode(x)[0] + _s2u = lambda x: unicode(x) + +if sys.version_info[0] >= 3: + str_types = [str] +else: + str_types = [str, unicode] + +# General functions + +def _equal_Q(a, b): + ota, otb = type(a), type(b) + if _string_Q(a) and _string_Q(b): + return a == b + if not (ota == otb or (_sequential_Q(a) and _sequential_Q(b))): + return False; + if _symbol_Q(a): + return a == b + elif _list_Q(a) or _vector_Q(a): + if len(a) != len(b): return False + for i in range(len(a)): + if not _equal_Q(a[i], b[i]): return False + return True + elif _hash_map_Q(a): + akeys = sorted(a.keys()) + bkeys = sorted(b.keys()) + if len(akeys) != len(bkeys): return False + for i in range(len(akeys)): + if akeys[i] != bkeys[i]: return False + if not _equal_Q(a[akeys[i]], b[bkeys[i]]): return False + return True + else: + return a == b + +def _sequential_Q(seq): return _list_Q(seq) or _vector_Q(seq) + +def _clone(obj): + #if type(obj) == type(lambda x:x): + if type(obj) == pytypes.FunctionType: + if obj.__code__: + return pytypes.FunctionType( + obj.__code__, obj.__globals__, name = obj.__name__, + argdefs = obj.__defaults__, closure = obj.__closure__) + else: + return pytypes.FunctionType( + obj.func_code, obj.func_globals, name = obj.func_name, + argdefs = obj.func_defaults, closure = obj.func_closure) + else: + return copy.copy(obj) + +# +# Exception type +# + +class MalException(Exception): + def __init__(self, object): + self.object = object + +# Scalars +def _nil_Q(exp): return exp is None +def _true_Q(exp): return exp is True +def _false_Q(exp): return exp is False +def _string_Q(exp): + if type(exp) in str_types: + return len(exp) == 0 or exp[0] != _u("\u029e") + else: + return False +def _number_Q(exp): return type(exp) == int + +# Symbols +class Symbol(str): pass +def _symbol(str): return Symbol(str) +def _symbol_Q(exp): return type(exp) == Symbol + +# Keywords +# A specially prefixed string +def _keyword(str): + if str[0] == _u("\u029e"): return str + else: return _u("\u029e") + str +def _keyword_Q(exp): + if type(exp) in str_types: + return len(exp) != 0 and exp[0] == _u("\u029e") + else: + return False + +# Functions +def _function(Eval, Env, ast, env, params): + def fn(*args): + return Eval(ast, Env(env, params, List(args))) + fn.__meta__ = None + fn.__ast__ = ast + fn.__gen_env__ = lambda args: Env(env, params, args) + return fn +def _function_Q(f): + return callable(f) + +# lists +class List(list): + def __add__(self, rhs): return List(list.__add__(self, rhs)) + def __getitem__(self, i): + if type(i) == slice: return List(list.__getitem__(self, i)) + elif i >= len(self): return None + else: return list.__getitem__(self, i) + def __getslice__(self, *a): return List(list.__getslice__(self, *a)) +def _list(*vals): return List(vals) +def _list_Q(exp): return type(exp) == List + + +# vectors +class Vector(list): + def __add__(self, rhs): return Vector(list.__add__(self, rhs)) + def __getitem__(self, i): + if type(i) == slice: return Vector(list.__getitem__(self, i)) + elif i >= len(self): return None + else: return list.__getitem__(self, i) + def __getslice__(self, *a): return Vector(list.__getslice__(self, *a)) +def _vector(*vals): return Vector(vals) +def _vector_Q(exp): return type(exp) == Vector + +# Hash maps +class Hash_Map(dict): pass +def _hash_map(*key_vals): + hm = Hash_Map() + for i in range(0,len(key_vals),2): hm[key_vals[i]] = key_vals[i+1] + return hm +def _hash_map_Q(exp): return type(exp) == Hash_Map + +# atoms +class Atom(object): + def __init__(self, val): + self.val = val +def _atom(val): return Atom(val) +def _atom_Q(exp): return type(exp) == Atom + +def py_to_mal(obj): + if type(obj) == list: return List(obj) + if type(obj) == tuple: return List(obj) + elif type(obj) == dict: return Hash_Map(obj) + else: return obj diff --git a/impls/python/printer.py b/impls/python/printer.py index 32d2708387..21cd5a045a 100644 --- a/impls/python/printer.py +++ b/impls/python/printer.py @@ -1,34 +1,34 @@ -import mal_types as types - -def _escape(s): - return s.replace('\\', '\\\\').replace('"', '\\"').replace('\n', '\\n') - -def _pr_str(obj, print_readably=True): - _r = print_readably - if types._list_Q(obj): - return "(" + " ".join(map(lambda e: _pr_str(e,_r), obj)) + ")" - elif types._vector_Q(obj): - return "[" + " ".join(map(lambda e: _pr_str(e,_r), obj)) + "]" - elif types._hash_map_Q(obj): - ret = [] - for k in obj.keys(): - ret.extend((_pr_str(k), _pr_str(obj[k],_r))) - return "{" + " ".join(ret) + "}" - elif type(obj) in types.str_types: - if len(obj) > 0 and obj[0] == types._u('\u029e'): - return ':' + obj[1:] - elif print_readably: - return '"' + _escape(obj) + '"' - else: - return obj - elif types._nil_Q(obj): - return "nil" - elif types._true_Q(obj): - return "true" - elif types._false_Q(obj): - return "false" - elif types._atom_Q(obj): - return "(atom " + _pr_str(obj.val,_r) + ")" - else: - return obj.__str__() - +import mal_types as types + +def _escape(s): + return s.replace('\\', '\\\\').replace('"', '\\"').replace('\n', '\\n') + +def _pr_str(obj, print_readably=True): + _r = print_readably + if types._list_Q(obj): + return "(" + " ".join(map(lambda e: _pr_str(e,_r), obj)) + ")" + elif types._vector_Q(obj): + return "[" + " ".join(map(lambda e: _pr_str(e,_r), obj)) + "]" + elif types._hash_map_Q(obj): + ret = [] + for k in obj.keys(): + ret.extend((_pr_str(k), _pr_str(obj[k],_r))) + return "{" + " ".join(ret) + "}" + elif type(obj) in types.str_types: + if len(obj) > 0 and obj[0] == types._u('\u029e'): + return ':' + obj[1:] + elif print_readably: + return '"' + _escape(obj) + '"' + else: + return obj + elif types._nil_Q(obj): + return "nil" + elif types._true_Q(obj): + return "true" + elif types._false_Q(obj): + return "false" + elif types._atom_Q(obj): + return "(atom " + _pr_str(obj.val,_r) + ")" + else: + return obj.__str__() + diff --git a/impls/python/reader.py b/impls/python/reader.py index 59d24cc319..3aa91a2718 100644 --- a/impls/python/reader.py +++ b/impls/python/reader.py @@ -1,110 +1,110 @@ -import re -from mal_types import (_symbol, _keyword, _list, _vector, _hash_map, _s2u, _u) - -class Blank(Exception): pass - -class Reader(): - def __init__(self, tokens, position=0): - self.tokens = tokens - self.position = position - - def next(self): - self.position += 1 - return self.tokens[self.position-1] - - def peek(self): - if len(self.tokens) > self.position: - return self.tokens[self.position] - else: - return None - -def tokenize(str): - tre = re.compile(r"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:[\\].|[^\\"])*"?|;.*|[^\s\[\]{}()'"`@,;]+)"""); - return [t for t in re.findall(tre, str) if t[0] != ';'] - -def _unescape(s): - return s.replace('\\\\', _u('\u029e')).replace('\\"', '"').replace('\\n', '\n').replace(_u('\u029e'), '\\') - -def read_atom(reader): - int_re = re.compile(r"-?[0-9]+$") - float_re = re.compile(r"-?[0-9][0-9.]*$") - string_re = re.compile(r'"(?:[\\].|[^\\"])*"') - token = reader.next() - if re.match(int_re, token): return int(token) - elif re.match(float_re, token): return int(token) - elif re.match(string_re, token):return _s2u(_unescape(token[1:-1])) - elif token[0] == '"': raise Exception("expected '\"', got EOF") - elif token[0] == ':': return _keyword(token[1:]) - elif token == "nil": return None - elif token == "true": return True - elif token == "false": return False - else: return _symbol(token) - -def read_sequence(reader, typ=list, start='(', end=')'): - ast = typ() - token = reader.next() - if token != start: raise Exception("expected '" + start + "'") - - token = reader.peek() - while token != end: - if not token: raise Exception("expected '" + end + "', got EOF") - ast.append(read_form(reader)) - token = reader.peek() - reader.next() - return ast - -def read_hash_map(reader): - lst = read_sequence(reader, list, '{', '}') - return _hash_map(*lst) - -def read_list(reader): - return read_sequence(reader, _list, '(', ')') - -def read_vector(reader): - return read_sequence(reader, _vector, '[', ']') - -def read_form(reader): - token = reader.peek() - # reader macros/transforms - if token[0] == ';': - reader.next() - return None - elif token == '\'': - reader.next() - return _list(_symbol('quote'), read_form(reader)) - elif token == '`': - reader.next() - return _list(_symbol('quasiquote'), read_form(reader)) - elif token == '~': - reader.next() - return _list(_symbol('unquote'), read_form(reader)) - elif token == '~@': - reader.next() - return _list(_symbol('splice-unquote'), read_form(reader)) - elif token == '^': - reader.next() - meta = read_form(reader) - return _list(_symbol('with-meta'), read_form(reader), meta) - elif token == '@': - reader.next() - return _list(_symbol('deref'), read_form(reader)) - - # list - elif token == ')': raise Exception("unexpected ')'") - elif token == '(': return read_list(reader) - - # vector - elif token == ']': raise Exception("unexpected ']'"); - elif token == '[': return read_vector(reader); - - # hash-map - elif token == '}': raise Exception("unexpected '}'"); - elif token == '{': return read_hash_map(reader); - - # atom - else: return read_atom(reader); - -def read_str(str): - tokens = tokenize(str) - if len(tokens) == 0: raise Blank("Blank Line") - return read_form(Reader(tokens)) +import re +from mal_types import (_symbol, _keyword, _list, _vector, _hash_map, _s2u, _u) + +class Blank(Exception): pass + +class Reader(): + def __init__(self, tokens, position=0): + self.tokens = tokens + self.position = position + + def next(self): + self.position += 1 + return self.tokens[self.position-1] + + def peek(self): + if len(self.tokens) > self.position: + return self.tokens[self.position] + else: + return None + +def tokenize(str): + tre = re.compile(r"""[\s,]*(~@|[\[\]{}()'`~^@]|"(?:[\\].|[^\\"])*"?|;.*|[^\s\[\]{}()'"`@,;]+)"""); + return [t for t in re.findall(tre, str) if t[0] != ';'] + +def _unescape(s): + return s.replace('\\\\', _u('\u029e')).replace('\\"', '"').replace('\\n', '\n').replace(_u('\u029e'), '\\') + +def read_atom(reader): + int_re = re.compile(r"-?[0-9]+$") + float_re = re.compile(r"-?[0-9][0-9.]*$") + string_re = re.compile(r'"(?:[\\].|[^\\"])*"') + token = reader.next() + if re.match(int_re, token): return int(token) + elif re.match(float_re, token): return int(token) + elif re.match(string_re, token):return _s2u(_unescape(token[1:-1])) + elif token[0] == '"': raise Exception("expected '\"', got EOF") + elif token[0] == ':': return _keyword(token[1:]) + elif token == "nil": return None + elif token == "true": return True + elif token == "false": return False + else: return _symbol(token) + +def read_sequence(reader, typ=list, start='(', end=')'): + ast = typ() + token = reader.next() + if token != start: raise Exception("expected '" + start + "'") + + token = reader.peek() + while token != end: + if not token: raise Exception("expected '" + end + "', got EOF") + ast.append(read_form(reader)) + token = reader.peek() + reader.next() + return ast + +def read_hash_map(reader): + lst = read_sequence(reader, list, '{', '}') + return _hash_map(*lst) + +def read_list(reader): + return read_sequence(reader, _list, '(', ')') + +def read_vector(reader): + return read_sequence(reader, _vector, '[', ']') + +def read_form(reader): + token = reader.peek() + # reader macros/transforms + if token[0] == ';': + reader.next() + return None + elif token == '\'': + reader.next() + return _list(_symbol('quote'), read_form(reader)) + elif token == '`': + reader.next() + return _list(_symbol('quasiquote'), read_form(reader)) + elif token == '~': + reader.next() + return _list(_symbol('unquote'), read_form(reader)) + elif token == '~@': + reader.next() + return _list(_symbol('splice-unquote'), read_form(reader)) + elif token == '^': + reader.next() + meta = read_form(reader) + return _list(_symbol('with-meta'), read_form(reader), meta) + elif token == '@': + reader.next() + return _list(_symbol('deref'), read_form(reader)) + + # list + elif token == ')': raise Exception("unexpected ')'") + elif token == '(': return read_list(reader) + + # vector + elif token == ']': raise Exception("unexpected ']'"); + elif token == '[': return read_vector(reader); + + # hash-map + elif token == '}': raise Exception("unexpected '}'"); + elif token == '{': return read_hash_map(reader); + + # atom + else: return read_atom(reader); + +def read_str(str): + tokens = tokenize(str) + if len(tokens) == 0: raise Blank("Blank Line") + return read_form(Reader(tokens)) diff --git a/impls/python/run b/impls/python/run index 7549617761..8665b9ad2f 100755 --- a/impls/python/run +++ b/impls/python/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec ${python_MODE:-python} $(dirname $0)/${STEP:-stepA_mal}.py "${@}" +#!/bin/bash +exec ${python_MODE:-python} $(dirname $0)/${STEP:-stepA_mal}.py "${@}" diff --git a/impls/python/step0_repl.py b/impls/python/step0_repl.py index 3e5801b55f..4c823ffade 100644 --- a/impls/python/step0_repl.py +++ b/impls/python/step0_repl.py @@ -1,29 +1,29 @@ -import sys, traceback -import mal_readline - -# read -def READ(str): - return str - -# eval -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - return ast - -# print -def PRINT(exp): - return exp - -# repl -def REP(str): - return PRINT(EVAL(READ(str), {})) - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import sys, traceback +import mal_readline + +# read +def READ(str): + return str + +# eval +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + return ast + +# print +def PRINT(exp): + return exp + +# repl +def REP(str): + return PRINT(EVAL(READ(str), {})) + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/step1_read_print.py b/impls/python/step1_read_print.py index c167e38613..3e930586df 100644 --- a/impls/python/step1_read_print.py +++ b/impls/python/step1_read_print.py @@ -1,32 +1,32 @@ -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer - -# read -def READ(str): - return reader.read_str(str) - -# eval -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - return ast - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -def REP(str): - return PRINT(EVAL(READ(str), {})) - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer + +# read +def READ(str): + return reader.read_str(str) + +# eval +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + return ast + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +def REP(str): + return PRINT(EVAL(READ(str), {})) + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/step2_eval.py b/impls/python/step2_eval.py index b2f17f1822..f54c1f5ec8 100644 --- a/impls/python/step2_eval.py +++ b/impls/python/step2_eval.py @@ -1,60 +1,60 @@ -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - try: - return env[ast] - except: - raise Exception("'" + ast + "' not found") - elif types._list_Q(ast): - return types._list(*map(lambda a: EVAL(a, env), ast)) - elif types._vector_Q(ast): - return types._vector(*map(lambda a: EVAL(a, env), ast)) - elif types._hash_map_Q(ast): - return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - el = eval_ast(ast, env) - f = el[0] - return f(*el[1:]) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = {} -def REP(str): - return PRINT(EVAL(READ(str), repl_env)) - -repl_env['+'] = lambda a,b: a+b -repl_env['-'] = lambda a,b: a-b -repl_env['*'] = lambda a,b: a*b -repl_env['/'] = lambda a,b: int(a/b) - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + try: + return env[ast] + except: + raise Exception("'" + ast + "' not found") + elif types._list_Q(ast): + return types._list(*map(lambda a: EVAL(a, env), ast)) + elif types._vector_Q(ast): + return types._vector(*map(lambda a: EVAL(a, env), ast)) + elif types._hash_map_Q(ast): + return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + el = eval_ast(ast, env) + f = el[0] + return f(*el[1:]) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = {} +def REP(str): + return PRINT(EVAL(READ(str), repl_env)) + +repl_env['+'] = lambda a,b: a+b +repl_env['-'] = lambda a,b: a-b +repl_env['*'] = lambda a,b: a*b +repl_env['/'] = lambda a,b: int(a/b) + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/step3_env.py b/impls/python/step3_env.py index 1496305795..8ba5a8d38e 100644 --- a/impls/python/step3_env.py +++ b/impls/python/step3_env.py @@ -1,71 +1,71 @@ -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer -from env import Env - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - return env.get(ast) - elif types._list_Q(ast): - return types._list(*map(lambda a: EVAL(a, env), ast)) - elif types._vector_Q(ast): - return types._vector(*map(lambda a: EVAL(a, env), ast)) - elif types._hash_map_Q(ast): - return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - - if "def!" == a0: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif "let*" == a0: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - return EVAL(a2, let_env) - else: - el = eval_ast(ast, env) - f = el[0] - return f(*el[1:]) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = Env() -def REP(str): - return PRINT(EVAL(READ(str), repl_env)) - -repl_env.set(types._symbol('+'), lambda a,b: a+b) -repl_env.set(types._symbol('-'), lambda a,b: a-b) -repl_env.set(types._symbol('*'), lambda a,b: a*b) -repl_env.set(types._symbol('/'), lambda a,b: int(a/b)) - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer +from env import Env + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + return env.get(ast) + elif types._list_Q(ast): + return types._list(*map(lambda a: EVAL(a, env), ast)) + elif types._vector_Q(ast): + return types._vector(*map(lambda a: EVAL(a, env), ast)) + elif types._hash_map_Q(ast): + return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + + if "def!" == a0: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif "let*" == a0: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + return EVAL(a2, let_env) + else: + el = eval_ast(ast, env) + f = el[0] + return f(*el[1:]) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = Env() +def REP(str): + return PRINT(EVAL(READ(str), repl_env)) + +repl_env.set(types._symbol('+'), lambda a,b: a+b) +repl_env.set(types._symbol('-'), lambda a,b: a-b) +repl_env.set(types._symbol('*'), lambda a,b: a*b) +repl_env.set(types._symbol('/'), lambda a,b: int(a/b)) + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/step4_if_fn_do.py b/impls/python/step4_if_fn_do.py index 3567a14cc9..ac32531c46 100644 --- a/impls/python/step4_if_fn_do.py +++ b/impls/python/step4_if_fn_do.py @@ -1,87 +1,87 @@ -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - return env.get(ast) - elif types._list_Q(ast): - return types._list(*map(lambda a: EVAL(a, env), ast)) - elif types._vector_Q(ast): - return types._vector(*map(lambda a: EVAL(a, env), ast)) - elif types._hash_map_Q(ast): - return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - - if "def!" == a0: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif "let*" == a0: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - return EVAL(a2, let_env) - elif "do" == a0: - el = eval_ast(ast[1:], env) - return el[-1] - elif "if" == a0: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is None or cond is False: - if len(ast) > 3: return EVAL(ast[3], env) - else: return None - else: - return EVAL(a2, env) - elif "fn*" == a0: - a1, a2 = ast[1], ast[2] - return types._function(EVAL, Env, a2, env, a1) - else: - el = eval_ast(ast, env) - f = el[0] - return f(*el[1:]) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = Env() -def REP(str): - return PRINT(EVAL(READ(str), repl_env)) - -# core.py: defined using python -for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + return env.get(ast) + elif types._list_Q(ast): + return types._list(*map(lambda a: EVAL(a, env), ast)) + elif types._vector_Q(ast): + return types._vector(*map(lambda a: EVAL(a, env), ast)) + elif types._hash_map_Q(ast): + return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + + if "def!" == a0: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif "let*" == a0: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + return EVAL(a2, let_env) + elif "do" == a0: + el = eval_ast(ast[1:], env) + return el[-1] + elif "if" == a0: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is None or cond is False: + if len(ast) > 3: return EVAL(ast[3], env) + else: return None + else: + return EVAL(a2, env) + elif "fn*" == a0: + a1, a2 = ast[1], ast[2] + return types._function(EVAL, Env, a2, env, a1) + else: + el = eval_ast(ast, env) + f = el[0] + return f(*el[1:]) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = Env() +def REP(str): + return PRINT(EVAL(READ(str), repl_env)) + +# core.py: defined using python +for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/step5_tco.py b/impls/python/step5_tco.py index 5d783d3d08..3ac45454bb 100644 --- a/impls/python/step5_tco.py +++ b/impls/python/step5_tco.py @@ -1,96 +1,96 @@ -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - return env.get(ast) - elif types._list_Q(ast): - return types._list(*map(lambda a: EVAL(a, env), ast)) - elif types._vector_Q(ast): - return types._vector(*map(lambda a: EVAL(a, env), ast)) - elif types._hash_map_Q(ast): - return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - - if "def!" == a0: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif "let*" == a0: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - # Continue loop (TCO) - elif "do" == a0: - eval_ast(ast[1:-1], env) - ast = ast[-1] - # Continue loop (TCO) - elif "if" == a0: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is None or cond is False: - if len(ast) > 3: ast = ast[3] - else: ast = None - else: - ast = a2 - # Continue loop (TCO) - elif "fn*" == a0: - a1, a2 = ast[1], ast[2] - return types._function(EVAL, Env, a2, env, a1) - else: - el = eval_ast(ast, env) - f = el[0] - if hasattr(f, '__ast__'): - ast = f.__ast__ - env = f.__gen_env__(el[1:]) - else: - return f(*el[1:]) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = Env() -def REP(str): - return PRINT(EVAL(READ(str), repl_env)) - -# core.py: defined using python -for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info())[0:100])) +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + return env.get(ast) + elif types._list_Q(ast): + return types._list(*map(lambda a: EVAL(a, env), ast)) + elif types._vector_Q(ast): + return types._vector(*map(lambda a: EVAL(a, env), ast)) + elif types._hash_map_Q(ast): + return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + + if "def!" == a0: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif "let*" == a0: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + # Continue loop (TCO) + elif "do" == a0: + eval_ast(ast[1:-1], env) + ast = ast[-1] + # Continue loop (TCO) + elif "if" == a0: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is None or cond is False: + if len(ast) > 3: ast = ast[3] + else: ast = None + else: + ast = a2 + # Continue loop (TCO) + elif "fn*" == a0: + a1, a2 = ast[1], ast[2] + return types._function(EVAL, Env, a2, env, a1) + else: + el = eval_ast(ast, env) + f = el[0] + if hasattr(f, '__ast__'): + ast = f.__ast__ + env = f.__gen_env__(el[1:]) + else: + return f(*el[1:]) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = Env() +def REP(str): + return PRINT(EVAL(READ(str), repl_env)) + +# core.py: defined using python +for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info())[0:100])) diff --git a/impls/python/step6_file.py b/impls/python/step6_file.py index 2fd02eb0ea..9b407e7a9d 100644 --- a/impls/python/step6_file.py +++ b/impls/python/step6_file.py @@ -1,103 +1,103 @@ -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - return env.get(ast) - elif types._list_Q(ast): - return types._list(*map(lambda a: EVAL(a, env), ast)) - elif types._vector_Q(ast): - return types._vector(*map(lambda a: EVAL(a, env), ast)) - elif types._hash_map_Q(ast): - return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - - if "def!" == a0: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif "let*" == a0: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - # Continue loop (TCO) - elif "do" == a0: - eval_ast(ast[1:-1], env) - ast = ast[-1] - # Continue loop (TCO) - elif "if" == a0: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is None or cond is False: - if len(ast) > 3: ast = ast[3] - else: ast = None - else: - ast = a2 - # Continue loop (TCO) - elif "fn*" == a0: - a1, a2 = ast[1], ast[2] - return types._function(EVAL, Env, a2, env, a1) - else: - el = eval_ast(ast, env) - f = el[0] - if hasattr(f, '__ast__'): - ast = f.__ast__ - env = f.__gen_env__(el[1:]) - else: - return f(*el[1:]) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = Env() -def REP(str): - return PRINT(EVAL(READ(str), repl_env)) - -# core.py: defined using python -for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) -repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) -repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if len(sys.argv) >= 2: - REP('(load-file "' + sys.argv[1] + '")') - sys.exit(0) - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + return env.get(ast) + elif types._list_Q(ast): + return types._list(*map(lambda a: EVAL(a, env), ast)) + elif types._vector_Q(ast): + return types._vector(*map(lambda a: EVAL(a, env), ast)) + elif types._hash_map_Q(ast): + return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + + if "def!" == a0: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif "let*" == a0: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + # Continue loop (TCO) + elif "do" == a0: + eval_ast(ast[1:-1], env) + ast = ast[-1] + # Continue loop (TCO) + elif "if" == a0: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is None or cond is False: + if len(ast) > 3: ast = ast[3] + else: ast = None + else: + ast = a2 + # Continue loop (TCO) + elif "fn*" == a0: + a1, a2 = ast[1], ast[2] + return types._function(EVAL, Env, a2, env, a1) + else: + el = eval_ast(ast, env) + f = el[0] + if hasattr(f, '__ast__'): + ast = f.__ast__ + env = f.__gen_env__(el[1:]) + else: + return f(*el[1:]) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = Env() +def REP(str): + return PRINT(EVAL(READ(str), repl_env)) + +# core.py: defined using python +for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) +repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) +repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if len(sys.argv) >= 2: + REP('(load-file "' + sys.argv[1] + '")') + sys.exit(0) + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/step7_quote.py b/impls/python/step7_quote.py index 7bdb312efd..c4c4f324e6 100644 --- a/impls/python/step7_quote.py +++ b/impls/python/step7_quote.py @@ -1,133 +1,133 @@ -import functools -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def qq_loop(acc, elt): - if types._list_Q(elt) and len(elt) == 2 and elt[0] == u'splice-unquote': - return types._list(types._symbol(u'concat'), elt[1], acc) - else: - return types._list(types._symbol(u'cons'), quasiquote(elt), acc) - -def qq_foldr(seq): - return functools.reduce(qq_loop, reversed(seq), types._list()) - -def quasiquote(ast): - if types._list_Q(ast): - if len(ast) == 2 and ast[0] == u'unquote': - return ast[1] - else: - return qq_foldr(ast) - elif types._hash_map_Q(ast) or types._symbol_Q(ast): - return types._list(types._symbol(u'quote'), ast) - elif types._vector_Q (ast): - return types._list(types._symbol(u'vec'), qq_foldr(ast)) - else: - return ast - -def eval_ast(ast, env): - if types._symbol_Q(ast): - return env.get(ast) - elif types._list_Q(ast): - return types._list(*map(lambda a: EVAL(a, env), ast)) - elif types._vector_Q(ast): - return types._vector(*map(lambda a: EVAL(a, env), ast)) - elif types._hash_map_Q(ast): - return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - - if "def!" == a0: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif "let*" == a0: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - # Continue loop (TCO) - elif "quote" == a0: - return ast[1] - elif "quasiquoteexpand" == a0: - return quasiquote(ast[1]); - elif "quasiquote" == a0: - ast = quasiquote(ast[1]); - # Continue loop (TCO) - elif "do" == a0: - eval_ast(ast[1:-1], env) - ast = ast[-1] - # Continue loop (TCO) - elif "if" == a0: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is None or cond is False: - if len(ast) > 3: ast = ast[3] - else: ast = None - else: - ast = a2 - # Continue loop (TCO) - elif "fn*" == a0: - a1, a2 = ast[1], ast[2] - return types._function(EVAL, Env, a2, env, a1) - else: - el = eval_ast(ast, env) - f = el[0] - if hasattr(f, '__ast__'): - ast = f.__ast__ - env = f.__gen_env__(el[1:]) - else: - return f(*el[1:]) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = Env() -def REP(str): - return PRINT(EVAL(READ(str), repl_env)) - -# core.py: defined using python -for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) -repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) -repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if len(sys.argv) >= 2: - REP('(load-file "' + sys.argv[1] + '")') - sys.exit(0) - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import functools +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def qq_loop(acc, elt): + if types._list_Q(elt) and len(elt) == 2 and elt[0] == u'splice-unquote': + return types._list(types._symbol(u'concat'), elt[1], acc) + else: + return types._list(types._symbol(u'cons'), quasiquote(elt), acc) + +def qq_foldr(seq): + return functools.reduce(qq_loop, reversed(seq), types._list()) + +def quasiquote(ast): + if types._list_Q(ast): + if len(ast) == 2 and ast[0] == u'unquote': + return ast[1] + else: + return qq_foldr(ast) + elif types._hash_map_Q(ast) or types._symbol_Q(ast): + return types._list(types._symbol(u'quote'), ast) + elif types._vector_Q (ast): + return types._list(types._symbol(u'vec'), qq_foldr(ast)) + else: + return ast + +def eval_ast(ast, env): + if types._symbol_Q(ast): + return env.get(ast) + elif types._list_Q(ast): + return types._list(*map(lambda a: EVAL(a, env), ast)) + elif types._vector_Q(ast): + return types._vector(*map(lambda a: EVAL(a, env), ast)) + elif types._hash_map_Q(ast): + return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + + if "def!" == a0: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif "let*" == a0: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + # Continue loop (TCO) + elif "quote" == a0: + return ast[1] + elif "quasiquoteexpand" == a0: + return quasiquote(ast[1]); + elif "quasiquote" == a0: + ast = quasiquote(ast[1]); + # Continue loop (TCO) + elif "do" == a0: + eval_ast(ast[1:-1], env) + ast = ast[-1] + # Continue loop (TCO) + elif "if" == a0: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is None or cond is False: + if len(ast) > 3: ast = ast[3] + else: ast = None + else: + ast = a2 + # Continue loop (TCO) + elif "fn*" == a0: + a1, a2 = ast[1], ast[2] + return types._function(EVAL, Env, a2, env, a1) + else: + el = eval_ast(ast, env) + f = el[0] + if hasattr(f, '__ast__'): + ast = f.__ast__ + env = f.__gen_env__(el[1:]) + else: + return f(*el[1:]) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = Env() +def REP(str): + return PRINT(EVAL(READ(str), repl_env)) + +# core.py: defined using python +for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) +repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) +repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if len(sys.argv) >= 2: + REP('(load-file "' + sys.argv[1] + '")') + sys.exit(0) + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/step8_macros.py b/impls/python/step8_macros.py index 4d67304e5c..188e703e4b 100644 --- a/impls/python/step8_macros.py +++ b/impls/python/step8_macros.py @@ -1,155 +1,155 @@ -import functools -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def qq_loop(acc, elt): - if types._list_Q(elt) and len(elt) == 2 and elt[0] == u'splice-unquote': - return types._list(types._symbol(u'concat'), elt[1], acc) - else: - return types._list(types._symbol(u'cons'), quasiquote(elt), acc) - -def qq_foldr(seq): - return functools.reduce(qq_loop, reversed(seq), types._list()) - -def quasiquote(ast): - if types._list_Q(ast): - if len(ast) == 2 and ast[0] == u'unquote': - return ast[1] - else: - return qq_foldr(ast) - elif types._hash_map_Q(ast) or types._symbol_Q(ast): - return types._list(types._symbol(u'quote'), ast) - elif types._vector_Q (ast): - return types._list(types._symbol(u'vec'), qq_foldr(ast)) - else: - return ast - -def is_macro_call(ast, env): - return (types._list_Q(ast) and - types._symbol_Q(ast[0]) and - env.find(ast[0]) and - hasattr(env.get(ast[0]), '_ismacro_')) - -def macroexpand(ast, env): - while is_macro_call(ast, env): - mac = env.get(ast[0]) - ast = mac(*ast[1:]) - return ast - -def eval_ast(ast, env): - if types._symbol_Q(ast): - return env.get(ast) - elif types._list_Q(ast): - return types._list(*map(lambda a: EVAL(a, env), ast)) - elif types._vector_Q(ast): - return types._vector(*map(lambda a: EVAL(a, env), ast)) - elif types._hash_map_Q(ast): - return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - ast = macroexpand(ast, env) - if not types._list_Q(ast): - return eval_ast(ast, env) - if len(ast) == 0: return ast - a0 = ast[0] - - if "def!" == a0: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif "let*" == a0: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - # Continue loop (TCO) - elif "quote" == a0: - return ast[1] - elif "quasiquoteexpand" == a0: - return quasiquote(ast[1]); - elif "quasiquote" == a0: - ast = quasiquote(ast[1]); - # Continue loop (TCO) - elif 'defmacro!' == a0: - func = types._clone(EVAL(ast[2], env)) - func._ismacro_ = True - return env.set(ast[1], func) - elif 'macroexpand' == a0: - return macroexpand(ast[1], env) - elif "do" == a0: - eval_ast(ast[1:-1], env) - ast = ast[-1] - # Continue loop (TCO) - elif "if" == a0: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is None or cond is False: - if len(ast) > 3: ast = ast[3] - else: ast = None - else: - ast = a2 - # Continue loop (TCO) - elif "fn*" == a0: - a1, a2 = ast[1], ast[2] - return types._function(EVAL, Env, a2, env, a1) - else: - el = eval_ast(ast, env) - f = el[0] - if hasattr(f, '__ast__'): - ast = f.__ast__ - env = f.__gen_env__(el[1:]) - else: - return f(*el[1:]) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = Env() -def REP(str): - return PRINT(EVAL(READ(str), repl_env)) - -# core.py: defined using python -for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) -repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) -repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))") - -if len(sys.argv) >= 2: - REP('(load-file "' + sys.argv[1] + '")') - sys.exit(0) - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import functools +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def qq_loop(acc, elt): + if types._list_Q(elt) and len(elt) == 2 and elt[0] == u'splice-unquote': + return types._list(types._symbol(u'concat'), elt[1], acc) + else: + return types._list(types._symbol(u'cons'), quasiquote(elt), acc) + +def qq_foldr(seq): + return functools.reduce(qq_loop, reversed(seq), types._list()) + +def quasiquote(ast): + if types._list_Q(ast): + if len(ast) == 2 and ast[0] == u'unquote': + return ast[1] + else: + return qq_foldr(ast) + elif types._hash_map_Q(ast) or types._symbol_Q(ast): + return types._list(types._symbol(u'quote'), ast) + elif types._vector_Q (ast): + return types._list(types._symbol(u'vec'), qq_foldr(ast)) + else: + return ast + +def is_macro_call(ast, env): + return (types._list_Q(ast) and + types._symbol_Q(ast[0]) and + env.find(ast[0]) and + hasattr(env.get(ast[0]), '_ismacro_')) + +def macroexpand(ast, env): + while is_macro_call(ast, env): + mac = env.get(ast[0]) + ast = mac(*ast[1:]) + return ast + +def eval_ast(ast, env): + if types._symbol_Q(ast): + return env.get(ast) + elif types._list_Q(ast): + return types._list(*map(lambda a: EVAL(a, env), ast)) + elif types._vector_Q(ast): + return types._vector(*map(lambda a: EVAL(a, env), ast)) + elif types._hash_map_Q(ast): + return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + ast = macroexpand(ast, env) + if not types._list_Q(ast): + return eval_ast(ast, env) + if len(ast) == 0: return ast + a0 = ast[0] + + if "def!" == a0: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif "let*" == a0: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + # Continue loop (TCO) + elif "quote" == a0: + return ast[1] + elif "quasiquoteexpand" == a0: + return quasiquote(ast[1]); + elif "quasiquote" == a0: + ast = quasiquote(ast[1]); + # Continue loop (TCO) + elif 'defmacro!' == a0: + func = types._clone(EVAL(ast[2], env)) + func._ismacro_ = True + return env.set(ast[1], func) + elif 'macroexpand' == a0: + return macroexpand(ast[1], env) + elif "do" == a0: + eval_ast(ast[1:-1], env) + ast = ast[-1] + # Continue loop (TCO) + elif "if" == a0: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is None or cond is False: + if len(ast) > 3: ast = ast[3] + else: ast = None + else: + ast = a2 + # Continue loop (TCO) + elif "fn*" == a0: + a1, a2 = ast[1], ast[2] + return types._function(EVAL, Env, a2, env, a1) + else: + el = eval_ast(ast, env) + f = el[0] + if hasattr(f, '__ast__'): + ast = f.__ast__ + env = f.__gen_env__(el[1:]) + else: + return f(*el[1:]) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = Env() +def REP(str): + return PRINT(EVAL(READ(str), repl_env)) + +# core.py: defined using python +for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) +repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) +repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))") + +if len(sys.argv) >= 2: + REP('(load-file "' + sys.argv[1] + '")') + sys.exit(0) + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/step9_try.py b/impls/python/step9_try.py index 8162ab3cdc..8e75a02cf9 100644 --- a/impls/python/step9_try.py +++ b/impls/python/step9_try.py @@ -1,179 +1,179 @@ -import functools -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def qq_loop(acc, elt): - if types._list_Q(elt) and len(elt) == 2 and elt[0] == u'splice-unquote': - return types._list(types._symbol(u'concat'), elt[1], acc) - else: - return types._list(types._symbol(u'cons'), quasiquote(elt), acc) - -def qq_foldr(seq): - return functools.reduce(qq_loop, reversed(seq), types._list()) - -def quasiquote(ast): - if types._list_Q(ast): - if len(ast) == 2 and ast[0] == u'unquote': - return ast[1] - else: - return qq_foldr(ast) - elif types._hash_map_Q(ast) or types._symbol_Q(ast): - return types._list(types._symbol(u'quote'), ast) - elif types._vector_Q (ast): - return types._list(types._symbol(u'vec'), qq_foldr(ast)) - else: - return ast - -def is_macro_call(ast, env): - return (types._list_Q(ast) and - types._symbol_Q(ast[0]) and - env.find(ast[0]) and - hasattr(env.get(ast[0]), '_ismacro_')) - -def macroexpand(ast, env): - while is_macro_call(ast, env): - mac = env.get(ast[0]) - ast = mac(*ast[1:]) - return ast - -def eval_ast(ast, env): - if types._symbol_Q(ast): - return env.get(ast) - elif types._list_Q(ast): - return types._list(*map(lambda a: EVAL(a, env), ast)) - elif types._vector_Q(ast): - return types._vector(*map(lambda a: EVAL(a, env), ast)) - elif types._hash_map_Q(ast): - return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - ast = macroexpand(ast, env) - if not types._list_Q(ast): - return eval_ast(ast, env) - if len(ast) == 0: return ast - a0 = ast[0] - - if "def!" == a0: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif "let*" == a0: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - # Continue loop (TCO) - elif "quote" == a0: - return ast[1] - elif "quasiquoteexpand" == a0: - return quasiquote(ast[1]); - elif "quasiquote" == a0: - ast = quasiquote(ast[1]); - # Continue loop (TCO) - elif 'defmacro!' == a0: - func = types._clone(EVAL(ast[2], env)) - func._ismacro_ = True - return env.set(ast[1], func) - elif 'macroexpand' == a0: - return macroexpand(ast[1], env) - elif "py!*" == a0: - if sys.version_info[0] >= 3: - exec(compile(ast[1], '', 'single'), globals()) - else: - exec(compile(ast[1], '', 'single') in globals()) - return None - elif "try*" == a0: - if len(ast) < 3: - return EVAL(ast[1], env) - a1, a2 = ast[1], ast[2] - if a2[0] == "catch*": - err = None - try: - return EVAL(a1, env) - except types.MalException as exc: - err = exc.object - except Exception as exc: - err = exc.args[0] - catch_env = Env(env, [a2[1]], [err]) - return EVAL(a2[2], catch_env) - else: - return EVAL(a1, env); - elif "do" == a0: - eval_ast(ast[1:-1], env) - ast = ast[-1] - # Continue loop (TCO) - elif "if" == a0: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is None or cond is False: - if len(ast) > 3: ast = ast[3] - else: ast = None - else: - ast = a2 - # Continue loop (TCO) - elif "fn*" == a0: - a1, a2 = ast[1], ast[2] - return types._function(EVAL, Env, a2, env, a1) - else: - el = eval_ast(ast, env) - f = el[0] - if hasattr(f, '__ast__'): - ast = f.__ast__ - env = f.__gen_env__(el[1:]) - else: - return f(*el[1:]) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = Env() -def REP(str): - return PRINT(EVAL(READ(str), repl_env)) - -# core.py: defined using python -for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) -repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) -repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) - -# core.mal: defined using the language itself -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))") - -if len(sys.argv) >= 2: - REP('(load-file "' + sys.argv[1] + '")') - sys.exit(0) - -# repl loop -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except types.MalException as e: - print("Error:", printer._pr_str(e.object)) - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import functools +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def qq_loop(acc, elt): + if types._list_Q(elt) and len(elt) == 2 and elt[0] == u'splice-unquote': + return types._list(types._symbol(u'concat'), elt[1], acc) + else: + return types._list(types._symbol(u'cons'), quasiquote(elt), acc) + +def qq_foldr(seq): + return functools.reduce(qq_loop, reversed(seq), types._list()) + +def quasiquote(ast): + if types._list_Q(ast): + if len(ast) == 2 and ast[0] == u'unquote': + return ast[1] + else: + return qq_foldr(ast) + elif types._hash_map_Q(ast) or types._symbol_Q(ast): + return types._list(types._symbol(u'quote'), ast) + elif types._vector_Q (ast): + return types._list(types._symbol(u'vec'), qq_foldr(ast)) + else: + return ast + +def is_macro_call(ast, env): + return (types._list_Q(ast) and + types._symbol_Q(ast[0]) and + env.find(ast[0]) and + hasattr(env.get(ast[0]), '_ismacro_')) + +def macroexpand(ast, env): + while is_macro_call(ast, env): + mac = env.get(ast[0]) + ast = mac(*ast[1:]) + return ast + +def eval_ast(ast, env): + if types._symbol_Q(ast): + return env.get(ast) + elif types._list_Q(ast): + return types._list(*map(lambda a: EVAL(a, env), ast)) + elif types._vector_Q(ast): + return types._vector(*map(lambda a: EVAL(a, env), ast)) + elif types._hash_map_Q(ast): + return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + ast = macroexpand(ast, env) + if not types._list_Q(ast): + return eval_ast(ast, env) + if len(ast) == 0: return ast + a0 = ast[0] + + if "def!" == a0: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif "let*" == a0: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + # Continue loop (TCO) + elif "quote" == a0: + return ast[1] + elif "quasiquoteexpand" == a0: + return quasiquote(ast[1]); + elif "quasiquote" == a0: + ast = quasiquote(ast[1]); + # Continue loop (TCO) + elif 'defmacro!' == a0: + func = types._clone(EVAL(ast[2], env)) + func._ismacro_ = True + return env.set(ast[1], func) + elif 'macroexpand' == a0: + return macroexpand(ast[1], env) + elif "py!*" == a0: + if sys.version_info[0] >= 3: + exec(compile(ast[1], '', 'single'), globals()) + else: + exec(compile(ast[1], '', 'single') in globals()) + return None + elif "try*" == a0: + if len(ast) < 3: + return EVAL(ast[1], env) + a1, a2 = ast[1], ast[2] + if a2[0] == "catch*": + err = None + try: + return EVAL(a1, env) + except types.MalException as exc: + err = exc.object + except Exception as exc: + err = exc.args[0] + catch_env = Env(env, [a2[1]], [err]) + return EVAL(a2[2], catch_env) + else: + return EVAL(a1, env); + elif "do" == a0: + eval_ast(ast[1:-1], env) + ast = ast[-1] + # Continue loop (TCO) + elif "if" == a0: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is None or cond is False: + if len(ast) > 3: ast = ast[3] + else: ast = None + else: + ast = a2 + # Continue loop (TCO) + elif "fn*" == a0: + a1, a2 = ast[1], ast[2] + return types._function(EVAL, Env, a2, env, a1) + else: + el = eval_ast(ast, env) + f = el[0] + if hasattr(f, '__ast__'): + ast = f.__ast__ + env = f.__gen_env__(el[1:]) + else: + return f(*el[1:]) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = Env() +def REP(str): + return PRINT(EVAL(READ(str), repl_env)) + +# core.py: defined using python +for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) +repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) +repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) + +# core.mal: defined using the language itself +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))") + +if len(sys.argv) >= 2: + REP('(load-file "' + sys.argv[1] + '")') + sys.exit(0) + +# repl loop +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except types.MalException as e: + print("Error:", printer._pr_str(e.object)) + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/stepA_mal.py b/impls/python/stepA_mal.py index 2ac1d679c3..d534a29546 100644 --- a/impls/python/stepA_mal.py +++ b/impls/python/stepA_mal.py @@ -1,184 +1,184 @@ -import functools -import sys, traceback -import mal_readline -import mal_types as types -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def qq_loop(acc, elt): - if types._list_Q(elt) and len(elt) == 2 and elt[0] == u'splice-unquote': - return types._list(types._symbol(u'concat'), elt[1], acc) - else: - return types._list(types._symbol(u'cons'), quasiquote(elt), acc) - -def qq_foldr(seq): - return functools.reduce(qq_loop, reversed(seq), types._list()) - -def quasiquote(ast): - if types._list_Q(ast): - if len(ast) == 2 and ast[0] == u'unquote': - return ast[1] - else: - return qq_foldr(ast) - elif types._hash_map_Q(ast) or types._symbol_Q(ast): - return types._list(types._symbol(u'quote'), ast) - elif types._vector_Q (ast): - return types._list(types._symbol(u'vec'), qq_foldr(ast)) - else: - return ast - -def is_macro_call(ast, env): - return (types._list_Q(ast) and - types._symbol_Q(ast[0]) and - env.find(ast[0]) and - hasattr(env.get(ast[0]), '_ismacro_')) - -def macroexpand(ast, env): - while is_macro_call(ast, env): - mac = env.get(ast[0]) - ast = mac(*ast[1:]) - return ast - -def eval_ast(ast, env): - if types._symbol_Q(ast): - return env.get(ast) - elif types._list_Q(ast): - return types._list(*map(lambda a: EVAL(a, env), ast)) - elif types._vector_Q(ast): - return types._vector(*map(lambda a: EVAL(a, env), ast)) - elif types._hash_map_Q(ast): - return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - ast = macroexpand(ast, env) - if not types._list_Q(ast): - return eval_ast(ast, env) - if len(ast) == 0: return ast - a0 = ast[0] - - if "def!" == a0: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif "let*" == a0: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env - # Continue loop (TCO) - elif "quote" == a0: - return ast[1] - elif "quasiquoteexpand" == a0: - return quasiquote(ast[1]); - elif "quasiquote" == a0: - ast = quasiquote(ast[1]); - # Continue loop (TCO) - elif 'defmacro!' == a0: - func = types._clone(EVAL(ast[2], env)) - func._ismacro_ = True - return env.set(ast[1], func) - elif 'macroexpand' == a0: - return macroexpand(ast[1], env) - elif "py!*" == a0: - exec(compile(ast[1], '', 'single'), globals()) - return None - elif "py*" == a0: - return types.py_to_mal(eval(ast[1])) - elif "." == a0: - el = eval_ast(ast[2:], env) - f = eval(ast[1]) - return f(*el) - elif "try*" == a0: - if len(ast) < 3: - return EVAL(ast[1], env) - a1, a2 = ast[1], ast[2] - if a2[0] == "catch*": - err = None - try: - return EVAL(a1, env) - except types.MalException as exc: - err = exc.object - except Exception as exc: - err = exc.args[0] - catch_env = Env(env, [a2[1]], [err]) - return EVAL(a2[2], catch_env) - else: - return EVAL(a1, env); - elif "do" == a0: - eval_ast(ast[1:-1], env) - ast = ast[-1] - # Continue loop (TCO) - elif "if" == a0: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is None or cond is False: - if len(ast) > 3: ast = ast[3] - else: ast = None - else: - ast = a2 - # Continue loop (TCO) - elif "fn*" == a0: - a1, a2 = ast[1], ast[2] - return types._function(EVAL, Env, a2, env, a1) - else: - el = eval_ast(ast, env) - f = el[0] - if hasattr(f, '__ast__'): - ast = f.__ast__ - env = f.__gen_env__(el[1:]) - else: - return f(*el[1:]) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = Env() -def REP(str): - return PRINT(EVAL(READ(str), repl_env)) - -# core.py: defined using python -for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) -repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) -repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) - -# core.mal: defined using the language itself -REP("(def! *host-language* \"python\")") -REP("(def! not (fn* (a) (if a false true)))") -REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))") - -if len(sys.argv) >= 2: - REP('(load-file "' + sys.argv[1] + '")') - sys.exit(0) - -# repl loop -REP("(println (str \"Mal [\" *host-language* \"]\"))") -while True: - try: - line = mal_readline.readline("user> ") - if line == None: break - if line == "": continue - print(REP(line)) - except reader.Blank: continue - except types.MalException as e: - print("Error:", printer._pr_str(e.object)) - except Exception as e: - print("".join(traceback.format_exception(*sys.exc_info()))) +import functools +import sys, traceback +import mal_readline +import mal_types as types +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def qq_loop(acc, elt): + if types._list_Q(elt) and len(elt) == 2 and elt[0] == u'splice-unquote': + return types._list(types._symbol(u'concat'), elt[1], acc) + else: + return types._list(types._symbol(u'cons'), quasiquote(elt), acc) + +def qq_foldr(seq): + return functools.reduce(qq_loop, reversed(seq), types._list()) + +def quasiquote(ast): + if types._list_Q(ast): + if len(ast) == 2 and ast[0] == u'unquote': + return ast[1] + else: + return qq_foldr(ast) + elif types._hash_map_Q(ast) or types._symbol_Q(ast): + return types._list(types._symbol(u'quote'), ast) + elif types._vector_Q (ast): + return types._list(types._symbol(u'vec'), qq_foldr(ast)) + else: + return ast + +def is_macro_call(ast, env): + return (types._list_Q(ast) and + types._symbol_Q(ast[0]) and + env.find(ast[0]) and + hasattr(env.get(ast[0]), '_ismacro_')) + +def macroexpand(ast, env): + while is_macro_call(ast, env): + mac = env.get(ast[0]) + ast = mac(*ast[1:]) + return ast + +def eval_ast(ast, env): + if types._symbol_Q(ast): + return env.get(ast) + elif types._list_Q(ast): + return types._list(*map(lambda a: EVAL(a, env), ast)) + elif types._vector_Q(ast): + return types._vector(*map(lambda a: EVAL(a, env), ast)) + elif types._hash_map_Q(ast): + return types.Hash_Map((k, EVAL(v, env)) for k, v in ast.items()) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + ast = macroexpand(ast, env) + if not types._list_Q(ast): + return eval_ast(ast, env) + if len(ast) == 0: return ast + a0 = ast[0] + + if "def!" == a0: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif "let*" == a0: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env + # Continue loop (TCO) + elif "quote" == a0: + return ast[1] + elif "quasiquoteexpand" == a0: + return quasiquote(ast[1]); + elif "quasiquote" == a0: + ast = quasiquote(ast[1]); + # Continue loop (TCO) + elif 'defmacro!' == a0: + func = types._clone(EVAL(ast[2], env)) + func._ismacro_ = True + return env.set(ast[1], func) + elif 'macroexpand' == a0: + return macroexpand(ast[1], env) + elif "py!*" == a0: + exec(compile(ast[1], '', 'single'), globals()) + return None + elif "py*" == a0: + return types.py_to_mal(eval(ast[1])) + elif "." == a0: + el = eval_ast(ast[2:], env) + f = eval(ast[1]) + return f(*el) + elif "try*" == a0: + if len(ast) < 3: + return EVAL(ast[1], env) + a1, a2 = ast[1], ast[2] + if a2[0] == "catch*": + err = None + try: + return EVAL(a1, env) + except types.MalException as exc: + err = exc.object + except Exception as exc: + err = exc.args[0] + catch_env = Env(env, [a2[1]], [err]) + return EVAL(a2[2], catch_env) + else: + return EVAL(a1, env); + elif "do" == a0: + eval_ast(ast[1:-1], env) + ast = ast[-1] + # Continue loop (TCO) + elif "if" == a0: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is None or cond is False: + if len(ast) > 3: ast = ast[3] + else: ast = None + else: + ast = a2 + # Continue loop (TCO) + elif "fn*" == a0: + a1, a2 = ast[1], ast[2] + return types._function(EVAL, Env, a2, env, a1) + else: + el = eval_ast(ast, env) + f = el[0] + if hasattr(f, '__ast__'): + ast = f.__ast__ + env = f.__gen_env__(el[1:]) + else: + return f(*el[1:]) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = Env() +def REP(str): + return PRINT(EVAL(READ(str), repl_env)) + +# core.py: defined using python +for k, v in core.ns.items(): repl_env.set(types._symbol(k), v) +repl_env.set(types._symbol('eval'), lambda ast: EVAL(ast, repl_env)) +repl_env.set(types._symbol('*ARGV*'), types._list(*sys.argv[2:])) + +# core.mal: defined using the language itself +REP("(def! *host-language* \"python\")") +REP("(def! not (fn* (a) (if a false true)))") +REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))") + +if len(sys.argv) >= 2: + REP('(load-file "' + sys.argv[1] + '")') + sys.exit(0) + +# repl loop +REP("(println (str \"Mal [\" *host-language* \"]\"))") +while True: + try: + line = mal_readline.readline("user> ") + if line == None: break + if line == "": continue + print(REP(line)) + except reader.Blank: continue + except types.MalException as e: + print("Error:", printer._pr_str(e.object)) + except Exception as e: + print("".join(traceback.format_exception(*sys.exc_info()))) diff --git a/impls/python/tests/step5_tco.mal b/impls/python/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/python/tests/step5_tco.mal +++ b/impls/python/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/python/tests/stepA_mal.mal b/impls/python/tests/stepA_mal.mal index 44669f8582..f607f02877 100644 --- a/impls/python/tests/stepA_mal.mal +++ b/impls/python/tests/stepA_mal.mal @@ -1,23 +1,23 @@ -;; Testing Python interop - -;; Testing Python expressions -(py* "7") -;=>7 -(py* "'7'") -;=>"7" -(py* "[7,8,9]") -;=>(7 8 9) -(py* "' '.join(['X'+c+'Y' for c in ['a','b','c']])") -;=>"XaY XbY XcY" -(py* "[1 + x for x in [1,2,3]]") -;=>(2 3 4) - -;; Testing Python statements -(py!* "print('hello')") -;/hello -;=>nil - -(py!* "foo = 19 % 4") -;=>nil -(py* "foo") -;=>3 +;; Testing Python interop + +;; Testing Python expressions +(py* "7") +;=>7 +(py* "'7'") +;=>"7" +(py* "[7,8,9]") +;=>(7 8 9) +(py* "' '.join(['X'+c+'Y' for c in ['a','b','c']])") +;=>"XaY XbY XcY" +(py* "[1 + x for x in [1,2,3]]") +;=>(2 3 4) + +;; Testing Python statements +(py!* "print('hello')") +;/hello +;=>nil + +(py!* "foo = 19 % 4") +;=>nil +(py* "foo") +;=>3 diff --git a/impls/r/Dockerfile b/impls/r/Dockerfile index 42611aeca2..d7ae9d7c99 100644 --- a/impls/r/Dockerfile +++ b/impls/r/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install r-base-core +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install r-base-core diff --git a/impls/r/Makefile b/impls/r/Makefile index 1b7e65e27f..840f784416 100644 --- a/impls/r/Makefile +++ b/impls/r/Makefile @@ -1,35 +1,35 @@ -SOURCES_BASE = readline.r types.r reader.r printer.r -SOURCES_LISP = env.r core.r stepA_mal.r -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -STEPS = step0_repl.r step1_read_print.r step2_eval.r step3_env.r \ - step4_if_fn_do.r step5_tco.r step6_file.r \ - step7_quote.r step8_macros.r step9_try.r stepA_mal.r - -all: libs - -dist: mal.r mal - -mal.r: $(SOURCES) - cat $+ | grep -v " source(" > $@ - -mal: mal.r - echo "#!/usr/bin/env Rscript" > $@ - cat $< >> $@ - chmod +x $@ - -$(STEPS): libs - -.PHONY: -libs: lib/rdyncall - -lib/rdyncall: - curl -O http://cran.r-project.org/src/contrib/Archive/rdyncall/rdyncall_0.7.5.tar.gz - mkdir -p lib - R CMD INSTALL rdyncall_0.7.5.tar.gz -l lib/ - rm rdyncall_0.7.5.tar.gz - -clean: - rm -f mal.r mal - - +SOURCES_BASE = readline.r types.r reader.r printer.r +SOURCES_LISP = env.r core.r stepA_mal.r +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +STEPS = step0_repl.r step1_read_print.r step2_eval.r step3_env.r \ + step4_if_fn_do.r step5_tco.r step6_file.r \ + step7_quote.r step8_macros.r step9_try.r stepA_mal.r + +all: libs + +dist: mal.r mal + +mal.r: $(SOURCES) + cat $+ | grep -v " source(" > $@ + +mal: mal.r + echo "#!/usr/bin/env Rscript" > $@ + cat $< >> $@ + chmod +x $@ + +$(STEPS): libs + +.PHONY: +libs: lib/rdyncall + +lib/rdyncall: + curl -O http://cran.r-project.org/src/contrib/Archive/rdyncall/rdyncall_0.7.5.tar.gz + mkdir -p lib + R CMD INSTALL rdyncall_0.7.5.tar.gz -l lib/ + rm rdyncall_0.7.5.tar.gz + +clean: + rm -f mal.r mal + + diff --git a/impls/r/core.r b/impls/r/core.r index 9a12de3a96..1b9cafeb94 100644 --- a/impls/r/core.r +++ b/impls/r/core.r @@ -1,204 +1,204 @@ -..core.. <- TRUE - -if(!exists("..types..")) source("types.r") -if(!exists("..printer..")) source("printer.r") - - -# String functions - -pr_str <- function(...) - .pr_list(list(...), print_readably=TRUE, join=" ") - -str <- function(...) - .pr_list(list(...), print_readably=FALSE, join="") - -prn <- function(...) { - cat(.pr_list(list(...), print_readably=TRUE, join=" ")) - cat("\n") - nil -} - -println <- function(...) { - cat(.pr_list(list(...), print_readably=FALSE, join=" ")) - cat("\n") - nil -} - -do_readline <- function(prompt) { - l <- readline(prompt) - if (is.null(l)) nil else l -} - -# Hash Map functions -do_get <- function(hm,k) { - if (class(hm) == "nil") return(nil) - v <- hm[[k]] - if (is.null(v)) nil else v -} -contains_q <-function(hm,k) { - if (class(hm) == "nil") return(FALSE) - if (is.null(hm[[k]])) FALSE else TRUE -} - -# Sequence functions -cons <- function(a,b) { - new_lst <- append(list(a), b) - new.listl(new_lst) -} - -nth <- function(a,b) { - if (b < length(a)) - a[[b+1]] - else - throw("nth: index out of range") -} - -do_concat <- function(...) { - new_lst <- list() - for(l in list(...)) { - new_lst <- append(new_lst, l) - } - new.listl(new_lst) -} - -do_apply <- function(f, ...) { - p <- list(...) - args <- list() - if (length(p) > 1) { - for(l in slice(p, 1, length(p)-1)) { - args[[length(args)+1]] <- l - } - } - args <- append(args, p[[length(p)]]) - fapply(f, args) -} - -map <- function(f, seq) { - new.listl(lapply(seq, function(el) fapply(f, list(el)))) -} - -conj <- function(obj, ...) { - p <- list(...) - new_obj <- .clone(obj) - if (.list_q(obj)) { - if (length(p) > 0) { - for(l in p) new_obj <- append(list(l), new_obj) - } - new.listl(new_obj) - } else if (.vector_q(obj)) { - if (length(p) > 0) { - for(l in p) new_obj <- append(new_obj, list(l)) - } - new.vectorl(new_obj) - } else { - throw("conj called on non-sequence") - } -} - -do_seq <- function(obj) { - if (.list_q(obj)) { - if (length(obj) == 0) nil else obj - } else if (.vector_q(obj)) { - if (length(obj) == 0) nil else new.listl(.clone(obj)) - } else if (.string_q(obj)) { - if (nchar(obj) == 0) nil else new.listl(strsplit(obj, "")[[1]]) - } else if (class(obj) == "nil") { - nil - } else { - throw("seq: called on non-sequence") - } -} - - -# Metadata functions -with_meta <- function(obj, m) { - new_obj <- .clone(obj) - attr(new_obj, "meta") <- m - new_obj -} - -meta <- function(obj) { - m <- attr(obj, "meta") - if (is.null(m)) nil else m -} - -# Atom functions -deref <- function(atm) atm$val -reset_bang <- function (atm, val) { atm$val <- val; val } -swap_bang <- function (atm, f, ...) { - p <- list(...) - args <- list(atm$val) - if (length(p) > 0) { - for(l in p) args[[length(args)+1]] <- l - } - atm$val <- fapply(f, args) -} - -core_ns <- list( - "="=function(a,b) .equal_q(a,b), - "throw"=function(err) throw(err), - "nil?"=.nil_q, - "true?"=.true_q, - "false?"=.false_q, - "string?"=.string_q, - "symbol"=new.symbol, - "symbol?"=.symbol_q, - "keyword"=new.keyword, - "keyword?"=.keyword_q, - "number?"=.number_q, - "fn?"=.fn_q, - "macro?"=.macro_q, - - "pr-str"=pr_str, - "str"=str, - "prn"=prn, - "println"=println, - "readline"=do_readline, - "read-string"=function(str) read_str(str), - "slurp"=function(path) readChar(path, file.info(path)$size), - "<"=function(a,b) a"=function(a,b) a>b, - ">="=function(a,b) a>=b, - "+"=function(a,b) a+b, - "-"=function(a,b) a-b, - "*"=function(a,b) a*b, - "/"=function(a,b) a/b, - "time-ms"=function() round(as.numeric(Sys.time())*1000), - - "list"=new.list, - "list?"=function(a) .list_q(a), - "vector"=new.vector, - "vector?"=function(a) .vector_q(a), - "hash-map"=new.hash_map, - "map?"=function(a) .hash_map_q(a), - "assoc"=function(hm,...) .assoc(hm,list(...)), - "dissoc"=function(hm,...) .dissoc(hm,list(...)), - "get"=do_get, - "contains?"=contains_q, - "keys"=function(hm) new.listl(ls(hm)), - "vals"=function(hm) new.listl(lapply(ls(hm), function(x) hm[[x]])), - - "sequential?"=.sequential_q, - "cons"=cons, - "concat"=do_concat, - "vec"=new.vectorl, - "nth"=nth, - "first"=function(a) if (.nil_q(a) || length(a) < 1) nil else a[[1]], - "rest"=function(a) if (.nil_q(a)) new.list() else new.listl(slice(a,2)), - "empty?"=function(a) .sequential_q(a) && length(a) == 0, - "count"=function(a) if (.nil_q(a)) 0 else length(a), - "apply"=do_apply, - "map"=map, - - "conj"=conj, - "seq"=do_seq, - - "with-meta"=with_meta, - "meta"=meta, - "atom"=new.atom, - "atom?"=.atom_q, - "deref"=deref, - "reset!"=reset_bang, - "swap!"=swap_bang -) +..core.. <- TRUE + +if(!exists("..types..")) source("types.r") +if(!exists("..printer..")) source("printer.r") + + +# String functions + +pr_str <- function(...) + .pr_list(list(...), print_readably=TRUE, join=" ") + +str <- function(...) + .pr_list(list(...), print_readably=FALSE, join="") + +prn <- function(...) { + cat(.pr_list(list(...), print_readably=TRUE, join=" ")) + cat("\n") + nil +} + +println <- function(...) { + cat(.pr_list(list(...), print_readably=FALSE, join=" ")) + cat("\n") + nil +} + +do_readline <- function(prompt) { + l <- readline(prompt) + if (is.null(l)) nil else l +} + +# Hash Map functions +do_get <- function(hm,k) { + if (class(hm) == "nil") return(nil) + v <- hm[[k]] + if (is.null(v)) nil else v +} +contains_q <-function(hm,k) { + if (class(hm) == "nil") return(FALSE) + if (is.null(hm[[k]])) FALSE else TRUE +} + +# Sequence functions +cons <- function(a,b) { + new_lst <- append(list(a), b) + new.listl(new_lst) +} + +nth <- function(a,b) { + if (b < length(a)) + a[[b+1]] + else + throw("nth: index out of range") +} + +do_concat <- function(...) { + new_lst <- list() + for(l in list(...)) { + new_lst <- append(new_lst, l) + } + new.listl(new_lst) +} + +do_apply <- function(f, ...) { + p <- list(...) + args <- list() + if (length(p) > 1) { + for(l in slice(p, 1, length(p)-1)) { + args[[length(args)+1]] <- l + } + } + args <- append(args, p[[length(p)]]) + fapply(f, args) +} + +map <- function(f, seq) { + new.listl(lapply(seq, function(el) fapply(f, list(el)))) +} + +conj <- function(obj, ...) { + p <- list(...) + new_obj <- .clone(obj) + if (.list_q(obj)) { + if (length(p) > 0) { + for(l in p) new_obj <- append(list(l), new_obj) + } + new.listl(new_obj) + } else if (.vector_q(obj)) { + if (length(p) > 0) { + for(l in p) new_obj <- append(new_obj, list(l)) + } + new.vectorl(new_obj) + } else { + throw("conj called on non-sequence") + } +} + +do_seq <- function(obj) { + if (.list_q(obj)) { + if (length(obj) == 0) nil else obj + } else if (.vector_q(obj)) { + if (length(obj) == 0) nil else new.listl(.clone(obj)) + } else if (.string_q(obj)) { + if (nchar(obj) == 0) nil else new.listl(strsplit(obj, "")[[1]]) + } else if (class(obj) == "nil") { + nil + } else { + throw("seq: called on non-sequence") + } +} + + +# Metadata functions +with_meta <- function(obj, m) { + new_obj <- .clone(obj) + attr(new_obj, "meta") <- m + new_obj +} + +meta <- function(obj) { + m <- attr(obj, "meta") + if (is.null(m)) nil else m +} + +# Atom functions +deref <- function(atm) atm$val +reset_bang <- function (atm, val) { atm$val <- val; val } +swap_bang <- function (atm, f, ...) { + p <- list(...) + args <- list(atm$val) + if (length(p) > 0) { + for(l in p) args[[length(args)+1]] <- l + } + atm$val <- fapply(f, args) +} + +core_ns <- list( + "="=function(a,b) .equal_q(a,b), + "throw"=function(err) throw(err), + "nil?"=.nil_q, + "true?"=.true_q, + "false?"=.false_q, + "string?"=.string_q, + "symbol"=new.symbol, + "symbol?"=.symbol_q, + "keyword"=new.keyword, + "keyword?"=.keyword_q, + "number?"=.number_q, + "fn?"=.fn_q, + "macro?"=.macro_q, + + "pr-str"=pr_str, + "str"=str, + "prn"=prn, + "println"=println, + "readline"=do_readline, + "read-string"=function(str) read_str(str), + "slurp"=function(path) readChar(path, file.info(path)$size), + "<"=function(a,b) a"=function(a,b) a>b, + ">="=function(a,b) a>=b, + "+"=function(a,b) a+b, + "-"=function(a,b) a-b, + "*"=function(a,b) a*b, + "/"=function(a,b) a/b, + "time-ms"=function() round(as.numeric(Sys.time())*1000), + + "list"=new.list, + "list?"=function(a) .list_q(a), + "vector"=new.vector, + "vector?"=function(a) .vector_q(a), + "hash-map"=new.hash_map, + "map?"=function(a) .hash_map_q(a), + "assoc"=function(hm,...) .assoc(hm,list(...)), + "dissoc"=function(hm,...) .dissoc(hm,list(...)), + "get"=do_get, + "contains?"=contains_q, + "keys"=function(hm) new.listl(ls(hm)), + "vals"=function(hm) new.listl(lapply(ls(hm), function(x) hm[[x]])), + + "sequential?"=.sequential_q, + "cons"=cons, + "concat"=do_concat, + "vec"=new.vectorl, + "nth"=nth, + "first"=function(a) if (.nil_q(a) || length(a) < 1) nil else a[[1]], + "rest"=function(a) if (.nil_q(a)) new.list() else new.listl(slice(a,2)), + "empty?"=function(a) .sequential_q(a) && length(a) == 0, + "count"=function(a) if (.nil_q(a)) 0 else length(a), + "apply"=do_apply, + "map"=map, + + "conj"=conj, + "seq"=do_seq, + + "with-meta"=with_meta, + "meta"=meta, + "atom"=new.atom, + "atom?"=.atom_q, + "deref"=deref, + "reset!"=reset_bang, + "swap!"=swap_bang +) diff --git a/impls/r/env.r b/impls/r/env.r index 6924881d87..04929eb81f 100644 --- a/impls/r/env.r +++ b/impls/r/env.r @@ -1,42 +1,42 @@ -..env.. <- TRUE - -if(!exists("..types..")) source("types.r") - -new.Env <- function(outer=emptyenv(), binds=list(), exprs=list()) { - e <- structure(new.env(parent=outer), class="Env") - - if (length(binds) > 0) { - for(i in seq(length(binds))) { - b <- binds[[i]] - if (b == "&") { - e[[binds[[i+1]]]] <- - slice(exprs, i, length(exprs)) - break - } else { - e[[b]] <- exprs[[i]] - } - } - } - e -} - -Env.find <- function(e, key) { - if (exists(key, envir=e, inherits=FALSE)) { - e - } else if (!identical(parent.env(e), emptyenv())) { - Env.find(parent.env(e), key) - } else { - nil - } -} - -Env.set <- function(e, key, val) { - e[[key]] <- val - invisible(val) -} - -Env.get <- function(e, key) { - e <- Env.find(e, key) - if (.nil_q(e)) throw(concat("'", key, "' not found")) - e[[key]] -} +..env.. <- TRUE + +if(!exists("..types..")) source("types.r") + +new.Env <- function(outer=emptyenv(), binds=list(), exprs=list()) { + e <- structure(new.env(parent=outer), class="Env") + + if (length(binds) > 0) { + for(i in seq(length(binds))) { + b <- binds[[i]] + if (b == "&") { + e[[binds[[i+1]]]] <- + slice(exprs, i, length(exprs)) + break + } else { + e[[b]] <- exprs[[i]] + } + } + } + e +} + +Env.find <- function(e, key) { + if (exists(key, envir=e, inherits=FALSE)) { + e + } else if (!identical(parent.env(e), emptyenv())) { + Env.find(parent.env(e), key) + } else { + nil + } +} + +Env.set <- function(e, key, val) { + e[[key]] <- val + invisible(val) +} + +Env.get <- function(e, key) { + e <- Env.find(e, key) + if (.nil_q(e)) throw(concat("'", key, "' not found")) + e[[key]] +} diff --git a/impls/r/printer.r b/impls/r/printer.r index ed8cbd42a4..e5b655782c 100644 --- a/impls/r/printer.r +++ b/impls/r/printer.r @@ -1,57 +1,57 @@ -..printer.. <- TRUE - -if(!exists("..types..")) source("types.r") - -.pr_list <- function(lst, print_readably=TRUE, join="") { - concatl(lapply(lst, - function(e) .pr_str(e, print_readably)), sep=join) -} - -.pr_str <- function(exp, print_readably=TRUE) { - pr <- print_readably - switch(class(exp), - "List"={ - paste("(", .pr_list(exp, pr, " "), ")", sep="", collapse="") - }, - "Vector"={ - paste("[", .pr_list(exp, pr, " "), "]", sep="", collapse="") - }, - "HashMap"={ - hlst <- list() - if (length(exp) > 0) { - for(k in ls(exp)) { - hlst[[length(hlst)+1]] <- k - hlst[[length(hlst)+1]] <- exp[[k]] - } - } - paste("{", .pr_list(hlst, pr, " "), "}", sep="", collapse="") - }, - "character"={ - if (substring(exp,1,1) == "\u029e") { - concat(":", substring(exp,2)) - } else if (substring(exp,1,8) == "") { - # terrible hack, appears in 3.1.1 on Utopic - concat(":", substring(exp,9)) - } else if (print_readably) { - paste("\"", - gsub("\\n", "\\\\n", - gsub("\\\"", "\\\\\"", - gsub("\\\\", "\\\\\\\\", exp))), - "\"", sep="", collapse="") - } else { - exp - } - }, - "Symbol"={ exp }, - "nil"={ "nil" }, - "logical"={ tolower(exp) }, - "MalFunc"={ - paste("(fn* ", .pr_str(exp$params,TRUE), - " ", .pr_str(exp$ast, TRUE), ")", sep="") - }, - "function"={ "<#function>" }, - "Atom"={ - paste("(atom ", .pr_str(exp$val,TRUE), ")", sep="") - }, - { toString(exp) }) -} +..printer.. <- TRUE + +if(!exists("..types..")) source("types.r") + +.pr_list <- function(lst, print_readably=TRUE, join="") { + concatl(lapply(lst, + function(e) .pr_str(e, print_readably)), sep=join) +} + +.pr_str <- function(exp, print_readably=TRUE) { + pr <- print_readably + switch(class(exp), + "List"={ + paste("(", .pr_list(exp, pr, " "), ")", sep="", collapse="") + }, + "Vector"={ + paste("[", .pr_list(exp, pr, " "), "]", sep="", collapse="") + }, + "HashMap"={ + hlst <- list() + if (length(exp) > 0) { + for(k in ls(exp)) { + hlst[[length(hlst)+1]] <- k + hlst[[length(hlst)+1]] <- exp[[k]] + } + } + paste("{", .pr_list(hlst, pr, " "), "}", sep="", collapse="") + }, + "character"={ + if (substring(exp,1,1) == "\u029e") { + concat(":", substring(exp,2)) + } else if (substring(exp,1,8) == "") { + # terrible hack, appears in 3.1.1 on Utopic + concat(":", substring(exp,9)) + } else if (print_readably) { + paste("\"", + gsub("\\n", "\\\\n", + gsub("\\\"", "\\\\\"", + gsub("\\\\", "\\\\\\\\", exp))), + "\"", sep="", collapse="") + } else { + exp + } + }, + "Symbol"={ exp }, + "nil"={ "nil" }, + "logical"={ tolower(exp) }, + "MalFunc"={ + paste("(fn* ", .pr_str(exp$params,TRUE), + " ", .pr_str(exp$ast, TRUE), ")", sep="") + }, + "function"={ "<#function>" }, + "Atom"={ + paste("(atom ", .pr_str(exp$val,TRUE), ")", sep="") + }, + { toString(exp) }) +} diff --git a/impls/r/reader.r b/impls/r/reader.r index dd782991f8..796b6190c6 100644 --- a/impls/r/reader.r +++ b/impls/r/reader.r @@ -1,141 +1,141 @@ -..reader.. <- TRUE - -if(!exists("..types..")) source("types.r") - -new.Reader <- function(tokens) { - e <- structure(new.env(), class="Reader") - e$tokens <- tokens - e$position <- 1 - e -} - -Reader.peek <- function(rdr) { - if (rdr$position > length(rdr$tokens)) return(NULL) - rdr$tokens[[rdr$position]] -} - -Reader.next <- function(rdr) { - if (rdr$position > length(rdr$tokens)) return(NULL) - rdr$position <- rdr$position + 1 - rdr$tokens[[rdr$position-1]] -} - -tokenize <- function(str) { - re <- "[\\s,]*(~@|[\\[\\]\\{\\}\\(\\)'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]\\{\\}\\('\"`,;\\)]*)" - m <- lapply(regmatches(str, gregexpr(re, str, perl=TRUE)), - function(e) sub("^[\\s,]+", "", e, perl=TRUE)) - res <- list() - i <- 1 - for(v in m[[1]]) { - if (v == "" || substr(v,1,1) == ";") next - res[[i]] <- v - i <- i+1 - } - res -} - -re_match <- function(re, str) { length(grep(re, c(str))) > 0 } - -read_atom <- function(rdr) { - token <- Reader.next(rdr) - if (re_match("^-?[0-9]+$", token)) { - as.integer(token) - } else if (re_match("^-?[0-9][0-9.]*$", token)) { - as.double(token) - } else if (re_match("^\"(?:\\\\.|[^\\\\\"])*\"$", token)) { - gsub("\x7f", "\\\\", - gsub("\\\\n", "\n", - gsub("\\\\\"", "\"", - gsub("\\\\\\\\", "\x7f", - substr(token, 2, nchar(token)-1))))) - } else if (substr(token,1,1) == "\"") { - throw("expected '\"', got EOF") - } else if (substr(token,1,1) == ":") { - new.keyword(substring(token,2)) - } else if (token == "nil") { - nil - } else if (token == "true") { - TRUE - } else if (token == "false") { - FALSE - } else { - new.symbol(token) - } -} - -read_seq <- function(rdr, start="(", end=")") { - lst <- list() - token <- Reader.next(rdr) - if (token != start) { - throw(concat("expected '", start, "'")) - } - repeat { - token <- Reader.peek(rdr) - if (is.null(token)) { - throw(concat("expected '", end, "', got EOF")) - } - if (token == end) break - lst[[length(lst)+1]] <- read_form(rdr) - } - Reader.next(rdr) - new.listl(lst) -} - -read_form <- function(rdr) { - token <- Reader.peek(rdr) - if (token == "'") { - . <- Reader.next(rdr); - new.list(new.symbol("quote"), read_form(rdr)) - } else if (token == "`") { - . <- Reader.next(rdr); - new.list(new.symbol("quasiquote"), read_form(rdr)) - } else if (token == "~") { - . <- Reader.next(rdr); - new.list(new.symbol("unquote"), read_form(rdr)) - } else if (token == "~@") { - . <- Reader.next(rdr); - new.list(new.symbol("splice-unquote"), read_form(rdr)) - } else if (token == "^") { - . <- Reader.next(rdr) - m <- read_form(rdr) - new.list(new.symbol("with-meta"), read_form(rdr), m) - } else if (token == "@") { - . <- Reader.next(rdr); - new.list(new.symbol("deref"), read_form(rdr)) - } else if (token == ")") { - throw("unexpected ')'") - } else if (token == "(") { - new.listl(read_seq(rdr)) - } else if (token == "]") { - throw("unexpected ']'") - } else if (token == "[") { - new.vectorl(read_seq(rdr, "[", "]")) - } else if (token == "}") { - throw("unexpected '}'") - } else if (token == "{") { - new.hash_mapl(read_seq(rdr, "{", "}")) - } else { - read_atom(rdr) - } -} - -read_str <- function(str) { - tokens <- tokenize(str) - if (length(tokens) == 0) return(nil) - return(read_form(new.Reader(tokens))) -} - -#cat("---\n") -#print(tokenize("123")) -#cat("---\n") -#print(tokenize(" ( 123 456 abc \"def\" ) ")) - -#rdr <- new.reader(tokenize(" ( 123 456 abc \"def\" ) ")) -#Reader.peek(rdr) -#Reader.next(rdr) -#Reader.next(rdr) -#Reader.next(rdr) -#Reader.next(rdr) -#Reader.next(rdr) -#Reader.next(rdr) -#Reader.next(rdr) +..reader.. <- TRUE + +if(!exists("..types..")) source("types.r") + +new.Reader <- function(tokens) { + e <- structure(new.env(), class="Reader") + e$tokens <- tokens + e$position <- 1 + e +} + +Reader.peek <- function(rdr) { + if (rdr$position > length(rdr$tokens)) return(NULL) + rdr$tokens[[rdr$position]] +} + +Reader.next <- function(rdr) { + if (rdr$position > length(rdr$tokens)) return(NULL) + rdr$position <- rdr$position + 1 + rdr$tokens[[rdr$position-1]] +} + +tokenize <- function(str) { + re <- "[\\s,]*(~@|[\\[\\]\\{\\}\\(\\)'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]\\{\\}\\('\"`,;\\)]*)" + m <- lapply(regmatches(str, gregexpr(re, str, perl=TRUE)), + function(e) sub("^[\\s,]+", "", e, perl=TRUE)) + res <- list() + i <- 1 + for(v in m[[1]]) { + if (v == "" || substr(v,1,1) == ";") next + res[[i]] <- v + i <- i+1 + } + res +} + +re_match <- function(re, str) { length(grep(re, c(str))) > 0 } + +read_atom <- function(rdr) { + token <- Reader.next(rdr) + if (re_match("^-?[0-9]+$", token)) { + as.integer(token) + } else if (re_match("^-?[0-9][0-9.]*$", token)) { + as.double(token) + } else if (re_match("^\"(?:\\\\.|[^\\\\\"])*\"$", token)) { + gsub("\x7f", "\\\\", + gsub("\\\\n", "\n", + gsub("\\\\\"", "\"", + gsub("\\\\\\\\", "\x7f", + substr(token, 2, nchar(token)-1))))) + } else if (substr(token,1,1) == "\"") { + throw("expected '\"', got EOF") + } else if (substr(token,1,1) == ":") { + new.keyword(substring(token,2)) + } else if (token == "nil") { + nil + } else if (token == "true") { + TRUE + } else if (token == "false") { + FALSE + } else { + new.symbol(token) + } +} + +read_seq <- function(rdr, start="(", end=")") { + lst <- list() + token <- Reader.next(rdr) + if (token != start) { + throw(concat("expected '", start, "'")) + } + repeat { + token <- Reader.peek(rdr) + if (is.null(token)) { + throw(concat("expected '", end, "', got EOF")) + } + if (token == end) break + lst[[length(lst)+1]] <- read_form(rdr) + } + Reader.next(rdr) + new.listl(lst) +} + +read_form <- function(rdr) { + token <- Reader.peek(rdr) + if (token == "'") { + . <- Reader.next(rdr); + new.list(new.symbol("quote"), read_form(rdr)) + } else if (token == "`") { + . <- Reader.next(rdr); + new.list(new.symbol("quasiquote"), read_form(rdr)) + } else if (token == "~") { + . <- Reader.next(rdr); + new.list(new.symbol("unquote"), read_form(rdr)) + } else if (token == "~@") { + . <- Reader.next(rdr); + new.list(new.symbol("splice-unquote"), read_form(rdr)) + } else if (token == "^") { + . <- Reader.next(rdr) + m <- read_form(rdr) + new.list(new.symbol("with-meta"), read_form(rdr), m) + } else if (token == "@") { + . <- Reader.next(rdr); + new.list(new.symbol("deref"), read_form(rdr)) + } else if (token == ")") { + throw("unexpected ')'") + } else if (token == "(") { + new.listl(read_seq(rdr)) + } else if (token == "]") { + throw("unexpected ']'") + } else if (token == "[") { + new.vectorl(read_seq(rdr, "[", "]")) + } else if (token == "}") { + throw("unexpected '}'") + } else if (token == "{") { + new.hash_mapl(read_seq(rdr, "{", "}")) + } else { + read_atom(rdr) + } +} + +read_str <- function(str) { + tokens <- tokenize(str) + if (length(tokens) == 0) return(nil) + return(read_form(new.Reader(tokens))) +} + +#cat("---\n") +#print(tokenize("123")) +#cat("---\n") +#print(tokenize(" ( 123 456 abc \"def\" ) ")) + +#rdr <- new.reader(tokenize(" ( 123 456 abc \"def\" ) ")) +#Reader.peek(rdr) +#Reader.next(rdr) +#Reader.next(rdr) +#Reader.next(rdr) +#Reader.next(rdr) +#Reader.next(rdr) +#Reader.next(rdr) +#Reader.next(rdr) diff --git a/impls/r/readline.r b/impls/r/readline.r index 795984c213..0715947d74 100644 --- a/impls/r/readline.r +++ b/impls/r/readline.r @@ -1,44 +1,44 @@ -..readline.. <- TRUE - -HISTORY_FILE = paste(path.expand("~"), "/.mal-history", sep="") - -library(rdyncall, lib.loc="lib/") - -#.rllib <- dynfind(c("edit")) -.rllib <- dynfind(c("readline")) -.call_readline <- .dynsym(.rllib,"readline") -.call_add_history <- .dynsym(.rllib,"add_history") - -.state <- new.env() -.state$rl_history_loaded = FALSE - -.readline <- function(prompt) { - res <- .dyncall(.call_readline, "Z)p", prompt) - if (is.nullptr(res)) { - return(NULL) - } else { - return(ptr2str(res)) - } -} - -readline <- function(prompt) { - if (!.state$rl_history_loaded) { - .state$rl_history_loaded <- TRUE - - if (file.access(HISTORY_FILE, 4) == 0) { - lines <- scan(HISTORY_FILE, what="", sep="\n", quiet=TRUE) - for(add_line in lines) { - .dyncall(.call_add_history, "Z)v", add_line) - } - } - } - - line <- .readline(prompt) - if (is.null(line)) return(NULL) - .dyncall(.call_add_history, "Z)v", line) - if (file.access(HISTORY_FILE, 2) == 0) { - write(line, file=HISTORY_FILE, append=TRUE) - } - - line -} +..readline.. <- TRUE + +HISTORY_FILE = paste(path.expand("~"), "/.mal-history", sep="") + +library(rdyncall, lib.loc="lib/") + +#.rllib <- dynfind(c("edit")) +.rllib <- dynfind(c("readline")) +.call_readline <- .dynsym(.rllib,"readline") +.call_add_history <- .dynsym(.rllib,"add_history") + +.state <- new.env() +.state$rl_history_loaded = FALSE + +.readline <- function(prompt) { + res <- .dyncall(.call_readline, "Z)p", prompt) + if (is.nullptr(res)) { + return(NULL) + } else { + return(ptr2str(res)) + } +} + +readline <- function(prompt) { + if (!.state$rl_history_loaded) { + .state$rl_history_loaded <- TRUE + + if (file.access(HISTORY_FILE, 4) == 0) { + lines <- scan(HISTORY_FILE, what="", sep="\n", quiet=TRUE) + for(add_line in lines) { + .dyncall(.call_add_history, "Z)v", add_line) + } + } + } + + line <- .readline(prompt) + if (is.null(line)) return(NULL) + .dyncall(.call_add_history, "Z)v", line) + if (file.access(HISTORY_FILE, 2) == 0) { + write(line, file=HISTORY_FILE, append=TRUE) + } + + line +} diff --git a/impls/r/run b/impls/r/run index 711ef09092..010565e5fe 100755 --- a/impls/r/run +++ b/impls/r/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec Rscript $(dirname $0)/${STEP:-stepA_mal}.r "${@}" +#!/bin/bash +exec Rscript $(dirname $0)/${STEP:-stepA_mal}.r "${@}" diff --git a/impls/r/step0_repl.r b/impls/r/step0_repl.r index 7b03dd38cf..36a5dbd575 100644 --- a/impls/r/step0_repl.r +++ b/impls/r/step0_repl.r @@ -1,27 +1,27 @@ -source("readline.r") - -READ <- function(str) { - return(str) -} - -EVAL <- function(ast, env) { - return(ast) -} - -PRINT <- function(exp) { - return(exp) -} - -rep <- function(str) { - return(PRINT(EVAL(READ(str), ""))) -} - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", err$message,"\n", sep="") - }) -} +source("readline.r") + +READ <- function(str) { + return(str) +} + +EVAL <- function(ast, env) { + return(ast) +} + +PRINT <- function(exp) { + return(exp) +} + +rep <- function(str) { + return(PRINT(EVAL(READ(str), ""))) +} + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", err$message,"\n", sep="") + }) +} diff --git a/impls/r/step1_read_print.r b/impls/r/step1_read_print.r index 39d189b085..6448d238cf 100644 --- a/impls/r/step1_read_print.r +++ b/impls/r/step1_read_print.r @@ -1,32 +1,32 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") - -READ <- function(str) { - return(read_str(str)) -} - -EVAL <- function(ast, env) { - return(ast) -} - -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -rep <- function(str) { - return(PRINT(EVAL(READ(str), ""))) -} - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") + +READ <- function(str) { + return(read_str(str)) +} + +EVAL <- function(ast, env) { + return(ast) +} + +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +rep <- function(str) { + return(PRINT(EVAL(READ(str), ""))) +} + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/step2_eval.r b/impls/r/step2_eval.r index 68cd4061bc..68ffec9c0a 100644 --- a/impls/r/step2_eval.r +++ b/impls/r/step2_eval.r @@ -1,66 +1,66 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") - -READ <- function(str) { - return(read_str(str)) -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - env[[as.character(ast)]] - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } - - # apply list - if (length(ast) == 0) { - return(ast) - } - el <- eval_ast(ast, env) - f <- el[[1]] - return(do.call(f,el[-1])) -} - -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -repl_env <- new.env() -repl_env[["+"]] <- function(a,b) a+b -repl_env[["-"]] <- function(a,b) a-b -repl_env[["*"]] <- function(a,b) a*b -repl_env[["/"]] <- function(a,b) a/b - -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") + +READ <- function(str) { + return(read_str(str)) +} + +eval_ast <- function(ast, env) { + if (.symbol_q(ast)) { + env[[as.character(ast)]] + } else if (.list_q(ast)) { + new.listl(lapply(ast, function(a) EVAL(a, env))) + } else if (.vector_q(ast)) { + new.vectorl(lapply(ast, function(a) EVAL(a, env))) + } else if (.hash_map_q(ast)) { + lst <- list() + for(k in ls(ast)) { + lst[[length(lst)+1]] = k + lst[[length(lst)+1]] = EVAL(ast[[k]], env) + } + new.hash_mapl(lst) + } else { + ast + } +} + +EVAL <- function(ast, env) { + #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") + if (!.list_q(ast)) { + return(eval_ast(ast, env)) + } + + # apply list + if (length(ast) == 0) { + return(ast) + } + el <- eval_ast(ast, env) + f <- el[[1]] + return(do.call(f,el[-1])) +} + +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +repl_env <- new.env() +repl_env[["+"]] <- function(a,b) a+b +repl_env[["-"]] <- function(a,b) a-b +repl_env[["*"]] <- function(a,b) a*b +repl_env[["/"]] <- function(a,b) a/b + +rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/step3_env.r b/impls/r/step3_env.r index 142f43dd9d..9a624b95c1 100644 --- a/impls/r/step3_env.r +++ b/impls/r/step3_env.r @@ -1,81 +1,81 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") -if(!exists("..env..")) source("env.r") - -READ <- function(str) { - return(read_str(str)) -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - Env.get(env, ast) - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } - - # apply list - switch(paste("l",length(ast),sep=""), - l0={ return(ast) }, - l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, - l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, - { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) - a0sym <- as.character(a0) - if (a0sym == "def!") { - res <- EVAL(ast[[3]], env) - return(Env.set(env, a1, res)) - } else if (a0sym == "let*") { - let_env <- new.Env(env) - for(i in seq(1,length(a1),2)) { - Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) - } - return(EVAL(a2, let_env)) - } else { - el <- eval_ast(ast, env) - f <- el[[1]] - return(do.call(f,slice(el,2))) - } -} - -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -repl_env <- new.Env() -Env.set(repl_env, "+", function(a,b) a+b) -Env.set(repl_env, "-", function(a,b) a-b) -Env.set(repl_env, "*", function(a,b) a*b) -Env.set(repl_env, "/", function(a,b) a/b) - -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") +if(!exists("..env..")) source("env.r") + +READ <- function(str) { + return(read_str(str)) +} + +eval_ast <- function(ast, env) { + if (.symbol_q(ast)) { + Env.get(env, ast) + } else if (.list_q(ast)) { + new.listl(lapply(ast, function(a) EVAL(a, env))) + } else if (.vector_q(ast)) { + new.vectorl(lapply(ast, function(a) EVAL(a, env))) + } else if (.hash_map_q(ast)) { + lst <- list() + for(k in ls(ast)) { + lst[[length(lst)+1]] = k + lst[[length(lst)+1]] = EVAL(ast[[k]], env) + } + new.hash_mapl(lst) + } else { + ast + } +} + +EVAL <- function(ast, env) { + #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") + if (!.list_q(ast)) { + return(eval_ast(ast, env)) + } + + # apply list + switch(paste("l",length(ast),sep=""), + l0={ return(ast) }, + l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, + l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, + { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) + a0sym <- as.character(a0) + if (a0sym == "def!") { + res <- EVAL(ast[[3]], env) + return(Env.set(env, a1, res)) + } else if (a0sym == "let*") { + let_env <- new.Env(env) + for(i in seq(1,length(a1),2)) { + Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) + } + return(EVAL(a2, let_env)) + } else { + el <- eval_ast(ast, env) + f <- el[[1]] + return(do.call(f,slice(el,2))) + } +} + +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +repl_env <- new.Env() +Env.set(repl_env, "+", function(a,b) a+b) +Env.set(repl_env, "-", function(a,b) a-b) +Env.set(repl_env, "*", function(a,b) a*b) +Env.set(repl_env, "/", function(a,b) a/b) + +rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/step4_if_fn_do.r b/impls/r/step4_if_fn_do.r index 567e18d70b..1ca3fa1152 100644 --- a/impls/r/step4_if_fn_do.r +++ b/impls/r/step4_if_fn_do.r @@ -1,100 +1,100 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") -if(!exists("..env..")) source("env.r") -if(!exists("..core..")) source("core.r") - -READ <- function(str) { - return(read_str(str)) -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - Env.get(env, ast) - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } - - # apply list - switch(paste("l",length(ast),sep=""), - l0={ return(ast) }, - l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, - l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, - { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) - if (length(a0) > 1) a0sym <- "__<*fn*>__" - else a0sym <- as.character(a0) - if (a0sym == "def!") { - res <- EVAL(ast[[3]], env) - return(Env.set(env, a1, res)) - } else if (a0sym == "let*") { - let_env <- new.Env(env) - for(i in seq(1,length(a1),2)) { - Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) - } - return(EVAL(a2, let_env)) - } else if (a0sym == "do") { - el <- eval_ast(slice(ast,2), env) - return(el[[length(el)]]) - } else if (a0sym == "if") { - cond <- EVAL(a1, env) - if (.nil_q(cond) || identical(cond, FALSE)) { - if (length(ast) < 4) return(nil) - return(EVAL(ast[[4]], env)) - } else { - return(EVAL(a2, env)) - } - } else if (a0sym == "fn*") { - return(function(...) { - EVAL(a2, new.Env(env, a1, list(...))) - }) - } else { - el <- eval_ast(ast, env) - f <- el[[1]] - return(do.call(f,slice(el,2))) - } -} - -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -repl_env <- new.Env() -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -# core.r: defined using R -for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } - -# core.mal: defined using the language itself -. <- rep("(def! not (fn* (a) (if a false true)))") - - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") +if(!exists("..env..")) source("env.r") +if(!exists("..core..")) source("core.r") + +READ <- function(str) { + return(read_str(str)) +} + +eval_ast <- function(ast, env) { + if (.symbol_q(ast)) { + Env.get(env, ast) + } else if (.list_q(ast)) { + new.listl(lapply(ast, function(a) EVAL(a, env))) + } else if (.vector_q(ast)) { + new.vectorl(lapply(ast, function(a) EVAL(a, env))) + } else if (.hash_map_q(ast)) { + lst <- list() + for(k in ls(ast)) { + lst[[length(lst)+1]] = k + lst[[length(lst)+1]] = EVAL(ast[[k]], env) + } + new.hash_mapl(lst) + } else { + ast + } +} + +EVAL <- function(ast, env) { + #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") + if (!.list_q(ast)) { + return(eval_ast(ast, env)) + } + + # apply list + switch(paste("l",length(ast),sep=""), + l0={ return(ast) }, + l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, + l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, + { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) + if (length(a0) > 1) a0sym <- "__<*fn*>__" + else a0sym <- as.character(a0) + if (a0sym == "def!") { + res <- EVAL(ast[[3]], env) + return(Env.set(env, a1, res)) + } else if (a0sym == "let*") { + let_env <- new.Env(env) + for(i in seq(1,length(a1),2)) { + Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) + } + return(EVAL(a2, let_env)) + } else if (a0sym == "do") { + el <- eval_ast(slice(ast,2), env) + return(el[[length(el)]]) + } else if (a0sym == "if") { + cond <- EVAL(a1, env) + if (.nil_q(cond) || identical(cond, FALSE)) { + if (length(ast) < 4) return(nil) + return(EVAL(ast[[4]], env)) + } else { + return(EVAL(a2, env)) + } + } else if (a0sym == "fn*") { + return(function(...) { + EVAL(a2, new.Env(env, a1, list(...))) + }) + } else { + el <- eval_ast(ast, env) + f <- el[[1]] + return(do.call(f,slice(el,2))) + } +} + +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +repl_env <- new.Env() +rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) + +# core.r: defined using R +for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } + +# core.mal: defined using the language itself +. <- rep("(def! not (fn* (a) (if a false true)))") + + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/step5_tco.r b/impls/r/step5_tco.r index 913c78fbd9..98e57aed28 100644 --- a/impls/r/step5_tco.r +++ b/impls/r/step5_tco.r @@ -1,108 +1,108 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") -if(!exists("..env..")) source("env.r") -if(!exists("..core..")) source("core.r") - -READ <- function(str) { - return(read_str(str)) -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - Env.get(env, ast) - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - repeat { - - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } - - # apply list - switch(paste("l",length(ast),sep=""), - l0={ return(ast) }, - l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, - l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, - { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) - if (length(a0) > 1) a0sym <- "__<*fn*>__" - else a0sym <- as.character(a0) - if (a0sym == "def!") { - res <- EVAL(a2, env) - return(Env.set(env, a1, res)) - } else if (a0sym == "let*") { - let_env <- new.Env(env) - for(i in seq(1,length(a1),2)) { - Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) - } - ast <- a2 - env <- let_env - } else if (a0sym == "do") { - eval_ast(slice(ast,2,length(ast)-1), env) - ast <- ast[[length(ast)]] - } else if (a0sym == "if") { - cond <- EVAL(a1, env) - if (.nil_q(cond) || identical(cond, FALSE)) { - if (length(ast) < 4) return(nil) - ast <- ast[[4]] - } else { - ast <- a2 - } - } else if (a0sym == "fn*") { - return(malfunc(EVAL, a2, env, a1)) - } else { - el <- eval_ast(ast, env) - f <- el[[1]] - if (class(f) == "MalFunc") { - ast <- f$ast - env <- f$gen_env(slice(el,2)) - } else { - return(do.call(f,slice(el,2))) - } - } - - } -} - -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -repl_env <- new.Env() -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -# core.r: defined using R -for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } - -# core.mal: defined using the language itself -. <- rep("(def! not (fn* (a) (if a false true)))") - - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") +if(!exists("..env..")) source("env.r") +if(!exists("..core..")) source("core.r") + +READ <- function(str) { + return(read_str(str)) +} + +eval_ast <- function(ast, env) { + if (.symbol_q(ast)) { + Env.get(env, ast) + } else if (.list_q(ast)) { + new.listl(lapply(ast, function(a) EVAL(a, env))) + } else if (.vector_q(ast)) { + new.vectorl(lapply(ast, function(a) EVAL(a, env))) + } else if (.hash_map_q(ast)) { + lst <- list() + for(k in ls(ast)) { + lst[[length(lst)+1]] = k + lst[[length(lst)+1]] = EVAL(ast[[k]], env) + } + new.hash_mapl(lst) + } else { + ast + } +} + +EVAL <- function(ast, env) { + repeat { + + #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") + if (!.list_q(ast)) { + return(eval_ast(ast, env)) + } + + # apply list + switch(paste("l",length(ast),sep=""), + l0={ return(ast) }, + l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, + l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, + { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) + if (length(a0) > 1) a0sym <- "__<*fn*>__" + else a0sym <- as.character(a0) + if (a0sym == "def!") { + res <- EVAL(a2, env) + return(Env.set(env, a1, res)) + } else if (a0sym == "let*") { + let_env <- new.Env(env) + for(i in seq(1,length(a1),2)) { + Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) + } + ast <- a2 + env <- let_env + } else if (a0sym == "do") { + eval_ast(slice(ast,2,length(ast)-1), env) + ast <- ast[[length(ast)]] + } else if (a0sym == "if") { + cond <- EVAL(a1, env) + if (.nil_q(cond) || identical(cond, FALSE)) { + if (length(ast) < 4) return(nil) + ast <- ast[[4]] + } else { + ast <- a2 + } + } else if (a0sym == "fn*") { + return(malfunc(EVAL, a2, env, a1)) + } else { + el <- eval_ast(ast, env) + f <- el[[1]] + if (class(f) == "MalFunc") { + ast <- f$ast + env <- f$gen_env(slice(el,2)) + } else { + return(do.call(f,slice(el,2))) + } + } + + } +} + +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +repl_env <- new.Env() +rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) + +# core.r: defined using R +for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } + +# core.mal: defined using the language itself +. <- rep("(def! not (fn* (a) (if a false true)))") + + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/step6_file.r b/impls/r/step6_file.r index c3a2297505..fe90e3c237 100644 --- a/impls/r/step6_file.r +++ b/impls/r/step6_file.r @@ -1,120 +1,120 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") -if(!exists("..env..")) source("env.r") -if(!exists("..core..")) source("core.r") - -# read -READ <- function(str) { - return(read_str(str)) -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - Env.get(env, ast) - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - repeat { - - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } - - # apply list - switch(paste("l",length(ast),sep=""), - l0={ return(ast) }, - l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, - l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, - { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) - if (length(a0) > 1) a0sym <- "__<*fn*>__" - else a0sym <- as.character(a0) - if (a0sym == "def!") { - res <- EVAL(a2, env) - return(Env.set(env, a1, res)) - } else if (a0sym == "let*") { - let_env <- new.Env(env) - for(i in seq(1,length(a1),2)) { - Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) - } - ast <- a2 - env <- let_env - } else if (a0sym == "do") { - eval_ast(slice(ast,2,length(ast)-1), env) - ast <- ast[[length(ast)]] - } else if (a0sym == "if") { - cond <- EVAL(a1, env) - if (.nil_q(cond) || identical(cond, FALSE)) { - if (length(ast) < 4) return(nil) - ast <- ast[[4]] - } else { - ast <- a2 - } - } else if (a0sym == "fn*") { - return(malfunc(EVAL, a2, env, a1)) - } else { - el <- eval_ast(ast, env) - f <- el[[1]] - if (class(f) == "MalFunc") { - ast <- f$ast - env <- f$gen_env(slice(el,2)) - } else { - return(do.call(f,slice(el,2))) - } - } - - } -} - -# print -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -# repl loop -repl_env <- new.Env() -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -# core.r: defined using R -for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } -Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) -Env.set(repl_env, "*ARGV*", new.list()) - -# core.mal: defined using the language itself -. <- rep("(def! not (fn* (a) (if a false true)))") -. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -args <- commandArgs(trailingOnly = TRUE) -if (length(args) > 0) { - Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) - . <- rep(concat("(load-file \"", args[[1]], "\")")) - quit(save="no", status=0) -} - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") +if(!exists("..env..")) source("env.r") +if(!exists("..core..")) source("core.r") + +# read +READ <- function(str) { + return(read_str(str)) +} + +eval_ast <- function(ast, env) { + if (.symbol_q(ast)) { + Env.get(env, ast) + } else if (.list_q(ast)) { + new.listl(lapply(ast, function(a) EVAL(a, env))) + } else if (.vector_q(ast)) { + new.vectorl(lapply(ast, function(a) EVAL(a, env))) + } else if (.hash_map_q(ast)) { + lst <- list() + for(k in ls(ast)) { + lst[[length(lst)+1]] = k + lst[[length(lst)+1]] = EVAL(ast[[k]], env) + } + new.hash_mapl(lst) + } else { + ast + } +} + +EVAL <- function(ast, env) { + repeat { + + #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") + if (!.list_q(ast)) { + return(eval_ast(ast, env)) + } + + # apply list + switch(paste("l",length(ast),sep=""), + l0={ return(ast) }, + l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, + l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, + { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) + if (length(a0) > 1) a0sym <- "__<*fn*>__" + else a0sym <- as.character(a0) + if (a0sym == "def!") { + res <- EVAL(a2, env) + return(Env.set(env, a1, res)) + } else if (a0sym == "let*") { + let_env <- new.Env(env) + for(i in seq(1,length(a1),2)) { + Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) + } + ast <- a2 + env <- let_env + } else if (a0sym == "do") { + eval_ast(slice(ast,2,length(ast)-1), env) + ast <- ast[[length(ast)]] + } else if (a0sym == "if") { + cond <- EVAL(a1, env) + if (.nil_q(cond) || identical(cond, FALSE)) { + if (length(ast) < 4) return(nil) + ast <- ast[[4]] + } else { + ast <- a2 + } + } else if (a0sym == "fn*") { + return(malfunc(EVAL, a2, env, a1)) + } else { + el <- eval_ast(ast, env) + f <- el[[1]] + if (class(f) == "MalFunc") { + ast <- f$ast + env <- f$gen_env(slice(el,2)) + } else { + return(do.call(f,slice(el,2))) + } + } + + } +} + +# print +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +# repl loop +repl_env <- new.Env() +rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) + +# core.r: defined using R +for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } +Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) +Env.set(repl_env, "*ARGV*", new.list()) + +# core.mal: defined using the language itself +. <- rep("(def! not (fn* (a) (if a false true)))") +. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +args <- commandArgs(trailingOnly = TRUE) +if (length(args) > 0) { + Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) + . <- rep(concat("(load-file \"", args[[1]], "\")")) + quit(save="no", status=0) +} + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/step7_quote.r b/impls/r/step7_quote.r index 52b68d0db7..b9bbbba10d 100644 --- a/impls/r/step7_quote.r +++ b/impls/r/step7_quote.r @@ -1,162 +1,162 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") -if(!exists("..env..")) source("env.r") -if(!exists("..core..")) source("core.r") - -# read -READ <- function(str) { - return(read_str(str)) -} - -# eval -starts_with <- function(ast, sym) { - .list_q(ast) && length(ast) == 2 && .symbol_q(ast[[1]]) && ast[[1]] == sym -} - -quasiquote_elements <- function(ast) { - acc <- new.list() - i <- length(ast) - while (0 < i) { - elt <- ast[[i]] - if (starts_with(elt, "splice-unquote")) { - acc = new.list(new.symbol("concat"), elt[[2]], acc) - } else { - acc = new.list(new.symbol("cons"), quasiquote(elt), acc) - } - i <- i-1 - } - acc -} - -quasiquote <- function(ast) { - if (.list_q(ast)) { - if (starts_with(ast, "unquote")) { - ast[[2]] - } else { - quasiquote_elements(ast) - } - } else if (.vector_q(ast)) { - new.list(new.symbol("vec"), quasiquote_elements(ast)) - } else if (.symbol_q(ast) || .hash_map_q(ast)) { - new.list(new.symbol("quote"), ast) - } else { - ast - } -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - Env.get(env, ast) - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - repeat { - - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { - return(eval_ast(ast, env)) - } - - # apply list - switch(paste("l",length(ast),sep=""), - l0={ return(ast) }, - l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, - l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, - { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) - if (length(a0) > 1) a0sym <- "__<*fn*>__" - else a0sym <- as.character(a0) - if (a0sym == "def!") { - res <- EVAL(a2, env) - return(Env.set(env, a1, res)) - } else if (a0sym == "let*") { - let_env <- new.Env(env) - for(i in seq(1,length(a1),2)) { - Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) - } - ast <- a2 - env <- let_env - } else if (a0sym == "quote") { - return(a1) - } else if (a0sym == "quasiquoteexpand") { - return(quasiquote(a1)) - } else if (a0sym == "quasiquote") { - ast <- quasiquote(a1) - } else if (a0sym == "do") { - eval_ast(slice(ast,2,length(ast)-1), env) - ast <- ast[[length(ast)]] - } else if (a0sym == "if") { - cond <- EVAL(a1, env) - if (.nil_q(cond) || identical(cond, FALSE)) { - if (length(ast) < 4) return(nil) - ast <- ast[[4]] - } else { - ast <- a2 - } - } else if (a0sym == "fn*") { - return(malfunc(EVAL, a2, env, a1)) - } else { - el <- eval_ast(ast, env) - f <- el[[1]] - if (class(f) == "MalFunc") { - ast <- f$ast - env <- f$gen_env(slice(el,2)) - } else { - return(do.call(f,slice(el,2))) - } - } - - } -} - -# print -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -# repl loop -repl_env <- new.Env() -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -# core.r: defined using R -for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } -Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) -Env.set(repl_env, "*ARGV*", new.list()) - -# core.mal: defined using the language itself -. <- rep("(def! not (fn* (a) (if a false true)))") -. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -args <- commandArgs(trailingOnly = TRUE) -if (length(args) > 0) { - Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) - . <- rep(concat("(load-file \"", args[[1]], "\")")) - quit(save="no", status=0) -} - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") +if(!exists("..env..")) source("env.r") +if(!exists("..core..")) source("core.r") + +# read +READ <- function(str) { + return(read_str(str)) +} + +# eval +starts_with <- function(ast, sym) { + .list_q(ast) && length(ast) == 2 && .symbol_q(ast[[1]]) && ast[[1]] == sym +} + +quasiquote_elements <- function(ast) { + acc <- new.list() + i <- length(ast) + while (0 < i) { + elt <- ast[[i]] + if (starts_with(elt, "splice-unquote")) { + acc = new.list(new.symbol("concat"), elt[[2]], acc) + } else { + acc = new.list(new.symbol("cons"), quasiquote(elt), acc) + } + i <- i-1 + } + acc +} + +quasiquote <- function(ast) { + if (.list_q(ast)) { + if (starts_with(ast, "unquote")) { + ast[[2]] + } else { + quasiquote_elements(ast) + } + } else if (.vector_q(ast)) { + new.list(new.symbol("vec"), quasiquote_elements(ast)) + } else if (.symbol_q(ast) || .hash_map_q(ast)) { + new.list(new.symbol("quote"), ast) + } else { + ast + } +} + +eval_ast <- function(ast, env) { + if (.symbol_q(ast)) { + Env.get(env, ast) + } else if (.list_q(ast)) { + new.listl(lapply(ast, function(a) EVAL(a, env))) + } else if (.vector_q(ast)) { + new.vectorl(lapply(ast, function(a) EVAL(a, env))) + } else if (.hash_map_q(ast)) { + lst <- list() + for(k in ls(ast)) { + lst[[length(lst)+1]] = k + lst[[length(lst)+1]] = EVAL(ast[[k]], env) + } + new.hash_mapl(lst) + } else { + ast + } +} + +EVAL <- function(ast, env) { + repeat { + + #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") + if (!.list_q(ast)) { + return(eval_ast(ast, env)) + } + + # apply list + switch(paste("l",length(ast),sep=""), + l0={ return(ast) }, + l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, + l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, + { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) + if (length(a0) > 1) a0sym <- "__<*fn*>__" + else a0sym <- as.character(a0) + if (a0sym == "def!") { + res <- EVAL(a2, env) + return(Env.set(env, a1, res)) + } else if (a0sym == "let*") { + let_env <- new.Env(env) + for(i in seq(1,length(a1),2)) { + Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) + } + ast <- a2 + env <- let_env + } else if (a0sym == "quote") { + return(a1) + } else if (a0sym == "quasiquoteexpand") { + return(quasiquote(a1)) + } else if (a0sym == "quasiquote") { + ast <- quasiquote(a1) + } else if (a0sym == "do") { + eval_ast(slice(ast,2,length(ast)-1), env) + ast <- ast[[length(ast)]] + } else if (a0sym == "if") { + cond <- EVAL(a1, env) + if (.nil_q(cond) || identical(cond, FALSE)) { + if (length(ast) < 4) return(nil) + ast <- ast[[4]] + } else { + ast <- a2 + } + } else if (a0sym == "fn*") { + return(malfunc(EVAL, a2, env, a1)) + } else { + el <- eval_ast(ast, env) + f <- el[[1]] + if (class(f) == "MalFunc") { + ast <- f$ast + env <- f$gen_env(slice(el,2)) + } else { + return(do.call(f,slice(el,2))) + } + } + + } +} + +# print +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +# repl loop +repl_env <- new.Env() +rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) + +# core.r: defined using R +for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } +Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) +Env.set(repl_env, "*ARGV*", new.list()) + +# core.mal: defined using the language itself +. <- rep("(def! not (fn* (a) (if a false true)))") +. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +args <- commandArgs(trailingOnly = TRUE) +if (length(args) > 0) { + Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) + . <- rep(concat("(load-file \"", args[[1]], "\")")) + quit(save="no", status=0) +} + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/step8_macros.r b/impls/r/step8_macros.r index c6434a388d..d7aab11b25 100644 --- a/impls/r/step8_macros.r +++ b/impls/r/step8_macros.r @@ -1,190 +1,190 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") -if(!exists("..env..")) source("env.r") -if(!exists("..core..")) source("core.r") - -# read -READ <- function(str) { - return(read_str(str)) -} - -# eval -starts_with <- function(ast, sym) { - .list_q(ast) && length(ast) == 2 && .symbol_q(ast[[1]]) && ast[[1]] == sym -} - -quasiquote_elements <- function(ast) { - acc <- new.list() - i <- length(ast) - while (0 < i) { - elt <- ast[[i]] - if (starts_with(elt, "splice-unquote")) { - acc = new.list(new.symbol("concat"), elt[[2]], acc) - } else { - acc = new.list(new.symbol("cons"), quasiquote(elt), acc) - } - i <- i-1 - } - acc -} - -quasiquote <- function(ast) { - if (.list_q(ast)) { - if (starts_with(ast, "unquote")) { - ast[[2]] - } else { - quasiquote_elements(ast) - } - } else if (.vector_q(ast)) { - new.list(new.symbol("vec"), quasiquote_elements(ast)) - } else if (.symbol_q(ast) || .hash_map_q(ast)) { - new.list(new.symbol("quote"), ast) - } else { - ast - } -} - -is_macro_call <- function(ast, env) { - if(.list_q(ast) && - .symbol_q(ast[[1]]) && - (!.nil_q(Env.find(env, ast[[1]])))) { - exp <- Env.get(env, ast[[1]]) - return(.malfunc_q(exp) && exp$ismacro) - } - FALSE -} - -macroexpand <- function(ast, env) { - while(is_macro_call(ast, env)) { - mac <- Env.get(env, ast[[1]]) - ast <- fapply(mac, slice(ast, 2)) - } - ast -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - Env.get(env, ast) - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - repeat { - - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { return(eval_ast(ast, env)) } - if (length(ast) == 0) { return(ast) } - - # apply list - ast <- macroexpand(ast, env) - if (!.list_q(ast)) return(eval_ast(ast, env)) - - switch(paste("l",length(ast),sep=""), - l0={ return(ast) }, - l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, - l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, - { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) - if (length(a0) > 1) a0sym <- "__<*fn*>__" - else a0sym <- as.character(a0) - if (a0sym == "def!") { - res <- EVAL(a2, env) - return(Env.set(env, a1, res)) - } else if (a0sym == "let*") { - let_env <- new.Env(env) - for(i in seq(1,length(a1),2)) { - Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) - } - ast <- a2 - env <- let_env - } else if (a0sym == "quote") { - return(a1) - } else if (a0sym == "quasiquoteexpand") { - return(quasiquote(a1)) - } else if (a0sym == "quasiquote") { - ast <- quasiquote(a1) - } else if (a0sym == "defmacro!") { - func <- EVAL(a2, env) - func$ismacro = TRUE - return(Env.set(env, a1, func)) - } else if (a0sym == "macroexpand") { - return(macroexpand(a1, env)) - } else if (a0sym == "do") { - eval_ast(slice(ast,2,length(ast)-1), env) - ast <- ast[[length(ast)]] - } else if (a0sym == "if") { - cond <- EVAL(a1, env) - if (.nil_q(cond) || identical(cond, FALSE)) { - if (length(ast) < 4) return(nil) - ast <- ast[[4]] - } else { - ast <- a2 - } - } else if (a0sym == "fn*") { - return(malfunc(EVAL, a2, env, a1)) - } else { - el <- eval_ast(ast, env) - f <- el[[1]] - if (class(f) == "MalFunc") { - ast <- f$ast - env <- f$gen_env(slice(el,2)) - } else { - return(do.call(f,slice(el,2))) - } - } - - } -} - -# print -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -# repl loop -repl_env <- new.Env() -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -# core.r: defined using R -for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } -Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) -Env.set(repl_env, "*ARGV*", new.list()) - -# core.mal: defined using the language itself -. <- rep("(def! not (fn* (a) (if a false true)))") -. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -. <- 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)))))))") - - -args <- commandArgs(trailingOnly = TRUE) -if (length(args) > 0) { - Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) - . <- rep(concat("(load-file \"", args[[1]], "\")")) - quit(save="no", status=0) -} - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") +if(!exists("..env..")) source("env.r") +if(!exists("..core..")) source("core.r") + +# read +READ <- function(str) { + return(read_str(str)) +} + +# eval +starts_with <- function(ast, sym) { + .list_q(ast) && length(ast) == 2 && .symbol_q(ast[[1]]) && ast[[1]] == sym +} + +quasiquote_elements <- function(ast) { + acc <- new.list() + i <- length(ast) + while (0 < i) { + elt <- ast[[i]] + if (starts_with(elt, "splice-unquote")) { + acc = new.list(new.symbol("concat"), elt[[2]], acc) + } else { + acc = new.list(new.symbol("cons"), quasiquote(elt), acc) + } + i <- i-1 + } + acc +} + +quasiquote <- function(ast) { + if (.list_q(ast)) { + if (starts_with(ast, "unquote")) { + ast[[2]] + } else { + quasiquote_elements(ast) + } + } else if (.vector_q(ast)) { + new.list(new.symbol("vec"), quasiquote_elements(ast)) + } else if (.symbol_q(ast) || .hash_map_q(ast)) { + new.list(new.symbol("quote"), ast) + } else { + ast + } +} + +is_macro_call <- function(ast, env) { + if(.list_q(ast) && + .symbol_q(ast[[1]]) && + (!.nil_q(Env.find(env, ast[[1]])))) { + exp <- Env.get(env, ast[[1]]) + return(.malfunc_q(exp) && exp$ismacro) + } + FALSE +} + +macroexpand <- function(ast, env) { + while(is_macro_call(ast, env)) { + mac <- Env.get(env, ast[[1]]) + ast <- fapply(mac, slice(ast, 2)) + } + ast +} + +eval_ast <- function(ast, env) { + if (.symbol_q(ast)) { + Env.get(env, ast) + } else if (.list_q(ast)) { + new.listl(lapply(ast, function(a) EVAL(a, env))) + } else if (.vector_q(ast)) { + new.vectorl(lapply(ast, function(a) EVAL(a, env))) + } else if (.hash_map_q(ast)) { + lst <- list() + for(k in ls(ast)) { + lst[[length(lst)+1]] = k + lst[[length(lst)+1]] = EVAL(ast[[k]], env) + } + new.hash_mapl(lst) + } else { + ast + } +} + +EVAL <- function(ast, env) { + repeat { + + #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") + if (!.list_q(ast)) { return(eval_ast(ast, env)) } + if (length(ast) == 0) { return(ast) } + + # apply list + ast <- macroexpand(ast, env) + if (!.list_q(ast)) return(eval_ast(ast, env)) + + switch(paste("l",length(ast),sep=""), + l0={ return(ast) }, + l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, + l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, + { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) + if (length(a0) > 1) a0sym <- "__<*fn*>__" + else a0sym <- as.character(a0) + if (a0sym == "def!") { + res <- EVAL(a2, env) + return(Env.set(env, a1, res)) + } else if (a0sym == "let*") { + let_env <- new.Env(env) + for(i in seq(1,length(a1),2)) { + Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) + } + ast <- a2 + env <- let_env + } else if (a0sym == "quote") { + return(a1) + } else if (a0sym == "quasiquoteexpand") { + return(quasiquote(a1)) + } else if (a0sym == "quasiquote") { + ast <- quasiquote(a1) + } else if (a0sym == "defmacro!") { + func <- EVAL(a2, env) + func$ismacro = TRUE + return(Env.set(env, a1, func)) + } else if (a0sym == "macroexpand") { + return(macroexpand(a1, env)) + } else if (a0sym == "do") { + eval_ast(slice(ast,2,length(ast)-1), env) + ast <- ast[[length(ast)]] + } else if (a0sym == "if") { + cond <- EVAL(a1, env) + if (.nil_q(cond) || identical(cond, FALSE)) { + if (length(ast) < 4) return(nil) + ast <- ast[[4]] + } else { + ast <- a2 + } + } else if (a0sym == "fn*") { + return(malfunc(EVAL, a2, env, a1)) + } else { + el <- eval_ast(ast, env) + f <- el[[1]] + if (class(f) == "MalFunc") { + ast <- f$ast + env <- f$gen_env(slice(el,2)) + } else { + return(do.call(f,slice(el,2))) + } + } + + } +} + +# print +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +# repl loop +repl_env <- new.Env() +rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) + +# core.r: defined using R +for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } +Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) +Env.set(repl_env, "*ARGV*", new.list()) + +# core.mal: defined using the language itself +. <- rep("(def! not (fn* (a) (if a false true)))") +. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +. <- 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)))))))") + + +args <- commandArgs(trailingOnly = TRUE) +if (length(args) > 0) { + Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) + . <- rep(concat("(load-file \"", args[[1]], "\")")) + quit(save="no", status=0) +} + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/step9_try.r b/impls/r/step9_try.r index c1be773a3d..8592987d5c 100644 --- a/impls/r/step9_try.r +++ b/impls/r/step9_try.r @@ -1,208 +1,208 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") -if(!exists("..env..")) source("env.r") -if(!exists("..core..")) source("core.r") - -# read -READ <- function(str) { - return(read_str(str)) -} - -# eval -starts_with <- function(ast, sym) { - .list_q(ast) && length(ast) == 2 && .symbol_q(ast[[1]]) && ast[[1]] == sym -} - -quasiquote_elements <- function(ast) { - acc <- new.list() - i <- length(ast) - while (0 < i) { - elt <- ast[[i]] - if (starts_with(elt, "splice-unquote")) { - acc = new.list(new.symbol("concat"), elt[[2]], acc) - } else { - acc = new.list(new.symbol("cons"), quasiquote(elt), acc) - } - i <- i-1 - } - acc -} - -quasiquote <- function(ast) { - if (.list_q(ast)) { - if (starts_with(ast, "unquote")) { - ast[[2]] - } else { - quasiquote_elements(ast) - } - } else if (.vector_q(ast)) { - new.list(new.symbol("vec"), quasiquote_elements(ast)) - } else if (.symbol_q(ast) || .hash_map_q(ast)) { - new.list(new.symbol("quote"), ast) - } else { - ast - } -} - -is_macro_call <- function(ast, env) { - if(.list_q(ast) && - .symbol_q(ast[[1]]) && - (!.nil_q(Env.find(env, ast[[1]])))) { - exp <- Env.get(env, ast[[1]]) - return(.malfunc_q(exp) && exp$ismacro) - } - FALSE -} - -macroexpand <- function(ast, env) { - while(is_macro_call(ast, env)) { - mac <- Env.get(env, ast[[1]]) - ast <- fapply(mac, slice(ast, 2)) - } - ast -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - Env.get(env, ast) - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - repeat { - - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { return(eval_ast(ast, env)) } - if (length(ast) == 0) { return(ast) } - - # apply list - ast <- macroexpand(ast, env) - if (!.list_q(ast)) return(eval_ast(ast, env)) - - switch(paste("l",length(ast),sep=""), - l0={ return(ast) }, - l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, - l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, - { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) - if (length(a0) > 1) a0sym <- "__<*fn*>__" - else a0sym <- as.character(a0) - if (a0sym == "def!") { - res <- EVAL(a2, env) - return(Env.set(env, a1, res)) - } else if (a0sym == "let*") { - let_env <- new.Env(env) - for(i in seq(1,length(a1),2)) { - Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) - } - ast <- a2 - env <- let_env - } else if (a0sym == "quote") { - return(a1) - } else if (a0sym == "quasiquoteexpand") { - return(quasiquote(a1)) - } else if (a0sym == "quasiquote") { - ast <- quasiquote(a1) - } else if (a0sym == "defmacro!") { - func <- EVAL(a2, env) - func$ismacro = TRUE - return(Env.set(env, a1, func)) - } else if (a0sym == "macroexpand") { - return(macroexpand(a1, env)) - } else if (a0sym == "try*") { - edata <- new.env() - tryCatch({ - return(EVAL(a1, env)) - }, error=function(err) { - edata$exc <- get_error(err) - }) - if ((!is.null(a2)) && a2[[1]] == "catch*") { - return(EVAL(a2[[3]], new.Env(env, - new.list(a2[[2]]), - new.list(edata$exc)))) - } else { - throw(edata$exc) - } - } else if (a0sym == "do") { - eval_ast(slice(ast,2,length(ast)-1), env) - ast <- ast[[length(ast)]] - } else if (a0sym == "if") { - cond <- EVAL(a1, env) - if (.nil_q(cond) || identical(cond, FALSE)) { - if (length(ast) < 4) return(nil) - ast <- ast[[4]] - } else { - ast <- a2 - } - } else if (a0sym == "fn*") { - return(malfunc(EVAL, a2, env, a1)) - } else { - el <- eval_ast(ast, env) - f <- el[[1]] - if (class(f) == "MalFunc") { - ast <- f$ast - env <- f$gen_env(slice(el,2)) - } else { - return(do.call(f,slice(el,2))) - } - } - - } -} - -# print -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -# repl loop -repl_env <- new.Env() -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -# core.r: defined using R -for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } -Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) -Env.set(repl_env, "*ARGV*", new.list()) - -# core.mal: defined using the language itself -. <- rep("(def! not (fn* (a) (if a false true)))") -. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -. <- 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)))))))") - - -args <- commandArgs(trailingOnly = TRUE) -if (length(args) > 0) { - Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) - tryCatch({ - . <- rep(concat("(load-file \"", args[[1]], "\")")) - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - quit(save="no", status=0) -} - -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", .pr_str(get_error(err),TRUE),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") +if(!exists("..env..")) source("env.r") +if(!exists("..core..")) source("core.r") + +# read +READ <- function(str) { + return(read_str(str)) +} + +# eval +starts_with <- function(ast, sym) { + .list_q(ast) && length(ast) == 2 && .symbol_q(ast[[1]]) && ast[[1]] == sym +} + +quasiquote_elements <- function(ast) { + acc <- new.list() + i <- length(ast) + while (0 < i) { + elt <- ast[[i]] + if (starts_with(elt, "splice-unquote")) { + acc = new.list(new.symbol("concat"), elt[[2]], acc) + } else { + acc = new.list(new.symbol("cons"), quasiquote(elt), acc) + } + i <- i-1 + } + acc +} + +quasiquote <- function(ast) { + if (.list_q(ast)) { + if (starts_with(ast, "unquote")) { + ast[[2]] + } else { + quasiquote_elements(ast) + } + } else if (.vector_q(ast)) { + new.list(new.symbol("vec"), quasiquote_elements(ast)) + } else if (.symbol_q(ast) || .hash_map_q(ast)) { + new.list(new.symbol("quote"), ast) + } else { + ast + } +} + +is_macro_call <- function(ast, env) { + if(.list_q(ast) && + .symbol_q(ast[[1]]) && + (!.nil_q(Env.find(env, ast[[1]])))) { + exp <- Env.get(env, ast[[1]]) + return(.malfunc_q(exp) && exp$ismacro) + } + FALSE +} + +macroexpand <- function(ast, env) { + while(is_macro_call(ast, env)) { + mac <- Env.get(env, ast[[1]]) + ast <- fapply(mac, slice(ast, 2)) + } + ast +} + +eval_ast <- function(ast, env) { + if (.symbol_q(ast)) { + Env.get(env, ast) + } else if (.list_q(ast)) { + new.listl(lapply(ast, function(a) EVAL(a, env))) + } else if (.vector_q(ast)) { + new.vectorl(lapply(ast, function(a) EVAL(a, env))) + } else if (.hash_map_q(ast)) { + lst <- list() + for(k in ls(ast)) { + lst[[length(lst)+1]] = k + lst[[length(lst)+1]] = EVAL(ast[[k]], env) + } + new.hash_mapl(lst) + } else { + ast + } +} + +EVAL <- function(ast, env) { + repeat { + + #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") + if (!.list_q(ast)) { return(eval_ast(ast, env)) } + if (length(ast) == 0) { return(ast) } + + # apply list + ast <- macroexpand(ast, env) + if (!.list_q(ast)) return(eval_ast(ast, env)) + + switch(paste("l",length(ast),sep=""), + l0={ return(ast) }, + l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, + l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, + { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) + if (length(a0) > 1) a0sym <- "__<*fn*>__" + else a0sym <- as.character(a0) + if (a0sym == "def!") { + res <- EVAL(a2, env) + return(Env.set(env, a1, res)) + } else if (a0sym == "let*") { + let_env <- new.Env(env) + for(i in seq(1,length(a1),2)) { + Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) + } + ast <- a2 + env <- let_env + } else if (a0sym == "quote") { + return(a1) + } else if (a0sym == "quasiquoteexpand") { + return(quasiquote(a1)) + } else if (a0sym == "quasiquote") { + ast <- quasiquote(a1) + } else if (a0sym == "defmacro!") { + func <- EVAL(a2, env) + func$ismacro = TRUE + return(Env.set(env, a1, func)) + } else if (a0sym == "macroexpand") { + return(macroexpand(a1, env)) + } else if (a0sym == "try*") { + edata <- new.env() + tryCatch({ + return(EVAL(a1, env)) + }, error=function(err) { + edata$exc <- get_error(err) + }) + if ((!is.null(a2)) && a2[[1]] == "catch*") { + return(EVAL(a2[[3]], new.Env(env, + new.list(a2[[2]]), + new.list(edata$exc)))) + } else { + throw(edata$exc) + } + } else if (a0sym == "do") { + eval_ast(slice(ast,2,length(ast)-1), env) + ast <- ast[[length(ast)]] + } else if (a0sym == "if") { + cond <- EVAL(a1, env) + if (.nil_q(cond) || identical(cond, FALSE)) { + if (length(ast) < 4) return(nil) + ast <- ast[[4]] + } else { + ast <- a2 + } + } else if (a0sym == "fn*") { + return(malfunc(EVAL, a2, env, a1)) + } else { + el <- eval_ast(ast, env) + f <- el[[1]] + if (class(f) == "MalFunc") { + ast <- f$ast + env <- f$gen_env(slice(el,2)) + } else { + return(do.call(f,slice(el,2))) + } + } + + } +} + +# print +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +# repl loop +repl_env <- new.Env() +rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) + +# core.r: defined using R +for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } +Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) +Env.set(repl_env, "*ARGV*", new.list()) + +# core.mal: defined using the language itself +. <- rep("(def! not (fn* (a) (if a false true)))") +. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +. <- 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)))))))") + + +args <- commandArgs(trailingOnly = TRUE) +if (length(args) > 0) { + Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) + tryCatch({ + . <- rep(concat("(load-file \"", args[[1]], "\")")) + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + quit(save="no", status=0) +} + +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", .pr_str(get_error(err),TRUE),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/stepA_mal.r b/impls/r/stepA_mal.r index ca77531c2d..60d2369f03 100644 --- a/impls/r/stepA_mal.r +++ b/impls/r/stepA_mal.r @@ -1,210 +1,210 @@ -if(!exists("..readline..")) source("readline.r") -if(!exists("..types..")) source("types.r") -if(!exists("..reader..")) source("reader.r") -if(!exists("..printer..")) source("printer.r") -if(!exists("..env..")) source("env.r") -if(!exists("..core..")) source("core.r") - -# read -READ <- function(str) { - return(read_str(str)) -} - -# eval -starts_with <- function(ast, sym) { - .list_q(ast) && length(ast) == 2 && .symbol_q(ast[[1]]) && ast[[1]] == sym -} - -quasiquote_elements <- function(ast) { - acc <- new.list() - i <- length(ast) - while (0 < i) { - elt <- ast[[i]] - if (starts_with(elt, "splice-unquote")) { - acc = new.list(new.symbol("concat"), elt[[2]], acc) - } else { - acc = new.list(new.symbol("cons"), quasiquote(elt), acc) - } - i <- i-1 - } - acc -} - -quasiquote <- function(ast) { - if (.list_q(ast)) { - if (starts_with(ast, "unquote")) { - ast[[2]] - } else { - quasiquote_elements(ast) - } - } else if (.vector_q(ast)) { - new.list(new.symbol("vec"), quasiquote_elements(ast)) - } else if (.symbol_q(ast) || .hash_map_q(ast)) { - new.list(new.symbol("quote"), ast) - } else { - ast - } -} - -is_macro_call <- function(ast, env) { - if(.list_q(ast) && - .symbol_q(ast[[1]]) && - (!.nil_q(Env.find(env, ast[[1]])))) { - exp <- Env.get(env, ast[[1]]) - return(.malfunc_q(exp) && exp$ismacro) - } - FALSE -} - -macroexpand <- function(ast, env) { - while(is_macro_call(ast, env)) { - mac <- Env.get(env, ast[[1]]) - ast <- fapply(mac, slice(ast, 2)) - } - ast -} - -eval_ast <- function(ast, env) { - if (.symbol_q(ast)) { - Env.get(env, ast) - } else if (.list_q(ast)) { - new.listl(lapply(ast, function(a) EVAL(a, env))) - } else if (.vector_q(ast)) { - new.vectorl(lapply(ast, function(a) EVAL(a, env))) - } else if (.hash_map_q(ast)) { - lst <- list() - for(k in ls(ast)) { - lst[[length(lst)+1]] = k - lst[[length(lst)+1]] = EVAL(ast[[k]], env) - } - new.hash_mapl(lst) - } else { - ast - } -} - -EVAL <- function(ast, env) { - repeat { - - #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") - if (!.list_q(ast)) { return(eval_ast(ast, env)) } - if (length(ast) == 0) { return(ast) } - - # apply list - ast <- macroexpand(ast, env) - if (!.list_q(ast)) return(eval_ast(ast, env)) - - switch(paste("l",length(ast),sep=""), - l0={ return(ast) }, - l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, - l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, - { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) - if (length(a0) > 1) a0sym <- "__<*fn*>__" - else a0sym <- as.character(a0) - if (a0sym == "def!") { - res <- EVAL(a2, env) - return(Env.set(env, a1, res)) - } else if (a0sym == "let*") { - let_env <- new.Env(env) - for(i in seq(1,length(a1),2)) { - Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) - } - ast <- a2 - env <- let_env - } else if (a0sym == "quote") { - return(a1) - } else if (a0sym == "quasiquoteexpand") { - return(quasiquote(a1)) - } else if (a0sym == "quasiquote") { - ast <- quasiquote(a1) - } else if (a0sym == "defmacro!") { - func <- EVAL(a2, env) - func$ismacro = TRUE - return(Env.set(env, a1, func)) - } else if (a0sym == "macroexpand") { - return(macroexpand(a1, env)) - } else if (a0sym == "try*") { - edata <- new.env() - tryCatch({ - return(EVAL(a1, env)) - }, error=function(err) { - edata$exc <- get_error(err) - }) - if ((!is.null(a2)) && a2[[1]] == "catch*") { - return(EVAL(a2[[3]], new.Env(env, - new.list(a2[[2]]), - new.list(edata$exc)))) - } else { - throw(edata$exc) - } - } else if (a0sym == "do") { - eval_ast(slice(ast,2,length(ast)-1), env) - ast <- ast[[length(ast)]] - } else if (a0sym == "if") { - cond <- EVAL(a1, env) - if (.nil_q(cond) || identical(cond, FALSE)) { - if (length(ast) < 4) return(nil) - ast <- ast[[4]] - } else { - ast <- a2 - } - } else if (a0sym == "fn*") { - return(malfunc(EVAL, a2, env, a1)) - } else { - el <- eval_ast(ast, env) - f <- el[[1]] - if (class(f) == "MalFunc") { - ast <- f$ast - env <- f$gen_env(slice(el,2)) - } else { - return(do.call(f,slice(el,2))) - } - } - - } -} - -# print -PRINT <- function(exp) { - return(.pr_str(exp, TRUE)) -} - -# repl loop -repl_env <- new.Env() -rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) - -# core.r: defined using R -for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } -Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) -Env.set(repl_env, "*ARGV*", new.list()) - -# core.mal: defined using the language itself -. <- rep("(def! *host-language* \"R\")") -. <- rep("(def! not (fn* (a) (if a false true)))") -. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -. <- 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)))))))") - - -args <- commandArgs(trailingOnly = TRUE) -if (length(args) > 0) { - Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) - tryCatch({ - . <- rep(concat("(load-file \"", args[[1]], "\")")) - }, error=function(err) { - cat("Error: ", get_error(err),"\n", sep="") - }) - quit(save="no", status=0) -} - -. <- rep("(println (str \"Mal [\" *host-language* \"]\"))") -repeat { - line <- readline("user> ") - if (is.null(line)) { cat("\n"); break } - tryCatch({ - cat(rep(line),"\n", sep="") - }, error=function(err) { - cat("Error: ", .pr_str(get_error(err),TRUE),"\n", sep="") - }) - # R debug/fatal with tracebacks: - #cat(rep(line),"\n", sep="") -} +if(!exists("..readline..")) source("readline.r") +if(!exists("..types..")) source("types.r") +if(!exists("..reader..")) source("reader.r") +if(!exists("..printer..")) source("printer.r") +if(!exists("..env..")) source("env.r") +if(!exists("..core..")) source("core.r") + +# read +READ <- function(str) { + return(read_str(str)) +} + +# eval +starts_with <- function(ast, sym) { + .list_q(ast) && length(ast) == 2 && .symbol_q(ast[[1]]) && ast[[1]] == sym +} + +quasiquote_elements <- function(ast) { + acc <- new.list() + i <- length(ast) + while (0 < i) { + elt <- ast[[i]] + if (starts_with(elt, "splice-unquote")) { + acc = new.list(new.symbol("concat"), elt[[2]], acc) + } else { + acc = new.list(new.symbol("cons"), quasiquote(elt), acc) + } + i <- i-1 + } + acc +} + +quasiquote <- function(ast) { + if (.list_q(ast)) { + if (starts_with(ast, "unquote")) { + ast[[2]] + } else { + quasiquote_elements(ast) + } + } else if (.vector_q(ast)) { + new.list(new.symbol("vec"), quasiquote_elements(ast)) + } else if (.symbol_q(ast) || .hash_map_q(ast)) { + new.list(new.symbol("quote"), ast) + } else { + ast + } +} + +is_macro_call <- function(ast, env) { + if(.list_q(ast) && + .symbol_q(ast[[1]]) && + (!.nil_q(Env.find(env, ast[[1]])))) { + exp <- Env.get(env, ast[[1]]) + return(.malfunc_q(exp) && exp$ismacro) + } + FALSE +} + +macroexpand <- function(ast, env) { + while(is_macro_call(ast, env)) { + mac <- Env.get(env, ast[[1]]) + ast <- fapply(mac, slice(ast, 2)) + } + ast +} + +eval_ast <- function(ast, env) { + if (.symbol_q(ast)) { + Env.get(env, ast) + } else if (.list_q(ast)) { + new.listl(lapply(ast, function(a) EVAL(a, env))) + } else if (.vector_q(ast)) { + new.vectorl(lapply(ast, function(a) EVAL(a, env))) + } else if (.hash_map_q(ast)) { + lst <- list() + for(k in ls(ast)) { + lst[[length(lst)+1]] = k + lst[[length(lst)+1]] = EVAL(ast[[k]], env) + } + new.hash_mapl(lst) + } else { + ast + } +} + +EVAL <- function(ast, env) { + repeat { + + #cat("EVAL: ", .pr_str(ast,TRUE), "\n", sep="") + if (!.list_q(ast)) { return(eval_ast(ast, env)) } + if (length(ast) == 0) { return(ast) } + + # apply list + ast <- macroexpand(ast, env) + if (!.list_q(ast)) return(eval_ast(ast, env)) + + switch(paste("l",length(ast),sep=""), + l0={ return(ast) }, + l1={ a0 <- ast[[1]]; a1 <- NULL; a2 <- NULL }, + l2={ a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- NULL }, + { a0 <- ast[[1]]; a1 <- ast[[2]]; a2 <- ast[[3]] }) + if (length(a0) > 1) a0sym <- "__<*fn*>__" + else a0sym <- as.character(a0) + if (a0sym == "def!") { + res <- EVAL(a2, env) + return(Env.set(env, a1, res)) + } else if (a0sym == "let*") { + let_env <- new.Env(env) + for(i in seq(1,length(a1),2)) { + Env.set(let_env, a1[[i]], EVAL(a1[[i+1]], let_env)) + } + ast <- a2 + env <- let_env + } else if (a0sym == "quote") { + return(a1) + } else if (a0sym == "quasiquoteexpand") { + return(quasiquote(a1)) + } else if (a0sym == "quasiquote") { + ast <- quasiquote(a1) + } else if (a0sym == "defmacro!") { + func <- EVAL(a2, env) + func$ismacro = TRUE + return(Env.set(env, a1, func)) + } else if (a0sym == "macroexpand") { + return(macroexpand(a1, env)) + } else if (a0sym == "try*") { + edata <- new.env() + tryCatch({ + return(EVAL(a1, env)) + }, error=function(err) { + edata$exc <- get_error(err) + }) + if ((!is.null(a2)) && a2[[1]] == "catch*") { + return(EVAL(a2[[3]], new.Env(env, + new.list(a2[[2]]), + new.list(edata$exc)))) + } else { + throw(edata$exc) + } + } else if (a0sym == "do") { + eval_ast(slice(ast,2,length(ast)-1), env) + ast <- ast[[length(ast)]] + } else if (a0sym == "if") { + cond <- EVAL(a1, env) + if (.nil_q(cond) || identical(cond, FALSE)) { + if (length(ast) < 4) return(nil) + ast <- ast[[4]] + } else { + ast <- a2 + } + } else if (a0sym == "fn*") { + return(malfunc(EVAL, a2, env, a1)) + } else { + el <- eval_ast(ast, env) + f <- el[[1]] + if (class(f) == "MalFunc") { + ast <- f$ast + env <- f$gen_env(slice(el,2)) + } else { + return(do.call(f,slice(el,2))) + } + } + + } +} + +# print +PRINT <- function(exp) { + return(.pr_str(exp, TRUE)) +} + +# repl loop +repl_env <- new.Env() +rep <- function(str) return(PRINT(EVAL(READ(str), repl_env))) + +# core.r: defined using R +for(k in names(core_ns)) { Env.set(repl_env, k, core_ns[[k]]) } +Env.set(repl_env, "eval", function(ast) EVAL(ast, repl_env)) +Env.set(repl_env, "*ARGV*", new.list()) + +# core.mal: defined using the language itself +. <- rep("(def! *host-language* \"R\")") +. <- rep("(def! not (fn* (a) (if a false true)))") +. <- rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +. <- 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)))))))") + + +args <- commandArgs(trailingOnly = TRUE) +if (length(args) > 0) { + Env.set(repl_env, "*ARGV*", new.listl(slice(as.list(args),2))) + tryCatch({ + . <- rep(concat("(load-file \"", args[[1]], "\")")) + }, error=function(err) { + cat("Error: ", get_error(err),"\n", sep="") + }) + quit(save="no", status=0) +} + +. <- rep("(println (str \"Mal [\" *host-language* \"]\"))") +repeat { + line <- readline("user> ") + if (is.null(line)) { cat("\n"); break } + tryCatch({ + cat(rep(line),"\n", sep="") + }, error=function(err) { + cat("Error: ", .pr_str(get_error(err),TRUE),"\n", sep="") + }) + # R debug/fatal with tracebacks: + #cat(rep(line),"\n", sep="") +} diff --git a/impls/r/tests/step5_tco.mal b/impls/r/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/r/tests/step5_tco.mal +++ b/impls/r/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/r/types.r b/impls/r/types.r index 9d8c29a913..1e68290ba2 100644 --- a/impls/r/types.r +++ b/impls/r/types.r @@ -1,185 +1,185 @@ -..types.. <- TRUE - -if(!exists("..env..")) source("env.r") - -# General type related functions -concat <- function(..., sep="") paste(..., collapse="", sep=sep) -concatl <- function(lst, sep="") paste(lst, collapse=sep, sep=sep) - -slice <- function(seq, start=1, end=-1) { - if (end == -1) end <- length(seq) - if (start > end) lst <- list() else lst <- seq[start:end] - switch(class(seq), - list={ new.listl(lst) }, - List={ new.listl(lst) }, - Vector={ new.vectorl(lst) }, - { throw("slice called on non-sequence") }) -} - -.sequential_q <- function(obj) .list_q(obj) || .vector_q(obj) - -.equal_q <- function(a,b) { - ota <- class(a); otb <- class(b) - if (!((ota == otb) || (.sequential_q(a) && .sequential_q(b)))) { - return(FALSE) - } - switch(ota, - "List"={ - if (length(a) != length(b)) return(FALSE) - if (length(a) == 0) return(TRUE) - for(i in seq(length(a))) { - if (!.equal_q(a[[i]],b[[i]])) return(FALSE) - } - TRUE - }, - "Vector"={ - if (length(a) != length(b)) return(FALSE) - if (length(a) == 0) return(TRUE) - for(i in seq(length(a))) { - if (!.equal_q(a[[i]],b[[i]])) return(FALSE) - } - TRUE - }, - "HashMap"={ - ks1 <- ls(a) - ks2 <- ls(b) - if (length(ks1) != length(ks2)) return(FALSE) - for(k in ks1) { - if (!.equal_q(a[[k]],b[[k]])) return(FALSE) - } - TRUE - }, - { - a == b - }) -} - -.clone <- function(obj) { - if (.hash_map_q(obj)) { - new_obj <- new.env() - for(k in ls(obj, all.names=TRUE)) new_obj[[k]] = obj[[k]] - class(new_obj) <- "HashMap" - } else { - new_obj <- obj - } - new_obj -} - -# Errors/exceptions -thrown_error = new.env() -thrown_error$val = NULL -throw <- function(obj) { - thrown_error$val = obj - stop("") -} -get_error <- function(e) { - estr <- e$message - if (estr == "") { - err <- thrown_error$val - thrown_error$val <- NULL - err - } else { - estr - } -} - -# Scalars -nil <- structure("malnil", class="nil") -.nil_q <- function(obj) "nil" == class(obj) -.true_q <- function(obj) "logical" == class(obj) && obj == TRUE -.false_q <- function(obj) "logical" == class(obj) && obj == FALSE -.string_q <- function(obj) { - "character" == class(obj) && - !("\u029e" == substr(obj,1,1) || - "" == substring(obj,1,8)) -} - -new.symbol <- function(name) structure(name, class="Symbol") -.symbol_q <- function(obj) "Symbol" == class(obj) - -new.keyword <- function(name) { - if (.keyword_q(name)) return (name) - concat("\u029e", name) -} - -.keyword_q <- function(obj) { - "character" == class(obj) && - ("\u029e" == substr(obj,1,1) || - "" == substring(obj,1,8)) -} - -.number_q <- function(obj) "numeric" == class(obj) || "integer" == class(obj) - -# Functions - -malfunc <- function(eval, ast, env, params) { - gen_env <- function(args) new.Env(env, params, args) - structure(list(eval=eval, - ast=ast, - env=env, - params=params, - gen_env=gen_env, - ismacro=FALSE), class="MalFunc") -} -.malfunc_q <- function(obj) "MalFunc" == class(obj) - -fapply <- function(mf, args) { - if (class(mf) == "MalFunc") { - ast <- mf$ast - env <- mf$gen_env(args) - mf$eval(ast, env) - } else { - #print(args) - do.call(mf,args) - } -} - -.fn_q <- function(obj) "function" == class(obj) || (.malfunc_q(obj) && !obj$ismacro) -.macro_q <- function(obj) .malfunc_q(obj) && obj$ismacro - -# Lists -new.list <- function(...) new.listl(list(...)) -new.listl <- function(lst) { class(lst) <- "List"; lst } -.list_q <- function(obj) "List" == class(obj) - -# Vectors -new.vector <- function(...) new.vectorl(list(...)) -new.vectorl <- function(lst) { class(lst) <- "Vector"; lst } -.vector_q <- function(obj) "Vector" == class(obj) - -# Hash Maps -new.hash_map <- function(...) new.hash_mapl(list(...)) -new.hash_mapl <- function(lst) { - .assoc(new.env(), lst) -} -.assoc <- function(src_hm, lst) { - hm <- .clone(src_hm) - if (length(lst) > 0) { - for(i in seq(1,length(lst),2)) { - hm[[lst[[i]]]] <- lst[[i+1]] - } - } - class(hm) <- "HashMap" - hm -} -.dissoc <- function(src_hm, lst) { - hm <- .clone(src_hm) - if (length(lst) > 0) { - for(k in lst) { - remove(list=c(k), envir=hm) - } - } - ls(hm) - class(hm) <- "HashMap" - hm -} -.hash_map_q <- function(obj) "HashMap" == class(obj) - -# Atoms -new.atom <- function(val) { - atm <- new.env() - class(atm) <- "Atom" - atm$val <- .clone(val) - atm -} -.atom_q <- function(obj) "Atom" == class(obj) +..types.. <- TRUE + +if(!exists("..env..")) source("env.r") + +# General type related functions +concat <- function(..., sep="") paste(..., collapse="", sep=sep) +concatl <- function(lst, sep="") paste(lst, collapse=sep, sep=sep) + +slice <- function(seq, start=1, end=-1) { + if (end == -1) end <- length(seq) + if (start > end) lst <- list() else lst <- seq[start:end] + switch(class(seq), + list={ new.listl(lst) }, + List={ new.listl(lst) }, + Vector={ new.vectorl(lst) }, + { throw("slice called on non-sequence") }) +} + +.sequential_q <- function(obj) .list_q(obj) || .vector_q(obj) + +.equal_q <- function(a,b) { + ota <- class(a); otb <- class(b) + if (!((ota == otb) || (.sequential_q(a) && .sequential_q(b)))) { + return(FALSE) + } + switch(ota, + "List"={ + if (length(a) != length(b)) return(FALSE) + if (length(a) == 0) return(TRUE) + for(i in seq(length(a))) { + if (!.equal_q(a[[i]],b[[i]])) return(FALSE) + } + TRUE + }, + "Vector"={ + if (length(a) != length(b)) return(FALSE) + if (length(a) == 0) return(TRUE) + for(i in seq(length(a))) { + if (!.equal_q(a[[i]],b[[i]])) return(FALSE) + } + TRUE + }, + "HashMap"={ + ks1 <- ls(a) + ks2 <- ls(b) + if (length(ks1) != length(ks2)) return(FALSE) + for(k in ks1) { + if (!.equal_q(a[[k]],b[[k]])) return(FALSE) + } + TRUE + }, + { + a == b + }) +} + +.clone <- function(obj) { + if (.hash_map_q(obj)) { + new_obj <- new.env() + for(k in ls(obj, all.names=TRUE)) new_obj[[k]] = obj[[k]] + class(new_obj) <- "HashMap" + } else { + new_obj <- obj + } + new_obj +} + +# Errors/exceptions +thrown_error = new.env() +thrown_error$val = NULL +throw <- function(obj) { + thrown_error$val = obj + stop("") +} +get_error <- function(e) { + estr <- e$message + if (estr == "") { + err <- thrown_error$val + thrown_error$val <- NULL + err + } else { + estr + } +} + +# Scalars +nil <- structure("malnil", class="nil") +.nil_q <- function(obj) "nil" == class(obj) +.true_q <- function(obj) "logical" == class(obj) && obj == TRUE +.false_q <- function(obj) "logical" == class(obj) && obj == FALSE +.string_q <- function(obj) { + "character" == class(obj) && + !("\u029e" == substr(obj,1,1) || + "" == substring(obj,1,8)) +} + +new.symbol <- function(name) structure(name, class="Symbol") +.symbol_q <- function(obj) "Symbol" == class(obj) + +new.keyword <- function(name) { + if (.keyword_q(name)) return (name) + concat("\u029e", name) +} + +.keyword_q <- function(obj) { + "character" == class(obj) && + ("\u029e" == substr(obj,1,1) || + "" == substring(obj,1,8)) +} + +.number_q <- function(obj) "numeric" == class(obj) || "integer" == class(obj) + +# Functions + +malfunc <- function(eval, ast, env, params) { + gen_env <- function(args) new.Env(env, params, args) + structure(list(eval=eval, + ast=ast, + env=env, + params=params, + gen_env=gen_env, + ismacro=FALSE), class="MalFunc") +} +.malfunc_q <- function(obj) "MalFunc" == class(obj) + +fapply <- function(mf, args) { + if (class(mf) == "MalFunc") { + ast <- mf$ast + env <- mf$gen_env(args) + mf$eval(ast, env) + } else { + #print(args) + do.call(mf,args) + } +} + +.fn_q <- function(obj) "function" == class(obj) || (.malfunc_q(obj) && !obj$ismacro) +.macro_q <- function(obj) .malfunc_q(obj) && obj$ismacro + +# Lists +new.list <- function(...) new.listl(list(...)) +new.listl <- function(lst) { class(lst) <- "List"; lst } +.list_q <- function(obj) "List" == class(obj) + +# Vectors +new.vector <- function(...) new.vectorl(list(...)) +new.vectorl <- function(lst) { class(lst) <- "Vector"; lst } +.vector_q <- function(obj) "Vector" == class(obj) + +# Hash Maps +new.hash_map <- function(...) new.hash_mapl(list(...)) +new.hash_mapl <- function(lst) { + .assoc(new.env(), lst) +} +.assoc <- function(src_hm, lst) { + hm <- .clone(src_hm) + if (length(lst) > 0) { + for(i in seq(1,length(lst),2)) { + hm[[lst[[i]]]] <- lst[[i+1]] + } + } + class(hm) <- "HashMap" + hm +} +.dissoc <- function(src_hm, lst) { + hm <- .clone(src_hm) + if (length(lst) > 0) { + for(k in lst) { + remove(list=c(k), envir=hm) + } + } + ls(hm) + class(hm) <- "HashMap" + hm +} +.hash_map_q <- function(obj) "HashMap" == class(obj) + +# Atoms +new.atom <- function(val) { + atm <- new.env() + class(atm) <- "Atom" + atm$val <- .clone(val) + atm +} +.atom_q <- function(obj) "Atom" == class(obj) diff --git a/impls/racket/Dockerfile b/impls/racket/Dockerfile index 1b05ee258b..2f66805a36 100644 --- a/impls/racket/Dockerfile +++ b/impls/racket/Dockerfile @@ -1,25 +1,25 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Racket -RUN apt-get -y install racket +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Racket +RUN apt-get -y install racket diff --git a/impls/racket/Makefile b/impls/racket/Makefile index 89bcac4ae0..6ff314dec6 100644 --- a/impls/racket/Makefile +++ b/impls/racket/Makefile @@ -1,14 +1,14 @@ -SOURCES_BASE = types.rkt reader.rkt printer.rkt -SOURCES_LISP = env.rkt core.rkt stepA_mal.rkt -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - -dist: mal - -mal: $(SOURCES) - raco exe stepA_mal.rkt - mv stepA_mal $@ - -clean: - rm -f mal +SOURCES_BASE = types.rkt reader.rkt printer.rkt +SOURCES_LISP = env.rkt core.rkt stepA_mal.rkt +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + +dist: mal + +mal: $(SOURCES) + raco exe stepA_mal.rkt + mv stepA_mal $@ + +clean: + rm -f mal diff --git a/impls/racket/core.rkt b/impls/racket/core.rkt index 1c69df2955..99efcc1f9c 100644 --- a/impls/racket/core.rkt +++ b/impls/racket/core.rkt @@ -1,122 +1,122 @@ -#lang racket - -(provide core_ns) - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt") - -(define (throw exc) - (raise (make-mal-exn "mal exception" - (current-continuation-marks) - exc))) - -;; Sequence functions -(define do_apply - (lambda a - (let* ([f (first a)] - [lst (_to_list (last a))] - [args (append (take (drop a 1) (- (length a) 2)) lst)]) - (apply f args)))) - -(define conj - (lambda a - (if (vector? (first a)) - (vector-append (first a) (list->vector (rest a))) - (append (reverse (rest a)) (first a))))) - -(define (seq obj) - (cond [(_nil? obj) nil] - [(_string? obj) (if (eq? 0 (string-length obj)) nil (map string (string->list obj)))] - [(_empty? obj) nil] - [else (_to_list obj)])) - -;; Meta functions -(define (meta obj) - (cond [(malfunc? obj) (malfunc-meta obj)] - [else nil])) - -(define (with-meta obj m) - (cond [(malfunc? obj) (struct-copy malfunc obj [meta m])] - [else (raise "metadata not supported on type")])) - -;; Atom functions - -(define swap! - (lambda a - (let* ([atm (first a)] - [f (second a)] - [args (cons (atom-val atm) (rest (rest a)))] - [val (apply f args)]) - (set-atom-val! atm val) - val))) - -(define core_ns - (hash - '= _equal? - 'throw throw - - 'nil? _nil? - 'true? (lambda (x) (eq? x #t)) - 'false? (lambda (x) (eq? x #f)) - 'number? number? - 'symbol (lambda (s) (if (symbol? s) s (string->symbol s))) - 'symbol? symbol? - 'string? _string? - 'keyword (lambda (s) (if (_keyword? s) s (_keyword s))) - 'keyword? _keyword? - 'fn? (lambda (s) (if (malfunc? s) - (not (malfunc-macro? s)) - (procedure? s))) - 'macro? (lambda (s) (and (malfunc? s) (malfunc-macro? s))) - - 'pr-str (lambda a (pr_lst a #t " ")) - 'str (lambda a (pr_lst a #f "")) - 'prn (lambda a (printf "~a~n" (pr_lst a #t " ")) nil) - 'println (lambda a (printf "~a~n" (pr_lst a #f " ")) nil) - 'read-string (lambda (s) (read_str s)) - 'readline readline - 'slurp (lambda (f) (port->string (open-input-file f))) - - '< < - '<= <= - '> > - '>= >= - '+ + - '- - - '* * - '/ / - 'time-ms (lambda () (round (current-inexact-milliseconds))) - - 'list list - 'list? list? - 'vector vector - 'vector? vector? - 'hash-map hash - 'map? hash? - 'assoc _assoc - 'dissoc _dissoc - 'get _get - 'contains? dict-has-key? - 'keys hash-keys - 'vals hash-values - - 'sequential? _sequential? - 'cons (lambda a (cons (first a) (_to_list (second a)))) - 'concat (lambda a (apply append (map _to_list a))) - 'vec (lambda a (let* ([x (first a)]) (if (vector? x) x (list->vector x)))) - 'nth _nth - 'first _first - 'rest _rest - 'empty? _empty? - 'count _count - 'apply do_apply - 'map (lambda (f s) (_to_list (_map f s))) - 'conj conj - 'seq seq - - 'meta meta - 'with-meta with-meta - 'atom atom - 'atom? atom? - 'deref (lambda (a) (atom-val a)) - 'reset! (lambda (a v) (set-atom-val! a v) v) - 'swap! swap!)) +#lang racket + +(provide core_ns) + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt") + +(define (throw exc) + (raise (make-mal-exn "mal exception" + (current-continuation-marks) + exc))) + +;; Sequence functions +(define do_apply + (lambda a + (let* ([f (first a)] + [lst (_to_list (last a))] + [args (append (take (drop a 1) (- (length a) 2)) lst)]) + (apply f args)))) + +(define conj + (lambda a + (if (vector? (first a)) + (vector-append (first a) (list->vector (rest a))) + (append (reverse (rest a)) (first a))))) + +(define (seq obj) + (cond [(_nil? obj) nil] + [(_string? obj) (if (eq? 0 (string-length obj)) nil (map string (string->list obj)))] + [(_empty? obj) nil] + [else (_to_list obj)])) + +;; Meta functions +(define (meta obj) + (cond [(malfunc? obj) (malfunc-meta obj)] + [else nil])) + +(define (with-meta obj m) + (cond [(malfunc? obj) (struct-copy malfunc obj [meta m])] + [else (raise "metadata not supported on type")])) + +;; Atom functions + +(define swap! + (lambda a + (let* ([atm (first a)] + [f (second a)] + [args (cons (atom-val atm) (rest (rest a)))] + [val (apply f args)]) + (set-atom-val! atm val) + val))) + +(define core_ns + (hash + '= _equal? + 'throw throw + + 'nil? _nil? + 'true? (lambda (x) (eq? x #t)) + 'false? (lambda (x) (eq? x #f)) + 'number? number? + 'symbol (lambda (s) (if (symbol? s) s (string->symbol s))) + 'symbol? symbol? + 'string? _string? + 'keyword (lambda (s) (if (_keyword? s) s (_keyword s))) + 'keyword? _keyword? + 'fn? (lambda (s) (if (malfunc? s) + (not (malfunc-macro? s)) + (procedure? s))) + 'macro? (lambda (s) (and (malfunc? s) (malfunc-macro? s))) + + 'pr-str (lambda a (pr_lst a #t " ")) + 'str (lambda a (pr_lst a #f "")) + 'prn (lambda a (printf "~a~n" (pr_lst a #t " ")) nil) + 'println (lambda a (printf "~a~n" (pr_lst a #f " ")) nil) + 'read-string (lambda (s) (read_str s)) + 'readline readline + 'slurp (lambda (f) (port->string (open-input-file f))) + + '< < + '<= <= + '> > + '>= >= + '+ + + '- - + '* * + '/ / + 'time-ms (lambda () (round (current-inexact-milliseconds))) + + 'list list + 'list? list? + 'vector vector + 'vector? vector? + 'hash-map hash + 'map? hash? + 'assoc _assoc + 'dissoc _dissoc + 'get _get + 'contains? dict-has-key? + 'keys hash-keys + 'vals hash-values + + 'sequential? _sequential? + 'cons (lambda a (cons (first a) (_to_list (second a)))) + 'concat (lambda a (apply append (map _to_list a))) + 'vec (lambda a (let* ([x (first a)]) (if (vector? x) x (list->vector x)))) + 'nth _nth + 'first _first + 'rest _rest + 'empty? _empty? + 'count _count + 'apply do_apply + 'map (lambda (f s) (_to_list (_map f s))) + 'conj conj + 'seq seq + + 'meta meta + 'with-meta with-meta + 'atom atom + 'atom? atom? + 'deref (lambda (a) (atom-val a)) + 'reset! (lambda (a v) (set-atom-val! a v) v) + 'swap! swap!)) diff --git a/impls/racket/env.rkt b/impls/racket/env.rkt index 8e47b634a7..5e031165be 100644 --- a/impls/racket/env.rkt +++ b/impls/racket/env.rkt @@ -1,47 +1,47 @@ -#lang racket - -(provide Env%) - -(require "types.rkt") - -(define Env% - (class object% - (init outer binds exprs) - (super-new) - (define _outer outer) - (define _binds (_to_list binds)) - (define _exprs (_to_list exprs)) - (define data (make-hash)) - (let ([vargs (member '& _binds)]) - (if vargs - (begin - (map (lambda (b e) (hash-set! data b e)) - (drop-right _binds 2) - (take _exprs (- (length _binds) 2))) - (hash-set! data - (last _binds) - (drop _exprs (- (length _binds) 2)))) - (map (lambda (b e) (hash-set! data b e)) - _binds - _exprs))) - - (define/public (set k v) - (hash-set! data k v) - v) - (define/public (find k) - (cond - [(hash-has-key? data k) this] - [(not (null? _outer)) (send _outer find k)] - [else null])) - (define/public (_get k) - (hash-ref data k)) - (define/public (get k) - (let ([e (find k)]) - (if (null? e) - (raise (string-append "'" - (symbol->string k) - "' not found")) - (send e _get k)))))) - - - +#lang racket + +(provide Env%) + +(require "types.rkt") + +(define Env% + (class object% + (init outer binds exprs) + (super-new) + (define _outer outer) + (define _binds (_to_list binds)) + (define _exprs (_to_list exprs)) + (define data (make-hash)) + (let ([vargs (member '& _binds)]) + (if vargs + (begin + (map (lambda (b e) (hash-set! data b e)) + (drop-right _binds 2) + (take _exprs (- (length _binds) 2))) + (hash-set! data + (last _binds) + (drop _exprs (- (length _binds) 2)))) + (map (lambda (b e) (hash-set! data b e)) + _binds + _exprs))) + + (define/public (set k v) + (hash-set! data k v) + v) + (define/public (find k) + (cond + [(hash-has-key? data k) this] + [(not (null? _outer)) (send _outer find k)] + [else null])) + (define/public (_get k) + (hash-ref data k)) + (define/public (get k) + (let ([e (find k)]) + (if (null? e) + (raise (string-append "'" + (symbol->string k) + "' not found")) + (send e _get k)))))) + + + diff --git a/impls/racket/printer.rkt b/impls/racket/printer.rkt index 07a8bb883c..a0c1e6f83c 100644 --- a/impls/racket/printer.rkt +++ b/impls/racket/printer.rkt @@ -1,44 +1,44 @@ -#lang racket - -(provide pr_str pr_lst) - -(require "types.rkt") - -(define (pr_str obj print_readably) - (let ([_r print_readably]) - (cond - [(list? obj) - (string-join (map (lambda (o) (pr_str o _r)) obj) - " " #:before-first "(" #:after-last ")")] - [(vector? obj) - (string-join (map (lambda (o) (pr_str o _r)) (vector->list obj)) - " " #:before-first "[" #:after-last "]")] - [(hash? obj) - (string-join (dict-map obj (lambda (k v) - (format "~a ~a" - (pr_str k _r) - (pr_str v _r)))) - " " #:before-first "{" #:after-last "}")] - [(string? obj) - (if (regexp-match #px"^\u029e" obj) - (format ":~a" (substring obj 1)) - (if _r - (format "\"~a\"" - (string-replace - (string-replace - (string-replace obj "\\" "\\\\") - "\"" "\\\"") - "\n" "\\n")) - obj))] - [(number? obj) (number->string obj)] - [(symbol? obj) (symbol->string obj)] - [(atom? obj) (format "(atom ~a)" (atom-val obj))] - [(_nil? obj) "nil"] - [(eq? #t obj) "true"] - [(eq? #f obj) "false"] - [else (format "~a" obj)]))) - -(define (pr_lst lst print_readably sep) - (string-join - (map (lambda (s) (pr_str s print_readably)) lst) - sep)) +#lang racket + +(provide pr_str pr_lst) + +(require "types.rkt") + +(define (pr_str obj print_readably) + (let ([_r print_readably]) + (cond + [(list? obj) + (string-join (map (lambda (o) (pr_str o _r)) obj) + " " #:before-first "(" #:after-last ")")] + [(vector? obj) + (string-join (map (lambda (o) (pr_str o _r)) (vector->list obj)) + " " #:before-first "[" #:after-last "]")] + [(hash? obj) + (string-join (dict-map obj (lambda (k v) + (format "~a ~a" + (pr_str k _r) + (pr_str v _r)))) + " " #:before-first "{" #:after-last "}")] + [(string? obj) + (if (regexp-match #px"^\u029e" obj) + (format ":~a" (substring obj 1)) + (if _r + (format "\"~a\"" + (string-replace + (string-replace + (string-replace obj "\\" "\\\\") + "\"" "\\\"") + "\n" "\\n")) + obj))] + [(number? obj) (number->string obj)] + [(symbol? obj) (symbol->string obj)] + [(atom? obj) (format "(atom ~a)" (atom-val obj))] + [(_nil? obj) "nil"] + [(eq? #t obj) "true"] + [(eq? #f obj) "false"] + [else (format "~a" obj)]))) + +(define (pr_lst lst print_readably sep) + (string-join + (map (lambda (s) (pr_str s print_readably)) lst) + sep)) diff --git a/impls/racket/reader.rkt b/impls/racket/reader.rkt index d0cb6c1547..95e1d0fb44 100644 --- a/impls/racket/reader.rkt +++ b/impls/racket/reader.rkt @@ -1,83 +1,83 @@ -#lang racket - -(provide read_str) - -(require "types.rkt") - -(define Reader% - (class object% - (init tokens) - (super-new) - (define toks tokens) - (define position 0) - (define/public (next) - (cond [(>= position (length toks)) null] - [else (begin - (set! position (+ 1 position)) - (list-ref toks (- position 1)))])) - (define/public (peek) - (cond [(>= position (length toks)) null] - [else (list-ref toks position )])))) - - -(define (tokenize str) - (filter-not (lambda (s) (or (equal? s "") (equal? (substring s 0 1) ";"))) - (regexp-match* #px"[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)" - str #:match-select cadr))) - -(define (read_atom rdr) - (let ([token (send rdr next)]) - (cond [(regexp-match #px"^-?[0-9]+$" token) - (string->number token)] - [(regexp-match #px"^-?[0-9][0-9.]*$" token) - (string->number token)] - [(regexp-match #px"^\"(?:\\\\.|[^\\\\\"])*\"$" token) - (with-input-from-string token read)] - [(regexp-match #px"^\".*$" token) - (raise "expected '\"', got EOF")] - [(regexp-match #px"^:" token) (_keyword (substring token 1))] - [(equal? "nil" token) nil] - [(equal? "true" token) #t] - [(equal? "false" token) #f] - [else (string->symbol token)]))) - -(define (read_list_entries rdr end) - (let ([tok (send rdr peek)]) - (cond - [(eq? tok '()) (raise (string-append "expected '" end "', got EOF"))] - [(equal? end tok) '()] - [else - (cons (read_form rdr) (read_list_entries rdr end))]))) - -(define (read_list rdr start end) - (let ([token (send rdr next)]) - (if (equal? start token) - (let ([lst (read_list_entries rdr end)]) - (send rdr next) - lst) - (raise (string-append "expected '" start "', got EOF"))))) - -(define (read_form rdr) - (let ([token (send rdr peek)]) - (if (null? token) - (raise (make-blank-exn "blank line" (current-continuation-marks))) - (cond - [(equal? "'" token) (send rdr next) (list 'quote (read_form rdr))] - [(equal? "`" token) (send rdr next) (list 'quasiquote (read_form rdr))] - [(equal? "~" token) (send rdr next) (list 'unquote (read_form rdr))] - [(equal? "~@" token) (send rdr next) (list 'splice-unquote (read_form rdr))] - [(equal? "^" token) (send rdr next) - (let ([meta (read_form rdr)]) - (list 'with-meta (read_form rdr) meta))] - [(equal? "@" token) (send rdr next) (list 'deref (read_form rdr))] - - [(equal? ")" token) (raise "unexpected ')'")] - [(equal? "(" token) (read_list rdr "(" ")")] - [(equal? "]" token) (raise "unexpected ']'")] - [(equal? "[" token) (list->vector (read_list rdr "[" "]"))] - [(equal? "}" token) (raise "unexpected '}'")] - [(equal? "{" token) (apply hash (read_list rdr "{" "}"))] - [else (read_atom rdr)])))) - -(define (read_str str) - (read_form (new Reader% [tokens (tokenize str)]))) +#lang racket + +(provide read_str) + +(require "types.rkt") + +(define Reader% + (class object% + (init tokens) + (super-new) + (define toks tokens) + (define position 0) + (define/public (next) + (cond [(>= position (length toks)) null] + [else (begin + (set! position (+ 1 position)) + (list-ref toks (- position 1)))])) + (define/public (peek) + (cond [(>= position (length toks)) null] + [else (list-ref toks position )])))) + + +(define (tokenize str) + (filter-not (lambda (s) (or (equal? s "") (equal? (substring s 0 1) ";"))) + (regexp-match* #px"[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)" + str #:match-select cadr))) + +(define (read_atom rdr) + (let ([token (send rdr next)]) + (cond [(regexp-match #px"^-?[0-9]+$" token) + (string->number token)] + [(regexp-match #px"^-?[0-9][0-9.]*$" token) + (string->number token)] + [(regexp-match #px"^\"(?:\\\\.|[^\\\\\"])*\"$" token) + (with-input-from-string token read)] + [(regexp-match #px"^\".*$" token) + (raise "expected '\"', got EOF")] + [(regexp-match #px"^:" token) (_keyword (substring token 1))] + [(equal? "nil" token) nil] + [(equal? "true" token) #t] + [(equal? "false" token) #f] + [else (string->symbol token)]))) + +(define (read_list_entries rdr end) + (let ([tok (send rdr peek)]) + (cond + [(eq? tok '()) (raise (string-append "expected '" end "', got EOF"))] + [(equal? end tok) '()] + [else + (cons (read_form rdr) (read_list_entries rdr end))]))) + +(define (read_list rdr start end) + (let ([token (send rdr next)]) + (if (equal? start token) + (let ([lst (read_list_entries rdr end)]) + (send rdr next) + lst) + (raise (string-append "expected '" start "', got EOF"))))) + +(define (read_form rdr) + (let ([token (send rdr peek)]) + (if (null? token) + (raise (make-blank-exn "blank line" (current-continuation-marks))) + (cond + [(equal? "'" token) (send rdr next) (list 'quote (read_form rdr))] + [(equal? "`" token) (send rdr next) (list 'quasiquote (read_form rdr))] + [(equal? "~" token) (send rdr next) (list 'unquote (read_form rdr))] + [(equal? "~@" token) (send rdr next) (list 'splice-unquote (read_form rdr))] + [(equal? "^" token) (send rdr next) + (let ([meta (read_form rdr)]) + (list 'with-meta (read_form rdr) meta))] + [(equal? "@" token) (send rdr next) (list 'deref (read_form rdr))] + + [(equal? ")" token) (raise "unexpected ')'")] + [(equal? "(" token) (read_list rdr "(" ")")] + [(equal? "]" token) (raise "unexpected ']'")] + [(equal? "[" token) (list->vector (read_list rdr "[" "]"))] + [(equal? "}" token) (raise "unexpected '}'")] + [(equal? "{" token) (apply hash (read_list rdr "{" "}"))] + [else (read_atom rdr)])))) + +(define (read_str str) + (read_form (new Reader% [tokens (tokenize str)]))) diff --git a/impls/racket/readline.rkt b/impls/racket/readline.rkt index fe2a72b02c..89fb272b4c 100644 --- a/impls/racket/readline.rkt +++ b/impls/racket/readline.rkt @@ -1,36 +1,36 @@ -#lang racket - -(provide readline) - -(require (prefix-in readline: readline/readline)) - -(require "types.rkt") - -(define history-loaded #f) -(define HISTORY-FILE (format "~a/.mal-history" (find-system-path 'home-dir))) - -(define (load-history path) - (with-handlers - ([exn:fail? (lambda (e) #t)]) - (map - (lambda (line) (readline:add-history line)) - (string-split - (port->string (open-input-file path)) - #px"\n")))) - -(define (readline prompt) - (when (not history-loaded) - (set! history-loaded #t) - (load-history HISTORY-FILE)) - (let ([line (readline:readline prompt)]) - (if (eq? eof line) - nil - (begin - (readline:add-history line) - (with-handlers - ([exn:fail? (lambda (e) #t)]) - (with-output-to-file - HISTORY-FILE - (lambda () (printf "~a~n" line)) - #:exists 'append)) - line)))) +#lang racket + +(provide readline) + +(require (prefix-in readline: readline/readline)) + +(require "types.rkt") + +(define history-loaded #f) +(define HISTORY-FILE (format "~a/.mal-history" (find-system-path 'home-dir))) + +(define (load-history path) + (with-handlers + ([exn:fail? (lambda (e) #t)]) + (map + (lambda (line) (readline:add-history line)) + (string-split + (port->string (open-input-file path)) + #px"\n")))) + +(define (readline prompt) + (when (not history-loaded) + (set! history-loaded #t) + (load-history HISTORY-FILE)) + (let ([line (readline:readline prompt)]) + (if (eq? eof line) + nil + (begin + (readline:add-history line) + (with-handlers + ([exn:fail? (lambda (e) #t)]) + (with-output-to-file + HISTORY-FILE + (lambda () (printf "~a~n" line)) + #:exists 'append)) + line)))) diff --git a/impls/racket/run b/impls/racket/run index 923de9df0d..c35fa3445a 100755 --- a/impls/racket/run +++ b/impls/racket/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec racket $(dirname $0)/${STEP:-stepA_mal}.rkt "${@}" +#!/bin/bash +exec racket $(dirname $0)/${STEP:-stepA_mal}.rkt "${@}" diff --git a/impls/racket/step0_repl.rkt b/impls/racket/step0_repl.rkt index 643d132fa2..a2b0537fa3 100755 --- a/impls/racket/step0_repl.rkt +++ b/impls/racket/step0_repl.rkt @@ -1,27 +1,27 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt") - -;; read -(define (READ str) - str) - -;; eval -(define (EVAL ast env) - ast) - -;; print -(define (PRINT exp) - exp) - -;; repl -(define (rep str) - (PRINT (EVAL (READ str) ""))) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (printf "~a~n" (rep line)) - (repl-loop)))) -(repl-loop) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt") + +;; read +(define (READ str) + str) + +;; eval +(define (EVAL ast env) + ast) + +;; print +(define (PRINT exp) + exp) + +;; repl +(define (rep str) + (PRINT (EVAL (READ str) ""))) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (printf "~a~n" (rep line)) + (repl-loop)))) +(repl-loop) diff --git a/impls/racket/step1_read_print.rkt b/impls/racket/step1_read_print.rkt index a5d8ac7761..6468178e55 100755 --- a/impls/racket/step1_read_print.rkt +++ b/impls/racket/step1_read_print.rkt @@ -1,30 +1,30 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval -(define (EVAL ast env) - ast) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define (rep str) - (PRINT (EVAL (READ str) ""))) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(repl-loop) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval +(define (EVAL ast env) + ast) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define (rep str) + (PRINT (EVAL (READ str) ""))) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(repl-loop) diff --git a/impls/racket/step2_eval.rkt b/impls/racket/step2_eval.rkt index 7f987dfa5f..5f46301979 100755 --- a/impls/racket/step2_eval.rkt +++ b/impls/racket/step2_eval.rkt @@ -1,49 +1,49 @@ -#!/usr/bin/env racket -#lang racket - -(require "types.rkt" "readline.rkt" "reader.rkt" "printer.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval -(define (eval-ast ast env) - (cond - [(symbol? ast) - (or (hash-ref env ast - (lambda () (raise (string-append "'" - (symbol->string ast) - "' not found")))))] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - (if (or (not (list? ast)) (empty? ast)) - (eval-ast ast env) - - (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (apply f args)))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env (hash '+ + '- - '* * '/ /)) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(repl-loop) +#!/usr/bin/env racket +#lang racket + +(require "types.rkt" "readline.rkt" "reader.rkt" "printer.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval +(define (eval-ast ast env) + (cond + [(symbol? ast) + (or (hash-ref env ast + (lambda () (raise (string-append "'" + (symbol->string ast) + "' not found")))))] + [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] + [(hash? ast) (make-hash + (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] + [else ast])) + +(define (EVAL ast env) + (if (or (not (list? ast)) (empty? ast)) + (eval-ast ast env) + + (let* ([el (eval-ast ast env)] + [f (first el)] + [args (rest el)]) + (apply f args)))) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define repl-env (hash '+ + '- - '* * '/ /)) +(define (rep str) + (PRINT (EVAL (READ str) repl-env))) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(repl-loop) diff --git a/impls/racket/step3_env.rkt b/impls/racket/step3_env.rkt index 91eff03e5b..2d1c449a29 100755 --- a/impls/racket/step3_env.rkt +++ b/impls/racket/step3_env.rkt @@ -1,61 +1,61 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" - "env.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval -(define (eval-ast ast env) - (cond - [(symbol? ast) (send env get ast)] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - (if (or (not (list? ast)) (empty? ast)) - (eval-ast ast env) - - (let ([a0 (_nth ast 0)]) - (cond - [(eq? 'def! a0) - (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] - [(eq? 'let* a0) - (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) - (_map (lambda (b_e) - (send let-env set (_first b_e) - (EVAL (_nth b_e 1) let-env))) - (_partition 2 (_to_list (_nth ast 1)))) - (EVAL (_nth ast 2) let-env))] - [else (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (apply f args))])))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env - (new Env% - [outer null] - [binds '(+ - * /)] - [exprs (list + - * /)])) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(repl-loop) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" + "env.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval +(define (eval-ast ast env) + (cond + [(symbol? ast) (send env get ast)] + [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] + [(hash? ast) (make-hash + (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] + [else ast])) + +(define (EVAL ast env) + (if (or (not (list? ast)) (empty? ast)) + (eval-ast ast env) + + (let ([a0 (_nth ast 0)]) + (cond + [(eq? 'def! a0) + (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] + [(eq? 'let* a0) + (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) + (_map (lambda (b_e) + (send let-env set (_first b_e) + (EVAL (_nth b_e 1) let-env))) + (_partition 2 (_to_list (_nth ast 1)))) + (EVAL (_nth ast 2) let-env))] + [else (let* ([el (eval-ast ast env)] + [f (first el)] + [args (rest el)]) + (apply f args))])))) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define repl-env + (new Env% + [outer null] + [binds '(+ - * /)] + [exprs (list + - * /)])) +(define (rep str) + (PRINT (EVAL (READ str) repl-env))) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(repl-loop) diff --git a/impls/racket/step4_if_fn_do.rkt b/impls/racket/step4_if_fn_do.rkt index 0a098029e6..d3a8c3eb74 100755 --- a/impls/racket/step4_if_fn_do.rkt +++ b/impls/racket/step4_if_fn_do.rkt @@ -1,82 +1,82 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" - "env.rkt" "core.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval -(define (eval-ast ast env) - (cond - [(symbol? ast) (send env get ast)] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - (if (or (not (list? ast)) (empty? ast)) - (eval-ast ast env) - - (let ([a0 (_nth ast 0)]) - (cond - [(eq? 'def! a0) - (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] - [(eq? 'let* a0) - (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) - (_map (lambda (b_e) - (send let-env set (_first b_e) - (EVAL (_nth b_e 1) let-env))) - (_partition 2 (_to_list (_nth ast 1)))) - (EVAL (_nth ast 2) let-env))] - [(eq? 'do a0) - (last (eval-ast (rest ast) env))] - [(eq? 'if a0) - (let ([cnd (EVAL (_nth ast 1) env)]) - (if (or (eq? cnd nil) (eq? cnd #f)) - (if (> (length ast) 3) - (EVAL (_nth ast 3) env) - nil) - (EVAL (_nth ast 2) env)))] - [(eq? 'fn* a0) - (lambda args (EVAL (_nth ast 2) - (new Env% [outer env] - [binds (_nth ast 1)] - [exprs args])))] - [else (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (apply f args))])))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env - (new Env% [outer null] [binds null] [exprs null])) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(for () ;; ignore return values - -;; core.rkt: defined using Racket -(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* (a) (if a false true)))") - -) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(repl-loop) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" + "env.rkt" "core.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval +(define (eval-ast ast env) + (cond + [(symbol? ast) (send env get ast)] + [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] + [(hash? ast) (make-hash + (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] + [else ast])) + +(define (EVAL ast env) + (if (or (not (list? ast)) (empty? ast)) + (eval-ast ast env) + + (let ([a0 (_nth ast 0)]) + (cond + [(eq? 'def! a0) + (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] + [(eq? 'let* a0) + (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) + (_map (lambda (b_e) + (send let-env set (_first b_e) + (EVAL (_nth b_e 1) let-env))) + (_partition 2 (_to_list (_nth ast 1)))) + (EVAL (_nth ast 2) let-env))] + [(eq? 'do a0) + (last (eval-ast (rest ast) env))] + [(eq? 'if a0) + (let ([cnd (EVAL (_nth ast 1) env)]) + (if (or (eq? cnd nil) (eq? cnd #f)) + (if (> (length ast) 3) + (EVAL (_nth ast 3) env) + nil) + (EVAL (_nth ast 2) env)))] + [(eq? 'fn* a0) + (lambda args (EVAL (_nth ast 2) + (new Env% [outer env] + [binds (_nth ast 1)] + [exprs args])))] + [else (let* ([el (eval-ast ast env)] + [f (first el)] + [args (rest el)]) + (apply f args))])))) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define repl-env + (new Env% [outer null] [binds null] [exprs null])) +(define (rep str) + (PRINT (EVAL (READ str) repl-env))) + +(for () ;; ignore return values + +;; core.rkt: defined using Racket +(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* (a) (if a false true)))") + +) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(repl-loop) diff --git a/impls/racket/step5_tco.rkt b/impls/racket/step5_tco.rkt index cdc5230894..8948270e5f 100755 --- a/impls/racket/step5_tco.rkt +++ b/impls/racket/step5_tco.rkt @@ -1,91 +1,91 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" - "env.rkt" "core.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval -(define (eval-ast ast env) - (cond - [(symbol? ast) (send env get ast)] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - (if (or (not (list? ast)) (empty? ast)) - (eval-ast ast env) - - (let ([a0 (_nth ast 0)]) - (cond - [(eq? 'def! a0) - (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] - [(eq? 'let* a0) - (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) - (_map (lambda (b_e) - (send let-env set (_first b_e) - (EVAL (_nth b_e 1) let-env))) - (_partition 2 (_to_list (_nth ast 1)))) - (EVAL (_nth ast 2) let-env))] - [(eq? 'do a0) - (eval-ast (drop (drop-right ast 1) 1) env) - (EVAL (last ast) env)] - [(eq? 'if a0) - (let ([cnd (EVAL (_nth ast 1) env)]) - (if (or (eq? cnd nil) (eq? cnd #f)) - (if (> (length ast) 3) - (EVAL (_nth ast 3) env) - nil) - (EVAL (_nth ast 2) env)))] - [(eq? 'fn* a0) - (malfunc - (lambda args (EVAL (_nth ast 2) - (new Env% [outer env] - [binds (_nth ast 1)] - [exprs args]))) - (_nth ast 2) env (_nth ast 1) #f nil)] - [else (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (if (malfunc? f) - (EVAL (malfunc-ast f) - (new Env% - [outer (malfunc-env f)] - [binds (malfunc-params f)] - [exprs args])) - (apply f args)))])))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env - (new Env% [outer null] [binds null] [exprs null])) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(for () ;; ignore return values - -;; core.rkt: defined using Racket -(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* (a) (if a false true)))") - -) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(repl-loop) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" + "env.rkt" "core.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval +(define (eval-ast ast env) + (cond + [(symbol? ast) (send env get ast)] + [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] + [(hash? ast) (make-hash + (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] + [else ast])) + +(define (EVAL ast env) + (if (or (not (list? ast)) (empty? ast)) + (eval-ast ast env) + + (let ([a0 (_nth ast 0)]) + (cond + [(eq? 'def! a0) + (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] + [(eq? 'let* a0) + (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) + (_map (lambda (b_e) + (send let-env set (_first b_e) + (EVAL (_nth b_e 1) let-env))) + (_partition 2 (_to_list (_nth ast 1)))) + (EVAL (_nth ast 2) let-env))] + [(eq? 'do a0) + (eval-ast (drop (drop-right ast 1) 1) env) + (EVAL (last ast) env)] + [(eq? 'if a0) + (let ([cnd (EVAL (_nth ast 1) env)]) + (if (or (eq? cnd nil) (eq? cnd #f)) + (if (> (length ast) 3) + (EVAL (_nth ast 3) env) + nil) + (EVAL (_nth ast 2) env)))] + [(eq? 'fn* a0) + (malfunc + (lambda args (EVAL (_nth ast 2) + (new Env% [outer env] + [binds (_nth ast 1)] + [exprs args]))) + (_nth ast 2) env (_nth ast 1) #f nil)] + [else (let* ([el (eval-ast ast env)] + [f (first el)] + [args (rest el)]) + (if (malfunc? f) + (EVAL (malfunc-ast f) + (new Env% + [outer (malfunc-env f)] + [binds (malfunc-params f)] + [exprs args])) + (apply f args)))])))) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define repl-env + (new Env% [outer null] [binds null] [exprs null])) +(define (rep str) + (PRINT (EVAL (READ str) repl-env))) + +(for () ;; ignore return values + +;; core.rkt: defined using Racket +(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* (a) (if a false true)))") + +) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(repl-loop) diff --git a/impls/racket/step6_file.rkt b/impls/racket/step6_file.rkt index 1db7a081f6..dcc6127710 100755 --- a/impls/racket/step6_file.rkt +++ b/impls/racket/step6_file.rkt @@ -1,97 +1,97 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" - "env.rkt" "core.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval -(define (eval-ast ast env) - (cond - [(symbol? ast) (send env get ast)] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - (if (or (not (list? ast)) (empty? ast)) - (eval-ast ast env) - - (let ([a0 (_nth ast 0)]) - (cond - [(eq? 'def! a0) - (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] - [(eq? 'let* a0) - (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) - (_map (lambda (b_e) - (send let-env set (_first b_e) - (EVAL (_nth b_e 1) let-env))) - (_partition 2 (_to_list (_nth ast 1)))) - (EVAL (_nth ast 2) let-env))] - [(eq? 'do a0) - (eval-ast (drop (drop-right ast 1) 1) env) - (EVAL (last ast) env)] - [(eq? 'if a0) - (let ([cnd (EVAL (_nth ast 1) env)]) - (if (or (eq? cnd nil) (eq? cnd #f)) - (if (> (length ast) 3) - (EVAL (_nth ast 3) env) - nil) - (EVAL (_nth ast 2) env)))] - [(eq? 'fn* a0) - (malfunc - (lambda args (EVAL (_nth ast 2) - (new Env% [outer env] - [binds (_nth ast 1)] - [exprs args]))) - (_nth ast 2) env (_nth ast 1) #f nil)] - [else (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (if (malfunc? f) - (EVAL (malfunc-ast f) - (new Env% - [outer (malfunc-env f)] - [binds (malfunc-params f)] - [exprs args])) - (apply f args)))])))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env - (new Env% [outer null] [binds null] [exprs null])) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(for () ;; ignore return values - -;; core.rkt: defined using Racket -(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) -(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) -(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(let ([args (current-command-line-arguments)]) - (if (> (vector-length args) 0) - (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) - (repl-loop))) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" + "env.rkt" "core.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval +(define (eval-ast ast env) + (cond + [(symbol? ast) (send env get ast)] + [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] + [(hash? ast) (make-hash + (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] + [else ast])) + +(define (EVAL ast env) + (if (or (not (list? ast)) (empty? ast)) + (eval-ast ast env) + + (let ([a0 (_nth ast 0)]) + (cond + [(eq? 'def! a0) + (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] + [(eq? 'let* a0) + (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) + (_map (lambda (b_e) + (send let-env set (_first b_e) + (EVAL (_nth b_e 1) let-env))) + (_partition 2 (_to_list (_nth ast 1)))) + (EVAL (_nth ast 2) let-env))] + [(eq? 'do a0) + (eval-ast (drop (drop-right ast 1) 1) env) + (EVAL (last ast) env)] + [(eq? 'if a0) + (let ([cnd (EVAL (_nth ast 1) env)]) + (if (or (eq? cnd nil) (eq? cnd #f)) + (if (> (length ast) 3) + (EVAL (_nth ast 3) env) + nil) + (EVAL (_nth ast 2) env)))] + [(eq? 'fn* a0) + (malfunc + (lambda args (EVAL (_nth ast 2) + (new Env% [outer env] + [binds (_nth ast 1)] + [exprs args]))) + (_nth ast 2) env (_nth ast 1) #f nil)] + [else (let* ([el (eval-ast ast env)] + [f (first el)] + [args (rest el)]) + (if (malfunc? f) + (EVAL (malfunc-ast f) + (new Env% + [outer (malfunc-env f)] + [binds (malfunc-params f)] + [exprs args])) + (apply f args)))])))) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define repl-env + (new Env% [outer null] [binds null] [exprs null])) +(define (rep str) + (PRINT (EVAL (READ str) repl-env))) + +(for () ;; ignore return values + +;; core.rkt: defined using Racket +(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) +(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) +(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(let ([args (current-command-line-arguments)]) + (if (> (vector-length args) 0) + (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) + (repl-loop))) diff --git a/impls/racket/step7_quote.rkt b/impls/racket/step7_quote.rkt index 3f2610aed9..83569cb434 100755 --- a/impls/racket/step7_quote.rkt +++ b/impls/racket/step7_quote.rkt @@ -1,126 +1,126 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" - "env.rkt" "core.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval - -(define (qq-loop elt acc) - (if (and (list? elt) (= (length elt) 2) (equal? (car elt) 'splice-unquote)) - (list 'concat (cadr elt) acc) - (list 'cons (quasiquote elt) acc))) - -(define (quasiquote ast) - (cond - [(or (symbol? ast) (hash? ast)) - (list 'quote ast)] - - [(vector? ast) - (list 'vec (foldr qq-loop null (_to_list ast)))] - - [(not (list? ast)) - ast] - - [(and (= (length ast) 2) (equal? (car ast) 'unquote)) - (cadr ast)] - - [else - (foldr qq-loop null ast)])) - -(define (eval-ast ast env) - (cond - [(symbol? ast) (send env get ast)] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - (if (or (not (list? ast)) (empty? ast)) - (eval-ast ast env) - - (let ([a0 (_nth ast 0)]) - (cond - [(eq? 'def! a0) - (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] - [(eq? 'let* a0) - (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) - (_map (lambda (b_e) - (send let-env set (_first b_e) - (EVAL (_nth b_e 1) let-env))) - (_partition 2 (_to_list (_nth ast 1)))) - (EVAL (_nth ast 2) let-env))] - [(eq? 'quote a0) - (_nth ast 1)] - [(eq? 'quasiquoteexpand a0) - (quasiquote (cadr ast))] - [(eq? 'quasiquote a0) - (EVAL (quasiquote (_nth ast 1)) env)] - [(eq? 'do a0) - (eval-ast (drop (drop-right ast 1) 1) env) - (EVAL (last ast) env)] - [(eq? 'if a0) - (let ([cnd (EVAL (_nth ast 1) env)]) - (if (or (eq? cnd nil) (eq? cnd #f)) - (if (> (length ast) 3) - (EVAL (_nth ast 3) env) - nil) - (EVAL (_nth ast 2) env)))] - [(eq? 'fn* a0) - (malfunc - (lambda args (EVAL (_nth ast 2) - (new Env% [outer env] - [binds (_nth ast 1)] - [exprs args]))) - (_nth ast 2) env (_nth ast 1) #f nil)] - [else (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (if (malfunc? f) - (EVAL (malfunc-ast f) - (new Env% - [outer (malfunc-env f)] - [binds (malfunc-params f)] - [exprs args])) - (apply f args)))])))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env - (new Env% [outer null] [binds null] [exprs null])) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(for () ;; ignore return values - -;; core.rkt: defined using Racket -(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) -(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) -(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(let ([args (current-command-line-arguments)]) - (if (> (vector-length args) 0) - (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) - (repl-loop))) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" + "env.rkt" "core.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval + +(define (qq-loop elt acc) + (if (and (list? elt) (= (length elt) 2) (equal? (car elt) 'splice-unquote)) + (list 'concat (cadr elt) acc) + (list 'cons (quasiquote elt) acc))) + +(define (quasiquote ast) + (cond + [(or (symbol? ast) (hash? ast)) + (list 'quote ast)] + + [(vector? ast) + (list 'vec (foldr qq-loop null (_to_list ast)))] + + [(not (list? ast)) + ast] + + [(and (= (length ast) 2) (equal? (car ast) 'unquote)) + (cadr ast)] + + [else + (foldr qq-loop null ast)])) + +(define (eval-ast ast env) + (cond + [(symbol? ast) (send env get ast)] + [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] + [(hash? ast) (make-hash + (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] + [else ast])) + +(define (EVAL ast env) + (if (or (not (list? ast)) (empty? ast)) + (eval-ast ast env) + + (let ([a0 (_nth ast 0)]) + (cond + [(eq? 'def! a0) + (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] + [(eq? 'let* a0) + (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) + (_map (lambda (b_e) + (send let-env set (_first b_e) + (EVAL (_nth b_e 1) let-env))) + (_partition 2 (_to_list (_nth ast 1)))) + (EVAL (_nth ast 2) let-env))] + [(eq? 'quote a0) + (_nth ast 1)] + [(eq? 'quasiquoteexpand a0) + (quasiquote (cadr ast))] + [(eq? 'quasiquote a0) + (EVAL (quasiquote (_nth ast 1)) env)] + [(eq? 'do a0) + (eval-ast (drop (drop-right ast 1) 1) env) + (EVAL (last ast) env)] + [(eq? 'if a0) + (let ([cnd (EVAL (_nth ast 1) env)]) + (if (or (eq? cnd nil) (eq? cnd #f)) + (if (> (length ast) 3) + (EVAL (_nth ast 3) env) + nil) + (EVAL (_nth ast 2) env)))] + [(eq? 'fn* a0) + (malfunc + (lambda args (EVAL (_nth ast 2) + (new Env% [outer env] + [binds (_nth ast 1)] + [exprs args]))) + (_nth ast 2) env (_nth ast 1) #f nil)] + [else (let* ([el (eval-ast ast env)] + [f (first el)] + [args (rest el)]) + (if (malfunc? f) + (EVAL (malfunc-ast f) + (new Env% + [outer (malfunc-env f)] + [binds (malfunc-params f)] + [exprs args])) + (apply f args)))])))) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define repl-env + (new Env% [outer null] [binds null] [exprs null])) +(define (rep str) + (PRINT (EVAL (READ str) repl-env))) + +(for () ;; ignore return values + +;; core.rkt: defined using Racket +(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) +(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) +(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(let ([args (current-command-line-arguments)]) + (if (> (vector-length args) 0) + (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) + (repl-loop))) diff --git a/impls/racket/step8_macros.rkt b/impls/racket/step8_macros.rkt index ccffa82286..c2ea5b4aa0 100755 --- a/impls/racket/step8_macros.rkt +++ b/impls/racket/step8_macros.rkt @@ -1,150 +1,150 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" - "env.rkt" "core.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval - -(define (qq-loop elt acc) - (if (and (list? elt) (= (length elt) 2) (equal? (car elt) 'splice-unquote)) - (list 'concat (cadr elt) acc) - (list 'cons (quasiquote elt) acc))) - -(define (quasiquote ast) - (cond - [(or (symbol? ast) (hash? ast)) - (list 'quote ast)] - - [(vector? ast) - (list 'vec (foldr qq-loop null (_to_list ast)))] - - [(not (list? ast)) - ast] - - [(and (= (length ast) 2) (equal? (car ast) 'unquote)) - (cadr ast)] - - [else - (foldr qq-loop null ast)])) - -(define (macro? ast env) - (and (list? ast) - (not (empty? ast)) - (symbol? (first ast)) - (not (equal? null (send env find (first ast)))) - (let ([fn (send env get (first ast))]) - (and (malfunc? fn) (malfunc-macro? fn))))) - -(define (macroexpand ast env) - (if (macro? ast env) - (let ([mac (malfunc-fn (send env get (first ast)))]) - (macroexpand (apply mac (rest ast)) env)) - ast)) - -(define (eval-ast ast env) - (cond - [(symbol? ast) (send env get ast)] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - (if (not (list? ast)) - (eval-ast ast env) - - (let ([ast (macroexpand ast env)]) - (if (or (not (list? ast)) (empty? ast)) - (eval-ast ast env) - (let ([a0 (_nth ast 0)]) - (cond - [(eq? 'def! a0) - (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] - [(eq? 'let* a0) - (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) - (_map (lambda (b_e) - (send let-env set (_first b_e) - (EVAL (_nth b_e 1) let-env))) - (_partition 2 (_to_list (_nth ast 1)))) - (EVAL (_nth ast 2) let-env))] - [(eq? 'quote a0) - (_nth ast 1)] - [(eq? 'quasiquoteexpand a0) - (quasiquote (cadr ast))] - [(eq? 'quasiquote a0) - (EVAL (quasiquote (_nth ast 1)) env)] - [(eq? 'defmacro! a0) - (let* ([func (EVAL (_nth ast 2) env)] - [mac (struct-copy malfunc func [macro? #t])]) - (send env set (_nth ast 1) mac))] - [(eq? 'macroexpand a0) - (macroexpand (_nth ast 1) env)] - [(eq? 'do a0) - (eval-ast (drop (drop-right ast 1) 1) env) - (EVAL (last ast) env)] - [(eq? 'if a0) - (let ([cnd (EVAL (_nth ast 1) env)]) - (if (or (eq? cnd nil) (eq? cnd #f)) - (if (> (length ast) 3) - (EVAL (_nth ast 3) env) - nil) - (EVAL (_nth ast 2) env)))] - [(eq? 'fn* a0) - (malfunc - (lambda args (EVAL (_nth ast 2) - (new Env% [outer env] - [binds (_nth ast 1)] - [exprs args]))) - (_nth ast 2) env (_nth ast 1) #f nil)] - [else (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (if (malfunc? f) - (EVAL (malfunc-ast f) - (new Env% - [outer (malfunc-env f)] - [binds (malfunc-params f)] - [exprs args])) - (apply f args)))])))))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env - (new Env% [outer null] [binds null] [exprs null])) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(for () ;; ignore return values - -;; core.rkt: defined using Racket -(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) -(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) -(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(let ([args (current-command-line-arguments)]) - (if (> (vector-length args) 0) - (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) - (repl-loop))) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" + "env.rkt" "core.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval + +(define (qq-loop elt acc) + (if (and (list? elt) (= (length elt) 2) (equal? (car elt) 'splice-unquote)) + (list 'concat (cadr elt) acc) + (list 'cons (quasiquote elt) acc))) + +(define (quasiquote ast) + (cond + [(or (symbol? ast) (hash? ast)) + (list 'quote ast)] + + [(vector? ast) + (list 'vec (foldr qq-loop null (_to_list ast)))] + + [(not (list? ast)) + ast] + + [(and (= (length ast) 2) (equal? (car ast) 'unquote)) + (cadr ast)] + + [else + (foldr qq-loop null ast)])) + +(define (macro? ast env) + (and (list? ast) + (not (empty? ast)) + (symbol? (first ast)) + (not (equal? null (send env find (first ast)))) + (let ([fn (send env get (first ast))]) + (and (malfunc? fn) (malfunc-macro? fn))))) + +(define (macroexpand ast env) + (if (macro? ast env) + (let ([mac (malfunc-fn (send env get (first ast)))]) + (macroexpand (apply mac (rest ast)) env)) + ast)) + +(define (eval-ast ast env) + (cond + [(symbol? ast) (send env get ast)] + [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] + [(hash? ast) (make-hash + (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] + [else ast])) + +(define (EVAL ast env) + (if (not (list? ast)) + (eval-ast ast env) + + (let ([ast (macroexpand ast env)]) + (if (or (not (list? ast)) (empty? ast)) + (eval-ast ast env) + (let ([a0 (_nth ast 0)]) + (cond + [(eq? 'def! a0) + (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] + [(eq? 'let* a0) + (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) + (_map (lambda (b_e) + (send let-env set (_first b_e) + (EVAL (_nth b_e 1) let-env))) + (_partition 2 (_to_list (_nth ast 1)))) + (EVAL (_nth ast 2) let-env))] + [(eq? 'quote a0) + (_nth ast 1)] + [(eq? 'quasiquoteexpand a0) + (quasiquote (cadr ast))] + [(eq? 'quasiquote a0) + (EVAL (quasiquote (_nth ast 1)) env)] + [(eq? 'defmacro! a0) + (let* ([func (EVAL (_nth ast 2) env)] + [mac (struct-copy malfunc func [macro? #t])]) + (send env set (_nth ast 1) mac))] + [(eq? 'macroexpand a0) + (macroexpand (_nth ast 1) env)] + [(eq? 'do a0) + (eval-ast (drop (drop-right ast 1) 1) env) + (EVAL (last ast) env)] + [(eq? 'if a0) + (let ([cnd (EVAL (_nth ast 1) env)]) + (if (or (eq? cnd nil) (eq? cnd #f)) + (if (> (length ast) 3) + (EVAL (_nth ast 3) env) + nil) + (EVAL (_nth ast 2) env)))] + [(eq? 'fn* a0) + (malfunc + (lambda args (EVAL (_nth ast 2) + (new Env% [outer env] + [binds (_nth ast 1)] + [exprs args]))) + (_nth ast 2) env (_nth ast 1) #f nil)] + [else (let* ([el (eval-ast ast env)] + [f (first el)] + [args (rest el)]) + (if (malfunc? f) + (EVAL (malfunc-ast f) + (new Env% + [outer (malfunc-env f)] + [binds (malfunc-params f)] + [exprs args])) + (apply f args)))])))))) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define repl-env + (new Env% [outer null] [binds null] [exprs null])) +(define (rep str) + (PRINT (EVAL (READ str) repl-env))) + +(for () ;; ignore return values + +;; core.rkt: defined using Racket +(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) +(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) +(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(let ([args (current-command-line-arguments)]) + (if (> (vector-length args) 0) + (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) + (repl-loop))) diff --git a/impls/racket/step9_try.rkt b/impls/racket/step9_try.rkt index 633fe1c04f..40e9e7c9c8 100755 --- a/impls/racket/step9_try.rkt +++ b/impls/racket/step9_try.rkt @@ -1,168 +1,168 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" - "env.rkt" "core.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval - -(define (qq-loop elt acc) - (if (and (list? elt) (= (length elt) 2) (equal? (car elt) 'splice-unquote)) - (list 'concat (cadr elt) acc) - (list 'cons (quasiquote elt) acc))) - -(define (quasiquote ast) - (cond - [(or (symbol? ast) (hash? ast)) - (list 'quote ast)] - - [(vector? ast) - (list 'vec (foldr qq-loop null (_to_list ast)))] - - [(not (list? ast)) - ast] - - [(and (= (length ast) 2) (equal? (car ast) 'unquote)) - (cadr ast)] - - [else - (foldr qq-loop null ast)])) - -(define (macro? ast env) - (and (list? ast) - (not (empty? ast)) - (symbol? (first ast)) - (not (equal? null (send env find (first ast)))) - (let ([fn (send env get (first ast))]) - (and (malfunc? fn) (malfunc-macro? fn))))) - -(define (macroexpand ast env) - (if (macro? ast env) - (let ([mac (malfunc-fn (send env get (first ast)))]) - (macroexpand (apply mac (rest ast)) env)) - ast)) - -(define (eval-ast ast env) - (cond - [(symbol? ast) (send env get ast)] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - ;(printf "~a~n" (pr_str ast true)) - (if (not (list? ast)) - (eval-ast ast env) - - (let ([ast (macroexpand ast env)]) - (if (or (not (list? ast)) (empty? ast)) - (eval-ast ast env) - (let ([a0 (_nth ast 0)]) - (cond - [(eq? 'def! a0) - (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] - [(eq? 'let* a0) - (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) - (_map (lambda (b_e) - (send let-env set (_first b_e) - (EVAL (_nth b_e 1) let-env))) - (_partition 2 (_to_list (_nth ast 1)))) - (EVAL (_nth ast 2) let-env))] - [(eq? 'quote a0) - (_nth ast 1)] - [(eq? 'quasiquoteexpand a0) - (quasiquote (cadr ast))] - [(eq? 'quasiquote a0) - (EVAL (quasiquote (_nth ast 1)) env)] - [(eq? 'defmacro! a0) - (let* ([func (EVAL (_nth ast 2) env)] - [mac (struct-copy malfunc func [macro? #t])]) - (send env set (_nth ast 1) mac))] - [(eq? 'macroexpand a0) - (macroexpand (_nth ast 1) env)] - [(eq? 'try* a0) - (if (or (< (length ast) 3) - (not (eq? 'catch* (_nth (_nth ast 2) 0)))) - (EVAL (_nth ast 1) env) - (let ([efn (lambda (exc) - (EVAL (_nth (_nth ast 2) 2) - (new Env% - [outer env] - [binds (list (_nth (_nth ast 2) 1))] - [exprs (list exc)])))]) - (with-handlers - ([mal-exn? (lambda (exc) (efn (mal-exn-val exc)))] - [string? (lambda (exc) (efn exc))] - [exn:fail? (lambda (exc) (efn (format "~a" exc)))]) - (EVAL (_nth ast 1) env))))] - [(eq? 'do a0) - (eval-ast (drop (drop-right ast 1) 1) env) - (EVAL (last ast) env)] - [(eq? 'if a0) - (let ([cnd (EVAL (_nth ast 1) env)]) - (if (or (eq? cnd nil) (eq? cnd #f)) - (if (> (length ast) 3) - (EVAL (_nth ast 3) env) - nil) - (EVAL (_nth ast 2) env)))] - [(eq? 'fn* a0) - (malfunc - (lambda args (EVAL (_nth ast 2) - (new Env% [outer env] - [binds (_nth ast 1)] - [exprs args]))) - (_nth ast 2) env (_nth ast 1) #f nil)] - [else (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (if (malfunc? f) - (EVAL (malfunc-ast f) - (new Env% - [outer (malfunc-env f)] - [binds (malfunc-params f)] - [exprs args])) - (apply f args)))])))))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env - (new Env% [outer null] [binds null] [exprs null])) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(for () ;; ignore return values - -;; core.rkt: defined using Racket -(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) -(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) -(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) - -;; core.mal: defined using the language itself -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [mal-exn? (lambda (exc) (printf "Error: ~a~n" - (pr_str (mal-exn-val exc) true)))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(let ([args (current-command-line-arguments)]) - (if (> (vector-length args) 0) - (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) - (repl-loop))) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" + "env.rkt" "core.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval + +(define (qq-loop elt acc) + (if (and (list? elt) (= (length elt) 2) (equal? (car elt) 'splice-unquote)) + (list 'concat (cadr elt) acc) + (list 'cons (quasiquote elt) acc))) + +(define (quasiquote ast) + (cond + [(or (symbol? ast) (hash? ast)) + (list 'quote ast)] + + [(vector? ast) + (list 'vec (foldr qq-loop null (_to_list ast)))] + + [(not (list? ast)) + ast] + + [(and (= (length ast) 2) (equal? (car ast) 'unquote)) + (cadr ast)] + + [else + (foldr qq-loop null ast)])) + +(define (macro? ast env) + (and (list? ast) + (not (empty? ast)) + (symbol? (first ast)) + (not (equal? null (send env find (first ast)))) + (let ([fn (send env get (first ast))]) + (and (malfunc? fn) (malfunc-macro? fn))))) + +(define (macroexpand ast env) + (if (macro? ast env) + (let ([mac (malfunc-fn (send env get (first ast)))]) + (macroexpand (apply mac (rest ast)) env)) + ast)) + +(define (eval-ast ast env) + (cond + [(symbol? ast) (send env get ast)] + [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] + [(hash? ast) (make-hash + (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] + [else ast])) + +(define (EVAL ast env) + ;(printf "~a~n" (pr_str ast true)) + (if (not (list? ast)) + (eval-ast ast env) + + (let ([ast (macroexpand ast env)]) + (if (or (not (list? ast)) (empty? ast)) + (eval-ast ast env) + (let ([a0 (_nth ast 0)]) + (cond + [(eq? 'def! a0) + (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] + [(eq? 'let* a0) + (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) + (_map (lambda (b_e) + (send let-env set (_first b_e) + (EVAL (_nth b_e 1) let-env))) + (_partition 2 (_to_list (_nth ast 1)))) + (EVAL (_nth ast 2) let-env))] + [(eq? 'quote a0) + (_nth ast 1)] + [(eq? 'quasiquoteexpand a0) + (quasiquote (cadr ast))] + [(eq? 'quasiquote a0) + (EVAL (quasiquote (_nth ast 1)) env)] + [(eq? 'defmacro! a0) + (let* ([func (EVAL (_nth ast 2) env)] + [mac (struct-copy malfunc func [macro? #t])]) + (send env set (_nth ast 1) mac))] + [(eq? 'macroexpand a0) + (macroexpand (_nth ast 1) env)] + [(eq? 'try* a0) + (if (or (< (length ast) 3) + (not (eq? 'catch* (_nth (_nth ast 2) 0)))) + (EVAL (_nth ast 1) env) + (let ([efn (lambda (exc) + (EVAL (_nth (_nth ast 2) 2) + (new Env% + [outer env] + [binds (list (_nth (_nth ast 2) 1))] + [exprs (list exc)])))]) + (with-handlers + ([mal-exn? (lambda (exc) (efn (mal-exn-val exc)))] + [string? (lambda (exc) (efn exc))] + [exn:fail? (lambda (exc) (efn (format "~a" exc)))]) + (EVAL (_nth ast 1) env))))] + [(eq? 'do a0) + (eval-ast (drop (drop-right ast 1) 1) env) + (EVAL (last ast) env)] + [(eq? 'if a0) + (let ([cnd (EVAL (_nth ast 1) env)]) + (if (or (eq? cnd nil) (eq? cnd #f)) + (if (> (length ast) 3) + (EVAL (_nth ast 3) env) + nil) + (EVAL (_nth ast 2) env)))] + [(eq? 'fn* a0) + (malfunc + (lambda args (EVAL (_nth ast 2) + (new Env% [outer env] + [binds (_nth ast 1)] + [exprs args]))) + (_nth ast 2) env (_nth ast 1) #f nil)] + [else (let* ([el (eval-ast ast env)] + [f (first el)] + [args (rest el)]) + (if (malfunc? f) + (EVAL (malfunc-ast f) + (new Env% + [outer (malfunc-env f)] + [binds (malfunc-params f)] + [exprs args])) + (apply f args)))])))))) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define repl-env + (new Env% [outer null] [binds null] [exprs null])) +(define (rep str) + (PRINT (EVAL (READ str) repl-env))) + +(for () ;; ignore return values + +;; core.rkt: defined using Racket +(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) +(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) +(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) + +;; core.mal: defined using the language itself +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [mal-exn? (lambda (exc) (printf "Error: ~a~n" + (pr_str (mal-exn-val exc) true)))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(let ([args (current-command-line-arguments)]) + (if (> (vector-length args) 0) + (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) + (repl-loop))) diff --git a/impls/racket/stepA_mal.rkt b/impls/racket/stepA_mal.rkt index 9b68e7097d..068d6e400c 100755 --- a/impls/racket/stepA_mal.rkt +++ b/impls/racket/stepA_mal.rkt @@ -1,173 +1,173 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" - "env.rkt" "core.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval - -(define (qq-loop elt acc) - (if (and (list? elt) (= (length elt) 2) (equal? (car elt) 'splice-unquote)) - (list 'concat (cadr elt) acc) - (list 'cons (quasiquote elt) acc))) - -(define (quasiquote ast) - (cond - [(or (symbol? ast) (hash? ast)) - (list 'quote ast)] - - [(vector? ast) - (list 'vec (foldr qq-loop null (_to_list ast)))] - - [(not (list? ast)) - ast] - - [(and (= (length ast) 2) (equal? (car ast) 'unquote)) - (cadr ast)] - - [else - (foldr qq-loop null ast)])) - -(define (macro? ast env) - (and (list? ast) - (not (empty? ast)) - (symbol? (first ast)) - (not (equal? null (send env find (first ast)))) - (let ([fn (send env get (first ast))]) - (and (malfunc? fn) (malfunc-macro? fn))))) - -(define (macroexpand ast env) - (if (macro? ast env) - (let ([mac (malfunc-fn (send env get (first ast)))]) - (macroexpand (apply mac (rest ast)) env)) - ast)) - -(define (eval-ast ast env) - (cond - [(symbol? ast) (send env get ast)] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - ;(printf "~a~n" (pr_str ast true)) - (if (not (list? ast)) - (eval-ast ast env) - - (let ([ast (macroexpand ast env)]) - (if (or (not (list? ast)) (empty? ast)) - (eval-ast ast env) - (let ([a0 (_nth ast 0)]) - (cond - [(eq? 'def! a0) - (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] - [(eq? 'let* a0) - (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) - (_map (lambda (b_e) - (send let-env set (_first b_e) - (EVAL (_nth b_e 1) let-env))) - (_partition 2 (_to_list (_nth ast 1)))) - (EVAL (_nth ast 2) let-env))] - [(eq? 'quote a0) - (_nth ast 1)] - [(eq? 'quasiquoteexpand a0) - (quasiquote (cadr ast))] - [(eq? 'quasiquote a0) - (EVAL (quasiquote (_nth ast 1)) env)] - [(eq? 'defmacro! a0) - (let* ([func (EVAL (_nth ast 2) env)] - [mac (struct-copy malfunc func [macro? #t])]) - (send env set (_nth ast 1) mac))] - [(eq? 'macroexpand a0) - (macroexpand (_nth ast 1) env)] - [(eq? 'try* a0) - (if (or (< (length ast) 3) - (not (eq? 'catch* (_nth (_nth ast 2) 0)))) - (EVAL (_nth ast 1) env) - (let ([efn (lambda (exc) - (EVAL (_nth (_nth ast 2) 2) - (new Env% - [outer env] - [binds (list (_nth (_nth ast 2) 1))] - [exprs (list exc)])))]) - (with-handlers - ([mal-exn? (lambda (exc) (efn (mal-exn-val exc)))] - [string? (lambda (exc) (efn exc))] - [exn:fail? (lambda (exc) (efn (format "~a" exc)))]) - (EVAL (_nth ast 1) env))))] - [(eq? 'do a0) - (eval-ast (drop (drop-right ast 1) 1) env) - (EVAL (last ast) env)] - [(eq? 'if a0) - (let ([cnd (EVAL (_nth ast 1) env)]) - (if (or (eq? cnd nil) (eq? cnd #f)) - (if (> (length ast) 3) - (EVAL (_nth ast 3) env) - nil) - (EVAL (_nth ast 2) env)))] - [(eq? 'fn* a0) - (malfunc - (lambda args (EVAL (_nth ast 2) - (new Env% [outer env] - [binds (_nth ast 1)] - [exprs args]))) - (_nth ast 2) env (_nth ast 1) #f nil)] - [else (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (if (malfunc? f) - (EVAL (malfunc-ast f) - (new Env% - [outer (malfunc-env f)] - [binds (malfunc-params f)] - [exprs args])) - (apply f args)))])))))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env - (new Env% [outer null] [binds null] [exprs null])) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(for () ;; ignore return values - -;; core.rkt: defined using Racket -(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) -(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) -(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) - -;; core.mal: defined using the language itself -(rep "(def! *host-language* \"racket\")") -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -) - -(define (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [mal-exn? (lambda (exc) (printf "Error: ~a~n" - (pr_str (mal-exn-val exc) true)))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(let ([args (current-command-line-arguments)]) - (if (> (vector-length args) 0) - (begin - (send repl-env set '*ARGV* (vector->list (vector-drop args 1))) - (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")")))) - (begin - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (repl-loop)))) +#!/usr/bin/env racket +#lang racket + +(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" + "env.rkt" "core.rkt") + +;; read +(define (READ str) + (read_str str)) + +;; eval + +(define (qq-loop elt acc) + (if (and (list? elt) (= (length elt) 2) (equal? (car elt) 'splice-unquote)) + (list 'concat (cadr elt) acc) + (list 'cons (quasiquote elt) acc))) + +(define (quasiquote ast) + (cond + [(or (symbol? ast) (hash? ast)) + (list 'quote ast)] + + [(vector? ast) + (list 'vec (foldr qq-loop null (_to_list ast)))] + + [(not (list? ast)) + ast] + + [(and (= (length ast) 2) (equal? (car ast) 'unquote)) + (cadr ast)] + + [else + (foldr qq-loop null ast)])) + +(define (macro? ast env) + (and (list? ast) + (not (empty? ast)) + (symbol? (first ast)) + (not (equal? null (send env find (first ast)))) + (let ([fn (send env get (first ast))]) + (and (malfunc? fn) (malfunc-macro? fn))))) + +(define (macroexpand ast env) + (if (macro? ast env) + (let ([mac (malfunc-fn (send env get (first ast)))]) + (macroexpand (apply mac (rest ast)) env)) + ast)) + +(define (eval-ast ast env) + (cond + [(symbol? ast) (send env get ast)] + [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] + [(hash? ast) (make-hash + (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] + [else ast])) + +(define (EVAL ast env) + ;(printf "~a~n" (pr_str ast true)) + (if (not (list? ast)) + (eval-ast ast env) + + (let ([ast (macroexpand ast env)]) + (if (or (not (list? ast)) (empty? ast)) + (eval-ast ast env) + (let ([a0 (_nth ast 0)]) + (cond + [(eq? 'def! a0) + (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] + [(eq? 'let* a0) + (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) + (_map (lambda (b_e) + (send let-env set (_first b_e) + (EVAL (_nth b_e 1) let-env))) + (_partition 2 (_to_list (_nth ast 1)))) + (EVAL (_nth ast 2) let-env))] + [(eq? 'quote a0) + (_nth ast 1)] + [(eq? 'quasiquoteexpand a0) + (quasiquote (cadr ast))] + [(eq? 'quasiquote a0) + (EVAL (quasiquote (_nth ast 1)) env)] + [(eq? 'defmacro! a0) + (let* ([func (EVAL (_nth ast 2) env)] + [mac (struct-copy malfunc func [macro? #t])]) + (send env set (_nth ast 1) mac))] + [(eq? 'macroexpand a0) + (macroexpand (_nth ast 1) env)] + [(eq? 'try* a0) + (if (or (< (length ast) 3) + (not (eq? 'catch* (_nth (_nth ast 2) 0)))) + (EVAL (_nth ast 1) env) + (let ([efn (lambda (exc) + (EVAL (_nth (_nth ast 2) 2) + (new Env% + [outer env] + [binds (list (_nth (_nth ast 2) 1))] + [exprs (list exc)])))]) + (with-handlers + ([mal-exn? (lambda (exc) (efn (mal-exn-val exc)))] + [string? (lambda (exc) (efn exc))] + [exn:fail? (lambda (exc) (efn (format "~a" exc)))]) + (EVAL (_nth ast 1) env))))] + [(eq? 'do a0) + (eval-ast (drop (drop-right ast 1) 1) env) + (EVAL (last ast) env)] + [(eq? 'if a0) + (let ([cnd (EVAL (_nth ast 1) env)]) + (if (or (eq? cnd nil) (eq? cnd #f)) + (if (> (length ast) 3) + (EVAL (_nth ast 3) env) + nil) + (EVAL (_nth ast 2) env)))] + [(eq? 'fn* a0) + (malfunc + (lambda args (EVAL (_nth ast 2) + (new Env% [outer env] + [binds (_nth ast 1)] + [exprs args]))) + (_nth ast 2) env (_nth ast 1) #f nil)] + [else (let* ([el (eval-ast ast env)] + [f (first el)] + [args (rest el)]) + (if (malfunc? f) + (EVAL (malfunc-ast f) + (new Env% + [outer (malfunc-env f)] + [binds (malfunc-params f)] + [exprs args])) + (apply f args)))])))))) + +;; print +(define (PRINT exp) + (pr_str exp true)) + +;; repl +(define repl-env + (new Env% [outer null] [binds null] [exprs null])) +(define (rep str) + (PRINT (EVAL (READ str) repl-env))) + +(for () ;; ignore return values + +;; core.rkt: defined using Racket +(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) +(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) +(send repl-env set '*ARGV* (_rest (current-command-line-arguments))) + +;; core.mal: defined using the language itself +(rep "(def! *host-language* \"racket\")") +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +) + +(define (repl-loop) + (let ([line (readline "user> ")]) + (when (not (eq? nil line)) + (with-handlers + ([string? (lambda (exc) (printf "Error: ~a~n" exc))] + [mal-exn? (lambda (exc) (printf "Error: ~a~n" + (pr_str (mal-exn-val exc) true)))] + [blank-exn? (lambda (exc) null)]) + (printf "~a~n" (rep line))) + (repl-loop)))) +(let ([args (current-command-line-arguments)]) + (if (> (vector-length args) 0) + (begin + (send repl-env set '*ARGV* (vector->list (vector-drop args 1))) + (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")")))) + (begin + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (repl-loop)))) diff --git a/impls/racket/tests/step5_tco.mal b/impls/racket/tests/step5_tco.mal index 93286cd766..581d410506 100644 --- a/impls/racket/tests/step5_tco.mal +++ b/impls/racket/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Racket: skipping non-TCO recursion -;; Reason: completes up to 1,000,000 +;; Racket: skipping non-TCO recursion +;; Reason: completes up to 1,000,000 diff --git a/impls/racket/types.rkt b/impls/racket/types.rkt index 22f7498548..5379f70a3e 100644 --- a/impls/racket/types.rkt +++ b/impls/racket/types.rkt @@ -1,123 +1,123 @@ -#lang racket - -(provide blank-exn? make-blank-exn mal-exn? make-mal-exn mal-exn-val - malfunc malfunc? malfunc-fn - malfunc-ast malfunc-env malfunc-params malfunc-macro? malfunc-meta - _partition _equal? _printf - nil _nil? _keyword _keyword? _string? - _to_list _sequential? _count _empty? _nth _first _rest _map - _assoc _dissoc _get - atom atom? atom-val set-atom-val!) - -(define-struct (blank-exn exn:fail:user) ()) -(define-struct (mal-exn exn:fail:user) [val]) - -(define nil% - (class object% - (super-new))) - -(define nil (new nil%)) - -(define (_nil? obj) - (eq? nil obj)) - -(struct malfunc [fn ast env params macro? meta] - #:property prop:procedure (struct-field-index fn)) - -;; General functions - -;; From: http://stackoverflow.com/questions/8725832/how-to-split-list-into-evenly-sized-chunks-in-racket-scheme/8731622#8731622 -(define (_partition n xs) - (if (null? xs) - '() - (let ((first-chunk (take xs n)) - (rest (drop xs n))) - (cons first-chunk (_partition n rest))))) - -(define (_equal_seqs? seq_a seq_b) - (let ([a (_to_list seq_a)] - [b (_to_list seq_b)]) - (and (= (length a) (length b)) - (andmap (lambda (va vb) (_equal? va vb)) a b)))) - -(define (_equal_hashes? a b) - (if (= (hash-count a) (hash-count b)) - (let ([keys (hash-keys a)]) - (andmap (lambda (k) (_equal? (_get a k) (_get b k))) keys)) - #f)) - -(define (_equal? a b) - (cond - [(and (_sequential? a) (_sequential? b)) (_equal_seqs? a b)] - [(and (hash? a) (hash? b)) (_equal_hashes? a b)] - [else (equal? a b)])) - -;; printf with flush -(define _printf (lambda a (apply printf a) (flush-output))) - -;; Keywords -(define (_keyword str) - (string-append "\u029e" str)) - -(define (_keyword? k) - (and (string? k) (regexp-match? #px"^\u029e" k))) - -;; Strings -(define (_string? s) - (and (string? s) (not (_keyword? s)))) - -;; Lists and vectors - -(define (_to_list a) - (if (vector? a) (vector->list a) a)) - -(define (_sequential? seq) - (or (vector? seq) (list? seq))) - -(define (_count seq) - (cond [(_nil? seq) 0] - [(vector? seq) (vector-length seq)] - [else (length seq)])) - -(define (_empty? seq) - (eq? 0 (_count seq))) - -(define (_nth seq idx) - (cond [(>= idx (_count seq)) (raise "nth: index out of range")] - [(vector? seq) (vector-ref seq idx)] - [else (list-ref seq idx)])) - -(define (_first seq) - (cond [(vector? seq) (if (_empty? seq) nil (vector-ref seq 0))] - [else (if (_empty? seq) nil (list-ref seq 0))])) - -(define (_rest seq) - (cond [(vector? seq) (if (_empty? seq) '() (rest (vector->list seq)))] - [else (if (_empty? seq) '() (rest seq))])) - -(define (_map f seq) - (cond [(vector? seq) (vector-map f seq)] - [else (map f seq)])) - -;; Hash maps -(define _assoc - (lambda args - (let ([new-hm (hash-copy (first args))] - [pairs (_partition 2 (rest args))]) - (map (lambda (k_v) - (hash-set! new-hm (first k_v) (second k_v))) pairs) - new-hm))) - -(define _dissoc - (lambda args - (let ([new-hm (hash-copy (first args))]) - (map (lambda (k) (hash-remove! new-hm k)) (rest args)) - new-hm))) - -(define (_get hm k) - (cond [(_nil? hm) nil] - [(dict-has-key? hm k) (hash-ref hm k)] - [else nil])) - -;; Atoms -(struct atom [val] #:mutable) +#lang racket + +(provide blank-exn? make-blank-exn mal-exn? make-mal-exn mal-exn-val + malfunc malfunc? malfunc-fn + malfunc-ast malfunc-env malfunc-params malfunc-macro? malfunc-meta + _partition _equal? _printf + nil _nil? _keyword _keyword? _string? + _to_list _sequential? _count _empty? _nth _first _rest _map + _assoc _dissoc _get + atom atom? atom-val set-atom-val!) + +(define-struct (blank-exn exn:fail:user) ()) +(define-struct (mal-exn exn:fail:user) [val]) + +(define nil% + (class object% + (super-new))) + +(define nil (new nil%)) + +(define (_nil? obj) + (eq? nil obj)) + +(struct malfunc [fn ast env params macro? meta] + #:property prop:procedure (struct-field-index fn)) + +;; General functions + +;; From: http://stackoverflow.com/questions/8725832/how-to-split-list-into-evenly-sized-chunks-in-racket-scheme/8731622#8731622 +(define (_partition n xs) + (if (null? xs) + '() + (let ((first-chunk (take xs n)) + (rest (drop xs n))) + (cons first-chunk (_partition n rest))))) + +(define (_equal_seqs? seq_a seq_b) + (let ([a (_to_list seq_a)] + [b (_to_list seq_b)]) + (and (= (length a) (length b)) + (andmap (lambda (va vb) (_equal? va vb)) a b)))) + +(define (_equal_hashes? a b) + (if (= (hash-count a) (hash-count b)) + (let ([keys (hash-keys a)]) + (andmap (lambda (k) (_equal? (_get a k) (_get b k))) keys)) + #f)) + +(define (_equal? a b) + (cond + [(and (_sequential? a) (_sequential? b)) (_equal_seqs? a b)] + [(and (hash? a) (hash? b)) (_equal_hashes? a b)] + [else (equal? a b)])) + +;; printf with flush +(define _printf (lambda a (apply printf a) (flush-output))) + +;; Keywords +(define (_keyword str) + (string-append "\u029e" str)) + +(define (_keyword? k) + (and (string? k) (regexp-match? #px"^\u029e" k))) + +;; Strings +(define (_string? s) + (and (string? s) (not (_keyword? s)))) + +;; Lists and vectors + +(define (_to_list a) + (if (vector? a) (vector->list a) a)) + +(define (_sequential? seq) + (or (vector? seq) (list? seq))) + +(define (_count seq) + (cond [(_nil? seq) 0] + [(vector? seq) (vector-length seq)] + [else (length seq)])) + +(define (_empty? seq) + (eq? 0 (_count seq))) + +(define (_nth seq idx) + (cond [(>= idx (_count seq)) (raise "nth: index out of range")] + [(vector? seq) (vector-ref seq idx)] + [else (list-ref seq idx)])) + +(define (_first seq) + (cond [(vector? seq) (if (_empty? seq) nil (vector-ref seq 0))] + [else (if (_empty? seq) nil (list-ref seq 0))])) + +(define (_rest seq) + (cond [(vector? seq) (if (_empty? seq) '() (rest (vector->list seq)))] + [else (if (_empty? seq) '() (rest seq))])) + +(define (_map f seq) + (cond [(vector? seq) (vector-map f seq)] + [else (map f seq)])) + +;; Hash maps +(define _assoc + (lambda args + (let ([new-hm (hash-copy (first args))] + [pairs (_partition 2 (rest args))]) + (map (lambda (k_v) + (hash-set! new-hm (first k_v) (second k_v))) pairs) + new-hm))) + +(define _dissoc + (lambda args + (let ([new-hm (hash-copy (first args))]) + (map (lambda (k) (hash-remove! new-hm k)) (rest args)) + new-hm))) + +(define (_get hm k) + (cond [(_nil? hm) nil] + [(dict-has-key? hm k) (hash-ref hm k)] + [else nil])) + +;; Atoms +(struct atom [val] #:mutable) diff --git a/impls/rexx/.gitignore b/impls/rexx/.gitignore index 8b0a0636a6..e3fb4384c4 100644 --- a/impls/rexx/.gitignore +++ b/impls/rexx/.gitignore @@ -1 +1 @@ -*.rexxpp +*.rexxpp diff --git a/impls/rexx/Dockerfile b/impls/rexx/Dockerfile index 83b666f13f..77cbe874ab 100644 --- a/impls/rexx/Dockerfile +++ b/impls/rexx/Dockerfile @@ -1,26 +1,26 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install cpp regina-rexx - -ENV HOME /mal +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install cpp regina-rexx + +ENV HOME /mal diff --git a/impls/rexx/Makefile b/impls/rexx/Makefile index b5a49b3b94..0808fa036a 100644 --- a/impls/rexx/Makefile +++ b/impls/rexx/Makefile @@ -1,24 +1,24 @@ -SRCS = step0_repl.rexx step1_read_print.rexx step2_eval.rexx step3_env.rexx \ - step4_if_fn_do.rexx step5_tco.rexx step6_file.rexx step7_quote.rexx \ - step8_macros.rexx step9_try.rexx stepA_mal.rexx -PREPROCESSED = $(SRCS:%.rexx=%.rexxpp) - -all: $(PREPROCESSED) dist - -dist: mal - -mal: mal.rexxpp - echo "#!/usr/bin/rexx -a" > $@ - cat $< >> $@ - chmod +x $@ - -mal.rexxpp: stepA_mal.rexxpp - cp -a $+ $@ - -$(PREPROCESSED): %.rexxpp: %.rexx readline.rexx types.rexx reader.rexx printer.rexx env.rexx core.rexx - cpp -CC -P -nostdinc $< > $@ - -clean: - rm -f mal.rexx mal *.rexxpp - -.PHONY: all dist clean +SRCS = step0_repl.rexx step1_read_print.rexx step2_eval.rexx step3_env.rexx \ + step4_if_fn_do.rexx step5_tco.rexx step6_file.rexx step7_quote.rexx \ + step8_macros.rexx step9_try.rexx stepA_mal.rexx +PREPROCESSED = $(SRCS:%.rexx=%.rexxpp) + +all: $(PREPROCESSED) dist + +dist: mal + +mal: mal.rexxpp + echo "#!/usr/bin/rexx -a" > $@ + cat $< >> $@ + chmod +x $@ + +mal.rexxpp: stepA_mal.rexxpp + cp -a $+ $@ + +$(PREPROCESSED): %.rexxpp: %.rexx readline.rexx types.rexx reader.rexx printer.rexx env.rexx core.rexx + cpp -CC -P -nostdinc $< > $@ + +clean: + rm -f mal.rexx mal *.rexxpp + +.PHONY: all dist clean diff --git a/impls/rexx/core.rexx b/impls/rexx/core.rexx index f92fd221b8..d0073af1c5 100644 --- a/impls/rexx/core.rexx +++ b/impls/rexx/core.rexx @@ -1,514 +1,514 @@ -#ifndef __core__ -#define __core__ - -#include "types.rexx" - -mal_equal?: procedure expose values. /* mal_equal?(a, b) */ - return new_boolean(equal?(arg(1), arg(2))) - -mal_throw: procedure expose values. err /* mal_throw(a) */ - err = "__MAL_EXCEPTION__" arg(1) - return "ERR" - -mal_nil?: procedure expose values. /* mal_nil?(a) */ - return new_boolean(nil?(arg(1))) - -mal_true?: procedure expose values. /* mal_true?(a) */ - return new_boolean(true?(arg(1))) - -mal_false?: procedure expose values. /* mal_false?(a) */ - return new_boolean(false?(arg(1))) - -mal_string?: procedure expose values. /* mal_string?(a) */ - return new_boolean(string?(arg(1))) - -mal_symbol: procedure expose values. /* mal_symbol(a) */ - return new_symbol(obj_val(arg(1))) - -mal_symbol?: procedure expose values. /* mal_symbol?(a) */ - return new_boolean(symbol?(arg(1))) - -mal_keyword: procedure expose values. /* mal_keyword(a) */ - return new_keyword(obj_val(arg(1))) - -mal_keyword?: procedure expose values. /* mal_keyword?(a) */ - return new_boolean(keyword?(arg(1))) - -mal_number?: procedure expose values. /* mal_number?(a) */ - return new_boolean(number?(arg(1))) - -mal_fn?: procedure expose values. /* mal_fn?(a) */ - return new_boolean(nativefn?(arg(1)) | (func?(arg(1)) & (func_is_macro(arg(1)) \= 1))) - -mal_macro?: procedure expose values. /* mal_macro?(a) */ - return new_boolean(func_macro?(arg(1))) - -mal_pr_str: procedure expose values. /* mal_pr_str(...) */ - res = "" - do i=1 to arg() - element = pr_str(arg(i), 1) - if i == 1 then - res = element - else - res = res || " " || element - end - return new_string(res) - -mal_str: procedure expose values. /* mal_str(...) */ - res = "" - do i=1 to arg() - element = pr_str(arg(i), 0) - if i == 1 then - res = element - else - res = res || element - end - return new_string(res) - -mal_prn: procedure expose values. /* mal_prn(...) */ - res = "" - do i=1 to arg() - element = pr_str(arg(i), 1) - if i == 1 then - res = element - else - res = res || " " || element - end - say res - return new_nil() - -mal_println: procedure expose values. /* mal_println(...) */ - res = "" - do i=1 to arg() - element = pr_str(arg(i), 0) - if i == 1 then - res = element - else - res = res || " " || element - end - say res - return new_nil() - -mal_read_string: procedure expose values. err /* mal_read_string(str) */ - return read_str(obj_val(arg(1))) - -mal_readline: procedure expose values. /* mal_readline(prompt) */ - line = readline(obj_val(arg(1))) - if length(line) > 0 then return new_string(line) - if lines() > 0 then return new_string("") - return new_nil() - -mal_slurp: procedure expose values. /* mal_read_string(filename) */ - file_content = charin(obj_val(arg(1)), 1, 100000) - return new_string(file_content) - -mal_lt: procedure expose values. /* mal_lt(a, b) */ - return new_boolean(obj_val(arg(1)) < obj_val(arg(2))) - -mal_lte: procedure expose values. /* mal_lte(a, b) */ - return new_boolean(obj_val(arg(1)) <= obj_val(arg(2))) - -mal_gt: procedure expose values. /* mal_gt(a, b) */ - return new_boolean(obj_val(arg(1)) > obj_val(arg(2))) - -mal_gte: procedure expose values. /* mal_gte(a, b) */ - return new_boolean(obj_val(arg(1)) >= obj_val(arg(2))) - -mal_add: procedure expose values. /* mal_add(a, b) */ - return new_number(obj_val(arg(1)) + obj_val(arg(2))) - -mal_sub: procedure expose values. /* mal_sub(a, b) */ - return new_number(obj_val(arg(1)) - obj_val(arg(2))) - -mal_mul: procedure expose values. /* mal_mul(a, b) */ - return new_number(obj_val(arg(1)) * obj_val(arg(2))) - -mal_div: procedure expose values. /* mal_div(a, b) */ - return new_number(obj_val(arg(1)) / obj_val(arg(2))) - -mal_time_ms: procedure expose values. /* mal_time_ms() */ - return new_number(trunc(time('E') * 1000)) - -mal_list: procedure expose values. /* mal_list(...) */ - res = "" - do i=1 to arg() - if i == 1 then - res = arg(i) - else - res = res || " " || arg(i) - end - return new_list(res) - -mal_list?: procedure expose values. /* mal_list?(a) */ - return new_boolean(list?(arg(1))) - -mal_vector: procedure expose values. /* mal_vector(...) */ - res = "" - do i=1 to arg() - if i == 1 then - res = arg(i) - else - res = res || " " || arg(i) - end - return new_vector(res) - -mal_vector?: procedure expose values. /* mal_vector?(a) */ - return new_boolean(vector?(arg(1))) - -mal_hash_map: procedure expose values. /* mal_hash_map(...) */ - res = "" - do i=1 to arg() - if i == 1 then - res = arg(i) - else - res = res || " " || arg(i) - end - return new_hashmap(res) - -mal_map?: procedure expose values. /* mal_map?(a) */ - return new_boolean(hashmap?(arg(1))) - -mal_assoc: procedure expose values. /* mal_assoc(a, ...) */ - hm = arg(1) - res = "" - do i=2 to arg() by 2 - key_val = arg(i) || " " || arg(i + 1) - if res == 2 then - res = key_val - else - res = res || " " || key_val - end - hm_val = obj_val(hm) - do i=1 to words(hm_val) by 2 - if \contains?(res, word(hm_val, i)) then - res = res || " " || word(hm_val, i) || " " || word(hm_val, i + 1) - end - return new_hashmap(res) - -mal_dissoc: procedure expose values. /* mal_dissoc(a, ...) */ - hm = arg(1) - res = "" - hm_val = obj_val(hm) - do i=1 to words(hm_val) by 2 - key = word(hm_val, i) - found = 0 - do j=2 to arg() - if equal?(key, arg(j)) then do - found = 1 - leave - end - end - if \found then do - if length(res) > 0 then res = res || " " - res = res || key || " " || word(hm_val, i + 1) - end - end - return new_hashmap(res) - -mal_get: procedure expose values. /* mal_get(a, b) */ - res = hashmap_get(obj_val(arg(1)), arg(2)) - if res == "" then - return new_nil() - else - return res - -mal_contains?: procedure expose values. /* mal_contains?(a, b) */ - return new_boolean(contains?(obj_val(arg(1)), arg(2))) - -mal_keys: procedure expose values. /* mal_keys(a) */ - hm_val = obj_val(arg(1)) - seq = "" - do i=1 to words(hm_val) by 2 - if i == 1 then - seq = word(hm_val, i) - else - seq = seq || " " || word(hm_val, i) - end - return new_list(seq) - -mal_vals: procedure expose values. /* mal_vals(a) */ - hm_val = obj_val(arg(1)) - seq = "" - do i=2 to words(hm_val) by 2 - if i == 1 then - seq = word(hm_val, i) - else - seq = seq || " " || word(hm_val, i) - end - return new_list(seq) - -mal_sequential?: procedure expose values. /* mal_sequential?(a) */ - return new_boolean(sequential?(arg(1))) - -mal_cons: procedure expose values. /* mal_cons(a, b) */ - return new_list(arg(1) || " " || obj_val(arg(2))) - -mal_concat: procedure expose values. /* mal_concat(...) */ - seq = "" - do i=1 to arg() - if i == 1 then - seq = obj_val(arg(i)) - else - seq = seq || " " || obj_val(arg(i)) - end - return new_list(seq) - -mal_vec: procedure expose values. /* mal_vec(a) */ - return new_vector(obj_val(arg(1))) - -mal_nth: procedure expose values. err /* mal_nth(list, index) */ - list_val = obj_val(arg(1)) - i = obj_val(arg(2)) - if i >= words(list_val) then do - err = "nth: index out of range" - return "ERR" - end - return word(list_val, i + 1) - -mal_first: procedure expose values. /* mal_first(a) */ - if nil?(arg(1)) then return new_nil() - list_val = obj_val(arg(1)) - if words(list_val) == 0 then return new_nil() - return word(list_val, 1) - -mal_rest: procedure expose values. /* mal_rest(a) */ - return new_list(subword(obj_val(arg(1)), 2)) - -mal_empty?: procedure expose values. /* mal_empty?(a) */ - if nil?(arg(1)) then return new_true() - return new_boolean(count_elements(arg(1)) == 0) - -mal_count: procedure expose values. /* mal_count(a) */ - if nil?(arg(1)) then return new_number(0) - return new_number(count_elements(arg(1))) - -apply_function: procedure expose values. env. err /* apply_function(fn, lst) */ - f = arg(1) - call_args = arg(2) - select - when nativefn?(f) then do - call_args_val = obj_val(call_args) - call_list = "" - do i=1 to words(call_args_val) - element = '"' || word(call_args_val, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || obj_val(f) || "(" || call_list || ")" - return res - end - when func?(f) then do - apply_env_idx = new_env(func_env_idx(f), func_binds(f), call_args) - return eval(func_body_ast(f), apply_env_idx) - end - otherwise - err = "Unsupported function object type: " || obj_type(f) - return "ERR" - end - -mal_apply: procedure expose values. env. err /* mal_apply(fn, ..., lst) */ - fn = arg(1) - seq = "" - do i=2 to (arg() - 1) - if i == 2 then - seq = arg(i) - else - seq = seq || " " || arg(i) - end - if arg() > 1 then do - seq = seq || " " || obj_val(arg(arg())) - end - return apply_function(fn, new_list(seq)) - -mal_map: procedure expose values. env. err /* mal_map(f, lst) */ - fn = arg(1) - lst_val = obj_val(arg(2)) - res = "" - do i=1 to words(lst_val) - element = word(lst_val, i) - mapped_element = apply_function(fn, new_list(element)) - if mapped_element == "ERR" then return "ERR" - if i == 1 then - res = mapped_element - else - res = res || " " || mapped_element - end - return new_list(res) - -mal_conj: procedure expose values. env. err /* mal_conj(a, ...) */ - a = arg(1) - select - when list?(a) then do - do i=2 to arg() - a = mal_cons(arg(i), a) - end - return a - end - when vector?(a) then do - seq = obj_val(a) - do i=2 to arg() - if length(seq) > 0 then seq = seq || " " - seq = seq || arg(i) - end - return new_vector(seq) - end - otherwise - err = "conj requires list or vector" - return "ERR" - end - -mal_seq: procedure expose values. env. err /* mal_conj(a) */ - a = arg(1) - select - when string?(a) then do - str = obj_val(a) - if length(str) == 0 then return new_nil() - seq = "" - do i=1 to length(str) - element = new_string(substr(str, i, 1)) - if i == 1 then - seq = element - else - seq = seq || " " || element - end - return new_list(seq) - end - when list?(a) then do - if count_elements(a) == 0 then return new_nil() - return a - end - when vector?(a) then do - if count_elements(a) == 0 then return new_nil() - return new_list(obj_val(a)) - end - when nil?(a) then return new_nil() - otherwise - err = "seq requires string or list or vector or nil" - return "ERR" - end - -mal_with_meta: procedure expose values. /* mal_with_meta(a, b) */ - new_obj = obj_clone_and_set_meta(arg(1), arg(2)) - if new_obj == "" then return arg(1) - return new_obj - -mal_meta: procedure expose values. /* mal_meta(a) */ - meta = obj_meta(arg(1)) - if meta == "" then return new_nil() - return meta - -mal_atom: procedure expose values. /* mal_atom(a) */ - return new_atom(arg(1)) - -mal_atom?: procedure expose values. /* mal_atom?(a) */ - return new_boolean(atom?(arg(1))) - -mal_deref: procedure expose values. /* mal_deref(a) */ - return obj_val(arg(1)) - -mal_reset!: procedure expose values. /* mal_reset!(a, new_val) */ - return atom_set(arg(1), arg(2)) - -mal_swap!: procedure expose values. env. err /* mal_swap!(a, fn, ...) */ - atom = arg(1) - fn = arg(2) - atom_val = obj_val(atom) - seq = atom_val - do i=3 to arg() - seq = seq || " " || arg(i) - end - new_val = apply_function(fn, new_list(seq)) - if new_val == "ERR" then return "ERR" - return atom_set(atom, new_val) - -mal_rexx_eval: procedure expose values. /* mal_rexx_eval(..., a) */ - do i=1 to (arg() - 1) - interpret obj_val(arg(i)) - end - last_arg = arg(arg()) - if nil?(last_arg) then return new_nil() - last_arg_str = obj_val(last_arg) - if length(last_arg_str) == 0 then return new_nil() - rexx_eval_res = "" - interpret "rexx_eval_res = " || last_arg_str - if datatype(rexx_eval_res) == "NUM" then - return new_number(rexx_eval_res) - else - return new_string(rexx_eval_res) - -get_core_ns: procedure /* get_core_ns() */ - return "= mal_equal?" , - "throw mal_throw" , - , - "nil? mal_nil?" , - "true? mal_true?" , - "false? mal_false?" , - "string? mal_string?" , - "symbol mal_symbol" , - "symbol? mal_symbol?" , - "keyword mal_keyword" , - "keyword? mal_keyword?" , - "number? mal_number?" , - "fn? mal_fn?" , - "macro? mal_macro?" , - , - "pr-str mal_pr_str" , - "str mal_str" , - "prn mal_prn" , - "println mal_println" , - "read-string mal_read_string" , - "readline mal_readline" , - "slurp mal_slurp" , - , - "< mal_lt" , - "<= mal_lte" , - "> mal_gt" , - ">= mal_gte" , - "+ mal_add" , - "- mal_sub" , - "* mal_mul" , - "/ mal_div" , - "time-ms mal_time_ms" , - , - "list mal_list" , - "list? mal_list?" , - "vector mal_vector" , - "vector? mal_vector?" , - "hash-map mal_hash_map" , - "map? mal_map?" , - "assoc mal_assoc" , - "dissoc mal_dissoc" , - "get mal_get" , - "contains? mal_contains?" , - "keys mal_keys" , - "vals mal_vals" , - , - "sequential? mal_sequential?" , - "cons mal_cons" , - "concat mal_concat" , - "vec mal_vec" , - "nth mal_nth" , - "first mal_first" , - "rest mal_rest" , - "empty? mal_empty?" , - "count mal_count" , - "apply mal_apply" , - "map mal_map" , - , - "conj mal_conj" , - "seq mal_seq" , - , - "meta mal_meta" , - "with-meta mal_with_meta" , - "atom mal_atom" , - "atom? mal_atom?" , - "deref mal_deref" , - "reset! mal_reset!" , - "swap! mal_swap!" , - , - "rexx-eval mal_rexx_eval" - -#endif +#ifndef __core__ +#define __core__ + +#include "types.rexx" + +mal_equal?: procedure expose values. /* mal_equal?(a, b) */ + return new_boolean(equal?(arg(1), arg(2))) + +mal_throw: procedure expose values. err /* mal_throw(a) */ + err = "__MAL_EXCEPTION__" arg(1) + return "ERR" + +mal_nil?: procedure expose values. /* mal_nil?(a) */ + return new_boolean(nil?(arg(1))) + +mal_true?: procedure expose values. /* mal_true?(a) */ + return new_boolean(true?(arg(1))) + +mal_false?: procedure expose values. /* mal_false?(a) */ + return new_boolean(false?(arg(1))) + +mal_string?: procedure expose values. /* mal_string?(a) */ + return new_boolean(string?(arg(1))) + +mal_symbol: procedure expose values. /* mal_symbol(a) */ + return new_symbol(obj_val(arg(1))) + +mal_symbol?: procedure expose values. /* mal_symbol?(a) */ + return new_boolean(symbol?(arg(1))) + +mal_keyword: procedure expose values. /* mal_keyword(a) */ + return new_keyword(obj_val(arg(1))) + +mal_keyword?: procedure expose values. /* mal_keyword?(a) */ + return new_boolean(keyword?(arg(1))) + +mal_number?: procedure expose values. /* mal_number?(a) */ + return new_boolean(number?(arg(1))) + +mal_fn?: procedure expose values. /* mal_fn?(a) */ + return new_boolean(nativefn?(arg(1)) | (func?(arg(1)) & (func_is_macro(arg(1)) \= 1))) + +mal_macro?: procedure expose values. /* mal_macro?(a) */ + return new_boolean(func_macro?(arg(1))) + +mal_pr_str: procedure expose values. /* mal_pr_str(...) */ + res = "" + do i=1 to arg() + element = pr_str(arg(i), 1) + if i == 1 then + res = element + else + res = res || " " || element + end + return new_string(res) + +mal_str: procedure expose values. /* mal_str(...) */ + res = "" + do i=1 to arg() + element = pr_str(arg(i), 0) + if i == 1 then + res = element + else + res = res || element + end + return new_string(res) + +mal_prn: procedure expose values. /* mal_prn(...) */ + res = "" + do i=1 to arg() + element = pr_str(arg(i), 1) + if i == 1 then + res = element + else + res = res || " " || element + end + say res + return new_nil() + +mal_println: procedure expose values. /* mal_println(...) */ + res = "" + do i=1 to arg() + element = pr_str(arg(i), 0) + if i == 1 then + res = element + else + res = res || " " || element + end + say res + return new_nil() + +mal_read_string: procedure expose values. err /* mal_read_string(str) */ + return read_str(obj_val(arg(1))) + +mal_readline: procedure expose values. /* mal_readline(prompt) */ + line = readline(obj_val(arg(1))) + if length(line) > 0 then return new_string(line) + if lines() > 0 then return new_string("") + return new_nil() + +mal_slurp: procedure expose values. /* mal_read_string(filename) */ + file_content = charin(obj_val(arg(1)), 1, 100000) + return new_string(file_content) + +mal_lt: procedure expose values. /* mal_lt(a, b) */ + return new_boolean(obj_val(arg(1)) < obj_val(arg(2))) + +mal_lte: procedure expose values. /* mal_lte(a, b) */ + return new_boolean(obj_val(arg(1)) <= obj_val(arg(2))) + +mal_gt: procedure expose values. /* mal_gt(a, b) */ + return new_boolean(obj_val(arg(1)) > obj_val(arg(2))) + +mal_gte: procedure expose values. /* mal_gte(a, b) */ + return new_boolean(obj_val(arg(1)) >= obj_val(arg(2))) + +mal_add: procedure expose values. /* mal_add(a, b) */ + return new_number(obj_val(arg(1)) + obj_val(arg(2))) + +mal_sub: procedure expose values. /* mal_sub(a, b) */ + return new_number(obj_val(arg(1)) - obj_val(arg(2))) + +mal_mul: procedure expose values. /* mal_mul(a, b) */ + return new_number(obj_val(arg(1)) * obj_val(arg(2))) + +mal_div: procedure expose values. /* mal_div(a, b) */ + return new_number(obj_val(arg(1)) / obj_val(arg(2))) + +mal_time_ms: procedure expose values. /* mal_time_ms() */ + return new_number(trunc(time('E') * 1000)) + +mal_list: procedure expose values. /* mal_list(...) */ + res = "" + do i=1 to arg() + if i == 1 then + res = arg(i) + else + res = res || " " || arg(i) + end + return new_list(res) + +mal_list?: procedure expose values. /* mal_list?(a) */ + return new_boolean(list?(arg(1))) + +mal_vector: procedure expose values. /* mal_vector(...) */ + res = "" + do i=1 to arg() + if i == 1 then + res = arg(i) + else + res = res || " " || arg(i) + end + return new_vector(res) + +mal_vector?: procedure expose values. /* mal_vector?(a) */ + return new_boolean(vector?(arg(1))) + +mal_hash_map: procedure expose values. /* mal_hash_map(...) */ + res = "" + do i=1 to arg() + if i == 1 then + res = arg(i) + else + res = res || " " || arg(i) + end + return new_hashmap(res) + +mal_map?: procedure expose values. /* mal_map?(a) */ + return new_boolean(hashmap?(arg(1))) + +mal_assoc: procedure expose values. /* mal_assoc(a, ...) */ + hm = arg(1) + res = "" + do i=2 to arg() by 2 + key_val = arg(i) || " " || arg(i + 1) + if res == 2 then + res = key_val + else + res = res || " " || key_val + end + hm_val = obj_val(hm) + do i=1 to words(hm_val) by 2 + if \contains?(res, word(hm_val, i)) then + res = res || " " || word(hm_val, i) || " " || word(hm_val, i + 1) + end + return new_hashmap(res) + +mal_dissoc: procedure expose values. /* mal_dissoc(a, ...) */ + hm = arg(1) + res = "" + hm_val = obj_val(hm) + do i=1 to words(hm_val) by 2 + key = word(hm_val, i) + found = 0 + do j=2 to arg() + if equal?(key, arg(j)) then do + found = 1 + leave + end + end + if \found then do + if length(res) > 0 then res = res || " " + res = res || key || " " || word(hm_val, i + 1) + end + end + return new_hashmap(res) + +mal_get: procedure expose values. /* mal_get(a, b) */ + res = hashmap_get(obj_val(arg(1)), arg(2)) + if res == "" then + return new_nil() + else + return res + +mal_contains?: procedure expose values. /* mal_contains?(a, b) */ + return new_boolean(contains?(obj_val(arg(1)), arg(2))) + +mal_keys: procedure expose values. /* mal_keys(a) */ + hm_val = obj_val(arg(1)) + seq = "" + do i=1 to words(hm_val) by 2 + if i == 1 then + seq = word(hm_val, i) + else + seq = seq || " " || word(hm_val, i) + end + return new_list(seq) + +mal_vals: procedure expose values. /* mal_vals(a) */ + hm_val = obj_val(arg(1)) + seq = "" + do i=2 to words(hm_val) by 2 + if i == 1 then + seq = word(hm_val, i) + else + seq = seq || " " || word(hm_val, i) + end + return new_list(seq) + +mal_sequential?: procedure expose values. /* mal_sequential?(a) */ + return new_boolean(sequential?(arg(1))) + +mal_cons: procedure expose values. /* mal_cons(a, b) */ + return new_list(arg(1) || " " || obj_val(arg(2))) + +mal_concat: procedure expose values. /* mal_concat(...) */ + seq = "" + do i=1 to arg() + if i == 1 then + seq = obj_val(arg(i)) + else + seq = seq || " " || obj_val(arg(i)) + end + return new_list(seq) + +mal_vec: procedure expose values. /* mal_vec(a) */ + return new_vector(obj_val(arg(1))) + +mal_nth: procedure expose values. err /* mal_nth(list, index) */ + list_val = obj_val(arg(1)) + i = obj_val(arg(2)) + if i >= words(list_val) then do + err = "nth: index out of range" + return "ERR" + end + return word(list_val, i + 1) + +mal_first: procedure expose values. /* mal_first(a) */ + if nil?(arg(1)) then return new_nil() + list_val = obj_val(arg(1)) + if words(list_val) == 0 then return new_nil() + return word(list_val, 1) + +mal_rest: procedure expose values. /* mal_rest(a) */ + return new_list(subword(obj_val(arg(1)), 2)) + +mal_empty?: procedure expose values. /* mal_empty?(a) */ + if nil?(arg(1)) then return new_true() + return new_boolean(count_elements(arg(1)) == 0) + +mal_count: procedure expose values. /* mal_count(a) */ + if nil?(arg(1)) then return new_number(0) + return new_number(count_elements(arg(1))) + +apply_function: procedure expose values. env. err /* apply_function(fn, lst) */ + f = arg(1) + call_args = arg(2) + select + when nativefn?(f) then do + call_args_val = obj_val(call_args) + call_list = "" + do i=1 to words(call_args_val) + element = '"' || word(call_args_val, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + apply_env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + return eval(func_body_ast(f), apply_env_idx) + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + +mal_apply: procedure expose values. env. err /* mal_apply(fn, ..., lst) */ + fn = arg(1) + seq = "" + do i=2 to (arg() - 1) + if i == 2 then + seq = arg(i) + else + seq = seq || " " || arg(i) + end + if arg() > 1 then do + seq = seq || " " || obj_val(arg(arg())) + end + return apply_function(fn, new_list(seq)) + +mal_map: procedure expose values. env. err /* mal_map(f, lst) */ + fn = arg(1) + lst_val = obj_val(arg(2)) + res = "" + do i=1 to words(lst_val) + element = word(lst_val, i) + mapped_element = apply_function(fn, new_list(element)) + if mapped_element == "ERR" then return "ERR" + if i == 1 then + res = mapped_element + else + res = res || " " || mapped_element + end + return new_list(res) + +mal_conj: procedure expose values. env. err /* mal_conj(a, ...) */ + a = arg(1) + select + when list?(a) then do + do i=2 to arg() + a = mal_cons(arg(i), a) + end + return a + end + when vector?(a) then do + seq = obj_val(a) + do i=2 to arg() + if length(seq) > 0 then seq = seq || " " + seq = seq || arg(i) + end + return new_vector(seq) + end + otherwise + err = "conj requires list or vector" + return "ERR" + end + +mal_seq: procedure expose values. env. err /* mal_conj(a) */ + a = arg(1) + select + when string?(a) then do + str = obj_val(a) + if length(str) == 0 then return new_nil() + seq = "" + do i=1 to length(str) + element = new_string(substr(str, i, 1)) + if i == 1 then + seq = element + else + seq = seq || " " || element + end + return new_list(seq) + end + when list?(a) then do + if count_elements(a) == 0 then return new_nil() + return a + end + when vector?(a) then do + if count_elements(a) == 0 then return new_nil() + return new_list(obj_val(a)) + end + when nil?(a) then return new_nil() + otherwise + err = "seq requires string or list or vector or nil" + return "ERR" + end + +mal_with_meta: procedure expose values. /* mal_with_meta(a, b) */ + new_obj = obj_clone_and_set_meta(arg(1), arg(2)) + if new_obj == "" then return arg(1) + return new_obj + +mal_meta: procedure expose values. /* mal_meta(a) */ + meta = obj_meta(arg(1)) + if meta == "" then return new_nil() + return meta + +mal_atom: procedure expose values. /* mal_atom(a) */ + return new_atom(arg(1)) + +mal_atom?: procedure expose values. /* mal_atom?(a) */ + return new_boolean(atom?(arg(1))) + +mal_deref: procedure expose values. /* mal_deref(a) */ + return obj_val(arg(1)) + +mal_reset!: procedure expose values. /* mal_reset!(a, new_val) */ + return atom_set(arg(1), arg(2)) + +mal_swap!: procedure expose values. env. err /* mal_swap!(a, fn, ...) */ + atom = arg(1) + fn = arg(2) + atom_val = obj_val(atom) + seq = atom_val + do i=3 to arg() + seq = seq || " " || arg(i) + end + new_val = apply_function(fn, new_list(seq)) + if new_val == "ERR" then return "ERR" + return atom_set(atom, new_val) + +mal_rexx_eval: procedure expose values. /* mal_rexx_eval(..., a) */ + do i=1 to (arg() - 1) + interpret obj_val(arg(i)) + end + last_arg = arg(arg()) + if nil?(last_arg) then return new_nil() + last_arg_str = obj_val(last_arg) + if length(last_arg_str) == 0 then return new_nil() + rexx_eval_res = "" + interpret "rexx_eval_res = " || last_arg_str + if datatype(rexx_eval_res) == "NUM" then + return new_number(rexx_eval_res) + else + return new_string(rexx_eval_res) + +get_core_ns: procedure /* get_core_ns() */ + return "= mal_equal?" , + "throw mal_throw" , + , + "nil? mal_nil?" , + "true? mal_true?" , + "false? mal_false?" , + "string? mal_string?" , + "symbol mal_symbol" , + "symbol? mal_symbol?" , + "keyword mal_keyword" , + "keyword? mal_keyword?" , + "number? mal_number?" , + "fn? mal_fn?" , + "macro? mal_macro?" , + , + "pr-str mal_pr_str" , + "str mal_str" , + "prn mal_prn" , + "println mal_println" , + "read-string mal_read_string" , + "readline mal_readline" , + "slurp mal_slurp" , + , + "< mal_lt" , + "<= mal_lte" , + "> mal_gt" , + ">= mal_gte" , + "+ mal_add" , + "- mal_sub" , + "* mal_mul" , + "/ mal_div" , + "time-ms mal_time_ms" , + , + "list mal_list" , + "list? mal_list?" , + "vector mal_vector" , + "vector? mal_vector?" , + "hash-map mal_hash_map" , + "map? mal_map?" , + "assoc mal_assoc" , + "dissoc mal_dissoc" , + "get mal_get" , + "contains? mal_contains?" , + "keys mal_keys" , + "vals mal_vals" , + , + "sequential? mal_sequential?" , + "cons mal_cons" , + "concat mal_concat" , + "vec mal_vec" , + "nth mal_nth" , + "first mal_first" , + "rest mal_rest" , + "empty? mal_empty?" , + "count mal_count" , + "apply mal_apply" , + "map mal_map" , + , + "conj mal_conj" , + "seq mal_seq" , + , + "meta mal_meta" , + "with-meta mal_with_meta" , + "atom mal_atom" , + "atom? mal_atom?" , + "deref mal_deref" , + "reset! mal_reset!" , + "swap! mal_swap!" , + , + "rexx-eval mal_rexx_eval" + +#endif diff --git a/impls/rexx/env.rexx b/impls/rexx/env.rexx index 4dec7e62bf..df1d903acb 100644 --- a/impls/rexx/env.rexx +++ b/impls/rexx/env.rexx @@ -1,59 +1,59 @@ -#ifndef __env__ -#define __env__ - -env. = "" -env.0 = 0 - -new_env_index: procedure expose env. /* new_env_index() */ - env.0 = env.0 + 1 - return env.0 - -new_env: procedure expose env. values. /* new_env(outer_env_idx [, binds, exprs]) */ - outer_env_idx = arg(1) - binds = arg(2) - exprs = arg(3) - idx = new_env_index() - env.idx.outer = outer_env_idx - env.idx.data. = "" - if binds \= "" then do - binds_val = obj_val(binds) - exprs_val = obj_val(exprs) - do i=1 to words(binds_val) - varname = obj_val(word(binds_val, i)) - if varname == "&" then do - rest_args_list = new_list(subword(exprs_val, i)) - varname = obj_val(word(binds_val, i + 1)) - x = env_set(idx, varname, rest_args_list) - leave - end - else - x = env_set(idx, varname, word(exprs_val, i)) - end - end - return idx - -env_set: procedure expose env. /* env_set(env_idx, key, val) */ - env_idx = arg(1) - key = arg(2) - val = arg(3) - env.env_idx.data.key = val - return val - -env_find: procedure expose env. /* env_find(env_idx, key) */ - env_idx = arg(1) - key = arg(2) - if env.env_idx.data.key \= "" then return env_idx - if env.env_idx.outer > 0 then return env_find(env.env_idx.outer, key) - return 0 - -env_get: procedure expose env. err /* env_get(env_idx, key) */ - env_idx = arg(1) - key = arg(2) - found_env_idx = env_find(env_idx, key) - if found_env_idx == 0 then do - err = "'" || key || "' not found" - return "ERR" - end - return env.found_env_idx.data.key - -#endif +#ifndef __env__ +#define __env__ + +env. = "" +env.0 = 0 + +new_env_index: procedure expose env. /* new_env_index() */ + env.0 = env.0 + 1 + return env.0 + +new_env: procedure expose env. values. /* new_env(outer_env_idx [, binds, exprs]) */ + outer_env_idx = arg(1) + binds = arg(2) + exprs = arg(3) + idx = new_env_index() + env.idx.outer = outer_env_idx + env.idx.data. = "" + if binds \= "" then do + binds_val = obj_val(binds) + exprs_val = obj_val(exprs) + do i=1 to words(binds_val) + varname = obj_val(word(binds_val, i)) + if varname == "&" then do + rest_args_list = new_list(subword(exprs_val, i)) + varname = obj_val(word(binds_val, i + 1)) + x = env_set(idx, varname, rest_args_list) + leave + end + else + x = env_set(idx, varname, word(exprs_val, i)) + end + end + return idx + +env_set: procedure expose env. /* env_set(env_idx, key, val) */ + env_idx = arg(1) + key = arg(2) + val = arg(3) + env.env_idx.data.key = val + return val + +env_find: procedure expose env. /* env_find(env_idx, key) */ + env_idx = arg(1) + key = arg(2) + if env.env_idx.data.key \= "" then return env_idx + if env.env_idx.outer > 0 then return env_find(env.env_idx.outer, key) + return 0 + +env_get: procedure expose env. err /* env_get(env_idx, key) */ + env_idx = arg(1) + key = arg(2) + found_env_idx = env_find(env_idx, key) + if found_env_idx == 0 then do + err = "'" || key || "' not found" + return "ERR" + end + return env.found_env_idx.data.key + +#endif diff --git a/impls/rexx/printer.rexx b/impls/rexx/printer.rexx index e7922ef0ab..5d924eb63b 100644 --- a/impls/rexx/printer.rexx +++ b/impls/rexx/printer.rexx @@ -1,54 +1,54 @@ -#ifndef __printer__ -#define __printer__ - -#include "types.rexx" - -format_string: procedure /* format_string(str, readable) */ - str = arg(1) - readable = arg(2) - if readable then do - res = changestr('5C'x, str, "\\") - res = changestr('"', res, '\"') - res = changestr('0A'x, res, "\n") - return '"' || res || '"' - end - else - return str - -format_sequence: procedure expose values. /* format_sequence(val, open_char, close_char, readable) */ - val = arg(1) - open_char = arg(2) - close_char = arg(3) - readable = arg(4) - res = "" - do i=1 to words(val) - element = word(val, i) - if i > 1 then res = res || " " - res = res || pr_str(element, readable) - end - return open_char || res || close_char - -pr_str: procedure expose values. /* pr_str(ast, readable) */ - ast = arg(1) - readable = arg(2) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "nill" then return "nil" - when type == "true" then return "true" - when type == "fals" then return "false" - when type == "numb" then return val - when type == "symb" then return val - when type == "stri" then return format_string(val, readable) - when type == "keyw" then return ":" || val - when type == "list" then return format_sequence(val, "(", ")", readable) - when type == "vect" then return format_sequence(val, "[", "]", readable) - when type == "hash" then return format_sequence(val, "{", "}", readable) - when type == "nafn" then return "#" - when type == "func" then return "#" - when type == "atom" then return "(atom " || pr_str(val, readable) || ")" - otherwise - return "#" - end - -#endif +#ifndef __printer__ +#define __printer__ + +#include "types.rexx" + +format_string: procedure /* format_string(str, readable) */ + str = arg(1) + readable = arg(2) + if readable then do + res = changestr('5C'x, str, "\\") + res = changestr('"', res, '\"') + res = changestr('0A'x, res, "\n") + return '"' || res || '"' + end + else + return str + +format_sequence: procedure expose values. /* format_sequence(val, open_char, close_char, readable) */ + val = arg(1) + open_char = arg(2) + close_char = arg(3) + readable = arg(4) + res = "" + do i=1 to words(val) + element = word(val, i) + if i > 1 then res = res || " " + res = res || pr_str(element, readable) + end + return open_char || res || close_char + +pr_str: procedure expose values. /* pr_str(ast, readable) */ + ast = arg(1) + readable = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "nill" then return "nil" + when type == "true" then return "true" + when type == "fals" then return "false" + when type == "numb" then return val + when type == "symb" then return val + when type == "stri" then return format_string(val, readable) + when type == "keyw" then return ":" || val + when type == "list" then return format_sequence(val, "(", ")", readable) + when type == "vect" then return format_sequence(val, "[", "]", readable) + when type == "hash" then return format_sequence(val, "{", "}", readable) + when type == "nafn" then return "#" + when type == "func" then return "#" + when type == "atom" then return "(atom " || pr_str(val, readable) || ")" + otherwise + return "#" + end + +#endif diff --git a/impls/rexx/reader.rexx b/impls/rexx/reader.rexx index cb8e8e8832..d0ea4cbdf6 100644 --- a/impls/rexx/reader.rexx +++ b/impls/rexx/reader.rexx @@ -1,206 +1,206 @@ -#ifndef __reader__ -#define __reader__ - -#include "types.rexx" - -next_token: procedure expose pos /* next_token(str) */ - TAB = '09'x - LF = '0A'x - CR = '0D'x - SEPARATOR_CHARS = TAB || LF || CR || " []{}()'`,;" || '"' - WHITESPACE_CHARS = TAB || LF || CR || " ," - str = arg(1) - token = "" - ch = substr(str, pos, 1) - select - when pos(ch, WHITESPACE_CHARS) > 0 then - pos = pos + 1 - when pos(ch, "[]{}()'`^@") > 0 then do - pos = pos + 1 - token = ch - end - when ch == '~' then do - if substr(str, pos + 1, 1) == '@' then do - pos = pos + 2 - token = "~@" - end - else do - pos = pos + 1 - token = "~" - end - end - when ch == ";" then do - do while pos <= length(str) - ch = substr(str, pos, 1) - if (ch == LF) | (ch == CR) then - leave - else - pos = pos + 1 - end - end - when ch == '"' then do - tmppos = pos + 1 - do while tmppos < length(str) - ch = substr(str, tmppos, 1) - select - when ch == '"' then - leave - when ch == '5C'x then /* backslash */ - tmppos = tmppos + 2 - otherwise - tmppos = tmppos + 1 - end - end - token = substr(str, pos, tmppos - pos + 1) - pos = tmppos + 1 - end - otherwise - tmppos = pos - do while tmppos <= length(str) - ch = substr(str, tmppos, 1) - if pos(ch, SEPARATOR_CHARS) > 0 then - leave - else - token = token || ch - tmppos = tmppos + 1 - end - pos = tmppos - end - return token - -tokenize: procedure expose tokens. /* tokenize(str) */ - str = arg(1) - tokens. = "" - num_of_tokens = 0 - str_to_tokenize = str - pos = 1 - do while pos <= length(str) - token = next_token(str_to_tokenize) - if length(token) > 0 then do - num_of_tokens = num_of_tokens + 1 - tokens.num_of_tokens = token - end - end - tokens.0 = num_of_tokens - return num_of_tokens - -is_number: procedure /* is_number(token) */ - token = arg(1) - ch = substr(token, 1, 1) - DIGITS = "0123456789" - if pos(ch, DIGITS) > 0 then return 1 - if (ch == '-') & (pos(substr(token, 2, 1), DIGITS) > 0) then return 1 - return 0 - -parse_string: procedure /* parse_string(token) */ - token = arg(1) - res = substr(token, 2, length(token) - 2) /* Remove quotes */ - res = changestr("\\", res, '01'x) - res = changestr("\n", res, '0A'x) - res = changestr('\"', res, '"') - res = changestr('01'x, res, '5C'x) - return res - -parse_keyword: procedure /* parse_keyword(token) */ - token = arg(1) - return substr(token, 2) /* Remove initial ":" */ - -read_atom: procedure expose values. tokens. pos err /* read_atom() */ - token = tokens.pos - pos = pos + 1 - select - when is_number(token) then return new_number(token) - when token == "nil" then return new_nil() - when token == "true" then return new_true() - when token == "false" then return new_false() - when substr(token, 1, 1) == ':' then return new_keyword(parse_keyword(token)) - when substr(token, 1, 1) == '"' then do - if substr(token, length(token), 1) \== '"' then do - end_char = '"' - err = "expected '" || end_char || "', got EOF" - return "ERR" - end - return new_string(parse_string(token)) - end - otherwise - return new_symbol(token) - end - -read_sequence: procedure expose values. tokens. pos err /* read_sequence(type, end_char) */ - type = arg(1) - end_char = arg(2) - pos = pos + 1 /* Consume the open paren */ - token = tokens.pos - seq = "" - do while (pos <= tokens.0) & (token \== end_char) - element = read_form() - if element == "ERR" then return "ERR" - if seq == "" then - seq = element - else - seq = seq || " " || element - token = tokens.pos - if token == "" then do - err = "expected '" || end_char || "', got EOF" - return "ERR" - end - end - pos = pos + 1 /* Consume the close paren */ - return new_seq(type, seq) - -reader_macro: procedure expose values. tokens. pos /* reader_macro(symbol) */ - symbol = arg(1) - pos = pos + 1 /* Consume the macro token */ - element = read_form() - if element == "ERR" then return "ERR" - seq = new_symbol(symbol) || " " || element - return new_list(seq) - -reader_with_meta_macro: procedure expose values. tokens. pos /* reader_with_meta_macro() */ - pos = pos + 1 /* Consume the macro token */ - meta = read_form() - if meta == "ERR" then return "ERR" - element = read_form() - if element == "ERR" then return "ERR" - seq = new_symbol("with-meta") || " " || element || " " || meta - return new_list(seq) - -read_form: procedure expose values. tokens. pos err /* read_form() */ - token = tokens.pos - select - when token == "'" then return reader_macro("quote") - when token == '`' then return reader_macro("quasiquote") - when token == '~' then return reader_macro("unquote") - when token == '~@' then return reader_macro("splice-unquote") - when token == '@' then return reader_macro("deref") - when token == '^' then return reader_with_meta_macro() - when token == '(' then return read_sequence("list", ")") - when token == ')' then do - err = "unexpected ')'" - return "ERR" - end - when token == '[' then return read_sequence("vect", "]") - when token == ']' then do - err = "unexpected ']'" - return "ERR" - end - when token == '{' then return read_sequence("hash", "}") - when token == '}' then do - err = "unexpected '}'" - return "ERR" - end - otherwise - return read_atom() - end - -read_str: procedure expose values. err /* read_str(line) */ - line = arg(1) - tokens. = "" - num_of_tokens = tokenize(line) - if num_of_tokens == 0 then - return "" - ast. = "" - pos = 1 - return read_form() - -#endif +#ifndef __reader__ +#define __reader__ + +#include "types.rexx" + +next_token: procedure expose pos /* next_token(str) */ + TAB = '09'x + LF = '0A'x + CR = '0D'x + SEPARATOR_CHARS = TAB || LF || CR || " []{}()'`,;" || '"' + WHITESPACE_CHARS = TAB || LF || CR || " ," + str = arg(1) + token = "" + ch = substr(str, pos, 1) + select + when pos(ch, WHITESPACE_CHARS) > 0 then + pos = pos + 1 + when pos(ch, "[]{}()'`^@") > 0 then do + pos = pos + 1 + token = ch + end + when ch == '~' then do + if substr(str, pos + 1, 1) == '@' then do + pos = pos + 2 + token = "~@" + end + else do + pos = pos + 1 + token = "~" + end + end + when ch == ";" then do + do while pos <= length(str) + ch = substr(str, pos, 1) + if (ch == LF) | (ch == CR) then + leave + else + pos = pos + 1 + end + end + when ch == '"' then do + tmppos = pos + 1 + do while tmppos < length(str) + ch = substr(str, tmppos, 1) + select + when ch == '"' then + leave + when ch == '5C'x then /* backslash */ + tmppos = tmppos + 2 + otherwise + tmppos = tmppos + 1 + end + end + token = substr(str, pos, tmppos - pos + 1) + pos = tmppos + 1 + end + otherwise + tmppos = pos + do while tmppos <= length(str) + ch = substr(str, tmppos, 1) + if pos(ch, SEPARATOR_CHARS) > 0 then + leave + else + token = token || ch + tmppos = tmppos + 1 + end + pos = tmppos + end + return token + +tokenize: procedure expose tokens. /* tokenize(str) */ + str = arg(1) + tokens. = "" + num_of_tokens = 0 + str_to_tokenize = str + pos = 1 + do while pos <= length(str) + token = next_token(str_to_tokenize) + if length(token) > 0 then do + num_of_tokens = num_of_tokens + 1 + tokens.num_of_tokens = token + end + end + tokens.0 = num_of_tokens + return num_of_tokens + +is_number: procedure /* is_number(token) */ + token = arg(1) + ch = substr(token, 1, 1) + DIGITS = "0123456789" + if pos(ch, DIGITS) > 0 then return 1 + if (ch == '-') & (pos(substr(token, 2, 1), DIGITS) > 0) then return 1 + return 0 + +parse_string: procedure /* parse_string(token) */ + token = arg(1) + res = substr(token, 2, length(token) - 2) /* Remove quotes */ + res = changestr("\\", res, '01'x) + res = changestr("\n", res, '0A'x) + res = changestr('\"', res, '"') + res = changestr('01'x, res, '5C'x) + return res + +parse_keyword: procedure /* parse_keyword(token) */ + token = arg(1) + return substr(token, 2) /* Remove initial ":" */ + +read_atom: procedure expose values. tokens. pos err /* read_atom() */ + token = tokens.pos + pos = pos + 1 + select + when is_number(token) then return new_number(token) + when token == "nil" then return new_nil() + when token == "true" then return new_true() + when token == "false" then return new_false() + when substr(token, 1, 1) == ':' then return new_keyword(parse_keyword(token)) + when substr(token, 1, 1) == '"' then do + if substr(token, length(token), 1) \== '"' then do + end_char = '"' + err = "expected '" || end_char || "', got EOF" + return "ERR" + end + return new_string(parse_string(token)) + end + otherwise + return new_symbol(token) + end + +read_sequence: procedure expose values. tokens. pos err /* read_sequence(type, end_char) */ + type = arg(1) + end_char = arg(2) + pos = pos + 1 /* Consume the open paren */ + token = tokens.pos + seq = "" + do while (pos <= tokens.0) & (token \== end_char) + element = read_form() + if element == "ERR" then return "ERR" + if seq == "" then + seq = element + else + seq = seq || " " || element + token = tokens.pos + if token == "" then do + err = "expected '" || end_char || "', got EOF" + return "ERR" + end + end + pos = pos + 1 /* Consume the close paren */ + return new_seq(type, seq) + +reader_macro: procedure expose values. tokens. pos /* reader_macro(symbol) */ + symbol = arg(1) + pos = pos + 1 /* Consume the macro token */ + element = read_form() + if element == "ERR" then return "ERR" + seq = new_symbol(symbol) || " " || element + return new_list(seq) + +reader_with_meta_macro: procedure expose values. tokens. pos /* reader_with_meta_macro() */ + pos = pos + 1 /* Consume the macro token */ + meta = read_form() + if meta == "ERR" then return "ERR" + element = read_form() + if element == "ERR" then return "ERR" + seq = new_symbol("with-meta") || " " || element || " " || meta + return new_list(seq) + +read_form: procedure expose values. tokens. pos err /* read_form() */ + token = tokens.pos + select + when token == "'" then return reader_macro("quote") + when token == '`' then return reader_macro("quasiquote") + when token == '~' then return reader_macro("unquote") + when token == '~@' then return reader_macro("splice-unquote") + when token == '@' then return reader_macro("deref") + when token == '^' then return reader_with_meta_macro() + when token == '(' then return read_sequence("list", ")") + when token == ')' then do + err = "unexpected ')'" + return "ERR" + end + when token == '[' then return read_sequence("vect", "]") + when token == ']' then do + err = "unexpected ']'" + return "ERR" + end + when token == '{' then return read_sequence("hash", "}") + when token == '}' then do + err = "unexpected '}'" + return "ERR" + end + otherwise + return read_atom() + end + +read_str: procedure expose values. err /* read_str(line) */ + line = arg(1) + tokens. = "" + num_of_tokens = tokenize(line) + if num_of_tokens == 0 then + return "" + ast. = "" + pos = 1 + return read_form() + +#endif diff --git a/impls/rexx/readline.rexx b/impls/rexx/readline.rexx index 4482bd7e5b..1e79304c39 100644 --- a/impls/rexx/readline.rexx +++ b/impls/rexx/readline.rexx @@ -1,8 +1,8 @@ -#ifndef __readline__ -#define __readline__ - -readline: procedure /* readline(prompt) */ - call charout , arg(1) - return linein() - -#endif +#ifndef __readline__ +#define __readline__ + +readline: procedure /* readline(prompt) */ + call charout , arg(1) + return linein() + +#endif diff --git a/impls/rexx/run b/impls/rexx/run index f792d597f3..dbc5c812dc 100755 --- a/impls/rexx/run +++ b/impls/rexx/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec rexx -a $(dirname $0)/${STEP:-stepA_mal}.rexxpp "${@}" +#!/bin/bash +exec rexx -a $(dirname $0)/${STEP:-stepA_mal}.rexxpp "${@}" diff --git a/impls/rexx/step0_repl.rexx b/impls/rexx/step0_repl.rexx index 7ae0168c1c..18d4d9c445 100644 --- a/impls/rexx/step0_repl.rexx +++ b/impls/rexx/step0_repl.rexx @@ -1,23 +1,23 @@ -call main -exit - -#include "readline.rexx" - -read: procedure /* read(str) */ - return arg(1) - -eval: procedure /* eval(exp, env) */ - return arg(1) - -print: procedure /* print(exp) */ - return arg(1) - -rep: procedure /* rep(str) */ - return print(eval(read(arg(1), ""))) - -main: - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then - call lineout , rep(input_line) - end +call main +exit + +#include "readline.rexx" + +read: procedure /* read(str) */ + return arg(1) + +eval: procedure /* eval(exp, env) */ + return arg(1) + +print: procedure /* print(exp) */ + return arg(1) + +rep: procedure /* rep(str) */ + return print(eval(read(arg(1), ""))) + +main: + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then + call lineout , rep(input_line) + end diff --git a/impls/rexx/step1_read_print.rexx b/impls/rexx/step1_read_print.rexx index 3101d67286..9fbfb7e69c 100644 --- a/impls/rexx/step1_read_print.rexx +++ b/impls/rexx/step1_read_print.rexx @@ -1,35 +1,35 @@ -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -eval: procedure expose values. /* eval(exp, env) */ - return arg(1) - -print: procedure expose values. /* print(exp) */ - return pr_str(arg(1), 1) - -rep: procedure expose values. env. err /* rep(str) */ - ast = read(arg(1)) - if ast == "ERR" then return "ERR" - exp = eval(ast) - return print(exp) - -main: - values. = "" - values.0 = 0 - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then - call lineout , "Error: " || err - else - call lineout , res - end - end +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval: procedure expose values. /* eval(exp, env) */ + return arg(1) + +print: procedure expose values. /* print(exp) */ + return pr_str(arg(1), 1) + +rep: procedure expose values. env. err /* rep(str) */ + ast = read(arg(1)) + if ast == "ERR" then return "ERR" + exp = eval(ast) + return print(exp) + +main: + values. = "" + values.0 = 0 + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/impls/rexx/step2_eval.rexx b/impls/rexx/step2_eval.rexx index 6fffd80acd..b3f6dd0e7a 100644 --- a/impls/rexx/step2_eval.rexx +++ b/impls/rexx/step2_eval.rexx @@ -1,127 +1,127 @@ -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" -#include "types.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -eval_ast: procedure expose values. env. err /* eval_ast(ast) */ - ast = arg(1) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "symb" then do - varname = val - if env.varname == "" then do - err = "'" || varname || "' not found" - return "ERR" - end - return env.varname - end - when type == "list" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i)) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_list(res) - end - when type == "vect" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i)) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_vector(res) - end - when type == "hash" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i)) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_hashmap(res) - end - otherwise - return ast - end - -eval: procedure expose values. env. err /* eval(ast) */ - ast = arg(1) - if \list?(ast) then return eval_ast(ast) - astval = obj_val(ast) - if words(astval) == 0 then return ast - lst_obj = eval_ast(ast) - if lst_obj == "ERR" then return "ERR" - lst = obj_val(lst_obj) - f = word(lst, 1) - call_args = subword(lst, 2) - call_list = "" - do i=1 to words(call_args) - element = '"' || word(call_args, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || f || "(" || call_list || ")" - return res - -print: procedure expose values. /* print(ast) */ - return pr_str(arg(1), 1) - -rep: procedure expose values. env. err /* rep(str) */ - ast = read(arg(1)) - if ast == "ERR" then return "ERR" - exp = eval(ast) - if exp == "ERR" then return "ERR" - return print(exp) - -mal_add: procedure expose values. /* mal_add(a, b) */ - return new_number(obj_val(arg(1)) + obj_val(arg(2))) - -mal_sub: procedure expose values. /* mal_sub(a, b) */ - return new_number(obj_val(arg(1)) - obj_val(arg(2))) - -mal_mul: procedure expose values. /* mal_mul(a, b) */ - return new_number(obj_val(arg(1)) * obj_val(arg(2))) - -mal_div: procedure expose values. /* mal_div(a, b) */ - return new_number(obj_val(arg(1)) / obj_val(arg(2))) - -main: - values. = "" - values.0 = 0 - env. = "" - key = "+" ; env.key = "mal_add" - key = "-" ; env.key = "mal_sub" - key = "*" ; env.key = "mal_mul" - key = "/" ; env.key = "mal_div" - err = "" - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then - call lineout , "Error: " || err - else - call lineout , res - end - end +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast) */ + ast = arg(1) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then do + varname = val + if env.varname == "" then do + err = "'" || varname || "' not found" + return "ERR" + end + return env.varname + end + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i)) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i)) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i)) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + if \list?(ast) then return eval_ast(ast) + astval = obj_val(ast) + if words(astval) == 0 then return ast + lst_obj = eval_ast(ast) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || f || "(" || call_list || ")" + return res + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +rep: procedure expose values. env. err /* rep(str) */ + ast = read(arg(1)) + if ast == "ERR" then return "ERR" + exp = eval(ast) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_add: procedure expose values. /* mal_add(a, b) */ + return new_number(obj_val(arg(1)) + obj_val(arg(2))) + +mal_sub: procedure expose values. /* mal_sub(a, b) */ + return new_number(obj_val(arg(1)) - obj_val(arg(2))) + +mal_mul: procedure expose values. /* mal_mul(a, b) */ + return new_number(obj_val(arg(1)) * obj_val(arg(2))) + +mal_div: procedure expose values. /* mal_div(a, b) */ + return new_number(obj_val(arg(1)) / obj_val(arg(2))) + +main: + values. = "" + values.0 = 0 + env. = "" + key = "+" ; env.key = "mal_add" + key = "-" ; env.key = "mal_sub" + key = "*" ; env.key = "mal_mul" + key = "/" ; env.key = "mal_div" + err = "" + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/impls/rexx/step3_env.rexx b/impls/rexx/step3_env.rexx index 839e2fe68c..59208b7757 100644 --- a/impls/rexx/step3_env.rexx +++ b/impls/rexx/step3_env.rexx @@ -1,151 +1,151 @@ -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" -#include "types.rexx" -#include "env.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "symb" then return env_get(env_idx, val) - when type == "list" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_list(res) - end - when type == "vect" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_vector(res) - end - when type == "hash" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_hashmap(res) - end - otherwise - return ast - end - -eval: procedure expose values. env. err /* eval(ast) */ - ast = arg(1) - env_idx = arg(2) - if \list?(ast) then return eval_ast(ast, env_idx) - astval = obj_val(ast) - if words(astval) == 0 then return ast - a0sym = obj_val(word(astval, 1)) - select - when a0sym == "def!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, a2) - end - when a0sym == "let*" then do - a1lst = obj_val(word(astval, 2)) - letenv_idx = new_env(env_idx) - do i=1 to words(a1lst) by 2 - k = obj_val(word(a1lst, i)) - v = eval(word(a1lst, i + 1), letenv_idx) - if v == "ERR" then return "ERR" - unused = env_set(letenv_idx, k, v) - end - return eval(word(astval, 3), letenv_idx) - end - otherwise - lst_obj = eval_ast(ast, env_idx) - if lst_obj == "ERR" then return "ERR" - lst = obj_val(lst_obj) - f = word(lst, 1) - call_args = subword(lst, 2) - call_list = "" - do i=1 to words(call_args) - element = '"' || word(call_args, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || f || "(" || call_list || ")" - return res - end - -print: procedure expose values. /* print(ast) */ - return pr_str(arg(1), 1) - -re: procedure expose values. env. err repl_env_idx /* re(str) */ - str = arg(1) - ast = read(str) - if ast == "ERR" then return "ERR" - return eval(ast, repl_env_idx) - -rep: procedure expose values. env. err repl_env_idx /* rep(str) */ - str = arg(1) - exp = re(str) - if exp == "ERR" then return "ERR" - return print(exp) - -mal_add: procedure expose values. /* mal_add(a, b) */ - return new_number(obj_val(arg(1)) + obj_val(arg(2))) - -mal_sub: procedure expose values. /* mal_sub(a, b) */ - return new_number(obj_val(arg(1)) - obj_val(arg(2))) - -mal_mul: procedure expose values. /* mal_mul(a, b) */ - return new_number(obj_val(arg(1)) * obj_val(arg(2))) - -mal_div: procedure expose values. /* mal_div(a, b) */ - return new_number(obj_val(arg(1)) / obj_val(arg(2))) - -main: - values. = "" - values.0 = 0 - env. = "" - env.0 = 0 - repl_env_idx = new_env(0) - x = env_set(repl_env_idx, "+", "mal_add") - x = env_set(repl_env_idx, "-", "mal_sub") - x = env_set(repl_env_idx, "*", "mal_mul") - x = env_set(repl_env_idx, "/", "mal_div") - err = "" - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then - call lineout , "Error: " || err - else - call lineout , res - end - end +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + return eval(word(astval, 3), letenv_idx) + end + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || f || "(" || call_list || ")" + return res + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_add: procedure expose values. /* mal_add(a, b) */ + return new_number(obj_val(arg(1)) + obj_val(arg(2))) + +mal_sub: procedure expose values. /* mal_sub(a, b) */ + return new_number(obj_val(arg(1)) - obj_val(arg(2))) + +mal_mul: procedure expose values. /* mal_mul(a, b) */ + return new_number(obj_val(arg(1)) * obj_val(arg(2))) + +mal_div: procedure expose values. /* mal_div(a, b) */ + return new_number(obj_val(arg(1)) / obj_val(arg(2))) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + x = env_set(repl_env_idx, "+", "mal_add") + x = env_set(repl_env_idx, "-", "mal_sub") + x = env_set(repl_env_idx, "*", "mal_mul") + x = env_set(repl_env_idx, "/", "mal_div") + err = "" + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/impls/rexx/step4_if_fn_do.rexx b/impls/rexx/step4_if_fn_do.rexx index 564fbed84e..7d4ea0bd57 100644 --- a/impls/rexx/step4_if_fn_do.rexx +++ b/impls/rexx/step4_if_fn_do.rexx @@ -1,176 +1,176 @@ -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" -#include "types.rexx" -#include "env.rexx" -#include "core.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "symb" then return env_get(env_idx, val) - when type == "list" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_list(res) - end - when type == "vect" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_vector(res) - end - when type == "hash" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_hashmap(res) - end - otherwise - return ast - end - -eval: procedure expose values. env. err /* eval(ast) */ - ast = arg(1) - env_idx = arg(2) - if \list?(ast) then return eval_ast(ast, env_idx) - astval = obj_val(ast) - if words(astval) == 0 then return ast - a0sym = obj_val(word(astval, 1)) - select - when a0sym == "def!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, a2) - end - when a0sym == "let*" then do - a1lst = obj_val(word(astval, 2)) - letenv_idx = new_env(env_idx) - do i=1 to words(a1lst) by 2 - k = obj_val(word(a1lst, i)) - v = eval(word(a1lst, i + 1), letenv_idx) - if v == "ERR" then return "ERR" - unused = env_set(letenv_idx, k, v) - end - return eval(word(astval, 3), letenv_idx) - end - when a0sym == "do" then do - res = "ERR" - do i=2 to words(astval) - res = eval(word(astval, i), env_idx) - if res == "ERR" then return "ERR" - end - return res - end - when a0sym == "if" then do - condval = eval(word(astval, 2), env_idx) - if false?(condval) | nil?(condval) then - if words(astval) >= 4 then - return eval(word(astval, 4), env_idx) - else - return new_nil() - else - return eval(word(astval, 3), env_idx) - end - when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) - otherwise - lst_obj = eval_ast(ast, env_idx) - if lst_obj == "ERR" then return "ERR" - lst = obj_val(lst_obj) - f = word(lst, 1) - select - when nativefn?(f) then do - call_args = subword(lst, 2) - call_list = "" - do i=1 to words(call_args) - element = '"' || word(call_args, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || obj_val(f) || "(" || call_list || ")" - return res - end - when func?(f) then do - call_args = new_list(subword(lst, 2)) - return eval(func_body_ast(f), new_env(func_env_idx(f), func_binds(f), call_args)) - end - otherwise - err = "Unsupported function object type: " || obj_type(f) - return "ERR" - end - end - -print: procedure expose values. /* print(ast) */ - return pr_str(arg(1), 1) - -re: procedure expose values. env. err repl_env_idx /* re(str) */ - str = arg(1) - ast = read(str) - if ast == "ERR" then return "ERR" - return eval(ast, repl_env_idx) - -rep: procedure expose values. env. err repl_env_idx /* rep(str) */ - str = arg(1) - exp = re(str) - if exp == "ERR" then return "ERR" - return print(exp) - -main: - values. = "" - values.0 = 0 - env. = "" - env.0 = 0 - repl_env_idx = new_env(0) - - /* core.rexx: defined using Rexx */ - core_ns = get_core_ns() - do i=1 to words(core_ns) by 2 - x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) - end - - /* core.mal: defined using the language itself */ - x = re("(def! not (fn* (a) (if a false true)))") - - err = "" - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then - call lineout , "Error: " || err - else - call lineout , res - end - end +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + return eval(word(astval, 3), letenv_idx) + end + when a0sym == "do" then do + res = "ERR" + do i=2 to words(astval) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + return res + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + return eval(word(astval, 4), env_idx) + else + return new_nil() + else + return eval(word(astval, 3), env_idx) + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + return eval(func_body_ast(f), new_env(func_env_idx(f), func_binds(f), call_args)) + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + + err = "" + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/impls/rexx/step5_tco.rexx b/impls/rexx/step5_tco.rexx index 6799b761ed..9626239267 100644 --- a/impls/rexx/step5_tco.rexx +++ b/impls/rexx/step5_tco.rexx @@ -1,183 +1,183 @@ -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" -#include "types.rexx" -#include "env.rexx" -#include "core.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "symb" then return env_get(env_idx, val) - when type == "list" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_list(res) - end - when type == "vect" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_vector(res) - end - when type == "hash" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_hashmap(res) - end - otherwise - return ast - end - -eval: procedure expose values. env. err /* eval(ast) */ - ast = arg(1) - env_idx = arg(2) - do forever - if \list?(ast) then return eval_ast(ast, env_idx) - astval = obj_val(ast) - if words(astval) == 0 then return ast - a0sym = obj_val(word(astval, 1)) - select - when a0sym == "def!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, a2) - end - when a0sym == "let*" then do - a1lst = obj_val(word(astval, 2)) - letenv_idx = new_env(env_idx) - do i=1 to words(a1lst) by 2 - k = obj_val(word(a1lst, i)) - v = eval(word(a1lst, i + 1), letenv_idx) - if v == "ERR" then return "ERR" - unused = env_set(letenv_idx, k, v) - end - env_idx = letenv_idx - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "do" then do - do i=2 to (words(astval) - 1) - res = eval(word(astval, i), env_idx) - if res == "ERR" then return "ERR" - end - ast = word(astval, words(astval)) - /* TCO */ - end - when a0sym == "if" then do - condval = eval(word(astval, 2), env_idx) - if false?(condval) | nil?(condval) then - if words(astval) >= 4 then - ast = word(astval, 4) - else - return new_nil() - else - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) - otherwise - lst_obj = eval_ast(ast, env_idx) - if lst_obj == "ERR" then return "ERR" - lst = obj_val(lst_obj) - f = word(lst, 1) - select - when nativefn?(f) then do - call_args = subword(lst, 2) - call_list = "" - do i=1 to words(call_args) - element = '"' || word(call_args, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || obj_val(f) || "(" || call_list || ")" - return res - end - when func?(f) then do - call_args = new_list(subword(lst, 2)) - env_idx = new_env(func_env_idx(f), func_binds(f), call_args) - ast = func_body_ast(f) - /* TCO */ - end - otherwise - err = "Unsupported function object type: " || obj_type(f) - return "ERR" - end - end - end - -print: procedure expose values. /* print(ast) */ - return pr_str(arg(1), 1) - -re: procedure expose values. env. err repl_env_idx /* re(str) */ - str = arg(1) - ast = read(str) - if ast == "ERR" then return "ERR" - return eval(ast, repl_env_idx) - -rep: procedure expose values. env. err repl_env_idx /* rep(str) */ - str = arg(1) - exp = re(str) - if exp == "ERR" then return "ERR" - return print(exp) - -main: - values. = "" - values.0 = 0 - env. = "" - env.0 = 0 - repl_env_idx = new_env(0) - - /* core.rexx: defined using Rexx */ - core_ns = get_core_ns() - do i=1 to words(core_ns) by 2 - x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) - end - - /* core.mal: defined using the language itself */ - x = rep("(def! not (fn* (a) (if a false true)))") - - err = "" - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then - call lineout , "Error: " || err - else - call lineout , res - end - end +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + + /* core.mal: defined using the language itself */ + x = rep("(def! not (fn* (a) (if a false true)))") + + err = "" + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/impls/rexx/step6_file.rexx b/impls/rexx/step6_file.rexx index 6c8d8279d5..69dbb3e339 100644 --- a/impls/rexx/step6_file.rexx +++ b/impls/rexx/step6_file.rexx @@ -1,214 +1,214 @@ -/* Save command-line arguments from the top-level program before entering a procedure */ -command_line_args. = "" -command_line_args.0 = arg() -do i=1 to command_line_args.0 - command_line_args.i = arg(i) -end - -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" -#include "types.rexx" -#include "env.rexx" -#include "core.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "symb" then return env_get(env_idx, val) - when type == "list" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_list(res) - end - when type == "vect" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_vector(res) - end - when type == "hash" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_hashmap(res) - end - otherwise - return ast - end - -eval: procedure expose values. env. err /* eval(ast) */ - ast = arg(1) - env_idx = arg(2) - do forever - if \list?(ast) then return eval_ast(ast, env_idx) - astval = obj_val(ast) - if words(astval) == 0 then return ast - a0sym = obj_val(word(astval, 1)) - select - when a0sym == "def!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, a2) - end - when a0sym == "let*" then do - a1lst = obj_val(word(astval, 2)) - letenv_idx = new_env(env_idx) - do i=1 to words(a1lst) by 2 - k = obj_val(word(a1lst, i)) - v = eval(word(a1lst, i + 1), letenv_idx) - if v == "ERR" then return "ERR" - unused = env_set(letenv_idx, k, v) - end - env_idx = letenv_idx - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "do" then do - do i=2 to (words(astval) - 1) - res = eval(word(astval, i), env_idx) - if res == "ERR" then return "ERR" - end - ast = word(astval, words(astval)) - /* TCO */ - end - when a0sym == "if" then do - condval = eval(word(astval, 2), env_idx) - if false?(condval) | nil?(condval) then - if words(astval) >= 4 then - ast = word(astval, 4) - else - return new_nil() - else - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) - otherwise - lst_obj = eval_ast(ast, env_idx) - if lst_obj == "ERR" then return "ERR" - lst = obj_val(lst_obj) - f = word(lst, 1) - select - when nativefn?(f) then do - call_args = subword(lst, 2) - call_list = "" - do i=1 to words(call_args) - element = '"' || word(call_args, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || obj_val(f) || "(" || call_list || ")" - return res - end - when func?(f) then do - call_args = new_list(subword(lst, 2)) - env_idx = new_env(func_env_idx(f), func_binds(f), call_args) - ast = func_body_ast(f) - /* TCO */ - end - otherwise - err = "Unsupported function object type: " || obj_type(f) - return "ERR" - end - end - end - -print: procedure expose values. /* print(ast) */ - return pr_str(arg(1), 1) - -re: procedure expose values. env. err repl_env_idx /* re(str) */ - str = arg(1) - ast = read(str) - if ast == "ERR" then return "ERR" - return eval(ast, repl_env_idx) - -rep: procedure expose values. env. err repl_env_idx /* rep(str) */ - str = arg(1) - exp = re(str) - if exp == "ERR" then return "ERR" - return print(exp) - -mal_eval: procedure expose values. env. err /* mal_eval(ast) */ - ast = arg(1) - if ast == "ERR" then return "ERR" - return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ - -build_args_list: procedure expose values. command_line_args. /* build_args_list() */ - seq = "" - do i=2 to command_line_args.0 - s = new_string(command_line_args.i) - if i == 1 then - seq = s - else - seq = seq || " " || s - end - return new_list(seq) - -main: - values. = "" - values.0 = 0 - env. = "" - env.0 = 0 - repl_env_idx = new_env(0) - - /* core.rexx: defined using Rexx */ - core_ns = get_core_ns() - do i=1 to words(core_ns) by 2 - x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) - end - x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) - x = env_set(repl_env_idx, "*ARGV*", build_args_list()) - - /* core.mal: defined using the language itself */ - x = re("(def! not (fn* (a) (if a false true)))") - x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') - - err = "" - if command_line_args.0 > 0 then do - x = re('(load-file "' || command_line_args.1 || '")') - return - end - - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then - call lineout , "Error: " || err - else - call lineout , res - end - end +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/impls/rexx/step7_quote.rexx b/impls/rexx/step7_quote.rexx index 6314c4f544..d715b24c6a 100644 --- a/impls/rexx/step7_quote.rexx +++ b/impls/rexx/step7_quote.rexx @@ -1,260 +1,260 @@ -/* Save command-line arguments from the top-level program before entering a procedure */ -command_line_args. = "" -command_line_args.0 = arg() -do i=1 to command_line_args.0 - command_line_args.i = arg(i) -end - -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" -#include "types.rexx" -#include "env.rexx" -#include "core.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -starts_with?: procedure expose values. /* starts_with?(lst, sym) */ - lst = arg(1) - sym = arg(2) - if words(obj_val(lst)) != 2 then return 0 - a0 = word(obj_val(lst), 1) - return symbol?(a0) & obj_val(a0) == sym - -qq_loop: procedure expose values. /* qq_loop(elt, acc) */ - elt = arg(1) - acc = arg(2) - if list?(elt) & starts_with?(elt, "splice-unquote") then - return new_list(new_symbol("concat") || " " || word(obj_val(elt), 2) || " " || acc) - else - return new_list(new_symbol("cons") || " " || quasiquote(elt) || " " || acc) - -qq_foldr: procedure expose values. /* qq_foldr(xs) */ - xs = arg(1) - acc = new_list() - do i=words(xs) to 1 by -1 - acc = qq_loop(word(xs, i), acc) - end - return acc - -quasiquote: procedure expose values. env. err /* quasiquote(ast) */ - ast = arg(1) - type = obj_type(ast) - select - when type == "list" then - if starts_with?(ast, "unquote") then - return word(obj_val(ast), 2) - else - return qq_foldr(obj_val(ast)) - when type == "vect" then - return new_list(new_symbol("vec") || " " || qq_foldr(obj_val(ast))) - when type == "symb" | type == "hash" then - return new_list(new_symbol("quote") || " " || ast) - otherwise - return ast - end - -eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "symb" then return env_get(env_idx, val) - when type == "list" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_list(res) - end - when type == "vect" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_vector(res) - end - when type == "hash" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_hashmap(res) - end - otherwise - return ast - end - -eval: procedure expose values. env. err /* eval(ast) */ - ast = arg(1) - env_idx = arg(2) - do forever - if \list?(ast) then return eval_ast(ast, env_idx) - astval = obj_val(ast) - if words(astval) == 0 then return ast - a0sym = obj_val(word(astval, 1)) - select - when a0sym == "def!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, a2) - end - when a0sym == "let*" then do - a1lst = obj_val(word(astval, 2)) - letenv_idx = new_env(env_idx) - do i=1 to words(a1lst) by 2 - k = obj_val(word(a1lst, i)) - v = eval(word(a1lst, i + 1), letenv_idx) - if v == "ERR" then return "ERR" - unused = env_set(letenv_idx, k, v) - end - env_idx = letenv_idx - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "quote" then return word(astval, 2) - when a0sym == "quasiquoteexpand" then return quasiquote(word(astval, 2)) - when a0sym == "quasiquote" then do - ast = quasiquote(word(astval, 2)) - /* TCO */ - end - when a0sym == "do" then do - do i=2 to (words(astval) - 1) - res = eval(word(astval, i), env_idx) - if res == "ERR" then return "ERR" - end - ast = word(astval, words(astval)) - /* TCO */ - end - when a0sym == "if" then do - condval = eval(word(astval, 2), env_idx) - if false?(condval) | nil?(condval) then - if words(astval) >= 4 then - ast = word(astval, 4) - else - return new_nil() - else - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) - otherwise - lst_obj = eval_ast(ast, env_idx) - if lst_obj == "ERR" then return "ERR" - lst = obj_val(lst_obj) - f = word(lst, 1) - select - when nativefn?(f) then do - call_args = subword(lst, 2) - call_list = "" - do i=1 to words(call_args) - element = '"' || word(call_args, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || obj_val(f) || "(" || call_list || ")" - return res - end - when func?(f) then do - call_args = new_list(subword(lst, 2)) - env_idx = new_env(func_env_idx(f), func_binds(f), call_args) - ast = func_body_ast(f) - /* TCO */ - end - otherwise - err = "Unsupported function object type: " || obj_type(f) - return "ERR" - end - end - end - -print: procedure expose values. /* print(ast) */ - return pr_str(arg(1), 1) - -re: procedure expose values. env. err repl_env_idx /* re(str) */ - str = arg(1) - ast = read(str) - if ast == "ERR" then return "ERR" - return eval(ast, repl_env_idx) - -rep: procedure expose values. env. err repl_env_idx /* rep(str) */ - str = arg(1) - exp = re(str) - if exp == "ERR" then return "ERR" - return print(exp) - -mal_eval: procedure expose values. env. err /* mal_eval(ast) */ - ast = arg(1) - if ast == "ERR" then return "ERR" - return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ - -build_args_list: procedure expose values. command_line_args. /* build_args_list() */ - seq = "" - do i=2 to command_line_args.0 - s = new_string(command_line_args.i) - if i == 1 then - seq = s - else - seq = seq || " " || s - end - return new_list(seq) - -main: - values. = "" - values.0 = 0 - env. = "" - env.0 = 0 - repl_env_idx = new_env(0) - - /* core.rexx: defined using Rexx */ - core_ns = get_core_ns() - do i=1 to words(core_ns) by 2 - x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) - end - x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) - x = env_set(repl_env_idx, "*ARGV*", build_args_list()) - - /* core.mal: defined using the language itself */ - x = re("(def! not (fn* (a) (if a false true)))") - x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') - - err = "" - if command_line_args.0 > 0 then do - x = re('(load-file "' || command_line_args.1 || '")') - return - end - - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then - call lineout , "Error: " || err - else - call lineout , res - end - end +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +starts_with?: procedure expose values. /* starts_with?(lst, sym) */ + lst = arg(1) + sym = arg(2) + if words(obj_val(lst)) != 2 then return 0 + a0 = word(obj_val(lst), 1) + return symbol?(a0) & obj_val(a0) == sym + +qq_loop: procedure expose values. /* qq_loop(elt, acc) */ + elt = arg(1) + acc = arg(2) + if list?(elt) & starts_with?(elt, "splice-unquote") then + return new_list(new_symbol("concat") || " " || word(obj_val(elt), 2) || " " || acc) + else + return new_list(new_symbol("cons") || " " || quasiquote(elt) || " " || acc) + +qq_foldr: procedure expose values. /* qq_foldr(xs) */ + xs = arg(1) + acc = new_list() + do i=words(xs) to 1 by -1 + acc = qq_loop(word(xs, i), acc) + end + return acc + +quasiquote: procedure expose values. env. err /* quasiquote(ast) */ + ast = arg(1) + type = obj_type(ast) + select + when type == "list" then + if starts_with?(ast, "unquote") then + return word(obj_val(ast), 2) + else + return qq_foldr(obj_val(ast)) + when type == "vect" then + return new_list(new_symbol("vec") || " " || qq_foldr(obj_val(ast))) + when type == "symb" | type == "hash" then + return new_list(new_symbol("quote") || " " || ast) + otherwise + return ast + end + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "quote" then return word(astval, 2) + when a0sym == "quasiquoteexpand" then return quasiquote(word(astval, 2)) + when a0sym == "quasiquote" then do + ast = quasiquote(word(astval, 2)) + /* TCO */ + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/impls/rexx/step8_macros.rexx b/impls/rexx/step8_macros.rexx index 64562d9b3f..0fed5d0af4 100644 --- a/impls/rexx/step8_macros.rexx +++ b/impls/rexx/step8_macros.rexx @@ -1,290 +1,290 @@ -/* Save command-line arguments from the top-level program before entering a procedure */ -command_line_args. = "" -command_line_args.0 = arg() -do i=1 to command_line_args.0 - command_line_args.i = arg(i) -end - -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" -#include "types.rexx" -#include "env.rexx" -#include "core.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -starts_with?: procedure expose values. /* starts_with?(lst, sym) */ - lst = arg(1) - sym = arg(2) - if words(obj_val(lst)) != 2 then return 0 - a0 = word(obj_val(lst), 1) - return symbol?(a0) & obj_val(a0) == sym - -qq_loop: procedure expose values. /* qq_loop(elt, acc) */ - elt = arg(1) - acc = arg(2) - if list?(elt) & starts_with?(elt, "splice-unquote") then - return new_list(new_symbol("concat") || " " || word(obj_val(elt), 2) || " " || acc) - else - return new_list(new_symbol("cons") || " " || quasiquote(elt) || " " || acc) - -qq_foldr: procedure expose values. /* qq_foldr(xs) */ - xs = arg(1) - acc = new_list() - do i=words(xs) to 1 by -1 - acc = qq_loop(word(xs, i), acc) - end - return acc - -quasiquote: procedure expose values. env. err /* quasiquote(ast) */ - ast = arg(1) - type = obj_type(ast) - select - when type == "list" then - if starts_with?(ast, "unquote") then - return word(obj_val(ast), 2) - else - return qq_foldr(obj_val(ast)) - when type == "vect" then - return new_list(new_symbol("vec") || " " || qq_foldr(obj_val(ast))) - when type == "symb" | type == "hash" then - return new_list(new_symbol("quote") || " " || ast) - otherwise - return ast - end - -macro?: procedure expose values. env. /* macro?(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - if \list?(ast) then return 0 - ast0 = mal_first(ast) - if \symbol?(ast0) then return 0 - if env_find(env_idx, obj_val(ast0)) == 0 then return 0 - return func_macro?(env_get(env_idx, obj_val(ast0))) - -macroexpand: procedure expose values. env. err /* macroexpand(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - do while macro?(ast, env_idx) - mac = env_get(env_idx, obj_val(mal_first(ast))) - call_args = mal_rest(ast) - mac_env_idx = new_env(func_env_idx(mac), func_binds(mac), call_args) - ast = eval(func_body_ast(mac), mac_env_idx) - end - return ast - -eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "symb" then return env_get(env_idx, val) - when type == "list" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_list(res) - end - when type == "vect" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_vector(res) - end - when type == "hash" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_hashmap(res) - end - otherwise - return ast - end - -eval: procedure expose values. env. err /* eval(ast) */ - ast = arg(1) - env_idx = arg(2) - do forever - if \list?(ast) then return eval_ast(ast, env_idx) - ast = macroexpand(ast, env_idx) - if \list?(ast) then return eval_ast(ast, env_idx) - astval = obj_val(ast) - if words(astval) == 0 then return ast - a0sym = obj_val(word(astval, 1)) - select - when a0sym == "def!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, a2) - end - when a0sym == "let*" then do - a1lst = obj_val(word(astval, 2)) - letenv_idx = new_env(env_idx) - do i=1 to words(a1lst) by 2 - k = obj_val(word(a1lst, i)) - v = eval(word(a1lst, i + 1), letenv_idx) - if v == "ERR" then return "ERR" - unused = env_set(letenv_idx, k, v) - end - env_idx = letenv_idx - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "quote" then return word(astval, 2) - when a0sym == "quasiquoteexpand" then return quasiquote(word(astval, 2)) - when a0sym == "quasiquote" then do - ast = quasiquote(word(astval, 2)) - /* TCO */ - end - when a0sym == "defmacro!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, func_mark_as_macro(a2)) - end - when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) - when a0sym == "do" then do - do i=2 to (words(astval) - 1) - res = eval(word(astval, i), env_idx) - if res == "ERR" then return "ERR" - end - ast = word(astval, words(astval)) - /* TCO */ - end - when a0sym == "if" then do - condval = eval(word(astval, 2), env_idx) - if false?(condval) | nil?(condval) then - if words(astval) >= 4 then - ast = word(astval, 4) - else - return new_nil() - else - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) - otherwise - lst_obj = eval_ast(ast, env_idx) - if lst_obj == "ERR" then return "ERR" - lst = obj_val(lst_obj) - f = word(lst, 1) - select - when nativefn?(f) then do - call_args = subword(lst, 2) - call_list = "" - do i=1 to words(call_args) - element = '"' || word(call_args, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || obj_val(f) || "(" || call_list || ")" - return res - end - when func?(f) then do - call_args = new_list(subword(lst, 2)) - env_idx = new_env(func_env_idx(f), func_binds(f), call_args) - ast = func_body_ast(f) - /* TCO */ - end - otherwise - err = "Unsupported function object type: " || obj_type(f) - return "ERR" - end - end - end - -print: procedure expose values. /* print(ast) */ - return pr_str(arg(1), 1) - -re: procedure expose values. env. err repl_env_idx /* re(str) */ - str = arg(1) - ast = read(str) - if ast == "ERR" then return "ERR" - return eval(ast, repl_env_idx) - -rep: procedure expose values. env. err repl_env_idx /* rep(str) */ - str = arg(1) - exp = re(str) - if exp == "ERR" then return "ERR" - return print(exp) - -mal_eval: procedure expose values. env. err /* mal_eval(ast) */ - ast = arg(1) - if ast == "ERR" then return "ERR" - return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ - -build_args_list: procedure expose values. command_line_args. /* build_args_list() */ - seq = "" - do i=2 to command_line_args.0 - s = new_string(command_line_args.i) - if i == 1 then - seq = s - else - seq = seq || " " || s - end - return new_list(seq) - -main: - values. = "" - values.0 = 0 - env. = "" - env.0 = 0 - repl_env_idx = new_env(0) - - /* core.rexx: defined using Rexx */ - core_ns = get_core_ns() - do i=1 to words(core_ns) by 2 - x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) - end - x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) - x = env_set(repl_env_idx, "*ARGV*", build_args_list()) - - /* core.mal: defined using the language itself */ - x = re("(def! not (fn* (a) (if a false true)))") - x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') - x = re("(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)))))))"); - - err = "" - if command_line_args.0 > 0 then do - x = re('(load-file "' || command_line_args.1 || '")') - return - end - - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then - call lineout , "Error: " || err - else - call lineout , res - end - end +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +starts_with?: procedure expose values. /* starts_with?(lst, sym) */ + lst = arg(1) + sym = arg(2) + if words(obj_val(lst)) != 2 then return 0 + a0 = word(obj_val(lst), 1) + return symbol?(a0) & obj_val(a0) == sym + +qq_loop: procedure expose values. /* qq_loop(elt, acc) */ + elt = arg(1) + acc = arg(2) + if list?(elt) & starts_with?(elt, "splice-unquote") then + return new_list(new_symbol("concat") || " " || word(obj_val(elt), 2) || " " || acc) + else + return new_list(new_symbol("cons") || " " || quasiquote(elt) || " " || acc) + +qq_foldr: procedure expose values. /* qq_foldr(xs) */ + xs = arg(1) + acc = new_list() + do i=words(xs) to 1 by -1 + acc = qq_loop(word(xs, i), acc) + end + return acc + +quasiquote: procedure expose values. env. err /* quasiquote(ast) */ + ast = arg(1) + type = obj_type(ast) + select + when type == "list" then + if starts_with?(ast, "unquote") then + return word(obj_val(ast), 2) + else + return qq_foldr(obj_val(ast)) + when type == "vect" then + return new_list(new_symbol("vec") || " " || qq_foldr(obj_val(ast))) + when type == "symb" | type == "hash" then + return new_list(new_symbol("quote") || " " || ast) + otherwise + return ast + end + +macro?: procedure expose values. env. /* macro?(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return 0 + ast0 = mal_first(ast) + if \symbol?(ast0) then return 0 + if env_find(env_idx, obj_val(ast0)) == 0 then return 0 + return func_macro?(env_get(env_idx, obj_val(ast0))) + +macroexpand: procedure expose values. env. err /* macroexpand(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + do while macro?(ast, env_idx) + mac = env_get(env_idx, obj_val(mal_first(ast))) + call_args = mal_rest(ast) + mac_env_idx = new_env(func_env_idx(mac), func_binds(mac), call_args) + ast = eval(func_body_ast(mac), mac_env_idx) + end + return ast + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + ast = macroexpand(ast, env_idx) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "quote" then return word(astval, 2) + when a0sym == "quasiquoteexpand" then return quasiquote(word(astval, 2)) + when a0sym == "quasiquote" then do + ast = quasiquote(word(astval, 2)) + /* TCO */ + end + when a0sym == "defmacro!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, func_mark_as_macro(a2)) + end + when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') + x = re("(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)))))))"); + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then + call lineout , "Error: " || err + else + call lineout , res + end + end diff --git a/impls/rexx/step9_try.rexx b/impls/rexx/step9_try.rexx index ac11561159..0c280bcf3e 100644 --- a/impls/rexx/step9_try.rexx +++ b/impls/rexx/step9_try.rexx @@ -1,312 +1,312 @@ -/* Save command-line arguments from the top-level program before entering a procedure */ -command_line_args. = "" -command_line_args.0 = arg() -do i=1 to command_line_args.0 - command_line_args.i = arg(i) -end - -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" -#include "types.rexx" -#include "env.rexx" -#include "core.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -starts_with?: procedure expose values. /* starts_with?(lst, sym) */ - lst = arg(1) - sym = arg(2) - if words(obj_val(lst)) != 2 then return 0 - a0 = word(obj_val(lst), 1) - return symbol?(a0) & obj_val(a0) == sym - -qq_loop: procedure expose values. /* qq_loop(elt, acc) */ - elt = arg(1) - acc = arg(2) - if list?(elt) & starts_with?(elt, "splice-unquote") then - return new_list(new_symbol("concat") || " " || word(obj_val(elt), 2) || " " || acc) - else - return new_list(new_symbol("cons") || " " || quasiquote(elt) || " " || acc) - -qq_foldr: procedure expose values. /* qq_foldr(xs) */ - xs = arg(1) - acc = new_list() - do i=words(xs) to 1 by -1 - acc = qq_loop(word(xs, i), acc) - end - return acc - -quasiquote: procedure expose values. env. err /* quasiquote(ast) */ - ast = arg(1) - type = obj_type(ast) - select - when type == "list" then - if starts_with?(ast, "unquote") then - return word(obj_val(ast), 2) - else - return qq_foldr(obj_val(ast)) - when type == "vect" then - return new_list(new_symbol("vec") || " " || qq_foldr(obj_val(ast))) - when type == "symb" | type == "hash" then - return new_list(new_symbol("quote") || " " || ast) - otherwise - return ast - end - -macro?: procedure expose values. env. /* macro?(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - if \list?(ast) then return 0 - ast0 = mal_first(ast) - if \symbol?(ast0) then return 0 - if env_find(env_idx, obj_val(ast0)) == 0 then return 0 - return func_macro?(env_get(env_idx, obj_val(ast0))) - -macroexpand: procedure expose values. env. err /* macroexpand(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - do while macro?(ast, env_idx) - mac = env_get(env_idx, obj_val(mal_first(ast))) - call_args = mal_rest(ast) - mac_env_idx = new_env(func_env_idx(mac), func_binds(mac), call_args) - ast = eval(func_body_ast(mac), mac_env_idx) - end - return ast - -eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "symb" then return env_get(env_idx, val) - when type == "list" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_list(res) - end - when type == "vect" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_vector(res) - end - when type == "hash" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_hashmap(res) - end - otherwise - return ast - end - -eval: procedure expose values. env. err /* eval(ast) */ - ast = arg(1) - env_idx = arg(2) - do forever - if \list?(ast) then return eval_ast(ast, env_idx) - ast = macroexpand(ast, env_idx) - if \list?(ast) then return eval_ast(ast, env_idx) - astval = obj_val(ast) - if words(astval) == 0 then return ast - a0sym = obj_val(word(astval, 1)) - select - when a0sym == "def!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, a2) - end - when a0sym == "let*" then do - a1lst = obj_val(word(astval, 2)) - letenv_idx = new_env(env_idx) - do i=1 to words(a1lst) by 2 - k = obj_val(word(a1lst, i)) - v = eval(word(a1lst, i + 1), letenv_idx) - if v == "ERR" then return "ERR" - unused = env_set(letenv_idx, k, v) - end - env_idx = letenv_idx - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "quote" then return word(astval, 2) - when a0sym == "quasiquoteexpand" then return quasiquote(word(astval, 2)) - when a0sym == "quasiquote" then do - ast = quasiquote(word(astval, 2)) - /* TCO */ - end - when a0sym == "defmacro!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, func_mark_as_macro(a2)) - end - when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) - when a0sym == "try*" then do - res = eval(word(astval, 2), env_idx) - if words(astval) < 3 then return res - if res == "ERR" then do - if word(err, 1) == "__MAL_EXCEPTION__" then - errobj = word(err, 2) - else - errobj = new_string(err) - catchlst = obj_val(word(astval, 3)) - catch_env_idx = new_env(env_idx, new_list(word(catchlst, 2)), new_list(errobj)) - err = "" - return eval(word(catchlst, 3), catch_env_idx) - end - else - return res - end - when a0sym == "do" then do - do i=2 to (words(astval) - 1) - res = eval(word(astval, i), env_idx) - if res == "ERR" then return "ERR" - end - ast = word(astval, words(astval)) - /* TCO */ - end - when a0sym == "if" then do - condval = eval(word(astval, 2), env_idx) - if false?(condval) | nil?(condval) then - if words(astval) >= 4 then - ast = word(astval, 4) - else - return new_nil() - else - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) - otherwise - lst_obj = eval_ast(ast, env_idx) - if lst_obj == "ERR" then return "ERR" - lst = obj_val(lst_obj) - f = word(lst, 1) - select - when nativefn?(f) then do - call_args = subword(lst, 2) - call_list = "" - do i=1 to words(call_args) - element = '"' || word(call_args, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || obj_val(f) || "(" || call_list || ")" - return res - end - when func?(f) then do - call_args = new_list(subword(lst, 2)) - env_idx = new_env(func_env_idx(f), func_binds(f), call_args) - ast = func_body_ast(f) - /* TCO */ - end - otherwise - err = "Unsupported function object type: " || obj_type(f) - return "ERR" - end - end - end - -print: procedure expose values. /* print(ast) */ - return pr_str(arg(1), 1) - -re: procedure expose values. env. err repl_env_idx /* re(str) */ - str = arg(1) - ast = read(str) - if ast == "ERR" then return "ERR" - return eval(ast, repl_env_idx) - -rep: procedure expose values. env. err repl_env_idx /* rep(str) */ - str = arg(1) - exp = re(str) - if exp == "ERR" then return "ERR" - return print(exp) - -mal_eval: procedure expose values. env. err /* mal_eval(ast) */ - ast = arg(1) - if ast == "ERR" then return "ERR" - return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ - -build_args_list: procedure expose values. command_line_args. /* build_args_list() */ - seq = "" - do i=2 to command_line_args.0 - s = new_string(command_line_args.i) - if i == 1 then - seq = s - else - seq = seq || " " || s - end - return new_list(seq) - -main: - values. = "" - values.0 = 0 - env. = "" - env.0 = 0 - repl_env_idx = new_env(0) - - /* core.rexx: defined using Rexx */ - core_ns = get_core_ns() - do i=1 to words(core_ns) by 2 - x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) - end - x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) - x = env_set(repl_env_idx, "*ARGV*", build_args_list()) - - /* core.mal: defined using the language itself */ - x = re("(def! not (fn* (a) (if a false true)))") - x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') - x = re("(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)))))))"); - - err = "" - if command_line_args.0 > 0 then do - x = re('(load-file "' || command_line_args.1 || '")') - return - end - - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then do - if word(err, 1) == "__MAL_EXCEPTION__" then - errstr = pr_str(word(err, 2), 0) - else - errstr = err - call lineout , "Error: " || errstr - err = "" - end - else - call lineout , res - end - end +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +starts_with?: procedure expose values. /* starts_with?(lst, sym) */ + lst = arg(1) + sym = arg(2) + if words(obj_val(lst)) != 2 then return 0 + a0 = word(obj_val(lst), 1) + return symbol?(a0) & obj_val(a0) == sym + +qq_loop: procedure expose values. /* qq_loop(elt, acc) */ + elt = arg(1) + acc = arg(2) + if list?(elt) & starts_with?(elt, "splice-unquote") then + return new_list(new_symbol("concat") || " " || word(obj_val(elt), 2) || " " || acc) + else + return new_list(new_symbol("cons") || " " || quasiquote(elt) || " " || acc) + +qq_foldr: procedure expose values. /* qq_foldr(xs) */ + xs = arg(1) + acc = new_list() + do i=words(xs) to 1 by -1 + acc = qq_loop(word(xs, i), acc) + end + return acc + +quasiquote: procedure expose values. env. err /* quasiquote(ast) */ + ast = arg(1) + type = obj_type(ast) + select + when type == "list" then + if starts_with?(ast, "unquote") then + return word(obj_val(ast), 2) + else + return qq_foldr(obj_val(ast)) + when type == "vect" then + return new_list(new_symbol("vec") || " " || qq_foldr(obj_val(ast))) + when type == "symb" | type == "hash" then + return new_list(new_symbol("quote") || " " || ast) + otherwise + return ast + end + +macro?: procedure expose values. env. /* macro?(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return 0 + ast0 = mal_first(ast) + if \symbol?(ast0) then return 0 + if env_find(env_idx, obj_val(ast0)) == 0 then return 0 + return func_macro?(env_get(env_idx, obj_val(ast0))) + +macroexpand: procedure expose values. env. err /* macroexpand(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + do while macro?(ast, env_idx) + mac = env_get(env_idx, obj_val(mal_first(ast))) + call_args = mal_rest(ast) + mac_env_idx = new_env(func_env_idx(mac), func_binds(mac), call_args) + ast = eval(func_body_ast(mac), mac_env_idx) + end + return ast + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + ast = macroexpand(ast, env_idx) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "quote" then return word(astval, 2) + when a0sym == "quasiquoteexpand" then return quasiquote(word(astval, 2)) + when a0sym == "quasiquote" then do + ast = quasiquote(word(astval, 2)) + /* TCO */ + end + when a0sym == "defmacro!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, func_mark_as_macro(a2)) + end + when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) + when a0sym == "try*" then do + res = eval(word(astval, 2), env_idx) + if words(astval) < 3 then return res + if res == "ERR" then do + if word(err, 1) == "__MAL_EXCEPTION__" then + errobj = word(err, 2) + else + errobj = new_string(err) + catchlst = obj_val(word(astval, 3)) + catch_env_idx = new_env(env_idx, new_list(word(catchlst, 2)), new_list(errobj)) + err = "" + return eval(word(catchlst, 3), catch_env_idx) + end + else + return res + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') + x = re("(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)))))))"); + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then do + if word(err, 1) == "__MAL_EXCEPTION__" then + errstr = pr_str(word(err, 2), 0) + else + errstr = err + call lineout , "Error: " || errstr + err = "" + end + else + call lineout , res + end + end diff --git a/impls/rexx/stepA_mal.rexx b/impls/rexx/stepA_mal.rexx index 8dbc6b4b39..4899363732 100644 --- a/impls/rexx/stepA_mal.rexx +++ b/impls/rexx/stepA_mal.rexx @@ -1,315 +1,315 @@ -/* Save command-line arguments from the top-level program before entering a procedure */ -command_line_args. = "" -command_line_args.0 = arg() -do i=1 to command_line_args.0 - command_line_args.i = arg(i) -end - -call main -exit - -#include "readline.rexx" -#include "reader.rexx" -#include "printer.rexx" -#include "types.rexx" -#include "env.rexx" -#include "core.rexx" - -read: procedure expose values. err /* read(str) */ - return read_str(arg(1)) - -starts_with?: procedure expose values. /* starts_with?(lst, sym) */ - lst = arg(1) - sym = arg(2) - if words(obj_val(lst)) != 2 then return 0 - a0 = word(obj_val(lst), 1) - return symbol?(a0) & obj_val(a0) == sym - -qq_loop: procedure expose values. /* qq_loop(elt, acc) */ - elt = arg(1) - acc = arg(2) - if list?(elt) & starts_with?(elt, "splice-unquote") then - return new_list(new_symbol("concat") || " " || word(obj_val(elt), 2) || " " || acc) - else - return new_list(new_symbol("cons") || " " || quasiquote(elt) || " " || acc) - -qq_foldr: procedure expose values. /* qq_foldr(xs) */ - xs = arg(1) - acc = new_list() - do i=words(xs) to 1 by -1 - acc = qq_loop(word(xs, i), acc) - end - return acc - -quasiquote: procedure expose values. env. err /* quasiquote(ast) */ - ast = arg(1) - type = obj_type(ast) - select - when type == "list" then - if starts_with?(ast, "unquote") then - return word(obj_val(ast), 2) - else - return qq_foldr(obj_val(ast)) - when type == "vect" then - return new_list(new_symbol("vec") || " " || qq_foldr(obj_val(ast))) - when type == "symb" | type == "hash" then - return new_list(new_symbol("quote") || " " || ast) - otherwise - return ast - end - -macro?: procedure expose values. env. /* macro?(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - if \list?(ast) then return 0 - ast0 = mal_first(ast) - if \symbol?(ast0) then return 0 - if env_find(env_idx, obj_val(ast0)) == 0 then return 0 - return func_macro?(env_get(env_idx, obj_val(ast0))) - -macroexpand: procedure expose values. env. err /* macroexpand(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - do while macro?(ast, env_idx) - mac = env_get(env_idx, obj_val(mal_first(ast))) - call_args = mal_rest(ast) - mac_env_idx = new_env(func_env_idx(mac), func_binds(mac), call_args) - ast = eval(func_body_ast(mac), mac_env_idx) - end - return ast - -eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ - ast = arg(1) - env_idx = arg(2) - type = obj_type(ast) - val = obj_val(ast) - select - when type == "symb" then return env_get(env_idx, val) - when type == "list" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_list(res) - end - when type == "vect" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_vector(res) - end - when type == "hash" then do - res = "" - do i=1 to words(val) - element = eval(word(val, i), env_idx) - if element == "ERR" then return "ERR" - if i > 1 then - res = res || " " || element - else - res = element - end - return new_hashmap(res) - end - otherwise - return ast - end - -eval: procedure expose values. env. err /* eval(ast) */ - ast = arg(1) - env_idx = arg(2) - do forever - if \list?(ast) then return eval_ast(ast, env_idx) - ast = macroexpand(ast, env_idx) - if \list?(ast) then return eval_ast(ast, env_idx) - astval = obj_val(ast) - if words(astval) == 0 then return ast - a0sym = obj_val(word(astval, 1)) - select - when a0sym == "def!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, a2) - end - when a0sym == "let*" then do - a1lst = obj_val(word(astval, 2)) - letenv_idx = new_env(env_idx) - do i=1 to words(a1lst) by 2 - k = obj_val(word(a1lst, i)) - v = eval(word(a1lst, i + 1), letenv_idx) - if v == "ERR" then return "ERR" - unused = env_set(letenv_idx, k, v) - end - env_idx = letenv_idx - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "quote" then return word(astval, 2) - when a0sym == "quasiquoteexpand" then return quasiquote(word(astval, 2)) - when a0sym == "quasiquote" then do - ast = quasiquote(word(astval, 2)) - /* TCO */ - end - when a0sym == "defmacro!" then do - a1sym = obj_val(word(astval, 2)) - a2 = eval(word(astval, 3), env_idx) - if a2 == "ERR" then return "ERR" - return env_set(env_idx, a1sym, func_mark_as_macro(a2)) - end - when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) - when a0sym == "try*" then do - res = eval(word(astval, 2), env_idx) - if words(astval) < 3 then return res - if res == "ERR" then do - if word(err, 1) == "__MAL_EXCEPTION__" then - errobj = word(err, 2) - else - errobj = new_string(err) - catchlst = obj_val(word(astval, 3)) - catch_env_idx = new_env(env_idx, new_list(word(catchlst, 2)), new_list(errobj)) - err = "" - return eval(word(catchlst, 3), catch_env_idx) - end - else - return res - end - when a0sym == "do" then do - do i=2 to (words(astval) - 1) - res = eval(word(astval, i), env_idx) - if res == "ERR" then return "ERR" - end - ast = word(astval, words(astval)) - /* TCO */ - end - when a0sym == "if" then do - condval = eval(word(astval, 2), env_idx) - if false?(condval) | nil?(condval) then - if words(astval) >= 4 then - ast = word(astval, 4) - else - return new_nil() - else - ast = word(astval, 3) - /* TCO */ - end - when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) - otherwise - lst_obj = eval_ast(ast, env_idx) - if lst_obj == "ERR" then return "ERR" - lst = obj_val(lst_obj) - f = word(lst, 1) - select - when nativefn?(f) then do - call_args = subword(lst, 2) - call_list = "" - do i=1 to words(call_args) - element = '"' || word(call_args, i) || '"' - if i > 1 then - call_list = call_list || ', ' || element - else - call_list = element - end - res = "" - interpret "res = " || obj_val(f) || "(" || call_list || ")" - return res - end - when func?(f) then do - call_args = new_list(subword(lst, 2)) - env_idx = new_env(func_env_idx(f), func_binds(f), call_args) - ast = func_body_ast(f) - /* TCO */ - end - otherwise - err = "Unsupported function object type: " || obj_type(f) - return "ERR" - end - end - end - -print: procedure expose values. /* print(ast) */ - return pr_str(arg(1), 1) - -re: procedure expose values. env. err repl_env_idx /* re(str) */ - str = arg(1) - ast = read(str) - if ast == "ERR" then return "ERR" - return eval(ast, repl_env_idx) - -rep: procedure expose values. env. err repl_env_idx /* rep(str) */ - str = arg(1) - exp = re(str) - if exp == "ERR" then return "ERR" - return print(exp) - -mal_eval: procedure expose values. env. err /* mal_eval(ast) */ - ast = arg(1) - if ast == "ERR" then return "ERR" - return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ - -build_args_list: procedure expose values. command_line_args. /* build_args_list() */ - seq = "" - do i=2 to command_line_args.0 - s = new_string(command_line_args.i) - if i == 1 then - seq = s - else - seq = seq || " " || s - end - return new_list(seq) - -main: - x = time('R') /* Reset the internal stopwatch; used by `time-ms` */ - values. = "" - values.0 = 0 - env. = "" - env.0 = 0 - repl_env_idx = new_env(0) - - /* core.rexx: defined using Rexx */ - core_ns = get_core_ns() - do i=1 to words(core_ns) by 2 - x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) - end - x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) - x = env_set(repl_env_idx, "*ARGV*", build_args_list()) - - /* core.mal: defined using the language itself */ - x = re('(def! *host-language* "rexx")') - x = re("(def! not (fn* (a) (if a false true)))") - x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') - x = re("(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)))))))"); - - err = "" - if command_line_args.0 > 0 then do - x = re('(load-file "' || command_line_args.1 || '")') - return - end - - x = re('(println (str "Mal [" *host-language* "]"))') - do while lines() > 0 /* 1 == 1 */ - input_line = readline('user> ') - if length(input_line) > 0 then do - res = rep(input_line) - if res == "ERR" then do - if word(err, 1) == "__MAL_EXCEPTION__" then - errstr = pr_str(word(err, 2), 0) - else - errstr = err - call lineout , "Error: " || errstr - err = "" - end - else - call lineout , res - end - end +/* Save command-line arguments from the top-level program before entering a procedure */ +command_line_args. = "" +command_line_args.0 = arg() +do i=1 to command_line_args.0 + command_line_args.i = arg(i) +end + +call main +exit + +#include "readline.rexx" +#include "reader.rexx" +#include "printer.rexx" +#include "types.rexx" +#include "env.rexx" +#include "core.rexx" + +read: procedure expose values. err /* read(str) */ + return read_str(arg(1)) + +starts_with?: procedure expose values. /* starts_with?(lst, sym) */ + lst = arg(1) + sym = arg(2) + if words(obj_val(lst)) != 2 then return 0 + a0 = word(obj_val(lst), 1) + return symbol?(a0) & obj_val(a0) == sym + +qq_loop: procedure expose values. /* qq_loop(elt, acc) */ + elt = arg(1) + acc = arg(2) + if list?(elt) & starts_with?(elt, "splice-unquote") then + return new_list(new_symbol("concat") || " " || word(obj_val(elt), 2) || " " || acc) + else + return new_list(new_symbol("cons") || " " || quasiquote(elt) || " " || acc) + +qq_foldr: procedure expose values. /* qq_foldr(xs) */ + xs = arg(1) + acc = new_list() + do i=words(xs) to 1 by -1 + acc = qq_loop(word(xs, i), acc) + end + return acc + +quasiquote: procedure expose values. env. err /* quasiquote(ast) */ + ast = arg(1) + type = obj_type(ast) + select + when type == "list" then + if starts_with?(ast, "unquote") then + return word(obj_val(ast), 2) + else + return qq_foldr(obj_val(ast)) + when type == "vect" then + return new_list(new_symbol("vec") || " " || qq_foldr(obj_val(ast))) + when type == "symb" | type == "hash" then + return new_list(new_symbol("quote") || " " || ast) + otherwise + return ast + end + +macro?: procedure expose values. env. /* macro?(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + if \list?(ast) then return 0 + ast0 = mal_first(ast) + if \symbol?(ast0) then return 0 + if env_find(env_idx, obj_val(ast0)) == 0 then return 0 + return func_macro?(env_get(env_idx, obj_val(ast0))) + +macroexpand: procedure expose values. env. err /* macroexpand(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + do while macro?(ast, env_idx) + mac = env_get(env_idx, obj_val(mal_first(ast))) + call_args = mal_rest(ast) + mac_env_idx = new_env(func_env_idx(mac), func_binds(mac), call_args) + ast = eval(func_body_ast(mac), mac_env_idx) + end + return ast + +eval_ast: procedure expose values. env. err /* eval_ast(ast, env_idx) */ + ast = arg(1) + env_idx = arg(2) + type = obj_type(ast) + val = obj_val(ast) + select + when type == "symb" then return env_get(env_idx, val) + when type == "list" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_list(res) + end + when type == "vect" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_vector(res) + end + when type == "hash" then do + res = "" + do i=1 to words(val) + element = eval(word(val, i), env_idx) + if element == "ERR" then return "ERR" + if i > 1 then + res = res || " " || element + else + res = element + end + return new_hashmap(res) + end + otherwise + return ast + end + +eval: procedure expose values. env. err /* eval(ast) */ + ast = arg(1) + env_idx = arg(2) + do forever + if \list?(ast) then return eval_ast(ast, env_idx) + ast = macroexpand(ast, env_idx) + if \list?(ast) then return eval_ast(ast, env_idx) + astval = obj_val(ast) + if words(astval) == 0 then return ast + a0sym = obj_val(word(astval, 1)) + select + when a0sym == "def!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, a2) + end + when a0sym == "let*" then do + a1lst = obj_val(word(astval, 2)) + letenv_idx = new_env(env_idx) + do i=1 to words(a1lst) by 2 + k = obj_val(word(a1lst, i)) + v = eval(word(a1lst, i + 1), letenv_idx) + if v == "ERR" then return "ERR" + unused = env_set(letenv_idx, k, v) + end + env_idx = letenv_idx + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "quote" then return word(astval, 2) + when a0sym == "quasiquoteexpand" then return quasiquote(word(astval, 2)) + when a0sym == "quasiquote" then do + ast = quasiquote(word(astval, 2)) + /* TCO */ + end + when a0sym == "defmacro!" then do + a1sym = obj_val(word(astval, 2)) + a2 = eval(word(astval, 3), env_idx) + if a2 == "ERR" then return "ERR" + return env_set(env_idx, a1sym, func_mark_as_macro(a2)) + end + when a0sym == "macroexpand" then return macroexpand(word(astval, 2), env_idx) + when a0sym == "try*" then do + res = eval(word(astval, 2), env_idx) + if words(astval) < 3 then return res + if res == "ERR" then do + if word(err, 1) == "__MAL_EXCEPTION__" then + errobj = word(err, 2) + else + errobj = new_string(err) + catchlst = obj_val(word(astval, 3)) + catch_env_idx = new_env(env_idx, new_list(word(catchlst, 2)), new_list(errobj)) + err = "" + return eval(word(catchlst, 3), catch_env_idx) + end + else + return res + end + when a0sym == "do" then do + do i=2 to (words(astval) - 1) + res = eval(word(astval, i), env_idx) + if res == "ERR" then return "ERR" + end + ast = word(astval, words(astval)) + /* TCO */ + end + when a0sym == "if" then do + condval = eval(word(astval, 2), env_idx) + if false?(condval) | nil?(condval) then + if words(astval) >= 4 then + ast = word(astval, 4) + else + return new_nil() + else + ast = word(astval, 3) + /* TCO */ + end + when a0sym == "fn*" then return new_func(word(astval, 3), env_idx, word(astval, 2)) + otherwise + lst_obj = eval_ast(ast, env_idx) + if lst_obj == "ERR" then return "ERR" + lst = obj_val(lst_obj) + f = word(lst, 1) + select + when nativefn?(f) then do + call_args = subword(lst, 2) + call_list = "" + do i=1 to words(call_args) + element = '"' || word(call_args, i) || '"' + if i > 1 then + call_list = call_list || ', ' || element + else + call_list = element + end + res = "" + interpret "res = " || obj_val(f) || "(" || call_list || ")" + return res + end + when func?(f) then do + call_args = new_list(subword(lst, 2)) + env_idx = new_env(func_env_idx(f), func_binds(f), call_args) + ast = func_body_ast(f) + /* TCO */ + end + otherwise + err = "Unsupported function object type: " || obj_type(f) + return "ERR" + end + end + end + +print: procedure expose values. /* print(ast) */ + return pr_str(arg(1), 1) + +re: procedure expose values. env. err repl_env_idx /* re(str) */ + str = arg(1) + ast = read(str) + if ast == "ERR" then return "ERR" + return eval(ast, repl_env_idx) + +rep: procedure expose values. env. err repl_env_idx /* rep(str) */ + str = arg(1) + exp = re(str) + if exp == "ERR" then return "ERR" + return print(exp) + +mal_eval: procedure expose values. env. err /* mal_eval(ast) */ + ast = arg(1) + if ast == "ERR" then return "ERR" + return eval(arg(1), 1) /* repl_env_idx is always 1 because it's the first env */ + +build_args_list: procedure expose values. command_line_args. /* build_args_list() */ + seq = "" + do i=2 to command_line_args.0 + s = new_string(command_line_args.i) + if i == 1 then + seq = s + else + seq = seq || " " || s + end + return new_list(seq) + +main: + x = time('R') /* Reset the internal stopwatch; used by `time-ms` */ + values. = "" + values.0 = 0 + env. = "" + env.0 = 0 + repl_env_idx = new_env(0) + + /* core.rexx: defined using Rexx */ + core_ns = get_core_ns() + do i=1 to words(core_ns) by 2 + x = env_set(repl_env_idx, word(core_ns, i), new_nativefn(word(core_ns, i + 1))) + end + x = env_set(repl_env_idx, "eval", new_nativefn("mal_eval")) + x = env_set(repl_env_idx, "*ARGV*", build_args_list()) + + /* core.mal: defined using the language itself */ + x = re('(def! *host-language* "rexx")') + x = re("(def! not (fn* (a) (if a false true)))") + x = re('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))') + x = re("(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)))))))"); + + err = "" + if command_line_args.0 > 0 then do + x = re('(load-file "' || command_line_args.1 || '")') + return + end + + x = re('(println (str "Mal [" *host-language* "]"))') + do while lines() > 0 /* 1 == 1 */ + input_line = readline('user> ') + if length(input_line) > 0 then do + res = rep(input_line) + if res == "ERR" then do + if word(err, 1) == "__MAL_EXCEPTION__" then + errstr = pr_str(word(err, 2), 0) + else + errstr = err + call lineout , "Error: " || errstr + err = "" + end + else + call lineout , res + end + end diff --git a/impls/rexx/tests/step5_tco.mal b/impls/rexx/tests/step5_tco.mal index 51604d627e..e6038ccf57 100644 --- a/impls/rexx/tests/step5_tco.mal +++ b/impls/rexx/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; REXX: skipping non-TCO recursion -;; Reason: regina rexx interpreter segfaults (unrecoverable) +;; REXX: skipping non-TCO recursion +;; Reason: regina rexx interpreter segfaults (unrecoverable) diff --git a/impls/rexx/tests/stepA_mal.mal b/impls/rexx/tests/stepA_mal.mal index 21a3f86050..f39937c9d9 100644 --- a/impls/rexx/tests/stepA_mal.mal +++ b/impls/rexx/tests/stepA_mal.mal @@ -1,23 +1,23 @@ -;; Testing basic Rexx interop -;; -;; Note that in Rexx "everything is a string". Numeric outputs are converted to -;; Mal numbers. - -(rexx-eval "3 ** 4") -;=>81 - -(rexx-eval "words('a bb ' || 'ccc dddd')") -;=>4 - -(rexx-eval "d2x(254)") -;=>"FE" - -(rexx-eval "say 'hello' 12.34 upper('rexx')" nil) -;/hello 12.34 REXX -;=>nil - -(rexx-eval "foo = 8" "foo + 3") -;=>11 - -(rexx-eval "parse version s1 s2 s3 s4 s5" "'rexx_version=' || s2") -;=>"rexx_version=5.00" +;; Testing basic Rexx interop +;; +;; Note that in Rexx "everything is a string". Numeric outputs are converted to +;; Mal numbers. + +(rexx-eval "3 ** 4") +;=>81 + +(rexx-eval "words('a bb ' || 'ccc dddd')") +;=>4 + +(rexx-eval "d2x(254)") +;=>"FE" + +(rexx-eval "say 'hello' 12.34 upper('rexx')" nil) +;/hello 12.34 REXX +;=>nil + +(rexx-eval "foo = 8" "foo + 3") +;=>11 + +(rexx-eval "parse version s1 s2 s3 s4 s5" "'rexx_version=' || s2") +;=>"rexx_version=5.00" diff --git a/impls/rexx/types.rexx b/impls/rexx/types.rexx index ba60256727..b448b4fab9 100644 --- a/impls/rexx/types.rexx +++ b/impls/rexx/types.rexx @@ -1,251 +1,251 @@ -#ifndef __types__ -#define __types__ - -values. = "" -values.0 = 0 - -new_value_index: procedure expose values. /* new_value_index() */ - values.0 = values.0 + 1 - return values.0 - -obj_type: procedure /* obj_type(obj) */ - obj = arg(1) - return left(obj, 4) - -obj_val: procedure expose values. /* obj_val(obj) */ - obj = arg(1) - type = obj_type(obj) - val = substr(obj, 6) - select - when type == "numb" | type == "nill" | type == "true" | type == "fals" then return val - otherwise - return values.val - end - -obj_meta: procedure expose values. /* obj_meta(obj) */ - obj = arg(1) - type = obj_type(obj) - if type == "numb" | type == "nill" | type == "true" | type == "fals" then return "" - ind = substr(obj, 6) - return values.meta.ind - -obj_clone_and_set_meta: procedure expose values. /* obj_clone_and_set_meta(obj, new_meta) */ - obj = arg(1) - new_meta = arg(2) - type = obj_type(obj) - if type == "numb" | type == "nill" | type == "true" | type == "fals" then return "" - orig_ind = substr(obj, 6) - new_idx = new_value_index() - values.new_idx = values.orig_ind - values.meta.new_idx = new_meta - return type || "_" || new_idx - -new_number: procedure /* new_number(n) */ - n = arg(1) - return "numb_" || n - -number?: procedure /* number?(obj) */ - return obj_type(arg(1)) == "numb" - -new_nil: procedure /* new_nil() */ - return "nill_0" - -nil?: procedure /* nil?(obj) */ - return obj_type(arg(1)) == "nill" - -new_true: procedure /* new_true() */ - return "true_0" - -true?: procedure /* true?(obj) */ - return obj_type(arg(1)) == "true" - -new_false: procedure /* new_false() */ - return "fals_0" - -false?: procedure /* false?(obj) */ - return obj_type(arg(1)) == "fals" - -new_boolean: procedure /* new_boolean(cond) */ - if arg(1) then - return new_true() - else - return new_false() - -new_symbol: procedure expose values. /* new_symbol(str) */ - str = arg(1) - idx = new_value_index() - values.idx = str - return "symb_" || idx - -symbol?: procedure /* symbol?(obj) */ - return obj_type(arg(1)) == "symb" - -new_string: procedure expose values. /* new_string(str) */ - str = arg(1) - idx = new_value_index() - values.idx = str - return "stri_" || idx - -string?: procedure /* string?(obj) */ - return obj_type(arg(1)) == "stri" - -new_keyword: procedure expose values. /* new_keyword(str) */ - str = arg(1) - idx = new_value_index() - values.idx = str - return "keyw_" || idx - -keyword?: procedure /* keyword?(obj) */ - return obj_type(arg(1)) == "keyw" - -new_seq: procedure expose values. /* new_seq(type, seq) */ - type = arg(1) - seq = arg(2) - idx = new_value_index() - values.idx = seq - return type || "_" || idx - -new_list: procedure expose values. /* new_list(seq) */ - seq = arg(1) - return new_seq("list", seq) - -list?: procedure /* list?(obj) */ - return obj_type(arg(1)) == "list" - -new_vector: procedure expose values. /* new_vector(seq) */ - seq = arg(1) - return new_seq("vect", seq) - -vector?: procedure /* vector?(obj) */ - return obj_type(arg(1)) == "vect" - -sequential?: procedure /* sequential?(obj) */ - return (list?(arg(1)) | vector?(arg(1))) - -count_elements: procedure expose values. /* count_elements(lst) */ - return words(obj_val(arg(1))) - -new_hashmap: procedure expose values. /* new_hashmap(seq) */ - seq = arg(1) - return new_seq("hash", seq) - -hashmap?: procedure /* hashmap?(obj) */ - return obj_type(arg(1)) == "hash" - -contains?: procedure expose values. /* contains?(hm_val, key) */ - hm_val = arg(1) - key = arg(2) - do i=1 to words(hm_val) by 2 - if equal?(key, word(hm_val, i)) then return 1 - end - return 0 - -hashmap_get: procedure expose values. /* hashmap_get(hm_val, key) */ - hm_val = arg(1) - key = arg(2) - do i=1 to words(hm_val) by 2 - if equal?(key, word(hm_val, i)) then return word(hm_val, i + 1) - end - return "" - -new_nativefn: procedure expose values. /* new_hashmap(native_func_name) */ - native_func_name = arg(1) - idx = new_value_index() - values.idx = native_func_name - return "nafn_" || idx - -nativefn?: procedure /* nativefn?(obj) */ - return obj_type(arg(1)) == "nafn" - -new_func: procedure expose values. /* new_func(body_ast, env_idx, binds) */ - body_ast = arg(1) - env_idx = arg(2) - binds = arg(3) - is_macro = 0 - idx = new_value_index() - values.idx = body_ast env_idx binds is_macro - return "func_" || idx - -func?: procedure /* func?(obj) */ - return obj_type(arg(1)) == "func" - -func_macro?: procedure expose values. /* func_macro?(obj) */ - return func?(arg(1)) & (func_is_macro(arg(1)) == 1) - -func_body_ast: procedure expose values. /* func_body_ast(func_obj) */ - return word(obj_val(arg(1)), 1) - -func_env_idx: procedure expose values. /* func_env_idx(func_obj) */ - return word(obj_val(arg(1)), 2) - -func_binds: procedure expose values. /* func_binds(func_obj) */ - return word(obj_val(arg(1)), 3) - -func_is_macro: procedure expose values. /* func_is_macro(func_obj) */ - return word(obj_val(arg(1)), 4) - -func_mark_as_macro: procedure expose values. /* func_mark_as_macro(func_obj) */ - idx = substr(arg(1), 6) - values.idx = subword(values.idx, 1, 3) 1 - return arg(1) - -new_atom: procedure expose values. /* new_atom(obj) */ - obj = arg(1) - idx = new_value_index() - values.idx = obj - return "atom_" || idx - -atom?: procedure /* atom?(obj) */ - return obj_type(arg(1)) == "atom" - -atom_set: procedure expose values. /* atom_set(atom, new_value) */ - atom = arg(1) - new_value = arg(2) - idx = substr(atom, 6) - values.idx = new_value - return new_value - -equal_hashmap?: procedure expose values. /* equal_hashmap?(a, b) */ - hma_val = obj_val(arg(1)) - hmb_val = obj_val(arg(2)) - if words(hma_val) \= words(hmb_val) then return 0 - do i=1 to words(hma_val) by 2 - a_key = word(hma_val, i) - a_val = word(hma_val, i + 1) - b_val = hashmap_get(hmb_val, a_key) - if b_val == "" then return 0 - if \equal?(a_val, b_val) then return 0 - end - return 1 - -equal_sequential?: procedure expose values. /* equal_sequential?(a, b) */ - a_val = obj_val(arg(1)) - b_val = obj_val(arg(2)) - if words(a_val) \= words(b_val) then return 0 - do i=1 to words(a_val) - if \equal?(word(a_val, i), word(b_val, i)) then return 0 - end - return 1 - -equal?: procedure expose values. /* equal?(a, b) */ - a = arg(1) - b = arg(2) - a_type = obj_type(a) - b_type = obj_type(b) - a_val = obj_val(a) - b_val = obj_val(b) - select - when nil?(a) then return nil?(b) - when true?(a) then return true?(b) - when false?(a) then return false?(b) - when (a_type == "numb" & b_type = "numb") | , - (a_type == "symb" & b_type = "symb") | , - (a_type == "stri" & b_type = "stri") | , - (a_type == "keyw" & b_type = "keyw") then return (obj_val(a) == obj_val(b)) - when (sequential?(a) & sequential?(b)) then return equal_sequential?(a, b) - when (hashmap?(a) & hashmap?(b)) then return equal_hashmap?(a, b) - otherwise - return 0 - end - -#endif +#ifndef __types__ +#define __types__ + +values. = "" +values.0 = 0 + +new_value_index: procedure expose values. /* new_value_index() */ + values.0 = values.0 + 1 + return values.0 + +obj_type: procedure /* obj_type(obj) */ + obj = arg(1) + return left(obj, 4) + +obj_val: procedure expose values. /* obj_val(obj) */ + obj = arg(1) + type = obj_type(obj) + val = substr(obj, 6) + select + when type == "numb" | type == "nill" | type == "true" | type == "fals" then return val + otherwise + return values.val + end + +obj_meta: procedure expose values. /* obj_meta(obj) */ + obj = arg(1) + type = obj_type(obj) + if type == "numb" | type == "nill" | type == "true" | type == "fals" then return "" + ind = substr(obj, 6) + return values.meta.ind + +obj_clone_and_set_meta: procedure expose values. /* obj_clone_and_set_meta(obj, new_meta) */ + obj = arg(1) + new_meta = arg(2) + type = obj_type(obj) + if type == "numb" | type == "nill" | type == "true" | type == "fals" then return "" + orig_ind = substr(obj, 6) + new_idx = new_value_index() + values.new_idx = values.orig_ind + values.meta.new_idx = new_meta + return type || "_" || new_idx + +new_number: procedure /* new_number(n) */ + n = arg(1) + return "numb_" || n + +number?: procedure /* number?(obj) */ + return obj_type(arg(1)) == "numb" + +new_nil: procedure /* new_nil() */ + return "nill_0" + +nil?: procedure /* nil?(obj) */ + return obj_type(arg(1)) == "nill" + +new_true: procedure /* new_true() */ + return "true_0" + +true?: procedure /* true?(obj) */ + return obj_type(arg(1)) == "true" + +new_false: procedure /* new_false() */ + return "fals_0" + +false?: procedure /* false?(obj) */ + return obj_type(arg(1)) == "fals" + +new_boolean: procedure /* new_boolean(cond) */ + if arg(1) then + return new_true() + else + return new_false() + +new_symbol: procedure expose values. /* new_symbol(str) */ + str = arg(1) + idx = new_value_index() + values.idx = str + return "symb_" || idx + +symbol?: procedure /* symbol?(obj) */ + return obj_type(arg(1)) == "symb" + +new_string: procedure expose values. /* new_string(str) */ + str = arg(1) + idx = new_value_index() + values.idx = str + return "stri_" || idx + +string?: procedure /* string?(obj) */ + return obj_type(arg(1)) == "stri" + +new_keyword: procedure expose values. /* new_keyword(str) */ + str = arg(1) + idx = new_value_index() + values.idx = str + return "keyw_" || idx + +keyword?: procedure /* keyword?(obj) */ + return obj_type(arg(1)) == "keyw" + +new_seq: procedure expose values. /* new_seq(type, seq) */ + type = arg(1) + seq = arg(2) + idx = new_value_index() + values.idx = seq + return type || "_" || idx + +new_list: procedure expose values. /* new_list(seq) */ + seq = arg(1) + return new_seq("list", seq) + +list?: procedure /* list?(obj) */ + return obj_type(arg(1)) == "list" + +new_vector: procedure expose values. /* new_vector(seq) */ + seq = arg(1) + return new_seq("vect", seq) + +vector?: procedure /* vector?(obj) */ + return obj_type(arg(1)) == "vect" + +sequential?: procedure /* sequential?(obj) */ + return (list?(arg(1)) | vector?(arg(1))) + +count_elements: procedure expose values. /* count_elements(lst) */ + return words(obj_val(arg(1))) + +new_hashmap: procedure expose values. /* new_hashmap(seq) */ + seq = arg(1) + return new_seq("hash", seq) + +hashmap?: procedure /* hashmap?(obj) */ + return obj_type(arg(1)) == "hash" + +contains?: procedure expose values. /* contains?(hm_val, key) */ + hm_val = arg(1) + key = arg(2) + do i=1 to words(hm_val) by 2 + if equal?(key, word(hm_val, i)) then return 1 + end + return 0 + +hashmap_get: procedure expose values. /* hashmap_get(hm_val, key) */ + hm_val = arg(1) + key = arg(2) + do i=1 to words(hm_val) by 2 + if equal?(key, word(hm_val, i)) then return word(hm_val, i + 1) + end + return "" + +new_nativefn: procedure expose values. /* new_hashmap(native_func_name) */ + native_func_name = arg(1) + idx = new_value_index() + values.idx = native_func_name + return "nafn_" || idx + +nativefn?: procedure /* nativefn?(obj) */ + return obj_type(arg(1)) == "nafn" + +new_func: procedure expose values. /* new_func(body_ast, env_idx, binds) */ + body_ast = arg(1) + env_idx = arg(2) + binds = arg(3) + is_macro = 0 + idx = new_value_index() + values.idx = body_ast env_idx binds is_macro + return "func_" || idx + +func?: procedure /* func?(obj) */ + return obj_type(arg(1)) == "func" + +func_macro?: procedure expose values. /* func_macro?(obj) */ + return func?(arg(1)) & (func_is_macro(arg(1)) == 1) + +func_body_ast: procedure expose values. /* func_body_ast(func_obj) */ + return word(obj_val(arg(1)), 1) + +func_env_idx: procedure expose values. /* func_env_idx(func_obj) */ + return word(obj_val(arg(1)), 2) + +func_binds: procedure expose values. /* func_binds(func_obj) */ + return word(obj_val(arg(1)), 3) + +func_is_macro: procedure expose values. /* func_is_macro(func_obj) */ + return word(obj_val(arg(1)), 4) + +func_mark_as_macro: procedure expose values. /* func_mark_as_macro(func_obj) */ + idx = substr(arg(1), 6) + values.idx = subword(values.idx, 1, 3) 1 + return arg(1) + +new_atom: procedure expose values. /* new_atom(obj) */ + obj = arg(1) + idx = new_value_index() + values.idx = obj + return "atom_" || idx + +atom?: procedure /* atom?(obj) */ + return obj_type(arg(1)) == "atom" + +atom_set: procedure expose values. /* atom_set(atom, new_value) */ + atom = arg(1) + new_value = arg(2) + idx = substr(atom, 6) + values.idx = new_value + return new_value + +equal_hashmap?: procedure expose values. /* equal_hashmap?(a, b) */ + hma_val = obj_val(arg(1)) + hmb_val = obj_val(arg(2)) + if words(hma_val) \= words(hmb_val) then return 0 + do i=1 to words(hma_val) by 2 + a_key = word(hma_val, i) + a_val = word(hma_val, i + 1) + b_val = hashmap_get(hmb_val, a_key) + if b_val == "" then return 0 + if \equal?(a_val, b_val) then return 0 + end + return 1 + +equal_sequential?: procedure expose values. /* equal_sequential?(a, b) */ + a_val = obj_val(arg(1)) + b_val = obj_val(arg(2)) + if words(a_val) \= words(b_val) then return 0 + do i=1 to words(a_val) + if \equal?(word(a_val, i), word(b_val, i)) then return 0 + end + return 1 + +equal?: procedure expose values. /* equal?(a, b) */ + a = arg(1) + b = arg(2) + a_type = obj_type(a) + b_type = obj_type(b) + a_val = obj_val(a) + b_val = obj_val(b) + select + when nil?(a) then return nil?(b) + when true?(a) then return true?(b) + when false?(a) then return false?(b) + when (a_type == "numb" & b_type = "numb") | , + (a_type == "symb" & b_type = "symb") | , + (a_type == "stri" & b_type = "stri") | , + (a_type == "keyw" & b_type = "keyw") then return (obj_val(a) == obj_val(b)) + when (sequential?(a) & sequential?(b)) then return equal_sequential?(a, b) + when (hashmap?(a) & hashmap?(b)) then return equal_hashmap?(a, b) + otherwise + return 0 + end + +#endif diff --git a/impls/rpython/Dockerfile b/impls/rpython/Dockerfile index 29f97d58e0..477f4f87ce 100644 --- a/impls/rpython/Dockerfile +++ b/impls/rpython/Dockerfile @@ -1,47 +1,47 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building rpython -RUN apt-get -y install g++ - -# pypy -RUN apt-get -y install software-properties-common -RUN add-apt-repository ppa:pypy -RUN apt-get -y update -RUN apt-get -y install pypy - -# rpython -RUN apt-get -y install mercurial libffi-dev pkg-config libz-dev libbz2-dev \ - libsqlite3-dev libncurses-dev libexpat1-dev libssl-dev libgdbm-dev tcl-dev - -RUN mkdir -p /opt/pypy && \ - curl -L https://bitbucket.org/pypy/pypy/downloads/pypy2-v5.6.0-src.tar.bz2 | tar -xjf - -C /opt/pypy/ --strip-components=1 - #curl https://bitbucket.org/pypy/pypy/get/tip.tar.gz | tar -xzf - -C /opt/pypy/ --strip-components=1 -RUN cd /opt/pypy && make && rm -rf /tmp/usession* - -RUN ln -sf /opt/pypy/rpython/bin/rpython /usr/local/bin/rpython -RUN ln -sf /opt/pypy/pypy-c /usr/local/bin/pypy -RUN chmod -R ugo+rw /opt/pypy/rpython/_cache - -RUN apt-get -y autoremove pypy - +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building rpython +RUN apt-get -y install g++ + +# pypy +RUN apt-get -y install software-properties-common +RUN add-apt-repository ppa:pypy +RUN apt-get -y update +RUN apt-get -y install pypy + +# rpython +RUN apt-get -y install mercurial libffi-dev pkg-config libz-dev libbz2-dev \ + libsqlite3-dev libncurses-dev libexpat1-dev libssl-dev libgdbm-dev tcl-dev + +RUN mkdir -p /opt/pypy && \ + curl -L https://bitbucket.org/pypy/pypy/downloads/pypy2-v5.6.0-src.tar.bz2 | tar -xjf - -C /opt/pypy/ --strip-components=1 + #curl https://bitbucket.org/pypy/pypy/get/tip.tar.gz | tar -xzf - -C /opt/pypy/ --strip-components=1 +RUN cd /opt/pypy && make && rm -rf /tmp/usession* + +RUN ln -sf /opt/pypy/rpython/bin/rpython /usr/local/bin/rpython +RUN ln -sf /opt/pypy/pypy-c /usr/local/bin/pypy +RUN chmod -R ugo+rw /opt/pypy/rpython/_cache + +RUN apt-get -y autoremove pypy + diff --git a/impls/rpython/Makefile b/impls/rpython/Makefile index 95a38adfd6..13ef81526c 100644 --- a/impls/rpython/Makefile +++ b/impls/rpython/Makefile @@ -1,32 +1,32 @@ - -RPYTHON = rpython - -UPPER_STEPS = step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal -STEPS = step0_repl step1_read_print step2_eval step3_env $(UPPER_STEPS) - -all: $(STEPS) - -dist: mal - -mal: stepA_mal - cp $< $@ - -%: %.py - $(RPYTHON) --output=$@ $< - -STEP0_DEPS = mal_readline.py -STEP1_DEPS = $(STEP0_DEPS) mal_types.py reader.py printer.py -STEP3_DEPS = $(STEP1_DEPS) env.py -STEP4_DEPS = $(STEP3_DEPS) core.py - -step0_repl: $(STEP0_DEPS) -step1_read_print step2_eval: $(STEP1_DEPS) -step3_env: $(STEP3_DEPS) -$(UPPER_STEPS): $(STEP4_DEPS) - -.PHONY: clean - -clean: - rm -f mal $(STEPS) *.pyc - rm -rf __pycache__ - + +RPYTHON = rpython + +UPPER_STEPS = step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal +STEPS = step0_repl step1_read_print step2_eval step3_env $(UPPER_STEPS) + +all: $(STEPS) + +dist: mal + +mal: stepA_mal + cp $< $@ + +%: %.py + $(RPYTHON) --output=$@ $< + +STEP0_DEPS = mal_readline.py +STEP1_DEPS = $(STEP0_DEPS) mal_types.py reader.py printer.py +STEP3_DEPS = $(STEP1_DEPS) env.py +STEP4_DEPS = $(STEP3_DEPS) core.py + +step0_repl: $(STEP0_DEPS) +step1_read_print step2_eval: $(STEP1_DEPS) +step3_env: $(STEP3_DEPS) +$(UPPER_STEPS): $(STEP4_DEPS) + +.PHONY: clean + +clean: + rm -f mal $(STEPS) *.pyc + rm -rf __pycache__ + diff --git a/impls/rpython/core.py b/impls/rpython/core.py index 6df848b5d6..a8f84d3f1c 100644 --- a/impls/rpython/core.py +++ b/impls/rpython/core.py @@ -1,445 +1,445 @@ -#import copy, time -import time - -import mal_types as types -from mal_types import (throw_str, - MalType, MalMeta, nil, true, false, - MalInt, MalSym, MalStr, - MalList, MalVector, MalHashMap, - MalAtom, MalFunc) -import mal_readline -import reader -import printer - -# General functions -def wrap_tf(tf): - if tf: return true - else: return false - -def do_equal(args): return wrap_tf(types._equal_Q(args[0], args[1])) - -# Errors/Exceptions -def throw(args): - raise types.MalException(args[0]) - -# Scalar functions -def nil_Q(args): return wrap_tf(types._nil_Q(args[0])) -def true_Q(args): return wrap_tf(types._true_Q(args[0])) -def false_Q(args): return wrap_tf(types._false_Q(args[0])) -def string_Q(args): return wrap_tf(types._string_Q(args[0])) -def symbol(args): - a0 = args[0] - if isinstance(a0, MalStr): - return types._symbol(a0.value) - elif isinstance(a0, MalSym): - return a0 - else: - throw_str("symbol called on non-string/non-symbol") -def symbol_Q(args): return wrap_tf(types._symbol_Q(args[0])) -def keyword(args): return types._keyword(args[0]) -def keyword_Q(args): return wrap_tf(types._keyword_Q(args[0])) -def number_Q(args): return wrap_tf(types._int_Q(args[0])) -def function_Q(args): return wrap_tf(types._function_Q(args[0]) and not args[0].ismacro) -def macro_Q(args): return wrap_tf(types._function_Q(args[0]) and args[0].ismacro) - - -# String functions -def pr_str(args): - parts = [] - for exp in args.values: parts.append(printer._pr_str(exp, True)) - return MalStr(u" ".join(parts)) - -def do_str(args): - parts = [] - for exp in args.values: parts.append(printer._pr_str(exp, False)) - return MalStr(u"".join(parts)) - -def prn(args): - parts = [] - for exp in args.values: parts.append(printer._pr_str(exp, True)) - print(u" ".join(parts)) - return nil - -def println(args): - parts = [] - for exp in args.values: parts.append(printer._pr_str(exp, False)) - print(u" ".join(parts)) - return nil - -def do_readline(args): - prompt = args[0] - if not isinstance(prompt, MalStr): - throw_str("readline prompt is not a string") - try: - return MalStr(unicode(mal_readline.readline(str(prompt.value)))) - except EOFError: - return nil - -def read_str(args): - a0 = args[0] - if not isinstance(a0, MalStr): - throw_str("read-string of non-string") - return reader.read_str(str(a0.value)) - -def slurp(args): - a0 = args[0] - if not isinstance(a0, MalStr): - throw_str("slurp with non-string filename") - return MalStr(unicode(open(str(a0.value)).read())) - -# Number functions -def lt(args): - a, b = args[0], args[1] - if not isinstance(a, MalInt) or not isinstance(b, MalInt): - throw_str("< called on non-integer") - return wrap_tf(a.value < b.value) -def lte(args): - a, b = args[0], args[1] - if not isinstance(a, MalInt) or not isinstance(b, MalInt): - throw_str("<= called on non-integer") - return wrap_tf(a.value <= b.value) -def gt(args): - a, b = args[0], args[1] - if not isinstance(a, MalInt) or not isinstance(b, MalInt): - throw_str("> called on non-integer") - return wrap_tf(a.value > b.value) -def gte(args): - a, b = args[0], args[1] - if not isinstance(a, MalInt) or not isinstance(b, MalInt): - throw_str(">= called on non-integer") - return wrap_tf(a.value >= b.value) - -def plus(args): - a, b = args[0], args[1] - if not isinstance(a, MalInt) or not isinstance(b, MalInt): - throw_str("+ called on non-integer") - return MalInt(a.value+b.value) -def minus(args): - a, b = args[0], args[1] - if not isinstance(a, MalInt) or not isinstance(b, MalInt): - throw_str("- called on non-integer") - return MalInt(a.value-b.value) -def multiply(args): - a, b = args[0], args[1] - if not isinstance(a, MalInt) or not isinstance(b, MalInt): - throw_str("* called on non-integer") - return MalInt(a.value*b.value) -def divide(args): - a, b = args[0], args[1] - if not isinstance(a, MalInt) or not isinstance(b, MalInt): - throw_str("/ called on non-integer") - if b.value == 0: - throw_str("divide by zero") - return MalInt(int(a.value/b.value)) - -def time_ms(args): - return MalInt(int(time.time() * 1000)) - - -# Hash map functions -def do_hash_map(ml): - return types._hash_mapl(ml.values) - -def hash_map_Q(args): - return wrap_tf(types._hash_map_Q(args[0])) - -def assoc(args): - src_hm, key_vals = args[0], args.rest() - new_dct = src_hm.dct.copy() - for i in range(0,len(key_vals),2): - k = key_vals[i] - if not isinstance(k, MalStr): - throw_str("assoc called with non-string/non-keyword key") - new_dct[k.value] = key_vals[i+1] - return MalHashMap(new_dct) - -def dissoc(args): - src_hm, keys = args[0], args.rest() - new_dct = src_hm.dct.copy() - for k in keys.values: - if not isinstance(k, MalStr): - throw_str("dissoc called with non-string/non-keyword key") - if k.value in new_dct: - del new_dct[k.value] - return MalHashMap(new_dct) - -def get(args): - obj, key = args[0], args[1] - if obj is nil: - return nil - elif isinstance(obj, MalHashMap): - if not isinstance(key, MalStr): - throw_str("get called on hash-map with non-string/non-keyword key") - if obj and key.value in obj.dct: - return obj.dct[key.value] - else: - return nil - elif isinstance(obj, MalList): - if not isinstance(key, MalInt): - throw_str("get called on list/vector with non-string/non-keyword key") - return obj.values[key.value] - else: - throw_str("get called on invalid type") - -def contains_Q(args): - hm, key = args[0], args[1] - if not isinstance(key, MalStr): - throw_str("contains? called on hash-map with non-string/non-keyword key") - return wrap_tf(key.value in hm.dct) - -def keys(args): - hm = args[0] - keys = [] - for k in hm.dct.keys(): keys.append(MalStr(k)) - return MalList(keys) - -def vals(args): - hm = args[0] - return MalList(hm.dct.values()) - - -# Sequence functions -def do_list(ml): - return ml - -def list_Q(args): - return wrap_tf(types._list_Q(args[0])) - -def do_vector(ml): - return MalVector(ml.values) - -def vector_Q(args): - return wrap_tf(types._vector_Q(args[0])) - -def empty_Q(args): - seq = args[0] - if isinstance(seq, MalList): - return wrap_tf(len(seq) == 0) - elif seq is nil: - return true - else: - throw_str("empty? called on non-sequence") - -def count(args): - seq = args[0] - if isinstance(seq, MalList): - return MalInt(len(seq)) - elif seq is nil: - return MalInt(0) - else: - throw_str("count called on non-sequence") - -def sequential_Q(args): - return wrap_tf(types._sequential_Q(args[0])) - -def vec(args): - seq = args[0] - if isinstance(seq, MalList): - return MalVector(seq.values) - else: - throw_str("vec called on non-sequence") - -def cons(args): - x, seq = args[0], args[1] - if not isinstance(seq, MalList): - throw_str("cons called with non-list/non-vector") - return MalList([x] + seq.values) - -def concat(args): - new_lst = [] - for l in args.values: - if not isinstance(l, MalList): - throw_str("concat called with non-list/non-vector") - new_lst = new_lst + l.values - return MalList(new_lst) - -def nth(args): - lst, idx = args[0], args[1] - if not isinstance(lst, MalList): - throw_str("nth called with non-list/non-vector") - if not isinstance(idx, MalInt): - throw_str("nth called with non-int index") - if idx.value < len(lst): return lst[idx.value] - else: throw_str("nth: index out of range") - -def first(args): - a0 = args[0] - if a0 is nil: - return nil - elif not isinstance(a0, MalList): - throw_str("first called with non-list/non-vector") - if len(a0) == 0: return nil - else: return a0[0] - -def rest(args): - a0 = args[0] - if a0 is nil: - return MalList([]) - elif not isinstance(a0, MalList): - throw_str("rest called with non-list/non-vector") - if len(a0) == 0: return MalList([]) - else: return a0.rest() - -def apply(args): - f, fargs = args[0], args.rest() - last_arg = fargs.values[-1] - if not isinstance(last_arg, MalList): - throw_str("map called with non-list") - all_args = fargs.values[0:-1] + last_arg.values - return f.apply(MalList(all_args)) - -def mapf(args): - f, lst = args[0], args[1] - if not isinstance(lst, MalList): - throw_str("map called with non-list") - res = [] - for a in lst.values: - res.append(f.apply(MalList([a]))) - return MalList(res) - -# retains metadata -def conj(args): - lst, args = args[0], args.rest() - new_lst = None - if types._list_Q(lst): - vals = args.values[:] - vals.reverse() - new_lst = MalList(vals + lst.values) - elif types._vector_Q(lst): - new_lst = MalVector(lst.values + list(args.values)) - else: - throw_str("conj on non-list/non-vector") - new_lst.meta = lst.meta - return new_lst - -def seq(args): - a0 = args[0] - if isinstance(a0, MalVector): - if len(a0) == 0: return nil - return MalList(a0.values) - elif isinstance(a0, MalList): - if len(a0) == 0: return nil - return a0 - elif types._string_Q(a0): - assert isinstance(a0, MalStr) - if len(a0) == 0: return nil - return MalList([MalStr(unicode(c)) for c in a0.value]) - elif a0 is nil: - return nil - else: - throw_str("seq: called on non-sequence") - -# Metadata functions -def with_meta(args): - obj, meta = args[0], args[1] - if isinstance(obj, MalMeta): - new_obj = types._clone(obj) - new_obj.meta = meta - return new_obj - else: - throw_str("with-meta not supported on type") - -def meta(args): - obj = args[0] - if isinstance(obj, MalMeta): - return obj.meta - else: - throw_str("meta not supported on type") - - -# Atoms functions -def do_atom(args): - return MalAtom(args[0]) -def atom_Q(args): - return wrap_tf(types._atom_Q(args[0])) -def deref(args): - atm = args[0] - if not isinstance(atm, MalAtom): - throw_str("deref called on non-atom") - return atm.value -def reset_BANG(args): - atm, val = args[0], args[1] - if not isinstance(atm, MalAtom): - throw_str("reset! called on non-atom") - atm.value = val - return atm.value -def swap_BANG(args): - atm, f, fargs = args[0], args[1], args.slice(2) - if not isinstance(atm, MalAtom): - throw_str("swap! called on non-atom") - if not isinstance(f, MalFunc): - throw_str("swap! called with non-function") - all_args = [atm.value] + fargs.values - atm.value = f.apply(MalList(all_args)) - return atm.value - - -ns = { - '=': do_equal, - 'throw': throw, - 'nil?': nil_Q, - 'true?': true_Q, - 'false?': false_Q, - 'string?': string_Q, - 'symbol': symbol, - 'symbol?': symbol_Q, - 'keyword': keyword, - 'keyword?': keyword_Q, - 'number?': number_Q, - 'fn?': function_Q, - 'macro?': macro_Q, - - 'pr-str': pr_str, - 'str': do_str, - 'prn': prn, - 'println': println, - 'readline': do_readline, - 'read-string': read_str, - 'slurp': slurp, - '<': lt, - '<=': lte, - '>': gt, - '>=': gte, - '+': plus, - '-': minus, - '*': multiply, - '/': divide, - 'time-ms': time_ms, - - 'list': do_list, - 'list?': list_Q, - 'vector': do_vector, - 'vector?': vector_Q, - 'hash-map': do_hash_map, - 'map?': hash_map_Q, - 'assoc': assoc, - 'dissoc': dissoc, - 'get': get, - 'contains?': contains_Q, - 'keys': keys, - 'vals': vals, - - 'sequential?': sequential_Q, - 'vec': vec, - 'cons': cons, - 'concat': concat, - 'nth': nth, - 'first': first, - 'rest': rest, - 'empty?': empty_Q, - 'count': count, - 'apply': apply, - 'map': mapf, - - 'conj': conj, - 'seq': seq, - - 'with-meta': with_meta, - 'meta': meta, - 'atom': do_atom, - 'atom?': atom_Q, - 'deref': deref, - 'reset!': reset_BANG, - 'swap!': swap_BANG - } - +#import copy, time +import time + +import mal_types as types +from mal_types import (throw_str, + MalType, MalMeta, nil, true, false, + MalInt, MalSym, MalStr, + MalList, MalVector, MalHashMap, + MalAtom, MalFunc) +import mal_readline +import reader +import printer + +# General functions +def wrap_tf(tf): + if tf: return true + else: return false + +def do_equal(args): return wrap_tf(types._equal_Q(args[0], args[1])) + +# Errors/Exceptions +def throw(args): + raise types.MalException(args[0]) + +# Scalar functions +def nil_Q(args): return wrap_tf(types._nil_Q(args[0])) +def true_Q(args): return wrap_tf(types._true_Q(args[0])) +def false_Q(args): return wrap_tf(types._false_Q(args[0])) +def string_Q(args): return wrap_tf(types._string_Q(args[0])) +def symbol(args): + a0 = args[0] + if isinstance(a0, MalStr): + return types._symbol(a0.value) + elif isinstance(a0, MalSym): + return a0 + else: + throw_str("symbol called on non-string/non-symbol") +def symbol_Q(args): return wrap_tf(types._symbol_Q(args[0])) +def keyword(args): return types._keyword(args[0]) +def keyword_Q(args): return wrap_tf(types._keyword_Q(args[0])) +def number_Q(args): return wrap_tf(types._int_Q(args[0])) +def function_Q(args): return wrap_tf(types._function_Q(args[0]) and not args[0].ismacro) +def macro_Q(args): return wrap_tf(types._function_Q(args[0]) and args[0].ismacro) + + +# String functions +def pr_str(args): + parts = [] + for exp in args.values: parts.append(printer._pr_str(exp, True)) + return MalStr(u" ".join(parts)) + +def do_str(args): + parts = [] + for exp in args.values: parts.append(printer._pr_str(exp, False)) + return MalStr(u"".join(parts)) + +def prn(args): + parts = [] + for exp in args.values: parts.append(printer._pr_str(exp, True)) + print(u" ".join(parts)) + return nil + +def println(args): + parts = [] + for exp in args.values: parts.append(printer._pr_str(exp, False)) + print(u" ".join(parts)) + return nil + +def do_readline(args): + prompt = args[0] + if not isinstance(prompt, MalStr): + throw_str("readline prompt is not a string") + try: + return MalStr(unicode(mal_readline.readline(str(prompt.value)))) + except EOFError: + return nil + +def read_str(args): + a0 = args[0] + if not isinstance(a0, MalStr): + throw_str("read-string of non-string") + return reader.read_str(str(a0.value)) + +def slurp(args): + a0 = args[0] + if not isinstance(a0, MalStr): + throw_str("slurp with non-string filename") + return MalStr(unicode(open(str(a0.value)).read())) + +# Number functions +def lt(args): + a, b = args[0], args[1] + if not isinstance(a, MalInt) or not isinstance(b, MalInt): + throw_str("< called on non-integer") + return wrap_tf(a.value < b.value) +def lte(args): + a, b = args[0], args[1] + if not isinstance(a, MalInt) or not isinstance(b, MalInt): + throw_str("<= called on non-integer") + return wrap_tf(a.value <= b.value) +def gt(args): + a, b = args[0], args[1] + if not isinstance(a, MalInt) or not isinstance(b, MalInt): + throw_str("> called on non-integer") + return wrap_tf(a.value > b.value) +def gte(args): + a, b = args[0], args[1] + if not isinstance(a, MalInt) or not isinstance(b, MalInt): + throw_str(">= called on non-integer") + return wrap_tf(a.value >= b.value) + +def plus(args): + a, b = args[0], args[1] + if not isinstance(a, MalInt) or not isinstance(b, MalInt): + throw_str("+ called on non-integer") + return MalInt(a.value+b.value) +def minus(args): + a, b = args[0], args[1] + if not isinstance(a, MalInt) or not isinstance(b, MalInt): + throw_str("- called on non-integer") + return MalInt(a.value-b.value) +def multiply(args): + a, b = args[0], args[1] + if not isinstance(a, MalInt) or not isinstance(b, MalInt): + throw_str("* called on non-integer") + return MalInt(a.value*b.value) +def divide(args): + a, b = args[0], args[1] + if not isinstance(a, MalInt) or not isinstance(b, MalInt): + throw_str("/ called on non-integer") + if b.value == 0: + throw_str("divide by zero") + return MalInt(int(a.value/b.value)) + +def time_ms(args): + return MalInt(int(time.time() * 1000)) + + +# Hash map functions +def do_hash_map(ml): + return types._hash_mapl(ml.values) + +def hash_map_Q(args): + return wrap_tf(types._hash_map_Q(args[0])) + +def assoc(args): + src_hm, key_vals = args[0], args.rest() + new_dct = src_hm.dct.copy() + for i in range(0,len(key_vals),2): + k = key_vals[i] + if not isinstance(k, MalStr): + throw_str("assoc called with non-string/non-keyword key") + new_dct[k.value] = key_vals[i+1] + return MalHashMap(new_dct) + +def dissoc(args): + src_hm, keys = args[0], args.rest() + new_dct = src_hm.dct.copy() + for k in keys.values: + if not isinstance(k, MalStr): + throw_str("dissoc called with non-string/non-keyword key") + if k.value in new_dct: + del new_dct[k.value] + return MalHashMap(new_dct) + +def get(args): + obj, key = args[0], args[1] + if obj is nil: + return nil + elif isinstance(obj, MalHashMap): + if not isinstance(key, MalStr): + throw_str("get called on hash-map with non-string/non-keyword key") + if obj and key.value in obj.dct: + return obj.dct[key.value] + else: + return nil + elif isinstance(obj, MalList): + if not isinstance(key, MalInt): + throw_str("get called on list/vector with non-string/non-keyword key") + return obj.values[key.value] + else: + throw_str("get called on invalid type") + +def contains_Q(args): + hm, key = args[0], args[1] + if not isinstance(key, MalStr): + throw_str("contains? called on hash-map with non-string/non-keyword key") + return wrap_tf(key.value in hm.dct) + +def keys(args): + hm = args[0] + keys = [] + for k in hm.dct.keys(): keys.append(MalStr(k)) + return MalList(keys) + +def vals(args): + hm = args[0] + return MalList(hm.dct.values()) + + +# Sequence functions +def do_list(ml): + return ml + +def list_Q(args): + return wrap_tf(types._list_Q(args[0])) + +def do_vector(ml): + return MalVector(ml.values) + +def vector_Q(args): + return wrap_tf(types._vector_Q(args[0])) + +def empty_Q(args): + seq = args[0] + if isinstance(seq, MalList): + return wrap_tf(len(seq) == 0) + elif seq is nil: + return true + else: + throw_str("empty? called on non-sequence") + +def count(args): + seq = args[0] + if isinstance(seq, MalList): + return MalInt(len(seq)) + elif seq is nil: + return MalInt(0) + else: + throw_str("count called on non-sequence") + +def sequential_Q(args): + return wrap_tf(types._sequential_Q(args[0])) + +def vec(args): + seq = args[0] + if isinstance(seq, MalList): + return MalVector(seq.values) + else: + throw_str("vec called on non-sequence") + +def cons(args): + x, seq = args[0], args[1] + if not isinstance(seq, MalList): + throw_str("cons called with non-list/non-vector") + return MalList([x] + seq.values) + +def concat(args): + new_lst = [] + for l in args.values: + if not isinstance(l, MalList): + throw_str("concat called with non-list/non-vector") + new_lst = new_lst + l.values + return MalList(new_lst) + +def nth(args): + lst, idx = args[0], args[1] + if not isinstance(lst, MalList): + throw_str("nth called with non-list/non-vector") + if not isinstance(idx, MalInt): + throw_str("nth called with non-int index") + if idx.value < len(lst): return lst[idx.value] + else: throw_str("nth: index out of range") + +def first(args): + a0 = args[0] + if a0 is nil: + return nil + elif not isinstance(a0, MalList): + throw_str("first called with non-list/non-vector") + if len(a0) == 0: return nil + else: return a0[0] + +def rest(args): + a0 = args[0] + if a0 is nil: + return MalList([]) + elif not isinstance(a0, MalList): + throw_str("rest called with non-list/non-vector") + if len(a0) == 0: return MalList([]) + else: return a0.rest() + +def apply(args): + f, fargs = args[0], args.rest() + last_arg = fargs.values[-1] + if not isinstance(last_arg, MalList): + throw_str("map called with non-list") + all_args = fargs.values[0:-1] + last_arg.values + return f.apply(MalList(all_args)) + +def mapf(args): + f, lst = args[0], args[1] + if not isinstance(lst, MalList): + throw_str("map called with non-list") + res = [] + for a in lst.values: + res.append(f.apply(MalList([a]))) + return MalList(res) + +# retains metadata +def conj(args): + lst, args = args[0], args.rest() + new_lst = None + if types._list_Q(lst): + vals = args.values[:] + vals.reverse() + new_lst = MalList(vals + lst.values) + elif types._vector_Q(lst): + new_lst = MalVector(lst.values + list(args.values)) + else: + throw_str("conj on non-list/non-vector") + new_lst.meta = lst.meta + return new_lst + +def seq(args): + a0 = args[0] + if isinstance(a0, MalVector): + if len(a0) == 0: return nil + return MalList(a0.values) + elif isinstance(a0, MalList): + if len(a0) == 0: return nil + return a0 + elif types._string_Q(a0): + assert isinstance(a0, MalStr) + if len(a0) == 0: return nil + return MalList([MalStr(unicode(c)) for c in a0.value]) + elif a0 is nil: + return nil + else: + throw_str("seq: called on non-sequence") + +# Metadata functions +def with_meta(args): + obj, meta = args[0], args[1] + if isinstance(obj, MalMeta): + new_obj = types._clone(obj) + new_obj.meta = meta + return new_obj + else: + throw_str("with-meta not supported on type") + +def meta(args): + obj = args[0] + if isinstance(obj, MalMeta): + return obj.meta + else: + throw_str("meta not supported on type") + + +# Atoms functions +def do_atom(args): + return MalAtom(args[0]) +def atom_Q(args): + return wrap_tf(types._atom_Q(args[0])) +def deref(args): + atm = args[0] + if not isinstance(atm, MalAtom): + throw_str("deref called on non-atom") + return atm.value +def reset_BANG(args): + atm, val = args[0], args[1] + if not isinstance(atm, MalAtom): + throw_str("reset! called on non-atom") + atm.value = val + return atm.value +def swap_BANG(args): + atm, f, fargs = args[0], args[1], args.slice(2) + if not isinstance(atm, MalAtom): + throw_str("swap! called on non-atom") + if not isinstance(f, MalFunc): + throw_str("swap! called with non-function") + all_args = [atm.value] + fargs.values + atm.value = f.apply(MalList(all_args)) + return atm.value + + +ns = { + '=': do_equal, + 'throw': throw, + 'nil?': nil_Q, + 'true?': true_Q, + 'false?': false_Q, + 'string?': string_Q, + 'symbol': symbol, + 'symbol?': symbol_Q, + 'keyword': keyword, + 'keyword?': keyword_Q, + 'number?': number_Q, + 'fn?': function_Q, + 'macro?': macro_Q, + + 'pr-str': pr_str, + 'str': do_str, + 'prn': prn, + 'println': println, + 'readline': do_readline, + 'read-string': read_str, + 'slurp': slurp, + '<': lt, + '<=': lte, + '>': gt, + '>=': gte, + '+': plus, + '-': minus, + '*': multiply, + '/': divide, + 'time-ms': time_ms, + + 'list': do_list, + 'list?': list_Q, + 'vector': do_vector, + 'vector?': vector_Q, + 'hash-map': do_hash_map, + 'map?': hash_map_Q, + 'assoc': assoc, + 'dissoc': dissoc, + 'get': get, + 'contains?': contains_Q, + 'keys': keys, + 'vals': vals, + + 'sequential?': sequential_Q, + 'vec': vec, + 'cons': cons, + 'concat': concat, + 'nth': nth, + 'first': first, + 'rest': rest, + 'empty?': empty_Q, + 'count': count, + 'apply': apply, + 'map': mapf, + + 'conj': conj, + 'seq': seq, + + 'with-meta': with_meta, + 'meta': meta, + 'atom': do_atom, + 'atom?': atom_Q, + 'deref': deref, + 'reset!': reset_BANG, + 'swap!': swap_BANG + } + diff --git a/impls/rpython/env.py b/impls/rpython/env.py index 258874623f..75d1d6f437 100644 --- a/impls/rpython/env.py +++ b/impls/rpython/env.py @@ -1,40 +1,40 @@ -from mal_types import MalType, MalSym, MalList, throw_str - -# Environment -class Env(): - def __init__(self, outer=None, binds=None, exprs=None): - self.data = {} - self.outer = outer or None - - if binds: - assert isinstance(binds, MalList) and isinstance(exprs, MalList) - for i in range(len(binds)): - bind = binds[i] - if not isinstance(bind, MalSym): - throw_str("env bind value is not a symbol") - if bind.value == u"&": - bind = binds[i+1] - if not isinstance(bind, MalSym): - throw_str("env bind value is not a symbol") - self.data[bind.value] = exprs.slice(i) - break - else: - self.data[bind.value] = exprs[i] - - def find(self, key): - assert isinstance(key, MalSym) - if key.value in self.data: return self - elif self.outer: return self.outer.find(key) - else: return None - - def set(self, key, value): - assert isinstance(key, MalSym) - assert isinstance(value, MalType) - self.data[key.value] = value - return value - - def get(self, key): - assert isinstance(key, MalSym) - env = self.find(key) - if not env: throw_str("'" + str(key.value) + "' not found") - return env.data[key.value] +from mal_types import MalType, MalSym, MalList, throw_str + +# Environment +class Env(): + def __init__(self, outer=None, binds=None, exprs=None): + self.data = {} + self.outer = outer or None + + if binds: + assert isinstance(binds, MalList) and isinstance(exprs, MalList) + for i in range(len(binds)): + bind = binds[i] + if not isinstance(bind, MalSym): + throw_str("env bind value is not a symbol") + if bind.value == u"&": + bind = binds[i+1] + if not isinstance(bind, MalSym): + throw_str("env bind value is not a symbol") + self.data[bind.value] = exprs.slice(i) + break + else: + self.data[bind.value] = exprs[i] + + def find(self, key): + assert isinstance(key, MalSym) + if key.value in self.data: return self + elif self.outer: return self.outer.find(key) + else: return None + + def set(self, key, value): + assert isinstance(key, MalSym) + assert isinstance(value, MalType) + self.data[key.value] = value + return value + + def get(self, key): + assert isinstance(key, MalSym) + env = self.find(key) + if not env: throw_str("'" + str(key.value) + "' not found") + return env.data[key.value] diff --git a/impls/rpython/mal_readline.py b/impls/rpython/mal_readline.py index 1502fce367..93649ee2bc 100644 --- a/impls/rpython/mal_readline.py +++ b/impls/rpython/mal_readline.py @@ -1,36 +1,36 @@ -#import os, readline as pyreadline -# -#histfile = os.path.expanduser("~/.mal-history") -# -#def init(): -# try: -# with open(histfile, "r") as hf: -# for line in hf.readlines(): -# pyreadline.add_history(line.rstrip("\r\n")) -# pass -# except IOError: -# #print("Could not open %s" % histfile) -# pass -# -#def readline(prompt="user> "): -# try: -# line = raw_input(prompt) -# pyreadline.add_history(line) -# with open(histfile, "a") as hf: -# hf.write(line + "\n") -# except IOError: -# pass -# except EOFError: -# return None -# return line - -import os -def readline(prompt): - res = '' - os.write(1, prompt) - while True: - buf = os.read(0, 255) - if not buf: raise EOFError() - res += buf - if res[-1] == '\n': return res[:-1] - +#import os, readline as pyreadline +# +#histfile = os.path.expanduser("~/.mal-history") +# +#def init(): +# try: +# with open(histfile, "r") as hf: +# for line in hf.readlines(): +# pyreadline.add_history(line.rstrip("\r\n")) +# pass +# except IOError: +# #print("Could not open %s" % histfile) +# pass +# +#def readline(prompt="user> "): +# try: +# line = raw_input(prompt) +# pyreadline.add_history(line) +# with open(histfile, "a") as hf: +# hf.write(line + "\n") +# except IOError: +# pass +# except EOFError: +# return None +# return line + +import os +def readline(prompt): + res = '' + os.write(1, prompt) + while True: + buf = os.read(0, 255) + if not buf: raise EOFError() + res += buf + if res[-1] == '\n': return res[:-1] + diff --git a/impls/rpython/mal_types.py b/impls/rpython/mal_types.py index 20d626d751..84a1f948e3 100644 --- a/impls/rpython/mal_types.py +++ b/impls/rpython/mal_types.py @@ -1,273 +1,273 @@ -import sys, copy, types as pytypes -IS_RPYTHON = sys.argv[0].endswith('rpython') - -if IS_RPYTHON: - from rpython.rlib.listsort import TimSort -else: - import re - -# General functions - -class StringSort(TimSort): - def lt(self, a, b): - assert isinstance(a, unicode) - assert isinstance(b, unicode) - return a < b - -def _equal_Q(a, b): - assert isinstance(a, MalType) and isinstance(b, MalType) - ota, otb = a.__class__, b.__class__ - if not (ota is otb or (_sequential_Q(a) and _sequential_Q(b))): - return False - if isinstance(a, MalSym) and isinstance(b, MalSym): - return a.value == b.value - elif isinstance(a, MalStr) and isinstance(b, MalStr): - return a.value == b.value - elif isinstance(a, MalInt) and isinstance(b, MalInt): - return a.value == b.value - elif _list_Q(a) or _vector_Q(a): - if len(a) != len(b): return False - for i in range(len(a)): - if not _equal_Q(a[i], b[i]): return False - return True - elif _hash_map_Q(a): - assert isinstance(a, MalHashMap) - assert isinstance(b, MalHashMap) - akeys = a.dct.keys() - bkeys = b.dct.keys() - if len(akeys) != len(bkeys): return False - - StringSort(akeys).sort() - StringSort(bkeys).sort() - for i in range(len(akeys)): - ak, bk = akeys[i], bkeys[i] - assert isinstance(ak, unicode) - assert isinstance(bk, unicode) - if ak != bk: return False - av, bv = a.dct[ak], b.dct[bk] - if not _equal_Q(av, bv): return False - return True - elif a is b: - return True - else: - throw_str("no = op defined for %s" % a.__class__.__name__) - -def _sequential_Q(seq): return _list_Q(seq) or _vector_Q(seq) - -def _clone(obj): - if isinstance(obj, MalFunc): - return MalFunc(obj.fn, obj.ast, obj.env, obj.params, - obj.EvalFunc, obj.ismacro) - elif isinstance(obj, MalList): - return obj.__class__(obj.values) - elif isinstance(obj, MalHashMap): - return MalHashMap(obj.dct) - elif isinstance(obj, MalAtom): - return MalAtom(obj.value) - else: - raise Exception("_clone on invalid type") - -def _replace(match, sub, old_str): - new_str = u"" - idx = 0 - while idx < len(old_str): - midx = old_str.find(match, idx) - if midx < 0: break - assert midx >= 0 and midx < len(old_str) - new_str = new_str + old_str[idx:midx] - new_str = new_str + sub - idx = midx + len(match) - new_str = new_str + old_str[idx:] - return new_str - -# -# Mal Types -# - -class MalException(Exception): - def __init__(self, object): - self.object = object - -def throw_str(s): - raise MalException(MalStr(unicode(s))) - - -### Parent types -class MalType(): pass -class MalMeta(MalType): pass - -### Scalars -class MalNil(MalType): pass -nil = MalNil() -def _nil_Q(exp): - assert isinstance(exp, MalType) - return exp is nil - -class MalTrue(MalType): pass -true = MalTrue() -def _true_Q(exp): - assert isinstance(exp, MalType) - return exp is true - -class MalFalse(MalType): pass -false = MalFalse() -def _false_Q(exp): - assert isinstance(exp, MalType) - return exp is false - -# Numbers -class MalInt(MalType): - def __init__(self, value): - assert isinstance(value, int) - self.value = value -def _int_Q(exp): - assert isinstance(exp, MalType) - return exp.__class__ is MalInt - -# String -class MalStr(MalType): - def __init__(self, value): - assert isinstance(value, unicode) - self.value = value - def __len__(self): - return len(self.value) -def _string_Q(exp): - assert isinstance(exp, MalType) - return exp.__class__ is MalStr and not _keyword_Q(exp) - -# Keywords -# A specially prefixed string -def _keyword(mstr): - assert isinstance(mstr, MalType) - if isinstance(mstr, MalStr): - val = mstr.value - if val[0] == u"\u029e": return mstr - else: return MalStr(u"\u029e" + val) - else: - throw_str("_keyword called on non-string") -# Create keyword from unicode string -def _keywordu(strn): - assert isinstance(strn, unicode) - return MalStr(u"\u029e" + strn) -def _keyword_Q(exp): - if isinstance(exp, MalStr) and len(exp.value) > 0: - return exp.value[0] == u"\u029e" - else: - return False - -# Symbols -class MalSym(MalMeta): - def __init__(self, value): - assert isinstance(value, unicode) - self.value = value - self.meta = nil -def _symbol(strn): - assert isinstance(strn, unicode) - return MalSym(strn) -def _symbol_Q(exp): - assert isinstance(exp, MalType) - return exp.__class__ is MalSym - -# lists -class MalList(MalMeta): - def __init__(self, vals): - assert isinstance(vals, list) - self.values = vals - self.meta = nil - def append(self, val): - self.values.append(val) - def rest(self): - return MalList(self.values[1:]) - def __len__(self): - return len(self.values) - def __getitem__(self, i): - assert isinstance(i, int) - return self.values[i] - def slice(self, start): - return MalList(self.values[start:len(self.values)]) - def slice2(self, start, end): - assert end >= 0 - return MalList(self.values[start:end]) -def _list(*vals): return MalList(list(vals)) -def _listl(lst): return MalList(lst) -def _list_Q(exp): - assert isinstance(exp, MalType) - return exp.__class__ is MalList - -### vectors -class MalVector(MalList): - pass -def _vector(*vals): return MalVector(list(vals)) -def _vectorl(lst): return MalVector(lst) -def _vector_Q(exp): - assert isinstance(exp, MalType) - return exp.__class__ is MalVector - -### hash maps -class MalHashMap(MalMeta): - def __init__(self, dct): - self.dct = dct - self.meta = nil - def append(self, val): - self.dct.append(val) - def __getitem__(self, k): - assert isinstance(k, unicode) - if not isinstance(k, unicode): - throw_str("hash-map lookup by non-string/non-keyword") - return self.dct[k] - def __setitem__(self, k, v): - if not isinstance(k, unicode): - throw_str("hash-map key must be string or keyword") - assert isinstance(v, MalType) - self.dct[k] = v - return v -def _hash_mapl(kvs): - dct = {} - for i in range(0, len(kvs), 2): - k = kvs[i] - if not isinstance(k, MalStr): - throw_str("hash-map key must be string or keyword") - v = kvs[i+1] - dct[k.value] = v - return MalHashMap(dct) -def _hash_map_Q(exp): - assert isinstance(exp, MalType) - return exp.__class__ is MalHashMap - -# Functions -# env import must happen after MalSym and MalList definitions to allow -# circular dependency -from env import Env -class MalFunc(MalMeta): - def __init__(self, fn, ast=None, env=None, params=None, - EvalFunc=None, ismacro=False): - if fn is None and EvalFunc is None: - throw_str("MalFunc requires either fn or EvalFunc") - self.fn = fn - self.ast = ast - self.env = env - self.params = params - self.EvalFunc = EvalFunc - self.ismacro = ismacro - self.meta = nil - def apply(self, args): - if self.EvalFunc: - return self.EvalFunc(self.ast, self.gen_env(args)) - else: - return self.fn(args) - def gen_env(self, args): - return Env(self.env, self.params, args) -def _function_Q(exp): - assert isinstance(exp, MalType) - return exp.__class__ is MalFunc - - -# atoms -class MalAtom(MalMeta): - def __init__(self, value): - self.value = value - self.meta = nil - def get_value(self): - return self.value -def _atom(val): return MalAtom(val) -def _atom_Q(exp): return exp.__class__ is MalAtom +import sys, copy, types as pytypes +IS_RPYTHON = sys.argv[0].endswith('rpython') + +if IS_RPYTHON: + from rpython.rlib.listsort import TimSort +else: + import re + +# General functions + +class StringSort(TimSort): + def lt(self, a, b): + assert isinstance(a, unicode) + assert isinstance(b, unicode) + return a < b + +def _equal_Q(a, b): + assert isinstance(a, MalType) and isinstance(b, MalType) + ota, otb = a.__class__, b.__class__ + if not (ota is otb or (_sequential_Q(a) and _sequential_Q(b))): + return False + if isinstance(a, MalSym) and isinstance(b, MalSym): + return a.value == b.value + elif isinstance(a, MalStr) and isinstance(b, MalStr): + return a.value == b.value + elif isinstance(a, MalInt) and isinstance(b, MalInt): + return a.value == b.value + elif _list_Q(a) or _vector_Q(a): + if len(a) != len(b): return False + for i in range(len(a)): + if not _equal_Q(a[i], b[i]): return False + return True + elif _hash_map_Q(a): + assert isinstance(a, MalHashMap) + assert isinstance(b, MalHashMap) + akeys = a.dct.keys() + bkeys = b.dct.keys() + if len(akeys) != len(bkeys): return False + + StringSort(akeys).sort() + StringSort(bkeys).sort() + for i in range(len(akeys)): + ak, bk = akeys[i], bkeys[i] + assert isinstance(ak, unicode) + assert isinstance(bk, unicode) + if ak != bk: return False + av, bv = a.dct[ak], b.dct[bk] + if not _equal_Q(av, bv): return False + return True + elif a is b: + return True + else: + throw_str("no = op defined for %s" % a.__class__.__name__) + +def _sequential_Q(seq): return _list_Q(seq) or _vector_Q(seq) + +def _clone(obj): + if isinstance(obj, MalFunc): + return MalFunc(obj.fn, obj.ast, obj.env, obj.params, + obj.EvalFunc, obj.ismacro) + elif isinstance(obj, MalList): + return obj.__class__(obj.values) + elif isinstance(obj, MalHashMap): + return MalHashMap(obj.dct) + elif isinstance(obj, MalAtom): + return MalAtom(obj.value) + else: + raise Exception("_clone on invalid type") + +def _replace(match, sub, old_str): + new_str = u"" + idx = 0 + while idx < len(old_str): + midx = old_str.find(match, idx) + if midx < 0: break + assert midx >= 0 and midx < len(old_str) + new_str = new_str + old_str[idx:midx] + new_str = new_str + sub + idx = midx + len(match) + new_str = new_str + old_str[idx:] + return new_str + +# +# Mal Types +# + +class MalException(Exception): + def __init__(self, object): + self.object = object + +def throw_str(s): + raise MalException(MalStr(unicode(s))) + + +### Parent types +class MalType(): pass +class MalMeta(MalType): pass + +### Scalars +class MalNil(MalType): pass +nil = MalNil() +def _nil_Q(exp): + assert isinstance(exp, MalType) + return exp is nil + +class MalTrue(MalType): pass +true = MalTrue() +def _true_Q(exp): + assert isinstance(exp, MalType) + return exp is true + +class MalFalse(MalType): pass +false = MalFalse() +def _false_Q(exp): + assert isinstance(exp, MalType) + return exp is false + +# Numbers +class MalInt(MalType): + def __init__(self, value): + assert isinstance(value, int) + self.value = value +def _int_Q(exp): + assert isinstance(exp, MalType) + return exp.__class__ is MalInt + +# String +class MalStr(MalType): + def __init__(self, value): + assert isinstance(value, unicode) + self.value = value + def __len__(self): + return len(self.value) +def _string_Q(exp): + assert isinstance(exp, MalType) + return exp.__class__ is MalStr and not _keyword_Q(exp) + +# Keywords +# A specially prefixed string +def _keyword(mstr): + assert isinstance(mstr, MalType) + if isinstance(mstr, MalStr): + val = mstr.value + if val[0] == u"\u029e": return mstr + else: return MalStr(u"\u029e" + val) + else: + throw_str("_keyword called on non-string") +# Create keyword from unicode string +def _keywordu(strn): + assert isinstance(strn, unicode) + return MalStr(u"\u029e" + strn) +def _keyword_Q(exp): + if isinstance(exp, MalStr) and len(exp.value) > 0: + return exp.value[0] == u"\u029e" + else: + return False + +# Symbols +class MalSym(MalMeta): + def __init__(self, value): + assert isinstance(value, unicode) + self.value = value + self.meta = nil +def _symbol(strn): + assert isinstance(strn, unicode) + return MalSym(strn) +def _symbol_Q(exp): + assert isinstance(exp, MalType) + return exp.__class__ is MalSym + +# lists +class MalList(MalMeta): + def __init__(self, vals): + assert isinstance(vals, list) + self.values = vals + self.meta = nil + def append(self, val): + self.values.append(val) + def rest(self): + return MalList(self.values[1:]) + def __len__(self): + return len(self.values) + def __getitem__(self, i): + assert isinstance(i, int) + return self.values[i] + def slice(self, start): + return MalList(self.values[start:len(self.values)]) + def slice2(self, start, end): + assert end >= 0 + return MalList(self.values[start:end]) +def _list(*vals): return MalList(list(vals)) +def _listl(lst): return MalList(lst) +def _list_Q(exp): + assert isinstance(exp, MalType) + return exp.__class__ is MalList + +### vectors +class MalVector(MalList): + pass +def _vector(*vals): return MalVector(list(vals)) +def _vectorl(lst): return MalVector(lst) +def _vector_Q(exp): + assert isinstance(exp, MalType) + return exp.__class__ is MalVector + +### hash maps +class MalHashMap(MalMeta): + def __init__(self, dct): + self.dct = dct + self.meta = nil + def append(self, val): + self.dct.append(val) + def __getitem__(self, k): + assert isinstance(k, unicode) + if not isinstance(k, unicode): + throw_str("hash-map lookup by non-string/non-keyword") + return self.dct[k] + def __setitem__(self, k, v): + if not isinstance(k, unicode): + throw_str("hash-map key must be string or keyword") + assert isinstance(v, MalType) + self.dct[k] = v + return v +def _hash_mapl(kvs): + dct = {} + for i in range(0, len(kvs), 2): + k = kvs[i] + if not isinstance(k, MalStr): + throw_str("hash-map key must be string or keyword") + v = kvs[i+1] + dct[k.value] = v + return MalHashMap(dct) +def _hash_map_Q(exp): + assert isinstance(exp, MalType) + return exp.__class__ is MalHashMap + +# Functions +# env import must happen after MalSym and MalList definitions to allow +# circular dependency +from env import Env +class MalFunc(MalMeta): + def __init__(self, fn, ast=None, env=None, params=None, + EvalFunc=None, ismacro=False): + if fn is None and EvalFunc is None: + throw_str("MalFunc requires either fn or EvalFunc") + self.fn = fn + self.ast = ast + self.env = env + self.params = params + self.EvalFunc = EvalFunc + self.ismacro = ismacro + self.meta = nil + def apply(self, args): + if self.EvalFunc: + return self.EvalFunc(self.ast, self.gen_env(args)) + else: + return self.fn(args) + def gen_env(self, args): + return Env(self.env, self.params, args) +def _function_Q(exp): + assert isinstance(exp, MalType) + return exp.__class__ is MalFunc + + +# atoms +class MalAtom(MalMeta): + def __init__(self, value): + self.value = value + self.meta = nil + def get_value(self): + return self.value +def _atom(val): return MalAtom(val) +def _atom_Q(exp): return exp.__class__ is MalAtom diff --git a/impls/rpython/printer.py b/impls/rpython/printer.py index 67b607b9da..9472d0ee9b 100644 --- a/impls/rpython/printer.py +++ b/impls/rpython/printer.py @@ -1,60 +1,60 @@ -import sys -IS_RPYTHON = sys.argv[0].endswith('rpython') - -if IS_RPYTHON: - from rpython.rlib.rsre import rsre_re as re -else: - import re - -import mal_types as types -from mal_types import (MalType, MalStr, MalSym, MalInt, - nil, true, false, MalAtom, MalFunc) - -def _pr_a_str(s, print_readably=True): - if len(s) > 0 and s[0] == u'\u029e': - return u':' + s[1:] - elif print_readably: - return u'"' + types._replace(u'\n', u'\\n', - types._replace(u'\"', u'\\"', - types._replace(u'\\', u'\\\\', s))) + u'"' - else: - return s - -def _pr_str(obj, print_readably=True): - assert isinstance(obj, MalType) - _r = print_readably - if types._list_Q(obj): - res = [] - for e in obj.values: - res.append(_pr_str(e,_r)) - return u"(" + u" ".join(res) + u")" - elif types._vector_Q(obj): - res = [] - for e in obj.values: - res.append(_pr_str(e,_r)) - return u"[" + u" ".join(res) + u"]" - elif types._hash_map_Q(obj): - ret = [] - for k in obj.dct.keys(): - ret.append(_pr_a_str(k,_r)) - ret.append(_pr_str(obj.dct[k],_r)) - return u"{" + u" ".join(ret) + u"}" - elif isinstance(obj, MalStr): - return _pr_a_str(obj.value,_r) - elif obj is nil: - return u"nil" - elif obj is true: - return u"true" - elif obj is false: - return u"false" - elif types._atom_Q(obj): - return u"(atom " + _pr_str(obj.get_value(),_r) + u")" - elif isinstance(obj, MalSym): - return obj.value - elif isinstance(obj, MalInt): - return unicode(str(obj.value)) - elif isinstance(obj, MalFunc): - return u"#" - else: - return u"unknown" - +import sys +IS_RPYTHON = sys.argv[0].endswith('rpython') + +if IS_RPYTHON: + from rpython.rlib.rsre import rsre_re as re +else: + import re + +import mal_types as types +from mal_types import (MalType, MalStr, MalSym, MalInt, + nil, true, false, MalAtom, MalFunc) + +def _pr_a_str(s, print_readably=True): + if len(s) > 0 and s[0] == u'\u029e': + return u':' + s[1:] + elif print_readably: + return u'"' + types._replace(u'\n', u'\\n', + types._replace(u'\"', u'\\"', + types._replace(u'\\', u'\\\\', s))) + u'"' + else: + return s + +def _pr_str(obj, print_readably=True): + assert isinstance(obj, MalType) + _r = print_readably + if types._list_Q(obj): + res = [] + for e in obj.values: + res.append(_pr_str(e,_r)) + return u"(" + u" ".join(res) + u")" + elif types._vector_Q(obj): + res = [] + for e in obj.values: + res.append(_pr_str(e,_r)) + return u"[" + u" ".join(res) + u"]" + elif types._hash_map_Q(obj): + ret = [] + for k in obj.dct.keys(): + ret.append(_pr_a_str(k,_r)) + ret.append(_pr_str(obj.dct[k],_r)) + return u"{" + u" ".join(ret) + u"}" + elif isinstance(obj, MalStr): + return _pr_a_str(obj.value,_r) + elif obj is nil: + return u"nil" + elif obj is true: + return u"true" + elif obj is false: + return u"false" + elif types._atom_Q(obj): + return u"(atom " + _pr_str(obj.get_value(),_r) + u")" + elif isinstance(obj, MalSym): + return obj.value + elif isinstance(obj, MalInt): + return unicode(str(obj.value)) + elif isinstance(obj, MalFunc): + return u"#" + else: + return u"unknown" + diff --git a/impls/rpython/reader.py b/impls/rpython/reader.py index 6fd81c595e..8869423ec9 100644 --- a/impls/rpython/reader.py +++ b/impls/rpython/reader.py @@ -1,138 +1,138 @@ -import sys -IS_RPYTHON = sys.argv[0].endswith('rpython') - -if IS_RPYTHON: - from rpython.rlib.rsre import rsre_re as re -else: - import re - -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, _keywordu, - _list, _listl, _vectorl, _hash_mapl) - -class Blank(Exception): pass - -class Reader(): - def __init__(self, tokens, position=0): - self.tokens = tokens - self.position = position - - def next(self): - self.position += 1 - return self.tokens[self.position-1] - - def peek(self): - if len(self.tokens) > self.position: - return self.tokens[self.position] - else: - return None - -def tokenize(str): - re_str = "[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\s\[\]{}()'\"`@,;]+)" - if IS_RPYTHON: - tok_re = re_str - else: - tok_re = re.compile(re_str) - return [t for t in re.findall(tok_re, str) if t[0] != ';'] - -def read_atom(reader): - if IS_RPYTHON: - int_re = '-?[0-9]+$' - float_re = '-?[0-9][0-9.]*$' - str_re = '"(?:[\\\\].|[^\\\\"])*"' - else: - int_re = re.compile('-?[0-9]+$') - float_re = re.compile('-?[0-9][0-9.]*$') - str_re = re.compile('"(?:[\\\\].|[^\\\\"])*"') - token = reader.next() - if re.match(int_re, token): return MalInt(int(token)) -## elif re.match(float_re, token): return int(token) - elif re.match(str_re, token): - end = len(token)-1 - if end <= 1: - return MalStr(u"") - else: - s = unicode(token[1:end]) - s = types._replace(u'\\\\', u"\u029e", s) - s = types._replace(u'\\"', u'"', s) - s = types._replace(u'\\n', u"\n", s) - s = types._replace(u"\u029e", u"\\", s) - return MalStr(s) - elif token[0] == '"': - types.throw_str("expected '\"', got EOF") - elif token[0] == ':': return _keywordu(unicode(token[1:])) - elif token == "nil": return types.nil - elif token == "true": return types.true - elif token == "false": return types.false - else: return MalSym(unicode(token)) - -def read_sequence(reader, start='(', end=')'): - ast = [] - token = reader.next() - if token != start: types.throw_str("expected '" + start + "'") - - token = reader.peek() - while token != end: - if not token: types.throw_str("expected '" + end + "', got EOF") - ast.append(read_form(reader)) - token = reader.peek() - reader.next() - return ast - -def read_list(reader): - lst = read_sequence(reader, '(', ')') - return _listl(lst) - -def read_vector(reader): - lst = read_sequence(reader, '[', ']') - return _vectorl(lst) - -def read_hash_map(reader): - lst = read_sequence(reader, '{', '}') - return _hash_mapl(lst) - -def read_form(reader): - token = reader.peek() - # reader macros/transforms - if token[0] == ';': - reader.next() - return None - elif token == '\'': - reader.next() - return _list(MalSym(u'quote'), read_form(reader)) - elif token == '`': - reader.next() - return _list(MalSym(u'quasiquote'), read_form(reader)) - elif token == '~': - reader.next() - return _list(MalSym(u'unquote'), read_form(reader)) - elif token == '~@': - reader.next() - return _list(MalSym(u'splice-unquote'), read_form(reader)) - elif token == '^': - reader.next() - meta = read_form(reader) - return _list(MalSym(u'with-meta'), read_form(reader), meta) - elif token == '@': - reader.next() - return _list(MalSym(u'deref'), read_form(reader)) - - # list - elif token == ')': types.throw_str("unexpected ')'") - elif token == '(': return read_list(reader) - - # vector - elif token == ']': types.throw_str("unexpected ']'"); - elif token == '[': return read_vector(reader); - - # hash-map - elif token == '}': types.throw_str("unexpected '}'"); - elif token == '{': return read_hash_map(reader); - - # atom - else: return read_atom(reader); - -def read_str(str): - tokens = tokenize(str) - if len(tokens) == 0: raise Blank("Blank Line") - return read_form(Reader(tokens)) +import sys +IS_RPYTHON = sys.argv[0].endswith('rpython') + +if IS_RPYTHON: + from rpython.rlib.rsre import rsre_re as re +else: + import re + +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, _keywordu, + _list, _listl, _vectorl, _hash_mapl) + +class Blank(Exception): pass + +class Reader(): + def __init__(self, tokens, position=0): + self.tokens = tokens + self.position = position + + def next(self): + self.position += 1 + return self.tokens[self.position-1] + + def peek(self): + if len(self.tokens) > self.position: + return self.tokens[self.position] + else: + return None + +def tokenize(str): + re_str = "[\s,]*(~@|[\[\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\s\[\]{}()'\"`@,;]+)" + if IS_RPYTHON: + tok_re = re_str + else: + tok_re = re.compile(re_str) + return [t for t in re.findall(tok_re, str) if t[0] != ';'] + +def read_atom(reader): + if IS_RPYTHON: + int_re = '-?[0-9]+$' + float_re = '-?[0-9][0-9.]*$' + str_re = '"(?:[\\\\].|[^\\\\"])*"' + else: + int_re = re.compile('-?[0-9]+$') + float_re = re.compile('-?[0-9][0-9.]*$') + str_re = re.compile('"(?:[\\\\].|[^\\\\"])*"') + token = reader.next() + if re.match(int_re, token): return MalInt(int(token)) +## elif re.match(float_re, token): return int(token) + elif re.match(str_re, token): + end = len(token)-1 + if end <= 1: + return MalStr(u"") + else: + s = unicode(token[1:end]) + s = types._replace(u'\\\\', u"\u029e", s) + s = types._replace(u'\\"', u'"', s) + s = types._replace(u'\\n', u"\n", s) + s = types._replace(u"\u029e", u"\\", s) + return MalStr(s) + elif token[0] == '"': + types.throw_str("expected '\"', got EOF") + elif token[0] == ':': return _keywordu(unicode(token[1:])) + elif token == "nil": return types.nil + elif token == "true": return types.true + elif token == "false": return types.false + else: return MalSym(unicode(token)) + +def read_sequence(reader, start='(', end=')'): + ast = [] + token = reader.next() + if token != start: types.throw_str("expected '" + start + "'") + + token = reader.peek() + while token != end: + if not token: types.throw_str("expected '" + end + "', got EOF") + ast.append(read_form(reader)) + token = reader.peek() + reader.next() + return ast + +def read_list(reader): + lst = read_sequence(reader, '(', ')') + return _listl(lst) + +def read_vector(reader): + lst = read_sequence(reader, '[', ']') + return _vectorl(lst) + +def read_hash_map(reader): + lst = read_sequence(reader, '{', '}') + return _hash_mapl(lst) + +def read_form(reader): + token = reader.peek() + # reader macros/transforms + if token[0] == ';': + reader.next() + return None + elif token == '\'': + reader.next() + return _list(MalSym(u'quote'), read_form(reader)) + elif token == '`': + reader.next() + return _list(MalSym(u'quasiquote'), read_form(reader)) + elif token == '~': + reader.next() + return _list(MalSym(u'unquote'), read_form(reader)) + elif token == '~@': + reader.next() + return _list(MalSym(u'splice-unquote'), read_form(reader)) + elif token == '^': + reader.next() + meta = read_form(reader) + return _list(MalSym(u'with-meta'), read_form(reader), meta) + elif token == '@': + reader.next() + return _list(MalSym(u'deref'), read_form(reader)) + + # list + elif token == ')': types.throw_str("unexpected ')'") + elif token == '(': return read_list(reader) + + # vector + elif token == ']': types.throw_str("unexpected ']'"); + elif token == '[': return read_vector(reader); + + # hash-map + elif token == '}': types.throw_str("unexpected '}'"); + elif token == '{': return read_hash_map(reader); + + # atom + else: return read_atom(reader); + +def read_str(str): + tokens = tokenize(str) + if len(tokens) == 0: raise Blank("Blank Line") + return read_form(Reader(tokens)) diff --git a/impls/rpython/run b/impls/rpython/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/rpython/run +++ b/impls/rpython/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/rpython/step0_repl.py b/impls/rpython/step0_repl.py index 1a6ef4be9e..c72a30915e 100644 --- a/impls/rpython/step0_repl.py +++ b/impls/rpython/step0_repl.py @@ -1,42 +1,42 @@ -#import sys, traceback -import mal_readline - -# read -def READ(str): - return str - -# eval -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - return ast - -# print -def PRINT(exp): - return exp - -# repl -def REP(str): - return PRINT(EVAL(READ(str), {})) - -def entry_point(argv): - #mal_readline.init() - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line)) - except EOFError as e: - break - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +#import sys, traceback +import mal_readline + +# read +def READ(str): + return str + +# eval +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + return ast + +# print +def PRINT(exp): + return exp + +# repl +def REP(str): + return PRINT(EVAL(READ(str), {})) + +def entry_point(argv): + #mal_readline.init() + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line)) + except EOFError as e: + break + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/step1_read_print.py b/impls/rpython/step1_read_print.py index fe39fd07fc..92e267e686 100644 --- a/impls/rpython/step1_read_print.py +++ b/impls/rpython/step1_read_print.py @@ -1,48 +1,48 @@ -#import sys, traceback -import mal_readline -import mal_types as types -import reader, printer - -# read -def READ(str): - return reader.read_str(str) - -# eval -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - return ast - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -def REP(str): - return PRINT(EVAL(READ(str), {})) - -def entry_point(argv): - #mal_readline.init() - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +#import sys, traceback +import mal_readline +import mal_types as types +import reader, printer + +# read +def READ(str): + return reader.read_str(str) + +# eval +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + return ast + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +def REP(str): + return PRINT(EVAL(READ(str), {})) + +def entry_point(argv): + #mal_readline.init() + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/step2_eval.py b/impls/rpython/step2_eval.py index 82d71c882d..c56043ffc4 100644 --- a/impls/rpython/step2_eval.py +++ b/impls/rpython/step2_eval.py @@ -1,111 +1,111 @@ -#import sys, traceback -import mal_readline -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, - _keywordu, - MalList, _list, MalVector, MalHashMap, MalFunc) -import reader, printer - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - assert isinstance(ast, MalSym) - if ast.value in env: - return env[ast.value] - else: - raise Exception(u"'" + ast.value + u"' not found") - elif types._list_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalList(res) - elif types._vector_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalVector(res) - elif types._hash_map_Q(ast): - new_dct = {} - for k in ast.dct.keys(): - new_dct[k] = EVAL(ast.dct[k], env) - return MalHashMap(new_dct) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - el = eval_ast(ast, env) - f = el.values[0] - if isinstance(f, MalFunc): - return f.apply(el.values[1:]) - else: - raise Exception("%s is not callable" % f) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = {} -def REP(str, env): - return PRINT(EVAL(READ(str), env)) - -def plus(args): - a, b = args[0], args[1] - assert isinstance(a, MalInt) - assert isinstance(b, MalInt) - return MalInt(a.value+b.value) -def minus(args): - a, b = args[0], args[1] - assert isinstance(a, MalInt) - assert isinstance(b, MalInt) - return MalInt(a.value-b.value) -def multiply(args): - a, b = args[0], args[1] - assert isinstance(a, MalInt) - assert isinstance(b, MalInt) - return MalInt(a.value*b.value) -def divide(args): - a, b = args[0], args[1] - assert isinstance(a, MalInt) - assert isinstance(b, MalInt) - return MalInt(int(a.value/b.value)) -repl_env[u'+'] = MalFunc(plus) -repl_env[u'-'] = MalFunc(minus) -repl_env[u'*'] = MalFunc(multiply) -repl_env[u'/'] = MalFunc(divide) - -def entry_point(argv): - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line, repl_env)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +#import sys, traceback +import mal_readline +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, + _keywordu, + MalList, _list, MalVector, MalHashMap, MalFunc) +import reader, printer + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + assert isinstance(ast, MalSym) + if ast.value in env: + return env[ast.value] + else: + raise Exception(u"'" + ast.value + u"' not found") + elif types._list_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalList(res) + elif types._vector_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalVector(res) + elif types._hash_map_Q(ast): + new_dct = {} + for k in ast.dct.keys(): + new_dct[k] = EVAL(ast.dct[k], env) + return MalHashMap(new_dct) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + el = eval_ast(ast, env) + f = el.values[0] + if isinstance(f, MalFunc): + return f.apply(el.values[1:]) + else: + raise Exception("%s is not callable" % f) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = {} +def REP(str, env): + return PRINT(EVAL(READ(str), env)) + +def plus(args): + a, b = args[0], args[1] + assert isinstance(a, MalInt) + assert isinstance(b, MalInt) + return MalInt(a.value+b.value) +def minus(args): + a, b = args[0], args[1] + assert isinstance(a, MalInt) + assert isinstance(b, MalInt) + return MalInt(a.value-b.value) +def multiply(args): + a, b = args[0], args[1] + assert isinstance(a, MalInt) + assert isinstance(b, MalInt) + return MalInt(a.value*b.value) +def divide(args): + a, b = args[0], args[1] + assert isinstance(a, MalInt) + assert isinstance(b, MalInt) + return MalInt(int(a.value/b.value)) +repl_env[u'+'] = MalFunc(plus) +repl_env[u'-'] = MalFunc(minus) +repl_env[u'*'] = MalFunc(multiply) +repl_env[u'/'] = MalFunc(divide) + +def entry_point(argv): + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line, repl_env)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/step3_env.py b/impls/rpython/step3_env.py index f196dfcecc..e2093d15b1 100644 --- a/impls/rpython/step3_env.py +++ b/impls/rpython/step3_env.py @@ -1,124 +1,124 @@ -#import sys, traceback -import mal_readline -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, - _symbol, _keywordu, - MalList, _list, MalVector, MalHashMap, MalFunc) -import reader, printer -from env import Env - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - assert isinstance(ast, MalSym) - return env.get(ast) - elif types._list_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalList(res) - elif types._vector_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalVector(res) - elif types._hash_map_Q(ast): - new_dct = {} - for k in ast.dct.keys(): - new_dct[k] = EVAL(ast.dct[k], env) - return MalHashMap(new_dct) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - if not isinstance(a0, MalSym): - raise Exception("attempt to apply on non-symbol") - - if u"def!" == a0.value: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif u"let*" == a0.value: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - return EVAL(a2, let_env) - else: - el = eval_ast(ast, env) - f = el.values[0] - if isinstance(f, MalFunc): - return f.apply(el.values[1:]) - else: - raise Exception("%s is not callable" % f) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -repl_env = Env() -def REP(str, env): - return PRINT(EVAL(READ(str), env)) - -def plus(args): - a, b = args[0], args[1] - assert isinstance(a, MalInt) - assert isinstance(b, MalInt) - return MalInt(a.value+b.value) -def minus(args): - a, b = args[0], args[1] - assert isinstance(a, MalInt) - assert isinstance(b, MalInt) - return MalInt(a.value-b.value) -def multiply(args): - a, b = args[0], args[1] - assert isinstance(a, MalInt) - assert isinstance(b, MalInt) - return MalInt(a.value*b.value) -def divide(args): - a, b = args[0], args[1] - assert isinstance(a, MalInt) - assert isinstance(b, MalInt) - return MalInt(int(a.value/b.value)) -repl_env.set(_symbol(u'+'), MalFunc(plus)) -repl_env.set(_symbol(u'-'), MalFunc(minus)) -repl_env.set(_symbol(u'*'), MalFunc(multiply)) -repl_env.set(_symbol(u'/'), MalFunc(divide)) - -def entry_point(argv): - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line, repl_env)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +#import sys, traceback +import mal_readline +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, + _symbol, _keywordu, + MalList, _list, MalVector, MalHashMap, MalFunc) +import reader, printer +from env import Env + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + assert isinstance(ast, MalSym) + return env.get(ast) + elif types._list_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalList(res) + elif types._vector_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalVector(res) + elif types._hash_map_Q(ast): + new_dct = {} + for k in ast.dct.keys(): + new_dct[k] = EVAL(ast.dct[k], env) + return MalHashMap(new_dct) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + if not isinstance(a0, MalSym): + raise Exception("attempt to apply on non-symbol") + + if u"def!" == a0.value: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif u"let*" == a0.value: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + return EVAL(a2, let_env) + else: + el = eval_ast(ast, env) + f = el.values[0] + if isinstance(f, MalFunc): + return f.apply(el.values[1:]) + else: + raise Exception("%s is not callable" % f) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +repl_env = Env() +def REP(str, env): + return PRINT(EVAL(READ(str), env)) + +def plus(args): + a, b = args[0], args[1] + assert isinstance(a, MalInt) + assert isinstance(b, MalInt) + return MalInt(a.value+b.value) +def minus(args): + a, b = args[0], args[1] + assert isinstance(a, MalInt) + assert isinstance(b, MalInt) + return MalInt(a.value-b.value) +def multiply(args): + a, b = args[0], args[1] + assert isinstance(a, MalInt) + assert isinstance(b, MalInt) + return MalInt(a.value*b.value) +def divide(args): + a, b = args[0], args[1] + assert isinstance(a, MalInt) + assert isinstance(b, MalInt) + return MalInt(int(a.value/b.value)) +repl_env.set(_symbol(u'+'), MalFunc(plus)) +repl_env.set(_symbol(u'-'), MalFunc(minus)) +repl_env.set(_symbol(u'*'), MalFunc(multiply)) +repl_env.set(_symbol(u'/'), MalFunc(divide)) + +def entry_point(argv): + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line, repl_env)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/step4_if_fn_do.py b/impls/rpython/step4_if_fn_do.py index 1ce49692c9..f40f0795a1 100644 --- a/impls/rpython/step4_if_fn_do.py +++ b/impls/rpython/step4_if_fn_do.py @@ -1,123 +1,123 @@ -import sys, traceback -import mal_readline -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, - nil, true, false, _symbol, _keywordu, - MalList, _list, MalVector, MalHashMap, MalFunc) -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - assert isinstance(ast, MalSym) - return env.get(ast) - elif types._list_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalList(res) - elif types._vector_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalVector(res) - elif types._hash_map_Q(ast): - new_dct = {} - for k in ast.dct.keys(): - new_dct[k] = EVAL(ast.dct[k], env) - return MalHashMap(new_dct) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - if isinstance(a0, MalSym): - a0sym = a0.value - else: - a0sym = u"__<*fn*>__" - - if u"def!" == a0sym: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif u"let*" == a0sym: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - return EVAL(a2, let_env) - elif u"do" == a0sym: - el = eval_ast(ast.rest(), env) - return el.values[-1] - elif u"if" == a0sym: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is nil or cond is false: - if len(ast) > 3: return EVAL(ast[3], env) - else: return nil - else: - return EVAL(a2, env) - elif u"fn*" == a0sym: - a1, a2 = ast[1], ast[2] - return MalFunc(None, a2, env, a1, EVAL) - else: - el = eval_ast(ast, env) - f = el.values[0] - if isinstance(f, MalFunc): - return f.apply(el.rest()) - else: - raise Exception("%s is not callable" % f) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -def entry_point(argv): - repl_env = Env() - def REP(str, env): - return PRINT(EVAL(READ(str), env)) - - # core.py: defined using python - for k, v in core.ns.items(): - repl_env.set(_symbol(unicode(k)), MalFunc(v)) - - # core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line, repl_env)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +import sys, traceback +import mal_readline +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, + nil, true, false, _symbol, _keywordu, + MalList, _list, MalVector, MalHashMap, MalFunc) +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + assert isinstance(ast, MalSym) + return env.get(ast) + elif types._list_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalList(res) + elif types._vector_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalVector(res) + elif types._hash_map_Q(ast): + new_dct = {} + for k in ast.dct.keys(): + new_dct[k] = EVAL(ast.dct[k], env) + return MalHashMap(new_dct) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + if isinstance(a0, MalSym): + a0sym = a0.value + else: + a0sym = u"__<*fn*>__" + + if u"def!" == a0sym: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif u"let*" == a0sym: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + return EVAL(a2, let_env) + elif u"do" == a0sym: + el = eval_ast(ast.rest(), env) + return el.values[-1] + elif u"if" == a0sym: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is nil or cond is false: + if len(ast) > 3: return EVAL(ast[3], env) + else: return nil + else: + return EVAL(a2, env) + elif u"fn*" == a0sym: + a1, a2 = ast[1], ast[2] + return MalFunc(None, a2, env, a1, EVAL) + else: + el = eval_ast(ast, env) + f = el.values[0] + if isinstance(f, MalFunc): + return f.apply(el.rest()) + else: + raise Exception("%s is not callable" % f) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +def entry_point(argv): + repl_env = Env() + def REP(str, env): + return PRINT(EVAL(READ(str), env)) + + # core.py: defined using python + for k, v in core.ns.items(): + repl_env.set(_symbol(unicode(k)), MalFunc(v)) + + # core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line, repl_env)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/step5_tco.py b/impls/rpython/step5_tco.py index 8d24555c87..e30d6326a5 100644 --- a/impls/rpython/step5_tco.py +++ b/impls/rpython/step5_tco.py @@ -1,132 +1,132 @@ -import sys, traceback -import mal_readline -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, - nil, true, false, _symbol, _keywordu, - MalList, _list, MalVector, MalHashMap, MalFunc) -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - assert isinstance(ast, MalSym) - return env.get(ast) - elif types._list_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalList(res) - elif types._vector_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalVector(res) - elif types._hash_map_Q(ast): - new_dct = {} - for k in ast.dct.keys(): - new_dct[k] = EVAL(ast.dct[k], env) - return MalHashMap(new_dct) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - if isinstance(a0, MalSym): - a0sym = a0.value - else: - a0sym = u"__<*fn*>__" - - if u"def!" == a0sym: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif u"let*" == a0sym: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env # Continue loop (TCO) - elif u"do" == a0sym: - if len(ast) == 0: - return nil - elif len(ast) > 1: - eval_ast(ast.slice2(1, len(ast)-1), env) - ast = ast[-1] # Continue loop (TCO) - elif u"if" == a0sym: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is nil or cond is false: - if len(ast) > 3: ast = ast[3] # Continue loop (TCO) - else: return nil - else: - ast = a2 # Continue loop (TCO) - elif u"fn*" == a0sym: - a1, a2 = ast[1], ast[2] - return MalFunc(None, a2, env, a1, EVAL) - else: - el = eval_ast(ast, env) - f = el.values[0] - if isinstance(f, MalFunc): - if f.ast: - ast = f.ast - env = f.gen_env(el.rest()) # Continue loop (TCO) - else: - return f.apply(el.rest()) - else: - raise Exception("%s is not callable" % f) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -def entry_point(argv): - repl_env = Env() - def REP(str, env): - return PRINT(EVAL(READ(str), env)) - - # core.py: defined using python - for k, v in core.ns.items(): - repl_env.set(_symbol(unicode(k)), MalFunc(v)) - - # core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line, repl_env)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +import sys, traceback +import mal_readline +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, + nil, true, false, _symbol, _keywordu, + MalList, _list, MalVector, MalHashMap, MalFunc) +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + assert isinstance(ast, MalSym) + return env.get(ast) + elif types._list_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalList(res) + elif types._vector_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalVector(res) + elif types._hash_map_Q(ast): + new_dct = {} + for k in ast.dct.keys(): + new_dct[k] = EVAL(ast.dct[k], env) + return MalHashMap(new_dct) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + if isinstance(a0, MalSym): + a0sym = a0.value + else: + a0sym = u"__<*fn*>__" + + if u"def!" == a0sym: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif u"let*" == a0sym: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env # Continue loop (TCO) + elif u"do" == a0sym: + if len(ast) == 0: + return nil + elif len(ast) > 1: + eval_ast(ast.slice2(1, len(ast)-1), env) + ast = ast[-1] # Continue loop (TCO) + elif u"if" == a0sym: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is nil or cond is false: + if len(ast) > 3: ast = ast[3] # Continue loop (TCO) + else: return nil + else: + ast = a2 # Continue loop (TCO) + elif u"fn*" == a0sym: + a1, a2 = ast[1], ast[2] + return MalFunc(None, a2, env, a1, EVAL) + else: + el = eval_ast(ast, env) + f = el.values[0] + if isinstance(f, MalFunc): + if f.ast: + ast = f.ast + env = f.gen_env(el.rest()) # Continue loop (TCO) + else: + return f.apply(el.rest()) + else: + raise Exception("%s is not callable" % f) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +def entry_point(argv): + repl_env = Env() + def REP(str, env): + return PRINT(EVAL(READ(str), env)) + + # core.py: defined using python + for k, v in core.ns.items(): + repl_env.set(_symbol(unicode(k)), MalFunc(v)) + + # core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line, repl_env)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/step6_file.py b/impls/rpython/step6_file.py index 474392761f..3cd34bdb8d 100644 --- a/impls/rpython/step6_file.py +++ b/impls/rpython/step6_file.py @@ -1,147 +1,147 @@ -import sys, traceback -import mal_readline -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, - nil, true, false, _symbol, _keywordu, - MalList, _list, MalVector, MalHashMap, MalFunc) -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def eval_ast(ast, env): - if types._symbol_Q(ast): - assert isinstance(ast, MalSym) - return env.get(ast) - elif types._list_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalList(res) - elif types._vector_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalVector(res) - elif types._hash_map_Q(ast): - new_dct = {} - for k in ast.dct.keys(): - new_dct[k] = EVAL(ast.dct[k], env) - return MalHashMap(new_dct) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - if isinstance(a0, MalSym): - a0sym = a0.value - else: - a0sym = u"__<*fn*>__" - - if u"def!" == a0sym: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif u"let*" == a0sym: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env # Continue loop (TCO) - elif u"do" == a0sym: - if len(ast) == 0: - return nil - elif len(ast) > 1: - eval_ast(ast.slice2(1, len(ast)-1), env) - ast = ast[-1] # Continue loop (TCO) - elif u"if" == a0sym: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is nil or cond is false: - if len(ast) > 3: ast = ast[3] # Continue loop (TCO) - else: return nil - else: - ast = a2 # Continue loop (TCO) - elif u"fn*" == a0sym: - a1, a2 = ast[1], ast[2] - return MalFunc(None, a2, env, a1, EVAL) - else: - el = eval_ast(ast, env) - f = el.values[0] - if isinstance(f, MalFunc): - if f.ast: - ast = f.ast - env = f.gen_env(el.rest()) # Continue loop (TCO) - else: - return f.apply(el.rest()) - else: - raise Exception("%s is not callable" % f) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -class MalEval(MalFunc): - def apply(self, args): - return self.EvalFunc(args[0], self.env) - -def entry_point(argv): - repl_env = Env() - def REP(str, env): - return PRINT(EVAL(READ(str), env)) - - # core.py: defined using python - for k, v in core.ns.items(): - repl_env.set(_symbol(unicode(k)), MalFunc(v)) - repl_env.set(types._symbol(u'eval'), - MalEval(None, env=repl_env, EvalFunc=EVAL)) - mal_args = [] - if len(argv) >= 3: - for a in argv[2:]: mal_args.append(MalStr(unicode(a))) - repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) - - # core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - - if len(argv) >= 2: - REP('(load-file "' + argv[1] + '")', repl_env) - return 0 - - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line, repl_env)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +import sys, traceback +import mal_readline +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, + nil, true, false, _symbol, _keywordu, + MalList, _list, MalVector, MalHashMap, MalFunc) +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def eval_ast(ast, env): + if types._symbol_Q(ast): + assert isinstance(ast, MalSym) + return env.get(ast) + elif types._list_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalList(res) + elif types._vector_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalVector(res) + elif types._hash_map_Q(ast): + new_dct = {} + for k in ast.dct.keys(): + new_dct[k] = EVAL(ast.dct[k], env) + return MalHashMap(new_dct) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + if isinstance(a0, MalSym): + a0sym = a0.value + else: + a0sym = u"__<*fn*>__" + + if u"def!" == a0sym: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif u"let*" == a0sym: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env # Continue loop (TCO) + elif u"do" == a0sym: + if len(ast) == 0: + return nil + elif len(ast) > 1: + eval_ast(ast.slice2(1, len(ast)-1), env) + ast = ast[-1] # Continue loop (TCO) + elif u"if" == a0sym: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is nil or cond is false: + if len(ast) > 3: ast = ast[3] # Continue loop (TCO) + else: return nil + else: + ast = a2 # Continue loop (TCO) + elif u"fn*" == a0sym: + a1, a2 = ast[1], ast[2] + return MalFunc(None, a2, env, a1, EVAL) + else: + el = eval_ast(ast, env) + f = el.values[0] + if isinstance(f, MalFunc): + if f.ast: + ast = f.ast + env = f.gen_env(el.rest()) # Continue loop (TCO) + else: + return f.apply(el.rest()) + else: + raise Exception("%s is not callable" % f) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +class MalEval(MalFunc): + def apply(self, args): + return self.EvalFunc(args[0], self.env) + +def entry_point(argv): + repl_env = Env() + def REP(str, env): + return PRINT(EVAL(READ(str), env)) + + # core.py: defined using python + for k, v in core.ns.items(): + repl_env.set(_symbol(unicode(k)), MalFunc(v)) + repl_env.set(types._symbol(u'eval'), + MalEval(None, env=repl_env, EvalFunc=EVAL)) + mal_args = [] + if len(argv) >= 3: + for a in argv[2:]: mal_args.append(MalStr(unicode(a))) + repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) + + # core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + + if len(argv) >= 2: + REP('(load-file "' + argv[1] + '")', repl_env) + return 0 + + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line, repl_env)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/step7_quote.py b/impls/rpython/step7_quote.py index cb8c063ab7..ebbb814f9f 100644 --- a/impls/rpython/step7_quote.py +++ b/impls/rpython/step7_quote.py @@ -1,180 +1,180 @@ -import sys, traceback -import mal_readline -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, - nil, true, false, _symbol, _keywordu, - MalList, _list, MalVector, MalHashMap, MalFunc) -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def qq_loop(elt, acc): - if types._list_Q(elt) and len(elt) == 2: - fst = elt[0] - if isinstance(fst, MalSym) and fst.value == u"splice-unquote": - return _list(_symbol(u"concat"), elt[1], acc) - return _list(_symbol(u"cons"), quasiquote(elt), acc) - -def qq_foldr(seq): - acc = _list() - for elt in reversed(seq): - acc = qq_loop (elt, acc) - return acc - -def quasiquote(ast): - if types._list_Q(ast): - if len(ast) == 2: - fst = ast[0] - if isinstance(fst, MalSym) and fst.value == u"unquote": - return ast[1] - return qq_foldr(ast.values) - elif types._vector_Q(ast): - return _list(_symbol(u"vec"), qq_foldr(ast.values)) - elif types._symbol_Q(ast) or types._hash_map_Q(ast): - return _list(_symbol(u"quote"), ast) - else: - return ast - -def eval_ast(ast, env): - if types._symbol_Q(ast): - assert isinstance(ast, MalSym) - return env.get(ast) - elif types._list_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalList(res) - elif types._vector_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalVector(res) - elif types._hash_map_Q(ast): - new_dct = {} - for k in ast.dct.keys(): - new_dct[k] = EVAL(ast.dct[k], env) - return MalHashMap(new_dct) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - - # apply list - if len(ast) == 0: return ast - a0 = ast[0] - if isinstance(a0, MalSym): - a0sym = a0.value - else: - a0sym = u"__<*fn*>__" - - if u"def!" == a0sym: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif u"let*" == a0sym: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env # Continue loop (TCO) - elif u"quote" == a0sym: - return ast[1] - elif u"quasiquoteexpand" == a0sym: - return quasiquote(ast[1]) - elif u"quasiquote" == a0sym: - ast = quasiquote(ast[1]) # Continue loop (TCO) - elif u"do" == a0sym: - if len(ast) == 0: - return nil - elif len(ast) > 1: - eval_ast(ast.slice2(1, len(ast)-1), env) - ast = ast[-1] # Continue loop (TCO) - elif u"if" == a0sym: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is nil or cond is false: - if len(ast) > 3: ast = ast[3] # Continue loop (TCO) - else: return nil - else: - ast = a2 # Continue loop (TCO) - elif u"fn*" == a0sym: - a1, a2 = ast[1], ast[2] - return MalFunc(None, a2, env, a1, EVAL) - else: - el = eval_ast(ast, env) - f = el.values[0] - if isinstance(f, MalFunc): - if f.ast: - ast = f.ast - env = f.gen_env(el.rest()) # Continue loop (TCO) - else: - return f.apply(el.rest()) - else: - raise Exception("%s is not callable" % f) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -class MalEval(MalFunc): - def apply(self, args): - return self.EvalFunc(args[0], self.env) - -def entry_point(argv): - repl_env = Env() - def REP(str, env): - return PRINT(EVAL(READ(str), env)) - - # core.py: defined using python - for k, v in core.ns.items(): - repl_env.set(_symbol(unicode(k)), MalFunc(v)) - repl_env.set(types._symbol(u'eval'), - MalEval(None, env=repl_env, EvalFunc=EVAL)) - mal_args = [] - if len(argv) >= 3: - for a in argv[2:]: mal_args.append(MalStr(unicode(a))) - repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) - - # core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - - if len(argv) >= 2: - REP('(load-file "' + argv[1] + '")', repl_env) - return 0 - - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line, repl_env)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +import sys, traceback +import mal_readline +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, + nil, true, false, _symbol, _keywordu, + MalList, _list, MalVector, MalHashMap, MalFunc) +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def qq_loop(elt, acc): + if types._list_Q(elt) and len(elt) == 2: + fst = elt[0] + if isinstance(fst, MalSym) and fst.value == u"splice-unquote": + return _list(_symbol(u"concat"), elt[1], acc) + return _list(_symbol(u"cons"), quasiquote(elt), acc) + +def qq_foldr(seq): + acc = _list() + for elt in reversed(seq): + acc = qq_loop (elt, acc) + return acc + +def quasiquote(ast): + if types._list_Q(ast): + if len(ast) == 2: + fst = ast[0] + if isinstance(fst, MalSym) and fst.value == u"unquote": + return ast[1] + return qq_foldr(ast.values) + elif types._vector_Q(ast): + return _list(_symbol(u"vec"), qq_foldr(ast.values)) + elif types._symbol_Q(ast) or types._hash_map_Q(ast): + return _list(_symbol(u"quote"), ast) + else: + return ast + +def eval_ast(ast, env): + if types._symbol_Q(ast): + assert isinstance(ast, MalSym) + return env.get(ast) + elif types._list_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalList(res) + elif types._vector_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalVector(res) + elif types._hash_map_Q(ast): + new_dct = {} + for k in ast.dct.keys(): + new_dct[k] = EVAL(ast.dct[k], env) + return MalHashMap(new_dct) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + + # apply list + if len(ast) == 0: return ast + a0 = ast[0] + if isinstance(a0, MalSym): + a0sym = a0.value + else: + a0sym = u"__<*fn*>__" + + if u"def!" == a0sym: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif u"let*" == a0sym: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env # Continue loop (TCO) + elif u"quote" == a0sym: + return ast[1] + elif u"quasiquoteexpand" == a0sym: + return quasiquote(ast[1]) + elif u"quasiquote" == a0sym: + ast = quasiquote(ast[1]) # Continue loop (TCO) + elif u"do" == a0sym: + if len(ast) == 0: + return nil + elif len(ast) > 1: + eval_ast(ast.slice2(1, len(ast)-1), env) + ast = ast[-1] # Continue loop (TCO) + elif u"if" == a0sym: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is nil or cond is false: + if len(ast) > 3: ast = ast[3] # Continue loop (TCO) + else: return nil + else: + ast = a2 # Continue loop (TCO) + elif u"fn*" == a0sym: + a1, a2 = ast[1], ast[2] + return MalFunc(None, a2, env, a1, EVAL) + else: + el = eval_ast(ast, env) + f = el.values[0] + if isinstance(f, MalFunc): + if f.ast: + ast = f.ast + env = f.gen_env(el.rest()) # Continue loop (TCO) + else: + return f.apply(el.rest()) + else: + raise Exception("%s is not callable" % f) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +class MalEval(MalFunc): + def apply(self, args): + return self.EvalFunc(args[0], self.env) + +def entry_point(argv): + repl_env = Env() + def REP(str, env): + return PRINT(EVAL(READ(str), env)) + + # core.py: defined using python + for k, v in core.ns.items(): + repl_env.set(_symbol(unicode(k)), MalFunc(v)) + repl_env.set(types._symbol(u'eval'), + MalEval(None, env=repl_env, EvalFunc=EVAL)) + mal_args = [] + if len(argv) >= 3: + for a in argv[2:]: mal_args.append(MalStr(unicode(a))) + repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) + + # core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + + if len(argv) >= 2: + REP('(load-file "' + argv[1] + '")', repl_env) + return 0 + + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line, repl_env)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/step8_macros.py b/impls/rpython/step8_macros.py index 8aff32a945..ceabd1d7bc 100644 --- a/impls/rpython/step8_macros.py +++ b/impls/rpython/step8_macros.py @@ -1,206 +1,206 @@ -import sys, traceback -import mal_readline -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, - nil, true, false, _symbol, _keywordu, - MalList, _list, MalVector, MalHashMap, MalFunc) -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def qq_loop(elt, acc): - if types._list_Q(elt) and len(elt) == 2: - fst = elt[0] - if isinstance(fst, MalSym) and fst.value == u"splice-unquote": - return _list(_symbol(u"concat"), elt[1], acc) - return _list(_symbol(u"cons"), quasiquote(elt), acc) - -def qq_foldr(seq): - acc = _list() - for elt in reversed(seq): - acc = qq_loop (elt, acc) - return acc - -def quasiquote(ast): - if types._list_Q(ast): - if len(ast) == 2: - fst = ast[0] - if isinstance(fst, MalSym) and fst.value == u"unquote": - return ast[1] - return qq_foldr(ast.values) - elif types._vector_Q(ast): - return _list(_symbol(u"vec"), qq_foldr(ast.values)) - elif types._symbol_Q(ast) or types._hash_map_Q(ast): - return _list(_symbol(u"quote"), ast) - else: - return ast - -def is_macro_call(ast, env): - if types._list_Q(ast): - a0 = ast[0] - if isinstance(a0, MalSym): - if not env.find(a0) is None: - return env.get(a0).ismacro - return False - -def macroexpand(ast, env): - while is_macro_call(ast, env): - assert isinstance(ast[0], MalSym) - mac = env.get(ast[0]) - ast = macroexpand(mac.apply(ast.rest()), env) - return ast - -def eval_ast(ast, env): - if types._symbol_Q(ast): - assert isinstance(ast, MalSym) - return env.get(ast) - elif types._list_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalList(res) - elif types._vector_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalVector(res) - elif types._hash_map_Q(ast): - new_dct = {} - for k in ast.dct.keys(): - new_dct[k] = EVAL(ast.dct[k], env) - return MalHashMap(new_dct) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - if len(ast) == 0: return ast - - # apply list - ast = macroexpand(ast, env) - if not types._list_Q(ast): - return eval_ast(ast, env) - if len(ast) == 0: return ast - a0 = ast[0] - if isinstance(a0, MalSym): - a0sym = a0.value - else: - a0sym = u"__<*fn*>__" - - if u"def!" == a0sym: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif u"let*" == a0sym: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env # Continue loop (TCO) - elif u"quote" == a0sym: - return ast[1] - elif u"quasiquoteexpand" == a0sym: - return quasiquote(ast[1]) - elif u"quasiquote" == a0sym: - ast = quasiquote(ast[1]) # Continue loop (TCO) - elif u"defmacro!" == a0sym: - func = EVAL(ast[2], env) - func.ismacro = True - return env.set(ast[1], func) - elif u"macroexpand" == a0sym: - return macroexpand(ast[1], env) - elif u"do" == a0sym: - if len(ast) == 0: - return nil - elif len(ast) > 1: - eval_ast(ast.slice2(1, len(ast)-1), env) - ast = ast[-1] # Continue loop (TCO) - elif u"if" == a0sym: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is nil or cond is false: - if len(ast) > 3: ast = ast[3] # Continue loop (TCO) - else: return nil - else: - ast = a2 # Continue loop (TCO) - elif u"fn*" == a0sym: - a1, a2 = ast[1], ast[2] - return MalFunc(None, a2, env, a1, EVAL) - else: - el = eval_ast(ast, env) - f = el.values[0] - if isinstance(f, MalFunc): - if f.ast: - ast = f.ast - env = f.gen_env(el.rest()) # Continue loop (TCO) - else: - return f.apply(el.rest()) - else: - raise Exception("%s is not callable" % f) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -class MalEval(MalFunc): - def apply(self, args): - return self.EvalFunc(args[0], self.env) - -def entry_point(argv): - repl_env = Env() - def REP(str, env): - return PRINT(EVAL(READ(str), env)) - - # core.py: defined using python - for k, v in core.ns.items(): - repl_env.set(_symbol(unicode(k)), MalFunc(v)) - repl_env.set(types._symbol(u'eval'), - MalEval(None, env=repl_env, EvalFunc=EVAL)) - mal_args = [] - if len(argv) >= 3: - for a in argv[2:]: mal_args.append(MalStr(unicode(a))) - repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) - - # core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - 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)))))))", repl_env) - - if len(argv) >= 2: - REP('(load-file "' + argv[1] + '")', repl_env) - return 0 - - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line, repl_env)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +import sys, traceback +import mal_readline +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, + nil, true, false, _symbol, _keywordu, + MalList, _list, MalVector, MalHashMap, MalFunc) +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def qq_loop(elt, acc): + if types._list_Q(elt) and len(elt) == 2: + fst = elt[0] + if isinstance(fst, MalSym) and fst.value == u"splice-unquote": + return _list(_symbol(u"concat"), elt[1], acc) + return _list(_symbol(u"cons"), quasiquote(elt), acc) + +def qq_foldr(seq): + acc = _list() + for elt in reversed(seq): + acc = qq_loop (elt, acc) + return acc + +def quasiquote(ast): + if types._list_Q(ast): + if len(ast) == 2: + fst = ast[0] + if isinstance(fst, MalSym) and fst.value == u"unquote": + return ast[1] + return qq_foldr(ast.values) + elif types._vector_Q(ast): + return _list(_symbol(u"vec"), qq_foldr(ast.values)) + elif types._symbol_Q(ast) or types._hash_map_Q(ast): + return _list(_symbol(u"quote"), ast) + else: + return ast + +def is_macro_call(ast, env): + if types._list_Q(ast): + a0 = ast[0] + if isinstance(a0, MalSym): + if not env.find(a0) is None: + return env.get(a0).ismacro + return False + +def macroexpand(ast, env): + while is_macro_call(ast, env): + assert isinstance(ast[0], MalSym) + mac = env.get(ast[0]) + ast = macroexpand(mac.apply(ast.rest()), env) + return ast + +def eval_ast(ast, env): + if types._symbol_Q(ast): + assert isinstance(ast, MalSym) + return env.get(ast) + elif types._list_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalList(res) + elif types._vector_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalVector(res) + elif types._hash_map_Q(ast): + new_dct = {} + for k in ast.dct.keys(): + new_dct[k] = EVAL(ast.dct[k], env) + return MalHashMap(new_dct) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + if len(ast) == 0: return ast + + # apply list + ast = macroexpand(ast, env) + if not types._list_Q(ast): + return eval_ast(ast, env) + if len(ast) == 0: return ast + a0 = ast[0] + if isinstance(a0, MalSym): + a0sym = a0.value + else: + a0sym = u"__<*fn*>__" + + if u"def!" == a0sym: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif u"let*" == a0sym: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env # Continue loop (TCO) + elif u"quote" == a0sym: + return ast[1] + elif u"quasiquoteexpand" == a0sym: + return quasiquote(ast[1]) + elif u"quasiquote" == a0sym: + ast = quasiquote(ast[1]) # Continue loop (TCO) + elif u"defmacro!" == a0sym: + func = EVAL(ast[2], env) + func.ismacro = True + return env.set(ast[1], func) + elif u"macroexpand" == a0sym: + return macroexpand(ast[1], env) + elif u"do" == a0sym: + if len(ast) == 0: + return nil + elif len(ast) > 1: + eval_ast(ast.slice2(1, len(ast)-1), env) + ast = ast[-1] # Continue loop (TCO) + elif u"if" == a0sym: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is nil or cond is false: + if len(ast) > 3: ast = ast[3] # Continue loop (TCO) + else: return nil + else: + ast = a2 # Continue loop (TCO) + elif u"fn*" == a0sym: + a1, a2 = ast[1], ast[2] + return MalFunc(None, a2, env, a1, EVAL) + else: + el = eval_ast(ast, env) + f = el.values[0] + if isinstance(f, MalFunc): + if f.ast: + ast = f.ast + env = f.gen_env(el.rest()) # Continue loop (TCO) + else: + return f.apply(el.rest()) + else: + raise Exception("%s is not callable" % f) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +class MalEval(MalFunc): + def apply(self, args): + return self.EvalFunc(args[0], self.env) + +def entry_point(argv): + repl_env = Env() + def REP(str, env): + return PRINT(EVAL(READ(str), env)) + + # core.py: defined using python + for k, v in core.ns.items(): + repl_env.set(_symbol(unicode(k)), MalFunc(v)) + repl_env.set(types._symbol(u'eval'), + MalEval(None, env=repl_env, EvalFunc=EVAL)) + mal_args = [] + if len(argv) >= 3: + for a in argv[2:]: mal_args.append(MalStr(unicode(a))) + repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) + + # core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + 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)))))))", repl_env) + + if len(argv) >= 2: + REP('(load-file "' + argv[1] + '")', repl_env) + return 0 + + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line, repl_env)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/step9_try.py b/impls/rpython/step9_try.py index 40989a7aab..0d35eed6c7 100644 --- a/impls/rpython/step9_try.py +++ b/impls/rpython/step9_try.py @@ -1,224 +1,224 @@ -import sys, traceback -import mal_readline -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, - nil, true, false, _symbol, _keywordu, - MalList, _list, MalVector, MalHashMap, MalFunc) -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def qq_loop(elt, acc): - if types._list_Q(elt) and len(elt) == 2: - fst = elt[0] - if isinstance(fst, MalSym) and fst.value == u"splice-unquote": - return _list(_symbol(u"concat"), elt[1], acc) - return _list(_symbol(u"cons"), quasiquote(elt), acc) - -def qq_foldr(seq): - acc = _list() - for elt in reversed(seq): - acc = qq_loop (elt, acc) - return acc - -def quasiquote(ast): - if types._list_Q(ast): - if len(ast) == 2: - fst = ast[0] - if isinstance(fst, MalSym) and fst.value == u"unquote": - return ast[1] - return qq_foldr(ast.values) - elif types._vector_Q(ast): - return _list(_symbol(u"vec"), qq_foldr(ast.values)) - elif types._symbol_Q(ast) or types._hash_map_Q(ast): - return _list(_symbol(u"quote"), ast) - else: - return ast - -def is_macro_call(ast, env): - if types._list_Q(ast): - a0 = ast[0] - if isinstance(a0, MalSym): - if not env.find(a0) is None: - return env.get(a0).ismacro - return False - -def macroexpand(ast, env): - while is_macro_call(ast, env): - assert isinstance(ast[0], MalSym) - mac = env.get(ast[0]) - ast = macroexpand(mac.apply(ast.rest()), env) - return ast - -def eval_ast(ast, env): - if types._symbol_Q(ast): - assert isinstance(ast, MalSym) - return env.get(ast) - elif types._list_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalList(res) - elif types._vector_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalVector(res) - elif types._hash_map_Q(ast): - new_dct = {} - for k in ast.dct.keys(): - new_dct[k] = EVAL(ast.dct[k], env) - return MalHashMap(new_dct) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - if len(ast) == 0: return ast - - # apply list - ast = macroexpand(ast, env) - if not types._list_Q(ast): - return eval_ast(ast, env) - if len(ast) == 0: return ast - a0 = ast[0] - if isinstance(a0, MalSym): - a0sym = a0.value - else: - a0sym = u"__<*fn*>__" - - if u"def!" == a0sym: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif u"let*" == a0sym: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env # Continue loop (TCO) - elif u"quote" == a0sym: - return ast[1] - elif u"quasiquoteexpand" == a0sym: - return quasiquote(ast[1]) - elif u"quasiquote" == a0sym: - ast = quasiquote(ast[1]) # Continue loop (TCO) - elif u"defmacro!" == a0sym: - func = EVAL(ast[2], env) - func.ismacro = True - return env.set(ast[1], func) - elif u"macroexpand" == a0sym: - return macroexpand(ast[1], env) - elif u"try*" == a0sym: - if len(ast) < 3: - return EVAL(ast[1], env); - a1, a2 = ast[1], ast[2] - a20 = a2[0] - if isinstance(a20, MalSym): - if a20.value == u"catch*": - try: - return EVAL(a1, env); - except types.MalException as exc: - exc = exc.object - catch_env = Env(env, _list(a2[1]), _list(exc)) - return EVAL(a2[2], catch_env) - except Exception as exc: - exc = MalStr(unicode("%s" % exc)) - catch_env = Env(env, _list(a2[1]), _list(exc)) - return EVAL(a2[2], catch_env) - return EVAL(a1, env); - elif u"do" == a0sym: - if len(ast) == 0: - return nil - elif len(ast) > 1: - eval_ast(ast.slice2(1, len(ast)-1), env) - ast = ast[-1] # Continue loop (TCO) - elif u"if" == a0sym: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is nil or cond is false: - if len(ast) > 3: ast = ast[3] # Continue loop (TCO) - else: return nil - else: - ast = a2 # Continue loop (TCO) - elif u"fn*" == a0sym: - a1, a2 = ast[1], ast[2] - return MalFunc(None, a2, env, a1, EVAL) - else: - el = eval_ast(ast, env) - f = el.values[0] - if isinstance(f, MalFunc): - if f.ast: - ast = f.ast - env = f.gen_env(el.rest()) # Continue loop (TCO) - else: - return f.apply(el.rest()) - else: - raise Exception("%s is not callable" % f) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -class MalEval(MalFunc): - def apply(self, args): - return self.EvalFunc(args[0], self.env) - -def entry_point(argv): - repl_env = Env() - def REP(str, env): - return PRINT(EVAL(READ(str), env)) - - # core.py: defined using python - for k, v in core.ns.items(): - repl_env.set(_symbol(unicode(k)), MalFunc(v)) - repl_env.set(types._symbol(u'eval'), - MalEval(None, env=repl_env, EvalFunc=EVAL)) - mal_args = [] - if len(argv) >= 3: - for a in argv[2:]: mal_args.append(MalStr(unicode(a))) - repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) - - # core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - 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)))))))", repl_env) - - if len(argv) >= 2: - REP('(load-file "' + argv[1] + '")', repl_env) - return 0 - - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line, repl_env)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - #print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +import sys, traceback +import mal_readline +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, + nil, true, false, _symbol, _keywordu, + MalList, _list, MalVector, MalHashMap, MalFunc) +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def qq_loop(elt, acc): + if types._list_Q(elt) and len(elt) == 2: + fst = elt[0] + if isinstance(fst, MalSym) and fst.value == u"splice-unquote": + return _list(_symbol(u"concat"), elt[1], acc) + return _list(_symbol(u"cons"), quasiquote(elt), acc) + +def qq_foldr(seq): + acc = _list() + for elt in reversed(seq): + acc = qq_loop (elt, acc) + return acc + +def quasiquote(ast): + if types._list_Q(ast): + if len(ast) == 2: + fst = ast[0] + if isinstance(fst, MalSym) and fst.value == u"unquote": + return ast[1] + return qq_foldr(ast.values) + elif types._vector_Q(ast): + return _list(_symbol(u"vec"), qq_foldr(ast.values)) + elif types._symbol_Q(ast) or types._hash_map_Q(ast): + return _list(_symbol(u"quote"), ast) + else: + return ast + +def is_macro_call(ast, env): + if types._list_Q(ast): + a0 = ast[0] + if isinstance(a0, MalSym): + if not env.find(a0) is None: + return env.get(a0).ismacro + return False + +def macroexpand(ast, env): + while is_macro_call(ast, env): + assert isinstance(ast[0], MalSym) + mac = env.get(ast[0]) + ast = macroexpand(mac.apply(ast.rest()), env) + return ast + +def eval_ast(ast, env): + if types._symbol_Q(ast): + assert isinstance(ast, MalSym) + return env.get(ast) + elif types._list_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalList(res) + elif types._vector_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalVector(res) + elif types._hash_map_Q(ast): + new_dct = {} + for k in ast.dct.keys(): + new_dct[k] = EVAL(ast.dct[k], env) + return MalHashMap(new_dct) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + if len(ast) == 0: return ast + + # apply list + ast = macroexpand(ast, env) + if not types._list_Q(ast): + return eval_ast(ast, env) + if len(ast) == 0: return ast + a0 = ast[0] + if isinstance(a0, MalSym): + a0sym = a0.value + else: + a0sym = u"__<*fn*>__" + + if u"def!" == a0sym: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif u"let*" == a0sym: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env # Continue loop (TCO) + elif u"quote" == a0sym: + return ast[1] + elif u"quasiquoteexpand" == a0sym: + return quasiquote(ast[1]) + elif u"quasiquote" == a0sym: + ast = quasiquote(ast[1]) # Continue loop (TCO) + elif u"defmacro!" == a0sym: + func = EVAL(ast[2], env) + func.ismacro = True + return env.set(ast[1], func) + elif u"macroexpand" == a0sym: + return macroexpand(ast[1], env) + elif u"try*" == a0sym: + if len(ast) < 3: + return EVAL(ast[1], env); + a1, a2 = ast[1], ast[2] + a20 = a2[0] + if isinstance(a20, MalSym): + if a20.value == u"catch*": + try: + return EVAL(a1, env); + except types.MalException as exc: + exc = exc.object + catch_env = Env(env, _list(a2[1]), _list(exc)) + return EVAL(a2[2], catch_env) + except Exception as exc: + exc = MalStr(unicode("%s" % exc)) + catch_env = Env(env, _list(a2[1]), _list(exc)) + return EVAL(a2[2], catch_env) + return EVAL(a1, env); + elif u"do" == a0sym: + if len(ast) == 0: + return nil + elif len(ast) > 1: + eval_ast(ast.slice2(1, len(ast)-1), env) + ast = ast[-1] # Continue loop (TCO) + elif u"if" == a0sym: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is nil or cond is false: + if len(ast) > 3: ast = ast[3] # Continue loop (TCO) + else: return nil + else: + ast = a2 # Continue loop (TCO) + elif u"fn*" == a0sym: + a1, a2 = ast[1], ast[2] + return MalFunc(None, a2, env, a1, EVAL) + else: + el = eval_ast(ast, env) + f = el.values[0] + if isinstance(f, MalFunc): + if f.ast: + ast = f.ast + env = f.gen_env(el.rest()) # Continue loop (TCO) + else: + return f.apply(el.rest()) + else: + raise Exception("%s is not callable" % f) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +class MalEval(MalFunc): + def apply(self, args): + return self.EvalFunc(args[0], self.env) + +def entry_point(argv): + repl_env = Env() + def REP(str, env): + return PRINT(EVAL(READ(str), env)) + + # core.py: defined using python + for k, v in core.ns.items(): + repl_env.set(_symbol(unicode(k)), MalFunc(v)) + repl_env.set(types._symbol(u'eval'), + MalEval(None, env=repl_env, EvalFunc=EVAL)) + mal_args = [] + if len(argv) >= 3: + for a in argv[2:]: mal_args.append(MalStr(unicode(a))) + repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) + + # core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + 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)))))))", repl_env) + + if len(argv) >= 2: + REP('(load-file "' + argv[1] + '")', repl_env) + return 0 + + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line, repl_env)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + #print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/stepA_mal.py b/impls/rpython/stepA_mal.py index 79f266211c..ac8c052c3f 100644 --- a/impls/rpython/stepA_mal.py +++ b/impls/rpython/stepA_mal.py @@ -1,238 +1,238 @@ -import sys -IS_RPYTHON = sys.argv[0].endswith('rpython') - -if IS_RPYTHON: - #from rpython.rlib.debug import fatalerror - from rpython.rtyper.lltypesystem import lltype - from rpython.rtyper.lltypesystem.lloperation import llop -else: - import traceback - -import mal_readline -import mal_types as types -from mal_types import (MalSym, MalInt, MalStr, - nil, true, false, _symbol, _keywordu, - MalList, _list, MalVector, MalHashMap, MalFunc) -import reader, printer -from env import Env -import core - -# read -def READ(str): - return reader.read_str(str) - -# eval -def qq_loop(elt, acc): - if types._list_Q(elt) and len(elt) == 2: - fst = elt[0] - if isinstance(fst, MalSym) and fst.value == u"splice-unquote": - return _list(_symbol(u"concat"), elt[1], acc) - return _list(_symbol(u"cons"), quasiquote(elt), acc) - -def qq_foldr(seq): - acc = _list() - for elt in reversed(seq): - acc = qq_loop (elt, acc) - return acc - -def quasiquote(ast): - if types._list_Q(ast): - if len(ast) == 2: - fst = ast[0] - if isinstance(fst, MalSym) and fst.value == u"unquote": - return ast[1] - return qq_foldr(ast.values) - elif types._vector_Q(ast): - return _list(_symbol(u"vec"), qq_foldr(ast.values)) - elif types._symbol_Q(ast) or types._hash_map_Q(ast): - return _list(_symbol(u"quote"), ast) - else: - return ast - -def is_macro_call(ast, env): - if types._list_Q(ast): - a0 = ast[0] - if isinstance(a0, MalSym): - if not env.find(a0) is None: - return env.get(a0).ismacro - return False - -def macroexpand(ast, env): - while is_macro_call(ast, env): - assert isinstance(ast[0], MalSym) - mac = env.get(ast[0]) - ast = macroexpand(mac.apply(ast.rest()), env) - return ast - -def eval_ast(ast, env): - if types._symbol_Q(ast): - assert isinstance(ast, MalSym) - return env.get(ast) - elif types._list_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalList(res) - elif types._vector_Q(ast): - res = [] - for a in ast.values: - res.append(EVAL(a, env)) - return MalVector(res) - elif types._hash_map_Q(ast): - new_dct = {} - for k in ast.dct.keys(): - new_dct[k] = EVAL(ast.dct[k], env) - return MalHashMap(new_dct) - else: - return ast # primitive value, return unchanged - -def EVAL(ast, env): - while True: - #print("EVAL %s" % printer._pr_str(ast)) - if not types._list_Q(ast): - return eval_ast(ast, env) - if len(ast) == 0: return ast - - # apply list - ast = macroexpand(ast, env) - if not types._list_Q(ast): - return eval_ast(ast, env) - if len(ast) == 0: return ast - a0 = ast[0] - if isinstance(a0, MalSym): - a0sym = a0.value - else: - a0sym = u"__<*fn*>__" - - if u"def!" == a0sym: - a1, a2 = ast[1], ast[2] - res = EVAL(a2, env) - return env.set(a1, res) - elif u"let*" == a0sym: - a1, a2 = ast[1], ast[2] - let_env = Env(env) - for i in range(0, len(a1), 2): - let_env.set(a1[i], EVAL(a1[i+1], let_env)) - ast = a2 - env = let_env # Continue loop (TCO) - elif u"quote" == a0sym: - return ast[1] - elif u"quasiquoteexpand" == a0sym: - return quasiquote(ast[1]) - elif u"quasiquote" == a0sym: - ast = quasiquote(ast[1]) # Continue loop (TCO) - elif u"defmacro!" == a0sym: - func = EVAL(ast[2], env) - func.ismacro = True - return env.set(ast[1], func) - elif u"macroexpand" == a0sym: - return macroexpand(ast[1], env) - elif u"try*" == a0sym: - if len(ast) < 3: - return EVAL(ast[1], env); - a1, a2 = ast[1], ast[2] - a20 = a2[0] - if isinstance(a20, MalSym): - if a20.value == u"catch*": - try: - return EVAL(a1, env); - except types.MalException as exc: - exc = exc.object - catch_env = Env(env, _list(a2[1]), _list(exc)) - return EVAL(a2[2], catch_env) - except Exception as exc: - exc = MalStr(unicode("%s" % exc)) - catch_env = Env(env, _list(a2[1]), _list(exc)) - return EVAL(a2[2], catch_env) - return EVAL(a1, env); - elif u"do" == a0sym: - if len(ast) == 0: - return nil - elif len(ast) > 1: - eval_ast(ast.slice2(1, len(ast)-1), env) - ast = ast[-1] # Continue loop (TCO) - elif u"if" == a0sym: - a1, a2 = ast[1], ast[2] - cond = EVAL(a1, env) - if cond is nil or cond is false: - if len(ast) > 3: ast = ast[3] # Continue loop (TCO) - else: return nil - else: - ast = a2 # Continue loop (TCO) - elif u"fn*" == a0sym: - a1, a2 = ast[1], ast[2] - return MalFunc(None, a2, env, a1, EVAL) - else: - el = eval_ast(ast, env) - f = el.values[0] - if isinstance(f, MalFunc): - if f.ast: - ast = f.ast - env = f.gen_env(el.rest()) # Continue loop (TCO) - else: - return f.apply(el.rest()) - else: - raise Exception("%s is not callable" % f) - -# print -def PRINT(exp): - return printer._pr_str(exp) - -# repl -class MalEval(MalFunc): - def apply(self, args): - return self.EvalFunc(args[0], self.env) - -def entry_point(argv): - repl_env = Env() - def REP(str, env): - return PRINT(EVAL(READ(str), env)) - - # core.py: defined using python - for k, v in core.ns.items(): - repl_env.set(_symbol(unicode(k)), MalFunc(v)) - repl_env.set(types._symbol(u'eval'), - MalEval(None, env=repl_env, EvalFunc=EVAL)) - mal_args = [] - if len(argv) >= 3: - for a in argv[2:]: mal_args.append(MalStr(unicode(a))) - repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) - - # core.mal: defined using the language itself - REP("(def! *host-language* \"rpython\")", repl_env) - REP("(def! not (fn* (a) (if a false true)))", repl_env) - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - 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)))))))", repl_env) - - if len(argv) >= 2: - REP('(load-file "' + argv[1] + '")', repl_env) - return 0 - - REP("(println (str \"Mal [\" *host-language* \"]\"))", repl_env) - while True: - try: - line = mal_readline.readline("user> ") - if line == "": continue - print(REP(line, repl_env)) - except EOFError as e: - break - except reader.Blank: - continue - except types.MalException as e: - print(u"Error: %s" % printer._pr_str(e.object, False)) - except Exception as e: - print("Error: %s" % e) - if IS_RPYTHON: - llop.debug_print_traceback(lltype.Void) - else: - print("".join(traceback.format_exception(*sys.exc_info()))) - return 0 - -# _____ Define and setup target ___ -def target(*args): - return entry_point - -# Just run entry_point if not RPython compilation -import sys -if not sys.argv[0].endswith('rpython'): - entry_point(sys.argv) +import sys +IS_RPYTHON = sys.argv[0].endswith('rpython') + +if IS_RPYTHON: + #from rpython.rlib.debug import fatalerror + from rpython.rtyper.lltypesystem import lltype + from rpython.rtyper.lltypesystem.lloperation import llop +else: + import traceback + +import mal_readline +import mal_types as types +from mal_types import (MalSym, MalInt, MalStr, + nil, true, false, _symbol, _keywordu, + MalList, _list, MalVector, MalHashMap, MalFunc) +import reader, printer +from env import Env +import core + +# read +def READ(str): + return reader.read_str(str) + +# eval +def qq_loop(elt, acc): + if types._list_Q(elt) and len(elt) == 2: + fst = elt[0] + if isinstance(fst, MalSym) and fst.value == u"splice-unquote": + return _list(_symbol(u"concat"), elt[1], acc) + return _list(_symbol(u"cons"), quasiquote(elt), acc) + +def qq_foldr(seq): + acc = _list() + for elt in reversed(seq): + acc = qq_loop (elt, acc) + return acc + +def quasiquote(ast): + if types._list_Q(ast): + if len(ast) == 2: + fst = ast[0] + if isinstance(fst, MalSym) and fst.value == u"unquote": + return ast[1] + return qq_foldr(ast.values) + elif types._vector_Q(ast): + return _list(_symbol(u"vec"), qq_foldr(ast.values)) + elif types._symbol_Q(ast) or types._hash_map_Q(ast): + return _list(_symbol(u"quote"), ast) + else: + return ast + +def is_macro_call(ast, env): + if types._list_Q(ast): + a0 = ast[0] + if isinstance(a0, MalSym): + if not env.find(a0) is None: + return env.get(a0).ismacro + return False + +def macroexpand(ast, env): + while is_macro_call(ast, env): + assert isinstance(ast[0], MalSym) + mac = env.get(ast[0]) + ast = macroexpand(mac.apply(ast.rest()), env) + return ast + +def eval_ast(ast, env): + if types._symbol_Q(ast): + assert isinstance(ast, MalSym) + return env.get(ast) + elif types._list_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalList(res) + elif types._vector_Q(ast): + res = [] + for a in ast.values: + res.append(EVAL(a, env)) + return MalVector(res) + elif types._hash_map_Q(ast): + new_dct = {} + for k in ast.dct.keys(): + new_dct[k] = EVAL(ast.dct[k], env) + return MalHashMap(new_dct) + else: + return ast # primitive value, return unchanged + +def EVAL(ast, env): + while True: + #print("EVAL %s" % printer._pr_str(ast)) + if not types._list_Q(ast): + return eval_ast(ast, env) + if len(ast) == 0: return ast + + # apply list + ast = macroexpand(ast, env) + if not types._list_Q(ast): + return eval_ast(ast, env) + if len(ast) == 0: return ast + a0 = ast[0] + if isinstance(a0, MalSym): + a0sym = a0.value + else: + a0sym = u"__<*fn*>__" + + if u"def!" == a0sym: + a1, a2 = ast[1], ast[2] + res = EVAL(a2, env) + return env.set(a1, res) + elif u"let*" == a0sym: + a1, a2 = ast[1], ast[2] + let_env = Env(env) + for i in range(0, len(a1), 2): + let_env.set(a1[i], EVAL(a1[i+1], let_env)) + ast = a2 + env = let_env # Continue loop (TCO) + elif u"quote" == a0sym: + return ast[1] + elif u"quasiquoteexpand" == a0sym: + return quasiquote(ast[1]) + elif u"quasiquote" == a0sym: + ast = quasiquote(ast[1]) # Continue loop (TCO) + elif u"defmacro!" == a0sym: + func = EVAL(ast[2], env) + func.ismacro = True + return env.set(ast[1], func) + elif u"macroexpand" == a0sym: + return macroexpand(ast[1], env) + elif u"try*" == a0sym: + if len(ast) < 3: + return EVAL(ast[1], env); + a1, a2 = ast[1], ast[2] + a20 = a2[0] + if isinstance(a20, MalSym): + if a20.value == u"catch*": + try: + return EVAL(a1, env); + except types.MalException as exc: + exc = exc.object + catch_env = Env(env, _list(a2[1]), _list(exc)) + return EVAL(a2[2], catch_env) + except Exception as exc: + exc = MalStr(unicode("%s" % exc)) + catch_env = Env(env, _list(a2[1]), _list(exc)) + return EVAL(a2[2], catch_env) + return EVAL(a1, env); + elif u"do" == a0sym: + if len(ast) == 0: + return nil + elif len(ast) > 1: + eval_ast(ast.slice2(1, len(ast)-1), env) + ast = ast[-1] # Continue loop (TCO) + elif u"if" == a0sym: + a1, a2 = ast[1], ast[2] + cond = EVAL(a1, env) + if cond is nil or cond is false: + if len(ast) > 3: ast = ast[3] # Continue loop (TCO) + else: return nil + else: + ast = a2 # Continue loop (TCO) + elif u"fn*" == a0sym: + a1, a2 = ast[1], ast[2] + return MalFunc(None, a2, env, a1, EVAL) + else: + el = eval_ast(ast, env) + f = el.values[0] + if isinstance(f, MalFunc): + if f.ast: + ast = f.ast + env = f.gen_env(el.rest()) # Continue loop (TCO) + else: + return f.apply(el.rest()) + else: + raise Exception("%s is not callable" % f) + +# print +def PRINT(exp): + return printer._pr_str(exp) + +# repl +class MalEval(MalFunc): + def apply(self, args): + return self.EvalFunc(args[0], self.env) + +def entry_point(argv): + repl_env = Env() + def REP(str, env): + return PRINT(EVAL(READ(str), env)) + + # core.py: defined using python + for k, v in core.ns.items(): + repl_env.set(_symbol(unicode(k)), MalFunc(v)) + repl_env.set(types._symbol(u'eval'), + MalEval(None, env=repl_env, EvalFunc=EVAL)) + mal_args = [] + if len(argv) >= 3: + for a in argv[2:]: mal_args.append(MalStr(unicode(a))) + repl_env.set(_symbol(u'*ARGV*'), MalList(mal_args)) + + # core.mal: defined using the language itself + REP("(def! *host-language* \"rpython\")", repl_env) + REP("(def! not (fn* (a) (if a false true)))", repl_env) + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + 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)))))))", repl_env) + + if len(argv) >= 2: + REP('(load-file "' + argv[1] + '")', repl_env) + return 0 + + REP("(println (str \"Mal [\" *host-language* \"]\"))", repl_env) + while True: + try: + line = mal_readline.readline("user> ") + if line == "": continue + print(REP(line, repl_env)) + except EOFError as e: + break + except reader.Blank: + continue + except types.MalException as e: + print(u"Error: %s" % printer._pr_str(e.object, False)) + except Exception as e: + print("Error: %s" % e) + if IS_RPYTHON: + llop.debug_print_traceback(lltype.Void) + else: + print("".join(traceback.format_exception(*sys.exc_info()))) + return 0 + +# _____ Define and setup target ___ +def target(*args): + return entry_point + +# Just run entry_point if not RPython compilation +import sys +if not sys.argv[0].endswith('rpython'): + entry_point(sys.argv) diff --git a/impls/rpython/tests/step5_tco.mal b/impls/rpython/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/rpython/tests/step5_tco.mal +++ b/impls/rpython/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/ruby.2/Dockerfile b/impls/ruby.2/Dockerfile index 3c2786c33d..a61f7b652b 100644 --- a/impls/ruby.2/Dockerfile +++ b/impls/ruby.2/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:20.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install ruby +FROM ubuntu:20.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install ruby diff --git a/impls/ruby.2/Makefile b/impls/ruby.2/Makefile index 9e87fdd142..18e2d5969d 100644 --- a/impls/ruby.2/Makefile +++ b/impls/ruby.2/Makefile @@ -1,19 +1,19 @@ -SOURCES_BASE = errors.rb types.rb reader.rb printer.rb -SOURCES_LISP = env.rb core.rb stepA_mal.rb -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.rb mal - -mal.rb: $(SOURCES) - cat $+ | grep -v "^require_relative" > $@ - -mal: mal.rb - echo "#!/usr/bin/env ruby" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.rb mal +SOURCES_BASE = errors.rb types.rb reader.rb printer.rb +SOURCES_LISP = env.rb core.rb stepA_mal.rb +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.rb mal + +mal.rb: $(SOURCES) + cat $+ | grep -v "^require_relative" > $@ + +mal: mal.rb + echo "#!/usr/bin/env ruby" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.rb mal diff --git a/impls/ruby.2/core.rb b/impls/ruby.2/core.rb index 70452cca23..48bf18ff0b 100644 --- a/impls/ruby.2/core.rb +++ b/impls/ruby.2/core.rb @@ -1,535 +1,535 @@ -require "readline" - -require_relative "types" - -module Mal - module Core - extend self - - def ns - { - Types::Symbol.for("+") => Types::Builtin.new("+") do |a, b| - a + b - end, - - Types::Symbol.for("-") => Types::Builtin.new("-") { |a, b| a - b }, - Types::Symbol.for("*") => Types::Builtin.new("*") { |a, b| a * b }, - Types::Symbol.for("/") => Types::Builtin.new("/") { |a, b| a / b }, - - Types::Symbol.for("list") => Types::Builtin.new("list") do |*mal| - list = Types::List.new - mal.each { |m| list << m } - list - end, - - Types::Symbol.for("list?") => Types::Builtin.new("list?") do |list = nil| - list.is_a?(Types::List) ? Types::True.instance : Types::False.instance - end, - - Types::Symbol.for("vector?") => Types::Builtin.new("vector?") do |vector = nil| - vector.is_a?(Types::Vector) ? Types::True.instance : Types::False.instance - end, - - Types::Symbol.for("string?") => Types::Builtin.new("string?") do |string = nil| - string.is_a?(Types::String) ? Types::True.instance : Types::False.instance - end, - - Types::Symbol.for("number?") => Types::Builtin.new("number?") do |number = nil| - number.is_a?(Types::Number) ? Types::True.instance : Types::False.instance - end, - - Types::Symbol.for("fn?") => Types::Builtin.new("fn?") do |fn = nil| - fn.is_a?(Types::Callable) && !fn.is_macro? ? Types::True.instance : Types::False.instance - end, - - Types::Symbol.for("macro?") => Types::Builtin.new("macro?") do |macro = nil| - macro.is_a?(Types::Callable) && macro.is_macro? ? Types::True.instance : Types::False.instance - end, - - Types::Symbol.for("empty?") => Types::Builtin.new("empty?") do |list_or_vector = nil| - is_empty = - case list_or_vector - when Types::List, Types::Vector - list_or_vector.empty? - else - true - end - - is_empty ? Types::True.instance : Types::False.instance - end, - - Types::Symbol.for("count") => Types::Builtin.new("count") do |*mal| - count = - if mal.any? - case mal.first - when Types::List, Types::Vector - mal.first.size - else - 0 - end - else - 0 - end - - Types::Number.new(count) - end, - - Types::Symbol.for("=") => Types::Builtin.new("=") do |a, b| - if a.nil? || b.nil? - Types::False.instance - else - if a == b - Types::True.instance - else - Types::False.instance - end - end - end, - - Types::Symbol.for("<") => Types::Builtin.new("<") do |a, b| - if a.nil? || b.nil? - Types::False.instance - else - if a.is_a?(Types::Number) && b.is_a?(Types::Number) - if a.value < b.value - Types::True.instance - else - Types::False.instance - end - else - Types::False.instance - end - end - end, - - Types::Symbol.for("<=") => Types::Builtin.new("<=") do |a, b| - if a.nil? || b.nil? - Types::False.instance - else - if a.is_a?(Types::Number) && b.is_a?(Types::Number) - if a.value <= b.value - Types::True.instance - else - Types::False.instance - end - else - Types::False.instance - end - end - end, - - Types::Symbol.for(">") => Types::Builtin.new(">") do |a, b| - if a.nil? || b.nil? - Types::False.instance - else - if a.is_a?(Types::Number) && b.is_a?(Types::Number) - if a.value > b.value - Types::True.instance - else - Types::False.instance - end - else - Types::False.instance - end - end - end, - - Types::Symbol.for(">=") => Types::Builtin.new(">=") do |a, b| - if a.nil? || b.nil? - Types::False.instance - else - if a.is_a?(Types::Number) && b.is_a?(Types::Number) - if a.value >= b.value - Types::True.instance - else - Types::False.instance - end - else - Types::False.instance - end - end - end, - - Types::Symbol.for("pr-str") => Types::Builtin.new("pr-str") do |*mal| - Types::String.new(mal.map { |m| Mal.pr_str(m, true) }.join(" ")) - end, - - Types::Symbol.for("str") => Types::Builtin.new("str") do |*mal| - Types::String.new(mal.map { |m| Mal.pr_str(m, false) }.join("")) - end, - - Types::Symbol.for("prn") => Types::Builtin.new("prn") do |*mal| - puts mal.map { |m| Mal.pr_str(m, true) }.join(" ") - Types::Nil.instance - end, - - Types::Symbol.for("println") => Types::Builtin.new("println") do |*mal| - puts mal.map { |m| Mal.pr_str(m, false) }.join(" ") - Types::Nil.instance - end, - - Types::Symbol.for("read-string") => Types::Builtin.new("read-string") do |string = nil| - if string.is_a?(Types::String) - Mal.read_str(string.value) - else - Types::Nil.instance - end - end, - - Types::Symbol.for("slurp") => Types::Builtin.new("slurp") do |file = nil| - if file.is_a?(Types::String) - if File.exist?(file.value) - Types::String.new(File.read(file.value)) - else - raise FileNotFoundError, file.value - end - else - Types::Nil.instance - end - end, - - Types::Symbol.for("atom") => Types::Builtin.new("atom") do |mal| - Types::Atom.new(mal) - end, - - Types::Symbol.for("atom?") => Types::Builtin.new("atom?") do |maybe_atom| - maybe_atom.is_a?(Types::Atom) ? Types::True.instance : Types::False.instance - end, - - Types::Symbol.for("deref") => Types::Builtin.new("deref") do |maybe_atom| - maybe_atom.is_a?(Types::Atom) ? maybe_atom.value : Types::Nil.instance - end, - - Types::Symbol.for("reset!") => Types::Builtin.new("reset!") do |atom, value| - if value.nil? - value = Types::Nil.instance - end - - atom.value = value - end, - - Types::Symbol.for("swap!") => Types::Builtin.new("swap!") do |atom, fn, *args| - atom.value = fn.call(Types::Args.new([atom.value, *args])) - end, - - Types::Symbol.for("cons") => Types::Builtin.new("cons") do |val, list_or_vector| - Types::List.new([val, *list_or_vector]) - end, - - Types::Symbol.for("concat") => Types::Builtin.new("concat") do |*mal| - list = Types::List.new - - mal.each do |l| - list.concat(l) - end - - list - end, - - Types::Symbol.for("vec") => Types::Builtin.new("vec") do |list_or_vector| - case list_or_vector - when Types::List - vec = Types::Vector.new - - list_or_vector.each do |m| - vec << m - end - - vec - when Types::Vector - list_or_vector - else - raise TypeError, "invalid `vec` arguments, must be vector or list" - end - end, - - Types::Symbol.for("nth") => Types::Builtin.new("nth") do |list_or_vector, index| - result = list_or_vector[index.value] - raise IndexError, "Index #{index.value} is out of bounds" if result.nil? - result - end, - - Types::Symbol.for("first") => Types::Builtin.new("first") do |list_or_vector| - if !list_or_vector.nil? && list_or_vector != Types::Nil.instance - result = list_or_vector.first - - if result.nil? - result = Types::Nil.instance - end - - result - else - Types::Nil.instance - end - end, - - Types::Symbol.for("rest") => Types::Builtin.new("rest") do |list_or_vector| - if !list_or_vector.nil? && list_or_vector != Types::Nil.instance - result = list_or_vector[1..] - - if result.nil? - result = Types::List.new - end - - result.to_list - else - Types::List.new - end - end, - - Types::Symbol.for("throw") => Types::Builtin.new("throw") do |to_throw| - raise MalError, to_throw - end, - - Types::Symbol.for("apply") => Types::Builtin.new("apply") do |fn, *rest| - args = Types::Args.new - - rest.flatten(1).each do |a| - args << a - end - - fn.call(args) - end, - - Types::Symbol.for("map") => Types::Builtin.new("map") do |fn, *rest| - results = Types::List.new - - rest.flatten(1).each do |a| - results << fn.call(Types::Args.new([a])) - end - - results - end, - - Types::Symbol.for("nil?") => Types::Builtin.new("nil?") do |mal| - if mal == Types::Nil.instance - Types::True.instance - else - Types::False.instance - end - end, - - Types::Symbol.for("true?") => Types::Builtin.new("true?") do |mal| - if mal == Types::True.instance - Types::True.instance - else - Types::False.instance - end - end, - - Types::Symbol.for("false?") => Types::Builtin.new("false?") do |mal| - if mal == Types::False.instance - Types::True.instance - else - Types::False.instance - end - end, - - Types::Symbol.for("symbol?") => Types::Builtin.new("symbol?") do |mal| - if mal.is_a?(Types::Symbol) - Types::True.instance - else - Types::False.instance - end - end, - - Types::Symbol.for("keyword?") => Types::Builtin.new("keyword?") do |mal| - if mal.is_a?(Types::Keyword) - Types::True.instance - else - Types::False.instance - end - end, - - Types::Symbol.for("symbol") => Types::Builtin.new("symbol") do |string| - if string - Types::Symbol.for(string.value) - else - Types::Nil.instance - end - end, - - Types::Symbol.for("keyword") => Types::Builtin.new("keyword") do |keyword| - if keyword - Types::Keyword.for(keyword.value) - else - Types::Nil.instance - end - end, - - Types::Symbol.for("vector") => Types::Builtin.new("vector") do |*items| - vector = Types::Vector.new - - items.each do |i| - vector << i - end - - vector - end, - - Types::Symbol.for("sequential?") => Types::Builtin.new("sequential?") do |list_or_vector| - case list_or_vector - when Types::List, Types::Vector - Types::True.instance - else - Types::False.instance - end - end, - - Types::Symbol.for("hash-map") => Types::Builtin.new("hash-map") do |*items| - raise UnbalancedHashmapError, "unbalanced hashmap error, arguments must be even" if items&.size&.odd? - - hashmap = Types::Hashmap.new - - items.each_slice(2) do |(k, v)| - hashmap[k] = v - end - - hashmap - end, - - Types::Symbol.for("map?") => Types::Builtin.new("map?") do |mal| - if mal.is_a?(Types::Hashmap) - Types::True.instance - else - Types::False.instance - end - end, - - Types::Symbol.for("assoc") => Types::Builtin.new("assoc") do |hashmap, *items| - raise UnbalancedHashmapError, "unbalanced hashmap error, arguments must be even" if items.size&.odd? - - new_hashmap = hashmap.dup - - items.each_slice(2) do |(k, v)| - new_hashmap[k] = v - end - - new_hashmap - end, - - Types::Symbol.for("dissoc") => Types::Builtin.new("dissoc") do |hashmap, *keys| - new_hashmap = Types::Hashmap.new - - hashmap.keys.each do |k| - next if keys.include?(k) - new_hashmap[k] = hashmap[k] - end - - new_hashmap - end, - - Types::Symbol.for("get") => Types::Builtin.new("get") do |hashmap, key| - if Types::Hashmap === hashmap && key && hashmap.key?(key) - hashmap[key] - else - Types::Nil.instance - end - end, - - Types::Symbol.for("contains?") => Types::Builtin.new("contains?") do |hashmap, key| - if Types::Hashmap === hashmap && key && hashmap.key?(key) - Types::True.instance - else - Types::False.instance - end - end, - - Types::Symbol.for("keys") => Types::Builtin.new("keys") do |hashmap| - if Types::Hashmap === hashmap - Types::List.new(hashmap.keys) - else - Types::Nil.instance - end - end, - - Types::Symbol.for("vals") => Types::Builtin.new("vals") do |hashmap| - if Types::Hashmap === hashmap - Types::List.new(hashmap.values) - else - Types::Nil.instance - end - end, - - Types::Symbol.for("readline") => Types::Builtin.new("readline") do |prompt = nil| - prompt = - if prompt.nil? - "user> " - else - prompt.value - end - - input = Readline.readline(prompt) - - if input.nil? - Types::Nil.instance - else - Types::String.new(input) - end - end, - - Types::Symbol.for("meta") => Types::Builtin.new("meta") do |value| - case value - when Types::List, Types::Vector, Types::Hashmap, Types::Callable - value.meta - else - Types::Nil.instance - end - end, - - Types::Symbol.for("with-meta") => Types::Builtin.new("with-meta") do |value, meta| - case value - when Types::List, Types::Vector, Types::Hashmap, Types::Callable - new_value = value.dup - new_value.meta = meta - new_value - else - raise TypeError, "Unable to use meta with #{Mal.pr_str(value)}" - end - end, - - Types::Symbol.for("time-ms") => Types::Builtin.new("time-ms") do - Types::Number.new((Time.now.to_f.round(3) * 1000).to_i) - end, - - Types::Symbol.for("conj") => Types::Builtin.new("conj") do |list_or_vector, *new_elems| - case list_or_vector - when Types::List - Types::List.new([*new_elems.reverse, *list_or_vector]) - when Types::Vector - Types::Vector.new([*list_or_vector, *new_elems]) - else - raise TypeError, "Unable to `conj` with <#{Mal.pr_str(list_or_vector)}>, must be list or vector" - end - end, - - Types::Symbol.for("seq") => Types::Builtin.new("seq") do |sequential| - case sequential - when Types::List - if sequential.any? - sequential - else - Types::Nil.instance - end - when Types::Vector - if sequential.any? - Types::List.new(sequential) - else - Types::Nil.instance - end - when Types::String - if !sequential.value.empty? - Types::List.new(sequential.value.chars.map { |c| Types::String.new(c) }) - else - Types::Nil.instance - end - when Types::Nil - Types::Nil.instance - else - raise TypeError, "Unable to `seq` with <#{Mal.pr_str(sequential)}>, must be list, vector, string, or nil" - end - end - } - end - end -end +require "readline" + +require_relative "types" + +module Mal + module Core + extend self + + def ns + { + Types::Symbol.for("+") => Types::Builtin.new("+") do |a, b| + a + b + end, + + Types::Symbol.for("-") => Types::Builtin.new("-") { |a, b| a - b }, + Types::Symbol.for("*") => Types::Builtin.new("*") { |a, b| a * b }, + Types::Symbol.for("/") => Types::Builtin.new("/") { |a, b| a / b }, + + Types::Symbol.for("list") => Types::Builtin.new("list") do |*mal| + list = Types::List.new + mal.each { |m| list << m } + list + end, + + Types::Symbol.for("list?") => Types::Builtin.new("list?") do |list = nil| + list.is_a?(Types::List) ? Types::True.instance : Types::False.instance + end, + + Types::Symbol.for("vector?") => Types::Builtin.new("vector?") do |vector = nil| + vector.is_a?(Types::Vector) ? Types::True.instance : Types::False.instance + end, + + Types::Symbol.for("string?") => Types::Builtin.new("string?") do |string = nil| + string.is_a?(Types::String) ? Types::True.instance : Types::False.instance + end, + + Types::Symbol.for("number?") => Types::Builtin.new("number?") do |number = nil| + number.is_a?(Types::Number) ? Types::True.instance : Types::False.instance + end, + + Types::Symbol.for("fn?") => Types::Builtin.new("fn?") do |fn = nil| + fn.is_a?(Types::Callable) && !fn.is_macro? ? Types::True.instance : Types::False.instance + end, + + Types::Symbol.for("macro?") => Types::Builtin.new("macro?") do |macro = nil| + macro.is_a?(Types::Callable) && macro.is_macro? ? Types::True.instance : Types::False.instance + end, + + Types::Symbol.for("empty?") => Types::Builtin.new("empty?") do |list_or_vector = nil| + is_empty = + case list_or_vector + when Types::List, Types::Vector + list_or_vector.empty? + else + true + end + + is_empty ? Types::True.instance : Types::False.instance + end, + + Types::Symbol.for("count") => Types::Builtin.new("count") do |*mal| + count = + if mal.any? + case mal.first + when Types::List, Types::Vector + mal.first.size + else + 0 + end + else + 0 + end + + Types::Number.new(count) + end, + + Types::Symbol.for("=") => Types::Builtin.new("=") do |a, b| + if a.nil? || b.nil? + Types::False.instance + else + if a == b + Types::True.instance + else + Types::False.instance + end + end + end, + + Types::Symbol.for("<") => Types::Builtin.new("<") do |a, b| + if a.nil? || b.nil? + Types::False.instance + else + if a.is_a?(Types::Number) && b.is_a?(Types::Number) + if a.value < b.value + Types::True.instance + else + Types::False.instance + end + else + Types::False.instance + end + end + end, + + Types::Symbol.for("<=") => Types::Builtin.new("<=") do |a, b| + if a.nil? || b.nil? + Types::False.instance + else + if a.is_a?(Types::Number) && b.is_a?(Types::Number) + if a.value <= b.value + Types::True.instance + else + Types::False.instance + end + else + Types::False.instance + end + end + end, + + Types::Symbol.for(">") => Types::Builtin.new(">") do |a, b| + if a.nil? || b.nil? + Types::False.instance + else + if a.is_a?(Types::Number) && b.is_a?(Types::Number) + if a.value > b.value + Types::True.instance + else + Types::False.instance + end + else + Types::False.instance + end + end + end, + + Types::Symbol.for(">=") => Types::Builtin.new(">=") do |a, b| + if a.nil? || b.nil? + Types::False.instance + else + if a.is_a?(Types::Number) && b.is_a?(Types::Number) + if a.value >= b.value + Types::True.instance + else + Types::False.instance + end + else + Types::False.instance + end + end + end, + + Types::Symbol.for("pr-str") => Types::Builtin.new("pr-str") do |*mal| + Types::String.new(mal.map { |m| Mal.pr_str(m, true) }.join(" ")) + end, + + Types::Symbol.for("str") => Types::Builtin.new("str") do |*mal| + Types::String.new(mal.map { |m| Mal.pr_str(m, false) }.join("")) + end, + + Types::Symbol.for("prn") => Types::Builtin.new("prn") do |*mal| + puts mal.map { |m| Mal.pr_str(m, true) }.join(" ") + Types::Nil.instance + end, + + Types::Symbol.for("println") => Types::Builtin.new("println") do |*mal| + puts mal.map { |m| Mal.pr_str(m, false) }.join(" ") + Types::Nil.instance + end, + + Types::Symbol.for("read-string") => Types::Builtin.new("read-string") do |string = nil| + if string.is_a?(Types::String) + Mal.read_str(string.value) + else + Types::Nil.instance + end + end, + + Types::Symbol.for("slurp") => Types::Builtin.new("slurp") do |file = nil| + if file.is_a?(Types::String) + if File.exist?(file.value) + Types::String.new(File.read(file.value)) + else + raise FileNotFoundError, file.value + end + else + Types::Nil.instance + end + end, + + Types::Symbol.for("atom") => Types::Builtin.new("atom") do |mal| + Types::Atom.new(mal) + end, + + Types::Symbol.for("atom?") => Types::Builtin.new("atom?") do |maybe_atom| + maybe_atom.is_a?(Types::Atom) ? Types::True.instance : Types::False.instance + end, + + Types::Symbol.for("deref") => Types::Builtin.new("deref") do |maybe_atom| + maybe_atom.is_a?(Types::Atom) ? maybe_atom.value : Types::Nil.instance + end, + + Types::Symbol.for("reset!") => Types::Builtin.new("reset!") do |atom, value| + if value.nil? + value = Types::Nil.instance + end + + atom.value = value + end, + + Types::Symbol.for("swap!") => Types::Builtin.new("swap!") do |atom, fn, *args| + atom.value = fn.call(Types::Args.new([atom.value, *args])) + end, + + Types::Symbol.for("cons") => Types::Builtin.new("cons") do |val, list_or_vector| + Types::List.new([val, *list_or_vector]) + end, + + Types::Symbol.for("concat") => Types::Builtin.new("concat") do |*mal| + list = Types::List.new + + mal.each do |l| + list.concat(l) + end + + list + end, + + Types::Symbol.for("vec") => Types::Builtin.new("vec") do |list_or_vector| + case list_or_vector + when Types::List + vec = Types::Vector.new + + list_or_vector.each do |m| + vec << m + end + + vec + when Types::Vector + list_or_vector + else + raise TypeError, "invalid `vec` arguments, must be vector or list" + end + end, + + Types::Symbol.for("nth") => Types::Builtin.new("nth") do |list_or_vector, index| + result = list_or_vector[index.value] + raise IndexError, "Index #{index.value} is out of bounds" if result.nil? + result + end, + + Types::Symbol.for("first") => Types::Builtin.new("first") do |list_or_vector| + if !list_or_vector.nil? && list_or_vector != Types::Nil.instance + result = list_or_vector.first + + if result.nil? + result = Types::Nil.instance + end + + result + else + Types::Nil.instance + end + end, + + Types::Symbol.for("rest") => Types::Builtin.new("rest") do |list_or_vector| + if !list_or_vector.nil? && list_or_vector != Types::Nil.instance + result = list_or_vector[1..] + + if result.nil? + result = Types::List.new + end + + result.to_list + else + Types::List.new + end + end, + + Types::Symbol.for("throw") => Types::Builtin.new("throw") do |to_throw| + raise MalError, to_throw + end, + + Types::Symbol.for("apply") => Types::Builtin.new("apply") do |fn, *rest| + args = Types::Args.new + + rest.flatten(1).each do |a| + args << a + end + + fn.call(args) + end, + + Types::Symbol.for("map") => Types::Builtin.new("map") do |fn, *rest| + results = Types::List.new + + rest.flatten(1).each do |a| + results << fn.call(Types::Args.new([a])) + end + + results + end, + + Types::Symbol.for("nil?") => Types::Builtin.new("nil?") do |mal| + if mal == Types::Nil.instance + Types::True.instance + else + Types::False.instance + end + end, + + Types::Symbol.for("true?") => Types::Builtin.new("true?") do |mal| + if mal == Types::True.instance + Types::True.instance + else + Types::False.instance + end + end, + + Types::Symbol.for("false?") => Types::Builtin.new("false?") do |mal| + if mal == Types::False.instance + Types::True.instance + else + Types::False.instance + end + end, + + Types::Symbol.for("symbol?") => Types::Builtin.new("symbol?") do |mal| + if mal.is_a?(Types::Symbol) + Types::True.instance + else + Types::False.instance + end + end, + + Types::Symbol.for("keyword?") => Types::Builtin.new("keyword?") do |mal| + if mal.is_a?(Types::Keyword) + Types::True.instance + else + Types::False.instance + end + end, + + Types::Symbol.for("symbol") => Types::Builtin.new("symbol") do |string| + if string + Types::Symbol.for(string.value) + else + Types::Nil.instance + end + end, + + Types::Symbol.for("keyword") => Types::Builtin.new("keyword") do |keyword| + if keyword + Types::Keyword.for(keyword.value) + else + Types::Nil.instance + end + end, + + Types::Symbol.for("vector") => Types::Builtin.new("vector") do |*items| + vector = Types::Vector.new + + items.each do |i| + vector << i + end + + vector + end, + + Types::Symbol.for("sequential?") => Types::Builtin.new("sequential?") do |list_or_vector| + case list_or_vector + when Types::List, Types::Vector + Types::True.instance + else + Types::False.instance + end + end, + + Types::Symbol.for("hash-map") => Types::Builtin.new("hash-map") do |*items| + raise UnbalancedHashmapError, "unbalanced hashmap error, arguments must be even" if items&.size&.odd? + + hashmap = Types::Hashmap.new + + items.each_slice(2) do |(k, v)| + hashmap[k] = v + end + + hashmap + end, + + Types::Symbol.for("map?") => Types::Builtin.new("map?") do |mal| + if mal.is_a?(Types::Hashmap) + Types::True.instance + else + Types::False.instance + end + end, + + Types::Symbol.for("assoc") => Types::Builtin.new("assoc") do |hashmap, *items| + raise UnbalancedHashmapError, "unbalanced hashmap error, arguments must be even" if items.size&.odd? + + new_hashmap = hashmap.dup + + items.each_slice(2) do |(k, v)| + new_hashmap[k] = v + end + + new_hashmap + end, + + Types::Symbol.for("dissoc") => Types::Builtin.new("dissoc") do |hashmap, *keys| + new_hashmap = Types::Hashmap.new + + hashmap.keys.each do |k| + next if keys.include?(k) + new_hashmap[k] = hashmap[k] + end + + new_hashmap + end, + + Types::Symbol.for("get") => Types::Builtin.new("get") do |hashmap, key| + if Types::Hashmap === hashmap && key && hashmap.key?(key) + hashmap[key] + else + Types::Nil.instance + end + end, + + Types::Symbol.for("contains?") => Types::Builtin.new("contains?") do |hashmap, key| + if Types::Hashmap === hashmap && key && hashmap.key?(key) + Types::True.instance + else + Types::False.instance + end + end, + + Types::Symbol.for("keys") => Types::Builtin.new("keys") do |hashmap| + if Types::Hashmap === hashmap + Types::List.new(hashmap.keys) + else + Types::Nil.instance + end + end, + + Types::Symbol.for("vals") => Types::Builtin.new("vals") do |hashmap| + if Types::Hashmap === hashmap + Types::List.new(hashmap.values) + else + Types::Nil.instance + end + end, + + Types::Symbol.for("readline") => Types::Builtin.new("readline") do |prompt = nil| + prompt = + if prompt.nil? + "user> " + else + prompt.value + end + + input = Readline.readline(prompt) + + if input.nil? + Types::Nil.instance + else + Types::String.new(input) + end + end, + + Types::Symbol.for("meta") => Types::Builtin.new("meta") do |value| + case value + when Types::List, Types::Vector, Types::Hashmap, Types::Callable + value.meta + else + Types::Nil.instance + end + end, + + Types::Symbol.for("with-meta") => Types::Builtin.new("with-meta") do |value, meta| + case value + when Types::List, Types::Vector, Types::Hashmap, Types::Callable + new_value = value.dup + new_value.meta = meta + new_value + else + raise TypeError, "Unable to use meta with #{Mal.pr_str(value)}" + end + end, + + Types::Symbol.for("time-ms") => Types::Builtin.new("time-ms") do + Types::Number.new((Time.now.to_f.round(3) * 1000).to_i) + end, + + Types::Symbol.for("conj") => Types::Builtin.new("conj") do |list_or_vector, *new_elems| + case list_or_vector + when Types::List + Types::List.new([*new_elems.reverse, *list_or_vector]) + when Types::Vector + Types::Vector.new([*list_or_vector, *new_elems]) + else + raise TypeError, "Unable to `conj` with <#{Mal.pr_str(list_or_vector)}>, must be list or vector" + end + end, + + Types::Symbol.for("seq") => Types::Builtin.new("seq") do |sequential| + case sequential + when Types::List + if sequential.any? + sequential + else + Types::Nil.instance + end + when Types::Vector + if sequential.any? + Types::List.new(sequential) + else + Types::Nil.instance + end + when Types::String + if !sequential.value.empty? + Types::List.new(sequential.value.chars.map { |c| Types::String.new(c) }) + else + Types::Nil.instance + end + when Types::Nil + Types::Nil.instance + else + raise TypeError, "Unable to `seq` with <#{Mal.pr_str(sequential)}>, must be list, vector, string, or nil" + end + end + } + end + end +end diff --git a/impls/ruby.2/env.rb b/impls/ruby.2/env.rb index e6bb765bbd..c7981fe26e 100644 --- a/impls/ruby.2/env.rb +++ b/impls/ruby.2/env.rb @@ -1,54 +1,54 @@ -require_relative "errors" -require_relative "types" - -module Mal - class Env - def initialize(outer = nil, binds = Types::List.new, exprs = Types::List.new) - @outer = outer - @data = {} - - spread_next = false - binds.each_with_index do |b, i| - if b.value == "&" - spread_next = true - else - if spread_next - set(b, Types::List.new(exprs[(i - 1)..]) || Types::Nil.instance) - break - else - set(b, exprs[i] || Types::Nil.instance) - end - end - end - end - - def set(k, v) - @data[k] = v - end - - def find(k) - if @data.key?(k) - self - elsif !@outer.nil? - @outer.find(k) - else - Types::Nil.instance - end - end - - def get(k) - environment = find(k) - - case environment - when self.class - environment.get_value(k) - when Types::Nil - raise SymbolNotFoundError, "'#{k.value}' not found" - end - end - - def get_value(k) - @data[k] - end - end -end +require_relative "errors" +require_relative "types" + +module Mal + class Env + def initialize(outer = nil, binds = Types::List.new, exprs = Types::List.new) + @outer = outer + @data = {} + + spread_next = false + binds.each_with_index do |b, i| + if b.value == "&" + spread_next = true + else + if spread_next + set(b, Types::List.new(exprs[(i - 1)..]) || Types::Nil.instance) + break + else + set(b, exprs[i] || Types::Nil.instance) + end + end + end + end + + def set(k, v) + @data[k] = v + end + + def find(k) + if @data.key?(k) + self + elsif !@outer.nil? + @outer.find(k) + else + Types::Nil.instance + end + end + + def get(k) + environment = find(k) + + case environment + when self.class + environment.get_value(k) + when Types::Nil + raise SymbolNotFoundError, "'#{k.value}' not found" + end + end + + def get_value(k) + @data[k] + end + end +end diff --git a/impls/ruby.2/errors.rb b/impls/ruby.2/errors.rb index 71bd718224..c9260af25c 100644 --- a/impls/ruby.2/errors.rb +++ b/impls/ruby.2/errors.rb @@ -1,53 +1,53 @@ -module Mal - class Error < ::StandardError; end - class TypeError < ::TypeError; end - - class MalError < Error - attr_reader :value - - def initialize(value) - @value = value - end - - def message - value.inspect - end - end - - class FileNotFoundError < Error; end - class IndexError < TypeError; end - class SkipCommentError < Error; end - - class InvalidHashmapKeyError < TypeError; end - class InvalidIfExpressionError < TypeError; end - class InvalidLetBindingsError < TypeError; end - class InvalidReaderPositionError < Error; end - class InvalidTypeError < TypeError; end - - class NotCallableError < Error; end - - class SymbolNotFoundError < Error; end - class SyntaxError < TypeError; end - - class UnbalancedEscapingError < Error; end - class UnbalancedHashmapError < Error; end - class UnbalancedListError < Error; end - class UnbalancedStringError < Error; end - class UnbalancedVectorError < Error; end - - class UnknownError < Error - attr_reader :original_error - - def initialize(original_error) - @original_error = original_error - end - - def inspect - "UnknownError :: #{original_error.inspect}" - end - - def message - "UnknownError<#{original_error.class}> :: #{original_error.message}" - end - end -end +module Mal + class Error < ::StandardError; end + class TypeError < ::TypeError; end + + class MalError < Error + attr_reader :value + + def initialize(value) + @value = value + end + + def message + value.inspect + end + end + + class FileNotFoundError < Error; end + class IndexError < TypeError; end + class SkipCommentError < Error; end + + class InvalidHashmapKeyError < TypeError; end + class InvalidIfExpressionError < TypeError; end + class InvalidLetBindingsError < TypeError; end + class InvalidReaderPositionError < Error; end + class InvalidTypeError < TypeError; end + + class NotCallableError < Error; end + + class SymbolNotFoundError < Error; end + class SyntaxError < TypeError; end + + class UnbalancedEscapingError < Error; end + class UnbalancedHashmapError < Error; end + class UnbalancedListError < Error; end + class UnbalancedStringError < Error; end + class UnbalancedVectorError < Error; end + + class UnknownError < Error + attr_reader :original_error + + def initialize(original_error) + @original_error = original_error + end + + def inspect + "UnknownError :: #{original_error.inspect}" + end + + def message + "UnknownError<#{original_error.class}> :: #{original_error.message}" + end + end +end diff --git a/impls/ruby.2/printer.rb b/impls/ruby.2/printer.rb index 256e5a058e..fcf8fa8982 100644 --- a/impls/ruby.2/printer.rb +++ b/impls/ruby.2/printer.rb @@ -1,55 +1,55 @@ -require_relative "errors" -require_relative "types" - -module Mal - extend self - - def pr_str(mal, print_readably = false) - case mal - when Types::List - "(#{mal.map { |m| pr_str(m, print_readably) }.join(" ")})" - when Types::Vector - "[#{mal.map { |m| pr_str(m, print_readably) }.join(" ")}]" - when Types::Hashmap - "{#{mal.map { |k, v| [pr_str(k, print_readably), pr_str(v, print_readably)].join(" ") }.join(" ")}}" - when Types::Keyword - if print_readably - pr_str_keyword(mal) - else - ":#{mal.value}" - end - when Types::String - if print_readably - pr_str_string(mal) - else - mal.value - end - when Types::Atom - "(atom #{pr_str(mal.value, print_readably)})" - when Types::Base, Types::Callable - mal.inspect - else - raise InvalidTypeError, "unable to print value <#{mal.inspect}>" - end - end - - def pr_str_keyword(mal) - value = mal.value.dup - - value.gsub!('\\','\\\\\\\\') - value.gsub!("\n",'\n') - value.gsub!('"','\"') - - ":#{value}" - end - - def pr_str_string(mal) - value = mal.value.dup - - value.gsub!('\\','\\\\\\\\') - value.gsub!("\n",'\n') - value.gsub!('"','\"') - - "\"#{value}\"" - end -end +require_relative "errors" +require_relative "types" + +module Mal + extend self + + def pr_str(mal, print_readably = false) + case mal + when Types::List + "(#{mal.map { |m| pr_str(m, print_readably) }.join(" ")})" + when Types::Vector + "[#{mal.map { |m| pr_str(m, print_readably) }.join(" ")}]" + when Types::Hashmap + "{#{mal.map { |k, v| [pr_str(k, print_readably), pr_str(v, print_readably)].join(" ") }.join(" ")}}" + when Types::Keyword + if print_readably + pr_str_keyword(mal) + else + ":#{mal.value}" + end + when Types::String + if print_readably + pr_str_string(mal) + else + mal.value + end + when Types::Atom + "(atom #{pr_str(mal.value, print_readably)})" + when Types::Base, Types::Callable + mal.inspect + else + raise InvalidTypeError, "unable to print value <#{mal.inspect}>" + end + end + + def pr_str_keyword(mal) + value = mal.value.dup + + value.gsub!('\\','\\\\\\\\') + value.gsub!("\n",'\n') + value.gsub!('"','\"') + + ":#{value}" + end + + def pr_str_string(mal) + value = mal.value.dup + + value.gsub!('\\','\\\\\\\\') + value.gsub!("\n",'\n') + value.gsub!('"','\"') + + "\"#{value}\"" + end +end diff --git a/impls/ruby.2/reader.rb b/impls/ruby.2/reader.rb index be572c61f5..03ce0424c3 100644 --- a/impls/ruby.2/reader.rb +++ b/impls/ruby.2/reader.rb @@ -1,268 +1,268 @@ -require_relative "errors" -require_relative "types" - -module Mal - extend self - - TOKEN_REGEX = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ - - def read_atom(reader) - case reader.peek - when /\A"(?:\\.|[^\\"])*"\z/ - read_string(reader) - when /\A"/ - raise UnbalancedStringError, "unbalanced string << #{reader.peek.inspect} >>" - when /\A:/ - read_keyword(reader) - when "nil" - read_nil(reader) - when "true" - read_true(reader) - when "false" - read_false(reader) - when /\A-?\d+(\.\d+)?/ - read_number(reader) - when /\A;/ - raise SkipCommentError - else - read_symbol(reader) - end - end - - def read_deref(reader) - list = Types::List.new - list << Types::Symbol.for("deref") - list << read_form(reader) - list - end - - def read_false(reader) - reader.advance! - Types::False.instance - end - - def read_form(reader) - case reader.peek - when "'" - read_quote(reader.advance!) - when "`" - read_quasiquote(reader.advance!) - when "~" - read_unquote(reader.advance!) - when "~@" - read_splice_unquote(reader.advance!) - when "@" - read_deref(reader.advance!) - when "^" - read_with_metadata(reader.advance!) - when "(" - read_list(reader.advance!) - when "[" - read_vector(reader.advance!) - when "{" - read_hashmap(reader.advance!) - else - read_atom(reader) - end - end - - def read_hashmap(reader) - hashmap = Types::Hashmap.new - - until reader.peek == "}" - key = read_form(reader) - - unless Types::String === key || Types::Keyword === key - raise InvalidHashmapKeyError, "invalid hashmap key, must be string or keyword" - end - - if reader.peek != "}" - value = read_form(reader) - else - raise UnbalancedHashmapError, "unbalanced hashmap error, missing closing '}'" - end - - hashmap[key] = value - end - - reader.advance! - hashmap - rescue Error => e - case e - when InvalidReaderPositionError - raise UnbalancedHashmapError, "unbalanced hashmap error, missing closing '}'" - else - raise e - end - end - - def read_keyword(reader) - value = reader.next.dup[1...] - substitute_escaped_chars!(value) - - Types::Keyword.for(value) - end - - def read_list(reader) - list = Types::List.new - - until reader.peek == ")" - list << read_form(reader) - end - - reader.advance! - list - rescue Error => e - case e - when InvalidReaderPositionError - raise UnbalancedListError, "unbalanced list error, missing closing ')'" - else - raise e - end - end - - def read_nil(reader) - reader.advance! - Types::Nil.instance - end - - def read_number(reader) - case reader.peek - when /\d+\.\d+/ - Types::Number.new(reader.next.to_f) - when /\d+/ - Types::Number.new(reader.next.to_i) - else - raise InvalidTypeError, "invalid number syntax, only supports integers/floats" - end - end - - def read_quasiquote(reader) - list = Types::List.new - list << Types::Symbol.for("quasiquote") - list << read_form(reader) - list - end - - def read_quote(reader) - list = Types::List.new - list << Types::Symbol.for("quote") - list << read_form(reader) - list - end - - def read_splice_unquote(reader) - list = Types::List.new - list << Types::Symbol.for("splice-unquote") - list << read_form(reader) - list - end - - def read_str(input) - tokenized = tokenize(input) - raise SkipCommentError if tokenized.empty? - read_form(Reader.new(tokenized)) - end - - def read_string(reader) - raw_value = reader.next.dup - - value = raw_value[1...-1] - substitute_escaped_chars!(value) - - if raw_value.length <= 1 || raw_value[-1] != '"' - raise UnbalancedStringError, "unbalanced string error, missing closing '\"'" - end - - Types::String.new(value) - end - - def read_symbol(reader) - Types::Symbol.for(reader.next) - end - - def read_true(reader) - reader.advance! - Types::True.instance - end - - def read_unquote(reader) - list = Types::List.new - list << Types::Symbol.for("unquote") - list << read_form(reader) - list - end - - def read_vector(reader) - vector = Types::Vector.new - - until reader.peek == "]" - vector << read_form(reader) - end - - reader.advance! - vector - rescue Error => e - case e - when InvalidReaderPositionError - raise UnbalancedVectorError, "unbalanced vector error, missing closing ']'" - else - raise e - end - end - - def read_with_metadata(reader) - list = Types::List.new - list << Types::Symbol.for("with-meta") - - first = read_form(reader) - second = read_form(reader) - - list << second - list << first - - list - end - - def tokenize(input) - input.scan(TOKEN_REGEX).flatten.each_with_object([]) do |token, tokens| - if token != "" && !token.start_with?(";") - tokens << token - end - end - end - - class Reader - attr_reader :tokens - - def initialize(tokens) - @position = 0 - @tokens = tokens - end - - def advance! - @position += 1 - self - end - - def next - value = peek - @position += 1 - value - end - - def peek - if @position > @tokens.size - 1 - raise InvalidReaderPositionError, "invalid reader position error, unable to parse mal expression" - end - - @tokens[@position] - end - end - - private - - def substitute_escaped_chars!(string_or_keyword) - string_or_keyword.gsub!(/\\./, {"\\\\" => "\\", "\\n" => "\n", "\\\"" => '"'}) - end -end +require_relative "errors" +require_relative "types" + +module Mal + extend self + + TOKEN_REGEX = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ + + def read_atom(reader) + case reader.peek + when /\A"(?:\\.|[^\\"])*"\z/ + read_string(reader) + when /\A"/ + raise UnbalancedStringError, "unbalanced string << #{reader.peek.inspect} >>" + when /\A:/ + read_keyword(reader) + when "nil" + read_nil(reader) + when "true" + read_true(reader) + when "false" + read_false(reader) + when /\A-?\d+(\.\d+)?/ + read_number(reader) + when /\A;/ + raise SkipCommentError + else + read_symbol(reader) + end + end + + def read_deref(reader) + list = Types::List.new + list << Types::Symbol.for("deref") + list << read_form(reader) + list + end + + def read_false(reader) + reader.advance! + Types::False.instance + end + + def read_form(reader) + case reader.peek + when "'" + read_quote(reader.advance!) + when "`" + read_quasiquote(reader.advance!) + when "~" + read_unquote(reader.advance!) + when "~@" + read_splice_unquote(reader.advance!) + when "@" + read_deref(reader.advance!) + when "^" + read_with_metadata(reader.advance!) + when "(" + read_list(reader.advance!) + when "[" + read_vector(reader.advance!) + when "{" + read_hashmap(reader.advance!) + else + read_atom(reader) + end + end + + def read_hashmap(reader) + hashmap = Types::Hashmap.new + + until reader.peek == "}" + key = read_form(reader) + + unless Types::String === key || Types::Keyword === key + raise InvalidHashmapKeyError, "invalid hashmap key, must be string or keyword" + end + + if reader.peek != "}" + value = read_form(reader) + else + raise UnbalancedHashmapError, "unbalanced hashmap error, missing closing '}'" + end + + hashmap[key] = value + end + + reader.advance! + hashmap + rescue Error => e + case e + when InvalidReaderPositionError + raise UnbalancedHashmapError, "unbalanced hashmap error, missing closing '}'" + else + raise e + end + end + + def read_keyword(reader) + value = reader.next.dup[1...] + substitute_escaped_chars!(value) + + Types::Keyword.for(value) + end + + def read_list(reader) + list = Types::List.new + + until reader.peek == ")" + list << read_form(reader) + end + + reader.advance! + list + rescue Error => e + case e + when InvalidReaderPositionError + raise UnbalancedListError, "unbalanced list error, missing closing ')'" + else + raise e + end + end + + def read_nil(reader) + reader.advance! + Types::Nil.instance + end + + def read_number(reader) + case reader.peek + when /\d+\.\d+/ + Types::Number.new(reader.next.to_f) + when /\d+/ + Types::Number.new(reader.next.to_i) + else + raise InvalidTypeError, "invalid number syntax, only supports integers/floats" + end + end + + def read_quasiquote(reader) + list = Types::List.new + list << Types::Symbol.for("quasiquote") + list << read_form(reader) + list + end + + def read_quote(reader) + list = Types::List.new + list << Types::Symbol.for("quote") + list << read_form(reader) + list + end + + def read_splice_unquote(reader) + list = Types::List.new + list << Types::Symbol.for("splice-unquote") + list << read_form(reader) + list + end + + def read_str(input) + tokenized = tokenize(input) + raise SkipCommentError if tokenized.empty? + read_form(Reader.new(tokenized)) + end + + def read_string(reader) + raw_value = reader.next.dup + + value = raw_value[1...-1] + substitute_escaped_chars!(value) + + if raw_value.length <= 1 || raw_value[-1] != '"' + raise UnbalancedStringError, "unbalanced string error, missing closing '\"'" + end + + Types::String.new(value) + end + + def read_symbol(reader) + Types::Symbol.for(reader.next) + end + + def read_true(reader) + reader.advance! + Types::True.instance + end + + def read_unquote(reader) + list = Types::List.new + list << Types::Symbol.for("unquote") + list << read_form(reader) + list + end + + def read_vector(reader) + vector = Types::Vector.new + + until reader.peek == "]" + vector << read_form(reader) + end + + reader.advance! + vector + rescue Error => e + case e + when InvalidReaderPositionError + raise UnbalancedVectorError, "unbalanced vector error, missing closing ']'" + else + raise e + end + end + + def read_with_metadata(reader) + list = Types::List.new + list << Types::Symbol.for("with-meta") + + first = read_form(reader) + second = read_form(reader) + + list << second + list << first + + list + end + + def tokenize(input) + input.scan(TOKEN_REGEX).flatten.each_with_object([]) do |token, tokens| + if token != "" && !token.start_with?(";") + tokens << token + end + end + end + + class Reader + attr_reader :tokens + + def initialize(tokens) + @position = 0 + @tokens = tokens + end + + def advance! + @position += 1 + self + end + + def next + value = peek + @position += 1 + value + end + + def peek + if @position > @tokens.size - 1 + raise InvalidReaderPositionError, "invalid reader position error, unable to parse mal expression" + end + + @tokens[@position] + end + end + + private + + def substitute_escaped_chars!(string_or_keyword) + string_or_keyword.gsub!(/\\./, {"\\\\" => "\\", "\\n" => "\n", "\\\"" => '"'}) + end +end diff --git a/impls/ruby.2/run b/impls/ruby.2/run index 000320bf5f..8419c1022a 100755 --- a/impls/ruby.2/run +++ b/impls/ruby.2/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec ruby $(dirname $0)/${STEP:-stepA_mal}.rb "${@}" +#!/bin/bash +exec ruby $(dirname $0)/${STEP:-stepA_mal}.rb "${@}" diff --git a/impls/ruby.2/step0_repl.rb b/impls/ruby.2/step0_repl.rb index de1e08ec78..96b0822dff 100644 --- a/impls/ruby.2/step0_repl.rb +++ b/impls/ruby.2/step0_repl.rb @@ -1,25 +1,25 @@ -require "readline" - -module Mal - extend self - - def READ(input) - input - end - - def EVAL(input) - input - end - - def PRINT(input) - input - end - - def rep(input) - PRINT(EVAL(READ(input))) - end -end - -while input = Readline.readline("user> ") - puts Mal.rep(input) -end +require "readline" + +module Mal + extend self + + def READ(input) + input + end + + def EVAL(input) + input + end + + def PRINT(input) + input + end + + def rep(input) + PRINT(EVAL(READ(input))) + end +end + +while input = Readline.readline("user> ") + puts Mal.rep(input) +end diff --git a/impls/ruby.2/step1_read_print.rb b/impls/ruby.2/step1_read_print.rb index 7cd24c5b9d..090fa4f6b1 100644 --- a/impls/ruby.2/step1_read_print.rb +++ b/impls/ruby.2/step1_read_print.rb @@ -1,45 +1,45 @@ -require "readline" - -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - def READ(input) - read_str(input) - end - - def EVAL(input) - input - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input))) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - rescue SkipCommentError - nil - end -end - -while input = Readline.readline("user> ") - puts Mal.rep(input) -end - -puts +require "readline" + +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + def READ(input) + read_str(input) + end + + def EVAL(input) + input + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input))) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + rescue SkipCommentError + nil + end +end + +while input = Readline.readline("user> ") + puts Mal.rep(input) +end + +puts diff --git a/impls/ruby.2/step2_eval.rb b/impls/ruby.2/step2_eval.rb index 5642d4e53b..0153bd4cc9 100644 --- a/impls/ruby.2/step2_eval.rb +++ b/impls/ruby.2/step2_eval.rb @@ -1,94 +1,94 @@ -require "readline" - -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - @repl_env = { - '+' => -> (a, b) { a + b }, - '-' => -> (a, b) { a - b }, - '*' => -> (a, b) { a * b }, - '/' => -> (a, b) { a / b }, - } - - def READ(input) - read_str(input) - end - - def EVAL(ast, environment) - if Types::List === ast && ast.size > 0 - evaluated = eval_ast(ast, environment) - maybe_callable = evaluated.first - - if maybe_callable.respond_to?(:call) - maybe_callable.call(*evaluated[1..]) - else - raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." - end - elsif Types::List === ast && ast.size == 0 - ast - else - eval_ast(ast, environment) - end - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input), @repl_env)) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue NotCallableError => e - e.message - rescue SymbolNotFoundError => e - e.message - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - end - - def eval_ast(mal, environment) - case mal - when Types::Symbol - if @repl_env.key?(mal.value) - @repl_env[mal.value] - else - raise SymbolNotFoundError, "Error! Symbol #{mal.value} not found." - end - when Types::List - list = Types::List.new - mal.each { |i| list << EVAL(i, environment) } - list - when Types::Vector - vec = Types::Vector.new - mal.each { |i| vec << EVAL(i, environment) } - vec - when Types::Hashmap - hashmap = Types::Hashmap.new - mal.each { |k, v| hashmap[k] = EVAL(v, environment) } - hashmap - else - mal - end - end -end - -while input = Readline.readline("user> ") - puts Mal.rep(input) -end - -puts - - +require "readline" + +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + @repl_env = { + '+' => -> (a, b) { a + b }, + '-' => -> (a, b) { a - b }, + '*' => -> (a, b) { a * b }, + '/' => -> (a, b) { a / b }, + } + + def READ(input) + read_str(input) + end + + def EVAL(ast, environment) + if Types::List === ast && ast.size > 0 + evaluated = eval_ast(ast, environment) + maybe_callable = evaluated.first + + if maybe_callable.respond_to?(:call) + maybe_callable.call(*evaluated[1..]) + else + raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." + end + elsif Types::List === ast && ast.size == 0 + ast + else + eval_ast(ast, environment) + end + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input), @repl_env)) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue NotCallableError => e + e.message + rescue SymbolNotFoundError => e + e.message + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + end + + def eval_ast(mal, environment) + case mal + when Types::Symbol + if @repl_env.key?(mal.value) + @repl_env[mal.value] + else + raise SymbolNotFoundError, "Error! Symbol #{mal.value} not found." + end + when Types::List + list = Types::List.new + mal.each { |i| list << EVAL(i, environment) } + list + when Types::Vector + vec = Types::Vector.new + mal.each { |i| vec << EVAL(i, environment) } + vec + when Types::Hashmap + hashmap = Types::Hashmap.new + mal.each { |k, v| hashmap[k] = EVAL(v, environment) } + hashmap + else + mal + end + end +end + +while input = Readline.readline("user> ") + puts Mal.rep(input) +end + +puts + + diff --git a/impls/ruby.2/step3_env.rb b/impls/ruby.2/step3_env.rb index dc908a70b6..159878808a 100644 --- a/impls/ruby.2/step3_env.rb +++ b/impls/ruby.2/step3_env.rb @@ -1,118 +1,118 @@ -require "readline" - -require_relative "env" -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - @repl_env = Env.new - @repl_env.set(Types::Symbol.for('+'), -> (a, b) { a + b }) - @repl_env.set(Types::Symbol.for('-'), -> (a, b) { a - b }) - @repl_env.set(Types::Symbol.for('*'), -> (a, b) { a * b }) - @repl_env.set(Types::Symbol.for('/'), -> (a, b) { a / b }) - - def READ(input) - read_str(input) - end - - def EVAL(ast, environment) - if Types::List === ast && ast.size > 0 - case ast.first - when Types::Symbol.for("def!") - _, sym, val = ast - environment.set(sym, EVAL(val, environment)) - when Types::Symbol.for("let*") - e = Env.new(environment) - _, bindings, val = ast - - unless Types::List === bindings || Types::Vector === bindings - raise InvalidLetBindingsError - end - - until bindings.empty? - k, v = bindings.shift(2) - - raise InvalidLetBindingsError if k.nil? - v = Types::Nil.instance if v.nil? - - e.set(k, EVAL(v, e)) - end - - if !val.nil? - EVAL(val, e) - else - Types::Nil.instance - end - else - evaluated = eval_ast(ast, environment) - maybe_callable = evaluated.first - - if maybe_callable.respond_to?(:call) - maybe_callable.call(*evaluated[1..]) - else - raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." - end - end - elsif Types::List === ast && ast.size == 0 - ast - else - eval_ast(ast, environment) - end - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input), @repl_env)) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue NotCallableError => e - e.message - rescue SymbolNotFoundError => e - e.message - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - end - - def eval_ast(mal, environment) - case mal - when Types::Symbol - environment.get(mal) - when Types::List - list = Types::List.new - mal.each { |i| list << EVAL(i, environment) } - list - when Types::Vector - vec = Types::Vector.new - mal.each { |i| vec << EVAL(i, environment) } - vec - when Types::Hashmap - hashmap = Types::Hashmap.new - mal.each { |k, v| hashmap[k] = EVAL(v, environment) } - hashmap - else - mal - end - end -end - -while input = Readline.readline("user> ") - puts Mal.rep(input) -end - -puts - - +require "readline" + +require_relative "env" +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + @repl_env = Env.new + @repl_env.set(Types::Symbol.for('+'), -> (a, b) { a + b }) + @repl_env.set(Types::Symbol.for('-'), -> (a, b) { a - b }) + @repl_env.set(Types::Symbol.for('*'), -> (a, b) { a * b }) + @repl_env.set(Types::Symbol.for('/'), -> (a, b) { a / b }) + + def READ(input) + read_str(input) + end + + def EVAL(ast, environment) + if Types::List === ast && ast.size > 0 + case ast.first + when Types::Symbol.for("def!") + _, sym, val = ast + environment.set(sym, EVAL(val, environment)) + when Types::Symbol.for("let*") + e = Env.new(environment) + _, bindings, val = ast + + unless Types::List === bindings || Types::Vector === bindings + raise InvalidLetBindingsError + end + + until bindings.empty? + k, v = bindings.shift(2) + + raise InvalidLetBindingsError if k.nil? + v = Types::Nil.instance if v.nil? + + e.set(k, EVAL(v, e)) + end + + if !val.nil? + EVAL(val, e) + else + Types::Nil.instance + end + else + evaluated = eval_ast(ast, environment) + maybe_callable = evaluated.first + + if maybe_callable.respond_to?(:call) + maybe_callable.call(*evaluated[1..]) + else + raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." + end + end + elsif Types::List === ast && ast.size == 0 + ast + else + eval_ast(ast, environment) + end + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input), @repl_env)) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue NotCallableError => e + e.message + rescue SymbolNotFoundError => e + e.message + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + end + + def eval_ast(mal, environment) + case mal + when Types::Symbol + environment.get(mal) + when Types::List + list = Types::List.new + mal.each { |i| list << EVAL(i, environment) } + list + when Types::Vector + vec = Types::Vector.new + mal.each { |i| vec << EVAL(i, environment) } + vec + when Types::Hashmap + hashmap = Types::Hashmap.new + mal.each { |k, v| hashmap[k] = EVAL(v, environment) } + hashmap + else + mal + end + end +end + +while input = Readline.readline("user> ") + puts Mal.rep(input) +end + +puts + + diff --git a/impls/ruby.2/step4_if_fn_do.rb b/impls/ruby.2/step4_if_fn_do.rb index 5133f51756..32b41a6477 100644 --- a/impls/ruby.2/step4_if_fn_do.rb +++ b/impls/ruby.2/step4_if_fn_do.rb @@ -1,162 +1,162 @@ -require "readline" - -require_relative "core" -require_relative "env" -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - def boot_repl! - @repl_env = Env.new - - Core.ns.each do |k, v| - @repl_env.set(k, v) - end - - Mal.rep("(def! not (fn* (a) (if a false true)))") - end - - def READ(input) - read_str(input) - end - - def EVAL(ast, environment) - if Types::List === ast && ast.size > 0 - case ast.first - when Types::Symbol.for("def!") - _, sym, val = ast - environment.set(sym, EVAL(val, environment)) - when Types::Symbol.for("let*") - e = Env.new(environment) - _, bindings, val = ast - - unless Types::List === bindings || Types::Vector === bindings - raise InvalidLetBindingsError - end - - until bindings.empty? - k, v = bindings.shift(2) - - raise InvalidLetBindingsError if k.nil? - v = Types::Nil.instance if v.nil? - - e.set(k, EVAL(v, e)) - end - - if !val.nil? - EVAL(val, e) - else - Types::Nil.instance - end - when Types::Symbol.for("do") - _, *values = ast - - if !values.nil? - evaluated = Types::List.new - - values.each do |v| - evaluated << EVAL(v, environment) - end - - evaluated.last - else - Types::Nil.instance - end - when Types::Symbol.for("if") - _, condition, when_true, when_false = ast - - case EVAL(condition, environment) - when Types::False.instance, Types::Nil.instance - if !when_false.nil? - EVAL(when_false, environment) - else - Types::Nil.instance - end - else - if !when_true.nil? - EVAL(when_true, environment) - else - raise InvalidIfExpressionError - end - end - when Types::Symbol.for("fn*") - _, binds, to_eval = ast - - Types::Function.new(to_eval, binds, environment) do |*exprs| - EVAL(to_eval, Env.new(environment, binds, exprs)) - end - else - evaluated = eval_ast(ast, environment) - maybe_callable = evaluated.first - - if maybe_callable.respond_to?(:call) - maybe_callable.call(Types::Args.new(evaluated[1..])) - else - raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." - end - end - elsif Types::List === ast && ast.size == 0 - ast - else - eval_ast(ast, environment) - end - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input), @repl_env)) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue NotCallableError => e - e.message - rescue SymbolNotFoundError => e - e.message - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - end - - def eval_ast(mal, environment) - case mal - when Types::Symbol - environment.get(mal) - when Types::List - list = Types::List.new - mal.each { |i| list << EVAL(i, environment) } - list - when Types::Vector - vec = Types::Vector.new - mal.each { |i| vec << EVAL(i, environment) } - vec - when Types::Hashmap - hashmap = Types::Hashmap.new - mal.each { |k, v| hashmap[k] = EVAL(v, environment) } - hashmap - else - mal - end - end -end - -Mal.boot_repl! - -while input = Readline.readline("user> ") - puts Mal.rep(input) -end - -puts - - +require "readline" + +require_relative "core" +require_relative "env" +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + def boot_repl! + @repl_env = Env.new + + Core.ns.each do |k, v| + @repl_env.set(k, v) + end + + Mal.rep("(def! not (fn* (a) (if a false true)))") + end + + def READ(input) + read_str(input) + end + + def EVAL(ast, environment) + if Types::List === ast && ast.size > 0 + case ast.first + when Types::Symbol.for("def!") + _, sym, val = ast + environment.set(sym, EVAL(val, environment)) + when Types::Symbol.for("let*") + e = Env.new(environment) + _, bindings, val = ast + + unless Types::List === bindings || Types::Vector === bindings + raise InvalidLetBindingsError + end + + until bindings.empty? + k, v = bindings.shift(2) + + raise InvalidLetBindingsError if k.nil? + v = Types::Nil.instance if v.nil? + + e.set(k, EVAL(v, e)) + end + + if !val.nil? + EVAL(val, e) + else + Types::Nil.instance + end + when Types::Symbol.for("do") + _, *values = ast + + if !values.nil? + evaluated = Types::List.new + + values.each do |v| + evaluated << EVAL(v, environment) + end + + evaluated.last + else + Types::Nil.instance + end + when Types::Symbol.for("if") + _, condition, when_true, when_false = ast + + case EVAL(condition, environment) + when Types::False.instance, Types::Nil.instance + if !when_false.nil? + EVAL(when_false, environment) + else + Types::Nil.instance + end + else + if !when_true.nil? + EVAL(when_true, environment) + else + raise InvalidIfExpressionError + end + end + when Types::Symbol.for("fn*") + _, binds, to_eval = ast + + Types::Function.new(to_eval, binds, environment) do |*exprs| + EVAL(to_eval, Env.new(environment, binds, exprs)) + end + else + evaluated = eval_ast(ast, environment) + maybe_callable = evaluated.first + + if maybe_callable.respond_to?(:call) + maybe_callable.call(Types::Args.new(evaluated[1..])) + else + raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." + end + end + elsif Types::List === ast && ast.size == 0 + ast + else + eval_ast(ast, environment) + end + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input), @repl_env)) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue NotCallableError => e + e.message + rescue SymbolNotFoundError => e + e.message + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + end + + def eval_ast(mal, environment) + case mal + when Types::Symbol + environment.get(mal) + when Types::List + list = Types::List.new + mal.each { |i| list << EVAL(i, environment) } + list + when Types::Vector + vec = Types::Vector.new + mal.each { |i| vec << EVAL(i, environment) } + vec + when Types::Hashmap + hashmap = Types::Hashmap.new + mal.each { |k, v| hashmap[k] = EVAL(v, environment) } + hashmap + else + mal + end + end +end + +Mal.boot_repl! + +while input = Readline.readline("user> ") + puts Mal.rep(input) +end + +puts + + diff --git a/impls/ruby.2/step5_tco.rb b/impls/ruby.2/step5_tco.rb index d6b4085c78..0788a7f081 100644 --- a/impls/ruby.2/step5_tco.rb +++ b/impls/ruby.2/step5_tco.rb @@ -1,175 +1,175 @@ -require "readline" - -require_relative "core" -require_relative "env" -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - def boot_repl! - @repl_env = Env.new - - Core.ns.each do |k, v| - @repl_env.set(k, v) - end - - Mal.rep("(def! not (fn* (a) (if a false true)))") - end - - def READ(input) - read_str(input) - end - - def EVAL(ast, environment) - loop do - if Types::List === ast && ast.size > 0 - case ast.first - when Types::Symbol.for("def!") - _, sym, val = ast - return environment.set(sym, EVAL(val, environment)) - when Types::Symbol.for("let*") - e = Env.new(environment) - _, bindings, val = ast - - unless Types::List === bindings || Types::Vector === bindings - raise InvalidLetBindingsError - end - - until bindings.empty? - k, v = bindings.shift(2) - - raise InvalidLetBindingsError if k.nil? - v = Types::Nil.instance if v.nil? - - e.set(k, EVAL(v, e)) - end - - if !val.nil? - # Continue loop - ast = val - environment = e - else - return Types::Nil.instance - end - when Types::Symbol.for("do") - _, *values = ast - - if !values.nil? && values.any? - values[0...-1].each do |v| - EVAL(v, environment) - end - - # Continue loop - ast = values.last - else - return Types::Nil.instance - end - when Types::Symbol.for("if") - _, condition, when_true, when_false = ast - - case EVAL(condition, environment) - when Types::False.instance, Types::Nil.instance - if !when_false.nil? - # Continue loop - ast = when_false - else - return Types::Nil.instance - end - else - if !when_true.nil? - # Continue loop - ast = when_true - else - raise InvalidIfExpressionError - end - end - when Types::Symbol.for("fn*") - _, binds, to_eval = ast - - return Types::Function.new(to_eval, binds, environment) do |*exprs| - EVAL(to_eval, Env.new(environment, binds, exprs)) - end - else - evaluated = eval_ast(ast, environment) - maybe_callable = evaluated.first - - if maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? - return maybe_callable.call(Types::Args.new(evaluated[1..])) - elsif maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? - # Continue loop - ast = maybe_callable.ast - environment = Env.new( - maybe_callable.env, - maybe_callable.params, - evaluated[1..], - ) - else - raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." - end - end - elsif Types::List === ast && ast.size == 0 - return ast - else - return eval_ast(ast, environment) - end - end - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input), @repl_env)) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue NotCallableError => e - e.message - rescue SymbolNotFoundError => e - e.message - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - end - - def eval_ast(mal, environment) - case mal - when Types::Symbol - environment.get(mal) - when Types::List - list = Types::List.new - mal.each { |i| list << EVAL(i, environment) } - list - when Types::Vector - vec = Types::Vector.new - mal.each { |i| vec << EVAL(i, environment) } - vec - when Types::Hashmap - hashmap = Types::Hashmap.new - mal.each { |k, v| hashmap[k] = EVAL(v, environment) } - hashmap - else - mal - end - end -end - -Mal.boot_repl! - -while input = Readline.readline("user> ") - puts Mal.rep(input) -end - -puts - - +require "readline" + +require_relative "core" +require_relative "env" +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + def boot_repl! + @repl_env = Env.new + + Core.ns.each do |k, v| + @repl_env.set(k, v) + end + + Mal.rep("(def! not (fn* (a) (if a false true)))") + end + + def READ(input) + read_str(input) + end + + def EVAL(ast, environment) + loop do + if Types::List === ast && ast.size > 0 + case ast.first + when Types::Symbol.for("def!") + _, sym, val = ast + return environment.set(sym, EVAL(val, environment)) + when Types::Symbol.for("let*") + e = Env.new(environment) + _, bindings, val = ast + + unless Types::List === bindings || Types::Vector === bindings + raise InvalidLetBindingsError + end + + until bindings.empty? + k, v = bindings.shift(2) + + raise InvalidLetBindingsError if k.nil? + v = Types::Nil.instance if v.nil? + + e.set(k, EVAL(v, e)) + end + + if !val.nil? + # Continue loop + ast = val + environment = e + else + return Types::Nil.instance + end + when Types::Symbol.for("do") + _, *values = ast + + if !values.nil? && values.any? + values[0...-1].each do |v| + EVAL(v, environment) + end + + # Continue loop + ast = values.last + else + return Types::Nil.instance + end + when Types::Symbol.for("if") + _, condition, when_true, when_false = ast + + case EVAL(condition, environment) + when Types::False.instance, Types::Nil.instance + if !when_false.nil? + # Continue loop + ast = when_false + else + return Types::Nil.instance + end + else + if !when_true.nil? + # Continue loop + ast = when_true + else + raise InvalidIfExpressionError + end + end + when Types::Symbol.for("fn*") + _, binds, to_eval = ast + + return Types::Function.new(to_eval, binds, environment) do |*exprs| + EVAL(to_eval, Env.new(environment, binds, exprs)) + end + else + evaluated = eval_ast(ast, environment) + maybe_callable = evaluated.first + + if maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? + return maybe_callable.call(Types::Args.new(evaluated[1..])) + elsif maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? + # Continue loop + ast = maybe_callable.ast + environment = Env.new( + maybe_callable.env, + maybe_callable.params, + evaluated[1..], + ) + else + raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." + end + end + elsif Types::List === ast && ast.size == 0 + return ast + else + return eval_ast(ast, environment) + end + end + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input), @repl_env)) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue NotCallableError => e + e.message + rescue SymbolNotFoundError => e + e.message + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + end + + def eval_ast(mal, environment) + case mal + when Types::Symbol + environment.get(mal) + when Types::List + list = Types::List.new + mal.each { |i| list << EVAL(i, environment) } + list + when Types::Vector + vec = Types::Vector.new + mal.each { |i| vec << EVAL(i, environment) } + vec + when Types::Hashmap + hashmap = Types::Hashmap.new + mal.each { |k, v| hashmap[k] = EVAL(v, environment) } + hashmap + else + mal + end + end +end + +Mal.boot_repl! + +while input = Readline.readline("user> ") + puts Mal.rep(input) +end + +puts + + diff --git a/impls/ruby.2/step6_file.rb b/impls/ruby.2/step6_file.rb index 3325d5e7eb..502fd2cae2 100644 --- a/impls/ruby.2/step6_file.rb +++ b/impls/ruby.2/step6_file.rb @@ -1,199 +1,199 @@ -require "readline" - -require_relative "core" -require_relative "env" -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - def boot_repl! - @repl_env = Env.new - - Core.ns.each do |k, v| - @repl_env.set(k, v) - end - - @repl_env.set( - Types::Symbol.for("eval"), - - Types::Builtin.new("eval") do |mal| - Mal.EVAL(mal, @repl_env) - end - ) - - Mal.rep("(def! not (fn* (a) (if a false true)))") - Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - Mal.rep("(def! *ARGV* (list))") if !run_application? - end - - def run_application? - ARGV.any? - end - - def run! - Mal.rep("(def! *ARGV* (list #{ARGV[1..].map(&:inspect).join(" ")}))") - Mal.rep("(load-file #{ARGV.first.inspect})") - end - - def READ(input) - read_str(input) - end - - def EVAL(ast, environment) - loop do - if Types::List === ast && ast.size > 0 - case ast.first - when Types::Symbol.for("def!") - _, sym, val = ast - return environment.set(sym, EVAL(val, environment)) - when Types::Symbol.for("let*") - e = Env.new(environment) - _, bindings, val = ast - - unless Types::List === bindings || Types::Vector === bindings - raise InvalidLetBindingsError - end - - until bindings.empty? - k, v = bindings.shift(2) - - raise InvalidLetBindingsError if k.nil? - v = Types::Nil.instance if v.nil? - - e.set(k, EVAL(v, e)) - end - - if !val.nil? - # Continue loop - ast = val - environment = e - else - return Types::Nil.instance - end - when Types::Symbol.for("do") - _, *values = ast - - if !values.nil? && values.any? - values[0...-1].each do |v| - EVAL(v, environment) - end - - # Continue loop - ast = values.last - else - return Types::Nil.instance - end - when Types::Symbol.for("if") - _, condition, when_true, when_false = ast - - case EVAL(condition, environment) - when Types::False.instance, Types::Nil.instance - if !when_false.nil? - # Continue loop - ast = when_false - else - return Types::Nil.instance - end - else - if !when_true.nil? - # Continue loop - ast = when_true - else - raise InvalidIfExpressionError - end - end - when Types::Symbol.for("fn*") - _, binds, to_eval = ast - - return Types::Function.new(to_eval, binds, environment) do |*exprs| - EVAL(to_eval, Env.new(environment, binds, exprs)) - end - else - evaluated = eval_ast(ast, environment) - maybe_callable = evaluated.first - - if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? - # Continue loop - ast = maybe_callable.ast - environment = Env.new( - maybe_callable.env, - maybe_callable.params, - evaluated[1..], - ) - elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? - return maybe_callable.call(Types::Args.new(evaluated[1..])) - else - raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." - end - end - elsif Types::List === ast && ast.size == 0 - return ast - else - return eval_ast(ast, environment) - end - end - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input), @repl_env)) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue NotCallableError => e - e.message - rescue SymbolNotFoundError => e - e.message - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - rescue SkipCommentError - nil - end - - def eval_ast(mal, environment) - case mal - when Types::Symbol - environment.get(mal) - when Types::List - list = Types::List.new - mal.each { |i| list << EVAL(i, environment) } - list - when Types::Vector - vec = Types::Vector.new - mal.each { |i| vec << EVAL(i, environment) } - vec - when Types::Hashmap - hashmap = Types::Hashmap.new - mal.each { |k, v| hashmap[k] = EVAL(v, environment) } - hashmap - else - mal - end - end -end - -Mal.boot_repl! - -if Mal.run_application? - Mal.run! -else - while input = Readline.readline("user> ") - val = Mal.rep(input) - puts val unless val.nil? - end - - puts -end +require "readline" + +require_relative "core" +require_relative "env" +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + def boot_repl! + @repl_env = Env.new + + Core.ns.each do |k, v| + @repl_env.set(k, v) + end + + @repl_env.set( + Types::Symbol.for("eval"), + + Types::Builtin.new("eval") do |mal| + Mal.EVAL(mal, @repl_env) + end + ) + + Mal.rep("(def! not (fn* (a) (if a false true)))") + Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + Mal.rep("(def! *ARGV* (list))") if !run_application? + end + + def run_application? + ARGV.any? + end + + def run! + Mal.rep("(def! *ARGV* (list #{ARGV[1..].map(&:inspect).join(" ")}))") + Mal.rep("(load-file #{ARGV.first.inspect})") + end + + def READ(input) + read_str(input) + end + + def EVAL(ast, environment) + loop do + if Types::List === ast && ast.size > 0 + case ast.first + when Types::Symbol.for("def!") + _, sym, val = ast + return environment.set(sym, EVAL(val, environment)) + when Types::Symbol.for("let*") + e = Env.new(environment) + _, bindings, val = ast + + unless Types::List === bindings || Types::Vector === bindings + raise InvalidLetBindingsError + end + + until bindings.empty? + k, v = bindings.shift(2) + + raise InvalidLetBindingsError if k.nil? + v = Types::Nil.instance if v.nil? + + e.set(k, EVAL(v, e)) + end + + if !val.nil? + # Continue loop + ast = val + environment = e + else + return Types::Nil.instance + end + when Types::Symbol.for("do") + _, *values = ast + + if !values.nil? && values.any? + values[0...-1].each do |v| + EVAL(v, environment) + end + + # Continue loop + ast = values.last + else + return Types::Nil.instance + end + when Types::Symbol.for("if") + _, condition, when_true, when_false = ast + + case EVAL(condition, environment) + when Types::False.instance, Types::Nil.instance + if !when_false.nil? + # Continue loop + ast = when_false + else + return Types::Nil.instance + end + else + if !when_true.nil? + # Continue loop + ast = when_true + else + raise InvalidIfExpressionError + end + end + when Types::Symbol.for("fn*") + _, binds, to_eval = ast + + return Types::Function.new(to_eval, binds, environment) do |*exprs| + EVAL(to_eval, Env.new(environment, binds, exprs)) + end + else + evaluated = eval_ast(ast, environment) + maybe_callable = evaluated.first + + if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? + # Continue loop + ast = maybe_callable.ast + environment = Env.new( + maybe_callable.env, + maybe_callable.params, + evaluated[1..], + ) + elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? + return maybe_callable.call(Types::Args.new(evaluated[1..])) + else + raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." + end + end + elsif Types::List === ast && ast.size == 0 + return ast + else + return eval_ast(ast, environment) + end + end + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input), @repl_env)) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue NotCallableError => e + e.message + rescue SymbolNotFoundError => e + e.message + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + rescue SkipCommentError + nil + end + + def eval_ast(mal, environment) + case mal + when Types::Symbol + environment.get(mal) + when Types::List + list = Types::List.new + mal.each { |i| list << EVAL(i, environment) } + list + when Types::Vector + vec = Types::Vector.new + mal.each { |i| vec << EVAL(i, environment) } + vec + when Types::Hashmap + hashmap = Types::Hashmap.new + mal.each { |k, v| hashmap[k] = EVAL(v, environment) } + hashmap + else + mal + end + end +end + +Mal.boot_repl! + +if Mal.run_application? + Mal.run! +else + while input = Readline.readline("user> ") + val = Mal.rep(input) + puts val unless val.nil? + end + + puts +end diff --git a/impls/ruby.2/step7_quote.rb b/impls/ruby.2/step7_quote.rb index 837ac721e0..6385ce2e10 100644 --- a/impls/ruby.2/step7_quote.rb +++ b/impls/ruby.2/step7_quote.rb @@ -1,253 +1,253 @@ -require "readline" - -require_relative "core" -require_relative "env" -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - def boot_repl! - @repl_env = Env.new - - Core.ns.each do |k, v| - @repl_env.set(k, v) - end - - @repl_env.set( - Types::Symbol.for("eval"), - - Types::Builtin.new("eval") do |mal| - Mal.EVAL(mal, @repl_env) - end - ) - - Mal.rep("(def! not (fn* (a) (if a false true)))") - Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - Mal.rep("(def! *ARGV* (list))") if !run_application? - end - - def run_application? - ARGV.any? - end - - def run! - Mal.rep("(def! *ARGV* (list #{ARGV[1..].map(&:inspect).join(" ")}))") - Mal.rep("(load-file #{ARGV.first.inspect})") - end - - def READ(input) - read_str(input) - end - - def EVAL(ast, environment) - loop do - if Types::List === ast && ast.size > 0 - case ast.first - when Types::Symbol.for("def!") - _, sym, val = ast - return environment.set(sym, EVAL(val, environment)) - when Types::Symbol.for("let*") - e = Env.new(environment) - _, bindings, val = ast - - unless Types::List === bindings || Types::Vector === bindings - raise InvalidLetBindingsError - end - - until bindings.empty? - k, v = bindings.shift(2) - - raise InvalidLetBindingsError if k.nil? - v = Types::Nil.instance if v.nil? - - e.set(k, EVAL(v, e)) - end - - if !val.nil? - # Continue loop - ast = val - environment = e - else - return Types::Nil.instance - end - when Types::Symbol.for("do") - _, *values = ast - - if !values.nil? && values.any? - values[0...-1].each do |v| - EVAL(v, environment) - end - - # Continue loop - ast = values.last - else - return Types::Nil.instance - end - when Types::Symbol.for("if") - _, condition, when_true, when_false = ast - - case EVAL(condition, environment) - when Types::False.instance, Types::Nil.instance - if !when_false.nil? - # Continue loop - ast = when_false - else - return Types::Nil.instance - end - else - if !when_true.nil? - # Continue loop - ast = when_true - else - raise InvalidIfExpressionError - end - end - when Types::Symbol.for("fn*") - _, binds, to_eval = ast - - return Types::Function.new(to_eval, binds, environment) do |*exprs| - EVAL(to_eval, Env.new(environment, binds, exprs)) - end - when Types::Symbol.for("quote") - _, ret = ast - return ret - when Types::Symbol.for("quasiquote") - _, ast_rest = ast - ast = quasiquote(ast_rest) - when Types::Symbol.for("quasiquoteexpand") - _, ast_rest = ast - return quasiquote(ast_rest) - else - evaluated = eval_ast(ast, environment) - maybe_callable = evaluated.first - - if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? - # Continue loop - ast = maybe_callable.ast - environment = Env.new( - maybe_callable.env, - maybe_callable.params, - evaluated[1..], - ) - elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? - return maybe_callable.call(Types::Args.new(evaluated[1..])) - else - raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." - end - end - elsif Types::List === ast && ast.size == 0 - return ast - else - return eval_ast(ast, environment) - end - end - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input), @repl_env)) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue NotCallableError => e - e.message - rescue SymbolNotFoundError => e - e.message - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - rescue SkipCommentError - nil - end - - def eval_ast(mal, environment) - case mal - when Types::Symbol - environment.get(mal) - when Types::List - list = Types::List.new - mal.each { |i| list << EVAL(i, environment) } - list - when Types::Vector - vec = Types::Vector.new - mal.each { |i| vec << EVAL(i, environment) } - vec - when Types::Hashmap - hashmap = Types::Hashmap.new - mal.each { |k, v| hashmap[k] = EVAL(v, environment) } - hashmap - else - mal - end - end - - def quasiquote_list(mal) - result = Types::List.new - - mal.reverse_each do |elt| - if elt.is_a?(Types::List) && elt.first == Types::Symbol.for("splice-unquote") - result = Types::List.new([ - Types::Symbol.for("concat"), - elt[1], - result - ]) - else - result = Types::List.new([ - Types::Symbol.for("cons"), - quasiquote(elt), - result - ]) - end - end - - result - end - - def quasiquote(mal) - case mal - when Types::List - if mal.first == Types::Symbol.for("unquote") - mal[1] - else - quasiquote_list(mal) - end - when Types::Vector - Types::List.new([ - Types::Symbol.for("vec"), - quasiquote_list(mal) - ]) - when Types::Hashmap, Types::Symbol - Types::List.new([ - Types::Symbol.for("quote"), - mal - ]) - else - mal - end - end -end - -Mal.boot_repl! - -if Mal.run_application? - Mal.run! -else - while input = Readline.readline("user> ") - val = Mal.rep(input) - puts val unless val.nil? - end - - puts -end +require "readline" + +require_relative "core" +require_relative "env" +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + def boot_repl! + @repl_env = Env.new + + Core.ns.each do |k, v| + @repl_env.set(k, v) + end + + @repl_env.set( + Types::Symbol.for("eval"), + + Types::Builtin.new("eval") do |mal| + Mal.EVAL(mal, @repl_env) + end + ) + + Mal.rep("(def! not (fn* (a) (if a false true)))") + Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + Mal.rep("(def! *ARGV* (list))") if !run_application? + end + + def run_application? + ARGV.any? + end + + def run! + Mal.rep("(def! *ARGV* (list #{ARGV[1..].map(&:inspect).join(" ")}))") + Mal.rep("(load-file #{ARGV.first.inspect})") + end + + def READ(input) + read_str(input) + end + + def EVAL(ast, environment) + loop do + if Types::List === ast && ast.size > 0 + case ast.first + when Types::Symbol.for("def!") + _, sym, val = ast + return environment.set(sym, EVAL(val, environment)) + when Types::Symbol.for("let*") + e = Env.new(environment) + _, bindings, val = ast + + unless Types::List === bindings || Types::Vector === bindings + raise InvalidLetBindingsError + end + + until bindings.empty? + k, v = bindings.shift(2) + + raise InvalidLetBindingsError if k.nil? + v = Types::Nil.instance if v.nil? + + e.set(k, EVAL(v, e)) + end + + if !val.nil? + # Continue loop + ast = val + environment = e + else + return Types::Nil.instance + end + when Types::Symbol.for("do") + _, *values = ast + + if !values.nil? && values.any? + values[0...-1].each do |v| + EVAL(v, environment) + end + + # Continue loop + ast = values.last + else + return Types::Nil.instance + end + when Types::Symbol.for("if") + _, condition, when_true, when_false = ast + + case EVAL(condition, environment) + when Types::False.instance, Types::Nil.instance + if !when_false.nil? + # Continue loop + ast = when_false + else + return Types::Nil.instance + end + else + if !when_true.nil? + # Continue loop + ast = when_true + else + raise InvalidIfExpressionError + end + end + when Types::Symbol.for("fn*") + _, binds, to_eval = ast + + return Types::Function.new(to_eval, binds, environment) do |*exprs| + EVAL(to_eval, Env.new(environment, binds, exprs)) + end + when Types::Symbol.for("quote") + _, ret = ast + return ret + when Types::Symbol.for("quasiquote") + _, ast_rest = ast + ast = quasiquote(ast_rest) + when Types::Symbol.for("quasiquoteexpand") + _, ast_rest = ast + return quasiquote(ast_rest) + else + evaluated = eval_ast(ast, environment) + maybe_callable = evaluated.first + + if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? + # Continue loop + ast = maybe_callable.ast + environment = Env.new( + maybe_callable.env, + maybe_callable.params, + evaluated[1..], + ) + elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? + return maybe_callable.call(Types::Args.new(evaluated[1..])) + else + raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." + end + end + elsif Types::List === ast && ast.size == 0 + return ast + else + return eval_ast(ast, environment) + end + end + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input), @repl_env)) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue NotCallableError => e + e.message + rescue SymbolNotFoundError => e + e.message + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + rescue SkipCommentError + nil + end + + def eval_ast(mal, environment) + case mal + when Types::Symbol + environment.get(mal) + when Types::List + list = Types::List.new + mal.each { |i| list << EVAL(i, environment) } + list + when Types::Vector + vec = Types::Vector.new + mal.each { |i| vec << EVAL(i, environment) } + vec + when Types::Hashmap + hashmap = Types::Hashmap.new + mal.each { |k, v| hashmap[k] = EVAL(v, environment) } + hashmap + else + mal + end + end + + def quasiquote_list(mal) + result = Types::List.new + + mal.reverse_each do |elt| + if elt.is_a?(Types::List) && elt.first == Types::Symbol.for("splice-unquote") + result = Types::List.new([ + Types::Symbol.for("concat"), + elt[1], + result + ]) + else + result = Types::List.new([ + Types::Symbol.for("cons"), + quasiquote(elt), + result + ]) + end + end + + result + end + + def quasiquote(mal) + case mal + when Types::List + if mal.first == Types::Symbol.for("unquote") + mal[1] + else + quasiquote_list(mal) + end + when Types::Vector + Types::List.new([ + Types::Symbol.for("vec"), + quasiquote_list(mal) + ]) + when Types::Hashmap, Types::Symbol + Types::List.new([ + Types::Symbol.for("quote"), + mal + ]) + else + mal + end + end +end + +Mal.boot_repl! + +if Mal.run_application? + Mal.run! +else + while input = Readline.readline("user> ") + val = Mal.rep(input) + puts val unless val.nil? + end + + puts +end diff --git a/impls/ruby.2/step8_macros.rb b/impls/ruby.2/step8_macros.rb index f65deea581..aadb3b7f7b 100644 --- a/impls/ruby.2/step8_macros.rb +++ b/impls/ruby.2/step8_macros.rb @@ -1,295 +1,295 @@ -require "readline" - -require_relative "core" -require_relative "env" -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - def boot_repl! - @repl_env = Env.new - - Core.ns.each do |k, v| - @repl_env.set(k, v) - end - - @repl_env.set( - Types::Symbol.for("eval"), - - Types::Builtin.new("eval") do |mal| - Mal.EVAL(mal, @repl_env) - end - ) - - Mal.rep("(def! not (fn* (a) (if a false true)))") - Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - Mal.rep("(def! *ARGV* (list))") if !run_application? - Mal.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)))))))") - end - - def run_application? - ARGV.any? - end - - def run! - Mal.rep("(def! *ARGV* (list #{ARGV[1..].map(&:inspect).join(" ")}))") - Mal.rep("(load-file #{ARGV.first.inspect})") - end - - def READ(input) - read_str(input) - end - - def EVAL(ast, environment) - loop do - ast = macro_expand(ast, environment) - - if Types::List === ast && ast.size > 0 - case ast.first - when Types::Symbol.for("def!") - _, sym, val = ast - return environment.set(sym, EVAL(val, environment)) - when Types::Symbol.for("defmacro!") - _, sym, val = ast - result = EVAL(val, environment) - - case result - when Types::Function - return environment.set(sym, result.to_macro) - else - raise TypeError - end - when Types::Symbol.for("macroexpand") - _, ast_rest = ast - return macro_expand(ast_rest, environment) - when Types::Symbol.for("let*") - e = Env.new(environment) - _, bindings, val = ast - - unless Types::List === bindings || Types::Vector === bindings - raise InvalidLetBindingsError - end - - until bindings.empty? - k, v = bindings.shift(2) - - raise InvalidLetBindingsError if k.nil? - v = Types::Nil.instance if v.nil? - - e.set(k, EVAL(v, e)) - end - - if !val.nil? - # Continue loop - ast = val - environment = e - else - return Types::Nil.instance - end - when Types::Symbol.for("do") - _, *values = ast - - if !values.nil? && values.any? - values[0...-1].each do |v| - EVAL(v, environment) - end - - # Continue loop - ast = values.last - else - return Types::Nil.instance - end - when Types::Symbol.for("if") - _, condition, when_true, when_false = ast - - case EVAL(condition, environment) - when Types::False.instance, Types::Nil.instance - if !when_false.nil? - # Continue loop - ast = when_false - else - return Types::Nil.instance - end - else - if !when_true.nil? - # Continue loop - ast = when_true - else - raise InvalidIfExpressionError - end - end - when Types::Symbol.for("fn*") - _, binds, to_eval = ast - - return Types::Function.new(to_eval, binds, environment) do |*exprs| - EVAL(to_eval, Env.new(environment, binds, exprs)) - end - when Types::Symbol.for("quote") - _, ret = ast - return ret - when Types::Symbol.for("quasiquote") - _, ast_rest = ast - ast = quasiquote(ast_rest) - when Types::Symbol.for("quasiquoteexpand") - _, ast_rest = ast - return quasiquote(ast_rest) - else - evaluated = eval_ast(ast, environment) - maybe_callable = evaluated.first - - if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? - # Continue loop - ast = maybe_callable.ast - environment = Env.new( - maybe_callable.env, - maybe_callable.params, - evaluated[1..], - ) - elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? - return maybe_callable.call(Types::Args.new(evaluated[1..])) - else - raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." - end - end - elsif Types::List === ast && ast.size == 0 - return ast - else - return eval_ast(ast, environment) - end - end - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input), @repl_env)) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue NotCallableError => e - e.message - rescue SymbolNotFoundError => e - e.message - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - rescue SkipCommentError - nil - rescue TypeError - nil - end - - def eval_ast(mal, environment) - case mal - when Types::Symbol - environment.get(mal) - when Types::List - list = Types::List.new - mal.each { |i| list << EVAL(i, environment) } - list - when Types::Vector - vec = Types::Vector.new - mal.each { |i| vec << EVAL(i, environment) } - vec - when Types::Hashmap - hashmap = Types::Hashmap.new - mal.each { |k, v| hashmap[k] = EVAL(v, environment) } - hashmap - else - mal - end - end - - def quasiquote_list(mal) - result = Types::List.new - - mal.reverse_each do |elt| - if elt.is_a?(Types::List) && elt.first == Types::Symbol.for("splice-unquote") - result = Types::List.new([ - Types::Symbol.for("concat"), - elt[1], - result - ]) - else - result = Types::List.new([ - Types::Symbol.for("cons"), - quasiquote(elt), - result - ]) - end - end - - result - end - - def quasiquote(mal) - case mal - when Types::List - if mal.first == Types::Symbol.for("unquote") - mal[1] - else - quasiquote_list(mal) - end - when Types::Vector - Types::List.new([ - Types::Symbol.for("vec"), - quasiquote_list(mal) - ]) - when Types::Hashmap, Types::Symbol - Types::List.new([ - Types::Symbol.for("quote"), - mal - ]) - else - mal - end - end - - def is_macro_call?(mal, env) - return false unless Types::List === mal - return false unless Types::Symbol === mal.first - val = env.get(mal.first) - return false unless Types::Callable === val - val.is_macro? - rescue SymbolNotFoundError - false - end - - def macro_expand(mal, env) - while is_macro_call?(mal, env) - macro_fn = env.get(mal.first) - - if (args = mal[1..]).any? - mal = macro_fn.call(Types::Args.new(mal[1..])) - else - mal = macro_fn.call - end - end - - mal - end -end - -Mal.boot_repl! - -if Mal.run_application? - Mal.run! -else - while input = Readline.readline("user> ") - val = Mal.rep(input) - puts val unless val.nil? - end - - puts -end +require "readline" + +require_relative "core" +require_relative "env" +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + def boot_repl! + @repl_env = Env.new + + Core.ns.each do |k, v| + @repl_env.set(k, v) + end + + @repl_env.set( + Types::Symbol.for("eval"), + + Types::Builtin.new("eval") do |mal| + Mal.EVAL(mal, @repl_env) + end + ) + + Mal.rep("(def! not (fn* (a) (if a false true)))") + Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + Mal.rep("(def! *ARGV* (list))") if !run_application? + Mal.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)))))))") + end + + def run_application? + ARGV.any? + end + + def run! + Mal.rep("(def! *ARGV* (list #{ARGV[1..].map(&:inspect).join(" ")}))") + Mal.rep("(load-file #{ARGV.first.inspect})") + end + + def READ(input) + read_str(input) + end + + def EVAL(ast, environment) + loop do + ast = macro_expand(ast, environment) + + if Types::List === ast && ast.size > 0 + case ast.first + when Types::Symbol.for("def!") + _, sym, val = ast + return environment.set(sym, EVAL(val, environment)) + when Types::Symbol.for("defmacro!") + _, sym, val = ast + result = EVAL(val, environment) + + case result + when Types::Function + return environment.set(sym, result.to_macro) + else + raise TypeError + end + when Types::Symbol.for("macroexpand") + _, ast_rest = ast + return macro_expand(ast_rest, environment) + when Types::Symbol.for("let*") + e = Env.new(environment) + _, bindings, val = ast + + unless Types::List === bindings || Types::Vector === bindings + raise InvalidLetBindingsError + end + + until bindings.empty? + k, v = bindings.shift(2) + + raise InvalidLetBindingsError if k.nil? + v = Types::Nil.instance if v.nil? + + e.set(k, EVAL(v, e)) + end + + if !val.nil? + # Continue loop + ast = val + environment = e + else + return Types::Nil.instance + end + when Types::Symbol.for("do") + _, *values = ast + + if !values.nil? && values.any? + values[0...-1].each do |v| + EVAL(v, environment) + end + + # Continue loop + ast = values.last + else + return Types::Nil.instance + end + when Types::Symbol.for("if") + _, condition, when_true, when_false = ast + + case EVAL(condition, environment) + when Types::False.instance, Types::Nil.instance + if !when_false.nil? + # Continue loop + ast = when_false + else + return Types::Nil.instance + end + else + if !when_true.nil? + # Continue loop + ast = when_true + else + raise InvalidIfExpressionError + end + end + when Types::Symbol.for("fn*") + _, binds, to_eval = ast + + return Types::Function.new(to_eval, binds, environment) do |*exprs| + EVAL(to_eval, Env.new(environment, binds, exprs)) + end + when Types::Symbol.for("quote") + _, ret = ast + return ret + when Types::Symbol.for("quasiquote") + _, ast_rest = ast + ast = quasiquote(ast_rest) + when Types::Symbol.for("quasiquoteexpand") + _, ast_rest = ast + return quasiquote(ast_rest) + else + evaluated = eval_ast(ast, environment) + maybe_callable = evaluated.first + + if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? + # Continue loop + ast = maybe_callable.ast + environment = Env.new( + maybe_callable.env, + maybe_callable.params, + evaluated[1..], + ) + elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? + return maybe_callable.call(Types::Args.new(evaluated[1..])) + else + raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." + end + end + elsif Types::List === ast && ast.size == 0 + return ast + else + return eval_ast(ast, environment) + end + end + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input), @repl_env)) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue NotCallableError => e + e.message + rescue SymbolNotFoundError => e + e.message + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + rescue SkipCommentError + nil + rescue TypeError + nil + end + + def eval_ast(mal, environment) + case mal + when Types::Symbol + environment.get(mal) + when Types::List + list = Types::List.new + mal.each { |i| list << EVAL(i, environment) } + list + when Types::Vector + vec = Types::Vector.new + mal.each { |i| vec << EVAL(i, environment) } + vec + when Types::Hashmap + hashmap = Types::Hashmap.new + mal.each { |k, v| hashmap[k] = EVAL(v, environment) } + hashmap + else + mal + end + end + + def quasiquote_list(mal) + result = Types::List.new + + mal.reverse_each do |elt| + if elt.is_a?(Types::List) && elt.first == Types::Symbol.for("splice-unquote") + result = Types::List.new([ + Types::Symbol.for("concat"), + elt[1], + result + ]) + else + result = Types::List.new([ + Types::Symbol.for("cons"), + quasiquote(elt), + result + ]) + end + end + + result + end + + def quasiquote(mal) + case mal + when Types::List + if mal.first == Types::Symbol.for("unquote") + mal[1] + else + quasiquote_list(mal) + end + when Types::Vector + Types::List.new([ + Types::Symbol.for("vec"), + quasiquote_list(mal) + ]) + when Types::Hashmap, Types::Symbol + Types::List.new([ + Types::Symbol.for("quote"), + mal + ]) + else + mal + end + end + + def is_macro_call?(mal, env) + return false unless Types::List === mal + return false unless Types::Symbol === mal.first + val = env.get(mal.first) + return false unless Types::Callable === val + val.is_macro? + rescue SymbolNotFoundError + false + end + + def macro_expand(mal, env) + while is_macro_call?(mal, env) + macro_fn = env.get(mal.first) + + if (args = mal[1..]).any? + mal = macro_fn.call(Types::Args.new(mal[1..])) + else + mal = macro_fn.call + end + end + + mal + end +end + +Mal.boot_repl! + +if Mal.run_application? + Mal.run! +else + while input = Readline.readline("user> ") + val = Mal.rep(input) + puts val unless val.nil? + end + + puts +end diff --git a/impls/ruby.2/step9_try.rb b/impls/ruby.2/step9_try.rb index 9cfa409c89..6caee033d6 100644 --- a/impls/ruby.2/step9_try.rb +++ b/impls/ruby.2/step9_try.rb @@ -1,331 +1,331 @@ -require "readline" - -require_relative "core" -require_relative "env" -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - def boot_repl! - @repl_env = Env.new - - Core.ns.each do |k, v| - @repl_env.set(k, v) - end - - @repl_env.set( - Types::Symbol.for("eval"), - - Types::Builtin.new("eval") do |mal| - Mal.EVAL(mal.first, @repl_env) - end - ) - - Mal.rep("(def! not (fn* (a) (if a false true)))") - Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - Mal.rep("(def! *ARGV* (list))") if !run_application? - Mal.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)))))))") - end - - def run_application? - ARGV.any? - end - - def run! - args = ARGV[1..].map(&:inspect) - - if args.any? - Mal.rep("(def! *ARGV* (list #{args.join(" ")}))") - else - Mal.rep("(def! *ARGV* (list))") - end - - puts Mal.rep("(load-file #{ARGV.first.inspect})") - end - - def READ(input) - read_str(input) - end - - def EVAL(ast, environment) - loop do - ast = macro_expand(ast, environment) - - if Types::List === ast && ast.size > 0 - case ast.first - when Types::Symbol.for("def!") - _, sym, val = ast - return environment.set(sym, EVAL(val, environment)) - when Types::Symbol.for("defmacro!") - _, sym, val = ast - result = EVAL(val, environment) - - case result - when Types::Function - return environment.set(sym, result.to_macro) - else - raise TypeError - end - when Types::Symbol.for("macroexpand") - _, ast_rest = ast - return macro_expand(ast_rest, environment) - when Types::Symbol.for("let*") - e = Env.new(environment) - _, bindings, val = ast - - unless Types::List === bindings || Types::Vector === bindings - raise InvalidLetBindingsError - end - - until bindings.empty? - k, v = bindings.shift(2) - - raise InvalidLetBindingsError if k.nil? - v = Types::Nil.instance if v.nil? - - e.set(k, EVAL(v, e)) - end - - if !val.nil? - # Continue loop - ast = val - environment = e - else - return Types::Nil.instance - end - when Types::Symbol.for("do") - _, *values = ast - - if !values.nil? && values.any? - values[0...-1].each do |v| - EVAL(v, environment) - end - - # Continue loop - ast = values.last - else - return Types::Nil.instance - end - when Types::Symbol.for("if") - _, condition, when_true, when_false = ast - - case EVAL(condition, environment) - when Types::False.instance, Types::Nil.instance - if !when_false.nil? - # Continue loop - ast = when_false - else - return Types::Nil.instance - end - else - if !when_true.nil? - # Continue loop - ast = when_true - else - raise InvalidIfExpressionError - end - end - when Types::Symbol.for("fn*") - _, binds, to_eval = ast - - return Types::Function.new(to_eval, binds, environment) do |*exprs| - EVAL(to_eval, Env.new(environment, binds, exprs)) - end - when Types::Symbol.for("quote") - _, ret = ast - return ret - when Types::Symbol.for("quasiquote") - _, ast_rest = ast - ast = quasiquote(ast_rest) - when Types::Symbol.for("quasiquoteexpand") - _, ast_rest = ast - return quasiquote(ast_rest) - when Types::Symbol.for("try*") - _, to_try, catch_list = ast - - begin - return EVAL(to_try, environment) - rescue => e - raise e if catch_list.nil? || catch_list&.empty? - raise SyntaxError, "try* missing proper catch*" unless catch_list&.first == Types::Symbol.for("catch*") - - _, exception_symbol, exception_handler = catch_list - - value = - if e.is_a?(MalError) - e.value - else - Types::String.new(e.message) - end - - return EVAL( - exception_handler, - Env.new( - environment, - Types::List.new([exception_symbol]), - Types::List.new([value]) - ) - ) - end - else - evaluated = eval_ast(ast, environment) - maybe_callable = evaluated.first - - if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? - # Continue loop - ast = maybe_callable.ast - environment = Env.new( - maybe_callable.env, - maybe_callable.params, - evaluated[1..], - ) - elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? - return maybe_callable.call(Types::Args.new(evaluated[1..])) - else - raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." - end - end - elsif Types::List === ast && ast.size == 0 - return ast - else - return eval_ast(ast, environment) - end - end - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input), @repl_env)) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue NotCallableError => e - e.message - rescue SymbolNotFoundError => e - e.message - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - rescue MalError => e - "Error: #{pr_str(e.value, true)}" - rescue Error, TypeError => e - "#{e.class} -- #{e.message}" - rescue SkipCommentError - nil - end - - def eval_ast(mal, environment) - case mal - when Types::Symbol - environment.get(mal) - when Types::List - list = Types::List.new - mal.each { |i| list << EVAL(i, environment) } - list - when Types::Vector - vec = Types::Vector.new - mal.each { |i| vec << EVAL(i, environment) } - vec - when Types::Hashmap - hashmap = Types::Hashmap.new - mal.each { |k, v| hashmap[k] = EVAL(v, environment) } - hashmap - else - mal - end - end - - def quasiquote_list(mal) - result = Types::List.new - - mal.reverse_each do |elt| - if elt.is_a?(Types::List) && elt.first == Types::Symbol.for("splice-unquote") - result = Types::List.new([ - Types::Symbol.for("concat"), - elt[1], - result - ]) - else - result = Types::List.new([ - Types::Symbol.for("cons"), - quasiquote(elt), - result - ]) - end - end - - result - end - - def quasiquote(mal) - case mal - when Types::List - if mal.first == Types::Symbol.for("unquote") - mal[1] - else - quasiquote_list(mal) - end - when Types::Vector - Types::List.new([ - Types::Symbol.for("vec"), - quasiquote_list(mal) - ]) - when Types::Hashmap, Types::Symbol - Types::List.new([ - Types::Symbol.for("quote"), - mal - ]) - else - mal - end - end - - def is_macro_call?(mal, env) - return false unless Types::List === mal - return false unless Types::Symbol === mal.first - val = env.get(mal.first) - return false unless Types::Callable === val - val.is_macro? - rescue SymbolNotFoundError - false - end - - def macro_expand(mal, env) - while is_macro_call?(mal, env) - macro_fn = env.get(mal.first) - - if (args = mal[1..]).any? - mal = macro_fn.call(Types::Args.new(mal[1..])) - else - mal = macro_fn.call - end - end - - mal - end -end - -Mal.boot_repl! - -if Mal.run_application? - Mal.run! -else - while input = Readline.readline("user> ") - val = Mal.rep(input) - puts val unless val.nil? - end - - puts -end +require "readline" + +require_relative "core" +require_relative "env" +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + def boot_repl! + @repl_env = Env.new + + Core.ns.each do |k, v| + @repl_env.set(k, v) + end + + @repl_env.set( + Types::Symbol.for("eval"), + + Types::Builtin.new("eval") do |mal| + Mal.EVAL(mal.first, @repl_env) + end + ) + + Mal.rep("(def! not (fn* (a) (if a false true)))") + Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + Mal.rep("(def! *ARGV* (list))") if !run_application? + Mal.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)))))))") + end + + def run_application? + ARGV.any? + end + + def run! + args = ARGV[1..].map(&:inspect) + + if args.any? + Mal.rep("(def! *ARGV* (list #{args.join(" ")}))") + else + Mal.rep("(def! *ARGV* (list))") + end + + puts Mal.rep("(load-file #{ARGV.first.inspect})") + end + + def READ(input) + read_str(input) + end + + def EVAL(ast, environment) + loop do + ast = macro_expand(ast, environment) + + if Types::List === ast && ast.size > 0 + case ast.first + when Types::Symbol.for("def!") + _, sym, val = ast + return environment.set(sym, EVAL(val, environment)) + when Types::Symbol.for("defmacro!") + _, sym, val = ast + result = EVAL(val, environment) + + case result + when Types::Function + return environment.set(sym, result.to_macro) + else + raise TypeError + end + when Types::Symbol.for("macroexpand") + _, ast_rest = ast + return macro_expand(ast_rest, environment) + when Types::Symbol.for("let*") + e = Env.new(environment) + _, bindings, val = ast + + unless Types::List === bindings || Types::Vector === bindings + raise InvalidLetBindingsError + end + + until bindings.empty? + k, v = bindings.shift(2) + + raise InvalidLetBindingsError if k.nil? + v = Types::Nil.instance if v.nil? + + e.set(k, EVAL(v, e)) + end + + if !val.nil? + # Continue loop + ast = val + environment = e + else + return Types::Nil.instance + end + when Types::Symbol.for("do") + _, *values = ast + + if !values.nil? && values.any? + values[0...-1].each do |v| + EVAL(v, environment) + end + + # Continue loop + ast = values.last + else + return Types::Nil.instance + end + when Types::Symbol.for("if") + _, condition, when_true, when_false = ast + + case EVAL(condition, environment) + when Types::False.instance, Types::Nil.instance + if !when_false.nil? + # Continue loop + ast = when_false + else + return Types::Nil.instance + end + else + if !when_true.nil? + # Continue loop + ast = when_true + else + raise InvalidIfExpressionError + end + end + when Types::Symbol.for("fn*") + _, binds, to_eval = ast + + return Types::Function.new(to_eval, binds, environment) do |*exprs| + EVAL(to_eval, Env.new(environment, binds, exprs)) + end + when Types::Symbol.for("quote") + _, ret = ast + return ret + when Types::Symbol.for("quasiquote") + _, ast_rest = ast + ast = quasiquote(ast_rest) + when Types::Symbol.for("quasiquoteexpand") + _, ast_rest = ast + return quasiquote(ast_rest) + when Types::Symbol.for("try*") + _, to_try, catch_list = ast + + begin + return EVAL(to_try, environment) + rescue => e + raise e if catch_list.nil? || catch_list&.empty? + raise SyntaxError, "try* missing proper catch*" unless catch_list&.first == Types::Symbol.for("catch*") + + _, exception_symbol, exception_handler = catch_list + + value = + if e.is_a?(MalError) + e.value + else + Types::String.new(e.message) + end + + return EVAL( + exception_handler, + Env.new( + environment, + Types::List.new([exception_symbol]), + Types::List.new([value]) + ) + ) + end + else + evaluated = eval_ast(ast, environment) + maybe_callable = evaluated.first + + if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? + # Continue loop + ast = maybe_callable.ast + environment = Env.new( + maybe_callable.env, + maybe_callable.params, + evaluated[1..], + ) + elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? + return maybe_callable.call(Types::Args.new(evaluated[1..])) + else + raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." + end + end + elsif Types::List === ast && ast.size == 0 + return ast + else + return eval_ast(ast, environment) + end + end + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input), @repl_env)) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue NotCallableError => e + e.message + rescue SymbolNotFoundError => e + e.message + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + rescue MalError => e + "Error: #{pr_str(e.value, true)}" + rescue Error, TypeError => e + "#{e.class} -- #{e.message}" + rescue SkipCommentError + nil + end + + def eval_ast(mal, environment) + case mal + when Types::Symbol + environment.get(mal) + when Types::List + list = Types::List.new + mal.each { |i| list << EVAL(i, environment) } + list + when Types::Vector + vec = Types::Vector.new + mal.each { |i| vec << EVAL(i, environment) } + vec + when Types::Hashmap + hashmap = Types::Hashmap.new + mal.each { |k, v| hashmap[k] = EVAL(v, environment) } + hashmap + else + mal + end + end + + def quasiquote_list(mal) + result = Types::List.new + + mal.reverse_each do |elt| + if elt.is_a?(Types::List) && elt.first == Types::Symbol.for("splice-unquote") + result = Types::List.new([ + Types::Symbol.for("concat"), + elt[1], + result + ]) + else + result = Types::List.new([ + Types::Symbol.for("cons"), + quasiquote(elt), + result + ]) + end + end + + result + end + + def quasiquote(mal) + case mal + when Types::List + if mal.first == Types::Symbol.for("unquote") + mal[1] + else + quasiquote_list(mal) + end + when Types::Vector + Types::List.new([ + Types::Symbol.for("vec"), + quasiquote_list(mal) + ]) + when Types::Hashmap, Types::Symbol + Types::List.new([ + Types::Symbol.for("quote"), + mal + ]) + else + mal + end + end + + def is_macro_call?(mal, env) + return false unless Types::List === mal + return false unless Types::Symbol === mal.first + val = env.get(mal.first) + return false unless Types::Callable === val + val.is_macro? + rescue SymbolNotFoundError + false + end + + def macro_expand(mal, env) + while is_macro_call?(mal, env) + macro_fn = env.get(mal.first) + + if (args = mal[1..]).any? + mal = macro_fn.call(Types::Args.new(mal[1..])) + else + mal = macro_fn.call + end + end + + mal + end +end + +Mal.boot_repl! + +if Mal.run_application? + Mal.run! +else + while input = Readline.readline("user> ") + val = Mal.rep(input) + puts val unless val.nil? + end + + puts +end diff --git a/impls/ruby.2/stepA_mal.rb b/impls/ruby.2/stepA_mal.rb index 16283a15c4..607eaf96ba 100644 --- a/impls/ruby.2/stepA_mal.rb +++ b/impls/ruby.2/stepA_mal.rb @@ -1,345 +1,345 @@ -require "readline" - -require_relative "core" -require_relative "env" -require_relative "errors" -require_relative "printer" -require_relative "reader" - -module Mal - extend self - - def boot_repl! - @repl_env = Env.new - - Core.ns.each do |k, v| - @repl_env.set(k, v) - end - - @repl_env.set( - Types::Symbol.for("eval"), - - Types::Builtin.new("eval") do |mal| - Mal.EVAL(mal, @repl_env) - end - ) - - Mal.rep("(def! not (fn* (a) (if a false true)))") - Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - Mal.rep("(def! *host-language* \"ruby.2\")") - Mal.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)))))))") - - if !run_application? - Mal.rep("(def! *ARGV* (list))") - Mal.rep("(println (str \"Mal [\" \*host-language\* \"]\"))") - end - end - - def run_application? - ARGV.any? - end - - def run! - args = ARGV[1..].map(&:inspect) - - if args.any? - Mal.rep("(def! *ARGV* (list #{args.join(" ")}))") - else - Mal.rep("(def! *ARGV* (list))") - end - - file = File.absolute_path(ARGV.first) - - Dir.chdir(File.dirname(file)) do - Mal.rep("(load-file #{file.inspect})") - end - end - - def READ(input) - read_str(input) - end - - def EVAL(ast, environment) - loop do - ast = macro_expand(ast, environment) - - if Types::List === ast && ast.size > 0 - case ast.first - when Types::Symbol.for("def!") - _, sym, val = ast - return environment.set(sym, EVAL(val, environment)) - when Types::Symbol.for("defmacro!") - _, sym, val = ast - result = EVAL(val, environment) - - case result - when Types::Function - return environment.set(sym, result.to_macro) - else - raise TypeError, "defmacro! must be bound to a function" - end - when Types::Symbol.for("macroexpand") - _, ast_rest = ast - return macro_expand(ast_rest, environment) - when Types::Symbol.for("let*") - e = Env.new(environment) - _, bindings, val = ast - bindings = bindings.dup # TODO note bugfix let bindings w/ TCO loop and destructive mutation (shift) - - unless Types::List === bindings || Types::Vector === bindings - raise InvalidLetBindingsError, "let* bindings must be a list or vector" - end - - until bindings.empty? - k, v = bindings.shift(2) - - raise InvalidLetBindingsError, "Invalid let* bindings 'nil' key" if k.nil? - v = Types::Nil.instance if v.nil? - - e.set(k, EVAL(v, e)) - end - - if !val.nil? - # Continue loop - ast = val - environment = e - else - return Types::Nil.instance - end - when Types::Symbol.for("do") - _, *values = ast - - if !values.nil? && values.any? - values[0...-1].each do |v| - EVAL(v, environment) - end - - # Continue loop - ast = values.last - else - return Types::Nil.instance - end - when Types::Symbol.for("if") - _, condition, when_true, when_false = ast - - case EVAL(condition, environment) - when Types::False.instance, Types::Nil.instance - if !when_false.nil? - # Continue loop - ast = when_false - else - return Types::Nil.instance - end - else - if !when_true.nil? - # Continue loop - ast = when_true - else - raise InvalidIfExpressionError, "No expression to evaluate when true" - end - end - when Types::Symbol.for("fn*") - _, binds, to_eval = ast - - return Types::Function.new(to_eval, binds, environment) do |*exprs| - EVAL(to_eval, Env.new(environment, binds, exprs)) - end - when Types::Symbol.for("quote") - _, ret = ast - return ret - when Types::Symbol.for("quasiquote") - _, ast_rest = ast - ast = quasiquote(ast_rest) - when Types::Symbol.for("quasiquoteexpand") - _, ast_rest = ast - return quasiquote(ast_rest) - when Types::Symbol.for("try*") - _, to_try, catch_list = ast - - begin - return EVAL(to_try, environment) - rescue => e - raise e if catch_list.nil? || catch_list&.empty? - raise SyntaxError, "try* missing proper catch*" unless catch_list&.first == Types::Symbol.for("catch*") - - _, exception_symbol, exception_handler = catch_list - - value = - if e.is_a?(MalError) - e.value - else - Types::String.new(e.message) - end - - return EVAL( - exception_handler, - Env.new( - environment, - Types::List.new([exception_symbol]), - Types::List.new([value]) - ) - ) - end - else - evaluated = eval_ast(ast, environment) - maybe_callable = evaluated.first - - if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? - # Continue loop - ast = maybe_callable.ast - environment = Env.new( - maybe_callable.env, - maybe_callable.params, - evaluated[1..], - ) - elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? - if (args = evaluated[1..]).any? - return maybe_callable.call(Types::Args.new(args)) - else - return maybe_callable.call(Types::Args.new) - end - else - raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." - end - end - elsif Types::List === ast && ast.size == 0 - return ast - else - return eval_ast(ast, environment) - end - end - end - - def PRINT(input) - pr_str(input, true) - end - - def rep(input) - PRINT(EVAL(READ(input), @repl_env)) - rescue InvalidHashmapKeyError => e - "Error! Hashmap keys can only be strings or keywords." - rescue NotCallableError => e - e.message - rescue SymbolNotFoundError => e - e.message - rescue UnbalancedEscapingError => e - "Error! Detected unbalanced escaping. Check for matching '\\'." - rescue UnbalancedHashmapError => e - "Error! Detected unbalanced list. Check for matching '}'." - rescue UnbalancedListError => e - "Error! Detected unbalanced list. Check for matching ')'." - rescue UnbalancedStringError => e - "Error! Detected unbalanced string. Check for matching '\"'." - rescue UnbalancedVectorError => e - "Error! Detected unbalanced list. Check for matching ']'." - rescue MalError => e - "Error: #{pr_str(e.value, true)}" - rescue Error, TypeError => e - "#{e.class} -- #{e.message}" - rescue SkipCommentError - nil - end - - def eval_ast(mal, environment) - case mal - when Types::Symbol - environment.get(mal) - when Types::List - list = Types::List.new - mal.each { |i| list << EVAL(i, environment) } - list - when Types::Vector - vec = Types::Vector.new - mal.each { |i| vec << EVAL(i, environment) } - vec - when Types::Hashmap - hashmap = Types::Hashmap.new - mal.each { |k, v| hashmap[k] = EVAL(v, environment) } - hashmap - else - mal - end - end - - def quasiquote_list(mal) - result = Types::List.new - - mal.reverse_each do |elt| - if elt.is_a?(Types::List) && elt.first == Types::Symbol.for("splice-unquote") - result = Types::List.new([ - Types::Symbol.for("concat"), - elt[1], - result - ]) - else - result = Types::List.new([ - Types::Symbol.for("cons"), - quasiquote(elt), - result - ]) - end - end - - result - end - - def quasiquote(mal) - case mal - when Types::List - if mal.first == Types::Symbol.for("unquote") - mal[1] - else - quasiquote_list(mal) - end - when Types::Vector - Types::List.new([ - Types::Symbol.for("vec"), - quasiquote_list(mal) - ]) - when Types::Hashmap, Types::Symbol - Types::List.new([ - Types::Symbol.for("quote"), - mal - ]) - else - mal - end - end - - def is_macro_call?(mal, env) - return false unless Types::List === mal - return false unless Types::Symbol === mal.first - val = env.get(mal.first) - return false unless Types::Callable === val - val.is_macro? - rescue SymbolNotFoundError - false - end - - def macro_expand(mal, env) - while is_macro_call?(mal, env) - macro_fn = env.get(mal.first) - - if (args = mal[1..]).any? - mal = macro_fn.call(Types::Args.new(mal[1..])) - else - mal = macro_fn.call - end - end - - mal - end -end - -Mal.boot_repl! - -if Mal.run_application? - Mal.run! -else - while input = Readline.readline("user> ") - val = Mal.rep(input) - puts val unless val.nil? - end - - puts -end +require "readline" + +require_relative "core" +require_relative "env" +require_relative "errors" +require_relative "printer" +require_relative "reader" + +module Mal + extend self + + def boot_repl! + @repl_env = Env.new + + Core.ns.each do |k, v| + @repl_env.set(k, v) + end + + @repl_env.set( + Types::Symbol.for("eval"), + + Types::Builtin.new("eval") do |mal| + Mal.EVAL(mal, @repl_env) + end + ) + + Mal.rep("(def! not (fn* (a) (if a false true)))") + Mal.rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + Mal.rep("(def! *host-language* \"ruby.2\")") + Mal.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)))))))") + + if !run_application? + Mal.rep("(def! *ARGV* (list))") + Mal.rep("(println (str \"Mal [\" \*host-language\* \"]\"))") + end + end + + def run_application? + ARGV.any? + end + + def run! + args = ARGV[1..].map(&:inspect) + + if args.any? + Mal.rep("(def! *ARGV* (list #{args.join(" ")}))") + else + Mal.rep("(def! *ARGV* (list))") + end + + file = File.absolute_path(ARGV.first) + + Dir.chdir(File.dirname(file)) do + Mal.rep("(load-file #{file.inspect})") + end + end + + def READ(input) + read_str(input) + end + + def EVAL(ast, environment) + loop do + ast = macro_expand(ast, environment) + + if Types::List === ast && ast.size > 0 + case ast.first + when Types::Symbol.for("def!") + _, sym, val = ast + return environment.set(sym, EVAL(val, environment)) + when Types::Symbol.for("defmacro!") + _, sym, val = ast + result = EVAL(val, environment) + + case result + when Types::Function + return environment.set(sym, result.to_macro) + else + raise TypeError, "defmacro! must be bound to a function" + end + when Types::Symbol.for("macroexpand") + _, ast_rest = ast + return macro_expand(ast_rest, environment) + when Types::Symbol.for("let*") + e = Env.new(environment) + _, bindings, val = ast + bindings = bindings.dup # TODO note bugfix let bindings w/ TCO loop and destructive mutation (shift) + + unless Types::List === bindings || Types::Vector === bindings + raise InvalidLetBindingsError, "let* bindings must be a list or vector" + end + + until bindings.empty? + k, v = bindings.shift(2) + + raise InvalidLetBindingsError, "Invalid let* bindings 'nil' key" if k.nil? + v = Types::Nil.instance if v.nil? + + e.set(k, EVAL(v, e)) + end + + if !val.nil? + # Continue loop + ast = val + environment = e + else + return Types::Nil.instance + end + when Types::Symbol.for("do") + _, *values = ast + + if !values.nil? && values.any? + values[0...-1].each do |v| + EVAL(v, environment) + end + + # Continue loop + ast = values.last + else + return Types::Nil.instance + end + when Types::Symbol.for("if") + _, condition, when_true, when_false = ast + + case EVAL(condition, environment) + when Types::False.instance, Types::Nil.instance + if !when_false.nil? + # Continue loop + ast = when_false + else + return Types::Nil.instance + end + else + if !when_true.nil? + # Continue loop + ast = when_true + else + raise InvalidIfExpressionError, "No expression to evaluate when true" + end + end + when Types::Symbol.for("fn*") + _, binds, to_eval = ast + + return Types::Function.new(to_eval, binds, environment) do |*exprs| + EVAL(to_eval, Env.new(environment, binds, exprs)) + end + when Types::Symbol.for("quote") + _, ret = ast + return ret + when Types::Symbol.for("quasiquote") + _, ast_rest = ast + ast = quasiquote(ast_rest) + when Types::Symbol.for("quasiquoteexpand") + _, ast_rest = ast + return quasiquote(ast_rest) + when Types::Symbol.for("try*") + _, to_try, catch_list = ast + + begin + return EVAL(to_try, environment) + rescue => e + raise e if catch_list.nil? || catch_list&.empty? + raise SyntaxError, "try* missing proper catch*" unless catch_list&.first == Types::Symbol.for("catch*") + + _, exception_symbol, exception_handler = catch_list + + value = + if e.is_a?(MalError) + e.value + else + Types::String.new(e.message) + end + + return EVAL( + exception_handler, + Env.new( + environment, + Types::List.new([exception_symbol]), + Types::List.new([value]) + ) + ) + end + else + evaluated = eval_ast(ast, environment) + maybe_callable = evaluated.first + + if maybe_callable.respond_to?(:call) && maybe_callable.is_mal_fn? + # Continue loop + ast = maybe_callable.ast + environment = Env.new( + maybe_callable.env, + maybe_callable.params, + evaluated[1..], + ) + elsif maybe_callable.respond_to?(:call) && !maybe_callable.is_mal_fn? + if (args = evaluated[1..]).any? + return maybe_callable.call(Types::Args.new(args)) + else + return maybe_callable.call(Types::Args.new) + end + else + raise NotCallableError, "Error! #{PRINT(maybe_callable)} is not callable." + end + end + elsif Types::List === ast && ast.size == 0 + return ast + else + return eval_ast(ast, environment) + end + end + end + + def PRINT(input) + pr_str(input, true) + end + + def rep(input) + PRINT(EVAL(READ(input), @repl_env)) + rescue InvalidHashmapKeyError => e + "Error! Hashmap keys can only be strings or keywords." + rescue NotCallableError => e + e.message + rescue SymbolNotFoundError => e + e.message + rescue UnbalancedEscapingError => e + "Error! Detected unbalanced escaping. Check for matching '\\'." + rescue UnbalancedHashmapError => e + "Error! Detected unbalanced list. Check for matching '}'." + rescue UnbalancedListError => e + "Error! Detected unbalanced list. Check for matching ')'." + rescue UnbalancedStringError => e + "Error! Detected unbalanced string. Check for matching '\"'." + rescue UnbalancedVectorError => e + "Error! Detected unbalanced list. Check for matching ']'." + rescue MalError => e + "Error: #{pr_str(e.value, true)}" + rescue Error, TypeError => e + "#{e.class} -- #{e.message}" + rescue SkipCommentError + nil + end + + def eval_ast(mal, environment) + case mal + when Types::Symbol + environment.get(mal) + when Types::List + list = Types::List.new + mal.each { |i| list << EVAL(i, environment) } + list + when Types::Vector + vec = Types::Vector.new + mal.each { |i| vec << EVAL(i, environment) } + vec + when Types::Hashmap + hashmap = Types::Hashmap.new + mal.each { |k, v| hashmap[k] = EVAL(v, environment) } + hashmap + else + mal + end + end + + def quasiquote_list(mal) + result = Types::List.new + + mal.reverse_each do |elt| + if elt.is_a?(Types::List) && elt.first == Types::Symbol.for("splice-unquote") + result = Types::List.new([ + Types::Symbol.for("concat"), + elt[1], + result + ]) + else + result = Types::List.new([ + Types::Symbol.for("cons"), + quasiquote(elt), + result + ]) + end + end + + result + end + + def quasiquote(mal) + case mal + when Types::List + if mal.first == Types::Symbol.for("unquote") + mal[1] + else + quasiquote_list(mal) + end + when Types::Vector + Types::List.new([ + Types::Symbol.for("vec"), + quasiquote_list(mal) + ]) + when Types::Hashmap, Types::Symbol + Types::List.new([ + Types::Symbol.for("quote"), + mal + ]) + else + mal + end + end + + def is_macro_call?(mal, env) + return false unless Types::List === mal + return false unless Types::Symbol === mal.first + val = env.get(mal.first) + return false unless Types::Callable === val + val.is_macro? + rescue SymbolNotFoundError + false + end + + def macro_expand(mal, env) + while is_macro_call?(mal, env) + macro_fn = env.get(mal.first) + + if (args = mal[1..]).any? + mal = macro_fn.call(Types::Args.new(mal[1..])) + else + mal = macro_fn.call + end + end + + mal + end +end + +Mal.boot_repl! + +if Mal.run_application? + Mal.run! +else + while input = Readline.readline("user> ") + val = Mal.rep(input) + puts val unless val.nil? + end + + puts +end diff --git a/impls/ruby.2/types.rb b/impls/ruby.2/types.rb index d50c50b433..19b4a4693b 100644 --- a/impls/ruby.2/types.rb +++ b/impls/ruby.2/types.rb @@ -1,217 +1,217 @@ -module Mal - module Types - class Args < ::Array - end - - class List < ::Array - def meta - @meta ||= Types::Nil.instance - end - - def meta=(value) - @meta = value - end - - def to_list - self - end - end - - class Vector < ::Array - def meta - @meta ||= Types::Nil.instance - end - - def meta=(value) - @meta = value - end - - def to_list - List.new(self) - end - end - - class Hashmap < ::Hash - def meta - @meta ||= Types::Nil.instance - end - - def meta=(value) - @meta = value - end - end - - class Base < ::Struct.new(:value) - def inspect - value.inspect - end - end - - class String < Base; end - - class Atom < Base - def inspect - "Atom<#{value.inspect}>" - end - end - - class Keyword < Base - def self.for(value) - @_keywords ||= {} - - if @_keywords.key?(value) - @_keywords[value] - else - @_keywords[value] = new(value) - end - end - end - - class Number < Base - def +(other) - self.class.new(value + other.value) - end - - def -(other) - self.class.new(value - other.value) - end - - def *(other) - self.class.new(value * other.value) - end - - def /(other) - self.class.new(value / other.value) - end - end - - class Symbol < Base - def self.for(value) - @_symbols ||= {} - - if @_symbols.key?(value) - @_symbols[value] - else - @_symbols[value] = new(value) - end - end - - def inspect - value - end - end - - class Nil < Base - def self.instance - @_instance ||= new(nil) - end - - def inspect - "nil" - end - end - - class True < Base - def self.instance - @_instance ||= new(true) - end - end - - class False < Base - def self.instance - @_instance ||= new(false) - end - end - - class Callable - def initialize(&block) - @fn = block - end - - def call(args = nil) - args = Types::Args.new if args.nil? - raise unless args.is_a?(Types::Args) - @fn.call(*args) - end - - def inspect - raise NotImplementedError, "invalid callable" - end - - def is_mal_fn? - false - end - - def is_macro? - false - end - - def meta - @meta ||= Types::Nil.instance - end - - def meta=(value) - @meta = value - end - end - - class Builtin < Callable - attr_reader :name - - def initialize(name, &block) - @name = name - @fn = block - end - - def inspect - "#" - end - end - - class Function < Callable - attr_reader :ast, :params, :env - - def initialize(ast, params, env, &block) - @ast = ast - @params = params - @env = env - @fn = block - end - - def inspect - "#" - end - - def is_mal_fn? - true - end - - def to_macro - Macro.new(ast, params, env, &@fn) - end - end - - class Macro < Callable - attr_reader :ast, :params, :env - - def initialize(ast, params, env, &block) - @ast = ast - @params = params - @env = env - @fn = block - end - - def inspect - "#" - end - - def is_mal_fn? - true - end - - def is_macro? - true - end - end - end -end +module Mal + module Types + class Args < ::Array + end + + class List < ::Array + def meta + @meta ||= Types::Nil.instance + end + + def meta=(value) + @meta = value + end + + def to_list + self + end + end + + class Vector < ::Array + def meta + @meta ||= Types::Nil.instance + end + + def meta=(value) + @meta = value + end + + def to_list + List.new(self) + end + end + + class Hashmap < ::Hash + def meta + @meta ||= Types::Nil.instance + end + + def meta=(value) + @meta = value + end + end + + class Base < ::Struct.new(:value) + def inspect + value.inspect + end + end + + class String < Base; end + + class Atom < Base + def inspect + "Atom<#{value.inspect}>" + end + end + + class Keyword < Base + def self.for(value) + @_keywords ||= {} + + if @_keywords.key?(value) + @_keywords[value] + else + @_keywords[value] = new(value) + end + end + end + + class Number < Base + def +(other) + self.class.new(value + other.value) + end + + def -(other) + self.class.new(value - other.value) + end + + def *(other) + self.class.new(value * other.value) + end + + def /(other) + self.class.new(value / other.value) + end + end + + class Symbol < Base + def self.for(value) + @_symbols ||= {} + + if @_symbols.key?(value) + @_symbols[value] + else + @_symbols[value] = new(value) + end + end + + def inspect + value + end + end + + class Nil < Base + def self.instance + @_instance ||= new(nil) + end + + def inspect + "nil" + end + end + + class True < Base + def self.instance + @_instance ||= new(true) + end + end + + class False < Base + def self.instance + @_instance ||= new(false) + end + end + + class Callable + def initialize(&block) + @fn = block + end + + def call(args = nil) + args = Types::Args.new if args.nil? + raise unless args.is_a?(Types::Args) + @fn.call(*args) + end + + def inspect + raise NotImplementedError, "invalid callable" + end + + def is_mal_fn? + false + end + + def is_macro? + false + end + + def meta + @meta ||= Types::Nil.instance + end + + def meta=(value) + @meta = value + end + end + + class Builtin < Callable + attr_reader :name + + def initialize(name, &block) + @name = name + @fn = block + end + + def inspect + "#" + end + end + + class Function < Callable + attr_reader :ast, :params, :env + + def initialize(ast, params, env, &block) + @ast = ast + @params = params + @env = env + @fn = block + end + + def inspect + "#" + end + + def is_mal_fn? + true + end + + def to_macro + Macro.new(ast, params, env, &@fn) + end + end + + class Macro < Callable + attr_reader :ast, :params, :env + + def initialize(ast, params, env, &block) + @ast = ast + @params = params + @env = env + @fn = block + end + + def inspect + "#" + end + + def is_mal_fn? + true + end + + def is_macro? + true + end + end + end +end diff --git a/impls/ruby/Dockerfile b/impls/ruby/Dockerfile index 3bda3bf706..da52643b6c 100644 --- a/impls/ruby/Dockerfile +++ b/impls/ruby/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install ruby +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install ruby diff --git a/impls/ruby/Makefile b/impls/ruby/Makefile index 13470a4e3d..931d8429ef 100644 --- a/impls/ruby/Makefile +++ b/impls/ruby/Makefile @@ -1,19 +1,19 @@ -SOURCES_BASE = mal_readline.rb types.rb reader.rb printer.rb -SOURCES_LISP = env.rb core.rb stepA_mal.rb -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.rb mal - -mal.rb: $(SOURCES) - cat $+ | grep -v "^require_relative" > $@ - -mal: mal.rb - echo "#!/usr/bin/env ruby" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.rb mal +SOURCES_BASE = mal_readline.rb types.rb reader.rb printer.rb +SOURCES_LISP = env.rb core.rb stepA_mal.rb +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.rb mal + +mal.rb: $(SOURCES) + cat $+ | grep -v "^require_relative" > $@ + +mal: mal.rb + echo "#!/usr/bin/env ruby" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.rb mal diff --git a/impls/ruby/core.rb b/impls/ruby/core.rb index 4322df0162..9033f8766f 100644 --- a/impls/ruby/core.rb +++ b/impls/ruby/core.rb @@ -1,73 +1,73 @@ -require "readline" -require_relative "reader" -require_relative "printer" - -$core_ns = { - :"=" => lambda {|a,b| a == b}, - :throw => lambda {|a| raise MalException.new(a), "Mal Exception"}, - :nil? => lambda {|a| a == nil}, - :true? => lambda {|a| a == true}, - :false? => lambda {|a| a == false}, - :string? => lambda {|a| (a.is_a? String) && "\u029e" != a[0]}, - :symbol => lambda {|a| a.to_sym}, - :symbol? => lambda {|a| a.is_a? Symbol}, - :keyword => lambda {|a| (a.is_a? String) && "\u029e" == a[0] ? a : "\u029e"+a}, - :keyword? => lambda {|a| (a.is_a? String) && "\u029e" == a[0]}, - :number? => lambda {|a| a.is_a? Numeric}, - :fn? => lambda {|a| (a.is_a? Proc) && (!(a.is_a? Function) || !a.is_macro)}, - :macro? => lambda {|a| (a.is_a? Function) && a.is_macro}, - - :"pr-str" => lambda {|*a| a.map {|e| _pr_str(e, true)}.join(" ")}, - :str => lambda {|*a| a.map {|e| _pr_str(e, false)}.join("")}, - :prn => lambda {|*a| puts(a.map {|e| _pr_str(e, true)}.join(" "))}, - :println => lambda {|*a| puts(a.map {|e| _pr_str(e, false)}.join(" "))}, - :readline => lambda {|a| Readline.readline(a,true)}, - :"read-string" => lambda {|a| read_str(a)}, - :slurp => lambda {|a| File.read(a)}, - :< => lambda {|a,b| a < b}, - :<= => lambda {|a,b| a <= b}, - :> => lambda {|a,b| a > b}, - :>= => lambda {|a,b| a >= b}, - :+ => lambda {|a,b| a + b}, - :- => lambda {|a,b| a - b}, - :* => lambda {|a,b| a * b}, - :/ => lambda {|a,b| a / b}, - :"time-ms" => lambda {|| (Time.now.to_f * 1000).to_i}, - - :list => lambda {|*a| List.new a}, - :list? => lambda {|*a| a[0].is_a? List}, - :vector => lambda {|*a| Vector.new a}, - :vector? => lambda {|*a| a[0].is_a? Vector}, - :"hash-map" =>lambda {|*a| Hash[a.each_slice(2).to_a]}, - :map? => lambda {|a| a.is_a? Hash}, - :assoc => lambda {|*a| a[0].merge(Hash[a.drop(1).each_slice(2).to_a])}, - :dissoc => lambda {|*a| h = a[0].clone; a.drop(1).each{|k| h.delete k}; h}, - :get => lambda {|a,b| return nil if a == nil; a[b]}, - :contains? => lambda {|a,b| a.key? b}, - :keys => lambda {|a| List.new a.keys}, - :vals => lambda {|a| List.new a.values}, - - :sequential? => lambda {|a| sequential?(a)}, - :vec => lambda {|a| Vector.new a}, - :cons => lambda {|a,b| List.new(b.clone.insert(0,a))}, - :concat => lambda {|*a| List.new(a && a.reduce(:+) || [])}, - :nth => lambda {|a,b| raise "nth: index out of range" if b >= a.size; a[b]}, - :first => lambda {|a| a.nil? ? nil : a[0]}, - :rest => lambda {|a| List.new(a.nil? || a.size == 0 ? [] : a.drop(1))}, - :empty? => lambda {|a| a.size == 0}, - :count => lambda {|a| return 0 if a == nil; a.size}, - :apply => lambda {|*a| a[0][*a[1..-2].concat(a[-1])]}, - :map => lambda {|a,b| List.new(b.map {|e| a[e]})}, - - :conj => lambda {|*a| a[0].clone.conj(a.drop(1))}, - :seq => lambda {|a| a.nil? ? nil : a.size == 0 ? nil : a.seq}, - - :"with-meta" => lambda {|a,b| x = a.clone; x.meta = b; x}, - :meta => lambda {|a| a.meta}, - :atom => lambda {|a| Atom.new(a)}, - :atom? => lambda {|a| a.is_a? Atom}, - :deref => lambda {|a| a.val}, - :reset! => lambda {|a,b| a.val = b}, - :swap! => lambda {|*a| a[0].val = a[1][*[a[0].val].concat(a.drop(2))]}, -} - +require "readline" +require_relative "reader" +require_relative "printer" + +$core_ns = { + :"=" => lambda {|a,b| a == b}, + :throw => lambda {|a| raise MalException.new(a), "Mal Exception"}, + :nil? => lambda {|a| a == nil}, + :true? => lambda {|a| a == true}, + :false? => lambda {|a| a == false}, + :string? => lambda {|a| (a.is_a? String) && "\u029e" != a[0]}, + :symbol => lambda {|a| a.to_sym}, + :symbol? => lambda {|a| a.is_a? Symbol}, + :keyword => lambda {|a| (a.is_a? String) && "\u029e" == a[0] ? a : "\u029e"+a}, + :keyword? => lambda {|a| (a.is_a? String) && "\u029e" == a[0]}, + :number? => lambda {|a| a.is_a? Numeric}, + :fn? => lambda {|a| (a.is_a? Proc) && (!(a.is_a? Function) || !a.is_macro)}, + :macro? => lambda {|a| (a.is_a? Function) && a.is_macro}, + + :"pr-str" => lambda {|*a| a.map {|e| _pr_str(e, true)}.join(" ")}, + :str => lambda {|*a| a.map {|e| _pr_str(e, false)}.join("")}, + :prn => lambda {|*a| puts(a.map {|e| _pr_str(e, true)}.join(" "))}, + :println => lambda {|*a| puts(a.map {|e| _pr_str(e, false)}.join(" "))}, + :readline => lambda {|a| Readline.readline(a,true)}, + :"read-string" => lambda {|a| read_str(a)}, + :slurp => lambda {|a| File.read(a)}, + :< => lambda {|a,b| a < b}, + :<= => lambda {|a,b| a <= b}, + :> => lambda {|a,b| a > b}, + :>= => lambda {|a,b| a >= b}, + :+ => lambda {|a,b| a + b}, + :- => lambda {|a,b| a - b}, + :* => lambda {|a,b| a * b}, + :/ => lambda {|a,b| a / b}, + :"time-ms" => lambda {|| (Time.now.to_f * 1000).to_i}, + + :list => lambda {|*a| List.new a}, + :list? => lambda {|*a| a[0].is_a? List}, + :vector => lambda {|*a| Vector.new a}, + :vector? => lambda {|*a| a[0].is_a? Vector}, + :"hash-map" =>lambda {|*a| Hash[a.each_slice(2).to_a]}, + :map? => lambda {|a| a.is_a? Hash}, + :assoc => lambda {|*a| a[0].merge(Hash[a.drop(1).each_slice(2).to_a])}, + :dissoc => lambda {|*a| h = a[0].clone; a.drop(1).each{|k| h.delete k}; h}, + :get => lambda {|a,b| return nil if a == nil; a[b]}, + :contains? => lambda {|a,b| a.key? b}, + :keys => lambda {|a| List.new a.keys}, + :vals => lambda {|a| List.new a.values}, + + :sequential? => lambda {|a| sequential?(a)}, + :vec => lambda {|a| Vector.new a}, + :cons => lambda {|a,b| List.new(b.clone.insert(0,a))}, + :concat => lambda {|*a| List.new(a && a.reduce(:+) || [])}, + :nth => lambda {|a,b| raise "nth: index out of range" if b >= a.size; a[b]}, + :first => lambda {|a| a.nil? ? nil : a[0]}, + :rest => lambda {|a| List.new(a.nil? || a.size == 0 ? [] : a.drop(1))}, + :empty? => lambda {|a| a.size == 0}, + :count => lambda {|a| return 0 if a == nil; a.size}, + :apply => lambda {|*a| a[0][*a[1..-2].concat(a[-1])]}, + :map => lambda {|a,b| List.new(b.map {|e| a[e]})}, + + :conj => lambda {|*a| a[0].clone.conj(a.drop(1))}, + :seq => lambda {|a| a.nil? ? nil : a.size == 0 ? nil : a.seq}, + + :"with-meta" => lambda {|a,b| x = a.clone; x.meta = b; x}, + :meta => lambda {|a| a.meta}, + :atom => lambda {|a| Atom.new(a)}, + :atom? => lambda {|a| a.is_a? Atom}, + :deref => lambda {|a| a.val}, + :reset! => lambda {|a,b| a.val = b}, + :swap! => lambda {|*a| a[0].val = a[1][*[a[0].val].concat(a.drop(2))]}, +} + diff --git a/impls/ruby/env.rb b/impls/ruby/env.rb index 97dfa13ef6..388f1f7cbf 100644 --- a/impls/ruby/env.rb +++ b/impls/ruby/env.rb @@ -1,37 +1,37 @@ -class Env - attr_accessor :data - def initialize(outer=nil, binds=[], exprs=[]) - @data = {} - @outer = outer - binds.each_index do |i| - if binds[i] == :"&" - data[binds[i+1]] = exprs.drop(i) - break - else - data[binds[i]] = exprs[i] - end - end - return self - end - - def find(key) - if @data.key? key - return self - elsif @outer - return @outer.find(key) - else - return nil - end - end - - def set(key, value) - @data[key] = value - return value - end - - def get(key) - env = find(key) - raise "'" + key.to_s + "' not found" if not env - env.data[key] - end -end +class Env + attr_accessor :data + def initialize(outer=nil, binds=[], exprs=[]) + @data = {} + @outer = outer + binds.each_index do |i| + if binds[i] == :"&" + data[binds[i+1]] = exprs.drop(i) + break + else + data[binds[i]] = exprs[i] + end + end + return self + end + + def find(key) + if @data.key? key + return self + elsif @outer + return @outer.find(key) + else + return nil + end + end + + def set(key, value) + @data[key] = value + return value + end + + def get(key) + env = find(key) + raise "'" + key.to_s + "' not found" if not env + env.data[key] + end +end diff --git a/impls/ruby/mal_readline.rb b/impls/ruby/mal_readline.rb index 89b6777892..14616ae758 100644 --- a/impls/ruby/mal_readline.rb +++ b/impls/ruby/mal_readline.rb @@ -1,22 +1,22 @@ -require "readline" - -$history_loaded = false -$histfile = "#{ENV['HOME']}/.mal-history" - -def _readline(prompt) - if !$history_loaded && File.exist?($histfile) - $history_loaded = true - if File.readable?($histfile) - File.readlines($histfile).each {|l| Readline::HISTORY.push(l.chomp)} - end - end - - if line = Readline.readline(prompt, true) - if File.writable?($histfile) - File.open($histfile, 'a+') {|f| f.write(line+"\n")} - end - return line - else - return nil - end -end +require "readline" + +$history_loaded = false +$histfile = "#{ENV['HOME']}/.mal-history" + +def _readline(prompt) + if !$history_loaded && File.exist?($histfile) + $history_loaded = true + if File.readable?($histfile) + File.readlines($histfile).each {|l| Readline::HISTORY.push(l.chomp)} + end + end + + if line = Readline.readline(prompt, true) + if File.writable?($histfile) + File.open($histfile, 'a+') {|f| f.write(line+"\n")} + end + return line + else + return nil + end +end diff --git a/impls/ruby/printer.rb b/impls/ruby/printer.rb index ef067a5ac0..f34a082818 100644 --- a/impls/ruby/printer.rb +++ b/impls/ruby/printer.rb @@ -1,29 +1,29 @@ -require_relative "types" - -def _pr_str(obj, print_readably=true) - _r = print_readably - return case obj - when List - "(" + obj.map{|x| _pr_str(x, _r)}.join(" ") + ")" - when Vector - "[" + obj.map{|x| _pr_str(x, _r)}.join(" ") + "]" - when Hash - ret = [] - obj.each{|k,v| ret.push(_pr_str(k,_r), _pr_str(v,_r))} - "{" + ret.join(" ") + "}" - when String - if obj[0] == "\u029e" - ":" + obj[1..-1] - elsif _r - obj.inspect # escape special characters - else - obj - end - when Atom - "(atom " + _pr_str(obj.val, true) + ")" - when nil - "nil" - else - obj.to_s - end -end +require_relative "types" + +def _pr_str(obj, print_readably=true) + _r = print_readably + return case obj + when List + "(" + obj.map{|x| _pr_str(x, _r)}.join(" ") + ")" + when Vector + "[" + obj.map{|x| _pr_str(x, _r)}.join(" ") + "]" + when Hash + ret = [] + obj.each{|k,v| ret.push(_pr_str(k,_r), _pr_str(v,_r))} + "{" + ret.join(" ") + "}" + when String + if obj[0] == "\u029e" + ":" + obj[1..-1] + elsif _r + obj.inspect # escape special characters + else + obj + end + when Atom + "(atom " + _pr_str(obj.val, true) + ")" + when nil + "nil" + else + obj.to_s + end +end diff --git a/impls/ruby/reader.rb b/impls/ruby/reader.rb index bc87be4fae..ba5d60b9a7 100644 --- a/impls/ruby/reader.rb +++ b/impls/ruby/reader.rb @@ -1,86 +1,86 @@ -require_relative "types" - -class Reader - def initialize(tokens) - @position = 0 - @tokens = tokens - end - def peek - return @tokens[@position] - end - def next - @position += 1 - return @tokens[@position-1] - end -end - - -def tokenize(str) - re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ - return str.scan(re).map{|m| m[0]}.select{ |t| - t != "" && t[0..0] != ";" - } -end - -def parse_str(t) # trim and unescape - return t[1..-2].gsub(/\\./, {"\\\\" => "\\", "\\n" => "\n", "\\\"" => '"'}) -end - -def read_atom(rdr) - token = rdr.next - return case token - when /^-?[0-9]+$/ then token.to_i # integer - when /^-?[0-9][0-9.]*$/ then token.to_f # float - when /^"(?:\\.|[^\\"])*"$/ then parse_str(token) # string - when /^"/ then raise "expected '\"', got EOF" - when /^:/ then "\u029e" + token[1..-1] # keyword - when "nil" then nil - when "true" then true - when "false" then false - else token.to_sym # symbol - end -end - -def read_list(rdr, klass, start="(", last =")") - ast = klass.new - token = rdr.next() - if token != start - raise "expected '" + start + "'" - end - while (token = rdr.peek) != last - if not token - raise "expected '" + last + "', got EOF" - end - ast.push(read_form(rdr)) - end - rdr.next - return ast -end - -def read_form(rdr) - return case rdr.peek - when ";" then nil - when "'" then rdr.next; List.new [:quote, read_form(rdr)] - when "`" then rdr.next; List.new [:quasiquote, read_form(rdr)] - when "~" then rdr.next; List.new [:unquote, read_form(rdr)] - when "~@" then rdr.next; List.new [:"splice-unquote", read_form(rdr)] - when "^" then rdr.next; meta = read_form(rdr); - List.new [:"with-meta", read_form(rdr), meta] - when "@" then rdr.next; List.new [:deref, read_form(rdr)] - - when "(" then read_list(rdr, List, "(", ")") - when ")" then raise "unexpected ')'" - when "[" then read_list(rdr, Vector, "[", "]") - when "]" then raise "unexpected ']'" - when "{" then Hash[read_list(rdr, List, "{", "}").each_slice(2).to_a] - when "}" then raise "unexpected '}'" - else read_atom(rdr) - end -end - -def read_str(str) - tokens = tokenize(str) - return nil if tokens.size == 0 - return read_form(Reader.new(tokens)) -end - +require_relative "types" + +class Reader + def initialize(tokens) + @position = 0 + @tokens = tokens + end + def peek + return @tokens[@position] + end + def next + @position += 1 + return @tokens[@position-1] + end +end + + +def tokenize(str) + re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/ + return str.scan(re).map{|m| m[0]}.select{ |t| + t != "" && t[0..0] != ";" + } +end + +def parse_str(t) # trim and unescape + return t[1..-2].gsub(/\\./, {"\\\\" => "\\", "\\n" => "\n", "\\\"" => '"'}) +end + +def read_atom(rdr) + token = rdr.next + return case token + when /^-?[0-9]+$/ then token.to_i # integer + when /^-?[0-9][0-9.]*$/ then token.to_f # float + when /^"(?:\\.|[^\\"])*"$/ then parse_str(token) # string + when /^"/ then raise "expected '\"', got EOF" + when /^:/ then "\u029e" + token[1..-1] # keyword + when "nil" then nil + when "true" then true + when "false" then false + else token.to_sym # symbol + end +end + +def read_list(rdr, klass, start="(", last =")") + ast = klass.new + token = rdr.next() + if token != start + raise "expected '" + start + "'" + end + while (token = rdr.peek) != last + if not token + raise "expected '" + last + "', got EOF" + end + ast.push(read_form(rdr)) + end + rdr.next + return ast +end + +def read_form(rdr) + return case rdr.peek + when ";" then nil + when "'" then rdr.next; List.new [:quote, read_form(rdr)] + when "`" then rdr.next; List.new [:quasiquote, read_form(rdr)] + when "~" then rdr.next; List.new [:unquote, read_form(rdr)] + when "~@" then rdr.next; List.new [:"splice-unquote", read_form(rdr)] + when "^" then rdr.next; meta = read_form(rdr); + List.new [:"with-meta", read_form(rdr), meta] + when "@" then rdr.next; List.new [:deref, read_form(rdr)] + + when "(" then read_list(rdr, List, "(", ")") + when ")" then raise "unexpected ')'" + when "[" then read_list(rdr, Vector, "[", "]") + when "]" then raise "unexpected ']'" + when "{" then Hash[read_list(rdr, List, "{", "}").each_slice(2).to_a] + when "}" then raise "unexpected '}'" + else read_atom(rdr) + end +end + +def read_str(str) + tokens = tokenize(str) + return nil if tokens.size == 0 + return read_form(Reader.new(tokens)) +end + diff --git a/impls/ruby/run b/impls/ruby/run index 000320bf5f..8419c1022a 100755 --- a/impls/ruby/run +++ b/impls/ruby/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec ruby $(dirname $0)/${STEP:-stepA_mal}.rb "${@}" +#!/bin/bash +exec ruby $(dirname $0)/${STEP:-stepA_mal}.rb "${@}" diff --git a/impls/ruby/step0_repl.rb b/impls/ruby/step0_repl.rb index 2f9e6a91dc..85d5a80e68 100644 --- a/impls/ruby/step0_repl.rb +++ b/impls/ruby/step0_repl.rb @@ -1,26 +1,26 @@ -require_relative "mal_readline" - -# read -def READ(str) - return str -end - -# eval -def EVAL(ast, env) - return ast -end - -# print -def PRINT(exp) - return exp -end - -# repl -def REP(str) - return PRINT(EVAL(READ(str), {})) -end - -# repl loop -while line = _readline("user> ") - puts REP(line) -end +require_relative "mal_readline" + +# read +def READ(str) + return str +end + +# eval +def EVAL(ast, env) + return ast +end + +# print +def PRINT(exp) + return exp +end + +# repl +def REP(str) + return PRINT(EVAL(READ(str), {})) +end + +# repl loop +while line = _readline("user> ") + puts REP(line) +end diff --git a/impls/ruby/step1_read_print.rb b/impls/ruby/step1_read_print.rb index ef416c308f..8525b17cf9 100644 --- a/impls/ruby/step1_read_print.rb +++ b/impls/ruby/step1_read_print.rb @@ -1,34 +1,34 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" - -# read -def READ(str) - return read_str(str) -end - -# eval -def EVAL(ast, env) - return ast -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -def REP(str) - return PRINT(EVAL(READ(str), {})) -end - -# repl loop -while line = _readline("user> ") - begin - puts REP(line) - rescue Exception => e - puts "Error: #{e}" - puts "\t#{e.backtrace.join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" + +# read +def READ(str) + return read_str(str) +end + +# eval +def EVAL(ast, env) + return ast +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +def REP(str) + return PRINT(EVAL(READ(str), {})) +end + +# repl loop +while line = _readline("user> ") + begin + puts REP(line) + rescue Exception => e + puts "Error: #{e}" + puts "\t#{e.backtrace.join("\n\t")}" + end +end diff --git a/impls/ruby/step2_eval.rb b/impls/ruby/step2_eval.rb index 23e47b3ff0..08ab25f22d 100644 --- a/impls/ruby/step2_eval.rb +++ b/impls/ruby/step2_eval.rb @@ -1,68 +1,68 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" - -# read -def READ(str) - return read_str(str) -end - -# eval -def eval_ast(ast, env) - return case ast - when Symbol - raise "'" + ast.to_s + "' not found" if not env.key? ast - env[ast] - when List - List.new ast.map{|a| EVAL(a, env)} - when Vector - Vector.new ast.map{|a| EVAL(a, env)} - when Hash - new_hm = {} - ast.each{|k,v| new_hm[k] = EVAL(v, env)} - new_hm - else - ast - end -end - -def EVAL(ast, env) - #puts "EVAL: #{_pr_str(ast, true)}" - - if not ast.is_a? List - return eval_ast(ast, env) - end - if ast.empty? - return ast - end - - # apply list - el = eval_ast(ast, env) - f = el[0] - return f[*el.drop(1)] -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -repl_env = {} -REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } - -repl_env[:+] = lambda {|a,b| a + b} -repl_env[:-] = lambda {|a,b| a - b} -repl_env[:*] = lambda {|a,b| a * b} -repl_env[:/] = lambda {|a,b| a / b} - -# repl loop -while line = _readline("user> ") - begin - puts REP[line] - rescue Exception => e - puts "Error: #{e}" - puts "\t#{e.backtrace.join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" + +# read +def READ(str) + return read_str(str) +end + +# eval +def eval_ast(ast, env) + return case ast + when Symbol + raise "'" + ast.to_s + "' not found" if not env.key? ast + env[ast] + when List + List.new ast.map{|a| EVAL(a, env)} + when Vector + Vector.new ast.map{|a| EVAL(a, env)} + when Hash + new_hm = {} + ast.each{|k,v| new_hm[k] = EVAL(v, env)} + new_hm + else + ast + end +end + +def EVAL(ast, env) + #puts "EVAL: #{_pr_str(ast, true)}" + + if not ast.is_a? List + return eval_ast(ast, env) + end + if ast.empty? + return ast + end + + # apply list + el = eval_ast(ast, env) + f = el[0] + return f[*el.drop(1)] +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +repl_env = {} +REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } + +repl_env[:+] = lambda {|a,b| a + b} +repl_env[:-] = lambda {|a,b| a - b} +repl_env[:*] = lambda {|a,b| a * b} +repl_env[:/] = lambda {|a,b| a / b} + +# repl loop +while line = _readline("user> ") + begin + puts REP[line] + rescue Exception => e + puts "Error: #{e}" + puts "\t#{e.backtrace.join("\n\t")}" + end +end diff --git a/impls/ruby/step3_env.rb b/impls/ruby/step3_env.rb index ece32bd57f..8ca8935b43 100644 --- a/impls/ruby/step3_env.rb +++ b/impls/ruby/step3_env.rb @@ -1,80 +1,80 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" -require_relative "env" - -# read -def READ(str) - return read_str(str) -end - -# eval -def eval_ast(ast, env) - return case ast - when Symbol - env.get(ast) - when List - List.new ast.map{|a| EVAL(a, env)} - when Vector - Vector.new ast.map{|a| EVAL(a, env)} - when Hash - new_hm = {} - ast.each{|k,v| new_hm[k] = EVAL(v, env)} - new_hm - else - ast - end -end - -def EVAL(ast, env) - #puts "EVAL: #{_pr_str(ast, true)}" - - if not ast.is_a? List - return eval_ast(ast, env) - end - if ast.empty? - return ast - end - - # apply list - a0,a1,a2,a3 = ast - case a0 - when :def! - return env.set(a1, EVAL(a2, env)) - when :"let*" - let_env = Env.new(env) - a1.each_slice(2) do |a,e| - let_env.set(a, EVAL(e, let_env)) - end - return EVAL(a2, let_env) - else - el = eval_ast(ast, env) - f = el[0] - return f[*el.drop(1)] - end -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -repl_env = Env.new -REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } - -repl_env.set(:+, lambda {|a,b| a + b}) -repl_env.set(:-, lambda {|a,b| a - b}) -repl_env.set(:*, lambda {|a,b| a * b}) -repl_env.set(:/, lambda {|a,b| a / b}) - -# repl loop -while line = _readline("user> ") - begin - puts REP[line] - rescue Exception => e - puts "Error: #{e}" - puts "\t#{e.backtrace.join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" +require_relative "env" + +# read +def READ(str) + return read_str(str) +end + +# eval +def eval_ast(ast, env) + return case ast + when Symbol + env.get(ast) + when List + List.new ast.map{|a| EVAL(a, env)} + when Vector + Vector.new ast.map{|a| EVAL(a, env)} + when Hash + new_hm = {} + ast.each{|k,v| new_hm[k] = EVAL(v, env)} + new_hm + else + ast + end +end + +def EVAL(ast, env) + #puts "EVAL: #{_pr_str(ast, true)}" + + if not ast.is_a? List + return eval_ast(ast, env) + end + if ast.empty? + return ast + end + + # apply list + a0,a1,a2,a3 = ast + case a0 + when :def! + return env.set(a1, EVAL(a2, env)) + when :"let*" + let_env = Env.new(env) + a1.each_slice(2) do |a,e| + let_env.set(a, EVAL(e, let_env)) + end + return EVAL(a2, let_env) + else + el = eval_ast(ast, env) + f = el[0] + return f[*el.drop(1)] + end +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +repl_env = Env.new +REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } + +repl_env.set(:+, lambda {|a,b| a + b}) +repl_env.set(:-, lambda {|a,b| a - b}) +repl_env.set(:*, lambda {|a,b| a * b}) +repl_env.set(:/, lambda {|a,b| a / b}) + +# repl loop +while line = _readline("user> ") + begin + puts REP[line] + rescue Exception => e + puts "Error: #{e}" + puts "\t#{e.backtrace.join("\n\t")}" + end +end diff --git a/impls/ruby/step4_if_fn_do.rb b/impls/ruby/step4_if_fn_do.rb index 204dde6f5d..a752a96b05 100644 --- a/impls/ruby/step4_if_fn_do.rb +++ b/impls/ruby/step4_if_fn_do.rb @@ -1,98 +1,98 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" -require_relative "env" -require_relative "core" - -# read -def READ(str) - return read_str(str) -end - -# eval -def eval_ast(ast, env) - return case ast - when Symbol - env.get(ast) - when List - List.new ast.map{|a| EVAL(a, env)} - when Vector - Vector.new ast.map{|a| EVAL(a, env)} - when Hash - new_hm = {} - ast.each{|k,v| new_hm[k] = EVAL(v, env)} - new_hm - else - ast - end -end - -def EVAL(ast, env) - #puts "EVAL: #{_pr_str(ast, true)}" - - if not ast.is_a? List - return eval_ast(ast, env) - end - if ast.empty? - return ast - end - - # apply list - a0,a1,a2,a3 = ast - case a0 - when :def! - return env.set(a1, EVAL(a2, env)) - when :"let*" - let_env = Env.new(env) - a1.each_slice(2) do |a,e| - let_env.set(a, EVAL(e, let_env)) - end - return EVAL(a2, let_env) - when :do - el = eval_ast(ast.drop(1), env) - return el.last - when :if - cond = EVAL(a1, env) - if not cond - return nil if a3 == nil - return EVAL(a3, env) - else - return EVAL(a2, env) - end - when :"fn*" - return lambda {|*args| - EVAL(a2, Env.new(env, a1, List.new(args))) - } - else - el = eval_ast(ast, env) - f = el[0] - return f[*el.drop(1)] - end -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -repl_env = Env.new -RE = lambda {|str| EVAL(READ(str), repl_env) } -REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } - -# core.rb: defined using ruby -$core_ns.each do |k,v| repl_env.set(k,v) end - -# core.mal: defined using the language itself -RE["(def! not (fn* (a) (if a false true)))"] - -# repl loop -while line = _readline("user> ") - begin - puts REP[line] - rescue Exception => e - puts "Error: #{e}" - puts "\t#{e.backtrace.join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" +require_relative "env" +require_relative "core" + +# read +def READ(str) + return read_str(str) +end + +# eval +def eval_ast(ast, env) + return case ast + when Symbol + env.get(ast) + when List + List.new ast.map{|a| EVAL(a, env)} + when Vector + Vector.new ast.map{|a| EVAL(a, env)} + when Hash + new_hm = {} + ast.each{|k,v| new_hm[k] = EVAL(v, env)} + new_hm + else + ast + end +end + +def EVAL(ast, env) + #puts "EVAL: #{_pr_str(ast, true)}" + + if not ast.is_a? List + return eval_ast(ast, env) + end + if ast.empty? + return ast + end + + # apply list + a0,a1,a2,a3 = ast + case a0 + when :def! + return env.set(a1, EVAL(a2, env)) + when :"let*" + let_env = Env.new(env) + a1.each_slice(2) do |a,e| + let_env.set(a, EVAL(e, let_env)) + end + return EVAL(a2, let_env) + when :do + el = eval_ast(ast.drop(1), env) + return el.last + when :if + cond = EVAL(a1, env) + if not cond + return nil if a3 == nil + return EVAL(a3, env) + else + return EVAL(a2, env) + end + when :"fn*" + return lambda {|*args| + EVAL(a2, Env.new(env, a1, List.new(args))) + } + else + el = eval_ast(ast, env) + f = el[0] + return f[*el.drop(1)] + end +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +repl_env = Env.new +RE = lambda {|str| EVAL(READ(str), repl_env) } +REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } + +# core.rb: defined using ruby +$core_ns.each do |k,v| repl_env.set(k,v) end + +# core.mal: defined using the language itself +RE["(def! not (fn* (a) (if a false true)))"] + +# repl loop +while line = _readline("user> ") + begin + puts REP[line] + rescue Exception => e + puts "Error: #{e}" + puts "\t#{e.backtrace.join("\n\t")}" + end +end diff --git a/impls/ruby/step5_tco.rb b/impls/ruby/step5_tco.rb index 06e5767012..a02d94c1e3 100644 --- a/impls/ruby/step5_tco.rb +++ b/impls/ruby/step5_tco.rb @@ -1,108 +1,108 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" -require_relative "env" -require_relative "core" - -# read -def READ(str) - return read_str(str) -end - -# eval -def eval_ast(ast, env) - return case ast - when Symbol - env.get(ast) - when List - List.new ast.map{|a| EVAL(a, env)} - when Vector - Vector.new ast.map{|a| EVAL(a, env)} - when Hash - new_hm = {} - ast.each{|k,v| new_hm[k] = EVAL(v, env)} - new_hm - else - ast - end -end - -def EVAL(ast, env) - while true - - #puts "EVAL: #{_pr_str(ast, true)}" - - if not ast.is_a? List - return eval_ast(ast, env) - end - if ast.empty? - return ast - end - - # apply list - a0,a1,a2,a3 = ast - case a0 - when :def! - return env.set(a1, EVAL(a2, env)) - when :"let*" - let_env = Env.new(env) - a1.each_slice(2) do |a,e| - let_env.set(a, EVAL(e, let_env)) - end - env = let_env - ast = a2 # Continue loop (TCO) - when :do - eval_ast(ast[1..-2], env) - ast = ast.last # Continue loop (TCO) - when :if - cond = EVAL(a1, env) - if not cond - return nil if a3 == nil - ast = a3 # Continue loop (TCO) - else - ast = a2 # Continue loop (TCO) - end - when :"fn*" - return Function.new(a2, env, a1) {|*args| - EVAL(a2, Env.new(env, a1, List.new(args))) - } - else - el = eval_ast(ast, env) - f = el[0] - if f.class == Function - ast = f.ast - env = f.gen_env(el.drop(1)) # Continue loop (TCO) - else - return f[*el.drop(1)] - end - end - - end -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -repl_env = Env.new -RE = lambda {|str| EVAL(READ(str), repl_env) } -REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } - -# core.rb: defined using ruby -$core_ns.each do |k,v| repl_env.set(k,v) end - -# core.mal: defined using the language itself -RE["(def! not (fn* (a) (if a false true)))"] - -# repl loop -while line = _readline("user> ") - begin - puts REP[line] - rescue Exception => e - puts "Error: #{e}" - puts "\t#{e.backtrace[0..100].join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" +require_relative "env" +require_relative "core" + +# read +def READ(str) + return read_str(str) +end + +# eval +def eval_ast(ast, env) + return case ast + when Symbol + env.get(ast) + when List + List.new ast.map{|a| EVAL(a, env)} + when Vector + Vector.new ast.map{|a| EVAL(a, env)} + when Hash + new_hm = {} + ast.each{|k,v| new_hm[k] = EVAL(v, env)} + new_hm + else + ast + end +end + +def EVAL(ast, env) + while true + + #puts "EVAL: #{_pr_str(ast, true)}" + + if not ast.is_a? List + return eval_ast(ast, env) + end + if ast.empty? + return ast + end + + # apply list + a0,a1,a2,a3 = ast + case a0 + when :def! + return env.set(a1, EVAL(a2, env)) + when :"let*" + let_env = Env.new(env) + a1.each_slice(2) do |a,e| + let_env.set(a, EVAL(e, let_env)) + end + env = let_env + ast = a2 # Continue loop (TCO) + when :do + eval_ast(ast[1..-2], env) + ast = ast.last # Continue loop (TCO) + when :if + cond = EVAL(a1, env) + if not cond + return nil if a3 == nil + ast = a3 # Continue loop (TCO) + else + ast = a2 # Continue loop (TCO) + end + when :"fn*" + return Function.new(a2, env, a1) {|*args| + EVAL(a2, Env.new(env, a1, List.new(args))) + } + else + el = eval_ast(ast, env) + f = el[0] + if f.class == Function + ast = f.ast + env = f.gen_env(el.drop(1)) # Continue loop (TCO) + else + return f[*el.drop(1)] + end + end + + end +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +repl_env = Env.new +RE = lambda {|str| EVAL(READ(str), repl_env) } +REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } + +# core.rb: defined using ruby +$core_ns.each do |k,v| repl_env.set(k,v) end + +# core.mal: defined using the language itself +RE["(def! not (fn* (a) (if a false true)))"] + +# repl loop +while line = _readline("user> ") + begin + puts REP[line] + rescue Exception => e + puts "Error: #{e}" + puts "\t#{e.backtrace[0..100].join("\n\t")}" + end +end diff --git a/impls/ruby/step6_file.rb b/impls/ruby/step6_file.rb index 0a1b060cd4..0d6afabe38 100644 --- a/impls/ruby/step6_file.rb +++ b/impls/ruby/step6_file.rb @@ -1,116 +1,116 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" -require_relative "env" -require_relative "core" - -# read -def READ(str) - return read_str(str) -end - -# eval -def eval_ast(ast, env) - return case ast - when Symbol - env.get(ast) - when List - List.new ast.map{|a| EVAL(a, env)} - when Vector - Vector.new ast.map{|a| EVAL(a, env)} - when Hash - new_hm = {} - ast.each{|k,v| new_hm[k] = EVAL(v, env)} - new_hm - else - ast - end -end - -def EVAL(ast, env) - while true - - #puts "EVAL: #{_pr_str(ast, true)}" - - if not ast.is_a? List - return eval_ast(ast, env) - end - if ast.empty? - return ast - end - - # apply list - a0,a1,a2,a3 = ast - case a0 - when :def! - return env.set(a1, EVAL(a2, env)) - when :"let*" - let_env = Env.new(env) - a1.each_slice(2) do |a,e| - let_env.set(a, EVAL(e, let_env)) - end - env = let_env - ast = a2 # Continue loop (TCO) - when :do - eval_ast(ast[1..-2], env) - ast = ast.last # Continue loop (TCO) - when :if - cond = EVAL(a1, env) - if not cond - return nil if a3 == nil - ast = a3 # Continue loop (TCO) - else - ast = a2 # Continue loop (TCO) - end - when :"fn*" - return Function.new(a2, env, a1) {|*args| - EVAL(a2, Env.new(env, a1, List.new(args))) - } - else - el = eval_ast(ast, env) - f = el[0] - if f.class == Function - ast = f.ast - env = f.gen_env(el.drop(1)) # Continue loop (TCO) - else - return f[*el.drop(1)] - end - end - - end -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -repl_env = Env.new -RE = lambda {|str| EVAL(READ(str), repl_env) } -REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } - -# core.rb: defined using ruby -$core_ns.each do |k,v| repl_env.set(k,v) end -repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) -repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) - -# core.mal: defined using the language itself -RE["(def! not (fn* (a) (if a false true)))"] -RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] - -if ARGV.size > 0 - RE["(load-file \"" + ARGV[0] + "\")"] - exit 0 -end - -# repl loop -while line = _readline("user> ") - begin - puts REP[line] - rescue Exception => e - puts "Error: #{e}" - puts "\t#{e.backtrace.join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" +require_relative "env" +require_relative "core" + +# read +def READ(str) + return read_str(str) +end + +# eval +def eval_ast(ast, env) + return case ast + when Symbol + env.get(ast) + when List + List.new ast.map{|a| EVAL(a, env)} + when Vector + Vector.new ast.map{|a| EVAL(a, env)} + when Hash + new_hm = {} + ast.each{|k,v| new_hm[k] = EVAL(v, env)} + new_hm + else + ast + end +end + +def EVAL(ast, env) + while true + + #puts "EVAL: #{_pr_str(ast, true)}" + + if not ast.is_a? List + return eval_ast(ast, env) + end + if ast.empty? + return ast + end + + # apply list + a0,a1,a2,a3 = ast + case a0 + when :def! + return env.set(a1, EVAL(a2, env)) + when :"let*" + let_env = Env.new(env) + a1.each_slice(2) do |a,e| + let_env.set(a, EVAL(e, let_env)) + end + env = let_env + ast = a2 # Continue loop (TCO) + when :do + eval_ast(ast[1..-2], env) + ast = ast.last # Continue loop (TCO) + when :if + cond = EVAL(a1, env) + if not cond + return nil if a3 == nil + ast = a3 # Continue loop (TCO) + else + ast = a2 # Continue loop (TCO) + end + when :"fn*" + return Function.new(a2, env, a1) {|*args| + EVAL(a2, Env.new(env, a1, List.new(args))) + } + else + el = eval_ast(ast, env) + f = el[0] + if f.class == Function + ast = f.ast + env = f.gen_env(el.drop(1)) # Continue loop (TCO) + else + return f[*el.drop(1)] + end + end + + end +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +repl_env = Env.new +RE = lambda {|str| EVAL(READ(str), repl_env) } +REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } + +# core.rb: defined using ruby +$core_ns.each do |k,v| repl_env.set(k,v) end +repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) +repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) + +# core.mal: defined using the language itself +RE["(def! not (fn* (a) (if a false true)))"] +RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] + +if ARGV.size > 0 + RE["(load-file \"" + ARGV[0] + "\")"] + exit 0 +end + +# repl loop +while line = _readline("user> ") + begin + puts REP[line] + rescue Exception => e + puts "Error: #{e}" + puts "\t#{e.backtrace.join("\n\t")}" + end +end diff --git a/impls/ruby/step7_quote.rb b/impls/ruby/step7_quote.rb index de33426a85..ecf3303e61 100644 --- a/impls/ruby/step7_quote.rb +++ b/impls/ruby/step7_quote.rb @@ -1,153 +1,153 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" -require_relative "env" -require_relative "core" - -# read -def READ(str) - return read_str(str) -end - -# eval -def qq_loop(ast) - acc = List.new [] - ast.reverse_each do |elt| - if elt.is_a?(List) && elt.size == 2 && elt[0] == :"splice-unquote" - acc = List.new [:concat, elt[1], acc] - else - acc = List.new [:cons, quasiquote(elt), acc] - end - end - return acc -end - -def quasiquote(ast) - return case ast - when List - if ast.size == 2 && ast[0] == :unquote - ast[1] - else - qq_loop(ast) - end - when Vector - List.new [:vec, qq_loop(ast)] - when Hash - List.new [:quote, ast] - when Symbol - List.new [:quote, ast] - else - ast - end -end - -def eval_ast(ast, env) - return case ast - when Symbol - env.get(ast) - when List - List.new ast.map{|a| EVAL(a, env)} - when Vector - Vector.new ast.map{|a| EVAL(a, env)} - when Hash - new_hm = {} - ast.each{|k,v| new_hm[k] = EVAL(v, env)} - new_hm - else - ast - end -end - -def EVAL(ast, env) - while true - - #puts "EVAL: #{_pr_str(ast, true)}" - - if not ast.is_a? List - return eval_ast(ast, env) - end - if ast.empty? - return ast - end - - # apply list - a0,a1,a2,a3 = ast - case a0 - when :def! - return env.set(a1, EVAL(a2, env)) - when :"let*" - let_env = Env.new(env) - a1.each_slice(2) do |a,e| - let_env.set(a, EVAL(e, let_env)) - end - env = let_env - ast = a2 # Continue loop (TCO) - when :quote - return a1 - when :quasiquoteexpand - return quasiquote(a1); - when :quasiquote - ast = quasiquote(a1); # Continue loop (TCO) - when :do - eval_ast(ast[1..-2], env) - ast = ast.last # Continue loop (TCO) - when :if - cond = EVAL(a1, env) - if not cond - return nil if a3 == nil - ast = a3 # Continue loop (TCO) - else - ast = a2 # Continue loop (TCO) - end - when :"fn*" - return Function.new(a2, env, a1) {|*args| - EVAL(a2, Env.new(env, a1, List.new(args))) - } - else - el = eval_ast(ast, env) - f = el[0] - if f.class == Function - ast = f.ast - env = f.gen_env(el.drop(1)) # Continue loop (TCO) - else - return f[*el.drop(1)] - end - end - - end -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -repl_env = Env.new -RE = lambda {|str| EVAL(READ(str), repl_env) } -REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } - -# core.rb: defined using ruby -$core_ns.each do |k,v| repl_env.set(k,v) end -repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) -repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) - -# core.mal: defined using the language itself -RE["(def! not (fn* (a) (if a false true)))"] -RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] - -if ARGV.size > 0 - RE["(load-file \"" + ARGV[0] + "\")"] - exit 0 -end - -# repl loop -while line = _readline("user> ") - begin - puts REP[line] - rescue Exception => e - puts "Error: #{e}" - puts "\t#{e.backtrace.join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" +require_relative "env" +require_relative "core" + +# read +def READ(str) + return read_str(str) +end + +# eval +def qq_loop(ast) + acc = List.new [] + ast.reverse_each do |elt| + if elt.is_a?(List) && elt.size == 2 && elt[0] == :"splice-unquote" + acc = List.new [:concat, elt[1], acc] + else + acc = List.new [:cons, quasiquote(elt), acc] + end + end + return acc +end + +def quasiquote(ast) + return case ast + when List + if ast.size == 2 && ast[0] == :unquote + ast[1] + else + qq_loop(ast) + end + when Vector + List.new [:vec, qq_loop(ast)] + when Hash + List.new [:quote, ast] + when Symbol + List.new [:quote, ast] + else + ast + end +end + +def eval_ast(ast, env) + return case ast + when Symbol + env.get(ast) + when List + List.new ast.map{|a| EVAL(a, env)} + when Vector + Vector.new ast.map{|a| EVAL(a, env)} + when Hash + new_hm = {} + ast.each{|k,v| new_hm[k] = EVAL(v, env)} + new_hm + else + ast + end +end + +def EVAL(ast, env) + while true + + #puts "EVAL: #{_pr_str(ast, true)}" + + if not ast.is_a? List + return eval_ast(ast, env) + end + if ast.empty? + return ast + end + + # apply list + a0,a1,a2,a3 = ast + case a0 + when :def! + return env.set(a1, EVAL(a2, env)) + when :"let*" + let_env = Env.new(env) + a1.each_slice(2) do |a,e| + let_env.set(a, EVAL(e, let_env)) + end + env = let_env + ast = a2 # Continue loop (TCO) + when :quote + return a1 + when :quasiquoteexpand + return quasiquote(a1); + when :quasiquote + ast = quasiquote(a1); # Continue loop (TCO) + when :do + eval_ast(ast[1..-2], env) + ast = ast.last # Continue loop (TCO) + when :if + cond = EVAL(a1, env) + if not cond + return nil if a3 == nil + ast = a3 # Continue loop (TCO) + else + ast = a2 # Continue loop (TCO) + end + when :"fn*" + return Function.new(a2, env, a1) {|*args| + EVAL(a2, Env.new(env, a1, List.new(args))) + } + else + el = eval_ast(ast, env) + f = el[0] + if f.class == Function + ast = f.ast + env = f.gen_env(el.drop(1)) # Continue loop (TCO) + else + return f[*el.drop(1)] + end + end + + end +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +repl_env = Env.new +RE = lambda {|str| EVAL(READ(str), repl_env) } +REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } + +# core.rb: defined using ruby +$core_ns.each do |k,v| repl_env.set(k,v) end +repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) +repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) + +# core.mal: defined using the language itself +RE["(def! not (fn* (a) (if a false true)))"] +RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] + +if ARGV.size > 0 + RE["(load-file \"" + ARGV[0] + "\")"] + exit 0 +end + +# repl loop +while line = _readline("user> ") + begin + puts REP[line] + rescue Exception => e + puts "Error: #{e}" + puts "\t#{e.backtrace.join("\n\t")}" + end +end diff --git a/impls/ruby/step8_macros.rb b/impls/ruby/step8_macros.rb index 04ebaa0be7..b0af08ae6c 100644 --- a/impls/ruby/step8_macros.rb +++ b/impls/ruby/step8_macros.rb @@ -1,185 +1,185 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" -require_relative "env" -require_relative "core" - -# read -def READ(str) - return read_str(str) -end - -# eval -def starts_with(ast, sym) - return ast.is_a?(List) && ast.size == 2 && ast[0] == sym -end - -def qq_loop(ast) - acc = List.new [] - ast.reverse_each do |elt| - if starts_with(elt, :"splice-unquote") - acc = List.new [:concat, elt[1], acc] - else - acc = List.new [:cons, quasiquote(elt), acc] - end - end - return acc -end - -def quasiquote(ast) - return case ast - when List - if starts_with(ast, :unquote) - ast[1] - else - qq_loop(ast) - end - when Vector - List.new [:vec, qq_loop(ast)] - when Hash - List.new [:quote, ast] - when Symbol - List.new [:quote, ast] - else - ast - end -end - -def macro_call?(ast, env) - return (ast.is_a?(List) && - ast[0].is_a?(Symbol) && - env.find(ast[0]) && - env.get(ast[0]).is_a?(Function) && - env.get(ast[0]).is_macro) -end - -def macroexpand(ast, env) - while macro_call?(ast, env) - mac = env.get(ast[0]) - ast = mac[*ast.drop(1)] - end - return ast -end - -def eval_ast(ast, env) - return case ast - when Symbol - env.get(ast) - when List - List.new ast.map{|a| EVAL(a, env)} - when Vector - Vector.new ast.map{|a| EVAL(a, env)} - when Hash - new_hm = {} - ast.each{|k,v| new_hm[k] = EVAL(v, env)} - new_hm - else - ast - end -end - -def EVAL(ast, env) - while true - - #puts "EVAL: #{_pr_str(ast, true)}" - - if not ast.is_a? List - return eval_ast(ast, env) - end - - # apply list - ast = macroexpand(ast, env) - if not ast.is_a? List - return eval_ast(ast, env) - end - if ast.empty? - return ast - end - - a0,a1,a2,a3 = ast - case a0 - when :def! - return env.set(a1, EVAL(a2, env)) - when :"let*" - let_env = Env.new(env) - a1.each_slice(2) do |a,e| - let_env.set(a, EVAL(e, let_env)) - end - env = let_env - ast = a2 # Continue loop (TCO) - when :quote - return a1 - when :quasiquoteexpand - return quasiquote(a1); - when :quasiquote - ast = quasiquote(a1); # Continue loop (TCO) - when :defmacro! - func = EVAL(a2, env).clone - func.is_macro = true - return env.set(a1, func) - when :macroexpand - return macroexpand(a1, env) - when :do - eval_ast(ast[1..-2], env) - ast = ast.last # Continue loop (TCO) - when :if - cond = EVAL(a1, env) - if not cond - return nil if a3 == nil - ast = a3 # Continue loop (TCO) - else - ast = a2 # Continue loop (TCO) - end - when :"fn*" - return Function.new(a2, env, a1) {|*args| - EVAL(a2, Env.new(env, a1, List.new(args))) - } - else - el = eval_ast(ast, env) - f = el[0] - if f.class == Function - ast = f.ast - env = f.gen_env(el.drop(1)) # Continue loop (TCO) - else - return f[*el.drop(1)] - end - end - - end -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -repl_env = Env.new -RE = lambda {|str| EVAL(READ(str), repl_env) } -REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } - -# core.rb: defined using ruby -$core_ns.each do |k,v| repl_env.set(k,v) end -repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) -repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) - -# core.mal: defined using the language itself -RE["(def! not (fn* (a) (if a false true)))"] -RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] -RE["(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)))))))"] - -if ARGV.size > 0 - RE["(load-file \"" + ARGV[0] + "\")"] - exit 0 -end - -# repl loop -while line = _readline("user> ") - begin - puts REP[line] - rescue Exception => e - puts "Error: #{e}" - puts "\t#{e.backtrace.join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" +require_relative "env" +require_relative "core" + +# read +def READ(str) + return read_str(str) +end + +# eval +def starts_with(ast, sym) + return ast.is_a?(List) && ast.size == 2 && ast[0] == sym +end + +def qq_loop(ast) + acc = List.new [] + ast.reverse_each do |elt| + if starts_with(elt, :"splice-unquote") + acc = List.new [:concat, elt[1], acc] + else + acc = List.new [:cons, quasiquote(elt), acc] + end + end + return acc +end + +def quasiquote(ast) + return case ast + when List + if starts_with(ast, :unquote) + ast[1] + else + qq_loop(ast) + end + when Vector + List.new [:vec, qq_loop(ast)] + when Hash + List.new [:quote, ast] + when Symbol + List.new [:quote, ast] + else + ast + end +end + +def macro_call?(ast, env) + return (ast.is_a?(List) && + ast[0].is_a?(Symbol) && + env.find(ast[0]) && + env.get(ast[0]).is_a?(Function) && + env.get(ast[0]).is_macro) +end + +def macroexpand(ast, env) + while macro_call?(ast, env) + mac = env.get(ast[0]) + ast = mac[*ast.drop(1)] + end + return ast +end + +def eval_ast(ast, env) + return case ast + when Symbol + env.get(ast) + when List + List.new ast.map{|a| EVAL(a, env)} + when Vector + Vector.new ast.map{|a| EVAL(a, env)} + when Hash + new_hm = {} + ast.each{|k,v| new_hm[k] = EVAL(v, env)} + new_hm + else + ast + end +end + +def EVAL(ast, env) + while true + + #puts "EVAL: #{_pr_str(ast, true)}" + + if not ast.is_a? List + return eval_ast(ast, env) + end + + # apply list + ast = macroexpand(ast, env) + if not ast.is_a? List + return eval_ast(ast, env) + end + if ast.empty? + return ast + end + + a0,a1,a2,a3 = ast + case a0 + when :def! + return env.set(a1, EVAL(a2, env)) + when :"let*" + let_env = Env.new(env) + a1.each_slice(2) do |a,e| + let_env.set(a, EVAL(e, let_env)) + end + env = let_env + ast = a2 # Continue loop (TCO) + when :quote + return a1 + when :quasiquoteexpand + return quasiquote(a1); + when :quasiquote + ast = quasiquote(a1); # Continue loop (TCO) + when :defmacro! + func = EVAL(a2, env).clone + func.is_macro = true + return env.set(a1, func) + when :macroexpand + return macroexpand(a1, env) + when :do + eval_ast(ast[1..-2], env) + ast = ast.last # Continue loop (TCO) + when :if + cond = EVAL(a1, env) + if not cond + return nil if a3 == nil + ast = a3 # Continue loop (TCO) + else + ast = a2 # Continue loop (TCO) + end + when :"fn*" + return Function.new(a2, env, a1) {|*args| + EVAL(a2, Env.new(env, a1, List.new(args))) + } + else + el = eval_ast(ast, env) + f = el[0] + if f.class == Function + ast = f.ast + env = f.gen_env(el.drop(1)) # Continue loop (TCO) + else + return f[*el.drop(1)] + end + end + + end +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +repl_env = Env.new +RE = lambda {|str| EVAL(READ(str), repl_env) } +REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } + +# core.rb: defined using ruby +$core_ns.each do |k,v| repl_env.set(k,v) end +repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) +repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) + +# core.mal: defined using the language itself +RE["(def! not (fn* (a) (if a false true)))"] +RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] +RE["(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)))))))"] + +if ARGV.size > 0 + RE["(load-file \"" + ARGV[0] + "\")"] + exit 0 +end + +# repl loop +while line = _readline("user> ") + begin + puts REP[line] + rescue Exception => e + puts "Error: #{e}" + puts "\t#{e.backtrace.join("\n\t")}" + end +end diff --git a/impls/ruby/step9_try.rb b/impls/ruby/step9_try.rb index d4b2bde72d..e8ee8a337d 100644 --- a/impls/ruby/step9_try.rb +++ b/impls/ruby/step9_try.rb @@ -1,204 +1,204 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" -require_relative "env" -require_relative "core" - -# read -def READ(str) - return read_str(str) -end - -# eval -def starts_with(ast, sym) - return ast.is_a?(List) && ast.size == 2 && ast[0] == sym -end - -def qq_loop(ast) - acc = List.new [] - ast.reverse_each do |elt| - if starts_with(elt, :"splice-unquote") - acc = List.new [:concat, elt[1], acc] - else - acc = List.new [:cons, quasiquote(elt), acc] - end - end - return acc -end - -def quasiquote(ast) - return case ast - when List - if starts_with(ast, :unquote) - ast[1] - else - qq_loop(ast) - end - when Vector - List.new [:vec, qq_loop(ast)] - when Hash - List.new [:quote, ast] - when Symbol - List.new [:quote, ast] - else - ast - end -end - -def macro_call?(ast, env) - return (ast.is_a?(List) && - ast[0].is_a?(Symbol) && - env.find(ast[0]) && - env.get(ast[0]).is_a?(Function) && - env.get(ast[0]).is_macro) -end - -def macroexpand(ast, env) - while macro_call?(ast, env) - mac = env.get(ast[0]) - ast = mac[*ast.drop(1)] - end - return ast -end - -def eval_ast(ast, env) - return case ast - when Symbol - env.get(ast) - when List - List.new ast.map{|a| EVAL(a, env)} - when Vector - Vector.new ast.map{|a| EVAL(a, env)} - when Hash - new_hm = {} - ast.each{|k,v| new_hm[k] = EVAL(v, env)} - new_hm - else - ast - end -end - -def EVAL(ast, env) - while true - - #puts "EVAL: #{_pr_str(ast, true)}" - - if not ast.is_a? List - return eval_ast(ast, env) - end - - # apply list - ast = macroexpand(ast, env) - if not ast.is_a? List - return eval_ast(ast, env) - end - if ast.empty? - return ast - end - - a0,a1,a2,a3 = ast - case a0 - when :def! - return env.set(a1, EVAL(a2, env)) - when :"let*" - let_env = Env.new(env) - a1.each_slice(2) do |a,e| - let_env.set(a, EVAL(e, let_env)) - end - env = let_env - ast = a2 # Continue loop (TCO) - when :quote - return a1 - when :quasiquoteexpand - return quasiquote(a1); - when :quasiquote - ast = quasiquote(a1); # Continue loop (TCO) - when :defmacro! - func = EVAL(a2, env).clone - func.is_macro = true - return env.set(a1, func) - when :macroexpand - return macroexpand(a1, env) - when :"try*" - begin - return EVAL(a1, env) - rescue Exception => exc - if exc.is_a? MalException - exc = exc.data - else - exc = exc.message - end - if a2 && a2[0] == :"catch*" - return EVAL(a2[2], Env.new(env, [a2[1]], [exc])) - else - raise exc - end - end - when :do - eval_ast(ast[1..-2], env) - ast = ast.last # Continue loop (TCO) - when :if - cond = EVAL(a1, env) - if not cond - return nil if a3 == nil - ast = a3 # Continue loop (TCO) - else - ast = a2 # Continue loop (TCO) - end - when :"fn*" - return Function.new(a2, env, a1) {|*args| - EVAL(a2, Env.new(env, a1, List.new(args))) - } - else - el = eval_ast(ast, env) - f = el[0] - if f.class == Function - ast = f.ast - env = f.gen_env(el.drop(1)) # Continue loop (TCO) - else - return f[*el.drop(1)] - end - end - - end -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -repl_env = Env.new -RE = lambda {|str| EVAL(READ(str), repl_env) } -REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } - -# core.rb: defined using ruby -$core_ns.each do |k,v| repl_env.set(k,v) end -repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) -repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) - -# core.mal: defined using the language itself -RE["(def! not (fn* (a) (if a false true)))"] -RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] -RE["(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)))))))"] - -if ARGV.size > 0 - RE["(load-file \"" + ARGV[0] + "\")"] - exit 0 -end - -# repl loop -while line = _readline("user> ") - begin - puts REP[line] - rescue Exception => e - if e.is_a? MalException - puts "Error: #{_pr_str(e.data, true)}" - else - puts "Error: #{e}" - end - puts "\t#{e.backtrace.join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" +require_relative "env" +require_relative "core" + +# read +def READ(str) + return read_str(str) +end + +# eval +def starts_with(ast, sym) + return ast.is_a?(List) && ast.size == 2 && ast[0] == sym +end + +def qq_loop(ast) + acc = List.new [] + ast.reverse_each do |elt| + if starts_with(elt, :"splice-unquote") + acc = List.new [:concat, elt[1], acc] + else + acc = List.new [:cons, quasiquote(elt), acc] + end + end + return acc +end + +def quasiquote(ast) + return case ast + when List + if starts_with(ast, :unquote) + ast[1] + else + qq_loop(ast) + end + when Vector + List.new [:vec, qq_loop(ast)] + when Hash + List.new [:quote, ast] + when Symbol + List.new [:quote, ast] + else + ast + end +end + +def macro_call?(ast, env) + return (ast.is_a?(List) && + ast[0].is_a?(Symbol) && + env.find(ast[0]) && + env.get(ast[0]).is_a?(Function) && + env.get(ast[0]).is_macro) +end + +def macroexpand(ast, env) + while macro_call?(ast, env) + mac = env.get(ast[0]) + ast = mac[*ast.drop(1)] + end + return ast +end + +def eval_ast(ast, env) + return case ast + when Symbol + env.get(ast) + when List + List.new ast.map{|a| EVAL(a, env)} + when Vector + Vector.new ast.map{|a| EVAL(a, env)} + when Hash + new_hm = {} + ast.each{|k,v| new_hm[k] = EVAL(v, env)} + new_hm + else + ast + end +end + +def EVAL(ast, env) + while true + + #puts "EVAL: #{_pr_str(ast, true)}" + + if not ast.is_a? List + return eval_ast(ast, env) + end + + # apply list + ast = macroexpand(ast, env) + if not ast.is_a? List + return eval_ast(ast, env) + end + if ast.empty? + return ast + end + + a0,a1,a2,a3 = ast + case a0 + when :def! + return env.set(a1, EVAL(a2, env)) + when :"let*" + let_env = Env.new(env) + a1.each_slice(2) do |a,e| + let_env.set(a, EVAL(e, let_env)) + end + env = let_env + ast = a2 # Continue loop (TCO) + when :quote + return a1 + when :quasiquoteexpand + return quasiquote(a1); + when :quasiquote + ast = quasiquote(a1); # Continue loop (TCO) + when :defmacro! + func = EVAL(a2, env).clone + func.is_macro = true + return env.set(a1, func) + when :macroexpand + return macroexpand(a1, env) + when :"try*" + begin + return EVAL(a1, env) + rescue Exception => exc + if exc.is_a? MalException + exc = exc.data + else + exc = exc.message + end + if a2 && a2[0] == :"catch*" + return EVAL(a2[2], Env.new(env, [a2[1]], [exc])) + else + raise exc + end + end + when :do + eval_ast(ast[1..-2], env) + ast = ast.last # Continue loop (TCO) + when :if + cond = EVAL(a1, env) + if not cond + return nil if a3 == nil + ast = a3 # Continue loop (TCO) + else + ast = a2 # Continue loop (TCO) + end + when :"fn*" + return Function.new(a2, env, a1) {|*args| + EVAL(a2, Env.new(env, a1, List.new(args))) + } + else + el = eval_ast(ast, env) + f = el[0] + if f.class == Function + ast = f.ast + env = f.gen_env(el.drop(1)) # Continue loop (TCO) + else + return f[*el.drop(1)] + end + end + + end +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +repl_env = Env.new +RE = lambda {|str| EVAL(READ(str), repl_env) } +REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } + +# core.rb: defined using ruby +$core_ns.each do |k,v| repl_env.set(k,v) end +repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) +repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) + +# core.mal: defined using the language itself +RE["(def! not (fn* (a) (if a false true)))"] +RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] +RE["(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)))))))"] + +if ARGV.size > 0 + RE["(load-file \"" + ARGV[0] + "\")"] + exit 0 +end + +# repl loop +while line = _readline("user> ") + begin + puts REP[line] + rescue Exception => e + if e.is_a? MalException + puts "Error: #{_pr_str(e.data, true)}" + else + puts "Error: #{e}" + end + puts "\t#{e.backtrace.join("\n\t")}" + end +end diff --git a/impls/ruby/stepA_mal.rb b/impls/ruby/stepA_mal.rb index 4f1b0d4453..96123cae7d 100644 --- a/impls/ruby/stepA_mal.rb +++ b/impls/ruby/stepA_mal.rb @@ -1,212 +1,212 @@ -require_relative "mal_readline" -require_relative "types" -require_relative "reader" -require_relative "printer" -require_relative "env" -require_relative "core" - -# read -def READ(str) - return read_str(str) -end - -# eval -def starts_with(ast, sym) - return ast.is_a?(List) && ast.size == 2 && ast[0] == sym -end - -def qq_loop(ast) - acc = List.new [] - ast.reverse_each do |elt| - if starts_with(elt, :"splice-unquote") - acc = List.new [:concat, elt[1], acc] - else - acc = List.new [:cons, quasiquote(elt), acc] - end - end - return acc -end - -def quasiquote(ast) - return case ast - when List - if starts_with(ast, :unquote) - ast[1] - else - qq_loop(ast) - end - when Vector - List.new [:vec, qq_loop(ast)] - when Hash - List.new [:quote, ast] - when Symbol - List.new [:quote, ast] - else - ast - end -end - -def macro_call?(ast, env) - return (ast.is_a?(List) && - ast[0].is_a?(Symbol) && - env.find(ast[0]) && - env.get(ast[0]).is_a?(Function) && - env.get(ast[0]).is_macro) -end - -def macroexpand(ast, env) - while macro_call?(ast, env) - mac = env.get(ast[0]) - ast = mac[*ast.drop(1)] - end - return ast -end - -def eval_ast(ast, env) - return case ast - when Symbol - env.get(ast) - when List - List.new ast.map{|a| EVAL(a, env)} - when Vector - Vector.new ast.map{|a| EVAL(a, env)} - when Hash - new_hm = {} - ast.each{|k,v| new_hm[k] = EVAL(v, env)} - new_hm - else - ast - end -end - -def EVAL(ast, env) - while true - - #puts "EVAL: #{_pr_str(ast, true)}" - - if not ast.is_a? List - return eval_ast(ast, env) - end - - # apply list - ast = macroexpand(ast, env) - if not ast.is_a? List - return eval_ast(ast, env) - end - if ast.empty? - return ast - end - - a0,a1,a2,a3 = ast - case a0 - when :def! - return env.set(a1, EVAL(a2, env)) - when :"let*" - let_env = Env.new(env) - a1.each_slice(2) do |a,e| - let_env.set(a, EVAL(e, let_env)) - end - env = let_env - ast = a2 # Continue loop (TCO) - when :quote - return a1 - when :quasiquoteexpand - return quasiquote(a1); - when :quasiquote - ast = quasiquote(a1); # Continue loop (TCO) - when :defmacro! - func = EVAL(a2, env).clone - func.is_macro = true - return env.set(a1, func) - when :macroexpand - return macroexpand(a1, env) - when :"rb*" - res = eval(a1) - return case res - when Array; List.new res - else; res - end - when :"try*" - begin - return EVAL(a1, env) - rescue Exception => exc - if exc.is_a? MalException - exc = exc.data - else - exc = exc.message - end - if a2 && a2[0] == :"catch*" - return EVAL(a2[2], Env.new(env, [a2[1]], [exc])) - else - raise exc - end - end - when :do - eval_ast(ast[1..-2], env) - ast = ast.last # Continue loop (TCO) - when :if - cond = EVAL(a1, env) - if not cond - return nil if a3 == nil - ast = a3 # Continue loop (TCO) - else - ast = a2 # Continue loop (TCO) - end - when :"fn*" - return Function.new(a2, env, a1) {|*args| - EVAL(a2, Env.new(env, a1, List.new(args))) - } - else - el = eval_ast(ast, env) - f = el[0] - if f.class == Function - ast = f.ast - env = f.gen_env(el.drop(1)) # Continue loop (TCO) - else - return f[*el.drop(1)] - end - end - - end -end - -# print -def PRINT(exp) - return _pr_str(exp, true) -end - -# repl -repl_env = Env.new -RE = lambda {|str| EVAL(READ(str), repl_env) } -REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } - -# core.rb: defined using ruby -$core_ns.each do |k,v| repl_env.set(k,v) end -repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) -repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) - -# core.mal: defined using the language itself -RE["(def! *host-language* \"ruby\")"] -RE["(def! not (fn* (a) (if a false true)))"] -RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] -RE["(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)))))))"] - -if ARGV.size > 0 - RE["(load-file \"" + ARGV[0] + "\")"] - exit 0 -end - -# repl loop -RE["(println (str \"Mal [\" *host-language* \"]\"))"] -while line = _readline("user> ") - begin - puts REP[line] - rescue Exception => e - if e.is_a? MalException - puts "Error: #{_pr_str(e.data, true)}" - else - puts "Error: #{e}" - end - puts "\t#{e.backtrace.join("\n\t")}" - end -end +require_relative "mal_readline" +require_relative "types" +require_relative "reader" +require_relative "printer" +require_relative "env" +require_relative "core" + +# read +def READ(str) + return read_str(str) +end + +# eval +def starts_with(ast, sym) + return ast.is_a?(List) && ast.size == 2 && ast[0] == sym +end + +def qq_loop(ast) + acc = List.new [] + ast.reverse_each do |elt| + if starts_with(elt, :"splice-unquote") + acc = List.new [:concat, elt[1], acc] + else + acc = List.new [:cons, quasiquote(elt), acc] + end + end + return acc +end + +def quasiquote(ast) + return case ast + when List + if starts_with(ast, :unquote) + ast[1] + else + qq_loop(ast) + end + when Vector + List.new [:vec, qq_loop(ast)] + when Hash + List.new [:quote, ast] + when Symbol + List.new [:quote, ast] + else + ast + end +end + +def macro_call?(ast, env) + return (ast.is_a?(List) && + ast[0].is_a?(Symbol) && + env.find(ast[0]) && + env.get(ast[0]).is_a?(Function) && + env.get(ast[0]).is_macro) +end + +def macroexpand(ast, env) + while macro_call?(ast, env) + mac = env.get(ast[0]) + ast = mac[*ast.drop(1)] + end + return ast +end + +def eval_ast(ast, env) + return case ast + when Symbol + env.get(ast) + when List + List.new ast.map{|a| EVAL(a, env)} + when Vector + Vector.new ast.map{|a| EVAL(a, env)} + when Hash + new_hm = {} + ast.each{|k,v| new_hm[k] = EVAL(v, env)} + new_hm + else + ast + end +end + +def EVAL(ast, env) + while true + + #puts "EVAL: #{_pr_str(ast, true)}" + + if not ast.is_a? List + return eval_ast(ast, env) + end + + # apply list + ast = macroexpand(ast, env) + if not ast.is_a? List + return eval_ast(ast, env) + end + if ast.empty? + return ast + end + + a0,a1,a2,a3 = ast + case a0 + when :def! + return env.set(a1, EVAL(a2, env)) + when :"let*" + let_env = Env.new(env) + a1.each_slice(2) do |a,e| + let_env.set(a, EVAL(e, let_env)) + end + env = let_env + ast = a2 # Continue loop (TCO) + when :quote + return a1 + when :quasiquoteexpand + return quasiquote(a1); + when :quasiquote + ast = quasiquote(a1); # Continue loop (TCO) + when :defmacro! + func = EVAL(a2, env).clone + func.is_macro = true + return env.set(a1, func) + when :macroexpand + return macroexpand(a1, env) + when :"rb*" + res = eval(a1) + return case res + when Array; List.new res + else; res + end + when :"try*" + begin + return EVAL(a1, env) + rescue Exception => exc + if exc.is_a? MalException + exc = exc.data + else + exc = exc.message + end + if a2 && a2[0] == :"catch*" + return EVAL(a2[2], Env.new(env, [a2[1]], [exc])) + else + raise exc + end + end + when :do + eval_ast(ast[1..-2], env) + ast = ast.last # Continue loop (TCO) + when :if + cond = EVAL(a1, env) + if not cond + return nil if a3 == nil + ast = a3 # Continue loop (TCO) + else + ast = a2 # Continue loop (TCO) + end + when :"fn*" + return Function.new(a2, env, a1) {|*args| + EVAL(a2, Env.new(env, a1, List.new(args))) + } + else + el = eval_ast(ast, env) + f = el[0] + if f.class == Function + ast = f.ast + env = f.gen_env(el.drop(1)) # Continue loop (TCO) + else + return f[*el.drop(1)] + end + end + + end +end + +# print +def PRINT(exp) + return _pr_str(exp, true) +end + +# repl +repl_env = Env.new +RE = lambda {|str| EVAL(READ(str), repl_env) } +REP = lambda {|str| PRINT(EVAL(READ(str), repl_env)) } + +# core.rb: defined using ruby +$core_ns.each do |k,v| repl_env.set(k,v) end +repl_env.set(:eval, lambda {|ast| EVAL(ast, repl_env)}) +repl_env.set(:"*ARGV*", List.new(ARGV.slice(1,ARGV.length) || [])) + +# core.mal: defined using the language itself +RE["(def! *host-language* \"ruby\")"] +RE["(def! not (fn* (a) (if a false true)))"] +RE["(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"] +RE["(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)))))))"] + +if ARGV.size > 0 + RE["(load-file \"" + ARGV[0] + "\")"] + exit 0 +end + +# repl loop +RE["(println (str \"Mal [\" *host-language* \"]\"))"] +while line = _readline("user> ") + begin + puts REP[line] + rescue Exception => e + if e.is_a? MalException + puts "Error: #{_pr_str(e.data, true)}" + else + puts "Error: #{e}" + end + puts "\t#{e.backtrace.join("\n\t")}" + end +end diff --git a/impls/ruby/tests/step5_tco.mal b/impls/ruby/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/ruby/tests/step5_tco.mal +++ b/impls/ruby/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/ruby/tests/stepA_mal.mal b/impls/ruby/tests/stepA_mal.mal index 79cca1984b..c1e28169e7 100644 --- a/impls/ruby/tests/stepA_mal.mal +++ b/impls/ruby/tests/stepA_mal.mal @@ -1,27 +1,27 @@ -;; Testing basic ruby interop - -(rb* "7") -;=>7 - -(rb* "'7'") -;=>"7" - -(rb* "[7,8,9]") -;=>(7 8 9) - -(rb* "{\"abc\" => 789}") -;=>{"abc" 789} - -(rb* "print 'hello\n'") -;/hello -;=>nil - -(rb* "$foo=8;") -(rb* "$foo") -;=>8 - -(rb* "['a','b','c'].map{|x| 'X'+x+'Y'}.join(' ')") -;=>"XaY XbY XcY" - -(rb* "[1,2,3].map{|x| 1+x}") -;=>(2 3 4) +;; Testing basic ruby interop + +(rb* "7") +;=>7 + +(rb* "'7'") +;=>"7" + +(rb* "[7,8,9]") +;=>(7 8 9) + +(rb* "{\"abc\" => 789}") +;=>{"abc" 789} + +(rb* "print 'hello\n'") +;/hello +;=>nil + +(rb* "$foo=8;") +(rb* "$foo") +;=>8 + +(rb* "['a','b','c'].map{|x| 'X'+x+'Y'}.join(' ')") +;=>"XaY XbY XcY" + +(rb* "[1,2,3].map{|x| 1+x}") +;=>(2 3 4) diff --git a/impls/ruby/types.rb b/impls/ruby/types.rb index 23f7d9b841..1bf70318cb 100644 --- a/impls/ruby/types.rb +++ b/impls/ruby/types.rb @@ -1,75 +1,75 @@ -require_relative "env" - -class MalException < StandardError - attr_reader :data - def initialize(data) - @data = data - end -end - -class String # re-open and add seq - def seq() - return List.new self.split("") - end -end - -class List < Array - attr_accessor :meta - def conj(xs) - xs.each{|x| self.unshift(x)} - return self - end - def seq() - return self - end -end - -class Vector < Array - attr_accessor :meta - def conj(xs) - self.push(*xs) - return self - end - def seq() - return List.new self - end -end - -class Hash # re-open and add meta - attr_accessor :meta -end - -def sequential?(obj) - return obj.is_a?(List) || obj.is_a?(Vector) -end - -class Proc # re-open and add meta - attr_accessor :meta -end - -class Function < Proc - attr_accessor :ast - attr_accessor :env - attr_accessor :params - attr_accessor :is_macro - - def initialize(ast=nil, env=nil, params=nil, &block) - super() - @ast = ast - @env = env - @params = params - @is_macro = false - end - - def gen_env(args) - return Env.new(@env, @params, args) - end -end - -class Atom - attr_accessor :meta - attr_accessor :val - def initialize(val) - @val = val - end -end +require_relative "env" + +class MalException < StandardError + attr_reader :data + def initialize(data) + @data = data + end +end + +class String # re-open and add seq + def seq() + return List.new self.split("") + end +end + +class List < Array + attr_accessor :meta + def conj(xs) + xs.each{|x| self.unshift(x)} + return self + end + def seq() + return self + end +end + +class Vector < Array + attr_accessor :meta + def conj(xs) + self.push(*xs) + return self + end + def seq() + return List.new self + end +end + +class Hash # re-open and add meta + attr_accessor :meta +end + +def sequential?(obj) + return obj.is_a?(List) || obj.is_a?(Vector) +end + +class Proc # re-open and add meta + attr_accessor :meta +end + +class Function < Proc + attr_accessor :ast + attr_accessor :env + attr_accessor :params + attr_accessor :is_macro + + def initialize(ast=nil, env=nil, params=nil, &block) + super() + @ast = ast + @env = env + @params = params + @is_macro = false + end + + def gen_env(args) + return Env.new(@env, @params, args) + end +end + +class Atom + attr_accessor :meta + attr_accessor :val + def initialize(val) + @val = val + end +end diff --git a/impls/rust/.gitignore b/impls/rust/.gitignore index 9fe342cbf4..d9f5fdb54a 100644 --- a/impls/rust/.gitignore +++ b/impls/rust/.gitignore @@ -1 +1 @@ -./target +./target diff --git a/impls/rust/Cargo.lock b/impls/rust/Cargo.lock index a4d1a0602b..45232a938f 100644 --- a/impls/rust/Cargo.lock +++ b/impls/rust/Cargo.lock @@ -1,456 +1,456 @@ -# This file is automatically @generated by Cargo. -# It is not intended for manual editing. -[[package]] -name = "aho-corasick" -version = "0.7.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "memchr 2.2.1 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "arrayref" -version = "0.3.5" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "arrayvec" -version = "0.4.12" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "nodrop 0.1.14 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "backtrace" -version = "0.3.40" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "backtrace-sys 0.1.32 (registry+https://github.com/rust-lang/crates.io-index)", - "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", - "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", - "rustc-demangle 0.1.16 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "backtrace-sys" -version = "0.1.32" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "cc 1.0.46 (registry+https://github.com/rust-lang/crates.io-index)", - "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "base64" -version = "0.10.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "byteorder 1.3.2 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "bitflags" -version = "1.2.1" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "blake2b_simd" -version = "0.5.8" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "arrayref 0.3.5 (registry+https://github.com/rust-lang/crates.io-index)", - "arrayvec 0.4.12 (registry+https://github.com/rust-lang/crates.io-index)", - "constant_time_eq 0.1.4 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "byteorder" -version = "1.3.2" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "cc" -version = "1.0.46" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "cfg-if" -version = "0.1.10" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "cloudabi" -version = "0.0.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "bitflags 1.2.1 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "constant_time_eq" -version = "0.1.4" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "crossbeam-utils" -version = "0.6.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", - "lazy_static 1.4.0 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "dirs" -version = "2.0.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", - "dirs-sys 0.3.4 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "dirs-sys" -version = "0.3.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", - "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", - "redox_users 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)", - "winapi 0.3.8 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "either" -version = "1.5.0" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "failure" -version = "0.1.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "backtrace 0.3.40 (registry+https://github.com/rust-lang/crates.io-index)", - "failure_derive 0.1.6 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "failure_derive" -version = "0.1.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", - "quote 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)", - "syn 1.0.5 (registry+https://github.com/rust-lang/crates.io-index)", - "synstructure 0.12.1 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "fnv" -version = "1.0.6" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "fuchsia-cprng" -version = "0.1.1" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "itertools" -version = "0.8.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "either 1.5.0 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "lazy_static" -version = "1.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "libc" -version = "0.2.65" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "log" -version = "0.4.8" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "memchr" -version = "2.2.1" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "nix" -version = "0.14.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "bitflags 1.2.1 (registry+https://github.com/rust-lang/crates.io-index)", - "cc 1.0.46 (registry+https://github.com/rust-lang/crates.io-index)", - "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", - "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", - "void 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "nodrop" -version = "0.1.14" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "proc-macro2" -version = "1.0.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "unicode-xid 0.2.0 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "quote" -version = "1.0.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "rand_core" -version = "0.3.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "rand_core 0.4.2 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "rand_core" -version = "0.4.2" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "rand_os" -version = "0.1.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "cloudabi 0.0.3 (registry+https://github.com/rust-lang/crates.io-index)", - "fuchsia-cprng 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)", - "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", - "rand_core 0.4.2 (registry+https://github.com/rust-lang/crates.io-index)", - "rdrand 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", - "winapi 0.3.8 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "rdrand" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "rand_core 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "redox_syscall" -version = "0.1.56" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "redox_users" -version = "0.3.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "failure 0.1.6 (registry+https://github.com/rust-lang/crates.io-index)", - "rand_os 0.1.3 (registry+https://github.com/rust-lang/crates.io-index)", - "redox_syscall 0.1.56 (registry+https://github.com/rust-lang/crates.io-index)", - "rust-argon2 0.5.1 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "regex" -version = "1.3.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "aho-corasick 0.7.6 (registry+https://github.com/rust-lang/crates.io-index)", - "memchr 2.2.1 (registry+https://github.com/rust-lang/crates.io-index)", - "regex-syntax 0.6.12 (registry+https://github.com/rust-lang/crates.io-index)", - "thread_local 0.3.6 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "regex-syntax" -version = "0.6.12" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "rust-argon2" -version = "0.5.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "base64 0.10.1 (registry+https://github.com/rust-lang/crates.io-index)", - "blake2b_simd 0.5.8 (registry+https://github.com/rust-lang/crates.io-index)", - "crossbeam-utils 0.6.6 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "rust2" -version = "0.1.0" -dependencies = [ - "fnv 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", - "itertools 0.8.0 (registry+https://github.com/rust-lang/crates.io-index)", - "lazy_static 1.4.0 (registry+https://github.com/rust-lang/crates.io-index)", - "regex 1.3.1 (registry+https://github.com/rust-lang/crates.io-index)", - "rustyline 5.0.3 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "rustc-demangle" -version = "0.1.16" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "rustyline" -version = "5.0.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "dirs 2.0.2 (registry+https://github.com/rust-lang/crates.io-index)", - "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", - "log 0.4.8 (registry+https://github.com/rust-lang/crates.io-index)", - "memchr 2.2.1 (registry+https://github.com/rust-lang/crates.io-index)", - "nix 0.14.1 (registry+https://github.com/rust-lang/crates.io-index)", - "unicode-segmentation 1.3.0 (registry+https://github.com/rust-lang/crates.io-index)", - "unicode-width 0.1.5 (registry+https://github.com/rust-lang/crates.io-index)", - "utf8parse 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)", - "winapi 0.3.8 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "syn" -version = "1.0.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", - "quote 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)", - "unicode-xid 0.2.0 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "synstructure" -version = "0.12.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", - "quote 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)", - "syn 1.0.5 (registry+https://github.com/rust-lang/crates.io-index)", - "unicode-xid 0.2.0 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "thread_local" -version = "0.3.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "lazy_static 1.4.0 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "unicode-segmentation" -version = "1.3.0" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "unicode-width" -version = "0.1.5" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "unicode-xid" -version = "0.2.0" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "utf8parse" -version = "0.1.1" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "void" -version = "1.0.2" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "winapi" -version = "0.3.8" -source = "registry+https://github.com/rust-lang/crates.io-index" -dependencies = [ - "winapi-i686-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", - "winapi-x86_64-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", -] - -[[package]] -name = "winapi-i686-pc-windows-gnu" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[[package]] -name = "winapi-x86_64-pc-windows-gnu" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" - -[metadata] -"checksum aho-corasick 0.7.6 (registry+https://github.com/rust-lang/crates.io-index)" = "58fb5e95d83b38284460a5fda7d6470aa0b8844d283a0b614b8535e880800d2d" -"checksum arrayref 0.3.5 (registry+https://github.com/rust-lang/crates.io-index)" = "0d382e583f07208808f6b1249e60848879ba3543f57c32277bf52d69c2f0f0ee" -"checksum arrayvec 0.4.12 (registry+https://github.com/rust-lang/crates.io-index)" = "cd9fd44efafa8690358b7408d253adf110036b88f55672a933f01d616ad9b1b9" -"checksum backtrace 0.3.40 (registry+https://github.com/rust-lang/crates.io-index)" = "924c76597f0d9ca25d762c25a4d369d51267536465dc5064bdf0eb073ed477ea" -"checksum backtrace-sys 0.1.32 (registry+https://github.com/rust-lang/crates.io-index)" = "5d6575f128516de27e3ce99689419835fce9643a9b215a14d2b5b685be018491" -"checksum base64 0.10.1 (registry+https://github.com/rust-lang/crates.io-index)" = "0b25d992356d2eb0ed82172f5248873db5560c4721f564b13cb5193bda5e668e" -"checksum bitflags 1.2.1 (registry+https://github.com/rust-lang/crates.io-index)" = "cf1de2fe8c75bc145a2f577add951f8134889b4795d47466a54a5c846d691693" -"checksum blake2b_simd 0.5.8 (registry+https://github.com/rust-lang/crates.io-index)" = "5850aeee1552f495dd0250014cf64b82b7c8879a89d83b33bbdace2cc4f63182" -"checksum byteorder 1.3.2 (registry+https://github.com/rust-lang/crates.io-index)" = "a7c3dd8985a7111efc5c80b44e23ecdd8c007de8ade3b96595387e812b957cf5" -"checksum cc 1.0.46 (registry+https://github.com/rust-lang/crates.io-index)" = "0213d356d3c4ea2c18c40b037c3be23cd639825c18f25ee670ac7813beeef99c" -"checksum cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)" = "4785bdd1c96b2a846b2bd7cc02e86b6b3dbf14e7e53446c4f54c92a361040822" -"checksum cloudabi 0.0.3 (registry+https://github.com/rust-lang/crates.io-index)" = "ddfc5b9aa5d4507acaf872de71051dfd0e309860e88966e1051e462a077aac4f" -"checksum constant_time_eq 0.1.4 (registry+https://github.com/rust-lang/crates.io-index)" = "995a44c877f9212528ccc74b21a232f66ad69001e40ede5bcee2ac9ef2657120" -"checksum crossbeam-utils 0.6.6 (registry+https://github.com/rust-lang/crates.io-index)" = "04973fa96e96579258a5091af6003abde64af786b860f18622b82e026cca60e6" -"checksum dirs 2.0.2 (registry+https://github.com/rust-lang/crates.io-index)" = "13aea89a5c93364a98e9b37b2fa237effbb694d5cfe01c5b70941f7eb087d5e3" -"checksum dirs-sys 0.3.4 (registry+https://github.com/rust-lang/crates.io-index)" = "afa0b23de8fd801745c471deffa6e12d248f962c9fd4b4c33787b055599bde7b" -"checksum either 1.5.0 (registry+https://github.com/rust-lang/crates.io-index)" = "3be565ca5c557d7f59e7cfcf1844f9e3033650c929c6566f511e8005f205c1d0" -"checksum failure 0.1.6 (registry+https://github.com/rust-lang/crates.io-index)" = "f8273f13c977665c5db7eb2b99ae520952fe5ac831ae4cd09d80c4c7042b5ed9" -"checksum failure_derive 0.1.6 (registry+https://github.com/rust-lang/crates.io-index)" = "0bc225b78e0391e4b8683440bf2e63c2deeeb2ce5189eab46e2b68c6d3725d08" -"checksum fnv 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)" = "2fad85553e09a6f881f739c29f0b00b0f01357c743266d478b68951ce23285f3" -"checksum fuchsia-cprng 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)" = "a06f77d526c1a601b7c4cdd98f54b5eaabffc14d5f2f0296febdc7f357c6d3ba" -"checksum itertools 0.8.0 (registry+https://github.com/rust-lang/crates.io-index)" = "5b8467d9c1cebe26feb08c640139247fac215782d35371ade9a2136ed6085358" -"checksum lazy_static 1.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "e2abad23fbc42b3700f2f279844dc832adb2b2eb069b2df918f455c4e18cc646" -"checksum libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)" = "1a31a0627fdf1f6a39ec0dd577e101440b7db22672c0901fe00a9a6fbb5c24e8" -"checksum log 0.4.8 (registry+https://github.com/rust-lang/crates.io-index)" = "14b6052be84e6b71ab17edffc2eeabf5c2c3ae1fdb464aae35ac50c67a44e1f7" -"checksum memchr 2.2.1 (registry+https://github.com/rust-lang/crates.io-index)" = "88579771288728879b57485cc7d6b07d648c9f0141eb955f8ab7f9d45394468e" -"checksum nix 0.14.1 (registry+https://github.com/rust-lang/crates.io-index)" = "6c722bee1037d430d0f8e687bbdbf222f27cc6e4e68d5caf630857bb2b6dbdce" -"checksum nodrop 0.1.14 (registry+https://github.com/rust-lang/crates.io-index)" = "72ef4a56884ca558e5ddb05a1d1e7e1bfd9a68d9ed024c21704cc98872dae1bb" -"checksum proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)" = "9c9e470a8dc4aeae2dee2f335e8f533e2d4b347e1434e5671afc49b054592f27" -"checksum quote 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)" = "053a8c8bcc71fcce321828dc897a98ab9760bef03a4fc36693c231e5b3216cfe" -"checksum rand_core 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)" = "7a6fdeb83b075e8266dcc8762c22776f6877a63111121f5f8c7411e5be7eed4b" -"checksum rand_core 0.4.2 (registry+https://github.com/rust-lang/crates.io-index)" = "9c33a3c44ca05fa6f1807d8e6743f3824e8509beca625669633be0acbdf509dc" -"checksum rand_os 0.1.3 (registry+https://github.com/rust-lang/crates.io-index)" = "7b75f676a1e053fc562eafbb47838d67c84801e38fc1ba459e8f180deabd5071" -"checksum rdrand 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "678054eb77286b51581ba43620cc911abf02758c91f93f479767aed0f90458b2" -"checksum redox_syscall 0.1.56 (registry+https://github.com/rust-lang/crates.io-index)" = "2439c63f3f6139d1b57529d16bc3b8bb855230c8efcc5d3a896c8bea7c3b1e84" -"checksum redox_users 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)" = "4ecedbca3bf205f8d8f5c2b44d83cd0690e39ee84b951ed649e9f1841132b66d" -"checksum regex 1.3.1 (registry+https://github.com/rust-lang/crates.io-index)" = "dc220bd33bdce8f093101afe22a037b8eb0e5af33592e6a9caafff0d4cb81cbd" -"checksum regex-syntax 0.6.12 (registry+https://github.com/rust-lang/crates.io-index)" = "11a7e20d1cce64ef2fed88b66d347f88bd9babb82845b2b858f3edbf59a4f716" -"checksum rust-argon2 0.5.1 (registry+https://github.com/rust-lang/crates.io-index)" = "4ca4eaef519b494d1f2848fc602d18816fed808a981aedf4f1f00ceb7c9d32cf" -"checksum rustc-demangle 0.1.16 (registry+https://github.com/rust-lang/crates.io-index)" = "4c691c0e608126e00913e33f0ccf3727d5fc84573623b8d65b2df340b5201783" -"checksum rustyline 5.0.3 (registry+https://github.com/rust-lang/crates.io-index)" = "4795e277e6e57dec9df62b515cd4991371daa80e8dc8d80d596e58722b89c417" -"checksum syn 1.0.5 (registry+https://github.com/rust-lang/crates.io-index)" = "66850e97125af79138385e9b88339cbcd037e3f28ceab8c5ad98e64f0f1f80bf" -"checksum synstructure 0.12.1 (registry+https://github.com/rust-lang/crates.io-index)" = "3f085a5855930c0441ca1288cf044ea4aecf4f43a91668abdb870b4ba546a203" -"checksum thread_local 0.3.6 (registry+https://github.com/rust-lang/crates.io-index)" = "c6b53e329000edc2b34dbe8545fd20e55a333362d0a321909685a19bd28c3f1b" -"checksum unicode-segmentation 1.3.0 (registry+https://github.com/rust-lang/crates.io-index)" = "1967f4cdfc355b37fd76d2a954fb2ed3871034eb4f26d60537d88795cfc332a9" -"checksum unicode-width 0.1.5 (registry+https://github.com/rust-lang/crates.io-index)" = "882386231c45df4700b275c7ff55b6f3698780a650026380e72dabe76fa46526" -"checksum unicode-xid 0.2.0 (registry+https://github.com/rust-lang/crates.io-index)" = "826e7639553986605ec5979c7dd957c7895e93eabed50ab2ffa7f6128a75097c" -"checksum utf8parse 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)" = "8772a4ccbb4e89959023bc5b7cb8623a795caa7092d99f3aa9501b9484d4557d" -"checksum void 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)" = "6a02e4885ed3bc0f2de90ea6dd45ebcbb66dacffe03547fadbb0eeae2770887d" -"checksum winapi 0.3.8 (registry+https://github.com/rust-lang/crates.io-index)" = "8093091eeb260906a183e6ae1abdba2ef5ef2257a21801128899c3fc699229c6" -"checksum winapi-i686-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "ac3b87c63620426dd9b991e5ce0329eff545bccbbb34f3be09ff6fb6ab51b7b6" -"checksum winapi-x86_64-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "712e227841d057c1ee1cd2fb22fa7e5a5461ae8e48fa2ca79ec42cfc1931183f" +# This file is automatically @generated by Cargo. +# It is not intended for manual editing. +[[package]] +name = "aho-corasick" +version = "0.7.6" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "memchr 2.2.1 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "arrayref" +version = "0.3.5" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "arrayvec" +version = "0.4.12" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "nodrop 0.1.14 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "backtrace" +version = "0.3.40" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "backtrace-sys 0.1.32 (registry+https://github.com/rust-lang/crates.io-index)", + "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", + "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", + "rustc-demangle 0.1.16 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "backtrace-sys" +version = "0.1.32" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "cc 1.0.46 (registry+https://github.com/rust-lang/crates.io-index)", + "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "base64" +version = "0.10.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "byteorder 1.3.2 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "bitflags" +version = "1.2.1" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "blake2b_simd" +version = "0.5.8" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "arrayref 0.3.5 (registry+https://github.com/rust-lang/crates.io-index)", + "arrayvec 0.4.12 (registry+https://github.com/rust-lang/crates.io-index)", + "constant_time_eq 0.1.4 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "byteorder" +version = "1.3.2" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "cc" +version = "1.0.46" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "cfg-if" +version = "0.1.10" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "cloudabi" +version = "0.0.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "bitflags 1.2.1 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "constant_time_eq" +version = "0.1.4" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "crossbeam-utils" +version = "0.6.6" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", + "lazy_static 1.4.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "dirs" +version = "2.0.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", + "dirs-sys 0.3.4 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "dirs-sys" +version = "0.3.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", + "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", + "redox_users 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)", + "winapi 0.3.8 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "either" +version = "1.5.0" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "failure" +version = "0.1.6" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "backtrace 0.3.40 (registry+https://github.com/rust-lang/crates.io-index)", + "failure_derive 0.1.6 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "failure_derive" +version = "0.1.6" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", + "quote 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)", + "syn 1.0.5 (registry+https://github.com/rust-lang/crates.io-index)", + "synstructure 0.12.1 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "fnv" +version = "1.0.6" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "fuchsia-cprng" +version = "0.1.1" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "itertools" +version = "0.8.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "either 1.5.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "lazy_static" +version = "1.4.0" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "libc" +version = "0.2.65" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "log" +version = "0.4.8" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "memchr" +version = "2.2.1" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "nix" +version = "0.14.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "bitflags 1.2.1 (registry+https://github.com/rust-lang/crates.io-index)", + "cc 1.0.46 (registry+https://github.com/rust-lang/crates.io-index)", + "cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)", + "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", + "void 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "nodrop" +version = "0.1.14" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "proc-macro2" +version = "1.0.6" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "unicode-xid 0.2.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "quote" +version = "1.0.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "rand_core" +version = "0.3.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "rand_core 0.4.2 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "rand_core" +version = "0.4.2" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "rand_os" +version = "0.1.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "cloudabi 0.0.3 (registry+https://github.com/rust-lang/crates.io-index)", + "fuchsia-cprng 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)", + "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", + "rand_core 0.4.2 (registry+https://github.com/rust-lang/crates.io-index)", + "rdrand 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", + "winapi 0.3.8 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "rdrand" +version = "0.4.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "rand_core 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "redox_syscall" +version = "0.1.56" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "redox_users" +version = "0.3.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "failure 0.1.6 (registry+https://github.com/rust-lang/crates.io-index)", + "rand_os 0.1.3 (registry+https://github.com/rust-lang/crates.io-index)", + "redox_syscall 0.1.56 (registry+https://github.com/rust-lang/crates.io-index)", + "rust-argon2 0.5.1 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "regex" +version = "1.3.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "aho-corasick 0.7.6 (registry+https://github.com/rust-lang/crates.io-index)", + "memchr 2.2.1 (registry+https://github.com/rust-lang/crates.io-index)", + "regex-syntax 0.6.12 (registry+https://github.com/rust-lang/crates.io-index)", + "thread_local 0.3.6 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "regex-syntax" +version = "0.6.12" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "rust-argon2" +version = "0.5.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "base64 0.10.1 (registry+https://github.com/rust-lang/crates.io-index)", + "blake2b_simd 0.5.8 (registry+https://github.com/rust-lang/crates.io-index)", + "crossbeam-utils 0.6.6 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "rust2" +version = "0.1.0" +dependencies = [ + "fnv 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", + "itertools 0.8.0 (registry+https://github.com/rust-lang/crates.io-index)", + "lazy_static 1.4.0 (registry+https://github.com/rust-lang/crates.io-index)", + "regex 1.3.1 (registry+https://github.com/rust-lang/crates.io-index)", + "rustyline 5.0.3 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "rustc-demangle" +version = "0.1.16" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "rustyline" +version = "5.0.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "dirs 2.0.2 (registry+https://github.com/rust-lang/crates.io-index)", + "libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)", + "log 0.4.8 (registry+https://github.com/rust-lang/crates.io-index)", + "memchr 2.2.1 (registry+https://github.com/rust-lang/crates.io-index)", + "nix 0.14.1 (registry+https://github.com/rust-lang/crates.io-index)", + "unicode-segmentation 1.3.0 (registry+https://github.com/rust-lang/crates.io-index)", + "unicode-width 0.1.5 (registry+https://github.com/rust-lang/crates.io-index)", + "utf8parse 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)", + "winapi 0.3.8 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "syn" +version = "1.0.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", + "quote 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)", + "unicode-xid 0.2.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "synstructure" +version = "0.12.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)", + "quote 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)", + "syn 1.0.5 (registry+https://github.com/rust-lang/crates.io-index)", + "unicode-xid 0.2.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "thread_local" +version = "0.3.6" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "lazy_static 1.4.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "unicode-segmentation" +version = "1.3.0" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "unicode-width" +version = "0.1.5" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "unicode-xid" +version = "0.2.0" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "utf8parse" +version = "0.1.1" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "void" +version = "1.0.2" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "winapi" +version = "0.3.8" +source = "registry+https://github.com/rust-lang/crates.io-index" +dependencies = [ + "winapi-i686-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", + "winapi-x86_64-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)", +] + +[[package]] +name = "winapi-i686-pc-windows-gnu" +version = "0.4.0" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[[package]] +name = "winapi-x86_64-pc-windows-gnu" +version = "0.4.0" +source = "registry+https://github.com/rust-lang/crates.io-index" + +[metadata] +"checksum aho-corasick 0.7.6 (registry+https://github.com/rust-lang/crates.io-index)" = "58fb5e95d83b38284460a5fda7d6470aa0b8844d283a0b614b8535e880800d2d" +"checksum arrayref 0.3.5 (registry+https://github.com/rust-lang/crates.io-index)" = "0d382e583f07208808f6b1249e60848879ba3543f57c32277bf52d69c2f0f0ee" +"checksum arrayvec 0.4.12 (registry+https://github.com/rust-lang/crates.io-index)" = "cd9fd44efafa8690358b7408d253adf110036b88f55672a933f01d616ad9b1b9" +"checksum backtrace 0.3.40 (registry+https://github.com/rust-lang/crates.io-index)" = "924c76597f0d9ca25d762c25a4d369d51267536465dc5064bdf0eb073ed477ea" +"checksum backtrace-sys 0.1.32 (registry+https://github.com/rust-lang/crates.io-index)" = "5d6575f128516de27e3ce99689419835fce9643a9b215a14d2b5b685be018491" +"checksum base64 0.10.1 (registry+https://github.com/rust-lang/crates.io-index)" = "0b25d992356d2eb0ed82172f5248873db5560c4721f564b13cb5193bda5e668e" +"checksum bitflags 1.2.1 (registry+https://github.com/rust-lang/crates.io-index)" = "cf1de2fe8c75bc145a2f577add951f8134889b4795d47466a54a5c846d691693" +"checksum blake2b_simd 0.5.8 (registry+https://github.com/rust-lang/crates.io-index)" = "5850aeee1552f495dd0250014cf64b82b7c8879a89d83b33bbdace2cc4f63182" +"checksum byteorder 1.3.2 (registry+https://github.com/rust-lang/crates.io-index)" = "a7c3dd8985a7111efc5c80b44e23ecdd8c007de8ade3b96595387e812b957cf5" +"checksum cc 1.0.46 (registry+https://github.com/rust-lang/crates.io-index)" = "0213d356d3c4ea2c18c40b037c3be23cd639825c18f25ee670ac7813beeef99c" +"checksum cfg-if 0.1.10 (registry+https://github.com/rust-lang/crates.io-index)" = "4785bdd1c96b2a846b2bd7cc02e86b6b3dbf14e7e53446c4f54c92a361040822" +"checksum cloudabi 0.0.3 (registry+https://github.com/rust-lang/crates.io-index)" = "ddfc5b9aa5d4507acaf872de71051dfd0e309860e88966e1051e462a077aac4f" +"checksum constant_time_eq 0.1.4 (registry+https://github.com/rust-lang/crates.io-index)" = "995a44c877f9212528ccc74b21a232f66ad69001e40ede5bcee2ac9ef2657120" +"checksum crossbeam-utils 0.6.6 (registry+https://github.com/rust-lang/crates.io-index)" = "04973fa96e96579258a5091af6003abde64af786b860f18622b82e026cca60e6" +"checksum dirs 2.0.2 (registry+https://github.com/rust-lang/crates.io-index)" = "13aea89a5c93364a98e9b37b2fa237effbb694d5cfe01c5b70941f7eb087d5e3" +"checksum dirs-sys 0.3.4 (registry+https://github.com/rust-lang/crates.io-index)" = "afa0b23de8fd801745c471deffa6e12d248f962c9fd4b4c33787b055599bde7b" +"checksum either 1.5.0 (registry+https://github.com/rust-lang/crates.io-index)" = "3be565ca5c557d7f59e7cfcf1844f9e3033650c929c6566f511e8005f205c1d0" +"checksum failure 0.1.6 (registry+https://github.com/rust-lang/crates.io-index)" = "f8273f13c977665c5db7eb2b99ae520952fe5ac831ae4cd09d80c4c7042b5ed9" +"checksum failure_derive 0.1.6 (registry+https://github.com/rust-lang/crates.io-index)" = "0bc225b78e0391e4b8683440bf2e63c2deeeb2ce5189eab46e2b68c6d3725d08" +"checksum fnv 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)" = "2fad85553e09a6f881f739c29f0b00b0f01357c743266d478b68951ce23285f3" +"checksum fuchsia-cprng 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)" = "a06f77d526c1a601b7c4cdd98f54b5eaabffc14d5f2f0296febdc7f357c6d3ba" +"checksum itertools 0.8.0 (registry+https://github.com/rust-lang/crates.io-index)" = "5b8467d9c1cebe26feb08c640139247fac215782d35371ade9a2136ed6085358" +"checksum lazy_static 1.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "e2abad23fbc42b3700f2f279844dc832adb2b2eb069b2df918f455c4e18cc646" +"checksum libc 0.2.65 (registry+https://github.com/rust-lang/crates.io-index)" = "1a31a0627fdf1f6a39ec0dd577e101440b7db22672c0901fe00a9a6fbb5c24e8" +"checksum log 0.4.8 (registry+https://github.com/rust-lang/crates.io-index)" = "14b6052be84e6b71ab17edffc2eeabf5c2c3ae1fdb464aae35ac50c67a44e1f7" +"checksum memchr 2.2.1 (registry+https://github.com/rust-lang/crates.io-index)" = "88579771288728879b57485cc7d6b07d648c9f0141eb955f8ab7f9d45394468e" +"checksum nix 0.14.1 (registry+https://github.com/rust-lang/crates.io-index)" = "6c722bee1037d430d0f8e687bbdbf222f27cc6e4e68d5caf630857bb2b6dbdce" +"checksum nodrop 0.1.14 (registry+https://github.com/rust-lang/crates.io-index)" = "72ef4a56884ca558e5ddb05a1d1e7e1bfd9a68d9ed024c21704cc98872dae1bb" +"checksum proc-macro2 1.0.6 (registry+https://github.com/rust-lang/crates.io-index)" = "9c9e470a8dc4aeae2dee2f335e8f533e2d4b347e1434e5671afc49b054592f27" +"checksum quote 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)" = "053a8c8bcc71fcce321828dc897a98ab9760bef03a4fc36693c231e5b3216cfe" +"checksum rand_core 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)" = "7a6fdeb83b075e8266dcc8762c22776f6877a63111121f5f8c7411e5be7eed4b" +"checksum rand_core 0.4.2 (registry+https://github.com/rust-lang/crates.io-index)" = "9c33a3c44ca05fa6f1807d8e6743f3824e8509beca625669633be0acbdf509dc" +"checksum rand_os 0.1.3 (registry+https://github.com/rust-lang/crates.io-index)" = "7b75f676a1e053fc562eafbb47838d67c84801e38fc1ba459e8f180deabd5071" +"checksum rdrand 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "678054eb77286b51581ba43620cc911abf02758c91f93f479767aed0f90458b2" +"checksum redox_syscall 0.1.56 (registry+https://github.com/rust-lang/crates.io-index)" = "2439c63f3f6139d1b57529d16bc3b8bb855230c8efcc5d3a896c8bea7c3b1e84" +"checksum redox_users 0.3.1 (registry+https://github.com/rust-lang/crates.io-index)" = "4ecedbca3bf205f8d8f5c2b44d83cd0690e39ee84b951ed649e9f1841132b66d" +"checksum regex 1.3.1 (registry+https://github.com/rust-lang/crates.io-index)" = "dc220bd33bdce8f093101afe22a037b8eb0e5af33592e6a9caafff0d4cb81cbd" +"checksum regex-syntax 0.6.12 (registry+https://github.com/rust-lang/crates.io-index)" = "11a7e20d1cce64ef2fed88b66d347f88bd9babb82845b2b858f3edbf59a4f716" +"checksum rust-argon2 0.5.1 (registry+https://github.com/rust-lang/crates.io-index)" = "4ca4eaef519b494d1f2848fc602d18816fed808a981aedf4f1f00ceb7c9d32cf" +"checksum rustc-demangle 0.1.16 (registry+https://github.com/rust-lang/crates.io-index)" = "4c691c0e608126e00913e33f0ccf3727d5fc84573623b8d65b2df340b5201783" +"checksum rustyline 5.0.3 (registry+https://github.com/rust-lang/crates.io-index)" = "4795e277e6e57dec9df62b515cd4991371daa80e8dc8d80d596e58722b89c417" +"checksum syn 1.0.5 (registry+https://github.com/rust-lang/crates.io-index)" = "66850e97125af79138385e9b88339cbcd037e3f28ceab8c5ad98e64f0f1f80bf" +"checksum synstructure 0.12.1 (registry+https://github.com/rust-lang/crates.io-index)" = "3f085a5855930c0441ca1288cf044ea4aecf4f43a91668abdb870b4ba546a203" +"checksum thread_local 0.3.6 (registry+https://github.com/rust-lang/crates.io-index)" = "c6b53e329000edc2b34dbe8545fd20e55a333362d0a321909685a19bd28c3f1b" +"checksum unicode-segmentation 1.3.0 (registry+https://github.com/rust-lang/crates.io-index)" = "1967f4cdfc355b37fd76d2a954fb2ed3871034eb4f26d60537d88795cfc332a9" +"checksum unicode-width 0.1.5 (registry+https://github.com/rust-lang/crates.io-index)" = "882386231c45df4700b275c7ff55b6f3698780a650026380e72dabe76fa46526" +"checksum unicode-xid 0.2.0 (registry+https://github.com/rust-lang/crates.io-index)" = "826e7639553986605ec5979c7dd957c7895e93eabed50ab2ffa7f6128a75097c" +"checksum utf8parse 0.1.1 (registry+https://github.com/rust-lang/crates.io-index)" = "8772a4ccbb4e89959023bc5b7cb8623a795caa7092d99f3aa9501b9484d4557d" +"checksum void 1.0.2 (registry+https://github.com/rust-lang/crates.io-index)" = "6a02e4885ed3bc0f2de90ea6dd45ebcbb66dacffe03547fadbb0eeae2770887d" +"checksum winapi 0.3.8 (registry+https://github.com/rust-lang/crates.io-index)" = "8093091eeb260906a183e6ae1abdba2ef5ef2257a21801128899c3fc699229c6" +"checksum winapi-i686-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "ac3b87c63620426dd9b991e5ce0329eff545bccbbb34f3be09ff6fb6ab51b7b6" +"checksum winapi-x86_64-pc-windows-gnu 0.4.0 (registry+https://github.com/rust-lang/crates.io-index)" = "712e227841d057c1ee1cd2fb22fa7e5a5461ae8e48fa2ca79ec42cfc1931183f" diff --git a/impls/rust/Cargo.toml b/impls/rust/Cargo.toml index de50a703b8..b394c03e5e 100644 --- a/impls/rust/Cargo.toml +++ b/impls/rust/Cargo.toml @@ -1,57 +1,57 @@ -[package] -name = "rust2" -version = "0.1.0" -authors = ["root"] - -[dependencies] -rustyline = "5.0.3" -lazy_static = "1.4.0" - -regex = "1.3.1" -itertools = "0.8.0" -fnv = "1.0.6" - - -[[bin]] -name = "step0_repl" -path = "step0_repl.rs" - -[[bin]] -name = "step1_read_print" -path = "step1_read_print.rs" - -[[bin]] -name = "step2_eval" -path = "step2_eval.rs" - -[[bin]] -name = "step3_env" -path = "step3_env.rs" - -[[bin]] -name = "step4_if_fn_do" -path = "step4_if_fn_do.rs" - -[[bin]] -name = "step5_tco" -path = "step5_tco.rs" - -[[bin]] -name = "step6_file" -path = "step6_file.rs" - -[[bin]] -name = "step7_quote" -path = "step7_quote.rs" - -[[bin]] -name = "step8_macros" -path = "step8_macros.rs" - -[[bin]] -name = "step9_try" -path = "step9_try.rs" - -[[bin]] -name = "stepA_mal" -path = "stepA_mal.rs" +[package] +name = "rust2" +version = "0.1.0" +authors = ["root"] + +[dependencies] +rustyline = "5.0.3" +lazy_static = "1.4.0" + +regex = "1.3.1" +itertools = "0.8.0" +fnv = "1.0.6" + + +[[bin]] +name = "step0_repl" +path = "step0_repl.rs" + +[[bin]] +name = "step1_read_print" +path = "step1_read_print.rs" + +[[bin]] +name = "step2_eval" +path = "step2_eval.rs" + +[[bin]] +name = "step3_env" +path = "step3_env.rs" + +[[bin]] +name = "step4_if_fn_do" +path = "step4_if_fn_do.rs" + +[[bin]] +name = "step5_tco" +path = "step5_tco.rs" + +[[bin]] +name = "step6_file" +path = "step6_file.rs" + +[[bin]] +name = "step7_quote" +path = "step7_quote.rs" + +[[bin]] +name = "step8_macros" +path = "step8_macros.rs" + +[[bin]] +name = "step9_try" +path = "step9_try.rs" + +[[bin]] +name = "stepA_mal" +path = "stepA_mal.rs" diff --git a/impls/rust/Dockerfile b/impls/rust/Dockerfile index 661df9e6ce..06b7376c53 100644 --- a/impls/rust/Dockerfile +++ b/impls/rust/Dockerfile @@ -1,5 +1,5 @@ -FROM rust:1.38.0 - -ENV CARGO_HOME /mal - -WORKDIR /mal +FROM rust:1.38.0 + +ENV CARGO_HOME /mal + +WORKDIR /mal diff --git a/impls/rust/Makefile b/impls/rust/Makefile index 6cceaafa9b..506b436599 100644 --- a/impls/rust/Makefile +++ b/impls/rust/Makefile @@ -1,31 +1,31 @@ - -UPPER_STEPS = step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal -STEPS = step0_repl step1_read_print step2_eval step3_env $(UPPER_STEPS) - -all: $(STEPS) - -dist: mal - -mal: stepA_mal - cp $< $@ - -%: %.rs - cargo build --release --bin $* - cp target/release/$* $@ - -STEP0_DEPS = Cargo.toml -STEP1_DEPS = $(STEP0_DEPS) types.rs reader.rs printer.rs -STEP3_DEPS = $(STEP1_DEPS) env.rs -STEP4_DEPS = $(STEP3_DEPS) core.rs - -step0_repl: $(STEP0_DEPS) -step1_read_print step2_eval: $(STEP1_DEPS) -step3_env: $(STEP3_DEPS) -$(UPPER_STEPS): $(STEP4_DEPS) - -.PHONY: clean - -clean: - cargo clean - rm -f $(STEPS) - rm -f mal + +UPPER_STEPS = step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal +STEPS = step0_repl step1_read_print step2_eval step3_env $(UPPER_STEPS) + +all: $(STEPS) + +dist: mal + +mal: stepA_mal + cp $< $@ + +%: %.rs + cargo build --release --bin $* + cp target/release/$* $@ + +STEP0_DEPS = Cargo.toml +STEP1_DEPS = $(STEP0_DEPS) types.rs reader.rs printer.rs +STEP3_DEPS = $(STEP1_DEPS) env.rs +STEP4_DEPS = $(STEP3_DEPS) core.rs + +step0_repl: $(STEP0_DEPS) +step1_read_print step2_eval: $(STEP1_DEPS) +step3_env: $(STEP3_DEPS) +$(UPPER_STEPS): $(STEP4_DEPS) + +.PHONY: clean + +clean: + cargo clean + rm -f $(STEPS) + rm -f mal diff --git a/impls/rust/core.rs b/impls/rust/core.rs index 58400f7c4e..5004f4533d 100644 --- a/impls/rust/core.rs +++ b/impls/rust/core.rs @@ -1,351 +1,351 @@ -use std::fs::File; -use std::io::Read; -use std::rc::Rc; -use std::sync::Mutex; -use std::time::{SystemTime, UNIX_EPOCH}; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -use crate::printer::pr_seq; -use crate::reader::read_str; -use crate::types::MalErr::ErrMalVal; -use crate::types::MalVal::{Atom, Bool, Func, Hash, Int, List, MalFunc, Nil, Str, Sym, Vector}; -use crate::types::{MalArgs, MalRet, MalVal, _assoc, _dissoc, atom, error, func, hash_map}; - -macro_rules! fn_t_int_int { - ($ret:ident, $fn:expr) => {{ - |a: MalArgs| match (a[0].clone(), a[1].clone()) { - (Int(a0), Int(a1)) => Ok($ret($fn(a0, a1))), - _ => error("expecting (int,int) args"), - } - }}; -} - -macro_rules! fn_is_type { - ($($ps:pat),*) => {{ - |a:MalArgs| { Ok(Bool(match a[0] { $($ps => true,)* _ => false})) } - }}; - ($p:pat if $e:expr) => {{ - |a:MalArgs| { Ok(Bool(match a[0] { $p if $e => true, _ => false})) } - }}; - ($p:pat if $e:expr,$($ps:pat),*) => {{ - |a:MalArgs| { Ok(Bool(match a[0] { $p if $e => true, $($ps => true,)* _ => false})) } - }}; -} - -macro_rules! fn_str { - ($fn:expr) => {{ - |a: MalArgs| match a[0].clone() { - Str(a0) => $fn(a0), - _ => error("expecting (str) arg"), - } - }}; -} - -fn symbol(a: MalArgs) -> MalRet { - match a[0] { - Str(ref s) => Ok(Sym(s.to_string())), - _ => error("illegal symbol call"), - } -} - -fn readline(a: MalArgs) -> MalRet { - lazy_static! { - static ref RL: Mutex> = Mutex::new(Editor::<()>::new()); - } - //let mut rl = Editor::<()>::new(); - - match a[0] { - Str(ref p) => { - //match rl.readline(p) { - match RL.lock().unwrap().readline(p) { - Ok(mut line) => { - // Remove any trailing \n or \r\n - if line.ends_with('\n') { - line.pop(); - if line.ends_with('\r') { - line.pop(); - } - } - Ok(Str(line)) - } - Err(ReadlineError::Eof) => Ok(Nil), - Err(e) => error(&format!("{:?}", e)), - } - } - _ => error("readline: prompt is not Str"), - } -} - -fn slurp(f: String) -> MalRet { - let mut s = String::new(); - match File::open(f).and_then(|mut f| f.read_to_string(&mut s)) { - Ok(_) => Ok(Str(s)), - Err(e) => error(&e.to_string()), - } -} - -fn time_ms(_a: MalArgs) -> MalRet { - let ms_e = match SystemTime::now().duration_since(UNIX_EPOCH) { - Ok(d) => d, - Err(e) => return error(&format!("{:?}", e)), - }; - Ok(Int( - ms_e.as_secs() as i64 * 1000 + ms_e.subsec_nanos() as i64 / 1_000_000 - )) -} - -fn get(a: MalArgs) -> MalRet { - match (a[0].clone(), a[1].clone()) { - (Nil, _) => Ok(Nil), - (Hash(ref hm, _), Str(ref s)) => match hm.get(s) { - Some(mv) => Ok(mv.clone()), - None => Ok(Nil), - }, - _ => error("illegal get args"), - } -} - -fn assoc(a: MalArgs) -> MalRet { - match a[0] { - Hash(ref hm, _) => _assoc((**hm).clone(), a[1..].to_vec()), - _ => error("assoc on non-Hash Map"), - } -} - -fn dissoc(a: MalArgs) -> MalRet { - match a[0] { - Hash(ref hm, _) => _dissoc((**hm).clone(), a[1..].to_vec()), - _ => error("dissoc on non-Hash Map"), - } -} - -fn contains_q(a: MalArgs) -> MalRet { - match (a[0].clone(), a[1].clone()) { - (Hash(ref hm, _), Str(ref s)) => Ok(Bool(hm.contains_key(s))), - _ => error("illegal get args"), - } -} - -fn keys(a: MalArgs) -> MalRet { - match a[0] { - Hash(ref hm, _) => Ok(list!(hm.keys().map(|k| { Str(k.to_string()) }).collect())), - _ => error("keys requires Hash Map"), - } -} - -fn vals(a: MalArgs) -> MalRet { - match a[0] { - Hash(ref hm, _) => Ok(list!(hm.values().map(|v| { v.clone() }).collect())), - _ => error("keys requires Hash Map"), - } -} - -fn vec(a: MalArgs) -> MalRet { - match a[0] { - List(ref v, _) | Vector(ref v, _) => Ok(vector!(v.to_vec())), - _ => error("non-seq passed to vec"), - } -} - -fn cons(a: MalArgs) -> MalRet { - match a[1].clone() { - List(v, _) | Vector(v, _) => { - let mut new_v = vec![a[0].clone()]; - new_v.extend_from_slice(&v); - Ok(list!(new_v.to_vec())) - } - _ => error("cons expects seq as second arg"), - } -} - -fn concat(a: MalArgs) -> MalRet { - let mut new_v = vec![]; - for seq in a.iter() { - match seq { - List(v, _) | Vector(v, _) => new_v.extend_from_slice(v), - _ => return error("non-seq passed to concat"), - } - } - Ok(list!(new_v.to_vec())) -} - -fn nth(a: MalArgs) -> MalRet { - match (a[0].clone(), a[1].clone()) { - (List(seq, _), Int(idx)) | (Vector(seq, _), Int(idx)) => { - if seq.len() <= idx as usize { - return error("nth: index out of range"); - } - Ok(seq[idx as usize].clone()) - } - _ => error("invalid args to nth"), - } -} - -fn first(a: MalArgs) -> MalRet { - match a[0].clone() { - List(ref seq, _) | Vector(ref seq, _) if seq.len() == 0 => Ok(Nil), - List(ref seq, _) | Vector(ref seq, _) => Ok(seq[0].clone()), - Nil => Ok(Nil), - _ => error("invalid args to first"), - } -} - -fn rest(a: MalArgs) -> MalRet { - match a[0].clone() { - List(ref seq, _) | Vector(ref seq, _) => { - if seq.len() > 1 { - Ok(list!(seq[1..].to_vec())) - } else { - Ok(list![]) - } - } - Nil => Ok(list![]), - _ => error("invalid args to first"), - } -} - -fn apply(a: MalArgs) -> MalRet { - match a[a.len() - 1] { - List(ref v, _) | Vector(ref v, _) => { - let f = &a[0]; - let mut fargs = a[1..a.len() - 1].to_vec(); - fargs.extend_from_slice(&v); - f.apply(fargs) - } - _ => error("apply called with non-seq"), - } -} - -fn map(a: MalArgs) -> MalRet { - match a[1] { - List(ref v, _) | Vector(ref v, _) => { - let mut res = vec![]; - for mv in v.iter() { - res.push(a[0].apply(vec![mv.clone()])?) - } - Ok(list!(res)) - } - _ => error("map called with non-seq"), - } -} - -fn conj(a: MalArgs) -> MalRet { - match a[0] { - List(ref v, _) => { - let sl = a[1..] - .iter() - .rev() - .map(|a| a.clone()) - .collect::>(); - Ok(list!([&sl[..], v].concat())) - } - Vector(ref v, _) => Ok(vector!([v, &a[1..]].concat())), - _ => error("conj: called with non-seq"), - } -} - -fn seq(a: MalArgs) -> MalRet { - match a[0] { - List(ref v, _) | Vector(ref v, _) if v.len() == 0 => Ok(Nil), - List(ref v, _) | Vector(ref v, _) => Ok(list!(v.to_vec())), - Str(ref s) if s.len() == 0 => Ok(Nil), - Str(ref s) if !a[0].keyword_q() => { - Ok(list!(s.chars().map(|c| { Str(c.to_string()) }).collect())) - } - Nil => Ok(Nil), - _ => error("seq: called with non-seq"), - } -} - -pub fn ns() -> Vec<(&'static str, MalVal)> { - vec![ - ("=", func(|a| Ok(Bool(a[0] == a[1])))), - ("throw", func(|a| Err(ErrMalVal(a[0].clone())))), - ("nil?", func(fn_is_type!(Nil))), - ("true?", func(fn_is_type!(Bool(true)))), - ("false?", func(fn_is_type!(Bool(false)))), - ("symbol", func(symbol)), - ("symbol?", func(fn_is_type!(Sym(_)))), - ( - "string?", - func(fn_is_type!(Str(ref s) if !s.starts_with("\u{29e}"))), - ), - ("keyword", func(|a| a[0].keyword())), - ( - "keyword?", - func(fn_is_type!(Str(ref s) if s.starts_with("\u{29e}"))), - ), - ("number?", func(fn_is_type!(Int(_)))), - ( - "fn?", - func(fn_is_type!(MalFunc{is_macro,..} if !is_macro,Func(_,_))), - ), - ( - "macro?", - func(fn_is_type!(MalFunc{is_macro,..} if is_macro)), - ), - ("pr-str", func(|a| Ok(Str(pr_seq(&a, true, "", "", " "))))), - ("str", func(|a| Ok(Str(pr_seq(&a, false, "", "", ""))))), - ( - "prn", - func(|a| { - println!("{}", pr_seq(&a, true, "", "", " ")); - Ok(Nil) - }), - ), - ( - "println", - func(|a| { - println!("{}", pr_seq(&a, false, "", "", " ")); - Ok(Nil) - }), - ), - ("read-string", func(fn_str!(|s| { read_str(s) }))), - ("readline", func(readline)), - ("slurp", func(fn_str!(|f| { slurp(f) }))), - ("<", func(fn_t_int_int!(Bool, |i, j| { i < j }))), - ("<=", func(fn_t_int_int!(Bool, |i, j| { i <= j }))), - (">", func(fn_t_int_int!(Bool, |i, j| { i > j }))), - (">=", func(fn_t_int_int!(Bool, |i, j| { i >= j }))), - ("+", func(fn_t_int_int!(Int, |i, j| { i + j }))), - ("-", func(fn_t_int_int!(Int, |i, j| { i - j }))), - ("*", func(fn_t_int_int!(Int, |i, j| { i * j }))), - ("/", func(fn_t_int_int!(Int, |i, j| { i / j }))), - ("time-ms", func(time_ms)), - ("sequential?", func(fn_is_type!(List(_, _), Vector(_, _)))), - ("list", func(|a| Ok(list!(a)))), - ("list?", func(fn_is_type!(List(_, _)))), - ("vector", func(|a| Ok(vector!(a)))), - ("vector?", func(fn_is_type!(Vector(_, _)))), - ("hash-map", func(|a| hash_map(a))), - ("map?", func(fn_is_type!(Hash(_, _)))), - ("assoc", func(assoc)), - ("dissoc", func(dissoc)), - ("get", func(get)), - ("contains?", func(contains_q)), - ("keys", func(keys)), - ("vals", func(vals)), - ("vec", func(vec)), - ("cons", func(cons)), - ("concat", func(concat)), - ("empty?", func(|a| a[0].empty_q())), - ("nth", func(nth)), - ("first", func(first)), - ("rest", func(rest)), - ("count", func(|a| a[0].count())), - ("apply", func(apply)), - ("map", func(map)), - ("conj", func(conj)), - ("seq", func(seq)), - ("meta", func(|a| a[0].get_meta())), - ("with-meta", func(|a| a[0].clone().with_meta(&a[1]))), - ("atom", func(|a| Ok(atom(&a[0])))), - ("atom?", func(fn_is_type!(Atom(_)))), - ("deref", func(|a| a[0].deref())), - ("reset!", func(|a| a[0].reset_bang(&a[1]))), - ("swap!", func(|a| a[0].swap_bang(&a[1..].to_vec()))), - ] -} +use std::fs::File; +use std::io::Read; +use std::rc::Rc; +use std::sync::Mutex; +use std::time::{SystemTime, UNIX_EPOCH}; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +use crate::printer::pr_seq; +use crate::reader::read_str; +use crate::types::MalErr::ErrMalVal; +use crate::types::MalVal::{Atom, Bool, Func, Hash, Int, List, MalFunc, Nil, Str, Sym, Vector}; +use crate::types::{MalArgs, MalRet, MalVal, _assoc, _dissoc, atom, error, func, hash_map}; + +macro_rules! fn_t_int_int { + ($ret:ident, $fn:expr) => {{ + |a: MalArgs| match (a[0].clone(), a[1].clone()) { + (Int(a0), Int(a1)) => Ok($ret($fn(a0, a1))), + _ => error("expecting (int,int) args"), + } + }}; +} + +macro_rules! fn_is_type { + ($($ps:pat),*) => {{ + |a:MalArgs| { Ok(Bool(match a[0] { $($ps => true,)* _ => false})) } + }}; + ($p:pat if $e:expr) => {{ + |a:MalArgs| { Ok(Bool(match a[0] { $p if $e => true, _ => false})) } + }}; + ($p:pat if $e:expr,$($ps:pat),*) => {{ + |a:MalArgs| { Ok(Bool(match a[0] { $p if $e => true, $($ps => true,)* _ => false})) } + }}; +} + +macro_rules! fn_str { + ($fn:expr) => {{ + |a: MalArgs| match a[0].clone() { + Str(a0) => $fn(a0), + _ => error("expecting (str) arg"), + } + }}; +} + +fn symbol(a: MalArgs) -> MalRet { + match a[0] { + Str(ref s) => Ok(Sym(s.to_string())), + _ => error("illegal symbol call"), + } +} + +fn readline(a: MalArgs) -> MalRet { + lazy_static! { + static ref RL: Mutex> = Mutex::new(Editor::<()>::new()); + } + //let mut rl = Editor::<()>::new(); + + match a[0] { + Str(ref p) => { + //match rl.readline(p) { + match RL.lock().unwrap().readline(p) { + Ok(mut line) => { + // Remove any trailing \n or \r\n + if line.ends_with('\n') { + line.pop(); + if line.ends_with('\r') { + line.pop(); + } + } + Ok(Str(line)) + } + Err(ReadlineError::Eof) => Ok(Nil), + Err(e) => error(&format!("{:?}", e)), + } + } + _ => error("readline: prompt is not Str"), + } +} + +fn slurp(f: String) -> MalRet { + let mut s = String::new(); + match File::open(f).and_then(|mut f| f.read_to_string(&mut s)) { + Ok(_) => Ok(Str(s)), + Err(e) => error(&e.to_string()), + } +} + +fn time_ms(_a: MalArgs) -> MalRet { + let ms_e = match SystemTime::now().duration_since(UNIX_EPOCH) { + Ok(d) => d, + Err(e) => return error(&format!("{:?}", e)), + }; + Ok(Int( + ms_e.as_secs() as i64 * 1000 + ms_e.subsec_nanos() as i64 / 1_000_000 + )) +} + +fn get(a: MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (Nil, _) => Ok(Nil), + (Hash(ref hm, _), Str(ref s)) => match hm.get(s) { + Some(mv) => Ok(mv.clone()), + None => Ok(Nil), + }, + _ => error("illegal get args"), + } +} + +fn assoc(a: MalArgs) -> MalRet { + match a[0] { + Hash(ref hm, _) => _assoc((**hm).clone(), a[1..].to_vec()), + _ => error("assoc on non-Hash Map"), + } +} + +fn dissoc(a: MalArgs) -> MalRet { + match a[0] { + Hash(ref hm, _) => _dissoc((**hm).clone(), a[1..].to_vec()), + _ => error("dissoc on non-Hash Map"), + } +} + +fn contains_q(a: MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (Hash(ref hm, _), Str(ref s)) => Ok(Bool(hm.contains_key(s))), + _ => error("illegal get args"), + } +} + +fn keys(a: MalArgs) -> MalRet { + match a[0] { + Hash(ref hm, _) => Ok(list!(hm.keys().map(|k| { Str(k.to_string()) }).collect())), + _ => error("keys requires Hash Map"), + } +} + +fn vals(a: MalArgs) -> MalRet { + match a[0] { + Hash(ref hm, _) => Ok(list!(hm.values().map(|v| { v.clone() }).collect())), + _ => error("keys requires Hash Map"), + } +} + +fn vec(a: MalArgs) -> MalRet { + match a[0] { + List(ref v, _) | Vector(ref v, _) => Ok(vector!(v.to_vec())), + _ => error("non-seq passed to vec"), + } +} + +fn cons(a: MalArgs) -> MalRet { + match a[1].clone() { + List(v, _) | Vector(v, _) => { + let mut new_v = vec![a[0].clone()]; + new_v.extend_from_slice(&v); + Ok(list!(new_v.to_vec())) + } + _ => error("cons expects seq as second arg"), + } +} + +fn concat(a: MalArgs) -> MalRet { + let mut new_v = vec![]; + for seq in a.iter() { + match seq { + List(v, _) | Vector(v, _) => new_v.extend_from_slice(v), + _ => return error("non-seq passed to concat"), + } + } + Ok(list!(new_v.to_vec())) +} + +fn nth(a: MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (List(seq, _), Int(idx)) | (Vector(seq, _), Int(idx)) => { + if seq.len() <= idx as usize { + return error("nth: index out of range"); + } + Ok(seq[idx as usize].clone()) + } + _ => error("invalid args to nth"), + } +} + +fn first(a: MalArgs) -> MalRet { + match a[0].clone() { + List(ref seq, _) | Vector(ref seq, _) if seq.len() == 0 => Ok(Nil), + List(ref seq, _) | Vector(ref seq, _) => Ok(seq[0].clone()), + Nil => Ok(Nil), + _ => error("invalid args to first"), + } +} + +fn rest(a: MalArgs) -> MalRet { + match a[0].clone() { + List(ref seq, _) | Vector(ref seq, _) => { + if seq.len() > 1 { + Ok(list!(seq[1..].to_vec())) + } else { + Ok(list![]) + } + } + Nil => Ok(list![]), + _ => error("invalid args to first"), + } +} + +fn apply(a: MalArgs) -> MalRet { + match a[a.len() - 1] { + List(ref v, _) | Vector(ref v, _) => { + let f = &a[0]; + let mut fargs = a[1..a.len() - 1].to_vec(); + fargs.extend_from_slice(&v); + f.apply(fargs) + } + _ => error("apply called with non-seq"), + } +} + +fn map(a: MalArgs) -> MalRet { + match a[1] { + List(ref v, _) | Vector(ref v, _) => { + let mut res = vec![]; + for mv in v.iter() { + res.push(a[0].apply(vec![mv.clone()])?) + } + Ok(list!(res)) + } + _ => error("map called with non-seq"), + } +} + +fn conj(a: MalArgs) -> MalRet { + match a[0] { + List(ref v, _) => { + let sl = a[1..] + .iter() + .rev() + .map(|a| a.clone()) + .collect::>(); + Ok(list!([&sl[..], v].concat())) + } + Vector(ref v, _) => Ok(vector!([v, &a[1..]].concat())), + _ => error("conj: called with non-seq"), + } +} + +fn seq(a: MalArgs) -> MalRet { + match a[0] { + List(ref v, _) | Vector(ref v, _) if v.len() == 0 => Ok(Nil), + List(ref v, _) | Vector(ref v, _) => Ok(list!(v.to_vec())), + Str(ref s) if s.len() == 0 => Ok(Nil), + Str(ref s) if !a[0].keyword_q() => { + Ok(list!(s.chars().map(|c| { Str(c.to_string()) }).collect())) + } + Nil => Ok(Nil), + _ => error("seq: called with non-seq"), + } +} + +pub fn ns() -> Vec<(&'static str, MalVal)> { + vec![ + ("=", func(|a| Ok(Bool(a[0] == a[1])))), + ("throw", func(|a| Err(ErrMalVal(a[0].clone())))), + ("nil?", func(fn_is_type!(Nil))), + ("true?", func(fn_is_type!(Bool(true)))), + ("false?", func(fn_is_type!(Bool(false)))), + ("symbol", func(symbol)), + ("symbol?", func(fn_is_type!(Sym(_)))), + ( + "string?", + func(fn_is_type!(Str(ref s) if !s.starts_with("\u{29e}"))), + ), + ("keyword", func(|a| a[0].keyword())), + ( + "keyword?", + func(fn_is_type!(Str(ref s) if s.starts_with("\u{29e}"))), + ), + ("number?", func(fn_is_type!(Int(_)))), + ( + "fn?", + func(fn_is_type!(MalFunc{is_macro,..} if !is_macro,Func(_,_))), + ), + ( + "macro?", + func(fn_is_type!(MalFunc{is_macro,..} if is_macro)), + ), + ("pr-str", func(|a| Ok(Str(pr_seq(&a, true, "", "", " "))))), + ("str", func(|a| Ok(Str(pr_seq(&a, false, "", "", ""))))), + ( + "prn", + func(|a| { + println!("{}", pr_seq(&a, true, "", "", " ")); + Ok(Nil) + }), + ), + ( + "println", + func(|a| { + println!("{}", pr_seq(&a, false, "", "", " ")); + Ok(Nil) + }), + ), + ("read-string", func(fn_str!(|s| { read_str(s) }))), + ("readline", func(readline)), + ("slurp", func(fn_str!(|f| { slurp(f) }))), + ("<", func(fn_t_int_int!(Bool, |i, j| { i < j }))), + ("<=", func(fn_t_int_int!(Bool, |i, j| { i <= j }))), + (">", func(fn_t_int_int!(Bool, |i, j| { i > j }))), + (">=", func(fn_t_int_int!(Bool, |i, j| { i >= j }))), + ("+", func(fn_t_int_int!(Int, |i, j| { i + j }))), + ("-", func(fn_t_int_int!(Int, |i, j| { i - j }))), + ("*", func(fn_t_int_int!(Int, |i, j| { i * j }))), + ("/", func(fn_t_int_int!(Int, |i, j| { i / j }))), + ("time-ms", func(time_ms)), + ("sequential?", func(fn_is_type!(List(_, _), Vector(_, _)))), + ("list", func(|a| Ok(list!(a)))), + ("list?", func(fn_is_type!(List(_, _)))), + ("vector", func(|a| Ok(vector!(a)))), + ("vector?", func(fn_is_type!(Vector(_, _)))), + ("hash-map", func(|a| hash_map(a))), + ("map?", func(fn_is_type!(Hash(_, _)))), + ("assoc", func(assoc)), + ("dissoc", func(dissoc)), + ("get", func(get)), + ("contains?", func(contains_q)), + ("keys", func(keys)), + ("vals", func(vals)), + ("vec", func(vec)), + ("cons", func(cons)), + ("concat", func(concat)), + ("empty?", func(|a| a[0].empty_q())), + ("nth", func(nth)), + ("first", func(first)), + ("rest", func(rest)), + ("count", func(|a| a[0].count())), + ("apply", func(apply)), + ("map", func(map)), + ("conj", func(conj)), + ("seq", func(seq)), + ("meta", func(|a| a[0].get_meta())), + ("with-meta", func(|a| a[0].clone().with_meta(&a[1]))), + ("atom", func(|a| Ok(atom(&a[0])))), + ("atom?", func(fn_is_type!(Atom(_)))), + ("deref", func(|a| a[0].deref())), + ("reset!", func(|a| a[0].reset_bang(&a[1]))), + ("swap!", func(|a| a[0].swap_bang(&a[1..].to_vec()))), + ] +} diff --git a/impls/rust/env.rs b/impls/rust/env.rs index 27e77b4249..72ebabb7f8 100644 --- a/impls/rust/env.rs +++ b/impls/rust/env.rs @@ -1,85 +1,85 @@ -use std::cell::RefCell; -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; - -use crate::types::MalErr::ErrString; -use crate::types::MalVal::{List, Nil, Sym, Vector}; -use crate::types::{error, MalErr, MalRet, MalVal}; - -#[derive(Debug)] -pub struct EnvStruct { - data: RefCell>, - pub outer: Option, -} - -pub type Env = Rc; - -// TODO: it would be nice to use impl here but it doesn't work on -// a deftype (i.e. Env) - -pub fn env_new(outer: Option) -> Env { - Rc::new(EnvStruct { - data: RefCell::new(FnvHashMap::default()), - outer: outer, - }) -} - -// TODO: mbinds and exprs as & types -pub fn env_bind(outer: Option, mbinds: MalVal, exprs: Vec) -> Result { - let env = env_new(outer); - match mbinds { - List(binds, _) | Vector(binds, _) => { - for (i, b) in binds.iter().enumerate() { - match b { - Sym(s) if s == "&" => { - env_set(&env, binds[i + 1].clone(), list!(exprs[i..].to_vec()))?; - break; - } - _ => { - env_set(&env, b.clone(), exprs[i].clone())?; - } - } - } - Ok(env) - } - _ => Err(ErrString("env_bind binds not List/Vector".to_string())), - } -} - -pub fn env_find(env: &Env, key: &str) -> Option { - match (env.data.borrow().contains_key(key), env.outer.clone()) { - (true, _) => Some(env.clone()), - (false, Some(o)) => env_find(&o, key), - _ => None, - } -} - -pub fn env_get(env: &Env, key: &MalVal) -> MalRet { - match key { - Sym(ref s) => match env_find(env, s) { - Some(e) => Ok(e - .data - .borrow() - .get(s) - .ok_or(ErrString(format!("'{}' not found", s)))? - .clone()), - _ => error(&format!("'{}' not found", s)), - }, - _ => error("Env.get called with non-Str"), - } -} - -pub fn env_set(env: &Env, key: MalVal, val: MalVal) -> MalRet { - match key { - Sym(ref s) => { - env.data.borrow_mut().insert(s.to_string(), val.clone()); - Ok(val) - } - _ => error("Env.set called with non-Str"), - } -} - -pub fn env_sets(env: &Env, key: &str, val: MalVal) { - env.data.borrow_mut().insert(key.to_string(), val); -} +use std::cell::RefCell; +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; + +use crate::types::MalErr::ErrString; +use crate::types::MalVal::{List, Nil, Sym, Vector}; +use crate::types::{error, MalErr, MalRet, MalVal}; + +#[derive(Debug)] +pub struct EnvStruct { + data: RefCell>, + pub outer: Option, +} + +pub type Env = Rc; + +// TODO: it would be nice to use impl here but it doesn't work on +// a deftype (i.e. Env) + +pub fn env_new(outer: Option) -> Env { + Rc::new(EnvStruct { + data: RefCell::new(FnvHashMap::default()), + outer: outer, + }) +} + +// TODO: mbinds and exprs as & types +pub fn env_bind(outer: Option, mbinds: MalVal, exprs: Vec) -> Result { + let env = env_new(outer); + match mbinds { + List(binds, _) | Vector(binds, _) => { + for (i, b) in binds.iter().enumerate() { + match b { + Sym(s) if s == "&" => { + env_set(&env, binds[i + 1].clone(), list!(exprs[i..].to_vec()))?; + break; + } + _ => { + env_set(&env, b.clone(), exprs[i].clone())?; + } + } + } + Ok(env) + } + _ => Err(ErrString("env_bind binds not List/Vector".to_string())), + } +} + +pub fn env_find(env: &Env, key: &str) -> Option { + match (env.data.borrow().contains_key(key), env.outer.clone()) { + (true, _) => Some(env.clone()), + (false, Some(o)) => env_find(&o, key), + _ => None, + } +} + +pub fn env_get(env: &Env, key: &MalVal) -> MalRet { + match key { + Sym(ref s) => match env_find(env, s) { + Some(e) => Ok(e + .data + .borrow() + .get(s) + .ok_or(ErrString(format!("'{}' not found", s)))? + .clone()), + _ => error(&format!("'{}' not found", s)), + }, + _ => error("Env.get called with non-Str"), + } +} + +pub fn env_set(env: &Env, key: MalVal, val: MalVal) -> MalRet { + match key { + Sym(ref s) => { + env.data.borrow_mut().insert(s.to_string(), val.clone()); + Ok(val) + } + _ => error("Env.set called with non-Str"), + } +} + +pub fn env_sets(env: &Env, key: &str, val: MalVal) { + env.data.borrow_mut().insert(key.to_string(), val); +} diff --git a/impls/rust/printer.rs b/impls/rust/printer.rs index 6cd4bc8b4d..6224a464c9 100644 --- a/impls/rust/printer.rs +++ b/impls/rust/printer.rs @@ -1,61 +1,61 @@ -use crate::types::MalVal; -use crate::types::MalVal::{Atom, Bool, Func, Hash, Int, List, MalFunc, Nil, Str, Sym, Vector}; - -fn escape_str(s: &str) -> String { - s.chars() - .map(|c| match c { - '"' => "\\\"".to_string(), - '\n' => "\\n".to_string(), - '\\' => "\\\\".to_string(), - _ => c.to_string(), - }) - .collect::>() - .join("") -} - -impl MalVal { - pub fn pr_str(&self, print_readably: bool) -> String { - match self { - Nil => String::from("nil"), - Bool(true) => String::from("true"), - Bool(false) => String::from("false"), - Int(i) => format!("{}", i), - //Float(f) => format!("{}", f), - Str(s) => { - if s.starts_with("\u{29e}") { - format!(":{}", &s[2..]) - } else if print_readably { - format!("\"{}\"", escape_str(s)) - } else { - s.clone() - } - } - Sym(s) => s.clone(), - List(l, _) => pr_seq(&**l, print_readably, "(", ")", " "), - Vector(l, _) => pr_seq(&**l, print_readably, "[", "]", " "), - Hash(hm, _) => { - let l: Vec = hm - .iter() - .flat_map(|(k, v)| vec![Str(k.to_string()), v.clone()]) - .collect(); - pr_seq(&l, print_readably, "{", "}", " ") - } - Func(f, _) => format!("#", f), - MalFunc { - ast: a, params: p, .. - } => format!("(fn* {} {})", p.pr_str(true), a.pr_str(true)), - Atom(a) => format!("(atom {})", a.borrow().pr_str(true)), - } - } -} - -pub fn pr_seq( - seq: &Vec, - print_readably: bool, - start: &str, - end: &str, - join: &str, -) -> String { - let strs: Vec = seq.iter().map(|x| x.pr_str(print_readably)).collect(); - format!("{}{}{}", start, strs.join(join), end) -} +use crate::types::MalVal; +use crate::types::MalVal::{Atom, Bool, Func, Hash, Int, List, MalFunc, Nil, Str, Sym, Vector}; + +fn escape_str(s: &str) -> String { + s.chars() + .map(|c| match c { + '"' => "\\\"".to_string(), + '\n' => "\\n".to_string(), + '\\' => "\\\\".to_string(), + _ => c.to_string(), + }) + .collect::>() + .join("") +} + +impl MalVal { + pub fn pr_str(&self, print_readably: bool) -> String { + match self { + Nil => String::from("nil"), + Bool(true) => String::from("true"), + Bool(false) => String::from("false"), + Int(i) => format!("{}", i), + //Float(f) => format!("{}", f), + Str(s) => { + if s.starts_with("\u{29e}") { + format!(":{}", &s[2..]) + } else if print_readably { + format!("\"{}\"", escape_str(s)) + } else { + s.clone() + } + } + Sym(s) => s.clone(), + List(l, _) => pr_seq(&**l, print_readably, "(", ")", " "), + Vector(l, _) => pr_seq(&**l, print_readably, "[", "]", " "), + Hash(hm, _) => { + let l: Vec = hm + .iter() + .flat_map(|(k, v)| vec![Str(k.to_string()), v.clone()]) + .collect(); + pr_seq(&l, print_readably, "{", "}", " ") + } + Func(f, _) => format!("#", f), + MalFunc { + ast: a, params: p, .. + } => format!("(fn* {} {})", p.pr_str(true), a.pr_str(true)), + Atom(a) => format!("(atom {})", a.borrow().pr_str(true)), + } + } +} + +pub fn pr_seq( + seq: &Vec, + print_readably: bool, + start: &str, + end: &str, + join: &str, +) -> String { + let strs: Vec = seq.iter().map(|x| x.pr_str(print_readably)).collect(); + format!("{}{}{}", start, strs.join(join), end) +} diff --git a/impls/rust/reader.rs b/impls/rust/reader.rs index 4355ff568c..2be5818b58 100644 --- a/impls/rust/reader.rs +++ b/impls/rust/reader.rs @@ -1,156 +1,156 @@ -use regex::{Captures, Regex}; -use std::rc::Rc; - -use crate::types::MalErr::ErrString; -use crate::types::MalVal::{Bool, Int, List, Nil, Str, Sym, Vector}; -use crate::types::{error, hash_map, MalErr, MalRet, MalVal}; - -#[derive(Debug, Clone)] -struct Reader { - tokens: Vec, - pos: usize, -} - -impl Reader { - fn next(&mut self) -> Result { - self.pos = self.pos + 1; - Ok(self - .tokens - .get(self.pos - 1) - .ok_or(ErrString("underflow".to_string()))? - .to_string()) - } - fn peek(&self) -> Result { - Ok(self - .tokens - .get(self.pos) - .ok_or(ErrString("underflow".to_string()))? - .to_string()) - } -} - -fn tokenize(str: &str) -> Vec { - lazy_static! { - static ref RE: Regex = Regex::new( - r###"[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]+)"### - ) - .unwrap(); - } - - let mut res = vec![]; - for cap in RE.captures_iter(str) { - if cap[1].starts_with(";") { - continue; - } - res.push(String::from(&cap[1])); - } - res -} - -fn unescape_str(s: &str) -> String { - lazy_static! { - static ref RE: Regex = Regex::new(r#"\\(.)"#).unwrap(); - } - RE.replace_all(&s, |caps: &Captures| { - format!("{}", if &caps[1] == "n" { "\n" } else { &caps[1] }) - }) - .to_string() -} - -fn read_atom(rdr: &mut Reader) -> MalRet { - lazy_static! { - static ref INT_RE: Regex = Regex::new(r"^-?[0-9]+$").unwrap(); - static ref STR_RE: Regex = Regex::new(r#""(?:\\.|[^\\"])*""#).unwrap(); - } - let token = rdr.next()?; - match &token[..] { - "nil" => Ok(Nil), - "false" => Ok(Bool(false)), - "true" => Ok(Bool(true)), - _ => { - if INT_RE.is_match(&token) { - Ok(Int(token.parse().unwrap())) - } else if STR_RE.is_match(&token) { - Ok(Str(unescape_str(&token[1..token.len() - 1]))) - } else if token.starts_with("\"") { - error("expected '\"', got EOF") - } else if token.starts_with(":") { - Ok(Str(format!("\u{29e}{}", &token[1..]))) - } else { - Ok(Sym(token.to_string())) - } - } - } -} - -fn read_seq(rdr: &mut Reader, end: &str) -> MalRet { - let mut seq: Vec = vec![]; - rdr.next()?; - loop { - let token = match rdr.peek() { - Ok(t) => t, - Err(_) => return error(&format!("expected '{}', got EOF", end)), - }; - if token == end { - break; - } - seq.push(read_form(rdr)?) - } - let _ = rdr.next(); - match end { - ")" => Ok(list!(seq)), - "]" => Ok(vector!(seq)), - "}" => hash_map(seq), - _ => error("read_seq unknown end value"), - } -} - -fn read_form(rdr: &mut Reader) -> MalRet { - let token = rdr.peek()?; - match &token[..] { - "'" => { - let _ = rdr.next(); - Ok(list![Sym("quote".to_string()), read_form(rdr)?]) - } - "`" => { - let _ = rdr.next(); - Ok(list![Sym("quasiquote".to_string()), read_form(rdr)?]) - } - "~" => { - let _ = rdr.next(); - Ok(list![Sym("unquote".to_string()), read_form(rdr)?]) - } - "~@" => { - let _ = rdr.next(); - Ok(list![Sym("splice-unquote".to_string()), read_form(rdr)?]) - } - "^" => { - let _ = rdr.next(); - let meta = read_form(rdr)?; - Ok(list![Sym("with-meta".to_string()), read_form(rdr)?, meta]) - } - "@" => { - let _ = rdr.next(); - Ok(list![Sym("deref".to_string()), read_form(rdr)?]) - } - ")" => error("unexpected ')'"), - "(" => read_seq(rdr, ")"), - "]" => error("unexpected ']'"), - "[" => read_seq(rdr, "]"), - "}" => error("unexpected '}'"), - "{" => read_seq(rdr, "}"), - _ => read_atom(rdr), - } -} - -pub fn read_str(str: String) -> MalRet { - let tokens = tokenize(&str); - //println!("tokens: {:?}", tokens); - if tokens.len() == 0 { - return error("no input"); - } - read_form(&mut Reader { - pos: 0, - tokens: tokens, - }) -} +use regex::{Captures, Regex}; +use std::rc::Rc; + +use crate::types::MalErr::ErrString; +use crate::types::MalVal::{Bool, Int, List, Nil, Str, Sym, Vector}; +use crate::types::{error, hash_map, MalErr, MalRet, MalVal}; + +#[derive(Debug, Clone)] +struct Reader { + tokens: Vec, + pos: usize, +} + +impl Reader { + fn next(&mut self) -> Result { + self.pos = self.pos + 1; + Ok(self + .tokens + .get(self.pos - 1) + .ok_or(ErrString("underflow".to_string()))? + .to_string()) + } + fn peek(&self) -> Result { + Ok(self + .tokens + .get(self.pos) + .ok_or(ErrString("underflow".to_string()))? + .to_string()) + } +} + +fn tokenize(str: &str) -> Vec { + lazy_static! { + static ref RE: Regex = Regex::new( + r###"[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]+)"### + ) + .unwrap(); + } + + let mut res = vec![]; + for cap in RE.captures_iter(str) { + if cap[1].starts_with(";") { + continue; + } + res.push(String::from(&cap[1])); + } + res +} + +fn unescape_str(s: &str) -> String { + lazy_static! { + static ref RE: Regex = Regex::new(r#"\\(.)"#).unwrap(); + } + RE.replace_all(&s, |caps: &Captures| { + format!("{}", if &caps[1] == "n" { "\n" } else { &caps[1] }) + }) + .to_string() +} + +fn read_atom(rdr: &mut Reader) -> MalRet { + lazy_static! { + static ref INT_RE: Regex = Regex::new(r"^-?[0-9]+$").unwrap(); + static ref STR_RE: Regex = Regex::new(r#""(?:\\.|[^\\"])*""#).unwrap(); + } + let token = rdr.next()?; + match &token[..] { + "nil" => Ok(Nil), + "false" => Ok(Bool(false)), + "true" => Ok(Bool(true)), + _ => { + if INT_RE.is_match(&token) { + Ok(Int(token.parse().unwrap())) + } else if STR_RE.is_match(&token) { + Ok(Str(unescape_str(&token[1..token.len() - 1]))) + } else if token.starts_with("\"") { + error("expected '\"', got EOF") + } else if token.starts_with(":") { + Ok(Str(format!("\u{29e}{}", &token[1..]))) + } else { + Ok(Sym(token.to_string())) + } + } + } +} + +fn read_seq(rdr: &mut Reader, end: &str) -> MalRet { + let mut seq: Vec = vec![]; + rdr.next()?; + loop { + let token = match rdr.peek() { + Ok(t) => t, + Err(_) => return error(&format!("expected '{}', got EOF", end)), + }; + if token == end { + break; + } + seq.push(read_form(rdr)?) + } + let _ = rdr.next(); + match end { + ")" => Ok(list!(seq)), + "]" => Ok(vector!(seq)), + "}" => hash_map(seq), + _ => error("read_seq unknown end value"), + } +} + +fn read_form(rdr: &mut Reader) -> MalRet { + let token = rdr.peek()?; + match &token[..] { + "'" => { + let _ = rdr.next(); + Ok(list![Sym("quote".to_string()), read_form(rdr)?]) + } + "`" => { + let _ = rdr.next(); + Ok(list![Sym("quasiquote".to_string()), read_form(rdr)?]) + } + "~" => { + let _ = rdr.next(); + Ok(list![Sym("unquote".to_string()), read_form(rdr)?]) + } + "~@" => { + let _ = rdr.next(); + Ok(list![Sym("splice-unquote".to_string()), read_form(rdr)?]) + } + "^" => { + let _ = rdr.next(); + let meta = read_form(rdr)?; + Ok(list![Sym("with-meta".to_string()), read_form(rdr)?, meta]) + } + "@" => { + let _ = rdr.next(); + Ok(list![Sym("deref".to_string()), read_form(rdr)?]) + } + ")" => error("unexpected ')'"), + "(" => read_seq(rdr, ")"), + "]" => error("unexpected ']'"), + "[" => read_seq(rdr, "]"), + "}" => error("unexpected '}'"), + "{" => read_seq(rdr, "}"), + _ => read_atom(rdr), + } +} + +pub fn read_str(str: String) -> MalRet { + let tokens = tokenize(&str); + //println!("tokens: {:?}", tokens); + if tokens.len() == 0 { + return error("no input"); + } + read_form(&mut Reader { + pos: 0, + tokens: tokens, + }) +} diff --git a/impls/rust/run b/impls/rust/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/rust/run +++ b/impls/rust/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/rust/step0_repl.rs b/impls/rust/step0_repl.rs index 3468e791d0..cb11c40f13 100644 --- a/impls/rust/step0_repl.rs +++ b/impls/rust/step0_repl.rs @@ -1,31 +1,31 @@ -extern crate rustyline; - -use rustyline::error::ReadlineError; -use rustyline::Editor; - -fn main() { - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - println!("{}", line); - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +extern crate rustyline; + +use rustyline::error::ReadlineError; +use rustyline::Editor; + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + println!("{}", line); + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/step1_read_print.rs b/impls/rust/step1_read_print.rs index 3b5394e550..16e57d3f85 100644 --- a/impls/rust/step1_read_print.rs +++ b/impls/rust/step1_read_print.rs @@ -1,51 +1,51 @@ -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -#[allow(dead_code)] -mod types; -use crate::types::format_error; -mod printer; -mod reader; -// TODO: figure out a way to avoid including env -#[allow(dead_code)] -mod env; - -fn main() { - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match reader::read_str(line) { - Ok(mv) => { - println!("{}", mv.pr_str(true)); - } - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +#[allow(dead_code)] +mod types; +use crate::types::format_error; +mod printer; +mod reader; +// TODO: figure out a way to avoid including env +#[allow(dead_code)] +mod env; + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match reader::read_str(line) { + Ok(mv) => { + println!("{}", mv.pr_str(true)); + } + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/step2_eval.rs b/impls/rust/step2_eval.rs index d19e8382d5..38b609abb2 100644 --- a/impls/rust/step2_eval.rs +++ b/impls/rust/step2_eval.rs @@ -1,136 +1,136 @@ -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; - -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -#[allow(dead_code)] -mod types; -use crate::types::MalErr::ErrString; -use crate::types::MalVal::{Hash, Int, List, Nil, Sym, Vector}; -use crate::types::{error, format_error, func, MalArgs, MalErr, MalRet, MalVal}; -mod printer; -mod reader; -// TODO: figure out a way to avoid including env -#[allow(dead_code)] -mod env; - -pub type Env = FnvHashMap; - -// read -fn read(str: &str) -> MalRet { - reader::read_str(str.to_string()) -} - -// eval -fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { - match ast { - Sym(sym) => Ok(env - .get(sym) - .ok_or(ErrString(format!("'{}' not found", sym)))? - .clone()), - List(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(list!(lst)) - } - Vector(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(vector!(lst)) - } - Hash(hm, _) => { - let mut new_hm: FnvHashMap = FnvHashMap::default(); - for (k, v) in hm.iter() { - new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); - } - Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) - } - _ => Ok(ast.clone()), - } -} - -fn eval(ast: MalVal, env: Env) -> MalRet { - match ast.clone() { - List(l, _) => { - if l.len() == 0 { - return Ok(ast); - } - match eval_ast(&ast, &env)? { - List(ref el, _) => { - let ref f = el[0].clone(); - f.apply(el[1..].to_vec()) - } - _ => error("expected a list"), - } - } - _ => eval_ast(&ast, &env), - } -} - -// print -fn print(ast: &MalVal) -> String { - ast.pr_str(true) -} - -fn rep(str: &str, env: &Env) -> Result { - let ast = read(str)?; - let exp = eval(ast, env.clone())?; - Ok(print(&exp)) -} - -fn int_op(op: fn(i64, i64) -> i64, a: MalArgs) -> MalRet { - match (a[0].clone(), a[1].clone()) { - (Int(a0), Int(a1)) => Ok(Int(op(a0, a1))), - _ => error("invalid int_op args"), - } -} - -fn main() { - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - let mut repl_env = Env::default(); - repl_env.insert("+".to_string(), func(|a: MalArgs| int_op(|i, j| i + j, a))); - repl_env.insert("-".to_string(), func(|a: MalArgs| int_op(|i, j| i - j, a))); - repl_env.insert("*".to_string(), func(|a: MalArgs| int_op(|i, j| i * j, a))); - repl_env.insert("/".to_string(), func(|a: MalArgs| int_op(|i, j| i / j, a))); - - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match rep(&line, &repl_env) { - Ok(out) => println!("{}", out), - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; + +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +#[allow(dead_code)] +mod types; +use crate::types::MalErr::ErrString; +use crate::types::MalVal::{Hash, Int, List, Nil, Sym, Vector}; +use crate::types::{error, format_error, func, MalArgs, MalErr, MalRet, MalVal}; +mod printer; +mod reader; +// TODO: figure out a way to avoid including env +#[allow(dead_code)] +mod env; + +pub type Env = FnvHashMap; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(sym) => Ok(env + .get(sym) + .ok_or(ErrString(format!("'{}' not found", sym)))? + .clone()), + List(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(list!(lst)) + } + Vector(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(vector!(lst)) + } + Hash(hm, _) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k, v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) + } + _ => Ok(ast.clone()), + } +} + +fn eval(ast: MalVal, env: Env) -> MalRet { + match ast.clone() { + List(l, _) => { + if l.len() == 0 { + return Ok(ast); + } + match eval_ast(&ast, &env)? { + List(ref el, _) => { + let ref f = el[0].clone(); + f.apply(el[1..].to_vec()) + } + _ => error("expected a list"), + } + } + _ => eval_ast(&ast, &env), + } +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn int_op(op: fn(i64, i64) -> i64, a: MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (Int(a0), Int(a1)) => Ok(Int(op(a0, a1))), + _ => error("invalid int_op args"), + } +} + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + let mut repl_env = Env::default(); + repl_env.insert("+".to_string(), func(|a: MalArgs| int_op(|i, j| i + j, a))); + repl_env.insert("-".to_string(), func(|a: MalArgs| int_op(|i, j| i - j, a))); + repl_env.insert("*".to_string(), func(|a: MalArgs| int_op(|i, j| i * j, a))); + repl_env.insert("/".to_string(), func(|a: MalArgs| int_op(|i, j| i / j, a))); + + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/step3_env.rs b/impls/rust/step3_env.rs index f7fa56652b..b10c3666e7 100644 --- a/impls/rust/step3_env.rs +++ b/impls/rust/step3_env.rs @@ -1,162 +1,162 @@ -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; -use itertools::Itertools; - -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -#[allow(dead_code)] -mod types; -use crate::types::MalVal::{Hash, Int, List, Nil, Sym, Vector}; -use crate::types::{error, format_error, func, MalArgs, MalErr, MalRet, MalVal}; -mod env; -mod printer; -mod reader; -use crate::env::{env_get, env_new, env_set, env_sets, Env}; - -// read -fn read(str: &str) -> MalRet { - reader::read_str(str.to_string()) -} - -// eval -fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { - match ast { - Sym(_) => Ok(env_get(&env, &ast)?), - List(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(list!(lst)) - } - Vector(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(vector!(lst)) - } - Hash(hm, _) => { - let mut new_hm: FnvHashMap = FnvHashMap::default(); - for (k, v) in hm.iter() { - new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); - } - Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) - } - _ => Ok(ast.clone()), - } -} - -fn eval(ast: MalVal, env: Env) -> MalRet { - match ast.clone() { - List(l, _) => { - if l.len() == 0 { - return Ok(ast); - } - let a0 = &l[0]; - match a0 { - Sym(ref a0sym) if a0sym == "def!" => { - env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) - } - Sym(ref a0sym) if a0sym == "let*" => { - let let_env = env_new(Some(env.clone())); - let (a1, a2) = (l[1].clone(), l[2].clone()); - match a1 { - List(ref binds, _) | Vector(ref binds, _) => { - for (b, e) in binds.iter().tuples() { - match b { - Sym(_) => { - let _ = env_set( - &let_env, - b.clone(), - eval(e.clone(), let_env.clone())?, - ); - } - _ => { - return error("let* with non-Sym binding"); - } - } - } - } - _ => { - return error("let* with non-List bindings"); - } - }; - eval(a2, let_env) - } - _ => match eval_ast(&ast, &env)? { - List(ref el, _) => { - let ref f = el[0].clone(); - f.apply(el[1..].to_vec()) - } - _ => error("expected a list"), - }, - } - } - _ => eval_ast(&ast, &env), - } -} - -// print -fn print(ast: &MalVal) -> String { - ast.pr_str(true) -} - -fn rep(str: &str, env: &Env) -> Result { - let ast = read(str)?; - let exp = eval(ast, env.clone())?; - Ok(print(&exp)) -} - -fn int_op(op: fn(i64, i64) -> i64, a: MalArgs) -> MalRet { - match (a[0].clone(), a[1].clone()) { - (Int(a0), Int(a1)) => Ok(Int(op(a0, a1))), - _ => error("invalid int_op args"), - } -} - -fn main() { - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - let repl_env = env_new(None); - env_sets(&repl_env, "+", func(|a: MalArgs| int_op(|i, j| i + j, a))); - env_sets(&repl_env, "-", func(|a: MalArgs| int_op(|i, j| i - j, a))); - env_sets(&repl_env, "*", func(|a: MalArgs| int_op(|i, j| i * j, a))); - env_sets(&repl_env, "/", func(|a: MalArgs| int_op(|i, j| i / j, a))); - - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match rep(&line, &repl_env) { - Ok(out) => println!("{}", out), - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +#[allow(dead_code)] +mod types; +use crate::types::MalVal::{Hash, Int, List, Nil, Sym, Vector}; +use crate::types::{error, format_error, func, MalArgs, MalErr, MalRet, MalVal}; +mod env; +mod printer; +mod reader; +use crate::env::{env_get, env_new, env_set, env_sets, Env}; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(list!(lst)) + } + Vector(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(vector!(lst)) + } + Hash(hm, _) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k, v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) + } + _ => Ok(ast.clone()), + } +} + +fn eval(ast: MalVal, env: Env) -> MalRet { + match ast.clone() { + List(l, _) => { + if l.len() == 0 { + return Ok(ast); + } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + } + Sym(ref a0sym) if a0sym == "let*" => { + let let_env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds, _) | Vector(ref binds, _) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set( + &let_env, + b.clone(), + eval(e.clone(), let_env.clone())?, + ); + } + _ => { + return error("let* with non-Sym binding"); + } + } + } + } + _ => { + return error("let* with non-List bindings"); + } + }; + eval(a2, let_env) + } + _ => match eval_ast(&ast, &env)? { + List(ref el, _) => { + let ref f = el[0].clone(); + f.apply(el[1..].to_vec()) + } + _ => error("expected a list"), + }, + } + } + _ => eval_ast(&ast, &env), + } +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn int_op(op: fn(i64, i64) -> i64, a: MalArgs) -> MalRet { + match (a[0].clone(), a[1].clone()) { + (Int(a0), Int(a1)) => Ok(Int(op(a0, a1))), + _ => error("invalid int_op args"), + } +} + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + let repl_env = env_new(None); + env_sets(&repl_env, "+", func(|a: MalArgs| int_op(|i, j| i + j, a))); + env_sets(&repl_env, "-", func(|a: MalArgs| int_op(|i, j| i - j, a))); + env_sets(&repl_env, "*", func(|a: MalArgs| int_op(|i, j| i * j, a))); + env_sets(&repl_env, "/", func(|a: MalArgs| int_op(|i, j| i / j, a))); + + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/step4_if_fn_do.rs b/impls/rust/step4_if_fn_do.rs index a21223a5f8..878aea8123 100644 --- a/impls/rust/step4_if_fn_do.rs +++ b/impls/rust/step4_if_fn_do.rs @@ -1,184 +1,184 @@ -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; -use itertools::Itertools; - -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -mod types; -use crate::types::MalVal::{Bool, Hash, List, MalFunc, Nil, Sym, Vector}; -use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; -mod env; -mod printer; -mod reader; -use crate::env::{env_get, env_new, env_set, env_sets, Env}; -#[macro_use] -mod core; - -// read -fn read(str: &str) -> MalRet { - reader::read_str(str.to_string()) -} - -// eval -fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { - match ast { - Sym(_) => Ok(env_get(&env, &ast)?), - List(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(list!(lst)) - } - Vector(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(vector!(lst)) - } - Hash(hm, _) => { - let mut new_hm: FnvHashMap = FnvHashMap::default(); - for (k, v) in hm.iter() { - new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); - } - Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) - } - _ => Ok(ast.clone()), - } -} - -fn eval(ast: MalVal, env: Env) -> MalRet { - match ast.clone() { - List(l, _) => { - if l.len() == 0 { - return Ok(ast); - } - let a0 = &l[0]; - match a0 { - Sym(ref a0sym) if a0sym == "def!" => { - env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) - } - Sym(ref a0sym) if a0sym == "let*" => { - let let_env = env_new(Some(env.clone())); - let (a1, a2) = (l[1].clone(), l[2].clone()); - match a1 { - List(ref binds, _) | Vector(ref binds, _) => { - for (b, e) in binds.iter().tuples() { - match b { - Sym(_) => { - let _ = env_set( - &let_env, - b.clone(), - eval(e.clone(), let_env.clone())?, - ); - } - _ => { - return error("let* with non-Sym binding"); - } - } - } - } - _ => { - return error("let* with non-List bindings"); - } - }; - eval(a2, let_env) - } - Sym(ref a0sym) if a0sym == "do" => match eval_ast(&list!(l[1..].to_vec()), &env)? { - List(el, _) => Ok(el.last().unwrap_or(&Nil).clone()), - _ => error("invalid do form"), - }, - Sym(ref a0sym) if a0sym == "if" => { - let cond = eval(l[1].clone(), env.clone())?; - match cond { - Bool(false) | Nil if l.len() >= 4 => eval(l[3].clone(), env.clone()), - Bool(false) | Nil => Ok(Nil), - _ if l.len() >= 3 => eval(l[2].clone(), env.clone()), - _ => Ok(Nil), - } - } - Sym(ref a0sym) if a0sym == "fn*" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - Ok(MalFunc { - eval: eval, - ast: Rc::new(a2), - env: env, - params: Rc::new(a1), - is_macro: false, - meta: Rc::new(Nil), - }) - } - _ => match eval_ast(&ast, &env)? { - List(ref el, _) => { - let ref f = el[0].clone(); - f.apply(el[1..].to_vec()) - } - _ => error("expected a list"), - }, - } - } - _ => eval_ast(&ast, &env), - } -} - -// print -fn print(ast: &MalVal) -> String { - ast.pr_str(true) -} - -fn rep(str: &str, env: &Env) -> Result { - let ast = read(str)?; - let exp = eval(ast, env.clone())?; - Ok(print(&exp)) -} - -fn main() { - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns() { - env_sets(&repl_env, k, v); - } - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); - - // main repl loop - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match rep(&line, &repl_env) { - Ok(out) => println!("{}", out), - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use crate::types::MalVal::{Bool, Hash, List, MalFunc, Nil, Sym, Vector}; +use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; +mod env; +mod printer; +mod reader; +use crate::env::{env_get, env_new, env_set, env_sets, Env}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(list!(lst)) + } + Vector(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(vector!(lst)) + } + Hash(hm, _) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k, v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) + } + _ => Ok(ast.clone()), + } +} + +fn eval(ast: MalVal, env: Env) -> MalRet { + match ast.clone() { + List(l, _) => { + if l.len() == 0 { + return Ok(ast); + } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + } + Sym(ref a0sym) if a0sym == "let*" => { + let let_env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds, _) | Vector(ref binds, _) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set( + &let_env, + b.clone(), + eval(e.clone(), let_env.clone())?, + ); + } + _ => { + return error("let* with non-Sym binding"); + } + } + } + } + _ => { + return error("let* with non-List bindings"); + } + }; + eval(a2, let_env) + } + Sym(ref a0sym) if a0sym == "do" => match eval_ast(&list!(l[1..].to_vec()), &env)? { + List(el, _) => Ok(el.last().unwrap_or(&Nil).clone()), + _ => error("invalid do form"), + }, + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => eval(l[3].clone(), env.clone()), + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => eval(l[2].clone(), env.clone()), + _ => Ok(Nil), + } + } + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc { + eval: eval, + ast: Rc::new(a2), + env: env, + params: Rc::new(a1), + is_macro: false, + meta: Rc::new(Nil), + }) + } + _ => match eval_ast(&ast, &env)? { + List(ref el, _) => { + let ref f = el[0].clone(); + f.apply(el[1..].to_vec()) + } + _ => error("expected a list"), + }, + } + } + _ => eval_ast(&ast, &env), + } +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/step5_tco.rs b/impls/rust/step5_tco.rs index 185b8df5ef..0837cdb64c 100644 --- a/impls/rust/step5_tco.rs +++ b/impls/rust/step5_tco.rs @@ -1,220 +1,220 @@ -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; -use itertools::Itertools; - -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -mod types; -use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Sym, Vector}; -use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; -mod env; -mod printer; -mod reader; -use crate::env::{env_bind, env_get, env_new, env_set, env_sets, Env}; -#[macro_use] -mod core; - -// read -fn read(str: &str) -> MalRet { - reader::read_str(str.to_string()) -} - -// eval -fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { - match ast { - Sym(_) => Ok(env_get(&env, &ast)?), - List(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(list!(lst)) - } - Vector(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(vector!(lst)) - } - Hash(hm, _) => { - let mut new_hm: FnvHashMap = FnvHashMap::default(); - for (k, v) in hm.iter() { - new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); - } - Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - let ret: MalRet; - - 'tco: loop { - ret = match ast.clone() { - List(l, _) => { - if l.len() == 0 { - return Ok(ast); - } - let a0 = &l[0]; - match a0 { - Sym(ref a0sym) if a0sym == "def!" => { - env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) - } - Sym(ref a0sym) if a0sym == "let*" => { - env = env_new(Some(env.clone())); - let (a1, a2) = (l[1].clone(), l[2].clone()); - match a1 { - List(ref binds, _) | Vector(ref binds, _) => { - for (b, e) in binds.iter().tuples() { - match b { - Sym(_) => { - let _ = env_set( - &env, - b.clone(), - eval(e.clone(), env.clone())?, - ); - } - _ => { - return error("let* with non-Sym binding"); - } - } - } - } - _ => { - return error("let* with non-List bindings"); - } - }; - ast = a2; - continue 'tco; - } - Sym(ref a0sym) if a0sym == "do" => { - match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { - List(_, _) => { - ast = l.last().unwrap_or(&Nil).clone(); - continue 'tco; - } - _ => error("invalid do form"), - } - } - Sym(ref a0sym) if a0sym == "if" => { - let cond = eval(l[1].clone(), env.clone())?; - match cond { - Bool(false) | Nil if l.len() >= 4 => { - ast = l[3].clone(); - continue 'tco; - } - Bool(false) | Nil => Ok(Nil), - _ if l.len() >= 3 => { - ast = l[2].clone(); - continue 'tco; - } - _ => Ok(Nil), - } - } - Sym(ref a0sym) if a0sym == "fn*" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - Ok(MalFunc { - eval: eval, - ast: Rc::new(a2), - env: env, - params: Rc::new(a1), - is_macro: false, - meta: Rc::new(Nil), - }) - } - _ => match eval_ast(&ast, &env)? { - List(ref el, _) => { - let ref f = el[0].clone(); - let args = el[1..].to_vec(); - match f { - Func(_, _) => f.apply(args), - MalFunc { - ast: mast, - env: menv, - params, - .. - } => { - let a = &**mast; - let p = &**params; - env = env_bind(Some(menv.clone()), p.clone(), args)?; - ast = a.clone(); - continue 'tco; - } - _ => error("attempt to call non-function"), - } - } - _ => error("expected a list"), - }, - } - } - _ => eval_ast(&ast, &env), - }; - - break; - } // end 'tco loop - - ret -} - -// print -fn print(ast: &MalVal) -> String { - ast.pr_str(true) -} - -fn rep(str: &str, env: &Env) -> Result { - let ast = read(str)?; - let exp = eval(ast, env.clone())?; - Ok(print(&exp)) -} - -fn main() { - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns() { - env_sets(&repl_env, k, v); - } - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); - - // main repl loop - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match rep(&line, &repl_env) { - Ok(out) => println!("{}", out), - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Sym, Vector}; +use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; +mod env; +mod printer; +mod reader; +use crate::env::{env_bind, env_get, env_new, env_set, env_sets, Env}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(list!(lst)) + } + Vector(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(vector!(lst)) + } + Hash(hm, _) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k, v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) + } + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + ret = match ast.clone() { + List(l, _) => { + if l.len() == 0 { + return Ok(ast); + } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + } + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds, _) | Vector(ref binds, _) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set( + &env, + b.clone(), + eval(e.clone(), env.clone())?, + ); + } + _ => { + return error("let* with non-Sym binding"); + } + } + } + } + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + } + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { + List(_, _) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + } + _ => error("invalid do form"), + } + } + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + } + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + } + _ => Ok(Nil), + } + } + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc { + eval: eval, + ast: Rc::new(a2), + env: env, + params: Rc::new(a1), + is_macro: false, + meta: Rc::new(Nil), + }) + } + _ => match eval_ast(&ast, &env)? { + List(ref el, _) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_, _) => f.apply(args), + MalFunc { + ast: mast, + env: menv, + params, + .. + } => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + } + _ => error("attempt to call non-function"), + } + } + _ => error("expected a list"), + }, + } + } + _ => eval_ast(&ast, &env), + }; + + break; + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/step6_file.rs b/impls/rust/step6_file.rs index 84e3c2bc1b..49ef5c5bc8 100644 --- a/impls/rust/step6_file.rs +++ b/impls/rust/step6_file.rs @@ -1,246 +1,246 @@ -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; -use itertools::Itertools; - -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -mod types; -use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; -use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; -mod env; -mod printer; -mod reader; -use crate::env::{env_bind, env_get, env_new, env_set, env_sets, Env}; -#[macro_use] -mod core; - -// read -fn read(str: &str) -> MalRet { - reader::read_str(str.to_string()) -} - -// eval -fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { - match ast { - Sym(_) => Ok(env_get(&env, &ast)?), - List(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(list!(lst)) - } - Vector(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(vector!(lst)) - } - Hash(hm, _) => { - let mut new_hm: FnvHashMap = FnvHashMap::default(); - for (k, v) in hm.iter() { - new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); - } - Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - let ret: MalRet; - - 'tco: loop { - ret = match ast.clone() { - List(l, _) => { - if l.len() == 0 { - return Ok(ast); - } - let a0 = &l[0]; - match a0 { - Sym(ref a0sym) if a0sym == "def!" => { - env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) - } - Sym(ref a0sym) if a0sym == "let*" => { - env = env_new(Some(env.clone())); - let (a1, a2) = (l[1].clone(), l[2].clone()); - match a1 { - List(ref binds, _) | Vector(ref binds, _) => { - for (b, e) in binds.iter().tuples() { - match b { - Sym(_) => { - let _ = env_set( - &env, - b.clone(), - eval(e.clone(), env.clone())?, - ); - } - _ => { - return error("let* with non-Sym binding"); - } - } - } - } - _ => { - return error("let* with non-List bindings"); - } - }; - ast = a2; - continue 'tco; - } - Sym(ref a0sym) if a0sym == "do" => { - match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { - List(_, _) => { - ast = l.last().unwrap_or(&Nil).clone(); - continue 'tco; - } - _ => error("invalid do form"), - } - } - Sym(ref a0sym) if a0sym == "if" => { - let cond = eval(l[1].clone(), env.clone())?; - match cond { - Bool(false) | Nil if l.len() >= 4 => { - ast = l[3].clone(); - continue 'tco; - } - Bool(false) | Nil => Ok(Nil), - _ if l.len() >= 3 => { - ast = l[2].clone(); - continue 'tco; - } - _ => Ok(Nil), - } - } - Sym(ref a0sym) if a0sym == "fn*" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - Ok(MalFunc { - eval: eval, - ast: Rc::new(a2), - env: env, - params: Rc::new(a1), - is_macro: false, - meta: Rc::new(Nil), - }) - } - Sym(ref a0sym) if a0sym == "eval" => { - ast = eval(l[1].clone(), env.clone())?; - while let Some(ref e) = env.clone().outer { - env = e.clone(); - } - continue 'tco; - } - _ => match eval_ast(&ast, &env)? { - List(ref el, _) => { - let ref f = el[0].clone(); - let args = el[1..].to_vec(); - match f { - Func(_, _) => f.apply(args), - MalFunc { - ast: mast, - env: menv, - params, - .. - } => { - let a = &**mast; - let p = &**params; - env = env_bind(Some(menv.clone()), p.clone(), args)?; - ast = a.clone(); - continue 'tco; - } - _ => error("attempt to call non-function"), - } - } - _ => error("expected a list"), - }, - } - } - _ => eval_ast(&ast, &env), - }; - - break; - } // end 'tco loop - - ret -} - -// print -fn print(ast: &MalVal) -> String { - ast.pr_str(true) -} - -fn rep(str: &str, env: &Env) -> Result { - let ast = read(str)?; - let exp = eval(ast, env.clone())?; - Ok(print(&exp)) -} - -fn main() { - let mut args = std::env::args(); - let arg1 = args.nth(1); - - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns() { - env_sets(&repl_env, k, v); - } - env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); - let _ = rep( - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", - &repl_env, - ); - - // Invoked with arguments - if let Some(f) = arg1 { - match rep(&format!("(load-file \"{}\")", f), &repl_env) { - Ok(_) => std::process::exit(0), - Err(e) => { - println!("Error: {}", format_error(e)); - std::process::exit(1); - } - } - } - - // main repl loop - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match rep(&line, &repl_env) { - Ok(out) => println!("{}", out), - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; +use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; +mod env; +mod printer; +mod reader; +use crate::env::{env_bind, env_get, env_new, env_set, env_sets, Env}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(list!(lst)) + } + Vector(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(vector!(lst)) + } + Hash(hm, _) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k, v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) + } + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + ret = match ast.clone() { + List(l, _) => { + if l.len() == 0 { + return Ok(ast); + } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + } + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds, _) | Vector(ref binds, _) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set( + &env, + b.clone(), + eval(e.clone(), env.clone())?, + ); + } + _ => { + return error("let* with non-Sym binding"); + } + } + } + } + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + } + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { + List(_, _) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + } + _ => error("invalid do form"), + } + } + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + } + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + } + _ => Ok(Nil), + } + } + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc { + eval: eval, + ast: Rc::new(a2), + env: env, + params: Rc::new(a1), + is_macro: false, + meta: Rc::new(Nil), + }) + } + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + } + _ => match eval_ast(&ast, &env)? { + List(ref el, _) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_, _) => f.apply(args), + MalFunc { + ast: mast, + env: menv, + params, + .. + } => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + } + _ => error("attempt to call non-function"), + } + } + _ => error("expected a list"), + }, + } + } + _ => eval_ast(&ast, &env), + }; + + break; + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep( + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", + &repl_env, + ); + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")", f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/step7_quote.rs b/impls/rust/step7_quote.rs index 374128a8d1..5bc4a6aefc 100644 --- a/impls/rust/step7_quote.rs +++ b/impls/rust/step7_quote.rs @@ -1,289 +1,289 @@ -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; -use itertools::Itertools; - -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -mod types; -use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; -use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; -mod env; -mod printer; -mod reader; -use crate::env::{env_bind, env_get, env_new, env_set, env_sets, Env}; -#[macro_use] -mod core; - -// read -fn read(str: &str) -> MalRet { - reader::read_str(str.to_string()) -} - -// eval - -fn qq_iter(elts: &MalArgs) -> MalVal { - let mut acc = list![]; - for elt in elts.iter().rev() { - if let List(v, _) = elt { - if v.len() == 2 { - if let Sym(ref s) = v[0] { - if s == "splice-unquote" { - acc = list![Sym("concat".to_string()), v[1].clone(), acc]; - continue; - } - } - } - } - acc = list![Sym("cons".to_string()), quasiquote(&elt), acc]; - } - return acc; -} - -fn quasiquote(ast: &MalVal) -> MalVal { - match ast { - List(v, _) => { - if v.len() == 2 { - if let Sym(ref s) = v[0] { - if s == "unquote" { - return v[1].clone(); - } - } - } - return qq_iter(&v); - }, - Vector(v, _) => return list![Sym("vec".to_string()), qq_iter(&v)], - Hash(_, _) | Sym(_)=> return list![Sym("quote".to_string()), ast.clone()], - _ => ast.clone(), - } -} - -fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { - match ast { - Sym(_) => Ok(env_get(&env, &ast)?), - List(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(list!(lst)) - } - Vector(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(vector!(lst)) - } - Hash(hm, _) => { - let mut new_hm: FnvHashMap = FnvHashMap::default(); - for (k, v) in hm.iter() { - new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); - } - Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - let ret: MalRet; - - 'tco: loop { - ret = match ast.clone() { - List(l, _) => { - if l.len() == 0 { - return Ok(ast); - } - let a0 = &l[0]; - match a0 { - Sym(ref a0sym) if a0sym == "def!" => { - env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) - } - Sym(ref a0sym) if a0sym == "let*" => { - env = env_new(Some(env.clone())); - let (a1, a2) = (l[1].clone(), l[2].clone()); - match a1 { - List(ref binds, _) | Vector(ref binds, _) => { - for (b, e) in binds.iter().tuples() { - match b { - Sym(_) => { - let _ = env_set( - &env, - b.clone(), - eval(e.clone(), env.clone())?, - ); - } - _ => { - return error("let* with non-Sym binding"); - } - } - } - } - _ => { - return error("let* with non-List bindings"); - } - }; - ast = a2; - continue 'tco; - } - Sym(ref a0sym) if a0sym == "quote" => Ok(l[1].clone()), - Sym(ref a0sym) if a0sym == "quasiquoteexpand" => Ok(quasiquote(&l[1])), - Sym(ref a0sym) if a0sym == "quasiquote" => { - ast = quasiquote(&l[1]); - continue 'tco; - } - Sym(ref a0sym) if a0sym == "do" => { - match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { - List(_, _) => { - ast = l.last().unwrap_or(&Nil).clone(); - continue 'tco; - } - _ => error("invalid do form"), - } - } - Sym(ref a0sym) if a0sym == "if" => { - let cond = eval(l[1].clone(), env.clone())?; - match cond { - Bool(false) | Nil if l.len() >= 4 => { - ast = l[3].clone(); - continue 'tco; - } - Bool(false) | Nil => Ok(Nil), - _ if l.len() >= 3 => { - ast = l[2].clone(); - continue 'tco; - } - _ => Ok(Nil), - } - } - Sym(ref a0sym) if a0sym == "fn*" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - Ok(MalFunc { - eval: eval, - ast: Rc::new(a2), - env: env, - params: Rc::new(a1), - is_macro: false, - meta: Rc::new(Nil), - }) - } - Sym(ref a0sym) if a0sym == "eval" => { - ast = eval(l[1].clone(), env.clone())?; - while let Some(ref e) = env.clone().outer { - env = e.clone(); - } - continue 'tco; - } - _ => match eval_ast(&ast, &env)? { - List(ref el, _) => { - let ref f = el[0].clone(); - let args = el[1..].to_vec(); - match f { - Func(_, _) => f.apply(args), - MalFunc { - ast: mast, - env: menv, - params, - .. - } => { - let a = &**mast; - let p = &**params; - env = env_bind(Some(menv.clone()), p.clone(), args)?; - ast = a.clone(); - continue 'tco; - } - _ => error("attempt to call non-function"), - } - } - _ => error("expected a list"), - }, - } - } - _ => eval_ast(&ast, &env), - }; - - break; - } // end 'tco loop - - ret -} - -// print -fn print(ast: &MalVal) -> String { - ast.pr_str(true) -} - -fn rep(str: &str, env: &Env) -> Result { - let ast = read(str)?; - let exp = eval(ast, env.clone())?; - Ok(print(&exp)) -} - -fn main() { - let mut args = std::env::args(); - let arg1 = args.nth(1); - - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns() { - env_sets(&repl_env, k, v); - } - env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); - let _ = rep( - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", - &repl_env, - ); - - // Invoked with arguments - if let Some(f) = arg1 { - match rep(&format!("(load-file \"{}\")", f), &repl_env) { - Ok(_) => std::process::exit(0), - Err(e) => { - println!("Error: {}", format_error(e)); - std::process::exit(1); - } - } - } - - // main repl loop - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match rep(&line, &repl_env) { - Ok(out) => println!("{}", out), - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; +use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; +mod env; +mod printer; +mod reader; +use crate::env::{env_bind, env_get, env_new, env_set, env_sets, Env}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval + +fn qq_iter(elts: &MalArgs) -> MalVal { + let mut acc = list![]; + for elt in elts.iter().rev() { + if let List(v, _) = elt { + if v.len() == 2 { + if let Sym(ref s) = v[0] { + if s == "splice-unquote" { + acc = list![Sym("concat".to_string()), v[1].clone(), acc]; + continue; + } + } + } + } + acc = list![Sym("cons".to_string()), quasiquote(&elt), acc]; + } + return acc; +} + +fn quasiquote(ast: &MalVal) -> MalVal { + match ast { + List(v, _) => { + if v.len() == 2 { + if let Sym(ref s) = v[0] { + if s == "unquote" { + return v[1].clone(); + } + } + } + return qq_iter(&v); + }, + Vector(v, _) => return list![Sym("vec".to_string()), qq_iter(&v)], + Hash(_, _) | Sym(_)=> return list![Sym("quote".to_string()), ast.clone()], + _ => ast.clone(), + } +} + +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(list!(lst)) + } + Vector(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(vector!(lst)) + } + Hash(hm, _) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k, v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) + } + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + ret = match ast.clone() { + List(l, _) => { + if l.len() == 0 { + return Ok(ast); + } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + } + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds, _) | Vector(ref binds, _) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set( + &env, + b.clone(), + eval(e.clone(), env.clone())?, + ); + } + _ => { + return error("let* with non-Sym binding"); + } + } + } + } + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + } + Sym(ref a0sym) if a0sym == "quote" => Ok(l[1].clone()), + Sym(ref a0sym) if a0sym == "quasiquoteexpand" => Ok(quasiquote(&l[1])), + Sym(ref a0sym) if a0sym == "quasiquote" => { + ast = quasiquote(&l[1]); + continue 'tco; + } + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { + List(_, _) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + } + _ => error("invalid do form"), + } + } + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + } + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + } + _ => Ok(Nil), + } + } + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc { + eval: eval, + ast: Rc::new(a2), + env: env, + params: Rc::new(a1), + is_macro: false, + meta: Rc::new(Nil), + }) + } + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + } + _ => match eval_ast(&ast, &env)? { + List(ref el, _) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_, _) => f.apply(args), + MalFunc { + ast: mast, + env: menv, + params, + .. + } => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + } + _ => error("attempt to call non-function"), + } + } + _ => error("expected a list"), + }, + } + } + _ => eval_ast(&ast, &env), + }; + + break; + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep( + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", + &repl_env, + ); + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")", f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/step8_macros.rs b/impls/rust/step8_macros.rs index 8808f0e155..138bb89afa 100644 --- a/impls/rust/step8_macros.rs +++ b/impls/rust/step8_macros.rs @@ -1,363 +1,363 @@ -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; -use itertools::Itertools; - -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -mod types; -use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; -use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; -mod env; -mod printer; -mod reader; -use crate::env::{env_bind, env_find, env_get, env_new, env_set, env_sets, Env}; -#[macro_use] -mod core; - -// read -fn read(str: &str) -> MalRet { - reader::read_str(str.to_string()) -} - -// eval - -fn qq_iter(elts: &MalArgs) -> MalVal { - let mut acc = list![]; - for elt in elts.iter().rev() { - if let List(v, _) = elt { - if v.len() == 2 { - if let Sym(ref s) = v[0] { - if s == "splice-unquote" { - acc = list![Sym("concat".to_string()), v[1].clone(), acc]; - continue; - } - } - } - } - acc = list![Sym("cons".to_string()), quasiquote(&elt), acc]; - } - return acc; -} - -fn quasiquote(ast: &MalVal) -> MalVal { - match ast { - List(v, _) => { - if v.len() == 2 { - if let Sym(ref s) = v[0] { - if s == "unquote" { - return v[1].clone(); - } - } - } - return qq_iter(&v); - }, - Vector(v, _) => return list![Sym("vec".to_string()), qq_iter(&v)], - Hash(_, _) | Sym(_)=> return list![Sym("quote".to_string()), ast.clone()], - _ => ast.clone(), - } -} - -fn is_macro_call(ast: &MalVal, env: &Env) -> Option<(MalVal, MalArgs)> { - match ast { - List(v, _) => match v[0] { - Sym(ref s) => match env_find(env, s) { - Some(e) => match env_get(&e, &v[0]) { - Ok(f @ MalFunc { is_macro: true, .. }) => Some((f, v[1..].to_vec())), - _ => None, - }, - _ => None, - }, - _ => None, - }, - _ => None, - } -} - -fn macroexpand(mut ast: MalVal, env: &Env) -> (bool, MalRet) { - let mut was_expanded = false; - while let Some((mf, args)) = is_macro_call(&ast, env) { - //println!("macroexpand 1: {:?}", ast); - ast = match mf.apply(args) { - Err(e) => return (false, Err(e)), - Ok(a) => a, - }; - //println!("macroexpand 2: {:?}", ast); - was_expanded = true; - } - ((was_expanded, Ok(ast))) -} - -fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { - match ast { - Sym(_) => Ok(env_get(&env, &ast)?), - List(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(list!(lst)) - } - Vector(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(vector!(lst)) - } - Hash(hm, _) => { - let mut new_hm: FnvHashMap = FnvHashMap::default(); - for (k, v) in hm.iter() { - new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); - } - Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - let ret: MalRet; - - 'tco: loop { - ret = match ast.clone() { - List(l, _) => { - if l.len() == 0 { - return Ok(ast); - } - match macroexpand(ast.clone(), &env) { - (true, Ok(new_ast)) => { - ast = new_ast; - continue 'tco; - } - (_, Err(e)) => return Err(e), - _ => (), - } - - if l.len() == 0 { - return Ok(ast); - } - let a0 = &l[0]; - match a0 { - Sym(ref a0sym) if a0sym == "def!" => { - env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) - } - Sym(ref a0sym) if a0sym == "let*" => { - env = env_new(Some(env.clone())); - let (a1, a2) = (l[1].clone(), l[2].clone()); - match a1 { - List(ref binds, _) | Vector(ref binds, _) => { - for (b, e) in binds.iter().tuples() { - match b { - Sym(_) => { - let _ = env_set( - &env, - b.clone(), - eval(e.clone(), env.clone())?, - ); - } - _ => { - return error("let* with non-Sym binding"); - } - } - } - } - _ => { - return error("let* with non-List bindings"); - } - }; - ast = a2; - continue 'tco; - } - Sym(ref a0sym) if a0sym == "quote" => Ok(l[1].clone()), - Sym(ref a0sym) if a0sym == "quasiquoteexpand" => Ok(quasiquote(&l[1])), - Sym(ref a0sym) if a0sym == "quasiquote" => { - ast = quasiquote(&l[1]); - continue 'tco; - } - Sym(ref a0sym) if a0sym == "defmacro!" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - let r = eval(a2, env.clone())?; - match r { - MalFunc { - eval, - ast, - env, - params, - .. - } => Ok(env_set( - &env, - a1.clone(), - MalFunc { - eval: eval, - ast: ast.clone(), - env: env.clone(), - params: params.clone(), - is_macro: true, - meta: Rc::new(Nil), - }, - )?), - _ => error("set_macro on non-function"), - } - } - Sym(ref a0sym) if a0sym == "macroexpand" => { - match macroexpand(l[1].clone(), &env) { - (_, Ok(new_ast)) => Ok(new_ast), - (_, e) => return e, - } - } - Sym(ref a0sym) if a0sym == "do" => { - match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { - List(_, _) => { - ast = l.last().unwrap_or(&Nil).clone(); - continue 'tco; - } - _ => error("invalid do form"), - } - } - Sym(ref a0sym) if a0sym == "if" => { - let cond = eval(l[1].clone(), env.clone())?; - match cond { - Bool(false) | Nil if l.len() >= 4 => { - ast = l[3].clone(); - continue 'tco; - } - Bool(false) | Nil => Ok(Nil), - _ if l.len() >= 3 => { - ast = l[2].clone(); - continue 'tco; - } - _ => Ok(Nil), - } - } - Sym(ref a0sym) if a0sym == "fn*" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - Ok(MalFunc { - eval: eval, - ast: Rc::new(a2), - env: env, - params: Rc::new(a1), - is_macro: false, - meta: Rc::new(Nil), - }) - } - Sym(ref a0sym) if a0sym == "eval" => { - ast = eval(l[1].clone(), env.clone())?; - while let Some(ref e) = env.clone().outer { - env = e.clone(); - } - continue 'tco; - } - _ => match eval_ast(&ast, &env)? { - List(ref el, _) => { - let ref f = el[0].clone(); - let args = el[1..].to_vec(); - match f { - Func(_, _) => f.apply(args), - MalFunc { - ast: mast, - env: menv, - params, - .. - } => { - let a = &**mast; - let p = &**params; - env = env_bind(Some(menv.clone()), p.clone(), args)?; - ast = a.clone(); - continue 'tco; - } - _ => error("attempt to call non-function"), - } - } - _ => error("expected a list"), - }, - } - } - _ => eval_ast(&ast, &env), - }; - - break; - } // end 'tco loop - - ret -} - -// print -fn print(ast: &MalVal) -> String { - ast.pr_str(true) -} - -fn rep(str: &str, env: &Env) -> Result { - let ast = read(str)?; - let exp = eval(ast, env.clone())?; - Ok(print(&exp)) -} - -fn main() { - let mut args = std::env::args(); - let arg1 = args.nth(1); - - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns() { - env_sets(&repl_env, k, v); - } - env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); - let _ = rep( - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", - &repl_env, - ); - let _ = 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)))))))", &repl_env); - - // Invoked with arguments - if let Some(f) = arg1 { - match rep(&format!("(load-file \"{}\")", f), &repl_env) { - Ok(_) => std::process::exit(0), - Err(e) => { - println!("Error: {}", format_error(e)); - std::process::exit(1); - } - } - } - - // main repl loop - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match rep(&line, &repl_env) { - Ok(out) => println!("{}", out), - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; +use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; +mod env; +mod printer; +mod reader; +use crate::env::{env_bind, env_find, env_get, env_new, env_set, env_sets, Env}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval + +fn qq_iter(elts: &MalArgs) -> MalVal { + let mut acc = list![]; + for elt in elts.iter().rev() { + if let List(v, _) = elt { + if v.len() == 2 { + if let Sym(ref s) = v[0] { + if s == "splice-unquote" { + acc = list![Sym("concat".to_string()), v[1].clone(), acc]; + continue; + } + } + } + } + acc = list![Sym("cons".to_string()), quasiquote(&elt), acc]; + } + return acc; +} + +fn quasiquote(ast: &MalVal) -> MalVal { + match ast { + List(v, _) => { + if v.len() == 2 { + if let Sym(ref s) = v[0] { + if s == "unquote" { + return v[1].clone(); + } + } + } + return qq_iter(&v); + }, + Vector(v, _) => return list![Sym("vec".to_string()), qq_iter(&v)], + Hash(_, _) | Sym(_)=> return list![Sym("quote".to_string()), ast.clone()], + _ => ast.clone(), + } +} + +fn is_macro_call(ast: &MalVal, env: &Env) -> Option<(MalVal, MalArgs)> { + match ast { + List(v, _) => match v[0] { + Sym(ref s) => match env_find(env, s) { + Some(e) => match env_get(&e, &v[0]) { + Ok(f @ MalFunc { is_macro: true, .. }) => Some((f, v[1..].to_vec())), + _ => None, + }, + _ => None, + }, + _ => None, + }, + _ => None, + } +} + +fn macroexpand(mut ast: MalVal, env: &Env) -> (bool, MalRet) { + let mut was_expanded = false; + while let Some((mf, args)) = is_macro_call(&ast, env) { + //println!("macroexpand 1: {:?}", ast); + ast = match mf.apply(args) { + Err(e) => return (false, Err(e)), + Ok(a) => a, + }; + //println!("macroexpand 2: {:?}", ast); + was_expanded = true; + } + ((was_expanded, Ok(ast))) +} + +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(list!(lst)) + } + Vector(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(vector!(lst)) + } + Hash(hm, _) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k, v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) + } + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + ret = match ast.clone() { + List(l, _) => { + if l.len() == 0 { + return Ok(ast); + } + match macroexpand(ast.clone(), &env) { + (true, Ok(new_ast)) => { + ast = new_ast; + continue 'tco; + } + (_, Err(e)) => return Err(e), + _ => (), + } + + if l.len() == 0 { + return Ok(ast); + } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + } + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds, _) | Vector(ref binds, _) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set( + &env, + b.clone(), + eval(e.clone(), env.clone())?, + ); + } + _ => { + return error("let* with non-Sym binding"); + } + } + } + } + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + } + Sym(ref a0sym) if a0sym == "quote" => Ok(l[1].clone()), + Sym(ref a0sym) if a0sym == "quasiquoteexpand" => Ok(quasiquote(&l[1])), + Sym(ref a0sym) if a0sym == "quasiquote" => { + ast = quasiquote(&l[1]); + continue 'tco; + } + Sym(ref a0sym) if a0sym == "defmacro!" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + let r = eval(a2, env.clone())?; + match r { + MalFunc { + eval, + ast, + env, + params, + .. + } => Ok(env_set( + &env, + a1.clone(), + MalFunc { + eval: eval, + ast: ast.clone(), + env: env.clone(), + params: params.clone(), + is_macro: true, + meta: Rc::new(Nil), + }, + )?), + _ => error("set_macro on non-function"), + } + } + Sym(ref a0sym) if a0sym == "macroexpand" => { + match macroexpand(l[1].clone(), &env) { + (_, Ok(new_ast)) => Ok(new_ast), + (_, e) => return e, + } + } + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { + List(_, _) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + } + _ => error("invalid do form"), + } + } + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + } + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + } + _ => Ok(Nil), + } + } + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc { + eval: eval, + ast: Rc::new(a2), + env: env, + params: Rc::new(a1), + is_macro: false, + meta: Rc::new(Nil), + }) + } + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + } + _ => match eval_ast(&ast, &env)? { + List(ref el, _) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_, _) => f.apply(args), + MalFunc { + ast: mast, + env: menv, + params, + .. + } => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + } + _ => error("attempt to call non-function"), + } + } + _ => error("expected a list"), + }, + } + } + _ => eval_ast(&ast, &env), + }; + + break; + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep( + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", + &repl_env, + ); + let _ = 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)))))))", &repl_env); + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")", f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/step9_try.rs b/impls/rust/step9_try.rs index 63b908224c..f5a5de26cf 100644 --- a/impls/rust/step9_try.rs +++ b/impls/rust/step9_try.rs @@ -1,384 +1,384 @@ -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; -use itertools::Itertools; - -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -mod types; -use crate::types::MalErr::{ErrMalVal, ErrString}; -use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; -use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; -mod env; -mod printer; -mod reader; -use crate::env::{env_bind, env_find, env_get, env_new, env_set, env_sets, Env}; -#[macro_use] -mod core; - -// read -fn read(str: &str) -> MalRet { - reader::read_str(str.to_string()) -} - -// eval - -fn qq_iter(elts: &MalArgs) -> MalVal { - let mut acc = list![]; - for elt in elts.iter().rev() { - if let List(v, _) = elt { - if v.len() == 2 { - if let Sym(ref s) = v[0] { - if s == "splice-unquote" { - acc = list![Sym("concat".to_string()), v[1].clone(), acc]; - continue; - } - } - } - } - acc = list![Sym("cons".to_string()), quasiquote(&elt), acc]; - } - return acc; -} - -fn quasiquote(ast: &MalVal) -> MalVal { - match ast { - List(v, _) => { - if v.len() == 2 { - if let Sym(ref s) = v[0] { - if s == "unquote" { - return v[1].clone(); - } - } - } - return qq_iter(&v); - }, - Vector(v, _) => return list![Sym("vec".to_string()), qq_iter(&v)], - Hash(_, _) | Sym(_)=> return list![Sym("quote".to_string()), ast.clone()], - _ => ast.clone(), - } -} - -fn is_macro_call(ast: &MalVal, env: &Env) -> Option<(MalVal, MalArgs)> { - match ast { - List(v, _) => match v[0] { - Sym(ref s) => match env_find(env, s) { - Some(e) => match env_get(&e, &v[0]) { - Ok(f @ MalFunc { is_macro: true, .. }) => Some((f, v[1..].to_vec())), - _ => None, - }, - _ => None, - }, - _ => None, - }, - _ => None, - } -} - -fn macroexpand(mut ast: MalVal, env: &Env) -> (bool, MalRet) { - let mut was_expanded = false; - while let Some((mf, args)) = is_macro_call(&ast, env) { - //println!("macroexpand 1: {:?}", ast); - ast = match mf.apply(args) { - Err(e) => return (false, Err(e)), - Ok(a) => a, - }; - //println!("macroexpand 2: {:?}", ast); - was_expanded = true; - } - ((was_expanded, Ok(ast))) -} - -fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { - match ast { - Sym(_) => Ok(env_get(&env, &ast)?), - List(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(list!(lst)) - } - Vector(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(vector!(lst)) - } - Hash(hm, _) => { - let mut new_hm: FnvHashMap = FnvHashMap::default(); - for (k, v) in hm.iter() { - new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); - } - Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - let ret: MalRet; - - 'tco: loop { - ret = match ast.clone() { - List(l, _) => { - if l.len() == 0 { - return Ok(ast); - } - match macroexpand(ast.clone(), &env) { - (true, Ok(new_ast)) => { - ast = new_ast; - continue 'tco; - } - (_, Err(e)) => return Err(e), - _ => (), - } - - if l.len() == 0 { - return Ok(ast); - } - let a0 = &l[0]; - match a0 { - Sym(ref a0sym) if a0sym == "def!" => { - env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) - } - Sym(ref a0sym) if a0sym == "let*" => { - env = env_new(Some(env.clone())); - let (a1, a2) = (l[1].clone(), l[2].clone()); - match a1 { - List(ref binds, _) | Vector(ref binds, _) => { - for (b, e) in binds.iter().tuples() { - match b { - Sym(_) => { - let _ = env_set( - &env, - b.clone(), - eval(e.clone(), env.clone())?, - ); - } - _ => { - return error("let* with non-Sym binding"); - } - } - } - } - _ => { - return error("let* with non-List bindings"); - } - }; - ast = a2; - continue 'tco; - } - Sym(ref a0sym) if a0sym == "quote" => Ok(l[1].clone()), - Sym(ref a0sym) if a0sym == "quasiquoteexpand" => Ok(quasiquote(&l[1])), - Sym(ref a0sym) if a0sym == "quasiquote" => { - ast = quasiquote(&l[1]); - continue 'tco; - } - Sym(ref a0sym) if a0sym == "defmacro!" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - let r = eval(a2, env.clone())?; - match r { - MalFunc { - eval, - ast, - env, - params, - .. - } => Ok(env_set( - &env, - a1.clone(), - MalFunc { - eval: eval, - ast: ast.clone(), - env: env.clone(), - params: params.clone(), - is_macro: true, - meta: Rc::new(Nil), - }, - )?), - _ => error("set_macro on non-function"), - } - } - Sym(ref a0sym) if a0sym == "macroexpand" => { - match macroexpand(l[1].clone(), &env) { - (_, Ok(new_ast)) => Ok(new_ast), - (_, e) => return e, - } - } - Sym(ref a0sym) if a0sym == "try*" => match eval(l[1].clone(), env.clone()) { - Err(ref e) if l.len() >= 3 => { - let exc = match e { - ErrMalVal(mv) => mv.clone(), - ErrString(s) => Str(s.to_string()), - }; - match l[2].clone() { - List(c, _) => { - let catch_env = env_bind( - Some(env.clone()), - list!(vec![c[1].clone()]), - vec![exc], - )?; - eval(c[2].clone(), catch_env) - } - _ => error("invalid catch block"), - } - } - res => res, - }, - Sym(ref a0sym) if a0sym == "do" => { - match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { - List(_, _) => { - ast = l.last().unwrap_or(&Nil).clone(); - continue 'tco; - } - _ => error("invalid do form"), - } - } - Sym(ref a0sym) if a0sym == "if" => { - let cond = eval(l[1].clone(), env.clone())?; - match cond { - Bool(false) | Nil if l.len() >= 4 => { - ast = l[3].clone(); - continue 'tco; - } - Bool(false) | Nil => Ok(Nil), - _ if l.len() >= 3 => { - ast = l[2].clone(); - continue 'tco; - } - _ => Ok(Nil), - } - } - Sym(ref a0sym) if a0sym == "fn*" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - Ok(MalFunc { - eval: eval, - ast: Rc::new(a2), - env: env, - params: Rc::new(a1), - is_macro: false, - meta: Rc::new(Nil), - }) - } - Sym(ref a0sym) if a0sym == "eval" => { - ast = eval(l[1].clone(), env.clone())?; - while let Some(ref e) = env.clone().outer { - env = e.clone(); - } - continue 'tco; - } - _ => match eval_ast(&ast, &env)? { - List(ref el, _) => { - let ref f = el[0].clone(); - let args = el[1..].to_vec(); - match f { - Func(_, _) => f.apply(args), - MalFunc { - ast: mast, - env: menv, - params, - .. - } => { - let a = &**mast; - let p = &**params; - env = env_bind(Some(menv.clone()), p.clone(), args)?; - ast = a.clone(); - continue 'tco; - } - _ => error("attempt to call non-function"), - } - } - _ => error("expected a list"), - }, - } - } - _ => eval_ast(&ast, &env), - }; - - break; - } // end 'tco loop - - ret -} - -// print -fn print(ast: &MalVal) -> String { - ast.pr_str(true) -} - -fn rep(str: &str, env: &Env) -> Result { - let ast = read(str)?; - let exp = eval(ast, env.clone())?; - Ok(print(&exp)) -} - -fn main() { - let mut args = std::env::args(); - let arg1 = args.nth(1); - - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns() { - env_sets(&repl_env, k, v); - } - env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); - - // core.mal: defined using the language itself - let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); - let _ = rep( - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", - &repl_env, - ); - let _ = 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)))))))", &repl_env); - - // Invoked with arguments - if let Some(f) = arg1 { - match rep(&format!("(load-file \"{}\")", f), &repl_env) { - Ok(_) => std::process::exit(0), - Err(e) => { - println!("Error: {}", format_error(e)); - std::process::exit(1); - } - } - } - - // main repl loop - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match rep(&line, &repl_env) { - Ok(out) => println!("{}", out), - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use crate::types::MalErr::{ErrMalVal, ErrString}; +use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; +use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; +mod env; +mod printer; +mod reader; +use crate::env::{env_bind, env_find, env_get, env_new, env_set, env_sets, Env}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval + +fn qq_iter(elts: &MalArgs) -> MalVal { + let mut acc = list![]; + for elt in elts.iter().rev() { + if let List(v, _) = elt { + if v.len() == 2 { + if let Sym(ref s) = v[0] { + if s == "splice-unquote" { + acc = list![Sym("concat".to_string()), v[1].clone(), acc]; + continue; + } + } + } + } + acc = list![Sym("cons".to_string()), quasiquote(&elt), acc]; + } + return acc; +} + +fn quasiquote(ast: &MalVal) -> MalVal { + match ast { + List(v, _) => { + if v.len() == 2 { + if let Sym(ref s) = v[0] { + if s == "unquote" { + return v[1].clone(); + } + } + } + return qq_iter(&v); + }, + Vector(v, _) => return list![Sym("vec".to_string()), qq_iter(&v)], + Hash(_, _) | Sym(_)=> return list![Sym("quote".to_string()), ast.clone()], + _ => ast.clone(), + } +} + +fn is_macro_call(ast: &MalVal, env: &Env) -> Option<(MalVal, MalArgs)> { + match ast { + List(v, _) => match v[0] { + Sym(ref s) => match env_find(env, s) { + Some(e) => match env_get(&e, &v[0]) { + Ok(f @ MalFunc { is_macro: true, .. }) => Some((f, v[1..].to_vec())), + _ => None, + }, + _ => None, + }, + _ => None, + }, + _ => None, + } +} + +fn macroexpand(mut ast: MalVal, env: &Env) -> (bool, MalRet) { + let mut was_expanded = false; + while let Some((mf, args)) = is_macro_call(&ast, env) { + //println!("macroexpand 1: {:?}", ast); + ast = match mf.apply(args) { + Err(e) => return (false, Err(e)), + Ok(a) => a, + }; + //println!("macroexpand 2: {:?}", ast); + was_expanded = true; + } + ((was_expanded, Ok(ast))) +} + +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(list!(lst)) + } + Vector(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(vector!(lst)) + } + Hash(hm, _) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k, v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) + } + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + ret = match ast.clone() { + List(l, _) => { + if l.len() == 0 { + return Ok(ast); + } + match macroexpand(ast.clone(), &env) { + (true, Ok(new_ast)) => { + ast = new_ast; + continue 'tco; + } + (_, Err(e)) => return Err(e), + _ => (), + } + + if l.len() == 0 { + return Ok(ast); + } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + } + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds, _) | Vector(ref binds, _) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set( + &env, + b.clone(), + eval(e.clone(), env.clone())?, + ); + } + _ => { + return error("let* with non-Sym binding"); + } + } + } + } + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + } + Sym(ref a0sym) if a0sym == "quote" => Ok(l[1].clone()), + Sym(ref a0sym) if a0sym == "quasiquoteexpand" => Ok(quasiquote(&l[1])), + Sym(ref a0sym) if a0sym == "quasiquote" => { + ast = quasiquote(&l[1]); + continue 'tco; + } + Sym(ref a0sym) if a0sym == "defmacro!" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + let r = eval(a2, env.clone())?; + match r { + MalFunc { + eval, + ast, + env, + params, + .. + } => Ok(env_set( + &env, + a1.clone(), + MalFunc { + eval: eval, + ast: ast.clone(), + env: env.clone(), + params: params.clone(), + is_macro: true, + meta: Rc::new(Nil), + }, + )?), + _ => error("set_macro on non-function"), + } + } + Sym(ref a0sym) if a0sym == "macroexpand" => { + match macroexpand(l[1].clone(), &env) { + (_, Ok(new_ast)) => Ok(new_ast), + (_, e) => return e, + } + } + Sym(ref a0sym) if a0sym == "try*" => match eval(l[1].clone(), env.clone()) { + Err(ref e) if l.len() >= 3 => { + let exc = match e { + ErrMalVal(mv) => mv.clone(), + ErrString(s) => Str(s.to_string()), + }; + match l[2].clone() { + List(c, _) => { + let catch_env = env_bind( + Some(env.clone()), + list!(vec![c[1].clone()]), + vec![exc], + )?; + eval(c[2].clone(), catch_env) + } + _ => error("invalid catch block"), + } + } + res => res, + }, + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { + List(_, _) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + } + _ => error("invalid do form"), + } + } + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + } + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + } + _ => Ok(Nil), + } + } + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc { + eval: eval, + ast: Rc::new(a2), + env: env, + params: Rc::new(a1), + is_macro: false, + meta: Rc::new(Nil), + }) + } + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + } + _ => match eval_ast(&ast, &env)? { + List(ref el, _) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_, _) => f.apply(args), + MalFunc { + ast: mast, + env: menv, + params, + .. + } => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + } + _ => error("attempt to call non-function"), + } + } + _ => error("expected a list"), + }, + } + } + _ => eval_ast(&ast, &env), + }; + + break; + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep( + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", + &repl_env, + ); + let _ = 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)))))))", &repl_env); + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")", f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/stepA_mal.rs b/impls/rust/stepA_mal.rs index 6b86d6b5b2..52d1acbb15 100644 --- a/impls/rust/stepA_mal.rs +++ b/impls/rust/stepA_mal.rs @@ -1,388 +1,388 @@ -#![allow(non_snake_case)] - -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; -use itertools::Itertools; - -#[macro_use] -extern crate lazy_static; -extern crate fnv; -extern crate itertools; -extern crate regex; - -extern crate rustyline; -use rustyline::error::ReadlineError; -use rustyline::Editor; - -#[macro_use] -mod types; -use crate::types::MalErr::{ErrMalVal, ErrString}; -use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; -use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; -mod env; -mod printer; -mod reader; -use crate::env::{env_bind, env_find, env_get, env_new, env_set, env_sets, Env}; -#[macro_use] -mod core; - -// read -fn read(str: &str) -> MalRet { - reader::read_str(str.to_string()) -} - -// eval - -fn qq_iter(elts: &MalArgs) -> MalVal { - let mut acc = list![]; - for elt in elts.iter().rev() { - if let List(v, _) = elt { - if v.len() == 2 { - if let Sym(ref s) = v[0] { - if s == "splice-unquote" { - acc = list![Sym("concat".to_string()), v[1].clone(), acc]; - continue; - } - } - } - } - acc = list![Sym("cons".to_string()), quasiquote(&elt), acc]; - } - return acc; -} - -fn quasiquote(ast: &MalVal) -> MalVal { - match ast { - List(v, _) => { - if v.len() == 2 { - if let Sym(ref s) = v[0] { - if s == "unquote" { - return v[1].clone(); - } - } - } - return qq_iter(&v); - }, - Vector(v, _) => return list![Sym("vec".to_string()), qq_iter(&v)], - Hash(_, _) | Sym(_)=> return list![Sym("quote".to_string()), ast.clone()], - _ => ast.clone(), - } -} - -fn is_macro_call(ast: &MalVal, env: &Env) -> Option<(MalVal, MalArgs)> { - match ast { - List(v, _) => match v[0] { - Sym(ref s) => match env_find(env, s) { - Some(e) => match env_get(&e, &v[0]) { - Ok(f @ MalFunc { is_macro: true, .. }) => Some((f, v[1..].to_vec())), - _ => None, - }, - _ => None, - }, - _ => None, - }, - _ => None, - } -} - -fn macroexpand(mut ast: MalVal, env: &Env) -> (bool, MalRet) { - let mut was_expanded = false; - while let Some((mf, args)) = is_macro_call(&ast, env) { - //println!("macroexpand 1: {:?}", ast); - ast = match mf.apply(args) { - Err(e) => return (false, Err(e)), - Ok(a) => a, - }; - //println!("macroexpand 2: {:?}", ast); - was_expanded = true; - } - ((was_expanded, Ok(ast))) -} - -fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { - match ast { - Sym(_) => Ok(env_get(&env, &ast)?), - List(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(list!(lst)) - } - Vector(v, _) => { - let mut lst: MalArgs = vec![]; - for a in v.iter() { - lst.push(eval(a.clone(), env.clone())?) - } - Ok(vector!(lst)) - } - Hash(hm, _) => { - let mut new_hm: FnvHashMap = FnvHashMap::default(); - for (k, v) in hm.iter() { - new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); - } - Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) - } - _ => Ok(ast.clone()), - } -} - -fn eval(mut ast: MalVal, mut env: Env) -> MalRet { - let ret: MalRet; - - 'tco: loop { - ret = match ast.clone() { - List(l, _) => { - if l.len() == 0 { - return Ok(ast); - } - match macroexpand(ast.clone(), &env) { - (true, Ok(new_ast)) => { - ast = new_ast; - continue 'tco; - } - (_, Err(e)) => return Err(e), - _ => (), - } - - if l.len() == 0 { - return Ok(ast); - } - let a0 = &l[0]; - match a0 { - Sym(ref a0sym) if a0sym == "def!" => { - env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) - } - Sym(ref a0sym) if a0sym == "let*" => { - env = env_new(Some(env.clone())); - let (a1, a2) = (l[1].clone(), l[2].clone()); - match a1 { - List(ref binds, _) | Vector(ref binds, _) => { - for (b, e) in binds.iter().tuples() { - match b { - Sym(_) => { - let _ = env_set( - &env, - b.clone(), - eval(e.clone(), env.clone())?, - ); - } - _ => { - return error("let* with non-Sym binding"); - } - } - } - } - _ => { - return error("let* with non-List bindings"); - } - }; - ast = a2; - continue 'tco; - } - Sym(ref a0sym) if a0sym == "quote" => Ok(l[1].clone()), - Sym(ref a0sym) if a0sym == "quasiquoteexpand" => Ok(quasiquote(&l[1])), - Sym(ref a0sym) if a0sym == "quasiquote" => { - ast = quasiquote(&l[1]); - continue 'tco; - } - Sym(ref a0sym) if a0sym == "defmacro!" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - let r = eval(a2, env.clone())?; - match r { - MalFunc { - eval, - ast, - env, - params, - .. - } => Ok(env_set( - &env, - a1.clone(), - MalFunc { - eval: eval, - ast: ast.clone(), - env: env.clone(), - params: params.clone(), - is_macro: true, - meta: Rc::new(Nil), - }, - )?), - _ => error("set_macro on non-function"), - } - } - Sym(ref a0sym) if a0sym == "macroexpand" => { - match macroexpand(l[1].clone(), &env) { - (_, Ok(new_ast)) => Ok(new_ast), - (_, e) => return e, - } - } - Sym(ref a0sym) if a0sym == "try*" => match eval(l[1].clone(), env.clone()) { - Err(ref e) if l.len() >= 3 => { - let exc = match e { - ErrMalVal(mv) => mv.clone(), - ErrString(s) => Str(s.to_string()), - }; - match l[2].clone() { - List(c, _) => { - let catch_env = env_bind( - Some(env.clone()), - list!(vec![c[1].clone()]), - vec![exc], - )?; - eval(c[2].clone(), catch_env) - } - _ => error("invalid catch block"), - } - } - res => res, - }, - Sym(ref a0sym) if a0sym == "do" => { - match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { - List(_, _) => { - ast = l.last().unwrap_or(&Nil).clone(); - continue 'tco; - } - _ => error("invalid do form"), - } - } - Sym(ref a0sym) if a0sym == "if" => { - let cond = eval(l[1].clone(), env.clone())?; - match cond { - Bool(false) | Nil if l.len() >= 4 => { - ast = l[3].clone(); - continue 'tco; - } - Bool(false) | Nil => Ok(Nil), - _ if l.len() >= 3 => { - ast = l[2].clone(); - continue 'tco; - } - _ => Ok(Nil), - } - } - Sym(ref a0sym) if a0sym == "fn*" => { - let (a1, a2) = (l[1].clone(), l[2].clone()); - Ok(MalFunc { - eval: eval, - ast: Rc::new(a2), - env: env, - params: Rc::new(a1), - is_macro: false, - meta: Rc::new(Nil), - }) - } - Sym(ref a0sym) if a0sym == "eval" => { - ast = eval(l[1].clone(), env.clone())?; - while let Some(ref e) = env.clone().outer { - env = e.clone(); - } - continue 'tco; - } - _ => match eval_ast(&ast, &env)? { - List(ref el, _) => { - let ref f = el[0].clone(); - let args = el[1..].to_vec(); - match f { - Func(_, _) => f.apply(args), - MalFunc { - ast: mast, - env: menv, - params, - .. - } => { - let a = &**mast; - let p = &**params; - env = env_bind(Some(menv.clone()), p.clone(), args)?; - ast = a.clone(); - continue 'tco; - } - _ => error("attempt to call non-function"), - } - } - _ => error("expected a list"), - }, - } - } - _ => eval_ast(&ast, &env), - }; - - break; - } // end 'tco loop - - ret -} - -// print -fn print(ast: &MalVal) -> String { - ast.pr_str(true) -} - -fn rep(str: &str, env: &Env) -> Result { - let ast = read(str)?; - let exp = eval(ast, env.clone())?; - Ok(print(&exp)) -} - -fn main() { - let mut args = std::env::args(); - let arg1 = args.nth(1); - - // `()` can be used when no completer is required - let mut rl = Editor::<()>::new(); - if rl.load_history(".mal-history").is_err() { - eprintln!("No previous history."); - } - - // core.rs: defined using rust - let repl_env = env_new(None); - for (k, v) in core::ns() { - env_sets(&repl_env, k, v); - } - env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); - - // core.mal: defined using the language itself - let _ = rep("(def! *host-language* \"rust\")", &repl_env); - let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); - let _ = rep( - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", - &repl_env, - ); - let _ = 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)))))))", &repl_env); - - // Invoked with arguments - if let Some(f) = arg1 { - match rep(&format!("(load-file \"{}\")", f), &repl_env) { - Ok(_) => std::process::exit(0), - Err(e) => { - println!("Error: {}", format_error(e)); - std::process::exit(1); - } - } - } - - // main repl loop - let _ = rep("(println (str \"Mal [\" *host-language* \"]\"))", &repl_env); - loop { - let readline = rl.readline("user> "); - match readline { - Ok(line) => { - rl.add_history_entry(&line); - rl.save_history(".mal-history").unwrap(); - if line.len() > 0 { - match rep(&line, &repl_env) { - Ok(out) => println!("{}", out), - Err(e) => println!("Error: {}", format_error(e)), - } - } - } - Err(ReadlineError::Interrupted) => continue, - Err(ReadlineError::Eof) => break, - Err(err) => { - println!("Error: {:?}", err); - break; - } - } - } -} +#![allow(non_snake_case)] + +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +#[macro_use] +extern crate lazy_static; +extern crate fnv; +extern crate itertools; +extern crate regex; + +extern crate rustyline; +use rustyline::error::ReadlineError; +use rustyline::Editor; + +#[macro_use] +mod types; +use crate::types::MalErr::{ErrMalVal, ErrString}; +use crate::types::MalVal::{Bool, Func, Hash, List, MalFunc, Nil, Str, Sym, Vector}; +use crate::types::{error, format_error, MalArgs, MalErr, MalRet, MalVal}; +mod env; +mod printer; +mod reader; +use crate::env::{env_bind, env_find, env_get, env_new, env_set, env_sets, Env}; +#[macro_use] +mod core; + +// read +fn read(str: &str) -> MalRet { + reader::read_str(str.to_string()) +} + +// eval + +fn qq_iter(elts: &MalArgs) -> MalVal { + let mut acc = list![]; + for elt in elts.iter().rev() { + if let List(v, _) = elt { + if v.len() == 2 { + if let Sym(ref s) = v[0] { + if s == "splice-unquote" { + acc = list![Sym("concat".to_string()), v[1].clone(), acc]; + continue; + } + } + } + } + acc = list![Sym("cons".to_string()), quasiquote(&elt), acc]; + } + return acc; +} + +fn quasiquote(ast: &MalVal) -> MalVal { + match ast { + List(v, _) => { + if v.len() == 2 { + if let Sym(ref s) = v[0] { + if s == "unquote" { + return v[1].clone(); + } + } + } + return qq_iter(&v); + }, + Vector(v, _) => return list![Sym("vec".to_string()), qq_iter(&v)], + Hash(_, _) | Sym(_)=> return list![Sym("quote".to_string()), ast.clone()], + _ => ast.clone(), + } +} + +fn is_macro_call(ast: &MalVal, env: &Env) -> Option<(MalVal, MalArgs)> { + match ast { + List(v, _) => match v[0] { + Sym(ref s) => match env_find(env, s) { + Some(e) => match env_get(&e, &v[0]) { + Ok(f @ MalFunc { is_macro: true, .. }) => Some((f, v[1..].to_vec())), + _ => None, + }, + _ => None, + }, + _ => None, + }, + _ => None, + } +} + +fn macroexpand(mut ast: MalVal, env: &Env) -> (bool, MalRet) { + let mut was_expanded = false; + while let Some((mf, args)) = is_macro_call(&ast, env) { + //println!("macroexpand 1: {:?}", ast); + ast = match mf.apply(args) { + Err(e) => return (false, Err(e)), + Ok(a) => a, + }; + //println!("macroexpand 2: {:?}", ast); + was_expanded = true; + } + ((was_expanded, Ok(ast))) +} + +fn eval_ast(ast: &MalVal, env: &Env) -> MalRet { + match ast { + Sym(_) => Ok(env_get(&env, &ast)?), + List(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(list!(lst)) + } + Vector(v, _) => { + let mut lst: MalArgs = vec![]; + for a in v.iter() { + lst.push(eval(a.clone(), env.clone())?) + } + Ok(vector!(lst)) + } + Hash(hm, _) => { + let mut new_hm: FnvHashMap = FnvHashMap::default(); + for (k, v) in hm.iter() { + new_hm.insert(k.to_string(), eval(v.clone(), env.clone())?); + } + Ok(Hash(Rc::new(new_hm), Rc::new(Nil))) + } + _ => Ok(ast.clone()), + } +} + +fn eval(mut ast: MalVal, mut env: Env) -> MalRet { + let ret: MalRet; + + 'tco: loop { + ret = match ast.clone() { + List(l, _) => { + if l.len() == 0 { + return Ok(ast); + } + match macroexpand(ast.clone(), &env) { + (true, Ok(new_ast)) => { + ast = new_ast; + continue 'tco; + } + (_, Err(e)) => return Err(e), + _ => (), + } + + if l.len() == 0 { + return Ok(ast); + } + let a0 = &l[0]; + match a0 { + Sym(ref a0sym) if a0sym == "def!" => { + env_set(&env, l[1].clone(), eval(l[2].clone(), env.clone())?) + } + Sym(ref a0sym) if a0sym == "let*" => { + env = env_new(Some(env.clone())); + let (a1, a2) = (l[1].clone(), l[2].clone()); + match a1 { + List(ref binds, _) | Vector(ref binds, _) => { + for (b, e) in binds.iter().tuples() { + match b { + Sym(_) => { + let _ = env_set( + &env, + b.clone(), + eval(e.clone(), env.clone())?, + ); + } + _ => { + return error("let* with non-Sym binding"); + } + } + } + } + _ => { + return error("let* with non-List bindings"); + } + }; + ast = a2; + continue 'tco; + } + Sym(ref a0sym) if a0sym == "quote" => Ok(l[1].clone()), + Sym(ref a0sym) if a0sym == "quasiquoteexpand" => Ok(quasiquote(&l[1])), + Sym(ref a0sym) if a0sym == "quasiquote" => { + ast = quasiquote(&l[1]); + continue 'tco; + } + Sym(ref a0sym) if a0sym == "defmacro!" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + let r = eval(a2, env.clone())?; + match r { + MalFunc { + eval, + ast, + env, + params, + .. + } => Ok(env_set( + &env, + a1.clone(), + MalFunc { + eval: eval, + ast: ast.clone(), + env: env.clone(), + params: params.clone(), + is_macro: true, + meta: Rc::new(Nil), + }, + )?), + _ => error("set_macro on non-function"), + } + } + Sym(ref a0sym) if a0sym == "macroexpand" => { + match macroexpand(l[1].clone(), &env) { + (_, Ok(new_ast)) => Ok(new_ast), + (_, e) => return e, + } + } + Sym(ref a0sym) if a0sym == "try*" => match eval(l[1].clone(), env.clone()) { + Err(ref e) if l.len() >= 3 => { + let exc = match e { + ErrMalVal(mv) => mv.clone(), + ErrString(s) => Str(s.to_string()), + }; + match l[2].clone() { + List(c, _) => { + let catch_env = env_bind( + Some(env.clone()), + list!(vec![c[1].clone()]), + vec![exc], + )?; + eval(c[2].clone(), catch_env) + } + _ => error("invalid catch block"), + } + } + res => res, + }, + Sym(ref a0sym) if a0sym == "do" => { + match eval_ast(&list!(l[1..l.len() - 1].to_vec()), &env)? { + List(_, _) => { + ast = l.last().unwrap_or(&Nil).clone(); + continue 'tco; + } + _ => error("invalid do form"), + } + } + Sym(ref a0sym) if a0sym == "if" => { + let cond = eval(l[1].clone(), env.clone())?; + match cond { + Bool(false) | Nil if l.len() >= 4 => { + ast = l[3].clone(); + continue 'tco; + } + Bool(false) | Nil => Ok(Nil), + _ if l.len() >= 3 => { + ast = l[2].clone(); + continue 'tco; + } + _ => Ok(Nil), + } + } + Sym(ref a0sym) if a0sym == "fn*" => { + let (a1, a2) = (l[1].clone(), l[2].clone()); + Ok(MalFunc { + eval: eval, + ast: Rc::new(a2), + env: env, + params: Rc::new(a1), + is_macro: false, + meta: Rc::new(Nil), + }) + } + Sym(ref a0sym) if a0sym == "eval" => { + ast = eval(l[1].clone(), env.clone())?; + while let Some(ref e) = env.clone().outer { + env = e.clone(); + } + continue 'tco; + } + _ => match eval_ast(&ast, &env)? { + List(ref el, _) => { + let ref f = el[0].clone(); + let args = el[1..].to_vec(); + match f { + Func(_, _) => f.apply(args), + MalFunc { + ast: mast, + env: menv, + params, + .. + } => { + let a = &**mast; + let p = &**params; + env = env_bind(Some(menv.clone()), p.clone(), args)?; + ast = a.clone(); + continue 'tco; + } + _ => error("attempt to call non-function"), + } + } + _ => error("expected a list"), + }, + } + } + _ => eval_ast(&ast, &env), + }; + + break; + } // end 'tco loop + + ret +} + +// print +fn print(ast: &MalVal) -> String { + ast.pr_str(true) +} + +fn rep(str: &str, env: &Env) -> Result { + let ast = read(str)?; + let exp = eval(ast, env.clone())?; + Ok(print(&exp)) +} + +fn main() { + let mut args = std::env::args(); + let arg1 = args.nth(1); + + // `()` can be used when no completer is required + let mut rl = Editor::<()>::new(); + if rl.load_history(".mal-history").is_err() { + eprintln!("No previous history."); + } + + // core.rs: defined using rust + let repl_env = env_new(None); + for (k, v) in core::ns() { + env_sets(&repl_env, k, v); + } + env_sets(&repl_env, "*ARGV*", list!(args.map(Str).collect())); + + // core.mal: defined using the language itself + let _ = rep("(def! *host-language* \"rust\")", &repl_env); + let _ = rep("(def! not (fn* (a) (if a false true)))", &repl_env); + let _ = rep( + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", + &repl_env, + ); + let _ = 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)))))))", &repl_env); + + // Invoked with arguments + if let Some(f) = arg1 { + match rep(&format!("(load-file \"{}\")", f), &repl_env) { + Ok(_) => std::process::exit(0), + Err(e) => { + println!("Error: {}", format_error(e)); + std::process::exit(1); + } + } + } + + // main repl loop + let _ = rep("(println (str \"Mal [\" *host-language* \"]\"))", &repl_env); + loop { + let readline = rl.readline("user> "); + match readline { + Ok(line) => { + rl.add_history_entry(&line); + rl.save_history(".mal-history").unwrap(); + if line.len() > 0 { + match rep(&line, &repl_env) { + Ok(out) => println!("{}", out), + Err(e) => println!("Error: {}", format_error(e)), + } + } + } + Err(ReadlineError::Interrupted) => continue, + Err(ReadlineError::Eof) => break, + Err(err) => { + println!("Error: {:?}", err); + break; + } + } + } +} diff --git a/impls/rust/types.rs b/impls/rust/types.rs index 108a646cfd..245a72e518 100644 --- a/impls/rust/types.rs +++ b/impls/rust/types.rs @@ -1,240 +1,240 @@ -use std::cell::RefCell; -use std::rc::Rc; -//use std::collections::HashMap; -use fnv::FnvHashMap; -use itertools::Itertools; - -use crate::env::{env_bind, Env}; -use crate::types::MalErr::{ErrMalVal, ErrString}; -use crate::types::MalVal::{Atom, Bool, Func, Hash, Int, List, MalFunc, Nil, Str, Sym, Vector}; - -#[derive(Debug, Clone)] -pub enum MalVal { - Nil, - Bool(bool), - Int(i64), - //Float(f64), - Str(String), - Sym(String), - List(Rc>, Rc), - Vector(Rc>, Rc), - Hash(Rc>, Rc), - Func(fn(MalArgs) -> MalRet, Rc), - MalFunc { - eval: fn(ast: MalVal, env: Env) -> MalRet, - ast: Rc, - env: Env, - params: Rc, - is_macro: bool, - meta: Rc, - }, - Atom(Rc>), -} - -#[derive(Debug)] -pub enum MalErr { - ErrString(String), - ErrMalVal(MalVal), -} - -pub type MalArgs = Vec; -pub type MalRet = Result; - -// type utility macros - -macro_rules! list { - ($seq:expr) => {{ - List(Rc::new($seq),Rc::new(Nil)) - }}; - [$($args:expr),*] => {{ - let v: Vec = vec![$($args),*]; - List(Rc::new(v),Rc::new(Nil)) - }} -} - -macro_rules! vector { - ($seq:expr) => {{ - Vector(Rc::new($seq),Rc::new(Nil)) - }}; - [$($args:expr),*] => {{ - let v: Vec = vec![$($args),*]; - Vector(Rc::new(v),Rc::new(Nil)) - }} -} - -// type utility functions - -pub fn error(s: &str) -> MalRet { - Err(ErrString(s.to_string())) -} - -pub fn format_error(e: MalErr) -> String { - match e { - ErrString(s) => s.clone(), - ErrMalVal(mv) => mv.pr_str(true), - } -} - -pub fn atom(mv: &MalVal) -> MalVal { - Atom(Rc::new(RefCell::new(mv.clone()))) -} - -impl MalVal { - pub fn keyword(&self) -> MalRet { - match self { - Str(s) if s.starts_with("\u{29e}") => Ok(Str(s.to_string())), - Str(s) => Ok(Str(format!("\u{29e}{}", s))), - _ => error("invalid type for keyword"), - } - } - - pub fn empty_q(&self) -> MalRet { - match self { - List(l, _) | Vector(l, _) => Ok(Bool(l.len() == 0)), - Nil => Ok(Bool(true)), - _ => error("invalid type for empty?"), - } - } - - pub fn count(&self) -> MalRet { - match self { - List(l, _) | Vector(l, _) => Ok(Int(l.len() as i64)), - Nil => Ok(Int(0)), - _ => error("invalid type for count"), - } - } - - pub fn apply(&self, args: MalArgs) -> MalRet { - match *self { - Func(f, _) => f(args), - MalFunc { - eval, - ref ast, - ref env, - ref params, - .. - } => { - let a = &**ast; - let p = &**params; - let fn_env = env_bind(Some(env.clone()), p.clone(), args)?; - Ok(eval(a.clone(), fn_env)?) - } - _ => error("attempt to call non-function"), - } - } - - pub fn keyword_q(&self) -> bool { - match self { - Str(s) if s.starts_with("\u{29e}") => true, - _ => false, - } - } - - pub fn deref(&self) -> MalRet { - match self { - Atom(a) => Ok(a.borrow().clone()), - _ => error("attempt to deref a non-Atom"), - } - } - - pub fn reset_bang(&self, new: &MalVal) -> MalRet { - match self { - Atom(a) => { - *a.borrow_mut() = new.clone(); - Ok(new.clone()) - } - _ => error("attempt to reset! a non-Atom"), - } - } - - pub fn swap_bang(&self, args: &MalArgs) -> MalRet { - match self { - Atom(a) => { - let f = &args[0]; - let mut fargs = args[1..].to_vec(); - fargs.insert(0, a.borrow().clone()); - *a.borrow_mut() = f.apply(fargs)?; - Ok(a.borrow().clone()) - } - _ => error("attempt to swap! a non-Atom"), - } - } - - pub fn get_meta(&self) -> MalRet { - match self { - List(_, meta) | Vector(_, meta) | Hash(_, meta) => Ok((&**meta).clone()), - Func(_, meta) => Ok((&**meta).clone()), - MalFunc { meta, .. } => Ok((&**meta).clone()), - _ => error("meta not supported by type"), - } - } - - pub fn with_meta(&mut self, new_meta: &MalVal) -> MalRet { - match self { - List(_, ref mut meta) - | Vector(_, ref mut meta) - | Hash(_, ref mut meta) - | Func(_, ref mut meta) - | MalFunc { ref mut meta, .. } => { - *meta = Rc::new((&*new_meta).clone()); - } - _ => return error("with-meta not supported by type"), - }; - Ok(self.clone()) - } -} - -impl PartialEq for MalVal { - fn eq(&self, other: &MalVal) -> bool { - match (self, other) { - (Nil, Nil) => true, - (Bool(ref a), Bool(ref b)) => a == b, - (Int(ref a), Int(ref b)) => a == b, - (Str(ref a), Str(ref b)) => a == b, - (Sym(ref a), Sym(ref b)) => a == b, - (List(ref a, _), List(ref b, _)) - | (Vector(ref a, _), Vector(ref b, _)) - | (List(ref a, _), Vector(ref b, _)) - | (Vector(ref a, _), List(ref b, _)) => a == b, - (Hash(ref a, _), Hash(ref b, _)) => a == b, - (MalFunc { .. }, MalFunc { .. }) => false, - _ => false, - } - } -} - -pub fn func(f: fn(MalArgs) -> MalRet) -> MalVal { - Func(f, Rc::new(Nil)) -} - -pub fn _assoc(mut hm: FnvHashMap, kvs: MalArgs) -> MalRet { - if kvs.len() % 2 != 0 { - return error("odd number of elements"); - } - for (k, v) in kvs.iter().tuples() { - match k { - Str(s) => { - hm.insert(s.to_string(), v.clone()); - } - _ => return error("key is not string"), - } - } - Ok(Hash(Rc::new(hm), Rc::new(Nil))) -} - -pub fn _dissoc(mut hm: FnvHashMap, ks: MalArgs) -> MalRet { - for k in ks.iter() { - match k { - Str(ref s) => { - hm.remove(s); - } - _ => return error("key is not string"), - } - } - Ok(Hash(Rc::new(hm), Rc::new(Nil))) -} - -pub fn hash_map(kvs: MalArgs) -> MalRet { - let hm: FnvHashMap = FnvHashMap::default(); - _assoc(hm, kvs) -} +use std::cell::RefCell; +use std::rc::Rc; +//use std::collections::HashMap; +use fnv::FnvHashMap; +use itertools::Itertools; + +use crate::env::{env_bind, Env}; +use crate::types::MalErr::{ErrMalVal, ErrString}; +use crate::types::MalVal::{Atom, Bool, Func, Hash, Int, List, MalFunc, Nil, Str, Sym, Vector}; + +#[derive(Debug, Clone)] +pub enum MalVal { + Nil, + Bool(bool), + Int(i64), + //Float(f64), + Str(String), + Sym(String), + List(Rc>, Rc), + Vector(Rc>, Rc), + Hash(Rc>, Rc), + Func(fn(MalArgs) -> MalRet, Rc), + MalFunc { + eval: fn(ast: MalVal, env: Env) -> MalRet, + ast: Rc, + env: Env, + params: Rc, + is_macro: bool, + meta: Rc, + }, + Atom(Rc>), +} + +#[derive(Debug)] +pub enum MalErr { + ErrString(String), + ErrMalVal(MalVal), +} + +pub type MalArgs = Vec; +pub type MalRet = Result; + +// type utility macros + +macro_rules! list { + ($seq:expr) => {{ + List(Rc::new($seq),Rc::new(Nil)) + }}; + [$($args:expr),*] => {{ + let v: Vec = vec![$($args),*]; + List(Rc::new(v),Rc::new(Nil)) + }} +} + +macro_rules! vector { + ($seq:expr) => {{ + Vector(Rc::new($seq),Rc::new(Nil)) + }}; + [$($args:expr),*] => {{ + let v: Vec = vec![$($args),*]; + Vector(Rc::new(v),Rc::new(Nil)) + }} +} + +// type utility functions + +pub fn error(s: &str) -> MalRet { + Err(ErrString(s.to_string())) +} + +pub fn format_error(e: MalErr) -> String { + match e { + ErrString(s) => s.clone(), + ErrMalVal(mv) => mv.pr_str(true), + } +} + +pub fn atom(mv: &MalVal) -> MalVal { + Atom(Rc::new(RefCell::new(mv.clone()))) +} + +impl MalVal { + pub fn keyword(&self) -> MalRet { + match self { + Str(s) if s.starts_with("\u{29e}") => Ok(Str(s.to_string())), + Str(s) => Ok(Str(format!("\u{29e}{}", s))), + _ => error("invalid type for keyword"), + } + } + + pub fn empty_q(&self) -> MalRet { + match self { + List(l, _) | Vector(l, _) => Ok(Bool(l.len() == 0)), + Nil => Ok(Bool(true)), + _ => error("invalid type for empty?"), + } + } + + pub fn count(&self) -> MalRet { + match self { + List(l, _) | Vector(l, _) => Ok(Int(l.len() as i64)), + Nil => Ok(Int(0)), + _ => error("invalid type for count"), + } + } + + pub fn apply(&self, args: MalArgs) -> MalRet { + match *self { + Func(f, _) => f(args), + MalFunc { + eval, + ref ast, + ref env, + ref params, + .. + } => { + let a = &**ast; + let p = &**params; + let fn_env = env_bind(Some(env.clone()), p.clone(), args)?; + Ok(eval(a.clone(), fn_env)?) + } + _ => error("attempt to call non-function"), + } + } + + pub fn keyword_q(&self) -> bool { + match self { + Str(s) if s.starts_with("\u{29e}") => true, + _ => false, + } + } + + pub fn deref(&self) -> MalRet { + match self { + Atom(a) => Ok(a.borrow().clone()), + _ => error("attempt to deref a non-Atom"), + } + } + + pub fn reset_bang(&self, new: &MalVal) -> MalRet { + match self { + Atom(a) => { + *a.borrow_mut() = new.clone(); + Ok(new.clone()) + } + _ => error("attempt to reset! a non-Atom"), + } + } + + pub fn swap_bang(&self, args: &MalArgs) -> MalRet { + match self { + Atom(a) => { + let f = &args[0]; + let mut fargs = args[1..].to_vec(); + fargs.insert(0, a.borrow().clone()); + *a.borrow_mut() = f.apply(fargs)?; + Ok(a.borrow().clone()) + } + _ => error("attempt to swap! a non-Atom"), + } + } + + pub fn get_meta(&self) -> MalRet { + match self { + List(_, meta) | Vector(_, meta) | Hash(_, meta) => Ok((&**meta).clone()), + Func(_, meta) => Ok((&**meta).clone()), + MalFunc { meta, .. } => Ok((&**meta).clone()), + _ => error("meta not supported by type"), + } + } + + pub fn with_meta(&mut self, new_meta: &MalVal) -> MalRet { + match self { + List(_, ref mut meta) + | Vector(_, ref mut meta) + | Hash(_, ref mut meta) + | Func(_, ref mut meta) + | MalFunc { ref mut meta, .. } => { + *meta = Rc::new((&*new_meta).clone()); + } + _ => return error("with-meta not supported by type"), + }; + Ok(self.clone()) + } +} + +impl PartialEq for MalVal { + fn eq(&self, other: &MalVal) -> bool { + match (self, other) { + (Nil, Nil) => true, + (Bool(ref a), Bool(ref b)) => a == b, + (Int(ref a), Int(ref b)) => a == b, + (Str(ref a), Str(ref b)) => a == b, + (Sym(ref a), Sym(ref b)) => a == b, + (List(ref a, _), List(ref b, _)) + | (Vector(ref a, _), Vector(ref b, _)) + | (List(ref a, _), Vector(ref b, _)) + | (Vector(ref a, _), List(ref b, _)) => a == b, + (Hash(ref a, _), Hash(ref b, _)) => a == b, + (MalFunc { .. }, MalFunc { .. }) => false, + _ => false, + } + } +} + +pub fn func(f: fn(MalArgs) -> MalRet) -> MalVal { + Func(f, Rc::new(Nil)) +} + +pub fn _assoc(mut hm: FnvHashMap, kvs: MalArgs) -> MalRet { + if kvs.len() % 2 != 0 { + return error("odd number of elements"); + } + for (k, v) in kvs.iter().tuples() { + match k { + Str(s) => { + hm.insert(s.to_string(), v.clone()); + } + _ => return error("key is not string"), + } + } + Ok(Hash(Rc::new(hm), Rc::new(Nil))) +} + +pub fn _dissoc(mut hm: FnvHashMap, ks: MalArgs) -> MalRet { + for k in ks.iter() { + match k { + Str(ref s) => { + hm.remove(s); + } + _ => return error("key is not string"), + } + } + Ok(Hash(Rc::new(hm), Rc::new(Nil))) +} + +pub fn hash_map(kvs: MalArgs) -> MalRet { + let hm: FnvHashMap = FnvHashMap::default(); + _assoc(hm, kvs) +} diff --git a/impls/scala/Dockerfile b/impls/scala/Dockerfile index 1aa29b5dde..1676233a96 100644 --- a/impls/scala/Dockerfile +++ b/impls/scala/Dockerfile @@ -1,36 +1,36 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Java and maven -RUN apt-get -y install openjdk-8-jdk -#RUN apt-get -y install maven2 -#ENV MAVEN_OPTS -Duser.home=/mal - -# Scala -RUN echo "deb http://dl.bintray.com/sbt/debian /" > /etc/apt/sources.list.d/sbt.list -RUN apt-get -y update - -RUN apt-get -y --force-yes install sbt -RUN apt-get -y install scala -ENV SBT_OPTS -Duser.home=/mal - +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Java and maven +RUN apt-get -y install openjdk-8-jdk +#RUN apt-get -y install maven2 +#ENV MAVEN_OPTS -Duser.home=/mal + +# Scala +RUN echo "deb http://dl.bintray.com/sbt/debian /" > /etc/apt/sources.list.d/sbt.list +RUN apt-get -y update + +RUN apt-get -y --force-yes install sbt +RUN apt-get -y install scala +ENV SBT_OPTS -Duser.home=/mal + diff --git a/impls/scala/Makefile b/impls/scala/Makefile index 12ca5b834b..b42474fb0c 100644 --- a/impls/scala/Makefile +++ b/impls/scala/Makefile @@ -1,23 +1,23 @@ -SOURCES_BASE = types.scala reader.scala printer.scala -SOURCES_LISP = env.scala core.scala stepA_mal.scala -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -TARGET_DIR=target/scala-2.11 - -all: $(TARGET_DIR)/mal.jar - -dist: mal - -mal: $(TARGET_DIR)/mal.jar - cp $< $@ - -$(TARGET_DIR)/mal.jar: - sbt assembly - -$(TARGET_DIR)/classes/step%.class: step%.scala $(SOURCES) - sbt assembly - -clean: - rm -rf mal target - -.PHONY: all dist clean +SOURCES_BASE = types.scala reader.scala printer.scala +SOURCES_LISP = env.scala core.scala stepA_mal.scala +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +TARGET_DIR=target/scala-2.11 + +all: $(TARGET_DIR)/mal.jar + +dist: mal + +mal: $(TARGET_DIR)/mal.jar + cp $< $@ + +$(TARGET_DIR)/mal.jar: + sbt assembly + +$(TARGET_DIR)/classes/step%.class: step%.scala $(SOURCES) + sbt assembly + +clean: + rm -rf mal target + +.PHONY: all dist clean diff --git a/impls/scala/assembly.sbt b/impls/scala/assembly.sbt index 0b3ef91c19..98c4f0f464 100644 --- a/impls/scala/assembly.sbt +++ b/impls/scala/assembly.sbt @@ -1,6 +1,6 @@ -import sbtassembly.AssemblyPlugin.defaultShellScript - -test in assembly := {} -assemblyJarName in assembly := "mal.jar" -mainClass in assembly := Some("stepA_mal") -assemblyOption in assembly ~= { _.copy(prependShellScript = Some(defaultShellScript)) } +import sbtassembly.AssemblyPlugin.defaultShellScript + +test in assembly := {} +assemblyJarName in assembly := "mal.jar" +mainClass in assembly := Some("stepA_mal") +assemblyOption in assembly ~= { _.copy(prependShellScript = Some(defaultShellScript)) } diff --git a/impls/scala/build.sbt b/impls/scala/build.sbt index c5bfda397c..c5c9b2325b 100644 --- a/impls/scala/build.sbt +++ b/impls/scala/build.sbt @@ -1,6 +1,6 @@ -lazy val root = (project in file(".")). - settings( - name := "mal", - version := "0.1", - scalaVersion := "2.11.4" - ) +lazy val root = (project in file(".")). + settings( + name := "mal", + version := "0.1", + scalaVersion := "2.11.4" + ) diff --git a/impls/scala/core.scala b/impls/scala/core.scala index 95136313af..ad5132757b 100644 --- a/impls/scala/core.scala +++ b/impls/scala/core.scala @@ -1,319 +1,319 @@ -import scala.collection.mutable -import scala.io.Source - -import types.{MalList, _list, _list_Q, - MalVector, _vector, _vector_Q, - MalHashMap, _hash_map_Q, _hash_map, - Func, MalFunction} -import printer._pr_list - -object core { - def mal_throw(a: List[Any]) = { - throw new types.MalException(printer._pr_str(a(0))).init(a(0)) - } - - // Scalar functions - def keyword(a: List[Any]) = { - "\u029e" + a(0).asInstanceOf[String] - } - - def keyword_Q(a: List[Any]) = { - a(0) match { - case s: String => s.length != 0 && s(0) == '\u029e' - case _ => false - } - } - - def string_Q(a: List[Any]) = { - a(0) match { - case s: String => s.length == 0 || s(0) != '\u029e' - case _ => false - } - } - - def fn_Q(a: List[Any]) = { - a(0) match { - case s: Func => true - case s: MalFunction => !s.asInstanceOf[MalFunction].ismacro - case _ => false - } - } - - def macro_Q(a: List[Any]) = { - a(0) match { - case s: MalFunction => s.asInstanceOf[MalFunction].ismacro - case _ => false - } - } - - // number functions - def _bool_op(a: List[Any], op: (Long, Long) => Boolean) = { - op(a(0).asInstanceOf[Long],a(1).asInstanceOf[Long]) - } - - def _num_op(a: List[Any], op: (Long, Long) => Long) = { - op(a(0).asInstanceOf[Long],a(1).asInstanceOf[Long]) - } - - def number_Q(a: List[Any]) = { - a(0).isInstanceOf[Long] || a(0).isInstanceOf[Double] - } - - - // string functions - def read_string(a: List[Any]) = { - reader.read_str(a(0).asInstanceOf[String]) - } - - def slurp(a: List[Any]) = { - Source.fromFile(a(0).asInstanceOf[String]).getLines.mkString("\n") + "\n" - } - - // Hash Map functions - def assoc(a: List[Any]): Any = { - a(0).asInstanceOf[MalHashMap] ++ _hash_map(a.drop(1):_*) - } - - def dissoc(a: List[Any]): Any = { - var kSet = a.drop(1).toSet - a(0).asInstanceOf[MalHashMap] - .filterKeys{ !kSet.contains(_) } - } - - def get(a: List[Any]): Any = { - val hm = a(0).asInstanceOf[MalHashMap] - val key = a(1).asInstanceOf[String] - if (hm != null && hm.value.contains(key)) hm(key) else null - } - - def contains_Q(a: List[Any]): Any = { - a(0).asInstanceOf[MalHashMap].value - .contains(a(1).asInstanceOf[String]) - } - - - // sequence functions - def concat(a: List[Any]): Any = { - _list((for (sq <- a) yield types._toIter(sq)).flatten:_*) - } - - def nth(a: List[Any]): Any = { - val lst = a(0).asInstanceOf[MalList].value - val idx = a(1).asInstanceOf[Long] - if (idx < lst.length) { - lst(idx.toInt) - } else { - throw new Exception("nth: index out of range") - } - } - - def first(a: List[Any]): Any = { - a(0) match { - case null => null - case ml: MalList => { - val lst = ml.value - if (lst.length > 0) lst(0) else null - } - } - } - - def rest(a: List[Any]): Any = { - a(0) match { - case null => _list() - case ml: MalList => _list(ml.drop(1).value:_*) - } - } - - def empty_Q(a: List[Any]): Any = { - a(0) match { - case null => true - case ml: MalList => ml.value.isEmpty - } - } - - def count(a: List[Any]): Any = { - a(0) match { - case null => 0 - case ml: MalList => ml.value.length.asInstanceOf[Long] - } - } - - def apply(a: List[Any]): Any = { - a match { - case f :: rest => { - var args1 = rest.slice(0,rest.length-1) - var args = args1 ++ rest(rest.length-1).asInstanceOf[MalList].value - types._apply(f, args) - } - case _ => throw new Exception("invalid apply call") - } - } - - def do_map(a: List[Any]): Any = { - a match { - case f :: seq :: Nil => { - var res = seq.asInstanceOf[MalList].map(x => types._apply(f,List(x))); - _list(res.value:_*) - } - case _ => throw new Exception("invalid map call") - } - } - - def conj(a: List[Any]): Any = { - a(0) match { - case mv: MalVector => { - _vector(mv.value ++ a.slice(1,a.length):_*) - } - case ml: MalList => { - _list(a.slice(1,a.length).reverse ++ ml.value:_*) - } - } - } - - def seq(a: List[Any]): Any = { - a(0) match { - case mv: MalVector => { - if (mv.value.length == 0) null else _list(mv.value:_*) - } - case ml: MalList => { - if (ml.value.length == 0) null else ml - } - case ms: String => { - if (ms.length == 0) null else _list(ms.split("(?!^)"):_*) - } - case null => null - case _ => throw new Exception("seq: called on non-sequence") - } - } - - - // meta functions - def with_meta(a: List[Any]): Any = { - val meta: Any = a(1) - a(0) match { - case ml: MalList => { - val new_ml = ml.clone() - new_ml.meta = meta - new_ml - } - case hm: MalHashMap => { - val new_hm = hm.clone() - new_hm.meta = meta - new_hm - } - case fn: Func => { - val new_fn = fn.clone() - new_fn.meta = meta - new_fn - } - case fn: MalFunction => { - val new_fn = fn.clone() - new_fn.meta = meta - new_fn - } - case _ => throw new Exception("no meta support for " + a(0).getClass) - } - } - - def meta(a: List[Any]): Any = { - a(0) match { - case ml: MalList => ml.meta - case hm: MalHashMap => hm.meta - case fn: Func => fn.meta - case fn: MalFunction => fn.meta - case _ => throw new Exception("no meta support for " + a(0).getClass) - } - } - - - // atom functions - def reset_BANG(a: List[Any]): Any = { - a(0).asInstanceOf[types.Atom].value = a(1) - a(1) - } - - def swap_BANG(a: List[Any]): Any = { - a match { - case a0 :: f :: rest => { - val atm = a0.asInstanceOf[types.Atom] - val args = atm.value +: rest - atm.value = types._apply(f, args) - atm.value - } - case _ => throw new Exception("invalid swap! call") - } - } - - - val ns: Map[String, (List[Any]) => Any] = Map( - "=" -> ((a: List[Any]) => types._equal_Q(a(0), a(1))), - "throw" -> mal_throw _, - "nil?" -> ((a: List[Any]) => a(0) == null), - "true?" -> ((a: List[Any]) => a(0) == true), - "false?" -> ((a: List[Any]) => a(0) == false), - "number?" -> number_Q _, - "string?" -> string_Q _, - "symbol" -> ((a: List[Any]) => Symbol(a(0).asInstanceOf[String])), - "symbol?" -> ((a: List[Any]) => a(0).isInstanceOf[Symbol]), - "keyword" -> keyword _, - "keyword?" -> keyword_Q _, - "fn?" -> fn_Q, - "macro?" -> macro_Q, - - "pr-str" -> ((a: List[Any]) => _pr_list(a, true, " ")), - "str" -> ((a: List[Any]) => _pr_list(a, false, "")), - "prn" -> ((a: List[Any]) => { println(_pr_list(a, true, " ")); null}), - "println" -> ((a: List[Any]) => { println(_pr_list(a, false, " ")); null}), - "readline" -> ((a: List[Any]) => readLine(a(0).asInstanceOf[String])), - "read-string" -> read_string _, - "slurp" -> slurp _, - - "<" -> ((a: List[Any]) => _bool_op(a, _ < _)), - "<=" -> ((a: List[Any]) => _bool_op(a, _ <= _)), - ">" -> ((a: List[Any]) => _bool_op(a, _ > _)), - ">=" -> ((a: List[Any]) => _bool_op(a, _ >= _)), - "+" -> ((a: List[Any]) => _num_op(a, _ + _)), - "-" -> ((a: List[Any]) => _num_op(a, _ - _)), - "*" -> ((a: List[Any]) => _num_op(a, _ * _)), - "/" -> ((a: List[Any]) => _num_op(a, _ / _)), - "time-ms" -> ((a: List[Any]) => System.currentTimeMillis), - - "list" -> ((a: List[Any]) => _list(a:_*)), - "list?" -> ((a: List[Any]) => _list_Q(a(0))), - "vector" -> ((a: List[Any]) => _vector(a:_*)), - "vector?" -> ((a: List[Any]) => _vector_Q(a(0))), - "hash-map" -> ((a: List[Any]) => _hash_map(a:_*)), - "map?" -> ((a: List[Any]) => _hash_map_Q(a(0))), - "assoc" -> assoc _, - "dissoc" -> dissoc _, - "get" -> get _, - "contains?" -> contains_Q _, - "keys" -> ((a: List[Any]) => a(0).asInstanceOf[MalHashMap].keys), - "vals" -> ((a: List[Any]) => a(0).asInstanceOf[MalHashMap].vals), - - "sequential?" -> ((a: List[Any]) => types._sequential_Q(a(0))), - "cons" -> ((a: List[Any]) => a(0) +: a(1).asInstanceOf[MalList]), - "concat" -> concat _, - "vec" -> ((a: List[Any]) => _vector(a(0).asInstanceOf[MalList].value:_*)), - "nth" -> nth _, - "first" -> first _, - "rest" -> rest _, - "empty?" -> empty_Q _, - "count" -> count _, - "apply" -> apply _, - "map" -> do_map _, - - "conj" -> conj _, - "seq" -> seq _, - - "with-meta" -> with_meta _, - "meta" -> meta _, - "atom" -> ((a: List[Any]) => new types.Atom(a(0))), - "atom?" -> ((a: List[Any]) => a(0).isInstanceOf[types.Atom]), - "deref" -> ((a: List[Any]) => a(0).asInstanceOf[types.Atom].value), - "reset!" -> reset_BANG _, - "swap!" -> swap_BANG _ - ) -} - -// vim:ts=2:sw=2 +import scala.collection.mutable +import scala.io.Source + +import types.{MalList, _list, _list_Q, + MalVector, _vector, _vector_Q, + MalHashMap, _hash_map_Q, _hash_map, + Func, MalFunction} +import printer._pr_list + +object core { + def mal_throw(a: List[Any]) = { + throw new types.MalException(printer._pr_str(a(0))).init(a(0)) + } + + // Scalar functions + def keyword(a: List[Any]) = { + "\u029e" + a(0).asInstanceOf[String] + } + + def keyword_Q(a: List[Any]) = { + a(0) match { + case s: String => s.length != 0 && s(0) == '\u029e' + case _ => false + } + } + + def string_Q(a: List[Any]) = { + a(0) match { + case s: String => s.length == 0 || s(0) != '\u029e' + case _ => false + } + } + + def fn_Q(a: List[Any]) = { + a(0) match { + case s: Func => true + case s: MalFunction => !s.asInstanceOf[MalFunction].ismacro + case _ => false + } + } + + def macro_Q(a: List[Any]) = { + a(0) match { + case s: MalFunction => s.asInstanceOf[MalFunction].ismacro + case _ => false + } + } + + // number functions + def _bool_op(a: List[Any], op: (Long, Long) => Boolean) = { + op(a(0).asInstanceOf[Long],a(1).asInstanceOf[Long]) + } + + def _num_op(a: List[Any], op: (Long, Long) => Long) = { + op(a(0).asInstanceOf[Long],a(1).asInstanceOf[Long]) + } + + def number_Q(a: List[Any]) = { + a(0).isInstanceOf[Long] || a(0).isInstanceOf[Double] + } + + + // string functions + def read_string(a: List[Any]) = { + reader.read_str(a(0).asInstanceOf[String]) + } + + def slurp(a: List[Any]) = { + Source.fromFile(a(0).asInstanceOf[String]).getLines.mkString("\n") + "\n" + } + + // Hash Map functions + def assoc(a: List[Any]): Any = { + a(0).asInstanceOf[MalHashMap] ++ _hash_map(a.drop(1):_*) + } + + def dissoc(a: List[Any]): Any = { + var kSet = a.drop(1).toSet + a(0).asInstanceOf[MalHashMap] + .filterKeys{ !kSet.contains(_) } + } + + def get(a: List[Any]): Any = { + val hm = a(0).asInstanceOf[MalHashMap] + val key = a(1).asInstanceOf[String] + if (hm != null && hm.value.contains(key)) hm(key) else null + } + + def contains_Q(a: List[Any]): Any = { + a(0).asInstanceOf[MalHashMap].value + .contains(a(1).asInstanceOf[String]) + } + + + // sequence functions + def concat(a: List[Any]): Any = { + _list((for (sq <- a) yield types._toIter(sq)).flatten:_*) + } + + def nth(a: List[Any]): Any = { + val lst = a(0).asInstanceOf[MalList].value + val idx = a(1).asInstanceOf[Long] + if (idx < lst.length) { + lst(idx.toInt) + } else { + throw new Exception("nth: index out of range") + } + } + + def first(a: List[Any]): Any = { + a(0) match { + case null => null + case ml: MalList => { + val lst = ml.value + if (lst.length > 0) lst(0) else null + } + } + } + + def rest(a: List[Any]): Any = { + a(0) match { + case null => _list() + case ml: MalList => _list(ml.drop(1).value:_*) + } + } + + def empty_Q(a: List[Any]): Any = { + a(0) match { + case null => true + case ml: MalList => ml.value.isEmpty + } + } + + def count(a: List[Any]): Any = { + a(0) match { + case null => 0 + case ml: MalList => ml.value.length.asInstanceOf[Long] + } + } + + def apply(a: List[Any]): Any = { + a match { + case f :: rest => { + var args1 = rest.slice(0,rest.length-1) + var args = args1 ++ rest(rest.length-1).asInstanceOf[MalList].value + types._apply(f, args) + } + case _ => throw new Exception("invalid apply call") + } + } + + def do_map(a: List[Any]): Any = { + a match { + case f :: seq :: Nil => { + var res = seq.asInstanceOf[MalList].map(x => types._apply(f,List(x))); + _list(res.value:_*) + } + case _ => throw new Exception("invalid map call") + } + } + + def conj(a: List[Any]): Any = { + a(0) match { + case mv: MalVector => { + _vector(mv.value ++ a.slice(1,a.length):_*) + } + case ml: MalList => { + _list(a.slice(1,a.length).reverse ++ ml.value:_*) + } + } + } + + def seq(a: List[Any]): Any = { + a(0) match { + case mv: MalVector => { + if (mv.value.length == 0) null else _list(mv.value:_*) + } + case ml: MalList => { + if (ml.value.length == 0) null else ml + } + case ms: String => { + if (ms.length == 0) null else _list(ms.split("(?!^)"):_*) + } + case null => null + case _ => throw new Exception("seq: called on non-sequence") + } + } + + + // meta functions + def with_meta(a: List[Any]): Any = { + val meta: Any = a(1) + a(0) match { + case ml: MalList => { + val new_ml = ml.clone() + new_ml.meta = meta + new_ml + } + case hm: MalHashMap => { + val new_hm = hm.clone() + new_hm.meta = meta + new_hm + } + case fn: Func => { + val new_fn = fn.clone() + new_fn.meta = meta + new_fn + } + case fn: MalFunction => { + val new_fn = fn.clone() + new_fn.meta = meta + new_fn + } + case _ => throw new Exception("no meta support for " + a(0).getClass) + } + } + + def meta(a: List[Any]): Any = { + a(0) match { + case ml: MalList => ml.meta + case hm: MalHashMap => hm.meta + case fn: Func => fn.meta + case fn: MalFunction => fn.meta + case _ => throw new Exception("no meta support for " + a(0).getClass) + } + } + + + // atom functions + def reset_BANG(a: List[Any]): Any = { + a(0).asInstanceOf[types.Atom].value = a(1) + a(1) + } + + def swap_BANG(a: List[Any]): Any = { + a match { + case a0 :: f :: rest => { + val atm = a0.asInstanceOf[types.Atom] + val args = atm.value +: rest + atm.value = types._apply(f, args) + atm.value + } + case _ => throw new Exception("invalid swap! call") + } + } + + + val ns: Map[String, (List[Any]) => Any] = Map( + "=" -> ((a: List[Any]) => types._equal_Q(a(0), a(1))), + "throw" -> mal_throw _, + "nil?" -> ((a: List[Any]) => a(0) == null), + "true?" -> ((a: List[Any]) => a(0) == true), + "false?" -> ((a: List[Any]) => a(0) == false), + "number?" -> number_Q _, + "string?" -> string_Q _, + "symbol" -> ((a: List[Any]) => Symbol(a(0).asInstanceOf[String])), + "symbol?" -> ((a: List[Any]) => a(0).isInstanceOf[Symbol]), + "keyword" -> keyword _, + "keyword?" -> keyword_Q _, + "fn?" -> fn_Q, + "macro?" -> macro_Q, + + "pr-str" -> ((a: List[Any]) => _pr_list(a, true, " ")), + "str" -> ((a: List[Any]) => _pr_list(a, false, "")), + "prn" -> ((a: List[Any]) => { println(_pr_list(a, true, " ")); null}), + "println" -> ((a: List[Any]) => { println(_pr_list(a, false, " ")); null}), + "readline" -> ((a: List[Any]) => readLine(a(0).asInstanceOf[String])), + "read-string" -> read_string _, + "slurp" -> slurp _, + + "<" -> ((a: List[Any]) => _bool_op(a, _ < _)), + "<=" -> ((a: List[Any]) => _bool_op(a, _ <= _)), + ">" -> ((a: List[Any]) => _bool_op(a, _ > _)), + ">=" -> ((a: List[Any]) => _bool_op(a, _ >= _)), + "+" -> ((a: List[Any]) => _num_op(a, _ + _)), + "-" -> ((a: List[Any]) => _num_op(a, _ - _)), + "*" -> ((a: List[Any]) => _num_op(a, _ * _)), + "/" -> ((a: List[Any]) => _num_op(a, _ / _)), + "time-ms" -> ((a: List[Any]) => System.currentTimeMillis), + + "list" -> ((a: List[Any]) => _list(a:_*)), + "list?" -> ((a: List[Any]) => _list_Q(a(0))), + "vector" -> ((a: List[Any]) => _vector(a:_*)), + "vector?" -> ((a: List[Any]) => _vector_Q(a(0))), + "hash-map" -> ((a: List[Any]) => _hash_map(a:_*)), + "map?" -> ((a: List[Any]) => _hash_map_Q(a(0))), + "assoc" -> assoc _, + "dissoc" -> dissoc _, + "get" -> get _, + "contains?" -> contains_Q _, + "keys" -> ((a: List[Any]) => a(0).asInstanceOf[MalHashMap].keys), + "vals" -> ((a: List[Any]) => a(0).asInstanceOf[MalHashMap].vals), + + "sequential?" -> ((a: List[Any]) => types._sequential_Q(a(0))), + "cons" -> ((a: List[Any]) => a(0) +: a(1).asInstanceOf[MalList]), + "concat" -> concat _, + "vec" -> ((a: List[Any]) => _vector(a(0).asInstanceOf[MalList].value:_*)), + "nth" -> nth _, + "first" -> first _, + "rest" -> rest _, + "empty?" -> empty_Q _, + "count" -> count _, + "apply" -> apply _, + "map" -> do_map _, + + "conj" -> conj _, + "seq" -> seq _, + + "with-meta" -> with_meta _, + "meta" -> meta _, + "atom" -> ((a: List[Any]) => new types.Atom(a(0))), + "atom?" -> ((a: List[Any]) => a(0).isInstanceOf[types.Atom]), + "deref" -> ((a: List[Any]) => a(0).asInstanceOf[types.Atom].value), + "reset!" -> reset_BANG _, + "swap!" -> swap_BANG _ + ) +} + +// vim:ts=2:sw=2 diff --git a/impls/scala/env.scala b/impls/scala/env.scala index 33be545aec..57e987267d 100644 --- a/impls/scala/env.scala +++ b/impls/scala/env.scala @@ -1,42 +1,42 @@ -import types._list - -import scala.collection.mutable - -object env { - class Env(outer: Env = null, - binds: Iterator[Any] = null, - exprs: Iterator[Any] = null) { - val data: mutable.Map[Symbol, Any] = mutable.Map() - if (binds != null && exprs != null) { - binds.foreach(b => { - val k = b.asInstanceOf[Symbol] - if (k == '&) { - data(binds.next().asInstanceOf[Symbol]) = _list(exprs.toSeq:_*) - } else { - data(k) = exprs.next() - } - }) - } - - def find(key: Symbol): Env = { - if (data.contains(key)) { - this - } else if (outer != null) { - outer.find(key) - } else { - null - } - } - def set(key: Symbol, value: Any): Any = { - data(key) = value - value - } - def get(key: Symbol): Any = { - val env = find(key) - if (env == null) throw new Exception("'" + key.name + "' not found") - env.data(key) - } - } -} - -// vim:ts=2:sw=2 +import types._list + +import scala.collection.mutable + +object env { + class Env(outer: Env = null, + binds: Iterator[Any] = null, + exprs: Iterator[Any] = null) { + val data: mutable.Map[Symbol, Any] = mutable.Map() + if (binds != null && exprs != null) { + binds.foreach(b => { + val k = b.asInstanceOf[Symbol] + if (k == '&) { + data(binds.next().asInstanceOf[Symbol]) = _list(exprs.toSeq:_*) + } else { + data(k) = exprs.next() + } + }) + } + + def find(key: Symbol): Env = { + if (data.contains(key)) { + this + } else if (outer != null) { + outer.find(key) + } else { + null + } + } + def set(key: Symbol, value: Any): Any = { + data(key) = value + value + } + def get(key: Symbol): Any = { + val env = find(key) + if (env == null) throw new Exception("'" + key.name + "' not found") + env.data(key) + } + } +} + +// vim:ts=2:sw=2 diff --git a/impls/scala/printer.scala b/impls/scala/printer.scala index 0a0e0b70ac..8dc194946d 100644 --- a/impls/scala/printer.scala +++ b/impls/scala/printer.scala @@ -1,43 +1,43 @@ -import types.{MalList, MalVector, MalHashMap, MalFunction} - - -object printer { - def _pr_str(obj: Any, print_readably: Boolean = true): String = { - val _r = print_readably - return obj match { - case v: MalVector => v.toString(_r) - case l: MalList => l.toString(_r) - case hm: MalHashMap => hm.toString(_r) - case s: String => { - if (s.length > 0 && s(0) == '\u029e') { - ":" + s.substring(1,s.length) - } else if (_r) { - //println("here1: " + s) - "\"" + s.replace("\\", "\\\\") - .replace("\"", "\\\"") - .replace("\n", "\\n") + "\"" - } else { - s - } - } - case Symbol(s) => s - case a: types.Atom => "(atom " + a.value + ")" - case null => "nil" - case _ => { - if (obj.isInstanceOf[MalFunction]) { - val f = obj.asInstanceOf[MalFunction] - "" - } else { - obj.toString - } - } - } - } - - def _pr_list(lst: List[Any], print_readably: Boolean = true, - sep: String = " "): String = { - lst.map{_pr_str(_, print_readably)}.mkString(sep) - } -} - -// vim: ts=2:sw=2 +import types.{MalList, MalVector, MalHashMap, MalFunction} + + +object printer { + def _pr_str(obj: Any, print_readably: Boolean = true): String = { + val _r = print_readably + return obj match { + case v: MalVector => v.toString(_r) + case l: MalList => l.toString(_r) + case hm: MalHashMap => hm.toString(_r) + case s: String => { + if (s.length > 0 && s(0) == '\u029e') { + ":" + s.substring(1,s.length) + } else if (_r) { + //println("here1: " + s) + "\"" + s.replace("\\", "\\\\") + .replace("\"", "\\\"") + .replace("\n", "\\n") + "\"" + } else { + s + } + } + case Symbol(s) => s + case a: types.Atom => "(atom " + a.value + ")" + case null => "nil" + case _ => { + if (obj.isInstanceOf[MalFunction]) { + val f = obj.asInstanceOf[MalFunction] + "" + } else { + obj.toString + } + } + } + } + + def _pr_list(lst: List[Any], print_readably: Boolean = true, + sep: String = " "): String = { + lst.map{_pr_str(_, print_readably)}.mkString(sep) + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/project/assembly.sbt b/impls/scala/project/assembly.sbt index 652a3b93be..c0d3e72146 100644 --- a/impls/scala/project/assembly.sbt +++ b/impls/scala/project/assembly.sbt @@ -1 +1 @@ -addSbtPlugin("com.eed3si9n" % "sbt-assembly" % "0.14.6") +addSbtPlugin("com.eed3si9n" % "sbt-assembly" % "0.14.6") diff --git a/impls/scala/reader.scala b/impls/scala/reader.scala index d4913f872b..bb2687d954 100644 --- a/impls/scala/reader.scala +++ b/impls/scala/reader.scala @@ -1,97 +1,97 @@ -import scala.util.matching.Regex - -import types.{MalList, _list, MalVector, _vector, MalHashMap, _hash_map} - -object reader { - - class Reader (tokens: Array[String]) { - var data = tokens - var position: Int = 0 - def peek(): String = { - if (position >= data.length) return(null) - data(position) - } - def next(): String = { - if (position >= data.length) return(null) - position = position + 1 - data(position-1) - } - } - - def tokenize(str: String): Array[String] = { - val re = """[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)""".r - re.findAllMatchIn(str).map{ _.group(1) } - .filter{ s => s != "" && s(0) != ';' } - .toArray - } - - def parse_str(s: String): String = { - // TODO: use re.replaceAllIn instead for single pass - s.replace("\\\\", "\u029e") - .replace("\\\"", "\"") - .replace("\\n", "\n") - .replace("\u029e", "\\") - } - - def read_atom(rdr: Reader): Any = { - val token = rdr.next() - val re_int = """^(-?[0-9]+)$""".r - val re_flt = """^(-?[0-9][0-9.]*)$""".r - val re_str = """^"((?:\\.|[^\\"])*)"$""".r - val re_str_bad = """^"(.*)$""".r - val re_key = """^:(.*)$""".r - return token match { - case re_int(i) => i.toLong // integer - case re_flt(f) => f.toDouble // float - case re_str(s) => parse_str(s) // string - case re_str_bad(s) => - throw new Exception("expected '\"', got EOF") - case re_key(k) => "\u029e" + k // keyword - case "nil" => null - case "true" => true - case "false" => false - case _ => Symbol(token) // symbol - } - } - - def read_list(rdr: Reader, - start: String = "(", end: String = ")"): MalList = { - var ast: MalList = _list() - var token = rdr.next() - if (token != start) throw new Exception("expected '" + start + "', got EOF") - while ({token = rdr.peek(); token != end}) { - if (token == null) throw new Exception("expected '" + end + "', got EOF") - ast = ast :+ read_form(rdr) - } - rdr.next() - ast - } - - def read_form(rdr: Reader): Any = { - return rdr.peek() match { - case "'" => { rdr.next; _list(Symbol("quote"), read_form(rdr)) } - case "`" => { rdr.next; _list(Symbol("quasiquote"), read_form(rdr)) } - case "~" => { rdr.next; _list(Symbol("unquote"), read_form(rdr)) } - case "~@" => { rdr.next; _list(Symbol("splice-unquote"), read_form(rdr)) } - case "^" => { rdr.next; val meta = read_form(rdr); - _list(Symbol("with-meta"), read_form(rdr), meta) } - case "@" => { rdr.next; _list(Symbol("deref"), read_form(rdr)) } - - case "(" => read_list(rdr) - case ")" => throw new Exception("unexpected ')')") - case "[" => _vector(read_list(rdr, "[", "]").value:_*) - case "]" => throw new Exception("unexpected ']')") - case "{" => _hash_map(read_list(rdr, "{", "}").value:_*) - case "}" => throw new Exception("unexpected '}')") - case _ => read_atom(rdr) - } - } - - def read_str(str: String): Any = { - val tokens = tokenize(str) - if (tokens.length == 0) return null - return read_form(new Reader(tokens)) - } -} - -// vim: ts=2:sw=2 +import scala.util.matching.Regex + +import types.{MalList, _list, MalVector, _vector, MalHashMap, _hash_map} + +object reader { + + class Reader (tokens: Array[String]) { + var data = tokens + var position: Int = 0 + def peek(): String = { + if (position >= data.length) return(null) + data(position) + } + def next(): String = { + if (position >= data.length) return(null) + position = position + 1 + data(position-1) + } + } + + def tokenize(str: String): Array[String] = { + val re = """[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)""".r + re.findAllMatchIn(str).map{ _.group(1) } + .filter{ s => s != "" && s(0) != ';' } + .toArray + } + + def parse_str(s: String): String = { + // TODO: use re.replaceAllIn instead for single pass + s.replace("\\\\", "\u029e") + .replace("\\\"", "\"") + .replace("\\n", "\n") + .replace("\u029e", "\\") + } + + def read_atom(rdr: Reader): Any = { + val token = rdr.next() + val re_int = """^(-?[0-9]+)$""".r + val re_flt = """^(-?[0-9][0-9.]*)$""".r + val re_str = """^"((?:\\.|[^\\"])*)"$""".r + val re_str_bad = """^"(.*)$""".r + val re_key = """^:(.*)$""".r + return token match { + case re_int(i) => i.toLong // integer + case re_flt(f) => f.toDouble // float + case re_str(s) => parse_str(s) // string + case re_str_bad(s) => + throw new Exception("expected '\"', got EOF") + case re_key(k) => "\u029e" + k // keyword + case "nil" => null + case "true" => true + case "false" => false + case _ => Symbol(token) // symbol + } + } + + def read_list(rdr: Reader, + start: String = "(", end: String = ")"): MalList = { + var ast: MalList = _list() + var token = rdr.next() + if (token != start) throw new Exception("expected '" + start + "', got EOF") + while ({token = rdr.peek(); token != end}) { + if (token == null) throw new Exception("expected '" + end + "', got EOF") + ast = ast :+ read_form(rdr) + } + rdr.next() + ast + } + + def read_form(rdr: Reader): Any = { + return rdr.peek() match { + case "'" => { rdr.next; _list(Symbol("quote"), read_form(rdr)) } + case "`" => { rdr.next; _list(Symbol("quasiquote"), read_form(rdr)) } + case "~" => { rdr.next; _list(Symbol("unquote"), read_form(rdr)) } + case "~@" => { rdr.next; _list(Symbol("splice-unquote"), read_form(rdr)) } + case "^" => { rdr.next; val meta = read_form(rdr); + _list(Symbol("with-meta"), read_form(rdr), meta) } + case "@" => { rdr.next; _list(Symbol("deref"), read_form(rdr)) } + + case "(" => read_list(rdr) + case ")" => throw new Exception("unexpected ')')") + case "[" => _vector(read_list(rdr, "[", "]").value:_*) + case "]" => throw new Exception("unexpected ']')") + case "{" => _hash_map(read_list(rdr, "{", "}").value:_*) + case "}" => throw new Exception("unexpected '}')") + case _ => read_atom(rdr) + } + } + + def read_str(str: String): Any = { + val tokens = tokenize(str) + if (tokens.length == 0) return null + return read_form(new Reader(tokens)) + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/run b/impls/scala/run index 49c913c26a..d1f972cfa8 100755 --- a/impls/scala/run +++ b/impls/scala/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec java -classpath "$(dirname $0)/target/scala-2.11/mal.jar" "${STEP:-stepA_mal}" "$@" +#!/bin/bash +exec java -classpath "$(dirname $0)/target/scala-2.11/mal.jar" "${STEP:-stepA_mal}" "$@" diff --git a/impls/scala/step0_repl.scala b/impls/scala/step0_repl.scala index 5ec94fe6c7..c5a1a822b6 100644 --- a/impls/scala/step0_repl.scala +++ b/impls/scala/step0_repl.scala @@ -1,33 +1,33 @@ -object step0_repl { - def READ(str: String): String = { - str - } - - def EVAL(str: String, env: String): String = { - str - } - - def PRINT(str: String): String = { - str - } - - def REP(str: String): String = { - PRINT(EVAL(READ(str), "")) - } - - def main(args: Array[String]) { - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Exception => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +object step0_repl { + def READ(str: String): String = { + str + } + + def EVAL(str: String, env: String): String = { + str + } + + def PRINT(str: String): String = { + str + } + + def REP(str: String): String = { + PRINT(EVAL(READ(str), "")) + } + + def main(args: Array[String]) { + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Exception => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/step1_read_print.scala b/impls/scala/step1_read_print.scala index 7485eb086c..fe6251ff1b 100644 --- a/impls/scala/step1_read_print.scala +++ b/impls/scala/step1_read_print.scala @@ -1,39 +1,39 @@ -import reader.tokenize - -object step1_read_print { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def EVAL(ast: Any, env: String): Any = { - ast - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val REP = (str: String) => { - PRINT(EVAL(READ(str), "")) - } - - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Exception => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import reader.tokenize + +object step1_read_print { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def EVAL(ast: Any, env: String): Any = { + ast + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val REP = (str: String) => { + PRINT(EVAL(READ(str), "")) + } + + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Exception => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/step2_eval.scala b/impls/scala/step2_eval.scala index a25dde1219..9333cdb746 100644 --- a/impls/scala/step2_eval.scala +++ b/impls/scala/step2_eval.scala @@ -1,75 +1,75 @@ -import types.{MalList, _list_Q, MalVector, MalHashMap, MalFunction} - -object step2_eval { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def eval_ast(ast: Any, env: Map[Symbol,Any]): Any = { - ast match { - case s : Symbol => env(s) - case v: MalVector => v.map(EVAL(_, env)) - case l: MalList => l.map(EVAL(_, env)) - case m: MalHashMap => { - m.map{case (k,v) => (k, EVAL(v, env))} - } - case _ => ast - } - } - - def EVAL(ast: Any, env: Map[Symbol,Any]): Any = { - //println("EVAL: " + printer._pr_str(ast,true)) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - // apply list - if (ast.asInstanceOf[MalList].value.length == 0) - return ast - eval_ast(ast, env).asInstanceOf[MalList].value match { - case f :: el => { - var fn: List[Any] => Any = null - try { - fn = f.asInstanceOf[List[Any] => Any] - } catch { - case _: Throwable => - throw new Exception("attempt to call non-function") - } - return fn(el) - } - case _ => throw new Exception("invalid apply") - } - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val repl_env: Map[Symbol,Any] = Map( - '+ -> ((a: List[Any]) => a(0).asInstanceOf[Long] + a(1).asInstanceOf[Long]), - '- -> ((a: List[Any]) => a(0).asInstanceOf[Long] - a(1).asInstanceOf[Long]), - '* -> ((a: List[Any]) => a(0).asInstanceOf[Long] * a(1).asInstanceOf[Long]), - '/ -> ((a: List[Any]) => a(0).asInstanceOf[Long] / a(1).asInstanceOf[Long])) - val REP = (str: String) => { - PRINT(EVAL(READ(str), repl_env)) - } - - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Exception => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import types.{MalList, _list_Q, MalVector, MalHashMap, MalFunction} + +object step2_eval { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def eval_ast(ast: Any, env: Map[Symbol,Any]): Any = { + ast match { + case s : Symbol => env(s) + case v: MalVector => v.map(EVAL(_, env)) + case l: MalList => l.map(EVAL(_, env)) + case m: MalHashMap => { + m.map{case (k,v) => (k, EVAL(v, env))} + } + case _ => ast + } + } + + def EVAL(ast: Any, env: Map[Symbol,Any]): Any = { + //println("EVAL: " + printer._pr_str(ast,true)) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + // apply list + if (ast.asInstanceOf[MalList].value.length == 0) + return ast + eval_ast(ast, env).asInstanceOf[MalList].value match { + case f :: el => { + var fn: List[Any] => Any = null + try { + fn = f.asInstanceOf[List[Any] => Any] + } catch { + case _: Throwable => + throw new Exception("attempt to call non-function") + } + return fn(el) + } + case _ => throw new Exception("invalid apply") + } + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val repl_env: Map[Symbol,Any] = Map( + '+ -> ((a: List[Any]) => a(0).asInstanceOf[Long] + a(1).asInstanceOf[Long]), + '- -> ((a: List[Any]) => a(0).asInstanceOf[Long] - a(1).asInstanceOf[Long]), + '* -> ((a: List[Any]) => a(0).asInstanceOf[Long] * a(1).asInstanceOf[Long]), + '/ -> ((a: List[Any]) => a(0).asInstanceOf[Long] / a(1).asInstanceOf[Long])) + val REP = (str: String) => { + PRINT(EVAL(READ(str), repl_env)) + } + + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Exception => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/step3_env.scala b/impls/scala/step3_env.scala index 0f37debca6..c737b28e18 100644 --- a/impls/scala/step3_env.scala +++ b/impls/scala/step3_env.scala @@ -1,92 +1,92 @@ -import types.{MalList, _list_Q, MalVector, MalHashMap, MalFunction} -import env.Env - -object step3_env { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def eval_ast(ast: Any, env: Env): Any = { - ast match { - case s : Symbol => env.get(s) - case v: MalVector => v.map(EVAL(_, env)) - case l: MalList => l.map(EVAL(_, env)) - case m: MalHashMap => { - m.map{case (k,v) => (k, EVAL(v, env))} - } - case _ => ast - } - } - - def EVAL(ast: Any, env: Env): Any = { - //println("EVAL: " + printer._pr_str(ast,true)) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - // apply list - ast.asInstanceOf[MalList].value match { - case Nil => { - return ast - } - case Symbol("def!") :: a1 :: a2 :: Nil => { - return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) - } - case Symbol("let*") :: a1 :: a2 :: Nil => { - val let_env = new Env(env) - for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { - let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) - } - return EVAL(a2, let_env) - } - case _ => { - // function call - eval_ast(ast, env).asInstanceOf[MalList].value match { - case f :: el => { - var fn: List[Any] => Any = null - try { - fn = f.asInstanceOf[(List[Any]) => Any] - } catch { - case _: Throwable => - throw new Exception("attempt to call non-function") - } - return fn(el) - } - case _ => throw new Exception("invalid apply") - } - } - } - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val repl_env: Env = new Env() - repl_env.set('+, (a: List[Any]) => a(0).asInstanceOf[Long] + a(1).asInstanceOf[Long]) - repl_env.set('-, (a: List[Any]) => a(0).asInstanceOf[Long] - a(1).asInstanceOf[Long]) - repl_env.set('*, (a: List[Any]) => a(0).asInstanceOf[Long] * a(1).asInstanceOf[Long]) - repl_env.set('/, (a: List[Any]) => a(0).asInstanceOf[Long] / a(1).asInstanceOf[Long]) - val REP = (str: String) => { - PRINT(EVAL(READ(str), repl_env)) - } - - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Throwable => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import types.{MalList, _list_Q, MalVector, MalHashMap, MalFunction} +import env.Env + +object step3_env { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def eval_ast(ast: Any, env: Env): Any = { + ast match { + case s : Symbol => env.get(s) + case v: MalVector => v.map(EVAL(_, env)) + case l: MalList => l.map(EVAL(_, env)) + case m: MalHashMap => { + m.map{case (k,v) => (k, EVAL(v, env))} + } + case _ => ast + } + } + + def EVAL(ast: Any, env: Env): Any = { + //println("EVAL: " + printer._pr_str(ast,true)) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + // apply list + ast.asInstanceOf[MalList].value match { + case Nil => { + return ast + } + case Symbol("def!") :: a1 :: a2 :: Nil => { + return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) + } + case Symbol("let*") :: a1 :: a2 :: Nil => { + val let_env = new Env(env) + for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { + let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) + } + return EVAL(a2, let_env) + } + case _ => { + // function call + eval_ast(ast, env).asInstanceOf[MalList].value match { + case f :: el => { + var fn: List[Any] => Any = null + try { + fn = f.asInstanceOf[(List[Any]) => Any] + } catch { + case _: Throwable => + throw new Exception("attempt to call non-function") + } + return fn(el) + } + case _ => throw new Exception("invalid apply") + } + } + } + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val repl_env: Env = new Env() + repl_env.set('+, (a: List[Any]) => a(0).asInstanceOf[Long] + a(1).asInstanceOf[Long]) + repl_env.set('-, (a: List[Any]) => a(0).asInstanceOf[Long] - a(1).asInstanceOf[Long]) + repl_env.set('*, (a: List[Any]) => a(0).asInstanceOf[Long] * a(1).asInstanceOf[Long]) + repl_env.set('/, (a: List[Any]) => a(0).asInstanceOf[Long] / a(1).asInstanceOf[Long]) + val REP = (str: String) => { + PRINT(EVAL(READ(str), repl_env)) + } + + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Throwable => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/step4_if_fn_do.scala b/impls/scala/step4_if_fn_do.scala index 4ae4bdc37c..5ead73e698 100644 --- a/impls/scala/step4_if_fn_do.scala +++ b/impls/scala/step4_if_fn_do.scala @@ -1,113 +1,113 @@ -import types.{MalList, _list, _list_Q, MalVector, MalHashMap, - Func, MalFunction} -import env.Env - -object step4_if_fn_do { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def eval_ast(ast: Any, env: Env): Any = { - ast match { - case s : Symbol => env.get(s) - case v: MalVector => v.map(EVAL(_, env)) - case l: MalList => l.map(EVAL(_, env)) - case m: MalHashMap => { - m.map{case (k,v) => (k, EVAL(v, env))} - } - case _ => ast - } - } - - def EVAL(ast: Any, env: Env): Any = { - //println("EVAL: " + printer._pr_str(ast,true)) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - // apply list - ast.asInstanceOf[MalList].value match { - case Nil => { - return ast - } - case Symbol("def!") :: a1 :: a2 :: Nil => { - return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) - } - case Symbol("let*") :: a1 :: a2 :: Nil => { - val let_env = new Env(env) - for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { - let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) - } - return EVAL(a2, let_env) - } - case Symbol("do") :: rest => { - val el = eval_ast(_list(rest:_*), env) - return el.asInstanceOf[MalList].value.last - } - case Symbol("if") :: a1 :: a2 :: rest => { - val cond = EVAL(a1, env) - if (cond == null || cond == false) { - if (rest.length == 0) return null - return EVAL(rest(0), env) - } else { - return EVAL(a2, env) - } - } - case Symbol("fn*") :: a1 :: a2 :: Nil => { - return new Func((args: List[Any]) => { - EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) - }) - } - case _ => { - // function call - eval_ast(ast, env).asInstanceOf[MalList].value match { - case f :: el => { - var fn: Func = null - try { - fn = f.asInstanceOf[Func] - } catch { - case _: Throwable => - throw new Exception("attempt to call non-function") - } - return fn(el) - } - case _ => throw new Exception("invalid apply") - } - } - } - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val repl_env: Env = new Env() - val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) - - // core.scala: defined using scala - core.ns.map{case (k: String,v: Any) => { - repl_env.set(Symbol(k), new Func(v)) - }} - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Throwable => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import types.{MalList, _list, _list_Q, MalVector, MalHashMap, + Func, MalFunction} +import env.Env + +object step4_if_fn_do { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def eval_ast(ast: Any, env: Env): Any = { + ast match { + case s : Symbol => env.get(s) + case v: MalVector => v.map(EVAL(_, env)) + case l: MalList => l.map(EVAL(_, env)) + case m: MalHashMap => { + m.map{case (k,v) => (k, EVAL(v, env))} + } + case _ => ast + } + } + + def EVAL(ast: Any, env: Env): Any = { + //println("EVAL: " + printer._pr_str(ast,true)) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + // apply list + ast.asInstanceOf[MalList].value match { + case Nil => { + return ast + } + case Symbol("def!") :: a1 :: a2 :: Nil => { + return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) + } + case Symbol("let*") :: a1 :: a2 :: Nil => { + val let_env = new Env(env) + for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { + let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) + } + return EVAL(a2, let_env) + } + case Symbol("do") :: rest => { + val el = eval_ast(_list(rest:_*), env) + return el.asInstanceOf[MalList].value.last + } + case Symbol("if") :: a1 :: a2 :: rest => { + val cond = EVAL(a1, env) + if (cond == null || cond == false) { + if (rest.length == 0) return null + return EVAL(rest(0), env) + } else { + return EVAL(a2, env) + } + } + case Symbol("fn*") :: a1 :: a2 :: Nil => { + return new Func((args: List[Any]) => { + EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) + }) + } + case _ => { + // function call + eval_ast(ast, env).asInstanceOf[MalList].value match { + case f :: el => { + var fn: Func = null + try { + fn = f.asInstanceOf[Func] + } catch { + case _: Throwable => + throw new Exception("attempt to call non-function") + } + return fn(el) + } + case _ => throw new Exception("invalid apply") + } + } + } + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val repl_env: Env = new Env() + val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) + + // core.scala: defined using scala + core.ns.map{case (k: String,v: Any) => { + repl_env.set(Symbol(k), new Func(v)) + }} + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Throwable => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/step5_tco.scala b/impls/scala/step5_tco.scala index f9cb813929..50c16d2eac 100644 --- a/impls/scala/step5_tco.scala +++ b/impls/scala/step5_tco.scala @@ -1,124 +1,124 @@ -import types.{MalList, _list, _list_Q, MalVector, MalHashMap, - Func, MalFunction} -import env.Env - -object step5_tco { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def eval_ast(ast: Any, env: Env): Any = { - ast match { - case s : Symbol => env.get(s) - case v: MalVector => v.map(EVAL(_, env)) - case l: MalList => l.map(EVAL(_, env)) - case m: MalHashMap => { - m.map{case (k,v) => (k, EVAL(v, env))} - } - case _ => ast - } - } - - def EVAL(orig_ast: Any, orig_env: Env): Any = { - var ast = orig_ast; var env = orig_env; - while (true) { - - //println("EVAL: " + printer._pr_str(ast,true)) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - // apply list - ast.asInstanceOf[MalList].value match { - case Nil => { - return ast - } - case Symbol("def!") :: a1 :: a2 :: Nil => { - return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) - } - case Symbol("let*") :: a1 :: a2 :: Nil => { - val let_env = new Env(env) - for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { - let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) - } - env = let_env - ast = a2 // continue loop (TCO) - } - case Symbol("do") :: rest => { - eval_ast(_list(rest.slice(0,rest.length-1):_*), env) - ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) - } - case Symbol("if") :: a1 :: a2 :: rest => { - val cond = EVAL(a1, env) - if (cond == null || cond == false) { - if (rest.length == 0) return null - ast = rest(0) // continue loop (TCO) - } else { - ast = a2 // continue loop (TCO) - } - } - case Symbol("fn*") :: a1 :: a2 :: Nil => { - return new MalFunction(a2, env, a1.asInstanceOf[MalList], - (args: List[Any]) => { - EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) - } - ) - } - case _ => { - // function call - eval_ast(ast, env).asInstanceOf[MalList].value match { - case f :: el => { - f match { - case fn: MalFunction => { - env = fn.gen_env(el) - ast = fn.ast // continue loop (TCO) - } - case fn: Func => { - return fn(el) - } - case _ => { - throw new Exception("attempt to call non-function: " + f) - } - } - } - case _ => throw new Exception("invalid apply") - } - } - } - } - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val repl_env: Env = new Env() - val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) - - // core.scala: defined using scala - core.ns.map{case (k: String,v: Any) => { - repl_env.set(Symbol(k), new Func(v)) - }} - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Throwable => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import types.{MalList, _list, _list_Q, MalVector, MalHashMap, + Func, MalFunction} +import env.Env + +object step5_tco { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def eval_ast(ast: Any, env: Env): Any = { + ast match { + case s : Symbol => env.get(s) + case v: MalVector => v.map(EVAL(_, env)) + case l: MalList => l.map(EVAL(_, env)) + case m: MalHashMap => { + m.map{case (k,v) => (k, EVAL(v, env))} + } + case _ => ast + } + } + + def EVAL(orig_ast: Any, orig_env: Env): Any = { + var ast = orig_ast; var env = orig_env; + while (true) { + + //println("EVAL: " + printer._pr_str(ast,true)) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + // apply list + ast.asInstanceOf[MalList].value match { + case Nil => { + return ast + } + case Symbol("def!") :: a1 :: a2 :: Nil => { + return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) + } + case Symbol("let*") :: a1 :: a2 :: Nil => { + val let_env = new Env(env) + for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { + let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) + } + env = let_env + ast = a2 // continue loop (TCO) + } + case Symbol("do") :: rest => { + eval_ast(_list(rest.slice(0,rest.length-1):_*), env) + ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) + } + case Symbol("if") :: a1 :: a2 :: rest => { + val cond = EVAL(a1, env) + if (cond == null || cond == false) { + if (rest.length == 0) return null + ast = rest(0) // continue loop (TCO) + } else { + ast = a2 // continue loop (TCO) + } + } + case Symbol("fn*") :: a1 :: a2 :: Nil => { + return new MalFunction(a2, env, a1.asInstanceOf[MalList], + (args: List[Any]) => { + EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) + } + ) + } + case _ => { + // function call + eval_ast(ast, env).asInstanceOf[MalList].value match { + case f :: el => { + f match { + case fn: MalFunction => { + env = fn.gen_env(el) + ast = fn.ast // continue loop (TCO) + } + case fn: Func => { + return fn(el) + } + case _ => { + throw new Exception("attempt to call non-function: " + f) + } + } + } + case _ => throw new Exception("invalid apply") + } + } + } + } + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val repl_env: Env = new Env() + val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) + + // core.scala: defined using scala + core.ns.map{case (k: String,v: Any) => { + repl_env.set(Symbol(k), new Func(v)) + }} + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Throwable => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/step6_file.scala b/impls/scala/step6_file.scala index 0a9d979ec9..d12d3db964 100644 --- a/impls/scala/step6_file.scala +++ b/impls/scala/step6_file.scala @@ -1,133 +1,133 @@ -import types.{MalList, _list, _list_Q, MalVector, MalHashMap, - Func, MalFunction} -import env.Env - -object step6_file { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def eval_ast(ast: Any, env: Env): Any = { - ast match { - case s : Symbol => env.get(s) - case v: MalVector => v.map(EVAL(_, env)) - case l: MalList => l.map(EVAL(_, env)) - case m: MalHashMap => { - m.map{case (k,v) => (k, EVAL(v, env))} - } - case _ => ast - } - } - - def EVAL(orig_ast: Any, orig_env: Env): Any = { - var ast = orig_ast; var env = orig_env; - while (true) { - - //println("EVAL: " + printer._pr_str(ast,true)) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - // apply list - ast.asInstanceOf[MalList].value match { - case Nil => { - return ast - } - case Symbol("def!") :: a1 :: a2 :: Nil => { - return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) - } - case Symbol("let*") :: a1 :: a2 :: Nil => { - val let_env = new Env(env) - for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { - let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) - } - env = let_env - ast = a2 // continue loop (TCO) - } - case Symbol("do") :: rest => { - eval_ast(_list(rest.slice(0,rest.length-1):_*), env) - ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) - } - case Symbol("if") :: a1 :: a2 :: rest => { - val cond = EVAL(a1, env) - if (cond == null || cond == false) { - if (rest.length == 0) return null - ast = rest(0) // continue loop (TCO) - } else { - ast = a2 // continue loop (TCO) - } - } - case Symbol("fn*") :: a1 :: a2 :: Nil => { - return new MalFunction(a2, env, a1.asInstanceOf[MalList], - (args: List[Any]) => { - EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) - } - ) - } - case _ => { - // function call - eval_ast(ast, env).asInstanceOf[MalList].value match { - case f :: el => { - f match { - case fn: MalFunction => { - env = fn.gen_env(el) - ast = fn.ast // continue loop (TCO) - } - case fn: Func => { - return fn(el) - } - case _ => { - throw new Exception("attempt to call non-function: " + f) - } - } - } - case _ => throw new Exception("invalid apply") - } - } - } - } - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val repl_env: Env = new Env() - val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) - - // core.scala: defined using scala - core.ns.map{case (k: String,v: Any) => { - repl_env.set(Symbol(k), new Func(v)) - }} - repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) - repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - - if (args.length > 0) { - REP("(load-file \"" + args(0) + "\")") - System.exit(0) - } - - // repl loop - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Throwable => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import types.{MalList, _list, _list_Q, MalVector, MalHashMap, + Func, MalFunction} +import env.Env + +object step6_file { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def eval_ast(ast: Any, env: Env): Any = { + ast match { + case s : Symbol => env.get(s) + case v: MalVector => v.map(EVAL(_, env)) + case l: MalList => l.map(EVAL(_, env)) + case m: MalHashMap => { + m.map{case (k,v) => (k, EVAL(v, env))} + } + case _ => ast + } + } + + def EVAL(orig_ast: Any, orig_env: Env): Any = { + var ast = orig_ast; var env = orig_env; + while (true) { + + //println("EVAL: " + printer._pr_str(ast,true)) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + // apply list + ast.asInstanceOf[MalList].value match { + case Nil => { + return ast + } + case Symbol("def!") :: a1 :: a2 :: Nil => { + return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) + } + case Symbol("let*") :: a1 :: a2 :: Nil => { + val let_env = new Env(env) + for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { + let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) + } + env = let_env + ast = a2 // continue loop (TCO) + } + case Symbol("do") :: rest => { + eval_ast(_list(rest.slice(0,rest.length-1):_*), env) + ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) + } + case Symbol("if") :: a1 :: a2 :: rest => { + val cond = EVAL(a1, env) + if (cond == null || cond == false) { + if (rest.length == 0) return null + ast = rest(0) // continue loop (TCO) + } else { + ast = a2 // continue loop (TCO) + } + } + case Symbol("fn*") :: a1 :: a2 :: Nil => { + return new MalFunction(a2, env, a1.asInstanceOf[MalList], + (args: List[Any]) => { + EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) + } + ) + } + case _ => { + // function call + eval_ast(ast, env).asInstanceOf[MalList].value match { + case f :: el => { + f match { + case fn: MalFunction => { + env = fn.gen_env(el) + ast = fn.ast // continue loop (TCO) + } + case fn: Func => { + return fn(el) + } + case _ => { + throw new Exception("attempt to call non-function: " + f) + } + } + } + case _ => throw new Exception("invalid apply") + } + } + } + } + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val repl_env: Env = new Env() + val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) + + // core.scala: defined using scala + core.ns.map{case (k: String,v: Any) => { + repl_env.set(Symbol(k), new Func(v)) + }} + repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) + repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + + if (args.length > 0) { + REP("(load-file \"" + args(0) + "\")") + System.exit(0) + } + + // repl loop + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Throwable => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/step7_quote.scala b/impls/scala/step7_quote.scala index 4afd5f5986..a831e36af0 100644 --- a/impls/scala/step7_quote.scala +++ b/impls/scala/step7_quote.scala @@ -1,179 +1,179 @@ -import types.{MalList, _list, _list_Q, MalVector, MalHashMap, - Func, MalFunction} -import env.Env - -object step7_quote { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def quasiquote_loop(elts: List[Any]): MalList = { - var acc = _list() - for (elt <- elts.reverse) { - if (types._list_Q(elt)) { - elt.asInstanceOf[MalList].value match { - case Symbol("splice-unquote") :: x :: Nil => { - acc = _list(Symbol("concat"), x, acc) - } - case _ => { - acc = _list(Symbol("cons"), quasiquote(elt), acc) - } - } - } else { - acc = _list(Symbol("cons"), quasiquote(elt), acc) - } - } - return acc - } - - def quasiquote(ast: Any): Any = { - ast match { - // Test vectors before they match MalList. - case v: MalVector => { - _list(Symbol("vec"), quasiquote_loop(v.value)) - } - case l: MalList => { - l.value match { - case Symbol("unquote") :: x :: Nil => x - case _ => quasiquote_loop(l.value) - } - } - case _ : Symbol => _list(Symbol("quote"), ast) - case _ : MalHashMap => _list(Symbol("quote"), ast) - case _ => ast - } - } - - def eval_ast(ast: Any, env: Env): Any = { - ast match { - case s : Symbol => env.get(s) - case v: MalVector => v.map(EVAL(_, env)) - case l: MalList => l.map(EVAL(_, env)) - case m: MalHashMap => { - m.map{case (k,v) => (k, EVAL(v, env))} - } - case _ => ast - } - } - - def EVAL(orig_ast: Any, orig_env: Env): Any = { - var ast = orig_ast; var env = orig_env; - while (true) { - - //println("EVAL: " + printer._pr_str(ast,true)) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - // apply list - ast.asInstanceOf[MalList].value match { - case Nil => { - return ast - } - case Symbol("def!") :: a1 :: a2 :: Nil => { - return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) - } - case Symbol("let*") :: a1 :: a2 :: Nil => { - val let_env = new Env(env) - for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { - let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) - } - env = let_env - ast = a2 // continue loop (TCO) - } - case Symbol("quote") :: a1 :: Nil => { - return a1 - } - case Symbol("quasiquoteexpand") :: a1 :: Nil => { - return quasiquote(a1) - } - case Symbol("quasiquote") :: a1 :: Nil => { - ast = quasiquote(a1) // continue loop (TCO) - } - case Symbol("do") :: rest => { - eval_ast(_list(rest.slice(0,rest.length-1):_*), env) - ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) - } - case Symbol("if") :: a1 :: a2 :: rest => { - val cond = EVAL(a1, env) - if (cond == null || cond == false) { - if (rest.length == 0) return null - ast = rest(0) // continue loop (TCO) - } else { - ast = a2 // continue loop (TCO) - } - } - case Symbol("fn*") :: a1 :: a2 :: Nil => { - return new MalFunction(a2, env, a1.asInstanceOf[MalList], - (args: List[Any]) => { - EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) - } - ) - } - case _ => { - // function call - eval_ast(ast, env).asInstanceOf[MalList].value match { - case f :: el => { - f match { - case fn: MalFunction => { - env = fn.gen_env(el) - ast = fn.ast // continue loop (TCO) - } - case fn: Func => { - return fn(el) - } - case _ => { - throw new Exception("attempt to call non-function: " + f) - } - } - } - case _ => throw new Exception("invalid apply") - } - } - } - } - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val repl_env: Env = new Env() - val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) - - // core.scala: defined using scala - core.ns.map{case (k: String,v: Any) => { - repl_env.set(Symbol(k), new Func(v)) - }} - repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) - repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - - if (args.length > 0) { - REP("(load-file \"" + args(0) + "\")") - System.exit(0) - } - - // repl loop - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Throwable => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import types.{MalList, _list, _list_Q, MalVector, MalHashMap, + Func, MalFunction} +import env.Env + +object step7_quote { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def quasiquote_loop(elts: List[Any]): MalList = { + var acc = _list() + for (elt <- elts.reverse) { + if (types._list_Q(elt)) { + elt.asInstanceOf[MalList].value match { + case Symbol("splice-unquote") :: x :: Nil => { + acc = _list(Symbol("concat"), x, acc) + } + case _ => { + acc = _list(Symbol("cons"), quasiquote(elt), acc) + } + } + } else { + acc = _list(Symbol("cons"), quasiquote(elt), acc) + } + } + return acc + } + + def quasiquote(ast: Any): Any = { + ast match { + // Test vectors before they match MalList. + case v: MalVector => { + _list(Symbol("vec"), quasiquote_loop(v.value)) + } + case l: MalList => { + l.value match { + case Symbol("unquote") :: x :: Nil => x + case _ => quasiquote_loop(l.value) + } + } + case _ : Symbol => _list(Symbol("quote"), ast) + case _ : MalHashMap => _list(Symbol("quote"), ast) + case _ => ast + } + } + + def eval_ast(ast: Any, env: Env): Any = { + ast match { + case s : Symbol => env.get(s) + case v: MalVector => v.map(EVAL(_, env)) + case l: MalList => l.map(EVAL(_, env)) + case m: MalHashMap => { + m.map{case (k,v) => (k, EVAL(v, env))} + } + case _ => ast + } + } + + def EVAL(orig_ast: Any, orig_env: Env): Any = { + var ast = orig_ast; var env = orig_env; + while (true) { + + //println("EVAL: " + printer._pr_str(ast,true)) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + // apply list + ast.asInstanceOf[MalList].value match { + case Nil => { + return ast + } + case Symbol("def!") :: a1 :: a2 :: Nil => { + return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) + } + case Symbol("let*") :: a1 :: a2 :: Nil => { + val let_env = new Env(env) + for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { + let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) + } + env = let_env + ast = a2 // continue loop (TCO) + } + case Symbol("quote") :: a1 :: Nil => { + return a1 + } + case Symbol("quasiquoteexpand") :: a1 :: Nil => { + return quasiquote(a1) + } + case Symbol("quasiquote") :: a1 :: Nil => { + ast = quasiquote(a1) // continue loop (TCO) + } + case Symbol("do") :: rest => { + eval_ast(_list(rest.slice(0,rest.length-1):_*), env) + ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) + } + case Symbol("if") :: a1 :: a2 :: rest => { + val cond = EVAL(a1, env) + if (cond == null || cond == false) { + if (rest.length == 0) return null + ast = rest(0) // continue loop (TCO) + } else { + ast = a2 // continue loop (TCO) + } + } + case Symbol("fn*") :: a1 :: a2 :: Nil => { + return new MalFunction(a2, env, a1.asInstanceOf[MalList], + (args: List[Any]) => { + EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) + } + ) + } + case _ => { + // function call + eval_ast(ast, env).asInstanceOf[MalList].value match { + case f :: el => { + f match { + case fn: MalFunction => { + env = fn.gen_env(el) + ast = fn.ast // continue loop (TCO) + } + case fn: Func => { + return fn(el) + } + case _ => { + throw new Exception("attempt to call non-function: " + f) + } + } + } + case _ => throw new Exception("invalid apply") + } + } + } + } + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val repl_env: Env = new Env() + val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) + + // core.scala: defined using scala + core.ns.map{case (k: String,v: Any) => { + repl_env.set(Symbol(k), new Func(v)) + }} + repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) + repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + + if (args.length > 0) { + REP("(load-file \"" + args(0) + "\")") + System.exit(0) + } + + // repl loop + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Throwable => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/step8_macros.scala b/impls/scala/step8_macros.scala index 614aeb05ec..bb99c3f77c 100644 --- a/impls/scala/step8_macros.scala +++ b/impls/scala/step8_macros.scala @@ -1,224 +1,224 @@ -import types.{MalList, _list, _list_Q, MalVector, MalHashMap, - Func, MalFunction} -import env.Env - -object step8_macros { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def quasiquote_loop(elts: List[Any]): MalList = { - var acc = _list() - for (elt <- elts.reverse) { - if (types._list_Q(elt)) { - elt.asInstanceOf[MalList].value match { - case Symbol("splice-unquote") :: x :: Nil => { - acc = _list(Symbol("concat"), x, acc) - } - case _ => { - acc = _list(Symbol("cons"), quasiquote(elt), acc) - } - } - } else { - acc = _list(Symbol("cons"), quasiquote(elt), acc) - } - } - return acc - } - - def quasiquote(ast: Any): Any = { - ast match { - // Test vectors before they match MalList. - case v: MalVector => { - _list(Symbol("vec"), quasiquote_loop(v.value)) - } - case l: MalList => { - l.value match { - case Symbol("unquote") :: x :: Nil => x - case _ => quasiquote_loop(l.value) - } - } - case _ : Symbol => _list(Symbol("quote"), ast) - case _ : MalHashMap => _list(Symbol("quote"), ast) - case _ => ast - } - } - - def is_macro_call(ast: Any, env: Env): Boolean = { - ast match { - case ml: MalList => { - if (ml.value.length > 0 && - types._symbol_Q(ml(0)) && - env.find(ml(0).asInstanceOf[Symbol]) != null) { - env.get(ml(0).asInstanceOf[Symbol]) match { - case f: MalFunction => return f.ismacro - case _ => return false - } - } - return false - } - case _ => return false - } - } - - def macroexpand(orig_ast: Any, env: Env): Any = { - var ast = orig_ast; - while (is_macro_call(ast, env)) { - ast.asInstanceOf[MalList].value match { - case f :: args => { - val mac = env.get(f.asInstanceOf[Symbol]) - ast = mac.asInstanceOf[MalFunction](args) - } - case _ => throw new Exception("macroexpand: invalid call") - } - } - ast - } - - def eval_ast(ast: Any, env: Env): Any = { - ast match { - case s : Symbol => env.get(s) - case v: MalVector => v.map(EVAL(_, env)) - case l: MalList => l.map(EVAL(_, env)) - case m: MalHashMap => { - m.map{case (k,v) => (k, EVAL(v, env))} - } - case _ => ast - } - } - - def EVAL(orig_ast: Any, orig_env: Env): Any = { - var ast = orig_ast; var env = orig_env; - while (true) { - - //println("EVAL: " + printer._pr_str(ast,true)) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - // apply list - ast = macroexpand(ast, env) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - ast.asInstanceOf[MalList].value match { - case Nil => { - return ast - } - case Symbol("def!") :: a1 :: a2 :: Nil => { - return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) - } - case Symbol("let*") :: a1 :: a2 :: Nil => { - val let_env = new Env(env) - for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { - let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) - } - env = let_env - ast = a2 // continue loop (TCO) - } - case Symbol("quote") :: a1 :: Nil => { - return a1 - } - case Symbol("quasiquoteexpand") :: a1 :: Nil => { - return quasiquote(a1) - } - case Symbol("quasiquote") :: a1 :: Nil => { - ast = quasiquote(a1) // continue loop (TCO) - } - case Symbol("defmacro!") :: a1 :: a2 :: Nil => { - val f = EVAL(a2, env) - f.asInstanceOf[MalFunction].ismacro = true - return env.set(a1.asInstanceOf[Symbol], f) - } - case Symbol("macroexpand") :: a1 :: Nil => { - return macroexpand(a1, env) - } - case Symbol("do") :: rest => { - eval_ast(_list(rest.slice(0,rest.length-1):_*), env) - ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) - } - case Symbol("if") :: a1 :: a2 :: rest => { - val cond = EVAL(a1, env) - if (cond == null || cond == false) { - if (rest.length == 0) return null - ast = rest(0) // continue loop (TCO) - } else { - ast = a2 // continue loop (TCO) - } - } - case Symbol("fn*") :: a1 :: a2 :: Nil => { - return new MalFunction(a2, env, a1.asInstanceOf[MalList], - (args: List[Any]) => { - EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) - } - ) - } - case _ => { - // function call - eval_ast(ast, env).asInstanceOf[MalList].value match { - case f :: el => { - f match { - case fn: MalFunction => { - env = fn.gen_env(el) - ast = fn.ast // continue loop (TCO) - } - case fn: Func => { - return fn(el) - } - case _ => { - throw new Exception("attempt to call non-function: " + f) - } - } - } - case _ => throw new Exception("invalid apply") - } - } - } - } - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val repl_env: Env = new Env() - val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) - - // core.scala: defined using scala - core.ns.map{case (k: String,v: Any) => { - repl_env.set(Symbol(k), new Func(v)) - }} - repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) - repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - 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)))))))") - - - if (args.length > 0) { - REP("(load-file \"" + args(0) + "\")") - System.exit(0) - } - - // repl loop - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Throwable => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import types.{MalList, _list, _list_Q, MalVector, MalHashMap, + Func, MalFunction} +import env.Env + +object step8_macros { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def quasiquote_loop(elts: List[Any]): MalList = { + var acc = _list() + for (elt <- elts.reverse) { + if (types._list_Q(elt)) { + elt.asInstanceOf[MalList].value match { + case Symbol("splice-unquote") :: x :: Nil => { + acc = _list(Symbol("concat"), x, acc) + } + case _ => { + acc = _list(Symbol("cons"), quasiquote(elt), acc) + } + } + } else { + acc = _list(Symbol("cons"), quasiquote(elt), acc) + } + } + return acc + } + + def quasiquote(ast: Any): Any = { + ast match { + // Test vectors before they match MalList. + case v: MalVector => { + _list(Symbol("vec"), quasiquote_loop(v.value)) + } + case l: MalList => { + l.value match { + case Symbol("unquote") :: x :: Nil => x + case _ => quasiquote_loop(l.value) + } + } + case _ : Symbol => _list(Symbol("quote"), ast) + case _ : MalHashMap => _list(Symbol("quote"), ast) + case _ => ast + } + } + + def is_macro_call(ast: Any, env: Env): Boolean = { + ast match { + case ml: MalList => { + if (ml.value.length > 0 && + types._symbol_Q(ml(0)) && + env.find(ml(0).asInstanceOf[Symbol]) != null) { + env.get(ml(0).asInstanceOf[Symbol]) match { + case f: MalFunction => return f.ismacro + case _ => return false + } + } + return false + } + case _ => return false + } + } + + def macroexpand(orig_ast: Any, env: Env): Any = { + var ast = orig_ast; + while (is_macro_call(ast, env)) { + ast.asInstanceOf[MalList].value match { + case f :: args => { + val mac = env.get(f.asInstanceOf[Symbol]) + ast = mac.asInstanceOf[MalFunction](args) + } + case _ => throw new Exception("macroexpand: invalid call") + } + } + ast + } + + def eval_ast(ast: Any, env: Env): Any = { + ast match { + case s : Symbol => env.get(s) + case v: MalVector => v.map(EVAL(_, env)) + case l: MalList => l.map(EVAL(_, env)) + case m: MalHashMap => { + m.map{case (k,v) => (k, EVAL(v, env))} + } + case _ => ast + } + } + + def EVAL(orig_ast: Any, orig_env: Env): Any = { + var ast = orig_ast; var env = orig_env; + while (true) { + + //println("EVAL: " + printer._pr_str(ast,true)) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + // apply list + ast = macroexpand(ast, env) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + ast.asInstanceOf[MalList].value match { + case Nil => { + return ast + } + case Symbol("def!") :: a1 :: a2 :: Nil => { + return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) + } + case Symbol("let*") :: a1 :: a2 :: Nil => { + val let_env = new Env(env) + for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { + let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) + } + env = let_env + ast = a2 // continue loop (TCO) + } + case Symbol("quote") :: a1 :: Nil => { + return a1 + } + case Symbol("quasiquoteexpand") :: a1 :: Nil => { + return quasiquote(a1) + } + case Symbol("quasiquote") :: a1 :: Nil => { + ast = quasiquote(a1) // continue loop (TCO) + } + case Symbol("defmacro!") :: a1 :: a2 :: Nil => { + val f = EVAL(a2, env) + f.asInstanceOf[MalFunction].ismacro = true + return env.set(a1.asInstanceOf[Symbol], f) + } + case Symbol("macroexpand") :: a1 :: Nil => { + return macroexpand(a1, env) + } + case Symbol("do") :: rest => { + eval_ast(_list(rest.slice(0,rest.length-1):_*), env) + ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) + } + case Symbol("if") :: a1 :: a2 :: rest => { + val cond = EVAL(a1, env) + if (cond == null || cond == false) { + if (rest.length == 0) return null + ast = rest(0) // continue loop (TCO) + } else { + ast = a2 // continue loop (TCO) + } + } + case Symbol("fn*") :: a1 :: a2 :: Nil => { + return new MalFunction(a2, env, a1.asInstanceOf[MalList], + (args: List[Any]) => { + EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) + } + ) + } + case _ => { + // function call + eval_ast(ast, env).asInstanceOf[MalList].value match { + case f :: el => { + f match { + case fn: MalFunction => { + env = fn.gen_env(el) + ast = fn.ast // continue loop (TCO) + } + case fn: Func => { + return fn(el) + } + case _ => { + throw new Exception("attempt to call non-function: " + f) + } + } + } + case _ => throw new Exception("invalid apply") + } + } + } + } + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val repl_env: Env = new Env() + val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) + + // core.scala: defined using scala + core.ns.map{case (k: String,v: Any) => { + repl_env.set(Symbol(k), new Func(v)) + }} + repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) + repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + 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)))))))") + + + if (args.length > 0) { + REP("(load-file \"" + args(0) + "\")") + System.exit(0) + } + + // repl loop + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Throwable => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/step9_try.scala b/impls/scala/step9_try.scala index 153839f092..4e60517ff4 100644 --- a/impls/scala/step9_try.scala +++ b/impls/scala/step9_try.scala @@ -1,245 +1,245 @@ -import types.{MalList, _list, _list_Q, MalVector, MalHashMap, - Func, MalFunction} -import env.Env - -object step9_try { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def quasiquote_loop(elts: List[Any]): MalList = { - var acc = _list() - for (elt <- elts.reverse) { - if (types._list_Q(elt)) { - elt.asInstanceOf[MalList].value match { - case Symbol("splice-unquote") :: x :: Nil => { - acc = _list(Symbol("concat"), x, acc) - } - case _ => { - acc = _list(Symbol("cons"), quasiquote(elt), acc) - } - } - } else { - acc = _list(Symbol("cons"), quasiquote(elt), acc) - } - } - return acc - } - - def quasiquote(ast: Any): Any = { - ast match { - // Test vectors before they match MalList. - case v: MalVector => { - _list(Symbol("vec"), quasiquote_loop(v.value)) - } - case l: MalList => { - l.value match { - case Symbol("unquote") :: x :: Nil => x - case _ => quasiquote_loop(l.value) - } - } - case _ : Symbol => _list(Symbol("quote"), ast) - case _ : MalHashMap => _list(Symbol("quote"), ast) - case _ => ast - } - } - - def is_macro_call(ast: Any, env: Env): Boolean = { - ast match { - case ml: MalList => { - if (ml.value.length > 0 && - types._symbol_Q(ml(0)) && - env.find(ml(0).asInstanceOf[Symbol]) != null) { - env.get(ml(0).asInstanceOf[Symbol]) match { - case f: MalFunction => return f.ismacro - case _ => return false - } - } - return false - } - case _ => return false - } - } - - def macroexpand(orig_ast: Any, env: Env): Any = { - var ast = orig_ast; - while (is_macro_call(ast, env)) { - ast.asInstanceOf[MalList].value match { - case f :: args => { - val mac = env.get(f.asInstanceOf[Symbol]) - ast = mac.asInstanceOf[MalFunction](args) - } - case _ => throw new Exception("macroexpand: invalid call") - } - } - ast - } - - def eval_ast(ast: Any, env: Env): Any = { - ast match { - case s : Symbol => env.get(s) - case v: MalVector => v.map(EVAL(_, env)) - case l: MalList => l.map(EVAL(_, env)) - case m: MalHashMap => { - m.map{case (k,v) => (k, EVAL(v, env))} - } - case _ => ast - } - } - - def EVAL(orig_ast: Any, orig_env: Env): Any = { - var ast = orig_ast; var env = orig_env; - while (true) { - - //println("EVAL: " + printer._pr_str(ast,true)) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - // apply list - ast = macroexpand(ast, env) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - ast.asInstanceOf[MalList].value match { - case Nil => { - return ast - } - case Symbol("def!") :: a1 :: a2 :: Nil => { - return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) - } - case Symbol("let*") :: a1 :: a2 :: Nil => { - val let_env = new Env(env) - for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { - let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) - } - env = let_env - ast = a2 // continue loop (TCO) - } - case Symbol("quote") :: a1 :: Nil => { - return a1 - } - case Symbol("quasiquoteexpand") :: a1 :: Nil => { - return quasiquote(a1) - } - case Symbol("quasiquote") :: a1 :: Nil => { - ast = quasiquote(a1) // continue loop (TCO) - } - case Symbol("defmacro!") :: a1 :: a2 :: Nil => { - val f = EVAL(a2, env) - f.asInstanceOf[MalFunction].ismacro = true - return env.set(a1.asInstanceOf[Symbol], f) - } - case Symbol("macroexpand") :: a1 :: Nil => { - return macroexpand(a1, env) - } - case Symbol("try*") :: a1 :: rest => { - try { - return EVAL(a1, env) - } catch { - case t: Throwable => { - if (rest.length == 0) throw t - rest(0).asInstanceOf[MalList].value match { - case List(Symbol("catch*"), a21, a22) => { - val exc: Any = t match { - case mex: types.MalException => mex.value - case _ => t.getMessage - } - return EVAL(a22, new Env(env, - List(a21).iterator, - List(exc).iterator)) - } - } - throw t - } - } - } - case Symbol("do") :: rest => { - eval_ast(_list(rest.slice(0,rest.length-1):_*), env) - ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) - } - case Symbol("if") :: a1 :: a2 :: rest => { - val cond = EVAL(a1, env) - if (cond == null || cond == false) { - if (rest.length == 0) return null - ast = rest(0) // continue loop (TCO) - } else { - ast = a2 // continue loop (TCO) - } - } - case Symbol("fn*") :: a1 :: a2 :: Nil => { - return new MalFunction(a2, env, a1.asInstanceOf[MalList], - (args: List[Any]) => { - EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) - } - ) - } - case _ => { - // function call - eval_ast(ast, env).asInstanceOf[MalList].value match { - case f :: el => { - f match { - case fn: MalFunction => { - env = fn.gen_env(el) - ast = fn.ast // continue loop (TCO) - } - case fn: Func => { - return fn(el) - } - case _ => { - throw new Exception("attempt to call non-function: " + f) - } - } - } - case _ => throw new Exception("invalid apply") - } - } - } - } - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val repl_env: Env = new Env() - val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) - - // core.scala: defined using scala - core.ns.map{case (k: String,v: Any) => { - repl_env.set(Symbol(k), new Func(v)) - }} - repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) - repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) - - // core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - 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)))))))") - - - if (args.length > 0) { - REP("(load-file \"" + args(0) + "\")") - System.exit(0) - } - - // repl loop - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Throwable => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import types.{MalList, _list, _list_Q, MalVector, MalHashMap, + Func, MalFunction} +import env.Env + +object step9_try { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def quasiquote_loop(elts: List[Any]): MalList = { + var acc = _list() + for (elt <- elts.reverse) { + if (types._list_Q(elt)) { + elt.asInstanceOf[MalList].value match { + case Symbol("splice-unquote") :: x :: Nil => { + acc = _list(Symbol("concat"), x, acc) + } + case _ => { + acc = _list(Symbol("cons"), quasiquote(elt), acc) + } + } + } else { + acc = _list(Symbol("cons"), quasiquote(elt), acc) + } + } + return acc + } + + def quasiquote(ast: Any): Any = { + ast match { + // Test vectors before they match MalList. + case v: MalVector => { + _list(Symbol("vec"), quasiquote_loop(v.value)) + } + case l: MalList => { + l.value match { + case Symbol("unquote") :: x :: Nil => x + case _ => quasiquote_loop(l.value) + } + } + case _ : Symbol => _list(Symbol("quote"), ast) + case _ : MalHashMap => _list(Symbol("quote"), ast) + case _ => ast + } + } + + def is_macro_call(ast: Any, env: Env): Boolean = { + ast match { + case ml: MalList => { + if (ml.value.length > 0 && + types._symbol_Q(ml(0)) && + env.find(ml(0).asInstanceOf[Symbol]) != null) { + env.get(ml(0).asInstanceOf[Symbol]) match { + case f: MalFunction => return f.ismacro + case _ => return false + } + } + return false + } + case _ => return false + } + } + + def macroexpand(orig_ast: Any, env: Env): Any = { + var ast = orig_ast; + while (is_macro_call(ast, env)) { + ast.asInstanceOf[MalList].value match { + case f :: args => { + val mac = env.get(f.asInstanceOf[Symbol]) + ast = mac.asInstanceOf[MalFunction](args) + } + case _ => throw new Exception("macroexpand: invalid call") + } + } + ast + } + + def eval_ast(ast: Any, env: Env): Any = { + ast match { + case s : Symbol => env.get(s) + case v: MalVector => v.map(EVAL(_, env)) + case l: MalList => l.map(EVAL(_, env)) + case m: MalHashMap => { + m.map{case (k,v) => (k, EVAL(v, env))} + } + case _ => ast + } + } + + def EVAL(orig_ast: Any, orig_env: Env): Any = { + var ast = orig_ast; var env = orig_env; + while (true) { + + //println("EVAL: " + printer._pr_str(ast,true)) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + // apply list + ast = macroexpand(ast, env) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + ast.asInstanceOf[MalList].value match { + case Nil => { + return ast + } + case Symbol("def!") :: a1 :: a2 :: Nil => { + return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) + } + case Symbol("let*") :: a1 :: a2 :: Nil => { + val let_env = new Env(env) + for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { + let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) + } + env = let_env + ast = a2 // continue loop (TCO) + } + case Symbol("quote") :: a1 :: Nil => { + return a1 + } + case Symbol("quasiquoteexpand") :: a1 :: Nil => { + return quasiquote(a1) + } + case Symbol("quasiquote") :: a1 :: Nil => { + ast = quasiquote(a1) // continue loop (TCO) + } + case Symbol("defmacro!") :: a1 :: a2 :: Nil => { + val f = EVAL(a2, env) + f.asInstanceOf[MalFunction].ismacro = true + return env.set(a1.asInstanceOf[Symbol], f) + } + case Symbol("macroexpand") :: a1 :: Nil => { + return macroexpand(a1, env) + } + case Symbol("try*") :: a1 :: rest => { + try { + return EVAL(a1, env) + } catch { + case t: Throwable => { + if (rest.length == 0) throw t + rest(0).asInstanceOf[MalList].value match { + case List(Symbol("catch*"), a21, a22) => { + val exc: Any = t match { + case mex: types.MalException => mex.value + case _ => t.getMessage + } + return EVAL(a22, new Env(env, + List(a21).iterator, + List(exc).iterator)) + } + } + throw t + } + } + } + case Symbol("do") :: rest => { + eval_ast(_list(rest.slice(0,rest.length-1):_*), env) + ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) + } + case Symbol("if") :: a1 :: a2 :: rest => { + val cond = EVAL(a1, env) + if (cond == null || cond == false) { + if (rest.length == 0) return null + ast = rest(0) // continue loop (TCO) + } else { + ast = a2 // continue loop (TCO) + } + } + case Symbol("fn*") :: a1 :: a2 :: Nil => { + return new MalFunction(a2, env, a1.asInstanceOf[MalList], + (args: List[Any]) => { + EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) + } + ) + } + case _ => { + // function call + eval_ast(ast, env).asInstanceOf[MalList].value match { + case f :: el => { + f match { + case fn: MalFunction => { + env = fn.gen_env(el) + ast = fn.ast // continue loop (TCO) + } + case fn: Func => { + return fn(el) + } + case _ => { + throw new Exception("attempt to call non-function: " + f) + } + } + } + case _ => throw new Exception("invalid apply") + } + } + } + } + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val repl_env: Env = new Env() + val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) + + // core.scala: defined using scala + core.ns.map{case (k: String,v: Any) => { + repl_env.set(Symbol(k), new Func(v)) + }} + repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) + repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) + + // core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + 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)))))))") + + + if (args.length > 0) { + REP("(load-file \"" + args(0) + "\")") + System.exit(0) + } + + // repl loop + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Throwable => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/stepA_mal.scala b/impls/scala/stepA_mal.scala index f5781cec92..c6475a6631 100644 --- a/impls/scala/stepA_mal.scala +++ b/impls/scala/stepA_mal.scala @@ -1,247 +1,247 @@ -import types.{MalList, _list, _list_Q, MalVector, MalHashMap, - Func, MalFunction} -import env.Env - -object stepA_mal { - // read - def READ(str: String): Any = { - reader.read_str(str) - } - - // eval - def quasiquote_loop(elts: List[Any]): MalList = { - var acc = _list() - for (elt <- elts.reverse) { - if (types._list_Q(elt)) { - elt.asInstanceOf[MalList].value match { - case Symbol("splice-unquote") :: x :: Nil => { - acc = _list(Symbol("concat"), x, acc) - } - case _ => { - acc = _list(Symbol("cons"), quasiquote(elt), acc) - } - } - } else { - acc = _list(Symbol("cons"), quasiquote(elt), acc) - } - } - return acc - } - - def quasiquote(ast: Any): Any = { - ast match { - // Test vectors before they match MalList. - case v: MalVector => { - _list(Symbol("vec"), quasiquote_loop(v.value)) - } - case l: MalList => { - l.value match { - case Symbol("unquote") :: x :: Nil => x - case _ => quasiquote_loop(l.value) - } - } - case _ : Symbol => _list(Symbol("quote"), ast) - case _ : MalHashMap => _list(Symbol("quote"), ast) - case _ => ast - } - } - - def is_macro_call(ast: Any, env: Env): Boolean = { - ast match { - case ml: MalList => { - if (ml.value.length > 0 && - types._symbol_Q(ml(0)) && - env.find(ml(0).asInstanceOf[Symbol]) != null) { - env.get(ml(0).asInstanceOf[Symbol]) match { - case f: MalFunction => return f.ismacro - case _ => return false - } - } - return false - } - case _ => return false - } - } - - def macroexpand(orig_ast: Any, env: Env): Any = { - var ast = orig_ast; - while (is_macro_call(ast, env)) { - ast.asInstanceOf[MalList].value match { - case f :: args => { - val mac = env.get(f.asInstanceOf[Symbol]) - ast = mac.asInstanceOf[MalFunction](args) - } - case _ => throw new Exception("macroexpand: invalid call") - } - } - ast - } - - def eval_ast(ast: Any, env: Env): Any = { - ast match { - case s : Symbol => env.get(s) - case v: MalVector => v.map(EVAL(_, env)) - case l: MalList => l.map(EVAL(_, env)) - case m: MalHashMap => { - m.map{case (k,v) => (k, EVAL(v, env))} - } - case _ => ast - } - } - - def EVAL(orig_ast: Any, orig_env: Env): Any = { - var ast = orig_ast; var env = orig_env; - while (true) { - - //println("EVAL: " + printer._pr_str(ast,true)) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - // apply list - ast = macroexpand(ast, env) - if (!_list_Q(ast)) - return eval_ast(ast, env) - - ast.asInstanceOf[MalList].value match { - case Nil => { - return ast - } - case Symbol("def!") :: a1 :: a2 :: Nil => { - return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) - } - case Symbol("let*") :: a1 :: a2 :: Nil => { - val let_env = new Env(env) - for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { - let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) - } - env = let_env - ast = a2 // continue loop (TCO) - } - case Symbol("quote") :: a1 :: Nil => { - return a1 - } - case Symbol("quasiquoteexpand") :: a1 :: Nil => { - return quasiquote(a1) - } - case Symbol("quasiquote") :: a1 :: Nil => { - ast = quasiquote(a1) // continue loop (TCO) - } - case Symbol("defmacro!") :: a1 :: a2 :: Nil => { - val f = EVAL(a2, env) - f.asInstanceOf[MalFunction].ismacro = true - return env.set(a1.asInstanceOf[Symbol], f) - } - case Symbol("macroexpand") :: a1 :: Nil => { - return macroexpand(a1, env) - } - case Symbol("try*") :: a1 :: rest => { - try { - return EVAL(a1, env) - } catch { - case t: Throwable => { - if (rest.length == 0) throw t - rest(0).asInstanceOf[MalList].value match { - case List(Symbol("catch*"), a21, a22) => { - val exc: Any = t match { - case mex: types.MalException => mex.value - case _ => t.getMessage - } - return EVAL(a22, new Env(env, - List(a21).iterator, - List(exc).iterator)) - } - } - throw t - } - } - } - case Symbol("do") :: rest => { - eval_ast(_list(rest.slice(0,rest.length-1):_*), env) - ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) - } - case Symbol("if") :: a1 :: a2 :: rest => { - val cond = EVAL(a1, env) - if (cond == null || cond == false) { - if (rest.length == 0) return null - ast = rest(0) // continue loop (TCO) - } else { - ast = a2 // continue loop (TCO) - } - } - case Symbol("fn*") :: a1 :: a2 :: Nil => { - return new MalFunction(a2, env, a1.asInstanceOf[MalList], - (args: List[Any]) => { - EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) - } - ) - } - case _ => { - // function call - eval_ast(ast, env).asInstanceOf[MalList].value match { - case f :: el => { - f match { - case fn: MalFunction => { - env = fn.gen_env(el) - ast = fn.ast // continue loop (TCO) - } - case fn: Func => { - return fn(el) - } - case _ => { - throw new Exception("attempt to call non-function: " + f) - } - } - } - case _ => throw new Exception("invalid apply") - } - } - } - } - } - - // print - def PRINT(exp: Any): String = { - printer._pr_str(exp, true) - } - - // repl - def main(args: Array[String]) = { - val repl_env: Env = new Env() - val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) - - // core.scala: defined using scala - core.ns.map{case (k: String,v: Any) => { - repl_env.set(Symbol(k), new Func(v)) - }} - repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) - repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) - - // core.mal: defined using the language itself - REP("(def! *host-language* \"scala\")") - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - 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)))))))") - - - if (args.length > 0) { - REP("(load-file \"" + args(0) + "\")") - System.exit(0) - } - - // repl loop - REP("(println (str \"Mal [\" *host-language* \"]\"))") - var line:String = null - while ({line = readLine("user> "); line != null}) { - try { - println(REP(line)) - } catch { - case e : Throwable => { - println("Error: " + e.getMessage) - println(" " + e.getStackTrace.mkString("\n ")) - } - } - } - } -} - -// vim: ts=2:sw=2 +import types.{MalList, _list, _list_Q, MalVector, MalHashMap, + Func, MalFunction} +import env.Env + +object stepA_mal { + // read + def READ(str: String): Any = { + reader.read_str(str) + } + + // eval + def quasiquote_loop(elts: List[Any]): MalList = { + var acc = _list() + for (elt <- elts.reverse) { + if (types._list_Q(elt)) { + elt.asInstanceOf[MalList].value match { + case Symbol("splice-unquote") :: x :: Nil => { + acc = _list(Symbol("concat"), x, acc) + } + case _ => { + acc = _list(Symbol("cons"), quasiquote(elt), acc) + } + } + } else { + acc = _list(Symbol("cons"), quasiquote(elt), acc) + } + } + return acc + } + + def quasiquote(ast: Any): Any = { + ast match { + // Test vectors before they match MalList. + case v: MalVector => { + _list(Symbol("vec"), quasiquote_loop(v.value)) + } + case l: MalList => { + l.value match { + case Symbol("unquote") :: x :: Nil => x + case _ => quasiquote_loop(l.value) + } + } + case _ : Symbol => _list(Symbol("quote"), ast) + case _ : MalHashMap => _list(Symbol("quote"), ast) + case _ => ast + } + } + + def is_macro_call(ast: Any, env: Env): Boolean = { + ast match { + case ml: MalList => { + if (ml.value.length > 0 && + types._symbol_Q(ml(0)) && + env.find(ml(0).asInstanceOf[Symbol]) != null) { + env.get(ml(0).asInstanceOf[Symbol]) match { + case f: MalFunction => return f.ismacro + case _ => return false + } + } + return false + } + case _ => return false + } + } + + def macroexpand(orig_ast: Any, env: Env): Any = { + var ast = orig_ast; + while (is_macro_call(ast, env)) { + ast.asInstanceOf[MalList].value match { + case f :: args => { + val mac = env.get(f.asInstanceOf[Symbol]) + ast = mac.asInstanceOf[MalFunction](args) + } + case _ => throw new Exception("macroexpand: invalid call") + } + } + ast + } + + def eval_ast(ast: Any, env: Env): Any = { + ast match { + case s : Symbol => env.get(s) + case v: MalVector => v.map(EVAL(_, env)) + case l: MalList => l.map(EVAL(_, env)) + case m: MalHashMap => { + m.map{case (k,v) => (k, EVAL(v, env))} + } + case _ => ast + } + } + + def EVAL(orig_ast: Any, orig_env: Env): Any = { + var ast = orig_ast; var env = orig_env; + while (true) { + + //println("EVAL: " + printer._pr_str(ast,true)) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + // apply list + ast = macroexpand(ast, env) + if (!_list_Q(ast)) + return eval_ast(ast, env) + + ast.asInstanceOf[MalList].value match { + case Nil => { + return ast + } + case Symbol("def!") :: a1 :: a2 :: Nil => { + return env.set(a1.asInstanceOf[Symbol], EVAL(a2, env)) + } + case Symbol("let*") :: a1 :: a2 :: Nil => { + val let_env = new Env(env) + for (g <- a1.asInstanceOf[MalList].value.grouped(2)) { + let_env.set(g(0).asInstanceOf[Symbol],EVAL(g(1),let_env)) + } + env = let_env + ast = a2 // continue loop (TCO) + } + case Symbol("quote") :: a1 :: Nil => { + return a1 + } + case Symbol("quasiquoteexpand") :: a1 :: Nil => { + return quasiquote(a1) + } + case Symbol("quasiquote") :: a1 :: Nil => { + ast = quasiquote(a1) // continue loop (TCO) + } + case Symbol("defmacro!") :: a1 :: a2 :: Nil => { + val f = EVAL(a2, env) + f.asInstanceOf[MalFunction].ismacro = true + return env.set(a1.asInstanceOf[Symbol], f) + } + case Symbol("macroexpand") :: a1 :: Nil => { + return macroexpand(a1, env) + } + case Symbol("try*") :: a1 :: rest => { + try { + return EVAL(a1, env) + } catch { + case t: Throwable => { + if (rest.length == 0) throw t + rest(0).asInstanceOf[MalList].value match { + case List(Symbol("catch*"), a21, a22) => { + val exc: Any = t match { + case mex: types.MalException => mex.value + case _ => t.getMessage + } + return EVAL(a22, new Env(env, + List(a21).iterator, + List(exc).iterator)) + } + } + throw t + } + } + } + case Symbol("do") :: rest => { + eval_ast(_list(rest.slice(0,rest.length-1):_*), env) + ast = ast.asInstanceOf[MalList].value.last // continue loop (TCO) + } + case Symbol("if") :: a1 :: a2 :: rest => { + val cond = EVAL(a1, env) + if (cond == null || cond == false) { + if (rest.length == 0) return null + ast = rest(0) // continue loop (TCO) + } else { + ast = a2 // continue loop (TCO) + } + } + case Symbol("fn*") :: a1 :: a2 :: Nil => { + return new MalFunction(a2, env, a1.asInstanceOf[MalList], + (args: List[Any]) => { + EVAL(a2, new Env(env, types._toIter(a1), args.iterator)) + } + ) + } + case _ => { + // function call + eval_ast(ast, env).asInstanceOf[MalList].value match { + case f :: el => { + f match { + case fn: MalFunction => { + env = fn.gen_env(el) + ast = fn.ast // continue loop (TCO) + } + case fn: Func => { + return fn(el) + } + case _ => { + throw new Exception("attempt to call non-function: " + f) + } + } + } + case _ => throw new Exception("invalid apply") + } + } + } + } + } + + // print + def PRINT(exp: Any): String = { + printer._pr_str(exp, true) + } + + // repl + def main(args: Array[String]) = { + val repl_env: Env = new Env() + val REP = (str: String) => PRINT(EVAL(READ(str), repl_env)) + + // core.scala: defined using scala + core.ns.map{case (k: String,v: Any) => { + repl_env.set(Symbol(k), new Func(v)) + }} + repl_env.set(Symbol("eval"), new Func((a: List[Any]) => EVAL(a(0), repl_env))) + repl_env.set(Symbol("*ARGV*"), _list(args.slice(1,args.length):_*)) + + // core.mal: defined using the language itself + REP("(def! *host-language* \"scala\")") + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + 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)))))))") + + + if (args.length > 0) { + REP("(load-file \"" + args(0) + "\")") + System.exit(0) + } + + // repl loop + REP("(println (str \"Mal [\" *host-language* \"]\"))") + var line:String = null + while ({line = readLine("user> "); line != null}) { + try { + println(REP(line)) + } catch { + case e : Throwable => { + println("Error: " + e.getMessage) + println(" " + e.getStackTrace.mkString("\n ")) + } + } + } + } +} + +// vim: ts=2:sw=2 diff --git a/impls/scala/tests/step5_tco.mal b/impls/scala/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/scala/tests/step5_tco.mal +++ b/impls/scala/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/scala/types.scala b/impls/scala/types.scala index b0c84f912e..0f3e78f1a8 100644 --- a/impls/scala/types.scala +++ b/impls/scala/types.scala @@ -1,224 +1,224 @@ -import scala.collection._ -import scala.collection.generic._ - -import env.Env -import printer._pr_str - -object types { - class MalException(msg: String) extends Throwable(msg) { - var value: Any = null - def init(obj: Any) = { value = obj; this } - } - - def _toIter(obj: Any): Iterator[Any] = { - obj match { - case v: MalVector => v.value.iterator - case l: MalList => l.value.iterator - case null => Iterator.empty - case _ => throw new Exception("cannot convert " + - obj.getClass + " to iterator") - } - } - - def _equal_Q(a: Any, b: Any): Any = { - (a, b) match { - case (a: MalList, b: MalList) => { - if (a.value.length != b.value.length) return false - for ( (x, y) <- (a.value zip b.value) ) { - if (_equal_Q(x, y) != true) return false - } - true - } - case (a: MalHashMap, b: MalHashMap) => { - if (a.value.size != b.value.size) return false - for ( (k,v) <- a.value ) { - if (_equal_Q(v,b.value(k)) != true) return false - } - true - } - case _ => a == b - } - } - - def _sequential_Q(a: Any): Boolean = { - a match { - case l: MalList => true - case _ => false - } - } - - def _symbol_Q(a: Any) = { a.isInstanceOf[Symbol] } - - - // Lists - class MalList(seq: Any*) { - var value: List[Any] = seq.toList - var meta: Any = null - - override def clone(): MalList = { - val new_ml = new MalList() - new_ml.value = value - new_ml.meta = meta - new_ml - } - - def apply(idx: Int): Any = value(idx) - def map(f: Any => Any) = new MalList(value.map(f):_*) - def drop(cnt: Int) = new MalList(value.drop(cnt):_*) - def :+(that: Any) = new MalList((value :+ that):_*) - def +:(that: Any) = new MalList((that +: value):_*) - - override def toString() = { - "(" + value.map(_pr_str(_, true)).mkString(" ") + ")" - } - def toString(print_readably: Boolean) = { - "(" + value.map(_pr_str(_, print_readably)).mkString(" ") + ")" - } - } - def _list(seq: Any*) = { - new MalList(seq:_*) - } - def _list_Q(obj: Any) = { - obj.isInstanceOf[MalList] && !obj.isInstanceOf[MalVector] - } - - - // Vectors - class MalVector(seq: Any*) extends MalList(seq:_*) { - override def clone() = { - val new_mv = new MalVector() - new_mv.value = value - new_mv.meta = meta - new_mv - } - - override def map(f: Any => Any) = new MalVector(value.map(f):_*) - override def drop(cnt: Int) = new MalVector(value.drop(cnt):_*) - - override def toString() = { - "[" + value.map(_pr_str(_, true)).mkString(" ") + "]" - } - override def toString(print_readably: Boolean) = { - "[" + value.map(_pr_str(_, print_readably)).mkString(" ") + "]" - } - } - def _vector(seq: Any*) = { - new MalVector(seq:_*) - } - def _vector_Q(obj: Any) = { - obj.isInstanceOf[MalVector] - } - - - // Hash Maps - class MalHashMap(seq: Any*) { - var value: Map[String,Any] = seq.toList.grouped(2).map( - (kv: List[Any]) => (kv(0).asInstanceOf[String], kv(1))).toMap - var meta: Any = null - - override def clone(): MalHashMap = { - val new_hm = new MalHashMap() - new_hm.value = value - new_hm.meta = meta - new_hm - } - - def keys(): MalList = new MalList(value.keys.toSeq:_*) - def vals(): MalList = new MalList(value.values.toSeq:_*) - - def apply(key: String): Any = value(key) - def map(f: ((String, Any)) => (String, Any)) = { - val res = value.map(f).map{case (k,v) => List(k,v)} - new MalHashMap(res.flatten.toSeq:_*) - } - def filterKeys(f: String => Boolean) = { - val res = value.filterKeys(f).map{case (k,v) => List(k,v)} - new MalHashMap(res.flatten.toSeq:_*) - } - def ++(that: MalHashMap) = { - val new_hm = clone() - new_hm.value ++= that.value - new_hm - } - - override def toString() = { - var res = mutable.MutableList[Any]() - for ((k,v) <- value) { - res += _pr_str(k, true) - res += _pr_str(v, true) - } - "{" + res.mkString(" ") + "}" - } - def toString(print_readably: Boolean) = { - var res = mutable.MutableList[Any]() - for ((k,v) <- value) { - res += _pr_str(k, print_readably) - res += _pr_str(v, print_readably) - } - "{" + res.mkString(" ") + "}" - } - } - def _hash_map(seq: Any*) = { - new MalHashMap(seq:_*) - } - def _hash_map_Q(obj: Any) = { - obj.isInstanceOf[MalHashMap] - } - - - // Function types - - class Func(_fn: ((List[Any]) => Any)) { - val fn = _fn - var meta: Any = null - - override def clone(): Func = { - val new_fn = new Func(fn) - new_fn.meta = meta - new_fn - } - - def apply(args: List[Any]): Any = fn(args) - } - - class MalFunction(_ast: Any, _env: Env, _params: MalList, - fn: ((List[Any]) => Any)) { - val ast = _ast - val env = _env - val params = _params - var ismacro = false - var meta: Any = null - - override def clone(): MalFunction = { - val new_fn = new MalFunction(ast, env, params, fn) - new_fn.ismacro = ismacro - new_fn.meta = meta - new_fn - } - - def apply(args: List[Any]): Any = fn(args) - - def gen_env(args: List[Any]): Env = { - return new Env(env, params.value.iterator, args.iterator) - } - } - - def _apply(f: Any, args: List[Any]): Any = { - f match { - case fn: types.MalFunction => fn(args) - case fn: Func => fn(args) - case _ => throw new Exception("attempt to call non-function") - } - } - - def _hash_map(lst: List[Any]): Any = { - lst.grouped(2).map( - (kv: List[Any]) => (kv(0).asInstanceOf[String], kv(1))).toMap - } - - class Atom(_value: Any) { - var value = _value - } -} - -// vim:ts=2:sw=2 +import scala.collection._ +import scala.collection.generic._ + +import env.Env +import printer._pr_str + +object types { + class MalException(msg: String) extends Throwable(msg) { + var value: Any = null + def init(obj: Any) = { value = obj; this } + } + + def _toIter(obj: Any): Iterator[Any] = { + obj match { + case v: MalVector => v.value.iterator + case l: MalList => l.value.iterator + case null => Iterator.empty + case _ => throw new Exception("cannot convert " + + obj.getClass + " to iterator") + } + } + + def _equal_Q(a: Any, b: Any): Any = { + (a, b) match { + case (a: MalList, b: MalList) => { + if (a.value.length != b.value.length) return false + for ( (x, y) <- (a.value zip b.value) ) { + if (_equal_Q(x, y) != true) return false + } + true + } + case (a: MalHashMap, b: MalHashMap) => { + if (a.value.size != b.value.size) return false + for ( (k,v) <- a.value ) { + if (_equal_Q(v,b.value(k)) != true) return false + } + true + } + case _ => a == b + } + } + + def _sequential_Q(a: Any): Boolean = { + a match { + case l: MalList => true + case _ => false + } + } + + def _symbol_Q(a: Any) = { a.isInstanceOf[Symbol] } + + + // Lists + class MalList(seq: Any*) { + var value: List[Any] = seq.toList + var meta: Any = null + + override def clone(): MalList = { + val new_ml = new MalList() + new_ml.value = value + new_ml.meta = meta + new_ml + } + + def apply(idx: Int): Any = value(idx) + def map(f: Any => Any) = new MalList(value.map(f):_*) + def drop(cnt: Int) = new MalList(value.drop(cnt):_*) + def :+(that: Any) = new MalList((value :+ that):_*) + def +:(that: Any) = new MalList((that +: value):_*) + + override def toString() = { + "(" + value.map(_pr_str(_, true)).mkString(" ") + ")" + } + def toString(print_readably: Boolean) = { + "(" + value.map(_pr_str(_, print_readably)).mkString(" ") + ")" + } + } + def _list(seq: Any*) = { + new MalList(seq:_*) + } + def _list_Q(obj: Any) = { + obj.isInstanceOf[MalList] && !obj.isInstanceOf[MalVector] + } + + + // Vectors + class MalVector(seq: Any*) extends MalList(seq:_*) { + override def clone() = { + val new_mv = new MalVector() + new_mv.value = value + new_mv.meta = meta + new_mv + } + + override def map(f: Any => Any) = new MalVector(value.map(f):_*) + override def drop(cnt: Int) = new MalVector(value.drop(cnt):_*) + + override def toString() = { + "[" + value.map(_pr_str(_, true)).mkString(" ") + "]" + } + override def toString(print_readably: Boolean) = { + "[" + value.map(_pr_str(_, print_readably)).mkString(" ") + "]" + } + } + def _vector(seq: Any*) = { + new MalVector(seq:_*) + } + def _vector_Q(obj: Any) = { + obj.isInstanceOf[MalVector] + } + + + // Hash Maps + class MalHashMap(seq: Any*) { + var value: Map[String,Any] = seq.toList.grouped(2).map( + (kv: List[Any]) => (kv(0).asInstanceOf[String], kv(1))).toMap + var meta: Any = null + + override def clone(): MalHashMap = { + val new_hm = new MalHashMap() + new_hm.value = value + new_hm.meta = meta + new_hm + } + + def keys(): MalList = new MalList(value.keys.toSeq:_*) + def vals(): MalList = new MalList(value.values.toSeq:_*) + + def apply(key: String): Any = value(key) + def map(f: ((String, Any)) => (String, Any)) = { + val res = value.map(f).map{case (k,v) => List(k,v)} + new MalHashMap(res.flatten.toSeq:_*) + } + def filterKeys(f: String => Boolean) = { + val res = value.filterKeys(f).map{case (k,v) => List(k,v)} + new MalHashMap(res.flatten.toSeq:_*) + } + def ++(that: MalHashMap) = { + val new_hm = clone() + new_hm.value ++= that.value + new_hm + } + + override def toString() = { + var res = mutable.MutableList[Any]() + for ((k,v) <- value) { + res += _pr_str(k, true) + res += _pr_str(v, true) + } + "{" + res.mkString(" ") + "}" + } + def toString(print_readably: Boolean) = { + var res = mutable.MutableList[Any]() + for ((k,v) <- value) { + res += _pr_str(k, print_readably) + res += _pr_str(v, print_readably) + } + "{" + res.mkString(" ") + "}" + } + } + def _hash_map(seq: Any*) = { + new MalHashMap(seq:_*) + } + def _hash_map_Q(obj: Any) = { + obj.isInstanceOf[MalHashMap] + } + + + // Function types + + class Func(_fn: ((List[Any]) => Any)) { + val fn = _fn + var meta: Any = null + + override def clone(): Func = { + val new_fn = new Func(fn) + new_fn.meta = meta + new_fn + } + + def apply(args: List[Any]): Any = fn(args) + } + + class MalFunction(_ast: Any, _env: Env, _params: MalList, + fn: ((List[Any]) => Any)) { + val ast = _ast + val env = _env + val params = _params + var ismacro = false + var meta: Any = null + + override def clone(): MalFunction = { + val new_fn = new MalFunction(ast, env, params, fn) + new_fn.ismacro = ismacro + new_fn.meta = meta + new_fn + } + + def apply(args: List[Any]): Any = fn(args) + + def gen_env(args: List[Any]): Env = { + return new Env(env, params.value.iterator, args.iterator) + } + } + + def _apply(f: Any, args: List[Any]): Any = { + f match { + case fn: types.MalFunction => fn(args) + case fn: Func => fn(args) + case _ => throw new Exception("attempt to call non-function") + } + } + + def _hash_map(lst: List[Any]): Any = { + lst.grouped(2).map( + (kv: List[Any]) => (kv(0).asInstanceOf[String], kv(1))).toMap + } + + class Atom(_value: Any) { + var value = _value + } +} + +// vim:ts=2:sw=2 diff --git a/impls/scheme/.gitignore b/impls/scheme/.gitignore index 31fc0e8966..14be1dd4f7 100644 --- a/impls/scheme/.gitignore +++ b/impls/scheme/.gitignore @@ -1,11 +1,11 @@ -lib/*.scm -lib/*.so -lib/*.c -lib/*.o -lib/*.meta -lib.*.scm -*.so -*.c -*.o -out/ +lib/*.scm +lib/*.so +lib/*.c +lib/*.o +lib/*.meta +lib.*.scm +*.so +*.c +*.o +out/ eggs/* \ No newline at end of file diff --git a/impls/scheme/Dockerfile b/impls/scheme/Dockerfile index 51583034af..f9e680835d 100644 --- a/impls/scheme/Dockerfile +++ b/impls/scheme/Dockerfile @@ -1,59 +1,59 @@ -FROM ubuntu:focal -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Dev tools -RUN DEBIAN_FRONTEND=noninteractive apt-get -y install gcc g++ bison flex groff make cmake pkg-config git - -# Prepackaged Scheme implementations -RUN apt-get -y install gauche chicken-bin -RUN chicken-install r7rs - -# Chibi -RUN cd /tmp && curl -Lo chibi-0.10.tar.gz https://github.com/ashinn/chibi-scheme/archive/0.10.tar.gz \ - && tar xvzf chibi-0.10.tar.gz && cd chibi-scheme-0.10 \ - && make && make install && rm -rf /tmp/chibi-* - -# Kawa -RUN apt-get -y install openjdk-8-jdk-headless -RUN cd /tmp && curl -O http://ftp.gnu.org/pub/gnu/kawa/kawa-3.1.1.tar.gz \ - && tar xvzf kawa-3.1.1.tar.gz && cd kawa-3.1.1 \ - && ./configure && make && make install && rm -rf /tmp/kawa-3.1.1* - -# Sagittarius -RUN apt-get -y install libgc-dev zlib1g-dev libffi-dev libssl-dev -RUN cd /tmp && curl -LO https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.9.7.tar.gz \ - && tar xvzf sagittarius-0.9.7.tar.gz && cd sagittarius-0.9.7 \ - && cmake . && make && make install && rm -rf /tmp/sagittarius-0.9.7* - -# Cyclone -RUN apt-get -y install libck-dev libtommath-dev -RUN cd /tmp && git clone https://github.com/justinethier/cyclone-bootstrap \ - && cd cyclone-bootstrap \ - && make && make install && rm -rf /tmp/cyclone-bootstrap - -# Foment -RUN cd /tmp && git clone https://github.com/leftmike/foment \ - && cd foment/unix && make && cp release/foment /usr/bin/foment \ - && rm -rf /tmp/foment - -ENV HOME /mal +FROM ubuntu:focal +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Dev tools +RUN DEBIAN_FRONTEND=noninteractive apt-get -y install gcc g++ bison flex groff make cmake pkg-config git + +# Prepackaged Scheme implementations +RUN apt-get -y install gauche chicken-bin +RUN chicken-install r7rs + +# Chibi +RUN cd /tmp && curl -Lo chibi-0.10.tar.gz https://github.com/ashinn/chibi-scheme/archive/0.10.tar.gz \ + && tar xvzf chibi-0.10.tar.gz && cd chibi-scheme-0.10 \ + && make && make install && rm -rf /tmp/chibi-* + +# Kawa +RUN apt-get -y install openjdk-8-jdk-headless +RUN cd /tmp && curl -O http://ftp.gnu.org/pub/gnu/kawa/kawa-3.1.1.tar.gz \ + && tar xvzf kawa-3.1.1.tar.gz && cd kawa-3.1.1 \ + && ./configure && make && make install && rm -rf /tmp/kawa-3.1.1* + +# Sagittarius +RUN apt-get -y install libgc-dev zlib1g-dev libffi-dev libssl-dev +RUN cd /tmp && curl -LO https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.9.7.tar.gz \ + && tar xvzf sagittarius-0.9.7.tar.gz && cd sagittarius-0.9.7 \ + && cmake . && make && make install && rm -rf /tmp/sagittarius-0.9.7* + +# Cyclone +RUN apt-get -y install libck-dev libtommath-dev +RUN cd /tmp && git clone https://github.com/justinethier/cyclone-bootstrap \ + && cd cyclone-bootstrap \ + && make && make install && rm -rf /tmp/cyclone-bootstrap + +# Foment +RUN cd /tmp && git clone https://github.com/leftmike/foment \ + && cd foment/unix && make && cp release/foment /usr/bin/foment \ + && rm -rf /tmp/foment + +ENV HOME /mal diff --git a/impls/scheme/Makefile b/impls/scheme/Makefile index 87b22e450e..364f97b8f6 100644 --- a/impls/scheme/Makefile +++ b/impls/scheme/Makefile @@ -1,87 +1,87 @@ -BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco -BINS += step6_file step7_quote step8_macros step9_try stepA_mal -scheme_MODE ?= chibi - -CLASSSTEPS = out/step0_repl.class out/step1_read_print.class \ - out/step3_env.class out/step4_if_fn_do.class out/step5_tco.class \ - out/step6_file.class out/step7_quote.class out/step8_macros.class \ - out/step9_try.class out/stepA_mal.class -STEPS = $(if $(filter kawa,$(scheme_MODE)),$(CLASSSTEPS),\ - $(if $(filter chicken,$(scheme_MODE)),$(BINS),\ - $(if $(filter cyclone,$(scheme_MODE)),$(BINS)))) - -KAWA_STEP1_DEPS = out/lib/util.class out/lib/reader.class \ - out/lib/printer.class out/lib/types.class -KAWA_STEP3_DEPS = $(KAWA_STEP1_DEPS) out/lib/env.class -KAWA_STEP4_DEPS = $(KAWA_STEP3_DEPS) out/lib/core.class -CHICKEN_STEP1_DEPS = lib.util.so lib.types.so lib.reader.so lib.printer.so -CHICKEN_STEP3_DEPS = $(CHICKEN_STEP1_DEPS) lib.env.so -CHICKEN_STEP4_DEPS = $(CHICKEN_STEP3_DEPS) lib.core.so -CYCLONE_STEP1_DEPS = lib/util.so lib/reader.so lib/printer.so lib/types.so -CYCLONE_STEP3_DEPS = $(CYCLONE_STEP1_DEPS) lib/env.so -CYCLONE_STEP4_DEPS = $(CYCLONE_STEP3_DEPS) lib/core.so - -STEP1_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP1_DEPS),\ - $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP1_DEPS),\ - $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP1_DEPS)))) -STEP3_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP3_DEPS),\ - $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP3_DEPS),\ - $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP3_DEPS)))) -STEP4_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP4_DEPS),\ - $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP4_DEPS),\ - $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP4_DEPS)))) - -KAWALIB = kawa --r7rs --no-warn-unused -d out -C -KAWA = kawa --r7rs --no-warn-unused -d out --main -C -CHICKEN = csc -setup-mode -host -O3 -R r7rs -CHICKENLIB = $(CHICKEN) -D compiling-extension -J -s -regenerate-import-libraries -CYCLONELIB = cyclone -O2 -CYCLONE = $(CYCLONELIB) - -SCMLIB = $(if $(filter kawa,$(scheme_MODE)),$(KAWALIB),\ - $(if $(filter chicken,$(scheme_MODE)),$(CHICKENLIB),\ - $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONELIB)))) -SCM = $(if $(filter kawa,$(scheme_MODE)),$(KAWA),\ - $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN),\ - $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE)))) - -MKDIR = mkdir -p -SYMLINK = ln -sfr -RM = rm -f -RMR = rm -rf - -all: $(STEPS) - -.PHONY: clean -.PRECIOUS: lib/%.scm - -lib/%.scm: lib/%.sld - $(SYMLINK) $< $@ - -out/lib/%.class: lib/%.scm - $(SCMLIB) $< - -out/%.class: %.scm - $(SCM) $< - -lib.%.so: lib/%.sld - $(SCMLIB) $< -o $@ - -lib/%.so: lib/%.sld - $(SCMLIB) $< - -%: %.scm - $(SCM) $< - -out/step1_read_print.class out/step2_eval.class: $(STEP1_DEPS) -out/step3_env.class: $(STEP3_DEPS) -out/step4_if_fn_do.class out/step5_tco.class out/step6_file.class out/step7_quote.class out/step8_macros.class out/step9_try.class out/stepA_mal.class: $(STEP4_DEPS) - -step1_read_print.scm step2_eval.scm: $(STEP1_DEPS) -step3_env.scm: $(STEP3_DEPS) -step4_if_fn_do.scm step5_tco.scm step6_file.scm step7_quote.scm step8_macros.scm step9_try.scm stepA_mal.scm: $(STEP4_DEPS) - -clean: - $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta - $(RM) lib.*.scm *.build.sh *.install.sh *.link *.so *.c *.o $(BINS) - $(RMR) out +BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco +BINS += step6_file step7_quote step8_macros step9_try stepA_mal +scheme_MODE ?= chibi + +CLASSSTEPS = out/step0_repl.class out/step1_read_print.class \ + out/step3_env.class out/step4_if_fn_do.class out/step5_tco.class \ + out/step6_file.class out/step7_quote.class out/step8_macros.class \ + out/step9_try.class out/stepA_mal.class +STEPS = $(if $(filter kawa,$(scheme_MODE)),$(CLASSSTEPS),\ + $(if $(filter chicken,$(scheme_MODE)),$(BINS),\ + $(if $(filter cyclone,$(scheme_MODE)),$(BINS)))) + +KAWA_STEP1_DEPS = out/lib/util.class out/lib/reader.class \ + out/lib/printer.class out/lib/types.class +KAWA_STEP3_DEPS = $(KAWA_STEP1_DEPS) out/lib/env.class +KAWA_STEP4_DEPS = $(KAWA_STEP3_DEPS) out/lib/core.class +CHICKEN_STEP1_DEPS = lib.util.so lib.types.so lib.reader.so lib.printer.so +CHICKEN_STEP3_DEPS = $(CHICKEN_STEP1_DEPS) lib.env.so +CHICKEN_STEP4_DEPS = $(CHICKEN_STEP3_DEPS) lib.core.so +CYCLONE_STEP1_DEPS = lib/util.so lib/reader.so lib/printer.so lib/types.so +CYCLONE_STEP3_DEPS = $(CYCLONE_STEP1_DEPS) lib/env.so +CYCLONE_STEP4_DEPS = $(CYCLONE_STEP3_DEPS) lib/core.so + +STEP1_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP1_DEPS),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP1_DEPS),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP1_DEPS)))) +STEP3_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP3_DEPS),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP3_DEPS),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP3_DEPS)))) +STEP4_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP4_DEPS),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP4_DEPS),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP4_DEPS)))) + +KAWALIB = kawa --r7rs --no-warn-unused -d out -C +KAWA = kawa --r7rs --no-warn-unused -d out --main -C +CHICKEN = csc -setup-mode -host -O3 -R r7rs +CHICKENLIB = $(CHICKEN) -D compiling-extension -J -s -regenerate-import-libraries +CYCLONELIB = cyclone -O2 +CYCLONE = $(CYCLONELIB) + +SCMLIB = $(if $(filter kawa,$(scheme_MODE)),$(KAWALIB),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKENLIB),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONELIB)))) +SCM = $(if $(filter kawa,$(scheme_MODE)),$(KAWA),\ + $(if $(filter chicken,$(scheme_MODE)),$(CHICKEN),\ + $(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE)))) + +MKDIR = mkdir -p +SYMLINK = ln -sfr +RM = rm -f +RMR = rm -rf + +all: $(STEPS) + +.PHONY: clean +.PRECIOUS: lib/%.scm + +lib/%.scm: lib/%.sld + $(SYMLINK) $< $@ + +out/lib/%.class: lib/%.scm + $(SCMLIB) $< + +out/%.class: %.scm + $(SCM) $< + +lib.%.so: lib/%.sld + $(SCMLIB) $< -o $@ + +lib/%.so: lib/%.sld + $(SCMLIB) $< + +%: %.scm + $(SCM) $< + +out/step1_read_print.class out/step2_eval.class: $(STEP1_DEPS) +out/step3_env.class: $(STEP3_DEPS) +out/step4_if_fn_do.class out/step5_tco.class out/step6_file.class out/step7_quote.class out/step8_macros.class out/step9_try.class out/stepA_mal.class: $(STEP4_DEPS) + +step1_read_print.scm step2_eval.scm: $(STEP1_DEPS) +step3_env.scm: $(STEP3_DEPS) +step4_if_fn_do.scm step5_tco.scm step6_file.scm step7_quote.scm step8_macros.scm step9_try.scm stepA_mal.scm: $(STEP4_DEPS) + +clean: + $(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta + $(RM) lib.*.scm *.build.sh *.install.sh *.link *.so *.c *.o $(BINS) + $(RMR) out diff --git a/impls/scheme/lib/core.sld b/impls/scheme/lib/core.sld index dcb8267f4f..1ae0889a9b 100644 --- a/impls/scheme/lib/core.sld +++ b/impls/scheme/lib/core.sld @@ -1,302 +1,302 @@ -(define-library (lib core) - -(export ns) - -(import (scheme base)) -(import (scheme write)) -(import (scheme file)) -(import (scheme time)) -(import (scheme read)) -(import (scheme eval)) -;; HACK: cyclone doesn't implement environments yet, but its eval -;; behaves as if you were using the repl environment -(cond-expand - (cyclone) - (else - (import (scheme repl)))) - -(import (lib types)) -(import (lib util)) -(import (lib printer)) -(import (lib reader)) - -(begin - -(define (coerce x) - (if x mal-true mal-false)) - -(define (->printed-string args print-readably sep) - (let ((items (map (lambda (arg) (pr-str arg print-readably)) args))) - (string-intersperse items sep))) - -(define (mal-equal? a b) - (let ((a-type (and (mal-object? a) (mal-type a))) - (a-value (and (mal-object? a) (mal-value a))) - (b-type (and (mal-object? b) (mal-type b))) - (b-value (and (mal-object? b) (mal-value b)))) - (cond - ((or (not a-type) (not b-type)) - mal-false) - ((and (memq a-type '(list vector)) - (memq b-type '(list vector))) - (mal-list-equal? (->list a-value) (->list b-value))) - ((and (eq? a-type 'map) (eq? b-type 'map)) - (mal-map-equal? a-value b-value)) - (else - (and (eq? a-type b-type) - (equal? a-value b-value)))))) - -(define (mal-list-equal? as bs) - (let loop ((as as) - (bs bs)) - (cond - ((and (null? as) (null? bs)) #t) - ((or (null? as) (null? bs)) #f) - (else - (if (mal-equal? (car as) (car bs)) - (loop (cdr as) (cdr bs)) - #f))))) - -(define (mal-map-ref key m . default) - (if (pair? default) - (alist-ref key m mal-equal? (car default)) - (alist-ref key m mal-equal?))) - -(define (mal-map-equal? as bs) - (if (not (= (length as) (length bs))) - #f - (let loop ((as as)) - (if (pair? as) - (let* ((item (car as)) - (key (car item)) - (value (cdr item))) - (if (mal-equal? (mal-map-ref key bs) value) - (loop (cdr as)) - #f)) - #t)))) - -(define (mal-map-dissoc m keys) - (let loop ((items m) - (acc '())) - (if (pair? items) - (let* ((item (car items)) - (key (car item))) - (if (contains? keys (lambda (x) (mal-equal? key x))) - (loop (cdr items) acc) - (loop (cdr items) (cons item acc)))) - (reverse acc)))) - -(define (mal-map-assoc m kvs) - (let ((kvs (list->alist kvs))) - (append kvs (mal-map-dissoc m (map car kvs))))) - -(define (map-in-order proc items) - (let loop ((items items) - (acc '())) - (if (null? items) - (reverse acc) - (loop (cdr items) (cons (proc (car items)) acc))))) - -(define (slurp path) - (call-with-output-string - (lambda (out) - (call-with-input-file path - (lambda (in) - (let loop () - (let ((chunk (read-string 1024 in))) - (when (not (eof-object? chunk)) - (display chunk out) - (loop))))))))) - -(define (time-ms) - (* (/ (current-jiffy) (jiffies-per-second)) 1000.0)) - -(define (->mal-object x) - (cond - ((boolean? x) (if x mal-true mal-false)) - ((char? x) (mal-string (char->string x))) - ((procedure? x) x) - ((symbol? x) (mal-symbol x)) - ((number? x) (mal-number x)) - ((string? x) (mal-string x)) - ((or (null? x) (pair? x)) - (mal-list (map ->mal-object x))) - ((vector? x) - (mal-vector (vector-map ->mal-object x))) - (else - (error "unknown type")))) - -(define (scm-eval input) - (call-with-input-string input - (lambda (port) - (cond-expand - (cyclone - (->mal-object (eval (read port)))) - (else - (->mal-object (eval (read port) (environment '(scheme base) - '(scheme write))))))))) - -(define ns - `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) - (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) - (* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) - (/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) - - (list . ,(lambda args (mal-list args))) - (list? . ,(lambda (x) (coerce (mal-instance-of? x 'list)))) - (empty? . ,(lambda (lis) (coerce (null? (->list (mal-value lis)))))) - (count . ,(lambda (lis) (mal-number - (if (eq? lis mal-nil) - 0 - (length (->list (mal-value lis))))))) - - (< . ,(lambda (a b) (coerce (< (mal-value a) (mal-value b))))) - (<= . ,(lambda (a b) (coerce (<= (mal-value a) (mal-value b))))) - (> . ,(lambda (a b) (coerce (> (mal-value a) (mal-value b))))) - (>= . ,(lambda (a b) (coerce (>= (mal-value a) (mal-value b))))) - (= . ,(lambda (a b) (coerce (mal-equal? a b)))) - - (pr-str . ,(lambda args (mal-string (->printed-string args #t " ")))) - (str . ,(lambda args (mal-string (->printed-string args #f "")))) - (prn . ,(lambda args - (display (->printed-string args #t " ")) - (newline) - mal-nil)) - (println . ,(lambda args - (display (->printed-string args #f " ")) - (newline) - mal-nil)) - - (read-string . ,(lambda (string) (read-str (mal-value string)))) - (slurp . ,(lambda (path) (mal-string (slurp (mal-value path))))) - (throw . ,(lambda (x) (raise (cons 'user-error x)))) - (readline . ,(lambda (prompt) (let ((output (readline (mal-value prompt)))) - (if output (mal-string output) mal-nil)))) - (time-ms . ,(lambda () (mal-number (time-ms)))) - (scm-eval . ,(lambda (input) (scm-eval (mal-value input)))) - - (atom . ,(lambda (x) (mal-atom x))) - (atom? . ,(lambda (x) (coerce (mal-instance-of? x 'atom)))) - (deref . ,(lambda (atom) (mal-value atom))) - (reset! . ,(lambda (atom x) (mal-value-set! atom x) x)) - (swap! . ,(lambda (atom fn . args) - (let* ((fn (if (func? fn) (func-fn fn) fn)) - (value (apply fn (cons (mal-value atom) args)))) - (mal-value-set! atom value) - value))) - - (cons . ,(lambda (x xs) (mal-list (cons x (->list (mal-value xs)))))) - (concat . ,(lambda args (mal-list (apply append (map (lambda (arg) (->list (mal-value arg))) args))))) - (vec . ,(lambda (x) - (case (mal-type x) - ((vector) x) - ((list) (mal-vector (list->vector (mal-value x)))) - (else (error "seq expects a sequence"))))) - (nth . ,(lambda (x n) (let ((items (->list (mal-value x))) - (index (mal-value n))) - (if (< index (length items)) - (list-ref items index) - (error (str "Out of range: " index)))))) - (first . ,(lambda (x) (if (eq? x mal-nil) - mal-nil - (let ((items (->list (mal-value x)))) - (if (null? items) - mal-nil - (car items)))))) - (rest . ,(lambda (x) (if (eq? x mal-nil) - (mal-list '()) - (let ((items (->list (mal-value x)))) - (if (null? items) - (mal-list '()) - (mal-list (cdr items))))))) - (conj . ,(lambda (coll . args) - (let ((items (mal-value coll))) - (cond - ((vector? items) - (mal-vector (vector-append items (list->vector args)))) - ((list? items) - (mal-list (append (reverse args) items))) - (else - (error "invalid collection type")))))) - (seq . ,(lambda (x) (if (eq? x mal-nil) - mal-nil - (let ((value (mal-value x))) - (case (mal-type x) - ((list) - (if (null? value) - mal-nil - x)) - ((vector) - (if (zero? (vector-length value)) - mal-nil - (mal-list (vector->list value)))) - ((string) - (if (zero? (string-length value)) - mal-nil - (mal-list (map mal-string (explode value))))) - (else - (error "invalid collection type"))))))) - - (apply . ,(lambda (f . args) (apply (if (func? f) (func-fn f) f) - (if (pair? (cdr args)) - (append (butlast args) - (->list (mal-value (last args)))) - (->list (mal-value (car args))))))) - (map . ,(lambda (f items) (mal-list (map-in-order - (if (func? f) (func-fn f) f) - (->list (mal-value items)))))) - - (nil? . ,(lambda (x) (coerce (eq? x mal-nil)))) - (true? . ,(lambda (x) (coerce (eq? x mal-true)))) - (false? . ,(lambda (x) (coerce (eq? x mal-false)))) - (number? . ,(lambda (x) (coerce (mal-instance-of? x 'number)))) - (string? . ,(lambda (x) (coerce (mal-instance-of? x 'string)))) - (symbol? . ,(lambda (x) (coerce (mal-instance-of? x 'symbol)))) - (symbol . ,(lambda (x) (mal-symbol (string->symbol (mal-value x))))) - (keyword? . ,(lambda (x) (coerce (mal-instance-of? x 'keyword)))) - (keyword . ,(lambda (x) (if (mal-instance-of? x 'keyword) - x - (mal-keyword (string->symbol (mal-value x)))))) - (vector? . ,(lambda (x) (coerce (mal-instance-of? x 'vector)))) - (vector . ,(lambda args (mal-vector (list->vector args)))) - (map? . ,(lambda (x) (coerce (mal-instance-of? x 'map)))) - (hash-map . ,(lambda args (mal-map (list->alist args)))) - (sequential? . ,(lambda (x) (coerce (and (mal-object? x) - (memq (mal-type x) - '(list vector)))))) - (fn? . ,(lambda (x) (coerce (or (procedure? x) - (and (func? x) (not (func-macro? x))))))) - (macro? . ,(lambda (x) (coerce (and (func? x) (func-macro? x))))) - - (assoc . ,(lambda (m . kvs) (mal-map (mal-map-assoc (mal-value m) kvs)))) - (dissoc . ,(lambda (m . keys) (mal-map (mal-map-dissoc (mal-value m) keys)))) - (get . ,(lambda (m key) (mal-map-ref key (mal-value m) mal-nil))) - (contains? . ,(lambda (m key) (coerce (mal-map-ref key (mal-value m))))) - (keys . ,(lambda (m) (mal-list (map car (mal-value m))))) - (vals . ,(lambda (m) (mal-list (map cdr (mal-value m))))) - - (with-meta . ,(lambda (x meta) - (cond - ((mal-object? x) - (make-mal-object (mal-type x) (mal-value x) meta)) - ((func? x) - (let ((func (make-func (func-ast x) (func-params x) - (func-env x) (func-fn x)))) - (func-macro?-set! func #f) - (func-meta-set! func meta) - func)) - (else - (error "unsupported type"))))) - (meta . ,(lambda (x) (cond - ((mal-object? x) - (or (mal-meta x) mal-nil)) - ((func? x) - (or (func-meta x) mal-nil)) - (else - mal-nil)))) - - )) - -) - -) +(define-library (lib core) + +(export ns) + +(import (scheme base)) +(import (scheme write)) +(import (scheme file)) +(import (scheme time)) +(import (scheme read)) +(import (scheme eval)) +;; HACK: cyclone doesn't implement environments yet, but its eval +;; behaves as if you were using the repl environment +(cond-expand + (cyclone) + (else + (import (scheme repl)))) + +(import (lib types)) +(import (lib util)) +(import (lib printer)) +(import (lib reader)) + +(begin + +(define (coerce x) + (if x mal-true mal-false)) + +(define (->printed-string args print-readably sep) + (let ((items (map (lambda (arg) (pr-str arg print-readably)) args))) + (string-intersperse items sep))) + +(define (mal-equal? a b) + (let ((a-type (and (mal-object? a) (mal-type a))) + (a-value (and (mal-object? a) (mal-value a))) + (b-type (and (mal-object? b) (mal-type b))) + (b-value (and (mal-object? b) (mal-value b)))) + (cond + ((or (not a-type) (not b-type)) + mal-false) + ((and (memq a-type '(list vector)) + (memq b-type '(list vector))) + (mal-list-equal? (->list a-value) (->list b-value))) + ((and (eq? a-type 'map) (eq? b-type 'map)) + (mal-map-equal? a-value b-value)) + (else + (and (eq? a-type b-type) + (equal? a-value b-value)))))) + +(define (mal-list-equal? as bs) + (let loop ((as as) + (bs bs)) + (cond + ((and (null? as) (null? bs)) #t) + ((or (null? as) (null? bs)) #f) + (else + (if (mal-equal? (car as) (car bs)) + (loop (cdr as) (cdr bs)) + #f))))) + +(define (mal-map-ref key m . default) + (if (pair? default) + (alist-ref key m mal-equal? (car default)) + (alist-ref key m mal-equal?))) + +(define (mal-map-equal? as bs) + (if (not (= (length as) (length bs))) + #f + (let loop ((as as)) + (if (pair? as) + (let* ((item (car as)) + (key (car item)) + (value (cdr item))) + (if (mal-equal? (mal-map-ref key bs) value) + (loop (cdr as)) + #f)) + #t)))) + +(define (mal-map-dissoc m keys) + (let loop ((items m) + (acc '())) + (if (pair? items) + (let* ((item (car items)) + (key (car item))) + (if (contains? keys (lambda (x) (mal-equal? key x))) + (loop (cdr items) acc) + (loop (cdr items) (cons item acc)))) + (reverse acc)))) + +(define (mal-map-assoc m kvs) + (let ((kvs (list->alist kvs))) + (append kvs (mal-map-dissoc m (map car kvs))))) + +(define (map-in-order proc items) + (let loop ((items items) + (acc '())) + (if (null? items) + (reverse acc) + (loop (cdr items) (cons (proc (car items)) acc))))) + +(define (slurp path) + (call-with-output-string + (lambda (out) + (call-with-input-file path + (lambda (in) + (let loop () + (let ((chunk (read-string 1024 in))) + (when (not (eof-object? chunk)) + (display chunk out) + (loop))))))))) + +(define (time-ms) + (* (/ (current-jiffy) (jiffies-per-second)) 1000.0)) + +(define (->mal-object x) + (cond + ((boolean? x) (if x mal-true mal-false)) + ((char? x) (mal-string (char->string x))) + ((procedure? x) x) + ((symbol? x) (mal-symbol x)) + ((number? x) (mal-number x)) + ((string? x) (mal-string x)) + ((or (null? x) (pair? x)) + (mal-list (map ->mal-object x))) + ((vector? x) + (mal-vector (vector-map ->mal-object x))) + (else + (error "unknown type")))) + +(define (scm-eval input) + (call-with-input-string input + (lambda (port) + (cond-expand + (cyclone + (->mal-object (eval (read port)))) + (else + (->mal-object (eval (read port) (environment '(scheme base) + '(scheme write))))))))) + +(define ns + `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) + (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) + (* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) + (/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) + + (list . ,(lambda args (mal-list args))) + (list? . ,(lambda (x) (coerce (mal-instance-of? x 'list)))) + (empty? . ,(lambda (lis) (coerce (null? (->list (mal-value lis)))))) + (count . ,(lambda (lis) (mal-number + (if (eq? lis mal-nil) + 0 + (length (->list (mal-value lis))))))) + + (< . ,(lambda (a b) (coerce (< (mal-value a) (mal-value b))))) + (<= . ,(lambda (a b) (coerce (<= (mal-value a) (mal-value b))))) + (> . ,(lambda (a b) (coerce (> (mal-value a) (mal-value b))))) + (>= . ,(lambda (a b) (coerce (>= (mal-value a) (mal-value b))))) + (= . ,(lambda (a b) (coerce (mal-equal? a b)))) + + (pr-str . ,(lambda args (mal-string (->printed-string args #t " ")))) + (str . ,(lambda args (mal-string (->printed-string args #f "")))) + (prn . ,(lambda args + (display (->printed-string args #t " ")) + (newline) + mal-nil)) + (println . ,(lambda args + (display (->printed-string args #f " ")) + (newline) + mal-nil)) + + (read-string . ,(lambda (string) (read-str (mal-value string)))) + (slurp . ,(lambda (path) (mal-string (slurp (mal-value path))))) + (throw . ,(lambda (x) (raise (cons 'user-error x)))) + (readline . ,(lambda (prompt) (let ((output (readline (mal-value prompt)))) + (if output (mal-string output) mal-nil)))) + (time-ms . ,(lambda () (mal-number (time-ms)))) + (scm-eval . ,(lambda (input) (scm-eval (mal-value input)))) + + (atom . ,(lambda (x) (mal-atom x))) + (atom? . ,(lambda (x) (coerce (mal-instance-of? x 'atom)))) + (deref . ,(lambda (atom) (mal-value atom))) + (reset! . ,(lambda (atom x) (mal-value-set! atom x) x)) + (swap! . ,(lambda (atom fn . args) + (let* ((fn (if (func? fn) (func-fn fn) fn)) + (value (apply fn (cons (mal-value atom) args)))) + (mal-value-set! atom value) + value))) + + (cons . ,(lambda (x xs) (mal-list (cons x (->list (mal-value xs)))))) + (concat . ,(lambda args (mal-list (apply append (map (lambda (arg) (->list (mal-value arg))) args))))) + (vec . ,(lambda (x) + (case (mal-type x) + ((vector) x) + ((list) (mal-vector (list->vector (mal-value x)))) + (else (error "seq expects a sequence"))))) + (nth . ,(lambda (x n) (let ((items (->list (mal-value x))) + (index (mal-value n))) + (if (< index (length items)) + (list-ref items index) + (error (str "Out of range: " index)))))) + (first . ,(lambda (x) (if (eq? x mal-nil) + mal-nil + (let ((items (->list (mal-value x)))) + (if (null? items) + mal-nil + (car items)))))) + (rest . ,(lambda (x) (if (eq? x mal-nil) + (mal-list '()) + (let ((items (->list (mal-value x)))) + (if (null? items) + (mal-list '()) + (mal-list (cdr items))))))) + (conj . ,(lambda (coll . args) + (let ((items (mal-value coll))) + (cond + ((vector? items) + (mal-vector (vector-append items (list->vector args)))) + ((list? items) + (mal-list (append (reverse args) items))) + (else + (error "invalid collection type")))))) + (seq . ,(lambda (x) (if (eq? x mal-nil) + mal-nil + (let ((value (mal-value x))) + (case (mal-type x) + ((list) + (if (null? value) + mal-nil + x)) + ((vector) + (if (zero? (vector-length value)) + mal-nil + (mal-list (vector->list value)))) + ((string) + (if (zero? (string-length value)) + mal-nil + (mal-list (map mal-string (explode value))))) + (else + (error "invalid collection type"))))))) + + (apply . ,(lambda (f . args) (apply (if (func? f) (func-fn f) f) + (if (pair? (cdr args)) + (append (butlast args) + (->list (mal-value (last args)))) + (->list (mal-value (car args))))))) + (map . ,(lambda (f items) (mal-list (map-in-order + (if (func? f) (func-fn f) f) + (->list (mal-value items)))))) + + (nil? . ,(lambda (x) (coerce (eq? x mal-nil)))) + (true? . ,(lambda (x) (coerce (eq? x mal-true)))) + (false? . ,(lambda (x) (coerce (eq? x mal-false)))) + (number? . ,(lambda (x) (coerce (mal-instance-of? x 'number)))) + (string? . ,(lambda (x) (coerce (mal-instance-of? x 'string)))) + (symbol? . ,(lambda (x) (coerce (mal-instance-of? x 'symbol)))) + (symbol . ,(lambda (x) (mal-symbol (string->symbol (mal-value x))))) + (keyword? . ,(lambda (x) (coerce (mal-instance-of? x 'keyword)))) + (keyword . ,(lambda (x) (if (mal-instance-of? x 'keyword) + x + (mal-keyword (string->symbol (mal-value x)))))) + (vector? . ,(lambda (x) (coerce (mal-instance-of? x 'vector)))) + (vector . ,(lambda args (mal-vector (list->vector args)))) + (map? . ,(lambda (x) (coerce (mal-instance-of? x 'map)))) + (hash-map . ,(lambda args (mal-map (list->alist args)))) + (sequential? . ,(lambda (x) (coerce (and (mal-object? x) + (memq (mal-type x) + '(list vector)))))) + (fn? . ,(lambda (x) (coerce (or (procedure? x) + (and (func? x) (not (func-macro? x))))))) + (macro? . ,(lambda (x) (coerce (and (func? x) (func-macro? x))))) + + (assoc . ,(lambda (m . kvs) (mal-map (mal-map-assoc (mal-value m) kvs)))) + (dissoc . ,(lambda (m . keys) (mal-map (mal-map-dissoc (mal-value m) keys)))) + (get . ,(lambda (m key) (mal-map-ref key (mal-value m) mal-nil))) + (contains? . ,(lambda (m key) (coerce (mal-map-ref key (mal-value m))))) + (keys . ,(lambda (m) (mal-list (map car (mal-value m))))) + (vals . ,(lambda (m) (mal-list (map cdr (mal-value m))))) + + (with-meta . ,(lambda (x meta) + (cond + ((mal-object? x) + (make-mal-object (mal-type x) (mal-value x) meta)) + ((func? x) + (let ((func (make-func (func-ast x) (func-params x) + (func-env x) (func-fn x)))) + (func-macro?-set! func #f) + (func-meta-set! func meta) + func)) + (else + (error "unsupported type"))))) + (meta . ,(lambda (x) (cond + ((mal-object? x) + (or (mal-meta x) mal-nil)) + ((func? x) + (or (func-meta x) mal-nil)) + (else + mal-nil)))) + + )) + +) + +) diff --git a/impls/scheme/lib/env.sld b/impls/scheme/lib/env.sld index 00e4f2a2c1..f33768c644 100644 --- a/impls/scheme/lib/env.sld +++ b/impls/scheme/lib/env.sld @@ -1,49 +1,49 @@ -(define-library (lib env) - -(export make-env env-set env-find env-get) - -(import (scheme base)) - -(import (lib util)) -(import (lib types)) - -(begin - -(define-record-type env - (%make-env outer data) - env? - (outer env-outer) - (data env-data env-data-set!)) - -(define (make-env outer . rest) - (let ((env (%make-env outer '()))) - (when (pair? rest) - (let loop ((binds (car rest)) - (exprs (cadr rest))) - (when (pair? binds) - (let ((bind (car binds))) - (if (eq? bind '&) - (env-set env (cadr binds) (mal-list exprs)) - (begin - (env-set env bind (car exprs)) - (loop (cdr binds) (cdr exprs)))))))) - env)) - -(define (env-set env key value) - (env-data-set! env (cons (cons key value) (env-data env)))) - -(define (env-find env key) - (cond - ((alist-ref key (env-data env)) => identity) - ((env-outer env) => (lambda (outer) (env-find outer key))) - (else #f))) - -(define (env-get env key) - (let ((value (env-find env key))) - (if value - value - (error (str "'" key "' not found"))))) - -) - -) +(define-library (lib env) + +(export make-env env-set env-find env-get) + +(import (scheme base)) + +(import (lib util)) +(import (lib types)) + +(begin + +(define-record-type env + (%make-env outer data) + env? + (outer env-outer) + (data env-data env-data-set!)) + +(define (make-env outer . rest) + (let ((env (%make-env outer '()))) + (when (pair? rest) + (let loop ((binds (car rest)) + (exprs (cadr rest))) + (when (pair? binds) + (let ((bind (car binds))) + (if (eq? bind '&) + (env-set env (cadr binds) (mal-list exprs)) + (begin + (env-set env bind (car exprs)) + (loop (cdr binds) (cdr exprs)))))))) + env)) + +(define (env-set env key value) + (env-data-set! env (cons (cons key value) (env-data env)))) + +(define (env-find env key) + (cond + ((alist-ref key (env-data env)) => identity) + ((env-outer env) => (lambda (outer) (env-find outer key))) + (else #f))) + +(define (env-get env key) + (let ((value (env-find env key))) + (if value + value + (error (str "'" key "' not found"))))) + +) + +) diff --git a/impls/scheme/lib/printer.sld b/impls/scheme/lib/printer.sld index 18fbfae74e..6729cc1e61 100644 --- a/impls/scheme/lib/printer.sld +++ b/impls/scheme/lib/printer.sld @@ -1,62 +1,62 @@ -(define-library (lib printer) - -(export pr-str) - -(import (scheme base)) -(import (scheme write)) - -(import (lib util)) -(import (lib types)) - -(begin - -(define (pr-str ast print-readably) - (cond - ((procedure? ast) - "#") - ((func? ast) - "#") - (else - (if (procedure? ast) - "#" - (let* ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((true) "true") - ((false) "false") - ((nil) "nil") - ((number) (number->string value)) - ((string) (call-with-output-string - (lambda (port) - (if print-readably - (begin - (display #\" port) - (string-for-each - (lambda (char) - (case char - ((#\\) (display "\\\\" port)) - ((#\") (display "\\\"" port)) - ((#\newline) (display "\\n" port)) - (else (display char port)))) - value) - (display #\" port)) - (display value port))))) - ((keyword) (string-append ":" (symbol->string value))) - ((symbol) (symbol->string value)) - ((list) (pr-list value "(" ")" print-readably)) - ((vector) (pr-list (vector->list value) "[" "]" print-readably)) - ((map) (pr-list (alist->list value) "{" "}" print-readably)) - ((atom) (string-append "(atom " (pr-str value print-readably) ")")) - (else (error "unknown type")))))))) - -(define (pr-list items starter ender print-readably) - (call-with-output-string - (lambda (port) - (display starter port) - (let ((reprs (map (lambda (item) (pr-str item print-readably)) items))) - (display (string-intersperse reprs " ") port)) - (display ender port)))) - -) - -) +(define-library (lib printer) + +(export pr-str) + +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib types)) + +(begin + +(define (pr-str ast print-readably) + (cond + ((procedure? ast) + "#") + ((func? ast) + "#") + (else + (if (procedure? ast) + "#" + (let* ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((true) "true") + ((false) "false") + ((nil) "nil") + ((number) (number->string value)) + ((string) (call-with-output-string + (lambda (port) + (if print-readably + (begin + (display #\" port) + (string-for-each + (lambda (char) + (case char + ((#\\) (display "\\\\" port)) + ((#\") (display "\\\"" port)) + ((#\newline) (display "\\n" port)) + (else (display char port)))) + value) + (display #\" port)) + (display value port))))) + ((keyword) (string-append ":" (symbol->string value))) + ((symbol) (symbol->string value)) + ((list) (pr-list value "(" ")" print-readably)) + ((vector) (pr-list (vector->list value) "[" "]" print-readably)) + ((map) (pr-list (alist->list value) "{" "}" print-readably)) + ((atom) (string-append "(atom " (pr-str value print-readably) ")")) + (else (error "unknown type")))))))) + +(define (pr-list items starter ender print-readably) + (call-with-output-string + (lambda (port) + (display starter port) + (let ((reprs (map (lambda (item) (pr-str item print-readably)) items))) + (display (string-intersperse reprs " ") port)) + (display ender port)))) + +) + +) diff --git a/impls/scheme/lib/reader.sld b/impls/scheme/lib/reader.sld index eb33eed169..73d6d80e2e 100644 --- a/impls/scheme/lib/reader.sld +++ b/impls/scheme/lib/reader.sld @@ -1,183 +1,183 @@ -(define-library (lib reader) - -(export read-str) - -(import (scheme base)) -(import (scheme char)) -(import (scheme read)) -(import (scheme write)) - -(import (lib util)) -(import (lib types)) - -(begin - -(define-record-type reader - (%make-reader tokens position) - reader? - (tokens %reader-tokens) - (position %reader-position %reader-position-set!)) - -(define (make-reader tokens) - (%make-reader (list->vector tokens) 0)) - -(define (peek reader) - (let ((tokens (%reader-tokens reader)) - (position (%reader-position reader))) - (if (>= position (vector-length tokens)) - #f - (vector-ref tokens position)))) - -(define (next reader) - (let ((token (peek reader))) - (when token - (%reader-position-set! reader (+ (%reader-position reader) 1))) - token)) - -(define (read-str input) - (let* ((tokens (tokenizer input)) - (reader (make-reader tokens))) - (read-form reader))) - -(define (whitespace-char? char) - (or (char-whitespace? char) (char=? char #\,))) - -(define (special-char? char) - (memv char '(#\[ #\] #\{ #\} #\( #\) #\' #\` #\~ #\^ #\@))) - -(define (non-word-char? char) - (or (whitespace-char? char) - (memv char '(#\[ #\] #\{ #\} #\( #\) #\' #\" #\` #\;)))) - -(define (tokenizer input) - (call-with-input-string input - (lambda (port) - (let loop ((tokens '())) - (if (eof-object? (peek-char port)) - (reverse tokens) - (let ((char (read-char port))) - (cond - ((whitespace-char? char) - (loop tokens)) - ((and (char=? char #\~) - (char=? (peek-char port) #\@)) - (read-char port) ; remove @ token - (loop (cons "~@" tokens))) - ((char=? char #\") - (loop (cons (tokenize-string port) tokens))) - ((char=? char #\;) - (skip-comment port) - (loop tokens)) - ((special-char? char) - (loop (cons (char->string char) tokens))) - (else - (loop (cons (tokenize-word port char) tokens)))))))))) - -(define (tokenize-string port) - (let loop ((chars '(#\"))) - (let ((char (read-char port))) - (cond - ((eof-object? char) - (list->string (reverse chars))) - ((char=? char #\\) - (let ((char (read-char port))) - (when (not (eof-object? char)) - (loop (cons char (cons #\\ chars)))))) - ((not (char=? char #\")) - (loop (cons char chars))) - ((char=? char #\") - (list->string (reverse (cons #\" chars)))))))) - -(define (skip-comment port) - (let loop () - (let ((char (peek-char port))) - (when (not (or (eof-object? char) - (char=? char #\newline))) - (read-char port) - (loop))))) - -(define (tokenize-word port char) - (let loop ((chars (list char))) - (let ((char (peek-char port))) - (if (or (eof-object? char) - (non-word-char? char)) - (list->string (reverse chars)) - (loop (cons (read-char port) chars)))))) - -(define (read-form reader) - (let ((token (peek reader))) - (cond - ((equal? token "'") - (read-macro reader 'quote)) - ((equal? token "`") - (read-macro reader 'quasiquote)) - ((equal? token "~") - (read-macro reader 'unquote)) - ((equal? token "~@") - (read-macro reader 'splice-unquote)) - ((equal? token "@") - (read-macro reader 'deref)) - ((equal? token "^") - (read-meta reader)) - ((equal? token "(") - (read-list reader ")" mal-list)) - ((equal? token "[") - (read-list reader "]" (lambda (items) (mal-vector (list->vector items))))) - ((equal? token "{") - (read-list reader "}" (lambda (items) (mal-map (list->alist items))))) - (else - (read-atom reader))))) - -(define (read-macro reader symbol) - (next reader) ; pop macro token - (mal-list (list (mal-symbol symbol) (read-form reader)))) - -(define (read-meta reader) - (next reader) ; pop macro token - (let ((form (read-form reader))) - (mal-list (list (mal-symbol 'with-meta) (read-form reader) form)))) - -(define (read-list reader ender proc) - (next reader) ; pop list start - (let loop ((items '())) - (let ((token (peek reader))) - (cond - ((equal? token ender) - (next reader) - (proc (reverse items))) - ((not token) - (error (str "expected '" ender "', got EOF"))) - (else - (loop (cons (read-form reader) items))))))) - -(define (read-atom reader) - (let ((token (next reader))) - (cond - ((not token) - (error "end of token stream" 'empty-input)) - ((equal? token "true") - mal-true) - ((equal? token "false") - mal-false) - ((equal? token "nil") - mal-nil) - ((string->number token) - => mal-number) - ((char=? (string-ref token 0) #\") - (guard - (ex ((cond-expand - ;; HACK: https://github.com/ashinn/chibi-scheme/pull/540 - (chibi - (error-object? ex)) - (else - (read-error? ex))) - (error (str "expected '" #\" "', got EOF")))) - (mal-string (call-with-input-string token read)))) - ((char=? (string-ref token 0) #\:) - (mal-keyword (string->symbol (string-copy token 1)))) - (else - (mal-symbol (string->symbol token)))))) - -) - -) +(define-library (lib reader) + +(export read-str) + +(import (scheme base)) +(import (scheme char)) +(import (scheme read)) +(import (scheme write)) + +(import (lib util)) +(import (lib types)) + +(begin + +(define-record-type reader + (%make-reader tokens position) + reader? + (tokens %reader-tokens) + (position %reader-position %reader-position-set!)) + +(define (make-reader tokens) + (%make-reader (list->vector tokens) 0)) + +(define (peek reader) + (let ((tokens (%reader-tokens reader)) + (position (%reader-position reader))) + (if (>= position (vector-length tokens)) + #f + (vector-ref tokens position)))) + +(define (next reader) + (let ((token (peek reader))) + (when token + (%reader-position-set! reader (+ (%reader-position reader) 1))) + token)) + +(define (read-str input) + (let* ((tokens (tokenizer input)) + (reader (make-reader tokens))) + (read-form reader))) + +(define (whitespace-char? char) + (or (char-whitespace? char) (char=? char #\,))) + +(define (special-char? char) + (memv char '(#\[ #\] #\{ #\} #\( #\) #\' #\` #\~ #\^ #\@))) + +(define (non-word-char? char) + (or (whitespace-char? char) + (memv char '(#\[ #\] #\{ #\} #\( #\) #\' #\" #\` #\;)))) + +(define (tokenizer input) + (call-with-input-string input + (lambda (port) + (let loop ((tokens '())) + (if (eof-object? (peek-char port)) + (reverse tokens) + (let ((char (read-char port))) + (cond + ((whitespace-char? char) + (loop tokens)) + ((and (char=? char #\~) + (char=? (peek-char port) #\@)) + (read-char port) ; remove @ token + (loop (cons "~@" tokens))) + ((char=? char #\") + (loop (cons (tokenize-string port) tokens))) + ((char=? char #\;) + (skip-comment port) + (loop tokens)) + ((special-char? char) + (loop (cons (char->string char) tokens))) + (else + (loop (cons (tokenize-word port char) tokens)))))))))) + +(define (tokenize-string port) + (let loop ((chars '(#\"))) + (let ((char (read-char port))) + (cond + ((eof-object? char) + (list->string (reverse chars))) + ((char=? char #\\) + (let ((char (read-char port))) + (when (not (eof-object? char)) + (loop (cons char (cons #\\ chars)))))) + ((not (char=? char #\")) + (loop (cons char chars))) + ((char=? char #\") + (list->string (reverse (cons #\" chars)))))))) + +(define (skip-comment port) + (let loop () + (let ((char (peek-char port))) + (when (not (or (eof-object? char) + (char=? char #\newline))) + (read-char port) + (loop))))) + +(define (tokenize-word port char) + (let loop ((chars (list char))) + (let ((char (peek-char port))) + (if (or (eof-object? char) + (non-word-char? char)) + (list->string (reverse chars)) + (loop (cons (read-char port) chars)))))) + +(define (read-form reader) + (let ((token (peek reader))) + (cond + ((equal? token "'") + (read-macro reader 'quote)) + ((equal? token "`") + (read-macro reader 'quasiquote)) + ((equal? token "~") + (read-macro reader 'unquote)) + ((equal? token "~@") + (read-macro reader 'splice-unquote)) + ((equal? token "@") + (read-macro reader 'deref)) + ((equal? token "^") + (read-meta reader)) + ((equal? token "(") + (read-list reader ")" mal-list)) + ((equal? token "[") + (read-list reader "]" (lambda (items) (mal-vector (list->vector items))))) + ((equal? token "{") + (read-list reader "}" (lambda (items) (mal-map (list->alist items))))) + (else + (read-atom reader))))) + +(define (read-macro reader symbol) + (next reader) ; pop macro token + (mal-list (list (mal-symbol symbol) (read-form reader)))) + +(define (read-meta reader) + (next reader) ; pop macro token + (let ((form (read-form reader))) + (mal-list (list (mal-symbol 'with-meta) (read-form reader) form)))) + +(define (read-list reader ender proc) + (next reader) ; pop list start + (let loop ((items '())) + (let ((token (peek reader))) + (cond + ((equal? token ender) + (next reader) + (proc (reverse items))) + ((not token) + (error (str "expected '" ender "', got EOF"))) + (else + (loop (cons (read-form reader) items))))))) + +(define (read-atom reader) + (let ((token (next reader))) + (cond + ((not token) + (error "end of token stream" 'empty-input)) + ((equal? token "true") + mal-true) + ((equal? token "false") + mal-false) + ((equal? token "nil") + mal-nil) + ((string->number token) + => mal-number) + ((char=? (string-ref token 0) #\") + (guard + (ex ((cond-expand + ;; HACK: https://github.com/ashinn/chibi-scheme/pull/540 + (chibi + (error-object? ex)) + (else + (read-error? ex))) + (error (str "expected '" #\" "', got EOF")))) + (mal-string (call-with-input-string token read)))) + ((char=? (string-ref token 0) #\:) + (mal-keyword (string->symbol (string-copy token 1)))) + (else + (mal-symbol (string->symbol token)))))) + +) + +) diff --git a/impls/scheme/lib/types.sld b/impls/scheme/lib/types.sld index 8eebb6f854..dca90e0ef9 100644 --- a/impls/scheme/lib/types.sld +++ b/impls/scheme/lib/types.sld @@ -1,70 +1,70 @@ -(define-library (lib types) - -(export make-mal-object mal-object? mal-type mal-value mal-value-set! mal-meta - mal-true mal-false mal-nil - mal-number mal-string mal-symbol mal-keyword - mal-list mal-vector mal-map mal-atom - - make-func func? func-ast func-params func-env - func-fn func-macro? func-macro?-set! func-meta func-meta-set! - - mal-instance-of?) - -(import (scheme base)) - -(begin - -(define-record-type mal-object - (make-mal-object type value meta) - mal-object? - (type mal-type) - (value mal-value mal-value-set!) - (meta mal-meta mal-meta-set!)) - -(define mal-true (make-mal-object 'true #t #f)) -(define mal-false (make-mal-object 'false #f #f)) -(define mal-nil (make-mal-object 'nil #f #f)) - -(define (mal-number n) - (make-mal-object 'number n #f)) - -(define (mal-string string) - (make-mal-object 'string string #f)) - -(define (mal-symbol name) - (make-mal-object 'symbol name #f)) - -(define (mal-keyword name) - (make-mal-object 'keyword name #f)) - -(define (mal-list items) - (make-mal-object 'list items #f)) - -(define (mal-vector items) - (make-mal-object 'vector items #f)) - -(define (mal-map items) - (make-mal-object 'map items #f)) - -(define (mal-atom item) - (make-mal-object 'atom item #f)) - -(define-record-type func - (%make-func ast params env fn macro? meta) - func? - (ast func-ast) - (params func-params) - (env func-env) - (fn func-fn) - (macro? func-macro? func-macro?-set!) - (meta func-meta func-meta-set!)) - -(define (make-func ast params env fn) - (%make-func ast params env fn #f #f)) - -(define (mal-instance-of? x type) - (and (mal-object? x) (eq? (mal-type x) type))) - -) - -) +(define-library (lib types) + +(export make-mal-object mal-object? mal-type mal-value mal-value-set! mal-meta + mal-true mal-false mal-nil + mal-number mal-string mal-symbol mal-keyword + mal-list mal-vector mal-map mal-atom + + make-func func? func-ast func-params func-env + func-fn func-macro? func-macro?-set! func-meta func-meta-set! + + mal-instance-of?) + +(import (scheme base)) + +(begin + +(define-record-type mal-object + (make-mal-object type value meta) + mal-object? + (type mal-type) + (value mal-value mal-value-set!) + (meta mal-meta mal-meta-set!)) + +(define mal-true (make-mal-object 'true #t #f)) +(define mal-false (make-mal-object 'false #f #f)) +(define mal-nil (make-mal-object 'nil #f #f)) + +(define (mal-number n) + (make-mal-object 'number n #f)) + +(define (mal-string string) + (make-mal-object 'string string #f)) + +(define (mal-symbol name) + (make-mal-object 'symbol name #f)) + +(define (mal-keyword name) + (make-mal-object 'keyword name #f)) + +(define (mal-list items) + (make-mal-object 'list items #f)) + +(define (mal-vector items) + (make-mal-object 'vector items #f)) + +(define (mal-map items) + (make-mal-object 'map items #f)) + +(define (mal-atom item) + (make-mal-object 'atom item #f)) + +(define-record-type func + (%make-func ast params env fn macro? meta) + func? + (ast func-ast) + (params func-params) + (env func-env) + (fn func-fn) + (macro? func-macro? func-macro?-set!) + (meta func-meta func-meta-set!)) + +(define (make-func ast params env fn) + (%make-func ast params env fn #f #f)) + +(define (mal-instance-of? x type) + (and (mal-object? x) (eq? (mal-type x) type))) + +) + +) diff --git a/impls/scheme/lib/util.sld b/impls/scheme/lib/util.sld index 679d73fca9..c51fe38b5a 100644 --- a/impls/scheme/lib/util.sld +++ b/impls/scheme/lib/util.sld @@ -1,163 +1,163 @@ -(define-library (lib util) - -(export call-with-input-string call-with-output-string - str prn debug - string-intersperse explode - char->string - list->alist alist->list alist-ref alist-map - ->list car-safe cdr-safe contains? last butlast - identity readline - - ;; HACK: cyclone doesn't have those - error-object? read-error? error-object-message error-object-irritants) - -(import (scheme base)) -(import (scheme write)) - -(begin - -;; HACK: cyclone currently implements error the SICP way -(cond-expand - (cyclone - (define (error-object? x) (and (pair? x) (string? (car x)))) - (define read-error? error-object?) - (define error-object-message car) - (define error-object-irritants cdr)) - (else)) - -(define (call-with-input-string string proc) - (let ((port (open-input-string string))) - (dynamic-wind - (lambda () #t) - (lambda () (proc port)) - (lambda () (close-input-port port))))) - -(define (call-with-output-string proc) - (let ((port (open-output-string))) - (dynamic-wind - (lambda () #t) - (lambda () (proc port) (get-output-string port)) - (lambda () (close-output-port port))))) - -(define (str . items) - (call-with-output-string - (lambda (port) - (for-each (lambda (item) (display item port)) items)))) - -(define (prn . items) - (for-each (lambda (item) (write item) (display " ")) items) - (newline)) - -(define (debug . items) - (parameterize ((current-output-port (current-error-port))) - (apply prn items))) - -(define (intersperse items sep) - (let loop ((items items) - (acc '())) - (if (null? items) - (reverse acc) - (let ((tail (cdr items))) - (if (null? tail) - (loop (cdr items) (cons (car items) acc)) - (loop (cdr items) (cons sep (cons (car items) acc)))))))) - -(define (string-intersperse items sep) - (apply string-append (intersperse items sep))) - -(define (char->string char) - (list->string (list char))) - -(define (explode string) - (map char->string (string->list string))) - -(define (list->alist items) - (let loop ((items items) - (acc '())) - (if (null? items) - (reverse acc) - (let ((key (car items))) - (when (null? (cdr items)) - (error "unbalanced list")) - (let ((value (cadr items))) - (loop (cddr items) - (cons (cons key value) acc))))))) - -(define (alist->list items) - (let loop ((items items) - (acc '())) - (if (null? items) - (reverse acc) - (let ((kv (car items))) - (loop (cdr items) - (cons (cdr kv) (cons (car kv) acc))))))) - -(define (alist-ref key alist . args) - (let ((test (if (pair? args) (car args) eqv?)) - (default (if (> (length args) 1) (cadr args) #f))) - (let loop ((items alist)) - (if (pair? items) - (let ((item (car items))) - (if (test (car item) key) - (cdr item) - (loop (cdr items)))) - default)))) - -(define (alist-map proc items) - (map (lambda (item) (proc (car item) (cdr item))) items)) - -(define (->list items) - (if (vector? items) - (vector->list items) - items)) - -(define (car-safe x) - (if (pair? x) - (car x) - '())) - -(define (cdr-safe x) - (if (pair? x) - (cdr x) - '())) - -(define (contains? items test) - (let loop ((items items)) - (if (pair? items) - (if (test (car items)) - #t - (loop (cdr items))) - #f))) - -(define (last items) - (when (null? items) - (error "empty argument")) - (let loop ((items items)) - (let ((tail (cdr items))) - (if (pair? tail) - (loop tail) - (car items))))) - -(define (butlast items) - (when (null? items) - (error "empty argument")) - (let loop ((items items) - (acc '())) - (let ((tail (cdr items))) - (if (pair? tail) - (loop tail (cons (car items) acc)) - (reverse acc))))) - -(define (identity x) x) - -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - -) - -) +(define-library (lib util) + +(export call-with-input-string call-with-output-string + str prn debug + string-intersperse explode + char->string + list->alist alist->list alist-ref alist-map + ->list car-safe cdr-safe contains? last butlast + identity readline + + ;; HACK: cyclone doesn't have those + error-object? read-error? error-object-message error-object-irritants) + +(import (scheme base)) +(import (scheme write)) + +(begin + +;; HACK: cyclone currently implements error the SICP way +(cond-expand + (cyclone + (define (error-object? x) (and (pair? x) (string? (car x)))) + (define read-error? error-object?) + (define error-object-message car) + (define error-object-irritants cdr)) + (else)) + +(define (call-with-input-string string proc) + (let ((port (open-input-string string))) + (dynamic-wind + (lambda () #t) + (lambda () (proc port)) + (lambda () (close-input-port port))))) + +(define (call-with-output-string proc) + (let ((port (open-output-string))) + (dynamic-wind + (lambda () #t) + (lambda () (proc port) (get-output-string port)) + (lambda () (close-output-port port))))) + +(define (str . items) + (call-with-output-string + (lambda (port) + (for-each (lambda (item) (display item port)) items)))) + +(define (prn . items) + (for-each (lambda (item) (write item) (display " ")) items) + (newline)) + +(define (debug . items) + (parameterize ((current-output-port (current-error-port))) + (apply prn items))) + +(define (intersperse items sep) + (let loop ((items items) + (acc '())) + (if (null? items) + (reverse acc) + (let ((tail (cdr items))) + (if (null? tail) + (loop (cdr items) (cons (car items) acc)) + (loop (cdr items) (cons sep (cons (car items) acc)))))))) + +(define (string-intersperse items sep) + (apply string-append (intersperse items sep))) + +(define (char->string char) + (list->string (list char))) + +(define (explode string) + (map char->string (string->list string))) + +(define (list->alist items) + (let loop ((items items) + (acc '())) + (if (null? items) + (reverse acc) + (let ((key (car items))) + (when (null? (cdr items)) + (error "unbalanced list")) + (let ((value (cadr items))) + (loop (cddr items) + (cons (cons key value) acc))))))) + +(define (alist->list items) + (let loop ((items items) + (acc '())) + (if (null? items) + (reverse acc) + (let ((kv (car items))) + (loop (cdr items) + (cons (cdr kv) (cons (car kv) acc))))))) + +(define (alist-ref key alist . args) + (let ((test (if (pair? args) (car args) eqv?)) + (default (if (> (length args) 1) (cadr args) #f))) + (let loop ((items alist)) + (if (pair? items) + (let ((item (car items))) + (if (test (car item) key) + (cdr item) + (loop (cdr items)))) + default)))) + +(define (alist-map proc items) + (map (lambda (item) (proc (car item) (cdr item))) items)) + +(define (->list items) + (if (vector? items) + (vector->list items) + items)) + +(define (car-safe x) + (if (pair? x) + (car x) + '())) + +(define (cdr-safe x) + (if (pair? x) + (cdr x) + '())) + +(define (contains? items test) + (let loop ((items items)) + (if (pair? items) + (if (test (car items)) + #t + (loop (cdr items))) + #f))) + +(define (last items) + (when (null? items) + (error "empty argument")) + (let loop ((items items)) + (let ((tail (cdr items))) + (if (pair? tail) + (loop tail) + (car items))))) + +(define (butlast items) + (when (null? items) + (error "empty argument")) + (let loop ((items items) + (acc '())) + (let ((tail (cdr items))) + (if (pair? tail) + (loop tail (cons (car items) acc)) + (reverse acc))))) + +(define (identity x) x) + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +) + +) diff --git a/impls/scheme/run b/impls/scheme/run index 9614f8baea..472b701a11 100755 --- a/impls/scheme/run +++ b/impls/scheme/run @@ -1,26 +1,26 @@ -#!/bin/bash -basedir=$(dirname $0) -step=${STEP:-stepA_mal} - -if [[ -e /usr/share/kawa/lib/kawa.jar ]]; then - kawa=/usr/share/kawa/lib/kawa.jar -elif [[ -e /usr/local/share/kawa/lib/kawa.jar ]]; then - kawa=/usr/local/share/kawa/lib/kawa.jar -fi - -if [[ $(which sash 2>/dev/null) ]]; then - sagittarius=sash -elif [[ $(which sagittarius 2>/dev/null) ]]; then - sagittarius=sagittarius -fi - -case ${scheme_MODE:-chibi} in - chibi) exec chibi-scheme -I$basedir $basedir/$step.scm "${@}" ;; - kawa) exec java -cp $kawa:$basedir/out $step "${@}" ;; - gauche) exec gosh -I$basedir $basedir/$step.scm "${@}" ;; - chicken) CHICKEN_REPOSITORY=$basedir/eggs exec $basedir/$step "${@}" ;; - sagittarius) exec $sagittarius -n -L$basedir $basedir/$step.scm "${@}" ;; - cyclone) exec $basedir/$step "${@}" ;; - foment) exec foment $basedir/$step.scm "${@}" ;; - *) echo "Invalid scheme_MODE: ${scheme_MODE}"; exit 2 ;; -esac +#!/bin/bash +basedir=$(dirname $0) +step=${STEP:-stepA_mal} + +if [[ -e /usr/share/kawa/lib/kawa.jar ]]; then + kawa=/usr/share/kawa/lib/kawa.jar +elif [[ -e /usr/local/share/kawa/lib/kawa.jar ]]; then + kawa=/usr/local/share/kawa/lib/kawa.jar +fi + +if [[ $(which sash 2>/dev/null) ]]; then + sagittarius=sash +elif [[ $(which sagittarius 2>/dev/null) ]]; then + sagittarius=sagittarius +fi + +case ${scheme_MODE:-chibi} in + chibi) exec chibi-scheme -I$basedir $basedir/$step.scm "${@}" ;; + kawa) exec java -cp $kawa:$basedir/out $step "${@}" ;; + gauche) exec gosh -I$basedir $basedir/$step.scm "${@}" ;; + chicken) CHICKEN_REPOSITORY=$basedir/eggs exec $basedir/$step "${@}" ;; + sagittarius) exec $sagittarius -n -L$basedir $basedir/$step.scm "${@}" ;; + cyclone) exec $basedir/$step "${@}" ;; + foment) exec foment $basedir/$step.scm "${@}" ;; + *) echo "Invalid scheme_MODE: ${scheme_MODE}"; exit 2 ;; +esac diff --git a/impls/scheme/step0_repl.scm b/impls/scheme/step0_repl.scm index c02c11ea9d..972c357c2e 100644 --- a/impls/scheme/step0_repl.scm +++ b/impls/scheme/step0_repl.scm @@ -1,33 +1,33 @@ -(import (scheme base)) -(import (scheme write)) - -(define (READ input) - input) - -(define (EVAL input) - input) - -(define (PRINT input) - input) - -(define (rep input) - (PRINT (EVAL (READ input)))) - -(define (readline prompt) - (display prompt) - (flush-output-port) - (let ((input (read-line))) - (if (eof-object? input) - #f - input))) - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (display (rep input)) - (newline) - (loop)))) - (newline)) - -(main) +(import (scheme base)) +(import (scheme write)) + +(define (READ input) + input) + +(define (EVAL input) + input) + +(define (PRINT input) + input) + +(define (rep input) + (PRINT (EVAL (READ input)))) + +(define (readline prompt) + (display prompt) + (flush-output-port) + (let ((input (read-line))) + (if (eof-object? input) + #f + input))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (display (rep input)) + (newline) + (loop)))) + (newline)) + +(main) diff --git a/impls/scheme/step1_read_print.scm b/impls/scheme/step1_read_print.scm index 6cb64d0d64..c66d69123f 100644 --- a/impls/scheme/step1_read_print.scm +++ b/impls/scheme/step1_read_print.scm @@ -1,36 +1,36 @@ -(import (scheme base)) -(import (scheme write)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) - -(define (READ input) - (read-str input)) - -(define (EVAL ast) - ast) - -(define (PRINT ast) - (pr-str ast #t)) - -(define (rep input) - (PRINT (EVAL (READ input)))) - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline)))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(main) +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) + +(define (READ input) + (read-str input)) + +(define (EVAL ast) + ast) + +(define (PRINT ast) + (pr-str ast #t)) + +(define (rep input) + (PRINT (EVAL (READ input)))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) diff --git a/impls/scheme/step2_eval.scm b/impls/scheme/step2_eval.scm index 87db7ee741..935ab64312 100644 --- a/impls/scheme/step2_eval.scm +++ b/impls/scheme/step2_eval.scm @@ -1,62 +1,62 @@ -(import (scheme base)) -(import (scheme write)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) - -(define (READ input) - (read-str input)) - -(define (eval-ast ast env) - (let ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((symbol) (or (alist-ref value env) - (error (str "'" value "' not found")))) - ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) - ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) - ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) - (else ast)))) - -(define (EVAL ast env) - (let ((type (and (mal-object? ast) (mal-type ast)))) - (if (not (eq? type 'list)) - (eval-ast ast env) - (let ((items (mal-value ast))) - (if (null? items) - ast - (let* ((items (mal-value (eval-ast ast env))) - (op (car items)) - (ops (cdr items))) - (apply op ops))))))) - -(define (PRINT ast) - (pr-str ast #t)) - -(define repl-env - `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) - (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) - (* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) - (/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))))) - -(define (rep input) - (PRINT (EVAL (READ input) repl-env))) - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline)))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(main) +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (or (alist-ref value env) + (error (str "'" value "' not found")))) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (apply op ops))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env + `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) + (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) + (* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) + (/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))))) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) diff --git a/impls/scheme/step3_env.scm b/impls/scheme/step3_env.scm index ab21a126e9..83a03dcff8 100644 --- a/impls/scheme/step3_env.scm +++ b/impls/scheme/step3_env.scm @@ -1,83 +1,83 @@ -(import (scheme base)) -(import (scheme write)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) -(import (lib env)) - -(define (READ input) - (read-str input)) - -(define (eval-ast ast env) - (let ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((symbol) (env-get env value)) - ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) - ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) - ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) - (else ast)))) - -(define (EVAL ast env) - (let ((type (and (mal-object? ast) (mal-type ast)))) - (if (not (eq? type 'list)) - (eval-ast ast env) - (let ((items (mal-value ast))) - (if (null? items) - ast - (case (mal-value (car items)) - ((def!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (env-set env symbol value) - value)) - ((let*) - (let* ((env* (make-env env)) - (binds (mal-value (cadr items))) - (binds (if (vector? binds) (vector->list binds) binds)) - (form (list-ref items 2))) - (let loop ((binds binds)) - (when (pair? binds) - (let ((key (mal-value (car binds)))) - (when (null? (cdr binds)) - (error "unbalanced list")) - (let ((value (EVAL (cadr binds) env*))) - (env-set env* key value) - (loop (cddr binds)))))) - (EVAL form env*))) - (else - (let* ((items (mal-value (eval-ast ast env))) - (op (car items)) - (ops (cdr items))) - (apply op ops))))))))) - -(define (PRINT ast) - (pr-str ast #t)) - -(define repl-env (make-env #f)) -(env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) -(env-set repl-env '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) -(env-set repl-env '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) -(env-set repl-env '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) - -(define (rep input) - (PRINT (EVAL (READ input) repl-env))) - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline)))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(main) +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (case (mal-value (car items)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let* ((env* (make-env env)) + (binds (mal-value (cadr items))) + (binds (if (vector? binds) (vector->list binds) binds)) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (apply op ops))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b))))) +(env-set repl-env '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b))))) +(env-set repl-env '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b))))) +(env-set repl-env '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b))))) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline)))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) diff --git a/impls/scheme/step4_if_fn_do.scm b/impls/scheme/step4_if_fn_do.scm index b077be9a11..5b0e4e9b77 100644 --- a/impls/scheme/step4_if_fn_do.scm +++ b/impls/scheme/step4_if_fn_do.scm @@ -1,115 +1,115 @@ -(import (scheme base)) -(import (scheme write)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) -(import (lib env)) -(import (lib core)) - -(define (READ input) - (read-str input)) - -(define (eval-ast ast env) - (let ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((symbol) (env-get env value)) - ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) - ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) - ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) - (else ast)))) - -(define (EVAL ast env) - (let ((type (and (mal-object? ast) (mal-type ast)))) - (if (not (eq? type 'list)) - (eval-ast ast env) - (let ((items (mal-value ast))) - (if (null? items) - ast - (case (mal-value (car items)) - ((def!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (env-set env symbol value) - value)) - ((let*) - (let ((env* (make-env env)) - (binds (->list (mal-value (cadr items)))) - (form (list-ref items 2))) - (let loop ((binds binds)) - (when (pair? binds) - (let ((key (mal-value (car binds)))) - (when (null? (cdr binds)) - (error "unbalanced list")) - (let ((value (EVAL (cadr binds) env*))) - (env-set env* key value) - (loop (cddr binds)))))) - (EVAL form env*))) - ((do) - (let ((forms (cdr items))) - (if (null? forms) - mal-nil - ;; the evaluation order of map is unspecified - (let loop ((forms forms)) - (let ((form (car forms)) - (tail (cdr forms))) - (if (null? tail) - (EVAL form env) - (begin - (EVAL form env) - (loop tail)))))))) - ((if) - (let* ((condition (EVAL (cadr items) env)) - (type (and (mal-object? condition) - (mal-type condition)))) - (if (memq type '(false nil)) - (if (< (length items) 4) - mal-nil - (EVAL (list-ref items 3) env)) - (EVAL (list-ref items 2) env)))) - ((fn*) - (let* ((binds (->list (mal-value (cadr items)))) - (binds (map mal-value binds)) - (body (list-ref items 2))) - (lambda args - (let ((env* (make-env env binds args))) - (EVAL body env*))))) - (else - (let* ((items (mal-value (eval-ast ast env))) - (op (car items)) - (ops (cdr items))) - (apply op ops))))))))) - -(define (PRINT ast) - (pr-str ast #t)) - -(define repl-env (make-env #f)) -(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) - -(define (rep input) - (PRINT (EVAL (READ input) repl-env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline))) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (display "[error] ") - (display (pr-str (cdr ex) #t)) - (newline))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(main) +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (case (mal-value (car items)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) + (EVAL (list-ref items 2) env)))) + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2))) + (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (apply op ops))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) diff --git a/impls/scheme/step5_tco.scm b/impls/scheme/step5_tco.scm index 87a029158c..10a56126ad 100644 --- a/impls/scheme/step5_tco.scm +++ b/impls/scheme/step5_tco.scm @@ -1,121 +1,121 @@ -(import (scheme base)) -(import (scheme write)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) -(import (lib env)) -(import (lib core)) - -(define (READ input) - (read-str input)) - -(define (eval-ast ast env) - (let ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((symbol) (env-get env value)) - ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) - ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) - ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) - (else ast)))) - -(define (EVAL ast env) - (let ((type (and (mal-object? ast) (mal-type ast)))) - (if (not (eq? type 'list)) - (eval-ast ast env) - (let ((items (mal-value ast))) - (if (null? items) - ast - (case (mal-value (car items)) - ((def!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (env-set env symbol value) - value)) - ((let*) - (let ((env* (make-env env)) - (binds (->list (mal-value (cadr items)))) - (form (list-ref items 2))) - (let loop ((binds binds)) - (when (pair? binds) - (let ((key (mal-value (car binds)))) - (when (null? (cdr binds)) - (error "unbalanced list")) - (let ((value (EVAL (cadr binds) env*))) - (env-set env* key value) - (loop (cddr binds)))))) - (EVAL form env*))) ; TCO - ((do) - (let ((forms (cdr items))) - (if (null? forms) - mal-nil - ;; the evaluation order of map is unspecified - (let loop ((forms forms)) - (let ((form (car forms)) - (tail (cdr forms))) - (if (null? tail) - (EVAL form env) ; TCO - (begin - (EVAL form env) - (loop tail)))))))) - ((if) - (let* ((condition (EVAL (cadr items) env)) - (type (and (mal-object? condition) - (mal-type condition)))) - (if (memq type '(false nil)) - (if (< (length items) 4) - mal-nil - (EVAL (list-ref items 3) env)) ; TCO - (EVAL (list-ref items 2) env)))) ; TCO - ((fn*) - (let* ((binds (->list (mal-value (cadr items)))) - (binds (map mal-value binds)) - (body (list-ref items 2)) - (fn (lambda args - (let ((env* (make-env env binds args))) - (EVAL body env*))))) - (make-func body binds env fn))) - (else - (let* ((items (mal-value (eval-ast ast env))) - (op (car items)) - (ops (cdr items))) - (if (func? op) - (let* ((outer (func-env op)) - (binds (func-params op)) - (env* (make-env outer binds ops))) - (EVAL (func-ast op) env*)) ; TCO - (apply op ops)))))))))) - -(define (PRINT ast) - (pr-str ast #t)) - -(define repl-env (make-env #f)) -(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) - -(define (rep input) - (PRINT (EVAL (READ input) repl-env))) - -(rep "(def! not (fn* (a) (if a false true)))") - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline))) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (display "[error] ") - (display (pr-str (cdr ex) #t)) - (newline))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(main) +(import (scheme base)) +(import (scheme write)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (case (mal-value (car items)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops)))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(rep "(def! not (fn* (a) (if a false true)))") + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(main) diff --git a/impls/scheme/step6_file.scm b/impls/scheme/step6_file.scm index bb4fed0724..3801bf9b3e 100644 --- a/impls/scheme/step6_file.scm +++ b/impls/scheme/step6_file.scm @@ -1,131 +1,131 @@ -(import (scheme base)) -(import (scheme write)) -(import (scheme process-context)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) -(import (lib env)) -(import (lib core)) - -(define (READ input) - (read-str input)) - -(define (eval-ast ast env) - (let ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((symbol) (env-get env value)) - ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) - ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) - ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) - (else ast)))) - -(define (EVAL ast env) - (let ((type (and (mal-object? ast) (mal-type ast)))) - (if (not (eq? type 'list)) - (eval-ast ast env) - (let ((items (mal-value ast))) - (if (null? items) - ast - (let ((a0 (car items))) - (case (and (mal-object? a0) (mal-value a0)) - ((def!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (env-set env symbol value) - value)) - ((let*) - (let ((env* (make-env env)) - (binds (->list (mal-value (cadr items)))) - (form (list-ref items 2))) - (let loop ((binds binds)) - (when (pair? binds) - (let ((key (mal-value (car binds)))) - (when (null? (cdr binds)) - (error "unbalanced list")) - (let ((value (EVAL (cadr binds) env*))) - (env-set env* key value) - (loop (cddr binds)))))) - (EVAL form env*))) ; TCO - ((do) - (let ((forms (cdr items))) - (if (null? forms) - mal-nil - ;; the evaluation order of map is unspecified - (let loop ((forms forms)) - (let ((form (car forms)) - (tail (cdr forms))) - (if (null? tail) - (EVAL form env) ; TCO - (begin - (EVAL form env) - (loop tail)))))))) - ((if) - (let* ((condition (EVAL (cadr items) env)) - (type (and (mal-object? condition) - (mal-type condition)))) - (if (memq type '(false nil)) - (if (< (length items) 4) - mal-nil - (EVAL (list-ref items 3) env)) ; TCO - (EVAL (list-ref items 2) env)))) ; TCO - ((fn*) - (let* ((binds (->list (mal-value (cadr items)))) - (binds (map mal-value binds)) - (body (list-ref items 2)) - (fn (lambda args - (let ((env* (make-env env binds args))) - (EVAL body env*))))) - (make-func body binds env fn))) - (else - (let* ((items (mal-value (eval-ast ast env))) - (op (car items)) - (ops (cdr items))) - (if (func? op) - (let* ((outer (func-env op)) - (binds (func-params op)) - (env* (make-env outer binds ops))) - (EVAL (func-ast op) env*)) ; TCO - (apply op ops))))))))))) - -(define (PRINT ast) - (pr-str ast #t)) - -(define repl-env (make-env #f)) -(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) - -(define (rep input) - (PRINT (EVAL (READ input) repl-env))) - -(define args (cdr (command-line))) - -(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline))) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (display "[error] ") - (display (pr-str (cdr ex) #t)) - (newline))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(if (null? args) - (main) - (rep (string-append "(load-file \"" (car args) "\")"))) +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define args (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? args) + (main) + (rep (string-append "(load-file \"" (car args) "\")"))) diff --git a/impls/scheme/step7_quote.scm b/impls/scheme/step7_quote.scm index b5527b8a97..9565c92781 100644 --- a/impls/scheme/step7_quote.scm +++ b/impls/scheme/step7_quote.scm @@ -1,159 +1,159 @@ -(import (scheme base)) -(import (scheme write)) -(import (scheme process-context)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) -(import (lib env)) -(import (lib core)) - -(define (READ input) - (read-str input)) - -(define (eval-ast ast env) - (let ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((symbol) (env-get env value)) - ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) - ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) - ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) - (else ast)))) - -(define (starts-with? ast sym) - (let ((items (mal-value ast))) - (and (not (null? items)) - (let ((a0 (car items))) - (and (mal-instance-of? a0 'symbol) - (eq? (mal-value a0) sym)))))) - -(define (qq-lst xs) - (if (null? xs) - (mal-list '()) - (let ((elt (car xs)) - (acc (qq-lst (cdr xs)))) - (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote)) - (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc)) - (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc)))))) - -(define (QUASIQUOTE ast) - (case (and (mal-object? ast) (mal-type ast)) - ((list) (if (starts-with? ast 'unquote) - (cadr (mal-value ast)) - (qq-lst (->list (mal-value ast))))) - ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast)))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (else ast))) - -(define (EVAL ast env) - (let ((type (and (mal-object? ast) (mal-type ast)))) - (if (not (eq? type 'list)) - (eval-ast ast env) - (let ((items (mal-value ast))) - (if (null? items) - ast - (let ((a0 (car items))) - (case (and (mal-object? a0) (mal-value a0)) - ((def!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (env-set env symbol value) - value)) - ((let*) - (let ((env* (make-env env)) - (binds (->list (mal-value (cadr items)))) - (form (list-ref items 2))) - (let loop ((binds binds)) - (when (pair? binds) - (let ((key (mal-value (car binds)))) - (when (null? (cdr binds)) - (error "unbalanced list")) - (let ((value (EVAL (cadr binds) env*))) - (env-set env* key value) - (loop (cddr binds)))))) - (EVAL form env*))) ; TCO - ((do) - (let ((forms (cdr items))) - (if (null? forms) - mal-nil - ;; the evaluation order of map is unspecified - (let loop ((forms forms)) - (let ((form (car forms)) - (tail (cdr forms))) - (if (null? tail) - (EVAL form env) ; TCO - (begin - (EVAL form env) - (loop tail)))))))) - ((if) - (let* ((condition (EVAL (cadr items) env)) - (type (and (mal-object? condition) - (mal-type condition)))) - (if (memq type '(false nil)) - (if (< (length items) 4) - mal-nil - (EVAL (list-ref items 3) env)) ; TCO - (EVAL (list-ref items 2) env)))) ; TCO - ((quote) (cadr items)) - ((quasiquoteexpand) (QUASIQUOTE (cadr items))) - ((quasiquote) (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO - ((fn*) - (let* ((binds (->list (mal-value (cadr items)))) - (binds (map mal-value binds)) - (body (list-ref items 2)) - (fn (lambda args - (let ((env* (make-env env binds args))) - (EVAL body env*))))) - (make-func body binds env fn))) - (else - (let* ((items (mal-value (eval-ast ast env))) - (op (car items)) - (ops (cdr items))) - (if (func? op) - (let* ((outer (func-env op)) - (binds (func-params op)) - (env* (make-env outer binds ops))) - (EVAL (func-ast op) env*)) ; TCO - (apply op ops))))))))))) - -(define (PRINT ast) - (pr-str ast #t)) - -(define repl-env (make-env #f)) -(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) - -(define (rep input) - (PRINT (EVAL (READ input) repl-env))) - -(define args (cdr (command-line))) - -(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline))) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (display "[error] ") - (display (pr-str (cdr ex) #t)) - (newline))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(if (null? args) - (main) - (rep (string-append "(load-file \"" (car args) "\")"))) +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (starts-with? ast sym) + (let ((items (mal-value ast))) + (and (not (null? items)) + (let ((a0 (car items))) + (and (mal-instance-of? a0 'symbol) + (eq? (mal-value a0) sym)))))) + +(define (qq-lst xs) + (if (null? xs) + (mal-list '()) + (let ((elt (car xs)) + (acc (qq-lst (cdr xs)))) + (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote)) + (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc)) + (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc)))))) + +(define (QUASIQUOTE ast) + (case (and (mal-object? ast) (mal-type ast)) + ((list) (if (starts-with? ast 'unquote) + (cadr (mal-value ast)) + (qq-lst (->list (mal-value ast))))) + ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast)))))) + ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) + (else ast))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (let ((items (mal-value ast))) + (if (null? items) + ast + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((quote) (cadr items)) + ((quasiquoteexpand) (QUASIQUOTE (cadr items))) + ((quasiquote) (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define args (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? args) + (main) + (rep (string-append "(load-file \"" (car args) "\")"))) diff --git a/impls/scheme/step8_macros.scm b/impls/scheme/step8_macros.scm index bd978b2b83..1bea49b106 100644 --- a/impls/scheme/step8_macros.scm +++ b/impls/scheme/step8_macros.scm @@ -1,198 +1,198 @@ -(import (scheme base)) -(import (scheme write)) -(import (scheme process-context)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) -(import (lib env)) -(import (lib core)) - -(define (READ input) - (read-str input)) - -(define (eval-ast ast env) - (let ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((symbol) (env-get env value)) - ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) - ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) - ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) - (else ast)))) - -(define (starts-with? ast sym) - (let ((items (mal-value ast))) - (and (not (null? items)) - (let ((a0 (car items))) - (and (mal-instance-of? a0 'symbol) - (eq? (mal-value a0) sym)))))) - -(define (qq-lst xs) - (if (null? xs) - (mal-list '()) - (let ((elt (car xs)) - (acc (qq-lst (cdr xs)))) - (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote)) - (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc)) - (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc)))))) - -(define (QUASIQUOTE ast) - (case (and (mal-object? ast) (mal-type ast)) - ((list) (if (starts-with? ast 'unquote) - (cadr (mal-value ast)) - (qq-lst (->list (mal-value ast))))) - ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast)))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (else ast))) - -(define (is-macro-call? ast env) - (if (mal-instance-of? ast 'list) - (let ((op (car-safe (mal-value ast)))) - (if (mal-instance-of? op 'symbol) - (let ((x (env-find env (mal-value op)))) - (if x - (if (and (func? x) (func-macro? x)) - #t - #f) - #f)) - #f)) - #f)) - -(define (macroexpand ast env) - (let loop ((ast ast)) - (if (is-macro-call? ast env) - (let* ((items (mal-value ast)) - (op (car items)) - (ops (cdr items)) - (fn (func-fn (env-get env (mal-value op))))) - (loop (apply fn ops))) - ast))) - -(define (EVAL ast env) - (let ((type (and (mal-object? ast) (mal-type ast)))) - (if (not (eq? type 'list)) - (eval-ast ast env) - (if (null? (mal-value ast)) - ast - (let* ((ast (macroexpand ast env)) - (items (mal-value ast))) - (if (not (mal-instance-of? ast 'list)) - (eval-ast ast env) - (let ((a0 (car items))) - (case (and (mal-object? a0) (mal-value a0)) - ((def!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (env-set env symbol value) - value)) - ((defmacro!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (when (func? value) - (func-macro?-set! value #t)) - (env-set env symbol value) - value)) - ((macroexpand) - (macroexpand (cadr items) env)) - ((let*) - (let ((env* (make-env env)) - (binds (->list (mal-value (cadr items)))) - (form (list-ref items 2))) - (let loop ((binds binds)) - (when (pair? binds) - (let ((key (mal-value (car binds)))) - (when (null? (cdr binds)) - (error "unbalanced list")) - (let ((value (EVAL (cadr binds) env*))) - (env-set env* key value) - (loop (cddr binds)))))) - (EVAL form env*))) ; TCO - ((do) - (let ((forms (cdr items))) - (if (null? forms) - mal-nil - ;; the evaluation order of map is unspecified - (let loop ((forms forms)) - (let ((form (car forms)) - (tail (cdr forms))) - (if (null? tail) - (EVAL form env) ; TCO - (begin - (EVAL form env) - (loop tail)))))))) - ((if) - (let* ((condition (EVAL (cadr items) env)) - (type (and (mal-object? condition) - (mal-type condition)))) - (if (memq type '(false nil)) - (if (< (length items) 4) - mal-nil - (EVAL (list-ref items 3) env)) ; TCO - (EVAL (list-ref items 2) env)))) ; TCO - ((quote) - (cadr items)) - ((quasiquoteexpand) - (QUASIQUOTE (cadr items))) - ((quasiquote) - (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO - ((fn*) - (let* ((binds (->list (mal-value (cadr items)))) - (binds (map mal-value binds)) - (body (list-ref items 2)) - (fn (lambda args - (let ((env* (make-env env binds args))) - (EVAL body env*))))) - (make-func body binds env fn))) - (else - (let* ((items (mal-value (eval-ast ast env))) - (op (car items)) - (ops (cdr items))) - (if (func? op) - (let* ((outer (func-env op)) - (binds (func-params op)) - (env* (make-env outer binds ops))) - (EVAL (func-ast op) env*)) ; TCO - (apply op ops)))))))))))) - -(define (PRINT ast) - (pr-str ast #t)) - -(define repl-env (make-env #f)) -(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) - -(define (rep input) - (PRINT (EVAL (READ input) repl-env))) - -(define args (cdr (command-line))) - -(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline))) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (display "[error] ") - (display (pr-str (cdr ex) #t)) - (newline))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(if (null? args) - (main) - (rep (string-append "(load-file \"" (car args) "\")"))) +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (starts-with? ast sym) + (let ((items (mal-value ast))) + (and (not (null? items)) + (let ((a0 (car items))) + (and (mal-instance-of? a0 'symbol) + (eq? (mal-value a0) sym)))))) + +(define (qq-lst xs) + (if (null? xs) + (mal-list '()) + (let ((elt (car xs)) + (acc (qq-lst (cdr xs)))) + (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote)) + (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc)) + (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc)))))) + +(define (QUASIQUOTE ast) + (case (and (mal-object? ast) (mal-type ast)) + ((list) (if (starts-with? ast 'unquote) + (cadr (mal-value ast)) + (qq-lst (->list (mal-value ast))))) + ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast)))))) + ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) + (else ast))) + +(define (is-macro-call? ast env) + (if (mal-instance-of? ast 'list) + (let ((op (car-safe (mal-value ast)))) + (if (mal-instance-of? op 'symbol) + (let ((x (env-find env (mal-value op)))) + (if x + (if (and (func? x) (func-macro? x)) + #t + #f) + #f)) + #f)) + #f)) + +(define (macroexpand ast env) + (let loop ((ast ast)) + (if (is-macro-call? ast env) + (let* ((items (mal-value ast)) + (op (car items)) + (ops (cdr items)) + (fn (func-fn (env-get env (mal-value op))))) + (loop (apply fn ops))) + ast))) + +(define (EVAL ast env) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (if (null? (mal-value ast)) + ast + (let* ((ast (macroexpand ast env)) + (items (mal-value ast))) + (if (not (mal-instance-of? ast 'list)) + (eval-ast ast env) + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((defmacro!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (when (func? value) + (func-macro?-set! value #t)) + (env-set env symbol value) + value)) + ((macroexpand) + (macroexpand (cadr items) env)) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((quote) + (cadr items)) + ((quasiquoteexpand) + (QUASIQUOTE (cadr items))) + ((quasiquote) + (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops)))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define args (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? args) + (main) + (rep (string-append "(load-file \"" (car args) "\")"))) diff --git a/impls/scheme/step9_try.scm b/impls/scheme/step9_try.scm index a670289e01..a98f3227cf 100644 --- a/impls/scheme/step9_try.scm +++ b/impls/scheme/step9_try.scm @@ -1,216 +1,216 @@ -(import (scheme base)) -(import (scheme write)) -(import (scheme process-context)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) -(import (lib env)) -(import (lib core)) - -(define (READ input) - (read-str input)) - -(define (eval-ast ast env) - (let ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((symbol) (env-get env value)) - ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) - ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) - ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) - (else ast)))) - -(define (starts-with? ast sym) - (let ((items (mal-value ast))) - (and (not (null? items)) - (let ((a0 (car items))) - (and (mal-instance-of? a0 'symbol) - (eq? (mal-value a0) sym)))))) - -(define (qq-lst xs) - (if (null? xs) - (mal-list '()) - (let ((elt (car xs)) - (acc (qq-lst (cdr xs)))) - (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote)) - (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc)) - (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc)))))) - -(define (QUASIQUOTE ast) - (case (and (mal-object? ast) (mal-type ast)) - ((list) (if (starts-with? ast 'unquote) - (cadr (mal-value ast)) - (qq-lst (->list (mal-value ast))))) - ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast)))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (else ast))) - -(define (is-macro-call? ast env) - (if (mal-instance-of? ast 'list) - (let ((op (car-safe (mal-value ast)))) - (if (mal-instance-of? op 'symbol) - (let ((x (env-find env (mal-value op)))) - (if x - (if (and (func? x) (func-macro? x)) - #t - #f) - #f)) - #f)) - #f)) - -(define (macroexpand ast env) - (let loop ((ast ast)) - (if (is-macro-call? ast env) - (let* ((items (mal-value ast)) - (op (car items)) - (ops (cdr items)) - (fn (func-fn (env-get env (mal-value op))))) - (loop (apply fn ops))) - ast))) - -(define (EVAL ast env) - (define (handle-catch value handler) - (let* ((symbol (mal-value (cadr handler))) - (form (list-ref handler 2)) - (env* (make-env env (list symbol) (list value)))) - (EVAL form env*))) - (let ((type (and (mal-object? ast) (mal-type ast)))) - (if (not (eq? type 'list)) - (eval-ast ast env) - (if (null? (mal-value ast)) - ast - (let* ((ast (macroexpand ast env)) - (items (mal-value ast))) - (if (not (mal-instance-of? ast 'list)) - (eval-ast ast env) - (let ((a0 (car items))) - (case (and (mal-object? a0) (mal-value a0)) - ((def!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (env-set env symbol value) - value)) - ((defmacro!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (when (func? value) - (func-macro?-set! value #t)) - (env-set env symbol value) - value)) - ((macroexpand) - (macroexpand (cadr items) env)) - ((try*) - (if (< (length items) 3) - (EVAL (cadr items) env) - (let* ((form (cadr items)) - (handler (mal-value (list-ref items 2)))) - (guard - (ex ((error-object? ex) - (handle-catch - (mal-string (error-object-message ex)) - handler)) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (handle-catch (cdr ex) handler))) - (EVAL form env))))) - ((let*) - (let ((env* (make-env env)) - (binds (->list (mal-value (cadr items)))) - (form (list-ref items 2))) - (let loop ((binds binds)) - (when (pair? binds) - (let ((key (mal-value (car binds)))) - (when (null? (cdr binds)) - (error "unbalanced list")) - (let ((value (EVAL (cadr binds) env*))) - (env-set env* key value) - (loop (cddr binds)))))) - (EVAL form env*))) ; TCO - ((do) - (let ((forms (cdr items))) - (if (null? forms) - mal-nil - ;; the evaluation order of map is unspecified - (let loop ((forms forms)) - (let ((form (car forms)) - (tail (cdr forms))) - (if (null? tail) - (EVAL form env) ; TCO - (begin - (EVAL form env) - (loop tail)))))))) - ((if) - (let* ((condition (EVAL (cadr items) env)) - (type (and (mal-object? condition) - (mal-type condition)))) - (if (memq type '(false nil)) - (if (< (length items) 4) - mal-nil - (EVAL (list-ref items 3) env)) ; TCO - (EVAL (list-ref items 2) env)))) ; TCO - ((quote) - (cadr items)) - ((quasiquoteexpand) - (QUASIQUOTE (cadr items))) - ((quasiquote) - (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO - ((fn*) - (let* ((binds (->list (mal-value (cadr items)))) - (binds (map mal-value binds)) - (body (list-ref items 2)) - (fn (lambda args - (let ((env* (make-env env binds args))) - (EVAL body env*))))) - (make-func body binds env fn))) - (else - (let* ((items (mal-value (eval-ast ast env))) - (op (car items)) - (ops (cdr items))) - (if (func? op) - (let* ((outer (func-env op)) - (binds (func-params op)) - (env* (make-env outer binds ops))) - (EVAL (func-ast op) env*)) ; TCO - (apply op ops)))))))))))) - -(define (PRINT ast) - (pr-str ast #t)) - -(define repl-env (make-env #f)) -(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) - -(define (rep input) - (PRINT (EVAL (READ input) repl-env))) - -(define args (cdr (command-line))) - -(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(define (main) - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline))) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (display "[error] ") - (display (pr-str (cdr ex) #t)) - (newline))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(if (null? args) - (main) - (rep (string-append "(load-file \"" (car args) "\")"))) +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (starts-with? ast sym) + (let ((items (mal-value ast))) + (and (not (null? items)) + (let ((a0 (car items))) + (and (mal-instance-of? a0 'symbol) + (eq? (mal-value a0) sym)))))) + +(define (qq-lst xs) + (if (null? xs) + (mal-list '()) + (let ((elt (car xs)) + (acc (qq-lst (cdr xs)))) + (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote)) + (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc)) + (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc)))))) + +(define (QUASIQUOTE ast) + (case (and (mal-object? ast) (mal-type ast)) + ((list) (if (starts-with? ast 'unquote) + (cadr (mal-value ast)) + (qq-lst (->list (mal-value ast))))) + ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast)))))) + ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) + (else ast))) + +(define (is-macro-call? ast env) + (if (mal-instance-of? ast 'list) + (let ((op (car-safe (mal-value ast)))) + (if (mal-instance-of? op 'symbol) + (let ((x (env-find env (mal-value op)))) + (if x + (if (and (func? x) (func-macro? x)) + #t + #f) + #f)) + #f)) + #f)) + +(define (macroexpand ast env) + (let loop ((ast ast)) + (if (is-macro-call? ast env) + (let* ((items (mal-value ast)) + (op (car items)) + (ops (cdr items)) + (fn (func-fn (env-get env (mal-value op))))) + (loop (apply fn ops))) + ast))) + +(define (EVAL ast env) + (define (handle-catch value handler) + (let* ((symbol (mal-value (cadr handler))) + (form (list-ref handler 2)) + (env* (make-env env (list symbol) (list value)))) + (EVAL form env*))) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (if (null? (mal-value ast)) + ast + (let* ((ast (macroexpand ast env)) + (items (mal-value ast))) + (if (not (mal-instance-of? ast 'list)) + (eval-ast ast env) + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((defmacro!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (when (func? value) + (func-macro?-set! value #t)) + (env-set env symbol value) + value)) + ((macroexpand) + (macroexpand (cadr items) env)) + ((try*) + (if (< (length items) 3) + (EVAL (cadr items) env) + (let* ((form (cadr items)) + (handler (mal-value (list-ref items 2)))) + (guard + (ex ((error-object? ex) + (handle-catch + (mal-string (error-object-message ex)) + handler)) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (handle-catch (cdr ex) handler))) + (EVAL form env))))) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((quote) + (cadr items)) + ((quasiquoteexpand) + (QUASIQUOTE (cadr items))) + ((quasiquote) + (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops)))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define args (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(define (main) + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? args) + (main) + (rep (string-append "(load-file \"" (car args) "\")"))) diff --git a/impls/scheme/stepA_mal.scm b/impls/scheme/stepA_mal.scm index f054354bf2..d08ca5d947 100644 --- a/impls/scheme/stepA_mal.scm +++ b/impls/scheme/stepA_mal.scm @@ -1,219 +1,219 @@ -(import (scheme base)) -(import (scheme write)) -(import (scheme process-context)) - -(import (lib util)) -(import (lib reader)) -(import (lib printer)) -(import (lib types)) -(import (lib env)) -(import (lib core)) - -(define (READ input) - (read-str input)) - -(define (eval-ast ast env) - (let ((type (and (mal-object? ast) (mal-type ast))) - (value (and (mal-object? ast) (mal-value ast)))) - (case type - ((symbol) (env-get env value)) - ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) - ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) - ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) - (else ast)))) - -(define (starts-with? ast sym) - (let ((items (mal-value ast))) - (and (not (null? items)) - (let ((a0 (car items))) - (and (mal-instance-of? a0 'symbol) - (eq? (mal-value a0) sym)))))) - -(define (qq-lst xs) - (if (null? xs) - (mal-list '()) - (let ((elt (car xs)) - (acc (qq-lst (cdr xs)))) - (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote)) - (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc)) - (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc)))))) - -(define (QUASIQUOTE ast) - (case (and (mal-object? ast) (mal-type ast)) - ((list) (if (starts-with? ast 'unquote) - (cadr (mal-value ast)) - (qq-lst (->list (mal-value ast))))) - ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast)))))) - ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) - (else ast))) - -(define (is-macro-call? ast env) - (if (mal-instance-of? ast 'list) - (let ((op (car-safe (mal-value ast)))) - (if (mal-instance-of? op 'symbol) - (let ((x (env-find env (mal-value op)))) - (if x - (if (and (func? x) (func-macro? x)) - #t - #f) - #f)) - #f)) - #f)) - -(define (macroexpand ast env) - (let loop ((ast ast)) - (if (is-macro-call? ast env) - (let* ((items (mal-value ast)) - (op (car items)) - (ops (cdr items)) - (fn (func-fn (env-get env (mal-value op))))) - (loop (apply fn ops))) - ast))) - -(define (EVAL ast env) - (define (handle-catch value handler) - (let* ((symbol (mal-value (cadr handler))) - (form (list-ref handler 2)) - (env* (make-env env (list symbol) (list value)))) - (EVAL form env*))) - (let ((type (and (mal-object? ast) (mal-type ast)))) - (if (not (eq? type 'list)) - (eval-ast ast env) - (if (null? (mal-value ast)) - ast - (let* ((ast (macroexpand ast env)) - (items (mal-value ast))) - (if (not (mal-instance-of? ast 'list)) - (eval-ast ast env) - (let ((a0 (car items))) - (case (and (mal-object? a0) (mal-value a0)) - ((def!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (env-set env symbol value) - value)) - ((defmacro!) - (let ((symbol (mal-value (cadr items))) - (value (EVAL (list-ref items 2) env))) - (when (func? value) - (func-macro?-set! value #t)) - (env-set env symbol value) - value)) - ((macroexpand) - (macroexpand (cadr items) env)) - ((try*) - (if (< (length items) 3) - (EVAL (cadr items) env) - (let* ((form (cadr items)) - (handler (mal-value (list-ref items 2)))) - (guard - (ex ((error-object? ex) - (handle-catch - (mal-string (error-object-message ex)) - handler)) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (handle-catch (cdr ex) handler))) - (EVAL form env))))) - ((let*) - (let ((env* (make-env env)) - (binds (->list (mal-value (cadr items)))) - (form (list-ref items 2))) - (let loop ((binds binds)) - (when (pair? binds) - (let ((key (mal-value (car binds)))) - (when (null? (cdr binds)) - (error "unbalanced list")) - (let ((value (EVAL (cadr binds) env*))) - (env-set env* key value) - (loop (cddr binds)))))) - (EVAL form env*))) ; TCO - ((do) - (let ((forms (cdr items))) - (if (null? forms) - mal-nil - ;; the evaluation order of map is unspecified - (let loop ((forms forms)) - (let ((form (car forms)) - (tail (cdr forms))) - (if (null? tail) - (EVAL form env) ; TCO - (begin - (EVAL form env) - (loop tail)))))))) - ((if) - (let* ((condition (EVAL (cadr items) env)) - (type (and (mal-object? condition) - (mal-type condition)))) - (if (memq type '(false nil)) - (if (< (length items) 4) - mal-nil - (EVAL (list-ref items 3) env)) ; TCO - (EVAL (list-ref items 2) env)))) ; TCO - ((quote) - (cadr items)) - ((quasiquoteexpand) - (QUASIQUOTE (cadr items))) - ((quasiquote) - (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO - ((fn*) - (let* ((binds (->list (mal-value (cadr items)))) - (binds (map mal-value binds)) - (body (list-ref items 2)) - (fn (lambda args - (let ((env* (make-env env binds args))) - (EVAL body env*))))) - (make-func body binds env fn))) - (else - (let* ((items (mal-value (eval-ast ast env))) - (op (car items)) - (ops (cdr items))) - (if (func? op) - (let* ((outer (func-env op)) - (binds (func-params op)) - (env* (make-env outer binds ops))) - (EVAL (func-ast op) env*)) ; TCO - (apply op ops)))))))))))) - -(define (PRINT ast) - (pr-str ast #t)) - -(define repl-env (make-env #f)) -(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) - -(define (rep input) - (PRINT (EVAL (READ input) repl-env))) - -(define args (cdr (command-line))) - -(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) -(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) -(let ((scheme (or (get-environment-variable "scheme_MODE") "chibi"))) - (env-set repl-env '*host-language* (mal-string (str "scheme (" scheme ")")))) - -(rep "(def! not (fn* (a) (if a false true)))") -(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -(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)))))))") - -(define (main) - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (let loop () - (let ((input (readline "user> "))) - (when input - (guard - (ex ((error-object? ex) - (when (not (memv 'empty-input (error-object-irritants ex))) - (display "[error] ") - (display (error-object-message ex)) - (newline))) - ((and (pair? ex) (eq? (car ex) 'user-error)) - (display "[error] ") - (display (pr-str (cdr ex) #t)) - (newline))) - (display (rep input)) - (newline)) - (loop)))) - (newline)) - -(if (null? args) - (main) - (rep (string-append "(load-file \"" (car args) "\")"))) +(import (scheme base)) +(import (scheme write)) +(import (scheme process-context)) + +(import (lib util)) +(import (lib reader)) +(import (lib printer)) +(import (lib types)) +(import (lib env)) +(import (lib core)) + +(define (READ input) + (read-str input)) + +(define (eval-ast ast env) + (let ((type (and (mal-object? ast) (mal-type ast))) + (value (and (mal-object? ast) (mal-value ast)))) + (case type + ((symbol) (env-get env value)) + ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) + ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) + ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) + (else ast)))) + +(define (starts-with? ast sym) + (let ((items (mal-value ast))) + (and (not (null? items)) + (let ((a0 (car items))) + (and (mal-instance-of? a0 'symbol) + (eq? (mal-value a0) sym)))))) + +(define (qq-lst xs) + (if (null? xs) + (mal-list '()) + (let ((elt (car xs)) + (acc (qq-lst (cdr xs)))) + (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote)) + (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc)) + (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc)))))) + +(define (QUASIQUOTE ast) + (case (and (mal-object? ast) (mal-type ast)) + ((list) (if (starts-with? ast 'unquote) + (cadr (mal-value ast)) + (qq-lst (->list (mal-value ast))))) + ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast)))))) + ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) + (else ast))) + +(define (is-macro-call? ast env) + (if (mal-instance-of? ast 'list) + (let ((op (car-safe (mal-value ast)))) + (if (mal-instance-of? op 'symbol) + (let ((x (env-find env (mal-value op)))) + (if x + (if (and (func? x) (func-macro? x)) + #t + #f) + #f)) + #f)) + #f)) + +(define (macroexpand ast env) + (let loop ((ast ast)) + (if (is-macro-call? ast env) + (let* ((items (mal-value ast)) + (op (car items)) + (ops (cdr items)) + (fn (func-fn (env-get env (mal-value op))))) + (loop (apply fn ops))) + ast))) + +(define (EVAL ast env) + (define (handle-catch value handler) + (let* ((symbol (mal-value (cadr handler))) + (form (list-ref handler 2)) + (env* (make-env env (list symbol) (list value)))) + (EVAL form env*))) + (let ((type (and (mal-object? ast) (mal-type ast)))) + (if (not (eq? type 'list)) + (eval-ast ast env) + (if (null? (mal-value ast)) + ast + (let* ((ast (macroexpand ast env)) + (items (mal-value ast))) + (if (not (mal-instance-of? ast 'list)) + (eval-ast ast env) + (let ((a0 (car items))) + (case (and (mal-object? a0) (mal-value a0)) + ((def!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (env-set env symbol value) + value)) + ((defmacro!) + (let ((symbol (mal-value (cadr items))) + (value (EVAL (list-ref items 2) env))) + (when (func? value) + (func-macro?-set! value #t)) + (env-set env symbol value) + value)) + ((macroexpand) + (macroexpand (cadr items) env)) + ((try*) + (if (< (length items) 3) + (EVAL (cadr items) env) + (let* ((form (cadr items)) + (handler (mal-value (list-ref items 2)))) + (guard + (ex ((error-object? ex) + (handle-catch + (mal-string (error-object-message ex)) + handler)) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (handle-catch (cdr ex) handler))) + (EVAL form env))))) + ((let*) + (let ((env* (make-env env)) + (binds (->list (mal-value (cadr items)))) + (form (list-ref items 2))) + (let loop ((binds binds)) + (when (pair? binds) + (let ((key (mal-value (car binds)))) + (when (null? (cdr binds)) + (error "unbalanced list")) + (let ((value (EVAL (cadr binds) env*))) + (env-set env* key value) + (loop (cddr binds)))))) + (EVAL form env*))) ; TCO + ((do) + (let ((forms (cdr items))) + (if (null? forms) + mal-nil + ;; the evaluation order of map is unspecified + (let loop ((forms forms)) + (let ((form (car forms)) + (tail (cdr forms))) + (if (null? tail) + (EVAL form env) ; TCO + (begin + (EVAL form env) + (loop tail)))))))) + ((if) + (let* ((condition (EVAL (cadr items) env)) + (type (and (mal-object? condition) + (mal-type condition)))) + (if (memq type '(false nil)) + (if (< (length items) 4) + mal-nil + (EVAL (list-ref items 3) env)) ; TCO + (EVAL (list-ref items 2) env)))) ; TCO + ((quote) + (cadr items)) + ((quasiquoteexpand) + (QUASIQUOTE (cadr items))) + ((quasiquote) + (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO + ((fn*) + (let* ((binds (->list (mal-value (cadr items)))) + (binds (map mal-value binds)) + (body (list-ref items 2)) + (fn (lambda args + (let ((env* (make-env env binds args))) + (EVAL body env*))))) + (make-func body binds env fn))) + (else + (let* ((items (mal-value (eval-ast ast env))) + (op (car items)) + (ops (cdr items))) + (if (func? op) + (let* ((outer (func-env op)) + (binds (func-params op)) + (env* (make-env outer binds ops))) + (EVAL (func-ast op) env*)) ; TCO + (apply op ops)))))))))))) + +(define (PRINT ast) + (pr-str ast #t)) + +(define repl-env (make-env #f)) +(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) + +(define (rep input) + (PRINT (EVAL (READ input) repl-env))) + +(define args (cdr (command-line))) + +(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) +(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) +(let ((scheme (or (get-environment-variable "scheme_MODE") "chibi"))) + (env-set repl-env '*host-language* (mal-string (str "scheme (" scheme ")")))) + +(rep "(def! not (fn* (a) (if a false true)))") +(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +(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)))))))") + +(define (main) + (rep "(println (str \"Mal [\" *host-language* \"]\"))") + (let loop () + (let ((input (readline "user> "))) + (when input + (guard + (ex ((error-object? ex) + (when (not (memv 'empty-input (error-object-irritants ex))) + (display "[error] ") + (display (error-object-message ex)) + (newline))) + ((and (pair? ex) (eq? (car ex) 'user-error)) + (display "[error] ") + (display (pr-str (cdr ex) #t)) + (newline))) + (display (rep input)) + (newline)) + (loop)))) + (newline)) + +(if (null? args) + (main) + (rep (string-append "(load-file \"" (car args) "\")"))) diff --git a/impls/scheme/tests/stepA_mal.mal b/impls/scheme/tests/stepA_mal.mal index 4ba3b9fab0..f3676d50a1 100644 --- a/impls/scheme/tests/stepA_mal.mal +++ b/impls/scheme/tests/stepA_mal.mal @@ -1,17 +1,17 @@ -;; Testing basic Scheme interop - -(scm-eval "(+ 1 1)") -;=>2 - -(scm-eval "(begin (display \"Hello World!\") (newline) 7)") -;/Hello World! -;=>7 - -(scm-eval "(string->list \"MAL\")") -;=>("M" "A" "L") - -(scm-eval "(map + '(1 2 3) '(4 5 6))") -;=>(5 7 9) - -(scm-eval "(string-map (lambda (c) (integer->char (+ 65 (modulo (+ (- (char->integer c) 65) 13) 26)))) \"ZNY\")") -;=>"MAL" +;; Testing basic Scheme interop + +(scm-eval "(+ 1 1)") +;=>2 + +(scm-eval "(begin (display \"Hello World!\") (newline) 7)") +;/Hello World! +;=>7 + +(scm-eval "(string->list \"MAL\")") +;=>("M" "A" "L") + +(scm-eval "(map + '(1 2 3) '(4 5 6))") +;=>(5 7 9) + +(scm-eval "(string-map (lambda (c) (integer->char (+ 65 (modulo (+ (- (char->integer c) 65) 13) 26)))) \"ZNY\")") +;=>"MAL" diff --git a/impls/skew/Dockerfile b/impls/skew/Dockerfile index 8e689fdadb..fd72679a4c 100644 --- a/impls/skew/Dockerfile +++ b/impls/skew/Dockerfile @@ -1,39 +1,39 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 0.12 stable -RUN curl -sL https://deb.nodesource.com/setup_0.12 | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -# Link common name -RUN ln -sf nodejs /usr/bin/node - -ENV NPM_CONFIG_CACHE /mal/.npm - -# Skew -RUN npm install -g skew +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 0.12 stable +RUN curl -sL https://deb.nodesource.com/setup_0.12 | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +# Link common name +RUN ln -sf nodejs /usr/bin/node + +ENV NPM_CONFIG_CACHE /mal/.npm + +# Skew +RUN npm install -g skew diff --git a/impls/skew/Makefile b/impls/skew/Makefile index 58bd6641fc..13526bbdbd 100644 --- a/impls/skew/Makefile +++ b/impls/skew/Makefile @@ -1,27 +1,27 @@ -STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ - step5_tco step6_file step7_quote step8_macros step9_try stepA_mal - -SOURCES_BASE = util.sk types.sk reader.sk printer.sk - -STEP3_DEPS = $(SOURCES_BASE) env.sk -STEP4_DEPS = $(STEP3_DEPS) core.sk - -all: $(foreach s,$(STEPS),$(s).js) dist - -dist: mal - -step0_repl.js step1_read_print.js step2_eval.js step3_env.js: $(STEP3_DEPS) -step4_if_fn_do.js step5_tco.js step6_file.js step7_quote.js step8_macros.js step9_try.js stepA_mal.js: $(STEP4_DEPS) - -%.js: %.sk - skewc --target=js --release --output-file=$@ $^ - -mal: stepA_mal.js - echo "#!/usr/bin/env node" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -rf step*.js mal - -.PHONY: all dist clean +STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ + step5_tco step6_file step7_quote step8_macros step9_try stepA_mal + +SOURCES_BASE = util.sk types.sk reader.sk printer.sk + +STEP3_DEPS = $(SOURCES_BASE) env.sk +STEP4_DEPS = $(STEP3_DEPS) core.sk + +all: $(foreach s,$(STEPS),$(s).js) dist + +dist: mal + +step0_repl.js step1_read_print.js step2_eval.js step3_env.js: $(STEP3_DEPS) +step4_if_fn_do.js step5_tco.js step6_file.js step7_quote.js step8_macros.js step9_try.js stepA_mal.js: $(STEP4_DEPS) + +%.js: %.sk + skewc --target=js --release --output-file=$@ $^ + +mal: stepA_mal.js + echo "#!/usr/bin/env node" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -rf step*.js mal + +.PHONY: all dist clean diff --git a/impls/skew/core.sk b/impls/skew/core.sk index b65d08c4ec..7862e5b4d2 100644 --- a/impls/skew/core.sk +++ b/impls/skew/core.sk @@ -1,103 +1,103 @@ -def _printLn(s string) MalVal { - printLn(s) - return gNil -} - -const ns StringMap) MalVal> = { - "eval": (a List) => EVAL(a[0], repl_env), - "=": (a List) => MalVal.fromBool(a[0].equal(a[1])), - "throw": (a List) => { throw MalUserError.new(a[0]) }, - - "nil?": (a List) => MalVal.fromBool(a[0] is MalNil), - "true?": (a List) => MalVal.fromBool(a[0] is MalTrue), - "false?": (a List) => MalVal.fromBool(a[0] is MalFalse), - "string?": (a List) => MalVal.fromBool(a[0] is MalString), - "symbol": (a List) => MalSymbol.new((a[0] as MalString).val), - "symbol?": (a List) => MalVal.fromBool(a[0] is MalSymbol), - "keyword": (a List) => a[0] is MalKeyword ? a[0] : MalKeyword.new((a[0] as MalString).val), - "keyword?": (a List) => MalVal.fromBool(a[0] is MalKeyword), - "number?": (a List) => MalVal.fromBool(a[0] is MalNumber), - "fn?": (a List) => MalVal.fromBool(a[0] is MalNativeFunc || - (a[0] is MalFunc && !(a[0] as MalFunc).isMacro)), - "macro?": (a List) => MalVal.fromBool(a[0] is MalFunc && (a[0] as MalFunc).isMacro), - - "pr-str": (a List) => MalString.new(" ".join(a.map(e => pr_str(e, true)))), - "str": (a List) => MalString.new("".join(a.map(e => pr_str(e, false)))), - "prn": (a List) => _printLn(" ".join(a.map(e => pr_str(e, true)))), - "println": (a List) => _printLn(" ".join(a.map(e => pr_str(e, false)))), - "read-string": (a List) => read_str((a[0] as MalString).val), - "readline": (a List) => { - const line = readLine((a[0] as MalString).val) - return line == null ? gNil : MalString.new(line) - }, - "slurp": (a List) => MalString.new(readFile((a[0] as MalString).val)), - - "<": (a List) => MalVal.fromBool((a[0] as MalNumber).val < (a[1] as MalNumber).val), - "<=": (a List) => MalVal.fromBool((a[0] as MalNumber).val <= (a[1] as MalNumber).val), - ">": (a List) => MalVal.fromBool((a[0] as MalNumber).val > (a[1] as MalNumber).val), - ">=": (a List) => MalVal.fromBool((a[0] as MalNumber).val >= (a[1] as MalNumber).val), - "+": (a List) => MalNumber.new((a[0] as MalNumber).val + (a[1] as MalNumber).val), - "-": (a List) => MalNumber.new((a[0] as MalNumber).val - (a[1] as MalNumber).val), - "*": (a List) => MalNumber.new((a[0] as MalNumber).val * (a[1] as MalNumber).val), - "/": (a List) => MalNumber.new((a[0] as MalNumber).val / (a[1] as MalNumber).val), - "time-ms": (a List) => MalNumber.new(timeMs), - - "list": (a List) => MalList.new(a), - "list?": (a List) => MalVal.fromBool(a[0] is MalList), - "vector": (a List) => MalVector.new(a), - "vector?": (a List) => MalVal.fromBool(a[0] is MalVector), - "hash-map": (a List) => MalHashMap.fromList(a), - "map?": (a List) => MalVal.fromBool(a[0] is MalHashMap), - "assoc": (a List) => (a[0] as MalHashMap).assoc(a.slice(1)), - "dissoc": (a List) => (a[0] as MalHashMap).dissoc(a.slice(1)), - "get": (a List) => a[0] is MalNil ? gNil : (a[0] as MalHashMap).get(a[1]), - "contains?": (a List) => MalVal.fromBool((a[0] as MalHashMap).contains(a[1])), - "keys": (a List) => MalList.new((a[0] as MalHashMap).keys), - "vals": (a List) => MalList.new((a[0] as MalHashMap).vals), - - "sequential?": (a List) => MalVal.fromBool(a[0] is MalSequential), - "cons": (a List) => { - var list List = (a[1] as MalSequential).val.clone - list.prepend(a[0]) - return MalList.new(list) - }, - "concat": (a List) => { - var list List = [] - a.each(e => list.append((e as MalSequential).val)) - return MalList.new(list) - }, - "vec": (a List) => a[0] is MalVector ? a[0] : MalVector.new((a[0] as MalSequential).val), - "nth": (a List) => (a[0] as MalSequential).nth((a[1] as MalNumber).val), - "first": (a List) => a[0] is MalNil ? gNil : (a[0] as MalSequential).first, - "rest": (a List) => a[0] is MalNil ? MalList.new([]) : (a[0] as MalSequential).rest, - "empty?": (a List) => MalVal.fromBool((a[0] as MalSequential).count == 0), - "count": (a List) => a[0] is MalNil ? MalNumber.new(0) : MalNumber.new((a[0] as MalSequential).count), - "apply": (a List) => { - const f = a[0] as MalCallable - var args = a.slice(1, a.count - 1) - args.append((a[a.count - 1] as MalSequential).val) - return f.call(args) - }, - "map": (a List) => { - const f = a[0] as MalCallable - return MalList.new((a[1] as MalSequential).val.map(e => f.call([e]))) - }, - - "conj": (a List) => (a[0] as MalSequential).conj(a.slice(1)), - "seq": (a List) => a[0].seq, - - "meta": (a List) => a[0].meta, - "with-meta": (a List) => a[0].withMeta(a[1]), - "atom": (a List) => MalAtom.new(a[0]), - "atom?": (a List) => MalVal.fromBool(a[0] is MalAtom), - "deref": (a List) => (a[0] as MalAtom).val, - "reset!": (a List) => (a[0] as MalAtom).resetBang(a[1]), - "swap!": (a List) => { - var atom = a[0] as MalAtom - const oldVal = atom.val - var callArgs = a.slice(2) - callArgs.prepend(oldVal) - const newVal = (a[1] as MalCallable).call(callArgs) - return atom.resetBang(newVal) - }, -} +def _printLn(s string) MalVal { + printLn(s) + return gNil +} + +const ns StringMap) MalVal> = { + "eval": (a List) => EVAL(a[0], repl_env), + "=": (a List) => MalVal.fromBool(a[0].equal(a[1])), + "throw": (a List) => { throw MalUserError.new(a[0]) }, + + "nil?": (a List) => MalVal.fromBool(a[0] is MalNil), + "true?": (a List) => MalVal.fromBool(a[0] is MalTrue), + "false?": (a List) => MalVal.fromBool(a[0] is MalFalse), + "string?": (a List) => MalVal.fromBool(a[0] is MalString), + "symbol": (a List) => MalSymbol.new((a[0] as MalString).val), + "symbol?": (a List) => MalVal.fromBool(a[0] is MalSymbol), + "keyword": (a List) => a[0] is MalKeyword ? a[0] : MalKeyword.new((a[0] as MalString).val), + "keyword?": (a List) => MalVal.fromBool(a[0] is MalKeyword), + "number?": (a List) => MalVal.fromBool(a[0] is MalNumber), + "fn?": (a List) => MalVal.fromBool(a[0] is MalNativeFunc || + (a[0] is MalFunc && !(a[0] as MalFunc).isMacro)), + "macro?": (a List) => MalVal.fromBool(a[0] is MalFunc && (a[0] as MalFunc).isMacro), + + "pr-str": (a List) => MalString.new(" ".join(a.map(e => pr_str(e, true)))), + "str": (a List) => MalString.new("".join(a.map(e => pr_str(e, false)))), + "prn": (a List) => _printLn(" ".join(a.map(e => pr_str(e, true)))), + "println": (a List) => _printLn(" ".join(a.map(e => pr_str(e, false)))), + "read-string": (a List) => read_str((a[0] as MalString).val), + "readline": (a List) => { + const line = readLine((a[0] as MalString).val) + return line == null ? gNil : MalString.new(line) + }, + "slurp": (a List) => MalString.new(readFile((a[0] as MalString).val)), + + "<": (a List) => MalVal.fromBool((a[0] as MalNumber).val < (a[1] as MalNumber).val), + "<=": (a List) => MalVal.fromBool((a[0] as MalNumber).val <= (a[1] as MalNumber).val), + ">": (a List) => MalVal.fromBool((a[0] as MalNumber).val > (a[1] as MalNumber).val), + ">=": (a List) => MalVal.fromBool((a[0] as MalNumber).val >= (a[1] as MalNumber).val), + "+": (a List) => MalNumber.new((a[0] as MalNumber).val + (a[1] as MalNumber).val), + "-": (a List) => MalNumber.new((a[0] as MalNumber).val - (a[1] as MalNumber).val), + "*": (a List) => MalNumber.new((a[0] as MalNumber).val * (a[1] as MalNumber).val), + "/": (a List) => MalNumber.new((a[0] as MalNumber).val / (a[1] as MalNumber).val), + "time-ms": (a List) => MalNumber.new(timeMs), + + "list": (a List) => MalList.new(a), + "list?": (a List) => MalVal.fromBool(a[0] is MalList), + "vector": (a List) => MalVector.new(a), + "vector?": (a List) => MalVal.fromBool(a[0] is MalVector), + "hash-map": (a List) => MalHashMap.fromList(a), + "map?": (a List) => MalVal.fromBool(a[0] is MalHashMap), + "assoc": (a List) => (a[0] as MalHashMap).assoc(a.slice(1)), + "dissoc": (a List) => (a[0] as MalHashMap).dissoc(a.slice(1)), + "get": (a List) => a[0] is MalNil ? gNil : (a[0] as MalHashMap).get(a[1]), + "contains?": (a List) => MalVal.fromBool((a[0] as MalHashMap).contains(a[1])), + "keys": (a List) => MalList.new((a[0] as MalHashMap).keys), + "vals": (a List) => MalList.new((a[0] as MalHashMap).vals), + + "sequential?": (a List) => MalVal.fromBool(a[0] is MalSequential), + "cons": (a List) => { + var list List = (a[1] as MalSequential).val.clone + list.prepend(a[0]) + return MalList.new(list) + }, + "concat": (a List) => { + var list List = [] + a.each(e => list.append((e as MalSequential).val)) + return MalList.new(list) + }, + "vec": (a List) => a[0] is MalVector ? a[0] : MalVector.new((a[0] as MalSequential).val), + "nth": (a List) => (a[0] as MalSequential).nth((a[1] as MalNumber).val), + "first": (a List) => a[0] is MalNil ? gNil : (a[0] as MalSequential).first, + "rest": (a List) => a[0] is MalNil ? MalList.new([]) : (a[0] as MalSequential).rest, + "empty?": (a List) => MalVal.fromBool((a[0] as MalSequential).count == 0), + "count": (a List) => a[0] is MalNil ? MalNumber.new(0) : MalNumber.new((a[0] as MalSequential).count), + "apply": (a List) => { + const f = a[0] as MalCallable + var args = a.slice(1, a.count - 1) + args.append((a[a.count - 1] as MalSequential).val) + return f.call(args) + }, + "map": (a List) => { + const f = a[0] as MalCallable + return MalList.new((a[1] as MalSequential).val.map(e => f.call([e]))) + }, + + "conj": (a List) => (a[0] as MalSequential).conj(a.slice(1)), + "seq": (a List) => a[0].seq, + + "meta": (a List) => a[0].meta, + "with-meta": (a List) => a[0].withMeta(a[1]), + "atom": (a List) => MalAtom.new(a[0]), + "atom?": (a List) => MalVal.fromBool(a[0] is MalAtom), + "deref": (a List) => (a[0] as MalAtom).val, + "reset!": (a List) => (a[0] as MalAtom).resetBang(a[1]), + "swap!": (a List) => { + var atom = a[0] as MalAtom + const oldVal = atom.val + var callArgs = a.slice(2) + callArgs.prepend(oldVal) + const newVal = (a[1] as MalCallable).call(callArgs) + return atom.resetBang(newVal) + }, +} diff --git a/impls/skew/env.sk b/impls/skew/env.sk index 2f4afb9c8e..130cbd191d 100644 --- a/impls/skew/env.sk +++ b/impls/skew/env.sk @@ -1,38 +1,38 @@ -class Env { - const _outer Env - var _data StringMap = {} - - def new(outer Env) { - _outer = outer - } - - def new(outer Env, binds List, exprs List) { - _outer = outer - for i in 0..binds.count { - const name = (binds[i] as MalSymbol).val - if name == "&" { - const restName = (binds[i + 1] as MalSymbol).val - _data[restName] = MalList.new(exprs.slice(i)) - break - } else { - _data[name] = exprs[i] - } - } - } - - def find(key MalSymbol) Env { - if key.val in _data { return self } - return _outer?.find(key) - } - - def get(key MalSymbol) MalVal { - const env = find(key) - if env == null { throw MalError.new("'" + key.val + "' not found") } - return env._data[key.val] - } - - def set(key MalSymbol, value MalVal) MalVal { - _data[key.val] = value - return value - } -} +class Env { + const _outer Env + var _data StringMap = {} + + def new(outer Env) { + _outer = outer + } + + def new(outer Env, binds List, exprs List) { + _outer = outer + for i in 0..binds.count { + const name = (binds[i] as MalSymbol).val + if name == "&" { + const restName = (binds[i + 1] as MalSymbol).val + _data[restName] = MalList.new(exprs.slice(i)) + break + } else { + _data[name] = exprs[i] + } + } + } + + def find(key MalSymbol) Env { + if key.val in _data { return self } + return _outer?.find(key) + } + + def get(key MalSymbol) MalVal { + const env = find(key) + if env == null { throw MalError.new("'" + key.val + "' not found") } + return env._data[key.val] + } + + def set(key MalSymbol, value MalVal) MalVal { + _data[key.val] = value + return value + } +} diff --git a/impls/skew/printer.sk b/impls/skew/printer.sk index bd767a0135..04ca70fe40 100644 --- a/impls/skew/printer.sk +++ b/impls/skew/printer.sk @@ -1,3 +1,3 @@ -def pr_str(obj MalVal, readable bool) string { - return obj.print(readable) -} +def pr_str(obj MalVal, readable bool) string { + return obj.print(readable) +} diff --git a/impls/skew/reader.sk b/impls/skew/reader.sk index 15bc83e04e..3f16e20d32 100644 --- a/impls/skew/reader.sk +++ b/impls/skew/reader.sk @@ -1,140 +1,140 @@ -class Reader { - const tokens List - var position = 0 - - def peek string { - if position >= tokens.count { - return null - } - return tokens[position] - } - - def next string { - const token = peek - position++ - return token - } -} - -def tokenize(str string) List { - var re = RegExp.new("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)", "g") - var tokens List = [] - var match string - while (match = re.exec(str)[1]) != "" { - if match[0] == ';' { - continue - } - tokens.append(match) - } - return tokens -} - -def unescape(s string) string { - return s.replaceAll("\\\\", "\x01").replaceAll("\\\"", "\"").replaceAll("\\n", "\n").replaceAll("\x01", "\\") -} - -def read_atom(rdr Reader) MalVal { - var sre = RegExp.new("^\"(?:\\\\.|[^\\\\\"])*\"$") - const token = rdr.peek - if token == "nil" { - rdr.next - return gNil - } - if token == "true" { - rdr.next - return gTrue - } - if token == "false" { - rdr.next - return gFalse - } - switch token[0] { - case '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' { return MalNumber.new(stringToInt(rdr.next)) } - case '-' { - if token.count <= 1 { return MalSymbol.new(rdr.next) } - switch token[1] { - case '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' { return MalNumber.new(stringToInt(rdr.next)) } - default { return MalSymbol.new(rdr.next) } - } - } - case '"' { - const s = rdr.next - if sre.exec(s) { - return MalString.new(unescape(s.slice(1, s.count - 1))) - } else { - throw MalError.new("expected '\"', got EOF") - } - } - case ':' { return MalKeyword.new(rdr.next.slice(1)) } - default { return MalSymbol.new(rdr.next) } - } -} - -def read_sequence(rdr Reader, open string, close string) List { - if rdr.next != open { - throw MalError.new("expected '" + open + "'") - } - var token string - var items List = [] - while (token = rdr.peek) != close { - if token == null { - throw MalError.new("expected '" + close + "', got EOF") - } - items.append(read_form(rdr)) - } - rdr.next # consume the close paren/bracket/brace - return items -} - -def read_list(rdr Reader) MalList { - return MalList.new(read_sequence(rdr, "(", ")")) -} - -def read_vector(rdr Reader) MalVector { - return MalVector.new(read_sequence(rdr, "[", "]")) -} - -def read_hash_map(rdr Reader) MalHashMap { - return MalHashMap.fromList(read_sequence(rdr, "{", "}")) -} - -def reader_macro(rdr Reader, symbol_name string) MalVal { - rdr.next - return MalList.new([MalSymbol.new(symbol_name), read_form(rdr)]) -} - -def read_form(rdr Reader) MalVal { - switch rdr.peek[0] { - case '\'' { return reader_macro(rdr, "quote") } - case '`' { return reader_macro(rdr, "quasiquote") } - case '~' { - if rdr.peek == "~" { return reader_macro(rdr, "unquote") } - else if rdr.peek == "~@" { return reader_macro(rdr, "splice-unquote") } - else { return read_atom(rdr) } - } - case '^' { - rdr.next - const meta = read_form(rdr) - return MalList.new([MalSymbol.new("with-meta"), read_form(rdr), meta]) - } - case '@' { return reader_macro(rdr, "deref") } - case ')' { throw MalError.new("unexpected ')'") } - case '(' { return read_list(rdr) } - case ']' { throw MalError.new("unexpected ']'") } - case '[' { return read_vector(rdr) } - case '}' { throw MalError.new("unexpected '}'") } - case '{' { return read_hash_map(rdr) } - default { return read_atom(rdr) } - } -} - -def read_str(str string) MalVal { - const tokens = tokenize(str) - if tokens.isEmpty { return null } - var rdr = Reader.new(tokens) - return read_form(rdr) -} - -@import { - const RegExp dynamic -} +class Reader { + const tokens List + var position = 0 + + def peek string { + if position >= tokens.count { + return null + } + return tokens[position] + } + + def next string { + const token = peek + position++ + return token + } +} + +def tokenize(str string) List { + var re = RegExp.new("[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)", "g") + var tokens List = [] + var match string + while (match = re.exec(str)[1]) != "" { + if match[0] == ';' { + continue + } + tokens.append(match) + } + return tokens +} + +def unescape(s string) string { + return s.replaceAll("\\\\", "\x01").replaceAll("\\\"", "\"").replaceAll("\\n", "\n").replaceAll("\x01", "\\") +} + +def read_atom(rdr Reader) MalVal { + var sre = RegExp.new("^\"(?:\\\\.|[^\\\\\"])*\"$") + const token = rdr.peek + if token == "nil" { + rdr.next + return gNil + } + if token == "true" { + rdr.next + return gTrue + } + if token == "false" { + rdr.next + return gFalse + } + switch token[0] { + case '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' { return MalNumber.new(stringToInt(rdr.next)) } + case '-' { + if token.count <= 1 { return MalSymbol.new(rdr.next) } + switch token[1] { + case '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' { return MalNumber.new(stringToInt(rdr.next)) } + default { return MalSymbol.new(rdr.next) } + } + } + case '"' { + const s = rdr.next + if sre.exec(s) { + return MalString.new(unescape(s.slice(1, s.count - 1))) + } else { + throw MalError.new("expected '\"', got EOF") + } + } + case ':' { return MalKeyword.new(rdr.next.slice(1)) } + default { return MalSymbol.new(rdr.next) } + } +} + +def read_sequence(rdr Reader, open string, close string) List { + if rdr.next != open { + throw MalError.new("expected '" + open + "'") + } + var token string + var items List = [] + while (token = rdr.peek) != close { + if token == null { + throw MalError.new("expected '" + close + "', got EOF") + } + items.append(read_form(rdr)) + } + rdr.next # consume the close paren/bracket/brace + return items +} + +def read_list(rdr Reader) MalList { + return MalList.new(read_sequence(rdr, "(", ")")) +} + +def read_vector(rdr Reader) MalVector { + return MalVector.new(read_sequence(rdr, "[", "]")) +} + +def read_hash_map(rdr Reader) MalHashMap { + return MalHashMap.fromList(read_sequence(rdr, "{", "}")) +} + +def reader_macro(rdr Reader, symbol_name string) MalVal { + rdr.next + return MalList.new([MalSymbol.new(symbol_name), read_form(rdr)]) +} + +def read_form(rdr Reader) MalVal { + switch rdr.peek[0] { + case '\'' { return reader_macro(rdr, "quote") } + case '`' { return reader_macro(rdr, "quasiquote") } + case '~' { + if rdr.peek == "~" { return reader_macro(rdr, "unquote") } + else if rdr.peek == "~@" { return reader_macro(rdr, "splice-unquote") } + else { return read_atom(rdr) } + } + case '^' { + rdr.next + const meta = read_form(rdr) + return MalList.new([MalSymbol.new("with-meta"), read_form(rdr), meta]) + } + case '@' { return reader_macro(rdr, "deref") } + case ')' { throw MalError.new("unexpected ')'") } + case '(' { return read_list(rdr) } + case ']' { throw MalError.new("unexpected ']'") } + case '[' { return read_vector(rdr) } + case '}' { throw MalError.new("unexpected '}'") } + case '{' { return read_hash_map(rdr) } + default { return read_atom(rdr) } + } +} + +def read_str(str string) MalVal { + const tokens = tokenize(str) + if tokens.isEmpty { return null } + var rdr = Reader.new(tokens) + return read_form(rdr) +} + +@import { + const RegExp dynamic +} diff --git a/impls/skew/run b/impls/skew/run index 6605303a29..75d63815c6 100755 --- a/impls/skew/run +++ b/impls/skew/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" +#!/bin/bash +exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" diff --git a/impls/skew/step0_repl.sk b/impls/skew/step0_repl.sk index 4afc931603..f8b6b7b9a0 100644 --- a/impls/skew/step0_repl.sk +++ b/impls/skew/step0_repl.sk @@ -1,24 +1,24 @@ -def READ(str string) string { - return str -} - -def EVAL(ast string, env StringMap) string { - return ast -} - -def PRINT(exp string) string { - return exp -} - -def REP(str string) string { - return PRINT(EVAL(READ(str), {})) -} - -@entry -def main { - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - printLn(REP(line)) - } -} +def READ(str string) string { + return str +} + +def EVAL(ast string, env StringMap) string { + return ast +} + +def PRINT(exp string) string { + return exp +} + +def REP(str string) string { + return PRINT(EVAL(READ(str), {})) +} + +@entry +def main { + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + printLn(REP(line)) + } +} diff --git a/impls/skew/step1_read_print.sk b/impls/skew/step1_read_print.sk index 30ead7bb91..66d87bc367 100644 --- a/impls/skew/step1_read_print.sk +++ b/impls/skew/step1_read_print.sk @@ -1,29 +1,29 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def EVAL(ast MalVal, env StringMap) MalVal { - return ast -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -def REP(str string) string { - return PRINT(EVAL(READ(str), {})) -} - -@entry -def main { - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalError { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def EVAL(ast MalVal, env StringMap) MalVal { + return ast +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +def REP(str string) string { + return PRINT(EVAL(READ(str), {})) +} + +@entry +def main { + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalError { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/step2_eval.sk b/impls/skew/step2_eval.sk index fb65d40f7b..45b3dd8e56 100644 --- a/impls/skew/step2_eval.sk +++ b/impls/skew/step2_eval.sk @@ -1,64 +1,64 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def eval_ast(ast MalVal, env StringMap) MalVal { - if ast is MalSymbol { - const name = (ast as MalSymbol).val - if !(name in env) { - throw MalError.new("'" + name + "' not found") - } - return env[name] - } else if ast is MalList { - return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) - } else if ast is MalVector { - return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) - } else if ast is MalHashMap { - var result List = [] - (ast as MalHashMap).val.each((k string, v MalVal) => { - result.append(MalVal.fromHashKey(k)) - result.append(EVAL(v, env)) - }) - return MalHashMap.fromList(result) - } else { - return ast - } -} - -def EVAL(ast MalVal, env StringMap) MalVal { - if !(ast is MalList) { return eval_ast(ast, env) } - var astList = ast as MalList - if astList.isEmpty { return ast } - var evaledList = eval_ast(ast, env) as MalList - var fn = evaledList[0] as MalNativeFunc - return fn.call(evaledList.val.slice(1)) -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -var repl_env StringMap = { - "+": MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val + (args[1] as MalNumber).val)), - "-": MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val - (args[1] as MalNumber).val)), - "*": MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val * (args[1] as MalNumber).val)), - "/": MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val / (args[1] as MalNumber).val)), -} - -def REP(str string) string { - return PRINT(EVAL(READ(str), repl_env)) -} - -@entry -def main { - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalError { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def eval_ast(ast MalVal, env StringMap) MalVal { + if ast is MalSymbol { + const name = (ast as MalSymbol).val + if !(name in env) { + throw MalError.new("'" + name + "' not found") + } + return env[name] + } else if ast is MalList { + return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) + } else if ast is MalVector { + return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) + } else if ast is MalHashMap { + var result List = [] + (ast as MalHashMap).val.each((k string, v MalVal) => { + result.append(MalVal.fromHashKey(k)) + result.append(EVAL(v, env)) + }) + return MalHashMap.fromList(result) + } else { + return ast + } +} + +def EVAL(ast MalVal, env StringMap) MalVal { + if !(ast is MalList) { return eval_ast(ast, env) } + var astList = ast as MalList + if astList.isEmpty { return ast } + var evaledList = eval_ast(ast, env) as MalList + var fn = evaledList[0] as MalNativeFunc + return fn.call(evaledList.val.slice(1)) +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +var repl_env StringMap = { + "+": MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val + (args[1] as MalNumber).val)), + "-": MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val - (args[1] as MalNumber).val)), + "*": MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val * (args[1] as MalNumber).val)), + "/": MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val / (args[1] as MalNumber).val)), +} + +def REP(str string) string { + return PRINT(EVAL(READ(str), repl_env)) +} + +@entry +def main { + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalError { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/step3_env.sk b/impls/skew/step3_env.sk index aebc57c32b..d4a06357b3 100644 --- a/impls/skew/step3_env.sk +++ b/impls/skew/step3_env.sk @@ -1,72 +1,72 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def eval_ast(ast MalVal, env Env) MalVal { - if ast is MalSymbol { - return env.get(ast as MalSymbol) - } else if ast is MalList { - return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) - } else if ast is MalVector { - return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) - } else if ast is MalHashMap { - var result List = [] - (ast as MalHashMap).val.each((k string, v MalVal) => { - result.append(MalVal.fromHashKey(k)) - result.append(EVAL(v, env)) - }) - return MalHashMap.fromList(result) - } else { - return ast - } -} - -def EVAL(ast MalVal, env Env) MalVal { - if !(ast is MalList) { return eval_ast(ast, env) } - const astList = ast as MalList - if astList.isEmpty { return ast } - const a0sym = astList[0] as MalSymbol - if a0sym.val == "def!" { - return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) - } else if a0sym.val == "let*" { - var letenv = Env.new(env) - const assigns = astList[1] as MalSequential - for i = 0; i < assigns.count; i += 2 { - letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) - } - return EVAL(astList[2], letenv) - } else { - const evaledList = eval_ast(ast, env) as MalList - const fn = evaledList[0] as MalNativeFunc - return fn.call(evaledList.val.slice(1)) - } -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -var repl_env = Env.new(null) - -def REP(str string) string { - return PRINT(EVAL(READ(str), repl_env)) -} - -@entry -def main { - repl_env.set(MalSymbol.new("+"), MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val + (args[1] as MalNumber).val))) - repl_env.set(MalSymbol.new("-"), MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val - (args[1] as MalNumber).val))) - repl_env.set(MalSymbol.new("*"), MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val * (args[1] as MalNumber).val))) - repl_env.set(MalSymbol.new("/"), MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val / (args[1] as MalNumber).val))) - - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalError { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def eval_ast(ast MalVal, env Env) MalVal { + if ast is MalSymbol { + return env.get(ast as MalSymbol) + } else if ast is MalList { + return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) + } else if ast is MalVector { + return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) + } else if ast is MalHashMap { + var result List = [] + (ast as MalHashMap).val.each((k string, v MalVal) => { + result.append(MalVal.fromHashKey(k)) + result.append(EVAL(v, env)) + }) + return MalHashMap.fromList(result) + } else { + return ast + } +} + +def EVAL(ast MalVal, env Env) MalVal { + if !(ast is MalList) { return eval_ast(ast, env) } + const astList = ast as MalList + if astList.isEmpty { return ast } + const a0sym = astList[0] as MalSymbol + if a0sym.val == "def!" { + return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) + } else if a0sym.val == "let*" { + var letenv = Env.new(env) + const assigns = astList[1] as MalSequential + for i = 0; i < assigns.count; i += 2 { + letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) + } + return EVAL(astList[2], letenv) + } else { + const evaledList = eval_ast(ast, env) as MalList + const fn = evaledList[0] as MalNativeFunc + return fn.call(evaledList.val.slice(1)) + } +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +var repl_env = Env.new(null) + +def REP(str string) string { + return PRINT(EVAL(READ(str), repl_env)) +} + +@entry +def main { + repl_env.set(MalSymbol.new("+"), MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val + (args[1] as MalNumber).val))) + repl_env.set(MalSymbol.new("-"), MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val - (args[1] as MalNumber).val))) + repl_env.set(MalSymbol.new("*"), MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val * (args[1] as MalNumber).val))) + repl_env.set(MalSymbol.new("/"), MalNativeFunc.new((args List) MalVal => MalNumber.new((args[0] as MalNumber).val / (args[1] as MalNumber).val))) + + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalError { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/step4_if_fn_do.sk b/impls/skew/step4_if_fn_do.sk index 87acb890d0..490dd1ebec 100644 --- a/impls/skew/step4_if_fn_do.sk +++ b/impls/skew/step4_if_fn_do.sk @@ -1,90 +1,90 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def eval_ast(ast MalVal, env Env) MalVal { - if ast is MalSymbol { - return env.get(ast as MalSymbol) - } else if ast is MalList { - return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) - } else if ast is MalVector { - return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) - } else if ast is MalHashMap { - var result List = [] - (ast as MalHashMap).val.each((k string, v MalVal) => { - result.append(MalVal.fromHashKey(k)) - result.append(EVAL(v, env)) - }) - return MalHashMap.fromList(result) - } else { - return ast - } -} - -def EVAL(ast MalVal, env Env) MalVal { - if !(ast is MalList) { return eval_ast(ast, env) } - const astList = ast as MalList - if astList.isEmpty { return ast } - const a0sym = astList[0] as MalSymbol - if a0sym.val == "def!" { - return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) - } else if a0sym.val == "let*" { - var letenv = Env.new(env) - const assigns = astList[1] as MalSequential - for i = 0; i < assigns.count; i += 2 { - letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) - } - return EVAL(astList[2], letenv) - } else if a0sym.val == "do" { - const r = eval_ast(MalList.new(astList.val.slice(1)), env) as MalList - return r[r.count - 1] - } else if a0sym.val == "if" { - const condRes = EVAL(astList[1], env) - if condRes is MalNil || condRes is MalFalse { - return astList.count > 3 ? EVAL(astList[3], env) : gNil - } else { - return EVAL(astList[2], env) - } - } else if a0sym.val == "fn*" { - const argsNames = (astList[1] as MalSequential).val - return MalNativeFunc.new((args List) => EVAL(astList[2], Env.new(env, argsNames, args))) - } else { - const evaledList = eval_ast(ast, env) as MalList - const fn = evaledList[0] as MalNativeFunc - return fn.call(evaledList.val.slice(1)) - } -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -var repl_env = Env.new(null) - -def RE(str string) MalVal { - return EVAL(READ(str), repl_env) -} - -def REP(str string) string { - return PRINT(RE(str)) -} - -@entry -def main { - # core.sk: defined using Skew - ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) - - # core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))") - - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalError { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def eval_ast(ast MalVal, env Env) MalVal { + if ast is MalSymbol { + return env.get(ast as MalSymbol) + } else if ast is MalList { + return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) + } else if ast is MalVector { + return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) + } else if ast is MalHashMap { + var result List = [] + (ast as MalHashMap).val.each((k string, v MalVal) => { + result.append(MalVal.fromHashKey(k)) + result.append(EVAL(v, env)) + }) + return MalHashMap.fromList(result) + } else { + return ast + } +} + +def EVAL(ast MalVal, env Env) MalVal { + if !(ast is MalList) { return eval_ast(ast, env) } + const astList = ast as MalList + if astList.isEmpty { return ast } + const a0sym = astList[0] as MalSymbol + if a0sym.val == "def!" { + return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) + } else if a0sym.val == "let*" { + var letenv = Env.new(env) + const assigns = astList[1] as MalSequential + for i = 0; i < assigns.count; i += 2 { + letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) + } + return EVAL(astList[2], letenv) + } else if a0sym.val == "do" { + const r = eval_ast(MalList.new(astList.val.slice(1)), env) as MalList + return r[r.count - 1] + } else if a0sym.val == "if" { + const condRes = EVAL(astList[1], env) + if condRes is MalNil || condRes is MalFalse { + return astList.count > 3 ? EVAL(astList[3], env) : gNil + } else { + return EVAL(astList[2], env) + } + } else if a0sym.val == "fn*" { + const argsNames = (astList[1] as MalSequential).val + return MalNativeFunc.new((args List) => EVAL(astList[2], Env.new(env, argsNames, args))) + } else { + const evaledList = eval_ast(ast, env) as MalList + const fn = evaledList[0] as MalNativeFunc + return fn.call(evaledList.val.slice(1)) + } +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +var repl_env = Env.new(null) + +def RE(str string) MalVal { + return EVAL(READ(str), repl_env) +} + +def REP(str string) string { + return PRINT(RE(str)) +} + +@entry +def main { + # core.sk: defined using Skew + ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) + + # core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))") + + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalError { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/step5_tco.sk b/impls/skew/step5_tco.sk index 6799003f8e..37cf011afe 100644 --- a/impls/skew/step5_tco.sk +++ b/impls/skew/step5_tco.sk @@ -1,110 +1,110 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def eval_ast(ast MalVal, env Env) MalVal { - if ast is MalSymbol { - return env.get(ast as MalSymbol) - } else if ast is MalList { - return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) - } else if ast is MalVector { - return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) - } else if ast is MalHashMap { - var result List = [] - (ast as MalHashMap).val.each((k string, v MalVal) => { - result.append(MalVal.fromHashKey(k)) - result.append(EVAL(v, env)) - }) - return MalHashMap.fromList(result) - } else { - return ast - } -} - -def EVAL(ast MalVal, env Env) MalVal { - while true { - if !(ast is MalList) { return eval_ast(ast, env) } - const astList = ast as MalList - if astList.isEmpty { return ast } - const a0sym = astList[0] as MalSymbol - if a0sym.val == "def!" { - return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) - } else if a0sym.val == "let*" { - var letenv = Env.new(env) - const assigns = astList[1] as MalSequential - for i = 0; i < assigns.count; i += 2 { - letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) - } - ast = astList[2] - env = letenv - continue # TCO - } else if a0sym.val == "do" { - const parts = astList.val.slice(1) - eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) - ast = parts[parts.count - 1] - continue # TCO - } else if a0sym.val == "if" { - const condRes = EVAL(astList[1], env) - if condRes is MalNil || condRes is MalFalse { - ast = astList.count > 3 ? astList[3] : gNil - } else { - ast = astList[2] - } - continue # TCO - } else if a0sym.val == "fn*" { - const argsNames = astList[1] as MalSequential - return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) - } else { - const evaledList = eval_ast(ast, env) as MalList - const fn = evaledList[0] - const callArgs = evaledList.val.slice(1) - if fn is MalNativeFunc { - return (fn as MalNativeFunc).call(callArgs) - } else if fn is MalFunc { - const f = fn as MalFunc - ast = f.ast - env = Env.new(f.env, f.params.val, callArgs) - continue # TCO - } else { - throw MalError.new("Expected function as head of list") - } - } - } -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -var repl_env = Env.new(null) - -def RE(str string) MalVal { - return EVAL(READ(str), repl_env) -} - -def REP(str string) string { - return PRINT(RE(str)) -} - -@entry -def main { - # core.sk: defined using Skew - ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) - - # core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))") - - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalError { - printLn("Error: \(e.message)") - } - catch e Error { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def eval_ast(ast MalVal, env Env) MalVal { + if ast is MalSymbol { + return env.get(ast as MalSymbol) + } else if ast is MalList { + return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) + } else if ast is MalVector { + return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) + } else if ast is MalHashMap { + var result List = [] + (ast as MalHashMap).val.each((k string, v MalVal) => { + result.append(MalVal.fromHashKey(k)) + result.append(EVAL(v, env)) + }) + return MalHashMap.fromList(result) + } else { + return ast + } +} + +def EVAL(ast MalVal, env Env) MalVal { + while true { + if !(ast is MalList) { return eval_ast(ast, env) } + const astList = ast as MalList + if astList.isEmpty { return ast } + const a0sym = astList[0] as MalSymbol + if a0sym.val == "def!" { + return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) + } else if a0sym.val == "let*" { + var letenv = Env.new(env) + const assigns = astList[1] as MalSequential + for i = 0; i < assigns.count; i += 2 { + letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) + } + ast = astList[2] + env = letenv + continue # TCO + } else if a0sym.val == "do" { + const parts = astList.val.slice(1) + eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) + ast = parts[parts.count - 1] + continue # TCO + } else if a0sym.val == "if" { + const condRes = EVAL(astList[1], env) + if condRes is MalNil || condRes is MalFalse { + ast = astList.count > 3 ? astList[3] : gNil + } else { + ast = astList[2] + } + continue # TCO + } else if a0sym.val == "fn*" { + const argsNames = astList[1] as MalSequential + return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) + } else { + const evaledList = eval_ast(ast, env) as MalList + const fn = evaledList[0] + const callArgs = evaledList.val.slice(1) + if fn is MalNativeFunc { + return (fn as MalNativeFunc).call(callArgs) + } else if fn is MalFunc { + const f = fn as MalFunc + ast = f.ast + env = Env.new(f.env, f.params.val, callArgs) + continue # TCO + } else { + throw MalError.new("Expected function as head of list") + } + } + } +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +var repl_env = Env.new(null) + +def RE(str string) MalVal { + return EVAL(READ(str), repl_env) +} + +def REP(str string) string { + return PRINT(RE(str)) +} + +@entry +def main { + # core.sk: defined using Skew + ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) + + # core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))") + + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalError { + printLn("Error: \(e.message)") + } + catch e Error { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/step6_file.sk b/impls/skew/step6_file.sk index bc1a901bd2..06e99b5afc 100644 --- a/impls/skew/step6_file.sk +++ b/impls/skew/step6_file.sk @@ -1,117 +1,117 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def eval_ast(ast MalVal, env Env) MalVal { - if ast is MalSymbol { - return env.get(ast as MalSymbol) - } else if ast is MalList { - return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) - } else if ast is MalVector { - return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) - } else if ast is MalHashMap { - var result List = [] - (ast as MalHashMap).val.each((k string, v MalVal) => { - result.append(MalVal.fromHashKey(k)) - result.append(EVAL(v, env)) - }) - return MalHashMap.fromList(result) - } else { - return ast - } -} - -def EVAL(ast MalVal, env Env) MalVal { - while true { - if !(ast is MalList) { return eval_ast(ast, env) } - const astList = ast as MalList - if astList.isEmpty { return ast } - const a0sym = astList[0] as MalSymbol - if a0sym.val == "def!" { - return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) - } else if a0sym.val == "let*" { - var letenv = Env.new(env) - const assigns = astList[1] as MalSequential - for i = 0; i < assigns.count; i += 2 { - letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) - } - ast = astList[2] - env = letenv - continue # TCO - } else if a0sym.val == "do" { - const parts = astList.val.slice(1) - eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) - ast = parts[parts.count - 1] - continue # TCO - } else if a0sym.val == "if" { - const condRes = EVAL(astList[1], env) - if condRes is MalNil || condRes is MalFalse { - ast = astList.count > 3 ? astList[3] : gNil - } else { - ast = astList[2] - } - continue # TCO - } else if a0sym.val == "fn*" { - const argsNames = astList[1] as MalSequential - return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) - } else { - const evaledList = eval_ast(ast, env) as MalList - const fn = evaledList[0] - const callArgs = evaledList.val.slice(1) - if fn is MalNativeFunc { - return (fn as MalNativeFunc).call(callArgs) - } else if fn is MalFunc { - const f = fn as MalFunc - ast = f.ast - env = Env.new(f.env, f.params.val, callArgs) - continue # TCO - } else { - throw MalError.new("Expected function as head of list") - } - } - } -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -var repl_env = Env.new(null) - -def RE(str string) MalVal { - return EVAL(READ(str), repl_env) -} - -def REP(str string) string { - return PRINT(RE(str)) -} - -@entry -def main { - # core.sk: defined using Skew - ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) - repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) - - # core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))") - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - - if argv.count > 0 { - RE("(load-file \"" + argv[0] + "\")") - return - } - - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalError { - printLn("Error: \(e.message)") - } - catch e Error { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def eval_ast(ast MalVal, env Env) MalVal { + if ast is MalSymbol { + return env.get(ast as MalSymbol) + } else if ast is MalList { + return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) + } else if ast is MalVector { + return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) + } else if ast is MalHashMap { + var result List = [] + (ast as MalHashMap).val.each((k string, v MalVal) => { + result.append(MalVal.fromHashKey(k)) + result.append(EVAL(v, env)) + }) + return MalHashMap.fromList(result) + } else { + return ast + } +} + +def EVAL(ast MalVal, env Env) MalVal { + while true { + if !(ast is MalList) { return eval_ast(ast, env) } + const astList = ast as MalList + if astList.isEmpty { return ast } + const a0sym = astList[0] as MalSymbol + if a0sym.val == "def!" { + return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) + } else if a0sym.val == "let*" { + var letenv = Env.new(env) + const assigns = astList[1] as MalSequential + for i = 0; i < assigns.count; i += 2 { + letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) + } + ast = astList[2] + env = letenv + continue # TCO + } else if a0sym.val == "do" { + const parts = astList.val.slice(1) + eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) + ast = parts[parts.count - 1] + continue # TCO + } else if a0sym.val == "if" { + const condRes = EVAL(astList[1], env) + if condRes is MalNil || condRes is MalFalse { + ast = astList.count > 3 ? astList[3] : gNil + } else { + ast = astList[2] + } + continue # TCO + } else if a0sym.val == "fn*" { + const argsNames = astList[1] as MalSequential + return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) + } else { + const evaledList = eval_ast(ast, env) as MalList + const fn = evaledList[0] + const callArgs = evaledList.val.slice(1) + if fn is MalNativeFunc { + return (fn as MalNativeFunc).call(callArgs) + } else if fn is MalFunc { + const f = fn as MalFunc + ast = f.ast + env = Env.new(f.env, f.params.val, callArgs) + continue # TCO + } else { + throw MalError.new("Expected function as head of list") + } + } + } +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +var repl_env = Env.new(null) + +def RE(str string) MalVal { + return EVAL(READ(str), repl_env) +} + +def REP(str string) string { + return PRINT(RE(str)) +} + +@entry +def main { + # core.sk: defined using Skew + ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) + repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) + + # core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))") + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + + if argv.count > 0 { + RE("(load-file \"" + argv[0] + "\")") + return + } + + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalError { + printLn("Error: \(e.message)") + } + catch e Error { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/step7_quote.sk b/impls/skew/step7_quote.sk index 68a57a7d2e..6b34b111ad 100644 --- a/impls/skew/step7_quote.sk +++ b/impls/skew/step7_quote.sk @@ -1,155 +1,155 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def starts_with(lst MalList, sym string) bool { - return lst.count == 2 && lst[0].isSymbol(sym) -} -def qq_loop(elt MalVal, acc MalList) MalList { - if elt is MalList && starts_with(elt as MalList, "splice-unquote") { - return MalList.new([MalSymbol.new("concat"), (elt as MalList)[1], acc]) - } else { - return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) - } -} -def qq_foldr(xs List) MalList { - var acc = MalList.new([]) - for i = xs.count-1; 0 <= i; i -= 1 { - acc = qq_loop(xs[i], acc) - } - return acc -} -def quasiquote(ast MalVal) MalVal { - if ast is MalVector { - return MalList.new([MalSymbol.new("vec"), qq_foldr((ast as MalVector).val)]) - } else if ast is MalSymbol || ast is MalHashMap { - return MalList.new([MalSymbol.new("quote"), ast]) - } else if !(ast is MalList) { - return ast - } else if starts_with(ast as MalList, "unquote") { - return (ast as MalList)[1] - } else { - return qq_foldr((ast as MalList).val) - } -} - -def eval_ast(ast MalVal, env Env) MalVal { - if ast is MalSymbol { - return env.get(ast as MalSymbol) - } else if ast is MalList { - return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) - } else if ast is MalVector { - return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) - } else if ast is MalHashMap { - var result List = [] - (ast as MalHashMap).val.each((k string, v MalVal) => { - result.append(MalVal.fromHashKey(k)) - result.append(EVAL(v, env)) - }) - return MalHashMap.fromList(result) - } else { - return ast - } -} - -def EVAL(ast MalVal, env Env) MalVal { - while true { - if !(ast is MalList) { return eval_ast(ast, env) } - const astList = ast as MalList - if astList.isEmpty { return ast } - const a0sym = astList[0] as MalSymbol - if a0sym.val == "def!" { - return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) - } else if a0sym.val == "let*" { - var letenv = Env.new(env) - const assigns = astList[1] as MalSequential - for i = 0; i < assigns.count; i += 2 { - letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) - } - ast = astList[2] - env = letenv - continue # TCO - } else if a0sym.val == "quote" { - return astList[1] - } else if a0sym.val == "quasiquoteexpand" { - return quasiquote(astList[1]) - } else if a0sym.val == "quasiquote" { - ast = quasiquote(astList[1]) - continue # TCO - } else if a0sym.val == "do" { - const parts = astList.val.slice(1) - eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) - ast = parts[parts.count - 1] - continue # TCO - } else if a0sym.val == "if" { - const condRes = EVAL(astList[1], env) - if condRes is MalNil || condRes is MalFalse { - ast = astList.count > 3 ? astList[3] : gNil - } else { - ast = astList[2] - } - continue # TCO - } else if a0sym.val == "fn*" { - const argsNames = astList[1] as MalSequential - return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) - } else { - const evaledList = eval_ast(ast, env) as MalList - const fn = evaledList[0] - const callArgs = evaledList.val.slice(1) - if fn is MalNativeFunc { - return (fn as MalNativeFunc).call(callArgs) - } else if fn is MalFunc { - const f = fn as MalFunc - ast = f.ast - env = Env.new(f.env, f.params.val, callArgs) - continue # TCO - } else { - throw MalError.new("Expected function as head of list") - } - } - } -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -var repl_env = Env.new(null) - -def RE(str string) MalVal { - return EVAL(READ(str), repl_env) -} - -def REP(str string) string { - return PRINT(RE(str)) -} - -@entry -def main { - # core.sk: defined using Skew - ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) - repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) - - # core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))") - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - - if argv.count > 0 { - RE("(load-file \"" + argv[0] + "\")") - return - } - - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalError { - printLn("Error: \(e.message)") - } - catch e Error { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def starts_with(lst MalList, sym string) bool { + return lst.count == 2 && lst[0].isSymbol(sym) +} +def qq_loop(elt MalVal, acc MalList) MalList { + if elt is MalList && starts_with(elt as MalList, "splice-unquote") { + return MalList.new([MalSymbol.new("concat"), (elt as MalList)[1], acc]) + } else { + return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) + } +} +def qq_foldr(xs List) MalList { + var acc = MalList.new([]) + for i = xs.count-1; 0 <= i; i -= 1 { + acc = qq_loop(xs[i], acc) + } + return acc +} +def quasiquote(ast MalVal) MalVal { + if ast is MalVector { + return MalList.new([MalSymbol.new("vec"), qq_foldr((ast as MalVector).val)]) + } else if ast is MalSymbol || ast is MalHashMap { + return MalList.new([MalSymbol.new("quote"), ast]) + } else if !(ast is MalList) { + return ast + } else if starts_with(ast as MalList, "unquote") { + return (ast as MalList)[1] + } else { + return qq_foldr((ast as MalList).val) + } +} + +def eval_ast(ast MalVal, env Env) MalVal { + if ast is MalSymbol { + return env.get(ast as MalSymbol) + } else if ast is MalList { + return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) + } else if ast is MalVector { + return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) + } else if ast is MalHashMap { + var result List = [] + (ast as MalHashMap).val.each((k string, v MalVal) => { + result.append(MalVal.fromHashKey(k)) + result.append(EVAL(v, env)) + }) + return MalHashMap.fromList(result) + } else { + return ast + } +} + +def EVAL(ast MalVal, env Env) MalVal { + while true { + if !(ast is MalList) { return eval_ast(ast, env) } + const astList = ast as MalList + if astList.isEmpty { return ast } + const a0sym = astList[0] as MalSymbol + if a0sym.val == "def!" { + return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) + } else if a0sym.val == "let*" { + var letenv = Env.new(env) + const assigns = astList[1] as MalSequential + for i = 0; i < assigns.count; i += 2 { + letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) + } + ast = astList[2] + env = letenv + continue # TCO + } else if a0sym.val == "quote" { + return astList[1] + } else if a0sym.val == "quasiquoteexpand" { + return quasiquote(astList[1]) + } else if a0sym.val == "quasiquote" { + ast = quasiquote(astList[1]) + continue # TCO + } else if a0sym.val == "do" { + const parts = astList.val.slice(1) + eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) + ast = parts[parts.count - 1] + continue # TCO + } else if a0sym.val == "if" { + const condRes = EVAL(astList[1], env) + if condRes is MalNil || condRes is MalFalse { + ast = astList.count > 3 ? astList[3] : gNil + } else { + ast = astList[2] + } + continue # TCO + } else if a0sym.val == "fn*" { + const argsNames = astList[1] as MalSequential + return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) + } else { + const evaledList = eval_ast(ast, env) as MalList + const fn = evaledList[0] + const callArgs = evaledList.val.slice(1) + if fn is MalNativeFunc { + return (fn as MalNativeFunc).call(callArgs) + } else if fn is MalFunc { + const f = fn as MalFunc + ast = f.ast + env = Env.new(f.env, f.params.val, callArgs) + continue # TCO + } else { + throw MalError.new("Expected function as head of list") + } + } + } +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +var repl_env = Env.new(null) + +def RE(str string) MalVal { + return EVAL(READ(str), repl_env) +} + +def REP(str string) string { + return PRINT(RE(str)) +} + +@entry +def main { + # core.sk: defined using Skew + ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) + repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) + + # core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))") + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + + if argv.count > 0 { + RE("(load-file \"" + argv[0] + "\")") + return + } + + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalError { + printLn("Error: \(e.message)") + } + catch e Error { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/step8_macros.sk b/impls/skew/step8_macros.sk index 7450e6e76c..bf9b4e15a9 100644 --- a/impls/skew/step8_macros.sk +++ b/impls/skew/step8_macros.sk @@ -1,187 +1,187 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def starts_with(lst MalList, sym string) bool { - return lst.count == 2 && lst[0].isSymbol(sym) -} -def qq_loop(elt MalVal, acc MalList) MalList { - if elt is MalList && starts_with(elt as MalList, "splice-unquote") { - return MalList.new([MalSymbol.new("concat"), (elt as MalList)[1], acc]) - } else { - return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) - } -} -def qq_foldr(xs List) MalList { - var acc = MalList.new([]) - for i = xs.count-1; 0 <= i; i -= 1 { - acc = qq_loop(xs[i], acc) - } - return acc -} -def quasiquote(ast MalVal) MalVal { - if ast is MalVector { - return MalList.new([MalSymbol.new("vec"), qq_foldr((ast as MalVector).val)]) - } else if ast is MalSymbol || ast is MalHashMap { - return MalList.new([MalSymbol.new("quote"), ast]) - } else if !(ast is MalList) { - return ast - } else if starts_with(ast as MalList, "unquote") { - return (ast as MalList)[1] - } else { - return qq_foldr((ast as MalList).val) - } -} - -def isMacro(ast MalVal, env Env) bool { - if !(ast is MalList) { return false } - const astList = ast as MalList - if astList.isEmpty { return false } - const a0 = astList[0] - if !(a0 is MalSymbol) { return false } - const a0Sym = a0 as MalSymbol - if env.find(a0Sym) == null { return false } - const f = env.get(a0Sym) - if !(f is MalFunc) { return false } - return (f as MalFunc).isMacro -} - -def macroexpand(ast MalVal, env Env) MalVal { - while isMacro(ast, env) { - const astList = ast as MalList - const mac = env.get(astList[0] as MalSymbol) as MalFunc - ast = mac.call((astList.rest as MalSequential).val) - } - return ast -} - -def eval_ast(ast MalVal, env Env) MalVal { - if ast is MalSymbol { - return env.get(ast as MalSymbol) - } else if ast is MalList { - return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) - } else if ast is MalVector { - return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) - } else if ast is MalHashMap { - var result List = [] - (ast as MalHashMap).val.each((k string, v MalVal) => { - result.append(MalVal.fromHashKey(k)) - result.append(EVAL(v, env)) - }) - return MalHashMap.fromList(result) - } else { - return ast - } -} - -def EVAL(ast MalVal, env Env) MalVal { - while true { - if !(ast is MalList) { return eval_ast(ast, env) } - ast = macroexpand(ast, env) - if !(ast is MalList) { return eval_ast(ast, env) } - const astList = ast as MalList - if astList.isEmpty { return ast } - const a0sym = astList[0] as MalSymbol - if a0sym.val == "def!" { - return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) - } else if a0sym.val == "let*" { - var letenv = Env.new(env) - const assigns = astList[1] as MalSequential - for i = 0; i < assigns.count; i += 2 { - letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) - } - ast = astList[2] - env = letenv - continue # TCO - } else if a0sym.val == "quote" { - return astList[1] - } else if a0sym.val == "quasiquoteexpand" { - return quasiquote(astList[1]) - } else if a0sym.val == "quasiquote" { - ast = quasiquote(astList[1]) - continue # TCO - } else if a0sym.val == "defmacro!" { - var fn = EVAL(astList[2], env) as MalFunc - var macro = MalFunc.new(fn.ast, fn.params, fn.env, fn.func) - macro.setAsMacro - return env.set(astList[1] as MalSymbol, macro) - } else if a0sym.val == "macroexpand" { - return macroexpand(astList[1], env) - } else if a0sym.val == "do" { - const parts = astList.val.slice(1) - eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) - ast = parts[parts.count - 1] - continue # TCO - } else if a0sym.val == "if" { - const condRes = EVAL(astList[1], env) - if condRes is MalNil || condRes is MalFalse { - ast = astList.count > 3 ? astList[3] : gNil - } else { - ast = astList[2] - } - continue # TCO - } else if a0sym.val == "fn*" { - const argsNames = astList[1] as MalSequential - return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) - } else { - const evaledList = eval_ast(ast, env) as MalList - const fn = evaledList[0] - const callArgs = evaledList.val.slice(1) - if fn is MalNativeFunc { - return (fn as MalNativeFunc).call(callArgs) - } else if fn is MalFunc { - const f = fn as MalFunc - ast = f.ast - env = Env.new(f.env, f.params.val, callArgs) - continue # TCO - } else { - throw MalError.new("Expected function as head of list") - } - } - } -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -var repl_env = Env.new(null) - -def RE(str string) MalVal { - return EVAL(READ(str), repl_env) -} - -def REP(str string) string { - return PRINT(RE(str)) -} - -@entry -def main { - # core.sk: defined using Skew - ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) - repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) - - # core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))") - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - RE("(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)))))))") - - if argv.count > 0 { - RE("(load-file \"" + argv[0] + "\")") - return - } - - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalError { - printLn("Error: \(e.message)") - } - catch e Error { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def starts_with(lst MalList, sym string) bool { + return lst.count == 2 && lst[0].isSymbol(sym) +} +def qq_loop(elt MalVal, acc MalList) MalList { + if elt is MalList && starts_with(elt as MalList, "splice-unquote") { + return MalList.new([MalSymbol.new("concat"), (elt as MalList)[1], acc]) + } else { + return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) + } +} +def qq_foldr(xs List) MalList { + var acc = MalList.new([]) + for i = xs.count-1; 0 <= i; i -= 1 { + acc = qq_loop(xs[i], acc) + } + return acc +} +def quasiquote(ast MalVal) MalVal { + if ast is MalVector { + return MalList.new([MalSymbol.new("vec"), qq_foldr((ast as MalVector).val)]) + } else if ast is MalSymbol || ast is MalHashMap { + return MalList.new([MalSymbol.new("quote"), ast]) + } else if !(ast is MalList) { + return ast + } else if starts_with(ast as MalList, "unquote") { + return (ast as MalList)[1] + } else { + return qq_foldr((ast as MalList).val) + } +} + +def isMacro(ast MalVal, env Env) bool { + if !(ast is MalList) { return false } + const astList = ast as MalList + if astList.isEmpty { return false } + const a0 = astList[0] + if !(a0 is MalSymbol) { return false } + const a0Sym = a0 as MalSymbol + if env.find(a0Sym) == null { return false } + const f = env.get(a0Sym) + if !(f is MalFunc) { return false } + return (f as MalFunc).isMacro +} + +def macroexpand(ast MalVal, env Env) MalVal { + while isMacro(ast, env) { + const astList = ast as MalList + const mac = env.get(astList[0] as MalSymbol) as MalFunc + ast = mac.call((astList.rest as MalSequential).val) + } + return ast +} + +def eval_ast(ast MalVal, env Env) MalVal { + if ast is MalSymbol { + return env.get(ast as MalSymbol) + } else if ast is MalList { + return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) + } else if ast is MalVector { + return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) + } else if ast is MalHashMap { + var result List = [] + (ast as MalHashMap).val.each((k string, v MalVal) => { + result.append(MalVal.fromHashKey(k)) + result.append(EVAL(v, env)) + }) + return MalHashMap.fromList(result) + } else { + return ast + } +} + +def EVAL(ast MalVal, env Env) MalVal { + while true { + if !(ast is MalList) { return eval_ast(ast, env) } + ast = macroexpand(ast, env) + if !(ast is MalList) { return eval_ast(ast, env) } + const astList = ast as MalList + if astList.isEmpty { return ast } + const a0sym = astList[0] as MalSymbol + if a0sym.val == "def!" { + return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) + } else if a0sym.val == "let*" { + var letenv = Env.new(env) + const assigns = astList[1] as MalSequential + for i = 0; i < assigns.count; i += 2 { + letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) + } + ast = astList[2] + env = letenv + continue # TCO + } else if a0sym.val == "quote" { + return astList[1] + } else if a0sym.val == "quasiquoteexpand" { + return quasiquote(astList[1]) + } else if a0sym.val == "quasiquote" { + ast = quasiquote(astList[1]) + continue # TCO + } else if a0sym.val == "defmacro!" { + var fn = EVAL(astList[2], env) as MalFunc + var macro = MalFunc.new(fn.ast, fn.params, fn.env, fn.func) + macro.setAsMacro + return env.set(astList[1] as MalSymbol, macro) + } else if a0sym.val == "macroexpand" { + return macroexpand(astList[1], env) + } else if a0sym.val == "do" { + const parts = astList.val.slice(1) + eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) + ast = parts[parts.count - 1] + continue # TCO + } else if a0sym.val == "if" { + const condRes = EVAL(astList[1], env) + if condRes is MalNil || condRes is MalFalse { + ast = astList.count > 3 ? astList[3] : gNil + } else { + ast = astList[2] + } + continue # TCO + } else if a0sym.val == "fn*" { + const argsNames = astList[1] as MalSequential + return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) + } else { + const evaledList = eval_ast(ast, env) as MalList + const fn = evaledList[0] + const callArgs = evaledList.val.slice(1) + if fn is MalNativeFunc { + return (fn as MalNativeFunc).call(callArgs) + } else if fn is MalFunc { + const f = fn as MalFunc + ast = f.ast + env = Env.new(f.env, f.params.val, callArgs) + continue # TCO + } else { + throw MalError.new("Expected function as head of list") + } + } + } +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +var repl_env = Env.new(null) + +def RE(str string) MalVal { + return EVAL(READ(str), repl_env) +} + +def REP(str string) string { + return PRINT(RE(str)) +} + +@entry +def main { + # core.sk: defined using Skew + ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) + repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) + + # core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))") + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + RE("(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)))))))") + + if argv.count > 0 { + RE("(load-file \"" + argv[0] + "\")") + return + } + + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalError { + printLn("Error: \(e.message)") + } + catch e Error { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/step9_try.sk b/impls/skew/step9_try.sk index a526d30a4f..0c88655d26 100644 --- a/impls/skew/step9_try.sk +++ b/impls/skew/step9_try.sk @@ -1,204 +1,204 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def starts_with(lst MalList, sym string) bool { - return lst.count == 2 && lst[0].isSymbol(sym) -} -def qq_loop(elt MalVal, acc MalList) MalList { - if elt is MalList && starts_with(elt as MalList, "splice-unquote") { - return MalList.new([MalSymbol.new("concat"), (elt as MalList)[1], acc]) - } else { - return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) - } -} -def qq_foldr(xs List) MalList { - var acc = MalList.new([]) - for i = xs.count-1; 0 <= i; i -= 1 { - acc = qq_loop(xs[i], acc) - } - return acc -} -def quasiquote(ast MalVal) MalVal { - if ast is MalVector { - return MalList.new([MalSymbol.new("vec"), qq_foldr((ast as MalVector).val)]) - } else if ast is MalSymbol || ast is MalHashMap { - return MalList.new([MalSymbol.new("quote"), ast]) - } else if !(ast is MalList) { - return ast - } else if starts_with(ast as MalList, "unquote") { - return (ast as MalList)[1] - } else { - return qq_foldr((ast as MalList).val) - } -} - -def isMacro(ast MalVal, env Env) bool { - if !(ast is MalList) { return false } - const astList = ast as MalList - if astList.isEmpty { return false } - const a0 = astList[0] - if !(a0 is MalSymbol) { return false } - const a0Sym = a0 as MalSymbol - if env.find(a0Sym) == null { return false } - const f = env.get(a0Sym) - if !(f is MalFunc) { return false } - return (f as MalFunc).isMacro -} - -def macroexpand(ast MalVal, env Env) MalVal { - while isMacro(ast, env) { - const astList = ast as MalList - const mac = env.get(astList[0] as MalSymbol) as MalFunc - ast = mac.call((astList.rest as MalSequential).val) - } - return ast -} - -def eval_ast(ast MalVal, env Env) MalVal { - if ast is MalSymbol { - return env.get(ast as MalSymbol) - } else if ast is MalList { - return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) - } else if ast is MalVector { - return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) - } else if ast is MalHashMap { - var result List = [] - (ast as MalHashMap).val.each((k string, v MalVal) => { - result.append(MalVal.fromHashKey(k)) - result.append(EVAL(v, env)) - }) - return MalHashMap.fromList(result) - } else { - return ast - } -} - -def EVAL(ast MalVal, env Env) MalVal { - while true { - if !(ast is MalList) { return eval_ast(ast, env) } - ast = macroexpand(ast, env) - if !(ast is MalList) { return eval_ast(ast, env) } - const astList = ast as MalList - if astList.isEmpty { return ast } - const a0sym = astList[0] as MalSymbol - if a0sym.val == "def!" { - return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) - } else if a0sym.val == "let*" { - var letenv = Env.new(env) - const assigns = astList[1] as MalSequential - for i = 0; i < assigns.count; i += 2 { - letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) - } - ast = astList[2] - env = letenv - continue # TCO - } else if a0sym.val == "quote" { - return astList[1] - } else if a0sym.val == "quasiquoteexpand" { - return quasiquote(astList[1]) - } else if a0sym.val == "quasiquote" { - ast = quasiquote(astList[1]) - continue # TCO - } else if a0sym.val == "defmacro!" { - var fn = EVAL(astList[2], env) as MalFunc - var macro = MalFunc.new(fn.ast, fn.params, fn.env, fn.func) - macro.setAsMacro - return env.set(astList[1] as MalSymbol, macro) - } else if a0sym.val == "macroexpand" { - return macroexpand(astList[1], env) - } else if a0sym.val == "try*" { - if astList.count < 3 { - return EVAL(astList[1], env) - } - var exc MalVal - try { - return EVAL(astList[1], env) - } - catch e MalUserError { exc = e.data } - catch e MalError { exc = MalString.new(e.message) } - catch e Error { exc = MalString.new(e.message) } - const catchClause = astList[2] as MalList - var catchEnv = Env.new(env, [catchClause[1] as MalSymbol], [exc]) - return EVAL(catchClause[2], catchEnv) - } else if a0sym.val == "do" { - const parts = astList.val.slice(1) - eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) - ast = parts[parts.count - 1] - continue # TCO - } else if a0sym.val == "if" { - const condRes = EVAL(astList[1], env) - if condRes is MalNil || condRes is MalFalse { - ast = astList.count > 3 ? astList[3] : gNil - } else { - ast = astList[2] - } - continue # TCO - } else if a0sym.val == "fn*" { - const argsNames = astList[1] as MalSequential - return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) - } else { - const evaledList = eval_ast(ast, env) as MalList - const fn = evaledList[0] - const callArgs = evaledList.val.slice(1) - if fn is MalNativeFunc { - return (fn as MalNativeFunc).call(callArgs) - } else if fn is MalFunc { - const f = fn as MalFunc - ast = f.ast - env = Env.new(f.env, f.params.val, callArgs) - continue # TCO - } else { - throw MalError.new("Expected function as head of list") - } - } - } -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -var repl_env = Env.new(null) - -def RE(str string) MalVal { - return EVAL(READ(str), repl_env) -} - -def REP(str string) string { - return PRINT(RE(str)) -} - -@entry -def main { - # core.sk: defined using Skew - ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) - repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) - - # core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))") - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - RE("(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)))))))") - - if argv.count > 0 { - RE("(load-file \"" + argv[0] + "\")") - return - } - - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalUserError { - printLn("Error: \(e.data.print(false))") - } - catch e MalError { - printLn("Error: \(e.message)") - } - catch e Error { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def starts_with(lst MalList, sym string) bool { + return lst.count == 2 && lst[0].isSymbol(sym) +} +def qq_loop(elt MalVal, acc MalList) MalList { + if elt is MalList && starts_with(elt as MalList, "splice-unquote") { + return MalList.new([MalSymbol.new("concat"), (elt as MalList)[1], acc]) + } else { + return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) + } +} +def qq_foldr(xs List) MalList { + var acc = MalList.new([]) + for i = xs.count-1; 0 <= i; i -= 1 { + acc = qq_loop(xs[i], acc) + } + return acc +} +def quasiquote(ast MalVal) MalVal { + if ast is MalVector { + return MalList.new([MalSymbol.new("vec"), qq_foldr((ast as MalVector).val)]) + } else if ast is MalSymbol || ast is MalHashMap { + return MalList.new([MalSymbol.new("quote"), ast]) + } else if !(ast is MalList) { + return ast + } else if starts_with(ast as MalList, "unquote") { + return (ast as MalList)[1] + } else { + return qq_foldr((ast as MalList).val) + } +} + +def isMacro(ast MalVal, env Env) bool { + if !(ast is MalList) { return false } + const astList = ast as MalList + if astList.isEmpty { return false } + const a0 = astList[0] + if !(a0 is MalSymbol) { return false } + const a0Sym = a0 as MalSymbol + if env.find(a0Sym) == null { return false } + const f = env.get(a0Sym) + if !(f is MalFunc) { return false } + return (f as MalFunc).isMacro +} + +def macroexpand(ast MalVal, env Env) MalVal { + while isMacro(ast, env) { + const astList = ast as MalList + const mac = env.get(astList[0] as MalSymbol) as MalFunc + ast = mac.call((astList.rest as MalSequential).val) + } + return ast +} + +def eval_ast(ast MalVal, env Env) MalVal { + if ast is MalSymbol { + return env.get(ast as MalSymbol) + } else if ast is MalList { + return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) + } else if ast is MalVector { + return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) + } else if ast is MalHashMap { + var result List = [] + (ast as MalHashMap).val.each((k string, v MalVal) => { + result.append(MalVal.fromHashKey(k)) + result.append(EVAL(v, env)) + }) + return MalHashMap.fromList(result) + } else { + return ast + } +} + +def EVAL(ast MalVal, env Env) MalVal { + while true { + if !(ast is MalList) { return eval_ast(ast, env) } + ast = macroexpand(ast, env) + if !(ast is MalList) { return eval_ast(ast, env) } + const astList = ast as MalList + if astList.isEmpty { return ast } + const a0sym = astList[0] as MalSymbol + if a0sym.val == "def!" { + return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) + } else if a0sym.val == "let*" { + var letenv = Env.new(env) + const assigns = astList[1] as MalSequential + for i = 0; i < assigns.count; i += 2 { + letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) + } + ast = astList[2] + env = letenv + continue # TCO + } else if a0sym.val == "quote" { + return astList[1] + } else if a0sym.val == "quasiquoteexpand" { + return quasiquote(astList[1]) + } else if a0sym.val == "quasiquote" { + ast = quasiquote(astList[1]) + continue # TCO + } else if a0sym.val == "defmacro!" { + var fn = EVAL(astList[2], env) as MalFunc + var macro = MalFunc.new(fn.ast, fn.params, fn.env, fn.func) + macro.setAsMacro + return env.set(astList[1] as MalSymbol, macro) + } else if a0sym.val == "macroexpand" { + return macroexpand(astList[1], env) + } else if a0sym.val == "try*" { + if astList.count < 3 { + return EVAL(astList[1], env) + } + var exc MalVal + try { + return EVAL(astList[1], env) + } + catch e MalUserError { exc = e.data } + catch e MalError { exc = MalString.new(e.message) } + catch e Error { exc = MalString.new(e.message) } + const catchClause = astList[2] as MalList + var catchEnv = Env.new(env, [catchClause[1] as MalSymbol], [exc]) + return EVAL(catchClause[2], catchEnv) + } else if a0sym.val == "do" { + const parts = astList.val.slice(1) + eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) + ast = parts[parts.count - 1] + continue # TCO + } else if a0sym.val == "if" { + const condRes = EVAL(astList[1], env) + if condRes is MalNil || condRes is MalFalse { + ast = astList.count > 3 ? astList[3] : gNil + } else { + ast = astList[2] + } + continue # TCO + } else if a0sym.val == "fn*" { + const argsNames = astList[1] as MalSequential + return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) + } else { + const evaledList = eval_ast(ast, env) as MalList + const fn = evaledList[0] + const callArgs = evaledList.val.slice(1) + if fn is MalNativeFunc { + return (fn as MalNativeFunc).call(callArgs) + } else if fn is MalFunc { + const f = fn as MalFunc + ast = f.ast + env = Env.new(f.env, f.params.val, callArgs) + continue # TCO + } else { + throw MalError.new("Expected function as head of list") + } + } + } +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +var repl_env = Env.new(null) + +def RE(str string) MalVal { + return EVAL(READ(str), repl_env) +} + +def REP(str string) string { + return PRINT(RE(str)) +} + +@entry +def main { + # core.sk: defined using Skew + ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) + repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) + + # core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))") + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + RE("(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)))))))") + + if argv.count > 0 { + RE("(load-file \"" + argv[0] + "\")") + return + } + + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalUserError { + printLn("Error: \(e.data.print(false))") + } + catch e MalError { + printLn("Error: \(e.message)") + } + catch e Error { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/stepA_mal.sk b/impls/skew/stepA_mal.sk index 622936426f..5bb76567c2 100644 --- a/impls/skew/stepA_mal.sk +++ b/impls/skew/stepA_mal.sk @@ -1,206 +1,206 @@ -def READ(str string) MalVal { - return read_str(str) -} - -def starts_with(lst MalList, sym string) bool { - return lst.count == 2 && lst[0].isSymbol(sym) -} -def qq_loop(elt MalVal, acc MalList) MalList { - if elt is MalList && starts_with(elt as MalList, "splice-unquote") { - return MalList.new([MalSymbol.new("concat"), (elt as MalList)[1], acc]) - } else { - return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) - } -} -def qq_foldr(xs List) MalList { - var acc = MalList.new([]) - for i = xs.count-1; 0 <= i; i -= 1 { - acc = qq_loop(xs[i], acc) - } - return acc -} -def quasiquote(ast MalVal) MalVal { - if ast is MalVector { - return MalList.new([MalSymbol.new("vec"), qq_foldr((ast as MalVector).val)]) - } else if ast is MalSymbol || ast is MalHashMap { - return MalList.new([MalSymbol.new("quote"), ast]) - } else if !(ast is MalList) { - return ast - } else if starts_with(ast as MalList, "unquote") { - return (ast as MalList)[1] - } else { - return qq_foldr((ast as MalList).val) - } -} - -def isMacro(ast MalVal, env Env) bool { - if !(ast is MalList) { return false } - const astList = ast as MalList - if astList.isEmpty { return false } - const a0 = astList[0] - if !(a0 is MalSymbol) { return false } - const a0Sym = a0 as MalSymbol - if env.find(a0Sym) == null { return false } - const f = env.get(a0Sym) - if !(f is MalFunc) { return false } - return (f as MalFunc).isMacro -} - -def macroexpand(ast MalVal, env Env) MalVal { - while isMacro(ast, env) { - const astList = ast as MalList - const mac = env.get(astList[0] as MalSymbol) as MalFunc - ast = mac.call((astList.rest as MalSequential).val) - } - return ast -} - -def eval_ast(ast MalVal, env Env) MalVal { - if ast is MalSymbol { - return env.get(ast as MalSymbol) - } else if ast is MalList { - return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) - } else if ast is MalVector { - return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) - } else if ast is MalHashMap { - var result List = [] - (ast as MalHashMap).val.each((k string, v MalVal) => { - result.append(MalVal.fromHashKey(k)) - result.append(EVAL(v, env)) - }) - return MalHashMap.fromList(result) - } else { - return ast - } -} - -def EVAL(ast MalVal, env Env) MalVal { - while true { - if !(ast is MalList) { return eval_ast(ast, env) } - ast = macroexpand(ast, env) - if !(ast is MalList) { return eval_ast(ast, env) } - const astList = ast as MalList - if astList.isEmpty { return ast } - const a0sym = astList[0] as MalSymbol - if a0sym.val == "def!" { - return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) - } else if a0sym.val == "let*" { - var letenv = Env.new(env) - const assigns = astList[1] as MalSequential - for i = 0; i < assigns.count; i += 2 { - letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) - } - ast = astList[2] - env = letenv - continue # TCO - } else if a0sym.val == "quote" { - return astList[1] - } else if a0sym.val == "quasiquoteexpand" { - return quasiquote(astList[1]) - } else if a0sym.val == "quasiquote" { - ast = quasiquote(astList[1]) - continue # TCO - } else if a0sym.val == "defmacro!" { - var fn = EVAL(astList[2], env) as MalFunc - var macro = MalFunc.new(fn.ast, fn.params, fn.env, fn.func) - macro.setAsMacro - return env.set(astList[1] as MalSymbol, macro) - } else if a0sym.val == "macroexpand" { - return macroexpand(astList[1], env) - } else if a0sym.val == "try*" { - if astList.count < 3 { - return EVAL(astList[1], env) - } - var exc MalVal - try { - return EVAL(astList[1], env) - } - catch e MalUserError { exc = e.data } - catch e MalError { exc = MalString.new(e.message) } - catch e Error { exc = MalString.new(e.message) } - const catchClause = astList[2] as MalList - var catchEnv = Env.new(env, [catchClause[1] as MalSymbol], [exc]) - return EVAL(catchClause[2], catchEnv) - } else if a0sym.val == "do" { - const parts = astList.val.slice(1) - eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) - ast = parts[parts.count - 1] - continue # TCO - } else if a0sym.val == "if" { - const condRes = EVAL(astList[1], env) - if condRes is MalNil || condRes is MalFalse { - ast = astList.count > 3 ? astList[3] : gNil - } else { - ast = astList[2] - } - continue # TCO - } else if a0sym.val == "fn*" { - const argsNames = astList[1] as MalSequential - return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) - } else { - const evaledList = eval_ast(ast, env) as MalList - const fn = evaledList[0] - const callArgs = evaledList.val.slice(1) - if fn is MalNativeFunc { - return (fn as MalNativeFunc).call(callArgs) - } else if fn is MalFunc { - const f = fn as MalFunc - ast = f.ast - env = Env.new(f.env, f.params.val, callArgs) - continue # TCO - } else { - throw MalError.new("Expected function as head of list") - } - } - } -} - -def PRINT(exp MalVal) string { - return exp?.print(true) -} - -var repl_env = Env.new(null) - -def RE(str string) MalVal { - return EVAL(READ(str), repl_env) -} - -def REP(str string) string { - return PRINT(RE(str)) -} - -@entry -def main { - # core.sk: defined using Skew - ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) - repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) - - # core.mal: defined using the language itself - RE("(def! *host-language* \"skew\")") - RE("(def! not (fn* (a) (if a false true)))") - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - RE("(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)))))))") - - if argv.count > 0 { - RE("(load-file \"" + argv[0] + "\")") - return - } - - RE("(println (str \"Mal [\" *host-language* \"]\"))") - var line string - while (line = readLine("user> ")) != null { - if line == "" { continue } - try { - printLn(REP(line)) - } - catch e MalUserError { - printLn("Error: \(e.data.print(false))") - } - catch e MalError { - printLn("Error: \(e.message)") - } - catch e Error { - printLn("Error: \(e.message)") - } - } -} +def READ(str string) MalVal { + return read_str(str) +} + +def starts_with(lst MalList, sym string) bool { + return lst.count == 2 && lst[0].isSymbol(sym) +} +def qq_loop(elt MalVal, acc MalList) MalList { + if elt is MalList && starts_with(elt as MalList, "splice-unquote") { + return MalList.new([MalSymbol.new("concat"), (elt as MalList)[1], acc]) + } else { + return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) + } +} +def qq_foldr(xs List) MalList { + var acc = MalList.new([]) + for i = xs.count-1; 0 <= i; i -= 1 { + acc = qq_loop(xs[i], acc) + } + return acc +} +def quasiquote(ast MalVal) MalVal { + if ast is MalVector { + return MalList.new([MalSymbol.new("vec"), qq_foldr((ast as MalVector).val)]) + } else if ast is MalSymbol || ast is MalHashMap { + return MalList.new([MalSymbol.new("quote"), ast]) + } else if !(ast is MalList) { + return ast + } else if starts_with(ast as MalList, "unquote") { + return (ast as MalList)[1] + } else { + return qq_foldr((ast as MalList).val) + } +} + +def isMacro(ast MalVal, env Env) bool { + if !(ast is MalList) { return false } + const astList = ast as MalList + if astList.isEmpty { return false } + const a0 = astList[0] + if !(a0 is MalSymbol) { return false } + const a0Sym = a0 as MalSymbol + if env.find(a0Sym) == null { return false } + const f = env.get(a0Sym) + if !(f is MalFunc) { return false } + return (f as MalFunc).isMacro +} + +def macroexpand(ast MalVal, env Env) MalVal { + while isMacro(ast, env) { + const astList = ast as MalList + const mac = env.get(astList[0] as MalSymbol) as MalFunc + ast = mac.call((astList.rest as MalSequential).val) + } + return ast +} + +def eval_ast(ast MalVal, env Env) MalVal { + if ast is MalSymbol { + return env.get(ast as MalSymbol) + } else if ast is MalList { + return MalList.new((ast as MalList).val.map(e => EVAL(e, env))) + } else if ast is MalVector { + return MalVector.new((ast as MalVector).val.map(e => EVAL(e, env))) + } else if ast is MalHashMap { + var result List = [] + (ast as MalHashMap).val.each((k string, v MalVal) => { + result.append(MalVal.fromHashKey(k)) + result.append(EVAL(v, env)) + }) + return MalHashMap.fromList(result) + } else { + return ast + } +} + +def EVAL(ast MalVal, env Env) MalVal { + while true { + if !(ast is MalList) { return eval_ast(ast, env) } + ast = macroexpand(ast, env) + if !(ast is MalList) { return eval_ast(ast, env) } + const astList = ast as MalList + if astList.isEmpty { return ast } + const a0sym = astList[0] as MalSymbol + if a0sym.val == "def!" { + return env.set(astList[1] as MalSymbol, EVAL(astList[2], env)) + } else if a0sym.val == "let*" { + var letenv = Env.new(env) + const assigns = astList[1] as MalSequential + for i = 0; i < assigns.count; i += 2 { + letenv.set(assigns[i] as MalSymbol, EVAL(assigns[i + 1], letenv)) + } + ast = astList[2] + env = letenv + continue # TCO + } else if a0sym.val == "quote" { + return astList[1] + } else if a0sym.val == "quasiquoteexpand" { + return quasiquote(astList[1]) + } else if a0sym.val == "quasiquote" { + ast = quasiquote(astList[1]) + continue # TCO + } else if a0sym.val == "defmacro!" { + var fn = EVAL(astList[2], env) as MalFunc + var macro = MalFunc.new(fn.ast, fn.params, fn.env, fn.func) + macro.setAsMacro + return env.set(astList[1] as MalSymbol, macro) + } else if a0sym.val == "macroexpand" { + return macroexpand(astList[1], env) + } else if a0sym.val == "try*" { + if astList.count < 3 { + return EVAL(astList[1], env) + } + var exc MalVal + try { + return EVAL(astList[1], env) + } + catch e MalUserError { exc = e.data } + catch e MalError { exc = MalString.new(e.message) } + catch e Error { exc = MalString.new(e.message) } + const catchClause = astList[2] as MalList + var catchEnv = Env.new(env, [catchClause[1] as MalSymbol], [exc]) + return EVAL(catchClause[2], catchEnv) + } else if a0sym.val == "do" { + const parts = astList.val.slice(1) + eval_ast(MalList.new(parts.slice(0, parts.count - 1)), env) + ast = parts[parts.count - 1] + continue # TCO + } else if a0sym.val == "if" { + const condRes = EVAL(astList[1], env) + if condRes is MalNil || condRes is MalFalse { + ast = astList.count > 3 ? astList[3] : gNil + } else { + ast = astList[2] + } + continue # TCO + } else if a0sym.val == "fn*" { + const argsNames = astList[1] as MalSequential + return MalFunc.new(astList[2], argsNames, env, (args List) => EVAL(astList[2], Env.new(env, argsNames.val, args))) + } else { + const evaledList = eval_ast(ast, env) as MalList + const fn = evaledList[0] + const callArgs = evaledList.val.slice(1) + if fn is MalNativeFunc { + return (fn as MalNativeFunc).call(callArgs) + } else if fn is MalFunc { + const f = fn as MalFunc + ast = f.ast + env = Env.new(f.env, f.params.val, callArgs) + continue # TCO + } else { + throw MalError.new("Expected function as head of list") + } + } + } +} + +def PRINT(exp MalVal) string { + return exp?.print(true) +} + +var repl_env = Env.new(null) + +def RE(str string) MalVal { + return EVAL(READ(str), repl_env) +} + +def REP(str string) string { + return PRINT(RE(str)) +} + +@entry +def main { + # core.sk: defined using Skew + ns.each((name, func) => repl_env.set(MalSymbol.new(name), MalNativeFunc.new(func))) + repl_env.set(MalSymbol.new("*ARGV*"), MalList.new(argv.isEmpty ? [] : argv.slice(1).map(e => MalString.new(e)))) + + # core.mal: defined using the language itself + RE("(def! *host-language* \"skew\")") + RE("(def! not (fn* (a) (if a false true)))") + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + RE("(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)))))))") + + if argv.count > 0 { + RE("(load-file \"" + argv[0] + "\")") + return + } + + RE("(println (str \"Mal [\" *host-language* \"]\"))") + var line string + while (line = readLine("user> ")) != null { + if line == "" { continue } + try { + printLn(REP(line)) + } + catch e MalUserError { + printLn("Error: \(e.data.print(false))") + } + catch e MalError { + printLn("Error: \(e.message)") + } + catch e Error { + printLn("Error: \(e.message)") + } + } +} diff --git a/impls/skew/tests/step5_tco.mal b/impls/skew/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/skew/tests/step5_tco.mal +++ b/impls/skew/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/skew/types.sk b/impls/skew/types.sk index f12ef88611..ac216c2b2d 100644 --- a/impls/skew/types.sk +++ b/impls/skew/types.sk @@ -1,250 +1,250 @@ -class MalError { - const message string -} - -class MalUserError { - const data MalVal -} - -class MalVal { - var _meta MalVal = gNil - def toHashKey string { throw MalError.new("Not allowed as hash map key") } - def print(readable bool) string - def equal(o MalVal) bool - def isSymbol(name string) bool { return false } - def seq MalVal { throw MalError.new("seq: called on non-sequence") } - def meta MalVal { return _meta } - def _setMeta(newMeta MalVal) { _meta = newMeta } - def withMeta(newMeta MalVal) MalVal { - var res = self.clone - res._setMeta(newMeta) - return res - } - def clone MalVal -} - -namespace MalVal { - def fromHashKey(key string) MalVal { - if key.startsWith("S_") { return MalString.new(key.slice(2)) } - else if key.startsWith("K_") { return MalKeyword.new(key.slice(2)) } - else { throw "Illegal hash key string" } - } - def fromBool(b bool) MalVal { return b ? gTrue : gFalse } -} - -class MalNil : MalVal { - over print(readable bool) string { return "nil" } - over equal(o MalVal) bool { return o is MalNil } - over seq MalVal { return gNil } - over clone MalVal { return self } -} -const gNil = MalNil.new - -class MalTrue : MalVal { - over print(readable bool) string { return "true" } - over equal(o MalVal) bool { return o is MalTrue } - over clone MalVal { return self } -} -const gTrue = MalTrue.new - -class MalFalse : MalVal { - over print(readable bool) string { return "false" } - over equal(o MalVal) bool { return o is MalFalse } - over clone MalVal { return self } -} -const gFalse = MalFalse.new - -class MalNumber : MalVal { - const _data int - over print(readable bool) string { return _data.toString } - def val int { return _data } - over equal(o MalVal) bool { return o is MalNumber && (o as MalNumber).val == val } - over clone MalVal { return self } -} - -class MalSymbol : MalVal { - const _data string - over print(readable bool) string { return _data } - def val string { return _data } - over equal(o MalVal) bool { return o is MalSymbol && (o as MalSymbol).val == val } - over isSymbol(name string) bool { return _data == name } - over clone MalVal { return MalSymbol.new(_data) } -} - -class MalString : MalVal { - const _data string - over print(readable bool) string { return readable ? "\"\(escaped_data)\"" : _data } - over toHashKey string { return "S_\(_data)" } - def val string { return _data } - over equal(o MalVal) bool { return o is MalString && (o as MalString).val == val } - def escaped_data string { - return _data.replaceAll("\\", "\\\\").replaceAll("\"", "\\\"").replaceAll("\n", "\\n") - } - over seq MalVal { return _data.count == 0 ? gNil : MalList.new(_data.split("").map(e => MalString.new(e))) } - over clone MalVal { return MalString.new(_data) } -} - -class MalKeyword : MalVal { - const _data string - over print(readable bool) string { return ":\(_data)" } - over toHashKey string { return "K_\(_data)" } - def val string { return _data } - over equal(o MalVal) bool { return o is MalKeyword && (o as MalKeyword).val == val } - over clone MalVal { return MalKeyword.new(_data) } -} - -class MalSequential : MalVal { - const _data List - def val List { return _data } - def isEmpty bool { return _data.isEmpty } - def asOneString(readable bool) string { - return " ".join(_data.map(v => v.print(readable))) - } - def count int { return _data.count } - def [](index int) MalVal { return _data[index] } - over equal(o MalVal) bool { - if !(o is MalSequential) { return false } - const oval = (o as MalSequential).val - if val.count != oval.count { return false } - for i in 0..val.count { - if !val[i].equal(oval[i]) { return false } - } - return true - } - def nth(position int) MalVal { - if position >= count { throw MalError.new("nth: index out of range") } - return val[position] - } - def first MalVal { - if isEmpty { return gNil } - return val[0] - } - def rest MalVal { - if isEmpty { return MalList.new([]) } - return MalList.new(val.slice(1)) - } - def conj(args List) MalVal -} - -class MalList : MalSequential { - over print(readable bool) string { return "(" + asOneString(readable) + ")" } - over seq MalVal { return isEmpty ? gNil : self } - over conj(args List) MalVal { - var res = args.clone - res.reverse - res.append(_data) - return MalList.new(res) - } - over clone MalVal { return MalList.new(_data) } -} - -class MalVector : MalSequential { - over print(readable bool) string { return "[" + asOneString(readable) + "]" } - over seq MalVal { return isEmpty ? gNil : MalList.new(_data) } - over conj(args List) MalVal { - var res = _data.clone - res.append(args) - return MalVector.new(res) - } - over clone MalVal { return MalVector.new(_data) } -} - -class MalHashMap : MalVal { - const _data StringMap - over print(readable bool) string { - var pairs List = [] - _data.each((k string, v MalVal) => pairs.append("\(MalVal.fromHashKey(k).print(readable)) \(v.print(readable))")) - return "{" + " ".join(pairs) + "}" - } - def val StringMap { return _data } - over equal(o MalVal) bool { - if !(o is MalHashMap) { return false } - const oh = o as MalHashMap - if oh.val.count != val.count { return false } - var allEqual = true - _data.each((k string, v MalVal) => { - if !(k in oh.val) || !(v.equal(oh.val[k])) { - allEqual = false - } - }) - return allEqual - } - def assoc(kv_list List) MalVal { - var new_data = _data.clone - for i = 0; i < kv_list.count; i += 2 { - new_data[kv_list[i].toHashKey] = kv_list[i + 1] - } - return MalHashMap.new(new_data) - } - def dissoc(keys List) MalVal { - var new_data = _data.clone - for key in keys { - new_data.remove(key.toHashKey) - } - return MalHashMap.new(new_data) - } - def get(key MalVal) MalVal { return _data.get(key.toHashKey, gNil) } - def contains(key MalVal) bool { return key.toHashKey in _data } - def keys List { - return _data.keys.map(k => MalVal.fromHashKey(k)) - } - def vals List { return _data.values } - over clone MalVal { return MalHashMap.new(_data) } -} - -namespace MalHashMap { - def fromList(kv_list List) MalHashMap { - var result StringMap = {} - for i = 0; i < kv_list.count; i += 2 { - result[kv_list[i].toHashKey] = kv_list[i + 1] - } - return MalHashMap.new(result) - } -} - -class MalCallable : MalVal { - const func fn(List) MalVal - def call(args List) MalVal { - return func(args) - } -} - -class MalNativeFunc : MalCallable { - over print(readable bool) string { return "#" } - over equal(o MalVal) bool { return false } - over clone MalVal { return MalNativeFunc.new(func) } -} - -class MalFunc : MalCallable { - const ast MalVal - const params MalSequential - const env Env - var _macro bool = false - def new(aAst MalVal, aParams MalSequential, aEnv Env, aFunc fn(List) MalVal) { - super(aFunc) - ast = aAst - params = aParams - env = aEnv - } - def isMacro bool { return _macro } - def setAsMacro { _macro = true } - over print(readable bool) string { return "#" } - over equal(o MalVal) bool { return false } - over clone MalVal { - var f = MalFunc.new(ast, params, env, func) - if isMacro { f.setAsMacro } - return f - } -} - -class MalAtom : MalVal { - var _data MalVal - over print(readable bool) string { return "(atom \(_data.print(readable)))" } - def val MalVal { return _data } - over equal(o MalVal) bool { return o is MalAtom && val.equal((o as MalAtom).val) } - def resetBang(newData MalVal) MalVal { - _data = newData - return _data - } - over clone MalVal { return MalAtom.new(_data) } -} +class MalError { + const message string +} + +class MalUserError { + const data MalVal +} + +class MalVal { + var _meta MalVal = gNil + def toHashKey string { throw MalError.new("Not allowed as hash map key") } + def print(readable bool) string + def equal(o MalVal) bool + def isSymbol(name string) bool { return false } + def seq MalVal { throw MalError.new("seq: called on non-sequence") } + def meta MalVal { return _meta } + def _setMeta(newMeta MalVal) { _meta = newMeta } + def withMeta(newMeta MalVal) MalVal { + var res = self.clone + res._setMeta(newMeta) + return res + } + def clone MalVal +} + +namespace MalVal { + def fromHashKey(key string) MalVal { + if key.startsWith("S_") { return MalString.new(key.slice(2)) } + else if key.startsWith("K_") { return MalKeyword.new(key.slice(2)) } + else { throw "Illegal hash key string" } + } + def fromBool(b bool) MalVal { return b ? gTrue : gFalse } +} + +class MalNil : MalVal { + over print(readable bool) string { return "nil" } + over equal(o MalVal) bool { return o is MalNil } + over seq MalVal { return gNil } + over clone MalVal { return self } +} +const gNil = MalNil.new + +class MalTrue : MalVal { + over print(readable bool) string { return "true" } + over equal(o MalVal) bool { return o is MalTrue } + over clone MalVal { return self } +} +const gTrue = MalTrue.new + +class MalFalse : MalVal { + over print(readable bool) string { return "false" } + over equal(o MalVal) bool { return o is MalFalse } + over clone MalVal { return self } +} +const gFalse = MalFalse.new + +class MalNumber : MalVal { + const _data int + over print(readable bool) string { return _data.toString } + def val int { return _data } + over equal(o MalVal) bool { return o is MalNumber && (o as MalNumber).val == val } + over clone MalVal { return self } +} + +class MalSymbol : MalVal { + const _data string + over print(readable bool) string { return _data } + def val string { return _data } + over equal(o MalVal) bool { return o is MalSymbol && (o as MalSymbol).val == val } + over isSymbol(name string) bool { return _data == name } + over clone MalVal { return MalSymbol.new(_data) } +} + +class MalString : MalVal { + const _data string + over print(readable bool) string { return readable ? "\"\(escaped_data)\"" : _data } + over toHashKey string { return "S_\(_data)" } + def val string { return _data } + over equal(o MalVal) bool { return o is MalString && (o as MalString).val == val } + def escaped_data string { + return _data.replaceAll("\\", "\\\\").replaceAll("\"", "\\\"").replaceAll("\n", "\\n") + } + over seq MalVal { return _data.count == 0 ? gNil : MalList.new(_data.split("").map(e => MalString.new(e))) } + over clone MalVal { return MalString.new(_data) } +} + +class MalKeyword : MalVal { + const _data string + over print(readable bool) string { return ":\(_data)" } + over toHashKey string { return "K_\(_data)" } + def val string { return _data } + over equal(o MalVal) bool { return o is MalKeyword && (o as MalKeyword).val == val } + over clone MalVal { return MalKeyword.new(_data) } +} + +class MalSequential : MalVal { + const _data List + def val List { return _data } + def isEmpty bool { return _data.isEmpty } + def asOneString(readable bool) string { + return " ".join(_data.map(v => v.print(readable))) + } + def count int { return _data.count } + def [](index int) MalVal { return _data[index] } + over equal(o MalVal) bool { + if !(o is MalSequential) { return false } + const oval = (o as MalSequential).val + if val.count != oval.count { return false } + for i in 0..val.count { + if !val[i].equal(oval[i]) { return false } + } + return true + } + def nth(position int) MalVal { + if position >= count { throw MalError.new("nth: index out of range") } + return val[position] + } + def first MalVal { + if isEmpty { return gNil } + return val[0] + } + def rest MalVal { + if isEmpty { return MalList.new([]) } + return MalList.new(val.slice(1)) + } + def conj(args List) MalVal +} + +class MalList : MalSequential { + over print(readable bool) string { return "(" + asOneString(readable) + ")" } + over seq MalVal { return isEmpty ? gNil : self } + over conj(args List) MalVal { + var res = args.clone + res.reverse + res.append(_data) + return MalList.new(res) + } + over clone MalVal { return MalList.new(_data) } +} + +class MalVector : MalSequential { + over print(readable bool) string { return "[" + asOneString(readable) + "]" } + over seq MalVal { return isEmpty ? gNil : MalList.new(_data) } + over conj(args List) MalVal { + var res = _data.clone + res.append(args) + return MalVector.new(res) + } + over clone MalVal { return MalVector.new(_data) } +} + +class MalHashMap : MalVal { + const _data StringMap + over print(readable bool) string { + var pairs List = [] + _data.each((k string, v MalVal) => pairs.append("\(MalVal.fromHashKey(k).print(readable)) \(v.print(readable))")) + return "{" + " ".join(pairs) + "}" + } + def val StringMap { return _data } + over equal(o MalVal) bool { + if !(o is MalHashMap) { return false } + const oh = o as MalHashMap + if oh.val.count != val.count { return false } + var allEqual = true + _data.each((k string, v MalVal) => { + if !(k in oh.val) || !(v.equal(oh.val[k])) { + allEqual = false + } + }) + return allEqual + } + def assoc(kv_list List) MalVal { + var new_data = _data.clone + for i = 0; i < kv_list.count; i += 2 { + new_data[kv_list[i].toHashKey] = kv_list[i + 1] + } + return MalHashMap.new(new_data) + } + def dissoc(keys List) MalVal { + var new_data = _data.clone + for key in keys { + new_data.remove(key.toHashKey) + } + return MalHashMap.new(new_data) + } + def get(key MalVal) MalVal { return _data.get(key.toHashKey, gNil) } + def contains(key MalVal) bool { return key.toHashKey in _data } + def keys List { + return _data.keys.map(k => MalVal.fromHashKey(k)) + } + def vals List { return _data.values } + over clone MalVal { return MalHashMap.new(_data) } +} + +namespace MalHashMap { + def fromList(kv_list List) MalHashMap { + var result StringMap = {} + for i = 0; i < kv_list.count; i += 2 { + result[kv_list[i].toHashKey] = kv_list[i + 1] + } + return MalHashMap.new(result) + } +} + +class MalCallable : MalVal { + const func fn(List) MalVal + def call(args List) MalVal { + return func(args) + } +} + +class MalNativeFunc : MalCallable { + over print(readable bool) string { return "#" } + over equal(o MalVal) bool { return false } + over clone MalVal { return MalNativeFunc.new(func) } +} + +class MalFunc : MalCallable { + const ast MalVal + const params MalSequential + const env Env + var _macro bool = false + def new(aAst MalVal, aParams MalSequential, aEnv Env, aFunc fn(List) MalVal) { + super(aFunc) + ast = aAst + params = aParams + env = aEnv + } + def isMacro bool { return _macro } + def setAsMacro { _macro = true } + over print(readable bool) string { return "#" } + over equal(o MalVal) bool { return false } + over clone MalVal { + var f = MalFunc.new(ast, params, env, func) + if isMacro { f.setAsMacro } + return f + } +} + +class MalAtom : MalVal { + var _data MalVal + over print(readable bool) string { return "(atom \(_data.print(readable)))" } + def val MalVal { return _data } + over equal(o MalVal) bool { return o is MalAtom && val.equal((o as MalAtom).val) } + def resetBang(newData MalVal) MalVal { + _data = newData + return _data + } + over clone MalVal { return MalAtom.new(_data) } +} diff --git a/impls/skew/util.sk b/impls/skew/util.sk index 04fdfc1fa6..62d09647dc 100644 --- a/impls/skew/util.sk +++ b/impls/skew/util.sk @@ -1,55 +1,55 @@ -def argv List { - return process.argv.slice(2) -} - -def timeMs int { - return Date.new.getTime() -} - -var fs = require("fs") - -def readFile(filename string) string { - return fs.readFileSync(filename, "utf-8") -} - -def writeString(s string) { - fs.writeSync(1, s) -} - -def printLn(s string) { - writeString(s) - writeString("\n") -} - -def readLine(prompt string) string { - writeString(prompt) - var buffer = Buffer.new(1024) # in newer Node this should be Buffer.alloc - var stdin = fs.openSync("/dev/stdin", "rs") - var bytesread int - var anycharseen = false - var total = 0 - while (bytesread = fs.readSync(stdin, buffer, total, 1)) > 0 { - anycharseen = true - var lastchar = buffer.slice(total, total + bytesread).toString() - if lastchar == "\n" { - break - } - total += bytesread - } - fs.closeSync(stdin) - return anycharseen ? buffer.slice(0, total).toString() : null -} - -def stringToInt(str string) int { - return parseInt(str) -} - -@import { - const process dynamic - const Buffer dynamic - const Date dynamic - const Error dynamic - - def parseInt(str string) int - def require(name string) dynamic -} +def argv List { + return process.argv.slice(2) +} + +def timeMs int { + return Date.new.getTime() +} + +var fs = require("fs") + +def readFile(filename string) string { + return fs.readFileSync(filename, "utf-8") +} + +def writeString(s string) { + fs.writeSync(1, s) +} + +def printLn(s string) { + writeString(s) + writeString("\n") +} + +def readLine(prompt string) string { + writeString(prompt) + var buffer = Buffer.new(1024) # in newer Node this should be Buffer.alloc + var stdin = fs.openSync("/dev/stdin", "rs") + var bytesread int + var anycharseen = false + var total = 0 + while (bytesread = fs.readSync(stdin, buffer, total, 1)) > 0 { + anycharseen = true + var lastchar = buffer.slice(total, total + bytesread).toString() + if lastchar == "\n" { + break + } + total += bytesread + } + fs.closeSync(stdin) + return anycharseen ? buffer.slice(0, total).toString() : null +} + +def stringToInt(str string) int { + return parseInt(str) +} + +@import { + const process dynamic + const Buffer dynamic + const Date dynamic + const Error dynamic + + def parseInt(str string) int + def require(name string) dynamic +} diff --git a/impls/sml/.gitignore b/impls/sml/.gitignore index cb5dad854d..2df05bb0eb 100644 --- a/impls/sml/.gitignore +++ b/impls/sml/.gitignore @@ -1,4 +1,4 @@ -.smlmode -.step* -*.ui -*.uo +.smlmode +.step* +*.ui +*.uo diff --git a/impls/sml/Dockerfile b/impls/sml/Dockerfile index 36a2c90bf2..3313884227 100644 --- a/impls/sml/Dockerfile +++ b/impls/sml/Dockerfile @@ -1,31 +1,31 @@ -# We need focal for the Moscow ML PPA -FROM ubuntu:focal - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install software-properties-common - -RUN apt-get -y install polyml libpolyml-dev - -RUN apt-get -y install mlton - -RUN add-apt-repository -y ppa:kflarsen/mosml -RUN apt-get -y install mosml +# We need focal for the Moscow ML PPA +FROM ubuntu:focal + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install software-properties-common + +RUN apt-get -y install polyml libpolyml-dev + +RUN apt-get -y install mlton + +RUN add-apt-repository -y ppa:kflarsen/mosml +RUN apt-get -y install mosml diff --git a/impls/sml/LargeInt.sml b/impls/sml/LargeInt.sml index db95f80b24..a5d79b65c1 100644 --- a/impls/sml/LargeInt.sml +++ b/impls/sml/LargeInt.sml @@ -1,6 +1,6 @@ -(* Moscow ML does not have the LargeInt structure, - * but its Int is 64 bit on 64 bit systems. - * We need 64 bit integers for the `time-ms` core function. - *) - -structure LargeInt = Int +(* Moscow ML does not have the LargeInt structure, + * but its Int is 64 bit on 64 bit systems. + * We need 64 bit integers for the `time-ms` core function. + *) + +structure LargeInt = Int diff --git a/impls/sml/Makefile b/impls/sml/Makefile index 1792efc453..fb3d147af0 100644 --- a/impls/sml/Makefile +++ b/impls/sml/Makefile @@ -1,61 +1,61 @@ -STEP_BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step6_file step7_quote step8_macros step9_try stepA_mal - -sml_MODE_DEFAULT = polyml -sml_MODE_CONFIG = .smlmode - -ifeq ($(sml_MODE),) -sml_MODE = $(sml_MODE_DEFAULT) -endif -# some hackery to let Make know if it needs to rebuild when sml_MODE changes -ifneq ($(sml_MODE),$(shell cat $(sml_MODE_CONFIG) 2> /dev/null)) -$(shell rm $(sml_MODE_CONFIG) 2> /dev/null) -endif - -ifeq ($(sml_MODE),mlton) -SMLC = mlton -SMLCOUTFLAG = -output -BUILD_FILE = %.mlb -build_args = $1 -endif -ifeq ($(sml_MODE),mosml) -SMLC = mosmlc -SMLCOUTFLAG = -o -BUILD_FILE = %.mlb -build_args = LargeInt.sml -toplevel $(shell grep "\\.sml" $1) -endif -ifeq ($(sml_MODE),polyml) -SMLC = polyc -SMLCOUTFLAG = -o -BUILD_FILE = .%.poly.sml -build_args = $1 -endif - -all: $(STEP_BINS) - -dist: mal - -mal: stepA_mal - cp $< $@ - -.%.dep: %.mlb - @echo sml-deps -o $@ $< - $(eval DEPS := $(shell grep "\\.sml" $<)) - @echo "$(@:.%.dep=%) $@: $(DEPS)" > $@ - -include $(STEP_BINS:%=.%.dep) - -.%.poly.sml: %.mlb - @echo generate-sml -o $@ $< - @grep "\\.sml" $< | grep -v main | xargs printf "use \"%s\";\n" > $@ - -# some hackery to let Make track changes in sml_MODE -$(sml_MODE_CONFIG): - @echo $(sml_MODE) > $@ - -$(STEP_BINS): %: $(BUILD_FILE) $(sml_MODE_CONFIG) - $(SMLC) $(SMLCOUTFLAG) $@ $(call build_args,$<) - -clean: - rm -f $(STEP_BINS) .*.dep *.ui *.uo .*.poly.sml $(sml_MODE_CONFIG) - -.PHONY: all clean +STEP_BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step6_file step7_quote step8_macros step9_try stepA_mal + +sml_MODE_DEFAULT = polyml +sml_MODE_CONFIG = .smlmode + +ifeq ($(sml_MODE),) +sml_MODE = $(sml_MODE_DEFAULT) +endif +# some hackery to let Make know if it needs to rebuild when sml_MODE changes +ifneq ($(sml_MODE),$(shell cat $(sml_MODE_CONFIG) 2> /dev/null)) +$(shell rm $(sml_MODE_CONFIG) 2> /dev/null) +endif + +ifeq ($(sml_MODE),mlton) +SMLC = mlton +SMLCOUTFLAG = -output +BUILD_FILE = %.mlb +build_args = $1 +endif +ifeq ($(sml_MODE),mosml) +SMLC = mosmlc +SMLCOUTFLAG = -o +BUILD_FILE = %.mlb +build_args = LargeInt.sml -toplevel $(shell grep "\\.sml" $1) +endif +ifeq ($(sml_MODE),polyml) +SMLC = polyc +SMLCOUTFLAG = -o +BUILD_FILE = .%.poly.sml +build_args = $1 +endif + +all: $(STEP_BINS) + +dist: mal + +mal: stepA_mal + cp $< $@ + +.%.dep: %.mlb + @echo sml-deps -o $@ $< + $(eval DEPS := $(shell grep "\\.sml" $<)) + @echo "$(@:.%.dep=%) $@: $(DEPS)" > $@ + +include $(STEP_BINS:%=.%.dep) + +.%.poly.sml: %.mlb + @echo generate-sml -o $@ $< + @grep "\\.sml" $< | grep -v main | xargs printf "use \"%s\";\n" > $@ + +# some hackery to let Make track changes in sml_MODE +$(sml_MODE_CONFIG): + @echo $(sml_MODE) > $@ + +$(STEP_BINS): %: $(BUILD_FILE) $(sml_MODE_CONFIG) + $(SMLC) $(SMLCOUTFLAG) $@ $(call build_args,$<) + +clean: + rm -f $(STEP_BINS) .*.dep *.ui *.uo .*.poly.sml $(sml_MODE_CONFIG) + +.PHONY: all clean diff --git a/impls/sml/README.md b/impls/sml/README.md index 8f0ee651c2..80c5264fee 100644 --- a/impls/sml/README.md +++ b/impls/sml/README.md @@ -1,34 +1,34 @@ -# SML-MAL - -This is Make-A-Lisp in Standard ML. - -## Building - -Just run `make`. - -Building requires a Standard ML compiler with basis library. This MAL -implementation has been tested and works with Poly/ML, MLton, and Moscow ML. - -On Ubuntu, you can run `apt-get install polyml libpolyml-dev`. - -By setting `sml_MODE` to `polyml`, `mosml`, or `mlton` on invoking `make` you -can select which compiler to use. The Makefile has some hacks to figure out -how to make the different compilers build everything. - -## Running - -You can build a `mal` binary from the final step with `make dist`: - -``` -$ make dist -$ ./mal -Mal [sml] -user> (map (fn* (x) (println "Odelay!")) [1 2 3 4 5]) -Odelay! -Odelay! -Odelay! -Odelay! -Odelay! -(nil nil nil nil nil) -user> -``` +# SML-MAL + +This is Make-A-Lisp in Standard ML. + +## Building + +Just run `make`. + +Building requires a Standard ML compiler with basis library. This MAL +implementation has been tested and works with Poly/ML, MLton, and Moscow ML. + +On Ubuntu, you can run `apt-get install polyml libpolyml-dev`. + +By setting `sml_MODE` to `polyml`, `mosml`, or `mlton` on invoking `make` you +can select which compiler to use. The Makefile has some hacks to figure out +how to make the different compilers build everything. + +## Running + +You can build a `mal` binary from the final step with `make dist`: + +``` +$ make dist +$ ./mal +Mal [sml] +user> (map (fn* (x) (println "Odelay!")) [1 2 3 4 5]) +Odelay! +Odelay! +Odelay! +Odelay! +Odelay! +(nil nil nil nil nil) +user> +``` diff --git a/impls/sml/core.sml b/impls/sml/core.sml index cf012671cf..03eea93d07 100644 --- a/impls/sml/core.sml +++ b/impls/sml/core.sml @@ -1,205 +1,205 @@ -exception NotDefined of string -exception NotApplicable of string -exception OutOfBounds of string -exception MalException of mal_type - -(* - * Some helper functions - *) - -fun buildMap (k::v::rest) acc = buildMap rest (malAssoc acc k v) - | buildMap [] acc = malMap (rev acc) - | buildMap _ _ = raise NotApplicable "maps can only be constructed from an even number of arguments" - -fun collectLists ls = collectLists' ls [] -and collectLists' (LIST (l,_)::rest) acc = collectLists' rest (l::acc) - | collectLists' (VECTOR (v,_)::rest) acc = collectLists' rest (v::acc) - | collectLists' [] acc = rev acc - | collectLists' _ _ = raise NotApplicable "invalid arguments" - -fun arithFolder n f (INT next, INT prev) = INT (f (prev, next)) - | arithFolder n _ _ = raise NotApplicable ("'" ^ n ^ "' requires integer arguments") - -fun cmpFolder n c (INT next, (INT prev, acc)) = (INT next, acc andalso (c (prev, next))) - | cmpFolder n _ _ = raise NotApplicable ("'" ^ n ^ "' requires integer arguments") - -fun cmpFold n c (x::xs) = foldl (cmpFolder n c) (x, true) xs |> #2 |> BOOL - | cmpFold n _ _ = raise NotApplicable ("'" ^ n ^ "' requires arguments") - -fun splatArgs [LIST (l,_)] = l - | splatArgs [VECTOR (v,_)] = v - | splatArgs (x::xs) = x::(splatArgs xs) - | splatArgs [] = [] - -fun slurp lines strm = case TextIO.inputLine strm of - SOME l => slurp (l::lines) strm - | NONE => (TextIO.closeIn strm; rev lines) - -fun malPrint s = ( - TextIO.print (s ^ "\n"); - NIL -) - -fun readLine prompt = ( - TextIO.print prompt; - TextIO.inputLine TextIO.stdIn |> Option.map (trimr 1) -) - -fun strJoin separator strings = String.concatWith separator strings - -(* - * Core primitives - *) - -fun prim name f = - let val badArgs = STRING ("incorrect arguments passed to '" ^ name ^ "'") in - [SYMBOL name, FN (fn args => f args handle Domain => raise MalException badArgs, NO_META)] - end - -val coreNs = List.concat [ - - (* Maths *) - prim "+" (fn args => foldl (arithFolder "+" (op +)) (INT 0) args), - prim "*" (fn args => foldl (arithFolder "*" (op * )) (INT 1) args), - prim "/" (fn (x::xs) => foldl (arithFolder "/" (op div)) x xs | _ => raise Domain), - prim "-" (fn (x::xs) => foldl (arithFolder "-" (op -)) x xs | _ => raise Domain), - - (* Comparisons *) - prim "<" (cmpFold "<" (op <)), - prim "<=" (cmpFold "<=" (op <=)), - prim ">=" (cmpFold ">=" (op >=)), - prim ">" (cmpFold ">" (op >)), - prim "=" - (fn (x::xs) => foldl (fn (n,(p,acc)) => (n,acc andalso (malEq (n, p)))) (x, true) xs |> #2 |> BOOL - | _ => raise Domain), - - (* Predicates *) - prim "nil?" (fn [NIL] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "true?" (fn [BOOL true] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "false?" (fn [BOOL false] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "symbol?" (fn [SYMBOL _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "keyword?" (fn [KEYWORD _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "vector?" (fn [VECTOR _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "map?" (fn [MAP _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "fn?" (fn [FN _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "macro?" (fn [MACRO _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "string?" (fn [STRING _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "number?" (fn [INT _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "atom?" (fn [ATOM _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "list?" (fn [LIST _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "sequential?" - (fn [LIST _] => BOOL true | [VECTOR _] => BOOL true | [_] => BOOL false | _ => raise Domain), - prim "empty?" - (fn [LIST (l,_)] => BOOL (length l = 0) | [VECTOR (v,_)] => BOOL (length v = 0) | _ => raise Domain), - prim "contains?" - (fn [MAP (m,_), k] => BOOL (List.exists (fn (k', _) => malEq (k, k')) m) | _ => raise Domain), - - (* I/O *) - prim "slurp" - (fn [STRING filename] => TextIO.openIn filename |> slurp [] |> strJoin "" |> STRING | _ => raise Domain), - prim "prn" - (fn args => args |> map prReadableStr |> strJoin " " |> malPrint), - prim "println" - (fn args => args |> map prStr |> strJoin " " |> malPrint), - prim "readline" - (fn [STRING prompt] => valOrElse (readLine prompt |> Option.map STRING) (fn () => NIL) | _ => raise Domain), - - (* Strings and stringoids *) - prim "str" - (fn args => args |> map prStr |> strJoin "" |> STRING), - prim "pr-str" - (fn args => args |> map prReadableStr |> strJoin " " |> STRING), - prim "symbol" - (fn [STRING s] => SYMBOL s | _ => raise Domain), - prim "keyword" - (fn [STRING s] => KEYWORD s | [kw as KEYWORD _] => kw | _ => raise Domain), - - (* Atoms *) - prim "atom" (fn [x] => ATOM (ref x) | _ => raise Domain), - prim "deref" (fn [ATOM a] => !a | _ => raise Domain), - prim "reset!" (fn [ATOM a, x] => (a := x; x) | _ => raise Domain), - prim "swap!" (fn (ATOM a::(FN (f,_))::args) => let val x = f ((!a)::args) in (a := x; x) end | _ => raise Domain), - - (* Listoids *) - prim "list" (fn args => malList args), - prim "vector" (fn args => malVector (args)), - prim "vec" (fn [LIST (xs,_)] => malVector (xs) | [v as VECTOR _] => v | _ => raise Domain), - prim "concat" (fn args => malList (List.concat (collectLists args))), - prim "cons" - (fn [hd, LIST (tl,_)] => malList (hd::tl) - | [hd, VECTOR (tl,_)] => malList (hd::tl) - | _ => raise Domain), - prim "conj" - (fn (LIST (l,_)::args) => malList (rev args @ l) - | (VECTOR (v,_)::args) => malVector (v @ args) - | _ => raise Domain), - prim "seq" - (fn [LIST ([],_)] => NIL | [l as LIST _] => l - | [VECTOR ([],_)] => NIL | [VECTOR (v,_)] => malList v - | [STRING ""] => NIL | [STRING s] => String.explode s |> List.map (STRING o String.str) |> malList - | [NIL] => NIL - | _ => raise Domain), - prim "count" - (fn [LIST (l,_)] => INT (length l |> LargeInt.fromInt) - | [VECTOR (v,_)] => INT (length v |> LargeInt.fromInt) - | [NIL] => INT 0 - | _ => raise Domain), - prim "nth" - (fn [LIST (l,_), INT n] => (List.nth (l, (Int.fromLarge n)) handle Subscript => raise OutOfBounds "index out of bounds") - | [VECTOR (v,_), INT n] => (List.nth (v, (Int.fromLarge n)) handle Subscript => raise OutOfBounds "index out of bounds") - | _ => raise Domain), - prim "first" - (fn [LIST (l,_)] => (case l of (x::_) => x | _ => NIL) - | [VECTOR (v,_)] => (case v of (x::_) => x | _ => NIL) - | [NIL] => NIL - | _ => raise Domain), - prim "rest" - (fn [LIST (l,_)] => malList (case l of (_::xs) => xs | _ => []) - | [VECTOR (v,_)] => malList (case v of (_::xs) => xs | _ => []) - | [NIL] => malList ([]) - | _ => raise Domain), - prim "map" - (fn [FN (f,_), LIST (l,_)] => malList (List.map (fn x => f [x]) l) - | [FN (f,_), VECTOR (v,_)] => malList (List.map (fn x => f [x]) v) - | _ => raise Domain), - - (* Maps *) - prim "hash-map" - (fn args => buildMap args []), - prim "assoc" - (fn (MAP (m,_)::(args as _::_)) => buildMap args m | _ => raise Domain), - prim "dissoc" - (fn (MAP (m,_)::(args as _::_)) => malMap (foldl (fn (k, acc) => malDissoc acc k) m args) | _ => raise Domain), - prim "get" - (fn [MAP (m,_), k] => valOrElse (malGet m k) (fn () => NIL) | [NIL, _] => NIL | _ => raise Domain), - prim "keys" - (fn [MAP (m,_)] => malList (map #1 m) | _ => raise Domain), - prim "vals" - (fn [MAP (m,_)] => malList (map #2 m) | _ => raise Domain), - - (* Metaprogramming and metadata *) - prim "read-string" - (fn [STRING s] => readStr s | _ => raise Domain), - prim "apply" - (fn (FN (f,_)::args) => f (splatArgs args) | _ => raise Domain), - prim "meta" - (fn [ FN (_, META m)] => m - | [ LIST (_, META m)] => m - | [VECTOR (_, META m)] => m - | [ MAP (_, META m)] => m - | [_] => NIL - | _ => raise Domain), - prim "with-meta" - (fn [FN (f,_), meta] => FN (f, META meta) - | [LIST (l,_), meta] => LIST (l, META meta) - | [VECTOR (v,_), meta] => VECTOR (v, META meta) - | [MAP (m,_), meta] => MAP (m, META meta) - | [x] => x - | _ => raise Domain), - - (* Odds and ends *) - prim "throw" - (fn [x] => raise MalException x | _ => raise Domain), - prim "time-ms" - (fn _ => INT (Time.now () |> Time.toMilliseconds)) -] +exception NotDefined of string +exception NotApplicable of string +exception OutOfBounds of string +exception MalException of mal_type + +(* + * Some helper functions + *) + +fun buildMap (k::v::rest) acc = buildMap rest (malAssoc acc k v) + | buildMap [] acc = malMap (rev acc) + | buildMap _ _ = raise NotApplicable "maps can only be constructed from an even number of arguments" + +fun collectLists ls = collectLists' ls [] +and collectLists' (LIST (l,_)::rest) acc = collectLists' rest (l::acc) + | collectLists' (VECTOR (v,_)::rest) acc = collectLists' rest (v::acc) + | collectLists' [] acc = rev acc + | collectLists' _ _ = raise NotApplicable "invalid arguments" + +fun arithFolder n f (INT next, INT prev) = INT (f (prev, next)) + | arithFolder n _ _ = raise NotApplicable ("'" ^ n ^ "' requires integer arguments") + +fun cmpFolder n c (INT next, (INT prev, acc)) = (INT next, acc andalso (c (prev, next))) + | cmpFolder n _ _ = raise NotApplicable ("'" ^ n ^ "' requires integer arguments") + +fun cmpFold n c (x::xs) = foldl (cmpFolder n c) (x, true) xs |> #2 |> BOOL + | cmpFold n _ _ = raise NotApplicable ("'" ^ n ^ "' requires arguments") + +fun splatArgs [LIST (l,_)] = l + | splatArgs [VECTOR (v,_)] = v + | splatArgs (x::xs) = x::(splatArgs xs) + | splatArgs [] = [] + +fun slurp lines strm = case TextIO.inputLine strm of + SOME l => slurp (l::lines) strm + | NONE => (TextIO.closeIn strm; rev lines) + +fun malPrint s = ( + TextIO.print (s ^ "\n"); + NIL +) + +fun readLine prompt = ( + TextIO.print prompt; + TextIO.inputLine TextIO.stdIn |> Option.map (trimr 1) +) + +fun strJoin separator strings = String.concatWith separator strings + +(* + * Core primitives + *) + +fun prim name f = + let val badArgs = STRING ("incorrect arguments passed to '" ^ name ^ "'") in + [SYMBOL name, FN (fn args => f args handle Domain => raise MalException badArgs, NO_META)] + end + +val coreNs = List.concat [ + + (* Maths *) + prim "+" (fn args => foldl (arithFolder "+" (op +)) (INT 0) args), + prim "*" (fn args => foldl (arithFolder "*" (op * )) (INT 1) args), + prim "/" (fn (x::xs) => foldl (arithFolder "/" (op div)) x xs | _ => raise Domain), + prim "-" (fn (x::xs) => foldl (arithFolder "-" (op -)) x xs | _ => raise Domain), + + (* Comparisons *) + prim "<" (cmpFold "<" (op <)), + prim "<=" (cmpFold "<=" (op <=)), + prim ">=" (cmpFold ">=" (op >=)), + prim ">" (cmpFold ">" (op >)), + prim "=" + (fn (x::xs) => foldl (fn (n,(p,acc)) => (n,acc andalso (malEq (n, p)))) (x, true) xs |> #2 |> BOOL + | _ => raise Domain), + + (* Predicates *) + prim "nil?" (fn [NIL] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "true?" (fn [BOOL true] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "false?" (fn [BOOL false] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "symbol?" (fn [SYMBOL _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "keyword?" (fn [KEYWORD _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "vector?" (fn [VECTOR _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "map?" (fn [MAP _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "fn?" (fn [FN _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "macro?" (fn [MACRO _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "string?" (fn [STRING _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "number?" (fn [INT _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "atom?" (fn [ATOM _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "list?" (fn [LIST _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "sequential?" + (fn [LIST _] => BOOL true | [VECTOR _] => BOOL true | [_] => BOOL false | _ => raise Domain), + prim "empty?" + (fn [LIST (l,_)] => BOOL (length l = 0) | [VECTOR (v,_)] => BOOL (length v = 0) | _ => raise Domain), + prim "contains?" + (fn [MAP (m,_), k] => BOOL (List.exists (fn (k', _) => malEq (k, k')) m) | _ => raise Domain), + + (* I/O *) + prim "slurp" + (fn [STRING filename] => TextIO.openIn filename |> slurp [] |> strJoin "" |> STRING | _ => raise Domain), + prim "prn" + (fn args => args |> map prReadableStr |> strJoin " " |> malPrint), + prim "println" + (fn args => args |> map prStr |> strJoin " " |> malPrint), + prim "readline" + (fn [STRING prompt] => valOrElse (readLine prompt |> Option.map STRING) (fn () => NIL) | _ => raise Domain), + + (* Strings and stringoids *) + prim "str" + (fn args => args |> map prStr |> strJoin "" |> STRING), + prim "pr-str" + (fn args => args |> map prReadableStr |> strJoin " " |> STRING), + prim "symbol" + (fn [STRING s] => SYMBOL s | _ => raise Domain), + prim "keyword" + (fn [STRING s] => KEYWORD s | [kw as KEYWORD _] => kw | _ => raise Domain), + + (* Atoms *) + prim "atom" (fn [x] => ATOM (ref x) | _ => raise Domain), + prim "deref" (fn [ATOM a] => !a | _ => raise Domain), + prim "reset!" (fn [ATOM a, x] => (a := x; x) | _ => raise Domain), + prim "swap!" (fn (ATOM a::(FN (f,_))::args) => let val x = f ((!a)::args) in (a := x; x) end | _ => raise Domain), + + (* Listoids *) + prim "list" (fn args => malList args), + prim "vector" (fn args => malVector (args)), + prim "vec" (fn [LIST (xs,_)] => malVector (xs) | [v as VECTOR _] => v | _ => raise Domain), + prim "concat" (fn args => malList (List.concat (collectLists args))), + prim "cons" + (fn [hd, LIST (tl,_)] => malList (hd::tl) + | [hd, VECTOR (tl,_)] => malList (hd::tl) + | _ => raise Domain), + prim "conj" + (fn (LIST (l,_)::args) => malList (rev args @ l) + | (VECTOR (v,_)::args) => malVector (v @ args) + | _ => raise Domain), + prim "seq" + (fn [LIST ([],_)] => NIL | [l as LIST _] => l + | [VECTOR ([],_)] => NIL | [VECTOR (v,_)] => malList v + | [STRING ""] => NIL | [STRING s] => String.explode s |> List.map (STRING o String.str) |> malList + | [NIL] => NIL + | _ => raise Domain), + prim "count" + (fn [LIST (l,_)] => INT (length l |> LargeInt.fromInt) + | [VECTOR (v,_)] => INT (length v |> LargeInt.fromInt) + | [NIL] => INT 0 + | _ => raise Domain), + prim "nth" + (fn [LIST (l,_), INT n] => (List.nth (l, (Int.fromLarge n)) handle Subscript => raise OutOfBounds "index out of bounds") + | [VECTOR (v,_), INT n] => (List.nth (v, (Int.fromLarge n)) handle Subscript => raise OutOfBounds "index out of bounds") + | _ => raise Domain), + prim "first" + (fn [LIST (l,_)] => (case l of (x::_) => x | _ => NIL) + | [VECTOR (v,_)] => (case v of (x::_) => x | _ => NIL) + | [NIL] => NIL + | _ => raise Domain), + prim "rest" + (fn [LIST (l,_)] => malList (case l of (_::xs) => xs | _ => []) + | [VECTOR (v,_)] => malList (case v of (_::xs) => xs | _ => []) + | [NIL] => malList ([]) + | _ => raise Domain), + prim "map" + (fn [FN (f,_), LIST (l,_)] => malList (List.map (fn x => f [x]) l) + | [FN (f,_), VECTOR (v,_)] => malList (List.map (fn x => f [x]) v) + | _ => raise Domain), + + (* Maps *) + prim "hash-map" + (fn args => buildMap args []), + prim "assoc" + (fn (MAP (m,_)::(args as _::_)) => buildMap args m | _ => raise Domain), + prim "dissoc" + (fn (MAP (m,_)::(args as _::_)) => malMap (foldl (fn (k, acc) => malDissoc acc k) m args) | _ => raise Domain), + prim "get" + (fn [MAP (m,_), k] => valOrElse (malGet m k) (fn () => NIL) | [NIL, _] => NIL | _ => raise Domain), + prim "keys" + (fn [MAP (m,_)] => malList (map #1 m) | _ => raise Domain), + prim "vals" + (fn [MAP (m,_)] => malList (map #2 m) | _ => raise Domain), + + (* Metaprogramming and metadata *) + prim "read-string" + (fn [STRING s] => readStr s | _ => raise Domain), + prim "apply" + (fn (FN (f,_)::args) => f (splatArgs args) | _ => raise Domain), + prim "meta" + (fn [ FN (_, META m)] => m + | [ LIST (_, META m)] => m + | [VECTOR (_, META m)] => m + | [ MAP (_, META m)] => m + | [_] => NIL + | _ => raise Domain), + prim "with-meta" + (fn [FN (f,_), meta] => FN (f, META meta) + | [LIST (l,_), meta] => LIST (l, META meta) + | [VECTOR (v,_), meta] => VECTOR (v, META meta) + | [MAP (m,_), meta] => MAP (m, META meta) + | [x] => x + | _ => raise Domain), + + (* Odds and ends *) + prim "throw" + (fn [x] => raise MalException x | _ => raise Domain), + prim "time-ms" + (fn _ => INT (Time.now () |> Time.toMilliseconds)) +] diff --git a/impls/sml/env.sml b/impls/sml/env.sml index a49e0d1653..8e47ea2389 100644 --- a/impls/sml/env.sml +++ b/impls/sml/env.sml @@ -1,11 +1,11 @@ -fun set s v (NS d) = d := (s, v) :: (!d |> List.filter (not o eq s o #1)) - -fun get (NS d) s = !d |> List.find (eq s o #1) |> Option.map #2 - -fun def s v (ENV ns) = set s v ns - | def s v (INNER (ns, _)) = set s v ns - -fun lookup (ENV ns) s = get ns s - | lookup (INNER (ns, outer)) s = optOrElse (get ns s) (fn () => lookup outer s) - -fun inside outer = INNER (NS (ref []), outer) +fun set s v (NS d) = d := (s, v) :: (!d |> List.filter (not o eq s o #1)) + +fun get (NS d) s = !d |> List.find (eq s o #1) |> Option.map #2 + +fun def s v (ENV ns) = set s v ns + | def s v (INNER (ns, _)) = set s v ns + +fun lookup (ENV ns) s = get ns s + | lookup (INNER (ns, outer)) s = optOrElse (get ns s) (fn () => lookup outer s) + +fun inside outer = INNER (NS (ref []), outer) diff --git a/impls/sml/main.sml b/impls/sml/main.sml index ccd9b5d05e..e54ec639d5 100644 --- a/impls/sml/main.sml +++ b/impls/sml/main.sml @@ -1 +1 @@ -val _ = main () +val _ = main () diff --git a/impls/sml/printer.sml b/impls/sml/printer.sml index 5d5b4b3c01..40bf9321b5 100644 --- a/impls/sml/printer.sml +++ b/impls/sml/printer.sml @@ -1,22 +1,22 @@ -fun prStr NIL = "nil" - | prStr (SYMBOL s) = s - | prStr (BOOL true) = "true" - | prStr (BOOL false) = "false" - | prStr (ATOM x) = "# (" ^ (prStr (!x)) ^ ")" - | prStr (INT i) = if i >= 0 then LargeInt.toString i else "-" ^ (LargeInt.toString (LargeInt.abs i)) - | prStr (STRING s) = s - | prStr (KEYWORD s) = ":" ^ s - | prStr (LIST (l,_)) = "(" ^ (String.concatWith " " (map prStr l)) ^ ")" (* N.B. not tail recursive *) - | prStr (VECTOR (v,_)) = "[" ^ (String.concatWith " " (map prStr v)) ^ "]" (* N.B. not tail recursive *) - | prStr (MAP (m,_)) = "{" ^ (String.concatWith " " (map prKvp m)) ^ "}" (* N.B. not tail recursive *) - | prStr (FN _) = "#" - | prStr (MACRO _) = "#" -and prKvp (k, v) = (prStr k) ^ " " ^ (prStr v) - -fun prReadableStr (STRING s) = "\"" ^ (malEscape s) ^ "\"" - | prReadableStr (ATOM x) = "(atom " ^ (prReadableStr (!x)) ^ ")" - | prReadableStr (LIST (l,_)) = "(" ^ (String.concatWith " " (map prReadableStr l)) ^ ")" (* N.B. not tail recursive *) - | prReadableStr (VECTOR (v,_)) = "[" ^ (String.concatWith " " (map prReadableStr v)) ^ "]" (* N.B. not tail recursive *) - | prReadableStr (MAP (m,_)) = "{" ^ (String.concatWith " " (map prReadableKvp m)) ^ "}" (* N.B. not tail recursive *) - | prReadableStr x = prStr x -and prReadableKvp (k, v) = (prReadableStr k) ^ " " ^ (prReadableStr v) +fun prStr NIL = "nil" + | prStr (SYMBOL s) = s + | prStr (BOOL true) = "true" + | prStr (BOOL false) = "false" + | prStr (ATOM x) = "# (" ^ (prStr (!x)) ^ ")" + | prStr (INT i) = if i >= 0 then LargeInt.toString i else "-" ^ (LargeInt.toString (LargeInt.abs i)) + | prStr (STRING s) = s + | prStr (KEYWORD s) = ":" ^ s + | prStr (LIST (l,_)) = "(" ^ (String.concatWith " " (map prStr l)) ^ ")" (* N.B. not tail recursive *) + | prStr (VECTOR (v,_)) = "[" ^ (String.concatWith " " (map prStr v)) ^ "]" (* N.B. not tail recursive *) + | prStr (MAP (m,_)) = "{" ^ (String.concatWith " " (map prKvp m)) ^ "}" (* N.B. not tail recursive *) + | prStr (FN _) = "#" + | prStr (MACRO _) = "#" +and prKvp (k, v) = (prStr k) ^ " " ^ (prStr v) + +fun prReadableStr (STRING s) = "\"" ^ (malEscape s) ^ "\"" + | prReadableStr (ATOM x) = "(atom " ^ (prReadableStr (!x)) ^ ")" + | prReadableStr (LIST (l,_)) = "(" ^ (String.concatWith " " (map prReadableStr l)) ^ ")" (* N.B. not tail recursive *) + | prReadableStr (VECTOR (v,_)) = "[" ^ (String.concatWith " " (map prReadableStr v)) ^ "]" (* N.B. not tail recursive *) + | prReadableStr (MAP (m,_)) = "{" ^ (String.concatWith " " (map prReadableKvp m)) ^ "}" (* N.B. not tail recursive *) + | prReadableStr x = prStr x +and prReadableKvp (k, v) = (prReadableStr k) ^ " " ^ (prReadableStr v) diff --git a/impls/sml/reader.sml b/impls/sml/reader.sml index 791fb68f59..ccac9b61dc 100644 --- a/impls/sml/reader.sml +++ b/impls/sml/reader.sml @@ -1,161 +1,161 @@ -exception Nothing -exception SyntaxError of string -exception ReaderError of string - -structure Ss = Substring - -datatype token = - SPACE - | COMMENT of string - | BRACKET_LEFT | BRACKET_RIGHT - | BRACE_LEFT | BRACE_RIGHT - | PAREN_LEFT | PAREN_RIGHT - | QUOTE | BACK_TICK | TILDE | TILDE_AT - | CARET - | AT - | LIT_ATOM of string - | LIT_STR of string - -fun tokenString SPACE = "SPACE" - | tokenString (COMMENT s) = "COMMENT (" ^ s ^ ")" - | tokenString BRACKET_LEFT = "BRACKET_LEFT" - | tokenString BRACKET_RIGHT = "BRACKET_RIGHT" - | tokenString BRACE_LEFT = "BRACE_LEFT" - | tokenString BRACE_RIGHT = "BRACE_RIGHT" - | tokenString PAREN_LEFT = "PAREN_LEFT" - | tokenString PAREN_RIGHT = "PAREN_RIGHT" - | tokenString QUOTE = "QUOTE" - | tokenString BACK_TICK = "BACK_TICK" - | tokenString TILDE = "TILDE" - | tokenString TILDE_AT = "TILDE_AT" - | tokenString CARET = "CARET" - | tokenString AT = "AT" - | tokenString (LIT_ATOM s) = "LIT_ATOM (" ^ s ^ ")" - | tokenString (LIT_STR s) = "LIT_STR \"" ^ s ^ "\"" - -datatype reader = READER of token list - -fun next (READER (x::xs)) = SOME (x, READER xs) - | next r = NONE - -fun peek (READER (x::_)) = SOME x - | peek r = NONE - -fun rest (READER (_::xs)) = READER xs - | rest r = raise ReaderError "out of tokens" - -fun findSpecial #"[" = SOME BRACKET_LEFT - | findSpecial #"]" = SOME BRACKET_RIGHT - | findSpecial #"(" = SOME PAREN_LEFT - | findSpecial #")" = SOME PAREN_RIGHT - | findSpecial #"{" = SOME BRACE_LEFT - | findSpecial #"}" = SOME BRACE_RIGHT - | findSpecial #"'" = SOME QUOTE - | findSpecial #"`" = SOME BACK_TICK - | findSpecial #"~" = SOME TILDE - | findSpecial #"^" = SOME CARET - | findSpecial #"@" = SOME AT - | findSpecial _ = NONE - -fun scanSpace ss = - let fun isSpace c = Char.isSpace c orelse c = #"," - val (tok, rest) = Ss.splitl isSpace ss in - if Ss.isEmpty tok then NONE else SOME (SPACE, rest) - end - -fun scanComment ss = case Ss.getc ss of - SOME (#";", rest) => - let val (comment, rest) = Ss.splitl (fn (c) => c <> #"\n") rest in - SOME (COMMENT (Ss.string comment), rest) - end - | _ => NONE - -fun scanSpecial ss = - if Ss.isPrefix "~@" ss - then SOME (TILDE_AT, Ss.slice (ss, 2, NONE)) - else let fun findToken (c, rest) = findSpecial c |> Option.map (fn t => (t, rest)) in - Option.composePartial (findToken, Ss.getc) ss - end - -fun scanString ss = - Ss.getc ss |> Option.mapPartial (fn (#"\"", rest) => spanString rest rest | _ => NONE) - -and spanString from to = case Ss.getc to of - SOME (#"\\", rest) => Ss.getc rest |> Option.mapPartial (fn (_, more) => spanString from more) - | SOME (#"\"", rest) => SOME (LIT_STR (spanString' from to), rest) - | SOME (_, rest) => spanString from rest - | NONE => raise SyntaxError "end of input reached when parsing string literal" -and spanString' from stop = - Ss.span (from, Ss.slice (stop, 0, SOME 0)) |> Ss.string - -fun scanAtom ss = - let fun isAtomChar c = Char.isGraph c andalso (findSpecial c = NONE) - val (tok, rest) = Ss.splitl isAtomChar ss in - if Ss.isEmpty tok then NONE else SOME (LIT_ATOM (Ss.string tok), rest) - end - -fun scanToken ss = - let val scanners = [scanSpace, scanComment, scanSpecial, scanString, scanAtom] - val findScanner = List.find (fn f => isSome (f ss)) - fun applyScanner s = s ss - in - Option.composePartial (applyScanner, findScanner) scanners - end - -fun tokenize s = tokenize' [] (Ss.full s) -and tokenize' acc ss = case scanToken ss of - SOME (token, rest) => tokenize' (token::acc) rest - | NONE => rev acc - -fun readAtom r = case next r of - SOME (LIT_ATOM "nil", r') => (NIL, r') - | SOME (LIT_ATOM "true", r') => (BOOL true, r') - | SOME (LIT_ATOM "false", r') => (BOOL false, r') - | SOME (LIT_ATOM s, r') => (LargeInt.fromString s |> Option.map INT - |> optIfNone (fn () => Option.filter (String.isPrefix ":") s |> Option.map (KEYWORD o (triml 1))) - |> valIfNone (fn () => SYMBOL s), r') - | SOME (LIT_STR s, r') => (malUnescape s |> STRING, r') - | SOME (CARET, r') => readWithMeta r' - | SOME (token, _) => raise SyntaxError ("unexpected token reading atom: " ^ (tokenString token)) - | NONE => raise SyntaxError "end of input reached when reading atom" - -and readForm r = case peek r of - SOME PAREN_LEFT => readList [] (rest r) - | SOME BRACKET_LEFT => readVector [] (rest r) - | SOME BRACE_LEFT => readMap [] (rest r) - | SOME AT => let val (a, r') = readAtom (rest r) in (malList [SYMBOL "deref", a], r') end - | SOME QUOTE => let val (a, r') = readForm (rest r) in (malList [SYMBOL "quote", a], r') end - | SOME BACK_TICK => let val (a, r') = readForm (rest r) in (malList [SYMBOL "quasiquote", a], r') end - | SOME TILDE => let val (a, r') = readForm (rest r) in (malList [SYMBOL "unquote", a], r') end - | SOME TILDE_AT => let val (a, r') = readForm (rest r) in (malList [SYMBOL "splice-unquote", a], r') end - | _ => readAtom r - -and readWithMeta r = - let val (m, r') = readForm r - val (v, r'') = readForm r' - in - (malList [SYMBOL "with-meta", v, m], r'') - end - -and readList acc r = - if peek r = SOME PAREN_RIGHT - then (LIST (rev acc, NO_META), (rest r)) - else let val (a, r') = readForm r in readList (a::acc) r' end - -and readVector acc r = - if peek r = SOME BRACKET_RIGHT - then (VECTOR (rev acc, NO_META), (rest r)) - else let val (a, r') = readForm r in readVector (a::acc) r' end - -and readMap acc r = - if peek r = SOME BRACE_RIGHT - then (MAP (rev acc, NO_META), (rest r)) - else let val (k, r') = readForm r val (v, r'') = readForm r' in readMap (malAssoc acc k v) r'' end - -fun clean ts = - ts |> List.filter (fn x => x <> SPACE) - |> List.filter (fn COMMENT _ => false | _ => true) - -fun readStr s = case tokenize s |> clean of - [] => raise Nothing - | ts => ts |> READER |> readForm |> #1 +exception Nothing +exception SyntaxError of string +exception ReaderError of string + +structure Ss = Substring + +datatype token = + SPACE + | COMMENT of string + | BRACKET_LEFT | BRACKET_RIGHT + | BRACE_LEFT | BRACE_RIGHT + | PAREN_LEFT | PAREN_RIGHT + | QUOTE | BACK_TICK | TILDE | TILDE_AT + | CARET + | AT + | LIT_ATOM of string + | LIT_STR of string + +fun tokenString SPACE = "SPACE" + | tokenString (COMMENT s) = "COMMENT (" ^ s ^ ")" + | tokenString BRACKET_LEFT = "BRACKET_LEFT" + | tokenString BRACKET_RIGHT = "BRACKET_RIGHT" + | tokenString BRACE_LEFT = "BRACE_LEFT" + | tokenString BRACE_RIGHT = "BRACE_RIGHT" + | tokenString PAREN_LEFT = "PAREN_LEFT" + | tokenString PAREN_RIGHT = "PAREN_RIGHT" + | tokenString QUOTE = "QUOTE" + | tokenString BACK_TICK = "BACK_TICK" + | tokenString TILDE = "TILDE" + | tokenString TILDE_AT = "TILDE_AT" + | tokenString CARET = "CARET" + | tokenString AT = "AT" + | tokenString (LIT_ATOM s) = "LIT_ATOM (" ^ s ^ ")" + | tokenString (LIT_STR s) = "LIT_STR \"" ^ s ^ "\"" + +datatype reader = READER of token list + +fun next (READER (x::xs)) = SOME (x, READER xs) + | next r = NONE + +fun peek (READER (x::_)) = SOME x + | peek r = NONE + +fun rest (READER (_::xs)) = READER xs + | rest r = raise ReaderError "out of tokens" + +fun findSpecial #"[" = SOME BRACKET_LEFT + | findSpecial #"]" = SOME BRACKET_RIGHT + | findSpecial #"(" = SOME PAREN_LEFT + | findSpecial #")" = SOME PAREN_RIGHT + | findSpecial #"{" = SOME BRACE_LEFT + | findSpecial #"}" = SOME BRACE_RIGHT + | findSpecial #"'" = SOME QUOTE + | findSpecial #"`" = SOME BACK_TICK + | findSpecial #"~" = SOME TILDE + | findSpecial #"^" = SOME CARET + | findSpecial #"@" = SOME AT + | findSpecial _ = NONE + +fun scanSpace ss = + let fun isSpace c = Char.isSpace c orelse c = #"," + val (tok, rest) = Ss.splitl isSpace ss in + if Ss.isEmpty tok then NONE else SOME (SPACE, rest) + end + +fun scanComment ss = case Ss.getc ss of + SOME (#";", rest) => + let val (comment, rest) = Ss.splitl (fn (c) => c <> #"\n") rest in + SOME (COMMENT (Ss.string comment), rest) + end + | _ => NONE + +fun scanSpecial ss = + if Ss.isPrefix "~@" ss + then SOME (TILDE_AT, Ss.slice (ss, 2, NONE)) + else let fun findToken (c, rest) = findSpecial c |> Option.map (fn t => (t, rest)) in + Option.composePartial (findToken, Ss.getc) ss + end + +fun scanString ss = + Ss.getc ss |> Option.mapPartial (fn (#"\"", rest) => spanString rest rest | _ => NONE) + +and spanString from to = case Ss.getc to of + SOME (#"\\", rest) => Ss.getc rest |> Option.mapPartial (fn (_, more) => spanString from more) + | SOME (#"\"", rest) => SOME (LIT_STR (spanString' from to), rest) + | SOME (_, rest) => spanString from rest + | NONE => raise SyntaxError "end of input reached when parsing string literal" +and spanString' from stop = + Ss.span (from, Ss.slice (stop, 0, SOME 0)) |> Ss.string + +fun scanAtom ss = + let fun isAtomChar c = Char.isGraph c andalso (findSpecial c = NONE) + val (tok, rest) = Ss.splitl isAtomChar ss in + if Ss.isEmpty tok then NONE else SOME (LIT_ATOM (Ss.string tok), rest) + end + +fun scanToken ss = + let val scanners = [scanSpace, scanComment, scanSpecial, scanString, scanAtom] + val findScanner = List.find (fn f => isSome (f ss)) + fun applyScanner s = s ss + in + Option.composePartial (applyScanner, findScanner) scanners + end + +fun tokenize s = tokenize' [] (Ss.full s) +and tokenize' acc ss = case scanToken ss of + SOME (token, rest) => tokenize' (token::acc) rest + | NONE => rev acc + +fun readAtom r = case next r of + SOME (LIT_ATOM "nil", r') => (NIL, r') + | SOME (LIT_ATOM "true", r') => (BOOL true, r') + | SOME (LIT_ATOM "false", r') => (BOOL false, r') + | SOME (LIT_ATOM s, r') => (LargeInt.fromString s |> Option.map INT + |> optIfNone (fn () => Option.filter (String.isPrefix ":") s |> Option.map (KEYWORD o (triml 1))) + |> valIfNone (fn () => SYMBOL s), r') + | SOME (LIT_STR s, r') => (malUnescape s |> STRING, r') + | SOME (CARET, r') => readWithMeta r' + | SOME (token, _) => raise SyntaxError ("unexpected token reading atom: " ^ (tokenString token)) + | NONE => raise SyntaxError "end of input reached when reading atom" + +and readForm r = case peek r of + SOME PAREN_LEFT => readList [] (rest r) + | SOME BRACKET_LEFT => readVector [] (rest r) + | SOME BRACE_LEFT => readMap [] (rest r) + | SOME AT => let val (a, r') = readAtom (rest r) in (malList [SYMBOL "deref", a], r') end + | SOME QUOTE => let val (a, r') = readForm (rest r) in (malList [SYMBOL "quote", a], r') end + | SOME BACK_TICK => let val (a, r') = readForm (rest r) in (malList [SYMBOL "quasiquote", a], r') end + | SOME TILDE => let val (a, r') = readForm (rest r) in (malList [SYMBOL "unquote", a], r') end + | SOME TILDE_AT => let val (a, r') = readForm (rest r) in (malList [SYMBOL "splice-unquote", a], r') end + | _ => readAtom r + +and readWithMeta r = + let val (m, r') = readForm r + val (v, r'') = readForm r' + in + (malList [SYMBOL "with-meta", v, m], r'') + end + +and readList acc r = + if peek r = SOME PAREN_RIGHT + then (LIST (rev acc, NO_META), (rest r)) + else let val (a, r') = readForm r in readList (a::acc) r' end + +and readVector acc r = + if peek r = SOME BRACKET_RIGHT + then (VECTOR (rev acc, NO_META), (rest r)) + else let val (a, r') = readForm r in readVector (a::acc) r' end + +and readMap acc r = + if peek r = SOME BRACE_RIGHT + then (MAP (rev acc, NO_META), (rest r)) + else let val (k, r') = readForm r val (v, r'') = readForm r' in readMap (malAssoc acc k v) r'' end + +fun clean ts = + ts |> List.filter (fn x => x <> SPACE) + |> List.filter (fn COMMENT _ => false | _ => true) + +fun readStr s = case tokenize s |> clean of + [] => raise Nothing + | ts => ts |> READER |> readForm |> #1 diff --git a/impls/sml/run b/impls/sml/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/sml/run +++ b/impls/sml/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/sml/step0_repl.mlb b/impls/sml/step0_repl.mlb index 613311cb56..1ba8fed98e 100644 --- a/impls/sml/step0_repl.mlb +++ b/impls/sml/step0_repl.mlb @@ -1,6 +1,6 @@ -local - $(SML_LIB)/basis/basis.mlb - step0_repl.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + step0_repl.sml +in + main.sml +end diff --git a/impls/sml/step0_repl.sml b/impls/sml/step0_repl.sml index 3485ec9b98..882b27c526 100644 --- a/impls/sml/step0_repl.sml +++ b/impls/sml/step0_repl.sml @@ -1,25 +1,25 @@ -fun read s: string = - s - -fun eval s: string = - s - -fun print s: string = - s - -fun rep s: string = - (print o eval o read) s - -fun repl () = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => ( - print(rep(line) ^ "\n"); - repl () - ) - | NONE => () - ) end - -fun main () = repl () +fun read s: string = + s + +fun eval s: string = + s + +fun print s: string = + s + +fun rep s: string = + (print o eval o read) s + +fun repl () = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => ( + print(rep(line) ^ "\n"); + repl () + ) + | NONE => () + ) end + +fun main () = repl () diff --git a/impls/sml/step1_read_print.mlb b/impls/sml/step1_read_print.mlb index 20927d5e7e..27edb268a1 100644 --- a/impls/sml/step1_read_print.mlb +++ b/impls/sml/step1_read_print.mlb @@ -1,10 +1,10 @@ -local - $(SML_LIB)/basis/basis.mlb - util.sml - types.sml - printer.sml - reader.sml - step1_read_print.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + step1_read_print.sml +in + main.sml +end diff --git a/impls/sml/step1_read_print.sml b/impls/sml/step1_read_print.sml index 1b47c0692e..eb54e2c8cb 100644 --- a/impls/sml/step1_read_print.sml +++ b/impls/sml/step1_read_print.sml @@ -1,27 +1,27 @@ -fun read s = - readStr s - -fun eval f = - f - -fun print f = - prReadableStr f - -fun rep s = - s |> read |> eval |> print - handle SyntaxError msg => "SYNTAX ERROR: " ^ msg - | Nothing => "" - -fun repl () = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => ( - print(rep(line) ^ "\n"); - repl () - ) - | NONE => () - ) end - -fun main () = repl () +fun read s = + readStr s + +fun eval f = + f + +fun print f = + prReadableStr f + +fun rep s = + s |> read |> eval |> print + handle SyntaxError msg => "SYNTAX ERROR: " ^ msg + | Nothing => "" + +fun repl () = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => ( + print(rep(line) ^ "\n"); + repl () + ) + | NONE => () + ) end + +fun main () = repl () diff --git a/impls/sml/step2_eval.mlb b/impls/sml/step2_eval.mlb index c07441f343..4e3d7f537d 100644 --- a/impls/sml/step2_eval.mlb +++ b/impls/sml/step2_eval.mlb @@ -1,11 +1,11 @@ -local - $(SML_LIB)/basis/basis.mlb - util.sml - types.sml - printer.sml - reader.sml - env.sml - step2_eval.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + env.sml + step2_eval.sml +in + main.sml +end diff --git a/impls/sml/step2_eval.sml b/impls/sml/step2_eval.sml index fa62f51892..9dfadb6f48 100644 --- a/impls/sml/step2_eval.sml +++ b/impls/sml/step2_eval.sml @@ -1,68 +1,68 @@ -exception NotDefined of string -exception NotApplicable of string - -fun read s = - readStr s - -fun eval e ast = case ast of - LIST (_::_,_) => evalApply e ast - | _ => evalAst e ast - -and evalAst e ast = case ast of - SYMBOL s => (case lookup e s of SOME v => v | NONE => raise NotDefined ("unable to resolve symbol '" ^ s ^ "'")) - | LIST (l,_) => LIST (List.map (eval e) l, NO_META) - | VECTOR (v,_) => VECTOR (List.map (eval e) v, NO_META) - | MAP (m,_) => MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) - | _ => ast - -and evalApply e ast = case evalAst e ast of - LIST ((FN (f,_))::args, _) => f args - | _ => raise NotApplicable "eval_apply needs a non-empty list" - -fun print f = - prReadableStr f - -fun rep e s = - s |> read |> eval e |> print - handle Nothing => "" - | e => "ERROR: " ^ (exnMessage e) - -fun malPlus (INT a, INT b) = INT (a + b) - | malPlus _ = raise NotApplicable "can only add integers" -fun malTimes (INT a, INT b) = INT (a * b) - | malTimes _ = raise NotApplicable "can only multiply integers" -fun malMinus (INT b, INT a) = INT (a - b) - | malMinus _ = raise NotApplicable "can only subtract integers" -fun malDiv (INT b, INT a) = INT (a div b) - | malDiv _ = raise NotApplicable "can only divide integers" - -val replEnv = ENV (NS (ref [ - ("+", FN (foldl malPlus (INT 0), NO_META)), - ("*", FN (foldl malTimes (INT 1), NO_META)), - ("-", FN ( - fn [x] => malMinus (x, INT 0) - | x::xs => foldr malMinus x xs - | _ => raise NotApplicable "'-' requires at least one argument" - , NO_META - )), - ("/", FN ( - fn [x] => malDiv (x, INT 1) - | x::xs => foldr malDiv x xs - | _ => raise NotApplicable "'/' requires at least one argument" - , NO_META - )) -])) - -fun repl () = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => ( - print((rep replEnv line) ^ "\n"); - repl () - ) - | NONE => () - ) end - -fun main () = repl () +exception NotDefined of string +exception NotApplicable of string + +fun read s = + readStr s + +fun eval e ast = case ast of + LIST (_::_,_) => evalApply e ast + | _ => evalAst e ast + +and evalAst e ast = case ast of + SYMBOL s => (case lookup e s of SOME v => v | NONE => raise NotDefined ("unable to resolve symbol '" ^ s ^ "'")) + | LIST (l,_) => LIST (List.map (eval e) l, NO_META) + | VECTOR (v,_) => VECTOR (List.map (eval e) v, NO_META) + | MAP (m,_) => MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) + | _ => ast + +and evalApply e ast = case evalAst e ast of + LIST ((FN (f,_))::args, _) => f args + | _ => raise NotApplicable "eval_apply needs a non-empty list" + +fun print f = + prReadableStr f + +fun rep e s = + s |> read |> eval e |> print + handle Nothing => "" + | e => "ERROR: " ^ (exnMessage e) + +fun malPlus (INT a, INT b) = INT (a + b) + | malPlus _ = raise NotApplicable "can only add integers" +fun malTimes (INT a, INT b) = INT (a * b) + | malTimes _ = raise NotApplicable "can only multiply integers" +fun malMinus (INT b, INT a) = INT (a - b) + | malMinus _ = raise NotApplicable "can only subtract integers" +fun malDiv (INT b, INT a) = INT (a div b) + | malDiv _ = raise NotApplicable "can only divide integers" + +val replEnv = ENV (NS (ref [ + ("+", FN (foldl malPlus (INT 0), NO_META)), + ("*", FN (foldl malTimes (INT 1), NO_META)), + ("-", FN ( + fn [x] => malMinus (x, INT 0) + | x::xs => foldr malMinus x xs + | _ => raise NotApplicable "'-' requires at least one argument" + , NO_META + )), + ("/", FN ( + fn [x] => malDiv (x, INT 1) + | x::xs => foldr malDiv x xs + | _ => raise NotApplicable "'/' requires at least one argument" + , NO_META + )) +])) + +fun repl () = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => ( + print((rep replEnv line) ^ "\n"); + repl () + ) + | NONE => () + ) end + +fun main () = repl () diff --git a/impls/sml/step3_env.mlb b/impls/sml/step3_env.mlb index a51484a27f..569ea94ef7 100644 --- a/impls/sml/step3_env.mlb +++ b/impls/sml/step3_env.mlb @@ -1,11 +1,11 @@ -local - $(SML_LIB)/basis/basis.mlb - util.sml - types.sml - printer.sml - reader.sml - env.sml - step3_env.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + env.sml + step3_env.sml +in + main.sml +end diff --git a/impls/sml/step3_env.sml b/impls/sml/step3_env.sml index ae8a172a40..edc1c6cc43 100644 --- a/impls/sml/step3_env.sml +++ b/impls/sml/step3_env.sml @@ -1,84 +1,84 @@ -exception NotDefined of string -exception NotApplicable of string - -fun read s = - readStr s - -fun eval e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) - | eval e (SYMBOL s) = evalSymbol e s - | eval e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) - | eval e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) - | eval e ast = ast - -and specialEval (SYMBOL "def!") = SOME evalDef - | specialEval (SYMBOL "let*") = SOME evalLet - | specialEval _ = NONE - -and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end - | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" - -and evalLet e [LIST (bs,_), ast] = eval (bind bs (inside e)) ast - | evalLet e [VECTOR (bs,_), ast] = eval (bind bs (inside e)) ast - | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" - -and evalApply e (FN (f,_)) args = f (map (eval e) args) - | evalApply _ a args = raise NotApplicable (prStr a ^ " is not applicable on " ^ prStr (LIST (args, NO_META))) - -and evalSymbol e s = valOrElse (lookup e s) - (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) - -and bind (SYMBOL s::v::rest) e = (def s (eval e v) e; bind rest e) - | bind [] e = e - | bind _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" - -fun print f = - prReadableStr f - -fun rep e s = - s |> read |> eval e |> print - handle Nothing => "" - | SyntaxError msg => "SYNTAX ERROR: " ^ msg - | NotApplicable msg => "CANNOT APPLY: " ^ msg - | NotDefined msg => "NOT DEFINED: " ^ msg - -fun malPlus (INT a, INT b) = INT (a + b) - | malPlus _ = raise NotApplicable "can only add integers" -fun malTimes (INT a, INT b) = INT (a * b) - | malTimes _ = raise NotApplicable "can only multiply integers" -fun malMinus (INT b, INT a) = INT (a - b) - | malMinus _ = raise NotApplicable "can only subtract integers" -fun malDiv (INT b, INT a) = INT (a div b) - | malDiv _ = raise NotApplicable "can only divide integers" - -val replEnv = ENV (NS (ref [])) |> bind [ - SYMBOL "+", - FN (foldl malPlus (INT 0), NO_META), - SYMBOL "*", - FN (foldl malTimes (INT 1), NO_META), - SYMBOL "-", - FN (fn [x] => malMinus (x, INT 0) - | x::xs => foldr malMinus x xs - | _ => raise NotApplicable "'-' requires arguments" - , NO_META), - SYMBOL "/", - FN (fn [x] => malDiv (x, INT 1) - | x::xs => foldr malDiv x xs - | _ => raise NotApplicable "'/' requires arguments" - , NO_META) -] - -fun repl e = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => - let val s = rep e line - val _ = print(s ^ "\n") - in - repl e - end - | NONE => () - ) end - -fun main () = repl replEnv +exception NotDefined of string +exception NotApplicable of string + +fun read s = + readStr s + +fun eval e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) + | eval e (SYMBOL s) = evalSymbol e s + | eval e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) + | eval e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) + | eval e ast = ast + +and specialEval (SYMBOL "def!") = SOME evalDef + | specialEval (SYMBOL "let*") = SOME evalLet + | specialEval _ = NONE + +and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end + | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" + +and evalLet e [LIST (bs,_), ast] = eval (bind bs (inside e)) ast + | evalLet e [VECTOR (bs,_), ast] = eval (bind bs (inside e)) ast + | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" + +and evalApply e (FN (f,_)) args = f (map (eval e) args) + | evalApply _ a args = raise NotApplicable (prStr a ^ " is not applicable on " ^ prStr (LIST (args, NO_META))) + +and evalSymbol e s = valOrElse (lookup e s) + (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) + +and bind (SYMBOL s::v::rest) e = (def s (eval e v) e; bind rest e) + | bind [] e = e + | bind _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" + +fun print f = + prReadableStr f + +fun rep e s = + s |> read |> eval e |> print + handle Nothing => "" + | SyntaxError msg => "SYNTAX ERROR: " ^ msg + | NotApplicable msg => "CANNOT APPLY: " ^ msg + | NotDefined msg => "NOT DEFINED: " ^ msg + +fun malPlus (INT a, INT b) = INT (a + b) + | malPlus _ = raise NotApplicable "can only add integers" +fun malTimes (INT a, INT b) = INT (a * b) + | malTimes _ = raise NotApplicable "can only multiply integers" +fun malMinus (INT b, INT a) = INT (a - b) + | malMinus _ = raise NotApplicable "can only subtract integers" +fun malDiv (INT b, INT a) = INT (a div b) + | malDiv _ = raise NotApplicable "can only divide integers" + +val replEnv = ENV (NS (ref [])) |> bind [ + SYMBOL "+", + FN (foldl malPlus (INT 0), NO_META), + SYMBOL "*", + FN (foldl malTimes (INT 1), NO_META), + SYMBOL "-", + FN (fn [x] => malMinus (x, INT 0) + | x::xs => foldr malMinus x xs + | _ => raise NotApplicable "'-' requires arguments" + , NO_META), + SYMBOL "/", + FN (fn [x] => malDiv (x, INT 1) + | x::xs => foldr malDiv x xs + | _ => raise NotApplicable "'/' requires arguments" + , NO_META) +] + +fun repl e = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => + let val s = rep e line + val _ = print(s ^ "\n") + in + repl e + end + | NONE => () + ) end + +fun main () = repl replEnv diff --git a/impls/sml/step4_if_fn_do.mlb b/impls/sml/step4_if_fn_do.mlb index 5df0c8adab..3d4a8f3df5 100644 --- a/impls/sml/step4_if_fn_do.mlb +++ b/impls/sml/step4_if_fn_do.mlb @@ -1,12 +1,12 @@ -local - $(SML_LIB)/basis/basis.mlb - util.sml - types.sml - printer.sml - reader.sml - env.sml - core.sml - step4_if_fn_do.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + env.sml + core.sml + step4_if_fn_do.sml +in + main.sml +end diff --git a/impls/sml/step4_if_fn_do.sml b/impls/sml/step4_if_fn_do.sml index 7510cda118..11e0e7b86f 100644 --- a/impls/sml/step4_if_fn_do.sml +++ b/impls/sml/step4_if_fn_do.sml @@ -1,82 +1,82 @@ -fun read s = - readStr s - -fun eval e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) - | eval e (SYMBOL s) = evalSymbol e s - | eval e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) - | eval e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) - | eval e ast = ast - -and specialEval (SYMBOL "def!") = SOME evalDef - | specialEval (SYMBOL "let*") = SOME evalLet - | specialEval (SYMBOL "do") = SOME evalDo - | specialEval (SYMBOL "if") = SOME evalIf - | specialEval (SYMBOL "fn*") = SOME evalFn - | specialEval _ = NONE - -and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end - | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" - -and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" - -and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs - | evalDo _ _ = raise NotApplicable "do needs at least one argument" - -and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b - | evalIf e [c,a] = evalIf e [c,a,NIL] - | evalIf _ _ = raise NotApplicable "if needs two or three arguments" - -and evalFn e [LIST (binds,_),body] = makeFn e binds body - | evalFn e [VECTOR (binds,_),body] = makeFn e binds body - | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" -and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) - -and evalApply e (FN (f,_)) args = f (map (eval e) args) - | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (LIST (args, NO_META))) - -and evalSymbol e s = valOrElse (lookup e s) - (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) - -and bindLet args e = bind' (eval e) args e -and bind args e = bind' identity args e -and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (LIST (map evl (v::vs), NO_META)) e; e) - | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (LIST ([], NO_META)) e; e) - | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) - | bind' _ [] e = e - | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" - -fun print f = - prReadableStr f - -fun rep e s = - s |> read |> eval e |> print - handle Nothing => "" - | SyntaxError msg => "SYNTAX ERROR: " ^ msg - | NotApplicable msg => "CANNOT APPLY: " ^ msg - | NotDefined msg => "NOT DEFINED: " ^ msg - -val replEnv = ENV (NS (ref [])) |> bind coreNs - -fun repl e = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => - let val s = rep e line - val _ = print(s ^ "\n") - in - repl e - end - | NONE => () - ) end - -val prelude = " \ -\(def! not (fn* (a) (if a false true)))" - -fun main () = ( - rep replEnv ("(do " ^ prelude ^ " nil)"); - repl replEnv -) +fun read s = + readStr s + +fun eval e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) + | eval e (SYMBOL s) = evalSymbol e s + | eval e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) + | eval e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) + | eval e ast = ast + +and specialEval (SYMBOL "def!") = SOME evalDef + | specialEval (SYMBOL "let*") = SOME evalLet + | specialEval (SYMBOL "do") = SOME evalDo + | specialEval (SYMBOL "if") = SOME evalIf + | specialEval (SYMBOL "fn*") = SOME evalFn + | specialEval _ = NONE + +and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end + | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" + +and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" + +and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs + | evalDo _ _ = raise NotApplicable "do needs at least one argument" + +and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b + | evalIf e [c,a] = evalIf e [c,a,NIL] + | evalIf _ _ = raise NotApplicable "if needs two or three arguments" + +and evalFn e [LIST (binds,_),body] = makeFn e binds body + | evalFn e [VECTOR (binds,_),body] = makeFn e binds body + | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" +and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) + +and evalApply e (FN (f,_)) args = f (map (eval e) args) + | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (LIST (args, NO_META))) + +and evalSymbol e s = valOrElse (lookup e s) + (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) + +and bindLet args e = bind' (eval e) args e +and bind args e = bind' identity args e +and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (LIST (map evl (v::vs), NO_META)) e; e) + | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (LIST ([], NO_META)) e; e) + | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) + | bind' _ [] e = e + | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" + +fun print f = + prReadableStr f + +fun rep e s = + s |> read |> eval e |> print + handle Nothing => "" + | SyntaxError msg => "SYNTAX ERROR: " ^ msg + | NotApplicable msg => "CANNOT APPLY: " ^ msg + | NotDefined msg => "NOT DEFINED: " ^ msg + +val replEnv = ENV (NS (ref [])) |> bind coreNs + +fun repl e = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => + let val s = rep e line + val _ = print(s ^ "\n") + in + repl e + end + | NONE => () + ) end + +val prelude = " \ +\(def! not (fn* (a) (if a false true)))" + +fun main () = ( + rep replEnv ("(do " ^ prelude ^ " nil)"); + repl replEnv +) diff --git a/impls/sml/step6_file.mlb b/impls/sml/step6_file.mlb index d8f6730653..8241e635b8 100644 --- a/impls/sml/step6_file.mlb +++ b/impls/sml/step6_file.mlb @@ -1,12 +1,12 @@ -local - $(SML_LIB)/basis/basis.mlb - util.sml - types.sml - printer.sml - reader.sml - env.sml - core.sml - step6_file.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + env.sml + core.sml + step6_file.sml +in + main.sml +end diff --git a/impls/sml/step6_file.sml b/impls/sml/step6_file.sml index a4db2a40be..860b384e7b 100644 --- a/impls/sml/step6_file.sml +++ b/impls/sml/step6_file.sml @@ -1,100 +1,100 @@ -fun read s = - readStr s - -fun eval e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) - | eval e (SYMBOL s) = evalSymbol e s - | eval e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) - | eval e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) - | eval e ast = ast - -and specialEval (SYMBOL "def!") = SOME evalDef - | specialEval (SYMBOL "let*") = SOME evalLet - | specialEval (SYMBOL "do") = SOME evalDo - | specialEval (SYMBOL "if") = SOME evalIf - | specialEval (SYMBOL "fn*") = SOME evalFn - | specialEval _ = NONE - -and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end - | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" - -and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" - -and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs - | evalDo _ _ = raise NotApplicable "do needs at least one argument" - -and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b - | evalIf e [c,a] = evalIf e [c,a,NIL] - | evalIf _ _ = raise NotApplicable "if needs two or three arguments" - -and evalFn e [LIST (binds,_),body] = makeFn e binds body - | evalFn e [VECTOR (binds,_),body] = makeFn e binds body - | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" -and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) - -and evalApply e (FN (f,_)) args = f (map (eval e) args) - | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (LIST (args, NO_META))) - -and evalSymbol e s = valOrElse (lookup e s) - (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) - -and bindLet args e = bind' (eval e) args e -and bind args e = bind' identity args e -and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (LIST (map evl (v::vs), NO_META)) e; e) - | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (LIST ([], NO_META)) e; e) - | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) - | bind' _ [] e = e - | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" - -fun print f = - prReadableStr f - -fun rep e s = - s |> read |> eval e |> print - handle Nothing => "" - | SyntaxError msg => "SYNTAX ERROR: " ^ msg - | NotApplicable msg => "CANNOT APPLY: " ^ msg - | NotDefined msg => "NOT DEFINED: " ^ msg - -val replEnv = ENV (NS (ref [])) |> bind coreNs - -fun repl e = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => - let val s = rep e line - val _ = print(s ^ "\n") - in - repl e - end - | NONE => () - ) end - -val prelude = " \ -\(def! not (fn* (a) (if a false true))) \ -\(def! \ -\ load-file \ -\ (fn* (f) \ -\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - -fun main () = ( - bind [ - SYMBOL "eval", - FN (fn ([x]) => eval replEnv x - | _ => raise NotApplicable "'eval' requires one argument", NO_META) - ] replEnv; - rep replEnv ("(do " ^ prelude ^ " nil)"); - case CommandLine.arguments () of - prog::args => ( - def "*ARGV*" (LIST (map STRING args, NO_META)) replEnv; - rep replEnv ("(load-file \"" ^ prog ^ "\")"); - () - ) - | args => ( - def "*ARGV*" (LIST (map STRING args, NO_META)) replEnv; - repl replEnv - ) -) +fun read s = + readStr s + +fun eval e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) + | eval e (SYMBOL s) = evalSymbol e s + | eval e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) + | eval e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) + | eval e ast = ast + +and specialEval (SYMBOL "def!") = SOME evalDef + | specialEval (SYMBOL "let*") = SOME evalLet + | specialEval (SYMBOL "do") = SOME evalDo + | specialEval (SYMBOL "if") = SOME evalIf + | specialEval (SYMBOL "fn*") = SOME evalFn + | specialEval _ = NONE + +and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end + | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" + +and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" + +and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs + | evalDo _ _ = raise NotApplicable "do needs at least one argument" + +and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b + | evalIf e [c,a] = evalIf e [c,a,NIL] + | evalIf _ _ = raise NotApplicable "if needs two or three arguments" + +and evalFn e [LIST (binds,_),body] = makeFn e binds body + | evalFn e [VECTOR (binds,_),body] = makeFn e binds body + | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" +and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) + +and evalApply e (FN (f,_)) args = f (map (eval e) args) + | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (LIST (args, NO_META))) + +and evalSymbol e s = valOrElse (lookup e s) + (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) + +and bindLet args e = bind' (eval e) args e +and bind args e = bind' identity args e +and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (LIST (map evl (v::vs), NO_META)) e; e) + | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (LIST ([], NO_META)) e; e) + | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) + | bind' _ [] e = e + | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" + +fun print f = + prReadableStr f + +fun rep e s = + s |> read |> eval e |> print + handle Nothing => "" + | SyntaxError msg => "SYNTAX ERROR: " ^ msg + | NotApplicable msg => "CANNOT APPLY: " ^ msg + | NotDefined msg => "NOT DEFINED: " ^ msg + +val replEnv = ENV (NS (ref [])) |> bind coreNs + +fun repl e = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => + let val s = rep e line + val _ = print(s ^ "\n") + in + repl e + end + | NONE => () + ) end + +val prelude = " \ +\(def! not (fn* (a) (if a false true))) \ +\(def! \ +\ load-file \ +\ (fn* (f) \ +\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + +fun main () = ( + bind [ + SYMBOL "eval", + FN (fn ([x]) => eval replEnv x + | _ => raise NotApplicable "'eval' requires one argument", NO_META) + ] replEnv; + rep replEnv ("(do " ^ prelude ^ " nil)"); + case CommandLine.arguments () of + prog::args => ( + def "*ARGV*" (LIST (map STRING args, NO_META)) replEnv; + rep replEnv ("(load-file \"" ^ prog ^ "\")"); + () + ) + | args => ( + def "*ARGV*" (LIST (map STRING args, NO_META)) replEnv; + repl replEnv + ) +) diff --git a/impls/sml/step7_quote.mlb b/impls/sml/step7_quote.mlb index 47a2f88cb3..a68d9bc907 100644 --- a/impls/sml/step7_quote.mlb +++ b/impls/sml/step7_quote.mlb @@ -1,12 +1,12 @@ -local - $(SML_LIB)/basis/basis.mlb - util.sml - types.sml - printer.sml - reader.sml - env.sml - core.sml - step7_quote.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + env.sml + core.sml + step7_quote.sml +in + main.sml +end diff --git a/impls/sml/step7_quote.sml b/impls/sml/step7_quote.sml index af7659b1f9..0ccf97c9ac 100644 --- a/impls/sml/step7_quote.sml +++ b/impls/sml/step7_quote.sml @@ -1,118 +1,118 @@ -fun read s = - readStr s - -fun eval e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) - | eval e (SYMBOL s) = evalSymbol e s - | eval e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) - | eval e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) - | eval e ast = ast - -and specialEval (SYMBOL "def!") = SOME evalDef - | specialEval (SYMBOL "let*") = SOME evalLet - | specialEval (SYMBOL "do") = SOME evalDo - | specialEval (SYMBOL "if") = SOME evalIf - | specialEval (SYMBOL "fn*") = SOME evalFn - | specialEval (SYMBOL "quote") = SOME evalQuote - | specialEval (SYMBOL "quasiquote") = SOME evalQuasiquote - | specialEval (SYMBOL "quasiquoteexpand") = SOME (fn _ => expandQuasiquote) - | specialEval _ = NONE - -and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end - | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" - -and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" - -and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs - | evalDo _ _ = raise NotApplicable "do needs at least one argument" - -and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b - | evalIf e [c,a] = evalIf e [c,a,NIL] - | evalIf _ _ = raise NotApplicable "if needs two or three arguments" - -and evalFn e [LIST (binds,_),body] = makeFn e binds body - | evalFn e [VECTOR (binds,_),body] = makeFn e binds body - | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" -and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) - -and evalQuote e [x] = x - | evalQuote _ _ = raise NotApplicable "quote needs one argument" - -and evalQuasiquote e args = eval e (expandQuasiquote args) - -and expandQuasiquote [LIST ([SYMBOL "unquote", x],_)] = x - | expandQuasiquote [LIST (l,_)] = malList (foldr quasiFolder [] l) - | expandQuasiquote [VECTOR (v,_)] = malList [SYMBOL "vec", malList (foldr quasiFolder [] v)] - | expandQuasiquote [m as MAP _] = malList ([SYMBOL "quote", m]) - | expandQuasiquote [s as SYMBOL _] = malList ([SYMBOL "quote", s]) - | expandQuasiquote [x] = x - | expandQuasiquote _ = raise NotApplicable "quasiquote needs one argument" -and quasiFolder (LIST ([SYMBOL "splice-unquote", x],_), acc) = [SYMBOL "concat", x, malList acc] - | quasiFolder (x, acc) = [SYMBOL "cons", expandQuasiquote [x], malList acc] - -and evalApply e (FN (f,_)) args = f (map (eval e) args) - | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (malList args)) - -and evalSymbol e s = valOrElse (lookup e s) - (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) - -and bindLet args e = bind' (eval e) args e -and bind args e = bind' identity args e -and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (malList (map evl (v::vs))) e; e) - | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (malList []) e; e) - | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) - | bind' _ [] e = e - | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" - -fun print f = - prReadableStr f - -fun rep e s = - s |> read |> eval e |> print - handle Nothing => "" - | SyntaxError msg => "SYNTAX ERROR: " ^ msg - | NotApplicable msg => "CANNOT APPLY: " ^ msg - | NotDefined msg => "NOT DEFINED: " ^ msg - -val replEnv = ENV (NS (ref [])) |> bind coreNs - -fun repl e = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => - let val s = rep e line - val _ = print(s ^ "\n") - in - repl e - end - | NONE => () - ) end - -val prelude = " \ -\(def! not (fn* (a) (if a false true))) \ -\(def! \ -\ load-file \ -\ (fn* (f) \ -\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" - -fun main () = ( - bind [ - SYMBOL "eval", - FN (fn ([x]) => eval replEnv x - | _ => raise NotApplicable "'eval' requires one argument", NO_META) - ] replEnv; - rep replEnv ("(do " ^ prelude ^ " nil)"); - case CommandLine.arguments () of - prog::args => ( - def "*ARGV*" (malList (map STRING args)) replEnv; - rep replEnv ("(load-file \"" ^ prog ^ "\")"); - () - ) - | args => ( - def "*ARGV*" (malList (map STRING args)) replEnv; - repl replEnv - ) -) +fun read s = + readStr s + +fun eval e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) + | eval e (SYMBOL s) = evalSymbol e s + | eval e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) + | eval e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) + | eval e ast = ast + +and specialEval (SYMBOL "def!") = SOME evalDef + | specialEval (SYMBOL "let*") = SOME evalLet + | specialEval (SYMBOL "do") = SOME evalDo + | specialEval (SYMBOL "if") = SOME evalIf + | specialEval (SYMBOL "fn*") = SOME evalFn + | specialEval (SYMBOL "quote") = SOME evalQuote + | specialEval (SYMBOL "quasiquote") = SOME evalQuasiquote + | specialEval (SYMBOL "quasiquoteexpand") = SOME (fn _ => expandQuasiquote) + | specialEval _ = NONE + +and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end + | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" + +and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" + +and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs + | evalDo _ _ = raise NotApplicable "do needs at least one argument" + +and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b + | evalIf e [c,a] = evalIf e [c,a,NIL] + | evalIf _ _ = raise NotApplicable "if needs two or three arguments" + +and evalFn e [LIST (binds,_),body] = makeFn e binds body + | evalFn e [VECTOR (binds,_),body] = makeFn e binds body + | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" +and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) + +and evalQuote e [x] = x + | evalQuote _ _ = raise NotApplicable "quote needs one argument" + +and evalQuasiquote e args = eval e (expandQuasiquote args) + +and expandQuasiquote [LIST ([SYMBOL "unquote", x],_)] = x + | expandQuasiquote [LIST (l,_)] = malList (foldr quasiFolder [] l) + | expandQuasiquote [VECTOR (v,_)] = malList [SYMBOL "vec", malList (foldr quasiFolder [] v)] + | expandQuasiquote [m as MAP _] = malList ([SYMBOL "quote", m]) + | expandQuasiquote [s as SYMBOL _] = malList ([SYMBOL "quote", s]) + | expandQuasiquote [x] = x + | expandQuasiquote _ = raise NotApplicable "quasiquote needs one argument" +and quasiFolder (LIST ([SYMBOL "splice-unquote", x],_), acc) = [SYMBOL "concat", x, malList acc] + | quasiFolder (x, acc) = [SYMBOL "cons", expandQuasiquote [x], malList acc] + +and evalApply e (FN (f,_)) args = f (map (eval e) args) + | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (malList args)) + +and evalSymbol e s = valOrElse (lookup e s) + (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) + +and bindLet args e = bind' (eval e) args e +and bind args e = bind' identity args e +and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (malList (map evl (v::vs))) e; e) + | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (malList []) e; e) + | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) + | bind' _ [] e = e + | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" + +fun print f = + prReadableStr f + +fun rep e s = + s |> read |> eval e |> print + handle Nothing => "" + | SyntaxError msg => "SYNTAX ERROR: " ^ msg + | NotApplicable msg => "CANNOT APPLY: " ^ msg + | NotDefined msg => "NOT DEFINED: " ^ msg + +val replEnv = ENV (NS (ref [])) |> bind coreNs + +fun repl e = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => + let val s = rep e line + val _ = print(s ^ "\n") + in + repl e + end + | NONE => () + ) end + +val prelude = " \ +\(def! not (fn* (a) (if a false true))) \ +\(def! \ +\ load-file \ +\ (fn* (f) \ +\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + +fun main () = ( + bind [ + SYMBOL "eval", + FN (fn ([x]) => eval replEnv x + | _ => raise NotApplicable "'eval' requires one argument", NO_META) + ] replEnv; + rep replEnv ("(do " ^ prelude ^ " nil)"); + case CommandLine.arguments () of + prog::args => ( + def "*ARGV*" (malList (map STRING args)) replEnv; + rep replEnv ("(load-file \"" ^ prog ^ "\")"); + () + ) + | args => ( + def "*ARGV*" (malList (map STRING args)) replEnv; + repl replEnv + ) +) diff --git a/impls/sml/step8_macros.mlb b/impls/sml/step8_macros.mlb index 0c710ceeeb..fa877dfa25 100644 --- a/impls/sml/step8_macros.mlb +++ b/impls/sml/step8_macros.mlb @@ -1,12 +1,12 @@ -local - $(SML_LIB)/basis/basis.mlb - util.sml - types.sml - printer.sml - reader.sml - env.sml - core.sml - step8_macros.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + env.sml + core.sml + step8_macros.sml +in + main.sml +end diff --git a/impls/sml/step8_macros.sml b/impls/sml/step8_macros.sml index fe6673b76d..19ae8342db 100644 --- a/impls/sml/step8_macros.sml +++ b/impls/sml/step8_macros.sml @@ -1,144 +1,144 @@ -fun read s = - readStr s - -fun eval e ast = eval' e (expandMacro e [ast]) - -and eval' e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) - | eval' e (SYMBOL s) = evalSymbol e s - | eval' e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) - | eval' e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) - | eval' e ast = ast - -and specialEval (SYMBOL "def!") = SOME evalDef - | specialEval (SYMBOL "let*") = SOME evalLet - | specialEval (SYMBOL "do") = SOME evalDo - | specialEval (SYMBOL "if") = SOME evalIf - | specialEval (SYMBOL "fn*") = SOME evalFn - | specialEval (SYMBOL "quote") = SOME evalQuote - | specialEval (SYMBOL "quasiquote") = SOME evalQuasiquote - | specialEval (SYMBOL "quasiquoteexpand") = SOME (fn _ => expandQuasiquote) - | specialEval (SYMBOL "defmacro!") = SOME evalDefmacro - | specialEval (SYMBOL "macroexpand") = SOME expandMacro - | specialEval _ = NONE - -and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end - | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" - -and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" - -and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs - | evalDo _ _ = raise NotApplicable "do needs at least one argument" - -and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b - | evalIf e [c,a] = evalIf e [c,a,NIL] - | evalIf _ _ = raise NotApplicable "if needs two or three arguments" - -and evalFn e [LIST (binds,_),body] = makeFn e binds body - | evalFn e [VECTOR (binds,_),body] = makeFn e binds body - | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" -and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) - -and evalQuote e [x] = x - | evalQuote _ _ = raise NotApplicable "quote needs one argument" - -and evalQuasiquote e args = eval e (expandQuasiquote args) - -and expandQuasiquote [LIST ([SYMBOL "unquote", x],_)] = x - | expandQuasiquote [LIST (l,_)] = malList (foldr quasiFolder [] l) - | expandQuasiquote [VECTOR (v,_)] = malList [SYMBOL "vec", malList (foldr quasiFolder [] v)] - | expandQuasiquote [m as MAP _] = malList [SYMBOL "quote", m] - | expandQuasiquote [s as SYMBOL _] = malList [SYMBOL "quote", s] - | expandQuasiquote [x] = x - | expandQuasiquote _ = raise NotApplicable "quasiquote needs one argument" -and quasiFolder (LIST ([SYMBOL "splice-unquote", x],_), acc) = [SYMBOL "concat", x, malList acc] - | quasiFolder (x, acc) = [SYMBOL "cons", expandQuasiquote [x], malList acc] - -and evalDefmacro e [SYMBOL s, ast] = defMacro e s (eval e ast) - | evalDefmacro _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" -and defMacro e s (FN (f,_)) = let val m = MACRO f in (def s m e; m) end - | defMacro _ _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" - -and expandMacro e [(ast as LIST (SYMBOL s::args, _))] = (case lookup e s of SOME (MACRO m) => m args | _ => ast) - | expandMacro _ [ast] = ast - | expandMacro _ _ = raise NotApplicable "macroexpand needs one argument" - -and evalApply e (FN (f,_)) args = f (map (eval e) args) - | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (malList args)) - -and evalSymbol e s = valOrElse (lookup e s) - (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) - -and bindLet args e = bind' (eval e) args e -and bind args e = bind' identity args e -and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (malList (map evl (v::vs))) e; e) - | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (malList []) e; e) - | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) - | bind' _ [] e = e - | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" - -fun print f = - prReadableStr f - -fun rep e s = - s |> read |> eval e |> print - handle Nothing => "" - | SyntaxError msg => "SYNTAX ERROR: " ^ msg - | NotApplicable msg => "CANNOT APPLY: " ^ msg - | NotDefined msg => "NOT DEFINED: " ^ msg - | e => "ERROR: " ^ (exnMessage e) - -val replEnv = ENV (NS (ref [])) |> bind coreNs - -fun repl e = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => - let val s = rep e line - val _ = print(s ^ "\n") - in - repl e - end - | NONE => () - ) end - -val prelude = " \ -\\ -\(def! not (fn* (a) (if a false true))) \ -\\ -\(def! \ -\ load-file \ -\ (fn* (f) \ -\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))\ -\\ -\(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)))))))" - -fun main () = ( - bind [ - SYMBOL "eval", - FN (fn ([x]) => eval replEnv x - | _ => raise NotApplicable "'eval' requires one argument", NO_META) - ] replEnv; - rep replEnv ("(do " ^ prelude ^ " nil)"); - case CommandLine.arguments () of - prog::args => ( - def "*ARGV*" (malList (map STRING args)) replEnv; - rep replEnv ("(load-file \"" ^ prog ^ "\")"); - () - ) - | args => ( - def "*ARGV*" (malList (map STRING args)) replEnv; - repl replEnv - ) -) +fun read s = + readStr s + +fun eval e ast = eval' e (expandMacro e [ast]) + +and eval' e (LIST (a::args,_)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) + | eval' e (SYMBOL s) = evalSymbol e s + | eval' e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) + | eval' e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) + | eval' e ast = ast + +and specialEval (SYMBOL "def!") = SOME evalDef + | specialEval (SYMBOL "let*") = SOME evalLet + | specialEval (SYMBOL "do") = SOME evalDo + | specialEval (SYMBOL "if") = SOME evalIf + | specialEval (SYMBOL "fn*") = SOME evalFn + | specialEval (SYMBOL "quote") = SOME evalQuote + | specialEval (SYMBOL "quasiquote") = SOME evalQuasiquote + | specialEval (SYMBOL "quasiquoteexpand") = SOME (fn _ => expandQuasiquote) + | specialEval (SYMBOL "defmacro!") = SOME evalDefmacro + | specialEval (SYMBOL "macroexpand") = SOME expandMacro + | specialEval _ = NONE + +and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end + | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" + +and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" + +and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs + | evalDo _ _ = raise NotApplicable "do needs at least one argument" + +and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b + | evalIf e [c,a] = evalIf e [c,a,NIL] + | evalIf _ _ = raise NotApplicable "if needs two or three arguments" + +and evalFn e [LIST (binds,_),body] = makeFn e binds body + | evalFn e [VECTOR (binds,_),body] = makeFn e binds body + | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" +and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) + +and evalQuote e [x] = x + | evalQuote _ _ = raise NotApplicable "quote needs one argument" + +and evalQuasiquote e args = eval e (expandQuasiquote args) + +and expandQuasiquote [LIST ([SYMBOL "unquote", x],_)] = x + | expandQuasiquote [LIST (l,_)] = malList (foldr quasiFolder [] l) + | expandQuasiquote [VECTOR (v,_)] = malList [SYMBOL "vec", malList (foldr quasiFolder [] v)] + | expandQuasiquote [m as MAP _] = malList [SYMBOL "quote", m] + | expandQuasiquote [s as SYMBOL _] = malList [SYMBOL "quote", s] + | expandQuasiquote [x] = x + | expandQuasiquote _ = raise NotApplicable "quasiquote needs one argument" +and quasiFolder (LIST ([SYMBOL "splice-unquote", x],_), acc) = [SYMBOL "concat", x, malList acc] + | quasiFolder (x, acc) = [SYMBOL "cons", expandQuasiquote [x], malList acc] + +and evalDefmacro e [SYMBOL s, ast] = defMacro e s (eval e ast) + | evalDefmacro _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" +and defMacro e s (FN (f,_)) = let val m = MACRO f in (def s m e; m) end + | defMacro _ _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" + +and expandMacro e [(ast as LIST (SYMBOL s::args, _))] = (case lookup e s of SOME (MACRO m) => m args | _ => ast) + | expandMacro _ [ast] = ast + | expandMacro _ _ = raise NotApplicable "macroexpand needs one argument" + +and evalApply e (FN (f,_)) args = f (map (eval e) args) + | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (malList args)) + +and evalSymbol e s = valOrElse (lookup e s) + (fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found")) + +and bindLet args e = bind' (eval e) args e +and bind args e = bind' identity args e +and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (malList (map evl (v::vs))) e; e) + | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (malList []) e; e) + | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) + | bind' _ [] e = e + | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" + +fun print f = + prReadableStr f + +fun rep e s = + s |> read |> eval e |> print + handle Nothing => "" + | SyntaxError msg => "SYNTAX ERROR: " ^ msg + | NotApplicable msg => "CANNOT APPLY: " ^ msg + | NotDefined msg => "NOT DEFINED: " ^ msg + | e => "ERROR: " ^ (exnMessage e) + +val replEnv = ENV (NS (ref [])) |> bind coreNs + +fun repl e = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => + let val s = rep e line + val _ = print(s ^ "\n") + in + repl e + end + | NONE => () + ) end + +val prelude = " \ +\\ +\(def! not (fn* (a) (if a false true))) \ +\\ +\(def! \ +\ load-file \ +\ (fn* (f) \ +\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))\ +\\ +\(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)))))))" + +fun main () = ( + bind [ + SYMBOL "eval", + FN (fn ([x]) => eval replEnv x + | _ => raise NotApplicable "'eval' requires one argument", NO_META) + ] replEnv; + rep replEnv ("(do " ^ prelude ^ " nil)"); + case CommandLine.arguments () of + prog::args => ( + def "*ARGV*" (malList (map STRING args)) replEnv; + rep replEnv ("(load-file \"" ^ prog ^ "\")"); + () + ) + | args => ( + def "*ARGV*" (malList (map STRING args)) replEnv; + repl replEnv + ) +) diff --git a/impls/sml/step9_try.mlb b/impls/sml/step9_try.mlb index a206b25d48..41955f0aec 100644 --- a/impls/sml/step9_try.mlb +++ b/impls/sml/step9_try.mlb @@ -1,12 +1,12 @@ -local - $(SML_LIB)/basis/basis.mlb - util.sml - types.sml - printer.sml - reader.sml - env.sml - core.sml - step9_try.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + env.sml + core.sml + step9_try.sml +in + main.sml +end diff --git a/impls/sml/step9_try.sml b/impls/sml/step9_try.sml index de468d1cca..71a14edf25 100644 --- a/impls/sml/step9_try.sml +++ b/impls/sml/step9_try.sml @@ -1,157 +1,157 @@ -fun read s = - readStr s - -fun eval e ast = eval' e (expandMacro e [ast]) - -and eval' e (LIST (a::args, _)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) - | eval' e (SYMBOL s) = evalSymbol e s - | eval' e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) - | eval' e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) - | eval' e ast = ast - -and specialEval (SYMBOL "def!") = SOME evalDef - | specialEval (SYMBOL "let*") = SOME evalLet - | specialEval (SYMBOL "do") = SOME evalDo - | specialEval (SYMBOL "if") = SOME evalIf - | specialEval (SYMBOL "fn*") = SOME evalFn - | specialEval (SYMBOL "quote") = SOME evalQuote - | specialEval (SYMBOL "quasiquote") = SOME evalQuasiquote - | specialEval (SYMBOL "quasiquoteexpand") = SOME (fn _ => expandQuasiquote) - | specialEval (SYMBOL "defmacro!") = SOME evalDefmacro - | specialEval (SYMBOL "macroexpand") = SOME expandMacro - | specialEval (SYMBOL "try*") = SOME evalTry - | specialEval _ = NONE - -and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end - | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" - -and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" - -and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs - | evalDo _ _ = raise NotApplicable "do needs at least one argument" - -and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b - | evalIf e [c,a] = evalIf e [c,a,NIL] - | evalIf _ _ = raise NotApplicable "if needs two or three arguments" - -and evalFn e [(LIST (binds,_)),body] = makeFn e binds body - | evalFn e [(VECTOR (binds,_)),body] = makeFn e binds body - | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" -and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) - -and evalQuote e [x] = x - | evalQuote _ _ = raise NotApplicable "quote needs one argument" - -and evalQuasiquote e args = eval e (expandQuasiquote args) - -and expandQuasiquote [LIST ([SYMBOL "unquote", x],_)] = x - | expandQuasiquote [LIST (l,_)] = malList (foldr quasiFolder [] l) - | expandQuasiquote [VECTOR (v,_)] = malList [SYMBOL "vec", malList (foldr quasiFolder [] v)] - | expandQuasiquote [m as MAP _] = malList [SYMBOL "quote", m] - | expandQuasiquote [s as SYMBOL _] = malList [SYMBOL "quote", s] - | expandQuasiquote [x] = x - | expandQuasiquote _ = raise NotApplicable "quasiquote needs one argument" -and quasiFolder (LIST ([SYMBOL "splice-unquote", x],_), acc) = [SYMBOL "concat", x, malList acc] - | quasiFolder (x, acc) = [SYMBOL "cons", expandQuasiquote [x], malList acc] - -and evalDefmacro e [SYMBOL s, ast] = defMacro e s (eval e ast) - | evalDefmacro _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" -and defMacro e s (FN (f,_)) = let val m = MACRO f in (def s m e; m) end - | defMacro _ _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" - -and expandMacro e [(ast as LIST (SYMBOL s::args, _))] = (case lookup e s of SOME (MACRO m) => m args | _ => ast) - | expandMacro _ [ast] = ast - | expandMacro _ _ = raise NotApplicable "macroexpand needs one argument" - -and evalTry e [a, LIST ([SYMBOL "catch*", b, c],_)] = (eval e a handle ex => evalCatch (inside e) b ex c) - | evalTry e [a] = eval e a - | evalTry _ _ = raise NotApplicable "try* needs a form to evaluate" -and evalCatch e b ex body = eval (bind [b, exnVal ex] e) body - -and exnVal (MalException x) = x - | exnVal (NotDefined msg) = STRING msg - | exnVal (NotApplicable msg) = STRING msg - | exnVal (OutOfBounds msg) = STRING msg - | exnVal exn = STRING (exnMessage exn) - -and evalApply e (FN (f,_)) args = f (map (eval e) args) - | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (malList args)) - -and evalSymbol e s = valOrElse (lookup e s) - (fn _ => raise NotDefined ("'" ^ s ^ "' not found")) - -and bindLet args e = bind' (eval e) args e -and bind args e = bind' identity args e -and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (malList (map evl (v::vs))) e; e) - | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (malList []) e; e) - | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) - | bind' _ [] e = e - | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" - -fun print f = - prReadableStr f - -fun rep e s = - s |> read |> eval e |> print - handle Nothing => "" - | SyntaxError msg => "SYNTAX ERROR: " ^ msg - | NotApplicable msg => "CANNOT APPLY: " ^ msg - | NotDefined msg => "NOT DEFINED: " ^ msg - | MalException e => "ERROR: " ^ (prStr e) - | e => "ERROR: " ^ (exnMessage e) - -val replEnv = ENV (NS (ref [])) |> bind coreNs - -fun repl e = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => - let val s = rep e line - val _ = print(s ^ "\n") - in - repl e - end - | NONE => () - ) end - -val prelude = " \ -\\ -\(def! not (fn* (a) (if a false true))) \ -\\ -\(def! \ -\ load-file \ -\ (fn* (f) \ -\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))\ -\\ -\(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)))))))" - -fun main () = ( - bind [ - SYMBOL "eval", - FN (fn ([x]) => eval replEnv x - | _ => raise NotApplicable "'eval' requires one argument", NO_META) - ] replEnv; - rep replEnv ("(do " ^ prelude ^ " nil)"); - case CommandLine.arguments () of - prog::args => ( - def "*ARGV*" (malList (map STRING args)) replEnv; - rep replEnv ("(load-file \"" ^ prog ^ "\")"); - () - ) - | args => ( - def "*ARGV*" (malList (map STRING args)) replEnv; - repl replEnv - ) -) +fun read s = + readStr s + +fun eval e ast = eval' e (expandMacro e [ast]) + +and eval' e (LIST (a::args, _)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) + | eval' e (SYMBOL s) = evalSymbol e s + | eval' e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) + | eval' e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) + | eval' e ast = ast + +and specialEval (SYMBOL "def!") = SOME evalDef + | specialEval (SYMBOL "let*") = SOME evalLet + | specialEval (SYMBOL "do") = SOME evalDo + | specialEval (SYMBOL "if") = SOME evalIf + | specialEval (SYMBOL "fn*") = SOME evalFn + | specialEval (SYMBOL "quote") = SOME evalQuote + | specialEval (SYMBOL "quasiquote") = SOME evalQuasiquote + | specialEval (SYMBOL "quasiquoteexpand") = SOME (fn _ => expandQuasiquote) + | specialEval (SYMBOL "defmacro!") = SOME evalDefmacro + | specialEval (SYMBOL "macroexpand") = SOME expandMacro + | specialEval (SYMBOL "try*") = SOME evalTry + | specialEval _ = NONE + +and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end + | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" + +and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" + +and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs + | evalDo _ _ = raise NotApplicable "do needs at least one argument" + +and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b + | evalIf e [c,a] = evalIf e [c,a,NIL] + | evalIf _ _ = raise NotApplicable "if needs two or three arguments" + +and evalFn e [(LIST (binds,_)),body] = makeFn e binds body + | evalFn e [(VECTOR (binds,_)),body] = makeFn e binds body + | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" +and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) + +and evalQuote e [x] = x + | evalQuote _ _ = raise NotApplicable "quote needs one argument" + +and evalQuasiquote e args = eval e (expandQuasiquote args) + +and expandQuasiquote [LIST ([SYMBOL "unquote", x],_)] = x + | expandQuasiquote [LIST (l,_)] = malList (foldr quasiFolder [] l) + | expandQuasiquote [VECTOR (v,_)] = malList [SYMBOL "vec", malList (foldr quasiFolder [] v)] + | expandQuasiquote [m as MAP _] = malList [SYMBOL "quote", m] + | expandQuasiquote [s as SYMBOL _] = malList [SYMBOL "quote", s] + | expandQuasiquote [x] = x + | expandQuasiquote _ = raise NotApplicable "quasiquote needs one argument" +and quasiFolder (LIST ([SYMBOL "splice-unquote", x],_), acc) = [SYMBOL "concat", x, malList acc] + | quasiFolder (x, acc) = [SYMBOL "cons", expandQuasiquote [x], malList acc] + +and evalDefmacro e [SYMBOL s, ast] = defMacro e s (eval e ast) + | evalDefmacro _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" +and defMacro e s (FN (f,_)) = let val m = MACRO f in (def s m e; m) end + | defMacro _ _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" + +and expandMacro e [(ast as LIST (SYMBOL s::args, _))] = (case lookup e s of SOME (MACRO m) => m args | _ => ast) + | expandMacro _ [ast] = ast + | expandMacro _ _ = raise NotApplicable "macroexpand needs one argument" + +and evalTry e [a, LIST ([SYMBOL "catch*", b, c],_)] = (eval e a handle ex => evalCatch (inside e) b ex c) + | evalTry e [a] = eval e a + | evalTry _ _ = raise NotApplicable "try* needs a form to evaluate" +and evalCatch e b ex body = eval (bind [b, exnVal ex] e) body + +and exnVal (MalException x) = x + | exnVal (NotDefined msg) = STRING msg + | exnVal (NotApplicable msg) = STRING msg + | exnVal (OutOfBounds msg) = STRING msg + | exnVal exn = STRING (exnMessage exn) + +and evalApply e (FN (f,_)) args = f (map (eval e) args) + | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (malList args)) + +and evalSymbol e s = valOrElse (lookup e s) + (fn _ => raise NotDefined ("'" ^ s ^ "' not found")) + +and bindLet args e = bind' (eval e) args e +and bind args e = bind' identity args e +and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (malList (map evl (v::vs))) e; e) + | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (malList []) e; e) + | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) + | bind' _ [] e = e + | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" + +fun print f = + prReadableStr f + +fun rep e s = + s |> read |> eval e |> print + handle Nothing => "" + | SyntaxError msg => "SYNTAX ERROR: " ^ msg + | NotApplicable msg => "CANNOT APPLY: " ^ msg + | NotDefined msg => "NOT DEFINED: " ^ msg + | MalException e => "ERROR: " ^ (prStr e) + | e => "ERROR: " ^ (exnMessage e) + +val replEnv = ENV (NS (ref [])) |> bind coreNs + +fun repl e = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => + let val s = rep e line + val _ = print(s ^ "\n") + in + repl e + end + | NONE => () + ) end + +val prelude = " \ +\\ +\(def! not (fn* (a) (if a false true))) \ +\\ +\(def! \ +\ load-file \ +\ (fn* (f) \ +\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))\ +\\ +\(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)))))))" + +fun main () = ( + bind [ + SYMBOL "eval", + FN (fn ([x]) => eval replEnv x + | _ => raise NotApplicable "'eval' requires one argument", NO_META) + ] replEnv; + rep replEnv ("(do " ^ prelude ^ " nil)"); + case CommandLine.arguments () of + prog::args => ( + def "*ARGV*" (malList (map STRING args)) replEnv; + rep replEnv ("(load-file \"" ^ prog ^ "\")"); + () + ) + | args => ( + def "*ARGV*" (malList (map STRING args)) replEnv; + repl replEnv + ) +) diff --git a/impls/sml/stepA_mal.mlb b/impls/sml/stepA_mal.mlb index 5bf38f95e2..87ecf00772 100644 --- a/impls/sml/stepA_mal.mlb +++ b/impls/sml/stepA_mal.mlb @@ -1,12 +1,12 @@ -local - $(SML_LIB)/basis/basis.mlb - util.sml - types.sml - printer.sml - reader.sml - env.sml - core.sml - stepA_mal.sml -in - main.sml -end +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + env.sml + core.sml + stepA_mal.sml +in + main.sml +end diff --git a/impls/sml/stepA_mal.sml b/impls/sml/stepA_mal.sml index e279debec9..c0baae6879 100644 --- a/impls/sml/stepA_mal.sml +++ b/impls/sml/stepA_mal.sml @@ -1,159 +1,159 @@ -fun read s = - readStr s - -fun eval e ast = eval' e (expandMacro e [ast]) - -and eval' e (LIST (a::args, _)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) - | eval' e (SYMBOL s) = evalSymbol e s - | eval' e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) - | eval' e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) - | eval' e ast = ast - -and specialEval (SYMBOL "def!") = SOME evalDef - | specialEval (SYMBOL "let*") = SOME evalLet - | specialEval (SYMBOL "do") = SOME evalDo - | specialEval (SYMBOL "if") = SOME evalIf - | specialEval (SYMBOL "fn*") = SOME evalFn - | specialEval (SYMBOL "quote") = SOME evalQuote - | specialEval (SYMBOL "quasiquote") = SOME evalQuasiquote - | specialEval (SYMBOL "quasiquoteexpand") = SOME (fn _ => expandQuasiquote) - | specialEval (SYMBOL "defmacro!") = SOME evalDefmacro - | specialEval (SYMBOL "macroexpand") = SOME expandMacro - | specialEval (SYMBOL "try*") = SOME evalTry - | specialEval _ = NONE - -and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end - | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" - -and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast - | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" - -and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs - | evalDo _ _ = raise NotApplicable "do needs at least one argument" - -and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b - | evalIf e [c,a] = evalIf e [c,a,NIL] - | evalIf _ _ = raise NotApplicable "if needs two or three arguments" - -and evalFn e [(LIST (binds,_)),body] = makeFn e binds body - | evalFn e [(VECTOR (binds,_)),body] = makeFn e binds body - | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" -and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) - -and evalQuote e [x] = x - | evalQuote _ _ = raise NotApplicable "quote needs one argument" - -and evalQuasiquote e args = eval e (expandQuasiquote args) - -and expandQuasiquote [LIST ([SYMBOL "unquote", x],_)] = x - | expandQuasiquote [LIST (l,_)] = malList (foldr quasiFolder [] l) - | expandQuasiquote [VECTOR (v,_)] = malList [SYMBOL "vec", malList (foldr quasiFolder [] v)] - | expandQuasiquote [m as MAP _] = malList [SYMBOL "quote", m] - | expandQuasiquote [s as SYMBOL _] = malList [SYMBOL "quote", s] - | expandQuasiquote [x] = x - | expandQuasiquote _ = raise NotApplicable "quasiquote needs one argument" -and quasiFolder (LIST ([SYMBOL "splice-unquote", x],_), acc) = [SYMBOL "concat", x, malList acc] - | quasiFolder (x, acc) = [SYMBOL "cons", expandQuasiquote [x], malList acc] - -and evalDefmacro e [SYMBOL s, ast] = defMacro e s (eval e ast) - | evalDefmacro _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" -and defMacro e s (FN (f,_)) = let val m = MACRO f in (def s m e; m) end - | defMacro _ _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" - -and expandMacro e [(ast as LIST (SYMBOL s::args, _))] = (case lookup e s of SOME (MACRO m) => m args | _ => ast) - | expandMacro _ [ast] = ast - | expandMacro _ _ = raise NotApplicable "macroexpand needs one argument" - -and evalTry e [a, LIST ([SYMBOL "catch*", b, c],_)] = (eval e a handle ex => evalCatch (inside e) b ex c) - | evalTry e [a] = eval e a - | evalTry _ _ = raise NotApplicable "try* needs a form to evaluate" -and evalCatch e b ex body = eval (bind [b, exnVal ex] e) body - -and exnVal (MalException x) = x - | exnVal (NotDefined msg) = STRING msg - | exnVal (NotApplicable msg) = STRING msg - | exnVal (OutOfBounds msg) = STRING msg - | exnVal exn = STRING (exnMessage exn) - -and evalApply e (FN (f,_)) args = f (map (eval e) args) - | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (malList args)) - -and evalSymbol e s = valOrElse (lookup e s) - (fn _ => raise NotDefined ("'" ^ s ^ "' not found")) - -and bindLet args e = bind' (eval e) args e -and bind args e = bind' identity args e -and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (malList (map evl (v::vs))) e; e) - | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (malList []) e; e) - | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) - | bind' _ [] e = e - | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" - -fun print f = - prReadableStr f - -fun rep e s = - s |> read |> eval e |> print - handle Nothing => "" - | SyntaxError msg => "SYNTAX ERROR: " ^ msg - | NotApplicable msg => "CANNOT APPLY: " ^ msg - | NotDefined msg => "NOT DEFINED: " ^ msg - | MalException e => "ERROR: " ^ (prStr e) - | e => "ERROR: " ^ (exnMessage e) - -val replEnv = ENV (NS (ref [])) |> bind coreNs - -fun repl e = - let open TextIO - in ( - print("user> "); - case inputLine(stdIn) of - SOME(line) => - let val s = rep e line - val _ = print(s ^ "\n") - in - repl e - end - | NONE => () - ) end - -val prelude = " \ -\\ -\(def! not (fn* (a) (if a false true))) \ -\\ -\(def! \ -\ load-file \ -\ (fn* (f) \ -\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))\ -\\ -\(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)))))))" - -fun main () = ( - def "*host-language*" (STRING "sml") replEnv; - bind [ - SYMBOL "eval", - FN (fn ([x]) => eval replEnv x - | _ => raise NotApplicable "'eval' requires one argument", NO_META) - ] replEnv; - rep replEnv ("(do " ^ prelude ^ " nil)"); - case CommandLine.arguments () of - prog::args => ( - def "*ARGV*" (malList (map STRING args)) replEnv; - rep replEnv ("(load-file \"" ^ prog ^ "\")"); - () - ) - | args => ( - def "*ARGV*" (malList (map STRING args)) replEnv; - rep replEnv "(println (str \"Mal [\" *host-language* \"]\"))"; - repl replEnv - ) -) +fun read s = + readStr s + +fun eval e ast = eval' e (expandMacro e [ast]) + +and eval' e (LIST (a::args, _)) = (case specialEval a of SOME special => special e args | _ => evalApply e (eval e a) args) + | eval' e (SYMBOL s) = evalSymbol e s + | eval' e (VECTOR (v,_)) = VECTOR (map (eval e) v, NO_META) + | eval' e (MAP (m,_)) = MAP (List.map (fn (k, v) => (k, eval e v)) m, NO_META) + | eval' e ast = ast + +and specialEval (SYMBOL "def!") = SOME evalDef + | specialEval (SYMBOL "let*") = SOME evalLet + | specialEval (SYMBOL "do") = SOME evalDo + | specialEval (SYMBOL "if") = SOME evalIf + | specialEval (SYMBOL "fn*") = SOME evalFn + | specialEval (SYMBOL "quote") = SOME evalQuote + | specialEval (SYMBOL "quasiquote") = SOME evalQuasiquote + | specialEval (SYMBOL "quasiquoteexpand") = SOME (fn _ => expandQuasiquote) + | specialEval (SYMBOL "defmacro!") = SOME evalDefmacro + | specialEval (SYMBOL "macroexpand") = SOME expandMacro + | specialEval (SYMBOL "try*") = SOME evalTry + | specialEval _ = NONE + +and evalDef e [SYMBOL s, ast] = let val v = eval e ast in (def s v e; v) end + | evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate" + +and evalLet e [LIST (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet e [VECTOR (bs,_), ast] = eval (bindLet bs (inside e)) ast + | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" + +and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs + | evalDo _ _ = raise NotApplicable "do needs at least one argument" + +and evalIf e [c,a,b] = if truthy (eval e c) then eval e a else eval e b + | evalIf e [c,a] = evalIf e [c,a,NIL] + | evalIf _ _ = raise NotApplicable "if needs two or three arguments" + +and evalFn e [(LIST (binds,_)),body] = makeFn e binds body + | evalFn e [(VECTOR (binds,_)),body] = makeFn e binds body + | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" +and makeFn e binds body = FN (fn (exprs) => eval (bind (interleave binds exprs) (inside e)) body, NO_META) + +and evalQuote e [x] = x + | evalQuote _ _ = raise NotApplicable "quote needs one argument" + +and evalQuasiquote e args = eval e (expandQuasiquote args) + +and expandQuasiquote [LIST ([SYMBOL "unquote", x],_)] = x + | expandQuasiquote [LIST (l,_)] = malList (foldr quasiFolder [] l) + | expandQuasiquote [VECTOR (v,_)] = malList [SYMBOL "vec", malList (foldr quasiFolder [] v)] + | expandQuasiquote [m as MAP _] = malList [SYMBOL "quote", m] + | expandQuasiquote [s as SYMBOL _] = malList [SYMBOL "quote", s] + | expandQuasiquote [x] = x + | expandQuasiquote _ = raise NotApplicable "quasiquote needs one argument" +and quasiFolder (LIST ([SYMBOL "splice-unquote", x],_), acc) = [SYMBOL "concat", x, malList acc] + | quasiFolder (x, acc) = [SYMBOL "cons", expandQuasiquote [x], malList acc] + +and evalDefmacro e [SYMBOL s, ast] = defMacro e s (eval e ast) + | evalDefmacro _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" +and defMacro e s (FN (f,_)) = let val m = MACRO f in (def s m e; m) end + | defMacro _ _ _ = raise NotApplicable "defmacro! needs a name, and a fn*" + +and expandMacro e [(ast as LIST (SYMBOL s::args, _))] = (case lookup e s of SOME (MACRO m) => m args | _ => ast) + | expandMacro _ [ast] = ast + | expandMacro _ _ = raise NotApplicable "macroexpand needs one argument" + +and evalTry e [a, LIST ([SYMBOL "catch*", b, c],_)] = (eval e a handle ex => evalCatch (inside e) b ex c) + | evalTry e [a] = eval e a + | evalTry _ _ = raise NotApplicable "try* needs a form to evaluate" +and evalCatch e b ex body = eval (bind [b, exnVal ex] e) body + +and exnVal (MalException x) = x + | exnVal (NotDefined msg) = STRING msg + | exnVal (NotApplicable msg) = STRING msg + | exnVal (OutOfBounds msg) = STRING msg + | exnVal exn = STRING (exnMessage exn) + +and evalApply e (FN (f,_)) args = f (map (eval e) args) + | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (malList args)) + +and evalSymbol e s = valOrElse (lookup e s) + (fn _ => raise NotDefined ("'" ^ s ^ "' not found")) + +and bindLet args e = bind' (eval e) args e +and bind args e = bind' identity args e +and bind' evl (SYMBOL "&"::v::(SYMBOL s)::vs) e = (def s (malList (map evl (v::vs))) e; e) + | bind' _ [SYMBOL "&", SYMBOL s] e = (def s (malList []) e; e) + | bind' evl (SYMBOL s::v::rest) e = (def s (evl v) e; bind' evl rest e) + | bind' _ [] e = e + | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" + +fun print f = + prReadableStr f + +fun rep e s = + s |> read |> eval e |> print + handle Nothing => "" + | SyntaxError msg => "SYNTAX ERROR: " ^ msg + | NotApplicable msg => "CANNOT APPLY: " ^ msg + | NotDefined msg => "NOT DEFINED: " ^ msg + | MalException e => "ERROR: " ^ (prStr e) + | e => "ERROR: " ^ (exnMessage e) + +val replEnv = ENV (NS (ref [])) |> bind coreNs + +fun repl e = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => + let val s = rep e line + val _ = print(s ^ "\n") + in + repl e + end + | NONE => () + ) end + +val prelude = " \ +\\ +\(def! not (fn* (a) (if a false true))) \ +\\ +\(def! \ +\ load-file \ +\ (fn* (f) \ +\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))\ +\\ +\(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)))))))" + +fun main () = ( + def "*host-language*" (STRING "sml") replEnv; + bind [ + SYMBOL "eval", + FN (fn ([x]) => eval replEnv x + | _ => raise NotApplicable "'eval' requires one argument", NO_META) + ] replEnv; + rep replEnv ("(do " ^ prelude ^ " nil)"); + case CommandLine.arguments () of + prog::args => ( + def "*ARGV*" (malList (map STRING args)) replEnv; + rep replEnv ("(load-file \"" ^ prog ^ "\")"); + () + ) + | args => ( + def "*ARGV*" (malList (map STRING args)) replEnv; + rep replEnv "(println (str \"Mal [\" *host-language* \"]\"))"; + repl replEnv + ) +) diff --git a/impls/sml/types.sml b/impls/sml/types.sml index fadc3217b3..ff9e819fc1 100644 --- a/impls/sml/types.sml +++ b/impls/sml/types.sml @@ -1,48 +1,48 @@ -datatype mal_type = NIL - | SYMBOL of string - | BOOL of bool - | INT of LargeInt.int - | STRING of string - | KEYWORD of string - | LIST of (mal_type list * mal_meta) - | VECTOR of (mal_type list * mal_meta) - | MAP of ((mal_type * mal_type) list * mal_meta) - | ATOM of mal_type ref - | FN of (mal_type list -> mal_type) * mal_meta - | MACRO of mal_type list -> mal_type - -and mal_meta = META of mal_type - | NO_META - -and mal_ns = NS of (string * mal_type) list ref - -and mal_env = ENV of mal_ns - | INNER of mal_ns * mal_env - -fun truthy (BOOL false) = false - | truthy NIL = false - | truthy _ = true - -fun malEq ( NIL, NIL) = true - | malEq ( SYMBOL a, SYMBOL b) = a = b - | malEq ( BOOL a, BOOL b) = a = b - | malEq ( INT a, INT b) = a = b - | malEq ( STRING a, STRING b) = a = b - | malEq ( KEYWORD a, KEYWORD b) = a = b - | malEq ( LIST (a,_), LIST (b,_)) = ListPair.allEq malEq (a, b) - | malEq (VECTOR (a,_), VECTOR (b,_)) = ListPair.allEq malEq (a, b) - | malEq ( LIST (a,_), VECTOR (b,_)) = ListPair.allEq malEq (a, b) - | malEq (VECTOR (a,_), LIST (b,_)) = ListPair.allEq malEq (a, b) - | malEq ( MAP (a,_), MAP (b,_)) = mapEq a b - | malEq _ = false -and mapEq a b = - a |> List.map (fn (k,va) => (va, malGet b k)) |> List.all (fn (va,SOME vb) => malEq (va, vb) | _ => false) andalso - b |> List.map (fn (k,vb) => (vb, malGet a k)) |> List.all (fn (vb,SOME va) => malEq (vb, va) | _ => false) - -and malGet m k = m |> List.find (fn (k',_) => malEq (k, k')) |> Option.map #2 -and malAssoc m k v = (k, v) :: (malDissoc m k) -and malDissoc m k = m |> List.filter (not o (fn (k', _) => malEq (k, k'))) - -fun malList xs = LIST (xs, NO_META) -fun malVector xs = VECTOR (xs, NO_META) -fun malMap kvps = MAP (kvps, NO_META) +datatype mal_type = NIL + | SYMBOL of string + | BOOL of bool + | INT of LargeInt.int + | STRING of string + | KEYWORD of string + | LIST of (mal_type list * mal_meta) + | VECTOR of (mal_type list * mal_meta) + | MAP of ((mal_type * mal_type) list * mal_meta) + | ATOM of mal_type ref + | FN of (mal_type list -> mal_type) * mal_meta + | MACRO of mal_type list -> mal_type + +and mal_meta = META of mal_type + | NO_META + +and mal_ns = NS of (string * mal_type) list ref + +and mal_env = ENV of mal_ns + | INNER of mal_ns * mal_env + +fun truthy (BOOL false) = false + | truthy NIL = false + | truthy _ = true + +fun malEq ( NIL, NIL) = true + | malEq ( SYMBOL a, SYMBOL b) = a = b + | malEq ( BOOL a, BOOL b) = a = b + | malEq ( INT a, INT b) = a = b + | malEq ( STRING a, STRING b) = a = b + | malEq ( KEYWORD a, KEYWORD b) = a = b + | malEq ( LIST (a,_), LIST (b,_)) = ListPair.allEq malEq (a, b) + | malEq (VECTOR (a,_), VECTOR (b,_)) = ListPair.allEq malEq (a, b) + | malEq ( LIST (a,_), VECTOR (b,_)) = ListPair.allEq malEq (a, b) + | malEq (VECTOR (a,_), LIST (b,_)) = ListPair.allEq malEq (a, b) + | malEq ( MAP (a,_), MAP (b,_)) = mapEq a b + | malEq _ = false +and mapEq a b = + a |> List.map (fn (k,va) => (va, malGet b k)) |> List.all (fn (va,SOME vb) => malEq (va, vb) | _ => false) andalso + b |> List.map (fn (k,vb) => (vb, malGet a k)) |> List.all (fn (vb,SOME va) => malEq (vb, va) | _ => false) + +and malGet m k = m |> List.find (fn (k',_) => malEq (k, k')) |> Option.map #2 +and malAssoc m k v = (k, v) :: (malDissoc m k) +and malDissoc m k = m |> List.filter (not o (fn (k', _) => malEq (k, k'))) + +fun malList xs = LIST (xs, NO_META) +fun malVector xs = VECTOR (xs, NO_META) +fun malMap kvps = MAP (kvps, NO_META) diff --git a/impls/sml/util.sml b/impls/sml/util.sml index b410fe07f4..6f60883fca 100644 --- a/impls/sml/util.sml +++ b/impls/sml/util.sml @@ -1,42 +1,42 @@ -fun takeWhile f xs = takeWhile' f [] xs -and takeWhile' f acc [] = rev acc - | takeWhile' f acc (x::xs) = if f x then takeWhile' f (x::acc) xs else rev acc - -infix 3 |> fun x |> f = f x - -fun eq a b = a = b - -fun optOrElse NONE b = b () - | optOrElse a _ = a - -fun valOrElse (SOME x) _ = x - | valOrElse a b = b () - -fun optIfNone b NONE = b () - | optIfNone _ a = a - -fun valIfNone _ (SOME a) = a - | valIfNone b _ = b () - -fun interleave (x::xs) (y::ys) = x :: y :: interleave xs ys - | interleave [] ys = ys - | interleave xs [] = xs - -fun identity x = x - -fun triml k s = String.extract (s, k, NONE) - -fun trimr k s = String.substring (s, 0, String.size s - k) - -fun malEscape s = String.translate (fn #"\"" => "\\\"" - | #"\n" => "\\n" - | #"\\" => "\\\\" - | c => String.str c) s - -fun malUnescape s = malUnescape' (String.explode s) -and malUnescape' (#"\\"::(#"\""::rest)) = "\"" ^ malUnescape' rest - | malUnescape' (#"\\"::(#"n" ::rest)) = "\n" ^ malUnescape' rest - | malUnescape' (#"\\"::(#"\\"::rest)) = "\\" ^ malUnescape' rest - | malUnescape' (c::rest) = (String.str c) ^ malUnescape' rest - | malUnescape' ([]) = "" - +fun takeWhile f xs = takeWhile' f [] xs +and takeWhile' f acc [] = rev acc + | takeWhile' f acc (x::xs) = if f x then takeWhile' f (x::acc) xs else rev acc + +infix 3 |> fun x |> f = f x + +fun eq a b = a = b + +fun optOrElse NONE b = b () + | optOrElse a _ = a + +fun valOrElse (SOME x) _ = x + | valOrElse a b = b () + +fun optIfNone b NONE = b () + | optIfNone _ a = a + +fun valIfNone _ (SOME a) = a + | valIfNone b _ = b () + +fun interleave (x::xs) (y::ys) = x :: y :: interleave xs ys + | interleave [] ys = ys + | interleave xs [] = xs + +fun identity x = x + +fun triml k s = String.extract (s, k, NONE) + +fun trimr k s = String.substring (s, 0, String.size s - k) + +fun malEscape s = String.translate (fn #"\"" => "\\\"" + | #"\n" => "\\n" + | #"\\" => "\\\\" + | c => String.str c) s + +fun malUnescape s = malUnescape' (String.explode s) +and malUnescape' (#"\\"::(#"\""::rest)) = "\"" ^ malUnescape' rest + | malUnescape' (#"\\"::(#"n" ::rest)) = "\n" ^ malUnescape' rest + | malUnescape' (#"\\"::(#"\\"::rest)) = "\\" ^ malUnescape' rest + | malUnescape' (c::rest) = (String.str c) ^ malUnescape' rest + | malUnescape' ([]) = "" + diff --git a/impls/swift/Makefile b/impls/swift/Makefile index 6372e0e043..fbd36e2e18 100644 --- a/impls/swift/Makefile +++ b/impls/swift/Makefile @@ -1,228 +1,228 @@ -################################################################################ -# -# Makefile for the Swift implementation of MAL. -# -# The MAL project consists of building up a dialect/subset of Clojure over a -# series of steps. Each step implements a new feature or concept in an easily -# understandable and approachable manner. Each step can be built on its own and -# tested. Each step is built from a step-specific "step.swift" file and a set -# of files common to all steps. -# -# The general approach in this file is to discover the set of "step" source -# files (step0_repl.swift, etc.), and build corresponding executable files -# (step0_repl, etc) from them and from the set of supporting Swift files. -# Since the set of "step" files is discovered on-the-fly, the rules to make -# those files are also generated on-the-fly using $(eval). -# -# The various "step0_repl.swift", etc., source files are actually generated -# from a file called "templates/step.swift". Since each "step" file -# incrementally builds towards the final, complete "step" file, -# "templates/step.swift" is -- for the most part -- a copy of this final "step" -# file with each line annotated with the step in which that line is introduced. -# Through the use of a simple filter program, the "templates/step.swift" file -# can then be processed to produce each intermediate "step" file. This Makefile -# takes care of performing that processing any time "templates/step.swift" -# changes. -# -# MAKE TARGETS: -# -# all: -# Make all step targets, (re)generating source files if needed. -# alls: -# (Re)generate source files, if needed. -# step0_repl, step1_read_print, etc.: -# Make the corresponding step target. -# s0...sN: -# Shortcuts for the previous targets. -# step0_repl.swift, step1_read_print.swift, etc.: -# (Re)generate source files for the corresponding step target, if -# needed. -# ss0...ssN: -# Shortcuts for the previous targets. -# clean: -# Delete all built executables. Generated source files are *not* -# deleted. -# dump: -# Print some Make variables for debugging. -# -# TODO: -# * Compile each .swift file into an intermediate .o file and link the .o -# files, rather than performing a complete build of all files any time -# any one of them is out-of-date. Here are the commands generated when -# using `swiftc -v`: -# -# /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/swift \ -# -frontend \ -# -c \ -# -primary-file stepA_mal.swift \ -# ./core.swift \ -# ./env.swift \ -# ./main.swift \ -# ./printer.swift \ -# ./reader.swift \ -# ./readline.swift \ -# ./types.swift \ -# -target x86_64-apple-darwin14.1.0 \ -# -target-cpu core2 \ -# -sdk /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.10.sdk \ -# -import-objc-header ./bridging-header.h \ -# -color-diagnostics \ -# -Onone \ -# -ledit \ -# -module-name stepA_mal \ -# -o /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/stepA_mal-e0a836.o -# ... Similar for each source file... -# /usr/bin/ld \ -# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/stepA_mal-e0a836.o \ -# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/core-28b620.o \ -# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/env-5d8422.o \ -# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/main-e79633.o \ -# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/printer-cdd3e5.o \ -# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/reader-bb188a.o \ -# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/readline-53df55.o \ -# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/types-7cb250.o \ -# -L /usr/lib \ -# -ledit \ -# -syslibroot \ -# /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.10.sdk \ -# -lSystem \ -# -arch x86_64 \ -# -L /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/swift/macosx \ -# -rpath /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/swift/macosx \ -# -macosx_version_min 10.10.0 \ -# -no_objc_category_merging \ -# -o stepA_mal -# -# * Consider adding a clean-dist (or similar) that deletes the generated -# "step" source files. -# -################################################################################ - -# -# Discover the set of "step" source files (those having the form -# "step<#>_foo.swift") -# -SRCS := $(wildcard ./step*.swift) - -# -# From the set of "step" source files, generate the set of executable files -# (those having the form "step<#>_foo") -# -EXES := $(patsubst %.swift,%,$(SRCS)) - -# -# Also generate references to any debug-symbol directories we may make when -g -# is specified. -# -DSYMS := $(patsubst %.swift,%.dSYM,$(SRCS)) - -# -# Given a name like "./step<#>_foo", return <#>. -# -# (Is there a better way to do this? $(patsubst) seems to be the most -# appropriate built-in command, but it doesn't seem powerful enough.) -# -# (I've included a `sed` version in case relying on bash is contraindicated.) -# -get_step_number = $(shell echo $(1) | sed -e "s/.*step\(.\).*/\1/") -#get_step_number = $(shell [[ $(1) =~ step(.)_.* ]] ; echo $${BASH_REMATCH[1]}) - -# -# Working from the list of discovered "step<#>_foo.swift" files, generate the -# list of step numbers. -# -get_all_step_numbers = $(foreach SRC,$(SRCS),$(call get_step_number,$(SRC))) - -# -# Generate the dependencies for the "all" target. This list has the form -# "s0 s1 ... sN" for all N returned by get_all_step_numbers. That is: -# -# all: s0 s1 ... sN -# -# Also create an "alls" target that just regenerates all the "step" files from -# the corresponding template file. -# -$(eval all: $(patsubst %,s%,$(call get_all_step_numbers))) -$(eval alls: $(patsubst %,ss%,$(call get_all_step_numbers))) - -# -# Generate the dependencies for the ".PHONY" target. That is: -# -# .PHONY: all clean dump s0 s1 ... sN -# -$(eval .PHONY: all clean dump $(patsubst %,s%,$(call get_all_step_numbers))) - -# -# Define the "EZ" targets, where "s0" builds "step0_repl", "s1" builds -# "step1_read_print", etc. That is: -# -# s0: step0_repl -# s1: step1_read_print -# ... -# sN: stepN_foo -# -# Also create corresponding targets that rebuild the sources files: -# -# ss0: step0_repl.swift -# ss1: step1_read_print.swift -# ... -# ssN: stepN_foo.swift -# -$(foreach EXE,$(EXES),$(eval s$(call get_step_number,$(EXE)): $(EXE))) -$(foreach SRC,$(SRCS),$(eval ss$(call get_step_number,$(SRC)): $(SRC))) - -# -# Various helpful variables. -# -DEV_DIR := $(firstword $(wildcard /Applications/Xcode-beta.app /Applications/Xcode.app)) -SWIFT := $(shell DEVELOPER_DIR="$(DEV_DIR)" xcrun --find swiftc 2>/dev/null) -SDKROOT := $(shell DEVELOPER_DIR="$(DEV_DIR)" xcrun --show-sdk-path 2>/dev/null) -STEP_TEMPLATE := ./templates/step.swift -FILTER := ./templates/filter_steps.sh -UTIL_SRC := $(filter-out $(STEP_TEMPLATE) $(SRCS),$(wildcard ./*.swift)) -ifndef TYPES -TYPES := CLASS -endif -ifeq ($(TYPES), ENUM) -UTIL_SRC := $(filter-out ./types_class.swift,$(UTIL_SRC)) -else -UTIL_SRC := $(filter-out ./types_enum.swift,$(UTIL_SRC)) -endif -OPT := -Ounchecked -whole-module-optimization -DEBUG := #-g -EXTRA := #-v -COMMON := $(UTIL_SRC) $(OPT) $(DEBUG) $(EXTRA) -import-objc-header ./bridging-header.h -L /usr/lib -ledit -sdk $(SDKROOT) - -# -# Build the executable from the input sources consisting of the appropriate -# "step" file and the supporting files in $(UTIL_SRC). -# -$(EXES) : % : %.swift $(UTIL_SRC) ./Makefile - @echo "Making : $@" - @$(SWIFT) $< $(COMMON) -o $@ - -# -# Build the "step" source file ("step<#>_foo.swift") from the step template -# file that combines all the steps in one file. -# -$(SRCS) : % : $(STEP_TEMPLATE) ./Makefile - @echo "Generating: $@" - @$(FILTER) $(call get_step_number,$@) $< $@ - -# -# Delete all of the build output (other than generated "step" source files) -# -clean: - @rm -rf $(EXES) $(DSYMS) - -# -# Display some variables for debugging. -# -dump: - @echo " SRCS = $(SRCS)" - @echo " EXES = $(EXES)" - @echo " DSYMS = $(DSYMS)" - @echo " UTIL = $(UTIL_SRC)" - @echo " SWIFT = $(SWIFT)" - @echo "SDKROOT = $(SDKROOT)" - @echo " STEPS = $(call get_all_step_numbers)" +################################################################################ +# +# Makefile for the Swift implementation of MAL. +# +# The MAL project consists of building up a dialect/subset of Clojure over a +# series of steps. Each step implements a new feature or concept in an easily +# understandable and approachable manner. Each step can be built on its own and +# tested. Each step is built from a step-specific "step.swift" file and a set +# of files common to all steps. +# +# The general approach in this file is to discover the set of "step" source +# files (step0_repl.swift, etc.), and build corresponding executable files +# (step0_repl, etc) from them and from the set of supporting Swift files. +# Since the set of "step" files is discovered on-the-fly, the rules to make +# those files are also generated on-the-fly using $(eval). +# +# The various "step0_repl.swift", etc., source files are actually generated +# from a file called "templates/step.swift". Since each "step" file +# incrementally builds towards the final, complete "step" file, +# "templates/step.swift" is -- for the most part -- a copy of this final "step" +# file with each line annotated with the step in which that line is introduced. +# Through the use of a simple filter program, the "templates/step.swift" file +# can then be processed to produce each intermediate "step" file. This Makefile +# takes care of performing that processing any time "templates/step.swift" +# changes. +# +# MAKE TARGETS: +# +# all: +# Make all step targets, (re)generating source files if needed. +# alls: +# (Re)generate source files, if needed. +# step0_repl, step1_read_print, etc.: +# Make the corresponding step target. +# s0...sN: +# Shortcuts for the previous targets. +# step0_repl.swift, step1_read_print.swift, etc.: +# (Re)generate source files for the corresponding step target, if +# needed. +# ss0...ssN: +# Shortcuts for the previous targets. +# clean: +# Delete all built executables. Generated source files are *not* +# deleted. +# dump: +# Print some Make variables for debugging. +# +# TODO: +# * Compile each .swift file into an intermediate .o file and link the .o +# files, rather than performing a complete build of all files any time +# any one of them is out-of-date. Here are the commands generated when +# using `swiftc -v`: +# +# /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/swift \ +# -frontend \ +# -c \ +# -primary-file stepA_mal.swift \ +# ./core.swift \ +# ./env.swift \ +# ./main.swift \ +# ./printer.swift \ +# ./reader.swift \ +# ./readline.swift \ +# ./types.swift \ +# -target x86_64-apple-darwin14.1.0 \ +# -target-cpu core2 \ +# -sdk /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.10.sdk \ +# -import-objc-header ./bridging-header.h \ +# -color-diagnostics \ +# -Onone \ +# -ledit \ +# -module-name stepA_mal \ +# -o /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/stepA_mal-e0a836.o +# ... Similar for each source file... +# /usr/bin/ld \ +# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/stepA_mal-e0a836.o \ +# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/core-28b620.o \ +# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/env-5d8422.o \ +# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/main-e79633.o \ +# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/printer-cdd3e5.o \ +# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/reader-bb188a.o \ +# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/readline-53df55.o \ +# /var/folders/dj/p3tx6v852sl88g79qvhhc2ch0000gp/T/types-7cb250.o \ +# -L /usr/lib \ +# -ledit \ +# -syslibroot \ +# /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.10.sdk \ +# -lSystem \ +# -arch x86_64 \ +# -L /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/swift/macosx \ +# -rpath /Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/swift/macosx \ +# -macosx_version_min 10.10.0 \ +# -no_objc_category_merging \ +# -o stepA_mal +# +# * Consider adding a clean-dist (or similar) that deletes the generated +# "step" source files. +# +################################################################################ + +# +# Discover the set of "step" source files (those having the form +# "step<#>_foo.swift") +# +SRCS := $(wildcard ./step*.swift) + +# +# From the set of "step" source files, generate the set of executable files +# (those having the form "step<#>_foo") +# +EXES := $(patsubst %.swift,%,$(SRCS)) + +# +# Also generate references to any debug-symbol directories we may make when -g +# is specified. +# +DSYMS := $(patsubst %.swift,%.dSYM,$(SRCS)) + +# +# Given a name like "./step<#>_foo", return <#>. +# +# (Is there a better way to do this? $(patsubst) seems to be the most +# appropriate built-in command, but it doesn't seem powerful enough.) +# +# (I've included a `sed` version in case relying on bash is contraindicated.) +# +get_step_number = $(shell echo $(1) | sed -e "s/.*step\(.\).*/\1/") +#get_step_number = $(shell [[ $(1) =~ step(.)_.* ]] ; echo $${BASH_REMATCH[1]}) + +# +# Working from the list of discovered "step<#>_foo.swift" files, generate the +# list of step numbers. +# +get_all_step_numbers = $(foreach SRC,$(SRCS),$(call get_step_number,$(SRC))) + +# +# Generate the dependencies for the "all" target. This list has the form +# "s0 s1 ... sN" for all N returned by get_all_step_numbers. That is: +# +# all: s0 s1 ... sN +# +# Also create an "alls" target that just regenerates all the "step" files from +# the corresponding template file. +# +$(eval all: $(patsubst %,s%,$(call get_all_step_numbers))) +$(eval alls: $(patsubst %,ss%,$(call get_all_step_numbers))) + +# +# Generate the dependencies for the ".PHONY" target. That is: +# +# .PHONY: all clean dump s0 s1 ... sN +# +$(eval .PHONY: all clean dump $(patsubst %,s%,$(call get_all_step_numbers))) + +# +# Define the "EZ" targets, where "s0" builds "step0_repl", "s1" builds +# "step1_read_print", etc. That is: +# +# s0: step0_repl +# s1: step1_read_print +# ... +# sN: stepN_foo +# +# Also create corresponding targets that rebuild the sources files: +# +# ss0: step0_repl.swift +# ss1: step1_read_print.swift +# ... +# ssN: stepN_foo.swift +# +$(foreach EXE,$(EXES),$(eval s$(call get_step_number,$(EXE)): $(EXE))) +$(foreach SRC,$(SRCS),$(eval ss$(call get_step_number,$(SRC)): $(SRC))) + +# +# Various helpful variables. +# +DEV_DIR := $(firstword $(wildcard /Applications/Xcode-beta.app /Applications/Xcode.app)) +SWIFT := $(shell DEVELOPER_DIR="$(DEV_DIR)" xcrun --find swiftc 2>/dev/null) +SDKROOT := $(shell DEVELOPER_DIR="$(DEV_DIR)" xcrun --show-sdk-path 2>/dev/null) +STEP_TEMPLATE := ./templates/step.swift +FILTER := ./templates/filter_steps.sh +UTIL_SRC := $(filter-out $(STEP_TEMPLATE) $(SRCS),$(wildcard ./*.swift)) +ifndef TYPES +TYPES := CLASS +endif +ifeq ($(TYPES), ENUM) +UTIL_SRC := $(filter-out ./types_class.swift,$(UTIL_SRC)) +else +UTIL_SRC := $(filter-out ./types_enum.swift,$(UTIL_SRC)) +endif +OPT := -Ounchecked -whole-module-optimization +DEBUG := #-g +EXTRA := #-v +COMMON := $(UTIL_SRC) $(OPT) $(DEBUG) $(EXTRA) -import-objc-header ./bridging-header.h -L /usr/lib -ledit -sdk $(SDKROOT) + +# +# Build the executable from the input sources consisting of the appropriate +# "step" file and the supporting files in $(UTIL_SRC). +# +$(EXES) : % : %.swift $(UTIL_SRC) ./Makefile + @echo "Making : $@" + @$(SWIFT) $< $(COMMON) -o $@ + +# +# Build the "step" source file ("step<#>_foo.swift") from the step template +# file that combines all the steps in one file. +# +$(SRCS) : % : $(STEP_TEMPLATE) ./Makefile + @echo "Generating: $@" + @$(FILTER) $(call get_step_number,$@) $< $@ + +# +# Delete all of the build output (other than generated "step" source files) +# +clean: + @rm -rf $(EXES) $(DSYMS) + +# +# Display some variables for debugging. +# +dump: + @echo " SRCS = $(SRCS)" + @echo " EXES = $(EXES)" + @echo " DSYMS = $(DSYMS)" + @echo " UTIL = $(UTIL_SRC)" + @echo " SWIFT = $(SWIFT)" + @echo "SDKROOT = $(SDKROOT)" + @echo " STEPS = $(call get_all_step_numbers)" diff --git a/impls/swift/bridging-header.h b/impls/swift/bridging-header.h index 9679345cae..ff9522b9cb 100644 --- a/impls/swift/bridging-header.h +++ b/impls/swift/bridging-header.h @@ -1,15 +1,15 @@ -// This is the "bridging" file for the Swift version of MAL. A bridging file -// brings in C/ObjC types and makes them available to Swift source code, using -// the type conversion process described in: -// -// https://developer.apple.com/library/prerelease/ios/documentation/Swift/Conceptual/BuildingCocoaApps/InteractingWithCAPIs.html#//apple_ref/doc/uid/TP40014216-CH8-XID_11 -// -// The mechanism for creating and using a bridging file is only documented for -// Xcode users. However, the following article describes how to specify a -// bridging file on the command line: -// -// http://stackoverflow.com/questions/24131476/compiling-and-linking-swift-plus-objective-c-code-from-the-os-x-command-line -// - -#include -#include +// This is the "bridging" file for the Swift version of MAL. A bridging file +// brings in C/ObjC types and makes them available to Swift source code, using +// the type conversion process described in: +// +// https://developer.apple.com/library/prerelease/ios/documentation/Swift/Conceptual/BuildingCocoaApps/InteractingWithCAPIs.html#//apple_ref/doc/uid/TP40014216-CH8-XID_11 +// +// The mechanism for creating and using a bridging file is only documented for +// Xcode users. However, the following article describes how to specify a +// bridging file on the command line: +// +// http://stackoverflow.com/questions/24131476/compiling-and-linking-swift-plus-objective-c-code-from-the-os-x-command-line +// + +#include +#include diff --git a/impls/swift/core.swift b/impls/swift/core.swift index 8b600b373f..0dd2166e8d 100644 --- a/impls/swift/core.swift +++ b/impls/swift/core.swift @@ -1,770 +1,770 @@ -//****************************************************************************** -// MAL - core -//****************************************************************************** - -import Foundation - -// This is a simple type distinct from all MalVal types so that we can pass a -// sequence to a function and be able to distinguish between those functions -// that want a sequence as a parameter and those that want a sequence that holds -// the rest of the function parameters. -// -final class MalVarArgs { - init(_ value: MalSequence) { self.value = value } - init(_ value: MalVal) { self.value = as_sequence(value) } - let value: MalSequence -} - -private func fn_eq(obj1: MalVal, obj2: MalVal) throws -> Bool { - return obj1 == obj2 -} - -private func fn_throw(exception: MalVal) throws -> MalVal { - try throw_error(exception) -} - -private func fn_nilQ(obj: MalVal) throws -> Bool { - return is_nil(obj) -} - -private func fn_trueQ(obj: MalVal) throws -> Bool { - return is_true(obj) -} - -private func fn_falseQ(obj: MalVal) throws -> Bool { - return is_false(obj) -} - -private func fn_stringQ(obj: MalVal) throws -> Bool { - return is_string(obj) -} - -private func fn_symbol(s: String) throws -> MalVal { - return make_symbol(s) -} - -private func fn_symbolQ(obj: MalVal) throws -> Bool { - return is_symbol(obj) -} - -private func fn_keyword(s: MalVal) throws -> MalVal { - if is_keyword(s) { - return s - } - if is_string(s) { - return make_keyword(as_string(s)) - } - try throw_error("expected string or keyword") -} - -private func fn_keywordQ(obj: MalVal) throws -> Bool { - return is_keyword(obj) -} - -private func fn_numberQ(obj: MalVal) throws -> Bool { - return is_integer(obj) || is_float(obj) -} - -private func fn_functionQ(obj: MalVal) throws -> Bool { - return is_function(obj) -} - -private func fn_macroQ(obj: MalVal) throws -> Bool { - return is_macro(obj) -} - -private func fn_prstr(args: MalVarArgs) throws -> String { - let args_str_array = args.value.map { pr_str($0, true) } - return args_str_array.joinWithSeparator(" ") -} - -private func fn_str(args: MalVarArgs) throws -> String { - let args_str_array = args.value.map { pr_str($0, false) } - return args_str_array.joinWithSeparator("") -} - -private func fn_prn(args: MalVarArgs) { - let args_str_array = args.value.map { pr_str($0, true) } - let args_str = args_str_array.joinWithSeparator(" ") - print(args_str) -} - -private func fn_println(args: MalVarArgs) { - let args_str_array = args.value.map { pr_str($0, false) } - let args_str = args_str_array.joinWithSeparator(" ") - print(args_str) -} - -private func fn_readstring(s: String) throws -> MalVal { - return try read_str(s) -} - -private func fn_readline(s: String) throws -> String? { - return _readline(s) -} - -private func fn_slurp(s: String) throws -> MalVal { - do { - let result = try String(contentsOfFile: s, encoding: NSUTF8StringEncoding) - return make_string(result) - } catch let error as NSError { - try throw_error("unknown error reading file \(error)") - } -} - -private func fn_lt(arg1: MalIntType, arg2: MalIntType) throws -> Bool { - return arg1 < arg2 -} - -private func fn_lte(arg1: MalIntType, arg2: MalIntType) throws -> Bool { - return arg1 <= arg2 -} - -private func fn_gt(arg1: MalIntType, arg2: MalIntType) throws -> Bool { - return arg1 > arg2 -} - -private func fn_gte(arg1: MalIntType, arg2: MalIntType) throws -> Bool { - return arg1 >= arg2 -} - -private func fn_add(arg1: MalIntType, arg2: MalIntType) throws -> MalIntType { - return arg1 + arg2 -} - -private func fn_subtract(arg1: MalIntType, arg2: MalIntType) throws -> MalIntType { - return arg1 - arg2 -} - -private func fn_multiply(arg1: MalIntType, arg2: MalIntType) throws -> MalIntType { - return arg1 * arg2 -} - -private func fn_divide(arg1: MalIntType, arg2: MalIntType) throws -> MalIntType { - return arg1 / arg2 -} - -private func fn_timems() throws -> MalIntType { - var time = timeval(tv_sec: 0, tv_usec: 0) - let res = gettimeofday(&time, nil) - if res == 0 { - return (MalIntType(time.tv_sec) * 1_000_000 + MalIntType(time.tv_usec)) / 1000 - } - return -1 -} - -private func fn_list(args: MalVarArgs) throws -> MalVal { - return make_list(args.value) -} - -private func fn_listQ(obj: MalVal) throws -> Bool { - return is_list(obj) -} - -private func fn_vector(args: MalVarArgs) throws -> MalVal { - return make_vector(args.value) -} - -private func fn_vectorQ(obj: MalVal) throws -> Bool { - return is_vector(obj) -} - -private func fn_hashmap(args: MalVarArgs) throws -> MalVal { - return make_hashmap(args.value) -} - -private func fn_hashmapQ(obj: MalVal) throws -> Bool { - return is_hashmap(obj) -} - -private func fn_assoc(hash: MalHashMap, args: MalVarArgs) throws -> MalVal { - guard args.value.count % 2 == 0 else { - try throw_error("expected even number of elements, got \(args.value.count)") - } - var new_dictionary = hash.hash - for var index: MalIntType = 0; index < args.value.count; index += 2 { - new_dictionary[try! args.value.nth(index)] = try! args.value.nth(index + 1) - } - return make_hashmap(new_dictionary) -} - -private func fn_dissoc(hash: MalHashMap, args: MalVarArgs) throws -> MalVal { - var new_dictionary = hash.hash - for value in args.value { - new_dictionary.removeValueForKey(value) - } - return make_hashmap(new_dictionary) -} - -private func fn_get(obj: MalVal, key: MalVal) throws -> MalVal { - if let as_vec = as_vectorQ(obj) { - guard let index = as_integerQ(key) else { - try throw_error("expected integer key for get(vector), got \(key)") - } - let n = as_inttype(index) - guard n >= as_vec.count else { try throw_error("index out of range: \(n) >= \(as_vec.count)") } - return try! as_vec.nth(n) - } - if let as_hash = as_hashmapQ(obj) { - if let value = as_hash.value_for(key) { return value } - return make_nil() - } - if is_nil(obj) { - return obj - } - try throw_error("get called on unsupported type: \(obj)") -} - -private func fn_containsQ(obj: MalVal, key: MalVal) throws -> MalVal { - if let as_vec = as_vectorQ(obj) { - guard let index = as_integerQ(key) else { - try throw_error("expected integer key for contains(vector), got \(key)") - } - let n = as_inttype(index) - return n < as_vec.count ? make_true() : make_false() - } - if let as_hash = as_hashmapQ(obj) { - return as_hash.value_for(key) != nil ? make_true() : make_false() - } - try throw_error("contains? called on unsupported type: \(obj)") -} - -private func fn_keys(hash: MalHashMap) throws -> MalVal { - return hash.keys -} - -private func fn_values(hash: MalHashMap) throws -> MalVal { - return hash.values -} - -private func fn_sequentialQ(obj: MalVal) throws -> Bool { - return is_sequence(obj) -} - -private func fn_cons(first: MalVal, rest: MalSequence) throws -> MalVal { - return rest.cons(first) -} - -private func fn_concat(args: MalVarArgs) throws -> MalVal { - var result = make_list() - for arg in args.value { - guard let arg_as_seq = as_sequenceQ(arg) else { - try throw_error("expected list, got \(arg)") - } - result = try! as_sequence(result).concat(arg_as_seq) - } - return result -} - -private func fn_vec(seq: MalSequence) throws -> MalVal { - return make_vector(seq) -} - -private func fn_nth(list: MalSequence, index: MalIntType) throws -> MalVal { - return try list.nth(index) -} - -private func fn_first(arg: MalVal) throws -> MalVal { - if is_nil(arg) { - return arg - } - if let list = as_sequenceQ(arg) { - return list.first() - } - try throw_error("expected list, got \(arg)") -} - -private func fn_rest(arg: MalVal) throws -> MalVal { - if is_nil(arg) { - return make_list() - } - if let seq = as_sequenceQ(arg) { - return seq.rest() - } - try throw_error("expected sequence, got \(arg)") -} - -private func fn_emptyQ(obj: MalVal) throws -> Bool { - if let list = as_sequenceQ(obj) { - return list.isEmpty - } - return true -} - -private func fn_count(obj: MalVal) throws -> MalIntType { - if is_nil(obj) { - return 0 - } - if let as_seq = as_sequenceQ(obj) { - return as_seq.count - } - if let as_hash = as_hashmapQ(obj) { - return as_hash.count - } - if let as_str = as_stringQ(obj) { - return MalIntType(as_stringtype(as_str).characters.count) - } - return 0 -} - -private func fn_apply(args: MalVarArgs) throws -> MalVal { - guard args.value.count >= 2 else { - try throw_error("expected at least 2 arguments to apply, got \(args.value.count)") - } - - let first = args.value.first() - let middle = args.value.range_from(1, to: args.value.count - 1) - let last = args.value.last() - - guard let fn = as_functionQ(first) else { - try throw_error("expected function for first argument to apply, got \(first)") - } - guard let seq = as_sequenceQ(last) else { - try throw_error("expected sequence for last argument to apply, got \(last)") - } - let exprs = try! as_sequence(middle).concat(seq) - return try fn.apply(as_sequence(exprs)) -} - -private func fn_map(fn: MalFunction, list: MalSequence) throws -> MalVal { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for var index: MalIntType = 0; index < list.count; ++index { - let apply_res = try fn.apply(as_sequence(make_list_from(try! list.nth(index)))) - result.append(apply_res) - } - return make_list(result) -} - -private func fn_conj(first: MalSequence, rest: MalVarArgs) throws -> MalVal { - return try first.conj(rest.value) -} - -private func fn_seq(seq: MalVal) throws -> MalVal { - if let list = as_listQ(seq) { - return list.count > 0 ? list : make_nil() - } else if let vector = as_vectorQ(seq) { - return vector.count > 0 ? make_list(vector) : make_nil() - } else if let str = as_stringQ(seq) { - if str.string.characters.count == 0 { return make_nil() } - return make_list(str.string.characters.map { make_string(String($0)) }) - } else if is_nil(seq) { - return make_nil() - } else { - try throw_error("seq: called with non-sequence") - } - return seq -} - -private func fn_meta(obj: MalVal) throws -> MalVal { - if let meta = get_meta(obj) { - return meta - } - - return make_nil() -} - -private func fn_withmeta(form: MalVal, meta: MalVal) throws -> MalVal { - return with_meta(form, meta) -} - -private func fn_atom(obj: MalVal) throws -> MalVal { - return make_atom(obj) -} - -private func fn_atomQ(obj: MalVal) throws -> Bool { - return is_atom(obj) -} - -private func fn_deref(atom: MalAtom) throws -> MalVal { - return atom.object -} - -private func fn_resetBang(atom: MalAtom, obj: MalVal) throws -> MalVal { - return atom.set_object(obj) -} - -private func fn_swapBang(let atom: MalAtom, fn: MalFunction, rest: MalVarArgs) throws -> MalVal { - var new_args = make_list_from(atom.object) - new_args = try as_sequence(new_args).concat(rest.value) - let result = try fn.apply(as_sequence(new_args)) - return atom.set_object(result) -} - -//****************************************************************************** -// -// The facility for invoking built-in functions makes use of a name -> -// function-pointer table (defined down below). The function-pointers accept a -// sequence of MalVals and return a MalVal as a result. Each built-in function -// that does actual work, on the other hand, may expect a different set of -// parameters of different types, and may naturally return a result of any type. -// In order to convert between these two types of interfaces, we have these -// unwrap_args functions. These functions implement the (MalSequence) -> MalVal -// interface expected by EVAL, and convert that information into Ints, Strings, -// etc. expected by the built-in functions. -// -//****************************************************************************** - -private func with_one_parameter(args: MalSequence, @noescape fn: (MalVal) throws -> MalVal) throws -> MalVal { - guard args.count >= 1 else { try throw_error("expected at least 1 parameter, got \(args.count)") } - let arg1 = try! args.nth(0) - return try fn(arg1) -} - -private func with_two_parameters(args: MalSequence, @noescape fn: (MalVal, MalVal) throws -> MalVal) throws -> MalVal { - guard args.count >= 2 else { try throw_error("expected at least 2 parameter, got \(args.count)") } - let arg1 = try! args.nth(0) - let arg2 = try! args.nth(1) - return try fn(arg1, arg2) -} - -// ========== 0-parameter functions ========== - -// () -> MalIntType - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: () throws -> MalIntType) throws -> MalVal { - return make_integer(try fn()) -} - -// () -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: () throws -> MalVal) throws -> MalVal { - return try fn() -} - -// ========== 1-parameter functions ========== - -// (MalAtom) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalAtom) throws -> MalVal) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - guard let atom = as_atomQ(arg1) else { - try throw_error("expected atom, got \(arg1)") - } - return try fn(atom) - } -} - -// (MalHashMap) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalHashMap) throws -> MalVal) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - guard let hash = as_hashmapQ(arg1) else { - try throw_error("expected hashmap, got \(arg1)") - } - return try fn(hash) - } -} - -// (MalSequence) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalSequence) throws -> MalVal) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - guard let seq = as_sequenceQ(arg1) else { - try throw_error("expected list, got \(arg1)") - } - return try fn(seq) - } -} - -// (MalVal) -> Bool - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal) throws -> Bool) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - return try fn(arg1) ? make_true() : make_false() - } -} - -// (MalVal) -> MalIntType - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal) throws -> MalIntType) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - return make_integer(try fn(arg1)) - } -} - -// (MalVal) -> MalVal - -func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal) throws -> MalVal) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - return try fn(arg1) - } -} - -// (String) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (String) throws -> MalVal) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - guard let str = as_stringQ(arg1) else { - try throw_error("expected string, got \(arg1)") - } - return try fn(as_stringtype(str)) - } -} - -// (String) -> MalVal? - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (String) throws -> MalVal?) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - guard let str = as_stringQ(arg1) else { - try throw_error("expected string, got \(arg1)") - } - let res = try fn(as_stringtype(str)) - return res != nil ? res! : make_nil() - } -} - -// (String) -> String - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (String) throws -> String) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - guard let str = as_stringQ(arg1) else { - try throw_error("expected string, got \(arg1)") - } - return make_string(try fn(as_stringtype(str))) - } -} - -// (String) -> String? - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (String) throws -> String?) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - guard let str = as_stringQ(arg1) else { - try throw_error("expected string, got \(arg1)") - } - let res = try fn(as_stringtype(str)) - return res != nil ? make_string(res!) : make_nil() - } -} - -// ========== 2-parameter functions ========== - -// (MalIntType, MalIntType) -> Bool - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalIntType, MalIntType) throws -> Bool) throws -> MalVal { - return try with_two_parameters(args) { (arg1, arg2) -> MalVal in - guard let int1 = as_integerQ(arg1) else { - try throw_error("expected number, got \(arg1)") - } - guard let int2 = as_integerQ(arg2) else { - try throw_error("expected number, got \(arg2)") - } - return try fn(as_inttype(int1), as_inttype(int2)) ? make_true() : make_false() - } -} - -// (MalIntType, MalIntType) -> MalIntType - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalIntType, MalIntType) throws -> MalIntType) throws -> MalVal { - return try with_two_parameters(args) { (arg1, arg2) -> MalVal in - guard let int1 = as_integerQ(arg1) else { - try throw_error("expected number, got \(arg1)") - } - guard let int2 = as_integerQ(arg2) else { - try throw_error("expected number, got \(arg2)") - } - return make_integer(try fn(as_inttype(int1), as_inttype(int2))) - } -} - -// (MalAtom, MalVal) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalAtom, MalVal) throws -> MalVal) throws -> MalVal { - return try with_two_parameters(args) { (arg1, arg2) -> MalVal in - guard let atom = as_atomQ(arg1) else { - try throw_error("expected atom, got \(arg1)") - } - return try fn(atom, arg2) - } -} - -// (MalFunction, MalSequence) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalFunction, MalSequence) throws -> MalVal) throws -> MalVal { - return try with_two_parameters(args) { (arg1, arg2) -> MalVal in - guard let fn1 = as_functionQ(arg1) else { - try throw_error("expected function, got \(arg1)") - } - guard let seq2 = as_sequenceQ(arg2) else { - try throw_error("expected sequence, got \(arg2)") - } - return try fn(fn1, seq2) - } -} - -// (MalSequence, MalIntType) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalSequence, MalIntType) throws -> MalVal) throws -> MalVal { - return try with_two_parameters(args) { (arg1, arg2) -> MalVal in - guard let seq = as_sequenceQ(arg1) else { - try throw_error("expected sequence, got \(arg1)") - } - guard let int = as_integerQ(arg2) else { - try throw_error("expected number, got \(arg2)") - } - return try fn(seq, as_inttype(int)) - } -} - -// (MalVal, MalSequence) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal, MalSequence) throws -> MalVal) throws -> MalVal { - return try with_two_parameters(args) { (arg1, arg2) -> MalVal in - guard let seq = as_sequenceQ(arg2) else { - try throw_error("expected sequence, got \(arg2)") - } - return try fn(arg1, seq) - } -} - -// (MalVal, MalVal) -> Bool - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal, MalVal) throws -> Bool) throws -> MalVal { - return try with_two_parameters(args) { (arg1, arg2) -> MalVal in - return try fn(arg1, arg2) ? make_true() : make_false() - } -} - -// (MalVal, MalVal) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal, MalVal) throws -> MalVal) throws -> MalVal { - return try with_two_parameters(args) { (arg1, arg2) -> MalVal in - return try fn(arg1, arg2) - } -} - -// ========== Variadic functions ========== - -// (MalVarArgs) -> () - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVarArgs) throws -> ()) throws -> MalVal { - try fn(MalVarArgs(args)) - return make_nil() -} - -// (MalVarArgs) -> String - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVarArgs) throws -> String) throws -> MalVal { - return make_string(try fn(MalVarArgs(args))) -} - -// (MalVarArgs) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVarArgs) throws -> MalVal) throws -> MalVal { - return try fn(MalVarArgs(args)) -} - -// (MalAtom, MalFunction, MalVarArgs) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalAtom, MalFunction, MalVarArgs) throws -> MalVal) throws -> MalVal { - return try with_two_parameters(args) { (arg1, arg2) -> MalVal in - guard let atom = as_atomQ(arg1) else { - try throw_error("expected atom, got \(arg1)") - } - guard let fn2 = as_functionQ(arg2) else { - try throw_error("expected function, got \(arg2)") - } - return try fn(atom, fn2, MalVarArgs(as_sequence(args.rest()).rest())) - } -} - -// (MalHashMap, MalVarArgs) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalHashMap, MalVarArgs) throws -> MalVal) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - guard let hash = as_hashmapQ(arg1) else { - try throw_error("expected hashmap, got \(arg1)") - } - return try fn(hash, MalVarArgs(args.rest())) - } -} - -// (MalSequence, MalVarArgs) -> MalVal - -private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalSequence, MalVarArgs) throws -> MalVal) throws -> MalVal { - return try with_one_parameter(args) { (arg1) -> MalVal in - guard let seq = as_sequenceQ(arg1) else { - try throw_error("expected sequence, got \(arg1)") - } - return try fn(seq, MalVarArgs(args.rest())) - } -} - -// *o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o* - -let ns: [String: MalBuiltin.Signature] = [ - "=": { try unwrap_args($0, forFunction: fn_eq) }, - "throw": { try unwrap_args($0, forFunction: fn_throw) }, - - "nil?": { try unwrap_args($0, forFunction: fn_nilQ) }, - "true?": { try unwrap_args($0, forFunction: fn_trueQ) }, - "false?": { try unwrap_args($0, forFunction: fn_falseQ) }, - "string?": { try unwrap_args($0, forFunction: fn_stringQ) }, - "symbol": { try unwrap_args($0, forFunction: fn_symbol) }, - "symbol?": { try unwrap_args($0, forFunction: fn_symbolQ) }, - "keyword": { try unwrap_args($0, forFunction: fn_keyword) }, - "keyword?": { try unwrap_args($0, forFunction: fn_keywordQ) }, - "number?": { try unwrap_args($0, forFunction: fn_numberQ) }, - "fn?": { try unwrap_args($0, forFunction: fn_functionQ) }, - "macro?": { try unwrap_args($0, forFunction: fn_macroQ) }, - - "pr-str": { try unwrap_args($0, forFunction: fn_prstr) }, - "str": { try unwrap_args($0, forFunction: fn_str) }, - "prn": { try unwrap_args($0, forFunction: fn_prn) }, - "println": { try unwrap_args($0, forFunction: fn_println) }, - "read-string": { try unwrap_args($0, forFunction: fn_readstring) }, - "readline": { try unwrap_args($0, forFunction: fn_readline) }, - "slurp": { try unwrap_args($0, forFunction: fn_slurp) }, - - "<": { try unwrap_args($0, forFunction: fn_lt) }, - "<=": { try unwrap_args($0, forFunction: fn_lte) }, - ">": { try unwrap_args($0, forFunction: fn_gt) }, - ">=": { try unwrap_args($0, forFunction: fn_gte) }, - "+": { try unwrap_args($0, forFunction: fn_add) }, - "-": { try unwrap_args($0, forFunction: fn_subtract) }, - "*": { try unwrap_args($0, forFunction: fn_multiply) }, - "/": { try unwrap_args($0, forFunction: fn_divide) }, - "time-ms": { try unwrap_args($0, forFunction: fn_timems) }, - - "list": { try unwrap_args($0, forFunction: fn_list) }, - "list?": { try unwrap_args($0, forFunction: fn_listQ) }, - "vector": { try unwrap_args($0, forFunction: fn_vector) }, - "vector?": { try unwrap_args($0, forFunction: fn_vectorQ) }, - "hash-map": { try unwrap_args($0, forFunction: fn_hashmap) }, - "map?": { try unwrap_args($0, forFunction: fn_hashmapQ) }, - "assoc": { try unwrap_args($0, forFunction: fn_assoc) }, - "dissoc": { try unwrap_args($0, forFunction: fn_dissoc) }, - "get": { try unwrap_args($0, forFunction: fn_get) }, - "contains?": { try unwrap_args($0, forFunction: fn_containsQ) }, - "keys": { try unwrap_args($0, forFunction: fn_keys) }, - "vals": { try unwrap_args($0, forFunction: fn_values) }, - - "sequential?": { try unwrap_args($0, forFunction: fn_sequentialQ) }, - "cons": { try unwrap_args($0, forFunction: fn_cons) }, - "concat": { try unwrap_args($0, forFunction: fn_concat) }, - "vec": { try unwrap_args($0, forFunction: fn_vec) }, - "nth": { try unwrap_args($0, forFunction: fn_nth) }, - "first": { try unwrap_args($0, forFunction: fn_first) }, - "rest": { try unwrap_args($0, forFunction: fn_rest) }, - "empty?": { try unwrap_args($0, forFunction: fn_emptyQ) }, - "count": { try unwrap_args($0, forFunction: fn_count) }, - "apply": { try unwrap_args($0, forFunction: fn_apply) }, - "map": { try unwrap_args($0, forFunction: fn_map) }, - - "conj": { try unwrap_args($0, forFunction: fn_conj) }, - "seq": { try unwrap_args($0, forFunction: fn_seq) }, - - "meta": { try unwrap_args($0, forFunction: fn_meta) }, - "with-meta": { try unwrap_args($0, forFunction: fn_withmeta) }, - "atom": { try unwrap_args($0, forFunction: fn_atom) }, - "atom?": { try unwrap_args($0, forFunction: fn_atomQ) }, - "deref": { try unwrap_args($0, forFunction: fn_deref) }, - "reset!": { try unwrap_args($0, forFunction: fn_resetBang) }, - "swap!": { try unwrap_args($0, forFunction: fn_swapBang) }, -] - -func load_builtins(env: Environment) { - for (name, fn) in ns { - env.set(as_symbol(make_symbol(name)), make_builtin(fn)) - } -} +//****************************************************************************** +// MAL - core +//****************************************************************************** + +import Foundation + +// This is a simple type distinct from all MalVal types so that we can pass a +// sequence to a function and be able to distinguish between those functions +// that want a sequence as a parameter and those that want a sequence that holds +// the rest of the function parameters. +// +final class MalVarArgs { + init(_ value: MalSequence) { self.value = value } + init(_ value: MalVal) { self.value = as_sequence(value) } + let value: MalSequence +} + +private func fn_eq(obj1: MalVal, obj2: MalVal) throws -> Bool { + return obj1 == obj2 +} + +private func fn_throw(exception: MalVal) throws -> MalVal { + try throw_error(exception) +} + +private func fn_nilQ(obj: MalVal) throws -> Bool { + return is_nil(obj) +} + +private func fn_trueQ(obj: MalVal) throws -> Bool { + return is_true(obj) +} + +private func fn_falseQ(obj: MalVal) throws -> Bool { + return is_false(obj) +} + +private func fn_stringQ(obj: MalVal) throws -> Bool { + return is_string(obj) +} + +private func fn_symbol(s: String) throws -> MalVal { + return make_symbol(s) +} + +private func fn_symbolQ(obj: MalVal) throws -> Bool { + return is_symbol(obj) +} + +private func fn_keyword(s: MalVal) throws -> MalVal { + if is_keyword(s) { + return s + } + if is_string(s) { + return make_keyword(as_string(s)) + } + try throw_error("expected string or keyword") +} + +private func fn_keywordQ(obj: MalVal) throws -> Bool { + return is_keyword(obj) +} + +private func fn_numberQ(obj: MalVal) throws -> Bool { + return is_integer(obj) || is_float(obj) +} + +private func fn_functionQ(obj: MalVal) throws -> Bool { + return is_function(obj) +} + +private func fn_macroQ(obj: MalVal) throws -> Bool { + return is_macro(obj) +} + +private func fn_prstr(args: MalVarArgs) throws -> String { + let args_str_array = args.value.map { pr_str($0, true) } + return args_str_array.joinWithSeparator(" ") +} + +private func fn_str(args: MalVarArgs) throws -> String { + let args_str_array = args.value.map { pr_str($0, false) } + return args_str_array.joinWithSeparator("") +} + +private func fn_prn(args: MalVarArgs) { + let args_str_array = args.value.map { pr_str($0, true) } + let args_str = args_str_array.joinWithSeparator(" ") + print(args_str) +} + +private func fn_println(args: MalVarArgs) { + let args_str_array = args.value.map { pr_str($0, false) } + let args_str = args_str_array.joinWithSeparator(" ") + print(args_str) +} + +private func fn_readstring(s: String) throws -> MalVal { + return try read_str(s) +} + +private func fn_readline(s: String) throws -> String? { + return _readline(s) +} + +private func fn_slurp(s: String) throws -> MalVal { + do { + let result = try String(contentsOfFile: s, encoding: NSUTF8StringEncoding) + return make_string(result) + } catch let error as NSError { + try throw_error("unknown error reading file \(error)") + } +} + +private func fn_lt(arg1: MalIntType, arg2: MalIntType) throws -> Bool { + return arg1 < arg2 +} + +private func fn_lte(arg1: MalIntType, arg2: MalIntType) throws -> Bool { + return arg1 <= arg2 +} + +private func fn_gt(arg1: MalIntType, arg2: MalIntType) throws -> Bool { + return arg1 > arg2 +} + +private func fn_gte(arg1: MalIntType, arg2: MalIntType) throws -> Bool { + return arg1 >= arg2 +} + +private func fn_add(arg1: MalIntType, arg2: MalIntType) throws -> MalIntType { + return arg1 + arg2 +} + +private func fn_subtract(arg1: MalIntType, arg2: MalIntType) throws -> MalIntType { + return arg1 - arg2 +} + +private func fn_multiply(arg1: MalIntType, arg2: MalIntType) throws -> MalIntType { + return arg1 * arg2 +} + +private func fn_divide(arg1: MalIntType, arg2: MalIntType) throws -> MalIntType { + return arg1 / arg2 +} + +private func fn_timems() throws -> MalIntType { + var time = timeval(tv_sec: 0, tv_usec: 0) + let res = gettimeofday(&time, nil) + if res == 0 { + return (MalIntType(time.tv_sec) * 1_000_000 + MalIntType(time.tv_usec)) / 1000 + } + return -1 +} + +private func fn_list(args: MalVarArgs) throws -> MalVal { + return make_list(args.value) +} + +private func fn_listQ(obj: MalVal) throws -> Bool { + return is_list(obj) +} + +private func fn_vector(args: MalVarArgs) throws -> MalVal { + return make_vector(args.value) +} + +private func fn_vectorQ(obj: MalVal) throws -> Bool { + return is_vector(obj) +} + +private func fn_hashmap(args: MalVarArgs) throws -> MalVal { + return make_hashmap(args.value) +} + +private func fn_hashmapQ(obj: MalVal) throws -> Bool { + return is_hashmap(obj) +} + +private func fn_assoc(hash: MalHashMap, args: MalVarArgs) throws -> MalVal { + guard args.value.count % 2 == 0 else { + try throw_error("expected even number of elements, got \(args.value.count)") + } + var new_dictionary = hash.hash + for var index: MalIntType = 0; index < args.value.count; index += 2 { + new_dictionary[try! args.value.nth(index)] = try! args.value.nth(index + 1) + } + return make_hashmap(new_dictionary) +} + +private func fn_dissoc(hash: MalHashMap, args: MalVarArgs) throws -> MalVal { + var new_dictionary = hash.hash + for value in args.value { + new_dictionary.removeValueForKey(value) + } + return make_hashmap(new_dictionary) +} + +private func fn_get(obj: MalVal, key: MalVal) throws -> MalVal { + if let as_vec = as_vectorQ(obj) { + guard let index = as_integerQ(key) else { + try throw_error("expected integer key for get(vector), got \(key)") + } + let n = as_inttype(index) + guard n >= as_vec.count else { try throw_error("index out of range: \(n) >= \(as_vec.count)") } + return try! as_vec.nth(n) + } + if let as_hash = as_hashmapQ(obj) { + if let value = as_hash.value_for(key) { return value } + return make_nil() + } + if is_nil(obj) { + return obj + } + try throw_error("get called on unsupported type: \(obj)") +} + +private func fn_containsQ(obj: MalVal, key: MalVal) throws -> MalVal { + if let as_vec = as_vectorQ(obj) { + guard let index = as_integerQ(key) else { + try throw_error("expected integer key for contains(vector), got \(key)") + } + let n = as_inttype(index) + return n < as_vec.count ? make_true() : make_false() + } + if let as_hash = as_hashmapQ(obj) { + return as_hash.value_for(key) != nil ? make_true() : make_false() + } + try throw_error("contains? called on unsupported type: \(obj)") +} + +private func fn_keys(hash: MalHashMap) throws -> MalVal { + return hash.keys +} + +private func fn_values(hash: MalHashMap) throws -> MalVal { + return hash.values +} + +private func fn_sequentialQ(obj: MalVal) throws -> Bool { + return is_sequence(obj) +} + +private func fn_cons(first: MalVal, rest: MalSequence) throws -> MalVal { + return rest.cons(first) +} + +private func fn_concat(args: MalVarArgs) throws -> MalVal { + var result = make_list() + for arg in args.value { + guard let arg_as_seq = as_sequenceQ(arg) else { + try throw_error("expected list, got \(arg)") + } + result = try! as_sequence(result).concat(arg_as_seq) + } + return result +} + +private func fn_vec(seq: MalSequence) throws -> MalVal { + return make_vector(seq) +} + +private func fn_nth(list: MalSequence, index: MalIntType) throws -> MalVal { + return try list.nth(index) +} + +private func fn_first(arg: MalVal) throws -> MalVal { + if is_nil(arg) { + return arg + } + if let list = as_sequenceQ(arg) { + return list.first() + } + try throw_error("expected list, got \(arg)") +} + +private func fn_rest(arg: MalVal) throws -> MalVal { + if is_nil(arg) { + return make_list() + } + if let seq = as_sequenceQ(arg) { + return seq.rest() + } + try throw_error("expected sequence, got \(arg)") +} + +private func fn_emptyQ(obj: MalVal) throws -> Bool { + if let list = as_sequenceQ(obj) { + return list.isEmpty + } + return true +} + +private func fn_count(obj: MalVal) throws -> MalIntType { + if is_nil(obj) { + return 0 + } + if let as_seq = as_sequenceQ(obj) { + return as_seq.count + } + if let as_hash = as_hashmapQ(obj) { + return as_hash.count + } + if let as_str = as_stringQ(obj) { + return MalIntType(as_stringtype(as_str).characters.count) + } + return 0 +} + +private func fn_apply(args: MalVarArgs) throws -> MalVal { + guard args.value.count >= 2 else { + try throw_error("expected at least 2 arguments to apply, got \(args.value.count)") + } + + let first = args.value.first() + let middle = args.value.range_from(1, to: args.value.count - 1) + let last = args.value.last() + + guard let fn = as_functionQ(first) else { + try throw_error("expected function for first argument to apply, got \(first)") + } + guard let seq = as_sequenceQ(last) else { + try throw_error("expected sequence for last argument to apply, got \(last)") + } + let exprs = try! as_sequence(middle).concat(seq) + return try fn.apply(as_sequence(exprs)) +} + +private func fn_map(fn: MalFunction, list: MalSequence) throws -> MalVal { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for var index: MalIntType = 0; index < list.count; ++index { + let apply_res = try fn.apply(as_sequence(make_list_from(try! list.nth(index)))) + result.append(apply_res) + } + return make_list(result) +} + +private func fn_conj(first: MalSequence, rest: MalVarArgs) throws -> MalVal { + return try first.conj(rest.value) +} + +private func fn_seq(seq: MalVal) throws -> MalVal { + if let list = as_listQ(seq) { + return list.count > 0 ? list : make_nil() + } else if let vector = as_vectorQ(seq) { + return vector.count > 0 ? make_list(vector) : make_nil() + } else if let str = as_stringQ(seq) { + if str.string.characters.count == 0 { return make_nil() } + return make_list(str.string.characters.map { make_string(String($0)) }) + } else if is_nil(seq) { + return make_nil() + } else { + try throw_error("seq: called with non-sequence") + } + return seq +} + +private func fn_meta(obj: MalVal) throws -> MalVal { + if let meta = get_meta(obj) { + return meta + } + + return make_nil() +} + +private func fn_withmeta(form: MalVal, meta: MalVal) throws -> MalVal { + return with_meta(form, meta) +} + +private func fn_atom(obj: MalVal) throws -> MalVal { + return make_atom(obj) +} + +private func fn_atomQ(obj: MalVal) throws -> Bool { + return is_atom(obj) +} + +private func fn_deref(atom: MalAtom) throws -> MalVal { + return atom.object +} + +private func fn_resetBang(atom: MalAtom, obj: MalVal) throws -> MalVal { + return atom.set_object(obj) +} + +private func fn_swapBang(let atom: MalAtom, fn: MalFunction, rest: MalVarArgs) throws -> MalVal { + var new_args = make_list_from(atom.object) + new_args = try as_sequence(new_args).concat(rest.value) + let result = try fn.apply(as_sequence(new_args)) + return atom.set_object(result) +} + +//****************************************************************************** +// +// The facility for invoking built-in functions makes use of a name -> +// function-pointer table (defined down below). The function-pointers accept a +// sequence of MalVals and return a MalVal as a result. Each built-in function +// that does actual work, on the other hand, may expect a different set of +// parameters of different types, and may naturally return a result of any type. +// In order to convert between these two types of interfaces, we have these +// unwrap_args functions. These functions implement the (MalSequence) -> MalVal +// interface expected by EVAL, and convert that information into Ints, Strings, +// etc. expected by the built-in functions. +// +//****************************************************************************** + +private func with_one_parameter(args: MalSequence, @noescape fn: (MalVal) throws -> MalVal) throws -> MalVal { + guard args.count >= 1 else { try throw_error("expected at least 1 parameter, got \(args.count)") } + let arg1 = try! args.nth(0) + return try fn(arg1) +} + +private func with_two_parameters(args: MalSequence, @noescape fn: (MalVal, MalVal) throws -> MalVal) throws -> MalVal { + guard args.count >= 2 else { try throw_error("expected at least 2 parameter, got \(args.count)") } + let arg1 = try! args.nth(0) + let arg2 = try! args.nth(1) + return try fn(arg1, arg2) +} + +// ========== 0-parameter functions ========== + +// () -> MalIntType + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: () throws -> MalIntType) throws -> MalVal { + return make_integer(try fn()) +} + +// () -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: () throws -> MalVal) throws -> MalVal { + return try fn() +} + +// ========== 1-parameter functions ========== + +// (MalAtom) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalAtom) throws -> MalVal) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + guard let atom = as_atomQ(arg1) else { + try throw_error("expected atom, got \(arg1)") + } + return try fn(atom) + } +} + +// (MalHashMap) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalHashMap) throws -> MalVal) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + guard let hash = as_hashmapQ(arg1) else { + try throw_error("expected hashmap, got \(arg1)") + } + return try fn(hash) + } +} + +// (MalSequence) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalSequence) throws -> MalVal) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + guard let seq = as_sequenceQ(arg1) else { + try throw_error("expected list, got \(arg1)") + } + return try fn(seq) + } +} + +// (MalVal) -> Bool + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal) throws -> Bool) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + return try fn(arg1) ? make_true() : make_false() + } +} + +// (MalVal) -> MalIntType + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal) throws -> MalIntType) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + return make_integer(try fn(arg1)) + } +} + +// (MalVal) -> MalVal + +func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal) throws -> MalVal) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + return try fn(arg1) + } +} + +// (String) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (String) throws -> MalVal) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + guard let str = as_stringQ(arg1) else { + try throw_error("expected string, got \(arg1)") + } + return try fn(as_stringtype(str)) + } +} + +// (String) -> MalVal? + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (String) throws -> MalVal?) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + guard let str = as_stringQ(arg1) else { + try throw_error("expected string, got \(arg1)") + } + let res = try fn(as_stringtype(str)) + return res != nil ? res! : make_nil() + } +} + +// (String) -> String + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (String) throws -> String) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + guard let str = as_stringQ(arg1) else { + try throw_error("expected string, got \(arg1)") + } + return make_string(try fn(as_stringtype(str))) + } +} + +// (String) -> String? + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (String) throws -> String?) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + guard let str = as_stringQ(arg1) else { + try throw_error("expected string, got \(arg1)") + } + let res = try fn(as_stringtype(str)) + return res != nil ? make_string(res!) : make_nil() + } +} + +// ========== 2-parameter functions ========== + +// (MalIntType, MalIntType) -> Bool + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalIntType, MalIntType) throws -> Bool) throws -> MalVal { + return try with_two_parameters(args) { (arg1, arg2) -> MalVal in + guard let int1 = as_integerQ(arg1) else { + try throw_error("expected number, got \(arg1)") + } + guard let int2 = as_integerQ(arg2) else { + try throw_error("expected number, got \(arg2)") + } + return try fn(as_inttype(int1), as_inttype(int2)) ? make_true() : make_false() + } +} + +// (MalIntType, MalIntType) -> MalIntType + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalIntType, MalIntType) throws -> MalIntType) throws -> MalVal { + return try with_two_parameters(args) { (arg1, arg2) -> MalVal in + guard let int1 = as_integerQ(arg1) else { + try throw_error("expected number, got \(arg1)") + } + guard let int2 = as_integerQ(arg2) else { + try throw_error("expected number, got \(arg2)") + } + return make_integer(try fn(as_inttype(int1), as_inttype(int2))) + } +} + +// (MalAtom, MalVal) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalAtom, MalVal) throws -> MalVal) throws -> MalVal { + return try with_two_parameters(args) { (arg1, arg2) -> MalVal in + guard let atom = as_atomQ(arg1) else { + try throw_error("expected atom, got \(arg1)") + } + return try fn(atom, arg2) + } +} + +// (MalFunction, MalSequence) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalFunction, MalSequence) throws -> MalVal) throws -> MalVal { + return try with_two_parameters(args) { (arg1, arg2) -> MalVal in + guard let fn1 = as_functionQ(arg1) else { + try throw_error("expected function, got \(arg1)") + } + guard let seq2 = as_sequenceQ(arg2) else { + try throw_error("expected sequence, got \(arg2)") + } + return try fn(fn1, seq2) + } +} + +// (MalSequence, MalIntType) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalSequence, MalIntType) throws -> MalVal) throws -> MalVal { + return try with_two_parameters(args) { (arg1, arg2) -> MalVal in + guard let seq = as_sequenceQ(arg1) else { + try throw_error("expected sequence, got \(arg1)") + } + guard let int = as_integerQ(arg2) else { + try throw_error("expected number, got \(arg2)") + } + return try fn(seq, as_inttype(int)) + } +} + +// (MalVal, MalSequence) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal, MalSequence) throws -> MalVal) throws -> MalVal { + return try with_two_parameters(args) { (arg1, arg2) -> MalVal in + guard let seq = as_sequenceQ(arg2) else { + try throw_error("expected sequence, got \(arg2)") + } + return try fn(arg1, seq) + } +} + +// (MalVal, MalVal) -> Bool + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal, MalVal) throws -> Bool) throws -> MalVal { + return try with_two_parameters(args) { (arg1, arg2) -> MalVal in + return try fn(arg1, arg2) ? make_true() : make_false() + } +} + +// (MalVal, MalVal) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVal, MalVal) throws -> MalVal) throws -> MalVal { + return try with_two_parameters(args) { (arg1, arg2) -> MalVal in + return try fn(arg1, arg2) + } +} + +// ========== Variadic functions ========== + +// (MalVarArgs) -> () + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVarArgs) throws -> ()) throws -> MalVal { + try fn(MalVarArgs(args)) + return make_nil() +} + +// (MalVarArgs) -> String + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVarArgs) throws -> String) throws -> MalVal { + return make_string(try fn(MalVarArgs(args))) +} + +// (MalVarArgs) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalVarArgs) throws -> MalVal) throws -> MalVal { + return try fn(MalVarArgs(args)) +} + +// (MalAtom, MalFunction, MalVarArgs) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalAtom, MalFunction, MalVarArgs) throws -> MalVal) throws -> MalVal { + return try with_two_parameters(args) { (arg1, arg2) -> MalVal in + guard let atom = as_atomQ(arg1) else { + try throw_error("expected atom, got \(arg1)") + } + guard let fn2 = as_functionQ(arg2) else { + try throw_error("expected function, got \(arg2)") + } + return try fn(atom, fn2, MalVarArgs(as_sequence(args.rest()).rest())) + } +} + +// (MalHashMap, MalVarArgs) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalHashMap, MalVarArgs) throws -> MalVal) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + guard let hash = as_hashmapQ(arg1) else { + try throw_error("expected hashmap, got \(arg1)") + } + return try fn(hash, MalVarArgs(args.rest())) + } +} + +// (MalSequence, MalVarArgs) -> MalVal + +private func unwrap_args(args: MalSequence, @noescape forFunction fn: (MalSequence, MalVarArgs) throws -> MalVal) throws -> MalVal { + return try with_one_parameter(args) { (arg1) -> MalVal in + guard let seq = as_sequenceQ(arg1) else { + try throw_error("expected sequence, got \(arg1)") + } + return try fn(seq, MalVarArgs(args.rest())) + } +} + +// *o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o*o* + +let ns: [String: MalBuiltin.Signature] = [ + "=": { try unwrap_args($0, forFunction: fn_eq) }, + "throw": { try unwrap_args($0, forFunction: fn_throw) }, + + "nil?": { try unwrap_args($0, forFunction: fn_nilQ) }, + "true?": { try unwrap_args($0, forFunction: fn_trueQ) }, + "false?": { try unwrap_args($0, forFunction: fn_falseQ) }, + "string?": { try unwrap_args($0, forFunction: fn_stringQ) }, + "symbol": { try unwrap_args($0, forFunction: fn_symbol) }, + "symbol?": { try unwrap_args($0, forFunction: fn_symbolQ) }, + "keyword": { try unwrap_args($0, forFunction: fn_keyword) }, + "keyword?": { try unwrap_args($0, forFunction: fn_keywordQ) }, + "number?": { try unwrap_args($0, forFunction: fn_numberQ) }, + "fn?": { try unwrap_args($0, forFunction: fn_functionQ) }, + "macro?": { try unwrap_args($0, forFunction: fn_macroQ) }, + + "pr-str": { try unwrap_args($0, forFunction: fn_prstr) }, + "str": { try unwrap_args($0, forFunction: fn_str) }, + "prn": { try unwrap_args($0, forFunction: fn_prn) }, + "println": { try unwrap_args($0, forFunction: fn_println) }, + "read-string": { try unwrap_args($0, forFunction: fn_readstring) }, + "readline": { try unwrap_args($0, forFunction: fn_readline) }, + "slurp": { try unwrap_args($0, forFunction: fn_slurp) }, + + "<": { try unwrap_args($0, forFunction: fn_lt) }, + "<=": { try unwrap_args($0, forFunction: fn_lte) }, + ">": { try unwrap_args($0, forFunction: fn_gt) }, + ">=": { try unwrap_args($0, forFunction: fn_gte) }, + "+": { try unwrap_args($0, forFunction: fn_add) }, + "-": { try unwrap_args($0, forFunction: fn_subtract) }, + "*": { try unwrap_args($0, forFunction: fn_multiply) }, + "/": { try unwrap_args($0, forFunction: fn_divide) }, + "time-ms": { try unwrap_args($0, forFunction: fn_timems) }, + + "list": { try unwrap_args($0, forFunction: fn_list) }, + "list?": { try unwrap_args($0, forFunction: fn_listQ) }, + "vector": { try unwrap_args($0, forFunction: fn_vector) }, + "vector?": { try unwrap_args($0, forFunction: fn_vectorQ) }, + "hash-map": { try unwrap_args($0, forFunction: fn_hashmap) }, + "map?": { try unwrap_args($0, forFunction: fn_hashmapQ) }, + "assoc": { try unwrap_args($0, forFunction: fn_assoc) }, + "dissoc": { try unwrap_args($0, forFunction: fn_dissoc) }, + "get": { try unwrap_args($0, forFunction: fn_get) }, + "contains?": { try unwrap_args($0, forFunction: fn_containsQ) }, + "keys": { try unwrap_args($0, forFunction: fn_keys) }, + "vals": { try unwrap_args($0, forFunction: fn_values) }, + + "sequential?": { try unwrap_args($0, forFunction: fn_sequentialQ) }, + "cons": { try unwrap_args($0, forFunction: fn_cons) }, + "concat": { try unwrap_args($0, forFunction: fn_concat) }, + "vec": { try unwrap_args($0, forFunction: fn_vec) }, + "nth": { try unwrap_args($0, forFunction: fn_nth) }, + "first": { try unwrap_args($0, forFunction: fn_first) }, + "rest": { try unwrap_args($0, forFunction: fn_rest) }, + "empty?": { try unwrap_args($0, forFunction: fn_emptyQ) }, + "count": { try unwrap_args($0, forFunction: fn_count) }, + "apply": { try unwrap_args($0, forFunction: fn_apply) }, + "map": { try unwrap_args($0, forFunction: fn_map) }, + + "conj": { try unwrap_args($0, forFunction: fn_conj) }, + "seq": { try unwrap_args($0, forFunction: fn_seq) }, + + "meta": { try unwrap_args($0, forFunction: fn_meta) }, + "with-meta": { try unwrap_args($0, forFunction: fn_withmeta) }, + "atom": { try unwrap_args($0, forFunction: fn_atom) }, + "atom?": { try unwrap_args($0, forFunction: fn_atomQ) }, + "deref": { try unwrap_args($0, forFunction: fn_deref) }, + "reset!": { try unwrap_args($0, forFunction: fn_resetBang) }, + "swap!": { try unwrap_args($0, forFunction: fn_swapBang) }, +] + +func load_builtins(env: Environment) { + for (name, fn) in ns { + env.set(as_symbol(make_symbol(name)), make_builtin(fn)) + } +} diff --git a/impls/swift/env.swift b/impls/swift/env.swift index ba6205d81f..26f8a33730 100644 --- a/impls/swift/env.swift +++ b/impls/swift/env.swift @@ -1,114 +1,114 @@ -//****************************************************************************** -// MAL - env -//****************************************************************************** - -import Foundation - -typealias EnvironmentVars = [MalSymbol: MalVal] - -private let kSymbolAmpersand = as_symbol(make_symbol("&")) -private let kSymbolNil = as_symbol(make_symbol("")) -private let kNil = make_nil() - -final class Environment { - init(outer: Environment?) { - self.outer = outer - } - - func set_bindings(binds: MalSequence, with_exprs exprs: MalSequence) throws -> MalVal { - for var index: MalIntType = 0; index < binds.count; ++index { - guard let sym = as_symbolQ(try! binds.nth(index)) else { - try throw_error("an entry in binds was not a symbol: index=\(index), binds[index]=\(try! binds.nth(index))") - } - if sym != kSymbolAmpersand { - if index < exprs.count { - set(sym, try! exprs.nth(index)) - } else { - set(sym, kNil) - } - continue - } - - guard (index + 1) < binds.count else { - try throw_error("found & but no symbol") - } - guard let rest_sym = as_symbolQ(try! binds.nth(index + 1)) else { - try throw_error("& was not followed by a symbol: index=\(index), binds[index]=\(try! binds.nth(index))") - } - let rest = exprs.range_from(index, to: exprs.count) - set(rest_sym, rest) - break - } - return kNil - } - - // In this implementation, rather than storing everything in a dictionary, - // we optimize for small environments by having a hard-coded set of four - // slots. We use these slots when creating small environments, such as when - // a function is invoked. Testing shows that supporting up to four variables - // in this way is a good trade-off. Otherwise, if we have more than four - // variables, we switch over to using a dictionary. Testing also shows that - // trying to use both the slots and the dictionary for large environments is - // not as efficient as just completely switching over to the dictionary. - // - // Interestingly, even though the MalVal return value is hardly ever used at - // the call site, removing it and returning nothing is a performance loss. - // This is because returning 'value' allows the compiler to skip calling - // swift_release on it. The result is that set() calls swift_release twice - // (on self and sym), as opposed to three times (on self, sym, and value) if - // it were to return something other than one of the parameters. - - func set(sym: MalSymbol, _ value: MalVal) -> MalVal { - if num_bindings == 0 { - slot_name0 = sym; slot_value0 = value; ++num_bindings - } else if num_bindings == 1 { - if slot_name0 == sym { slot_value0 = value } - else { slot_name1 = sym; slot_value1 = value; ++num_bindings } - } else if num_bindings == 2 { - if slot_name0 == sym { slot_value0 = value } - else if slot_name1 == sym { slot_value1 = value } - else { slot_name2 = sym; slot_value2 = value; ++num_bindings } - } else if num_bindings == 3 { - if slot_name0 == sym { slot_value0 = value } - else if slot_name1 == sym { slot_value1 = value } - else if slot_name2 == sym { slot_value2 = value } - else { slot_name3 = sym; slot_value3 = value; ++num_bindings } - } else if num_bindings == 4 { - if slot_name0 == sym { slot_value0 = value } - else if slot_name1 == sym { slot_value1 = value } - else if slot_name2 == sym { slot_value2 = value } - else if slot_name3 == sym { slot_value3 = value } - else { - data[slot_name0] = slot_value0 - data[slot_name1] = slot_value1 - data[slot_name2] = slot_value2 - data[slot_name3] = slot_value3 - data[sym] = value; ++num_bindings - } - } else { - data[sym] = value - } - return value - } - - func get(sym: MalSymbol) -> MalVal? { - if num_bindings > 4 { if let val = data[sym] { return val }; return outer?.get(sym) } - if num_bindings > 3 { if slot_name3 == sym { return slot_value3 } } - if num_bindings > 2 { if slot_name2 == sym { return slot_value2 } } - if num_bindings > 1 { if slot_name1 == sym { return slot_value1 } } - if num_bindings > 0 { if slot_name0 == sym { return slot_value0 } } - return outer?.get(sym) - } - - private var outer: Environment? - private var data = EnvironmentVars() - private var num_bindings = 0 - private var slot_name0 = kSymbolNil - private var slot_name1 = kSymbolNil - private var slot_name2 = kSymbolNil - private var slot_name3 = kSymbolNil - private var slot_value0 = kNil - private var slot_value1 = kNil - private var slot_value2 = kNil - private var slot_value3 = kNil -} +//****************************************************************************** +// MAL - env +//****************************************************************************** + +import Foundation + +typealias EnvironmentVars = [MalSymbol: MalVal] + +private let kSymbolAmpersand = as_symbol(make_symbol("&")) +private let kSymbolNil = as_symbol(make_symbol("")) +private let kNil = make_nil() + +final class Environment { + init(outer: Environment?) { + self.outer = outer + } + + func set_bindings(binds: MalSequence, with_exprs exprs: MalSequence) throws -> MalVal { + for var index: MalIntType = 0; index < binds.count; ++index { + guard let sym = as_symbolQ(try! binds.nth(index)) else { + try throw_error("an entry in binds was not a symbol: index=\(index), binds[index]=\(try! binds.nth(index))") + } + if sym != kSymbolAmpersand { + if index < exprs.count { + set(sym, try! exprs.nth(index)) + } else { + set(sym, kNil) + } + continue + } + + guard (index + 1) < binds.count else { + try throw_error("found & but no symbol") + } + guard let rest_sym = as_symbolQ(try! binds.nth(index + 1)) else { + try throw_error("& was not followed by a symbol: index=\(index), binds[index]=\(try! binds.nth(index))") + } + let rest = exprs.range_from(index, to: exprs.count) + set(rest_sym, rest) + break + } + return kNil + } + + // In this implementation, rather than storing everything in a dictionary, + // we optimize for small environments by having a hard-coded set of four + // slots. We use these slots when creating small environments, such as when + // a function is invoked. Testing shows that supporting up to four variables + // in this way is a good trade-off. Otherwise, if we have more than four + // variables, we switch over to using a dictionary. Testing also shows that + // trying to use both the slots and the dictionary for large environments is + // not as efficient as just completely switching over to the dictionary. + // + // Interestingly, even though the MalVal return value is hardly ever used at + // the call site, removing it and returning nothing is a performance loss. + // This is because returning 'value' allows the compiler to skip calling + // swift_release on it. The result is that set() calls swift_release twice + // (on self and sym), as opposed to three times (on self, sym, and value) if + // it were to return something other than one of the parameters. + + func set(sym: MalSymbol, _ value: MalVal) -> MalVal { + if num_bindings == 0 { + slot_name0 = sym; slot_value0 = value; ++num_bindings + } else if num_bindings == 1 { + if slot_name0 == sym { slot_value0 = value } + else { slot_name1 = sym; slot_value1 = value; ++num_bindings } + } else if num_bindings == 2 { + if slot_name0 == sym { slot_value0 = value } + else if slot_name1 == sym { slot_value1 = value } + else { slot_name2 = sym; slot_value2 = value; ++num_bindings } + } else if num_bindings == 3 { + if slot_name0 == sym { slot_value0 = value } + else if slot_name1 == sym { slot_value1 = value } + else if slot_name2 == sym { slot_value2 = value } + else { slot_name3 = sym; slot_value3 = value; ++num_bindings } + } else if num_bindings == 4 { + if slot_name0 == sym { slot_value0 = value } + else if slot_name1 == sym { slot_value1 = value } + else if slot_name2 == sym { slot_value2 = value } + else if slot_name3 == sym { slot_value3 = value } + else { + data[slot_name0] = slot_value0 + data[slot_name1] = slot_value1 + data[slot_name2] = slot_value2 + data[slot_name3] = slot_value3 + data[sym] = value; ++num_bindings + } + } else { + data[sym] = value + } + return value + } + + func get(sym: MalSymbol) -> MalVal? { + if num_bindings > 4 { if let val = data[sym] { return val }; return outer?.get(sym) } + if num_bindings > 3 { if slot_name3 == sym { return slot_value3 } } + if num_bindings > 2 { if slot_name2 == sym { return slot_value2 } } + if num_bindings > 1 { if slot_name1 == sym { return slot_value1 } } + if num_bindings > 0 { if slot_name0 == sym { return slot_value0 } } + return outer?.get(sym) + } + + private var outer: Environment? + private var data = EnvironmentVars() + private var num_bindings = 0 + private var slot_name0 = kSymbolNil + private var slot_name1 = kSymbolNil + private var slot_name2 = kSymbolNil + private var slot_name3 = kSymbolNil + private var slot_value0 = kNil + private var slot_value1 = kNil + private var slot_value2 = kNil + private var slot_value3 = kNil +} diff --git a/impls/swift/main.swift b/impls/swift/main.swift index 428e0578ff..c812a85381 100644 --- a/impls/swift/main.swift +++ b/impls/swift/main.swift @@ -1,18 +1,18 @@ -//****************************************************************************** -// MAL - main -//****************************************************************************** - -// Swift requires that main() be invoked from a file named "main.swift". See the -// paragraph "Application Entry Points and “main.swift” on -// https://developer.apple.com/swift/blog/?id=7: -// -// You’ll notice that earlier we said top-level code isn’t allowed in most -// of your app’s source files. The exception is a special file named -// “main.swift”, which behaves much like a playground file, but is built -// with your app’s source code. The “main.swift” file can contain top-level -// code, and the order-dependent rules apply as well. In effect, the first -// line of code to run in “main.swift” is implicitly defined as the main -// entrypoint for the program. This allows the minimal Swift program to be -// a single line — as long as that line is in “main.swift”. - -main() +//****************************************************************************** +// MAL - main +//****************************************************************************** + +// Swift requires that main() be invoked from a file named "main.swift". See the +// paragraph "Application Entry Points and “main.swift” on +// https://developer.apple.com/swift/blog/?id=7: +// +// You’ll notice that earlier we said top-level code isn’t allowed in most +// of your app’s source files. The exception is a special file named +// “main.swift”, which behaves much like a playground file, but is built +// with your app’s source code. The “main.swift” file can contain top-level +// code, and the order-dependent rules apply as well. In effect, the first +// line of code to run in “main.swift” is implicitly defined as the main +// entrypoint for the program. This allows the minimal Swift program to be +// a single line — as long as that line is in “main.swift”. + +main() diff --git a/impls/swift/printer.swift b/impls/swift/printer.swift index c6ed030048..107c5f1778 100644 --- a/impls/swift/printer.swift +++ b/impls/swift/printer.swift @@ -1,27 +1,27 @@ -//****************************************************************************** -// MAL - printer -//****************************************************************************** - -import Foundation - -var MalValPrintReadably = true - -func with_print_readably(print_readably: Bool, fn: () -> T) -> T { - let old = MalValPrintReadably - MalValPrintReadably = print_readably - let result = fn() - MalValPrintReadably = old - return result -} - -func pr_str(m: MalVal, _ print_readably: Bool = MalValPrintReadably) -> String { - return with_print_readably(print_readably) { - if is_string(m) { - return print_readably ? escape(m.description) : m.description - } - if is_keyword(m) { - return ":\(m.description)" - } - return m.description - } -} +//****************************************************************************** +// MAL - printer +//****************************************************************************** + +import Foundation + +var MalValPrintReadably = true + +func with_print_readably(print_readably: Bool, fn: () -> T) -> T { + let old = MalValPrintReadably + MalValPrintReadably = print_readably + let result = fn() + MalValPrintReadably = old + return result +} + +func pr_str(m: MalVal, _ print_readably: Bool = MalValPrintReadably) -> String { + return with_print_readably(print_readably) { + if is_string(m) { + return print_readably ? escape(m.description) : m.description + } + if is_keyword(m) { + return ":\(m.description)" + } + return m.description + } +} diff --git a/impls/swift/reader.swift b/impls/swift/reader.swift index d51c536cee..3f9cf70cec 100644 --- a/impls/swift/reader.swift +++ b/impls/swift/reader.swift @@ -1,203 +1,203 @@ -//****************************************************************************** -// MAL - reader -//****************************************************************************** - -import Foundation - -private let kSymbolWithMeta = make_symbol("with-meta") -private let kSymbolDeref = make_symbol("deref") - -private let token_pattern = - "[[:space:],]*" + // Skip whitespace: a sequence of zero or more commas or [:space:]'s - "(" + - "~@" + // Literal "~@" - "|" + - "[\\[\\]{}()`'~^@]" + // Punctuation: Any one of []{}()`'~^@ - "|" + - "\"(?:\\\\.|[^\\\\\"])*\"?" + // Quoted string: characters other than \ or ", or any escaped characters - "|" + - ";.*" + // Comment: semicolon followed by anything - "|" + - "[^[:space:]\\[\\]{}()`'\",;]*" + // Symbol, keyword, number, nil, true, false: any sequence of chars but [:space:] or []{}()`'",; - ")" - -private let atom_pattern = - "(^;.*$)" + // Comment - "|" + - "(^-?[0-9]+$)" + // Integer - "|" + - "(^-?[0-9][0-9.]*$)" + // Float - "|" + - "(^nil$)" + // nil - "|" + - "(^true$)" + // true - "|" + - "(^false$)" + // false - "|" + - "(^\"(?:\\\\.|[^\\\\\"])*\"$)" + // String - "|" + - "(^\".*$)" + // Invalid/unclosed string - "|" + - "(:.*)" + // Keyword - "|" + - "(^[^\"]*$)" // Symbol - -private var token_regex: NSRegularExpression = try! NSRegularExpression(pattern: token_pattern, options: NSRegularExpressionOptions()) -private var atom_regex: NSRegularExpression = try! NSRegularExpression(pattern: atom_pattern, options: NSRegularExpressionOptions()) - -private final class Reader { - - init(_ tokens: [String]) { - self.tokens = tokens - self.index = 0 - } - - func next() -> String? { - let token = peek() - increment() - return token - } - - func peek() -> String? { - if index < tokens.count { - return tokens[index] - } - return nil - } - - private func increment() { - ++index - } - - private let tokens: [String] - private var index: Int -} - -private func tokenizer(s: String) -> [String] { - var tokens = [String]() - let range = NSMakeRange(0, s.characters.count) - let matches = token_regex.matchesInString(s, options: NSMatchingOptions(), range: range) - for match in matches { - if match.range.length > 0 { - let token = (s as NSString).substringWithRange(match.rangeAtIndex(1)) - tokens.append(token) - } - } - return tokens -} - -private func have_match(match: NSTextCheckingResult, at_index index: Int) -> Bool { - return Int64(match.rangeAtIndex(index).location) < LLONG_MAX -} - -private func read_atom(token: String) throws -> MalVal { - let range = NSMakeRange(0, token.characters.count) - let matches = atom_regex.matchesInString(token, options: NSMatchingOptions(), range: range) - for match in matches { - if have_match(match, at_index: 1) { // Comment - return make_comment() - } else if have_match(match, at_index: 2) { // Integer - guard let value = NSNumberFormatter().numberFromString(token)?.longLongValue else { - try throw_error("invalid integer: \(token)") - } - return make_integer(value) - } else if have_match(match, at_index: 3) { // Float - guard let value = NSNumberFormatter().numberFromString(token)?.doubleValue else { - try throw_error("invalid float: \(token)") - } - return make_float(value) - } else if have_match(match, at_index: 4) { // nil - return make_nil() - } else if have_match(match, at_index: 5) { // true - return make_true() - } else if have_match(match, at_index: 6) { // false - return make_false() - } else if have_match(match, at_index: 7) { // String - return make_string(unescape(token)) - } else if have_match(match, at_index: 8) { // Invalid/unclosed string - try throw_error("expected '\"', got EOF") - } else if have_match(match, at_index: 9) { // Keyword - return make_keyword(token[token.startIndex.successor() ..< token.endIndex]) - } else if have_match(match, at_index: 10) { // Symbol - return make_symbol(token) - } - } - try throw_error("Unknown token=\(token)") -} - -private func read_elements(r: Reader, _ open: String, _ close: String) throws -> [MalVal] { - var list = [MalVal]() - while let token = r.peek() { - if token == close { - r.increment() // Consume the closing paren - return list - } else { - let item = try read_form(r) - if !is_comment(item) { - list.append(item) - } - } - } - try throw_error("ran out of tokens -- possibly unbalanced ()'s") -} - -private func read_list(r: Reader) throws -> MalVal { - return make_list(try read_elements(r, "(", ")")) -} - -private func read_vector(r: Reader) throws -> MalVal { - return make_vector(try read_elements(r, "[", "]")) -} - -private func read_hashmap(r: Reader) throws -> MalVal { - return make_hashmap(try read_elements(r, "{", "}")) -} - -private func common_quote(r: Reader, _ symbol: String) throws -> MalVal { - let next = try read_form(r) - return make_list_from(make_symbol(symbol), next) -} - -private func read_form(r: Reader) throws -> MalVal { - if let token = r.next() { - switch token { - case "(": - return try read_list(r) - case ")": - try throw_error("unexpected \")\"") - case "[": - return try read_vector(r) - case "]": - try throw_error("unexpected \"]\"") - case "{": - return try read_hashmap(r) - case "}": - try throw_error("unexpected \"}\"") - case "`": - return try common_quote(r, "quasiquote") - case "'": - return try common_quote(r, "quote") - case "~": - return try common_quote(r, "unquote") - case "~@": - return try common_quote(r, "splice-unquote") - case "^": - let meta = try read_form(r) - let form = try read_form(r) - return make_list_from(kSymbolWithMeta, form, meta) - case "@": - let form = try read_form(r) - return make_list_from(kSymbolDeref, form) - default: - return try read_atom(token) - } - } - try throw_error("ran out of tokens -- possibly unbalanced ()'s") -} - -func read_str(s: String) throws -> MalVal { - let tokens = tokenizer(s) - let reader = Reader(tokens) - let obj = try read_form(reader) - return obj -} +//****************************************************************************** +// MAL - reader +//****************************************************************************** + +import Foundation + +private let kSymbolWithMeta = make_symbol("with-meta") +private let kSymbolDeref = make_symbol("deref") + +private let token_pattern = + "[[:space:],]*" + // Skip whitespace: a sequence of zero or more commas or [:space:]'s + "(" + + "~@" + // Literal "~@" + "|" + + "[\\[\\]{}()`'~^@]" + // Punctuation: Any one of []{}()`'~^@ + "|" + + "\"(?:\\\\.|[^\\\\\"])*\"?" + // Quoted string: characters other than \ or ", or any escaped characters + "|" + + ";.*" + // Comment: semicolon followed by anything + "|" + + "[^[:space:]\\[\\]{}()`'\",;]*" + // Symbol, keyword, number, nil, true, false: any sequence of chars but [:space:] or []{}()`'",; + ")" + +private let atom_pattern = + "(^;.*$)" + // Comment + "|" + + "(^-?[0-9]+$)" + // Integer + "|" + + "(^-?[0-9][0-9.]*$)" + // Float + "|" + + "(^nil$)" + // nil + "|" + + "(^true$)" + // true + "|" + + "(^false$)" + // false + "|" + + "(^\"(?:\\\\.|[^\\\\\"])*\"$)" + // String + "|" + + "(^\".*$)" + // Invalid/unclosed string + "|" + + "(:.*)" + // Keyword + "|" + + "(^[^\"]*$)" // Symbol + +private var token_regex: NSRegularExpression = try! NSRegularExpression(pattern: token_pattern, options: NSRegularExpressionOptions()) +private var atom_regex: NSRegularExpression = try! NSRegularExpression(pattern: atom_pattern, options: NSRegularExpressionOptions()) + +private final class Reader { + + init(_ tokens: [String]) { + self.tokens = tokens + self.index = 0 + } + + func next() -> String? { + let token = peek() + increment() + return token + } + + func peek() -> String? { + if index < tokens.count { + return tokens[index] + } + return nil + } + + private func increment() { + ++index + } + + private let tokens: [String] + private var index: Int +} + +private func tokenizer(s: String) -> [String] { + var tokens = [String]() + let range = NSMakeRange(0, s.characters.count) + let matches = token_regex.matchesInString(s, options: NSMatchingOptions(), range: range) + for match in matches { + if match.range.length > 0 { + let token = (s as NSString).substringWithRange(match.rangeAtIndex(1)) + tokens.append(token) + } + } + return tokens +} + +private func have_match(match: NSTextCheckingResult, at_index index: Int) -> Bool { + return Int64(match.rangeAtIndex(index).location) < LLONG_MAX +} + +private func read_atom(token: String) throws -> MalVal { + let range = NSMakeRange(0, token.characters.count) + let matches = atom_regex.matchesInString(token, options: NSMatchingOptions(), range: range) + for match in matches { + if have_match(match, at_index: 1) { // Comment + return make_comment() + } else if have_match(match, at_index: 2) { // Integer + guard let value = NSNumberFormatter().numberFromString(token)?.longLongValue else { + try throw_error("invalid integer: \(token)") + } + return make_integer(value) + } else if have_match(match, at_index: 3) { // Float + guard let value = NSNumberFormatter().numberFromString(token)?.doubleValue else { + try throw_error("invalid float: \(token)") + } + return make_float(value) + } else if have_match(match, at_index: 4) { // nil + return make_nil() + } else if have_match(match, at_index: 5) { // true + return make_true() + } else if have_match(match, at_index: 6) { // false + return make_false() + } else if have_match(match, at_index: 7) { // String + return make_string(unescape(token)) + } else if have_match(match, at_index: 8) { // Invalid/unclosed string + try throw_error("expected '\"', got EOF") + } else if have_match(match, at_index: 9) { // Keyword + return make_keyword(token[token.startIndex.successor() ..< token.endIndex]) + } else if have_match(match, at_index: 10) { // Symbol + return make_symbol(token) + } + } + try throw_error("Unknown token=\(token)") +} + +private func read_elements(r: Reader, _ open: String, _ close: String) throws -> [MalVal] { + var list = [MalVal]() + while let token = r.peek() { + if token == close { + r.increment() // Consume the closing paren + return list + } else { + let item = try read_form(r) + if !is_comment(item) { + list.append(item) + } + } + } + try throw_error("ran out of tokens -- possibly unbalanced ()'s") +} + +private func read_list(r: Reader) throws -> MalVal { + return make_list(try read_elements(r, "(", ")")) +} + +private func read_vector(r: Reader) throws -> MalVal { + return make_vector(try read_elements(r, "[", "]")) +} + +private func read_hashmap(r: Reader) throws -> MalVal { + return make_hashmap(try read_elements(r, "{", "}")) +} + +private func common_quote(r: Reader, _ symbol: String) throws -> MalVal { + let next = try read_form(r) + return make_list_from(make_symbol(symbol), next) +} + +private func read_form(r: Reader) throws -> MalVal { + if let token = r.next() { + switch token { + case "(": + return try read_list(r) + case ")": + try throw_error("unexpected \")\"") + case "[": + return try read_vector(r) + case "]": + try throw_error("unexpected \"]\"") + case "{": + return try read_hashmap(r) + case "}": + try throw_error("unexpected \"}\"") + case "`": + return try common_quote(r, "quasiquote") + case "'": + return try common_quote(r, "quote") + case "~": + return try common_quote(r, "unquote") + case "~@": + return try common_quote(r, "splice-unquote") + case "^": + let meta = try read_form(r) + let form = try read_form(r) + return make_list_from(kSymbolWithMeta, form, meta) + case "@": + let form = try read_form(r) + return make_list_from(kSymbolDeref, form) + default: + return try read_atom(token) + } + } + try throw_error("ran out of tokens -- possibly unbalanced ()'s") +} + +func read_str(s: String) throws -> MalVal { + let tokens = tokenizer(s) + let reader = Reader(tokens) + let obj = try read_form(reader) + return obj +} diff --git a/impls/swift/readline.swift b/impls/swift/readline.swift index 3cb00845f2..1dd5184751 100644 --- a/impls/swift/readline.swift +++ b/impls/swift/readline.swift @@ -1,46 +1,46 @@ -//****************************************************************************** -// MAL - readline -//****************************************************************************** - -import Foundation - -private let HISTORY_FILE = "~/.mal-history" - -private func with_history_file(do_to_history_file: (UnsafePointer) -> ()) { - HISTORY_FILE.withCString { - (c_str) -> () in - let abs_path = tilde_expand(UnsafeMutablePointer(c_str)) - if abs_path != nil { - do_to_history_file(abs_path) - free(abs_path) - } - } -} - -func load_history_file() { - using_history() - with_history_file { - let _ = read_history($0) - } -} - -func save_history_file() { - // Do this? stifle_history(1000) - with_history_file { - let _ = write_history($0) - } -} - -func _readline(prompt: String) -> String? { - let line = prompt.withCString { - (c_str) -> UnsafeMutablePointer in - return readline(c_str) - } - if line != nil { - if let result = String(UTF8String: line) { - add_history(line) - return result - } - } - return nil -} +//****************************************************************************** +// MAL - readline +//****************************************************************************** + +import Foundation + +private let HISTORY_FILE = "~/.mal-history" + +private func with_history_file(do_to_history_file: (UnsafePointer) -> ()) { + HISTORY_FILE.withCString { + (c_str) -> () in + let abs_path = tilde_expand(UnsafeMutablePointer(c_str)) + if abs_path != nil { + do_to_history_file(abs_path) + free(abs_path) + } + } +} + +func load_history_file() { + using_history() + with_history_file { + let _ = read_history($0) + } +} + +func save_history_file() { + // Do this? stifle_history(1000) + with_history_file { + let _ = write_history($0) + } +} + +func _readline(prompt: String) -> String? { + let line = prompt.withCString { + (c_str) -> UnsafeMutablePointer in + return readline(c_str) + } + if line != nil { + if let result = String(UTF8String: line) { + add_history(line) + return result + } + } + return nil +} diff --git a/impls/swift/run b/impls/swift/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/swift/run +++ b/impls/swift/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/swift/step0_repl.swift b/impls/swift/step0_repl.swift index 1de32e6639..bfa1028902 100644 --- a/impls/swift/step0_repl.swift +++ b/impls/swift/step0_repl.swift @@ -1,64 +1,64 @@ -//****************************************************************************** -// MAL - step 0 - repl -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// Parse the string into an AST. -// -private func READ(str: String) -> String { - return str -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(ast: String) -> String { - return ast -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: String) -> String { - return exp -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String) -> String { - let ast = READ(text) - let exp = EVAL(ast) - return exp -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String) -> String { - let exp = RE(text) - return PRINT(exp) -} - -// Perform the full REPL. -// -private func REPL() { - while true { - if let text = _readline("user> ") { - print("\(REP(text))") - } else { - print("") - break - } - } -} - -func main() { - load_history_file() - REPL() - save_history_file() -} +//****************************************************************************** +// MAL - step 0 - repl +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// Parse the string into an AST. +// +private func READ(str: String) -> String { + return str +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(ast: String) -> String { + return ast +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: String) -> String { + return exp +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String) -> String { + let ast = READ(text) + let exp = EVAL(ast) + return exp +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String) -> String { + let exp = RE(text) + return PRINT(exp) +} + +// Perform the full REPL. +// +private func REPL() { + while true { + if let text = _readline("user> ") { + print("\(REP(text))") + } else { + print("") + break + } + } +} + +func main() { + load_history_file() + REPL() + save_history_file() +} diff --git a/impls/swift/step1_read_print.swift b/impls/swift/step1_read_print.swift index ee10da70f5..4ea3af25d6 100644 --- a/impls/swift/step1_read_print.swift +++ b/impls/swift/step1_read_print.swift @@ -1,75 +1,75 @@ -//****************************************************************************** -// MAL - step 1 - read/print -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(ast: MalVal) -> MalVal { - return ast -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - return EVAL(ast) - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String) -> String? { - let exp = RE(text) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL() { - while true { - if let text = _readline("user> ") { - if let output = REP(text) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -func main() { - load_history_file() - REPL() - save_history_file() -} +//****************************************************************************** +// MAL - step 1 - read/print +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(ast: MalVal) -> MalVal { + return ast +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + return EVAL(ast) + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String) -> String? { + let exp = RE(text) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL() { + while true { + if let text = _readline("user> ") { + if let output = REP(text) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +func main() { + load_history_file() + REPL() + save_history_file() +} diff --git a/impls/swift/step2_eval.swift b/impls/swift/step2_eval.swift index 52aeab23bb..383007ec35 100644 --- a/impls/swift/step2_eval.swift +++ b/impls/swift/step2_eval.swift @@ -1,170 +1,170 @@ -//****************************************************************************** -// MAL - step 2 - eval -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Perform a simple evaluation of the `ast` object. If it's a symbol, -// dereference it and return its value. If it's a collection, call EVAL on all -// elements (or just the values, in the case of the hashmap). Otherwise, return -// the object unchanged. -// -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { - if let symbol = as_symbolQ(ast) { - guard let val = env.get(symbol) else { - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests - } - return val - } - if let list = as_listQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for item in list { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_list(result) - } - if let vec = as_vectorQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(vec.count)) - for item in vec { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_vector(result) - } - if let hash = as_hashmapQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(hash.count) * 2) - for (k, v) in hash { - let new_v = try EVAL(v, env) - result.append(k) - result.append(new_v) - } - return make_hashmap(result) - } - return ast -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(ast: MalVal, _ env: Environment) throws -> MalVal { - - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - return answer - } - - // Special handling if it's a list. - - let list = as_list(ast) - - if list.isEmpty { - return ast - } - - // Standard list to be applied. Evaluate all the elements first. - - let eval = try eval_ast(ast, env) - - // The result had better be a list and better be non-empty. - - let eval_list = as_list(eval) - if eval_list.isEmpty { - return eval - } - - // Get the first element of the list and execute it. - - let first = eval_list.first() - let rest = as_sequence(eval_list.rest()) - - if let fn = as_builtinQ(first) { - let answer = try fn.apply(rest) - return answer - } - - // The first element wasn't a function to be executed. Return an - // error saying so. - - try throw_error("first list item does not evaluate to a function: \(first)") -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String, _ env: Environment) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - do { - return try EVAL(ast, env) - } catch let error as MalException { - print("Error evaluating input: \(error)") - } catch { - print("Error evaluating input: \(error)") - } - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String, _ env: Environment) -> String? { - let exp = RE(text, env) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL(env: Environment) { - while true { - if let text = _readline("user> ") { - if let output = REP(text, env) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -func main() { - let env = Environment(outer: nil) - - load_history_file() - load_builtins(env) - - REPL(env) - - save_history_file() -} +//****************************************************************************** +// MAL - step 2 - eval +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Perform a simple evaluation of the `ast` object. If it's a symbol, +// dereference it and return its value. If it's a collection, call EVAL on all +// elements (or just the values, in the case of the hashmap). Otherwise, return +// the object unchanged. +// +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { + if let symbol = as_symbolQ(ast) { + guard let val = env.get(symbol) else { + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests + } + return val + } + if let list = as_listQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for item in list { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_list(result) + } + if let vec = as_vectorQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(vec.count)) + for item in vec { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_vector(result) + } + if let hash = as_hashmapQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(hash.count) * 2) + for (k, v) in hash { + let new_v = try EVAL(v, env) + result.append(k) + result.append(new_v) + } + return make_hashmap(result) + } + return ast +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(ast: MalVal, _ env: Environment) throws -> MalVal { + + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + return answer + } + + // Special handling if it's a list. + + let list = as_list(ast) + + if list.isEmpty { + return ast + } + + // Standard list to be applied. Evaluate all the elements first. + + let eval = try eval_ast(ast, env) + + // The result had better be a list and better be non-empty. + + let eval_list = as_list(eval) + if eval_list.isEmpty { + return eval + } + + // Get the first element of the list and execute it. + + let first = eval_list.first() + let rest = as_sequence(eval_list.rest()) + + if let fn = as_builtinQ(first) { + let answer = try fn.apply(rest) + return answer + } + + // The first element wasn't a function to be executed. Return an + // error saying so. + + try throw_error("first list item does not evaluate to a function: \(first)") +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String, _ env: Environment) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + do { + return try EVAL(ast, env) + } catch let error as MalException { + print("Error evaluating input: \(error)") + } catch { + print("Error evaluating input: \(error)") + } + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String, _ env: Environment) -> String? { + let exp = RE(text, env) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL(env: Environment) { + while true { + if let text = _readline("user> ") { + if let output = REP(text, env) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +func main() { + let env = Environment(outer: nil) + + load_history_file() + load_builtins(env) + + REPL(env) + + save_history_file() +} diff --git a/impls/swift/step3_env.swift b/impls/swift/step3_env.swift index 7e3cde9d77..f55bce447b 100644 --- a/impls/swift/step3_env.swift +++ b/impls/swift/step3_env.swift @@ -1,234 +1,234 @@ -//****************************************************************************** -// MAL - step 3 - env -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// Symbols used in this module. -// -private let kValDef = make_symbol("def!") -private let kValLet = make_symbol("let*") -private let kValTry = make_symbol("try*") - -private let kSymbolDef = as_symbol(kValDef) -private let kSymbolLet = as_symbol(kValLet) - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Perform a simple evaluation of the `ast` object. If it's a symbol, -// dereference it and return its value. If it's a collection, call EVAL on all -// elements (or just the values, in the case of the hashmap). Otherwise, return -// the object unchanged. -// -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { - if let symbol = as_symbolQ(ast) { - guard let val = env.get(symbol) else { - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests - } - return val - } - if let list = as_listQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for item in list { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_list(result) - } - if let vec = as_vectorQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(vec.count)) - for item in vec { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_vector(result) - } - if let hash = as_hashmapQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(hash.count) * 2) - for (k, v) in hash { - let new_v = try EVAL(v, env) - result.append(k) - result.append(new_v) - } - return make_hashmap(result) - } - return ast -} - -// EVALuate "def!". -// -private func eval_def(list: MalSequence, _ env: Environment) throws -> MalVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to def!, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let sym = as_symbolQ(arg1) else { - try throw_error("expected symbol for first argument to def!") - } - let value = try EVAL(arg2, env) - return env.set(sym, value) -} - -// EVALuate "let*". -// -private func eval_let(list: MalSequence, _ env: Environment) throws -> MalVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to let*, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let bindings = as_sequenceQ(arg1) else { - try throw_error("expected list for first argument to let*") - } - guard bindings.count % 2 == 0 else { - try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") - } - let new_env = Environment(outer: env) - for var index: MalIntType = 0; index < bindings.count; index += 2 { - let binding_name = try! bindings.nth(index) - let binding_value = try! bindings.nth(index + 1) - guard let binding_symbol = as_symbolQ(binding_name) else { - try throw_error("expected symbol for first element in binding pair") - } - let evaluated_value = try EVAL(binding_value, new_env) - new_env.set(binding_symbol, evaluated_value) - } - return try EVAL(arg2, new_env) -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(ast: MalVal, _ env: Environment) throws -> MalVal { - - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - return answer - } - - // Special handling if it's a list. - - let list = as_list(ast) - - if list.isEmpty { - return ast - } - - // Check for special forms, where we want to check the operation - // before evaluating all of the parameters. - - let arg0 = list.first() - if let fn_symbol = as_symbolQ(arg0) { - - switch fn_symbol { - case kSymbolDef: return try eval_def(list, env) - case kSymbolLet: return try eval_let(list, env) - default: break - } - } - - // Standard list to be applied. Evaluate all the elements first. - - let eval = try eval_ast(ast, env) - - // The result had better be a list and better be non-empty. - - let eval_list = as_list(eval) - if eval_list.isEmpty { - return eval - } - - // Get the first element of the list and execute it. - - let first = eval_list.first() - let rest = as_sequence(eval_list.rest()) - - if let fn = as_builtinQ(first) { - let answer = try fn.apply(rest) - return answer - } - - // The first element wasn't a function to be executed. Return an - // error saying so. - - try throw_error("first list item does not evaluate to a function: \(first)") -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String, _ env: Environment) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - do { - return try EVAL(ast, env) - } catch let error as MalException { - print("Error evaluating input: \(error)") - } catch { - print("Error evaluating input: \(error)") - } - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String, _ env: Environment) -> String? { - let exp = RE(text, env) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL(env: Environment) { - while true { - if let text = _readline("user> ") { - if let output = REP(text, env) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -func main() { - let env = Environment(outer: nil) - - load_history_file() - load_builtins(env) - - REPL(env) - - save_history_file() -} +//****************************************************************************** +// MAL - step 3 - env +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// Symbols used in this module. +// +private let kValDef = make_symbol("def!") +private let kValLet = make_symbol("let*") +private let kValTry = make_symbol("try*") + +private let kSymbolDef = as_symbol(kValDef) +private let kSymbolLet = as_symbol(kValLet) + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Perform a simple evaluation of the `ast` object. If it's a symbol, +// dereference it and return its value. If it's a collection, call EVAL on all +// elements (or just the values, in the case of the hashmap). Otherwise, return +// the object unchanged. +// +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { + if let symbol = as_symbolQ(ast) { + guard let val = env.get(symbol) else { + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests + } + return val + } + if let list = as_listQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for item in list { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_list(result) + } + if let vec = as_vectorQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(vec.count)) + for item in vec { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_vector(result) + } + if let hash = as_hashmapQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(hash.count) * 2) + for (k, v) in hash { + let new_v = try EVAL(v, env) + result.append(k) + result.append(new_v) + } + return make_hashmap(result) + } + return ast +} + +// EVALuate "def!". +// +private func eval_def(list: MalSequence, _ env: Environment) throws -> MalVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to def!, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let sym = as_symbolQ(arg1) else { + try throw_error("expected symbol for first argument to def!") + } + let value = try EVAL(arg2, env) + return env.set(sym, value) +} + +// EVALuate "let*". +// +private func eval_let(list: MalSequence, _ env: Environment) throws -> MalVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to let*, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let bindings = as_sequenceQ(arg1) else { + try throw_error("expected list for first argument to let*") + } + guard bindings.count % 2 == 0 else { + try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") + } + let new_env = Environment(outer: env) + for var index: MalIntType = 0; index < bindings.count; index += 2 { + let binding_name = try! bindings.nth(index) + let binding_value = try! bindings.nth(index + 1) + guard let binding_symbol = as_symbolQ(binding_name) else { + try throw_error("expected symbol for first element in binding pair") + } + let evaluated_value = try EVAL(binding_value, new_env) + new_env.set(binding_symbol, evaluated_value) + } + return try EVAL(arg2, new_env) +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(ast: MalVal, _ env: Environment) throws -> MalVal { + + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + return answer + } + + // Special handling if it's a list. + + let list = as_list(ast) + + if list.isEmpty { + return ast + } + + // Check for special forms, where we want to check the operation + // before evaluating all of the parameters. + + let arg0 = list.first() + if let fn_symbol = as_symbolQ(arg0) { + + switch fn_symbol { + case kSymbolDef: return try eval_def(list, env) + case kSymbolLet: return try eval_let(list, env) + default: break + } + } + + // Standard list to be applied. Evaluate all the elements first. + + let eval = try eval_ast(ast, env) + + // The result had better be a list and better be non-empty. + + let eval_list = as_list(eval) + if eval_list.isEmpty { + return eval + } + + // Get the first element of the list and execute it. + + let first = eval_list.first() + let rest = as_sequence(eval_list.rest()) + + if let fn = as_builtinQ(first) { + let answer = try fn.apply(rest) + return answer + } + + // The first element wasn't a function to be executed. Return an + // error saying so. + + try throw_error("first list item does not evaluate to a function: \(first)") +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String, _ env: Environment) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + do { + return try EVAL(ast, env) + } catch let error as MalException { + print("Error evaluating input: \(error)") + } catch { + print("Error evaluating input: \(error)") + } + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String, _ env: Environment) -> String? { + let exp = RE(text, env) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL(env: Environment) { + while true { + if let text = _readline("user> ") { + if let output = REP(text, env) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +func main() { + let env = Environment(outer: nil) + + load_history_file() + load_builtins(env) + + REPL(env) + + save_history_file() +} diff --git a/impls/swift/step4_if_fn_do.swift b/impls/swift/step4_if_fn_do.swift index c27ee29493..4cd4c3936d 100644 --- a/impls/swift/step4_if_fn_do.swift +++ b/impls/swift/step4_if_fn_do.swift @@ -1,287 +1,287 @@ -//****************************************************************************** -// MAL - step 4 - if/fn/do -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// Symbols used in this module. -// -private let kValDef = make_symbol("def!") -private let kValDo = make_symbol("do") -private let kValFn = make_symbol("fn*") -private let kValIf = make_symbol("if") -private let kValLet = make_symbol("let*") -private let kValTry = make_symbol("try*") - -private let kSymbolDef = as_symbol(kValDef) -private let kSymbolDo = as_symbol(kValDo) -private let kSymbolFn = as_symbol(kValFn) -private let kSymbolIf = as_symbol(kValIf) -private let kSymbolLet = as_symbol(kValLet) - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Perform a simple evaluation of the `ast` object. If it's a symbol, -// dereference it and return its value. If it's a collection, call EVAL on all -// elements (or just the values, in the case of the hashmap). Otherwise, return -// the object unchanged. -// -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { - if let symbol = as_symbolQ(ast) { - guard let val = env.get(symbol) else { - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests - } - return val - } - if let list = as_listQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for item in list { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_list(result) - } - if let vec = as_vectorQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(vec.count)) - for item in vec { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_vector(result) - } - if let hash = as_hashmapQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(hash.count) * 2) - for (k, v) in hash { - let new_v = try EVAL(v, env) - result.append(k) - result.append(new_v) - } - return make_hashmap(result) - } - return ast -} - -// EVALuate "def!". -// -private func eval_def(list: MalSequence, _ env: Environment) throws -> MalVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to def!, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let sym = as_symbolQ(arg1) else { - try throw_error("expected symbol for first argument to def!") - } - let value = try EVAL(arg2, env) - return env.set(sym, value) -} - -// EVALuate "let*". -// -private func eval_let(list: MalSequence, _ env: Environment) throws -> MalVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to let*, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let bindings = as_sequenceQ(arg1) else { - try throw_error("expected list for first argument to let*") - } - guard bindings.count % 2 == 0 else { - try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") - } - let new_env = Environment(outer: env) - for var index: MalIntType = 0; index < bindings.count; index += 2 { - let binding_name = try! bindings.nth(index) - let binding_value = try! bindings.nth(index + 1) - guard let binding_symbol = as_symbolQ(binding_name) else { - try throw_error("expected symbol for first element in binding pair") - } - let evaluated_value = try EVAL(binding_value, new_env) - new_env.set(binding_symbol, evaluated_value) - } - return try EVAL(arg2, new_env) -} - -// EVALuate "do". -// -private func eval_do(list: MalSequence, _ env: Environment) throws -> MalVal { - let evaluated_ast = try eval_ast(list.rest(), env) - let evaluated_seq = as_sequence(evaluated_ast) - return evaluated_seq.last() -} - -// EVALuate "if". -// -private func eval_if(list: MalSequence, _ env: Environment) throws -> MalVal { - guard list.count >= 3 else { - try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") - } - let cond_result = try EVAL(try! list.nth(1), env) - var new_ast: MalVal - if is_truthy(cond_result) { - new_ast = try! list.nth(2) - } else if list.count == 4 { - new_ast = try! list.nth(3) - } else { - return make_nil() - } - return try EVAL(new_ast, env) -} - -// EVALuate "fn*". -// -private func eval_fn(list: MalSequence, _ env: Environment) throws -> MalVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") - } - guard let seq = as_sequenceQ(try! list.nth(1)) else { - try throw_error("expected list or vector for first argument to fn*") - } - return make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env)) -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(ast: MalVal, _ env: Environment) throws -> MalVal { - - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - return answer - } - - // Special handling if it's a list. - - let list = as_list(ast) - - if list.isEmpty { - return ast - } - - // Check for special forms, where we want to check the operation - // before evaluating all of the parameters. - - let arg0 = list.first() - if let fn_symbol = as_symbolQ(arg0) { - - switch fn_symbol { - case kSymbolDef: return try eval_def(list, env) - case kSymbolLet: return try eval_let(list, env) - case kSymbolDo: return try eval_do(list, env) - case kSymbolIf: return try eval_if(list, env) - case kSymbolFn: return try eval_fn(list, env) - default: break - } - } - - // Standard list to be applied. Evaluate all the elements first. - - let eval = try eval_ast(ast, env) - - // The result had better be a list and better be non-empty. - - let eval_list = as_list(eval) - if eval_list.isEmpty { - return eval - } - - // Get the first element of the list and execute it. - - let first = eval_list.first() - let rest = as_sequence(eval_list.rest()) - - if let fn = as_builtinQ(first) { - let answer = try fn.apply(rest) - return answer - } else if let fn = as_closureQ(first) { - let new_env = Environment(outer: fn.env) - let _ = try new_env.set_bindings(fn.args, with_exprs: rest) - let answer = try EVAL(fn.body, new_env) - return answer - } - - // The first element wasn't a function to be executed. Return an - // error saying so. - - try throw_error("first list item does not evaluate to a function: \(first)") -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String, _ env: Environment) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - do { - return try EVAL(ast, env) - } catch let error as MalException { - print("Error evaluating input: \(error)") - } catch { - print("Error evaluating input: \(error)") - } - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String, _ env: Environment) -> String? { - let exp = RE(text, env) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL(env: Environment) { - while true { - if let text = _readline("user> ") { - if let output = REP(text, env) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -func main() { - let env = Environment(outer: nil) - - load_history_file() - load_builtins(env) - - RE("(def! not (fn* (a) (if a false true)))", env) - REPL(env) - - save_history_file() -} +//****************************************************************************** +// MAL - step 4 - if/fn/do +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// Symbols used in this module. +// +private let kValDef = make_symbol("def!") +private let kValDo = make_symbol("do") +private let kValFn = make_symbol("fn*") +private let kValIf = make_symbol("if") +private let kValLet = make_symbol("let*") +private let kValTry = make_symbol("try*") + +private let kSymbolDef = as_symbol(kValDef) +private let kSymbolDo = as_symbol(kValDo) +private let kSymbolFn = as_symbol(kValFn) +private let kSymbolIf = as_symbol(kValIf) +private let kSymbolLet = as_symbol(kValLet) + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Perform a simple evaluation of the `ast` object. If it's a symbol, +// dereference it and return its value. If it's a collection, call EVAL on all +// elements (or just the values, in the case of the hashmap). Otherwise, return +// the object unchanged. +// +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { + if let symbol = as_symbolQ(ast) { + guard let val = env.get(symbol) else { + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests + } + return val + } + if let list = as_listQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for item in list { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_list(result) + } + if let vec = as_vectorQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(vec.count)) + for item in vec { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_vector(result) + } + if let hash = as_hashmapQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(hash.count) * 2) + for (k, v) in hash { + let new_v = try EVAL(v, env) + result.append(k) + result.append(new_v) + } + return make_hashmap(result) + } + return ast +} + +// EVALuate "def!". +// +private func eval_def(list: MalSequence, _ env: Environment) throws -> MalVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to def!, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let sym = as_symbolQ(arg1) else { + try throw_error("expected symbol for first argument to def!") + } + let value = try EVAL(arg2, env) + return env.set(sym, value) +} + +// EVALuate "let*". +// +private func eval_let(list: MalSequence, _ env: Environment) throws -> MalVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to let*, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let bindings = as_sequenceQ(arg1) else { + try throw_error("expected list for first argument to let*") + } + guard bindings.count % 2 == 0 else { + try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") + } + let new_env = Environment(outer: env) + for var index: MalIntType = 0; index < bindings.count; index += 2 { + let binding_name = try! bindings.nth(index) + let binding_value = try! bindings.nth(index + 1) + guard let binding_symbol = as_symbolQ(binding_name) else { + try throw_error("expected symbol for first element in binding pair") + } + let evaluated_value = try EVAL(binding_value, new_env) + new_env.set(binding_symbol, evaluated_value) + } + return try EVAL(arg2, new_env) +} + +// EVALuate "do". +// +private func eval_do(list: MalSequence, _ env: Environment) throws -> MalVal { + let evaluated_ast = try eval_ast(list.rest(), env) + let evaluated_seq = as_sequence(evaluated_ast) + return evaluated_seq.last() +} + +// EVALuate "if". +// +private func eval_if(list: MalSequence, _ env: Environment) throws -> MalVal { + guard list.count >= 3 else { + try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") + } + let cond_result = try EVAL(try! list.nth(1), env) + var new_ast: MalVal + if is_truthy(cond_result) { + new_ast = try! list.nth(2) + } else if list.count == 4 { + new_ast = try! list.nth(3) + } else { + return make_nil() + } + return try EVAL(new_ast, env) +} + +// EVALuate "fn*". +// +private func eval_fn(list: MalSequence, _ env: Environment) throws -> MalVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") + } + guard let seq = as_sequenceQ(try! list.nth(1)) else { + try throw_error("expected list or vector for first argument to fn*") + } + return make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env)) +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(ast: MalVal, _ env: Environment) throws -> MalVal { + + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + return answer + } + + // Special handling if it's a list. + + let list = as_list(ast) + + if list.isEmpty { + return ast + } + + // Check for special forms, where we want to check the operation + // before evaluating all of the parameters. + + let arg0 = list.first() + if let fn_symbol = as_symbolQ(arg0) { + + switch fn_symbol { + case kSymbolDef: return try eval_def(list, env) + case kSymbolLet: return try eval_let(list, env) + case kSymbolDo: return try eval_do(list, env) + case kSymbolIf: return try eval_if(list, env) + case kSymbolFn: return try eval_fn(list, env) + default: break + } + } + + // Standard list to be applied. Evaluate all the elements first. + + let eval = try eval_ast(ast, env) + + // The result had better be a list and better be non-empty. + + let eval_list = as_list(eval) + if eval_list.isEmpty { + return eval + } + + // Get the first element of the list and execute it. + + let first = eval_list.first() + let rest = as_sequence(eval_list.rest()) + + if let fn = as_builtinQ(first) { + let answer = try fn.apply(rest) + return answer + } else if let fn = as_closureQ(first) { + let new_env = Environment(outer: fn.env) + let _ = try new_env.set_bindings(fn.args, with_exprs: rest) + let answer = try EVAL(fn.body, new_env) + return answer + } + + // The first element wasn't a function to be executed. Return an + // error saying so. + + try throw_error("first list item does not evaluate to a function: \(first)") +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String, _ env: Environment) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + do { + return try EVAL(ast, env) + } catch let error as MalException { + print("Error evaluating input: \(error)") + } catch { + print("Error evaluating input: \(error)") + } + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String, _ env: Environment) -> String? { + let exp = RE(text, env) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL(env: Environment) { + while true { + if let text = _readline("user> ") { + if let output = REP(text, env) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +func main() { + let env = Environment(outer: nil) + + load_history_file() + load_builtins(env) + + RE("(def! not (fn* (a) (if a false true)))", env) + REPL(env) + + save_history_file() +} diff --git a/impls/swift/step5_tco.swift b/impls/swift/step5_tco.swift index 286414ee8b..c6f28d88e2 100644 --- a/impls/swift/step5_tco.swift +++ b/impls/swift/step5_tco.swift @@ -1,382 +1,382 @@ -//****************************************************************************** -// MAL - step 5 - tco -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// The number of times EVAL has been entered recursively. We keep track of this -// so that we can protect against overrunning the stack. -// -private var EVAL_level = 0 - -// The maximum number of times we let EVAL recurse before throwing an exception. -// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 -// for safety's sake. -// -private let EVAL_leval_max = 500 - -// Control whether or not tail-call optimization (TCO) is enabled. We want it -// `true` most of the time, but may disable it for debugging purposes (it's -// easier to get a meaningful backtrace that way). -// -private let TCO = true - -// Control whether or not we emit debugging statements in EVAL. -// -private let DEBUG_EVAL = false - -// String used to prefix information logged in EVAL. Increasing lengths of the -// string are used the more EVAL is recursed. -// -private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" - -// Holds the prefix of INDENT_TEMPLATE used for actual logging. -// -private var indent = String() - -// Symbols used in this module. -// -private let kValDef = make_symbol("def!") -private let kValDo = make_symbol("do") -private let kValFn = make_symbol("fn*") -private let kValIf = make_symbol("if") -private let kValLet = make_symbol("let*") -private let kValTry = make_symbol("try*") - -private let kSymbolDef = as_symbol(kValDef) -private let kSymbolDo = as_symbol(kValDo) -private let kSymbolFn = as_symbol(kValFn) -private let kSymbolIf = as_symbol(kValIf) -private let kSymbolLet = as_symbol(kValLet) - -func substring(s: String, _ begin: Int, _ end: Int) -> String { - return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] -} - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Perform a simple evaluation of the `ast` object. If it's a symbol, -// dereference it and return its value. If it's a collection, call EVAL on all -// elements (or just the values, in the case of the hashmap). Otherwise, return -// the object unchanged. -// -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { - if let symbol = as_symbolQ(ast) { - guard let val = env.get(symbol) else { - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests - } - return val - } - if let list = as_listQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for item in list { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_list(result) - } - if let vec = as_vectorQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(vec.count)) - for item in vec { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_vector(result) - } - if let hash = as_hashmapQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(hash.count) * 2) - for (k, v) in hash { - let new_v = try EVAL(v, env) - result.append(k) - result.append(new_v) - } - return make_hashmap(result) - } - return ast -} - -private enum TCOVal { - case NoResult - case Return(MalVal) - case Continue(MalVal, Environment) - - init() { self = .NoResult } - init(_ result: MalVal) { self = .Return(result) } - init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } -} - -// EVALuate "def!". -// -private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to def!, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let sym = as_symbolQ(arg1) else { - try throw_error("expected symbol for first argument to def!") - } - let value = try EVAL(arg2, env) - return TCOVal(env.set(sym, value)) -} - -// EVALuate "let*". -// -private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to let*, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let bindings = as_sequenceQ(arg1) else { - try throw_error("expected list for first argument to let*") - } - guard bindings.count % 2 == 0 else { - try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") - } - let new_env = Environment(outer: env) - for var index: MalIntType = 0; index < bindings.count; index += 2 { - let binding_name = try! bindings.nth(index) - let binding_value = try! bindings.nth(index + 1) - guard let binding_symbol = as_symbolQ(binding_name) else { - try throw_error("expected symbol for first element in binding pair") - } - let evaluated_value = try EVAL(binding_value, new_env) - new_env.set(binding_symbol, evaluated_value) - } - if TCO { - return TCOVal(arg2, new_env) - } - return TCOVal(try EVAL(arg2, new_env)) -} - -// EVALuate "do". -// -private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { - if TCO { - let _ = try eval_ast(list.range_from(1, to: list.count-1), env) - return TCOVal(list.last(), env) - } - - let evaluated_ast = try eval_ast(list.rest(), env) - let evaluated_seq = as_sequence(evaluated_ast) - return TCOVal(evaluated_seq.last()) -} - -// EVALuate "if". -// -private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 3 else { - try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") - } - let cond_result = try EVAL(try! list.nth(1), env) - var new_ast: MalVal - if is_truthy(cond_result) { - new_ast = try! list.nth(2) - } else if list.count == 4 { - new_ast = try! list.nth(3) - } else { - return TCOVal(make_nil()) - } - if TCO { - return TCOVal(new_ast, env) - } - return TCOVal(try EVAL(new_ast, env)) -} - -// EVALuate "fn*". -// -private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") - } - guard let seq = as_sequenceQ(try! list.nth(1)) else { - try throw_error("expected list or vector for first argument to fn*") - } - return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { - EVAL_level++ - defer { EVAL_level-- } - guard EVAL_level <= EVAL_leval_max else { - try throw_error("Recursing too many levels (> \(EVAL_leval_max))") - } - - if DEBUG_EVAL { - indent = substring(INDENT_TEMPLATE, 0, EVAL_level) - } - - while true { - if DEBUG_EVAL { print("\(indent)> \(ast)") } - - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // Special handling if it's a list. - - let list = as_list(ast) - if DEBUG_EVAL { print("\(indent)>. \(list)") } - - if list.isEmpty { - return ast - } - - // Check for special forms, where we want to check the operation - // before evaluating all of the parameters. - - let arg0 = list.first() - if let fn_symbol = as_symbolQ(arg0) { - let res: TCOVal - - switch fn_symbol { - case kSymbolDef: res = try eval_def(list, env) - case kSymbolLet: res = try eval_let(list, env) - case kSymbolDo: res = try eval_do(list, env) - case kSymbolIf: res = try eval_if(list, env) - case kSymbolFn: res = try eval_fn(list, env) - default: res = TCOVal() - } - switch res { - case let .Return(result): return result - case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue - case .NoResult: break - } - } - - // Standard list to be applied. Evaluate all the elements first. - - let eval = try eval_ast(ast, env) - - // The result had better be a list and better be non-empty. - - let eval_list = as_list(eval) - if eval_list.isEmpty { - return eval - } - - if DEBUG_EVAL { print("\(indent)>> \(eval)") } - - // Get the first element of the list and execute it. - - let first = eval_list.first() - let rest = as_sequence(eval_list.rest()) - - if let fn = as_builtinQ(first) { - let answer = try fn.apply(rest) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } else if let fn = as_closureQ(first) { - let new_env = Environment(outer: fn.env) - let _ = try new_env.set_bindings(fn.args, with_exprs: rest) - if TCO { - env = new_env - ast = fn.body - continue - } - let answer = try EVAL(fn.body, new_env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // The first element wasn't a function to be executed. Return an - // error saying so. - - try throw_error("first list item does not evaluate to a function: \(first)") - } -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String, _ env: Environment) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - do { - return try EVAL(ast, env) - } catch let error as MalException { - print("Error evaluating input: \(error)") - } catch { - print("Error evaluating input: \(error)") - } - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String, _ env: Environment) -> String? { - let exp = RE(text, env) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL(env: Environment) { - while true { - if let text = _readline("user> ") { - if let output = REP(text, env) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -func main() { - let env = Environment(outer: nil) - - load_history_file() - load_builtins(env) - - RE("(def! not (fn* (a) (if a false true)))", env) - REPL(env) - - save_history_file() -} +//****************************************************************************** +// MAL - step 5 - tco +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// The number of times EVAL has been entered recursively. We keep track of this +// so that we can protect against overrunning the stack. +// +private var EVAL_level = 0 + +// The maximum number of times we let EVAL recurse before throwing an exception. +// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 +// for safety's sake. +// +private let EVAL_leval_max = 500 + +// Control whether or not tail-call optimization (TCO) is enabled. We want it +// `true` most of the time, but may disable it for debugging purposes (it's +// easier to get a meaningful backtrace that way). +// +private let TCO = true + +// Control whether or not we emit debugging statements in EVAL. +// +private let DEBUG_EVAL = false + +// String used to prefix information logged in EVAL. Increasing lengths of the +// string are used the more EVAL is recursed. +// +private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + +// Holds the prefix of INDENT_TEMPLATE used for actual logging. +// +private var indent = String() + +// Symbols used in this module. +// +private let kValDef = make_symbol("def!") +private let kValDo = make_symbol("do") +private let kValFn = make_symbol("fn*") +private let kValIf = make_symbol("if") +private let kValLet = make_symbol("let*") +private let kValTry = make_symbol("try*") + +private let kSymbolDef = as_symbol(kValDef) +private let kSymbolDo = as_symbol(kValDo) +private let kSymbolFn = as_symbol(kValFn) +private let kSymbolIf = as_symbol(kValIf) +private let kSymbolLet = as_symbol(kValLet) + +func substring(s: String, _ begin: Int, _ end: Int) -> String { + return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] +} + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Perform a simple evaluation of the `ast` object. If it's a symbol, +// dereference it and return its value. If it's a collection, call EVAL on all +// elements (or just the values, in the case of the hashmap). Otherwise, return +// the object unchanged. +// +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { + if let symbol = as_symbolQ(ast) { + guard let val = env.get(symbol) else { + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests + } + return val + } + if let list = as_listQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for item in list { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_list(result) + } + if let vec = as_vectorQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(vec.count)) + for item in vec { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_vector(result) + } + if let hash = as_hashmapQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(hash.count) * 2) + for (k, v) in hash { + let new_v = try EVAL(v, env) + result.append(k) + result.append(new_v) + } + return make_hashmap(result) + } + return ast +} + +private enum TCOVal { + case NoResult + case Return(MalVal) + case Continue(MalVal, Environment) + + init() { self = .NoResult } + init(_ result: MalVal) { self = .Return(result) } + init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } +} + +// EVALuate "def!". +// +private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to def!, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let sym = as_symbolQ(arg1) else { + try throw_error("expected symbol for first argument to def!") + } + let value = try EVAL(arg2, env) + return TCOVal(env.set(sym, value)) +} + +// EVALuate "let*". +// +private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to let*, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let bindings = as_sequenceQ(arg1) else { + try throw_error("expected list for first argument to let*") + } + guard bindings.count % 2 == 0 else { + try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") + } + let new_env = Environment(outer: env) + for var index: MalIntType = 0; index < bindings.count; index += 2 { + let binding_name = try! bindings.nth(index) + let binding_value = try! bindings.nth(index + 1) + guard let binding_symbol = as_symbolQ(binding_name) else { + try throw_error("expected symbol for first element in binding pair") + } + let evaluated_value = try EVAL(binding_value, new_env) + new_env.set(binding_symbol, evaluated_value) + } + if TCO { + return TCOVal(arg2, new_env) + } + return TCOVal(try EVAL(arg2, new_env)) +} + +// EVALuate "do". +// +private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { + if TCO { + let _ = try eval_ast(list.range_from(1, to: list.count-1), env) + return TCOVal(list.last(), env) + } + + let evaluated_ast = try eval_ast(list.rest(), env) + let evaluated_seq = as_sequence(evaluated_ast) + return TCOVal(evaluated_seq.last()) +} + +// EVALuate "if". +// +private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 3 else { + try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") + } + let cond_result = try EVAL(try! list.nth(1), env) + var new_ast: MalVal + if is_truthy(cond_result) { + new_ast = try! list.nth(2) + } else if list.count == 4 { + new_ast = try! list.nth(3) + } else { + return TCOVal(make_nil()) + } + if TCO { + return TCOVal(new_ast, env) + } + return TCOVal(try EVAL(new_ast, env)) +} + +// EVALuate "fn*". +// +private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") + } + guard let seq = as_sequenceQ(try! list.nth(1)) else { + try throw_error("expected list or vector for first argument to fn*") + } + return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { + EVAL_level++ + defer { EVAL_level-- } + guard EVAL_level <= EVAL_leval_max else { + try throw_error("Recursing too many levels (> \(EVAL_leval_max))") + } + + if DEBUG_EVAL { + indent = substring(INDENT_TEMPLATE, 0, EVAL_level) + } + + while true { + if DEBUG_EVAL { print("\(indent)> \(ast)") } + + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // Special handling if it's a list. + + let list = as_list(ast) + if DEBUG_EVAL { print("\(indent)>. \(list)") } + + if list.isEmpty { + return ast + } + + // Check for special forms, where we want to check the operation + // before evaluating all of the parameters. + + let arg0 = list.first() + if let fn_symbol = as_symbolQ(arg0) { + let res: TCOVal + + switch fn_symbol { + case kSymbolDef: res = try eval_def(list, env) + case kSymbolLet: res = try eval_let(list, env) + case kSymbolDo: res = try eval_do(list, env) + case kSymbolIf: res = try eval_if(list, env) + case kSymbolFn: res = try eval_fn(list, env) + default: res = TCOVal() + } + switch res { + case let .Return(result): return result + case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue + case .NoResult: break + } + } + + // Standard list to be applied. Evaluate all the elements first. + + let eval = try eval_ast(ast, env) + + // The result had better be a list and better be non-empty. + + let eval_list = as_list(eval) + if eval_list.isEmpty { + return eval + } + + if DEBUG_EVAL { print("\(indent)>> \(eval)") } + + // Get the first element of the list and execute it. + + let first = eval_list.first() + let rest = as_sequence(eval_list.rest()) + + if let fn = as_builtinQ(first) { + let answer = try fn.apply(rest) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } else if let fn = as_closureQ(first) { + let new_env = Environment(outer: fn.env) + let _ = try new_env.set_bindings(fn.args, with_exprs: rest) + if TCO { + env = new_env + ast = fn.body + continue + } + let answer = try EVAL(fn.body, new_env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // The first element wasn't a function to be executed. Return an + // error saying so. + + try throw_error("first list item does not evaluate to a function: \(first)") + } +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String, _ env: Environment) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + do { + return try EVAL(ast, env) + } catch let error as MalException { + print("Error evaluating input: \(error)") + } catch { + print("Error evaluating input: \(error)") + } + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String, _ env: Environment) -> String? { + let exp = RE(text, env) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL(env: Environment) { + while true { + if let text = _readline("user> ") { + if let output = REP(text, env) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +func main() { + let env = Environment(outer: nil) + + load_history_file() + load_builtins(env) + + RE("(def! not (fn* (a) (if a false true)))", env) + REPL(env) + + save_history_file() +} diff --git a/impls/swift/step6_file.swift b/impls/swift/step6_file.swift index 962fd8d84c..7977825f71 100644 --- a/impls/swift/step6_file.swift +++ b/impls/swift/step6_file.swift @@ -1,420 +1,420 @@ -//****************************************************************************** -// MAL - step 6 - file -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// The number of times EVAL has been entered recursively. We keep track of this -// so that we can protect against overrunning the stack. -// -private var EVAL_level = 0 - -// The maximum number of times we let EVAL recurse before throwing an exception. -// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 -// for safety's sake. -// -private let EVAL_leval_max = 500 - -// Control whether or not tail-call optimization (TCO) is enabled. We want it -// `true` most of the time, but may disable it for debugging purposes (it's -// easier to get a meaningful backtrace that way). -// -private let TCO = true - -// Control whether or not we emit debugging statements in EVAL. -// -private let DEBUG_EVAL = false - -// String used to prefix information logged in EVAL. Increasing lengths of the -// string are used the more EVAL is recursed. -// -private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" - -// Holds the prefix of INDENT_TEMPLATE used for actual logging. -// -private var indent = String() - -// Symbols used in this module. -// -private let kValArgv = make_symbol("*ARGV*") -private let kValDef = make_symbol("def!") -private let kValDo = make_symbol("do") -private let kValEval = make_symbol("eval") -private let kValFn = make_symbol("fn*") -private let kValIf = make_symbol("if") -private let kValLet = make_symbol("let*") -private let kValTry = make_symbol("try*") - -private let kSymbolArgv = as_symbol(kValArgv) -private let kSymbolDef = as_symbol(kValDef) -private let kSymbolDo = as_symbol(kValDo) -private let kSymbolEval = as_symbol(kValEval) -private let kSymbolFn = as_symbol(kValFn) -private let kSymbolIf = as_symbol(kValIf) -private let kSymbolLet = as_symbol(kValLet) - -func substring(s: String, _ begin: Int, _ end: Int) -> String { - return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] -} - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Perform a simple evaluation of the `ast` object. If it's a symbol, -// dereference it and return its value. If it's a collection, call EVAL on all -// elements (or just the values, in the case of the hashmap). Otherwise, return -// the object unchanged. -// -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { - if let symbol = as_symbolQ(ast) { - guard let val = env.get(symbol) else { - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests - } - return val - } - if let list = as_listQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for item in list { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_list(result) - } - if let vec = as_vectorQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(vec.count)) - for item in vec { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_vector(result) - } - if let hash = as_hashmapQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(hash.count) * 2) - for (k, v) in hash { - let new_v = try EVAL(v, env) - result.append(k) - result.append(new_v) - } - return make_hashmap(result) - } - return ast -} - -private enum TCOVal { - case NoResult - case Return(MalVal) - case Continue(MalVal, Environment) - - init() { self = .NoResult } - init(_ result: MalVal) { self = .Return(result) } - init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } -} - -// EVALuate "def!". -// -private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to def!, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let sym = as_symbolQ(arg1) else { - try throw_error("expected symbol for first argument to def!") - } - let value = try EVAL(arg2, env) - return TCOVal(env.set(sym, value)) -} - -// EVALuate "let*". -// -private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to let*, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let bindings = as_sequenceQ(arg1) else { - try throw_error("expected list for first argument to let*") - } - guard bindings.count % 2 == 0 else { - try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") - } - let new_env = Environment(outer: env) - for var index: MalIntType = 0; index < bindings.count; index += 2 { - let binding_name = try! bindings.nth(index) - let binding_value = try! bindings.nth(index + 1) - guard let binding_symbol = as_symbolQ(binding_name) else { - try throw_error("expected symbol for first element in binding pair") - } - let evaluated_value = try EVAL(binding_value, new_env) - new_env.set(binding_symbol, evaluated_value) - } - if TCO { - return TCOVal(arg2, new_env) - } - return TCOVal(try EVAL(arg2, new_env)) -} - -// EVALuate "do". -// -private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { - if TCO { - let _ = try eval_ast(list.range_from(1, to: list.count-1), env) - return TCOVal(list.last(), env) - } - - let evaluated_ast = try eval_ast(list.rest(), env) - let evaluated_seq = as_sequence(evaluated_ast) - return TCOVal(evaluated_seq.last()) -} - -// EVALuate "if". -// -private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 3 else { - try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") - } - let cond_result = try EVAL(try! list.nth(1), env) - var new_ast: MalVal - if is_truthy(cond_result) { - new_ast = try! list.nth(2) - } else if list.count == 4 { - new_ast = try! list.nth(3) - } else { - return TCOVal(make_nil()) - } - if TCO { - return TCOVal(new_ast, env) - } - return TCOVal(try EVAL(new_ast, env)) -} - -// EVALuate "fn*". -// -private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") - } - guard let seq = as_sequenceQ(try! list.nth(1)) else { - try throw_error("expected list or vector for first argument to fn*") - } - return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { - EVAL_level++ - defer { EVAL_level-- } - guard EVAL_level <= EVAL_leval_max else { - try throw_error("Recursing too many levels (> \(EVAL_leval_max))") - } - - if DEBUG_EVAL { - indent = substring(INDENT_TEMPLATE, 0, EVAL_level) - } - - while true { - if DEBUG_EVAL { print("\(indent)> \(ast)") } - - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // Special handling if it's a list. - - let list = as_list(ast) - if DEBUG_EVAL { print("\(indent)>. \(list)") } - - if list.isEmpty { - return ast - } - - // Check for special forms, where we want to check the operation - // before evaluating all of the parameters. - - let arg0 = list.first() - if let fn_symbol = as_symbolQ(arg0) { - let res: TCOVal - - switch fn_symbol { - case kSymbolDef: res = try eval_def(list, env) - case kSymbolLet: res = try eval_let(list, env) - case kSymbolDo: res = try eval_do(list, env) - case kSymbolIf: res = try eval_if(list, env) - case kSymbolFn: res = try eval_fn(list, env) - default: res = TCOVal() - } - switch res { - case let .Return(result): return result - case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue - case .NoResult: break - } - } - - // Standard list to be applied. Evaluate all the elements first. - - let eval = try eval_ast(ast, env) - - // The result had better be a list and better be non-empty. - - let eval_list = as_list(eval) - if eval_list.isEmpty { - return eval - } - - if DEBUG_EVAL { print("\(indent)>> \(eval)") } - - // Get the first element of the list and execute it. - - let first = eval_list.first() - let rest = as_sequence(eval_list.rest()) - - if let fn = as_builtinQ(first) { - let answer = try fn.apply(rest) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } else if let fn = as_closureQ(first) { - let new_env = Environment(outer: fn.env) - let _ = try new_env.set_bindings(fn.args, with_exprs: rest) - if TCO { - env = new_env - ast = fn.body - continue - } - let answer = try EVAL(fn.body, new_env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // The first element wasn't a function to be executed. Return an - // error saying so. - - try throw_error("first list item does not evaluate to a function: \(first)") - } -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String, _ env: Environment) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - do { - return try EVAL(ast, env) - } catch let error as MalException { - print("Error evaluating input: \(error)") - } catch { - print("Error evaluating input: \(error)") - } - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String, _ env: Environment) -> String? { - let exp = RE(text, env) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL(env: Environment) { - while true { - if let text = _readline("user> ") { - if let output = REP(text, env) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -// Process any command line arguments. Any trailing arguments are incorporated -// into the environment. Any argument immediately after the process name is -// taken as a script to execute. If one exists, it is executed in lieu of -// running the REPL. -// -private func process_command_line(args: [String], _ env: Environment) -> Bool { - var argv = make_list() - if args.count > 2 { - let args1 = args[2.. 1 { - RE("(load-file \"\(args[1])\")", env) - return false - } - - return true -} - -func main() { - let env = Environment(outer: nil) - - load_history_file() - load_builtins(env) - - RE("(def! not (fn* (a) (if a false true)))", env) - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) - - env.set(kSymbolEval, make_builtin({ - try! unwrap_args($0) { - (ast: MalVal) -> MalVal in - try EVAL(ast, env) - } - })) - - if process_command_line(Process.arguments, env) { - REPL(env) - } - - save_history_file() -} +//****************************************************************************** +// MAL - step 6 - file +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// The number of times EVAL has been entered recursively. We keep track of this +// so that we can protect against overrunning the stack. +// +private var EVAL_level = 0 + +// The maximum number of times we let EVAL recurse before throwing an exception. +// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 +// for safety's sake. +// +private let EVAL_leval_max = 500 + +// Control whether or not tail-call optimization (TCO) is enabled. We want it +// `true` most of the time, but may disable it for debugging purposes (it's +// easier to get a meaningful backtrace that way). +// +private let TCO = true + +// Control whether or not we emit debugging statements in EVAL. +// +private let DEBUG_EVAL = false + +// String used to prefix information logged in EVAL. Increasing lengths of the +// string are used the more EVAL is recursed. +// +private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + +// Holds the prefix of INDENT_TEMPLATE used for actual logging. +// +private var indent = String() + +// Symbols used in this module. +// +private let kValArgv = make_symbol("*ARGV*") +private let kValDef = make_symbol("def!") +private let kValDo = make_symbol("do") +private let kValEval = make_symbol("eval") +private let kValFn = make_symbol("fn*") +private let kValIf = make_symbol("if") +private let kValLet = make_symbol("let*") +private let kValTry = make_symbol("try*") + +private let kSymbolArgv = as_symbol(kValArgv) +private let kSymbolDef = as_symbol(kValDef) +private let kSymbolDo = as_symbol(kValDo) +private let kSymbolEval = as_symbol(kValEval) +private let kSymbolFn = as_symbol(kValFn) +private let kSymbolIf = as_symbol(kValIf) +private let kSymbolLet = as_symbol(kValLet) + +func substring(s: String, _ begin: Int, _ end: Int) -> String { + return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] +} + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Perform a simple evaluation of the `ast` object. If it's a symbol, +// dereference it and return its value. If it's a collection, call EVAL on all +// elements (or just the values, in the case of the hashmap). Otherwise, return +// the object unchanged. +// +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { + if let symbol = as_symbolQ(ast) { + guard let val = env.get(symbol) else { + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests + } + return val + } + if let list = as_listQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for item in list { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_list(result) + } + if let vec = as_vectorQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(vec.count)) + for item in vec { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_vector(result) + } + if let hash = as_hashmapQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(hash.count) * 2) + for (k, v) in hash { + let new_v = try EVAL(v, env) + result.append(k) + result.append(new_v) + } + return make_hashmap(result) + } + return ast +} + +private enum TCOVal { + case NoResult + case Return(MalVal) + case Continue(MalVal, Environment) + + init() { self = .NoResult } + init(_ result: MalVal) { self = .Return(result) } + init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } +} + +// EVALuate "def!". +// +private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to def!, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let sym = as_symbolQ(arg1) else { + try throw_error("expected symbol for first argument to def!") + } + let value = try EVAL(arg2, env) + return TCOVal(env.set(sym, value)) +} + +// EVALuate "let*". +// +private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to let*, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let bindings = as_sequenceQ(arg1) else { + try throw_error("expected list for first argument to let*") + } + guard bindings.count % 2 == 0 else { + try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") + } + let new_env = Environment(outer: env) + for var index: MalIntType = 0; index < bindings.count; index += 2 { + let binding_name = try! bindings.nth(index) + let binding_value = try! bindings.nth(index + 1) + guard let binding_symbol = as_symbolQ(binding_name) else { + try throw_error("expected symbol for first element in binding pair") + } + let evaluated_value = try EVAL(binding_value, new_env) + new_env.set(binding_symbol, evaluated_value) + } + if TCO { + return TCOVal(arg2, new_env) + } + return TCOVal(try EVAL(arg2, new_env)) +} + +// EVALuate "do". +// +private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { + if TCO { + let _ = try eval_ast(list.range_from(1, to: list.count-1), env) + return TCOVal(list.last(), env) + } + + let evaluated_ast = try eval_ast(list.rest(), env) + let evaluated_seq = as_sequence(evaluated_ast) + return TCOVal(evaluated_seq.last()) +} + +// EVALuate "if". +// +private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 3 else { + try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") + } + let cond_result = try EVAL(try! list.nth(1), env) + var new_ast: MalVal + if is_truthy(cond_result) { + new_ast = try! list.nth(2) + } else if list.count == 4 { + new_ast = try! list.nth(3) + } else { + return TCOVal(make_nil()) + } + if TCO { + return TCOVal(new_ast, env) + } + return TCOVal(try EVAL(new_ast, env)) +} + +// EVALuate "fn*". +// +private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") + } + guard let seq = as_sequenceQ(try! list.nth(1)) else { + try throw_error("expected list or vector for first argument to fn*") + } + return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { + EVAL_level++ + defer { EVAL_level-- } + guard EVAL_level <= EVAL_leval_max else { + try throw_error("Recursing too many levels (> \(EVAL_leval_max))") + } + + if DEBUG_EVAL { + indent = substring(INDENT_TEMPLATE, 0, EVAL_level) + } + + while true { + if DEBUG_EVAL { print("\(indent)> \(ast)") } + + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // Special handling if it's a list. + + let list = as_list(ast) + if DEBUG_EVAL { print("\(indent)>. \(list)") } + + if list.isEmpty { + return ast + } + + // Check for special forms, where we want to check the operation + // before evaluating all of the parameters. + + let arg0 = list.first() + if let fn_symbol = as_symbolQ(arg0) { + let res: TCOVal + + switch fn_symbol { + case kSymbolDef: res = try eval_def(list, env) + case kSymbolLet: res = try eval_let(list, env) + case kSymbolDo: res = try eval_do(list, env) + case kSymbolIf: res = try eval_if(list, env) + case kSymbolFn: res = try eval_fn(list, env) + default: res = TCOVal() + } + switch res { + case let .Return(result): return result + case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue + case .NoResult: break + } + } + + // Standard list to be applied. Evaluate all the elements first. + + let eval = try eval_ast(ast, env) + + // The result had better be a list and better be non-empty. + + let eval_list = as_list(eval) + if eval_list.isEmpty { + return eval + } + + if DEBUG_EVAL { print("\(indent)>> \(eval)") } + + // Get the first element of the list and execute it. + + let first = eval_list.first() + let rest = as_sequence(eval_list.rest()) + + if let fn = as_builtinQ(first) { + let answer = try fn.apply(rest) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } else if let fn = as_closureQ(first) { + let new_env = Environment(outer: fn.env) + let _ = try new_env.set_bindings(fn.args, with_exprs: rest) + if TCO { + env = new_env + ast = fn.body + continue + } + let answer = try EVAL(fn.body, new_env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // The first element wasn't a function to be executed. Return an + // error saying so. + + try throw_error("first list item does not evaluate to a function: \(first)") + } +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String, _ env: Environment) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + do { + return try EVAL(ast, env) + } catch let error as MalException { + print("Error evaluating input: \(error)") + } catch { + print("Error evaluating input: \(error)") + } + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String, _ env: Environment) -> String? { + let exp = RE(text, env) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL(env: Environment) { + while true { + if let text = _readline("user> ") { + if let output = REP(text, env) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +// Process any command line arguments. Any trailing arguments are incorporated +// into the environment. Any argument immediately after the process name is +// taken as a script to execute. If one exists, it is executed in lieu of +// running the REPL. +// +private func process_command_line(args: [String], _ env: Environment) -> Bool { + var argv = make_list() + if args.count > 2 { + let args1 = args[2.. 1 { + RE("(load-file \"\(args[1])\")", env) + return false + } + + return true +} + +func main() { + let env = Environment(outer: nil) + + load_history_file() + load_builtins(env) + + RE("(def! not (fn* (a) (if a false true)))", env) + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) + + env.set(kSymbolEval, make_builtin({ + try! unwrap_args($0) { + (ast: MalVal) -> MalVal in + try EVAL(ast, env) + } + })) + + if process_command_line(Process.arguments, env) { + REPL(env) + } + + save_history_file() +} diff --git a/impls/swift/step7_quote.swift b/impls/swift/step7_quote.swift index f9397a76a5..8a71d3d8fa 100644 --- a/impls/swift/step7_quote.swift +++ b/impls/swift/step7_quote.swift @@ -1,521 +1,521 @@ -//****************************************************************************** -// MAL - step 7 - quote -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// The number of times EVAL has been entered recursively. We keep track of this -// so that we can protect against overrunning the stack. -// -private var EVAL_level = 0 - -// The maximum number of times we let EVAL recurse before throwing an exception. -// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 -// for safety's sake. -// -private let EVAL_leval_max = 500 - -// Control whether or not tail-call optimization (TCO) is enabled. We want it -// `true` most of the time, but may disable it for debugging purposes (it's -// easier to get a meaningful backtrace that way). -// -private let TCO = true - -// Control whether or not we emit debugging statements in EVAL. -// -private let DEBUG_EVAL = false - -// String used to prefix information logged in EVAL. Increasing lengths of the -// string are used the more EVAL is recursed. -// -private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" - -// Holds the prefix of INDENT_TEMPLATE used for actual logging. -// -private var indent = String() - -// Symbols used in this module. -// -private let kValArgv = make_symbol("*ARGV*") -private let kValConcat = make_symbol("concat") -private let kValCons = make_symbol("cons") -private let kValDef = make_symbol("def!") -private let kValDo = make_symbol("do") -private let kValEval = make_symbol("eval") -private let kValFn = make_symbol("fn*") -private let kValIf = make_symbol("if") -private let kValLet = make_symbol("let*") -private let kValQuasiQuote = make_symbol("quasiquote") -private let kValQuasiQuoteExp = make_symbol("quasiquoteexpand") -private let kValQuote = make_symbol("quote") -private let kValSpliceUnquote = make_symbol("splice-unquote") -private let kValUnquote = make_symbol("unquote") -private let kValTry = make_symbol("try*") -private let kValVec = make_symbol("vec") - -private let kSymbolArgv = as_symbol(kValArgv) -private let kSymbolConcat = as_symbol(kValConcat) -private let kSymbolCons = as_symbol(kValCons) -private let kSymbolDef = as_symbol(kValDef) -private let kSymbolDo = as_symbol(kValDo) -private let kSymbolEval = as_symbol(kValEval) -private let kSymbolFn = as_symbol(kValFn) -private let kSymbolIf = as_symbol(kValIf) -private let kSymbolLet = as_symbol(kValLet) -private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) -private let kSymbolQuasiQuoteExp = as_symbol(kValQuasiQuoteExp) -private let kSymbolQuote = as_symbol(kValQuote) -private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) -private let kSymbolUnquote = as_symbol(kValUnquote) -private let kSymbolVec = as_symbol(kValVec) - -func substring(s: String, _ begin: Int, _ end: Int) -> String { - return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] -} - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Return whether or not `ast` is a list and first element is the required symbol. -// -private func starts_with(ast: MalVal, sym: MalSymbol) -> MalVal? { - if let list = as_listQ(ast) where 1 < list.count, - let a0 = as_symbolQ(try! list.nth(0)) where a0 == sym { - return try! list.nth(1) - } else { - return nil - } -} - -// Evaluate `quasiquote`, possibly recursing in the process. -// -private func quasiquote(qq_arg: MalVal) throws -> MalVal { - - // If the argument is an atom or empty list: - // - // Return: (quote ) - - if is_symbol(qq_arg) || is_hashmap(qq_arg) { - return make_list_from(kValQuote, qq_arg) - } - - guard let seq = as_sequenceQ(qq_arg) else { - return qq_arg - } - - // The argument is a non-empty list -- that is (item rest...) - - // If the first item from the list is a symbol and it's "unquote" -- that - // is, (unquote item ignored...): - // - // Return: item - - if let x = starts_with(qq_arg, sym: kSymbolUnquote) { - return x - } - - var result = make_list_from() - for elt in seq.reverse() { - if let x = starts_with(elt, sym: kSymbolSpliceUnquote) { - result = make_list_from(kValConcat, x, result) - } else { - result = make_list_from(kValCons, try quasiquote (elt), result) - } - } - if is_vector(qq_arg) { - return make_list_from(kValVec, result) - } - return result -} - -// Perform a simple evaluation of the `ast` object. If it's a symbol, -// dereference it and return its value. If it's a collection, call EVAL on all -// elements (or just the values, in the case of the hashmap). Otherwise, return -// the object unchanged. -// -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { - if let symbol = as_symbolQ(ast) { - guard let val = env.get(symbol) else { - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests - } - return val - } - if let list = as_listQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for item in list { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_list(result) - } - if let vec = as_vectorQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(vec.count)) - for item in vec { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_vector(result) - } - if let hash = as_hashmapQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(hash.count) * 2) - for (k, v) in hash { - let new_v = try EVAL(v, env) - result.append(k) - result.append(new_v) - } - return make_hashmap(result) - } - return ast -} - -private enum TCOVal { - case NoResult - case Return(MalVal) - case Continue(MalVal, Environment) - - init() { self = .NoResult } - init(_ result: MalVal) { self = .Return(result) } - init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } -} - -// EVALuate "def!". -// -private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to def!, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let sym = as_symbolQ(arg1) else { - try throw_error("expected symbol for first argument to def!") - } - let value = try EVAL(arg2, env) - return TCOVal(env.set(sym, value)) -} - -// EVALuate "let*". -// -private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to let*, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let bindings = as_sequenceQ(arg1) else { - try throw_error("expected list for first argument to let*") - } - guard bindings.count % 2 == 0 else { - try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") - } - let new_env = Environment(outer: env) - for var index: MalIntType = 0; index < bindings.count; index += 2 { - let binding_name = try! bindings.nth(index) - let binding_value = try! bindings.nth(index + 1) - guard let binding_symbol = as_symbolQ(binding_name) else { - try throw_error("expected symbol for first element in binding pair") - } - let evaluated_value = try EVAL(binding_value, new_env) - new_env.set(binding_symbol, evaluated_value) - } - if TCO { - return TCOVal(arg2, new_env) - } - return TCOVal(try EVAL(arg2, new_env)) -} - -// EVALuate "do". -// -private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { - if TCO { - let _ = try eval_ast(list.range_from(1, to: list.count-1), env) - return TCOVal(list.last(), env) - } - - let evaluated_ast = try eval_ast(list.rest(), env) - let evaluated_seq = as_sequence(evaluated_ast) - return TCOVal(evaluated_seq.last()) -} - -// EVALuate "if". -// -private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 3 else { - try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") - } - let cond_result = try EVAL(try! list.nth(1), env) - var new_ast: MalVal - if is_truthy(cond_result) { - new_ast = try! list.nth(2) - } else if list.count == 4 { - new_ast = try! list.nth(3) - } else { - return TCOVal(make_nil()) - } - if TCO { - return TCOVal(new_ast, env) - } - return TCOVal(try EVAL(new_ast, env)) -} - -// EVALuate "fn*". -// -private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") - } - guard let seq = as_sequenceQ(try! list.nth(1)) else { - try throw_error("expected list or vector for first argument to fn*") - } - return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) -} - -// EVALuate "quote". -// -private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { - if list.count >= 2 { - return TCOVal(try! list.nth(1)) - } - return TCOVal(make_nil()) -} - -// EVALuate "quasiquoteexpand". -// -private func eval_quasiquoteexp(list: MalSequence) throws -> TCOVal { - if list.count < 2 { - try throw_error("quasiquoteexpand: arg count") - } - return TCOVal(try! quasiquote(try! list.nth(1))) -} - -// EVALuate "quasiquote". -// -private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 2 else { - try throw_error("Expected non-nil parameter to 'quasiquote'") - } - if TCO { - return TCOVal(try quasiquote(try! list.nth(1)), env) - } - return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { - EVAL_level++ - defer { EVAL_level-- } - guard EVAL_level <= EVAL_leval_max else { - try throw_error("Recursing too many levels (> \(EVAL_leval_max))") - } - - if DEBUG_EVAL { - indent = substring(INDENT_TEMPLATE, 0, EVAL_level) - } - - while true { - if DEBUG_EVAL { print("\(indent)> \(ast)") } - - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // Special handling if it's a list. - - let list = as_list(ast) - if DEBUG_EVAL { print("\(indent)>. \(list)") } - - if list.isEmpty { - return ast - } - - // Check for special forms, where we want to check the operation - // before evaluating all of the parameters. - - let arg0 = list.first() - if let fn_symbol = as_symbolQ(arg0) { - let res: TCOVal - - switch fn_symbol { - case kSymbolDef: res = try eval_def(list, env) - case kSymbolLet: res = try eval_let(list, env) - case kSymbolDo: res = try eval_do(list, env) - case kSymbolIf: res = try eval_if(list, env) - case kSymbolFn: res = try eval_fn(list, env) - case kSymbolQuote: res = try eval_quote(list, env) - case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) - case kSymbolQuasiQuoteExp: res = try eval_quasiquoteexp(list) - default: res = TCOVal() - } - switch res { - case let .Return(result): return result - case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue - case .NoResult: break - } - } - - // Standard list to be applied. Evaluate all the elements first. - - let eval = try eval_ast(ast, env) - - // The result had better be a list and better be non-empty. - - let eval_list = as_list(eval) - if eval_list.isEmpty { - return eval - } - - if DEBUG_EVAL { print("\(indent)>> \(eval)") } - - // Get the first element of the list and execute it. - - let first = eval_list.first() - let rest = as_sequence(eval_list.rest()) - - if let fn = as_builtinQ(first) { - let answer = try fn.apply(rest) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } else if let fn = as_closureQ(first) { - let new_env = Environment(outer: fn.env) - let _ = try new_env.set_bindings(fn.args, with_exprs: rest) - if TCO { - env = new_env - ast = fn.body - continue - } - let answer = try EVAL(fn.body, new_env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // The first element wasn't a function to be executed. Return an - // error saying so. - - try throw_error("first list item does not evaluate to a function: \(first)") - } -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String, _ env: Environment) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - do { - return try EVAL(ast, env) - } catch let error as MalException { - print("Error evaluating input: \(error)") - } catch { - print("Error evaluating input: \(error)") - } - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String, _ env: Environment) -> String? { - let exp = RE(text, env) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL(env: Environment) { - while true { - if let text = _readline("user> ") { - if let output = REP(text, env) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -// Process any command line arguments. Any trailing arguments are incorporated -// into the environment. Any argument immediately after the process name is -// taken as a script to execute. If one exists, it is executed in lieu of -// running the REPL. -// -private func process_command_line(args: [String], _ env: Environment) -> Bool { - var argv = make_list() - if args.count > 2 { - let args1 = args[2.. 1 { - RE("(load-file \"\(args[1])\")", env) - return false - } - - return true -} - -func main() { - let env = Environment(outer: nil) - - load_history_file() - load_builtins(env) - - RE("(def! not (fn* (a) (if a false true)))", env) - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) - - env.set(kSymbolEval, make_builtin({ - try! unwrap_args($0) { - (ast: MalVal) -> MalVal in - try EVAL(ast, env) - } - })) - - if process_command_line(Process.arguments, env) { - REPL(env) - } - - save_history_file() -} +//****************************************************************************** +// MAL - step 7 - quote +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// The number of times EVAL has been entered recursively. We keep track of this +// so that we can protect against overrunning the stack. +// +private var EVAL_level = 0 + +// The maximum number of times we let EVAL recurse before throwing an exception. +// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 +// for safety's sake. +// +private let EVAL_leval_max = 500 + +// Control whether or not tail-call optimization (TCO) is enabled. We want it +// `true` most of the time, but may disable it for debugging purposes (it's +// easier to get a meaningful backtrace that way). +// +private let TCO = true + +// Control whether or not we emit debugging statements in EVAL. +// +private let DEBUG_EVAL = false + +// String used to prefix information logged in EVAL. Increasing lengths of the +// string are used the more EVAL is recursed. +// +private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + +// Holds the prefix of INDENT_TEMPLATE used for actual logging. +// +private var indent = String() + +// Symbols used in this module. +// +private let kValArgv = make_symbol("*ARGV*") +private let kValConcat = make_symbol("concat") +private let kValCons = make_symbol("cons") +private let kValDef = make_symbol("def!") +private let kValDo = make_symbol("do") +private let kValEval = make_symbol("eval") +private let kValFn = make_symbol("fn*") +private let kValIf = make_symbol("if") +private let kValLet = make_symbol("let*") +private let kValQuasiQuote = make_symbol("quasiquote") +private let kValQuasiQuoteExp = make_symbol("quasiquoteexpand") +private let kValQuote = make_symbol("quote") +private let kValSpliceUnquote = make_symbol("splice-unquote") +private let kValUnquote = make_symbol("unquote") +private let kValTry = make_symbol("try*") +private let kValVec = make_symbol("vec") + +private let kSymbolArgv = as_symbol(kValArgv) +private let kSymbolConcat = as_symbol(kValConcat) +private let kSymbolCons = as_symbol(kValCons) +private let kSymbolDef = as_symbol(kValDef) +private let kSymbolDo = as_symbol(kValDo) +private let kSymbolEval = as_symbol(kValEval) +private let kSymbolFn = as_symbol(kValFn) +private let kSymbolIf = as_symbol(kValIf) +private let kSymbolLet = as_symbol(kValLet) +private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) +private let kSymbolQuasiQuoteExp = as_symbol(kValQuasiQuoteExp) +private let kSymbolQuote = as_symbol(kValQuote) +private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) +private let kSymbolUnquote = as_symbol(kValUnquote) +private let kSymbolVec = as_symbol(kValVec) + +func substring(s: String, _ begin: Int, _ end: Int) -> String { + return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] +} + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Return whether or not `ast` is a list and first element is the required symbol. +// +private func starts_with(ast: MalVal, sym: MalSymbol) -> MalVal? { + if let list = as_listQ(ast) where 1 < list.count, + let a0 = as_symbolQ(try! list.nth(0)) where a0 == sym { + return try! list.nth(1) + } else { + return nil + } +} + +// Evaluate `quasiquote`, possibly recursing in the process. +// +private func quasiquote(qq_arg: MalVal) throws -> MalVal { + + // If the argument is an atom or empty list: + // + // Return: (quote ) + + if is_symbol(qq_arg) || is_hashmap(qq_arg) { + return make_list_from(kValQuote, qq_arg) + } + + guard let seq = as_sequenceQ(qq_arg) else { + return qq_arg + } + + // The argument is a non-empty list -- that is (item rest...) + + // If the first item from the list is a symbol and it's "unquote" -- that + // is, (unquote item ignored...): + // + // Return: item + + if let x = starts_with(qq_arg, sym: kSymbolUnquote) { + return x + } + + var result = make_list_from() + for elt in seq.reverse() { + if let x = starts_with(elt, sym: kSymbolSpliceUnquote) { + result = make_list_from(kValConcat, x, result) + } else { + result = make_list_from(kValCons, try quasiquote (elt), result) + } + } + if is_vector(qq_arg) { + return make_list_from(kValVec, result) + } + return result +} + +// Perform a simple evaluation of the `ast` object. If it's a symbol, +// dereference it and return its value. If it's a collection, call EVAL on all +// elements (or just the values, in the case of the hashmap). Otherwise, return +// the object unchanged. +// +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { + if let symbol = as_symbolQ(ast) { + guard let val = env.get(symbol) else { + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests + } + return val + } + if let list = as_listQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for item in list { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_list(result) + } + if let vec = as_vectorQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(vec.count)) + for item in vec { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_vector(result) + } + if let hash = as_hashmapQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(hash.count) * 2) + for (k, v) in hash { + let new_v = try EVAL(v, env) + result.append(k) + result.append(new_v) + } + return make_hashmap(result) + } + return ast +} + +private enum TCOVal { + case NoResult + case Return(MalVal) + case Continue(MalVal, Environment) + + init() { self = .NoResult } + init(_ result: MalVal) { self = .Return(result) } + init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } +} + +// EVALuate "def!". +// +private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to def!, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let sym = as_symbolQ(arg1) else { + try throw_error("expected symbol for first argument to def!") + } + let value = try EVAL(arg2, env) + return TCOVal(env.set(sym, value)) +} + +// EVALuate "let*". +// +private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to let*, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let bindings = as_sequenceQ(arg1) else { + try throw_error("expected list for first argument to let*") + } + guard bindings.count % 2 == 0 else { + try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") + } + let new_env = Environment(outer: env) + for var index: MalIntType = 0; index < bindings.count; index += 2 { + let binding_name = try! bindings.nth(index) + let binding_value = try! bindings.nth(index + 1) + guard let binding_symbol = as_symbolQ(binding_name) else { + try throw_error("expected symbol for first element in binding pair") + } + let evaluated_value = try EVAL(binding_value, new_env) + new_env.set(binding_symbol, evaluated_value) + } + if TCO { + return TCOVal(arg2, new_env) + } + return TCOVal(try EVAL(arg2, new_env)) +} + +// EVALuate "do". +// +private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { + if TCO { + let _ = try eval_ast(list.range_from(1, to: list.count-1), env) + return TCOVal(list.last(), env) + } + + let evaluated_ast = try eval_ast(list.rest(), env) + let evaluated_seq = as_sequence(evaluated_ast) + return TCOVal(evaluated_seq.last()) +} + +// EVALuate "if". +// +private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 3 else { + try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") + } + let cond_result = try EVAL(try! list.nth(1), env) + var new_ast: MalVal + if is_truthy(cond_result) { + new_ast = try! list.nth(2) + } else if list.count == 4 { + new_ast = try! list.nth(3) + } else { + return TCOVal(make_nil()) + } + if TCO { + return TCOVal(new_ast, env) + } + return TCOVal(try EVAL(new_ast, env)) +} + +// EVALuate "fn*". +// +private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") + } + guard let seq = as_sequenceQ(try! list.nth(1)) else { + try throw_error("expected list or vector for first argument to fn*") + } + return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) +} + +// EVALuate "quote". +// +private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { + if list.count >= 2 { + return TCOVal(try! list.nth(1)) + } + return TCOVal(make_nil()) +} + +// EVALuate "quasiquoteexpand". +// +private func eval_quasiquoteexp(list: MalSequence) throws -> TCOVal { + if list.count < 2 { + try throw_error("quasiquoteexpand: arg count") + } + return TCOVal(try! quasiquote(try! list.nth(1))) +} + +// EVALuate "quasiquote". +// +private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 2 else { + try throw_error("Expected non-nil parameter to 'quasiquote'") + } + if TCO { + return TCOVal(try quasiquote(try! list.nth(1)), env) + } + return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { + EVAL_level++ + defer { EVAL_level-- } + guard EVAL_level <= EVAL_leval_max else { + try throw_error("Recursing too many levels (> \(EVAL_leval_max))") + } + + if DEBUG_EVAL { + indent = substring(INDENT_TEMPLATE, 0, EVAL_level) + } + + while true { + if DEBUG_EVAL { print("\(indent)> \(ast)") } + + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // Special handling if it's a list. + + let list = as_list(ast) + if DEBUG_EVAL { print("\(indent)>. \(list)") } + + if list.isEmpty { + return ast + } + + // Check for special forms, where we want to check the operation + // before evaluating all of the parameters. + + let arg0 = list.first() + if let fn_symbol = as_symbolQ(arg0) { + let res: TCOVal + + switch fn_symbol { + case kSymbolDef: res = try eval_def(list, env) + case kSymbolLet: res = try eval_let(list, env) + case kSymbolDo: res = try eval_do(list, env) + case kSymbolIf: res = try eval_if(list, env) + case kSymbolFn: res = try eval_fn(list, env) + case kSymbolQuote: res = try eval_quote(list, env) + case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) + case kSymbolQuasiQuoteExp: res = try eval_quasiquoteexp(list) + default: res = TCOVal() + } + switch res { + case let .Return(result): return result + case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue + case .NoResult: break + } + } + + // Standard list to be applied. Evaluate all the elements first. + + let eval = try eval_ast(ast, env) + + // The result had better be a list and better be non-empty. + + let eval_list = as_list(eval) + if eval_list.isEmpty { + return eval + } + + if DEBUG_EVAL { print("\(indent)>> \(eval)") } + + // Get the first element of the list and execute it. + + let first = eval_list.first() + let rest = as_sequence(eval_list.rest()) + + if let fn = as_builtinQ(first) { + let answer = try fn.apply(rest) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } else if let fn = as_closureQ(first) { + let new_env = Environment(outer: fn.env) + let _ = try new_env.set_bindings(fn.args, with_exprs: rest) + if TCO { + env = new_env + ast = fn.body + continue + } + let answer = try EVAL(fn.body, new_env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // The first element wasn't a function to be executed. Return an + // error saying so. + + try throw_error("first list item does not evaluate to a function: \(first)") + } +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String, _ env: Environment) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + do { + return try EVAL(ast, env) + } catch let error as MalException { + print("Error evaluating input: \(error)") + } catch { + print("Error evaluating input: \(error)") + } + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String, _ env: Environment) -> String? { + let exp = RE(text, env) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL(env: Environment) { + while true { + if let text = _readline("user> ") { + if let output = REP(text, env) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +// Process any command line arguments. Any trailing arguments are incorporated +// into the environment. Any argument immediately after the process name is +// taken as a script to execute. If one exists, it is executed in lieu of +// running the REPL. +// +private func process_command_line(args: [String], _ env: Environment) -> Bool { + var argv = make_list() + if args.count > 2 { + let args1 = args[2.. 1 { + RE("(load-file \"\(args[1])\")", env) + return false + } + + return true +} + +func main() { + let env = Environment(outer: nil) + + load_history_file() + load_builtins(env) + + RE("(def! not (fn* (a) (if a false true)))", env) + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) + + env.set(kSymbolEval, make_builtin({ + try! unwrap_args($0) { + (ast: MalVal) -> MalVal in + try EVAL(ast, env) + } + })) + + if process_command_line(Process.arguments, env) { + REPL(env) + } + + save_history_file() +} diff --git a/impls/swift/step8_macros.swift b/impls/swift/step8_macros.swift index 81712ca61c..35d96d752d 100644 --- a/impls/swift/step8_macros.swift +++ b/impls/swift/step8_macros.swift @@ -1,575 +1,575 @@ -//****************************************************************************** -// MAL - step 8 - macros -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// The number of times EVAL has been entered recursively. We keep track of this -// so that we can protect against overrunning the stack. -// -private var EVAL_level = 0 - -// The maximum number of times we let EVAL recurse before throwing an exception. -// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 -// for safety's sake. -// -private let EVAL_leval_max = 500 - -// Control whether or not tail-call optimization (TCO) is enabled. We want it -// `true` most of the time, but may disable it for debugging purposes (it's -// easier to get a meaningful backtrace that way). -// -private let TCO = true - -// Control whether or not we emit debugging statements in EVAL. -// -private let DEBUG_EVAL = false - -// String used to prefix information logged in EVAL. Increasing lengths of the -// string are used the more EVAL is recursed. -// -private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" - -// Holds the prefix of INDENT_TEMPLATE used for actual logging. -// -private var indent = String() - -// Symbols used in this module. -// -private let kValArgv = make_symbol("*ARGV*") -private let kValConcat = make_symbol("concat") -private let kValCons = make_symbol("cons") -private let kValDef = make_symbol("def!") -private let kValDefMacro = make_symbol("defmacro!") -private let kValDo = make_symbol("do") -private let kValEval = make_symbol("eval") -private let kValFn = make_symbol("fn*") -private let kValIf = make_symbol("if") -private let kValLet = make_symbol("let*") -private let kValMacroExpand = make_symbol("macroexpand") -private let kValQuasiQuote = make_symbol("quasiquote") -private let kValQuasiQuoteExp = make_symbol("quasiquoteexpand") -private let kValQuote = make_symbol("quote") -private let kValSpliceUnquote = make_symbol("splice-unquote") -private let kValUnquote = make_symbol("unquote") -private let kValTry = make_symbol("try*") -private let kValVec = make_symbol("vec") - -private let kSymbolArgv = as_symbol(kValArgv) -private let kSymbolConcat = as_symbol(kValConcat) -private let kSymbolCons = as_symbol(kValCons) -private let kSymbolDef = as_symbol(kValDef) -private let kSymbolDefMacro = as_symbol(kValDefMacro) -private let kSymbolDo = as_symbol(kValDo) -private let kSymbolEval = as_symbol(kValEval) -private let kSymbolFn = as_symbol(kValFn) -private let kSymbolIf = as_symbol(kValIf) -private let kSymbolLet = as_symbol(kValLet) -private let kSymbolMacroExpand = as_symbol(kValMacroExpand) -private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) -private let kSymbolQuasiQuoteExp = as_symbol(kValQuasiQuoteExp) -private let kSymbolQuote = as_symbol(kValQuote) -private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) -private let kSymbolUnquote = as_symbol(kValUnquote) -private let kSymbolVec = as_symbol(kValVec) - -func substring(s: String, _ begin: Int, _ end: Int) -> String { - return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] -} - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Expand macros for as long as the expression looks like a macro invocation. -// -private func macroexpand(var ast: MalVal, _ env: Environment) throws -> MalVal { - while true { - if let ast_as_list = as_listQ(ast) where !ast_as_list.isEmpty, - let macro_name = as_symbolQ(ast_as_list.first()), - let obj = env.get(macro_name), - let macro = as_macroQ(obj) - { - let new_env = Environment(outer: macro.env) - let rest = as_sequence(ast_as_list.rest()) - let _ = try new_env.set_bindings(macro.args, with_exprs: rest) - ast = try EVAL(macro.body, new_env) - continue - } - return ast - } -} - -// Return whether or not `ast` is a list and first element is the required symbol. -// -private func starts_with(ast: MalVal, sym: MalSymbol) -> MalVal? { - if let list = as_listQ(ast) where 1 < list.count, - let a0 = as_symbolQ(try! list.nth(0)) where a0 == sym { - return try! list.nth(1) - } else { - return nil - } -} - -// Evaluate `quasiquote`, possibly recursing in the process. -// -private func quasiquote(qq_arg: MalVal) throws -> MalVal { - - // If the argument is an atom or empty list: - // - // Return: (quote ) - - if is_symbol(qq_arg) || is_hashmap(qq_arg) { - return make_list_from(kValQuote, qq_arg) - } - - guard let seq = as_sequenceQ(qq_arg) else { - return qq_arg - } - - // The argument is a non-empty list -- that is (item rest...) - - // If the first item from the list is a symbol and it's "unquote" -- that - // is, (unquote item ignored...): - // - // Return: item - - if let x = starts_with(qq_arg, sym: kSymbolUnquote) { - return x - } - - var result = make_list_from() - for elt in seq.reverse() { - if let x = starts_with(elt, sym: kSymbolSpliceUnquote) { - result = make_list_from(kValConcat, x, result) - } else { - result = make_list_from(kValCons, try quasiquote (elt), result) - } - } - if is_vector(qq_arg) { - return make_list_from(kValVec, result) - } - return result -} - -// Perform a simple evaluation of the `ast` object. If it's a symbol, -// dereference it and return its value. If it's a collection, call EVAL on all -// elements (or just the values, in the case of the hashmap). Otherwise, return -// the object unchanged. -// -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { - if let symbol = as_symbolQ(ast) { - guard let val = env.get(symbol) else { - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests - } - return val - } - if let list = as_listQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for item in list { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_list(result) - } - if let vec = as_vectorQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(vec.count)) - for item in vec { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_vector(result) - } - if let hash = as_hashmapQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(hash.count) * 2) - for (k, v) in hash { - let new_v = try EVAL(v, env) - result.append(k) - result.append(new_v) - } - return make_hashmap(result) - } - return ast -} - -private enum TCOVal { - case NoResult - case Return(MalVal) - case Continue(MalVal, Environment) - - init() { self = .NoResult } - init(_ result: MalVal) { self = .Return(result) } - init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } -} - -// EVALuate "def!" and "defmacro!". -// -private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to def!, got \(list.count - 1)") - } - let arg0 = try! list.nth(0) - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let sym = as_symbolQ(arg1) else { - try throw_error("expected symbol for first argument to def!") - } - var value = try EVAL(arg2, env) - if as_symbol(arg0) == kSymbolDefMacro { - guard let closure = as_closureQ(value) else { - try throw_error("expected closure, got \(value)") - } - value = make_macro(closure) - } - return TCOVal(env.set(sym, value)) -} - -// EVALuate "let*". -// -private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to let*, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let bindings = as_sequenceQ(arg1) else { - try throw_error("expected list for first argument to let*") - } - guard bindings.count % 2 == 0 else { - try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") - } - let new_env = Environment(outer: env) - for var index: MalIntType = 0; index < bindings.count; index += 2 { - let binding_name = try! bindings.nth(index) - let binding_value = try! bindings.nth(index + 1) - guard let binding_symbol = as_symbolQ(binding_name) else { - try throw_error("expected symbol for first element in binding pair") - } - let evaluated_value = try EVAL(binding_value, new_env) - new_env.set(binding_symbol, evaluated_value) - } - if TCO { - return TCOVal(arg2, new_env) - } - return TCOVal(try EVAL(arg2, new_env)) -} - -// EVALuate "do". -// -private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { - if TCO { - let _ = try eval_ast(list.range_from(1, to: list.count-1), env) - return TCOVal(list.last(), env) - } - - let evaluated_ast = try eval_ast(list.rest(), env) - let evaluated_seq = as_sequence(evaluated_ast) - return TCOVal(evaluated_seq.last()) -} - -// EVALuate "if". -// -private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 3 else { - try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") - } - let cond_result = try EVAL(try! list.nth(1), env) - var new_ast: MalVal - if is_truthy(cond_result) { - new_ast = try! list.nth(2) - } else if list.count == 4 { - new_ast = try! list.nth(3) - } else { - return TCOVal(make_nil()) - } - if TCO { - return TCOVal(new_ast, env) - } - return TCOVal(try EVAL(new_ast, env)) -} - -// EVALuate "fn*". -// -private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") - } - guard let seq = as_sequenceQ(try! list.nth(1)) else { - try throw_error("expected list or vector for first argument to fn*") - } - return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) -} - -// EVALuate "quote". -// -private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { - if list.count >= 2 { - return TCOVal(try! list.nth(1)) - } - return TCOVal(make_nil()) -} - -// EVALuate "quasiquoteexpand". -// -private func eval_quasiquoteexp(list: MalSequence) throws -> TCOVal { - if list.count < 2 { - try throw_error("quasiquoteexpand: arg count") - } - return TCOVal(try! quasiquote(try! list.nth(1))) -} - -// EVALuate "quasiquote". -// -private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 2 else { - try throw_error("Expected non-nil parameter to 'quasiquote'") - } - if TCO { - return TCOVal(try quasiquote(try! list.nth(1)), env) - } - return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) -} - -// EVALuate "macroexpand". -// -private func eval_macroexpand(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 2 else { - try throw_error("Expected parameter to 'macroexpand'") - } - return TCOVal(try macroexpand(try! list.nth(1), env)) -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { - EVAL_level++ - defer { EVAL_level-- } - guard EVAL_level <= EVAL_leval_max else { - try throw_error("Recursing too many levels (> \(EVAL_leval_max))") - } - - if DEBUG_EVAL { - indent = substring(INDENT_TEMPLATE, 0, EVAL_level) - } - - while true { - if DEBUG_EVAL { print("\(indent)> \(ast)") } - - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // Special handling if it's a list. - - var list = as_list(ast) - ast = try macroexpand(ast, env) - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - list = as_list(ast) - - if DEBUG_EVAL { print("\(indent)>. \(list)") } - - if list.isEmpty { - return ast - } - - // Check for special forms, where we want to check the operation - // before evaluating all of the parameters. - - let arg0 = list.first() - if let fn_symbol = as_symbolQ(arg0) { - let res: TCOVal - - switch fn_symbol { - case kSymbolDef: res = try eval_def(list, env) - case kSymbolDefMacro: res = try eval_def(list, env) - case kSymbolLet: res = try eval_let(list, env) - case kSymbolDo: res = try eval_do(list, env) - case kSymbolIf: res = try eval_if(list, env) - case kSymbolFn: res = try eval_fn(list, env) - case kSymbolQuote: res = try eval_quote(list, env) - case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) - case kSymbolQuasiQuoteExp: res = try eval_quasiquoteexp(list) - case kSymbolMacroExpand: res = try eval_macroexpand(list, env) - default: res = TCOVal() - } - switch res { - case let .Return(result): return result - case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue - case .NoResult: break - } - } - - // Standard list to be applied. Evaluate all the elements first. - - let eval = try eval_ast(ast, env) - - // The result had better be a list and better be non-empty. - - let eval_list = as_list(eval) - if eval_list.isEmpty { - return eval - } - - if DEBUG_EVAL { print("\(indent)>> \(eval)") } - - // Get the first element of the list and execute it. - - let first = eval_list.first() - let rest = as_sequence(eval_list.rest()) - - if let fn = as_builtinQ(first) { - let answer = try fn.apply(rest) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } else if let fn = as_closureQ(first) { - let new_env = Environment(outer: fn.env) - let _ = try new_env.set_bindings(fn.args, with_exprs: rest) - if TCO { - env = new_env - ast = fn.body - continue - } - let answer = try EVAL(fn.body, new_env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // The first element wasn't a function to be executed. Return an - // error saying so. - - try throw_error("first list item does not evaluate to a function: \(first)") - } -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String, _ env: Environment) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - do { - return try EVAL(ast, env) - } catch let error as MalException { - print("Error evaluating input: \(error)") - } catch { - print("Error evaluating input: \(error)") - } - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String, _ env: Environment) -> String? { - let exp = RE(text, env) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL(env: Environment) { - while true { - if let text = _readline("user> ") { - if let output = REP(text, env) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -// Process any command line arguments. Any trailing arguments are incorporated -// into the environment. Any argument immediately after the process name is -// taken as a script to execute. If one exists, it is executed in lieu of -// running the REPL. -// -private func process_command_line(args: [String], _ env: Environment) -> Bool { - var argv = make_list() - if args.count > 2 { - let args1 = args[2.. 1 { - RE("(load-file \"\(args[1])\")", env) - return false - } - - return true -} - -func main() { - let env = Environment(outer: nil) - - load_history_file() - load_builtins(env) - - RE("(def! not (fn* (a) (if a false true)))", env) - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) - RE("(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)))))))", env) - - env.set(kSymbolEval, make_builtin({ - try! unwrap_args($0) { - (ast: MalVal) -> MalVal in - try EVAL(ast, env) - } - })) - - if process_command_line(Process.arguments, env) { - REPL(env) - } - - save_history_file() -} +//****************************************************************************** +// MAL - step 8 - macros +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// The number of times EVAL has been entered recursively. We keep track of this +// so that we can protect against overrunning the stack. +// +private var EVAL_level = 0 + +// The maximum number of times we let EVAL recurse before throwing an exception. +// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 +// for safety's sake. +// +private let EVAL_leval_max = 500 + +// Control whether or not tail-call optimization (TCO) is enabled. We want it +// `true` most of the time, but may disable it for debugging purposes (it's +// easier to get a meaningful backtrace that way). +// +private let TCO = true + +// Control whether or not we emit debugging statements in EVAL. +// +private let DEBUG_EVAL = false + +// String used to prefix information logged in EVAL. Increasing lengths of the +// string are used the more EVAL is recursed. +// +private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + +// Holds the prefix of INDENT_TEMPLATE used for actual logging. +// +private var indent = String() + +// Symbols used in this module. +// +private let kValArgv = make_symbol("*ARGV*") +private let kValConcat = make_symbol("concat") +private let kValCons = make_symbol("cons") +private let kValDef = make_symbol("def!") +private let kValDefMacro = make_symbol("defmacro!") +private let kValDo = make_symbol("do") +private let kValEval = make_symbol("eval") +private let kValFn = make_symbol("fn*") +private let kValIf = make_symbol("if") +private let kValLet = make_symbol("let*") +private let kValMacroExpand = make_symbol("macroexpand") +private let kValQuasiQuote = make_symbol("quasiquote") +private let kValQuasiQuoteExp = make_symbol("quasiquoteexpand") +private let kValQuote = make_symbol("quote") +private let kValSpliceUnquote = make_symbol("splice-unquote") +private let kValUnquote = make_symbol("unquote") +private let kValTry = make_symbol("try*") +private let kValVec = make_symbol("vec") + +private let kSymbolArgv = as_symbol(kValArgv) +private let kSymbolConcat = as_symbol(kValConcat) +private let kSymbolCons = as_symbol(kValCons) +private let kSymbolDef = as_symbol(kValDef) +private let kSymbolDefMacro = as_symbol(kValDefMacro) +private let kSymbolDo = as_symbol(kValDo) +private let kSymbolEval = as_symbol(kValEval) +private let kSymbolFn = as_symbol(kValFn) +private let kSymbolIf = as_symbol(kValIf) +private let kSymbolLet = as_symbol(kValLet) +private let kSymbolMacroExpand = as_symbol(kValMacroExpand) +private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) +private let kSymbolQuasiQuoteExp = as_symbol(kValQuasiQuoteExp) +private let kSymbolQuote = as_symbol(kValQuote) +private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) +private let kSymbolUnquote = as_symbol(kValUnquote) +private let kSymbolVec = as_symbol(kValVec) + +func substring(s: String, _ begin: Int, _ end: Int) -> String { + return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] +} + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Expand macros for as long as the expression looks like a macro invocation. +// +private func macroexpand(var ast: MalVal, _ env: Environment) throws -> MalVal { + while true { + if let ast_as_list = as_listQ(ast) where !ast_as_list.isEmpty, + let macro_name = as_symbolQ(ast_as_list.first()), + let obj = env.get(macro_name), + let macro = as_macroQ(obj) + { + let new_env = Environment(outer: macro.env) + let rest = as_sequence(ast_as_list.rest()) + let _ = try new_env.set_bindings(macro.args, with_exprs: rest) + ast = try EVAL(macro.body, new_env) + continue + } + return ast + } +} + +// Return whether or not `ast` is a list and first element is the required symbol. +// +private func starts_with(ast: MalVal, sym: MalSymbol) -> MalVal? { + if let list = as_listQ(ast) where 1 < list.count, + let a0 = as_symbolQ(try! list.nth(0)) where a0 == sym { + return try! list.nth(1) + } else { + return nil + } +} + +// Evaluate `quasiquote`, possibly recursing in the process. +// +private func quasiquote(qq_arg: MalVal) throws -> MalVal { + + // If the argument is an atom or empty list: + // + // Return: (quote ) + + if is_symbol(qq_arg) || is_hashmap(qq_arg) { + return make_list_from(kValQuote, qq_arg) + } + + guard let seq = as_sequenceQ(qq_arg) else { + return qq_arg + } + + // The argument is a non-empty list -- that is (item rest...) + + // If the first item from the list is a symbol and it's "unquote" -- that + // is, (unquote item ignored...): + // + // Return: item + + if let x = starts_with(qq_arg, sym: kSymbolUnquote) { + return x + } + + var result = make_list_from() + for elt in seq.reverse() { + if let x = starts_with(elt, sym: kSymbolSpliceUnquote) { + result = make_list_from(kValConcat, x, result) + } else { + result = make_list_from(kValCons, try quasiquote (elt), result) + } + } + if is_vector(qq_arg) { + return make_list_from(kValVec, result) + } + return result +} + +// Perform a simple evaluation of the `ast` object. If it's a symbol, +// dereference it and return its value. If it's a collection, call EVAL on all +// elements (or just the values, in the case of the hashmap). Otherwise, return +// the object unchanged. +// +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { + if let symbol = as_symbolQ(ast) { + guard let val = env.get(symbol) else { + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests + } + return val + } + if let list = as_listQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for item in list { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_list(result) + } + if let vec = as_vectorQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(vec.count)) + for item in vec { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_vector(result) + } + if let hash = as_hashmapQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(hash.count) * 2) + for (k, v) in hash { + let new_v = try EVAL(v, env) + result.append(k) + result.append(new_v) + } + return make_hashmap(result) + } + return ast +} + +private enum TCOVal { + case NoResult + case Return(MalVal) + case Continue(MalVal, Environment) + + init() { self = .NoResult } + init(_ result: MalVal) { self = .Return(result) } + init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } +} + +// EVALuate "def!" and "defmacro!". +// +private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to def!, got \(list.count - 1)") + } + let arg0 = try! list.nth(0) + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let sym = as_symbolQ(arg1) else { + try throw_error("expected symbol for first argument to def!") + } + var value = try EVAL(arg2, env) + if as_symbol(arg0) == kSymbolDefMacro { + guard let closure = as_closureQ(value) else { + try throw_error("expected closure, got \(value)") + } + value = make_macro(closure) + } + return TCOVal(env.set(sym, value)) +} + +// EVALuate "let*". +// +private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to let*, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let bindings = as_sequenceQ(arg1) else { + try throw_error("expected list for first argument to let*") + } + guard bindings.count % 2 == 0 else { + try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") + } + let new_env = Environment(outer: env) + for var index: MalIntType = 0; index < bindings.count; index += 2 { + let binding_name = try! bindings.nth(index) + let binding_value = try! bindings.nth(index + 1) + guard let binding_symbol = as_symbolQ(binding_name) else { + try throw_error("expected symbol for first element in binding pair") + } + let evaluated_value = try EVAL(binding_value, new_env) + new_env.set(binding_symbol, evaluated_value) + } + if TCO { + return TCOVal(arg2, new_env) + } + return TCOVal(try EVAL(arg2, new_env)) +} + +// EVALuate "do". +// +private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { + if TCO { + let _ = try eval_ast(list.range_from(1, to: list.count-1), env) + return TCOVal(list.last(), env) + } + + let evaluated_ast = try eval_ast(list.rest(), env) + let evaluated_seq = as_sequence(evaluated_ast) + return TCOVal(evaluated_seq.last()) +} + +// EVALuate "if". +// +private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 3 else { + try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") + } + let cond_result = try EVAL(try! list.nth(1), env) + var new_ast: MalVal + if is_truthy(cond_result) { + new_ast = try! list.nth(2) + } else if list.count == 4 { + new_ast = try! list.nth(3) + } else { + return TCOVal(make_nil()) + } + if TCO { + return TCOVal(new_ast, env) + } + return TCOVal(try EVAL(new_ast, env)) +} + +// EVALuate "fn*". +// +private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") + } + guard let seq = as_sequenceQ(try! list.nth(1)) else { + try throw_error("expected list or vector for first argument to fn*") + } + return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) +} + +// EVALuate "quote". +// +private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { + if list.count >= 2 { + return TCOVal(try! list.nth(1)) + } + return TCOVal(make_nil()) +} + +// EVALuate "quasiquoteexpand". +// +private func eval_quasiquoteexp(list: MalSequence) throws -> TCOVal { + if list.count < 2 { + try throw_error("quasiquoteexpand: arg count") + } + return TCOVal(try! quasiquote(try! list.nth(1))) +} + +// EVALuate "quasiquote". +// +private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 2 else { + try throw_error("Expected non-nil parameter to 'quasiquote'") + } + if TCO { + return TCOVal(try quasiquote(try! list.nth(1)), env) + } + return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) +} + +// EVALuate "macroexpand". +// +private func eval_macroexpand(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 2 else { + try throw_error("Expected parameter to 'macroexpand'") + } + return TCOVal(try macroexpand(try! list.nth(1), env)) +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { + EVAL_level++ + defer { EVAL_level-- } + guard EVAL_level <= EVAL_leval_max else { + try throw_error("Recursing too many levels (> \(EVAL_leval_max))") + } + + if DEBUG_EVAL { + indent = substring(INDENT_TEMPLATE, 0, EVAL_level) + } + + while true { + if DEBUG_EVAL { print("\(indent)> \(ast)") } + + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // Special handling if it's a list. + + var list = as_list(ast) + ast = try macroexpand(ast, env) + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + list = as_list(ast) + + if DEBUG_EVAL { print("\(indent)>. \(list)") } + + if list.isEmpty { + return ast + } + + // Check for special forms, where we want to check the operation + // before evaluating all of the parameters. + + let arg0 = list.first() + if let fn_symbol = as_symbolQ(arg0) { + let res: TCOVal + + switch fn_symbol { + case kSymbolDef: res = try eval_def(list, env) + case kSymbolDefMacro: res = try eval_def(list, env) + case kSymbolLet: res = try eval_let(list, env) + case kSymbolDo: res = try eval_do(list, env) + case kSymbolIf: res = try eval_if(list, env) + case kSymbolFn: res = try eval_fn(list, env) + case kSymbolQuote: res = try eval_quote(list, env) + case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) + case kSymbolQuasiQuoteExp: res = try eval_quasiquoteexp(list) + case kSymbolMacroExpand: res = try eval_macroexpand(list, env) + default: res = TCOVal() + } + switch res { + case let .Return(result): return result + case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue + case .NoResult: break + } + } + + // Standard list to be applied. Evaluate all the elements first. + + let eval = try eval_ast(ast, env) + + // The result had better be a list and better be non-empty. + + let eval_list = as_list(eval) + if eval_list.isEmpty { + return eval + } + + if DEBUG_EVAL { print("\(indent)>> \(eval)") } + + // Get the first element of the list and execute it. + + let first = eval_list.first() + let rest = as_sequence(eval_list.rest()) + + if let fn = as_builtinQ(first) { + let answer = try fn.apply(rest) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } else if let fn = as_closureQ(first) { + let new_env = Environment(outer: fn.env) + let _ = try new_env.set_bindings(fn.args, with_exprs: rest) + if TCO { + env = new_env + ast = fn.body + continue + } + let answer = try EVAL(fn.body, new_env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // The first element wasn't a function to be executed. Return an + // error saying so. + + try throw_error("first list item does not evaluate to a function: \(first)") + } +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String, _ env: Environment) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + do { + return try EVAL(ast, env) + } catch let error as MalException { + print("Error evaluating input: \(error)") + } catch { + print("Error evaluating input: \(error)") + } + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String, _ env: Environment) -> String? { + let exp = RE(text, env) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL(env: Environment) { + while true { + if let text = _readline("user> ") { + if let output = REP(text, env) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +// Process any command line arguments. Any trailing arguments are incorporated +// into the environment. Any argument immediately after the process name is +// taken as a script to execute. If one exists, it is executed in lieu of +// running the REPL. +// +private func process_command_line(args: [String], _ env: Environment) -> Bool { + var argv = make_list() + if args.count > 2 { + let args1 = args[2.. 1 { + RE("(load-file \"\(args[1])\")", env) + return false + } + + return true +} + +func main() { + let env = Environment(outer: nil) + + load_history_file() + load_builtins(env) + + RE("(def! not (fn* (a) (if a false true)))", env) + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) + RE("(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)))))))", env) + + env.set(kSymbolEval, make_builtin({ + try! unwrap_args($0) { + (ast: MalVal) -> MalVal in + try EVAL(ast, env) + } + })) + + if process_command_line(Process.arguments, env) { + REPL(env) + } + + save_history_file() +} diff --git a/impls/swift/step9_try.swift b/impls/swift/step9_try.swift index 793539237c..e10c8ff41d 100644 --- a/impls/swift/step9_try.swift +++ b/impls/swift/step9_try.swift @@ -1,608 +1,608 @@ -//****************************************************************************** -// MAL - step 9 - try -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// The number of times EVAL has been entered recursively. We keep track of this -// so that we can protect against overrunning the stack. -// -private var EVAL_level = 0 - -// The maximum number of times we let EVAL recurse before throwing an exception. -// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 -// for safety's sake. -// -private let EVAL_leval_max = 500 - -// Control whether or not tail-call optimization (TCO) is enabled. We want it -// `true` most of the time, but may disable it for debugging purposes (it's -// easier to get a meaningful backtrace that way). -// -private let TCO = true - -// Control whether or not we emit debugging statements in EVAL. -// -private let DEBUG_EVAL = false - -// String used to prefix information logged in EVAL. Increasing lengths of the -// string are used the more EVAL is recursed. -// -private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" - -// Holds the prefix of INDENT_TEMPLATE used for actual logging. -// -private var indent = String() - -// Symbols used in this module. -// -private let kValArgv = make_symbol("*ARGV*") -private let kValCatch = make_symbol("catch*") -private let kValConcat = make_symbol("concat") -private let kValCons = make_symbol("cons") -private let kValDef = make_symbol("def!") -private let kValDefMacro = make_symbol("defmacro!") -private let kValDo = make_symbol("do") -private let kValEval = make_symbol("eval") -private let kValFn = make_symbol("fn*") -private let kValIf = make_symbol("if") -private let kValLet = make_symbol("let*") -private let kValMacroExpand = make_symbol("macroexpand") -private let kValQuasiQuote = make_symbol("quasiquote") -private let kValQuasiQuoteExp = make_symbol("quasiquoteexpand") -private let kValQuote = make_symbol("quote") -private let kValSpliceUnquote = make_symbol("splice-unquote") -private let kValUnquote = make_symbol("unquote") -private let kValTry = make_symbol("try*") -private let kValVec = make_symbol("vec") - -private let kSymbolArgv = as_symbol(kValArgv) -private let kSymbolCatch = as_symbol(kValCatch) -private let kSymbolConcat = as_symbol(kValConcat) -private let kSymbolCons = as_symbol(kValCons) -private let kSymbolDef = as_symbol(kValDef) -private let kSymbolDefMacro = as_symbol(kValDefMacro) -private let kSymbolDo = as_symbol(kValDo) -private let kSymbolEval = as_symbol(kValEval) -private let kSymbolFn = as_symbol(kValFn) -private let kSymbolIf = as_symbol(kValIf) -private let kSymbolLet = as_symbol(kValLet) -private let kSymbolMacroExpand = as_symbol(kValMacroExpand) -private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) -private let kSymbolQuasiQuoteExp = as_symbol(kValQuasiQuoteExp) -private let kSymbolQuote = as_symbol(kValQuote) -private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) -private let kSymbolUnquote = as_symbol(kValUnquote) -private let kSymbolTry = as_symbol(kValTry) -private let kSymbolVec = as_symbol(kValVec) - -func substring(s: String, _ begin: Int, _ end: Int) -> String { - return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] -} - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Expand macros for as long as the expression looks like a macro invocation. -// -private func macroexpand(var ast: MalVal, _ env: Environment) throws -> MalVal { - while true { - if let ast_as_list = as_listQ(ast) where !ast_as_list.isEmpty, - let macro_name = as_symbolQ(ast_as_list.first()), - let obj = env.get(macro_name), - let macro = as_macroQ(obj) - { - let new_env = Environment(outer: macro.env) - let rest = as_sequence(ast_as_list.rest()) - let _ = try new_env.set_bindings(macro.args, with_exprs: rest) - ast = try EVAL(macro.body, new_env) - continue - } - return ast - } -} - -// Return whether or not `ast` is a list and first element is the required symbol. -// -private func starts_with(ast: MalVal, sym: MalSymbol) -> MalVal? { - if let list = as_listQ(ast) where 1 < list.count, - let a0 = as_symbolQ(try! list.nth(0)) where a0 == sym { - return try! list.nth(1) - } else { - return nil - } -} - -// Evaluate `quasiquote`, possibly recursing in the process. -// -private func quasiquote(qq_arg: MalVal) throws -> MalVal { - - // If the argument is an atom or empty list: - // - // Return: (quote ) - - if is_symbol(qq_arg) || is_hashmap(qq_arg) { - return make_list_from(kValQuote, qq_arg) - } - - guard let seq = as_sequenceQ(qq_arg) else { - return qq_arg - } - - // The argument is a non-empty list -- that is (item rest...) - - // If the first item from the list is a symbol and it's "unquote" -- that - // is, (unquote item ignored...): - // - // Return: item - - if let x = starts_with(qq_arg, sym: kSymbolUnquote) { - return x - } - - var result = make_list_from() - for elt in seq.reverse() { - if let x = starts_with(elt, sym: kSymbolSpliceUnquote) { - result = make_list_from(kValConcat, x, result) - } else { - result = make_list_from(kValCons, try quasiquote (elt), result) - } - } - if is_vector(qq_arg) { - return make_list_from(kValVec, result) - } - return result -} - -// Perform a simple evaluation of the `ast` object. If it's a symbol, -// dereference it and return its value. If it's a collection, call EVAL on all -// elements (or just the values, in the case of the hashmap). Otherwise, return -// the object unchanged. -// -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { - if let symbol = as_symbolQ(ast) { - guard let val = env.get(symbol) else { - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests - } - return val - } - if let list = as_listQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for item in list { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_list(result) - } - if let vec = as_vectorQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(vec.count)) - for item in vec { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_vector(result) - } - if let hash = as_hashmapQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(hash.count) * 2) - for (k, v) in hash { - let new_v = try EVAL(v, env) - result.append(k) - result.append(new_v) - } - return make_hashmap(result) - } - return ast -} - -private enum TCOVal { - case NoResult - case Return(MalVal) - case Continue(MalVal, Environment) - - init() { self = .NoResult } - init(_ result: MalVal) { self = .Return(result) } - init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } -} - -// EVALuate "def!" and "defmacro!". -// -private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to def!, got \(list.count - 1)") - } - let arg0 = try! list.nth(0) - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let sym = as_symbolQ(arg1) else { - try throw_error("expected symbol for first argument to def!") - } - var value = try EVAL(arg2, env) - if as_symbol(arg0) == kSymbolDefMacro { - guard let closure = as_closureQ(value) else { - try throw_error("expected closure, got \(value)") - } - value = make_macro(closure) - } - return TCOVal(env.set(sym, value)) -} - -// EVALuate "let*". -// -private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to let*, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let bindings = as_sequenceQ(arg1) else { - try throw_error("expected list for first argument to let*") - } - guard bindings.count % 2 == 0 else { - try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") - } - let new_env = Environment(outer: env) - for var index: MalIntType = 0; index < bindings.count; index += 2 { - let binding_name = try! bindings.nth(index) - let binding_value = try! bindings.nth(index + 1) - guard let binding_symbol = as_symbolQ(binding_name) else { - try throw_error("expected symbol for first element in binding pair") - } - let evaluated_value = try EVAL(binding_value, new_env) - new_env.set(binding_symbol, evaluated_value) - } - if TCO { - return TCOVal(arg2, new_env) - } - return TCOVal(try EVAL(arg2, new_env)) -} - -// EVALuate "do". -// -private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { - if TCO { - let _ = try eval_ast(list.range_from(1, to: list.count-1), env) - return TCOVal(list.last(), env) - } - - let evaluated_ast = try eval_ast(list.rest(), env) - let evaluated_seq = as_sequence(evaluated_ast) - return TCOVal(evaluated_seq.last()) -} - -// EVALuate "if". -// -private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 3 else { - try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") - } - let cond_result = try EVAL(try! list.nth(1), env) - var new_ast: MalVal - if is_truthy(cond_result) { - new_ast = try! list.nth(2) - } else if list.count == 4 { - new_ast = try! list.nth(3) - } else { - return TCOVal(make_nil()) - } - if TCO { - return TCOVal(new_ast, env) - } - return TCOVal(try EVAL(new_ast, env)) -} - -// EVALuate "fn*". -// -private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") - } - guard let seq = as_sequenceQ(try! list.nth(1)) else { - try throw_error("expected list or vector for first argument to fn*") - } - return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) -} - -// EVALuate "quote". -// -private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { - if list.count >= 2 { - return TCOVal(try! list.nth(1)) - } - return TCOVal(make_nil()) -} - -// EVALuate "quasiquoteexpand". -// -private func eval_quasiquoteexp(list: MalSequence) throws -> TCOVal { - if list.count < 2 { - try throw_error("quasiquoteexpand: arg count") - } - return TCOVal(try! quasiquote(try! list.nth(1))) -} - -// EVALuate "quasiquote". -// -private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 2 else { - try throw_error("Expected non-nil parameter to 'quasiquote'") - } - if TCO { - return TCOVal(try quasiquote(try! list.nth(1)), env) - } - return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) -} - -// EVALuate "macroexpand". -// -private func eval_macroexpand(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 2 else { - try throw_error("Expected parameter to 'macroexpand'") - } - return TCOVal(try macroexpand(try! list.nth(1), env)) -} - -// EVALuate "try*" (and "catch*"). -// -private func eval_try(list: MalSequence, _ env: Environment) throws -> TCOVal { - // This is a subset of the Clojure try/catch: - // - // (try* expr (catch exception-name expr)) - - guard list.count >= 2 else { - try throw_error("try*: no body parameter") - } - - do { - return TCOVal(try EVAL(try! list.nth(1), env)) - } catch let error as MalException { - guard list.count >= 3, - let catch_list = as_sequenceQ(try! list.nth(2)) where catch_list.count >= 3, - let _ = as_symbolQ(try! catch_list.nth(0)) else - { - throw error // No catch parameter - } - let catch_name = try! catch_list.nth(1) - let catch_expr = try! catch_list.nth(2) - let catch_env = Environment(outer: env) - try catch_env.set_bindings(as_sequence(make_list_from(catch_name)), - with_exprs: as_sequence(make_list_from(error.exception))) - return TCOVal(try EVAL(catch_expr, catch_env)) - } -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { - EVAL_level++ - defer { EVAL_level-- } - guard EVAL_level <= EVAL_leval_max else { - try throw_error("Recursing too many levels (> \(EVAL_leval_max))") - } - - if DEBUG_EVAL { - indent = substring(INDENT_TEMPLATE, 0, EVAL_level) - } - - while true { - if DEBUG_EVAL { print("\(indent)> \(ast)") } - - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // Special handling if it's a list. - - var list = as_list(ast) - ast = try macroexpand(ast, env) - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - list = as_list(ast) - - if DEBUG_EVAL { print("\(indent)>. \(list)") } - - if list.isEmpty { - return ast - } - - // Check for special forms, where we want to check the operation - // before evaluating all of the parameters. - - let arg0 = list.first() - if let fn_symbol = as_symbolQ(arg0) { - let res: TCOVal - - switch fn_symbol { - case kSymbolDef: res = try eval_def(list, env) - case kSymbolDefMacro: res = try eval_def(list, env) - case kSymbolLet: res = try eval_let(list, env) - case kSymbolDo: res = try eval_do(list, env) - case kSymbolIf: res = try eval_if(list, env) - case kSymbolFn: res = try eval_fn(list, env) - case kSymbolQuote: res = try eval_quote(list, env) - case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) - case kSymbolQuasiQuoteExp: res = try eval_quasiquoteexp(list) - case kSymbolMacroExpand: res = try eval_macroexpand(list, env) - case kSymbolTry: res = try eval_try(list, env) - default: res = TCOVal() - } - switch res { - case let .Return(result): return result - case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue - case .NoResult: break - } - } - - // Standard list to be applied. Evaluate all the elements first. - - let eval = try eval_ast(ast, env) - - // The result had better be a list and better be non-empty. - - let eval_list = as_list(eval) - if eval_list.isEmpty { - return eval - } - - if DEBUG_EVAL { print("\(indent)>> \(eval)") } - - // Get the first element of the list and execute it. - - let first = eval_list.first() - let rest = as_sequence(eval_list.rest()) - - if let fn = as_builtinQ(first) { - let answer = try fn.apply(rest) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } else if let fn = as_closureQ(first) { - let new_env = Environment(outer: fn.env) - let _ = try new_env.set_bindings(fn.args, with_exprs: rest) - if TCO { - env = new_env - ast = fn.body - continue - } - let answer = try EVAL(fn.body, new_env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // The first element wasn't a function to be executed. Return an - // error saying so. - - try throw_error("first list item does not evaluate to a function: \(first)") - } -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String, _ env: Environment) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - do { - return try EVAL(ast, env) - } catch let error as MalException { - print("Error evaluating input: \(error)") - } catch { - print("Error evaluating input: \(error)") - } - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String, _ env: Environment) -> String? { - let exp = RE(text, env) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL(env: Environment) { - while true { - if let text = _readline("user> ") { - if let output = REP(text, env) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -// Process any command line arguments. Any trailing arguments are incorporated -// into the environment. Any argument immediately after the process name is -// taken as a script to execute. If one exists, it is executed in lieu of -// running the REPL. -// -private func process_command_line(args: [String], _ env: Environment) -> Bool { - var argv = make_list() - if args.count > 2 { - let args1 = args[2.. 1 { - RE("(load-file \"\(args[1])\")", env) - return false - } - - return true -} - -func main() { - let env = Environment(outer: nil) - - load_history_file() - load_builtins(env) - - RE("(def! not (fn* (a) (if a false true)))", env) - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) - RE("(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)))))))", env) - - env.set(kSymbolEval, make_builtin({ - try! unwrap_args($0) { - (ast: MalVal) -> MalVal in - try EVAL(ast, env) - } - })) - - if process_command_line(Process.arguments, env) { - REPL(env) - } - - save_history_file() -} +//****************************************************************************** +// MAL - step 9 - try +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// The number of times EVAL has been entered recursively. We keep track of this +// so that we can protect against overrunning the stack. +// +private var EVAL_level = 0 + +// The maximum number of times we let EVAL recurse before throwing an exception. +// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 +// for safety's sake. +// +private let EVAL_leval_max = 500 + +// Control whether or not tail-call optimization (TCO) is enabled. We want it +// `true` most of the time, but may disable it for debugging purposes (it's +// easier to get a meaningful backtrace that way). +// +private let TCO = true + +// Control whether or not we emit debugging statements in EVAL. +// +private let DEBUG_EVAL = false + +// String used to prefix information logged in EVAL. Increasing lengths of the +// string are used the more EVAL is recursed. +// +private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + +// Holds the prefix of INDENT_TEMPLATE used for actual logging. +// +private var indent = String() + +// Symbols used in this module. +// +private let kValArgv = make_symbol("*ARGV*") +private let kValCatch = make_symbol("catch*") +private let kValConcat = make_symbol("concat") +private let kValCons = make_symbol("cons") +private let kValDef = make_symbol("def!") +private let kValDefMacro = make_symbol("defmacro!") +private let kValDo = make_symbol("do") +private let kValEval = make_symbol("eval") +private let kValFn = make_symbol("fn*") +private let kValIf = make_symbol("if") +private let kValLet = make_symbol("let*") +private let kValMacroExpand = make_symbol("macroexpand") +private let kValQuasiQuote = make_symbol("quasiquote") +private let kValQuasiQuoteExp = make_symbol("quasiquoteexpand") +private let kValQuote = make_symbol("quote") +private let kValSpliceUnquote = make_symbol("splice-unquote") +private let kValUnquote = make_symbol("unquote") +private let kValTry = make_symbol("try*") +private let kValVec = make_symbol("vec") + +private let kSymbolArgv = as_symbol(kValArgv) +private let kSymbolCatch = as_symbol(kValCatch) +private let kSymbolConcat = as_symbol(kValConcat) +private let kSymbolCons = as_symbol(kValCons) +private let kSymbolDef = as_symbol(kValDef) +private let kSymbolDefMacro = as_symbol(kValDefMacro) +private let kSymbolDo = as_symbol(kValDo) +private let kSymbolEval = as_symbol(kValEval) +private let kSymbolFn = as_symbol(kValFn) +private let kSymbolIf = as_symbol(kValIf) +private let kSymbolLet = as_symbol(kValLet) +private let kSymbolMacroExpand = as_symbol(kValMacroExpand) +private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) +private let kSymbolQuasiQuoteExp = as_symbol(kValQuasiQuoteExp) +private let kSymbolQuote = as_symbol(kValQuote) +private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) +private let kSymbolUnquote = as_symbol(kValUnquote) +private let kSymbolTry = as_symbol(kValTry) +private let kSymbolVec = as_symbol(kValVec) + +func substring(s: String, _ begin: Int, _ end: Int) -> String { + return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] +} + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Expand macros for as long as the expression looks like a macro invocation. +// +private func macroexpand(var ast: MalVal, _ env: Environment) throws -> MalVal { + while true { + if let ast_as_list = as_listQ(ast) where !ast_as_list.isEmpty, + let macro_name = as_symbolQ(ast_as_list.first()), + let obj = env.get(macro_name), + let macro = as_macroQ(obj) + { + let new_env = Environment(outer: macro.env) + let rest = as_sequence(ast_as_list.rest()) + let _ = try new_env.set_bindings(macro.args, with_exprs: rest) + ast = try EVAL(macro.body, new_env) + continue + } + return ast + } +} + +// Return whether or not `ast` is a list and first element is the required symbol. +// +private func starts_with(ast: MalVal, sym: MalSymbol) -> MalVal? { + if let list = as_listQ(ast) where 1 < list.count, + let a0 = as_symbolQ(try! list.nth(0)) where a0 == sym { + return try! list.nth(1) + } else { + return nil + } +} + +// Evaluate `quasiquote`, possibly recursing in the process. +// +private func quasiquote(qq_arg: MalVal) throws -> MalVal { + + // If the argument is an atom or empty list: + // + // Return: (quote ) + + if is_symbol(qq_arg) || is_hashmap(qq_arg) { + return make_list_from(kValQuote, qq_arg) + } + + guard let seq = as_sequenceQ(qq_arg) else { + return qq_arg + } + + // The argument is a non-empty list -- that is (item rest...) + + // If the first item from the list is a symbol and it's "unquote" -- that + // is, (unquote item ignored...): + // + // Return: item + + if let x = starts_with(qq_arg, sym: kSymbolUnquote) { + return x + } + + var result = make_list_from() + for elt in seq.reverse() { + if let x = starts_with(elt, sym: kSymbolSpliceUnquote) { + result = make_list_from(kValConcat, x, result) + } else { + result = make_list_from(kValCons, try quasiquote (elt), result) + } + } + if is_vector(qq_arg) { + return make_list_from(kValVec, result) + } + return result +} + +// Perform a simple evaluation of the `ast` object. If it's a symbol, +// dereference it and return its value. If it's a collection, call EVAL on all +// elements (or just the values, in the case of the hashmap). Otherwise, return +// the object unchanged. +// +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { + if let symbol = as_symbolQ(ast) { + guard let val = env.get(symbol) else { + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests + } + return val + } + if let list = as_listQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for item in list { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_list(result) + } + if let vec = as_vectorQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(vec.count)) + for item in vec { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_vector(result) + } + if let hash = as_hashmapQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(hash.count) * 2) + for (k, v) in hash { + let new_v = try EVAL(v, env) + result.append(k) + result.append(new_v) + } + return make_hashmap(result) + } + return ast +} + +private enum TCOVal { + case NoResult + case Return(MalVal) + case Continue(MalVal, Environment) + + init() { self = .NoResult } + init(_ result: MalVal) { self = .Return(result) } + init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } +} + +// EVALuate "def!" and "defmacro!". +// +private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to def!, got \(list.count - 1)") + } + let arg0 = try! list.nth(0) + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let sym = as_symbolQ(arg1) else { + try throw_error("expected symbol for first argument to def!") + } + var value = try EVAL(arg2, env) + if as_symbol(arg0) == kSymbolDefMacro { + guard let closure = as_closureQ(value) else { + try throw_error("expected closure, got \(value)") + } + value = make_macro(closure) + } + return TCOVal(env.set(sym, value)) +} + +// EVALuate "let*". +// +private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to let*, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let bindings = as_sequenceQ(arg1) else { + try throw_error("expected list for first argument to let*") + } + guard bindings.count % 2 == 0 else { + try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") + } + let new_env = Environment(outer: env) + for var index: MalIntType = 0; index < bindings.count; index += 2 { + let binding_name = try! bindings.nth(index) + let binding_value = try! bindings.nth(index + 1) + guard let binding_symbol = as_symbolQ(binding_name) else { + try throw_error("expected symbol for first element in binding pair") + } + let evaluated_value = try EVAL(binding_value, new_env) + new_env.set(binding_symbol, evaluated_value) + } + if TCO { + return TCOVal(arg2, new_env) + } + return TCOVal(try EVAL(arg2, new_env)) +} + +// EVALuate "do". +// +private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { + if TCO { + let _ = try eval_ast(list.range_from(1, to: list.count-1), env) + return TCOVal(list.last(), env) + } + + let evaluated_ast = try eval_ast(list.rest(), env) + let evaluated_seq = as_sequence(evaluated_ast) + return TCOVal(evaluated_seq.last()) +} + +// EVALuate "if". +// +private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 3 else { + try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") + } + let cond_result = try EVAL(try! list.nth(1), env) + var new_ast: MalVal + if is_truthy(cond_result) { + new_ast = try! list.nth(2) + } else if list.count == 4 { + new_ast = try! list.nth(3) + } else { + return TCOVal(make_nil()) + } + if TCO { + return TCOVal(new_ast, env) + } + return TCOVal(try EVAL(new_ast, env)) +} + +// EVALuate "fn*". +// +private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") + } + guard let seq = as_sequenceQ(try! list.nth(1)) else { + try throw_error("expected list or vector for first argument to fn*") + } + return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) +} + +// EVALuate "quote". +// +private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { + if list.count >= 2 { + return TCOVal(try! list.nth(1)) + } + return TCOVal(make_nil()) +} + +// EVALuate "quasiquoteexpand". +// +private func eval_quasiquoteexp(list: MalSequence) throws -> TCOVal { + if list.count < 2 { + try throw_error("quasiquoteexpand: arg count") + } + return TCOVal(try! quasiquote(try! list.nth(1))) +} + +// EVALuate "quasiquote". +// +private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 2 else { + try throw_error("Expected non-nil parameter to 'quasiquote'") + } + if TCO { + return TCOVal(try quasiquote(try! list.nth(1)), env) + } + return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) +} + +// EVALuate "macroexpand". +// +private func eval_macroexpand(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 2 else { + try throw_error("Expected parameter to 'macroexpand'") + } + return TCOVal(try macroexpand(try! list.nth(1), env)) +} + +// EVALuate "try*" (and "catch*"). +// +private func eval_try(list: MalSequence, _ env: Environment) throws -> TCOVal { + // This is a subset of the Clojure try/catch: + // + // (try* expr (catch exception-name expr)) + + guard list.count >= 2 else { + try throw_error("try*: no body parameter") + } + + do { + return TCOVal(try EVAL(try! list.nth(1), env)) + } catch let error as MalException { + guard list.count >= 3, + let catch_list = as_sequenceQ(try! list.nth(2)) where catch_list.count >= 3, + let _ = as_symbolQ(try! catch_list.nth(0)) else + { + throw error // No catch parameter + } + let catch_name = try! catch_list.nth(1) + let catch_expr = try! catch_list.nth(2) + let catch_env = Environment(outer: env) + try catch_env.set_bindings(as_sequence(make_list_from(catch_name)), + with_exprs: as_sequence(make_list_from(error.exception))) + return TCOVal(try EVAL(catch_expr, catch_env)) + } +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { + EVAL_level++ + defer { EVAL_level-- } + guard EVAL_level <= EVAL_leval_max else { + try throw_error("Recursing too many levels (> \(EVAL_leval_max))") + } + + if DEBUG_EVAL { + indent = substring(INDENT_TEMPLATE, 0, EVAL_level) + } + + while true { + if DEBUG_EVAL { print("\(indent)> \(ast)") } + + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // Special handling if it's a list. + + var list = as_list(ast) + ast = try macroexpand(ast, env) + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + list = as_list(ast) + + if DEBUG_EVAL { print("\(indent)>. \(list)") } + + if list.isEmpty { + return ast + } + + // Check for special forms, where we want to check the operation + // before evaluating all of the parameters. + + let arg0 = list.first() + if let fn_symbol = as_symbolQ(arg0) { + let res: TCOVal + + switch fn_symbol { + case kSymbolDef: res = try eval_def(list, env) + case kSymbolDefMacro: res = try eval_def(list, env) + case kSymbolLet: res = try eval_let(list, env) + case kSymbolDo: res = try eval_do(list, env) + case kSymbolIf: res = try eval_if(list, env) + case kSymbolFn: res = try eval_fn(list, env) + case kSymbolQuote: res = try eval_quote(list, env) + case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) + case kSymbolQuasiQuoteExp: res = try eval_quasiquoteexp(list) + case kSymbolMacroExpand: res = try eval_macroexpand(list, env) + case kSymbolTry: res = try eval_try(list, env) + default: res = TCOVal() + } + switch res { + case let .Return(result): return result + case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue + case .NoResult: break + } + } + + // Standard list to be applied. Evaluate all the elements first. + + let eval = try eval_ast(ast, env) + + // The result had better be a list and better be non-empty. + + let eval_list = as_list(eval) + if eval_list.isEmpty { + return eval + } + + if DEBUG_EVAL { print("\(indent)>> \(eval)") } + + // Get the first element of the list and execute it. + + let first = eval_list.first() + let rest = as_sequence(eval_list.rest()) + + if let fn = as_builtinQ(first) { + let answer = try fn.apply(rest) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } else if let fn = as_closureQ(first) { + let new_env = Environment(outer: fn.env) + let _ = try new_env.set_bindings(fn.args, with_exprs: rest) + if TCO { + env = new_env + ast = fn.body + continue + } + let answer = try EVAL(fn.body, new_env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // The first element wasn't a function to be executed. Return an + // error saying so. + + try throw_error("first list item does not evaluate to a function: \(first)") + } +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String, _ env: Environment) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + do { + return try EVAL(ast, env) + } catch let error as MalException { + print("Error evaluating input: \(error)") + } catch { + print("Error evaluating input: \(error)") + } + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String, _ env: Environment) -> String? { + let exp = RE(text, env) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL(env: Environment) { + while true { + if let text = _readline("user> ") { + if let output = REP(text, env) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +// Process any command line arguments. Any trailing arguments are incorporated +// into the environment. Any argument immediately after the process name is +// taken as a script to execute. If one exists, it is executed in lieu of +// running the REPL. +// +private func process_command_line(args: [String], _ env: Environment) -> Bool { + var argv = make_list() + if args.count > 2 { + let args1 = args[2.. 1 { + RE("(load-file \"\(args[1])\")", env) + return false + } + + return true +} + +func main() { + let env = Environment(outer: nil) + + load_history_file() + load_builtins(env) + + RE("(def! not (fn* (a) (if a false true)))", env) + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) + RE("(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)))))))", env) + + env.set(kSymbolEval, make_builtin({ + try! unwrap_args($0) { + (ast: MalVal) -> MalVal in + try EVAL(ast, env) + } + })) + + if process_command_line(Process.arguments, env) { + REPL(env) + } + + save_history_file() +} diff --git a/impls/swift/stepA_mal.swift b/impls/swift/stepA_mal.swift index 96e93ecedc..b22dde319c 100644 --- a/impls/swift/stepA_mal.swift +++ b/impls/swift/stepA_mal.swift @@ -1,610 +1,610 @@ -//****************************************************************************** -// MAL - step A - mal -//****************************************************************************** -// This file is automatically generated from templates/step.swift. Rather than -// editing it directly, it's probably better to edit templates/step.swift and -// regenerate this file. Otherwise, your change might be lost if/when someone -// else performs that process. -//****************************************************************************** - -import Foundation - -// The number of times EVAL has been entered recursively. We keep track of this -// so that we can protect against overrunning the stack. -// -private var EVAL_level = 0 - -// The maximum number of times we let EVAL recurse before throwing an exception. -// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 -// for safety's sake. -// -private let EVAL_leval_max = 500 - -// Control whether or not tail-call optimization (TCO) is enabled. We want it -// `true` most of the time, but may disable it for debugging purposes (it's -// easier to get a meaningful backtrace that way). -// -private let TCO = true - -// Control whether or not we emit debugging statements in EVAL. -// -private let DEBUG_EVAL = false - -// String used to prefix information logged in EVAL. Increasing lengths of the -// string are used the more EVAL is recursed. -// -private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" + - "----|----|----|----|----|----|----|----|----|----|----|" - -// Holds the prefix of INDENT_TEMPLATE used for actual logging. -// -private var indent = String() - -// Symbols used in this module. -// -private let kValArgv = make_symbol("*ARGV*") -private let kValCatch = make_symbol("catch*") -private let kValConcat = make_symbol("concat") -private let kValCons = make_symbol("cons") -private let kValDef = make_symbol("def!") -private let kValDefMacro = make_symbol("defmacro!") -private let kValDo = make_symbol("do") -private let kValEval = make_symbol("eval") -private let kValFn = make_symbol("fn*") -private let kValIf = make_symbol("if") -private let kValLet = make_symbol("let*") -private let kValMacroExpand = make_symbol("macroexpand") -private let kValQuasiQuote = make_symbol("quasiquote") -private let kValQuasiQuoteExp = make_symbol("quasiquoteexpand") -private let kValQuote = make_symbol("quote") -private let kValSpliceUnquote = make_symbol("splice-unquote") -private let kValUnquote = make_symbol("unquote") -private let kValTry = make_symbol("try*") -private let kValVec = make_symbol("vec") - -private let kSymbolArgv = as_symbol(kValArgv) -private let kSymbolCatch = as_symbol(kValCatch) -private let kSymbolConcat = as_symbol(kValConcat) -private let kSymbolCons = as_symbol(kValCons) -private let kSymbolDef = as_symbol(kValDef) -private let kSymbolDefMacro = as_symbol(kValDefMacro) -private let kSymbolDo = as_symbol(kValDo) -private let kSymbolEval = as_symbol(kValEval) -private let kSymbolFn = as_symbol(kValFn) -private let kSymbolIf = as_symbol(kValIf) -private let kSymbolLet = as_symbol(kValLet) -private let kSymbolMacroExpand = as_symbol(kValMacroExpand) -private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) -private let kSymbolQuasiQuoteExp = as_symbol(kValQuasiQuoteExp) -private let kSymbolQuote = as_symbol(kValQuote) -private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) -private let kSymbolUnquote = as_symbol(kValUnquote) -private let kSymbolTry = as_symbol(kValTry) -private let kSymbolVec = as_symbol(kValVec) - -func substring(s: String, _ begin: Int, _ end: Int) -> String { - return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] -} - -// Parse the string into an AST. -// -private func READ(str: String) throws -> MalVal { - return try read_str(str) -} - -// Expand macros for as long as the expression looks like a macro invocation. -// -private func macroexpand(var ast: MalVal, _ env: Environment) throws -> MalVal { - while true { - if let ast_as_list = as_listQ(ast) where !ast_as_list.isEmpty, - let macro_name = as_symbolQ(ast_as_list.first()), - let obj = env.get(macro_name), - let macro = as_macroQ(obj) - { - let new_env = Environment(outer: macro.env) - let rest = as_sequence(ast_as_list.rest()) - let _ = try new_env.set_bindings(macro.args, with_exprs: rest) - ast = try EVAL(macro.body, new_env) - continue - } - return ast - } -} - -// Return whether or not `ast` is a list and first element is the required symbol. -// -private func starts_with(ast: MalVal, sym: MalSymbol) -> MalVal? { - if let list = as_listQ(ast) where 1 < list.count, - let a0 = as_symbolQ(try! list.nth(0)) where a0 == sym { - return try! list.nth(1) - } else { - return nil - } -} - -// Evaluate `quasiquote`, possibly recursing in the process. -// -private func quasiquote(qq_arg: MalVal) throws -> MalVal { - - // If the argument is an atom or empty list: - // - // Return: (quote ) - - if is_symbol(qq_arg) || is_hashmap(qq_arg) { - return make_list_from(kValQuote, qq_arg) - } - - guard let seq = as_sequenceQ(qq_arg) else { - return qq_arg - } - - // The argument is a non-empty list -- that is (item rest...) - - // If the first item from the list is a symbol and it's "unquote" -- that - // is, (unquote item ignored...): - // - // Return: item - - if let x = starts_with(qq_arg, sym: kSymbolUnquote) { - return x - } - - var result = make_list_from() - for elt in seq.reverse() { - if let x = starts_with(elt, sym: kSymbolSpliceUnquote) { - result = make_list_from(kValConcat, x, result) - } else { - result = make_list_from(kValCons, try quasiquote (elt), result) - } - } - if is_vector(qq_arg) { - return make_list_from(kValVec, result) - } - return result -} - -// Perform a simple evaluation of the `ast` object. If it's a symbol, -// dereference it and return its value. If it's a collection, call EVAL on all -// elements (or just the values, in the case of the hashmap). Otherwise, return -// the object unchanged. -// -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { - if let symbol = as_symbolQ(ast) { - guard let val = env.get(symbol) else { - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests - } - return val - } - if let list = as_listQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(list.count)) - for item in list { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_list(result) - } - if let vec = as_vectorQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(vec.count)) - for item in vec { - let eval = try EVAL(item, env) - result.append(eval) - } - return make_vector(result) - } - if let hash = as_hashmapQ(ast) { - var result = [MalVal]() - result.reserveCapacity(Int(hash.count) * 2) - for (k, v) in hash { - let new_v = try EVAL(v, env) - result.append(k) - result.append(new_v) - } - return make_hashmap(result) - } - return ast -} - -private enum TCOVal { - case NoResult - case Return(MalVal) - case Continue(MalVal, Environment) - - init() { self = .NoResult } - init(_ result: MalVal) { self = .Return(result) } - init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } -} - -// EVALuate "def!" and "defmacro!". -// -private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to def!, got \(list.count - 1)") - } - let arg0 = try! list.nth(0) - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let sym = as_symbolQ(arg1) else { - try throw_error("expected symbol for first argument to def!") - } - var value = try EVAL(arg2, env) - if as_symbol(arg0) == kSymbolDefMacro { - guard let closure = as_closureQ(value) else { - try throw_error("expected closure, got \(value)") - } - value = make_macro(closure) - } - return TCOVal(env.set(sym, value)) -} - -// EVALuate "let*". -// -private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to let*, got \(list.count - 1)") - } - let arg1 = try! list.nth(1) - let arg2 = try! list.nth(2) - guard let bindings = as_sequenceQ(arg1) else { - try throw_error("expected list for first argument to let*") - } - guard bindings.count % 2 == 0 else { - try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") - } - let new_env = Environment(outer: env) - for var index: MalIntType = 0; index < bindings.count; index += 2 { - let binding_name = try! bindings.nth(index) - let binding_value = try! bindings.nth(index + 1) - guard let binding_symbol = as_symbolQ(binding_name) else { - try throw_error("expected symbol for first element in binding pair") - } - let evaluated_value = try EVAL(binding_value, new_env) - new_env.set(binding_symbol, evaluated_value) - } - if TCO { - return TCOVal(arg2, new_env) - } - return TCOVal(try EVAL(arg2, new_env)) -} - -// EVALuate "do". -// -private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { - if TCO { - let _ = try eval_ast(list.range_from(1, to: list.count-1), env) - return TCOVal(list.last(), env) - } - - let evaluated_ast = try eval_ast(list.rest(), env) - let evaluated_seq = as_sequence(evaluated_ast) - return TCOVal(evaluated_seq.last()) -} - -// EVALuate "if". -// -private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 3 else { - try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") - } - let cond_result = try EVAL(try! list.nth(1), env) - var new_ast: MalVal - if is_truthy(cond_result) { - new_ast = try! list.nth(2) - } else if list.count == 4 { - new_ast = try! list.nth(3) - } else { - return TCOVal(make_nil()) - } - if TCO { - return TCOVal(new_ast, env) - } - return TCOVal(try EVAL(new_ast, env)) -} - -// EVALuate "fn*". -// -private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count == 3 else { - try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") - } - guard let seq = as_sequenceQ(try! list.nth(1)) else { - try throw_error("expected list or vector for first argument to fn*") - } - return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) -} - -// EVALuate "quote". -// -private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { - if list.count >= 2 { - return TCOVal(try! list.nth(1)) - } - return TCOVal(make_nil()) -} - -// EVALuate "quasiquoteexpand". -// -private func eval_quasiquoteexp(list: MalSequence) throws -> TCOVal { - if list.count < 2 { - try throw_error("quasiquoteexpand: arg count") - } - return TCOVal(try! quasiquote(try! list.nth(1))) -} - -// EVALuate "quasiquote". -// -private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 2 else { - try throw_error("Expected non-nil parameter to 'quasiquote'") - } - if TCO { - return TCOVal(try quasiquote(try! list.nth(1)), env) - } - return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) -} - -// EVALuate "macroexpand". -// -private func eval_macroexpand(list: MalSequence, _ env: Environment) throws -> TCOVal { - guard list.count >= 2 else { - try throw_error("Expected parameter to 'macroexpand'") - } - return TCOVal(try macroexpand(try! list.nth(1), env)) -} - -// EVALuate "try*" (and "catch*"). -// -private func eval_try(list: MalSequence, _ env: Environment) throws -> TCOVal { - // This is a subset of the Clojure try/catch: - // - // (try* expr (catch exception-name expr)) - - guard list.count >= 2 else { - try throw_error("try*: no body parameter") - } - - do { - return TCOVal(try EVAL(try! list.nth(1), env)) - } catch let error as MalException { - guard list.count >= 3, - let catch_list = as_sequenceQ(try! list.nth(2)) where catch_list.count >= 3, - let _ = as_symbolQ(try! catch_list.nth(0)) else - { - throw error // No catch parameter - } - let catch_name = try! catch_list.nth(1) - let catch_expr = try! catch_list.nth(2) - let catch_env = Environment(outer: env) - try catch_env.set_bindings(as_sequence(make_list_from(catch_name)), - with_exprs: as_sequence(make_list_from(error.exception))) - return TCOVal(try EVAL(catch_expr, catch_env)) - } -} - -// Walk the AST and completely evaluate it, handling macro expansions, special -// forms and function calls. -// -private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { - EVAL_level++ - defer { EVAL_level-- } - guard EVAL_level <= EVAL_leval_max else { - try throw_error("Recursing too many levels (> \(EVAL_leval_max))") - } - - if DEBUG_EVAL { - indent = substring(INDENT_TEMPLATE, 0, EVAL_level) - } - - while true { - if DEBUG_EVAL { print("\(indent)> \(ast)") } - - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // Special handling if it's a list. - - var list = as_list(ast) - ast = try macroexpand(ast, env) - if !is_list(ast) { - - // Not a list -- just evaluate and return. - - let answer = try eval_ast(ast, env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - list = as_list(ast) - - if DEBUG_EVAL { print("\(indent)>. \(list)") } - - if list.isEmpty { - return ast - } - - // Check for special forms, where we want to check the operation - // before evaluating all of the parameters. - - let arg0 = list.first() - if let fn_symbol = as_symbolQ(arg0) { - let res: TCOVal - - switch fn_symbol { - case kSymbolDef: res = try eval_def(list, env) - case kSymbolDefMacro: res = try eval_def(list, env) - case kSymbolLet: res = try eval_let(list, env) - case kSymbolDo: res = try eval_do(list, env) - case kSymbolIf: res = try eval_if(list, env) - case kSymbolFn: res = try eval_fn(list, env) - case kSymbolQuote: res = try eval_quote(list, env) - case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) - case kSymbolQuasiQuoteExp: res = try eval_quasiquoteexp(list) - case kSymbolMacroExpand: res = try eval_macroexpand(list, env) - case kSymbolTry: res = try eval_try(list, env) - default: res = TCOVal() - } - switch res { - case let .Return(result): return result - case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue - case .NoResult: break - } - } - - // Standard list to be applied. Evaluate all the elements first. - - let eval = try eval_ast(ast, env) - - // The result had better be a list and better be non-empty. - - let eval_list = as_list(eval) - if eval_list.isEmpty { - return eval - } - - if DEBUG_EVAL { print("\(indent)>> \(eval)") } - - // Get the first element of the list and execute it. - - let first = eval_list.first() - let rest = as_sequence(eval_list.rest()) - - if let fn = as_builtinQ(first) { - let answer = try fn.apply(rest) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } else if let fn = as_closureQ(first) { - let new_env = Environment(outer: fn.env) - let _ = try new_env.set_bindings(fn.args, with_exprs: rest) - if TCO { - env = new_env - ast = fn.body - continue - } - let answer = try EVAL(fn.body, new_env) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } - return answer - } - - // The first element wasn't a function to be executed. Return an - // error saying so. - - try throw_error("first list item does not evaluate to a function: \(first)") - } -} - -// Convert the value into a human-readable string for printing. -// -private func PRINT(exp: MalVal) -> String { - return pr_str(exp, true) -} - -// Perform the READ and EVAL steps. Useful for when you don't care about the -// printable result. -// -private func RE(text: String, _ env: Environment) -> MalVal? { - if !text.isEmpty { - do { - let ast = try READ(text) - do { - return try EVAL(ast, env) - } catch let error as MalException { - print("Error evaluating input: \(error)") - } catch { - print("Error evaluating input: \(error)") - } - } catch let error as MalException { - print("Error parsing input: \(error)") - } catch { - print("Error parsing input: \(error)") - } - } - return nil -} - -// Perform the full READ/EVAL/PRINT, returning a printable string. -// -private func REP(text: String, _ env: Environment) -> String? { - let exp = RE(text, env) - if exp == nil { return nil } - return PRINT(exp!) -} - -// Perform the full REPL. -// -private func REPL(env: Environment) { - while true { - if let text = _readline("user> ") { - if let output = REP(text, env) { - print("\(output)") - } - } else { - print("") - break - } - } -} - -// Process any command line arguments. Any trailing arguments are incorporated -// into the environment. Any argument immediately after the process name is -// taken as a script to execute. If one exists, it is executed in lieu of -// running the REPL. -// -private func process_command_line(args: [String], _ env: Environment) -> Bool { - var argv = make_list() - if args.count > 2 { - let args1 = args[2.. 1 { - RE("(load-file \"\(args[1])\")", env) - return false - } - - return true -} - -func main() { - let env = Environment(outer: nil) - - load_history_file() - load_builtins(env) - - RE("(def! *host-language* \"swift\")", env) - RE("(def! not (fn* (a) (if a false true)))", env) - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) - RE("(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)))))))", env) - - env.set(kSymbolEval, make_builtin({ - try! unwrap_args($0) { - (ast: MalVal) -> MalVal in - try EVAL(ast, env) - } - })) - - if process_command_line(Process.arguments, env) { - RE("(println (str \"Mal [\" *host-language*\"]\"))", env) - REPL(env) - } - - save_history_file() -} +//****************************************************************************** +// MAL - step A - mal +//****************************************************************************** +// This file is automatically generated from templates/step.swift. Rather than +// editing it directly, it's probably better to edit templates/step.swift and +// regenerate this file. Otherwise, your change might be lost if/when someone +// else performs that process. +//****************************************************************************** + +import Foundation + +// The number of times EVAL has been entered recursively. We keep track of this +// so that we can protect against overrunning the stack. +// +private var EVAL_level = 0 + +// The maximum number of times we let EVAL recurse before throwing an exception. +// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 +// for safety's sake. +// +private let EVAL_leval_max = 500 + +// Control whether or not tail-call optimization (TCO) is enabled. We want it +// `true` most of the time, but may disable it for debugging purposes (it's +// easier to get a meaningful backtrace that way). +// +private let TCO = true + +// Control whether or not we emit debugging statements in EVAL. +// +private let DEBUG_EVAL = false + +// String used to prefix information logged in EVAL. Increasing lengths of the +// string are used the more EVAL is recursed. +// +private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + + "----|----|----|----|----|----|----|----|----|----|----|" + +// Holds the prefix of INDENT_TEMPLATE used for actual logging. +// +private var indent = String() + +// Symbols used in this module. +// +private let kValArgv = make_symbol("*ARGV*") +private let kValCatch = make_symbol("catch*") +private let kValConcat = make_symbol("concat") +private let kValCons = make_symbol("cons") +private let kValDef = make_symbol("def!") +private let kValDefMacro = make_symbol("defmacro!") +private let kValDo = make_symbol("do") +private let kValEval = make_symbol("eval") +private let kValFn = make_symbol("fn*") +private let kValIf = make_symbol("if") +private let kValLet = make_symbol("let*") +private let kValMacroExpand = make_symbol("macroexpand") +private let kValQuasiQuote = make_symbol("quasiquote") +private let kValQuasiQuoteExp = make_symbol("quasiquoteexpand") +private let kValQuote = make_symbol("quote") +private let kValSpliceUnquote = make_symbol("splice-unquote") +private let kValUnquote = make_symbol("unquote") +private let kValTry = make_symbol("try*") +private let kValVec = make_symbol("vec") + +private let kSymbolArgv = as_symbol(kValArgv) +private let kSymbolCatch = as_symbol(kValCatch) +private let kSymbolConcat = as_symbol(kValConcat) +private let kSymbolCons = as_symbol(kValCons) +private let kSymbolDef = as_symbol(kValDef) +private let kSymbolDefMacro = as_symbol(kValDefMacro) +private let kSymbolDo = as_symbol(kValDo) +private let kSymbolEval = as_symbol(kValEval) +private let kSymbolFn = as_symbol(kValFn) +private let kSymbolIf = as_symbol(kValIf) +private let kSymbolLet = as_symbol(kValLet) +private let kSymbolMacroExpand = as_symbol(kValMacroExpand) +private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) +private let kSymbolQuasiQuoteExp = as_symbol(kValQuasiQuoteExp) +private let kSymbolQuote = as_symbol(kValQuote) +private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) +private let kSymbolUnquote = as_symbol(kValUnquote) +private let kSymbolTry = as_symbol(kValTry) +private let kSymbolVec = as_symbol(kValVec) + +func substring(s: String, _ begin: Int, _ end: Int) -> String { + return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] +} + +// Parse the string into an AST. +// +private func READ(str: String) throws -> MalVal { + return try read_str(str) +} + +// Expand macros for as long as the expression looks like a macro invocation. +// +private func macroexpand(var ast: MalVal, _ env: Environment) throws -> MalVal { + while true { + if let ast_as_list = as_listQ(ast) where !ast_as_list.isEmpty, + let macro_name = as_symbolQ(ast_as_list.first()), + let obj = env.get(macro_name), + let macro = as_macroQ(obj) + { + let new_env = Environment(outer: macro.env) + let rest = as_sequence(ast_as_list.rest()) + let _ = try new_env.set_bindings(macro.args, with_exprs: rest) + ast = try EVAL(macro.body, new_env) + continue + } + return ast + } +} + +// Return whether or not `ast` is a list and first element is the required symbol. +// +private func starts_with(ast: MalVal, sym: MalSymbol) -> MalVal? { + if let list = as_listQ(ast) where 1 < list.count, + let a0 = as_symbolQ(try! list.nth(0)) where a0 == sym { + return try! list.nth(1) + } else { + return nil + } +} + +// Evaluate `quasiquote`, possibly recursing in the process. +// +private func quasiquote(qq_arg: MalVal) throws -> MalVal { + + // If the argument is an atom or empty list: + // + // Return: (quote ) + + if is_symbol(qq_arg) || is_hashmap(qq_arg) { + return make_list_from(kValQuote, qq_arg) + } + + guard let seq = as_sequenceQ(qq_arg) else { + return qq_arg + } + + // The argument is a non-empty list -- that is (item rest...) + + // If the first item from the list is a symbol and it's "unquote" -- that + // is, (unquote item ignored...): + // + // Return: item + + if let x = starts_with(qq_arg, sym: kSymbolUnquote) { + return x + } + + var result = make_list_from() + for elt in seq.reverse() { + if let x = starts_with(elt, sym: kSymbolSpliceUnquote) { + result = make_list_from(kValConcat, x, result) + } else { + result = make_list_from(kValCons, try quasiquote (elt), result) + } + } + if is_vector(qq_arg) { + return make_list_from(kValVec, result) + } + return result +} + +// Perform a simple evaluation of the `ast` object. If it's a symbol, +// dereference it and return its value. If it's a collection, call EVAL on all +// elements (or just the values, in the case of the hashmap). Otherwise, return +// the object unchanged. +// +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { + if let symbol = as_symbolQ(ast) { + guard let val = env.get(symbol) else { + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests + } + return val + } + if let list = as_listQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(list.count)) + for item in list { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_list(result) + } + if let vec = as_vectorQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(vec.count)) + for item in vec { + let eval = try EVAL(item, env) + result.append(eval) + } + return make_vector(result) + } + if let hash = as_hashmapQ(ast) { + var result = [MalVal]() + result.reserveCapacity(Int(hash.count) * 2) + for (k, v) in hash { + let new_v = try EVAL(v, env) + result.append(k) + result.append(new_v) + } + return make_hashmap(result) + } + return ast +} + +private enum TCOVal { + case NoResult + case Return(MalVal) + case Continue(MalVal, Environment) + + init() { self = .NoResult } + init(_ result: MalVal) { self = .Return(result) } + init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } +} + +// EVALuate "def!" and "defmacro!". +// +private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to def!, got \(list.count - 1)") + } + let arg0 = try! list.nth(0) + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let sym = as_symbolQ(arg1) else { + try throw_error("expected symbol for first argument to def!") + } + var value = try EVAL(arg2, env) + if as_symbol(arg0) == kSymbolDefMacro { + guard let closure = as_closureQ(value) else { + try throw_error("expected closure, got \(value)") + } + value = make_macro(closure) + } + return TCOVal(env.set(sym, value)) +} + +// EVALuate "let*". +// +private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to let*, got \(list.count - 1)") + } + let arg1 = try! list.nth(1) + let arg2 = try! list.nth(2) + guard let bindings = as_sequenceQ(arg1) else { + try throw_error("expected list for first argument to let*") + } + guard bindings.count % 2 == 0 else { + try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") + } + let new_env = Environment(outer: env) + for var index: MalIntType = 0; index < bindings.count; index += 2 { + let binding_name = try! bindings.nth(index) + let binding_value = try! bindings.nth(index + 1) + guard let binding_symbol = as_symbolQ(binding_name) else { + try throw_error("expected symbol for first element in binding pair") + } + let evaluated_value = try EVAL(binding_value, new_env) + new_env.set(binding_symbol, evaluated_value) + } + if TCO { + return TCOVal(arg2, new_env) + } + return TCOVal(try EVAL(arg2, new_env)) +} + +// EVALuate "do". +// +private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { + if TCO { + let _ = try eval_ast(list.range_from(1, to: list.count-1), env) + return TCOVal(list.last(), env) + } + + let evaluated_ast = try eval_ast(list.rest(), env) + let evaluated_seq = as_sequence(evaluated_ast) + return TCOVal(evaluated_seq.last()) +} + +// EVALuate "if". +// +private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 3 else { + try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") + } + let cond_result = try EVAL(try! list.nth(1), env) + var new_ast: MalVal + if is_truthy(cond_result) { + new_ast = try! list.nth(2) + } else if list.count == 4 { + new_ast = try! list.nth(3) + } else { + return TCOVal(make_nil()) + } + if TCO { + return TCOVal(new_ast, env) + } + return TCOVal(try EVAL(new_ast, env)) +} + +// EVALuate "fn*". +// +private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count == 3 else { + try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") + } + guard let seq = as_sequenceQ(try! list.nth(1)) else { + try throw_error("expected list or vector for first argument to fn*") + } + return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) +} + +// EVALuate "quote". +// +private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { + if list.count >= 2 { + return TCOVal(try! list.nth(1)) + } + return TCOVal(make_nil()) +} + +// EVALuate "quasiquoteexpand". +// +private func eval_quasiquoteexp(list: MalSequence) throws -> TCOVal { + if list.count < 2 { + try throw_error("quasiquoteexpand: arg count") + } + return TCOVal(try! quasiquote(try! list.nth(1))) +} + +// EVALuate "quasiquote". +// +private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 2 else { + try throw_error("Expected non-nil parameter to 'quasiquote'") + } + if TCO { + return TCOVal(try quasiquote(try! list.nth(1)), env) + } + return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) +} + +// EVALuate "macroexpand". +// +private func eval_macroexpand(list: MalSequence, _ env: Environment) throws -> TCOVal { + guard list.count >= 2 else { + try throw_error("Expected parameter to 'macroexpand'") + } + return TCOVal(try macroexpand(try! list.nth(1), env)) +} + +// EVALuate "try*" (and "catch*"). +// +private func eval_try(list: MalSequence, _ env: Environment) throws -> TCOVal { + // This is a subset of the Clojure try/catch: + // + // (try* expr (catch exception-name expr)) + + guard list.count >= 2 else { + try throw_error("try*: no body parameter") + } + + do { + return TCOVal(try EVAL(try! list.nth(1), env)) + } catch let error as MalException { + guard list.count >= 3, + let catch_list = as_sequenceQ(try! list.nth(2)) where catch_list.count >= 3, + let _ = as_symbolQ(try! catch_list.nth(0)) else + { + throw error // No catch parameter + } + let catch_name = try! catch_list.nth(1) + let catch_expr = try! catch_list.nth(2) + let catch_env = Environment(outer: env) + try catch_env.set_bindings(as_sequence(make_list_from(catch_name)), + with_exprs: as_sequence(make_list_from(error.exception))) + return TCOVal(try EVAL(catch_expr, catch_env)) + } +} + +// Walk the AST and completely evaluate it, handling macro expansions, special +// forms and function calls. +// +private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { + EVAL_level++ + defer { EVAL_level-- } + guard EVAL_level <= EVAL_leval_max else { + try throw_error("Recursing too many levels (> \(EVAL_leval_max))") + } + + if DEBUG_EVAL { + indent = substring(INDENT_TEMPLATE, 0, EVAL_level) + } + + while true { + if DEBUG_EVAL { print("\(indent)> \(ast)") } + + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // Special handling if it's a list. + + var list = as_list(ast) + ast = try macroexpand(ast, env) + if !is_list(ast) { + + // Not a list -- just evaluate and return. + + let answer = try eval_ast(ast, env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + list = as_list(ast) + + if DEBUG_EVAL { print("\(indent)>. \(list)") } + + if list.isEmpty { + return ast + } + + // Check for special forms, where we want to check the operation + // before evaluating all of the parameters. + + let arg0 = list.first() + if let fn_symbol = as_symbolQ(arg0) { + let res: TCOVal + + switch fn_symbol { + case kSymbolDef: res = try eval_def(list, env) + case kSymbolDefMacro: res = try eval_def(list, env) + case kSymbolLet: res = try eval_let(list, env) + case kSymbolDo: res = try eval_do(list, env) + case kSymbolIf: res = try eval_if(list, env) + case kSymbolFn: res = try eval_fn(list, env) + case kSymbolQuote: res = try eval_quote(list, env) + case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) + case kSymbolQuasiQuoteExp: res = try eval_quasiquoteexp(list) + case kSymbolMacroExpand: res = try eval_macroexpand(list, env) + case kSymbolTry: res = try eval_try(list, env) + default: res = TCOVal() + } + switch res { + case let .Return(result): return result + case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue + case .NoResult: break + } + } + + // Standard list to be applied. Evaluate all the elements first. + + let eval = try eval_ast(ast, env) + + // The result had better be a list and better be non-empty. + + let eval_list = as_list(eval) + if eval_list.isEmpty { + return eval + } + + if DEBUG_EVAL { print("\(indent)>> \(eval)") } + + // Get the first element of the list and execute it. + + let first = eval_list.first() + let rest = as_sequence(eval_list.rest()) + + if let fn = as_builtinQ(first) { + let answer = try fn.apply(rest) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } else if let fn = as_closureQ(first) { + let new_env = Environment(outer: fn.env) + let _ = try new_env.set_bindings(fn.args, with_exprs: rest) + if TCO { + env = new_env + ast = fn.body + continue + } + let answer = try EVAL(fn.body, new_env) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } + return answer + } + + // The first element wasn't a function to be executed. Return an + // error saying so. + + try throw_error("first list item does not evaluate to a function: \(first)") + } +} + +// Convert the value into a human-readable string for printing. +// +private func PRINT(exp: MalVal) -> String { + return pr_str(exp, true) +} + +// Perform the READ and EVAL steps. Useful for when you don't care about the +// printable result. +// +private func RE(text: String, _ env: Environment) -> MalVal? { + if !text.isEmpty { + do { + let ast = try READ(text) + do { + return try EVAL(ast, env) + } catch let error as MalException { + print("Error evaluating input: \(error)") + } catch { + print("Error evaluating input: \(error)") + } + } catch let error as MalException { + print("Error parsing input: \(error)") + } catch { + print("Error parsing input: \(error)") + } + } + return nil +} + +// Perform the full READ/EVAL/PRINT, returning a printable string. +// +private func REP(text: String, _ env: Environment) -> String? { + let exp = RE(text, env) + if exp == nil { return nil } + return PRINT(exp!) +} + +// Perform the full REPL. +// +private func REPL(env: Environment) { + while true { + if let text = _readline("user> ") { + if let output = REP(text, env) { + print("\(output)") + } + } else { + print("") + break + } + } +} + +// Process any command line arguments. Any trailing arguments are incorporated +// into the environment. Any argument immediately after the process name is +// taken as a script to execute. If one exists, it is executed in lieu of +// running the REPL. +// +private func process_command_line(args: [String], _ env: Environment) -> Bool { + var argv = make_list() + if args.count > 2 { + let args1 = args[2.. 1 { + RE("(load-file \"\(args[1])\")", env) + return false + } + + return true +} + +func main() { + let env = Environment(outer: nil) + + load_history_file() + load_builtins(env) + + RE("(def! *host-language* \"swift\")", env) + RE("(def! not (fn* (a) (if a false true)))", env) + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", env) + RE("(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)))))))", env) + + env.set(kSymbolEval, make_builtin({ + try! unwrap_args($0) { + (ast: MalVal) -> MalVal in + try EVAL(ast, env) + } + })) + + if process_command_line(Process.arguments, env) { + RE("(println (str \"Mal [\" *host-language*\"]\"))", env) + REPL(env) + } + + save_history_file() +} diff --git a/impls/swift/templates/add_steps.sh b/impls/swift/templates/add_steps.sh index 488b54b82d..1e7ad8d030 100755 --- a/impls/swift/templates/add_steps.sh +++ b/impls/swift/templates/add_steps.sh @@ -1,23 +1,23 @@ -#!/bin/bash - -# add_steps.sh input-file output-file -# -# Adds placeholder annotations to each line of a file. These annotations -# indicate which version(s) of the main (step*.swift) file the line should be -# included in. The annotations are just placeholders, and need to be edited to -# identify the right file versions. -# -# e.g.: -# -# $ ./add_steps.sh stepA_mal.swift main_template.swift - -SPC10=" " -SPC20="${SPC10}${SPC10}" -SPC40="${SPC20}${SPC20}" -SPC80="${SPC40}${SPC40}" -SPC160="${SPC80}${SPC80}" -sed < $1 > $2 -e "s/\(.*\)/\1${SPC160}/" -e "/^\(.\)\{156\} .*$/s/\(.\{160\}\).*/\1\/\/ malstep(A)/" - -# TBD: try the following, subsequently found on stackoverflow: -# -# sed -i ':a;/.\{63\}/!{s/$/ /;ba}' file +#!/bin/bash + +# add_steps.sh input-file output-file +# +# Adds placeholder annotations to each line of a file. These annotations +# indicate which version(s) of the main (step*.swift) file the line should be +# included in. The annotations are just placeholders, and need to be edited to +# identify the right file versions. +# +# e.g.: +# +# $ ./add_steps.sh stepA_mal.swift main_template.swift + +SPC10=" " +SPC20="${SPC10}${SPC10}" +SPC40="${SPC20}${SPC20}" +SPC80="${SPC40}${SPC40}" +SPC160="${SPC80}${SPC80}" +sed < $1 > $2 -e "s/\(.*\)/\1${SPC160}/" -e "/^\(.\)\{156\} .*$/s/\(.\{160\}\).*/\1\/\/ malstep(A)/" + +# TBD: try the following, subsequently found on stackoverflow: +# +# sed -i ':a;/.\{63\}/!{s/$/ /;ba}' file diff --git a/impls/swift/templates/filter_steps.sh b/impls/swift/templates/filter_steps.sh index 44fe604b78..5a6486a647 100755 --- a/impls/swift/templates/filter_steps.sh +++ b/impls/swift/templates/filter_steps.sh @@ -1,9 +1,9 @@ -#!/bin/bash - -# filter_steps.sh step input-file output-file -# -# Filter the template file to produce a specific version of the file. E.g.: -# -# $ ./filter_steps 4 main_template.swift step4_if_fn_do.swift - -grep "malstep.*\<$1\>" $2 | sed -e 's/\(.*\)\/\/ malstep(.*)$/\1/' -e 's/ *$//' > $3 +#!/bin/bash + +# filter_steps.sh step input-file output-file +# +# Filter the template file to produce a specific version of the file. E.g.: +# +# $ ./filter_steps 4 main_template.swift step4_if_fn_do.swift + +grep "malstep.*\<$1\>" $2 | sed -e 's/\(.*\)\/\/ malstep(.*)$/\1/' -e 's/ *$//' > $3 diff --git a/impls/swift/templates/step.swift b/impls/swift/templates/step.swift index 8e66e7a0fc..bec22f1dec 100644 --- a/impls/swift/templates/step.swift +++ b/impls/swift/templates/step.swift @@ -1,804 +1,804 @@ -//****************************************************************************** -// -// This file is used to generate the various "step" files, which in turn are -// used to create the various step executables. -// -// For the most part, this file is the final step file, with each line annotated -// with information that says in which step the line is introduced into the -// project. A simple filter program scans this template file, pulling out the -// lines required for a specified step. -// -// Ideally, after each line is included in a project, it stays in the project. -// This would make each step file a proper superset of the previous steps files. -// However, such idealism cannot be realized. There are cases where lines -// introduced in early step files need to be removed or replaced with new -// version. -// -// When this happens, multiple versions of a particular line can appear in the -// file. For example, consider the READ function. Early in the project, it is -// introduced as: -// -// func READ(str: String) -> String { -// return str -// } -// -// However, it is replaced in a subsequent step with: -// -// func READ(str: String) -> MalVal { -// return read_str(str) -// } -// -// To support both forms, both are included in this template file. The first is -// annotated to say that it appears in step 0 and *only* in step 0. The second -// is annotated to say that it appears in step 1 and in all subsequent versions. -// -// Where possible, in the interests for clarity, where lines are introduced and -// replaced, the entire function that is affected is introduced and replaced. -// This is as opposed to trying to surgically identify the line-by-line changes -// within a function that need to be replaced. -// -// However, in other cases, the surgical line-by-line replacement of text is -// employed. This is done in cases where the number of lines to change is small -// compared to the overall size of the function. -// -// Places where previously-introduced lines are changed or removed are marked -// with a ">>> NOTE:" comment. -// -// Lines with no annotations (like those comprising this comment block) are -// never included in any output. -// -//****************************************************************************** - -//****************************************************************************** // malstep(0,1,2,3,4,5,6,7,8,9,A) -// MAL - step 0 - repl // malstep(0) -// MAL - step 1 - read/print // malstep(1) -// MAL - step 2 - eval // malstep(2) -// MAL - step 3 - env // malstep(3) -// MAL - step 4 - if/fn/do // malstep(4) -// MAL - step 5 - tco // malstep(5) -// MAL - step 6 - file // malstep(6) -// MAL - step 7 - quote // malstep(7) -// MAL - step 8 - macros // malstep(8) -// MAL - step 9 - try // malstep(9) -// MAL - step A - mal // malstep(A) -//****************************************************************************** // malstep(0,1,2,3,4,5,6,7,8,9,A) -// This file is automatically generated from templates/step.swift. Rather than // malstep(0,1,2,3,4,5,6,7,8,9,A) -// editing it directly, it's probably better to edit templates/step.swift and // malstep(0,1,2,3,4,5,6,7,8,9,A) -// regenerate this file. Otherwise, your change might be lost if/when someone // malstep(0,1,2,3,4,5,6,7,8,9,A) -// else performs that process. // malstep(0,1,2,3,4,5,6,7,8,9,A) -//****************************************************************************** // malstep(0,1,2,3,4,5,6,7,8,9,A) - // malstep(0,1,2,3,4,5,6,7,8,9,A) -import Foundation // malstep(0,1,2,3,4,5,6,7,8,9,A) - // malstep(0,1,2,3,4,5,6,7,8,9,A) -// The number of times EVAL has been entered recursively. We keep track of this // malstep(5,6,7,8,9,A) -// so that we can protect against overrunning the stack. // malstep(5,6,7,8,9,A) -// // malstep(5,6,7,8,9,A) -private var EVAL_level = 0 // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) -// The maximum number of times we let EVAL recurse before throwing an exception. // malstep(5,6,7,8,9,A) -// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 // malstep(5,6,7,8,9,A) -// for safety's sake. // malstep(5,6,7,8,9,A) -// // malstep(5,6,7,8,9,A) -private let EVAL_leval_max = 500 // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) -// Control whether or not tail-call optimization (TCO) is enabled. We want it // malstep(5,6,7,8,9,A) -// `true` most of the time, but may disable it for debugging purposes (it's // malstep(5,6,7,8,9,A) -// easier to get a meaningful backtrace that way). // malstep(5,6,7,8,9,A) -// // malstep(5,6,7,8,9,A) -private let TCO = true // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) -// Control whether or not we emit debugging statements in EVAL. // malstep(5,6,7,8,9,A) -// // malstep(5,6,7,8,9,A) -private let DEBUG_EVAL = false // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) -// String used to prefix information logged in EVAL. Increasing lengths of the // malstep(5,6,7,8,9,A) -// string are used the more EVAL is recursed. // malstep(5,6,7,8,9,A) -// // malstep(5,6,7,8,9,A) -private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) - "----|----|----|----|----|----|----|----|----|----|----|" // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) -// Holds the prefix of INDENT_TEMPLATE used for actual logging. // malstep(5,6,7,8,9,A) -// // malstep(5,6,7,8,9,A) -private var indent = String() // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) -// Symbols used in this module. // malstep(3,4,5,6,7,8,9,A) -// // malstep(3,4,5,6,7,8,9,A) -private let kValArgv = make_symbol("*ARGV*") // malstep(6,7,8,9,A) -private let kValCatch = make_symbol("catch*") // malstep(9,A) -private let kValConcat = make_symbol("concat") // malstep(7,8,9,A) -private let kValCons = make_symbol("cons") // malstep(7,8,9,A) -private let kValDef = make_symbol("def!") // malstep(3,4,5,6,7,8,9,A) -private let kValDefMacro = make_symbol("defmacro!") // malstep(8,9,A) -private let kValDo = make_symbol("do") // malstep(4,5,6,7,8,9,A) -private let kValEval = make_symbol("eval") // malstep(6,7,8,9,A) -private let kValFn = make_symbol("fn*") // malstep(4,5,6,7,8,9,A) -private let kValIf = make_symbol("if") // malstep(4,5,6,7,8,9,A) -private let kValLet = make_symbol("let*") // malstep(3,4,5,6,7,8,9,A) -private let kValMacroExpand = make_symbol("macroexpand") // malstep(8,9,A) -private let kValQuasiQuote = make_symbol("quasiquote") // malstep(7,8,9,A) -private let kValQuote = make_symbol("quote") // malstep(7,8,9,A) -private let kValSpliceUnquote = make_symbol("splice-unquote") // malstep(7,8,9,A) -private let kValUnquote = make_symbol("unquote") // malstep(7,8,9,A) -private let kValTry = make_symbol("try*") // malstep(3,4,5,6,7,8,9,A) - // malstep(3,4,5,6,7,8,9,A) -private let kSymbolArgv = as_symbol(kValArgv) // malstep(6,7,8,9,A) -private let kSymbolCatch = as_symbol(kValCatch) // malstep(9,A) -private let kSymbolConcat = as_symbol(kValConcat) // malstep(7,8,9,A) -private let kSymbolCons = as_symbol(kValCons) // malstep(7,8,9,A) -private let kSymbolDef = as_symbol(kValDef) // malstep(3,4,5,6,7,8,9,A) -private let kSymbolDefMacro = as_symbol(kValDefMacro) // malstep(8,9,A) -private let kSymbolDo = as_symbol(kValDo) // malstep(4,5,6,7,8,9,A) -private let kSymbolEval = as_symbol(kValEval) // malstep(6,7,8,9,A) -private let kSymbolFn = as_symbol(kValFn) // malstep(4,5,6,7,8,9,A) -private let kSymbolIf = as_symbol(kValIf) // malstep(4,5,6,7,8,9,A) -private let kSymbolLet = as_symbol(kValLet) // malstep(3,4,5,6,7,8,9,A) -private let kSymbolMacroExpand = as_symbol(kValMacroExpand) // malstep(8,9,A) -private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) // malstep(7,8,9,A) -private let kSymbolQuote = as_symbol(kValQuote) // malstep(7,8,9,A) -private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) // malstep(7,8,9,A) -private let kSymbolUnquote = as_symbol(kValUnquote) // malstep(7,8,9,A) -private let kSymbolTry = as_symbol(kValTry) // malstep(9,A) - // malstep(3,4,5,6,7,8,9,A) -func substring(s: String, _ begin: Int, _ end: Int) -> String { // malstep(5,6,7,8,9,A) - return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] // malstep(5,6,7,8,9,A) -} // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) -// -// >>> NOTE: There are two versions of the following function: one used in step -// >>> 0 and one used in all subsequent versions. -// - -// Parse the string into an AST. // malstep(0,1,2,3,4,5,6,7,8,9,A) -// // malstep(0,1,2,3,4,5,6,7,8,9,A) -private func READ(str: String) -> String { // malstep(0) - return str // malstep(0) -} // malstep(0) -private func READ(str: String) throws -> MalVal { // malstep(1,2,3,4,5,6,7,8,9,A) - return try read_str(str) // malstep(1,2,3,4,5,6,7,8,9,A) -} // malstep(1,2,3,4,5,6,7,8,9,A) - // malstep(0,1,2,3,4,5,6,7,8,9,A) -// Return whether or not `val` is a non-empty list. // malstep(7,8,9,A) -// // malstep(7,8,9,A) -private func is_pair(val: MalVal) -> Bool { // malstep(7,8,9,A) - if let seq = as_sequenceQ(val) { // malstep(7,8,9,A) - return !seq.isEmpty // malstep(7,8,9,A) - } // malstep(7,8,9,A) - return false // malstep(7,8,9,A) -} // malstep(7,8,9,A) - // malstep(7,8,9,A) -// Expand macros for as long as the expression looks like a macro invocation. // malstep(8,9,A) -// // malstep(8,9,A) -private func macroexpand(var ast: MalVal, _ env: Environment) throws -> MalVal { // malstep(8,9,A) - while true { // malstep(8,9,A) - if let ast_as_list = as_listQ(ast) where !ast_as_list.isEmpty, // malstep(8,9,A) - let macro_name = as_symbolQ(ast_as_list.first()), // malstep(8,9,A) - let obj = env.get(macro_name), // malstep(8,9,A) - let macro = as_macroQ(obj) // malstep(8,9,A) - { // malstep(8,9,A) - let new_env = Environment(outer: macro.env) // malstep(8,9,A) - let rest = as_sequence(ast_as_list.rest()) // malstep(8,9,A) - let _ = try new_env.set_bindings(macro.args, with_exprs: rest) // malstep(8,9,A) - ast = try EVAL(macro.body, new_env) // malstep(8,9,A) - continue // malstep(8,9,A) - } // malstep(8,9,A) - return ast // malstep(8,9,A) - } // malstep(8,9,A) -} // malstep(8,9,A) - // malstep(8,9,A) -// Evaluate `quasiquote`, possibly recursing in the process. // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// As with quote, unquote, and splice-unquote, quasiquote takes a single // malstep(7,8,9,A) -// parameter, typically a list. In the general case, this list is processed // malstep(7,8,9,A) -// recursively as: // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// (quasiquote (first rest...)) -> (cons (quasiquote first) (quasiquote rest)) // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// In the processing of the parameter passed to it, quasiquote handles three // malstep(7,8,9,A) -// special cases: // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// * If the parameter is an atom or an empty list, the following expression // malstep(7,8,9,A) -// is formed and returned for evaluation: // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// (quasiquote atom-or-empty-list) -> (quote atom-or-empty-list) // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// * If the first element of the non-empty list is the symbol "unquote" // malstep(7,8,9,A) -// followed by a second item, the second item is returned as-is: // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// (quasiquote (unquote fred)) -> fred // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// * If the first element of the non-empty list is another list containing // malstep(7,8,9,A) -// the symbol "splice-unquote" followed by a list, that list is catenated // malstep(7,8,9,A) -// with the quasiquoted result of the remaining items in the non-empty // malstep(7,8,9,A) -// parent list: // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// (quasiquote (splice-unquote list) rest...) -> (items-from-list items-from-quasiquote(rest...)) // malstep(7,8,9,A) -// // malstep(7,8,9,A) -// Note the inconsistent handling between "quote" and "splice-quote". The former // malstep(7,8,9,A) -// is handled when this function is handed a list that starts with "quote", // malstep(7,8,9,A) -// whereas the latter is handled when this function is handled a list whose // malstep(7,8,9,A) -// first element is a list that starts with "splice-quote". The handling of the // malstep(7,8,9,A) -// latter is forced by the need to incorporate the results of (splice-quote // malstep(7,8,9,A) -// list) with the remaining items of the list containing that splice-quote // malstep(7,8,9,A) -// expression. However, it's not clear to me why the handling of "unquote" is // malstep(7,8,9,A) -// not handled similarly, for consistency's sake. // malstep(7,8,9,A) -// // malstep(7,8,9,A) -private func quasiquote(qq_arg: MalVal) throws -> MalVal { // malstep(7,8,9,A) - // malstep(7,8,9,A) - // If the argument is an atom or empty list: // malstep(7,8,9,A) - // // malstep(7,8,9,A) - // Return: (quote ) // malstep(7,8,9,A) - // malstep(7,8,9,A) - if !is_pair(qq_arg) { // malstep(7,8,9,A) - return make_list_from(kValQuote, qq_arg) // malstep(7,8,9,A) - } // malstep(7,8,9,A) - // malstep(7,8,9,A) - // The argument is a non-empty list -- that is (item rest...) // malstep(7,8,9,A) - // malstep(7,8,9,A) - // If the first item from the list is a symbol and it's "unquote" -- that // malstep(7,8,9,A) - // is, (unquote item ignored...): // malstep(7,8,9,A) - // // malstep(7,8,9,A) - // Return: item // malstep(7,8,9,A) - // malstep(7,8,9,A) - let qq_list = as_sequence(qq_arg) // malstep(7,8,9,A) - if let sym = as_symbolQ(qq_list.first()) where sym == kSymbolUnquote { // malstep(7,8,9,A) - return qq_list.count >= 2 ? try! qq_list.nth(1) : make_nil() // malstep(7,8,9,A) - } // malstep(7,8,9,A) - // malstep(7,8,9,A) - // If the first item from the list is itself a non-empty list starting with // malstep(7,8,9,A) - // "splice-unquote"-- that is, ((splice-unquote item ignored...) rest...): // malstep(7,8,9,A) - // // malstep(7,8,9,A) - // Return: (concat item quasiquote(rest...)) // malstep(7,8,9,A) - // malstep(7,8,9,A) - if is_pair(qq_list.first()) { // malstep(7,8,9,A) - let qq_list_item0 = as_sequence(qq_list.first()) // malstep(7,8,9,A) - if let sym = as_symbolQ(qq_list_item0.first()) where sym == kSymbolSpliceUnquote { // malstep(7,8,9,A) - let result = try quasiquote(qq_list.rest()) // malstep(7,8,9,A) - return make_list_from(kValConcat, try! qq_list_item0.nth(1), result) // malstep(7,8,9,A) - } // malstep(7,8,9,A) - } // malstep(7,8,9,A) - // malstep(7,8,9,A) - // General case: (item rest...): // malstep(7,8,9,A) - // // malstep(7,8,9,A) - // Return: (cons (quasiquote item) (quasiquote (rest...)) // malstep(7,8,9,A) - // malstep(7,8,9,A) - let first = try quasiquote(qq_list.first()) // malstep(7,8,9,A) - let rest = try quasiquote(qq_list.rest()) // malstep(7,8,9,A) - return make_list_from(kValCons, first, rest) // malstep(7,8,9,A) -} // malstep(7,8,9,A) - // malstep(7,8,9,A) -// Perform a simple evaluation of the `ast` object. If it's a symbol, // malstep(2,3,4,5,6,7,8,9,A) -// dereference it and return its value. If it's a collection, call EVAL on all // malstep(2,3,4,5,6,7,8,9,A) -// elements (or just the values, in the case of the hashmap). Otherwise, return // malstep(2,3,4,5,6,7,8,9,A) -// the object unchanged. // malstep(2,3,4,5,6,7,8,9,A) -// // malstep(2,3,4,5,6,7,8,9,A) -private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { // malstep(2,3,4,5,6,7,8,9,A) - if let symbol = as_symbolQ(ast) { // malstep(2,3,4,5,6,7,8,9,A) - guard let val = env.get(symbol) else { // malstep(2,3,4,5,6,7,8,9,A) - try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - return val // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - if let list = as_listQ(ast) { // malstep(2,3,4,5,6,7,8,9,A) - var result = [MalVal]() // malstep(2,3,4,5,6,7,8,9,A) - result.reserveCapacity(Int(list.count)) // malstep(2,3,4,5,6,7,8,9,A) - for item in list { // malstep(2,3,4,5,6,7,8,9,A) - let eval = try EVAL(item, env) // malstep(2,3,4,5,6,7,8,9,A) - result.append(eval) // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - return make_list(result) // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - if let vec = as_vectorQ(ast) { // malstep(2,3,4,5,6,7,8,9,A) - var result = [MalVal]() // malstep(2,3,4,5,6,7,8,9,A) - result.reserveCapacity(Int(vec.count)) // malstep(2,3,4,5,6,7,8,9,A) - for item in vec { // malstep(2,3,4,5,6,7,8,9,A) - let eval = try EVAL(item, env) // malstep(2,3,4,5,6,7,8,9,A) - result.append(eval) // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - return make_vector(result) // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - if let hash = as_hashmapQ(ast) { // malstep(2,3,4,5,6,7,8,9,A) - var result = [MalVal]() // malstep(2,3,4,5,6,7,8,9,A) - result.reserveCapacity(Int(hash.count) * 2) // malstep(2,3,4,5,6,7,8,9,A) - for (k, v) in hash { // malstep(2,3,4,5,6,7,8,9,A) - let new_v = try EVAL(v, env) // malstep(2,3,4,5,6,7,8,9,A) - result.append(k) // malstep(2,3,4,5,6,7,8,9,A) - result.append(new_v) // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - return make_hashmap(result) // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - return ast // malstep(2,3,4,5,6,7,8,9,A) -} // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) -private enum TCOVal { // malstep(5,6,7,8,9,A) - case NoResult // malstep(5,6,7,8,9,A) - case Return(MalVal) // malstep(5,6,7,8,9,A) - case Continue(MalVal, Environment) // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) - init() { self = .NoResult } // malstep(5,6,7,8,9,A) - init(_ result: MalVal) { self = .Return(result) } // malstep(5,6,7,8,9,A) - init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } // malstep(5,6,7,8,9,A) -} // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) -// EVALuate "def!". // malstep(3,4,5,6,7) -// EVALuate "def!" and "defmacro!". // malstep(8,9,A) -// // malstep(3,4,5,6,7,8,9,A) -private func eval_def(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(3,4) -private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) - guard list.count == 3 else { // malstep(3,4,5,6,7,8,9,A) - try throw_error("expected 2 arguments to def!, got \(list.count - 1)") // malstep(3,4,5,6,7,8,9,A) - } // malstep(3,4,5,6,7,8,9,A) - let arg0 = try! list.nth(0) // malstep(8,9,A) - let arg1 = try! list.nth(1) // malstep(3,4,5,6,7,8,9,A) - let arg2 = try! list.nth(2) // malstep(3,4,5,6,7,8,9,A) - guard let sym = as_symbolQ(arg1) else { // malstep(3,4,5,6,7,8,9,A) - try throw_error("expected symbol for first argument to def!") // malstep(3,4,5,6,7,8,9,A) - } // malstep(3,4,5,6,7,8,9,A) - let value = try EVAL(arg2, env) // malstep(3,4,5,6,7) - var value = try EVAL(arg2, env) // malstep(8,9,A) - if as_symbol(arg0) == kSymbolDefMacro { // malstep(8,9,A) - guard let closure = as_closureQ(value) else { // malstep(8,9,A) - try throw_error("expected closure, got \(value)") // malstep(8,9,A) - } // malstep(8,9,A) - value = make_macro(closure) // malstep(8,9,A) - } // malstep(8,9,A) - return env.set(sym, value) // malstep(3,4) - return TCOVal(env.set(sym, value)) // malstep(5,6,7,8,9,A) -} // malstep(3,4,5,6,7,8,9,A) - // malstep(3,4,5,6,7,8,9,A) -// EVALuate "let*". // malstep(3,4,5,6,7,8,9,A) -// // malstep(3,4,5,6,7,8,9,A) -private func eval_let(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(3,4) -private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) - guard list.count == 3 else { // malstep(3,4,5,6,7,8,9,A) - try throw_error("expected 2 arguments to let*, got \(list.count - 1)") // malstep(3,4,5,6,7,8,9,A) - } // malstep(3,4,5,6,7,8,9,A) - let arg1 = try! list.nth(1) // malstep(3,4,5,6,7,8,9,A) - let arg2 = try! list.nth(2) // malstep(3,4,5,6,7,8,9,A) - guard let bindings = as_sequenceQ(arg1) else { // malstep(3,4,5,6,7,8,9,A) - try throw_error("expected list for first argument to let*") // malstep(3,4,5,6,7,8,9,A) - } // malstep(3,4,5,6,7,8,9,A) - guard bindings.count % 2 == 0 else { // malstep(3,4,5,6,7,8,9,A) - try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") // malstep(3,4,5,6,7,8,9,A) - } // malstep(3,4,5,6,7,8,9,A) - let new_env = Environment(outer: env) // malstep(3,4,5,6,7,8,9,A) - for var index: MalIntType = 0; index < bindings.count; index += 2 { // malstep(3,4,5,6,7,8,9,A) - let binding_name = try! bindings.nth(index) // malstep(3,4,5,6,7,8,9,A) - let binding_value = try! bindings.nth(index + 1) // malstep(3,4,5,6,7,8,9,A) - guard let binding_symbol = as_symbolQ(binding_name) else { // malstep(3,4,5,6,7,8,9,A) - try throw_error("expected symbol for first element in binding pair") // malstep(3,4,5,6,7,8,9,A) - } // malstep(3,4,5,6,7,8,9,A) - let evaluated_value = try EVAL(binding_value, new_env) // malstep(3,4,5,6,7,8,9,A) - new_env.set(binding_symbol, evaluated_value) // malstep(3,4,5,6,7,8,9,A) - } // malstep(3,4,5,6,7,8,9,A) - if TCO { // malstep(5,6,7,8,9,A) - return TCOVal(arg2, new_env) // malstep(5,6,7,8,9,A) - } // malstep(5,6,7,8,9,A) - return try EVAL(arg2, new_env) // malstep(3,4) - return TCOVal(try EVAL(arg2, new_env)) // malstep(5,6,7,8,9,A) -} // malstep(3,4,5,6,7,8,9,A) - // malstep(3,4,5,6,7,8,9,A) -// EVALuate "do". // malstep(4,5,6,7,8,9,A) -// // malstep(4,5,6,7,8,9,A) -private func eval_do(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(4) -private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) - if TCO { // malstep(5,6,7,8,9,A) - let _ = try eval_ast(list.range_from(1, to: list.count-1), env) // malstep(5,6,7,8,9,A) - return TCOVal(list.last(), env) // malstep(5,6,7,8,9,A) - } // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) - let evaluated_ast = try eval_ast(list.rest(), env) // malstep(4,5,6,7,8,9,A) - let evaluated_seq = as_sequence(evaluated_ast) // malstep(4,5,6,7,8,9,A) - return evaluated_seq.last() // malstep(4) - return TCOVal(evaluated_seq.last()) // malstep(5,6,7,8,9,A) -} // malstep(4,5,6,7,8,9,A) - // malstep(4,5,6,7,8,9,A) -// EVALuate "if". // malstep(4,5,6,7,8,9,A) -// // malstep(4,5,6,7,8,9,A) -private func eval_if(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(4) -private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) - guard list.count >= 3 else { // malstep(4,5,6,7,8,9,A) - try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") // malstep(4,5,6,7,8,9,A) - } // malstep(4,5,6,7,8,9,A) - let cond_result = try EVAL(try! list.nth(1), env) // malstep(4,5,6,7,8,9,A) - var new_ast: MalVal // malstep(4,5,6,7,8,9,A) - if is_truthy(cond_result) { // malstep(4,5,6,7,8,9,A) - new_ast = try! list.nth(2) // malstep(4,5,6,7,8,9,A) - } else if list.count == 4 { // malstep(4,5,6,7,8,9,A) - new_ast = try! list.nth(3) // malstep(4,5,6,7,8,9,A) - } else { // malstep(4,5,6,7,8,9,A) - return make_nil() // malstep(4) - return TCOVal(make_nil()) // malstep(5,6,7,8,9,A) - } // malstep(4,5,6,7,8,9,A) - if TCO { // malstep(5,6,7,8,9,A) - return TCOVal(new_ast, env) // malstep(5,6,7,8,9,A) - } // malstep(5,6,7,8,9,A) - return try EVAL(new_ast, env) // malstep(4) - return TCOVal(try EVAL(new_ast, env)) // malstep(5,6,7,8,9,A) -} // malstep(4,5,6,7,8,9,A) - // malstep(4,5,6,7,8,9,A) -// EVALuate "fn*". // malstep(4,5,6,7,8,9,A) -// // malstep(4,5,6,7,8,9,A) -private func eval_fn(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(4) -private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) - guard list.count == 3 else { // malstep(4,5,6,7,8,9,A) - try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") // malstep(4,5,6,7,8,9,A) - } // malstep(4,5,6,7,8,9,A) - guard let seq = as_sequenceQ(try! list.nth(1)) else { // malstep(4,5,6,7,8,9,A) - try throw_error("expected list or vector for first argument to fn*") // malstep(4,5,6,7,8,9,A) - } // malstep(4,5,6,7,8,9,A) - return make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env)) // malstep(4) - return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) // malstep(5,6,7,8,9,A) -} // malstep(4,5,6,7,8,9,A) - // malstep(4,5,6,7,8,9,A) -// EVALuate "quote". // malstep(7,8,9,A) -// // malstep(7,8,9,A) -private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(7,8,9,A) - if list.count >= 2 { // malstep(7,8,9,A) - return TCOVal(try! list.nth(1)) // malstep(7,8,9,A) - } // malstep(7,8,9,A) - return TCOVal(make_nil()) // malstep(7,8,9,A) -} // malstep(7,8,9,A) - // malstep(7,8,9,A) -// EVALuate "quasiquote". // malstep(7,8,9,A) -// // malstep(7,8,9,A) -private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(7,8,9,A) - guard list.count >= 2 else { // malstep(7,8,9,A) - try throw_error("Expected non-nil parameter to 'quasiquote'") // malstep(7,8,9,A) - } // malstep(7,8,9,A) - if TCO { // malstep(7,8,9,A) - return TCOVal(try quasiquote(try! list.nth(1)), env) // malstep(7,8,9,A) - } // malstep(7,8,9,A) - return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) // malstep(7,8,9,A) -} // malstep(7,8,9,A) - // malstep(7,8,9,A) -// EVALuate "macroexpand". // malstep(8,9,A) -// // malstep(8,9,A) -private func eval_macroexpand(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(8,9,A) - guard list.count >= 2 else { // malstep(8,9,A) - try throw_error("Expected parameter to 'macroexpand'") // malstep(8,9,A) - } // malstep(8,9,A) - return TCOVal(try macroexpand(try! list.nth(1), env)) // malstep(8,9,A) -} // malstep(8,9,A) - // malstep(8,9,A) -// EVALuate "try*" (and "catch*"). // malstep(9,A) -// // malstep(9,A) -private func eval_try(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(9,A) - // This is a subset of the Clojure try/catch: // malstep(9,A) - // // malstep(9,A) - // (try* expr (catch exception-name expr)) // malstep(9,A) - // malstep(9,A) - guard list.count >= 2 else { // malstep(9,A) - try throw_error("try*: no body parameter") // malstep(9,A) - } // malstep(9,A) - // malstep(9,A) - do { // malstep(9,A) - return TCOVal(try EVAL(try! list.nth(1), env)) // malstep(9,A) - } catch let error as MalException { // malstep(9,A) - guard list.count >= 3, // malstep(9,A) - let catch_list = as_sequenceQ(try! list.nth(2)) where catch_list.count >= 3, // malstep(9,A) - let _ = as_symbolQ(try! catch_list.nth(0)) else // malstep(9,A) - { // malstep(9,A) - throw error // No catch parameter // malstep(9,A) - } // malstep(9,A) - let catch_name = try! catch_list.nth(1) // malstep(9,A) - let catch_expr = try! catch_list.nth(2) // malstep(9,A) - let catch_env = Environment(outer: env) // malstep(9,A) - try catch_env.set_bindings(as_sequence(make_list_from(catch_name)), // malstep(9,A) - with_exprs: as_sequence(make_list_from(error.exception))) // malstep(9,A) - return TCOVal(try EVAL(catch_expr, catch_env)) // malstep(9,A) - } // malstep(9,A) -} // malstep(9,A) - // malstep(9,A) -// -// >>> NOTE: There are several versions of the EVAL function. One is used in -// >>> step 0, one is used in step 1, and a final one is used in step 2 and all -// >>> subsequent versions. This final version is extended throughout the -// >>> project through the addition of functionality. -// - -// Walk the AST and completely evaluate it, handling macro expansions, special // malstep(0,1,2,3,4,5,6,7,8,9,A) -// forms and function calls. // malstep(0,1,2,3,4,5,6,7,8,9,A) -// // malstep(0,1,2,3,4,5,6,7,8,9,A) -private func EVAL(ast: String) -> String { // malstep(0) - return ast // malstep(0) -} // malstep(0) -private func EVAL(ast: MalVal) -> MalVal { // malstep(1) - return ast // malstep(1) -} // malstep(1) -private func EVAL(ast: MalVal, _ env: Environment) throws -> MalVal { // malstep(2,3,4) -private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { // malstep(5,6,7,8,9,A) - EVAL_level++ // malstep(5,6,7,8,9,A) - defer { EVAL_level-- } // malstep(5,6,7,8,9,A) - guard EVAL_level <= EVAL_leval_max else { // malstep(5,6,7,8,9,A) - try throw_error("Recursing too many levels (> \(EVAL_leval_max))") // malstep(5,6,7,8,9,A) - } // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) - if DEBUG_EVAL { // malstep(5,6,7,8,9,A) - indent = substring(INDENT_TEMPLATE, 0, EVAL_level) // malstep(5,6,7,8,9,A) - } // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) - while true { // malstep(5,6,7,8,9,A) - if DEBUG_EVAL { print("\(indent)> \(ast)") } // malstep(5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - if !is_list(ast) { // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - // Not a list -- just evaluate and return. // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - let answer = try eval_ast(ast, env) // malstep(2,3,4,5,6,7,8,9,A) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } // malstep(5,6,7,8,9,A) - return answer // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - // Special handling if it's a list. // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - let list = as_list(ast) // malstep(2,3,4,5,6,7) - var list = as_list(ast) // malstep(8,9,A) - ast = try macroexpand(ast, env) // malstep(8,9,A) - if !is_list(ast) { // malstep(8,9,A) - // malstep(8,9,A) - // Not a list -- just evaluate and return. // malstep(8,9,A) - // malstep(8,9,A) - let answer = try eval_ast(ast, env) // malstep(8,9,A) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } // malstep(8,9,A) - return answer // malstep(8,9,A) - } // malstep(8,9,A) - list = as_list(ast) // malstep(8,9,A) - // malstep(8,9,A) - if DEBUG_EVAL { print("\(indent)>. \(list)") } // malstep(5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - if list.isEmpty { // malstep(2,3,4,5,6,7,8,9,A) - return ast // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - // Check for special forms, where we want to check the operation // malstep(3,4,5,6,7,8,9,A) - // before evaluating all of the parameters. // malstep(3,4,5,6,7,8,9,A) - // malstep(3,4,5,6,7,8,9,A) - let arg0 = list.first() // malstep(3,4,5,6,7,8,9,A) - if let fn_symbol = as_symbolQ(arg0) { // malstep(3,4,5,6,7,8,9,A) - let res: TCOVal // malstep(5,6,7,8,9,A) - // malstep(3,4,5,6,7,8,9,A) - switch fn_symbol { // malstep(3,4,5,6,7,8,9,A) - case kSymbolDef: return try eval_def(list, env) // malstep(3,4) - case kSymbolDef: res = try eval_def(list, env) // malstep(5,6,7,8,9,A) - case kSymbolDefMacro: res = try eval_def(list, env) // malstep(8,9,A) - case kSymbolLet: return try eval_let(list, env) // malstep(3,4) - case kSymbolLet: res = try eval_let(list, env) // malstep(5,6,7,8,9,A) - case kSymbolDo: return try eval_do(list, env) // malstep(4) - case kSymbolDo: res = try eval_do(list, env) // malstep(5,6,7,8,9,A) - case kSymbolIf: return try eval_if(list, env) // malstep(4) - case kSymbolIf: res = try eval_if(list, env) // malstep(5,6,7,8,9,A) - case kSymbolFn: return try eval_fn(list, env) // malstep(4) - case kSymbolFn: res = try eval_fn(list, env) // malstep(5,6,7,8,9,A) - case kSymbolQuote: res = try eval_quote(list, env) // malstep(7,8,9,A) - case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) // malstep(7,8,9,A) - case kSymbolMacroExpand: res = try eval_macroexpand(list, env) // malstep(8,9,A) - case kSymbolTry: res = try eval_try(list, env) // malstep(9,A) - default: break // malstep(3,4) - default: res = TCOVal() // malstep(5,6,7,8,9,A) - } // malstep(3,4,5,6,7,8,9,A) - switch res { // malstep(5,6,7,8,9,A) - case let .Return(result): return result // malstep(5,6,7,8,9,A) - case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue // malstep(5,6,7,8,9,A) - case .NoResult: break // malstep(5,6,7,8,9,A) - } // malstep(5,6,7,8,9,A) - } // malstep(3,4,5,6,7,8,9,A) - // malstep(3,4,5,6,7,8,9,A) - // Standard list to be applied. Evaluate all the elements first. // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - let eval = try eval_ast(ast, env) // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - // The result had better be a list and better be non-empty. // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - let eval_list = as_list(eval) // malstep(2,3,4,5,6,7,8,9,A) - if eval_list.isEmpty { // malstep(2,3,4,5,6,7,8,9,A) - return eval // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - if DEBUG_EVAL { print("\(indent)>> \(eval)") } // malstep(5,6,7,8,9,A) - // malstep(5,6,7,8,9,A) - // Get the first element of the list and execute it. // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - let first = eval_list.first() // malstep(2,3,4,5,6,7,8,9,A) - let rest = as_sequence(eval_list.rest()) // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - if let fn = as_builtinQ(first) { // malstep(2,3,4,5,6,7,8,9,A) - let answer = try fn.apply(rest) // malstep(2,3,4,5,6,7,8,9,A) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } // malstep(5,6,7,8,9,A) - return answer // malstep(2,3,4,5,6,7,8,9,A) - } else if let fn = as_closureQ(first) { // malstep(4,5,6,7,8,9,A) - let new_env = Environment(outer: fn.env) // malstep(4,5,6,7,8,9,A) - let _ = try new_env.set_bindings(fn.args, with_exprs: rest) // malstep(4,5,6,7,8,9,A) - if TCO { // malstep(5,6,7,8,9,A) - env = new_env // malstep(5,6,7,8,9,A) - ast = fn.body // malstep(5,6,7,8,9,A) - continue // malstep(5,6,7,8,9,A) - } // malstep(5,6,7,8,9,A) - let answer = try EVAL(fn.body, new_env) // malstep(4,5,6,7,8,9,A) - if DEBUG_EVAL { print("\(indent)>>> \(answer)") } // malstep(5,6,7,8,9,A) - return answer // malstep(4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - // The first element wasn't a function to be executed. Return an // malstep(2,3,4,5,6,7,8,9,A) - // error saying so. // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - try throw_error("first list item does not evaluate to a function: \(first)") // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(5,6,7,8,9,A) -} // malstep(2,3,4,5,6,7,8,9,A) - // malstep(0,1,2,3,4,5,6,7,8,9,A) -// Convert the value into a human-readable string for printing. // malstep(0,1,2,3,4,5,6,7,8,9,A) -// // malstep(0,1,2,3,4,5,6,7,8,9,A) -private func PRINT(exp: String) -> String { // malstep(0) - return exp // malstep(0) -} // malstep(0) -private func PRINT(exp: MalVal) -> String { // malstep(1,2,3,4,5,6,7,8,9,A) - return pr_str(exp, true) // malstep(1,2,3,4,5,6,7,8,9,A) -} // malstep(1,2,3,4,5,6,7,8,9,A) - // malstep(0,1,2,3,4,5,6,7,8,9,A) -// -// >>> NOTE: The following function has several versions. Also note that the -// >>> call to EVAL comes in two flavors. -// - -// Perform the READ and EVAL steps. Useful for when you don't care about the // malstep(0,1,2,3,4,5,6,7,8,9,A) -// printable result. // malstep(0,1,2,3,4,5,6,7,8,9,A) -// // malstep(0,1,2,3,4,5,6,7,8,9,A) -private func RE(text: String) -> String { // malstep(0) - let ast = READ(text) // malstep(0) - let exp = EVAL(ast) // malstep(0) - return exp // malstep(0) -} // malstep(0) -private func RE(text: String) -> MalVal? { // malstep(1) -private func RE(text: String, _ env: Environment) -> MalVal? { // malstep(2,3,4,5,6,7,8,9,A) - if !text.isEmpty { // malstep(1,2,3,4,5,6,7,8,9,A) - do { // malstep(1,2,3,4,5,6,7,8,9,A) - let ast = try READ(text) // malstep(1,2,3,4,5,6,7,8,9,A) - do { // malstep(2,3,4,5,6,7,8,9,A) - return EVAL(ast) // malstep(1) - return try EVAL(ast, env) // malstep(2,3,4,5,6,7,8,9,A) - } catch let error as MalException { // malstep(2,3,4,5,6,7,8,9,A) - print("Error evaluating input: \(error)") // malstep(2,3,4,5,6,7,8,9,A) - } catch { // malstep(2,3,4,5,6,7,8,9,A) - print("Error evaluating input: \(error)") // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - } catch let error as MalException { // malstep(1,2,3,4,5,6,7,8,9,A) - print("Error parsing input: \(error)") // malstep(1,2,3,4,5,6,7,8,9,A) - } catch { // malstep(1,2,3,4,5,6,7,8,9,A) - print("Error parsing input: \(error)") // malstep(1,2,3,4,5,6,7,8,9,A) - } // malstep(1,2,3,4,5,6,7,8,9,A) - } // malstep(1,2,3,4,5,6,7,8,9,A) - return nil // malstep(1,2,3,4,5,6,7,8,9,A) -} // malstep(1,2,3,4,5,6,7,8,9,A) - // malstep(0,1,2,3,4,5,6,7,8,9,A) -// -// >>> NOTE: The following function has several versions. -// - -// Perform the full READ/EVAL/PRINT, returning a printable string. // malstep(0,1,2,3,4,5,6,7,8,9,A) -// // malstep(0,1,2,3,4,5,6,7,8,9,A) -private func REP(text: String) -> String { // malstep(0) - let exp = RE(text) // malstep(0) - return PRINT(exp) // malstep(0) -} // malstep(0) -private func REP(text: String) -> String? { // malstep(1) - let exp = RE(text) // malstep(1) - if exp == nil { return nil } // malstep(1) - return PRINT(exp!) // malstep(1) -} // malstep(1) -private func REP(text: String, _ env: Environment) -> String? { // malstep(2,3,4,5,6,7,8,9,A) - let exp = RE(text, env) // malstep(2,3,4,5,6,7,8,9,A) - if exp == nil { return nil } // malstep(2,3,4,5,6,7,8,9,A) - return PRINT(exp!) // malstep(2,3,4,5,6,7,8,9,A) -} // malstep(2,3,4,5,6,7,8,9,A) - // malstep(0,1,2,3,4,5,6,7,8,9,A) -// -// >>> NOTE: The following function has several versions. -// - -// Perform the full REPL. // malstep(0,1,2,3,4,5,6,7,8,9,A) -// // malstep(0,1,2,3,4,5,6,7,8,9,A) -private func REPL() { // malstep(0) - while true { // malstep(0) - if let text = _readline("user> ") { // malstep(0) - print("\(REP(text))") // malstep(0) - } else { // malstep(0) - print("") // malstep(0) - break // malstep(0) - } // malstep(0) - } // malstep(0) -} // malstep(0) -private func REPL() { // malstep(1) - while true { // malstep(1) - if let text = _readline("user> ") { // malstep(1) - if let output = REP(text) { // malstep(1) - print("\(output)") // malstep(1) - } // malstep(1) - } else { // malstep(1) - print("") // malstep(1) - break // malstep(1) - } // malstep(1) - } // malstep(1) -} // malstep(1) -private func REPL(env: Environment) { // malstep(2,3,4,5,6,7,8,9,A) - while true { // malstep(2,3,4,5,6,7,8,9,A) - if let text = _readline("user> ") { // malstep(2,3,4,5,6,7,8,9,A) - if let output = REP(text, env) { // malstep(2,3,4,5,6,7,8,9,A) - print("\(output)") // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - } else { // malstep(2,3,4,5,6,7,8,9,A) - print("") // malstep(2,3,4,5,6,7,8,9,A) - break // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) - } // malstep(2,3,4,5,6,7,8,9,A) -} // malstep(2,3,4,5,6,7,8,9,A) - // malstep(0,1,2,3,4,5,6,7,8,9,A) -// Process any command line arguments. Any trailing arguments are incorporated // malstep(6,7,8,9,A) -// into the environment. Any argument immediately after the process name is // malstep(6,7,8,9,A) -// taken as a script to execute. If one exists, it is executed in lieu of // malstep(6,7,8,9,A) -// running the REPL. // malstep(6,7,8,9,A) -// // malstep(6,7,8,9,A) -private func process_command_line(args: [String], _ env: Environment) -> Bool { // malstep(6,7,8,9,A) - var argv = make_list() // malstep(6,7,8,9,A) - if args.count > 2 { // malstep(6,7,8,9,A) - let args1 = args[2.. 1 { // malstep(6,7,8,9,A) - RE("(load-file \"\(args[1])\")", env) // malstep(6,7,8,9,A) - return false // malstep(6,7,8,9,A) - } // malstep(6,7,8,9,A) - // malstep(6,7,8,9,A) - return true // malstep(6,7,8,9,A) -} // malstep(6,7,8,9,A) - // malstep(6,7,8,9,A) -func main() { // malstep(0,1,2,3,4,5,6,7,8,9,A) - let env = Environment(outer: nil) // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - load_history_file() // malstep(0,1,2,3,4,5,6,7,8,9,A) - load_builtins(env) // malstep(2,3,4,5,6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - RE("(def! *host-language* \"swift\")", env) // malstep(A) - RE("(def! not (fn* (a) (if a false true)))", env) // malstep(4,5,6,7,8,9,A) - RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env) // malstep(6,7,8,9,A) - RE("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) " + // malstep(8,9,A) - "(throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", env) // malstep(8,9,A) - RE("(def! inc (fn* [x] (+ x 1)))", env) // malstep(A) - RE("(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str \"G__\" (swap! counter inc))))))", env) // malstep(A) - RE("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) " + // malstep(8,9,A) - "`(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", env) // malstep(8,9) - "(let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))", env) // malstep(A) - // malstep(6,7,8,9,A) - env.set(kSymbolEval, make_builtin({ // malstep(6,7,8,9,A) - try! unwrap_args($0) { // malstep(6,7,8,9,A) - (ast: MalVal) -> MalVal in // malstep(6,7,8,9,A) - try EVAL(ast, env) // malstep(6,7,8,9,A) - } // malstep(6,7,8,9,A) - })) // malstep(6,7,8,9,A) - // malstep(6,7,8,9,A) -// -// >>> NOTE: The call to REPL() is managed in three different ways. First, we -// >>> just call it with no parameters. Second, we call it with an "env" -// >>> parameter. Finally, we call it only if there is no program on the -// >>> command line to execute. -// - REPL() // malstep(0,1) - REPL(env) // malstep(2,3,4,5) - if process_command_line(Process.arguments, env) { // malstep(6,7,8,9,A) - RE("(println (str \"Mal [\" *host-language*\"]\"))", env) // malstep(A) - REPL(env) // malstep(6,7,8,9,A) - } // malstep(6,7,8,9,A) - // malstep(2,3,4,5,6,7,8,9,A) - save_history_file() // malstep(0,1,2,3,4,5,6,7,8,9,A) -} // malstep(0,1,2,3,4,5,6,7,8,9,A) +//****************************************************************************** +// +// This file is used to generate the various "step" files, which in turn are +// used to create the various step executables. +// +// For the most part, this file is the final step file, with each line annotated +// with information that says in which step the line is introduced into the +// project. A simple filter program scans this template file, pulling out the +// lines required for a specified step. +// +// Ideally, after each line is included in a project, it stays in the project. +// This would make each step file a proper superset of the previous steps files. +// However, such idealism cannot be realized. There are cases where lines +// introduced in early step files need to be removed or replaced with new +// version. +// +// When this happens, multiple versions of a particular line can appear in the +// file. For example, consider the READ function. Early in the project, it is +// introduced as: +// +// func READ(str: String) -> String { +// return str +// } +// +// However, it is replaced in a subsequent step with: +// +// func READ(str: String) -> MalVal { +// return read_str(str) +// } +// +// To support both forms, both are included in this template file. The first is +// annotated to say that it appears in step 0 and *only* in step 0. The second +// is annotated to say that it appears in step 1 and in all subsequent versions. +// +// Where possible, in the interests for clarity, where lines are introduced and +// replaced, the entire function that is affected is introduced and replaced. +// This is as opposed to trying to surgically identify the line-by-line changes +// within a function that need to be replaced. +// +// However, in other cases, the surgical line-by-line replacement of text is +// employed. This is done in cases where the number of lines to change is small +// compared to the overall size of the function. +// +// Places where previously-introduced lines are changed or removed are marked +// with a ">>> NOTE:" comment. +// +// Lines with no annotations (like those comprising this comment block) are +// never included in any output. +// +//****************************************************************************** + +//****************************************************************************** // malstep(0,1,2,3,4,5,6,7,8,9,A) +// MAL - step 0 - repl // malstep(0) +// MAL - step 1 - read/print // malstep(1) +// MAL - step 2 - eval // malstep(2) +// MAL - step 3 - env // malstep(3) +// MAL - step 4 - if/fn/do // malstep(4) +// MAL - step 5 - tco // malstep(5) +// MAL - step 6 - file // malstep(6) +// MAL - step 7 - quote // malstep(7) +// MAL - step 8 - macros // malstep(8) +// MAL - step 9 - try // malstep(9) +// MAL - step A - mal // malstep(A) +//****************************************************************************** // malstep(0,1,2,3,4,5,6,7,8,9,A) +// This file is automatically generated from templates/step.swift. Rather than // malstep(0,1,2,3,4,5,6,7,8,9,A) +// editing it directly, it's probably better to edit templates/step.swift and // malstep(0,1,2,3,4,5,6,7,8,9,A) +// regenerate this file. Otherwise, your change might be lost if/when someone // malstep(0,1,2,3,4,5,6,7,8,9,A) +// else performs that process. // malstep(0,1,2,3,4,5,6,7,8,9,A) +//****************************************************************************** // malstep(0,1,2,3,4,5,6,7,8,9,A) + // malstep(0,1,2,3,4,5,6,7,8,9,A) +import Foundation // malstep(0,1,2,3,4,5,6,7,8,9,A) + // malstep(0,1,2,3,4,5,6,7,8,9,A) +// The number of times EVAL has been entered recursively. We keep track of this // malstep(5,6,7,8,9,A) +// so that we can protect against overrunning the stack. // malstep(5,6,7,8,9,A) +// // malstep(5,6,7,8,9,A) +private var EVAL_level = 0 // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) +// The maximum number of times we let EVAL recurse before throwing an exception. // malstep(5,6,7,8,9,A) +// Testing puts this at some place between 1800 and 1900. Let's keep it at 500 // malstep(5,6,7,8,9,A) +// for safety's sake. // malstep(5,6,7,8,9,A) +// // malstep(5,6,7,8,9,A) +private let EVAL_leval_max = 500 // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) +// Control whether or not tail-call optimization (TCO) is enabled. We want it // malstep(5,6,7,8,9,A) +// `true` most of the time, but may disable it for debugging purposes (it's // malstep(5,6,7,8,9,A) +// easier to get a meaningful backtrace that way). // malstep(5,6,7,8,9,A) +// // malstep(5,6,7,8,9,A) +private let TCO = true // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) +// Control whether or not we emit debugging statements in EVAL. // malstep(5,6,7,8,9,A) +// // malstep(5,6,7,8,9,A) +private let DEBUG_EVAL = false // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) +// String used to prefix information logged in EVAL. Increasing lengths of the // malstep(5,6,7,8,9,A) +// string are used the more EVAL is recursed. // malstep(5,6,7,8,9,A) +// // malstep(5,6,7,8,9,A) +private let INDENT_TEMPLATE = "|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" + // malstep(5,6,7,8,9,A) + "----|----|----|----|----|----|----|----|----|----|----|" // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) +// Holds the prefix of INDENT_TEMPLATE used for actual logging. // malstep(5,6,7,8,9,A) +// // malstep(5,6,7,8,9,A) +private var indent = String() // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) +// Symbols used in this module. // malstep(3,4,5,6,7,8,9,A) +// // malstep(3,4,5,6,7,8,9,A) +private let kValArgv = make_symbol("*ARGV*") // malstep(6,7,8,9,A) +private let kValCatch = make_symbol("catch*") // malstep(9,A) +private let kValConcat = make_symbol("concat") // malstep(7,8,9,A) +private let kValCons = make_symbol("cons") // malstep(7,8,9,A) +private let kValDef = make_symbol("def!") // malstep(3,4,5,6,7,8,9,A) +private let kValDefMacro = make_symbol("defmacro!") // malstep(8,9,A) +private let kValDo = make_symbol("do") // malstep(4,5,6,7,8,9,A) +private let kValEval = make_symbol("eval") // malstep(6,7,8,9,A) +private let kValFn = make_symbol("fn*") // malstep(4,5,6,7,8,9,A) +private let kValIf = make_symbol("if") // malstep(4,5,6,7,8,9,A) +private let kValLet = make_symbol("let*") // malstep(3,4,5,6,7,8,9,A) +private let kValMacroExpand = make_symbol("macroexpand") // malstep(8,9,A) +private let kValQuasiQuote = make_symbol("quasiquote") // malstep(7,8,9,A) +private let kValQuote = make_symbol("quote") // malstep(7,8,9,A) +private let kValSpliceUnquote = make_symbol("splice-unquote") // malstep(7,8,9,A) +private let kValUnquote = make_symbol("unquote") // malstep(7,8,9,A) +private let kValTry = make_symbol("try*") // malstep(3,4,5,6,7,8,9,A) + // malstep(3,4,5,6,7,8,9,A) +private let kSymbolArgv = as_symbol(kValArgv) // malstep(6,7,8,9,A) +private let kSymbolCatch = as_symbol(kValCatch) // malstep(9,A) +private let kSymbolConcat = as_symbol(kValConcat) // malstep(7,8,9,A) +private let kSymbolCons = as_symbol(kValCons) // malstep(7,8,9,A) +private let kSymbolDef = as_symbol(kValDef) // malstep(3,4,5,6,7,8,9,A) +private let kSymbolDefMacro = as_symbol(kValDefMacro) // malstep(8,9,A) +private let kSymbolDo = as_symbol(kValDo) // malstep(4,5,6,7,8,9,A) +private let kSymbolEval = as_symbol(kValEval) // malstep(6,7,8,9,A) +private let kSymbolFn = as_symbol(kValFn) // malstep(4,5,6,7,8,9,A) +private let kSymbolIf = as_symbol(kValIf) // malstep(4,5,6,7,8,9,A) +private let kSymbolLet = as_symbol(kValLet) // malstep(3,4,5,6,7,8,9,A) +private let kSymbolMacroExpand = as_symbol(kValMacroExpand) // malstep(8,9,A) +private let kSymbolQuasiQuote = as_symbol(kValQuasiQuote) // malstep(7,8,9,A) +private let kSymbolQuote = as_symbol(kValQuote) // malstep(7,8,9,A) +private let kSymbolSpliceUnquote = as_symbol(kValSpliceUnquote) // malstep(7,8,9,A) +private let kSymbolUnquote = as_symbol(kValUnquote) // malstep(7,8,9,A) +private let kSymbolTry = as_symbol(kValTry) // malstep(9,A) + // malstep(3,4,5,6,7,8,9,A) +func substring(s: String, _ begin: Int, _ end: Int) -> String { // malstep(5,6,7,8,9,A) + return s[s.startIndex.advancedBy(begin) ..< s.startIndex.advancedBy(end)] // malstep(5,6,7,8,9,A) +} // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) +// +// >>> NOTE: There are two versions of the following function: one used in step +// >>> 0 and one used in all subsequent versions. +// + +// Parse the string into an AST. // malstep(0,1,2,3,4,5,6,7,8,9,A) +// // malstep(0,1,2,3,4,5,6,7,8,9,A) +private func READ(str: String) -> String { // malstep(0) + return str // malstep(0) +} // malstep(0) +private func READ(str: String) throws -> MalVal { // malstep(1,2,3,4,5,6,7,8,9,A) + return try read_str(str) // malstep(1,2,3,4,5,6,7,8,9,A) +} // malstep(1,2,3,4,5,6,7,8,9,A) + // malstep(0,1,2,3,4,5,6,7,8,9,A) +// Return whether or not `val` is a non-empty list. // malstep(7,8,9,A) +// // malstep(7,8,9,A) +private func is_pair(val: MalVal) -> Bool { // malstep(7,8,9,A) + if let seq = as_sequenceQ(val) { // malstep(7,8,9,A) + return !seq.isEmpty // malstep(7,8,9,A) + } // malstep(7,8,9,A) + return false // malstep(7,8,9,A) +} // malstep(7,8,9,A) + // malstep(7,8,9,A) +// Expand macros for as long as the expression looks like a macro invocation. // malstep(8,9,A) +// // malstep(8,9,A) +private func macroexpand(var ast: MalVal, _ env: Environment) throws -> MalVal { // malstep(8,9,A) + while true { // malstep(8,9,A) + if let ast_as_list = as_listQ(ast) where !ast_as_list.isEmpty, // malstep(8,9,A) + let macro_name = as_symbolQ(ast_as_list.first()), // malstep(8,9,A) + let obj = env.get(macro_name), // malstep(8,9,A) + let macro = as_macroQ(obj) // malstep(8,9,A) + { // malstep(8,9,A) + let new_env = Environment(outer: macro.env) // malstep(8,9,A) + let rest = as_sequence(ast_as_list.rest()) // malstep(8,9,A) + let _ = try new_env.set_bindings(macro.args, with_exprs: rest) // malstep(8,9,A) + ast = try EVAL(macro.body, new_env) // malstep(8,9,A) + continue // malstep(8,9,A) + } // malstep(8,9,A) + return ast // malstep(8,9,A) + } // malstep(8,9,A) +} // malstep(8,9,A) + // malstep(8,9,A) +// Evaluate `quasiquote`, possibly recursing in the process. // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// As with quote, unquote, and splice-unquote, quasiquote takes a single // malstep(7,8,9,A) +// parameter, typically a list. In the general case, this list is processed // malstep(7,8,9,A) +// recursively as: // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// (quasiquote (first rest...)) -> (cons (quasiquote first) (quasiquote rest)) // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// In the processing of the parameter passed to it, quasiquote handles three // malstep(7,8,9,A) +// special cases: // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// * If the parameter is an atom or an empty list, the following expression // malstep(7,8,9,A) +// is formed and returned for evaluation: // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// (quasiquote atom-or-empty-list) -> (quote atom-or-empty-list) // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// * If the first element of the non-empty list is the symbol "unquote" // malstep(7,8,9,A) +// followed by a second item, the second item is returned as-is: // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// (quasiquote (unquote fred)) -> fred // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// * If the first element of the non-empty list is another list containing // malstep(7,8,9,A) +// the symbol "splice-unquote" followed by a list, that list is catenated // malstep(7,8,9,A) +// with the quasiquoted result of the remaining items in the non-empty // malstep(7,8,9,A) +// parent list: // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// (quasiquote (splice-unquote list) rest...) -> (items-from-list items-from-quasiquote(rest...)) // malstep(7,8,9,A) +// // malstep(7,8,9,A) +// Note the inconsistent handling between "quote" and "splice-quote". The former // malstep(7,8,9,A) +// is handled when this function is handed a list that starts with "quote", // malstep(7,8,9,A) +// whereas the latter is handled when this function is handled a list whose // malstep(7,8,9,A) +// first element is a list that starts with "splice-quote". The handling of the // malstep(7,8,9,A) +// latter is forced by the need to incorporate the results of (splice-quote // malstep(7,8,9,A) +// list) with the remaining items of the list containing that splice-quote // malstep(7,8,9,A) +// expression. However, it's not clear to me why the handling of "unquote" is // malstep(7,8,9,A) +// not handled similarly, for consistency's sake. // malstep(7,8,9,A) +// // malstep(7,8,9,A) +private func quasiquote(qq_arg: MalVal) throws -> MalVal { // malstep(7,8,9,A) + // malstep(7,8,9,A) + // If the argument is an atom or empty list: // malstep(7,8,9,A) + // // malstep(7,8,9,A) + // Return: (quote ) // malstep(7,8,9,A) + // malstep(7,8,9,A) + if !is_pair(qq_arg) { // malstep(7,8,9,A) + return make_list_from(kValQuote, qq_arg) // malstep(7,8,9,A) + } // malstep(7,8,9,A) + // malstep(7,8,9,A) + // The argument is a non-empty list -- that is (item rest...) // malstep(7,8,9,A) + // malstep(7,8,9,A) + // If the first item from the list is a symbol and it's "unquote" -- that // malstep(7,8,9,A) + // is, (unquote item ignored...): // malstep(7,8,9,A) + // // malstep(7,8,9,A) + // Return: item // malstep(7,8,9,A) + // malstep(7,8,9,A) + let qq_list = as_sequence(qq_arg) // malstep(7,8,9,A) + if let sym = as_symbolQ(qq_list.first()) where sym == kSymbolUnquote { // malstep(7,8,9,A) + return qq_list.count >= 2 ? try! qq_list.nth(1) : make_nil() // malstep(7,8,9,A) + } // malstep(7,8,9,A) + // malstep(7,8,9,A) + // If the first item from the list is itself a non-empty list starting with // malstep(7,8,9,A) + // "splice-unquote"-- that is, ((splice-unquote item ignored...) rest...): // malstep(7,8,9,A) + // // malstep(7,8,9,A) + // Return: (concat item quasiquote(rest...)) // malstep(7,8,9,A) + // malstep(7,8,9,A) + if is_pair(qq_list.first()) { // malstep(7,8,9,A) + let qq_list_item0 = as_sequence(qq_list.first()) // malstep(7,8,9,A) + if let sym = as_symbolQ(qq_list_item0.first()) where sym == kSymbolSpliceUnquote { // malstep(7,8,9,A) + let result = try quasiquote(qq_list.rest()) // malstep(7,8,9,A) + return make_list_from(kValConcat, try! qq_list_item0.nth(1), result) // malstep(7,8,9,A) + } // malstep(7,8,9,A) + } // malstep(7,8,9,A) + // malstep(7,8,9,A) + // General case: (item rest...): // malstep(7,8,9,A) + // // malstep(7,8,9,A) + // Return: (cons (quasiquote item) (quasiquote (rest...)) // malstep(7,8,9,A) + // malstep(7,8,9,A) + let first = try quasiquote(qq_list.first()) // malstep(7,8,9,A) + let rest = try quasiquote(qq_list.rest()) // malstep(7,8,9,A) + return make_list_from(kValCons, first, rest) // malstep(7,8,9,A) +} // malstep(7,8,9,A) + // malstep(7,8,9,A) +// Perform a simple evaluation of the `ast` object. If it's a symbol, // malstep(2,3,4,5,6,7,8,9,A) +// dereference it and return its value. If it's a collection, call EVAL on all // malstep(2,3,4,5,6,7,8,9,A) +// elements (or just the values, in the case of the hashmap). Otherwise, return // malstep(2,3,4,5,6,7,8,9,A) +// the object unchanged. // malstep(2,3,4,5,6,7,8,9,A) +// // malstep(2,3,4,5,6,7,8,9,A) +private func eval_ast(ast: MalVal, _ env: Environment) throws -> MalVal { // malstep(2,3,4,5,6,7,8,9,A) + if let symbol = as_symbolQ(ast) { // malstep(2,3,4,5,6,7,8,9,A) + guard let val = env.get(symbol) else { // malstep(2,3,4,5,6,7,8,9,A) + try throw_error("'\(symbol)' not found") // Specific text needed to match MAL unit tests // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + return val // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + if let list = as_listQ(ast) { // malstep(2,3,4,5,6,7,8,9,A) + var result = [MalVal]() // malstep(2,3,4,5,6,7,8,9,A) + result.reserveCapacity(Int(list.count)) // malstep(2,3,4,5,6,7,8,9,A) + for item in list { // malstep(2,3,4,5,6,7,8,9,A) + let eval = try EVAL(item, env) // malstep(2,3,4,5,6,7,8,9,A) + result.append(eval) // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + return make_list(result) // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + if let vec = as_vectorQ(ast) { // malstep(2,3,4,5,6,7,8,9,A) + var result = [MalVal]() // malstep(2,3,4,5,6,7,8,9,A) + result.reserveCapacity(Int(vec.count)) // malstep(2,3,4,5,6,7,8,9,A) + for item in vec { // malstep(2,3,4,5,6,7,8,9,A) + let eval = try EVAL(item, env) // malstep(2,3,4,5,6,7,8,9,A) + result.append(eval) // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + return make_vector(result) // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + if let hash = as_hashmapQ(ast) { // malstep(2,3,4,5,6,7,8,9,A) + var result = [MalVal]() // malstep(2,3,4,5,6,7,8,9,A) + result.reserveCapacity(Int(hash.count) * 2) // malstep(2,3,4,5,6,7,8,9,A) + for (k, v) in hash { // malstep(2,3,4,5,6,7,8,9,A) + let new_v = try EVAL(v, env) // malstep(2,3,4,5,6,7,8,9,A) + result.append(k) // malstep(2,3,4,5,6,7,8,9,A) + result.append(new_v) // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + return make_hashmap(result) // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + return ast // malstep(2,3,4,5,6,7,8,9,A) +} // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) +private enum TCOVal { // malstep(5,6,7,8,9,A) + case NoResult // malstep(5,6,7,8,9,A) + case Return(MalVal) // malstep(5,6,7,8,9,A) + case Continue(MalVal, Environment) // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) + init() { self = .NoResult } // malstep(5,6,7,8,9,A) + init(_ result: MalVal) { self = .Return(result) } // malstep(5,6,7,8,9,A) + init(_ ast: MalVal, _ env: Environment) { self = .Continue(ast, env) } // malstep(5,6,7,8,9,A) +} // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) +// EVALuate "def!". // malstep(3,4,5,6,7) +// EVALuate "def!" and "defmacro!". // malstep(8,9,A) +// // malstep(3,4,5,6,7,8,9,A) +private func eval_def(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(3,4) +private func eval_def(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) + guard list.count == 3 else { // malstep(3,4,5,6,7,8,9,A) + try throw_error("expected 2 arguments to def!, got \(list.count - 1)") // malstep(3,4,5,6,7,8,9,A) + } // malstep(3,4,5,6,7,8,9,A) + let arg0 = try! list.nth(0) // malstep(8,9,A) + let arg1 = try! list.nth(1) // malstep(3,4,5,6,7,8,9,A) + let arg2 = try! list.nth(2) // malstep(3,4,5,6,7,8,9,A) + guard let sym = as_symbolQ(arg1) else { // malstep(3,4,5,6,7,8,9,A) + try throw_error("expected symbol for first argument to def!") // malstep(3,4,5,6,7,8,9,A) + } // malstep(3,4,5,6,7,8,9,A) + let value = try EVAL(arg2, env) // malstep(3,4,5,6,7) + var value = try EVAL(arg2, env) // malstep(8,9,A) + if as_symbol(arg0) == kSymbolDefMacro { // malstep(8,9,A) + guard let closure = as_closureQ(value) else { // malstep(8,9,A) + try throw_error("expected closure, got \(value)") // malstep(8,9,A) + } // malstep(8,9,A) + value = make_macro(closure) // malstep(8,9,A) + } // malstep(8,9,A) + return env.set(sym, value) // malstep(3,4) + return TCOVal(env.set(sym, value)) // malstep(5,6,7,8,9,A) +} // malstep(3,4,5,6,7,8,9,A) + // malstep(3,4,5,6,7,8,9,A) +// EVALuate "let*". // malstep(3,4,5,6,7,8,9,A) +// // malstep(3,4,5,6,7,8,9,A) +private func eval_let(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(3,4) +private func eval_let(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) + guard list.count == 3 else { // malstep(3,4,5,6,7,8,9,A) + try throw_error("expected 2 arguments to let*, got \(list.count - 1)") // malstep(3,4,5,6,7,8,9,A) + } // malstep(3,4,5,6,7,8,9,A) + let arg1 = try! list.nth(1) // malstep(3,4,5,6,7,8,9,A) + let arg2 = try! list.nth(2) // malstep(3,4,5,6,7,8,9,A) + guard let bindings = as_sequenceQ(arg1) else { // malstep(3,4,5,6,7,8,9,A) + try throw_error("expected list for first argument to let*") // malstep(3,4,5,6,7,8,9,A) + } // malstep(3,4,5,6,7,8,9,A) + guard bindings.count % 2 == 0 else { // malstep(3,4,5,6,7,8,9,A) + try throw_error("expected even number of elements in bindings to let*, got \(bindings.count)") // malstep(3,4,5,6,7,8,9,A) + } // malstep(3,4,5,6,7,8,9,A) + let new_env = Environment(outer: env) // malstep(3,4,5,6,7,8,9,A) + for var index: MalIntType = 0; index < bindings.count; index += 2 { // malstep(3,4,5,6,7,8,9,A) + let binding_name = try! bindings.nth(index) // malstep(3,4,5,6,7,8,9,A) + let binding_value = try! bindings.nth(index + 1) // malstep(3,4,5,6,7,8,9,A) + guard let binding_symbol = as_symbolQ(binding_name) else { // malstep(3,4,5,6,7,8,9,A) + try throw_error("expected symbol for first element in binding pair") // malstep(3,4,5,6,7,8,9,A) + } // malstep(3,4,5,6,7,8,9,A) + let evaluated_value = try EVAL(binding_value, new_env) // malstep(3,4,5,6,7,8,9,A) + new_env.set(binding_symbol, evaluated_value) // malstep(3,4,5,6,7,8,9,A) + } // malstep(3,4,5,6,7,8,9,A) + if TCO { // malstep(5,6,7,8,9,A) + return TCOVal(arg2, new_env) // malstep(5,6,7,8,9,A) + } // malstep(5,6,7,8,9,A) + return try EVAL(arg2, new_env) // malstep(3,4) + return TCOVal(try EVAL(arg2, new_env)) // malstep(5,6,7,8,9,A) +} // malstep(3,4,5,6,7,8,9,A) + // malstep(3,4,5,6,7,8,9,A) +// EVALuate "do". // malstep(4,5,6,7,8,9,A) +// // malstep(4,5,6,7,8,9,A) +private func eval_do(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(4) +private func eval_do(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) + if TCO { // malstep(5,6,7,8,9,A) + let _ = try eval_ast(list.range_from(1, to: list.count-1), env) // malstep(5,6,7,8,9,A) + return TCOVal(list.last(), env) // malstep(5,6,7,8,9,A) + } // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) + let evaluated_ast = try eval_ast(list.rest(), env) // malstep(4,5,6,7,8,9,A) + let evaluated_seq = as_sequence(evaluated_ast) // malstep(4,5,6,7,8,9,A) + return evaluated_seq.last() // malstep(4) + return TCOVal(evaluated_seq.last()) // malstep(5,6,7,8,9,A) +} // malstep(4,5,6,7,8,9,A) + // malstep(4,5,6,7,8,9,A) +// EVALuate "if". // malstep(4,5,6,7,8,9,A) +// // malstep(4,5,6,7,8,9,A) +private func eval_if(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(4) +private func eval_if(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) + guard list.count >= 3 else { // malstep(4,5,6,7,8,9,A) + try throw_error("expected at least 2 arguments to if, got \(list.count - 1)") // malstep(4,5,6,7,8,9,A) + } // malstep(4,5,6,7,8,9,A) + let cond_result = try EVAL(try! list.nth(1), env) // malstep(4,5,6,7,8,9,A) + var new_ast: MalVal // malstep(4,5,6,7,8,9,A) + if is_truthy(cond_result) { // malstep(4,5,6,7,8,9,A) + new_ast = try! list.nth(2) // malstep(4,5,6,7,8,9,A) + } else if list.count == 4 { // malstep(4,5,6,7,8,9,A) + new_ast = try! list.nth(3) // malstep(4,5,6,7,8,9,A) + } else { // malstep(4,5,6,7,8,9,A) + return make_nil() // malstep(4) + return TCOVal(make_nil()) // malstep(5,6,7,8,9,A) + } // malstep(4,5,6,7,8,9,A) + if TCO { // malstep(5,6,7,8,9,A) + return TCOVal(new_ast, env) // malstep(5,6,7,8,9,A) + } // malstep(5,6,7,8,9,A) + return try EVAL(new_ast, env) // malstep(4) + return TCOVal(try EVAL(new_ast, env)) // malstep(5,6,7,8,9,A) +} // malstep(4,5,6,7,8,9,A) + // malstep(4,5,6,7,8,9,A) +// EVALuate "fn*". // malstep(4,5,6,7,8,9,A) +// // malstep(4,5,6,7,8,9,A) +private func eval_fn(list: MalSequence, _ env: Environment) throws -> MalVal { // malstep(4) +private func eval_fn(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(5,6,7,8,9,A) + guard list.count == 3 else { // malstep(4,5,6,7,8,9,A) + try throw_error("expected 2 arguments to fn*, got \(list.count - 1)") // malstep(4,5,6,7,8,9,A) + } // malstep(4,5,6,7,8,9,A) + guard let seq = as_sequenceQ(try! list.nth(1)) else { // malstep(4,5,6,7,8,9,A) + try throw_error("expected list or vector for first argument to fn*") // malstep(4,5,6,7,8,9,A) + } // malstep(4,5,6,7,8,9,A) + return make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env)) // malstep(4) + return TCOVal(make_closure((eval: EVAL, args: seq, body: try! list.nth(2), env: env))) // malstep(5,6,7,8,9,A) +} // malstep(4,5,6,7,8,9,A) + // malstep(4,5,6,7,8,9,A) +// EVALuate "quote". // malstep(7,8,9,A) +// // malstep(7,8,9,A) +private func eval_quote(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(7,8,9,A) + if list.count >= 2 { // malstep(7,8,9,A) + return TCOVal(try! list.nth(1)) // malstep(7,8,9,A) + } // malstep(7,8,9,A) + return TCOVal(make_nil()) // malstep(7,8,9,A) +} // malstep(7,8,9,A) + // malstep(7,8,9,A) +// EVALuate "quasiquote". // malstep(7,8,9,A) +// // malstep(7,8,9,A) +private func eval_quasiquote(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(7,8,9,A) + guard list.count >= 2 else { // malstep(7,8,9,A) + try throw_error("Expected non-nil parameter to 'quasiquote'") // malstep(7,8,9,A) + } // malstep(7,8,9,A) + if TCO { // malstep(7,8,9,A) + return TCOVal(try quasiquote(try! list.nth(1)), env) // malstep(7,8,9,A) + } // malstep(7,8,9,A) + return TCOVal(try EVAL(try quasiquote(try! list.nth(1)), env)) // malstep(7,8,9,A) +} // malstep(7,8,9,A) + // malstep(7,8,9,A) +// EVALuate "macroexpand". // malstep(8,9,A) +// // malstep(8,9,A) +private func eval_macroexpand(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(8,9,A) + guard list.count >= 2 else { // malstep(8,9,A) + try throw_error("Expected parameter to 'macroexpand'") // malstep(8,9,A) + } // malstep(8,9,A) + return TCOVal(try macroexpand(try! list.nth(1), env)) // malstep(8,9,A) +} // malstep(8,9,A) + // malstep(8,9,A) +// EVALuate "try*" (and "catch*"). // malstep(9,A) +// // malstep(9,A) +private func eval_try(list: MalSequence, _ env: Environment) throws -> TCOVal { // malstep(9,A) + // This is a subset of the Clojure try/catch: // malstep(9,A) + // // malstep(9,A) + // (try* expr (catch exception-name expr)) // malstep(9,A) + // malstep(9,A) + guard list.count >= 2 else { // malstep(9,A) + try throw_error("try*: no body parameter") // malstep(9,A) + } // malstep(9,A) + // malstep(9,A) + do { // malstep(9,A) + return TCOVal(try EVAL(try! list.nth(1), env)) // malstep(9,A) + } catch let error as MalException { // malstep(9,A) + guard list.count >= 3, // malstep(9,A) + let catch_list = as_sequenceQ(try! list.nth(2)) where catch_list.count >= 3, // malstep(9,A) + let _ = as_symbolQ(try! catch_list.nth(0)) else // malstep(9,A) + { // malstep(9,A) + throw error // No catch parameter // malstep(9,A) + } // malstep(9,A) + let catch_name = try! catch_list.nth(1) // malstep(9,A) + let catch_expr = try! catch_list.nth(2) // malstep(9,A) + let catch_env = Environment(outer: env) // malstep(9,A) + try catch_env.set_bindings(as_sequence(make_list_from(catch_name)), // malstep(9,A) + with_exprs: as_sequence(make_list_from(error.exception))) // malstep(9,A) + return TCOVal(try EVAL(catch_expr, catch_env)) // malstep(9,A) + } // malstep(9,A) +} // malstep(9,A) + // malstep(9,A) +// +// >>> NOTE: There are several versions of the EVAL function. One is used in +// >>> step 0, one is used in step 1, and a final one is used in step 2 and all +// >>> subsequent versions. This final version is extended throughout the +// >>> project through the addition of functionality. +// + +// Walk the AST and completely evaluate it, handling macro expansions, special // malstep(0,1,2,3,4,5,6,7,8,9,A) +// forms and function calls. // malstep(0,1,2,3,4,5,6,7,8,9,A) +// // malstep(0,1,2,3,4,5,6,7,8,9,A) +private func EVAL(ast: String) -> String { // malstep(0) + return ast // malstep(0) +} // malstep(0) +private func EVAL(ast: MalVal) -> MalVal { // malstep(1) + return ast // malstep(1) +} // malstep(1) +private func EVAL(ast: MalVal, _ env: Environment) throws -> MalVal { // malstep(2,3,4) +private func EVAL(var ast: MalVal, var _ env: Environment) throws -> MalVal { // malstep(5,6,7,8,9,A) + EVAL_level++ // malstep(5,6,7,8,9,A) + defer { EVAL_level-- } // malstep(5,6,7,8,9,A) + guard EVAL_level <= EVAL_leval_max else { // malstep(5,6,7,8,9,A) + try throw_error("Recursing too many levels (> \(EVAL_leval_max))") // malstep(5,6,7,8,9,A) + } // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) + if DEBUG_EVAL { // malstep(5,6,7,8,9,A) + indent = substring(INDENT_TEMPLATE, 0, EVAL_level) // malstep(5,6,7,8,9,A) + } // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) + while true { // malstep(5,6,7,8,9,A) + if DEBUG_EVAL { print("\(indent)> \(ast)") } // malstep(5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + if !is_list(ast) { // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + // Not a list -- just evaluate and return. // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + let answer = try eval_ast(ast, env) // malstep(2,3,4,5,6,7,8,9,A) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } // malstep(5,6,7,8,9,A) + return answer // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + // Special handling if it's a list. // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + let list = as_list(ast) // malstep(2,3,4,5,6,7) + var list = as_list(ast) // malstep(8,9,A) + ast = try macroexpand(ast, env) // malstep(8,9,A) + if !is_list(ast) { // malstep(8,9,A) + // malstep(8,9,A) + // Not a list -- just evaluate and return. // malstep(8,9,A) + // malstep(8,9,A) + let answer = try eval_ast(ast, env) // malstep(8,9,A) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } // malstep(8,9,A) + return answer // malstep(8,9,A) + } // malstep(8,9,A) + list = as_list(ast) // malstep(8,9,A) + // malstep(8,9,A) + if DEBUG_EVAL { print("\(indent)>. \(list)") } // malstep(5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + if list.isEmpty { // malstep(2,3,4,5,6,7,8,9,A) + return ast // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + // Check for special forms, where we want to check the operation // malstep(3,4,5,6,7,8,9,A) + // before evaluating all of the parameters. // malstep(3,4,5,6,7,8,9,A) + // malstep(3,4,5,6,7,8,9,A) + let arg0 = list.first() // malstep(3,4,5,6,7,8,9,A) + if let fn_symbol = as_symbolQ(arg0) { // malstep(3,4,5,6,7,8,9,A) + let res: TCOVal // malstep(5,6,7,8,9,A) + // malstep(3,4,5,6,7,8,9,A) + switch fn_symbol { // malstep(3,4,5,6,7,8,9,A) + case kSymbolDef: return try eval_def(list, env) // malstep(3,4) + case kSymbolDef: res = try eval_def(list, env) // malstep(5,6,7,8,9,A) + case kSymbolDefMacro: res = try eval_def(list, env) // malstep(8,9,A) + case kSymbolLet: return try eval_let(list, env) // malstep(3,4) + case kSymbolLet: res = try eval_let(list, env) // malstep(5,6,7,8,9,A) + case kSymbolDo: return try eval_do(list, env) // malstep(4) + case kSymbolDo: res = try eval_do(list, env) // malstep(5,6,7,8,9,A) + case kSymbolIf: return try eval_if(list, env) // malstep(4) + case kSymbolIf: res = try eval_if(list, env) // malstep(5,6,7,8,9,A) + case kSymbolFn: return try eval_fn(list, env) // malstep(4) + case kSymbolFn: res = try eval_fn(list, env) // malstep(5,6,7,8,9,A) + case kSymbolQuote: res = try eval_quote(list, env) // malstep(7,8,9,A) + case kSymbolQuasiQuote: res = try eval_quasiquote(list, env) // malstep(7,8,9,A) + case kSymbolMacroExpand: res = try eval_macroexpand(list, env) // malstep(8,9,A) + case kSymbolTry: res = try eval_try(list, env) // malstep(9,A) + default: break // malstep(3,4) + default: res = TCOVal() // malstep(5,6,7,8,9,A) + } // malstep(3,4,5,6,7,8,9,A) + switch res { // malstep(5,6,7,8,9,A) + case let .Return(result): return result // malstep(5,6,7,8,9,A) + case let .Continue(new_ast, new_env): ast = new_ast; env = new_env; continue // malstep(5,6,7,8,9,A) + case .NoResult: break // malstep(5,6,7,8,9,A) + } // malstep(5,6,7,8,9,A) + } // malstep(3,4,5,6,7,8,9,A) + // malstep(3,4,5,6,7,8,9,A) + // Standard list to be applied. Evaluate all the elements first. // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + let eval = try eval_ast(ast, env) // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + // The result had better be a list and better be non-empty. // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + let eval_list = as_list(eval) // malstep(2,3,4,5,6,7,8,9,A) + if eval_list.isEmpty { // malstep(2,3,4,5,6,7,8,9,A) + return eval // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + if DEBUG_EVAL { print("\(indent)>> \(eval)") } // malstep(5,6,7,8,9,A) + // malstep(5,6,7,8,9,A) + // Get the first element of the list and execute it. // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + let first = eval_list.first() // malstep(2,3,4,5,6,7,8,9,A) + let rest = as_sequence(eval_list.rest()) // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + if let fn = as_builtinQ(first) { // malstep(2,3,4,5,6,7,8,9,A) + let answer = try fn.apply(rest) // malstep(2,3,4,5,6,7,8,9,A) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } // malstep(5,6,7,8,9,A) + return answer // malstep(2,3,4,5,6,7,8,9,A) + } else if let fn = as_closureQ(first) { // malstep(4,5,6,7,8,9,A) + let new_env = Environment(outer: fn.env) // malstep(4,5,6,7,8,9,A) + let _ = try new_env.set_bindings(fn.args, with_exprs: rest) // malstep(4,5,6,7,8,9,A) + if TCO { // malstep(5,6,7,8,9,A) + env = new_env // malstep(5,6,7,8,9,A) + ast = fn.body // malstep(5,6,7,8,9,A) + continue // malstep(5,6,7,8,9,A) + } // malstep(5,6,7,8,9,A) + let answer = try EVAL(fn.body, new_env) // malstep(4,5,6,7,8,9,A) + if DEBUG_EVAL { print("\(indent)>>> \(answer)") } // malstep(5,6,7,8,9,A) + return answer // malstep(4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + // The first element wasn't a function to be executed. Return an // malstep(2,3,4,5,6,7,8,9,A) + // error saying so. // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + try throw_error("first list item does not evaluate to a function: \(first)") // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(5,6,7,8,9,A) +} // malstep(2,3,4,5,6,7,8,9,A) + // malstep(0,1,2,3,4,5,6,7,8,9,A) +// Convert the value into a human-readable string for printing. // malstep(0,1,2,3,4,5,6,7,8,9,A) +// // malstep(0,1,2,3,4,5,6,7,8,9,A) +private func PRINT(exp: String) -> String { // malstep(0) + return exp // malstep(0) +} // malstep(0) +private func PRINT(exp: MalVal) -> String { // malstep(1,2,3,4,5,6,7,8,9,A) + return pr_str(exp, true) // malstep(1,2,3,4,5,6,7,8,9,A) +} // malstep(1,2,3,4,5,6,7,8,9,A) + // malstep(0,1,2,3,4,5,6,7,8,9,A) +// +// >>> NOTE: The following function has several versions. Also note that the +// >>> call to EVAL comes in two flavors. +// + +// Perform the READ and EVAL steps. Useful for when you don't care about the // malstep(0,1,2,3,4,5,6,7,8,9,A) +// printable result. // malstep(0,1,2,3,4,5,6,7,8,9,A) +// // malstep(0,1,2,3,4,5,6,7,8,9,A) +private func RE(text: String) -> String { // malstep(0) + let ast = READ(text) // malstep(0) + let exp = EVAL(ast) // malstep(0) + return exp // malstep(0) +} // malstep(0) +private func RE(text: String) -> MalVal? { // malstep(1) +private func RE(text: String, _ env: Environment) -> MalVal? { // malstep(2,3,4,5,6,7,8,9,A) + if !text.isEmpty { // malstep(1,2,3,4,5,6,7,8,9,A) + do { // malstep(1,2,3,4,5,6,7,8,9,A) + let ast = try READ(text) // malstep(1,2,3,4,5,6,7,8,9,A) + do { // malstep(2,3,4,5,6,7,8,9,A) + return EVAL(ast) // malstep(1) + return try EVAL(ast, env) // malstep(2,3,4,5,6,7,8,9,A) + } catch let error as MalException { // malstep(2,3,4,5,6,7,8,9,A) + print("Error evaluating input: \(error)") // malstep(2,3,4,5,6,7,8,9,A) + } catch { // malstep(2,3,4,5,6,7,8,9,A) + print("Error evaluating input: \(error)") // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + } catch let error as MalException { // malstep(1,2,3,4,5,6,7,8,9,A) + print("Error parsing input: \(error)") // malstep(1,2,3,4,5,6,7,8,9,A) + } catch { // malstep(1,2,3,4,5,6,7,8,9,A) + print("Error parsing input: \(error)") // malstep(1,2,3,4,5,6,7,8,9,A) + } // malstep(1,2,3,4,5,6,7,8,9,A) + } // malstep(1,2,3,4,5,6,7,8,9,A) + return nil // malstep(1,2,3,4,5,6,7,8,9,A) +} // malstep(1,2,3,4,5,6,7,8,9,A) + // malstep(0,1,2,3,4,5,6,7,8,9,A) +// +// >>> NOTE: The following function has several versions. +// + +// Perform the full READ/EVAL/PRINT, returning a printable string. // malstep(0,1,2,3,4,5,6,7,8,9,A) +// // malstep(0,1,2,3,4,5,6,7,8,9,A) +private func REP(text: String) -> String { // malstep(0) + let exp = RE(text) // malstep(0) + return PRINT(exp) // malstep(0) +} // malstep(0) +private func REP(text: String) -> String? { // malstep(1) + let exp = RE(text) // malstep(1) + if exp == nil { return nil } // malstep(1) + return PRINT(exp!) // malstep(1) +} // malstep(1) +private func REP(text: String, _ env: Environment) -> String? { // malstep(2,3,4,5,6,7,8,9,A) + let exp = RE(text, env) // malstep(2,3,4,5,6,7,8,9,A) + if exp == nil { return nil } // malstep(2,3,4,5,6,7,8,9,A) + return PRINT(exp!) // malstep(2,3,4,5,6,7,8,9,A) +} // malstep(2,3,4,5,6,7,8,9,A) + // malstep(0,1,2,3,4,5,6,7,8,9,A) +// +// >>> NOTE: The following function has several versions. +// + +// Perform the full REPL. // malstep(0,1,2,3,4,5,6,7,8,9,A) +// // malstep(0,1,2,3,4,5,6,7,8,9,A) +private func REPL() { // malstep(0) + while true { // malstep(0) + if let text = _readline("user> ") { // malstep(0) + print("\(REP(text))") // malstep(0) + } else { // malstep(0) + print("") // malstep(0) + break // malstep(0) + } // malstep(0) + } // malstep(0) +} // malstep(0) +private func REPL() { // malstep(1) + while true { // malstep(1) + if let text = _readline("user> ") { // malstep(1) + if let output = REP(text) { // malstep(1) + print("\(output)") // malstep(1) + } // malstep(1) + } else { // malstep(1) + print("") // malstep(1) + break // malstep(1) + } // malstep(1) + } // malstep(1) +} // malstep(1) +private func REPL(env: Environment) { // malstep(2,3,4,5,6,7,8,9,A) + while true { // malstep(2,3,4,5,6,7,8,9,A) + if let text = _readline("user> ") { // malstep(2,3,4,5,6,7,8,9,A) + if let output = REP(text, env) { // malstep(2,3,4,5,6,7,8,9,A) + print("\(output)") // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + } else { // malstep(2,3,4,5,6,7,8,9,A) + print("") // malstep(2,3,4,5,6,7,8,9,A) + break // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) + } // malstep(2,3,4,5,6,7,8,9,A) +} // malstep(2,3,4,5,6,7,8,9,A) + // malstep(0,1,2,3,4,5,6,7,8,9,A) +// Process any command line arguments. Any trailing arguments are incorporated // malstep(6,7,8,9,A) +// into the environment. Any argument immediately after the process name is // malstep(6,7,8,9,A) +// taken as a script to execute. If one exists, it is executed in lieu of // malstep(6,7,8,9,A) +// running the REPL. // malstep(6,7,8,9,A) +// // malstep(6,7,8,9,A) +private func process_command_line(args: [String], _ env: Environment) -> Bool { // malstep(6,7,8,9,A) + var argv = make_list() // malstep(6,7,8,9,A) + if args.count > 2 { // malstep(6,7,8,9,A) + let args1 = args[2.. 1 { // malstep(6,7,8,9,A) + RE("(load-file \"\(args[1])\")", env) // malstep(6,7,8,9,A) + return false // malstep(6,7,8,9,A) + } // malstep(6,7,8,9,A) + // malstep(6,7,8,9,A) + return true // malstep(6,7,8,9,A) +} // malstep(6,7,8,9,A) + // malstep(6,7,8,9,A) +func main() { // malstep(0,1,2,3,4,5,6,7,8,9,A) + let env = Environment(outer: nil) // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + load_history_file() // malstep(0,1,2,3,4,5,6,7,8,9,A) + load_builtins(env) // malstep(2,3,4,5,6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + RE("(def! *host-language* \"swift\")", env) // malstep(A) + RE("(def! not (fn* (a) (if a false true)))", env) // malstep(4,5,6,7,8,9,A) + RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))", env) // malstep(6,7,8,9,A) + RE("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) " + // malstep(8,9,A) + "(throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))", env) // malstep(8,9,A) + RE("(def! inc (fn* [x] (+ x 1)))", env) // malstep(A) + RE("(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str \"G__\" (swap! counter inc))))))", env) // malstep(A) + RE("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) " + // malstep(8,9,A) + "`(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))", env) // malstep(8,9) + "(let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))", env) // malstep(A) + // malstep(6,7,8,9,A) + env.set(kSymbolEval, make_builtin({ // malstep(6,7,8,9,A) + try! unwrap_args($0) { // malstep(6,7,8,9,A) + (ast: MalVal) -> MalVal in // malstep(6,7,8,9,A) + try EVAL(ast, env) // malstep(6,7,8,9,A) + } // malstep(6,7,8,9,A) + })) // malstep(6,7,8,9,A) + // malstep(6,7,8,9,A) +// +// >>> NOTE: The call to REPL() is managed in three different ways. First, we +// >>> just call it with no parameters. Second, we call it with an "env" +// >>> parameter. Finally, we call it only if there is no program on the +// >>> command line to execute. +// + REPL() // malstep(0,1) + REPL(env) // malstep(2,3,4,5) + if process_command_line(Process.arguments, env) { // malstep(6,7,8,9,A) + RE("(println (str \"Mal [\" *host-language*\"]\"))", env) // malstep(A) + REPL(env) // malstep(6,7,8,9,A) + } // malstep(6,7,8,9,A) + // malstep(2,3,4,5,6,7,8,9,A) + save_history_file() // malstep(0,1,2,3,4,5,6,7,8,9,A) +} // malstep(0,1,2,3,4,5,6,7,8,9,A) diff --git a/impls/swift/tests/step5_tco.mal b/impls/swift/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/swift/tests/step5_tco.mal +++ b/impls/swift/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/swift/types_class.swift b/impls/swift/types_class.swift index 569bfa51de..6f994baf81 100644 --- a/impls/swift/types_class.swift +++ b/impls/swift/types_class.swift @@ -1,1101 +1,1101 @@ -//****************************************************************************** -// MAL - types, implemented as a Swift "class". -//****************************************************************************** - -import Foundation - -// ==================== Types / Constants / Variables ==================== - -typealias MalProtocol = protocol - -typealias MalIntType = Int64 -typealias MalFloatType = Double -typealias MalSymbolType = String -typealias MalKeywordType = String -typealias MalStringType = String -typealias MalVectorType = ArraySlice -typealias MalHashType = Dictionary - -private let kUnknown = MalUnknown() -private let kNil = MalNil() -private let kTrue = MalTrue() -private let kFalse = MalFalse() -private let kComment = MalComment() - -// ==================== MalVal ==================== - -class MalVal : MalProtocol { - init() { - self._meta = nil - } - init(_ other: MalVal, _ meta: MalVal?) { - self._meta = meta - } - init(_ meta: MalVal?) { - self._meta = meta - } - - // CustomStringConvertible - // - var description: String { die() } - - // Hashable - // - var hashValue: Int { return description.hashValue } - - // MalVal - // - func clone_with_meta(meta: MalVal) -> MalVal { die() } - final var meta: MalVal? { return self._meta } - - let _meta: MalVal? -} - -// Equatable -// -let tMalUnknown = class_getName(MalUnknown) -let tMalNil = class_getName(MalNil) -let tMalTrue = class_getName(MalTrue) -let tMalFalse = class_getName(MalFalse) -let tMalComment = class_getName(MalComment) -let tMalInteger = class_getName(MalInteger) -let tMalFloat = class_getName(MalFloat) -let tMalSymbol = class_getName(MalSymbol) -let tMalKeyword = class_getName(MalKeyword) -let tMalString = class_getName(MalString) -let tMalList = class_getName(MalList) -let tMalVector = class_getName(MalVector) -let tMalHashMap = class_getName(MalHashMap) -let tMalAtom = class_getName(MalAtom) -let tMalClosure = class_getName(MalClosure) -let tMalBuiltin = class_getName(MalBuiltin) -let tMalMacro = class_getName(MalMacro) - -func ==(left: MalVal, right: MalVal) -> Bool { - let leftClass = object_getClassName(left) - let rightClass = object_getClassName(right) - - if leftClass == tMalUnknown && rightClass == tMalUnknown { return as_unknown(left) == as_unknown(right) } - if leftClass == tMalNil && rightClass == tMalNil { return as_nil(left) == as_nil(right) } - if leftClass == tMalTrue && rightClass == tMalTrue { return as_true(left) == as_true(right) } - if leftClass == tMalFalse && rightClass == tMalFalse { return as_false(left) == as_false(right) } - if leftClass == tMalComment && rightClass == tMalComment { return as_comment(left) == as_comment(right) } - if leftClass == tMalInteger && rightClass == tMalInteger { return as_integer(left) == as_integer(right) } - if leftClass == tMalFloat && rightClass == tMalFloat { return as_float(left) == as_float(right) } - if leftClass == tMalSymbol && rightClass == tMalSymbol { return as_symbol(left) == as_symbol(right) } - if leftClass == tMalKeyword && rightClass == tMalKeyword { return as_keyword(left) == as_keyword(right) } - if leftClass == tMalString && rightClass == tMalString { return as_string(left) == as_string(right) } - //if leftClass == tMalList && rightClass == tMalList { return as_sequence(left) == as_sequence(right) } - //if leftClass == tMalVector && rightClass == tMalVector { return as_sequence(left) == as_sequence(right) } - if leftClass == tMalHashMap && rightClass == tMalHashMap { return as_hashmap(left) == as_hashmap(right) } - if leftClass == tMalAtom && rightClass == tMalAtom { return as_atom(left) == as_atom(right) } - if leftClass == tMalClosure && rightClass == tMalClosure { return as_closure(left) == as_closure(right) } - if leftClass == tMalBuiltin && rightClass == tMalBuiltin { return as_builtin(left) == as_builtin(right) } - if leftClass == tMalMacro && rightClass == tMalMacro { return as_macro(left) == as_macro(right) } - // - // Special case lists/vectors, since they are different types that are - // nonetheless comparable. - if - (leftClass == tMalList || leftClass == tMalVector) && - (rightClass == tMalList || rightClass == tMalVector) { - return as_sequence(left) == as_sequence(right) - } - - return false -} - -func !=(left: MalVal, right: MalVal) -> Bool { - return !(left == right) -} - -// ==================== MalUnknown ==================== - -final class MalUnknown: MalVal { - override var description: String { return "unknown" } - override func clone_with_meta(meta: MalVal) -> MalVal { return MalUnknown(meta) } -} -func ==(left: MalUnknown, right: MalUnknown) -> Bool { return false } - -// ==================== MalNil ==================== - -final class MalNil: MalVal { - override var description: String { return "nil" } - override func clone_with_meta(meta: MalVal) -> MalVal { return MalNil(meta) } -} -func ==(left: MalNil, right: MalNil) -> Bool { return true } - -// ==================== MalTrue ==================== - -final class MalTrue: MalVal { - override var description: String { return "true" } - override func clone_with_meta(meta: MalVal) -> MalVal { return MalTrue(meta) } -} -func ==(left: MalTrue, right: MalTrue) -> Bool { return true } - -// ==================== MalFalse ==================== - -final class MalFalse: MalVal { - override var description: String { return "false" } - override func clone_with_meta(meta: MalVal) -> MalVal { return MalFalse(meta) } -} -func ==(left: MalFalse, right: MalFalse) -> Bool { return true } - -// ==================== MalComment ==================== - -final class MalComment: MalVal { - override var description: String { return "Comment" } - override func clone_with_meta(meta: MalVal) -> MalVal { return MalComment(meta) } -} - -// Equatable -// -func ==(left: MalComment, right: MalComment) -> Bool { return false } - -// ==================== MalInteger ==================== - -final class MalInteger: MalVal { - override init() { - self._integer = 0 - super.init() - } - init(_ other: MalInteger, _ meta: MalVal? = nil) { - self._integer = other._integer - super.init(other, meta) - } - init(_ integer: MalIntType) { - self._integer = integer - super.init() - } - - // CustomStringConvertible - // - override var description: String { return "\(self._integer)" } - - // Hashable - // - override var hashValue: Int { return Int(self._integer) } - - // MalInteger - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalInteger(self, meta) } - var integer: MalIntType { return self._integer } - - private let _integer: MalIntType -} - -// Equatable -// -func ==(left: MalInteger, right: MalInteger) -> Bool { return left.integer == right.integer } - -// ==================== MalFloat ==================== - -final class MalFloat: MalVal { - override init() { - self._float = 0 - super.init() - } - init(_ other: MalFloat, _ meta: MalVal? = nil) { - self._float = other._float - super.init(other, meta) - } - init(_ float: Double) { - self._float = float - super.init() - } - - // CustomStringConvertible - // - override var description: String { return "\(self._float)" } - - // Hashable - // - override var hashValue: Int { return Int(self._float) } - - // MalFloat - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalFloat(self, meta) } - var float: MalFloatType { return self._float } - - private let _float: Double -} - -// Equatable -// -func ==(left: MalFloat, right: MalFloat) -> Bool { return left.float == right.float } - -// ==================== MalSymbol ==================== - -private var symbolHash = [MalSymbolType : Int]() -private var symbolArray = [MalSymbolType]() - -private func indexForSymbol(s: MalSymbolType) -> Int { - if let i = symbolHash[s] { - return i - } - - symbolArray.append(s) - symbolHash[s] = symbolArray.count - 1 - return symbolArray.count - 1 -} - -private func symbolForIndex(i: Int) -> MalSymbolType { - return symbolArray[i] -} - -final class MalSymbol: MalVal { - override init() { - self._index = indexForSymbol("") - super.init() - } - init(_ other: MalSymbol, _ meta: MalVal? = nil) { - self._index = other._index - super.init(other, meta) - } - init(_ symbol: MalSymbolType) { - self._index = indexForSymbol(symbol) - super.init() - } - - // CustomStringConvertible - // - override var description: String { return symbolForIndex(self._index) } - - // Hashable - // - override var hashValue: Int { return self._index } - - // MalSymbol - override func clone_with_meta(meta: MalVal) -> MalVal { return MalSymbol(self, meta) } - var index: Int { return self._index } - - private let _index: Int -} - -// Equatable -// -func ==(left: MalSymbol, right: MalSymbol) -> Bool { return left.index == right.index } - -// ==================== MalKeyword ==================== - -final class MalKeyword: MalVal { - override init() { - self._keyword = "" - super.init() - } - init(_ other: MalKeyword, _ meta: MalVal? = nil) { - self._keyword = other._keyword - super.init(other, meta) - } - init(_ keyword: MalKeywordType) { - self._keyword = keyword - super.init() - } - init(_ string: MalString) { - self._keyword = string.string - super.init() - } - - // CustomStringConvertible - // - override var description: String { return self._keyword } // ":" added in pr_str - - // MalKeyword - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalKeyword(self, meta) } - var keyword: MalKeywordType { return self._keyword } - - private let _keyword: MalKeywordType -} - -// Equatable -// -func ==(left: MalKeyword, right: MalKeyword) -> Bool { return left._keyword == right._keyword } - -// ==================== MalString ==================== - -final class MalString: MalVal { - override init() { - self._string = "" - super.init() - } - init(_ other: MalString, _ meta: MalVal? = nil) { - self._string = other._string - super.init(other, meta) - } - init(_ string: MalStringType) { - self._string = string - super.init() - } - - // CustomStringConvertible - // - override var description: String { return self._string } - - // MalString - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalString(self, meta) } - var string: MalStringType { return self._string } - - private let _string: MalStringType -} - -// Equatable -// -func ==(left: MalString, right: MalString) -> Bool { return left.string == right.string } - -// ==================== MalSequence ==================== - -class MalSequence: MalVal, SequenceType { - override init() { - self.count = 0 - self.isEmpty = true - super.init() - } - init(_ other: MalSequence, _ meta: MalVal? = nil) { - self.count = other.count - self.isEmpty = other.isEmpty - super.init(other, meta) - } - init(_ count: MalIntType, _ isEmpty: Bool) { - self.count = count - self.isEmpty = isEmpty - super.init() - } - - // SequenceType - // - func generate() -> MalVectorType.Generator { die() } - - // MalSequence - // - var count: MalIntType - var isEmpty: Bool - - func first() -> MalVal { die() } - func last() -> MalVal { die() } - func rest() -> MalVal { die() } - func nth(n: MalIntType) throws -> MalVal { die() } - func range_from(from: MalIntType, to: MalIntType) -> MalVal { die() } - func cons(element: MalVal) -> MalVal { die() } - func concat(seq: MalSequence) throws -> MalVal { die() } - func conj(seq: MalSequence) throws -> MalVal { die() } - func map(@noescape transform: (MalVal) -> U) -> ArraySlice { die() } - func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { die() } -} - -// Equatable -// -func ==(left: MalSequence, right: MalSequence) -> Bool { - if left.count != right.count { return false } - var left_gen = left.generate() - var right_gen = right.generate() - while true { - if let left = left_gen.next(), right = right_gen.next() { - if left != right { - return false - } - } else { - break - } - } - return true -} - -// ==================== MalList ==================== - -final class MalList: MalSequence { - override init() { - self._slice = MalVectorType() - super.init(MalIntType(self._slice.count), self._slice.isEmpty) - } - init(_ other: MalList, _ meta: MalVal? = nil) { - self._slice = other._slice - super.init(other, meta) - } - init(seq: MalSequence) { // We need the "seq" in order to differentiate it from the previous init() - self._slice = seq.reduce(MalVectorType()){ var s = $0; s.append($1); return s } - super.init(MalIntType(self._slice.count), self._slice.isEmpty) - } - init(_ slice: MalVectorType) { - self._slice = slice - super.init(MalIntType(self._slice.count), self._slice.isEmpty) - } - init(_ array: Array) { - self._slice = array[0..(_ collection: T) { - self._slice = collection.reduce(MalVectorType()){ var s = $0; s.append($1); return s } - super.init(MalIntType(self._slice.count), self._slice.isEmpty) - } - - // CustomStringConvertible - // - override var description: String { return "(" + self.map { pr_str($0) }.joinWithSeparator(" ") + ")" } - - // SequenceType - // - override func generate() -> MalVectorType.Generator { return self._slice.generate() } - - // MalSequence - // - override func first() -> MalVal { return isEmpty ? make_nil() : try! nth(0) } - override func last() -> MalVal { return try! nth(count - 1) } - override func rest() -> MalVal { return range_from(MalIntType(1), to: MalIntType(count)) } - override func nth(n: MalIntType) throws -> MalVal { guard n < count else { try throw_error("index (\(n)) out of range (\(count))") }; return self._slice[self._slice.startIndex.advancedBy(Int(n))] } - override func range_from(from: MalIntType, to: MalIntType) -> MalVal { - return from <= to && to <= count - ? make_list(self._slice[self._slice.startIndex.advancedBy(Int(from)).. MalVal { - var result = self._slice - result.insert(element, atIndex: result.startIndex) - return make_list(result) - } - override func concat(seq: MalSequence) throws -> MalVal { - var result = self._slice - if let list = as_listQ(seq) { - result.appendContentsOf(list._slice) - } else if let vector = as_vectorQ(seq) { - result.appendContentsOf(vector._slice) - } else { - try throw_error("Expected sequence, got \(seq)") - } - return make_list(result) - } - override func conj(seq: MalSequence) throws -> MalVal { - var result: Array - if let list = as_listQ(seq) { - result = list._slice.reverse() - } else if let vector = as_vectorQ(seq) { - result = vector._slice.reverse() - } else { - try throw_error("Expected sequence, got \(seq)") - } - result.appendContentsOf(self._slice) - return make_list(result) - } - override func map(@noescape transform: (MalVal) -> U) -> ArraySlice { return ArraySlice(self._slice.map(transform)) } - override func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { return self._slice.reduce(initial, combine: combine) } - - // MalList - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalList(self, meta) } - - private let _slice: MalVectorType -} - -// Equatable -// -func ==(left: MalList, right: MalList) -> Bool { - return as_sequence(left) == as_sequence(right) -} - -// ==================== MalVector ==================== - -final class MalVector: MalSequence { - override init() { - self._slice = MalVectorType() - super.init(MalIntType(self._slice.count), self._slice.isEmpty) - } - init(_ other: MalVector, _ meta: MalVal? = nil) { - self._slice = other._slice - super.init(other, meta) - } - init(seq: MalSequence) { // We need the "seq" in order to differentiate it from the previous init() - self._slice = seq.reduce(MalVectorType()){ var s = $0; s.append($1); return s } - super.init(MalIntType(self._slice.count), self._slice.isEmpty) - } - init(_ slice: MalVectorType) { - self._slice = slice - super.init(MalIntType(self._slice.count), self._slice.isEmpty) - } - init(_ array: Array) { - self._slice = array[0..(_ collection: T) { - self._slice = collection.reduce(MalVectorType()){ var s = $0; s.append($1); return s } - super.init(MalIntType(self._slice.count), self._slice.isEmpty) - } - - // CustomStringConvertible - // - override var description: String { return "[" + self.map { pr_str($0) }.joinWithSeparator(" ") + "]" } - - // SequenceType - // - override func generate() -> MalVectorType.Generator { return self._slice.generate() } - - // MalSequence - // - override func first() -> MalVal { return isEmpty ? make_nil() : try! nth(0) } - override func last() -> MalVal { return try! nth(count - 1) } - override func rest() -> MalVal { return range_from(MalIntType(1), to: MalIntType(count)) } - override func nth(n: MalIntType) throws -> MalVal { guard n < count else { try throw_error("index (\(n)) out of range (\(count))") }; return self._slice[self._slice.startIndex.advancedBy(Int(n))] } - override func range_from(from: MalIntType, to: MalIntType) -> MalVal { - return from <= to && to <= count - ? make_list(self._slice[self._slice.startIndex.advancedBy(Int(from)).. MalVal { - var result = self._slice - result.insert(element, atIndex: result.startIndex) - return make_list(result) // Yes, make_list - } - override func concat(seq: MalSequence) throws -> MalVal { - var result = self._slice - if let list = as_listQ(seq) { - result.appendContentsOf(list._slice) - } else if let vector = as_vectorQ(seq) { - result.appendContentsOf(vector._slice) - } else { - try throw_error("Expected sequence, got \(seq)") - } - return make_list(result) - } - override func conj(seq: MalSequence) throws -> MalVal { - var result = self._slice - if let list = as_listQ(seq) { - result.appendContentsOf(list._slice) - } else if let vector = as_vectorQ(seq) { - result.appendContentsOf(vector._slice) - } else { - try throw_error("Expected sequence, got \(seq)") - } - return make_vector(result) - } - override func map(@noescape transform: (MalVal) -> U) -> ArraySlice { return ArraySlice(self._slice.map(transform)) } - override func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { return self._slice.reduce(initial, combine: combine) } - - // MalVector - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalVector(self, meta) } - - private let _slice: MalVectorType -} - -// Equatable -// -func ==(left: MalVector, right: MalVector) -> Bool { - return as_sequence(left) == as_sequence(right) -} - -// ==================== MalHashMap ==================== - -final class MalHashMap: MalVal, SequenceType { - override init() { - self._hash = MalHashType() - self.count = MalIntType(self._hash.count) - self.isEmpty = self._hash.isEmpty - super.init() - } - init(_ other: MalHashMap, _ meta: MalVal? = nil) { - self._hash = other._hash - self.count = MalIntType(self._hash.count) - self.isEmpty = self._hash.isEmpty - super.init(other, meta) - } - init(_ hash: MalHashType) { - self._hash = hash - self.count = MalIntType(self._hash.count) - self.isEmpty = self._hash.isEmpty - super.init() - } - convenience init(_ seq: MalSequence) { - var hash = MalHashType() - for var index: MalIntType = 0; index < seq.count; index += 2 { - hash[try! seq.nth(index)] = try! seq.nth(index + 1) - } - self.init(hash) - } - convenience init(_ collection: T) { - // TBD: Use SequenceType/generate - var hash = MalHashType() - for var index = collection.startIndex; index != collection.endIndex; { - let key = collection[index++] - let value = collection[index++] - hash[key] = value - } - self.init(hash) - } - - // CustomStringConvertible - // - override var description: String { - // TBD: Use reduce - var a = [String]() - for (k, v) in self._hash { - a.append("\(pr_str(k)) \(pr_str(v))") - } - let s = a.joinWithSeparator(" ") - return "{\(s)}" - } - - // SequenceType - // - func generate() -> MalHashType.Generator { return self._hash.generate() } - - // MalHashMap - // - let count: MalIntType - let isEmpty: Bool - var hash: MalHashType { return self._hash } - var keys: MalVal { return make_list(self._hash.keys) } - var values: MalVal { return make_list(self._hash.values) } - - override func clone_with_meta(meta: MalVal) -> MalVal { return MalHashMap(self, meta) } - - func value_for(key: MalVal) -> MalVal? { - return self._hash[key] - } - - private let _hash: MalHashType -} - -// Equatable -// -func ==(left: MalHashMap, right: MalHashMap) -> Bool { - if left.count != right.count { return false } - var left_gen = left.generate() - var right_gen = right.generate() - while true { - if let left = left_gen.next(), let right = right_gen.next() { - if left.0 != right.0 || left.1 != right.1 { - return false - } - } else { - break - } - } - return true -} - -// ==================== MalAtom ==================== - -final class MalAtom: MalVal { - override init() { - self._object = make_nil() - super.init() - } - init(_ other: MalAtom, _ meta: MalVal? = nil) { - self._object = other._object - super.init(other, meta) - } - init(object: MalVal) { - self._object = object - super.init() - } - - // CustomStringConvertible - // - override var description: String { return "(atom \(self._object.description))" } - - // MalAtom - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalAtom(self, meta) } - var object: MalVal { return self._object } - - func set_object(obj: MalVal) -> MalVal { - self._object = obj - return obj - } - - private var _object: MalVal -} - -// Equatable -// -func ==(left: MalAtom, right: MalAtom) -> Bool { return left.object == right.object } - -// ==================== MalFunction ==================== - -class MalFunction: MalVal { - override init() { - super.init() - } - init(_ other: MalFunction, _ meta: MalVal? = nil) { - super.init(other, meta) - } - - // MalFunction - // - func apply(exprs: MalSequence) throws -> MalVal { die() } -} - -// ==================== MalClosure ==================== - -final class MalClosure: MalFunction { - typealias Evaluator = (MalVal, Environment) throws -> MalVal - typealias Parameters = (eval: Evaluator, args: MalSequence, body: MalVal, env: Environment) - - override init() { - self._eval = nil - self._args = as_sequence(make_list()) - self._body = make_nil() - self._env = Environment(outer: nil) - super.init() - } - init(_ other: MalClosure, _ meta: MalVal? = nil) { - self._eval = other._eval - self._args = other._args - self._body = other._body - self._env = other._env - super.init(other, meta) - } - init(_ p: Parameters) { - self._eval = p.eval - self._args = p.args - self._body = p.body - self._env = p.env - super.init() - } - - // CustomStringConvertible - // - override var description: String { return "#: (fn* \(self._args.description) \(self._body.description))" } - - // MalFunction - // - override func apply(exprs: MalSequence) throws -> MalVal { - let new_env = Environment(outer: self._env) - let _ = try new_env.set_bindings(self._args, with_exprs: exprs) - // Calling EVAL indirectly via an 'eval' data member is a bit of a hack. - // We can't call EVAL directly because this file (types.swift) needs to - // be used with many different versions of the main MAL file - // (step[0-10]*.swift), and EVAL is declared differently across those - // versions. By using this indirection, we avoid that problem. - return try self._eval(self._body, new_env) - } - - // MalClosure - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalClosure(self, meta) } - - var args: MalSequence { return self._args } - var body: MalVal { return self._body } - var env: Environment { return self._env } - - private let _eval: Evaluator! - private let _args: MalSequence - private let _body: MalVal - private let _env: Environment -} - -// Equatable -// -func ==(left: MalClosure, right: MalClosure) -> Bool { return false } - -// ==================== MalBuiltin ==================== - -final class MalBuiltin: MalFunction { - typealias Signature = (MalSequence) throws -> MalVal - - override init() { - self._fn = nil - super.init() - } - init(_ other: MalBuiltin, _ meta: MalVal? = nil) { - self._fn = other._fn - super.init(other, meta) - } - init(_ fn: Signature) { - self._fn = fn - super.init() - } - - // CustomStringConvertible - // - override var description: String { return "#" } - - // MalFunction - // - override func apply(exprs: MalSequence) throws -> MalVal { return try self._fn(exprs) } - - // MalBuiltin - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalBuiltin(self, meta) } - - private let _fn: Signature! -} - -// Equatable -// -func ==(left: MalBuiltin, right: MalBuiltin) -> Bool { return false } // Can't compare function references in Swift - -// ==================== MalMacro ==================== - -final class MalMacro : MalVal { - override init() { - self._closure = as_closure(make_closure()) - super.init() - } - init(_ other: MalMacro, _ meta: MalVal? = nil) { - self._closure = other._closure - super.init(other, meta) - } - init(_ closure: MalClosure) { - self._closure = closure - super.init() - } - - // CustomStringConvertible - // - override var description: String { return self._closure.description } - - // MalMacro - // - override func clone_with_meta(meta: MalVal) -> MalVal { return MalMacro(self, meta) } - - var args: MalSequence { return self._closure.args } - var body: MalVal { return self._closure.body } - var env: Environment { return self._closure.env } - - private let _closure: MalClosure -} - -// Equatable -// -func ==(left: MalMacro, right: MalMacro) -> Bool { return false } - - -// ==================== Constructors ==================== - -// ----- Default ----- - -func make_unknown () -> MalVal { return kUnknown } -func make_nil () -> MalVal { return kNil } -func make_true () -> MalVal { return kTrue } -func make_false () -> MalVal { return kFalse } -func make_comment () -> MalVal { return kComment } -func make_integer () -> MalVal { return MalInteger() } -func make_float () -> MalVal { return MalFloat() } -func make_symbol () -> MalVal { return MalSymbol() } -func make_keyword () -> MalVal { return MalKeyword() } -func make_string () -> MalVal { return MalString() } -func make_list () -> MalVal { return MalList() } -func make_vector () -> MalVal { return MalVector() } -func make_hashmap () -> MalVal { return MalHashMap() } -func make_atom () -> MalVal { return MalAtom() } -func make_closure () -> MalVal { return MalClosure() } -func make_builtin () -> MalVal { return MalBuiltin() } -func make_macro () -> MalVal { return MalMacro() } - -// ----- Copy ----- - -func make_integer (v: MalInteger) -> MalVal { return MalInteger(v) } -func make_float (v: MalFloat) -> MalVal { return MalFloat(v) } -func make_symbol (v: MalSymbol) -> MalVal { return MalSymbol(v) } -func make_keyword (v: MalKeyword) -> MalVal { return MalKeyword(v) } -func make_string (v: MalString) -> MalVal { return MalString(v) } -func make_list (v: MalList) -> MalVal { return MalList(v) } -func make_vector (v: MalVector) -> MalVal { return MalVector(v) } -func make_hashmap (v: MalHashMap) -> MalVal { return MalHashMap(v) } -func make_atom (v: MalAtom) -> MalVal { return MalAtom(v) } -func make_closure (v: MalClosure) -> MalVal { return MalClosure(v) } -func make_builtin (v: MalBuiltin) -> MalVal { return MalBuiltin(v) } -func make_macro (v: MalMacro) -> MalVal { return MalMacro(v) } - -// ----- Parameterized ----- - -func make_integer (v: MalIntType) -> MalVal { return MalInteger(v) } -func make_float (v: MalFloatType) -> MalVal { return MalFloat(v) } -func make_symbol (v: String) -> MalVal { return MalSymbol(v) } -func make_keyword (v: String) -> MalVal { return MalKeyword(v) } -func make_keyword (v: MalString) -> MalVal { return MalKeyword(v) } -func make_string (v: String) -> MalVal { return MalString(v) } -func make_list (v: MalSequence) -> MalVal { return MalList(seq: v) } -func make_list (v: MalVectorType) -> MalVal { return MalList(v) } -func make_list (v: Array) -> MalVal { return MalList(v) } -func make_list_from (v: MalVal...) -> MalVal { return MalList(v) } -func make_list - (v: T) -> MalVal { return MalList(v) } -func make_vector (v: MalSequence) -> MalVal { return MalVector(seq: v) } -func make_vector (v: MalVectorType) -> MalVal { return MalVector(v) } -func make_vector (v: Array) -> MalVal { return MalVector(v) } -func make_vector - (v: T) -> MalVal { return MalVector(v) } -func make_hashmap (v: MalSequence) -> MalVal { return MalHashMap(v) } -func make_hashmap (v: MalHashType) -> MalVal { return MalHashMap(v) } -func make_hashmap - (v: T) -> MalVal { return MalHashMap(v) } -func make_atom (v: MalVal) -> MalVal { return MalAtom(object: v) } -func make_closure (v: MalClosure.Parameters) -> MalVal { return MalClosure(v) } -func make_builtin (v: MalBuiltin.Signature) -> MalVal { return MalBuiltin(v) } -func make_macro (v: MalClosure) -> MalVal { return MalMacro(v) } - -// ==================== Predicates ==================== - -// ----- Simple ----- - -func is_unknown (v: MalVal) -> Bool { return v is MalUnknown } -func is_nil (v: MalVal) -> Bool { return v is MalNil } -func is_true (v: MalVal) -> Bool { return v is MalTrue } -func is_false (v: MalVal) -> Bool { return v is MalFalse } -func is_comment (v: MalVal) -> Bool { return v is MalComment } -func is_integer (v: MalVal) -> Bool { return v is MalInteger } -func is_float (v: MalVal) -> Bool { return v is MalFloat } -func is_symbol (v: MalVal) -> Bool { return v is MalSymbol } -func is_keyword (v: MalVal) -> Bool { return v is MalKeyword } -func is_string (v: MalVal) -> Bool { return v is MalString } -func is_list (v: MalVal) -> Bool { return v is MalList } -func is_vector (v: MalVal) -> Bool { return v is MalVector } -func is_hashmap (v: MalVal) -> Bool { return v is MalHashMap } -func is_atom (v: MalVal) -> Bool { return v is MalAtom } -func is_closure (v: MalVal) -> Bool { return v is MalClosure } -func is_builtin (v: MalVal) -> Bool { return v is MalBuiltin } -func is_macro (v: MalVal) -> Bool { return v is MalMacro } - -// ----- Compound ----- - -func is_truthy (v: MalVal) -> Bool { return !is_falsey(v) } -func is_falsey (v: MalVal) -> Bool { return is_nil(v) || is_false(v) } -func is_number (v: MalVal) -> Bool { return is_integer(v) || is_float(v) } -func is_sequence (v: MalVal) -> Bool { return is_list(v) || is_vector(v) } -func is_function (v: MalVal) -> Bool { return is_closure(v) || is_builtin(v) } - -// ==================== Converters/Extractors ==================== - -func as_unknown (v: MalVal) -> MalUnknown { return v as! MalUnknown } -func as_nil (v: MalVal) -> MalNil { return v as! MalNil } -func as_true (v: MalVal) -> MalTrue { return v as! MalTrue } -func as_false (v: MalVal) -> MalFalse { return v as! MalFalse } -func as_comment (v: MalVal) -> MalComment { return v as! MalComment } -func as_integer (v: MalVal) -> MalInteger { return v as! MalInteger } -func as_float (v: MalVal) -> MalFloat { return v as! MalFloat } -func as_symbol (v: MalVal) -> MalSymbol { return v as! MalSymbol } -func as_keyword (v: MalVal) -> MalKeyword { return v as! MalKeyword } -func as_string (v: MalVal) -> MalString { return v as! MalString } -func as_list (v: MalVal) -> MalList { return v as! MalList } -func as_vector (v: MalVal) -> MalVector { return v as! MalVector } -func as_hashmap (v: MalVal) -> MalHashMap { return v as! MalHashMap } -func as_atom (v: MalVal) -> MalAtom { return v as! MalAtom } -func as_closure (v: MalVal) -> MalClosure { return v as! MalClosure } -func as_builtin (v: MalVal) -> MalBuiltin { return v as! MalBuiltin } -func as_macro (v: MalVal) -> MalMacro { return v as! MalMacro } - -func as_sequence (v: MalVal) -> MalSequence { return v as! MalSequence } -func as_function (v: MalVal) -> MalFunction { return v as! MalFunction } - -func as_inttype (v: MalVal) -> MalIntType { return as_integer(v).integer } -func as_floattype (v: MalVal) -> MalFloatType { return as_float(v).float } -func as_stringtype (v: MalVal) -> MalStringType { return as_string(v).string } - -func as_inttype (v: MalInteger) -> MalIntType { return v.integer } -func as_floattype (v: MalFloat) -> MalFloatType { return v.float } -func as_stringtype (v: MalString) -> MalStringType { return v.string } - -func as_unknownQ (v: MalVal) -> MalUnknown? { return v as? MalUnknown } -func as_nilQ (v: MalVal) -> MalNil? { return v as? MalNil } -func as_trueQ (v: MalVal) -> MalTrue? { return v as? MalTrue } -func as_falseQ (v: MalVal) -> MalFalse? { return v as? MalFalse } -func as_commentQ (v: MalVal) -> MalComment? { return v as? MalComment } -func as_integerQ (v: MalVal) -> MalInteger? { return v as? MalInteger } -func as_floatQ (v: MalVal) -> MalFloat? { return v as? MalFloat } -func as_symbolQ (v: MalVal) -> MalSymbol? { return v as? MalSymbol } -func as_keywordQ (v: MalVal) -> MalKeyword? { return v as? MalKeyword } -func as_stringQ (v: MalVal) -> MalString? { return v as? MalString } -func as_listQ (v: MalVal) -> MalList? { return v as? MalList } -func as_vectorQ (v: MalVal) -> MalVector? { return v as? MalVector } -func as_hashmapQ (v: MalVal) -> MalHashMap? { return v as? MalHashMap } -func as_atomQ (v: MalVal) -> MalAtom? { return v as? MalAtom } -func as_closureQ (v: MalVal) -> MalClosure? { return v as? MalClosure } -func as_builtinQ (v: MalVal) -> MalBuiltin? { return v as? MalBuiltin } -func as_macroQ (v: MalVal) -> MalMacro? { return v as? MalMacro } - -func as_sequenceQ (v: MalVal) -> MalSequence? { return v as? MalSequence } -func as_functionQ (v: MalVal) -> MalFunction? { return v as? MalFunction } - -func as_inttypeQ (v: MalVal) -> MalIntType? { return as_integerQ(v)?.integer } -func as_floattypeQ (v: MalVal) -> MalFloatType? { return as_floatQ(v)?.float } -func as_stringtypeQ (v: MalVal) -> MalStringType? { return as_stringQ(v)?.string } - -// ==================== Exceptions ==================== - -enum MalException: ErrorType, CustomStringConvertible { - case None - case Message(String) - case Object(MalVal) - - var exception: MalVal { - switch self { - case .None: - return make_nil() - case .Message(let v): - return make_string(v) - case .Object(let v): - return v - } - } - - // CustomStringConvertible - // - var description: String { - switch self { - case .None: - return "NIL Exception" - case .Message(let v): - return v - case .Object(let v): - return v.description - } - } -} - -@noreturn -func throw_error(v: String) throws { throw MalException.Message(v) } - -@noreturn -func throw_error(v: MalVal) throws { throw MalException.Object(v) } - -// ==================== Utilities ==================== - -@noreturn private func die() { - preconditionFailure("Should not get here") -} - -func get_meta(v: MalVal) -> MalVal? { - return v.meta -} - -func with_meta(obj: MalVal, _ meta: MalVal) -> MalVal { - return obj.clone_with_meta(meta) -} - -func unescape(s: String) -> String { - var index = 0 - var prev_is_escape = false - var str = "" - let chars = s.characters - for ch in chars { - if index == chars.count - 1 { continue } - if index++ == 0 { continue } - if prev_is_escape { - prev_is_escape = false - if ch == "n" { str.appendContentsOf("\n") } - else if ch == "r" { str.appendContentsOf("\r") } - else if ch == "t" { str.appendContentsOf("\t") } - else { str.append(ch) } - } else if ch == "\\" { - prev_is_escape = true - } else { - str.append(ch) - } - } - return str -} - -func escape(s: String) -> String { - var str = "" - let chars = s.characters - for ch in chars { - if ch == "\n" { str.appendContentsOf("\\n"); continue } - if ch == "\r" { str.appendContentsOf("\\r"); continue } - if ch == "\t" { str.appendContentsOf("\\t"); continue } - if ch == "\"" || ch == "\\" { str.appendContentsOf("\\") } - str.append(ch) - } - str = "\"" + str + "\"" - return str -} +//****************************************************************************** +// MAL - types, implemented as a Swift "class". +//****************************************************************************** + +import Foundation + +// ==================== Types / Constants / Variables ==================== + +typealias MalProtocol = protocol + +typealias MalIntType = Int64 +typealias MalFloatType = Double +typealias MalSymbolType = String +typealias MalKeywordType = String +typealias MalStringType = String +typealias MalVectorType = ArraySlice +typealias MalHashType = Dictionary + +private let kUnknown = MalUnknown() +private let kNil = MalNil() +private let kTrue = MalTrue() +private let kFalse = MalFalse() +private let kComment = MalComment() + +// ==================== MalVal ==================== + +class MalVal : MalProtocol { + init() { + self._meta = nil + } + init(_ other: MalVal, _ meta: MalVal?) { + self._meta = meta + } + init(_ meta: MalVal?) { + self._meta = meta + } + + // CustomStringConvertible + // + var description: String { die() } + + // Hashable + // + var hashValue: Int { return description.hashValue } + + // MalVal + // + func clone_with_meta(meta: MalVal) -> MalVal { die() } + final var meta: MalVal? { return self._meta } + + let _meta: MalVal? +} + +// Equatable +// +let tMalUnknown = class_getName(MalUnknown) +let tMalNil = class_getName(MalNil) +let tMalTrue = class_getName(MalTrue) +let tMalFalse = class_getName(MalFalse) +let tMalComment = class_getName(MalComment) +let tMalInteger = class_getName(MalInteger) +let tMalFloat = class_getName(MalFloat) +let tMalSymbol = class_getName(MalSymbol) +let tMalKeyword = class_getName(MalKeyword) +let tMalString = class_getName(MalString) +let tMalList = class_getName(MalList) +let tMalVector = class_getName(MalVector) +let tMalHashMap = class_getName(MalHashMap) +let tMalAtom = class_getName(MalAtom) +let tMalClosure = class_getName(MalClosure) +let tMalBuiltin = class_getName(MalBuiltin) +let tMalMacro = class_getName(MalMacro) + +func ==(left: MalVal, right: MalVal) -> Bool { + let leftClass = object_getClassName(left) + let rightClass = object_getClassName(right) + + if leftClass == tMalUnknown && rightClass == tMalUnknown { return as_unknown(left) == as_unknown(right) } + if leftClass == tMalNil && rightClass == tMalNil { return as_nil(left) == as_nil(right) } + if leftClass == tMalTrue && rightClass == tMalTrue { return as_true(left) == as_true(right) } + if leftClass == tMalFalse && rightClass == tMalFalse { return as_false(left) == as_false(right) } + if leftClass == tMalComment && rightClass == tMalComment { return as_comment(left) == as_comment(right) } + if leftClass == tMalInteger && rightClass == tMalInteger { return as_integer(left) == as_integer(right) } + if leftClass == tMalFloat && rightClass == tMalFloat { return as_float(left) == as_float(right) } + if leftClass == tMalSymbol && rightClass == tMalSymbol { return as_symbol(left) == as_symbol(right) } + if leftClass == tMalKeyword && rightClass == tMalKeyword { return as_keyword(left) == as_keyword(right) } + if leftClass == tMalString && rightClass == tMalString { return as_string(left) == as_string(right) } + //if leftClass == tMalList && rightClass == tMalList { return as_sequence(left) == as_sequence(right) } + //if leftClass == tMalVector && rightClass == tMalVector { return as_sequence(left) == as_sequence(right) } + if leftClass == tMalHashMap && rightClass == tMalHashMap { return as_hashmap(left) == as_hashmap(right) } + if leftClass == tMalAtom && rightClass == tMalAtom { return as_atom(left) == as_atom(right) } + if leftClass == tMalClosure && rightClass == tMalClosure { return as_closure(left) == as_closure(right) } + if leftClass == tMalBuiltin && rightClass == tMalBuiltin { return as_builtin(left) == as_builtin(right) } + if leftClass == tMalMacro && rightClass == tMalMacro { return as_macro(left) == as_macro(right) } + // + // Special case lists/vectors, since they are different types that are + // nonetheless comparable. + if + (leftClass == tMalList || leftClass == tMalVector) && + (rightClass == tMalList || rightClass == tMalVector) { + return as_sequence(left) == as_sequence(right) + } + + return false +} + +func !=(left: MalVal, right: MalVal) -> Bool { + return !(left == right) +} + +// ==================== MalUnknown ==================== + +final class MalUnknown: MalVal { + override var description: String { return "unknown" } + override func clone_with_meta(meta: MalVal) -> MalVal { return MalUnknown(meta) } +} +func ==(left: MalUnknown, right: MalUnknown) -> Bool { return false } + +// ==================== MalNil ==================== + +final class MalNil: MalVal { + override var description: String { return "nil" } + override func clone_with_meta(meta: MalVal) -> MalVal { return MalNil(meta) } +} +func ==(left: MalNil, right: MalNil) -> Bool { return true } + +// ==================== MalTrue ==================== + +final class MalTrue: MalVal { + override var description: String { return "true" } + override func clone_with_meta(meta: MalVal) -> MalVal { return MalTrue(meta) } +} +func ==(left: MalTrue, right: MalTrue) -> Bool { return true } + +// ==================== MalFalse ==================== + +final class MalFalse: MalVal { + override var description: String { return "false" } + override func clone_with_meta(meta: MalVal) -> MalVal { return MalFalse(meta) } +} +func ==(left: MalFalse, right: MalFalse) -> Bool { return true } + +// ==================== MalComment ==================== + +final class MalComment: MalVal { + override var description: String { return "Comment" } + override func clone_with_meta(meta: MalVal) -> MalVal { return MalComment(meta) } +} + +// Equatable +// +func ==(left: MalComment, right: MalComment) -> Bool { return false } + +// ==================== MalInteger ==================== + +final class MalInteger: MalVal { + override init() { + self._integer = 0 + super.init() + } + init(_ other: MalInteger, _ meta: MalVal? = nil) { + self._integer = other._integer + super.init(other, meta) + } + init(_ integer: MalIntType) { + self._integer = integer + super.init() + } + + // CustomStringConvertible + // + override var description: String { return "\(self._integer)" } + + // Hashable + // + override var hashValue: Int { return Int(self._integer) } + + // MalInteger + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalInteger(self, meta) } + var integer: MalIntType { return self._integer } + + private let _integer: MalIntType +} + +// Equatable +// +func ==(left: MalInteger, right: MalInteger) -> Bool { return left.integer == right.integer } + +// ==================== MalFloat ==================== + +final class MalFloat: MalVal { + override init() { + self._float = 0 + super.init() + } + init(_ other: MalFloat, _ meta: MalVal? = nil) { + self._float = other._float + super.init(other, meta) + } + init(_ float: Double) { + self._float = float + super.init() + } + + // CustomStringConvertible + // + override var description: String { return "\(self._float)" } + + // Hashable + // + override var hashValue: Int { return Int(self._float) } + + // MalFloat + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalFloat(self, meta) } + var float: MalFloatType { return self._float } + + private let _float: Double +} + +// Equatable +// +func ==(left: MalFloat, right: MalFloat) -> Bool { return left.float == right.float } + +// ==================== MalSymbol ==================== + +private var symbolHash = [MalSymbolType : Int]() +private var symbolArray = [MalSymbolType]() + +private func indexForSymbol(s: MalSymbolType) -> Int { + if let i = symbolHash[s] { + return i + } + + symbolArray.append(s) + symbolHash[s] = symbolArray.count - 1 + return symbolArray.count - 1 +} + +private func symbolForIndex(i: Int) -> MalSymbolType { + return symbolArray[i] +} + +final class MalSymbol: MalVal { + override init() { + self._index = indexForSymbol("") + super.init() + } + init(_ other: MalSymbol, _ meta: MalVal? = nil) { + self._index = other._index + super.init(other, meta) + } + init(_ symbol: MalSymbolType) { + self._index = indexForSymbol(symbol) + super.init() + } + + // CustomStringConvertible + // + override var description: String { return symbolForIndex(self._index) } + + // Hashable + // + override var hashValue: Int { return self._index } + + // MalSymbol + override func clone_with_meta(meta: MalVal) -> MalVal { return MalSymbol(self, meta) } + var index: Int { return self._index } + + private let _index: Int +} + +// Equatable +// +func ==(left: MalSymbol, right: MalSymbol) -> Bool { return left.index == right.index } + +// ==================== MalKeyword ==================== + +final class MalKeyword: MalVal { + override init() { + self._keyword = "" + super.init() + } + init(_ other: MalKeyword, _ meta: MalVal? = nil) { + self._keyword = other._keyword + super.init(other, meta) + } + init(_ keyword: MalKeywordType) { + self._keyword = keyword + super.init() + } + init(_ string: MalString) { + self._keyword = string.string + super.init() + } + + // CustomStringConvertible + // + override var description: String { return self._keyword } // ":" added in pr_str + + // MalKeyword + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalKeyword(self, meta) } + var keyword: MalKeywordType { return self._keyword } + + private let _keyword: MalKeywordType +} + +// Equatable +// +func ==(left: MalKeyword, right: MalKeyword) -> Bool { return left._keyword == right._keyword } + +// ==================== MalString ==================== + +final class MalString: MalVal { + override init() { + self._string = "" + super.init() + } + init(_ other: MalString, _ meta: MalVal? = nil) { + self._string = other._string + super.init(other, meta) + } + init(_ string: MalStringType) { + self._string = string + super.init() + } + + // CustomStringConvertible + // + override var description: String { return self._string } + + // MalString + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalString(self, meta) } + var string: MalStringType { return self._string } + + private let _string: MalStringType +} + +// Equatable +// +func ==(left: MalString, right: MalString) -> Bool { return left.string == right.string } + +// ==================== MalSequence ==================== + +class MalSequence: MalVal, SequenceType { + override init() { + self.count = 0 + self.isEmpty = true + super.init() + } + init(_ other: MalSequence, _ meta: MalVal? = nil) { + self.count = other.count + self.isEmpty = other.isEmpty + super.init(other, meta) + } + init(_ count: MalIntType, _ isEmpty: Bool) { + self.count = count + self.isEmpty = isEmpty + super.init() + } + + // SequenceType + // + func generate() -> MalVectorType.Generator { die() } + + // MalSequence + // + var count: MalIntType + var isEmpty: Bool + + func first() -> MalVal { die() } + func last() -> MalVal { die() } + func rest() -> MalVal { die() } + func nth(n: MalIntType) throws -> MalVal { die() } + func range_from(from: MalIntType, to: MalIntType) -> MalVal { die() } + func cons(element: MalVal) -> MalVal { die() } + func concat(seq: MalSequence) throws -> MalVal { die() } + func conj(seq: MalSequence) throws -> MalVal { die() } + func map(@noescape transform: (MalVal) -> U) -> ArraySlice { die() } + func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { die() } +} + +// Equatable +// +func ==(left: MalSequence, right: MalSequence) -> Bool { + if left.count != right.count { return false } + var left_gen = left.generate() + var right_gen = right.generate() + while true { + if let left = left_gen.next(), right = right_gen.next() { + if left != right { + return false + } + } else { + break + } + } + return true +} + +// ==================== MalList ==================== + +final class MalList: MalSequence { + override init() { + self._slice = MalVectorType() + super.init(MalIntType(self._slice.count), self._slice.isEmpty) + } + init(_ other: MalList, _ meta: MalVal? = nil) { + self._slice = other._slice + super.init(other, meta) + } + init(seq: MalSequence) { // We need the "seq" in order to differentiate it from the previous init() + self._slice = seq.reduce(MalVectorType()){ var s = $0; s.append($1); return s } + super.init(MalIntType(self._slice.count), self._slice.isEmpty) + } + init(_ slice: MalVectorType) { + self._slice = slice + super.init(MalIntType(self._slice.count), self._slice.isEmpty) + } + init(_ array: Array) { + self._slice = array[0..(_ collection: T) { + self._slice = collection.reduce(MalVectorType()){ var s = $0; s.append($1); return s } + super.init(MalIntType(self._slice.count), self._slice.isEmpty) + } + + // CustomStringConvertible + // + override var description: String { return "(" + self.map { pr_str($0) }.joinWithSeparator(" ") + ")" } + + // SequenceType + // + override func generate() -> MalVectorType.Generator { return self._slice.generate() } + + // MalSequence + // + override func first() -> MalVal { return isEmpty ? make_nil() : try! nth(0) } + override func last() -> MalVal { return try! nth(count - 1) } + override func rest() -> MalVal { return range_from(MalIntType(1), to: MalIntType(count)) } + override func nth(n: MalIntType) throws -> MalVal { guard n < count else { try throw_error("index (\(n)) out of range (\(count))") }; return self._slice[self._slice.startIndex.advancedBy(Int(n))] } + override func range_from(from: MalIntType, to: MalIntType) -> MalVal { + return from <= to && to <= count + ? make_list(self._slice[self._slice.startIndex.advancedBy(Int(from)).. MalVal { + var result = self._slice + result.insert(element, atIndex: result.startIndex) + return make_list(result) + } + override func concat(seq: MalSequence) throws -> MalVal { + var result = self._slice + if let list = as_listQ(seq) { + result.appendContentsOf(list._slice) + } else if let vector = as_vectorQ(seq) { + result.appendContentsOf(vector._slice) + } else { + try throw_error("Expected sequence, got \(seq)") + } + return make_list(result) + } + override func conj(seq: MalSequence) throws -> MalVal { + var result: Array + if let list = as_listQ(seq) { + result = list._slice.reverse() + } else if let vector = as_vectorQ(seq) { + result = vector._slice.reverse() + } else { + try throw_error("Expected sequence, got \(seq)") + } + result.appendContentsOf(self._slice) + return make_list(result) + } + override func map(@noescape transform: (MalVal) -> U) -> ArraySlice { return ArraySlice(self._slice.map(transform)) } + override func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { return self._slice.reduce(initial, combine: combine) } + + // MalList + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalList(self, meta) } + + private let _slice: MalVectorType +} + +// Equatable +// +func ==(left: MalList, right: MalList) -> Bool { + return as_sequence(left) == as_sequence(right) +} + +// ==================== MalVector ==================== + +final class MalVector: MalSequence { + override init() { + self._slice = MalVectorType() + super.init(MalIntType(self._slice.count), self._slice.isEmpty) + } + init(_ other: MalVector, _ meta: MalVal? = nil) { + self._slice = other._slice + super.init(other, meta) + } + init(seq: MalSequence) { // We need the "seq" in order to differentiate it from the previous init() + self._slice = seq.reduce(MalVectorType()){ var s = $0; s.append($1); return s } + super.init(MalIntType(self._slice.count), self._slice.isEmpty) + } + init(_ slice: MalVectorType) { + self._slice = slice + super.init(MalIntType(self._slice.count), self._slice.isEmpty) + } + init(_ array: Array) { + self._slice = array[0..(_ collection: T) { + self._slice = collection.reduce(MalVectorType()){ var s = $0; s.append($1); return s } + super.init(MalIntType(self._slice.count), self._slice.isEmpty) + } + + // CustomStringConvertible + // + override var description: String { return "[" + self.map { pr_str($0) }.joinWithSeparator(" ") + "]" } + + // SequenceType + // + override func generate() -> MalVectorType.Generator { return self._slice.generate() } + + // MalSequence + // + override func first() -> MalVal { return isEmpty ? make_nil() : try! nth(0) } + override func last() -> MalVal { return try! nth(count - 1) } + override func rest() -> MalVal { return range_from(MalIntType(1), to: MalIntType(count)) } + override func nth(n: MalIntType) throws -> MalVal { guard n < count else { try throw_error("index (\(n)) out of range (\(count))") }; return self._slice[self._slice.startIndex.advancedBy(Int(n))] } + override func range_from(from: MalIntType, to: MalIntType) -> MalVal { + return from <= to && to <= count + ? make_list(self._slice[self._slice.startIndex.advancedBy(Int(from)).. MalVal { + var result = self._slice + result.insert(element, atIndex: result.startIndex) + return make_list(result) // Yes, make_list + } + override func concat(seq: MalSequence) throws -> MalVal { + var result = self._slice + if let list = as_listQ(seq) { + result.appendContentsOf(list._slice) + } else if let vector = as_vectorQ(seq) { + result.appendContentsOf(vector._slice) + } else { + try throw_error("Expected sequence, got \(seq)") + } + return make_list(result) + } + override func conj(seq: MalSequence) throws -> MalVal { + var result = self._slice + if let list = as_listQ(seq) { + result.appendContentsOf(list._slice) + } else if let vector = as_vectorQ(seq) { + result.appendContentsOf(vector._slice) + } else { + try throw_error("Expected sequence, got \(seq)") + } + return make_vector(result) + } + override func map(@noescape transform: (MalVal) -> U) -> ArraySlice { return ArraySlice(self._slice.map(transform)) } + override func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { return self._slice.reduce(initial, combine: combine) } + + // MalVector + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalVector(self, meta) } + + private let _slice: MalVectorType +} + +// Equatable +// +func ==(left: MalVector, right: MalVector) -> Bool { + return as_sequence(left) == as_sequence(right) +} + +// ==================== MalHashMap ==================== + +final class MalHashMap: MalVal, SequenceType { + override init() { + self._hash = MalHashType() + self.count = MalIntType(self._hash.count) + self.isEmpty = self._hash.isEmpty + super.init() + } + init(_ other: MalHashMap, _ meta: MalVal? = nil) { + self._hash = other._hash + self.count = MalIntType(self._hash.count) + self.isEmpty = self._hash.isEmpty + super.init(other, meta) + } + init(_ hash: MalHashType) { + self._hash = hash + self.count = MalIntType(self._hash.count) + self.isEmpty = self._hash.isEmpty + super.init() + } + convenience init(_ seq: MalSequence) { + var hash = MalHashType() + for var index: MalIntType = 0; index < seq.count; index += 2 { + hash[try! seq.nth(index)] = try! seq.nth(index + 1) + } + self.init(hash) + } + convenience init(_ collection: T) { + // TBD: Use SequenceType/generate + var hash = MalHashType() + for var index = collection.startIndex; index != collection.endIndex; { + let key = collection[index++] + let value = collection[index++] + hash[key] = value + } + self.init(hash) + } + + // CustomStringConvertible + // + override var description: String { + // TBD: Use reduce + var a = [String]() + for (k, v) in self._hash { + a.append("\(pr_str(k)) \(pr_str(v))") + } + let s = a.joinWithSeparator(" ") + return "{\(s)}" + } + + // SequenceType + // + func generate() -> MalHashType.Generator { return self._hash.generate() } + + // MalHashMap + // + let count: MalIntType + let isEmpty: Bool + var hash: MalHashType { return self._hash } + var keys: MalVal { return make_list(self._hash.keys) } + var values: MalVal { return make_list(self._hash.values) } + + override func clone_with_meta(meta: MalVal) -> MalVal { return MalHashMap(self, meta) } + + func value_for(key: MalVal) -> MalVal? { + return self._hash[key] + } + + private let _hash: MalHashType +} + +// Equatable +// +func ==(left: MalHashMap, right: MalHashMap) -> Bool { + if left.count != right.count { return false } + var left_gen = left.generate() + var right_gen = right.generate() + while true { + if let left = left_gen.next(), let right = right_gen.next() { + if left.0 != right.0 || left.1 != right.1 { + return false + } + } else { + break + } + } + return true +} + +// ==================== MalAtom ==================== + +final class MalAtom: MalVal { + override init() { + self._object = make_nil() + super.init() + } + init(_ other: MalAtom, _ meta: MalVal? = nil) { + self._object = other._object + super.init(other, meta) + } + init(object: MalVal) { + self._object = object + super.init() + } + + // CustomStringConvertible + // + override var description: String { return "(atom \(self._object.description))" } + + // MalAtom + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalAtom(self, meta) } + var object: MalVal { return self._object } + + func set_object(obj: MalVal) -> MalVal { + self._object = obj + return obj + } + + private var _object: MalVal +} + +// Equatable +// +func ==(left: MalAtom, right: MalAtom) -> Bool { return left.object == right.object } + +// ==================== MalFunction ==================== + +class MalFunction: MalVal { + override init() { + super.init() + } + init(_ other: MalFunction, _ meta: MalVal? = nil) { + super.init(other, meta) + } + + // MalFunction + // + func apply(exprs: MalSequence) throws -> MalVal { die() } +} + +// ==================== MalClosure ==================== + +final class MalClosure: MalFunction { + typealias Evaluator = (MalVal, Environment) throws -> MalVal + typealias Parameters = (eval: Evaluator, args: MalSequence, body: MalVal, env: Environment) + + override init() { + self._eval = nil + self._args = as_sequence(make_list()) + self._body = make_nil() + self._env = Environment(outer: nil) + super.init() + } + init(_ other: MalClosure, _ meta: MalVal? = nil) { + self._eval = other._eval + self._args = other._args + self._body = other._body + self._env = other._env + super.init(other, meta) + } + init(_ p: Parameters) { + self._eval = p.eval + self._args = p.args + self._body = p.body + self._env = p.env + super.init() + } + + // CustomStringConvertible + // + override var description: String { return "#: (fn* \(self._args.description) \(self._body.description))" } + + // MalFunction + // + override func apply(exprs: MalSequence) throws -> MalVal { + let new_env = Environment(outer: self._env) + let _ = try new_env.set_bindings(self._args, with_exprs: exprs) + // Calling EVAL indirectly via an 'eval' data member is a bit of a hack. + // We can't call EVAL directly because this file (types.swift) needs to + // be used with many different versions of the main MAL file + // (step[0-10]*.swift), and EVAL is declared differently across those + // versions. By using this indirection, we avoid that problem. + return try self._eval(self._body, new_env) + } + + // MalClosure + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalClosure(self, meta) } + + var args: MalSequence { return self._args } + var body: MalVal { return self._body } + var env: Environment { return self._env } + + private let _eval: Evaluator! + private let _args: MalSequence + private let _body: MalVal + private let _env: Environment +} + +// Equatable +// +func ==(left: MalClosure, right: MalClosure) -> Bool { return false } + +// ==================== MalBuiltin ==================== + +final class MalBuiltin: MalFunction { + typealias Signature = (MalSequence) throws -> MalVal + + override init() { + self._fn = nil + super.init() + } + init(_ other: MalBuiltin, _ meta: MalVal? = nil) { + self._fn = other._fn + super.init(other, meta) + } + init(_ fn: Signature) { + self._fn = fn + super.init() + } + + // CustomStringConvertible + // + override var description: String { return "#" } + + // MalFunction + // + override func apply(exprs: MalSequence) throws -> MalVal { return try self._fn(exprs) } + + // MalBuiltin + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalBuiltin(self, meta) } + + private let _fn: Signature! +} + +// Equatable +// +func ==(left: MalBuiltin, right: MalBuiltin) -> Bool { return false } // Can't compare function references in Swift + +// ==================== MalMacro ==================== + +final class MalMacro : MalVal { + override init() { + self._closure = as_closure(make_closure()) + super.init() + } + init(_ other: MalMacro, _ meta: MalVal? = nil) { + self._closure = other._closure + super.init(other, meta) + } + init(_ closure: MalClosure) { + self._closure = closure + super.init() + } + + // CustomStringConvertible + // + override var description: String { return self._closure.description } + + // MalMacro + // + override func clone_with_meta(meta: MalVal) -> MalVal { return MalMacro(self, meta) } + + var args: MalSequence { return self._closure.args } + var body: MalVal { return self._closure.body } + var env: Environment { return self._closure.env } + + private let _closure: MalClosure +} + +// Equatable +// +func ==(left: MalMacro, right: MalMacro) -> Bool { return false } + + +// ==================== Constructors ==================== + +// ----- Default ----- + +func make_unknown () -> MalVal { return kUnknown } +func make_nil () -> MalVal { return kNil } +func make_true () -> MalVal { return kTrue } +func make_false () -> MalVal { return kFalse } +func make_comment () -> MalVal { return kComment } +func make_integer () -> MalVal { return MalInteger() } +func make_float () -> MalVal { return MalFloat() } +func make_symbol () -> MalVal { return MalSymbol() } +func make_keyword () -> MalVal { return MalKeyword() } +func make_string () -> MalVal { return MalString() } +func make_list () -> MalVal { return MalList() } +func make_vector () -> MalVal { return MalVector() } +func make_hashmap () -> MalVal { return MalHashMap() } +func make_atom () -> MalVal { return MalAtom() } +func make_closure () -> MalVal { return MalClosure() } +func make_builtin () -> MalVal { return MalBuiltin() } +func make_macro () -> MalVal { return MalMacro() } + +// ----- Copy ----- + +func make_integer (v: MalInteger) -> MalVal { return MalInteger(v) } +func make_float (v: MalFloat) -> MalVal { return MalFloat(v) } +func make_symbol (v: MalSymbol) -> MalVal { return MalSymbol(v) } +func make_keyword (v: MalKeyword) -> MalVal { return MalKeyword(v) } +func make_string (v: MalString) -> MalVal { return MalString(v) } +func make_list (v: MalList) -> MalVal { return MalList(v) } +func make_vector (v: MalVector) -> MalVal { return MalVector(v) } +func make_hashmap (v: MalHashMap) -> MalVal { return MalHashMap(v) } +func make_atom (v: MalAtom) -> MalVal { return MalAtom(v) } +func make_closure (v: MalClosure) -> MalVal { return MalClosure(v) } +func make_builtin (v: MalBuiltin) -> MalVal { return MalBuiltin(v) } +func make_macro (v: MalMacro) -> MalVal { return MalMacro(v) } + +// ----- Parameterized ----- + +func make_integer (v: MalIntType) -> MalVal { return MalInteger(v) } +func make_float (v: MalFloatType) -> MalVal { return MalFloat(v) } +func make_symbol (v: String) -> MalVal { return MalSymbol(v) } +func make_keyword (v: String) -> MalVal { return MalKeyword(v) } +func make_keyword (v: MalString) -> MalVal { return MalKeyword(v) } +func make_string (v: String) -> MalVal { return MalString(v) } +func make_list (v: MalSequence) -> MalVal { return MalList(seq: v) } +func make_list (v: MalVectorType) -> MalVal { return MalList(v) } +func make_list (v: Array) -> MalVal { return MalList(v) } +func make_list_from (v: MalVal...) -> MalVal { return MalList(v) } +func make_list + (v: T) -> MalVal { return MalList(v) } +func make_vector (v: MalSequence) -> MalVal { return MalVector(seq: v) } +func make_vector (v: MalVectorType) -> MalVal { return MalVector(v) } +func make_vector (v: Array) -> MalVal { return MalVector(v) } +func make_vector + (v: T) -> MalVal { return MalVector(v) } +func make_hashmap (v: MalSequence) -> MalVal { return MalHashMap(v) } +func make_hashmap (v: MalHashType) -> MalVal { return MalHashMap(v) } +func make_hashmap + (v: T) -> MalVal { return MalHashMap(v) } +func make_atom (v: MalVal) -> MalVal { return MalAtom(object: v) } +func make_closure (v: MalClosure.Parameters) -> MalVal { return MalClosure(v) } +func make_builtin (v: MalBuiltin.Signature) -> MalVal { return MalBuiltin(v) } +func make_macro (v: MalClosure) -> MalVal { return MalMacro(v) } + +// ==================== Predicates ==================== + +// ----- Simple ----- + +func is_unknown (v: MalVal) -> Bool { return v is MalUnknown } +func is_nil (v: MalVal) -> Bool { return v is MalNil } +func is_true (v: MalVal) -> Bool { return v is MalTrue } +func is_false (v: MalVal) -> Bool { return v is MalFalse } +func is_comment (v: MalVal) -> Bool { return v is MalComment } +func is_integer (v: MalVal) -> Bool { return v is MalInteger } +func is_float (v: MalVal) -> Bool { return v is MalFloat } +func is_symbol (v: MalVal) -> Bool { return v is MalSymbol } +func is_keyword (v: MalVal) -> Bool { return v is MalKeyword } +func is_string (v: MalVal) -> Bool { return v is MalString } +func is_list (v: MalVal) -> Bool { return v is MalList } +func is_vector (v: MalVal) -> Bool { return v is MalVector } +func is_hashmap (v: MalVal) -> Bool { return v is MalHashMap } +func is_atom (v: MalVal) -> Bool { return v is MalAtom } +func is_closure (v: MalVal) -> Bool { return v is MalClosure } +func is_builtin (v: MalVal) -> Bool { return v is MalBuiltin } +func is_macro (v: MalVal) -> Bool { return v is MalMacro } + +// ----- Compound ----- + +func is_truthy (v: MalVal) -> Bool { return !is_falsey(v) } +func is_falsey (v: MalVal) -> Bool { return is_nil(v) || is_false(v) } +func is_number (v: MalVal) -> Bool { return is_integer(v) || is_float(v) } +func is_sequence (v: MalVal) -> Bool { return is_list(v) || is_vector(v) } +func is_function (v: MalVal) -> Bool { return is_closure(v) || is_builtin(v) } + +// ==================== Converters/Extractors ==================== + +func as_unknown (v: MalVal) -> MalUnknown { return v as! MalUnknown } +func as_nil (v: MalVal) -> MalNil { return v as! MalNil } +func as_true (v: MalVal) -> MalTrue { return v as! MalTrue } +func as_false (v: MalVal) -> MalFalse { return v as! MalFalse } +func as_comment (v: MalVal) -> MalComment { return v as! MalComment } +func as_integer (v: MalVal) -> MalInteger { return v as! MalInteger } +func as_float (v: MalVal) -> MalFloat { return v as! MalFloat } +func as_symbol (v: MalVal) -> MalSymbol { return v as! MalSymbol } +func as_keyword (v: MalVal) -> MalKeyword { return v as! MalKeyword } +func as_string (v: MalVal) -> MalString { return v as! MalString } +func as_list (v: MalVal) -> MalList { return v as! MalList } +func as_vector (v: MalVal) -> MalVector { return v as! MalVector } +func as_hashmap (v: MalVal) -> MalHashMap { return v as! MalHashMap } +func as_atom (v: MalVal) -> MalAtom { return v as! MalAtom } +func as_closure (v: MalVal) -> MalClosure { return v as! MalClosure } +func as_builtin (v: MalVal) -> MalBuiltin { return v as! MalBuiltin } +func as_macro (v: MalVal) -> MalMacro { return v as! MalMacro } + +func as_sequence (v: MalVal) -> MalSequence { return v as! MalSequence } +func as_function (v: MalVal) -> MalFunction { return v as! MalFunction } + +func as_inttype (v: MalVal) -> MalIntType { return as_integer(v).integer } +func as_floattype (v: MalVal) -> MalFloatType { return as_float(v).float } +func as_stringtype (v: MalVal) -> MalStringType { return as_string(v).string } + +func as_inttype (v: MalInteger) -> MalIntType { return v.integer } +func as_floattype (v: MalFloat) -> MalFloatType { return v.float } +func as_stringtype (v: MalString) -> MalStringType { return v.string } + +func as_unknownQ (v: MalVal) -> MalUnknown? { return v as? MalUnknown } +func as_nilQ (v: MalVal) -> MalNil? { return v as? MalNil } +func as_trueQ (v: MalVal) -> MalTrue? { return v as? MalTrue } +func as_falseQ (v: MalVal) -> MalFalse? { return v as? MalFalse } +func as_commentQ (v: MalVal) -> MalComment? { return v as? MalComment } +func as_integerQ (v: MalVal) -> MalInteger? { return v as? MalInteger } +func as_floatQ (v: MalVal) -> MalFloat? { return v as? MalFloat } +func as_symbolQ (v: MalVal) -> MalSymbol? { return v as? MalSymbol } +func as_keywordQ (v: MalVal) -> MalKeyword? { return v as? MalKeyword } +func as_stringQ (v: MalVal) -> MalString? { return v as? MalString } +func as_listQ (v: MalVal) -> MalList? { return v as? MalList } +func as_vectorQ (v: MalVal) -> MalVector? { return v as? MalVector } +func as_hashmapQ (v: MalVal) -> MalHashMap? { return v as? MalHashMap } +func as_atomQ (v: MalVal) -> MalAtom? { return v as? MalAtom } +func as_closureQ (v: MalVal) -> MalClosure? { return v as? MalClosure } +func as_builtinQ (v: MalVal) -> MalBuiltin? { return v as? MalBuiltin } +func as_macroQ (v: MalVal) -> MalMacro? { return v as? MalMacro } + +func as_sequenceQ (v: MalVal) -> MalSequence? { return v as? MalSequence } +func as_functionQ (v: MalVal) -> MalFunction? { return v as? MalFunction } + +func as_inttypeQ (v: MalVal) -> MalIntType? { return as_integerQ(v)?.integer } +func as_floattypeQ (v: MalVal) -> MalFloatType? { return as_floatQ(v)?.float } +func as_stringtypeQ (v: MalVal) -> MalStringType? { return as_stringQ(v)?.string } + +// ==================== Exceptions ==================== + +enum MalException: ErrorType, CustomStringConvertible { + case None + case Message(String) + case Object(MalVal) + + var exception: MalVal { + switch self { + case .None: + return make_nil() + case .Message(let v): + return make_string(v) + case .Object(let v): + return v + } + } + + // CustomStringConvertible + // + var description: String { + switch self { + case .None: + return "NIL Exception" + case .Message(let v): + return v + case .Object(let v): + return v.description + } + } +} + +@noreturn +func throw_error(v: String) throws { throw MalException.Message(v) } + +@noreturn +func throw_error(v: MalVal) throws { throw MalException.Object(v) } + +// ==================== Utilities ==================== + +@noreturn private func die() { + preconditionFailure("Should not get here") +} + +func get_meta(v: MalVal) -> MalVal? { + return v.meta +} + +func with_meta(obj: MalVal, _ meta: MalVal) -> MalVal { + return obj.clone_with_meta(meta) +} + +func unescape(s: String) -> String { + var index = 0 + var prev_is_escape = false + var str = "" + let chars = s.characters + for ch in chars { + if index == chars.count - 1 { continue } + if index++ == 0 { continue } + if prev_is_escape { + prev_is_escape = false + if ch == "n" { str.appendContentsOf("\n") } + else if ch == "r" { str.appendContentsOf("\r") } + else if ch == "t" { str.appendContentsOf("\t") } + else { str.append(ch) } + } else if ch == "\\" { + prev_is_escape = true + } else { + str.append(ch) + } + } + return str +} + +func escape(s: String) -> String { + var str = "" + let chars = s.characters + for ch in chars { + if ch == "\n" { str.appendContentsOf("\\n"); continue } + if ch == "\r" { str.appendContentsOf("\\r"); continue } + if ch == "\t" { str.appendContentsOf("\\t"); continue } + if ch == "\"" || ch == "\\" { str.appendContentsOf("\\") } + str.append(ch) + } + str = "\"" + str + "\"" + return str +} diff --git a/impls/swift/types_enum.swift b/impls/swift/types_enum.swift index 1f610c318d..e29518f421 100644 --- a/impls/swift/types_enum.swift +++ b/impls/swift/types_enum.swift @@ -1,1010 +1,1010 @@ -//****************************************************************************** -// MAL - types, implemented as a Swift "enum". -//****************************************************************************** - -import Foundation - -// ===== Types / Constants / Variables ===== - -typealias MalProtocol = protocol - -typealias MalIntType = Int64 -typealias MalFloatType = Double -typealias MalSymbolType = String -typealias MalKeywordType = String -typealias MalStringType = String -typealias MalVectorType = ArraySlice -typealias MalHashType = Dictionary - -typealias MalInteger = MalIntType -typealias MalFloat = MalFloatType -typealias MalSymbol = MalSymbolType -typealias MalKeyword = MalKeywordType -typealias MalString = MalStringType - -private let kUnknown = MalVal.TypeUnknown -private let kNil = MalVal.TypeNil -private let kTrue = MalVal.TypeTrue -private let kFalse = MalVal.TypeFalse -private let kComment = MalVal.TypeComment - -// ==================== MalSequence ==================== - -class MalSequence : MalProtocol, SequenceType { - init() { - self.count = 0 - self.isEmpty = true - } - init(_ seq: MalSequence) { - self.count = seq.count - self.isEmpty = seq.isEmpty - } - init(_ count: MalIntType) { - self.count = count - self.isEmpty = self.count == 0 - } - - // CustomStringConvertible - // - var description: String { die() } - - // Hashable - // - var hashValue: Int { die() } - - // SequenceType - // - func generate() -> MalVectorType.Generator { die() } - - // MalSequence - // - let count: MalIntType - let isEmpty: Bool - - func first() -> MalVal { die() } - func last() -> MalVal { die() } - func rest() -> MalVal { die() } - func nth(n: MalIntType) throws -> MalVal { die() } - func range_from(from: MalIntType, to: MalIntType) -> MalVal { die() } - func cons(element: MalVal) -> MalVal { die() } - func concat(seq: MalSequence) throws -> MalVal { die() } - func conj(seq: MalSequence) throws -> MalVal { die() } - func map(@noescape transform: (MalVal) -> U) -> ArraySlice { die() } - func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { die() } -} - -// Equatable -// -func ==(left: MalSequence, right: MalSequence) -> Bool { - if left.count != right.count { return false } - var left_gen = left.generate() - var right_gen = right.generate() - while true { - if let left = left_gen.next(), right = right_gen.next() { - if left != right { - return false - } - } else { - break - } - } - return true -} - -// ==================== MalList ==================== - -final class MalList : MalSequence { - override convenience init() { - self.init(MalVectorType()) - } - init(_ other: MalList, _ meta: MalVal?) { - self._slice = other._slice - self._meta = meta - super.init(other) - } - override convenience init(_ seq: MalSequence) { - if let list = seq as? MalList { self.init(list._slice) } - else - if let vector = seq as? MalVector { self.init(vector._slice) } - else - { self.init(seq.reduce(MalVectorType()){ var s = $0; s.append($1); return s }) } - } - init(_ slice: MalVectorType) { - self._slice = slice - self._meta = nil - super.init(MalIntType(self._slice.count)) - } - convenience init(_ array: Array) { - self.init(array[0..(_ collection: T) { - self.init(collection.reduce(MalVectorType()){ var s = $0; s.append($1); return s }) - } - - // CustomStringConvertible - // - override var description: String { return "(" + self.map { pr_str($0) }.joinWithSeparator(" ") + ")" } - - // Hashable - // - override var hashValue: Int { return description.hashValue } - - // SequenceType - // - override func generate() -> MalVectorType.Generator { return self._slice.generate() } - - // MalSequence - // - override func first() -> MalVal { return isEmpty ? make_nil() : try! nth(0) } - override func last() -> MalVal { return try! nth(count - 1) } - override func rest() -> MalVal { return range_from(MalIntType(1), to: MalIntType(count)) } - override func nth(n: MalIntType) throws -> MalVal { guard n < count else { try throw_error("index (\(n)) out of range (\(count))") }; return self._slice[self._slice.startIndex.advancedBy(Int(n))] } - override func range_from(from: MalIntType, to: MalIntType) -> MalVal { - return from <= to && to <= count - ? make_list(self._slice[self._slice.startIndex.advancedBy(Int(from)).. MalVal { - var result = self._slice - result.insert(element, atIndex: result.startIndex) - return make_list(result) - } - override func concat(seq: MalSequence) throws -> MalVal { - var result = self._slice - if let list = as_listQ(seq) { - result.appendContentsOf(list._slice) - } else if let vector = as_vectorQ(seq) { - result.appendContentsOf(vector._slice) - } else { - try throw_error("Expected sequence, got \(seq)") - } - return make_list(result) - } - override func conj(seq: MalSequence) throws -> MalVal { - var result: Array - if let list = as_listQ(seq) { - result = list._slice.reverse() - } else if let vector = as_vectorQ(seq) { - result = vector._slice.reverse() - } else { - try throw_error("Expected sequence, got \(seq)") - } - result.appendContentsOf(self._slice) - return make_list(result) - } - override func map(@noescape transform: (MalVal) -> U) -> ArraySlice { return ArraySlice(self._slice.map(transform)) } - override func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { return self._slice.reduce(initial, combine: combine) } - - // MalList - // - var meta: MalVal? { return self._meta } - - private let _slice: MalVectorType - private let _meta: MalVal? -} - -// Equatable -// -func ==(left: MalList, right: MalList) -> Bool { - return (left as MalSequence) == (right as MalSequence) -} - -// ==================== MalVector ==================== - -final class MalVector : MalSequence { - override convenience init() { - self.init(MalVectorType()) - } - init(_ other: MalVector, _ meta: MalVal?) { - self._slice = other._slice - self._meta = meta - super.init(other) - } - override convenience init(_ seq: MalSequence) { - if let list = seq as? MalList { self.init(list._slice) } - else - if let vector = seq as? MalVector { self.init(vector._slice) } - else - { self.init(seq.reduce(MalVectorType()){ var s = $0; s.append($1); return s }) } - } - init(_ slice: MalVectorType) { - self._slice = slice - self._meta = nil - super.init(MalIntType(self._slice.count)) - } - convenience init(_ array: Array) { - self.init(array[0..(_ collection: T) { - self.init(collection.reduce(MalVectorType()){ var s = $0; s.append($1); return s }) - } - - // CustomStringConvertible - // - override var description: String { return "[" + self.map { pr_str($0) }.joinWithSeparator(" ") + "]" } - - // Hashable - // - override var hashValue: Int { return description.hashValue } - - // SequenceType - // - override func generate() -> MalVectorType.Generator { return self._slice.generate() } - - // MalSequence - // - override func first() -> MalVal { return isEmpty ? make_nil() : try! nth(0) } - override func last() -> MalVal { return try! nth(count - 1) } - override func rest() -> MalVal { return range_from(MalIntType(1), to: MalIntType(count)) } - override func nth(n: MalIntType) throws -> MalVal { guard n < count else { try throw_error("index (\(n)) out of range (\(count))") }; return self._slice[self._slice.startIndex.advancedBy(Int(n))] } - override func range_from(from: MalIntType, to: MalIntType) -> MalVal { - return from <= to && to <= count - ? make_list(self._slice[self._slice.startIndex.advancedBy(Int(from)).. MalVal { - var result = self._slice - result.insert(element, atIndex: result.startIndex) - return make_list(result) // Yes, make_list - } - override func concat(seq: MalSequence) throws -> MalVal { - var result = self._slice - if let list = as_listQ(seq) { - result.appendContentsOf(list._slice) - } else if let vector = as_vectorQ(seq) { - result.appendContentsOf(vector._slice) - } else { - try throw_error("Expected sequence, got \(seq)") - } - return make_vector(result) - } - override func conj(seq: MalSequence) throws -> MalVal { - var result = self._slice - if let list = as_listQ(seq) { - result.appendContentsOf(list._slice) - } else if let vector = as_vectorQ(seq) { - result.appendContentsOf(vector._slice) - } else { - try throw_error("Expected sequence, got \(seq)") - } - return make_vector(result) - } - override func map(@noescape transform: (MalVal) -> U) -> ArraySlice { return ArraySlice(self._slice.map(transform)) } - override func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { return self._slice.reduce(initial, combine: combine) } - - // MalVector - // - var meta: MalVal? { return self._meta } - - private let _slice: MalVectorType - private let _meta: MalVal? -} - -// Equatable -// -func ==(left: MalVector, right: MalVector) -> Bool { - return (left as MalSequence) == (right as MalSequence) -} - -// ==================== MalHashMap ==================== - -final class MalHashMap : MalProtocol, SequenceType { - convenience init() { - self.init(MalHashType()) - } - init(_ other: MalHashMap, _ meta: MalVal?) { - self._hash = other._hash - self._meta = meta - self.count = MalIntType(self._hash.count) - self.isEmpty = self._hash.isEmpty - } - init(_ hash: MalHashType) { - self._hash = hash - self._meta = nil - self.count = MalIntType(self._hash.count) - self.isEmpty = self._hash.isEmpty - } - convenience init(_ seq: MalSequence) { - var hash = MalHashType() - for var index: MalIntType = 0; index < seq.count; index += 2 { - hash[try! seq.nth(index)] = try! seq.nth(index + 1) - } - self.init(hash) - } - convenience init(_ collection: T) { - var hash = MalHashType() - for var index = collection.startIndex; index != collection.endIndex; { - let key = collection[index++] - let value = collection[index++] - hash[key] = value - } - self.init(hash) - } - - // CustomStringConvertible - // - var description: String { - var a = [String]() - for (k, v) in self._hash { - a.append("\(pr_str(k)) \(pr_str(v))") - } - let s = a.joinWithSeparator(" ") - return "{\(s)}" - } - - // Hashable - // - var hashValue: Int { return description.hashValue } - - // SequenceType - // - func generate() -> MalHashType.Generator { return self._hash.generate() } - - // MalHashMap - // - let count: MalIntType - let isEmpty: Bool - var hash: MalHashType { return self._hash } - var keys: MalVal { return make_list(self._hash.keys) } - var values: MalVal { return make_list(self._hash.values) } - var meta: MalVal? { return self._meta } - - func value_for(key: MalVal) -> MalVal? { - return self._hash[key] - } - - private let _hash: MalHashType - private let _meta: MalVal? -} - -// Equatable -// -func ==(left: MalHashMap, right: MalHashMap) -> Bool { - if left.count != right.count { return false } - var left_gen = left.generate() - var right_gen = right.generate() - while true { - if let left = left_gen.next(), right = right_gen.next() { - if left.0 != right.0 || left.1 != right.1 { - return false - } - } else { - break - } - } - return true -} - -// ==================== MalAtom ==================== - -final class MalAtom : MalProtocol { - convenience init() { - self.init(make_nil()) - } - init(_ other: MalAtom, _ meta: MalVal?) { - self._object = other._object - self._meta = meta - } - init(_ object: MalVal) { - self._object = object - self._meta = nil - } - - // CustomStringConvertible - // - var description: String { return "(atom \(pr_str(self._object)))" } - - // Hashable - // - var hashValue: Int { return description.hashValue } - - // MalAtom - // - var object: MalVal { return self._object } - var meta: MalVal? { return self._meta } - - func set_object(obj: MalVal) -> MalVal { - self._object = obj - return obj - } - - private var _object: MalVal - private let _meta: MalVal? -} - -// Equatable -// -func ==(left: MalAtom, right: MalAtom) -> Bool { return left.object == right.object } - -// ==================== MalFunction ==================== - -class MalFunction : MalProtocol { - init() { - } - init(_ other: MalFunction) { - } - - // CustomStringConvertible - // - var description: String { die() } - - // Hashable - // - var hashValue: Int { die() } - - // MalFunction - // - func apply(exprs: MalSequence) throws -> MalVal { die() } -} - -// Equatable -// -func ==(left: MalFunction, right: MalFunction) -> Bool { return false } - -// ==================== MalClosure ==================== - - -final class MalClosure : MalFunction { - typealias Evaluator = (MalVal, Environment) throws -> MalVal - typealias Parameters = (eval: Evaluator, args: MalSequence, body: MalVal, env: Environment) - - override convenience init() { - self.init(( - eval: {(a: MalVal, b: Environment) -> MalVal in make_nil() }, - args: as_sequence(make_list()), - body: make_nil(), - env: Environment(outer: nil) - )) - } - init(_ other: MalClosure, _ meta: MalVal?) { - self._eval = other._eval - self._args = other._args - self._body = other._body - self._env = other._env - self._meta = meta - super.init(other) - } - init(_ p: Parameters) { - self._eval = p.eval - self._args = p.args - self._body = p.body - self._env = p.env - self._meta = nil - super.init() - } - - // CustomStringConvertible - // - override var description: String { return "#: (fn* \(self._args.description) \(self._body.description))" } - - // Hashable - // - override var hashValue: Int { return description.hashValue } - - // MalFunction - // - override func apply(exprs: MalSequence) throws -> MalVal { - let new_env = Environment(outer: self._env) - let _ = try new_env.set_bindings(self._args, with_exprs: exprs) - // Calling EVAL indirectly via an 'eval' data member is a bit of a hack. - // We can't call EVAL directly because this file (types.swift) needs to - // be used with many different versions of the main MAL file - // (step[0-10]*.swift), and EVAL is declared differently across those - // versions. By using this indirection, we avoid that problem. - return try self._eval(self._body, new_env) - } - - var args: MalSequence { return self._args } - var body: MalVal { return self._body } - var env: Environment { return self._env } - var meta: MalVal? { return self._meta } - - private let _eval: Evaluator! - private let _args: MalSequence - private let _body: MalVal - private let _env: Environment - private let _meta: MalVal? -} - -// Equatable -// -func ==(left: MalClosure, right: MalClosure) -> Bool { return false } - -// ==================== MalBuiltin ==================== - -final class MalBuiltin : MalFunction { - typealias Signature = (MalSequence) throws -> MalVal - - override convenience init() { - self.init( {(MalSequence) -> MalVal in make_nil()} ) - } - init(_ other: MalBuiltin, _ meta: MalVal?) { - self._fn = other._fn - self._meta = meta - super.init(other) - } - init(_ fn: Signature) { - self._fn = fn - self._meta = nil - super.init() - } - - // CustomStringConvertible - // - override var description: String { return "#" } - - // Hashable - // - override var hashValue: Int { return description.hashValue } - - // MalBuiltin - // - override func apply(exprs: MalSequence) throws -> MalVal { return try self._fn(exprs) } - var meta: MalVal? { return self._meta } - - private let _fn: Signature! - private let _meta: MalVal? -} - -// Equatable -// -func ==(left: MalBuiltin, right: MalBuiltin) -> Bool { return false } // Can't compare function references in Swift - -// ==================== MalMacro ==================== - -final class MalMacro : MalProtocol { - convenience init() { - self.init(as_closure(make_closure())) - } - init(_ other: MalMacro, _ meta: MalVal?) { - self._closure = other._closure - self._meta = meta - } - init(_ closure: MalClosure) { - self._closure = closure - self._meta = nil - } - - // CustomStringConvertible - // - var description: String { return self._closure.description } - - // Hashable - // - var hashValue: Int { return description.hashValue } - - var args: MalSequence { return self._closure.args } - var body: MalVal { return self._closure.body } - var env: Environment { return self._closure.env } - var meta: MalVal? { return self._meta } - - private let _closure: MalClosure - private let _meta: MalVal? -} - -// Equatable -// -func ==(left: MalMacro, right: MalMacro) -> Bool { return false } - -// ==================== MalVal ==================== - -enum MalVal : MalProtocol { - case TypeUnknown - case TypeNil - case TypeTrue - case TypeFalse - case TypeComment - case TypeInteger (MalInteger) - case TypeFloat (MalFloat) - case TypeSymbol (MalSymbol) - case TypeKeyword (MalKeyword) - case TypeString (MalString) - case TypeList (MalList) - case TypeVector (MalVector) - case TypeHashMap (MalHashMap) - case TypeAtom (MalAtom) - case TypeClosure (MalClosure) - case TypeBuiltin (MalBuiltin) - case TypeMacro (MalMacro) - - // CustomStringConvertible - // - var description: String { - switch self { - case .TypeUnknown: return "unknown" - case .TypeNil: return "nil" - case .TypeTrue: return "true" - case .TypeFalse: return "false" - case .TypeComment: return "comment" - case .TypeInteger (let v): return v.description - case .TypeFloat (let v): return v.description - case .TypeSymbol (let v): return v - case .TypeKeyword (let v): return v - case .TypeString (let v): return v - case .TypeList (let v): return v.description - case .TypeVector (let v): return v.description - case .TypeHashMap (let v): return v.description - case .TypeAtom (let v): return v.description - case .TypeClosure (let v): return v.description - case .TypeBuiltin (let v): return v.description - case .TypeMacro (let v): return v.description - } - } - - // Hashable - // - var hashValue: Int { - switch self { - case .TypeUnknown: return 0 - case .TypeNil: return 0 - case .TypeTrue: return 0 - case .TypeFalse: return 0 - case .TypeComment: return 0 - case .TypeInteger (let v): return v.hashValue - case .TypeFloat (let v): return v.hashValue - case .TypeSymbol (let v): return v.hashValue - case .TypeKeyword (let v): return v.hashValue - case .TypeString (let v): return v.hashValue - case .TypeList (let v): return v.hashValue - case .TypeVector (let v): return v.hashValue - case .TypeHashMap (let v): return v.hashValue - case .TypeAtom (let v): return v.hashValue - case .TypeClosure (let v): return v.hashValue - case .TypeBuiltin (let v): return v.hashValue - case .TypeMacro (let v): return v.hashValue - } - } -} - -// Equatable -// -func ==(left: MalVal, right: MalVal) -> Bool { - switch (left, right) { - case (.TypeUnknown, .TypeUnknown): return true - case (.TypeNil, .TypeNil): return true - case (.TypeTrue, .TypeTrue): return true - case (.TypeFalse, .TypeFalse): return true - case (.TypeComment, .TypeComment): return false - case (.TypeInteger (let vLeft), .TypeInteger (let vRight)): return vLeft == vRight - case (.TypeFloat (let vLeft), .TypeFloat (let vRight)): return vLeft == vRight - case (.TypeSymbol (let vLeft), .TypeSymbol (let vRight)): return vLeft == vRight - case (.TypeKeyword (let vLeft), .TypeKeyword (let vRight)): return vLeft == vRight - case (.TypeString (let vLeft), .TypeString (let vRight)): return vLeft == vRight - case (.TypeList (let vLeft), .TypeList (let vRight)): return vLeft == vRight - case (.TypeVector (let vLeft), .TypeVector (let vRight)): return vLeft == vRight - case (.TypeHashMap (let vLeft), .TypeHashMap (let vRight)): return vLeft == vRight - case (.TypeAtom (let vLeft), .TypeAtom (let vRight)): return vLeft == vRight - case (.TypeClosure (let vLeft), .TypeClosure (let vRight)): return vLeft == vRight - case (.TypeBuiltin (let vLeft), .TypeBuiltin (let vRight)): return vLeft == vRight - case (.TypeMacro (let vLeft), .TypeMacro (let vRight)): return vLeft == vRight - - case (.TypeList (let vLeft), .TypeVector (let vRight)): return vLeft == vRight - case (.TypeVector (let vLeft), .TypeList (let vRight)): return vLeft == vRight - - default: return false - } -} - -func ==(left: MalList, right: MalVector) -> Bool { - if left.count != right.count { return false } - var left_gen = left.generate() - var right_gen = right.generate() - while true { - if let left = left_gen.next(), right = right_gen.next() { - if left != right { - return false - } - } else { - break - } - } - return true -} - -func ==(left: MalVector, right: MalList) -> Bool { - if left.count != right.count { return false } - var left_gen = left.generate() - var right_gen = right.generate() - while true { - if let left = left_gen.next(), right = right_gen.next() { - if left != right { - return false - } - } else { - break - } - } - return true -} - -// ==================== Constructors ==================== - -// ----- Default ----- - -func make_unknown () -> MalVal { return kUnknown } -func make_nil () -> MalVal { return kNil } -func make_true () -> MalVal { return kTrue } -func make_false () -> MalVal { return kFalse } -func make_comment () -> MalVal { return kComment } -func make_integer () -> MalVal { return make_integer (MalInteger()) } -func make_float () -> MalVal { return make_float (MalFloat()) } -func make_symbol () -> MalVal { return make_symbol (MalSymbol()) } -func make_keyword () -> MalVal { return make_keyword (MalKeyword()) } -func make_string () -> MalVal { return make_string (MalString()) } -func make_list () -> MalVal { return make_list (MalList()) } -func make_vector () -> MalVal { return make_vector (MalVector()) } -func make_hashmap () -> MalVal { return make_hashmap (MalHashMap()) } -func make_atom () -> MalVal { return make_atom (MalAtom()) } -func make_closure () -> MalVal { return make_closure (MalClosure()) } -func make_builtin () -> MalVal { return make_builtin (MalBuiltin()) } -func make_macro () -> MalVal { return make_macro (MalMacro()) } - -// ----- Base ----- - -func make_integer (v: MalInteger) -> MalVal { return MalVal.TypeInteger(v) } -func make_float (v: MalFloat) -> MalVal { return MalVal.TypeFloat(v) } -func make_symbol (v: MalSymbol) -> MalVal { return MalVal.TypeSymbol(v) } -func make_keyword (v: MalKeyword) -> MalVal { return MalVal.TypeKeyword(v) } -func make_string (v: MalString) -> MalVal { return MalVal.TypeString(v) } -func make_list (v: MalList) -> MalVal { return MalVal.TypeList(v) } -func make_vector (v: MalVector) -> MalVal { return MalVal.TypeVector(v) } -func make_hashmap (v: MalHashMap) -> MalVal { return MalVal.TypeHashMap(v) } -func make_atom (v: MalAtom) -> MalVal { return MalVal.TypeAtom(v) } -func make_closure (v: MalClosure) -> MalVal { return MalVal.TypeClosure(v) } -func make_builtin (v: MalBuiltin) -> MalVal { return MalVal.TypeBuiltin(v) } -func make_macro (v: MalMacro) -> MalVal { return MalVal.TypeMacro(v) } - -// ----- Parameterized ----- - -func make_list (v: MalSequence) -> MalVal { return make_list(MalList(v)) } -func make_list (v: MalVectorType) -> MalVal { return make_list(MalList(v)) } -func make_list (v: Array) -> MalVal { return make_list(MalList(v)) } -func make_list_from (v: MalVal...) -> MalVal { return make_list(MalList(v)) } -func make_list - (v: T) -> MalVal { return make_list(MalList(v)) } -func make_vector (v: MalSequence) -> MalVal { return make_vector(MalVector(v)) } -func make_vector (v: MalVectorType) -> MalVal { return make_vector(MalVector(v)) } -func make_vector (v: Array) -> MalVal { return make_vector(MalVector(v)) } -func make_vector_from (v: MalVal...) -> MalVal { return make_vector(MalVector(v)) } -func make_vector - (v: T) -> MalVal { return make_vector(MalVector(v)) } -func make_hashmap (v: MalSequence) -> MalVal { return make_hashmap(MalHashMap(v)) } -func make_hashmap (v: MalHashType) -> MalVal { return make_hashmap(MalHashMap(v)) } -func make_hashmap - (v: T) -> MalVal { return make_hashmap(MalHashMap(v)) } -func make_atom (v: MalVal) -> MalVal { return make_atom(MalAtom(v)) } -func make_closure (v: MalClosure.Parameters) -> MalVal { return make_closure(MalClosure(v)) } -func make_builtin (v: MalBuiltin.Signature) -> MalVal { return make_builtin(MalBuiltin(v)) } -func make_macro (v: MalClosure) -> MalVal { return make_macro(MalMacro(v)) } - -// ==================== Predicates ==================== - -// ----- Simple ----- - -func is_unknown (v: MalVal) -> Bool { if case .TypeUnknown = v { return true } else { return false } } -func is_nil (v: MalVal) -> Bool { if case .TypeNil = v { return true } else { return false } } -func is_true (v: MalVal) -> Bool { if case .TypeTrue = v { return true } else { return false } } -func is_false (v: MalVal) -> Bool { if case .TypeFalse = v { return true } else { return false } } -func is_comment (v: MalVal) -> Bool { if case .TypeComment = v { return true } else { return false } } -func is_integer (v: MalVal) -> Bool { if case .TypeInteger = v { return true } else { return false } } -func is_float (v: MalVal) -> Bool { if case .TypeFloat = v { return true } else { return false } } -func is_symbol (v: MalVal) -> Bool { if case .TypeSymbol = v { return true } else { return false } } -func is_keyword (v: MalVal) -> Bool { if case .TypeKeyword = v { return true } else { return false } } -func is_string (v: MalVal) -> Bool { if case .TypeString = v { return true } else { return false } } -func is_list (v: MalVal) -> Bool { if case .TypeList = v { return true } else { return false } } -func is_vector (v: MalVal) -> Bool { if case .TypeVector = v { return true } else { return false } } -func is_hashmap (v: MalVal) -> Bool { if case .TypeHashMap = v { return true } else { return false } } -func is_atom (v: MalVal) -> Bool { if case .TypeAtom = v { return true } else { return false } } -func is_closure (v: MalVal) -> Bool { if case .TypeClosure = v { return true } else { return false } } -func is_builtin (v: MalVal) -> Bool { if case .TypeBuiltin = v { return true } else { return false } } -func is_macro (v: MalVal) -> Bool { if case .TypeMacro = v { return true } else { return false } } - -// ----- Compound ----- - -func is_truthy (v: MalVal) -> Bool { return !is_falsey(v) } -func is_falsey (v: MalVal) -> Bool { switch v { case .TypeNil, .TypeFalse: return true; default: return false } } -func is_number (v: MalVal) -> Bool { switch v { case .TypeInteger, .TypeFloat: return true; default: return false } } -func is_sequence (v: MalVal) -> Bool { switch v { case .TypeList, .TypeVector: return true; default: return false } } -func is_function (v: MalVal) -> Bool { switch v { case .TypeClosure, .TypeBuiltin: return true; default: return false } } - -// ==================== Converters/Extractors ==================== - -func as_integer (v: MalVal) -> MalInteger { if case .TypeInteger(let w) = v { return w }; die("expected integer, got \(v)") } -func as_float (v: MalVal) -> MalFloat { if case .TypeFloat(let w) = v { return w }; die("expected float, got \(v)") } -func as_symbol (v: MalVal) -> MalSymbol { if case .TypeSymbol(let w) = v { return w }; die("expected symbol, got \(v)") } -func as_keyword (v: MalVal) -> MalKeyword { if case .TypeKeyword(let w) = v { return w }; die("expected keyword, got \(v)") } -func as_string (v: MalVal) -> MalString { if case .TypeString(let w) = v { return w }; die("expected string, got \(v)") } -func as_list (v: MalVal) -> MalList { if case .TypeList(let w) = v { return w }; die("expected list, got \(v)") } -func as_vector (v: MalVal) -> MalVector { if case .TypeVector(let w) = v { return w }; die("expected vector, got \(v)") } -func as_hashmap (v: MalVal) -> MalHashMap { if case .TypeHashMap(let w) = v { return w }; die("expected hashmap, got \(v)") } -func as_atom (v: MalVal) -> MalAtom { if case .TypeAtom(let w) = v { return w }; die("expected atom, got \(v)") } -func as_closure (v: MalVal) -> MalClosure { if case .TypeClosure(let w) = v { return w }; die("expected closure, got \(v)") } -func as_builtin (v: MalVal) -> MalBuiltin { if case .TypeBuiltin(let w) = v { return w }; die("expected builtin, got \(v)") } -func as_macro (v: MalVal) -> MalMacro { if case .TypeMacro(let w) = v { return w }; die("expected macro, got \(v)") } - -func as_sequence (v: MalVal) -> MalSequence { - switch v { - case .TypeList(let v): return v - case .TypeVector(let v): return v - default: die("expected sequence, got \(v)") - } -} -func as_function (v: MalVal) -> MalFunction { - switch v { - case .TypeClosure(let v): return v - case .TypeBuiltin(let v): return v - default: die("expected function, got \(v)") - } -} - -func as_inttype (v: MalVal) -> MalIntType { return as_integer(v) } -func as_floattype (v: MalVal) -> MalFloatType { return as_float(v) } -func as_stringtype (v: MalVal) -> MalStringType { return as_string(v) } - -func as_inttype (v: MalInteger) -> MalIntType { return v } -func as_floattype (v: MalFloat) -> MalFloatType { return v } -func as_stringtype (v: MalString) -> MalStringType { return v } - -func as_integerQ (v: MalVal) -> MalInteger? { if case .TypeInteger(let w) = v { return w }; return nil } -func as_floatQ (v: MalVal) -> MalFloat? { if case .TypeFloat(let w) = v { return w }; return nil } -func as_symbolQ (v: MalVal) -> MalSymbol? { if case .TypeSymbol(let w) = v { return w }; return nil } -func as_keywordQ (v: MalVal) -> MalKeyword? { if case .TypeKeyword(let w) = v { return w }; return nil } -func as_stringQ (v: MalVal) -> MalString? { if case .TypeString(let w) = v { return w }; return nil } -func as_listQ (v: MalVal) -> MalList? { if case .TypeList(let w) = v { return w }; return nil } -func as_vectorQ (v: MalVal) -> MalVector? { if case .TypeVector(let w) = v { return w }; return nil } -func as_hashmapQ (v: MalVal) -> MalHashMap? { if case .TypeHashMap(let w) = v { return w }; return nil } -func as_atomQ (v: MalVal) -> MalAtom? { if case .TypeAtom(let w) = v { return w }; return nil } -func as_closureQ (v: MalVal) -> MalClosure? { if case .TypeClosure(let w) = v { return w }; return nil } -func as_builtinQ (v: MalVal) -> MalBuiltin? { if case .TypeBuiltin(let w) = v { return w }; return nil } -func as_macroQ (v: MalVal) -> MalMacro? { if case .TypeMacro(let w) = v { return w }; return nil } - -func as_listQ (v: MalSequence) -> MalList? { return v as? MalList } -func as_vectorQ (v: MalSequence) -> MalVector? { return v as? MalVector } - -func as_sequenceQ (v: MalVal) -> MalSequence? { - switch v { - case .TypeList(let v): return v - case .TypeVector(let v): return v - default: return nil - } -} -func as_functionQ (v: MalVal) -> MalFunction? { - switch v { - case .TypeClosure(let v): return v - case .TypeBuiltin(let v): return v - default: return nil - } -} - -func as_inttypeQ (v: MalVal) -> MalIntType? { return as_integerQ(v) } -func as_floattypeQ (v: MalVal) -> MalFloatType? { return as_floatQ(v) } -func as_stringtypeQ (v: MalVal) -> MalStringType? { return as_stringQ(v) } - -// ==================== Exceptions ==================== - -enum MalException: ErrorType, CustomStringConvertible { - case None - case Message(String) - case Object(MalVal) - - var exception: MalVal { - switch self { - case .None: - return make_nil() - case .Message(let v): - return make_string(v) - case .Object(let v): - return v - } - } - - // CustomStringConvertible - // - var description: String { - switch self { - case .None: - return "NIL Exception" - case .Message(let v): - return v - case .Object(let v): - return v.description - } - } -} - -@noreturn -func throw_error(v: String) throws { throw MalException.Message(v) } - -@noreturn -func throw_error(v: MalVal) throws { throw MalException.Object(v) } - -// ==================== Utilities ==================== - -@noreturn private func die(msg: String) { - preconditionFailure(msg) -} - -@noreturn private func die() { - die("Should not get here") -} - -func get_meta(v: MalVal) -> MalVal? { - switch v { - case .TypeUnknown: return nil - case .TypeNil: return nil - case .TypeTrue: return nil - case .TypeFalse: return nil - case .TypeComment: return nil - case .TypeInteger: return nil - case .TypeFloat: return nil - case .TypeSymbol: return nil - case .TypeKeyword: return nil - case .TypeString: return nil - case .TypeList (let v): return v.meta - case .TypeVector (let v): return v.meta - case .TypeHashMap (let v): return v.meta - case .TypeAtom (let v): return v.meta - case .TypeClosure (let v): return v.meta - case .TypeBuiltin (let v): return v.meta - case .TypeMacro (let v): return v.meta - } -} - -func with_meta(obj: MalVal, _ meta: MalVal) -> MalVal { - switch obj { - case .TypeUnknown: return obj - case .TypeNil: return obj - case .TypeTrue: return obj - case .TypeFalse: return obj - case .TypeComment: return obj - case .TypeInteger: return obj - case .TypeFloat: return obj - case .TypeSymbol: return obj - case .TypeKeyword: return obj - case .TypeString: return obj - case .TypeList (let v): return make_list(MalList(v, meta)) - case .TypeVector (let v): return make_vector(MalVector(v, meta)) - case .TypeHashMap (let v): return make_hashmap(MalHashMap(v, meta)) - case .TypeAtom (let v): return make_atom(MalAtom(v, meta)) - case .TypeClosure (let v): return make_closure(MalClosure(v, meta)) - case .TypeBuiltin (let v): return make_builtin(MalBuiltin(v, meta)) - case .TypeMacro (let v): return make_macro(MalMacro(v, meta)) - } -} - -func unescape(s: String) -> String { - var index = 0 - var prev_is_escape = false - var str = "" - let chars = s.characters - for ch in chars { - if index == chars.count - 1 { continue } - if index++ == 0 { continue } - if prev_is_escape { - prev_is_escape = false - if ch == "n" { str.appendContentsOf("\n") } - else if ch == "r" { str.appendContentsOf("\r") } - else if ch == "t" { str.appendContentsOf("\t") } - else { str.append(ch) } - } else if ch == "\\" { - prev_is_escape = true - } else { - str.append(ch) - } - } - return str -} - -func escape(s: String) -> String { - var str = "" - let chars = s.characters - for ch in chars { - if ch == "\n" { str.appendContentsOf("\\n"); continue } - if ch == "\r" { str.appendContentsOf("\\r"); continue } - if ch == "\t" { str.appendContentsOf("\\t"); continue } - if ch == "\"" || ch == "\\" { str.appendContentsOf("\\") } - str.append(ch) - } - str = "\"" + str + "\"" - return str -} +//****************************************************************************** +// MAL - types, implemented as a Swift "enum". +//****************************************************************************** + +import Foundation + +// ===== Types / Constants / Variables ===== + +typealias MalProtocol = protocol + +typealias MalIntType = Int64 +typealias MalFloatType = Double +typealias MalSymbolType = String +typealias MalKeywordType = String +typealias MalStringType = String +typealias MalVectorType = ArraySlice +typealias MalHashType = Dictionary + +typealias MalInteger = MalIntType +typealias MalFloat = MalFloatType +typealias MalSymbol = MalSymbolType +typealias MalKeyword = MalKeywordType +typealias MalString = MalStringType + +private let kUnknown = MalVal.TypeUnknown +private let kNil = MalVal.TypeNil +private let kTrue = MalVal.TypeTrue +private let kFalse = MalVal.TypeFalse +private let kComment = MalVal.TypeComment + +// ==================== MalSequence ==================== + +class MalSequence : MalProtocol, SequenceType { + init() { + self.count = 0 + self.isEmpty = true + } + init(_ seq: MalSequence) { + self.count = seq.count + self.isEmpty = seq.isEmpty + } + init(_ count: MalIntType) { + self.count = count + self.isEmpty = self.count == 0 + } + + // CustomStringConvertible + // + var description: String { die() } + + // Hashable + // + var hashValue: Int { die() } + + // SequenceType + // + func generate() -> MalVectorType.Generator { die() } + + // MalSequence + // + let count: MalIntType + let isEmpty: Bool + + func first() -> MalVal { die() } + func last() -> MalVal { die() } + func rest() -> MalVal { die() } + func nth(n: MalIntType) throws -> MalVal { die() } + func range_from(from: MalIntType, to: MalIntType) -> MalVal { die() } + func cons(element: MalVal) -> MalVal { die() } + func concat(seq: MalSequence) throws -> MalVal { die() } + func conj(seq: MalSequence) throws -> MalVal { die() } + func map(@noescape transform: (MalVal) -> U) -> ArraySlice { die() } + func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { die() } +} + +// Equatable +// +func ==(left: MalSequence, right: MalSequence) -> Bool { + if left.count != right.count { return false } + var left_gen = left.generate() + var right_gen = right.generate() + while true { + if let left = left_gen.next(), right = right_gen.next() { + if left != right { + return false + } + } else { + break + } + } + return true +} + +// ==================== MalList ==================== + +final class MalList : MalSequence { + override convenience init() { + self.init(MalVectorType()) + } + init(_ other: MalList, _ meta: MalVal?) { + self._slice = other._slice + self._meta = meta + super.init(other) + } + override convenience init(_ seq: MalSequence) { + if let list = seq as? MalList { self.init(list._slice) } + else + if let vector = seq as? MalVector { self.init(vector._slice) } + else + { self.init(seq.reduce(MalVectorType()){ var s = $0; s.append($1); return s }) } + } + init(_ slice: MalVectorType) { + self._slice = slice + self._meta = nil + super.init(MalIntType(self._slice.count)) + } + convenience init(_ array: Array) { + self.init(array[0..(_ collection: T) { + self.init(collection.reduce(MalVectorType()){ var s = $0; s.append($1); return s }) + } + + // CustomStringConvertible + // + override var description: String { return "(" + self.map { pr_str($0) }.joinWithSeparator(" ") + ")" } + + // Hashable + // + override var hashValue: Int { return description.hashValue } + + // SequenceType + // + override func generate() -> MalVectorType.Generator { return self._slice.generate() } + + // MalSequence + // + override func first() -> MalVal { return isEmpty ? make_nil() : try! nth(0) } + override func last() -> MalVal { return try! nth(count - 1) } + override func rest() -> MalVal { return range_from(MalIntType(1), to: MalIntType(count)) } + override func nth(n: MalIntType) throws -> MalVal { guard n < count else { try throw_error("index (\(n)) out of range (\(count))") }; return self._slice[self._slice.startIndex.advancedBy(Int(n))] } + override func range_from(from: MalIntType, to: MalIntType) -> MalVal { + return from <= to && to <= count + ? make_list(self._slice[self._slice.startIndex.advancedBy(Int(from)).. MalVal { + var result = self._slice + result.insert(element, atIndex: result.startIndex) + return make_list(result) + } + override func concat(seq: MalSequence) throws -> MalVal { + var result = self._slice + if let list = as_listQ(seq) { + result.appendContentsOf(list._slice) + } else if let vector = as_vectorQ(seq) { + result.appendContentsOf(vector._slice) + } else { + try throw_error("Expected sequence, got \(seq)") + } + return make_list(result) + } + override func conj(seq: MalSequence) throws -> MalVal { + var result: Array + if let list = as_listQ(seq) { + result = list._slice.reverse() + } else if let vector = as_vectorQ(seq) { + result = vector._slice.reverse() + } else { + try throw_error("Expected sequence, got \(seq)") + } + result.appendContentsOf(self._slice) + return make_list(result) + } + override func map(@noescape transform: (MalVal) -> U) -> ArraySlice { return ArraySlice(self._slice.map(transform)) } + override func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { return self._slice.reduce(initial, combine: combine) } + + // MalList + // + var meta: MalVal? { return self._meta } + + private let _slice: MalVectorType + private let _meta: MalVal? +} + +// Equatable +// +func ==(left: MalList, right: MalList) -> Bool { + return (left as MalSequence) == (right as MalSequence) +} + +// ==================== MalVector ==================== + +final class MalVector : MalSequence { + override convenience init() { + self.init(MalVectorType()) + } + init(_ other: MalVector, _ meta: MalVal?) { + self._slice = other._slice + self._meta = meta + super.init(other) + } + override convenience init(_ seq: MalSequence) { + if let list = seq as? MalList { self.init(list._slice) } + else + if let vector = seq as? MalVector { self.init(vector._slice) } + else + { self.init(seq.reduce(MalVectorType()){ var s = $0; s.append($1); return s }) } + } + init(_ slice: MalVectorType) { + self._slice = slice + self._meta = nil + super.init(MalIntType(self._slice.count)) + } + convenience init(_ array: Array) { + self.init(array[0..(_ collection: T) { + self.init(collection.reduce(MalVectorType()){ var s = $0; s.append($1); return s }) + } + + // CustomStringConvertible + // + override var description: String { return "[" + self.map { pr_str($0) }.joinWithSeparator(" ") + "]" } + + // Hashable + // + override var hashValue: Int { return description.hashValue } + + // SequenceType + // + override func generate() -> MalVectorType.Generator { return self._slice.generate() } + + // MalSequence + // + override func first() -> MalVal { return isEmpty ? make_nil() : try! nth(0) } + override func last() -> MalVal { return try! nth(count - 1) } + override func rest() -> MalVal { return range_from(MalIntType(1), to: MalIntType(count)) } + override func nth(n: MalIntType) throws -> MalVal { guard n < count else { try throw_error("index (\(n)) out of range (\(count))") }; return self._slice[self._slice.startIndex.advancedBy(Int(n))] } + override func range_from(from: MalIntType, to: MalIntType) -> MalVal { + return from <= to && to <= count + ? make_list(self._slice[self._slice.startIndex.advancedBy(Int(from)).. MalVal { + var result = self._slice + result.insert(element, atIndex: result.startIndex) + return make_list(result) // Yes, make_list + } + override func concat(seq: MalSequence) throws -> MalVal { + var result = self._slice + if let list = as_listQ(seq) { + result.appendContentsOf(list._slice) + } else if let vector = as_vectorQ(seq) { + result.appendContentsOf(vector._slice) + } else { + try throw_error("Expected sequence, got \(seq)") + } + return make_vector(result) + } + override func conj(seq: MalSequence) throws -> MalVal { + var result = self._slice + if let list = as_listQ(seq) { + result.appendContentsOf(list._slice) + } else if let vector = as_vectorQ(seq) { + result.appendContentsOf(vector._slice) + } else { + try throw_error("Expected sequence, got \(seq)") + } + return make_vector(result) + } + override func map(@noescape transform: (MalVal) -> U) -> ArraySlice { return ArraySlice(self._slice.map(transform)) } + override func reduce(initial: U, @noescape combine: (U, MalVal) -> U) -> U { return self._slice.reduce(initial, combine: combine) } + + // MalVector + // + var meta: MalVal? { return self._meta } + + private let _slice: MalVectorType + private let _meta: MalVal? +} + +// Equatable +// +func ==(left: MalVector, right: MalVector) -> Bool { + return (left as MalSequence) == (right as MalSequence) +} + +// ==================== MalHashMap ==================== + +final class MalHashMap : MalProtocol, SequenceType { + convenience init() { + self.init(MalHashType()) + } + init(_ other: MalHashMap, _ meta: MalVal?) { + self._hash = other._hash + self._meta = meta + self.count = MalIntType(self._hash.count) + self.isEmpty = self._hash.isEmpty + } + init(_ hash: MalHashType) { + self._hash = hash + self._meta = nil + self.count = MalIntType(self._hash.count) + self.isEmpty = self._hash.isEmpty + } + convenience init(_ seq: MalSequence) { + var hash = MalHashType() + for var index: MalIntType = 0; index < seq.count; index += 2 { + hash[try! seq.nth(index)] = try! seq.nth(index + 1) + } + self.init(hash) + } + convenience init(_ collection: T) { + var hash = MalHashType() + for var index = collection.startIndex; index != collection.endIndex; { + let key = collection[index++] + let value = collection[index++] + hash[key] = value + } + self.init(hash) + } + + // CustomStringConvertible + // + var description: String { + var a = [String]() + for (k, v) in self._hash { + a.append("\(pr_str(k)) \(pr_str(v))") + } + let s = a.joinWithSeparator(" ") + return "{\(s)}" + } + + // Hashable + // + var hashValue: Int { return description.hashValue } + + // SequenceType + // + func generate() -> MalHashType.Generator { return self._hash.generate() } + + // MalHashMap + // + let count: MalIntType + let isEmpty: Bool + var hash: MalHashType { return self._hash } + var keys: MalVal { return make_list(self._hash.keys) } + var values: MalVal { return make_list(self._hash.values) } + var meta: MalVal? { return self._meta } + + func value_for(key: MalVal) -> MalVal? { + return self._hash[key] + } + + private let _hash: MalHashType + private let _meta: MalVal? +} + +// Equatable +// +func ==(left: MalHashMap, right: MalHashMap) -> Bool { + if left.count != right.count { return false } + var left_gen = left.generate() + var right_gen = right.generate() + while true { + if let left = left_gen.next(), right = right_gen.next() { + if left.0 != right.0 || left.1 != right.1 { + return false + } + } else { + break + } + } + return true +} + +// ==================== MalAtom ==================== + +final class MalAtom : MalProtocol { + convenience init() { + self.init(make_nil()) + } + init(_ other: MalAtom, _ meta: MalVal?) { + self._object = other._object + self._meta = meta + } + init(_ object: MalVal) { + self._object = object + self._meta = nil + } + + // CustomStringConvertible + // + var description: String { return "(atom \(pr_str(self._object)))" } + + // Hashable + // + var hashValue: Int { return description.hashValue } + + // MalAtom + // + var object: MalVal { return self._object } + var meta: MalVal? { return self._meta } + + func set_object(obj: MalVal) -> MalVal { + self._object = obj + return obj + } + + private var _object: MalVal + private let _meta: MalVal? +} + +// Equatable +// +func ==(left: MalAtom, right: MalAtom) -> Bool { return left.object == right.object } + +// ==================== MalFunction ==================== + +class MalFunction : MalProtocol { + init() { + } + init(_ other: MalFunction) { + } + + // CustomStringConvertible + // + var description: String { die() } + + // Hashable + // + var hashValue: Int { die() } + + // MalFunction + // + func apply(exprs: MalSequence) throws -> MalVal { die() } +} + +// Equatable +// +func ==(left: MalFunction, right: MalFunction) -> Bool { return false } + +// ==================== MalClosure ==================== + + +final class MalClosure : MalFunction { + typealias Evaluator = (MalVal, Environment) throws -> MalVal + typealias Parameters = (eval: Evaluator, args: MalSequence, body: MalVal, env: Environment) + + override convenience init() { + self.init(( + eval: {(a: MalVal, b: Environment) -> MalVal in make_nil() }, + args: as_sequence(make_list()), + body: make_nil(), + env: Environment(outer: nil) + )) + } + init(_ other: MalClosure, _ meta: MalVal?) { + self._eval = other._eval + self._args = other._args + self._body = other._body + self._env = other._env + self._meta = meta + super.init(other) + } + init(_ p: Parameters) { + self._eval = p.eval + self._args = p.args + self._body = p.body + self._env = p.env + self._meta = nil + super.init() + } + + // CustomStringConvertible + // + override var description: String { return "#: (fn* \(self._args.description) \(self._body.description))" } + + // Hashable + // + override var hashValue: Int { return description.hashValue } + + // MalFunction + // + override func apply(exprs: MalSequence) throws -> MalVal { + let new_env = Environment(outer: self._env) + let _ = try new_env.set_bindings(self._args, with_exprs: exprs) + // Calling EVAL indirectly via an 'eval' data member is a bit of a hack. + // We can't call EVAL directly because this file (types.swift) needs to + // be used with many different versions of the main MAL file + // (step[0-10]*.swift), and EVAL is declared differently across those + // versions. By using this indirection, we avoid that problem. + return try self._eval(self._body, new_env) + } + + var args: MalSequence { return self._args } + var body: MalVal { return self._body } + var env: Environment { return self._env } + var meta: MalVal? { return self._meta } + + private let _eval: Evaluator! + private let _args: MalSequence + private let _body: MalVal + private let _env: Environment + private let _meta: MalVal? +} + +// Equatable +// +func ==(left: MalClosure, right: MalClosure) -> Bool { return false } + +// ==================== MalBuiltin ==================== + +final class MalBuiltin : MalFunction { + typealias Signature = (MalSequence) throws -> MalVal + + override convenience init() { + self.init( {(MalSequence) -> MalVal in make_nil()} ) + } + init(_ other: MalBuiltin, _ meta: MalVal?) { + self._fn = other._fn + self._meta = meta + super.init(other) + } + init(_ fn: Signature) { + self._fn = fn + self._meta = nil + super.init() + } + + // CustomStringConvertible + // + override var description: String { return "#" } + + // Hashable + // + override var hashValue: Int { return description.hashValue } + + // MalBuiltin + // + override func apply(exprs: MalSequence) throws -> MalVal { return try self._fn(exprs) } + var meta: MalVal? { return self._meta } + + private let _fn: Signature! + private let _meta: MalVal? +} + +// Equatable +// +func ==(left: MalBuiltin, right: MalBuiltin) -> Bool { return false } // Can't compare function references in Swift + +// ==================== MalMacro ==================== + +final class MalMacro : MalProtocol { + convenience init() { + self.init(as_closure(make_closure())) + } + init(_ other: MalMacro, _ meta: MalVal?) { + self._closure = other._closure + self._meta = meta + } + init(_ closure: MalClosure) { + self._closure = closure + self._meta = nil + } + + // CustomStringConvertible + // + var description: String { return self._closure.description } + + // Hashable + // + var hashValue: Int { return description.hashValue } + + var args: MalSequence { return self._closure.args } + var body: MalVal { return self._closure.body } + var env: Environment { return self._closure.env } + var meta: MalVal? { return self._meta } + + private let _closure: MalClosure + private let _meta: MalVal? +} + +// Equatable +// +func ==(left: MalMacro, right: MalMacro) -> Bool { return false } + +// ==================== MalVal ==================== + +enum MalVal : MalProtocol { + case TypeUnknown + case TypeNil + case TypeTrue + case TypeFalse + case TypeComment + case TypeInteger (MalInteger) + case TypeFloat (MalFloat) + case TypeSymbol (MalSymbol) + case TypeKeyword (MalKeyword) + case TypeString (MalString) + case TypeList (MalList) + case TypeVector (MalVector) + case TypeHashMap (MalHashMap) + case TypeAtom (MalAtom) + case TypeClosure (MalClosure) + case TypeBuiltin (MalBuiltin) + case TypeMacro (MalMacro) + + // CustomStringConvertible + // + var description: String { + switch self { + case .TypeUnknown: return "unknown" + case .TypeNil: return "nil" + case .TypeTrue: return "true" + case .TypeFalse: return "false" + case .TypeComment: return "comment" + case .TypeInteger (let v): return v.description + case .TypeFloat (let v): return v.description + case .TypeSymbol (let v): return v + case .TypeKeyword (let v): return v + case .TypeString (let v): return v + case .TypeList (let v): return v.description + case .TypeVector (let v): return v.description + case .TypeHashMap (let v): return v.description + case .TypeAtom (let v): return v.description + case .TypeClosure (let v): return v.description + case .TypeBuiltin (let v): return v.description + case .TypeMacro (let v): return v.description + } + } + + // Hashable + // + var hashValue: Int { + switch self { + case .TypeUnknown: return 0 + case .TypeNil: return 0 + case .TypeTrue: return 0 + case .TypeFalse: return 0 + case .TypeComment: return 0 + case .TypeInteger (let v): return v.hashValue + case .TypeFloat (let v): return v.hashValue + case .TypeSymbol (let v): return v.hashValue + case .TypeKeyword (let v): return v.hashValue + case .TypeString (let v): return v.hashValue + case .TypeList (let v): return v.hashValue + case .TypeVector (let v): return v.hashValue + case .TypeHashMap (let v): return v.hashValue + case .TypeAtom (let v): return v.hashValue + case .TypeClosure (let v): return v.hashValue + case .TypeBuiltin (let v): return v.hashValue + case .TypeMacro (let v): return v.hashValue + } + } +} + +// Equatable +// +func ==(left: MalVal, right: MalVal) -> Bool { + switch (left, right) { + case (.TypeUnknown, .TypeUnknown): return true + case (.TypeNil, .TypeNil): return true + case (.TypeTrue, .TypeTrue): return true + case (.TypeFalse, .TypeFalse): return true + case (.TypeComment, .TypeComment): return false + case (.TypeInteger (let vLeft), .TypeInteger (let vRight)): return vLeft == vRight + case (.TypeFloat (let vLeft), .TypeFloat (let vRight)): return vLeft == vRight + case (.TypeSymbol (let vLeft), .TypeSymbol (let vRight)): return vLeft == vRight + case (.TypeKeyword (let vLeft), .TypeKeyword (let vRight)): return vLeft == vRight + case (.TypeString (let vLeft), .TypeString (let vRight)): return vLeft == vRight + case (.TypeList (let vLeft), .TypeList (let vRight)): return vLeft == vRight + case (.TypeVector (let vLeft), .TypeVector (let vRight)): return vLeft == vRight + case (.TypeHashMap (let vLeft), .TypeHashMap (let vRight)): return vLeft == vRight + case (.TypeAtom (let vLeft), .TypeAtom (let vRight)): return vLeft == vRight + case (.TypeClosure (let vLeft), .TypeClosure (let vRight)): return vLeft == vRight + case (.TypeBuiltin (let vLeft), .TypeBuiltin (let vRight)): return vLeft == vRight + case (.TypeMacro (let vLeft), .TypeMacro (let vRight)): return vLeft == vRight + + case (.TypeList (let vLeft), .TypeVector (let vRight)): return vLeft == vRight + case (.TypeVector (let vLeft), .TypeList (let vRight)): return vLeft == vRight + + default: return false + } +} + +func ==(left: MalList, right: MalVector) -> Bool { + if left.count != right.count { return false } + var left_gen = left.generate() + var right_gen = right.generate() + while true { + if let left = left_gen.next(), right = right_gen.next() { + if left != right { + return false + } + } else { + break + } + } + return true +} + +func ==(left: MalVector, right: MalList) -> Bool { + if left.count != right.count { return false } + var left_gen = left.generate() + var right_gen = right.generate() + while true { + if let left = left_gen.next(), right = right_gen.next() { + if left != right { + return false + } + } else { + break + } + } + return true +} + +// ==================== Constructors ==================== + +// ----- Default ----- + +func make_unknown () -> MalVal { return kUnknown } +func make_nil () -> MalVal { return kNil } +func make_true () -> MalVal { return kTrue } +func make_false () -> MalVal { return kFalse } +func make_comment () -> MalVal { return kComment } +func make_integer () -> MalVal { return make_integer (MalInteger()) } +func make_float () -> MalVal { return make_float (MalFloat()) } +func make_symbol () -> MalVal { return make_symbol (MalSymbol()) } +func make_keyword () -> MalVal { return make_keyword (MalKeyword()) } +func make_string () -> MalVal { return make_string (MalString()) } +func make_list () -> MalVal { return make_list (MalList()) } +func make_vector () -> MalVal { return make_vector (MalVector()) } +func make_hashmap () -> MalVal { return make_hashmap (MalHashMap()) } +func make_atom () -> MalVal { return make_atom (MalAtom()) } +func make_closure () -> MalVal { return make_closure (MalClosure()) } +func make_builtin () -> MalVal { return make_builtin (MalBuiltin()) } +func make_macro () -> MalVal { return make_macro (MalMacro()) } + +// ----- Base ----- + +func make_integer (v: MalInteger) -> MalVal { return MalVal.TypeInteger(v) } +func make_float (v: MalFloat) -> MalVal { return MalVal.TypeFloat(v) } +func make_symbol (v: MalSymbol) -> MalVal { return MalVal.TypeSymbol(v) } +func make_keyword (v: MalKeyword) -> MalVal { return MalVal.TypeKeyword(v) } +func make_string (v: MalString) -> MalVal { return MalVal.TypeString(v) } +func make_list (v: MalList) -> MalVal { return MalVal.TypeList(v) } +func make_vector (v: MalVector) -> MalVal { return MalVal.TypeVector(v) } +func make_hashmap (v: MalHashMap) -> MalVal { return MalVal.TypeHashMap(v) } +func make_atom (v: MalAtom) -> MalVal { return MalVal.TypeAtom(v) } +func make_closure (v: MalClosure) -> MalVal { return MalVal.TypeClosure(v) } +func make_builtin (v: MalBuiltin) -> MalVal { return MalVal.TypeBuiltin(v) } +func make_macro (v: MalMacro) -> MalVal { return MalVal.TypeMacro(v) } + +// ----- Parameterized ----- + +func make_list (v: MalSequence) -> MalVal { return make_list(MalList(v)) } +func make_list (v: MalVectorType) -> MalVal { return make_list(MalList(v)) } +func make_list (v: Array) -> MalVal { return make_list(MalList(v)) } +func make_list_from (v: MalVal...) -> MalVal { return make_list(MalList(v)) } +func make_list + (v: T) -> MalVal { return make_list(MalList(v)) } +func make_vector (v: MalSequence) -> MalVal { return make_vector(MalVector(v)) } +func make_vector (v: MalVectorType) -> MalVal { return make_vector(MalVector(v)) } +func make_vector (v: Array) -> MalVal { return make_vector(MalVector(v)) } +func make_vector_from (v: MalVal...) -> MalVal { return make_vector(MalVector(v)) } +func make_vector + (v: T) -> MalVal { return make_vector(MalVector(v)) } +func make_hashmap (v: MalSequence) -> MalVal { return make_hashmap(MalHashMap(v)) } +func make_hashmap (v: MalHashType) -> MalVal { return make_hashmap(MalHashMap(v)) } +func make_hashmap + (v: T) -> MalVal { return make_hashmap(MalHashMap(v)) } +func make_atom (v: MalVal) -> MalVal { return make_atom(MalAtom(v)) } +func make_closure (v: MalClosure.Parameters) -> MalVal { return make_closure(MalClosure(v)) } +func make_builtin (v: MalBuiltin.Signature) -> MalVal { return make_builtin(MalBuiltin(v)) } +func make_macro (v: MalClosure) -> MalVal { return make_macro(MalMacro(v)) } + +// ==================== Predicates ==================== + +// ----- Simple ----- + +func is_unknown (v: MalVal) -> Bool { if case .TypeUnknown = v { return true } else { return false } } +func is_nil (v: MalVal) -> Bool { if case .TypeNil = v { return true } else { return false } } +func is_true (v: MalVal) -> Bool { if case .TypeTrue = v { return true } else { return false } } +func is_false (v: MalVal) -> Bool { if case .TypeFalse = v { return true } else { return false } } +func is_comment (v: MalVal) -> Bool { if case .TypeComment = v { return true } else { return false } } +func is_integer (v: MalVal) -> Bool { if case .TypeInteger = v { return true } else { return false } } +func is_float (v: MalVal) -> Bool { if case .TypeFloat = v { return true } else { return false } } +func is_symbol (v: MalVal) -> Bool { if case .TypeSymbol = v { return true } else { return false } } +func is_keyword (v: MalVal) -> Bool { if case .TypeKeyword = v { return true } else { return false } } +func is_string (v: MalVal) -> Bool { if case .TypeString = v { return true } else { return false } } +func is_list (v: MalVal) -> Bool { if case .TypeList = v { return true } else { return false } } +func is_vector (v: MalVal) -> Bool { if case .TypeVector = v { return true } else { return false } } +func is_hashmap (v: MalVal) -> Bool { if case .TypeHashMap = v { return true } else { return false } } +func is_atom (v: MalVal) -> Bool { if case .TypeAtom = v { return true } else { return false } } +func is_closure (v: MalVal) -> Bool { if case .TypeClosure = v { return true } else { return false } } +func is_builtin (v: MalVal) -> Bool { if case .TypeBuiltin = v { return true } else { return false } } +func is_macro (v: MalVal) -> Bool { if case .TypeMacro = v { return true } else { return false } } + +// ----- Compound ----- + +func is_truthy (v: MalVal) -> Bool { return !is_falsey(v) } +func is_falsey (v: MalVal) -> Bool { switch v { case .TypeNil, .TypeFalse: return true; default: return false } } +func is_number (v: MalVal) -> Bool { switch v { case .TypeInteger, .TypeFloat: return true; default: return false } } +func is_sequence (v: MalVal) -> Bool { switch v { case .TypeList, .TypeVector: return true; default: return false } } +func is_function (v: MalVal) -> Bool { switch v { case .TypeClosure, .TypeBuiltin: return true; default: return false } } + +// ==================== Converters/Extractors ==================== + +func as_integer (v: MalVal) -> MalInteger { if case .TypeInteger(let w) = v { return w }; die("expected integer, got \(v)") } +func as_float (v: MalVal) -> MalFloat { if case .TypeFloat(let w) = v { return w }; die("expected float, got \(v)") } +func as_symbol (v: MalVal) -> MalSymbol { if case .TypeSymbol(let w) = v { return w }; die("expected symbol, got \(v)") } +func as_keyword (v: MalVal) -> MalKeyword { if case .TypeKeyword(let w) = v { return w }; die("expected keyword, got \(v)") } +func as_string (v: MalVal) -> MalString { if case .TypeString(let w) = v { return w }; die("expected string, got \(v)") } +func as_list (v: MalVal) -> MalList { if case .TypeList(let w) = v { return w }; die("expected list, got \(v)") } +func as_vector (v: MalVal) -> MalVector { if case .TypeVector(let w) = v { return w }; die("expected vector, got \(v)") } +func as_hashmap (v: MalVal) -> MalHashMap { if case .TypeHashMap(let w) = v { return w }; die("expected hashmap, got \(v)") } +func as_atom (v: MalVal) -> MalAtom { if case .TypeAtom(let w) = v { return w }; die("expected atom, got \(v)") } +func as_closure (v: MalVal) -> MalClosure { if case .TypeClosure(let w) = v { return w }; die("expected closure, got \(v)") } +func as_builtin (v: MalVal) -> MalBuiltin { if case .TypeBuiltin(let w) = v { return w }; die("expected builtin, got \(v)") } +func as_macro (v: MalVal) -> MalMacro { if case .TypeMacro(let w) = v { return w }; die("expected macro, got \(v)") } + +func as_sequence (v: MalVal) -> MalSequence { + switch v { + case .TypeList(let v): return v + case .TypeVector(let v): return v + default: die("expected sequence, got \(v)") + } +} +func as_function (v: MalVal) -> MalFunction { + switch v { + case .TypeClosure(let v): return v + case .TypeBuiltin(let v): return v + default: die("expected function, got \(v)") + } +} + +func as_inttype (v: MalVal) -> MalIntType { return as_integer(v) } +func as_floattype (v: MalVal) -> MalFloatType { return as_float(v) } +func as_stringtype (v: MalVal) -> MalStringType { return as_string(v) } + +func as_inttype (v: MalInteger) -> MalIntType { return v } +func as_floattype (v: MalFloat) -> MalFloatType { return v } +func as_stringtype (v: MalString) -> MalStringType { return v } + +func as_integerQ (v: MalVal) -> MalInteger? { if case .TypeInteger(let w) = v { return w }; return nil } +func as_floatQ (v: MalVal) -> MalFloat? { if case .TypeFloat(let w) = v { return w }; return nil } +func as_symbolQ (v: MalVal) -> MalSymbol? { if case .TypeSymbol(let w) = v { return w }; return nil } +func as_keywordQ (v: MalVal) -> MalKeyword? { if case .TypeKeyword(let w) = v { return w }; return nil } +func as_stringQ (v: MalVal) -> MalString? { if case .TypeString(let w) = v { return w }; return nil } +func as_listQ (v: MalVal) -> MalList? { if case .TypeList(let w) = v { return w }; return nil } +func as_vectorQ (v: MalVal) -> MalVector? { if case .TypeVector(let w) = v { return w }; return nil } +func as_hashmapQ (v: MalVal) -> MalHashMap? { if case .TypeHashMap(let w) = v { return w }; return nil } +func as_atomQ (v: MalVal) -> MalAtom? { if case .TypeAtom(let w) = v { return w }; return nil } +func as_closureQ (v: MalVal) -> MalClosure? { if case .TypeClosure(let w) = v { return w }; return nil } +func as_builtinQ (v: MalVal) -> MalBuiltin? { if case .TypeBuiltin(let w) = v { return w }; return nil } +func as_macroQ (v: MalVal) -> MalMacro? { if case .TypeMacro(let w) = v { return w }; return nil } + +func as_listQ (v: MalSequence) -> MalList? { return v as? MalList } +func as_vectorQ (v: MalSequence) -> MalVector? { return v as? MalVector } + +func as_sequenceQ (v: MalVal) -> MalSequence? { + switch v { + case .TypeList(let v): return v + case .TypeVector(let v): return v + default: return nil + } +} +func as_functionQ (v: MalVal) -> MalFunction? { + switch v { + case .TypeClosure(let v): return v + case .TypeBuiltin(let v): return v + default: return nil + } +} + +func as_inttypeQ (v: MalVal) -> MalIntType? { return as_integerQ(v) } +func as_floattypeQ (v: MalVal) -> MalFloatType? { return as_floatQ(v) } +func as_stringtypeQ (v: MalVal) -> MalStringType? { return as_stringQ(v) } + +// ==================== Exceptions ==================== + +enum MalException: ErrorType, CustomStringConvertible { + case None + case Message(String) + case Object(MalVal) + + var exception: MalVal { + switch self { + case .None: + return make_nil() + case .Message(let v): + return make_string(v) + case .Object(let v): + return v + } + } + + // CustomStringConvertible + // + var description: String { + switch self { + case .None: + return "NIL Exception" + case .Message(let v): + return v + case .Object(let v): + return v.description + } + } +} + +@noreturn +func throw_error(v: String) throws { throw MalException.Message(v) } + +@noreturn +func throw_error(v: MalVal) throws { throw MalException.Object(v) } + +// ==================== Utilities ==================== + +@noreturn private func die(msg: String) { + preconditionFailure(msg) +} + +@noreturn private func die() { + die("Should not get here") +} + +func get_meta(v: MalVal) -> MalVal? { + switch v { + case .TypeUnknown: return nil + case .TypeNil: return nil + case .TypeTrue: return nil + case .TypeFalse: return nil + case .TypeComment: return nil + case .TypeInteger: return nil + case .TypeFloat: return nil + case .TypeSymbol: return nil + case .TypeKeyword: return nil + case .TypeString: return nil + case .TypeList (let v): return v.meta + case .TypeVector (let v): return v.meta + case .TypeHashMap (let v): return v.meta + case .TypeAtom (let v): return v.meta + case .TypeClosure (let v): return v.meta + case .TypeBuiltin (let v): return v.meta + case .TypeMacro (let v): return v.meta + } +} + +func with_meta(obj: MalVal, _ meta: MalVal) -> MalVal { + switch obj { + case .TypeUnknown: return obj + case .TypeNil: return obj + case .TypeTrue: return obj + case .TypeFalse: return obj + case .TypeComment: return obj + case .TypeInteger: return obj + case .TypeFloat: return obj + case .TypeSymbol: return obj + case .TypeKeyword: return obj + case .TypeString: return obj + case .TypeList (let v): return make_list(MalList(v, meta)) + case .TypeVector (let v): return make_vector(MalVector(v, meta)) + case .TypeHashMap (let v): return make_hashmap(MalHashMap(v, meta)) + case .TypeAtom (let v): return make_atom(MalAtom(v, meta)) + case .TypeClosure (let v): return make_closure(MalClosure(v, meta)) + case .TypeBuiltin (let v): return make_builtin(MalBuiltin(v, meta)) + case .TypeMacro (let v): return make_macro(MalMacro(v, meta)) + } +} + +func unescape(s: String) -> String { + var index = 0 + var prev_is_escape = false + var str = "" + let chars = s.characters + for ch in chars { + if index == chars.count - 1 { continue } + if index++ == 0 { continue } + if prev_is_escape { + prev_is_escape = false + if ch == "n" { str.appendContentsOf("\n") } + else if ch == "r" { str.appendContentsOf("\r") } + else if ch == "t" { str.appendContentsOf("\t") } + else { str.append(ch) } + } else if ch == "\\" { + prev_is_escape = true + } else { + str.append(ch) + } + } + return str +} + +func escape(s: String) -> String { + var str = "" + let chars = s.characters + for ch in chars { + if ch == "\n" { str.appendContentsOf("\\n"); continue } + if ch == "\r" { str.appendContentsOf("\\r"); continue } + if ch == "\t" { str.appendContentsOf("\\t"); continue } + if ch == "\"" || ch == "\\" { str.appendContentsOf("\\") } + str.append(ch) + } + str = "\"" + str + "\"" + return str +} diff --git a/impls/swift3/Dockerfile b/impls/swift3/Dockerfile index 67fed0a3a0..6757f5bf44 100644 --- a/impls/swift3/Dockerfile +++ b/impls/swift3/Dockerfile @@ -1,44 +1,44 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Swift -RUN apt-get -y install clang-3.6 cmake pkg-config \ - git ninja-build uuid-dev libicu-dev icu-devtools \ - libbsd-dev libedit-dev libxml2-dev libsqlite3-dev \ - swig libpython-dev libncurses5-dev - -# TODO: better way to do this? -RUN ln -sf /usr/lib/llvm-3.6/bin/clang++ /usr/bin/clang++ -RUN ln -sf /usr/lib/llvm-3.6/bin/clang /usr/bin/clang - -ENV SWIFT_PREFIX swift-3.0.1-PREVIEW-3 -ENV SWIFT_RELEASE ${SWIFT_PREFIX}-ubuntu16.04 - -RUN cd /opt && \ - curl -O https://swift.org/builds/swift-3.0.1-preview-3/ubuntu1604/${SWIFT_PREFIX}/${SWIFT_RELEASE}.tar.gz && \ - tar xvzf ${SWIFT_RELEASE}.tar.gz && \ - rm ${SWIFT_RELEASE}.tar.gz - -ENV PATH /opt/${SWIFT_RELEASE}/usr/bin/:$PATH - - +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Swift +RUN apt-get -y install clang-3.6 cmake pkg-config \ + git ninja-build uuid-dev libicu-dev icu-devtools \ + libbsd-dev libedit-dev libxml2-dev libsqlite3-dev \ + swig libpython-dev libncurses5-dev + +# TODO: better way to do this? +RUN ln -sf /usr/lib/llvm-3.6/bin/clang++ /usr/bin/clang++ +RUN ln -sf /usr/lib/llvm-3.6/bin/clang /usr/bin/clang + +ENV SWIFT_PREFIX swift-3.0.1-PREVIEW-3 +ENV SWIFT_RELEASE ${SWIFT_PREFIX}-ubuntu16.04 + +RUN cd /opt && \ + curl -O https://swift.org/builds/swift-3.0.1-preview-3/ubuntu1604/${SWIFT_PREFIX}/${SWIFT_RELEASE}.tar.gz && \ + tar xvzf ${SWIFT_RELEASE}.tar.gz && \ + rm ${SWIFT_RELEASE}.tar.gz + +ENV PATH /opt/${SWIFT_RELEASE}/usr/bin/:$PATH + + diff --git a/impls/swift3/Makefile b/impls/swift3/Makefile index a76309c52c..3eb76548e3 100644 --- a/impls/swift3/Makefile +++ b/impls/swift3/Makefile @@ -1,29 +1,29 @@ -ifneq ($(shell which xcrun),) - SWIFT = xcrun -sdk macosx swiftc -else - SWIFT = swiftc -endif - -STEP3_DEPS = Sources/types.swift Sources/reader.swift Sources/printer.swift Sources/env.swift -STEP4_DEPS = $(STEP3_DEPS) Sources/core.swift - -STEPS = step0_repl step1_read_print step2_eval step3_env \ - step4_if_fn_do step5_tco step6_file step7_quote \ - step8_macros step9_try stepA_mal - -all: $(STEPS) - -dist: mal - -mal: stepA_mal - cp $< $@ - -step1_read_print step2_eval step3_env: $(STEP3_DEPS) -step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) - -step%: Sources/step%/main.swift - $(SWIFT) $+ -o $@ - -clean: - rm -f $(STEPS) mal - +ifneq ($(shell which xcrun),) + SWIFT = xcrun -sdk macosx swiftc +else + SWIFT = swiftc +endif + +STEP3_DEPS = Sources/types.swift Sources/reader.swift Sources/printer.swift Sources/env.swift +STEP4_DEPS = $(STEP3_DEPS) Sources/core.swift + +STEPS = step0_repl step1_read_print step2_eval step3_env \ + step4_if_fn_do step5_tco step6_file step7_quote \ + step8_macros step9_try stepA_mal + +all: $(STEPS) + +dist: mal + +mal: stepA_mal + cp $< $@ + +step1_read_print step2_eval step3_env: $(STEP3_DEPS) +step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) + +step%: Sources/step%/main.swift + $(SWIFT) $+ -o $@ + +clean: + rm -f $(STEPS) mal + diff --git a/impls/swift3/Sources/core.swift b/impls/swift3/Sources/core.swift index be44f35c4f..898a540a4d 100644 --- a/impls/swift3/Sources/core.swift +++ b/impls/swift3/Sources/core.swift @@ -1,467 +1,467 @@ -// TODO: remove this once time-ms and slurp use standard library calls - -#if os(Linux) -import Glibc -#else -import Darwin -#endif - -func IntOp(_ op: (Int, Int) -> Int, _ a: MalVal, _ b: MalVal) throws -> MalVal { - switch (a, b) { - case (MV.MalInt(let i1), MV.MalInt(let i2)): - return MV.MalInt(op(i1, i2)) - default: - throw MalError.General(msg: "Invalid IntOp call") - } -} - -func CmpOp(_ op: (Int, Int) -> Bool, _ a: MalVal, _ b: MalVal) throws -> MalVal { - switch (a, b) { - case (MV.MalInt(let i1), MV.MalInt(let i2)): - return wraptf(op(i1, i2)) - default: - throw MalError.General(msg: "Invalid CmpOp call") - } -} - - - -let core_ns: Dictionary) throws -> MalVal> = [ - "=": { wraptf(equal_Q($0[0], $0[1])) }, - "throw": { throw MalError.MalException(obj: $0[0]) }, - - "nil?": { - switch $0[0] { - case MV.MalNil(_): return MV.MalTrue - default: return MV.MalFalse - } - }, - "true?": { - switch $0[0] { - case MV.MalTrue(_): return MV.MalTrue - default: return MV.MalFalse - } - }, - "false?": { - switch $0[0] { - case MV.MalFalse(_): return MV.MalTrue - default: return MV.MalFalse - } - }, - "string?": { - switch $0[0] { - case MV.MalString(let s) where s.characters.count == 0: - return MV.MalTrue - case MV.MalString(let s): - return wraptf(s[s.startIndex] != "\u{029e}") - default: return MV.MalFalse - } - }, - "symbol": { - switch $0[0] { - case MV.MalSymbol(_): return $0[0] - case MV.MalString(let s): return MV.MalSymbol(s) - default: throw MalError.General(msg: "Invalid symbol call") - } - }, - "symbol?": { - switch $0[0] { - case MV.MalSymbol(_): return MV.MalTrue - default: return MV.MalFalse - } - }, - "keyword": { - switch $0[0] { - case MV.MalString(let s) where s.characters.count > 0: - if s[s.startIndex] == "\u{029e}" { return $0[0] } - else { return MV.MalString("\u{029e}\(s)") } - default: throw MalError.General(msg: "Invalid symbol call") - } - }, - "keyword?": { - switch $0[0] { - case MV.MalString(let s) where s.characters.count > 0: - return wraptf(s[s.startIndex] == "\u{029e}") - default: return MV.MalFalse - } - }, - "number?": { - switch $0[0] { - case MV.MalInt(_): return MV.MalTrue - default: return MV.MalFalse - } - }, - "fn?": { - switch $0[0] { - case MalVal.MalFunc(_, nil, _, _, _, _), - MalVal.MalFunc(_, _, _, _, false, _): return MV.MalTrue - default: return MV.MalFalse - } - }, - "macro?": { - switch $0[0] { - case MalVal.MalFunc(_, _, _, _, true, _): return MV.MalTrue - default: return MV.MalFalse - } - }, - - "pr-str": { - // TODO: if the following two statements are combined into one, we get - // the following error message. It's not clear to me that there's - // actually any error, so this might be a compiler issue. - // - // Sources/core.swift:29:59: error: type of expression is ambiguous without more context - // let core_ns: [String: (Array) throws -> MalVal] = [ - // ^ - - let s = $0.map { pr_str($0,true) }.joined(separator: " ") - return MV.MalString(s) - }, - "str": { - // The comment for "pr-str" applies here, too. - let s = $0.map { pr_str($0,false) }.joined(separator: "") - return MV.MalString(s) - }, - "prn": { - print($0.map { pr_str($0,true) }.joined(separator: " ")) - return MV.MalNil - }, - "println": { - print($0.map { pr_str($0,false) }.joined(separator: " ")) - return MV.MalNil - }, - "read-string": { - switch $0[0] { - case MV.MalString(let str): return try read_str(str) - default: throw MalError.General(msg: "Invalid read-string call") - } - }, - "readline": { - switch $0[0] { - case MV.MalString(let prompt): - print(prompt, terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { return MV.MalNil } - return MV.MalString(line!) - default: throw MalError.General(msg: "Invalid readline call") - } - }, - "slurp": { - switch $0[0] { - case MV.MalString(let file): - let data = try String(contentsOfFile: file, encoding: String.Encoding.utf8) - return MV.MalString(data) - default: throw MalError.General(msg: "Invalid slurp call") - } - }, - - - "<": { try CmpOp({ $0 < $1}, $0[0], $0[1]) }, - "<=": { try CmpOp({ $0 <= $1}, $0[0], $0[1]) }, - ">": { try CmpOp({ $0 > $1}, $0[0], $0[1]) }, - ">=": { try CmpOp({ $0 >= $1}, $0[0], $0[1]) }, - "+": { try IntOp({ $0 + $1}, $0[0], $0[1]) }, - "-": { try IntOp({ $0 - $1}, $0[0], $0[1]) }, - "*": { try IntOp({ $0 * $1}, $0[0], $0[1]) }, - "/": { try IntOp({ $0 / $1}, $0[0], $0[1]) }, - "time-ms": { - let read = $0; // no parameters - - // TODO: replace with something more like this - // return MV.MalInt(NSDate().timeIntervalSince1970 ) - - var tv:timeval = timeval(tv_sec: 0, tv_usec: 0) - gettimeofday(&tv, nil) - return MV.MalInt(tv.tv_sec * 1000 + Int(tv.tv_usec)/1000) - }, - - "list": { list($0) }, - "list?": { - switch $0[0] { - case MV.MalList: return MV.MalTrue - default: return MV.MalFalse - } - }, - "vector": { vector($0) }, - "vector?": { - switch $0[0] { - case MV.MalVector: return MV.MalTrue - default: return MV.MalFalse - } - }, - "hash-map": { try hash_map($0) }, - "map?": { - switch $0[0] { - case MV.MalHashMap: return MV.MalTrue - default: return MV.MalFalse - } - }, - "assoc": { - switch $0[0] { - case MV.MalHashMap(let dict, _): - return hash_map(try _assoc(dict, Array($0[1..<$0.endIndex]))) - default: throw MalError.General(msg: "Invalid assoc call") - } - }, - "dissoc": { - switch $0[0] { - case MV.MalHashMap(let dict, _): - return hash_map(try _dissoc(dict, Array($0[1..<$0.endIndex]))) - default: throw MalError.General(msg: "Invalid dissoc call") - } - }, - "get": { - switch ($0[0], $0[1]) { - case (MV.MalHashMap(let dict, _), MV.MalString(let k)): - return dict[k] ?? MV.MalNil - case (MV.MalNil, MV.MalString(let k)): - return MV.MalNil - default: throw MalError.General(msg: "Invalid get call") - } - }, - "contains?": { - switch ($0[0], $0[1]) { - case (MV.MalHashMap(let dict, _), MV.MalString(let k)): - return dict[k] != nil ? MV.MalTrue : MV.MalFalse - case (MV.MalNil, MV.MalString(let k)): - return MV.MalFalse - default: throw MalError.General(msg: "Invalid contains? call") - } - }, - "keys": { - switch $0[0] { - case MV.MalHashMap(let dict, _): - return list(dict.keys.map { MV.MalString($0) }) - default: throw MalError.General(msg: "Invalid keys call") - } - }, - "vals": { - switch $0[0] { - case MV.MalHashMap(let dict, _): - return list(dict.values.map { $0 }) - default: throw MalError.General(msg: "Invalid vals call") - } - }, - - - "sequential?": { - switch $0[0] { - case MV.MalList: return MV.MalTrue - case MV.MalVector: return MV.MalTrue - default: return MV.MalFalse - } - }, - "cons": { - if $0.count != 2 { throw MalError.General(msg: "Invalid cons call") } - switch ($0[0], $0[1]) { - case (let mv, MV.MalList(let lst, _)): - return list([mv] + lst) - case (let mv, MV.MalVector(let lst, _)): - return list([mv] + lst) - default: throw MalError.General(msg: "Invalid cons call") - } - }, - "concat": { - var res = Array() - for seq in $0 { - switch seq { - case MV.MalList(let lst, _): res = res + lst - case MV.MalVector(let lst, _): res = res + lst - default: throw MalError.General(msg: "Invalid concat call") - } - } - return list(res) - }, - "vec": { - if $0.count != 1 { throw MalError.General(msg: "Invalid vec call") } - switch $0[0] { - case MV.MalList (let lst, _): return vector(lst) - case MV.MalVector(let lst, _): return vector(lst) - default: throw MalError.General(msg: "Invalid vec call") - } - }, - "nth": { - if $0.count != 2 { throw MalError.General(msg: "Invalid nth call") } - switch ($0[0], $0[1]) { - case (MV.MalList(let lst, _), MV.MalInt(let idx)): - if idx >= lst.count { - throw MalError.General(msg: "nth: index out of range") - } - return try _nth($0[0], idx) - case (MV.MalVector(let lst, _), MV.MalInt(let idx)): - if idx >= lst.count { - throw MalError.General(msg: "nth: index out of range") - } - return try _nth($0[0], idx) - default: - throw MalError.General(msg: "Invalid nth call") - } - }, - "first": { - switch $0[0] { - case MV.MalList(let lst, _): - return lst.count > 0 ? lst[0] : MV.MalNil - case MV.MalVector(let lst, _): - return lst.count > 0 ? lst[0] : MV.MalNil - case MV.MalNil: return MV.MalNil - default: throw MalError.General(msg: "Invalid first call") - } - }, - "rest": { - switch $0[0] { - case MV.MalList(let lst, _): - return lst.count > 0 ? try rest($0[0]) : list([]) - case MV.MalVector(let lst, _): - return lst.count > 0 ? try rest($0[0]) : list([]) - case MV.MalNil: return list([]) - default: throw MalError.General(msg: "Invalid rest call") - } - }, - "empty?": { - switch $0[0] { - case MV.MalList(let lst, _): - return lst.count == 0 ? MV.MalTrue : MV.MalFalse - case MV.MalVector(let lst, _): - return lst.count == 0 ? MV.MalTrue : MV.MalFalse - case MV.MalNil: return MV.MalTrue - default: throw MalError.General(msg: "Invalid empty? call") - } - }, - "count": { - switch $0[0] { - case MV.MalList(let lst, _): return MV.MalInt(lst.count) - case MV.MalVector(let lst, _): return MV.MalInt(lst.count) - case MV.MalNil: return MV.MalInt(0) - default: throw MalError.General(msg: "Invalid count call") - } - }, - "apply": { - let fn: (Array) throws -> MalVal - switch $0[0] { - case MV.MalFunc(let f, _, _, _, _, _): fn = f - default: throw MalError.General(msg: "Invalid apply call") - } - - var args = Array($0[1..<$0.endIndex-1]) - switch $0[$0.endIndex-1] { - case MV.MalList(let l, _): args = args + l - case MV.MalVector(let l, _): args = args + l - default: throw MalError.General(msg: "Invalid apply call") - } - - return try fn(args) - }, - "map": { - let fn: (Array) throws -> MalVal - switch $0[0] { - case MV.MalFunc(let f, _, _, _, _, _): fn = f - default: throw MalError.General(msg: "Invalid map call") - } - - var lst = Array() - switch $0[1] { - case MV.MalList(let l, _): lst = l - case MV.MalVector(let l, _): lst = l - default: throw MalError.General(msg: "Invalid map call") - } - - var res = Array() - for mv in lst { - res.append(try fn([mv])) - } - return list(res) - }, - - "conj": { - if $0.count < 1 { throw MalError.General(msg: "Invalid conj call") } - switch $0[0] { - case MV.MalList(let lst, _): - let a = Array($0[1..<$0.endIndex]).reversed() - return list(a + lst) - case MV.MalVector(let lst, _): - return vector(lst + $0[1..<$0.endIndex]) - default: throw MalError.General(msg: "Invalid conj call") - } - }, - "seq": { - if $0.count < 1 { throw MalError.General(msg: "Invalid seq call") } - switch $0[0] { - case MV.MalList(let lst, _): - if lst.count == 0 { return MV.MalNil } - return $0[0] - case MV.MalVector(let lst, _): - if lst.count == 0 { return MV.MalNil } - return list(lst) - case MV.MalString(let str): - if str.characters.count == 0 { return MV.MalNil } - return list(str.characters.map { MV.MalString(String($0)) }) - case MV.MalNil: - return MV.MalNil - default: throw MalError.General(msg: "Invalid seq call") - } - }, - - "meta": { - switch $0[0] { - case MV.MalList(_, let m): - return m != nil ? m![0] : MV.MalNil - case MV.MalVector(_, let m): - return m != nil ? m![0] : MV.MalNil - case MV.MalHashMap(_, let m): - return m != nil ? m![0] : MV.MalNil - case MV.MalFunc(_, _, _, _, _, let m): - return m != nil ? m![0] : MV.MalNil - default: throw MalError.General(msg: "meta called on non-function") - } - }, - "with-meta": { - switch $0[0] { - case MV.MalList(let l, _): - return list(l, meta: $0[1]) - case MV.MalVector(let l, _): - return vector(l, meta: $0[1]) - case MV.MalHashMap(let d, _): - return hash_map(d, meta: $0[1]) - case MV.MalFunc(let f, let a, let e, let p, let m, _): - return malfunc(f, ast:a, env:e, params:p, macro:m, meta:$0[1]) - //return MV.MalFunc(f,ast:a,env:e,params:p,macro:m,meta:[$0[1]]) - default: - throw MalError.General(msg: "with-meta called on non-collection") - } - }, - "atom": { - return MV.MalAtom(MutableAtom(val: $0[0])) - }, - "atom?": { - switch $0[0] { - case MV.MalAtom(_): return MV.MalTrue - default: return MV.MalFalse - } - }, - "deref": { - switch $0[0] { - case MV.MalAtom(let ma): return ma.val - default: throw MalError.General(msg: "Invalid deref call") - } - }, - "reset!": { - switch $0[0] { - case MV.MalAtom(var a): - a.val = $0[1] - return $0[1] - default: throw MalError.General(msg: "Invalid reset! call") - } - }, - "swap!": { - switch ($0[0], $0[1]) { - case (MV.MalAtom(var a), MV.MalFunc(let fn, _, _, _, _, _)): - var args = [a.val] - if $0.count > 2 { - args = args + Array($0[2..<$0.endIndex]) - } - a.val = try fn(args) - return a.val - default: throw MalError.General(msg: "Invalid swap! call") - } - }, -] +// TODO: remove this once time-ms and slurp use standard library calls + +#if os(Linux) +import Glibc +#else +import Darwin +#endif + +func IntOp(_ op: (Int, Int) -> Int, _ a: MalVal, _ b: MalVal) throws -> MalVal { + switch (a, b) { + case (MV.MalInt(let i1), MV.MalInt(let i2)): + return MV.MalInt(op(i1, i2)) + default: + throw MalError.General(msg: "Invalid IntOp call") + } +} + +func CmpOp(_ op: (Int, Int) -> Bool, _ a: MalVal, _ b: MalVal) throws -> MalVal { + switch (a, b) { + case (MV.MalInt(let i1), MV.MalInt(let i2)): + return wraptf(op(i1, i2)) + default: + throw MalError.General(msg: "Invalid CmpOp call") + } +} + + + +let core_ns: Dictionary) throws -> MalVal> = [ + "=": { wraptf(equal_Q($0[0], $0[1])) }, + "throw": { throw MalError.MalException(obj: $0[0]) }, + + "nil?": { + switch $0[0] { + case MV.MalNil(_): return MV.MalTrue + default: return MV.MalFalse + } + }, + "true?": { + switch $0[0] { + case MV.MalTrue(_): return MV.MalTrue + default: return MV.MalFalse + } + }, + "false?": { + switch $0[0] { + case MV.MalFalse(_): return MV.MalTrue + default: return MV.MalFalse + } + }, + "string?": { + switch $0[0] { + case MV.MalString(let s) where s.characters.count == 0: + return MV.MalTrue + case MV.MalString(let s): + return wraptf(s[s.startIndex] != "\u{029e}") + default: return MV.MalFalse + } + }, + "symbol": { + switch $0[0] { + case MV.MalSymbol(_): return $0[0] + case MV.MalString(let s): return MV.MalSymbol(s) + default: throw MalError.General(msg: "Invalid symbol call") + } + }, + "symbol?": { + switch $0[0] { + case MV.MalSymbol(_): return MV.MalTrue + default: return MV.MalFalse + } + }, + "keyword": { + switch $0[0] { + case MV.MalString(let s) where s.characters.count > 0: + if s[s.startIndex] == "\u{029e}" { return $0[0] } + else { return MV.MalString("\u{029e}\(s)") } + default: throw MalError.General(msg: "Invalid symbol call") + } + }, + "keyword?": { + switch $0[0] { + case MV.MalString(let s) where s.characters.count > 0: + return wraptf(s[s.startIndex] == "\u{029e}") + default: return MV.MalFalse + } + }, + "number?": { + switch $0[0] { + case MV.MalInt(_): return MV.MalTrue + default: return MV.MalFalse + } + }, + "fn?": { + switch $0[0] { + case MalVal.MalFunc(_, nil, _, _, _, _), + MalVal.MalFunc(_, _, _, _, false, _): return MV.MalTrue + default: return MV.MalFalse + } + }, + "macro?": { + switch $0[0] { + case MalVal.MalFunc(_, _, _, _, true, _): return MV.MalTrue + default: return MV.MalFalse + } + }, + + "pr-str": { + // TODO: if the following two statements are combined into one, we get + // the following error message. It's not clear to me that there's + // actually any error, so this might be a compiler issue. + // + // Sources/core.swift:29:59: error: type of expression is ambiguous without more context + // let core_ns: [String: (Array) throws -> MalVal] = [ + // ^ + + let s = $0.map { pr_str($0,true) }.joined(separator: " ") + return MV.MalString(s) + }, + "str": { + // The comment for "pr-str" applies here, too. + let s = $0.map { pr_str($0,false) }.joined(separator: "") + return MV.MalString(s) + }, + "prn": { + print($0.map { pr_str($0,true) }.joined(separator: " ")) + return MV.MalNil + }, + "println": { + print($0.map { pr_str($0,false) }.joined(separator: " ")) + return MV.MalNil + }, + "read-string": { + switch $0[0] { + case MV.MalString(let str): return try read_str(str) + default: throw MalError.General(msg: "Invalid read-string call") + } + }, + "readline": { + switch $0[0] { + case MV.MalString(let prompt): + print(prompt, terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { return MV.MalNil } + return MV.MalString(line!) + default: throw MalError.General(msg: "Invalid readline call") + } + }, + "slurp": { + switch $0[0] { + case MV.MalString(let file): + let data = try String(contentsOfFile: file, encoding: String.Encoding.utf8) + return MV.MalString(data) + default: throw MalError.General(msg: "Invalid slurp call") + } + }, + + + "<": { try CmpOp({ $0 < $1}, $0[0], $0[1]) }, + "<=": { try CmpOp({ $0 <= $1}, $0[0], $0[1]) }, + ">": { try CmpOp({ $0 > $1}, $0[0], $0[1]) }, + ">=": { try CmpOp({ $0 >= $1}, $0[0], $0[1]) }, + "+": { try IntOp({ $0 + $1}, $0[0], $0[1]) }, + "-": { try IntOp({ $0 - $1}, $0[0], $0[1]) }, + "*": { try IntOp({ $0 * $1}, $0[0], $0[1]) }, + "/": { try IntOp({ $0 / $1}, $0[0], $0[1]) }, + "time-ms": { + let read = $0; // no parameters + + // TODO: replace with something more like this + // return MV.MalInt(NSDate().timeIntervalSince1970 ) + + var tv:timeval = timeval(tv_sec: 0, tv_usec: 0) + gettimeofday(&tv, nil) + return MV.MalInt(tv.tv_sec * 1000 + Int(tv.tv_usec)/1000) + }, + + "list": { list($0) }, + "list?": { + switch $0[0] { + case MV.MalList: return MV.MalTrue + default: return MV.MalFalse + } + }, + "vector": { vector($0) }, + "vector?": { + switch $0[0] { + case MV.MalVector: return MV.MalTrue + default: return MV.MalFalse + } + }, + "hash-map": { try hash_map($0) }, + "map?": { + switch $0[0] { + case MV.MalHashMap: return MV.MalTrue + default: return MV.MalFalse + } + }, + "assoc": { + switch $0[0] { + case MV.MalHashMap(let dict, _): + return hash_map(try _assoc(dict, Array($0[1..<$0.endIndex]))) + default: throw MalError.General(msg: "Invalid assoc call") + } + }, + "dissoc": { + switch $0[0] { + case MV.MalHashMap(let dict, _): + return hash_map(try _dissoc(dict, Array($0[1..<$0.endIndex]))) + default: throw MalError.General(msg: "Invalid dissoc call") + } + }, + "get": { + switch ($0[0], $0[1]) { + case (MV.MalHashMap(let dict, _), MV.MalString(let k)): + return dict[k] ?? MV.MalNil + case (MV.MalNil, MV.MalString(let k)): + return MV.MalNil + default: throw MalError.General(msg: "Invalid get call") + } + }, + "contains?": { + switch ($0[0], $0[1]) { + case (MV.MalHashMap(let dict, _), MV.MalString(let k)): + return dict[k] != nil ? MV.MalTrue : MV.MalFalse + case (MV.MalNil, MV.MalString(let k)): + return MV.MalFalse + default: throw MalError.General(msg: "Invalid contains? call") + } + }, + "keys": { + switch $0[0] { + case MV.MalHashMap(let dict, _): + return list(dict.keys.map { MV.MalString($0) }) + default: throw MalError.General(msg: "Invalid keys call") + } + }, + "vals": { + switch $0[0] { + case MV.MalHashMap(let dict, _): + return list(dict.values.map { $0 }) + default: throw MalError.General(msg: "Invalid vals call") + } + }, + + + "sequential?": { + switch $0[0] { + case MV.MalList: return MV.MalTrue + case MV.MalVector: return MV.MalTrue + default: return MV.MalFalse + } + }, + "cons": { + if $0.count != 2 { throw MalError.General(msg: "Invalid cons call") } + switch ($0[0], $0[1]) { + case (let mv, MV.MalList(let lst, _)): + return list([mv] + lst) + case (let mv, MV.MalVector(let lst, _)): + return list([mv] + lst) + default: throw MalError.General(msg: "Invalid cons call") + } + }, + "concat": { + var res = Array() + for seq in $0 { + switch seq { + case MV.MalList(let lst, _): res = res + lst + case MV.MalVector(let lst, _): res = res + lst + default: throw MalError.General(msg: "Invalid concat call") + } + } + return list(res) + }, + "vec": { + if $0.count != 1 { throw MalError.General(msg: "Invalid vec call") } + switch $0[0] { + case MV.MalList (let lst, _): return vector(lst) + case MV.MalVector(let lst, _): return vector(lst) + default: throw MalError.General(msg: "Invalid vec call") + } + }, + "nth": { + if $0.count != 2 { throw MalError.General(msg: "Invalid nth call") } + switch ($0[0], $0[1]) { + case (MV.MalList(let lst, _), MV.MalInt(let idx)): + if idx >= lst.count { + throw MalError.General(msg: "nth: index out of range") + } + return try _nth($0[0], idx) + case (MV.MalVector(let lst, _), MV.MalInt(let idx)): + if idx >= lst.count { + throw MalError.General(msg: "nth: index out of range") + } + return try _nth($0[0], idx) + default: + throw MalError.General(msg: "Invalid nth call") + } + }, + "first": { + switch $0[0] { + case MV.MalList(let lst, _): + return lst.count > 0 ? lst[0] : MV.MalNil + case MV.MalVector(let lst, _): + return lst.count > 0 ? lst[0] : MV.MalNil + case MV.MalNil: return MV.MalNil + default: throw MalError.General(msg: "Invalid first call") + } + }, + "rest": { + switch $0[0] { + case MV.MalList(let lst, _): + return lst.count > 0 ? try rest($0[0]) : list([]) + case MV.MalVector(let lst, _): + return lst.count > 0 ? try rest($0[0]) : list([]) + case MV.MalNil: return list([]) + default: throw MalError.General(msg: "Invalid rest call") + } + }, + "empty?": { + switch $0[0] { + case MV.MalList(let lst, _): + return lst.count == 0 ? MV.MalTrue : MV.MalFalse + case MV.MalVector(let lst, _): + return lst.count == 0 ? MV.MalTrue : MV.MalFalse + case MV.MalNil: return MV.MalTrue + default: throw MalError.General(msg: "Invalid empty? call") + } + }, + "count": { + switch $0[0] { + case MV.MalList(let lst, _): return MV.MalInt(lst.count) + case MV.MalVector(let lst, _): return MV.MalInt(lst.count) + case MV.MalNil: return MV.MalInt(0) + default: throw MalError.General(msg: "Invalid count call") + } + }, + "apply": { + let fn: (Array) throws -> MalVal + switch $0[0] { + case MV.MalFunc(let f, _, _, _, _, _): fn = f + default: throw MalError.General(msg: "Invalid apply call") + } + + var args = Array($0[1..<$0.endIndex-1]) + switch $0[$0.endIndex-1] { + case MV.MalList(let l, _): args = args + l + case MV.MalVector(let l, _): args = args + l + default: throw MalError.General(msg: "Invalid apply call") + } + + return try fn(args) + }, + "map": { + let fn: (Array) throws -> MalVal + switch $0[0] { + case MV.MalFunc(let f, _, _, _, _, _): fn = f + default: throw MalError.General(msg: "Invalid map call") + } + + var lst = Array() + switch $0[1] { + case MV.MalList(let l, _): lst = l + case MV.MalVector(let l, _): lst = l + default: throw MalError.General(msg: "Invalid map call") + } + + var res = Array() + for mv in lst { + res.append(try fn([mv])) + } + return list(res) + }, + + "conj": { + if $0.count < 1 { throw MalError.General(msg: "Invalid conj call") } + switch $0[0] { + case MV.MalList(let lst, _): + let a = Array($0[1..<$0.endIndex]).reversed() + return list(a + lst) + case MV.MalVector(let lst, _): + return vector(lst + $0[1..<$0.endIndex]) + default: throw MalError.General(msg: "Invalid conj call") + } + }, + "seq": { + if $0.count < 1 { throw MalError.General(msg: "Invalid seq call") } + switch $0[0] { + case MV.MalList(let lst, _): + if lst.count == 0 { return MV.MalNil } + return $0[0] + case MV.MalVector(let lst, _): + if lst.count == 0 { return MV.MalNil } + return list(lst) + case MV.MalString(let str): + if str.characters.count == 0 { return MV.MalNil } + return list(str.characters.map { MV.MalString(String($0)) }) + case MV.MalNil: + return MV.MalNil + default: throw MalError.General(msg: "Invalid seq call") + } + }, + + "meta": { + switch $0[0] { + case MV.MalList(_, let m): + return m != nil ? m![0] : MV.MalNil + case MV.MalVector(_, let m): + return m != nil ? m![0] : MV.MalNil + case MV.MalHashMap(_, let m): + return m != nil ? m![0] : MV.MalNil + case MV.MalFunc(_, _, _, _, _, let m): + return m != nil ? m![0] : MV.MalNil + default: throw MalError.General(msg: "meta called on non-function") + } + }, + "with-meta": { + switch $0[0] { + case MV.MalList(let l, _): + return list(l, meta: $0[1]) + case MV.MalVector(let l, _): + return vector(l, meta: $0[1]) + case MV.MalHashMap(let d, _): + return hash_map(d, meta: $0[1]) + case MV.MalFunc(let f, let a, let e, let p, let m, _): + return malfunc(f, ast:a, env:e, params:p, macro:m, meta:$0[1]) + //return MV.MalFunc(f,ast:a,env:e,params:p,macro:m,meta:[$0[1]]) + default: + throw MalError.General(msg: "with-meta called on non-collection") + } + }, + "atom": { + return MV.MalAtom(MutableAtom(val: $0[0])) + }, + "atom?": { + switch $0[0] { + case MV.MalAtom(_): return MV.MalTrue + default: return MV.MalFalse + } + }, + "deref": { + switch $0[0] { + case MV.MalAtom(let ma): return ma.val + default: throw MalError.General(msg: "Invalid deref call") + } + }, + "reset!": { + switch $0[0] { + case MV.MalAtom(var a): + a.val = $0[1] + return $0[1] + default: throw MalError.General(msg: "Invalid reset! call") + } + }, + "swap!": { + switch ($0[0], $0[1]) { + case (MV.MalAtom(var a), MV.MalFunc(let fn, _, _, _, _, _)): + var args = [a.val] + if $0.count > 2 { + args = args + Array($0[2..<$0.endIndex]) + } + a.val = try fn(args) + return a.val + default: throw MalError.General(msg: "Invalid swap! call") + } + }, +] diff --git a/impls/swift3/Sources/env.swift b/impls/swift3/Sources/env.swift index f080dce800..8feec7782e 100644 --- a/impls/swift3/Sources/env.swift +++ b/impls/swift3/Sources/env.swift @@ -1,89 +1,89 @@ -class Env { - var outer: Env? = nil - var data: Dictionary = [:] - - init(_ outer: Env? = nil, binds: MalVal? = nil, - exprs: MalVal? = nil) throws { - self.outer = outer - - if binds != nil { - var bs = Array(), es = Array() - //print("binds: \(binds), exprs: \(exprs)") - switch (binds!, exprs!) { - case (MalVal.MalList(let l1, _), MalVal.MalList(let l2, _)): - bs = l1; es = l2 - case (MalVal.MalVector(let l1, _), MalVal.MalList(let l2, _)): - bs = l1; es = l2 - default: - throw MalError.General(msg: "invalid Env init call") - } - - var pos = bs.startIndex - - bhandle: - while pos < bs.endIndex { - let b = bs[pos] - switch b { - case MalVal.MalSymbol("&"): - switch bs[bs.index(after: pos)] { - case MalVal.MalSymbol(let sym): - if pos < es.endIndex { - let slc = es[pos.. Env? { - switch key { - case MalVal.MalSymbol(let str): - if data[str] != nil { - return self - } else if outer != nil { - return try outer!.find(key) - } else { - return nil - } - default: - throw MalError.General(msg: "invalid Env.find call") - } - } - - func get(_ key: MalVal) throws -> MalVal { - switch key { - case MalVal.MalSymbol(let str): - let env = try self.find(key) - if env == nil { - throw MalError.General(msg: "'\(str)' not found") - } - return env!.data[str]! - default: - throw MalError.General(msg: "invalid Env.find call") - } - } - - @discardableResult - func set(_ key: MalVal, _ val: MalVal) throws -> MalVal { - switch key { - case MalVal.MalSymbol(let str): - data[str] = val - return val - default: - throw MalError.General(msg: "invalid Env.find call") - } - } -} +class Env { + var outer: Env? = nil + var data: Dictionary = [:] + + init(_ outer: Env? = nil, binds: MalVal? = nil, + exprs: MalVal? = nil) throws { + self.outer = outer + + if binds != nil { + var bs = Array(), es = Array() + //print("binds: \(binds), exprs: \(exprs)") + switch (binds!, exprs!) { + case (MalVal.MalList(let l1, _), MalVal.MalList(let l2, _)): + bs = l1; es = l2 + case (MalVal.MalVector(let l1, _), MalVal.MalList(let l2, _)): + bs = l1; es = l2 + default: + throw MalError.General(msg: "invalid Env init call") + } + + var pos = bs.startIndex + + bhandle: + while pos < bs.endIndex { + let b = bs[pos] + switch b { + case MalVal.MalSymbol("&"): + switch bs[bs.index(after: pos)] { + case MalVal.MalSymbol(let sym): + if pos < es.endIndex { + let slc = es[pos.. Env? { + switch key { + case MalVal.MalSymbol(let str): + if data[str] != nil { + return self + } else if outer != nil { + return try outer!.find(key) + } else { + return nil + } + default: + throw MalError.General(msg: "invalid Env.find call") + } + } + + func get(_ key: MalVal) throws -> MalVal { + switch key { + case MalVal.MalSymbol(let str): + let env = try self.find(key) + if env == nil { + throw MalError.General(msg: "'\(str)' not found") + } + return env!.data[str]! + default: + throw MalError.General(msg: "invalid Env.find call") + } + } + + @discardableResult + func set(_ key: MalVal, _ val: MalVal) throws -> MalVal { + switch key { + case MalVal.MalSymbol(let str): + data[str] = val + return val + default: + throw MalError.General(msg: "invalid Env.find call") + } + } +} diff --git a/impls/swift3/Sources/printer.swift b/impls/swift3/Sources/printer.swift index b4ec36a1d9..2121f13e1d 100644 --- a/impls/swift3/Sources/printer.swift +++ b/impls/swift3/Sources/printer.swift @@ -1,43 +1,43 @@ - -func pr_str(_ obj: MalVal, _ print_readably: Bool = true) -> String { - switch obj { - case MalVal.MalList(let lst, _): - let elems = lst.map { pr_str($0, print_readably) } - return "(" + elems.joined(separator: " ") + ")" - case MalVal.MalVector(let lst, _): - let elems = lst.map { pr_str($0, print_readably) } - return "[" + elems.joined(separator: " ") + "]" - case MalVal.MalHashMap(let dict, _): - let elems = dict.map { - pr_str(MalVal.MalString($0), print_readably) + - " " + pr_str($1, print_readably) - } - return "{" + elems.joined(separator: " ") + "}" - case MalVal.MalString(let str): - //print("kw: '\(str[str.startIndex])'") - if str.characters.count > 0 && str[str.startIndex] == "\u{029e}" { - return ":" + str[str.index(after: str.startIndex).." - case MalVal.MalFunc(_, let ast, _, let params, _, _): - return "(fn* \(pr_str(params![0])) \(pr_str(ast![0])))" - case MalVal.MalAtom(let ma): - return "(atom \(pr_str(ma.val, print_readably)))" - default: - return String(describing:obj) - } -} + +func pr_str(_ obj: MalVal, _ print_readably: Bool = true) -> String { + switch obj { + case MalVal.MalList(let lst, _): + let elems = lst.map { pr_str($0, print_readably) } + return "(" + elems.joined(separator: " ") + ")" + case MalVal.MalVector(let lst, _): + let elems = lst.map { pr_str($0, print_readably) } + return "[" + elems.joined(separator: " ") + "]" + case MalVal.MalHashMap(let dict, _): + let elems = dict.map { + pr_str(MalVal.MalString($0), print_readably) + + " " + pr_str($1, print_readably) + } + return "{" + elems.joined(separator: " ") + "}" + case MalVal.MalString(let str): + //print("kw: '\(str[str.startIndex])'") + if str.characters.count > 0 && str[str.startIndex] == "\u{029e}" { + return ":" + str[str.index(after: str.startIndex).." + case MalVal.MalFunc(_, let ast, _, let params, _, _): + return "(fn* \(pr_str(params![0])) \(pr_str(ast![0])))" + case MalVal.MalAtom(let ma): + return "(atom \(pr_str(ma.val, print_readably)))" + default: + return String(describing:obj) + } +} diff --git a/impls/swift3/Sources/reader.swift b/impls/swift3/Sources/reader.swift index cbb51d17ce..a7061a77a3 100644 --- a/impls/swift3/Sources/reader.swift +++ b/impls/swift3/Sources/reader.swift @@ -1,207 +1,207 @@ -let token_delim: Set = [ - ";", ",", "\"", "`", " ", "\n", "{", "}", "(", ")", "[", "]" -] - -let int_char: Set = [ - "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9" -] - -let float_char: Set = [ - ".", "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9" -] - -let whitespace: Set = [" ", "\t", "\n", ","] - -class Reader { - var str: String - var pos: String.Index - init(_ str: String) { - self.str = str - pos = str.startIndex - } - func next() { pos = str.index(after: pos) } -} - -func read_int(_ rdr: Reader) -> MalVal { - let start = rdr.pos - var cidx = rdr.pos - while cidx < rdr.str.endIndex { - if !int_char.contains(rdr.str[cidx]) { break } - cidx = rdr.str.index(after: cidx) - rdr.pos = cidx - } - let matchStr = rdr.str.substring(with: start.. MalVal { - let start = rdr.pos - var escaped = false - if rdr.str[rdr.pos] != "\"" { - throw MalError.Reader(msg: "read_string call on non-string") - } - var cidx = rdr.str.index(after: rdr.pos) - while cidx < rdr.str.endIndex { - rdr.pos = rdr.str.index(after: cidx) - if escaped { - escaped = false - cidx = rdr.pos - continue - } - if rdr.str[cidx] == "\\" { escaped = true } - if rdr.str[cidx] == "\"" { break } - cidx = rdr.pos - } - if cidx >= rdr.str.endIndex || rdr.str[rdr.str.index(before: rdr.pos)] != "\"" { - throw MalError.Reader(msg: "Expected '\"', got EOF") - } - let matchStr = rdr.str.substring(with: - rdr.str.index(after: start).. String { - let start = rdr.pos - var cidx = rdr.pos - while cidx < rdr.str.endIndex { - rdr.pos = cidx - if token_delim.contains(rdr.str[cidx]) { break } - cidx = rdr.str.index(after: cidx) - rdr.pos = cidx - } - return rdr.str.substring(with: start.. MalVal { - let tok = read_token(rdr) - switch tok { - case "nil": return MalVal.MalNil - case "true": return MalVal.MalTrue - case "false": return MalVal.MalFalse - default: return MalVal.MalSymbol(tok) - } -} - -func read_atom(_ rdr: Reader) throws -> MalVal { - if rdr.str.characters.count == 0 { - throw MalError.Reader(msg: "Empty string passed to read_atom") - } - switch rdr.str[rdr.pos] { - case "-" where rdr.str.characters.count == 1 || !int_char.contains(rdr.str[rdr.str.index(after: rdr.pos)]): - return try read_symbol(rdr) - case let c where int_char.contains(c): - return read_int(rdr) - case "\"": - return try read_string(rdr) - case ":": - rdr.next() - return MalVal.MalString("\u{029e}\(read_token(rdr))") - default: - return try read_symbol(rdr) - } -} - -func read_list(_ rdr: Reader, start: Character = "(", end: Character = ")") throws -> Array { - if rdr.str[rdr.pos] != start { - throw MalError.Reader(msg: "expected '\(start)'") - } - rdr.next() - skip_whitespace_and_comments(rdr) - var lst: [MalVal] = [] - while rdr.pos < rdr.str.endIndex { - if (rdr.str[rdr.pos] == end) { break } - lst.append(try read_form(rdr)) - } - if rdr.pos >= rdr.str.endIndex { - throw MalError.Reader(msg: "Expected '\(end)', got EOF") - } - rdr.next() - return lst -} - -func read_form(_ rdr: Reader) throws -> MalVal { - if rdr.str.characters.count == 0 { - throw MalError.Reader(msg: "Empty string passed to read_form") - } - //print("read_form: \(rdr.pos): \(rdr.str[rdr.pos])") - skip_whitespace_and_comments(rdr) - var res: MalVal - switch rdr.str[rdr.pos] { - // reader macros/transforms - case "'": - rdr.next() - return list([MalVal.MalSymbol("quote"), try read_form(rdr)]) - case "`": - rdr.next() - return list([MalVal.MalSymbol("quasiquote"), try read_form(rdr)]) - case "~": - switch rdr.str[rdr.str.index(after: rdr.pos)] { - case "@": - rdr.next() - rdr.next() - return list([MalVal.MalSymbol("splice-unquote"), - try read_form(rdr)]) - default: - rdr.next() - return list([MalVal.MalSymbol("unquote"), - try read_form(rdr)]) - } - case "^": - rdr.next() - let meta = try read_form(rdr) - return list([MalVal.MalSymbol("with-meta"), - try read_form(rdr), - meta]) - case "@": - rdr.next() - return list([MalVal.MalSymbol("deref"), - try read_form(rdr)]) - - // list - case "(": res = list(try read_list(rdr)) - case ")": throw MalError.Reader(msg: "unexpected ')'") - - // vector - case "[": res = vector(try read_list(rdr, start: "[", end: "]")) - case "]": throw MalError.Reader(msg: "unexpected ']'") - - // hash-map - case "{": res = try hash_map(try read_list(rdr, start: "{", end: "}")) - case "}": throw MalError.Reader(msg: "unexpected '}'") - - // atom - default: res = try read_atom(rdr) - } - skip_whitespace_and_comments(rdr) - return res -} - -func read_str(_ str: String) throws -> MalVal { - return try read_form(Reader(str)) -} +let token_delim: Set = [ + ";", ",", "\"", "`", " ", "\n", "{", "}", "(", ")", "[", "]" +] + +let int_char: Set = [ + "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9" +] + +let float_char: Set = [ + ".", "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9" +] + +let whitespace: Set = [" ", "\t", "\n", ","] + +class Reader { + var str: String + var pos: String.Index + init(_ str: String) { + self.str = str + pos = str.startIndex + } + func next() { pos = str.index(after: pos) } +} + +func read_int(_ rdr: Reader) -> MalVal { + let start = rdr.pos + var cidx = rdr.pos + while cidx < rdr.str.endIndex { + if !int_char.contains(rdr.str[cidx]) { break } + cidx = rdr.str.index(after: cidx) + rdr.pos = cidx + } + let matchStr = rdr.str.substring(with: start.. MalVal { + let start = rdr.pos + var escaped = false + if rdr.str[rdr.pos] != "\"" { + throw MalError.Reader(msg: "read_string call on non-string") + } + var cidx = rdr.str.index(after: rdr.pos) + while cidx < rdr.str.endIndex { + rdr.pos = rdr.str.index(after: cidx) + if escaped { + escaped = false + cidx = rdr.pos + continue + } + if rdr.str[cidx] == "\\" { escaped = true } + if rdr.str[cidx] == "\"" { break } + cidx = rdr.pos + } + if cidx >= rdr.str.endIndex || rdr.str[rdr.str.index(before: rdr.pos)] != "\"" { + throw MalError.Reader(msg: "Expected '\"', got EOF") + } + let matchStr = rdr.str.substring(with: + rdr.str.index(after: start).. String { + let start = rdr.pos + var cidx = rdr.pos + while cidx < rdr.str.endIndex { + rdr.pos = cidx + if token_delim.contains(rdr.str[cidx]) { break } + cidx = rdr.str.index(after: cidx) + rdr.pos = cidx + } + return rdr.str.substring(with: start.. MalVal { + let tok = read_token(rdr) + switch tok { + case "nil": return MalVal.MalNil + case "true": return MalVal.MalTrue + case "false": return MalVal.MalFalse + default: return MalVal.MalSymbol(tok) + } +} + +func read_atom(_ rdr: Reader) throws -> MalVal { + if rdr.str.characters.count == 0 { + throw MalError.Reader(msg: "Empty string passed to read_atom") + } + switch rdr.str[rdr.pos] { + case "-" where rdr.str.characters.count == 1 || !int_char.contains(rdr.str[rdr.str.index(after: rdr.pos)]): + return try read_symbol(rdr) + case let c where int_char.contains(c): + return read_int(rdr) + case "\"": + return try read_string(rdr) + case ":": + rdr.next() + return MalVal.MalString("\u{029e}\(read_token(rdr))") + default: + return try read_symbol(rdr) + } +} + +func read_list(_ rdr: Reader, start: Character = "(", end: Character = ")") throws -> Array { + if rdr.str[rdr.pos] != start { + throw MalError.Reader(msg: "expected '\(start)'") + } + rdr.next() + skip_whitespace_and_comments(rdr) + var lst: [MalVal] = [] + while rdr.pos < rdr.str.endIndex { + if (rdr.str[rdr.pos] == end) { break } + lst.append(try read_form(rdr)) + } + if rdr.pos >= rdr.str.endIndex { + throw MalError.Reader(msg: "Expected '\(end)', got EOF") + } + rdr.next() + return lst +} + +func read_form(_ rdr: Reader) throws -> MalVal { + if rdr.str.characters.count == 0 { + throw MalError.Reader(msg: "Empty string passed to read_form") + } + //print("read_form: \(rdr.pos): \(rdr.str[rdr.pos])") + skip_whitespace_and_comments(rdr) + var res: MalVal + switch rdr.str[rdr.pos] { + // reader macros/transforms + case "'": + rdr.next() + return list([MalVal.MalSymbol("quote"), try read_form(rdr)]) + case "`": + rdr.next() + return list([MalVal.MalSymbol("quasiquote"), try read_form(rdr)]) + case "~": + switch rdr.str[rdr.str.index(after: rdr.pos)] { + case "@": + rdr.next() + rdr.next() + return list([MalVal.MalSymbol("splice-unquote"), + try read_form(rdr)]) + default: + rdr.next() + return list([MalVal.MalSymbol("unquote"), + try read_form(rdr)]) + } + case "^": + rdr.next() + let meta = try read_form(rdr) + return list([MalVal.MalSymbol("with-meta"), + try read_form(rdr), + meta]) + case "@": + rdr.next() + return list([MalVal.MalSymbol("deref"), + try read_form(rdr)]) + + // list + case "(": res = list(try read_list(rdr)) + case ")": throw MalError.Reader(msg: "unexpected ')'") + + // vector + case "[": res = vector(try read_list(rdr, start: "[", end: "]")) + case "]": throw MalError.Reader(msg: "unexpected ']'") + + // hash-map + case "{": res = try hash_map(try read_list(rdr, start: "{", end: "}")) + case "}": throw MalError.Reader(msg: "unexpected '}'") + + // atom + default: res = try read_atom(rdr) + } + skip_whitespace_and_comments(rdr) + return res +} + +func read_str(_ str: String) throws -> MalVal { + return try read_form(Reader(str)) +} diff --git a/impls/swift3/Sources/step0_repl/main.swift b/impls/swift3/Sources/step0_repl/main.swift index f850fa793a..bf2dfcbc16 100644 --- a/impls/swift3/Sources/step0_repl/main.swift +++ b/impls/swift3/Sources/step0_repl/main.swift @@ -1,10 +1,10 @@ -import Foundation - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - print("\(line!)") -} +import Foundation + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + print("\(line!)") +} diff --git a/impls/swift3/Sources/step1_read_print/main.swift b/impls/swift3/Sources/step1_read_print/main.swift index 07d79d1327..c21c5146e5 100644 --- a/impls/swift3/Sources/step1_read_print/main.swift +++ b/impls/swift3/Sources/step1_read_print/main.swift @@ -1,35 +1,35 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval -func EVAL(_ ast: MalVal, _ env: String) throws -> MalVal { - return ast -} - -// print -func PRINT(_ exp: MalVal) -> String { - return pr_str(exp, true) -} - - -// repl -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), "")) -} - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval +func EVAL(_ ast: MalVal, _ env: String) throws -> MalVal { + return ast +} + +// print +func PRINT(_ exp: MalVal) -> String { + return pr_str(exp, true) +} + + +// repl +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), "")) +} + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } +} diff --git a/impls/swift3/Sources/step2_eval/main.swift b/impls/swift3/Sources/step2_eval/main.swift index 7a3e49ad04..b05643455e 100644 --- a/impls/swift3/Sources/step2_eval/main.swift +++ b/impls/swift3/Sources/step2_eval/main.swift @@ -1,88 +1,88 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval -func eval_ast(_ ast: MalVal, _ env: Dictionary) throws -> MalVal { - switch ast { - case MalVal.MalSymbol(let sym): - if env[sym] == nil { - throw MalError.General(msg: "'\(sym)' not found") - } - return env[sym]! - case MalVal.MalList(let lst, _): - return list(try lst.map { try EVAL($0, env) }) - case MalVal.MalVector(let lst, _): - return vector(try lst.map { try EVAL($0, env) }) - case MalVal.MalHashMap(let dict, _): - var new_dict = Dictionary() - for (k,v) in dict { new_dict[k] = try EVAL(v, env) } - return hash_map(new_dict) - default: - return ast - } -} - -func EVAL(_ ast: MalVal, _ env: Dictionary) throws -> MalVal { - switch ast { - case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } - default: return try eval_ast(ast, env) - } - - switch try eval_ast(ast, env) { - case MalVal.MalList(let elst, _): - switch elst[0] { - case MalVal.MalFunc(let fn,_,_,_,_,_): - let args = Array(elst[1.. String { - return pr_str(exp, true) -} - - -// repl -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), repl_env)) -} - -func IntOp(_ op: (Int, Int) -> Int, _ a: MalVal, _ b: MalVal) throws -> MalVal { - switch (a, b) { - case (MalVal.MalInt(let i1), MalVal.MalInt(let i2)): - return MalVal.MalInt(op(i1, i2)) - default: - throw MalError.General(msg: "Invalid IntOp call") - } -} - -var repl_env: Dictionary = [ - "+": malfunc({ try IntOp({ $0 + $1}, $0[0], $0[1]) }), - "-": malfunc({ try IntOp({ $0 - $1}, $0[0], $0[1]) }), - "*": malfunc({ try IntOp({ $0 * $1}, $0[0], $0[1]) }), - "/": malfunc({ try IntOp({ $0 / $1}, $0[0], $0[1]) }), -] - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } catch (MalError.General(let msg)) { - print("Error: \(msg)") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval +func eval_ast(_ ast: MalVal, _ env: Dictionary) throws -> MalVal { + switch ast { + case MalVal.MalSymbol(let sym): + if env[sym] == nil { + throw MalError.General(msg: "'\(sym)' not found") + } + return env[sym]! + case MalVal.MalList(let lst, _): + return list(try lst.map { try EVAL($0, env) }) + case MalVal.MalVector(let lst, _): + return vector(try lst.map { try EVAL($0, env) }) + case MalVal.MalHashMap(let dict, _): + var new_dict = Dictionary() + for (k,v) in dict { new_dict[k] = try EVAL(v, env) } + return hash_map(new_dict) + default: + return ast + } +} + +func EVAL(_ ast: MalVal, _ env: Dictionary) throws -> MalVal { + switch ast { + case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } + default: return try eval_ast(ast, env) + } + + switch try eval_ast(ast, env) { + case MalVal.MalList(let elst, _): + switch elst[0] { + case MalVal.MalFunc(let fn,_,_,_,_,_): + let args = Array(elst[1.. String { + return pr_str(exp, true) +} + + +// repl +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), repl_env)) +} + +func IntOp(_ op: (Int, Int) -> Int, _ a: MalVal, _ b: MalVal) throws -> MalVal { + switch (a, b) { + case (MalVal.MalInt(let i1), MalVal.MalInt(let i2)): + return MalVal.MalInt(op(i1, i2)) + default: + throw MalError.General(msg: "Invalid IntOp call") + } +} + +var repl_env: Dictionary = [ + "+": malfunc({ try IntOp({ $0 + $1}, $0[0], $0[1]) }), + "-": malfunc({ try IntOp({ $0 - $1}, $0[0], $0[1]) }), + "*": malfunc({ try IntOp({ $0 * $1}, $0[0], $0[1]) }), + "/": malfunc({ try IntOp({ $0 / $1}, $0[0], $0[1]) }), +] + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } catch (MalError.General(let msg)) { + print("Error: \(msg)") + } +} diff --git a/impls/swift3/Sources/step3_env/main.swift b/impls/swift3/Sources/step3_env/main.swift index 8f37521770..df025c0a8b 100644 --- a/impls/swift3/Sources/step3_env/main.swift +++ b/impls/swift3/Sources/step3_env/main.swift @@ -1,115 +1,115 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval -func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalSymbol: - return try env.get(ast) - case MalVal.MalList(let lst, _): - return list(try lst.map { try EVAL($0, env) }) - case MalVal.MalVector(let lst, _): - return vector(try lst.map { try EVAL($0, env) }) - case MalVal.MalHashMap(let dict, _): - var new_dict = Dictionary() - for (k,v) in dict { new_dict[k] = try EVAL(v, env) } - return hash_map(new_dict) - default: - return ast - } -} - -func EVAL(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } - default: return try eval_ast(ast, env) - } - - switch ast { - case MalVal.MalList(let lst, _): - switch lst[0] { - case MalVal.MalSymbol("def!"): - return try env.set(lst[1], try EVAL(lst[2], env)) - case MalVal.MalSymbol("let*"): - let let_env = try Env(env) - var binds = Array() - switch lst[1] { - case MalVal.MalList(let l, _): binds = l - case MalVal.MalVector(let l, _): binds = l - default: - throw MalError.General(msg: "Invalid let* bindings") - } - var idx = binds.startIndex - while idx < binds.endIndex { - let v = try EVAL(binds[binds.index(after: idx)], let_env) - try let_env.set(binds[idx], v) - idx = binds.index(idx, offsetBy: 2) - } - return try EVAL(lst[2], let_env) - default: - switch try eval_ast(ast, env) { - case MalVal.MalList(let elst, _): - switch elst[0] { - case MalVal.MalFunc(let fn,_,_,_,_,_): - let args = Array(elst[1.. String { - return pr_str(exp, true) -} - - -// repl -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), repl_env)) -} - -func IntOp(_ op: (Int, Int) -> Int, _ a: MalVal, _ b: MalVal) throws -> MalVal { - switch (a, b) { - case (MalVal.MalInt(let i1), MalVal.MalInt(let i2)): - return MalVal.MalInt(op(i1, i2)) - default: - throw MalError.General(msg: "Invalid IntOp call") - } -} - -var repl_env: Env = try Env() -try repl_env.set(MalVal.MalSymbol("+"), - malfunc({ try IntOp({ $0 + $1}, $0[0], $0[1]) })) -try repl_env.set(MalVal.MalSymbol("-"), - malfunc({ try IntOp({ $0 - $1}, $0[0], $0[1]) })) -try repl_env.set(MalVal.MalSymbol("*"), - malfunc({ try IntOp({ $0 * $1}, $0[0], $0[1]) })) -try repl_env.set(MalVal.MalSymbol("/"), - malfunc({ try IntOp({ $0 / $1}, $0[0], $0[1]) })) - - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } catch (MalError.General(let msg)) { - print("Error: \(msg)") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval +func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalSymbol: + return try env.get(ast) + case MalVal.MalList(let lst, _): + return list(try lst.map { try EVAL($0, env) }) + case MalVal.MalVector(let lst, _): + return vector(try lst.map { try EVAL($0, env) }) + case MalVal.MalHashMap(let dict, _): + var new_dict = Dictionary() + for (k,v) in dict { new_dict[k] = try EVAL(v, env) } + return hash_map(new_dict) + default: + return ast + } +} + +func EVAL(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } + default: return try eval_ast(ast, env) + } + + switch ast { + case MalVal.MalList(let lst, _): + switch lst[0] { + case MalVal.MalSymbol("def!"): + return try env.set(lst[1], try EVAL(lst[2], env)) + case MalVal.MalSymbol("let*"): + let let_env = try Env(env) + var binds = Array() + switch lst[1] { + case MalVal.MalList(let l, _): binds = l + case MalVal.MalVector(let l, _): binds = l + default: + throw MalError.General(msg: "Invalid let* bindings") + } + var idx = binds.startIndex + while idx < binds.endIndex { + let v = try EVAL(binds[binds.index(after: idx)], let_env) + try let_env.set(binds[idx], v) + idx = binds.index(idx, offsetBy: 2) + } + return try EVAL(lst[2], let_env) + default: + switch try eval_ast(ast, env) { + case MalVal.MalList(let elst, _): + switch elst[0] { + case MalVal.MalFunc(let fn,_,_,_,_,_): + let args = Array(elst[1.. String { + return pr_str(exp, true) +} + + +// repl +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), repl_env)) +} + +func IntOp(_ op: (Int, Int) -> Int, _ a: MalVal, _ b: MalVal) throws -> MalVal { + switch (a, b) { + case (MalVal.MalInt(let i1), MalVal.MalInt(let i2)): + return MalVal.MalInt(op(i1, i2)) + default: + throw MalError.General(msg: "Invalid IntOp call") + } +} + +var repl_env: Env = try Env() +try repl_env.set(MalVal.MalSymbol("+"), + malfunc({ try IntOp({ $0 + $1}, $0[0], $0[1]) })) +try repl_env.set(MalVal.MalSymbol("-"), + malfunc({ try IntOp({ $0 - $1}, $0[0], $0[1]) })) +try repl_env.set(MalVal.MalSymbol("*"), + malfunc({ try IntOp({ $0 * $1}, $0[0], $0[1]) })) +try repl_env.set(MalVal.MalSymbol("/"), + malfunc({ try IntOp({ $0 / $1}, $0[0], $0[1]) })) + + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } catch (MalError.General(let msg)) { + print("Error: \(msg)") + } +} diff --git a/impls/swift3/Sources/step4_if_fn_do/main.swift b/impls/swift3/Sources/step4_if_fn_do/main.swift index 17b4c90b14..66d573d9d5 100644 --- a/impls/swift3/Sources/step4_if_fn_do/main.swift +++ b/impls/swift3/Sources/step4_if_fn_do/main.swift @@ -1,133 +1,133 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval -func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalSymbol: - return try env.get(ast) - case MalVal.MalList(let lst, _): - return list(try lst.map { try EVAL($0, env) }) - case MalVal.MalVector(let lst, _): - return vector(try lst.map { try EVAL($0, env) }) - case MalVal.MalHashMap(let dict, _): - var new_dict = Dictionary() - for (k,v) in dict { new_dict[k] = try EVAL(v, env) } - return hash_map(new_dict) - default: - return ast - } -} - -func EVAL(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } - default: return try eval_ast(ast, env) - } - - switch ast { - case MalVal.MalList(let lst, _): - switch lst[0] { - case MalVal.MalSymbol("def!"): - return try env.set(lst[1], try EVAL(lst[2], env)) - case MalVal.MalSymbol("let*"): - let let_env = try Env(env) - var binds = Array() - switch lst[1] { - case MalVal.MalList(let l, _): binds = l - case MalVal.MalVector(let l, _): binds = l - default: - throw MalError.General(msg: "Invalid let* bindings") - } - var idx = binds.startIndex - while idx < binds.endIndex { - let v = try EVAL(binds[binds.index(after: idx)], let_env) - try let_env.set(binds[idx], v) - idx = binds.index(idx, offsetBy: 2) - } - return try EVAL(lst[2], let_env) - case MalVal.MalSymbol("do"): - let slc = lst[lst.index(after: lst.startIndex).. 3 { - return try EVAL(lst[3], env) - } else { - return MalVal.MalNil - } - default: - return try EVAL(lst[2], env) - } - case MalVal.MalSymbol("fn*"): - return malfunc( { - return try EVAL(lst[2], Env(env, binds: lst[1], - exprs: list($0))) - }) - default: - switch try eval_ast(ast, env) { - case MalVal.MalList(let elst, _): - switch elst[0] { - case MalVal.MalFunc(let fn,_,_,_,_,_): - let args = Array(elst[1.. String { - return pr_str(exp, true) -} - - -// repl -@discardableResult -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), repl_env)) -} - -var repl_env: Env = try Env() - -// core.swift: defined using Swift -for (k, fn) in core_ns { - try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) -} - -// core.mal: defined using the language itself -try rep("(def! not (fn* (a) (if a false true)))") - - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } catch (MalError.General(let msg)) { - print("Error: \(msg)") - } catch (MalError.MalException(let obj)) { - print("Error: \(pr_str(obj, true))") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval +func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalSymbol: + return try env.get(ast) + case MalVal.MalList(let lst, _): + return list(try lst.map { try EVAL($0, env) }) + case MalVal.MalVector(let lst, _): + return vector(try lst.map { try EVAL($0, env) }) + case MalVal.MalHashMap(let dict, _): + var new_dict = Dictionary() + for (k,v) in dict { new_dict[k] = try EVAL(v, env) } + return hash_map(new_dict) + default: + return ast + } +} + +func EVAL(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } + default: return try eval_ast(ast, env) + } + + switch ast { + case MalVal.MalList(let lst, _): + switch lst[0] { + case MalVal.MalSymbol("def!"): + return try env.set(lst[1], try EVAL(lst[2], env)) + case MalVal.MalSymbol("let*"): + let let_env = try Env(env) + var binds = Array() + switch lst[1] { + case MalVal.MalList(let l, _): binds = l + case MalVal.MalVector(let l, _): binds = l + default: + throw MalError.General(msg: "Invalid let* bindings") + } + var idx = binds.startIndex + while idx < binds.endIndex { + let v = try EVAL(binds[binds.index(after: idx)], let_env) + try let_env.set(binds[idx], v) + idx = binds.index(idx, offsetBy: 2) + } + return try EVAL(lst[2], let_env) + case MalVal.MalSymbol("do"): + let slc = lst[lst.index(after: lst.startIndex).. 3 { + return try EVAL(lst[3], env) + } else { + return MalVal.MalNil + } + default: + return try EVAL(lst[2], env) + } + case MalVal.MalSymbol("fn*"): + return malfunc( { + return try EVAL(lst[2], Env(env, binds: lst[1], + exprs: list($0))) + }) + default: + switch try eval_ast(ast, env) { + case MalVal.MalList(let elst, _): + switch elst[0] { + case MalVal.MalFunc(let fn,_,_,_,_,_): + let args = Array(elst[1.. String { + return pr_str(exp, true) +} + + +// repl +@discardableResult +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), repl_env)) +} + +var repl_env: Env = try Env() + +// core.swift: defined using Swift +for (k, fn) in core_ns { + try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) +} + +// core.mal: defined using the language itself +try rep("(def! not (fn* (a) (if a false true)))") + + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } catch (MalError.General(let msg)) { + print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") + } +} diff --git a/impls/swift3/Sources/step5_tco/main.swift b/impls/swift3/Sources/step5_tco/main.swift index 337d76f1ed..583d6faa01 100644 --- a/impls/swift3/Sources/step5_tco/main.swift +++ b/impls/swift3/Sources/step5_tco/main.swift @@ -1,138 +1,138 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval -func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalSymbol: - return try env.get(ast) - case MalVal.MalList(let lst, _): - return list(try lst.map { try EVAL($0, env) }) - case MalVal.MalVector(let lst, _): - return vector(try lst.map { try EVAL($0, env) }) - case MalVal.MalHashMap(let dict, _): - var new_dict = Dictionary() - for (k,v) in dict { new_dict[k] = try EVAL(v, env) } - return hash_map(new_dict) - default: - return ast - } -} - -func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { - var ast = orig_ast, env = orig_env - while true { - switch ast { - case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } - default: return try eval_ast(ast, env) - } - - switch ast { - case MalVal.MalList(let lst, _): - switch lst[0] { - case MalVal.MalSymbol("def!"): - return try env.set(lst[1], try EVAL(lst[2], env)) - case MalVal.MalSymbol("let*"): - let let_env = try Env(env) - var binds = Array() - switch lst[1] { - case MalVal.MalList(let l, _): binds = l - case MalVal.MalVector(let l, _): binds = l - default: - throw MalError.General(msg: "Invalid let* bindings") - } - var idx = binds.startIndex - while idx < binds.endIndex { - let v = try EVAL(binds[binds.index(after: idx)], let_env) - try let_env.set(binds[idx], v) - idx = binds.index(idx, offsetBy: 2) - } - env = let_env - ast = lst[2] // TCO - case MalVal.MalSymbol("do"): - let slc = lst[1.. 3 { - ast = lst[3] // TCO - } else { - return MalVal.MalNil - } - default: - ast = lst[2] // TCO - } - case MalVal.MalSymbol("fn*"): - return malfunc( { - return try EVAL(lst[2], Env(env, binds: lst[1], - exprs: list($0))) - }, ast:[lst[2]], env:env, params:[lst[1]]) - default: - switch try eval_ast(ast, env) { - case MalVal.MalList(let elst, _): - switch elst[0] { - case MalVal.MalFunc(let fn, nil, _, _, _, _): - let args = Array(elst[1.. String { - return pr_str(exp, true) -} - - -// repl -@discardableResult -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), repl_env)) -} - -var repl_env: Env = try Env() - -// core.swift: defined using Swift -for (k, fn) in core_ns { - try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) -} - -// core.mal: defined using the language itself -try rep("(def! not (fn* (a) (if a false true)))") - - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } catch (MalError.General(let msg)) { - print("Error: \(msg)") - } catch (MalError.MalException(let obj)) { - print("Error: \(pr_str(obj, true))") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval +func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalSymbol: + return try env.get(ast) + case MalVal.MalList(let lst, _): + return list(try lst.map { try EVAL($0, env) }) + case MalVal.MalVector(let lst, _): + return vector(try lst.map { try EVAL($0, env) }) + case MalVal.MalHashMap(let dict, _): + var new_dict = Dictionary() + for (k,v) in dict { new_dict[k] = try EVAL(v, env) } + return hash_map(new_dict) + default: + return ast + } +} + +func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { + var ast = orig_ast, env = orig_env + while true { + switch ast { + case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } + default: return try eval_ast(ast, env) + } + + switch ast { + case MalVal.MalList(let lst, _): + switch lst[0] { + case MalVal.MalSymbol("def!"): + return try env.set(lst[1], try EVAL(lst[2], env)) + case MalVal.MalSymbol("let*"): + let let_env = try Env(env) + var binds = Array() + switch lst[1] { + case MalVal.MalList(let l, _): binds = l + case MalVal.MalVector(let l, _): binds = l + default: + throw MalError.General(msg: "Invalid let* bindings") + } + var idx = binds.startIndex + while idx < binds.endIndex { + let v = try EVAL(binds[binds.index(after: idx)], let_env) + try let_env.set(binds[idx], v) + idx = binds.index(idx, offsetBy: 2) + } + env = let_env + ast = lst[2] // TCO + case MalVal.MalSymbol("do"): + let slc = lst[1.. 3 { + ast = lst[3] // TCO + } else { + return MalVal.MalNil + } + default: + ast = lst[2] // TCO + } + case MalVal.MalSymbol("fn*"): + return malfunc( { + return try EVAL(lst[2], Env(env, binds: lst[1], + exprs: list($0))) + }, ast:[lst[2]], env:env, params:[lst[1]]) + default: + switch try eval_ast(ast, env) { + case MalVal.MalList(let elst, _): + switch elst[0] { + case MalVal.MalFunc(let fn, nil, _, _, _, _): + let args = Array(elst[1.. String { + return pr_str(exp, true) +} + + +// repl +@discardableResult +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), repl_env)) +} + +var repl_env: Env = try Env() + +// core.swift: defined using Swift +for (k, fn) in core_ns { + try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) +} + +// core.mal: defined using the language itself +try rep("(def! not (fn* (a) (if a false true)))") + + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } catch (MalError.General(let msg)) { + print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") + } +} diff --git a/impls/swift3/Sources/step6_file/main.swift b/impls/swift3/Sources/step6_file/main.swift index 876e900e60..21115c0783 100644 --- a/impls/swift3/Sources/step6_file/main.swift +++ b/impls/swift3/Sources/step6_file/main.swift @@ -1,153 +1,153 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval -func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalSymbol: - return try env.get(ast) - case MalVal.MalList(let lst, _): - return list(try lst.map { try EVAL($0, env) }) - case MalVal.MalVector(let lst, _): - return vector(try lst.map { try EVAL($0, env) }) - case MalVal.MalHashMap(let dict, _): - var new_dict = Dictionary() - for (k,v) in dict { new_dict[k] = try EVAL(v, env) } - return hash_map(new_dict) - default: - return ast - } -} - -func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { - var ast = orig_ast, env = orig_env - while true { - switch ast { - case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } - default: return try eval_ast(ast, env) - } - - switch ast { - case MalVal.MalList(let lst, _): - switch lst[0] { - case MalVal.MalSymbol("def!"): - return try env.set(lst[1], try EVAL(lst[2], env)) - case MalVal.MalSymbol("let*"): - let let_env = try Env(env) - var binds = Array() - switch lst[1] { - case MalVal.MalList(let l, _): binds = l - case MalVal.MalVector(let l, _): binds = l - default: - throw MalError.General(msg: "Invalid let* bindings") - } - var idx = binds.startIndex - while idx < binds.endIndex { - let v = try EVAL(binds[binds.index(after: idx)], let_env) - try let_env.set(binds[idx], v) - idx = binds.index(idx, offsetBy: 2) - } - env = let_env - ast = lst[2] // TCO - case MalVal.MalSymbol("do"): - let slc = lst[1.. 3 { - ast = lst[3] // TCO - } else { - return MalVal.MalNil - } - default: - ast = lst[2] // TCO - } - case MalVal.MalSymbol("fn*"): - return malfunc( { - return try EVAL(lst[2], Env(env, binds: lst[1], - exprs: list($0))) - }, ast:[lst[2]], env:env, params:[lst[1]]) - default: - switch try eval_ast(ast, env) { - case MalVal.MalList(let elst, _): - switch elst[0] { - case MalVal.MalFunc(let fn, nil, _, _, _, _): - let args = Array(elst[1.. String { - return pr_str(exp, true) -} - - -// repl -@discardableResult -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), repl_env)) -} - -var repl_env: Env = try Env() - -// core.swift: defined using Swift -for (k, fn) in core_ns { - try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) -} -try repl_env.set(MalVal.MalSymbol("eval"), - malfunc({ try EVAL($0[0], repl_env) })) -let pargs = CommandLine.arguments.map { MalVal.MalString($0) } -// TODO: weird way to get empty list, fix this -var args = pargs[pargs.startIndex.. 1 { - try rep("(load-file \"" + CommandLine.arguments[1] + "\")") - exit(0) -} - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } catch (MalError.General(let msg)) { - print("Error: \(msg)") - } catch (MalError.MalException(let obj)) { - print("Error: \(pr_str(obj, true))") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval +func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalSymbol: + return try env.get(ast) + case MalVal.MalList(let lst, _): + return list(try lst.map { try EVAL($0, env) }) + case MalVal.MalVector(let lst, _): + return vector(try lst.map { try EVAL($0, env) }) + case MalVal.MalHashMap(let dict, _): + var new_dict = Dictionary() + for (k,v) in dict { new_dict[k] = try EVAL(v, env) } + return hash_map(new_dict) + default: + return ast + } +} + +func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { + var ast = orig_ast, env = orig_env + while true { + switch ast { + case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } + default: return try eval_ast(ast, env) + } + + switch ast { + case MalVal.MalList(let lst, _): + switch lst[0] { + case MalVal.MalSymbol("def!"): + return try env.set(lst[1], try EVAL(lst[2], env)) + case MalVal.MalSymbol("let*"): + let let_env = try Env(env) + var binds = Array() + switch lst[1] { + case MalVal.MalList(let l, _): binds = l + case MalVal.MalVector(let l, _): binds = l + default: + throw MalError.General(msg: "Invalid let* bindings") + } + var idx = binds.startIndex + while idx < binds.endIndex { + let v = try EVAL(binds[binds.index(after: idx)], let_env) + try let_env.set(binds[idx], v) + idx = binds.index(idx, offsetBy: 2) + } + env = let_env + ast = lst[2] // TCO + case MalVal.MalSymbol("do"): + let slc = lst[1.. 3 { + ast = lst[3] // TCO + } else { + return MalVal.MalNil + } + default: + ast = lst[2] // TCO + } + case MalVal.MalSymbol("fn*"): + return malfunc( { + return try EVAL(lst[2], Env(env, binds: lst[1], + exprs: list($0))) + }, ast:[lst[2]], env:env, params:[lst[1]]) + default: + switch try eval_ast(ast, env) { + case MalVal.MalList(let elst, _): + switch elst[0] { + case MalVal.MalFunc(let fn, nil, _, _, _, _): + let args = Array(elst[1.. String { + return pr_str(exp, true) +} + + +// repl +@discardableResult +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), repl_env)) +} + +var repl_env: Env = try Env() + +// core.swift: defined using Swift +for (k, fn) in core_ns { + try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) +} +try repl_env.set(MalVal.MalSymbol("eval"), + malfunc({ try EVAL($0[0], repl_env) })) +let pargs = CommandLine.arguments.map { MalVal.MalString($0) } +// TODO: weird way to get empty list, fix this +var args = pargs[pargs.startIndex.. 1 { + try rep("(load-file \"" + CommandLine.arguments[1] + "\")") + exit(0) +} + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } catch (MalError.General(let msg)) { + print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") + } +} diff --git a/impls/swift3/Sources/step7_quote/main.swift b/impls/swift3/Sources/step7_quote/main.swift index e878750abc..8167895e58 100644 --- a/impls/swift3/Sources/step7_quote/main.swift +++ b/impls/swift3/Sources/step7_quote/main.swift @@ -1,204 +1,204 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval - -func starts_with(_ ast: MalVal, _ sym: String) -> MalVal? { - switch ast { - case MalVal.MalList(let lst, _) where 1 < lst.count: - switch lst[0] { - case MalVal.MalSymbol(sym): - return lst[1] - default: - return nil - } - default: - return nil - } -} - -func qqIter(_ lst: [MalVal]) -> MalVal { - var result = list([]) - for elt in lst.reversed() { - if let elt1 = starts_with(elt, "splice-unquote") { - result = list([MalVal.MalSymbol("concat"), elt1, result]) - } else { - result = list([MalVal.MalSymbol("cons"), quasiquote(elt), result]) - } - } - return result -} - -func quasiquote(_ ast: MalVal) -> MalVal { - if let a1 = starts_with(ast, "unquote") { - return a1 - } - switch ast { - case MalVal.MalList(let lst, _): - return qqIter(lst) - case MalVal.MalVector(let lst, _): - return list([MalVal.MalSymbol("vec"), qqIter(lst)]) - case MalVal.MalSymbol: - return list([MalVal.MalSymbol("quote"), ast]) - case MalVal.MalHashMap: - return list([MalVal.MalSymbol("quote"), ast]) - default: - return ast - } -} - -func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalSymbol: - return try env.get(ast) - case MalVal.MalList(let lst, _): - return list(try lst.map { try EVAL($0, env) }) - case MalVal.MalVector(let lst, _): - return vector(try lst.map { try EVAL($0, env) }) - case MalVal.MalHashMap(let dict, _): - var new_dict = Dictionary() - for (k,v) in dict { new_dict[k] = try EVAL(v, env) } - return hash_map(new_dict) - default: - return ast - } -} - -func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { - var ast = orig_ast, env = orig_env - while true { - switch ast { - case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } - default: return try eval_ast(ast, env) - } - - switch ast { - case MalVal.MalList(let lst, _): - switch lst[0] { - case MalVal.MalSymbol("def!"): - return try env.set(lst[1], try EVAL(lst[2], env)) - case MalVal.MalSymbol("let*"): - let let_env = try Env(env) - var binds = Array() - switch lst[1] { - case MalVal.MalList(let l, _): binds = l - case MalVal.MalVector(let l, _): binds = l - default: - throw MalError.General(msg: "Invalid let* bindings") - } - var idx = binds.startIndex - while idx < binds.endIndex { - let v = try EVAL(binds[binds.index(after: idx)], let_env) - try let_env.set(binds[idx], v) - idx = binds.index(idx, offsetBy: 2) - } - env = let_env - ast = lst[2] // TCO - case MalVal.MalSymbol("quote"): - return lst[1] - case MalVal.MalSymbol("quasiquoteexpand"): - return quasiquote(lst[1]) - case MalVal.MalSymbol("quasiquote"): - ast = quasiquote(lst[1]) // TCO - case MalVal.MalSymbol("do"): - let slc = lst[1.. 3 { - ast = lst[3] // TCO - } else { - return MalVal.MalNil - } - default: - ast = lst[2] // TCO - } - case MalVal.MalSymbol("fn*"): - return malfunc( { - return try EVAL(lst[2], Env(env, binds: lst[1], - exprs: list($0))) - }, ast:[lst[2]], env:env, params:[lst[1]]) - default: - switch try eval_ast(ast, env) { - case MalVal.MalList(let elst, _): - switch elst[0] { - case MalVal.MalFunc(let fn, nil, _, _, _, _): - let args = Array(elst[1.. String { - return pr_str(exp, true) -} - - -// repl -@discardableResult -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), repl_env)) -} - -var repl_env: Env = try Env() - -// core.swift: defined using Swift -for (k, fn) in core_ns { - try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) -} -try repl_env.set(MalVal.MalSymbol("eval"), - malfunc({ try EVAL($0[0], repl_env) })) -let pargs = CommandLine.arguments.map { MalVal.MalString($0) } -// TODO: weird way to get empty list, fix this -var args = pargs[pargs.startIndex.. 1 { - try rep("(load-file \"" + CommandLine.arguments[1] + "\")") - exit(0) -} - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } catch (MalError.General(let msg)) { - print("Error: \(msg)") - } catch (MalError.MalException(let obj)) { - print("Error: \(pr_str(obj, true))") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval + +func starts_with(_ ast: MalVal, _ sym: String) -> MalVal? { + switch ast { + case MalVal.MalList(let lst, _) where 1 < lst.count: + switch lst[0] { + case MalVal.MalSymbol(sym): + return lst[1] + default: + return nil + } + default: + return nil + } +} + +func qqIter(_ lst: [MalVal]) -> MalVal { + var result = list([]) + for elt in lst.reversed() { + if let elt1 = starts_with(elt, "splice-unquote") { + result = list([MalVal.MalSymbol("concat"), elt1, result]) + } else { + result = list([MalVal.MalSymbol("cons"), quasiquote(elt), result]) + } + } + return result +} + +func quasiquote(_ ast: MalVal) -> MalVal { + if let a1 = starts_with(ast, "unquote") { + return a1 + } + switch ast { + case MalVal.MalList(let lst, _): + return qqIter(lst) + case MalVal.MalVector(let lst, _): + return list([MalVal.MalSymbol("vec"), qqIter(lst)]) + case MalVal.MalSymbol: + return list([MalVal.MalSymbol("quote"), ast]) + case MalVal.MalHashMap: + return list([MalVal.MalSymbol("quote"), ast]) + default: + return ast + } +} + +func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalSymbol: + return try env.get(ast) + case MalVal.MalList(let lst, _): + return list(try lst.map { try EVAL($0, env) }) + case MalVal.MalVector(let lst, _): + return vector(try lst.map { try EVAL($0, env) }) + case MalVal.MalHashMap(let dict, _): + var new_dict = Dictionary() + for (k,v) in dict { new_dict[k] = try EVAL(v, env) } + return hash_map(new_dict) + default: + return ast + } +} + +func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { + var ast = orig_ast, env = orig_env + while true { + switch ast { + case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } + default: return try eval_ast(ast, env) + } + + switch ast { + case MalVal.MalList(let lst, _): + switch lst[0] { + case MalVal.MalSymbol("def!"): + return try env.set(lst[1], try EVAL(lst[2], env)) + case MalVal.MalSymbol("let*"): + let let_env = try Env(env) + var binds = Array() + switch lst[1] { + case MalVal.MalList(let l, _): binds = l + case MalVal.MalVector(let l, _): binds = l + default: + throw MalError.General(msg: "Invalid let* bindings") + } + var idx = binds.startIndex + while idx < binds.endIndex { + let v = try EVAL(binds[binds.index(after: idx)], let_env) + try let_env.set(binds[idx], v) + idx = binds.index(idx, offsetBy: 2) + } + env = let_env + ast = lst[2] // TCO + case MalVal.MalSymbol("quote"): + return lst[1] + case MalVal.MalSymbol("quasiquoteexpand"): + return quasiquote(lst[1]) + case MalVal.MalSymbol("quasiquote"): + ast = quasiquote(lst[1]) // TCO + case MalVal.MalSymbol("do"): + let slc = lst[1.. 3 { + ast = lst[3] // TCO + } else { + return MalVal.MalNil + } + default: + ast = lst[2] // TCO + } + case MalVal.MalSymbol("fn*"): + return malfunc( { + return try EVAL(lst[2], Env(env, binds: lst[1], + exprs: list($0))) + }, ast:[lst[2]], env:env, params:[lst[1]]) + default: + switch try eval_ast(ast, env) { + case MalVal.MalList(let elst, _): + switch elst[0] { + case MalVal.MalFunc(let fn, nil, _, _, _, _): + let args = Array(elst[1.. String { + return pr_str(exp, true) +} + + +// repl +@discardableResult +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), repl_env)) +} + +var repl_env: Env = try Env() + +// core.swift: defined using Swift +for (k, fn) in core_ns { + try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) +} +try repl_env.set(MalVal.MalSymbol("eval"), + malfunc({ try EVAL($0[0], repl_env) })) +let pargs = CommandLine.arguments.map { MalVal.MalString($0) } +// TODO: weird way to get empty list, fix this +var args = pargs[pargs.startIndex.. 1 { + try rep("(load-file \"" + CommandLine.arguments[1] + "\")") + exit(0) +} + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } catch (MalError.General(let msg)) { + print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") + } +} diff --git a/impls/swift3/Sources/step8_macros/main.swift b/impls/swift3/Sources/step8_macros/main.swift index 970fa2a896..ffa03737a4 100644 --- a/impls/swift3/Sources/step8_macros/main.swift +++ b/impls/swift3/Sources/step8_macros/main.swift @@ -1,255 +1,255 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval - -func starts_with(_ ast: MalVal, _ sym: String) -> MalVal? { - switch ast { - case MalVal.MalList(let lst, _) where 1 < lst.count: - switch lst[0] { - case MalVal.MalSymbol(sym): - return lst[1] - default: - return nil - } - default: - return nil - } -} - -func qqIter(_ lst: [MalVal]) -> MalVal { - var result = list([]) - for elt in lst.reversed() { - if let elt1 = starts_with(elt, "splice-unquote") { - result = list([MalVal.MalSymbol("concat"), elt1, result]) - } else { - result = list([MalVal.MalSymbol("cons"), quasiquote(elt), result]) - } - } - return result -} - -func quasiquote(_ ast: MalVal) -> MalVal { - if let a1 = starts_with(ast, "unquote") { - return a1 - } - switch ast { - case MalVal.MalList(let lst, _): - return qqIter(lst) - case MalVal.MalVector(let lst, _): - return list([MalVal.MalSymbol("vec"), qqIter(lst)]) - case MalVal.MalSymbol: - return list([MalVal.MalSymbol("quote"), ast]) - case MalVal.MalHashMap: - return list([MalVal.MalSymbol("quote"), ast]) - default: - return ast - } -} - -func is_macro(_ ast: MalVal, _ env: Env) -> Bool { - switch ast { - case MalVal.MalList(let lst, _) where lst.count > 0: - let a0 = lst[lst.startIndex] - switch a0 { - case MalVal.MalSymbol: - let e = try! env.find(a0) - if e != nil { - let mac = try! e!.get(a0) - switch mac { - case MalVal.MalFunc(_,_,_,_,let macro,_): return macro - default: return false - } - } else { - return false - } - default: return false - } - default: return false - } -} - -func macroexpand(_ orig_ast: MalVal, _ env: Env) throws -> MalVal { - var ast: MalVal = orig_ast - while is_macro(ast, env) { - switch try! env.get(try! _nth(ast, 0)) { - case MalVal.MalFunc(let mac,_,_,_,_,_): - ast = try mac(_rest(ast)) - default: throw MalError.General(msg: "impossible state in macroexpand") - } - } - return ast -} - -func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalSymbol: - return try env.get(ast) - case MalVal.MalList(let lst, _): - return list(try lst.map { try EVAL($0, env) }) - case MalVal.MalVector(let lst, _): - return vector(try lst.map { try EVAL($0, env) }) - case MalVal.MalHashMap(let dict, _): - var new_dict = Dictionary() - for (k,v) in dict { new_dict[k] = try EVAL(v, env) } - return hash_map(new_dict) - default: - return ast - } -} - -func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { - var ast = orig_ast, env = orig_env - while true { - switch ast { - case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } - default: return try eval_ast(ast, env) - } - - ast = try macroexpand(ast, env) - switch ast { - case MalVal.MalList: break - default: return try eval_ast(ast, env) - } - - switch ast { - case MalVal.MalList(let lst, _): - switch lst[0] { - case MalVal.MalSymbol("def!"): - return try env.set(lst[1], try EVAL(lst[2], env)) - case MalVal.MalSymbol("let*"): - let let_env = try Env(env) - var binds = Array() - switch lst[1] { - case MalVal.MalList(let l, _): binds = l - case MalVal.MalVector(let l, _): binds = l - default: - throw MalError.General(msg: "Invalid let* bindings") - } - var idx = binds.startIndex - while idx < binds.endIndex { - let v = try EVAL(binds[binds.index(after: idx)], let_env) - try let_env.set(binds[idx], v) - idx = binds.index(idx, offsetBy: 2) - } - env = let_env - ast = lst[2] // TCO - case MalVal.MalSymbol("quote"): - return lst[1] - case MalVal.MalSymbol("quasiquoteexpand"): - return quasiquote(lst[1]) - case MalVal.MalSymbol("quasiquote"): - ast = quasiquote(lst[1]) // TCO - case MalVal.MalSymbol("defmacro!"): - var mac = try EVAL(lst[2], env) - switch mac { - case MalVal.MalFunc(let fn, let a, let e, let p, _, let m): - mac = malfunc(fn,ast:a,env:e,params:p,macro:true,meta:m) - default: throw MalError.General(msg: "invalid defmacro! form") - } - return try env.set(lst[1], mac) - case MalVal.MalSymbol("macroexpand"): - return try macroexpand(lst[1], env) - case MalVal.MalSymbol("do"): - let slc = lst[1.. 3 { - ast = lst[3] // TCO - } else { - return MalVal.MalNil - } - default: - ast = lst[2] // TCO - } - case MalVal.MalSymbol("fn*"): - return malfunc( { - return try EVAL(lst[2], Env(env, binds: lst[1], - exprs: list($0))) - }, ast:[lst[2]], env:env, params:[lst[1]]) - default: - switch try eval_ast(ast, env) { - case MalVal.MalList(let elst, _): - switch elst[0] { - case MalVal.MalFunc(let fn, nil, _, _, _, _): - let args = Array(elst[1.. String { - return pr_str(exp, true) -} - - -// repl -@discardableResult -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), repl_env)) -} - -var repl_env: Env = try Env() - -// core.swift: defined using Swift -for (k, fn) in core_ns { - try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) -} -try repl_env.set(MalVal.MalSymbol("eval"), - malfunc({ try EVAL($0[0], repl_env) })) -let pargs = CommandLine.arguments.map { MalVal.MalString($0) } -// TODO: weird way to get empty list, fix this -var args = pargs[pargs.startIndex.. (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)))))))") - - -if CommandLine.arguments.count > 1 { - try rep("(load-file \"" + CommandLine.arguments[1] + "\")") - exit(0) -} - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } catch (MalError.General(let msg)) { - print("Error: \(msg)") - } catch (MalError.MalException(let obj)) { - print("Error: \(pr_str(obj, true))") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval + +func starts_with(_ ast: MalVal, _ sym: String) -> MalVal? { + switch ast { + case MalVal.MalList(let lst, _) where 1 < lst.count: + switch lst[0] { + case MalVal.MalSymbol(sym): + return lst[1] + default: + return nil + } + default: + return nil + } +} + +func qqIter(_ lst: [MalVal]) -> MalVal { + var result = list([]) + for elt in lst.reversed() { + if let elt1 = starts_with(elt, "splice-unquote") { + result = list([MalVal.MalSymbol("concat"), elt1, result]) + } else { + result = list([MalVal.MalSymbol("cons"), quasiquote(elt), result]) + } + } + return result +} + +func quasiquote(_ ast: MalVal) -> MalVal { + if let a1 = starts_with(ast, "unquote") { + return a1 + } + switch ast { + case MalVal.MalList(let lst, _): + return qqIter(lst) + case MalVal.MalVector(let lst, _): + return list([MalVal.MalSymbol("vec"), qqIter(lst)]) + case MalVal.MalSymbol: + return list([MalVal.MalSymbol("quote"), ast]) + case MalVal.MalHashMap: + return list([MalVal.MalSymbol("quote"), ast]) + default: + return ast + } +} + +func is_macro(_ ast: MalVal, _ env: Env) -> Bool { + switch ast { + case MalVal.MalList(let lst, _) where lst.count > 0: + let a0 = lst[lst.startIndex] + switch a0 { + case MalVal.MalSymbol: + let e = try! env.find(a0) + if e != nil { + let mac = try! e!.get(a0) + switch mac { + case MalVal.MalFunc(_,_,_,_,let macro,_): return macro + default: return false + } + } else { + return false + } + default: return false + } + default: return false + } +} + +func macroexpand(_ orig_ast: MalVal, _ env: Env) throws -> MalVal { + var ast: MalVal = orig_ast + while is_macro(ast, env) { + switch try! env.get(try! _nth(ast, 0)) { + case MalVal.MalFunc(let mac,_,_,_,_,_): + ast = try mac(_rest(ast)) + default: throw MalError.General(msg: "impossible state in macroexpand") + } + } + return ast +} + +func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalSymbol: + return try env.get(ast) + case MalVal.MalList(let lst, _): + return list(try lst.map { try EVAL($0, env) }) + case MalVal.MalVector(let lst, _): + return vector(try lst.map { try EVAL($0, env) }) + case MalVal.MalHashMap(let dict, _): + var new_dict = Dictionary() + for (k,v) in dict { new_dict[k] = try EVAL(v, env) } + return hash_map(new_dict) + default: + return ast + } +} + +func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { + var ast = orig_ast, env = orig_env + while true { + switch ast { + case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } + default: return try eval_ast(ast, env) + } + + ast = try macroexpand(ast, env) + switch ast { + case MalVal.MalList: break + default: return try eval_ast(ast, env) + } + + switch ast { + case MalVal.MalList(let lst, _): + switch lst[0] { + case MalVal.MalSymbol("def!"): + return try env.set(lst[1], try EVAL(lst[2], env)) + case MalVal.MalSymbol("let*"): + let let_env = try Env(env) + var binds = Array() + switch lst[1] { + case MalVal.MalList(let l, _): binds = l + case MalVal.MalVector(let l, _): binds = l + default: + throw MalError.General(msg: "Invalid let* bindings") + } + var idx = binds.startIndex + while idx < binds.endIndex { + let v = try EVAL(binds[binds.index(after: idx)], let_env) + try let_env.set(binds[idx], v) + idx = binds.index(idx, offsetBy: 2) + } + env = let_env + ast = lst[2] // TCO + case MalVal.MalSymbol("quote"): + return lst[1] + case MalVal.MalSymbol("quasiquoteexpand"): + return quasiquote(lst[1]) + case MalVal.MalSymbol("quasiquote"): + ast = quasiquote(lst[1]) // TCO + case MalVal.MalSymbol("defmacro!"): + var mac = try EVAL(lst[2], env) + switch mac { + case MalVal.MalFunc(let fn, let a, let e, let p, _, let m): + mac = malfunc(fn,ast:a,env:e,params:p,macro:true,meta:m) + default: throw MalError.General(msg: "invalid defmacro! form") + } + return try env.set(lst[1], mac) + case MalVal.MalSymbol("macroexpand"): + return try macroexpand(lst[1], env) + case MalVal.MalSymbol("do"): + let slc = lst[1.. 3 { + ast = lst[3] // TCO + } else { + return MalVal.MalNil + } + default: + ast = lst[2] // TCO + } + case MalVal.MalSymbol("fn*"): + return malfunc( { + return try EVAL(lst[2], Env(env, binds: lst[1], + exprs: list($0))) + }, ast:[lst[2]], env:env, params:[lst[1]]) + default: + switch try eval_ast(ast, env) { + case MalVal.MalList(let elst, _): + switch elst[0] { + case MalVal.MalFunc(let fn, nil, _, _, _, _): + let args = Array(elst[1.. String { + return pr_str(exp, true) +} + + +// repl +@discardableResult +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), repl_env)) +} + +var repl_env: Env = try Env() + +// core.swift: defined using Swift +for (k, fn) in core_ns { + try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) +} +try repl_env.set(MalVal.MalSymbol("eval"), + malfunc({ try EVAL($0[0], repl_env) })) +let pargs = CommandLine.arguments.map { MalVal.MalString($0) } +// TODO: weird way to get empty list, fix this +var args = pargs[pargs.startIndex.. (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)))))))") + + +if CommandLine.arguments.count > 1 { + try rep("(load-file \"" + CommandLine.arguments[1] + "\")") + exit(0) +} + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } catch (MalError.General(let msg)) { + print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") + } +} diff --git a/impls/swift3/Sources/step9_try/main.swift b/impls/swift3/Sources/step9_try/main.swift index 3515539103..d346153de9 100644 --- a/impls/swift3/Sources/step9_try/main.swift +++ b/impls/swift3/Sources/step9_try/main.swift @@ -1,288 +1,288 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval - -func starts_with(_ ast: MalVal, _ sym: String) -> MalVal? { - switch ast { - case MalVal.MalList(let lst, _) where 1 < lst.count: - switch lst[0] { - case MalVal.MalSymbol(sym): - return lst[1] - default: - return nil - } - default: - return nil - } -} - -func qqIter(_ lst: [MalVal]) -> MalVal { - var result = list([]) - for elt in lst.reversed() { - if let elt1 = starts_with(elt, "splice-unquote") { - result = list([MalVal.MalSymbol("concat"), elt1, result]) - } else { - result = list([MalVal.MalSymbol("cons"), quasiquote(elt), result]) - } - } - return result -} - -func quasiquote(_ ast: MalVal) -> MalVal { - if let a1 = starts_with(ast, "unquote") { - return a1 - } - switch ast { - case MalVal.MalList(let lst, _): - return qqIter(lst) - case MalVal.MalVector(let lst, _): - return list([MalVal.MalSymbol("vec"), qqIter(lst)]) - case MalVal.MalSymbol: - return list([MalVal.MalSymbol("quote"), ast]) - case MalVal.MalHashMap: - return list([MalVal.MalSymbol("quote"), ast]) - default: - return ast - } -} - -func is_macro(_ ast: MalVal, _ env: Env) -> Bool { - switch ast { - case MalVal.MalList(let lst, _) where lst.count > 0: - let a0 = lst[lst.startIndex] - switch a0 { - case MalVal.MalSymbol: - let e = try! env.find(a0) - if e != nil { - let mac = try! e!.get(a0) - switch mac { - case MalVal.MalFunc(_,_,_,_,let macro,_): return macro - default: return false - } - } else { - return false - } - default: return false - } - default: return false - } -} - -func macroexpand(_ orig_ast: MalVal, _ env: Env) throws -> MalVal { - var ast: MalVal = orig_ast - while is_macro(ast, env) { - switch try! env.get(try! _nth(ast, 0)) { - case MalVal.MalFunc(let mac,_,_,_,_,_): - ast = try mac(_rest(ast)) - default: throw MalError.General(msg: "impossible state in macroexpand") - } - } - return ast -} - -func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalSymbol: - return try env.get(ast) - case MalVal.MalList(let lst, _): - return list(try lst.map { try EVAL($0, env) }) - case MalVal.MalVector(let lst, _): - return vector(try lst.map { try EVAL($0, env) }) - case MalVal.MalHashMap(let dict, _): - var new_dict = Dictionary() - for (k,v) in dict { new_dict[k] = try EVAL(v, env) } - return hash_map(new_dict) - default: - return ast - } -} - -func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { - var ast = orig_ast, env = orig_env - while true { - switch ast { - case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } - default: return try eval_ast(ast, env) - } - - ast = try macroexpand(ast, env) - switch ast { - case MalVal.MalList: break - default: return try eval_ast(ast, env) - } - - switch ast { - case MalVal.MalList(let lst, _): - switch lst[0] { - case MalVal.MalSymbol("def!"): - return try env.set(lst[1], try EVAL(lst[2], env)) - case MalVal.MalSymbol("let*"): - let let_env = try Env(env) - var binds = Array() - switch lst[1] { - case MalVal.MalList(let l, _): binds = l - case MalVal.MalVector(let l, _): binds = l - default: - throw MalError.General(msg: "Invalid let* bindings") - } - var idx = binds.startIndex - while idx < binds.endIndex { - let v = try EVAL(binds[binds.index(after: idx)], let_env) - try let_env.set(binds[idx], v) - idx = binds.index(idx, offsetBy: 2) - } - env = let_env - ast = lst[2] // TCO - case MalVal.MalSymbol("quote"): - return lst[1] - case MalVal.MalSymbol("quasiquoteexpand"): - return quasiquote(lst[1]) - case MalVal.MalSymbol("quasiquote"): - ast = quasiquote(lst[1]) // TCO - case MalVal.MalSymbol("defmacro!"): - var mac = try EVAL(lst[2], env) - switch mac { - case MalVal.MalFunc(let fn, let a, let e, let p, _, let m): - mac = malfunc(fn,ast:a,env:e,params:p,macro:true,meta:m) - default: throw MalError.General(msg: "invalid defmacro! form") - } - return try env.set(lst[1], mac) - case MalVal.MalSymbol("macroexpand"): - return try macroexpand(lst[1], env) - case MalVal.MalSymbol("try*"): - do { - return try EVAL(_nth(ast, 1), env) - } catch (let exc) { - if lst.count > 2 { - let a2 = lst[2] - switch a2 { - case MalVal.MalList(let a2lst, _): - let a20 = a2lst[0] - switch a20 { - case MalVal.MalSymbol("catch*"): - if a2lst.count < 3 { return MalVal.MalNil } - let a21 = a2lst[1], a22 = a2lst[2] - var err: MalVal - switch exc { - case MalError.Reader(let msg): - err = MalVal.MalString(msg) - case MalError.General(let msg): - err = MalVal.MalString(msg) - case MalError.MalException(let obj): - err = obj - default: - err = MalVal.MalString(String(describing:exc)) - } - return try EVAL(a22, Env(env, binds: list([a21]), - exprs: list([err]))) - default: break - } - default: break - } - } - throw exc - } - case MalVal.MalSymbol("do"): - let slc = lst[1.. 3 { - ast = lst[3] // TCO - } else { - return MalVal.MalNil - } - default: - ast = lst[2] // TCO - } - case MalVal.MalSymbol("fn*"): - return malfunc( { - return try EVAL(lst[2], Env(env, binds: lst[1], - exprs: list($0))) - }, ast:[lst[2]], env:env, params:[lst[1]]) - default: - switch try eval_ast(ast, env) { - case MalVal.MalList(let elst, _): - switch elst[0] { - case MalVal.MalFunc(let fn, nil, _, _, _, _): - let args = Array(elst[1.. String { - return pr_str(exp, true) -} - - -// repl -@discardableResult -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), repl_env)) -} - -var repl_env: Env = try Env() - -// core.swift: defined using Swift -for (k, fn) in core_ns { - try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) -} -try repl_env.set(MalVal.MalSymbol("eval"), - malfunc({ try EVAL($0[0], repl_env) })) -let pargs = CommandLine.arguments.map { MalVal.MalString($0) } -// TODO: weird way to get empty list, fix this -var args = pargs[pargs.startIndex.. (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)))))))") - - -if CommandLine.arguments.count > 1 { - try rep("(load-file \"" + CommandLine.arguments[1] + "\")") - exit(0) -} - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } catch (MalError.General(let msg)) { - print("Error: \(msg)") - } catch (MalError.MalException(let obj)) { - print("Error: \(pr_str(obj, true))") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval + +func starts_with(_ ast: MalVal, _ sym: String) -> MalVal? { + switch ast { + case MalVal.MalList(let lst, _) where 1 < lst.count: + switch lst[0] { + case MalVal.MalSymbol(sym): + return lst[1] + default: + return nil + } + default: + return nil + } +} + +func qqIter(_ lst: [MalVal]) -> MalVal { + var result = list([]) + for elt in lst.reversed() { + if let elt1 = starts_with(elt, "splice-unquote") { + result = list([MalVal.MalSymbol("concat"), elt1, result]) + } else { + result = list([MalVal.MalSymbol("cons"), quasiquote(elt), result]) + } + } + return result +} + +func quasiquote(_ ast: MalVal) -> MalVal { + if let a1 = starts_with(ast, "unquote") { + return a1 + } + switch ast { + case MalVal.MalList(let lst, _): + return qqIter(lst) + case MalVal.MalVector(let lst, _): + return list([MalVal.MalSymbol("vec"), qqIter(lst)]) + case MalVal.MalSymbol: + return list([MalVal.MalSymbol("quote"), ast]) + case MalVal.MalHashMap: + return list([MalVal.MalSymbol("quote"), ast]) + default: + return ast + } +} + +func is_macro(_ ast: MalVal, _ env: Env) -> Bool { + switch ast { + case MalVal.MalList(let lst, _) where lst.count > 0: + let a0 = lst[lst.startIndex] + switch a0 { + case MalVal.MalSymbol: + let e = try! env.find(a0) + if e != nil { + let mac = try! e!.get(a0) + switch mac { + case MalVal.MalFunc(_,_,_,_,let macro,_): return macro + default: return false + } + } else { + return false + } + default: return false + } + default: return false + } +} + +func macroexpand(_ orig_ast: MalVal, _ env: Env) throws -> MalVal { + var ast: MalVal = orig_ast + while is_macro(ast, env) { + switch try! env.get(try! _nth(ast, 0)) { + case MalVal.MalFunc(let mac,_,_,_,_,_): + ast = try mac(_rest(ast)) + default: throw MalError.General(msg: "impossible state in macroexpand") + } + } + return ast +} + +func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalSymbol: + return try env.get(ast) + case MalVal.MalList(let lst, _): + return list(try lst.map { try EVAL($0, env) }) + case MalVal.MalVector(let lst, _): + return vector(try lst.map { try EVAL($0, env) }) + case MalVal.MalHashMap(let dict, _): + var new_dict = Dictionary() + for (k,v) in dict { new_dict[k] = try EVAL(v, env) } + return hash_map(new_dict) + default: + return ast + } +} + +func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { + var ast = orig_ast, env = orig_env + while true { + switch ast { + case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } + default: return try eval_ast(ast, env) + } + + ast = try macroexpand(ast, env) + switch ast { + case MalVal.MalList: break + default: return try eval_ast(ast, env) + } + + switch ast { + case MalVal.MalList(let lst, _): + switch lst[0] { + case MalVal.MalSymbol("def!"): + return try env.set(lst[1], try EVAL(lst[2], env)) + case MalVal.MalSymbol("let*"): + let let_env = try Env(env) + var binds = Array() + switch lst[1] { + case MalVal.MalList(let l, _): binds = l + case MalVal.MalVector(let l, _): binds = l + default: + throw MalError.General(msg: "Invalid let* bindings") + } + var idx = binds.startIndex + while idx < binds.endIndex { + let v = try EVAL(binds[binds.index(after: idx)], let_env) + try let_env.set(binds[idx], v) + idx = binds.index(idx, offsetBy: 2) + } + env = let_env + ast = lst[2] // TCO + case MalVal.MalSymbol("quote"): + return lst[1] + case MalVal.MalSymbol("quasiquoteexpand"): + return quasiquote(lst[1]) + case MalVal.MalSymbol("quasiquote"): + ast = quasiquote(lst[1]) // TCO + case MalVal.MalSymbol("defmacro!"): + var mac = try EVAL(lst[2], env) + switch mac { + case MalVal.MalFunc(let fn, let a, let e, let p, _, let m): + mac = malfunc(fn,ast:a,env:e,params:p,macro:true,meta:m) + default: throw MalError.General(msg: "invalid defmacro! form") + } + return try env.set(lst[1], mac) + case MalVal.MalSymbol("macroexpand"): + return try macroexpand(lst[1], env) + case MalVal.MalSymbol("try*"): + do { + return try EVAL(_nth(ast, 1), env) + } catch (let exc) { + if lst.count > 2 { + let a2 = lst[2] + switch a2 { + case MalVal.MalList(let a2lst, _): + let a20 = a2lst[0] + switch a20 { + case MalVal.MalSymbol("catch*"): + if a2lst.count < 3 { return MalVal.MalNil } + let a21 = a2lst[1], a22 = a2lst[2] + var err: MalVal + switch exc { + case MalError.Reader(let msg): + err = MalVal.MalString(msg) + case MalError.General(let msg): + err = MalVal.MalString(msg) + case MalError.MalException(let obj): + err = obj + default: + err = MalVal.MalString(String(describing:exc)) + } + return try EVAL(a22, Env(env, binds: list([a21]), + exprs: list([err]))) + default: break + } + default: break + } + } + throw exc + } + case MalVal.MalSymbol("do"): + let slc = lst[1.. 3 { + ast = lst[3] // TCO + } else { + return MalVal.MalNil + } + default: + ast = lst[2] // TCO + } + case MalVal.MalSymbol("fn*"): + return malfunc( { + return try EVAL(lst[2], Env(env, binds: lst[1], + exprs: list($0))) + }, ast:[lst[2]], env:env, params:[lst[1]]) + default: + switch try eval_ast(ast, env) { + case MalVal.MalList(let elst, _): + switch elst[0] { + case MalVal.MalFunc(let fn, nil, _, _, _, _): + let args = Array(elst[1.. String { + return pr_str(exp, true) +} + + +// repl +@discardableResult +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), repl_env)) +} + +var repl_env: Env = try Env() + +// core.swift: defined using Swift +for (k, fn) in core_ns { + try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) +} +try repl_env.set(MalVal.MalSymbol("eval"), + malfunc({ try EVAL($0[0], repl_env) })) +let pargs = CommandLine.arguments.map { MalVal.MalString($0) } +// TODO: weird way to get empty list, fix this +var args = pargs[pargs.startIndex.. (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)))))))") + + +if CommandLine.arguments.count > 1 { + try rep("(load-file \"" + CommandLine.arguments[1] + "\")") + exit(0) +} + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } catch (MalError.General(let msg)) { + print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") + } +} diff --git a/impls/swift3/Sources/stepA_mal/main.swift b/impls/swift3/Sources/stepA_mal/main.swift index d743338e07..5c7ac4dbbe 100644 --- a/impls/swift3/Sources/stepA_mal/main.swift +++ b/impls/swift3/Sources/stepA_mal/main.swift @@ -1,289 +1,289 @@ -import Foundation - -// read -func READ(_ str: String) throws -> MalVal { - return try read_str(str) -} - -// eval - -func starts_with(_ ast: MalVal, _ sym: String) -> MalVal? { - switch ast { - case MalVal.MalList(let lst, _) where 1 < lst.count: - switch lst[0] { - case MalVal.MalSymbol(sym): - return lst[1] - default: - return nil - } - default: - return nil - } -} - -func qqIter(_ lst: [MalVal]) -> MalVal { - var result = list([]) - for elt in lst.reversed() { - if let elt1 = starts_with(elt, "splice-unquote") { - result = list([MalVal.MalSymbol("concat"), elt1, result]) - } else { - result = list([MalVal.MalSymbol("cons"), quasiquote(elt), result]) - } - } - return result -} - -func quasiquote(_ ast: MalVal) -> MalVal { - if let a1 = starts_with(ast, "unquote") { - return a1 - } - switch ast { - case MalVal.MalList(let lst, _): - return qqIter(lst) - case MalVal.MalVector(let lst, _): - return list([MalVal.MalSymbol("vec"), qqIter(lst)]) - case MalVal.MalSymbol: - return list([MalVal.MalSymbol("quote"), ast]) - case MalVal.MalHashMap: - return list([MalVal.MalSymbol("quote"), ast]) - default: - return ast - } -} - -func is_macro(_ ast: MalVal, _ env: Env) -> Bool { - switch ast { - case MalVal.MalList(let lst, _) where lst.count > 0: - let a0 = lst[lst.startIndex] - switch a0 { - case MalVal.MalSymbol: - let e = try! env.find(a0) - if e != nil { - let mac = try! e!.get(a0) - switch mac { - case MalVal.MalFunc(_,_,_,_,let macro,_): return macro - default: return false - } - } else { - return false - } - default: return false - } - default: return false - } -} - -func macroexpand(_ orig_ast: MalVal, _ env: Env) throws -> MalVal { - var ast: MalVal = orig_ast - while is_macro(ast, env) { - switch try! env.get(try! _nth(ast, 0)) { - case MalVal.MalFunc(let mac,_,_,_,_,_): - ast = try mac(_rest(ast)) - default: throw MalError.General(msg: "impossible state in macroexpand") - } - } - return ast -} - -func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { - switch ast { - case MalVal.MalSymbol: - return try env.get(ast) - case MalVal.MalList(let lst, _): - return list(try lst.map { try EVAL($0, env) }) - case MalVal.MalVector(let lst, _): - return vector(try lst.map { try EVAL($0, env) }) - case MalVal.MalHashMap(let dict, _): - var new_dict = Dictionary() - for (k,v) in dict { new_dict[k] = try EVAL(v, env) } - return hash_map(new_dict) - default: - return ast - } -} - -func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { - var ast = orig_ast, env = orig_env - while true { - switch ast { - case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } - default: return try eval_ast(ast, env) - } - - ast = try macroexpand(ast, env) - switch ast { - case MalVal.MalList: break - default: return try eval_ast(ast, env) - } - - switch ast { - case MalVal.MalList(let lst, _): - switch lst[0] { - case MalVal.MalSymbol("def!"): - return try env.set(lst[1], try EVAL(lst[2], env)) - case MalVal.MalSymbol("let*"): - let let_env = try Env(env) - var binds = Array() - switch lst[1] { - case MalVal.MalList(let l, _): binds = l - case MalVal.MalVector(let l, _): binds = l - default: - throw MalError.General(msg: "Invalid let* bindings") - } - var idx = binds.startIndex - while idx < binds.endIndex { - let v = try EVAL(binds[binds.index(after: idx)], let_env) - try let_env.set(binds[idx], v) - idx = binds.index(idx, offsetBy: 2) - } - env = let_env - ast = lst[2] // TCO - case MalVal.MalSymbol("quote"): - return lst[1] - case MalVal.MalSymbol("quasiquoteexpand"): - return quasiquote(lst[1]) - case MalVal.MalSymbol("quasiquote"): - ast = quasiquote(lst[1]) // TCO - case MalVal.MalSymbol("defmacro!"): - var mac = try EVAL(lst[2], env) - switch mac { - case MalVal.MalFunc(let fn, let a, let e, let p, _, let m): - mac = malfunc(fn,ast:a,env:e,params:p,macro:true,meta:m) - default: throw MalError.General(msg: "invalid defmacro! form") - } - return try env.set(lst[1], mac) - case MalVal.MalSymbol("macroexpand"): - return try macroexpand(lst[1], env) - case MalVal.MalSymbol("try*"): - do { - return try EVAL(_nth(ast, 1), env) - } catch (let exc) { - if lst.count > 2 { - let a2 = lst[2] - switch a2 { - case MalVal.MalList(let a2lst, _): - let a20 = a2lst[0] - switch a20 { - case MalVal.MalSymbol("catch*"): - if a2lst.count < 3 { return MalVal.MalNil } - let a21 = a2lst[1], a22 = a2lst[2] - var err: MalVal - switch exc { - case MalError.Reader(let msg): - err = MalVal.MalString(msg) - case MalError.General(let msg): - err = MalVal.MalString(msg) - case MalError.MalException(let obj): - err = obj - default: - err = MalVal.MalString(String(describing:exc)) - } - return try EVAL(a22, Env(env, binds: list([a21]), - exprs: list([err]))) - default: break - } - default: break - } - } - throw exc - } - case MalVal.MalSymbol("do"): - let slc = lst[1.. 3 { - ast = lst[3] // TCO - } else { - return MalVal.MalNil - } - default: - ast = lst[2] // TCO - } - case MalVal.MalSymbol("fn*"): - return malfunc( { - return try EVAL(lst[2], Env(env, binds: lst[1], - exprs: list($0))) - }, ast:[lst[2]], env:env, params:[lst[1]]) - default: - switch try eval_ast(ast, env) { - case MalVal.MalList(let elst, _): - switch elst[0] { - case MalVal.MalFunc(let fn, nil, _, _, _, _): - let args = Array(elst[1.. String { - return pr_str(exp, true) -} - - -// repl -@discardableResult -func rep(_ str:String) throws -> String { - return PRINT(try EVAL(try READ(str), repl_env)) -} - -var repl_env: Env = try Env() - -// core.swift: defined using Swift -for (k, fn) in core_ns { - try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) -} -try repl_env.set(MalVal.MalSymbol("eval"), - malfunc({ try EVAL($0[0], repl_env) })) -let pargs = CommandLine.arguments.map { MalVal.MalString($0) } -// TODO: weird way to get empty list, fix this -var args = pargs[pargs.startIndex.. (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)))))))") - - -if CommandLine.arguments.count > 1 { - try rep("(load-file \"" + CommandLine.arguments[1] + "\")") - exit(0) -} - -while true { - print("user> ", terminator: "") - let line = readLine(strippingNewline: true) - if line == nil { break } - if line == "" { continue } - - do { - print(try rep(line!)) - } catch (MalError.Reader(let msg)) { - print("Error: \(msg)") - } catch (MalError.General(let msg)) { - print("Error: \(msg)") - } catch (MalError.MalException(let obj)) { - print("Error: \(pr_str(obj, true))") - } -} +import Foundation + +// read +func READ(_ str: String) throws -> MalVal { + return try read_str(str) +} + +// eval + +func starts_with(_ ast: MalVal, _ sym: String) -> MalVal? { + switch ast { + case MalVal.MalList(let lst, _) where 1 < lst.count: + switch lst[0] { + case MalVal.MalSymbol(sym): + return lst[1] + default: + return nil + } + default: + return nil + } +} + +func qqIter(_ lst: [MalVal]) -> MalVal { + var result = list([]) + for elt in lst.reversed() { + if let elt1 = starts_with(elt, "splice-unquote") { + result = list([MalVal.MalSymbol("concat"), elt1, result]) + } else { + result = list([MalVal.MalSymbol("cons"), quasiquote(elt), result]) + } + } + return result +} + +func quasiquote(_ ast: MalVal) -> MalVal { + if let a1 = starts_with(ast, "unquote") { + return a1 + } + switch ast { + case MalVal.MalList(let lst, _): + return qqIter(lst) + case MalVal.MalVector(let lst, _): + return list([MalVal.MalSymbol("vec"), qqIter(lst)]) + case MalVal.MalSymbol: + return list([MalVal.MalSymbol("quote"), ast]) + case MalVal.MalHashMap: + return list([MalVal.MalSymbol("quote"), ast]) + default: + return ast + } +} + +func is_macro(_ ast: MalVal, _ env: Env) -> Bool { + switch ast { + case MalVal.MalList(let lst, _) where lst.count > 0: + let a0 = lst[lst.startIndex] + switch a0 { + case MalVal.MalSymbol: + let e = try! env.find(a0) + if e != nil { + let mac = try! e!.get(a0) + switch mac { + case MalVal.MalFunc(_,_,_,_,let macro,_): return macro + default: return false + } + } else { + return false + } + default: return false + } + default: return false + } +} + +func macroexpand(_ orig_ast: MalVal, _ env: Env) throws -> MalVal { + var ast: MalVal = orig_ast + while is_macro(ast, env) { + switch try! env.get(try! _nth(ast, 0)) { + case MalVal.MalFunc(let mac,_,_,_,_,_): + ast = try mac(_rest(ast)) + default: throw MalError.General(msg: "impossible state in macroexpand") + } + } + return ast +} + +func eval_ast(_ ast: MalVal, _ env: Env) throws -> MalVal { + switch ast { + case MalVal.MalSymbol: + return try env.get(ast) + case MalVal.MalList(let lst, _): + return list(try lst.map { try EVAL($0, env) }) + case MalVal.MalVector(let lst, _): + return vector(try lst.map { try EVAL($0, env) }) + case MalVal.MalHashMap(let dict, _): + var new_dict = Dictionary() + for (k,v) in dict { new_dict[k] = try EVAL(v, env) } + return hash_map(new_dict) + default: + return ast + } +} + +func EVAL(_ orig_ast: MalVal, _ orig_env: Env) throws -> MalVal { + var ast = orig_ast, env = orig_env + while true { + switch ast { + case MalVal.MalList(let lst, _): if lst.count == 0 { return ast } + default: return try eval_ast(ast, env) + } + + ast = try macroexpand(ast, env) + switch ast { + case MalVal.MalList: break + default: return try eval_ast(ast, env) + } + + switch ast { + case MalVal.MalList(let lst, _): + switch lst[0] { + case MalVal.MalSymbol("def!"): + return try env.set(lst[1], try EVAL(lst[2], env)) + case MalVal.MalSymbol("let*"): + let let_env = try Env(env) + var binds = Array() + switch lst[1] { + case MalVal.MalList(let l, _): binds = l + case MalVal.MalVector(let l, _): binds = l + default: + throw MalError.General(msg: "Invalid let* bindings") + } + var idx = binds.startIndex + while idx < binds.endIndex { + let v = try EVAL(binds[binds.index(after: idx)], let_env) + try let_env.set(binds[idx], v) + idx = binds.index(idx, offsetBy: 2) + } + env = let_env + ast = lst[2] // TCO + case MalVal.MalSymbol("quote"): + return lst[1] + case MalVal.MalSymbol("quasiquoteexpand"): + return quasiquote(lst[1]) + case MalVal.MalSymbol("quasiquote"): + ast = quasiquote(lst[1]) // TCO + case MalVal.MalSymbol("defmacro!"): + var mac = try EVAL(lst[2], env) + switch mac { + case MalVal.MalFunc(let fn, let a, let e, let p, _, let m): + mac = malfunc(fn,ast:a,env:e,params:p,macro:true,meta:m) + default: throw MalError.General(msg: "invalid defmacro! form") + } + return try env.set(lst[1], mac) + case MalVal.MalSymbol("macroexpand"): + return try macroexpand(lst[1], env) + case MalVal.MalSymbol("try*"): + do { + return try EVAL(_nth(ast, 1), env) + } catch (let exc) { + if lst.count > 2 { + let a2 = lst[2] + switch a2 { + case MalVal.MalList(let a2lst, _): + let a20 = a2lst[0] + switch a20 { + case MalVal.MalSymbol("catch*"): + if a2lst.count < 3 { return MalVal.MalNil } + let a21 = a2lst[1], a22 = a2lst[2] + var err: MalVal + switch exc { + case MalError.Reader(let msg): + err = MalVal.MalString(msg) + case MalError.General(let msg): + err = MalVal.MalString(msg) + case MalError.MalException(let obj): + err = obj + default: + err = MalVal.MalString(String(describing:exc)) + } + return try EVAL(a22, Env(env, binds: list([a21]), + exprs: list([err]))) + default: break + } + default: break + } + } + throw exc + } + case MalVal.MalSymbol("do"): + let slc = lst[1.. 3 { + ast = lst[3] // TCO + } else { + return MalVal.MalNil + } + default: + ast = lst[2] // TCO + } + case MalVal.MalSymbol("fn*"): + return malfunc( { + return try EVAL(lst[2], Env(env, binds: lst[1], + exprs: list($0))) + }, ast:[lst[2]], env:env, params:[lst[1]]) + default: + switch try eval_ast(ast, env) { + case MalVal.MalList(let elst, _): + switch elst[0] { + case MalVal.MalFunc(let fn, nil, _, _, _, _): + let args = Array(elst[1.. String { + return pr_str(exp, true) +} + + +// repl +@discardableResult +func rep(_ str:String) throws -> String { + return PRINT(try EVAL(try READ(str), repl_env)) +} + +var repl_env: Env = try Env() + +// core.swift: defined using Swift +for (k, fn) in core_ns { + try repl_env.set(MalVal.MalSymbol(k), malfunc(fn)) +} +try repl_env.set(MalVal.MalSymbol("eval"), + malfunc({ try EVAL($0[0], repl_env) })) +let pargs = CommandLine.arguments.map { MalVal.MalString($0) } +// TODO: weird way to get empty list, fix this +var args = pargs[pargs.startIndex.. (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)))))))") + + +if CommandLine.arguments.count > 1 { + try rep("(load-file \"" + CommandLine.arguments[1] + "\")") + exit(0) +} + +while true { + print("user> ", terminator: "") + let line = readLine(strippingNewline: true) + if line == nil { break } + if line == "" { continue } + + do { + print(try rep(line!)) + } catch (MalError.Reader(let msg)) { + print("Error: \(msg)") + } catch (MalError.General(let msg)) { + print("Error: \(msg)") + } catch (MalError.MalException(let obj)) { + print("Error: \(pr_str(obj, true))") + } +} diff --git a/impls/swift3/Sources/types.swift b/impls/swift3/Sources/types.swift index 25f1468d7e..04c4536969 100644 --- a/impls/swift3/Sources/types.swift +++ b/impls/swift3/Sources/types.swift @@ -1,212 +1,212 @@ - -enum MalError: Error { - case Reader(msg: String) - case General(msg: String) - case MalException(obj: MalVal) -} - -class MutableAtom { - var val: MalVal - init(val: MalVal) { - self.val = val - } -} - -enum MalVal { - case MalNil - case MalTrue - case MalFalse - case MalInt(Int) - case MalFloat(Float) - case MalString(String) - case MalSymbol(String) - case MalList(Array, meta: Array?) - case MalVector(Array, meta: Array?) - case MalHashMap(Dictionary, meta: Array?) - // TODO: internal MalVals are wrapped in arrays because otherwise - // compiler throws a fault - case MalFunc((Array) throws -> MalVal, - ast: Array?, - env: Env?, - params: Array?, - macro: Bool, - meta: Array?) - case MalAtom(MutableAtom) -} - -typealias MV = MalVal - -// General functions - -func wraptf(_ a: Bool) -> MalVal { - return a ? MV.MalTrue : MV.MalFalse -} - - -// equality functions -func cmp_seqs(_ a: Array, _ b: Array) -> Bool { - if a.count != b.count { return false } - var idx = a.startIndex - while idx < a.endIndex { - if !equal_Q(a[idx], b[idx]) { return false } - idx = a.index(after:idx) - } - return true -} - -func cmp_maps(_ a: Dictionary, - _ b: Dictionary) -> Bool { - if a.count != b.count { return false } - for (k,v1) in a { - if b[k] == nil { return false } - if !equal_Q(v1, b[k]!) { return false } - } - return true -} - -func equal_Q(_ a: MalVal, _ b: MalVal) -> Bool { - switch (a, b) { - case (MV.MalNil, MV.MalNil): return true - case (MV.MalFalse, MV.MalFalse): return true - case (MV.MalTrue, MV.MalTrue): return true - case (MV.MalInt(let i1), MV.MalInt(let i2)): return i1 == i2 - case (MV.MalString(let s1), MV.MalString(let s2)): return s1 == s2 - case (MV.MalSymbol(let s1), MV.MalSymbol(let s2)): return s1 == s2 - case (MV.MalList(let l1,_), MV.MalList(let l2,_)): - return cmp_seqs(l1, l2) - case (MV.MalList(let l1,_), MV.MalVector(let l2,_)): - return cmp_seqs(l1, l2) - case (MV.MalVector(let l1,_), MV.MalList(let l2,_)): - return cmp_seqs(l1, l2) - case (MV.MalVector(let l1,_), MV.MalVector(let l2,_)): - return cmp_seqs(l1, l2) - case (MV.MalHashMap(let d1,_), MV.MalHashMap(let d2,_)): - return cmp_maps(d1, d2) - default: - return false - } -} - -// list and vector functions -func list(_ lst: Array) -> MalVal { - return MV.MalList(lst, meta:nil) -} -func list(_ lst: Array, meta: MalVal) -> MalVal { - return MV.MalList(lst, meta:[meta]) -} - -func vector(_ lst: Array) -> MalVal { - return MV.MalVector(lst, meta:nil) -} -func vector(_ lst: Array, meta: MalVal) -> MalVal { - return MV.MalVector(lst, meta:[meta]) -} - - -// hash-map functions - -func _assoc(_ src: Dictionary, _ mvs: Array) - throws -> Dictionary { - var d = src - if mvs.count % 2 != 0 { - throw MalError.General(msg: "Odd number of args to assoc_BANG") - } - var pos = mvs.startIndex - while pos < mvs.count { - switch (mvs[pos], mvs[pos+1]) { - case (MV.MalString(let k), let mv): - d[k] = mv - default: - throw MalError.General(msg: "Invalid _assoc call") - } - pos += 2 - } - return d -} - -func _dissoc(_ src: Dictionary, _ mvs: Array) - throws -> Dictionary { - var d = src - for mv in mvs { - switch mv { - case MV.MalString(let k): d.removeValue(forKey: k) - default: throw MalError.General(msg: "Invalid _dissoc call") - } - } - return d -} - - -func hash_map(_ dict: Dictionary) -> MalVal { - return MV.MalHashMap(dict, meta:nil) -} - -func hash_map(_ dict: Dictionary, meta:MalVal) -> MalVal { - return MV.MalHashMap(dict, meta:[meta]) -} - -func hash_map(_ arr: Array) throws -> MalVal { - let d = Dictionary(); - return MV.MalHashMap(try _assoc(d, arr), meta:nil) -} - - -// function functions -func malfunc(_ fn: @escaping (Array) throws -> MalVal) -> MalVal { - return MV.MalFunc(fn, ast: nil, env: nil, params: nil, - macro: false, meta: nil) -} -func malfunc(_ fn: @escaping (Array) throws -> MalVal, - ast: Array?, - env: Env?, - params: Array?) -> MalVal { - return MV.MalFunc(fn, ast: ast, env: env, params: params, - macro: false, meta: nil) -} -func malfunc(_ fn: @escaping (Array) throws -> MalVal, - ast: Array?, - env: Env?, - params: Array?, - macro: Bool, - meta: MalVal?) -> MalVal { - return MV.MalFunc(fn, ast: ast, env: env, params: params, - macro: macro, meta: meta != nil ? [meta!] : nil) -} -func malfunc(_ fn: @escaping (Array) throws -> MalVal, - ast: Array?, - env: Env?, - params: Array?, - macro: Bool, - meta: Array?) -> MalVal { - return MV.MalFunc(fn, ast: ast, env: env, params: params, - macro: macro, meta: meta) -} - -// sequence functions - -func _rest(_ a: MalVal) throws -> Array { - switch a { - case MV.MalList(let lst,_): - let start = lst.index(after: lst.startIndex) - let slc = lst[start.. MalVal { - return list(try _rest(a)) -} - -func _nth(_ a: MalVal, _ idx: Int) throws -> MalVal { - switch a { - case MV.MalList(let l,_): return l[l.startIndex.advanced(by: idx)] - case MV.MalVector(let l,_): return l[l.startIndex.advanced(by: idx)] - default: throw MalError.General(msg: "Invalid nth call") - } -} + +enum MalError: Error { + case Reader(msg: String) + case General(msg: String) + case MalException(obj: MalVal) +} + +class MutableAtom { + var val: MalVal + init(val: MalVal) { + self.val = val + } +} + +enum MalVal { + case MalNil + case MalTrue + case MalFalse + case MalInt(Int) + case MalFloat(Float) + case MalString(String) + case MalSymbol(String) + case MalList(Array, meta: Array?) + case MalVector(Array, meta: Array?) + case MalHashMap(Dictionary, meta: Array?) + // TODO: internal MalVals are wrapped in arrays because otherwise + // compiler throws a fault + case MalFunc((Array) throws -> MalVal, + ast: Array?, + env: Env?, + params: Array?, + macro: Bool, + meta: Array?) + case MalAtom(MutableAtom) +} + +typealias MV = MalVal + +// General functions + +func wraptf(_ a: Bool) -> MalVal { + return a ? MV.MalTrue : MV.MalFalse +} + + +// equality functions +func cmp_seqs(_ a: Array, _ b: Array) -> Bool { + if a.count != b.count { return false } + var idx = a.startIndex + while idx < a.endIndex { + if !equal_Q(a[idx], b[idx]) { return false } + idx = a.index(after:idx) + } + return true +} + +func cmp_maps(_ a: Dictionary, + _ b: Dictionary) -> Bool { + if a.count != b.count { return false } + for (k,v1) in a { + if b[k] == nil { return false } + if !equal_Q(v1, b[k]!) { return false } + } + return true +} + +func equal_Q(_ a: MalVal, _ b: MalVal) -> Bool { + switch (a, b) { + case (MV.MalNil, MV.MalNil): return true + case (MV.MalFalse, MV.MalFalse): return true + case (MV.MalTrue, MV.MalTrue): return true + case (MV.MalInt(let i1), MV.MalInt(let i2)): return i1 == i2 + case (MV.MalString(let s1), MV.MalString(let s2)): return s1 == s2 + case (MV.MalSymbol(let s1), MV.MalSymbol(let s2)): return s1 == s2 + case (MV.MalList(let l1,_), MV.MalList(let l2,_)): + return cmp_seqs(l1, l2) + case (MV.MalList(let l1,_), MV.MalVector(let l2,_)): + return cmp_seqs(l1, l2) + case (MV.MalVector(let l1,_), MV.MalList(let l2,_)): + return cmp_seqs(l1, l2) + case (MV.MalVector(let l1,_), MV.MalVector(let l2,_)): + return cmp_seqs(l1, l2) + case (MV.MalHashMap(let d1,_), MV.MalHashMap(let d2,_)): + return cmp_maps(d1, d2) + default: + return false + } +} + +// list and vector functions +func list(_ lst: Array) -> MalVal { + return MV.MalList(lst, meta:nil) +} +func list(_ lst: Array, meta: MalVal) -> MalVal { + return MV.MalList(lst, meta:[meta]) +} + +func vector(_ lst: Array) -> MalVal { + return MV.MalVector(lst, meta:nil) +} +func vector(_ lst: Array, meta: MalVal) -> MalVal { + return MV.MalVector(lst, meta:[meta]) +} + + +// hash-map functions + +func _assoc(_ src: Dictionary, _ mvs: Array) + throws -> Dictionary { + var d = src + if mvs.count % 2 != 0 { + throw MalError.General(msg: "Odd number of args to assoc_BANG") + } + var pos = mvs.startIndex + while pos < mvs.count { + switch (mvs[pos], mvs[pos+1]) { + case (MV.MalString(let k), let mv): + d[k] = mv + default: + throw MalError.General(msg: "Invalid _assoc call") + } + pos += 2 + } + return d +} + +func _dissoc(_ src: Dictionary, _ mvs: Array) + throws -> Dictionary { + var d = src + for mv in mvs { + switch mv { + case MV.MalString(let k): d.removeValue(forKey: k) + default: throw MalError.General(msg: "Invalid _dissoc call") + } + } + return d +} + + +func hash_map(_ dict: Dictionary) -> MalVal { + return MV.MalHashMap(dict, meta:nil) +} + +func hash_map(_ dict: Dictionary, meta:MalVal) -> MalVal { + return MV.MalHashMap(dict, meta:[meta]) +} + +func hash_map(_ arr: Array) throws -> MalVal { + let d = Dictionary(); + return MV.MalHashMap(try _assoc(d, arr), meta:nil) +} + + +// function functions +func malfunc(_ fn: @escaping (Array) throws -> MalVal) -> MalVal { + return MV.MalFunc(fn, ast: nil, env: nil, params: nil, + macro: false, meta: nil) +} +func malfunc(_ fn: @escaping (Array) throws -> MalVal, + ast: Array?, + env: Env?, + params: Array?) -> MalVal { + return MV.MalFunc(fn, ast: ast, env: env, params: params, + macro: false, meta: nil) +} +func malfunc(_ fn: @escaping (Array) throws -> MalVal, + ast: Array?, + env: Env?, + params: Array?, + macro: Bool, + meta: MalVal?) -> MalVal { + return MV.MalFunc(fn, ast: ast, env: env, params: params, + macro: macro, meta: meta != nil ? [meta!] : nil) +} +func malfunc(_ fn: @escaping (Array) throws -> MalVal, + ast: Array?, + env: Env?, + params: Array?, + macro: Bool, + meta: Array?) -> MalVal { + return MV.MalFunc(fn, ast: ast, env: env, params: params, + macro: macro, meta: meta) +} + +// sequence functions + +func _rest(_ a: MalVal) throws -> Array { + switch a { + case MV.MalList(let lst,_): + let start = lst.index(after: lst.startIndex) + let slc = lst[start.. MalVal { + return list(try _rest(a)) +} + +func _nth(_ a: MalVal, _ idx: Int) throws -> MalVal { + switch a { + case MV.MalList(let l,_): return l[l.startIndex.advanced(by: idx)] + case MV.MalVector(let l,_): return l[l.startIndex.advanced(by: idx)] + default: throw MalError.General(msg: "Invalid nth call") + } +} diff --git a/impls/swift3/run b/impls/swift3/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/swift3/run +++ b/impls/swift3/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/swift3/tests/step5_tco.mal b/impls/swift3/tests/step5_tco.mal index 3a866dc556..c80c88729f 100644 --- a/impls/swift3/tests/step5_tco.mal +++ b/impls/swift3/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Swift 3: skipping non-TCO recursion -;; Reason: unrecoverable segfault at 10,000 +;; Swift 3: skipping non-TCO recursion +;; Reason: unrecoverable segfault at 10,000 diff --git a/impls/swift4/Dockerfile b/impls/swift4/Dockerfile index 744f62b17c..1b9580ff7e 100644 --- a/impls/swift4/Dockerfile +++ b/impls/swift4/Dockerfile @@ -1,44 +1,44 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Swift -RUN apt-get -y install clang-3.6 cmake pkg-config \ - git ninja-build uuid-dev libicu-dev icu-devtools \ - libbsd-dev libedit-dev libxml2-dev libsqlite3-dev \ - swig libpython-dev libncurses5-dev - -# TODO: better way to do this? -RUN ln -sf /usr/lib/llvm-3.6/bin/clang++ /usr/bin/clang++ -RUN ln -sf /usr/lib/llvm-3.6/bin/clang /usr/bin/clang - -ENV SWIFT_PREFIX swift-4.2.3-RELEASE -ENV SWIFT_RELEASE ${SWIFT_PREFIX}-ubuntu16.04 - -RUN cd /opt && \ - curl -O https://swift.org/builds/swift-4.2.3-release/ubuntu1604/${SWIFT_PREFIX}/${SWIFT_RELEASE}.tar.gz && \ - tar xvzf ${SWIFT_RELEASE}.tar.gz && \ - rm ${SWIFT_RELEASE}.tar.gz - -ENV PATH /opt/${SWIFT_RELEASE}/usr/bin/:$PATH - - +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Swift +RUN apt-get -y install clang-3.6 cmake pkg-config \ + git ninja-build uuid-dev libicu-dev icu-devtools \ + libbsd-dev libedit-dev libxml2-dev libsqlite3-dev \ + swig libpython-dev libncurses5-dev + +# TODO: better way to do this? +RUN ln -sf /usr/lib/llvm-3.6/bin/clang++ /usr/bin/clang++ +RUN ln -sf /usr/lib/llvm-3.6/bin/clang /usr/bin/clang + +ENV SWIFT_PREFIX swift-4.2.3-RELEASE +ENV SWIFT_RELEASE ${SWIFT_PREFIX}-ubuntu16.04 + +RUN cd /opt && \ + curl -O https://swift.org/builds/swift-4.2.3-release/ubuntu1604/${SWIFT_PREFIX}/${SWIFT_RELEASE}.tar.gz && \ + tar xvzf ${SWIFT_RELEASE}.tar.gz && \ + rm ${SWIFT_RELEASE}.tar.gz + +ENV PATH /opt/${SWIFT_RELEASE}/usr/bin/:$PATH + + diff --git a/impls/swift4/Makefile b/impls/swift4/Makefile index 5bb375446d..1821f4f4c1 100644 --- a/impls/swift4/Makefile +++ b/impls/swift4/Makefile @@ -1,28 +1,28 @@ -ifneq ($(shell which xcrun),) - SWIFT = xcrun -sdk macosx swiftc -else - SWIFT = swiftc -endif - -STEP3_DEPS = Sources/types.swift Sources/reader.swift Sources/printer.swift Sources/env.swift -STEP4_DEPS = $(STEP3_DEPS) Sources/core.swift - -STEPS = step0_repl step1_read_print step2_eval step3_env \ - step4_if_fn_do step5_tco step6_file step7_quote \ - step8_macros step9_try stepA_mal - -all: $(STEPS) - -dist: mal - -mal: stepA_mal - cp $< $@ - -step1_read_print step2_eval step3_env: $(STEP3_DEPS) -step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) - -step%: Sources/step%/main.swift - $(SWIFT) $+ -o $@ - -clean: - rm -f $(STEPS) mal +ifneq ($(shell which xcrun),) + SWIFT = xcrun -sdk macosx swiftc +else + SWIFT = swiftc +endif + +STEP3_DEPS = Sources/types.swift Sources/reader.swift Sources/printer.swift Sources/env.swift +STEP4_DEPS = $(STEP3_DEPS) Sources/core.swift + +STEPS = step0_repl step1_read_print step2_eval step3_env \ + step4_if_fn_do step5_tco step6_file step7_quote \ + step8_macros step9_try stepA_mal + +all: $(STEPS) + +dist: mal + +mal: stepA_mal + cp $< $@ + +step1_read_print step2_eval step3_env: $(STEP3_DEPS) +step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS) + +step%: Sources/step%/main.swift + $(SWIFT) $+ -o $@ + +clean: + rm -f $(STEPS) mal diff --git a/impls/swift4/Sources/core.swift b/impls/swift4/Sources/core.swift index e10fe5afb9..71fbc31605 100644 --- a/impls/swift4/Sources/core.swift +++ b/impls/swift4/Sources/core.swift @@ -1,210 +1,210 @@ - -import Foundation - -func calculate(_ args: [MalData], op: (Number, Number) -> Number) throws -> MalData { - guard args.count == 2, args[0] is Number, args[1] is Number else { - throw MalError.InvalidArgument - } - return op(args[0] as! Number, args[1] as! Number) -} - -func isEqualList(_ l: [MalData], _ r: [MalData]) -> Bool { - guard l.count == r.count else { - return false - } - for i in l.indices { - if !isEqual(l[i], r[i]) { return false } - } - return true -} - -func isEqualHashMap (_ l: [String: MalData], _ r: [String: MalData]) -> Bool { - guard l.count == r.count else { - return false - } - for key in l.keys { - guard let lValue = l[key], let rValue = r[key] else { return false } - if !isEqual(lValue, rValue) { return false } - } - return true -} - -func isEqual(_ l: MalData, _ r: MalData) -> Bool { - switch (l.dataType, r.dataType) { - case (.Symbol, .Symbol): - return (l as! Symbol).name == (r as! Symbol).name - case (.String, .String), (.Keyword, .Keyword): - return (l as! String) == (r as! String) - case (.Number, .Number): - return (l as! Number) == (r as! Number) - case (.List, .List), (.Vector, .Vector), (.List, .Vector), (. Vector, .List): - return isEqualList(l.listForm, r.listForm) - case (.HashMap, .HashMap): - return isEqualHashMap((l as! [String: MalData]), (r as! [String: MalData])) - case (.Nil, .Nil), (.True, .True), (.False, .False): - return true - default: // atom, function - return false - } -} - -func hashMap(fromList list: [MalData]) throws -> [String: MalData] { - var hashMap: [String: MalData] = [:] - for index in stride(from: 0, to: list.count, by: 2) { - guard list[index] is String, index+1 < list.count else { throw MalError.Error } - hashMap.updateValue(list[index+1], forKey: list[index] as! String) - } - return hashMap -} - -let ns: [String: ([MalData]) throws -> MalData] = - ["+": { try calculate($0, op: +) }, - "-": { try calculate($0, op: -) }, - "*": { try calculate($0, op: *) }, - "/": { try calculate($0, op: /) }, - "<": { args in (args[0] as! Number) < (args[1] as! Number) }, - ">": { args in (args[0] as! Number) > (args[1] as! Number) }, - "<=": { args in (args[0] as! Number) <= (args[1] as! Number) }, - ">=": { args in (args[0] as! Number) >= (args[1] as! Number) }, - - "=": { args in let left = args[0], right = args[1]; return isEqual(left, right) }, - - "pr-str": { $0.map { pr_str($0, print_readably: true)}.joined(separator: " ") }, - "str": { $0.map { pr_str($0, print_readably: false)}.joined(separator: "") }, - "prn": { print($0.map { pr_str($0, print_readably: true)}.joined(separator: " ")); return Nil() }, - "println": { print($0.map { pr_str($0, print_readably: false)}.joined(separator: " ")); return Nil() }, - - "list": { List($0) }, - "list?": { let param = $0[0]; return param is [MalData] }, - "empty?": { $0[0].count == 0 }, - "count": { $0[0].count }, - - "read-string": { try read_str($0[0] as! String) }, - "slurp": { try String(contentsOfFile: $0[0] as! String) }, - - "atom": { Atom($0[0]) }, - "atom?": { $0[0] is Atom }, - "deref": { ($0[0] as? Atom)?.value ?? Nil() }, - "reset!": { args in (args[0] as! Atom).value = args[1]; return args[1] }, - "swap!": { args in - let atom = args[0] as! Atom, fn = args[1] as! Function, - others = args.dropFirst(2).listForm - atom.value = try fn.fn([atom.value] + others) - return atom.value - }, - "cons": { args in [args[0]] + args[1].listForm }, - "concat": { $0.reduce([]) { (result, array ) in result + array.listForm } }, - "vec": { Vector($0[0].listForm) }, - - "nth": { args in - let list = args[0].listForm, i = args[1] as! Int - guard list.indices.contains(i) else { throw MalError.IndexOutOfBounds } - return list[i] - }, - "first": { $0[0].listForm.first ?? Nil() }, - "rest": { $0[0].listForm.dropFirst().listForm }, - - "throw": { throw MalError.MalException($0[0]) }, - "apply": { args in - let fn = args[0] as! Function - let newArgs = args.dropFirst().dropLast().listForm + args.last!.listForm - return try fn.fn(newArgs) - }, - "map": { args in - let fn = args[0] as! Function - let closure = fn.fn - var result: [MalData] = [] - for element in args[1].listForm { - result.append(try fn.fn([element])) } - return result - }, - - "nil?": { $0[0] is Nil }, - "true?": { $0[0].dataType == .True }, - "false?": { $0[0].dataType == .False }, - "symbol?": { $0[0].dataType == .Symbol }, - "symbol": { Symbol($0[0] as! String) }, - "keyword": { ($0[0].dataType == .Keyword) ? $0[0] : "\u{029E}" + ($0[0] as! String) }, - "keyword?":{ $0[0].dataType == .Keyword }, - "vector": { Vector($0) }, - "vector?": { $0[0].dataType == .Vector }, - "hash-map":{ try hashMap(fromList: $0) }, - "map?": { $0[0].dataType == .HashMap }, - "assoc": { - let map = $0[0] as! [String: MalData] - return map.merging(try hashMap(fromList: $0.dropFirst().listForm)) { (_, new) in new } - }, - "dissoc": { args in - let map = args[0] as! [String: MalData] - return map.filter { (key, _) in !(args.dropFirst().listForm as! [String]).contains(key) } - }, - "get": { - if let map = $0[0] as? [String: MalData] { - return map[$0[1] as! String] ?? Nil() } - return Nil() - }, - "contains?": { ($0[0] as! [String: MalData])[$0[1] as! String] != nil }, - "keys": { - ($0[0] as! [String: MalData]).reduce([]) { result, element in - let (key, _) = element - return result + [key] } - }, - "vals": { - ($0[0] as! [String: MalData]).reduce([]) { result, element in - let (_, value) = element - return result + [value] } - }, - "sequential?": { [.List, .Vector].contains($0[0].dataType) }, - - "readline": { - print($0[0] as! String, terminator: "") - return readLine(strippingNewline: true) ?? Nil() }, - - "meta": { - switch $0[0].dataType { - case .Function: - return ($0[0] as! Function).meta ?? Nil() - default: - return Nil() - }}, - "with-meta": { - switch $0[0].dataType { - case .Function: - return Function(withFunction: $0[0] as! Function, meta: $0[1]) - default: - return $0[0] - }}, - "time-ms": { _ in Int(Date().timeIntervalSince1970 * 1000) }, - "conj": { - if let list = $0[0] as? [MalData] { - return $0.dropFirst().reversed().listForm + list - } else { // vector - return ($0[0] as! Vector) + Vector($0.dropFirst()) - }}, - "string?": { $0[0].dataType == .String }, - "number?": { $0[0].dataType == .Number }, - "fn?": { - if let fn = $0[0] as? Function { - return !fn.isMacro - } else { - return false - }}, - "macro?": { - if let fn = $0[0] as? Function { - return fn.isMacro - } else { - return false - }}, - "seq": { - if $0[0].count == 0 { return Nil() } - switch $0[0].dataType { - case .List: - return $0[0] as! List - case .Vector: - return List($0[0] as! ContiguousArray) - case .String: - return List($0[0] as! String).map { String($0) } - default: - return Nil() - }}, -] + +import Foundation + +func calculate(_ args: [MalData], op: (Number, Number) -> Number) throws -> MalData { + guard args.count == 2, args[0] is Number, args[1] is Number else { + throw MalError.InvalidArgument + } + return op(args[0] as! Number, args[1] as! Number) +} + +func isEqualList(_ l: [MalData], _ r: [MalData]) -> Bool { + guard l.count == r.count else { + return false + } + for i in l.indices { + if !isEqual(l[i], r[i]) { return false } + } + return true +} + +func isEqualHashMap (_ l: [String: MalData], _ r: [String: MalData]) -> Bool { + guard l.count == r.count else { + return false + } + for key in l.keys { + guard let lValue = l[key], let rValue = r[key] else { return false } + if !isEqual(lValue, rValue) { return false } + } + return true +} + +func isEqual(_ l: MalData, _ r: MalData) -> Bool { + switch (l.dataType, r.dataType) { + case (.Symbol, .Symbol): + return (l as! Symbol).name == (r as! Symbol).name + case (.String, .String), (.Keyword, .Keyword): + return (l as! String) == (r as! String) + case (.Number, .Number): + return (l as! Number) == (r as! Number) + case (.List, .List), (.Vector, .Vector), (.List, .Vector), (. Vector, .List): + return isEqualList(l.listForm, r.listForm) + case (.HashMap, .HashMap): + return isEqualHashMap((l as! [String: MalData]), (r as! [String: MalData])) + case (.Nil, .Nil), (.True, .True), (.False, .False): + return true + default: // atom, function + return false + } +} + +func hashMap(fromList list: [MalData]) throws -> [String: MalData] { + var hashMap: [String: MalData] = [:] + for index in stride(from: 0, to: list.count, by: 2) { + guard list[index] is String, index+1 < list.count else { throw MalError.Error } + hashMap.updateValue(list[index+1], forKey: list[index] as! String) + } + return hashMap +} + +let ns: [String: ([MalData]) throws -> MalData] = + ["+": { try calculate($0, op: +) }, + "-": { try calculate($0, op: -) }, + "*": { try calculate($0, op: *) }, + "/": { try calculate($0, op: /) }, + "<": { args in (args[0] as! Number) < (args[1] as! Number) }, + ">": { args in (args[0] as! Number) > (args[1] as! Number) }, + "<=": { args in (args[0] as! Number) <= (args[1] as! Number) }, + ">=": { args in (args[0] as! Number) >= (args[1] as! Number) }, + + "=": { args in let left = args[0], right = args[1]; return isEqual(left, right) }, + + "pr-str": { $0.map { pr_str($0, print_readably: true)}.joined(separator: " ") }, + "str": { $0.map { pr_str($0, print_readably: false)}.joined(separator: "") }, + "prn": { print($0.map { pr_str($0, print_readably: true)}.joined(separator: " ")); return Nil() }, + "println": { print($0.map { pr_str($0, print_readably: false)}.joined(separator: " ")); return Nil() }, + + "list": { List($0) }, + "list?": { let param = $0[0]; return param is [MalData] }, + "empty?": { $0[0].count == 0 }, + "count": { $0[0].count }, + + "read-string": { try read_str($0[0] as! String) }, + "slurp": { try String(contentsOfFile: $0[0] as! String) }, + + "atom": { Atom($0[0]) }, + "atom?": { $0[0] is Atom }, + "deref": { ($0[0] as? Atom)?.value ?? Nil() }, + "reset!": { args in (args[0] as! Atom).value = args[1]; return args[1] }, + "swap!": { args in + let atom = args[0] as! Atom, fn = args[1] as! Function, + others = args.dropFirst(2).listForm + atom.value = try fn.fn([atom.value] + others) + return atom.value + }, + "cons": { args in [args[0]] + args[1].listForm }, + "concat": { $0.reduce([]) { (result, array ) in result + array.listForm } }, + "vec": { Vector($0[0].listForm) }, + + "nth": { args in + let list = args[0].listForm, i = args[1] as! Int + guard list.indices.contains(i) else { throw MalError.IndexOutOfBounds } + return list[i] + }, + "first": { $0[0].listForm.first ?? Nil() }, + "rest": { $0[0].listForm.dropFirst().listForm }, + + "throw": { throw MalError.MalException($0[0]) }, + "apply": { args in + let fn = args[0] as! Function + let newArgs = args.dropFirst().dropLast().listForm + args.last!.listForm + return try fn.fn(newArgs) + }, + "map": { args in + let fn = args[0] as! Function + let closure = fn.fn + var result: [MalData] = [] + for element in args[1].listForm { + result.append(try fn.fn([element])) } + return result + }, + + "nil?": { $0[0] is Nil }, + "true?": { $0[0].dataType == .True }, + "false?": { $0[0].dataType == .False }, + "symbol?": { $0[0].dataType == .Symbol }, + "symbol": { Symbol($0[0] as! String) }, + "keyword": { ($0[0].dataType == .Keyword) ? $0[0] : "\u{029E}" + ($0[0] as! String) }, + "keyword?":{ $0[0].dataType == .Keyword }, + "vector": { Vector($0) }, + "vector?": { $0[0].dataType == .Vector }, + "hash-map":{ try hashMap(fromList: $0) }, + "map?": { $0[0].dataType == .HashMap }, + "assoc": { + let map = $0[0] as! [String: MalData] + return map.merging(try hashMap(fromList: $0.dropFirst().listForm)) { (_, new) in new } + }, + "dissoc": { args in + let map = args[0] as! [String: MalData] + return map.filter { (key, _) in !(args.dropFirst().listForm as! [String]).contains(key) } + }, + "get": { + if let map = $0[0] as? [String: MalData] { + return map[$0[1] as! String] ?? Nil() } + return Nil() + }, + "contains?": { ($0[0] as! [String: MalData])[$0[1] as! String] != nil }, + "keys": { + ($0[0] as! [String: MalData]).reduce([]) { result, element in + let (key, _) = element + return result + [key] } + }, + "vals": { + ($0[0] as! [String: MalData]).reduce([]) { result, element in + let (_, value) = element + return result + [value] } + }, + "sequential?": { [.List, .Vector].contains($0[0].dataType) }, + + "readline": { + print($0[0] as! String, terminator: "") + return readLine(strippingNewline: true) ?? Nil() }, + + "meta": { + switch $0[0].dataType { + case .Function: + return ($0[0] as! Function).meta ?? Nil() + default: + return Nil() + }}, + "with-meta": { + switch $0[0].dataType { + case .Function: + return Function(withFunction: $0[0] as! Function, meta: $0[1]) + default: + return $0[0] + }}, + "time-ms": { _ in Int(Date().timeIntervalSince1970 * 1000) }, + "conj": { + if let list = $0[0] as? [MalData] { + return $0.dropFirst().reversed().listForm + list + } else { // vector + return ($0[0] as! Vector) + Vector($0.dropFirst()) + }}, + "string?": { $0[0].dataType == .String }, + "number?": { $0[0].dataType == .Number }, + "fn?": { + if let fn = $0[0] as? Function { + return !fn.isMacro + } else { + return false + }}, + "macro?": { + if let fn = $0[0] as? Function { + return fn.isMacro + } else { + return false + }}, + "seq": { + if $0[0].count == 0 { return Nil() } + switch $0[0].dataType { + case .List: + return $0[0] as! List + case .Vector: + return List($0[0] as! ContiguousArray) + case .String: + return List($0[0] as! String).map { String($0) } + default: + return Nil() + }}, +] diff --git a/impls/swift4/Sources/env.swift b/impls/swift4/Sources/env.swift index 50b8ca1cd3..f1936f3c78 100644 --- a/impls/swift4/Sources/env.swift +++ b/impls/swift4/Sources/env.swift @@ -1,43 +1,43 @@ - -import Foundation - -class Env { - let outer: Env? - var data: [String: MalData] = [:] - - init(outer: Env) { - self.outer = outer - } - init() { - outer = nil - } - init(binds: [Symbol], exprs: [MalData], outer: Env) { - self.outer = outer - self.data = [:] - for i in binds.indices { - if binds[i].name == "&" { - data.updateValue(List(exprs[i.. Env? { - if let _ = data[key.name] { - return self - } else { - return outer?.find(key) - } - } - func get(forKey key: Symbol) throws -> MalData { - if let env = find(key), let value = env.data[key.name] { - return value - } else { - throw MalError.SymbolNotFound(key) - } - } -} + +import Foundation + +class Env { + let outer: Env? + var data: [String: MalData] = [:] + + init(outer: Env) { + self.outer = outer + } + init() { + outer = nil + } + init(binds: [Symbol], exprs: [MalData], outer: Env) { + self.outer = outer + self.data = [:] + for i in binds.indices { + if binds[i].name == "&" { + data.updateValue(List(exprs[i.. Env? { + if let _ = data[key.name] { + return self + } else { + return outer?.find(key) + } + } + func get(forKey key: Symbol) throws -> MalData { + if let env = find(key), let value = env.data[key.name] { + return value + } else { + throw MalError.SymbolNotFound(key) + } + } +} diff --git a/impls/swift4/Sources/printer.swift b/impls/swift4/Sources/printer.swift index 0ccfc1f93b..4af9a7852b 100644 --- a/impls/swift4/Sources/printer.swift +++ b/impls/swift4/Sources/printer.swift @@ -1,51 +1,51 @@ - -import Foundation - -func pr_str(_ input: MalData, print_readably: Bool) -> String { - switch input.dataType { - case .Symbol: - let symbol = input as! Symbol - return symbol.name - case .Number: - let number = input as! Number - return String(number) - case .True: - return "true" - case .False: - return "false" - case .Nil: - return "nil" - case .Keyword: - let keyword = input as! String - return keyword.replacingCharacters(in: keyword.startIndex...keyword.startIndex, with: ":") - case .String: - let string = input as! String - if print_readably { - return "\"" + string.replacingOccurrences(of: "\\", with: "\\\\") - .replacingOccurrences(of: "\"", with: "\\\"") - .replacingOccurrences(of: "\n", with: "\\n") + "\"" - } else { - return string - } - case .List: - let list = input as! List - let stringOfElements = list.map { pr_str($0, print_readably: print_readably) }.joined(separator: " ") - return "(" + stringOfElements + ")" - case .Vector: - let vector = input as! Vector - let stringOfElements = vector.map { pr_str($0, print_readably: print_readably) }.joined(separator: " ") - return "[" + stringOfElements + "]" - case .HashMap: - let hashMap = input as! [String: MalData] - let stringOfElements = hashMap.map { (key, value) in - pr_str(key, print_readably: print_readably) + " " + pr_str(value, print_readably: print_readably) - }.joined(separator: " ") - return "{" + stringOfElements + "}" - case .Atom: - return pr_str("(atom \((input as! Atom).value))", print_readably: false) - case .Function: - return "#" - default: - return "error type!" - } -} + +import Foundation + +func pr_str(_ input: MalData, print_readably: Bool) -> String { + switch input.dataType { + case .Symbol: + let symbol = input as! Symbol + return symbol.name + case .Number: + let number = input as! Number + return String(number) + case .True: + return "true" + case .False: + return "false" + case .Nil: + return "nil" + case .Keyword: + let keyword = input as! String + return keyword.replacingCharacters(in: keyword.startIndex...keyword.startIndex, with: ":") + case .String: + let string = input as! String + if print_readably { + return "\"" + string.replacingOccurrences(of: "\\", with: "\\\\") + .replacingOccurrences(of: "\"", with: "\\\"") + .replacingOccurrences(of: "\n", with: "\\n") + "\"" + } else { + return string + } + case .List: + let list = input as! List + let stringOfElements = list.map { pr_str($0, print_readably: print_readably) }.joined(separator: " ") + return "(" + stringOfElements + ")" + case .Vector: + let vector = input as! Vector + let stringOfElements = vector.map { pr_str($0, print_readably: print_readably) }.joined(separator: " ") + return "[" + stringOfElements + "]" + case .HashMap: + let hashMap = input as! [String: MalData] + let stringOfElements = hashMap.map { (key, value) in + pr_str(key, print_readably: print_readably) + " " + pr_str(value, print_readably: print_readably) + }.joined(separator: " ") + return "{" + stringOfElements + "}" + case .Atom: + return pr_str("(atom \((input as! Atom).value))", print_readably: false) + case .Function: + return "#" + default: + return "error type!" + } +} diff --git a/impls/swift4/Sources/reader.swift b/impls/swift4/Sources/reader.swift index 44d3041b38..d405e989c6 100644 --- a/impls/swift4/Sources/reader.swift +++ b/impls/swift4/Sources/reader.swift @@ -1,147 +1,147 @@ - -import Foundation - -struct Reader { - let tokens: [String] - var position = 0 - - init(tokens: [String]) { - self.tokens = tokens - } - - mutating func next() -> String? { - guard tokens.indices.contains(position) else { - return nil - } - position += 1 - return tokens[position - 1] - } - - func peak() -> String? { - guard tokens.indices.contains(position) else { - return nil - } - return tokens[position] - } - - mutating func pass() { - guard tokens.indices.contains(position) else { - return - } - position += 1 - } - - mutating func read_form() throws -> MalData { - guard let token = peak() else { throw MalError.Error } - switch token { - case "(", "[", "{": - return try read_list(startWith: token) - case "'", "`", "~", "~@", "@": - let readerMacros = ["'": "quote", - "`": "quasiquote", - "~": "unquote", - "~@": "splice-unquote", - "@": "deref"] - pass() // pass the mark - return try [Symbol(readerMacros[token]!), read_form()] - case "^": - pass() // pass the mark - let meta = try read_form() - return try [Symbol("with-meta"), read_form(), meta] - default: - return try read_atom() - } - } - - - mutating func read_list(startWith leftParen: String) throws -> MalData { - pass() // pass the left paren - defer { - pass() // pass the right paren - } - - var list: [MalData] = [] - while ![")", "]", "}"].contains(peak()) { - guard peak() != nil else { - throw MalError.ParensMismatch - } - list.append(try read_form()) - } - - switch (leftParen, peak()) { - case ("(", ")"): - return list - case ("[", "]"): - return Vector(list) - case ("{", "}"): - var hashMap: [String: MalData] = [:] - for index in stride(from: 0, to: list.count, by: 2) { - guard list[index] is String, index+1 < list.count else { throw MalError.Error } - hashMap.updateValue(list[index+1], forKey: list[index] as! String) - } - return hashMap - default: - throw MalError.ParensMismatch - } - } - - mutating func read_atom() throws -> MalData { - let token = next()! - let regexInt = "^-?[0-9]+$" - let regexString = "\"(?:\\\\.|[^\\\\\"])*\"" - let regexStringUnbalanced = "\"(?:\\\\.|[^\\\\\"])*" - let regexKeyword = "^:" - func match(string: String, regex: String) -> Bool { - return token.range(of: regex, options: .regularExpression, range: token.startIndex.. [String] { - guard let regex = try? NSRegularExpression(pattern: "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}()'\"`@,;]+)", options: .useUnixLineSeparators) - else { return [] } - let matches = regex.matches(in: input, range: NSMakeRange(0, input.count)) - - return matches.map { match in - String(input[Range(match.range(at: 1), in: input)!]) - }.filter { token in - !token.hasPrefix(";") && !token.isEmpty } -} - - -func read_str(_ input: String) throws -> MalData { - let tokens = tokenizer(input) - guard tokens.count>0 else { - throw MalError.EmptyData - } - var reader = Reader(tokens: tokens) - return try reader.read_form() -} - - - - - + +import Foundation + +struct Reader { + let tokens: [String] + var position = 0 + + init(tokens: [String]) { + self.tokens = tokens + } + + mutating func next() -> String? { + guard tokens.indices.contains(position) else { + return nil + } + position += 1 + return tokens[position - 1] + } + + func peak() -> String? { + guard tokens.indices.contains(position) else { + return nil + } + return tokens[position] + } + + mutating func pass() { + guard tokens.indices.contains(position) else { + return + } + position += 1 + } + + mutating func read_form() throws -> MalData { + guard let token = peak() else { throw MalError.Error } + switch token { + case "(", "[", "{": + return try read_list(startWith: token) + case "'", "`", "~", "~@", "@": + let readerMacros = ["'": "quote", + "`": "quasiquote", + "~": "unquote", + "~@": "splice-unquote", + "@": "deref"] + pass() // pass the mark + return try [Symbol(readerMacros[token]!), read_form()] + case "^": + pass() // pass the mark + let meta = try read_form() + return try [Symbol("with-meta"), read_form(), meta] + default: + return try read_atom() + } + } + + + mutating func read_list(startWith leftParen: String) throws -> MalData { + pass() // pass the left paren + defer { + pass() // pass the right paren + } + + var list: [MalData] = [] + while ![")", "]", "}"].contains(peak()) { + guard peak() != nil else { + throw MalError.ParensMismatch + } + list.append(try read_form()) + } + + switch (leftParen, peak()) { + case ("(", ")"): + return list + case ("[", "]"): + return Vector(list) + case ("{", "}"): + var hashMap: [String: MalData] = [:] + for index in stride(from: 0, to: list.count, by: 2) { + guard list[index] is String, index+1 < list.count else { throw MalError.Error } + hashMap.updateValue(list[index+1], forKey: list[index] as! String) + } + return hashMap + default: + throw MalError.ParensMismatch + } + } + + mutating func read_atom() throws -> MalData { + let token = next()! + let regexInt = "^-?[0-9]+$" + let regexString = "\"(?:\\\\.|[^\\\\\"])*\"" + let regexStringUnbalanced = "\"(?:\\\\.|[^\\\\\"])*" + let regexKeyword = "^:" + func match(string: String, regex: String) -> Bool { + return token.range(of: regex, options: .regularExpression, range: token.startIndex.. [String] { + guard let regex = try? NSRegularExpression(pattern: "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:[\\\\].|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}()'\"`@,;]+)", options: .useUnixLineSeparators) + else { return [] } + let matches = regex.matches(in: input, range: NSMakeRange(0, input.count)) + + return matches.map { match in + String(input[Range(match.range(at: 1), in: input)!]) + }.filter { token in + !token.hasPrefix(";") && !token.isEmpty } +} + + +func read_str(_ input: String) throws -> MalData { + let tokens = tokenizer(input) + guard tokens.count>0 else { + throw MalError.EmptyData + } + var reader = Reader(tokens: tokens) + return try reader.read_form() +} + + + + + diff --git a/impls/swift4/Sources/step0_repl/main.swift b/impls/swift4/Sources/step0_repl/main.swift index f725a995b6..f2062c8d15 100644 --- a/impls/swift4/Sources/step0_repl/main.swift +++ b/impls/swift4/Sources/step0_repl/main.swift @@ -1,27 +1,27 @@ - -import Foundation - -func READ(_ input:String) -> String { - return input -} - -func EVAL(_ input:String) -> String { - return input -} - -func PRINT(_ input:String) -> String { - return input -} - -@discardableResult func rep(_ input:String) -> String { - return PRINT(EVAL(READ(input))) -} - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - print(rep(input)) - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input:String) -> String { + return input +} + +func EVAL(_ input:String) -> String { + return input +} + +func PRINT(_ input:String) -> String { + return input +} + +@discardableResult func rep(_ input:String) -> String { + return PRINT(EVAL(READ(input))) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + print(rep(input)) + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/step1_read_print/main.swift b/impls/swift4/Sources/step1_read_print/main.swift index 187cbaedff..a3a4a65bd0 100644 --- a/impls/swift4/Sources/step1_read_print/main.swift +++ b/impls/swift4/Sources/step1_read_print/main.swift @@ -1,33 +1,33 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func EVAL(_ input: MalData) throws -> MalData { - return input -} - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String) throws -> String { - return try PRINT(EVAL(READ(input))) -} - - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input)) - } catch let error as MalError { - print(error.info()) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ input: MalData) throws -> MalData { + return input +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String) throws -> String { + return try PRINT(EVAL(READ(input))) +} + + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input)) + } catch let error as MalError { + print(error.info()) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/step2_eval/main.swift b/impls/swift4/Sources/step2_eval/main.swift index e2f4fd2333..3adf60df89 100644 --- a/impls/swift4/Sources/step2_eval/main.swift +++ b/impls/swift4/Sources/step2_eval/main.swift @@ -1,80 +1,80 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func EVAL(_ ast: MalData, env: [String: MalData]) throws -> MalData { - switch ast.dataType { - case .Vector: - let vector = ast as! ContiguousArray - return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) - case .List: - let list = ast as! [MalData] - if list.isEmpty { return list } - let evaluated = try eval_ast(list, env: env) as! [MalData] - if let function = evaluated[0] as? Function { - return try function.fn(List(evaluated.dropFirst())) - } else { - throw MalError.SymbolNotFound(list[0] as! Symbol) - } - case .HashMap: - let hashMap = ast as! HashMap - return try hashMap.mapValues { value in try EVAL(value, env: env) } - default: - return try eval_ast(ast, env: env) - } -} - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String) throws -> String{ - func calculate(_ args: [MalData], op: (Number, Number) -> Number) throws -> MalData { - guard args.count == 2, args[0] is Number, args[1] is Number else { throw MalError.InvalidArgument } - return op(args[0] as! Number, args[1] as! Number) - } - - let repl_env = ["+": Function(fn: { args in try calculate(args, op: +) }), - "-": Function(fn: { args in try calculate(args, op: -) }), - "*": Function(fn: { args in try calculate(args, op: *) }), - "/": Function(fn: { args in try calculate(args, op: /) })] - - return try PRINT(EVAL(READ(input), env: repl_env)) -} - -func eval_ast(_ ast: MalData, env: [String: MalData]) throws -> MalData { - switch ast.dataType { - case .Symbol: - let sym = ast as! Symbol - if let function = env[sym.name] { - return function - } else { - throw MalError.SymbolNotFound(sym) - } - case .List: - let list = ast as! [MalData] - return try list.map { element in try EVAL(element, env: env) } - default: - return ast - } -} - - - - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input)) - } catch let error as MalError { - print(error.info()) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ ast: MalData, env: [String: MalData]) throws -> MalData { + switch ast.dataType { + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .List: + let list = ast as! [MalData] + if list.isEmpty { return list } + let evaluated = try eval_ast(list, env: env) as! [MalData] + if let function = evaluated[0] as? Function { + return try function.fn(List(evaluated.dropFirst())) + } else { + throw MalError.SymbolNotFound(list[0] as! Symbol) + } + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String) throws -> String{ + func calculate(_ args: [MalData], op: (Number, Number) -> Number) throws -> MalData { + guard args.count == 2, args[0] is Number, args[1] is Number else { throw MalError.InvalidArgument } + return op(args[0] as! Number, args[1] as! Number) + } + + let repl_env = ["+": Function(fn: { args in try calculate(args, op: +) }), + "-": Function(fn: { args in try calculate(args, op: -) }), + "*": Function(fn: { args in try calculate(args, op: *) }), + "/": Function(fn: { args in try calculate(args, op: /) })] + + return try PRINT(EVAL(READ(input), env: repl_env)) +} + +func eval_ast(_ ast: MalData, env: [String: MalData]) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = env[sym.name] { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + default: + return ast + } +} + + + + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input)) + } catch let error as MalError { + print(error.info()) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/step3_env/main.swift b/impls/swift4/Sources/step3_env/main.swift index 159cba0127..d92066407f 100644 --- a/impls/swift4/Sources/step3_env/main.swift +++ b/impls/swift4/Sources/step3_env/main.swift @@ -1,96 +1,96 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func EVAL(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Vector: - let vector = ast as! ContiguousArray - return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) - case .List: - let list = ast as! [MalData] - guard !list.isEmpty else { return list } - guard let sym = list[0] as? Symbol else { throw MalError.Error } - - switch sym.name { - case "def!": - let value = try EVAL(list[2], env: env), key = list[1] as! Symbol - env.set(value, forKey: key) - return value - case "let*": - let newEnv = Env(outer: env), expr = list[2] - let bindings = (list[1] is Vector) ? List(list[1] as! Vector) : list[1] as! List - for i in stride(from: 0, to: bindings.count-1, by: 2) { - let key = bindings[i], value = bindings[i+1] - let result = try EVAL(value, env: newEnv) - newEnv.set(result, forKey: key as! Symbol) - } - return try EVAL(expr, env: newEnv) - default: - let evaluated = try eval_ast(list, env: env) as! [MalData] - if let function = evaluated[0] as? Function { - return try function.fn(List(evaluated.dropFirst())) - } else { - throw MalError.SymbolNotFound(list[0] as! Symbol) - } - } - case .HashMap: - let hashMap = ast as! HashMap - return try hashMap.mapValues { value in try EVAL(value, env: env) } - default: - return try eval_ast(ast, env: env) - } -} - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String, env: Env) throws -> String { - - return try PRINT(EVAL(READ(input), env: env)) -} - -func eval_ast(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Symbol: - let sym = ast as! Symbol - if let function = try? env.get(forKey: sym) { - return function - } else { - throw MalError.SymbolNotFound(sym) - } - case .List: - let list = ast as! [MalData] - return try list.map { element in try EVAL(element, env: env) } - default: - return ast - } -} - -func calculate(_ args: [MalData], op: (Number, Number) -> Number) throws -> MalData { - guard args.count == 2, args[0] is Number, args[1] is Number else { throw MalError.InvalidArgument } - return op(args[0] as! Number, args[1] as! Number) -} -let repl_env = Env() -repl_env.set(Function(fn: { args in try calculate(args, op: +) }), forKey: Symbol("+")) -repl_env.set(Function(fn: { args in try calculate(args, op: -) }), forKey: Symbol("-")) -repl_env.set(Function(fn: { args in try calculate(args, op: *) }), forKey: Symbol("*")) -repl_env.set(Function(fn: { args in try calculate(args, op: /) }), forKey: Symbol("/")) - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input, env: repl_env)) - } catch let error as MalError { - print(error.info()) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + guard let sym = list[0] as? Symbol else { throw MalError.Error } + + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = (list[1] is Vector) ? List(list[1] as! Vector) : list[1] as! List + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + return try EVAL(expr, env: newEnv) + default: + let evaluated = try eval_ast(list, env: env) as! [MalData] + if let function = evaluated[0] as? Function { + return try function.fn(List(evaluated.dropFirst())) + } else { + throw MalError.SymbolNotFound(list[0] as! Symbol) + } + } + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + default: + return ast + } +} + +func calculate(_ args: [MalData], op: (Number, Number) -> Number) throws -> MalData { + guard args.count == 2, args[0] is Number, args[1] is Number else { throw MalError.InvalidArgument } + return op(args[0] as! Number, args[1] as! Number) +} +let repl_env = Env() +repl_env.set(Function(fn: { args in try calculate(args, op: +) }), forKey: Symbol("+")) +repl_env.set(Function(fn: { args in try calculate(args, op: -) }), forKey: Symbol("-")) +repl_env.set(Function(fn: { args in try calculate(args, op: *) }), forKey: Symbol("*")) +repl_env.set(Function(fn: { args in try calculate(args, op: /) }), forKey: Symbol("/")) + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/step4_if_fn_do/main.swift b/impls/swift4/Sources/step4_if_fn_do/main.swift index 51dc7c0642..b7667737be 100644 --- a/impls/swift4/Sources/step4_if_fn_do/main.swift +++ b/impls/swift4/Sources/step4_if_fn_do/main.swift @@ -1,110 +1,110 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func EVAL(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Vector: - let vector = ast as! ContiguousArray - return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) - case .List: - let list = ast as! [MalData] - guard !list.isEmpty else { return list } - if let sym = list[0] as? Symbol { - switch sym.name { - case "def!": - let value = try EVAL(list[2], env: env), key = list[1] as! Symbol - env.set(value, forKey: key) - return value - case "let*": - let newEnv = Env(outer: env), expr = list[2] - let bindings = (list[1] is Vector) ? List(list[1] as! Vector) : list[1] as! List - for i in stride(from: 0, to: bindings.count-1, by: 2) { - let key = bindings[i], value = bindings[i+1] - let result = try EVAL(value, env: newEnv) - newEnv.set(result, forKey: key as! Symbol) - } - return try EVAL(expr, env: newEnv) - case "do": - return try list.dropFirst().map { try EVAL($0, env: env) }.last ?? Nil() - case "if": - let predicate = try EVAL(list[1], env: env) - if predicate as? Bool == false || predicate is Nil { - return list.count>3 ? try EVAL(list[3], env: env) : Nil() - } else { - return try EVAL(list[2], env: env) - } - case "fn*": - let ops = {(params: [MalData]) -> MalData in - let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) - return try EVAL(list[2], env: newEnv) - } - return Function(fn: ops) - default: - break - } - } - // not a symbol. maybe: function, list, or some wrong type - let evaluated = try eval_ast(list, env: env) as! [MalData] - if let function = evaluated[0] as? Function { - return try function.fn(List(evaluated.dropFirst())) - } else { - throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) - } - case .HashMap: - let hashMap = ast as! HashMap - return try hashMap.mapValues { value in try EVAL(value, env: env) } - default: - return try eval_ast(ast, env: env) - } -} - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String, env: Env) throws -> String { - - return try PRINT(EVAL(READ(input), env: env)) -} - -func eval_ast(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Symbol: - let sym = ast as! Symbol - if let function = try? env.get(forKey: sym) { - return function - } else { - throw MalError.SymbolNotFound(sym) - } - case .List: - let list = ast as! [MalData] - return try list.map { element in try EVAL(element, env: env) } - default: - return ast - } -} - - -var repl_env = Env() -for (key, value) in ns { - repl_env.set(Function(fn: value), forKey: Symbol(key)) -} -try _ = rep("(def! not (fn* (a) (if a false true)))", env: repl_env) - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input, env: repl_env)) - } catch let error as MalError { - print(error.info()) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = (list[1] is Vector) ? List(list[1] as! Vector) : list[1] as! List + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + return try EVAL(expr, env: newEnv) + case "do": + return try list.dropFirst().map { try EVAL($0, env: env) }.last ?? Nil() + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + return list.count>3 ? try EVAL(list[3], env: env) : Nil() + } else { + return try EVAL(list[2], env: env) + } + case "fn*": + let ops = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(fn: ops) + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + if let function = evaluated[0] as? Function { + return try function.fn(List(evaluated.dropFirst())) + } else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + default: + return ast + } +} + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +try _ = rep("(def! not (fn* (a) (if a false true)))", env: repl_env) + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/step5_tco/main.swift b/impls/swift4/Sources/step5_tco/main.swift index 5c29f067f5..c610581177 100644 --- a/impls/swift4/Sources/step5_tco/main.swift +++ b/impls/swift4/Sources/step5_tco/main.swift @@ -1,139 +1,139 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { - var ast = anAst, env = anEnv - while true { - switch ast.dataType { - case .List: - let list = ast as! [MalData] - guard !list.isEmpty else { return list } - if let sym = list[0] as? Symbol { - switch sym.name { - case "def!": - let value = try EVAL(list[2], env: env), key = list[1] as! Symbol - env.set(value, forKey: key) - return value - case "let*": - let newEnv = Env(outer: env), expr = list[2] - let bindings = list[1].listForm - for i in stride(from: 0, to: bindings.count-1, by: 2) { - let key = bindings[i], value = bindings[i+1] - let result = try EVAL(value, env: newEnv) - newEnv.set(result, forKey: key as! Symbol) - } - env = newEnv - ast = expr - continue - case "do": - try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } - ast = list.last ?? Nil() - continue - case "if": - let predicate = try EVAL(list[1], env: env) - if predicate as? Bool == false || predicate is Nil { - ast = list.count>3 ? list[3] : Nil() - } else { - ast = list[2] - } - continue - case "fn*": - let fn = {(params: [MalData]) -> MalData in - let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) - return try EVAL(list[2], env: newEnv) - } - return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) - - default: - break - } - } - // not a symbol. maybe: function, list, or some wrong type - let evaluated = try eval_ast(list, env: env) as! [MalData] - guard let function = evaluated[0] as? Function else { - throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) - } - if let fnAst = function.ast { // a full fn - ast = fnAst - env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) - } else { // normal function - return try function.fn(evaluated.dropFirst().listForm) - } - continue -/* fn 的尾递归优化 -fn 的语法形式： （（fn （a，b）（+ a b ）） 1 2） 形参，函数体，实参 -fn 本来的实现。 - 1.生成：制造一个闭包 - 1.1 闭包的功能：读入实参， 建立 形参=实参 的环境，在这个环境中 求值函数体 - 1.2 闭包本身不带有环境，当求值闭包时使用当时的环境 - 2.使用： - 以使用时的环境，使用实参调用闭包，闭包的返回值作为返回值。over （一次函数调用） -fn 的 TCO 实现。 - 1.生成: 形参 函数体 闭包（闭包包含最初的形参和函数体）+ 生成fn时的环境 - 2.使用： - 取出 函数体， - 使用求值时的形参，以 fn 中的 env 为外层 env 建立环境 （） - 通过循环，在新建的环境中求值函数体 - */ - case .Vector: - let vector = ast as! ContiguousArray - return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) - case .HashMap: - let hashMap = ast as! HashMap - return try hashMap.mapValues { value in try EVAL(value, env: env) } - default: - return try eval_ast(ast, env: env) - } - } -} - - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String, env: Env) throws -> String { - return try PRINT(EVAL(READ(input), env: env)) -} - -func eval_ast(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Symbol: - let sym = ast as! Symbol - if let function = try? env.get(forKey: sym) { - return function - } else { - throw MalError.SymbolNotFound(sym) - } - case .List: - let list = ast as! [MalData] - return try list.map { element in try EVAL(element, env: env) } - default: - return ast - } -} - - -var repl_env = Env() -for (key, value) in ns { - repl_env.set(Function(fn: value), forKey: Symbol(key)) -} -try _ = rep("(def! not (fn* (a) (if a false true)))", env: repl_env) - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input, env: repl_env)) - } catch let error as MalError { - print(error.info()) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue +/* fn 的尾递归优化 +fn 的语法形式： （（fn （a，b）（+ a b ）） 1 2） 形参，函数体，实参 +fn 本来的实现。 + 1.生成：制造一个闭包 + 1.1 闭包的功能：读入实参， 建立 形参=实参 的环境，在这个环境中 求值函数体 + 1.2 闭包本身不带有环境，当求值闭包时使用当时的环境 + 2.使用： + 以使用时的环境，使用实参调用闭包，闭包的返回值作为返回值。over （一次函数调用） +fn 的 TCO 实现。 + 1.生成: 形参 函数体 闭包（闭包包含最初的形参和函数体）+ 生成fn时的环境 + 2.使用： + 取出 函数体， + 使用求值时的形参，以 fn 中的 env 为外层 env 建立环境 （） + 通过循环，在新建的环境中求值函数体 + */ + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + default: + return ast + } +} + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +try _ = rep("(def! not (fn* (a) (if a false true)))", env: repl_env) + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/step6_file/main.swift b/impls/swift4/Sources/step6_file/main.swift index 6a20514e82..c33b741c96 100644 --- a/impls/swift4/Sources/step6_file/main.swift +++ b/impls/swift4/Sources/step6_file/main.swift @@ -1,138 +1,138 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { - var ast = anAst, env = anEnv - while true { - switch ast.dataType { - case .List: - let list = ast as! [MalData] - guard !list.isEmpty else { return list } - if let sym = list[0] as? Symbol { - switch sym.name { - case "def!": - let value = try EVAL(list[2], env: env), key = list[1] as! Symbol - env.set(value, forKey: key) - return value - case "let*": - let newEnv = Env(outer: env), expr = list[2] - let bindings = list[1].listForm - for i in stride(from: 0, to: bindings.count-1, by: 2) { - let key = bindings[i], value = bindings[i+1] - let result = try EVAL(value, env: newEnv) - newEnv.set(result, forKey: key as! Symbol) - } - env = newEnv - ast = expr - continue - case "do": - try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } - ast = list.last ?? Nil() - continue - case "if": - let predicate = try EVAL(list[1], env: env) - if predicate as? Bool == false || predicate is Nil { - ast = list.count>3 ? list[3] : Nil() - } else { - ast = list[2] - } - continue - case "fn*": - let fn = {(params: [MalData]) -> MalData in - let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) - return try EVAL(list[2], env: newEnv) - } - return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) - - default: - break - } - } - // not a symbol. maybe: function, list, or some wrong type - let evaluated = try eval_ast(list, env: env) as! [MalData] - guard let function = evaluated[0] as? Function else { - throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) - } - if let fnAst = function.ast { // a full fn - ast = fnAst - env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) - } else { // normal function - return try function.fn(evaluated.dropFirst().listForm) - } - continue - case .Vector: - let vector = ast as! ContiguousArray - return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) - case .HashMap: - let hashMap = ast as! HashMap - return try hashMap.mapValues { value in try EVAL(value, env: env) } - default: - return try eval_ast(ast, env: env) - } - } -} - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String, env: Env) throws -> String { - return try PRINT(EVAL(READ(input), env: env)) -} - -func eval_ast(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Symbol: - let sym = ast as! Symbol - if let function = try? env.get(forKey: sym) { - return function - } else { - throw MalError.SymbolNotFound(sym) - } - case .List: - let list = ast as! [MalData] - return try list.map { element in try EVAL(element, env: env) } - case .Atom: - return (ast as! Atom).value - default: - return ast - } -} - - - -var repl_env = Env() -for (key, value) in ns { - repl_env.set(Function(fn: value), forKey: Symbol(key)) -} -repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) -repl_env.set([], forKey: Symbol("*ARGV*")) - -try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) -try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) - -if CommandLine.argc > 1 { - let fileName = CommandLine.arguments[1], - args = List(CommandLine.arguments.dropFirst(2)) - repl_env.set(args, forKey: Symbol("*ARGV*")) - try rep("(load-file \"\(fileName)\")", env: repl_env) - exit(0) -} - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input, env: repl_env)) - } catch let error as MalError { - print(error.info()) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/step7_quote/main.swift b/impls/swift4/Sources/step7_quote/main.swift index a5e7a3eb29..297702b7df 100644 --- a/impls/swift4/Sources/step7_quote/main.swift +++ b/impls/swift4/Sources/step7_quote/main.swift @@ -1,186 +1,186 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func starts_with(_ ast: MalData, _ sym: String) -> MalData? { - if let list = ast as? [MalData], - 2 == list.count, - let a0 = list[0] as? Symbol, - a0.name == sym { - return list[1] - } else { - return nil - } -} - -func qqIter(_ lst: [MalData]) -> MalData { - var result:MalData = [] - for elt in lst.reversed() { - if let x = starts_with(elt, "splice-unquote") { - result = [Symbol("concat"), x, result] - } else { - result = [Symbol("cons"), quasiquote(elt), result] - } - } - return result -} - -func quasiquote(_ ast: MalData) -> MalData { - switch ast.dataType { - case .List: - if let x = starts_with(ast, "unquote") { - return x - } else { - return qqIter (ast.listForm) - } - case .Vector: - return [Symbol("vec"), qqIter (ast.listForm)] - case .Symbol: - return [Symbol("quote"), ast] - case .HashMap: - return [Symbol("quote"), ast] - default: - return ast - } -} - -func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { - var ast = anAst, env = anEnv - while true { - switch ast.dataType { - case .List: - let list = ast as! [MalData] - guard !list.isEmpty else { return list } - if let sym = list[0] as? Symbol { - switch sym.name { - case "def!": - let value = try EVAL(list[2], env: env), key = list[1] as! Symbol - env.set(value, forKey: key) - return value - case "let*": - let newEnv = Env(outer: env), expr = list[2] - let bindings = list[1].listForm - for i in stride(from: 0, to: bindings.count-1, by: 2) { - let key = bindings[i], value = bindings[i+1] - let result = try EVAL(value, env: newEnv) - newEnv.set(result, forKey: key as! Symbol) - } - env = newEnv - ast = expr - continue - case "do": - try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } - ast = list.last ?? Nil() - continue - case "if": - let predicate = try EVAL(list[1], env: env) - if predicate as? Bool == false || predicate is Nil { - ast = list.count>3 ? list[3] : Nil() - } else { - ast = list[2] - } - continue - case "fn*": - let fn = {(params: [MalData]) -> MalData in - let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) - return try EVAL(list[2], env: newEnv) - } - return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) - case "quote": - return list[1] - case "quasiquoteexpand": - return quasiquote(list[1]) - case "quasiquote": - ast = quasiquote(list[1]) - continue - default: - break - } - } - // not a symbol. maybe: function, list, or some wrong type - let evaluated = try eval_ast(list, env: env) as! [MalData] - guard let function = evaluated[0] as? Function else { - throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) - } - if let fnAst = function.ast { // a full fn - ast = fnAst - env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) - } else { // normal function - return try function.fn(evaluated.dropFirst().listForm) - } - continue - case .Vector: - let vector = ast as! ContiguousArray - return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) - case .HashMap: - let hashMap = ast as! HashMap - return try hashMap.mapValues { value in try EVAL(value, env: env) } - default: - return try eval_ast(ast, env: env) - } - } -} - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String, env: Env) throws -> String { - return try PRINT(EVAL(READ(input), env: env)) -} - -func eval_ast(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Symbol: - let sym = ast as! Symbol - if let function = try? env.get(forKey: sym) { - return function - } else { - throw MalError.SymbolNotFound(sym) - } - case .List: - let list = ast as! [MalData] - return try list.map { element in try EVAL(element, env: env) } - case .Atom: - return (ast as! Atom).value - default: - return ast - } -} - - - -var repl_env = Env() -for (key, value) in ns { - repl_env.set(Function(fn: value), forKey: Symbol(key)) -} -repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) -repl_env.set([], forKey: Symbol("*ARGV*")) - -try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) -try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) - -if CommandLine.argc > 1 { - let fileName = CommandLine.arguments[1], - args = List(CommandLine.arguments.dropFirst(2)) - repl_env.set(args, forKey: Symbol("*ARGV*")) - try rep("(load-file \"\(fileName)\")", env: repl_env) - exit(0) -} - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input, env: repl_env)) - } catch let error as MalError { - print(error.info()) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func starts_with(_ ast: MalData, _ sym: String) -> MalData? { + if let list = ast as? [MalData], + 2 == list.count, + let a0 = list[0] as? Symbol, + a0.name == sym { + return list[1] + } else { + return nil + } +} + +func qqIter(_ lst: [MalData]) -> MalData { + var result:MalData = [] + for elt in lst.reversed() { + if let x = starts_with(elt, "splice-unquote") { + result = [Symbol("concat"), x, result] + } else { + result = [Symbol("cons"), quasiquote(elt), result] + } + } + return result +} + +func quasiquote(_ ast: MalData) -> MalData { + switch ast.dataType { + case .List: + if let x = starts_with(ast, "unquote") { + return x + } else { + return qqIter (ast.listForm) + } + case .Vector: + return [Symbol("vec"), qqIter (ast.listForm)] + case .Symbol: + return [Symbol("quote"), ast] + case .HashMap: + return [Symbol("quote"), ast] + default: + return ast + } +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + let list = ast as! [MalData] + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + case "quote": + return list[1] + case "quasiquoteexpand": + return quasiquote(list[1]) + case "quasiquote": + ast = quasiquote(list[1]) + continue + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/step8_macros/main.swift b/impls/swift4/Sources/step8_macros/main.swift index afd08a4bb4..3727c8cc45 100644 --- a/impls/swift4/Sources/step8_macros/main.swift +++ b/impls/swift4/Sources/step8_macros/main.swift @@ -1,217 +1,217 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func starts_with(_ ast: MalData, _ sym: String) -> MalData? { - if let list = ast as? [MalData], - 2 == list.count, - let a0 = list[0] as? Symbol, - a0.name == sym { - return list[1] - } else { - return nil - } -} - -func qqIter(_ lst: [MalData]) -> MalData { - var result:MalData = [] - for elt in lst.reversed() { - if let x = starts_with(elt, "splice-unquote") { - result = [Symbol("concat"), x, result] - } else { - result = [Symbol("cons"), quasiquote(elt), result] - } - } - return result -} - -func quasiquote(_ ast: MalData) -> MalData { - switch ast.dataType { - case .List: - if let x = starts_with(ast, "unquote") { - return x - } else { - return qqIter (ast.listForm) - } - case .Vector: - return [Symbol("vec"), qqIter (ast.listForm)] - case .Symbol: - return [Symbol("quote"), ast] - case .HashMap: - return [Symbol("quote"), ast] - default: - return ast - } -} - -func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { - func macroexpand(_ anAst: MalData, env: Env) throws -> MalData { - func isMacro_call(_ ast: MalData, env: Env) -> Bool { // not used - if let list = ast as? [MalData], - let symbol = list[0] as? Symbol, - let fn = try? env.get(forKey: symbol) as? Function { - return fn?.isMacro ?? false - } - return false - } - - var ast = anAst - while let list = ast as? [MalData], - let symbol = list[0] as? Symbol, - let fn = try? env.get(forKey: symbol) as? Function, - let isMacro = fn?.isMacro, isMacro == true { - ast = try fn!.fn(List(list.dropFirst())) - } - return ast - } - - /// Apply - var ast = anAst, env = anEnv - while true { - switch ast.dataType { - case .List: - if (ast as! [MalData]).isEmpty { return ast } - ast = try macroexpand(ast, env: env) - guard let list = ast as? [MalData] else { return try eval_ast(ast, env: env) } - guard !list.isEmpty else { return list } - if let sym = list[0] as? Symbol { - switch sym.name { - case "def!": - let value = try EVAL(list[2], env: env), key = list[1] as! Symbol - env.set(value, forKey: key) - return value - case "defmacro!": - let fn = try EVAL(list[2], env: env) as! Function, key = list[1] as! Symbol - let macro = Function(withFunction: fn, isMacro: true) - env.set(macro, forKey: key) - return macro - case "let*": - let newEnv = Env(outer: env), expr = list[2] - let bindings = list[1].listForm - for i in stride(from: 0, to: bindings.count-1, by: 2) { - let key = bindings[i], value = bindings[i+1] - let result = try EVAL(value, env: newEnv) - newEnv.set(result, forKey: key as! Symbol) - } - env = newEnv - ast = expr - continue - case "do": - try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } - ast = list.last ?? Nil() - continue - case "if": - let predicate = try EVAL(list[1], env: env) - if predicate as? Bool == false || predicate is Nil { - ast = list.count>3 ? list[3] : Nil() - } else { - ast = list[2] - } - continue - case "fn*": - let fn = {(params: [MalData]) -> MalData in - let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) - return try EVAL(list[2], env: newEnv) - } - return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) - case "quote": - return list[1] - case "quasiquoteexpand": - return quasiquote(list[1]) - case "quasiquote": - ast = quasiquote(list[1]) - continue - case "macroexpand": - return try macroexpand(list[1], env: env) - default: - break - } - } - // not a symbol. maybe: function, list, or some wrong type - let evaluated = try eval_ast(list, env: env) as! [MalData] - guard let function = evaluated[0] as? Function else { - throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) - } - if let fnAst = function.ast { // a full fn - ast = fnAst - env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) - } else { // normal function - return try function.fn(evaluated.dropFirst().listForm) - } - continue - case .Vector: - let vector = ast as! ContiguousArray - return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) - case .HashMap: - let hashMap = ast as! HashMap - return try hashMap.mapValues { value in try EVAL(value, env: env) } - default: - return try eval_ast(ast, env: env) - } - } -} - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String, env: Env) throws -> String { - return try PRINT(EVAL(READ(input), env: env)) -} - -func eval_ast(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Symbol: - let sym = ast as! Symbol - if let function = try? env.get(forKey: sym) { - return function - } else { - throw MalError.SymbolNotFound(sym) - } - case .List: - let list = ast as! [MalData] - return try list.map { element in try EVAL(element, env: env) } - case .Atom: - return (ast as! Atom).value - default: - return ast - } -} - - - -var repl_env = Env() -for (key, value) in ns { - repl_env.set(Function(fn: value), forKey: Symbol(key)) -} -repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) -repl_env.set([], forKey: Symbol("*ARGV*")) - -try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) -try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) -try 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)))))))", env: repl_env) - -if CommandLine.argc > 1 { - let fileName = CommandLine.arguments[1], - args = List(CommandLine.arguments.dropFirst(2)) - repl_env.set(args, forKey: Symbol("*ARGV*")) - try rep("(load-file \"\(fileName)\")", env: repl_env) - exit(0) -} - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input, env: repl_env)) - } catch let error as MalError { - print(error.info()) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func starts_with(_ ast: MalData, _ sym: String) -> MalData? { + if let list = ast as? [MalData], + 2 == list.count, + let a0 = list[0] as? Symbol, + a0.name == sym { + return list[1] + } else { + return nil + } +} + +func qqIter(_ lst: [MalData]) -> MalData { + var result:MalData = [] + for elt in lst.reversed() { + if let x = starts_with(elt, "splice-unquote") { + result = [Symbol("concat"), x, result] + } else { + result = [Symbol("cons"), quasiquote(elt), result] + } + } + return result +} + +func quasiquote(_ ast: MalData) -> MalData { + switch ast.dataType { + case .List: + if let x = starts_with(ast, "unquote") { + return x + } else { + return qqIter (ast.listForm) + } + case .Vector: + return [Symbol("vec"), qqIter (ast.listForm)] + case .Symbol: + return [Symbol("quote"), ast] + case .HashMap: + return [Symbol("quote"), ast] + default: + return ast + } +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + func macroexpand(_ anAst: MalData, env: Env) throws -> MalData { + func isMacro_call(_ ast: MalData, env: Env) -> Bool { // not used + if let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function { + return fn?.isMacro ?? false + } + return false + } + + var ast = anAst + while let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function, + let isMacro = fn?.isMacro, isMacro == true { + ast = try fn!.fn(List(list.dropFirst())) + } + return ast + } + + /// Apply + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + if (ast as! [MalData]).isEmpty { return ast } + ast = try macroexpand(ast, env: env) + guard let list = ast as? [MalData] else { return try eval_ast(ast, env: env) } + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "defmacro!": + let fn = try EVAL(list[2], env: env) as! Function, key = list[1] as! Symbol + let macro = Function(withFunction: fn, isMacro: true) + env.set(macro, forKey: key) + return macro + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + case "quote": + return list[1] + case "quasiquoteexpand": + return quasiquote(list[1]) + case "quasiquote": + ast = quasiquote(list[1]) + continue + case "macroexpand": + return try macroexpand(list[1], env: env) + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) +try 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)))))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch let error as MalError { + print(error.info()) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/step9_try/main.swift b/impls/swift4/Sources/step9_try/main.swift index 3928329305..872757cce4 100644 --- a/impls/swift4/Sources/step9_try/main.swift +++ b/impls/swift4/Sources/step9_try/main.swift @@ -1,235 +1,235 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func starts_with(_ ast: MalData, _ sym: String) -> MalData? { - if let list = ast as? [MalData], - 2 == list.count, - let a0 = list[0] as? Symbol, - a0.name == sym { - return list[1] - } else { - return nil - } -} - -func qqIter(_ lst: [MalData]) -> MalData { - var result:MalData = [] - for elt in lst.reversed() { - if let x = starts_with(elt, "splice-unquote") { - result = [Symbol("concat"), x, result] - } else { - result = [Symbol("cons"), quasiquote(elt), result] - } - } - return result -} - -func quasiquote(_ ast: MalData) -> MalData { - switch ast.dataType { - case .List: - if let x = starts_with(ast, "unquote") { - return x - } else { - return qqIter (ast.listForm) - } - case .Vector: - return [Symbol("vec"), qqIter (ast.listForm)] - case .Symbol: - return [Symbol("quote"), ast] - case .HashMap: - return [Symbol("quote"), ast] - default: - return ast - } -} - -func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { - func macroexpand(_ anAst: MalData, env: Env) throws -> MalData { - func isMacro_call(_ ast: MalData, env: Env) -> Bool { // not used - if let list = ast as? [MalData], - let symbol = list[0] as? Symbol, - let fn = try? env.get(forKey: symbol) as? Function { - return fn?.isMacro ?? false - } - return false - } - - var ast = anAst - while let list = ast as? [MalData], - let symbol = list[0] as? Symbol, - let fn = try? env.get(forKey: symbol) as? Function, - let isMacro = fn?.isMacro, isMacro == true { - ast = try fn!.fn(List(list.dropFirst())) - } - return ast - } - - /// Apply - var ast = anAst, env = anEnv - while true { - switch ast.dataType { - case .List: - if (ast as! [MalData]).isEmpty { return ast } - ast = try macroexpand(ast, env: env) - guard let list = ast as? [MalData] else { return try eval_ast(ast, env: env) } - guard !list.isEmpty else { return list } - if let sym = list[0] as? Symbol { - switch sym.name { - case "def!": - let value = try EVAL(list[2], env: env), key = list[1] as! Symbol - env.set(value, forKey: key) - return value - case "defmacro!": - let fn = try EVAL(list[2], env: env) as! Function, key = list[1] as! Symbol - let macro = Function(withFunction: fn, isMacro: true) - env.set(macro, forKey: key) - return macro - case "let*": - let newEnv = Env(outer: env), expr = list[2] - let bindings = list[1].listForm - for i in stride(from: 0, to: bindings.count-1, by: 2) { - let key = bindings[i], value = bindings[i+1] - let result = try EVAL(value, env: newEnv) - newEnv.set(result, forKey: key as! Symbol) - } - env = newEnv - ast = expr - continue - case "do": - try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } - ast = list.last ?? Nil() - continue - case "if": - let predicate = try EVAL(list[1], env: env) - if predicate as? Bool == false || predicate is Nil { - ast = list.count>3 ? list[3] : Nil() - } else { - ast = list[2] - } - continue - case "fn*": - let fn = {(params: [MalData]) -> MalData in - let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) - return try EVAL(list[2], env: newEnv) - } - return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) - case "quote": - return list[1] - case "quasiquoteexpand": - return quasiquote(list[1]) - case "quasiquote": - ast = quasiquote(list[1]) - continue - case "macroexpand": - return try macroexpand(list[1], env: env) - case "try*": - do { - return try EVAL(list[1], env: env) - } catch let error as MalError { - if list.count > 2 { - let catchList = list[2] as! [MalData] - let catchEnv = Env(binds: [catchList[1] as! Symbol], exprs:[error.info()] , outer: env) - return try EVAL(catchList[2], env: catchEnv) - } else { - throw error - } - } - default: - break - } - } - // not a symbol. maybe: function, list, or some wrong type - let evaluated = try eval_ast(list, env: env) as! [MalData] - guard let function = evaluated[0] as? Function else { - throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) - } - if let fnAst = function.ast { // a full fn - ast = fnAst - env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) - } else { // normal function - return try function.fn(evaluated.dropFirst().listForm) - } - continue - case .Vector: - let vector = ast as! ContiguousArray - return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) - case .HashMap: - let hashMap = ast as! HashMap - return try hashMap.mapValues { value in try EVAL(value, env: env) } - default: - return try eval_ast(ast, env: env) - } - } -} - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String, env: Env) throws -> String { - return try PRINT(EVAL(READ(input), env: env)) -} - -func eval_ast(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Symbol: - let sym = ast as! Symbol - if let function = try? env.get(forKey: sym) { - return function - } else { - throw MalError.SymbolNotFound(sym) - } - case .List: - let list = ast as! [MalData] - return try list.map { element in try EVAL(element, env: env) } - case .Atom: - return (ast as! Atom).value - default: - return ast - } -} - - - -var repl_env = Env() -for (key, value) in ns { - repl_env.set(Function(fn: value), forKey: Symbol(key)) -} -repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) -repl_env.set([], forKey: Symbol("*ARGV*")) - -try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) -try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) -try 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)))))))", env: repl_env) - -if CommandLine.argc > 1 { - let fileName = CommandLine.arguments[1], - args = List(CommandLine.arguments.dropFirst(2)) - repl_env.set(args, forKey: Symbol("*ARGV*")) - try rep("(load-file \"\(fileName)\")", env: repl_env) - exit(0) -} - -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input, env: repl_env)) - } catch MalError.MalException(let data) { - if let description = data as? String { - print("Exception." + description) - } else if let dic = data as? [String: String], !dic.isEmpty { - print("Exception." + dic.keys.first! + "." + dic.values.first!) - } - } catch let error as MalError { - print((pr_str(error.info(), print_readably: false))) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func starts_with(_ ast: MalData, _ sym: String) -> MalData? { + if let list = ast as? [MalData], + 2 == list.count, + let a0 = list[0] as? Symbol, + a0.name == sym { + return list[1] + } else { + return nil + } +} + +func qqIter(_ lst: [MalData]) -> MalData { + var result:MalData = [] + for elt in lst.reversed() { + if let x = starts_with(elt, "splice-unquote") { + result = [Symbol("concat"), x, result] + } else { + result = [Symbol("cons"), quasiquote(elt), result] + } + } + return result +} + +func quasiquote(_ ast: MalData) -> MalData { + switch ast.dataType { + case .List: + if let x = starts_with(ast, "unquote") { + return x + } else { + return qqIter (ast.listForm) + } + case .Vector: + return [Symbol("vec"), qqIter (ast.listForm)] + case .Symbol: + return [Symbol("quote"), ast] + case .HashMap: + return [Symbol("quote"), ast] + default: + return ast + } +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + func macroexpand(_ anAst: MalData, env: Env) throws -> MalData { + func isMacro_call(_ ast: MalData, env: Env) -> Bool { // not used + if let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function { + return fn?.isMacro ?? false + } + return false + } + + var ast = anAst + while let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function, + let isMacro = fn?.isMacro, isMacro == true { + ast = try fn!.fn(List(list.dropFirst())) + } + return ast + } + + /// Apply + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + if (ast as! [MalData]).isEmpty { return ast } + ast = try macroexpand(ast, env: env) + guard let list = ast as? [MalData] else { return try eval_ast(ast, env: env) } + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "defmacro!": + let fn = try EVAL(list[2], env: env) as! Function, key = list[1] as! Symbol + let macro = Function(withFunction: fn, isMacro: true) + env.set(macro, forKey: key) + return macro + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + case "quote": + return list[1] + case "quasiquoteexpand": + return quasiquote(list[1]) + case "quasiquote": + ast = quasiquote(list[1]) + continue + case "macroexpand": + return try macroexpand(list[1], env: env) + case "try*": + do { + return try EVAL(list[1], env: env) + } catch let error as MalError { + if list.count > 2 { + let catchList = list[2] as! [MalData] + let catchEnv = Env(binds: [catchList[1] as! Symbol], exprs:[error.info()] , outer: env) + return try EVAL(catchList[2], env: catchEnv) + } else { + throw error + } + } + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) +try 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)))))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch MalError.MalException(let data) { + if let description = data as? String { + print("Exception." + description) + } else if let dic = data as? [String: String], !dic.isEmpty { + print("Exception." + dic.keys.first! + "." + dic.values.first!) + } + } catch let error as MalError { + print((pr_str(error.info(), print_readably: false))) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/stepA_mal/main.swift b/impls/swift4/Sources/stepA_mal/main.swift index 07580b3d49..a2c6b655f9 100644 --- a/impls/swift4/Sources/stepA_mal/main.swift +++ b/impls/swift4/Sources/stepA_mal/main.swift @@ -1,238 +1,238 @@ - -import Foundation - -func READ(_ input: String) throws -> MalData { - return try read_str(input) -} - -func starts_with(_ ast: MalData, _ sym: String) -> MalData? { - if let list = ast as? [MalData], - 2 == list.count, - let a0 = list[0] as? Symbol, - a0.name == sym { - return list[1] - } else { - return nil - } -} - -func qqIter(_ lst: [MalData]) -> MalData { - var result:MalData = [] - for elt in lst.reversed() { - if let x = starts_with(elt, "splice-unquote") { - result = [Symbol("concat"), x, result] - } else { - result = [Symbol("cons"), quasiquote(elt), result] - } - } - return result -} - -func quasiquote(_ ast: MalData) -> MalData { - switch ast.dataType { - case .List: - if let x = starts_with(ast, "unquote") { - return x - } else { - return qqIter (ast.listForm) - } - case .Vector: - return [Symbol("vec"), qqIter (ast.listForm)] - case .Symbol: - return [Symbol("quote"), ast] - case .HashMap: - return [Symbol("quote"), ast] - default: - return ast - } -} - -func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { - func macroexpand(_ anAst: MalData, env: Env) throws -> MalData { - func isMacro_call(_ ast: MalData, env: Env) -> Bool { // not used - if let list = ast as? [MalData], - let symbol = list[0] as? Symbol, - let fn = try? env.get(forKey: symbol) as? Function { - return fn?.isMacro ?? false - } - return false - } - - var ast = anAst - while let list = ast as? [MalData], - let symbol = list[0] as? Symbol, - let fn = try? env.get(forKey: symbol) as? Function, - let isMacro = fn?.isMacro, isMacro == true { - ast = try fn!.fn(List(list.dropFirst())) - } - return ast - } - - /// Apply - var ast = anAst, env = anEnv - while true { - switch ast.dataType { - case .List: - if (ast as! [MalData]).isEmpty { return ast } - ast = try macroexpand(ast, env: env) - guard let list = ast as? [MalData] else { return try eval_ast(ast, env: env) } - guard !list.isEmpty else { return list } - if let sym = list[0] as? Symbol { - switch sym.name { - case "def!": - let value = try EVAL(list[2], env: env), key = list[1] as! Symbol - env.set(value, forKey: key) - return value - case "defmacro!": - let fn = try EVAL(list[2], env: env) as! Function, key = list[1] as! Symbol - let macro = Function(withFunction: fn, isMacro: true) - env.set(macro, forKey: key) - return macro - case "let*": - let newEnv = Env(outer: env), expr = list[2] - let bindings = list[1].listForm - for i in stride(from: 0, to: bindings.count-1, by: 2) { - let key = bindings[i], value = bindings[i+1] - let result = try EVAL(value, env: newEnv) - newEnv.set(result, forKey: key as! Symbol) - } - env = newEnv - ast = expr - continue - case "do": - try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } - ast = list.last ?? Nil() - continue - case "if": - let predicate = try EVAL(list[1], env: env) - if predicate as? Bool == false || predicate is Nil { - ast = list.count>3 ? list[3] : Nil() - } else { - ast = list[2] - } - continue - case "fn*": - let fn = {(params: [MalData]) -> MalData in - let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) - return try EVAL(list[2], env: newEnv) - } - return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) - case "quote": - return list[1] - case "quasiquoteexpand": - return quasiquote(list[1]) - case "quasiquote": - ast = quasiquote(list[1]) - continue - case "macroexpand": - return try macroexpand(list[1], env: env) - case "try*": - do { - return try EVAL(list[1], env: env) - } catch let error as MalError { - if list.count > 2 { - let catchList = list[2] as! [MalData] - let catchEnv = Env(binds: [catchList[1] as! Symbol], exprs:[error.info()] , outer: env) - return try EVAL(catchList[2], env: catchEnv) - } else { - throw error - } - } - default: - break - } - } - // not a symbol. maybe: function, list, or some wrong type - let evaluated = try eval_ast(list, env: env) as! [MalData] - guard let function = evaluated[0] as? Function else { - throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) - } - if let fnAst = function.ast { // a full fn - ast = fnAst - env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) - } else { // normal function - return try function.fn(evaluated.dropFirst().listForm) - } - continue - case .Vector: - let vector = ast as! ContiguousArray - return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) - case .HashMap: - let hashMap = ast as! HashMap - return try hashMap.mapValues { value in try EVAL(value, env: env) } - default: - return try eval_ast(ast, env: env) - } - } -} - -func PRINT(_ input: MalData) -> String { - return pr_str(input, print_readably: true) -} - -@discardableResult func rep(_ input: String, env: Env) throws -> String { - return try PRINT(EVAL(READ(input), env: env)) -} - -func eval_ast(_ ast: MalData, env: Env) throws -> MalData { - switch ast.dataType { - case .Symbol: - let sym = ast as! Symbol - if let function = try? env.get(forKey: sym) { - return function - } else { - throw MalError.SymbolNotFound(sym) - } - case .List: - let list = ast as! [MalData] - return try list.map { element in try EVAL(element, env: env) } - case .Atom: - return (ast as! Atom).value - default: - return ast - } -} - - - -var repl_env = Env() -for (key, value) in ns { - repl_env.set(Function(fn: value), forKey: Symbol(key)) -} -repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) -repl_env.set([], forKey: Symbol("*ARGV*")) -repl_env.set("Swift4", forKey: Symbol("*host-language*")) - - -try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) -try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) -try 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)))))))", env: repl_env) - -if CommandLine.argc > 1 { - let fileName = CommandLine.arguments[1], - args = List(CommandLine.arguments.dropFirst(2)) - repl_env.set(args, forKey: Symbol("*ARGV*")) - try rep("(load-file \"\(fileName)\")", env: repl_env) - exit(0) -} - -try rep("(println (str \"Mal [\" *host-language* \"]\"))", env: repl_env) -while true { - print("user> ", terminator: "") - if let input = readLine(strippingNewline: true) { - guard input != "" else { continue } - do { - try print(rep(input, env: repl_env)) - } catch MalError.MalException(let data) { - if let description = data as? String { - print("Exception." + description) - } else if let dic = data as? [String: String], !dic.isEmpty { - print("Exception." + dic.keys.first! + "." + dic.values.first!) - } - } catch let error as MalError { - print((pr_str(error.info(), print_readably: false))) - } - } else { - exit(0); - } -} + +import Foundation + +func READ(_ input: String) throws -> MalData { + return try read_str(input) +} + +func starts_with(_ ast: MalData, _ sym: String) -> MalData? { + if let list = ast as? [MalData], + 2 == list.count, + let a0 = list[0] as? Symbol, + a0.name == sym { + return list[1] + } else { + return nil + } +} + +func qqIter(_ lst: [MalData]) -> MalData { + var result:MalData = [] + for elt in lst.reversed() { + if let x = starts_with(elt, "splice-unquote") { + result = [Symbol("concat"), x, result] + } else { + result = [Symbol("cons"), quasiquote(elt), result] + } + } + return result +} + +func quasiquote(_ ast: MalData) -> MalData { + switch ast.dataType { + case .List: + if let x = starts_with(ast, "unquote") { + return x + } else { + return qqIter (ast.listForm) + } + case .Vector: + return [Symbol("vec"), qqIter (ast.listForm)] + case .Symbol: + return [Symbol("quote"), ast] + case .HashMap: + return [Symbol("quote"), ast] + default: + return ast + } +} + +func EVAL(_ anAst: MalData, env anEnv: Env) throws -> MalData { + func macroexpand(_ anAst: MalData, env: Env) throws -> MalData { + func isMacro_call(_ ast: MalData, env: Env) -> Bool { // not used + if let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function { + return fn?.isMacro ?? false + } + return false + } + + var ast = anAst + while let list = ast as? [MalData], + let symbol = list[0] as? Symbol, + let fn = try? env.get(forKey: symbol) as? Function, + let isMacro = fn?.isMacro, isMacro == true { + ast = try fn!.fn(List(list.dropFirst())) + } + return ast + } + + /// Apply + var ast = anAst, env = anEnv + while true { + switch ast.dataType { + case .List: + if (ast as! [MalData]).isEmpty { return ast } + ast = try macroexpand(ast, env: env) + guard let list = ast as? [MalData] else { return try eval_ast(ast, env: env) } + guard !list.isEmpty else { return list } + if let sym = list[0] as? Symbol { + switch sym.name { + case "def!": + let value = try EVAL(list[2], env: env), key = list[1] as! Symbol + env.set(value, forKey: key) + return value + case "defmacro!": + let fn = try EVAL(list[2], env: env) as! Function, key = list[1] as! Symbol + let macro = Function(withFunction: fn, isMacro: true) + env.set(macro, forKey: key) + return macro + case "let*": + let newEnv = Env(outer: env), expr = list[2] + let bindings = list[1].listForm + for i in stride(from: 0, to: bindings.count-1, by: 2) { + let key = bindings[i], value = bindings[i+1] + let result = try EVAL(value, env: newEnv) + newEnv.set(result, forKey: key as! Symbol) + } + env = newEnv + ast = expr + continue + case "do": + try _ = list.dropFirst().dropLast().map { try EVAL($0, env: env) } + ast = list.last ?? Nil() + continue + case "if": + let predicate = try EVAL(list[1], env: env) + if predicate as? Bool == false || predicate is Nil { + ast = list.count>3 ? list[3] : Nil() + } else { + ast = list[2] + } + continue + case "fn*": + let fn = {(params: [MalData]) -> MalData in + let newEnv = Env(binds: (list[1].listForm as! [Symbol]), exprs: params, outer: env) + return try EVAL(list[2], env: newEnv) + } + return Function(ast: list[2], params: (list[1].listForm as! [Symbol]), env:env , fn: fn) + case "quote": + return list[1] + case "quasiquoteexpand": + return quasiquote(list[1]) + case "quasiquote": + ast = quasiquote(list[1]) + continue + case "macroexpand": + return try macroexpand(list[1], env: env) + case "try*": + do { + return try EVAL(list[1], env: env) + } catch let error as MalError { + if list.count > 2 { + let catchList = list[2] as! [MalData] + let catchEnv = Env(binds: [catchList[1] as! Symbol], exprs:[error.info()] , outer: env) + return try EVAL(catchList[2], env: catchEnv) + } else { + throw error + } + } + default: + break + } + } + // not a symbol. maybe: function, list, or some wrong type + let evaluated = try eval_ast(list, env: env) as! [MalData] + guard let function = evaluated[0] as? Function else { + throw MalError.SymbolNotFound(list[0] as? Symbol ?? Symbol("Symbol")) + } + if let fnAst = function.ast { // a full fn + ast = fnAst + env = Env(binds: function.params!, exprs: evaluated.dropFirst().listForm, outer: function.env!) + } else { // normal function + return try function.fn(evaluated.dropFirst().listForm) + } + continue + case .Vector: + let vector = ast as! ContiguousArray + return try ContiguousArray(vector.map { element in try EVAL(element, env: env) }) + case .HashMap: + let hashMap = ast as! HashMap + return try hashMap.mapValues { value in try EVAL(value, env: env) } + default: + return try eval_ast(ast, env: env) + } + } +} + +func PRINT(_ input: MalData) -> String { + return pr_str(input, print_readably: true) +} + +@discardableResult func rep(_ input: String, env: Env) throws -> String { + return try PRINT(EVAL(READ(input), env: env)) +} + +func eval_ast(_ ast: MalData, env: Env) throws -> MalData { + switch ast.dataType { + case .Symbol: + let sym = ast as! Symbol + if let function = try? env.get(forKey: sym) { + return function + } else { + throw MalError.SymbolNotFound(sym) + } + case .List: + let list = ast as! [MalData] + return try list.map { element in try EVAL(element, env: env) } + case .Atom: + return (ast as! Atom).value + default: + return ast + } +} + + + +var repl_env = Env() +for (key, value) in ns { + repl_env.set(Function(fn: value), forKey: Symbol(key)) +} +repl_env.set(Function(fn: { try EVAL($0[0], env: repl_env) }), forKey: Symbol("eval")) +repl_env.set([], forKey: Symbol("*ARGV*")) +repl_env.set("Swift4", forKey: Symbol("*host-language*")) + + +try rep("(def! not (fn* (a) (if a false true)))", env: repl_env) +try rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env: repl_env) +try 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)))))))", env: repl_env) + +if CommandLine.argc > 1 { + let fileName = CommandLine.arguments[1], + args = List(CommandLine.arguments.dropFirst(2)) + repl_env.set(args, forKey: Symbol("*ARGV*")) + try rep("(load-file \"\(fileName)\")", env: repl_env) + exit(0) +} + +try rep("(println (str \"Mal [\" *host-language* \"]\"))", env: repl_env) +while true { + print("user> ", terminator: "") + if let input = readLine(strippingNewline: true) { + guard input != "" else { continue } + do { + try print(rep(input, env: repl_env)) + } catch MalError.MalException(let data) { + if let description = data as? String { + print("Exception." + description) + } else if let dic = data as? [String: String], !dic.isEmpty { + print("Exception." + dic.keys.first! + "." + dic.values.first!) + } + } catch let error as MalError { + print((pr_str(error.info(), print_readably: false))) + } + } else { + exit(0); + } +} diff --git a/impls/swift4/Sources/types.swift b/impls/swift4/Sources/types.swift index 0686b8dae4..9f8775d3e9 100644 --- a/impls/swift4/Sources/types.swift +++ b/impls/swift4/Sources/types.swift @@ -1,151 +1,151 @@ - -import Foundation - -enum MalDataType: String { - case Number, String, List, Vector, HashMap, Symbol, Keyword, Atom, Nil, True, False, Function, Unknown -} - -protocol MalData { - var dataType: MalDataType { get } - - var count: Int { get } - var listForm: [MalData] { get } -} -extension MalData { - var dataType: MalDataType { // not used - return MalDataType(rawValue: String(describing: type(of: self))) ?? MalDataType.Unknown - } - var count: Int { return 0 } - var listForm: [MalData] { return [] } -} - -typealias Number = Int -typealias List = Array -typealias Vector = ContiguousArray -typealias HashMap = Dictionary - -struct Symbol: MalData { - let dataType = MalDataType.Symbol - let name: String - init(_ name: String) { - self.name = name - } -} - -struct Nil: MalData { - let dataType = MalDataType.Nil -} - -class Atom: MalData { - let dataType = MalDataType.Atom - var value: MalData - init(_ value: MalData) { - self.value = value - } -} - -struct Function: MalData { - let dataType = MalDataType.Function - - let ast: MalData? - let params: [Symbol]? - let env: Env? - let fn: (([MalData]) throws -> MalData) - let isMacro: Bool - let meta: MalData? - - init(ast: MalData? = nil, params: [Symbol]? = nil, env: Env? = nil, isMacro: Bool = false, meta: MalData? = nil, - fn: @escaping ([MalData]) throws -> MalData) { - self.ast = ast - self.params = params - self.env = env - self.isMacro = isMacro - self.fn = fn - self.meta = meta - } - init(withFunction function: Function, isMacro: Bool) { - self.ast = function.ast - self.params = function.params - self.env = function.env - self.fn = function.fn - self.meta = function.meta - self.isMacro = isMacro - } - init(withFunction function: Function, meta: MalData) { - self.ast = function.ast - self.params = function.params - self.env = function.env - self.fn = function.fn - self.isMacro = function.isMacro - self.meta = meta - } - -} - - -extension String: MalData { - var dataType: MalDataType { - return !self.isEmpty && self[startIndex] == "\u{029E}" ? .Keyword : .String } -} -extension Number: MalData { - var dataType: MalDataType { return .Number } -} -extension Bool : MalData { - var dataType: MalDataType { return self == true ? .True : .False } -} - -extension List : MalData { - var dataType: MalDataType { return .List } - var listForm: [MalData] { return self as! [MalData] } -} -extension Vector: MalData { - var dataType: MalDataType { return .Vector } - var listForm: [MalData] { return List(self) as! [MalData] } -} -extension ArraySlice: MalData { - var dataType: MalDataType { return .List } - var listForm: [MalData] { return List(self) as! [MalData] } -} -extension HashMap: MalData { - var dataType: MalDataType { return .HashMap } - static func hashMap(fromList list: [MalData]) throws -> [String: MalData] { - var hashMap: [String: MalData] = [:] - for index in stride(from: 0, to: list.count, by: 2) { - guard list[index] is String, index+1 < list.count else { throw MalError.Error } - hashMap.updateValue(list[index+1], forKey: list[index] as! String) - } - return hashMap - } -} - -// MARK: Errors -enum MalError: Error { - case ParensMismatch - case QuotationMarkMismatch - case EmptyData - case SymbolNotFound(Symbol) - case InvalidArgument - case Error - case IndexOutOfBounds - case MalException(MalData) - func info() -> MalData { - switch self { - case .ParensMismatch: - return "unbalanced parens" - case .QuotationMarkMismatch: - return "unbalanced quotation mark" - case .EmptyData: - return "empty data" - case .InvalidArgument: - return "invalid argument" - case .SymbolNotFound(let symbol): - return "'\(symbol.name)' not found" - case .IndexOutOfBounds: - return "index out of bounds" - case .MalException(let data): - return data - default: - return "uncaught error!" - } - } -} + +import Foundation + +enum MalDataType: String { + case Number, String, List, Vector, HashMap, Symbol, Keyword, Atom, Nil, True, False, Function, Unknown +} + +protocol MalData { + var dataType: MalDataType { get } + + var count: Int { get } + var listForm: [MalData] { get } +} +extension MalData { + var dataType: MalDataType { // not used + return MalDataType(rawValue: String(describing: type(of: self))) ?? MalDataType.Unknown + } + var count: Int { return 0 } + var listForm: [MalData] { return [] } +} + +typealias Number = Int +typealias List = Array +typealias Vector = ContiguousArray +typealias HashMap = Dictionary + +struct Symbol: MalData { + let dataType = MalDataType.Symbol + let name: String + init(_ name: String) { + self.name = name + } +} + +struct Nil: MalData { + let dataType = MalDataType.Nil +} + +class Atom: MalData { + let dataType = MalDataType.Atom + var value: MalData + init(_ value: MalData) { + self.value = value + } +} + +struct Function: MalData { + let dataType = MalDataType.Function + + let ast: MalData? + let params: [Symbol]? + let env: Env? + let fn: (([MalData]) throws -> MalData) + let isMacro: Bool + let meta: MalData? + + init(ast: MalData? = nil, params: [Symbol]? = nil, env: Env? = nil, isMacro: Bool = false, meta: MalData? = nil, + fn: @escaping ([MalData]) throws -> MalData) { + self.ast = ast + self.params = params + self.env = env + self.isMacro = isMacro + self.fn = fn + self.meta = meta + } + init(withFunction function: Function, isMacro: Bool) { + self.ast = function.ast + self.params = function.params + self.env = function.env + self.fn = function.fn + self.meta = function.meta + self.isMacro = isMacro + } + init(withFunction function: Function, meta: MalData) { + self.ast = function.ast + self.params = function.params + self.env = function.env + self.fn = function.fn + self.isMacro = function.isMacro + self.meta = meta + } + +} + + +extension String: MalData { + var dataType: MalDataType { + return !self.isEmpty && self[startIndex] == "\u{029E}" ? .Keyword : .String } +} +extension Number: MalData { + var dataType: MalDataType { return .Number } +} +extension Bool : MalData { + var dataType: MalDataType { return self == true ? .True : .False } +} + +extension List : MalData { + var dataType: MalDataType { return .List } + var listForm: [MalData] { return self as! [MalData] } +} +extension Vector: MalData { + var dataType: MalDataType { return .Vector } + var listForm: [MalData] { return List(self) as! [MalData] } +} +extension ArraySlice: MalData { + var dataType: MalDataType { return .List } + var listForm: [MalData] { return List(self) as! [MalData] } +} +extension HashMap: MalData { + var dataType: MalDataType { return .HashMap } + static func hashMap(fromList list: [MalData]) throws -> [String: MalData] { + var hashMap: [String: MalData] = [:] + for index in stride(from: 0, to: list.count, by: 2) { + guard list[index] is String, index+1 < list.count else { throw MalError.Error } + hashMap.updateValue(list[index+1], forKey: list[index] as! String) + } + return hashMap + } +} + +// MARK: Errors +enum MalError: Error { + case ParensMismatch + case QuotationMarkMismatch + case EmptyData + case SymbolNotFound(Symbol) + case InvalidArgument + case Error + case IndexOutOfBounds + case MalException(MalData) + func info() -> MalData { + switch self { + case .ParensMismatch: + return "unbalanced parens" + case .QuotationMarkMismatch: + return "unbalanced quotation mark" + case .EmptyData: + return "empty data" + case .InvalidArgument: + return "invalid argument" + case .SymbolNotFound(let symbol): + return "'\(symbol.name)' not found" + case .IndexOutOfBounds: + return "index out of bounds" + case .MalException(let data): + return data + default: + return "uncaught error!" + } + } +} diff --git a/impls/swift4/run b/impls/swift4/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/swift4/run +++ b/impls/swift4/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/swift5/.gitignore b/impls/swift5/.gitignore index d0543d7ea1..ad93add9ca 100644 --- a/impls/swift5/.gitignore +++ b/impls/swift5/.gitignore @@ -1,7 +1,7 @@ -.DS_Store -/.build -/out -/Packages -/*.xcodeproj -xcuserdata/ -.swiftpm +.DS_Store +/.build +/out +/Packages +/*.xcodeproj +xcuserdata/ +.swiftpm diff --git a/impls/swift5/Dockerfile b/impls/swift5/Dockerfile index b757d3c32b..23bb9e2e11 100644 --- a/impls/swift5/Dockerfile +++ b/impls/swift5/Dockerfile @@ -1,44 +1,44 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Swift -RUN apt-get -y install clang-3.6 cmake pkg-config \ - git ninja-build uuid-dev libicu-dev icu-devtools \ - libbsd-dev libedit-dev libxml2-dev libsqlite3-dev \ - swig libpython-dev libncurses5-dev - -# TODO: better way to do this? -RUN ln -sf /usr/lib/llvm-3.6/bin/clang++ /usr/bin/clang++ -RUN ln -sf /usr/lib/llvm-3.6/bin/clang /usr/bin/clang - -ENV SWIFT_PREFIX swift-5.1.1-RELEASE -ENV SWIFT_RELEASE ${SWIFT_PREFIX}-ubuntu16.04 - -RUN cd /opt && \ - curl -O https://swift.org/builds/swift-5.1.1-release/ubuntu1604/${SWIFT_PREFIX}/${SWIFT_RELEASE}.tar.gz && \ - tar xvzf ${SWIFT_RELEASE}.tar.gz && \ - rm ${SWIFT_RELEASE}.tar.gz - -ENV PATH /opt/${SWIFT_RELEASE}/usr/bin/:$PATH - - +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Swift +RUN apt-get -y install clang-3.6 cmake pkg-config \ + git ninja-build uuid-dev libicu-dev icu-devtools \ + libbsd-dev libedit-dev libxml2-dev libsqlite3-dev \ + swig libpython-dev libncurses5-dev + +# TODO: better way to do this? +RUN ln -sf /usr/lib/llvm-3.6/bin/clang++ /usr/bin/clang++ +RUN ln -sf /usr/lib/llvm-3.6/bin/clang /usr/bin/clang + +ENV SWIFT_PREFIX swift-5.1.1-RELEASE +ENV SWIFT_RELEASE ${SWIFT_PREFIX}-ubuntu16.04 + +RUN cd /opt && \ + curl -O https://swift.org/builds/swift-5.1.1-release/ubuntu1604/${SWIFT_PREFIX}/${SWIFT_RELEASE}.tar.gz && \ + tar xvzf ${SWIFT_RELEASE}.tar.gz && \ + rm ${SWIFT_RELEASE}.tar.gz + +ENV PATH /opt/${SWIFT_RELEASE}/usr/bin/:$PATH + + diff --git a/impls/swift5/Makefile b/impls/swift5/Makefile index 19f7a97e24..b1b889e743 100644 --- a/impls/swift5/Makefile +++ b/impls/swift5/Makefile @@ -1,9 +1,9 @@ -step%: - mkdir -p ./out - swift build --product $@ - cp "$(shell swift build --show-bin-path)/$@" "./out/$@" - -clean: - rm -rf ./out - rm -rf ./.build - +step%: + mkdir -p ./out + swift build --product $@ + cp "$(shell swift build --show-bin-path)/$@" "./out/$@" + +clean: + rm -rf ./out + rm -rf ./.build + diff --git a/impls/swift5/Package.swift b/impls/swift5/Package.swift index 3f567c4d89..f933cc7d98 100644 --- a/impls/swift5/Package.swift +++ b/impls/swift5/Package.swift @@ -1,42 +1,42 @@ -// swift-tools-version:5.1 -// The swift-tools-version declares the minimum version of Swift required to build this package. - -import PackageDescription - -let package = Package( - name: "mal", - products: [ - // Products define the executables and libraries produced by a package, and make them visible to other packages. - .executable(name: "step0_repl", targets: ["step0_repl"]), - .executable(name: "step1_read_print", targets: ["step1_read_print"]), - .executable(name: "step2_eval", targets: ["step2_eval"]), - .executable(name: "step3_env", targets: ["step3_env"]), - .executable(name: "step4_if_fn_do", targets: ["step4_if_fn_do"]), - .executable(name: "step5_tco", targets: ["step5_tco"]), - .executable(name: "step6_file", targets: ["step6_file"]), - .executable(name: "step7_quote", targets: ["step7_quote"]), - .executable(name: "step8_macros", targets: ["step8_macros"]), - .executable(name: "step9_try", targets: ["step9_try"]), - .executable(name: "stepA_mal", targets: ["stepA_mal"]) - ], - dependencies: [ - // Dependencies declare other packages that this package depends on. - // .package(url: /* package url */, from: "1.0.0"), - ], - targets: [ - // Targets are the basic building blocks of a package. A target can define a module or a test suite. - // Targets can depend on other targets in this package, and on products in packages which this package depends on. - .target(name: "core", dependencies: []), - .target(name: "step0_repl", dependencies: ["core"]), - .target(name: "step1_read_print", dependencies: ["core"]), - .target(name: "step2_eval", dependencies: ["core"]), - .target(name: "step3_env", dependencies: ["core"]), - .target(name: "step4_if_fn_do", dependencies: ["core"]), - .target(name: "step5_tco", dependencies: ["core"]), - .target(name: "step6_file", dependencies: ["core"]), - .target(name: "step7_quote", dependencies: ["core"]), - .target(name: "step8_macros", dependencies: ["core"]), - .target(name: "step9_try", dependencies: ["core"]), - .target(name: "stepA_mal", dependencies: ["core"]) - ] -) +// swift-tools-version:5.1 +// The swift-tools-version declares the minimum version of Swift required to build this package. + +import PackageDescription + +let package = Package( + name: "mal", + products: [ + // Products define the executables and libraries produced by a package, and make them visible to other packages. + .executable(name: "step0_repl", targets: ["step0_repl"]), + .executable(name: "step1_read_print", targets: ["step1_read_print"]), + .executable(name: "step2_eval", targets: ["step2_eval"]), + .executable(name: "step3_env", targets: ["step3_env"]), + .executable(name: "step4_if_fn_do", targets: ["step4_if_fn_do"]), + .executable(name: "step5_tco", targets: ["step5_tco"]), + .executable(name: "step6_file", targets: ["step6_file"]), + .executable(name: "step7_quote", targets: ["step7_quote"]), + .executable(name: "step8_macros", targets: ["step8_macros"]), + .executable(name: "step9_try", targets: ["step9_try"]), + .executable(name: "stepA_mal", targets: ["stepA_mal"]) + ], + dependencies: [ + // Dependencies declare other packages that this package depends on. + // .package(url: /* package url */, from: "1.0.0"), + ], + targets: [ + // Targets are the basic building blocks of a package. A target can define a module or a test suite. + // Targets can depend on other targets in this package, and on products in packages which this package depends on. + .target(name: "core", dependencies: []), + .target(name: "step0_repl", dependencies: ["core"]), + .target(name: "step1_read_print", dependencies: ["core"]), + .target(name: "step2_eval", dependencies: ["core"]), + .target(name: "step3_env", dependencies: ["core"]), + .target(name: "step4_if_fn_do", dependencies: ["core"]), + .target(name: "step5_tco", dependencies: ["core"]), + .target(name: "step6_file", dependencies: ["core"]), + .target(name: "step7_quote", dependencies: ["core"]), + .target(name: "step8_macros", dependencies: ["core"]), + .target(name: "step9_try", dependencies: ["core"]), + .target(name: "stepA_mal", dependencies: ["core"]) + ] +) diff --git a/impls/swift5/Sources/core/Core.swift b/impls/swift5/Sources/core/Core.swift index a30c9f3746..86b8183287 100644 --- a/impls/swift5/Sources/core/Core.swift +++ b/impls/swift5/Sources/core/Core.swift @@ -1,567 +1,567 @@ -import Foundation - -private extension Func { - private static func hashMapDataFrom(_ args: [Expr]) throws -> [String: Expr] { - guard args.count.isMultiple(of: 2) else { throw MalError.invalidArguments() } - - var data: [String: Expr] = [:] - for i in stride(from: 0, to: args.count - 1, by: 2) { - guard case let .string(key) = args[i] else { throw MalError.invalidArguments() } - let value = args[i + 1] - data[key] = value - } - return data - } - - static func intOperation(_ op: @escaping (Int, Int) -> Int) -> Func { - return Func { args in - guard args.count == 2, - case let .number(a) = args[0], - case let .number(b) = args[1] else { throw MalError.invalidArguments() } - - return .number(op(a, b)) - } - } - - static func comparisonOperation(_ op: @escaping (Int, Int) -> Bool) -> Func { - return Func { args in - guard args.count == 2, - case let .number(a) = args[0], - case let .number(b) = args[1] else { throw MalError.invalidArguments() } - - return .bool(op(a, b)) - } - } - - static let prn = Func { args in - let printFunc = curry(Expr.print)(true) - let result = args.map(printFunc).joined(separator: " ") - print(result) - return .null - } - - static let str = Func { args in - let printFunc = curry(Expr.print)(false) - let result = args.map(printFunc).joined(separator: "") - return .string(result) - } - - static let prStr = Func { args in - let printFunc = curry(Expr.print)(true) - let result = args.map(printFunc).joined(separator: " ") - return .string(result) - } - - static let println = Func { args in - let printFunc = curry(Expr.print)(false) - let result = args.map(printFunc).joined(separator: " ") - print(result) - return .null - } - - static let list = Func { args in .list(args) } - - static let isList = Func { args in - if case .list = args.first { - return .bool(true) - } - return .bool(false) - } - - static let isEmpty = Func { args in - switch args.first { - case let .list(xs, _), let .vector(xs, _): - return .bool(xs.isEmpty) - default: - return .bool(false) - } - } - - static let count = Func { args in - switch args.first { - case let .list(xs, _), let .vector(xs, _): - return .number(xs.count) - default: - return .number(0) - } - } - - static let eq = Func { args in - guard args.count == 2 else { throw MalError.invalidArguments("eq") } - return args[0] == args[1] ? .bool(true) : .bool(false) - } - - static let readString = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("read-string") } - guard case let .string(s) = args[0] else { throw MalError.invalidArguments("read-string") } - return try Reader.read(s) - } - - static let slurp = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("slurp") } - guard case let .string(filename) = args[0] else { throw MalError.invalidArguments("slurp") } - return .string(try String(contentsOfFile: filename)) - } - - static let atom = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("atom") } - return .atom(Atom(args[0])) - } - - static let isAtom = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("atom?") } - if case .atom = args[0] { - return .bool(true) - } else { - return .bool(false) - } - } - - static let deref = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("deref") } - guard case let .atom(atom) = args[0] else { throw MalError.invalidArguments("deref") } - return atom.val - } - - static let reset = Func { args in - guard args.count == 2 else { throw MalError.invalidArguments("reset!") } - guard case let .atom(atom) = args[0] else { throw MalError.invalidArguments("reset!") } - atom.val = args[1] - return args[1] - } - - static let swap = Func { args in - guard args.count >= 2 else { throw MalError.invalidArguments("swap!") } - guard case let .atom(atom) = args[0] else { throw MalError.invalidArguments("swap!") } - guard case let .function(fn) = args[1] else { throw MalError.invalidArguments("swap!") } - let otherArgs = args.dropFirst(2) - atom.val = try fn.run([atom.val] + otherArgs) - return atom.val - } - - static let cons = Func { args in - guard args.count == 2 else { throw MalError.invalidArguments("cons") } - switch args[1] { - case let .list(values, _), let .vector(values, _): - return .list([args[0]] + values) - default: - throw MalError.invalidArguments("cons") - } - } - - static let concat = Func { args in - let values = try args.flatMap { el throws -> [Expr] in - switch el { - case let .list(values, _), let .vector(values, _): - return values - default: - throw MalError.invalidArguments("concat") - } - } - return .list(values) - } - - static let vec = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("vec") } - switch args[0] { - case let .list(values, _): - return .vector(values) - case let .vector(values, _): - return args[0] - default: - throw MalError.invalidArguments("vec") - } - } - - static let nth = Func { args in - guard args.count == 2 else { throw MalError.invalidArguments("nth") } - guard case let .number(index) = args[1] else { throw MalError.invalidArguments("nth") } - - switch args.first { - case let .list(values, _), let .vector(values, _): - guard values.indices ~= index else { throw MalError.outOfRange() } - return values[index] - default: - throw MalError.invalidArguments("nth") - } - } - - static let first = Func { args in - switch args.first { - case let .list(values, _), let .vector(values, _): - return values.first ?? .null - case .null: - return .null - default: - throw MalError.invalidArguments("first") - } - } - - static let rest = Func { args in - switch args.first { - case let .list(values, _), let .vector(values, _): - return .list(Array(values.dropFirst())) - case .null: - return .list([]) - default: - throw MalError.invalidArguments("rest") - } - } - - static let `throw` = Func { args in - guard args.count > 0 else { throw MalError.invalidArguments("throw") } - throw args[0] - } - - static let apply = Func { args in - guard args.count >= 2 else { throw MalError.invalidArguments("apply") } - guard case let .function(fn) = args[0] else { throw MalError.invalidArguments("apply") } - - let lastArgs: [Expr] - switch args.last! { - case let .list(values, _), let .vector(values, _): - lastArgs = values - default: - throw MalError.invalidArguments("apply") - } - - - let fnArgs = Array(args.dropFirst().dropLast()) + lastArgs - return try fn.run(fnArgs) - } - - static let map = Func { args in - guard args.count == 2 else { throw MalError.invalidArguments("map") } - guard case let .function(fn) = args[0] else { throw MalError.invalidArguments("map") } - - switch args[1] { - case let .list(values, _), let .vector(values, _): - return .list(try values.map { try fn.run([$0]) }) - default: - throw MalError.invalidArguments("map") - } - } - - static let isNil = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("nil?") } - if case .null = args[0] { - return .bool(true) - } - return .bool(false) - } - - static let isTrue = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("true?") } - if case .bool(true) = args[0] { - return .bool(true) - } - return .bool(false) - } - - static let isFalse = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("false?") } - if case .bool(false) = args[0] { - return .bool(true) - } - return .bool(false) - } - - static let isSymbol = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("symbol?") } - if case .symbol = args[0] { - return .bool(true) - } - return .bool(false) - } - - static let symbol = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("symbol") } - guard case let .string(name) = args[0] else { throw MalError.invalidArguments("symbol") } - return .symbol(name) - } - - static let keyword = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("keyword") } - guard case let .string(name) = args[0] else { throw MalError.invalidArguments("keyword") } - return name.first == keywordMagic - ? .string(name) - : .string(String(keywordMagic) + name) - } - - static let isKeyword = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("keyword?") } - if case let .string(name) = args[0] { - return name.first == keywordMagic ? .bool(true) : .bool(false) - } - return .bool(false) - } - - static let vector = Func { args in - return .vector(args) - } - - static let isVector = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("vector?") } - if case .vector = args[0] { - return .bool(true) - } - return .bool(false) - } - - static let isSequential = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("sequential?") } - switch args[0] { - case .list, .vector: - return .bool(true) - default: - return .bool(false) - } - } - - static let hashmap = Func { args in - return .hashmap(try hashMapDataFrom(args)) - } - - static let isHashmap = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("map?") } - if case .hashmap = args[0] { - return .bool(true) - } - return .bool(false) - } - - static let assoc = Func { args in - guard args.count > 0 else { throw MalError.invalidArguments("assoc") } - guard case let .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("assoc") } - - let newData = try hashMapDataFrom(Array(args.dropFirst())) - return .hashmap(data.merging(newData, uniquingKeysWith: { _, new in new })) - } - - static let dissoc = Func { args in - guard args.count > 0 else { throw MalError.invalidArguments("dissoc") } - guard case var .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("dissoc") } - - for key in args.dropFirst() { - guard case let .string(name) = key else { throw MalError.invalidArguments("dissoc") } - data.removeValue(forKey: name) - } - return .hashmap(data) - } - - static let get = Func { args in - guard args.count == 2 else { throw MalError.invalidArguments("get") } - guard case let .string(key) = args[1] else { throw MalError.invalidArguments("get") } - - switch args[0] { - case let .hashmap(data, _): - return data[key] ?? .null - case .null: - return .null - default: - throw MalError.invalidArguments("get") - } - } - - static let contains = Func { args in - guard args.count == 2 else { throw MalError.invalidArguments("contains?") } - guard case let .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("contains?") } - guard case let .string(key) = args[1] else { throw MalError.invalidArguments("contains?") } - return data.keys.contains(key) ? .bool(true) : .bool(false) - } - - static let keys = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("keys") } - guard case let .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("keys") } - return .list(data.keys.map(Expr.string)) - } - - static let vals = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("vals") } - guard case let .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("vals") } - return .list(Array(data.values)) - } - - static let readline = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("readline") } - guard case let .string(promt) = args[0] else { throw MalError.invalidArguments("readline") } - print(promt, terminator: "") - if let s = readLine() { - return .string(s) - } - return .null - } - - static let timeMs = Func { args in - guard args.count == 0 else { throw MalError.invalidArguments("time-ms") } - return .number(Int(Date().timeIntervalSince1970 * 1000)) - } - - static let isFunction = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("fn?") } - if case let .function(fn) = args[0] { - return .bool(!fn.isMacro) - } - return .bool(false) - } - - static let isMacro = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("macro?") } - if case let .function(fn) = args[0] { - return .bool(fn.isMacro) - } - return .bool(false) - } - - static let isString = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("string?") } - if case let .string(s) = args[0] { - return s.first == keywordMagic ? .bool(false) : .bool(true) - } - return .bool(false) - } - - static let isNumber = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("number?") } - if case .number = args[0] { - return .bool(true) - } - return .bool(false) - } - - static let seq = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("seq") } - - switch args[0] { - case .list([], _), .vector([], _), .string(""), .null: - return .null - case .list: - return args[0] - case let .vector(values, _): - return .list(values) - case let .string(s): - if s.first == keywordMagic { - throw MalError.invalidArguments("seq") - } - return .list(Array(s.map { .string(String($0)) })) - default: - throw MalError.invalidArguments("seq") - } - } - - static let conj = Func { args in - guard args.count > 0 else { throw MalError.invalidArguments("conj") } - switch args[0] { - case let .list(values, _): - return .list(Array(args.dropFirst()).reversed() + values) - case let .vector(values, _): - return .vector(values + Array(args.dropFirst())) - default: - throw MalError.invalidArguments("conj") - } - } - - static let meta = Func { args in - guard args.count == 1 else { throw MalError.invalidArguments("meta") } - switch args[0] { - case let .function(fn): - return fn.meta - case let .list(_, meta): - return meta - case let .vector(_, meta): - return meta - case let .hashmap(_, meta): - return meta - case let .atom(atom): - return atom.meta - default: - throw MalError.invalidArguments("meta") - } - } - - static let withMeta = Func { args in - guard args.count == 2 else { throw MalError.invalidArguments("with-meta") } - switch args[0] { - case let .function(fn): - return .function(fn.withMeta(args[1])) - case let .list(values, _): - return .list(values, args[1]) - case let .vector(values, _): - return .vector(values, args[1]) - case let .hashmap(data, _): - return .hashmap(data, args[1]) - case let .atom(atom): - return .atom(atom.withMeta(args[1])) - default: - throw MalError.invalidArguments("with-meta") - } - } -} - -private let data: [String: Expr] = [ - "+": .function(.intOperation(+)), - "-": .function(.intOperation(-)), - "*": .function(.intOperation(*)), - "/": .function(.intOperation(/)), - "prn": .function(.prn), - "println": .function(.println), - "pr-str": .function(.prStr), - "str": .function(.str), - "list": .function(.list), - "list?": .function(.isList), - "empty?": .function(.isEmpty), - "count": .function(.count), - "=": .function(.eq), - "<": .function(.comparisonOperation(<)), - "<=": .function(.comparisonOperation(<=)), - ">": .function(.comparisonOperation(>)), - ">=": .function(.comparisonOperation(>=)), - "read-string": .function(.readString), - "slurp": .function(.slurp), - "atom": .function(.atom), - "atom?": .function(.isAtom), - "deref": .function(.deref), - "reset!": .function(.reset), - "swap!": .function(.swap), - "cons": .function(.cons), - "concat": .function(.concat), - "vec": .function(.vec), - "nth": .function(.nth), - "first": .function(.first), - "rest": .function(.rest), - "throw": .function(.throw), - "apply": .function(.apply), - "map": .function(.map), - "nil?": .function(.isNil), - "true?": .function(.isTrue), - "false?": .function(.isFalse), - "symbol?": .function(.isSymbol), - "symbol": .function(.symbol), - "keyword": .function(.keyword), - "keyword?": .function(.isKeyword), - "vector": .function(.vector), - "vector?": .function(.isVector), - "sequential?": .function(.isSequential), - "hash-map": .function(.hashmap), - "map?": .function(.isHashmap), - "assoc": .function(.assoc), - "dissoc": .function(.dissoc), - "get": .function(.get), - "contains?": .function(.contains), - "keys": .function(.keys), - "vals": .function(.vals), - "readline": .function(.readline), - "time-ms": .function(.timeMs), - "meta": .function(.meta), - "with-meta": .function(.withMeta), - "fn?": .function(.isFunction), - "macro?": .function(.isMacro), - "string?": .function(.isString), - "number?": .function(.isNumber), - "seq": .function(.seq), - "conj": .function(.conj) -] - -public enum Core { - public static let ns: Env = Env.init(data: data, outer: nil) -} +import Foundation + +private extension Func { + private static func hashMapDataFrom(_ args: [Expr]) throws -> [String: Expr] { + guard args.count.isMultiple(of: 2) else { throw MalError.invalidArguments() } + + var data: [String: Expr] = [:] + for i in stride(from: 0, to: args.count - 1, by: 2) { + guard case let .string(key) = args[i] else { throw MalError.invalidArguments() } + let value = args[i + 1] + data[key] = value + } + return data + } + + static func intOperation(_ op: @escaping (Int, Int) -> Int) -> Func { + return Func { args in + guard args.count == 2, + case let .number(a) = args[0], + case let .number(b) = args[1] else { throw MalError.invalidArguments() } + + return .number(op(a, b)) + } + } + + static func comparisonOperation(_ op: @escaping (Int, Int) -> Bool) -> Func { + return Func { args in + guard args.count == 2, + case let .number(a) = args[0], + case let .number(b) = args[1] else { throw MalError.invalidArguments() } + + return .bool(op(a, b)) + } + } + + static let prn = Func { args in + let printFunc = curry(Expr.print)(true) + let result = args.map(printFunc).joined(separator: " ") + print(result) + return .null + } + + static let str = Func { args in + let printFunc = curry(Expr.print)(false) + let result = args.map(printFunc).joined(separator: "") + return .string(result) + } + + static let prStr = Func { args in + let printFunc = curry(Expr.print)(true) + let result = args.map(printFunc).joined(separator: " ") + return .string(result) + } + + static let println = Func { args in + let printFunc = curry(Expr.print)(false) + let result = args.map(printFunc).joined(separator: " ") + print(result) + return .null + } + + static let list = Func { args in .list(args) } + + static let isList = Func { args in + if case .list = args.first { + return .bool(true) + } + return .bool(false) + } + + static let isEmpty = Func { args in + switch args.first { + case let .list(xs, _), let .vector(xs, _): + return .bool(xs.isEmpty) + default: + return .bool(false) + } + } + + static let count = Func { args in + switch args.first { + case let .list(xs, _), let .vector(xs, _): + return .number(xs.count) + default: + return .number(0) + } + } + + static let eq = Func { args in + guard args.count == 2 else { throw MalError.invalidArguments("eq") } + return args[0] == args[1] ? .bool(true) : .bool(false) + } + + static let readString = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("read-string") } + guard case let .string(s) = args[0] else { throw MalError.invalidArguments("read-string") } + return try Reader.read(s) + } + + static let slurp = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("slurp") } + guard case let .string(filename) = args[0] else { throw MalError.invalidArguments("slurp") } + return .string(try String(contentsOfFile: filename)) + } + + static let atom = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("atom") } + return .atom(Atom(args[0])) + } + + static let isAtom = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("atom?") } + if case .atom = args[0] { + return .bool(true) + } else { + return .bool(false) + } + } + + static let deref = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("deref") } + guard case let .atom(atom) = args[0] else { throw MalError.invalidArguments("deref") } + return atom.val + } + + static let reset = Func { args in + guard args.count == 2 else { throw MalError.invalidArguments("reset!") } + guard case let .atom(atom) = args[0] else { throw MalError.invalidArguments("reset!") } + atom.val = args[1] + return args[1] + } + + static let swap = Func { args in + guard args.count >= 2 else { throw MalError.invalidArguments("swap!") } + guard case let .atom(atom) = args[0] else { throw MalError.invalidArguments("swap!") } + guard case let .function(fn) = args[1] else { throw MalError.invalidArguments("swap!") } + let otherArgs = args.dropFirst(2) + atom.val = try fn.run([atom.val] + otherArgs) + return atom.val + } + + static let cons = Func { args in + guard args.count == 2 else { throw MalError.invalidArguments("cons") } + switch args[1] { + case let .list(values, _), let .vector(values, _): + return .list([args[0]] + values) + default: + throw MalError.invalidArguments("cons") + } + } + + static let concat = Func { args in + let values = try args.flatMap { el throws -> [Expr] in + switch el { + case let .list(values, _), let .vector(values, _): + return values + default: + throw MalError.invalidArguments("concat") + } + } + return .list(values) + } + + static let vec = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("vec") } + switch args[0] { + case let .list(values, _): + return .vector(values) + case let .vector(values, _): + return args[0] + default: + throw MalError.invalidArguments("vec") + } + } + + static let nth = Func { args in + guard args.count == 2 else { throw MalError.invalidArguments("nth") } + guard case let .number(index) = args[1] else { throw MalError.invalidArguments("nth") } + + switch args.first { + case let .list(values, _), let .vector(values, _): + guard values.indices ~= index else { throw MalError.outOfRange() } + return values[index] + default: + throw MalError.invalidArguments("nth") + } + } + + static let first = Func { args in + switch args.first { + case let .list(values, _), let .vector(values, _): + return values.first ?? .null + case .null: + return .null + default: + throw MalError.invalidArguments("first") + } + } + + static let rest = Func { args in + switch args.first { + case let .list(values, _), let .vector(values, _): + return .list(Array(values.dropFirst())) + case .null: + return .list([]) + default: + throw MalError.invalidArguments("rest") + } + } + + static let `throw` = Func { args in + guard args.count > 0 else { throw MalError.invalidArguments("throw") } + throw args[0] + } + + static let apply = Func { args in + guard args.count >= 2 else { throw MalError.invalidArguments("apply") } + guard case let .function(fn) = args[0] else { throw MalError.invalidArguments("apply") } + + let lastArgs: [Expr] + switch args.last! { + case let .list(values, _), let .vector(values, _): + lastArgs = values + default: + throw MalError.invalidArguments("apply") + } + + + let fnArgs = Array(args.dropFirst().dropLast()) + lastArgs + return try fn.run(fnArgs) + } + + static let map = Func { args in + guard args.count == 2 else { throw MalError.invalidArguments("map") } + guard case let .function(fn) = args[0] else { throw MalError.invalidArguments("map") } + + switch args[1] { + case let .list(values, _), let .vector(values, _): + return .list(try values.map { try fn.run([$0]) }) + default: + throw MalError.invalidArguments("map") + } + } + + static let isNil = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("nil?") } + if case .null = args[0] { + return .bool(true) + } + return .bool(false) + } + + static let isTrue = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("true?") } + if case .bool(true) = args[0] { + return .bool(true) + } + return .bool(false) + } + + static let isFalse = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("false?") } + if case .bool(false) = args[0] { + return .bool(true) + } + return .bool(false) + } + + static let isSymbol = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("symbol?") } + if case .symbol = args[0] { + return .bool(true) + } + return .bool(false) + } + + static let symbol = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("symbol") } + guard case let .string(name) = args[0] else { throw MalError.invalidArguments("symbol") } + return .symbol(name) + } + + static let keyword = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("keyword") } + guard case let .string(name) = args[0] else { throw MalError.invalidArguments("keyword") } + return name.first == keywordMagic + ? .string(name) + : .string(String(keywordMagic) + name) + } + + static let isKeyword = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("keyword?") } + if case let .string(name) = args[0] { + return name.first == keywordMagic ? .bool(true) : .bool(false) + } + return .bool(false) + } + + static let vector = Func { args in + return .vector(args) + } + + static let isVector = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("vector?") } + if case .vector = args[0] { + return .bool(true) + } + return .bool(false) + } + + static let isSequential = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("sequential?") } + switch args[0] { + case .list, .vector: + return .bool(true) + default: + return .bool(false) + } + } + + static let hashmap = Func { args in + return .hashmap(try hashMapDataFrom(args)) + } + + static let isHashmap = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("map?") } + if case .hashmap = args[0] { + return .bool(true) + } + return .bool(false) + } + + static let assoc = Func { args in + guard args.count > 0 else { throw MalError.invalidArguments("assoc") } + guard case let .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("assoc") } + + let newData = try hashMapDataFrom(Array(args.dropFirst())) + return .hashmap(data.merging(newData, uniquingKeysWith: { _, new in new })) + } + + static let dissoc = Func { args in + guard args.count > 0 else { throw MalError.invalidArguments("dissoc") } + guard case var .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("dissoc") } + + for key in args.dropFirst() { + guard case let .string(name) = key else { throw MalError.invalidArguments("dissoc") } + data.removeValue(forKey: name) + } + return .hashmap(data) + } + + static let get = Func { args in + guard args.count == 2 else { throw MalError.invalidArguments("get") } + guard case let .string(key) = args[1] else { throw MalError.invalidArguments("get") } + + switch args[0] { + case let .hashmap(data, _): + return data[key] ?? .null + case .null: + return .null + default: + throw MalError.invalidArguments("get") + } + } + + static let contains = Func { args in + guard args.count == 2 else { throw MalError.invalidArguments("contains?") } + guard case let .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("contains?") } + guard case let .string(key) = args[1] else { throw MalError.invalidArguments("contains?") } + return data.keys.contains(key) ? .bool(true) : .bool(false) + } + + static let keys = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("keys") } + guard case let .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("keys") } + return .list(data.keys.map(Expr.string)) + } + + static let vals = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("vals") } + guard case let .hashmap(data, _) = args[0] else { throw MalError.invalidArguments("vals") } + return .list(Array(data.values)) + } + + static let readline = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("readline") } + guard case let .string(promt) = args[0] else { throw MalError.invalidArguments("readline") } + print(promt, terminator: "") + if let s = readLine() { + return .string(s) + } + return .null + } + + static let timeMs = Func { args in + guard args.count == 0 else { throw MalError.invalidArguments("time-ms") } + return .number(Int(Date().timeIntervalSince1970 * 1000)) + } + + static let isFunction = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("fn?") } + if case let .function(fn) = args[0] { + return .bool(!fn.isMacro) + } + return .bool(false) + } + + static let isMacro = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("macro?") } + if case let .function(fn) = args[0] { + return .bool(fn.isMacro) + } + return .bool(false) + } + + static let isString = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("string?") } + if case let .string(s) = args[0] { + return s.first == keywordMagic ? .bool(false) : .bool(true) + } + return .bool(false) + } + + static let isNumber = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("number?") } + if case .number = args[0] { + return .bool(true) + } + return .bool(false) + } + + static let seq = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("seq") } + + switch args[0] { + case .list([], _), .vector([], _), .string(""), .null: + return .null + case .list: + return args[0] + case let .vector(values, _): + return .list(values) + case let .string(s): + if s.first == keywordMagic { + throw MalError.invalidArguments("seq") + } + return .list(Array(s.map { .string(String($0)) })) + default: + throw MalError.invalidArguments("seq") + } + } + + static let conj = Func { args in + guard args.count > 0 else { throw MalError.invalidArguments("conj") } + switch args[0] { + case let .list(values, _): + return .list(Array(args.dropFirst()).reversed() + values) + case let .vector(values, _): + return .vector(values + Array(args.dropFirst())) + default: + throw MalError.invalidArguments("conj") + } + } + + static let meta = Func { args in + guard args.count == 1 else { throw MalError.invalidArguments("meta") } + switch args[0] { + case let .function(fn): + return fn.meta + case let .list(_, meta): + return meta + case let .vector(_, meta): + return meta + case let .hashmap(_, meta): + return meta + case let .atom(atom): + return atom.meta + default: + throw MalError.invalidArguments("meta") + } + } + + static let withMeta = Func { args in + guard args.count == 2 else { throw MalError.invalidArguments("with-meta") } + switch args[0] { + case let .function(fn): + return .function(fn.withMeta(args[1])) + case let .list(values, _): + return .list(values, args[1]) + case let .vector(values, _): + return .vector(values, args[1]) + case let .hashmap(data, _): + return .hashmap(data, args[1]) + case let .atom(atom): + return .atom(atom.withMeta(args[1])) + default: + throw MalError.invalidArguments("with-meta") + } + } +} + +private let data: [String: Expr] = [ + "+": .function(.intOperation(+)), + "-": .function(.intOperation(-)), + "*": .function(.intOperation(*)), + "/": .function(.intOperation(/)), + "prn": .function(.prn), + "println": .function(.println), + "pr-str": .function(.prStr), + "str": .function(.str), + "list": .function(.list), + "list?": .function(.isList), + "empty?": .function(.isEmpty), + "count": .function(.count), + "=": .function(.eq), + "<": .function(.comparisonOperation(<)), + "<=": .function(.comparisonOperation(<=)), + ">": .function(.comparisonOperation(>)), + ">=": .function(.comparisonOperation(>=)), + "read-string": .function(.readString), + "slurp": .function(.slurp), + "atom": .function(.atom), + "atom?": .function(.isAtom), + "deref": .function(.deref), + "reset!": .function(.reset), + "swap!": .function(.swap), + "cons": .function(.cons), + "concat": .function(.concat), + "vec": .function(.vec), + "nth": .function(.nth), + "first": .function(.first), + "rest": .function(.rest), + "throw": .function(.throw), + "apply": .function(.apply), + "map": .function(.map), + "nil?": .function(.isNil), + "true?": .function(.isTrue), + "false?": .function(.isFalse), + "symbol?": .function(.isSymbol), + "symbol": .function(.symbol), + "keyword": .function(.keyword), + "keyword?": .function(.isKeyword), + "vector": .function(.vector), + "vector?": .function(.isVector), + "sequential?": .function(.isSequential), + "hash-map": .function(.hashmap), + "map?": .function(.isHashmap), + "assoc": .function(.assoc), + "dissoc": .function(.dissoc), + "get": .function(.get), + "contains?": .function(.contains), + "keys": .function(.keys), + "vals": .function(.vals), + "readline": .function(.readline), + "time-ms": .function(.timeMs), + "meta": .function(.meta), + "with-meta": .function(.withMeta), + "fn?": .function(.isFunction), + "macro?": .function(.isMacro), + "string?": .function(.isString), + "number?": .function(.isNumber), + "seq": .function(.seq), + "conj": .function(.conj) +] + +public enum Core { + public static let ns: Env = Env.init(data: data, outer: nil) +} diff --git a/impls/swift5/Sources/core/Env.swift b/impls/swift5/Sources/core/Env.swift index ef86a598b4..a2be8ae3cb 100644 --- a/impls/swift5/Sources/core/Env.swift +++ b/impls/swift5/Sources/core/Env.swift @@ -1,46 +1,46 @@ -import Foundation - -public class Env { - private var outer: Env? - public private(set) var data: [String: Expr] - - public init(data: [String: Expr] = [:], outer: Env? = nil) { - self.outer = outer - self.data = data - } - - public init(binds: [String], exprs: [Expr], outer: Env? = nil) throws { - self.outer = outer - self.data = [:] - - for i in 0.. Expr { - guard let val = find(key) else { throw MalError.symbolNotFound(key) } - return val - } - - private func find(_ key: String) -> Expr? { - if let val = data[key] { - return val - } - if let outer = outer { - return outer.find(key) - } - return nil - } -} +import Foundation + +public class Env { + private var outer: Env? + public private(set) var data: [String: Expr] + + public init(data: [String: Expr] = [:], outer: Env? = nil) { + self.outer = outer + self.data = data + } + + public init(binds: [String], exprs: [Expr], outer: Env? = nil) throws { + self.outer = outer + self.data = [:] + + for i in 0.. Expr { + guard let val = find(key) else { throw MalError.symbolNotFound(key) } + return val + } + + private func find(_ key: String) -> Expr? { + if let val = data[key] { + return val + } + if let outer = outer { + return outer.find(key) + } + return nil + } +} diff --git a/impls/swift5/Sources/core/Errors.swift b/impls/swift5/Sources/core/Errors.swift index be3b1a1cb6..37e988f5b5 100644 --- a/impls/swift5/Sources/core/Errors.swift +++ b/impls/swift5/Sources/core/Errors.swift @@ -1,57 +1,57 @@ -import Foundation - -public struct MalError: Error, LocalizedError { - let message: String - - public init(_ message: String) { - self.message = message - } - - public var errorDescription: String? { - "\(message)" - } -} - -extension MalError { - public static func unbalanced(expected: String) -> MalError { - return MalError("unbalanced: expected \(expected)") - } - - public static func unbalanced(unexpected: String) -> MalError { - return MalError("unbalanced: unexpected \(unexpected)") - } - - public static func invalidArguments(_ name: String) -> MalError { - return MalError("\(name): invalid arguments") - } - - public static func invalidArguments() -> MalError { - return MalError("invalid arguments") - } - - public static func outOfRange() -> MalError { - return MalError("index out of range") - } - - public static func invalidFunctionCall(_ expr: Expr) -> MalError { - return MalError("not a function: \(expr)") - } - - public static func symbolNotFound(_ s: String) -> MalError { - return MalError("'\(s)' not found") - } - - public static func invalidVariadicFunction() -> MalError { - return MalError("invalid variadic function definition") - } - - public static func reader() -> MalError { - return MalError("can't parse") - } -} - -extension Expr: Error, LocalizedError { - public var errorDescription: String? { - return "Error: \(self)" - } -} +import Foundation + +public struct MalError: Error, LocalizedError { + let message: String + + public init(_ message: String) { + self.message = message + } + + public var errorDescription: String? { + "\(message)" + } +} + +extension MalError { + public static func unbalanced(expected: String) -> MalError { + return MalError("unbalanced: expected \(expected)") + } + + public static func unbalanced(unexpected: String) -> MalError { + return MalError("unbalanced: unexpected \(unexpected)") + } + + public static func invalidArguments(_ name: String) -> MalError { + return MalError("\(name): invalid arguments") + } + + public static func invalidArguments() -> MalError { + return MalError("invalid arguments") + } + + public static func outOfRange() -> MalError { + return MalError("index out of range") + } + + public static func invalidFunctionCall(_ expr: Expr) -> MalError { + return MalError("not a function: \(expr)") + } + + public static func symbolNotFound(_ s: String) -> MalError { + return MalError("'\(s)' not found") + } + + public static func invalidVariadicFunction() -> MalError { + return MalError("invalid variadic function definition") + } + + public static func reader() -> MalError { + return MalError("can't parse") + } +} + +extension Expr: Error, LocalizedError { + public var errorDescription: String? { + return "Error: \(self)" + } +} diff --git a/impls/swift5/Sources/core/Parser.swift b/impls/swift5/Sources/core/Parser.swift index 2cfb5c4ded..8c2d5c90e4 100644 --- a/impls/swift5/Sources/core/Parser.swift +++ b/impls/swift5/Sources/core/Parser.swift @@ -1,210 +1,210 @@ -// The MIT License (MIT) -// -// Copyright (c) 2019 Alexander Grebenyuk (github.com/kean). - -// from https://raw.githubusercontent.com/kean/Regex/master/Source/Parser.swift - -import Foundation - -// MARK: - Parser - -struct Parser { - /// Parses the given string. Returns the matched element `A` and the - /// remaining substring if the match is succesful. Returns `nil` otherwise. - let parse: (_ string: Substring) throws -> (A, Substring)? -} - -extension Parser { - func parse(_ string: String) throws -> A? { - try parse(string[...])?.0 - } -} - -// MARK: - Parser (Predifined) - -struct Parsers {} - -extension Parsers { - /// Matches the given string. - static func string(_ p: String) -> Parser { - Parser { str in - str.hasPrefix(p) ? ((), str.dropFirst(p.count)) : nil - } - } - - /// Matches any single character. - static let char = Parser { str in - str.isEmpty ? nil : (str.first!, str.dropFirst()) - } - - /// Matches a character if the given string doesn't contain it. - static func char(excluding string: String) -> Parser { - char.filter { !string.contains($0) } - } - - /// Matches any character contained in the given string. - static func char(from string: String) -> Parser { - char.filter(string.contains) - } - - /// Matches characters while the given string doesn't contain them. - static func string(excluding string: String) -> Parser { - char(excluding: string).oneOrMore.map { String($0) } - } - - static let digit = char(from: "0123456789") - static let naturalNumber = digit.oneOrMore.map { Int(String($0)) } -} - -extension Parser: ExpressibleByStringLiteral, ExpressibleByUnicodeScalarLiteral, ExpressibleByExtendedGraphemeClusterLiteral where A == Void { - // Unfortunately had to add these explicitly supposably because of the - // conditional conformance limitations. - typealias ExtendedGraphemeClusterLiteralType = StringLiteralType - typealias UnicodeScalarLiteralType = StringLiteralType - typealias StringLiteralType = String - - init(stringLiteral value: String) { - self = Parsers.string(value) - } -} - -// MARK: - Parser (Combinators) - -/// Matches only if both of the given parsers produced a result. -func zip(_ a: Parser, _ b: Parser) -> Parser<(A, B)> { - a.flatMap { matchA in b.map { matchB in (matchA, matchB) } } -} - -/// Returns the first match or `nil` if no matches are found. -func oneOf(_ parsers: Parser...) -> Parser { - precondition(!parsers.isEmpty) - return Parser { str -> (A, Substring)? in - for parser in parsers { - if let match = try parser.parse(str) { - return match - } - } - return nil - } -} - -extension Parser { - func map(_ transform: @escaping (A) throws -> B?) -> Parser { - flatMap { match in - Parser { str in - (try transform(match)).map { ($0, str) } - } - } - } - - func flatMap(_ transform: @escaping (A) throws -> Parser) -> Parser { - Parser { str in - guard let (a, str) = try self.parse(str) else { return nil } - return try transform(a).parse(str) - } - } - - func filter(_ predicate: @escaping (A) -> Bool) -> Parser { - map { predicate($0) ? $0 : nil } - } -} - -// MARK: - Parser (Quantifiers) - -extension Parser { - /// Matches the given parser zero or more times. - var zeroOrMore: Parser<[A]> { - Parser<[A]> { str in - var str = str - var matches = [A]() - while let (match, newStr) = try self.parse(str) { - matches.append(match) - str = newStr - } - return (matches, str) - } - } - - /// Matches the given parser one or more times. - var oneOrMore: Parser<[A]> { - zeroOrMore.map { $0.isEmpty ? nil : $0 } - } -} - -// MARK: - Parser (Optional) - -func optional(_ parser: Parser) -> Parser { - Parser { str -> (A?, Substring)? in - guard let match = try parser.parse(str) else { - return (nil, str) // Return empty match without consuming any characters - } - return match - } -} - -// MARK: - Parser (Error Reporting) - -extension Parser { - - /// Throws an error if the parser fails to produce a match. - func orThrow(_ error: MalError) -> Parser { - Parser { str -> (A, Substring)? in - guard let match = try self.parse(str) else { - throw error - } - return match - } - } - - /// Matches if the parser produces no matches. Throws an error otherwise. - func zeroOrThrow(_ error: MalError) -> Parser { // automatically cast - map { _ in throw error } - } -} - -// MARK: - Parser (Misc) - -extension Parsers { - - /// Succeeds when input is empty. - static let end = Parser { str in str.isEmpty ? ((), str) : nil } - - /// Delays the creation of parser. Use it to break dependency cycles when - /// creating recursive parsers. - static func lazy(_ closure: @autoclosure @escaping () -> Parser) -> Parser { - Parser { str in - try closure().parse(str) - } - } -} - -// MARK: - Parser (Operators) - -infix operator *> : CombinatorPrecedence -infix operator <* : CombinatorPrecedence -infix operator <*> : CombinatorPrecedence - -func *> (_ lhs: Parser, _ rhs: Parser) -> Parser { - zip(lhs, rhs).map { $0.1 } -} - -func <* (_ lhs: Parser, _ rhs: Parser) -> Parser { - zip(lhs, rhs).map { $0.0 } -} - -func <*> (_ lhs: Parser, _ rhs: Parser) -> Parser<(A, B)> { - zip(lhs, rhs) -} - -precedencegroup CombinatorPrecedence { - associativity: left - higherThan: DefaultPrecedence -} - -// MARK: - Extensions - -extension CharacterSet { - func contains(_ c: Character) -> Bool { - return c.unicodeScalars.allSatisfy(contains) - } -} +// The MIT License (MIT) +// +// Copyright (c) 2019 Alexander Grebenyuk (github.com/kean). + +// from https://raw.githubusercontent.com/kean/Regex/master/Source/Parser.swift + +import Foundation + +// MARK: - Parser + +struct Parser { + /// Parses the given string. Returns the matched element `A` and the + /// remaining substring if the match is succesful. Returns `nil` otherwise. + let parse: (_ string: Substring) throws -> (A, Substring)? +} + +extension Parser { + func parse(_ string: String) throws -> A? { + try parse(string[...])?.0 + } +} + +// MARK: - Parser (Predifined) + +struct Parsers {} + +extension Parsers { + /// Matches the given string. + static func string(_ p: String) -> Parser { + Parser { str in + str.hasPrefix(p) ? ((), str.dropFirst(p.count)) : nil + } + } + + /// Matches any single character. + static let char = Parser { str in + str.isEmpty ? nil : (str.first!, str.dropFirst()) + } + + /// Matches a character if the given string doesn't contain it. + static func char(excluding string: String) -> Parser { + char.filter { !string.contains($0) } + } + + /// Matches any character contained in the given string. + static func char(from string: String) -> Parser { + char.filter(string.contains) + } + + /// Matches characters while the given string doesn't contain them. + static func string(excluding string: String) -> Parser { + char(excluding: string).oneOrMore.map { String($0) } + } + + static let digit = char(from: "0123456789") + static let naturalNumber = digit.oneOrMore.map { Int(String($0)) } +} + +extension Parser: ExpressibleByStringLiteral, ExpressibleByUnicodeScalarLiteral, ExpressibleByExtendedGraphemeClusterLiteral where A == Void { + // Unfortunately had to add these explicitly supposably because of the + // conditional conformance limitations. + typealias ExtendedGraphemeClusterLiteralType = StringLiteralType + typealias UnicodeScalarLiteralType = StringLiteralType + typealias StringLiteralType = String + + init(stringLiteral value: String) { + self = Parsers.string(value) + } +} + +// MARK: - Parser (Combinators) + +/// Matches only if both of the given parsers produced a result. +func zip(_ a: Parser, _ b: Parser) -> Parser<(A, B)> { + a.flatMap { matchA in b.map { matchB in (matchA, matchB) } } +} + +/// Returns the first match or `nil` if no matches are found. +func oneOf(_ parsers: Parser...) -> Parser { + precondition(!parsers.isEmpty) + return Parser { str -> (A, Substring)? in + for parser in parsers { + if let match = try parser.parse(str) { + return match + } + } + return nil + } +} + +extension Parser { + func map(_ transform: @escaping (A) throws -> B?) -> Parser { + flatMap { match in + Parser { str in + (try transform(match)).map { ($0, str) } + } + } + } + + func flatMap(_ transform: @escaping (A) throws -> Parser) -> Parser { + Parser { str in + guard let (a, str) = try self.parse(str) else { return nil } + return try transform(a).parse(str) + } + } + + func filter(_ predicate: @escaping (A) -> Bool) -> Parser { + map { predicate($0) ? $0 : nil } + } +} + +// MARK: - Parser (Quantifiers) + +extension Parser { + /// Matches the given parser zero or more times. + var zeroOrMore: Parser<[A]> { + Parser<[A]> { str in + var str = str + var matches = [A]() + while let (match, newStr) = try self.parse(str) { + matches.append(match) + str = newStr + } + return (matches, str) + } + } + + /// Matches the given parser one or more times. + var oneOrMore: Parser<[A]> { + zeroOrMore.map { $0.isEmpty ? nil : $0 } + } +} + +// MARK: - Parser (Optional) + +func optional(_ parser: Parser) -> Parser { + Parser { str -> (A?, Substring)? in + guard let match = try parser.parse(str) else { + return (nil, str) // Return empty match without consuming any characters + } + return match + } +} + +// MARK: - Parser (Error Reporting) + +extension Parser { + + /// Throws an error if the parser fails to produce a match. + func orThrow(_ error: MalError) -> Parser { + Parser { str -> (A, Substring)? in + guard let match = try self.parse(str) else { + throw error + } + return match + } + } + + /// Matches if the parser produces no matches. Throws an error otherwise. + func zeroOrThrow(_ error: MalError) -> Parser { // automatically cast + map { _ in throw error } + } +} + +// MARK: - Parser (Misc) + +extension Parsers { + + /// Succeeds when input is empty. + static let end = Parser { str in str.isEmpty ? ((), str) : nil } + + /// Delays the creation of parser. Use it to break dependency cycles when + /// creating recursive parsers. + static func lazy(_ closure: @autoclosure @escaping () -> Parser) -> Parser { + Parser { str in + try closure().parse(str) + } + } +} + +// MARK: - Parser (Operators) + +infix operator *> : CombinatorPrecedence +infix operator <* : CombinatorPrecedence +infix operator <*> : CombinatorPrecedence + +func *> (_ lhs: Parser, _ rhs: Parser) -> Parser { + zip(lhs, rhs).map { $0.1 } +} + +func <* (_ lhs: Parser, _ rhs: Parser) -> Parser { + zip(lhs, rhs).map { $0.0 } +} + +func <*> (_ lhs: Parser, _ rhs: Parser) -> Parser<(A, B)> { + zip(lhs, rhs) +} + +precedencegroup CombinatorPrecedence { + associativity: left + higherThan: DefaultPrecedence +} + +// MARK: - Extensions + +extension CharacterSet { + func contains(_ c: Character) -> Bool { + return c.unicodeScalars.allSatisfy(contains) + } +} diff --git a/impls/swift5/Sources/core/Printer.swift b/impls/swift5/Sources/core/Printer.swift index 1c41fa69b5..24d512248a 100644 --- a/impls/swift5/Sources/core/Printer.swift +++ b/impls/swift5/Sources/core/Printer.swift @@ -1,55 +1,55 @@ -import Foundation - -extension Expr { - - public static func print(readable: Bool = true, _ expr: Expr) -> String { - - let print = curry(Self.print)(readable) - - switch expr { - case let .number(value): - return "\(value)" - case let .list(arr, _): - let inner: String = arr.map(print).joined(separator: " ") - return "(" + inner + ")" - case let .vector(arr, _): - let inner: String = arr.map(print).joined(separator: " ") - return "[" + inner + "]" - case let .hashmap(m, _): - let inner = m.map { printString($0.key, readable: readable) + " " + print($0.value) }.joined(separator: " ") - return "{" + inner + "}" - case let .string(s): - return printString(s, readable: readable) - case let .symbol(s): - return s - case let .bool(b): - return b ? "true" : "false" - case .null: - return "nil" - case let .function(fn): - return fn.isMacro ? "#" : "#" - case let .atom(expr): - return "(atom \(print(expr.val)))" - } - } -} - -private func printString(_ s: String, readable: Bool) -> String { - if s.first == keywordMagic { - return ":" + s.dropFirst() - } - return readable ? ("\"" + unescape(s) + "\"") : s -} - -private func unescape(_ s: String) -> String { - return s - .replacingOccurrences(of: "\\", with: "\\\\") - .replacingOccurrences(of: "\n", with: "\\n") - .replacingOccurrences(of: "\"", with: "\\\"") -} - -extension Expr: CustomDebugStringConvertible { - public var debugDescription: String { - Expr.print(self) - } -} +import Foundation + +extension Expr { + + public static func print(readable: Bool = true, _ expr: Expr) -> String { + + let print = curry(Self.print)(readable) + + switch expr { + case let .number(value): + return "\(value)" + case let .list(arr, _): + let inner: String = arr.map(print).joined(separator: " ") + return "(" + inner + ")" + case let .vector(arr, _): + let inner: String = arr.map(print).joined(separator: " ") + return "[" + inner + "]" + case let .hashmap(m, _): + let inner = m.map { printString($0.key, readable: readable) + " " + print($0.value) }.joined(separator: " ") + return "{" + inner + "}" + case let .string(s): + return printString(s, readable: readable) + case let .symbol(s): + return s + case let .bool(b): + return b ? "true" : "false" + case .null: + return "nil" + case let .function(fn): + return fn.isMacro ? "#" : "#" + case let .atom(expr): + return "(atom \(print(expr.val)))" + } + } +} + +private func printString(_ s: String, readable: Bool) -> String { + if s.first == keywordMagic { + return ":" + s.dropFirst() + } + return readable ? ("\"" + unescape(s) + "\"") : s +} + +private func unescape(_ s: String) -> String { + return s + .replacingOccurrences(of: "\\", with: "\\\\") + .replacingOccurrences(of: "\n", with: "\\n") + .replacingOccurrences(of: "\"", with: "\\\"") +} + +extension Expr: CustomDebugStringConvertible { + public var debugDescription: String { + Expr.print(self) + } +} diff --git a/impls/swift5/Sources/core/Reader.swift b/impls/swift5/Sources/core/Reader.swift index 32f70c4093..de26ae9248 100644 --- a/impls/swift5/Sources/core/Reader.swift +++ b/impls/swift5/Sources/core/Reader.swift @@ -1,146 +1,146 @@ -import Foundation - -public enum Reader { - - public static func read(_ str: String) throws -> Expr { - return try Parsers.expr.orThrow(MalError.reader()).parse(str)! - } -} - -private extension Parsers { - - static let expr = form <* endPattern - - static let endPattern = oneOf( - end, - char(from: ")").zeroOrThrow(.unbalanced(unexpected: ")")), - char(from: "]").zeroOrThrow(.unbalanced(unexpected: "]")), - char(from: "}").zeroOrThrow(.unbalanced(unexpected: "}")) - ) - - static let form = oneOf( - list, - vector, - hashmap, - atom, - readerMacros - ).ignoreAround() - - static let _form: Parser = lazy(form) - - static let atom = oneOf( - malString, - number, - null, - bool, - symbol, - keyword - ) - - static let list = ("(" *> _form.zeroOrMore.ignoreAround() <* string(")").orThrow(.unbalanced(expected: ")"))).map { Expr.list($0) } - static let vector = ("[" *> _form.zeroOrMore.ignoreAround() <* string("]").orThrow(.unbalanced(expected: "]"))).map { Expr.vector($0) } - - // MARK: - Hashmap - - static let hashmap = ("{" *> (hashmapKey <*> _form).zeroOrMore.ignoreAround() <* string("}").orThrow(.unbalanced(expected: "}"))).map(makeHashmap) - static func makeHashmap(_ xs: [(Expr, Expr)]) -> Expr { - var dict: [String: Expr] = [:] - for x in xs { - guard case let .string(key) = x.0 else { fatalError() } - dict[key] = x.1 - } - return .hashmap(dict) - } - - static let hashmapKey = oneOf(malString, keyword) - - // MARK: - Number - - static let number = (optional(char(from: "-")) <*> naturalNumber).map(makeNumber) - static func makeNumber(_ negative: Character?, value: Int) -> Expr { - let factor = negative != nil ? -1 : 1 - return .number(value * factor) - } - - // MARK: - String - - static let stringContent = oneOf( - string(excluding: "\\\""), - string("\\\\").map { "\\" }, - string("\\\"").map { "\"" }, - string("\\n").map { "\n" }, - string("\\").map { "\\" } - ) - - static let malString = ("\"" *> stringContent.zeroOrMore <* string("\"").orThrow(.unbalanced(expected: "\""))).map(makeMalString) - static func makeMalString(_ xs: [String]) -> Expr { - return .string(xs.joined()) - } - - // MARK: - Keyword - - static let keyword = (":" *> name).map { Expr.string(String(keywordMagic) + $0) } - - // MARK: - Symbol - - static let symbolHead = char(excluding: "0123456789^`'\"#~@:%()[]{} \n\r\t,") - static let symbolRest = oneOf(symbolHead, char(from: "0123456789.")) - static let name = (symbolHead <*> symbolRest.zeroOrMore).map { String($0) + String($1) } - static let symbol = name.map(Expr.symbol) - - // MARK: - Bool - - static let bool = name.map(makeBool) - static func makeBool(_ s: String) -> Expr? { - switch s { - case "true": return .bool(true) - case "false": return .bool(false) - default: return nil - } - } - - // MARK: - Null - - static let null = name.map(makeNull) - static func makeNull(_ s: String) -> Expr? { - return s == "nil" ? .null : nil - } - - // MARK: - Reader macros - - static let quote = ("'" *> _form).readerMacros("quote") - static let quasiquote = ("`" *> _form).readerMacros("quasiquote") - static let spliceUnquote = ("~@" *> _form).readerMacros("splice-unquote") - static let unquote = ("~" *> _form).readerMacros("unquote") - static let deref = ("@" *> _form).readerMacros("deref") - static let meta = ("^" *> hashmap <*> _form).map { Expr.list([.symbol("with-meta"), $1, $0]) } - - - static let readerMacros = oneOf( - quote, - quasiquote, - spliceUnquote, - unquote, - deref, - meta - ) - - // MARK: - Ignore - - static let whitespace = char(from: " \n\r\t,") - static let comment = char(from: ";") <* char(excluding: "\n\r").zeroOrMore - static let ignore = oneOf(whitespace, comment) -} - -extension Parser { - - func ignoreAround() -> Parser { - return (Parsers.ignore.zeroOrMore *> self <* Parsers.ignore.zeroOrMore) - } -} - -extension Parser where A == Expr { - func readerMacros(_ s: String) -> Parser { - return map { Expr.list([.symbol(s), $0]) } - } -} +import Foundation + +public enum Reader { + + public static func read(_ str: String) throws -> Expr { + return try Parsers.expr.orThrow(MalError.reader()).parse(str)! + } +} + +private extension Parsers { + + static let expr = form <* endPattern + + static let endPattern = oneOf( + end, + char(from: ")").zeroOrThrow(.unbalanced(unexpected: ")")), + char(from: "]").zeroOrThrow(.unbalanced(unexpected: "]")), + char(from: "}").zeroOrThrow(.unbalanced(unexpected: "}")) + ) + + static let form = oneOf( + list, + vector, + hashmap, + atom, + readerMacros + ).ignoreAround() + + static let _form: Parser = lazy(form) + + static let atom = oneOf( + malString, + number, + null, + bool, + symbol, + keyword + ) + + static let list = ("(" *> _form.zeroOrMore.ignoreAround() <* string(")").orThrow(.unbalanced(expected: ")"))).map { Expr.list($0) } + static let vector = ("[" *> _form.zeroOrMore.ignoreAround() <* string("]").orThrow(.unbalanced(expected: "]"))).map { Expr.vector($0) } + + // MARK: - Hashmap + + static let hashmap = ("{" *> (hashmapKey <*> _form).zeroOrMore.ignoreAround() <* string("}").orThrow(.unbalanced(expected: "}"))).map(makeHashmap) + static func makeHashmap(_ xs: [(Expr, Expr)]) -> Expr { + var dict: [String: Expr] = [:] + for x in xs { + guard case let .string(key) = x.0 else { fatalError() } + dict[key] = x.1 + } + return .hashmap(dict) + } + + static let hashmapKey = oneOf(malString, keyword) + + // MARK: - Number + + static let number = (optional(char(from: "-")) <*> naturalNumber).map(makeNumber) + static func makeNumber(_ negative: Character?, value: Int) -> Expr { + let factor = negative != nil ? -1 : 1 + return .number(value * factor) + } + + // MARK: - String + + static let stringContent = oneOf( + string(excluding: "\\\""), + string("\\\\").map { "\\" }, + string("\\\"").map { "\"" }, + string("\\n").map { "\n" }, + string("\\").map { "\\" } + ) + + static let malString = ("\"" *> stringContent.zeroOrMore <* string("\"").orThrow(.unbalanced(expected: "\""))).map(makeMalString) + static func makeMalString(_ xs: [String]) -> Expr { + return .string(xs.joined()) + } + + // MARK: - Keyword + + static let keyword = (":" *> name).map { Expr.string(String(keywordMagic) + $0) } + + // MARK: - Symbol + + static let symbolHead = char(excluding: "0123456789^`'\"#~@:%()[]{} \n\r\t,") + static let symbolRest = oneOf(symbolHead, char(from: "0123456789.")) + static let name = (symbolHead <*> symbolRest.zeroOrMore).map { String($0) + String($1) } + static let symbol = name.map(Expr.symbol) + + // MARK: - Bool + + static let bool = name.map(makeBool) + static func makeBool(_ s: String) -> Expr? { + switch s { + case "true": return .bool(true) + case "false": return .bool(false) + default: return nil + } + } + + // MARK: - Null + + static let null = name.map(makeNull) + static func makeNull(_ s: String) -> Expr? { + return s == "nil" ? .null : nil + } + + // MARK: - Reader macros + + static let quote = ("'" *> _form).readerMacros("quote") + static let quasiquote = ("`" *> _form).readerMacros("quasiquote") + static let spliceUnquote = ("~@" *> _form).readerMacros("splice-unquote") + static let unquote = ("~" *> _form).readerMacros("unquote") + static let deref = ("@" *> _form).readerMacros("deref") + static let meta = ("^" *> hashmap <*> _form).map { Expr.list([.symbol("with-meta"), $1, $0]) } + + + static let readerMacros = oneOf( + quote, + quasiquote, + spliceUnquote, + unquote, + deref, + meta + ) + + // MARK: - Ignore + + static let whitespace = char(from: " \n\r\t,") + static let comment = char(from: ";") <* char(excluding: "\n\r").zeroOrMore + static let ignore = oneOf(whitespace, comment) +} + +extension Parser { + + func ignoreAround() -> Parser { + return (Parsers.ignore.zeroOrMore *> self <* Parsers.ignore.zeroOrMore) + } +} + +extension Parser where A == Expr { + func readerMacros(_ s: String) -> Parser { + return map { Expr.list([.symbol(s), $0]) } + } +} diff --git a/impls/swift5/Sources/core/Types.swift b/impls/swift5/Sources/core/Types.swift index 6ee53bc9ab..4d3734c09b 100644 --- a/impls/swift5/Sources/core/Types.swift +++ b/impls/swift5/Sources/core/Types.swift @@ -1,124 +1,124 @@ -import Foundation - -public let keywordMagic: Character = "\u{029E}" - -public enum Expr { - case number(Int) - case bool(Bool) - case null - case string(String) - case symbol(String) - indirect case list([Expr], Expr) - indirect case vector([Expr], Expr) - indirect case hashmap([String: Expr], Expr) - case function(Func) - case atom(Atom) -} - -public extension Expr { - static func list(_ arr: [Expr]) -> Expr { - return .list(arr, .null) - } - - static func vector(_ arr: [Expr]) -> Expr { - return .vector(arr, .null) - } - - static func hashmap(_ data: [String: Expr]) -> Expr { - return .hashmap(data, .null) - } -} - -extension Expr: Equatable { - public static func == (lhs: Self, rhs: Self) -> Bool { - switch (lhs, rhs) { - case let (.number(a), .number(b)): - return a == b - case let (.bool(a), .bool(b)): - return a == b - case (.null, .null): - return true - case let (.string(a), .string(b)): - return a == b - case let (.symbol(a), .symbol(b)): - return a == b - case let (.list(a), .list(b)), - let (.vector(a), .vector(b)), - let (.list(a), .vector(b)), - let (.vector(a), .list(b)): - return a == b - case let (.hashmap(a), .hashmap(b)): - return a == b - case let (.function(a), .function(b)): - return a == b - case let (.atom(a), .atom(b)): - return a == b - - default: - return false - } - } -} - -// MARK: - Func - -final public class Func { - public let run: ([Expr]) throws -> Expr - public let ast: Expr? - public let params: [String] - public let env: Env? - public let isMacro: Bool - public let meta: Expr - - public init( - ast: Expr? = nil, - params: [String] = [], - env: Env? = nil, - isMacro: Bool = false, - meta: Expr = .null, - run: @escaping ([Expr]) throws -> Expr - ) { - self.run = run - self.ast = ast - self.params = params - self.env = env - self.isMacro = isMacro - self.meta = meta - } - - public func asMacros() -> Func { - return Func(ast: ast, params: params, env: env, isMacro: true, meta: meta, run: run) - } - - public func withMeta(_ meta: Expr) -> Func { - return Func(ast: ast, params: params, env: env, isMacro: isMacro, meta: meta, run: run) - } -} - -extension Func: Equatable { - public static func == (lhs: Func, rhs: Func) -> Bool { - return lhs === rhs - } -} - -// MARK: - Atom - -final public class Atom { - public var val: Expr - public let meta: Expr - - public init(_ val: Expr, meta: Expr = .null) { - self.val = val - self.meta = meta - } - - public func withMeta(_ meta: Expr) -> Atom { - return Atom(val, meta: meta) - } -} - -extension Atom: Equatable { - public static func == (lhs: Atom, rhs: Atom) -> Bool { - return lhs.val == rhs.val - } -} +import Foundation + +public let keywordMagic: Character = "\u{029E}" + +public enum Expr { + case number(Int) + case bool(Bool) + case null + case string(String) + case symbol(String) + indirect case list([Expr], Expr) + indirect case vector([Expr], Expr) + indirect case hashmap([String: Expr], Expr) + case function(Func) + case atom(Atom) +} + +public extension Expr { + static func list(_ arr: [Expr]) -> Expr { + return .list(arr, .null) + } + + static func vector(_ arr: [Expr]) -> Expr { + return .vector(arr, .null) + } + + static func hashmap(_ data: [String: Expr]) -> Expr { + return .hashmap(data, .null) + } +} + +extension Expr: Equatable { + public static func == (lhs: Self, rhs: Self) -> Bool { + switch (lhs, rhs) { + case let (.number(a), .number(b)): + return a == b + case let (.bool(a), .bool(b)): + return a == b + case (.null, .null): + return true + case let (.string(a), .string(b)): + return a == b + case let (.symbol(a), .symbol(b)): + return a == b + case let (.list(a), .list(b)), + let (.vector(a), .vector(b)), + let (.list(a), .vector(b)), + let (.vector(a), .list(b)): + return a == b + case let (.hashmap(a), .hashmap(b)): + return a == b + case let (.function(a), .function(b)): + return a == b + case let (.atom(a), .atom(b)): + return a == b + + default: + return false + } + } +} + +// MARK: - Func + +final public class Func { + public let run: ([Expr]) throws -> Expr + public let ast: Expr? + public let params: [String] + public let env: Env? + public let isMacro: Bool + public let meta: Expr + + public init( + ast: Expr? = nil, + params: [String] = [], + env: Env? = nil, + isMacro: Bool = false, + meta: Expr = .null, + run: @escaping ([Expr]) throws -> Expr + ) { + self.run = run + self.ast = ast + self.params = params + self.env = env + self.isMacro = isMacro + self.meta = meta + } + + public func asMacros() -> Func { + return Func(ast: ast, params: params, env: env, isMacro: true, meta: meta, run: run) + } + + public func withMeta(_ meta: Expr) -> Func { + return Func(ast: ast, params: params, env: env, isMacro: isMacro, meta: meta, run: run) + } +} + +extension Func: Equatable { + public static func == (lhs: Func, rhs: Func) -> Bool { + return lhs === rhs + } +} + +// MARK: - Atom + +final public class Atom { + public var val: Expr + public let meta: Expr + + public init(_ val: Expr, meta: Expr = .null) { + self.val = val + self.meta = meta + } + + public func withMeta(_ meta: Expr) -> Atom { + return Atom(val, meta: meta) + } +} + +extension Atom: Equatable { + public static func == (lhs: Atom, rhs: Atom) -> Bool { + return lhs.val == rhs.val + } +} diff --git a/impls/swift5/Sources/core/Utils.swift b/impls/swift5/Sources/core/Utils.swift index e65973381e..44f4c2d691 100644 --- a/impls/swift5/Sources/core/Utils.swift +++ b/impls/swift5/Sources/core/Utils.swift @@ -1,11 +1,11 @@ -import Foundation - -public func curry(_ function: @escaping (A, B) -> C) -> (A) -> (B) -> C { - return { (a: A) -> (B) -> C in { (b: B) -> C in function(a, b) } } -} - -public extension Collection { - subscript (safe index: Index) -> Element? { - return indices.contains(index) ? self[index] : nil - } -} +import Foundation + +public func curry(_ function: @escaping (A, B) -> C) -> (A) -> (B) -> C { + return { (a: A) -> (B) -> C in { (b: B) -> C in function(a, b) } } +} + +public extension Collection { + subscript (safe index: Index) -> Element? { + return indices.contains(index) ? self[index] : nil + } +} diff --git a/impls/swift5/Sources/step0_repl/main.swift b/impls/swift5/Sources/step0_repl/main.swift index 88ff958811..00a5ac62eb 100644 --- a/impls/swift5/Sources/step0_repl/main.swift +++ b/impls/swift5/Sources/step0_repl/main.swift @@ -1,23 +1,23 @@ -import Foundation - -func READ(_ s: String) -> String { - return s -} - -func EVAL(_ s: String) -> String { - return s -} - -func PRINT(_ s: String) -> String { - return s -} - -func rep(_ s: String) -> String { - return PRINT(EVAL(READ(s))) -} - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s)) -} +import Foundation + +func READ(_ s: String) -> String { + return s +} + +func EVAL(_ s: String) -> String { + return s +} + +func PRINT(_ s: String) -> String { + return s +} + +func rep(_ s: String) -> String { + return PRINT(EVAL(READ(s))) +} + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s)) +} diff --git a/impls/swift5/Sources/step1_read_print/main.swift b/impls/swift5/Sources/step1_read_print/main.swift index e65f342e33..2ff15b32fc 100644 --- a/impls/swift5/Sources/step1_read_print/main.swift +++ b/impls/swift5/Sources/step1_read_print/main.swift @@ -1,31 +1,31 @@ -import Foundation -import core - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -func eval(_ expr: Expr) throws -> Expr { - return expr -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -func rep(_ s: String) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s)) -} +import Foundation +import core + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +func eval(_ expr: Expr) throws -> Expr { + return expr +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +func rep(_ s: String) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s)) +} diff --git a/impls/swift5/Sources/step2_eval/main.swift b/impls/swift5/Sources/step2_eval/main.swift index 378b0f0d78..e7e8d7bc2b 100644 --- a/impls/swift5/Sources/step2_eval/main.swift +++ b/impls/swift5/Sources/step2_eval/main.swift @@ -1,75 +1,75 @@ -import Foundation -import core - -extension Func { - - static fileprivate func infixOperation(_ op: @escaping (Int, Int) -> Int) -> Func { - return Func { args in - guard args.count == 2, - case let .number(a) = args[0], - case let .number(b) = args[1] else { throw MalError.invalidArguments() } - - return .number(op(a, b)) - } - } -} - -var replEnv: Env = Env() -replEnv.set(forKey: "+", val: .function(.infixOperation(+))) -replEnv.set(forKey: "-", val: .function(.infixOperation(-))) -replEnv.set(forKey: "*", val: .function(.infixOperation(*))) -replEnv.set(forKey: "/", val: .function(.infixOperation(/))) - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -private func evalAst(_ expr: Expr, env: Env) throws -> Expr { - switch expr { - case let .symbol(name): - return try env.get(name) - case let .vector(values, _): - return .vector(try values.map { try eval($0, env: env) }) - case let .hashmap(values, _): - return .hashmap(try values.mapValues { try eval($0, env: env) }) - case let .list(ast, _): - return .list(try ast.map { try eval($0, env: env) }) - default: - return expr - } -} - -func eval(_ expr: Expr, env: Env) throws -> Expr { - guard case let .list(values, _) = expr else { - return try evalAst(expr, env: env) - } - - if values.isEmpty { - return expr - } - - let ast = try values.map { try eval($0, env: env) } - guard case let .function(fn) = ast.first else { throw MalError.invalidFunctionCall(ast[0]) } - return try fn.run(Array(ast.dropFirst())) -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -func rep(_ s: String, env: Env) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr, env: env) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s, env: replEnv)) -} +import Foundation +import core + +extension Func { + + static fileprivate func infixOperation(_ op: @escaping (Int, Int) -> Int) -> Func { + return Func { args in + guard args.count == 2, + case let .number(a) = args[0], + case let .number(b) = args[1] else { throw MalError.invalidArguments() } + + return .number(op(a, b)) + } + } +} + +var replEnv: Env = Env() +replEnv.set(forKey: "+", val: .function(.infixOperation(+))) +replEnv.set(forKey: "-", val: .function(.infixOperation(-))) +replEnv.set(forKey: "*", val: .function(.infixOperation(*))) +replEnv.set(forKey: "/", val: .function(.infixOperation(/))) + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +private func evalAst(_ expr: Expr, env: Env) throws -> Expr { + switch expr { + case let .symbol(name): + return try env.get(name) + case let .vector(values, _): + return .vector(try values.map { try eval($0, env: env) }) + case let .hashmap(values, _): + return .hashmap(try values.mapValues { try eval($0, env: env) }) + case let .list(ast, _): + return .list(try ast.map { try eval($0, env: env) }) + default: + return expr + } +} + +func eval(_ expr: Expr, env: Env) throws -> Expr { + guard case let .list(values, _) = expr else { + return try evalAst(expr, env: env) + } + + if values.isEmpty { + return expr + } + + let ast = try values.map { try eval($0, env: env) } + guard case let .function(fn) = ast.first else { throw MalError.invalidFunctionCall(ast[0]) } + return try fn.run(Array(ast.dropFirst())) +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +func rep(_ s: String, env: Env) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr, env: env) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s, env: replEnv)) +} diff --git a/impls/swift5/Sources/step3_env/main.swift b/impls/swift5/Sources/step3_env/main.swift index 14d79aa5d3..732095f7d9 100644 --- a/impls/swift5/Sources/step3_env/main.swift +++ b/impls/swift5/Sources/step3_env/main.swift @@ -1,106 +1,106 @@ -import Foundation -import core - -extension Func { - - static fileprivate func infixOperation(_ op: @escaping (Int, Int) -> Int) -> Func { - return Func { args in - guard args.count == 2, - case let .number(a) = args[0], - case let .number(b) = args[1] else { throw MalError.invalidArguments() } - - return .number(op(a, b)) - } - } -} - -var replEnv: Env = Env() -replEnv.set(forKey: "+", val: .function(.infixOperation(+))) -replEnv.set(forKey: "-", val: .function(.infixOperation(-))) -replEnv.set(forKey: "*", val: .function(.infixOperation(*))) -replEnv.set(forKey: "/", val: .function(.infixOperation(/))) - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -private func evalAst(_ expr: Expr, env: Env) throws -> Expr { - switch expr { - case let .symbol(name): - return try env.get(name) - case let .vector(values, _): - return .vector(try values.map { try eval($0, env: env) }) - case let .hashmap(values, _): - return .hashmap(try values.mapValues { try eval($0, env: env) }) - case let .list(ast, _): - return .list(try ast.map { try eval($0, env: env) }) - default: - return expr - } -} - -func eval(_ expr: Expr, env: Env) throws -> Expr { - - guard case let .list(ast, _) = expr else { - return try evalAst(expr, env: env) - } - if ast.isEmpty { - return expr - } - - switch ast[0] { - - case .symbol("def!"): - guard ast.count == 3 else { throw MalError.invalidArguments("def!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } - - let val = try eval(ast[2], env: env) - env.set(forKey: name, val: val) - return val - - case .symbol("let*"): - guard ast.count == 3 else { throw MalError.invalidArguments("let*") } - - switch ast[1] { - case let .list(bindable, _), let .vector(bindable, _): - let letEnv = Env(outer: env) - - for i in stride(from: 0, to: bindable.count - 1, by: 2) { - guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } - let value = bindable[i + 1] - letEnv.set(forKey: key, val: try eval(value, env: letEnv)) - } - - let expToEval = ast[2] - return try eval(expToEval, env: letEnv) - default: - throw MalError.invalidArguments("let*") - } - - default: - guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } - guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } - return try fn.run(Array(ast.dropFirst())) - } -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -func rep(_ s: String, env: Env) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr, env: env) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s, env: replEnv)) -} +import Foundation +import core + +extension Func { + + static fileprivate func infixOperation(_ op: @escaping (Int, Int) -> Int) -> Func { + return Func { args in + guard args.count == 2, + case let .number(a) = args[0], + case let .number(b) = args[1] else { throw MalError.invalidArguments() } + + return .number(op(a, b)) + } + } +} + +var replEnv: Env = Env() +replEnv.set(forKey: "+", val: .function(.infixOperation(+))) +replEnv.set(forKey: "-", val: .function(.infixOperation(-))) +replEnv.set(forKey: "*", val: .function(.infixOperation(*))) +replEnv.set(forKey: "/", val: .function(.infixOperation(/))) + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +private func evalAst(_ expr: Expr, env: Env) throws -> Expr { + switch expr { + case let .symbol(name): + return try env.get(name) + case let .vector(values, _): + return .vector(try values.map { try eval($0, env: env) }) + case let .hashmap(values, _): + return .hashmap(try values.mapValues { try eval($0, env: env) }) + case let .list(ast, _): + return .list(try ast.map { try eval($0, env: env) }) + default: + return expr + } +} + +func eval(_ expr: Expr, env: Env) throws -> Expr { + + guard case let .list(ast, _) = expr else { + return try evalAst(expr, env: env) + } + if ast.isEmpty { + return expr + } + + switch ast[0] { + + case .symbol("def!"): + guard ast.count == 3 else { throw MalError.invalidArguments("def!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } + + let val = try eval(ast[2], env: env) + env.set(forKey: name, val: val) + return val + + case .symbol("let*"): + guard ast.count == 3 else { throw MalError.invalidArguments("let*") } + + switch ast[1] { + case let .list(bindable, _), let .vector(bindable, _): + let letEnv = Env(outer: env) + + for i in stride(from: 0, to: bindable.count - 1, by: 2) { + guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } + let value = bindable[i + 1] + letEnv.set(forKey: key, val: try eval(value, env: letEnv)) + } + + let expToEval = ast[2] + return try eval(expToEval, env: letEnv) + default: + throw MalError.invalidArguments("let*") + } + + default: + guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } + guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } + return try fn.run(Array(ast.dropFirst())) + } +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +func rep(_ s: String, env: Env) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr, env: env) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s, env: replEnv)) +} diff --git a/impls/swift5/Sources/step4_if_fn_do/main.swift b/impls/swift5/Sources/step4_if_fn_do/main.swift index 2c110443cc..826b82a448 100644 --- a/impls/swift5/Sources/step4_if_fn_do/main.swift +++ b/impls/swift5/Sources/step4_if_fn_do/main.swift @@ -1,129 +1,129 @@ -import Foundation -import core - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -private func evalAst(_ expr: Expr, env: Env) throws -> Expr { - switch expr { - case let .symbol(name): - return try env.get(name) - case let .vector(values, _): - return .vector(try values.map { try eval($0, env: env) }) - case let .hashmap(values, _): - return .hashmap(try values.mapValues { try eval($0, env: env) }) - case let .list(ast, _): - return .list(try ast.map { try eval($0, env: env) }) - default: - return expr - } -} - -func eval(_ expr: Expr, env: Env) throws -> Expr { - - guard case let .list(ast, _) = expr else { - return try evalAst(expr, env: env) - } - if ast.isEmpty { - return expr - } - - switch ast[0] { - - case .symbol("def!"): - guard ast.count == 3 else { throw MalError.invalidArguments("def!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } - - let val = try eval(ast[2], env: env) - env.set(forKey: name, val: val) - return val - - case .symbol("let*"): - guard ast.count == 3 else { throw MalError.invalidArguments("let*") } - - switch ast[1] { - case let .list(bindable, _), let .vector(bindable, _): - let letEnv = Env(outer: env) - - for i in stride(from: 0, to: bindable.count - 1, by: 2) { - guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } - let value = bindable[i + 1] - letEnv.set(forKey: key, val: try eval(value, env: letEnv)) - } - - let expToEval = ast[2] - return try eval(expToEval, env: letEnv) - default: - throw MalError.invalidArguments("let*") - } - - case .symbol("do"): - let exprsToEval = ast.dropFirst() - if exprsToEval.isEmpty { throw MalError.invalidArguments("do") } - return try exprsToEval.map { try eval($0, env: env) }.last! - - case .symbol("if"): - guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } - - let condExpr = ast[1] - switch try eval(condExpr, env: env) { - case .bool(false), .null: - if let falseExpr = ast[safe: 3] { - return try eval(falseExpr, env: env) - } - return .null - default: - return try eval(ast[2], env: env) - } - - case .symbol("fn*"): - guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } - let binds: [String] - switch ast[1] { - case let .list(xs, _), let .vector(xs, _): - binds = try xs.map { - guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } - return name - } - default: - throw MalError.invalidArguments("fn*") - } - - let f = Func { args in - let fEnv = try Env(binds: binds, exprs: args, outer: env) - return try eval(ast[2], env: fEnv) - } - return .function(f) - - default: - guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } - guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } - return try fn.run(Array(ast.dropFirst())) - } -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -func rep(_ s: String, env: Env) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr, env: env) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -let replEnv: Env = Env(data: Core.ns.data) - -_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s, env: replEnv)) -} +import Foundation +import core + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +private func evalAst(_ expr: Expr, env: Env) throws -> Expr { + switch expr { + case let .symbol(name): + return try env.get(name) + case let .vector(values, _): + return .vector(try values.map { try eval($0, env: env) }) + case let .hashmap(values, _): + return .hashmap(try values.mapValues { try eval($0, env: env) }) + case let .list(ast, _): + return .list(try ast.map { try eval($0, env: env) }) + default: + return expr + } +} + +func eval(_ expr: Expr, env: Env) throws -> Expr { + + guard case let .list(ast, _) = expr else { + return try evalAst(expr, env: env) + } + if ast.isEmpty { + return expr + } + + switch ast[0] { + + case .symbol("def!"): + guard ast.count == 3 else { throw MalError.invalidArguments("def!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } + + let val = try eval(ast[2], env: env) + env.set(forKey: name, val: val) + return val + + case .symbol("let*"): + guard ast.count == 3 else { throw MalError.invalidArguments("let*") } + + switch ast[1] { + case let .list(bindable, _), let .vector(bindable, _): + let letEnv = Env(outer: env) + + for i in stride(from: 0, to: bindable.count - 1, by: 2) { + guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } + let value = bindable[i + 1] + letEnv.set(forKey: key, val: try eval(value, env: letEnv)) + } + + let expToEval = ast[2] + return try eval(expToEval, env: letEnv) + default: + throw MalError.invalidArguments("let*") + } + + case .symbol("do"): + let exprsToEval = ast.dropFirst() + if exprsToEval.isEmpty { throw MalError.invalidArguments("do") } + return try exprsToEval.map { try eval($0, env: env) }.last! + + case .symbol("if"): + guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } + + let condExpr = ast[1] + switch try eval(condExpr, env: env) { + case .bool(false), .null: + if let falseExpr = ast[safe: 3] { + return try eval(falseExpr, env: env) + } + return .null + default: + return try eval(ast[2], env: env) + } + + case .symbol("fn*"): + guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } + let binds: [String] + switch ast[1] { + case let .list(xs, _), let .vector(xs, _): + binds = try xs.map { + guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } + return name + } + default: + throw MalError.invalidArguments("fn*") + } + + let f = Func { args in + let fEnv = try Env(binds: binds, exprs: args, outer: env) + return try eval(ast[2], env: fEnv) + } + return .function(f) + + default: + guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } + guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } + return try fn.run(Array(ast.dropFirst())) + } +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +func rep(_ s: String, env: Env) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr, env: env) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +let replEnv: Env = Env(data: Core.ns.data) + +_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s, env: replEnv)) +} diff --git a/impls/swift5/Sources/step5_tco/main.swift b/impls/swift5/Sources/step5_tco/main.swift index 449dd691f0..eca237f551 100644 --- a/impls/swift5/Sources/step5_tco/main.swift +++ b/impls/swift5/Sources/step5_tco/main.swift @@ -1,147 +1,147 @@ -import Foundation -import core - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -private func evalAst(_ expr: Expr, env: Env) throws -> Expr { - switch expr { - case let .symbol(name): - return try env.get(name) - case let .vector(values, _): - return .vector(try values.map { try eval($0, env: env) }) - case let .hashmap(values, _): - return .hashmap(try values.mapValues { try eval($0, env: env) }) - case let .list(ast, _): - return .list(try ast.map { try eval($0, env: env) }) - default: - return expr - } -} - -func eval(_ expr: Expr, env: Env) throws -> Expr { - - var env = env - var expr = expr - - while true { - - guard case let .list(ast, _) = expr else { - return try evalAst(expr, env: env) - } - if ast.isEmpty { - return expr - } - - switch ast[0] { - - case .symbol("def!"): - guard ast.count == 3 else { throw MalError.invalidArguments("def!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } - - let val = try eval(ast[2], env: env) - env.set(forKey: name, val: val) - return val - - case .symbol("let*"): - guard ast.count == 3 else { throw MalError.invalidArguments("let*") } - - switch ast[1] { - case let .list(bindable, _), let .vector(bindable, _): - let letEnv = Env(outer: env) - - for i in stride(from: 0, to: bindable.count - 1, by: 2) { - guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } - let value = bindable[i + 1] - letEnv.set(forKey: key, val: try eval(value, env: letEnv)) - } - - expr = ast[2] - env = letEnv - default: - throw MalError.invalidArguments("let*") - } - - case .symbol("do"): - let exprsToEval = ast.dropFirst() - guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } - _ = try exprsToEval.dropLast().map { try eval($0, env: env) } - expr = exprsToEval.last! - - case .symbol("if"): - guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } - - switch try eval(ast[1], env: env) { - case .bool(false), .null: - if let falseBranch = ast[safe: 3] { - expr = falseBranch - } else { - expr = .null - } - default: - expr = ast[2] - } - - case .symbol("fn*"): - guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } - let binds: [String] - - switch ast[1] { - case let .list(xs, _), let .vector(xs, _): - binds = try xs.map { - guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } - return name - } - default: - throw MalError.invalidArguments("fn*") - } - - let run: ([Expr]) throws -> Expr = { args in - let fEnv = try Env(binds: binds, exprs: args, outer: env) - return try eval(ast[2], env: fEnv) - } - - let f = Func(ast: ast[2], params: binds, env: env, run: run) - return .function(f) - - default: - guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } - guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } - - let args = Array(ast.dropFirst()) - if let ast = fn.ast, let fnEnv = fn.env { - let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) - env = newEnv - expr = ast - } else { - return try fn.run(args) - } - } - } -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -func rep(_ s: String, env: Env) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr, env: env) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -let replEnv: Env = Env(data: Core.ns.data) - -_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s, env: replEnv)) -} +import Foundation +import core + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +private func evalAst(_ expr: Expr, env: Env) throws -> Expr { + switch expr { + case let .symbol(name): + return try env.get(name) + case let .vector(values, _): + return .vector(try values.map { try eval($0, env: env) }) + case let .hashmap(values, _): + return .hashmap(try values.mapValues { try eval($0, env: env) }) + case let .list(ast, _): + return .list(try ast.map { try eval($0, env: env) }) + default: + return expr + } +} + +func eval(_ expr: Expr, env: Env) throws -> Expr { + + var env = env + var expr = expr + + while true { + + guard case let .list(ast, _) = expr else { + return try evalAst(expr, env: env) + } + if ast.isEmpty { + return expr + } + + switch ast[0] { + + case .symbol("def!"): + guard ast.count == 3 else { throw MalError.invalidArguments("def!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } + + let val = try eval(ast[2], env: env) + env.set(forKey: name, val: val) + return val + + case .symbol("let*"): + guard ast.count == 3 else { throw MalError.invalidArguments("let*") } + + switch ast[1] { + case let .list(bindable, _), let .vector(bindable, _): + let letEnv = Env(outer: env) + + for i in stride(from: 0, to: bindable.count - 1, by: 2) { + guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } + let value = bindable[i + 1] + letEnv.set(forKey: key, val: try eval(value, env: letEnv)) + } + + expr = ast[2] + env = letEnv + default: + throw MalError.invalidArguments("let*") + } + + case .symbol("do"): + let exprsToEval = ast.dropFirst() + guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } + _ = try exprsToEval.dropLast().map { try eval($0, env: env) } + expr = exprsToEval.last! + + case .symbol("if"): + guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } + + switch try eval(ast[1], env: env) { + case .bool(false), .null: + if let falseBranch = ast[safe: 3] { + expr = falseBranch + } else { + expr = .null + } + default: + expr = ast[2] + } + + case .symbol("fn*"): + guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } + let binds: [String] + + switch ast[1] { + case let .list(xs, _), let .vector(xs, _): + binds = try xs.map { + guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } + return name + } + default: + throw MalError.invalidArguments("fn*") + } + + let run: ([Expr]) throws -> Expr = { args in + let fEnv = try Env(binds: binds, exprs: args, outer: env) + return try eval(ast[2], env: fEnv) + } + + let f = Func(ast: ast[2], params: binds, env: env, run: run) + return .function(f) + + default: + guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } + guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } + + let args = Array(ast.dropFirst()) + if let ast = fn.ast, let fnEnv = fn.env { + let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) + env = newEnv + expr = ast + } else { + return try fn.run(args) + } + } + } +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +func rep(_ s: String, env: Env) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr, env: env) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +let replEnv: Env = Env(data: Core.ns.data) + +_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s, env: replEnv)) +} diff --git a/impls/swift5/Sources/step6_file/main.swift b/impls/swift5/Sources/step6_file/main.swift index 935fcb9da6..89b89d3e1f 100644 --- a/impls/swift5/Sources/step6_file/main.swift +++ b/impls/swift5/Sources/step6_file/main.swift @@ -1,159 +1,159 @@ -import Foundation -import core - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -private func evalAst(_ expr: Expr, env: Env) throws -> Expr { - switch expr { - case let .symbol(name): - return try env.get(name) - case let .vector(values, _): - return .vector(try values.map { try eval($0, env: env) }) - case let .hashmap(values, _): - return .hashmap(try values.mapValues { try eval($0, env: env) }) - case let .list(ast, _): - return .list(try ast.map { try eval($0, env: env) }) - default: - return expr - } -} - -func eval(_ expr: Expr, env: Env) throws -> Expr { - - var env = env - var expr = expr - - while true { - - guard case let .list(ast, _) = expr else { - return try evalAst(expr, env: env) - } - if ast.isEmpty { - return expr - } - - switch ast[0] { - - case .symbol("def!"): - guard ast.count == 3 else { throw MalError.invalidArguments("def!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } - - let val = try eval(ast[2], env: env) - env.set(forKey: name, val: val) - return val - - case .symbol("let*"): - guard ast.count == 3 else { throw MalError.invalidArguments("let*") } - - switch ast[1] { - case let .list(bindable, _), let .vector(bindable, _): - let letEnv = Env(outer: env) - - for i in stride(from: 0, to: bindable.count - 1, by: 2) { - guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } - let value = bindable[i + 1] - letEnv.set(forKey: key, val: try eval(value, env: letEnv)) - } - - expr = ast[2] - env = letEnv - default: - throw MalError.invalidArguments("let*") - } - - case .symbol("do"): - let exprsToEval = ast.dropFirst() - guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } - _ = try exprsToEval.dropLast().map { try eval($0, env: env) } - expr = exprsToEval.last! - - case .symbol("if"): - guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } - - switch try eval(ast[1], env: env) { - case .bool(false), .null: - if let falseBranch = ast[safe: 3] { - expr = falseBranch - } else { - expr = .null - } - default: - expr = ast[2] - } - - case .symbol("fn*"): - guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } - let binds: [String] - - switch ast[1] { - case let .list(xs, _), let .vector(xs, _): - binds = try xs.map { - guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } - return name - } - default: - throw MalError.invalidArguments("fn*") - } - - let run: ([Expr]) throws -> Expr = { args in - let fEnv = try Env(binds: binds, exprs: args, outer: env) - return try eval(ast[2], env: fEnv) - } - - let f = Func(ast: ast[2], params: binds, env: env, run: run) - return .function(f) - - default: - guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } - guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } - - let args = Array(ast.dropFirst()) - if let ast = fn.ast, let fnEnv = fn.env { - let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) - env = newEnv - expr = ast - } else { - return try fn.run(args) - } - } - } -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -func rep(_ s: String, env: Env) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr, env: env) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -let replEnv: Env = Env(data: Core.ns.data) - -replEnv.set(forKey: "eval", val: .function(Func { args in - guard let expr = args.first else { throw MalError.invalidArguments("eval") } - return try eval(expr, env: replEnv) -})) -replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) - -_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) -_ = rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) - -if CommandLine.arguments.count > 1 { - _ = rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) - exit(0) -} - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s, env: replEnv)) -} +import Foundation +import core + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +private func evalAst(_ expr: Expr, env: Env) throws -> Expr { + switch expr { + case let .symbol(name): + return try env.get(name) + case let .vector(values, _): + return .vector(try values.map { try eval($0, env: env) }) + case let .hashmap(values, _): + return .hashmap(try values.mapValues { try eval($0, env: env) }) + case let .list(ast, _): + return .list(try ast.map { try eval($0, env: env) }) + default: + return expr + } +} + +func eval(_ expr: Expr, env: Env) throws -> Expr { + + var env = env + var expr = expr + + while true { + + guard case let .list(ast, _) = expr else { + return try evalAst(expr, env: env) + } + if ast.isEmpty { + return expr + } + + switch ast[0] { + + case .symbol("def!"): + guard ast.count == 3 else { throw MalError.invalidArguments("def!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } + + let val = try eval(ast[2], env: env) + env.set(forKey: name, val: val) + return val + + case .symbol("let*"): + guard ast.count == 3 else { throw MalError.invalidArguments("let*") } + + switch ast[1] { + case let .list(bindable, _), let .vector(bindable, _): + let letEnv = Env(outer: env) + + for i in stride(from: 0, to: bindable.count - 1, by: 2) { + guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } + let value = bindable[i + 1] + letEnv.set(forKey: key, val: try eval(value, env: letEnv)) + } + + expr = ast[2] + env = letEnv + default: + throw MalError.invalidArguments("let*") + } + + case .symbol("do"): + let exprsToEval = ast.dropFirst() + guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } + _ = try exprsToEval.dropLast().map { try eval($0, env: env) } + expr = exprsToEval.last! + + case .symbol("if"): + guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } + + switch try eval(ast[1], env: env) { + case .bool(false), .null: + if let falseBranch = ast[safe: 3] { + expr = falseBranch + } else { + expr = .null + } + default: + expr = ast[2] + } + + case .symbol("fn*"): + guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } + let binds: [String] + + switch ast[1] { + case let .list(xs, _), let .vector(xs, _): + binds = try xs.map { + guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } + return name + } + default: + throw MalError.invalidArguments("fn*") + } + + let run: ([Expr]) throws -> Expr = { args in + let fEnv = try Env(binds: binds, exprs: args, outer: env) + return try eval(ast[2], env: fEnv) + } + + let f = Func(ast: ast[2], params: binds, env: env, run: run) + return .function(f) + + default: + guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } + guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } + + let args = Array(ast.dropFirst()) + if let ast = fn.ast, let fnEnv = fn.env { + let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) + env = newEnv + expr = ast + } else { + return try fn.run(args) + } + } + } +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +func rep(_ s: String, env: Env) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr, env: env) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +let replEnv: Env = Env(data: Core.ns.data) + +replEnv.set(forKey: "eval", val: .function(Func { args in + guard let expr = args.first else { throw MalError.invalidArguments("eval") } + return try eval(expr, env: replEnv) +})) +replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) + +_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) +_ = rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) + +if CommandLine.arguments.count > 1 { + _ = rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) + exit(0) +} + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s, env: replEnv)) +} diff --git a/impls/swift5/Sources/step7_quote/main.swift b/impls/swift5/Sources/step7_quote/main.swift index 5dacab4286..949315299e 100644 --- a/impls/swift5/Sources/step7_quote/main.swift +++ b/impls/swift5/Sources/step7_quote/main.swift @@ -1,205 +1,205 @@ -import Foundation -import core - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -private func qq_loop(_ elt: Expr, acc: Expr) throws -> Expr { - if case let .list(xs, _) = elt { - if 0 < xs.count && xs[0] == .symbol("splice-unquote") { - guard xs.count == 2 else { throw MalError.invalidArguments("splice-unquote") } - return .list([.symbol("concat"), xs[1], acc]) - } - } - return .list([.symbol("cons"), try quasiquote(elt), acc]) -} -private func qq_foldr(_ xs: [Expr]) throws -> Expr { - var acc : Expr = .list([]) - for i in stride(from: xs.count-1, through: 0, by: -1) { - acc = try qq_loop(xs[i], acc:acc) - } - return acc -} -private func quasiquote(_ expr: Expr) throws -> Expr { - switch expr { - case let .list(xs, _): - if 0 < xs.count && xs[0] == .symbol("unquote") { - guard xs.count == 2 else { throw MalError.invalidArguments("unquote") } - return xs[1] - } else { - return try qq_foldr(xs) - } - case let .vector(xs, _): - return .list([.symbol("vec"), try qq_foldr(xs)]) - case .symbol(_), .hashmap(_): - return .list([.symbol("quote"), expr]) - default: - return expr - } -} - -private func evalAst(_ expr: Expr, env: Env) throws -> Expr { - switch expr { - case let .symbol(name): - return try env.get(name) - case let .vector(values, _): - return .vector(try values.map { try eval($0, env: env) }) - case let .hashmap(values, _): - return .hashmap(try values.mapValues { try eval($0, env: env) }) - case let .list(ast, _): - return .list(try ast.map { try eval($0, env: env) }) - default: - return expr - } -} - -func eval(_ expr: Expr, env: Env) throws -> Expr { - - var env = env - var expr = expr - - while true { - - guard case let .list(ast, _) = expr else { - return try evalAst(expr, env: env) - } - if ast.isEmpty { - return expr - } - - switch ast[0] { - - case .symbol("def!"): - guard ast.count == 3 else { throw MalError.invalidArguments("def!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } - - let val = try eval(ast[2], env: env) - env.set(forKey: name, val: val) - return val - - case .symbol("let*"): - guard ast.count == 3 else { throw MalError.invalidArguments("let*") } - - switch ast[1] { - case let .list(bindable, _), let .vector(bindable, _): - let letEnv = Env(outer: env) - - for i in stride(from: 0, to: bindable.count - 1, by: 2) { - guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } - let value = bindable[i + 1] - letEnv.set(forKey: key, val: try eval(value, env: letEnv)) - } - - expr = ast[2] - env = letEnv - default: - throw MalError.invalidArguments("let*") - } - - case .symbol("quote"): - guard ast.count == 2 else { throw MalError.invalidArguments("quote") } - return ast[1] - - case .symbol("quasiquoteexpand"): - guard ast.count == 2 else { throw MalError.invalidArguments("quasiquoteexpand") } - return try quasiquote(ast[1]) - - case .symbol("quasiquote"): - guard ast.count == 2 else { throw MalError.invalidArguments("quasiquote") } - expr = try quasiquote(ast[1]) - - case .symbol("do"): - let exprsToEval = ast.dropFirst() - guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } - _ = try exprsToEval.dropLast().map { try eval($0, env: env) } - expr = exprsToEval.last! - - case .symbol("if"): - guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } - - switch try eval(ast[1], env: env) { - case .bool(false), .null: - if let falseBranch = ast[safe: 3] { - expr = falseBranch - } else { - expr = .null - } - default: - expr = ast[2] - } - - case .symbol("fn*"): - guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } - let binds: [String] - - switch ast[1] { - case let .list(xs, _), let .vector(xs, _): - binds = try xs.map { - guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } - return name - } - default: - throw MalError.invalidArguments("fn*") - } - - let run: ([Expr]) throws -> Expr = { args in - let fEnv = try Env(binds: binds, exprs: args, outer: env) - return try eval(ast[2], env: fEnv) - } - - let f = Func(ast: ast[2], params: binds, env: env, run: run) - return .function(f) - - default: - guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } - guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } - - let args = Array(ast.dropFirst()) - if let ast = fn.ast, let fnEnv = fn.env { - let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) - env = newEnv - expr = ast - } else { - return try fn.run(args) - } - } - } -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -func rep(_ s: String, env: Env) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr, env: env) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -let replEnv: Env = Env(data: Core.ns.data) - -replEnv.set(forKey: "eval", val: .function(Func { args in - guard let expr = args.first else { throw MalError.invalidArguments("eval") } - return try eval(expr, env: replEnv) -})) -replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) - -_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) -_ = rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) - -if CommandLine.arguments.count > 1 { - _ = rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) - exit(0) -} - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s, env: replEnv)) -} +import Foundation +import core + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +private func qq_loop(_ elt: Expr, acc: Expr) throws -> Expr { + if case let .list(xs, _) = elt { + if 0 < xs.count && xs[0] == .symbol("splice-unquote") { + guard xs.count == 2 else { throw MalError.invalidArguments("splice-unquote") } + return .list([.symbol("concat"), xs[1], acc]) + } + } + return .list([.symbol("cons"), try quasiquote(elt), acc]) +} +private func qq_foldr(_ xs: [Expr]) throws -> Expr { + var acc : Expr = .list([]) + for i in stride(from: xs.count-1, through: 0, by: -1) { + acc = try qq_loop(xs[i], acc:acc) + } + return acc +} +private func quasiquote(_ expr: Expr) throws -> Expr { + switch expr { + case let .list(xs, _): + if 0 < xs.count && xs[0] == .symbol("unquote") { + guard xs.count == 2 else { throw MalError.invalidArguments("unquote") } + return xs[1] + } else { + return try qq_foldr(xs) + } + case let .vector(xs, _): + return .list([.symbol("vec"), try qq_foldr(xs)]) + case .symbol(_), .hashmap(_): + return .list([.symbol("quote"), expr]) + default: + return expr + } +} + +private func evalAst(_ expr: Expr, env: Env) throws -> Expr { + switch expr { + case let .symbol(name): + return try env.get(name) + case let .vector(values, _): + return .vector(try values.map { try eval($0, env: env) }) + case let .hashmap(values, _): + return .hashmap(try values.mapValues { try eval($0, env: env) }) + case let .list(ast, _): + return .list(try ast.map { try eval($0, env: env) }) + default: + return expr + } +} + +func eval(_ expr: Expr, env: Env) throws -> Expr { + + var env = env + var expr = expr + + while true { + + guard case let .list(ast, _) = expr else { + return try evalAst(expr, env: env) + } + if ast.isEmpty { + return expr + } + + switch ast[0] { + + case .symbol("def!"): + guard ast.count == 3 else { throw MalError.invalidArguments("def!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } + + let val = try eval(ast[2], env: env) + env.set(forKey: name, val: val) + return val + + case .symbol("let*"): + guard ast.count == 3 else { throw MalError.invalidArguments("let*") } + + switch ast[1] { + case let .list(bindable, _), let .vector(bindable, _): + let letEnv = Env(outer: env) + + for i in stride(from: 0, to: bindable.count - 1, by: 2) { + guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } + let value = bindable[i + 1] + letEnv.set(forKey: key, val: try eval(value, env: letEnv)) + } + + expr = ast[2] + env = letEnv + default: + throw MalError.invalidArguments("let*") + } + + case .symbol("quote"): + guard ast.count == 2 else { throw MalError.invalidArguments("quote") } + return ast[1] + + case .symbol("quasiquoteexpand"): + guard ast.count == 2 else { throw MalError.invalidArguments("quasiquoteexpand") } + return try quasiquote(ast[1]) + + case .symbol("quasiquote"): + guard ast.count == 2 else { throw MalError.invalidArguments("quasiquote") } + expr = try quasiquote(ast[1]) + + case .symbol("do"): + let exprsToEval = ast.dropFirst() + guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } + _ = try exprsToEval.dropLast().map { try eval($0, env: env) } + expr = exprsToEval.last! + + case .symbol("if"): + guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } + + switch try eval(ast[1], env: env) { + case .bool(false), .null: + if let falseBranch = ast[safe: 3] { + expr = falseBranch + } else { + expr = .null + } + default: + expr = ast[2] + } + + case .symbol("fn*"): + guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } + let binds: [String] + + switch ast[1] { + case let .list(xs, _), let .vector(xs, _): + binds = try xs.map { + guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } + return name + } + default: + throw MalError.invalidArguments("fn*") + } + + let run: ([Expr]) throws -> Expr = { args in + let fEnv = try Env(binds: binds, exprs: args, outer: env) + return try eval(ast[2], env: fEnv) + } + + let f = Func(ast: ast[2], params: binds, env: env, run: run) + return .function(f) + + default: + guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } + guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } + + let args = Array(ast.dropFirst()) + if let ast = fn.ast, let fnEnv = fn.env { + let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) + env = newEnv + expr = ast + } else { + return try fn.run(args) + } + } + } +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +func rep(_ s: String, env: Env) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr, env: env) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +let replEnv: Env = Env(data: Core.ns.data) + +replEnv.set(forKey: "eval", val: .function(Func { args in + guard let expr = args.first else { throw MalError.invalidArguments("eval") } + return try eval(expr, env: replEnv) +})) +replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) + +_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) +_ = rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) + +if CommandLine.arguments.count > 1 { + _ = rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) + exit(0) +} + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s, env: replEnv)) +} diff --git a/impls/swift5/Sources/step8_macros/main.swift b/impls/swift5/Sources/step8_macros/main.swift index 9998ab62b4..132f52a9c8 100644 --- a/impls/swift5/Sources/step8_macros/main.swift +++ b/impls/swift5/Sources/step8_macros/main.swift @@ -1,237 +1,237 @@ -import Foundation -import core - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -private func qq_loop(_ elt: Expr, acc: Expr) throws -> Expr { - if case let .list(xs, _) = elt { - if 0 < xs.count && xs[0] == .symbol("splice-unquote") { - guard xs.count == 2 else { throw MalError.invalidArguments("splice-unquote") } - return .list([.symbol("concat"), xs[1], acc]) - } - } - return .list([.symbol("cons"), try quasiquote(elt), acc]) -} -private func qq_foldr(_ xs: [Expr]) throws -> Expr { - var acc : Expr = .list([]) - for i in stride(from: xs.count-1, through: 0, by: -1) { - acc = try qq_loop(xs[i], acc:acc) - } - return acc -} -private func quasiquote(_ expr: Expr) throws -> Expr { - switch expr { - case let .list(xs, _): - if 0 < xs.count && xs[0] == .symbol("unquote") { - guard xs.count == 2 else { throw MalError.invalidArguments("unquote") } - return xs[1] - } else { - return try qq_foldr(xs) - } - case let .vector(xs, _): - return .list([.symbol("vec"), try qq_foldr(xs)]) - case .symbol(_), .hashmap(_): - return .list([.symbol("quote"), expr]) - default: - return expr - } -} - -private func macroExpand(_ expr: Expr, env: Env) throws -> Expr { - var expr = expr - while true { - guard case let .list(ast, _) = expr, - case let .symbol(name) = ast.first, - case let .function(fn) = try? env.get(name), - fn.isMacro else { - break - } - - expr = try fn.run(Array(ast.dropFirst())) - } - return expr -} - -private func evalAst(_ expr: Expr, env: Env) throws -> Expr { - switch expr { - case let .symbol(name): - return try env.get(name) - case let .vector(values, _): - return .vector(try values.map { try eval($0, env: env) }) - case let .hashmap(values, _): - return .hashmap(try values.mapValues { try eval($0, env: env) }) - case let .list(ast, _): - return .list(try ast.map { try eval($0, env: env) }) - default: - return expr - } -} - -func eval(_ expr: Expr, env: Env) throws -> Expr { - - var env = env - var expr = expr - - while true { - - expr = try macroExpand(expr, env: env) - - guard case let .list(ast, _) = expr else { - return try evalAst(expr, env: env) - } - - if ast.isEmpty { - return expr - } - - switch ast[0] { - - case .symbol("def!"): - guard ast.count == 3 else { throw MalError.invalidArguments("def!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } - - let val = try eval(ast[2], env: env) - env.set(forKey: name, val: val) - return val - - case .symbol("let*"): - guard ast.count == 3 else { throw MalError.invalidArguments("let*") } - - switch ast[1] { - case let .list(bindable, _), let .vector(bindable, _): - let letEnv = Env(outer: env) - - for i in stride(from: 0, to: bindable.count - 1, by: 2) { - guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } - let value = bindable[i + 1] - letEnv.set(forKey: key, val: try eval(value, env: letEnv)) - } - - expr = ast[2] - env = letEnv - default: - throw MalError.invalidArguments("let*") - } - - case .symbol("quote"): - guard ast.count == 2 else { throw MalError.invalidArguments("quote") } - return ast[1] - - case .symbol("quasiquoteexpand"): - guard ast.count == 2 else { throw MalError.invalidArguments("quasiquoteexpand") } - return try quasiquote(ast[1]) - - case .symbol("quasiquote"): - guard ast.count == 2 else { throw MalError.invalidArguments("quasiquote") } - expr = try quasiquote(ast[1]) - - case .symbol("defmacro!"): - guard ast.count == 3 else { throw MalError.invalidArguments("defmacro!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("defmacro!") } - - guard case let .function(fn) = try eval(ast[2], env: env) else { throw MalError.invalidArguments("defmacro!") } - let macros = fn.asMacros() - env.set(forKey: name, val: .function(macros)) - return .function(macros) - - case .symbol("macroexpand"): - guard ast.count == 2 else { throw MalError.invalidArguments("macroexpand") } - return try macroExpand(ast[1], env: env) - - case .symbol("do"): - let exprsToEval = ast.dropFirst() - guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } - _ = try exprsToEval.dropLast().map { try eval($0, env: env) } - expr = exprsToEval.last! - - case .symbol("if"): - guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } - - switch try eval(ast[1], env: env) { - case .bool(false), .null: - if let falseBranch = ast[safe: 3] { - expr = falseBranch - } else { - expr = .null - } - default: - expr = ast[2] - } - - case .symbol("fn*"): - guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } - let binds: [String] - - switch ast[1] { - case let .list(xs, _), let .vector(xs, _): - binds = try xs.map { - guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } - return name - } - default: - throw MalError.invalidArguments("fn*") - } - - let run: ([Expr]) throws -> Expr = { args in - let fEnv = try Env(binds: binds, exprs: args, outer: env) - return try eval(ast[2], env: fEnv) - } - - let f = Func(ast: ast[2], params: binds, env: env, run: run) - return .function(f) - - default: - guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } - guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } - - let args = Array(ast.dropFirst()) - if let ast = fn.ast, let fnEnv = fn.env { - let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) - env = newEnv - expr = ast - } else { - return try fn.run(args) - } - } - } -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -func rep(_ s: String, env: Env) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr, env: env) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -let replEnv: Env = Env(data: Core.ns.data) - -replEnv.set(forKey: "eval", val: .function(Func { args in - guard let expr = args.first else { throw MalError.invalidArguments("eval") } - return try eval(expr, env: replEnv) -})) -replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) - -_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) -_ = rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) -_ = 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)))))))"#, env: replEnv) - -if CommandLine.arguments.count > 1 { - _ = rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) - exit(0) -} - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s, env: replEnv)) -} +import Foundation +import core + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +private func qq_loop(_ elt: Expr, acc: Expr) throws -> Expr { + if case let .list(xs, _) = elt { + if 0 < xs.count && xs[0] == .symbol("splice-unquote") { + guard xs.count == 2 else { throw MalError.invalidArguments("splice-unquote") } + return .list([.symbol("concat"), xs[1], acc]) + } + } + return .list([.symbol("cons"), try quasiquote(elt), acc]) +} +private func qq_foldr(_ xs: [Expr]) throws -> Expr { + var acc : Expr = .list([]) + for i in stride(from: xs.count-1, through: 0, by: -1) { + acc = try qq_loop(xs[i], acc:acc) + } + return acc +} +private func quasiquote(_ expr: Expr) throws -> Expr { + switch expr { + case let .list(xs, _): + if 0 < xs.count && xs[0] == .symbol("unquote") { + guard xs.count == 2 else { throw MalError.invalidArguments("unquote") } + return xs[1] + } else { + return try qq_foldr(xs) + } + case let .vector(xs, _): + return .list([.symbol("vec"), try qq_foldr(xs)]) + case .symbol(_), .hashmap(_): + return .list([.symbol("quote"), expr]) + default: + return expr + } +} + +private func macroExpand(_ expr: Expr, env: Env) throws -> Expr { + var expr = expr + while true { + guard case let .list(ast, _) = expr, + case let .symbol(name) = ast.first, + case let .function(fn) = try? env.get(name), + fn.isMacro else { + break + } + + expr = try fn.run(Array(ast.dropFirst())) + } + return expr +} + +private func evalAst(_ expr: Expr, env: Env) throws -> Expr { + switch expr { + case let .symbol(name): + return try env.get(name) + case let .vector(values, _): + return .vector(try values.map { try eval($0, env: env) }) + case let .hashmap(values, _): + return .hashmap(try values.mapValues { try eval($0, env: env) }) + case let .list(ast, _): + return .list(try ast.map { try eval($0, env: env) }) + default: + return expr + } +} + +func eval(_ expr: Expr, env: Env) throws -> Expr { + + var env = env + var expr = expr + + while true { + + expr = try macroExpand(expr, env: env) + + guard case let .list(ast, _) = expr else { + return try evalAst(expr, env: env) + } + + if ast.isEmpty { + return expr + } + + switch ast[0] { + + case .symbol("def!"): + guard ast.count == 3 else { throw MalError.invalidArguments("def!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } + + let val = try eval(ast[2], env: env) + env.set(forKey: name, val: val) + return val + + case .symbol("let*"): + guard ast.count == 3 else { throw MalError.invalidArguments("let*") } + + switch ast[1] { + case let .list(bindable, _), let .vector(bindable, _): + let letEnv = Env(outer: env) + + for i in stride(from: 0, to: bindable.count - 1, by: 2) { + guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } + let value = bindable[i + 1] + letEnv.set(forKey: key, val: try eval(value, env: letEnv)) + } + + expr = ast[2] + env = letEnv + default: + throw MalError.invalidArguments("let*") + } + + case .symbol("quote"): + guard ast.count == 2 else { throw MalError.invalidArguments("quote") } + return ast[1] + + case .symbol("quasiquoteexpand"): + guard ast.count == 2 else { throw MalError.invalidArguments("quasiquoteexpand") } + return try quasiquote(ast[1]) + + case .symbol("quasiquote"): + guard ast.count == 2 else { throw MalError.invalidArguments("quasiquote") } + expr = try quasiquote(ast[1]) + + case .symbol("defmacro!"): + guard ast.count == 3 else { throw MalError.invalidArguments("defmacro!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("defmacro!") } + + guard case let .function(fn) = try eval(ast[2], env: env) else { throw MalError.invalidArguments("defmacro!") } + let macros = fn.asMacros() + env.set(forKey: name, val: .function(macros)) + return .function(macros) + + case .symbol("macroexpand"): + guard ast.count == 2 else { throw MalError.invalidArguments("macroexpand") } + return try macroExpand(ast[1], env: env) + + case .symbol("do"): + let exprsToEval = ast.dropFirst() + guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } + _ = try exprsToEval.dropLast().map { try eval($0, env: env) } + expr = exprsToEval.last! + + case .symbol("if"): + guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } + + switch try eval(ast[1], env: env) { + case .bool(false), .null: + if let falseBranch = ast[safe: 3] { + expr = falseBranch + } else { + expr = .null + } + default: + expr = ast[2] + } + + case .symbol("fn*"): + guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } + let binds: [String] + + switch ast[1] { + case let .list(xs, _), let .vector(xs, _): + binds = try xs.map { + guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } + return name + } + default: + throw MalError.invalidArguments("fn*") + } + + let run: ([Expr]) throws -> Expr = { args in + let fEnv = try Env(binds: binds, exprs: args, outer: env) + return try eval(ast[2], env: fEnv) + } + + let f = Func(ast: ast[2], params: binds, env: env, run: run) + return .function(f) + + default: + guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } + guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } + + let args = Array(ast.dropFirst()) + if let ast = fn.ast, let fnEnv = fn.env { + let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) + env = newEnv + expr = ast + } else { + return try fn.run(args) + } + } + } +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +func rep(_ s: String, env: Env) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr, env: env) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +let replEnv: Env = Env(data: Core.ns.data) + +replEnv.set(forKey: "eval", val: .function(Func { args in + guard let expr = args.first else { throw MalError.invalidArguments("eval") } + return try eval(expr, env: replEnv) +})) +replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) + +_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) +_ = rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) +_ = 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)))))))"#, env: replEnv) + +if CommandLine.arguments.count > 1 { + _ = rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) + exit(0) +} + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s, env: replEnv)) +} diff --git a/impls/swift5/Sources/step9_try/main.swift b/impls/swift5/Sources/step9_try/main.swift index 91c5a34cdf..37d409dba8 100644 --- a/impls/swift5/Sources/step9_try/main.swift +++ b/impls/swift5/Sources/step9_try/main.swift @@ -1,256 +1,256 @@ -import Foundation -import core - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -private func qq_loop(_ elt: Expr, acc: Expr) throws -> Expr { - if case let .list(xs, _) = elt { - if 0 < xs.count && xs[0] == .symbol("splice-unquote") { - guard xs.count == 2 else { throw MalError.invalidArguments("splice-unquote") } - return .list([.symbol("concat"), xs[1], acc]) - } - } - return .list([.symbol("cons"), try quasiquote(elt), acc]) -} -private func qq_foldr(_ xs: [Expr]) throws -> Expr { - var acc : Expr = .list([]) - for i in stride(from: xs.count-1, through: 0, by: -1) { - acc = try qq_loop(xs[i], acc:acc) - } - return acc -} -private func quasiquote(_ expr: Expr) throws -> Expr { - switch expr { - case let .list(xs, _): - if 0 < xs.count && xs[0] == .symbol("unquote") { - guard xs.count == 2 else { throw MalError.invalidArguments("unquote") } - return xs[1] - } else { - return try qq_foldr(xs) - } - case let .vector(xs, _): - return .list([.symbol("vec"), try qq_foldr(xs)]) - case .symbol(_), .hashmap(_): - return .list([.symbol("quote"), expr]) - default: - return expr - } -} - -private func macroExpand(_ expr: Expr, env: Env) throws -> Expr { - var expr = expr - while true { - guard case let .list(ast, _) = expr, - case let .symbol(name) = ast.first, - case let .function(fn) = try? env.get(name), - fn.isMacro else { - break - } - - expr = try fn.run(Array(ast.dropFirst())) - } - return expr -} - -private func evalAst(_ expr: Expr, env: Env) throws -> Expr { - switch expr { - case let .symbol(name): - return try env.get(name) - case let .vector(values, _): - return .vector(try values.map { try eval($0, env: env) }) - case let .hashmap(values, _): - return .hashmap(try values.mapValues { try eval($0, env: env) }) - case let .list(ast, _): - return .list(try ast.map { try eval($0, env: env) }) - default: - return expr - } -} - -func eval(_ expr: Expr, env: Env) throws -> Expr { - - var env = env - var expr = expr - - while true { - - expr = try macroExpand(expr, env: env) - - guard case let .list(ast, _) = expr else { - return try evalAst(expr, env: env) - } - - if ast.isEmpty { - return expr - } - - switch ast[0] { - - case .symbol("def!"): - guard ast.count == 3 else { throw MalError.invalidArguments("def!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } - - let val = try eval(ast[2], env: env) - env.set(forKey: name, val: val) - return val - - case .symbol("let*"): - guard ast.count == 3 else { throw MalError.invalidArguments("let*") } - - switch ast[1] { - case let .list(bindable, _), let .vector(bindable, _): - let letEnv = Env(outer: env) - - for i in stride(from: 0, to: bindable.count - 1, by: 2) { - guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } - let value = bindable[i + 1] - letEnv.set(forKey: key, val: try eval(value, env: letEnv)) - } - - expr = ast[2] - env = letEnv - default: - throw MalError.invalidArguments("let*") - } - - case .symbol("quote"): - guard ast.count == 2 else { throw MalError.invalidArguments("quote") } - return ast[1] - - case .symbol("quasiquoteexpand"): - guard ast.count == 2 else { throw MalError.invalidArguments("quasiquoteexpand") } - return try quasiquote(ast[1]) - - case .symbol("quasiquote"): - guard ast.count == 2 else { throw MalError.invalidArguments("quasiquote") } - expr = try quasiquote(ast[1]) - - case .symbol("defmacro!"): - guard ast.count == 3 else { throw MalError.invalidArguments("defmacro!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("defmacro!") } - - guard case let .function(fn) = try eval(ast[2], env: env) else { throw MalError.invalidArguments("defmacro!") } - let macros = fn.asMacros() - env.set(forKey: name, val: .function(macros)) - return .function(macros) - - case .symbol("macroexpand"): - guard ast.count == 2 else { throw MalError.invalidArguments("macroexpand") } - return try macroExpand(ast[1], env: env) - - case .symbol("try*"): - if ast.count == 2 { - expr = ast[1] - continue - } - guard ast.count == 3 else { throw MalError.invalidArguments("try*") } - guard case let .list(values, _) = ast[2], values.count == 3 else { throw MalError.invalidArguments("try*") } - guard case .symbol("catch*") = values[0] else { throw MalError.invalidArguments("try*") } - guard case let .symbol(bind) = values[1] else { throw MalError.invalidArguments("catch*") } - - do { - expr = try eval(ast[1], env: env) - } catch { - let malErr = (error as? Expr) ?? .string(error.localizedDescription) - let newEnv = try Env(binds: [bind], exprs: [malErr], outer: env) - env = newEnv - expr = values[2] - } - - case .symbol("do"): - let exprsToEval = ast.dropFirst() - guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } - _ = try exprsToEval.dropLast().map { try eval($0, env: env) } - expr = exprsToEval.last! - - case .symbol("if"): - guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } - - switch try eval(ast[1], env: env) { - case .bool(false), .null: - if let falseBranch = ast[safe: 3] { - expr = falseBranch - } else { - expr = .null - } - default: - expr = ast[2] - } - - case .symbol("fn*"): - guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } - let binds: [String] - - switch ast[1] { - case let .list(xs, _), let .vector(xs, _): - binds = try xs.map { - guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } - return name - } - default: - throw MalError.invalidArguments("fn*") - } - - let run: ([Expr]) throws -> Expr = { args in - let fEnv = try Env(binds: binds, exprs: args, outer: env) - return try eval(ast[2], env: fEnv) - } - - let f = Func(ast: ast[2], params: binds, env: env, run: run) - return .function(f) - - default: - guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } - guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } - - let args = Array(ast.dropFirst()) - if let ast = fn.ast, let fnEnv = fn.env { - let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) - env = newEnv - expr = ast - } else { - return try fn.run(args) - } - } - } -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -func rep(_ s: String, env: Env) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr, env: env) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -let replEnv: Env = Env(data: Core.ns.data) - -replEnv.set(forKey: "eval", val: .function(Func { args in - guard let expr = args.first else { throw MalError.invalidArguments("eval") } - return try eval(expr, env: replEnv) -})) -replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) - -_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) -_ = rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) -_ = 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)))))))"#, env: replEnv) - -if CommandLine.arguments.count > 1 { - _ = rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) - exit(0) -} - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s, env: replEnv)) -} +import Foundation +import core + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +private func qq_loop(_ elt: Expr, acc: Expr) throws -> Expr { + if case let .list(xs, _) = elt { + if 0 < xs.count && xs[0] == .symbol("splice-unquote") { + guard xs.count == 2 else { throw MalError.invalidArguments("splice-unquote") } + return .list([.symbol("concat"), xs[1], acc]) + } + } + return .list([.symbol("cons"), try quasiquote(elt), acc]) +} +private func qq_foldr(_ xs: [Expr]) throws -> Expr { + var acc : Expr = .list([]) + for i in stride(from: xs.count-1, through: 0, by: -1) { + acc = try qq_loop(xs[i], acc:acc) + } + return acc +} +private func quasiquote(_ expr: Expr) throws -> Expr { + switch expr { + case let .list(xs, _): + if 0 < xs.count && xs[0] == .symbol("unquote") { + guard xs.count == 2 else { throw MalError.invalidArguments("unquote") } + return xs[1] + } else { + return try qq_foldr(xs) + } + case let .vector(xs, _): + return .list([.symbol("vec"), try qq_foldr(xs)]) + case .symbol(_), .hashmap(_): + return .list([.symbol("quote"), expr]) + default: + return expr + } +} + +private func macroExpand(_ expr: Expr, env: Env) throws -> Expr { + var expr = expr + while true { + guard case let .list(ast, _) = expr, + case let .symbol(name) = ast.first, + case let .function(fn) = try? env.get(name), + fn.isMacro else { + break + } + + expr = try fn.run(Array(ast.dropFirst())) + } + return expr +} + +private func evalAst(_ expr: Expr, env: Env) throws -> Expr { + switch expr { + case let .symbol(name): + return try env.get(name) + case let .vector(values, _): + return .vector(try values.map { try eval($0, env: env) }) + case let .hashmap(values, _): + return .hashmap(try values.mapValues { try eval($0, env: env) }) + case let .list(ast, _): + return .list(try ast.map { try eval($0, env: env) }) + default: + return expr + } +} + +func eval(_ expr: Expr, env: Env) throws -> Expr { + + var env = env + var expr = expr + + while true { + + expr = try macroExpand(expr, env: env) + + guard case let .list(ast, _) = expr else { + return try evalAst(expr, env: env) + } + + if ast.isEmpty { + return expr + } + + switch ast[0] { + + case .symbol("def!"): + guard ast.count == 3 else { throw MalError.invalidArguments("def!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } + + let val = try eval(ast[2], env: env) + env.set(forKey: name, val: val) + return val + + case .symbol("let*"): + guard ast.count == 3 else { throw MalError.invalidArguments("let*") } + + switch ast[1] { + case let .list(bindable, _), let .vector(bindable, _): + let letEnv = Env(outer: env) + + for i in stride(from: 0, to: bindable.count - 1, by: 2) { + guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } + let value = bindable[i + 1] + letEnv.set(forKey: key, val: try eval(value, env: letEnv)) + } + + expr = ast[2] + env = letEnv + default: + throw MalError.invalidArguments("let*") + } + + case .symbol("quote"): + guard ast.count == 2 else { throw MalError.invalidArguments("quote") } + return ast[1] + + case .symbol("quasiquoteexpand"): + guard ast.count == 2 else { throw MalError.invalidArguments("quasiquoteexpand") } + return try quasiquote(ast[1]) + + case .symbol("quasiquote"): + guard ast.count == 2 else { throw MalError.invalidArguments("quasiquote") } + expr = try quasiquote(ast[1]) + + case .symbol("defmacro!"): + guard ast.count == 3 else { throw MalError.invalidArguments("defmacro!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("defmacro!") } + + guard case let .function(fn) = try eval(ast[2], env: env) else { throw MalError.invalidArguments("defmacro!") } + let macros = fn.asMacros() + env.set(forKey: name, val: .function(macros)) + return .function(macros) + + case .symbol("macroexpand"): + guard ast.count == 2 else { throw MalError.invalidArguments("macroexpand") } + return try macroExpand(ast[1], env: env) + + case .symbol("try*"): + if ast.count == 2 { + expr = ast[1] + continue + } + guard ast.count == 3 else { throw MalError.invalidArguments("try*") } + guard case let .list(values, _) = ast[2], values.count == 3 else { throw MalError.invalidArguments("try*") } + guard case .symbol("catch*") = values[0] else { throw MalError.invalidArguments("try*") } + guard case let .symbol(bind) = values[1] else { throw MalError.invalidArguments("catch*") } + + do { + expr = try eval(ast[1], env: env) + } catch { + let malErr = (error as? Expr) ?? .string(error.localizedDescription) + let newEnv = try Env(binds: [bind], exprs: [malErr], outer: env) + env = newEnv + expr = values[2] + } + + case .symbol("do"): + let exprsToEval = ast.dropFirst() + guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } + _ = try exprsToEval.dropLast().map { try eval($0, env: env) } + expr = exprsToEval.last! + + case .symbol("if"): + guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } + + switch try eval(ast[1], env: env) { + case .bool(false), .null: + if let falseBranch = ast[safe: 3] { + expr = falseBranch + } else { + expr = .null + } + default: + expr = ast[2] + } + + case .symbol("fn*"): + guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } + let binds: [String] + + switch ast[1] { + case let .list(xs, _), let .vector(xs, _): + binds = try xs.map { + guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } + return name + } + default: + throw MalError.invalidArguments("fn*") + } + + let run: ([Expr]) throws -> Expr = { args in + let fEnv = try Env(binds: binds, exprs: args, outer: env) + return try eval(ast[2], env: fEnv) + } + + let f = Func(ast: ast[2], params: binds, env: env, run: run) + return .function(f) + + default: + guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } + guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } + + let args = Array(ast.dropFirst()) + if let ast = fn.ast, let fnEnv = fn.env { + let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) + env = newEnv + expr = ast + } else { + return try fn.run(args) + } + } + } +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +func rep(_ s: String, env: Env) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr, env: env) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +let replEnv: Env = Env(data: Core.ns.data) + +replEnv.set(forKey: "eval", val: .function(Func { args in + guard let expr = args.first else { throw MalError.invalidArguments("eval") } + return try eval(expr, env: replEnv) +})) +replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) + +_ = rep("(def! not (fn* (a) (if a false true)))", env: replEnv) +_ = rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) +_ = 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)))))))"#, env: replEnv) + +if CommandLine.arguments.count > 1 { + _ = rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) + exit(0) +} + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s, env: replEnv)) +} diff --git a/impls/swift5/Sources/stepA_mal/main.swift b/impls/swift5/Sources/stepA_mal/main.swift index 1f0aa5b1c1..88ef7372e3 100644 --- a/impls/swift5/Sources/stepA_mal/main.swift +++ b/impls/swift5/Sources/stepA_mal/main.swift @@ -1,260 +1,260 @@ -import Foundation -import core - -func read(_ s: String) throws -> Expr { - return try Reader.read(s) -} - -private func qq_loop(_ elt: Expr, acc: Expr) throws -> Expr { - if case let .list(xs, _) = elt { - if 0 < xs.count && xs[0] == .symbol("splice-unquote") { - guard xs.count == 2 else { throw MalError.invalidArguments("splice-unquote") } - return .list([.symbol("concat"), xs[1], acc]) - } - } - return .list([.symbol("cons"), try quasiquote(elt), acc]) -} -private func qq_foldr(_ xs: [Expr]) throws -> Expr { - var acc : Expr = .list([]) - for i in stride(from: xs.count-1, through: 0, by: -1) { - acc = try qq_loop(xs[i], acc:acc) - } - return acc -} -private func quasiquote(_ expr: Expr) throws -> Expr { - switch expr { - case let .list(xs, _): - if 0 < xs.count && xs[0] == .symbol("unquote") { - guard xs.count == 2 else { throw MalError.invalidArguments("unquote") } - return xs[1] - } else { - return try qq_foldr(xs) - } - case let .vector(xs, _): - return .list([.symbol("vec"), try qq_foldr(xs)]) - case .symbol(_), .hashmap(_): - return .list([.symbol("quote"), expr]) - default: - return expr - } -} - -private func macroExpand(_ expr: Expr, env: Env) throws -> Expr { - var expr = expr - while true { - guard case let .list(ast, _) = expr, - case let .symbol(name) = ast.first, - case let .function(fn) = try? env.get(name), - fn.isMacro else { - break - } - - expr = try fn.run(Array(ast.dropFirst())) - } - return expr -} - -private func evalAst(_ expr: Expr, env: Env) throws -> Expr { - switch expr { - case let .symbol(name): - return try env.get(name) - case let .vector(values, _): - return .vector(try values.map { try eval($0, env: env) }) - case let .hashmap(values, _): - return .hashmap(try values.mapValues { try eval($0, env: env) }) - case let .list(ast, _): - return .list(try ast.map { try eval($0, env: env) }) - default: - return expr - } -} - -func eval(_ expr: Expr, env: Env) throws -> Expr { - - var env = env - var expr = expr - - while true { - - expr = try macroExpand(expr, env: env) - - guard case let .list(ast, _) = expr else { - return try evalAst(expr, env: env) - } - - if ast.isEmpty { - return expr - } - - switch ast[0] { - - case .symbol("def!"): - guard ast.count == 3 else { throw MalError.invalidArguments("def!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } - - let val = try eval(ast[2], env: env) - env.set(forKey: name, val: val) - return val - - case .symbol("let*"): - guard ast.count == 3 else { throw MalError.invalidArguments("let*") } - - switch ast[1] { - case let .list(bindable, _), let .vector(bindable, _): - let letEnv = Env(outer: env) - - for i in stride(from: 0, to: bindable.count - 1, by: 2) { - guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } - let value = bindable[i + 1] - letEnv.set(forKey: key, val: try eval(value, env: letEnv)) - } - - expr = ast[2] - env = letEnv - default: - throw MalError.invalidArguments("let*") - } - - case .symbol("quote"): - guard ast.count == 2 else { throw MalError.invalidArguments("quote") } - return ast[1] - - case .symbol("quasiquoteexpand"): - guard ast.count == 2 else { throw MalError.invalidArguments("quasiquoteexpand") } - return try quasiquote(ast[1]) - - case .symbol("quasiquote"): - guard ast.count == 2 else { throw MalError.invalidArguments("quasiquote") } - expr = try quasiquote(ast[1]) - - case .symbol("defmacro!"): - guard ast.count == 3 else { throw MalError.invalidArguments("defmacro!") } - guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("defmacro!") } - - guard case let .function(fn) = try eval(ast[2], env: env) else { throw MalError.invalidArguments("defmacro!") } - let macros = fn.asMacros() - env.set(forKey: name, val: .function(macros)) - return .function(macros) - - case .symbol("macroexpand"): - guard ast.count == 2 else { throw MalError.invalidArguments("macroexpand") } - return try macroExpand(ast[1], env: env) - - case .symbol("try*"): - if ast.count == 2 { - expr = ast[1] - continue - } - guard ast.count == 3 else { throw MalError.invalidArguments("try*") } - guard case let .list(values, _) = ast[2], values.count == 3 else { throw MalError.invalidArguments("try*") } - guard case .symbol("catch*") = values[0] else { throw MalError.invalidArguments("try*") } - guard case let .symbol(bind) = values[1] else { throw MalError.invalidArguments("catch*") } - - do { - expr = try eval(ast[1], env: env) - } catch { - let malErr = (error as? Expr) ?? .string(error.localizedDescription) - let newEnv = try Env(binds: [bind], exprs: [malErr], outer: env) - env = newEnv - expr = values[2] - } - - case .symbol("do"): - let exprsToEval = ast.dropFirst() - guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } - _ = try exprsToEval.dropLast().map { try eval($0, env: env) } - expr = exprsToEval.last! - - case .symbol("if"): - guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } - - switch try eval(ast[1], env: env) { - case .bool(false), .null: - if let falseBranch = ast[safe: 3] { - expr = falseBranch - } else { - expr = .null - } - default: - expr = ast[2] - } - - case .symbol("fn*"): - guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } - let binds: [String] - - switch ast[1] { - case let .list(xs, _), let .vector(xs, _): - binds = try xs.map { - guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } - return name - } - default: - throw MalError.invalidArguments("fn*") - } - - let run: ([Expr]) throws -> Expr = { args in - let fEnv = try Env(binds: binds, exprs: args, outer: env) - return try eval(ast[2], env: fEnv) - } - - let f = Func(ast: ast[2], params: binds, env: env, run: run) - return .function(f) - - default: - guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } - guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } - - let args = Array(ast.dropFirst()) - if let ast = fn.ast, let fnEnv = fn.env { - let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) - env = newEnv - expr = ast - } else { - return try fn.run(args) - } - } - } -} - -func print(_ expr: Expr) -> String { - return Expr.print(expr) -} - -@discardableResult -func rep(_ s: String, env: Env) -> String { - do { - let expr = try read(s) - let resExpr = try eval(expr, env: env) - let resultStr = print(resExpr) - return resultStr - } catch { - return error.localizedDescription - } -} - -let replEnv: Env = Env(data: Core.ns.data) - -replEnv.set(forKey: "eval", val: .function(Func { args in - guard let expr = args.first else { throw MalError.invalidArguments("eval") } - return try eval(expr, env: replEnv) -})) -replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) -replEnv.set(forKey: "*host-language*", val: .string("swift5")) - -rep("(def! not (fn* (a) (if a false true)))", env: replEnv) -rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) -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)))))))"#, env: replEnv) - -if CommandLine.arguments.count > 1 { - rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) - exit(0) -} - -rep(#"(println (str "Mal [" *host-language* "]"))"#, env: replEnv) - -while true { - print("user> ", terminator: "") - guard let s = readLine() else { break } - print(rep(s, env: replEnv)) -} +import Foundation +import core + +func read(_ s: String) throws -> Expr { + return try Reader.read(s) +} + +private func qq_loop(_ elt: Expr, acc: Expr) throws -> Expr { + if case let .list(xs, _) = elt { + if 0 < xs.count && xs[0] == .symbol("splice-unquote") { + guard xs.count == 2 else { throw MalError.invalidArguments("splice-unquote") } + return .list([.symbol("concat"), xs[1], acc]) + } + } + return .list([.symbol("cons"), try quasiquote(elt), acc]) +} +private func qq_foldr(_ xs: [Expr]) throws -> Expr { + var acc : Expr = .list([]) + for i in stride(from: xs.count-1, through: 0, by: -1) { + acc = try qq_loop(xs[i], acc:acc) + } + return acc +} +private func quasiquote(_ expr: Expr) throws -> Expr { + switch expr { + case let .list(xs, _): + if 0 < xs.count && xs[0] == .symbol("unquote") { + guard xs.count == 2 else { throw MalError.invalidArguments("unquote") } + return xs[1] + } else { + return try qq_foldr(xs) + } + case let .vector(xs, _): + return .list([.symbol("vec"), try qq_foldr(xs)]) + case .symbol(_), .hashmap(_): + return .list([.symbol("quote"), expr]) + default: + return expr + } +} + +private func macroExpand(_ expr: Expr, env: Env) throws -> Expr { + var expr = expr + while true { + guard case let .list(ast, _) = expr, + case let .symbol(name) = ast.first, + case let .function(fn) = try? env.get(name), + fn.isMacro else { + break + } + + expr = try fn.run(Array(ast.dropFirst())) + } + return expr +} + +private func evalAst(_ expr: Expr, env: Env) throws -> Expr { + switch expr { + case let .symbol(name): + return try env.get(name) + case let .vector(values, _): + return .vector(try values.map { try eval($0, env: env) }) + case let .hashmap(values, _): + return .hashmap(try values.mapValues { try eval($0, env: env) }) + case let .list(ast, _): + return .list(try ast.map { try eval($0, env: env) }) + default: + return expr + } +} + +func eval(_ expr: Expr, env: Env) throws -> Expr { + + var env = env + var expr = expr + + while true { + + expr = try macroExpand(expr, env: env) + + guard case let .list(ast, _) = expr else { + return try evalAst(expr, env: env) + } + + if ast.isEmpty { + return expr + } + + switch ast[0] { + + case .symbol("def!"): + guard ast.count == 3 else { throw MalError.invalidArguments("def!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("def!") } + + let val = try eval(ast[2], env: env) + env.set(forKey: name, val: val) + return val + + case .symbol("let*"): + guard ast.count == 3 else { throw MalError.invalidArguments("let*") } + + switch ast[1] { + case let .list(bindable, _), let .vector(bindable, _): + let letEnv = Env(outer: env) + + for i in stride(from: 0, to: bindable.count - 1, by: 2) { + guard case let .symbol(key) = bindable[i] else { throw MalError.invalidArguments("let*") } + let value = bindable[i + 1] + letEnv.set(forKey: key, val: try eval(value, env: letEnv)) + } + + expr = ast[2] + env = letEnv + default: + throw MalError.invalidArguments("let*") + } + + case .symbol("quote"): + guard ast.count == 2 else { throw MalError.invalidArguments("quote") } + return ast[1] + + case .symbol("quasiquoteexpand"): + guard ast.count == 2 else { throw MalError.invalidArguments("quasiquoteexpand") } + return try quasiquote(ast[1]) + + case .symbol("quasiquote"): + guard ast.count == 2 else { throw MalError.invalidArguments("quasiquote") } + expr = try quasiquote(ast[1]) + + case .symbol("defmacro!"): + guard ast.count == 3 else { throw MalError.invalidArguments("defmacro!") } + guard case let .symbol(name) = ast[1] else { throw MalError.invalidArguments("defmacro!") } + + guard case let .function(fn) = try eval(ast[2], env: env) else { throw MalError.invalidArguments("defmacro!") } + let macros = fn.asMacros() + env.set(forKey: name, val: .function(macros)) + return .function(macros) + + case .symbol("macroexpand"): + guard ast.count == 2 else { throw MalError.invalidArguments("macroexpand") } + return try macroExpand(ast[1], env: env) + + case .symbol("try*"): + if ast.count == 2 { + expr = ast[1] + continue + } + guard ast.count == 3 else { throw MalError.invalidArguments("try*") } + guard case let .list(values, _) = ast[2], values.count == 3 else { throw MalError.invalidArguments("try*") } + guard case .symbol("catch*") = values[0] else { throw MalError.invalidArguments("try*") } + guard case let .symbol(bind) = values[1] else { throw MalError.invalidArguments("catch*") } + + do { + expr = try eval(ast[1], env: env) + } catch { + let malErr = (error as? Expr) ?? .string(error.localizedDescription) + let newEnv = try Env(binds: [bind], exprs: [malErr], outer: env) + env = newEnv + expr = values[2] + } + + case .symbol("do"): + let exprsToEval = ast.dropFirst() + guard !exprsToEval.isEmpty else { throw MalError.invalidArguments("do") } + _ = try exprsToEval.dropLast().map { try eval($0, env: env) } + expr = exprsToEval.last! + + case .symbol("if"): + guard 3...4 ~= ast.count else { throw MalError.invalidArguments("if") } + + switch try eval(ast[1], env: env) { + case .bool(false), .null: + if let falseBranch = ast[safe: 3] { + expr = falseBranch + } else { + expr = .null + } + default: + expr = ast[2] + } + + case .symbol("fn*"): + guard ast.count == 3 else { throw MalError.invalidArguments("fn*") } + let binds: [String] + + switch ast[1] { + case let .list(xs, _), let .vector(xs, _): + binds = try xs.map { + guard case let .symbol(name) = $0 else { throw MalError.invalidArguments("fn*") } + return name + } + default: + throw MalError.invalidArguments("fn*") + } + + let run: ([Expr]) throws -> Expr = { args in + let fEnv = try Env(binds: binds, exprs: args, outer: env) + return try eval(ast[2], env: fEnv) + } + + let f = Func(ast: ast[2], params: binds, env: env, run: run) + return .function(f) + + default: + guard case let .list(ast, _) = try evalAst(expr, env: env) else { fatalError() } + guard case let .function(fn) = ast[0] else { throw MalError.invalidFunctionCall(ast[0]) } + + let args = Array(ast.dropFirst()) + if let ast = fn.ast, let fnEnv = fn.env { + let newEnv = try Env(binds: fn.params, exprs: args, outer: fnEnv) + env = newEnv + expr = ast + } else { + return try fn.run(args) + } + } + } +} + +func print(_ expr: Expr) -> String { + return Expr.print(expr) +} + +@discardableResult +func rep(_ s: String, env: Env) -> String { + do { + let expr = try read(s) + let resExpr = try eval(expr, env: env) + let resultStr = print(resExpr) + return resultStr + } catch { + return error.localizedDescription + } +} + +let replEnv: Env = Env(data: Core.ns.data) + +replEnv.set(forKey: "eval", val: .function(Func { args in + guard let expr = args.first else { throw MalError.invalidArguments("eval") } + return try eval(expr, env: replEnv) +})) +replEnv.set(forKey: "*ARGV*", val: .list(CommandLine.arguments.dropFirst(2).map(Expr.string))) +replEnv.set(forKey: "*host-language*", val: .string("swift5")) + +rep("(def! not (fn* (a) (if a false true)))", env: replEnv) +rep(#"(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))"#, env: replEnv) +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)))))))"#, env: replEnv) + +if CommandLine.arguments.count > 1 { + rep("(load-file \"" + CommandLine.arguments[1] + "\")", env: replEnv) + exit(0) +} + +rep(#"(println (str "Mal [" *host-language* "]"))"#, env: replEnv) + +while true { + print("user> ", terminator: "") + guard let s = readLine() else { break } + print(rep(s, env: replEnv)) +} diff --git a/impls/swift5/run b/impls/swift5/run index ee43964797..c2417d10e1 100755 --- a/impls/swift5/run +++ b/impls/swift5/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/out/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/out/${STEP:-stepA_mal} "${@}" diff --git a/impls/tcl/Dockerfile b/impls/tcl/Dockerfile index 2ad3f330c3..fbb0b566a5 100644 --- a/impls/tcl/Dockerfile +++ b/impls/tcl/Dockerfile @@ -1,26 +1,26 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install tcl tcl-tclreadline - -ENV HOME /mal +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install tcl tcl-tclreadline + +ENV HOME /mal diff --git a/impls/tcl/Makefile b/impls/tcl/Makefile index ba4ddbb379..c3a25f69ff 100644 --- a/impls/tcl/Makefile +++ b/impls/tcl/Makefile @@ -1,19 +1,19 @@ -SOURCES_BASE = mal_readline.tcl types.tcl reader.tcl printer.tcl -SOURCES_LISP = env.tcl core.tcl stepA_mal.tcl -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: - true - -dist: mal.tcl mal - -mal.tcl: $(SOURCES) - cat $+ | grep -v "^source " > $@ - -mal: mal.tcl - echo "#!/usr/bin/env tclsh" > $@ - cat $< >> $@ - chmod +x $@ - -clean: - rm -f mal.tcl mal +SOURCES_BASE = mal_readline.tcl types.tcl reader.tcl printer.tcl +SOURCES_LISP = env.tcl core.tcl stepA_mal.tcl +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: + true + +dist: mal.tcl mal + +mal.tcl: $(SOURCES) + cat $+ | grep -v "^source " > $@ + +mal: mal.tcl + echo "#!/usr/bin/env tclsh" > $@ + cat $< >> $@ + chmod +x $@ + +clean: + rm -f mal.tcl mal diff --git a/impls/tcl/core.tcl b/impls/tcl/core.tcl index 2485c87db1..18a4313e31 100644 --- a/impls/tcl/core.tcl +++ b/impls/tcl/core.tcl @@ -1,475 +1,475 @@ -proc mal_equal {a} { - bool_new [equal_q [lindex $a 0] [lindex $a 1]] -} - -set ::mal_exception_obj 0 -proc mal_throw {a} { - set ::mal_exception_obj [lindex $a 0] - error "__MalException__" -} - -proc mal_nil_q {a} { - bool_new [nil_q [lindex $a 0]] -} - -proc mal_true_q {a} { - bool_new [true_q [lindex $a 0]] -} - -proc mal_false_q {a} { - bool_new [false_q [lindex $a 0]] -} - -proc mal_symbol {a} { - symbol_new [obj_val [lindex $a 0]] -} - -proc mal_symbol_q {a} { - bool_new [symbol_q [lindex $a 0]] -} - -proc mal_string_q {a} { - bool_new [string_q [lindex $a 0]] -} - -proc mal_keyword {a} { - lassign $a a0 - if {[keyword_q $a0]} { - return $a0 - } - keyword_new [obj_val $a0] -} - -proc mal_keyword_q {a} { - bool_new [keyword_q [lindex $a 0]] -} - -proc mal_number_q {a} { - bool_new [integer_q [lindex $a 0]] -} - -proc mal_fn_q {a} { - set f [lindex $a 0] - switch [obj_type $f] { - function { return [bool_new [expr {![macro_q $f]}]] } - nativefunction { return $::mal_true } - default { return $::mal_false } - } -} - -proc mal_macro_q {a} { - bool_new [macro_q [lindex $a 0]] -} - -proc render_array {arr readable delim} { - set res {} - foreach e $arr { - lappend res [pr_str $e $readable] - } - join $res $delim -} - -proc mal_pr_str {a} { - string_new [render_array $a 1 " "] -} - -proc mal_str {a} { - string_new [render_array $a 0 ""] -} - -proc mal_prn {a} { - puts [render_array $a 1 " "] - return $::mal_nil -} - -proc mal_println {a} { - puts [render_array $a 0 " "] - return $::mal_nil -} - -proc mal_read_string {a} { - read_str [obj_val [lindex $a 0]] -} - -proc mal_readline {a} { - set prompt [obj_val [lindex $a 0]] - set res [_readline $prompt] - if {[lindex $res 0] == "EOF"} { - return $::mal_nil - } - string_new [lindex $res 1] -} - -proc mal_slurp {a} { - set filename [obj_val [lindex $a 0]] - set file [open $filename] - set content [read $file] - close $file - string_new $content -} - -proc mal_lt {a} { - bool_new [expr {[obj_val [lindex $a 0]] < [obj_val [lindex $a 1]]}] -} - -proc mal_lte {a} { - bool_new [expr {[obj_val [lindex $a 0]] <= [obj_val [lindex $a 1]]}] -} - -proc mal_gt {a} { - bool_new [expr {[obj_val [lindex $a 0]] > [obj_val [lindex $a 1]]}] -} - -proc mal_gte {a} { - bool_new [expr {[obj_val [lindex $a 0]] >= [obj_val [lindex $a 1]]}] -} - -proc mal_add {a} { - integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}] -} - -proc mal_sub {a} { - integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}] -} - -proc mal_mul {a} { - integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}] -} - -proc mal_div {a} { - integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}] -} - -proc mal_time_ms {a} { - integer_new [clock milliseconds] -} - -proc mal_list {a} { - list_new $a -} - -proc mal_list_q {a} { - bool_new [list_q [lindex $a 0]] -} - -proc mal_vector {a} { - vector_new $a -} - -proc mal_vector_q {a} { - bool_new [vector_q [lindex $a 0]] -} - -proc mal_hash_map {a} { - set d [dict create] - foreach {k v} $a { - dict set d [obj_val $k] $v - } - hashmap_new $d -} - -proc mal_map_q {a} { - bool_new [hashmap_q [lindex $a 0]] -} - -proc mal_assoc {a} { - set d [dict create] - dict for {k v} [obj_val [lindex $a 0]] { - dict set d $k $v - } - foreach {k v} [lrange $a 1 end] { - dict set d [obj_val $k] $v - } - hashmap_new $d -} - -proc mal_dissoc {a} { - set d [dict create] - dict for {k v} [obj_val [lindex $a 0]] { - dict set d $k $v - } - foreach k [lrange $a 1 end] { - dict unset d [obj_val $k] - } - hashmap_new $d -} - -proc mal_get {a} { - lassign $a hashmap_obj key_obj - if {[dict exists [obj_val $hashmap_obj] [obj_val $key_obj]]} { - dict get [obj_val $hashmap_obj] [obj_val $key_obj] - } else { - return $::mal_nil - } -} - -proc mal_contains_q {a} { - lassign $a hashmap_obj key_obj - bool_new [dict exists [obj_val $hashmap_obj] [obj_val $key_obj]] -} - -proc mal_keys {a} { - set res {} - foreach k [dict keys [obj_val [lindex $a 0]]] { - lappend res [string_new $k] - } - list_new $res -} - -proc mal_vals {a} { - list_new [dict values [obj_val [lindex $a 0]]] -} - -proc mal_sequential_q {a} { - bool_new [sequential_q [lindex $a 0]] -} - -proc mal_cons {a} { - lassign $a head lst - list_new [concat [list $head] [obj_val $lst]] -} - -proc mal_concat {a} { - set res {} - foreach lst $a { - if {[nil_q $lst]} { - continue - } - set res [concat $res [obj_val $lst]] - } - list_new $res -} - -proc mal_vec {a} { - lassign $a a0 - if {[vector_q $a0]} { - return $a0 - } elseif {[list_q $a0]} { - return [vector_new [obj_val $a0]] - } else { - error "vec requires list or vector" - } -} - -proc mal_nth {a} { - lassign $a lst_obj index_obj - set index [obj_val $index_obj] - set lst [obj_val $lst_obj] - if {$index >= [llength $lst]} { - error "nth: index out of range" - } - lindex $lst $index -} - -proc mal_first {a} { - lassign $a lst - if {[nil_q $lst] || [llength [obj_val $lst]] == 0} { - return $::mal_nil - } - lindex [obj_val $lst] 0 -} - -proc mal_rest {a} { - lassign $a lst - list_new [lrange [obj_val $lst] 1 end] -} - -proc mal_empty_q {a} { - bool_new [expr {[llength [obj_val [lindex $a 0]]] == 0}] -} - -proc mal_count {a} { - integer_new [llength [obj_val [lindex $a 0]]] -} - -proc mal_apply {a} { - set f [lindex $a 0] - if {[llength $a] > 1} { - set mid_args [lrange $a 1 end-1] - set last_list [lindex $a end] - set apply_args [concat $mid_args [obj_val $last_list]] - } else { - set apply_args {} - } - - switch [obj_type $f] { - function { - set funcdict [obj_val $f] - set body [dict get $funcdict body] - set env [dict get $funcdict env] - set binds [dict get $funcdict binds] - set funcenv [Env new $env $binds $apply_args] - return [EVAL $body $funcenv] - } - nativefunction { - set body [concat [list [obj_val $f]] {$a}] - set lambda [list {a} $body] - return [apply $lambda $apply_args] - } - default { - error "Not a function" - } - } -} - -proc mal_map {a} { - lassign $a f seq - set res {} - foreach item [obj_val $seq] { - set mappeditem [mal_apply [list $f [list_new [list $item]]]] - lappend res $mappeditem - } - list_new $res -} - -proc mal_conj {a} { - lassign $a a0 - if {[list_q $a0]} { - set lst $a0 - foreach item [lrange $a 1 end] { - set lst [mal_cons [list $item $lst]] - } - return $lst - } elseif {[vector_q $a0]} { - set res [obj_val $a0] - foreach item [lrange $a 1 end] { - lappend res $item - } - vector_new $res - } else { - error "conj requires list or vector" - } -} - -proc mal_seq {a} { - lassign $a a0 - if {[string_q $a0]} { - set str [obj_val $a0] - if {$str == ""} { - return $::mal_nil - } - set res {} - foreach char [split $str {}] { - lappend res [string_new $char] - } - list_new $res - } elseif {[list_q $a0]} { - if {[llength [obj_val $a0]] == 0} { - return $::mal_nil - } - return $a0 - } elseif {[vector_q $a0]} { - if {[llength [obj_val $a0]] == 0} { - return $::mal_nil - } - list_new [obj_val $a0] - } elseif {[nil_q $a0]} { - return $::mal_nil - } else { - error "seq requires string or list or vector or nil" - } -} - -proc mal_meta {a} { - obj_meta [lindex $a 0] -} - -proc mal_with_meta {a} { - lassign $a a0 a1 - obj_new [obj_type $a0] [obj_val $a0] $a1 -} - -proc mal_atom {a} { - atom_new [lindex $a 0] -} - -proc mal_atom_q {a} { - bool_new [atom_q [lindex $a 0]] -} - -proc mal_deref {a} { - obj_val [lindex $a 0] -} - -proc mal_reset_bang {a} { - lassign $a a0 a1 - obj_set_val $a0 $a1 -} - -proc mal_swap_bang {a} { - lassign $a a0 f - set apply_args [concat [list [obj_val $a0]] [lrange $a 2 end]] - set newval [mal_apply [list $f [list_new $apply_args]]] - mal_reset_bang [list $a0 $newval] -} - -set core_ns [dict create \ - "=" [nativefunction_new mal_equal] \ - "throw" [nativefunction_new mal_throw] \ - \ - "nil?" [nativefunction_new mal_nil_q] \ - "true?" [nativefunction_new mal_true_q] \ - "false?" [nativefunction_new mal_false_q] \ - "symbol" [nativefunction_new mal_symbol] \ - "symbol?" [nativefunction_new mal_symbol_q] \ - "string?" [nativefunction_new mal_string_q] \ - "keyword" [nativefunction_new mal_keyword] \ - "keyword?" [nativefunction_new mal_keyword_q] \ - "number?" [nativefunction_new mal_number_q] \ - "fn?" [nativefunction_new mal_fn_q] \ - "macro?" [nativefunction_new mal_macro_q] \ - \ - "pr-str" [nativefunction_new mal_pr_str] \ - "str" [nativefunction_new mal_str] \ - "prn" [nativefunction_new mal_prn] \ - "println" [nativefunction_new mal_println] \ - "read-string" [nativefunction_new mal_read_string] \ - "readline" [nativefunction_new mal_readline] \ - "slurp" [nativefunction_new mal_slurp] \ - \ - "<" [nativefunction_new mal_lt] \ - "<=" [nativefunction_new mal_lte] \ - ">" [nativefunction_new mal_gt] \ - ">=" [nativefunction_new mal_gte] \ - "+" [nativefunction_new mal_add] \ - "-" [nativefunction_new mal_sub] \ - "*" [nativefunction_new mal_mul] \ - "/" [nativefunction_new mal_div] \ - "time-ms" [nativefunction_new mal_time_ms] \ - \ - "list" [nativefunction_new mal_list] \ - "list?" [nativefunction_new mal_list_q] \ - "vector" [nativefunction_new mal_vector] \ - "vector?" [nativefunction_new mal_vector_q] \ - "hash-map" [nativefunction_new mal_hash_map] \ - "map?" [nativefunction_new mal_map_q] \ - "assoc" [nativefunction_new mal_assoc] \ - "dissoc" [nativefunction_new mal_dissoc] \ - "get" [nativefunction_new mal_get] \ - "contains?" [nativefunction_new mal_contains_q] \ - "keys" [nativefunction_new mal_keys] \ - "vals" [nativefunction_new mal_vals] \ - \ - "sequential?" [nativefunction_new mal_sequential_q] \ - "cons" [nativefunction_new mal_cons] \ - "concat" [nativefunction_new mal_concat] \ - "vec" [nativefunction_new mal_vec] \ - "nth" [nativefunction_new mal_nth] \ - "first" [nativefunction_new mal_first] \ - "rest" [nativefunction_new mal_rest] \ - "empty?" [nativefunction_new mal_empty_q] \ - "count" [nativefunction_new mal_count] \ - "apply" [nativefunction_new mal_apply] \ - "map" [nativefunction_new mal_map] \ - \ - "conj" [nativefunction_new mal_conj] \ - "seq" [nativefunction_new mal_seq] \ - \ - "meta" [nativefunction_new mal_meta] \ - "with-meta" [nativefunction_new mal_with_meta] \ - "atom" [nativefunction_new mal_atom] \ - "atom?" [nativefunction_new mal_atom_q] \ - "deref" [nativefunction_new mal_deref] \ - "reset!" [nativefunction_new mal_reset_bang] \ - "swap!" [nativefunction_new mal_swap_bang] \ -] +proc mal_equal {a} { + bool_new [equal_q [lindex $a 0] [lindex $a 1]] +} + +set ::mal_exception_obj 0 +proc mal_throw {a} { + set ::mal_exception_obj [lindex $a 0] + error "__MalException__" +} + +proc mal_nil_q {a} { + bool_new [nil_q [lindex $a 0]] +} + +proc mal_true_q {a} { + bool_new [true_q [lindex $a 0]] +} + +proc mal_false_q {a} { + bool_new [false_q [lindex $a 0]] +} + +proc mal_symbol {a} { + symbol_new [obj_val [lindex $a 0]] +} + +proc mal_symbol_q {a} { + bool_new [symbol_q [lindex $a 0]] +} + +proc mal_string_q {a} { + bool_new [string_q [lindex $a 0]] +} + +proc mal_keyword {a} { + lassign $a a0 + if {[keyword_q $a0]} { + return $a0 + } + keyword_new [obj_val $a0] +} + +proc mal_keyword_q {a} { + bool_new [keyword_q [lindex $a 0]] +} + +proc mal_number_q {a} { + bool_new [integer_q [lindex $a 0]] +} + +proc mal_fn_q {a} { + set f [lindex $a 0] + switch [obj_type $f] { + function { return [bool_new [expr {![macro_q $f]}]] } + nativefunction { return $::mal_true } + default { return $::mal_false } + } +} + +proc mal_macro_q {a} { + bool_new [macro_q [lindex $a 0]] +} + +proc render_array {arr readable delim} { + set res {} + foreach e $arr { + lappend res [pr_str $e $readable] + } + join $res $delim +} + +proc mal_pr_str {a} { + string_new [render_array $a 1 " "] +} + +proc mal_str {a} { + string_new [render_array $a 0 ""] +} + +proc mal_prn {a} { + puts [render_array $a 1 " "] + return $::mal_nil +} + +proc mal_println {a} { + puts [render_array $a 0 " "] + return $::mal_nil +} + +proc mal_read_string {a} { + read_str [obj_val [lindex $a 0]] +} + +proc mal_readline {a} { + set prompt [obj_val [lindex $a 0]] + set res [_readline $prompt] + if {[lindex $res 0] == "EOF"} { + return $::mal_nil + } + string_new [lindex $res 1] +} + +proc mal_slurp {a} { + set filename [obj_val [lindex $a 0]] + set file [open $filename] + set content [read $file] + close $file + string_new $content +} + +proc mal_lt {a} { + bool_new [expr {[obj_val [lindex $a 0]] < [obj_val [lindex $a 1]]}] +} + +proc mal_lte {a} { + bool_new [expr {[obj_val [lindex $a 0]] <= [obj_val [lindex $a 1]]}] +} + +proc mal_gt {a} { + bool_new [expr {[obj_val [lindex $a 0]] > [obj_val [lindex $a 1]]}] +} + +proc mal_gte {a} { + bool_new [expr {[obj_val [lindex $a 0]] >= [obj_val [lindex $a 1]]}] +} + +proc mal_add {a} { + integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}] +} + +proc mal_sub {a} { + integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}] +} + +proc mal_mul {a} { + integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}] +} + +proc mal_div {a} { + integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}] +} + +proc mal_time_ms {a} { + integer_new [clock milliseconds] +} + +proc mal_list {a} { + list_new $a +} + +proc mal_list_q {a} { + bool_new [list_q [lindex $a 0]] +} + +proc mal_vector {a} { + vector_new $a +} + +proc mal_vector_q {a} { + bool_new [vector_q [lindex $a 0]] +} + +proc mal_hash_map {a} { + set d [dict create] + foreach {k v} $a { + dict set d [obj_val $k] $v + } + hashmap_new $d +} + +proc mal_map_q {a} { + bool_new [hashmap_q [lindex $a 0]] +} + +proc mal_assoc {a} { + set d [dict create] + dict for {k v} [obj_val [lindex $a 0]] { + dict set d $k $v + } + foreach {k v} [lrange $a 1 end] { + dict set d [obj_val $k] $v + } + hashmap_new $d +} + +proc mal_dissoc {a} { + set d [dict create] + dict for {k v} [obj_val [lindex $a 0]] { + dict set d $k $v + } + foreach k [lrange $a 1 end] { + dict unset d [obj_val $k] + } + hashmap_new $d +} + +proc mal_get {a} { + lassign $a hashmap_obj key_obj + if {[dict exists [obj_val $hashmap_obj] [obj_val $key_obj]]} { + dict get [obj_val $hashmap_obj] [obj_val $key_obj] + } else { + return $::mal_nil + } +} + +proc mal_contains_q {a} { + lassign $a hashmap_obj key_obj + bool_new [dict exists [obj_val $hashmap_obj] [obj_val $key_obj]] +} + +proc mal_keys {a} { + set res {} + foreach k [dict keys [obj_val [lindex $a 0]]] { + lappend res [string_new $k] + } + list_new $res +} + +proc mal_vals {a} { + list_new [dict values [obj_val [lindex $a 0]]] +} + +proc mal_sequential_q {a} { + bool_new [sequential_q [lindex $a 0]] +} + +proc mal_cons {a} { + lassign $a head lst + list_new [concat [list $head] [obj_val $lst]] +} + +proc mal_concat {a} { + set res {} + foreach lst $a { + if {[nil_q $lst]} { + continue + } + set res [concat $res [obj_val $lst]] + } + list_new $res +} + +proc mal_vec {a} { + lassign $a a0 + if {[vector_q $a0]} { + return $a0 + } elseif {[list_q $a0]} { + return [vector_new [obj_val $a0]] + } else { + error "vec requires list or vector" + } +} + +proc mal_nth {a} { + lassign $a lst_obj index_obj + set index [obj_val $index_obj] + set lst [obj_val $lst_obj] + if {$index >= [llength $lst]} { + error "nth: index out of range" + } + lindex $lst $index +} + +proc mal_first {a} { + lassign $a lst + if {[nil_q $lst] || [llength [obj_val $lst]] == 0} { + return $::mal_nil + } + lindex [obj_val $lst] 0 +} + +proc mal_rest {a} { + lassign $a lst + list_new [lrange [obj_val $lst] 1 end] +} + +proc mal_empty_q {a} { + bool_new [expr {[llength [obj_val [lindex $a 0]]] == 0}] +} + +proc mal_count {a} { + integer_new [llength [obj_val [lindex $a 0]]] +} + +proc mal_apply {a} { + set f [lindex $a 0] + if {[llength $a] > 1} { + set mid_args [lrange $a 1 end-1] + set last_list [lindex $a end] + set apply_args [concat $mid_args [obj_val $last_list]] + } else { + set apply_args {} + } + + switch [obj_type $f] { + function { + set funcdict [obj_val $f] + set body [dict get $funcdict body] + set env [dict get $funcdict env] + set binds [dict get $funcdict binds] + set funcenv [Env new $env $binds $apply_args] + return [EVAL $body $funcenv] + } + nativefunction { + set body [concat [list [obj_val $f]] {$a}] + set lambda [list {a} $body] + return [apply $lambda $apply_args] + } + default { + error "Not a function" + } + } +} + +proc mal_map {a} { + lassign $a f seq + set res {} + foreach item [obj_val $seq] { + set mappeditem [mal_apply [list $f [list_new [list $item]]]] + lappend res $mappeditem + } + list_new $res +} + +proc mal_conj {a} { + lassign $a a0 + if {[list_q $a0]} { + set lst $a0 + foreach item [lrange $a 1 end] { + set lst [mal_cons [list $item $lst]] + } + return $lst + } elseif {[vector_q $a0]} { + set res [obj_val $a0] + foreach item [lrange $a 1 end] { + lappend res $item + } + vector_new $res + } else { + error "conj requires list or vector" + } +} + +proc mal_seq {a} { + lassign $a a0 + if {[string_q $a0]} { + set str [obj_val $a0] + if {$str == ""} { + return $::mal_nil + } + set res {} + foreach char [split $str {}] { + lappend res [string_new $char] + } + list_new $res + } elseif {[list_q $a0]} { + if {[llength [obj_val $a0]] == 0} { + return $::mal_nil + } + return $a0 + } elseif {[vector_q $a0]} { + if {[llength [obj_val $a0]] == 0} { + return $::mal_nil + } + list_new [obj_val $a0] + } elseif {[nil_q $a0]} { + return $::mal_nil + } else { + error "seq requires string or list or vector or nil" + } +} + +proc mal_meta {a} { + obj_meta [lindex $a 0] +} + +proc mal_with_meta {a} { + lassign $a a0 a1 + obj_new [obj_type $a0] [obj_val $a0] $a1 +} + +proc mal_atom {a} { + atom_new [lindex $a 0] +} + +proc mal_atom_q {a} { + bool_new [atom_q [lindex $a 0]] +} + +proc mal_deref {a} { + obj_val [lindex $a 0] +} + +proc mal_reset_bang {a} { + lassign $a a0 a1 + obj_set_val $a0 $a1 +} + +proc mal_swap_bang {a} { + lassign $a a0 f + set apply_args [concat [list [obj_val $a0]] [lrange $a 2 end]] + set newval [mal_apply [list $f [list_new $apply_args]]] + mal_reset_bang [list $a0 $newval] +} + +set core_ns [dict create \ + "=" [nativefunction_new mal_equal] \ + "throw" [nativefunction_new mal_throw] \ + \ + "nil?" [nativefunction_new mal_nil_q] \ + "true?" [nativefunction_new mal_true_q] \ + "false?" [nativefunction_new mal_false_q] \ + "symbol" [nativefunction_new mal_symbol] \ + "symbol?" [nativefunction_new mal_symbol_q] \ + "string?" [nativefunction_new mal_string_q] \ + "keyword" [nativefunction_new mal_keyword] \ + "keyword?" [nativefunction_new mal_keyword_q] \ + "number?" [nativefunction_new mal_number_q] \ + "fn?" [nativefunction_new mal_fn_q] \ + "macro?" [nativefunction_new mal_macro_q] \ + \ + "pr-str" [nativefunction_new mal_pr_str] \ + "str" [nativefunction_new mal_str] \ + "prn" [nativefunction_new mal_prn] \ + "println" [nativefunction_new mal_println] \ + "read-string" [nativefunction_new mal_read_string] \ + "readline" [nativefunction_new mal_readline] \ + "slurp" [nativefunction_new mal_slurp] \ + \ + "<" [nativefunction_new mal_lt] \ + "<=" [nativefunction_new mal_lte] \ + ">" [nativefunction_new mal_gt] \ + ">=" [nativefunction_new mal_gte] \ + "+" [nativefunction_new mal_add] \ + "-" [nativefunction_new mal_sub] \ + "*" [nativefunction_new mal_mul] \ + "/" [nativefunction_new mal_div] \ + "time-ms" [nativefunction_new mal_time_ms] \ + \ + "list" [nativefunction_new mal_list] \ + "list?" [nativefunction_new mal_list_q] \ + "vector" [nativefunction_new mal_vector] \ + "vector?" [nativefunction_new mal_vector_q] \ + "hash-map" [nativefunction_new mal_hash_map] \ + "map?" [nativefunction_new mal_map_q] \ + "assoc" [nativefunction_new mal_assoc] \ + "dissoc" [nativefunction_new mal_dissoc] \ + "get" [nativefunction_new mal_get] \ + "contains?" [nativefunction_new mal_contains_q] \ + "keys" [nativefunction_new mal_keys] \ + "vals" [nativefunction_new mal_vals] \ + \ + "sequential?" [nativefunction_new mal_sequential_q] \ + "cons" [nativefunction_new mal_cons] \ + "concat" [nativefunction_new mal_concat] \ + "vec" [nativefunction_new mal_vec] \ + "nth" [nativefunction_new mal_nth] \ + "first" [nativefunction_new mal_first] \ + "rest" [nativefunction_new mal_rest] \ + "empty?" [nativefunction_new mal_empty_q] \ + "count" [nativefunction_new mal_count] \ + "apply" [nativefunction_new mal_apply] \ + "map" [nativefunction_new mal_map] \ + \ + "conj" [nativefunction_new mal_conj] \ + "seq" [nativefunction_new mal_seq] \ + \ + "meta" [nativefunction_new mal_meta] \ + "with-meta" [nativefunction_new mal_with_meta] \ + "atom" [nativefunction_new mal_atom] \ + "atom?" [nativefunction_new mal_atom_q] \ + "deref" [nativefunction_new mal_deref] \ + "reset!" [nativefunction_new mal_reset_bang] \ + "swap!" [nativefunction_new mal_swap_bang] \ +] diff --git a/impls/tcl/env.tcl b/impls/tcl/env.tcl index 2cb9628341..e2efd0a2f9 100644 --- a/impls/tcl/env.tcl +++ b/impls/tcl/env.tcl @@ -1,49 +1,49 @@ -oo::class create Env { - variable outer data - - constructor {{outerenv 0} {binds ""} {exprs ""}} { - set outer $outerenv - set data [dict create] - if {$binds != ""} { - for {set i 0} {$i < [llength $binds]} {incr i} { - set b [lindex $binds $i] - if {$b == "&"} { - set varrest [lindex $binds [expr {$i + 1}]] - set restexprs [list_new [lrange $exprs $i end]] - my set $varrest $restexprs - break - } else { - my set $b [lindex $exprs $i] - } - } - } - } - - method set {symbol objval} { - dict set data $symbol $objval - return $objval - } - - method find {symbol} { - if {[dict exist $data $symbol]} { - return [self] - } elseif {$outer != 0} { - return [$outer find $symbol] - } else { - return 0 - } - } - - method get {symbol} { - set foundenv [my find $symbol] - if {$foundenv == 0} { - error "'$symbol' not found" - } else { - return [$foundenv get_symbol $symbol] - } - } - - method get_symbol {symbol} { - dict get $data $symbol - } -} +oo::class create Env { + variable outer data + + constructor {{outerenv 0} {binds ""} {exprs ""}} { + set outer $outerenv + set data [dict create] + if {$binds != ""} { + for {set i 0} {$i < [llength $binds]} {incr i} { + set b [lindex $binds $i] + if {$b == "&"} { + set varrest [lindex $binds [expr {$i + 1}]] + set restexprs [list_new [lrange $exprs $i end]] + my set $varrest $restexprs + break + } else { + my set $b [lindex $exprs $i] + } + } + } + } + + method set {symbol objval} { + dict set data $symbol $objval + return $objval + } + + method find {symbol} { + if {[dict exist $data $symbol]} { + return [self] + } elseif {$outer != 0} { + return [$outer find $symbol] + } else { + return 0 + } + } + + method get {symbol} { + set foundenv [my find $symbol] + if {$foundenv == 0} { + error "'$symbol' not found" + } else { + return [$foundenv get_symbol $symbol] + } + } + + method get_symbol {symbol} { + dict get $data $symbol + } +} diff --git a/impls/tcl/mal_readline.tcl b/impls/tcl/mal_readline.tcl index 58c7d6ce7d..1600dc07bb 100644 --- a/impls/tcl/mal_readline.tcl +++ b/impls/tcl/mal_readline.tcl @@ -1,54 +1,54 @@ -if {[lindex $argv 0] == "--raw"} { - set ::readline_mode "raw" - set argv [lrange $argv 1 end] - incr argc -1 -} else { - if {[catch {package require tclreadline}]} { - set ::readline_mode "raw" - } else { - set ::readline_mode "library" - } -} - -set ::historyfile "$env(HOME)/.mal-history" -set ::readline_library_initalized 0 -proc readline_library_init {} { - if {$::readline_library_initalized} { - return - } - - ::tclreadline::readline initialize $::historyfile - ::tclreadline::readline builtincompleter 0 - ::tclreadline::readline customcompleter "" - set ::readline_library_initalized 1 -} - -proc _readline_library prompt { - readline_library_init - - set reached_eof 0 - ::tclreadline::readline eofchar { set reached_eof 1 } - set line [::tclreadline::readline read $prompt] - if {$reached_eof} { - return {"EOF" ""} - } - ::tclreadline::readline write $::historyfile - list "OK" $line -} - -proc _readline_raw prompt { - puts -nonewline $prompt - flush stdout - if {[gets stdin line] < 0} { - return {"EOF" ""} - } - list "OK" $line -} - -proc _readline prompt { - if {$::readline_mode == "library"} { - _readline_library $prompt - } else { - _readline_raw $prompt - } -} +if {[lindex $argv 0] == "--raw"} { + set ::readline_mode "raw" + set argv [lrange $argv 1 end] + incr argc -1 +} else { + if {[catch {package require tclreadline}]} { + set ::readline_mode "raw" + } else { + set ::readline_mode "library" + } +} + +set ::historyfile "$env(HOME)/.mal-history" +set ::readline_library_initalized 0 +proc readline_library_init {} { + if {$::readline_library_initalized} { + return + } + + ::tclreadline::readline initialize $::historyfile + ::tclreadline::readline builtincompleter 0 + ::tclreadline::readline customcompleter "" + set ::readline_library_initalized 1 +} + +proc _readline_library prompt { + readline_library_init + + set reached_eof 0 + ::tclreadline::readline eofchar { set reached_eof 1 } + set line [::tclreadline::readline read $prompt] + if {$reached_eof} { + return {"EOF" ""} + } + ::tclreadline::readline write $::historyfile + list "OK" $line +} + +proc _readline_raw prompt { + puts -nonewline $prompt + flush stdout + if {[gets stdin line] < 0} { + return {"EOF" ""} + } + list "OK" $line +} + +proc _readline prompt { + if {$::readline_mode == "library"} { + _readline_library $prompt + } else { + _readline_raw $prompt + } +} diff --git a/impls/tcl/printer.tcl b/impls/tcl/printer.tcl index 4f1d8f0ec7..cd1e584e19 100644 --- a/impls/tcl/printer.tcl +++ b/impls/tcl/printer.tcl @@ -1,56 +1,56 @@ -proc format_list {elements start_char end_char readable} { - set res {} - foreach element $elements { - lappend res [pr_str $element $readable] - } - set joined [join $res " "] - return "${start_char}${joined}${end_char}" -} - -proc format_hashmap {dictionary readable} { - set lst {} - dict for {keystr valobj} $dictionary { - lappend lst [string_new $keystr] - lappend lst $valobj - } - format_list $lst "\{" "\}" $readable -} - -proc format_string {str readable} { - if {[string index $str 0] == "\u029E"} { - return ":[string range $str 1 end]" - } elseif {$readable} { - set escaped [string map {"\n" "\\n" "\"" "\\\"" "\\" "\\\\"} $str] - return "\"$escaped\"" - } else { - return $str - } -} - -proc format_function {funcdict} { - set type "function" - if {[dict get $funcdict is_macro]} { - set type "macro" - } - return "<$type:args=[join [dict get $funcdict binds] ","]>" -} - -proc pr_str {ast readable} { - set nodetype [obj_type $ast] - set nodevalue [obj_val $ast] - switch $nodetype { - nil { return "nil" } - true { return "true" } - false { return "false" } - integer { return $nodevalue } - symbol { return $nodevalue } - string { return [format_string $nodevalue $readable] } - list { return [format_list $nodevalue "(" ")" $readable] } - vector { return [format_list $nodevalue "\[" "\]" $readable] } - hashmap { return [format_hashmap [dict get $nodevalue] $readable] } - atom { return "(atom [pr_str $nodevalue $readable])" } - function { return [format_function $nodevalue] } - nativefunction { return "" } - default { error "cannot print type $nodetype" } - } -} +proc format_list {elements start_char end_char readable} { + set res {} + foreach element $elements { + lappend res [pr_str $element $readable] + } + set joined [join $res " "] + return "${start_char}${joined}${end_char}" +} + +proc format_hashmap {dictionary readable} { + set lst {} + dict for {keystr valobj} $dictionary { + lappend lst [string_new $keystr] + lappend lst $valobj + } + format_list $lst "\{" "\}" $readable +} + +proc format_string {str readable} { + if {[string index $str 0] == "\u029E"} { + return ":[string range $str 1 end]" + } elseif {$readable} { + set escaped [string map {"\n" "\\n" "\"" "\\\"" "\\" "\\\\"} $str] + return "\"$escaped\"" + } else { + return $str + } +} + +proc format_function {funcdict} { + set type "function" + if {[dict get $funcdict is_macro]} { + set type "macro" + } + return "<$type:args=[join [dict get $funcdict binds] ","]>" +} + +proc pr_str {ast readable} { + set nodetype [obj_type $ast] + set nodevalue [obj_val $ast] + switch $nodetype { + nil { return "nil" } + true { return "true" } + false { return "false" } + integer { return $nodevalue } + symbol { return $nodevalue } + string { return [format_string $nodevalue $readable] } + list { return [format_list $nodevalue "(" ")" $readable] } + vector { return [format_list $nodevalue "\[" "\]" $readable] } + hashmap { return [format_hashmap [dict get $nodevalue] $readable] } + atom { return "(atom [pr_str $nodevalue $readable])" } + function { return [format_function $nodevalue] } + nativefunction { return "" } + default { error "cannot print type $nodetype" } + } +} diff --git a/impls/tcl/reader.tcl b/impls/tcl/reader.tcl index 6812335f04..7c73c183bf 100644 --- a/impls/tcl/reader.tcl +++ b/impls/tcl/reader.tcl @@ -1,126 +1,126 @@ -oo::class create Reader { - variable pos tokens - - constructor {tokens_list} { - set tokens $tokens_list - set pos 0 - } - - method peek {} { - lindex $tokens $pos - } - - method next {} { - set token [my peek] - incr pos - return $token - } -} - -proc tokenize str { - set re {[\s,]*(~@|[\[\]\{\}()'`~^@]|\"(?:\\.|[^\\\"])*\"?|;[^\n]*|[^\s\[\]\{\}('\"`~^@,;)]*)} - set tokens {} - foreach {_ capture} [regexp -all -inline $re $str] { - if {[string length $capture] > 0 && [string range $capture 0 0] != ";"} { - lappend tokens $capture - } - } - return $tokens -} - -proc read_tokens_list {reader start_char end_char} { - set token [$reader next] - if {$token != $start_char} { - error "expected '$start_char', got EOF" - } - - set elements {} - set token [$reader peek] - while {$token != $end_char} { - if {$token == ""} { - error "expected '$end_char', got EOF" - } - lappend elements [read_form $reader] - set token [$reader peek] - } - $reader next - return $elements -} - -proc read_list {reader} { - set elements [read_tokens_list $reader "(" ")"] - list_new $elements -} - -proc read_vector {reader} { - set elements [read_tokens_list $reader "\[" "\]"] - vector_new $elements -} - -proc read_hashmap {reader} { - set res [dict create] - foreach {keytoken valtoken} [read_tokens_list $reader "{" "}"] { - dict set res [obj_val $keytoken] $valtoken - } - hashmap_new $res -} - -proc parse_string {str} { - set res [string range $str 1 end-1] - string map {"\\n" "\n" "\\\"" "\"" "\\\\" "\\"} $res -} - -proc parse_keyword {str} { - # Remove initial ":" - string range $str 1 end -} - -proc read_atom {reader} { - set token [$reader next] - switch -regexp $token { - ^-?[0-9]+$ { return [obj_new "integer" $token] } - ^nil$ { return $::mal_nil } - ^true$ { return $::mal_true } - ^false$ { return $::mal_false } - ^: { return [keyword_new [parse_keyword $token]] } - ^\"(\\\\.|[^\\\\\"])*\"$ - { return [string_new [parse_string $token]] } - ^\" { error "expected '\"', got EOF" } - default { return [symbol_new $token] } - } -} - -proc symbol_shortcut {symbol_name reader} { - $reader next - list_new [list [symbol_new $symbol_name] [read_form $reader]] -} - -proc read_form {reader} { - switch [$reader peek] { - "'" { return [symbol_shortcut "quote" $reader] } - "`" { return [symbol_shortcut "quasiquote" $reader] } - "~" { return [symbol_shortcut "unquote" $reader] } - "~@" { return [symbol_shortcut "splice-unquote" $reader] } - "^" { - $reader next - set meta [read_form $reader] - return [list_new [list [symbol_new "with-meta"] [read_form $reader] $meta]] - } - "@" { return [symbol_shortcut "deref" $reader] } - "(" { return [read_list $reader] } - ")" { error "unexpected ')'" } - "\[" { return [read_vector $reader] } - "\]" { error "unexpected '\]'" } - "\{" { return [read_hashmap $reader] } - "\}" { error "unexpected '\}'" } - default { return [read_atom $reader] } - } -} - -proc read_str str { - set tokens [tokenize $str] - set reader [Reader new $tokens] - set res [read_form $reader] - $reader destroy - return $res -} +oo::class create Reader { + variable pos tokens + + constructor {tokens_list} { + set tokens $tokens_list + set pos 0 + } + + method peek {} { + lindex $tokens $pos + } + + method next {} { + set token [my peek] + incr pos + return $token + } +} + +proc tokenize str { + set re {[\s,]*(~@|[\[\]\{\}()'`~^@]|\"(?:\\.|[^\\\"])*\"?|;[^\n]*|[^\s\[\]\{\}('\"`~^@,;)]*)} + set tokens {} + foreach {_ capture} [regexp -all -inline $re $str] { + if {[string length $capture] > 0 && [string range $capture 0 0] != ";"} { + lappend tokens $capture + } + } + return $tokens +} + +proc read_tokens_list {reader start_char end_char} { + set token [$reader next] + if {$token != $start_char} { + error "expected '$start_char', got EOF" + } + + set elements {} + set token [$reader peek] + while {$token != $end_char} { + if {$token == ""} { + error "expected '$end_char', got EOF" + } + lappend elements [read_form $reader] + set token [$reader peek] + } + $reader next + return $elements +} + +proc read_list {reader} { + set elements [read_tokens_list $reader "(" ")"] + list_new $elements +} + +proc read_vector {reader} { + set elements [read_tokens_list $reader "\[" "\]"] + vector_new $elements +} + +proc read_hashmap {reader} { + set res [dict create] + foreach {keytoken valtoken} [read_tokens_list $reader "{" "}"] { + dict set res [obj_val $keytoken] $valtoken + } + hashmap_new $res +} + +proc parse_string {str} { + set res [string range $str 1 end-1] + string map {"\\n" "\n" "\\\"" "\"" "\\\\" "\\"} $res +} + +proc parse_keyword {str} { + # Remove initial ":" + string range $str 1 end +} + +proc read_atom {reader} { + set token [$reader next] + switch -regexp $token { + ^-?[0-9]+$ { return [obj_new "integer" $token] } + ^nil$ { return $::mal_nil } + ^true$ { return $::mal_true } + ^false$ { return $::mal_false } + ^: { return [keyword_new [parse_keyword $token]] } + ^\"(\\\\.|[^\\\\\"])*\"$ + { return [string_new [parse_string $token]] } + ^\" { error "expected '\"', got EOF" } + default { return [symbol_new $token] } + } +} + +proc symbol_shortcut {symbol_name reader} { + $reader next + list_new [list [symbol_new $symbol_name] [read_form $reader]] +} + +proc read_form {reader} { + switch [$reader peek] { + "'" { return [symbol_shortcut "quote" $reader] } + "`" { return [symbol_shortcut "quasiquote" $reader] } + "~" { return [symbol_shortcut "unquote" $reader] } + "~@" { return [symbol_shortcut "splice-unquote" $reader] } + "^" { + $reader next + set meta [read_form $reader] + return [list_new [list [symbol_new "with-meta"] [read_form $reader] $meta]] + } + "@" { return [symbol_shortcut "deref" $reader] } + "(" { return [read_list $reader] } + ")" { error "unexpected ')'" } + "\[" { return [read_vector $reader] } + "\]" { error "unexpected '\]'" } + "\{" { return [read_hashmap $reader] } + "\}" { error "unexpected '\}'" } + default { return [read_atom $reader] } + } +} + +proc read_str str { + set tokens [tokenize $str] + set reader [Reader new $tokens] + set res [read_form $reader] + $reader destroy + return $res +} diff --git a/impls/tcl/run b/impls/tcl/run index e73c2a63fe..ccc92328b4 100755 --- a/impls/tcl/run +++ b/impls/tcl/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec tclsh $(dirname $0)/${STEP:-stepA_mal}.tcl ${RAW:+--raw} "${@}" +#!/bin/bash +exec tclsh $(dirname $0)/${STEP:-stepA_mal}.tcl ${RAW:+--raw} "${@}" diff --git a/impls/tcl/step0_repl.tcl b/impls/tcl/step0_repl.tcl index 5c18f04b15..f070d254f6 100644 --- a/impls/tcl/step0_repl.tcl +++ b/impls/tcl/step0_repl.tcl @@ -1,33 +1,33 @@ -source mal_readline.tcl - -proc READ str { - return $str -} - -proc EVAL {ast env} { - return $ast -} - -proc PRINT exp { - return $exp -} - -proc REP str { - PRINT [EVAL [READ $str] {}] -} - -fconfigure stdout -translation binary - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - puts [REP $line] -} -puts "" +source mal_readline.tcl + +proc READ str { + return $str +} + +proc EVAL {ast env} { + return $ast +} + +proc PRINT exp { + return $exp +} + +proc REP str { + PRINT [EVAL [READ $str] {}] +} + +fconfigure stdout -translation binary + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + puts [REP $line] +} +puts "" diff --git a/impls/tcl/step1_read_print.tcl b/impls/tcl/step1_read_print.tcl index f4aa064908..2ce0c3355f 100644 --- a/impls/tcl/step1_read_print.tcl +++ b/impls/tcl/step1_read_print.tcl @@ -1,38 +1,38 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl - -proc READ str { - read_str $str -} - -proc EVAL {ast env} { - return $ast -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP str { - PRINT [EVAL [READ $str] {}] -} - -fconfigure stdout -translation binary - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line] } exception] } { - puts "Error: $exception" - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl + +proc READ str { + read_str $str +} + +proc EVAL {ast env} { + return $ast +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP str { + PRINT [EVAL [READ $str] {}] +} + +fconfigure stdout -translation binary + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line] } exception] } { + puts "Error: $exception" + } +} +puts "" diff --git a/impls/tcl/step2_eval.tcl b/impls/tcl/step2_eval.tcl index 70001493a9..570f631bf6 100644 --- a/impls/tcl/step2_eval.tcl +++ b/impls/tcl/step2_eval.tcl @@ -1,107 +1,107 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl - -proc READ str { - read_str $str -} - -proc eval_ast {ast env} { - switch [obj_type $ast] { - "symbol" { - set varname [obj_val $ast] - if {[dict exists $env $varname]} { - return [dict get $env $varname] - } else { - error "'$varname' not found" - } - } - "list" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [list_new $res] - } - "vector" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [vector_new $res] - } - "hashmap" { - set res [dict create] - dict for {k v} [obj_val $ast] { - dict set res $k [EVAL $v $env] - } - return [hashmap_new $res] - } - default { return $ast } - } -} - -proc EVAL {ast env} { - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - set a0 [lindex [obj_val $ast] 0] - if {$a0 == ""} { - return $ast - } - set lst_obj [eval_ast $ast $env] - set lst [obj_val $lst_obj] - set f [lindex $lst 0] - set call_args [lrange $lst 1 end] - apply $f $call_args -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP {str env} { - PRINT [EVAL [READ $str] $env] -} - -proc mal_add {a} { - integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}] -} - -proc mal_sub {a} { - integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}] -} - -proc mal_mul {a} { - integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}] -} - -proc mal_div {a} { - integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}] -} - -set repl_env [dict create \ - "+" {{a} {mal_add $a}} \ - "-" {{a} {mal_sub $a}} \ - "*" {{a} {mal_mul $a}} \ - "/" {{a} {mal_div $a}} \ -] - -fconfigure stdout -translation binary - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line $repl_env] } exception] } { - puts "Error: $exception" - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl + +proc READ str { + read_str $str +} + +proc eval_ast {ast env} { + switch [obj_type $ast] { + "symbol" { + set varname [obj_val $ast] + if {[dict exists $env $varname]} { + return [dict get $env $varname] + } else { + error "'$varname' not found" + } + } + "list" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [list_new $res] + } + "vector" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [vector_new $res] + } + "hashmap" { + set res [dict create] + dict for {k v} [obj_val $ast] { + dict set res $k [EVAL $v $env] + } + return [hashmap_new $res] + } + default { return $ast } + } +} + +proc EVAL {ast env} { + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + set a0 [lindex [obj_val $ast] 0] + if {$a0 == ""} { + return $ast + } + set lst_obj [eval_ast $ast $env] + set lst [obj_val $lst_obj] + set f [lindex $lst 0] + set call_args [lrange $lst 1 end] + apply $f $call_args +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP {str env} { + PRINT [EVAL [READ $str] $env] +} + +proc mal_add {a} { + integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}] +} + +proc mal_sub {a} { + integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}] +} + +proc mal_mul {a} { + integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}] +} + +proc mal_div {a} { + integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}] +} + +set repl_env [dict create \ + "+" {{a} {mal_add $a}} \ + "-" {{a} {mal_sub $a}} \ + "*" {{a} {mal_mul $a}} \ + "/" {{a} {mal_div $a}} \ +] + +fconfigure stdout -translation binary + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line $repl_env] } exception] } { + puts "Error: $exception" + } +} +puts "" diff --git a/impls/tcl/step3_env.tcl b/impls/tcl/step3_env.tcl index 69f5a9a3c3..a8536af8b8 100644 --- a/impls/tcl/step3_env.tcl +++ b/impls/tcl/step3_env.tcl @@ -1,122 +1,122 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl -source env.tcl - -proc READ str { - read_str $str -} - -proc eval_ast {ast env} { - switch [obj_type $ast] { - "symbol" { - set varname [obj_val $ast] - return [$env get $varname] - } - "list" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [list_new $res] - } - "vector" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [vector_new $res] - } - "hashmap" { - set res [dict create] - dict for {k v} [obj_val $ast] { - dict set res $k [EVAL $v $env] - } - return [hashmap_new $res] - } - default { return $ast } - } -} - -proc EVAL {ast env} { - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - set a0 [lindex [obj_val $ast] 0] - if {$a0 == ""} { - return $ast - } - set a1 [lindex [obj_val $ast] 1] - set a2 [lindex [obj_val $ast] 2] - switch [obj_val $a0] { - "def!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname $value] - } - "let*" { - set letenv [Env new $env] - set bindings_list [obj_val $a1] - foreach {varnameobj varvalobj} $bindings_list { - $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] - } - return [EVAL $a2 $letenv] - } - default { - set lst_obj [eval_ast $ast $env] - set lst [obj_val $lst_obj] - set f [lindex $lst 0] - set call_args [lrange $lst 1 end] - return [apply $f $call_args] - } - } -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP {str env} { - PRINT [EVAL [READ $str] $env] -} - -proc mal_add {a} { - integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}] -} - -proc mal_sub {a} { - integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}] -} - -proc mal_mul {a} { - integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}] -} - -proc mal_div {a} { - integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}] -} - -set repl_env [Env new] -$repl_env set "+" {{a} {mal_add $a}} -$repl_env set "-" {{a} {mal_sub $a}} -$repl_env set "*" {{a} {mal_mul $a}} -$repl_env set "/" {{a} {mal_div $a}} - -fconfigure stdout -translation binary - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line $repl_env] } exception] } { - puts "Error: $exception" - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl +source env.tcl + +proc READ str { + read_str $str +} + +proc eval_ast {ast env} { + switch [obj_type $ast] { + "symbol" { + set varname [obj_val $ast] + return [$env get $varname] + } + "list" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [list_new $res] + } + "vector" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [vector_new $res] + } + "hashmap" { + set res [dict create] + dict for {k v} [obj_val $ast] { + dict set res $k [EVAL $v $env] + } + return [hashmap_new $res] + } + default { return $ast } + } +} + +proc EVAL {ast env} { + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + set a0 [lindex [obj_val $ast] 0] + if {$a0 == ""} { + return $ast + } + set a1 [lindex [obj_val $ast] 1] + set a2 [lindex [obj_val $ast] 2] + switch [obj_val $a0] { + "def!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname $value] + } + "let*" { + set letenv [Env new $env] + set bindings_list [obj_val $a1] + foreach {varnameobj varvalobj} $bindings_list { + $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] + } + return [EVAL $a2 $letenv] + } + default { + set lst_obj [eval_ast $ast $env] + set lst [obj_val $lst_obj] + set f [lindex $lst 0] + set call_args [lrange $lst 1 end] + return [apply $f $call_args] + } + } +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP {str env} { + PRINT [EVAL [READ $str] $env] +} + +proc mal_add {a} { + integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}] +} + +proc mal_sub {a} { + integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}] +} + +proc mal_mul {a} { + integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}] +} + +proc mal_div {a} { + integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}] +} + +set repl_env [Env new] +$repl_env set "+" {{a} {mal_add $a}} +$repl_env set "-" {{a} {mal_sub $a}} +$repl_env set "*" {{a} {mal_mul $a}} +$repl_env set "/" {{a} {mal_div $a}} + +fconfigure stdout -translation binary + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line $repl_env] } exception] } { + puts "Error: $exception" + } +} +puts "" diff --git a/impls/tcl/step4_if_fn_do.tcl b/impls/tcl/step4_if_fn_do.tcl index 4e2ae2f630..140dd9e603 100644 --- a/impls/tcl/step4_if_fn_do.tcl +++ b/impls/tcl/step4_if_fn_do.tcl @@ -1,158 +1,158 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl -source env.tcl -source core.tcl - -proc READ str { - read_str $str -} - -proc eval_ast {ast env} { - switch [obj_type $ast] { - "symbol" { - set varname [obj_val $ast] - return [$env get $varname] - } - "list" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [list_new $res] - } - "vector" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [vector_new $res] - } - "hashmap" { - set res [dict create] - dict for {k v} [obj_val $ast] { - dict set res $k [EVAL $v $env] - } - return [hashmap_new $res] - } - default { return $ast } - } -} - -proc EVAL {ast env} { - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - lassign [obj_val $ast] a0 a1 a2 a3 - if {$a0 == ""} { - return $ast - } - switch [obj_val $a0] { - "def!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname $value] - } - "let*" { - set letenv [Env new $env] - set bindings_list [obj_val $a1] - foreach {varnameobj varvalobj} $bindings_list { - $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] - } - return [EVAL $a2 $letenv] - } - "do" { - set el [list_new [lrange [obj_val $ast] 1 end-1]] - eval_ast $el $env - return [EVAL [lindex [obj_val $ast] end] $env] - } - "if" { - set condval [EVAL $a1 $env] - if {[false_q $condval] || [nil_q $condval]} { - if {$a3 == ""} { - return $::mal_nil - } - return [EVAL $a3 $env] - } - return [EVAL $a2 $env] - } - "fn*" { - set binds {} - foreach v [obj_val $a1] { - lappend binds [obj_val $v] - } - return [function_new $a2 $env $binds] - } - default { - set lst_obj [eval_ast $ast $env] - set lst [obj_val $lst_obj] - set f [lindex $lst 0] - set call_args [lrange $lst 1 end] - switch [obj_type $f] { - function { - set funcdict [obj_val $f] - set body [dict get $funcdict body] - set env [dict get $funcdict env] - set binds [dict get $funcdict binds] - set funcenv [Env new $env $binds $call_args] - return [EVAL $body $funcenv] - } - nativefunction { - set body [concat [list [obj_val $f]] {$a}] - set lambda [list {a} $body] - return [apply $lambda $call_args] - } - default { - error "Not a function" - } - } - } - } -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP {str env} { - PRINT [EVAL [READ $str] $env] -} - -proc RE {str env} { - EVAL [READ $str] $env -} - -set repl_env [Env new] -dict for {k v} $core_ns { - $repl_env set $k $v -} - -# core.mal: defined using the language itself -RE "(def! not (fn* (a) (if a false true)))" $repl_env - -fconfigure stdout -translation binary - -set DEBUG_MODE 0 -if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { - set DEBUG_MODE 1 -} - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line $repl_env] } exception] } { - puts "Error: $exception" - if { $DEBUG_MODE } { - puts $::errorInfo - } - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl +source env.tcl +source core.tcl + +proc READ str { + read_str $str +} + +proc eval_ast {ast env} { + switch [obj_type $ast] { + "symbol" { + set varname [obj_val $ast] + return [$env get $varname] + } + "list" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [list_new $res] + } + "vector" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [vector_new $res] + } + "hashmap" { + set res [dict create] + dict for {k v} [obj_val $ast] { + dict set res $k [EVAL $v $env] + } + return [hashmap_new $res] + } + default { return $ast } + } +} + +proc EVAL {ast env} { + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + lassign [obj_val $ast] a0 a1 a2 a3 + if {$a0 == ""} { + return $ast + } + switch [obj_val $a0] { + "def!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname $value] + } + "let*" { + set letenv [Env new $env] + set bindings_list [obj_val $a1] + foreach {varnameobj varvalobj} $bindings_list { + $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] + } + return [EVAL $a2 $letenv] + } + "do" { + set el [list_new [lrange [obj_val $ast] 1 end-1]] + eval_ast $el $env + return [EVAL [lindex [obj_val $ast] end] $env] + } + "if" { + set condval [EVAL $a1 $env] + if {[false_q $condval] || [nil_q $condval]} { + if {$a3 == ""} { + return $::mal_nil + } + return [EVAL $a3 $env] + } + return [EVAL $a2 $env] + } + "fn*" { + set binds {} + foreach v [obj_val $a1] { + lappend binds [obj_val $v] + } + return [function_new $a2 $env $binds] + } + default { + set lst_obj [eval_ast $ast $env] + set lst [obj_val $lst_obj] + set f [lindex $lst 0] + set call_args [lrange $lst 1 end] + switch [obj_type $f] { + function { + set funcdict [obj_val $f] + set body [dict get $funcdict body] + set env [dict get $funcdict env] + set binds [dict get $funcdict binds] + set funcenv [Env new $env $binds $call_args] + return [EVAL $body $funcenv] + } + nativefunction { + set body [concat [list [obj_val $f]] {$a}] + set lambda [list {a} $body] + return [apply $lambda $call_args] + } + default { + error "Not a function" + } + } + } + } +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP {str env} { + PRINT [EVAL [READ $str] $env] +} + +proc RE {str env} { + EVAL [READ $str] $env +} + +set repl_env [Env new] +dict for {k v} $core_ns { + $repl_env set $k $v +} + +# core.mal: defined using the language itself +RE "(def! not (fn* (a) (if a false true)))" $repl_env + +fconfigure stdout -translation binary + +set DEBUG_MODE 0 +if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { + set DEBUG_MODE 1 +} + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line $repl_env] } exception] } { + puts "Error: $exception" + if { $DEBUG_MODE } { + puts $::errorInfo + } + } +} +puts "" diff --git a/impls/tcl/step5_tco.tcl b/impls/tcl/step5_tco.tcl index 3e1f62bb27..140f2456b3 100644 --- a/impls/tcl/step5_tco.tcl +++ b/impls/tcl/step5_tco.tcl @@ -1,163 +1,163 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl -source env.tcl -source core.tcl - -proc READ str { - read_str $str -} - -proc eval_ast {ast env} { - switch [obj_type $ast] { - "symbol" { - set varname [obj_val $ast] - return [$env get $varname] - } - "list" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [list_new $res] - } - "vector" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [vector_new $res] - } - "hashmap" { - set res [dict create] - dict for {k v} [obj_val $ast] { - dict set res $k [EVAL $v $env] - } - return [hashmap_new $res] - } - default { return $ast } - } -} - -proc EVAL {ast env} { - while {true} { - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - lassign [obj_val $ast] a0 a1 a2 a3 - if {$a0 == ""} { - return $ast - } - switch [obj_val $a0] { - "def!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname $value] - } - "let*" { - set letenv [Env new $env] - set bindings_list [obj_val $a1] - foreach {varnameobj varvalobj} $bindings_list { - $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] - } - set ast $a2 - set env $letenv - # TCO: Continue loop - } - "do" { - set el [list_new [lrange [obj_val $ast] 1 end-1]] - eval_ast $el $env - set ast [lindex [obj_val $ast] end] - # TCO: Continue loop - } - "if" { - set condval [EVAL $a1 $env] - if {[false_q $condval] || [nil_q $condval]} { - if {$a3 == ""} { - return $::mal_nil - } - set ast $a3 - } else { - set ast $a2 - } - # TCO: Continue loop - } - "fn*" { - set binds {} - foreach v [obj_val $a1] { - lappend binds [obj_val $v] - } - return [function_new $a2 $env $binds] - } - default { - set lst_obj [eval_ast $ast $env] - set lst [obj_val $lst_obj] - set f [lindex $lst 0] - set call_args [lrange $lst 1 end] - switch [obj_type $f] { - function { - set fn [obj_val $f] - set ast [dict get $fn body] - set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] - # TCO: Continue loop - } - nativefunction { - set body [concat [list [obj_val $f]] {$a}] - set lambda [list {a} $body] - return [apply $lambda $call_args] - } - default { - error "Not a function" - } - } - } - } - } -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP {str env} { - PRINT [EVAL [READ $str] $env] -} - -proc RE {str env} { - EVAL [READ $str] $env -} - -set repl_env [Env new] -dict for {k v} $core_ns { - $repl_env set $k $v -} - -# core.mal: defined using the language itself -RE "(def! not (fn* (a) (if a false true)))" $repl_env - -fconfigure stdout -translation binary - -set DEBUG_MODE 0 -if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { - set DEBUG_MODE 1 -} - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line $repl_env] } exception] } { - puts "Error: $exception" - if { $DEBUG_MODE } { - puts $::errorInfo - } - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl +source env.tcl +source core.tcl + +proc READ str { + read_str $str +} + +proc eval_ast {ast env} { + switch [obj_type $ast] { + "symbol" { + set varname [obj_val $ast] + return [$env get $varname] + } + "list" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [list_new $res] + } + "vector" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [vector_new $res] + } + "hashmap" { + set res [dict create] + dict for {k v} [obj_val $ast] { + dict set res $k [EVAL $v $env] + } + return [hashmap_new $res] + } + default { return $ast } + } +} + +proc EVAL {ast env} { + while {true} { + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + lassign [obj_val $ast] a0 a1 a2 a3 + if {$a0 == ""} { + return $ast + } + switch [obj_val $a0] { + "def!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname $value] + } + "let*" { + set letenv [Env new $env] + set bindings_list [obj_val $a1] + foreach {varnameobj varvalobj} $bindings_list { + $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] + } + set ast $a2 + set env $letenv + # TCO: Continue loop + } + "do" { + set el [list_new [lrange [obj_val $ast] 1 end-1]] + eval_ast $el $env + set ast [lindex [obj_val $ast] end] + # TCO: Continue loop + } + "if" { + set condval [EVAL $a1 $env] + if {[false_q $condval] || [nil_q $condval]} { + if {$a3 == ""} { + return $::mal_nil + } + set ast $a3 + } else { + set ast $a2 + } + # TCO: Continue loop + } + "fn*" { + set binds {} + foreach v [obj_val $a1] { + lappend binds [obj_val $v] + } + return [function_new $a2 $env $binds] + } + default { + set lst_obj [eval_ast $ast $env] + set lst [obj_val $lst_obj] + set f [lindex $lst 0] + set call_args [lrange $lst 1 end] + switch [obj_type $f] { + function { + set fn [obj_val $f] + set ast [dict get $fn body] + set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] + # TCO: Continue loop + } + nativefunction { + set body [concat [list [obj_val $f]] {$a}] + set lambda [list {a} $body] + return [apply $lambda $call_args] + } + default { + error "Not a function" + } + } + } + } + } +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP {str env} { + PRINT [EVAL [READ $str] $env] +} + +proc RE {str env} { + EVAL [READ $str] $env +} + +set repl_env [Env new] +dict for {k v} $core_ns { + $repl_env set $k $v +} + +# core.mal: defined using the language itself +RE "(def! not (fn* (a) (if a false true)))" $repl_env + +fconfigure stdout -translation binary + +set DEBUG_MODE 0 +if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { + set DEBUG_MODE 1 +} + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line $repl_env] } exception] } { + puts "Error: $exception" + if { $DEBUG_MODE } { + puts $::errorInfo + } + } +} +puts "" diff --git a/impls/tcl/step6_file.tcl b/impls/tcl/step6_file.tcl index 193df2c122..93be41ae2c 100644 --- a/impls/tcl/step6_file.tcl +++ b/impls/tcl/step6_file.tcl @@ -1,182 +1,182 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl -source env.tcl -source core.tcl - -proc READ str { - read_str $str -} - -proc eval_ast {ast env} { - switch [obj_type $ast] { - "symbol" { - set varname [obj_val $ast] - return [$env get $varname] - } - "list" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [list_new $res] - } - "vector" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [vector_new $res] - } - "hashmap" { - set res [dict create] - dict for {k v} [obj_val $ast] { - dict set res $k [EVAL $v $env] - } - return [hashmap_new $res] - } - default { return $ast } - } -} - -proc EVAL {ast env} { - while {true} { - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - lassign [obj_val $ast] a0 a1 a2 a3 - if {$a0 == ""} { - return $ast - } - switch [obj_val $a0] { - "def!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname $value] - } - "let*" { - set letenv [Env new $env] - set bindings_list [obj_val $a1] - foreach {varnameobj varvalobj} $bindings_list { - $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] - } - set ast $a2 - set env $letenv - # TCO: Continue loop - } - "do" { - set el [list_new [lrange [obj_val $ast] 1 end-1]] - eval_ast $el $env - set ast [lindex [obj_val $ast] end] - # TCO: Continue loop - } - "if" { - set condval [EVAL $a1 $env] - if {[false_q $condval] || [nil_q $condval]} { - if {$a3 == ""} { - return $::mal_nil - } - set ast $a3 - } else { - set ast $a2 - } - # TCO: Continue loop - } - "fn*" { - set binds {} - foreach v [obj_val $a1] { - lappend binds [obj_val $v] - } - return [function_new $a2 $env $binds] - } - default { - set lst_obj [eval_ast $ast $env] - set lst [obj_val $lst_obj] - set f [lindex $lst 0] - set call_args [lrange $lst 1 end] - switch [obj_type $f] { - function { - set fn [obj_val $f] - set ast [dict get $fn body] - set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] - # TCO: Continue loop - } - nativefunction { - set body [concat [list [obj_val $f]] {$a}] - set lambda [list {a} $body] - return [apply $lambda $call_args] - } - default { - error "Not a function" - } - } - } - } - } -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP {str env} { - PRINT [EVAL [READ $str] $env] -} - -proc RE {str env} { - EVAL [READ $str] $env -} - -proc mal_eval {a} { - global repl_env - EVAL [lindex $a 0] $repl_env -} - -set repl_env [Env new] -dict for {k v} $core_ns { - $repl_env set $k $v -} - -$repl_env set "eval" [nativefunction_new mal_eval] - -set argv_list {} -foreach arg [lrange $argv 1 end] { - lappend argv_list [string_new $arg] -} -$repl_env set "*ARGV*" [list_new $argv_list] - -# core.mal: defined using the language itself -RE "(def! not (fn* (a) (if a false true)))" $repl_env -RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env - -fconfigure stdout -translation binary - -set DEBUG_MODE 0 -if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { - set DEBUG_MODE 1 -} - -if {$argc > 0} { - REP "(load-file \"[lindex $argv 0]\")" $repl_env - exit -} - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line $repl_env] } exception] } { - puts "Error: $exception" - if { $DEBUG_MODE } { - puts $::errorInfo - } - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl +source env.tcl +source core.tcl + +proc READ str { + read_str $str +} + +proc eval_ast {ast env} { + switch [obj_type $ast] { + "symbol" { + set varname [obj_val $ast] + return [$env get $varname] + } + "list" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [list_new $res] + } + "vector" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [vector_new $res] + } + "hashmap" { + set res [dict create] + dict for {k v} [obj_val $ast] { + dict set res $k [EVAL $v $env] + } + return [hashmap_new $res] + } + default { return $ast } + } +} + +proc EVAL {ast env} { + while {true} { + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + lassign [obj_val $ast] a0 a1 a2 a3 + if {$a0 == ""} { + return $ast + } + switch [obj_val $a0] { + "def!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname $value] + } + "let*" { + set letenv [Env new $env] + set bindings_list [obj_val $a1] + foreach {varnameobj varvalobj} $bindings_list { + $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] + } + set ast $a2 + set env $letenv + # TCO: Continue loop + } + "do" { + set el [list_new [lrange [obj_val $ast] 1 end-1]] + eval_ast $el $env + set ast [lindex [obj_val $ast] end] + # TCO: Continue loop + } + "if" { + set condval [EVAL $a1 $env] + if {[false_q $condval] || [nil_q $condval]} { + if {$a3 == ""} { + return $::mal_nil + } + set ast $a3 + } else { + set ast $a2 + } + # TCO: Continue loop + } + "fn*" { + set binds {} + foreach v [obj_val $a1] { + lappend binds [obj_val $v] + } + return [function_new $a2 $env $binds] + } + default { + set lst_obj [eval_ast $ast $env] + set lst [obj_val $lst_obj] + set f [lindex $lst 0] + set call_args [lrange $lst 1 end] + switch [obj_type $f] { + function { + set fn [obj_val $f] + set ast [dict get $fn body] + set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] + # TCO: Continue loop + } + nativefunction { + set body [concat [list [obj_val $f]] {$a}] + set lambda [list {a} $body] + return [apply $lambda $call_args] + } + default { + error "Not a function" + } + } + } + } + } +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP {str env} { + PRINT [EVAL [READ $str] $env] +} + +proc RE {str env} { + EVAL [READ $str] $env +} + +proc mal_eval {a} { + global repl_env + EVAL [lindex $a 0] $repl_env +} + +set repl_env [Env new] +dict for {k v} $core_ns { + $repl_env set $k $v +} + +$repl_env set "eval" [nativefunction_new mal_eval] + +set argv_list {} +foreach arg [lrange $argv 1 end] { + lappend argv_list [string_new $arg] +} +$repl_env set "*ARGV*" [list_new $argv_list] + +# core.mal: defined using the language itself +RE "(def! not (fn* (a) (if a false true)))" $repl_env +RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env + +fconfigure stdout -translation binary + +set DEBUG_MODE 0 +if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { + set DEBUG_MODE 1 +} + +if {$argc > 0} { + REP "(load-file \"[lindex $argv 0]\")" $repl_env + exit +} + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line $repl_env] } exception] } { + puts "Error: $exception" + if { $DEBUG_MODE } { + puts $::errorInfo + } + } +} +puts "" diff --git a/impls/tcl/step7_quote.tcl b/impls/tcl/step7_quote.tcl index 41d76ea900..bc34704431 100644 --- a/impls/tcl/step7_quote.tcl +++ b/impls/tcl/step7_quote.tcl @@ -1,237 +1,237 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl -source env.tcl -source core.tcl - -proc READ str { - read_str $str -} - -proc starts_with {lst sym} { - if {[llength $lst] != 2} { - return 0 - } - lassign [lindex $lst 0] a0 - return [symbol_q $a0] && [expr {[obj_val $a0] == $sym}] -} -proc qq_loop {elt acc} { - if {[list_q $elt] && [starts_with [obj_val $elt] "splice-unquote"]} { - return [list_new [list [symbol_new "concat"] [lindex [obj_val $elt] 1] $acc]] - } else { - return [list_new [list [symbol_new "cons"] [quasiquote $elt] $acc]] - } -} -proc qq_foldr {xs} { - set acc [list_new []] - for {set i [expr {[llength $xs] - 1}]} {0 <= $i} {incr i -1} { - set acc [qq_loop [lindex $xs $i] $acc] - } - return $acc -} - -proc quasiquote {ast} { - switch [obj_type $ast] { - "symbol" { - return [list_new [list [symbol_new "quote"] $ast]] - } - "hashmap" { - return [list_new [list [symbol_new "quote"] $ast]] - } - "vector" { - return [list_new [list [symbol_new "vec"] [qq_foldr [obj_val $ast]]]] - } - "list" { - if {[starts_with [obj_val $ast] "unquote"]} { - return [lindex [obj_val $ast] 1] - } else { - return [qq_foldr [obj_val $ast]] - } - } - default { - return $ast - } - } -} - -proc eval_ast {ast env} { - switch [obj_type $ast] { - "symbol" { - set varname [obj_val $ast] - return [$env get $varname] - } - "list" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [list_new $res] - } - "vector" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [vector_new $res] - } - "hashmap" { - set res [dict create] - dict for {k v} [obj_val $ast] { - dict set res $k [EVAL $v $env] - } - return [hashmap_new $res] - } - default { return $ast } - } -} - -proc EVAL {ast env} { - while {true} { - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - lassign [obj_val $ast] a0 a1 a2 a3 - if {$a0 == ""} { - return $ast - } - switch [obj_val $a0] { - "def!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname $value] - } - "let*" { - set letenv [Env new $env] - set bindings_list [obj_val $a1] - foreach {varnameobj varvalobj} $bindings_list { - $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] - } - set ast $a2 - set env $letenv - # TCO: Continue loop - } - "quote" { - return $a1 - } - "quasiquoteexpand" { - return [quasiquote $a1] - } - "quasiquote" { - set ast [quasiquote $a1] - } - "do" { - set el [list_new [lrange [obj_val $ast] 1 end-1]] - eval_ast $el $env - set ast [lindex [obj_val $ast] end] - # TCO: Continue loop - } - "if" { - set condval [EVAL $a1 $env] - if {[false_q $condval] || [nil_q $condval]} { - if {$a3 == ""} { - return $::mal_nil - } - set ast $a3 - } else { - set ast $a2 - } - # TCO: Continue loop - } - "fn*" { - set binds {} - foreach v [obj_val $a1] { - lappend binds [obj_val $v] - } - return [function_new $a2 $env $binds] - } - default { - set lst_obj [eval_ast $ast $env] - set lst [obj_val $lst_obj] - set f [lindex $lst 0] - set call_args [lrange $lst 1 end] - switch [obj_type $f] { - function { - set fn [obj_val $f] - set ast [dict get $fn body] - set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] - # TCO: Continue loop - } - nativefunction { - set body [concat [list [obj_val $f]] {$a}] - set lambda [list {a} $body] - return [apply $lambda $call_args] - } - default { - error "Not a function" - } - } - } - } - } -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP {str env} { - PRINT [EVAL [READ $str] $env] -} - -proc RE {str env} { - EVAL [READ $str] $env -} - -proc mal_eval {a} { - global repl_env - EVAL [lindex $a 0] $repl_env -} - -set repl_env [Env new] -dict for {k v} $core_ns { - $repl_env set $k $v -} - -$repl_env set "eval" [nativefunction_new mal_eval] - -set argv_list {} -foreach arg [lrange $argv 1 end] { - lappend argv_list [string_new $arg] -} -$repl_env set "*ARGV*" [list_new $argv_list] - -# core.mal: defined using the language itself -RE "(def! not (fn* (a) (if a false true)))" $repl_env -RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env - -fconfigure stdout -translation binary - -set DEBUG_MODE 0 -if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { - set DEBUG_MODE 1 -} - -if {$argc > 0} { - REP "(load-file \"[lindex $argv 0]\")" $repl_env - exit -} - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line $repl_env] } exception] } { - puts "Error: $exception" - if { $DEBUG_MODE } { - puts $::errorInfo - } - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl +source env.tcl +source core.tcl + +proc READ str { + read_str $str +} + +proc starts_with {lst sym} { + if {[llength $lst] != 2} { + return 0 + } + lassign [lindex $lst 0] a0 + return [symbol_q $a0] && [expr {[obj_val $a0] == $sym}] +} +proc qq_loop {elt acc} { + if {[list_q $elt] && [starts_with [obj_val $elt] "splice-unquote"]} { + return [list_new [list [symbol_new "concat"] [lindex [obj_val $elt] 1] $acc]] + } else { + return [list_new [list [symbol_new "cons"] [quasiquote $elt] $acc]] + } +} +proc qq_foldr {xs} { + set acc [list_new []] + for {set i [expr {[llength $xs] - 1}]} {0 <= $i} {incr i -1} { + set acc [qq_loop [lindex $xs $i] $acc] + } + return $acc +} + +proc quasiquote {ast} { + switch [obj_type $ast] { + "symbol" { + return [list_new [list [symbol_new "quote"] $ast]] + } + "hashmap" { + return [list_new [list [symbol_new "quote"] $ast]] + } + "vector" { + return [list_new [list [symbol_new "vec"] [qq_foldr [obj_val $ast]]]] + } + "list" { + if {[starts_with [obj_val $ast] "unquote"]} { + return [lindex [obj_val $ast] 1] + } else { + return [qq_foldr [obj_val $ast]] + } + } + default { + return $ast + } + } +} + +proc eval_ast {ast env} { + switch [obj_type $ast] { + "symbol" { + set varname [obj_val $ast] + return [$env get $varname] + } + "list" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [list_new $res] + } + "vector" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [vector_new $res] + } + "hashmap" { + set res [dict create] + dict for {k v} [obj_val $ast] { + dict set res $k [EVAL $v $env] + } + return [hashmap_new $res] + } + default { return $ast } + } +} + +proc EVAL {ast env} { + while {true} { + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + lassign [obj_val $ast] a0 a1 a2 a3 + if {$a0 == ""} { + return $ast + } + switch [obj_val $a0] { + "def!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname $value] + } + "let*" { + set letenv [Env new $env] + set bindings_list [obj_val $a1] + foreach {varnameobj varvalobj} $bindings_list { + $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] + } + set ast $a2 + set env $letenv + # TCO: Continue loop + } + "quote" { + return $a1 + } + "quasiquoteexpand" { + return [quasiquote $a1] + } + "quasiquote" { + set ast [quasiquote $a1] + } + "do" { + set el [list_new [lrange [obj_val $ast] 1 end-1]] + eval_ast $el $env + set ast [lindex [obj_val $ast] end] + # TCO: Continue loop + } + "if" { + set condval [EVAL $a1 $env] + if {[false_q $condval] || [nil_q $condval]} { + if {$a3 == ""} { + return $::mal_nil + } + set ast $a3 + } else { + set ast $a2 + } + # TCO: Continue loop + } + "fn*" { + set binds {} + foreach v [obj_val $a1] { + lappend binds [obj_val $v] + } + return [function_new $a2 $env $binds] + } + default { + set lst_obj [eval_ast $ast $env] + set lst [obj_val $lst_obj] + set f [lindex $lst 0] + set call_args [lrange $lst 1 end] + switch [obj_type $f] { + function { + set fn [obj_val $f] + set ast [dict get $fn body] + set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] + # TCO: Continue loop + } + nativefunction { + set body [concat [list [obj_val $f]] {$a}] + set lambda [list {a} $body] + return [apply $lambda $call_args] + } + default { + error "Not a function" + } + } + } + } + } +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP {str env} { + PRINT [EVAL [READ $str] $env] +} + +proc RE {str env} { + EVAL [READ $str] $env +} + +proc mal_eval {a} { + global repl_env + EVAL [lindex $a 0] $repl_env +} + +set repl_env [Env new] +dict for {k v} $core_ns { + $repl_env set $k $v +} + +$repl_env set "eval" [nativefunction_new mal_eval] + +set argv_list {} +foreach arg [lrange $argv 1 end] { + lappend argv_list [string_new $arg] +} +$repl_env set "*ARGV*" [list_new $argv_list] + +# core.mal: defined using the language itself +RE "(def! not (fn* (a) (if a false true)))" $repl_env +RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env + +fconfigure stdout -translation binary + +set DEBUG_MODE 0 +if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { + set DEBUG_MODE 1 +} + +if {$argc > 0} { + REP "(load-file \"[lindex $argv 0]\")" $repl_env + exit +} + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line $repl_env] } exception] } { + puts "Error: $exception" + if { $DEBUG_MODE } { + puts $::errorInfo + } + } +} +puts "" diff --git a/impls/tcl/step8_macros.tcl b/impls/tcl/step8_macros.tcl index 6bdf1994f3..46f7085de9 100644 --- a/impls/tcl/step8_macros.tcl +++ b/impls/tcl/step8_macros.tcl @@ -1,285 +1,285 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl -source env.tcl -source core.tcl - -proc READ str { - read_str $str -} - -proc starts_with {lst sym} { - if {[llength $lst] != 2} { - return 0 - } - lassign [lindex $lst 0] a0 - return [symbol_q $a0] && [expr {[obj_val $a0] == $sym}] -} -proc qq_loop {elt acc} { - if {[list_q $elt] && [starts_with [obj_val $elt] "splice-unquote"]} { - return [list_new [list [symbol_new "concat"] [lindex [obj_val $elt] 1] $acc]] - } else { - return [list_new [list [symbol_new "cons"] [quasiquote $elt] $acc]] - } -} -proc qq_foldr {xs} { - set acc [list_new []] - for {set i [expr {[llength $xs] - 1}]} {0 <= $i} {incr i -1} { - set acc [qq_loop [lindex $xs $i] $acc] - } - return $acc -} - -proc quasiquote {ast} { - switch [obj_type $ast] { - "symbol" { - return [list_new [list [symbol_new "quote"] $ast]] - } - "hashmap" { - return [list_new [list [symbol_new "quote"] $ast]] - } - "vector" { - return [list_new [list [symbol_new "vec"] [qq_foldr [obj_val $ast]]]] - } - "list" { - if {[starts_with [obj_val $ast] "unquote"]} { - return [lindex [obj_val $ast] 1] - } else { - return [qq_foldr [obj_val $ast]] - } - } - default { - return $ast - } - } -} - -proc is_macro_call {ast env} { - if {![list_q $ast]} { - return 0 - } - set a0 [lindex [obj_val $ast] 0] - if {$a0 == "" || ![symbol_q $a0]} { - return 0 - } - set varname [obj_val $a0] - set foundenv [$env find $varname] - if {$foundenv == 0} { - return 0 - } - macro_q [$env get $varname] -} - -proc macroexpand {ast env} { - while {[is_macro_call $ast $env]} { - set a0 [mal_first [list $ast]] - set macro_name [obj_val $a0] - set macro_obj [$env get $macro_name] - set macro_args [obj_val [mal_rest [list $ast]]] - - set funcdict [obj_val $macro_obj] - set body [dict get $funcdict body] - set env [dict get $funcdict env] - set binds [dict get $funcdict binds] - set funcenv [Env new $env $binds $macro_args] - set ast [EVAL $body $funcenv] - } - return $ast -} - -proc eval_ast {ast env} { - switch [obj_type $ast] { - "symbol" { - set varname [obj_val $ast] - return [$env get $varname] - } - "list" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [list_new $res] - } - "vector" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [vector_new $res] - } - "hashmap" { - set res [dict create] - dict for {k v} [obj_val $ast] { - dict set res $k [EVAL $v $env] - } - return [hashmap_new $res] - } - default { return $ast } - } -} - -proc EVAL {ast env} { - while {true} { - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - - set ast [macroexpand $ast $env] - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - - lassign [obj_val $ast] a0 a1 a2 a3 - if {$a0 == ""} { - return $ast - } - switch [obj_val $a0] { - "def!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname $value] - } - "let*" { - set letenv [Env new $env] - set bindings_list [obj_val $a1] - foreach {varnameobj varvalobj} $bindings_list { - $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] - } - set ast $a2 - set env $letenv - # TCO: Continue loop - } - "quote" { - return $a1 - } - "quasiquoteexpand" { - return [quasiquote $a1] - } - "quasiquote" { - set ast [quasiquote $a1] - } - "defmacro!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname [macro_new $value]] - } - "macroexpand" { - return [macroexpand $a1 $env] - } - "do" { - set el [list_new [lrange [obj_val $ast] 1 end-1]] - eval_ast $el $env - set ast [lindex [obj_val $ast] end] - # TCO: Continue loop - } - "if" { - set condval [EVAL $a1 $env] - if {[false_q $condval] || [nil_q $condval]} { - if {$a3 == ""} { - return $::mal_nil - } - set ast $a3 - } else { - set ast $a2 - } - # TCO: Continue loop - } - "fn*" { - set binds {} - foreach v [obj_val $a1] { - lappend binds [obj_val $v] - } - return [function_new $a2 $env $binds] - } - default { - set lst_obj [eval_ast $ast $env] - set lst [obj_val $lst_obj] - set f [lindex $lst 0] - set call_args [lrange $lst 1 end] - switch [obj_type $f] { - function { - set fn [obj_val $f] - set ast [dict get $fn body] - set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] - # TCO: Continue loop - } - nativefunction { - set body [concat [list [obj_val $f]] {$a}] - set lambda [list {a} $body] - return [apply $lambda $call_args] - } - default { - error "Not a function" - } - } - } - } - } -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP {str env} { - PRINT [EVAL [READ $str] $env] -} - -proc RE {str env} { - EVAL [READ $str] $env -} - -proc mal_eval {a} { - global repl_env - EVAL [lindex $a 0] $repl_env -} - -set repl_env [Env new] -dict for {k v} $core_ns { - $repl_env set $k $v -} - -$repl_env set "eval" [nativefunction_new mal_eval] - -set argv_list {} -foreach arg [lrange $argv 1 end] { - lappend argv_list [string_new $arg] -} -$repl_env set "*ARGV*" [list_new $argv_list] - -# core.mal: defined using the language itself -RE "(def! not (fn* (a) (if a false true)))" $repl_env -RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env -RE "(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)))))))" $repl_env - -fconfigure stdout -translation binary - -set DEBUG_MODE 0 -if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { - set DEBUG_MODE 1 -} - -if {$argc > 0} { - REP "(load-file \"[lindex $argv 0]\")" $repl_env - exit -} - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line $repl_env] } exception] } { - puts "Error: $exception" - if { $DEBUG_MODE } { - puts $::errorInfo - } - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl +source env.tcl +source core.tcl + +proc READ str { + read_str $str +} + +proc starts_with {lst sym} { + if {[llength $lst] != 2} { + return 0 + } + lassign [lindex $lst 0] a0 + return [symbol_q $a0] && [expr {[obj_val $a0] == $sym}] +} +proc qq_loop {elt acc} { + if {[list_q $elt] && [starts_with [obj_val $elt] "splice-unquote"]} { + return [list_new [list [symbol_new "concat"] [lindex [obj_val $elt] 1] $acc]] + } else { + return [list_new [list [symbol_new "cons"] [quasiquote $elt] $acc]] + } +} +proc qq_foldr {xs} { + set acc [list_new []] + for {set i [expr {[llength $xs] - 1}]} {0 <= $i} {incr i -1} { + set acc [qq_loop [lindex $xs $i] $acc] + } + return $acc +} + +proc quasiquote {ast} { + switch [obj_type $ast] { + "symbol" { + return [list_new [list [symbol_new "quote"] $ast]] + } + "hashmap" { + return [list_new [list [symbol_new "quote"] $ast]] + } + "vector" { + return [list_new [list [symbol_new "vec"] [qq_foldr [obj_val $ast]]]] + } + "list" { + if {[starts_with [obj_val $ast] "unquote"]} { + return [lindex [obj_val $ast] 1] + } else { + return [qq_foldr [obj_val $ast]] + } + } + default { + return $ast + } + } +} + +proc is_macro_call {ast env} { + if {![list_q $ast]} { + return 0 + } + set a0 [lindex [obj_val $ast] 0] + if {$a0 == "" || ![symbol_q $a0]} { + return 0 + } + set varname [obj_val $a0] + set foundenv [$env find $varname] + if {$foundenv == 0} { + return 0 + } + macro_q [$env get $varname] +} + +proc macroexpand {ast env} { + while {[is_macro_call $ast $env]} { + set a0 [mal_first [list $ast]] + set macro_name [obj_val $a0] + set macro_obj [$env get $macro_name] + set macro_args [obj_val [mal_rest [list $ast]]] + + set funcdict [obj_val $macro_obj] + set body [dict get $funcdict body] + set env [dict get $funcdict env] + set binds [dict get $funcdict binds] + set funcenv [Env new $env $binds $macro_args] + set ast [EVAL $body $funcenv] + } + return $ast +} + +proc eval_ast {ast env} { + switch [obj_type $ast] { + "symbol" { + set varname [obj_val $ast] + return [$env get $varname] + } + "list" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [list_new $res] + } + "vector" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [vector_new $res] + } + "hashmap" { + set res [dict create] + dict for {k v} [obj_val $ast] { + dict set res $k [EVAL $v $env] + } + return [hashmap_new $res] + } + default { return $ast } + } +} + +proc EVAL {ast env} { + while {true} { + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + + set ast [macroexpand $ast $env] + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + + lassign [obj_val $ast] a0 a1 a2 a3 + if {$a0 == ""} { + return $ast + } + switch [obj_val $a0] { + "def!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname $value] + } + "let*" { + set letenv [Env new $env] + set bindings_list [obj_val $a1] + foreach {varnameobj varvalobj} $bindings_list { + $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] + } + set ast $a2 + set env $letenv + # TCO: Continue loop + } + "quote" { + return $a1 + } + "quasiquoteexpand" { + return [quasiquote $a1] + } + "quasiquote" { + set ast [quasiquote $a1] + } + "defmacro!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname [macro_new $value]] + } + "macroexpand" { + return [macroexpand $a1 $env] + } + "do" { + set el [list_new [lrange [obj_val $ast] 1 end-1]] + eval_ast $el $env + set ast [lindex [obj_val $ast] end] + # TCO: Continue loop + } + "if" { + set condval [EVAL $a1 $env] + if {[false_q $condval] || [nil_q $condval]} { + if {$a3 == ""} { + return $::mal_nil + } + set ast $a3 + } else { + set ast $a2 + } + # TCO: Continue loop + } + "fn*" { + set binds {} + foreach v [obj_val $a1] { + lappend binds [obj_val $v] + } + return [function_new $a2 $env $binds] + } + default { + set lst_obj [eval_ast $ast $env] + set lst [obj_val $lst_obj] + set f [lindex $lst 0] + set call_args [lrange $lst 1 end] + switch [obj_type $f] { + function { + set fn [obj_val $f] + set ast [dict get $fn body] + set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] + # TCO: Continue loop + } + nativefunction { + set body [concat [list [obj_val $f]] {$a}] + set lambda [list {a} $body] + return [apply $lambda $call_args] + } + default { + error "Not a function" + } + } + } + } + } +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP {str env} { + PRINT [EVAL [READ $str] $env] +} + +proc RE {str env} { + EVAL [READ $str] $env +} + +proc mal_eval {a} { + global repl_env + EVAL [lindex $a 0] $repl_env +} + +set repl_env [Env new] +dict for {k v} $core_ns { + $repl_env set $k $v +} + +$repl_env set "eval" [nativefunction_new mal_eval] + +set argv_list {} +foreach arg [lrange $argv 1 end] { + lappend argv_list [string_new $arg] +} +$repl_env set "*ARGV*" [list_new $argv_list] + +# core.mal: defined using the language itself +RE "(def! not (fn* (a) (if a false true)))" $repl_env +RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env +RE "(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)))))))" $repl_env + +fconfigure stdout -translation binary + +set DEBUG_MODE 0 +if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { + set DEBUG_MODE 1 +} + +if {$argc > 0} { + REP "(load-file \"[lindex $argv 0]\")" $repl_env + exit +} + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line $repl_env] } exception] } { + puts "Error: $exception" + if { $DEBUG_MODE } { + puts $::errorInfo + } + } +} +puts "" diff --git a/impls/tcl/step9_try.tcl b/impls/tcl/step9_try.tcl index 6518536a31..48ba390ea7 100644 --- a/impls/tcl/step9_try.tcl +++ b/impls/tcl/step9_try.tcl @@ -1,308 +1,308 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl -source env.tcl -source core.tcl - -proc READ str { - read_str $str -} - -proc starts_with {lst sym} { - if {[llength $lst] != 2} { - return 0 - } - lassign [lindex $lst 0] a0 - return [symbol_q $a0] && [expr {[obj_val $a0] == $sym}] -} -proc qq_loop {elt acc} { - if {[list_q $elt] && [starts_with [obj_val $elt] "splice-unquote"]} { - return [list_new [list [symbol_new "concat"] [lindex [obj_val $elt] 1] $acc]] - } else { - return [list_new [list [symbol_new "cons"] [quasiquote $elt] $acc]] - } -} -proc qq_foldr {xs} { - set acc [list_new []] - for {set i [expr {[llength $xs] - 1}]} {0 <= $i} {incr i -1} { - set acc [qq_loop [lindex $xs $i] $acc] - } - return $acc -} - -proc quasiquote {ast} { - switch [obj_type $ast] { - "symbol" { - return [list_new [list [symbol_new "quote"] $ast]] - } - "hashmap" { - return [list_new [list [symbol_new "quote"] $ast]] - } - "vector" { - return [list_new [list [symbol_new "vec"] [qq_foldr [obj_val $ast]]]] - } - "list" { - if {[starts_with [obj_val $ast] "unquote"]} { - return [lindex [obj_val $ast] 1] - } else { - return [qq_foldr [obj_val $ast]] - } - } - default { - return $ast - } - } -} - -proc is_macro_call {ast env} { - if {![list_q $ast]} { - return 0 - } - set a0 [lindex [obj_val $ast] 0] - if {$a0 == "" || ![symbol_q $a0]} { - return 0 - } - set varname [obj_val $a0] - set foundenv [$env find $varname] - if {$foundenv == 0} { - return 0 - } - macro_q [$env get $varname] -} - -proc macroexpand {ast env} { - while {[is_macro_call $ast $env]} { - set a0 [mal_first [list $ast]] - set macro_name [obj_val $a0] - set macro_obj [$env get $macro_name] - set macro_args [obj_val [mal_rest [list $ast]]] - - set funcdict [obj_val $macro_obj] - set body [dict get $funcdict body] - set env [dict get $funcdict env] - set binds [dict get $funcdict binds] - set funcenv [Env new $env $binds $macro_args] - set ast [EVAL $body $funcenv] - } - return $ast -} - -proc eval_ast {ast env} { - switch [obj_type $ast] { - "symbol" { - set varname [obj_val $ast] - return [$env get $varname] - } - "list" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [list_new $res] - } - "vector" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [vector_new $res] - } - "hashmap" { - set res [dict create] - dict for {k v} [obj_val $ast] { - dict set res $k [EVAL $v $env] - } - return [hashmap_new $res] - } - default { return $ast } - } -} - -proc EVAL {ast env} { - while {true} { - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - - set ast [macroexpand $ast $env] - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - - lassign [obj_val $ast] a0 a1 a2 a3 - if {$a0 == ""} { - return $ast - } - switch [obj_val $a0] { - "def!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname $value] - } - "let*" { - set letenv [Env new $env] - set bindings_list [obj_val $a1] - foreach {varnameobj varvalobj} $bindings_list { - $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] - } - set ast $a2 - set env $letenv - # TCO: Continue loop - } - "quote" { - return $a1 - } - "quasiquoteexpand" { - return [quasiquote $a1] - } - "quasiquote" { - set ast [quasiquote $a1] - } - "defmacro!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname [macro_new $value]] - } - "macroexpand" { - return [macroexpand $a1 $env] - } - "try*" { - if {$a2 == ""} { - return [EVAL $a1 $env] - } - set res {} - if { [catch { set res [EVAL $a1 $env] } exception] } { - set exc_var [obj_val [lindex [obj_val $a2] 1]] - if {$exception == "__MalException__"} { - set exc_value $::mal_exception_obj - } else { - set exc_value [string_new $exception] - } - set catch_env [Env new $env [list $exc_var] [list $exc_value]] - return [EVAL [lindex [obj_val $a2] 2] $catch_env] - } else { - return $res - } - } - "do" { - set el [list_new [lrange [obj_val $ast] 1 end-1]] - eval_ast $el $env - set ast [lindex [obj_val $ast] end] - # TCO: Continue loop - } - "if" { - set condval [EVAL $a1 $env] - if {[false_q $condval] || [nil_q $condval]} { - if {$a3 == ""} { - return $::mal_nil - } - set ast $a3 - } else { - set ast $a2 - } - # TCO: Continue loop - } - "fn*" { - set binds {} - foreach v [obj_val $a1] { - lappend binds [obj_val $v] - } - return [function_new $a2 $env $binds] - } - default { - set lst_obj [eval_ast $ast $env] - set lst [obj_val $lst_obj] - set f [lindex $lst 0] - set call_args [lrange $lst 1 end] - switch [obj_type $f] { - function { - set fn [obj_val $f] - set ast [dict get $fn body] - set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] - # TCO: Continue loop - } - nativefunction { - set body [concat [list [obj_val $f]] {$a}] - set lambda [list {a} $body] - return [apply $lambda $call_args] - } - default { - error "Not a function" - } - } - } - } - } -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP {str env} { - PRINT [EVAL [READ $str] $env] -} - -proc RE {str env} { - EVAL [READ $str] $env -} - -proc mal_eval {a} { - global repl_env - EVAL [lindex $a 0] $repl_env -} - -set repl_env [Env new] -dict for {k v} $core_ns { - $repl_env set $k $v -} - -$repl_env set "eval" [nativefunction_new mal_eval] - -set argv_list {} -foreach arg [lrange $argv 1 end] { - lappend argv_list [string_new $arg] -} -$repl_env set "*ARGV*" [list_new $argv_list] - -# core.mal: defined using the language itself -RE "(def! not (fn* (a) (if a false true)))" $repl_env -RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env -RE "(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)))))))" $repl_env - -fconfigure stdout -translation binary - -set DEBUG_MODE 0 -if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { - set DEBUG_MODE 1 -} - -if {$argc > 0} { - REP "(load-file \"[lindex $argv 0]\")" $repl_env - exit -} - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line $repl_env] } exception] } { - if {$exception == "__MalException__"} { - set res [pr_str $::mal_exception_obj 1] - puts "Error: $res" - } else { - puts "Error: $exception" - } - if { $DEBUG_MODE } { - puts $::errorInfo - } - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl +source env.tcl +source core.tcl + +proc READ str { + read_str $str +} + +proc starts_with {lst sym} { + if {[llength $lst] != 2} { + return 0 + } + lassign [lindex $lst 0] a0 + return [symbol_q $a0] && [expr {[obj_val $a0] == $sym}] +} +proc qq_loop {elt acc} { + if {[list_q $elt] && [starts_with [obj_val $elt] "splice-unquote"]} { + return [list_new [list [symbol_new "concat"] [lindex [obj_val $elt] 1] $acc]] + } else { + return [list_new [list [symbol_new "cons"] [quasiquote $elt] $acc]] + } +} +proc qq_foldr {xs} { + set acc [list_new []] + for {set i [expr {[llength $xs] - 1}]} {0 <= $i} {incr i -1} { + set acc [qq_loop [lindex $xs $i] $acc] + } + return $acc +} + +proc quasiquote {ast} { + switch [obj_type $ast] { + "symbol" { + return [list_new [list [symbol_new "quote"] $ast]] + } + "hashmap" { + return [list_new [list [symbol_new "quote"] $ast]] + } + "vector" { + return [list_new [list [symbol_new "vec"] [qq_foldr [obj_val $ast]]]] + } + "list" { + if {[starts_with [obj_val $ast] "unquote"]} { + return [lindex [obj_val $ast] 1] + } else { + return [qq_foldr [obj_val $ast]] + } + } + default { + return $ast + } + } +} + +proc is_macro_call {ast env} { + if {![list_q $ast]} { + return 0 + } + set a0 [lindex [obj_val $ast] 0] + if {$a0 == "" || ![symbol_q $a0]} { + return 0 + } + set varname [obj_val $a0] + set foundenv [$env find $varname] + if {$foundenv == 0} { + return 0 + } + macro_q [$env get $varname] +} + +proc macroexpand {ast env} { + while {[is_macro_call $ast $env]} { + set a0 [mal_first [list $ast]] + set macro_name [obj_val $a0] + set macro_obj [$env get $macro_name] + set macro_args [obj_val [mal_rest [list $ast]]] + + set funcdict [obj_val $macro_obj] + set body [dict get $funcdict body] + set env [dict get $funcdict env] + set binds [dict get $funcdict binds] + set funcenv [Env new $env $binds $macro_args] + set ast [EVAL $body $funcenv] + } + return $ast +} + +proc eval_ast {ast env} { + switch [obj_type $ast] { + "symbol" { + set varname [obj_val $ast] + return [$env get $varname] + } + "list" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [list_new $res] + } + "vector" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [vector_new $res] + } + "hashmap" { + set res [dict create] + dict for {k v} [obj_val $ast] { + dict set res $k [EVAL $v $env] + } + return [hashmap_new $res] + } + default { return $ast } + } +} + +proc EVAL {ast env} { + while {true} { + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + + set ast [macroexpand $ast $env] + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + + lassign [obj_val $ast] a0 a1 a2 a3 + if {$a0 == ""} { + return $ast + } + switch [obj_val $a0] { + "def!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname $value] + } + "let*" { + set letenv [Env new $env] + set bindings_list [obj_val $a1] + foreach {varnameobj varvalobj} $bindings_list { + $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] + } + set ast $a2 + set env $letenv + # TCO: Continue loop + } + "quote" { + return $a1 + } + "quasiquoteexpand" { + return [quasiquote $a1] + } + "quasiquote" { + set ast [quasiquote $a1] + } + "defmacro!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname [macro_new $value]] + } + "macroexpand" { + return [macroexpand $a1 $env] + } + "try*" { + if {$a2 == ""} { + return [EVAL $a1 $env] + } + set res {} + if { [catch { set res [EVAL $a1 $env] } exception] } { + set exc_var [obj_val [lindex [obj_val $a2] 1]] + if {$exception == "__MalException__"} { + set exc_value $::mal_exception_obj + } else { + set exc_value [string_new $exception] + } + set catch_env [Env new $env [list $exc_var] [list $exc_value]] + return [EVAL [lindex [obj_val $a2] 2] $catch_env] + } else { + return $res + } + } + "do" { + set el [list_new [lrange [obj_val $ast] 1 end-1]] + eval_ast $el $env + set ast [lindex [obj_val $ast] end] + # TCO: Continue loop + } + "if" { + set condval [EVAL $a1 $env] + if {[false_q $condval] || [nil_q $condval]} { + if {$a3 == ""} { + return $::mal_nil + } + set ast $a3 + } else { + set ast $a2 + } + # TCO: Continue loop + } + "fn*" { + set binds {} + foreach v [obj_val $a1] { + lappend binds [obj_val $v] + } + return [function_new $a2 $env $binds] + } + default { + set lst_obj [eval_ast $ast $env] + set lst [obj_val $lst_obj] + set f [lindex $lst 0] + set call_args [lrange $lst 1 end] + switch [obj_type $f] { + function { + set fn [obj_val $f] + set ast [dict get $fn body] + set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] + # TCO: Continue loop + } + nativefunction { + set body [concat [list [obj_val $f]] {$a}] + set lambda [list {a} $body] + return [apply $lambda $call_args] + } + default { + error "Not a function" + } + } + } + } + } +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP {str env} { + PRINT [EVAL [READ $str] $env] +} + +proc RE {str env} { + EVAL [READ $str] $env +} + +proc mal_eval {a} { + global repl_env + EVAL [lindex $a 0] $repl_env +} + +set repl_env [Env new] +dict for {k v} $core_ns { + $repl_env set $k $v +} + +$repl_env set "eval" [nativefunction_new mal_eval] + +set argv_list {} +foreach arg [lrange $argv 1 end] { + lappend argv_list [string_new $arg] +} +$repl_env set "*ARGV*" [list_new $argv_list] + +# core.mal: defined using the language itself +RE "(def! not (fn* (a) (if a false true)))" $repl_env +RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env +RE "(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)))))))" $repl_env + +fconfigure stdout -translation binary + +set DEBUG_MODE 0 +if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { + set DEBUG_MODE 1 +} + +if {$argc > 0} { + REP "(load-file \"[lindex $argv 0]\")" $repl_env + exit +} + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line $repl_env] } exception] } { + if {$exception == "__MalException__"} { + set res [pr_str $::mal_exception_obj 1] + puts "Error: $res" + } else { + puts "Error: $exception" + } + if { $DEBUG_MODE } { + puts $::errorInfo + } + } +} +puts "" diff --git a/impls/tcl/stepA_mal.tcl b/impls/tcl/stepA_mal.tcl index 1857a9a5ef..24ee5ca3d2 100644 --- a/impls/tcl/stepA_mal.tcl +++ b/impls/tcl/stepA_mal.tcl @@ -1,314 +1,314 @@ -source mal_readline.tcl -source types.tcl -source reader.tcl -source printer.tcl -source env.tcl -source core.tcl - -proc READ str { - read_str $str -} - -proc starts_with {lst sym} { - if {[llength $lst] != 2} { - return 0 - } - lassign [lindex $lst 0] a0 - return [symbol_q $a0] && [expr {[obj_val $a0] == $sym}] -} -proc qq_loop {elt acc} { - if {[list_q $elt] && [starts_with [obj_val $elt] "splice-unquote"]} { - return [list_new [list [symbol_new "concat"] [lindex [obj_val $elt] 1] $acc]] - } else { - return [list_new [list [symbol_new "cons"] [quasiquote $elt] $acc]] - } -} -proc qq_foldr {xs} { - set acc [list_new []] - for {set i [expr {[llength $xs] - 1}]} {0 <= $i} {incr i -1} { - set acc [qq_loop [lindex $xs $i] $acc] - } - return $acc -} - -proc quasiquote {ast} { - switch [obj_type $ast] { - "symbol" { - return [list_new [list [symbol_new "quote"] $ast]] - } - "hashmap" { - return [list_new [list [symbol_new "quote"] $ast]] - } - "vector" { - return [list_new [list [symbol_new "vec"] [qq_foldr [obj_val $ast]]]] - } - "list" { - if {[starts_with [obj_val $ast] "unquote"]} { - return [lindex [obj_val $ast] 1] - } else { - return [qq_foldr [obj_val $ast]] - } - } - default { - return $ast - } - } -} - -proc is_macro_call {ast env} { - if {![list_q $ast]} { - return 0 - } - set a0 [lindex [obj_val $ast] 0] - if {$a0 == "" || ![symbol_q $a0]} { - return 0 - } - set varname [obj_val $a0] - set foundenv [$env find $varname] - if {$foundenv == 0} { - return 0 - } - macro_q [$env get $varname] -} - -proc macroexpand {ast env} { - while {[is_macro_call $ast $env]} { - set a0 [mal_first [list $ast]] - set macro_name [obj_val $a0] - set macro_obj [$env get $macro_name] - set macro_args [obj_val [mal_rest [list $ast]]] - - set funcdict [obj_val $macro_obj] - set body [dict get $funcdict body] - set env [dict get $funcdict env] - set binds [dict get $funcdict binds] - set funcenv [Env new $env $binds $macro_args] - set ast [EVAL $body $funcenv] - } - return $ast -} - -proc eval_ast {ast env} { - switch [obj_type $ast] { - "symbol" { - set varname [obj_val $ast] - return [$env get $varname] - } - "list" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [list_new $res] - } - "vector" { - set res {} - foreach element [obj_val $ast] { - lappend res [EVAL $element $env] - } - return [vector_new $res] - } - "hashmap" { - set res [dict create] - dict for {k v} [obj_val $ast] { - dict set res $k [EVAL $v $env] - } - return [hashmap_new $res] - } - default { return $ast } - } -} - -proc EVAL {ast env} { - while {true} { - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - - set ast [macroexpand $ast $env] - if {![list_q $ast]} { - return [eval_ast $ast $env] - } - - lassign [obj_val $ast] a0 a1 a2 a3 - if {$a0 == ""} { - return $ast - } - switch [obj_val $a0] { - "def!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname $value] - } - "let*" { - set letenv [Env new $env] - set bindings_list [obj_val $a1] - foreach {varnameobj varvalobj} $bindings_list { - $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] - } - set ast $a2 - set env $letenv - # TCO: Continue loop - } - "quote" { - return $a1 - } - "quasiquoteexpand" { - return [quasiquote $a1] - } - "quasiquote" { - set ast [quasiquote $a1] - } - "defmacro!" { - set varname [obj_val $a1] - set value [EVAL $a2 $env] - return [$env set $varname [macro_new $value]] - } - "macroexpand" { - return [macroexpand $a1 $env] - } - "tcl*" { - return [string_new [eval [obj_val $a1]]] - } - "try*" { - if {$a2 == ""} { - return [EVAL $a1 $env] - } - set res {} - if { [catch { set res [EVAL $a1 $env] } exception] } { - set exc_var [obj_val [lindex [obj_val $a2] 1]] - if {$exception == "__MalException__"} { - set exc_value $::mal_exception_obj - } else { - set exc_value [string_new $exception] - } - set catch_env [Env new $env [list $exc_var] [list $exc_value]] - return [EVAL [lindex [obj_val $a2] 2] $catch_env] - } else { - return $res - } - } - "do" { - set el [list_new [lrange [obj_val $ast] 1 end-1]] - eval_ast $el $env - set ast [lindex [obj_val $ast] end] - # TCO: Continue loop - } - "if" { - set condval [EVAL $a1 $env] - if {[false_q $condval] || [nil_q $condval]} { - if {$a3 == ""} { - return $::mal_nil - } - set ast $a3 - } else { - set ast $a2 - } - # TCO: Continue loop - } - "fn*" { - set binds {} - foreach v [obj_val $a1] { - lappend binds [obj_val $v] - } - return [function_new $a2 $env $binds] - } - default { - set lst_obj [eval_ast $ast $env] - set lst [obj_val $lst_obj] - set f [lindex $lst 0] - set call_args [lrange $lst 1 end] - switch [obj_type $f] { - function { - set fn [obj_val $f] - set ast [dict get $fn body] - set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] - # TCO: Continue loop - } - nativefunction { - set body [concat [list [obj_val $f]] {$a}] - set lambda [list {a} $body] - return [apply $lambda $call_args] - } - default { - error "Not a function" - } - } - } - } - } -} - -proc PRINT exp { - pr_str $exp 1 -} - -proc REP {str env} { - PRINT [EVAL [READ $str] $env] -} - -proc RE {str env} { - EVAL [READ $str] $env -} - -proc mal_eval {a} { - global repl_env - EVAL [lindex $a 0] $repl_env -} - -set repl_env [Env new] -dict for {k v} $core_ns { - $repl_env set $k $v -} - -$repl_env set "eval" [nativefunction_new mal_eval] - -set argv_list {} -foreach arg [lrange $argv 1 end] { - lappend argv_list [string_new $arg] -} -$repl_env set "*ARGV*" [list_new $argv_list] - -# core.mal: defined using the language itself -RE "(def! *host-language* \"tcl\")" $repl_env -RE "(def! not (fn* (a) (if a false true)))" $repl_env -RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env -RE "(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)))))))" $repl_env - -fconfigure stdout -translation binary - -set DEBUG_MODE 0 -if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { - set DEBUG_MODE 1 -} - -if {$argc > 0} { - REP "(load-file \"[lindex $argv 0]\")" $repl_env - exit -} - -REP "(println (str \"Mal \[\" *host-language* \"\]\"))" $repl_env - -# repl loop -while {true} { - set res [_readline "user> "] - if {[lindex $res 0] == "EOF"} { - break - } - set line [lindex $res 1] - if {$line == ""} { - continue - } - if { [catch { puts [REP $line $repl_env] } exception] } { - if {$exception == "__MalException__"} { - set res [pr_str $::mal_exception_obj 1] - puts "Error: $res" - } else { - puts "Error: $exception" - } - if { $DEBUG_MODE } { - puts $::errorInfo - } - } -} -puts "" +source mal_readline.tcl +source types.tcl +source reader.tcl +source printer.tcl +source env.tcl +source core.tcl + +proc READ str { + read_str $str +} + +proc starts_with {lst sym} { + if {[llength $lst] != 2} { + return 0 + } + lassign [lindex $lst 0] a0 + return [symbol_q $a0] && [expr {[obj_val $a0] == $sym}] +} +proc qq_loop {elt acc} { + if {[list_q $elt] && [starts_with [obj_val $elt] "splice-unquote"]} { + return [list_new [list [symbol_new "concat"] [lindex [obj_val $elt] 1] $acc]] + } else { + return [list_new [list [symbol_new "cons"] [quasiquote $elt] $acc]] + } +} +proc qq_foldr {xs} { + set acc [list_new []] + for {set i [expr {[llength $xs] - 1}]} {0 <= $i} {incr i -1} { + set acc [qq_loop [lindex $xs $i] $acc] + } + return $acc +} + +proc quasiquote {ast} { + switch [obj_type $ast] { + "symbol" { + return [list_new [list [symbol_new "quote"] $ast]] + } + "hashmap" { + return [list_new [list [symbol_new "quote"] $ast]] + } + "vector" { + return [list_new [list [symbol_new "vec"] [qq_foldr [obj_val $ast]]]] + } + "list" { + if {[starts_with [obj_val $ast] "unquote"]} { + return [lindex [obj_val $ast] 1] + } else { + return [qq_foldr [obj_val $ast]] + } + } + default { + return $ast + } + } +} + +proc is_macro_call {ast env} { + if {![list_q $ast]} { + return 0 + } + set a0 [lindex [obj_val $ast] 0] + if {$a0 == "" || ![symbol_q $a0]} { + return 0 + } + set varname [obj_val $a0] + set foundenv [$env find $varname] + if {$foundenv == 0} { + return 0 + } + macro_q [$env get $varname] +} + +proc macroexpand {ast env} { + while {[is_macro_call $ast $env]} { + set a0 [mal_first [list $ast]] + set macro_name [obj_val $a0] + set macro_obj [$env get $macro_name] + set macro_args [obj_val [mal_rest [list $ast]]] + + set funcdict [obj_val $macro_obj] + set body [dict get $funcdict body] + set env [dict get $funcdict env] + set binds [dict get $funcdict binds] + set funcenv [Env new $env $binds $macro_args] + set ast [EVAL $body $funcenv] + } + return $ast +} + +proc eval_ast {ast env} { + switch [obj_type $ast] { + "symbol" { + set varname [obj_val $ast] + return [$env get $varname] + } + "list" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [list_new $res] + } + "vector" { + set res {} + foreach element [obj_val $ast] { + lappend res [EVAL $element $env] + } + return [vector_new $res] + } + "hashmap" { + set res [dict create] + dict for {k v} [obj_val $ast] { + dict set res $k [EVAL $v $env] + } + return [hashmap_new $res] + } + default { return $ast } + } +} + +proc EVAL {ast env} { + while {true} { + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + + set ast [macroexpand $ast $env] + if {![list_q $ast]} { + return [eval_ast $ast $env] + } + + lassign [obj_val $ast] a0 a1 a2 a3 + if {$a0 == ""} { + return $ast + } + switch [obj_val $a0] { + "def!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname $value] + } + "let*" { + set letenv [Env new $env] + set bindings_list [obj_val $a1] + foreach {varnameobj varvalobj} $bindings_list { + $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] + } + set ast $a2 + set env $letenv + # TCO: Continue loop + } + "quote" { + return $a1 + } + "quasiquoteexpand" { + return [quasiquote $a1] + } + "quasiquote" { + set ast [quasiquote $a1] + } + "defmacro!" { + set varname [obj_val $a1] + set value [EVAL $a2 $env] + return [$env set $varname [macro_new $value]] + } + "macroexpand" { + return [macroexpand $a1 $env] + } + "tcl*" { + return [string_new [eval [obj_val $a1]]] + } + "try*" { + if {$a2 == ""} { + return [EVAL $a1 $env] + } + set res {} + if { [catch { set res [EVAL $a1 $env] } exception] } { + set exc_var [obj_val [lindex [obj_val $a2] 1]] + if {$exception == "__MalException__"} { + set exc_value $::mal_exception_obj + } else { + set exc_value [string_new $exception] + } + set catch_env [Env new $env [list $exc_var] [list $exc_value]] + return [EVAL [lindex [obj_val $a2] 2] $catch_env] + } else { + return $res + } + } + "do" { + set el [list_new [lrange [obj_val $ast] 1 end-1]] + eval_ast $el $env + set ast [lindex [obj_val $ast] end] + # TCO: Continue loop + } + "if" { + set condval [EVAL $a1 $env] + if {[false_q $condval] || [nil_q $condval]} { + if {$a3 == ""} { + return $::mal_nil + } + set ast $a3 + } else { + set ast $a2 + } + # TCO: Continue loop + } + "fn*" { + set binds {} + foreach v [obj_val $a1] { + lappend binds [obj_val $v] + } + return [function_new $a2 $env $binds] + } + default { + set lst_obj [eval_ast $ast $env] + set lst [obj_val $lst_obj] + set f [lindex $lst 0] + set call_args [lrange $lst 1 end] + switch [obj_type $f] { + function { + set fn [obj_val $f] + set ast [dict get $fn body] + set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] + # TCO: Continue loop + } + nativefunction { + set body [concat [list [obj_val $f]] {$a}] + set lambda [list {a} $body] + return [apply $lambda $call_args] + } + default { + error "Not a function" + } + } + } + } + } +} + +proc PRINT exp { + pr_str $exp 1 +} + +proc REP {str env} { + PRINT [EVAL [READ $str] $env] +} + +proc RE {str env} { + EVAL [READ $str] $env +} + +proc mal_eval {a} { + global repl_env + EVAL [lindex $a 0] $repl_env +} + +set repl_env [Env new] +dict for {k v} $core_ns { + $repl_env set $k $v +} + +$repl_env set "eval" [nativefunction_new mal_eval] + +set argv_list {} +foreach arg [lrange $argv 1 end] { + lappend argv_list [string_new $arg] +} +$repl_env set "*ARGV*" [list_new $argv_list] + +# core.mal: defined using the language itself +RE "(def! *host-language* \"tcl\")" $repl_env +RE "(def! not (fn* (a) (if a false true)))" $repl_env +RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env +RE "(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)))))))" $repl_env + +fconfigure stdout -translation binary + +set DEBUG_MODE 0 +if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { + set DEBUG_MODE 1 +} + +if {$argc > 0} { + REP "(load-file \"[lindex $argv 0]\")" $repl_env + exit +} + +REP "(println (str \"Mal \[\" *host-language* \"\]\"))" $repl_env + +# repl loop +while {true} { + set res [_readline "user> "] + if {[lindex $res 0] == "EOF"} { + break + } + set line [lindex $res 1] + if {$line == ""} { + continue + } + if { [catch { puts [REP $line $repl_env] } exception] } { + if {$exception == "__MalException__"} { + set res [pr_str $::mal_exception_obj 1] + puts "Error: $res" + } else { + puts "Error: $exception" + } + if { $DEBUG_MODE } { + puts $::errorInfo + } + } +} +puts "" diff --git a/impls/tcl/tests/step5_tco.mal b/impls/tcl/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/tcl/tests/step5_tco.mal +++ b/impls/tcl/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/tcl/tests/stepA_mal.mal b/impls/tcl/tests/stepA_mal.mal index a53ddab71d..5a89d39dff 100644 --- a/impls/tcl/tests/stepA_mal.mal +++ b/impls/tcl/tests/stepA_mal.mal @@ -1,28 +1,28 @@ -;; Testing basic Tcl interop -;; -;; Note that in Tcl "everything is a string", so we don't have enough -;; information to convert the results to other Mal types. - -(tcl* "expr {3 ** 4}") -;=>"81" - -(tcl* "llength {a b c d}") -;=>"4" - -(tcl* "concat {a b} c {d e} f g") -;=>"a b c d e f g" - -(tcl* "puts \"hello [expr {5 + 6}] world\"") -;/hello 11 world -;=>"" - -(tcl* "set ::foo 8") -(tcl* "expr {$::foo}") -;=>"8" - -(tcl* "proc mult3 {x} { expr {$x * 3} }") -(tcl* "mult3 6") -;=>"18" - -(tcl* "string range $::tcl_version 0 1") -;=>"8." +;; Testing basic Tcl interop +;; +;; Note that in Tcl "everything is a string", so we don't have enough +;; information to convert the results to other Mal types. + +(tcl* "expr {3 ** 4}") +;=>"81" + +(tcl* "llength {a b c d}") +;=>"4" + +(tcl* "concat {a b} c {d e} f g") +;=>"a b c d e f g" + +(tcl* "puts \"hello [expr {5 + 6}] world\"") +;/hello 11 world +;=>"" + +(tcl* "set ::foo 8") +(tcl* "expr {$::foo}") +;=>"8" + +(tcl* "proc mult3 {x} { expr {$x * 3} }") +(tcl* "mult3 6") +;=>"18" + +(tcl* "string range $::tcl_version 0 1") +;=>"8." diff --git a/impls/tcl/types.tcl b/impls/tcl/types.tcl index 3742fc2c00..1ce85913a2 100644 --- a/impls/tcl/types.tcl +++ b/impls/tcl/types.tcl @@ -1,201 +1,201 @@ -oo::class create MalObj { - variable type val meta - - constructor {obj_type obj_val {obj_meta 0}} { - set type $obj_type - set val $obj_val - set meta $obj_meta - } - - method get_type {} { - return $type - } - - method get_val {} { - return $val - } - - method get_meta {} { - return $meta - } - - method set_val {new_val} { - set val $new_val - return $new_val - } -} - -proc obj_new {obj_type obj_val {obj_meta 0}} { - MalObj new $obj_type $obj_val $obj_meta -} - -proc obj_type {obj} { - $obj get_type -} - -proc obj_val {obj} { - $obj get_val -} - -proc obj_meta {obj} { - $obj get_meta -} - -proc obj_set_val {obj new_val} { - $obj set_val $new_val -} - -set ::mal_nil [obj_new "nil" {}] -set ::mal_true [obj_new "true" {}] -set ::mal_false [obj_new "false" {}] - -proc nil_q {obj} { - expr {[obj_type $obj] == "nil"} -} - -proc false_q {obj} { - expr {[obj_type $obj] == "false"} -} - -proc true_q {obj} { - expr {[obj_type $obj] == "true"} -} - -proc bool_new {val} { - if {$val == 0} { - return $::mal_false - } else { - return $::mal_true - } -} - -proc integer_new {num} { - obj_new "integer" $num -} - -proc integer_q {obj} { - expr {[obj_type $obj] == "integer"} -} - -proc symbol_new {name} { - obj_new "symbol" $name -} - -proc symbol_q {obj} { - expr {[obj_type $obj] == "symbol"} -} - -proc string_new {val} { - obj_new "string" $val -} - -proc string_q {obj} { - expr {[obj_type $obj] == "string" && [string index [obj_val $obj] 0] != "\u029E"} -} - -proc keyword_new {val} { - string_new "\u029E$val" -} - -proc keyword_q {obj} { - expr {[obj_type $obj] == "string" && [string index [obj_val $obj] 0] == "\u029E"} -} - -proc list_new {lst} { - obj_new "list" $lst $::mal_nil -} - -proc list_q {obj} { - expr {[obj_type $obj] == "list"} -} - -proc vector_new {lst} { - obj_new "vector" $lst $::mal_nil -} - -proc vector_q {obj} { - expr {[obj_type $obj] == "vector"} -} - -proc hashmap_new {lst} { - obj_new "hashmap" $lst $::mal_nil -} - -proc hashmap_q {obj} { - expr {[obj_type $obj] == "hashmap"} -} - -proc sequential_q {obj} { - expr {[list_q $obj] || [vector_q $obj]} -} - -proc sequential_equal_q {seq_a seq_b} { - foreach obj_a [obj_val $seq_a] obj_b [obj_val $seq_b] { - if {$obj_a == "" || $obj_b == "" || ![equal_q $obj_a $obj_b]} { - return 0 - } - } - return 1 -} - -proc hashmap_equal_q {hashmap_a hashmap_b} { - set dict_a [obj_val $hashmap_a] - set dict_b [obj_val $hashmap_b] - set keys_a [lsort [dict keys $dict_a]] - set keys_b [lsort [dict keys $dict_b]] - if {$keys_a != $keys_b} { - return 0 - } - foreach key $keys_a { - set obj_a [dict get $dict_a $key] - set obj_b [dict get $dict_b $key] - if {![equal_q $obj_a $obj_b]} { - return 0 - } - } - return 1 -} - -proc equal_q {a b} { - if {[sequential_q $a] && [sequential_q $b]} { - sequential_equal_q $a $b - } elseif {[hashmap_q $a] && [hashmap_q $b]} { - hashmap_equal_q $a $b - } else { - expr {[obj_type $a] == [obj_type $b] && [obj_val $a] == [obj_val $b]} - } -} - -proc nativefunction_new {name} { - obj_new "nativefunction" $name $::mal_nil -} - -proc function_new {body env binds} { - set funcdict [dict create body $body env $env binds $binds is_macro 0] - obj_new "function" $funcdict $::mal_nil -} - -proc macro_new {funcobj} { - set fn [obj_val $funcobj] - set body [dict get $fn body] - set env [dict get $fn env] - set binds [dict get $fn binds] - set funcdict [dict create body $body env $env binds $binds is_macro 1] - obj_new "function" $funcdict $::mal_nil -} - -proc function_q {obj} { - expr {[obj_type $obj] == "function"} -} - -proc macro_q {obj} { - expr {[obj_type $obj] == "function" && [dict get [obj_val $obj] is_macro]} -} - -proc atom_new {val} { - obj_new "atom" $val $::mal_nil -} - -proc atom_q {obj} { - expr {[obj_type $obj] == "atom"} -} +oo::class create MalObj { + variable type val meta + + constructor {obj_type obj_val {obj_meta 0}} { + set type $obj_type + set val $obj_val + set meta $obj_meta + } + + method get_type {} { + return $type + } + + method get_val {} { + return $val + } + + method get_meta {} { + return $meta + } + + method set_val {new_val} { + set val $new_val + return $new_val + } +} + +proc obj_new {obj_type obj_val {obj_meta 0}} { + MalObj new $obj_type $obj_val $obj_meta +} + +proc obj_type {obj} { + $obj get_type +} + +proc obj_val {obj} { + $obj get_val +} + +proc obj_meta {obj} { + $obj get_meta +} + +proc obj_set_val {obj new_val} { + $obj set_val $new_val +} + +set ::mal_nil [obj_new "nil" {}] +set ::mal_true [obj_new "true" {}] +set ::mal_false [obj_new "false" {}] + +proc nil_q {obj} { + expr {[obj_type $obj] == "nil"} +} + +proc false_q {obj} { + expr {[obj_type $obj] == "false"} +} + +proc true_q {obj} { + expr {[obj_type $obj] == "true"} +} + +proc bool_new {val} { + if {$val == 0} { + return $::mal_false + } else { + return $::mal_true + } +} + +proc integer_new {num} { + obj_new "integer" $num +} + +proc integer_q {obj} { + expr {[obj_type $obj] == "integer"} +} + +proc symbol_new {name} { + obj_new "symbol" $name +} + +proc symbol_q {obj} { + expr {[obj_type $obj] == "symbol"} +} + +proc string_new {val} { + obj_new "string" $val +} + +proc string_q {obj} { + expr {[obj_type $obj] == "string" && [string index [obj_val $obj] 0] != "\u029E"} +} + +proc keyword_new {val} { + string_new "\u029E$val" +} + +proc keyword_q {obj} { + expr {[obj_type $obj] == "string" && [string index [obj_val $obj] 0] == "\u029E"} +} + +proc list_new {lst} { + obj_new "list" $lst $::mal_nil +} + +proc list_q {obj} { + expr {[obj_type $obj] == "list"} +} + +proc vector_new {lst} { + obj_new "vector" $lst $::mal_nil +} + +proc vector_q {obj} { + expr {[obj_type $obj] == "vector"} +} + +proc hashmap_new {lst} { + obj_new "hashmap" $lst $::mal_nil +} + +proc hashmap_q {obj} { + expr {[obj_type $obj] == "hashmap"} +} + +proc sequential_q {obj} { + expr {[list_q $obj] || [vector_q $obj]} +} + +proc sequential_equal_q {seq_a seq_b} { + foreach obj_a [obj_val $seq_a] obj_b [obj_val $seq_b] { + if {$obj_a == "" || $obj_b == "" || ![equal_q $obj_a $obj_b]} { + return 0 + } + } + return 1 +} + +proc hashmap_equal_q {hashmap_a hashmap_b} { + set dict_a [obj_val $hashmap_a] + set dict_b [obj_val $hashmap_b] + set keys_a [lsort [dict keys $dict_a]] + set keys_b [lsort [dict keys $dict_b]] + if {$keys_a != $keys_b} { + return 0 + } + foreach key $keys_a { + set obj_a [dict get $dict_a $key] + set obj_b [dict get $dict_b $key] + if {![equal_q $obj_a $obj_b]} { + return 0 + } + } + return 1 +} + +proc equal_q {a b} { + if {[sequential_q $a] && [sequential_q $b]} { + sequential_equal_q $a $b + } elseif {[hashmap_q $a] && [hashmap_q $b]} { + hashmap_equal_q $a $b + } else { + expr {[obj_type $a] == [obj_type $b] && [obj_val $a] == [obj_val $b]} + } +} + +proc nativefunction_new {name} { + obj_new "nativefunction" $name $::mal_nil +} + +proc function_new {body env binds} { + set funcdict [dict create body $body env $env binds $binds is_macro 0] + obj_new "function" $funcdict $::mal_nil +} + +proc macro_new {funcobj} { + set fn [obj_val $funcobj] + set body [dict get $fn body] + set env [dict get $fn env] + set binds [dict get $fn binds] + set funcdict [dict create body $body env $env binds $binds is_macro 1] + obj_new "function" $funcdict $::mal_nil +} + +proc function_q {obj} { + expr {[obj_type $obj] == "function"} +} + +proc macro_q {obj} { + expr {[obj_type $obj] == "function" && [dict get [obj_val $obj] is_macro]} +} + +proc atom_new {val} { + obj_new "atom" $val $::mal_nil +} + +proc atom_q {obj} { + expr {[obj_type $obj] == "atom"} +} diff --git a/impls/tests/busywork.mal b/impls/tests/busywork.mal index fed35bf503..7ffc0b8157 100644 --- a/impls/tests/busywork.mal +++ b/impls/tests/busywork.mal @@ -1,31 +1,31 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/threading.mal") ; -> -(load-file-once "../lib/benchmark.mal") -(load-file-once "../lib/test_cascade.mal") ; or - -;; Indicate that these macros are safe to eagerly expand. -;; Provides a large performance benefit for supporting implementations. -(def! and ^{:inline? true} and) -(def! or ^{:inline? true} or) -(def! -> ^{:inline? true} ->) -(def! -> ^{:inline? true} ->>) - -(def! do-times (fn* [f n] - (if (> n 0) - (do (f) - (do-times f (- n 1)))))) - -(def! atm (atom (list 0 1 2 3 4 5 6 7 8 9))) - -(def! busywork (fn* [] - (do - (or false nil false nil false nil false nil false nil (first @atm)) - (cond false 1 nil 2 false 3 nil 4 false 5 nil 6 "else" (first @atm)) - (-> (deref atm) rest rest rest rest rest rest first) - (swap! atm (fn* [a] (concat (rest a) (list (first a)))))))) - -(def! num-iterations 10000) - -(println (str "Execution time (in ms) of " num-iterations " busywork iterations on " - *host-language* ": ") - (benchmark (do-times busywork num-iterations) 10)) +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/threading.mal") ; -> +(load-file-once "../lib/benchmark.mal") +(load-file-once "../lib/test_cascade.mal") ; or + +;; Indicate that these macros are safe to eagerly expand. +;; Provides a large performance benefit for supporting implementations. +(def! and ^{:inline? true} and) +(def! or ^{:inline? true} or) +(def! -> ^{:inline? true} ->) +(def! -> ^{:inline? true} ->>) + +(def! do-times (fn* [f n] + (if (> n 0) + (do (f) + (do-times f (- n 1)))))) + +(def! atm (atom (list 0 1 2 3 4 5 6 7 8 9))) + +(def! busywork (fn* [] + (do + (or false nil false nil false nil false nil false nil (first @atm)) + (cond false 1 nil 2 false 3 nil 4 false 5 nil 6 "else" (first @atm)) + (-> (deref atm) rest rest rest rest rest rest first) + (swap! atm (fn* [a] (concat (rest a) (list (first a)))))))) + +(def! num-iterations 10000) + +(println (str "Execution time (in ms) of " num-iterations " busywork iterations on " + *host-language* ": ") + (benchmark (do-times busywork num-iterations) 10)) diff --git a/impls/tests/computations.mal b/impls/tests/computations.mal index 9e418d9908..06bbfdf651 100644 --- a/impls/tests/computations.mal +++ b/impls/tests/computations.mal @@ -1,17 +1,17 @@ -;; Some inefficient arithmetic computations for benchmarking. - -;; Unfortunately not yet available in tests of steps 4 and 5. - -;; Compute n(n+1)/2 with a non tail-recursive call. -(def! sumdown - (fn* [n] ; non-negative number - (if (= n 0) - 0 - (+ n (sumdown (- n 1)))))) - -;; Compute a Fibonacci number with two recursions. -(def! fib - (fn* [n] ; non-negative number - (if (<= n 1) - n - (+ (fib (- n 1)) (fib (- n 2)))))) +;; Some inefficient arithmetic computations for benchmarking. + +;; Unfortunately not yet available in tests of steps 4 and 5. + +;; Compute n(n+1)/2 with a non tail-recursive call. +(def! sumdown + (fn* [n] ; non-negative number + (if (= n 0) + 0 + (+ n (sumdown (- n 1)))))) + +;; Compute a Fibonacci number with two recursions. +(def! fib + (fn* [n] ; non-negative number + (if (<= n 1) + n + (+ (fib (- n 1)) (fib (- n 2)))))) diff --git a/impls/tests/docker-build.sh b/impls/tests/docker-build.sh index e79c149de5..9652835036 100755 --- a/impls/tests/docker-build.sh +++ b/impls/tests/docker-build.sh @@ -1,6 +1,6 @@ -#!/bin/bash - -IMAGE_NAME=${IMAGE_NAME:-mal-test-ubuntu-utopic} -GIT_TOP=$(git rev-parse --show-toplevel) - -docker build -t "${IMAGE_NAME}" "${GIT_TOP}/tests/docker" +#!/bin/bash + +IMAGE_NAME=${IMAGE_NAME:-mal-test-ubuntu-utopic} +GIT_TOP=$(git rev-parse --show-toplevel) + +docker build -t "${IMAGE_NAME}" "${GIT_TOP}/tests/docker" diff --git a/impls/tests/docker-run.sh b/impls/tests/docker-run.sh index 1666d7d318..bb7252707f 100755 --- a/impls/tests/docker-run.sh +++ b/impls/tests/docker-run.sh @@ -1,9 +1,9 @@ -#!/bin/bash - -IMAGE_NAME=${IMAGE_NAME:-mal-test-ubuntu-utopic} -GIT_TOP=$(git rev-parse --show-toplevel) - -docker run -it --rm -u ${EUID} \ - --volume=${GIT_TOP}:/mal \ - ${IMAGE_NAME} \ - "${@}" +#!/bin/bash + +IMAGE_NAME=${IMAGE_NAME:-mal-test-ubuntu-utopic} +GIT_TOP=$(git rev-parse --show-toplevel) + +docker run -it --rm -u ${EUID} \ + --volume=${GIT_TOP}:/mal \ + ${IMAGE_NAME} \ + "${@}" diff --git a/impls/tests/docker/Dockerfile b/impls/tests/docker/Dockerfile index 71b7ed0a3e..95802d00da 100644 --- a/impls/tests/docker/Dockerfile +++ b/impls/tests/docker/Dockerfile @@ -1,178 +1,178 @@ -# WARNING: This file is deprecated. Each implementation now has its -# own Dockerfile. - -FROM ubuntu:utopic -MAINTAINER Joel Martin - -ENV DEBIAN_FRONTEND noninteractive - -RUN echo "deb http://dl.bintray.com/sbt/debian /" > /etc/apt/sources.list.d/sbt.list -RUN apt-get -y update - -# -# General dependencies -# -VOLUME /mal - -RUN apt-get -y install make wget curl git - -# Deps for compiled languages (C, Go, Rust, Nim, etc) -RUN apt-get -y install gcc pkg-config - -# Deps for Java-based languages (Clojure, Scala, Java) -RUN apt-get -y install openjdk-7-jdk -ENV MAVEN_OPTS -Duser.home=/mal - -# Deps for Mono-based languages (C#, VB.Net) -RUN apt-get -y install mono-runtime mono-mcs mono-vbnc - -# Deps for node.js languages (JavaScript, CoffeeScript, miniMAL, etc) -RUN apt-get -y install nodejs npm -RUN ln -sf nodejs /usr/bin/node - - -# -# Implementation specific installs -# - -# GNU awk -RUN apt-get -y install gawk - -# Bash -RUN apt-get -y install bash - -# C -RUN apt-get -y install libglib2.0 libglib2.0-dev -RUN apt-get -y install libffi-dev libreadline-dev libedit2 libedit-dev - -# C++ -RUN apt-get -y install g++-4.9 libreadline-dev - -# Clojure -ADD https://raw.githubusercontent.com/technomancy/leiningen/stable/bin/lein \ - /usr/local/bin/lein -RUN sudo chmod 0755 /usr/local/bin/lein -ENV LEIN_HOME /mal/.lein -ENV LEIN_JVM_OPTS -Duser.home=/mal - -# CoffeeScript -RUN npm install -g coffee-script -RUN touch /.coffee_history && chmod go+w /.coffee_history - -# C# -RUN apt-get -y install mono-mcs - -# Elixir -RUN wget https://packages.erlang-solutions.com/erlang-solutions_1.0_all.deb \ - && dpkg -i erlang-solutions_1.0_all.deb -RUN apt-get update -RUN apt-get -y install elixir - -# Erlang R17 (so I can use maps) -RUN apt-get -y install build-essential libncurses5-dev libssl-dev -RUN cd /tmp && wget http://www.erlang.org/download/otp_src_17.5.tar.gz \ - && tar -C /tmp -zxf /tmp/otp_src_17.5.tar.gz \ - && cd /tmp/otp_src_17.5 && ./configure && make && make install \ - && rm -rf /tmp/otp_src_17.5 /tmp/otp_src_17.5.tar.gz -# Rebar for building the Erlang implementation -RUN cd /tmp/ && git clone -q https://github.com/rebar/rebar.git \ - && cd /tmp/rebar && ./bootstrap && cp rebar /usr/local/bin \ - && rm -rf /tmp/rebar - -# Forth -RUN apt-get -y install gforth - -# Go -RUN apt-get -y install golang - -# Guile -RUN apt-get -y install libunistring-dev libgc-dev autoconf libtool flex gettext texinfo libgmp-dev -RUN git clone git://git.sv.gnu.org/guile.git /tmp/guile \ - && cd /tmp/guile && ./autogen.sh && ./configure && make && make install - -# Haskell -RUN apt-get -y install ghc haskell-platform libghc-readline-dev libghc-editline-dev - -# Java -RUN apt-get -y install maven2 - -# JavaScript -# Already satisfied above - -# Julia -RUN apt-get -y install software-properties-common -RUN apt-add-repository -y ppa:staticfloat/juliareleases -RUN apt-get -y update -RUN apt-get -y install julia - -# Lua -RUN apt-get -y install lua5.1 lua-rex-pcre luarocks -RUN luarocks install linenoise - -# Mal -# N/A: self-hosted on other language implementations - -# GNU Make -# Already satisfied as a based dependency for testing - -# miniMAL -RUN npm install -g minimal-lisp - -# Nim -RUN cd /tmp && wget http://nim-lang.org/download/nim-0.17.0.tar.xz \ - && tar xvJf /tmp/nim-0.17.0.tar.xz && cd nim-0.17.0 \ - && make && sh install.sh /usr/local/bin \ - && rm -r /tmp/nim-0.17.0 - -# OCaml -RUN apt-get -y install ocaml-batteries-included - -# perl -RUN apt-get -y install perl - -# PHP -RUN apt-get -y install php5-cli - -# PostScript/ghostscript -RUN apt-get -y install ghostscript - -# python -RUN apt-get -y install python - -# R -RUN apt-get -y install r-base-core - -# Racket -RUN apt-get -y install racket - -# Ruby -RUN apt-get -y install ruby - -# Rust -RUN curl -sf https://raw.githubusercontent.com/brson/multirust/master/blastoff.sh | sh - -# Scala -RUN apt-get -y --force-yes install sbt -RUN apt-get -y install scala -ENV SBT_OPTS -Duser.home=/mal - -# VB.Net -RUN apt-get -y install mono-vbnc - -# TODO: move up -# Factor -RUN apt-get -y install libgtkglext1 -RUN cd /usr/lib/x86_64-linux-gnu/ \ - && wget http://downloads.factorcode.org/releases/0.97/factor-linux-x86-64-0.97.tar.gz \ - && tar xvzf factor-linux-x86-64-0.97.tar.gz \ - && ln -sf /usr/lib/x86_64-linux-gnu/factor/factor /usr/bin/factor \ - && rm factor-linux-x86-64-0.97.tar.gz - -# MATLAB is proprietary/licensed. Maybe someday with Octave. -# Swift is XCode/OS X only -ENV SKIP_IMPLS matlab swift - -ENV DEBIAN_FRONTEND newt -ENV HOME / - -WORKDIR /mal +# WARNING: This file is deprecated. Each implementation now has its +# own Dockerfile. + +FROM ubuntu:utopic +MAINTAINER Joel Martin + +ENV DEBIAN_FRONTEND noninteractive + +RUN echo "deb http://dl.bintray.com/sbt/debian /" > /etc/apt/sources.list.d/sbt.list +RUN apt-get -y update + +# +# General dependencies +# +VOLUME /mal + +RUN apt-get -y install make wget curl git + +# Deps for compiled languages (C, Go, Rust, Nim, etc) +RUN apt-get -y install gcc pkg-config + +# Deps for Java-based languages (Clojure, Scala, Java) +RUN apt-get -y install openjdk-7-jdk +ENV MAVEN_OPTS -Duser.home=/mal + +# Deps for Mono-based languages (C#, VB.Net) +RUN apt-get -y install mono-runtime mono-mcs mono-vbnc + +# Deps for node.js languages (JavaScript, CoffeeScript, miniMAL, etc) +RUN apt-get -y install nodejs npm +RUN ln -sf nodejs /usr/bin/node + + +# +# Implementation specific installs +# + +# GNU awk +RUN apt-get -y install gawk + +# Bash +RUN apt-get -y install bash + +# C +RUN apt-get -y install libglib2.0 libglib2.0-dev +RUN apt-get -y install libffi-dev libreadline-dev libedit2 libedit-dev + +# C++ +RUN apt-get -y install g++-4.9 libreadline-dev + +# Clojure +ADD https://raw.githubusercontent.com/technomancy/leiningen/stable/bin/lein \ + /usr/local/bin/lein +RUN sudo chmod 0755 /usr/local/bin/lein +ENV LEIN_HOME /mal/.lein +ENV LEIN_JVM_OPTS -Duser.home=/mal + +# CoffeeScript +RUN npm install -g coffee-script +RUN touch /.coffee_history && chmod go+w /.coffee_history + +# C# +RUN apt-get -y install mono-mcs + +# Elixir +RUN wget https://packages.erlang-solutions.com/erlang-solutions_1.0_all.deb \ + && dpkg -i erlang-solutions_1.0_all.deb +RUN apt-get update +RUN apt-get -y install elixir + +# Erlang R17 (so I can use maps) +RUN apt-get -y install build-essential libncurses5-dev libssl-dev +RUN cd /tmp && wget http://www.erlang.org/download/otp_src_17.5.tar.gz \ + && tar -C /tmp -zxf /tmp/otp_src_17.5.tar.gz \ + && cd /tmp/otp_src_17.5 && ./configure && make && make install \ + && rm -rf /tmp/otp_src_17.5 /tmp/otp_src_17.5.tar.gz +# Rebar for building the Erlang implementation +RUN cd /tmp/ && git clone -q https://github.com/rebar/rebar.git \ + && cd /tmp/rebar && ./bootstrap && cp rebar /usr/local/bin \ + && rm -rf /tmp/rebar + +# Forth +RUN apt-get -y install gforth + +# Go +RUN apt-get -y install golang + +# Guile +RUN apt-get -y install libunistring-dev libgc-dev autoconf libtool flex gettext texinfo libgmp-dev +RUN git clone git://git.sv.gnu.org/guile.git /tmp/guile \ + && cd /tmp/guile && ./autogen.sh && ./configure && make && make install + +# Haskell +RUN apt-get -y install ghc haskell-platform libghc-readline-dev libghc-editline-dev + +# Java +RUN apt-get -y install maven2 + +# JavaScript +# Already satisfied above + +# Julia +RUN apt-get -y install software-properties-common +RUN apt-add-repository -y ppa:staticfloat/juliareleases +RUN apt-get -y update +RUN apt-get -y install julia + +# Lua +RUN apt-get -y install lua5.1 lua-rex-pcre luarocks +RUN luarocks install linenoise + +# Mal +# N/A: self-hosted on other language implementations + +# GNU Make +# Already satisfied as a based dependency for testing + +# miniMAL +RUN npm install -g minimal-lisp + +# Nim +RUN cd /tmp && wget http://nim-lang.org/download/nim-0.17.0.tar.xz \ + && tar xvJf /tmp/nim-0.17.0.tar.xz && cd nim-0.17.0 \ + && make && sh install.sh /usr/local/bin \ + && rm -r /tmp/nim-0.17.0 + +# OCaml +RUN apt-get -y install ocaml-batteries-included + +# perl +RUN apt-get -y install perl + +# PHP +RUN apt-get -y install php5-cli + +# PostScript/ghostscript +RUN apt-get -y install ghostscript + +# python +RUN apt-get -y install python + +# R +RUN apt-get -y install r-base-core + +# Racket +RUN apt-get -y install racket + +# Ruby +RUN apt-get -y install ruby + +# Rust +RUN curl -sf https://raw.githubusercontent.com/brson/multirust/master/blastoff.sh | sh + +# Scala +RUN apt-get -y --force-yes install sbt +RUN apt-get -y install scala +ENV SBT_OPTS -Duser.home=/mal + +# VB.Net +RUN apt-get -y install mono-vbnc + +# TODO: move up +# Factor +RUN apt-get -y install libgtkglext1 +RUN cd /usr/lib/x86_64-linux-gnu/ \ + && wget http://downloads.factorcode.org/releases/0.97/factor-linux-x86-64-0.97.tar.gz \ + && tar xvzf factor-linux-x86-64-0.97.tar.gz \ + && ln -sf /usr/lib/x86_64-linux-gnu/factor/factor /usr/bin/factor \ + && rm factor-linux-x86-64-0.97.tar.gz + +# MATLAB is proprietary/licensed. Maybe someday with Octave. +# Swift is XCode/OS X only +ENV SKIP_IMPLS matlab swift + +ENV DEBIAN_FRONTEND newt +ENV HOME / + +WORKDIR /mal diff --git a/impls/tests/inc.mal b/impls/tests/inc.mal index 39ebc55562..424fd3c085 100644 --- a/impls/tests/inc.mal +++ b/impls/tests/inc.mal @@ -1,4 +1,4 @@ -(def! inc1 (fn* (a) (+ 1 a))) -(def! inc2 (fn* (a) (+ 2 a))) -(def! inc3 (fn* (a) - (+ 3 a))) +(def! inc1 (fn* (a) (+ 1 a))) +(def! inc2 (fn* (a) (+ 2 a))) +(def! inc3 (fn* (a) + (+ 3 a))) diff --git a/impls/tests/incA.mal b/impls/tests/incA.mal index cbbea79651..7c5194313e 100644 --- a/impls/tests/incA.mal +++ b/impls/tests/incA.mal @@ -1,3 +1,3 @@ -(def! inc4 (fn* (a) (+ 4 a))) - -(prn (inc4 5)) +(def! inc4 (fn* (a) (+ 4 a))) + +(prn (inc4 5)) diff --git a/impls/tests/incB.mal b/impls/tests/incB.mal index 4dd43ad4a4..8df2d32d57 100644 --- a/impls/tests/incB.mal +++ b/impls/tests/incB.mal @@ -1,6 +1,6 @@ -;; A comment in a file -(def! inc4 (fn* (a) (+ 4 a))) -(def! inc5 (fn* (a) ;; a comment after code - (+ 5 a))) - +;; A comment in a file +(def! inc4 (fn* (a) (+ 4 a))) +(def! inc5 (fn* (a) ;; a comment after code + (+ 5 a))) + ;; ending comment without final new line \ No newline at end of file diff --git a/impls/tests/incC.mal b/impls/tests/incC.mal index d647d88082..9d323fbd9e 100644 --- a/impls/tests/incC.mal +++ b/impls/tests/incC.mal @@ -1,2 +1,2 @@ -(def! mymap {"a" - 1}) +(def! mymap {"a" + 1}) diff --git a/impls/tests/lib/alias-hacks.mal b/impls/tests/lib/alias-hacks.mal index 906a208f87..8d1c8a97fd 100644 --- a/impls/tests/lib/alias-hacks.mal +++ b/impls/tests/lib/alias-hacks.mal @@ -1,55 +1,55 @@ -;; Testing alias-hacks.mal -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/alias-hacks.mal") -;=>nil - -;; Testing let -(macroexpand (let binds a b)) -;=>(let* binds (do a b)) -(let [x 2] 3 x) -;=>2 - -;; Testing when -(macroexpand (when condition a b)) -;=>(if condition (do a b)) -(when false (nth () 0) a) -;=>nil -(when true 3 2) -;=>2 - -;; Testing name -(macroexpand (def name a b)) -;=>(def! name (do a b)) -(def x 1 2 3) -;=>3 -x -;=>3 - -;; Testing fn -(macroexpand (fn args a b)) -;=>(fn* args (do a b)) -((fn [x] 1 2) 3) -;=>2 - -;; Testing defn -(macroexpand (defn name args b)) -;=>(def! name (fn args b)) -(defn f [x] 1 2 x) -(f 3) -;=>3 - -;; Testing partial -((partial +) 1 2) -;=>3 -((partial + 1) 2) -;=>3 -((partial + 1 2)) -;=>3 -((partial not) false) -;=>true -((partial not false)) -;=>true -((partial (fn* [x y] (+ x y)) 1) 2) -;=>3 -((partial str 1 2) 3 4) -;=>"1234" +;; Testing alias-hacks.mal +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/alias-hacks.mal") +;=>nil + +;; Testing let +(macroexpand (let binds a b)) +;=>(let* binds (do a b)) +(let [x 2] 3 x) +;=>2 + +;; Testing when +(macroexpand (when condition a b)) +;=>(if condition (do a b)) +(when false (nth () 0) a) +;=>nil +(when true 3 2) +;=>2 + +;; Testing name +(macroexpand (def name a b)) +;=>(def! name (do a b)) +(def x 1 2 3) +;=>3 +x +;=>3 + +;; Testing fn +(macroexpand (fn args a b)) +;=>(fn* args (do a b)) +((fn [x] 1 2) 3) +;=>2 + +;; Testing defn +(macroexpand (defn name args b)) +;=>(def! name (fn args b)) +(defn f [x] 1 2 x) +(f 3) +;=>3 + +;; Testing partial +((partial +) 1 2) +;=>3 +((partial + 1) 2) +;=>3 +((partial + 1 2)) +;=>3 +((partial not) false) +;=>true +((partial not false)) +;=>true +((partial (fn* [x y] (+ x y)) 1) 2) +;=>3 +((partial str 1 2) 3 4) +;=>"1234" diff --git a/impls/tests/lib/equality.mal b/impls/tests/lib/equality.mal index 52c42b1597..641dc1a7f4 100644 --- a/impls/tests/lib/equality.mal +++ b/impls/tests/lib/equality.mal @@ -1,61 +1,61 @@ -(def! orig= =) - -;; Testing equality.mal does not fix built-in equality. -(load-file "../lib/equality.mal") -;=>nil - -;; Testing bool-and -(bool-and) -;=>true -(bool-and true) -;=>true -(bool-and false) -;=>false -(bool-and nil) -;=>false -(bool-and 1) -;=>true -(bool-and 1 2) -;=>true -(bool-and nil (nth () 1)) -;=>false - -;; Testing bool-or -(bool-or) -;=>false -(bool-or true) -;=>true -(bool-or false) -;=>false -(bool-or nil) -;=>false -(bool-or 1) -;=>true -(bool-or 1 (nth () 1)) -;=>true -(bool-or 1 2) -;=>true -(bool-or false nil) -;=>false - -;; Breaking equality. -(def! = (fn* [a b] (bool-and (orig= a b) (cond (list? a) (list? b) (vector? a) (vector? b) true true)))) -(= [] ()) -;=>false - -;; Testing that equality.mal detects the problem. -(load-file "../lib/equality.mal") -;/equality.mal: Replaced = with pure mal implementation -;=>nil - -;; Testing fixed equality. -(= [] ()) -;=>true -(= [:a :b] (list :a :b)) -;=>true -(= [:a :b] [:a :b :c]) -;=>false -(= {:a 1} {:a 1}) -;=>true -(= {:a 1} {:a 1 :b 2}) -;=>false +(def! orig= =) + +;; Testing equality.mal does not fix built-in equality. +(load-file "../lib/equality.mal") +;=>nil + +;; Testing bool-and +(bool-and) +;=>true +(bool-and true) +;=>true +(bool-and false) +;=>false +(bool-and nil) +;=>false +(bool-and 1) +;=>true +(bool-and 1 2) +;=>true +(bool-and nil (nth () 1)) +;=>false + +;; Testing bool-or +(bool-or) +;=>false +(bool-or true) +;=>true +(bool-or false) +;=>false +(bool-or nil) +;=>false +(bool-or 1) +;=>true +(bool-or 1 (nth () 1)) +;=>true +(bool-or 1 2) +;=>true +(bool-or false nil) +;=>false + +;; Breaking equality. +(def! = (fn* [a b] (bool-and (orig= a b) (cond (list? a) (list? b) (vector? a) (vector? b) true true)))) +(= [] ()) +;=>false + +;; Testing that equality.mal detects the problem. +(load-file "../lib/equality.mal") +;/equality.mal: Replaced = with pure mal implementation +;=>nil + +;; Testing fixed equality. +(= [] ()) +;=>true +(= [:a :b] (list :a :b)) +;=>true +(= [:a :b] [:a :b :c]) +;=>false +(= {:a 1} {:a 1}) +;=>true +(= {:a 1} {:a 1 :b 2}) +;=>false diff --git a/impls/tests/lib/load-file-once-inc.mal b/impls/tests/lib/load-file-once-inc.mal index 2f912a8985..d9684606cd 100644 --- a/impls/tests/lib/load-file-once-inc.mal +++ b/impls/tests/lib/load-file-once-inc.mal @@ -1 +1 @@ -(swap! counter (fn* [x] (+ 1 x))) +(swap! counter (fn* [x] (+ 1 x))) diff --git a/impls/tests/lib/load-file-once.mal b/impls/tests/lib/load-file-once.mal index ac84cb01e9..96722cce6d 100644 --- a/impls/tests/lib/load-file-once.mal +++ b/impls/tests/lib/load-file-once.mal @@ -1,44 +1,44 @@ -(def! counter (atom 0)) -;=>(atom 0) - -;; The counter is increased by each `load-file`. -(load-file "../tests/lib/load-file-once-inc.mal") -;=>nil -@counter -;=>1 -(load-file "../tests/lib/load-file-once-inc.mal") -;=>nil -@counter -;=>2 - -;; load-file-once is available -(load-file "../lib/load-file-once.mal") -;=>nil - -;; First import actually calls `load-file`. -(load-file-once "../tests/lib/load-file-once-inc.mal") -;=>nil -@counter -;=>3 - -;; Later imports do nothing. -(load-file-once "../tests/lib/load-file-once-inc.mal") -;=>nil -@counter -;=>3 - -;; Loading the module twice does not reset its memory. -(load-file "../lib/load-file-once.mal") -;=>nil -(load-file-once "../tests/lib/load-file-once-inc.mal") -;=>nil -@counter -;=>3 - -;; even if done with itself -(load-file-once "../lib/load-file-once.mal") -;=>nil -(load-file-once "../tests/lib/load-file-once-inc.mal") -;=>nil -@counter -;=>3 +(def! counter (atom 0)) +;=>(atom 0) + +;; The counter is increased by each `load-file`. +(load-file "../tests/lib/load-file-once-inc.mal") +;=>nil +@counter +;=>1 +(load-file "../tests/lib/load-file-once-inc.mal") +;=>nil +@counter +;=>2 + +;; load-file-once is available +(load-file "../lib/load-file-once.mal") +;=>nil + +;; First import actually calls `load-file`. +(load-file-once "../tests/lib/load-file-once-inc.mal") +;=>nil +@counter +;=>3 + +;; Later imports do nothing. +(load-file-once "../tests/lib/load-file-once-inc.mal") +;=>nil +@counter +;=>3 + +;; Loading the module twice does not reset its memory. +(load-file "../lib/load-file-once.mal") +;=>nil +(load-file-once "../tests/lib/load-file-once-inc.mal") +;=>nil +@counter +;=>3 + +;; even if done with itself +(load-file-once "../lib/load-file-once.mal") +;=>nil +(load-file-once "../tests/lib/load-file-once-inc.mal") +;=>nil +@counter +;=>3 diff --git a/impls/tests/lib/memoize.mal b/impls/tests/lib/memoize.mal index 60fc43d23e..aad30416b4 100644 --- a/impls/tests/lib/memoize.mal +++ b/impls/tests/lib/memoize.mal @@ -1,18 +1,18 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../tests/computations.mal") -(load-file-once "../lib/memoize.mal") -;=>nil - -(def! N 32) - -;; Benchmark naive 'fib' - -(def! r1 (fib N)) ; Should be slow - -;; Benchmark memoized 'fib' - -(def! fib (memoize fib)) -(def! r2 (fib N)) ; Should be quick - -(= r1 r2) -;=>true +(load-file "../lib/load-file-once.mal") +(load-file-once "../tests/computations.mal") +(load-file-once "../lib/memoize.mal") +;=>nil + +(def! N 32) + +;; Benchmark naive 'fib' + +(def! r1 (fib N)) ; Should be slow + +;; Benchmark memoized 'fib' + +(def! fib (memoize fib)) +(def! r2 (fib N)) ; Should be quick + +(= r1 r2) +;=>true diff --git a/impls/tests/lib/pprint.mal b/impls/tests/lib/pprint.mal index 457dd4d63e..7e33080aa6 100644 --- a/impls/tests/lib/pprint.mal +++ b/impls/tests/lib/pprint.mal @@ -1,39 +1,39 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/pprint.mal") -;=>nil - -(pprint '(7 8 9 "ten" [11 12 [13 14]] 15 16)) -;/\(7 -;/ 8 -;/ 9 -;/ "ten" -;/ \[11 -;/ 12 -;/ \[13 -;/ 14\]\] -;/ 15 -;/ 16\) -;=>nil - -(pprint '{:abc 123 :def {:ghi 456 :jkl [789 "ten eleven twelve"]}}) -;/\{:abc 123 -;/ :def \{:ghi 456 -;/ :jkl \[789 -;/ "ten eleven twelve"\]\}\} -;=>nil - -(pprint '(7 8 {:abc 123 :def {:ghi 456 :jkl 789}} 9 10 [11 12 [13 14]] 15 16)) -;/\(7 -;/ 8 -;/ \{:abc 123 -;/ :def \{:ghi 456 -;/ :jkl 789\}\} -;/ 9 -;/ 10 -;/ \[11 -;/ 12 -;/ \[13 -;/ 14\]\] -;/ 15 -;/ 16\) -;=>nil +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/pprint.mal") +;=>nil + +(pprint '(7 8 9 "ten" [11 12 [13 14]] 15 16)) +;/\(7 +;/ 8 +;/ 9 +;/ "ten" +;/ \[11 +;/ 12 +;/ \[13 +;/ 14\]\] +;/ 15 +;/ 16\) +;=>nil + +(pprint '{:abc 123 :def {:ghi 456 :jkl [789 "ten eleven twelve"]}}) +;/\{:abc 123 +;/ :def \{:ghi 456 +;/ :jkl \[789 +;/ "ten eleven twelve"\]\}\} +;=>nil + +(pprint '(7 8 {:abc 123 :def {:ghi 456 :jkl 789}} 9 10 [11 12 [13 14]] 15 16)) +;/\(7 +;/ 8 +;/ \{:abc 123 +;/ :def \{:ghi 456 +;/ :jkl 789\}\} +;/ 9 +;/ 10 +;/ \[11 +;/ 12 +;/ \[13 +;/ 14\]\] +;/ 15 +;/ 16\) +;=>nil diff --git a/impls/tests/lib/protocols.mal b/impls/tests/lib/protocols.mal index 819543d808..a2ed58dcfc 100644 --- a/impls/tests/lib/protocols.mal +++ b/impls/tests/lib/protocols.mal @@ -1,81 +1,81 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/protocols.mal") -;=>nil - -;; Testing find-type for normal objects. -(find-type 'a) -;=>:mal/symbol -(find-type :a) -;=>:mal/keyword -(find-type (atom 0)) -;=>:mal/atom -(find-type nil) -;=>:mal/nil -(find-type true) -;=>:mal/boolean -(find-type false) -;=>:mal/boolean -(find-type 0) -;=>:mal/number -(find-type "") -;=>:mal/string -(find-type (defmacro! m (fn* [] nil))) -;=>:mal/macro -(find-type ()) -;=>:mal/list -(find-type []) -;=>:mal/vector -(find-type {}) -;=>:mal/map -(find-type (fn* [] nil)) -;=>:mal/function - -;; Testing find-type for explicit type metadata. -(find-type ^{:type :a } ()) -;=>:a -(find-type ^{:type :a } []) -;=>:a -(find-type ^{:type :a } {}) -;=>:a -(find-type ^{:type :a } (fn* [] nil)) -;=>:a - -;; Testing protocols. -(def! o1 ^{:type :t1 } [1]) -(def! o2 ^{:type :t2 } [2]) -(defprotocol p1 [m0 [this]] [ma [this a]] [mb [this & b]]) -(defprotocol p2) -(satisfies? p1 o1) -;=>false -(satisfies? p1 o2) -;=>false -(satisfies? p2 o1) -;=>false -(satisfies? p2 o2) -;=>false -(extend :t1 p1 { :m0 (fn* [this] (str "t0" this)) :ma (fn* [this a] (str "ta" this a)) :mb (fn* [this & b] (str "tb" this b))}) -;=>nil -(extend :t2 p1 { :m0 (fn* [this] (str "u0" this)) :ma (fn* [this a] (str "ua" this a)) :mb (fn* [this & b] (str "ub" this b))} p2 {}) -;=>nil -(satisfies? p1 o1) -;=>true -(satisfies? p1 o2) -;=>true -(satisfies? p2 o1) -;=>false -(satisfies? p2 o2) -;=>true - -;; Testing dispatching. -(m0 o1) -;=>"t0[1]" -(ma o1 "blue") -;=>"ta[1]blue" -(mb o1 1 2 3) -;=>"tb[1](1 2 3)" -(m0 o2) -;=>"u0[2]" -(ma o2 "blue") -;=>"ua[2]blue" -(mb o2 1 2 3) -;=>"ub[2](1 2 3)" +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/protocols.mal") +;=>nil + +;; Testing find-type for normal objects. +(find-type 'a) +;=>:mal/symbol +(find-type :a) +;=>:mal/keyword +(find-type (atom 0)) +;=>:mal/atom +(find-type nil) +;=>:mal/nil +(find-type true) +;=>:mal/boolean +(find-type false) +;=>:mal/boolean +(find-type 0) +;=>:mal/number +(find-type "") +;=>:mal/string +(find-type (defmacro! m (fn* [] nil))) +;=>:mal/macro +(find-type ()) +;=>:mal/list +(find-type []) +;=>:mal/vector +(find-type {}) +;=>:mal/map +(find-type (fn* [] nil)) +;=>:mal/function + +;; Testing find-type for explicit type metadata. +(find-type ^{:type :a } ()) +;=>:a +(find-type ^{:type :a } []) +;=>:a +(find-type ^{:type :a } {}) +;=>:a +(find-type ^{:type :a } (fn* [] nil)) +;=>:a + +;; Testing protocols. +(def! o1 ^{:type :t1 } [1]) +(def! o2 ^{:type :t2 } [2]) +(defprotocol p1 [m0 [this]] [ma [this a]] [mb [this & b]]) +(defprotocol p2) +(satisfies? p1 o1) +;=>false +(satisfies? p1 o2) +;=>false +(satisfies? p2 o1) +;=>false +(satisfies? p2 o2) +;=>false +(extend :t1 p1 { :m0 (fn* [this] (str "t0" this)) :ma (fn* [this a] (str "ta" this a)) :mb (fn* [this & b] (str "tb" this b))}) +;=>nil +(extend :t2 p1 { :m0 (fn* [this] (str "u0" this)) :ma (fn* [this a] (str "ua" this a)) :mb (fn* [this & b] (str "ub" this b))} p2 {}) +;=>nil +(satisfies? p1 o1) +;=>true +(satisfies? p1 o2) +;=>true +(satisfies? p2 o1) +;=>false +(satisfies? p2 o2) +;=>true + +;; Testing dispatching. +(m0 o1) +;=>"t0[1]" +(ma o1 "blue") +;=>"ta[1]blue" +(mb o1 1 2 3) +;=>"tb[1](1 2 3)" +(m0 o2) +;=>"u0[2]" +(ma o2 "blue") +;=>"ua[2]blue" +(mb o2 1 2 3) +;=>"ub[2](1 2 3)" diff --git a/impls/tests/lib/reducers.mal b/impls/tests/lib/reducers.mal index 9aa242dac5..94fb27de1b 100644 --- a/impls/tests/lib/reducers.mal +++ b/impls/tests/lib/reducers.mal @@ -1,33 +1,33 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/reducers.mal") -;=>nil - -;; Testing reduce -(reduce + 7 []) -;=>7 -(reduce + 7 [1]) -;=>8 -(reduce + 7 [1 2]) -;=>10 -(reduce * 7 [-1 2]) -;=>-14 -(reduce concat [1] [[2] [3]]) -;=>(1 2 3) -(reduce str "a" ["b" "c"]) -;=>"abc" - -;; Testing foldr -(foldr + 7 []) -;=>7 -(foldr + 7 [1]) -;=>8 -(foldr + 7 [1 2]) -;=>10 -(reduce * 7 [-1 2]) -;=>-14 -(foldr concat [1] [[2] [3]]) -;=>(2 3 1) -(foldr str "a" ["b" "c"]) -;=>"bca" -(foldr cons [4 5] [2 3]) -;=>(2 3 4 5) +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/reducers.mal") +;=>nil + +;; Testing reduce +(reduce + 7 []) +;=>7 +(reduce + 7 [1]) +;=>8 +(reduce + 7 [1 2]) +;=>10 +(reduce * 7 [-1 2]) +;=>-14 +(reduce concat [1] [[2] [3]]) +;=>(1 2 3) +(reduce str "a" ["b" "c"]) +;=>"abc" + +;; Testing foldr +(foldr + 7 []) +;=>7 +(foldr + 7 [1]) +;=>8 +(foldr + 7 [1 2]) +;=>10 +(reduce * 7 [-1 2]) +;=>-14 +(foldr concat [1] [[2] [3]]) +;=>(2 3 1) +(foldr str "a" ["b" "c"]) +;=>"bca" +(foldr cons [4 5] [2 3]) +;=>(2 3 4 5) diff --git a/impls/tests/lib/test_cascade.mal b/impls/tests/lib/test_cascade.mal index 95e4632a12..b2ca2550d8 100644 --- a/impls/tests/lib/test_cascade.mal +++ b/impls/tests/lib/test_cascade.mal @@ -1,46 +1,46 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/test_cascade.mal") -;=>nil - -;; Testing or -(or) -;=>nil -(or 1) -;=>1 -(or 1 2 3 4) -;=>1 -(or false 2) -;=>2 -(or false nil 3) -;=>3 -(or false nil false false nil 4) -;=>4 -(or false nil 3 false nil 4) -;=>3 -(or (or false 4)) -;=>4 - -;; Testing every? -(every? first []) -;=>true -(every? first [[1] [2]]) -;=>true -(every? first [[1] [nil] []]) -;=>false - -;; Testing some -(some first []) -;=>nil -(some first [[nil] [1] []]) -;=>1 - -(and) -;=>true -(and 1) -;=>1 -(and 1 2 3 4) -;=>4 -(and false 2) -;=>false -(and true 1 nil false) -;=>nil +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/test_cascade.mal") +;=>nil + +;; Testing or +(or) +;=>nil +(or 1) +;=>1 +(or 1 2 3 4) +;=>1 +(or false 2) +;=>2 +(or false nil 3) +;=>3 +(or false nil false false nil 4) +;=>4 +(or false nil 3 false nil 4) +;=>3 +(or (or false 4)) +;=>4 + +;; Testing every? +(every? first []) +;=>true +(every? first [[1] [2]]) +;=>true +(every? first [[1] [nil] []]) +;=>false + +;; Testing some +(some first []) +;=>nil +(some first [[nil] [1] []]) +;=>1 + +(and) +;=>true +(and 1) +;=>1 +(and 1 2 3 4) +;=>4 +(and false 2) +;=>false +(and true 1 nil false) +;=>nil diff --git a/impls/tests/lib/threading.mal b/impls/tests/lib/threading.mal index 9d3fe96eaf..274a8a2e94 100644 --- a/impls/tests/lib/threading.mal +++ b/impls/tests/lib/threading.mal @@ -1,23 +1,23 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/threading.mal") -;=>nil - -;; Testing -> macro -(-> 7) -;=>7 -(-> (list 7 8 9) first) -;=>7 -(-> (list 7 8 9) (first)) -;=>7 -(-> (list 7 8 9) first (+ 7)) -;=>14 -(-> (list 7 8 9) rest (rest) first (+ 7)) -;=>16 - -;; Testing ->> macro -(->> "L") -;=>"L" -(->> "L" (str "A") (str "M")) -;=>"MAL" -(->> [4] (concat [3]) (concat [2]) rest (concat [1])) -;=>(1 3 4) +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/threading.mal") +;=>nil + +;; Testing -> macro +(-> 7) +;=>7 +(-> (list 7 8 9) first) +;=>7 +(-> (list 7 8 9) (first)) +;=>7 +(-> (list 7 8 9) first (+ 7)) +;=>14 +(-> (list 7 8 9) rest (rest) first (+ 7)) +;=>16 + +;; Testing ->> macro +(->> "L") +;=>"L" +(->> "L" (str "A") (str "M")) +;=>"MAL" +(->> [4] (concat [3]) (concat [2]) rest (concat [1])) +;=>(1 3 4) diff --git a/impls/tests/lib/trivial.mal b/impls/tests/lib/trivial.mal index 1d9c7c0bd3..66fe3bc4c3 100644 --- a/impls/tests/lib/trivial.mal +++ b/impls/tests/lib/trivial.mal @@ -1,16 +1,16 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/trivial.mal") -;=>nil - -(inc 12) -;=>13 -(dec 12) -;=>11 -(zero? 12) -;=>false -(zero? 0) -;=>true -(identity 12) -;=>12 -(= (gensym) (gensym)) -;=>false +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/trivial.mal") +;=>nil + +(inc 12) +;=>13 +(dec 12) +;=>11 +(zero? 12) +;=>false +(zero? 0) +;=>true +(identity 12) +;=>12 +(= (gensym) (gensym)) +;=>false diff --git a/impls/tests/perf1.mal b/impls/tests/perf1.mal index 9d1db7cbc2..4a56e50197 100644 --- a/impls/tests/perf1.mal +++ b/impls/tests/perf1.mal @@ -1,13 +1,13 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/threading.mal") ; -> -(load-file-once "../lib/perf.mal") ; time -(load-file-once "../lib/test_cascade.mal") ; or - -;;(prn "Start: basic macros performance test") - -(time (do - (or false nil false nil false nil false nil false nil 4) - (cond false 1 nil 2 false 3 nil 4 false 5 nil 6 "else" 7) - (-> (list 1 2 3 4 5 6 7 8 9) rest rest rest rest rest rest first))) - -;;(prn "Done: basic macros performance test") +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/threading.mal") ; -> +(load-file-once "../lib/perf.mal") ; time +(load-file-once "../lib/test_cascade.mal") ; or + +;;(prn "Start: basic macros performance test") + +(time (do + (or false nil false nil false nil false nil false nil 4) + (cond false 1 nil 2 false 3 nil 4 false 5 nil 6 "else" 7) + (-> (list 1 2 3 4 5 6 7 8 9) rest rest rest rest rest rest first))) + +;;(prn "Done: basic macros performance test") diff --git a/impls/tests/perf2.mal b/impls/tests/perf2.mal index 4f0bc6ccde..071215f9c1 100644 --- a/impls/tests/perf2.mal +++ b/impls/tests/perf2.mal @@ -1,11 +1,11 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../tests/computations.mal") ; fib sumdown -(load-file-once "../lib/perf.mal") ; time - -;;(prn "Start: basic math/recursion test") - -(time (do - (sumdown 10) - (fib 12))) - -;;(prn "Done: basic math/recursion test") +(load-file "../lib/load-file-once.mal") +(load-file-once "../tests/computations.mal") ; fib sumdown +(load-file-once "../lib/perf.mal") ; time + +;;(prn "Start: basic math/recursion test") + +(time (do + (sumdown 10) + (fib 12))) + +;;(prn "Done: basic math/recursion test") diff --git a/impls/tests/perf3.mal b/impls/tests/perf3.mal index da81f8dedc..e99d9bd8bd 100644 --- a/impls/tests/perf3.mal +++ b/impls/tests/perf3.mal @@ -1,20 +1,20 @@ -(load-file "../lib/load-file-once.mal") -(load-file-once "../lib/threading.mal") ; -> -(load-file-once "../lib/perf.mal") ; run-fn-for -(load-file-once "../lib/test_cascade.mal") ; or - -;;(prn "Start: basic macros/atom test") - -(def! atm (atom (list 0 1 2 3 4 5 6 7 8 9))) - -(println "iters over 10 seconds:" - (run-fn-for - (fn* [] - (do - (or false nil false nil false nil false nil false nil (first @atm)) - (cond false 1 nil 2 false 3 nil 4 false 5 nil 6 "else" (first @atm)) - (-> (deref atm) rest rest rest rest rest rest first) - (swap! atm (fn* [a] (concat (rest a) (list (first a))))))) - 10)) - -;;(prn "Done: basic macros/atom test") +(load-file "../lib/load-file-once.mal") +(load-file-once "../lib/threading.mal") ; -> +(load-file-once "../lib/perf.mal") ; run-fn-for +(load-file-once "../lib/test_cascade.mal") ; or + +;;(prn "Start: basic macros/atom test") + +(def! atm (atom (list 0 1 2 3 4 5 6 7 8 9))) + +(println "iters over 10 seconds:" + (run-fn-for + (fn* [] + (do + (or false nil false nil false nil false nil false nil (first @atm)) + (cond false 1 nil 2 false 3 nil 4 false 5 nil 6 "else" (first @atm)) + (-> (deref atm) rest rest rest rest rest rest first) + (swap! atm (fn* [a] (concat (rest a) (list (first a))))))) + 10)) + +;;(prn "Done: basic macros/atom test") diff --git a/impls/tests/print_argv.mal b/impls/tests/print_argv.mal index 7c28dfb79c..bb467e25dd 100644 --- a/impls/tests/print_argv.mal +++ b/impls/tests/print_argv.mal @@ -1,2 +1,2 @@ -; Used by the run_argv_test.sh test harness -(prn *ARGV*) +; Used by the run_argv_test.sh test harness +(prn *ARGV*) diff --git a/impls/tests/run_argv_test.sh b/impls/tests/run_argv_test.sh index bb29598f03..84bd688dd0 100755 --- a/impls/tests/run_argv_test.sh +++ b/impls/tests/run_argv_test.sh @@ -1,39 +1,39 @@ -#!/bin/bash - -# -# Usage: run_argv_test.sh -# -# Example: run_argv_test.sh python step6_file.py -# - -assert_equal() { - if [ "$1" = "$2" ] ; then - echo "OK: '$1'" - else - echo "FAIL: Expected '$1' but got '$2'" - echo - exit 1 - fi -} - -if [ -z "$1" ] ; then - echo "Usage: $0 " - exit 1 -fi - -root="$(dirname $0)" - -out="$( $@ $root/print_argv.mal aaa bbb ccc | tr -d '\r' )" -assert_equal '("aaa" "bbb" "ccc")' "$out" - -# Note: The 'make' implementation cannot handle arguments with spaces in them, -# so for now we skip this test. -# -# out="$( $@ $root/print_argv.mal aaa 'bbb ccc' ddd )" -# assert_equal '("aaa" "bbb ccc" "ddd")' "$out" - -out="$( $@ $root/print_argv.mal | tr -d '\r' )" -assert_equal '()' "$out" - -echo 'Passed all *ARGV* tests' -echo +#!/bin/bash + +# +# Usage: run_argv_test.sh +# +# Example: run_argv_test.sh python step6_file.py +# + +assert_equal() { + if [ "$1" = "$2" ] ; then + echo "OK: '$1'" + else + echo "FAIL: Expected '$1' but got '$2'" + echo + exit 1 + fi +} + +if [ -z "$1" ] ; then + echo "Usage: $0 " + exit 1 +fi + +root="$(dirname $0)" + +out="$( $@ $root/print_argv.mal aaa bbb ccc | tr -d '\r' )" +assert_equal '("aaa" "bbb" "ccc")' "$out" + +# Note: The 'make' implementation cannot handle arguments with spaces in them, +# so for now we skip this test. +# +# out="$( $@ $root/print_argv.mal aaa 'bbb ccc' ddd )" +# assert_equal '("aaa" "bbb ccc" "ddd")' "$out" + +out="$( $@ $root/print_argv.mal | tr -d '\r' )" +assert_equal '()' "$out" + +echo 'Passed all *ARGV* tests' +echo diff --git "a/impls/tests/step0_repl - \345\211\257\346\234\254.mal" "b/impls/tests/step0_repl - \345\211\257\346\234\254.mal" new file mode 100644 index 0000000000..90b5923aa7 --- /dev/null +++ "b/impls/tests/step0_repl - \345\211\257\346\234\254.mal" @@ -0,0 +1,66 @@ +;; Testing basic string +abcABC123 +;=>abcABC123 + +;; Testing string containing spaces +hello mal world +;=>hello mal world + +;; Testing string containing symbols +[]{}"'* ;:() +;=>[]{}"'* ;:() + + +;; Test long string +hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*) +;=>hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*) + +;; Non alphanumeric characters +! +;=>! +& +;=>& ++ +;=>+ +, +;=>, +- +;=>- +/ +;=>/ +< +;=>< += +;=>= +> +;=>> +? +;=>? +@ +;=>@ +;;; Behaviour of backslash is not specified enough to test anything in step0. +^ +;=>^ +_ +;=>_ +` +;=>` +~ +;=>~ + +;>>> soft=True +;>>> optional=True +;; ------- Optional Functionality -------------- +;; ------- (Not needed for self-hosting) ------- + +;; Non alphanumeric characters +# +;=># +$ +;=>$ +% +;=>% +. +;=>. +| +;=>| diff --git a/impls/tests/step0_repl.mal b/impls/tests/step0_repl.mal index 4706a1ae1f..90b5923aa7 100644 --- a/impls/tests/step0_repl.mal +++ b/impls/tests/step0_repl.mal @@ -1,66 +1,66 @@ -;; Testing basic string -abcABC123 -;=>abcABC123 - -;; Testing string containing spaces -hello mal world -;=>hello mal world - -;; Testing string containing symbols -[]{}"'* ;:() -;=>[]{}"'* ;:() - - -;; Test long string -hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*) -;=>hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*) - -;; Non alphanumeric characters -! -;=>! -& -;=>& -+ -;=>+ -, -;=>, -- -;=>- -/ -;=>/ -< -;=>< -= -;=>= -> -;=>> -? -;=>? -@ -;=>@ -;;; Behaviour of backslash is not specified enough to test anything in step0. -^ -;=>^ -_ -;=>_ -` -;=>` -~ -;=>~ - -;>>> soft=True -;>>> optional=True -;; ------- Optional Functionality -------------- -;; ------- (Not needed for self-hosting) ------- - -;; Non alphanumeric characters -# -;=># -$ -;=>$ -% -;=>% -. -;=>. -| -;=>| +;; Testing basic string +abcABC123 +;=>abcABC123 + +;; Testing string containing spaces +hello mal world +;=>hello mal world + +;; Testing string containing symbols +[]{}"'* ;:() +;=>[]{}"'* ;:() + + +;; Test long string +hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*) +;=>hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*) + +;; Non alphanumeric characters +! +;=>! +& +;=>& ++ +;=>+ +, +;=>, +- +;=>- +/ +;=>/ +< +;=>< += +;=>= +> +;=>> +? +;=>? +@ +;=>@ +;;; Behaviour of backslash is not specified enough to test anything in step0. +^ +;=>^ +_ +;=>_ +` +;=>` +~ +;=>~ + +;>>> soft=True +;>>> optional=True +;; ------- Optional Functionality -------------- +;; ------- (Not needed for self-hosting) ------- + +;; Non alphanumeric characters +# +;=># +$ +;=>$ +% +;=>% +. +;=>. +| +;=>| diff --git a/impls/tests/step1_read_print.mal b/impls/tests/step1_read_print.mal index 403af6b49f..3a004f96fb 100644 --- a/impls/tests/step1_read_print.mal +++ b/impls/tests/step1_read_print.mal @@ -1,286 +1,286 @@ -;; Testing read of numbers -1 -;=>1 -7 -;=>7 - 7 -;=>7 --123 -;=>-123 - - -;; Testing read of symbols -+ -;=>+ -abc -;=>abc - abc -;=>abc -abc5 -;=>abc5 -abc-def -;=>abc-def - -;; Testing non-numbers starting with a dash. -- -;=>- --abc -;=>-abc -->> -;=>->> - -;; Testing read of lists -(+ 1 2) -;=>(+ 1 2) -() -;=>() -( ) -;=>() -(nil) -;=>(nil) -((3 4)) -;=>((3 4)) -(+ 1 (+ 2 3)) -;=>(+ 1 (+ 2 3)) - ( + 1 (+ 2 3 ) ) -;=>(+ 1 (+ 2 3)) -(* 1 2) -;=>(* 1 2) -(** 1 2) -;=>(** 1 2) -(* -3 6) -;=>(* -3 6) -(()()) -;=>(() ()) - -;; Test commas as whitespace -(1 2, 3,,,,),, -;=>(1 2 3) - - -;>>> deferrable=True - -;; -;; -------- Deferrable Functionality -------- - -;; Testing read of nil/true/false -nil -;=>nil -true -;=>true -false -;=>false - -;; Testing read of strings -"abc" -;=>"abc" - "abc" -;=>"abc" -"abc (with parens)" -;=>"abc (with parens)" -"abc\"def" -;=>"abc\"def" -"" -;=>"" -"\\" -;=>"\\" -"\\\\\\\\\\\\\\\\\\" -;=>"\\\\\\\\\\\\\\\\\\" -"&" -;=>"&" -"'" -;=>"'" -"(" -;=>"(" -")" -;=>")" -"*" -;=>"*" -"+" -;=>"+" -"," -;=>"," -"-" -;=>"-" -"/" -;=>"/" -":" -;=>":" -";" -;=>";" -"<" -;=>"<" -"=" -;=>"=" -">" -;=>">" -"?" -;=>"?" -"@" -;=>"@" -"[" -;=>"[" -"]" -;=>"]" -"^" -;=>"^" -"_" -;=>"_" -"`" -;=>"`" -"{" -;=>"{" -"}" -;=>"}" -"~" -;=>"~" -"!" -;=>"!" - -;; Testing reader errors -(1 2 -;/.*(EOF|end of input|unbalanced).* -[1 2 -;/.*(EOF|end of input|unbalanced).* - -;;; These should throw some error with no return value -"abc -;/.*(EOF|end of input|unbalanced).* -" -;/.*(EOF|end of input|unbalanced).* -"\" -;/.*(EOF|end of input|unbalanced).* -"\\\\\\\\\\\\\\\\\\\" -;/.*(EOF|end of input|unbalanced).* -(1 "abc -;/.*(EOF|end of input|unbalanced).* -(1 "abc" -;/.*(EOF|end of input|unbalanced).* - -;; Testing read of quoting -'1 -;=>(quote 1) -'(1 2 3) -;=>(quote (1 2 3)) -`1 -;=>(quasiquote 1) -`(1 2 3) -;=>(quasiquote (1 2 3)) -~1 -;=>(unquote 1) -~(1 2 3) -;=>(unquote (1 2 3)) -`(1 ~a 3) -;=>(quasiquote (1 (unquote a) 3)) -~@(1 2 3) -;=>(splice-unquote (1 2 3)) - - -;; Testing keywords -:kw -;=>:kw -(:kw1 :kw2 :kw3) -;=>(:kw1 :kw2 :kw3) - -;; Testing read of vectors -[+ 1 2] -;=>[+ 1 2] -[] -;=>[] -[ ] -;=>[] -[[3 4]] -;=>[[3 4]] -[+ 1 [+ 2 3]] -;=>[+ 1 [+ 2 3]] - [ + 1 [+ 2 3 ] ] -;=>[+ 1 [+ 2 3]] -([]) -;=>([]) - -;; Testing read of hash maps -{} -;=>{} -{ } -;=>{} -{"abc" 1} -;=>{"abc" 1} -{"a" {"b" 2}} -;=>{"a" {"b" 2}} -{"a" {"b" {"c" 3}}} -;=>{"a" {"b" {"c" 3}}} -{ "a" {"b" { "cde" 3 } }} -;=>{"a" {"b" {"cde" 3}}} -;;; The regexp sorcery here ensures that each key goes with the correct -;;; value and that each key appears only once. -{"a1" 1 "a2" 2 "a3" 3} -;/{"a([1-3])" \1 "a(?!\1)([1-3])" \2 "a(?!\1)(?!\2)([1-3])" \3} -{ :a {:b { :cde 3 } }} -;=>{:a {:b {:cde 3}}} -{"1" 1} -;=>{"1" 1} -({}) -;=>({}) - -;; Testing read of comments - ;; whole line comment (not an exception) -1 ; comment after expression -;=>1 -1; comment after expression -;=>1 - -;; Testing read of @/deref -@a -;=>(deref a) - -;>>> soft=True -;>>> optional=True -;; -;; -------- Optional Functionality -------- - -;; Testing read of ^/metadata -^{"a" 1} [1 2 3] -;=>(with-meta [1 2 3] {"a" 1}) - - -;; Non alphanumerice characters in strings -;;; \t is not specified enough to be tested -"\n" -;=>"\n" -"#" -;=>"#" -"$" -;=>"$" -"%" -;=>"%" -"." -;=>"." -"\\" -;=>"\\" -"|" -;=>"|" - -;; Non alphanumeric characters in comments -1;! -;=>1 -1;" -;=>1 -1;# -;=>1 -1;$ -;=>1 -1;% -;=>1 -1;' -;=>1 -1;\ -;=>1 -1;\\ -;=>1 -1;\\\ -;=>1 -1;` -;=>1 -;;; Hopefully less problematic characters -1; &()*+,-./:;<=>?@[]^_{|}~ -;=>1 +;; Testing read of numbers +1 +;=>1 +7 +;=>7 + 7 +;=>7 +-123 +;=>-123 + + +;; Testing read of symbols ++ +;=>+ +abc +;=>abc + abc +;=>abc +abc5 +;=>abc5 +abc-def +;=>abc-def + +;; Testing non-numbers starting with a dash. +- +;=>- +-abc +;=>-abc +->> +;=>->> + +;; Testing read of lists +(+ 1 2) +;=>(+ 1 2) +() +;=>() +( ) +;=>() +(nil) +;=>(nil) +((3 4)) +;=>((3 4)) +(+ 1 (+ 2 3)) +;=>(+ 1 (+ 2 3)) + ( + 1 (+ 2 3 ) ) +;=>(+ 1 (+ 2 3)) +(* 1 2) +;=>(* 1 2) +(** 1 2) +;=>(** 1 2) +(* -3 6) +;=>(* -3 6) +(()()) +;=>(() ()) + +;; Test commas as whitespace +(1 2, 3,,,,),, +;=>(1 2 3) + + +;>>> deferrable=True + +;; +;; -------- Deferrable Functionality -------- + +;; Testing read of nil/true/false +nil +;=>nil +true +;=>true +false +;=>false + +;; Testing read of strings +"abc" +;=>"abc" + "abc" +;=>"abc" +"abc (with parens)" +;=>"abc (with parens)" +"abc\"def" +;=>"abc\"def" +"" +;=>"" +"\\" +;=>"\\" +"\\\\\\\\\\\\\\\\\\" +;=>"\\\\\\\\\\\\\\\\\\" +"&" +;=>"&" +"'" +;=>"'" +"(" +;=>"(" +")" +;=>")" +"*" +;=>"*" +"+" +;=>"+" +"," +;=>"," +"-" +;=>"-" +"/" +;=>"/" +":" +;=>":" +";" +;=>";" +"<" +;=>"<" +"=" +;=>"=" +">" +;=>">" +"?" +;=>"?" +"@" +;=>"@" +"[" +;=>"[" +"]" +;=>"]" +"^" +;=>"^" +"_" +;=>"_" +"`" +;=>"`" +"{" +;=>"{" +"}" +;=>"}" +"~" +;=>"~" +"!" +;=>"!" + +;; Testing reader errors +(1 2 +;/.*(EOF|end of input|unbalanced).* +[1 2 +;/.*(EOF|end of input|unbalanced).* + +;;; These should throw some error with no return value +"abc +;/.*(EOF|end of input|unbalanced).* +" +;/.*(EOF|end of input|unbalanced).* +"\" +;/.*(EOF|end of input|unbalanced).* +"\\\\\\\\\\\\\\\\\\\" +;/.*(EOF|end of input|unbalanced).* +(1 "abc +;/.*(EOF|end of input|unbalanced).* +(1 "abc" +;/.*(EOF|end of input|unbalanced).* + +;; Testing read of quoting +'1 +;=>(quote 1) +'(1 2 3) +;=>(quote (1 2 3)) +`1 +;=>(quasiquote 1) +`(1 2 3) +;=>(quasiquote (1 2 3)) +~1 +;=>(unquote 1) +~(1 2 3) +;=>(unquote (1 2 3)) +`(1 ~a 3) +;=>(quasiquote (1 (unquote a) 3)) +~@(1 2 3) +;=>(splice-unquote (1 2 3)) + + +;; Testing keywords +:kw +;=>:kw +(:kw1 :kw2 :kw3) +;=>(:kw1 :kw2 :kw3) + +;; Testing read of vectors +[+ 1 2] +;=>[+ 1 2] +[] +;=>[] +[ ] +;=>[] +[[3 4]] +;=>[[3 4]] +[+ 1 [+ 2 3]] +;=>[+ 1 [+ 2 3]] + [ + 1 [+ 2 3 ] ] +;=>[+ 1 [+ 2 3]] +([]) +;=>([]) + +;; Testing read of hash maps +{} +;=>{} +{ } +;=>{} +{"abc" 1} +;=>{"abc" 1} +{"a" {"b" 2}} +;=>{"a" {"b" 2}} +{"a" {"b" {"c" 3}}} +;=>{"a" {"b" {"c" 3}}} +{ "a" {"b" { "cde" 3 } }} +;=>{"a" {"b" {"cde" 3}}} +;;; The regexp sorcery here ensures that each key goes with the correct +;;; value and that each key appears only once. +{"a1" 1 "a2" 2 "a3" 3} +;/{"a([1-3])" \1 "a(?!\1)([1-3])" \2 "a(?!\1)(?!\2)([1-3])" \3} +{ :a {:b { :cde 3 } }} +;=>{:a {:b {:cde 3}}} +{"1" 1} +;=>{"1" 1} +({}) +;=>({}) + +;; Testing read of comments + ;; whole line comment (not an exception) +1 ; comment after expression +;=>1 +1; comment after expression +;=>1 + +;; Testing read of @/deref +@a +;=>(deref a) + +;>>> soft=True +;>>> optional=True +;; +;; -------- Optional Functionality -------- + +;; Testing read of ^/metadata +^{"a" 1} [1 2 3] +;=>(with-meta [1 2 3] {"a" 1}) + + +;; Non alphanumerice characters in strings +;;; \t is not specified enough to be tested +"\n" +;=>"\n" +"#" +;=>"#" +"$" +;=>"$" +"%" +;=>"%" +"." +;=>"." +"\\" +;=>"\\" +"|" +;=>"|" + +;; Non alphanumeric characters in comments +1;! +;=>1 +1;" +;=>1 +1;# +;=>1 +1;$ +;=>1 +1;% +;=>1 +1;' +;=>1 +1;\ +;=>1 +1;\\ +;=>1 +1;\\\ +;=>1 +1;` +;=>1 +;;; Hopefully less problematic characters +1; &()*+,-./:;<=>?@[]^_{|}~ +;=>1 diff --git "a/impls/tests/step2_eval - \345\211\257\346\234\254.mal" "b/impls/tests/step2_eval - \345\211\257\346\234\254.mal" new file mode 100644 index 0000000000..0741c2ef75 --- /dev/null +++ "b/impls/tests/step2_eval - \345\211\257\346\234\254.mal" @@ -0,0 +1,49 @@ +;; Testing evaluation of arithmetic operations +(+ 1 2) +;=>3 + +(+ 5 (* 2 3)) +;=>11 + +(- (+ 5 (* 2 3)) 3) +;=>8 + +(/ (- (+ 5 (* 2 3)) 3) 4) +;=>2 + +(/ (- (+ 515 (* 87 311)) 302) 27) +;=>1010 + +(* -3 6) +;=>-18 + +(/ (- (+ 515 (* -87 311)) 296) 27) +;=>-994 + +;;; This should throw an error with no return value +(abc 1 2 3) +;/.+ + +;; Testing empty list +() +;=>() + +;>>> deferrable=True +;; +;; -------- Deferrable Functionality -------- + +;; Testing evaluation within collection literals +[1 2 (+ 1 2)] +;=>[1 2 3] + +{"a" (+ 7 8)} +;=>{"a" 15} + +{:a (+ 7 8)} +;=>{:a 15} + +;; Check that evaluation hasn't broken empty collections +[] +;=>[] +{} +;=>{} diff --git a/impls/tests/step2_eval.mal b/impls/tests/step2_eval.mal index 1116502025..0741c2ef75 100644 --- a/impls/tests/step2_eval.mal +++ b/impls/tests/step2_eval.mal @@ -1,49 +1,49 @@ -;; Testing evaluation of arithmetic operations -(+ 1 2) -;=>3 - -(+ 5 (* 2 3)) -;=>11 - -(- (+ 5 (* 2 3)) 3) -;=>8 - -(/ (- (+ 5 (* 2 3)) 3) 4) -;=>2 - -(/ (- (+ 515 (* 87 311)) 302) 27) -;=>1010 - -(* -3 6) -;=>-18 - -(/ (- (+ 515 (* -87 311)) 296) 27) -;=>-994 - -;;; This should throw an error with no return value -(abc 1 2 3) -;/.+ - -;; Testing empty list -() -;=>() - -;>>> deferrable=True -;; -;; -------- Deferrable Functionality -------- - -;; Testing evaluation within collection literals -[1 2 (+ 1 2)] -;=>[1 2 3] - -{"a" (+ 7 8)} -;=>{"a" 15} - -{:a (+ 7 8)} -;=>{:a 15} - -;; Check that evaluation hasn't broken empty collections -[] -;=>[] -{} -;=>{} +;; Testing evaluation of arithmetic operations +(+ 1 2) +;=>3 + +(+ 5 (* 2 3)) +;=>11 + +(- (+ 5 (* 2 3)) 3) +;=>8 + +(/ (- (+ 5 (* 2 3)) 3) 4) +;=>2 + +(/ (- (+ 515 (* 87 311)) 302) 27) +;=>1010 + +(* -3 6) +;=>-18 + +(/ (- (+ 515 (* -87 311)) 296) 27) +;=>-994 + +;;; This should throw an error with no return value +(abc 1 2 3) +;/.+ + +;; Testing empty list +() +;=>() + +;>>> deferrable=True +;; +;; -------- Deferrable Functionality -------- + +;; Testing evaluation within collection literals +[1 2 (+ 1 2)] +;=>[1 2 3] + +{"a" (+ 7 8)} +;=>{"a" 15} + +{:a (+ 7 8)} +;=>{:a 15} + +;; Check that evaluation hasn't broken empty collections +[] +;=>[] +{} +;=>{} diff --git a/impls/tests/step3_env.mal b/impls/tests/step3_env.mal index a3554544cb..2e4d4d6ca0 100644 --- a/impls/tests/step3_env.mal +++ b/impls/tests/step3_env.mal @@ -1,87 +1,87 @@ -;; Testing REPL_ENV -(+ 1 2) -;=>3 -(/ (- (+ 5 (* 2 3)) 3) 4) -;=>2 - - -;; Testing def! -(def! x 3) -;=>3 -x -;=>3 -(def! x 4) -;=>4 -x -;=>4 -(def! y (+ 1 7)) -;=>8 -y -;=>8 - -;; Verifying symbols are case-sensitive -(def! mynum 111) -;=>111 -(def! MYNUM 222) -;=>222 -mynum -;=>111 -MYNUM -;=>222 - -;; Check env lookup non-fatal error -(abc 1 2 3) -;/.*\'?abc\'? not found.* -;; Check that error aborts def! -(def! w 123) -(def! w (abc)) -w -;=>123 - -;; Testing let* -(let* (z 9) z) -;=>9 -(let* (x 9) x) -;=>9 -x -;=>4 -(let* (z (+ 2 3)) (+ 1 z)) -;=>6 -(let* (p (+ 2 3) q (+ 2 p)) (+ p q)) -;=>12 -(def! y (let* (z 7) z)) -y -;=>7 - -;; Testing outer environment -(def! a 4) -;=>4 -(let* (q 9) q) -;=>9 -(let* (q 9) a) -;=>4 -(let* (z 2) (let* (q 9) a)) -;=>4 - -;>>> deferrable=True -;; -;; -------- Deferrable Functionality -------- - -;; Testing let* with vector bindings -(let* [z 9] z) -;=>9 -(let* [p (+ 2 3) q (+ 2 p)] (+ p q)) -;=>12 - -;; Testing vector evaluation -(let* (a 5 b 6) [3 4 a [b 7] 8]) -;=>[3 4 5 [6 7] 8] - -;>>> soft=True -;>>> optional=True -;; -;; -------- Optional Functionality -------- - -;; Check that last assignment takes priority -(let* (x 2 x 3) x) -;=>3 +;; Testing REPL_ENV +(+ 1 2) +;=>3 +(/ (- (+ 5 (* 2 3)) 3) 4) +;=>2 + + +;; Testing def! +(def! x 3) +;=>3 +x +;=>3 +(def! x 4) +;=>4 +x +;=>4 +(def! y (+ 1 7)) +;=>8 +y +;=>8 + +;; Verifying symbols are case-sensitive +(def! mynum 111) +;=>111 +(def! MYNUM 222) +;=>222 +mynum +;=>111 +MYNUM +;=>222 + +;; Check env lookup non-fatal error +(abc 1 2 3) +;/.*\'?abc\'? not found.* +;; Check that error aborts def! +(def! w 123) +(def! w (abc)) +w +;=>123 + +;; Testing let* +(let* (z 9) z) +;=>9 +(let* (x 9) x) +;=>9 +x +;=>4 +(let* (z (+ 2 3)) (+ 1 z)) +;=>6 +(let* (p (+ 2 3) q (+ 2 p)) (+ p q)) +;=>12 +(def! y (let* (z 7) z)) +y +;=>7 + +;; Testing outer environment +(def! a 4) +;=>4 +(let* (q 9) q) +;=>9 +(let* (q 9) a) +;=>4 +(let* (z 2) (let* (q 9) a)) +;=>4 + +;>>> deferrable=True +;; +;; -------- Deferrable Functionality -------- + +;; Testing let* with vector bindings +(let* [z 9] z) +;=>9 +(let* [p (+ 2 3) q (+ 2 p)] (+ p q)) +;=>12 + +;; Testing vector evaluation +(let* (a 5 b 6) [3 4 a [b 7] 8]) +;=>[3 4 5 [6 7] 8] + +;>>> soft=True +;>>> optional=True +;; +;; -------- Optional Functionality -------- + +;; Check that last assignment takes priority +(let* (x 2 x 3) x) +;=>3 diff --git a/impls/tests/step4_if_fn_do.mal b/impls/tests/step4_if_fn_do.mal index 46c1bb9247..edd2a66975 100644 --- a/impls/tests/step4_if_fn_do.mal +++ b/impls/tests/step4_if_fn_do.mal @@ -1,500 +1,500 @@ -;; ----------------------------------------------------- - - -;; Testing list functions -(list) -;=>() -(list? (list)) -;=>true -(empty? (list)) -;=>true -(empty? (list 1)) -;=>false -(list 1 2 3) -;=>(1 2 3) -(count (list 1 2 3)) -;=>3 -(count (list)) -;=>0 -(count nil) -;=>0 -(if (> (count (list 1 2 3)) 3) 89 78) -;=>78 -(if (>= (count (list 1 2 3)) 3) 89 78) -;=>89 - - -;; Testing if form -(if true 7 8) -;=>7 -(if false 7 8) -;=>8 -(if false 7 false) -;=>false -(if true (+ 1 7) (+ 1 8)) -;=>8 -(if false (+ 1 7) (+ 1 8)) -;=>9 -(if nil 7 8) -;=>8 -(if 0 7 8) -;=>7 -(if (list) 7 8) -;=>7 -(if (list 1 2 3) 7 8) -;=>7 -(= (list) nil) -;=>false - - -;; Testing 1-way if form -(if false (+ 1 7)) -;=>nil -(if nil 8) -;=>nil -(if nil 8 7) -;=>7 -(if true (+ 1 7)) -;=>8 - - -;; Testing basic conditionals -(= 2 1) -;=>false -(= 1 1) -;=>true -(= 1 2) -;=>false -(= 1 (+ 1 1)) -;=>false -(= 2 (+ 1 1)) -;=>true -(= nil 1) -;=>false -(= nil nil) -;=>true - -(> 2 1) -;=>true -(> 1 1) -;=>false -(> 1 2) -;=>false - -(>= 2 1) -;=>true -(>= 1 1) -;=>true -(>= 1 2) -;=>false - -(< 2 1) -;=>false -(< 1 1) -;=>false -(< 1 2) -;=>true - -(<= 2 1) -;=>false -(<= 1 1) -;=>true -(<= 1 2) -;=>true - - -;; Testing equality -(= 1 1) -;=>true -(= 0 0) -;=>true -(= 1 0) -;=>false -(= true true) -;=>true -(= false false) -;=>true -(= nil nil) -;=>true - -(= (list) (list)) -;=>true -(= (list) ()) -;=>true -(= (list 1 2) (list 1 2)) -;=>true -(= (list 1) (list)) -;=>false -(= (list) (list 1)) -;=>false -(= 0 (list)) -;=>false -(= (list) 0) -;=>false -(= (list nil) (list)) -;=>false - - -;; Testing builtin and user defined functions -(+ 1 2) -;=>3 -( (fn* (a b) (+ b a)) 3 4) -;=>7 -( (fn* () 4) ) -;=>4 - -( (fn* (f x) (f x)) (fn* (a) (+ 1 a)) 7) -;=>8 - - -;; Testing closures -( ( (fn* (a) (fn* (b) (+ a b))) 5) 7) -;=>12 - -(def! gen-plus5 (fn* () (fn* (b) (+ 5 b)))) -(def! plus5 (gen-plus5)) -(plus5 7) -;=>12 - -(def! gen-plusX (fn* (x) (fn* (b) (+ x b)))) -(def! plus7 (gen-plusX 7)) -(plus7 8) -;=>15 - -;; Testing do form -(do (prn 101)) -;/101 -;=>nil -(do (prn 102) 7) -;/102 -;=>7 -(do (prn 101) (prn 102) (+ 1 2)) -;/101 -;/102 -;=>3 - -(do (def! a 6) 7 (+ a 8)) -;=>14 -a -;=>6 - -;; Testing special form case-sensitivity -(def! DO (fn* (a) 7)) -(DO 3) -;=>7 - -;; Testing recursive sumdown function -(def! sumdown (fn* (N) (if (> N 0) (+ N (sumdown (- N 1))) 0))) -(sumdown 1) -;=>1 -(sumdown 2) -;=>3 -(sumdown 6) -;=>21 - - -;; Testing recursive fibonacci function -(def! fib (fn* (N) (if (= N 0) 1 (if (= N 1) 1 (+ (fib (- N 1)) (fib (- N 2))))))) -(fib 1) -;=>1 -(fib 2) -;=>2 -(fib 4) -;=>5 - - -;; Testing recursive function in environment. -(let* (f (fn* () x) x 3) (f)) -;=>3 -(let* (cst (fn* (n) (if (= n 0) nil (cst (- n 1))))) (cst 1)) -;=>nil -(let* (f (fn* (n) (if (= n 0) 0 (g (- n 1)))) g (fn* (n) (f n))) (f 2)) -;=>0 - - -;>>> deferrable=True -;; -;; -------- Deferrable Functionality -------- - -;; Testing if on strings - -(if "" 7 8) -;=>7 - -;; Testing string equality - -(= "" "") -;=>true -(= "abc" "abc") -;=>true -(= "abc" "") -;=>false -(= "" "abc") -;=>false -(= "abc" "def") -;=>false -(= "abc" "ABC") -;=>false -(= (list) "") -;=>false -(= "" (list)) -;=>false - -;; Testing variable length arguments - -( (fn* (& more) (count more)) 1 2 3) -;=>3 -( (fn* (& more) (list? more)) 1 2 3) -;=>true -( (fn* (& more) (count more)) 1) -;=>1 -( (fn* (& more) (count more)) ) -;=>0 -( (fn* (& more) (list? more)) ) -;=>true -( (fn* (a & more) (count more)) 1 2 3) -;=>2 -( (fn* (a & more) (count more)) 1) -;=>0 -( (fn* (a & more) (list? more)) 1) -;=>true - - -;; Testing language defined not function -(not false) -;=>true -(not nil) -;=>true -(not true) -;=>false -(not "a") -;=>false -(not 0) -;=>false - - -;; ----------------------------------------------------- - -;; Testing string quoting - -"" -;=>"" - -"abc" -;=>"abc" - -"abc def" -;=>"abc def" - -"\"" -;=>"\"" - -"abc\ndef\nghi" -;=>"abc\ndef\nghi" - -"abc\\def\\ghi" -;=>"abc\\def\\ghi" - -"\\n" -;=>"\\n" - -;; Testing pr-str - -(pr-str) -;=>"" - -(pr-str "") -;=>"\"\"" - -(pr-str "abc") -;=>"\"abc\"" - -(pr-str "abc def" "ghi jkl") -;=>"\"abc def\" \"ghi jkl\"" - -(pr-str "\"") -;=>"\"\\\"\"" - -(pr-str (list 1 2 "abc" "\"") "def") -;=>"(1 2 \"abc\" \"\\\"\") \"def\"" - -(pr-str "abc\ndef\nghi") -;=>"\"abc\\ndef\\nghi\"" - -(pr-str "abc\\def\\ghi") -;=>"\"abc\\\\def\\\\ghi\"" - -(pr-str (list)) -;=>"()" - -;; Testing str - -(str) -;=>"" - -(str "") -;=>"" - -(str "abc") -;=>"abc" - -(str "\"") -;=>"\"" - -(str 1 "abc" 3) -;=>"1abc3" - -(str "abc def" "ghi jkl") -;=>"abc defghi jkl" - -(str "abc\ndef\nghi") -;=>"abc\ndef\nghi" - -(str "abc\\def\\ghi") -;=>"abc\\def\\ghi" - -(str (list 1 2 "abc" "\"") "def") -;=>"(1 2 abc \")def" - -(str (list)) -;=>"()" - -;; Testing prn -(prn) -;/ -;=>nil - -(prn "") -;/"" -;=>nil - -(prn "abc") -;/"abc" -;=>nil - -(prn "abc def" "ghi jkl") -;/"abc def" "ghi jkl" - -(prn "\"") -;/"\\"" -;=>nil - -(prn "abc\ndef\nghi") -;/"abc\\ndef\\nghi" -;=>nil - -(prn "abc\\def\\ghi") -;/"abc\\\\def\\\\ghi" -nil - -(prn (list 1 2 "abc" "\"") "def") -;/\(1 2 "abc" "\\""\) "def" -;=>nil - - -;; Testing println -(println) -;/ -;=>nil - -(println "") -;/ -;=>nil - -(println "abc") -;/abc -;=>nil - -(println "abc def" "ghi jkl") -;/abc def ghi jkl - -(println "\"") -;/" -;=>nil - -(println "abc\ndef\nghi") -;/abc -;/def -;/ghi -;=>nil - -(println "abc\\def\\ghi") -;/abc\\def\\ghi -;=>nil - -(println (list 1 2 "abc" "\"") "def") -;/\(1 2 abc "\) def -;=>nil - - -;; Testing keywords -(= :abc :abc) -;=>true -(= :abc :def) -;=>false -(= :abc ":abc") -;=>false -(= (list :abc) (list :abc)) -;=>true - -;; Testing vector truthiness -(if [] 7 8) -;=>7 - -;; Testing vector printing -(pr-str [1 2 "abc" "\""] "def") -;=>"[1 2 \"abc\" \"\\\"\"] \"def\"" - -(pr-str []) -;=>"[]" - -(str [1 2 "abc" "\""] "def") -;=>"[1 2 abc \"]def" - -(str []) -;=>"[]" - - -;; Testing vector functions -(count [1 2 3]) -;=>3 -(empty? [1 2 3]) -;=>false -(empty? []) -;=>true -(list? [4 5 6]) -;=>false - -;; Testing vector equality -(= [] (list)) -;=>true -(= [7 8] [7 8]) -;=>true -(= [:abc] [:abc]) -;=>true -(= (list 1 2) [1 2]) -;=>true -(= (list 1) []) -;=>false -(= [] [1]) -;=>false -(= 0 []) -;=>false -(= [] 0) -;=>false -(= [] "") -;=>false -(= "" []) -;=>false - -;; Testing vector parameter lists -( (fn* [] 4) ) -;=>4 -( (fn* [f x] (f x)) (fn* [a] (+ 1 a)) 7) -;=>8 - -;; Nested vector/list equality -(= [(list)] (list [])) -;=>true -(= [1 2 (list 3 4 [5 6])] (list 1 2 [3 4 (list 5 6)])) -;=>true +;; ----------------------------------------------------- + + +;; Testing list functions +(list) +;=>() +(list? (list)) +;=>true +(empty? (list)) +;=>true +(empty? (list 1)) +;=>false +(list 1 2 3) +;=>(1 2 3) +(count (list 1 2 3)) +;=>3 +(count (list)) +;=>0 +(count nil) +;=>0 +(if (> (count (list 1 2 3)) 3) 89 78) +;=>78 +(if (>= (count (list 1 2 3)) 3) 89 78) +;=>89 + + +;; Testing if form +(if true 7 8) +;=>7 +(if false 7 8) +;=>8 +(if false 7 false) +;=>false +(if true (+ 1 7) (+ 1 8)) +;=>8 +(if false (+ 1 7) (+ 1 8)) +;=>9 +(if nil 7 8) +;=>8 +(if 0 7 8) +;=>7 +(if (list) 7 8) +;=>7 +(if (list 1 2 3) 7 8) +;=>7 +(= (list) nil) +;=>false + + +;; Testing 1-way if form +(if false (+ 1 7)) +;=>nil +(if nil 8) +;=>nil +(if nil 8 7) +;=>7 +(if true (+ 1 7)) +;=>8 + + +;; Testing basic conditionals +(= 2 1) +;=>false +(= 1 1) +;=>true +(= 1 2) +;=>false +(= 1 (+ 1 1)) +;=>false +(= 2 (+ 1 1)) +;=>true +(= nil 1) +;=>false +(= nil nil) +;=>true + +(> 2 1) +;=>true +(> 1 1) +;=>false +(> 1 2) +;=>false + +(>= 2 1) +;=>true +(>= 1 1) +;=>true +(>= 1 2) +;=>false + +(< 2 1) +;=>false +(< 1 1) +;=>false +(< 1 2) +;=>true + +(<= 2 1) +;=>false +(<= 1 1) +;=>true +(<= 1 2) +;=>true + + +;; Testing equality +(= 1 1) +;=>true +(= 0 0) +;=>true +(= 1 0) +;=>false +(= true true) +;=>true +(= false false) +;=>true +(= nil nil) +;=>true + +(= (list) (list)) +;=>true +(= (list) ()) +;=>true +(= (list 1 2) (list 1 2)) +;=>true +(= (list 1) (list)) +;=>false +(= (list) (list 1)) +;=>false +(= 0 (list)) +;=>false +(= (list) 0) +;=>false +(= (list nil) (list)) +;=>false + + +;; Testing builtin and user defined functions +(+ 1 2) +;=>3 +( (fn* (a b) (+ b a)) 3 4) +;=>7 +( (fn* () 4) ) +;=>4 + +( (fn* (f x) (f x)) (fn* (a) (+ 1 a)) 7) +;=>8 + + +;; Testing closures +( ( (fn* (a) (fn* (b) (+ a b))) 5) 7) +;=>12 + +(def! gen-plus5 (fn* () (fn* (b) (+ 5 b)))) +(def! plus5 (gen-plus5)) +(plus5 7) +;=>12 + +(def! gen-plusX (fn* (x) (fn* (b) (+ x b)))) +(def! plus7 (gen-plusX 7)) +(plus7 8) +;=>15 + +;; Testing do form +(do (prn 101)) +;/101 +;=>nil +(do (prn 102) 7) +;/102 +;=>7 +(do (prn 101) (prn 102) (+ 1 2)) +;/101 +;/102 +;=>3 + +(do (def! a 6) 7 (+ a 8)) +;=>14 +a +;=>6 + +;; Testing special form case-sensitivity +(def! DO (fn* (a) 7)) +(DO 3) +;=>7 + +;; Testing recursive sumdown function +(def! sumdown (fn* (N) (if (> N 0) (+ N (sumdown (- N 1))) 0))) +(sumdown 1) +;=>1 +(sumdown 2) +;=>3 +(sumdown 6) +;=>21 + + +;; Testing recursive fibonacci function +(def! fib (fn* (N) (if (= N 0) 1 (if (= N 1) 1 (+ (fib (- N 1)) (fib (- N 2))))))) +(fib 1) +;=>1 +(fib 2) +;=>2 +(fib 4) +;=>5 + + +;; Testing recursive function in environment. +(let* (f (fn* () x) x 3) (f)) +;=>3 +(let* (cst (fn* (n) (if (= n 0) nil (cst (- n 1))))) (cst 1)) +;=>nil +(let* (f (fn* (n) (if (= n 0) 0 (g (- n 1)))) g (fn* (n) (f n))) (f 2)) +;=>0 + + +;>>> deferrable=True +;; +;; -------- Deferrable Functionality -------- + +;; Testing if on strings + +(if "" 7 8) +;=>7 + +;; Testing string equality + +(= "" "") +;=>true +(= "abc" "abc") +;=>true +(= "abc" "") +;=>false +(= "" "abc") +;=>false +(= "abc" "def") +;=>false +(= "abc" "ABC") +;=>false +(= (list) "") +;=>false +(= "" (list)) +;=>false + +;; Testing variable length arguments + +( (fn* (& more) (count more)) 1 2 3) +;=>3 +( (fn* (& more) (list? more)) 1 2 3) +;=>true +( (fn* (& more) (count more)) 1) +;=>1 +( (fn* (& more) (count more)) ) +;=>0 +( (fn* (& more) (list? more)) ) +;=>true +( (fn* (a & more) (count more)) 1 2 3) +;=>2 +( (fn* (a & more) (count more)) 1) +;=>0 +( (fn* (a & more) (list? more)) 1) +;=>true + + +;; Testing language defined not function +(not false) +;=>true +(not nil) +;=>true +(not true) +;=>false +(not "a") +;=>false +(not 0) +;=>false + + +;; ----------------------------------------------------- + +;; Testing string quoting + +"" +;=>"" + +"abc" +;=>"abc" + +"abc def" +;=>"abc def" + +"\"" +;=>"\"" + +"abc\ndef\nghi" +;=>"abc\ndef\nghi" + +"abc\\def\\ghi" +;=>"abc\\def\\ghi" + +"\\n" +;=>"\\n" + +;; Testing pr-str + +(pr-str) +;=>"" + +(pr-str "") +;=>"\"\"" + +(pr-str "abc") +;=>"\"abc\"" + +(pr-str "abc def" "ghi jkl") +;=>"\"abc def\" \"ghi jkl\"" + +(pr-str "\"") +;=>"\"\\\"\"" + +(pr-str (list 1 2 "abc" "\"") "def") +;=>"(1 2 \"abc\" \"\\\"\") \"def\"" + +(pr-str "abc\ndef\nghi") +;=>"\"abc\\ndef\\nghi\"" + +(pr-str "abc\\def\\ghi") +;=>"\"abc\\\\def\\\\ghi\"" + +(pr-str (list)) +;=>"()" + +;; Testing str + +(str) +;=>"" + +(str "") +;=>"" + +(str "abc") +;=>"abc" + +(str "\"") +;=>"\"" + +(str 1 "abc" 3) +;=>"1abc3" + +(str "abc def" "ghi jkl") +;=>"abc defghi jkl" + +(str "abc\ndef\nghi") +;=>"abc\ndef\nghi" + +(str "abc\\def\\ghi") +;=>"abc\\def\\ghi" + +(str (list 1 2 "abc" "\"") "def") +;=>"(1 2 abc \")def" + +(str (list)) +;=>"()" + +;; Testing prn +(prn) +;/ +;=>nil + +(prn "") +;/"" +;=>nil + +(prn "abc") +;/"abc" +;=>nil + +(prn "abc def" "ghi jkl") +;/"abc def" "ghi jkl" + +(prn "\"") +;/"\\"" +;=>nil + +(prn "abc\ndef\nghi") +;/"abc\\ndef\\nghi" +;=>nil + +(prn "abc\\def\\ghi") +;/"abc\\\\def\\\\ghi" +nil + +(prn (list 1 2 "abc" "\"") "def") +;/\(1 2 "abc" "\\""\) "def" +;=>nil + + +;; Testing println +(println) +;/ +;=>nil + +(println "") +;/ +;=>nil + +(println "abc") +;/abc +;=>nil + +(println "abc def" "ghi jkl") +;/abc def ghi jkl + +(println "\"") +;/" +;=>nil + +(println "abc\ndef\nghi") +;/abc +;/def +;/ghi +;=>nil + +(println "abc\\def\\ghi") +;/abc\\def\\ghi +;=>nil + +(println (list 1 2 "abc" "\"") "def") +;/\(1 2 abc "\) def +;=>nil + + +;; Testing keywords +(= :abc :abc) +;=>true +(= :abc :def) +;=>false +(= :abc ":abc") +;=>false +(= (list :abc) (list :abc)) +;=>true + +;; Testing vector truthiness +(if [] 7 8) +;=>7 + +;; Testing vector printing +(pr-str [1 2 "abc" "\""] "def") +;=>"[1 2 \"abc\" \"\\\"\"] \"def\"" + +(pr-str []) +;=>"[]" + +(str [1 2 "abc" "\""] "def") +;=>"[1 2 abc \"]def" + +(str []) +;=>"[]" + + +;; Testing vector functions +(count [1 2 3]) +;=>3 +(empty? [1 2 3]) +;=>false +(empty? []) +;=>true +(list? [4 5 6]) +;=>false + +;; Testing vector equality +(= [] (list)) +;=>true +(= [7 8] [7 8]) +;=>true +(= [:abc] [:abc]) +;=>true +(= (list 1 2) [1 2]) +;=>true +(= (list 1) []) +;=>false +(= [] [1]) +;=>false +(= 0 []) +;=>false +(= [] 0) +;=>false +(= [] "") +;=>false +(= "" []) +;=>false + +;; Testing vector parameter lists +( (fn* [] 4) ) +;=>4 +( (fn* [f x] (f x)) (fn* [a] (+ 1 a)) 7) +;=>8 + +;; Nested vector/list equality +(= [(list)] (list [])) +;=>true +(= [1 2 (list 3 4 [5 6])] (list 1 2 [3 4 (list 5 6)])) +;=>true diff --git a/impls/tests/step5_tco.mal b/impls/tests/step5_tco.mal index 0e87b5babc..b077c89e65 100644 --- a/impls/tests/step5_tco.mal +++ b/impls/tests/step5_tco.mal @@ -1,23 +1,23 @@ -;; Testing recursive tail-call function - -(def! sum2 (fn* (n acc) (if (= n 0) acc (sum2 (- n 1) (+ n acc))))) - -;; TODO: test let*, and do for TCO - -(sum2 10 0) -;=>55 - -(def! res2 nil) -;=>nil -(def! res2 (sum2 10000 0)) -res2 -;=>50005000 - - -;; Test mutually recursive tail-call functions - -(def! foo (fn* (n) (if (= n 0) 0 (bar (- n 1))))) -(def! bar (fn* (n) (if (= n 0) 0 (foo (- n 1))))) - -(foo 10000) -;=>0 +;; Testing recursive tail-call function + +(def! sum2 (fn* (n acc) (if (= n 0) acc (sum2 (- n 1) (+ n acc))))) + +;; TODO: test let*, and do for TCO + +(sum2 10 0) +;=>55 + +(def! res2 nil) +;=>nil +(def! res2 (sum2 10000 0)) +res2 +;=>50005000 + + +;; Test mutually recursive tail-call functions + +(def! foo (fn* (n) (if (= n 0) 0 (bar (- n 1))))) +(def! bar (fn* (n) (if (= n 0) 0 (foo (- n 1))))) + +(foo 10000) +;=>0 diff --git a/impls/tests/step6_file.mal b/impls/tests/step6_file.mal index e8a3ae881f..032b935f35 100644 --- a/impls/tests/step6_file.mal +++ b/impls/tests/step6_file.mal @@ -1,192 +1,192 @@ -;;; TODO: really a step5 test -;; -;; Testing that (do (do)) not broken by TCO -(do (do 1 2)) -;=>2 - -;; -;; Testing read-string, eval and slurp -(read-string "(1 2 (3 4) nil)") -;=>(1 2 (3 4) nil) - -(= nil (read-string "nil")) -;=>true - -(read-string "(+ 2 3)") -;=>(+ 2 3) - -(read-string "\"\n\"") -;=>"\n" - -(read-string "7 ;; comment") -;=>7 - -;;; Differing output, but make sure no fatal error -(read-string ";; comment") - - -(eval (read-string "(+ 2 3)")) -;=>5 - -(slurp "../tests/test.txt") -;=>"A line of text\n" - -;;; Load the same file twice. -(slurp "../tests/test.txt") -;=>"A line of text\n" - -;; Testing load-file - -(load-file "../tests/inc.mal") -;=>nil -(inc1 7) -;=>8 -(inc2 7) -;=>9 -(inc3 9) -;=>12 - -;; -;; Testing atoms - -(def! inc3 (fn* (a) (+ 3 a))) - -(def! a (atom 2)) -;=>(atom 2) - -(atom? a) -;=>true - -(atom? 1) -;=>false - -(deref a) -;=>2 - -(reset! a 3) -;=>3 - -(deref a) -;=>3 - -(swap! a inc3) -;=>6 - -(deref a) -;=>6 - -(swap! a (fn* (a) a)) -;=>6 - -(swap! a (fn* (a) (* 2 a))) -;=>12 - -(swap! a (fn* (a b) (* a b)) 10) -;=>120 - -(swap! a + 3) -;=>123 - -;; Testing swap!/closure interaction -(def! inc-it (fn* (a) (+ 1 a))) -(def! atm (atom 7)) -(def! f (fn* () (swap! atm inc-it))) -(f) -;=>8 -(f) -;=>9 - -;; Testing whether closures can retain atoms -(def! g (let* (atm (atom 0)) (fn* () (deref atm)))) -(def! atm (atom 1)) -(g) -;=>0 - -;>>> deferrable=True -;; -;; -------- Deferrable Functionality -------- - -;; Testing reading of large files -(load-file "../tests/computations.mal") -;=>nil -(sumdown 2) -;=>3 -(fib 2) -;=>1 - -;; Testing `@` reader macro (short for `deref`) -(def! atm (atom 9)) -@atm -;=>9 - -;;; TODO: really a step5 test -;; Testing that vector params not broken by TCO -(def! g (fn* [] 78)) -(g) -;=>78 -(def! g (fn* [a] (+ a 78))) -(g 3) -;=>81 - -;; -;; Testing that *ARGV* exists and is an empty list -(list? *ARGV*) -;=>true -*ARGV* -;=>() - -;; -;; Testing that eval sets aa in root scope, and that it is found in nested scope -(let* (b 12) (do (eval (read-string "(def! aa 7)")) aa )) -;=>7 - -;>>> soft=True -;>>> optional=True -;; -;; -------- Optional Functionality -------- - -;; Testing comments in a file -(load-file "../tests/incB.mal") -;=>nil -(inc4 7) -;=>11 -(inc5 7) -;=>12 - -;; Testing map literal across multiple lines in a file -(load-file "../tests/incC.mal") -;=>nil -mymap -;=>{"a" 1} - -;; Checking that eval does not use local environments. -(def! a 1) -;=>1 -(let* (a 2) (eval (read-string "a"))) -;=>1 - -;; Non alphanumeric characters in comments in read-string -(read-string "1;!") -;=>1 -(read-string "1;\"") -;=>1 -(read-string "1;#") -;=>1 -(read-string "1;$") -;=>1 -(read-string "1;%") -;=>1 -(read-string "1;'") -;=>1 -(read-string "1;\\") -;=>1 -(read-string "1;\\\\") -;=>1 -(read-string "1;\\\\\\") -;=>1 -(read-string "1;`") -;=>1 -;;; Hopefully less problematic characters can be checked together -(read-string "1; &()*+,-./:;<=>?@[]^_{|}~") -;=>1 - +;;; TODO: really a step5 test +;; +;; Testing that (do (do)) not broken by TCO +(do (do 1 2)) +;=>2 + +;; +;; Testing read-string, eval and slurp +(read-string "(1 2 (3 4) nil)") +;=>(1 2 (3 4) nil) + +(= nil (read-string "nil")) +;=>true + +(read-string "(+ 2 3)") +;=>(+ 2 3) + +(read-string "\"\n\"") +;=>"\n" + +(read-string "7 ;; comment") +;=>7 + +;;; Differing output, but make sure no fatal error +(read-string ";; comment") + + +(eval (read-string "(+ 2 3)")) +;=>5 + +(slurp "../tests/test.txt") +;=>"A line of text\n" + +;;; Load the same file twice. +(slurp "../tests/test.txt") +;=>"A line of text\n" + +;; Testing load-file + +(load-file "../tests/inc.mal") +;=>nil +(inc1 7) +;=>8 +(inc2 7) +;=>9 +(inc3 9) +;=>12 + +;; +;; Testing atoms + +(def! inc3 (fn* (a) (+ 3 a))) + +(def! a (atom 2)) +;=>(atom 2) + +(atom? a) +;=>true + +(atom? 1) +;=>false + +(deref a) +;=>2 + +(reset! a 3) +;=>3 + +(deref a) +;=>3 + +(swap! a inc3) +;=>6 + +(deref a) +;=>6 + +(swap! a (fn* (a) a)) +;=>6 + +(swap! a (fn* (a) (* 2 a))) +;=>12 + +(swap! a (fn* (a b) (* a b)) 10) +;=>120 + +(swap! a + 3) +;=>123 + +;; Testing swap!/closure interaction +(def! inc-it (fn* (a) (+ 1 a))) +(def! atm (atom 7)) +(def! f (fn* () (swap! atm inc-it))) +(f) +;=>8 +(f) +;=>9 + +;; Testing whether closures can retain atoms +(def! g (let* (atm (atom 0)) (fn* () (deref atm)))) +(def! atm (atom 1)) +(g) +;=>0 + +;>>> deferrable=True +;; +;; -------- Deferrable Functionality -------- + +;; Testing reading of large files +(load-file "../tests/computations.mal") +;=>nil +(sumdown 2) +;=>3 +(fib 2) +;=>1 + +;; Testing `@` reader macro (short for `deref`) +(def! atm (atom 9)) +@atm +;=>9 + +;;; TODO: really a step5 test +;; Testing that vector params not broken by TCO +(def! g (fn* [] 78)) +(g) +;=>78 +(def! g (fn* [a] (+ a 78))) +(g 3) +;=>81 + +;; +;; Testing that *ARGV* exists and is an empty list +(list? *ARGV*) +;=>true +*ARGV* +;=>() + +;; +;; Testing that eval sets aa in root scope, and that it is found in nested scope +(let* (b 12) (do (eval (read-string "(def! aa 7)")) aa )) +;=>7 + +;>>> soft=True +;>>> optional=True +;; +;; -------- Optional Functionality -------- + +;; Testing comments in a file +(load-file "../tests/incB.mal") +;=>nil +(inc4 7) +;=>11 +(inc5 7) +;=>12 + +;; Testing map literal across multiple lines in a file +(load-file "../tests/incC.mal") +;=>nil +mymap +;=>{"a" 1} + +;; Checking that eval does not use local environments. +(def! a 1) +;=>1 +(let* (a 2) (eval (read-string "a"))) +;=>1 + +;; Non alphanumeric characters in comments in read-string +(read-string "1;!") +;=>1 +(read-string "1;\"") +;=>1 +(read-string "1;#") +;=>1 +(read-string "1;$") +;=>1 +(read-string "1;%") +;=>1 +(read-string "1;'") +;=>1 +(read-string "1;\\") +;=>1 +(read-string "1;\\\\") +;=>1 +(read-string "1;\\\\\\") +;=>1 +(read-string "1;`") +;=>1 +;;; Hopefully less problematic characters can be checked together +(read-string "1; &()*+,-./:;<=>?@[]^_{|}~") +;=>1 + diff --git a/impls/tests/step7_quote.mal b/impls/tests/step7_quote.mal index ef80c8259a..e37818a965 100644 --- a/impls/tests/step7_quote.mal +++ b/impls/tests/step7_quote.mal @@ -1,349 +1,349 @@ -;; Testing cons function -(cons 1 (list)) -;=>(1) -(cons 1 (list 2)) -;=>(1 2) -(cons 1 (list 2 3)) -;=>(1 2 3) -(cons (list 1) (list 2 3)) -;=>((1) 2 3) - -(def! a (list 2 3)) -(cons 1 a) -;=>(1 2 3) -a -;=>(2 3) - -;; Testing concat function -(concat) -;=>() -(concat (list 1 2)) -;=>(1 2) -(concat (list 1 2) (list 3 4)) -;=>(1 2 3 4) -(concat (list 1 2) (list 3 4) (list 5 6)) -;=>(1 2 3 4 5 6) -(concat (concat)) -;=>() -(concat (list) (list)) -;=>() -(= () (concat)) -;=>true - -(def! a (list 1 2)) -(def! b (list 3 4)) -(concat a b (list 5 6)) -;=>(1 2 3 4 5 6) -a -;=>(1 2) -b -;=>(3 4) - -;; Testing regular quote -(quote 7) -;=>7 -(quote (1 2 3)) -;=>(1 2 3) -(quote (1 2 (3 4))) -;=>(1 2 (3 4)) - -;; Testing simple quasiquote -(quasiquote nil) -;=>nil -(quasiquote 7) -;=>7 -(quasiquote a) -;=>a -(quasiquote {"a" b}) -;=>{"a" b} - -;; Testing quasiquote with lists -(quasiquote ()) -;=>() -(quasiquote (1 2 3)) -;=>(1 2 3) -(quasiquote (a)) -;=>(a) -(quasiquote (1 2 (3 4))) -;=>(1 2 (3 4)) -(quasiquote (nil)) -;=>(nil) -(quasiquote (1 ())) -;=>(1 ()) -(quasiquote (() 1)) -;=>(() 1) -(quasiquote (1 () 2)) -;=>(1 () 2) -(quasiquote (())) -;=>(()) -;; (quasiquote (f () g (h) i (j k) l)) -;; =>(f () g (h) i (j k) l) - -;; Testing unquote -(quasiquote (unquote 7)) -;=>7 -(def! a 8) -;=>8 -(quasiquote a) -;=>a -(quasiquote (unquote a)) -;=>8 -(quasiquote (1 a 3)) -;=>(1 a 3) -(quasiquote (1 (unquote a) 3)) -;=>(1 8 3) -(def! b (quote (1 "b" "d"))) -;=>(1 "b" "d") -(quasiquote (1 b 3)) -;=>(1 b 3) -(quasiquote (1 (unquote b) 3)) -;=>(1 (1 "b" "d") 3) -(quasiquote ((unquote 1) (unquote 2))) -;=>(1 2) - -;; Quasiquote and environments -(let* (x 0) (quasiquote (unquote x))) -;=>0 - -;; Testing splice-unquote -(def! c (quote (1 "b" "d"))) -;=>(1 "b" "d") -(quasiquote (1 c 3)) -;=>(1 c 3) -(quasiquote (1 (splice-unquote c) 3)) -;=>(1 1 "b" "d" 3) -(quasiquote (1 (splice-unquote c))) -;=>(1 1 "b" "d") -(quasiquote ((splice-unquote c) 2)) -;=>(1 "b" "d" 2) -(quasiquote ((splice-unquote c) (splice-unquote c))) -;=>(1 "b" "d" 1 "b" "d") - -;; Testing symbol equality -(= (quote abc) (quote abc)) -;=>true -(= (quote abc) (quote abcd)) -;=>false -(= (quote abc) "abc") -;=>false -(= "abc" (quote abc)) -;=>false -(= "abc" (str (quote abc))) -;=>true -(= (quote abc) nil) -;=>false -(= nil (quote abc)) -;=>false - -;>>> deferrable=True -;; -;; -------- Deferrable Functionality -------- - -;; Testing ' (quote) reader macro -'7 -;=>7 -'(1 2 3) -;=>(1 2 3) -'(1 2 (3 4)) -;=>(1 2 (3 4)) - -;; Testing cons and concat with vectors - -(cons 1 []) -;=>(1) -(cons [1] [2 3]) -;=>([1] 2 3) -(cons 1 [2 3]) -;=>(1 2 3) -(concat [1 2] (list 3 4) [5 6]) -;=>(1 2 3 4 5 6) -(concat [1 2]) -;=>(1 2) - -;>>> optional=True -;; -;; -------- Optional Functionality -------- - -;; Testing ` (quasiquote) reader macro -`7 -;=>7 -`(1 2 3) -;=>(1 2 3) -`(1 2 (3 4)) -;=>(1 2 (3 4)) -`(nil) -;=>(nil) - -;; Testing ~ (unquote) reader macro -`~7 -;=>7 -(def! a 8) -;=>8 -`(1 ~a 3) -;=>(1 8 3) -(def! b '(1 "b" "d")) -;=>(1 "b" "d") -`(1 b 3) -;=>(1 b 3) -`(1 ~b 3) -;=>(1 (1 "b" "d") 3) - -;; Testing ~@ (splice-unquote) reader macro -(def! c '(1 "b" "d")) -;=>(1 "b" "d") -`(1 c 3) -;=>(1 c 3) -`(1 ~@c 3) -;=>(1 1 "b" "d" 3) - -;>>> soft=True - -;; Testing vec function - -(vec (list)) -;=>[] -(vec (list 1)) -;=>[1] -(vec (list 1 2)) -;=>[1 2] -(vec []) -;=>[] -(vec [1 2]) -;=>[1 2] - -;; Testing that vec does not mutate the original list -(def! a (list 1 2)) -(vec a) -;=>[1 2] -a -;=>(1 2) - -;; Test quine -((fn* (q) (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* (q) (quasiquote ((unquote q) (quote (unquote q))))))) -;=>((fn* (q) (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* (q) (quasiquote ((unquote q) (quote (unquote q))))))) - -;; Testing quasiquote with vectors -(quasiquote []) -;=>[] -(quasiquote [[]]) -;=>[[]] -(quasiquote [()]) -;=>[()] -(quasiquote ([])) -;=>([]) -(def! a 8) -;=>8 -`[1 a 3] -;=>[1 a 3] -(quasiquote [a [] b [c] d [e f] g]) -;=>[a [] b [c] d [e f] g] - -;; Testing unquote with vectors -`[~a] -;=>[8] -`[(~a)] -;=>[(8)] -`([~a]) -;=>([8]) -`[a ~a a] -;=>[a 8 a] -`([a ~a a]) -;=>([a 8 a]) -`[(a ~a a)] -;=>[(a 8 a)] - -;; Testing splice-unquote with vectors -(def! c '(1 "b" "d")) -;=>(1 "b" "d") -`[~@c] -;=>[1 "b" "d"] -`[(~@c)] -;=>[(1 "b" "d")] -`([~@c]) -;=>([1 "b" "d"]) -`[1 ~@c 3] -;=>[1 1 "b" "d" 3] -`([1 ~@c 3]) -;=>([1 1 "b" "d" 3]) -`[(1 ~@c 3)] -;=>[(1 1 "b" "d" 3)] - -;; Misplaced unquote or splice-unquote -`(0 unquote) -;=>(0 unquote) -`(0 splice-unquote) -;=>(0 splice-unquote) -`[unquote 0] -;=>[unquote 0] -`[splice-unquote 0] -;=>[splice-unquote 0] - -;; Debugging quasiquote -(quasiquoteexpand nil) -;=>nil -(quasiquoteexpand 7) -;=>7 -(quasiquoteexpand a) -;=>(quote a) -(quasiquoteexpand {"a" b}) -;=>(quote {"a" b}) -(quasiquoteexpand ()) -;=>() -(quasiquoteexpand (1 2 3)) -;=>(cons 1 (cons 2 (cons 3 ()))) -(quasiquoteexpand (a)) -;=>(cons (quote a) ()) -(quasiquoteexpand (1 2 (3 4))) -;=>(cons 1 (cons 2 (cons (cons 3 (cons 4 ())) ()))) -(quasiquoteexpand (nil)) -;=>(cons nil ()) -(quasiquoteexpand (1 ())) -;=>(cons 1 (cons () ())) -(quasiquoteexpand (() 1)) -;=>(cons () (cons 1 ())) -(quasiquoteexpand (1 () 2)) -;=>(cons 1 (cons () (cons 2 ()))) -(quasiquoteexpand (())) -;=>(cons () ()) -(quasiquoteexpand (f () g (h) i (j k) l)) -;=>(cons (quote f) (cons () (cons (quote g) (cons (cons (quote h) ()) (cons (quote i) (cons (cons (quote j) (cons (quote k) ())) (cons (quote l) ()))))))) -(quasiquoteexpand (unquote 7)) -;=>7 -(quasiquoteexpand a) -;=>(quote a) -(quasiquoteexpand (unquote a)) -;=>a -(quasiquoteexpand (1 a 3)) -;=>(cons 1 (cons (quote a) (cons 3 ()))) -(quasiquoteexpand (1 (unquote a) 3)) -;=>(cons 1 (cons a (cons 3 ()))) -(quasiquoteexpand (1 b 3)) -;=>(cons 1 (cons (quote b) (cons 3 ()))) -(quasiquoteexpand (1 (unquote b) 3)) -;=>(cons 1 (cons b (cons 3 ()))) -(quasiquoteexpand ((unquote 1) (unquote 2))) -;=>(cons 1 (cons 2 ())) -(quasiquoteexpand (a (splice-unquote (b c)) d)) -;=>(cons (quote a) (concat (b c) (cons (quote d) ()))) -(quasiquoteexpand (1 c 3)) -;=>(cons 1 (cons (quote c) (cons 3 ()))) -(quasiquoteexpand (1 (splice-unquote c) 3)) -;=>(cons 1 (concat c (cons 3 ()))) -(quasiquoteexpand (1 (splice-unquote c))) -;=>(cons 1 (concat c ())) -(quasiquoteexpand ((splice-unquote c) 2)) -;=>(concat c (cons 2 ())) -(quasiquoteexpand ((splice-unquote c) (splice-unquote c))) -;=>(concat c (concat c ())) -(quasiquoteexpand []) -;=>(vec ()) -(quasiquoteexpand [[]]) -;=>(vec (cons (vec ()) ())) -(quasiquoteexpand [()]) -;=>(vec (cons () ())) -(quasiquoteexpand ([])) -;=>(cons (vec ()) ()) -(quasiquoteexpand [1 a 3]) -;=>(vec (cons 1 (cons (quote a) (cons 3 ())))) -(quasiquoteexpand [a [] b [c] d [e f] g]) -;=>(vec (cons (quote a) (cons (vec ()) (cons (quote b) (cons (vec (cons (quote c) ())) (cons (quote d) (cons (vec (cons (quote e) (cons (quote f) ()))) (cons (quote g) ())))))))) +;; Testing cons function +(cons 1 (list)) +;=>(1) +(cons 1 (list 2)) +;=>(1 2) +(cons 1 (list 2 3)) +;=>(1 2 3) +(cons (list 1) (list 2 3)) +;=>((1) 2 3) + +(def! a (list 2 3)) +(cons 1 a) +;=>(1 2 3) +a +;=>(2 3) + +;; Testing concat function +(concat) +;=>() +(concat (list 1 2)) +;=>(1 2) +(concat (list 1 2) (list 3 4)) +;=>(1 2 3 4) +(concat (list 1 2) (list 3 4) (list 5 6)) +;=>(1 2 3 4 5 6) +(concat (concat)) +;=>() +(concat (list) (list)) +;=>() +(= () (concat)) +;=>true + +(def! a (list 1 2)) +(def! b (list 3 4)) +(concat a b (list 5 6)) +;=>(1 2 3 4 5 6) +a +;=>(1 2) +b +;=>(3 4) + +;; Testing regular quote +(quote 7) +;=>7 +(quote (1 2 3)) +;=>(1 2 3) +(quote (1 2 (3 4))) +;=>(1 2 (3 4)) + +;; Testing simple quasiquote +(quasiquote nil) +;=>nil +(quasiquote 7) +;=>7 +(quasiquote a) +;=>a +(quasiquote {"a" b}) +;=>{"a" b} + +;; Testing quasiquote with lists +(quasiquote ()) +;=>() +(quasiquote (1 2 3)) +;=>(1 2 3) +(quasiquote (a)) +;=>(a) +(quasiquote (1 2 (3 4))) +;=>(1 2 (3 4)) +(quasiquote (nil)) +;=>(nil) +(quasiquote (1 ())) +;=>(1 ()) +(quasiquote (() 1)) +;=>(() 1) +(quasiquote (1 () 2)) +;=>(1 () 2) +(quasiquote (())) +;=>(()) +;; (quasiquote (f () g (h) i (j k) l)) +;; =>(f () g (h) i (j k) l) + +;; Testing unquote +(quasiquote (unquote 7)) +;=>7 +(def! a 8) +;=>8 +(quasiquote a) +;=>a +(quasiquote (unquote a)) +;=>8 +(quasiquote (1 a 3)) +;=>(1 a 3) +(quasiquote (1 (unquote a) 3)) +;=>(1 8 3) +(def! b (quote (1 "b" "d"))) +;=>(1 "b" "d") +(quasiquote (1 b 3)) +;=>(1 b 3) +(quasiquote (1 (unquote b) 3)) +;=>(1 (1 "b" "d") 3) +(quasiquote ((unquote 1) (unquote 2))) +;=>(1 2) + +;; Quasiquote and environments +(let* (x 0) (quasiquote (unquote x))) +;=>0 + +;; Testing splice-unquote +(def! c (quote (1 "b" "d"))) +;=>(1 "b" "d") +(quasiquote (1 c 3)) +;=>(1 c 3) +(quasiquote (1 (splice-unquote c) 3)) +;=>(1 1 "b" "d" 3) +(quasiquote (1 (splice-unquote c))) +;=>(1 1 "b" "d") +(quasiquote ((splice-unquote c) 2)) +;=>(1 "b" "d" 2) +(quasiquote ((splice-unquote c) (splice-unquote c))) +;=>(1 "b" "d" 1 "b" "d") + +;; Testing symbol equality +(= (quote abc) (quote abc)) +;=>true +(= (quote abc) (quote abcd)) +;=>false +(= (quote abc) "abc") +;=>false +(= "abc" (quote abc)) +;=>false +(= "abc" (str (quote abc))) +;=>true +(= (quote abc) nil) +;=>false +(= nil (quote abc)) +;=>false + +;>>> deferrable=True +;; +;; -------- Deferrable Functionality -------- + +;; Testing ' (quote) reader macro +'7 +;=>7 +'(1 2 3) +;=>(1 2 3) +'(1 2 (3 4)) +;=>(1 2 (3 4)) + +;; Testing cons and concat with vectors + +(cons 1 []) +;=>(1) +(cons [1] [2 3]) +;=>([1] 2 3) +(cons 1 [2 3]) +;=>(1 2 3) +(concat [1 2] (list 3 4) [5 6]) +;=>(1 2 3 4 5 6) +(concat [1 2]) +;=>(1 2) + +;>>> optional=True +;; +;; -------- Optional Functionality -------- + +;; Testing ` (quasiquote) reader macro +`7 +;=>7 +`(1 2 3) +;=>(1 2 3) +`(1 2 (3 4)) +;=>(1 2 (3 4)) +`(nil) +;=>(nil) + +;; Testing ~ (unquote) reader macro +`~7 +;=>7 +(def! a 8) +;=>8 +`(1 ~a 3) +;=>(1 8 3) +(def! b '(1 "b" "d")) +;=>(1 "b" "d") +`(1 b 3) +;=>(1 b 3) +`(1 ~b 3) +;=>(1 (1 "b" "d") 3) + +;; Testing ~@ (splice-unquote) reader macro +(def! c '(1 "b" "d")) +;=>(1 "b" "d") +`(1 c 3) +;=>(1 c 3) +`(1 ~@c 3) +;=>(1 1 "b" "d" 3) + +;>>> soft=True + +;; Testing vec function + +(vec (list)) +;=>[] +(vec (list 1)) +;=>[1] +(vec (list 1 2)) +;=>[1 2] +(vec []) +;=>[] +(vec [1 2]) +;=>[1 2] + +;; Testing that vec does not mutate the original list +(def! a (list 1 2)) +(vec a) +;=>[1 2] +a +;=>(1 2) + +;; Test quine +((fn* (q) (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* (q) (quasiquote ((unquote q) (quote (unquote q))))))) +;=>((fn* (q) (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* (q) (quasiquote ((unquote q) (quote (unquote q))))))) + +;; Testing quasiquote with vectors +(quasiquote []) +;=>[] +(quasiquote [[]]) +;=>[[]] +(quasiquote [()]) +;=>[()] +(quasiquote ([])) +;=>([]) +(def! a 8) +;=>8 +`[1 a 3] +;=>[1 a 3] +(quasiquote [a [] b [c] d [e f] g]) +;=>[a [] b [c] d [e f] g] + +;; Testing unquote with vectors +`[~a] +;=>[8] +`[(~a)] +;=>[(8)] +`([~a]) +;=>([8]) +`[a ~a a] +;=>[a 8 a] +`([a ~a a]) +;=>([a 8 a]) +`[(a ~a a)] +;=>[(a 8 a)] + +;; Testing splice-unquote with vectors +(def! c '(1 "b" "d")) +;=>(1 "b" "d") +`[~@c] +;=>[1 "b" "d"] +`[(~@c)] +;=>[(1 "b" "d")] +`([~@c]) +;=>([1 "b" "d"]) +`[1 ~@c 3] +;=>[1 1 "b" "d" 3] +`([1 ~@c 3]) +;=>([1 1 "b" "d" 3]) +`[(1 ~@c 3)] +;=>[(1 1 "b" "d" 3)] + +;; Misplaced unquote or splice-unquote +`(0 unquote) +;=>(0 unquote) +`(0 splice-unquote) +;=>(0 splice-unquote) +`[unquote 0] +;=>[unquote 0] +`[splice-unquote 0] +;=>[splice-unquote 0] + +;; Debugging quasiquote +(quasiquoteexpand nil) +;=>nil +(quasiquoteexpand 7) +;=>7 +(quasiquoteexpand a) +;=>(quote a) +(quasiquoteexpand {"a" b}) +;=>(quote {"a" b}) +(quasiquoteexpand ()) +;=>() +(quasiquoteexpand (1 2 3)) +;=>(cons 1 (cons 2 (cons 3 ()))) +(quasiquoteexpand (a)) +;=>(cons (quote a) ()) +(quasiquoteexpand (1 2 (3 4))) +;=>(cons 1 (cons 2 (cons (cons 3 (cons 4 ())) ()))) +(quasiquoteexpand (nil)) +;=>(cons nil ()) +(quasiquoteexpand (1 ())) +;=>(cons 1 (cons () ())) +(quasiquoteexpand (() 1)) +;=>(cons () (cons 1 ())) +(quasiquoteexpand (1 () 2)) +;=>(cons 1 (cons () (cons 2 ()))) +(quasiquoteexpand (())) +;=>(cons () ()) +(quasiquoteexpand (f () g (h) i (j k) l)) +;=>(cons (quote f) (cons () (cons (quote g) (cons (cons (quote h) ()) (cons (quote i) (cons (cons (quote j) (cons (quote k) ())) (cons (quote l) ()))))))) +(quasiquoteexpand (unquote 7)) +;=>7 +(quasiquoteexpand a) +;=>(quote a) +(quasiquoteexpand (unquote a)) +;=>a +(quasiquoteexpand (1 a 3)) +;=>(cons 1 (cons (quote a) (cons 3 ()))) +(quasiquoteexpand (1 (unquote a) 3)) +;=>(cons 1 (cons a (cons 3 ()))) +(quasiquoteexpand (1 b 3)) +;=>(cons 1 (cons (quote b) (cons 3 ()))) +(quasiquoteexpand (1 (unquote b) 3)) +;=>(cons 1 (cons b (cons 3 ()))) +(quasiquoteexpand ((unquote 1) (unquote 2))) +;=>(cons 1 (cons 2 ())) +(quasiquoteexpand (a (splice-unquote (b c)) d)) +;=>(cons (quote a) (concat (b c) (cons (quote d) ()))) +(quasiquoteexpand (1 c 3)) +;=>(cons 1 (cons (quote c) (cons 3 ()))) +(quasiquoteexpand (1 (splice-unquote c) 3)) +;=>(cons 1 (concat c (cons 3 ()))) +(quasiquoteexpand (1 (splice-unquote c))) +;=>(cons 1 (concat c ())) +(quasiquoteexpand ((splice-unquote c) 2)) +;=>(concat c (cons 2 ())) +(quasiquoteexpand ((splice-unquote c) (splice-unquote c))) +;=>(concat c (concat c ())) +(quasiquoteexpand []) +;=>(vec ()) +(quasiquoteexpand [[]]) +;=>(vec (cons (vec ()) ())) +(quasiquoteexpand [()]) +;=>(vec (cons () ())) +(quasiquoteexpand ([])) +;=>(cons (vec ()) ()) +(quasiquoteexpand [1 a 3]) +;=>(vec (cons 1 (cons (quote a) (cons 3 ())))) +(quasiquoteexpand [a [] b [c] d [e f] g]) +;=>(vec (cons (quote a) (cons (vec ()) (cons (quote b) (cons (vec (cons (quote c) ())) (cons (quote d) (cons (vec (cons (quote e) (cons (quote f) ()))) (cons (quote g) ())))))))) diff --git a/impls/tests/step8_macros.mal b/impls/tests/step8_macros.mal index 6fd1ef9d94..46ef76a239 100644 --- a/impls/tests/step8_macros.mal +++ b/impls/tests/step8_macros.mal @@ -1,165 +1,165 @@ -;; Testing trivial macros -(defmacro! one (fn* () 1)) -(one) -;=>1 -(defmacro! two (fn* () 2)) -(two) -;=>2 - -;; Testing unless macros -(defmacro! unless (fn* (pred a b) `(if ~pred ~b ~a))) -(unless false 7 8) -;=>7 -(unless true 7 8) -;=>8 -(defmacro! unless2 (fn* (pred a b) (list 'if (list 'not pred) a b))) -(unless2 false 7 8) -;=>7 -(unless2 true 7 8) -;=>8 - -;; Testing macroexpand -(macroexpand (one)) -;=>1 -(macroexpand (unless PRED A B)) -;=>(if PRED B A) -(macroexpand (unless2 PRED A B)) -;=>(if (not PRED) A B) -(macroexpand (unless2 2 3 4)) -;=>(if (not 2) 3 4) - -;; Testing evaluation of macro result -(defmacro! identity (fn* (x) x)) -(let* (a 123) (macroexpand (identity a))) -;=>a -(let* (a 123) (identity a)) -;=>123 - -;; Test that macros do not break empty list -() -;=>() - -;; Test that macros do not break quasiquote -`(1) -;=>(1) - -;>>> deferrable=True -;; -;; -------- Deferrable Functionality -------- - -;; Testing non-macro function -(not (= 1 1)) -;=>false -;;; This should fail if it is a macro -(not (= 1 2)) -;=>true - -;; Testing nth, first and rest functions - -(nth (list 1) 0) -;=>1 -(nth (list 1 2) 1) -;=>2 -(nth (list 1 2 nil) 2) -;=>nil -(def! x "x") -(def! x (nth (list 1 2) 2)) -x -;=>"x" - -(first (list)) -;=>nil -(first (list 6)) -;=>6 -(first (list 7 8 9)) -;=>7 - -(rest (list)) -;=>() -(rest (list 6)) -;=>() -(rest (list 7 8 9)) -;=>(8 9) - - -;; Testing cond macro - -(macroexpand (cond)) -;=>nil -(cond) -;=>nil -(macroexpand (cond X Y)) -;=>(if X Y (cond)) -(cond true 7) -;=>7 -(cond false 7) -;=>nil -(macroexpand (cond X Y Z T)) -;=>(if X Y (cond Z T)) -(cond true 7 true 8) -;=>7 -(cond false 7 true 8) -;=>8 -(cond false 7 false 8 "else" 9) -;=>9 -(cond false 7 (= 2 2) 8 "else" 9) -;=>8 -(cond false 7 false 8 false 9) -;=>nil - -;; Testing EVAL in let* - -(let* (x (cond false "no" true "yes")) x) -;=>"yes" - - -;; Testing nth, first, rest with vectors - -(nth [1] 0) -;=>1 -(nth [1 2] 1) -;=>2 -(nth [1 2 nil] 2) -;=>nil -(def! x "x") -(def! x (nth [1 2] 2)) -x -;=>"x" - -(first []) -;=>nil -(first nil) -;=>nil -(first [10]) -;=>10 -(first [10 11 12]) -;=>10 -(rest []) -;=>() -(rest nil) -;=>() -(rest [10]) -;=>() -(rest [10 11 12]) -;=>(11 12) -(rest (cons 10 [11 12])) -;=>(11 12) - -;; Testing EVAL in vector let* - -(let* [x (cond false "no" true "yes")] x) -;=>"yes" - -;>>> soft=True -;>>> optional=True -;; -;; ------- Optional Functionality -------------- -;; ------- (Not needed for self-hosting) ------- - -;; Test that macros use closures -(def! x 2) -(defmacro! a (fn* [] x)) -(a) -;=>2 -(let* (x 3) (a)) -;=>2 +;; Testing trivial macros +(defmacro! one (fn* () 1)) +(one) +;=>1 +(defmacro! two (fn* () 2)) +(two) +;=>2 + +;; Testing unless macros +(defmacro! unless (fn* (pred a b) `(if ~pred ~b ~a))) +(unless false 7 8) +;=>7 +(unless true 7 8) +;=>8 +(defmacro! unless2 (fn* (pred a b) (list 'if (list 'not pred) a b))) +(unless2 false 7 8) +;=>7 +(unless2 true 7 8) +;=>8 + +;; Testing macroexpand +(macroexpand (one)) +;=>1 +(macroexpand (unless PRED A B)) +;=>(if PRED B A) +(macroexpand (unless2 PRED A B)) +;=>(if (not PRED) A B) +(macroexpand (unless2 2 3 4)) +;=>(if (not 2) 3 4) + +;; Testing evaluation of macro result +(defmacro! identity (fn* (x) x)) +(let* (a 123) (macroexpand (identity a))) +;=>a +(let* (a 123) (identity a)) +;=>123 + +;; Test that macros do not break empty list +() +;=>() + +;; Test that macros do not break quasiquote +`(1) +;=>(1) + +;>>> deferrable=True +;; +;; -------- Deferrable Functionality -------- + +;; Testing non-macro function +(not (= 1 1)) +;=>false +;;; This should fail if it is a macro +(not (= 1 2)) +;=>true + +;; Testing nth, first and rest functions + +(nth (list 1) 0) +;=>1 +(nth (list 1 2) 1) +;=>2 +(nth (list 1 2 nil) 2) +;=>nil +(def! x "x") +(def! x (nth (list 1 2) 2)) +x +;=>"x" + +(first (list)) +;=>nil +(first (list 6)) +;=>6 +(first (list 7 8 9)) +;=>7 + +(rest (list)) +;=>() +(rest (list 6)) +;=>() +(rest (list 7 8 9)) +;=>(8 9) + + +;; Testing cond macro + +(macroexpand (cond)) +;=>nil +(cond) +;=>nil +(macroexpand (cond X Y)) +;=>(if X Y (cond)) +(cond true 7) +;=>7 +(cond false 7) +;=>nil +(macroexpand (cond X Y Z T)) +;=>(if X Y (cond Z T)) +(cond true 7 true 8) +;=>7 +(cond false 7 true 8) +;=>8 +(cond false 7 false 8 "else" 9) +;=>9 +(cond false 7 (= 2 2) 8 "else" 9) +;=>8 +(cond false 7 false 8 false 9) +;=>nil + +;; Testing EVAL in let* + +(let* (x (cond false "no" true "yes")) x) +;=>"yes" + + +;; Testing nth, first, rest with vectors + +(nth [1] 0) +;=>1 +(nth [1 2] 1) +;=>2 +(nth [1 2 nil] 2) +;=>nil +(def! x "x") +(def! x (nth [1 2] 2)) +x +;=>"x" + +(first []) +;=>nil +(first nil) +;=>nil +(first [10]) +;=>10 +(first [10 11 12]) +;=>10 +(rest []) +;=>() +(rest nil) +;=>() +(rest [10]) +;=>() +(rest [10 11 12]) +;=>(11 12) +(rest (cons 10 [11 12])) +;=>(11 12) + +;; Testing EVAL in vector let* + +(let* [x (cond false "no" true "yes")] x) +;=>"yes" + +;>>> soft=True +;>>> optional=True +;; +;; ------- Optional Functionality -------------- +;; ------- (Not needed for self-hosting) ------- + +;; Test that macros use closures +(def! x 2) +(defmacro! a (fn* [] x)) +(a) +;=>2 +(let* (x 3) (a)) +;=>2 diff --git a/impls/tests/step9_try.mal b/impls/tests/step9_try.mal index 81de41e47b..5c40797c0e 100644 --- a/impls/tests/step9_try.mal +++ b/impls/tests/step9_try.mal @@ -1,404 +1,404 @@ -;; -;; Testing throw - -(throw "err1") -;/.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*err1.* - -;; -;; Testing try*/catch* - -(try* 123 (catch* e 456)) -;=>123 - -(try* abc (catch* exc (prn "exc is:" exc))) -;/"exc is:" "'abc' not found" -;=>nil - -(try* (abc 1 2) (catch* exc (prn "exc is:" exc))) -;/"exc is:" "'abc' not found" -;=>nil - -;; Make sure error from core can be caught -(try* (nth () 1) (catch* exc (prn "exc is:" exc))) -;/"exc is:".*(length|range|[Bb]ounds|beyond).* -;=>nil - -(try* (throw "my exception") (catch* exc (do (prn "exc:" exc) 7))) -;/"exc:" "my exception" -;=>7 - -;; Test that exception handlers get restored correctly -(try* (do (try* "t1" (catch* e "c1")) (throw "e1")) (catch* e "c2")) -;=>"c2" -(try* (try* (throw "e1") (catch* e (throw "e2"))) (catch* e "c2")) -;=>"c2" - -;;; Test that throw is a function: -(try* (map throw (list "my err")) (catch* exc exc)) -;=>"my err" - - -;; -;; Testing builtin functions - -(symbol? 'abc) -;=>true -(symbol? "abc") -;=>false - -(nil? nil) -;=>true -(nil? true) -;=>false - -(true? true) -;=>true -(true? false) -;=>false -(true? true?) -;=>false - -(false? false) -;=>true -(false? true) -;=>false - -;; Testing apply function with core functions -(apply + (list 2 3)) -;=>5 -(apply + 4 (list 5)) -;=>9 -(apply prn (list 1 2 "3" (list))) -;/1 2 "3" \(\) -;=>nil -(apply prn 1 2 (list "3" (list))) -;/1 2 "3" \(\) -;=>nil -(apply list (list)) -;=>() -(apply symbol? (list (quote two))) -;=>true - -;; Testing apply function with user functions -(apply (fn* (a b) (+ a b)) (list 2 3)) -;=>5 -(apply (fn* (a b) (+ a b)) 4 (list 5)) -;=>9 - -;; Testing map function -(def! nums (list 1 2 3)) -(def! double (fn* (a) (* 2 a))) -(double 3) -;=>6 -(map double nums) -;=>(2 4 6) -(map (fn* (x) (symbol? x)) (list 1 (quote two) "three")) -;=>(false true false) -(= () (map str ())) -;=>true - -;>>> deferrable=True -;; -;; ------- Deferrable Functionality ---------- -;; ------- (Needed for self-hosting) ------- - -;; Testing symbol and keyword functions -(symbol? :abc) -;=>false -(symbol? 'abc) -;=>true -(symbol? "abc") -;=>false -(symbol? (symbol "abc")) -;=>true -(keyword? :abc) -;=>true -(keyword? 'abc) -;=>false -(keyword? "abc") -;=>false -(keyword? "") -;=>false -(keyword? (keyword "abc")) -;=>true - -(symbol "abc") -;=>abc -(keyword "abc") -;=>:abc - -;; Testing sequential? function - -(sequential? (list 1 2 3)) -;=>true -(sequential? [15]) -;=>true -(sequential? sequential?) -;=>false -(sequential? nil) -;=>false -(sequential? "abc") -;=>false - -;; Testing apply function with core functions and arguments in vector -(apply + 4 [5]) -;=>9 -(apply prn 1 2 ["3" 4]) -;/1 2 "3" 4 -;=>nil -(apply list []) -;=>() -;; Testing apply function with user functions and arguments in vector -(apply (fn* (a b) (+ a b)) [2 3]) -;=>5 -(apply (fn* (a b) (+ a b)) 4 [5]) -;=>9 - - -;; Testing map function with vectors -(map (fn* (a) (* 2 a)) [1 2 3]) -;=>(2 4 6) - -(map (fn* [& args] (list? args)) [1 2]) -;=>(true true) - -;; Testing vector functions - -(vector? [10 11]) -;=>true -(vector? '(12 13)) -;=>false -(vector 3 4 5) -;=>[3 4 5] -(= [] (vector)) -;=>true - -(map? {}) -;=>true -(map? '()) -;=>false -(map? []) -;=>false -(map? 'abc) -;=>false -(map? :abc) -;=>false - - -;; -;; Testing hash-maps -(hash-map "a" 1) -;=>{"a" 1} - -{"a" 1} -;=>{"a" 1} - -(assoc {} "a" 1) -;=>{"a" 1} - -(get (assoc (assoc {"a" 1 } "b" 2) "c" 3) "a") -;=>1 - -(def! hm1 (hash-map)) -;=>{} - -(map? hm1) -;=>true -(map? 1) -;=>false -(map? "abc") -;=>false - -(get nil "a") -;=>nil - -(get hm1 "a") -;=>nil - -(contains? hm1 "a") -;=>false - -(def! hm2 (assoc hm1 "a" 1)) -;=>{"a" 1} - -(get hm1 "a") -;=>nil - -(contains? hm1 "a") -;=>false - -(get hm2 "a") -;=>1 - -(contains? hm2 "a") -;=>true - - -;;; TODO: fix. Clojure returns nil but this breaks mal impl -(keys hm1) -;=>() -(= () (keys hm1)) -;=>true - -(keys hm2) -;=>("a") - -(keys {"1" 1}) -;=>("1") - -;;; TODO: fix. Clojure returns nil but this breaks mal impl -(vals hm1) -;=>() -(= () (vals hm1)) -;=>true - -(vals hm2) -;=>(1) - -(count (keys (assoc hm2 "b" 2 "c" 3))) -;=>3 - -;; Testing keywords as hash-map keys -(get {:abc 123} :abc) -;=>123 -(contains? {:abc 123} :abc) -;=>true -(contains? {:abcd 123} :abc) -;=>false -(assoc {} :bcd 234) -;=>{:bcd 234} -(keyword? (nth (keys {:abc 123 :def 456}) 0)) -;=>true -(keyword? (nth (vals {"a" :abc "b" :def}) 0)) -;=>true - -;; Testing whether assoc updates properly -(def! hm4 (assoc {:a 1 :b 2} :a 3 :c 1)) -(get hm4 :a) -;=>3 -(get hm4 :b) -;=>2 -(get hm4 :c) -;=>1 - -;; Testing nil as hash-map values -(contains? {:abc nil} :abc) -;=>true -(assoc {} :bcd nil) -;=>{:bcd nil} - -;; -;; Additional str and pr-str tests - -(str "A" {:abc "val"} "Z") -;=>"A{:abc val}Z" - -(str true "." false "." nil "." :keyw "." 'symb) -;=>"true.false.nil.:keyw.symb" - -(pr-str "A" {:abc "val"} "Z") -;=>"\"A\" {:abc \"val\"} \"Z\"" - -(pr-str true "." false "." nil "." :keyw "." 'symb) -;=>"true \".\" false \".\" nil \".\" :keyw \".\" symb" - -(def! s (str {:abc "val1" :def "val2"})) -(cond (= s "{:abc val1 :def val2}") true (= s "{:def val2 :abc val1}") true) -;=>true - -(def! p (pr-str {:abc "val1" :def "val2"})) -(cond (= p "{:abc \"val1\" :def \"val2\"}") true (= p "{:def \"val2\" :abc \"val1\"}") true) -;=>true - -;; -;; Test extra function arguments as Mal List (bypassing TCO with apply) -(apply (fn* (& more) (list? more)) [1 2 3]) -;=>true -(apply (fn* (& more) (list? more)) []) -;=>true -(apply (fn* (a & more) (list? more)) [1]) -;=>true - -;>>> soft=True -;>>> optional=True -;; -;; ------- Optional Functionality -------------- -;; ------- (Not needed for self-hosting) ------- - - -;; Testing throwing a hash-map -(throw {:msg "err2"}) -;/.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*msg.*err2.* - -;;;TODO: fix so long lines don't trigger ANSI escape codes ;;;(try* -;;;(try* (throw ["data" "foo"]) (catch* exc (do (prn "exc is:" exc) 7))) ;;;; -;;;; "exc is:" ["data" "foo"] ;;;;=>7 -;;;;=>7 - -;; -;; Testing try* without catch* -(try* xyz) -;/.*\'?xyz\'? not found.* - -;; -;; Testing throwing non-strings -(try* (throw (list 1 2 3)) (catch* exc (do (prn "err:" exc) 7))) -;/"err:" \(1 2 3\) -;=>7 - -;; -;; Testing dissoc -(def! hm3 (assoc hm2 "b" 2)) -(count (keys hm3)) -;=>2 -(count (vals hm3)) -;=>2 -(dissoc hm3 "a") -;=>{"b" 2} -(dissoc hm3 "a" "b") -;=>{} -(dissoc hm3 "a" "b" "c") -;=>{} -(count (keys hm3)) -;=>2 - -(dissoc {:cde 345 :fgh 456} :cde) -;=>{:fgh 456} -(dissoc {:cde nil :fgh 456} :cde) -;=>{:fgh 456} - -;; -;; Testing equality of hash-maps -(= {} {}) -;=>true -(= {} (hash-map)) -;=>true -(= {:a 11 :b 22} (hash-map :b 22 :a 11)) -;=>true -(= {:a 11 :b [22 33]} (hash-map :b [22 33] :a 11)) -;=>true -(= {:a 11 :b {:c 33}} (hash-map :b {:c 33} :a 11)) -;=>true -(= {:a 11 :b 22} (hash-map :b 23 :a 11)) -;=>false -(= {:a 11 :b 22} (hash-map :a 11)) -;=>false -(= {:a [11 22]} {:a (list 11 22)}) -;=>true -(= {:a 11 :b 22} (list :a 11 :b 22)) -;=>false -(= {} []) -;=>false -(= [] {}) -;=>false - -(keyword :abc) -;=>:abc -(keyword? (first (keys {":abc" 123 ":def" 456}))) -;=>false - -;; Testing that hashmaps don't alter function ast -(def! bar (fn* [a] {:foo (get a :foo)})) -(bar {:foo (fn* [x] x)}) -(bar {:foo 3}) +;; +;; Testing throw + +(throw "err1") +;/.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*err1.* + +;; +;; Testing try*/catch* + +(try* 123 (catch* e 456)) +;=>123 + +(try* abc (catch* exc (prn "exc is:" exc))) +;/"exc is:" "'abc' not found" +;=>nil + +(try* (abc 1 2) (catch* exc (prn "exc is:" exc))) +;/"exc is:" "'abc' not found" +;=>nil + +;; Make sure error from core can be caught +(try* (nth () 1) (catch* exc (prn "exc is:" exc))) +;/"exc is:".*(length|range|[Bb]ounds|beyond).* +;=>nil + +(try* (throw "my exception") (catch* exc (do (prn "exc:" exc) 7))) +;/"exc:" "my exception" +;=>7 + +;; Test that exception handlers get restored correctly +(try* (do (try* "t1" (catch* e "c1")) (throw "e1")) (catch* e "c2")) +;=>"c2" +(try* (try* (throw "e1") (catch* e (throw "e2"))) (catch* e "c2")) +;=>"c2" + +;;; Test that throw is a function: +(try* (map throw (list "my err")) (catch* exc exc)) +;=>"my err" + + +;; +;; Testing builtin functions + +(symbol? 'abc) +;=>true +(symbol? "abc") +;=>false + +(nil? nil) +;=>true +(nil? true) +;=>false + +(true? true) +;=>true +(true? false) +;=>false +(true? true?) +;=>false + +(false? false) +;=>true +(false? true) +;=>false + +;; Testing apply function with core functions +(apply + (list 2 3)) +;=>5 +(apply + 4 (list 5)) +;=>9 +(apply prn (list 1 2 "3" (list))) +;/1 2 "3" \(\) +;=>nil +(apply prn 1 2 (list "3" (list))) +;/1 2 "3" \(\) +;=>nil +(apply list (list)) +;=>() +(apply symbol? (list (quote two))) +;=>true + +;; Testing apply function with user functions +(apply (fn* (a b) (+ a b)) (list 2 3)) +;=>5 +(apply (fn* (a b) (+ a b)) 4 (list 5)) +;=>9 + +;; Testing map function +(def! nums (list 1 2 3)) +(def! double (fn* (a) (* 2 a))) +(double 3) +;=>6 +(map double nums) +;=>(2 4 6) +(map (fn* (x) (symbol? x)) (list 1 (quote two) "three")) +;=>(false true false) +(= () (map str ())) +;=>true + +;>>> deferrable=True +;; +;; ------- Deferrable Functionality ---------- +;; ------- (Needed for self-hosting) ------- + +;; Testing symbol and keyword functions +(symbol? :abc) +;=>false +(symbol? 'abc) +;=>true +(symbol? "abc") +;=>false +(symbol? (symbol "abc")) +;=>true +(keyword? :abc) +;=>true +(keyword? 'abc) +;=>false +(keyword? "abc") +;=>false +(keyword? "") +;=>false +(keyword? (keyword "abc")) +;=>true + +(symbol "abc") +;=>abc +(keyword "abc") +;=>:abc + +;; Testing sequential? function + +(sequential? (list 1 2 3)) +;=>true +(sequential? [15]) +;=>true +(sequential? sequential?) +;=>false +(sequential? nil) +;=>false +(sequential? "abc") +;=>false + +;; Testing apply function with core functions and arguments in vector +(apply + 4 [5]) +;=>9 +(apply prn 1 2 ["3" 4]) +;/1 2 "3" 4 +;=>nil +(apply list []) +;=>() +;; Testing apply function with user functions and arguments in vector +(apply (fn* (a b) (+ a b)) [2 3]) +;=>5 +(apply (fn* (a b) (+ a b)) 4 [5]) +;=>9 + + +;; Testing map function with vectors +(map (fn* (a) (* 2 a)) [1 2 3]) +;=>(2 4 6) + +(map (fn* [& args] (list? args)) [1 2]) +;=>(true true) + +;; Testing vector functions + +(vector? [10 11]) +;=>true +(vector? '(12 13)) +;=>false +(vector 3 4 5) +;=>[3 4 5] +(= [] (vector)) +;=>true + +(map? {}) +;=>true +(map? '()) +;=>false +(map? []) +;=>false +(map? 'abc) +;=>false +(map? :abc) +;=>false + + +;; +;; Testing hash-maps +(hash-map "a" 1) +;=>{"a" 1} + +{"a" 1} +;=>{"a" 1} + +(assoc {} "a" 1) +;=>{"a" 1} + +(get (assoc (assoc {"a" 1 } "b" 2) "c" 3) "a") +;=>1 + +(def! hm1 (hash-map)) +;=>{} + +(map? hm1) +;=>true +(map? 1) +;=>false +(map? "abc") +;=>false + +(get nil "a") +;=>nil + +(get hm1 "a") +;=>nil + +(contains? hm1 "a") +;=>false + +(def! hm2 (assoc hm1 "a" 1)) +;=>{"a" 1} + +(get hm1 "a") +;=>nil + +(contains? hm1 "a") +;=>false + +(get hm2 "a") +;=>1 + +(contains? hm2 "a") +;=>true + + +;;; TODO: fix. Clojure returns nil but this breaks mal impl +(keys hm1) +;=>() +(= () (keys hm1)) +;=>true + +(keys hm2) +;=>("a") + +(keys {"1" 1}) +;=>("1") + +;;; TODO: fix. Clojure returns nil but this breaks mal impl +(vals hm1) +;=>() +(= () (vals hm1)) +;=>true + +(vals hm2) +;=>(1) + +(count (keys (assoc hm2 "b" 2 "c" 3))) +;=>3 + +;; Testing keywords as hash-map keys +(get {:abc 123} :abc) +;=>123 +(contains? {:abc 123} :abc) +;=>true +(contains? {:abcd 123} :abc) +;=>false +(assoc {} :bcd 234) +;=>{:bcd 234} +(keyword? (nth (keys {:abc 123 :def 456}) 0)) +;=>true +(keyword? (nth (vals {"a" :abc "b" :def}) 0)) +;=>true + +;; Testing whether assoc updates properly +(def! hm4 (assoc {:a 1 :b 2} :a 3 :c 1)) +(get hm4 :a) +;=>3 +(get hm4 :b) +;=>2 +(get hm4 :c) +;=>1 + +;; Testing nil as hash-map values +(contains? {:abc nil} :abc) +;=>true +(assoc {} :bcd nil) +;=>{:bcd nil} + +;; +;; Additional str and pr-str tests + +(str "A" {:abc "val"} "Z") +;=>"A{:abc val}Z" + +(str true "." false "." nil "." :keyw "." 'symb) +;=>"true.false.nil.:keyw.symb" + +(pr-str "A" {:abc "val"} "Z") +;=>"\"A\" {:abc \"val\"} \"Z\"" + +(pr-str true "." false "." nil "." :keyw "." 'symb) +;=>"true \".\" false \".\" nil \".\" :keyw \".\" symb" + +(def! s (str {:abc "val1" :def "val2"})) +(cond (= s "{:abc val1 :def val2}") true (= s "{:def val2 :abc val1}") true) +;=>true + +(def! p (pr-str {:abc "val1" :def "val2"})) +(cond (= p "{:abc \"val1\" :def \"val2\"}") true (= p "{:def \"val2\" :abc \"val1\"}") true) +;=>true + +;; +;; Test extra function arguments as Mal List (bypassing TCO with apply) +(apply (fn* (& more) (list? more)) [1 2 3]) +;=>true +(apply (fn* (& more) (list? more)) []) +;=>true +(apply (fn* (a & more) (list? more)) [1]) +;=>true + +;>>> soft=True +;>>> optional=True +;; +;; ------- Optional Functionality -------------- +;; ------- (Not needed for self-hosting) ------- + + +;; Testing throwing a hash-map +(throw {:msg "err2"}) +;/.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*msg.*err2.* + +;;;TODO: fix so long lines don't trigger ANSI escape codes ;;;(try* +;;;(try* (throw ["data" "foo"]) (catch* exc (do (prn "exc is:" exc) 7))) ;;;; +;;;; "exc is:" ["data" "foo"] ;;;;=>7 +;;;;=>7 + +;; +;; Testing try* without catch* +(try* xyz) +;/.*\'?xyz\'? not found.* + +;; +;; Testing throwing non-strings +(try* (throw (list 1 2 3)) (catch* exc (do (prn "err:" exc) 7))) +;/"err:" \(1 2 3\) +;=>7 + +;; +;; Testing dissoc +(def! hm3 (assoc hm2 "b" 2)) +(count (keys hm3)) +;=>2 +(count (vals hm3)) +;=>2 +(dissoc hm3 "a") +;=>{"b" 2} +(dissoc hm3 "a" "b") +;=>{} +(dissoc hm3 "a" "b" "c") +;=>{} +(count (keys hm3)) +;=>2 + +(dissoc {:cde 345 :fgh 456} :cde) +;=>{:fgh 456} +(dissoc {:cde nil :fgh 456} :cde) +;=>{:fgh 456} + +;; +;; Testing equality of hash-maps +(= {} {}) +;=>true +(= {} (hash-map)) +;=>true +(= {:a 11 :b 22} (hash-map :b 22 :a 11)) +;=>true +(= {:a 11 :b [22 33]} (hash-map :b [22 33] :a 11)) +;=>true +(= {:a 11 :b {:c 33}} (hash-map :b {:c 33} :a 11)) +;=>true +(= {:a 11 :b 22} (hash-map :b 23 :a 11)) +;=>false +(= {:a 11 :b 22} (hash-map :a 11)) +;=>false +(= {:a [11 22]} {:a (list 11 22)}) +;=>true +(= {:a 11 :b 22} (list :a 11 :b 22)) +;=>false +(= {} []) +;=>false +(= [] {}) +;=>false + +(keyword :abc) +;=>:abc +(keyword? (first (keys {":abc" 123 ":def" 456}))) +;=>false + +;; Testing that hashmaps don't alter function ast +(def! bar (fn* [a] {:foo (get a :foo)})) +(bar {:foo (fn* [x] x)}) +(bar {:foo 3}) ;; shouldn't give an error \ No newline at end of file diff --git a/impls/tests/stepA_mal.mal b/impls/tests/stepA_mal.mal index 465c8af796..e2d7f66647 100644 --- a/impls/tests/stepA_mal.mal +++ b/impls/tests/stepA_mal.mal @@ -1,300 +1,300 @@ -;;; -;;; See IMPL/tests/stepA_mal.mal for implementation specific -;;; interop tests. -;;; - - -;; -;; Testing readline -(readline "mal-user> ") -"hello" -;=>"\"hello\"" - -;; -;; Testing *host-language* -;;; each impl is different, but this should return false -;;; rather than throwing an exception -(= "something bogus" *host-language*) -;=>false - - -;>>> deferrable=True -;; -;; ------- Deferrable Functionality ---------- -;; ------- (Needed for self-hosting) ------- - -;; -;; -;; Testing hash-map evaluation and atoms (i.e. an env) -(def! e (atom {"+" +})) -(swap! e assoc "-" -) -( (get @e "+") 7 8) -;=>15 -( (get @e "-") 11 8) -;=>3 -(swap! e assoc "foo" (list)) -(get @e "foo") -;=>() -(swap! e assoc "bar" '(1 2 3)) -(get @e "bar") -;=>(1 2 3) - -;; Testing for presence of optional functions -(do (list time-ms string? number? seq conj meta with-meta fn?) nil) -;=>nil - -(map symbol? '(nil false true)) -;=>(false false false) - -;; ------------------------------------------------------------------ - -;>>> soft=True -;>>> optional=True -;; -;; ------- Optional Functionality -------------- -;; ------- (Not needed for self-hosting) ------- - -;; Testing metadata on functions - -;; -;; Testing metadata on mal functions - -(meta (fn* (a) a)) -;=>nil - -(meta (with-meta (fn* (a) a) {"b" 1})) -;=>{"b" 1} - -(meta (with-meta (fn* (a) a) "abc")) -;=>"abc" - -(def! l-wm (with-meta (fn* (a) a) {"b" 2})) -(meta l-wm) -;=>{"b" 2} - -(meta (with-meta l-wm {"new_meta" 123})) -;=>{"new_meta" 123} -(meta l-wm) -;=>{"b" 2} - -(def! f-wm (with-meta (fn* [a] (+ 1 a)) {"abc" 1})) -(meta f-wm) -;=>{"abc" 1} - -(meta (with-meta f-wm {"new_meta" 123})) -;=>{"new_meta" 123} -(meta f-wm) -;=>{"abc" 1} - -(def! f-wm2 ^{"abc" 1} (fn* [a] (+ 1 a))) -(meta f-wm2) -;=>{"abc" 1} - -;; Meta of native functions should return nil (not fail) -(meta +) -;=>nil - -;; -;; Make sure closures and metadata co-exist -(def! gen-plusX (fn* (x) (with-meta (fn* (b) (+ x b)) {"meta" 1}))) -(def! plus7 (gen-plusX 7)) -(def! plus8 (gen-plusX 8)) -(plus7 8) -;=>15 -(meta plus7) -;=>{"meta" 1} -(meta plus8) -;=>{"meta" 1} -(meta (with-meta plus7 {"meta" 2})) -;=>{"meta" 2} -(meta plus8) -;=>{"meta" 1} - -;; -;; Testing string? function -(string? "") -;=>true -(string? 'abc) -;=>false -(string? "abc") -;=>true -(string? :abc) -;=>false -(string? (keyword "abc")) -;=>false -(string? 234) -;=>false -(string? nil) -;=>false - -;; Testing number? function -(number? 123) -;=>true -(number? -1) -;=>true -(number? nil) -;=>false -(number? false) -;=>false -(number? "123") -;=>false - -(def! add1 (fn* (x) (+ x 1))) - -;; Testing fn? function -(fn? +) -;=>true -(fn? add1) -;=>true -(fn? cond) -;=>false -(fn? "+") -;=>false -(fn? :+) -;=>false -(fn? ^{"ismacro" true} (fn* () 0)) -;=>true - -;; Testing macro? function -(macro? cond) -;=>true -(macro? +) -;=>false -(macro? add1) -;=>false -(macro? "+") -;=>false -(macro? :+) -;=>false -(macro? {}) -;=>false - - -;; -;; Testing conj function -(conj (list) 1) -;=>(1) -(conj (list 1) 2) -;=>(2 1) -(conj (list 2 3) 4) -;=>(4 2 3) -(conj (list 2 3) 4 5 6) -;=>(6 5 4 2 3) -(conj (list 1) (list 2 3)) -;=>((2 3) 1) - -(conj [] 1) -;=>[1] -(conj [1] 2) -;=>[1 2] -(conj [2 3] 4) -;=>[2 3 4] -(conj [2 3] 4 5 6) -;=>[2 3 4 5 6] -(conj [1] [2 3]) -;=>[1 [2 3]] - -;; -;; Testing seq function -(seq "abc") -;=>("a" "b" "c") -(apply str (seq "this is a test")) -;=>"this is a test" -(seq '(2 3 4)) -;=>(2 3 4) -(seq [2 3 4]) -;=>(2 3 4) - -(seq "") -;=>nil -(seq '()) -;=>nil -(seq []) -;=>nil -(seq nil) -;=>nil - -;; -;; Testing metadata on collections - -(meta [1 2 3]) -;=>nil - -(with-meta [1 2 3] {"a" 1}) -;=>[1 2 3] - -(meta (with-meta [1 2 3] {"a" 1})) -;=>{"a" 1} - -(vector? (with-meta [1 2 3] {"a" 1})) -;=>true - -(meta (with-meta [1 2 3] "abc")) -;=>"abc" - -(with-meta [] "abc") -;=>[] - -(meta (with-meta (list 1 2 3) {"a" 1})) -;=>{"a" 1} - -(list? (with-meta (list 1 2 3) {"a" 1})) -;=>true - -(with-meta (list) {"a" 1}) -;=>() - -(empty? (with-meta (list) {"a" 1})) -;=>true - -(meta (with-meta {"abc" 123} {"a" 1})) -;=>{"a" 1} - -(map? (with-meta {"abc" 123} {"a" 1})) -;=>true - -(with-meta {} {"a" 1}) -;=>{} - -(def! l-wm (with-meta [4 5 6] {"b" 2})) -;=>[4 5 6] -(meta l-wm) -;=>{"b" 2} - -(meta (with-meta l-wm {"new_meta" 123})) -;=>{"new_meta" 123} -(meta l-wm) -;=>{"b" 2} - -;; -;; Testing metadata on builtin functions -(meta +) -;=>nil -(def! f-wm3 ^{"def" 2} +) -(meta f-wm3) -;=>{"def" 2} -(meta +) -;=>nil - -;; Loading sumdown from computations.mal -(load-file "../tests/computations.mal") -;=>nil - -;; -;; Testing time-ms function -(def! start-time (time-ms)) -(= start-time 0) -;=>false -(sumdown 10) ; Waste some time -;=>55 -(> (time-ms) start-time) -;=>true - -;; -;; Test that defining a macro does not mutate an existing function. -(def! f (fn* [x] (number? x))) -(defmacro! m f) -(f (+ 1 1)) -;=>true -(m (+ 1 1)) -;=>false +;;; +;;; See IMPL/tests/stepA_mal.mal for implementation specific +;;; interop tests. +;;; + + +;; +;; Testing readline +(readline "mal-user> ") +"hello" +;=>"\"hello\"" + +;; +;; Testing *host-language* +;;; each impl is different, but this should return false +;;; rather than throwing an exception +(= "something bogus" *host-language*) +;=>false + + +;>>> deferrable=True +;; +;; ------- Deferrable Functionality ---------- +;; ------- (Needed for self-hosting) ------- + +;; +;; +;; Testing hash-map evaluation and atoms (i.e. an env) +(def! e (atom {"+" +})) +(swap! e assoc "-" -) +( (get @e "+") 7 8) +;=>15 +( (get @e "-") 11 8) +;=>3 +(swap! e assoc "foo" (list)) +(get @e "foo") +;=>() +(swap! e assoc "bar" '(1 2 3)) +(get @e "bar") +;=>(1 2 3) + +;; Testing for presence of optional functions +(do (list time-ms string? number? seq conj meta with-meta fn?) nil) +;=>nil + +(map symbol? '(nil false true)) +;=>(false false false) + +;; ------------------------------------------------------------------ + +;>>> soft=True +;>>> optional=True +;; +;; ------- Optional Functionality -------------- +;; ------- (Not needed for self-hosting) ------- + +;; Testing metadata on functions + +;; +;; Testing metadata on mal functions + +(meta (fn* (a) a)) +;=>nil + +(meta (with-meta (fn* (a) a) {"b" 1})) +;=>{"b" 1} + +(meta (with-meta (fn* (a) a) "abc")) +;=>"abc" + +(def! l-wm (with-meta (fn* (a) a) {"b" 2})) +(meta l-wm) +;=>{"b" 2} + +(meta (with-meta l-wm {"new_meta" 123})) +;=>{"new_meta" 123} +(meta l-wm) +;=>{"b" 2} + +(def! f-wm (with-meta (fn* [a] (+ 1 a)) {"abc" 1})) +(meta f-wm) +;=>{"abc" 1} + +(meta (with-meta f-wm {"new_meta" 123})) +;=>{"new_meta" 123} +(meta f-wm) +;=>{"abc" 1} + +(def! f-wm2 ^{"abc" 1} (fn* [a] (+ 1 a))) +(meta f-wm2) +;=>{"abc" 1} + +;; Meta of native functions should return nil (not fail) +(meta +) +;=>nil + +;; +;; Make sure closures and metadata co-exist +(def! gen-plusX (fn* (x) (with-meta (fn* (b) (+ x b)) {"meta" 1}))) +(def! plus7 (gen-plusX 7)) +(def! plus8 (gen-plusX 8)) +(plus7 8) +;=>15 +(meta plus7) +;=>{"meta" 1} +(meta plus8) +;=>{"meta" 1} +(meta (with-meta plus7 {"meta" 2})) +;=>{"meta" 2} +(meta plus8) +;=>{"meta" 1} + +;; +;; Testing string? function +(string? "") +;=>true +(string? 'abc) +;=>false +(string? "abc") +;=>true +(string? :abc) +;=>false +(string? (keyword "abc")) +;=>false +(string? 234) +;=>false +(string? nil) +;=>false + +;; Testing number? function +(number? 123) +;=>true +(number? -1) +;=>true +(number? nil) +;=>false +(number? false) +;=>false +(number? "123") +;=>false + +(def! add1 (fn* (x) (+ x 1))) + +;; Testing fn? function +(fn? +) +;=>true +(fn? add1) +;=>true +(fn? cond) +;=>false +(fn? "+") +;=>false +(fn? :+) +;=>false +(fn? ^{"ismacro" true} (fn* () 0)) +;=>true + +;; Testing macro? function +(macro? cond) +;=>true +(macro? +) +;=>false +(macro? add1) +;=>false +(macro? "+") +;=>false +(macro? :+) +;=>false +(macro? {}) +;=>false + + +;; +;; Testing conj function +(conj (list) 1) +;=>(1) +(conj (list 1) 2) +;=>(2 1) +(conj (list 2 3) 4) +;=>(4 2 3) +(conj (list 2 3) 4 5 6) +;=>(6 5 4 2 3) +(conj (list 1) (list 2 3)) +;=>((2 3) 1) + +(conj [] 1) +;=>[1] +(conj [1] 2) +;=>[1 2] +(conj [2 3] 4) +;=>[2 3 4] +(conj [2 3] 4 5 6) +;=>[2 3 4 5 6] +(conj [1] [2 3]) +;=>[1 [2 3]] + +;; +;; Testing seq function +(seq "abc") +;=>("a" "b" "c") +(apply str (seq "this is a test")) +;=>"this is a test" +(seq '(2 3 4)) +;=>(2 3 4) +(seq [2 3 4]) +;=>(2 3 4) + +(seq "") +;=>nil +(seq '()) +;=>nil +(seq []) +;=>nil +(seq nil) +;=>nil + +;; +;; Testing metadata on collections + +(meta [1 2 3]) +;=>nil + +(with-meta [1 2 3] {"a" 1}) +;=>[1 2 3] + +(meta (with-meta [1 2 3] {"a" 1})) +;=>{"a" 1} + +(vector? (with-meta [1 2 3] {"a" 1})) +;=>true + +(meta (with-meta [1 2 3] "abc")) +;=>"abc" + +(with-meta [] "abc") +;=>[] + +(meta (with-meta (list 1 2 3) {"a" 1})) +;=>{"a" 1} + +(list? (with-meta (list 1 2 3) {"a" 1})) +;=>true + +(with-meta (list) {"a" 1}) +;=>() + +(empty? (with-meta (list) {"a" 1})) +;=>true + +(meta (with-meta {"abc" 123} {"a" 1})) +;=>{"a" 1} + +(map? (with-meta {"abc" 123} {"a" 1})) +;=>true + +(with-meta {} {"a" 1}) +;=>{} + +(def! l-wm (with-meta [4 5 6] {"b" 2})) +;=>[4 5 6] +(meta l-wm) +;=>{"b" 2} + +(meta (with-meta l-wm {"new_meta" 123})) +;=>{"new_meta" 123} +(meta l-wm) +;=>{"b" 2} + +;; +;; Testing metadata on builtin functions +(meta +) +;=>nil +(def! f-wm3 ^{"def" 2} +) +(meta f-wm3) +;=>{"def" 2} +(meta +) +;=>nil + +;; Loading sumdown from computations.mal +(load-file "../tests/computations.mal") +;=>nil + +;; +;; Testing time-ms function +(def! start-time (time-ms)) +(= start-time 0) +;=>false +(sumdown 10) ; Waste some time +;=>55 +(> (time-ms) start-time) +;=>true + +;; +;; Test that defining a macro does not mutate an existing function. +(def! f (fn* [x] (number? x))) +(defmacro! m f) +(f (+ 1 1)) +;=>true +(m (+ 1 1)) +;=>false diff --git a/impls/tests/test.txt b/impls/tests/test.txt index 0f24bc045a..92fdbfcfde 100644 --- a/impls/tests/test.txt +++ b/impls/tests/test.txt @@ -1 +1 @@ -A line of text +A line of text diff --git a/impls/tests/travis_trigger.sh b/impls/tests/travis_trigger.sh index 424f39508b..a3aa630b90 100755 --- a/impls/tests/travis_trigger.sh +++ b/impls/tests/travis_trigger.sh @@ -1,78 +1,78 @@ -#!/bin/bash - -# Reference: https://docs.travis-ci.com/user/triggering-builds/ - -set -e - -die() { echo "${*}"; exit 1; } -usage() { - [ "${*}" ] && echo >&2 -e "${*}\n" - echo "Usage: $0 REPO BRANCH [VAR=VAL]... - - Authorization: - - If you have the travis program installed then it will be called - to get an API token (you need to have done 'travis login --org' - in the past). Alternately you can explicity pass a token using - the TRAVIS_TOKEN environment variable. You can see your API - token at https://travis-ci.org/account/preferences. - - Travis .org vs .com: - - By default 'api.travis-ci.org' is used for API calls. This can - be overridden by setting TRAVIS_HOST="api.travis-ci.com" - - Examples: - - Trigger build/test in self-hosted mode: - $0 REPO BRANCH DO_SELF_HOST=1 - - Trigger build/test with stop on soft failures: - $0 REPO BRANCH DO_HARD=1 - - Trigger build/test using regress mode on stepA: - $0 REPO BRANCH REGRESS=1 STEP=stepA - - Trigger build/test using regress mode on all steps: - $0 REPO BRANCH REGRESS=1 - " | sed 's/^ //' >&2 - - exit 2 -} - -TRAVIS_TOKEN="${TRAVIS_TOKEN:-}" # default to travis program -TRAVIS_HOST="${TRAVIS_HOST:-api.travis-ci.org}" - -REPO="${1}"; shift || usage "REPO required" -BRANCH="${1}"; shift || usage "BRANCH required" -VARS="${*}" - -repo="${REPO/\//%2F}" -vars="" -[ "${VARS}" ] && vars="\"${VARS// /\", \"}\"" - -body="{ - \"request\": { - \"message\": \"Manual build. Settings: ${VARS}\", - \"branch\":\"${BRANCH}\", - \"config\": { - \"env\": { - \"global\": [${vars}] - } - } - } -}" - -if [ -z "${TRAVIS_TOKEN}" ]; then - which travis >/dev/null \ - || die "TRAVIS_TOKEN not set and travis command not found" - TRAVIS_TOKEN="$(travis token --org --no-interactive)" -fi - -curl -X POST \ - -H "Content-Type: application/json" \ - -H "Accept: application/json" \ - -H "Travis-API-Version: 3" \ - -H "Authorization: token ${TRAVIS_TOKEN}" \ - -d "$body" \ - "https://${TRAVIS_HOST}/repo/${repo}/requests" +#!/bin/bash + +# Reference: https://docs.travis-ci.com/user/triggering-builds/ + +set -e + +die() { echo "${*}"; exit 1; } +usage() { + [ "${*}" ] && echo >&2 -e "${*}\n" + echo "Usage: $0 REPO BRANCH [VAR=VAL]... + + Authorization: + + If you have the travis program installed then it will be called + to get an API token (you need to have done 'travis login --org' + in the past). Alternately you can explicity pass a token using + the TRAVIS_TOKEN environment variable. You can see your API + token at https://travis-ci.org/account/preferences. + + Travis .org vs .com: + + By default 'api.travis-ci.org' is used for API calls. This can + be overridden by setting TRAVIS_HOST="api.travis-ci.com" + + Examples: + + Trigger build/test in self-hosted mode: + $0 REPO BRANCH DO_SELF_HOST=1 + + Trigger build/test with stop on soft failures: + $0 REPO BRANCH DO_HARD=1 + + Trigger build/test using regress mode on stepA: + $0 REPO BRANCH REGRESS=1 STEP=stepA + + Trigger build/test using regress mode on all steps: + $0 REPO BRANCH REGRESS=1 + " | sed 's/^ //' >&2 + + exit 2 +} + +TRAVIS_TOKEN="${TRAVIS_TOKEN:-}" # default to travis program +TRAVIS_HOST="${TRAVIS_HOST:-api.travis-ci.org}" + +REPO="${1}"; shift || usage "REPO required" +BRANCH="${1}"; shift || usage "BRANCH required" +VARS="${*}" + +repo="${REPO/\//%2F}" +vars="" +[ "${VARS}" ] && vars="\"${VARS// /\", \"}\"" + +body="{ + \"request\": { + \"message\": \"Manual build. Settings: ${VARS}\", + \"branch\":\"${BRANCH}\", + \"config\": { + \"env\": { + \"global\": [${vars}] + } + } + } +}" + +if [ -z "${TRAVIS_TOKEN}" ]; then + which travis >/dev/null \ + || die "TRAVIS_TOKEN not set and travis command not found" + TRAVIS_TOKEN="$(travis token --org --no-interactive)" +fi + +curl -X POST \ + -H "Content-Type: application/json" \ + -H "Accept: application/json" \ + -H "Travis-API-Version: 3" \ + -H "Authorization: token ${TRAVIS_TOKEN}" \ + -d "$body" \ + "https://${TRAVIS_HOST}/repo/${repo}/requests" diff --git a/impls/ts/.gitignore b/impls/ts/.gitignore index 0aa7778c55..37c3f845b5 100644 --- a/impls/ts/.gitignore +++ b/impls/ts/.gitignore @@ -1,5 +1,5 @@ -node_modules/ - -npm-debug.log - -*.js +node_modules/ + +npm-debug.log + +*.js diff --git a/impls/ts/Dockerfile b/impls/ts/Dockerfile index ae21ee02cf..6d92b7597d 100644 --- a/impls/ts/Dockerfile +++ b/impls/ts/Dockerfile @@ -1,34 +1,34 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_12.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_12.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm diff --git a/impls/ts/Makefile b/impls/ts/Makefile index 1ea5a79e59..10e45056ae 100644 --- a/impls/ts/Makefile +++ b/impls/ts/Makefile @@ -1,19 +1,19 @@ -STEPS = step0_repl step1_read_print step2_eval step3_env \ - step4_if_fn_do step5_tco step6_file step7_quote \ - step8_macros step9_try stepA_mal - -all: ts - -node_modules: - npm install - -step%.js: node_modules types.ts reader.ts printer.ts env.ts core.ts step%.ts - ./node_modules/.bin/tsc -p ./ - - -.PHONY: ts clean - -ts: $(foreach s,$(STEPS),$(s).js) - -clean: - rm -f *.js +STEPS = step0_repl step1_read_print step2_eval step3_env \ + step4_if_fn_do step5_tco step6_file step7_quote \ + step8_macros step9_try stepA_mal + +all: ts + +node_modules: + npm install + +step%.js: node_modules types.ts reader.ts printer.ts env.ts core.ts step%.ts + ./node_modules/.bin/tsc -p ./ + + +.PHONY: ts clean + +ts: $(foreach s,$(STEPS),$(s).js) + +clean: + rm -f *.js diff --git a/impls/ts/core.ts b/impls/ts/core.ts index e8d7dd513e..092870d300 100644 --- a/impls/ts/core.ts +++ b/impls/ts/core.ts @@ -1,441 +1,441 @@ -import * as fs from "fs"; - -import { readline } from "./node_readline"; - -import { Node, MalType, MalSymbol, MalFunction, MalNil, MalList, MalVector, MalBoolean, MalNumber, MalString, MalKeyword, MalHashMap, MalAtom, equals, isSeq } from "./types"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -export const ns: Map = (() => { - const ns: { [symbol: string]: typeof MalFunction.prototype.func; } = { - "="(a: MalType, b: MalType): MalBoolean { - return new MalBoolean(equals(a, b)); - }, - throw(v: MalType): MalType { - throw v; - }, - - "nil?"(v: MalType) { - return new MalBoolean(v.type === Node.Nil); - }, - "true?"(v: MalType) { - return new MalBoolean(v.type === Node.Boolean && v.v); - }, - "false?"(v: MalType) { - return new MalBoolean(v.type === Node.Boolean && !v.v); - }, - "string?"(v: MalType) { - return new MalBoolean(v.type === Node.String); - }, - symbol(v: MalType) { - if (v.type !== Node.String) { - throw new Error(`unexpected symbol: ${v.type}, expected: string`); - } - return MalSymbol.get(v.v); - }, - "symbol?"(v: MalType) { - return new MalBoolean(v.type === Node.Symbol); - }, - keyword(v: MalType) { - if (v.type === Node.Keyword) { - return v; - } - if (v.type !== Node.String) { - throw new Error(`unexpected symbol: ${v.type}, expected: string`); - } - return MalKeyword.get(v.v); - }, - "keyword?"(v: MalType) { - return new MalBoolean(v.type === Node.Keyword); - }, - "number?"(v: MalType) { - return new MalBoolean(v.type === Node.Number); - }, - "fn?"(v: MalType) { - return new MalBoolean(v.type === Node.Function && !v.isMacro); - }, - "macro?"(v: MalType) { - return new MalBoolean(v.type === Node.Function && v.isMacro); - }, - - "pr-str"(...args: MalType[]): MalString { - return new MalString(args.map(v => prStr(v, true)).join(" ")); - }, - "str"(...args: MalType[]): MalString { - return new MalString(args.map(v => prStr(v, false)).join("")); - }, - prn(...args: MalType[]): MalNil { - const str = args.map(v => prStr(v, true)).join(" "); - console.log(str); - return MalNil.instance; - }, - println(...args: MalType[]): MalNil { - const str = args.map(v => prStr(v, false)).join(" "); - console.log(str); - return MalNil.instance; - }, - "read-string"(v: MalType) { - if (v.type !== Node.String) { - throw new Error(`unexpected symbol: ${v.type}, expected: string`); - } - return readStr(v.v); - }, - readline(v: MalType) { - if (v.type !== Node.String) { - throw new Error(`unexpected symbol: ${v.type}, expected: string`); - } - - const ret = readline(v.v); - if (ret == null) { - return MalNil.instance; - } - - return new MalString(ret); - }, - slurp(v: MalType) { - if (v.type !== Node.String) { - throw new Error(`unexpected symbol: ${v.type}, expected: string`); - } - const content = fs.readFileSync(v.v, "utf-8"); - return new MalString(content); - }, - - "<"(a: MalType, b: MalType): MalBoolean { - if (a.type !== Node.Number) { - throw new Error(`unexpected symbol: ${a.type}, expected: number`); - } - if (b.type !== Node.Number) { - throw new Error(`unexpected symbol: ${b.type}, expected: number`); - } - - return new MalBoolean(a.v < b.v); - }, - "<="(a: MalType, b: MalType): MalBoolean { - if (a.type !== Node.Number) { - throw new Error(`unexpected symbol: ${a.type}, expected: number`); - } - if (b.type !== Node.Number) { - throw new Error(`unexpected symbol: ${b.type}, expected: number`); - } - - return new MalBoolean(a.v <= b.v); - }, - ">"(a: MalType, b: MalType): MalBoolean { - if (a.type !== Node.Number) { - throw new Error(`unexpected symbol: ${a.type}, expected: number`); - } - if (b.type !== Node.Number) { - throw new Error(`unexpected symbol: ${b.type}, expected: number`); - } - - return new MalBoolean(a.v > b.v); - }, - ">="(a: MalType, b: MalType): MalBoolean { - if (a.type !== Node.Number) { - throw new Error(`unexpected symbol: ${a.type}, expected: number`); - } - if (b.type !== Node.Number) { - throw new Error(`unexpected symbol: ${b.type}, expected: number`); - } - - return new MalBoolean(a.v >= b.v); - }, - "+"(a: MalType, b: MalType): MalNumber { - if (a.type !== Node.Number) { - throw new Error(`unexpected symbol: ${a.type}, expected: number`); - } - if (b.type !== Node.Number) { - throw new Error(`unexpected symbol: ${b.type}, expected: number`); - } - - return new MalNumber(a.v + b.v); - }, - "-"(a: MalType, b: MalType): MalNumber { - if (a.type !== Node.Number) { - throw new Error(`unexpected symbol: ${a.type}, expected: number`); - } - if (b.type !== Node.Number) { - throw new Error(`unexpected symbol: ${b.type}, expected: number`); - } - - return new MalNumber(a.v - b.v); - }, - "*"(a: MalType, b: MalType): MalNumber { - if (a.type !== Node.Number) { - throw new Error(`unexpected symbol: ${a.type}, expected: number`); - } - if (b.type !== Node.Number) { - throw new Error(`unexpected symbol: ${b.type}, expected: number`); - } - - return new MalNumber(a.v * b.v); - }, - "/"(a: MalType, b: MalType): MalNumber { - if (a.type !== Node.Number) { - throw new Error(`unexpected symbol: ${a.type}, expected: number`); - } - if (b.type !== Node.Number) { - throw new Error(`unexpected symbol: ${b.type}, expected: number`); - } - - return new MalNumber(a.v / b.v); - }, - "time-ms"() { - return new MalNumber(Date.now()); - }, - - list(...args: MalType[]): MalList { - return new MalList(args); - }, - "list?"(v: MalType): MalBoolean { - return new MalBoolean(v.type === Node.List); - }, - vector(...args: MalType[]): MalVector { - return new MalVector(args); - }, - "vector?"(v: MalType): MalBoolean { - return new MalBoolean(v.type === Node.Vector); - }, - "hash-map"(...args: MalType[]) { - return new MalHashMap(args); - }, - "map?"(v: MalType): MalBoolean { - return new MalBoolean(v.type === Node.HashMap); - }, - assoc(v: MalType, ...args: MalType[]) { - if (v.type !== Node.HashMap) { - throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); - } - return v.assoc(args); - }, - dissoc(v: MalType, ...args: MalType[]) { - if (v.type !== Node.HashMap) { - throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); - } - return v.dissoc(args); - }, - get(v: MalType, key: MalType) { - if (v.type === Node.Nil) { - return MalNil.instance; - } - if (v.type !== Node.HashMap) { - throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); - } - if (key.type !== Node.String && key.type !== Node.Keyword) { - throw new Error(`unexpected symbol: ${key.type}, expected: string or keyword`); - } - - return v.get(key) || MalNil.instance; - }, - "contains?"(v: MalType, key: MalType) { - if (v.type === Node.Nil) { - return MalNil.instance; - } - if (v.type !== Node.HashMap) { - throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); - } - if (key.type !== Node.String && key.type !== Node.Keyword) { - throw new Error(`unexpected symbol: ${key.type}, expected: string or keyword`); - } - - return new MalBoolean(v.has(key)); - }, - keys(v: MalType) { - if (v.type !== Node.HashMap) { - throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); - } - - return new MalList([...v.keys()]); - }, - vals(v: MalType) { - if (v.type !== Node.HashMap) { - throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); - } - - return new MalList([...v.vals()]); - }, - - "sequential?"(v: MalType) { - return new MalBoolean(isSeq(v)); - }, - cons(a: MalType, b: MalType) { - if (!isSeq(b)) { - throw new Error(`unexpected symbol: ${b.type}, expected: list or vector`); - } - - return new MalList([a].concat(b.list)); - }, - concat(...args: MalType[]) { - const list = args - .map(arg => { - if (!isSeq(arg)) { - throw new Error(`unexpected symbol: ${arg.type}, expected: list or vector`); - } - return arg; - }) - .reduce((p, c) => p.concat(c.list), [] as MalType[]); - - return new MalList(list); - }, - vec(a: MalType) { - switch (a.type) { - case Node.List: - return new MalVector(a.list); - case Node.Vector: - return a; - } - throw new Error(`unexpected symbol: ${a.type}, expected: list or vector`); - }, - - nth(list: MalType, idx: MalType) { - if (!isSeq(list)) { - throw new Error(`unexpected symbol: ${list.type}, expected: list or vector`); - } - if (idx.type !== Node.Number) { - throw new Error(`unexpected symbol: ${idx.type}, expected: number`); - } - - const v = list.list[idx.v]; - if (!v) { - throw new Error("nth: index out of range"); - } - - return v; - }, - first(v: MalType) { - if (v.type === Node.Nil) { - return MalNil.instance; - } - if (!isSeq(v)) { - throw new Error(`unexpected symbol: ${v.type}, expected: list or vector`); - } - - return v.list[0] || MalNil.instance; - }, - rest(v: MalType) { - if (v.type === Node.Nil) { - return new MalList([]); - } - if (!isSeq(v)) { - throw new Error(`unexpected symbol: ${v.type}, expected: list or vector`); - } - - return new MalList(v.list.slice(1)); - }, - "empty?"(v: MalType): MalBoolean { - if (!isSeq(v)) { - return new MalBoolean(false); - } - return new MalBoolean(v.list.length === 0); - }, - count(v: MalType): MalNumber { - if (isSeq(v)) { - return new MalNumber(v.list.length); - } - if (v.type === Node.Nil) { - return new MalNumber(0); - } - throw new Error(`unexpected symbol: ${v.type}`); - }, - apply(f: MalType, ...list: MalType[]) { - if (f.type !== Node.Function) { - throw new Error(`unexpected symbol: ${f.type}, expected: function`); - } - - const tail = list[list.length - 1]; - if (!isSeq(tail)) { - throw new Error(`unexpected symbol: ${tail.type}, expected: list or vector`); - } - const args = list.slice(0, -1).concat(tail.list); - return f.func(...args); - }, - map(f: MalType, list: MalType) { - if (f.type !== Node.Function) { - throw new Error(`unexpected symbol: ${f.type}, expected: function`); - } - if (!isSeq(list)) { - throw new Error(`unexpected symbol: ${list.type}, expected: list or vector`); - } - - return new MalList(list.list.map(v => f.func(v))); - }, - - conj(list: MalType, ...args: MalType[]) { - switch (list.type) { - case Node.List: - const newList = new MalList(list.list); - args.forEach(arg => newList.list.unshift(arg)); - return newList; - case Node.Vector: - return new MalVector([...list.list, ...args]); - } - - throw new Error(`unexpected symbol: ${list.type}, expected: list or vector`); - }, - seq(v: MalType) { - if (v.type === Node.List) { - if (v.list.length === 0) { - return MalNil.instance; - } - return v; - } - if (v.type === Node.Vector) { - if (v.list.length === 0) { - return MalNil.instance; - } - return new MalList(v.list); - } - if (v.type === Node.String) { - if (v.v.length === 0) { - return MalNil.instance; - } - return new MalList(v.v.split("").map(s => new MalString(s))); - } - if (v.type === Node.Nil) { - return MalNil.instance; - } - - throw new Error(`unexpected symbol: ${v.type}, expected: list or vector or string`); - }, - - meta(v: MalType) { - return v.meta || MalNil.instance; - }, - "with-meta"(v: MalType, m: MalType) { - return v.withMeta(m); - }, - atom(v: MalType): MalAtom { - return new MalAtom(v); - }, - "atom?"(v: MalType): MalBoolean { - return new MalBoolean(v.type === Node.Atom); - }, - deref(v: MalType): MalType { - if (v.type !== Node.Atom) { - throw new Error(`unexpected symbol: ${v.type}, expected: atom`); - } - return v.v; - }, - "reset!"(atom: MalType, v: MalType): MalType { - if (atom.type !== Node.Atom) { - throw new Error(`unexpected symbol: ${atom.type}, expected: atom`); - } - atom.v = v; - return v; - }, - "swap!"(atom: MalType, f: MalType, ...args: MalType[]): MalType { - if (atom.type !== Node.Atom) { - throw new Error(`unexpected symbol: ${atom.type}, expected: atom`); - } - if (f.type !== Node.Function) { - throw new Error(`unexpected symbol: ${f.type}, expected: function`); - } - atom.v = f.func(...[atom.v].concat(args)); - return atom.v; - }, - }; - - const map = new Map(); - Object.keys(ns).forEach(key => map.set(MalSymbol.get(key), MalFunction.fromBootstrap(ns[key]))); - return map; -})(); +import * as fs from "fs"; + +import { readline } from "./node_readline"; + +import { Node, MalType, MalSymbol, MalFunction, MalNil, MalList, MalVector, MalBoolean, MalNumber, MalString, MalKeyword, MalHashMap, MalAtom, equals, isSeq } from "./types"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +export const ns: Map = (() => { + const ns: { [symbol: string]: typeof MalFunction.prototype.func; } = { + "="(a: MalType, b: MalType): MalBoolean { + return new MalBoolean(equals(a, b)); + }, + throw(v: MalType): MalType { + throw v; + }, + + "nil?"(v: MalType) { + return new MalBoolean(v.type === Node.Nil); + }, + "true?"(v: MalType) { + return new MalBoolean(v.type === Node.Boolean && v.v); + }, + "false?"(v: MalType) { + return new MalBoolean(v.type === Node.Boolean && !v.v); + }, + "string?"(v: MalType) { + return new MalBoolean(v.type === Node.String); + }, + symbol(v: MalType) { + if (v.type !== Node.String) { + throw new Error(`unexpected symbol: ${v.type}, expected: string`); + } + return MalSymbol.get(v.v); + }, + "symbol?"(v: MalType) { + return new MalBoolean(v.type === Node.Symbol); + }, + keyword(v: MalType) { + if (v.type === Node.Keyword) { + return v; + } + if (v.type !== Node.String) { + throw new Error(`unexpected symbol: ${v.type}, expected: string`); + } + return MalKeyword.get(v.v); + }, + "keyword?"(v: MalType) { + return new MalBoolean(v.type === Node.Keyword); + }, + "number?"(v: MalType) { + return new MalBoolean(v.type === Node.Number); + }, + "fn?"(v: MalType) { + return new MalBoolean(v.type === Node.Function && !v.isMacro); + }, + "macro?"(v: MalType) { + return new MalBoolean(v.type === Node.Function && v.isMacro); + }, + + "pr-str"(...args: MalType[]): MalString { + return new MalString(args.map(v => prStr(v, true)).join(" ")); + }, + "str"(...args: MalType[]): MalString { + return new MalString(args.map(v => prStr(v, false)).join("")); + }, + prn(...args: MalType[]): MalNil { + const str = args.map(v => prStr(v, true)).join(" "); + console.log(str); + return MalNil.instance; + }, + println(...args: MalType[]): MalNil { + const str = args.map(v => prStr(v, false)).join(" "); + console.log(str); + return MalNil.instance; + }, + "read-string"(v: MalType) { + if (v.type !== Node.String) { + throw new Error(`unexpected symbol: ${v.type}, expected: string`); + } + return readStr(v.v); + }, + readline(v: MalType) { + if (v.type !== Node.String) { + throw new Error(`unexpected symbol: ${v.type}, expected: string`); + } + + const ret = readline(v.v); + if (ret == null) { + return MalNil.instance; + } + + return new MalString(ret); + }, + slurp(v: MalType) { + if (v.type !== Node.String) { + throw new Error(`unexpected symbol: ${v.type}, expected: string`); + } + const content = fs.readFileSync(v.v, "utf-8"); + return new MalString(content); + }, + + "<"(a: MalType, b: MalType): MalBoolean { + if (a.type !== Node.Number) { + throw new Error(`unexpected symbol: ${a.type}, expected: number`); + } + if (b.type !== Node.Number) { + throw new Error(`unexpected symbol: ${b.type}, expected: number`); + } + + return new MalBoolean(a.v < b.v); + }, + "<="(a: MalType, b: MalType): MalBoolean { + if (a.type !== Node.Number) { + throw new Error(`unexpected symbol: ${a.type}, expected: number`); + } + if (b.type !== Node.Number) { + throw new Error(`unexpected symbol: ${b.type}, expected: number`); + } + + return new MalBoolean(a.v <= b.v); + }, + ">"(a: MalType, b: MalType): MalBoolean { + if (a.type !== Node.Number) { + throw new Error(`unexpected symbol: ${a.type}, expected: number`); + } + if (b.type !== Node.Number) { + throw new Error(`unexpected symbol: ${b.type}, expected: number`); + } + + return new MalBoolean(a.v > b.v); + }, + ">="(a: MalType, b: MalType): MalBoolean { + if (a.type !== Node.Number) { + throw new Error(`unexpected symbol: ${a.type}, expected: number`); + } + if (b.type !== Node.Number) { + throw new Error(`unexpected symbol: ${b.type}, expected: number`); + } + + return new MalBoolean(a.v >= b.v); + }, + "+"(a: MalType, b: MalType): MalNumber { + if (a.type !== Node.Number) { + throw new Error(`unexpected symbol: ${a.type}, expected: number`); + } + if (b.type !== Node.Number) { + throw new Error(`unexpected symbol: ${b.type}, expected: number`); + } + + return new MalNumber(a.v + b.v); + }, + "-"(a: MalType, b: MalType): MalNumber { + if (a.type !== Node.Number) { + throw new Error(`unexpected symbol: ${a.type}, expected: number`); + } + if (b.type !== Node.Number) { + throw new Error(`unexpected symbol: ${b.type}, expected: number`); + } + + return new MalNumber(a.v - b.v); + }, + "*"(a: MalType, b: MalType): MalNumber { + if (a.type !== Node.Number) { + throw new Error(`unexpected symbol: ${a.type}, expected: number`); + } + if (b.type !== Node.Number) { + throw new Error(`unexpected symbol: ${b.type}, expected: number`); + } + + return new MalNumber(a.v * b.v); + }, + "/"(a: MalType, b: MalType): MalNumber { + if (a.type !== Node.Number) { + throw new Error(`unexpected symbol: ${a.type}, expected: number`); + } + if (b.type !== Node.Number) { + throw new Error(`unexpected symbol: ${b.type}, expected: number`); + } + + return new MalNumber(a.v / b.v); + }, + "time-ms"() { + return new MalNumber(Date.now()); + }, + + list(...args: MalType[]): MalList { + return new MalList(args); + }, + "list?"(v: MalType): MalBoolean { + return new MalBoolean(v.type === Node.List); + }, + vector(...args: MalType[]): MalVector { + return new MalVector(args); + }, + "vector?"(v: MalType): MalBoolean { + return new MalBoolean(v.type === Node.Vector); + }, + "hash-map"(...args: MalType[]) { + return new MalHashMap(args); + }, + "map?"(v: MalType): MalBoolean { + return new MalBoolean(v.type === Node.HashMap); + }, + assoc(v: MalType, ...args: MalType[]) { + if (v.type !== Node.HashMap) { + throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); + } + return v.assoc(args); + }, + dissoc(v: MalType, ...args: MalType[]) { + if (v.type !== Node.HashMap) { + throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); + } + return v.dissoc(args); + }, + get(v: MalType, key: MalType) { + if (v.type === Node.Nil) { + return MalNil.instance; + } + if (v.type !== Node.HashMap) { + throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); + } + if (key.type !== Node.String && key.type !== Node.Keyword) { + throw new Error(`unexpected symbol: ${key.type}, expected: string or keyword`); + } + + return v.get(key) || MalNil.instance; + }, + "contains?"(v: MalType, key: MalType) { + if (v.type === Node.Nil) { + return MalNil.instance; + } + if (v.type !== Node.HashMap) { + throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); + } + if (key.type !== Node.String && key.type !== Node.Keyword) { + throw new Error(`unexpected symbol: ${key.type}, expected: string or keyword`); + } + + return new MalBoolean(v.has(key)); + }, + keys(v: MalType) { + if (v.type !== Node.HashMap) { + throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); + } + + return new MalList([...v.keys()]); + }, + vals(v: MalType) { + if (v.type !== Node.HashMap) { + throw new Error(`unexpected symbol: ${v.type}, expected: hash-map`); + } + + return new MalList([...v.vals()]); + }, + + "sequential?"(v: MalType) { + return new MalBoolean(isSeq(v)); + }, + cons(a: MalType, b: MalType) { + if (!isSeq(b)) { + throw new Error(`unexpected symbol: ${b.type}, expected: list or vector`); + } + + return new MalList([a].concat(b.list)); + }, + concat(...args: MalType[]) { + const list = args + .map(arg => { + if (!isSeq(arg)) { + throw new Error(`unexpected symbol: ${arg.type}, expected: list or vector`); + } + return arg; + }) + .reduce((p, c) => p.concat(c.list), [] as MalType[]); + + return new MalList(list); + }, + vec(a: MalType) { + switch (a.type) { + case Node.List: + return new MalVector(a.list); + case Node.Vector: + return a; + } + throw new Error(`unexpected symbol: ${a.type}, expected: list or vector`); + }, + + nth(list: MalType, idx: MalType) { + if (!isSeq(list)) { + throw new Error(`unexpected symbol: ${list.type}, expected: list or vector`); + } + if (idx.type !== Node.Number) { + throw new Error(`unexpected symbol: ${idx.type}, expected: number`); + } + + const v = list.list[idx.v]; + if (!v) { + throw new Error("nth: index out of range"); + } + + return v; + }, + first(v: MalType) { + if (v.type === Node.Nil) { + return MalNil.instance; + } + if (!isSeq(v)) { + throw new Error(`unexpected symbol: ${v.type}, expected: list or vector`); + } + + return v.list[0] || MalNil.instance; + }, + rest(v: MalType) { + if (v.type === Node.Nil) { + return new MalList([]); + } + if (!isSeq(v)) { + throw new Error(`unexpected symbol: ${v.type}, expected: list or vector`); + } + + return new MalList(v.list.slice(1)); + }, + "empty?"(v: MalType): MalBoolean { + if (!isSeq(v)) { + return new MalBoolean(false); + } + return new MalBoolean(v.list.length === 0); + }, + count(v: MalType): MalNumber { + if (isSeq(v)) { + return new MalNumber(v.list.length); + } + if (v.type === Node.Nil) { + return new MalNumber(0); + } + throw new Error(`unexpected symbol: ${v.type}`); + }, + apply(f: MalType, ...list: MalType[]) { + if (f.type !== Node.Function) { + throw new Error(`unexpected symbol: ${f.type}, expected: function`); + } + + const tail = list[list.length - 1]; + if (!isSeq(tail)) { + throw new Error(`unexpected symbol: ${tail.type}, expected: list or vector`); + } + const args = list.slice(0, -1).concat(tail.list); + return f.func(...args); + }, + map(f: MalType, list: MalType) { + if (f.type !== Node.Function) { + throw new Error(`unexpected symbol: ${f.type}, expected: function`); + } + if (!isSeq(list)) { + throw new Error(`unexpected symbol: ${list.type}, expected: list or vector`); + } + + return new MalList(list.list.map(v => f.func(v))); + }, + + conj(list: MalType, ...args: MalType[]) { + switch (list.type) { + case Node.List: + const newList = new MalList(list.list); + args.forEach(arg => newList.list.unshift(arg)); + return newList; + case Node.Vector: + return new MalVector([...list.list, ...args]); + } + + throw new Error(`unexpected symbol: ${list.type}, expected: list or vector`); + }, + seq(v: MalType) { + if (v.type === Node.List) { + if (v.list.length === 0) { + return MalNil.instance; + } + return v; + } + if (v.type === Node.Vector) { + if (v.list.length === 0) { + return MalNil.instance; + } + return new MalList(v.list); + } + if (v.type === Node.String) { + if (v.v.length === 0) { + return MalNil.instance; + } + return new MalList(v.v.split("").map(s => new MalString(s))); + } + if (v.type === Node.Nil) { + return MalNil.instance; + } + + throw new Error(`unexpected symbol: ${v.type}, expected: list or vector or string`); + }, + + meta(v: MalType) { + return v.meta || MalNil.instance; + }, + "with-meta"(v: MalType, m: MalType) { + return v.withMeta(m); + }, + atom(v: MalType): MalAtom { + return new MalAtom(v); + }, + "atom?"(v: MalType): MalBoolean { + return new MalBoolean(v.type === Node.Atom); + }, + deref(v: MalType): MalType { + if (v.type !== Node.Atom) { + throw new Error(`unexpected symbol: ${v.type}, expected: atom`); + } + return v.v; + }, + "reset!"(atom: MalType, v: MalType): MalType { + if (atom.type !== Node.Atom) { + throw new Error(`unexpected symbol: ${atom.type}, expected: atom`); + } + atom.v = v; + return v; + }, + "swap!"(atom: MalType, f: MalType, ...args: MalType[]): MalType { + if (atom.type !== Node.Atom) { + throw new Error(`unexpected symbol: ${atom.type}, expected: atom`); + } + if (f.type !== Node.Function) { + throw new Error(`unexpected symbol: ${f.type}, expected: function`); + } + atom.v = f.func(...[atom.v].concat(args)); + return atom.v; + }, + }; + + const map = new Map(); + Object.keys(ns).forEach(key => map.set(MalSymbol.get(key), MalFunction.fromBootstrap(ns[key]))); + return map; +})(); diff --git a/impls/ts/env.ts b/impls/ts/env.ts index 91f87838aa..b4463bf8fb 100644 --- a/impls/ts/env.ts +++ b/impls/ts/env.ts @@ -1,48 +1,48 @@ -import { MalType, MalSymbol, MalList } from "./types"; - -export class Env { - data: Map; - - constructor(public outer?: Env, binds: MalSymbol[] = [], exprts: MalType[] = []) { - this.data = new Map(); - - for (let i = 0; i < binds.length; i++) { - const bind = binds[i]; - if (bind.v === "&") { - this.set(binds[i + 1], new MalList(exprts.slice(i))); - break; - } - this.set(bind, exprts[i]); - } - } - - set(key: MalSymbol, value: MalType): MalType { - this.data.set(key, value); - return value; - } - - find(key: MalSymbol): Env | undefined { - if (this.data.has(key)) { - return this; - } - if (this.outer) { - return this.outer.find(key); - } - - return void 0; - } - - get(key: MalSymbol): MalType { - const env = this.find(key); - if (!env) { - throw new Error(`'${key.v}' not found`); - } - - const v = env.data.get(key); - if (!v) { - throw new Error(`'${key.v}' not found`); - } - - return v; - } -} +import { MalType, MalSymbol, MalList } from "./types"; + +export class Env { + data: Map; + + constructor(public outer?: Env, binds: MalSymbol[] = [], exprts: MalType[] = []) { + this.data = new Map(); + + for (let i = 0; i < binds.length; i++) { + const bind = binds[i]; + if (bind.v === "&") { + this.set(binds[i + 1], new MalList(exprts.slice(i))); + break; + } + this.set(bind, exprts[i]); + } + } + + set(key: MalSymbol, value: MalType): MalType { + this.data.set(key, value); + return value; + } + + find(key: MalSymbol): Env | undefined { + if (this.data.has(key)) { + return this; + } + if (this.outer) { + return this.outer.find(key); + } + + return void 0; + } + + get(key: MalSymbol): MalType { + const env = this.find(key); + if (!env) { + throw new Error(`'${key.v}' not found`); + } + + const v = env.data.get(key); + if (!v) { + throw new Error(`'${key.v}' not found`); + } + + return v; + } +} diff --git a/impls/ts/node_readline.ts b/impls/ts/node_readline.ts index 6018c92cec..0d39494c8b 100644 --- a/impls/ts/node_readline.ts +++ b/impls/ts/node_readline.ts @@ -1,45 +1,45 @@ -import * as path from "path"; -import * as ffi from "ffi-napi"; -import * as fs from "fs"; - -// IMPORTANT: choose one -const RL_LIB = "libreadline"; // NOTE: libreadline is GPL -// var RL_LIB = "libedit"; - -const HISTORY_FILE = path.join(process.env.HOME || ".", ".mal-history"); - -const rllib = ffi.Library(RL_LIB, { - "readline": ["string", ["string"]], - "add_history": ["int", ["string"]], -}); - -let rlHistoryLoaded = false; - -export function readline(prompt?: string): string | null { - prompt = prompt || "user> "; - - if (!rlHistoryLoaded) { - rlHistoryLoaded = true; - let lines: string[] = []; - if (fs.existsSync(HISTORY_FILE)) { - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - } - // Max of 2000 lines - lines = lines.slice(Math.max(lines.length - 2000, 0)); - for (let i = 0; i < lines.length; i++) { - if (lines[i]) { rllib.add_history(lines[i]); } - } - } - - const line = rllib.readline(prompt); - if (line) { - rllib.add_history(line); - try { - fs.appendFileSync(HISTORY_FILE, line + "\n"); - } catch (exc) { - // ignored - } - } - - return line; -}; +import * as path from "path"; +import * as ffi from "ffi-napi"; +import * as fs from "fs"; + +// IMPORTANT: choose one +const RL_LIB = "libreadline"; // NOTE: libreadline is GPL +// var RL_LIB = "libedit"; + +const HISTORY_FILE = path.join(process.env.HOME || ".", ".mal-history"); + +const rllib = ffi.Library(RL_LIB, { + "readline": ["string", ["string"]], + "add_history": ["int", ["string"]], +}); + +let rlHistoryLoaded = false; + +export function readline(prompt?: string): string | null { + prompt = prompt || "user> "; + + if (!rlHistoryLoaded) { + rlHistoryLoaded = true; + let lines: string[] = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (let i = 0; i < lines.length; i++) { + if (lines[i]) { rllib.add_history(lines[i]); } + } + } + + const line = rllib.readline(prompt); + if (line) { + rllib.add_history(line); + try { + fs.appendFileSync(HISTORY_FILE, line + "\n"); + } catch (exc) { + // ignored + } + } + + return line; +}; diff --git a/impls/ts/package.json b/impls/ts/package.json index 09c1d83476..735301f568 100644 --- a/impls/ts/package.json +++ b/impls/ts/package.json @@ -1,30 +1,30 @@ -{ - "name": "mal", - "private": true, - "version": "1.0.0", - "description": "Make a Lisp (mal) language implemented in TypeScript", - "scripts": { - "build": "tsfmt -r && tsc -p ./", - "test": "npm run build && npm run test:step0 && npm run test:step1 && npm run test:step2 && npm run test:step3 && npm run test:step4 && npm run test:step5 && npm run test:step6 && npm run test:step7 && npm run test:step8 && npm run test:step9 && npm run test:stepA", - "test:step0": "cd .. && make 'test^ts^step0'", - "test:step1": "cd .. && make 'test^ts^step1'", - "test:step2": "cd .. && make 'test^ts^step2'", - "test:step3": "cd .. && make 'test^ts^step3'", - "test:step4": "cd .. && make 'test^ts^step4'", - "test:step5": "cd .. && make 'test^ts^step5'", - "test:step6": "cd .. && make 'test^ts^step6'", - "test:step7": "cd .. && make 'test^ts^step7'", - "test:step8": "cd .. && make 'test^ts^step8'", - "test:step9": "cd .. && make 'test^ts^step9'", - "test:stepA": "cd .. && make 'test^ts^stepA'" - }, - "dependencies": { - "ffi-napi": "^2.4.0" - }, - "devDependencies": { - "@types/ffi-napi": "4.0.4", - "@types/node": "^14.14.3", - "typescript": "^4.3.5", - "typescript-formatter": "^7.2.2" - } -} +{ + "name": "mal", + "private": true, + "version": "1.0.0", + "description": "Make a Lisp (mal) language implemented in TypeScript", + "scripts": { + "build": "tsfmt -r && tsc -p ./", + "test": "npm run build && npm run test:step0 && npm run test:step1 && npm run test:step2 && npm run test:step3 && npm run test:step4 && npm run test:step5 && npm run test:step6 && npm run test:step7 && npm run test:step8 && npm run test:step9 && npm run test:stepA", + "test:step0": "cd .. && make 'test^ts^step0'", + "test:step1": "cd .. && make 'test^ts^step1'", + "test:step2": "cd .. && make 'test^ts^step2'", + "test:step3": "cd .. && make 'test^ts^step3'", + "test:step4": "cd .. && make 'test^ts^step4'", + "test:step5": "cd .. && make 'test^ts^step5'", + "test:step6": "cd .. && make 'test^ts^step6'", + "test:step7": "cd .. && make 'test^ts^step7'", + "test:step8": "cd .. && make 'test^ts^step8'", + "test:step9": "cd .. && make 'test^ts^step9'", + "test:stepA": "cd .. && make 'test^ts^stepA'" + }, + "dependencies": { + "ffi-napi": "^2.4.0" + }, + "devDependencies": { + "@types/ffi-napi": "4.0.4", + "@types/node": "^14.14.3", + "typescript": "^4.3.5", + "typescript-formatter": "^7.2.2" + } +} diff --git a/impls/ts/printer.ts b/impls/ts/printer.ts index f1806c3272..4c5589472f 100644 --- a/impls/ts/printer.ts +++ b/impls/ts/printer.ts @@ -1,42 +1,42 @@ -import { Node, MalType } from "./types"; - -export function prStr(v: MalType, printReadably = true): string { - switch (v.type) { - case Node.List: - return `(${v.list.map(v => prStr(v, printReadably)).join(" ")})`; - case Node.Vector: - return `[${v.list.map(v => prStr(v, printReadably)).join(" ")}]`; - case Node.HashMap: - let result = "{"; - for (const [key, value] of v.entries()) { - if (result !== "{") { - result += " "; - } - result += `${prStr(key, printReadably)} ${prStr(value, printReadably)}`; - } - result += "}"; - return result; - case Node.Number: - case Node.Symbol: - case Node.Boolean: - return `${v.v}`; - case Node.String: - if (printReadably) { - const str = v.v - .replace(/\\/g, "\\\\") - .replace(/"/g, '\\"') - .replace(/\n/g, "\\n"); - return `"${str}"`; - } else { - return v.v; - } - case Node.Nil: - return "nil"; - case Node.Keyword: - return `:${v.v}`; - case Node.Function: - return "#"; - case Node.Atom: - return `(atom ${prStr(v.v, printReadably)})`; - } -} +import { Node, MalType } from "./types"; + +export function prStr(v: MalType, printReadably = true): string { + switch (v.type) { + case Node.List: + return `(${v.list.map(v => prStr(v, printReadably)).join(" ")})`; + case Node.Vector: + return `[${v.list.map(v => prStr(v, printReadably)).join(" ")}]`; + case Node.HashMap: + let result = "{"; + for (const [key, value] of v.entries()) { + if (result !== "{") { + result += " "; + } + result += `${prStr(key, printReadably)} ${prStr(value, printReadably)}`; + } + result += "}"; + return result; + case Node.Number: + case Node.Symbol: + case Node.Boolean: + return `${v.v}`; + case Node.String: + if (printReadably) { + const str = v.v + .replace(/\\/g, "\\\\") + .replace(/"/g, '\\"') + .replace(/\n/g, "\\n"); + return `"${str}"`; + } else { + return v.v; + } + case Node.Nil: + return "nil"; + case Node.Keyword: + return `:${v.v}`; + case Node.Function: + return "#"; + case Node.Atom: + return `(atom ${prStr(v.v, printReadably)})`; + } +} diff --git a/impls/ts/reader.ts b/impls/ts/reader.ts index 24fc24de93..afc851ff59 100644 --- a/impls/ts/reader.ts +++ b/impls/ts/reader.ts @@ -1,146 +1,146 @@ -import { MalType, MalList, MalString, MalNumber, MalBoolean, MalNil, MalKeyword, MalSymbol, MalVector, MalHashMap } from "./types"; - -class Reader { - position = 0; - - constructor(private tokens: string[]) { } - - next(): string { - const ret = this.peek(); - this.position += 1; - return ret; - } - - peek(): string { - return this.tokens[this.position]; - } -} - -export function readStr(input: string): MalType { - const tokens = tokenizer(input); - const reader = new Reader(tokens); - return readForm(reader); -} - -function tokenizer(input: string): string[] { - const regexp = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; - const tokens: string[] = []; - while (true) { - const matches = regexp.exec(input); - if (!matches) { - break; - } - const match = matches[1]; - if (match === "") { - break; - } - if (match[0] !== ";") { - tokens.push(match); - } - } - - return tokens; -} - -function readForm(reader: Reader): MalType { - const token = reader.peek(); - switch (token) { - case "(": - return readList(reader); - case "[": - return readVector(reader); - case "{": - return readHashMap(reader); - case "'": - return readSymbol("quote"); - case "`": - return readSymbol("quasiquote"); - case "~": - return readSymbol("unquote"); - case "~@": - return readSymbol("splice-unquote"); - case "@": - return readSymbol("deref"); - case "^": - { - reader.next(); - const sym = MalSymbol.get("with-meta"); - const target = readForm(reader); - return new MalList([sym, readForm(reader), target]); - } - default: - return readAtom(reader); - } - - function readSymbol(name: string) { - reader.next(); - const sym = MalSymbol.get(name); - const target = readForm(reader); - return new MalList([sym, target]); - } -} - -function readList(reader: Reader): MalType { - return readParen(reader, MalList, "(", ")"); -} - -function readVector(reader: Reader): MalType { - return readParen(reader, MalVector, "[", "]"); -} - -function readHashMap(reader: Reader): MalType { - return readParen(reader, MalHashMap, "{", "}"); -} - -function readParen(reader: Reader, ctor: { new (list: MalType[]): MalType; }, open: string, close: string): MalType { - const token = reader.next(); // drop open paren - if (token !== open) { - throw new Error(`unexpected token ${token}, expected ${open}`); - } - const list: MalType[] = []; - while (true) { - const next = reader.peek(); - if (next === close) { - break; - } else if (!next) { - throw new Error("unexpected EOF"); - } - list.push(readForm(reader)); - } - reader.next(); // drop close paren - - return new ctor(list); -} - -function readAtom(reader: Reader): MalType { - const token = reader.next(); - if (token.match(/^-?[0-9]+$/)) { - const v = parseInt(token, 10); - return new MalNumber(v); - } - if (token.match(/^-?[0-9]\.[0-9]+$/)) { - const v = parseFloat(token); - return new MalNumber(v); - } - if (token.match(/^"(?:\\.|[^\\"])*"$/)) { - const v = token.slice(1, token.length - 1) - .replace(/\\(.)/g, (_, c: string) => c == 'n' ? '\n' : c) - return new MalString(v); - } - if (token[0] === '"') { - throw new Error("expected '\"', got EOF"); - } - if (token[0] === ":") { - return MalKeyword.get(token.substr(1)); - } - switch (token) { - case "nil": - return MalNil.instance; - case "true": - return new MalBoolean(true); - case "false": - return new MalBoolean(false); - } - - return MalSymbol.get(token); -} +import { MalType, MalList, MalString, MalNumber, MalBoolean, MalNil, MalKeyword, MalSymbol, MalVector, MalHashMap } from "./types"; + +class Reader { + position = 0; + + constructor(private tokens: string[]) { } + + next(): string { + const ret = this.peek(); + this.position += 1; + return ret; + } + + peek(): string { + return this.tokens[this.position]; + } +} + +export function readStr(input: string): MalType { + const tokens = tokenizer(input); + const reader = new Reader(tokens); + return readForm(reader); +} + +function tokenizer(input: string): string[] { + const regexp = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*)/g; + const tokens: string[] = []; + while (true) { + const matches = regexp.exec(input); + if (!matches) { + break; + } + const match = matches[1]; + if (match === "") { + break; + } + if (match[0] !== ";") { + tokens.push(match); + } + } + + return tokens; +} + +function readForm(reader: Reader): MalType { + const token = reader.peek(); + switch (token) { + case "(": + return readList(reader); + case "[": + return readVector(reader); + case "{": + return readHashMap(reader); + case "'": + return readSymbol("quote"); + case "`": + return readSymbol("quasiquote"); + case "~": + return readSymbol("unquote"); + case "~@": + return readSymbol("splice-unquote"); + case "@": + return readSymbol("deref"); + case "^": + { + reader.next(); + const sym = MalSymbol.get("with-meta"); + const target = readForm(reader); + return new MalList([sym, readForm(reader), target]); + } + default: + return readAtom(reader); + } + + function readSymbol(name: string) { + reader.next(); + const sym = MalSymbol.get(name); + const target = readForm(reader); + return new MalList([sym, target]); + } +} + +function readList(reader: Reader): MalType { + return readParen(reader, MalList, "(", ")"); +} + +function readVector(reader: Reader): MalType { + return readParen(reader, MalVector, "[", "]"); +} + +function readHashMap(reader: Reader): MalType { + return readParen(reader, MalHashMap, "{", "}"); +} + +function readParen(reader: Reader, ctor: { new (list: MalType[]): MalType; }, open: string, close: string): MalType { + const token = reader.next(); // drop open paren + if (token !== open) { + throw new Error(`unexpected token ${token}, expected ${open}`); + } + const list: MalType[] = []; + while (true) { + const next = reader.peek(); + if (next === close) { + break; + } else if (!next) { + throw new Error("unexpected EOF"); + } + list.push(readForm(reader)); + } + reader.next(); // drop close paren + + return new ctor(list); +} + +function readAtom(reader: Reader): MalType { + const token = reader.next(); + if (token.match(/^-?[0-9]+$/)) { + const v = parseInt(token, 10); + return new MalNumber(v); + } + if (token.match(/^-?[0-9]\.[0-9]+$/)) { + const v = parseFloat(token); + return new MalNumber(v); + } + if (token.match(/^"(?:\\.|[^\\"])*"$/)) { + const v = token.slice(1, token.length - 1) + .replace(/\\(.)/g, (_, c: string) => c == 'n' ? '\n' : c) + return new MalString(v); + } + if (token[0] === '"') { + throw new Error("expected '\"', got EOF"); + } + if (token[0] === ":") { + return MalKeyword.get(token.substr(1)); + } + switch (token) { + case "nil": + return MalNil.instance; + case "true": + return new MalBoolean(true); + case "false": + return new MalBoolean(false); + } + + return MalSymbol.get(token); +} diff --git a/impls/ts/run b/impls/ts/run index 6605303a29..75d63815c6 100755 --- a/impls/ts/run +++ b/impls/ts/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" +#!/bin/bash +exec node $(dirname $0)/${STEP:-stepA_mal}.js "${@}" diff --git a/impls/ts/step0_repl.ts b/impls/ts/step0_repl.ts index 5ed8da9e18..eafc716b1a 100644 --- a/impls/ts/step0_repl.ts +++ b/impls/ts/step0_repl.ts @@ -1,35 +1,35 @@ -import { readline } from "./node_readline"; - -// READ -function read(str: string): any { - // TODO - return str; -} - -// EVAL -function evalMal(ast: any, _env?: any): any { - // TODO - return ast; -} - -// PRINT -function print(exp: any): string { - // TODO - return exp; -} - -function rep(str: string): string { - // TODO - return print(evalMal(read(str))); -} - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - console.log(rep(line)); -} +import { readline } from "./node_readline"; + +// READ +function read(str: string): any { + // TODO + return str; +} + +// EVAL +function evalMal(ast: any, _env?: any): any { + // TODO + return ast; +} + +// PRINT +function print(exp: any): string { + // TODO + return exp; +} + +function rep(str: string): string { + // TODO + return print(evalMal(read(str))); +} + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + console.log(rep(line)); +} diff --git a/impls/ts/step1_read_print.ts b/impls/ts/step1_read_print.ts index 47e4e9a977..aa8414a068 100644 --- a/impls/ts/step1_read_print.ts +++ b/impls/ts/step1_read_print.ts @@ -1,41 +1,41 @@ -import { readline } from "./node_readline"; - -import { MalType } from "./types"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -// EVAL -function evalMal(ast: any, _env?: any): any { - // TODO - return ast; -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -function rep(str: string): string { - return print(evalMal(read(str))); -} - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - const err: Error = e; - console.error(err.message); - } -} +import { readline } from "./node_readline"; + +import { MalType } from "./types"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +// EVAL +function evalMal(ast: any, _env?: any): any { + // TODO + return ast; +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +function rep(str: string): string { + return print(evalMal(read(str))); +} + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + const err: Error = e; + console.error(err.message); + } +} diff --git a/impls/ts/step2_eval.ts b/impls/ts/step2_eval.ts index a3b95ccd04..4b3d57fda2 100644 --- a/impls/ts/step2_eval.ts +++ b/impls/ts/step2_eval.ts @@ -1,88 +1,88 @@ -import { readline } from "./node_readline"; - -import { Node, MalType, MalNumber, MalList, MalVector, MalHashMap, MalFunction, isSeq } from "./types"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -interface MalEnvironment { - [key: string]: MalFunction; -} - -function evalAST(ast: MalType, env: MalEnvironment): MalType { - switch (ast.type) { - case Node.Symbol: - const f = env[ast.v]; - if (!f) { - throw new Error(`unknown symbol: ${ast.v}`); - } - return f; - case Node.List: - return new MalList(ast.list.map(ast => evalMal(ast, env))); - case Node.Vector: - return new MalVector(ast.list.map(ast => evalMal(ast, env))); - case Node.HashMap: - const list: MalType[] = []; - for (const [key, value] of ast.entries()) { - list.push(key); - list.push(evalMal(value, env)); - } - return new MalHashMap(list); - default: - return ast; - } -} - -// EVAL -function evalMal(ast: MalType, env: MalEnvironment): MalType { - if (ast.type !== Node.List) { - return evalAST(ast, env); - } - if (ast.list.length === 0) { - return ast; - } - const result = evalAST(ast, env); - if (!isSeq(result)) { - throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); - } - const [f, ...args] = result.list; - if (f.type !== Node.Function) { - throw new Error(`unexpected token: ${f.type}, expected: function`); - } - return f.func(...args); -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -const replEnv: MalEnvironment = { - "+": MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v + b!.v)), - "-": MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v - b!.v)), - "*": MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v * b!.v)), - "/": MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v / b!.v)), -}; -function rep(str: string): string { - return print(evalMal(read(str), replEnv)); -} - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - const err: Error = e; - console.error(err.message); - } -} +import { readline } from "./node_readline"; + +import { Node, MalType, MalNumber, MalList, MalVector, MalHashMap, MalFunction, isSeq } from "./types"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +interface MalEnvironment { + [key: string]: MalFunction; +} + +function evalAST(ast: MalType, env: MalEnvironment): MalType { + switch (ast.type) { + case Node.Symbol: + const f = env[ast.v]; + if (!f) { + throw new Error(`unknown symbol: ${ast.v}`); + } + return f; + case Node.List: + return new MalList(ast.list.map(ast => evalMal(ast, env))); + case Node.Vector: + return new MalVector(ast.list.map(ast => evalMal(ast, env))); + case Node.HashMap: + const list: MalType[] = []; + for (const [key, value] of ast.entries()) { + list.push(key); + list.push(evalMal(value, env)); + } + return new MalHashMap(list); + default: + return ast; + } +} + +// EVAL +function evalMal(ast: MalType, env: MalEnvironment): MalType { + if (ast.type !== Node.List) { + return evalAST(ast, env); + } + if (ast.list.length === 0) { + return ast; + } + const result = evalAST(ast, env); + if (!isSeq(result)) { + throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); + } + const [f, ...args] = result.list; + if (f.type !== Node.Function) { + throw new Error(`unexpected token: ${f.type}, expected: function`); + } + return f.func(...args); +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +const replEnv: MalEnvironment = { + "+": MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v + b!.v)), + "-": MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v - b!.v)), + "*": MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v * b!.v)), + "/": MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v / b!.v)), +}; +function rep(str: string): string { + return print(evalMal(read(str), replEnv)); +} + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + const err: Error = e; + console.error(err.message); + } +} diff --git a/impls/ts/step3_env.ts b/impls/ts/step3_env.ts index 4be842383c..bf5f99a9df 100644 --- a/impls/ts/step3_env.ts +++ b/impls/ts/step3_env.ts @@ -1,122 +1,122 @@ -import { readline } from "./node_readline"; - -import { Node, MalType, MalNumber, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isSeq } from "./types"; -import { Env } from "./env"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -function evalAST(ast: MalType, env: Env): MalType { - switch (ast.type) { - case Node.Symbol: - const f = env.get(ast); - if (!f) { - throw new Error(`unknown symbol: ${ast.v}`); - } - return f; - case Node.List: - return new MalList(ast.list.map(ast => evalMal(ast, env))); - case Node.Vector: - return new MalVector(ast.list.map(ast => evalMal(ast, env))); - case Node.HashMap: - const list: MalType[] = []; - for (const [key, value] of ast.entries()) { - list.push(key); - list.push(evalMal(value, env)); - } - return new MalHashMap(list); - default: - return ast; - } -} - -// EVAL -function evalMal(ast: MalType, env: Env): MalType { - if (ast.type !== Node.List) { - return evalAST(ast, env); - } - if (ast.list.length === 0) { - return ast; - } - const first = ast.list[0]; - switch (first.type) { - case Node.Symbol: - switch (first.v) { - case "def!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected toke type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - return env.set(key, evalMal(value, env)); - } - case "let*": { - let letEnv = new Env(env); - const pairs = ast.list[1]; - if (!isSeq(pairs)) { - throw new Error(`unexpected toke type: ${pairs.type}, expected: list or vector`); - } - const list = pairs.list; - for (let i = 0; i < list.length; i += 2) { - const key = list[i]; - const value = list[i + 1]; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!key || !value) { - throw new Error(`unexpected syntax`); - } - - letEnv.set(key, evalMal(value, letEnv)); - } - return evalMal(ast.list[2], letEnv); - } - } - } - const result = evalAST(ast, env); - if (!isSeq(result)) { - throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); - } - const [f, ...args] = result.list; - if (f.type !== Node.Function) { - throw new Error(`unexpected token: ${f.type}, expected: function`); - } - return f.func(...args); -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -const replEnv = new Env(); -function rep(str: string): string { - return print(evalMal(read(str), replEnv)); -} - -replEnv.set(MalSymbol.get("+"), MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v + b!.v))); -replEnv.set(MalSymbol.get("-"), MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v - b!.v))); -replEnv.set(MalSymbol.get("*"), MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v * b!.v))); -replEnv.set(MalSymbol.get("/"), MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v / b!.v))); - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - const err: Error = e; - console.error(err.message); - } -} +import { readline } from "./node_readline"; + +import { Node, MalType, MalNumber, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isSeq } from "./types"; +import { Env } from "./env"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +function evalAST(ast: MalType, env: Env): MalType { + switch (ast.type) { + case Node.Symbol: + const f = env.get(ast); + if (!f) { + throw new Error(`unknown symbol: ${ast.v}`); + } + return f; + case Node.List: + return new MalList(ast.list.map(ast => evalMal(ast, env))); + case Node.Vector: + return new MalVector(ast.list.map(ast => evalMal(ast, env))); + case Node.HashMap: + const list: MalType[] = []; + for (const [key, value] of ast.entries()) { + list.push(key); + list.push(evalMal(value, env)); + } + return new MalHashMap(list); + default: + return ast; + } +} + +// EVAL +function evalMal(ast: MalType, env: Env): MalType { + if (ast.type !== Node.List) { + return evalAST(ast, env); + } + if (ast.list.length === 0) { + return ast; + } + const first = ast.list[0]; + switch (first.type) { + case Node.Symbol: + switch (first.v) { + case "def!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected toke type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + return env.set(key, evalMal(value, env)); + } + case "let*": { + let letEnv = new Env(env); + const pairs = ast.list[1]; + if (!isSeq(pairs)) { + throw new Error(`unexpected toke type: ${pairs.type}, expected: list or vector`); + } + const list = pairs.list; + for (let i = 0; i < list.length; i += 2) { + const key = list[i]; + const value = list[i + 1]; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!key || !value) { + throw new Error(`unexpected syntax`); + } + + letEnv.set(key, evalMal(value, letEnv)); + } + return evalMal(ast.list[2], letEnv); + } + } + } + const result = evalAST(ast, env); + if (!isSeq(result)) { + throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); + } + const [f, ...args] = result.list; + if (f.type !== Node.Function) { + throw new Error(`unexpected token: ${f.type}, expected: function`); + } + return f.func(...args); +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +const replEnv = new Env(); +function rep(str: string): string { + return print(evalMal(read(str), replEnv)); +} + +replEnv.set(MalSymbol.get("+"), MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v + b!.v))); +replEnv.set(MalSymbol.get("-"), MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v - b!.v))); +replEnv.set(MalSymbol.get("*"), MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v * b!.v))); +replEnv.set(MalSymbol.get("/"), MalFunction.fromBootstrap((a?: MalNumber, b?: MalNumber) => new MalNumber(a!.v / b!.v))); + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + const err: Error = e; + console.error(err.message); + } +} diff --git a/impls/ts/step4_if_fn_do.ts b/impls/ts/step4_if_fn_do.ts index fd42ed738b..1efddca649 100644 --- a/impls/ts/step4_if_fn_do.ts +++ b/impls/ts/step4_if_fn_do.ts @@ -1,169 +1,169 @@ -import { readline } from "./node_readline"; - -import { Node, MalType, MalNil, MalList, MalVector, MalHashMap, MalFunction, isAST, isSeq } from "./types"; -import { Env } from "./env"; -import * as core from "./core"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -function evalAST(ast: MalType, env: Env): MalType { - switch (ast.type) { - case Node.Symbol: - const f = env.get(ast); - if (!f) { - throw new Error(`unknown symbol: ${ast.v}`); - } - return f; - case Node.List: - return new MalList(ast.list.map(ast => evalMal(ast, env))); - case Node.Vector: - return new MalVector(ast.list.map(ast => evalMal(ast, env))); - case Node.HashMap: - const list: MalType[] = []; - for (const [key, value] of ast.entries()) { - list.push(key); - list.push(evalMal(value, env)); - } - return new MalHashMap(list); - default: - return ast; - } -} - -// EVAL -function evalMal(ast: MalType, env: Env): MalType { - if (ast.type !== Node.List) { - return evalAST(ast, env); - } - if (ast.list.length === 0) { - return ast; - } - const first = ast.list[0]; - switch (first.type) { - case Node.Symbol: - switch (first.v) { - case "def!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - return env.set(key, evalMal(value, env)); - } - case "let*": { - let letEnv = new Env(env); - const pairs = ast.list[1]; - if (!isSeq(pairs)) { - throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); - } - for (let i = 0; i < pairs.list.length; i += 2) { - const key = pairs.list[i]; - const value = pairs.list[i + 1]; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!key || !value) { - throw new Error(`unexpected syntax`); - } - - letEnv.set(key, evalMal(value, letEnv)); - } - return evalMal(ast.list[2], letEnv); - } - case "do": { - const [, ...list] = ast.list; - const ret = evalAST(new MalList(list), env); - if (!isSeq(ret)) { - throw new Error(`unexpected return type: ${ret.type}, expected: list or vector`); - } - return ret.list[ret.list.length - 1]; - } - case "if": { - const [, cond, thenExpr, elseExrp] = ast.list; - const ret = evalMal(cond, env); - let b = true; - if (ret.type === Node.Boolean && !ret.v) { - b = false; - } else if (ret.type === Node.Nil) { - b = false; - } - if (b) { - return evalMal(thenExpr, env); - } else if (elseExrp) { - return evalMal(elseExrp, env); - } else { - return MalNil.instance; - } - } - case "fn*": { - const [, args, binds] = ast.list; - if (!isSeq(args)) { - throw new Error(`unexpected return type: ${args.type}, expected: list or vector`); - } - const symbols = args.list.map(param => { - if (param.type !== Node.Symbol) { - throw new Error(`unexpected return type: ${param.type}, expected: symbol`); - } - return param; - }); - return MalFunction.fromBootstrap((...fnArgs: MalType[]) => { - return evalMal(binds, new Env(env, symbols, fnArgs)); - }); - } - } - } - const result = evalAST(ast, env); - if (!isSeq(result)) { - throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); - } - const [f, ...args] = result.list; - if (f.type !== Node.Function) { - throw new Error(`unexpected token: ${f.type}, expected: function`); - } - return f.func(...args); -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -const replEnv = new Env(); -function rep(str: string): string { - return print(evalMal(read(str), replEnv)); -} - -// core.EXT: defined using Racket -core.ns.forEach((value, key) => { - replEnv.set(key, value); -}); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - if (isAST(e)) { - console.error("Error:", prStr(e)); - } else { - const err: Error = e; - console.error("Error:", err.message); - } - } -} +import { readline } from "./node_readline"; + +import { Node, MalType, MalNil, MalList, MalVector, MalHashMap, MalFunction, isAST, isSeq } from "./types"; +import { Env } from "./env"; +import * as core from "./core"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +function evalAST(ast: MalType, env: Env): MalType { + switch (ast.type) { + case Node.Symbol: + const f = env.get(ast); + if (!f) { + throw new Error(`unknown symbol: ${ast.v}`); + } + return f; + case Node.List: + return new MalList(ast.list.map(ast => evalMal(ast, env))); + case Node.Vector: + return new MalVector(ast.list.map(ast => evalMal(ast, env))); + case Node.HashMap: + const list: MalType[] = []; + for (const [key, value] of ast.entries()) { + list.push(key); + list.push(evalMal(value, env)); + } + return new MalHashMap(list); + default: + return ast; + } +} + +// EVAL +function evalMal(ast: MalType, env: Env): MalType { + if (ast.type !== Node.List) { + return evalAST(ast, env); + } + if (ast.list.length === 0) { + return ast; + } + const first = ast.list[0]; + switch (first.type) { + case Node.Symbol: + switch (first.v) { + case "def!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + return env.set(key, evalMal(value, env)); + } + case "let*": { + let letEnv = new Env(env); + const pairs = ast.list[1]; + if (!isSeq(pairs)) { + throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); + } + for (let i = 0; i < pairs.list.length; i += 2) { + const key = pairs.list[i]; + const value = pairs.list[i + 1]; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!key || !value) { + throw new Error(`unexpected syntax`); + } + + letEnv.set(key, evalMal(value, letEnv)); + } + return evalMal(ast.list[2], letEnv); + } + case "do": { + const [, ...list] = ast.list; + const ret = evalAST(new MalList(list), env); + if (!isSeq(ret)) { + throw new Error(`unexpected return type: ${ret.type}, expected: list or vector`); + } + return ret.list[ret.list.length - 1]; + } + case "if": { + const [, cond, thenExpr, elseExrp] = ast.list; + const ret = evalMal(cond, env); + let b = true; + if (ret.type === Node.Boolean && !ret.v) { + b = false; + } else if (ret.type === Node.Nil) { + b = false; + } + if (b) { + return evalMal(thenExpr, env); + } else if (elseExrp) { + return evalMal(elseExrp, env); + } else { + return MalNil.instance; + } + } + case "fn*": { + const [, args, binds] = ast.list; + if (!isSeq(args)) { + throw new Error(`unexpected return type: ${args.type}, expected: list or vector`); + } + const symbols = args.list.map(param => { + if (param.type !== Node.Symbol) { + throw new Error(`unexpected return type: ${param.type}, expected: symbol`); + } + return param; + }); + return MalFunction.fromBootstrap((...fnArgs: MalType[]) => { + return evalMal(binds, new Env(env, symbols, fnArgs)); + }); + } + } + } + const result = evalAST(ast, env); + if (!isSeq(result)) { + throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); + } + const [f, ...args] = result.list; + if (f.type !== Node.Function) { + throw new Error(`unexpected token: ${f.type}, expected: function`); + } + return f.func(...args); +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +const replEnv = new Env(); +function rep(str: string): string { + return print(evalMal(read(str), replEnv)); +} + +// core.EXT: defined using Racket +core.ns.forEach((value, key) => { + replEnv.set(key, value); +}); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } + } +} diff --git a/impls/ts/step5_tco.ts b/impls/ts/step5_tco.ts index 04f76d4816..07025f5255 100644 --- a/impls/ts/step5_tco.ts +++ b/impls/ts/step5_tco.ts @@ -1,175 +1,175 @@ -import { readline } from "./node_readline"; - -import { Node, MalType, MalNil, MalList, MalVector, MalHashMap, MalFunction, isAST, isSeq } from "./types"; -import { Env } from "./env"; -import * as core from "./core"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -function evalAST(ast: MalType, env: Env): MalType { - switch (ast.type) { - case Node.Symbol: - const f = env.get(ast); - if (!f) { - throw new Error(`unknown symbol: ${ast.v}`); - } - return f; - case Node.List: - return new MalList(ast.list.map(ast => evalMal(ast, env))); - case Node.Vector: - return new MalVector(ast.list.map(ast => evalMal(ast, env))); - case Node.HashMap: - const list: MalType[] = []; - for (const [key, value] of ast.entries()) { - list.push(key); - list.push(evalMal(value, env)); - } - return new MalHashMap(list); - default: - return ast; - } -} - -// EVAL -function evalMal(ast: MalType, env: Env): MalType { - loop: while (true) { - if (ast.type !== Node.List) { - return evalAST(ast, env); - } - if (ast.list.length === 0) { - return ast; - } - const first = ast.list[0]; - switch (first.type) { - case Node.Symbol: - switch (first.v) { - case "def!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - return env.set(key, evalMal(value, env)); - } - case "let*": { - env = new Env(env); - const pairs = ast.list[1]; - if (!isSeq(pairs)) { - throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); - } - for (let i = 0; i < pairs.list.length; i += 2) { - const key = pairs.list[i]; - const value = pairs.list[i + 1]; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!key || !value) { - throw new Error(`unexpected syntax`); - } - - env.set(key, evalMal(value, env)); - } - ast = ast.list[2]; - continue loop; - } - case "do": { - const list = ast.list.slice(1, -1); - evalAST(new MalList(list), env); - ast = ast.list[ast.list.length - 1]; - continue loop; - } - case "if": { - const [, cond, thenExpr, elseExrp] = ast.list; - const ret = evalMal(cond, env); - let b = true; - if (ret.type === Node.Boolean && !ret.v) { - b = false; - } else if (ret.type === Node.Nil) { - b = false; - } - if (b) { - ast = thenExpr; - } else if (elseExrp) { - ast = elseExrp; - } else { - ast = MalNil.instance; - } - continue loop; - } - case "fn*": { - const [, params, bodyAst] = ast.list; - if (!isSeq(params)) { - throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); - } - const symbols = params.list.map(param => { - if (param.type !== Node.Symbol) { - throw new Error(`unexpected return type: ${param.type}, expected: symbol`); - } - return param; - }); - return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); - } - } - } - const result = evalAST(ast, env); - if (!isSeq(result)) { - throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); - } - const [f, ...args] = result.list; - if (f.type !== Node.Function) { - throw new Error(`unexpected token: ${f.type}, expected: function`); - } - if (f.ast) { - ast = f.ast; - env = f.newEnv(args); - continue loop; - } - - return f.func(...args); - } -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -const replEnv = new Env(); -function rep(str: string): string { - return print(evalMal(read(str), replEnv)); -} - -// core.EXT: defined using Racket -core.ns.forEach((value, key) => { - replEnv.set(key, value); -}); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - if (isAST(e)) { - console.error("Error:", prStr(e)); - } else { - const err: Error = e; - console.error("Error:", err.message); - } - } -} +import { readline } from "./node_readline"; + +import { Node, MalType, MalNil, MalList, MalVector, MalHashMap, MalFunction, isAST, isSeq } from "./types"; +import { Env } from "./env"; +import * as core from "./core"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +function evalAST(ast: MalType, env: Env): MalType { + switch (ast.type) { + case Node.Symbol: + const f = env.get(ast); + if (!f) { + throw new Error(`unknown symbol: ${ast.v}`); + } + return f; + case Node.List: + return new MalList(ast.list.map(ast => evalMal(ast, env))); + case Node.Vector: + return new MalVector(ast.list.map(ast => evalMal(ast, env))); + case Node.HashMap: + const list: MalType[] = []; + for (const [key, value] of ast.entries()) { + list.push(key); + list.push(evalMal(value, env)); + } + return new MalHashMap(list); + default: + return ast; + } +} + +// EVAL +function evalMal(ast: MalType, env: Env): MalType { + loop: while (true) { + if (ast.type !== Node.List) { + return evalAST(ast, env); + } + if (ast.list.length === 0) { + return ast; + } + const first = ast.list[0]; + switch (first.type) { + case Node.Symbol: + switch (first.v) { + case "def!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + return env.set(key, evalMal(value, env)); + } + case "let*": { + env = new Env(env); + const pairs = ast.list[1]; + if (!isSeq(pairs)) { + throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); + } + for (let i = 0; i < pairs.list.length; i += 2) { + const key = pairs.list[i]; + const value = pairs.list[i + 1]; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!key || !value) { + throw new Error(`unexpected syntax`); + } + + env.set(key, evalMal(value, env)); + } + ast = ast.list[2]; + continue loop; + } + case "do": { + const list = ast.list.slice(1, -1); + evalAST(new MalList(list), env); + ast = ast.list[ast.list.length - 1]; + continue loop; + } + case "if": { + const [, cond, thenExpr, elseExrp] = ast.list; + const ret = evalMal(cond, env); + let b = true; + if (ret.type === Node.Boolean && !ret.v) { + b = false; + } else if (ret.type === Node.Nil) { + b = false; + } + if (b) { + ast = thenExpr; + } else if (elseExrp) { + ast = elseExrp; + } else { + ast = MalNil.instance; + } + continue loop; + } + case "fn*": { + const [, params, bodyAst] = ast.list; + if (!isSeq(params)) { + throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); + } + const symbols = params.list.map(param => { + if (param.type !== Node.Symbol) { + throw new Error(`unexpected return type: ${param.type}, expected: symbol`); + } + return param; + }); + return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); + } + } + } + const result = evalAST(ast, env); + if (!isSeq(result)) { + throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); + } + const [f, ...args] = result.list; + if (f.type !== Node.Function) { + throw new Error(`unexpected token: ${f.type}, expected: function`); + } + if (f.ast) { + ast = f.ast; + env = f.newEnv(args); + continue loop; + } + + return f.func(...args); + } +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +const replEnv = new Env(); +function rep(str: string): string { + return print(evalMal(read(str), replEnv)); +} + +// core.EXT: defined using Racket +core.ns.forEach((value, key) => { + replEnv.set(key, value); +}); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } + } +} diff --git a/impls/ts/step6_file.ts b/impls/ts/step6_file.ts index 10747e6eac..6b80c692f3 100644 --- a/impls/ts/step6_file.ts +++ b/impls/ts/step6_file.ts @@ -1,190 +1,190 @@ -import { readline } from "./node_readline"; - -import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; -import { Env } from "./env"; -import * as core from "./core"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -function evalAST(ast: MalType, env: Env): MalType { - switch (ast.type) { - case Node.Symbol: - const f = env.get(ast); - if (!f) { - throw new Error(`unknown symbol: ${ast.v}`); - } - return f; - case Node.List: - return new MalList(ast.list.map(ast => evalMal(ast, env))); - case Node.Vector: - return new MalVector(ast.list.map(ast => evalMal(ast, env))); - case Node.HashMap: - const list: MalType[] = []; - for (const [key, value] of ast.entries()) { - list.push(key); - list.push(evalMal(value, env)); - } - return new MalHashMap(list); - default: - return ast; - } -} - -// EVAL -function evalMal(ast: MalType, env: Env): MalType { - loop: while (true) { - if (ast.type !== Node.List) { - return evalAST(ast, env); - } - if (ast.list.length === 0) { - return ast; - } - const first = ast.list[0]; - switch (first.type) { - case Node.Symbol: - switch (first.v) { - case "def!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - return env.set(key, evalMal(value, env)); - } - case "let*": { - env = new Env(env); - const pairs = ast.list[1]; - if (!isSeq(pairs)) { - throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); - } - for (let i = 0; i < pairs.list.length; i += 2) { - const key = pairs.list[i]; - const value = pairs.list[i + 1]; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!key || !value) { - throw new Error(`unexpected syntax`); - } - - env.set(key, evalMal(value, env)); - } - ast = ast.list[2]; - continue loop; - } - case "do": { - const list = ast.list.slice(1, -1); - evalAST(new MalList(list), env); - ast = ast.list[ast.list.length - 1]; - continue loop; - } - case "if": { - const [, cond, thenExpr, elseExrp] = ast.list; - const ret = evalMal(cond, env); - let b = true; - if (ret.type === Node.Boolean && !ret.v) { - b = false; - } else if (ret.type === Node.Nil) { - b = false; - } - if (b) { - ast = thenExpr; - } else if (elseExrp) { - ast = elseExrp; - } else { - ast = MalNil.instance; - } - continue loop; - } - case "fn*": { - const [, params, bodyAst] = ast.list; - if (!isSeq(params)) { - throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); - } - const symbols = params.list.map(param => { - if (param.type !== Node.Symbol) { - throw new Error(`unexpected return type: ${param.type}, expected: symbol`); - } - return param; - }); - return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); - } - } - } - const result = evalAST(ast, env); - if (!isSeq(result)) { - throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); - } - const [f, ...args] = result.list; - if (f.type !== Node.Function) { - throw new Error(`unexpected token: ${f.type}, expected: function`); - } - if (f.ast) { - ast = f.ast; - env = f.newEnv(args); - continue loop; - } - - return f.func(...args); - } -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -const replEnv = new Env(); -function rep(str: string): string { - return print(evalMal(read(str), replEnv)); -} - -// core.EXT: defined using Racket -core.ns.forEach((value, key) => { - replEnv.set(key, value); -}); -replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { - if (!ast) { - throw new Error(`undefined argument`); - } - return evalMal(ast, replEnv); -})); - -replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); - -if (typeof process !== "undefined" && 2 < process.argv.length) { - replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); - rep(`(load-file "${process.argv[2]}")`); - process.exit(0); -} - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - if (isAST(e)) { - console.error("Error:", prStr(e)); - } else { - const err: Error = e; - console.error("Error:", err.message); - } - } -} +import { readline } from "./node_readline"; + +import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; +import { Env } from "./env"; +import * as core from "./core"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +function evalAST(ast: MalType, env: Env): MalType { + switch (ast.type) { + case Node.Symbol: + const f = env.get(ast); + if (!f) { + throw new Error(`unknown symbol: ${ast.v}`); + } + return f; + case Node.List: + return new MalList(ast.list.map(ast => evalMal(ast, env))); + case Node.Vector: + return new MalVector(ast.list.map(ast => evalMal(ast, env))); + case Node.HashMap: + const list: MalType[] = []; + for (const [key, value] of ast.entries()) { + list.push(key); + list.push(evalMal(value, env)); + } + return new MalHashMap(list); + default: + return ast; + } +} + +// EVAL +function evalMal(ast: MalType, env: Env): MalType { + loop: while (true) { + if (ast.type !== Node.List) { + return evalAST(ast, env); + } + if (ast.list.length === 0) { + return ast; + } + const first = ast.list[0]; + switch (first.type) { + case Node.Symbol: + switch (first.v) { + case "def!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + return env.set(key, evalMal(value, env)); + } + case "let*": { + env = new Env(env); + const pairs = ast.list[1]; + if (!isSeq(pairs)) { + throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); + } + for (let i = 0; i < pairs.list.length; i += 2) { + const key = pairs.list[i]; + const value = pairs.list[i + 1]; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!key || !value) { + throw new Error(`unexpected syntax`); + } + + env.set(key, evalMal(value, env)); + } + ast = ast.list[2]; + continue loop; + } + case "do": { + const list = ast.list.slice(1, -1); + evalAST(new MalList(list), env); + ast = ast.list[ast.list.length - 1]; + continue loop; + } + case "if": { + const [, cond, thenExpr, elseExrp] = ast.list; + const ret = evalMal(cond, env); + let b = true; + if (ret.type === Node.Boolean && !ret.v) { + b = false; + } else if (ret.type === Node.Nil) { + b = false; + } + if (b) { + ast = thenExpr; + } else if (elseExrp) { + ast = elseExrp; + } else { + ast = MalNil.instance; + } + continue loop; + } + case "fn*": { + const [, params, bodyAst] = ast.list; + if (!isSeq(params)) { + throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); + } + const symbols = params.list.map(param => { + if (param.type !== Node.Symbol) { + throw new Error(`unexpected return type: ${param.type}, expected: symbol`); + } + return param; + }); + return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); + } + } + } + const result = evalAST(ast, env); + if (!isSeq(result)) { + throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); + } + const [f, ...args] = result.list; + if (f.type !== Node.Function) { + throw new Error(`unexpected token: ${f.type}, expected: function`); + } + if (f.ast) { + ast = f.ast; + env = f.newEnv(args); + continue loop; + } + + return f.func(...args); + } +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +const replEnv = new Env(); +function rep(str: string): string { + return print(evalMal(read(str), replEnv)); +} + +// core.EXT: defined using Racket +core.ns.forEach((value, key) => { + replEnv.set(key, value); +}); +replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { + if (!ast) { + throw new Error(`undefined argument`); + } + return evalMal(ast, replEnv); +})); + +replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); + +if (typeof process !== "undefined" && 2 < process.argv.length) { + replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); + rep(`(load-file "${process.argv[2]}")`); + process.exit(0); +} + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } + } +} diff --git a/impls/ts/step7_quote.ts b/impls/ts/step7_quote.ts index 2b1d47f82f..b510b41980 100644 --- a/impls/ts/step7_quote.ts +++ b/impls/ts/step7_quote.ts @@ -1,245 +1,245 @@ -import { readline } from "./node_readline"; - -import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; -import { Env } from "./env"; -import * as core from "./core"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -function starts_with(lst: MalType[], sym: string): boolean { - if (lst.length == 2) { - let a0 = lst[0] - switch (a0.type) { - case Node.Symbol: - return a0.v === sym; - } - } - return false; -} - -function qq_loop(elt: MalType, acc: MalList): MalList { - if (elt.type == Node.List && starts_with(elt.list, "splice-unquote")) { - return new MalList([MalSymbol.get("concat"), elt.list[1], acc]); - } else { - return new MalList([MalSymbol.get("cons"), quasiquote(elt), acc]); - } -} - -function qq_foldr(xs : MalType[]): MalList { - let acc = new MalList([]) - for (let i=xs.length-1; 0<=i; i-=1) { - acc = qq_loop(xs[i], acc) - } - return acc; -} - -function quasiquote(ast: MalType): MalType { - switch (ast.type) { - case Node.Symbol: - return new MalList([MalSymbol.get("quote"), ast]); - case Node.HashMap: - return new MalList([MalSymbol.get("quote"), ast]); - case Node.List: - if (starts_with(ast.list, "unquote")) { - return ast.list[1]; - } else { - return qq_foldr(ast.list); - } - case Node.Vector: - return new MalList([MalSymbol.get("vec"), qq_foldr(ast.list)]); - default: - return ast; - } -} - -function evalAST(ast: MalType, env: Env): MalType { - switch (ast.type) { - case Node.Symbol: - const f = env.get(ast); - if (!f) { - throw new Error(`unknown symbol: ${ast.v}`); - } - return f; - case Node.List: - return new MalList(ast.list.map(ast => evalMal(ast, env))); - case Node.Vector: - return new MalVector(ast.list.map(ast => evalMal(ast, env))); - case Node.HashMap: - const list: MalType[] = []; - for (const [key, value] of ast.entries()) { - list.push(key); - list.push(evalMal(value, env)); - } - return new MalHashMap(list); - default: - return ast; - } -} - -// EVAL -function evalMal(ast: MalType, env: Env): MalType { - loop: while (true) { - if (ast.type !== Node.List) { - return evalAST(ast, env); - } - if (ast.list.length === 0) { - return ast; - } - const first = ast.list[0]; - switch (first.type) { - case Node.Symbol: - switch (first.v) { - case "def!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - return env.set(key, evalMal(value, env)); - } - case "let*": { - env = new Env(env); - const pairs = ast.list[1]; - if (!isSeq(pairs)) { - throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); - } - for (let i = 0; i < pairs.list.length; i += 2) { - const key = pairs.list[i]; - const value = pairs.list[i + 1]; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!key || !value) { - throw new Error(`unexpected syntax`); - } - - env.set(key, evalMal(value, env)); - } - ast = ast.list[2]; - continue loop; - } - case "quote": { - return ast.list[1]; - } - case "quasiquoteexpand": { - return quasiquote(ast.list[1]); - } - case "quasiquote": { - ast = quasiquote(ast.list[1]); - continue loop; - } - case "do": { - const list = ast.list.slice(1, -1); - evalAST(new MalList(list), env); - ast = ast.list[ast.list.length - 1]; - continue loop; - } - case "if": { - const [, cond, thenExpr, elseExrp] = ast.list; - const ret = evalMal(cond, env); - let b = true; - if (ret.type === Node.Boolean && !ret.v) { - b = false; - } else if (ret.type === Node.Nil) { - b = false; - } - if (b) { - ast = thenExpr; - } else if (elseExrp) { - ast = elseExrp; - } else { - ast = MalNil.instance; - } - continue loop; - } - case "fn*": { - const [, params, bodyAst] = ast.list; - if (!isSeq(params)) { - throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); - } - const symbols = params.list.map(param => { - if (param.type !== Node.Symbol) { - throw new Error(`unexpected return type: ${param.type}, expected: symbol`); - } - return param; - }); - return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); - } - } - } - const result = evalAST(ast, env); - if (!isSeq(result)) { - throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); - } - const [f, ...args] = result.list; - if (f.type !== Node.Function) { - throw new Error(`unexpected token: ${f.type}, expected: function`); - } - if (f.ast) { - ast = f.ast; - env = f.newEnv(args); - continue loop; - } - - return f.func(...args); - } -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -const replEnv = new Env(); -function rep(str: string): string { - return print(evalMal(read(str), replEnv)); -} - -// core.EXT: defined using Racket -core.ns.forEach((value, key) => { - replEnv.set(key, value); -}); -replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { - if (!ast) { - throw new Error(`undefined argument`); - } - return evalMal(ast, replEnv); -})); -replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); - -if (typeof process !== "undefined" && 2 < process.argv.length) { - replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); - rep(`(load-file "${process.argv[2]}")`); - process.exit(0); -} - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - if (isAST(e)) { - console.error("Error:", prStr(e)); - } else { - const err: Error = e; - console.error("Error:", err.message); - } - } -} +import { readline } from "./node_readline"; + +import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; +import { Env } from "./env"; +import * as core from "./core"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +function starts_with(lst: MalType[], sym: string): boolean { + if (lst.length == 2) { + let a0 = lst[0] + switch (a0.type) { + case Node.Symbol: + return a0.v === sym; + } + } + return false; +} + +function qq_loop(elt: MalType, acc: MalList): MalList { + if (elt.type == Node.List && starts_with(elt.list, "splice-unquote")) { + return new MalList([MalSymbol.get("concat"), elt.list[1], acc]); + } else { + return new MalList([MalSymbol.get("cons"), quasiquote(elt), acc]); + } +} + +function qq_foldr(xs : MalType[]): MalList { + let acc = new MalList([]) + for (let i=xs.length-1; 0<=i; i-=1) { + acc = qq_loop(xs[i], acc) + } + return acc; +} + +function quasiquote(ast: MalType): MalType { + switch (ast.type) { + case Node.Symbol: + return new MalList([MalSymbol.get("quote"), ast]); + case Node.HashMap: + return new MalList([MalSymbol.get("quote"), ast]); + case Node.List: + if (starts_with(ast.list, "unquote")) { + return ast.list[1]; + } else { + return qq_foldr(ast.list); + } + case Node.Vector: + return new MalList([MalSymbol.get("vec"), qq_foldr(ast.list)]); + default: + return ast; + } +} + +function evalAST(ast: MalType, env: Env): MalType { + switch (ast.type) { + case Node.Symbol: + const f = env.get(ast); + if (!f) { + throw new Error(`unknown symbol: ${ast.v}`); + } + return f; + case Node.List: + return new MalList(ast.list.map(ast => evalMal(ast, env))); + case Node.Vector: + return new MalVector(ast.list.map(ast => evalMal(ast, env))); + case Node.HashMap: + const list: MalType[] = []; + for (const [key, value] of ast.entries()) { + list.push(key); + list.push(evalMal(value, env)); + } + return new MalHashMap(list); + default: + return ast; + } +} + +// EVAL +function evalMal(ast: MalType, env: Env): MalType { + loop: while (true) { + if (ast.type !== Node.List) { + return evalAST(ast, env); + } + if (ast.list.length === 0) { + return ast; + } + const first = ast.list[0]; + switch (first.type) { + case Node.Symbol: + switch (first.v) { + case "def!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + return env.set(key, evalMal(value, env)); + } + case "let*": { + env = new Env(env); + const pairs = ast.list[1]; + if (!isSeq(pairs)) { + throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); + } + for (let i = 0; i < pairs.list.length; i += 2) { + const key = pairs.list[i]; + const value = pairs.list[i + 1]; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!key || !value) { + throw new Error(`unexpected syntax`); + } + + env.set(key, evalMal(value, env)); + } + ast = ast.list[2]; + continue loop; + } + case "quote": { + return ast.list[1]; + } + case "quasiquoteexpand": { + return quasiquote(ast.list[1]); + } + case "quasiquote": { + ast = quasiquote(ast.list[1]); + continue loop; + } + case "do": { + const list = ast.list.slice(1, -1); + evalAST(new MalList(list), env); + ast = ast.list[ast.list.length - 1]; + continue loop; + } + case "if": { + const [, cond, thenExpr, elseExrp] = ast.list; + const ret = evalMal(cond, env); + let b = true; + if (ret.type === Node.Boolean && !ret.v) { + b = false; + } else if (ret.type === Node.Nil) { + b = false; + } + if (b) { + ast = thenExpr; + } else if (elseExrp) { + ast = elseExrp; + } else { + ast = MalNil.instance; + } + continue loop; + } + case "fn*": { + const [, params, bodyAst] = ast.list; + if (!isSeq(params)) { + throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); + } + const symbols = params.list.map(param => { + if (param.type !== Node.Symbol) { + throw new Error(`unexpected return type: ${param.type}, expected: symbol`); + } + return param; + }); + return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); + } + } + } + const result = evalAST(ast, env); + if (!isSeq(result)) { + throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); + } + const [f, ...args] = result.list; + if (f.type !== Node.Function) { + throw new Error(`unexpected token: ${f.type}, expected: function`); + } + if (f.ast) { + ast = f.ast; + env = f.newEnv(args); + continue loop; + } + + return f.func(...args); + } +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +const replEnv = new Env(); +function rep(str: string): string { + return print(evalMal(read(str), replEnv)); +} + +// core.EXT: defined using Racket +core.ns.forEach((value, key) => { + replEnv.set(key, value); +}); +replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { + if (!ast) { + throw new Error(`undefined argument`); + } + return evalMal(ast, replEnv); +})); +replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); + +if (typeof process !== "undefined" && 2 < process.argv.length) { + replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); + rep(`(load-file "${process.argv[2]}")`); + process.exit(0); +} + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } + } +} diff --git a/impls/ts/step8_macros.ts b/impls/ts/step8_macros.ts index b9610a687d..2216073b85 100644 --- a/impls/ts/step8_macros.ts +++ b/impls/ts/step8_macros.ts @@ -1,312 +1,312 @@ -import { readline } from "./node_readline"; - -import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; -import { Env } from "./env"; -import * as core from "./core"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -function starts_with(lst: MalType[], sym: string): boolean { - if (lst.length == 2) { - let a0 = lst[0] - switch (a0.type) { - case Node.Symbol: - return a0.v === sym; - } - } - return false; -} - -function qq_loop(elt: MalType, acc: MalList): MalList { - if (elt.type == Node.List && starts_with(elt.list, "splice-unquote")) { - return new MalList([MalSymbol.get("concat"), elt.list[1], acc]); - } else { - return new MalList([MalSymbol.get("cons"), quasiquote(elt), acc]); - } -} - -function qq_foldr(xs : MalType[]): MalList { - let acc = new MalList([]) - for (let i=xs.length-1; 0<=i; i-=1) { - acc = qq_loop(xs[i], acc) - } - return acc; -} - -function quasiquote(ast: MalType): MalType { - switch (ast.type) { - case Node.Symbol: - return new MalList([MalSymbol.get("quote"), ast]); - case Node.HashMap: - return new MalList([MalSymbol.get("quote"), ast]); - case Node.List: - if (starts_with(ast.list, "unquote")) { - return ast.list[1]; - } else { - return qq_foldr(ast.list); - } - case Node.Vector: - return new MalList([MalSymbol.get("vec"), qq_foldr(ast.list)]); - default: - return ast; - } -} - -function isMacro(ast: MalType, env: Env): boolean { - if (!isSeq(ast)) { - return false; - } - const s = ast.list[0]; - if (s.type !== Node.Symbol) { - return false; - } - const foundEnv = env.find(s); - if (!foundEnv) { - return false; - } - - const f = foundEnv.get(s); - if (f.type !== Node.Function) { - return false; - } - - return f.isMacro; -} - -function macroexpand(ast: MalType, env: Env): MalType { - while (isMacro(ast, env)) { - if (!isSeq(ast)) { - throw new Error(`unexpected token type: ${ast.type}, expected: list or vector`); - } - const s = ast.list[0]; - if (s.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${s.type}, expected: symbol`); - } - const f = env.get(s); - if (f.type !== Node.Function) { - throw new Error(`unexpected token type: ${f.type}, expected: function`); - } - ast = f.func(...ast.list.slice(1)); - } - - return ast; -} - -function evalAST(ast: MalType, env: Env): MalType { - switch (ast.type) { - case Node.Symbol: - const f = env.get(ast); - if (!f) { - throw new Error(`unknown symbol: ${ast.v}`); - } - return f; - case Node.List: - return new MalList(ast.list.map(ast => evalMal(ast, env))); - case Node.Vector: - return new MalVector(ast.list.map(ast => evalMal(ast, env))); - case Node.HashMap: - const list: MalType[] = []; - for (const [key, value] of ast.entries()) { - list.push(key); - list.push(evalMal(value, env)); - } - return new MalHashMap(list); - default: - return ast; - } -} - -// EVAL -function evalMal(ast: MalType, env: Env): MalType { - loop: while (true) { - if (ast.type !== Node.List) { - return evalAST(ast, env); - } - if (ast.list.length === 0) { - return ast; - } - - ast = macroexpand(ast, env); - if (!isSeq(ast)) { - return evalAST(ast, env); - } - - if (ast.list.length === 0) { - return ast; - } - const first = ast.list[0]; - switch (first.type) { - case Node.Symbol: - switch (first.v) { - case "def!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - return env.set(key, evalMal(value, env)); - } - case "let*": { - env = new Env(env); - const pairs = ast.list[1]; - if (!isSeq(pairs)) { - throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); - } - for (let i = 0; i < pairs.list.length; i += 2) { - const key = pairs.list[i]; - const value = pairs.list[i + 1]; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!key || !value) { - throw new Error(`unexpected syntax`); - } - - env.set(key, evalMal(value, env)); - } - ast = ast.list[2]; - continue loop; - } - case "quote": { - return ast.list[1]; - } - case "quasiquoteexpand": { - return quasiquote(ast.list[1]); - } - case "quasiquote": { - ast = quasiquote(ast.list[1]); - continue loop; - } - case "defmacro!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - const f = evalMal(value, env); - if (f.type !== Node.Function) { - throw new Error(`unexpected token type: ${f.type}, expected: function`); - } - return env.set(key, f.toMacro()); - } - case "macroexpand": { - return macroexpand(ast.list[1], env); - } - case "do": { - const list = ast.list.slice(1, -1); - evalAST(new MalList(list), env); - ast = ast.list[ast.list.length - 1]; - continue loop; - } - case "if": { - const [, cond, thenExpr, elseExrp] = ast.list; - const ret = evalMal(cond, env); - let b = true; - if (ret.type === Node.Boolean && !ret.v) { - b = false; - } else if (ret.type === Node.Nil) { - b = false; - } - if (b) { - ast = thenExpr; - } else if (elseExrp) { - ast = elseExrp; - } else { - ast = MalNil.instance; - } - continue loop; - } - case "fn*": { - const [, params, bodyAst] = ast.list; - if (!isSeq(params)) { - throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); - } - const symbols = params.list.map(param => { - if (param.type !== Node.Symbol) { - throw new Error(`unexpected return type: ${param.type}, expected: symbol`); - } - return param; - }); - return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); - } - } - } - const result = evalAST(ast, env); - if (!isSeq(result)) { - throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); - } - const [f, ...args] = result.list; - if (f.type !== Node.Function) { - throw new Error(`unexpected token: ${f.type}, expected: function`); - } - if (f.ast) { - ast = f.ast; - env = f.newEnv(args); - continue loop; - } - - return f.func(...args); - } -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -const replEnv = new Env(); -function rep(str: string): string { - return print(evalMal(read(str), replEnv)); -} - -// core.EXT: defined using Racket -core.ns.forEach((value, key) => { - replEnv.set(key, value); -}); -replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { - if (!ast) { - throw new Error(`undefined argument`); - } - return evalMal(ast, replEnv); -})); -replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); -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)))))))`); - -if (typeof process !== "undefined" && 2 < process.argv.length) { - replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); - rep(`(load-file "${process.argv[2]}")`); - process.exit(0); -} - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - if (isAST(e)) { - console.error("Error:", prStr(e)); - } else { - const err: Error = e; - console.error("Error:", err.message); - } - } -} +import { readline } from "./node_readline"; + +import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; +import { Env } from "./env"; +import * as core from "./core"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +function starts_with(lst: MalType[], sym: string): boolean { + if (lst.length == 2) { + let a0 = lst[0] + switch (a0.type) { + case Node.Symbol: + return a0.v === sym; + } + } + return false; +} + +function qq_loop(elt: MalType, acc: MalList): MalList { + if (elt.type == Node.List && starts_with(elt.list, "splice-unquote")) { + return new MalList([MalSymbol.get("concat"), elt.list[1], acc]); + } else { + return new MalList([MalSymbol.get("cons"), quasiquote(elt), acc]); + } +} + +function qq_foldr(xs : MalType[]): MalList { + let acc = new MalList([]) + for (let i=xs.length-1; 0<=i; i-=1) { + acc = qq_loop(xs[i], acc) + } + return acc; +} + +function quasiquote(ast: MalType): MalType { + switch (ast.type) { + case Node.Symbol: + return new MalList([MalSymbol.get("quote"), ast]); + case Node.HashMap: + return new MalList([MalSymbol.get("quote"), ast]); + case Node.List: + if (starts_with(ast.list, "unquote")) { + return ast.list[1]; + } else { + return qq_foldr(ast.list); + } + case Node.Vector: + return new MalList([MalSymbol.get("vec"), qq_foldr(ast.list)]); + default: + return ast; + } +} + +function isMacro(ast: MalType, env: Env): boolean { + if (!isSeq(ast)) { + return false; + } + const s = ast.list[0]; + if (s.type !== Node.Symbol) { + return false; + } + const foundEnv = env.find(s); + if (!foundEnv) { + return false; + } + + const f = foundEnv.get(s); + if (f.type !== Node.Function) { + return false; + } + + return f.isMacro; +} + +function macroexpand(ast: MalType, env: Env): MalType { + while (isMacro(ast, env)) { + if (!isSeq(ast)) { + throw new Error(`unexpected token type: ${ast.type}, expected: list or vector`); + } + const s = ast.list[0]; + if (s.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${s.type}, expected: symbol`); + } + const f = env.get(s); + if (f.type !== Node.Function) { + throw new Error(`unexpected token type: ${f.type}, expected: function`); + } + ast = f.func(...ast.list.slice(1)); + } + + return ast; +} + +function evalAST(ast: MalType, env: Env): MalType { + switch (ast.type) { + case Node.Symbol: + const f = env.get(ast); + if (!f) { + throw new Error(`unknown symbol: ${ast.v}`); + } + return f; + case Node.List: + return new MalList(ast.list.map(ast => evalMal(ast, env))); + case Node.Vector: + return new MalVector(ast.list.map(ast => evalMal(ast, env))); + case Node.HashMap: + const list: MalType[] = []; + for (const [key, value] of ast.entries()) { + list.push(key); + list.push(evalMal(value, env)); + } + return new MalHashMap(list); + default: + return ast; + } +} + +// EVAL +function evalMal(ast: MalType, env: Env): MalType { + loop: while (true) { + if (ast.type !== Node.List) { + return evalAST(ast, env); + } + if (ast.list.length === 0) { + return ast; + } + + ast = macroexpand(ast, env); + if (!isSeq(ast)) { + return evalAST(ast, env); + } + + if (ast.list.length === 0) { + return ast; + } + const first = ast.list[0]; + switch (first.type) { + case Node.Symbol: + switch (first.v) { + case "def!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + return env.set(key, evalMal(value, env)); + } + case "let*": { + env = new Env(env); + const pairs = ast.list[1]; + if (!isSeq(pairs)) { + throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); + } + for (let i = 0; i < pairs.list.length; i += 2) { + const key = pairs.list[i]; + const value = pairs.list[i + 1]; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!key || !value) { + throw new Error(`unexpected syntax`); + } + + env.set(key, evalMal(value, env)); + } + ast = ast.list[2]; + continue loop; + } + case "quote": { + return ast.list[1]; + } + case "quasiquoteexpand": { + return quasiquote(ast.list[1]); + } + case "quasiquote": { + ast = quasiquote(ast.list[1]); + continue loop; + } + case "defmacro!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + const f = evalMal(value, env); + if (f.type !== Node.Function) { + throw new Error(`unexpected token type: ${f.type}, expected: function`); + } + return env.set(key, f.toMacro()); + } + case "macroexpand": { + return macroexpand(ast.list[1], env); + } + case "do": { + const list = ast.list.slice(1, -1); + evalAST(new MalList(list), env); + ast = ast.list[ast.list.length - 1]; + continue loop; + } + case "if": { + const [, cond, thenExpr, elseExrp] = ast.list; + const ret = evalMal(cond, env); + let b = true; + if (ret.type === Node.Boolean && !ret.v) { + b = false; + } else if (ret.type === Node.Nil) { + b = false; + } + if (b) { + ast = thenExpr; + } else if (elseExrp) { + ast = elseExrp; + } else { + ast = MalNil.instance; + } + continue loop; + } + case "fn*": { + const [, params, bodyAst] = ast.list; + if (!isSeq(params)) { + throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); + } + const symbols = params.list.map(param => { + if (param.type !== Node.Symbol) { + throw new Error(`unexpected return type: ${param.type}, expected: symbol`); + } + return param; + }); + return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); + } + } + } + const result = evalAST(ast, env); + if (!isSeq(result)) { + throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); + } + const [f, ...args] = result.list; + if (f.type !== Node.Function) { + throw new Error(`unexpected token: ${f.type}, expected: function`); + } + if (f.ast) { + ast = f.ast; + env = f.newEnv(args); + continue loop; + } + + return f.func(...args); + } +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +const replEnv = new Env(); +function rep(str: string): string { + return print(evalMal(read(str), replEnv)); +} + +// core.EXT: defined using Racket +core.ns.forEach((value, key) => { + replEnv.set(key, value); +}); +replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { + if (!ast) { + throw new Error(`undefined argument`); + } + return evalMal(ast, replEnv); +})); +replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); +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)))))))`); + +if (typeof process !== "undefined" && 2 < process.argv.length) { + replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); + rep(`(load-file "${process.argv[2]}")`); + process.exit(0); +} + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } + } +} diff --git a/impls/ts/step9_try.ts b/impls/ts/step9_try.ts index 2e4767b517..c0e42aa28f 100644 --- a/impls/ts/step9_try.ts +++ b/impls/ts/step9_try.ts @@ -1,337 +1,337 @@ -import { readline } from "./node_readline"; - -import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; -import { Env } from "./env"; -import * as core from "./core"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -function starts_with(lst: MalType[], sym: string): boolean { - if (lst.length == 2) { - let a0 = lst[0] - switch (a0.type) { - case Node.Symbol: - return a0.v === sym; - } - } - return false; -} - -function qq_loop(elt: MalType, acc: MalList): MalList { - if (elt.type == Node.List && starts_with(elt.list, "splice-unquote")) { - return new MalList([MalSymbol.get("concat"), elt.list[1], acc]); - } else { - return new MalList([MalSymbol.get("cons"), quasiquote(elt), acc]); - } -} - -function qq_foldr(xs : MalType[]): MalList { - let acc = new MalList([]) - for (let i=xs.length-1; 0<=i; i-=1) { - acc = qq_loop(xs[i], acc) - } - return acc; -} - -function quasiquote(ast: MalType): MalType { - switch (ast.type) { - case Node.Symbol: - return new MalList([MalSymbol.get("quote"), ast]); - case Node.HashMap: - return new MalList([MalSymbol.get("quote"), ast]); - case Node.List: - if (starts_with(ast.list, "unquote")) { - return ast.list[1]; - } else { - return qq_foldr(ast.list); - } - case Node.Vector: - return new MalList([MalSymbol.get("vec"), qq_foldr(ast.list)]); - default: - return ast; - } -} - -function isMacro(ast: MalType, env: Env): boolean { - if (!isSeq(ast)) { - return false; - } - const s = ast.list[0]; - if (s.type !== Node.Symbol) { - return false; - } - const foundEnv = env.find(s); - if (!foundEnv) { - return false; - } - - const f = foundEnv.get(s); - if (f.type !== Node.Function) { - return false; - } - - return f.isMacro; -} - -function macroexpand(ast: MalType, env: Env): MalType { - while (isMacro(ast, env)) { - if (!isSeq(ast)) { - throw new Error(`unexpected token type: ${ast.type}, expected: list or vector`); - } - const s = ast.list[0]; - if (s.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${s.type}, expected: symbol`); - } - const f = env.get(s); - if (f.type !== Node.Function) { - throw new Error(`unexpected token type: ${f.type}, expected: function`); - } - ast = f.func(...ast.list.slice(1)); - } - - return ast; -} - -function evalAST(ast: MalType, env: Env): MalType { - switch (ast.type) { - case Node.Symbol: - const f = env.get(ast); - if (!f) { - throw new Error(`unknown symbol: ${ast.v}`); - } - return f; - case Node.List: - return new MalList(ast.list.map(ast => evalMal(ast, env))); - case Node.Vector: - return new MalVector(ast.list.map(ast => evalMal(ast, env))); - case Node.HashMap: - const list: MalType[] = []; - for (const [key, value] of ast.entries()) { - list.push(key); - list.push(evalMal(value, env)); - } - return new MalHashMap(list); - default: - return ast; - } -} - -// EVAL -function evalMal(ast: MalType, env: Env): MalType { - loop: while (true) { - if (ast.type !== Node.List) { - return evalAST(ast, env); - } - if (ast.list.length === 0) { - return ast; - } - - ast = macroexpand(ast, env); - if (!isSeq(ast)) { - return evalAST(ast, env); - } - - if (ast.list.length === 0) { - return ast; - } - const first = ast.list[0]; - switch (first.type) { - case Node.Symbol: - switch (first.v) { - case "def!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - return env.set(key, evalMal(value, env)); - } - case "let*": { - env = new Env(env); - const pairs = ast.list[1]; - if (!isSeq(pairs)) { - throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); - } - for (let i = 0; i < pairs.list.length; i += 2) { - const key = pairs.list[i]; - const value = pairs.list[i + 1]; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!key || !value) { - throw new Error(`unexpected syntax`); - } - - env.set(key, evalMal(value, env)); - } - ast = ast.list[2]; - continue loop; - } - case "quote": { - return ast.list[1]; - } - case "quasiquoteexpand": { - return quasiquote(ast.list[1]); - } - case "quasiquote": { - ast = quasiquote(ast.list[1]); - continue loop; - } - case "defmacro!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - const f = evalMal(value, env); - if (f.type !== Node.Function) { - throw new Error(`unexpected token type: ${f.type}, expected: function`); - } - return env.set(key, f.toMacro()); - } - case "macroexpand": { - return macroexpand(ast.list[1], env); - } - case "try*": { - try { - return evalMal(ast.list[1], env); - } catch (e) { - if (ast.list.length < 3) { - throw e; - } - const catchBody = ast.list[2]; - if (!isSeq(catchBody)) { - throw new Error(`unexpected return type: ${catchBody.type}, expected: list or vector`); - } - const catchSymbol = catchBody.list[0]; - if (catchSymbol.type === Node.Symbol && catchSymbol.v === "catch*") { - const errorSymbol = catchBody.list[1]; - if (errorSymbol.type !== Node.Symbol) { - throw new Error(`unexpected return type: ${errorSymbol.type}, expected: symbol`); - } - if (!isAST(e)) { - e = new MalString((e as Error).message); - } - return evalMal(catchBody.list[2], new Env(env, [errorSymbol], [e])); - } - throw e; - } - } - case "do": { - const list = ast.list.slice(1, -1); - evalAST(new MalList(list), env); - ast = ast.list[ast.list.length - 1]; - continue loop; - } - case "if": { - const [, cond, thenExpr, elseExrp] = ast.list; - const ret = evalMal(cond, env); - let b = true; - if (ret.type === Node.Boolean && !ret.v) { - b = false; - } else if (ret.type === Node.Nil) { - b = false; - } - if (b) { - ast = thenExpr; - } else if (elseExrp) { - ast = elseExrp; - } else { - ast = MalNil.instance; - } - continue loop; - } - case "fn*": { - const [, params, bodyAst] = ast.list; - if (!isSeq(params)) { - throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); - } - const symbols = params.list.map(param => { - if (param.type !== Node.Symbol) { - throw new Error(`unexpected return type: ${param.type}, expected: symbol`); - } - return param; - }); - return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); - } - } - } - const result = evalAST(ast, env); - if (!isSeq(result)) { - throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); - } - const [f, ...args] = result.list; - if (f.type !== Node.Function) { - throw new Error(`unexpected token: ${f.type}, expected: function`); - } - if (f.ast) { - ast = f.ast; - env = f.newEnv(args); - continue loop; - } - - return f.func(...args); - } -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -const replEnv = new Env(); -function rep(str: string): string { - return print(evalMal(read(str), replEnv)); -} - -// core.EXT: defined using Racket -core.ns.forEach((value, key) => { - replEnv.set(key, value); -}); -replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { - if (!ast) { - throw new Error(`undefined argument`); - } - return evalMal(ast, replEnv); -})); -replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); - -// core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))"); -rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); -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)))))))`); - -if (typeof process !== "undefined" && 2 < process.argv.length) { - replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); - rep(`(load-file "${process.argv[2]}")`); - process.exit(0); -} - -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - if (isAST(e)) { - console.error("Error:", prStr(e)); - } else { - const err: Error = e; - console.error("Error:", err.message); - } - } -} +import { readline } from "./node_readline"; + +import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; +import { Env } from "./env"; +import * as core from "./core"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +function starts_with(lst: MalType[], sym: string): boolean { + if (lst.length == 2) { + let a0 = lst[0] + switch (a0.type) { + case Node.Symbol: + return a0.v === sym; + } + } + return false; +} + +function qq_loop(elt: MalType, acc: MalList): MalList { + if (elt.type == Node.List && starts_with(elt.list, "splice-unquote")) { + return new MalList([MalSymbol.get("concat"), elt.list[1], acc]); + } else { + return new MalList([MalSymbol.get("cons"), quasiquote(elt), acc]); + } +} + +function qq_foldr(xs : MalType[]): MalList { + let acc = new MalList([]) + for (let i=xs.length-1; 0<=i; i-=1) { + acc = qq_loop(xs[i], acc) + } + return acc; +} + +function quasiquote(ast: MalType): MalType { + switch (ast.type) { + case Node.Symbol: + return new MalList([MalSymbol.get("quote"), ast]); + case Node.HashMap: + return new MalList([MalSymbol.get("quote"), ast]); + case Node.List: + if (starts_with(ast.list, "unquote")) { + return ast.list[1]; + } else { + return qq_foldr(ast.list); + } + case Node.Vector: + return new MalList([MalSymbol.get("vec"), qq_foldr(ast.list)]); + default: + return ast; + } +} + +function isMacro(ast: MalType, env: Env): boolean { + if (!isSeq(ast)) { + return false; + } + const s = ast.list[0]; + if (s.type !== Node.Symbol) { + return false; + } + const foundEnv = env.find(s); + if (!foundEnv) { + return false; + } + + const f = foundEnv.get(s); + if (f.type !== Node.Function) { + return false; + } + + return f.isMacro; +} + +function macroexpand(ast: MalType, env: Env): MalType { + while (isMacro(ast, env)) { + if (!isSeq(ast)) { + throw new Error(`unexpected token type: ${ast.type}, expected: list or vector`); + } + const s = ast.list[0]; + if (s.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${s.type}, expected: symbol`); + } + const f = env.get(s); + if (f.type !== Node.Function) { + throw new Error(`unexpected token type: ${f.type}, expected: function`); + } + ast = f.func(...ast.list.slice(1)); + } + + return ast; +} + +function evalAST(ast: MalType, env: Env): MalType { + switch (ast.type) { + case Node.Symbol: + const f = env.get(ast); + if (!f) { + throw new Error(`unknown symbol: ${ast.v}`); + } + return f; + case Node.List: + return new MalList(ast.list.map(ast => evalMal(ast, env))); + case Node.Vector: + return new MalVector(ast.list.map(ast => evalMal(ast, env))); + case Node.HashMap: + const list: MalType[] = []; + for (const [key, value] of ast.entries()) { + list.push(key); + list.push(evalMal(value, env)); + } + return new MalHashMap(list); + default: + return ast; + } +} + +// EVAL +function evalMal(ast: MalType, env: Env): MalType { + loop: while (true) { + if (ast.type !== Node.List) { + return evalAST(ast, env); + } + if (ast.list.length === 0) { + return ast; + } + + ast = macroexpand(ast, env); + if (!isSeq(ast)) { + return evalAST(ast, env); + } + + if (ast.list.length === 0) { + return ast; + } + const first = ast.list[0]; + switch (first.type) { + case Node.Symbol: + switch (first.v) { + case "def!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + return env.set(key, evalMal(value, env)); + } + case "let*": { + env = new Env(env); + const pairs = ast.list[1]; + if (!isSeq(pairs)) { + throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); + } + for (let i = 0; i < pairs.list.length; i += 2) { + const key = pairs.list[i]; + const value = pairs.list[i + 1]; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!key || !value) { + throw new Error(`unexpected syntax`); + } + + env.set(key, evalMal(value, env)); + } + ast = ast.list[2]; + continue loop; + } + case "quote": { + return ast.list[1]; + } + case "quasiquoteexpand": { + return quasiquote(ast.list[1]); + } + case "quasiquote": { + ast = quasiquote(ast.list[1]); + continue loop; + } + case "defmacro!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + const f = evalMal(value, env); + if (f.type !== Node.Function) { + throw new Error(`unexpected token type: ${f.type}, expected: function`); + } + return env.set(key, f.toMacro()); + } + case "macroexpand": { + return macroexpand(ast.list[1], env); + } + case "try*": { + try { + return evalMal(ast.list[1], env); + } catch (e) { + if (ast.list.length < 3) { + throw e; + } + const catchBody = ast.list[2]; + if (!isSeq(catchBody)) { + throw new Error(`unexpected return type: ${catchBody.type}, expected: list or vector`); + } + const catchSymbol = catchBody.list[0]; + if (catchSymbol.type === Node.Symbol && catchSymbol.v === "catch*") { + const errorSymbol = catchBody.list[1]; + if (errorSymbol.type !== Node.Symbol) { + throw new Error(`unexpected return type: ${errorSymbol.type}, expected: symbol`); + } + if (!isAST(e)) { + e = new MalString((e as Error).message); + } + return evalMal(catchBody.list[2], new Env(env, [errorSymbol], [e])); + } + throw e; + } + } + case "do": { + const list = ast.list.slice(1, -1); + evalAST(new MalList(list), env); + ast = ast.list[ast.list.length - 1]; + continue loop; + } + case "if": { + const [, cond, thenExpr, elseExrp] = ast.list; + const ret = evalMal(cond, env); + let b = true; + if (ret.type === Node.Boolean && !ret.v) { + b = false; + } else if (ret.type === Node.Nil) { + b = false; + } + if (b) { + ast = thenExpr; + } else if (elseExrp) { + ast = elseExrp; + } else { + ast = MalNil.instance; + } + continue loop; + } + case "fn*": { + const [, params, bodyAst] = ast.list; + if (!isSeq(params)) { + throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); + } + const symbols = params.list.map(param => { + if (param.type !== Node.Symbol) { + throw new Error(`unexpected return type: ${param.type}, expected: symbol`); + } + return param; + }); + return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); + } + } + } + const result = evalAST(ast, env); + if (!isSeq(result)) { + throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); + } + const [f, ...args] = result.list; + if (f.type !== Node.Function) { + throw new Error(`unexpected token: ${f.type}, expected: function`); + } + if (f.ast) { + ast = f.ast; + env = f.newEnv(args); + continue loop; + } + + return f.func(...args); + } +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +const replEnv = new Env(); +function rep(str: string): string { + return print(evalMal(read(str), replEnv)); +} + +// core.EXT: defined using Racket +core.ns.forEach((value, key) => { + replEnv.set(key, value); +}); +replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { + if (!ast) { + throw new Error(`undefined argument`); + } + return evalMal(ast, replEnv); +})); +replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); + +// core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))"); +rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); +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)))))))`); + +if (typeof process !== "undefined" && 2 < process.argv.length) { + replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); + rep(`(load-file "${process.argv[2]}")`); + process.exit(0); +} + +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } + } +} diff --git a/impls/ts/stepA_mal.ts b/impls/ts/stepA_mal.ts index e61f8ce30f..6487503bad 100644 --- a/impls/ts/stepA_mal.ts +++ b/impls/ts/stepA_mal.ts @@ -1,339 +1,339 @@ -import { readline } from "./node_readline"; - -import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; -import { Env } from "./env"; -import * as core from "./core"; -import { readStr } from "./reader"; -import { prStr } from "./printer"; - -// READ -function read(str: string): MalType { - return readStr(str); -} - -function starts_with(lst: MalType[], sym: string): boolean { - if (lst.length == 2) { - let a0 = lst[0] - switch (a0.type) { - case Node.Symbol: - return a0.v === sym; - } - } - return false; -} - -function qq_loop(elt: MalType, acc: MalList): MalList { - if (elt.type == Node.List && starts_with(elt.list, "splice-unquote")) { - return new MalList([MalSymbol.get("concat"), elt.list[1], acc]); - } else { - return new MalList([MalSymbol.get("cons"), quasiquote(elt), acc]); - } -} - -function qq_foldr(xs : MalType[]): MalList { - let acc = new MalList([]) - for (let i=xs.length-1; 0<=i; i-=1) { - acc = qq_loop(xs[i], acc) - } - return acc; -} - -function quasiquote(ast: MalType): MalType { - switch (ast.type) { - case Node.Symbol: - return new MalList([MalSymbol.get("quote"), ast]); - case Node.HashMap: - return new MalList([MalSymbol.get("quote"), ast]); - case Node.List: - if (starts_with(ast.list, "unquote")) { - return ast.list[1]; - } else { - return qq_foldr(ast.list); - } - case Node.Vector: - return new MalList([MalSymbol.get("vec"), qq_foldr(ast.list)]); - default: - return ast; - } -} - -function isMacro(ast: MalType, env: Env): boolean { - if (!isSeq(ast)) { - return false; - } - const s = ast.list[0]; - if (s.type !== Node.Symbol) { - return false; - } - const foundEnv = env.find(s); - if (!foundEnv) { - return false; - } - - const f = foundEnv.get(s); - if (f.type !== Node.Function) { - return false; - } - - return f.isMacro; -} - -function macroexpand(ast: MalType, env: Env): MalType { - while (isMacro(ast, env)) { - if (!isSeq(ast)) { - throw new Error(`unexpected token type: ${ast.type}, expected: list or vector`); - } - const s = ast.list[0]; - if (s.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${s.type}, expected: symbol`); - } - const f = env.get(s); - if (f.type !== Node.Function) { - throw new Error(`unexpected token type: ${f.type}, expected: function`); - } - ast = f.func(...ast.list.slice(1)); - } - - return ast; -} - -function evalAST(ast: MalType, env: Env): MalType { - switch (ast.type) { - case Node.Symbol: - const f = env.get(ast); - if (!f) { - throw new Error(`unknown symbol: ${ast.v}`); - } - return f; - case Node.List: - return new MalList(ast.list.map(ast => evalMal(ast, env))); - case Node.Vector: - return new MalVector(ast.list.map(ast => evalMal(ast, env))); - case Node.HashMap: - const list: MalType[] = []; - for (const [key, value] of ast.entries()) { - list.push(key); - list.push(evalMal(value, env)); - } - return new MalHashMap(list); - default: - return ast; - } -} - -// EVAL -function evalMal(ast: MalType, env: Env): MalType { - loop: while (true) { - if (ast.type !== Node.List) { - return evalAST(ast, env); - } - if (ast.list.length === 0) { - return ast; - } - - ast = macroexpand(ast, env); - if (!isSeq(ast)) { - return evalAST(ast, env); - } - - if (ast.list.length === 0) { - return ast; - } - const first = ast.list[0]; - switch (first.type) { - case Node.Symbol: - switch (first.v) { - case "def!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - return env.set(key, evalMal(value, env)); - } - case "let*": { - env = new Env(env); - const pairs = ast.list[1]; - if (!isSeq(pairs)) { - throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); - } - for (let i = 0; i < pairs.list.length; i += 2) { - const key = pairs.list[i]; - const value = pairs.list[i + 1]; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!key || !value) { - throw new Error(`unexpected syntax`); - } - - env.set(key, evalMal(value, env)); - } - ast = ast.list[2]; - continue loop; - } - case "quote": { - return ast.list[1]; - } - case "quasiquoteexpand": { - return quasiquote(ast.list[1]); - } - case "quasiquote": { - ast = quasiquote(ast.list[1]); - continue loop; - } - case "defmacro!": { - const [, key, value] = ast.list; - if (key.type !== Node.Symbol) { - throw new Error(`unexpected token type: ${key.type}, expected: symbol`); - } - if (!value) { - throw new Error(`unexpected syntax`); - } - const f = evalMal(value, env); - if (f.type !== Node.Function) { - throw new Error(`unexpected token type: ${f.type}, expected: function`); - } - return env.set(key, f.toMacro()); - } - case "macroexpand": { - return macroexpand(ast.list[1], env); - } - case "try*": { - try { - return evalMal(ast.list[1], env); - } catch (e) { - if (ast.list.length < 3) { - throw e; - } - const catchBody = ast.list[2]; - if (!isSeq(catchBody)) { - throw new Error(`unexpected return type: ${catchBody.type}, expected: list or vector`); - } - const catchSymbol = catchBody.list[0]; - if (catchSymbol.type === Node.Symbol && catchSymbol.v === "catch*") { - const errorSymbol = catchBody.list[1]; - if (errorSymbol.type !== Node.Symbol) { - throw new Error(`unexpected return type: ${errorSymbol.type}, expected: symbol`); - } - if (!isAST(e)) { - e = new MalString((e as Error).message); - } - return evalMal(catchBody.list[2], new Env(env, [errorSymbol], [e])); - } - throw e; - } - } - case "do": { - const list = ast.list.slice(1, -1); - evalAST(new MalList(list), env); - ast = ast.list[ast.list.length - 1]; - continue loop; - } - case "if": { - const [, cond, thenExpr, elseExrp] = ast.list; - const ret = evalMal(cond, env); - let b = true; - if (ret.type === Node.Boolean && !ret.v) { - b = false; - } else if (ret.type === Node.Nil) { - b = false; - } - if (b) { - ast = thenExpr; - } else if (elseExrp) { - ast = elseExrp; - } else { - ast = MalNil.instance; - } - continue loop; - } - case "fn*": { - const [, params, bodyAst] = ast.list; - if (!isSeq(params)) { - throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); - } - const symbols = params.list.map(param => { - if (param.type !== Node.Symbol) { - throw new Error(`unexpected return type: ${param.type}, expected: symbol`); - } - return param; - }); - return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); - } - } - } - const result = evalAST(ast, env); - if (!isSeq(result)) { - throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); - } - const [f, ...args] = result.list; - if (f.type !== Node.Function) { - throw new Error(`unexpected token: ${f.type}, expected: function`); - } - if (f.ast) { - ast = f.ast; - env = f.newEnv(args); - continue loop; - } - - return f.func(...args); - } -} - -// PRINT -function print(exp: MalType): string { - return prStr(exp); -} - -const replEnv = new Env(); -function rep(str: string): string { - return print(evalMal(read(str), replEnv)); -} - -// core.EXT: defined using Racket -core.ns.forEach((value, key) => { - replEnv.set(key, value); -}); -replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { - if (!ast) { - throw new Error(`undefined argument`); - } - return evalMal(ast, replEnv); -})); -replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); - -// core.mal: defined using the language itself -rep(`(def! *host-language* "TypeScript")`); -rep("(def! not (fn* (a) (if a false true)))"); -rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); -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)))))))`); - -if (typeof process !== "undefined" && 2 < process.argv.length) { - replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); - rep(`(load-file "${process.argv[2]}")`); - process.exit(0); -} - -rep(`(println (str "Mal [" *host-language* "]"))`); -while (true) { - const line = readline("user> "); - if (line == null) { - break; - } - if (line === "") { - continue; - } - try { - console.log(rep(line)); - } catch (e) { - if (isAST(e)) { - console.error("Error:", prStr(e)); - } else { - const err: Error = e; - console.error("Error:", err.message); - } - } -} +import { readline } from "./node_readline"; + +import { Node, MalType, MalString, MalNil, MalList, MalVector, MalHashMap, MalSymbol, MalFunction, isAST, isSeq } from "./types"; +import { Env } from "./env"; +import * as core from "./core"; +import { readStr } from "./reader"; +import { prStr } from "./printer"; + +// READ +function read(str: string): MalType { + return readStr(str); +} + +function starts_with(lst: MalType[], sym: string): boolean { + if (lst.length == 2) { + let a0 = lst[0] + switch (a0.type) { + case Node.Symbol: + return a0.v === sym; + } + } + return false; +} + +function qq_loop(elt: MalType, acc: MalList): MalList { + if (elt.type == Node.List && starts_with(elt.list, "splice-unquote")) { + return new MalList([MalSymbol.get("concat"), elt.list[1], acc]); + } else { + return new MalList([MalSymbol.get("cons"), quasiquote(elt), acc]); + } +} + +function qq_foldr(xs : MalType[]): MalList { + let acc = new MalList([]) + for (let i=xs.length-1; 0<=i; i-=1) { + acc = qq_loop(xs[i], acc) + } + return acc; +} + +function quasiquote(ast: MalType): MalType { + switch (ast.type) { + case Node.Symbol: + return new MalList([MalSymbol.get("quote"), ast]); + case Node.HashMap: + return new MalList([MalSymbol.get("quote"), ast]); + case Node.List: + if (starts_with(ast.list, "unquote")) { + return ast.list[1]; + } else { + return qq_foldr(ast.list); + } + case Node.Vector: + return new MalList([MalSymbol.get("vec"), qq_foldr(ast.list)]); + default: + return ast; + } +} + +function isMacro(ast: MalType, env: Env): boolean { + if (!isSeq(ast)) { + return false; + } + const s = ast.list[0]; + if (s.type !== Node.Symbol) { + return false; + } + const foundEnv = env.find(s); + if (!foundEnv) { + return false; + } + + const f = foundEnv.get(s); + if (f.type !== Node.Function) { + return false; + } + + return f.isMacro; +} + +function macroexpand(ast: MalType, env: Env): MalType { + while (isMacro(ast, env)) { + if (!isSeq(ast)) { + throw new Error(`unexpected token type: ${ast.type}, expected: list or vector`); + } + const s = ast.list[0]; + if (s.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${s.type}, expected: symbol`); + } + const f = env.get(s); + if (f.type !== Node.Function) { + throw new Error(`unexpected token type: ${f.type}, expected: function`); + } + ast = f.func(...ast.list.slice(1)); + } + + return ast; +} + +function evalAST(ast: MalType, env: Env): MalType { + switch (ast.type) { + case Node.Symbol: + const f = env.get(ast); + if (!f) { + throw new Error(`unknown symbol: ${ast.v}`); + } + return f; + case Node.List: + return new MalList(ast.list.map(ast => evalMal(ast, env))); + case Node.Vector: + return new MalVector(ast.list.map(ast => evalMal(ast, env))); + case Node.HashMap: + const list: MalType[] = []; + for (const [key, value] of ast.entries()) { + list.push(key); + list.push(evalMal(value, env)); + } + return new MalHashMap(list); + default: + return ast; + } +} + +// EVAL +function evalMal(ast: MalType, env: Env): MalType { + loop: while (true) { + if (ast.type !== Node.List) { + return evalAST(ast, env); + } + if (ast.list.length === 0) { + return ast; + } + + ast = macroexpand(ast, env); + if (!isSeq(ast)) { + return evalAST(ast, env); + } + + if (ast.list.length === 0) { + return ast; + } + const first = ast.list[0]; + switch (first.type) { + case Node.Symbol: + switch (first.v) { + case "def!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + return env.set(key, evalMal(value, env)); + } + case "let*": { + env = new Env(env); + const pairs = ast.list[1]; + if (!isSeq(pairs)) { + throw new Error(`unexpected token type: ${pairs.type}, expected: list or vector`); + } + for (let i = 0; i < pairs.list.length; i += 2) { + const key = pairs.list[i]; + const value = pairs.list[i + 1]; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!key || !value) { + throw new Error(`unexpected syntax`); + } + + env.set(key, evalMal(value, env)); + } + ast = ast.list[2]; + continue loop; + } + case "quote": { + return ast.list[1]; + } + case "quasiquoteexpand": { + return quasiquote(ast.list[1]); + } + case "quasiquote": { + ast = quasiquote(ast.list[1]); + continue loop; + } + case "defmacro!": { + const [, key, value] = ast.list; + if (key.type !== Node.Symbol) { + throw new Error(`unexpected token type: ${key.type}, expected: symbol`); + } + if (!value) { + throw new Error(`unexpected syntax`); + } + const f = evalMal(value, env); + if (f.type !== Node.Function) { + throw new Error(`unexpected token type: ${f.type}, expected: function`); + } + return env.set(key, f.toMacro()); + } + case "macroexpand": { + return macroexpand(ast.list[1], env); + } + case "try*": { + try { + return evalMal(ast.list[1], env); + } catch (e) { + if (ast.list.length < 3) { + throw e; + } + const catchBody = ast.list[2]; + if (!isSeq(catchBody)) { + throw new Error(`unexpected return type: ${catchBody.type}, expected: list or vector`); + } + const catchSymbol = catchBody.list[0]; + if (catchSymbol.type === Node.Symbol && catchSymbol.v === "catch*") { + const errorSymbol = catchBody.list[1]; + if (errorSymbol.type !== Node.Symbol) { + throw new Error(`unexpected return type: ${errorSymbol.type}, expected: symbol`); + } + if (!isAST(e)) { + e = new MalString((e as Error).message); + } + return evalMal(catchBody.list[2], new Env(env, [errorSymbol], [e])); + } + throw e; + } + } + case "do": { + const list = ast.list.slice(1, -1); + evalAST(new MalList(list), env); + ast = ast.list[ast.list.length - 1]; + continue loop; + } + case "if": { + const [, cond, thenExpr, elseExrp] = ast.list; + const ret = evalMal(cond, env); + let b = true; + if (ret.type === Node.Boolean && !ret.v) { + b = false; + } else if (ret.type === Node.Nil) { + b = false; + } + if (b) { + ast = thenExpr; + } else if (elseExrp) { + ast = elseExrp; + } else { + ast = MalNil.instance; + } + continue loop; + } + case "fn*": { + const [, params, bodyAst] = ast.list; + if (!isSeq(params)) { + throw new Error(`unexpected return type: ${params.type}, expected: list or vector`); + } + const symbols = params.list.map(param => { + if (param.type !== Node.Symbol) { + throw new Error(`unexpected return type: ${param.type}, expected: symbol`); + } + return param; + }); + return MalFunction.fromLisp(evalMal, env, symbols, bodyAst); + } + } + } + const result = evalAST(ast, env); + if (!isSeq(result)) { + throw new Error(`unexpected return type: ${result.type}, expected: list or vector`); + } + const [f, ...args] = result.list; + if (f.type !== Node.Function) { + throw new Error(`unexpected token: ${f.type}, expected: function`); + } + if (f.ast) { + ast = f.ast; + env = f.newEnv(args); + continue loop; + } + + return f.func(...args); + } +} + +// PRINT +function print(exp: MalType): string { + return prStr(exp); +} + +const replEnv = new Env(); +function rep(str: string): string { + return print(evalMal(read(str), replEnv)); +} + +// core.EXT: defined using Racket +core.ns.forEach((value, key) => { + replEnv.set(key, value); +}); +replEnv.set(MalSymbol.get("eval"), MalFunction.fromBootstrap(ast => { + if (!ast) { + throw new Error(`undefined argument`); + } + return evalMal(ast, replEnv); +})); +replEnv.set(MalSymbol.get("*ARGV*"), new MalList([])); + +// core.mal: defined using the language itself +rep(`(def! *host-language* "TypeScript")`); +rep("(def! not (fn* (a) (if a false true)))"); +rep(`(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))`); +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)))))))`); + +if (typeof process !== "undefined" && 2 < process.argv.length) { + replEnv.set(MalSymbol.get("*ARGV*"), new MalList(process.argv.slice(3).map(s => new MalString(s)))); + rep(`(load-file "${process.argv[2]}")`); + process.exit(0); +} + +rep(`(println (str "Mal [" *host-language* "]"))`); +while (true) { + const line = readline("user> "); + if (line == null) { + break; + } + if (line === "") { + continue; + } + try { + console.log(rep(line)); + } catch (e) { + if (isAST(e)) { + console.error("Error:", prStr(e)); + } else { + const err: Error = e; + console.error("Error:", err.message); + } + } +} diff --git a/impls/ts/tsconfig.json b/impls/ts/tsconfig.json index 94a5d7816d..8ae45ca516 100644 --- a/impls/ts/tsconfig.json +++ b/impls/ts/tsconfig.json @@ -1,21 +1,21 @@ -{ - "compilerOptions": { - "module": "commonjs", - "target": "es5", - "lib": [ - "es2015" - ], - "noImplicitAny": true, - "noEmitOnError": true, - "noImplicitReturns": true, - "noImplicitThis": true, - "noUnusedLocals": true, - "noUnusedParameters": true, - "newLine": "LF", - "strictNullChecks": true, - "sourceMap": false - }, - "exclude": [ - "node_modules" - ] -} +{ + "compilerOptions": { + "module": "commonjs", + "target": "es5", + "lib": [ + "es2015" + ], + "noImplicitAny": true, + "noEmitOnError": true, + "noImplicitReturns": true, + "noImplicitThis": true, + "noUnusedLocals": true, + "noUnusedParameters": true, + "newLine": "LF", + "strictNullChecks": true, + "sourceMap": false + }, + "exclude": [ + "node_modules" + ] +} diff --git a/impls/ts/types.ts b/impls/ts/types.ts index 0a61f2b2a2..59e7d13e83 100644 --- a/impls/ts/types.ts +++ b/impls/ts/types.ts @@ -1,411 +1,411 @@ -import { Env } from "./env"; - -export type MalType = MalList | MalNumber | MalString | MalNil | MalBoolean | MalSymbol | MalKeyword | MalVector | MalHashMap | MalFunction | MalAtom; - -export const enum Node { - List = 1, - Number, - String, - Nil, - Boolean, - Symbol, - Keyword, - Vector, - HashMap, - Function, - Atom, -} - -export function equals(a: MalType, b: MalType, strict?: boolean): boolean { - if (strict && a.type !== b.type) { - return false; - } - - if (a.type === Node.Nil && b.type === Node.Nil) { - return true; - } - if (isSeq(a) && isSeq(b)) { - return listEquals(a.list, b.list); - } - if (a.type === Node.HashMap && b.type === Node.HashMap) { - if (a.keywordMap.size !== b.keywordMap.size) { - return false; - } - if (Object.keys(a.stringMap).length !== Object.keys(b.stringMap).length) { - return false; - } - for (const [aK, aV] of a.entries()) { - if (aK.type !== Node.String && aK.type !== Node.Keyword) { - throw new Error(`unexpected symbol: ${aK.type}, expected: string or keyword`); - } - const bV = b.get(aK); - if (aV.type === Node.Nil && bV.type === Node.Nil) { - continue; - } - if (!equals(aV, bV)) { - return false; - } - } - - return true; - } - if ( - (a.type === Node.Number && b.type === Node.Number) - || (a.type === Node.String && b.type === Node.String) - || (a.type === Node.Boolean && b.type === Node.Boolean) - || (a.type === Node.Symbol && b.type === Node.Symbol) - || (a.type === Node.Keyword && b.type === Node.Keyword) - ) { - return a.v === b.v; - } - - return false; - - function listEquals(a: MalType[], b: MalType[]): boolean { - if (a.length !== b.length) { - return false; - } - for (let i = 0; i < a.length; i++) { - if (!equals(a[i], b[i], strict)) { - return false; - } - } - return true; - } -} - -export function isSeq(ast: MalType): ast is MalList | MalVector { - return ast.type === Node.List || ast.type === Node.Vector; -} - -export function isAST(v: MalType): v is MalType { - return !!v.type; -} - -export class MalList { - type: Node.List = Node.List; - meta?: MalType; - - constructor(public list: MalType[]) { - } - - withMeta(meta: MalType) { - const v = new MalList(this.list); - v.meta = meta; - return v; - } -} - -export class MalNumber { - type: Node.Number = Node.Number; - meta?: MalType; - - constructor(public v: number) { - } - - withMeta(meta: MalType) { - const v = new MalNumber(this.v); - v.meta = meta; - return v; - } -} - -export class MalString { - type: Node.String = Node.String; - meta?: MalType; - - constructor(public v: string) { - } - - withMeta(meta: MalType) { - const v = new MalString(this.v); - v.meta = meta; - return v; - } -} - -export class MalNil { - - private static _instance?: MalNil; - - static get instance(): MalNil { - if (this._instance) { - return this._instance; - } - this._instance = new MalNil(); - return this._instance; - } - - type: Node.Nil = Node.Nil; - meta?: MalType; - - private constructor() { } - - withMeta(_meta: MalType): MalNil { - throw new Error(`not supported`); - } -} - -export class MalBoolean { - type: Node.Boolean = Node.Boolean; - meta?: MalType; - - constructor(public v: boolean) { - } - - withMeta(meta: MalType) { - const v = new MalBoolean(this.v); - v.meta = meta; - return v; - } -} - -export class MalSymbol { - static map = new Map(); - - static get(name: string): MalSymbol { - const sym = Symbol.for(name); - let token = this.map.get(sym); - if (token) { - return token; - } - token = new MalSymbol(name); - this.map.set(sym, token); - return token; - } - - type: Node.Symbol = Node.Symbol; - meta?: MalType; - - private constructor(public v: string) { - } - - withMeta(_meta: MalType): MalSymbol { - throw new Error(`not supported`); - } -} - -export class MalKeyword { - static map = new Map(); - - static get(name: string): MalKeyword { - const sym = Symbol.for(name); - let token = this.map.get(sym); - if (token) { - return token; - } - token = new MalKeyword(name); - this.map.set(sym, token); - return token; - } - - type: Node.Keyword = Node.Keyword; - meta?: MalType; - - private constructor(public v: string) { - } - - withMeta(_meta: MalType): MalKeyword { - throw new Error(`not supported`); - } -} - -export class MalVector { - type: Node.Vector = Node.Vector; - meta?: MalType; - - constructor(public list: MalType[]) { - } - - withMeta(meta: MalType) { - const v = new MalVector(this.list); - v.meta = meta; - return v; - } -} - -export class MalHashMap { - type: Node.HashMap = Node.HashMap; - stringMap: { [key: string]: MalType } = {}; - keywordMap = new Map(); - meta?: MalType; - - constructor(list: MalType[]) { - while (list.length !== 0) { - const key = list.shift()!; - const value = list.shift(); - if (value == null) { - throw new Error("unexpected hash length"); - } - if (key.type === Node.Keyword) { - this.keywordMap.set(key, value); - } else if (key.type === Node.String) { - this.stringMap[key.v] = value; - } else { - throw new Error(`unexpected key symbol: ${key.type}, expected: keyword or string`); - } - } - } - - withMeta(meta: MalType) { - const v = this.assoc([]); - v.meta = meta; - return v; - } - - has(key: MalKeyword | MalString) { - if (key.type === Node.Keyword) { - return !!this.keywordMap.get(key); - } - return !!this.stringMap[key.v]; - } - - get(key: MalKeyword | MalString) { - if (key.type === Node.Keyword) { - return this.keywordMap.get(key) || MalNil.instance; - } - return this.stringMap[key.v] || MalNil.instance; - } - - entries(): [MalType, MalType][] { - const list: [MalType, MalType][] = []; - - this.keywordMap.forEach((v, k) => { - list.push([k, v]); - }); - Object.keys(this.stringMap).forEach(v => list.push([new MalString(v), this.stringMap[v]])); - - return list; - } - - keys(): MalType[] { - const list: MalType[] = []; - this.keywordMap.forEach((_v, k) => { - list.push(k); - }); - Object.keys(this.stringMap).forEach(v => list.push(new MalString(v))); - return list; - } - - vals(): MalType[] { - const list: MalType[] = []; - this.keywordMap.forEach(v => { - list.push(v); - }); - Object.keys(this.stringMap).forEach(v => list.push(this.stringMap[v])); - return list; - } - - assoc(args: MalType[]): MalHashMap { - const list: MalType[] = []; - this.keywordMap.forEach((value, key) => { - list.push(key); - list.push(value); - }); - Object.keys(this.stringMap).forEach(keyStr => { - list.push(new MalString(keyStr)); - list.push(this.stringMap[keyStr]); - }); - - return new MalHashMap(list.concat(args)); - } - - dissoc(args: MalType[]): MalHashMap { - const newHashMap = this.assoc([]); - - args.forEach(arg => { - if (arg.type === Node.String) { - delete newHashMap.stringMap[arg.v]; - } else if (arg.type === Node.Keyword) { - newHashMap.keywordMap.delete(arg); - } else { - throw new Error(`unexpected symbol: ${arg.type}, expected: keyword or string`); - } - }); - return newHashMap; - } -} - -type MalF = (...args: (MalType | undefined)[]) => MalType; - -export class MalFunction { - static fromLisp(evalMal: (ast: MalType, env: Env) => MalType, env: Env, params: MalSymbol[], bodyAst: MalType): MalFunction { - const f = new MalFunction(); - f.func = (...args) => evalMal(bodyAst, new Env(env, params, checkUndefined(args))); - f.env = env; - f.params = params; - f.ast = bodyAst; - f.isMacro = false; - - return f; - - function checkUndefined(args: (MalType | undefined)[]): MalType[] { - return args.map(arg => { - if (!arg) { - throw new Error(`undefined argument`); - } - return arg; - }); - } - } - - static fromBootstrap(func: MalF): MalFunction { - const f = new MalFunction(); - f.func = func; - f.isMacro = false; - - return f; - } - - type: Node.Function = Node.Function; - func: MalF; - ast: MalType; - env: Env; - params: MalSymbol[]; - isMacro: boolean; - meta?: MalType; - - private constructor() { } - - toMacro() { - const f = new MalFunction(); - f.func = this.func; - f.ast = this.ast; - f.env = this.env; - f.params = this.params; - f.isMacro = true; - f.meta = this.meta; - - return f; - } - - withMeta(meta: MalType) { - const f = new MalFunction(); - f.func = this.func; - f.ast = this.ast; - f.env = this.env; - f.params = this.params; - f.isMacro = this.isMacro; - f.meta = meta; - - return f; - } - - newEnv(args: MalType[]) { - return new Env(this.env, this.params, args); - } -} - -export class MalAtom { - type: Node.Atom = Node.Atom; - meta?: MalType; - - constructor(public v: MalType) { - } - - withMeta(meta: MalType) { - const v = new MalAtom(this.v); - v.meta = meta; - return v; - } +import { Env } from "./env"; + +export type MalType = MalList | MalNumber | MalString | MalNil | MalBoolean | MalSymbol | MalKeyword | MalVector | MalHashMap | MalFunction | MalAtom; + +export const enum Node { + List = 1, + Number, + String, + Nil, + Boolean, + Symbol, + Keyword, + Vector, + HashMap, + Function, + Atom, +} + +export function equals(a: MalType, b: MalType, strict?: boolean): boolean { + if (strict && a.type !== b.type) { + return false; + } + + if (a.type === Node.Nil && b.type === Node.Nil) { + return true; + } + if (isSeq(a) && isSeq(b)) { + return listEquals(a.list, b.list); + } + if (a.type === Node.HashMap && b.type === Node.HashMap) { + if (a.keywordMap.size !== b.keywordMap.size) { + return false; + } + if (Object.keys(a.stringMap).length !== Object.keys(b.stringMap).length) { + return false; + } + for (const [aK, aV] of a.entries()) { + if (aK.type !== Node.String && aK.type !== Node.Keyword) { + throw new Error(`unexpected symbol: ${aK.type}, expected: string or keyword`); + } + const bV = b.get(aK); + if (aV.type === Node.Nil && bV.type === Node.Nil) { + continue; + } + if (!equals(aV, bV)) { + return false; + } + } + + return true; + } + if ( + (a.type === Node.Number && b.type === Node.Number) + || (a.type === Node.String && b.type === Node.String) + || (a.type === Node.Boolean && b.type === Node.Boolean) + || (a.type === Node.Symbol && b.type === Node.Symbol) + || (a.type === Node.Keyword && b.type === Node.Keyword) + ) { + return a.v === b.v; + } + + return false; + + function listEquals(a: MalType[], b: MalType[]): boolean { + if (a.length !== b.length) { + return false; + } + for (let i = 0; i < a.length; i++) { + if (!equals(a[i], b[i], strict)) { + return false; + } + } + return true; + } +} + +export function isSeq(ast: MalType): ast is MalList | MalVector { + return ast.type === Node.List || ast.type === Node.Vector; +} + +export function isAST(v: MalType): v is MalType { + return !!v.type; +} + +export class MalList { + type: Node.List = Node.List; + meta?: MalType; + + constructor(public list: MalType[]) { + } + + withMeta(meta: MalType) { + const v = new MalList(this.list); + v.meta = meta; + return v; + } +} + +export class MalNumber { + type: Node.Number = Node.Number; + meta?: MalType; + + constructor(public v: number) { + } + + withMeta(meta: MalType) { + const v = new MalNumber(this.v); + v.meta = meta; + return v; + } +} + +export class MalString { + type: Node.String = Node.String; + meta?: MalType; + + constructor(public v: string) { + } + + withMeta(meta: MalType) { + const v = new MalString(this.v); + v.meta = meta; + return v; + } +} + +export class MalNil { + + private static _instance?: MalNil; + + static get instance(): MalNil { + if (this._instance) { + return this._instance; + } + this._instance = new MalNil(); + return this._instance; + } + + type: Node.Nil = Node.Nil; + meta?: MalType; + + private constructor() { } + + withMeta(_meta: MalType): MalNil { + throw new Error(`not supported`); + } +} + +export class MalBoolean { + type: Node.Boolean = Node.Boolean; + meta?: MalType; + + constructor(public v: boolean) { + } + + withMeta(meta: MalType) { + const v = new MalBoolean(this.v); + v.meta = meta; + return v; + } +} + +export class MalSymbol { + static map = new Map(); + + static get(name: string): MalSymbol { + const sym = Symbol.for(name); + let token = this.map.get(sym); + if (token) { + return token; + } + token = new MalSymbol(name); + this.map.set(sym, token); + return token; + } + + type: Node.Symbol = Node.Symbol; + meta?: MalType; + + private constructor(public v: string) { + } + + withMeta(_meta: MalType): MalSymbol { + throw new Error(`not supported`); + } +} + +export class MalKeyword { + static map = new Map(); + + static get(name: string): MalKeyword { + const sym = Symbol.for(name); + let token = this.map.get(sym); + if (token) { + return token; + } + token = new MalKeyword(name); + this.map.set(sym, token); + return token; + } + + type: Node.Keyword = Node.Keyword; + meta?: MalType; + + private constructor(public v: string) { + } + + withMeta(_meta: MalType): MalKeyword { + throw new Error(`not supported`); + } +} + +export class MalVector { + type: Node.Vector = Node.Vector; + meta?: MalType; + + constructor(public list: MalType[]) { + } + + withMeta(meta: MalType) { + const v = new MalVector(this.list); + v.meta = meta; + return v; + } +} + +export class MalHashMap { + type: Node.HashMap = Node.HashMap; + stringMap: { [key: string]: MalType } = {}; + keywordMap = new Map(); + meta?: MalType; + + constructor(list: MalType[]) { + while (list.length !== 0) { + const key = list.shift()!; + const value = list.shift(); + if (value == null) { + throw new Error("unexpected hash length"); + } + if (key.type === Node.Keyword) { + this.keywordMap.set(key, value); + } else if (key.type === Node.String) { + this.stringMap[key.v] = value; + } else { + throw new Error(`unexpected key symbol: ${key.type}, expected: keyword or string`); + } + } + } + + withMeta(meta: MalType) { + const v = this.assoc([]); + v.meta = meta; + return v; + } + + has(key: MalKeyword | MalString) { + if (key.type === Node.Keyword) { + return !!this.keywordMap.get(key); + } + return !!this.stringMap[key.v]; + } + + get(key: MalKeyword | MalString) { + if (key.type === Node.Keyword) { + return this.keywordMap.get(key) || MalNil.instance; + } + return this.stringMap[key.v] || MalNil.instance; + } + + entries(): [MalType, MalType][] { + const list: [MalType, MalType][] = []; + + this.keywordMap.forEach((v, k) => { + list.push([k, v]); + }); + Object.keys(this.stringMap).forEach(v => list.push([new MalString(v), this.stringMap[v]])); + + return list; + } + + keys(): MalType[] { + const list: MalType[] = []; + this.keywordMap.forEach((_v, k) => { + list.push(k); + }); + Object.keys(this.stringMap).forEach(v => list.push(new MalString(v))); + return list; + } + + vals(): MalType[] { + const list: MalType[] = []; + this.keywordMap.forEach(v => { + list.push(v); + }); + Object.keys(this.stringMap).forEach(v => list.push(this.stringMap[v])); + return list; + } + + assoc(args: MalType[]): MalHashMap { + const list: MalType[] = []; + this.keywordMap.forEach((value, key) => { + list.push(key); + list.push(value); + }); + Object.keys(this.stringMap).forEach(keyStr => { + list.push(new MalString(keyStr)); + list.push(this.stringMap[keyStr]); + }); + + return new MalHashMap(list.concat(args)); + } + + dissoc(args: MalType[]): MalHashMap { + const newHashMap = this.assoc([]); + + args.forEach(arg => { + if (arg.type === Node.String) { + delete newHashMap.stringMap[arg.v]; + } else if (arg.type === Node.Keyword) { + newHashMap.keywordMap.delete(arg); + } else { + throw new Error(`unexpected symbol: ${arg.type}, expected: keyword or string`); + } + }); + return newHashMap; + } +} + +type MalF = (...args: (MalType | undefined)[]) => MalType; + +export class MalFunction { + static fromLisp(evalMal: (ast: MalType, env: Env) => MalType, env: Env, params: MalSymbol[], bodyAst: MalType): MalFunction { + const f = new MalFunction(); + f.func = (...args) => evalMal(bodyAst, new Env(env, params, checkUndefined(args))); + f.env = env; + f.params = params; + f.ast = bodyAst; + f.isMacro = false; + + return f; + + function checkUndefined(args: (MalType | undefined)[]): MalType[] { + return args.map(arg => { + if (!arg) { + throw new Error(`undefined argument`); + } + return arg; + }); + } + } + + static fromBootstrap(func: MalF): MalFunction { + const f = new MalFunction(); + f.func = func; + f.isMacro = false; + + return f; + } + + type: Node.Function = Node.Function; + func: MalF; + ast: MalType; + env: Env; + params: MalSymbol[]; + isMacro: boolean; + meta?: MalType; + + private constructor() { } + + toMacro() { + const f = new MalFunction(); + f.func = this.func; + f.ast = this.ast; + f.env = this.env; + f.params = this.params; + f.isMacro = true; + f.meta = this.meta; + + return f; + } + + withMeta(meta: MalType) { + const f = new MalFunction(); + f.func = this.func; + f.ast = this.ast; + f.env = this.env; + f.params = this.params; + f.isMacro = this.isMacro; + f.meta = meta; + + return f; + } + + newEnv(args: MalType[]) { + return new Env(this.env, this.params, args); + } +} + +export class MalAtom { + type: Node.Atom = Node.Atom; + meta?: MalType; + + constructor(public v: MalType) { + } + + withMeta(meta: MalType) { + const v = new MalAtom(this.v); + v.meta = meta; + return v; + } } \ No newline at end of file diff --git a/impls/vala/.gitignore b/impls/vala/.gitignore index 71c67bdcef..43885b5633 100644 --- a/impls/vala/.gitignore +++ b/impls/vala/.gitignore @@ -1,3 +1,3 @@ -*.c -*.h -*.o +*.c +*.h +*.o diff --git a/impls/vala/Dockerfile b/impls/vala/Dockerfile index cc5e78cfe7..b36d69f5b6 100644 --- a/impls/vala/Dockerfile +++ b/impls/vala/Dockerfile @@ -1,24 +1,24 @@ -FROM ubuntu:18.04 - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Nothing additional needed for vala -RUN apt-get -y install valac +FROM ubuntu:18.04 + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Nothing additional needed for vala +RUN apt-get -y install valac diff --git a/impls/vala/Makefile b/impls/vala/Makefile index 741c8eba5a..8f64b480ae 100644 --- a/impls/vala/Makefile +++ b/impls/vala/Makefile @@ -1,52 +1,52 @@ -PROGRAMS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ - step5_tco step6_file step7_quote step8_macros step9_try stepA_mal -AUX1 = gc.vala types.vala reader.vala printer.vala -AUX3 = $(AUX1) env.vala -AUX4 = $(AUX3) core.vala - -# Inhibit default make rules, in case they try to build from leftover .c files -.SUFFIXES: - -all: $(PROGRAMS) - -# You can define VFLAGS on the command line to add flags to the vala compiler. -# Some useful ones: -# -# -g annotate the output C with #line directives so that backtraces -# from gdb, sanitisers and valgrind will list Vala source locations -# -# -X -g -X -O0 compile the output C for sensible debugging -# -# -X -fsanitize=address link the output program against Address Sanitizer -# -# --save-temps don't automatically delete the C files after compiling -# -# -D GC_STATS print statistics every time the garbage collector runs -# -# -D GC_DEBUG print full diagnostics from the garbage collector -# -# -D GC_ALWAYS make the garbage collector run at every opportunity -# (good for making occasional GC errors show up sooner) - -$(PROGRAMS): %: %.vala - valac $(VFLAGS) -o $@ $^ $(DEFINES) --pkg readline -X -lreadline - -step1_read_print step2_eval: override DEFINES += -D NO_ENV - -step0_repl: -step1_read_print: $(AUX1) -step2_eval: $(AUX1) -step3_env: $(AUX3) -step4_if_fn_do: $(AUX4) -step5_tco: $(AUX4) -step6_file: $(AUX4) -step7_quote: $(AUX4) -step8_macros: $(AUX4) -step9_try: $(AUX4) -stepA_mal: $(AUX4) - -clean: clean-c - rm -f $(PROGRAMS) - -clean-c: - rm -f *.c *.h +PROGRAMS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ + step5_tco step6_file step7_quote step8_macros step9_try stepA_mal +AUX1 = gc.vala types.vala reader.vala printer.vala +AUX3 = $(AUX1) env.vala +AUX4 = $(AUX3) core.vala + +# Inhibit default make rules, in case they try to build from leftover .c files +.SUFFIXES: + +all: $(PROGRAMS) + +# You can define VFLAGS on the command line to add flags to the vala compiler. +# Some useful ones: +# +# -g annotate the output C with #line directives so that backtraces +# from gdb, sanitisers and valgrind will list Vala source locations +# +# -X -g -X -O0 compile the output C for sensible debugging +# +# -X -fsanitize=address link the output program against Address Sanitizer +# +# --save-temps don't automatically delete the C files after compiling +# +# -D GC_STATS print statistics every time the garbage collector runs +# +# -D GC_DEBUG print full diagnostics from the garbage collector +# +# -D GC_ALWAYS make the garbage collector run at every opportunity +# (good for making occasional GC errors show up sooner) + +$(PROGRAMS): %: %.vala + valac $(VFLAGS) -o $@ $^ $(DEFINES) --pkg readline -X -lreadline + +step1_read_print step2_eval: override DEFINES += -D NO_ENV + +step0_repl: +step1_read_print: $(AUX1) +step2_eval: $(AUX1) +step3_env: $(AUX3) +step4_if_fn_do: $(AUX4) +step5_tco: $(AUX4) +step6_file: $(AUX4) +step7_quote: $(AUX4) +step8_macros: $(AUX4) +step9_try: $(AUX4) +stepA_mal: $(AUX4) + +clean: clean-c + rm -f $(PROGRAMS) + +clean-c: + rm -f *.c *.h diff --git a/impls/vala/README.md b/impls/vala/README.md index 6ae562e2b3..8c2b9f560b 100644 --- a/impls/vala/README.md +++ b/impls/vala/README.md @@ -1,60 +1,60 @@ -# Vala implementation - -Notes on building: - -* With the Debian or Ubuntu packages `valac` and `libreadline-dev` - installed, and GNU make, you should be able to build using the - provided Makefile. - -* The build will not be warning-clean, because the shared modules like - `types.vala` and `core.vala` are shared between all the `stepN` main - programs, and not all the steps use all the functions in the shared - modules, and the Vala compiler has no way to turn off the warning - about unused pieces of source code. - -* The Vala compiler works by translating the program to C and then - compiling that. The C compilation stage can sometimes encounter an - error, in which case the compiler will leave `.c` source files in - the working directory. If that happens, you can run `make clean-c` - to get rid of them. - -Design notes on the implementation: - -* Vala has exceptions (which it calls 'error domains'), but they don't - let you store an arbitrary data type: every exception subclass you - make stores the same data, namely a string. So mal exceptions are - implemented by storing a mal value in a static variable, and then - throwing a particular Vala error whose semantics are 'check that - variable when you catch me'. - -* Vala's bare function pointers are hard to use, especially if you - want one to survive the scope it was created in. So all the core - functions are implemented as classes with a `call` method, which - leads to a lot of boilerplate. - -* To make `types.vala` work in step 2, when the `Env` type doesn't - exist yet, I had to use `#if` to condition out the parts of the code - that depend on that type. - -* Mutability of objects at the Vala level is a bit informal. A lot of - core functions construct a list by making an empty `Mal.List` and - then mutating the `GLib.List` contained in it. But once they've - finished and returned the `Mal.List` to their caller, that list is - never mutated again, which means it's safe for the copying operation - in `with-meta` to make a second `Mal.List` sharing the reference to - the same `GLib.List`. - -* Vala has a reference counting system built in to the language, but - that's not enough to implement mal sensibly, because the common - construction `(def! FUNC (fn* [ARGS] BODY))` causes a length-2 cycle - of references: the environment captured in `FUNC`'s function object - is the same one where `def!` inserts the definition of `FUNC`, so - the function and environment both link to each other. And either - element of the cycle could end up being the last one referred to - from elsewhere, so you can't break the link by just making the right - one of those references weak. So instead there's a small garbage - collector in `gc.vala`, which works by being the only part of the - program that keeps a non-weak reference to any `Mal.Val` or - `Mal.Env`: it links all GCable objects together into a list, and - when the collector runs, it unlinks dead objects from that list and - allows Vala's normal reference counting to free them. +# Vala implementation + +Notes on building: + +* With the Debian or Ubuntu packages `valac` and `libreadline-dev` + installed, and GNU make, you should be able to build using the + provided Makefile. + +* The build will not be warning-clean, because the shared modules like + `types.vala` and `core.vala` are shared between all the `stepN` main + programs, and not all the steps use all the functions in the shared + modules, and the Vala compiler has no way to turn off the warning + about unused pieces of source code. + +* The Vala compiler works by translating the program to C and then + compiling that. The C compilation stage can sometimes encounter an + error, in which case the compiler will leave `.c` source files in + the working directory. If that happens, you can run `make clean-c` + to get rid of them. + +Design notes on the implementation: + +* Vala has exceptions (which it calls 'error domains'), but they don't + let you store an arbitrary data type: every exception subclass you + make stores the same data, namely a string. So mal exceptions are + implemented by storing a mal value in a static variable, and then + throwing a particular Vala error whose semantics are 'check that + variable when you catch me'. + +* Vala's bare function pointers are hard to use, especially if you + want one to survive the scope it was created in. So all the core + functions are implemented as classes with a `call` method, which + leads to a lot of boilerplate. + +* To make `types.vala` work in step 2, when the `Env` type doesn't + exist yet, I had to use `#if` to condition out the parts of the code + that depend on that type. + +* Mutability of objects at the Vala level is a bit informal. A lot of + core functions construct a list by making an empty `Mal.List` and + then mutating the `GLib.List` contained in it. But once they've + finished and returned the `Mal.List` to their caller, that list is + never mutated again, which means it's safe for the copying operation + in `with-meta` to make a second `Mal.List` sharing the reference to + the same `GLib.List`. + +* Vala has a reference counting system built in to the language, but + that's not enough to implement mal sensibly, because the common + construction `(def! FUNC (fn* [ARGS] BODY))` causes a length-2 cycle + of references: the environment captured in `FUNC`'s function object + is the same one where `def!` inserts the definition of `FUNC`, so + the function and environment both link to each other. And either + element of the cycle could end up being the last one referred to + from elsewhere, so you can't break the link by just making the right + one of those references weak. So instead there's a small garbage + collector in `gc.vala`, which works by being the only part of the + program that keeps a non-weak reference to any `Mal.Val` or + `Mal.Env`: it links all GCable objects together into a list, and + when the collector runs, it unlinks dead objects from that list and + allows Vala's normal reference counting to free them. diff --git a/impls/vala/core.vala b/impls/vala/core.vala index bed6c33c2e..1b11e0c2bb 100644 --- a/impls/vala/core.vala +++ b/impls/vala/core.vala @@ -1,1203 +1,1203 @@ -abstract class Mal.BuiltinFunctionDyadicArithmetic : Mal.BuiltinFunction { - public abstract int64 result(int64 a, int64 b); - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); - Mal.Num a = args.vs.data as Mal.Num; - Mal.Num b = args.vs.next.data as Mal.Num; - if (a == null || b == null) - throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); - return new Mal.Num(result(a.v, b.v)); - } -} - -class Mal.BuiltinFunctionAdd : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionAdd(); - } - public override string name() { return "+"; } - public override int64 result(int64 a, int64 b) { return a+b; } -} - -class Mal.BuiltinFunctionSub : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionSub(); - } - public override string name() { return "-"; } - public override int64 result(int64 a, int64 b) { return a-b; } -} - -class Mal.BuiltinFunctionMul : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionMul(); - } - public override string name() { return "*"; } - public override int64 result(int64 a, int64 b) { return a*b; } -} - -class Mal.BuiltinFunctionDiv : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionDiv(); - } - public override string name() { return "/"; } - public override int64 result(int64 a, int64 b) { return a/b; } -} - -class Mal.BuiltinFunctionPrStr : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionPrStr(); - } - public override string name() { return "pr-str"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - string result = ""; - string sep = ""; - foreach (var value in args.vs) { - result += sep + pr_str(value, true); - sep = " "; - } - return new Mal.String(result); - } -} - -class Mal.BuiltinFunctionStr : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionStr(); - } - public override string name() { return "str"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - string result = ""; - foreach (var value in args.vs) { - result += pr_str(value, false); - } - return new Mal.String(result); - } -} - -class Mal.BuiltinFunctionPrn : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionPrn(); - } - public override string name() { return "prn"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - string sep = ""; - foreach (var value in args.vs) { - stdout.printf("%s%s", sep, pr_str(value, true)); - sep = " "; - } - stdout.printf("\n"); - return new Mal.Nil(); - } -} - -class Mal.BuiltinFunctionPrintln : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionPrintln(); - } - public override string name() { return "println"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - string sep = ""; - foreach (var value in args.vs) { - stdout.printf("%s%s", sep, pr_str(value, false)); - sep = " "; - } - stdout.printf("\n"); - return new Mal.Nil(); - } -} - -class Mal.BuiltinFunctionReadString : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionReadString(); - } - public override string name() { return "read-string"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1 || !(args.vs.data is Mal.String)) - throw new Mal.Error.BAD_PARAMS("%s: expected one string", name()); - return Reader.read_str((args.vs.data as Mal.String).v); - } -} - -class Mal.BuiltinFunctionSlurp : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionSlurp(); - } - public override string name() { return "slurp"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1 || !(args.vs.data is Mal.String)) - throw new Mal.Error.BAD_PARAMS("%s: expected one string", name()); - string filename = (args.vs.data as Mal.String).v; - string contents; - try { - FileUtils.get_contents(filename, out contents); - } catch (FileError e) { - throw new Mal.Error.BAD_PARAMS("%s: unable to read '%s': %s", - name(), filename, e.message); - } - return new Mal.String(contents); - } -} - -class Mal.BuiltinFunctionList : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionList(); - } - public override string name() { return "list"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - return args; - } -} - -class Mal.BuiltinFunctionListP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionListP(); - } - public override string name() { return "list?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.List); - } -} - -class Mal.BuiltinFunctionSequentialP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionSequentialP(); - } - public override string name() { return "sequential?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.List || - args.vs.data is Mal.Vector); - } -} - -class Mal.BuiltinFunctionNilP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionNilP(); - } - public override string name() { return "nil?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.Nil); - } -} - -class Mal.BuiltinFunctionTrueP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionTrueP(); - } - public override string name() { return "true?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.Bool && - (args.vs.data as Mal.Bool).v); - } -} - -class Mal.BuiltinFunctionFalseP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionFalseP(); - } - public override string name() { return "false?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.Bool && - !(args.vs.data as Mal.Bool).v); - } -} - -class Mal.BuiltinFunctionNumberP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionNumberP(); - } - public override string name() { return "number?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.Num); - } -} - -class Mal.BuiltinFunctionStringP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionStringP(); - } - public override string name() { return "string?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.String); - } -} - -class Mal.BuiltinFunctionSymbolP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionSymbolP(); - } - public override string name() { return "symbol?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.Sym); - } -} - -class Mal.BuiltinFunctionKeywordP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionKeywordP(); - } - public override string name() { return "keyword?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.Keyword); - } -} - -class Mal.BuiltinFunctionVector : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionVector(); - } - public override string name() { return "vector"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - return new Mal.Vector.from_list(args.vs); - } -} - -class Mal.BuiltinFunctionVectorP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionVectorP(); - } - public override string name() { return "vector?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.Vector); - } -} - -class Mal.BuiltinFunctionHashMap : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionHashMap(); - } - public override string name() { return "hash-map"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - var map = new Mal.Hashmap(); - for (var iter = args.iter(); iter.nonempty(); iter.step()) { - var key = iter.deref(); - var value = iter.step().deref(); - if (value == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected an even number of arguments", name()); - map.insert(key, value); - } - return map; - } -} - -class Mal.BuiltinFunctionMapP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionMapP(); - } - public override string name() { return "map?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.Hashmap); - } -} - -class Mal.BuiltinFunctionEmptyP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionEmptyP(); - } - public override string name() { return "empty?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - var list = args.vs.data as Mal.Listlike; - if (list == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a list-like argument", name()); - return new Mal.Bool(list.iter().deref() == null); - } -} - -class Mal.BuiltinFunctionFnP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionFnP(); - } - public override string name() { return "fn?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - if (args.vs.data is Mal.BuiltinFunction) - return new Mal.Bool(true); - var fn = args.vs.data as Mal.Function; - return new Mal.Bool(fn != null && !fn.is_macro); - } -} - -class Mal.BuiltinFunctionMacroP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionMacroP(); - } - public override string name() { return "macro?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - var fn = args.vs.data as Mal.Function; - return new Mal.Bool(fn != null && fn.is_macro); - } -} - -class Mal.BuiltinFunctionCount : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionCount(); - } - public override string name() { return "count"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - if (args.vs.data is Mal.Nil) - return new Mal.Num(0); // nil is treated like () - if (args.vs.data is Mal.List) - return new Mal.Num((args.vs.data as Mal.List).vs.length()); - if (args.vs.data is Mal.Vector) - return new Mal.Num((args.vs.data as Mal.Vector).length); - throw new Mal.Error.BAD_PARAMS( - "%s: expected a list argument", name()); - } -} - -class Mal.BuiltinFunctionEQ : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionEQ(); - } - public override string name() { return "="; } - private static bool eq(Mal.Val a, Mal.Val b) { - if (a is Mal.Nil && b is Mal.Nil) - return true; - if (a is Mal.Bool && b is Mal.Bool) - return (a as Mal.Bool).v == (b as Mal.Bool).v; - if (a is Mal.Sym && b is Mal.Sym) - return (a as Mal.Sym).v == (b as Mal.Sym).v; - if (a is Mal.Keyword && b is Mal.Keyword) - return (a as Mal.Keyword).v == (b as Mal.Keyword).v; - if (a is Mal.Num && b is Mal.Num) - return (a as Mal.Num).v == (b as Mal.Num).v; - if (a is Mal.String && b is Mal.String) - return (a as Mal.String).v == (b as Mal.String).v; - if (a is Mal.Listlike && b is Mal.Listlike) { - if (a is Mal.Nil || b is Mal.Nil) - return false; - var aiter = (a as Mal.Listlike).iter(); - var biter = (b as Mal.Listlike).iter(); - while (aiter.nonempty() || biter.nonempty()) { - if (aiter.empty() || biter.empty()) - return false; - if (!eq(aiter.deref(), biter.deref())) - return false; - aiter.step(); - biter.step(); - } - return true; - } - if (a is Mal.Vector && b is Mal.Vector) { - var av = a as Mal.Vector; - var bv = b as Mal.Vector; - if (av.length != bv.length) - return false; - for (var i = 0; i < av.length; i++) - if (!eq(av[i], bv[i])) - return false; - return true; - } - if (a is Mal.Hashmap && b is Mal.Hashmap) { - var ah = (a as Mal.Hashmap).vs; - var bh = (b as Mal.Hashmap).vs; - if (ah.length != bh.length) - return false; - foreach (var k in ah.get_keys()) { - var av = ah[k]; - var bv = bh[k]; - if (bv == null || !eq(av, bv)) - return false; - } - return true; - } - if (a is Mal.BuiltinFunction && b is Mal.BuiltinFunction) { - return ((a as Mal.BuiltinFunction).name() == - (b as Mal.BuiltinFunction).name()); - } - if (a is Mal.Function && b is Mal.Function) { - var af = a as Mal.Function; - var bf = b as Mal.Function; - return (eq(af.parameters, bf.parameters) && - eq(af.body, bf.body)); - } - return false; - } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected two arguments", name()); - return new Mal.Bool(eq(args.vs.data, args.vs.next.data)); - } -} - -abstract class Mal.BuiltinFunctionNumberCmp : Mal.BuiltinFunction { - public abstract bool result(int64 a, int64 b); - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); - Mal.Num a = args.vs.data as Mal.Num; - Mal.Num b = args.vs.next.data as Mal.Num; - if (a == null || b == null) - throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); - return new Mal.Bool(result(a.v, b.v)); - } -} - -class Mal.BuiltinFunctionLT : Mal.BuiltinFunctionNumberCmp { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionLT(); - } - public override string name() { return "<"; } - public override bool result(int64 a, int64 b) { return a"; } - public override bool result(int64 a, int64 b) { return a>b; } -} - -class Mal.BuiltinFunctionGE : Mal.BuiltinFunctionNumberCmp { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionGE(); - } - public override string name() { return ">="; } - public override bool result(int64 a, int64 b) { return a>=b; } -} - -class Mal.BuiltinFunctionAtom : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionAtom(); - } - public override string name() { return "atom"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Atom(args.vs.data); - } -} - -class Mal.BuiltinFunctionAtomP : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionAtomP(); - } - public override string name() { return "atom?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return new Mal.Bool(args.vs.data is Mal.Atom); - } -} - -class Mal.BuiltinFunctionDeref : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionDeref(); - } - public override string name() { return "deref"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - var atom = args.vs.data as Mal.Atom; - if (atom == null) - throw new Mal.Error.BAD_PARAMS("%s: expected an atom", name()); - return atom.v; - } -} - -class Mal.BuiltinFunctionReset : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionReset(); - } - public override string name() { return "reset!"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected two arguments", name()); - var atom = args.vs.data as Mal.Atom; - if (atom == null) - throw new Mal.Error.BAD_PARAMS("%s: expected an atom", name()); - atom.v = args.vs.next.data; - return atom.v; - } -} - -Mal.Val call_function(Mal.Val function, GLib.List args, string caller) -throws Mal.Error { - var fnargs = new Mal.List(args); - if (function is Mal.BuiltinFunction) { - return (function as Mal.BuiltinFunction).call(fnargs); - } else if (function is Mal.Function) { - var fn = function as Mal.Function; - var env = new Mal.Env.funcall(fn.env, fn.parameters, fnargs); - return Mal.Main.EVAL(fn.body, env); - } else { - throw new Mal.Error.CANNOT_APPLY("%s: expected a function", caller); - } -} - -class Mal.BuiltinFunctionSwap : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionSwap(); - } - public override string name() { return "swap!"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() < 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected at least two arguments", name()); - var atom = args.vs.data as Mal.Atom; - var function = args.vs.next.data; - var fnargs = args.vs.next.next.copy(); - fnargs.prepend(atom.v); - atom.v = call_function(function, fnargs, name()); - return atom.v; - } -} - -class Mal.BuiltinFunctionCons : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionCons(); - } - public override string name() { return "cons"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected two arguments", name()); - var first = args.vs.data; - var rest = args.vs.next.data as Mal.Listlike; - if (rest == null) { - if (args.vs.next.data is Mal.Nil) - rest = new Mal.List.empty(); - else - throw new Mal.Error.BAD_PARAMS("%s: expected a list", name()); - } - var newlist = new Mal.List.empty(); - newlist.vs.append(first); - for (var iter = rest.iter(); iter.nonempty(); iter.step()) - newlist.vs.append(iter.deref()); - return newlist; - } -} - -class Mal.BuiltinFunctionConcat : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionConcat(); - } - public override string name() { return "concat"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - var newlist = new GLib.List(); - foreach (var listval in args.vs) { - if (listval is Mal.Nil) - continue; - var list = listval as Mal.Listlike; - if (list == null) - throw new Mal.Error.BAD_PARAMS("%s: expected a list", name()); - for (var iter = list.iter(); iter.nonempty(); iter.step()) - newlist.append(iter.deref()); - } - return new Mal.List(newlist); - } -} - -class Mal.BuiltinFunctionVec : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionVec(); - } - public override string name() { return "vec"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - var a0 = args.vs.data; - if (a0 is Mal.List) - return new Mal.Vector.from_list((a0 as Mal.List).vs); - if (a0 is Mal.Vector) - return a0; - throw new Mal.Error.BAD_PARAMS( - "%s: expected a list or a vector", name()); - } -} - -class Mal.BuiltinFunctionNth : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionNth(); - } - public override string name() { return "nth"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected two arguments", name()); - var list = args.vs.data as Mal.Listlike; - var index = args.vs.next.data as Mal.Num; - if (list == null || index == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a list and a number", name()); - if (index.v < 0) - throw new Mal.Error.BAD_PARAMS( - "%s: negative list index", name()); - Mal.Val? result = null; - if (list is Mal.Vector) { - var vec = list as Mal.Vector; - if (index.v < vec.length) - result = vec[(uint)index.v]; - } else { - var iter = list.iter(); - var i = index.v; - while (!iter.empty()) { - if (i == 0) { - result = iter.deref(); - break; - } - iter.step(); - i--; - } - } - if (result == null) - throw new Mal.Error.BAD_PARAMS( - "%s: list index out of range", name()); - return result; - } -} - -class Mal.BuiltinFunctionFirst : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionFirst(); - } - public override string name() { return "first"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS( - "%s: expected two arguments", name()); - var list = args.vs.data as Mal.Listlike; - if (list == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a list number", name()); - Mal.Val? result = list.iter().deref(); - if (result == null) - result = new Mal.Nil(); - return result; - } -} - -class Mal.BuiltinFunctionRest : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionRest(); - } - public override string name() { return "rest"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS( - "%s: expected two arguments", name()); - var list = args.vs.data as Mal.Listlike; - if (list == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a list", name()); - var result = new Mal.List.empty(); - for (var iter = list.iter().step(); iter.nonempty(); iter.step()) - result.vs.append(iter.deref()); - return result; - } -} - -class Mal.BuiltinFunctionThrow : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionThrow(); - } - private static Mal.Val? curr_exception; - static construct { - curr_exception = null; - } - public static void clear() { - curr_exception = null; - } - public static Mal.Val thrown_value(Mal.Error err) { - if (err is Mal.Error.EXCEPTION_THROWN) { - assert(curr_exception != null); - Mal.Val toret = curr_exception; - curr_exception = null; - return toret; - } else { - return new Mal.String(err.message); - } - } - - public override string name() { return "throw"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - assert(curr_exception == null); - curr_exception = args.vs.data; - throw new Mal.Error.EXCEPTION_THROWN("core function throw called"); - } -} - -class Mal.BuiltinFunctionApply : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionApply(); - } - public override string name() { return "apply"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() < 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected at least two arguments", name()); - var function = args.vs.data; - unowned GLib.List lastlink = args.vs.last(); - var list = lastlink.data as Mal.Listlike; - if (list == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected final argument to be a list", name()); - var fnargs = new GLib.List(); - for (var iter = list.iter(); iter.nonempty(); iter.step()) - fnargs.append(iter.deref()); - for (unowned GLib.List link = lastlink.prev; - link != args.vs; link = link.prev) - fnargs.prepend(link.data); - return call_function(function, fnargs, name()); - } -} - -class Mal.BuiltinFunctionMap : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionMap(); - } - public override string name() { return "map"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected two arguments", name()); - var function = args.vs.data; - var list = args.vs.next.data as Mal.Listlike; - if (list == null) - throw new Mal.Error.BAD_PARAMS("%s: expected a list", name()); - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - for (var iter = list.iter(); iter.nonempty(); iter.step()) { - var fnargs = new GLib.List(); - fnargs.append(iter.deref()); - result.vs.append(call_function(function, fnargs, name())); - } - return result; - } -} - -class Mal.BuiltinFunctionSymbol : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionSymbol(); - } - public override string name() { return "symbol"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1 || !(args.vs.data is Mal.String)) - throw new Mal.Error.BAD_PARAMS("%s: expected one string", name()); - return new Mal.Sym((args.vs.data as Mal.String).v); - } -} - -class Mal.BuiltinFunctionKeyword : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionKeyword(); - } - public override string name() { return "keyword"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1 || !(args.vs.data is Mal.String)) - throw new Mal.Error.BAD_PARAMS("%s: expected one string", name()); - return new Mal.Keyword((args.vs.data as Mal.String).v); - } -} - -class Mal.BuiltinFunctionAssoc : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionAssoc(); - } - public override string name() { return "assoc"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - var iter = args.iter(); - var oldmap = iter.deref() as Mal.Hashmap; - if (iter.deref() is Mal.Nil) - oldmap = new Mal.Hashmap(); - if (oldmap == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a hash-map to modify", name()); - - var map = new Mal.Hashmap(); - foreach (var key in oldmap.vs.get_keys()) - map.insert(key, oldmap.vs[key]); - - for (iter.step(); iter.nonempty(); iter.step()) { - var key = iter.deref(); - var value = iter.step().deref(); - if (value == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected an even number of arguments", name()); - map.insert(key, value); - } - return map; - } -} - -class Mal.BuiltinFunctionDissoc : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionDissoc(); - } - public override string name() { return "dissoc"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - var iter = args.iter(); - var oldmap = iter.deref() as Mal.Hashmap; - if (iter.deref() is Mal.Nil) - oldmap = new Mal.Hashmap(); - if (oldmap == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a hash-map to modify", name()); - - var map = new Mal.Hashmap(); - foreach (var key in oldmap.vs.get_keys()) - map.insert(key, oldmap.vs[key]); - - for (iter.step(); iter.nonempty(); iter.step()) { - var key = iter.deref(); - map.remove(key); - } - return map; - } -} - -// Can't call it BuiltinFunctionGet, or else valac defines -// BUILTIN_FUNCTION_GET_CLASS at the C level for this class, but that -// was already defined as the 'get class' macro for BuiltinFunction -// itself! -class Mal.BuiltinFunctionGetFn : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionGetFn(); - } - public override string name() { return "get"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected two arguments", name()); - if (args.vs.data is Mal.Nil) - return new Mal.Nil(); - var map = args.vs.data as Mal.Hashmap; - if (map == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a hash-map to query", name()); - var key = args.vs.next.data as Mal.Hashable; - if (key == null) - throw new Mal.Error.HASH_KEY_TYPE_ERROR( - "%s: bad type as hash key", name()); - var value = map.vs[key]; - return value != null ? value : new Mal.Nil(); - } -} - -class Mal.BuiltinFunctionContains : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionContains(); - } - public override string name() { return "contains?"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected two arguments", name()); - if (args.vs.data is Mal.Nil) - return new Mal.Bool(false); - var map = args.vs.data as Mal.Hashmap; - if (map == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a hash-map to query", name()); - var key = args.vs.next.data as Mal.Hashable; - if (key == null) - throw new Mal.Error.HASH_KEY_TYPE_ERROR( - "%s: bad type as hash key", name()); - var value = map.vs[key]; - return new Mal.Bool(value != null); - } -} - -class Mal.BuiltinFunctionKeys : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionKeys(); - } - public override string name() { return "keys"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS( - "%s: expected one argument", name()); - var keys = new Mal.List.empty(); - if (args.vs.data is Mal.Nil) - return keys; - var map = args.vs.data as Mal.Hashmap; - if (map == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a hash-map to query", name()); - foreach (var key in map.vs.get_keys()) - keys.vs.append(key); - return keys; - } -} - -class Mal.BuiltinFunctionVals : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionVals(); - } - public override string name() { return "vals"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS( - "%s: expected one argument", name()); - var vals = new Mal.List.empty(); - if (args.vs.data is Mal.Nil) - return vals; - var map = args.vs.data as Mal.Hashmap; - if (map == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a hash-map to query", name()); - foreach (var key in map.vs.get_keys()) - vals.vs.append(map.vs[key]); - return vals; - } -} - -class Mal.BuiltinFunctionReadline : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionReadline(); - } - public override string name() { return "readline"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS( - "%s: expected one argument", name()); - string prompt = ""; - if (args.vs.data is Mal.String) - prompt = (args.vs.data as Mal.String).v; - else if (!(args.vs.data is Mal.Nil)) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a string prompt", name()); - string? line = Readline.readline(prompt); - if (line == null) - return new Mal.Nil(); - return new Mal.String(line); - } -} - -class Mal.BuiltinFunctionMeta : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionMeta(); - } - public override string name() { return "meta"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS( - "%s: expected one argument", name()); - var vwm = args.vs.data as Mal.ValWithMetadata; - if (vwm == null || vwm.metadata == null) - return new Mal.Nil(); - return vwm.metadata; - } -} - -class Mal.BuiltinFunctionWithMeta : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionWithMeta(); - } - public override string name() { return "with-meta"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "%s: expected one argument", name()); - var vwm = args.vs.data as Mal.ValWithMetadata; - if (vwm == null) - throw new Mal.Error.BAD_PARAMS( - "%s: bad type for with-meta", name()); - var copied = vwm.copy(); - copied.metadata = args.vs.next.data; - return copied; - } -} - -class Mal.BuiltinFunctionTimeMs : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionTimeMs(); - } - public override string name() { return "time-ms"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 0) - throw new Mal.Error.BAD_PARAMS( - "%s: expected no arguments", name()); - var time = GLib.TimeVal(); - time.get_current_time(); - return new Mal.Num(time.tv_sec * 1000 + time.tv_usec / 1000); - } -} - -class Mal.BuiltinFunctionConj : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionConj(); - } - public override string name() { return "conj"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - var iter = args.iter(); - var collection = iter.deref() as Mal.Listlike; - if (collection == null) - throw new Mal.Error.BAD_PARAMS( - "%s: expected a collection to modify", name()); - - if (collection is Mal.Vector) { - var oldvec = collection as Mal.Vector; - var n = args.vs.length() - 1; - var newvec = new Mal.Vector.with_size(oldvec.length + n); - int i; - for (i = 0; i < oldvec.length; i++) - newvec[i] = oldvec[i]; - for (iter.step(); iter.nonempty(); iter.step(), i++) - newvec[i] = iter.deref(); - return newvec; - } else { - var newlist = new Mal.List.empty(); - for (var citer = collection.iter(); citer.nonempty(); citer.step()) - newlist.vs.append(citer.deref()); - for (iter.step(); iter.nonempty(); iter.step()) - newlist.vs.prepend(iter.deref()); - return newlist; - } - } -} - -class Mal.BuiltinFunctionSeq : Mal.BuiltinFunction { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionSeq(); - } - public override string name() { return "seq"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS( - "%s: expected one argument", name()); - Mal.List toret; - if (args.vs.data is Mal.List) { - toret = args.vs.data as Mal.List; - } else { - toret = new Mal.List.empty(); - if (args.vs.data is Mal.String) { - var str = (args.vs.data as Mal.String).v; - if (str.length != 0) { - unowned string tail = str; - while (tail != "") { - unowned string new_tail = tail.next_char(); - var ch = str.substring(str.length - tail.length, - tail.length - new_tail.length); - toret.vs.append(new Mal.String(ch)); - tail = new_tail; - } - } - } else if (args.vs.data is Mal.Listlike) { - var collection = args.vs.data as Mal.Listlike; - for (var iter = collection.iter(); iter.nonempty(); iter.step()) - toret.vs.append(iter.deref()); - } else { - throw new Mal.Error.BAD_PARAMS("%s: bad input type", name()); - } - } - if (toret.vs.length() == 0) - return new Mal.Nil(); - return toret; - } -} - -class Mal.Core { - public static GLib.HashTable ns; - - private static void add_builtin(Mal.BuiltinFunction f) { - ns[f.name()] = f; - } - - public static void make_ns() { - ns = new GLib.HashTable(str_hash, str_equal); - add_builtin(new BuiltinFunctionAdd()); - add_builtin(new BuiltinFunctionSub()); - add_builtin(new BuiltinFunctionMul()); - add_builtin(new BuiltinFunctionDiv()); - add_builtin(new BuiltinFunctionPrStr()); - add_builtin(new BuiltinFunctionStr()); - add_builtin(new BuiltinFunctionPrn()); - add_builtin(new BuiltinFunctionPrintln()); - add_builtin(new BuiltinFunctionReadString()); - add_builtin(new BuiltinFunctionSlurp()); - add_builtin(new BuiltinFunctionList()); - add_builtin(new BuiltinFunctionListP()); - add_builtin(new BuiltinFunctionNilP()); - add_builtin(new BuiltinFunctionTrueP()); - add_builtin(new BuiltinFunctionFalseP()); - add_builtin(new BuiltinFunctionNumberP()); - add_builtin(new BuiltinFunctionStringP()); - add_builtin(new BuiltinFunctionSymbol()); - add_builtin(new BuiltinFunctionSymbolP()); - add_builtin(new BuiltinFunctionKeyword()); - add_builtin(new BuiltinFunctionKeywordP()); - add_builtin(new BuiltinFunctionVector()); - add_builtin(new BuiltinFunctionVectorP()); - add_builtin(new BuiltinFunctionSequentialP()); - add_builtin(new BuiltinFunctionHashMap()); - add_builtin(new BuiltinFunctionMapP()); - add_builtin(new BuiltinFunctionEmptyP()); - add_builtin(new BuiltinFunctionFnP()); - add_builtin(new BuiltinFunctionMacroP()); - add_builtin(new BuiltinFunctionCount()); - add_builtin(new BuiltinFunctionEQ()); - add_builtin(new BuiltinFunctionLT()); - add_builtin(new BuiltinFunctionLE()); - add_builtin(new BuiltinFunctionGT()); - add_builtin(new BuiltinFunctionGE()); - add_builtin(new BuiltinFunctionAtom()); - add_builtin(new BuiltinFunctionAtomP()); - add_builtin(new BuiltinFunctionDeref()); - add_builtin(new BuiltinFunctionReset()); - add_builtin(new BuiltinFunctionSwap()); - add_builtin(new BuiltinFunctionCons()); - add_builtin(new BuiltinFunctionConcat()); - add_builtin(new BuiltinFunctionVec()); - add_builtin(new BuiltinFunctionNth()); - add_builtin(new BuiltinFunctionFirst()); - add_builtin(new BuiltinFunctionRest()); - add_builtin(new BuiltinFunctionThrow()); - add_builtin(new BuiltinFunctionApply()); - add_builtin(new BuiltinFunctionMap()); - add_builtin(new BuiltinFunctionAssoc()); - add_builtin(new BuiltinFunctionDissoc()); - add_builtin(new BuiltinFunctionGetFn()); - add_builtin(new BuiltinFunctionContains()); - add_builtin(new BuiltinFunctionKeys()); - add_builtin(new BuiltinFunctionVals()); - add_builtin(new BuiltinFunctionReadline()); - add_builtin(new BuiltinFunctionMeta()); - add_builtin(new BuiltinFunctionWithMeta()); - add_builtin(new BuiltinFunctionTimeMs()); - add_builtin(new BuiltinFunctionConj()); - add_builtin(new BuiltinFunctionSeq()); - } -} +abstract class Mal.BuiltinFunctionDyadicArithmetic : Mal.BuiltinFunction { + public abstract int64 result(int64 a, int64 b); + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); + Mal.Num a = args.vs.data as Mal.Num; + Mal.Num b = args.vs.next.data as Mal.Num; + if (a == null || b == null) + throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); + return new Mal.Num(result(a.v, b.v)); + } +} + +class Mal.BuiltinFunctionAdd : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionAdd(); + } + public override string name() { return "+"; } + public override int64 result(int64 a, int64 b) { return a+b; } +} + +class Mal.BuiltinFunctionSub : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionSub(); + } + public override string name() { return "-"; } + public override int64 result(int64 a, int64 b) { return a-b; } +} + +class Mal.BuiltinFunctionMul : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionMul(); + } + public override string name() { return "*"; } + public override int64 result(int64 a, int64 b) { return a*b; } +} + +class Mal.BuiltinFunctionDiv : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionDiv(); + } + public override string name() { return "/"; } + public override int64 result(int64 a, int64 b) { return a/b; } +} + +class Mal.BuiltinFunctionPrStr : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionPrStr(); + } + public override string name() { return "pr-str"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + string result = ""; + string sep = ""; + foreach (var value in args.vs) { + result += sep + pr_str(value, true); + sep = " "; + } + return new Mal.String(result); + } +} + +class Mal.BuiltinFunctionStr : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionStr(); + } + public override string name() { return "str"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + string result = ""; + foreach (var value in args.vs) { + result += pr_str(value, false); + } + return new Mal.String(result); + } +} + +class Mal.BuiltinFunctionPrn : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionPrn(); + } + public override string name() { return "prn"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + string sep = ""; + foreach (var value in args.vs) { + stdout.printf("%s%s", sep, pr_str(value, true)); + sep = " "; + } + stdout.printf("\n"); + return new Mal.Nil(); + } +} + +class Mal.BuiltinFunctionPrintln : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionPrintln(); + } + public override string name() { return "println"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + string sep = ""; + foreach (var value in args.vs) { + stdout.printf("%s%s", sep, pr_str(value, false)); + sep = " "; + } + stdout.printf("\n"); + return new Mal.Nil(); + } +} + +class Mal.BuiltinFunctionReadString : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionReadString(); + } + public override string name() { return "read-string"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1 || !(args.vs.data is Mal.String)) + throw new Mal.Error.BAD_PARAMS("%s: expected one string", name()); + return Reader.read_str((args.vs.data as Mal.String).v); + } +} + +class Mal.BuiltinFunctionSlurp : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionSlurp(); + } + public override string name() { return "slurp"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1 || !(args.vs.data is Mal.String)) + throw new Mal.Error.BAD_PARAMS("%s: expected one string", name()); + string filename = (args.vs.data as Mal.String).v; + string contents; + try { + FileUtils.get_contents(filename, out contents); + } catch (FileError e) { + throw new Mal.Error.BAD_PARAMS("%s: unable to read '%s': %s", + name(), filename, e.message); + } + return new Mal.String(contents); + } +} + +class Mal.BuiltinFunctionList : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionList(); + } + public override string name() { return "list"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + return args; + } +} + +class Mal.BuiltinFunctionListP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionListP(); + } + public override string name() { return "list?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.List); + } +} + +class Mal.BuiltinFunctionSequentialP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionSequentialP(); + } + public override string name() { return "sequential?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.List || + args.vs.data is Mal.Vector); + } +} + +class Mal.BuiltinFunctionNilP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionNilP(); + } + public override string name() { return "nil?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.Nil); + } +} + +class Mal.BuiltinFunctionTrueP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionTrueP(); + } + public override string name() { return "true?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.Bool && + (args.vs.data as Mal.Bool).v); + } +} + +class Mal.BuiltinFunctionFalseP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionFalseP(); + } + public override string name() { return "false?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.Bool && + !(args.vs.data as Mal.Bool).v); + } +} + +class Mal.BuiltinFunctionNumberP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionNumberP(); + } + public override string name() { return "number?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.Num); + } +} + +class Mal.BuiltinFunctionStringP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionStringP(); + } + public override string name() { return "string?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.String); + } +} + +class Mal.BuiltinFunctionSymbolP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionSymbolP(); + } + public override string name() { return "symbol?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.Sym); + } +} + +class Mal.BuiltinFunctionKeywordP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionKeywordP(); + } + public override string name() { return "keyword?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.Keyword); + } +} + +class Mal.BuiltinFunctionVector : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionVector(); + } + public override string name() { return "vector"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + return new Mal.Vector.from_list(args.vs); + } +} + +class Mal.BuiltinFunctionVectorP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionVectorP(); + } + public override string name() { return "vector?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.Vector); + } +} + +class Mal.BuiltinFunctionHashMap : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionHashMap(); + } + public override string name() { return "hash-map"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + var map = new Mal.Hashmap(); + for (var iter = args.iter(); iter.nonempty(); iter.step()) { + var key = iter.deref(); + var value = iter.step().deref(); + if (value == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected an even number of arguments", name()); + map.insert(key, value); + } + return map; + } +} + +class Mal.BuiltinFunctionMapP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionMapP(); + } + public override string name() { return "map?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.Hashmap); + } +} + +class Mal.BuiltinFunctionEmptyP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionEmptyP(); + } + public override string name() { return "empty?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + var list = args.vs.data as Mal.Listlike; + if (list == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a list-like argument", name()); + return new Mal.Bool(list.iter().deref() == null); + } +} + +class Mal.BuiltinFunctionFnP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionFnP(); + } + public override string name() { return "fn?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + if (args.vs.data is Mal.BuiltinFunction) + return new Mal.Bool(true); + var fn = args.vs.data as Mal.Function; + return new Mal.Bool(fn != null && !fn.is_macro); + } +} + +class Mal.BuiltinFunctionMacroP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionMacroP(); + } + public override string name() { return "macro?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + var fn = args.vs.data as Mal.Function; + return new Mal.Bool(fn != null && fn.is_macro); + } +} + +class Mal.BuiltinFunctionCount : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionCount(); + } + public override string name() { return "count"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + if (args.vs.data is Mal.Nil) + return new Mal.Num(0); // nil is treated like () + if (args.vs.data is Mal.List) + return new Mal.Num((args.vs.data as Mal.List).vs.length()); + if (args.vs.data is Mal.Vector) + return new Mal.Num((args.vs.data as Mal.Vector).length); + throw new Mal.Error.BAD_PARAMS( + "%s: expected a list argument", name()); + } +} + +class Mal.BuiltinFunctionEQ : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionEQ(); + } + public override string name() { return "="; } + private static bool eq(Mal.Val a, Mal.Val b) { + if (a is Mal.Nil && b is Mal.Nil) + return true; + if (a is Mal.Bool && b is Mal.Bool) + return (a as Mal.Bool).v == (b as Mal.Bool).v; + if (a is Mal.Sym && b is Mal.Sym) + return (a as Mal.Sym).v == (b as Mal.Sym).v; + if (a is Mal.Keyword && b is Mal.Keyword) + return (a as Mal.Keyword).v == (b as Mal.Keyword).v; + if (a is Mal.Num && b is Mal.Num) + return (a as Mal.Num).v == (b as Mal.Num).v; + if (a is Mal.String && b is Mal.String) + return (a as Mal.String).v == (b as Mal.String).v; + if (a is Mal.Listlike && b is Mal.Listlike) { + if (a is Mal.Nil || b is Mal.Nil) + return false; + var aiter = (a as Mal.Listlike).iter(); + var biter = (b as Mal.Listlike).iter(); + while (aiter.nonempty() || biter.nonempty()) { + if (aiter.empty() || biter.empty()) + return false; + if (!eq(aiter.deref(), biter.deref())) + return false; + aiter.step(); + biter.step(); + } + return true; + } + if (a is Mal.Vector && b is Mal.Vector) { + var av = a as Mal.Vector; + var bv = b as Mal.Vector; + if (av.length != bv.length) + return false; + for (var i = 0; i < av.length; i++) + if (!eq(av[i], bv[i])) + return false; + return true; + } + if (a is Mal.Hashmap && b is Mal.Hashmap) { + var ah = (a as Mal.Hashmap).vs; + var bh = (b as Mal.Hashmap).vs; + if (ah.length != bh.length) + return false; + foreach (var k in ah.get_keys()) { + var av = ah[k]; + var bv = bh[k]; + if (bv == null || !eq(av, bv)) + return false; + } + return true; + } + if (a is Mal.BuiltinFunction && b is Mal.BuiltinFunction) { + return ((a as Mal.BuiltinFunction).name() == + (b as Mal.BuiltinFunction).name()); + } + if (a is Mal.Function && b is Mal.Function) { + var af = a as Mal.Function; + var bf = b as Mal.Function; + return (eq(af.parameters, bf.parameters) && + eq(af.body, bf.body)); + } + return false; + } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected two arguments", name()); + return new Mal.Bool(eq(args.vs.data, args.vs.next.data)); + } +} + +abstract class Mal.BuiltinFunctionNumberCmp : Mal.BuiltinFunction { + public abstract bool result(int64 a, int64 b); + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); + Mal.Num a = args.vs.data as Mal.Num; + Mal.Num b = args.vs.next.data as Mal.Num; + if (a == null || b == null) + throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); + return new Mal.Bool(result(a.v, b.v)); + } +} + +class Mal.BuiltinFunctionLT : Mal.BuiltinFunctionNumberCmp { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionLT(); + } + public override string name() { return "<"; } + public override bool result(int64 a, int64 b) { return a"; } + public override bool result(int64 a, int64 b) { return a>b; } +} + +class Mal.BuiltinFunctionGE : Mal.BuiltinFunctionNumberCmp { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionGE(); + } + public override string name() { return ">="; } + public override bool result(int64 a, int64 b) { return a>=b; } +} + +class Mal.BuiltinFunctionAtom : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionAtom(); + } + public override string name() { return "atom"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Atom(args.vs.data); + } +} + +class Mal.BuiltinFunctionAtomP : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionAtomP(); + } + public override string name() { return "atom?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return new Mal.Bool(args.vs.data is Mal.Atom); + } +} + +class Mal.BuiltinFunctionDeref : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionDeref(); + } + public override string name() { return "deref"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + var atom = args.vs.data as Mal.Atom; + if (atom == null) + throw new Mal.Error.BAD_PARAMS("%s: expected an atom", name()); + return atom.v; + } +} + +class Mal.BuiltinFunctionReset : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionReset(); + } + public override string name() { return "reset!"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected two arguments", name()); + var atom = args.vs.data as Mal.Atom; + if (atom == null) + throw new Mal.Error.BAD_PARAMS("%s: expected an atom", name()); + atom.v = args.vs.next.data; + return atom.v; + } +} + +Mal.Val call_function(Mal.Val function, GLib.List args, string caller) +throws Mal.Error { + var fnargs = new Mal.List(args); + if (function is Mal.BuiltinFunction) { + return (function as Mal.BuiltinFunction).call(fnargs); + } else if (function is Mal.Function) { + var fn = function as Mal.Function; + var env = new Mal.Env.funcall(fn.env, fn.parameters, fnargs); + return Mal.Main.EVAL(fn.body, env); + } else { + throw new Mal.Error.CANNOT_APPLY("%s: expected a function", caller); + } +} + +class Mal.BuiltinFunctionSwap : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionSwap(); + } + public override string name() { return "swap!"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() < 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected at least two arguments", name()); + var atom = args.vs.data as Mal.Atom; + var function = args.vs.next.data; + var fnargs = args.vs.next.next.copy(); + fnargs.prepend(atom.v); + atom.v = call_function(function, fnargs, name()); + return atom.v; + } +} + +class Mal.BuiltinFunctionCons : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionCons(); + } + public override string name() { return "cons"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected two arguments", name()); + var first = args.vs.data; + var rest = args.vs.next.data as Mal.Listlike; + if (rest == null) { + if (args.vs.next.data is Mal.Nil) + rest = new Mal.List.empty(); + else + throw new Mal.Error.BAD_PARAMS("%s: expected a list", name()); + } + var newlist = new Mal.List.empty(); + newlist.vs.append(first); + for (var iter = rest.iter(); iter.nonempty(); iter.step()) + newlist.vs.append(iter.deref()); + return newlist; + } +} + +class Mal.BuiltinFunctionConcat : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionConcat(); + } + public override string name() { return "concat"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + var newlist = new GLib.List(); + foreach (var listval in args.vs) { + if (listval is Mal.Nil) + continue; + var list = listval as Mal.Listlike; + if (list == null) + throw new Mal.Error.BAD_PARAMS("%s: expected a list", name()); + for (var iter = list.iter(); iter.nonempty(); iter.step()) + newlist.append(iter.deref()); + } + return new Mal.List(newlist); + } +} + +class Mal.BuiltinFunctionVec : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionVec(); + } + public override string name() { return "vec"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + var a0 = args.vs.data; + if (a0 is Mal.List) + return new Mal.Vector.from_list((a0 as Mal.List).vs); + if (a0 is Mal.Vector) + return a0; + throw new Mal.Error.BAD_PARAMS( + "%s: expected a list or a vector", name()); + } +} + +class Mal.BuiltinFunctionNth : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionNth(); + } + public override string name() { return "nth"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected two arguments", name()); + var list = args.vs.data as Mal.Listlike; + var index = args.vs.next.data as Mal.Num; + if (list == null || index == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a list and a number", name()); + if (index.v < 0) + throw new Mal.Error.BAD_PARAMS( + "%s: negative list index", name()); + Mal.Val? result = null; + if (list is Mal.Vector) { + var vec = list as Mal.Vector; + if (index.v < vec.length) + result = vec[(uint)index.v]; + } else { + var iter = list.iter(); + var i = index.v; + while (!iter.empty()) { + if (i == 0) { + result = iter.deref(); + break; + } + iter.step(); + i--; + } + } + if (result == null) + throw new Mal.Error.BAD_PARAMS( + "%s: list index out of range", name()); + return result; + } +} + +class Mal.BuiltinFunctionFirst : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionFirst(); + } + public override string name() { return "first"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS( + "%s: expected two arguments", name()); + var list = args.vs.data as Mal.Listlike; + if (list == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a list number", name()); + Mal.Val? result = list.iter().deref(); + if (result == null) + result = new Mal.Nil(); + return result; + } +} + +class Mal.BuiltinFunctionRest : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionRest(); + } + public override string name() { return "rest"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS( + "%s: expected two arguments", name()); + var list = args.vs.data as Mal.Listlike; + if (list == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a list", name()); + var result = new Mal.List.empty(); + for (var iter = list.iter().step(); iter.nonempty(); iter.step()) + result.vs.append(iter.deref()); + return result; + } +} + +class Mal.BuiltinFunctionThrow : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionThrow(); + } + private static Mal.Val? curr_exception; + static construct { + curr_exception = null; + } + public static void clear() { + curr_exception = null; + } + public static Mal.Val thrown_value(Mal.Error err) { + if (err is Mal.Error.EXCEPTION_THROWN) { + assert(curr_exception != null); + Mal.Val toret = curr_exception; + curr_exception = null; + return toret; + } else { + return new Mal.String(err.message); + } + } + + public override string name() { return "throw"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + assert(curr_exception == null); + curr_exception = args.vs.data; + throw new Mal.Error.EXCEPTION_THROWN("core function throw called"); + } +} + +class Mal.BuiltinFunctionApply : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionApply(); + } + public override string name() { return "apply"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() < 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected at least two arguments", name()); + var function = args.vs.data; + unowned GLib.List lastlink = args.vs.last(); + var list = lastlink.data as Mal.Listlike; + if (list == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected final argument to be a list", name()); + var fnargs = new GLib.List(); + for (var iter = list.iter(); iter.nonempty(); iter.step()) + fnargs.append(iter.deref()); + for (unowned GLib.List link = lastlink.prev; + link != args.vs; link = link.prev) + fnargs.prepend(link.data); + return call_function(function, fnargs, name()); + } +} + +class Mal.BuiltinFunctionMap : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionMap(); + } + public override string name() { return "map"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected two arguments", name()); + var function = args.vs.data; + var list = args.vs.next.data as Mal.Listlike; + if (list == null) + throw new Mal.Error.BAD_PARAMS("%s: expected a list", name()); + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + for (var iter = list.iter(); iter.nonempty(); iter.step()) { + var fnargs = new GLib.List(); + fnargs.append(iter.deref()); + result.vs.append(call_function(function, fnargs, name())); + } + return result; + } +} + +class Mal.BuiltinFunctionSymbol : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionSymbol(); + } + public override string name() { return "symbol"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1 || !(args.vs.data is Mal.String)) + throw new Mal.Error.BAD_PARAMS("%s: expected one string", name()); + return new Mal.Sym((args.vs.data as Mal.String).v); + } +} + +class Mal.BuiltinFunctionKeyword : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionKeyword(); + } + public override string name() { return "keyword"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1 || !(args.vs.data is Mal.String)) + throw new Mal.Error.BAD_PARAMS("%s: expected one string", name()); + return new Mal.Keyword((args.vs.data as Mal.String).v); + } +} + +class Mal.BuiltinFunctionAssoc : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionAssoc(); + } + public override string name() { return "assoc"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + var iter = args.iter(); + var oldmap = iter.deref() as Mal.Hashmap; + if (iter.deref() is Mal.Nil) + oldmap = new Mal.Hashmap(); + if (oldmap == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a hash-map to modify", name()); + + var map = new Mal.Hashmap(); + foreach (var key in oldmap.vs.get_keys()) + map.insert(key, oldmap.vs[key]); + + for (iter.step(); iter.nonempty(); iter.step()) { + var key = iter.deref(); + var value = iter.step().deref(); + if (value == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected an even number of arguments", name()); + map.insert(key, value); + } + return map; + } +} + +class Mal.BuiltinFunctionDissoc : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionDissoc(); + } + public override string name() { return "dissoc"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + var iter = args.iter(); + var oldmap = iter.deref() as Mal.Hashmap; + if (iter.deref() is Mal.Nil) + oldmap = new Mal.Hashmap(); + if (oldmap == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a hash-map to modify", name()); + + var map = new Mal.Hashmap(); + foreach (var key in oldmap.vs.get_keys()) + map.insert(key, oldmap.vs[key]); + + for (iter.step(); iter.nonempty(); iter.step()) { + var key = iter.deref(); + map.remove(key); + } + return map; + } +} + +// Can't call it BuiltinFunctionGet, or else valac defines +// BUILTIN_FUNCTION_GET_CLASS at the C level for this class, but that +// was already defined as the 'get class' macro for BuiltinFunction +// itself! +class Mal.BuiltinFunctionGetFn : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionGetFn(); + } + public override string name() { return "get"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected two arguments", name()); + if (args.vs.data is Mal.Nil) + return new Mal.Nil(); + var map = args.vs.data as Mal.Hashmap; + if (map == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a hash-map to query", name()); + var key = args.vs.next.data as Mal.Hashable; + if (key == null) + throw new Mal.Error.HASH_KEY_TYPE_ERROR( + "%s: bad type as hash key", name()); + var value = map.vs[key]; + return value != null ? value : new Mal.Nil(); + } +} + +class Mal.BuiltinFunctionContains : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionContains(); + } + public override string name() { return "contains?"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected two arguments", name()); + if (args.vs.data is Mal.Nil) + return new Mal.Bool(false); + var map = args.vs.data as Mal.Hashmap; + if (map == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a hash-map to query", name()); + var key = args.vs.next.data as Mal.Hashable; + if (key == null) + throw new Mal.Error.HASH_KEY_TYPE_ERROR( + "%s: bad type as hash key", name()); + var value = map.vs[key]; + return new Mal.Bool(value != null); + } +} + +class Mal.BuiltinFunctionKeys : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionKeys(); + } + public override string name() { return "keys"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS( + "%s: expected one argument", name()); + var keys = new Mal.List.empty(); + if (args.vs.data is Mal.Nil) + return keys; + var map = args.vs.data as Mal.Hashmap; + if (map == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a hash-map to query", name()); + foreach (var key in map.vs.get_keys()) + keys.vs.append(key); + return keys; + } +} + +class Mal.BuiltinFunctionVals : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionVals(); + } + public override string name() { return "vals"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS( + "%s: expected one argument", name()); + var vals = new Mal.List.empty(); + if (args.vs.data is Mal.Nil) + return vals; + var map = args.vs.data as Mal.Hashmap; + if (map == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a hash-map to query", name()); + foreach (var key in map.vs.get_keys()) + vals.vs.append(map.vs[key]); + return vals; + } +} + +class Mal.BuiltinFunctionReadline : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionReadline(); + } + public override string name() { return "readline"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS( + "%s: expected one argument", name()); + string prompt = ""; + if (args.vs.data is Mal.String) + prompt = (args.vs.data as Mal.String).v; + else if (!(args.vs.data is Mal.Nil)) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a string prompt", name()); + string? line = Readline.readline(prompt); + if (line == null) + return new Mal.Nil(); + return new Mal.String(line); + } +} + +class Mal.BuiltinFunctionMeta : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionMeta(); + } + public override string name() { return "meta"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS( + "%s: expected one argument", name()); + var vwm = args.vs.data as Mal.ValWithMetadata; + if (vwm == null || vwm.metadata == null) + return new Mal.Nil(); + return vwm.metadata; + } +} + +class Mal.BuiltinFunctionWithMeta : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionWithMeta(); + } + public override string name() { return "with-meta"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "%s: expected one argument", name()); + var vwm = args.vs.data as Mal.ValWithMetadata; + if (vwm == null) + throw new Mal.Error.BAD_PARAMS( + "%s: bad type for with-meta", name()); + var copied = vwm.copy(); + copied.metadata = args.vs.next.data; + return copied; + } +} + +class Mal.BuiltinFunctionTimeMs : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionTimeMs(); + } + public override string name() { return "time-ms"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 0) + throw new Mal.Error.BAD_PARAMS( + "%s: expected no arguments", name()); + var time = GLib.TimeVal(); + time.get_current_time(); + return new Mal.Num(time.tv_sec * 1000 + time.tv_usec / 1000); + } +} + +class Mal.BuiltinFunctionConj : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionConj(); + } + public override string name() { return "conj"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + var iter = args.iter(); + var collection = iter.deref() as Mal.Listlike; + if (collection == null) + throw new Mal.Error.BAD_PARAMS( + "%s: expected a collection to modify", name()); + + if (collection is Mal.Vector) { + var oldvec = collection as Mal.Vector; + var n = args.vs.length() - 1; + var newvec = new Mal.Vector.with_size(oldvec.length + n); + int i; + for (i = 0; i < oldvec.length; i++) + newvec[i] = oldvec[i]; + for (iter.step(); iter.nonempty(); iter.step(), i++) + newvec[i] = iter.deref(); + return newvec; + } else { + var newlist = new Mal.List.empty(); + for (var citer = collection.iter(); citer.nonempty(); citer.step()) + newlist.vs.append(citer.deref()); + for (iter.step(); iter.nonempty(); iter.step()) + newlist.vs.prepend(iter.deref()); + return newlist; + } + } +} + +class Mal.BuiltinFunctionSeq : Mal.BuiltinFunction { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionSeq(); + } + public override string name() { return "seq"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS( + "%s: expected one argument", name()); + Mal.List toret; + if (args.vs.data is Mal.List) { + toret = args.vs.data as Mal.List; + } else { + toret = new Mal.List.empty(); + if (args.vs.data is Mal.String) { + var str = (args.vs.data as Mal.String).v; + if (str.length != 0) { + unowned string tail = str; + while (tail != "") { + unowned string new_tail = tail.next_char(); + var ch = str.substring(str.length - tail.length, + tail.length - new_tail.length); + toret.vs.append(new Mal.String(ch)); + tail = new_tail; + } + } + } else if (args.vs.data is Mal.Listlike) { + var collection = args.vs.data as Mal.Listlike; + for (var iter = collection.iter(); iter.nonempty(); iter.step()) + toret.vs.append(iter.deref()); + } else { + throw new Mal.Error.BAD_PARAMS("%s: bad input type", name()); + } + } + if (toret.vs.length() == 0) + return new Mal.Nil(); + return toret; + } +} + +class Mal.Core { + public static GLib.HashTable ns; + + private static void add_builtin(Mal.BuiltinFunction f) { + ns[f.name()] = f; + } + + public static void make_ns() { + ns = new GLib.HashTable(str_hash, str_equal); + add_builtin(new BuiltinFunctionAdd()); + add_builtin(new BuiltinFunctionSub()); + add_builtin(new BuiltinFunctionMul()); + add_builtin(new BuiltinFunctionDiv()); + add_builtin(new BuiltinFunctionPrStr()); + add_builtin(new BuiltinFunctionStr()); + add_builtin(new BuiltinFunctionPrn()); + add_builtin(new BuiltinFunctionPrintln()); + add_builtin(new BuiltinFunctionReadString()); + add_builtin(new BuiltinFunctionSlurp()); + add_builtin(new BuiltinFunctionList()); + add_builtin(new BuiltinFunctionListP()); + add_builtin(new BuiltinFunctionNilP()); + add_builtin(new BuiltinFunctionTrueP()); + add_builtin(new BuiltinFunctionFalseP()); + add_builtin(new BuiltinFunctionNumberP()); + add_builtin(new BuiltinFunctionStringP()); + add_builtin(new BuiltinFunctionSymbol()); + add_builtin(new BuiltinFunctionSymbolP()); + add_builtin(new BuiltinFunctionKeyword()); + add_builtin(new BuiltinFunctionKeywordP()); + add_builtin(new BuiltinFunctionVector()); + add_builtin(new BuiltinFunctionVectorP()); + add_builtin(new BuiltinFunctionSequentialP()); + add_builtin(new BuiltinFunctionHashMap()); + add_builtin(new BuiltinFunctionMapP()); + add_builtin(new BuiltinFunctionEmptyP()); + add_builtin(new BuiltinFunctionFnP()); + add_builtin(new BuiltinFunctionMacroP()); + add_builtin(new BuiltinFunctionCount()); + add_builtin(new BuiltinFunctionEQ()); + add_builtin(new BuiltinFunctionLT()); + add_builtin(new BuiltinFunctionLE()); + add_builtin(new BuiltinFunctionGT()); + add_builtin(new BuiltinFunctionGE()); + add_builtin(new BuiltinFunctionAtom()); + add_builtin(new BuiltinFunctionAtomP()); + add_builtin(new BuiltinFunctionDeref()); + add_builtin(new BuiltinFunctionReset()); + add_builtin(new BuiltinFunctionSwap()); + add_builtin(new BuiltinFunctionCons()); + add_builtin(new BuiltinFunctionConcat()); + add_builtin(new BuiltinFunctionVec()); + add_builtin(new BuiltinFunctionNth()); + add_builtin(new BuiltinFunctionFirst()); + add_builtin(new BuiltinFunctionRest()); + add_builtin(new BuiltinFunctionThrow()); + add_builtin(new BuiltinFunctionApply()); + add_builtin(new BuiltinFunctionMap()); + add_builtin(new BuiltinFunctionAssoc()); + add_builtin(new BuiltinFunctionDissoc()); + add_builtin(new BuiltinFunctionGetFn()); + add_builtin(new BuiltinFunctionContains()); + add_builtin(new BuiltinFunctionKeys()); + add_builtin(new BuiltinFunctionVals()); + add_builtin(new BuiltinFunctionReadline()); + add_builtin(new BuiltinFunctionMeta()); + add_builtin(new BuiltinFunctionWithMeta()); + add_builtin(new BuiltinFunctionTimeMs()); + add_builtin(new BuiltinFunctionConj()); + add_builtin(new BuiltinFunctionSeq()); + } +} diff --git a/impls/vala/env.vala b/impls/vala/env.vala index ffe9cfdd7b..da45542059 100644 --- a/impls/vala/env.vala +++ b/impls/vala/env.vala @@ -1,76 +1,76 @@ -class Mal.Env : GC.Object { - private GLib.HashTable data; - weak Mal.Env? outer; - - construct { - data = new GLib.HashTable( - Mal.Hashable.hash, Mal.Hashable.equal); - } - - public Env.within(Mal.Env outer_) { - outer = outer_; - } - - public Env() { - outer = null; - } - - public override void gc_traverse(GC.Object.VisitorFunc visit) { - visit(outer); - foreach (var key in data.get_keys()) { - visit(key); - visit(data[key]); - } - } - - public Env.funcall(Mal.Env outer_, Mal.Listlike binds, Mal.List exprs) - throws Mal.Error { - outer = outer_; - var binditer = binds.iter(); - unowned GLib.List exprlist = exprs.vs; - - while (binditer.nonempty()) { - var paramsym = binditer.deref() as Mal.Sym; - if (paramsym.v == "&") { - binditer.step(); - var rest = binditer.deref(); - binditer.step(); - if (rest == null || binditer.nonempty()) - throw new Mal.Error.BAD_PARAMS( - "expected exactly one parameter name after &"); - set(rest as Mal.Sym, new Mal.List(exprlist.copy())); - return; - } else { - if (exprlist == null) - throw new Mal.Error.BAD_PARAMS( - "too few arguments for function"); - set(paramsym, exprlist.data); - binditer.step(); - exprlist = exprlist.next; - } - } - if (exprlist != null) - throw new Mal.Error.BAD_PARAMS("too many arguments for function"); - } - - // Use the 'new' keyword to silence warnings about 'set' and 'get' - // already having meanings that we're overwriting - public new void set(Mal.Sym key, Mal.Val f) { - data[key] = f; - } - - public Mal.Env? find(Mal.Sym key) { - if (key in data) - return this; - if (outer == null) - return null; - return outer.find(key); - } - - public new Mal.Val get(Mal.Sym key) throws Mal.Error { - var found = find(key); - if (found == null) - throw new Error.ENV_LOOKUP_FAILED("'%s' not found", key.v); - return found.data[key]; - } -} +class Mal.Env : GC.Object { + private GLib.HashTable data; + weak Mal.Env? outer; + + construct { + data = new GLib.HashTable( + Mal.Hashable.hash, Mal.Hashable.equal); + } + + public Env.within(Mal.Env outer_) { + outer = outer_; + } + + public Env() { + outer = null; + } + + public override void gc_traverse(GC.Object.VisitorFunc visit) { + visit(outer); + foreach (var key in data.get_keys()) { + visit(key); + visit(data[key]); + } + } + + public Env.funcall(Mal.Env outer_, Mal.Listlike binds, Mal.List exprs) + throws Mal.Error { + outer = outer_; + var binditer = binds.iter(); + unowned GLib.List exprlist = exprs.vs; + + while (binditer.nonempty()) { + var paramsym = binditer.deref() as Mal.Sym; + if (paramsym.v == "&") { + binditer.step(); + var rest = binditer.deref(); + binditer.step(); + if (rest == null || binditer.nonempty()) + throw new Mal.Error.BAD_PARAMS( + "expected exactly one parameter name after &"); + set(rest as Mal.Sym, new Mal.List(exprlist.copy())); + return; + } else { + if (exprlist == null) + throw new Mal.Error.BAD_PARAMS( + "too few arguments for function"); + set(paramsym, exprlist.data); + binditer.step(); + exprlist = exprlist.next; + } + } + if (exprlist != null) + throw new Mal.Error.BAD_PARAMS("too many arguments for function"); + } + + // Use the 'new' keyword to silence warnings about 'set' and 'get' + // already having meanings that we're overwriting + public new void set(Mal.Sym key, Mal.Val f) { + data[key] = f; + } + + public Mal.Env? find(Mal.Sym key) { + if (key in data) + return this; + if (outer == null) + return null; + return outer.find(key); + } + + public new Mal.Val get(Mal.Sym key) throws Mal.Error { + var found = find(key); + if (found == null) + throw new Error.ENV_LOOKUP_FAILED("'%s' not found", key.v); + return found.data[key]; + } +} diff --git a/impls/vala/gc.vala b/impls/vala/gc.vala index cb5b6d7989..0c99a9eacc 100644 --- a/impls/vala/gc.vala +++ b/impls/vala/gc.vala @@ -1,196 +1,196 @@ -abstract class GC.Object : GLib.Object { - public GC.Object? next; - public unowned GC.Object? prev; - public bool visited; - - public delegate void VisitorFunc(GC.Object? obj); - - construct { - next = null; - prev = null; - GC.Core.register_object(this); - } - public abstract void gc_traverse(VisitorFunc visitor); -} - -class GC.Root : GLib.Object { - public weak GC.Root? next; - public weak GC.Root? prev; - - public GC.Object? obj; - - construct { GC.Core.register_root(this); } - ~Root() { GC.Core.unregister_root(this); } - - public Root.empty() { obj = null; } - public Root(GC.Object? obj_) { obj = obj_; } -} - -class GC.Core : GLib.Object { - private struct ObjectQueue { - GC.Object? head; - GC.Object? tail; - - public void unlink(GC.Object obj_) { - GC.Object obj = obj_; - - if (obj.prev == null) { - assert(obj == head); - head = obj.next; - } - else - obj.prev.next = obj.next; - - if (obj.next == null) - tail = obj.prev; - else - obj.next.prev = obj.prev; - } - - public void link(GC.Object obj) { - if (tail != null) { - tail.next = obj; - obj.prev = tail; - } else { - head = obj; - obj.prev = null; - } - - tail = obj; - obj.next = null; - } - } - - private static ObjectQueue objects; - private static weak GC.Root? roots_head; - private static uint until_next_collection; - - static construct { - objects.head = objects.tail = null; - roots_head = null; - } - - public static void register_object(GC.Object obj) { -#if GC_DEBUG - stderr.printf("GC: registered %p [%s]\n", - obj, Type.from_instance(obj).name()); -#endif - objects.link(obj); - if (until_next_collection > 0) - until_next_collection--; - } - public static void register_root(GC.Root root) { -#if GC_DEBUG - stderr.printf("GC: registered root %p\n", root); -#endif - root.next = roots_head; - root.prev = null; - if (roots_head != null) - roots_head.prev = root; - roots_head = root; - } - public static void unregister_root(GC.Root root) { -#if GC_DEBUG - stderr.printf("GC: unregistered root %p\n", root); -#endif - if (root.prev == null) - roots_head = root.next; - else - root.prev.next = root.next; - if (root.next != null) - root.next.prev = root.prev; - } - - private static void statistics(uint before, uint after, uint roots) { -#if GC_STATS - stderr.printf("GC: %u roots, %u -> %u objects\n", - roots, before, after); -#endif - } - - public static void collect() { - uint orig = 0; - uint roots = 0; - -#if GC_DEBUG - stderr.printf("GC: started\n"); -#endif - for (unowned GC.Object obj = objects.head; obj != null; obj = obj.next) - { - obj.visited = false; -#if GC_DEBUG - stderr.printf("GC: considering %p [%s]\n", - obj, Type.from_instance(obj).name()); -#endif - orig++; - } - - ObjectQueue after = { null, null }; - until_next_collection = 0; - - for (unowned GC.Root root = roots_head; root != null; root = root.next) - { - roots++; - if (root.obj != null && !root.obj.visited) { - GC.Object obj = root.obj; -#if GC_DEBUG - stderr.printf("GC: root %p -> %p [%s]\n", - root, obj, Type.from_instance(obj).name()); -#endif - objects.unlink(obj); - after.link(obj); - obj.visited = true; - until_next_collection++; - } - } - - for (GC.Object? obj = after.head; obj != null; obj = obj.next) { -#if GC_DEBUG - stderr.printf("GC: traversing %p [%s]\n", - obj, Type.from_instance(obj).name()); -#endif - obj.gc_traverse((obj2_) => { - GC.Object obj2 = obj2_; - if (obj2 == null) - return; - if (!obj2.visited) { -#if GC_DEBUG - stderr.printf("GC: %p -> %p [%s]\n", - obj, obj2, Type.from_instance(obj2).name()); -#endif - objects.unlink(obj2); - after.link(obj2); - obj2.visited = true; - until_next_collection++; - } - }); - } - - // Manually free everything, to avoid stack overflow while - // recursing down the list unreffing them all - objects.tail = null; - while (objects.head != null) { -#if GC_DEBUG - stderr.printf("GC: collecting %p [%s]\n", objects.head, - Type.from_instance(objects.head).name()); -#endif - objects.head = objects.head.next; - } - - objects = after; - -#if GC_DEBUG - stderr.printf("GC: finished\n"); -#endif - - statistics(orig, until_next_collection, roots); - } - - public static void maybe_collect() { -#if !GC_ALWAYS - if (until_next_collection > 0) - return; -#endif - collect(); - } -} +abstract class GC.Object : GLib.Object { + public GC.Object? next; + public unowned GC.Object? prev; + public bool visited; + + public delegate void VisitorFunc(GC.Object? obj); + + construct { + next = null; + prev = null; + GC.Core.register_object(this); + } + public abstract void gc_traverse(VisitorFunc visitor); +} + +class GC.Root : GLib.Object { + public weak GC.Root? next; + public weak GC.Root? prev; + + public GC.Object? obj; + + construct { GC.Core.register_root(this); } + ~Root() { GC.Core.unregister_root(this); } + + public Root.empty() { obj = null; } + public Root(GC.Object? obj_) { obj = obj_; } +} + +class GC.Core : GLib.Object { + private struct ObjectQueue { + GC.Object? head; + GC.Object? tail; + + public void unlink(GC.Object obj_) { + GC.Object obj = obj_; + + if (obj.prev == null) { + assert(obj == head); + head = obj.next; + } + else + obj.prev.next = obj.next; + + if (obj.next == null) + tail = obj.prev; + else + obj.next.prev = obj.prev; + } + + public void link(GC.Object obj) { + if (tail != null) { + tail.next = obj; + obj.prev = tail; + } else { + head = obj; + obj.prev = null; + } + + tail = obj; + obj.next = null; + } + } + + private static ObjectQueue objects; + private static weak GC.Root? roots_head; + private static uint until_next_collection; + + static construct { + objects.head = objects.tail = null; + roots_head = null; + } + + public static void register_object(GC.Object obj) { +#if GC_DEBUG + stderr.printf("GC: registered %p [%s]\n", + obj, Type.from_instance(obj).name()); +#endif + objects.link(obj); + if (until_next_collection > 0) + until_next_collection--; + } + public static void register_root(GC.Root root) { +#if GC_DEBUG + stderr.printf("GC: registered root %p\n", root); +#endif + root.next = roots_head; + root.prev = null; + if (roots_head != null) + roots_head.prev = root; + roots_head = root; + } + public static void unregister_root(GC.Root root) { +#if GC_DEBUG + stderr.printf("GC: unregistered root %p\n", root); +#endif + if (root.prev == null) + roots_head = root.next; + else + root.prev.next = root.next; + if (root.next != null) + root.next.prev = root.prev; + } + + private static void statistics(uint before, uint after, uint roots) { +#if GC_STATS + stderr.printf("GC: %u roots, %u -> %u objects\n", + roots, before, after); +#endif + } + + public static void collect() { + uint orig = 0; + uint roots = 0; + +#if GC_DEBUG + stderr.printf("GC: started\n"); +#endif + for (unowned GC.Object obj = objects.head; obj != null; obj = obj.next) + { + obj.visited = false; +#if GC_DEBUG + stderr.printf("GC: considering %p [%s]\n", + obj, Type.from_instance(obj).name()); +#endif + orig++; + } + + ObjectQueue after = { null, null }; + until_next_collection = 0; + + for (unowned GC.Root root = roots_head; root != null; root = root.next) + { + roots++; + if (root.obj != null && !root.obj.visited) { + GC.Object obj = root.obj; +#if GC_DEBUG + stderr.printf("GC: root %p -> %p [%s]\n", + root, obj, Type.from_instance(obj).name()); +#endif + objects.unlink(obj); + after.link(obj); + obj.visited = true; + until_next_collection++; + } + } + + for (GC.Object? obj = after.head; obj != null; obj = obj.next) { +#if GC_DEBUG + stderr.printf("GC: traversing %p [%s]\n", + obj, Type.from_instance(obj).name()); +#endif + obj.gc_traverse((obj2_) => { + GC.Object obj2 = obj2_; + if (obj2 == null) + return; + if (!obj2.visited) { +#if GC_DEBUG + stderr.printf("GC: %p -> %p [%s]\n", + obj, obj2, Type.from_instance(obj2).name()); +#endif + objects.unlink(obj2); + after.link(obj2); + obj2.visited = true; + until_next_collection++; + } + }); + } + + // Manually free everything, to avoid stack overflow while + // recursing down the list unreffing them all + objects.tail = null; + while (objects.head != null) { +#if GC_DEBUG + stderr.printf("GC: collecting %p [%s]\n", objects.head, + Type.from_instance(objects.head).name()); +#endif + objects.head = objects.head.next; + } + + objects = after; + +#if GC_DEBUG + stderr.printf("GC: finished\n"); +#endif + + statistics(orig, until_next_collection, roots); + } + + public static void maybe_collect() { +#if !GC_ALWAYS + if (until_next_collection > 0) + return; +#endif + collect(); + } +} diff --git a/impls/vala/printer.vala b/impls/vala/printer.vala index 7dd75a3b77..d5b3af59a4 100644 --- a/impls/vala/printer.vala +++ b/impls/vala/printer.vala @@ -1,58 +1,58 @@ -namespace Mal { - string pr_str(Mal.Val val, bool print_readably = true) { - if (val is Mal.Nil) - return "nil"; - if (val is Mal.Bool) - return (val as Mal.Bool).v ? "true" : "false"; - if (val is Mal.Sym) - return (val as Mal.Sym).v; - if (val is Mal.Keyword) - return ":" + (val as Mal.Keyword).v; - if (val is Mal.Num) - return ("%"+int64.FORMAT_MODIFIER+"d") - .printf((val as Mal.Num).v); - if (val is Mal.String) { - string s = (val as Mal.String).v; - if (print_readably) - s = "\"%s\"".printf(s.replace("\\", "\\\\") - .replace("\n", "\\n"). - replace("\"", "\\\"")); - return s; - } - if (val is Mal.Listlike) { - bool vec = val is Mal.Vector; - string toret = vec ? "[" : "("; - string sep = ""; - for (var iter = (val as Mal.Listlike).iter(); - iter.nonempty(); iter.step()) { - toret += sep + pr_str(iter.deref(), print_readably); - sep = " "; - } - toret += vec ? "]" : ")"; - return toret; - } - if (val is Mal.Hashmap) { - string toret = "{"; - string sep = ""; - var map = (val as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) { - toret += (sep + pr_str(key, print_readably) + " " + - pr_str(map[key], print_readably)); - sep = " "; - } - toret += "}"; - return toret; - } - if (val is Mal.BuiltinFunction) { - return "#".printf((val as Mal.BuiltinFunction).name()); - } - if (val is Mal.Function) { - return "#"; - } - if (val is Mal.Atom) { - return "(atom %s)".printf( - pr_str((val as Mal.Atom).v, print_readably)); - } - return "??"; - } -} +namespace Mal { + string pr_str(Mal.Val val, bool print_readably = true) { + if (val is Mal.Nil) + return "nil"; + if (val is Mal.Bool) + return (val as Mal.Bool).v ? "true" : "false"; + if (val is Mal.Sym) + return (val as Mal.Sym).v; + if (val is Mal.Keyword) + return ":" + (val as Mal.Keyword).v; + if (val is Mal.Num) + return ("%"+int64.FORMAT_MODIFIER+"d") + .printf((val as Mal.Num).v); + if (val is Mal.String) { + string s = (val as Mal.String).v; + if (print_readably) + s = "\"%s\"".printf(s.replace("\\", "\\\\") + .replace("\n", "\\n"). + replace("\"", "\\\"")); + return s; + } + if (val is Mal.Listlike) { + bool vec = val is Mal.Vector; + string toret = vec ? "[" : "("; + string sep = ""; + for (var iter = (val as Mal.Listlike).iter(); + iter.nonempty(); iter.step()) { + toret += sep + pr_str(iter.deref(), print_readably); + sep = " "; + } + toret += vec ? "]" : ")"; + return toret; + } + if (val is Mal.Hashmap) { + string toret = "{"; + string sep = ""; + var map = (val as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) { + toret += (sep + pr_str(key, print_readably) + " " + + pr_str(map[key], print_readably)); + sep = " "; + } + toret += "}"; + return toret; + } + if (val is Mal.BuiltinFunction) { + return "#".printf((val as Mal.BuiltinFunction).name()); + } + if (val is Mal.Function) { + return "#"; + } + if (val is Mal.Atom) { + return "(atom %s)".printf( + pr_str((val as Mal.Atom).v, print_readably)); + } + return "??"; + } +} diff --git a/impls/vala/reader.vala b/impls/vala/reader.vala index de0c63ed81..0846243475 100644 --- a/impls/vala/reader.vala +++ b/impls/vala/reader.vala @@ -1,183 +1,183 @@ -class Mal.Reader : GLib.Object { - static Regex tok_re; - static Regex tok_num; - - int origlen; - string data; - int pos; - - string next_token; - - static construct { - tok_re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;[^\n]*|[^\s\[\]{}('"`,;)]*)/; // comment to unconfuse emacs vala-mode "]); - tok_num = /^-?[0-9]/; - } - - private string poserr(string fmt, ...) { - return "char %d: %s".printf(origlen - data.length, - fmt.vprintf(va_list())); - } - - private void advance() throws Error { - do { - MatchInfo info; - if (!tok_re.match(data, 0, out info)) - throw new Error.BAD_TOKEN(poserr("bad token")); - - next_token = info.fetch(1); - int tokenend; - info.fetch_pos(1, null, out tokenend); - data = data[tokenend:data.length]; - } while (next_token.has_prefix(";")); - } - - public Reader(string str) throws Error { - data = str; - origlen = data.length; - pos = 0; - advance(); - } - - public string peek() throws Error { - return next_token; - } - - public string next() throws Error { - advance(); - return peek(); - } - - public static Mal.Val? read_str(string str) throws Error { - var rdr = new Reader(str); - if (rdr.peek() == "") - return null; - var toret = rdr.read_form(); - if (rdr.peek() != "") - throw new Mal.Error.PARSE_ERROR( - rdr.poserr("trailing junk after expression")); - return toret; - } - - public Mal.Val read_form() throws Error { - string token = peek(); - if (token == "(") { - next(); // eat ( - return new Mal.List(read_list(")")); - } else { - return read_atom(); - } - } - - public GLib.List read_list(string endtok) throws Error { - var list = new GLib.List(); - string token; - while (true) { - token = peek(); - if (token == "") - throw new Mal.Error.PARSE_ERROR(poserr("unbalanced parens")); - if (token == endtok) { - next(); // eat end token - return list; - } - - list.append(read_form()); - } - } - - public Mal.Hashmap read_hashmap() throws Error { - var map = new Mal.Hashmap(); - string token; - while (true) { - Mal.Val vals[2]; - for (int i = 0; i < 2; i++) { - token = peek(); - if (token == "") - throw new Mal.Error.PARSE_ERROR( - poserr("unbalanced braces")); - if (token == "}") { - if (i != 0) - throw new Mal.Error.PARSE_ERROR( - poserr("odd number of elements in hashmap")); - - next(); // eat end token - return map; - } - - vals[i] = read_form(); - } - map.insert(vals[0], vals[1]); - } - } - - public Mal.Val read_atom() throws Error { - string token = peek(); - next(); - if (tok_num.match(token)) - return new Mal.Num(int64.parse(token)); - if (token.has_prefix(":")) - return new Mal.Keyword(token[1:token.length]); - if (token.has_prefix("\"")) { - if (token.length < 2 || !token.has_suffix("\"")) - throw new Mal.Error.BAD_TOKEN( - poserr("end of input in mid-string")); - - token = token[1:token.length-1]; - - int end = 0; - int pos = 0; - string strval = ""; - - while ((pos = token.index_of ("\\", end)) != -1) { - strval += token[end:pos]; - if (token.length - pos < 2) - throw new Mal.Error.BAD_TOKEN( - poserr("end of input in mid-string")); - switch (token[pos:pos+2]) { - case "\\\\": - strval += "\\"; break; - case "\\\"": - strval += "\""; break; - case "\\n": - strval += "\n"; break; - } - end = pos+2; - } - strval += token[end:token.length]; - return new Mal.String(strval); - } - switch (token) { - case "nil": - return new Mal.Nil(); - case "true": - return new Mal.Bool(true); - case "false": - return new Mal.Bool(false); - case "[": - return new Mal.Vector.from_list(read_list("]")); - case "{": - return read_hashmap(); - case "'": - case "`": - case "~": - case "~@": - case "@": - var list = new GLib.List(); - list.append(new Mal.Sym( - token == "'" ? "quote" : - token == "`" ? "quasiquote" : - token == "~" ? "unquote" : - token == "~@" ? "splice-unquote" : "deref")); - list.append(read_form()); - return new Mal.List(list); - case "^": - var list = new GLib.List(); - list.append(new Mal.Sym("with-meta")); - var metadata = read_form(); - list.append(read_form()); - list.append(metadata); - return new Mal.List(list); - default: - return new Mal.Sym(token); - } - } -} +class Mal.Reader : GLib.Object { + static Regex tok_re; + static Regex tok_num; + + int origlen; + string data; + int pos; + + string next_token; + + static construct { + tok_re = /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;[^\n]*|[^\s\[\]{}('"`,;)]*)/; // comment to unconfuse emacs vala-mode "]); + tok_num = /^-?[0-9]/; + } + + private string poserr(string fmt, ...) { + return "char %d: %s".printf(origlen - data.length, + fmt.vprintf(va_list())); + } + + private void advance() throws Error { + do { + MatchInfo info; + if (!tok_re.match(data, 0, out info)) + throw new Error.BAD_TOKEN(poserr("bad token")); + + next_token = info.fetch(1); + int tokenend; + info.fetch_pos(1, null, out tokenend); + data = data[tokenend:data.length]; + } while (next_token.has_prefix(";")); + } + + public Reader(string str) throws Error { + data = str; + origlen = data.length; + pos = 0; + advance(); + } + + public string peek() throws Error { + return next_token; + } + + public string next() throws Error { + advance(); + return peek(); + } + + public static Mal.Val? read_str(string str) throws Error { + var rdr = new Reader(str); + if (rdr.peek() == "") + return null; + var toret = rdr.read_form(); + if (rdr.peek() != "") + throw new Mal.Error.PARSE_ERROR( + rdr.poserr("trailing junk after expression")); + return toret; + } + + public Mal.Val read_form() throws Error { + string token = peek(); + if (token == "(") { + next(); // eat ( + return new Mal.List(read_list(")")); + } else { + return read_atom(); + } + } + + public GLib.List read_list(string endtok) throws Error { + var list = new GLib.List(); + string token; + while (true) { + token = peek(); + if (token == "") + throw new Mal.Error.PARSE_ERROR(poserr("unbalanced parens")); + if (token == endtok) { + next(); // eat end token + return list; + } + + list.append(read_form()); + } + } + + public Mal.Hashmap read_hashmap() throws Error { + var map = new Mal.Hashmap(); + string token; + while (true) { + Mal.Val vals[2]; + for (int i = 0; i < 2; i++) { + token = peek(); + if (token == "") + throw new Mal.Error.PARSE_ERROR( + poserr("unbalanced braces")); + if (token == "}") { + if (i != 0) + throw new Mal.Error.PARSE_ERROR( + poserr("odd number of elements in hashmap")); + + next(); // eat end token + return map; + } + + vals[i] = read_form(); + } + map.insert(vals[0], vals[1]); + } + } + + public Mal.Val read_atom() throws Error { + string token = peek(); + next(); + if (tok_num.match(token)) + return new Mal.Num(int64.parse(token)); + if (token.has_prefix(":")) + return new Mal.Keyword(token[1:token.length]); + if (token.has_prefix("\"")) { + if (token.length < 2 || !token.has_suffix("\"")) + throw new Mal.Error.BAD_TOKEN( + poserr("end of input in mid-string")); + + token = token[1:token.length-1]; + + int end = 0; + int pos = 0; + string strval = ""; + + while ((pos = token.index_of ("\\", end)) != -1) { + strval += token[end:pos]; + if (token.length - pos < 2) + throw new Mal.Error.BAD_TOKEN( + poserr("end of input in mid-string")); + switch (token[pos:pos+2]) { + case "\\\\": + strval += "\\"; break; + case "\\\"": + strval += "\""; break; + case "\\n": + strval += "\n"; break; + } + end = pos+2; + } + strval += token[end:token.length]; + return new Mal.String(strval); + } + switch (token) { + case "nil": + return new Mal.Nil(); + case "true": + return new Mal.Bool(true); + case "false": + return new Mal.Bool(false); + case "[": + return new Mal.Vector.from_list(read_list("]")); + case "{": + return read_hashmap(); + case "'": + case "`": + case "~": + case "~@": + case "@": + var list = new GLib.List(); + list.append(new Mal.Sym( + token == "'" ? "quote" : + token == "`" ? "quasiquote" : + token == "~" ? "unquote" : + token == "~@" ? "splice-unquote" : "deref")); + list.append(read_form()); + return new Mal.List(list); + case "^": + var list = new GLib.List(); + list.append(new Mal.Sym("with-meta")); + var metadata = read_form(); + list.append(read_form()); + list.append(metadata); + return new Mal.List(list); + default: + return new Mal.Sym(token); + } + } +} diff --git a/impls/vala/run b/impls/vala/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/vala/run +++ b/impls/vala/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/vala/step0_repl.vala b/impls/vala/step0_repl.vala index 817a92eb8c..86a89e1d8d 100644 --- a/impls/vala/step0_repl.vala +++ b/impls/vala/step0_repl.vala @@ -1,36 +1,36 @@ -class Mal.Main : GLib.Object { - public static string? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - } else { - stdout.printf("\n"); - } - return line; - } - - public static string EVAL(string expr) { - return expr; - } - - public static void PRINT(string value) { - stdout.printf("%s\n", value); - } - - public static bool rep() { - string? line = READ(); - if (line == null) - return false; - if (line.length > 0) { - string value = EVAL(line); - PRINT(value); - } - return true; - } - - public static int main(string[] args) { - while (rep()); - return 0; - } -} +class Mal.Main : GLib.Object { + public static string? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + } else { + stdout.printf("\n"); + } + return line; + } + + public static string EVAL(string expr) { + return expr; + } + + public static void PRINT(string value) { + stdout.printf("%s\n", value); + } + + public static bool rep() { + string? line = READ(); + if (line == null) + return false; + if (line.length > 0) { + string value = EVAL(line); + PRINT(value); + } + return true; + } + + public static int main(string[] args) { + while (rep()); + return 0; + } +} diff --git a/impls/vala/step1_read_print.vala b/impls/vala/step1_read_print.vala index 730de2ffb4..4f66658db3 100644 --- a/impls/vala/step1_read_print.vala +++ b/impls/vala/step1_read_print.vala @@ -1,49 +1,49 @@ -class Mal.Main : GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val EVAL(Mal.Val expr) { - return expr; - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep() { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val); - PRINT(val); - GC.Core.maybe_collect(); - } - } - - public static int main(string[] args) { - while (!eof) - rep(); - return 0; - } -} +class Mal.Main : GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val EVAL(Mal.Val expr) { + return expr; + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep() { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val); + PRINT(val); + GC.Core.maybe_collect(); + } + } + + public static int main(string[] args) { + while (!eof) + rep(); + return 0; + } +} diff --git a/impls/vala/step2_eval.vala b/impls/vala/step2_eval.vala index f62e8806a2..1c52544230 100644 --- a/impls/vala/step2_eval.vala +++ b/impls/vala/step2_eval.vala @@ -1,170 +1,170 @@ -abstract class Mal.BuiltinFunctionDyadicArithmetic : Mal.BuiltinFunction { - public abstract int64 result(int64 a, int64 b); - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); - unowned Mal.Num a = args.vs.nth_data(0) as Mal.Num; - unowned Mal.Num b = args.vs.nth_data(1) as Mal.Num; - if (a == null || b == null) - throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); - return new Mal.Num(result(a.v, b.v)); - } -} - -class Mal.BuiltinFunctionAdd : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionAdd(); - } - public override string name() { return "+"; } - public override int64 result(int64 a, int64 b) { return a+b; } -} - -class Mal.BuiltinFunctionSub : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionSub(); - } - public override string name() { return "-"; } - public override int64 result(int64 a, int64 b) { return a-b; } -} - -class Mal.BuiltinFunctionMul : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionMul(); - } - public override string name() { return "*"; } - public override int64 result(int64 a, int64 b) { return a*b; } -} - -class Mal.BuiltinFunctionDiv : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionDiv(); - } - public override string name() { return "/"; } - public override int64 result(int64 a, int64 b) { return a/b; } -} - -class Mal.Env : GLib.Object { - public GLib.HashTable data; - construct { - data = new GLib.HashTable( - Mal.Hashable.hash, Mal.Hashable.equal); - } - // Use the 'new' keyword to silence warnings about 'set' and 'get' - // already having meanings that we're overwriting - public new void set(Mal.Sym key, Mal.Val f) { - data[key] = f; - } - public new Mal.Val get(Mal.Sym key) throws Mal.Error { - var toret = data[key]; - if (toret == null) - throw new Error.ENV_LOOKUP_FAILED("no such variable '%s'", key.v); - return toret; - } -} - -class Mal.Main : GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var roota = new GC.Root(ast); (void)roota; - if (ast is Mal.Sym) - return env.get(ast as Mal.Sym); - if (ast is Mal.List) { - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - foreach (var elt in (ast as Mal.List).vs) - result.vs.append(EVAL(elt, env)); - return result; - } - if (ast is Mal.Vector) { - var vec = ast as Mal.Vector; - var result = new Mal.Vector.with_size(vec.length); - var root = new GC.Root(result); (void)root; - for (var i = 0; i < vec.length; i++) - result[i] = EVAL(vec[i], env); - return result; - } - if (ast is Mal.Hashmap) { - var result = new Mal.Hashmap(); - var root = new GC.Root(result); (void)root; - var map = (ast as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) - result.insert(key, EVAL(map[key], env)); - return result; - } - return ast; - } - - public static Mal.Val EVAL(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var ast_root = new GC.Root(ast); (void)ast_root; - GC.Core.maybe_collect(); - - if (ast is Mal.List) { - unowned GLib.List list = (ast as Mal.List).vs; - if (list.first() == null) - return ast; - var newlist = eval_ast(ast, env) as Mal.List; - unowned GLib.List firstlink = newlist.vs.first(); - var fn = firstlink.data as Mal.BuiltinFunction; - newlist.vs.remove_link(firstlink); - return fn.call(newlist); - } else { - return eval_ast(ast, env); - } - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep(Mal.Env env) throws Mal.Error { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val, env); - PRINT(val); - } - } - - public static int main(string[] args) { - var env = new Mal.Env(); - - env.set(new Mal.Sym("+"), new BuiltinFunctionAdd()); - env.set(new Mal.Sym("-"), new BuiltinFunctionSub()); - env.set(new Mal.Sym("*"), new BuiltinFunctionMul()); - env.set(new Mal.Sym("/"), new BuiltinFunctionDiv()); - - while (!eof) { - try { - rep(env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - } - } - return 0; - } -} +abstract class Mal.BuiltinFunctionDyadicArithmetic : Mal.BuiltinFunction { + public abstract int64 result(int64 a, int64 b); + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); + unowned Mal.Num a = args.vs.nth_data(0) as Mal.Num; + unowned Mal.Num b = args.vs.nth_data(1) as Mal.Num; + if (a == null || b == null) + throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); + return new Mal.Num(result(a.v, b.v)); + } +} + +class Mal.BuiltinFunctionAdd : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionAdd(); + } + public override string name() { return "+"; } + public override int64 result(int64 a, int64 b) { return a+b; } +} + +class Mal.BuiltinFunctionSub : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionSub(); + } + public override string name() { return "-"; } + public override int64 result(int64 a, int64 b) { return a-b; } +} + +class Mal.BuiltinFunctionMul : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionMul(); + } + public override string name() { return "*"; } + public override int64 result(int64 a, int64 b) { return a*b; } +} + +class Mal.BuiltinFunctionDiv : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionDiv(); + } + public override string name() { return "/"; } + public override int64 result(int64 a, int64 b) { return a/b; } +} + +class Mal.Env : GLib.Object { + public GLib.HashTable data; + construct { + data = new GLib.HashTable( + Mal.Hashable.hash, Mal.Hashable.equal); + } + // Use the 'new' keyword to silence warnings about 'set' and 'get' + // already having meanings that we're overwriting + public new void set(Mal.Sym key, Mal.Val f) { + data[key] = f; + } + public new Mal.Val get(Mal.Sym key) throws Mal.Error { + var toret = data[key]; + if (toret == null) + throw new Error.ENV_LOOKUP_FAILED("no such variable '%s'", key.v); + return toret; + } +} + +class Mal.Main : GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var roota = new GC.Root(ast); (void)roota; + if (ast is Mal.Sym) + return env.get(ast as Mal.Sym); + if (ast is Mal.List) { + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + foreach (var elt in (ast as Mal.List).vs) + result.vs.append(EVAL(elt, env)); + return result; + } + if (ast is Mal.Vector) { + var vec = ast as Mal.Vector; + var result = new Mal.Vector.with_size(vec.length); + var root = new GC.Root(result); (void)root; + for (var i = 0; i < vec.length; i++) + result[i] = EVAL(vec[i], env); + return result; + } + if (ast is Mal.Hashmap) { + var result = new Mal.Hashmap(); + var root = new GC.Root(result); (void)root; + var map = (ast as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) + result.insert(key, EVAL(map[key], env)); + return result; + } + return ast; + } + + public static Mal.Val EVAL(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var ast_root = new GC.Root(ast); (void)ast_root; + GC.Core.maybe_collect(); + + if (ast is Mal.List) { + unowned GLib.List list = (ast as Mal.List).vs; + if (list.first() == null) + return ast; + var newlist = eval_ast(ast, env) as Mal.List; + unowned GLib.List firstlink = newlist.vs.first(); + var fn = firstlink.data as Mal.BuiltinFunction; + newlist.vs.remove_link(firstlink); + return fn.call(newlist); + } else { + return eval_ast(ast, env); + } + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep(Mal.Env env) throws Mal.Error { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val, env); + PRINT(val); + } + } + + public static int main(string[] args) { + var env = new Mal.Env(); + + env.set(new Mal.Sym("+"), new BuiltinFunctionAdd()); + env.set(new Mal.Sym("-"), new BuiltinFunctionSub()); + env.set(new Mal.Sym("*"), new BuiltinFunctionMul()); + env.set(new Mal.Sym("/"), new BuiltinFunctionDiv()); + + while (!eof) { + try { + rep(env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + } + } + return 0; + } +} diff --git a/impls/vala/step3_env.vala b/impls/vala/step3_env.vala index 429b5b17db..8c4cffcbd9 100644 --- a/impls/vala/step3_env.vala +++ b/impls/vala/step3_env.vala @@ -1,218 +1,218 @@ -abstract class Mal.BuiltinFunctionDyadicArithmetic : Mal.BuiltinFunction { - public abstract int64 result(int64 a, int64 b); - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 2) - throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); - unowned Mal.Num a = args.vs.nth_data(0) as Mal.Num; - unowned Mal.Num b = args.vs.nth_data(1) as Mal.Num; - if (a == null || b == null) - throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); - return new Mal.Num(result(a.v, b.v)); - } -} - -class Mal.BuiltinFunctionAdd : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionAdd(); - } - public override string name() { return "+"; } - public override int64 result(int64 a, int64 b) { return a+b; } -} - -class Mal.BuiltinFunctionSub : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionSub(); - } - public override string name() { return "-"; } - public override int64 result(int64 a, int64 b) { return a-b; } -} - -class Mal.BuiltinFunctionMul : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionMul(); - } - public override string name() { return "*"; } - public override int64 result(int64 a, int64 b) { return a*b; } -} - -class Mal.BuiltinFunctionDiv : Mal.BuiltinFunctionDyadicArithmetic { - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionDiv(); - } - public override string name() { return "/"; } - public override int64 result(int64 a, int64 b) { return a/b; } -} - -class Mal.Main : GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var roota = new GC.Root(ast); (void)roota; - var roote = new GC.Root(env); (void)roote; - if (ast is Mal.Sym) - return env.get(ast as Mal.Sym); - if (ast is Mal.List) { - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - foreach (var elt in (ast as Mal.List).vs) - result.vs.append(EVAL(elt, env)); - return result; - } - if (ast is Mal.Vector) { - var vec = ast as Mal.Vector; - var result = new Mal.Vector.with_size(vec.length); - var root = new GC.Root(result); (void)root; - for (var i = 0; i < vec.length; i++) - result[i] = EVAL(vec[i], env); - return result; - } - if (ast is Mal.Hashmap) { - var result = new Mal.Hashmap(); - var root = new GC.Root(result); (void)root; - var map = (ast as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) - result.insert(key, EVAL(map[key], env)); - return result; - } - return ast; - } - - private static Mal.Val define_eval(Mal.Val key, Mal.Val value, - Mal.Env env) - throws Mal.Error { - var rootk = new GC.Root(key); (void)rootk; - var roote = new GC.Root(env); (void)roote; - var symkey = key as Mal.Sym; - if (symkey == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected a symbol to define"); - var val = EVAL(value, env); - env.set(symkey, val); - return val; - } - - public static Mal.Val EVAL(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var ast_root = new GC.Root(ast); (void)ast_root; - var env_root = new GC.Root(env); (void)env_root; - GC.Core.maybe_collect(); - - if (ast is Mal.List) { - unowned GLib.List list = (ast as Mal.List).vs; - if (list.first() == null) - return ast; - - var first = list.first().data; - if (first is Mal.Sym) { - var sym = first as Mal.Sym; - switch (sym.v) { - case "def!": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "def!: expected two values"); - return define_eval(list.next.data, list.next.next.data, - env); - case "let*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "let*: expected two values"); - var defns = list.nth(1).data; - var newenv = new Mal.Env.within(env); - - if (defns is Mal.List) { - for (unowned GLib.List iter = - (defns as Mal.List).vs; - iter != null; iter = iter.next.next) { - if (iter.next == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length list" + - " of definitions"); - define_eval(iter.data, iter.next.data, newenv); - } - } else if (defns is Mal.Vector) { - var vec = defns as Mal.Vector; - if (vec.length % 2 != 0) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length vector" + - " of definitions"); - for (var i = 0; i < vec.length; i += 2) - define_eval(vec[i], vec[i+1], newenv); - } else { - throw new Mal.Error.BAD_PARAMS( - "let*: expected a list or vector of definitions"); - } - return EVAL(list.nth(2).data, newenv); - } - } - - var newlist = eval_ast(ast, env) as Mal.List; - unowned GLib.List firstlink = newlist.vs.first(); - Mal.Val firstdata = firstlink.data; - newlist.vs.remove_link(firstlink); - - if (firstdata is Mal.BuiltinFunction) { - return (firstdata as Mal.BuiltinFunction).call(newlist); - } else { - throw new Mal.Error.CANNOT_APPLY( - "bad value at start of list"); - } - } else { - return eval_ast(ast, env); - } - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep(Mal.Env env) throws Mal.Error { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val, env); - PRINT(val); - } - } - - public static int main(string[] args) { - var env = new Mal.Env(); - var root = new GC.Root(env); (void)root; - - env.set(new Mal.Sym("+"), new BuiltinFunctionAdd()); - env.set(new Mal.Sym("-"), new BuiltinFunctionSub()); - env.set(new Mal.Sym("*"), new BuiltinFunctionMul()); - env.set(new Mal.Sym("/"), new BuiltinFunctionDiv()); - - while (!eof) { - try { - rep(env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - } - } - return 0; - } -} +abstract class Mal.BuiltinFunctionDyadicArithmetic : Mal.BuiltinFunction { + public abstract int64 result(int64 a, int64 b); + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 2) + throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); + unowned Mal.Num a = args.vs.nth_data(0) as Mal.Num; + unowned Mal.Num b = args.vs.nth_data(1) as Mal.Num; + if (a == null || b == null) + throw new Mal.Error.BAD_PARAMS("%s: expected two numbers", name()); + return new Mal.Num(result(a.v, b.v)); + } +} + +class Mal.BuiltinFunctionAdd : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionAdd(); + } + public override string name() { return "+"; } + public override int64 result(int64 a, int64 b) { return a+b; } +} + +class Mal.BuiltinFunctionSub : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionSub(); + } + public override string name() { return "-"; } + public override int64 result(int64 a, int64 b) { return a-b; } +} + +class Mal.BuiltinFunctionMul : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionMul(); + } + public override string name() { return "*"; } + public override int64 result(int64 a, int64 b) { return a*b; } +} + +class Mal.BuiltinFunctionDiv : Mal.BuiltinFunctionDyadicArithmetic { + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionDiv(); + } + public override string name() { return "/"; } + public override int64 result(int64 a, int64 b) { return a/b; } +} + +class Mal.Main : GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var roota = new GC.Root(ast); (void)roota; + var roote = new GC.Root(env); (void)roote; + if (ast is Mal.Sym) + return env.get(ast as Mal.Sym); + if (ast is Mal.List) { + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + foreach (var elt in (ast as Mal.List).vs) + result.vs.append(EVAL(elt, env)); + return result; + } + if (ast is Mal.Vector) { + var vec = ast as Mal.Vector; + var result = new Mal.Vector.with_size(vec.length); + var root = new GC.Root(result); (void)root; + for (var i = 0; i < vec.length; i++) + result[i] = EVAL(vec[i], env); + return result; + } + if (ast is Mal.Hashmap) { + var result = new Mal.Hashmap(); + var root = new GC.Root(result); (void)root; + var map = (ast as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) + result.insert(key, EVAL(map[key], env)); + return result; + } + return ast; + } + + private static Mal.Val define_eval(Mal.Val key, Mal.Val value, + Mal.Env env) + throws Mal.Error { + var rootk = new GC.Root(key); (void)rootk; + var roote = new GC.Root(env); (void)roote; + var symkey = key as Mal.Sym; + if (symkey == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected a symbol to define"); + var val = EVAL(value, env); + env.set(symkey, val); + return val; + } + + public static Mal.Val EVAL(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var ast_root = new GC.Root(ast); (void)ast_root; + var env_root = new GC.Root(env); (void)env_root; + GC.Core.maybe_collect(); + + if (ast is Mal.List) { + unowned GLib.List list = (ast as Mal.List).vs; + if (list.first() == null) + return ast; + + var first = list.first().data; + if (first is Mal.Sym) { + var sym = first as Mal.Sym; + switch (sym.v) { + case "def!": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "def!: expected two values"); + return define_eval(list.next.data, list.next.next.data, + env); + case "let*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "let*: expected two values"); + var defns = list.nth(1).data; + var newenv = new Mal.Env.within(env); + + if (defns is Mal.List) { + for (unowned GLib.List iter = + (defns as Mal.List).vs; + iter != null; iter = iter.next.next) { + if (iter.next == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length list" + + " of definitions"); + define_eval(iter.data, iter.next.data, newenv); + } + } else if (defns is Mal.Vector) { + var vec = defns as Mal.Vector; + if (vec.length % 2 != 0) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length vector" + + " of definitions"); + for (var i = 0; i < vec.length; i += 2) + define_eval(vec[i], vec[i+1], newenv); + } else { + throw new Mal.Error.BAD_PARAMS( + "let*: expected a list or vector of definitions"); + } + return EVAL(list.nth(2).data, newenv); + } + } + + var newlist = eval_ast(ast, env) as Mal.List; + unowned GLib.List firstlink = newlist.vs.first(); + Mal.Val firstdata = firstlink.data; + newlist.vs.remove_link(firstlink); + + if (firstdata is Mal.BuiltinFunction) { + return (firstdata as Mal.BuiltinFunction).call(newlist); + } else { + throw new Mal.Error.CANNOT_APPLY( + "bad value at start of list"); + } + } else { + return eval_ast(ast, env); + } + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep(Mal.Env env) throws Mal.Error { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val, env); + PRINT(val); + } + } + + public static int main(string[] args) { + var env = new Mal.Env(); + var root = new GC.Root(env); (void)root; + + env.set(new Mal.Sym("+"), new BuiltinFunctionAdd()); + env.set(new Mal.Sym("-"), new BuiltinFunctionSub()); + env.set(new Mal.Sym("*"), new BuiltinFunctionMul()); + env.set(new Mal.Sym("/"), new BuiltinFunctionDiv()); + + while (!eof) { + try { + rep(env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + } + } + return 0; + } +} diff --git a/impls/vala/step4_if_fn_do.vala b/impls/vala/step4_if_fn_do.vala index 93d09c3f58..bcb4670993 100644 --- a/impls/vala/step4_if_fn_do.vala +++ b/impls/vala/step4_if_fn_do.vala @@ -1,221 +1,221 @@ -class Mal.Main: GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var roota = new GC.Root(ast); (void)roota; - var roote = new GC.Root(env); (void)roote; - if (ast is Mal.Sym) - return env.get(ast as Mal.Sym); - if (ast is Mal.List) { - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - foreach (var elt in (ast as Mal.List).vs) - result.vs.append(EVAL(elt, env)); - return result; - } - if (ast is Mal.Vector) { - var vec = ast as Mal.Vector; - var result = new Mal.Vector.with_size(vec.length); - var root = new GC.Root(result); (void)root; - for (var i = 0; i < vec.length; i++) - result[i] = EVAL(vec[i], env); - return result; - } - if (ast is Mal.Hashmap) { - var result = new Mal.Hashmap(); - var root = new GC.Root(result); (void)root; - var map = (ast as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) - result.insert(key, EVAL(map[key], env)); - return result; - } - return ast; - } - - private static Mal.Val define_eval(Mal.Val key, Mal.Val value, - Mal.Env env) - throws Mal.Error { - var rootk = new GC.Root(key); (void)rootk; - var roote = new GC.Root(env); (void)roote; - var symkey = key as Mal.Sym; - if (symkey == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected a symbol to define"); - var val = EVAL(value, env); - env.set(symkey, val); - return val; - } - - public static Mal.Val EVAL(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var ast_root = new GC.Root(ast); (void)ast_root; - var env_root = new GC.Root(env); (void)env_root; - GC.Core.maybe_collect(); - - if (ast is Mal.List) { - unowned GLib.List list = (ast as Mal.List).vs; - if (list.first() == null) - return ast; - - var first = list.first().data; - if (first is Mal.Sym) { - var sym = first as Mal.Sym; - switch (sym.v) { - case "def!": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "def!: expected two values"); - return define_eval(list.next.data, list.next.next.data, - env); - case "let*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "let*: expected two values"); - var defns = list.nth(1).data; - var newenv = new Mal.Env.within(env); - - if (defns is Mal.List) { - for (unowned GLib.List iter = - (defns as Mal.List).vs; - iter != null; iter = iter.next.next) { - if (iter.next == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length list" + - " of definitions"); - define_eval(iter.data, iter.next.data, newenv); - } - } else if (defns is Mal.Vector) { - var vec = defns as Mal.Vector; - if (vec.length % 2 != 0) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length vector" + - " of definitions"); - for (var i = 0; i < vec.length; i += 2) - define_eval(vec[i], vec[i+1], newenv); - } else { - throw new Mal.Error.BAD_PARAMS( - "let*: expected a list or vector of definitions"); - } - return EVAL(list.nth(2).data, newenv); - case "do": - Mal.Val result = null; - for (list = list.next; list != null; list = list.next) - result = EVAL(list.data, env); - if (result == null) - throw new Mal.Error.BAD_PARAMS( - "do: expected at least one argument"); - return result; - case "if": - if (list.length() != 3 && list.length() != 4) - throw new Mal.Error.BAD_PARAMS( - "if: expected two or three arguments"); - list = list.next; - var cond = EVAL(list.data, env); - list = list.next; - if (!cond.truth_value()) { - // Skip to the else clause, which defaults to nil. - list = list.next; - if (list == null) - return new Mal.Nil(); - } - return EVAL(list.data, env); - case "fn*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected two arguments"); - var binds = list.next.data as Mal.Listlike; - var body = list.next.next.data; - if (binds == null) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected a list of parameter names"); - for (var iter = binds.iter(); iter.nonempty(); iter.step()) - if (!(iter.deref() is Mal.Sym)) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected parameter name to be "+ - "symbol"); - return new Mal.Function(binds, body, env); - } - } - - var newlist = eval_ast(ast, env) as Mal.List; - unowned GLib.List firstlink = newlist.vs.first(); - Mal.Val firstdata = firstlink.data; - newlist.vs.remove_link(firstlink); - - if (firstdata is Mal.BuiltinFunction) { - return (firstdata as Mal.BuiltinFunction).call(newlist); - } else if (firstdata is Mal.Function) { - var fn = firstdata as Mal.Function; - var newenv = new Mal.Env.funcall( - fn.env, fn.parameters, newlist); - return EVAL(fn.body, newenv); - } else { - throw new Mal.Error.CANNOT_APPLY( - "bad value at start of list"); - } - } else { - return eval_ast(ast, env); - } - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep(Mal.Env env) throws Mal.Error { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val, env); - PRINT(val); - } - } - - public static int main(string[] args) { - var env = new Mal.Env(); - var root = new GC.Root(env); (void)root; - - Mal.Core.make_ns(); - foreach (var key in Mal.Core.ns.get_keys()) - env.set(new Mal.Sym(key), Mal.Core.ns[key]); - - try { - EVAL(Mal.Reader.read_str("(def! not (fn* (a) (if a false true)))"), - env); - } catch (Mal.Error err) { - assert(false); // shouldn't happen - } - - while (!eof) { - try { - rep(env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - } - } - return 0; - } -} +class Mal.Main: GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var roota = new GC.Root(ast); (void)roota; + var roote = new GC.Root(env); (void)roote; + if (ast is Mal.Sym) + return env.get(ast as Mal.Sym); + if (ast is Mal.List) { + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + foreach (var elt in (ast as Mal.List).vs) + result.vs.append(EVAL(elt, env)); + return result; + } + if (ast is Mal.Vector) { + var vec = ast as Mal.Vector; + var result = new Mal.Vector.with_size(vec.length); + var root = new GC.Root(result); (void)root; + for (var i = 0; i < vec.length; i++) + result[i] = EVAL(vec[i], env); + return result; + } + if (ast is Mal.Hashmap) { + var result = new Mal.Hashmap(); + var root = new GC.Root(result); (void)root; + var map = (ast as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) + result.insert(key, EVAL(map[key], env)); + return result; + } + return ast; + } + + private static Mal.Val define_eval(Mal.Val key, Mal.Val value, + Mal.Env env) + throws Mal.Error { + var rootk = new GC.Root(key); (void)rootk; + var roote = new GC.Root(env); (void)roote; + var symkey = key as Mal.Sym; + if (symkey == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected a symbol to define"); + var val = EVAL(value, env); + env.set(symkey, val); + return val; + } + + public static Mal.Val EVAL(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var ast_root = new GC.Root(ast); (void)ast_root; + var env_root = new GC.Root(env); (void)env_root; + GC.Core.maybe_collect(); + + if (ast is Mal.List) { + unowned GLib.List list = (ast as Mal.List).vs; + if (list.first() == null) + return ast; + + var first = list.first().data; + if (first is Mal.Sym) { + var sym = first as Mal.Sym; + switch (sym.v) { + case "def!": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "def!: expected two values"); + return define_eval(list.next.data, list.next.next.data, + env); + case "let*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "let*: expected two values"); + var defns = list.nth(1).data; + var newenv = new Mal.Env.within(env); + + if (defns is Mal.List) { + for (unowned GLib.List iter = + (defns as Mal.List).vs; + iter != null; iter = iter.next.next) { + if (iter.next == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length list" + + " of definitions"); + define_eval(iter.data, iter.next.data, newenv); + } + } else if (defns is Mal.Vector) { + var vec = defns as Mal.Vector; + if (vec.length % 2 != 0) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length vector" + + " of definitions"); + for (var i = 0; i < vec.length; i += 2) + define_eval(vec[i], vec[i+1], newenv); + } else { + throw new Mal.Error.BAD_PARAMS( + "let*: expected a list or vector of definitions"); + } + return EVAL(list.nth(2).data, newenv); + case "do": + Mal.Val result = null; + for (list = list.next; list != null; list = list.next) + result = EVAL(list.data, env); + if (result == null) + throw new Mal.Error.BAD_PARAMS( + "do: expected at least one argument"); + return result; + case "if": + if (list.length() != 3 && list.length() != 4) + throw new Mal.Error.BAD_PARAMS( + "if: expected two or three arguments"); + list = list.next; + var cond = EVAL(list.data, env); + list = list.next; + if (!cond.truth_value()) { + // Skip to the else clause, which defaults to nil. + list = list.next; + if (list == null) + return new Mal.Nil(); + } + return EVAL(list.data, env); + case "fn*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected two arguments"); + var binds = list.next.data as Mal.Listlike; + var body = list.next.next.data; + if (binds == null) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected a list of parameter names"); + for (var iter = binds.iter(); iter.nonempty(); iter.step()) + if (!(iter.deref() is Mal.Sym)) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected parameter name to be "+ + "symbol"); + return new Mal.Function(binds, body, env); + } + } + + var newlist = eval_ast(ast, env) as Mal.List; + unowned GLib.List firstlink = newlist.vs.first(); + Mal.Val firstdata = firstlink.data; + newlist.vs.remove_link(firstlink); + + if (firstdata is Mal.BuiltinFunction) { + return (firstdata as Mal.BuiltinFunction).call(newlist); + } else if (firstdata is Mal.Function) { + var fn = firstdata as Mal.Function; + var newenv = new Mal.Env.funcall( + fn.env, fn.parameters, newlist); + return EVAL(fn.body, newenv); + } else { + throw new Mal.Error.CANNOT_APPLY( + "bad value at start of list"); + } + } else { + return eval_ast(ast, env); + } + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep(Mal.Env env) throws Mal.Error { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val, env); + PRINT(val); + } + } + + public static int main(string[] args) { + var env = new Mal.Env(); + var root = new GC.Root(env); (void)root; + + Mal.Core.make_ns(); + foreach (var key in Mal.Core.ns.get_keys()) + env.set(new Mal.Sym(key), Mal.Core.ns[key]); + + try { + EVAL(Mal.Reader.read_str("(def! not (fn* (a) (if a false true)))"), + env); + } catch (Mal.Error err) { + assert(false); // shouldn't happen + } + + while (!eof) { + try { + rep(env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + } + } + return 0; + } +} diff --git a/impls/vala/step5_tco.vala b/impls/vala/step5_tco.vala index c29a31fd6d..e8027ad6ac 100644 --- a/impls/vala/step5_tco.vala +++ b/impls/vala/step5_tco.vala @@ -1,233 +1,233 @@ -class Mal.Main : GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var roota = new GC.Root(ast); (void)roota; - var roote = new GC.Root(env); (void)roote; - if (ast is Mal.Sym) - return env.get(ast as Mal.Sym); - if (ast is Mal.List) { - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - foreach (var elt in (ast as Mal.List).vs) - result.vs.append(EVAL(elt, env)); - return result; - } - if (ast is Mal.Vector) { - var vec = ast as Mal.Vector; - var result = new Mal.Vector.with_size(vec.length); - var root = new GC.Root(result); (void)root; - for (var i = 0; i < vec.length; i++) - result[i] = EVAL(vec[i], env); - return result; - } - if (ast is Mal.Hashmap) { - var result = new Mal.Hashmap(); - var root = new GC.Root(result); (void)root; - var map = (ast as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) - result.insert(key, EVAL(map[key], env)); - return result; - } - return ast; - } - - private static Mal.Val define_eval(Mal.Val key, Mal.Val value, - Mal.Env env) - throws Mal.Error { - var rootk = new GC.Root(key); (void)rootk; - var roote = new GC.Root(env); (void)roote; - var symkey = key as Mal.Sym; - if (symkey == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected a symbol to define"); - var val = EVAL(value, env); - env.set(symkey, val); - return val; - } - - public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) - throws Mal.Error { - // Copy the implicitly 'unowned' function arguments into - // ordinary owned variables which increment the objects' - // reference counts. This is so that when we overwrite these - // variables within the loop (for TCO) the objects we assign - // into them don't immediately get garbage-collected. - Mal.Val ast = ast_; - Mal.Env env = env_; - var ast_root = new GC.Root(ast); (void)ast_root; - var env_root = new GC.Root(env); (void)env_root; - while (true) { - ast_root.obj = ast; - env_root.obj = env; - GC.Core.maybe_collect(); - if (ast is Mal.List) { - unowned GLib.List list = (ast as Mal.List).vs; - if (list.first() == null) - return ast; - - var first = list.first().data; - if (first is Mal.Sym) { - var sym = first as Mal.Sym; - switch (sym.v) { - case "def!": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "def!: expected two values"); - return define_eval(list.next.data, list.next.next.data, - env); - case "let*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "let*: expected two values"); - var defns = list.nth(1).data; - env = new Mal.Env.within(env); - - if (defns is Mal.List) { - for (unowned GLib.List iter = - (defns as Mal.List).vs; - iter != null; iter = iter.next.next) { - if (iter.next == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length list" + - " of definitions"); - define_eval(iter.data, iter.next.data, env); - } - } else if (defns is Mal.Vector) { - var vec = defns as Mal.Vector; - if (vec.length % 2 != 0) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length vector" + - " of definitions"); - for (var i = 0; i < vec.length; i += 2) - define_eval(vec[i], vec[i+1], env); - } else { - throw new Mal.Error.BAD_PARAMS( - "let*: expected a list or vector of definitions"); - } - ast = list.nth(2).data; - continue; // tail-call optimisation - case "do": - Mal.Val result = null; - for (list = list.next; list != null; list = list.next) - result = EVAL(list.data, env); - if (result == null) - throw new Mal.Error.BAD_PARAMS( - "do: expected at least one argument"); - return result; - case "if": - if (list.length() != 3 && list.length() != 4) - throw new Mal.Error.BAD_PARAMS( - "if: expected two or three arguments"); - list = list.next; - var cond = EVAL(list.data, env); - list = list.next; - if (!cond.truth_value()) { - // Skip to the else clause, which defaults to nil. - list = list.next; - if (list == null) - return new Mal.Nil(); - } - ast = list.data; - continue; // tail-call optimisation - case "fn*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected two arguments"); - var binds = list.next.data as Mal.Listlike; - var body = list.next.next.data; - if (binds == null) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected a list of parameter names"); - for (var iter = binds.iter(); iter.nonempty(); iter.step()) - if (!(iter.deref() is Mal.Sym)) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected parameter name to be "+ - "symbol"); - return new Mal.Function(binds, body, env); - } - } - - var newlist = eval_ast(ast, env) as Mal.List; - unowned GLib.List firstlink = newlist.vs.first(); - Mal.Val firstdata = firstlink.data; - newlist.vs.remove_link(firstlink); - - if (firstdata is Mal.BuiltinFunction) { - return (firstdata as Mal.BuiltinFunction).call(newlist); - } else if (firstdata is Mal.Function) { - var fn = firstdata as Mal.Function; - env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); - ast = fn.body; - continue; // tail-call optimisation - } else { - throw new Mal.Error.CANNOT_APPLY( - "bad value at start of list"); - } - } else { - return eval_ast(ast, env); - } - } - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep(Mal.Env env) throws Mal.Error { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val, env); - PRINT(val); - } - } - - public static int main(string[] args) { - var env = new Mal.Env(); - var root = new GC.Root(env); (void)root; - - Mal.Core.make_ns(); - foreach (var key in Mal.Core.ns.get_keys()) - env.set(new Mal.Sym(key), Mal.Core.ns[key]); - - try { - EVAL(Mal.Reader.read_str("(def! not (fn* (a) (if a false true)))"), - env); - } catch (Mal.Error err) { - assert(false); // shouldn't happen - } - - while (!eof) { - try { - rep(env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - } - } - return 0; - } -} +class Mal.Main : GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var roota = new GC.Root(ast); (void)roota; + var roote = new GC.Root(env); (void)roote; + if (ast is Mal.Sym) + return env.get(ast as Mal.Sym); + if (ast is Mal.List) { + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + foreach (var elt in (ast as Mal.List).vs) + result.vs.append(EVAL(elt, env)); + return result; + } + if (ast is Mal.Vector) { + var vec = ast as Mal.Vector; + var result = new Mal.Vector.with_size(vec.length); + var root = new GC.Root(result); (void)root; + for (var i = 0; i < vec.length; i++) + result[i] = EVAL(vec[i], env); + return result; + } + if (ast is Mal.Hashmap) { + var result = new Mal.Hashmap(); + var root = new GC.Root(result); (void)root; + var map = (ast as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) + result.insert(key, EVAL(map[key], env)); + return result; + } + return ast; + } + + private static Mal.Val define_eval(Mal.Val key, Mal.Val value, + Mal.Env env) + throws Mal.Error { + var rootk = new GC.Root(key); (void)rootk; + var roote = new GC.Root(env); (void)roote; + var symkey = key as Mal.Sym; + if (symkey == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected a symbol to define"); + var val = EVAL(value, env); + env.set(symkey, val); + return val; + } + + public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) + throws Mal.Error { + // Copy the implicitly 'unowned' function arguments into + // ordinary owned variables which increment the objects' + // reference counts. This is so that when we overwrite these + // variables within the loop (for TCO) the objects we assign + // into them don't immediately get garbage-collected. + Mal.Val ast = ast_; + Mal.Env env = env_; + var ast_root = new GC.Root(ast); (void)ast_root; + var env_root = new GC.Root(env); (void)env_root; + while (true) { + ast_root.obj = ast; + env_root.obj = env; + GC.Core.maybe_collect(); + if (ast is Mal.List) { + unowned GLib.List list = (ast as Mal.List).vs; + if (list.first() == null) + return ast; + + var first = list.first().data; + if (first is Mal.Sym) { + var sym = first as Mal.Sym; + switch (sym.v) { + case "def!": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "def!: expected two values"); + return define_eval(list.next.data, list.next.next.data, + env); + case "let*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "let*: expected two values"); + var defns = list.nth(1).data; + env = new Mal.Env.within(env); + + if (defns is Mal.List) { + for (unowned GLib.List iter = + (defns as Mal.List).vs; + iter != null; iter = iter.next.next) { + if (iter.next == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length list" + + " of definitions"); + define_eval(iter.data, iter.next.data, env); + } + } else if (defns is Mal.Vector) { + var vec = defns as Mal.Vector; + if (vec.length % 2 != 0) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length vector" + + " of definitions"); + for (var i = 0; i < vec.length; i += 2) + define_eval(vec[i], vec[i+1], env); + } else { + throw new Mal.Error.BAD_PARAMS( + "let*: expected a list or vector of definitions"); + } + ast = list.nth(2).data; + continue; // tail-call optimisation + case "do": + Mal.Val result = null; + for (list = list.next; list != null; list = list.next) + result = EVAL(list.data, env); + if (result == null) + throw new Mal.Error.BAD_PARAMS( + "do: expected at least one argument"); + return result; + case "if": + if (list.length() != 3 && list.length() != 4) + throw new Mal.Error.BAD_PARAMS( + "if: expected two or three arguments"); + list = list.next; + var cond = EVAL(list.data, env); + list = list.next; + if (!cond.truth_value()) { + // Skip to the else clause, which defaults to nil. + list = list.next; + if (list == null) + return new Mal.Nil(); + } + ast = list.data; + continue; // tail-call optimisation + case "fn*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected two arguments"); + var binds = list.next.data as Mal.Listlike; + var body = list.next.next.data; + if (binds == null) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected a list of parameter names"); + for (var iter = binds.iter(); iter.nonempty(); iter.step()) + if (!(iter.deref() is Mal.Sym)) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected parameter name to be "+ + "symbol"); + return new Mal.Function(binds, body, env); + } + } + + var newlist = eval_ast(ast, env) as Mal.List; + unowned GLib.List firstlink = newlist.vs.first(); + Mal.Val firstdata = firstlink.data; + newlist.vs.remove_link(firstlink); + + if (firstdata is Mal.BuiltinFunction) { + return (firstdata as Mal.BuiltinFunction).call(newlist); + } else if (firstdata is Mal.Function) { + var fn = firstdata as Mal.Function; + env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); + ast = fn.body; + continue; // tail-call optimisation + } else { + throw new Mal.Error.CANNOT_APPLY( + "bad value at start of list"); + } + } else { + return eval_ast(ast, env); + } + } + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep(Mal.Env env) throws Mal.Error { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val, env); + PRINT(val); + } + } + + public static int main(string[] args) { + var env = new Mal.Env(); + var root = new GC.Root(env); (void)root; + + Mal.Core.make_ns(); + foreach (var key in Mal.Core.ns.get_keys()) + env.set(new Mal.Sym(key), Mal.Core.ns[key]); + + try { + EVAL(Mal.Reader.read_str("(def! not (fn* (a) (if a false true)))"), + env); + } catch (Mal.Error err) { + assert(false); // shouldn't happen + } + + while (!eof) { + try { + rep(env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + } + } + return 0; + } +} diff --git a/impls/vala/step6_file.vala b/impls/vala/step6_file.vala index 8177d75b3f..08f2af838f 100644 --- a/impls/vala/step6_file.vala +++ b/impls/vala/step6_file.vala @@ -1,271 +1,271 @@ -class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { - public Mal.Env env; - public BuiltinFunctionEval(Mal.Env env_) { env = env_; } - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionEval(env); - } - public override string name() { return "eval"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return Mal.Main.EVAL(args.vs.data, env); - } -} - -class Mal.Main : GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var roota = new GC.Root(ast); (void)roota; - var roote = new GC.Root(env); (void)roote; - if (ast is Mal.Sym) - return env.get(ast as Mal.Sym); - if (ast is Mal.List) { - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - foreach (var elt in (ast as Mal.List).vs) - result.vs.append(EVAL(elt, env)); - return result; - } - if (ast is Mal.Vector) { - var vec = ast as Mal.Vector; - var result = new Mal.Vector.with_size(vec.length); - var root = new GC.Root(result); (void)root; - for (var i = 0; i < vec.length; i++) - result[i] = EVAL(vec[i], env); - return result; - } - if (ast is Mal.Hashmap) { - var result = new Mal.Hashmap(); - var root = new GC.Root(result); (void)root; - var map = (ast as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) - result.insert(key, EVAL(map[key], env)); - return result; - } - return ast; - } - - private static Mal.Val define_eval(Mal.Val key, Mal.Val value, - Mal.Env env) - throws Mal.Error { - var rootk = new GC.Root(key); (void)rootk; - var roote = new GC.Root(env); (void)roote; - var symkey = key as Mal.Sym; - if (symkey == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected a symbol to define"); - var val = EVAL(value, env); - env.set(symkey, val); - return val; - } - - public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) - throws Mal.Error { - // Copy the implicitly 'unowned' function arguments into - // ordinary owned variables which increment the objects' - // reference counts. This is so that when we overwrite these - // variables within the loop (for TCO) the objects we assign - // into them don't immediately get garbage-collected. - Mal.Val ast = ast_; - Mal.Env env = env_; - var ast_root = new GC.Root(ast); (void)ast_root; - var env_root = new GC.Root(env); (void)env_root; - while (true) { - ast_root.obj = ast; - env_root.obj = env; - GC.Core.maybe_collect(); - if (ast is Mal.List) { - unowned GLib.List list = (ast as Mal.List).vs; - if (list.first() == null) - return ast; - - var first = list.first().data; - if (first is Mal.Sym) { - var sym = first as Mal.Sym; - switch (sym.v) { - case "def!": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "def!: expected two values"); - return define_eval(list.next.data, list.next.next.data, - env); - case "let*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "let*: expected two values"); - var defns = list.nth(1).data; - env = new Mal.Env.within(env); - - if (defns is Mal.List) { - for (unowned GLib.List iter = - (defns as Mal.List).vs; - iter != null; iter = iter.next.next) { - if (iter.next == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length list" + - " of definitions"); - define_eval(iter.data, iter.next.data, env); - } - } else if (defns is Mal.Vector) { - var vec = defns as Mal.Vector; - if (vec.length % 2 != 0) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length vector" + - " of definitions"); - for (var i = 0; i < vec.length; i += 2) - define_eval(vec[i], vec[i+1], env); - } else { - throw new Mal.Error.BAD_PARAMS( - "let*: expected a list or vector of definitions"); - } - ast = list.nth(2).data; - continue; // tail-call optimisation - case "do": - Mal.Val result = null; - for (list = list.next; list != null; list = list.next) - result = EVAL(list.data, env); - if (result == null) - throw new Mal.Error.BAD_PARAMS( - "do: expected at least one argument"); - return result; - case "if": - if (list.length() != 3 && list.length() != 4) - throw new Mal.Error.BAD_PARAMS( - "if: expected two or three arguments"); - list = list.next; - var cond = EVAL(list.data, env); - list = list.next; - if (!cond.truth_value()) { - // Skip to the else clause, which defaults to nil. - list = list.next; - if (list == null) - return new Mal.Nil(); - } - ast = list.data; - continue; // tail-call optimisation - case "fn*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected two arguments"); - var binds = list.next.data as Mal.Listlike; - var body = list.next.next.data; - if (binds == null) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected a list of parameter names"); - for (var iter = binds.iter(); iter.nonempty(); iter.step()) - if (!(iter.deref() is Mal.Sym)) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected parameter name to be "+ - "symbol"); - return new Mal.Function(binds, body, env); - } - } - - var newlist = eval_ast(ast, env) as Mal.List; - unowned GLib.List firstlink = newlist.vs.first(); - Mal.Val firstdata = firstlink.data; - newlist.vs.remove_link(firstlink); - - if (firstdata is Mal.BuiltinFunction) { - return (firstdata as Mal.BuiltinFunction).call(newlist); - } else if (firstdata is Mal.Function) { - var fn = firstdata as Mal.Function; - env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); - ast = fn.body; - continue; // tail-call optimisation - } else { - throw new Mal.Error.CANNOT_APPLY( - "bad value at start of list"); - } - } else { - return eval_ast(ast, env); - } - } - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep(Mal.Env env) throws Mal.Error { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val, env); - PRINT(val); - } - } - - public static void setup(string line, Mal.Env env) { - try { - EVAL(Reader.read_str(line), env); - } catch (Mal.Error err) { - assert(false); // shouldn't happen - } - } - - public static int main(string[] args) { - var env = new Mal.Env(); - var root = new GC.Root(env); (void)root; - - Mal.Core.make_ns(); - foreach (var key in Mal.Core.ns.get_keys()) - env.set(new Mal.Sym(key), Mal.Core.ns[key]); - env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); - - setup("(def! not (fn* (a) (if a false true)))", env); - setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); - - var ARGV = new GLib.List(); - if (args.length > 1) { - for (int i = args.length - 1; i >= 2; i--) - ARGV.prepend(new Mal.String(args[i])); - } - env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); - - if (args.length > 1) { - var contents = new GLib.List(); - contents.prepend(new Mal.String(args[1])); - contents.prepend(new Mal.Sym("load-file")); - try { - EVAL(new Mal.List(contents), env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return 1; - } - } else { - while (!eof) { - try { - rep(env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - } - } - } - return 0; - } -} +class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { + public Mal.Env env; + public BuiltinFunctionEval(Mal.Env env_) { env = env_; } + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionEval(env); + } + public override string name() { return "eval"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return Mal.Main.EVAL(args.vs.data, env); + } +} + +class Mal.Main : GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var roota = new GC.Root(ast); (void)roota; + var roote = new GC.Root(env); (void)roote; + if (ast is Mal.Sym) + return env.get(ast as Mal.Sym); + if (ast is Mal.List) { + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + foreach (var elt in (ast as Mal.List).vs) + result.vs.append(EVAL(elt, env)); + return result; + } + if (ast is Mal.Vector) { + var vec = ast as Mal.Vector; + var result = new Mal.Vector.with_size(vec.length); + var root = new GC.Root(result); (void)root; + for (var i = 0; i < vec.length; i++) + result[i] = EVAL(vec[i], env); + return result; + } + if (ast is Mal.Hashmap) { + var result = new Mal.Hashmap(); + var root = new GC.Root(result); (void)root; + var map = (ast as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) + result.insert(key, EVAL(map[key], env)); + return result; + } + return ast; + } + + private static Mal.Val define_eval(Mal.Val key, Mal.Val value, + Mal.Env env) + throws Mal.Error { + var rootk = new GC.Root(key); (void)rootk; + var roote = new GC.Root(env); (void)roote; + var symkey = key as Mal.Sym; + if (symkey == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected a symbol to define"); + var val = EVAL(value, env); + env.set(symkey, val); + return val; + } + + public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) + throws Mal.Error { + // Copy the implicitly 'unowned' function arguments into + // ordinary owned variables which increment the objects' + // reference counts. This is so that when we overwrite these + // variables within the loop (for TCO) the objects we assign + // into them don't immediately get garbage-collected. + Mal.Val ast = ast_; + Mal.Env env = env_; + var ast_root = new GC.Root(ast); (void)ast_root; + var env_root = new GC.Root(env); (void)env_root; + while (true) { + ast_root.obj = ast; + env_root.obj = env; + GC.Core.maybe_collect(); + if (ast is Mal.List) { + unowned GLib.List list = (ast as Mal.List).vs; + if (list.first() == null) + return ast; + + var first = list.first().data; + if (first is Mal.Sym) { + var sym = first as Mal.Sym; + switch (sym.v) { + case "def!": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "def!: expected two values"); + return define_eval(list.next.data, list.next.next.data, + env); + case "let*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "let*: expected two values"); + var defns = list.nth(1).data; + env = new Mal.Env.within(env); + + if (defns is Mal.List) { + for (unowned GLib.List iter = + (defns as Mal.List).vs; + iter != null; iter = iter.next.next) { + if (iter.next == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length list" + + " of definitions"); + define_eval(iter.data, iter.next.data, env); + } + } else if (defns is Mal.Vector) { + var vec = defns as Mal.Vector; + if (vec.length % 2 != 0) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length vector" + + " of definitions"); + for (var i = 0; i < vec.length; i += 2) + define_eval(vec[i], vec[i+1], env); + } else { + throw new Mal.Error.BAD_PARAMS( + "let*: expected a list or vector of definitions"); + } + ast = list.nth(2).data; + continue; // tail-call optimisation + case "do": + Mal.Val result = null; + for (list = list.next; list != null; list = list.next) + result = EVAL(list.data, env); + if (result == null) + throw new Mal.Error.BAD_PARAMS( + "do: expected at least one argument"); + return result; + case "if": + if (list.length() != 3 && list.length() != 4) + throw new Mal.Error.BAD_PARAMS( + "if: expected two or three arguments"); + list = list.next; + var cond = EVAL(list.data, env); + list = list.next; + if (!cond.truth_value()) { + // Skip to the else clause, which defaults to nil. + list = list.next; + if (list == null) + return new Mal.Nil(); + } + ast = list.data; + continue; // tail-call optimisation + case "fn*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected two arguments"); + var binds = list.next.data as Mal.Listlike; + var body = list.next.next.data; + if (binds == null) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected a list of parameter names"); + for (var iter = binds.iter(); iter.nonempty(); iter.step()) + if (!(iter.deref() is Mal.Sym)) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected parameter name to be "+ + "symbol"); + return new Mal.Function(binds, body, env); + } + } + + var newlist = eval_ast(ast, env) as Mal.List; + unowned GLib.List firstlink = newlist.vs.first(); + Mal.Val firstdata = firstlink.data; + newlist.vs.remove_link(firstlink); + + if (firstdata is Mal.BuiltinFunction) { + return (firstdata as Mal.BuiltinFunction).call(newlist); + } else if (firstdata is Mal.Function) { + var fn = firstdata as Mal.Function; + env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); + ast = fn.body; + continue; // tail-call optimisation + } else { + throw new Mal.Error.CANNOT_APPLY( + "bad value at start of list"); + } + } else { + return eval_ast(ast, env); + } + } + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep(Mal.Env env) throws Mal.Error { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val, env); + PRINT(val); + } + } + + public static void setup(string line, Mal.Env env) { + try { + EVAL(Reader.read_str(line), env); + } catch (Mal.Error err) { + assert(false); // shouldn't happen + } + } + + public static int main(string[] args) { + var env = new Mal.Env(); + var root = new GC.Root(env); (void)root; + + Mal.Core.make_ns(); + foreach (var key in Mal.Core.ns.get_keys()) + env.set(new Mal.Sym(key), Mal.Core.ns[key]); + env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); + + setup("(def! not (fn* (a) (if a false true)))", env); + setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); + + var ARGV = new GLib.List(); + if (args.length > 1) { + for (int i = args.length - 1; i >= 2; i--) + ARGV.prepend(new Mal.String(args[i])); + } + env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); + + if (args.length > 1) { + var contents = new GLib.List(); + contents.prepend(new Mal.String(args[1])); + contents.prepend(new Mal.Sym("load-file")); + try { + EVAL(new Mal.List(contents), env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return 1; + } + } else { + while (!eof) { + try { + rep(env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + } + } + } + return 0; + } +} diff --git a/impls/vala/step7_quote.vala b/impls/vala/step7_quote.vala index 2347b9b185..e1e2469028 100644 --- a/impls/vala/step7_quote.vala +++ b/impls/vala/step7_quote.vala @@ -1,352 +1,352 @@ -class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { - public Mal.Env env; - public BuiltinFunctionEval(Mal.Env env_) { env = env_; } - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionEval(env); - } - public override string name() { return "eval"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return Mal.Main.EVAL(args.vs.data, env); - } -} - -class Mal.Main : GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var roota = new GC.Root(ast); (void)roota; - var roote = new GC.Root(env); (void)roote; - if (ast is Mal.Sym) - return env.get(ast as Mal.Sym); - if (ast is Mal.List) { - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - foreach (var elt in (ast as Mal.List).vs) - result.vs.append(EVAL(elt, env)); - return result; - } - if (ast is Mal.Vector) { - var vec = ast as Mal.Vector; - var result = new Mal.Vector.with_size(vec.length); - var root = new GC.Root(result); (void)root; - for (var i = 0; i < vec.length; i++) - result[i] = EVAL(vec[i], env); - return result; - } - if (ast is Mal.Hashmap) { - var result = new Mal.Hashmap(); - var root = new GC.Root(result); (void)root; - var map = (ast as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) - result.insert(key, EVAL(map[key], env)); - return result; - } - return ast; - } - - private static Mal.Val define_eval(Mal.Val key, Mal.Val value, - Mal.Env env) - throws Mal.Error { - var rootk = new GC.Root(key); (void)rootk; - var roote = new GC.Root(env); (void)roote; - var symkey = key as Mal.Sym; - if (symkey == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected a symbol to define"); - var val = EVAL(value, env); - env.set(symkey, val); - return val; - } - - // If ast is (sym x), return x, else return null. - public static Mal.Val? unquoted (Mal.Val ast, - string sym) - throws Mal.Error { - var list = ast as Mal.List; - if (list == null || list.vs == null) return null; - var a0 = list.vs.data as Mal.Sym; - if (a0 == null || a0.v != sym) return null; - if (list.vs.next == null || list.vs.next.next != null) - throw new Mal.Error.BAD_PARAMS(sym + ": wrong arg count"); - return list.vs.next.data; - } - - public static Mal.Val qq_loop(Mal.Val elt, - Mal.Val acc) - throws Mal.Error { - var list = new Mal.List.empty(); - var unq = unquoted(elt, "splice-unquote"); - if (unq != null) { - list.vs.append(new Mal.Sym("concat")); - list.vs.append(unq); - } else { - list.vs.append(new Mal.Sym("cons")); - list.vs.append(quasiquote (elt)); - } - list.vs.append(acc); - return list; - } - - public static Mal.Val qq_foldr(Mal.Iterator xs) - throws Mal.Error { - if (xs.empty()) { - return new Mal.List.empty(); - } else { - var elt = xs.deref(); - xs.step(); - return qq_loop(elt, qq_foldr(xs)); - } - } - - public static Mal.Val quasiquote(Mal.Val ast) - throws Mal.Error { - if (ast is Mal.List) { - var unq = unquoted(ast, "unquote"); - if (unq != null) { - return unq; - } else { - return qq_foldr((ast as Mal.List).iter()); - } - } else if (ast is Mal.Vector) { - var list = new Mal.List.empty(); - list.vs.append(new Mal.Sym("vec")); - list.vs.append(qq_foldr((ast as Mal.Vector).iter())); - return list; - } else if (ast is Mal.Sym || ast is Mal.Hashmap) { - var list = new Mal.List.empty(); - list.vs.append(new Mal.Sym("quote")); - list.vs.append(ast); - return list; - } else { - return ast; - } - } - - public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) - throws Mal.Error { - // Copy the implicitly 'unowned' function arguments into - // ordinary owned variables which increment the objects' - // reference counts. This is so that when we overwrite these - // variables within the loop (for TCO) the objects we assign - // into them don't immediately get garbage-collected. - Mal.Val ast = ast_; - Mal.Env env = env_; - var ast_root = new GC.Root(ast); (void)ast_root; - var env_root = new GC.Root(env); (void)env_root; - while (true) { - ast_root.obj = ast; - env_root.obj = env; - GC.Core.maybe_collect(); - if (ast is Mal.List) { - unowned GLib.List list = (ast as Mal.List).vs; - if (list.first() == null) - return ast; - - var first = list.first().data; - if (first is Mal.Sym) { - var sym = first as Mal.Sym; - switch (sym.v) { - case "def!": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "def!: expected two values"); - return define_eval(list.next.data, list.next.next.data, - env); - case "let*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "let*: expected two values"); - var defns = list.nth(1).data; - env = new Mal.Env.within(env); - - if (defns is Mal.List) { - for (unowned GLib.List iter = - (defns as Mal.List).vs; - iter != null; iter = iter.next.next) { - if (iter.next == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length list" + - " of definitions"); - define_eval(iter.data, iter.next.data, env); - } - } else if (defns is Mal.Vector) { - var vec = defns as Mal.Vector; - if (vec.length % 2 != 0) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length vector" + - " of definitions"); - for (var i = 0; i < vec.length; i += 2) - define_eval(vec[i], vec[i+1], env); - } else { - throw new Mal.Error.BAD_PARAMS( - "let*: expected a list or vector of definitions"); - } - ast = list.nth(2).data; - continue; // tail-call optimisation - case "do": - Mal.Val result = null; - for (list = list.next; list != null; list = list.next) - result = EVAL(list.data, env); - if (result == null) - throw new Mal.Error.BAD_PARAMS( - "do: expected at least one argument"); - return result; - case "if": - if (list.length() != 3 && list.length() != 4) - throw new Mal.Error.BAD_PARAMS( - "if: expected two or three arguments"); - list = list.next; - var cond = EVAL(list.data, env); - list = list.next; - if (!cond.truth_value()) { - // Skip to the else clause, which defaults to nil. - list = list.next; - if (list == null) - return new Mal.Nil(); - } - ast = list.data; - continue; // tail-call optimisation - case "fn*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected two arguments"); - var binds = list.next.data as Mal.Listlike; - var body = list.next.next.data; - if (binds == null) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected a list of parameter names"); - for (var iter = binds.iter(); iter.nonempty(); - iter.step()) - if (!(iter.deref() is Mal.Sym)) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected parameter name to be "+ - "symbol"); - return new Mal.Function(binds, body, env); - case "quote": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quote: expected one argument"); - return list.next.data; - case "quasiquoteexpand": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quasiquoteexpand: expected one argument"); - return quasiquote(list.next.data); - case "quasiquote": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quasiquote: expected one argument"); - ast = quasiquote(list.next.data); - continue; // tail-call optimisation - } - } - - var newlist = eval_ast(ast, env) as Mal.List; - unowned GLib.List firstlink = newlist.vs.first(); - Mal.Val firstdata = firstlink.data; - newlist.vs.remove_link(firstlink); - - if (firstdata is Mal.BuiltinFunction) { - return (firstdata as Mal.BuiltinFunction).call(newlist); - } else if (firstdata is Mal.Function) { - var fn = firstdata as Mal.Function; - env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); - ast = fn.body; - continue; // tail-call optimisation - } else { - throw new Mal.Error.CANNOT_APPLY( - "bad value at start of list"); - } - } else { - return eval_ast(ast, env); - } - } - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep(Mal.Env env) throws Mal.Error { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val, env); - PRINT(val); - } - } - - public static void setup(string line, Mal.Env env) { - try { - EVAL(Reader.read_str(line), env); - } catch (Mal.Error err) { - assert(false); // shouldn't happen - } - } - - public static int main(string[] args) { - var env = new Mal.Env(); - var root = new GC.Root(env); (void)root; - - Mal.Core.make_ns(); - foreach (var key in Mal.Core.ns.get_keys()) - env.set(new Mal.Sym(key), Mal.Core.ns[key]); - env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); - - setup("(def! not (fn* (a) (if a false true)))", env); - setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); - - var ARGV = new GLib.List(); - if (args.length > 1) { - for (int i = args.length - 1; i >= 2; i--) - ARGV.prepend(new Mal.String(args[i])); - } - env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); - - if (args.length > 1) { - var contents = new GLib.List(); - contents.prepend(new Mal.String(args[1])); - contents.prepend(new Mal.Sym("load-file")); - try { - EVAL(new Mal.List(contents), env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return 1; - } - } else { - while (!eof) { - try { - rep(env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - } - } - } - return 0; - } -} +class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { + public Mal.Env env; + public BuiltinFunctionEval(Mal.Env env_) { env = env_; } + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionEval(env); + } + public override string name() { return "eval"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return Mal.Main.EVAL(args.vs.data, env); + } +} + +class Mal.Main : GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var roota = new GC.Root(ast); (void)roota; + var roote = new GC.Root(env); (void)roote; + if (ast is Mal.Sym) + return env.get(ast as Mal.Sym); + if (ast is Mal.List) { + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + foreach (var elt in (ast as Mal.List).vs) + result.vs.append(EVAL(elt, env)); + return result; + } + if (ast is Mal.Vector) { + var vec = ast as Mal.Vector; + var result = new Mal.Vector.with_size(vec.length); + var root = new GC.Root(result); (void)root; + for (var i = 0; i < vec.length; i++) + result[i] = EVAL(vec[i], env); + return result; + } + if (ast is Mal.Hashmap) { + var result = new Mal.Hashmap(); + var root = new GC.Root(result); (void)root; + var map = (ast as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) + result.insert(key, EVAL(map[key], env)); + return result; + } + return ast; + } + + private static Mal.Val define_eval(Mal.Val key, Mal.Val value, + Mal.Env env) + throws Mal.Error { + var rootk = new GC.Root(key); (void)rootk; + var roote = new GC.Root(env); (void)roote; + var symkey = key as Mal.Sym; + if (symkey == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected a symbol to define"); + var val = EVAL(value, env); + env.set(symkey, val); + return val; + } + + // If ast is (sym x), return x, else return null. + public static Mal.Val? unquoted (Mal.Val ast, + string sym) + throws Mal.Error { + var list = ast as Mal.List; + if (list == null || list.vs == null) return null; + var a0 = list.vs.data as Mal.Sym; + if (a0 == null || a0.v != sym) return null; + if (list.vs.next == null || list.vs.next.next != null) + throw new Mal.Error.BAD_PARAMS(sym + ": wrong arg count"); + return list.vs.next.data; + } + + public static Mal.Val qq_loop(Mal.Val elt, + Mal.Val acc) + throws Mal.Error { + var list = new Mal.List.empty(); + var unq = unquoted(elt, "splice-unquote"); + if (unq != null) { + list.vs.append(new Mal.Sym("concat")); + list.vs.append(unq); + } else { + list.vs.append(new Mal.Sym("cons")); + list.vs.append(quasiquote (elt)); + } + list.vs.append(acc); + return list; + } + + public static Mal.Val qq_foldr(Mal.Iterator xs) + throws Mal.Error { + if (xs.empty()) { + return new Mal.List.empty(); + } else { + var elt = xs.deref(); + xs.step(); + return qq_loop(elt, qq_foldr(xs)); + } + } + + public static Mal.Val quasiquote(Mal.Val ast) + throws Mal.Error { + if (ast is Mal.List) { + var unq = unquoted(ast, "unquote"); + if (unq != null) { + return unq; + } else { + return qq_foldr((ast as Mal.List).iter()); + } + } else if (ast is Mal.Vector) { + var list = new Mal.List.empty(); + list.vs.append(new Mal.Sym("vec")); + list.vs.append(qq_foldr((ast as Mal.Vector).iter())); + return list; + } else if (ast is Mal.Sym || ast is Mal.Hashmap) { + var list = new Mal.List.empty(); + list.vs.append(new Mal.Sym("quote")); + list.vs.append(ast); + return list; + } else { + return ast; + } + } + + public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) + throws Mal.Error { + // Copy the implicitly 'unowned' function arguments into + // ordinary owned variables which increment the objects' + // reference counts. This is so that when we overwrite these + // variables within the loop (for TCO) the objects we assign + // into them don't immediately get garbage-collected. + Mal.Val ast = ast_; + Mal.Env env = env_; + var ast_root = new GC.Root(ast); (void)ast_root; + var env_root = new GC.Root(env); (void)env_root; + while (true) { + ast_root.obj = ast; + env_root.obj = env; + GC.Core.maybe_collect(); + if (ast is Mal.List) { + unowned GLib.List list = (ast as Mal.List).vs; + if (list.first() == null) + return ast; + + var first = list.first().data; + if (first is Mal.Sym) { + var sym = first as Mal.Sym; + switch (sym.v) { + case "def!": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "def!: expected two values"); + return define_eval(list.next.data, list.next.next.data, + env); + case "let*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "let*: expected two values"); + var defns = list.nth(1).data; + env = new Mal.Env.within(env); + + if (defns is Mal.List) { + for (unowned GLib.List iter = + (defns as Mal.List).vs; + iter != null; iter = iter.next.next) { + if (iter.next == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length list" + + " of definitions"); + define_eval(iter.data, iter.next.data, env); + } + } else if (defns is Mal.Vector) { + var vec = defns as Mal.Vector; + if (vec.length % 2 != 0) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length vector" + + " of definitions"); + for (var i = 0; i < vec.length; i += 2) + define_eval(vec[i], vec[i+1], env); + } else { + throw new Mal.Error.BAD_PARAMS( + "let*: expected a list or vector of definitions"); + } + ast = list.nth(2).data; + continue; // tail-call optimisation + case "do": + Mal.Val result = null; + for (list = list.next; list != null; list = list.next) + result = EVAL(list.data, env); + if (result == null) + throw new Mal.Error.BAD_PARAMS( + "do: expected at least one argument"); + return result; + case "if": + if (list.length() != 3 && list.length() != 4) + throw new Mal.Error.BAD_PARAMS( + "if: expected two or three arguments"); + list = list.next; + var cond = EVAL(list.data, env); + list = list.next; + if (!cond.truth_value()) { + // Skip to the else clause, which defaults to nil. + list = list.next; + if (list == null) + return new Mal.Nil(); + } + ast = list.data; + continue; // tail-call optimisation + case "fn*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected two arguments"); + var binds = list.next.data as Mal.Listlike; + var body = list.next.next.data; + if (binds == null) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected a list of parameter names"); + for (var iter = binds.iter(); iter.nonempty(); + iter.step()) + if (!(iter.deref() is Mal.Sym)) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected parameter name to be "+ + "symbol"); + return new Mal.Function(binds, body, env); + case "quote": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quote: expected one argument"); + return list.next.data; + case "quasiquoteexpand": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quasiquoteexpand: expected one argument"); + return quasiquote(list.next.data); + case "quasiquote": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quasiquote: expected one argument"); + ast = quasiquote(list.next.data); + continue; // tail-call optimisation + } + } + + var newlist = eval_ast(ast, env) as Mal.List; + unowned GLib.List firstlink = newlist.vs.first(); + Mal.Val firstdata = firstlink.data; + newlist.vs.remove_link(firstlink); + + if (firstdata is Mal.BuiltinFunction) { + return (firstdata as Mal.BuiltinFunction).call(newlist); + } else if (firstdata is Mal.Function) { + var fn = firstdata as Mal.Function; + env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); + ast = fn.body; + continue; // tail-call optimisation + } else { + throw new Mal.Error.CANNOT_APPLY( + "bad value at start of list"); + } + } else { + return eval_ast(ast, env); + } + } + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep(Mal.Env env) throws Mal.Error { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val, env); + PRINT(val); + } + } + + public static void setup(string line, Mal.Env env) { + try { + EVAL(Reader.read_str(line), env); + } catch (Mal.Error err) { + assert(false); // shouldn't happen + } + } + + public static int main(string[] args) { + var env = new Mal.Env(); + var root = new GC.Root(env); (void)root; + + Mal.Core.make_ns(); + foreach (var key in Mal.Core.ns.get_keys()) + env.set(new Mal.Sym(key), Mal.Core.ns[key]); + env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); + + setup("(def! not (fn* (a) (if a false true)))", env); + setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); + + var ARGV = new GLib.List(); + if (args.length > 1) { + for (int i = args.length - 1; i >= 2; i--) + ARGV.prepend(new Mal.String(args[i])); + } + env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); + + if (args.length > 1) { + var contents = new GLib.List(); + contents.prepend(new Mal.String(args[1])); + contents.prepend(new Mal.Sym("load-file")); + try { + EVAL(new Mal.List(contents), env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return 1; + } + } else { + while (!eof) { + try { + rep(env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + } + } + } + return 0; + } +} diff --git a/impls/vala/step8_macros.vala b/impls/vala/step8_macros.vala index 37aade0b01..0942680b5d 100644 --- a/impls/vala/step8_macros.vala +++ b/impls/vala/step8_macros.vala @@ -1,391 +1,391 @@ -class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { - public Mal.Env env; - public BuiltinFunctionEval(Mal.Env env_) { env = env_; } - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionEval(env); - } - public override string name() { return "eval"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return Mal.Main.EVAL(args.vs.data, env); - } -} - -class Mal.Main : GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var roota = new GC.Root(ast); (void)roota; - var roote = new GC.Root(env); (void)roote; - if (ast is Mal.Sym) - return env.get(ast as Mal.Sym); - if (ast is Mal.List) { - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - foreach (var elt in (ast as Mal.List).vs) - result.vs.append(EVAL(elt, env)); - return result; - } - if (ast is Mal.Vector) { - var vec = ast as Mal.Vector; - var result = new Mal.Vector.with_size(vec.length); - var root = new GC.Root(result); (void)root; - for (var i = 0; i < vec.length; i++) - result[i] = EVAL(vec[i], env); - return result; - } - if (ast is Mal.Hashmap) { - var result = new Mal.Hashmap(); - var root = new GC.Root(result); (void)root; - var map = (ast as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) - result.insert(key, EVAL(map[key], env)); - return result; - } - return ast; - } - - private static Mal.Val define_eval(Mal.Val key, Mal.Val value, - Mal.Env env, - bool is_macro = false) - throws Mal.Error { - var rootk = new GC.Root(key); (void)rootk; - var roote = new GC.Root(env); (void)roote; - var symkey = key as Mal.Sym; - if (symkey == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected a symbol to define"); - var val = EVAL(value, env); - if (val is Mal.Function) - (val as Mal.Function).is_macro = is_macro; - env.set(symkey, val); - return val; - } - - // If ast is (sym x), return x, else return null. - public static Mal.Val? unquoted (Mal.Val ast, - string sym) - throws Mal.Error { - var list = ast as Mal.List; - if (list == null || list.vs == null) return null; - var a0 = list.vs.data as Mal.Sym; - if (a0 == null || a0.v != sym) return null; - if (list.vs.next == null || list.vs.next.next != null) - throw new Mal.Error.BAD_PARAMS(sym + ": wrong arg count"); - return list.vs.next.data; - } - - public static Mal.Val qq_loop(Mal.Val elt, - Mal.Val acc) - throws Mal.Error { - var list = new Mal.List.empty(); - var unq = unquoted(elt, "splice-unquote"); - if (unq != null) { - list.vs.append(new Mal.Sym("concat")); - list.vs.append(unq); - } else { - list.vs.append(new Mal.Sym("cons")); - list.vs.append(quasiquote (elt)); - } - list.vs.append(acc); - return list; - } - - public static Mal.Val qq_foldr(Mal.Iterator xs) - throws Mal.Error { - if (xs.empty()) { - return new Mal.List.empty(); - } else { - var elt = xs.deref(); - xs.step(); - return qq_loop(elt, qq_foldr(xs)); - } - } - - public static Mal.Val quasiquote(Mal.Val ast) - throws Mal.Error { - if (ast is Mal.List) { - var unq = unquoted(ast, "unquote"); - if (unq != null) { - return unq; - } else { - return qq_foldr((ast as Mal.List).iter()); - } - } else if (ast is Mal.Vector) { - var list = new Mal.List.empty(); - list.vs.append(new Mal.Sym("vec")); - list.vs.append(qq_foldr((ast as Mal.Vector).iter())); - return list; - } else if (ast is Mal.Sym || ast is Mal.Hashmap) { - var list = new Mal.List.empty(); - list.vs.append(new Mal.Sym("quote")); - list.vs.append(ast); - return list; - } else { - return ast; - } - } - - public static bool is_macro_call(Mal.Val v, Mal.Env env) { - var list = v as Mal.List; - if (list == null || list.vs == null || !(list.vs.data is Mal.Sym)) - return false; - try { - var fn = env.get(list.vs.data as Mal.Sym) as Mal.Function; - return (fn != null && fn.is_macro); - } catch (Mal.Error err) { - return false; - } - } - - public static Mal.Val macroexpand(Mal.Val ast_, Mal.Env env) - throws Mal.Error { - Mal.Val ast = ast_; - while (is_macro_call(ast, env)) { - var call = ast as Mal.List; - var macro = (env.get(call.vs.data as Mal.Sym) as Mal.Function); - var macroargs = new Mal.List(call.vs.copy()); - macroargs.vs.remove_link(macroargs.vs.first()); - var fnenv = new Mal.Env.funcall( - macro.env, macro.parameters, macroargs); - ast = Mal.Main.EVAL(macro.body, fnenv); - } - return ast; - } - - public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) - throws Mal.Error { - // Copy the implicitly 'unowned' function arguments into - // ordinary owned variables which increment the objects' - // reference counts. This is so that when we overwrite these - // variables within the loop (for TCO) the objects we assign - // into them don't immediately get garbage-collected. - Mal.Val ast = ast_; - Mal.Env env = env_; - var ast_root = new GC.Root(ast); (void)ast_root; - var env_root = new GC.Root(env); (void)env_root; - while (true) { - ast_root.obj = ast; - env_root.obj = env; - GC.Core.maybe_collect(); - ast = macroexpand(ast, env); - ast_root.obj = ast; - if (ast is Mal.List) { - unowned GLib.List list = (ast as Mal.List).vs; - if (list.first() == null) - return ast; - - var first = list.first().data; - if (first is Mal.Sym) { - var sym = first as Mal.Sym; - switch (sym.v) { - case "def!": - case "defmacro!": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "def!: expected two values"); - return define_eval(list.next.data, list.next.next.data, - env, sym.v == "defmacro!"); - case "let*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "let*: expected two values"); - var defns = list.nth(1).data; - env = new Mal.Env.within(env); - - if (defns is Mal.List) { - for (unowned GLib.List iter = - (defns as Mal.List).vs; - iter != null; iter = iter.next.next) { - if (iter.next == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length list" + - " of definitions"); - define_eval(iter.data, iter.next.data, env); - } - } else if (defns is Mal.Vector) { - var vec = defns as Mal.Vector; - if (vec.length % 2 != 0) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length vector" + - " of definitions"); - for (var i = 0; i < vec.length; i += 2) - define_eval(vec[i], vec[i+1], env); - } else { - throw new Mal.Error.BAD_PARAMS( - "let*: expected a list or vector of definitions"); - } - ast = list.nth(2).data; - continue; // tail-call optimisation - case "do": - Mal.Val result = null; - for (list = list.next; list != null; list = list.next) - result = EVAL(list.data, env); - if (result == null) - throw new Mal.Error.BAD_PARAMS( - "do: expected at least one argument"); - return result; - case "if": - if (list.length() != 3 && list.length() != 4) - throw new Mal.Error.BAD_PARAMS( - "if: expected two or three arguments"); - list = list.next; - var cond = EVAL(list.data, env); - list = list.next; - if (!cond.truth_value()) { - // Skip to the else clause, which defaults to nil. - list = list.next; - if (list == null) - return new Mal.Nil(); - } - ast = list.data; - continue; // tail-call optimisation - case "fn*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected two arguments"); - var binds = list.next.data as Mal.Listlike; - var body = list.next.next.data; - if (binds == null) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected a list of parameter names"); - for (var iter = binds.iter(); iter.nonempty(); - iter.step()) - if (!(iter.deref() is Mal.Sym)) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected parameter name to be "+ - "symbol"); - return new Mal.Function(binds, body, env); - case "quote": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quote: expected one argument"); - return list.next.data; - case "quasiquoteexpand": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quasiquoteexpand: expected one argument"); - return quasiquote(list.next.data); - case "quasiquote": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quasiquote: expected one argument"); - ast = quasiquote(list.next.data); - continue; // tail-call optimisation - case "macroexpand": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "macroexpand: expected one argument"); - return macroexpand(list.next.data, env); - } - } - - var newlist = eval_ast(ast, env) as Mal.List; - unowned GLib.List firstlink = newlist.vs.first(); - Mal.Val firstdata = firstlink.data; - newlist.vs.remove_link(firstlink); - - if (firstdata is Mal.BuiltinFunction) { - return (firstdata as Mal.BuiltinFunction).call(newlist); - } else if (firstdata is Mal.Function) { - var fn = firstdata as Mal.Function; - env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); - ast = fn.body; - continue; // tail-call optimisation - } else { - throw new Mal.Error.CANNOT_APPLY( - "bad value at start of list"); - } - } else { - return eval_ast(ast, env); - } - } - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep(Mal.Env env) throws Mal.Error { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val, env); - PRINT(val); - } - } - - public static void setup(string line, Mal.Env env) { - try { - EVAL(Reader.read_str(line), env); - } catch (Mal.Error err) { - assert(false); // shouldn't happen - } - } - - public static int main(string[] args) { - var env = new Mal.Env(); - var root = new GC.Root(env); (void)root; - - Mal.Core.make_ns(); - foreach (var key in Mal.Core.ns.get_keys()) - env.set(new Mal.Sym(key), Mal.Core.ns[key]); - env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); - - setup("(def! not (fn* (a) (if a false true)))", env); - setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); - setup("(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)))))))", env); - - var ARGV = new GLib.List(); - if (args.length > 1) { - for (int i = args.length - 1; i >= 2; i--) - ARGV.prepend(new Mal.String(args[i])); - } - env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); - - if (args.length > 1) { - var contents = new GLib.List(); - contents.prepend(new Mal.String(args[1])); - contents.prepend(new Mal.Sym("load-file")); - try { - EVAL(new Mal.List(contents), env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return 1; - } - } else { - while (!eof) { - try { - rep(env); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - } - } - } - return 0; - } -} +class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { + public Mal.Env env; + public BuiltinFunctionEval(Mal.Env env_) { env = env_; } + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionEval(env); + } + public override string name() { return "eval"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return Mal.Main.EVAL(args.vs.data, env); + } +} + +class Mal.Main : GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var roota = new GC.Root(ast); (void)roota; + var roote = new GC.Root(env); (void)roote; + if (ast is Mal.Sym) + return env.get(ast as Mal.Sym); + if (ast is Mal.List) { + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + foreach (var elt in (ast as Mal.List).vs) + result.vs.append(EVAL(elt, env)); + return result; + } + if (ast is Mal.Vector) { + var vec = ast as Mal.Vector; + var result = new Mal.Vector.with_size(vec.length); + var root = new GC.Root(result); (void)root; + for (var i = 0; i < vec.length; i++) + result[i] = EVAL(vec[i], env); + return result; + } + if (ast is Mal.Hashmap) { + var result = new Mal.Hashmap(); + var root = new GC.Root(result); (void)root; + var map = (ast as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) + result.insert(key, EVAL(map[key], env)); + return result; + } + return ast; + } + + private static Mal.Val define_eval(Mal.Val key, Mal.Val value, + Mal.Env env, + bool is_macro = false) + throws Mal.Error { + var rootk = new GC.Root(key); (void)rootk; + var roote = new GC.Root(env); (void)roote; + var symkey = key as Mal.Sym; + if (symkey == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected a symbol to define"); + var val = EVAL(value, env); + if (val is Mal.Function) + (val as Mal.Function).is_macro = is_macro; + env.set(symkey, val); + return val; + } + + // If ast is (sym x), return x, else return null. + public static Mal.Val? unquoted (Mal.Val ast, + string sym) + throws Mal.Error { + var list = ast as Mal.List; + if (list == null || list.vs == null) return null; + var a0 = list.vs.data as Mal.Sym; + if (a0 == null || a0.v != sym) return null; + if (list.vs.next == null || list.vs.next.next != null) + throw new Mal.Error.BAD_PARAMS(sym + ": wrong arg count"); + return list.vs.next.data; + } + + public static Mal.Val qq_loop(Mal.Val elt, + Mal.Val acc) + throws Mal.Error { + var list = new Mal.List.empty(); + var unq = unquoted(elt, "splice-unquote"); + if (unq != null) { + list.vs.append(new Mal.Sym("concat")); + list.vs.append(unq); + } else { + list.vs.append(new Mal.Sym("cons")); + list.vs.append(quasiquote (elt)); + } + list.vs.append(acc); + return list; + } + + public static Mal.Val qq_foldr(Mal.Iterator xs) + throws Mal.Error { + if (xs.empty()) { + return new Mal.List.empty(); + } else { + var elt = xs.deref(); + xs.step(); + return qq_loop(elt, qq_foldr(xs)); + } + } + + public static Mal.Val quasiquote(Mal.Val ast) + throws Mal.Error { + if (ast is Mal.List) { + var unq = unquoted(ast, "unquote"); + if (unq != null) { + return unq; + } else { + return qq_foldr((ast as Mal.List).iter()); + } + } else if (ast is Mal.Vector) { + var list = new Mal.List.empty(); + list.vs.append(new Mal.Sym("vec")); + list.vs.append(qq_foldr((ast as Mal.Vector).iter())); + return list; + } else if (ast is Mal.Sym || ast is Mal.Hashmap) { + var list = new Mal.List.empty(); + list.vs.append(new Mal.Sym("quote")); + list.vs.append(ast); + return list; + } else { + return ast; + } + } + + public static bool is_macro_call(Mal.Val v, Mal.Env env) { + var list = v as Mal.List; + if (list == null || list.vs == null || !(list.vs.data is Mal.Sym)) + return false; + try { + var fn = env.get(list.vs.data as Mal.Sym) as Mal.Function; + return (fn != null && fn.is_macro); + } catch (Mal.Error err) { + return false; + } + } + + public static Mal.Val macroexpand(Mal.Val ast_, Mal.Env env) + throws Mal.Error { + Mal.Val ast = ast_; + while (is_macro_call(ast, env)) { + var call = ast as Mal.List; + var macro = (env.get(call.vs.data as Mal.Sym) as Mal.Function); + var macroargs = new Mal.List(call.vs.copy()); + macroargs.vs.remove_link(macroargs.vs.first()); + var fnenv = new Mal.Env.funcall( + macro.env, macro.parameters, macroargs); + ast = Mal.Main.EVAL(macro.body, fnenv); + } + return ast; + } + + public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) + throws Mal.Error { + // Copy the implicitly 'unowned' function arguments into + // ordinary owned variables which increment the objects' + // reference counts. This is so that when we overwrite these + // variables within the loop (for TCO) the objects we assign + // into them don't immediately get garbage-collected. + Mal.Val ast = ast_; + Mal.Env env = env_; + var ast_root = new GC.Root(ast); (void)ast_root; + var env_root = new GC.Root(env); (void)env_root; + while (true) { + ast_root.obj = ast; + env_root.obj = env; + GC.Core.maybe_collect(); + ast = macroexpand(ast, env); + ast_root.obj = ast; + if (ast is Mal.List) { + unowned GLib.List list = (ast as Mal.List).vs; + if (list.first() == null) + return ast; + + var first = list.first().data; + if (first is Mal.Sym) { + var sym = first as Mal.Sym; + switch (sym.v) { + case "def!": + case "defmacro!": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "def!: expected two values"); + return define_eval(list.next.data, list.next.next.data, + env, sym.v == "defmacro!"); + case "let*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "let*: expected two values"); + var defns = list.nth(1).data; + env = new Mal.Env.within(env); + + if (defns is Mal.List) { + for (unowned GLib.List iter = + (defns as Mal.List).vs; + iter != null; iter = iter.next.next) { + if (iter.next == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length list" + + " of definitions"); + define_eval(iter.data, iter.next.data, env); + } + } else if (defns is Mal.Vector) { + var vec = defns as Mal.Vector; + if (vec.length % 2 != 0) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length vector" + + " of definitions"); + for (var i = 0; i < vec.length; i += 2) + define_eval(vec[i], vec[i+1], env); + } else { + throw new Mal.Error.BAD_PARAMS( + "let*: expected a list or vector of definitions"); + } + ast = list.nth(2).data; + continue; // tail-call optimisation + case "do": + Mal.Val result = null; + for (list = list.next; list != null; list = list.next) + result = EVAL(list.data, env); + if (result == null) + throw new Mal.Error.BAD_PARAMS( + "do: expected at least one argument"); + return result; + case "if": + if (list.length() != 3 && list.length() != 4) + throw new Mal.Error.BAD_PARAMS( + "if: expected two or three arguments"); + list = list.next; + var cond = EVAL(list.data, env); + list = list.next; + if (!cond.truth_value()) { + // Skip to the else clause, which defaults to nil. + list = list.next; + if (list == null) + return new Mal.Nil(); + } + ast = list.data; + continue; // tail-call optimisation + case "fn*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected two arguments"); + var binds = list.next.data as Mal.Listlike; + var body = list.next.next.data; + if (binds == null) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected a list of parameter names"); + for (var iter = binds.iter(); iter.nonempty(); + iter.step()) + if (!(iter.deref() is Mal.Sym)) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected parameter name to be "+ + "symbol"); + return new Mal.Function(binds, body, env); + case "quote": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quote: expected one argument"); + return list.next.data; + case "quasiquoteexpand": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quasiquoteexpand: expected one argument"); + return quasiquote(list.next.data); + case "quasiquote": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quasiquote: expected one argument"); + ast = quasiquote(list.next.data); + continue; // tail-call optimisation + case "macroexpand": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "macroexpand: expected one argument"); + return macroexpand(list.next.data, env); + } + } + + var newlist = eval_ast(ast, env) as Mal.List; + unowned GLib.List firstlink = newlist.vs.first(); + Mal.Val firstdata = firstlink.data; + newlist.vs.remove_link(firstlink); + + if (firstdata is Mal.BuiltinFunction) { + return (firstdata as Mal.BuiltinFunction).call(newlist); + } else if (firstdata is Mal.Function) { + var fn = firstdata as Mal.Function; + env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); + ast = fn.body; + continue; // tail-call optimisation + } else { + throw new Mal.Error.CANNOT_APPLY( + "bad value at start of list"); + } + } else { + return eval_ast(ast, env); + } + } + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep(Mal.Env env) throws Mal.Error { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val, env); + PRINT(val); + } + } + + public static void setup(string line, Mal.Env env) { + try { + EVAL(Reader.read_str(line), env); + } catch (Mal.Error err) { + assert(false); // shouldn't happen + } + } + + public static int main(string[] args) { + var env = new Mal.Env(); + var root = new GC.Root(env); (void)root; + + Mal.Core.make_ns(); + foreach (var key in Mal.Core.ns.get_keys()) + env.set(new Mal.Sym(key), Mal.Core.ns[key]); + env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); + + setup("(def! not (fn* (a) (if a false true)))", env); + setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); + setup("(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)))))))", env); + + var ARGV = new GLib.List(); + if (args.length > 1) { + for (int i = args.length - 1; i >= 2; i--) + ARGV.prepend(new Mal.String(args[i])); + } + env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); + + if (args.length > 1) { + var contents = new GLib.List(); + contents.prepend(new Mal.String(args[1])); + contents.prepend(new Mal.Sym("load-file")); + try { + EVAL(new Mal.List(contents), env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return 1; + } + } else { + while (!eof) { + try { + rep(env); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + } + } + } + return 0; + } +} diff --git a/impls/vala/step9_try.vala b/impls/vala/step9_try.vala index 97b09a1162..0f517d0697 100644 --- a/impls/vala/step9_try.vala +++ b/impls/vala/step9_try.vala @@ -1,437 +1,437 @@ -class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { - public Mal.Env env; - public BuiltinFunctionEval(Mal.Env env_) { env = env_; } - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionEval(env); - } - public override string name() { return "eval"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return Mal.Main.EVAL(args.vs.data, env); - } -} - -class Mal.Main : GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - Mal.BuiltinFunctionThrow.clear(); - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var roota = new GC.Root(ast); (void)roota; - var roote = new GC.Root(env); (void)roote; - if (ast is Mal.Sym) - return env.get(ast as Mal.Sym); - if (ast is Mal.List) { - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - foreach (var elt in (ast as Mal.List).vs) - result.vs.append(EVAL(elt, env)); - return result; - } - if (ast is Mal.Vector) { - var vec = ast as Mal.Vector; - var result = new Mal.Vector.with_size(vec.length); - var root = new GC.Root(result); (void)root; - for (var i = 0; i < vec.length; i++) - result[i] = EVAL(vec[i], env); - return result; - } - if (ast is Mal.Hashmap) { - var result = new Mal.Hashmap(); - var root = new GC.Root(result); (void)root; - var map = (ast as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) - result.insert(key, EVAL(map[key], env)); - return result; - } - return ast; - } - - private static Mal.Val define_eval(Mal.Val key, Mal.Val value, - Mal.Env env, - bool is_macro = false) - throws Mal.Error { - var rootk = new GC.Root(key); (void)rootk; - var roote = new GC.Root(env); (void)roote; - var symkey = key as Mal.Sym; - if (symkey == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected a symbol to define"); - var val = EVAL(value, env); - if (val is Mal.Function) - (val as Mal.Function).is_macro = is_macro; - env.set(symkey, val); - return val; - } - - // If ast is (sym x), return x, else return null. - public static Mal.Val? unquoted (Mal.Val ast, - string sym) - throws Mal.Error { - var list = ast as Mal.List; - if (list == null || list.vs == null) return null; - var a0 = list.vs.data as Mal.Sym; - if (a0 == null || a0.v != sym) return null; - if (list.vs.next == null || list.vs.next.next != null) - throw new Mal.Error.BAD_PARAMS(sym + ": wrong arg count"); - return list.vs.next.data; - } - - public static Mal.Val qq_loop(Mal.Val elt, - Mal.Val acc) - throws Mal.Error { - var list = new Mal.List.empty(); - var unq = unquoted(elt, "splice-unquote"); - if (unq != null) { - list.vs.append(new Mal.Sym("concat")); - list.vs.append(unq); - } else { - list.vs.append(new Mal.Sym("cons")); - list.vs.append(quasiquote (elt)); - } - list.vs.append(acc); - return list; - } - - public static Mal.Val qq_foldr(Mal.Iterator xs) - throws Mal.Error { - if (xs.empty()) { - return new Mal.List.empty(); - } else { - var elt = xs.deref(); - xs.step(); - return qq_loop(elt, qq_foldr(xs)); - } - } - - public static Mal.Val quasiquote(Mal.Val ast) - throws Mal.Error { - if (ast is Mal.List) { - var unq = unquoted(ast, "unquote"); - if (unq != null) { - return unq; - } else { - return qq_foldr((ast as Mal.List).iter()); - } - } else if (ast is Mal.Vector) { - var list = new Mal.List.empty(); - list.vs.append(new Mal.Sym("vec")); - list.vs.append(qq_foldr((ast as Mal.Vector).iter())); - return list; - } else if (ast is Mal.Sym || ast is Mal.Hashmap) { - var list = new Mal.List.empty(); - list.vs.append(new Mal.Sym("quote")); - list.vs.append(ast); - return list; - } else { - return ast; - } - } - - public static bool is_macro_call(Mal.Val v, Mal.Env env) - throws Mal.Error { - var list = v as Mal.List; - if (list == null || list.vs == null || !(list.vs.data is Mal.Sym)) - return false; - try { - var fn = env.get(list.vs.data as Mal.Sym) as Mal.Function; - return (fn != null && fn.is_macro); - } catch (Mal.Error.ENV_LOOKUP_FAILED err) { - return false; - } - } - - public static Mal.Val macroexpand(Mal.Val ast_, Mal.Env env) - throws Mal.Error { - // Copy the parameter into an owned variable (see comment in EVAL). - Mal.Val ast = ast_; - while (is_macro_call(ast, env)) { - var call = ast as Mal.List; - var macro = (env.get(call.vs.data as Mal.Sym) as Mal.Function); - var macroargs = new Mal.List(call.vs.copy()); - macroargs.vs.remove_link(macroargs.vs.first()); - var fnenv = new Mal.Env.funcall( - macro.env, macro.parameters, macroargs); - ast = Mal.Main.EVAL(macro.body, fnenv); - } - return ast; - } - - public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) - throws Mal.Error { - // Copy the implicitly 'unowned' function arguments into - // ordinary owned variables which increment the objects' - // reference counts. This is so that when we overwrite these - // variables within the loop (for TCO) the objects we assign - // into them don't immediately get garbage-collected. - Mal.Val ast = ast_; - Mal.Env env = env_; - var ast_root = new GC.Root(ast); (void)ast_root; - var env_root = new GC.Root(env); (void)env_root; - while (true) { - ast_root.obj = ast; - env_root.obj = env; - GC.Core.maybe_collect(); - ast = macroexpand(ast, env); - ast_root.obj = ast; - if (ast is Mal.List) { - unowned GLib.List list = (ast as Mal.List).vs; - if (list.first() == null) - return ast; - - var first = list.first().data; - if (first is Mal.Sym) { - var sym = first as Mal.Sym; - switch (sym.v) { - case "def!": - case "defmacro!": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "def!: expected two values"); - return define_eval(list.next.data, list.next.next.data, - env, sym.v == "defmacro!"); - case "let*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "let*: expected two values"); - var defns = list.nth(1).data; - env = new Mal.Env.within(env); - - if (defns is Mal.List) { - for (unowned GLib.List iter = - (defns as Mal.List).vs; - iter != null; iter = iter.next.next) { - if (iter.next == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length list" + - " of definitions"); - define_eval(iter.data, iter.next.data, env); - } - } else if (defns is Mal.Vector) { - var vec = defns as Mal.Vector; - if (vec.length % 2 != 0) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length vector" + - " of definitions"); - for (var i = 0; i < vec.length; i += 2) - define_eval(vec[i], vec[i+1], env); - } else { - throw new Mal.Error.BAD_PARAMS( - "let*: expected a list or vector of definitions"); - } - ast = list.nth(2).data; - continue; // tail-call optimisation - case "do": - Mal.Val result = null; - for (list = list.next; list != null; list = list.next) - result = EVAL(list.data, env); - if (result == null) - throw new Mal.Error.BAD_PARAMS( - "do: expected at least one argument"); - return result; - case "if": - if (list.length() != 3 && list.length() != 4) - throw new Mal.Error.BAD_PARAMS( - "if: expected two or three arguments"); - list = list.next; - var cond = EVAL(list.data, env); - list = list.next; - if (!cond.truth_value()) { - // Skip to the else clause, which defaults to nil. - list = list.next; - if (list == null) - return new Mal.Nil(); - } - ast = list.data; - continue; // tail-call optimisation - case "fn*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected two arguments"); - var binds = list.next.data as Mal.Listlike; - var body = list.next.next.data; - if (binds == null) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected a list of parameter names"); - for (var iter = binds.iter(); iter.nonempty(); - iter.step()) - if (!(iter.deref() is Mal.Sym)) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected parameter name to be "+ - "symbol"); - return new Mal.Function(binds, body, env); - case "quote": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quote: expected one argument"); - return list.next.data; - case "quasiquoteexpand": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quasiquoteexpand: expected one argument"); - return quasiquote(list.next.data); - case "quasiquote": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quasiquote: expected one argument"); - ast = quasiquote(list.next.data); - continue; // tail-call optimisation - case "macroexpand": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "macroexpand: expected one argument"); - return macroexpand(list.next.data, env); - case "try*": - if (list.length() != 2 && list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "try*: expected one or two arguments"); - var trybody = list.next.data; - if (list.length() == 2) { - // Trivial catchless form of try - ast = trybody; - continue; // tail-call optimisation - } - var catchclause = list.next.next.data as Mal.List; - if (!(catchclause.vs.data is Mal.Sym) || - (catchclause.vs.data as Mal.Sym).v != "catch*") - throw new Mal.Error.BAD_PARAMS( - "try*: expected catch*"); - if (catchclause.vs.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "catch*: expected two arguments"); - var catchparam = catchclause.vs.next.data as Mal.Sym; - if (catchparam == null) - throw new Mal.Error.BAD_PARAMS( - "catch*: expected a parameter name"); - var catchbody = catchclause.vs.next.next.data; - try { - return EVAL(trybody, env); - } catch (Mal.Error exc) { - var catchenv = new Mal.Env.within(env); - catchenv.set(catchparam, Mal.BuiltinFunctionThrow. - thrown_value(exc)); - ast = catchbody; - env = catchenv; - continue; // tail-call optimisation - } - } - } - - var newlist = eval_ast(ast, env) as Mal.List; - unowned GLib.List firstlink = newlist.vs.first(); - Mal.Val firstdata = firstlink.data; - newlist.vs.remove_link(firstlink); - - if (firstdata is Mal.BuiltinFunction) { - return (firstdata as Mal.BuiltinFunction).call(newlist); - } else if (firstdata is Mal.Function) { - var fn = firstdata as Mal.Function; - env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); - ast = fn.body; - continue; // tail-call optimisation - } else { - throw new Mal.Error.CANNOT_APPLY( - "bad value at start of list"); - } - } else { - return eval_ast(ast, env); - } - } - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep(Mal.Env env) throws Mal.Error { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val, env); - PRINT(val); - } - } - - public static void setup(string line, Mal.Env env) { - try { - EVAL(Reader.read_str(line), env); - } catch (Mal.Error err) { - stderr.printf("Error during setup:\n%s\n-> %s\n", - line, err.message); - GLib.Process.exit(1); - } - } - - public static int main(string[] args) { - var env = new Mal.Env(); - var root = new GC.Root(env); (void)root; - - Mal.Core.make_ns(); - foreach (var key in Mal.Core.ns.get_keys()) - env.set(new Mal.Sym(key), Mal.Core.ns[key]); - env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); - - setup("(def! not (fn* (a) (if a false true)))", env); - setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); - setup("(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)))))))", env); - - var ARGV = new GLib.List(); - if (args.length > 1) { - for (int i = args.length - 1; i >= 2; i--) - ARGV.prepend(new Mal.String(args[i])); - } - env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); - - if (args.length > 1) { - var contents = new GLib.List(); - contents.prepend(new Mal.String(args[1])); - contents.prepend(new Mal.Sym("load-file")); - try { - EVAL(new Mal.List(contents), env); - } catch (Mal.Error.EXCEPTION_THROWN exc) { - GLib.stderr.printf( - "uncaught exception: %s\n", - pr_str(Mal.BuiltinFunctionThrow.thrown_value(exc))); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return 1; - } - } else { - while (!eof) { - try { - rep(env); - } catch (Mal.Error.EXCEPTION_THROWN exc) { - GLib.stderr.printf( - "uncaught exception: %s\n", - pr_str(Mal.BuiltinFunctionThrow.thrown_value(exc))); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - } - } - } - return 0; - } -} +class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { + public Mal.Env env; + public BuiltinFunctionEval(Mal.Env env_) { env = env_; } + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionEval(env); + } + public override string name() { return "eval"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return Mal.Main.EVAL(args.vs.data, env); + } +} + +class Mal.Main : GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + Mal.BuiltinFunctionThrow.clear(); + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var roota = new GC.Root(ast); (void)roota; + var roote = new GC.Root(env); (void)roote; + if (ast is Mal.Sym) + return env.get(ast as Mal.Sym); + if (ast is Mal.List) { + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + foreach (var elt in (ast as Mal.List).vs) + result.vs.append(EVAL(elt, env)); + return result; + } + if (ast is Mal.Vector) { + var vec = ast as Mal.Vector; + var result = new Mal.Vector.with_size(vec.length); + var root = new GC.Root(result); (void)root; + for (var i = 0; i < vec.length; i++) + result[i] = EVAL(vec[i], env); + return result; + } + if (ast is Mal.Hashmap) { + var result = new Mal.Hashmap(); + var root = new GC.Root(result); (void)root; + var map = (ast as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) + result.insert(key, EVAL(map[key], env)); + return result; + } + return ast; + } + + private static Mal.Val define_eval(Mal.Val key, Mal.Val value, + Mal.Env env, + bool is_macro = false) + throws Mal.Error { + var rootk = new GC.Root(key); (void)rootk; + var roote = new GC.Root(env); (void)roote; + var symkey = key as Mal.Sym; + if (symkey == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected a symbol to define"); + var val = EVAL(value, env); + if (val is Mal.Function) + (val as Mal.Function).is_macro = is_macro; + env.set(symkey, val); + return val; + } + + // If ast is (sym x), return x, else return null. + public static Mal.Val? unquoted (Mal.Val ast, + string sym) + throws Mal.Error { + var list = ast as Mal.List; + if (list == null || list.vs == null) return null; + var a0 = list.vs.data as Mal.Sym; + if (a0 == null || a0.v != sym) return null; + if (list.vs.next == null || list.vs.next.next != null) + throw new Mal.Error.BAD_PARAMS(sym + ": wrong arg count"); + return list.vs.next.data; + } + + public static Mal.Val qq_loop(Mal.Val elt, + Mal.Val acc) + throws Mal.Error { + var list = new Mal.List.empty(); + var unq = unquoted(elt, "splice-unquote"); + if (unq != null) { + list.vs.append(new Mal.Sym("concat")); + list.vs.append(unq); + } else { + list.vs.append(new Mal.Sym("cons")); + list.vs.append(quasiquote (elt)); + } + list.vs.append(acc); + return list; + } + + public static Mal.Val qq_foldr(Mal.Iterator xs) + throws Mal.Error { + if (xs.empty()) { + return new Mal.List.empty(); + } else { + var elt = xs.deref(); + xs.step(); + return qq_loop(elt, qq_foldr(xs)); + } + } + + public static Mal.Val quasiquote(Mal.Val ast) + throws Mal.Error { + if (ast is Mal.List) { + var unq = unquoted(ast, "unquote"); + if (unq != null) { + return unq; + } else { + return qq_foldr((ast as Mal.List).iter()); + } + } else if (ast is Mal.Vector) { + var list = new Mal.List.empty(); + list.vs.append(new Mal.Sym("vec")); + list.vs.append(qq_foldr((ast as Mal.Vector).iter())); + return list; + } else if (ast is Mal.Sym || ast is Mal.Hashmap) { + var list = new Mal.List.empty(); + list.vs.append(new Mal.Sym("quote")); + list.vs.append(ast); + return list; + } else { + return ast; + } + } + + public static bool is_macro_call(Mal.Val v, Mal.Env env) + throws Mal.Error { + var list = v as Mal.List; + if (list == null || list.vs == null || !(list.vs.data is Mal.Sym)) + return false; + try { + var fn = env.get(list.vs.data as Mal.Sym) as Mal.Function; + return (fn != null && fn.is_macro); + } catch (Mal.Error.ENV_LOOKUP_FAILED err) { + return false; + } + } + + public static Mal.Val macroexpand(Mal.Val ast_, Mal.Env env) + throws Mal.Error { + // Copy the parameter into an owned variable (see comment in EVAL). + Mal.Val ast = ast_; + while (is_macro_call(ast, env)) { + var call = ast as Mal.List; + var macro = (env.get(call.vs.data as Mal.Sym) as Mal.Function); + var macroargs = new Mal.List(call.vs.copy()); + macroargs.vs.remove_link(macroargs.vs.first()); + var fnenv = new Mal.Env.funcall( + macro.env, macro.parameters, macroargs); + ast = Mal.Main.EVAL(macro.body, fnenv); + } + return ast; + } + + public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) + throws Mal.Error { + // Copy the implicitly 'unowned' function arguments into + // ordinary owned variables which increment the objects' + // reference counts. This is so that when we overwrite these + // variables within the loop (for TCO) the objects we assign + // into them don't immediately get garbage-collected. + Mal.Val ast = ast_; + Mal.Env env = env_; + var ast_root = new GC.Root(ast); (void)ast_root; + var env_root = new GC.Root(env); (void)env_root; + while (true) { + ast_root.obj = ast; + env_root.obj = env; + GC.Core.maybe_collect(); + ast = macroexpand(ast, env); + ast_root.obj = ast; + if (ast is Mal.List) { + unowned GLib.List list = (ast as Mal.List).vs; + if (list.first() == null) + return ast; + + var first = list.first().data; + if (first is Mal.Sym) { + var sym = first as Mal.Sym; + switch (sym.v) { + case "def!": + case "defmacro!": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "def!: expected two values"); + return define_eval(list.next.data, list.next.next.data, + env, sym.v == "defmacro!"); + case "let*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "let*: expected two values"); + var defns = list.nth(1).data; + env = new Mal.Env.within(env); + + if (defns is Mal.List) { + for (unowned GLib.List iter = + (defns as Mal.List).vs; + iter != null; iter = iter.next.next) { + if (iter.next == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length list" + + " of definitions"); + define_eval(iter.data, iter.next.data, env); + } + } else if (defns is Mal.Vector) { + var vec = defns as Mal.Vector; + if (vec.length % 2 != 0) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length vector" + + " of definitions"); + for (var i = 0; i < vec.length; i += 2) + define_eval(vec[i], vec[i+1], env); + } else { + throw new Mal.Error.BAD_PARAMS( + "let*: expected a list or vector of definitions"); + } + ast = list.nth(2).data; + continue; // tail-call optimisation + case "do": + Mal.Val result = null; + for (list = list.next; list != null; list = list.next) + result = EVAL(list.data, env); + if (result == null) + throw new Mal.Error.BAD_PARAMS( + "do: expected at least one argument"); + return result; + case "if": + if (list.length() != 3 && list.length() != 4) + throw new Mal.Error.BAD_PARAMS( + "if: expected two or three arguments"); + list = list.next; + var cond = EVAL(list.data, env); + list = list.next; + if (!cond.truth_value()) { + // Skip to the else clause, which defaults to nil. + list = list.next; + if (list == null) + return new Mal.Nil(); + } + ast = list.data; + continue; // tail-call optimisation + case "fn*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected two arguments"); + var binds = list.next.data as Mal.Listlike; + var body = list.next.next.data; + if (binds == null) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected a list of parameter names"); + for (var iter = binds.iter(); iter.nonempty(); + iter.step()) + if (!(iter.deref() is Mal.Sym)) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected parameter name to be "+ + "symbol"); + return new Mal.Function(binds, body, env); + case "quote": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quote: expected one argument"); + return list.next.data; + case "quasiquoteexpand": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quasiquoteexpand: expected one argument"); + return quasiquote(list.next.data); + case "quasiquote": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quasiquote: expected one argument"); + ast = quasiquote(list.next.data); + continue; // tail-call optimisation + case "macroexpand": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "macroexpand: expected one argument"); + return macroexpand(list.next.data, env); + case "try*": + if (list.length() != 2 && list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "try*: expected one or two arguments"); + var trybody = list.next.data; + if (list.length() == 2) { + // Trivial catchless form of try + ast = trybody; + continue; // tail-call optimisation + } + var catchclause = list.next.next.data as Mal.List; + if (!(catchclause.vs.data is Mal.Sym) || + (catchclause.vs.data as Mal.Sym).v != "catch*") + throw new Mal.Error.BAD_PARAMS( + "try*: expected catch*"); + if (catchclause.vs.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "catch*: expected two arguments"); + var catchparam = catchclause.vs.next.data as Mal.Sym; + if (catchparam == null) + throw new Mal.Error.BAD_PARAMS( + "catch*: expected a parameter name"); + var catchbody = catchclause.vs.next.next.data; + try { + return EVAL(trybody, env); + } catch (Mal.Error exc) { + var catchenv = new Mal.Env.within(env); + catchenv.set(catchparam, Mal.BuiltinFunctionThrow. + thrown_value(exc)); + ast = catchbody; + env = catchenv; + continue; // tail-call optimisation + } + } + } + + var newlist = eval_ast(ast, env) as Mal.List; + unowned GLib.List firstlink = newlist.vs.first(); + Mal.Val firstdata = firstlink.data; + newlist.vs.remove_link(firstlink); + + if (firstdata is Mal.BuiltinFunction) { + return (firstdata as Mal.BuiltinFunction).call(newlist); + } else if (firstdata is Mal.Function) { + var fn = firstdata as Mal.Function; + env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); + ast = fn.body; + continue; // tail-call optimisation + } else { + throw new Mal.Error.CANNOT_APPLY( + "bad value at start of list"); + } + } else { + return eval_ast(ast, env); + } + } + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep(Mal.Env env) throws Mal.Error { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val, env); + PRINT(val); + } + } + + public static void setup(string line, Mal.Env env) { + try { + EVAL(Reader.read_str(line), env); + } catch (Mal.Error err) { + stderr.printf("Error during setup:\n%s\n-> %s\n", + line, err.message); + GLib.Process.exit(1); + } + } + + public static int main(string[] args) { + var env = new Mal.Env(); + var root = new GC.Root(env); (void)root; + + Mal.Core.make_ns(); + foreach (var key in Mal.Core.ns.get_keys()) + env.set(new Mal.Sym(key), Mal.Core.ns[key]); + env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); + + setup("(def! not (fn* (a) (if a false true)))", env); + setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); + setup("(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)))))))", env); + + var ARGV = new GLib.List(); + if (args.length > 1) { + for (int i = args.length - 1; i >= 2; i--) + ARGV.prepend(new Mal.String(args[i])); + } + env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); + + if (args.length > 1) { + var contents = new GLib.List(); + contents.prepend(new Mal.String(args[1])); + contents.prepend(new Mal.Sym("load-file")); + try { + EVAL(new Mal.List(contents), env); + } catch (Mal.Error.EXCEPTION_THROWN exc) { + GLib.stderr.printf( + "uncaught exception: %s\n", + pr_str(Mal.BuiltinFunctionThrow.thrown_value(exc))); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return 1; + } + } else { + while (!eof) { + try { + rep(env); + } catch (Mal.Error.EXCEPTION_THROWN exc) { + GLib.stderr.printf( + "uncaught exception: %s\n", + pr_str(Mal.BuiltinFunctionThrow.thrown_value(exc))); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + } + } + } + return 0; + } +} diff --git a/impls/vala/stepA_mal.vala b/impls/vala/stepA_mal.vala index c5f1abab1f..7c027babb2 100644 --- a/impls/vala/stepA_mal.vala +++ b/impls/vala/stepA_mal.vala @@ -1,439 +1,439 @@ -class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { - public Mal.Env env; - public BuiltinFunctionEval(Mal.Env env_) { env = env_; } - public override Mal.ValWithMetadata copy() { - return new Mal.BuiltinFunctionEval(env); - } - public override string name() { return "eval"; } - public override Mal.Val call(Mal.List args) throws Mal.Error { - if (args.vs.length() != 1) - throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); - return Mal.Main.EVAL(args.vs.data, env); - } -} - -class Mal.Main : GLib.Object { - static bool eof; - - static construct { - eof = false; - } - - public static Mal.Val? READ() { - string? line = Readline.readline("user> "); - if (line != null) { - if (line.length > 0) - Readline.History.add(line); - - try { - return Reader.read_str(line); - } catch (Mal.Error err) { - Mal.BuiltinFunctionThrow.clear(); - GLib.stderr.printf("%s\n", err.message); - return null; - } - } else { - stdout.printf("\n"); - eof = true; - return null; - } - } - - public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) - throws Mal.Error { - var roota = new GC.Root(ast); (void)roota; - var roote = new GC.Root(env); (void)roote; - if (ast is Mal.Sym) - return env.get(ast as Mal.Sym); - if (ast is Mal.List) { - var result = new Mal.List.empty(); - var root = new GC.Root(result); (void)root; - foreach (var elt in (ast as Mal.List).vs) - result.vs.append(EVAL(elt, env)); - return result; - } - if (ast is Mal.Vector) { - var vec = ast as Mal.Vector; - var result = new Mal.Vector.with_size(vec.length); - var root = new GC.Root(result); (void)root; - for (var i = 0; i < vec.length; i++) - result[i] = EVAL(vec[i], env); - return result; - } - if (ast is Mal.Hashmap) { - var result = new Mal.Hashmap(); - var root = new GC.Root(result); (void)root; - var map = (ast as Mal.Hashmap).vs; - foreach (var key in map.get_keys()) - result.insert(key, EVAL(map[key], env)); - return result; - } - return ast; - } - - private static Mal.Val define_eval(Mal.Val key, Mal.Val value, - Mal.Env env, - bool is_macro = false) - throws Mal.Error { - var rootk = new GC.Root(key); (void)rootk; - var roote = new GC.Root(env); (void)roote; - var symkey = key as Mal.Sym; - if (symkey == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected a symbol to define"); - var val = EVAL(value, env); - if (val is Mal.Function) - (val as Mal.Function).is_macro = is_macro; - env.set(symkey, val); - return val; - } - - // If ast is (sym x), return x, else return null. - public static Mal.Val? unquoted (Mal.Val ast, - string sym) - throws Mal.Error { - var list = ast as Mal.List; - if (list == null || list.vs == null) return null; - var a0 = list.vs.data as Mal.Sym; - if (a0 == null || a0.v != sym) return null; - if (list.vs.next == null || list.vs.next.next != null) - throw new Mal.Error.BAD_PARAMS(sym + ": wrong arg count"); - return list.vs.next.data; - } - - public static Mal.Val qq_loop(Mal.Val elt, - Mal.Val acc) - throws Mal.Error { - var list = new Mal.List.empty(); - var unq = unquoted(elt, "splice-unquote"); - if (unq != null) { - list.vs.append(new Mal.Sym("concat")); - list.vs.append(unq); - } else { - list.vs.append(new Mal.Sym("cons")); - list.vs.append(quasiquote (elt)); - } - list.vs.append(acc); - return list; - } - - public static Mal.Val qq_foldr(Mal.Iterator xs) - throws Mal.Error { - if (xs.empty()) { - return new Mal.List.empty(); - } else { - var elt = xs.deref(); - xs.step(); - return qq_loop(elt, qq_foldr(xs)); - } - } - - public static Mal.Val quasiquote(Mal.Val ast) - throws Mal.Error { - if (ast is Mal.List) { - var unq = unquoted(ast, "unquote"); - if (unq != null) { - return unq; - } else { - return qq_foldr((ast as Mal.List).iter()); - } - } else if (ast is Mal.Vector) { - var list = new Mal.List.empty(); - list.vs.append(new Mal.Sym("vec")); - list.vs.append(qq_foldr((ast as Mal.Vector).iter())); - return list; - } else if (ast is Mal.Sym || ast is Mal.Hashmap) { - var list = new Mal.List.empty(); - list.vs.append(new Mal.Sym("quote")); - list.vs.append(ast); - return list; - } else { - return ast; - } - } - - public static bool is_macro_call(Mal.Val v, Mal.Env env) - throws Mal.Error { - var list = v as Mal.List; - if (list == null || list.vs == null || !(list.vs.data is Mal.Sym)) - return false; - try { - var fn = env.get(list.vs.data as Mal.Sym) as Mal.Function; - return (fn != null && fn.is_macro); - } catch (Mal.Error.ENV_LOOKUP_FAILED err) { - return false; - } - } - - public static Mal.Val macroexpand(Mal.Val ast_, Mal.Env env) - throws Mal.Error { - // Copy the parameter into an owned variable (see comment in EVAL). - Mal.Val ast = ast_; - while (is_macro_call(ast, env)) { - var call = ast as Mal.List; - var macro = (env.get(call.vs.data as Mal.Sym) as Mal.Function); - var macroargs = new Mal.List(call.vs.copy()); - macroargs.vs.remove_link(macroargs.vs.first()); - var fnenv = new Mal.Env.funcall( - macro.env, macro.parameters, macroargs); - ast = Mal.Main.EVAL(macro.body, fnenv); - } - return ast; - } - - public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) - throws Mal.Error { - // Copy the implicitly 'unowned' function arguments into - // ordinary owned variables which increment the objects' - // reference counts. This is so that when we overwrite these - // variables within the loop (for TCO) the objects we assign - // into them don't immediately get garbage-collected. - Mal.Val ast = ast_; - Mal.Env env = env_; - var ast_root = new GC.Root(ast); (void)ast_root; - var env_root = new GC.Root(env); (void)env_root; - while (true) { - ast_root.obj = ast; - env_root.obj = env; - GC.Core.maybe_collect(); - ast = macroexpand(ast, env); - ast_root.obj = ast; - if (ast is Mal.List) { - unowned GLib.List list = (ast as Mal.List).vs; - if (list.first() == null) - return ast; - - var first = list.first().data; - if (first is Mal.Sym) { - var sym = first as Mal.Sym; - switch (sym.v) { - case "def!": - case "defmacro!": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "def!: expected two values"); - return define_eval(list.next.data, list.next.next.data, - env, sym.v == "defmacro!"); - case "let*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "let*: expected two values"); - var defns = list.nth(1).data; - env = new Mal.Env.within(env); - - if (defns is Mal.List) { - for (unowned GLib.List iter = - (defns as Mal.List).vs; - iter != null; iter = iter.next.next) { - if (iter.next == null) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length list" + - " of definitions"); - define_eval(iter.data, iter.next.data, env); - } - } else if (defns is Mal.Vector) { - var vec = defns as Mal.Vector; - if (vec.length % 2 != 0) - throw new Mal.Error.BAD_PARAMS( - "let*: expected an even-length vector" + - " of definitions"); - for (var i = 0; i < vec.length; i += 2) - define_eval(vec[i], vec[i+1], env); - } else { - throw new Mal.Error.BAD_PARAMS( - "let*: expected a list or vector of definitions"); - } - ast = list.nth(2).data; - continue; // tail-call optimisation - case "do": - Mal.Val result = null; - for (list = list.next; list != null; list = list.next) - result = EVAL(list.data, env); - if (result == null) - throw new Mal.Error.BAD_PARAMS( - "do: expected at least one argument"); - return result; - case "if": - if (list.length() != 3 && list.length() != 4) - throw new Mal.Error.BAD_PARAMS( - "if: expected two or three arguments"); - list = list.next; - var cond = EVAL(list.data, env); - list = list.next; - if (!cond.truth_value()) { - // Skip to the else clause, which defaults to nil. - list = list.next; - if (list == null) - return new Mal.Nil(); - } - ast = list.data; - continue; // tail-call optimisation - case "fn*": - if (list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected two arguments"); - var binds = list.next.data as Mal.Listlike; - var body = list.next.next.data; - if (binds == null) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected a list of parameter names"); - for (var iter = binds.iter(); iter.nonempty(); - iter.step()) - if (!(iter.deref() is Mal.Sym)) - throw new Mal.Error.BAD_PARAMS( - "fn*: expected parameter name to be "+ - "symbol"); - return new Mal.Function(binds, body, env); - case "quote": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quote: expected one argument"); - return list.next.data; - case "quasiquoteexpand": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quasiquoteexpand: expected one argument"); - return quasiquote(list.next.data); - case "quasiquote": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "quasiquote: expected one argument"); - ast = quasiquote(list.next.data); - continue; // tail-call optimisation - case "macroexpand": - if (list.length() != 2) - throw new Mal.Error.BAD_PARAMS( - "macroexpand: expected one argument"); - return macroexpand(list.next.data, env); - case "try*": - if (list.length() != 2 && list.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "try*: expected one or two arguments"); - var trybody = list.next.data; - if (list.length() == 2) { - // Trivial catchless form of try - ast = trybody; - continue; // tail-call optimisation - } - var catchclause = list.next.next.data as Mal.List; - if (!(catchclause.vs.data is Mal.Sym) || - (catchclause.vs.data as Mal.Sym).v != "catch*") - throw new Mal.Error.BAD_PARAMS( - "try*: expected catch*"); - if (catchclause.vs.length() != 3) - throw new Mal.Error.BAD_PARAMS( - "catch*: expected two arguments"); - var catchparam = catchclause.vs.next.data as Mal.Sym; - if (catchparam == null) - throw new Mal.Error.BAD_PARAMS( - "catch*: expected a parameter name"); - var catchbody = catchclause.vs.next.next.data; - try { - return EVAL(trybody, env); - } catch (Mal.Error exc) { - var catchenv = new Mal.Env.within(env); - catchenv.set(catchparam, Mal.BuiltinFunctionThrow. - thrown_value(exc)); - ast = catchbody; - env = catchenv; - continue; // tail-call optimisation - } - } - } - - var newlist = eval_ast(ast, env) as Mal.List; - unowned GLib.List firstlink = newlist.vs.first(); - Mal.Val firstdata = firstlink.data; - newlist.vs.remove_link(firstlink); - - if (firstdata is Mal.BuiltinFunction) { - return (firstdata as Mal.BuiltinFunction).call(newlist); - } else if (firstdata is Mal.Function) { - var fn = firstdata as Mal.Function; - env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); - ast = fn.body; - continue; // tail-call optimisation - } else { - throw new Mal.Error.CANNOT_APPLY( - "bad value at start of list"); - } - } else { - return eval_ast(ast, env); - } - } - } - - public static void PRINT(Mal.Val value) { - stdout.printf("%s\n", pr_str(value)); - } - - public static void rep(Mal.Env env) throws Mal.Error { - Mal.Val? val = READ(); - if (val != null) { - val = EVAL(val, env); - PRINT(val); - } - } - - public static void setup(string line, Mal.Env env) { - try { - EVAL(Reader.read_str(line), env); - } catch (Mal.Error err) { - stderr.printf("Error during setup:\n%s\n-> %s\n", - line, err.message); - GLib.Process.exit(1); - } - } - - public static int main(string[] args) { - var env = new Mal.Env(); - var root = new GC.Root(env); (void)root; - - Mal.Core.make_ns(); - foreach (var key in Mal.Core.ns.get_keys()) - env.set(new Mal.Sym(key), Mal.Core.ns[key]); - env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); - env.set(new Mal.Sym("*host-language*"), new Mal.String("vala")); - - setup("(def! not (fn* (a) (if a false true)))", env); - setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); - setup("(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)))))))", env); - - var ARGV = new GLib.List(); - if (args.length > 1) { - for (int i = args.length - 1; i >= 2; i--) - ARGV.prepend(new Mal.String(args[i])); - } - env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); - - if (args.length > 1) { - var contents = new GLib.List(); - contents.prepend(new Mal.String(args[1])); - contents.prepend(new Mal.Sym("load-file")); - try { - EVAL(new Mal.List(contents), env); - } catch (Mal.Error.EXCEPTION_THROWN exc) { - GLib.stderr.printf( - "uncaught exception: %s\n", - pr_str(Mal.BuiltinFunctionThrow.thrown_value(exc))); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - return 1; - } - } else { - setup("(println (str \"Mal [\" *host-language* \"]\"))", env); - while (!eof) { - try { - rep(env); - } catch (Mal.Error.EXCEPTION_THROWN exc) { - GLib.stderr.printf( - "uncaught exception: %s\n", - pr_str(Mal.BuiltinFunctionThrow.thrown_value(exc))); - } catch (Mal.Error err) { - GLib.stderr.printf("%s\n", err.message); - } - } - } - return 0; - } -} +class Mal.BuiltinFunctionEval : Mal.BuiltinFunction { + public Mal.Env env; + public BuiltinFunctionEval(Mal.Env env_) { env = env_; } + public override Mal.ValWithMetadata copy() { + return new Mal.BuiltinFunctionEval(env); + } + public override string name() { return "eval"; } + public override Mal.Val call(Mal.List args) throws Mal.Error { + if (args.vs.length() != 1) + throw new Mal.Error.BAD_PARAMS("%s: expected one argument", name()); + return Mal.Main.EVAL(args.vs.data, env); + } +} + +class Mal.Main : GLib.Object { + static bool eof; + + static construct { + eof = false; + } + + public static Mal.Val? READ() { + string? line = Readline.readline("user> "); + if (line != null) { + if (line.length > 0) + Readline.History.add(line); + + try { + return Reader.read_str(line); + } catch (Mal.Error err) { + Mal.BuiltinFunctionThrow.clear(); + GLib.stderr.printf("%s\n", err.message); + return null; + } + } else { + stdout.printf("\n"); + eof = true; + return null; + } + } + + public static Mal.Val eval_ast(Mal.Val ast, Mal.Env env) + throws Mal.Error { + var roota = new GC.Root(ast); (void)roota; + var roote = new GC.Root(env); (void)roote; + if (ast is Mal.Sym) + return env.get(ast as Mal.Sym); + if (ast is Mal.List) { + var result = new Mal.List.empty(); + var root = new GC.Root(result); (void)root; + foreach (var elt in (ast as Mal.List).vs) + result.vs.append(EVAL(elt, env)); + return result; + } + if (ast is Mal.Vector) { + var vec = ast as Mal.Vector; + var result = new Mal.Vector.with_size(vec.length); + var root = new GC.Root(result); (void)root; + for (var i = 0; i < vec.length; i++) + result[i] = EVAL(vec[i], env); + return result; + } + if (ast is Mal.Hashmap) { + var result = new Mal.Hashmap(); + var root = new GC.Root(result); (void)root; + var map = (ast as Mal.Hashmap).vs; + foreach (var key in map.get_keys()) + result.insert(key, EVAL(map[key], env)); + return result; + } + return ast; + } + + private static Mal.Val define_eval(Mal.Val key, Mal.Val value, + Mal.Env env, + bool is_macro = false) + throws Mal.Error { + var rootk = new GC.Root(key); (void)rootk; + var roote = new GC.Root(env); (void)roote; + var symkey = key as Mal.Sym; + if (symkey == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected a symbol to define"); + var val = EVAL(value, env); + if (val is Mal.Function) + (val as Mal.Function).is_macro = is_macro; + env.set(symkey, val); + return val; + } + + // If ast is (sym x), return x, else return null. + public static Mal.Val? unquoted (Mal.Val ast, + string sym) + throws Mal.Error { + var list = ast as Mal.List; + if (list == null || list.vs == null) return null; + var a0 = list.vs.data as Mal.Sym; + if (a0 == null || a0.v != sym) return null; + if (list.vs.next == null || list.vs.next.next != null) + throw new Mal.Error.BAD_PARAMS(sym + ": wrong arg count"); + return list.vs.next.data; + } + + public static Mal.Val qq_loop(Mal.Val elt, + Mal.Val acc) + throws Mal.Error { + var list = new Mal.List.empty(); + var unq = unquoted(elt, "splice-unquote"); + if (unq != null) { + list.vs.append(new Mal.Sym("concat")); + list.vs.append(unq); + } else { + list.vs.append(new Mal.Sym("cons")); + list.vs.append(quasiquote (elt)); + } + list.vs.append(acc); + return list; + } + + public static Mal.Val qq_foldr(Mal.Iterator xs) + throws Mal.Error { + if (xs.empty()) { + return new Mal.List.empty(); + } else { + var elt = xs.deref(); + xs.step(); + return qq_loop(elt, qq_foldr(xs)); + } + } + + public static Mal.Val quasiquote(Mal.Val ast) + throws Mal.Error { + if (ast is Mal.List) { + var unq = unquoted(ast, "unquote"); + if (unq != null) { + return unq; + } else { + return qq_foldr((ast as Mal.List).iter()); + } + } else if (ast is Mal.Vector) { + var list = new Mal.List.empty(); + list.vs.append(new Mal.Sym("vec")); + list.vs.append(qq_foldr((ast as Mal.Vector).iter())); + return list; + } else if (ast is Mal.Sym || ast is Mal.Hashmap) { + var list = new Mal.List.empty(); + list.vs.append(new Mal.Sym("quote")); + list.vs.append(ast); + return list; + } else { + return ast; + } + } + + public static bool is_macro_call(Mal.Val v, Mal.Env env) + throws Mal.Error { + var list = v as Mal.List; + if (list == null || list.vs == null || !(list.vs.data is Mal.Sym)) + return false; + try { + var fn = env.get(list.vs.data as Mal.Sym) as Mal.Function; + return (fn != null && fn.is_macro); + } catch (Mal.Error.ENV_LOOKUP_FAILED err) { + return false; + } + } + + public static Mal.Val macroexpand(Mal.Val ast_, Mal.Env env) + throws Mal.Error { + // Copy the parameter into an owned variable (see comment in EVAL). + Mal.Val ast = ast_; + while (is_macro_call(ast, env)) { + var call = ast as Mal.List; + var macro = (env.get(call.vs.data as Mal.Sym) as Mal.Function); + var macroargs = new Mal.List(call.vs.copy()); + macroargs.vs.remove_link(macroargs.vs.first()); + var fnenv = new Mal.Env.funcall( + macro.env, macro.parameters, macroargs); + ast = Mal.Main.EVAL(macro.body, fnenv); + } + return ast; + } + + public static Mal.Val EVAL(Mal.Val ast_, Mal.Env env_) + throws Mal.Error { + // Copy the implicitly 'unowned' function arguments into + // ordinary owned variables which increment the objects' + // reference counts. This is so that when we overwrite these + // variables within the loop (for TCO) the objects we assign + // into them don't immediately get garbage-collected. + Mal.Val ast = ast_; + Mal.Env env = env_; + var ast_root = new GC.Root(ast); (void)ast_root; + var env_root = new GC.Root(env); (void)env_root; + while (true) { + ast_root.obj = ast; + env_root.obj = env; + GC.Core.maybe_collect(); + ast = macroexpand(ast, env); + ast_root.obj = ast; + if (ast is Mal.List) { + unowned GLib.List list = (ast as Mal.List).vs; + if (list.first() == null) + return ast; + + var first = list.first().data; + if (first is Mal.Sym) { + var sym = first as Mal.Sym; + switch (sym.v) { + case "def!": + case "defmacro!": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "def!: expected two values"); + return define_eval(list.next.data, list.next.next.data, + env, sym.v == "defmacro!"); + case "let*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "let*: expected two values"); + var defns = list.nth(1).data; + env = new Mal.Env.within(env); + + if (defns is Mal.List) { + for (unowned GLib.List iter = + (defns as Mal.List).vs; + iter != null; iter = iter.next.next) { + if (iter.next == null) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length list" + + " of definitions"); + define_eval(iter.data, iter.next.data, env); + } + } else if (defns is Mal.Vector) { + var vec = defns as Mal.Vector; + if (vec.length % 2 != 0) + throw new Mal.Error.BAD_PARAMS( + "let*: expected an even-length vector" + + " of definitions"); + for (var i = 0; i < vec.length; i += 2) + define_eval(vec[i], vec[i+1], env); + } else { + throw new Mal.Error.BAD_PARAMS( + "let*: expected a list or vector of definitions"); + } + ast = list.nth(2).data; + continue; // tail-call optimisation + case "do": + Mal.Val result = null; + for (list = list.next; list != null; list = list.next) + result = EVAL(list.data, env); + if (result == null) + throw new Mal.Error.BAD_PARAMS( + "do: expected at least one argument"); + return result; + case "if": + if (list.length() != 3 && list.length() != 4) + throw new Mal.Error.BAD_PARAMS( + "if: expected two or three arguments"); + list = list.next; + var cond = EVAL(list.data, env); + list = list.next; + if (!cond.truth_value()) { + // Skip to the else clause, which defaults to nil. + list = list.next; + if (list == null) + return new Mal.Nil(); + } + ast = list.data; + continue; // tail-call optimisation + case "fn*": + if (list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected two arguments"); + var binds = list.next.data as Mal.Listlike; + var body = list.next.next.data; + if (binds == null) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected a list of parameter names"); + for (var iter = binds.iter(); iter.nonempty(); + iter.step()) + if (!(iter.deref() is Mal.Sym)) + throw new Mal.Error.BAD_PARAMS( + "fn*: expected parameter name to be "+ + "symbol"); + return new Mal.Function(binds, body, env); + case "quote": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quote: expected one argument"); + return list.next.data; + case "quasiquoteexpand": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quasiquoteexpand: expected one argument"); + return quasiquote(list.next.data); + case "quasiquote": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "quasiquote: expected one argument"); + ast = quasiquote(list.next.data); + continue; // tail-call optimisation + case "macroexpand": + if (list.length() != 2) + throw new Mal.Error.BAD_PARAMS( + "macroexpand: expected one argument"); + return macroexpand(list.next.data, env); + case "try*": + if (list.length() != 2 && list.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "try*: expected one or two arguments"); + var trybody = list.next.data; + if (list.length() == 2) { + // Trivial catchless form of try + ast = trybody; + continue; // tail-call optimisation + } + var catchclause = list.next.next.data as Mal.List; + if (!(catchclause.vs.data is Mal.Sym) || + (catchclause.vs.data as Mal.Sym).v != "catch*") + throw new Mal.Error.BAD_PARAMS( + "try*: expected catch*"); + if (catchclause.vs.length() != 3) + throw new Mal.Error.BAD_PARAMS( + "catch*: expected two arguments"); + var catchparam = catchclause.vs.next.data as Mal.Sym; + if (catchparam == null) + throw new Mal.Error.BAD_PARAMS( + "catch*: expected a parameter name"); + var catchbody = catchclause.vs.next.next.data; + try { + return EVAL(trybody, env); + } catch (Mal.Error exc) { + var catchenv = new Mal.Env.within(env); + catchenv.set(catchparam, Mal.BuiltinFunctionThrow. + thrown_value(exc)); + ast = catchbody; + env = catchenv; + continue; // tail-call optimisation + } + } + } + + var newlist = eval_ast(ast, env) as Mal.List; + unowned GLib.List firstlink = newlist.vs.first(); + Mal.Val firstdata = firstlink.data; + newlist.vs.remove_link(firstlink); + + if (firstdata is Mal.BuiltinFunction) { + return (firstdata as Mal.BuiltinFunction).call(newlist); + } else if (firstdata is Mal.Function) { + var fn = firstdata as Mal.Function; + env = new Mal.Env.funcall(fn.env, fn.parameters, newlist); + ast = fn.body; + continue; // tail-call optimisation + } else { + throw new Mal.Error.CANNOT_APPLY( + "bad value at start of list"); + } + } else { + return eval_ast(ast, env); + } + } + } + + public static void PRINT(Mal.Val value) { + stdout.printf("%s\n", pr_str(value)); + } + + public static void rep(Mal.Env env) throws Mal.Error { + Mal.Val? val = READ(); + if (val != null) { + val = EVAL(val, env); + PRINT(val); + } + } + + public static void setup(string line, Mal.Env env) { + try { + EVAL(Reader.read_str(line), env); + } catch (Mal.Error err) { + stderr.printf("Error during setup:\n%s\n-> %s\n", + line, err.message); + GLib.Process.exit(1); + } + } + + public static int main(string[] args) { + var env = new Mal.Env(); + var root = new GC.Root(env); (void)root; + + Mal.Core.make_ns(); + foreach (var key in Mal.Core.ns.get_keys()) + env.set(new Mal.Sym(key), Mal.Core.ns[key]); + env.set(new Mal.Sym("eval"), new Mal.BuiltinFunctionEval(env)); + env.set(new Mal.Sym("*host-language*"), new Mal.String("vala")); + + setup("(def! not (fn* (a) (if a false true)))", env); + setup("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", env); + setup("(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)))))))", env); + + var ARGV = new GLib.List(); + if (args.length > 1) { + for (int i = args.length - 1; i >= 2; i--) + ARGV.prepend(new Mal.String(args[i])); + } + env.set(new Mal.Sym("*ARGV*"), new Mal.List(ARGV)); + + if (args.length > 1) { + var contents = new GLib.List(); + contents.prepend(new Mal.String(args[1])); + contents.prepend(new Mal.Sym("load-file")); + try { + EVAL(new Mal.List(contents), env); + } catch (Mal.Error.EXCEPTION_THROWN exc) { + GLib.stderr.printf( + "uncaught exception: %s\n", + pr_str(Mal.BuiltinFunctionThrow.thrown_value(exc))); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + return 1; + } + } else { + setup("(println (str \"Mal [\" *host-language* \"]\"))", env); + while (!eof) { + try { + rep(env); + } catch (Mal.Error.EXCEPTION_THROWN exc) { + GLib.stderr.printf( + "uncaught exception: %s\n", + pr_str(Mal.BuiltinFunctionThrow.thrown_value(exc))); + } catch (Mal.Error err) { + GLib.stderr.printf("%s\n", err.message); + } + } + } + return 0; + } +} diff --git a/impls/vala/types.vala b/impls/vala/types.vala index 11e4a30aa5..c3e71dd75c 100644 --- a/impls/vala/types.vala +++ b/impls/vala/types.vala @@ -1,288 +1,288 @@ -public errordomain Mal.Error { - BAD_TOKEN, - PARSE_ERROR, - HASH_KEY_TYPE_ERROR, - ENV_LOOKUP_FAILED, - BAD_PARAMS, - CANNOT_APPLY, - EXCEPTION_THROWN, - NOT_IMPLEMENTED_IN_THIS_STEP, -} - -abstract class Mal.Val : GC.Object { - public abstract bool truth_value(); -} - -abstract class Mal.Hashable : Mal.Val { - public string hashkey; - public static uint hash(Hashable h) { return str_hash(h.hashkey); } - public static bool equal(Hashable hl, Hashable hr) { - return hl.hashkey == hr.hashkey; - } -} - -class Mal.Bool : Mal.Hashable { - public bool v; - public Bool(bool value) { - v = value; - hashkey = value ? "bt" : "bf"; - } - public override bool truth_value() { return v; } - public override void gc_traverse(GC.Object.VisitorFunc visit) {} -} - -// Mal.Listlike is a subclass of Mal.Val which includes both lists and -// vectors, and provides a common iterator API so that core functions -// and special forms can treat them the same. -// -// Most core functions that take a list argument also accept nil. To -// make that easy, Mal.Nil also derives from Mal.Listlike. -abstract class Mal.Listlike : Mal.ValWithMetadata { - public abstract Mal.Iterator iter(); -} - -abstract class Mal.Iterator : GLib.Object { - public abstract Mal.Val? deref(); - public abstract Mal.Iterator step(); - public bool empty() { return deref() == null; } - public bool nonempty() { return deref() != null; } -} - -// ValWithMetadata is a subclass of Mal.Val which includes every value -// type you can put metadata on. Value types implementing this class -// must provide a copy() method, because with-meta has to make a copy -// of the value with new metadata. -abstract class Mal.ValWithMetadata : Mal.Val { - public Mal.Val? metadata; - construct { - metadata = null; - } - public abstract Mal.ValWithMetadata copy(); - public abstract void gc_traverse_m(GC.Object.VisitorFunc visit); - public override void gc_traverse(GC.Object.VisitorFunc visit) { - visit(metadata); - gc_traverse_m(visit); - } -} - -class Mal.Nil : Mal.Listlike { - public override bool truth_value() { return false; } - public override Mal.Iterator iter() { return new Mal.NilIterator(); } - public override Mal.ValWithMetadata copy() { return new Mal.Nil(); } - public override void gc_traverse_m(GC.Object.VisitorFunc visit) {} -} - -class Mal.NilIterator : Mal.Iterator { - public override Mal.Val? deref() { return null; } - public override Mal.Iterator step() { return this; } -} - -class Mal.List : Mal.Listlike { - public GLib.List vs; - public List(GLib.List values) { - foreach (var value in values) { - vs.append(value); - } - } - public List.empty() { - } - public override bool truth_value() { return true; } - public override Mal.Iterator iter() { - var toret = new Mal.ListIterator(); - toret.node = vs; - return toret; - } - public override Mal.ValWithMetadata copy() { - return new Mal.List(vs); - } - public override void gc_traverse_m(GC.Object.VisitorFunc visit) { - foreach (var v in vs) - visit(v); - } -} - -class Mal.ListIterator : Mal.Iterator { - public unowned GLib.List? node; - public override Mal.Val? deref() { - return node == null ? null : node.data; - } - public override Mal.Iterator step() { - if (node != null) - node = node.next; - return this; - } -} - -class Mal.Vector : Mal.Listlike { - struct Ref { weak Mal.Val v; } - private Ref[] rs; - public Vector.from_list(GLib.List values) { - rs = new Ref[values.length()]; - int i = 0; - foreach (var value in values) { - rs[i++] = { value }; - } - } - public Vector.with_size(uint size) { - rs = new Ref[size]; - } - private Vector.copy_of(Vector v) { - rs = v.rs; - } - public override bool truth_value() { return true; } - public override Mal.Iterator iter() { - var toret = new Mal.VectorIterator(); - toret.vec = this; - toret.pos = 0; - return toret; - } - public override Mal.ValWithMetadata copy() { - return new Mal.Vector.copy_of(this); - } - public uint length { get { return rs.length; } } - public new Mal.Val @get(uint pos) { - assert(pos < rs.length); - return rs[pos].v; - } - public new void @set(uint pos, Mal.Val v) { - assert(pos < rs.length); - rs[pos].v = v; - } - public override void gc_traverse_m(GC.Object.VisitorFunc visit) { - foreach (var r in rs) - visit(r.v); - } -} - -class Mal.VectorIterator : Mal.Iterator { - public Mal.Vector vec; - public int pos; - public override Mal.Val? deref() { - return pos >= vec.length ? null : vec[pos]; - } - public override Mal.Iterator step() { - if (pos < vec.length) pos++; - return this; - } -} - -class Mal.Num : Mal.Hashable { - public int64 v; - public Num(int64 value) { - v = value; - hashkey = "N" + v.to_string(); - } - public override bool truth_value() { return true; } - public override void gc_traverse(GC.Object.VisitorFunc visit) {} -} - -abstract class Mal.SymBase : Mal.Hashable { - public string v; - public override bool truth_value() { return true; } - public override void gc_traverse(GC.Object.VisitorFunc visit) {} -} - -class Mal.Sym : Mal.SymBase { - public Sym(string value) { - v = value; - hashkey = "'" + v; - } -} - -class Mal.Keyword : Mal.SymBase { - public Keyword(string value) { - v = value; - hashkey = ":" + v; - } -} - -class Mal.String : Mal.Hashable { - public string v; - public String(string value) { - v = value; - hashkey = "\"" + v; - } - public override bool truth_value() { return true; } - public override void gc_traverse(GC.Object.VisitorFunc visit) {} -} - -class Mal.Hashmap : Mal.ValWithMetadata { - public GLib.HashTable vs; - construct { - vs = new GLib.HashTable( - Mal.Hashable.hash, Mal.Hashable.equal); - } - public void insert(Mal.Val key, Mal.Val value) throws Mal.Error { - var hkey = key as Mal.Hashable; - if (hkey == null) - throw new Error.HASH_KEY_TYPE_ERROR("bad type as hash key"); - vs[hkey] = value; - } - public void remove(Mal.Val key) throws Mal.Error { - var hkey = key as Mal.Hashable; - if (hkey == null) - throw new Error.HASH_KEY_TYPE_ERROR("bad type as hash key"); - vs.remove(hkey); - } - public override bool truth_value() { return true; } - public override Mal.ValWithMetadata copy() { - var toret = new Mal.Hashmap(); - toret.vs = vs; - return toret; - } - public override void gc_traverse_m(GC.Object.VisitorFunc visit) { - foreach (var key in vs.get_keys()) { - visit(key); - visit(vs[key]); - } - } -} - -abstract class Mal.BuiltinFunction : Mal.ValWithMetadata { - public abstract string name(); - public abstract Mal.Val call(Mal.List args) throws Mal.Error; - public override bool truth_value() { return true; } - public override void gc_traverse_m(GC.Object.VisitorFunc visit) {} -} - -class Mal.Function : Mal.ValWithMetadata { - public bool is_macro; -#if !NO_ENV - public weak Mal.Listlike parameters; - public weak Mal.Val body; - public weak Mal.Env env; - public Function(Mal.Listlike parameters_, Mal.Val body_, Mal.Env env_) { - parameters = parameters_; - body = body_; - env = env_; - is_macro = false; - } -#endif - public override Mal.ValWithMetadata copy() { -#if !NO_ENV - var copied = new Mal.Function(parameters, body, env); - copied.is_macro = is_macro; - return copied; -#else - throw new Mal.Error.NOT_IMPLEMENTED_IN_THIS_STEP( - "can't copy a Mal.Function without Mal.Env existing"); -#endif - } - public override bool truth_value() { return true; } - public override void gc_traverse_m(GC.Object.VisitorFunc visit) { -#if !NO_ENV - visit(parameters); - visit(body); - visit(env); -#endif - } -} - -class Mal.Atom : Mal.Val { - public weak Mal.Val v; - public Atom(Mal.Val v_) { v = v_; } - public override bool truth_value() { return true; } - public override void gc_traverse(GC.Object.VisitorFunc visit) { - visit(v); - } -} +public errordomain Mal.Error { + BAD_TOKEN, + PARSE_ERROR, + HASH_KEY_TYPE_ERROR, + ENV_LOOKUP_FAILED, + BAD_PARAMS, + CANNOT_APPLY, + EXCEPTION_THROWN, + NOT_IMPLEMENTED_IN_THIS_STEP, +} + +abstract class Mal.Val : GC.Object { + public abstract bool truth_value(); +} + +abstract class Mal.Hashable : Mal.Val { + public string hashkey; + public static uint hash(Hashable h) { return str_hash(h.hashkey); } + public static bool equal(Hashable hl, Hashable hr) { + return hl.hashkey == hr.hashkey; + } +} + +class Mal.Bool : Mal.Hashable { + public bool v; + public Bool(bool value) { + v = value; + hashkey = value ? "bt" : "bf"; + } + public override bool truth_value() { return v; } + public override void gc_traverse(GC.Object.VisitorFunc visit) {} +} + +// Mal.Listlike is a subclass of Mal.Val which includes both lists and +// vectors, and provides a common iterator API so that core functions +// and special forms can treat them the same. +// +// Most core functions that take a list argument also accept nil. To +// make that easy, Mal.Nil also derives from Mal.Listlike. +abstract class Mal.Listlike : Mal.ValWithMetadata { + public abstract Mal.Iterator iter(); +} + +abstract class Mal.Iterator : GLib.Object { + public abstract Mal.Val? deref(); + public abstract Mal.Iterator step(); + public bool empty() { return deref() == null; } + public bool nonempty() { return deref() != null; } +} + +// ValWithMetadata is a subclass of Mal.Val which includes every value +// type you can put metadata on. Value types implementing this class +// must provide a copy() method, because with-meta has to make a copy +// of the value with new metadata. +abstract class Mal.ValWithMetadata : Mal.Val { + public Mal.Val? metadata; + construct { + metadata = null; + } + public abstract Mal.ValWithMetadata copy(); + public abstract void gc_traverse_m(GC.Object.VisitorFunc visit); + public override void gc_traverse(GC.Object.VisitorFunc visit) { + visit(metadata); + gc_traverse_m(visit); + } +} + +class Mal.Nil : Mal.Listlike { + public override bool truth_value() { return false; } + public override Mal.Iterator iter() { return new Mal.NilIterator(); } + public override Mal.ValWithMetadata copy() { return new Mal.Nil(); } + public override void gc_traverse_m(GC.Object.VisitorFunc visit) {} +} + +class Mal.NilIterator : Mal.Iterator { + public override Mal.Val? deref() { return null; } + public override Mal.Iterator step() { return this; } +} + +class Mal.List : Mal.Listlike { + public GLib.List vs; + public List(GLib.List values) { + foreach (var value in values) { + vs.append(value); + } + } + public List.empty() { + } + public override bool truth_value() { return true; } + public override Mal.Iterator iter() { + var toret = new Mal.ListIterator(); + toret.node = vs; + return toret; + } + public override Mal.ValWithMetadata copy() { + return new Mal.List(vs); + } + public override void gc_traverse_m(GC.Object.VisitorFunc visit) { + foreach (var v in vs) + visit(v); + } +} + +class Mal.ListIterator : Mal.Iterator { + public unowned GLib.List? node; + public override Mal.Val? deref() { + return node == null ? null : node.data; + } + public override Mal.Iterator step() { + if (node != null) + node = node.next; + return this; + } +} + +class Mal.Vector : Mal.Listlike { + struct Ref { weak Mal.Val v; } + private Ref[] rs; + public Vector.from_list(GLib.List values) { + rs = new Ref[values.length()]; + int i = 0; + foreach (var value in values) { + rs[i++] = { value }; + } + } + public Vector.with_size(uint size) { + rs = new Ref[size]; + } + private Vector.copy_of(Vector v) { + rs = v.rs; + } + public override bool truth_value() { return true; } + public override Mal.Iterator iter() { + var toret = new Mal.VectorIterator(); + toret.vec = this; + toret.pos = 0; + return toret; + } + public override Mal.ValWithMetadata copy() { + return new Mal.Vector.copy_of(this); + } + public uint length { get { return rs.length; } } + public new Mal.Val @get(uint pos) { + assert(pos < rs.length); + return rs[pos].v; + } + public new void @set(uint pos, Mal.Val v) { + assert(pos < rs.length); + rs[pos].v = v; + } + public override void gc_traverse_m(GC.Object.VisitorFunc visit) { + foreach (var r in rs) + visit(r.v); + } +} + +class Mal.VectorIterator : Mal.Iterator { + public Mal.Vector vec; + public int pos; + public override Mal.Val? deref() { + return pos >= vec.length ? null : vec[pos]; + } + public override Mal.Iterator step() { + if (pos < vec.length) pos++; + return this; + } +} + +class Mal.Num : Mal.Hashable { + public int64 v; + public Num(int64 value) { + v = value; + hashkey = "N" + v.to_string(); + } + public override bool truth_value() { return true; } + public override void gc_traverse(GC.Object.VisitorFunc visit) {} +} + +abstract class Mal.SymBase : Mal.Hashable { + public string v; + public override bool truth_value() { return true; } + public override void gc_traverse(GC.Object.VisitorFunc visit) {} +} + +class Mal.Sym : Mal.SymBase { + public Sym(string value) { + v = value; + hashkey = "'" + v; + } +} + +class Mal.Keyword : Mal.SymBase { + public Keyword(string value) { + v = value; + hashkey = ":" + v; + } +} + +class Mal.String : Mal.Hashable { + public string v; + public String(string value) { + v = value; + hashkey = "\"" + v; + } + public override bool truth_value() { return true; } + public override void gc_traverse(GC.Object.VisitorFunc visit) {} +} + +class Mal.Hashmap : Mal.ValWithMetadata { + public GLib.HashTable vs; + construct { + vs = new GLib.HashTable( + Mal.Hashable.hash, Mal.Hashable.equal); + } + public void insert(Mal.Val key, Mal.Val value) throws Mal.Error { + var hkey = key as Mal.Hashable; + if (hkey == null) + throw new Error.HASH_KEY_TYPE_ERROR("bad type as hash key"); + vs[hkey] = value; + } + public void remove(Mal.Val key) throws Mal.Error { + var hkey = key as Mal.Hashable; + if (hkey == null) + throw new Error.HASH_KEY_TYPE_ERROR("bad type as hash key"); + vs.remove(hkey); + } + public override bool truth_value() { return true; } + public override Mal.ValWithMetadata copy() { + var toret = new Mal.Hashmap(); + toret.vs = vs; + return toret; + } + public override void gc_traverse_m(GC.Object.VisitorFunc visit) { + foreach (var key in vs.get_keys()) { + visit(key); + visit(vs[key]); + } + } +} + +abstract class Mal.BuiltinFunction : Mal.ValWithMetadata { + public abstract string name(); + public abstract Mal.Val call(Mal.List args) throws Mal.Error; + public override bool truth_value() { return true; } + public override void gc_traverse_m(GC.Object.VisitorFunc visit) {} +} + +class Mal.Function : Mal.ValWithMetadata { + public bool is_macro; +#if !NO_ENV + public weak Mal.Listlike parameters; + public weak Mal.Val body; + public weak Mal.Env env; + public Function(Mal.Listlike parameters_, Mal.Val body_, Mal.Env env_) { + parameters = parameters_; + body = body_; + env = env_; + is_macro = false; + } +#endif + public override Mal.ValWithMetadata copy() { +#if !NO_ENV + var copied = new Mal.Function(parameters, body, env); + copied.is_macro = is_macro; + return copied; +#else + throw new Mal.Error.NOT_IMPLEMENTED_IN_THIS_STEP( + "can't copy a Mal.Function without Mal.Env existing"); +#endif + } + public override bool truth_value() { return true; } + public override void gc_traverse_m(GC.Object.VisitorFunc visit) { +#if !NO_ENV + visit(parameters); + visit(body); + visit(env); +#endif + } +} + +class Mal.Atom : Mal.Val { + public weak Mal.Val v; + public Atom(Mal.Val v_) { v = v_; } + public override bool truth_value() { return true; } + public override void gc_traverse(GC.Object.VisitorFunc visit) { + visit(v); + } +} diff --git a/impls/vb/Dockerfile b/impls/vb/Dockerfile index f5f133484d..e8180bc9fd 100644 --- a/impls/vb/Dockerfile +++ b/impls/vb/Dockerfile @@ -1,25 +1,25 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# Deps for Mono-based languages (C#, VB.Net) -RUN apt-get -y install mono-runtime mono-mcs mono-vbnc mono-devel +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# Deps for Mono-based languages (C#, VB.Net) +RUN apt-get -y install mono-runtime mono-mcs mono-vbnc mono-devel diff --git a/impls/vb/Makefile b/impls/vb/Makefile index 4f269959e1..1485edc818 100644 --- a/impls/vb/Makefile +++ b/impls/vb/Makefile @@ -1,39 +1,39 @@ -##################### - -DEBUG = - -SOURCES_BASE = readline.vb types.vb reader.vb printer.vb -SOURCES_LISP = env.vb core.vb stepA_mal.vb -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -##################### - -SRCS = step0_repl.vb step1_read_print.vb step2_eval.vb \ - step3_env.vb step4_if_fn_do.vb step5_tco.vb step6_file.vb \ - step7_quote.vb step8_macros.vb step9_try.vb stepA_mal.vb - -LIB_CS_SRCS = getline.cs -LIB_VB_SRCS = $(filter-out step%,$(filter %.vb,$(SOURCES))) - -FLAGS = $(if $(strip $(DEBUG)),-debug:full,) - -##################### - -all: $(patsubst %.vb,%.exe,$(SRCS)) - -dist: mal.exe - -mal.exe: $(patsubst %.vb,%.exe,$(word $(words $(SOURCES)),$(SOURCES))) - cp $< $@ - -mal_cs.dll: $(LIB_CS_SRCS) - mcs $(FLAGS) -target:library $+ -out:$@ - -mal_vb.dll: mal_cs.dll $(LIB_VB_SRCS) - vbnc $(FLAGS) -target:library -r:mal_cs.dll $(LIB_VB_SRCS) -out:$@ - -%.exe: %.vb mal_vb.dll - vbnc $(FLAGS) -r:mal_vb.dll -r:mal_cs.dll $< - -clean: - rm -f *.dll *.exe *.mdb +##################### + +DEBUG = + +SOURCES_BASE = readline.vb types.vb reader.vb printer.vb +SOURCES_LISP = env.vb core.vb stepA_mal.vb +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +##################### + +SRCS = step0_repl.vb step1_read_print.vb step2_eval.vb \ + step3_env.vb step4_if_fn_do.vb step5_tco.vb step6_file.vb \ + step7_quote.vb step8_macros.vb step9_try.vb stepA_mal.vb + +LIB_CS_SRCS = getline.cs +LIB_VB_SRCS = $(filter-out step%,$(filter %.vb,$(SOURCES))) + +FLAGS = $(if $(strip $(DEBUG)),-debug:full,) + +##################### + +all: $(patsubst %.vb,%.exe,$(SRCS)) + +dist: mal.exe + +mal.exe: $(patsubst %.vb,%.exe,$(word $(words $(SOURCES)),$(SOURCES))) + cp $< $@ + +mal_cs.dll: $(LIB_CS_SRCS) + mcs $(FLAGS) -target:library $+ -out:$@ + +mal_vb.dll: mal_cs.dll $(LIB_VB_SRCS) + vbnc $(FLAGS) -target:library -r:mal_cs.dll $(LIB_VB_SRCS) -out:$@ + +%.exe: %.vb mal_vb.dll + vbnc $(FLAGS) -r:mal_vb.dll -r:mal_cs.dll $< + +clean: + rm -f *.dll *.exe *.mdb diff --git a/impls/vb/core.vb b/impls/vb/core.vb index 08d3caf308..c8d6139574 100644 --- a/impls/vb/core.vb +++ b/impls/vb/core.vb @@ -1,543 +1,543 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports MalVal = Mal.types.MalVal -Imports MalConstant = Mal.types.MalConstant -Imports MalInt = Mal.types.MalInt -Imports MalSymbol = Mal.types.MalSymbol -Imports MalString = Mal.types.MalString -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalAtom = Mal.types.MalAtom -Imports MalFunc = Mal.types.MalFunc - -Namespace Mal - Public Class core - Shared Nil As MalConstant = Mal.types.Nil - Shared MalTrue As MalConstant = Mal.types.MalTrue - Shared MalFalse As MalConstant = Mal.types.MalFalse - - ' Errors/Exceptions - Shared Function mal_throw(a As MalList) As MalVal - throw New Mal.types.MalException(a(0)) - End Function - - ' General functions - Shared Function equal_Q(a As MalList) As MalVal - If Mal.types._equal_Q(a(0), a(1)) Then - return MalTrue - Else - return MalFalse - End If - End Function - - ' Scalar functions - Shared Function nil_Q(a As MalList) As MalVal - If a(0) Is Nil Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function true_Q(a As MalList) As MalVal - If a(0) Is MalTrue Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function false_Q(a As MalList) As MalVal - If a(0) Is MalFalse Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function symbol(a As MalList) As MalVal - return new MalSymbol(DirectCast(a(0),MalString)) - End Function - - Shared Function symbol_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalSymbol Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function string_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalString Then - Dim s As String = DirectCast(a(0),MalString).getValue() - If s.Length = 0 Then - return MalTrue - Elseif s.Substring(0,1) = Strings.ChrW(&H029e) Then - return MalFalse - Else - return MalTrue - End If - Else - return MalFalse - End If - End Function - - Shared Function keyword(a As MalList) As MalVal - Dim s As String = DirectCast(a(0),MalString).getValue() - return new MalString(ChrW(&H029e) & s) - End Function - - Shared Function keyword_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalString Then - Dim s As String = DirectCast(a(0),MalString).getValue() - If s.Length = 0 Then - return MalFalse - Elseif s.Substring(0,1) = Strings.ChrW(&H029e) Then - return MalTrue - Else - return MalFalse - End If - Else - return MalFalse - End If - End Function - - Shared Function number_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalInt Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function fn_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalFunc AndAlso Not DirectCast(a(0),MalFunc).isMacro() Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function macro_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalFunc AndAlso DirectCast(a(0),MalFunc).isMacro() Then - return MalTrue - Else - return MalFalse - End If - End Function - - - ' Number functions - Shared Function lt(a As MalList) As MalVal - return DirectCast(a(0),MalInt) < DirectCast(a(1),MalInt) - End Function - Shared Function lte(a As MalList) As MalVal - return DirectCast(a(0),MalInt) <= DirectCast(a(1),MalInt) - End Function - Shared Function gt(a As MalList) As MalVal - return DirectCast(a(0),MalInt) > DirectCast(a(1),MalInt) - End Function - Shared Function gte(a As MalList) As MalVal - return DirectCast(a(0),MalInt) >= DirectCast(a(1),MalInt) - End Function - Shared Function plus(a As MalList) As MalVal - return DirectCast(a(0),MalInt) + DirectCast(a(1),MalInt) - End Function - Shared Function minus(a As MalList) As MalVal - return DirectCast(a(0),MalInt) - DirectCast(a(1),MalInt) - End Function - Shared Function mult(a As MalList) As MalVal - return DirectCast(a(0),MalInt) * DirectCast(a(1),MalInt) - End Function - Shared Function div(a As MalList) As MalVal - return DirectCast(a(0),MalInt) / DirectCast(a(1),MalInt) - End Function - - Shared Function time_ms(a As MalList) As MalVal - return New MalInt(DateTime.Now.Ticks / TimeSpan.TicksPerMillisecond) - End Function - - ' String functions - Shared Function pr_str(a As MalList) As MalVal - return New MalString(printer._pr_str_args(a, " ", true)) - End Function - - Shared Function str(a As MalList) As MalVal - return new MalString(printer._pr_str_args(a, "", false)) - End Function - - Shared Function prn(a As MalList) As MalVal - Console.WriteLine(printer._pr_str_args(a, " ", true)) - return Nil - End Function - - Shared Function println(a As MalList) As MalVal - Console.WriteLine(printer._pr_str_args(a, " ", false)) - return Nil - End Function - - Shared Function mal_readline(a As MalList) As MalVal - Dim line As String - line = readline.Readline(DirectCast(a(0),MalString).getValue()) - If line Is Nothing Then - return types.Nil - Else - return New MalString(line) - End If - End Function - - Shared Function read_string(a As MalList) As MalVal - return reader.read_str(DirectCast(a(0),MalString).getValue()) - End Function - - Shared Function slurp(a As MalList) As MalVal - return New MalString(File.ReadAllText(DirectCast(a(0),MalString).getValue())) - End Function - - - ' List/Vector functions - - Shared Function list(a As MalList) As MalVal - return New MalList(a.getValue()) - End Function - - Shared Function list_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalList And Not TypeOf a(0) Is MalVector Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function vector(a As MalList) As MalVal - return New MalVector(a.getValue()) - End Function - - Shared Function vector_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalVector Then - return MalTrue - Else - return MalFalse - End If - End Function - - ' HashMap functions - Shared Function hash_map(a As MalList) As MalVal - return New MalHashMap(a) - End Function - - Shared Function hash_map_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalHashMap Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function contains_Q(a As MalList) As MalVal - Dim key As String = DirectCast(a(1),MalString).getValue() - Dim dict As Dictionary(Of String,MalVal) = DirectCast(a(0),MalHashMap).getValue() - If dict.ContainsKey(key) Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function assoc(a As MalList) As MalVal - Dim new_hm As MalHashMap = DirectCast(a(0),MalHashMap).copy() - return new_hm.assoc_BANG(DirectCast(a.slice(1),MalList)) - End Function - - Shared Function dissoc(a As MalList) As MalVal - Dim new_hm As MalHashMap = DirectCast(a(0),MalHashMap).copy() - return new_hm.dissoc_BANG(DirectCast(a.slice(1),MalList)) - End Function - - Shared Function do_get(a As MalList) As MalVal - Dim k As String = DirectCast(a(1),MalString).getValue() - If a(0) Is Nil Then - return Nil - Else - Dim dict As Dictionary(Of String,MalVal) = DirectCast(a(0),MalHashMap).getValue() - If dict.ContainsKey(k) Then - return dict(k) - Else - return Nil - End If - End If - End Function - - Shared Function keys(a As MalList) As MalVal - Dim dict As Dictionary(Of String,MalVal) = DirectCast(a(0),MalHashMap).getValue() - Dim key_lst As MalList = New MalList() - For Each key As String in dict.Keys - key_lst.conj_BANG(new MalString(key)) - Next - return key_lst - End Function - - Shared Function vals(a As MalList) As MalVal - Dim dict As Dictionary(Of String,MalVal) = DirectCast(a(0),MalHashMap).getValue() - Dim val_lst As MalList = New MalList() - For Each val As MalVal In dict.Values - val_lst.conj_BANG(val) - Next - return val_lst - End Function - - ' Sequence functions - Shared Function sequential_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalList Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function cons(a As MalList) As MalVal - Dim lst As New List(Of MalVal) - lst.Add(a(0)) - lst.AddRange(DirectCast(a(1),MalList).getValue()) - return DirectCast(New MalList(lst),MalVal) - End Function - - Shared Function concat(a As MalList) As MalVal - If a.size() = 0 Then - return new MalList() - End If - Dim lst As New List(Of MalVal) - lst.AddRange(DirectCast(a(0),MalList).getValue()) - for i As Integer = 1 To a.size()-1 - lst.AddRange(DirectCast(a(i),MalList).getValue()) - Next - return DirectCast(new MalList(lst),MalVal) - End Function - - Shared Function vec(a As MalList) As MalVal - return New MalVector(DirectCast(a(0),MalList).getValue()) - End Function - - Shared Function nth(a As MalList) As MalVal - Dim idx As Integer = DirectCast(a(1),MalInt).getValue() - If (idx < DirectCast(a(0),MalList).size()) Then - return DirectCast(a(0),MalList)( idx ) - Else - throw new Mal.types.MalException( - "nth: index out of range") - End If - End Function - - Shared Function first(a As MalList) As MalVal - If a(0) Is Nil Then - return Nil - Else - return DirectCast(a(0),MalList)(0) - End If - End Function - - Shared Function rest(a As MalList) As MalVal - If a(0) Is Nil Then - return new MalList() - Else - return DirectCast(a(0),MalList).rest() - End If - End Function - - Shared Function empty_Q(a As MalList) As MalVal - If DirectCast(a(0),MalList).size() = 0 Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function count(a As MalList) As MalVal - If a(0) Is Nil Then - return new MalInt(0) - Else - return new MalInt(DirectCast(a(0),MalList).size()) - End If - End Function - - Shared Function conj(a As MalList) As MalVal - Dim src_lst As List(Of MalVal) = DirectCast(a(0),MalList).getValue() - Dim new_lst As New List(Of MalVal) - new_lst.AddRange(src_lst) - If TypeOf a(0) Is MalVector Then - For i As Integer = 1 To a.size()-1 - new_lst.Add(a(i)) - Next - return new MalVector(new_lst) - Else - For i As Integer = 1 To a.size()-1 - new_lst.Insert(0, a(i)) - Next - return new MalList(new_lst) - End If - End Function - - Shared Function seq(a As MalList) As MalVal - If a(0) Is Nil Then - return Nil - Elseif TypeOf a(0) is MalVector Then - If DirectCast(a(0),MalVector).size() = 0 Then - return Nil - End If - return new MalList(DirectCast(a(0),MalVector).getValue()) - Elseif TypeOf a(0) is MalList Then - If DirectCast(a(0),MalList).size() = 0 Then - return Nil - End If - return a(0) - Elseif TypeOf a(0) is MalString Then - Dim s As String = DirectCast(a(0),MalString).getValue() - If s.Length = 0 Then - return Nil - End If - Dim chars_list As New List(Of MalVal) - For Each c As Char In s - chars_list.Add(new MalString(c.ToString())) - Next - return new MalList(chars_list) - Else - return Nil - End If - End Function - - ' General list related functions - Shared Function apply(a As MalList) As MalVal - Dim f As MalFunc = DirectCast(a(0),MalFunc) - Dim lst As New List(Of MalVal) - lst.AddRange(a.slice(1,a.size()-1).getValue()) - lst.AddRange(DirectCast(a(a.size()-1),MalList).getValue()) - return f.apply(New MalList(lst)) - End Function - - Shared Function map(a As MalList) As MalVal - Dim f As MalFunc = DirectCast(a(0),MalFunc) - Dim src_lst As List(Of MalVal) = DirectCast(a(1),MalList).getValue() - Dim new_lst As New List(Of MalVal) - for i As Integer = 0 To src_lst.Count-1 - new_lst.Add(f.apply(New MalList(src_lst(i)))) - Next - return new MalList(new_lst) - End Function - - - ' Metadata functions - Shared Function atom(a As MalList) As MalVal - return new MalAtom(a(0)) - End Function - - Shared Function meta(a As MalList) As MalVal - return a(0).getMeta() - End Function - - Shared Function with_meta(a As MalList) As MalVal - return DirectCast(a(0),MalVal).copy().setMeta(a(1)) - End Function - - - ' Atom functions - Shared Function atom_Q(a As MalList) As MalVal - If TypeOf a(0) Is MalAtom Then - return MalTrue - Else - return MalFalse - End If - End Function - - Shared Function deref(a As MalList) As MalVal - return DirectCast(a(0),MalAtom).getValue() - End Function - - Shared Function reset_BANG(a As MalList) As MalVal - return DirectCast(a(0),MalAtom).setValue(a(1)) - End Function - - Shared Function swap_BANG(a As MalList) As MalVal - Dim atm As MalAtom = DirectCast(a(0),MalAtom) - Dim f As MalFunc = DirectCast(a(1),MalFunc) - Dim new_lst As New List(Of MalVal) - new_lst.Add(atm.getValue()) - new_lst.AddRange(DirectCast(a.slice(2),MalList).getValue()) - return atm.setValue(f.apply(New MalList(new_lst))) - End Function - - - - Shared Function ns As Dictionary(Of String, MalVal) - Dim ns As New Dictionary(Of String, MalVal) - - ns.Add("=", New MalFunc(AddressOf equal_Q)) - ns.Add("throw", New MalFunc(AddressOf mal_throw)) - ns.Add("nil?", New MalFunc(AddressOf nil_Q)) - ns.Add("true?", New MalFunc(AddressOf true_Q)) - ns.Add("false?", New MalFunc(AddressOf false_Q)) - ns.Add("symbol", new MalFunc(AddressOf symbol)) - ns.Add("symbol?", New MalFunc(AddressOf symbol_Q)) - ns.Add("string?", New MalFunc(AddressOf string_Q)) - ns.Add("keyword", new MalFunc(AddressOf keyword)) - ns.Add("keyword?", New MalFunc(AddressOf keyword_Q)) - ns.Add("number?", New MalFunc(AddressOf number_Q)) - ns.Add("fn?", New MalFunc(AddressOf fn_Q)) - ns.Add("macro?", New MalFunc(AddressOf macro_Q)) - - ns.Add("pr-str",New MalFunc(AddressOf pr_str)) - ns.Add("str", New MalFunc(AddressOf str)) - ns.Add("prn", New MalFunc(AddressOf prn)) - ns.Add("println", New MalFunc(AddressOf println)) - ns.Add("readline", New MalFunc(AddressOf mal_readline)) - ns.Add("read-string", New MalFunc(AddressOf read_string)) - ns.Add("slurp", New MalFunc(AddressOf slurp)) - ns.Add("<", New MalFunc(AddressOf lt)) - ns.Add("<=", New MalFunc(AddressOf lte)) - ns.Add(">", New MalFunc(AddressOf gt)) - ns.Add(">=", New MalFunc(AddressOf gte)) - ns.Add("+", New MalFunc(AddressOf plus)) - ns.Add("-", New MalFunc(AddressOf minus)) - ns.Add("*", New MalFunc(AddressOf mult)) - ns.Add("/", New MalFunc(AddressOf div)) - ns.Add("time-ms", New MalFunc(AddressOf time_ms)) - - ns.Add("list", New MalFunc(AddressOf list)) - ns.Add("list?", New MalFunc(AddressOf list_Q)) - ns.Add("vector", new MalFunc(AddressOf vector)) - ns.Add("vector?", New MalFunc(AddressOf vector_Q)) - ns.Add("hash-map", new MalFunc(AddressOf hash_map)) - ns.Add("map?", New MalFunc(AddressOf hash_map_Q)) - ns.Add("contains?", New MalFunc(AddressOf contains_Q)) - ns.Add("assoc", New MalFunc(AddressOf assoc)) - ns.Add("dissoc", New MalFunc(AddressOf dissoc)) - ns.Add("get", New MalFunc(AddressOf do_get)) - ns.Add("keys", New MalFunc(AddressOf keys)) - ns.Add("vals", New MalFunc(AddressOf vals)) - - ns.Add("sequential?", New MalFunc(AddressOf sequential_Q)) - ns.Add("cons", New MalFunc(AddressOf cons)) - ns.Add("concat", New MalFunc(AddressOf concat)) - ns.Add("vec", New MalFunc(AddressOf vec)) - ns.Add("nth", New MalFunc(AddressOf nth)) - ns.Add("first", New MalFunc(AddressOf first)) - ns.Add("rest", New MalFunc(AddressOf rest)) - ns.Add("empty?", New MalFunc(AddressOf empty_Q)) - ns.Add("count",New MalFunc(AddressOf count)) - ns.Add("conj", New MalFunc(AddressOf conj)) - ns.Add("seq", New MalFunc(AddressOf seq)) - ns.Add("apply", New MalFunc(AddressOf apply)) - ns.Add("map", New MalFunc(AddressOf map)) - - ns.Add("with-meta", New MalFunc(AddressOf with_meta)) - ns.Add("meta", New MalFunc(AddressOf meta)) - ns.Add("atom", new MalFunc(AddressOf atom)) - ns.Add("atom?", New MalFunc(AddressOf atom_Q)) - ns.Add("deref", New MalFunc(AddressOf deref)) - ns.Add("reset!", New MalFunc(AddressOf reset_BANG)) - ns.Add("swap!", New MalFunc(AddressOf swap_BANG)) - return ns - End Function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports MalVal = Mal.types.MalVal +Imports MalConstant = Mal.types.MalConstant +Imports MalInt = Mal.types.MalInt +Imports MalSymbol = Mal.types.MalSymbol +Imports MalString = Mal.types.MalString +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalAtom = Mal.types.MalAtom +Imports MalFunc = Mal.types.MalFunc + +Namespace Mal + Public Class core + Shared Nil As MalConstant = Mal.types.Nil + Shared MalTrue As MalConstant = Mal.types.MalTrue + Shared MalFalse As MalConstant = Mal.types.MalFalse + + ' Errors/Exceptions + Shared Function mal_throw(a As MalList) As MalVal + throw New Mal.types.MalException(a(0)) + End Function + + ' General functions + Shared Function equal_Q(a As MalList) As MalVal + If Mal.types._equal_Q(a(0), a(1)) Then + return MalTrue + Else + return MalFalse + End If + End Function + + ' Scalar functions + Shared Function nil_Q(a As MalList) As MalVal + If a(0) Is Nil Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function true_Q(a As MalList) As MalVal + If a(0) Is MalTrue Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function false_Q(a As MalList) As MalVal + If a(0) Is MalFalse Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function symbol(a As MalList) As MalVal + return new MalSymbol(DirectCast(a(0),MalString)) + End Function + + Shared Function symbol_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalSymbol Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function string_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalString Then + Dim s As String = DirectCast(a(0),MalString).getValue() + If s.Length = 0 Then + return MalTrue + Elseif s.Substring(0,1) = Strings.ChrW(&H029e) Then + return MalFalse + Else + return MalTrue + End If + Else + return MalFalse + End If + End Function + + Shared Function keyword(a As MalList) As MalVal + Dim s As String = DirectCast(a(0),MalString).getValue() + return new MalString(ChrW(&H029e) & s) + End Function + + Shared Function keyword_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalString Then + Dim s As String = DirectCast(a(0),MalString).getValue() + If s.Length = 0 Then + return MalFalse + Elseif s.Substring(0,1) = Strings.ChrW(&H029e) Then + return MalTrue + Else + return MalFalse + End If + Else + return MalFalse + End If + End Function + + Shared Function number_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalInt Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function fn_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalFunc AndAlso Not DirectCast(a(0),MalFunc).isMacro() Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function macro_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalFunc AndAlso DirectCast(a(0),MalFunc).isMacro() Then + return MalTrue + Else + return MalFalse + End If + End Function + + + ' Number functions + Shared Function lt(a As MalList) As MalVal + return DirectCast(a(0),MalInt) < DirectCast(a(1),MalInt) + End Function + Shared Function lte(a As MalList) As MalVal + return DirectCast(a(0),MalInt) <= DirectCast(a(1),MalInt) + End Function + Shared Function gt(a As MalList) As MalVal + return DirectCast(a(0),MalInt) > DirectCast(a(1),MalInt) + End Function + Shared Function gte(a As MalList) As MalVal + return DirectCast(a(0),MalInt) >= DirectCast(a(1),MalInt) + End Function + Shared Function plus(a As MalList) As MalVal + return DirectCast(a(0),MalInt) + DirectCast(a(1),MalInt) + End Function + Shared Function minus(a As MalList) As MalVal + return DirectCast(a(0),MalInt) - DirectCast(a(1),MalInt) + End Function + Shared Function mult(a As MalList) As MalVal + return DirectCast(a(0),MalInt) * DirectCast(a(1),MalInt) + End Function + Shared Function div(a As MalList) As MalVal + return DirectCast(a(0),MalInt) / DirectCast(a(1),MalInt) + End Function + + Shared Function time_ms(a As MalList) As MalVal + return New MalInt(DateTime.Now.Ticks / TimeSpan.TicksPerMillisecond) + End Function + + ' String functions + Shared Function pr_str(a As MalList) As MalVal + return New MalString(printer._pr_str_args(a, " ", true)) + End Function + + Shared Function str(a As MalList) As MalVal + return new MalString(printer._pr_str_args(a, "", false)) + End Function + + Shared Function prn(a As MalList) As MalVal + Console.WriteLine(printer._pr_str_args(a, " ", true)) + return Nil + End Function + + Shared Function println(a As MalList) As MalVal + Console.WriteLine(printer._pr_str_args(a, " ", false)) + return Nil + End Function + + Shared Function mal_readline(a As MalList) As MalVal + Dim line As String + line = readline.Readline(DirectCast(a(0),MalString).getValue()) + If line Is Nothing Then + return types.Nil + Else + return New MalString(line) + End If + End Function + + Shared Function read_string(a As MalList) As MalVal + return reader.read_str(DirectCast(a(0),MalString).getValue()) + End Function + + Shared Function slurp(a As MalList) As MalVal + return New MalString(File.ReadAllText(DirectCast(a(0),MalString).getValue())) + End Function + + + ' List/Vector functions + + Shared Function list(a As MalList) As MalVal + return New MalList(a.getValue()) + End Function + + Shared Function list_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalList And Not TypeOf a(0) Is MalVector Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function vector(a As MalList) As MalVal + return New MalVector(a.getValue()) + End Function + + Shared Function vector_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalVector Then + return MalTrue + Else + return MalFalse + End If + End Function + + ' HashMap functions + Shared Function hash_map(a As MalList) As MalVal + return New MalHashMap(a) + End Function + + Shared Function hash_map_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalHashMap Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function contains_Q(a As MalList) As MalVal + Dim key As String = DirectCast(a(1),MalString).getValue() + Dim dict As Dictionary(Of String,MalVal) = DirectCast(a(0),MalHashMap).getValue() + If dict.ContainsKey(key) Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function assoc(a As MalList) As MalVal + Dim new_hm As MalHashMap = DirectCast(a(0),MalHashMap).copy() + return new_hm.assoc_BANG(DirectCast(a.slice(1),MalList)) + End Function + + Shared Function dissoc(a As MalList) As MalVal + Dim new_hm As MalHashMap = DirectCast(a(0),MalHashMap).copy() + return new_hm.dissoc_BANG(DirectCast(a.slice(1),MalList)) + End Function + + Shared Function do_get(a As MalList) As MalVal + Dim k As String = DirectCast(a(1),MalString).getValue() + If a(0) Is Nil Then + return Nil + Else + Dim dict As Dictionary(Of String,MalVal) = DirectCast(a(0),MalHashMap).getValue() + If dict.ContainsKey(k) Then + return dict(k) + Else + return Nil + End If + End If + End Function + + Shared Function keys(a As MalList) As MalVal + Dim dict As Dictionary(Of String,MalVal) = DirectCast(a(0),MalHashMap).getValue() + Dim key_lst As MalList = New MalList() + For Each key As String in dict.Keys + key_lst.conj_BANG(new MalString(key)) + Next + return key_lst + End Function + + Shared Function vals(a As MalList) As MalVal + Dim dict As Dictionary(Of String,MalVal) = DirectCast(a(0),MalHashMap).getValue() + Dim val_lst As MalList = New MalList() + For Each val As MalVal In dict.Values + val_lst.conj_BANG(val) + Next + return val_lst + End Function + + ' Sequence functions + Shared Function sequential_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalList Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function cons(a As MalList) As MalVal + Dim lst As New List(Of MalVal) + lst.Add(a(0)) + lst.AddRange(DirectCast(a(1),MalList).getValue()) + return DirectCast(New MalList(lst),MalVal) + End Function + + Shared Function concat(a As MalList) As MalVal + If a.size() = 0 Then + return new MalList() + End If + Dim lst As New List(Of MalVal) + lst.AddRange(DirectCast(a(0),MalList).getValue()) + for i As Integer = 1 To a.size()-1 + lst.AddRange(DirectCast(a(i),MalList).getValue()) + Next + return DirectCast(new MalList(lst),MalVal) + End Function + + Shared Function vec(a As MalList) As MalVal + return New MalVector(DirectCast(a(0),MalList).getValue()) + End Function + + Shared Function nth(a As MalList) As MalVal + Dim idx As Integer = DirectCast(a(1),MalInt).getValue() + If (idx < DirectCast(a(0),MalList).size()) Then + return DirectCast(a(0),MalList)( idx ) + Else + throw new Mal.types.MalException( + "nth: index out of range") + End If + End Function + + Shared Function first(a As MalList) As MalVal + If a(0) Is Nil Then + return Nil + Else + return DirectCast(a(0),MalList)(0) + End If + End Function + + Shared Function rest(a As MalList) As MalVal + If a(0) Is Nil Then + return new MalList() + Else + return DirectCast(a(0),MalList).rest() + End If + End Function + + Shared Function empty_Q(a As MalList) As MalVal + If DirectCast(a(0),MalList).size() = 0 Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function count(a As MalList) As MalVal + If a(0) Is Nil Then + return new MalInt(0) + Else + return new MalInt(DirectCast(a(0),MalList).size()) + End If + End Function + + Shared Function conj(a As MalList) As MalVal + Dim src_lst As List(Of MalVal) = DirectCast(a(0),MalList).getValue() + Dim new_lst As New List(Of MalVal) + new_lst.AddRange(src_lst) + If TypeOf a(0) Is MalVector Then + For i As Integer = 1 To a.size()-1 + new_lst.Add(a(i)) + Next + return new MalVector(new_lst) + Else + For i As Integer = 1 To a.size()-1 + new_lst.Insert(0, a(i)) + Next + return new MalList(new_lst) + End If + End Function + + Shared Function seq(a As MalList) As MalVal + If a(0) Is Nil Then + return Nil + Elseif TypeOf a(0) is MalVector Then + If DirectCast(a(0),MalVector).size() = 0 Then + return Nil + End If + return new MalList(DirectCast(a(0),MalVector).getValue()) + Elseif TypeOf a(0) is MalList Then + If DirectCast(a(0),MalList).size() = 0 Then + return Nil + End If + return a(0) + Elseif TypeOf a(0) is MalString Then + Dim s As String = DirectCast(a(0),MalString).getValue() + If s.Length = 0 Then + return Nil + End If + Dim chars_list As New List(Of MalVal) + For Each c As Char In s + chars_list.Add(new MalString(c.ToString())) + Next + return new MalList(chars_list) + Else + return Nil + End If + End Function + + ' General list related functions + Shared Function apply(a As MalList) As MalVal + Dim f As MalFunc = DirectCast(a(0),MalFunc) + Dim lst As New List(Of MalVal) + lst.AddRange(a.slice(1,a.size()-1).getValue()) + lst.AddRange(DirectCast(a(a.size()-1),MalList).getValue()) + return f.apply(New MalList(lst)) + End Function + + Shared Function map(a As MalList) As MalVal + Dim f As MalFunc = DirectCast(a(0),MalFunc) + Dim src_lst As List(Of MalVal) = DirectCast(a(1),MalList).getValue() + Dim new_lst As New List(Of MalVal) + for i As Integer = 0 To src_lst.Count-1 + new_lst.Add(f.apply(New MalList(src_lst(i)))) + Next + return new MalList(new_lst) + End Function + + + ' Metadata functions + Shared Function atom(a As MalList) As MalVal + return new MalAtom(a(0)) + End Function + + Shared Function meta(a As MalList) As MalVal + return a(0).getMeta() + End Function + + Shared Function with_meta(a As MalList) As MalVal + return DirectCast(a(0),MalVal).copy().setMeta(a(1)) + End Function + + + ' Atom functions + Shared Function atom_Q(a As MalList) As MalVal + If TypeOf a(0) Is MalAtom Then + return MalTrue + Else + return MalFalse + End If + End Function + + Shared Function deref(a As MalList) As MalVal + return DirectCast(a(0),MalAtom).getValue() + End Function + + Shared Function reset_BANG(a As MalList) As MalVal + return DirectCast(a(0),MalAtom).setValue(a(1)) + End Function + + Shared Function swap_BANG(a As MalList) As MalVal + Dim atm As MalAtom = DirectCast(a(0),MalAtom) + Dim f As MalFunc = DirectCast(a(1),MalFunc) + Dim new_lst As New List(Of MalVal) + new_lst.Add(atm.getValue()) + new_lst.AddRange(DirectCast(a.slice(2),MalList).getValue()) + return atm.setValue(f.apply(New MalList(new_lst))) + End Function + + + + Shared Function ns As Dictionary(Of String, MalVal) + Dim ns As New Dictionary(Of String, MalVal) + + ns.Add("=", New MalFunc(AddressOf equal_Q)) + ns.Add("throw", New MalFunc(AddressOf mal_throw)) + ns.Add("nil?", New MalFunc(AddressOf nil_Q)) + ns.Add("true?", New MalFunc(AddressOf true_Q)) + ns.Add("false?", New MalFunc(AddressOf false_Q)) + ns.Add("symbol", new MalFunc(AddressOf symbol)) + ns.Add("symbol?", New MalFunc(AddressOf symbol_Q)) + ns.Add("string?", New MalFunc(AddressOf string_Q)) + ns.Add("keyword", new MalFunc(AddressOf keyword)) + ns.Add("keyword?", New MalFunc(AddressOf keyword_Q)) + ns.Add("number?", New MalFunc(AddressOf number_Q)) + ns.Add("fn?", New MalFunc(AddressOf fn_Q)) + ns.Add("macro?", New MalFunc(AddressOf macro_Q)) + + ns.Add("pr-str",New MalFunc(AddressOf pr_str)) + ns.Add("str", New MalFunc(AddressOf str)) + ns.Add("prn", New MalFunc(AddressOf prn)) + ns.Add("println", New MalFunc(AddressOf println)) + ns.Add("readline", New MalFunc(AddressOf mal_readline)) + ns.Add("read-string", New MalFunc(AddressOf read_string)) + ns.Add("slurp", New MalFunc(AddressOf slurp)) + ns.Add("<", New MalFunc(AddressOf lt)) + ns.Add("<=", New MalFunc(AddressOf lte)) + ns.Add(">", New MalFunc(AddressOf gt)) + ns.Add(">=", New MalFunc(AddressOf gte)) + ns.Add("+", New MalFunc(AddressOf plus)) + ns.Add("-", New MalFunc(AddressOf minus)) + ns.Add("*", New MalFunc(AddressOf mult)) + ns.Add("/", New MalFunc(AddressOf div)) + ns.Add("time-ms", New MalFunc(AddressOf time_ms)) + + ns.Add("list", New MalFunc(AddressOf list)) + ns.Add("list?", New MalFunc(AddressOf list_Q)) + ns.Add("vector", new MalFunc(AddressOf vector)) + ns.Add("vector?", New MalFunc(AddressOf vector_Q)) + ns.Add("hash-map", new MalFunc(AddressOf hash_map)) + ns.Add("map?", New MalFunc(AddressOf hash_map_Q)) + ns.Add("contains?", New MalFunc(AddressOf contains_Q)) + ns.Add("assoc", New MalFunc(AddressOf assoc)) + ns.Add("dissoc", New MalFunc(AddressOf dissoc)) + ns.Add("get", New MalFunc(AddressOf do_get)) + ns.Add("keys", New MalFunc(AddressOf keys)) + ns.Add("vals", New MalFunc(AddressOf vals)) + + ns.Add("sequential?", New MalFunc(AddressOf sequential_Q)) + ns.Add("cons", New MalFunc(AddressOf cons)) + ns.Add("concat", New MalFunc(AddressOf concat)) + ns.Add("vec", New MalFunc(AddressOf vec)) + ns.Add("nth", New MalFunc(AddressOf nth)) + ns.Add("first", New MalFunc(AddressOf first)) + ns.Add("rest", New MalFunc(AddressOf rest)) + ns.Add("empty?", New MalFunc(AddressOf empty_Q)) + ns.Add("count",New MalFunc(AddressOf count)) + ns.Add("conj", New MalFunc(AddressOf conj)) + ns.Add("seq", New MalFunc(AddressOf seq)) + ns.Add("apply", New MalFunc(AddressOf apply)) + ns.Add("map", New MalFunc(AddressOf map)) + + ns.Add("with-meta", New MalFunc(AddressOf with_meta)) + ns.Add("meta", New MalFunc(AddressOf meta)) + ns.Add("atom", new MalFunc(AddressOf atom)) + ns.Add("atom?", New MalFunc(AddressOf atom_Q)) + ns.Add("deref", New MalFunc(AddressOf deref)) + ns.Add("reset!", New MalFunc(AddressOf reset_BANG)) + ns.Add("swap!", New MalFunc(AddressOf swap_BANG)) + return ns + End Function + End Class +End Namespace diff --git a/impls/vb/env.vb b/impls/vb/env.vb index a2c46289a3..2f288400d1 100644 --- a/impls/vb/env.vb +++ b/impls/vb/env.vb @@ -1,55 +1,55 @@ -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList - -Namespace Mal - Public Class env - Public Class Env - Dim outer As Env = Nothing - Dim data As Dictionary(Of String, MalVal) = New Dictionary(Of String, MalVal) - - Public Sub New(new_outer As Env) - outer = new_outer - End Sub - Public Sub New(new_outer As Env, binds As MalList, exprs As MalList) - outer = new_outer - For i As Integer = 0 To binds.size()-1 - Dim sym As String = DirectCast(binds.nth(i),MalSymbol).getName() - If sym = "&" Then - data(DirectCast(binds.nth(i+1),MalSymbol).getName()) = exprs.slice(i) - Exit For - Else - data(sym) = exprs.nth(i) - End If - Next - End Sub - - Public Function find(key As MalSymbol) As Env - If data.ContainsKey(key.getName()) Then - return Me - Else If outer IsNot Nothing Then - return outer.find(key) - Else - return Nothing - End If - End Function - - Public Function do_get(key As MalSymbol) As MalVal - Dim e As Env = find(key) - If e Is Nothing Then - throw New Mal.types.MalException( - "'" & key.getName() & "' not found") - Else - return e.data(key.getName()) - End If - End Function - - Public Function do_set(key As MalSymbol, value As MalVal) As Env - data(key.getName()) = value - return Me - End Function - End Class - End Class -End Namespace +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList + +Namespace Mal + Public Class env + Public Class Env + Dim outer As Env = Nothing + Dim data As Dictionary(Of String, MalVal) = New Dictionary(Of String, MalVal) + + Public Sub New(new_outer As Env) + outer = new_outer + End Sub + Public Sub New(new_outer As Env, binds As MalList, exprs As MalList) + outer = new_outer + For i As Integer = 0 To binds.size()-1 + Dim sym As String = DirectCast(binds.nth(i),MalSymbol).getName() + If sym = "&" Then + data(DirectCast(binds.nth(i+1),MalSymbol).getName()) = exprs.slice(i) + Exit For + Else + data(sym) = exprs.nth(i) + End If + Next + End Sub + + Public Function find(key As MalSymbol) As Env + If data.ContainsKey(key.getName()) Then + return Me + Else If outer IsNot Nothing Then + return outer.find(key) + Else + return Nothing + End If + End Function + + Public Function do_get(key As MalSymbol) As MalVal + Dim e As Env = find(key) + If e Is Nothing Then + throw New Mal.types.MalException( + "'" & key.getName() & "' not found") + Else + return e.data(key.getName()) + End If + End Function + + Public Function do_set(key As MalSymbol, value As MalVal) As Env + data(key.getName()) = value + return Me + End Function + End Class + End Class +End Namespace diff --git a/impls/vb/getline.cs b/impls/vb/getline.cs index c11a11d8b8..40212ab1da 100644 --- a/impls/vb/getline.cs +++ b/impls/vb/getline.cs @@ -1,1089 +1,1089 @@ -// -// getline.cs: A command line editor -// -// Authors: -// Miguel de Icaza (miguel@novell.com) -// -// Copyright 2008 Novell, Inc. -// -// Dual-licensed under the terms of the MIT X11 license or the -// Apache License 2.0 -// -// USE -define:DEMO to build this as a standalone file and test it -// -// TODO: -// Enter an error (a = 1); Notice how the prompt is in the wrong line -// This is caused by Stderr not being tracked by System.Console. -// Completion support -// Why is Thread.Interrupt not working? Currently I resort to Abort which is too much. -// -// Limitations in System.Console: -// Console needs SIGWINCH support of some sort -// Console needs a way of updating its position after things have been written -// behind its back (P/Invoke puts for example). -// System.Console needs to get the DELETE character, and report accordingly. -// - -using System; -using System.Text; -using System.IO; -using System.Threading; -using System.Reflection; - -namespace Mono.Terminal { - - public class LineEditor { - - public class Completion { - public string [] Result; - public string Prefix; - - public Completion (string prefix, string [] result) - { - Prefix = prefix; - Result = result; - } - } - - public delegate Completion AutoCompleteHandler (string text, int pos); - - //static StreamWriter log; - - // The text being edited. - StringBuilder text; - - // The text as it is rendered (replaces (char)1 with ^A on display for example). - StringBuilder rendered_text; - - // The prompt specified, and the prompt shown to the user. - string prompt; - string shown_prompt; - - // The current cursor position, indexes into "text", for an index - // into rendered_text, use TextToRenderPos - int cursor; - - // The row where we started displaying data. - int home_row; - - // The maximum length that has been displayed on the screen - int max_rendered; - - // If we are done editing, this breaks the interactive loop - bool done = false; - - // The thread where the Editing started taking place - Thread edit_thread; - - // Our object that tracks history - History history; - - // The contents of the kill buffer (cut/paste in Emacs parlance) - string kill_buffer = ""; - - // The string being searched for - string search; - string last_search; - - // whether we are searching (-1= reverse; 0 = no; 1 = forward) - int searching; - - // The position where we found the match. - int match_at; - - // Used to implement the Kill semantics (multiple Alt-Ds accumulate) - KeyHandler last_handler; - - delegate void KeyHandler (); - - struct Handler { - public ConsoleKeyInfo CKI; - public KeyHandler KeyHandler; - - public Handler (ConsoleKey key, KeyHandler h) - { - CKI = new ConsoleKeyInfo ((char) 0, key, false, false, false); - KeyHandler = h; - } - - public Handler (char c, KeyHandler h) - { - KeyHandler = h; - // Use the "Zoom" as a flag that we only have a character. - CKI = new ConsoleKeyInfo (c, ConsoleKey.Zoom, false, false, false); - } - - public Handler (ConsoleKeyInfo cki, KeyHandler h) - { - CKI = cki; - KeyHandler = h; - } - - public static Handler Control (char c, KeyHandler h) - { - return new Handler ((char) (c - 'A' + 1), h); - } - - public static Handler Alt (char c, ConsoleKey k, KeyHandler h) - { - ConsoleKeyInfo cki = new ConsoleKeyInfo ((char) c, k, false, true, false); - return new Handler (cki, h); - } - } - - /// - /// Invoked when the user requests auto-completion using the tab character - /// - /// - /// The result is null for no values found, an array with a single - /// string, in that case the string should be the text to be inserted - /// for example if the word at pos is "T", the result for a completion - /// of "ToString" should be "oString", not "ToString". - /// - /// When there are multiple results, the result should be the full - /// text - /// - public AutoCompleteHandler AutoCompleteEvent; - - static Handler [] handlers; - - public LineEditor (string name) : this (name, 10) { } - - public LineEditor (string name, int histsize) - { - handlers = new Handler [] { - new Handler (ConsoleKey.Home, CmdHome), - new Handler (ConsoleKey.End, CmdEnd), - new Handler (ConsoleKey.LeftArrow, CmdLeft), - new Handler (ConsoleKey.RightArrow, CmdRight), - new Handler (ConsoleKey.UpArrow, CmdHistoryPrev), - new Handler (ConsoleKey.DownArrow, CmdHistoryNext), - new Handler (ConsoleKey.Enter, CmdDone), - new Handler (ConsoleKey.Backspace, CmdBackspace), - new Handler (ConsoleKey.Delete, CmdDeleteChar), - new Handler (ConsoleKey.Tab, CmdTabOrComplete), - - // Emacs keys - Handler.Control ('A', CmdHome), - Handler.Control ('E', CmdEnd), - Handler.Control ('B', CmdLeft), - Handler.Control ('F', CmdRight), - Handler.Control ('P', CmdHistoryPrev), - Handler.Control ('N', CmdHistoryNext), - Handler.Control ('K', CmdKillToEOF), - Handler.Control ('Y', CmdYank), - Handler.Control ('D', CmdDeleteChar), - Handler.Control ('L', CmdRefresh), - Handler.Control ('R', CmdReverseSearch), - Handler.Control ('G', delegate {} ), - Handler.Alt ('B', ConsoleKey.B, CmdBackwardWord), - Handler.Alt ('F', ConsoleKey.F, CmdForwardWord), - - Handler.Alt ('D', ConsoleKey.D, CmdDeleteWord), - Handler.Alt ((char) 8, ConsoleKey.Backspace, CmdDeleteBackword), - - // DEBUG - //Handler.Control ('T', CmdDebug), - - // quote - Handler.Control ('Q', delegate { HandleChar (Console.ReadKey (true).KeyChar); }) - }; - - rendered_text = new StringBuilder (); - text = new StringBuilder (); - - history = new History (name, histsize); - - //if (File.Exists ("log"))File.Delete ("log"); - //log = File.CreateText ("log"); - } - - void CmdDebug () - { - history.Dump (); - Console.WriteLine (); - Render (); - } - - void Render () - { - Console.Write (shown_prompt); - Console.Write (rendered_text); - - int max = System.Math.Max (rendered_text.Length + shown_prompt.Length, max_rendered); - - for (int i = rendered_text.Length + shown_prompt.Length; i < max_rendered; i++) - Console.Write (' '); - max_rendered = shown_prompt.Length + rendered_text.Length; - - // Write one more to ensure that we always wrap around properly if we are at the - // end of a line. - Console.Write (' '); - - UpdateHomeRow (max); - } - - void UpdateHomeRow (int screenpos) - { - int lines = 1 + (screenpos / Console.WindowWidth); - - home_row = Console.CursorTop - (lines - 1); - if (home_row < 0) - home_row = 0; - } - - - void RenderFrom (int pos) - { - int rpos = TextToRenderPos (pos); - int i; - - for (i = rpos; i < rendered_text.Length; i++) - Console.Write (rendered_text [i]); - - if ((shown_prompt.Length + rendered_text.Length) > max_rendered) - max_rendered = shown_prompt.Length + rendered_text.Length; - else { - int max_extra = max_rendered - shown_prompt.Length; - for (; i < max_extra; i++) - Console.Write (' '); - } - } - - void ComputeRendered () - { - rendered_text.Length = 0; - - for (int i = 0; i < text.Length; i++){ - int c = (int) text [i]; - if (c < 26){ - if (c == '\t') - rendered_text.Append (" "); - else { - rendered_text.Append ('^'); - rendered_text.Append ((char) (c + (int) 'A' - 1)); - } - } else - rendered_text.Append ((char)c); - } - } - - int TextToRenderPos (int pos) - { - int p = 0; - - for (int i = 0; i < pos; i++){ - int c; - - c = (int) text [i]; - - if (c < 26){ - if (c == 9) - p += 4; - else - p += 2; - } else - p++; - } - - return p; - } - - int TextToScreenPos (int pos) - { - return shown_prompt.Length + TextToRenderPos (pos); - } - - string Prompt { - get { return prompt; } - set { prompt = value; } - } - - int LineCount { - get { - return (shown_prompt.Length + rendered_text.Length)/Console.WindowWidth; - } - } - - void ForceCursor (int newpos) - { - cursor = newpos; - - int actual_pos = shown_prompt.Length + TextToRenderPos (cursor); - int row = home_row + (actual_pos/Console.WindowWidth); - int col = actual_pos % Console.WindowWidth; - - if (row >= Console.BufferHeight) - row = Console.BufferHeight-1; - Console.SetCursorPosition (col, row); - - //log.WriteLine ("Going to cursor={0} row={1} col={2} actual={3} prompt={4} ttr={5} old={6}", newpos, row, col, actual_pos, prompt.Length, TextToRenderPos (cursor), cursor); - //log.Flush (); - } - - void UpdateCursor (int newpos) - { - if (cursor == newpos) - return; - - ForceCursor (newpos); - } - - void InsertChar (char c) - { - int prev_lines = LineCount; - text = text.Insert (cursor, c); - ComputeRendered (); - if (prev_lines != LineCount){ - - Console.SetCursorPosition (0, home_row); - Render (); - ForceCursor (++cursor); - } else { - RenderFrom (cursor); - ForceCursor (++cursor); - UpdateHomeRow (TextToScreenPos (cursor)); - } - } - - // - // Commands - // - void CmdDone () - { - done = true; - } - - void CmdTabOrComplete () - { - bool complete = false; - - if (AutoCompleteEvent != null){ - if (TabAtStartCompletes) - complete = true; - else { - for (int i = 0; i < cursor; i++){ - if (!Char.IsWhiteSpace (text [i])){ - complete = true; - break; - } - } - } - - if (complete){ - Completion completion = AutoCompleteEvent (text.ToString (), cursor); - string [] completions = completion.Result; - if (completions == null) - return; - - int ncompletions = completions.Length; - if (ncompletions == 0) - return; - - if (completions.Length == 1){ - InsertTextAtCursor (completions [0]); - } else { - int last = -1; - - for (int p = 0; p < completions [0].Length; p++){ - char c = completions [0][p]; - - - for (int i = 1; i < ncompletions; i++){ - if (completions [i].Length < p) - goto mismatch; - - if (completions [i][p] != c){ - goto mismatch; - } - } - last = p; - } - mismatch: - if (last != -1){ - InsertTextAtCursor (completions [0].Substring (0, last+1)); - } - Console.WriteLine (); - foreach (string s in completions){ - Console.Write (completion.Prefix); - Console.Write (s); - Console.Write (' '); - } - Console.WriteLine (); - Render (); - ForceCursor (cursor); - } - } else - HandleChar ('\t'); - } else - HandleChar ('t'); - } - - void CmdHome () - { - UpdateCursor (0); - } - - void CmdEnd () - { - UpdateCursor (text.Length); - } - - void CmdLeft () - { - if (cursor == 0) - return; - - UpdateCursor (cursor-1); - } - - void CmdBackwardWord () - { - int p = WordBackward (cursor); - if (p == -1) - return; - UpdateCursor (p); - } - - void CmdForwardWord () - { - int p = WordForward (cursor); - if (p == -1) - return; - UpdateCursor (p); - } - - void CmdRight () - { - if (cursor == text.Length) - return; - - UpdateCursor (cursor+1); - } - - void RenderAfter (int p) - { - ForceCursor (p); - RenderFrom (p); - ForceCursor (cursor); - } - - void CmdBackspace () - { - if (cursor == 0) - return; - - text.Remove (--cursor, 1); - ComputeRendered (); - RenderAfter (cursor); - } - - void CmdDeleteChar () - { - // If there is no input, this behaves like EOF - if (text.Length == 0){ - done = true; - text = null; - Console.WriteLine (); - return; - } - - if (cursor == text.Length) - return; - text.Remove (cursor, 1); - ComputeRendered (); - RenderAfter (cursor); - } - - int WordForward (int p) - { - if (p >= text.Length) - return -1; - - int i = p; - if (Char.IsPunctuation (text [p]) || Char.IsSymbol (text [p]) || Char.IsWhiteSpace (text[p])){ - for (; i < text.Length; i++){ - if (Char.IsLetterOrDigit (text [i])) - break; - } - for (; i < text.Length; i++){ - if (!Char.IsLetterOrDigit (text [i])) - break; - } - } else { - for (; i < text.Length; i++){ - if (!Char.IsLetterOrDigit (text [i])) - break; - } - } - if (i != p) - return i; - return -1; - } - - int WordBackward (int p) - { - if (p == 0) - return -1; - - int i = p-1; - if (i == 0) - return 0; - - if (Char.IsPunctuation (text [i]) || Char.IsSymbol (text [i]) || Char.IsWhiteSpace (text[i])){ - for (; i >= 0; i--){ - if (Char.IsLetterOrDigit (text [i])) - break; - } - for (; i >= 0; i--){ - if (!Char.IsLetterOrDigit (text[i])) - break; - } - } else { - for (; i >= 0; i--){ - if (!Char.IsLetterOrDigit (text [i])) - break; - } - } - i++; - - if (i != p) - return i; - - return -1; - } - - void CmdDeleteWord () - { - int pos = WordForward (cursor); - - if (pos == -1) - return; - - string k = text.ToString (cursor, pos-cursor); - - if (last_handler == CmdDeleteWord) - kill_buffer = kill_buffer + k; - else - kill_buffer = k; - - text.Remove (cursor, pos-cursor); - ComputeRendered (); - RenderAfter (cursor); - } - - void CmdDeleteBackword () - { - int pos = WordBackward (cursor); - if (pos == -1) - return; - - string k = text.ToString (pos, cursor-pos); - - if (last_handler == CmdDeleteBackword) - kill_buffer = k + kill_buffer; - else - kill_buffer = k; - - text.Remove (pos, cursor-pos); - ComputeRendered (); - RenderAfter (pos); - } - - // - // Adds the current line to the history if needed - // - void HistoryUpdateLine () - { - history.Update (text.ToString ()); - } - - void CmdHistoryPrev () - { - if (!history.PreviousAvailable ()) - return; - - HistoryUpdateLine (); - - SetText (history.Previous ()); - } - - void CmdHistoryNext () - { - if (!history.NextAvailable()) - return; - - history.Update (text.ToString ()); - SetText (history.Next ()); - - } - - void CmdKillToEOF () - { - kill_buffer = text.ToString (cursor, text.Length-cursor); - text.Length = cursor; - ComputeRendered (); - RenderAfter (cursor); - } - - void CmdYank () - { - InsertTextAtCursor (kill_buffer); - } - - void InsertTextAtCursor (string str) - { - int prev_lines = LineCount; - text.Insert (cursor, str); - ComputeRendered (); - if (prev_lines != LineCount){ - Console.SetCursorPosition (0, home_row); - Render (); - cursor += str.Length; - ForceCursor (cursor); - } else { - RenderFrom (cursor); - cursor += str.Length; - ForceCursor (cursor); - UpdateHomeRow (TextToScreenPos (cursor)); - } - } - - void SetSearchPrompt (string s) - { - SetPrompt ("(reverse-i-search)`" + s + "': "); - } - - void ReverseSearch () - { - int p; - - if (cursor == text.Length){ - // The cursor is at the end of the string - - p = text.ToString ().LastIndexOf (search); - if (p != -1){ - match_at = p; - cursor = p; - ForceCursor (cursor); - return; - } - } else { - // The cursor is somewhere in the middle of the string - int start = (cursor == match_at) ? cursor - 1 : cursor; - if (start != -1){ - p = text.ToString ().LastIndexOf (search, start); - if (p != -1){ - match_at = p; - cursor = p; - ForceCursor (cursor); - return; - } - } - } - - // Need to search backwards in history - HistoryUpdateLine (); - string s = history.SearchBackward (search); - if (s != null){ - match_at = -1; - SetText (s); - ReverseSearch (); - } - } - - void CmdReverseSearch () - { - if (searching == 0){ - match_at = -1; - last_search = search; - searching = -1; - search = ""; - SetSearchPrompt (""); - } else { - if (search == ""){ - if (last_search != "" && last_search != null){ - search = last_search; - SetSearchPrompt (search); - - ReverseSearch (); - } - return; - } - ReverseSearch (); - } - } - - void SearchAppend (char c) - { - search = search + c; - SetSearchPrompt (search); - - // - // If the new typed data still matches the current text, stay here - // - if (cursor < text.Length){ - string r = text.ToString (cursor, text.Length - cursor); - if (r.StartsWith (search)) - return; - } - - ReverseSearch (); - } - - void CmdRefresh () - { - Console.Clear (); - max_rendered = 0; - Render (); - ForceCursor (cursor); - } - - void InterruptEdit (object sender, ConsoleCancelEventArgs a) - { - // Do not abort our program: - a.Cancel = true; - - // Interrupt the editor - edit_thread.Abort(); - } - - void HandleChar (char c) - { - if (searching != 0) - SearchAppend (c); - else - InsertChar (c); - } - - void EditLoop () - { - ConsoleKeyInfo cki; - - while (!done){ - ConsoleModifiers mod; - - cki = Console.ReadKey (true); - if (cki.Key == ConsoleKey.Escape){ - cki = Console.ReadKey (true); - - mod = ConsoleModifiers.Alt; - } else - mod = cki.Modifiers; - - bool handled = false; - - foreach (Handler handler in handlers){ - ConsoleKeyInfo t = handler.CKI; - - if (t.Key == cki.Key && t.Modifiers == mod){ - handled = true; - handler.KeyHandler (); - last_handler = handler.KeyHandler; - break; - } else if (t.KeyChar == cki.KeyChar && t.Key == ConsoleKey.Zoom){ - handled = true; - handler.KeyHandler (); - last_handler = handler.KeyHandler; - break; - } - } - if (handled){ - if (searching != 0){ - if (last_handler != CmdReverseSearch){ - searching = 0; - SetPrompt (prompt); - } - } - continue; - } - - if (cki.KeyChar != (char) 0) - HandleChar (cki.KeyChar); - } - } - - void InitText (string initial) - { - text = new StringBuilder (initial); - ComputeRendered (); - cursor = text.Length; - Render (); - ForceCursor (cursor); - } - - void SetText (string newtext) - { - Console.SetCursorPosition (0, home_row); - InitText (newtext); - } - - void SetPrompt (string newprompt) - { - shown_prompt = newprompt; - Console.SetCursorPosition (0, home_row); - Render (); - ForceCursor (cursor); - } - - public string Edit (string prompt, string initial) - { - edit_thread = Thread.CurrentThread; - searching = 0; - Console.CancelKeyPress += InterruptEdit; - - done = false; - history.CursorToEnd (); - max_rendered = 0; - - Prompt = prompt; - shown_prompt = prompt; - InitText (initial); - history.Append (initial); - - do { - try { - EditLoop (); - } catch (ThreadAbortException){ - searching = 0; - Thread.ResetAbort (); - Console.WriteLine (); - SetPrompt (prompt); - SetText (""); - } - } while (!done); - Console.WriteLine (); - - Console.CancelKeyPress -= InterruptEdit; - - if (text == null){ - history.Close (); - return null; - } - - string result = text.ToString (); - if (result != "") - history.Accept (result); - else - history.RemoveLast (); - - return result; - } - - public void SaveHistory () - { - if (history != null) { - history.Close (); - } - } - - public bool TabAtStartCompletes { get; set; } - - // - // Emulates the bash-like behavior, where edits done to the - // history are recorded - // - class History { - string [] history; - int head, tail; - int cursor, count; - string histfile; - - public History (string app, int size) - { - if (size < 1) - throw new ArgumentException ("size"); - - if (app != null){ - string dir = Environment.GetFolderPath (Environment.SpecialFolder.Personal); - //Console.WriteLine (dir); - /* - if (!Directory.Exists (dir)){ - try { - Directory.CreateDirectory (dir); - } catch { - app = null; - } - } - if (app != null) - histfile = Path.Combine (dir, app) + ".history"; - */ - histfile = Path.Combine (dir, ".mal-history"); - } - - history = new string [size]; - head = tail = cursor = 0; - - if (File.Exists (histfile)){ - using (StreamReader sr = File.OpenText (histfile)){ - string line; - - while ((line = sr.ReadLine ()) != null){ - if (line != "") - Append (line); - } - } - } - } - - public void Close () - { - if (histfile == null) - return; - - try { - using (StreamWriter sw = File.CreateText (histfile)){ - int start = (count == history.Length) ? head : tail; - for (int i = start; i < start+count; i++){ - int p = i % history.Length; - sw.WriteLine (history [p]); - } - } - } catch { - // ignore - } - } - - // - // Appends a value to the history - // - public void Append (string s) - { - //Console.WriteLine ("APPENDING {0} head={1} tail={2}", s, head, tail); - history [head] = s; - head = (head+1) % history.Length; - if (head == tail) - tail = (tail+1 % history.Length); - if (count != history.Length) - count++; - //Console.WriteLine ("DONE: head={1} tail={2}", s, head, tail); - } - - // - // Updates the current cursor location with the string, - // to support editing of history items. For the current - // line to participate, an Append must be done before. - // - public void Update (string s) - { - history [cursor] = s; - } - - public void RemoveLast () - { - head = head-1; - if (head < 0) - head = history.Length-1; - } - - public void Accept (string s) - { - int t = head-1; - if (t < 0) - t = history.Length-1; - - history [t] = s; - } - - public bool PreviousAvailable () - { - //Console.WriteLine ("h={0} t={1} cursor={2}", head, tail, cursor); - if (count == 0) - return false; - int next = cursor-1; - if (next < 0) - next = count-1; - - if (next == head) - return false; - - return true; - } - - public bool NextAvailable () - { - if (count == 0) - return false; - int next = (cursor + 1) % history.Length; - if (next == head) - return false; - return true; - } - - - // - // Returns: a string with the previous line contents, or - // nul if there is no data in the history to move to. - // - public string Previous () - { - if (!PreviousAvailable ()) - return null; - - cursor--; - if (cursor < 0) - cursor = history.Length - 1; - - return history [cursor]; - } - - public string Next () - { - if (!NextAvailable ()) - return null; - - cursor = (cursor + 1) % history.Length; - return history [cursor]; - } - - public void CursorToEnd () - { - if (head == tail) - return; - - cursor = head; - } - - public void Dump () - { - Console.WriteLine ("Head={0} Tail={1} Cursor={2} count={3}", head, tail, cursor, count); - for (int i = 0; i < history.Length;i++){ - Console.WriteLine (" {0} {1}: {2}", i == cursor ? "==>" : " ", i, history[i]); - } - //log.Flush (); - } - - public string SearchBackward (string term) - { - for (int i = 0; i < count; i++){ - int slot = cursor-i-1; - if (slot < 0) - slot = history.Length+slot; - if (slot >= history.Length) - slot = 0; - if (history [slot] != null && history [slot].IndexOf (term) != -1){ - cursor = slot; - return history [slot]; - } - } - - return null; - } - - } - } - -#if DEMO - class Demo { - static void Main () - { - LineEditor le = new LineEditor ("foo"); - string s; - - while ((s = le.Edit ("shell> ", "")) != null){ - Console.WriteLine ("----> [{0}]", s); - } - } - } -#endif -} +// +// getline.cs: A command line editor +// +// Authors: +// Miguel de Icaza (miguel@novell.com) +// +// Copyright 2008 Novell, Inc. +// +// Dual-licensed under the terms of the MIT X11 license or the +// Apache License 2.0 +// +// USE -define:DEMO to build this as a standalone file and test it +// +// TODO: +// Enter an error (a = 1); Notice how the prompt is in the wrong line +// This is caused by Stderr not being tracked by System.Console. +// Completion support +// Why is Thread.Interrupt not working? Currently I resort to Abort which is too much. +// +// Limitations in System.Console: +// Console needs SIGWINCH support of some sort +// Console needs a way of updating its position after things have been written +// behind its back (P/Invoke puts for example). +// System.Console needs to get the DELETE character, and report accordingly. +// + +using System; +using System.Text; +using System.IO; +using System.Threading; +using System.Reflection; + +namespace Mono.Terminal { + + public class LineEditor { + + public class Completion { + public string [] Result; + public string Prefix; + + public Completion (string prefix, string [] result) + { + Prefix = prefix; + Result = result; + } + } + + public delegate Completion AutoCompleteHandler (string text, int pos); + + //static StreamWriter log; + + // The text being edited. + StringBuilder text; + + // The text as it is rendered (replaces (char)1 with ^A on display for example). + StringBuilder rendered_text; + + // The prompt specified, and the prompt shown to the user. + string prompt; + string shown_prompt; + + // The current cursor position, indexes into "text", for an index + // into rendered_text, use TextToRenderPos + int cursor; + + // The row where we started displaying data. + int home_row; + + // The maximum length that has been displayed on the screen + int max_rendered; + + // If we are done editing, this breaks the interactive loop + bool done = false; + + // The thread where the Editing started taking place + Thread edit_thread; + + // Our object that tracks history + History history; + + // The contents of the kill buffer (cut/paste in Emacs parlance) + string kill_buffer = ""; + + // The string being searched for + string search; + string last_search; + + // whether we are searching (-1= reverse; 0 = no; 1 = forward) + int searching; + + // The position where we found the match. + int match_at; + + // Used to implement the Kill semantics (multiple Alt-Ds accumulate) + KeyHandler last_handler; + + delegate void KeyHandler (); + + struct Handler { + public ConsoleKeyInfo CKI; + public KeyHandler KeyHandler; + + public Handler (ConsoleKey key, KeyHandler h) + { + CKI = new ConsoleKeyInfo ((char) 0, key, false, false, false); + KeyHandler = h; + } + + public Handler (char c, KeyHandler h) + { + KeyHandler = h; + // Use the "Zoom" as a flag that we only have a character. + CKI = new ConsoleKeyInfo (c, ConsoleKey.Zoom, false, false, false); + } + + public Handler (ConsoleKeyInfo cki, KeyHandler h) + { + CKI = cki; + KeyHandler = h; + } + + public static Handler Control (char c, KeyHandler h) + { + return new Handler ((char) (c - 'A' + 1), h); + } + + public static Handler Alt (char c, ConsoleKey k, KeyHandler h) + { + ConsoleKeyInfo cki = new ConsoleKeyInfo ((char) c, k, false, true, false); + return new Handler (cki, h); + } + } + + /// + /// Invoked when the user requests auto-completion using the tab character + /// + /// + /// The result is null for no values found, an array with a single + /// string, in that case the string should be the text to be inserted + /// for example if the word at pos is "T", the result for a completion + /// of "ToString" should be "oString", not "ToString". + /// + /// When there are multiple results, the result should be the full + /// text + /// + public AutoCompleteHandler AutoCompleteEvent; + + static Handler [] handlers; + + public LineEditor (string name) : this (name, 10) { } + + public LineEditor (string name, int histsize) + { + handlers = new Handler [] { + new Handler (ConsoleKey.Home, CmdHome), + new Handler (ConsoleKey.End, CmdEnd), + new Handler (ConsoleKey.LeftArrow, CmdLeft), + new Handler (ConsoleKey.RightArrow, CmdRight), + new Handler (ConsoleKey.UpArrow, CmdHistoryPrev), + new Handler (ConsoleKey.DownArrow, CmdHistoryNext), + new Handler (ConsoleKey.Enter, CmdDone), + new Handler (ConsoleKey.Backspace, CmdBackspace), + new Handler (ConsoleKey.Delete, CmdDeleteChar), + new Handler (ConsoleKey.Tab, CmdTabOrComplete), + + // Emacs keys + Handler.Control ('A', CmdHome), + Handler.Control ('E', CmdEnd), + Handler.Control ('B', CmdLeft), + Handler.Control ('F', CmdRight), + Handler.Control ('P', CmdHistoryPrev), + Handler.Control ('N', CmdHistoryNext), + Handler.Control ('K', CmdKillToEOF), + Handler.Control ('Y', CmdYank), + Handler.Control ('D', CmdDeleteChar), + Handler.Control ('L', CmdRefresh), + Handler.Control ('R', CmdReverseSearch), + Handler.Control ('G', delegate {} ), + Handler.Alt ('B', ConsoleKey.B, CmdBackwardWord), + Handler.Alt ('F', ConsoleKey.F, CmdForwardWord), + + Handler.Alt ('D', ConsoleKey.D, CmdDeleteWord), + Handler.Alt ((char) 8, ConsoleKey.Backspace, CmdDeleteBackword), + + // DEBUG + //Handler.Control ('T', CmdDebug), + + // quote + Handler.Control ('Q', delegate { HandleChar (Console.ReadKey (true).KeyChar); }) + }; + + rendered_text = new StringBuilder (); + text = new StringBuilder (); + + history = new History (name, histsize); + + //if (File.Exists ("log"))File.Delete ("log"); + //log = File.CreateText ("log"); + } + + void CmdDebug () + { + history.Dump (); + Console.WriteLine (); + Render (); + } + + void Render () + { + Console.Write (shown_prompt); + Console.Write (rendered_text); + + int max = System.Math.Max (rendered_text.Length + shown_prompt.Length, max_rendered); + + for (int i = rendered_text.Length + shown_prompt.Length; i < max_rendered; i++) + Console.Write (' '); + max_rendered = shown_prompt.Length + rendered_text.Length; + + // Write one more to ensure that we always wrap around properly if we are at the + // end of a line. + Console.Write (' '); + + UpdateHomeRow (max); + } + + void UpdateHomeRow (int screenpos) + { + int lines = 1 + (screenpos / Console.WindowWidth); + + home_row = Console.CursorTop - (lines - 1); + if (home_row < 0) + home_row = 0; + } + + + void RenderFrom (int pos) + { + int rpos = TextToRenderPos (pos); + int i; + + for (i = rpos; i < rendered_text.Length; i++) + Console.Write (rendered_text [i]); + + if ((shown_prompt.Length + rendered_text.Length) > max_rendered) + max_rendered = shown_prompt.Length + rendered_text.Length; + else { + int max_extra = max_rendered - shown_prompt.Length; + for (; i < max_extra; i++) + Console.Write (' '); + } + } + + void ComputeRendered () + { + rendered_text.Length = 0; + + for (int i = 0; i < text.Length; i++){ + int c = (int) text [i]; + if (c < 26){ + if (c == '\t') + rendered_text.Append (" "); + else { + rendered_text.Append ('^'); + rendered_text.Append ((char) (c + (int) 'A' - 1)); + } + } else + rendered_text.Append ((char)c); + } + } + + int TextToRenderPos (int pos) + { + int p = 0; + + for (int i = 0; i < pos; i++){ + int c; + + c = (int) text [i]; + + if (c < 26){ + if (c == 9) + p += 4; + else + p += 2; + } else + p++; + } + + return p; + } + + int TextToScreenPos (int pos) + { + return shown_prompt.Length + TextToRenderPos (pos); + } + + string Prompt { + get { return prompt; } + set { prompt = value; } + } + + int LineCount { + get { + return (shown_prompt.Length + rendered_text.Length)/Console.WindowWidth; + } + } + + void ForceCursor (int newpos) + { + cursor = newpos; + + int actual_pos = shown_prompt.Length + TextToRenderPos (cursor); + int row = home_row + (actual_pos/Console.WindowWidth); + int col = actual_pos % Console.WindowWidth; + + if (row >= Console.BufferHeight) + row = Console.BufferHeight-1; + Console.SetCursorPosition (col, row); + + //log.WriteLine ("Going to cursor={0} row={1} col={2} actual={3} prompt={4} ttr={5} old={6}", newpos, row, col, actual_pos, prompt.Length, TextToRenderPos (cursor), cursor); + //log.Flush (); + } + + void UpdateCursor (int newpos) + { + if (cursor == newpos) + return; + + ForceCursor (newpos); + } + + void InsertChar (char c) + { + int prev_lines = LineCount; + text = text.Insert (cursor, c); + ComputeRendered (); + if (prev_lines != LineCount){ + + Console.SetCursorPosition (0, home_row); + Render (); + ForceCursor (++cursor); + } else { + RenderFrom (cursor); + ForceCursor (++cursor); + UpdateHomeRow (TextToScreenPos (cursor)); + } + } + + // + // Commands + // + void CmdDone () + { + done = true; + } + + void CmdTabOrComplete () + { + bool complete = false; + + if (AutoCompleteEvent != null){ + if (TabAtStartCompletes) + complete = true; + else { + for (int i = 0; i < cursor; i++){ + if (!Char.IsWhiteSpace (text [i])){ + complete = true; + break; + } + } + } + + if (complete){ + Completion completion = AutoCompleteEvent (text.ToString (), cursor); + string [] completions = completion.Result; + if (completions == null) + return; + + int ncompletions = completions.Length; + if (ncompletions == 0) + return; + + if (completions.Length == 1){ + InsertTextAtCursor (completions [0]); + } else { + int last = -1; + + for (int p = 0; p < completions [0].Length; p++){ + char c = completions [0][p]; + + + for (int i = 1; i < ncompletions; i++){ + if (completions [i].Length < p) + goto mismatch; + + if (completions [i][p] != c){ + goto mismatch; + } + } + last = p; + } + mismatch: + if (last != -1){ + InsertTextAtCursor (completions [0].Substring (0, last+1)); + } + Console.WriteLine (); + foreach (string s in completions){ + Console.Write (completion.Prefix); + Console.Write (s); + Console.Write (' '); + } + Console.WriteLine (); + Render (); + ForceCursor (cursor); + } + } else + HandleChar ('\t'); + } else + HandleChar ('t'); + } + + void CmdHome () + { + UpdateCursor (0); + } + + void CmdEnd () + { + UpdateCursor (text.Length); + } + + void CmdLeft () + { + if (cursor == 0) + return; + + UpdateCursor (cursor-1); + } + + void CmdBackwardWord () + { + int p = WordBackward (cursor); + if (p == -1) + return; + UpdateCursor (p); + } + + void CmdForwardWord () + { + int p = WordForward (cursor); + if (p == -1) + return; + UpdateCursor (p); + } + + void CmdRight () + { + if (cursor == text.Length) + return; + + UpdateCursor (cursor+1); + } + + void RenderAfter (int p) + { + ForceCursor (p); + RenderFrom (p); + ForceCursor (cursor); + } + + void CmdBackspace () + { + if (cursor == 0) + return; + + text.Remove (--cursor, 1); + ComputeRendered (); + RenderAfter (cursor); + } + + void CmdDeleteChar () + { + // If there is no input, this behaves like EOF + if (text.Length == 0){ + done = true; + text = null; + Console.WriteLine (); + return; + } + + if (cursor == text.Length) + return; + text.Remove (cursor, 1); + ComputeRendered (); + RenderAfter (cursor); + } + + int WordForward (int p) + { + if (p >= text.Length) + return -1; + + int i = p; + if (Char.IsPunctuation (text [p]) || Char.IsSymbol (text [p]) || Char.IsWhiteSpace (text[p])){ + for (; i < text.Length; i++){ + if (Char.IsLetterOrDigit (text [i])) + break; + } + for (; i < text.Length; i++){ + if (!Char.IsLetterOrDigit (text [i])) + break; + } + } else { + for (; i < text.Length; i++){ + if (!Char.IsLetterOrDigit (text [i])) + break; + } + } + if (i != p) + return i; + return -1; + } + + int WordBackward (int p) + { + if (p == 0) + return -1; + + int i = p-1; + if (i == 0) + return 0; + + if (Char.IsPunctuation (text [i]) || Char.IsSymbol (text [i]) || Char.IsWhiteSpace (text[i])){ + for (; i >= 0; i--){ + if (Char.IsLetterOrDigit (text [i])) + break; + } + for (; i >= 0; i--){ + if (!Char.IsLetterOrDigit (text[i])) + break; + } + } else { + for (; i >= 0; i--){ + if (!Char.IsLetterOrDigit (text [i])) + break; + } + } + i++; + + if (i != p) + return i; + + return -1; + } + + void CmdDeleteWord () + { + int pos = WordForward (cursor); + + if (pos == -1) + return; + + string k = text.ToString (cursor, pos-cursor); + + if (last_handler == CmdDeleteWord) + kill_buffer = kill_buffer + k; + else + kill_buffer = k; + + text.Remove (cursor, pos-cursor); + ComputeRendered (); + RenderAfter (cursor); + } + + void CmdDeleteBackword () + { + int pos = WordBackward (cursor); + if (pos == -1) + return; + + string k = text.ToString (pos, cursor-pos); + + if (last_handler == CmdDeleteBackword) + kill_buffer = k + kill_buffer; + else + kill_buffer = k; + + text.Remove (pos, cursor-pos); + ComputeRendered (); + RenderAfter (pos); + } + + // + // Adds the current line to the history if needed + // + void HistoryUpdateLine () + { + history.Update (text.ToString ()); + } + + void CmdHistoryPrev () + { + if (!history.PreviousAvailable ()) + return; + + HistoryUpdateLine (); + + SetText (history.Previous ()); + } + + void CmdHistoryNext () + { + if (!history.NextAvailable()) + return; + + history.Update (text.ToString ()); + SetText (history.Next ()); + + } + + void CmdKillToEOF () + { + kill_buffer = text.ToString (cursor, text.Length-cursor); + text.Length = cursor; + ComputeRendered (); + RenderAfter (cursor); + } + + void CmdYank () + { + InsertTextAtCursor (kill_buffer); + } + + void InsertTextAtCursor (string str) + { + int prev_lines = LineCount; + text.Insert (cursor, str); + ComputeRendered (); + if (prev_lines != LineCount){ + Console.SetCursorPosition (0, home_row); + Render (); + cursor += str.Length; + ForceCursor (cursor); + } else { + RenderFrom (cursor); + cursor += str.Length; + ForceCursor (cursor); + UpdateHomeRow (TextToScreenPos (cursor)); + } + } + + void SetSearchPrompt (string s) + { + SetPrompt ("(reverse-i-search)`" + s + "': "); + } + + void ReverseSearch () + { + int p; + + if (cursor == text.Length){ + // The cursor is at the end of the string + + p = text.ToString ().LastIndexOf (search); + if (p != -1){ + match_at = p; + cursor = p; + ForceCursor (cursor); + return; + } + } else { + // The cursor is somewhere in the middle of the string + int start = (cursor == match_at) ? cursor - 1 : cursor; + if (start != -1){ + p = text.ToString ().LastIndexOf (search, start); + if (p != -1){ + match_at = p; + cursor = p; + ForceCursor (cursor); + return; + } + } + } + + // Need to search backwards in history + HistoryUpdateLine (); + string s = history.SearchBackward (search); + if (s != null){ + match_at = -1; + SetText (s); + ReverseSearch (); + } + } + + void CmdReverseSearch () + { + if (searching == 0){ + match_at = -1; + last_search = search; + searching = -1; + search = ""; + SetSearchPrompt (""); + } else { + if (search == ""){ + if (last_search != "" && last_search != null){ + search = last_search; + SetSearchPrompt (search); + + ReverseSearch (); + } + return; + } + ReverseSearch (); + } + } + + void SearchAppend (char c) + { + search = search + c; + SetSearchPrompt (search); + + // + // If the new typed data still matches the current text, stay here + // + if (cursor < text.Length){ + string r = text.ToString (cursor, text.Length - cursor); + if (r.StartsWith (search)) + return; + } + + ReverseSearch (); + } + + void CmdRefresh () + { + Console.Clear (); + max_rendered = 0; + Render (); + ForceCursor (cursor); + } + + void InterruptEdit (object sender, ConsoleCancelEventArgs a) + { + // Do not abort our program: + a.Cancel = true; + + // Interrupt the editor + edit_thread.Abort(); + } + + void HandleChar (char c) + { + if (searching != 0) + SearchAppend (c); + else + InsertChar (c); + } + + void EditLoop () + { + ConsoleKeyInfo cki; + + while (!done){ + ConsoleModifiers mod; + + cki = Console.ReadKey (true); + if (cki.Key == ConsoleKey.Escape){ + cki = Console.ReadKey (true); + + mod = ConsoleModifiers.Alt; + } else + mod = cki.Modifiers; + + bool handled = false; + + foreach (Handler handler in handlers){ + ConsoleKeyInfo t = handler.CKI; + + if (t.Key == cki.Key && t.Modifiers == mod){ + handled = true; + handler.KeyHandler (); + last_handler = handler.KeyHandler; + break; + } else if (t.KeyChar == cki.KeyChar && t.Key == ConsoleKey.Zoom){ + handled = true; + handler.KeyHandler (); + last_handler = handler.KeyHandler; + break; + } + } + if (handled){ + if (searching != 0){ + if (last_handler != CmdReverseSearch){ + searching = 0; + SetPrompt (prompt); + } + } + continue; + } + + if (cki.KeyChar != (char) 0) + HandleChar (cki.KeyChar); + } + } + + void InitText (string initial) + { + text = new StringBuilder (initial); + ComputeRendered (); + cursor = text.Length; + Render (); + ForceCursor (cursor); + } + + void SetText (string newtext) + { + Console.SetCursorPosition (0, home_row); + InitText (newtext); + } + + void SetPrompt (string newprompt) + { + shown_prompt = newprompt; + Console.SetCursorPosition (0, home_row); + Render (); + ForceCursor (cursor); + } + + public string Edit (string prompt, string initial) + { + edit_thread = Thread.CurrentThread; + searching = 0; + Console.CancelKeyPress += InterruptEdit; + + done = false; + history.CursorToEnd (); + max_rendered = 0; + + Prompt = prompt; + shown_prompt = prompt; + InitText (initial); + history.Append (initial); + + do { + try { + EditLoop (); + } catch (ThreadAbortException){ + searching = 0; + Thread.ResetAbort (); + Console.WriteLine (); + SetPrompt (prompt); + SetText (""); + } + } while (!done); + Console.WriteLine (); + + Console.CancelKeyPress -= InterruptEdit; + + if (text == null){ + history.Close (); + return null; + } + + string result = text.ToString (); + if (result != "") + history.Accept (result); + else + history.RemoveLast (); + + return result; + } + + public void SaveHistory () + { + if (history != null) { + history.Close (); + } + } + + public bool TabAtStartCompletes { get; set; } + + // + // Emulates the bash-like behavior, where edits done to the + // history are recorded + // + class History { + string [] history; + int head, tail; + int cursor, count; + string histfile; + + public History (string app, int size) + { + if (size < 1) + throw new ArgumentException ("size"); + + if (app != null){ + string dir = Environment.GetFolderPath (Environment.SpecialFolder.Personal); + //Console.WriteLine (dir); + /* + if (!Directory.Exists (dir)){ + try { + Directory.CreateDirectory (dir); + } catch { + app = null; + } + } + if (app != null) + histfile = Path.Combine (dir, app) + ".history"; + */ + histfile = Path.Combine (dir, ".mal-history"); + } + + history = new string [size]; + head = tail = cursor = 0; + + if (File.Exists (histfile)){ + using (StreamReader sr = File.OpenText (histfile)){ + string line; + + while ((line = sr.ReadLine ()) != null){ + if (line != "") + Append (line); + } + } + } + } + + public void Close () + { + if (histfile == null) + return; + + try { + using (StreamWriter sw = File.CreateText (histfile)){ + int start = (count == history.Length) ? head : tail; + for (int i = start; i < start+count; i++){ + int p = i % history.Length; + sw.WriteLine (history [p]); + } + } + } catch { + // ignore + } + } + + // + // Appends a value to the history + // + public void Append (string s) + { + //Console.WriteLine ("APPENDING {0} head={1} tail={2}", s, head, tail); + history [head] = s; + head = (head+1) % history.Length; + if (head == tail) + tail = (tail+1 % history.Length); + if (count != history.Length) + count++; + //Console.WriteLine ("DONE: head={1} tail={2}", s, head, tail); + } + + // + // Updates the current cursor location with the string, + // to support editing of history items. For the current + // line to participate, an Append must be done before. + // + public void Update (string s) + { + history [cursor] = s; + } + + public void RemoveLast () + { + head = head-1; + if (head < 0) + head = history.Length-1; + } + + public void Accept (string s) + { + int t = head-1; + if (t < 0) + t = history.Length-1; + + history [t] = s; + } + + public bool PreviousAvailable () + { + //Console.WriteLine ("h={0} t={1} cursor={2}", head, tail, cursor); + if (count == 0) + return false; + int next = cursor-1; + if (next < 0) + next = count-1; + + if (next == head) + return false; + + return true; + } + + public bool NextAvailable () + { + if (count == 0) + return false; + int next = (cursor + 1) % history.Length; + if (next == head) + return false; + return true; + } + + + // + // Returns: a string with the previous line contents, or + // nul if there is no data in the history to move to. + // + public string Previous () + { + if (!PreviousAvailable ()) + return null; + + cursor--; + if (cursor < 0) + cursor = history.Length - 1; + + return history [cursor]; + } + + public string Next () + { + if (!NextAvailable ()) + return null; + + cursor = (cursor + 1) % history.Length; + return history [cursor]; + } + + public void CursorToEnd () + { + if (head == tail) + return; + + cursor = head; + } + + public void Dump () + { + Console.WriteLine ("Head={0} Tail={1} Cursor={2} count={3}", head, tail, cursor, count); + for (int i = 0; i < history.Length;i++){ + Console.WriteLine (" {0} {1}: {2}", i == cursor ? "==>" : " ", i, history[i]); + } + //log.Flush (); + } + + public string SearchBackward (string term) + { + for (int i = 0; i < count; i++){ + int slot = cursor-i-1; + if (slot < 0) + slot = history.Length+slot; + if (slot >= history.Length) + slot = 0; + if (history [slot] != null && history [slot].IndexOf (term) != -1){ + cursor = slot; + return history [slot]; + } + } + + return null; + } + + } + } + +#if DEMO + class Demo { + static void Main () + { + LineEditor le = new LineEditor ("foo"); + string s; + + while ((s = le.Edit ("shell> ", "")) != null){ + Console.WriteLine ("----> [{0}]", s); + } + } + } +#endif +} diff --git a/impls/vb/printer.vb b/impls/vb/printer.vb index 3f3e6e26b8..24c3bdaea8 100644 --- a/impls/vb/printer.vb +++ b/impls/vb/printer.vb @@ -1,52 +1,52 @@ -Imports System -Imports System.Collections.Generic -Imports System.Text.RegularExpressions -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalList = Mal.types.MalList - -Namespace Mal - Public Class printer - Shared Function join(value As List(Of MalVal), - delim As String, - print_readably As Boolean) As String - Dim strs As New List(Of String) - For Each mv As MalVal In value - strs.Add(mv.ToString(print_readably)) - Next - return String.Join(delim, strs.ToArray()) - End Function - - Shared Function join(value As Dictionary(Of String, MalVal), - delim As String, - print_readably As Boolean) As String - Dim strs As New List(Of String) - For Each entry As KeyValuePair(Of String, MalVal) In value - If entry.Key.Length > 0 and entry.Key(0) = ChrW(&H029e) Then - strs.Add(":" & entry.Key.Substring(1)) - Else If print_readably Then - strs.Add("""" & entry.Key.ToString() & """") - Else - strs.Add(entry.Key.ToString()) - End If - strs.Add(entry.Value.ToString(print_readably)) - Next - return String.Join(delim, strs.ToArray()) - End Function - - Shared Function _pr_str(mv As MalVal, - print_readably As Boolean) As String - return mv.ToString(print_readably) - End Function - - Shared Function _pr_str_args(args As MalList, - sep As String, - print_readably As Boolean) As String - return join(args.getValue(), sep, print_readably) - End Function - - Shared Function escapeString(str As String) As String - return Regex.Escape(str) - End Function - End Class -End Namespace +Imports System +Imports System.Collections.Generic +Imports System.Text.RegularExpressions +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalList = Mal.types.MalList + +Namespace Mal + Public Class printer + Shared Function join(value As List(Of MalVal), + delim As String, + print_readably As Boolean) As String + Dim strs As New List(Of String) + For Each mv As MalVal In value + strs.Add(mv.ToString(print_readably)) + Next + return String.Join(delim, strs.ToArray()) + End Function + + Shared Function join(value As Dictionary(Of String, MalVal), + delim As String, + print_readably As Boolean) As String + Dim strs As New List(Of String) + For Each entry As KeyValuePair(Of String, MalVal) In value + If entry.Key.Length > 0 and entry.Key(0) = ChrW(&H029e) Then + strs.Add(":" & entry.Key.Substring(1)) + Else If print_readably Then + strs.Add("""" & entry.Key.ToString() & """") + Else + strs.Add(entry.Key.ToString()) + End If + strs.Add(entry.Value.ToString(print_readably)) + Next + return String.Join(delim, strs.ToArray()) + End Function + + Shared Function _pr_str(mv As MalVal, + print_readably As Boolean) As String + return mv.ToString(print_readably) + End Function + + Shared Function _pr_str_args(args As MalList, + sep As String, + print_readably As Boolean) As String + return join(args.getValue(), sep, print_readably) + End Function + + Shared Function escapeString(str As String) As String + return Regex.Escape(str) + End Function + End Class +End Namespace diff --git a/impls/vb/reader.vb b/impls/vb/reader.vb index 6d30e49a1e..0b2315670c 100644 --- a/impls/vb/reader.vb +++ b/impls/vb/reader.vb @@ -1,187 +1,187 @@ -Imports System -Imports System.Collections -Imports System.Collections.Generic -Imports System.Text.RegularExpressions -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalThrowable = Mal.types.MalThrowable -Imports MalContinue = Mal.types.MalContinue - -Namespace Mal - Public Class reader - Public Class ParseError - Inherits MalThrowable - Public Sub New(msg As String) - MyBase.New(msg) - End Sub - End Class - - Public Class Reader - Private tokens As New List(Of String) - Private position As Int32 = 0 - Sub New(t As List(Of String)) - tokens = t - position = 0 - End Sub - - Public Function peek() As String - If position >= tokens.Count Then - return Nothing - Else - return tokens(position) - End If - End Function - - Public Function get_next() As String - If position >= tokens.Count Then - return Nothing - Else - position += 1 - return tokens(position-1) - End If - End Function - End Class - - Shared Function tokenize(str As String) As List(Of String) - Dim tokens As New List(Of String) - Dim pattern As String = "[\s ,]*(~@|[\[\]{}()'`~@]|""(?:[\\].|[^\\""])*""?|;.*|[^\s \[\]{}()'""`~@,;]*)" - Dim regex As New Regex(pattern) - For Each match As Match In regex.Matches(str) - Dim token As String = match.Groups(1).Value - If Not token Is Nothing _ - AndAlso Not token = "" _ - AndAlso Not token(0) = ";" Then - 'Console.WriteLine("match: ^" & match.Groups[1] & "$") - tokens.Add(token) - End If - Next - return tokens - End Function - - Shared Function read_atom(rdr As Reader) As MalVal - Dim token As String = rdr.get_next() - Dim pattern As String = "(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|(^""(?:[\\].|[^\\""])*""$)|^("".*)|^:(.*)|(^[^""]*$)" - Dim regex As Regex = New Regex(pattern) - Dim match As Match = regex.Match(token) - 'Console.WriteLine("token: ^" + token + "$") - If not match.Success Then - throw New ParseError("unrecognized token '" & token & "'") - End If - If match.Groups(1).Value <> String.Empty Then - return New Mal.types.MalInt(Integer.Parse(match.Groups(1).Value)) - Else If match.Groups(3).Value <> String.Empty Then - return Mal.types.Nil - Else If match.Groups(4).Value <> String.Empty Then - return Mal.types.MalTrue - Else If match.Groups(5).Value <> String.Empty Then - return Mal.types.MalFalse - Else If match.Groups(6).Value <> String.Empty Then - Dim str As String = match.Groups(6).Value - return New Mal.types.MalString( - str.Substring(1, str.Length-2) _ - .Replace("\\", ChrW(&H029e)) _ - .Replace("\""", """") _ - .Replace("\n", Environment.NewLine) _ - .Replace(ChrW(&H029e), "\")) - Else If match.Groups(7).Value <> String.Empty Then - throw New ParseError("expected '""', got EOF") - Else If match.Groups(8).Value <> String.Empty Then - return New Mal.types.MalString(ChrW(&H029e) & match.Groups(8).Value) - Else If match.Groups(9).Value <> String.Empty Then - return New Mal.types.MalSymbol(match.Groups(9).Value) - Else - throw New ParseError("unrecognized '" & match.Groups(0).Value & "'") - End If - End Function - - Shared Function read_list(rdr As Reader, lst As MalList, - start As String, last As String) As MalVal - Dim token As String = rdr.get_next() - If token(0) <> start Then - throw New ParseError("expected '" & start & "'") - End If - - token = rdr.peek() - While token IsNot Nothing AndAlso token(0) <> last - lst.conj_BANG(read_form(rdr)) - token = rdr.peek() - End While - - If token Is Nothing Then - throw New ParseError("expected '" & last & "', got EOF") - End If - rdr.get_next() - - return lst - End Function - - Shared Function read_hash_map(rdr As Reader) As MalVal - Dim lst As MalList = DirectCast(read_list(rdr, new MalList(), - "{", "}"),MalList) - return New MalHashMap(lst) - End Function - - - Shared Function read_form(rdr As Reader) As MalVal - Dim token As String = rdr.peek() - If token Is Nothing Then - throw New MalContinue() - End If - Dim form As MalVal = Nothing - - Select token - Case "'" - rdr.get_next() - return New MalList(New MalSymbol("quote"), - read_form(rdr)) - Case "`" - rdr.get_next() - return New MalList(New MalSymbol("quasiquote"), - read_form(rdr)) - Case "~" - rdr.get_next() - return New MalList(New MalSymbol("unquote"), - read_form(rdr)) - Case "~@" - rdr.get_next() - return new MalList(New MalSymbol("splice-unquote"), - read_form(rdr)) - Case "^" - rdr.get_next() - Dim meta As MalVal = read_form(rdr) - return new MalList(New MalSymbol("with-meta"), - read_form(rdr), - meta) - Case "@" - rdr.get_next() - return new MalList(New MalSymbol("deref"), - read_form(rdr)) - - Case "(" - form = read_list(rdr, New MalList(), "(" , ")") - Case ")" - throw New ParseError("unexpected ')'") - Case "[" - form = read_list(rdr, New MalVector(), "[" , "]") - Case "]" - throw New ParseError("unexpected ']'") - Case "{" - form = read_hash_map(rdr) - Case "}" - throw New ParseError("unexpected '}'") - Case Else - form = read_atom(rdr) - End Select - return form - End Function - - - Shared Function read_str(str As string) As MalVal - return read_form(New Reader(tokenize(str))) - End Function - End Class -End Namespace +Imports System +Imports System.Collections +Imports System.Collections.Generic +Imports System.Text.RegularExpressions +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalThrowable = Mal.types.MalThrowable +Imports MalContinue = Mal.types.MalContinue + +Namespace Mal + Public Class reader + Public Class ParseError + Inherits MalThrowable + Public Sub New(msg As String) + MyBase.New(msg) + End Sub + End Class + + Public Class Reader + Private tokens As New List(Of String) + Private position As Int32 = 0 + Sub New(t As List(Of String)) + tokens = t + position = 0 + End Sub + + Public Function peek() As String + If position >= tokens.Count Then + return Nothing + Else + return tokens(position) + End If + End Function + + Public Function get_next() As String + If position >= tokens.Count Then + return Nothing + Else + position += 1 + return tokens(position-1) + End If + End Function + End Class + + Shared Function tokenize(str As String) As List(Of String) + Dim tokens As New List(Of String) + Dim pattern As String = "[\s ,]*(~@|[\[\]{}()'`~@]|""(?:[\\].|[^\\""])*""?|;.*|[^\s \[\]{}()'""`~@,;]*)" + Dim regex As New Regex(pattern) + For Each match As Match In regex.Matches(str) + Dim token As String = match.Groups(1).Value + If Not token Is Nothing _ + AndAlso Not token = "" _ + AndAlso Not token(0) = ";" Then + 'Console.WriteLine("match: ^" & match.Groups[1] & "$") + tokens.Add(token) + End If + Next + return tokens + End Function + + Shared Function read_atom(rdr As Reader) As MalVal + Dim token As String = rdr.get_next() + Dim pattern As String = "(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|(^""(?:[\\].|[^\\""])*""$)|^("".*)|^:(.*)|(^[^""]*$)" + Dim regex As Regex = New Regex(pattern) + Dim match As Match = regex.Match(token) + 'Console.WriteLine("token: ^" + token + "$") + If not match.Success Then + throw New ParseError("unrecognized token '" & token & "'") + End If + If match.Groups(1).Value <> String.Empty Then + return New Mal.types.MalInt(Integer.Parse(match.Groups(1).Value)) + Else If match.Groups(3).Value <> String.Empty Then + return Mal.types.Nil + Else If match.Groups(4).Value <> String.Empty Then + return Mal.types.MalTrue + Else If match.Groups(5).Value <> String.Empty Then + return Mal.types.MalFalse + Else If match.Groups(6).Value <> String.Empty Then + Dim str As String = match.Groups(6).Value + return New Mal.types.MalString( + str.Substring(1, str.Length-2) _ + .Replace("\\", ChrW(&H029e)) _ + .Replace("\""", """") _ + .Replace("\n", Environment.NewLine) _ + .Replace(ChrW(&H029e), "\")) + Else If match.Groups(7).Value <> String.Empty Then + throw New ParseError("expected '""', got EOF") + Else If match.Groups(8).Value <> String.Empty Then + return New Mal.types.MalString(ChrW(&H029e) & match.Groups(8).Value) + Else If match.Groups(9).Value <> String.Empty Then + return New Mal.types.MalSymbol(match.Groups(9).Value) + Else + throw New ParseError("unrecognized '" & match.Groups(0).Value & "'") + End If + End Function + + Shared Function read_list(rdr As Reader, lst As MalList, + start As String, last As String) As MalVal + Dim token As String = rdr.get_next() + If token(0) <> start Then + throw New ParseError("expected '" & start & "'") + End If + + token = rdr.peek() + While token IsNot Nothing AndAlso token(0) <> last + lst.conj_BANG(read_form(rdr)) + token = rdr.peek() + End While + + If token Is Nothing Then + throw New ParseError("expected '" & last & "', got EOF") + End If + rdr.get_next() + + return lst + End Function + + Shared Function read_hash_map(rdr As Reader) As MalVal + Dim lst As MalList = DirectCast(read_list(rdr, new MalList(), + "{", "}"),MalList) + return New MalHashMap(lst) + End Function + + + Shared Function read_form(rdr As Reader) As MalVal + Dim token As String = rdr.peek() + If token Is Nothing Then + throw New MalContinue() + End If + Dim form As MalVal = Nothing + + Select token + Case "'" + rdr.get_next() + return New MalList(New MalSymbol("quote"), + read_form(rdr)) + Case "`" + rdr.get_next() + return New MalList(New MalSymbol("quasiquote"), + read_form(rdr)) + Case "~" + rdr.get_next() + return New MalList(New MalSymbol("unquote"), + read_form(rdr)) + Case "~@" + rdr.get_next() + return new MalList(New MalSymbol("splice-unquote"), + read_form(rdr)) + Case "^" + rdr.get_next() + Dim meta As MalVal = read_form(rdr) + return new MalList(New MalSymbol("with-meta"), + read_form(rdr), + meta) + Case "@" + rdr.get_next() + return new MalList(New MalSymbol("deref"), + read_form(rdr)) + + Case "(" + form = read_list(rdr, New MalList(), "(" , ")") + Case ")" + throw New ParseError("unexpected ')'") + Case "[" + form = read_list(rdr, New MalVector(), "[" , "]") + Case "]" + throw New ParseError("unexpected ']'") + Case "{" + form = read_hash_map(rdr) + Case "}" + throw New ParseError("unexpected '}'") + Case Else + form = read_atom(rdr) + End Select + return form + End Function + + + Shared Function read_str(str As string) As MalVal + return read_form(New Reader(tokenize(str))) + End Function + End Class +End Namespace diff --git a/impls/vb/readline.vb b/impls/vb/readline.vb index 74047ce500..161bf903d7 100644 --- a/impls/vb/readline.vb +++ b/impls/vb/readline.vb @@ -1,32 +1,32 @@ -Imports System -Imports Mono.Terminal ' LineEditor (getline.cs) - -Namespace Mal - Public Class readline - Enum Modes - Terminal - Raw - End Enum - - Public Shared mode As Modes = Modes.Terminal - - Shared lineedit As LineEditor = Nothing - - Public Shared Sub SetMode(new_mode As Modes) - mode = new_mode - End Sub - - Public Shared Function Readline(prompt As String) As String - If mode = Modes.Terminal Then - If lineedit Is Nothing Then - lineedit = New LineEditor("Mal") - End If - return lineedit.Edit(prompt, "") - Else - Console.Write(prompt) - Console.Out.Flush() - return Console.ReadLine() - End If - End Function - End Class -End Namespace +Imports System +Imports Mono.Terminal ' LineEditor (getline.cs) + +Namespace Mal + Public Class readline + Enum Modes + Terminal + Raw + End Enum + + Public Shared mode As Modes = Modes.Terminal + + Shared lineedit As LineEditor = Nothing + + Public Shared Sub SetMode(new_mode As Modes) + mode = new_mode + End Sub + + Public Shared Function Readline(prompt As String) As String + If mode = Modes.Terminal Then + If lineedit Is Nothing Then + lineedit = New LineEditor("Mal") + End If + return lineedit.Edit(prompt, "") + Else + Console.Write(prompt) + Console.Out.Flush() + return Console.ReadLine() + End If + End Function + End Class +End Namespace diff --git a/impls/vb/run b/impls/vb/run index fa517a6ec7..6292af1203 100755 --- a/impls/vb/run +++ b/impls/vb/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec mono $(dirname $0)/${STEP:-stepA_mal}.exe ${RAW:+--raw} "${@}" +#!/bin/bash +exec mono $(dirname $0)/${STEP:-stepA_mal}.exe ${RAW:+--raw} "${@}" diff --git a/impls/vb/step0_repl.vb b/impls/vb/step0_repl.vb index 3880598523..379e243404 100644 --- a/impls/vb/step0_repl.vb +++ b/impls/vb/step0_repl.vb @@ -1,48 +1,48 @@ -Imports System -Imports Mal - -Namespace Mal - Class step0_repl - ' read - Shared Function READ(str As String) As String - Return str - End Function - - ' eval - Shared Function EVAL(ast As String, env As String) As String - Return ast - End Function - - ' print - Shared Function PRINT(exp As String) As String - Return exp - End Function - - ' repl - Shared Function REP(str As String, env As String) As String - Return PRINT(EVAL(READ(str), env)) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - End If - - ' repl loop - Dim line As String - Do - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Console.WriteLine(REP(line, "")) - Loop While True - Return 0 - End function - End Class -End Namespace +Imports System +Imports Mal + +Namespace Mal + Class step0_repl + ' read + Shared Function READ(str As String) As String + Return str + End Function + + ' eval + Shared Function EVAL(ast As String, env As String) As String + Return ast + End Function + + ' print + Shared Function PRINT(exp As String) As String + Return exp + End Function + + ' repl + Shared Function REP(str As String, env As String) As String + Return PRINT(EVAL(READ(str), env)) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + End If + + ' repl loop + Dim line As String + Do + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Console.WriteLine(REP(line, "")) + Loop While True + Return 0 + End function + End Class +End Namespace diff --git a/impls/vb/step1_read_print.vb b/impls/vb/step1_read_print.vb index 2734973077..8db3a18afb 100644 --- a/impls/vb/step1_read_print.vb +++ b/impls/vb/step1_read_print.vb @@ -1,59 +1,59 @@ -Imports System -Imports System.IO -Imports Mal -Imports MalVal = Mal.types.MalVal - -Namespace Mal - Class step1_read_print - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function EVAL(ast As MalVal, env As String) As MalVal - Return ast - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), "")) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - End If - - ' repl loop - Dim line As String - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e as Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports Mal +Imports MalVal = Mal.types.MalVal + +Namespace Mal + Class step1_read_print + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function EVAL(ast As MalVal, env As String) As MalVal + Return ast + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), "")) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + End If + + ' repl loop + Dim line As String + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e as Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/step2_eval.vb b/impls/vb/step2_eval.vb index 6e45efe85f..3fccea6ed8 100644 --- a/impls/vb/step2_eval.vb +++ b/impls/vb/step2_eval.vb @@ -1,134 +1,134 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalInt = Mal.types.MalInt -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalFunc = Mal.types.MalFunc - -Namespace Mal - Class step2_eval - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function eval_ast(ast As MalVal, env As Dictionary(Of String, MalVal)) As MalVal - If TypeOf ast Is MalSymbol Then - Dim sym As MalSymbol = DirectCast(ast, MalSymbol) - return env.Item(sym.getName()) - Else If TypeOf ast Is MalList Then - Dim old_lst As MalList = DirectCast(ast, MalList) - Dim new_lst As MalList - If ast.list_Q() Then - new_lst = New MalList - Else - new_lst = DirectCast(New MalVector, MalList) - End If - Dim mv As MalVal - For Each mv in old_lst.getValue() - new_lst.conj_BANG(EVAL(mv, env)) - Next - return new_lst - Else If TypeOf ast Is MalHashMap Then - Dim new_dict As New Dictionary(Of String, MalVal) - Dim entry As KeyValuePair(Of String, MalVal) - For Each entry in DirectCast(ast,MalHashMap).getValue() - new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) - Next - return New MalHashMap(new_dict) - Else - return ast - End If - return ast - End Function - - Shared Function EVAL(orig_ast As MalVal, env As Dictionary(Of String, MalVal)) As MalVal - 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) - If not orig_ast.list_Q() Then - return eval_ast(orig_ast, env) - End If - - ' apply list - Dim ast As MalList = DirectCast(orig_ast, MalList) - If ast.size() = 0 Then - return ast - End If - Dim a0 As MalVal = ast(0) - Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) - Dim f As MalFunc = DirectCast(el(0), MalFunc) - Return f.apply(el.rest()) - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared repl_env As Dictionary(Of String, MalVal) - - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), repl_env)) - End Function - - Shared Function add(a As MalList) As MalVal - Return DirectCast(a.Item(0),MalInt) + DirectCast(a.Item(1),MalInt) - End Function - - Shared Function minus(a As MalList) As MalVal - Return DirectCast(a.Item(0),MalInt) - DirectCast(a.Item(1),MalInt) - End Function - - Shared Function mult(a As MalList) As MalVal - Return DirectCast(a.Item(0),MalInt) * DirectCast(a.Item(1),MalInt) - End Function - - Shared Function div(a As MalList) As MalVal - Return DirectCast(a.Item(0),MalInt) / DirectCast(a.Item(1),MalInt) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - repl_env = New Dictionary(Of String, MalVal) - repl_env.Add("+", New MalFunc(AddressOf add)) - repl_env.Add("-", New MalFunc(AddressOf minus)) - repl_env.Add("*", New MalFunc(AddressOf mult)) - repl_env.Add("/", New MalFunc(AddressOf div)) - - - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - End If - - ' repl loop - Dim line As String - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e as Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalInt = Mal.types.MalInt +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalFunc = Mal.types.MalFunc + +Namespace Mal + Class step2_eval + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function eval_ast(ast As MalVal, env As Dictionary(Of String, MalVal)) As MalVal + If TypeOf ast Is MalSymbol Then + Dim sym As MalSymbol = DirectCast(ast, MalSymbol) + return env.Item(sym.getName()) + Else If TypeOf ast Is MalList Then + Dim old_lst As MalList = DirectCast(ast, MalList) + Dim new_lst As MalList + If ast.list_Q() Then + new_lst = New MalList + Else + new_lst = DirectCast(New MalVector, MalList) + End If + Dim mv As MalVal + For Each mv in old_lst.getValue() + new_lst.conj_BANG(EVAL(mv, env)) + Next + return new_lst + Else If TypeOf ast Is MalHashMap Then + Dim new_dict As New Dictionary(Of String, MalVal) + Dim entry As KeyValuePair(Of String, MalVal) + For Each entry in DirectCast(ast,MalHashMap).getValue() + new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) + Next + return New MalHashMap(new_dict) + Else + return ast + End If + return ast + End Function + + Shared Function EVAL(orig_ast As MalVal, env As Dictionary(Of String, MalVal)) As MalVal + 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) + If not orig_ast.list_Q() Then + return eval_ast(orig_ast, env) + End If + + ' apply list + Dim ast As MalList = DirectCast(orig_ast, MalList) + If ast.size() = 0 Then + return ast + End If + Dim a0 As MalVal = ast(0) + Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) + Dim f As MalFunc = DirectCast(el(0), MalFunc) + Return f.apply(el.rest()) + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared repl_env As Dictionary(Of String, MalVal) + + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), repl_env)) + End Function + + Shared Function add(a As MalList) As MalVal + Return DirectCast(a.Item(0),MalInt) + DirectCast(a.Item(1),MalInt) + End Function + + Shared Function minus(a As MalList) As MalVal + Return DirectCast(a.Item(0),MalInt) - DirectCast(a.Item(1),MalInt) + End Function + + Shared Function mult(a As MalList) As MalVal + Return DirectCast(a.Item(0),MalInt) * DirectCast(a.Item(1),MalInt) + End Function + + Shared Function div(a As MalList) As MalVal + Return DirectCast(a.Item(0),MalInt) / DirectCast(a.Item(1),MalInt) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + repl_env = New Dictionary(Of String, MalVal) + repl_env.Add("+", New MalFunc(AddressOf add)) + repl_env.Add("-", New MalFunc(AddressOf minus)) + repl_env.Add("*", New MalFunc(AddressOf mult)) + repl_env.Add("/", New MalFunc(AddressOf div)) + + + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + End If + + ' repl loop + Dim line As String + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e as Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/step3_env.vb b/impls/vb/step3_env.vb index dfee614b74..46faeb69b4 100644 --- a/impls/vb/step3_env.vb +++ b/impls/vb/step3_env.vb @@ -1,155 +1,155 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalInt = Mal.types.MalInt -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalFunc = Mal.types.MalFunc -Imports MalEnv = Mal.env.Env - -Namespace Mal - Class step3_env - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal - If TypeOf ast Is MalSymbol Then - return env.do_get(DirectCast(ast, MalSymbol)) - Else If TypeOf ast Is MalList Then - Dim old_lst As MalList = DirectCast(ast, MalList) - Dim new_lst As MalList - If ast.list_Q() Then - new_lst = New MalList - Else - new_lst = DirectCast(New MalVector, MalList) - End If - Dim mv As MalVal - For Each mv in old_lst.getValue() - new_lst.conj_BANG(EVAL(mv, env)) - Next - return new_lst - Else If TypeOf ast Is MalHashMap Then - Dim new_dict As New Dictionary(Of String, MalVal) - Dim entry As KeyValuePair(Of String, MalVal) - For Each entry in DirectCast(ast,MalHashMap).getValue() - new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) - Next - return New MalHashMap(new_dict) - Else - return ast - End If - return ast - End Function - - Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal - 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) - If not orig_ast.list_Q() Then - return eval_ast(orig_ast, env) - End If - - ' apply list - Dim ast As MalList = DirectCast(orig_ast, MalList) - If ast.size() = 0 Then - return ast - End If - Dim a0 As MalVal = ast(0) - Select DirectCast(a0,MalSymbol).getName() - Case "def!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "let*" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim key As MalSymbol - Dim val as MalVal - Dim let_env As new MalEnv(env) - For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 - key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) - val = DirectCast(a1,MalList)(i+1) - let_env.do_set(key, EVAL(val, let_env)) - Next - return EVAL(a2, let_env) - Case Else - Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) - Dim f As MalFunc = DirectCast(el(0), MalFunc) - Return f.apply(el.rest()) - End Select - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared repl_env As MalEnv - - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), repl_env)) - End Function - - Shared Function add(a As MalList) As MalVal - Return DirectCast(a.Item(0),MalInt) + DirectCast(a.Item(1),MalInt) - End Function - - Shared Function minus(a As MalList) As MalVal - Return DirectCast(a.Item(0),MalInt) - DirectCast(a.Item(1),MalInt) - End Function - - Shared Function mult(a As MalList) As MalVal - Return DirectCast(a.Item(0),MalInt) * DirectCast(a.Item(1),MalInt) - End Function - - Shared Function div(a As MalList) As MalVal - Return DirectCast(a.Item(0),MalInt) / DirectCast(a.Item(1),MalInt) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - repl_env = New MalEnv(Nothing) - repl_env.do_set(new MalSymbol("+"), New MalFunc(AddressOf add)) - repl_env.do_set(new MalSymbol("-"), New MalFunc(AddressOf minus)) - repl_env.do_set(new MalSymbol("*"), New MalFunc(AddressOf mult)) - repl_env.do_set(new MalSymbol("/"), New MalFunc(AddressOf div)) - - - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - End If - - ' repl loop - Dim line As String - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e as Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalInt = Mal.types.MalInt +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalFunc = Mal.types.MalFunc +Imports MalEnv = Mal.env.Env + +Namespace Mal + Class step3_env + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal + If TypeOf ast Is MalSymbol Then + return env.do_get(DirectCast(ast, MalSymbol)) + Else If TypeOf ast Is MalList Then + Dim old_lst As MalList = DirectCast(ast, MalList) + Dim new_lst As MalList + If ast.list_Q() Then + new_lst = New MalList + Else + new_lst = DirectCast(New MalVector, MalList) + End If + Dim mv As MalVal + For Each mv in old_lst.getValue() + new_lst.conj_BANG(EVAL(mv, env)) + Next + return new_lst + Else If TypeOf ast Is MalHashMap Then + Dim new_dict As New Dictionary(Of String, MalVal) + Dim entry As KeyValuePair(Of String, MalVal) + For Each entry in DirectCast(ast,MalHashMap).getValue() + new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) + Next + return New MalHashMap(new_dict) + Else + return ast + End If + return ast + End Function + + Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal + 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) + If not orig_ast.list_Q() Then + return eval_ast(orig_ast, env) + End If + + ' apply list + Dim ast As MalList = DirectCast(orig_ast, MalList) + If ast.size() = 0 Then + return ast + End If + Dim a0 As MalVal = ast(0) + Select DirectCast(a0,MalSymbol).getName() + Case "def!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "let*" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim key As MalSymbol + Dim val as MalVal + Dim let_env As new MalEnv(env) + For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 + key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) + val = DirectCast(a1,MalList)(i+1) + let_env.do_set(key, EVAL(val, let_env)) + Next + return EVAL(a2, let_env) + Case Else + Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) + Dim f As MalFunc = DirectCast(el(0), MalFunc) + Return f.apply(el.rest()) + End Select + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared repl_env As MalEnv + + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), repl_env)) + End Function + + Shared Function add(a As MalList) As MalVal + Return DirectCast(a.Item(0),MalInt) + DirectCast(a.Item(1),MalInt) + End Function + + Shared Function minus(a As MalList) As MalVal + Return DirectCast(a.Item(0),MalInt) - DirectCast(a.Item(1),MalInt) + End Function + + Shared Function mult(a As MalList) As MalVal + Return DirectCast(a.Item(0),MalInt) * DirectCast(a.Item(1),MalInt) + End Function + + Shared Function div(a As MalList) As MalVal + Return DirectCast(a.Item(0),MalInt) / DirectCast(a.Item(1),MalInt) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + repl_env = New MalEnv(Nothing) + repl_env.do_set(new MalSymbol("+"), New MalFunc(AddressOf add)) + repl_env.do_set(new MalSymbol("-"), New MalFunc(AddressOf minus)) + repl_env.do_set(new MalSymbol("*"), New MalFunc(AddressOf mult)) + repl_env.do_set(new MalSymbol("/"), New MalFunc(AddressOf div)) + + + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + End If + + ' repl loop + Dim line As String + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e as Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/step4_if_fn_do.vb b/impls/vb/step4_if_fn_do.vb index 470ae86661..8d4dcd2841 100644 --- a/impls/vb/step4_if_fn_do.vb +++ b/impls/vb/step4_if_fn_do.vb @@ -1,188 +1,188 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalInt = Mal.types.MalInt -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalFunc = Mal.types.MalFunc -Imports MalEnv = Mal.env.Env - -Namespace Mal - Class step4_if_fn_do - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal - If TypeOf ast Is MalSymbol Then - return env.do_get(DirectCast(ast, MalSymbol)) - Else If TypeOf ast Is MalList Then - Dim old_lst As MalList = DirectCast(ast, MalList) - Dim new_lst As MalList - If ast.list_Q() Then - new_lst = New MalList - Else - new_lst = DirectCast(New MalVector, MalList) - End If - Dim mv As MalVal - For Each mv in old_lst.getValue() - new_lst.conj_BANG(EVAL(mv, env)) - Next - return new_lst - Else If TypeOf ast Is MalHashMap Then - Dim new_dict As New Dictionary(Of String, MalVal) - Dim entry As KeyValuePair(Of String, MalVal) - For Each entry in DirectCast(ast,MalHashMap).getValue() - new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) - Next - return New MalHashMap(new_dict) - Else - return ast - End If - return ast - End Function - - ' TODO: move to types.vb when it is ported - Class FClosure - Public ast As MalVal - Public params As MalList - Public env As MalEnv - Function fn(args as MalList) As MalVal - return EVAL(ast, new MalEnv(env, params, args)) - End Function - End Class - - Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal - 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) - If not orig_ast.list_Q() Then - return eval_ast(orig_ast, env) - End If - - ' apply list - Dim ast As MalList = DirectCast(orig_ast, MalList) - If ast.size() = 0 Then - return ast - End If - Dim a0 As MalVal = ast(0) - Dim a0sym As String - If TypeOf a0 is MalSymbol Then - a0sym = DirectCast(a0,MalSymbol).getName() - Else - a0sym = "__<*fn*>__" - End If - - Select a0sym - Case "def!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "let*" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim key As MalSymbol - Dim val as MalVal - Dim let_env As new MalEnv(env) - For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 - key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) - val = DirectCast(a1,MalList)(i+1) - let_env.do_set(key, EVAL(val, let_env)) - Next - return EVAL(a2, let_env) - Case "do" - Dim el As MalList = DirectCast(eval_ast(ast.rest(), env), _ - MalLIst) - return el(el.size()-1) - Case "if" - Dim a1 As MalVal = ast(1) - Dim cond As MalVal = EVAL(a1, env) - If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then - ' eval false slot form - If ast.size() > 3 Then - Dim a3 As MalVal = ast(3) - return EVAL(a3, env) - Else - return Mal.types.Nil - End If - Else - ' eval true slot form - Dim a2 As MalVal = ast(2) - return EVAL(a2, env) - - End If - Case "fn*" - Dim fc As New FClosure() - fc.ast = ast(2) - fc.params = DirectCast(ast(1),MalLIst) - fc.env = env - Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn - Dim mf As new MalFunc(f) - return DirectCast(mf,MalVal) - Case Else - Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) - Dim f As MalFunc = DirectCast(el(0), MalFunc) - Return f.apply(el.rest()) - End Select - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared repl_env As MalEnv - - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), repl_env)) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - repl_env = New MalEnv(Nothing) - - ' core.vb: defined using VB.NET - For Each entry As KeyValuePair(Of String,MalVal) In core.ns() - repl_env.do_set(new MalSymbol(entry.Key), entry.Value) - Next - - ' core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - End If - - ' repl loop - Dim line As String - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e as Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalInt = Mal.types.MalInt +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalFunc = Mal.types.MalFunc +Imports MalEnv = Mal.env.Env + +Namespace Mal + Class step4_if_fn_do + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal + If TypeOf ast Is MalSymbol Then + return env.do_get(DirectCast(ast, MalSymbol)) + Else If TypeOf ast Is MalList Then + Dim old_lst As MalList = DirectCast(ast, MalList) + Dim new_lst As MalList + If ast.list_Q() Then + new_lst = New MalList + Else + new_lst = DirectCast(New MalVector, MalList) + End If + Dim mv As MalVal + For Each mv in old_lst.getValue() + new_lst.conj_BANG(EVAL(mv, env)) + Next + return new_lst + Else If TypeOf ast Is MalHashMap Then + Dim new_dict As New Dictionary(Of String, MalVal) + Dim entry As KeyValuePair(Of String, MalVal) + For Each entry in DirectCast(ast,MalHashMap).getValue() + new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) + Next + return New MalHashMap(new_dict) + Else + return ast + End If + return ast + End Function + + ' TODO: move to types.vb when it is ported + Class FClosure + Public ast As MalVal + Public params As MalList + Public env As MalEnv + Function fn(args as MalList) As MalVal + return EVAL(ast, new MalEnv(env, params, args)) + End Function + End Class + + Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal + 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) + If not orig_ast.list_Q() Then + return eval_ast(orig_ast, env) + End If + + ' apply list + Dim ast As MalList = DirectCast(orig_ast, MalList) + If ast.size() = 0 Then + return ast + End If + Dim a0 As MalVal = ast(0) + Dim a0sym As String + If TypeOf a0 is MalSymbol Then + a0sym = DirectCast(a0,MalSymbol).getName() + Else + a0sym = "__<*fn*>__" + End If + + Select a0sym + Case "def!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "let*" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim key As MalSymbol + Dim val as MalVal + Dim let_env As new MalEnv(env) + For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 + key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) + val = DirectCast(a1,MalList)(i+1) + let_env.do_set(key, EVAL(val, let_env)) + Next + return EVAL(a2, let_env) + Case "do" + Dim el As MalList = DirectCast(eval_ast(ast.rest(), env), _ + MalLIst) + return el(el.size()-1) + Case "if" + Dim a1 As MalVal = ast(1) + Dim cond As MalVal = EVAL(a1, env) + If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then + ' eval false slot form + If ast.size() > 3 Then + Dim a3 As MalVal = ast(3) + return EVAL(a3, env) + Else + return Mal.types.Nil + End If + Else + ' eval true slot form + Dim a2 As MalVal = ast(2) + return EVAL(a2, env) + + End If + Case "fn*" + Dim fc As New FClosure() + fc.ast = ast(2) + fc.params = DirectCast(ast(1),MalLIst) + fc.env = env + Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn + Dim mf As new MalFunc(f) + return DirectCast(mf,MalVal) + Case Else + Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) + Dim f As MalFunc = DirectCast(el(0), MalFunc) + Return f.apply(el.rest()) + End Select + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared repl_env As MalEnv + + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), repl_env)) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + repl_env = New MalEnv(Nothing) + + ' core.vb: defined using VB.NET + For Each entry As KeyValuePair(Of String,MalVal) In core.ns() + repl_env.do_set(new MalSymbol(entry.Key), entry.Value) + Next + + ' core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + End If + + ' repl loop + Dim line As String + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e as Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/step5_tco.vb b/impls/vb/step5_tco.vb index bb36b22bbf..51082ce829 100644 --- a/impls/vb/step5_tco.vb +++ b/impls/vb/step5_tco.vb @@ -1,197 +1,197 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalInt = Mal.types.MalInt -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalFunc = Mal.types.MalFunc -Imports MalEnv = Mal.env.Env - -Namespace Mal - Class step5_tco - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal - If TypeOf ast Is MalSymbol Then - return env.do_get(DirectCast(ast, MalSymbol)) - Else If TypeOf ast Is MalList Then - Dim old_lst As MalList = DirectCast(ast, MalList) - Dim new_lst As MalList - If ast.list_Q() Then - new_lst = New MalList - Else - new_lst = DirectCast(New MalVector, MalList) - End If - Dim mv As MalVal - For Each mv in old_lst.getValue() - new_lst.conj_BANG(EVAL(mv, env)) - Next - return new_lst - Else If TypeOf ast Is MalHashMap Then - Dim new_dict As New Dictionary(Of String, MalVal) - Dim entry As KeyValuePair(Of String, MalVal) - For Each entry in DirectCast(ast,MalHashMap).getValue() - new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) - Next - return New MalHashMap(new_dict) - Else - return ast - End If - return ast - End Function - - ' TODO: move to types.vb when it is ported - Class FClosure - Public ast As MalVal - Public params As MalList - Public env As MalEnv - Function fn(args as MalList) As MalVal - return EVAL(ast, new MalEnv(env, params, args)) - End Function - End Class - - Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal - Do - - 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) - If not orig_ast.list_Q() Then - return eval_ast(orig_ast, env) - End If - - ' apply list - Dim ast As MalList = DirectCast(orig_ast, MalList) - If ast.size() = 0 Then - return ast - End If - Dim a0 As MalVal = ast(0) - Dim a0sym As String - If TypeOf a0 is MalSymbol Then - a0sym = DirectCast(a0,MalSymbol).getName() - Else - a0sym = "__<*fn*>__" - End If - - Select a0sym - Case "def!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "let*" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim key As MalSymbol - Dim val as MalVal - Dim let_env As new MalEnv(env) - For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 - key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) - val = DirectCast(a1,MalList)(i+1) - let_env.do_set(key, EVAL(val, let_env)) - Next - orig_ast = a2 - env = let_env - Case "do" - eval_ast(ast.slice(1, ast.size()-1), env) - orig_ast = ast(ast.size()-1) - Case "if" - Dim a1 As MalVal = ast(1) - Dim cond As MalVal = EVAL(a1, env) - If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then - ' eval false slot form - If ast.size() > 3 Then - orig_ast = ast(3) - Else - return Mal.types.Nil - End If - Else - ' eval true slot form - orig_ast = ast(2) - - End If - Case "fn*" - Dim fc As New FClosure() - fc.ast = ast(2) - fc.params = DirectCast(ast(1),MalLIst) - fc.env = env - Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn - Dim mf As new MalFunc(ast(2), env, - DirectCast(ast(1),MalList), f) - return DirectCast(mf,MalVal) - Case Else - Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) - Dim f As MalFunc = DirectCast(el(0), MalFunc) - Dim fnast As MalVal = f.getAst() - If not fnast Is Nothing - orig_ast = fnast - env = f.genEnv(el.rest()) - Else - Return f.apply(el.rest()) - End If - End Select - - Loop While True - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared repl_env As MalEnv - - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), repl_env)) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - repl_env = New MalEnv(Nothing) - - ' core.vb: defined using VB.NET - For Each entry As KeyValuePair(Of String,MalVal) In core.ns() - repl_env.do_set(new MalSymbol(entry.Key), entry.Value) - Next - - ' core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - End If - - ' repl loop - Dim line As String - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e as Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalInt = Mal.types.MalInt +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalFunc = Mal.types.MalFunc +Imports MalEnv = Mal.env.Env + +Namespace Mal + Class step5_tco + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal + If TypeOf ast Is MalSymbol Then + return env.do_get(DirectCast(ast, MalSymbol)) + Else If TypeOf ast Is MalList Then + Dim old_lst As MalList = DirectCast(ast, MalList) + Dim new_lst As MalList + If ast.list_Q() Then + new_lst = New MalList + Else + new_lst = DirectCast(New MalVector, MalList) + End If + Dim mv As MalVal + For Each mv in old_lst.getValue() + new_lst.conj_BANG(EVAL(mv, env)) + Next + return new_lst + Else If TypeOf ast Is MalHashMap Then + Dim new_dict As New Dictionary(Of String, MalVal) + Dim entry As KeyValuePair(Of String, MalVal) + For Each entry in DirectCast(ast,MalHashMap).getValue() + new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) + Next + return New MalHashMap(new_dict) + Else + return ast + End If + return ast + End Function + + ' TODO: move to types.vb when it is ported + Class FClosure + Public ast As MalVal + Public params As MalList + Public env As MalEnv + Function fn(args as MalList) As MalVal + return EVAL(ast, new MalEnv(env, params, args)) + End Function + End Class + + Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal + Do + + 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) + If not orig_ast.list_Q() Then + return eval_ast(orig_ast, env) + End If + + ' apply list + Dim ast As MalList = DirectCast(orig_ast, MalList) + If ast.size() = 0 Then + return ast + End If + Dim a0 As MalVal = ast(0) + Dim a0sym As String + If TypeOf a0 is MalSymbol Then + a0sym = DirectCast(a0,MalSymbol).getName() + Else + a0sym = "__<*fn*>__" + End If + + Select a0sym + Case "def!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "let*" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim key As MalSymbol + Dim val as MalVal + Dim let_env As new MalEnv(env) + For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 + key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) + val = DirectCast(a1,MalList)(i+1) + let_env.do_set(key, EVAL(val, let_env)) + Next + orig_ast = a2 + env = let_env + Case "do" + eval_ast(ast.slice(1, ast.size()-1), env) + orig_ast = ast(ast.size()-1) + Case "if" + Dim a1 As MalVal = ast(1) + Dim cond As MalVal = EVAL(a1, env) + If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then + ' eval false slot form + If ast.size() > 3 Then + orig_ast = ast(3) + Else + return Mal.types.Nil + End If + Else + ' eval true slot form + orig_ast = ast(2) + + End If + Case "fn*" + Dim fc As New FClosure() + fc.ast = ast(2) + fc.params = DirectCast(ast(1),MalLIst) + fc.env = env + Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn + Dim mf As new MalFunc(ast(2), env, + DirectCast(ast(1),MalList), f) + return DirectCast(mf,MalVal) + Case Else + Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) + Dim f As MalFunc = DirectCast(el(0), MalFunc) + Dim fnast As MalVal = f.getAst() + If not fnast Is Nothing + orig_ast = fnast + env = f.genEnv(el.rest()) + Else + Return f.apply(el.rest()) + End If + End Select + + Loop While True + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared repl_env As MalEnv + + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), repl_env)) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + repl_env = New MalEnv(Nothing) + + ' core.vb: defined using VB.NET + For Each entry As KeyValuePair(Of String,MalVal) In core.ns() + repl_env.do_set(new MalSymbol(entry.Key), entry.Value) + Next + + ' core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + End If + + ' repl loop + Dim line As String + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e as Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/step6_file.vb b/impls/vb/step6_file.vb index 8c9c43504b..ac6ad70b11 100644 --- a/impls/vb/step6_file.vb +++ b/impls/vb/step6_file.vb @@ -1,215 +1,215 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalInt = Mal.types.MalInt -Imports MalString = Mal.types.MalString -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalFunc = Mal.types.MalFunc -Imports MalEnv = Mal.env.Env - -Namespace Mal - Class step6_file - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal - If TypeOf ast Is MalSymbol Then - return env.do_get(DirectCast(ast, MalSymbol)) - Else If TypeOf ast Is MalList Then - Dim old_lst As MalList = DirectCast(ast, MalList) - Dim new_lst As MalList - If ast.list_Q() Then - new_lst = New MalList - Else - new_lst = DirectCast(New MalVector, MalList) - End If - Dim mv As MalVal - For Each mv in old_lst.getValue() - new_lst.conj_BANG(EVAL(mv, env)) - Next - return new_lst - Else If TypeOf ast Is MalHashMap Then - Dim new_dict As New Dictionary(Of String, MalVal) - Dim entry As KeyValuePair(Of String, MalVal) - For Each entry in DirectCast(ast,MalHashMap).getValue() - new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) - Next - return New MalHashMap(new_dict) - Else - return ast - End If - return ast - End Function - - ' TODO: move to types.vb when it is ported - Class FClosure - Public ast As MalVal - Public params As MalList - Public env As MalEnv - Function fn(args as MalList) As MalVal - return EVAL(ast, new MalEnv(env, params, args)) - End Function - End Class - - Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal - Do - - 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) - If not orig_ast.list_Q() Then - return eval_ast(orig_ast, env) - End If - - ' apply list - Dim ast As MalList = DirectCast(orig_ast, MalList) - If ast.size() = 0 Then - return ast - End If - Dim a0 As MalVal = ast(0) - Dim a0sym As String - If TypeOf a0 is MalSymbol Then - a0sym = DirectCast(a0,MalSymbol).getName() - Else - a0sym = "__<*fn*>__" - End If - - Select a0sym - Case "def!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "let*" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim key As MalSymbol - Dim val as MalVal - Dim let_env As new MalEnv(env) - For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 - key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) - val = DirectCast(a1,MalList)(i+1) - let_env.do_set(key, EVAL(val, let_env)) - Next - orig_ast = a2 - env = let_env - Case "do" - eval_ast(ast.slice(1, ast.size()-1), env) - orig_ast = ast(ast.size()-1) - Case "if" - Dim a1 As MalVal = ast(1) - Dim cond As MalVal = EVAL(a1, env) - If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then - ' eval false slot form - If ast.size() > 3 Then - orig_ast = ast(3) - Else - return Mal.types.Nil - End If - Else - ' eval true slot form - orig_ast = ast(2) - - End If - Case "fn*" - Dim fc As New FClosure() - fc.ast = ast(2) - fc.params = DirectCast(ast(1),MalLIst) - fc.env = env - Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn - Dim mf As new MalFunc(ast(2), env, - DirectCast(ast(1),MalList), f) - return DirectCast(mf,MalVal) - Case Else - Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) - Dim f As MalFunc = DirectCast(el(0), MalFunc) - Dim fnast As MalVal = f.getAst() - If not fnast Is Nothing - orig_ast = fnast - env = f.genEnv(el.rest()) - Else - Return f.apply(el.rest()) - End If - End Select - - Loop While True - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared repl_env As MalEnv - - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), repl_env)) - End Function - - Shared Function do_eval(args As MalList) As MalVal - Return EVAL(args(0), repl_env) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - repl_env = New MalEnv(Nothing) - - ' core.vb: defined using VB.NET - For Each entry As KeyValuePair(Of String,MalVal) In core.ns() - repl_env.do_set(new MalSymbol(entry.Key), entry.Value) - Next - repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) - Dim fileIdx As Integer = 1 - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - fileIdx = 2 - End If - Dim argv As New MalList() - For i As Integer = fileIdx+1 To args.Length-1 - argv.conj_BANG(new MalString(args(i))) - Next - repl_env.do_set(new MalSymbol("*ARGV*"), argv) - - ' core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") - - If args.Length > fileIdx Then - REP("(load-file """ & args(fileIdx) & """)") - return 0 - End If - - ' repl loop - Dim line As String - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e as Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalInt = Mal.types.MalInt +Imports MalString = Mal.types.MalString +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalFunc = Mal.types.MalFunc +Imports MalEnv = Mal.env.Env + +Namespace Mal + Class step6_file + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal + If TypeOf ast Is MalSymbol Then + return env.do_get(DirectCast(ast, MalSymbol)) + Else If TypeOf ast Is MalList Then + Dim old_lst As MalList = DirectCast(ast, MalList) + Dim new_lst As MalList + If ast.list_Q() Then + new_lst = New MalList + Else + new_lst = DirectCast(New MalVector, MalList) + End If + Dim mv As MalVal + For Each mv in old_lst.getValue() + new_lst.conj_BANG(EVAL(mv, env)) + Next + return new_lst + Else If TypeOf ast Is MalHashMap Then + Dim new_dict As New Dictionary(Of String, MalVal) + Dim entry As KeyValuePair(Of String, MalVal) + For Each entry in DirectCast(ast,MalHashMap).getValue() + new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) + Next + return New MalHashMap(new_dict) + Else + return ast + End If + return ast + End Function + + ' TODO: move to types.vb when it is ported + Class FClosure + Public ast As MalVal + Public params As MalList + Public env As MalEnv + Function fn(args as MalList) As MalVal + return EVAL(ast, new MalEnv(env, params, args)) + End Function + End Class + + Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal + Do + + 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) + If not orig_ast.list_Q() Then + return eval_ast(orig_ast, env) + End If + + ' apply list + Dim ast As MalList = DirectCast(orig_ast, MalList) + If ast.size() = 0 Then + return ast + End If + Dim a0 As MalVal = ast(0) + Dim a0sym As String + If TypeOf a0 is MalSymbol Then + a0sym = DirectCast(a0,MalSymbol).getName() + Else + a0sym = "__<*fn*>__" + End If + + Select a0sym + Case "def!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "let*" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim key As MalSymbol + Dim val as MalVal + Dim let_env As new MalEnv(env) + For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 + key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) + val = DirectCast(a1,MalList)(i+1) + let_env.do_set(key, EVAL(val, let_env)) + Next + orig_ast = a2 + env = let_env + Case "do" + eval_ast(ast.slice(1, ast.size()-1), env) + orig_ast = ast(ast.size()-1) + Case "if" + Dim a1 As MalVal = ast(1) + Dim cond As MalVal = EVAL(a1, env) + If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then + ' eval false slot form + If ast.size() > 3 Then + orig_ast = ast(3) + Else + return Mal.types.Nil + End If + Else + ' eval true slot form + orig_ast = ast(2) + + End If + Case "fn*" + Dim fc As New FClosure() + fc.ast = ast(2) + fc.params = DirectCast(ast(1),MalLIst) + fc.env = env + Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn + Dim mf As new MalFunc(ast(2), env, + DirectCast(ast(1),MalList), f) + return DirectCast(mf,MalVal) + Case Else + Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) + Dim f As MalFunc = DirectCast(el(0), MalFunc) + Dim fnast As MalVal = f.getAst() + If not fnast Is Nothing + orig_ast = fnast + env = f.genEnv(el.rest()) + Else + Return f.apply(el.rest()) + End If + End Select + + Loop While True + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared repl_env As MalEnv + + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), repl_env)) + End Function + + Shared Function do_eval(args As MalList) As MalVal + Return EVAL(args(0), repl_env) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + repl_env = New MalEnv(Nothing) + + ' core.vb: defined using VB.NET + For Each entry As KeyValuePair(Of String,MalVal) In core.ns() + repl_env.do_set(new MalSymbol(entry.Key), entry.Value) + Next + repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) + Dim fileIdx As Integer = 1 + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + fileIdx = 2 + End If + Dim argv As New MalList() + For i As Integer = fileIdx+1 To args.Length-1 + argv.conj_BANG(new MalString(args(i))) + Next + repl_env.do_set(new MalSymbol("*ARGV*"), argv) + + ' core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") + + If args.Length > fileIdx Then + REP("(load-file """ & args(fileIdx) & """)") + return 0 + End If + + ' repl loop + Dim line As String + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e as Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/step7_quote.vb b/impls/vb/step7_quote.vb index 3303f31861..e22975f77f 100644 --- a/impls/vb/step7_quote.vb +++ b/impls/vb/step7_quote.vb @@ -1,263 +1,263 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalInt = Mal.types.MalInt -Imports MalString = Mal.types.MalString -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalFunc = Mal.types.MalFunc -Imports MalEnv = Mal.env.Env - -Namespace Mal - Class step7_quote - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function starts_with(ast As Malval, sym As String) As MalVal - If ast.list_Q() Then - Const lst As MalList = DirectCast(ast, MalList) - If 0 < lst.size() Then - Const fst As MalSymbol = TryCast(lst(0), MalSymbol) - If fst IsNot Nothing AndAlso fst.getName() = sym Then - return lst(1) - End If - End If - End If - return Nothing - End Function - - Shared Function quasiquote(ast As MalVal) As MalVal - If TypeOf ast Is Mal.types.MalSymbol or Typeof ast Is Mal.types.MalHashMap Then - return New MalList(New MalSymbol("quote"), ast) - End If - Const source As MalList = TryCast(ast, MalList) - If source Is Nothing Then - return ast - End If - Const unquoted As MalVal = starts_with(ast, "unquote") - If unquoted IsNot Nothing Then - return unquoted - End If - Dim result As MalList = New MalList() - For i As Integer = source.size()-1 To 0 Step -1 - Const elt As MalVal = source(i) - Const splice_unquoted As MalVal = starts_with(elt, "splice-unquote") - If splice_unquoted IsNot Nothing Then - result = New MalList(New MalSymbol("concat"), splice_unquoted, result) - Else - result = New MalList(New MalSymbol("cons"), quasiquote(elt), result) - End If - Next - If TypeOf ast Is MalVector Then - result = New MalList(New MalSymbol("vec"), result) - End If - return result - End Function - - - Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal - If TypeOf ast Is MalSymbol Then - return env.do_get(DirectCast(ast, MalSymbol)) - Else If TypeOf ast Is MalList Then - Dim old_lst As MalList = DirectCast(ast, MalList) - Dim new_lst As MalList - If ast.list_Q() Then - new_lst = New MalList - Else - new_lst = DirectCast(New MalVector, MalList) - End If - Dim mv As MalVal - For Each mv in old_lst.getValue() - new_lst.conj_BANG(EVAL(mv, env)) - Next - return new_lst - Else If TypeOf ast Is MalHashMap Then - Dim new_dict As New Dictionary(Of String, MalVal) - Dim entry As KeyValuePair(Of String, MalVal) - For Each entry in DirectCast(ast,MalHashMap).getValue() - new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) - Next - return New MalHashMap(new_dict) - Else - return ast - End If - return ast - End Function - - ' TODO: move to types.vb when it is ported - Class FClosure - Public ast As MalVal - Public params As MalList - Public env As MalEnv - Function fn(args as MalList) As MalVal - return EVAL(ast, new MalEnv(env, params, args)) - End Function - End Class - - Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal - Do - - 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) - If not orig_ast.list_Q() Then - return eval_ast(orig_ast, env) - End If - - ' apply list - Dim ast As MalList = DirectCast(orig_ast, MalList) - If ast.size() = 0 Then - return ast - End If - Dim a0 As MalVal = ast(0) - Dim a0sym As String - If TypeOf a0 is MalSymbol Then - a0sym = DirectCast(a0,MalSymbol).getName() - Else - a0sym = "__<*fn*>__" - End If - - Select a0sym - Case "def!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "let*" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim key As MalSymbol - Dim val as MalVal - Dim let_env As new MalEnv(env) - For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 - key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) - val = DirectCast(a1,MalList)(i+1) - let_env.do_set(key, EVAL(val, let_env)) - Next - orig_ast = a2 - env = let_env - Case "quote" - return ast(1) - Case "quasiquoteexpand" - return quasiquote(ast(1)) - Case "quasiquote" - orig_ast = quasiquote(ast(1)) - Case "do" - eval_ast(ast.slice(1, ast.size()-1), env) - orig_ast = ast(ast.size()-1) - Case "if" - Dim a1 As MalVal = ast(1) - Dim cond As MalVal = EVAL(a1, env) - If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then - ' eval false slot form - If ast.size() > 3 Then - orig_ast = ast(3) - Else - return Mal.types.Nil - End If - Else - ' eval true slot form - orig_ast = ast(2) - - End If - Case "fn*" - Dim fc As New FClosure() - fc.ast = ast(2) - fc.params = DirectCast(ast(1),MalLIst) - fc.env = env - Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn - Dim mf As new MalFunc(ast(2), env, - DirectCast(ast(1),MalList), f) - return DirectCast(mf,MalVal) - Case Else - Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) - Dim f As MalFunc = DirectCast(el(0), MalFunc) - Dim fnast As MalVal = f.getAst() - If not fnast Is Nothing - orig_ast = fnast - env = f.genEnv(el.rest()) - Else - Return f.apply(el.rest()) - End If - End Select - - Loop While True - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared repl_env As MalEnv - - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), repl_env)) - End Function - - Shared Function do_eval(args As MalList) As MalVal - Return EVAL(args(0), repl_env) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - repl_env = New MalEnv(Nothing) - - ' core.vb: defined using VB.NET - For Each entry As KeyValuePair(Of String,MalVal) In core.ns() - repl_env.do_set(new MalSymbol(entry.Key), entry.Value) - Next - repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) - Dim fileIdx As Integer = 1 - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - fileIdx = 2 - End If - Dim argv As New MalList() - For i As Integer = fileIdx+1 To args.Length-1 - argv.conj_BANG(new MalString(args(i))) - Next - repl_env.do_set(new MalSymbol("*ARGV*"), argv) - - ' core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") - - If args.Length > fileIdx Then - REP("(load-file """ & args(fileIdx) & """)") - return 0 - End If - - ' repl loop - Dim line As String - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e as Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalInt = Mal.types.MalInt +Imports MalString = Mal.types.MalString +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalFunc = Mal.types.MalFunc +Imports MalEnv = Mal.env.Env + +Namespace Mal + Class step7_quote + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function starts_with(ast As Malval, sym As String) As MalVal + If ast.list_Q() Then + Const lst As MalList = DirectCast(ast, MalList) + If 0 < lst.size() Then + Const fst As MalSymbol = TryCast(lst(0), MalSymbol) + If fst IsNot Nothing AndAlso fst.getName() = sym Then + return lst(1) + End If + End If + End If + return Nothing + End Function + + Shared Function quasiquote(ast As MalVal) As MalVal + If TypeOf ast Is Mal.types.MalSymbol or Typeof ast Is Mal.types.MalHashMap Then + return New MalList(New MalSymbol("quote"), ast) + End If + Const source As MalList = TryCast(ast, MalList) + If source Is Nothing Then + return ast + End If + Const unquoted As MalVal = starts_with(ast, "unquote") + If unquoted IsNot Nothing Then + return unquoted + End If + Dim result As MalList = New MalList() + For i As Integer = source.size()-1 To 0 Step -1 + Const elt As MalVal = source(i) + Const splice_unquoted As MalVal = starts_with(elt, "splice-unquote") + If splice_unquoted IsNot Nothing Then + result = New MalList(New MalSymbol("concat"), splice_unquoted, result) + Else + result = New MalList(New MalSymbol("cons"), quasiquote(elt), result) + End If + Next + If TypeOf ast Is MalVector Then + result = New MalList(New MalSymbol("vec"), result) + End If + return result + End Function + + + Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal + If TypeOf ast Is MalSymbol Then + return env.do_get(DirectCast(ast, MalSymbol)) + Else If TypeOf ast Is MalList Then + Dim old_lst As MalList = DirectCast(ast, MalList) + Dim new_lst As MalList + If ast.list_Q() Then + new_lst = New MalList + Else + new_lst = DirectCast(New MalVector, MalList) + End If + Dim mv As MalVal + For Each mv in old_lst.getValue() + new_lst.conj_BANG(EVAL(mv, env)) + Next + return new_lst + Else If TypeOf ast Is MalHashMap Then + Dim new_dict As New Dictionary(Of String, MalVal) + Dim entry As KeyValuePair(Of String, MalVal) + For Each entry in DirectCast(ast,MalHashMap).getValue() + new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) + Next + return New MalHashMap(new_dict) + Else + return ast + End If + return ast + End Function + + ' TODO: move to types.vb when it is ported + Class FClosure + Public ast As MalVal + Public params As MalList + Public env As MalEnv + Function fn(args as MalList) As MalVal + return EVAL(ast, new MalEnv(env, params, args)) + End Function + End Class + + Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal + Do + + 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) + If not orig_ast.list_Q() Then + return eval_ast(orig_ast, env) + End If + + ' apply list + Dim ast As MalList = DirectCast(orig_ast, MalList) + If ast.size() = 0 Then + return ast + End If + Dim a0 As MalVal = ast(0) + Dim a0sym As String + If TypeOf a0 is MalSymbol Then + a0sym = DirectCast(a0,MalSymbol).getName() + Else + a0sym = "__<*fn*>__" + End If + + Select a0sym + Case "def!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "let*" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim key As MalSymbol + Dim val as MalVal + Dim let_env As new MalEnv(env) + For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 + key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) + val = DirectCast(a1,MalList)(i+1) + let_env.do_set(key, EVAL(val, let_env)) + Next + orig_ast = a2 + env = let_env + Case "quote" + return ast(1) + Case "quasiquoteexpand" + return quasiquote(ast(1)) + Case "quasiquote" + orig_ast = quasiquote(ast(1)) + Case "do" + eval_ast(ast.slice(1, ast.size()-1), env) + orig_ast = ast(ast.size()-1) + Case "if" + Dim a1 As MalVal = ast(1) + Dim cond As MalVal = EVAL(a1, env) + If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then + ' eval false slot form + If ast.size() > 3 Then + orig_ast = ast(3) + Else + return Mal.types.Nil + End If + Else + ' eval true slot form + orig_ast = ast(2) + + End If + Case "fn*" + Dim fc As New FClosure() + fc.ast = ast(2) + fc.params = DirectCast(ast(1),MalLIst) + fc.env = env + Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn + Dim mf As new MalFunc(ast(2), env, + DirectCast(ast(1),MalList), f) + return DirectCast(mf,MalVal) + Case Else + Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) + Dim f As MalFunc = DirectCast(el(0), MalFunc) + Dim fnast As MalVal = f.getAst() + If not fnast Is Nothing + orig_ast = fnast + env = f.genEnv(el.rest()) + Else + Return f.apply(el.rest()) + End If + End Select + + Loop While True + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared repl_env As MalEnv + + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), repl_env)) + End Function + + Shared Function do_eval(args As MalList) As MalVal + Return EVAL(args(0), repl_env) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + repl_env = New MalEnv(Nothing) + + ' core.vb: defined using VB.NET + For Each entry As KeyValuePair(Of String,MalVal) In core.ns() + repl_env.do_set(new MalSymbol(entry.Key), entry.Value) + Next + repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) + Dim fileIdx As Integer = 1 + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + fileIdx = 2 + End If + Dim argv As New MalList() + For i As Integer = fileIdx+1 To args.Length-1 + argv.conj_BANG(new MalString(args(i))) + Next + repl_env.do_set(new MalSymbol("*ARGV*"), argv) + + ' core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") + + If args.Length > fileIdx Then + REP("(load-file """ & args(fileIdx) & """)") + return 0 + End If + + ' repl loop + Dim line As String + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e as Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/step8_macros.vb b/impls/vb/step8_macros.vb index 43befb9eba..108829377b 100644 --- a/impls/vb/step8_macros.vb +++ b/impls/vb/step8_macros.vb @@ -1,302 +1,302 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalInt = Mal.types.MalInt -Imports MalString = Mal.types.MalString -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalFunc = Mal.types.MalFunc -Imports MalEnv = Mal.env.Env - -Namespace Mal - Class step8_macros - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function starts_with(ast As Malval, sym As String) As MalVal - If ast.list_Q() Then - Const lst As MalList = DirectCast(ast, MalList) - If 0 < lst.size() Then - Const fst As MalSymbol = TryCast(lst(0), MalSymbol) - If fst IsNot Nothing AndAlso fst.getName() = sym Then - return lst(1) - End If - End If - End If - return Nothing - End Function - - Shared Function quasiquote(ast As MalVal) As MalVal - If TypeOf ast Is Mal.types.MalSymbol or Typeof ast Is Mal.types.MalHashMap Then - return New MalList(New MalSymbol("quote"), ast) - End If - Const source As MalList = TryCast(ast, MalList) - If source Is Nothing Then - return ast - End If - Const unquoted As MalVal = starts_with(ast, "unquote") - If unquoted IsNot Nothing Then - return unquoted - End If - Dim result As MalList = New MalList() - For i As Integer = source.size()-1 To 0 Step -1 - Const elt As MalVal = source(i) - Const splice_unquoted As MalVal = starts_with(elt, "splice-unquote") - If splice_unquoted IsNot Nothing Then - result = New MalList(New MalSymbol("concat"), splice_unquoted, result) - Else - result = New MalList(New MalSymbol("cons"), quasiquote(elt), result) - End If - Next - If TypeOf ast Is MalVector Then - result = New MalList(New MalSymbol("vec"), result) - End If - return result - End Function - - Shared Function is_macro_call(ast As MalVal, env As MalEnv) As Boolean - If TypeOf ast Is MalList Then - Dim a0 As MalVal = DirectCast(ast,MalList)(0) - If TypeOf a0 Is MalSymbol AndAlso _ - env.find(DirectCast(a0,MalSymbol)) IsNot Nothing Then - Dim mac As MalVal = env.do_get(DirectCast(a0,MalSymbol)) - If TypeOf mac Is MalFunc AndAlso _ - DirectCast(mac,MalFunc).isMacro() Then - return True - End If - End If - End If - return False - End Function - - Shared Function macroexpand(ast As MalVal, env As MalEnv) As MalVal - While is_macro_call(ast, env) - Dim a0 As MalSymbol = DirectCast(DirectCast(ast,MalList)(0),MalSymbol) - Dim mac As MalFunc = DirectCast(env.do_get(a0),MalFunc) - ast = mac.apply(DirectCast(ast,MalList).rest()) - End While - return ast - End Function - - Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal - If TypeOf ast Is MalSymbol Then - return env.do_get(DirectCast(ast, MalSymbol)) - Else If TypeOf ast Is MalList Then - Dim old_lst As MalList = DirectCast(ast, MalList) - Dim new_lst As MalList - If ast.list_Q() Then - new_lst = New MalList - Else - new_lst = DirectCast(New MalVector, MalList) - End If - Dim mv As MalVal - For Each mv in old_lst.getValue() - new_lst.conj_BANG(EVAL(mv, env)) - Next - return new_lst - Else If TypeOf ast Is MalHashMap Then - Dim new_dict As New Dictionary(Of String, MalVal) - Dim entry As KeyValuePair(Of String, MalVal) - For Each entry in DirectCast(ast,MalHashMap).getValue() - new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) - Next - return New MalHashMap(new_dict) - Else - return ast - End If - return ast - End Function - - ' TODO: move to types.vb when it is ported - Class FClosure - Public ast As MalVal - Public params As MalList - Public env As MalEnv - Function fn(args as MalList) As MalVal - return EVAL(ast, new MalEnv(env, params, args)) - End Function - End Class - - Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal - Do - - 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) - If not orig_ast.list_Q() Then - return eval_ast(orig_ast, env) - End If - - ' apply list - Dim expanded As MalVal = macroexpand(orig_ast, env) - if not expanded.list_Q() Then - return eval_ast(expanded, env) - End If - Dim ast As MalList = DirectCast(expanded, MalList) - - If ast.size() = 0 Then - return ast - End If - Dim a0 As MalVal = ast(0) - Dim a0sym As String - If TypeOf a0 is MalSymbol Then - a0sym = DirectCast(a0,MalSymbol).getName() - Else - a0sym = "__<*fn*>__" - End If - - Select a0sym - Case "def!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "let*" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim key As MalSymbol - Dim val as MalVal - Dim let_env As new MalEnv(env) - For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 - key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) - val = DirectCast(a1,MalList)(i+1) - let_env.do_set(key, EVAL(val, let_env)) - Next - orig_ast = a2 - env = let_env - Case "quote" - return ast(1) - Case "quasiquoteexpand" - return quasiquote(ast(1)) - Case "quasiquote" - orig_ast = quasiquote(ast(1)) - Case "defmacro!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - DirectCast(res,MalFunc).setMacro() - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "macroexpand" - Dim a1 As MalVal = ast(1) - return macroexpand(a1, env) - Case "do" - eval_ast(ast.slice(1, ast.size()-1), env) - orig_ast = ast(ast.size()-1) - Case "if" - Dim a1 As MalVal = ast(1) - Dim cond As MalVal = EVAL(a1, env) - If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then - ' eval false slot form - If ast.size() > 3 Then - orig_ast = ast(3) - Else - return Mal.types.Nil - End If - Else - ' eval true slot form - orig_ast = ast(2) - - End If - Case "fn*" - Dim fc As New FClosure() - fc.ast = ast(2) - fc.params = DirectCast(ast(1),MalLIst) - fc.env = env - Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn - Dim mf As new MalFunc(ast(2), env, - DirectCast(ast(1),MalList), f) - return DirectCast(mf,MalVal) - Case Else - Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) - Dim f As MalFunc = DirectCast(el(0), MalFunc) - Dim fnast As MalVal = f.getAst() - If not fnast Is Nothing - orig_ast = fnast - env = f.genEnv(el.rest()) - Else - Return f.apply(el.rest()) - End If - End Select - - Loop While True - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared repl_env As MalEnv - - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), repl_env)) - End Function - - Shared Function do_eval(args As MalList) As MalVal - Return EVAL(args(0), repl_env) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - repl_env = New MalEnv(Nothing) - - ' core.vb: defined using VB.NET - For Each entry As KeyValuePair(Of String,MalVal) In core.ns() - repl_env.do_set(new MalSymbol(entry.Key), entry.Value) - Next - repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) - Dim fileIdx As Integer = 1 - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - fileIdx = 2 - End If - Dim argv As New MalList() - For i As Integer = fileIdx+1 To args.Length-1 - argv.conj_BANG(new MalString(args(i))) - Next - repl_env.do_set(new MalSymbol("*ARGV*"), argv) - - ' core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") - 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)))))))") - - If args.Length > fileIdx Then - REP("(load-file """ & args(fileIdx) & """)") - return 0 - End If - - ' repl loop - Dim line As String - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e as Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalInt = Mal.types.MalInt +Imports MalString = Mal.types.MalString +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalFunc = Mal.types.MalFunc +Imports MalEnv = Mal.env.Env + +Namespace Mal + Class step8_macros + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function starts_with(ast As Malval, sym As String) As MalVal + If ast.list_Q() Then + Const lst As MalList = DirectCast(ast, MalList) + If 0 < lst.size() Then + Const fst As MalSymbol = TryCast(lst(0), MalSymbol) + If fst IsNot Nothing AndAlso fst.getName() = sym Then + return lst(1) + End If + End If + End If + return Nothing + End Function + + Shared Function quasiquote(ast As MalVal) As MalVal + If TypeOf ast Is Mal.types.MalSymbol or Typeof ast Is Mal.types.MalHashMap Then + return New MalList(New MalSymbol("quote"), ast) + End If + Const source As MalList = TryCast(ast, MalList) + If source Is Nothing Then + return ast + End If + Const unquoted As MalVal = starts_with(ast, "unquote") + If unquoted IsNot Nothing Then + return unquoted + End If + Dim result As MalList = New MalList() + For i As Integer = source.size()-1 To 0 Step -1 + Const elt As MalVal = source(i) + Const splice_unquoted As MalVal = starts_with(elt, "splice-unquote") + If splice_unquoted IsNot Nothing Then + result = New MalList(New MalSymbol("concat"), splice_unquoted, result) + Else + result = New MalList(New MalSymbol("cons"), quasiquote(elt), result) + End If + Next + If TypeOf ast Is MalVector Then + result = New MalList(New MalSymbol("vec"), result) + End If + return result + End Function + + Shared Function is_macro_call(ast As MalVal, env As MalEnv) As Boolean + If TypeOf ast Is MalList Then + Dim a0 As MalVal = DirectCast(ast,MalList)(0) + If TypeOf a0 Is MalSymbol AndAlso _ + env.find(DirectCast(a0,MalSymbol)) IsNot Nothing Then + Dim mac As MalVal = env.do_get(DirectCast(a0,MalSymbol)) + If TypeOf mac Is MalFunc AndAlso _ + DirectCast(mac,MalFunc).isMacro() Then + return True + End If + End If + End If + return False + End Function + + Shared Function macroexpand(ast As MalVal, env As MalEnv) As MalVal + While is_macro_call(ast, env) + Dim a0 As MalSymbol = DirectCast(DirectCast(ast,MalList)(0),MalSymbol) + Dim mac As MalFunc = DirectCast(env.do_get(a0),MalFunc) + ast = mac.apply(DirectCast(ast,MalList).rest()) + End While + return ast + End Function + + Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal + If TypeOf ast Is MalSymbol Then + return env.do_get(DirectCast(ast, MalSymbol)) + Else If TypeOf ast Is MalList Then + Dim old_lst As MalList = DirectCast(ast, MalList) + Dim new_lst As MalList + If ast.list_Q() Then + new_lst = New MalList + Else + new_lst = DirectCast(New MalVector, MalList) + End If + Dim mv As MalVal + For Each mv in old_lst.getValue() + new_lst.conj_BANG(EVAL(mv, env)) + Next + return new_lst + Else If TypeOf ast Is MalHashMap Then + Dim new_dict As New Dictionary(Of String, MalVal) + Dim entry As KeyValuePair(Of String, MalVal) + For Each entry in DirectCast(ast,MalHashMap).getValue() + new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) + Next + return New MalHashMap(new_dict) + Else + return ast + End If + return ast + End Function + + ' TODO: move to types.vb when it is ported + Class FClosure + Public ast As MalVal + Public params As MalList + Public env As MalEnv + Function fn(args as MalList) As MalVal + return EVAL(ast, new MalEnv(env, params, args)) + End Function + End Class + + Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal + Do + + 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) + If not orig_ast.list_Q() Then + return eval_ast(orig_ast, env) + End If + + ' apply list + Dim expanded As MalVal = macroexpand(orig_ast, env) + if not expanded.list_Q() Then + return eval_ast(expanded, env) + End If + Dim ast As MalList = DirectCast(expanded, MalList) + + If ast.size() = 0 Then + return ast + End If + Dim a0 As MalVal = ast(0) + Dim a0sym As String + If TypeOf a0 is MalSymbol Then + a0sym = DirectCast(a0,MalSymbol).getName() + Else + a0sym = "__<*fn*>__" + End If + + Select a0sym + Case "def!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "let*" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim key As MalSymbol + Dim val as MalVal + Dim let_env As new MalEnv(env) + For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 + key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) + val = DirectCast(a1,MalList)(i+1) + let_env.do_set(key, EVAL(val, let_env)) + Next + orig_ast = a2 + env = let_env + Case "quote" + return ast(1) + Case "quasiquoteexpand" + return quasiquote(ast(1)) + Case "quasiquote" + orig_ast = quasiquote(ast(1)) + Case "defmacro!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + DirectCast(res,MalFunc).setMacro() + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "macroexpand" + Dim a1 As MalVal = ast(1) + return macroexpand(a1, env) + Case "do" + eval_ast(ast.slice(1, ast.size()-1), env) + orig_ast = ast(ast.size()-1) + Case "if" + Dim a1 As MalVal = ast(1) + Dim cond As MalVal = EVAL(a1, env) + If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then + ' eval false slot form + If ast.size() > 3 Then + orig_ast = ast(3) + Else + return Mal.types.Nil + End If + Else + ' eval true slot form + orig_ast = ast(2) + + End If + Case "fn*" + Dim fc As New FClosure() + fc.ast = ast(2) + fc.params = DirectCast(ast(1),MalLIst) + fc.env = env + Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn + Dim mf As new MalFunc(ast(2), env, + DirectCast(ast(1),MalList), f) + return DirectCast(mf,MalVal) + Case Else + Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) + Dim f As MalFunc = DirectCast(el(0), MalFunc) + Dim fnast As MalVal = f.getAst() + If not fnast Is Nothing + orig_ast = fnast + env = f.genEnv(el.rest()) + Else + Return f.apply(el.rest()) + End If + End Select + + Loop While True + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared repl_env As MalEnv + + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), repl_env)) + End Function + + Shared Function do_eval(args As MalList) As MalVal + Return EVAL(args(0), repl_env) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + repl_env = New MalEnv(Nothing) + + ' core.vb: defined using VB.NET + For Each entry As KeyValuePair(Of String,MalVal) In core.ns() + repl_env.do_set(new MalSymbol(entry.Key), entry.Value) + Next + repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) + Dim fileIdx As Integer = 1 + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + fileIdx = 2 + End If + Dim argv As New MalList() + For i As Integer = fileIdx+1 To args.Length-1 + argv.conj_BANG(new MalString(args(i))) + Next + repl_env.do_set(new MalSymbol("*ARGV*"), argv) + + ' core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") + 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)))))))") + + If args.Length > fileIdx Then + REP("(load-file """ & args(fileIdx) & """)") + return 0 + End If + + ' repl loop + Dim line As String + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e as Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/step9_try.vb b/impls/vb/step9_try.vb index e8f35a0b4c..0dcdc72c66 100644 --- a/impls/vb/step9_try.vb +++ b/impls/vb/step9_try.vb @@ -1,329 +1,329 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalInt = Mal.types.MalInt -Imports MalString = Mal.types.MalString -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalFunc = Mal.types.MalFunc -Imports MalEnv = Mal.env.Env - -Namespace Mal - Class step9_try - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function starts_with(ast As Malval, sym As String) As MalVal - If ast.list_Q() Then - Const lst As MalList = DirectCast(ast, MalList) - If 0 < lst.size() Then - Const fst As MalSymbol = TryCast(lst(0), MalSymbol) - If fst IsNot Nothing AndAlso fst.getName() = sym Then - return lst(1) - End If - End If - End If - return Nothing - End Function - - Shared Function quasiquote(ast As MalVal) As MalVal - If TypeOf ast Is Mal.types.MalSymbol or Typeof ast Is Mal.types.MalHashMap Then - return New MalList(New MalSymbol("quote"), ast) - End If - Const source As MalList = TryCast(ast, MalList) - If source Is Nothing Then - return ast - End If - Const unquoted As MalVal = starts_with(ast, "unquote") - If unquoted IsNot Nothing Then - return unquoted - End If - Dim result As MalList = New MalList() - For i As Integer = source.size()-1 To 0 Step -1 - Const elt As MalVal = source(i) - Const splice_unquoted As MalVal = starts_with(elt, "splice-unquote") - If splice_unquoted IsNot Nothing Then - result = New MalList(New MalSymbol("concat"), splice_unquoted, result) - Else - result = New MalList(New MalSymbol("cons"), quasiquote(elt), result) - End If - Next - If TypeOf ast Is MalVector Then - result = New MalList(New MalSymbol("vec"), result) - End If - return result - End Function - - Shared Function is_macro_call(ast As MalVal, env As MalEnv) As Boolean - If TypeOf ast Is MalList Then - Dim a0 As MalVal = DirectCast(ast,MalList)(0) - If TypeOf a0 Is MalSymbol AndAlso _ - env.find(DirectCast(a0,MalSymbol)) IsNot Nothing Then - Dim mac As MalVal = env.do_get(DirectCast(a0,MalSymbol)) - If TypeOf mac Is MalFunc AndAlso _ - DirectCast(mac,MalFunc).isMacro() Then - return True - End If - End If - End If - return False - End Function - - Shared Function macroexpand(ast As MalVal, env As MalEnv) As MalVal - While is_macro_call(ast, env) - Dim a0 As MalSymbol = DirectCast(DirectCast(ast,MalList)(0),MalSymbol) - Dim mac As MalFunc = DirectCast(env.do_get(a0),MalFunc) - ast = mac.apply(DirectCast(ast,MalList).rest()) - End While - return ast - End Function - - Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal - If TypeOf ast Is MalSymbol Then - return env.do_get(DirectCast(ast, MalSymbol)) - Else If TypeOf ast Is MalList Then - Dim old_lst As MalList = DirectCast(ast, MalList) - Dim new_lst As MalList - If ast.list_Q() Then - new_lst = New MalList - Else - new_lst = DirectCast(New MalVector, MalList) - End If - Dim mv As MalVal - For Each mv in old_lst.getValue() - new_lst.conj_BANG(EVAL(mv, env)) - Next - return new_lst - Else If TypeOf ast Is MalHashMap Then - Dim new_dict As New Dictionary(Of String, MalVal) - Dim entry As KeyValuePair(Of String, MalVal) - For Each entry in DirectCast(ast,MalHashMap).getValue() - new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) - Next - return New MalHashMap(new_dict) - Else - return ast - End If - return ast - End Function - - ' TODO: move to types.vb when it is ported - Class FClosure - Public ast As MalVal - Public params As MalList - Public env As MalEnv - Function fn(args as MalList) As MalVal - return EVAL(ast, new MalEnv(env, params, args)) - End Function - End Class - - Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal - Do - - 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) - If not orig_ast.list_Q() Then - return eval_ast(orig_ast, env) - End If - - ' apply list - Dim expanded As MalVal = macroexpand(orig_ast, env) - if not expanded.list_Q() Then - return eval_ast(expanded, env) - End If - Dim ast As MalList = DirectCast(expanded, MalList) - - If ast.size() = 0 Then - return ast - End If - Dim a0 As MalVal = ast(0) - Dim a0sym As String - If TypeOf a0 is MalSymbol Then - a0sym = DirectCast(a0,MalSymbol).getName() - Else - a0sym = "__<*fn*>__" - End If - - Select a0sym - Case "def!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "let*" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim key As MalSymbol - Dim val as MalVal - Dim let_env As new MalEnv(env) - For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 - key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) - val = DirectCast(a1,MalList)(i+1) - let_env.do_set(key, EVAL(val, let_env)) - Next - orig_ast = a2 - env = let_env - Case "quote" - return ast(1) - Case "quasiquoteexpand" - return quasiquote(ast(1)) - Case "quasiquote" - orig_ast = quasiquote(ast(1)) - Case "defmacro!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - DirectCast(res,MalFunc).setMacro() - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "macroexpand" - Dim a1 As MalVal = ast(1) - return macroexpand(a1, env) - Case "try*" - Try - return EVAL(ast(1), env) - Catch e As Exception - If ast.size() > 2 Then - Dim exc As MalVal - Dim a2 As MalVal = ast(2) - Dim a20 As MalVal = DirectCast(a2,MalList)(0) - If DirectCast(a20,MalSymbol).getName() = "catch*" Then - If TypeOf e Is Mal.types.MalException Then - exc = DirectCast(e,Mal.types.MalException).getValue() - Else - exc = New MalString(e.Message) - End If - return EVAL( - DirectCast(a2,MalList)(2), - New MalEnv(env, - DirectCast(a2,MalList).slice(1,2), - New MalList(exc))) - End If - End If - Throw e - End Try - Case "do" - eval_ast(ast.slice(1, ast.size()-1), env) - orig_ast = ast(ast.size()-1) - Case "if" - Dim a1 As MalVal = ast(1) - Dim cond As MalVal = EVAL(a1, env) - If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then - ' eval false slot form - If ast.size() > 3 Then - orig_ast = ast(3) - Else - return Mal.types.Nil - End If - Else - ' eval true slot form - orig_ast = ast(2) - - End If - Case "fn*" - Dim fc As New FClosure() - fc.ast = ast(2) - fc.params = DirectCast(ast(1),MalLIst) - fc.env = env - Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn - Dim mf As new MalFunc(ast(2), env, - DirectCast(ast(1),MalList), f) - return DirectCast(mf,MalVal) - Case Else - Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) - Dim f As MalFunc = DirectCast(el(0), MalFunc) - Dim fnast As MalVal = f.getAst() - If not fnast Is Nothing - orig_ast = fnast - env = f.genEnv(el.rest()) - Else - Return f.apply(el.rest()) - End If - End Select - - Loop While True - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared repl_env As MalEnv - - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), repl_env)) - End Function - - Shared Function do_eval(args As MalList) As MalVal - Return EVAL(args(0), repl_env) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - repl_env = New MalEnv(Nothing) - - ' core.vb: defined using VB.NET - For Each entry As KeyValuePair(Of String,MalVal) In core.ns() - repl_env.do_set(new MalSymbol(entry.Key), entry.Value) - Next - repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) - Dim fileIdx As Integer = 1 - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - fileIdx = 2 - End If - Dim argv As New MalList() - For i As Integer = fileIdx+1 To args.Length-1 - argv.conj_BANG(new MalString(args(i))) - Next - repl_env.do_set(new MalSymbol("*ARGV*"), argv) - - ' core.mal: defined using the language itself - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") - 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)))))))") - - If args.Length > fileIdx Then - REP("(load-file """ & args(fileIdx) & """)") - return 0 - End If - - ' repl loop - Dim line As String - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e As Mal.types.MalException - Console.WriteLine("Error: " & _ - printer._pr_str(e.getValue(), False)) - Continue Do - Catch e As Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalInt = Mal.types.MalInt +Imports MalString = Mal.types.MalString +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalFunc = Mal.types.MalFunc +Imports MalEnv = Mal.env.Env + +Namespace Mal + Class step9_try + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function starts_with(ast As Malval, sym As String) As MalVal + If ast.list_Q() Then + Const lst As MalList = DirectCast(ast, MalList) + If 0 < lst.size() Then + Const fst As MalSymbol = TryCast(lst(0), MalSymbol) + If fst IsNot Nothing AndAlso fst.getName() = sym Then + return lst(1) + End If + End If + End If + return Nothing + End Function + + Shared Function quasiquote(ast As MalVal) As MalVal + If TypeOf ast Is Mal.types.MalSymbol or Typeof ast Is Mal.types.MalHashMap Then + return New MalList(New MalSymbol("quote"), ast) + End If + Const source As MalList = TryCast(ast, MalList) + If source Is Nothing Then + return ast + End If + Const unquoted As MalVal = starts_with(ast, "unquote") + If unquoted IsNot Nothing Then + return unquoted + End If + Dim result As MalList = New MalList() + For i As Integer = source.size()-1 To 0 Step -1 + Const elt As MalVal = source(i) + Const splice_unquoted As MalVal = starts_with(elt, "splice-unquote") + If splice_unquoted IsNot Nothing Then + result = New MalList(New MalSymbol("concat"), splice_unquoted, result) + Else + result = New MalList(New MalSymbol("cons"), quasiquote(elt), result) + End If + Next + If TypeOf ast Is MalVector Then + result = New MalList(New MalSymbol("vec"), result) + End If + return result + End Function + + Shared Function is_macro_call(ast As MalVal, env As MalEnv) As Boolean + If TypeOf ast Is MalList Then + Dim a0 As MalVal = DirectCast(ast,MalList)(0) + If TypeOf a0 Is MalSymbol AndAlso _ + env.find(DirectCast(a0,MalSymbol)) IsNot Nothing Then + Dim mac As MalVal = env.do_get(DirectCast(a0,MalSymbol)) + If TypeOf mac Is MalFunc AndAlso _ + DirectCast(mac,MalFunc).isMacro() Then + return True + End If + End If + End If + return False + End Function + + Shared Function macroexpand(ast As MalVal, env As MalEnv) As MalVal + While is_macro_call(ast, env) + Dim a0 As MalSymbol = DirectCast(DirectCast(ast,MalList)(0),MalSymbol) + Dim mac As MalFunc = DirectCast(env.do_get(a0),MalFunc) + ast = mac.apply(DirectCast(ast,MalList).rest()) + End While + return ast + End Function + + Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal + If TypeOf ast Is MalSymbol Then + return env.do_get(DirectCast(ast, MalSymbol)) + Else If TypeOf ast Is MalList Then + Dim old_lst As MalList = DirectCast(ast, MalList) + Dim new_lst As MalList + If ast.list_Q() Then + new_lst = New MalList + Else + new_lst = DirectCast(New MalVector, MalList) + End If + Dim mv As MalVal + For Each mv in old_lst.getValue() + new_lst.conj_BANG(EVAL(mv, env)) + Next + return new_lst + Else If TypeOf ast Is MalHashMap Then + Dim new_dict As New Dictionary(Of String, MalVal) + Dim entry As KeyValuePair(Of String, MalVal) + For Each entry in DirectCast(ast,MalHashMap).getValue() + new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) + Next + return New MalHashMap(new_dict) + Else + return ast + End If + return ast + End Function + + ' TODO: move to types.vb when it is ported + Class FClosure + Public ast As MalVal + Public params As MalList + Public env As MalEnv + Function fn(args as MalList) As MalVal + return EVAL(ast, new MalEnv(env, params, args)) + End Function + End Class + + Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal + Do + + 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) + If not orig_ast.list_Q() Then + return eval_ast(orig_ast, env) + End If + + ' apply list + Dim expanded As MalVal = macroexpand(orig_ast, env) + if not expanded.list_Q() Then + return eval_ast(expanded, env) + End If + Dim ast As MalList = DirectCast(expanded, MalList) + + If ast.size() = 0 Then + return ast + End If + Dim a0 As MalVal = ast(0) + Dim a0sym As String + If TypeOf a0 is MalSymbol Then + a0sym = DirectCast(a0,MalSymbol).getName() + Else + a0sym = "__<*fn*>__" + End If + + Select a0sym + Case "def!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "let*" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim key As MalSymbol + Dim val as MalVal + Dim let_env As new MalEnv(env) + For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 + key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) + val = DirectCast(a1,MalList)(i+1) + let_env.do_set(key, EVAL(val, let_env)) + Next + orig_ast = a2 + env = let_env + Case "quote" + return ast(1) + Case "quasiquoteexpand" + return quasiquote(ast(1)) + Case "quasiquote" + orig_ast = quasiquote(ast(1)) + Case "defmacro!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + DirectCast(res,MalFunc).setMacro() + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "macroexpand" + Dim a1 As MalVal = ast(1) + return macroexpand(a1, env) + Case "try*" + Try + return EVAL(ast(1), env) + Catch e As Exception + If ast.size() > 2 Then + Dim exc As MalVal + Dim a2 As MalVal = ast(2) + Dim a20 As MalVal = DirectCast(a2,MalList)(0) + If DirectCast(a20,MalSymbol).getName() = "catch*" Then + If TypeOf e Is Mal.types.MalException Then + exc = DirectCast(e,Mal.types.MalException).getValue() + Else + exc = New MalString(e.Message) + End If + return EVAL( + DirectCast(a2,MalList)(2), + New MalEnv(env, + DirectCast(a2,MalList).slice(1,2), + New MalList(exc))) + End If + End If + Throw e + End Try + Case "do" + eval_ast(ast.slice(1, ast.size()-1), env) + orig_ast = ast(ast.size()-1) + Case "if" + Dim a1 As MalVal = ast(1) + Dim cond As MalVal = EVAL(a1, env) + If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then + ' eval false slot form + If ast.size() > 3 Then + orig_ast = ast(3) + Else + return Mal.types.Nil + End If + Else + ' eval true slot form + orig_ast = ast(2) + + End If + Case "fn*" + Dim fc As New FClosure() + fc.ast = ast(2) + fc.params = DirectCast(ast(1),MalLIst) + fc.env = env + Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn + Dim mf As new MalFunc(ast(2), env, + DirectCast(ast(1),MalList), f) + return DirectCast(mf,MalVal) + Case Else + Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) + Dim f As MalFunc = DirectCast(el(0), MalFunc) + Dim fnast As MalVal = f.getAst() + If not fnast Is Nothing + orig_ast = fnast + env = f.genEnv(el.rest()) + Else + Return f.apply(el.rest()) + End If + End Select + + Loop While True + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared repl_env As MalEnv + + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), repl_env)) + End Function + + Shared Function do_eval(args As MalList) As MalVal + Return EVAL(args(0), repl_env) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + repl_env = New MalEnv(Nothing) + + ' core.vb: defined using VB.NET + For Each entry As KeyValuePair(Of String,MalVal) In core.ns() + repl_env.do_set(new MalSymbol(entry.Key), entry.Value) + Next + repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) + Dim fileIdx As Integer = 1 + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + fileIdx = 2 + End If + Dim argv As New MalList() + For i As Integer = fileIdx+1 To args.Length-1 + argv.conj_BANG(new MalString(args(i))) + Next + repl_env.do_set(new MalSymbol("*ARGV*"), argv) + + ' core.mal: defined using the language itself + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") + 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)))))))") + + If args.Length > fileIdx Then + REP("(load-file """ & args(fileIdx) & """)") + return 0 + End If + + ' repl loop + Dim line As String + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e As Mal.types.MalException + Console.WriteLine("Error: " & _ + printer._pr_str(e.getValue(), False)) + Continue Do + Catch e As Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/stepA_mal.vb b/impls/vb/stepA_mal.vb index ba289f5c3c..c970a3c547 100644 --- a/impls/vb/stepA_mal.vb +++ b/impls/vb/stepA_mal.vb @@ -1,331 +1,331 @@ -Imports System -Imports System.IO -Imports System.Collections.Generic -Imports Mal -Imports MalVal = Mal.types.MalVal -Imports MalInt = Mal.types.MalInt -Imports MalString = Mal.types.MalString -Imports MalSymbol = Mal.types.MalSymbol -Imports MalList = Mal.types.MalList -Imports MalVector = Mal.types.MalVector -Imports MalHashMap = Mal.types.MalHashMap -Imports MalFunc = Mal.types.MalFunc -Imports MalEnv = Mal.env.Env - -Namespace Mal - Class stepA_mal - ' read - Shared Function READ(str As String) As MalVal - Return reader.read_str(str) - End Function - - ' eval - Shared Function starts_with(ast As Malval, sym As String) As MalVal - If ast.list_Q() Then - Const lst As MalList = DirectCast(ast, MalList) - If 0 < lst.size() Then - Const fst As MalSymbol = TryCast(lst(0), MalSymbol) - If fst IsNot Nothing AndAlso fst.getName() = sym Then - return lst(1) - End If - End If - End If - return Nothing - End Function - - Shared Function quasiquote(ast As MalVal) As MalVal - If TypeOf ast Is Mal.types.MalSymbol or Typeof ast Is Mal.types.MalHashMap Then - return New MalList(New MalSymbol("quote"), ast) - End If - Const source As MalList = TryCast(ast, MalList) - If source Is Nothing Then - return ast - End If - Const unquoted As MalVal = starts_with(ast, "unquote") - If unquoted IsNot Nothing Then - return unquoted - End If - Dim result As MalList = New MalList() - For i As Integer = source.size()-1 To 0 Step -1 - Const elt As MalVal = source(i) - Const splice_unquoted As MalVal = starts_with(elt, "splice-unquote") - If splice_unquoted IsNot Nothing Then - result = New MalList(New MalSymbol("concat"), splice_unquoted, result) - Else - result = New MalList(New MalSymbol("cons"), quasiquote(elt), result) - End If - Next - If TypeOf ast Is MalVector Then - result = New MalList(New MalSymbol("vec"), result) - End If - return result - End Function - - Shared Function is_macro_call(ast As MalVal, env As MalEnv) As Boolean - If TypeOf ast Is MalList Then - Dim a0 As MalVal = DirectCast(ast,MalList)(0) - If TypeOf a0 Is MalSymbol AndAlso _ - env.find(DirectCast(a0,MalSymbol)) IsNot Nothing Then - Dim mac As MalVal = env.do_get(DirectCast(a0,MalSymbol)) - If TypeOf mac Is MalFunc AndAlso _ - DirectCast(mac,MalFunc).isMacro() Then - return True - End If - End If - End If - return False - End Function - - Shared Function macroexpand(ast As MalVal, env As MalEnv) As MalVal - While is_macro_call(ast, env) - Dim a0 As MalSymbol = DirectCast(DirectCast(ast,MalList)(0),MalSymbol) - Dim mac As MalFunc = DirectCast(env.do_get(a0),MalFunc) - ast = mac.apply(DirectCast(ast,MalList).rest()) - End While - return ast - End Function - - Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal - If TypeOf ast Is MalSymbol Then - return env.do_get(DirectCast(ast, MalSymbol)) - Else If TypeOf ast Is MalList Then - Dim old_lst As MalList = DirectCast(ast, MalList) - Dim new_lst As MalList - If ast.list_Q() Then - new_lst = New MalList - Else - new_lst = DirectCast(New MalVector, MalList) - End If - Dim mv As MalVal - For Each mv in old_lst.getValue() - new_lst.conj_BANG(EVAL(mv, env)) - Next - return new_lst - Else If TypeOf ast Is MalHashMap Then - Dim new_dict As New Dictionary(Of String, MalVal) - Dim entry As KeyValuePair(Of String, MalVal) - For Each entry in DirectCast(ast,MalHashMap).getValue() - new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) - Next - return New MalHashMap(new_dict) - Else - return ast - End If - return ast - End Function - - ' TODO: move to types.vb when it is ported - Class FClosure - Public ast As MalVal - Public params As MalList - Public env As MalEnv - Function fn(args as MalList) As MalVal - return EVAL(ast, new MalEnv(env, params, args)) - End Function - End Class - - Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal - Do - - 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) - If not orig_ast.list_Q() Then - return eval_ast(orig_ast, env) - End If - - ' apply list - Dim expanded As MalVal = macroexpand(orig_ast, env) - if not expanded.list_Q() Then - return eval_ast(expanded, env) - End If - Dim ast As MalList = DirectCast(expanded, MalList) - - If ast.size() = 0 Then - return ast - End If - Dim a0 As MalVal = ast(0) - Dim a0sym As String - If TypeOf a0 is MalSymbol Then - a0sym = DirectCast(a0,MalSymbol).getName() - Else - a0sym = "__<*fn*>__" - End If - - Select a0sym - Case "def!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "let*" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim key As MalSymbol - Dim val as MalVal - Dim let_env As new MalEnv(env) - For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 - key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) - val = DirectCast(a1,MalList)(i+1) - let_env.do_set(key, EVAL(val, let_env)) - Next - orig_ast = a2 - env = let_env - Case "quote" - return ast(1) - Case "quasiquoteexpand" - return quasiquote(ast(1)) - Case "quasiquote" - orig_ast = quasiquote(ast(1)) - Case "defmacro!" - Dim a1 As MalVal = ast(1) - Dim a2 As MalVal = ast(2) - Dim res As MalVal = EVAL(a2, env) - DirectCast(res,MalFunc).setMacro() - env.do_set(DirectCast(a1,MalSymbol), res) - return res - Case "macroexpand" - Dim a1 As MalVal = ast(1) - return macroexpand(a1, env) - Case "try*" - Try - return EVAL(ast(1), env) - Catch e As Exception - If ast.size() > 2 Then - Dim exc As MalVal - Dim a2 As MalVal = ast(2) - Dim a20 As MalVal = DirectCast(a2,MalList)(0) - If DirectCast(a20,MalSymbol).getName() = "catch*" Then - If TypeOf e Is Mal.types.MalException Then - exc = DirectCast(e,Mal.types.MalException).getValue() - Else - exc = New MalString(e.Message) - End If - return EVAL( - DirectCast(a2,MalList)(2), - New MalEnv(env, - DirectCast(a2,MalList).slice(1,2), - New MalList(exc))) - End If - End If - Throw e - End Try - Case "do" - eval_ast(ast.slice(1, ast.size()-1), env) - orig_ast = ast(ast.size()-1) - Case "if" - Dim a1 As MalVal = ast(1) - Dim cond As MalVal = EVAL(a1, env) - If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then - ' eval false slot form - If ast.size() > 3 Then - orig_ast = ast(3) - Else - return Mal.types.Nil - End If - Else - ' eval true slot form - orig_ast = ast(2) - - End If - Case "fn*" - Dim fc As New FClosure() - fc.ast = ast(2) - fc.params = DirectCast(ast(1),MalLIst) - fc.env = env - Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn - Dim mf As new MalFunc(ast(2), env, - DirectCast(ast(1),MalList), f) - return DirectCast(mf,MalVal) - Case Else - Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) - Dim f As MalFunc = DirectCast(el(0), MalFunc) - Dim fnast As MalVal = f.getAst() - If not fnast Is Nothing - orig_ast = fnast - env = f.genEnv(el.rest()) - Else - Return f.apply(el.rest()) - End If - End Select - - Loop While True - End Function - - ' print - Shared Function PRINT(exp As MalVal) As String - return printer._pr_str(exp, TRUE) - End Function - - ' repl - Shared repl_env As MalEnv - - Shared Function REP(str As String) As String - Return PRINT(EVAL(READ(str), repl_env)) - End Function - - Shared Function do_eval(args As MalList) As MalVal - Return EVAL(args(0), repl_env) - End Function - - Shared Function Main As Integer - Dim args As String() = Environment.GetCommandLineArgs() - - repl_env = New MalEnv(Nothing) - - ' core.vb: defined using VB.NET - For Each entry As KeyValuePair(Of String,MalVal) In core.ns() - repl_env.do_set(new MalSymbol(entry.Key), entry.Value) - Next - repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) - Dim fileIdx As Integer = 1 - If args.Length > 1 AndAlso args(1) = "--raw" Then - Mal.readline.SetMode(Mal.readline.Modes.Raw) - fileIdx = 2 - End If - Dim argv As New MalList() - For i As Integer = fileIdx+1 To args.Length-1 - argv.conj_BANG(new MalString(args(i))) - Next - repl_env.do_set(new MalSymbol("*ARGV*"), argv) - - ' core.mal: defined using the language itself - REP("(def! *host-language* ""VB.NET"")") - REP("(def! not (fn* (a) (if a false true)))") - REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") - 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)))))))") - - If args.Length > fileIdx Then - REP("(load-file """ & args(fileIdx) & """)") - return 0 - End If - - ' repl loop - Dim line As String - REP("(println (str ""Mal ["" *host-language* ""]""))") - Do - Try - line = Mal.readline.Readline("user> ") - If line is Nothing Then - Exit Do - End If - If line = "" Then - Continue Do - End If - Catch e As IOException - Console.WriteLine("IOException: " & e.Message) - End Try - Try - Console.WriteLine(REP(line)) - Catch e As Mal.types.MalException - Console.WriteLine("Error: " & _ - printer._pr_str(e.getValue(), False)) - Continue Do - Catch e As Exception - Console.WriteLine("Error: " & e.Message) - Console.WriteLine(e.StackTrace) - Continue Do - End Try - Loop While True - End function - End Class -End Namespace +Imports System +Imports System.IO +Imports System.Collections.Generic +Imports Mal +Imports MalVal = Mal.types.MalVal +Imports MalInt = Mal.types.MalInt +Imports MalString = Mal.types.MalString +Imports MalSymbol = Mal.types.MalSymbol +Imports MalList = Mal.types.MalList +Imports MalVector = Mal.types.MalVector +Imports MalHashMap = Mal.types.MalHashMap +Imports MalFunc = Mal.types.MalFunc +Imports MalEnv = Mal.env.Env + +Namespace Mal + Class stepA_mal + ' read + Shared Function READ(str As String) As MalVal + Return reader.read_str(str) + End Function + + ' eval + Shared Function starts_with(ast As Malval, sym As String) As MalVal + If ast.list_Q() Then + Const lst As MalList = DirectCast(ast, MalList) + If 0 < lst.size() Then + Const fst As MalSymbol = TryCast(lst(0), MalSymbol) + If fst IsNot Nothing AndAlso fst.getName() = sym Then + return lst(1) + End If + End If + End If + return Nothing + End Function + + Shared Function quasiquote(ast As MalVal) As MalVal + If TypeOf ast Is Mal.types.MalSymbol or Typeof ast Is Mal.types.MalHashMap Then + return New MalList(New MalSymbol("quote"), ast) + End If + Const source As MalList = TryCast(ast, MalList) + If source Is Nothing Then + return ast + End If + Const unquoted As MalVal = starts_with(ast, "unquote") + If unquoted IsNot Nothing Then + return unquoted + End If + Dim result As MalList = New MalList() + For i As Integer = source.size()-1 To 0 Step -1 + Const elt As MalVal = source(i) + Const splice_unquoted As MalVal = starts_with(elt, "splice-unquote") + If splice_unquoted IsNot Nothing Then + result = New MalList(New MalSymbol("concat"), splice_unquoted, result) + Else + result = New MalList(New MalSymbol("cons"), quasiquote(elt), result) + End If + Next + If TypeOf ast Is MalVector Then + result = New MalList(New MalSymbol("vec"), result) + End If + return result + End Function + + Shared Function is_macro_call(ast As MalVal, env As MalEnv) As Boolean + If TypeOf ast Is MalList Then + Dim a0 As MalVal = DirectCast(ast,MalList)(0) + If TypeOf a0 Is MalSymbol AndAlso _ + env.find(DirectCast(a0,MalSymbol)) IsNot Nothing Then + Dim mac As MalVal = env.do_get(DirectCast(a0,MalSymbol)) + If TypeOf mac Is MalFunc AndAlso _ + DirectCast(mac,MalFunc).isMacro() Then + return True + End If + End If + End If + return False + End Function + + Shared Function macroexpand(ast As MalVal, env As MalEnv) As MalVal + While is_macro_call(ast, env) + Dim a0 As MalSymbol = DirectCast(DirectCast(ast,MalList)(0),MalSymbol) + Dim mac As MalFunc = DirectCast(env.do_get(a0),MalFunc) + ast = mac.apply(DirectCast(ast,MalList).rest()) + End While + return ast + End Function + + Shared Function eval_ast(ast As MalVal, env As MalEnv) As MalVal + If TypeOf ast Is MalSymbol Then + return env.do_get(DirectCast(ast, MalSymbol)) + Else If TypeOf ast Is MalList Then + Dim old_lst As MalList = DirectCast(ast, MalList) + Dim new_lst As MalList + If ast.list_Q() Then + new_lst = New MalList + Else + new_lst = DirectCast(New MalVector, MalList) + End If + Dim mv As MalVal + For Each mv in old_lst.getValue() + new_lst.conj_BANG(EVAL(mv, env)) + Next + return new_lst + Else If TypeOf ast Is MalHashMap Then + Dim new_dict As New Dictionary(Of String, MalVal) + Dim entry As KeyValuePair(Of String, MalVal) + For Each entry in DirectCast(ast,MalHashMap).getValue() + new_dict.Add(entry.Key, EVAL(DirectCast(entry.Value,MalVal), env)) + Next + return New MalHashMap(new_dict) + Else + return ast + End If + return ast + End Function + + ' TODO: move to types.vb when it is ported + Class FClosure + Public ast As MalVal + Public params As MalList + Public env As MalEnv + Function fn(args as MalList) As MalVal + return EVAL(ast, new MalEnv(env, params, args)) + End Function + End Class + + Shared Function EVAL(orig_ast As MalVal, env As MalEnv) As MalVal + Do + + 'Console.WriteLine("EVAL: {0}", printer._pr_str(orig_ast, true)) + If not orig_ast.list_Q() Then + return eval_ast(orig_ast, env) + End If + + ' apply list + Dim expanded As MalVal = macroexpand(orig_ast, env) + if not expanded.list_Q() Then + return eval_ast(expanded, env) + End If + Dim ast As MalList = DirectCast(expanded, MalList) + + If ast.size() = 0 Then + return ast + End If + Dim a0 As MalVal = ast(0) + Dim a0sym As String + If TypeOf a0 is MalSymbol Then + a0sym = DirectCast(a0,MalSymbol).getName() + Else + a0sym = "__<*fn*>__" + End If + + Select a0sym + Case "def!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "let*" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim key As MalSymbol + Dim val as MalVal + Dim let_env As new MalEnv(env) + For i As Integer = 0 To (DirectCast(a1,MalList)).size()-1 Step 2 + key = DirectCast(DirectCast(a1,MalList)(i),MalSymbol) + val = DirectCast(a1,MalList)(i+1) + let_env.do_set(key, EVAL(val, let_env)) + Next + orig_ast = a2 + env = let_env + Case "quote" + return ast(1) + Case "quasiquoteexpand" + return quasiquote(ast(1)) + Case "quasiquote" + orig_ast = quasiquote(ast(1)) + Case "defmacro!" + Dim a1 As MalVal = ast(1) + Dim a2 As MalVal = ast(2) + Dim res As MalVal = EVAL(a2, env) + DirectCast(res,MalFunc).setMacro() + env.do_set(DirectCast(a1,MalSymbol), res) + return res + Case "macroexpand" + Dim a1 As MalVal = ast(1) + return macroexpand(a1, env) + Case "try*" + Try + return EVAL(ast(1), env) + Catch e As Exception + If ast.size() > 2 Then + Dim exc As MalVal + Dim a2 As MalVal = ast(2) + Dim a20 As MalVal = DirectCast(a2,MalList)(0) + If DirectCast(a20,MalSymbol).getName() = "catch*" Then + If TypeOf e Is Mal.types.MalException Then + exc = DirectCast(e,Mal.types.MalException).getValue() + Else + exc = New MalString(e.Message) + End If + return EVAL( + DirectCast(a2,MalList)(2), + New MalEnv(env, + DirectCast(a2,MalList).slice(1,2), + New MalList(exc))) + End If + End If + Throw e + End Try + Case "do" + eval_ast(ast.slice(1, ast.size()-1), env) + orig_ast = ast(ast.size()-1) + Case "if" + Dim a1 As MalVal = ast(1) + Dim cond As MalVal = EVAL(a1, env) + If cond Is Mal.types.Nil or cond Is Mal.types.MalFalse Then + ' eval false slot form + If ast.size() > 3 Then + orig_ast = ast(3) + Else + return Mal.types.Nil + End If + Else + ' eval true slot form + orig_ast = ast(2) + + End If + Case "fn*" + Dim fc As New FClosure() + fc.ast = ast(2) + fc.params = DirectCast(ast(1),MalLIst) + fc.env = env + Dim f As Func(Of MalList, MalVal) = AddressOf fc.fn + Dim mf As new MalFunc(ast(2), env, + DirectCast(ast(1),MalList), f) + return DirectCast(mf,MalVal) + Case Else + Dim el As MalList = DirectCast(eval_ast(ast, env), MalList) + Dim f As MalFunc = DirectCast(el(0), MalFunc) + Dim fnast As MalVal = f.getAst() + If not fnast Is Nothing + orig_ast = fnast + env = f.genEnv(el.rest()) + Else + Return f.apply(el.rest()) + End If + End Select + + Loop While True + End Function + + ' print + Shared Function PRINT(exp As MalVal) As String + return printer._pr_str(exp, TRUE) + End Function + + ' repl + Shared repl_env As MalEnv + + Shared Function REP(str As String) As String + Return PRINT(EVAL(READ(str), repl_env)) + End Function + + Shared Function do_eval(args As MalList) As MalVal + Return EVAL(args(0), repl_env) + End Function + + Shared Function Main As Integer + Dim args As String() = Environment.GetCommandLineArgs() + + repl_env = New MalEnv(Nothing) + + ' core.vb: defined using VB.NET + For Each entry As KeyValuePair(Of String,MalVal) In core.ns() + repl_env.do_set(new MalSymbol(entry.Key), entry.Value) + Next + repl_env.do_set(new MalSymbol("eval"), new MalFunc(AddressOf do_eval)) + Dim fileIdx As Integer = 1 + If args.Length > 1 AndAlso args(1) = "--raw" Then + Mal.readline.SetMode(Mal.readline.Modes.Raw) + fileIdx = 2 + End If + Dim argv As New MalList() + For i As Integer = fileIdx+1 To args.Length-1 + argv.conj_BANG(new MalString(args(i))) + Next + repl_env.do_set(new MalSymbol("*ARGV*"), argv) + + ' core.mal: defined using the language itself + REP("(def! *host-language* ""VB.NET"")") + REP("(def! not (fn* (a) (if a false true)))") + REP("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))") + 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)))))))") + + If args.Length > fileIdx Then + REP("(load-file """ & args(fileIdx) & """)") + return 0 + End If + + ' repl loop + Dim line As String + REP("(println (str ""Mal ["" *host-language* ""]""))") + Do + Try + line = Mal.readline.Readline("user> ") + If line is Nothing Then + Exit Do + End If + If line = "" Then + Continue Do + End If + Catch e As IOException + Console.WriteLine("IOException: " & e.Message) + End Try + Try + Console.WriteLine(REP(line)) + Catch e As Mal.types.MalException + Console.WriteLine("Error: " & _ + printer._pr_str(e.getValue(), False)) + Continue Do + Catch e As Exception + Console.WriteLine("Error: " & e.Message) + Console.WriteLine(e.StackTrace) + Continue Do + End Try + Loop While True + End function + End Class +End Namespace diff --git a/impls/vb/tests/step5_tco.mal b/impls/vb/tests/step5_tco.mal index 3631fdf53f..318bb43b01 100644 --- a/impls/vb/tests/step5_tco.mal +++ b/impls/vb/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; VB: skipping non-TCO recursion -;; Reason: unrecoverable segfault at 10,000 +;; VB: skipping non-TCO recursion +;; Reason: unrecoverable segfault at 10,000 diff --git a/impls/vb/types.vb b/impls/vb/types.vb index 711011ece6..02d95f0273 100644 --- a/impls/vb/types.vb +++ b/impls/vb/types.vb @@ -1,473 +1,473 @@ -Imports System -Imports System.Collections.Generic -Imports System.Text.RegularExpressions -Imports Mal - -namespace Mal - Public Class types - ' - ' Exceptions/Errors - ' - Public Class MalThrowable - Inherits Exception - Public Sub New() - MyBase.New() - End Sub - Public Sub New(msg As String) - MyBase.New(msg) - End Sub - End Class - Public Class MalError - Inherits MalThrowable - Public Sub New(msg As String) - MyBase.New(msg) - End Sub - End Class - Public Class MalContinue - Inherits MalThrowable - End Class - - ' Thrown by throw function - Public Class MalException - Inherits MalThrowable - Private value As MalVal - - 'string Message - Public Sub New(new_value As MalVal) - value = new_value - End Sub - Public Sub New(new_value As String) - MyBase.New(new_value) - value = New MalString(new_value) - End Sub - Public Function getValue() As MalVal - return value - End Function - End Class - - ' - ' General functions - ' - Public Shared Function _equal_Q(a As MalVal, b As MalVal) As Boolean - Dim ota As Type = a.GetType() - Dim otb As Type = b.GetType() - If not (ota = otb Or - (TypeOf a Is MalList and TypeOf b Is MalList)) Then - return False - Else - If TypeOf a Is MalInt Then - return DirectCast(a,MalInt).getValue() = - DirectCast(b,MalInt).getValue() - Else If TypeOf a Is MalSymbol Then - return DirectCast(a,MalSymbol).getName() = - DirectCast(b,MalSymbol).getName() - Else If TypeOf a Is MalString Then - return DirectCast(a,MalString).getValue() = - DirectCast(b,MalString).getValue() - Else If TypeOf a Is MalList Then - If DirectCast(a,MalList).size() <> - DirectCast(b,MalList).size() - return False - End If - for i As Integer = 0 To DirectCast(a,MalList).size()-1 - If not _equal_Q(DirectCast(a,MalList)(i), - DirectCast(b,MalList)(i)) - return False - End If - Next - return True - Else If TypeOf a Is MalHashMap Then - Dim ahm As Dictionary(Of String,MalVal) = DirectCast(a,MalHashMap).getValue() - Dim bhm As Dictionary(Of String,MalVal) = DirectCast(b,MalHashMap).getValue() - For Each key As String in ahm.keys - If not bhm.ContainsKey(key) Then - return False - End If - If not _equal_Q(DirectCast(a,MalHashMap).getValue()(key), - DirectCast(b,MalHashMap).getValue()(key)) - return False - End If - Next - return True - Else - return a Is b - End If - End If - End Function - - - Public MustInherit Class MalVal - Private meta As MalVal = Nil - Public Overridable Function copy() As MalVal - return DirectCast(Me.MemberwiseClone(),MalVal) - End Function - - ' Default is just to call regular toString() - Public Overridable Function ToString() As String - throw New MalException("ToString called on abstract MalVal") - End Function - Public Overridable Function ToString(print_readably As Boolean) As String - return Me.ToString() - End Function - Public Function getMeta() As MalVal - return meta - End Function - Public Function setMeta(m As MalVal) As MalVal - meta = m - return Me - End Function - Public Overridable Function list_Q() As Boolean - return False - End Function - End Class - - Public Class MalConstant - Inherits MalVal - Private value As String - Public Sub New(name As String) - value = name - End Sub - Public Shadows Function copy() As MalConstant - return Me - End Function - - Public Overrides Function ToString() As String - return value - End Function - Public Overrides Function ToString(print_readably As Boolean) As String - return value - End Function - End Class - - Public Shared Nil As MalConstant = New MalConstant("nil") - Public Shared MalTrue As MalConstant = New MalConstant("true") - Public Shared MalFalse As MalConstant = New MalConstant("false") - - Public Class MalInt - Inherits MalVal - Private value As Int64 - Public Sub New(v As Int64) - value = v - End Sub - Public Shadows Function copy() As MalInt - return Me - End Function - - Public Function getValue() As Int64 - return value - End Function - Public Overrides Function ToString() As String - return value.ToString() - End Function - Public Overrides Function ToString(print_readably As Boolean) As String - return value.ToString() - End Function - Public Shared Operator <(a As MalInt, b As Malint) As MalConstant - If a.getValue() < b.getValue() Then - return MalTrue - Else - return MalFalse - End If - End Operator - Public Shared Operator <=(a As MalInt, b As Malint) As MalConstant - If a.getValue() <= b.getValue() Then - return MalTrue - Else - return MalFalse - End If - End Operator - Public Shared Operator >(a As MalInt, b As Malint) As MalConstant - If a.getValue() > b.getValue() Then - return MalTrue - Else - return MalFalse - End If - End Operator - Public Shared Operator >=(a As MalInt, b As Malint) As MalConstant - If a.getValue() >= b.getValue() Then - return MalTrue - Else - return MalFalse - End If - End Operator - Public Shared Operator +(a As MalInt, b As Malint) As MalInt - return new MalInt(a.getValue() + b.getValue()) - End Operator - Public Shared Operator -(a As MalInt, b As Malint) As MalInt - return new MalInt(a.getValue() - b.getValue()) - End Operator - Public Shared Operator *(a As MalInt, b As Malint) As MalInt - return new MalInt(a.getValue() * b.getValue()) - End Operator - Public Shared Operator /(a As MalInt, b As Malint) As MalInt - return new MalInt(a.getValue() / b.getValue()) - End Operator - End Class - - Public Class MalSymbol - Inherits MalVal - Private value As String - Public Sub New(v As String) - value = v - End Sub - Public Sub New(v As MalString) - value = v.getValue() - End Sub - Public Shadows Function copy() As MalSymbol - return Me - End Function - - Public Function getName() As String - return value - End Function - Public Overrides Function ToString() As String - return value - End Function - Public Overrides Function ToString(print_readably As Boolean) As String - return value - End Function - End Class - - Public Class MalString - Inherits MalVal - Private value As String - Public Sub New(v As String) - value = v - End Sub - Public Shadows Function copy() As MalString - return Me - End Function - - Public Function getValue() As String - return value - End Function - Public Overrides Function ToString() As String - return """" & value & """" - End Function - Public Overrides Function ToString(print_readably As Boolean) As String - If value.Length > 0 AndAlso value(0) = ChrW(&H029e) Then - return ":" & value.Substring(1) - Else If print_readably Then - return """" & _ - value.Replace("\", "\\") _ - .Replace("""", "\""") _ - .Replace(Environment.NewLine, "\n") & _ - """" - Else - return value - End If - End Function - End Class - - - Public Class MalList - Inherits MalVal - Public start As String = "(" - Public last As String = ")" - Private value As List(Of MalVal) - Public Sub New() - value = New List(Of MalVal) - End Sub - Public Sub New(val As List(Of MalVal)) - value = val - End Sub - Public Sub New(ParamArray mvs() As MalVal) - value = New List(Of MalVal) - conj_BANG(mvs) - End Sub - - Public Function getValue() As List(Of MalVal) - return value - End Function - Public Overrides Function list_Q() As Boolean - return True - End Function - - Public Overrides Function ToString() As String - return start & printer.join(value, " ", true) & last - End Function - Public Overrides Function ToString(print_readably As Boolean) As String - return start & printer.join(value, " ", print_readably) & last - End Function - - Public Function conj_BANG(ParamArray mvs() As MalVal) As MalList - For i As Integer = 0 To mvs.Length-1 - value.Add(mvs(i)) - Next - return Me - End Function - - Public Function size() As Int64 - return value.Count - End Function - Public Function nth(ByVal idx As Integer) As MalVal - If value.Count > idx Then - return value(idx) - Else - return Nil - End If - End Function - Default Public ReadOnly Property Item(idx As Integer) As MalVal - Get - If value.Count > idx then - return value(idx) - Else - return Nil - End If - End Get - End Property - Public Function rest() As MalList - If size() > 0 Then - return New MalList(value.GetRange(1, value.Count-1)) - Else - return New MalList() - End If - End Function - Public Overridable Function slice(start As Int64) As MalList - return New MalList(value.GetRange(start, value.Count-start)) - End Function - Public Overridable Function slice(start As Int64, last As Int64) As MalList - return New MalList(value.GetRange(start, last-start)) - End Function - End Class - - Public Class MalVector - Inherits MalList -' ' Same implementation except for instantiation methods - Public Sub New() - MyBase.New() - start = "[" - last = "]" - End Sub - Public Sub New(val As List(Of MalVal)) - MyBase.New(val) - start = "[" - last = "]" - End Sub - - Public Overrides Function list_Q() As Boolean - return False - End Function - - Public Overrides Function slice(start As Int64, last As Int64) As MalList - Dim val As List(Of MalVal) = Me.getValue() - return New MalVector(val.GetRange(start, val.Count-start)) - End Function - End Class - - Public Class MalHashMap - Inherits MalVal - Private value As Dictionary(Of string, MalVal) - Public Sub New(val As Dictionary(Of String, MalVal)) - value = val - End Sub - Public Sub New(lst As MalList) - value = New Dictionary(Of String, MalVal) - assoc_BANG(lst) - End Sub - Public Shadows Function copy() As MalHashMap - Dim new_self As MalHashMap = DirectCast(Me.MemberwiseClone(),MalHashMap) - new_self.value = New Dictionary(Of String, MalVal)(value) - return new_self - End Function - - Public Function getValue() As Dictionary(Of String, MalVal) - return value - End Function - - Public Overrides Function ToString() As String - return "{" & printer.join(value, " ", true) & "}" - End Function - Public Overrides Function ToString(print_readably As Boolean) As String - return "{" & printer.join(value, " ", print_readably) & "}" - End Function - - Public Function assoc_BANG(lst As MalList) As MalHashMap - For i As Integer = 0 To lst.size()-1 Step 2 - value(DirectCast(lst(i),MalString).getValue()) = lst(i+1) - Next - return Me - End Function - - Public Function dissoc_BANG(lst As MalList) As MalHashMap - for i As Integer = 0 To lst.size()-1 - value.Remove(DirectCast(lst.nth(i),MalString).getValue()) - Next - return Me - End Function - End Class - - Public Class MalAtom - Inherits MalVal - Private value As MalVal - Public Sub New(val As MalVal) - value = val - End Sub - 'Public MalAtom copy() { return New MalAtom(value) } - Public Function getValue() As MalVal - return value - End Function - Public Function setValue(val As MalVal) As MalVal - value = val - return value - End Function - Public Overrides Function ToString() As String - return "(atom " & printer._pr_str(value, true) & ")" - End Function - Public Overrides Function ToString(print_readably As Boolean) As String - return "(atom " & printer._pr_str(value, print_readably) & ")" - End Function - End Class - - Public Class MalFunc - Inherits MalVal - Private fn As Func(Of MalList, MalVal) = Nothing - Private ast As MalVal = Nothing - Private env As Mal.env.Env = Nothing - Private fparams As MalList - Private macro As Boolean = False - Public Sub New(new_fn As Func(Of MalList, MalVal)) - fn = new_fn - End Sub - Public Sub New(new_ast As MalVal, new_env As Mal.env.Env, - new_fparams As MalList, new_fn As Func(Of MalList, MalVal)) - fn = new_fn - ast = new_ast - env = new_env - fparams = new_fparams - End Sub - - Public Overrides Function ToString() As String - If Not ast Is Nothing Then - return "" - Else - return "" - End If - End Function - - Public Function apply(args As MalList) As MalVal - return fn(args) - End Function - - Public Function getAst() As MalVal - return ast - End Function - Public Function getEnv() As Mal.env.Env - return env - End Function - Public Function getFParams() As MalList - return fparams - End Function - Public Function genEnv(args As MalList) As Mal.env.Env - return New Mal.env.Env(env, fparams, args) - End Function - Public Function isMacro() As Boolean - return macro - End Function - Public Sub setMacro() - macro = true - End Sub - End Class - End Class -End Namespace +Imports System +Imports System.Collections.Generic +Imports System.Text.RegularExpressions +Imports Mal + +namespace Mal + Public Class types + ' + ' Exceptions/Errors + ' + Public Class MalThrowable + Inherits Exception + Public Sub New() + MyBase.New() + End Sub + Public Sub New(msg As String) + MyBase.New(msg) + End Sub + End Class + Public Class MalError + Inherits MalThrowable + Public Sub New(msg As String) + MyBase.New(msg) + End Sub + End Class + Public Class MalContinue + Inherits MalThrowable + End Class + + ' Thrown by throw function + Public Class MalException + Inherits MalThrowable + Private value As MalVal + + 'string Message + Public Sub New(new_value As MalVal) + value = new_value + End Sub + Public Sub New(new_value As String) + MyBase.New(new_value) + value = New MalString(new_value) + End Sub + Public Function getValue() As MalVal + return value + End Function + End Class + + ' + ' General functions + ' + Public Shared Function _equal_Q(a As MalVal, b As MalVal) As Boolean + Dim ota As Type = a.GetType() + Dim otb As Type = b.GetType() + If not (ota = otb Or + (TypeOf a Is MalList and TypeOf b Is MalList)) Then + return False + Else + If TypeOf a Is MalInt Then + return DirectCast(a,MalInt).getValue() = + DirectCast(b,MalInt).getValue() + Else If TypeOf a Is MalSymbol Then + return DirectCast(a,MalSymbol).getName() = + DirectCast(b,MalSymbol).getName() + Else If TypeOf a Is MalString Then + return DirectCast(a,MalString).getValue() = + DirectCast(b,MalString).getValue() + Else If TypeOf a Is MalList Then + If DirectCast(a,MalList).size() <> + DirectCast(b,MalList).size() + return False + End If + for i As Integer = 0 To DirectCast(a,MalList).size()-1 + If not _equal_Q(DirectCast(a,MalList)(i), + DirectCast(b,MalList)(i)) + return False + End If + Next + return True + Else If TypeOf a Is MalHashMap Then + Dim ahm As Dictionary(Of String,MalVal) = DirectCast(a,MalHashMap).getValue() + Dim bhm As Dictionary(Of String,MalVal) = DirectCast(b,MalHashMap).getValue() + For Each key As String in ahm.keys + If not bhm.ContainsKey(key) Then + return False + End If + If not _equal_Q(DirectCast(a,MalHashMap).getValue()(key), + DirectCast(b,MalHashMap).getValue()(key)) + return False + End If + Next + return True + Else + return a Is b + End If + End If + End Function + + + Public MustInherit Class MalVal + Private meta As MalVal = Nil + Public Overridable Function copy() As MalVal + return DirectCast(Me.MemberwiseClone(),MalVal) + End Function + + ' Default is just to call regular toString() + Public Overridable Function ToString() As String + throw New MalException("ToString called on abstract MalVal") + End Function + Public Overridable Function ToString(print_readably As Boolean) As String + return Me.ToString() + End Function + Public Function getMeta() As MalVal + return meta + End Function + Public Function setMeta(m As MalVal) As MalVal + meta = m + return Me + End Function + Public Overridable Function list_Q() As Boolean + return False + End Function + End Class + + Public Class MalConstant + Inherits MalVal + Private value As String + Public Sub New(name As String) + value = name + End Sub + Public Shadows Function copy() As MalConstant + return Me + End Function + + Public Overrides Function ToString() As String + return value + End Function + Public Overrides Function ToString(print_readably As Boolean) As String + return value + End Function + End Class + + Public Shared Nil As MalConstant = New MalConstant("nil") + Public Shared MalTrue As MalConstant = New MalConstant("true") + Public Shared MalFalse As MalConstant = New MalConstant("false") + + Public Class MalInt + Inherits MalVal + Private value As Int64 + Public Sub New(v As Int64) + value = v + End Sub + Public Shadows Function copy() As MalInt + return Me + End Function + + Public Function getValue() As Int64 + return value + End Function + Public Overrides Function ToString() As String + return value.ToString() + End Function + Public Overrides Function ToString(print_readably As Boolean) As String + return value.ToString() + End Function + Public Shared Operator <(a As MalInt, b As Malint) As MalConstant + If a.getValue() < b.getValue() Then + return MalTrue + Else + return MalFalse + End If + End Operator + Public Shared Operator <=(a As MalInt, b As Malint) As MalConstant + If a.getValue() <= b.getValue() Then + return MalTrue + Else + return MalFalse + End If + End Operator + Public Shared Operator >(a As MalInt, b As Malint) As MalConstant + If a.getValue() > b.getValue() Then + return MalTrue + Else + return MalFalse + End If + End Operator + Public Shared Operator >=(a As MalInt, b As Malint) As MalConstant + If a.getValue() >= b.getValue() Then + return MalTrue + Else + return MalFalse + End If + End Operator + Public Shared Operator +(a As MalInt, b As Malint) As MalInt + return new MalInt(a.getValue() + b.getValue()) + End Operator + Public Shared Operator -(a As MalInt, b As Malint) As MalInt + return new MalInt(a.getValue() - b.getValue()) + End Operator + Public Shared Operator *(a As MalInt, b As Malint) As MalInt + return new MalInt(a.getValue() * b.getValue()) + End Operator + Public Shared Operator /(a As MalInt, b As Malint) As MalInt + return new MalInt(a.getValue() / b.getValue()) + End Operator + End Class + + Public Class MalSymbol + Inherits MalVal + Private value As String + Public Sub New(v As String) + value = v + End Sub + Public Sub New(v As MalString) + value = v.getValue() + End Sub + Public Shadows Function copy() As MalSymbol + return Me + End Function + + Public Function getName() As String + return value + End Function + Public Overrides Function ToString() As String + return value + End Function + Public Overrides Function ToString(print_readably As Boolean) As String + return value + End Function + End Class + + Public Class MalString + Inherits MalVal + Private value As String + Public Sub New(v As String) + value = v + End Sub + Public Shadows Function copy() As MalString + return Me + End Function + + Public Function getValue() As String + return value + End Function + Public Overrides Function ToString() As String + return """" & value & """" + End Function + Public Overrides Function ToString(print_readably As Boolean) As String + If value.Length > 0 AndAlso value(0) = ChrW(&H029e) Then + return ":" & value.Substring(1) + Else If print_readably Then + return """" & _ + value.Replace("\", "\\") _ + .Replace("""", "\""") _ + .Replace(Environment.NewLine, "\n") & _ + """" + Else + return value + End If + End Function + End Class + + + Public Class MalList + Inherits MalVal + Public start As String = "(" + Public last As String = ")" + Private value As List(Of MalVal) + Public Sub New() + value = New List(Of MalVal) + End Sub + Public Sub New(val As List(Of MalVal)) + value = val + End Sub + Public Sub New(ParamArray mvs() As MalVal) + value = New List(Of MalVal) + conj_BANG(mvs) + End Sub + + Public Function getValue() As List(Of MalVal) + return value + End Function + Public Overrides Function list_Q() As Boolean + return True + End Function + + Public Overrides Function ToString() As String + return start & printer.join(value, " ", true) & last + End Function + Public Overrides Function ToString(print_readably As Boolean) As String + return start & printer.join(value, " ", print_readably) & last + End Function + + Public Function conj_BANG(ParamArray mvs() As MalVal) As MalList + For i As Integer = 0 To mvs.Length-1 + value.Add(mvs(i)) + Next + return Me + End Function + + Public Function size() As Int64 + return value.Count + End Function + Public Function nth(ByVal idx As Integer) As MalVal + If value.Count > idx Then + return value(idx) + Else + return Nil + End If + End Function + Default Public ReadOnly Property Item(idx As Integer) As MalVal + Get + If value.Count > idx then + return value(idx) + Else + return Nil + End If + End Get + End Property + Public Function rest() As MalList + If size() > 0 Then + return New MalList(value.GetRange(1, value.Count-1)) + Else + return New MalList() + End If + End Function + Public Overridable Function slice(start As Int64) As MalList + return New MalList(value.GetRange(start, value.Count-start)) + End Function + Public Overridable Function slice(start As Int64, last As Int64) As MalList + return New MalList(value.GetRange(start, last-start)) + End Function + End Class + + Public Class MalVector + Inherits MalList +' ' Same implementation except for instantiation methods + Public Sub New() + MyBase.New() + start = "[" + last = "]" + End Sub + Public Sub New(val As List(Of MalVal)) + MyBase.New(val) + start = "[" + last = "]" + End Sub + + Public Overrides Function list_Q() As Boolean + return False + End Function + + Public Overrides Function slice(start As Int64, last As Int64) As MalList + Dim val As List(Of MalVal) = Me.getValue() + return New MalVector(val.GetRange(start, val.Count-start)) + End Function + End Class + + Public Class MalHashMap + Inherits MalVal + Private value As Dictionary(Of string, MalVal) + Public Sub New(val As Dictionary(Of String, MalVal)) + value = val + End Sub + Public Sub New(lst As MalList) + value = New Dictionary(Of String, MalVal) + assoc_BANG(lst) + End Sub + Public Shadows Function copy() As MalHashMap + Dim new_self As MalHashMap = DirectCast(Me.MemberwiseClone(),MalHashMap) + new_self.value = New Dictionary(Of String, MalVal)(value) + return new_self + End Function + + Public Function getValue() As Dictionary(Of String, MalVal) + return value + End Function + + Public Overrides Function ToString() As String + return "{" & printer.join(value, " ", true) & "}" + End Function + Public Overrides Function ToString(print_readably As Boolean) As String + return "{" & printer.join(value, " ", print_readably) & "}" + End Function + + Public Function assoc_BANG(lst As MalList) As MalHashMap + For i As Integer = 0 To lst.size()-1 Step 2 + value(DirectCast(lst(i),MalString).getValue()) = lst(i+1) + Next + return Me + End Function + + Public Function dissoc_BANG(lst As MalList) As MalHashMap + for i As Integer = 0 To lst.size()-1 + value.Remove(DirectCast(lst.nth(i),MalString).getValue()) + Next + return Me + End Function + End Class + + Public Class MalAtom + Inherits MalVal + Private value As MalVal + Public Sub New(val As MalVal) + value = val + End Sub + 'Public MalAtom copy() { return New MalAtom(value) } + Public Function getValue() As MalVal + return value + End Function + Public Function setValue(val As MalVal) As MalVal + value = val + return value + End Function + Public Overrides Function ToString() As String + return "(atom " & printer._pr_str(value, true) & ")" + End Function + Public Overrides Function ToString(print_readably As Boolean) As String + return "(atom " & printer._pr_str(value, print_readably) & ")" + End Function + End Class + + Public Class MalFunc + Inherits MalVal + Private fn As Func(Of MalList, MalVal) = Nothing + Private ast As MalVal = Nothing + Private env As Mal.env.Env = Nothing + Private fparams As MalList + Private macro As Boolean = False + Public Sub New(new_fn As Func(Of MalList, MalVal)) + fn = new_fn + End Sub + Public Sub New(new_ast As MalVal, new_env As Mal.env.Env, + new_fparams As MalList, new_fn As Func(Of MalList, MalVal)) + fn = new_fn + ast = new_ast + env = new_env + fparams = new_fparams + End Sub + + Public Overrides Function ToString() As String + If Not ast Is Nothing Then + return "" + Else + return "" + End If + End Function + + Public Function apply(args As MalList) As MalVal + return fn(args) + End Function + + Public Function getAst() As MalVal + return ast + End Function + Public Function getEnv() As Mal.env.Env + return env + End Function + Public Function getFParams() As MalList + return fparams + End Function + Public Function genEnv(args As MalList) As Mal.env.Env + return New Mal.env.Env(env, fparams, args) + End Function + Public Function isMacro() As Boolean + return macro + End Function + Public Sub setMacro() + macro = true + End Sub + End Class + End Class +End Namespace diff --git a/impls/vbs/core.vbs b/impls/vbs/core.vbs index 5ec631ca81..2a351dc837 100644 --- a/impls/vbs/core.vbs +++ b/impls/vbs/core.vbs @@ -1,866 +1,866 @@ -Option Explicit - -Sub CheckArgNum(objArgs, lngArgNum) - If objArgs.Count - 1 <> lngArgNum Then - Err.Raise vbObjectError, _ - "CheckArgNum", "Wrong number of arguments." - End IF -End Sub - -Sub CheckType(objMal, varType) - If objMal.Type <> varType Then - Err.Raise vbObjectError, _ - "CheckType", "Wrong argument type." - End IF -End Sub - -Function IsListOrVec(objMal) - IsListOrVec = _ - objMal.Type = TYPES.LIST Or _ - objMal.Type = TYPES.VECTOR -End Function - -Sub CheckListOrVec(objMal) - If Not IsListOrVec(objMal) Then - Err.Raise vbObjectError, _ - "CheckListOrVec", _ - "Wrong argument type, need a list or a vector." - End If -End Sub - -Dim objNS -Set objNS = NewEnv(Nothing) - -Function MAdd(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MAdd = NewMalNum( _ - objArgs.Item(1).Value + objArgs.Item(2).Value) -End Function -objNS.Add NewMalSym("+"), NewVbsProc("MAdd", False) - -Function MSub(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MSub = NewMalNum( _ - objArgs.Item(1).Value - objArgs.Item(2).Value) -End Function -objNS.Add NewMalSym("-"), NewVbsProc("MSub", False) - -Function MMul(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MMul = NewMalNum( _ - objArgs.Item(1).Value * objArgs.Item(2).Value) -End Function -objNS.Add NewMalSym("*"), NewVbsProc("MMul", False) - -Function MDiv(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MDiv = NewMalNum( _ - objArgs.Item(1).Value \ objArgs.Item(2).Value) -End Function -objNS.Add NewMalSym("/"), NewVbsProc("MDiv", False) - -Function MList(objArgs, objEnv) - Dim varRet - Set varRet = NewMalList(Array()) - Dim i - For i = 1 To objArgs.Count - 1 - varRet.Add objArgs.Item(i) - Next - Set MList = varRet -End Function -objNS.Add NewMalSym("list"), NewVbsProc("MList", False) - -Function MIsList(objArgs, objEnv) - CheckArgNum objArgs, 1 - - Set MIsList = NewMalBool(objArgs.Item(1).Type = TYPES.LIST) -End Function -objNS.Add NewMalSym("list?"), NewVbsProc("MIsList", False) - -Function MIsEmpty(objArgs, objEnv) - CheckArgNum objArgs, 1 - CheckListOrVec objArgs.Item(1) - - Set MIsEmpty = NewMalBool(objArgs.Item(1).Count = 0) -End Function -objNS.Add NewMalSym("empty?"), NewVbsProc("MIsEmpty", False) - -Function MCount(objArgs, objEnv) - CheckArgNum objArgs, 1 - If objArgs.Item(1).Type = TYPES.NIL Then - Set MCount = NewMalNum(0) - Else - CheckListOrVec objArgs.Item(1) - Set MCount = NewMalNum(objArgs.Item(1).Count) - End If -End Function -objNS.Add NewMalSym("count"), NewVbsProc("MCount", False) - -Function MEqual(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim boolResult, i - If IsListOrVec(objArgs.Item(1)) And _ - IsListOrVec(objArgs.Item(2)) Then - If objArgs.Item(1).Count <> objArgs.Item(2).Count Then - Set varRet = NewMalBool(False) - Else - boolResult = True - For i = 0 To objArgs.Item(1).Count - 1 - boolResult = boolResult And _ - MEqual(NewMalList(Array(Nothing, _ - objArgs.Item(1).Item(i), _ - objArgs.Item(2).Item(i))), objEnv).Value - Next - Set varRet = NewMalBool(boolResult) - End If - Else - If objArgs.Item(1).Type <> objArgs.Item(2).Type Then - Set varRet = NewMalBool(False) - Else - Select Case objArgs.Item(1).Type - Case TYPES.HASHMAP - 'Err.Raise vbObjectError, _ - ' "MEqual", "Not implement yet~" - If UBound(objArgs.Item(1).Keys) <> UBound(objArgs.Item(2).Keys) Then - Set varRet = NewMalBool(False) - Set MEqual = varRet - Exit Function - End If - - boolResult = True - For Each i In objArgs.Item(1).Keys - If Not objArgs.Item(2).Exists(i) Then - Set varRet = NewMalBool(False) - Set MEqual = varRet - Exit Function - End If - - boolResult = boolResult And _ - MEqual(NewMalList(Array(Nothing, objArgs.Item(1).Item(i), objArgs.Item(2).Item(i))), objEnv).Value - Next - Set varRet = NewMalBool(boolResult) - - Case Else - Set varRet = NewMalBool( _ - objArgs.Item(1).Value = objArgs.Item(2).Value) - End Select - End If - End If - - Set MEqual = varRet -End Function -objNS.Add NewMalSym("="), NewVbsProc("MEqual", False) - -Function MGreater(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set varRet = NewMalBool( _ - objArgs.Item(1).Value > objArgs.Item(2).Value) - Set MGreater = varRet -End Function -objNS.Add NewMalSym(">"), NewVbsProc("MGreater", False) - -Function MPrStr(objArgs, objEnv) - Dim varRet - Dim strRet - strRet = "" - Dim i - If objArgs.Count - 1 >= 1 Then - strRet = PrintMalType(objArgs.Item(1), True) - End If - For i = 2 To objArgs.Count - 1 - strRet = strRet + " " + _ - PrintMalType(objArgs.Item(i), True) - Next - Set varRet = NewMalStr(strRet) - Set MPrStr = varRet -End Function -objNS.Add NewMalSym("pr-str"), NewVbsProc("MPrStr", False) - -Function MStr(objArgs, objEnv) - Dim varRet - Dim strRet - strRet = "" - Dim i - For i = 1 To objArgs.Count - 1 - strRet = strRet + _ - PrintMalType(objArgs.Item(i), False) - Next - Set varRet = NewMalStr(strRet) - Set MStr = varRet -End Function -objNS.Add NewMalSym("str"), NewVbsProc("MStr", False) - -Function MPrn(objArgs, objEnv) - Dim varRet - Dim objStr - Set objStr = MPrStr(objArgs, objEnv) - WScript.StdOut.WriteLine objStr.Value - Set varRet = NewMalNil() - Set MPrn = varRet -End Function -objNS.Add NewMalSym("prn"), NewVbsProc("MPrn", False) - -Function MPrintln(objArgs, objEnv) - Dim varRet - Dim strRes - strRes = "" - Dim i - If objArgs.Count - 1 >= 1 Then - strRes = PrintMalType(objArgs.Item(1), False) - End If - For i = 2 To objArgs.Count - 1 - strRes = strRes + " " + _ - PrintMalType(objArgs.Item(i), False) - Next - WScript.StdOut.WriteLine strRes - Set varRet = NewMalNil() - Set MPrintln = varRet -End Function -objNS.Add NewMalSym("println"), NewVbsProc("MPrintln", False) - -Sub InitBuiltIn() - REP "(def! not (fn* [bool] (if bool false true)))" - REP "(def! <= (fn* [a b] (not (> a b))))" - REP "(def! < (fn* [a b] (> b a)))" - REP "(def! >= (fn* [a b] (not (> b a))))" - REP "(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" - REP "(def! cons (fn* [a b] (concat (list a) b)))" - REP "(def! nil? (fn* [x] (= x nil)))" - REP "(def! true? (fn* [x] (= x true)))" - REP "(def! false? (fn* [x] (= x false)))" - REP "(def! vector (fn* [& args] (vec args)))" - REP "(def! vals (fn* [hmap] (map (fn* [key] (get hmap key)) (keys hmap))))" - REP "(def! *host-language* ""VBScript"")" -End Sub - -Function MReadStr(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - CheckType objArgs.Item(1), TYPES.STRING - - Set varRes = ReadString(objArgs.Item(1).Value) - If TypeName(varRes) = "Nothing" Then - Set varRes = NewMalNil() - End If - Set MReadStr = varRes -End Function -objNS.Add NewMalSym("read-string"), NewVbsProc("MReadStr", False) - -Function MSlurp(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - CheckType objArgs.Item(1), TYPES.STRING - - Dim strRes - With CreateObject("Scripting.FileSystemObject") - strRes = .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & objArgs.Item(1).Value).ReadAll - End With - - Set varRes = NewMalStr(strRes) - Set MSlurp = varRes -End Function -objNS.Add NewMalSym("slurp"), NewVbsProc("MSlurp", False) - -Function MAtom(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = NewMalAtom(objArgs.Item(1)) - Set MAtom = varRes -End Function -objNS.Add NewMalSym("atom"), NewVbsProc("MAtom", False) - -Function MIsAtom(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.ATOM) - Set MIsAtom = varRes -End Function -objNS.Add NewMalSym("atom?"), NewVbsProc("MIsAtom", False) - -Function MDeref(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - CheckType objArgs.Item(1), TYPES.ATOM - - Set varRes = objArgs.Item(1).Value - Set MDeref = varRes -End Function -objNS.Add NewMalSym("deref"), NewVbsProc("MDeref", False) - -Function MReset(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.ATOM - - objArgs.Item(1).Reset objArgs.Item(2) - Set varRes = objArgs.Item(2) - Set MReset = varRes -End Function -objNS.Add NewMalSym("reset!"), NewVbsProc("MReset", False) - -Function MSwap(objArgs, objEnv) - Dim varRes - If objArgs.Count - 1 < 2 Then - Err.Raise vbObjectError, _ - "MSwap", "Need more arguments." - End If - - Dim objAtom, objFn - Set objAtom = objArgs.Item(1) - CheckType objAtom, TYPES.ATOM - Set objFn = objArgs.Item(2) - CheckType objFn, TYPES.PROCEDURE - - Dim objProg - Set objProg = NewMalList(Array(objFn)) - objProg.Add objAtom.Value - Dim i - For i = 3 To objArgs.Count - 1 - objProg.Add objArgs.Item(i) - Next - - objAtom.Reset objFn.ApplyWithoutEval(objProg, objEnv) - Set varRes = objAtom.Value - Set MSwap = varRes -End Function -objNS.Add NewMalSym("swap!"), NewVbsProc("MSwap", False) - -Function MConcat(objArgs, objEnv) - Dim varRes - Dim i, j - Set varRes = NewMalList(Array()) - For i = 1 To objArgs.Count - 1 - If Not IsListOrVec(objArgs.Item(i)) Then - Err.Raise vbObjectError, _ - "MConcat", "Invaild argument(s)." - End If - - For j = 0 To objArgs.Item(i).Count - 1 - varRes.Add objArgs.Item(i).Item(j) - Next - Next - Set MConcat = varRes -End Function -objNS.Add NewMalSym("concat"), NewVbsProc("MConcat", False) - -Function MVec(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - CheckListOrVec objArgs.Item(1) - Set varRes = NewMalVec(Array()) - Dim i - For i = 0 To objArgs.Item(1).Count - 1 - varRes.Add objArgs.Item(1).Item(i) - Next - Set MVec = varRes -End Function -objNS.Add NewMalSym("vec"), NewVbsProc("MVec", False) - -Function MNth(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 2 - CheckListOrVec objArgs.Item(1) - CheckType objArgs.Item(2), TYPES.NUMBER - - If objArgs.Item(2).Value < objArgs.Item(1).Count Then - Set varRes = objArgs.Item(1).Item(objArgs.Item(2).Value) - Else - Err.Raise vbObjectError, _ - "MNth", "Index out of bounds." - End If - - Set MNth = varRes -End Function -objNS.Add NewMalSym("nth"), NewVbsProc("MNth", False) - -Function MFirst(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - If objArgs.Item(1).Type = TYPES.NIL Then - Set varRes = NewMalNil() - Set MFirst = varRes - Exit Function - End If - - CheckListOrVec objArgs.Item(1) - - If objArgs.Item(1).Count < 1 Then - Set varRes = NewMalNil() - Else - Set varRes = objArgs.Item(1).Item(0) - End If - - Set MFirst = varRes -End Function -objNS.Add NewMalSym("first"), NewVbsProc("MFirst", False) - -Function MRest(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - If objArgs.Item(1).Type = TYPES.NIL Then - Set varRes = NewMalList(Array()) - Set MRest = varRes - Exit Function - End If - - Dim objList - Set objList = objArgs.Item(1) - CheckListOrVec objList - - Set varRes = NewMalList(Array()) - Dim i - For i = 1 To objList.Count - 1 - varRes.Add objList.Item(i) - Next - - Set MRest = varRes -End Function -objNS.Add NewMalSym("rest"), NewVbsProc("MRest", False) - -Sub InitMacro() - REP "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ""odd number of forms to cond"")) (cons'cond (rest (rest xs)))))))" - 'REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" - REP "(def! *gensym-counter* (atom 0))" - REP "(def! gensym (fn* [] (symbol (str ""G__"" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))" - REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))" -End Sub - -Class MalException - Private objDict - Private Sub Class_Initialize - Set objDict = CreateObject("Scripting.Dictionary") - End Sub - - Public Sub Add(varKey, varValue) - objDict.Add varKey, varValue - End Sub - - Public Function Item(varKey) - Set Item = objDict.Item(varKey) - End Function - - Public Sub Remove(varKey) - objDict.Remove varKey - End Sub -End Class - -Dim objExceptions -Set objExceptions = New MalException - -Function MThrow(objArgs, objEnv) - CheckArgNum objArgs, 1 - Dim strRnd - strRnd = CStr(Rnd()) - objExceptions.Add strRnd, objArgs.Item(1) - Err.Raise vbObjectError, _ - "MThrow", strRnd -End Function -objNS.Add NewMalSym("throw"), NewVbsProc("MThrow", False) - -Function MApply(objArgs, objEnv) - Dim varRes - If objArgs.Count - 1 < 2 Then - Err.Raise vbObjectError, _ - "MApply", "Need more arguments." - End If - - Dim objFn - Set objFn = objArgs.Item(1) - CheckType objFn, TYPES.PROCEDURE - If objFn.IsSpecial Or objFn.IsMacro Then - Err.Raise vbObjectError, _ - "MApply", "Need a function." - End If - - Dim objAST - Set objAST = NewMalList(Array(objFn)) - Dim i - For i = 2 To objArgs.Count - 2 - objAST.Add objArgs.Item(i) - Next - - Dim objSeq - Set objSeq = objArgs.Item(objArgs.Count - 1) - CheckListOrVec objSeq - - For i = 0 To objSeq.Count - 1 - objAST.Add objSeq.Item(i) - Next - - Set varRes = objFn.ApplyWithoutEval(objAST, objEnv) - Set MApply = varRes -End Function -objNS.Add NewMalSym("apply"), NewVbsProc("MApply", False) - -Function MMap(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 2 - Dim objFn, objSeq - Set objFn = objArgs.Item(1) - Set objSeq = objArgs.Item(2) - CheckType objFn, TYPES.PROCEDURE - CheckListOrVec objSeq - If objFn.IsSpecial Or objFn.IsMacro Then - Err.Raise vbObjectError, _ - "MApply", "Need a function." - End If - - Set varRes = NewMalList(Array()) - Dim i - For i = 0 To objSeq.Count - 1 - varRes.Add objFn.ApplyWithoutEval(NewMalList(Array( _ - objFn, objSeq.Item(i))), objEnv) - Next - - Set MMap = varRes -End Function -objNS.Add NewMalSym("map"), NewVbsProc("MMap", False) - -Function MIsSymbol(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.SYMBOL) - Set MIsSymbol = varRes -End Function -objNS.Add NewMalSym("symbol?"), NewVbsProc("MIsSymbol", False) - -Function MSymbol(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - CheckType objArgs.Item(1), TYPES.STRING - Set varRes = NewMalSym(objArgs.Item(1).Value) - Set MSymbol = varRes -End Function -objNS.Add NewMalSym("symbol"), NewVbsProc("MSymbol", False) - -Function MKeyword(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - Select Case objArgs.Item(1).Type - Case TYPES.STRING - Set varRes = NewMalKwd(":" + objArgs.Item(1).Value) - Case TYPES.KEYWORD - Set varRes = objArgs.Item(1) - Case Else - Err.Raise vbObjectError, _ - "MKeyword", "Unexpect argument(s)." - End Select - Set MKeyword = varRes -End Function -objNS.Add NewMalSym("keyword"), NewVbsProc("MKeyword", False) - -Function MIsKeyword(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.KEYWORD) - Set MIsKeyword = varRes -End Function -objNS.Add NewMalSym("keyword?"), NewVbsProc("MIsKeyword", False) - -Function MIsSeq(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - Set varRes = NewMalBool( _ - objArgs.Item(1).Type = TYPES.LIST Or _ - objArgs.Item(1).Type = TYPES.VECTOR) - Set MIsSeq = varRes -End Function -objNS.Add NewMalSym("sequential?"), NewVbsProc("MIsSeq", False) - -Function MIsVec(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.VECTOR) - Set MIsVec = varRes -End Function -objNS.Add NewMalSym("vector?"), NewVbsProc("MIsVec", False) - -Function MIsMap(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.HASHMAP) - Set MIsMap = varRes -End Function -objNS.Add NewMalSym("map?"), NewVbsProc("MIsMap", False) - -Function MHashMap(objArgs, objEnv) - Dim varRes - If objArgs.Count Mod 2 <> 1 Then - Err.Raise vbObjectError, _ - "MHashMap", "Unexpect argument(s)." - End If - Set varRes = NewMalMap(Array(), Array()) - Dim i - For i = 1 To objArgs.Count - 1 Step 2 - varRes.Add objArgs.Item(i), objArgs.Item(i + 1) - Next - Set MHashMap = varRes -End Function -objNS.Add NewMalSym("hash-map"), NewVbsProc("MHashMap", False) - -Function MAssoc(objArgs, objEnv) - Dim varRes - If objArgs.Count - 1 < 3 Or objArgs.Count Mod 2 <> 0 Then - Err.Raise vbObjectError, _ - "MHashMap", "Unexpect argument(s)." - End If - - Dim objMap - Set objMap = objArgs.Item(1) - CheckType objMap, TYPES.HASHMAP - - Dim i - Set varRes = NewMalMap(Array(), Array()) - For Each i In objMap.Keys - varRes.Add i, objMap.Item(i) - Next - For i = 2 To objArgs.Count - 1 Step 2 - varRes.Add objArgs.Item(i), objArgs.Item(i + 1) - Next - Set MAssoc = varRes -End Function -objNS.Add NewMalSym("assoc"), NewVbsProc("MAssoc", False) - -Function MGet(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 2 - - If objArgs.Item(1).Type = TYPES.NIL Then - Set varRes = NewMalNil() - Else - CheckType objArgs.Item(1), TYPES.HASHMAP - If objArgs.Item(1).Exists(objArgs.Item(2)) Then - Set varRes = objArgs.Item(1).Item(objArgs.Item(2)) - Else - Set varRes = NewMalNil() - End If - End If - - Set MGet = varRes -End Function -objNS.Add NewMalSym("get"), NewVbsProc("MGet", False) - -Function MDissoc(objArgs, objEnv) - Dim varRes - 'CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.HASHMAP - - If objArgs.Item(1).Exists(objArgs.Item(2)) Then - Set varRes = NewMalMap(Array(), Array()) - - Dim i - Dim j, boolFlag - For Each i In objArgs.Item(1).Keys - boolFlag = True - For j = 2 To objArgs.Count - 1 - If i.Type = objArgs.Item(j).Type And _ - i.Value = objArgs.Item(j).Value Then - boolFlag = False - End If - Next - If boolFlag Then - varRes.Add i, objArgs.Item(1).Item(i) - End If - Next - Else - Set varRes = objArgs.Item(1) - End If - - Set MDissoc = varRes -End Function -objNS.Add NewMalSym("dissoc"), NewVbsProc("MDissoc", False) - -Function MKeys(objArgs, objEnv) - CheckArgNum objArgs, 1 - CheckType objArgs.Item(1), TYPES.HASHMAP - Set MKeys = NewMalList(objArgs.Item(1).Keys) -End Function -objNS.Add NewMalSym("keys"), NewVbsProc("MKeys", False) - -Function MIsContains(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.HASHMAP - - Set MIsContains = NewMalBool(objArgs.Item(1).Exists(objArgs.Item(2))) -End Function -objNS.Add NewMalSym("contains?"), NewVbsProc("MIsContains", False) - -Function MReadLine(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - CheckType objArgs.Item(1), TYPES.STRING - - Dim strInput - WScript.StdOut.Write objArgs.Item(1).Value - On Error Resume Next - strInput = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then - Set varRes = NewMalNil() - Else - Set varRes = NewMalStr(strInput) - End If - On Error Goto 0 - Set MReadLine = varRes -End Function -objNS.Add NewMalSym("readline"), NewVbsProc("MReadLine", False) - -Function MTimeMs(objArgs, objEnv) - Set MTimeMs = NewMalNum(CLng(Timer * 1000)) -End Function -objNS.Add NewMalSym("time-ms"), NewVbsProc("MTimeMs", False) - -Function MIsStr(objArgs, objEnv) - CheckArgNum objArgs, 1 - Set MIsStr = NewMalBool(objArgs.Item(1).Type = TYPES.STRING) -End Function -objNS.Add NewMalSym("string?"), NewVbsProc("MIsStr", False) - -Function MIsNum(objArgs, objEnv) - CheckArgNum objArgs, 1 - Set MIsNum = NewMalBool(objArgs.Item(1).Type = TYPES.NUMBER) -End Function -objNS.Add NewMalSym("number?"), NewVbsProc("MIsNum", False) - -Function MIsFn(objArgs, objEnv) - CheckArgNum objArgs, 1 - Dim varRes - varRes = objArgs.Item(1).Type = TYPES.PROCEDURE - If varRes Then - varRes = (Not objArgs.Item(1).IsMacro) And _ - (Not objArgs.Item(1).IsSpecial) - End If - - Set MIsFn = NewMalBool(varRes) -End Function -objNS.Add NewMalSym("fn?"), NewVbsProc("MIsFn", False) - - -Function MIsMacro(objArgs, objEnv) - CheckArgNum objArgs, 1 - Dim varRes - varRes = objArgs.Item(1).Type = TYPES.PROCEDURE - If varRes Then - varRes = objArgs.Item(1).IsMacro And _ - (Not objArgs.Item(1).IsSpecial) - End If - - Set MIsMacro = NewMalBool(varRes) -End Function -objNS.Add NewMalSym("macro?"), NewVbsProc("MIsMacro", False) - - -Function MMeta(objArgs, objEnv) - CheckArgNum objArgs, 1 - 'CheckType objArgs.Item(1), TYPES.PROCEDURE - - Dim varRes - Set varRes = GetMeta(objArgs.Item(1)) - Set MMeta = varRes -End Function -objNS.Add NewMalSym("meta"), NewVbsProc("MMeta", False) - -Function MWithMeta(objArgs, objEnv) - CheckArgNum objArgs, 2 - 'CheckType objArgs.Item(1), TYPES.PROCEDURE - - Dim varRes - Set varRes = SetMeta(objArgs.Item(1), objArgs.Item(2)) - Set MWithMeta = varRes -End Function -objNS.Add NewMalSym("with-meta"), NewVbsProc("MWithMeta", False) - -Function MConj(objArgs, objEnv) - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MConj", "Need more arguments." - End If - Dim varRes - Dim objSeq - Set objSeq = objArgs.Item(1) - Dim i - Select Case objSeq.Type - Case TYPES.LIST - Set varRes = NewMalList(Array()) - For i = objArgs.Count - 1 To 2 Step -1 - varRes.Add objArgs.Item(i) - Next - For i = 0 To objSeq.Count - 1 - varRes.Add objSeq.Item(i) - Next - Case TYPES.VECTOR - Set varRes = NewMalVec(Array()) - For i = 0 To objSeq.Count - 1 - varRes.Add objSeq.Item(i) - Next - For i = 2 To objArgs.Count - 1 - varRes.Add objArgs.Item(i) - Next - Case Else - Err.Raise vbObjectError, _ - "MConj", "Unexpect argument type." - End Select - Set MConj = varRes -End Function -objNS.Add NewMalSym("conj"), NewVbsProc("MConj", False) - -Function MSeq(objArgs, objEnv) - CheckArgNum objArgs, 1 - Dim objSeq - Set objSeq = objArgs.Item(1) - Dim varRes - Dim i - Select Case objSeq.Type - Case TYPES.STRING - If objSeq.Value = "" Then - Set varRes = NewMalNil() - Else - Set varRes = NewMalList(Array()) - For i = 1 To Len(objSeq.Value) - varRes.Add NewMalStr(Mid(objSeq.Value, i, 1)) - Next - End If - Case TYPES.LIST - If objSeq.Count = 0 Then - Set varRes = NewMalNil() - Else - Set varRes = objSeq - End If - Case TYPES.VECTOR - If objSeq.Count = 0 Then - Set varRes = NewMalNil() - Else - Set varRes = NewMalList(Array()) - For i = 0 To objSeq.Count - 1 - varRes.Add objSeq.Item(i) - Next - End If - Case TYPES.NIL - Set varRes = NewMalNil() - Case Else - Err.Raise vbObjectError, _ - "MSeq", "Unexpect argument type." - End Select - Set MSeq = varRes -End Function -objNS.Add NewMalSym("seq"), NewVbsProc("MSeq", False) - +Option Explicit + +Sub CheckArgNum(objArgs, lngArgNum) + If objArgs.Count - 1 <> lngArgNum Then + Err.Raise vbObjectError, _ + "CheckArgNum", "Wrong number of arguments." + End IF +End Sub + +Sub CheckType(objMal, varType) + If objMal.Type <> varType Then + Err.Raise vbObjectError, _ + "CheckType", "Wrong argument type." + End IF +End Sub + +Function IsListOrVec(objMal) + IsListOrVec = _ + objMal.Type = TYPES.LIST Or _ + objMal.Type = TYPES.VECTOR +End Function + +Sub CheckListOrVec(objMal) + If Not IsListOrVec(objMal) Then + Err.Raise vbObjectError, _ + "CheckListOrVec", _ + "Wrong argument type, need a list or a vector." + End If +End Sub + +Dim objNS +Set objNS = NewEnv(Nothing) + +Function MAdd(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MAdd = NewMalNum( _ + objArgs.Item(1).Value + objArgs.Item(2).Value) +End Function +objNS.Add NewMalSym("+"), NewVbsProc("MAdd", False) + +Function MSub(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MSub = NewMalNum( _ + objArgs.Item(1).Value - objArgs.Item(2).Value) +End Function +objNS.Add NewMalSym("-"), NewVbsProc("MSub", False) + +Function MMul(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MMul = NewMalNum( _ + objArgs.Item(1).Value * objArgs.Item(2).Value) +End Function +objNS.Add NewMalSym("*"), NewVbsProc("MMul", False) + +Function MDiv(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MDiv = NewMalNum( _ + objArgs.Item(1).Value \ objArgs.Item(2).Value) +End Function +objNS.Add NewMalSym("/"), NewVbsProc("MDiv", False) + +Function MList(objArgs, objEnv) + Dim varRet + Set varRet = NewMalList(Array()) + Dim i + For i = 1 To objArgs.Count - 1 + varRet.Add objArgs.Item(i) + Next + Set MList = varRet +End Function +objNS.Add NewMalSym("list"), NewVbsProc("MList", False) + +Function MIsList(objArgs, objEnv) + CheckArgNum objArgs, 1 + + Set MIsList = NewMalBool(objArgs.Item(1).Type = TYPES.LIST) +End Function +objNS.Add NewMalSym("list?"), NewVbsProc("MIsList", False) + +Function MIsEmpty(objArgs, objEnv) + CheckArgNum objArgs, 1 + CheckListOrVec objArgs.Item(1) + + Set MIsEmpty = NewMalBool(objArgs.Item(1).Count = 0) +End Function +objNS.Add NewMalSym("empty?"), NewVbsProc("MIsEmpty", False) + +Function MCount(objArgs, objEnv) + CheckArgNum objArgs, 1 + If objArgs.Item(1).Type = TYPES.NIL Then + Set MCount = NewMalNum(0) + Else + CheckListOrVec objArgs.Item(1) + Set MCount = NewMalNum(objArgs.Item(1).Count) + End If +End Function +objNS.Add NewMalSym("count"), NewVbsProc("MCount", False) + +Function MEqual(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim boolResult, i + If IsListOrVec(objArgs.Item(1)) And _ + IsListOrVec(objArgs.Item(2)) Then + If objArgs.Item(1).Count <> objArgs.Item(2).Count Then + Set varRet = NewMalBool(False) + Else + boolResult = True + For i = 0 To objArgs.Item(1).Count - 1 + boolResult = boolResult And _ + MEqual(NewMalList(Array(Nothing, _ + objArgs.Item(1).Item(i), _ + objArgs.Item(2).Item(i))), objEnv).Value + Next + Set varRet = NewMalBool(boolResult) + End If + Else + If objArgs.Item(1).Type <> objArgs.Item(2).Type Then + Set varRet = NewMalBool(False) + Else + Select Case objArgs.Item(1).Type + Case TYPES.HASHMAP + 'Err.Raise vbObjectError, _ + ' "MEqual", "Not implement yet~" + If UBound(objArgs.Item(1).Keys) <> UBound(objArgs.Item(2).Keys) Then + Set varRet = NewMalBool(False) + Set MEqual = varRet + Exit Function + End If + + boolResult = True + For Each i In objArgs.Item(1).Keys + If Not objArgs.Item(2).Exists(i) Then + Set varRet = NewMalBool(False) + Set MEqual = varRet + Exit Function + End If + + boolResult = boolResult And _ + MEqual(NewMalList(Array(Nothing, objArgs.Item(1).Item(i), objArgs.Item(2).Item(i))), objEnv).Value + Next + Set varRet = NewMalBool(boolResult) + + Case Else + Set varRet = NewMalBool( _ + objArgs.Item(1).Value = objArgs.Item(2).Value) + End Select + End If + End If + + Set MEqual = varRet +End Function +objNS.Add NewMalSym("="), NewVbsProc("MEqual", False) + +Function MGreater(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set varRet = NewMalBool( _ + objArgs.Item(1).Value > objArgs.Item(2).Value) + Set MGreater = varRet +End Function +objNS.Add NewMalSym(">"), NewVbsProc("MGreater", False) + +Function MPrStr(objArgs, objEnv) + Dim varRet + Dim strRet + strRet = "" + Dim i + If objArgs.Count - 1 >= 1 Then + strRet = PrintMalType(objArgs.Item(1), True) + End If + For i = 2 To objArgs.Count - 1 + strRet = strRet + " " + _ + PrintMalType(objArgs.Item(i), True) + Next + Set varRet = NewMalStr(strRet) + Set MPrStr = varRet +End Function +objNS.Add NewMalSym("pr-str"), NewVbsProc("MPrStr", False) + +Function MStr(objArgs, objEnv) + Dim varRet + Dim strRet + strRet = "" + Dim i + For i = 1 To objArgs.Count - 1 + strRet = strRet + _ + PrintMalType(objArgs.Item(i), False) + Next + Set varRet = NewMalStr(strRet) + Set MStr = varRet +End Function +objNS.Add NewMalSym("str"), NewVbsProc("MStr", False) + +Function MPrn(objArgs, objEnv) + Dim varRet + Dim objStr + Set objStr = MPrStr(objArgs, objEnv) + WScript.StdOut.WriteLine objStr.Value + Set varRet = NewMalNil() + Set MPrn = varRet +End Function +objNS.Add NewMalSym("prn"), NewVbsProc("MPrn", False) + +Function MPrintln(objArgs, objEnv) + Dim varRet + Dim strRes + strRes = "" + Dim i + If objArgs.Count - 1 >= 1 Then + strRes = PrintMalType(objArgs.Item(1), False) + End If + For i = 2 To objArgs.Count - 1 + strRes = strRes + " " + _ + PrintMalType(objArgs.Item(i), False) + Next + WScript.StdOut.WriteLine strRes + Set varRet = NewMalNil() + Set MPrintln = varRet +End Function +objNS.Add NewMalSym("println"), NewVbsProc("MPrintln", False) + +Sub InitBuiltIn() + REP "(def! not (fn* [bool] (if bool false true)))" + REP "(def! <= (fn* [a b] (not (> a b))))" + REP "(def! < (fn* [a b] (> b a)))" + REP "(def! >= (fn* [a b] (not (> b a))))" + REP "(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))" + REP "(def! cons (fn* [a b] (concat (list a) b)))" + REP "(def! nil? (fn* [x] (= x nil)))" + REP "(def! true? (fn* [x] (= x true)))" + REP "(def! false? (fn* [x] (= x false)))" + REP "(def! vector (fn* [& args] (vec args)))" + REP "(def! vals (fn* [hmap] (map (fn* [key] (get hmap key)) (keys hmap))))" + REP "(def! *host-language* ""VBScript"")" +End Sub + +Function MReadStr(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + CheckType objArgs.Item(1), TYPES.STRING + + Set varRes = ReadString(objArgs.Item(1).Value) + If TypeName(varRes) = "Nothing" Then + Set varRes = NewMalNil() + End If + Set MReadStr = varRes +End Function +objNS.Add NewMalSym("read-string"), NewVbsProc("MReadStr", False) + +Function MSlurp(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + CheckType objArgs.Item(1), TYPES.STRING + + Dim strRes + With CreateObject("Scripting.FileSystemObject") + strRes = .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & objArgs.Item(1).Value).ReadAll + End With + + Set varRes = NewMalStr(strRes) + Set MSlurp = varRes +End Function +objNS.Add NewMalSym("slurp"), NewVbsProc("MSlurp", False) + +Function MAtom(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = NewMalAtom(objArgs.Item(1)) + Set MAtom = varRes +End Function +objNS.Add NewMalSym("atom"), NewVbsProc("MAtom", False) + +Function MIsAtom(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.ATOM) + Set MIsAtom = varRes +End Function +objNS.Add NewMalSym("atom?"), NewVbsProc("MIsAtom", False) + +Function MDeref(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + CheckType objArgs.Item(1), TYPES.ATOM + + Set varRes = objArgs.Item(1).Value + Set MDeref = varRes +End Function +objNS.Add NewMalSym("deref"), NewVbsProc("MDeref", False) + +Function MReset(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.ATOM + + objArgs.Item(1).Reset objArgs.Item(2) + Set varRes = objArgs.Item(2) + Set MReset = varRes +End Function +objNS.Add NewMalSym("reset!"), NewVbsProc("MReset", False) + +Function MSwap(objArgs, objEnv) + Dim varRes + If objArgs.Count - 1 < 2 Then + Err.Raise vbObjectError, _ + "MSwap", "Need more arguments." + End If + + Dim objAtom, objFn + Set objAtom = objArgs.Item(1) + CheckType objAtom, TYPES.ATOM + Set objFn = objArgs.Item(2) + CheckType objFn, TYPES.PROCEDURE + + Dim objProg + Set objProg = NewMalList(Array(objFn)) + objProg.Add objAtom.Value + Dim i + For i = 3 To objArgs.Count - 1 + objProg.Add objArgs.Item(i) + Next + + objAtom.Reset objFn.ApplyWithoutEval(objProg, objEnv) + Set varRes = objAtom.Value + Set MSwap = varRes +End Function +objNS.Add NewMalSym("swap!"), NewVbsProc("MSwap", False) + +Function MConcat(objArgs, objEnv) + Dim varRes + Dim i, j + Set varRes = NewMalList(Array()) + For i = 1 To objArgs.Count - 1 + If Not IsListOrVec(objArgs.Item(i)) Then + Err.Raise vbObjectError, _ + "MConcat", "Invaild argument(s)." + End If + + For j = 0 To objArgs.Item(i).Count - 1 + varRes.Add objArgs.Item(i).Item(j) + Next + Next + Set MConcat = varRes +End Function +objNS.Add NewMalSym("concat"), NewVbsProc("MConcat", False) + +Function MVec(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + CheckListOrVec objArgs.Item(1) + Set varRes = NewMalVec(Array()) + Dim i + For i = 0 To objArgs.Item(1).Count - 1 + varRes.Add objArgs.Item(1).Item(i) + Next + Set MVec = varRes +End Function +objNS.Add NewMalSym("vec"), NewVbsProc("MVec", False) + +Function MNth(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 2 + CheckListOrVec objArgs.Item(1) + CheckType objArgs.Item(2), TYPES.NUMBER + + If objArgs.Item(2).Value < objArgs.Item(1).Count Then + Set varRes = objArgs.Item(1).Item(objArgs.Item(2).Value) + Else + Err.Raise vbObjectError, _ + "MNth", "Index out of bounds." + End If + + Set MNth = varRes +End Function +objNS.Add NewMalSym("nth"), NewVbsProc("MNth", False) + +Function MFirst(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + If objArgs.Item(1).Type = TYPES.NIL Then + Set varRes = NewMalNil() + Set MFirst = varRes + Exit Function + End If + + CheckListOrVec objArgs.Item(1) + + If objArgs.Item(1).Count < 1 Then + Set varRes = NewMalNil() + Else + Set varRes = objArgs.Item(1).Item(0) + End If + + Set MFirst = varRes +End Function +objNS.Add NewMalSym("first"), NewVbsProc("MFirst", False) + +Function MRest(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + If objArgs.Item(1).Type = TYPES.NIL Then + Set varRes = NewMalList(Array()) + Set MRest = varRes + Exit Function + End If + + Dim objList + Set objList = objArgs.Item(1) + CheckListOrVec objList + + Set varRes = NewMalList(Array()) + Dim i + For i = 1 To objList.Count - 1 + varRes.Add objList.Item(i) + Next + + Set MRest = varRes +End Function +objNS.Add NewMalSym("rest"), NewVbsProc("MRest", False) + +Sub InitMacro() + REP "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ""odd number of forms to cond"")) (cons'cond (rest (rest xs)))))))" + 'REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" + REP "(def! *gensym-counter* (atom 0))" + REP "(def! gensym (fn* [] (symbol (str ""G__"" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))" + REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))" +End Sub + +Class MalException + Private objDict + Private Sub Class_Initialize + Set objDict = CreateObject("Scripting.Dictionary") + End Sub + + Public Sub Add(varKey, varValue) + objDict.Add varKey, varValue + End Sub + + Public Function Item(varKey) + Set Item = objDict.Item(varKey) + End Function + + Public Sub Remove(varKey) + objDict.Remove varKey + End Sub +End Class + +Dim objExceptions +Set objExceptions = New MalException + +Function MThrow(objArgs, objEnv) + CheckArgNum objArgs, 1 + Dim strRnd + strRnd = CStr(Rnd()) + objExceptions.Add strRnd, objArgs.Item(1) + Err.Raise vbObjectError, _ + "MThrow", strRnd +End Function +objNS.Add NewMalSym("throw"), NewVbsProc("MThrow", False) + +Function MApply(objArgs, objEnv) + Dim varRes + If objArgs.Count - 1 < 2 Then + Err.Raise vbObjectError, _ + "MApply", "Need more arguments." + End If + + Dim objFn + Set objFn = objArgs.Item(1) + CheckType objFn, TYPES.PROCEDURE + If objFn.IsSpecial Or objFn.IsMacro Then + Err.Raise vbObjectError, _ + "MApply", "Need a function." + End If + + Dim objAST + Set objAST = NewMalList(Array(objFn)) + Dim i + For i = 2 To objArgs.Count - 2 + objAST.Add objArgs.Item(i) + Next + + Dim objSeq + Set objSeq = objArgs.Item(objArgs.Count - 1) + CheckListOrVec objSeq + + For i = 0 To objSeq.Count - 1 + objAST.Add objSeq.Item(i) + Next + + Set varRes = objFn.ApplyWithoutEval(objAST, objEnv) + Set MApply = varRes +End Function +objNS.Add NewMalSym("apply"), NewVbsProc("MApply", False) + +Function MMap(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 2 + Dim objFn, objSeq + Set objFn = objArgs.Item(1) + Set objSeq = objArgs.Item(2) + CheckType objFn, TYPES.PROCEDURE + CheckListOrVec objSeq + If objFn.IsSpecial Or objFn.IsMacro Then + Err.Raise vbObjectError, _ + "MApply", "Need a function." + End If + + Set varRes = NewMalList(Array()) + Dim i + For i = 0 To objSeq.Count - 1 + varRes.Add objFn.ApplyWithoutEval(NewMalList(Array( _ + objFn, objSeq.Item(i))), objEnv) + Next + + Set MMap = varRes +End Function +objNS.Add NewMalSym("map"), NewVbsProc("MMap", False) + +Function MIsSymbol(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.SYMBOL) + Set MIsSymbol = varRes +End Function +objNS.Add NewMalSym("symbol?"), NewVbsProc("MIsSymbol", False) + +Function MSymbol(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + CheckType objArgs.Item(1), TYPES.STRING + Set varRes = NewMalSym(objArgs.Item(1).Value) + Set MSymbol = varRes +End Function +objNS.Add NewMalSym("symbol"), NewVbsProc("MSymbol", False) + +Function MKeyword(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + Select Case objArgs.Item(1).Type + Case TYPES.STRING + Set varRes = NewMalKwd(":" + objArgs.Item(1).Value) + Case TYPES.KEYWORD + Set varRes = objArgs.Item(1) + Case Else + Err.Raise vbObjectError, _ + "MKeyword", "Unexpect argument(s)." + End Select + Set MKeyword = varRes +End Function +objNS.Add NewMalSym("keyword"), NewVbsProc("MKeyword", False) + +Function MIsKeyword(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.KEYWORD) + Set MIsKeyword = varRes +End Function +objNS.Add NewMalSym("keyword?"), NewVbsProc("MIsKeyword", False) + +Function MIsSeq(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + Set varRes = NewMalBool( _ + objArgs.Item(1).Type = TYPES.LIST Or _ + objArgs.Item(1).Type = TYPES.VECTOR) + Set MIsSeq = varRes +End Function +objNS.Add NewMalSym("sequential?"), NewVbsProc("MIsSeq", False) + +Function MIsVec(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.VECTOR) + Set MIsVec = varRes +End Function +objNS.Add NewMalSym("vector?"), NewVbsProc("MIsVec", False) + +Function MIsMap(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + Set varRes = NewMalBool(objArgs.Item(1).Type = TYPES.HASHMAP) + Set MIsMap = varRes +End Function +objNS.Add NewMalSym("map?"), NewVbsProc("MIsMap", False) + +Function MHashMap(objArgs, objEnv) + Dim varRes + If objArgs.Count Mod 2 <> 1 Then + Err.Raise vbObjectError, _ + "MHashMap", "Unexpect argument(s)." + End If + Set varRes = NewMalMap(Array(), Array()) + Dim i + For i = 1 To objArgs.Count - 1 Step 2 + varRes.Add objArgs.Item(i), objArgs.Item(i + 1) + Next + Set MHashMap = varRes +End Function +objNS.Add NewMalSym("hash-map"), NewVbsProc("MHashMap", False) + +Function MAssoc(objArgs, objEnv) + Dim varRes + If objArgs.Count - 1 < 3 Or objArgs.Count Mod 2 <> 0 Then + Err.Raise vbObjectError, _ + "MHashMap", "Unexpect argument(s)." + End If + + Dim objMap + Set objMap = objArgs.Item(1) + CheckType objMap, TYPES.HASHMAP + + Dim i + Set varRes = NewMalMap(Array(), Array()) + For Each i In objMap.Keys + varRes.Add i, objMap.Item(i) + Next + For i = 2 To objArgs.Count - 1 Step 2 + varRes.Add objArgs.Item(i), objArgs.Item(i + 1) + Next + Set MAssoc = varRes +End Function +objNS.Add NewMalSym("assoc"), NewVbsProc("MAssoc", False) + +Function MGet(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 2 + + If objArgs.Item(1).Type = TYPES.NIL Then + Set varRes = NewMalNil() + Else + CheckType objArgs.Item(1), TYPES.HASHMAP + If objArgs.Item(1).Exists(objArgs.Item(2)) Then + Set varRes = objArgs.Item(1).Item(objArgs.Item(2)) + Else + Set varRes = NewMalNil() + End If + End If + + Set MGet = varRes +End Function +objNS.Add NewMalSym("get"), NewVbsProc("MGet", False) + +Function MDissoc(objArgs, objEnv) + Dim varRes + 'CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.HASHMAP + + If objArgs.Item(1).Exists(objArgs.Item(2)) Then + Set varRes = NewMalMap(Array(), Array()) + + Dim i + Dim j, boolFlag + For Each i In objArgs.Item(1).Keys + boolFlag = True + For j = 2 To objArgs.Count - 1 + If i.Type = objArgs.Item(j).Type And _ + i.Value = objArgs.Item(j).Value Then + boolFlag = False + End If + Next + If boolFlag Then + varRes.Add i, objArgs.Item(1).Item(i) + End If + Next + Else + Set varRes = objArgs.Item(1) + End If + + Set MDissoc = varRes +End Function +objNS.Add NewMalSym("dissoc"), NewVbsProc("MDissoc", False) + +Function MKeys(objArgs, objEnv) + CheckArgNum objArgs, 1 + CheckType objArgs.Item(1), TYPES.HASHMAP + Set MKeys = NewMalList(objArgs.Item(1).Keys) +End Function +objNS.Add NewMalSym("keys"), NewVbsProc("MKeys", False) + +Function MIsContains(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.HASHMAP + + Set MIsContains = NewMalBool(objArgs.Item(1).Exists(objArgs.Item(2))) +End Function +objNS.Add NewMalSym("contains?"), NewVbsProc("MIsContains", False) + +Function MReadLine(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + CheckType objArgs.Item(1), TYPES.STRING + + Dim strInput + WScript.StdOut.Write objArgs.Item(1).Value + On Error Resume Next + strInput = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then + Set varRes = NewMalNil() + Else + Set varRes = NewMalStr(strInput) + End If + On Error Goto 0 + Set MReadLine = varRes +End Function +objNS.Add NewMalSym("readline"), NewVbsProc("MReadLine", False) + +Function MTimeMs(objArgs, objEnv) + Set MTimeMs = NewMalNum(CLng(Timer * 1000)) +End Function +objNS.Add NewMalSym("time-ms"), NewVbsProc("MTimeMs", False) + +Function MIsStr(objArgs, objEnv) + CheckArgNum objArgs, 1 + Set MIsStr = NewMalBool(objArgs.Item(1).Type = TYPES.STRING) +End Function +objNS.Add NewMalSym("string?"), NewVbsProc("MIsStr", False) + +Function MIsNum(objArgs, objEnv) + CheckArgNum objArgs, 1 + Set MIsNum = NewMalBool(objArgs.Item(1).Type = TYPES.NUMBER) +End Function +objNS.Add NewMalSym("number?"), NewVbsProc("MIsNum", False) + +Function MIsFn(objArgs, objEnv) + CheckArgNum objArgs, 1 + Dim varRes + varRes = objArgs.Item(1).Type = TYPES.PROCEDURE + If varRes Then + varRes = (Not objArgs.Item(1).IsMacro) And _ + (Not objArgs.Item(1).IsSpecial) + End If + + Set MIsFn = NewMalBool(varRes) +End Function +objNS.Add NewMalSym("fn?"), NewVbsProc("MIsFn", False) + + +Function MIsMacro(objArgs, objEnv) + CheckArgNum objArgs, 1 + Dim varRes + varRes = objArgs.Item(1).Type = TYPES.PROCEDURE + If varRes Then + varRes = objArgs.Item(1).IsMacro And _ + (Not objArgs.Item(1).IsSpecial) + End If + + Set MIsMacro = NewMalBool(varRes) +End Function +objNS.Add NewMalSym("macro?"), NewVbsProc("MIsMacro", False) + + +Function MMeta(objArgs, objEnv) + CheckArgNum objArgs, 1 + 'CheckType objArgs.Item(1), TYPES.PROCEDURE + + Dim varRes + Set varRes = GetMeta(objArgs.Item(1)) + Set MMeta = varRes +End Function +objNS.Add NewMalSym("meta"), NewVbsProc("MMeta", False) + +Function MWithMeta(objArgs, objEnv) + CheckArgNum objArgs, 2 + 'CheckType objArgs.Item(1), TYPES.PROCEDURE + + Dim varRes + Set varRes = SetMeta(objArgs.Item(1), objArgs.Item(2)) + Set MWithMeta = varRes +End Function +objNS.Add NewMalSym("with-meta"), NewVbsProc("MWithMeta", False) + +Function MConj(objArgs, objEnv) + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MConj", "Need more arguments." + End If + Dim varRes + Dim objSeq + Set objSeq = objArgs.Item(1) + Dim i + Select Case objSeq.Type + Case TYPES.LIST + Set varRes = NewMalList(Array()) + For i = objArgs.Count - 1 To 2 Step -1 + varRes.Add objArgs.Item(i) + Next + For i = 0 To objSeq.Count - 1 + varRes.Add objSeq.Item(i) + Next + Case TYPES.VECTOR + Set varRes = NewMalVec(Array()) + For i = 0 To objSeq.Count - 1 + varRes.Add objSeq.Item(i) + Next + For i = 2 To objArgs.Count - 1 + varRes.Add objArgs.Item(i) + Next + Case Else + Err.Raise vbObjectError, _ + "MConj", "Unexpect argument type." + End Select + Set MConj = varRes +End Function +objNS.Add NewMalSym("conj"), NewVbsProc("MConj", False) + +Function MSeq(objArgs, objEnv) + CheckArgNum objArgs, 1 + Dim objSeq + Set objSeq = objArgs.Item(1) + Dim varRes + Dim i + Select Case objSeq.Type + Case TYPES.STRING + If objSeq.Value = "" Then + Set varRes = NewMalNil() + Else + Set varRes = NewMalList(Array()) + For i = 1 To Len(objSeq.Value) + varRes.Add NewMalStr(Mid(objSeq.Value, i, 1)) + Next + End If + Case TYPES.LIST + If objSeq.Count = 0 Then + Set varRes = NewMalNil() + Else + Set varRes = objSeq + End If + Case TYPES.VECTOR + If objSeq.Count = 0 Then + Set varRes = NewMalNil() + Else + Set varRes = NewMalList(Array()) + For i = 0 To objSeq.Count - 1 + varRes.Add objSeq.Item(i) + Next + End If + Case TYPES.NIL + Set varRes = NewMalNil() + Case Else + Err.Raise vbObjectError, _ + "MSeq", "Unexpect argument type." + End Select + Set MSeq = varRes +End Function +objNS.Add NewMalSym("seq"), NewVbsProc("MSeq", False) + diff --git a/impls/vbs/env.vbs b/impls/vbs/env.vbs index c86671b478..60df009497 100644 --- a/impls/vbs/env.vbs +++ b/impls/vbs/env.vbs @@ -1,63 +1,63 @@ -Option Explicit - -Function NewEnv(objOuter) - Dim varRet - Set varRet = New Environment - Set varRet.Self = varRet - Set varRet.Outer = objOuter - Set NewEnv = varRet -End Function - -Class Environment - Private objOuter, objSelf - Private objBinds - Private Sub Class_Initialize() - Set objBinds = CreateObject("Scripting.Dictionary") - Set objOuter = Nothing - Set objSelf = Nothing - End Sub - - Public Property Set Outer(objEnv) - Set objOuter = objEnv - End Property - - Public Property Get Outer() - Set Outer = objOuter - End Property - - Public Property Set Self(objEnv) - Set objSelf = objEnv - End Property - - Public Sub Add(varKey, varValue) - Set objBinds.Item(varKey.Value) = varValue - End Sub - - Public Function Find(varKey) - Dim varRet - If objBinds.Exists(varKey.Value) Then - Set varRet = objSelf - Else - If TypeName(objOuter) <> "Nothing" Then - Set varRet = objOuter.Find(varKey) - Else - Err.Raise vbObjectError, _ - "Environment", "'" + varKey.Value + "' not found" - End If - End If - - Set Find = varRet - End Function - - Public Function [Get](varKey) - Dim objEnv, varRet - Set objEnv = Find(varKey) - If objEnv Is objSelf Then - Set varRet = objBinds(varKey.Value) - Else - Set varRet = objEnv.Get(varKey) - End If - - Set [Get] = varRet - End Function +Option Explicit + +Function NewEnv(objOuter) + Dim varRet + Set varRet = New Environment + Set varRet.Self = varRet + Set varRet.Outer = objOuter + Set NewEnv = varRet +End Function + +Class Environment + Private objOuter, objSelf + Private objBinds + Private Sub Class_Initialize() + Set objBinds = CreateObject("Scripting.Dictionary") + Set objOuter = Nothing + Set objSelf = Nothing + End Sub + + Public Property Set Outer(objEnv) + Set objOuter = objEnv + End Property + + Public Property Get Outer() + Set Outer = objOuter + End Property + + Public Property Set Self(objEnv) + Set objSelf = objEnv + End Property + + Public Sub Add(varKey, varValue) + Set objBinds.Item(varKey.Value) = varValue + End Sub + + Public Function Find(varKey) + Dim varRet + If objBinds.Exists(varKey.Value) Then + Set varRet = objSelf + Else + If TypeName(objOuter) <> "Nothing" Then + Set varRet = objOuter.Find(varKey) + Else + Err.Raise vbObjectError, _ + "Environment", "'" + varKey.Value + "' not found" + End If + End If + + Set Find = varRet + End Function + + Public Function [Get](varKey) + Dim objEnv, varRet + Set objEnv = Find(varKey) + If objEnv Is objSelf Then + Set varRet = objBinds(varKey.Value) + Else + Set varRet = objEnv.Get(varKey) + End If + + Set [Get] = varRet + End Function End Class \ No newline at end of file diff --git a/impls/vbs/install.vbs b/impls/vbs/install.vbs index ca97f52901..c444c0ee2a 100644 --- a/impls/vbs/install.vbs +++ b/impls/vbs/install.vbs @@ -1,2 +1,2 @@ -On Error Resume Next +On Error Resume Next CreateObject("System.Collections.ArrayList") \ No newline at end of file diff --git a/impls/vbs/printer.vbs b/impls/vbs/printer.vbs index fd78defe27..83b8f2c818 100644 --- a/impls/vbs/printer.vbs +++ b/impls/vbs/printer.vbs @@ -1,93 +1,93 @@ -Option Explicit - -Function PrintMalType(objMal, boolReadable) - Dim varResult - - varResult = "" - - If TypeName(objMal) = "Nothing" Then - PrintMalType = "" - Exit Function - End If - - Dim i - Select Case objMal.Type - Case TYPES.LIST - With objMal - For i = 0 To .Count - 2 - varResult = varResult & _ - PrintMalType(.Item(i), boolReadable) & " " - Next - If .Count > 0 Then - varResult = varResult & _ - PrintMalType(.Item(.Count - 1), boolReadable) - End If - End With - varResult = "(" & varResult & ")" - Case TYPES.VECTOR - With objMal - For i = 0 To .Count - 2 - varResult = varResult & _ - PrintMalType(.Item(i), boolReadable) & " " - Next - If .Count > 0 Then - varResult = varResult & _ - PrintMalType(.Item(.Count - 1), boolReadable) - End If - End With - varResult = "[" & varResult & "]" - Case TYPES.HASHMAP - With objMal - Dim arrKeys - arrKeys = .Keys - For i = 0 To .Count - 2 - varResult = varResult & _ - PrintMalType(arrKeys(i), boolReadable) & " " & _ - PrintMalType(.Item(arrKeys(i)), boolReadable) & " " - Next - If .Count > 0 Then - varResult = varResult & _ - PrintMalType(arrKeys(.Count - 1), boolReadable) & " " & _ - PrintMalType(.Item(arrKeys(.Count - 1)), boolReadable) - End If - End With - varResult = "{" & varResult & "}" - Case TYPES.STRING - If boolReadable Then - varResult = EscapeString(objMal.Value) - Else - varResult = objMal.Value - End If - Case TYPES.BOOLEAN - If objMal.Value Then - varResult = "true" - Else - varResult = "false" - End If - Case TYPES.NIL - varResult = "nil" - Case TYPES.NUMBER - varResult = CStr(objMal.Value) - Case TYPES.PROCEDURE - varResult = "#" - Case TYPES.KEYWORD - varResult = objMal.Value - Case TYPES.SYMBOL - varResult = objMal.Value - Case TYPES.ATOM - varResult = "(atom " + PrintMalType(objMal.Value, boolReadable) + ")" - Case Else - Err.Raise vbObjectError, _ - "PrintMalType", "Unknown type." - End Select - - PrintMalType = varResult -End Function - -Function EscapeString(strRaw) - EscapeString = strRaw - EscapeString = Replace(EscapeString, "\", "\\") - EscapeString = Replace(EscapeString, vbCrLf, "\n") - EscapeString = Replace(EscapeString, """", "\""") - EscapeString = """" & EscapeString & """" -End Function +Option Explicit + +Function PrintMalType(objMal, boolReadable) + Dim varResult + + varResult = "" + + If TypeName(objMal) = "Nothing" Then + PrintMalType = "" + Exit Function + End If + + Dim i + Select Case objMal.Type + Case TYPES.LIST + With objMal + For i = 0 To .Count - 2 + varResult = varResult & _ + PrintMalType(.Item(i), boolReadable) & " " + Next + If .Count > 0 Then + varResult = varResult & _ + PrintMalType(.Item(.Count - 1), boolReadable) + End If + End With + varResult = "(" & varResult & ")" + Case TYPES.VECTOR + With objMal + For i = 0 To .Count - 2 + varResult = varResult & _ + PrintMalType(.Item(i), boolReadable) & " " + Next + If .Count > 0 Then + varResult = varResult & _ + PrintMalType(.Item(.Count - 1), boolReadable) + End If + End With + varResult = "[" & varResult & "]" + Case TYPES.HASHMAP + With objMal + Dim arrKeys + arrKeys = .Keys + For i = 0 To .Count - 2 + varResult = varResult & _ + PrintMalType(arrKeys(i), boolReadable) & " " & _ + PrintMalType(.Item(arrKeys(i)), boolReadable) & " " + Next + If .Count > 0 Then + varResult = varResult & _ + PrintMalType(arrKeys(.Count - 1), boolReadable) & " " & _ + PrintMalType(.Item(arrKeys(.Count - 1)), boolReadable) + End If + End With + varResult = "{" & varResult & "}" + Case TYPES.STRING + If boolReadable Then + varResult = EscapeString(objMal.Value) + Else + varResult = objMal.Value + End If + Case TYPES.BOOLEAN + If objMal.Value Then + varResult = "true" + Else + varResult = "false" + End If + Case TYPES.NIL + varResult = "nil" + Case TYPES.NUMBER + varResult = CStr(objMal.Value) + Case TYPES.PROCEDURE + varResult = "#" + Case TYPES.KEYWORD + varResult = objMal.Value + Case TYPES.SYMBOL + varResult = objMal.Value + Case TYPES.ATOM + varResult = "(atom " + PrintMalType(objMal.Value, boolReadable) + ")" + Case Else + Err.Raise vbObjectError, _ + "PrintMalType", "Unknown type." + End Select + + PrintMalType = varResult +End Function + +Function EscapeString(strRaw) + EscapeString = strRaw + EscapeString = Replace(EscapeString, "\", "\\") + EscapeString = Replace(EscapeString, vbCrLf, "\n") + EscapeString = Replace(EscapeString, """", "\""") + EscapeString = """" & EscapeString & """" +End Function diff --git a/impls/vbs/reader.vbs b/impls/vbs/reader.vbs index 7c6c9dfcb2..23eade7b56 100644 --- a/impls/vbs/reader.vbs +++ b/impls/vbs/reader.vbs @@ -1,287 +1,287 @@ -Option Explicit - -Function ReadString(strCode) - Dim objTokens - Set objTokens = Tokenize(strCode) - Set ReadString = ReadForm(objTokens) - If Not objTokens.AtEnd() Then - Err.Raise vbObjectError, _ - "ReadForm", "extra token '" + objTokens.Current() + "'." - End If -End Function - -Class Tokens - Private objQueue - Private objRE - - Private Sub Class_Initialize - Set objRE = New RegExp - With objRE - .Pattern = "[\s,]*" + _ - "(" + _ - "~@" + "|" + _ - "[\[\]{}()'`~^@]" + "|" + _ - """(?:\\.|[^\\""])*""?" + "|" + _ - ";.*" + "|" + _ - "[^\s\[\]{}('""`,;)]*" + _ - ")" - .IgnoreCase = True - .Global = True - End With - - Set objQueue = CreateObject("System.Collections.Queue") - End Sub - - Public Function Init(strCode) - Dim objMatches, objMatch - Set objMatches = objRE.Execute(strCode) - Dim strToken - For Each objMatch In objMatches - strToken = Trim(objMatch.SubMatches(0)) - If Not (Left(strToken, 1) = ";" Or strToken = "") Then - objQueue.Enqueue strToken - End If - Next - End Function - - Public Function Current() - Current = objQueue.Peek() - End Function - - Public Function MoveToNext() - MoveToNext = objQueue.Dequeue() - End Function - - Public Function AtEnd() - AtEnd = (objQueue.Count = 0) - End Function - - Public Function Count() - Count = objQueue.Count - End Function -End Class - -Function Tokenize(strCode) ' Return objTokens - Dim varResult - Set varResult = New Tokens - varResult.Init strCode - Set Tokenize = varResult -End Function - -Function ReadForm(objTokens) ' Return Nothing / MalType - If objTokens.AtEnd() Then - Set ReadForm = Nothing - Exit Function - End If - - Dim strToken - strToken = objTokens.Current() - - Dim varResult - If InStr("([{", strToken) Then - Select Case strToken - Case "(" - Set varResult = ReadList(objTokens) - Case "[" - Set varResult = ReadVector(objTokens) - Case "{" - Set varResult = ReadHashmap(objTokens) - End Select - ElseIf InStr("'`~@", strToken) Then - Set varResult = ReadSpecial(objTokens) - ElseIf InStr(")]}", strToken) Then - Err.Raise vbObjectError, _ - "ReadForm", "unbalanced parentheses." - ElseIf strToken = "^" Then - Set varResult = ReadMetadata(objTokens) - Else - Set varResult = ReadAtom(objTokens) - End If - - Set ReadForm = varResult -End Function - -Function ReadMetadata(objTokens) - Dim varResult - - Call objTokens.MoveToNext() - Dim objTemp - Set objTemp = ReadForm(objTokens) - Set varResult = NewMalList(Array( _ - NewMalSym("with-meta"), _ - ReadForm(objTokens), objTemp)) - - Set ReadMetadata = varResult -End Function - -Function ReadSpecial(objTokens) - Dim varResult - - Dim strToken, strAlias - strToken = objTokens.Current() - Select Case strToken - Case "'" - strAlias = "quote" - Case "`" - strAlias = "quasiquote" - Case "~" - strAlias = "unquote" - Case "~@" - strAlias = "splice-unquote" - Case "@" - strAlias = "deref" - Case Else - Err.Raise vbObjectError, _ - "ReadSpecial", "unknown token '" & strAlias & "'." - End Select - - Call objTokens.MoveToNext() - Set varResult = NewMalList(Array( _ - NewMalSym(strAlias), _ - ReadForm(objTokens))) - - Set ReadSpecial = varResult -End Function - -Function ReadList(objTokens) - Dim varResult - Call objTokens.MoveToNext() - - If objTokens.AtEnd() Then - Err.Raise vbObjectError, _ - "ReadList", "unbalanced parentheses." - End If - - Set varResult = NewMalList(Array()) - With varResult - While objTokens.Count() > 1 And objTokens.Current() <> ")" - .Add ReadForm(objTokens) - Wend - End With - - If objTokens.MoveToNext() <> ")" Then - Err.Raise vbObjectError, _ - "ReadList", "unbalanced parentheses." - End If - - Set ReadList = varResult -End Function - -Function ReadVector(objTokens) - Dim varResult - Call objTokens.MoveToNext() - - If objTokens.AtEnd() Then - Err.Raise vbObjectError, _ - "ReadVector", "unbalanced parentheses." - End If - - Set varResult = NewMalVec(Array()) - With varResult - While objTokens.Count() > 1 And objTokens.Current() <> "]" - .Add ReadForm(objTokens) - Wend - End With - - If objTokens.MoveToNext() <> "]" Then - Err.Raise vbObjectError, _ - "ReadVector", "unbalanced parentheses." - End If - - Set ReadVector = varResult -End Function - -Function ReadHashmap(objTokens) - Dim varResult - Call objTokens.MoveToNext() - - If objTokens.Count = 0 Then - Err.Raise vbObjectError, _ - "ReadHashmap", "unbalanced parentheses." - End If - - Set varResult = NewMalMap(Array(), Array()) - Dim objKey, objValue - With varResult - While objTokens.Count > 2 And objTokens.Current() <> "}" - Set objKey = ReadForm(objTokens) - Set objValue = ReadForm(objTokens) - .Add objKey, objValue - Wend - End With - - If objTokens.MoveToNext() <> "}" Then - Err.Raise vbObjectError, _ - "ReadHashmap", "unbalanced parentheses." - End If - - Set ReadHashmap = varResult -End Function - -Function ReadAtom(objTokens) - Dim varResult - - Dim strAtom - strAtom = objTokens.MoveToNext() - - Select Case strAtom - Case "true" - Set varResult = NewMalBool(True) - Case "false" - Set varResult = NewMalBool(False) - Case "nil" - Set varResult = NewMalNil() - Case Else - Select Case Left(strAtom, 1) - Case ":" - Set varResult = NewMalKwd(strAtom) - Case """" - Set varResult = NewMalStr(ParseString(strAtom)) - Case Else - If IsNumeric(strAtom) Then - Set varResult = NewMalNum(Eval(strAtom)) - Else - Set varResult = NewMalSym(strAtom) - End If - End Select - End Select - - Set ReadAtom = varResult -End Function - -Function ParseString(strRaw) - If Right(strRaw, 1) <> """" Or Len(strRaw) < 2 Then - Err.Raise vbObjectError, _ - "ParseString", "unterminated string, got EOF." - End If - - Dim strTemp - strTemp = Mid(strRaw, 2, Len(strRaw) - 2) - Dim i - i = 1 - ParseString = "" - While i <= Len(strTemp) - 1 - Select Case Mid(strTemp, i, 2) - Case "\\" - ParseString = ParseString & "\" - Case "\n" - ParseString = ParseString & vbCrLf - Case "\""" - ParseString = ParseString & """" - Case Else - ParseString = ParseString & Mid(strTemp, i, 1) - i = i - 1 - End Select - i = i + 2 - Wend - - If i <= Len(strTemp) Then - ' Last char is not processed. - If Right(strTemp, 1) <> "\" Then - ParseString = ParseString & Right(strTemp, 1) - Else - Err.Raise vbObjectError, _ - "ParseString", "unterminated string, got EOF." - End If - End If -End Function +Option Explicit + +Function ReadString(strCode) + Dim objTokens + Set objTokens = Tokenize(strCode) + Set ReadString = ReadForm(objTokens) + If Not objTokens.AtEnd() Then + Err.Raise vbObjectError, _ + "ReadForm", "extra token '" + objTokens.Current() + "'." + End If +End Function + +Class Tokens + Private objQueue + Private objRE + + Private Sub Class_Initialize + Set objRE = New RegExp + With objRE + .Pattern = "[\s,]*" + _ + "(" + _ + "~@" + "|" + _ + "[\[\]{}()'`~^@]" + "|" + _ + """(?:\\.|[^\\""])*""?" + "|" + _ + ";.*" + "|" + _ + "[^\s\[\]{}('""`,;)]*" + _ + ")" + .IgnoreCase = True + .Global = True + End With + + Set objQueue = CreateObject("System.Collections.Queue") + End Sub + + Public Function Init(strCode) + Dim objMatches, objMatch + Set objMatches = objRE.Execute(strCode) + Dim strToken + For Each objMatch In objMatches + strToken = Trim(objMatch.SubMatches(0)) + If Not (Left(strToken, 1) = ";" Or strToken = "") Then + objQueue.Enqueue strToken + End If + Next + End Function + + Public Function Current() + Current = objQueue.Peek() + End Function + + Public Function MoveToNext() + MoveToNext = objQueue.Dequeue() + End Function + + Public Function AtEnd() + AtEnd = (objQueue.Count = 0) + End Function + + Public Function Count() + Count = objQueue.Count + End Function +End Class + +Function Tokenize(strCode) ' Return objTokens + Dim varResult + Set varResult = New Tokens + varResult.Init strCode + Set Tokenize = varResult +End Function + +Function ReadForm(objTokens) ' Return Nothing / MalType + If objTokens.AtEnd() Then + Set ReadForm = Nothing + Exit Function + End If + + Dim strToken + strToken = objTokens.Current() + + Dim varResult + If InStr("([{", strToken) Then + Select Case strToken + Case "(" + Set varResult = ReadList(objTokens) + Case "[" + Set varResult = ReadVector(objTokens) + Case "{" + Set varResult = ReadHashmap(objTokens) + End Select + ElseIf InStr("'`~@", strToken) Then + Set varResult = ReadSpecial(objTokens) + ElseIf InStr(")]}", strToken) Then + Err.Raise vbObjectError, _ + "ReadForm", "unbalanced parentheses." + ElseIf strToken = "^" Then + Set varResult = ReadMetadata(objTokens) + Else + Set varResult = ReadAtom(objTokens) + End If + + Set ReadForm = varResult +End Function + +Function ReadMetadata(objTokens) + Dim varResult + + Call objTokens.MoveToNext() + Dim objTemp + Set objTemp = ReadForm(objTokens) + Set varResult = NewMalList(Array( _ + NewMalSym("with-meta"), _ + ReadForm(objTokens), objTemp)) + + Set ReadMetadata = varResult +End Function + +Function ReadSpecial(objTokens) + Dim varResult + + Dim strToken, strAlias + strToken = objTokens.Current() + Select Case strToken + Case "'" + strAlias = "quote" + Case "`" + strAlias = "quasiquote" + Case "~" + strAlias = "unquote" + Case "~@" + strAlias = "splice-unquote" + Case "@" + strAlias = "deref" + Case Else + Err.Raise vbObjectError, _ + "ReadSpecial", "unknown token '" & strAlias & "'." + End Select + + Call objTokens.MoveToNext() + Set varResult = NewMalList(Array( _ + NewMalSym(strAlias), _ + ReadForm(objTokens))) + + Set ReadSpecial = varResult +End Function + +Function ReadList(objTokens) + Dim varResult + Call objTokens.MoveToNext() + + If objTokens.AtEnd() Then + Err.Raise vbObjectError, _ + "ReadList", "unbalanced parentheses." + End If + + Set varResult = NewMalList(Array()) + With varResult + While objTokens.Count() > 1 And objTokens.Current() <> ")" + .Add ReadForm(objTokens) + Wend + End With + + If objTokens.MoveToNext() <> ")" Then + Err.Raise vbObjectError, _ + "ReadList", "unbalanced parentheses." + End If + + Set ReadList = varResult +End Function + +Function ReadVector(objTokens) + Dim varResult + Call objTokens.MoveToNext() + + If objTokens.AtEnd() Then + Err.Raise vbObjectError, _ + "ReadVector", "unbalanced parentheses." + End If + + Set varResult = NewMalVec(Array()) + With varResult + While objTokens.Count() > 1 And objTokens.Current() <> "]" + .Add ReadForm(objTokens) + Wend + End With + + If objTokens.MoveToNext() <> "]" Then + Err.Raise vbObjectError, _ + "ReadVector", "unbalanced parentheses." + End If + + Set ReadVector = varResult +End Function + +Function ReadHashmap(objTokens) + Dim varResult + Call objTokens.MoveToNext() + + If objTokens.Count = 0 Then + Err.Raise vbObjectError, _ + "ReadHashmap", "unbalanced parentheses." + End If + + Set varResult = NewMalMap(Array(), Array()) + Dim objKey, objValue + With varResult + While objTokens.Count > 2 And objTokens.Current() <> "}" + Set objKey = ReadForm(objTokens) + Set objValue = ReadForm(objTokens) + .Add objKey, objValue + Wend + End With + + If objTokens.MoveToNext() <> "}" Then + Err.Raise vbObjectError, _ + "ReadHashmap", "unbalanced parentheses." + End If + + Set ReadHashmap = varResult +End Function + +Function ReadAtom(objTokens) + Dim varResult + + Dim strAtom + strAtom = objTokens.MoveToNext() + + Select Case strAtom + Case "true" + Set varResult = NewMalBool(True) + Case "false" + Set varResult = NewMalBool(False) + Case "nil" + Set varResult = NewMalNil() + Case Else + Select Case Left(strAtom, 1) + Case ":" + Set varResult = NewMalKwd(strAtom) + Case """" + Set varResult = NewMalStr(ParseString(strAtom)) + Case Else + If IsNumeric(strAtom) Then + Set varResult = NewMalNum(Eval(strAtom)) + Else + Set varResult = NewMalSym(strAtom) + End If + End Select + End Select + + Set ReadAtom = varResult +End Function + +Function ParseString(strRaw) + If Right(strRaw, 1) <> """" Or Len(strRaw) < 2 Then + Err.Raise vbObjectError, _ + "ParseString", "unterminated string, got EOF." + End If + + Dim strTemp + strTemp = Mid(strRaw, 2, Len(strRaw) - 2) + Dim i + i = 1 + ParseString = "" + While i <= Len(strTemp) - 1 + Select Case Mid(strTemp, i, 2) + Case "\\" + ParseString = ParseString & "\" + Case "\n" + ParseString = ParseString & vbCrLf + Case "\""" + ParseString = ParseString & """" + Case Else + ParseString = ParseString & Mid(strTemp, i, 1) + i = i - 1 + End Select + i = i + 2 + Wend + + If i <= Len(strTemp) Then + ' Last char is not processed. + If Right(strTemp, 1) <> "\" Then + ParseString = ParseString & Right(strTemp, 1) + Else + Err.Raise vbObjectError, _ + "ParseString", "unterminated string, got EOF." + End If + End If +End Function diff --git a/impls/vbs/step0_repl.vbs b/impls/vbs/step0_repl.vbs index 9c920dab44..cfc850cb47 100644 --- a/impls/vbs/step0_repl.vbs +++ b/impls/vbs/step0_repl.vbs @@ -1,28 +1,28 @@ -Option Explicit - -Function Read(strCode) - Read = strCode -End Function - -Function Evaluate(strCode) - Evaluate = strCode -End Function - -Function Print(strCode) - Print = strCode -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode))) -End Function - -Dim strCode -While True 'REPL - WScript.StdOut.Write "user> " - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - WScript.Echo REP(strCode) -Wend +Option Explicit + +Function Read(strCode) + Read = strCode +End Function + +Function Evaluate(strCode) + Evaluate = strCode +End Function + +Function Print(strCode) + Print = strCode +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode))) +End Function + +Dim strCode +While True 'REPL + WScript.StdOut.Write "user> " + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + WScript.Echo REP(strCode) +Wend diff --git a/impls/vbs/step1_read_print.vbs b/impls/vbs/step1_read_print.vbs index 01757b6e14..4b95c55ed3 100644 --- a/impls/vbs/step1_read_print.vbs +++ b/impls/vbs/step1_read_print.vbs @@ -1,57 +1,57 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" - -Call REPL() - -Sub REPL() - Dim strCode - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(objCode) - Set Evaluate = objCode -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode))) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" + +Call REPL() + +Sub REPL() + Dim strCode + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(objCode) + Set Evaluate = objCode +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode))) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/step2_eval.vbs b/impls/vbs/step2_eval.vbs index 769a342697..7f7a05fa0a 100644 --- a/impls/vbs/step2_eval.vbs +++ b/impls/vbs/step2_eval.vbs @@ -1,196 +1,196 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" - -Class Enviroment - Private objDict - Private objSelf - - Private Sub Class_Initialize - Set objDict = CreateObject("Scripting.Dictionary") - End Sub - - Public Function Add(objSymbol, objProcedure) - objDict.Add objSymbol.Value, objProcedure - End Function - - Public Property Set Self(objThis) - Set objSelf = objThis - End Property - - Public Function Find(varKey) - Set Find = objSelf - End Function - - Public Function [Get](objSymbol) - If objDict.Exists(objSymbol.Value) Then - Set [Get] = objDict.Item(objSymbol.Value) - Else - Err.Raise vbObjectError, _ - "Enviroment", "Symbol '" + PrintMalType(objSymbol, True) + "' not found." - End If - End Function -End Class - -Dim objEnv -Set objEnv = New Enviroment -Set objEnv.Self = objEnv - -Function MAdd(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MAdd = NewMalNum( _ - objArgs.Item(1).Value + objArgs.Item(2).Value) -End Function -objEnv.Add NewMalSym("+"), NewVbsProc("MAdd", False) - -Function MSub(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MSub = NewMalNum( _ - objArgs.Item(1).Value - objArgs.Item(2).Value) -End Function -objEnv.Add NewMalSym("-"), NewVbsProc("MSub", False) - -Function MMul(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MMul = NewMalNum( _ - objArgs.Item(1).Value * objArgs.Item(2).Value) -End Function -objEnv.Add NewMalSym("*"), NewVbsProc("MMul", False) - -Function MDiv(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MDiv = NewMalNum( _ - objArgs.Item(1).Value \ objArgs.Item(2).Value) -End Function -objEnv.Add NewMalSym("/"), NewVbsProc("MDiv", False) - -Sub CheckArgNum(objArgs, lngArgNum) - If objArgs.Count - 1 <> lngArgNum Then - Err.Raise vbObjectError, _ - "CheckArgNum", "Wrong number of arguments." - End IF -End Sub - -Sub CheckType(objMal, varType) - If objMal.Type <> varType Then - Err.Raise vbObjectError, _ - "CheckType", "Wrong argument type." - End IF -End Sub - -Call REPL() -Sub REPL() - Dim strCode, strResult - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(objCode, objEnv) - If TypeName(objCode) = "Nothing" Then - Set Evaluate = Nothing - Exit Function - End If - Dim varRet, objFirst - If objCode.Type = TYPES.LIST Then - If objCode.Count = 0 Then ' () - Set Evaluate = objCode - Exit Function - End If - Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) - Else - Set varRet = EvaluateAST(objCode, objEnv) - End If - - Set Evaluate = varRet -End Function - - -Function EvaluateAST(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) - Case TYPES.LIST - Err.Raise vbObjectError, _ - "EvaluateAST", "Unexpect type." - Case TYPES.VECTOR - Set varRet = NewMalVec(Array()) - For i = 0 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case TYPES.HASHMAP - Set varRet = NewMalMap(Array(), Array()) - For Each i In objCode.Keys() - varRet.Add i, Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Set varRet = objCode - End Select - Set EvaluateAST = varRet -End Function - -Function EvaluateRest(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.LIST - Set varRet = NewMalList(Array(NewMalNil())) - For i = 1 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Err.Raise vbObjectError, _ - "EvaluateRest", "Unexpected type." - End Select - Set EvaluateRest = varRet -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objEnv)) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" + +Class Enviroment + Private objDict + Private objSelf + + Private Sub Class_Initialize + Set objDict = CreateObject("Scripting.Dictionary") + End Sub + + Public Function Add(objSymbol, objProcedure) + objDict.Add objSymbol.Value, objProcedure + End Function + + Public Property Set Self(objThis) + Set objSelf = objThis + End Property + + Public Function Find(varKey) + Set Find = objSelf + End Function + + Public Function [Get](objSymbol) + If objDict.Exists(objSymbol.Value) Then + Set [Get] = objDict.Item(objSymbol.Value) + Else + Err.Raise vbObjectError, _ + "Enviroment", "Symbol '" + PrintMalType(objSymbol, True) + "' not found." + End If + End Function +End Class + +Dim objEnv +Set objEnv = New Enviroment +Set objEnv.Self = objEnv + +Function MAdd(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MAdd = NewMalNum( _ + objArgs.Item(1).Value + objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("+"), NewVbsProc("MAdd", False) + +Function MSub(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MSub = NewMalNum( _ + objArgs.Item(1).Value - objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("-"), NewVbsProc("MSub", False) + +Function MMul(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MMul = NewMalNum( _ + objArgs.Item(1).Value * objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("*"), NewVbsProc("MMul", False) + +Function MDiv(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MDiv = NewMalNum( _ + objArgs.Item(1).Value \ objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("/"), NewVbsProc("MDiv", False) + +Sub CheckArgNum(objArgs, lngArgNum) + If objArgs.Count - 1 <> lngArgNum Then + Err.Raise vbObjectError, _ + "CheckArgNum", "Wrong number of arguments." + End IF +End Sub + +Sub CheckType(objMal, varType) + If objMal.Type <> varType Then + Err.Raise vbObjectError, _ + "CheckType", "Wrong argument type." + End IF +End Sub + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(objCode, objEnv) + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + Set Evaluate = varRet +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objEnv)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/step3_env.vbs b/impls/vbs/step3_env.vbs index eedff1a996..215fbb538e 100644 --- a/impls/vbs/step3_env.vbs +++ b/impls/vbs/step3_env.vbs @@ -1,207 +1,207 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" -Include "Env.vbs" - -Dim objEnv -Set objEnv = NewEnv(Nothing) - -Function MAdd(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MAdd = NewMalNum( _ - objArgs.Item(1).Value + objArgs.Item(2).Value) -End Function -objEnv.Add NewMalSym("+"), NewVbsProc("MAdd", False) - -Function MSub(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MSub = NewMalNum( _ - objArgs.Item(1).Value - objArgs.Item(2).Value) -End Function -objEnv.Add NewMalSym("-"), NewVbsProc("MSub", False) - -Function MMul(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MMul = NewMalNum( _ - objArgs.Item(1).Value * objArgs.Item(2).Value) -End Function -objEnv.Add NewMalSym("*"), NewVbsProc("MMul", False) - -Function MDiv(objArgs, objEnv) - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.NUMBER - CheckType objArgs.Item(2), TYPES.NUMBER - Set MDiv = NewMalNum( _ - objArgs.Item(1).Value \ objArgs.Item(2).Value) -End Function -objEnv.Add NewMalSym("/"), NewVbsProc("MDiv", False) - -Sub CheckArgNum(objArgs, lngArgNum) - If objArgs.Count - 1 <> lngArgNum Then - Err.Raise vbObjectError, _ - "CheckArgNum", "Wrong number of arguments." - End IF -End Sub - -Sub CheckType(objMal, varType) - If objMal.Type <> varType Then - Err.Raise vbObjectError, _ - "CheckType", "Wrong argument type." - End IF -End Sub - -Function MDef(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) - objEnv.Add objArgs.Item(1), varRet - Set MDef = varRet -End Function -objEnv.Add NewMalSym("def!"), NewVbsProc("MDef", True) - -Function MLet(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objBinds - Set objBinds = objArgs.Item(1) - If objBinds.Type <> TYPES.LIST And _ - objBinds.Type <> TYPES.VECTOR Then - Err.Raise vbObjectError, _ - "MLet", "Wrong argument type." - End If - - If objBinds.Count Mod 2 <> 0 Then - Err.Raise vbObjectError, _ - "MLet", "Wrong argument count." - End If - - Dim objNewEnv - Set objNewEnv = NewEnv(objEnv) - Dim i, objSym - For i = 0 To objBinds.Count - 1 Step 2 - Set objSym = objBinds.Item(i) - CheckType objSym, TYPES.SYMBOL - objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) - Next - - Set varRet = Evaluate(objArgs.Item(2), objNewEnv) - Set MLet = varRet -End Function -objEnv.Add NewMalSym("let*"), NewVbsProc("MLet", True) - -Call REPL() -Sub REPL() - Dim strCode, strResult - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(objCode, objEnv) - If TypeName(objCode) = "Nothing" Then - Set Evaluate = Nothing - Exit Function - End If - Dim varRet, objFirst - If objCode.Type = TYPES.LIST Then - If objCode.Count = 0 Then ' () - Set Evaluate = objCode - Exit Function - End If - Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) - Else - Set varRet = EvaluateAST(objCode, objEnv) - End If - - Set Evaluate = varRet -End Function - - -Function EvaluateAST(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) - Case TYPES.LIST - Err.Raise vbObjectError, _ - "EvaluateAST", "Unexpect type." - Case TYPES.VECTOR - Set varRet = NewMalVec(Array()) - For i = 0 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case TYPES.HASHMAP - Set varRet = NewMalMap(Array(), Array()) - For Each i In objCode.Keys() - varRet.Add i, Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Set varRet = objCode - End Select - Set EvaluateAST = varRet -End Function - -Function EvaluateRest(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.LIST - Set varRet = NewMalList(Array(NewMalNil())) - For i = 1 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Err.Raise vbObjectError, _ - "EvaluateRest", "Unexpected type." - End Select - Set EvaluateRest = varRet -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objEnv)) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" + +Dim objEnv +Set objEnv = NewEnv(Nothing) + +Function MAdd(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MAdd = NewMalNum( _ + objArgs.Item(1).Value + objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("+"), NewVbsProc("MAdd", False) + +Function MSub(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MSub = NewMalNum( _ + objArgs.Item(1).Value - objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("-"), NewVbsProc("MSub", False) + +Function MMul(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MMul = NewMalNum( _ + objArgs.Item(1).Value * objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("*"), NewVbsProc("MMul", False) + +Function MDiv(objArgs, objEnv) + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.NUMBER + CheckType objArgs.Item(2), TYPES.NUMBER + Set MDiv = NewMalNum( _ + objArgs.Item(1).Value \ objArgs.Item(2).Value) +End Function +objEnv.Add NewMalSym("/"), NewVbsProc("MDiv", False) + +Sub CheckArgNum(objArgs, lngArgNum) + If objArgs.Count - 1 <> lngArgNum Then + Err.Raise vbObjectError, _ + "CheckArgNum", "Wrong number of arguments." + End IF +End Sub + +Sub CheckType(objMal, varType) + If objMal.Type <> varType Then + Err.Raise vbObjectError, _ + "CheckType", "Wrong argument type." + End IF +End Sub + +Function MDef(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv) + objEnv.Add objArgs.Item(1), varRet + Set MDef = varRet +End Function +objEnv.Add NewMalSym("def!"), NewVbsProc("MDef", True) + +Function MLet(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objBinds + Set objBinds = objArgs.Item(1) + If objBinds.Type <> TYPES.LIST And _ + objBinds.Type <> TYPES.VECTOR Then + Err.Raise vbObjectError, _ + "MLet", "Wrong argument type." + End If + + If objBinds.Count Mod 2 <> 0 Then + Err.Raise vbObjectError, _ + "MLet", "Wrong argument count." + End If + + Dim objNewEnv + Set objNewEnv = NewEnv(objEnv) + Dim i, objSym + For i = 0 To objBinds.Count - 1 Step 2 + Set objSym = objBinds.Item(i) + CheckType objSym, TYPES.SYMBOL + objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) + Next + + Set varRet = Evaluate(objArgs.Item(2), objNewEnv) + Set MLet = varRet +End Function +objEnv.Add NewMalSym("let*"), NewVbsProc("MLet", True) + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(objCode, objEnv) + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + Set Evaluate = varRet +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objEnv)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ 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 d9cb2e890b..5db881424d 100644 --- a/impls/vbs/step4_if_fn_do.vbs +++ b/impls/vbs/step4_if_fn_do.vbs @@ -1,221 +1,221 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" -Include "Env.vbs" -Include "Core.vbs" - -Function EvalLater(objMal, objEnv) - ' A fake implement, for compatibility. - Dim varRes - Set varRes = Evaluate(objMal, objEnv) - Set EvalLater = varRes -End Function - -Function MDef(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) - objEnv.Add objArgs.Item(1), varRet - Set MDef = varRet -End Function -objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) - -Function MLet(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objBinds - Set objBinds = objArgs.Item(1) - CheckListOrVec objBinds - - If objBinds.Count Mod 2 <> 0 Then - Err.Raise vbObjectError, _ - "MLet", "Wrong argument count." - End If - - Dim objNewEnv - Set objNewEnv = NewEnv(objEnv) - Dim i, objSym - For i = 0 To objBinds.Count - 1 Step 2 - Set objSym = objBinds.Item(i) - CheckType objSym, TYPES.SYMBOL - objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) - Next - - Set varRet = Evaluate(objArgs.Item(2), objNewEnv) - Set MLet = varRet -End Function -objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) - -Function MDo(objArgs, objEnv) - Dim varRet, i - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MDo", "Need more arguments." - End If - For i = 1 To objArgs.Count - 1 - Set varRet = Evaluate(objArgs.Item(i), objEnv) - Next - Set MDo = varRet -End Function -objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) - -Function MIf(objArgs, objEnv) - Dim varRet - If objArgs.Count - 1 <> 3 And _ - objArgs.Count - 1 <> 2 Then - Err.Raise vbObjectError, _ - "MIf", "Wrong number of arguments." - End If - - Dim objCond - Set objCond = Evaluate(objArgs.Item(1), objEnv) - Dim boolCond - If objCond.Type = TYPES.BOOLEAN Then - boolCond = objCond.Value - Else - boolCond = True - End If - boolCond = (boolCond And objCond.Type <> TYPES.NIL) - If boolCond Then - Set varRet = Evaluate(objArgs.Item(2), objEnv) - Else - If objArgs.Count - 1 = 3 Then - Set varRet = Evaluate(objArgs.Item(3), objEnv) - Else - Set varRet = NewMalNil() - End If - End If - Set MIf = varRet -End Function -objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) - -Function MFn(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objParams, objCode - Set objParams = objArgs.Item(1) - CheckListOrVec objParams - Set objCode = objArgs.Item(2) - - Dim i - For i = 0 To objParams.Count - 1 - CheckType objParams.Item(i), TYPES.SYMBOL - Next - Set varRet = NewMalProc(objParams, objCode, objEnv) - Set MFn = varRet -End Function -objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) - -Call InitBuiltIn() - -Call REPL() -Sub REPL() - Dim strCode, strResult - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(objCode, objEnv) - If TypeName(objCode) = "Nothing" Then - Set Evaluate = Nothing - Exit Function - End If - Dim varRet, objFirst - If objCode.Type = TYPES.LIST Then - If objCode.Count = 0 Then ' () - Set Evaluate = objCode - Exit Function - End If - Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) - Else - Set varRet = EvaluateAST(objCode, objEnv) - End If - - Set Evaluate = varRet -End Function - - -Function EvaluateAST(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) - Case TYPES.LIST - Err.Raise vbObjectError, _ - "EvaluateAST", "Unexpect type." - Case TYPES.VECTOR - Set varRet = NewMalVec(Array()) - For i = 0 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case TYPES.HASHMAP - Set varRet = NewMalMap(Array(), Array()) - For Each i In objCode.Keys() - varRet.Add i, Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Set varRet = objCode - End Select - Set EvaluateAST = varRet -End Function - -Function EvaluateRest(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.LIST - Set varRet = NewMalList(Array(NewMalNil())) - For i = 1 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Err.Raise vbObjectError, _ - "EvaluateRest", "Unexpected type." - End Select - Set EvaluateRest = varRet -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objNS)) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" +Include "Core.vbs" + +Function EvalLater(objMal, objEnv) + ' A fake implement, for compatibility. + Dim varRes + Set varRes = Evaluate(objMal, objEnv) + Set EvalLater = varRes +End Function + +Function MDef(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv) + objEnv.Add objArgs.Item(1), varRet + Set MDef = varRet +End Function +objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) + +Function MLet(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objBinds + Set objBinds = objArgs.Item(1) + CheckListOrVec objBinds + + If objBinds.Count Mod 2 <> 0 Then + Err.Raise vbObjectError, _ + "MLet", "Wrong argument count." + End If + + Dim objNewEnv + Set objNewEnv = NewEnv(objEnv) + Dim i, objSym + For i = 0 To objBinds.Count - 1 Step 2 + Set objSym = objBinds.Item(i) + CheckType objSym, TYPES.SYMBOL + objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) + Next + + Set varRet = Evaluate(objArgs.Item(2), objNewEnv) + Set MLet = varRet +End Function +objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) + +Function MDo(objArgs, objEnv) + Dim varRet, i + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MDo", "Need more arguments." + End If + For i = 1 To objArgs.Count - 1 + Set varRet = Evaluate(objArgs.Item(i), objEnv) + Next + Set MDo = varRet +End Function +objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) + +Function MIf(objArgs, objEnv) + Dim varRet + If objArgs.Count - 1 <> 3 And _ + objArgs.Count - 1 <> 2 Then + Err.Raise vbObjectError, _ + "MIf", "Wrong number of arguments." + End If + + Dim objCond + Set objCond = Evaluate(objArgs.Item(1), objEnv) + Dim boolCond + If objCond.Type = TYPES.BOOLEAN Then + boolCond = objCond.Value + Else + boolCond = True + End If + boolCond = (boolCond And objCond.Type <> TYPES.NIL) + If boolCond Then + Set varRet = Evaluate(objArgs.Item(2), objEnv) + Else + If objArgs.Count - 1 = 3 Then + Set varRet = Evaluate(objArgs.Item(3), objEnv) + Else + Set varRet = NewMalNil() + End If + End If + Set MIf = varRet +End Function +objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) + +Function MFn(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objParams, objCode + Set objParams = objArgs.Item(1) + CheckListOrVec objParams + Set objCode = objArgs.Item(2) + + Dim i + For i = 0 To objParams.Count - 1 + CheckType objParams.Item(i), TYPES.SYMBOL + Next + Set varRet = NewMalProc(objParams, objCode, objEnv) + Set MFn = varRet +End Function +objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) + +Call InitBuiltIn() + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(objCode, objEnv) + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + Set Evaluate = varRet +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objNS)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/step5_tco.vbs b/impls/vbs/step5_tco.vbs index 3b77ecac35..91fee41123 100644 --- a/impls/vbs/step5_tco.vbs +++ b/impls/vbs/step5_tco.vbs @@ -1,242 +1,242 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" -Include "Env.vbs" -Include "Core.vbs" - -Class TailCall - Public objMalType - Public objEnv -End Class - -Function EvalLater(objMal, objEnv) - Dim varRes - Set varRes = New TailCall - Set varRes.objMalType = objMal - Set varRes.objEnv = objEnv - Set EvalLater = varRes -End Function - -Function MDef(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) - objEnv.Add objArgs.Item(1), varRet - Set MDef = varRet -End Function -objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) - -Function MLet(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objBinds - Set objBinds = objArgs.Item(1) - CheckListOrVec objBinds - - If objBinds.Count Mod 2 <> 0 Then - Err.Raise vbObjectError, _ - "MLet", "Wrong argument count." - End If - - Dim objNewEnv - Set objNewEnv = NewEnv(objEnv) - Dim i, objSym - For i = 0 To objBinds.Count - 1 Step 2 - Set objSym = objBinds.Item(i) - CheckType objSym, TYPES.SYMBOL - objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) - Next - - Set varRet = EvalLater(objArgs.Item(2), objNewEnv) - Set MLet = varRet -End Function -objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) - -Function MDo(objArgs, objEnv) - Dim varRet, i - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MDo", "Need more arguments." - End If - For i = 1 To objArgs.Count - 2 - Call Evaluate(objArgs.Item(i), objEnv) - Next - Set varRet = EvalLater( _ - objArgs.Item(objArgs.Count - 1), _ - objEnv) - Set MDo = varRet -End Function -objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) - -Function MIf(objArgs, objEnv) - Dim varRet - If objArgs.Count - 1 <> 3 And _ - objArgs.Count - 1 <> 2 Then - Err.Raise vbObjectError, _ - "MIf", "Wrong number of arguments." - End If - - Dim objCond - Set objCond = Evaluate(objArgs.Item(1), objEnv) - Dim boolCond - If objCond.Type = TYPES.BOOLEAN Then - boolCond = objCond.Value - Else - boolCond = True - End If - boolCond = (boolCond And objCond.Type <> TYPES.NIL) - If boolCond Then - Set varRet = EvalLater(objArgs.Item(2), objEnv) - Else - If objArgs.Count - 1 = 3 Then - Set varRet = EvalLater(objArgs.Item(3), objEnv) - Else - Set varRet = NewMalNil() - End If - End If - Set MIf = varRet -End Function -objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) - -Function MFn(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objParams, objCode - Set objParams = objArgs.Item(1) - CheckListOrVec objParams - Set objCode = objArgs.Item(2) - - Dim i - For i = 0 To objParams.Count - 1 - CheckType objParams.Item(i), TYPES.SYMBOL - Next - Set varRet = NewMalProc(objParams, objCode, objEnv) - Set MFn = varRet -End Function -objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) - -Call InitBuiltIn() - -Call REPL() -Sub REPL() - Dim strCode, strResult - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(ByVal objCode, ByVal objEnv) - While True - If TypeName(objCode) = "Nothing" Then - Set Evaluate = Nothing - Exit Function - End If - - Dim varRet, objFirst - If objCode.Type = TYPES.LIST Then - If objCode.Count = 0 Then ' () - Set Evaluate = objCode - Exit Function - End If - Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) - Else - Set varRet = EvaluateAST(objCode, objEnv) - End If - - If TypeName(varRet) = "TailCall" Then - ' NOTICE: If not specify 'ByVal', - ' Change of arguments will influence - ' the caller's variable! - Set objCode = varRet.objMalType - Set objEnv = varRet.objEnv - Else - Set Evaluate = varRet - Exit Function - End If - Wend -End Function - - -Function EvaluateAST(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) - Case TYPES.LIST - Err.Raise vbObjectError, _ - "EvaluateAST", "Unexpect type." - Case TYPES.VECTOR - Set varRet = NewMalVec(Array()) - For i = 0 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case TYPES.HASHMAP - Set varRet = NewMalMap(Array(), Array()) - For Each i In objCode.Keys() - varRet.Add i, Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Set varRet = objCode - End Select - Set EvaluateAST = varRet -End Function - -Function EvaluateRest(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.LIST - Set varRet = NewMalList(Array(NewMalNil())) - For i = 1 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Err.Raise vbObjectError, _ - "EvaluateRest", "Unexpected type." - End Select - Set EvaluateRest = varRet -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objNS)) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" +Include "Core.vbs" + +Class TailCall + Public objMalType + Public objEnv +End Class + +Function EvalLater(objMal, objEnv) + Dim varRes + Set varRes = New TailCall + Set varRes.objMalType = objMal + Set varRes.objEnv = objEnv + Set EvalLater = varRes +End Function + +Function MDef(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv) + objEnv.Add objArgs.Item(1), varRet + Set MDef = varRet +End Function +objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) + +Function MLet(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objBinds + Set objBinds = objArgs.Item(1) + CheckListOrVec objBinds + + If objBinds.Count Mod 2 <> 0 Then + Err.Raise vbObjectError, _ + "MLet", "Wrong argument count." + End If + + Dim objNewEnv + Set objNewEnv = NewEnv(objEnv) + Dim i, objSym + For i = 0 To objBinds.Count - 1 Step 2 + Set objSym = objBinds.Item(i) + CheckType objSym, TYPES.SYMBOL + objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) + Next + + Set varRet = EvalLater(objArgs.Item(2), objNewEnv) + Set MLet = varRet +End Function +objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) + +Function MDo(objArgs, objEnv) + Dim varRet, i + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MDo", "Need more arguments." + End If + For i = 1 To objArgs.Count - 2 + Call Evaluate(objArgs.Item(i), objEnv) + Next + Set varRet = EvalLater( _ + objArgs.Item(objArgs.Count - 1), _ + objEnv) + Set MDo = varRet +End Function +objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) + +Function MIf(objArgs, objEnv) + Dim varRet + If objArgs.Count - 1 <> 3 And _ + objArgs.Count - 1 <> 2 Then + Err.Raise vbObjectError, _ + "MIf", "Wrong number of arguments." + End If + + Dim objCond + Set objCond = Evaluate(objArgs.Item(1), objEnv) + Dim boolCond + If objCond.Type = TYPES.BOOLEAN Then + boolCond = objCond.Value + Else + boolCond = True + End If + boolCond = (boolCond And objCond.Type <> TYPES.NIL) + If boolCond Then + Set varRet = EvalLater(objArgs.Item(2), objEnv) + Else + If objArgs.Count - 1 = 3 Then + Set varRet = EvalLater(objArgs.Item(3), objEnv) + Else + Set varRet = NewMalNil() + End If + End If + Set MIf = varRet +End Function +objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) + +Function MFn(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objParams, objCode + Set objParams = objArgs.Item(1) + CheckListOrVec objParams + Set objCode = objArgs.Item(2) + + Dim i + For i = 0 To objParams.Count - 1 + CheckType objParams.Item(i), TYPES.SYMBOL + Next + Set varRet = NewMalProc(objParams, objCode, objEnv) + Set MFn = varRet +End Function +objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) + +Call InitBuiltIn() + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(ByVal objCode, ByVal objEnv) + While True + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + If TypeName(varRet) = "TailCall" Then + ' NOTICE: If not specify 'ByVal', + ' Change of arguments will influence + ' the caller's variable! + Set objCode = varRet.objMalType + Set objEnv = varRet.objEnv + Else + Set Evaluate = varRet + Exit Function + End If + Wend +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objNS)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/step6_file.vbs b/impls/vbs/step6_file.vbs index c7cb37baa8..dddd4b018e 100644 --- a/impls/vbs/step6_file.vbs +++ b/impls/vbs/step6_file.vbs @@ -1,270 +1,270 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" -Include "Env.vbs" -Include "Core.vbs" - -Class TailCall - Public objMalType - Public objEnv -End Class - -Function EvalLater(objMal, objEnv) - Dim varRes - Set varRes = New TailCall - Set varRes.objMalType = objMal - Set varRes.objEnv = objEnv - Set EvalLater = varRes -End Function - -Function MDef(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) - objEnv.Add objArgs.Item(1), varRet - Set MDef = varRet -End Function -objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) - -Function MLet(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objBinds - Set objBinds = objArgs.Item(1) - CheckListOrVec objBinds - - If objBinds.Count Mod 2 <> 0 Then - Err.Raise vbObjectError, _ - "MLet", "Wrong argument count." - End If - - Dim objNewEnv - Set objNewEnv = NewEnv(objEnv) - Dim i, objSym - For i = 0 To objBinds.Count - 1 Step 2 - Set objSym = objBinds.Item(i) - CheckType objSym, TYPES.SYMBOL - objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) - Next - - Set varRet = EvalLater(objArgs.Item(2), objNewEnv) - Set MLet = varRet -End Function -objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) - -Function MDo(objArgs, objEnv) - Dim varRet, i - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MDo", "Need more arguments." - End If - For i = 1 To objArgs.Count - 2 - Call Evaluate(objArgs.Item(i), objEnv) - Next - Set varRet = EvalLater( _ - objArgs.Item(objArgs.Count - 1), _ - objEnv) - Set MDo = varRet -End Function -objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) - -Function MIf(objArgs, objEnv) - Dim varRet - If objArgs.Count - 1 <> 3 And _ - objArgs.Count - 1 <> 2 Then - Err.Raise vbObjectError, _ - "MIf", "Wrong number of arguments." - End If - - Dim objCond - Set objCond = Evaluate(objArgs.Item(1), objEnv) - Dim boolCond - If objCond.Type = TYPES.BOOLEAN Then - boolCond = objCond.Value - Else - boolCond = True - End If - boolCond = (boolCond And objCond.Type <> TYPES.NIL) - If boolCond Then - Set varRet = EvalLater(objArgs.Item(2), objEnv) - Else - If objArgs.Count - 1 = 3 Then - Set varRet = EvalLater(objArgs.Item(3), objEnv) - Else - Set varRet = NewMalNil() - End If - End If - Set MIf = varRet -End Function -objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) - -Function MFn(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objParams, objCode - Set objParams = objArgs.Item(1) - CheckListOrVec objParams - Set objCode = objArgs.Item(2) - - Dim i - For i = 0 To objParams.Count - 1 - CheckType objParams.Item(i), TYPES.SYMBOL - Next - Set varRet = NewMalProc(objParams, objCode, objEnv) - Set MFn = varRet -End Function -objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) - -Function MEval(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = Evaluate(objArgs.Item(1), objEnv) - Set varRes = EvalLater(varRes, objNS) - Set MEval = varRes -End Function -objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) - -Call InitBuiltIn() - -Call InitArgs() -Sub InitArgs() - Dim objArgs - Set objArgs = NewMalList(Array()) - - Dim i - For i = 1 To WScript.Arguments.Count - 1 - objArgs.Add NewMalStr(WScript.Arguments.Item(i)) - Next - - objNS.Add NewMalSym("*ARGV*"), objArgs - - If WScript.Arguments.Count > 0 Then - REP "(load-file """ + WScript.Arguments.Item(0) + """)" - WScript.Quit 0 - End If -End Sub - -Call REPL() -Sub REPL() - Dim strCode, strResult - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(ByVal objCode, ByVal objEnv) - While True - If TypeName(objCode) = "Nothing" Then - Set Evaluate = Nothing - Exit Function - End If - - Dim varRet, objFirst - If objCode.Type = TYPES.LIST Then - If objCode.Count = 0 Then ' () - Set Evaluate = objCode - Exit Function - End If - Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) - Else - Set varRet = EvaluateAST(objCode, objEnv) - End If - - If TypeName(varRet) = "TailCall" Then - ' NOTICE: If not specify 'ByVal', - ' Change of arguments will influence - ' the caller's variable! - Set objCode = varRet.objMalType - Set objEnv = varRet.objEnv - Else - Set Evaluate = varRet - Exit Function - End If - Wend -End Function - - -Function EvaluateAST(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) - Case TYPES.LIST - Err.Raise vbObjectError, _ - "EvaluateAST", "Unexpect type." - Case TYPES.VECTOR - Set varRet = NewMalVec(Array()) - For i = 0 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case TYPES.HASHMAP - Set varRet = NewMalMap(Array(), Array()) - For Each i In objCode.Keys() - varRet.Add i, Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Set varRet = objCode - End Select - Set EvaluateAST = varRet -End Function - -Function EvaluateRest(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.LIST - Set varRet = NewMalList(Array(NewMalNil())) - For i = 1 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Err.Raise vbObjectError, _ - "EvaluateRest", "Unexpected type." - End Select - Set EvaluateRest = varRet -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objNS)) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" +Include "Core.vbs" + +Class TailCall + Public objMalType + Public objEnv +End Class + +Function EvalLater(objMal, objEnv) + Dim varRes + Set varRes = New TailCall + Set varRes.objMalType = objMal + Set varRes.objEnv = objEnv + Set EvalLater = varRes +End Function + +Function MDef(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv) + objEnv.Add objArgs.Item(1), varRet + Set MDef = varRet +End Function +objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) + +Function MLet(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objBinds + Set objBinds = objArgs.Item(1) + CheckListOrVec objBinds + + If objBinds.Count Mod 2 <> 0 Then + Err.Raise vbObjectError, _ + "MLet", "Wrong argument count." + End If + + Dim objNewEnv + Set objNewEnv = NewEnv(objEnv) + Dim i, objSym + For i = 0 To objBinds.Count - 1 Step 2 + Set objSym = objBinds.Item(i) + CheckType objSym, TYPES.SYMBOL + objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) + Next + + Set varRet = EvalLater(objArgs.Item(2), objNewEnv) + Set MLet = varRet +End Function +objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) + +Function MDo(objArgs, objEnv) + Dim varRet, i + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MDo", "Need more arguments." + End If + For i = 1 To objArgs.Count - 2 + Call Evaluate(objArgs.Item(i), objEnv) + Next + Set varRet = EvalLater( _ + objArgs.Item(objArgs.Count - 1), _ + objEnv) + Set MDo = varRet +End Function +objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) + +Function MIf(objArgs, objEnv) + Dim varRet + If objArgs.Count - 1 <> 3 And _ + objArgs.Count - 1 <> 2 Then + Err.Raise vbObjectError, _ + "MIf", "Wrong number of arguments." + End If + + Dim objCond + Set objCond = Evaluate(objArgs.Item(1), objEnv) + Dim boolCond + If objCond.Type = TYPES.BOOLEAN Then + boolCond = objCond.Value + Else + boolCond = True + End If + boolCond = (boolCond And objCond.Type <> TYPES.NIL) + If boolCond Then + Set varRet = EvalLater(objArgs.Item(2), objEnv) + Else + If objArgs.Count - 1 = 3 Then + Set varRet = EvalLater(objArgs.Item(3), objEnv) + Else + Set varRet = NewMalNil() + End If + End If + Set MIf = varRet +End Function +objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) + +Function MFn(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objParams, objCode + Set objParams = objArgs.Item(1) + CheckListOrVec objParams + Set objCode = objArgs.Item(2) + + Dim i + For i = 0 To objParams.Count - 1 + CheckType objParams.Item(i), TYPES.SYMBOL + Next + Set varRet = NewMalProc(objParams, objCode, objEnv) + Set MFn = varRet +End Function +objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) + +Function MEval(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = Evaluate(objArgs.Item(1), objEnv) + Set varRes = EvalLater(varRes, objNS) + Set MEval = varRes +End Function +objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) + +Call InitBuiltIn() + +Call InitArgs() +Sub InitArgs() + Dim objArgs + Set objArgs = NewMalList(Array()) + + Dim i + For i = 1 To WScript.Arguments.Count - 1 + objArgs.Add NewMalStr(WScript.Arguments.Item(i)) + Next + + objNS.Add NewMalSym("*ARGV*"), objArgs + + If WScript.Arguments.Count > 0 Then + REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 + End If +End Sub + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(ByVal objCode, ByVal objEnv) + While True + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + If TypeName(varRet) = "TailCall" Then + ' NOTICE: If not specify 'ByVal', + ' Change of arguments will influence + ' the caller's variable! + Set objCode = varRet.objMalType + Set objEnv = varRet.objEnv + Else + Set Evaluate = varRet + Exit Function + End If + Wend +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objNS)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/step7_quote.vbs b/impls/vbs/step7_quote.vbs index 4dadef08ef..1076c93f4a 100644 --- a/impls/vbs/step7_quote.vbs +++ b/impls/vbs/step7_quote.vbs @@ -1,394 +1,394 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" -Include "Env.vbs" -Include "Core.vbs" - -Class TailCall - Public objMalType - Public objEnv -End Class - -Function EvalLater(objMal, objEnv) - Dim varRes - Set varRes = New TailCall - Set varRes.objMalType = objMal - Set varRes.objEnv = objEnv - Set EvalLater = varRes -End Function - -Function MDef(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) - objEnv.Add objArgs.Item(1), varRet - Set MDef = varRet -End Function -objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) - -Function MLet(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objBinds - Set objBinds = objArgs.Item(1) - CheckListOrVec objBinds - - If objBinds.Count Mod 2 <> 0 Then - Err.Raise vbObjectError, _ - "MLet", "Wrong argument count." - End If - - Dim objNewEnv - Set objNewEnv = NewEnv(objEnv) - Dim i, objSym - For i = 0 To objBinds.Count - 1 Step 2 - Set objSym = objBinds.Item(i) - CheckType objSym, TYPES.SYMBOL - objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) - Next - - Set varRet = EvalLater(objArgs.Item(2), objNewEnv) - Set MLet = varRet -End Function -objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) - -Function MDo(objArgs, objEnv) - Dim varRet, i - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MDo", "Need more arguments." - End If - For i = 1 To objArgs.Count - 2 - Call Evaluate(objArgs.Item(i), objEnv) - Next - Set varRet = EvalLater( _ - objArgs.Item(objArgs.Count - 1), _ - objEnv) - Set MDo = varRet -End Function -objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) - -Function MIf(objArgs, objEnv) - Dim varRet - If objArgs.Count - 1 <> 3 And _ - objArgs.Count - 1 <> 2 Then - Err.Raise vbObjectError, _ - "MIf", "Wrong number of arguments." - End If - - Dim objCond - Set objCond = Evaluate(objArgs.Item(1), objEnv) - Dim boolCond - If objCond.Type = TYPES.BOOLEAN Then - boolCond = objCond.Value - Else - boolCond = True - End If - boolCond = (boolCond And objCond.Type <> TYPES.NIL) - If boolCond Then - Set varRet = EvalLater(objArgs.Item(2), objEnv) - Else - If objArgs.Count - 1 = 3 Then - Set varRet = EvalLater(objArgs.Item(3), objEnv) - Else - Set varRet = NewMalNil() - End If - End If - Set MIf = varRet -End Function -objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) - -Function MFn(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objParams, objCode - Set objParams = objArgs.Item(1) - CheckListOrVec objParams - Set objCode = objArgs.Item(2) - - Dim i - For i = 0 To objParams.Count - 1 - CheckType objParams.Item(i), TYPES.SYMBOL - Next - Set varRet = NewMalProc(objParams, objCode, objEnv) - Set MFn = varRet -End Function -objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) - -Function MEval(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = Evaluate(objArgs.Item(1), objEnv) - Set varRes = EvalLater(varRes, objNS) - Set MEval = varRes -End Function -objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) - -Function MQuote(objArgs, objEnv) - CheckArgNum objArgs, 1 - Set MQuote = objArgs.Item(1) -End Function -objNS.Add NewMalSym("quote"), NewVbsProc("MQuote", True) - -Function MQuasiQuote(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = EvalLater( _ - MQuasiQuoteExpand(objArgs, objEnv), objEnv) - Set MQuasiQuote = varRes -End Function -objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) - -Function MQuasiQuoteExpand(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = ExpandHelper(objArgs.Item(1)) - If varRes.Splice Then - Err.Raise vbObjectError, _ - "MQuasiQuoteExpand", "Wrong return value type." - End If - Set varRes = varRes.Value - - Set MQuasiQuoteExpand = varRes -End Function -objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) - -Class ExpandType - Public Splice - Public Value -End Class - -Function NewExpandType(objValue, boolSplice) - Dim varRes - Set varRes = New ExpandType - Set varRes.Value = objValue - varRes.Splice = boolSplice - Set NewExpandType = varRes -End Function - -Function ExpandHelper(objArg) - Dim varRes, boolSplice - Dim varBuilder, varEType, i - boolSplice = False - Select Case objArg.Type - Case TYPES.LIST - Dim boolNormal - boolNormal = False - - ' Check for unquotes. - Select Case objArg.Count - Case 2 - ' Maybe have a bug here - ' like (unquote a b c) should be throw a error - If objArg.Item(0).Type = TYPES.SYMBOL Then - Select Case objArg.Item(0).Value - Case "unquote" - Set varRes = objArg.Item(1) - Case "splice-unquote" - Set varRes = objArg.Item(1) - boolSplice = True - Case Else - boolNormal = True - End Select - Else - boolNormal = True - End If - Case Else - boolNormal = True - End Select - - If boolNormal Then - Set varRes = NewMalList(Array()) - Set varBuilder = varRes - - For i = 0 To objArg.Count - 1 - Set varEType = ExpandHelper(objArg.Item(i)) - If varEType.Splice Then - varBuilder.Add NewMalSym("concat") - Else - varBuilder.Add NewMalSym("cons") - End If - varBuilder.Add varEType.Value - varBuilder.Add NewMalList(Array()) - Set varBuilder = varBuilder.Item(2) - Next - End If - Case TYPES.VECTOR - Set varRes = NewMalList(Array( _ - NewMalSym("vec"), NewMalList(Array()))) - - Set varBuilder = varRes.Item(1) - For i = 0 To objArg.Count - 1 - Set varEType = ExpandHelper(objArg.Item(i)) - If varEType.Splice Then - varBuilder.Add NewMalSym("concat") - Else - varBuilder.Add NewMalSym("cons") - End If - varBuilder.Add varEType.Value - varBuilder.Add NewMalList(Array()) - Set varBuilder = varBuilder.Item(2) - Next - Case TYPES.HASHMAP - ' Maybe have a bug here. - ' e.g. {"key" ~value} - Set varRes = NewMalList(Array( _ - NewMalSym("quote"), objArg)) - Case TYPES.SYMBOL - Set varRes = NewMalList(Array( _ - NewMalSym("quote"), objArg)) - Case Else - ' Maybe have a bug here. - ' All unspecified type will return itself. - Set varRes = objArg - End Select - - Set ExpandHelper = NewExpandType(varRes, boolSplice) -End Function - -Call InitBuiltIn() - -Call InitArgs() -Sub InitArgs() - Dim objArgs - Set objArgs = NewMalList(Array()) - - Dim i - For i = 1 To WScript.Arguments.Count - 1 - objArgs.Add NewMalStr(WScript.Arguments.Item(i)) - Next - - objNS.Add NewMalSym("*ARGV*"), objArgs - - If WScript.Arguments.Count > 0 Then - REP "(load-file """ + WScript.Arguments.Item(0) + """)" - WScript.Quit 0 - End If -End Sub - -Call REPL() -Sub REPL() - Dim strCode, strResult - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(ByVal objCode, ByVal objEnv) - While True - If TypeName(objCode) = "Nothing" Then - Set Evaluate = Nothing - Exit Function - End If - - Dim varRet, objFirst - If objCode.Type = TYPES.LIST Then - If objCode.Count = 0 Then ' () - Set Evaluate = objCode - Exit Function - End If - Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) - Else - Set varRet = EvaluateAST(objCode, objEnv) - End If - - If TypeName(varRet) = "TailCall" Then - ' NOTICE: If not specify 'ByVal', - ' Change of arguments will influence - ' the caller's variable! - Set objCode = varRet.objMalType - Set objEnv = varRet.objEnv - Else - Set Evaluate = varRet - Exit Function - End If - Wend -End Function - - -Function EvaluateAST(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) - Case TYPES.LIST - Err.Raise vbObjectError, _ - "EvaluateAST", "Unexpect type." - Case TYPES.VECTOR - Set varRet = NewMalVec(Array()) - For i = 0 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case TYPES.HASHMAP - Set varRet = NewMalMap(Array(), Array()) - For Each i In objCode.Keys() - varRet.Add i, Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Set varRet = objCode - End Select - Set EvaluateAST = varRet -End Function - -Function EvaluateRest(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.LIST - Set varRet = NewMalList(Array(NewMalNil())) - For i = 1 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Err.Raise vbObjectError, _ - "EvaluateRest", "Unexpected type." - End Select - Set EvaluateRest = varRet -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objNS)) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" +Include "Core.vbs" + +Class TailCall + Public objMalType + Public objEnv +End Class + +Function EvalLater(objMal, objEnv) + Dim varRes + Set varRes = New TailCall + Set varRes.objMalType = objMal + Set varRes.objEnv = objEnv + Set EvalLater = varRes +End Function + +Function MDef(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv) + objEnv.Add objArgs.Item(1), varRet + Set MDef = varRet +End Function +objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) + +Function MLet(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objBinds + Set objBinds = objArgs.Item(1) + CheckListOrVec objBinds + + If objBinds.Count Mod 2 <> 0 Then + Err.Raise vbObjectError, _ + "MLet", "Wrong argument count." + End If + + Dim objNewEnv + Set objNewEnv = NewEnv(objEnv) + Dim i, objSym + For i = 0 To objBinds.Count - 1 Step 2 + Set objSym = objBinds.Item(i) + CheckType objSym, TYPES.SYMBOL + objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) + Next + + Set varRet = EvalLater(objArgs.Item(2), objNewEnv) + Set MLet = varRet +End Function +objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) + +Function MDo(objArgs, objEnv) + Dim varRet, i + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MDo", "Need more arguments." + End If + For i = 1 To objArgs.Count - 2 + Call Evaluate(objArgs.Item(i), objEnv) + Next + Set varRet = EvalLater( _ + objArgs.Item(objArgs.Count - 1), _ + objEnv) + Set MDo = varRet +End Function +objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) + +Function MIf(objArgs, objEnv) + Dim varRet + If objArgs.Count - 1 <> 3 And _ + objArgs.Count - 1 <> 2 Then + Err.Raise vbObjectError, _ + "MIf", "Wrong number of arguments." + End If + + Dim objCond + Set objCond = Evaluate(objArgs.Item(1), objEnv) + Dim boolCond + If objCond.Type = TYPES.BOOLEAN Then + boolCond = objCond.Value + Else + boolCond = True + End If + boolCond = (boolCond And objCond.Type <> TYPES.NIL) + If boolCond Then + Set varRet = EvalLater(objArgs.Item(2), objEnv) + Else + If objArgs.Count - 1 = 3 Then + Set varRet = EvalLater(objArgs.Item(3), objEnv) + Else + Set varRet = NewMalNil() + End If + End If + Set MIf = varRet +End Function +objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) + +Function MFn(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objParams, objCode + Set objParams = objArgs.Item(1) + CheckListOrVec objParams + Set objCode = objArgs.Item(2) + + Dim i + For i = 0 To objParams.Count - 1 + CheckType objParams.Item(i), TYPES.SYMBOL + Next + Set varRet = NewMalProc(objParams, objCode, objEnv) + Set MFn = varRet +End Function +objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) + +Function MEval(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = Evaluate(objArgs.Item(1), objEnv) + Set varRes = EvalLater(varRes, objNS) + Set MEval = varRes +End Function +objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) + +Function MQuote(objArgs, objEnv) + CheckArgNum objArgs, 1 + Set MQuote = objArgs.Item(1) +End Function +objNS.Add NewMalSym("quote"), NewVbsProc("MQuote", True) + +Function MQuasiQuote(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = EvalLater( _ + MQuasiQuoteExpand(objArgs, objEnv), objEnv) + Set MQuasiQuote = varRes +End Function +objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) + +Function MQuasiQuoteExpand(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = ExpandHelper(objArgs.Item(1)) + If varRes.Splice Then + Err.Raise vbObjectError, _ + "MQuasiQuoteExpand", "Wrong return value type." + End If + Set varRes = varRes.Value + + Set MQuasiQuoteExpand = varRes +End Function +objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) + +Class ExpandType + Public Splice + Public Value +End Class + +Function NewExpandType(objValue, boolSplice) + Dim varRes + Set varRes = New ExpandType + Set varRes.Value = objValue + varRes.Splice = boolSplice + Set NewExpandType = varRes +End Function + +Function ExpandHelper(objArg) + Dim varRes, boolSplice + Dim varBuilder, varEType, i + boolSplice = False + Select Case objArg.Type + Case TYPES.LIST + Dim boolNormal + boolNormal = False + + ' Check for unquotes. + Select Case objArg.Count + Case 2 + ' Maybe have a bug here + ' like (unquote a b c) should be throw a error + If objArg.Item(0).Type = TYPES.SYMBOL Then + Select Case objArg.Item(0).Value + Case "unquote" + Set varRes = objArg.Item(1) + Case "splice-unquote" + Set varRes = objArg.Item(1) + boolSplice = True + Case Else + boolNormal = True + End Select + Else + boolNormal = True + End If + Case Else + boolNormal = True + End Select + + If boolNormal Then + Set varRes = NewMalList(Array()) + Set varBuilder = varRes + + For i = 0 To objArg.Count - 1 + Set varEType = ExpandHelper(objArg.Item(i)) + If varEType.Splice Then + varBuilder.Add NewMalSym("concat") + Else + varBuilder.Add NewMalSym("cons") + End If + varBuilder.Add varEType.Value + varBuilder.Add NewMalList(Array()) + Set varBuilder = varBuilder.Item(2) + Next + End If + Case TYPES.VECTOR + Set varRes = NewMalList(Array( _ + NewMalSym("vec"), NewMalList(Array()))) + + Set varBuilder = varRes.Item(1) + For i = 0 To objArg.Count - 1 + Set varEType = ExpandHelper(objArg.Item(i)) + If varEType.Splice Then + varBuilder.Add NewMalSym("concat") + Else + varBuilder.Add NewMalSym("cons") + End If + varBuilder.Add varEType.Value + varBuilder.Add NewMalList(Array()) + Set varBuilder = varBuilder.Item(2) + Next + Case TYPES.HASHMAP + ' Maybe have a bug here. + ' e.g. {"key" ~value} + Set varRes = NewMalList(Array( _ + NewMalSym("quote"), objArg)) + Case TYPES.SYMBOL + Set varRes = NewMalList(Array( _ + NewMalSym("quote"), objArg)) + Case Else + ' Maybe have a bug here. + ' All unspecified type will return itself. + Set varRes = objArg + End Select + + Set ExpandHelper = NewExpandType(varRes, boolSplice) +End Function + +Call InitBuiltIn() + +Call InitArgs() +Sub InitArgs() + Dim objArgs + Set objArgs = NewMalList(Array()) + + Dim i + For i = 1 To WScript.Arguments.Count - 1 + objArgs.Add NewMalStr(WScript.Arguments.Item(i)) + Next + + objNS.Add NewMalSym("*ARGV*"), objArgs + + If WScript.Arguments.Count > 0 Then + REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 + End If +End Sub + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(ByVal objCode, ByVal objEnv) + While True + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + If TypeName(varRet) = "TailCall" Then + ' NOTICE: If not specify 'ByVal', + ' Change of arguments will influence + ' the caller's variable! + Set objCode = varRet.objMalType + Set objEnv = varRet.objEnv + Else + Set Evaluate = varRet + Exit Function + End If + Wend +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objNS)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/step8_macros.vbs b/impls/vbs/step8_macros.vbs index ed02107a3d..21b01d05a2 100644 --- a/impls/vbs/step8_macros.vbs +++ b/impls/vbs/step8_macros.vbs @@ -1,451 +1,451 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" -Include "Env.vbs" -Include "Core.vbs" - -Class TailCall - Public objMalType - Public objEnv -End Class - -Function EvalLater(objMal, objEnv) - Dim varRes - Set varRes = New TailCall - Set varRes.objMalType = objMal - Set varRes.objEnv = objEnv - Set EvalLater = varRes -End Function - -Function MDef(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) - objEnv.Add objArgs.Item(1), varRet - Set MDef = varRet -End Function -objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) - -Function MLet(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objBinds - Set objBinds = objArgs.Item(1) - CheckListOrVec objBinds - - If objBinds.Count Mod 2 <> 0 Then - Err.Raise vbObjectError, _ - "MLet", "Wrong argument count." - End If - - Dim objNewEnv - Set objNewEnv = NewEnv(objEnv) - Dim i, objSym - For i = 0 To objBinds.Count - 1 Step 2 - Set objSym = objBinds.Item(i) - CheckType objSym, TYPES.SYMBOL - objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) - Next - - Set varRet = EvalLater(objArgs.Item(2), objNewEnv) - Set MLet = varRet -End Function -objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) - -Function MDo(objArgs, objEnv) - Dim varRet, i - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MDo", "Need more arguments." - End If - For i = 1 To objArgs.Count - 2 - Call Evaluate(objArgs.Item(i), objEnv) - Next - Set varRet = EvalLater( _ - objArgs.Item(objArgs.Count - 1), _ - objEnv) - Set MDo = varRet -End Function -objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) - -Function MIf(objArgs, objEnv) - Dim varRet - If objArgs.Count - 1 <> 3 And _ - objArgs.Count - 1 <> 2 Then - Err.Raise vbObjectError, _ - "MIf", "Wrong number of arguments." - End If - - Dim objCond - Set objCond = Evaluate(objArgs.Item(1), objEnv) - Dim boolCond - If objCond.Type = TYPES.BOOLEAN Then - boolCond = objCond.Value - Else - boolCond = True - End If - boolCond = (boolCond And objCond.Type <> TYPES.NIL) - If boolCond Then - Set varRet = EvalLater(objArgs.Item(2), objEnv) - Else - If objArgs.Count - 1 = 3 Then - Set varRet = EvalLater(objArgs.Item(3), objEnv) - Else - Set varRet = NewMalNil() - End If - End If - Set MIf = varRet -End Function -objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) - -Function MFn(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objParams, objCode - Set objParams = objArgs.Item(1) - CheckListOrVec objParams - Set objCode = objArgs.Item(2) - - Dim i - For i = 0 To objParams.Count - 1 - CheckType objParams.Item(i), TYPES.SYMBOL - Next - Set varRet = NewMalProc(objParams, objCode, objEnv) - Set MFn = varRet -End Function -objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) - -Function MEval(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = Evaluate(objArgs.Item(1), objEnv) - Set varRes = EvalLater(varRes, objNS) - Set MEval = varRes -End Function -objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) - -Function MQuote(objArgs, objEnv) - CheckArgNum objArgs, 1 - Set MQuote = objArgs.Item(1) -End Function -objNS.Add NewMalSym("quote"), NewVbsProc("MQuote", True) - -Function MQuasiQuote(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = EvalLater( _ - MQuasiQuoteExpand(objArgs, objEnv), objEnv) - Set MQuasiQuote = varRes -End Function -objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) - -Function MQuasiQuoteExpand(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = ExpandHelper(objArgs.Item(1)) - If varRes.Splice Then - Err.Raise vbObjectError, _ - "MQuasiQuoteExpand", "Wrong return value type." - End If - Set varRes = varRes.Value - - Set MQuasiQuoteExpand = varRes -End Function -objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) - -Class ExpandType - Public Splice - Public Value -End Class - -Function NewExpandType(objValue, boolSplice) - Dim varRes - Set varRes = New ExpandType - Set varRes.Value = objValue - varRes.Splice = boolSplice - Set NewExpandType = varRes -End Function - -Function ExpandHelper(objArg) - Dim varRes, boolSplice - Dim varBuilder, varEType, i - boolSplice = False - Select Case objArg.Type - Case TYPES.LIST - Dim boolNormal - boolNormal = False - - ' Check for unquotes. - Select Case objArg.Count - Case 2 - ' Maybe have a bug here - ' like (unquote a b c) should be throw a error - If objArg.Item(0).Type = TYPES.SYMBOL Then - Select Case objArg.Item(0).Value - Case "unquote" - Set varRes = objArg.Item(1) - Case "splice-unquote" - Set varRes = objArg.Item(1) - boolSplice = True - Case Else - boolNormal = True - End Select - Else - boolNormal = True - End If - Case Else - boolNormal = True - End Select - - If boolNormal Then - Set varRes = NewMalList(Array()) - Set varBuilder = varRes - - For i = 0 To objArg.Count - 1 - Set varEType = ExpandHelper(objArg.Item(i)) - If varEType.Splice Then - varBuilder.Add NewMalSym("concat") - Else - varBuilder.Add NewMalSym("cons") - End If - varBuilder.Add varEType.Value - varBuilder.Add NewMalList(Array()) - Set varBuilder = varBuilder.Item(2) - Next - End If - Case TYPES.VECTOR - Set varRes = NewMalList(Array( _ - NewMalSym("vec"), NewMalList(Array()))) - - Set varBuilder = varRes.Item(1) - For i = 0 To objArg.Count - 1 - Set varEType = ExpandHelper(objArg.Item(i)) - If varEType.Splice Then - varBuilder.Add NewMalSym("concat") - Else - varBuilder.Add NewMalSym("cons") - End If - varBuilder.Add varEType.Value - varBuilder.Add NewMalList(Array()) - Set varBuilder = varBuilder.Item(2) - Next - Case TYPES.HASHMAP - ' Maybe have a bug here. - ' e.g. {"key" ~value} - Set varRes = NewMalList(Array( _ - NewMalSym("quote"), objArg)) - Case TYPES.SYMBOL - Set varRes = NewMalList(Array( _ - NewMalSym("quote"), objArg)) - Case Else - ' Maybe have a bug here. - ' All unspecified type will return itself. - Set varRes = objArg - End Select - - Set ExpandHelper = NewExpandType(varRes, boolSplice) -End Function - -Function MDefMacro(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv).Copy() - CheckType varRet, TYPES.PROCEDURE - varRet.IsMacro = True - objEnv.Add objArgs.Item(1), varRet - Set MDefMacro = varRet -End Function -objNS.Add NewMalSym("defmacro!"), NewVbsProc("MDefMacro", True) - -Function IsMacroCall(objCode, objEnv) - Dim varRes - varRes = False - - ' VBS has no short-circuit evaluation. - If objCode.Type = TYPES.LIST Then - If objCode.Count > 0 Then - If objCode.Item(0).Type = TYPES.SYMBOL Then - Dim varValue - Set varValue = objEnv.Get(objCode.Item(0)) - If varValue.Type = TYPES.PROCEDURE Then - If varValue.IsMacro Then - varRes = True - End If - End If - End If - End If - End If - - IsMacroCall = varRes -End Function - -Function MacroExpand(ByVal objAST, ByVal objEnv) - Dim varRes - While IsMacroCall(objAST, objEnv) - Dim varMacro - Set varMacro = objEnv.Get(objAST.Item(0)) - Set objAST = varMacro.MacroApply(objAST, objEnv) - Wend - Set varRes = objAST - Set MacroExpand = varRes -End Function - -Function MMacroExpand(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - Set varRes = MacroExpand(objArgs.Item(1), objEnv) - Set MMacroExpand = varRes -End Function -objNS.Add NewMalSym("macroexpand"), NewVbsProc("MMacroExpand", True) - -Call InitBuiltIn() -Call InitMacro() - -Call InitArgs() -Sub InitArgs() - Dim objArgs - Set objArgs = NewMalList(Array()) - - Dim i - For i = 1 To WScript.Arguments.Count - 1 - objArgs.Add NewMalStr(WScript.Arguments.Item(i)) - Next - - objNS.Add NewMalSym("*ARGV*"), objArgs - - If WScript.Arguments.Count > 0 Then - REP "(load-file """ + WScript.Arguments.Item(0) + """)" - WScript.Quit 0 - End If -End Sub - -Call REPL() -Sub REPL() - Dim strCode, strResult - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(ByVal objCode, ByVal objEnv) - While True - If TypeName(objCode) = "Nothing" Then - Set Evaluate = Nothing - Exit Function - End If - - Set objCode = MacroExpand(objCode, objEnv) - - Dim varRet, objFirst - If objCode.Type = TYPES.LIST Then - If objCode.Count = 0 Then ' () - Set Evaluate = objCode - Exit Function - End If - - Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) - Else - Set varRet = EvaluateAST(objCode, objEnv) - End If - - If TypeName(varRet) = "TailCall" Then - ' NOTICE: If not specify 'ByVal', - ' Change of arguments will influence - ' the caller's variable! - Set objCode = varRet.objMalType - Set objEnv = varRet.objEnv - Else - Set Evaluate = varRet - Exit Function - End If - Wend -End Function - - -Function EvaluateAST(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) - Case TYPES.LIST - Err.Raise vbObjectError, _ - "EvaluateAST", "Unexpect type." - Case TYPES.VECTOR - Set varRet = NewMalVec(Array()) - For i = 0 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case TYPES.HASHMAP - Set varRet = NewMalMap(Array(), Array()) - For Each i In objCode.Keys() - varRet.Add i, Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Set varRet = objCode - End Select - Set EvaluateAST = varRet -End Function - -Function EvaluateRest(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.LIST - Set varRet = NewMalList(Array(NewMalNil())) - For i = 1 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Err.Raise vbObjectError, _ - "EvaluateRest", "Unexpected type." - End Select - Set EvaluateRest = varRet -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objNS)) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" +Include "Core.vbs" + +Class TailCall + Public objMalType + Public objEnv +End Class + +Function EvalLater(objMal, objEnv) + Dim varRes + Set varRes = New TailCall + Set varRes.objMalType = objMal + Set varRes.objEnv = objEnv + Set EvalLater = varRes +End Function + +Function MDef(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv) + objEnv.Add objArgs.Item(1), varRet + Set MDef = varRet +End Function +objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) + +Function MLet(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objBinds + Set objBinds = objArgs.Item(1) + CheckListOrVec objBinds + + If objBinds.Count Mod 2 <> 0 Then + Err.Raise vbObjectError, _ + "MLet", "Wrong argument count." + End If + + Dim objNewEnv + Set objNewEnv = NewEnv(objEnv) + Dim i, objSym + For i = 0 To objBinds.Count - 1 Step 2 + Set objSym = objBinds.Item(i) + CheckType objSym, TYPES.SYMBOL + objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) + Next + + Set varRet = EvalLater(objArgs.Item(2), objNewEnv) + Set MLet = varRet +End Function +objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) + +Function MDo(objArgs, objEnv) + Dim varRet, i + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MDo", "Need more arguments." + End If + For i = 1 To objArgs.Count - 2 + Call Evaluate(objArgs.Item(i), objEnv) + Next + Set varRet = EvalLater( _ + objArgs.Item(objArgs.Count - 1), _ + objEnv) + Set MDo = varRet +End Function +objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) + +Function MIf(objArgs, objEnv) + Dim varRet + If objArgs.Count - 1 <> 3 And _ + objArgs.Count - 1 <> 2 Then + Err.Raise vbObjectError, _ + "MIf", "Wrong number of arguments." + End If + + Dim objCond + Set objCond = Evaluate(objArgs.Item(1), objEnv) + Dim boolCond + If objCond.Type = TYPES.BOOLEAN Then + boolCond = objCond.Value + Else + boolCond = True + End If + boolCond = (boolCond And objCond.Type <> TYPES.NIL) + If boolCond Then + Set varRet = EvalLater(objArgs.Item(2), objEnv) + Else + If objArgs.Count - 1 = 3 Then + Set varRet = EvalLater(objArgs.Item(3), objEnv) + Else + Set varRet = NewMalNil() + End If + End If + Set MIf = varRet +End Function +objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) + +Function MFn(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objParams, objCode + Set objParams = objArgs.Item(1) + CheckListOrVec objParams + Set objCode = objArgs.Item(2) + + Dim i + For i = 0 To objParams.Count - 1 + CheckType objParams.Item(i), TYPES.SYMBOL + Next + Set varRet = NewMalProc(objParams, objCode, objEnv) + Set MFn = varRet +End Function +objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) + +Function MEval(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = Evaluate(objArgs.Item(1), objEnv) + Set varRes = EvalLater(varRes, objNS) + Set MEval = varRes +End Function +objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) + +Function MQuote(objArgs, objEnv) + CheckArgNum objArgs, 1 + Set MQuote = objArgs.Item(1) +End Function +objNS.Add NewMalSym("quote"), NewVbsProc("MQuote", True) + +Function MQuasiQuote(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = EvalLater( _ + MQuasiQuoteExpand(objArgs, objEnv), objEnv) + Set MQuasiQuote = varRes +End Function +objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) + +Function MQuasiQuoteExpand(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = ExpandHelper(objArgs.Item(1)) + If varRes.Splice Then + Err.Raise vbObjectError, _ + "MQuasiQuoteExpand", "Wrong return value type." + End If + Set varRes = varRes.Value + + Set MQuasiQuoteExpand = varRes +End Function +objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) + +Class ExpandType + Public Splice + Public Value +End Class + +Function NewExpandType(objValue, boolSplice) + Dim varRes + Set varRes = New ExpandType + Set varRes.Value = objValue + varRes.Splice = boolSplice + Set NewExpandType = varRes +End Function + +Function ExpandHelper(objArg) + Dim varRes, boolSplice + Dim varBuilder, varEType, i + boolSplice = False + Select Case objArg.Type + Case TYPES.LIST + Dim boolNormal + boolNormal = False + + ' Check for unquotes. + Select Case objArg.Count + Case 2 + ' Maybe have a bug here + ' like (unquote a b c) should be throw a error + If objArg.Item(0).Type = TYPES.SYMBOL Then + Select Case objArg.Item(0).Value + Case "unquote" + Set varRes = objArg.Item(1) + Case "splice-unquote" + Set varRes = objArg.Item(1) + boolSplice = True + Case Else + boolNormal = True + End Select + Else + boolNormal = True + End If + Case Else + boolNormal = True + End Select + + If boolNormal Then + Set varRes = NewMalList(Array()) + Set varBuilder = varRes + + For i = 0 To objArg.Count - 1 + Set varEType = ExpandHelper(objArg.Item(i)) + If varEType.Splice Then + varBuilder.Add NewMalSym("concat") + Else + varBuilder.Add NewMalSym("cons") + End If + varBuilder.Add varEType.Value + varBuilder.Add NewMalList(Array()) + Set varBuilder = varBuilder.Item(2) + Next + End If + Case TYPES.VECTOR + Set varRes = NewMalList(Array( _ + NewMalSym("vec"), NewMalList(Array()))) + + Set varBuilder = varRes.Item(1) + For i = 0 To objArg.Count - 1 + Set varEType = ExpandHelper(objArg.Item(i)) + If varEType.Splice Then + varBuilder.Add NewMalSym("concat") + Else + varBuilder.Add NewMalSym("cons") + End If + varBuilder.Add varEType.Value + varBuilder.Add NewMalList(Array()) + Set varBuilder = varBuilder.Item(2) + Next + Case TYPES.HASHMAP + ' Maybe have a bug here. + ' e.g. {"key" ~value} + Set varRes = NewMalList(Array( _ + NewMalSym("quote"), objArg)) + Case TYPES.SYMBOL + Set varRes = NewMalList(Array( _ + NewMalSym("quote"), objArg)) + Case Else + ' Maybe have a bug here. + ' All unspecified type will return itself. + Set varRes = objArg + End Select + + Set ExpandHelper = NewExpandType(varRes, boolSplice) +End Function + +Function MDefMacro(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv).Copy() + CheckType varRet, TYPES.PROCEDURE + varRet.IsMacro = True + objEnv.Add objArgs.Item(1), varRet + Set MDefMacro = varRet +End Function +objNS.Add NewMalSym("defmacro!"), NewVbsProc("MDefMacro", True) + +Function IsMacroCall(objCode, objEnv) + Dim varRes + varRes = False + + ' VBS has no short-circuit evaluation. + If objCode.Type = TYPES.LIST Then + If objCode.Count > 0 Then + If objCode.Item(0).Type = TYPES.SYMBOL Then + Dim varValue + Set varValue = objEnv.Get(objCode.Item(0)) + If varValue.Type = TYPES.PROCEDURE Then + If varValue.IsMacro Then + varRes = True + End If + End If + End If + End If + End If + + IsMacroCall = varRes +End Function + +Function MacroExpand(ByVal objAST, ByVal objEnv) + Dim varRes + While IsMacroCall(objAST, objEnv) + Dim varMacro + Set varMacro = objEnv.Get(objAST.Item(0)) + Set objAST = varMacro.MacroApply(objAST, objEnv) + Wend + Set varRes = objAST + Set MacroExpand = varRes +End Function + +Function MMacroExpand(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + Set varRes = MacroExpand(objArgs.Item(1), objEnv) + Set MMacroExpand = varRes +End Function +objNS.Add NewMalSym("macroexpand"), NewVbsProc("MMacroExpand", True) + +Call InitBuiltIn() +Call InitMacro() + +Call InitArgs() +Sub InitArgs() + Dim objArgs + Set objArgs = NewMalList(Array()) + + Dim i + For i = 1 To WScript.Arguments.Count - 1 + objArgs.Add NewMalStr(WScript.Arguments.Item(i)) + Next + + objNS.Add NewMalSym("*ARGV*"), objArgs + + If WScript.Arguments.Count > 0 Then + REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 + End If +End Sub + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(ByVal objCode, ByVal objEnv) + While True + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + + Set objCode = MacroExpand(objCode, objEnv) + + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + If TypeName(varRet) = "TailCall" Then + ' NOTICE: If not specify 'ByVal', + ' Change of arguments will influence + ' the caller's variable! + Set objCode = varRet.objMalType + Set objEnv = varRet.objEnv + Else + Set Evaluate = varRet + Exit Function + End If + Wend +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objNS)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/step9_try.vbs b/impls/vbs/step9_try.vbs index 8b4af962e0..c1764de599 100644 --- a/impls/vbs/step9_try.vbs +++ b/impls/vbs/step9_try.vbs @@ -1,518 +1,518 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" -Include "Env.vbs" -Include "Core.vbs" - -Class TailCall - Public objMalType - Public objEnv -End Class - -Function EvalLater(objMal, objEnv) - Dim varRes - Set varRes = New TailCall - Set varRes.objMalType = objMal - Set varRes.objEnv = objEnv - Set EvalLater = varRes -End Function - -Function MDef(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) - objEnv.Add objArgs.Item(1), varRet - Set MDef = varRet -End Function -objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) - -Function MLet(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objBinds - Set objBinds = objArgs.Item(1) - CheckListOrVec objBinds - - If objBinds.Count Mod 2 <> 0 Then - Err.Raise vbObjectError, _ - "MLet", "Wrong argument count." - End If - - Dim objNewEnv - Set objNewEnv = NewEnv(objEnv) - Dim i, objSym - For i = 0 To objBinds.Count - 1 Step 2 - Set objSym = objBinds.Item(i) - CheckType objSym, TYPES.SYMBOL - objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) - Next - - Set varRet = EvalLater(objArgs.Item(2), objNewEnv) - Set MLet = varRet -End Function -objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) - -Function MDo(objArgs, objEnv) - Dim varRet, i - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MDo", "Need more arguments." - End If - For i = 1 To objArgs.Count - 2 - Call Evaluate(objArgs.Item(i), objEnv) - Next - Set varRet = EvalLater( _ - objArgs.Item(objArgs.Count - 1), _ - objEnv) - Set MDo = varRet -End Function -objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) - -Function MIf(objArgs, objEnv) - Dim varRet - If objArgs.Count - 1 <> 3 And _ - objArgs.Count - 1 <> 2 Then - Err.Raise vbObjectError, _ - "MIf", "Wrong number of arguments." - End If - - Dim objCond - Set objCond = Evaluate(objArgs.Item(1), objEnv) - Dim boolCond - If objCond.Type = TYPES.BOOLEAN Then - boolCond = objCond.Value - Else - boolCond = True - End If - boolCond = (boolCond And objCond.Type <> TYPES.NIL) - If boolCond Then - Set varRet = EvalLater(objArgs.Item(2), objEnv) - Else - If objArgs.Count - 1 = 3 Then - Set varRet = EvalLater(objArgs.Item(3), objEnv) - Else - Set varRet = NewMalNil() - End If - End If - Set MIf = varRet -End Function -objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) - -Function MFn(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objParams, objCode - Set objParams = objArgs.Item(1) - CheckListOrVec objParams - Set objCode = objArgs.Item(2) - - Dim i - For i = 0 To objParams.Count - 1 - CheckType objParams.Item(i), TYPES.SYMBOL - Next - Set varRet = NewMalProc(objParams, objCode, objEnv) - Set MFn = varRet -End Function -objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) - -Function MEval(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = Evaluate(objArgs.Item(1), objEnv) - Set varRes = EvalLater(varRes, objNS) - Set MEval = varRes -End Function -objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) - -Function MQuote(objArgs, objEnv) - CheckArgNum objArgs, 1 - Set MQuote = objArgs.Item(1) -End Function -objNS.Add NewMalSym("quote"), NewVbsProc("MQuote", True) - -Function MQuasiQuote(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = EvalLater( _ - MQuasiQuoteExpand(objArgs, objEnv), objEnv) - Set MQuasiQuote = varRes -End Function -objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) - -Function MQuasiQuoteExpand(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = ExpandHelper(objArgs.Item(1)) - If varRes.Splice Then - Err.Raise vbObjectError, _ - "MQuasiQuoteExpand", "Wrong return value type." - End If - Set varRes = varRes.Value - - Set MQuasiQuoteExpand = varRes -End Function -objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) - -Class ExpandType - Public Splice - Public Value -End Class - -Function NewExpandType(objValue, boolSplice) - Dim varRes - Set varRes = New ExpandType - Set varRes.Value = objValue - varRes.Splice = boolSplice - Set NewExpandType = varRes -End Function - -Function ExpandHelper(objArg) - Dim varRes, boolSplice - Dim varBuilder, varEType, i - boolSplice = False - Select Case objArg.Type - Case TYPES.LIST - Dim boolNormal - boolNormal = False - - ' Check for unquotes. - Select Case objArg.Count - Case 2 - ' Maybe have a bug here - ' like (unquote a b c) should be throw a error - If objArg.Item(0).Type = TYPES.SYMBOL Then - Select Case objArg.Item(0).Value - Case "unquote" - Set varRes = objArg.Item(1) - Case "splice-unquote" - Set varRes = objArg.Item(1) - boolSplice = True - Case Else - boolNormal = True - End Select - Else - boolNormal = True - End If - Case Else - boolNormal = True - End Select - - If boolNormal Then - Set varRes = NewMalList(Array()) - Set varBuilder = varRes - - For i = 0 To objArg.Count - 1 - Set varEType = ExpandHelper(objArg.Item(i)) - If varEType.Splice Then - varBuilder.Add NewMalSym("concat") - Else - varBuilder.Add NewMalSym("cons") - End If - varBuilder.Add varEType.Value - varBuilder.Add NewMalList(Array()) - Set varBuilder = varBuilder.Item(2) - Next - End If - Case TYPES.VECTOR - Set varRes = NewMalList(Array( _ - NewMalSym("vec"), NewMalList(Array()))) - - Set varBuilder = varRes.Item(1) - For i = 0 To objArg.Count - 1 - Set varEType = ExpandHelper(objArg.Item(i)) - If varEType.Splice Then - varBuilder.Add NewMalSym("concat") - Else - varBuilder.Add NewMalSym("cons") - End If - varBuilder.Add varEType.Value - varBuilder.Add NewMalList(Array()) - Set varBuilder = varBuilder.Item(2) - Next - Case TYPES.HASHMAP - ' Maybe have a bug here. - ' e.g. {"key" ~value} - Set varRes = NewMalList(Array( _ - NewMalSym("quote"), objArg)) - Case TYPES.SYMBOL - Set varRes = NewMalList(Array( _ - NewMalSym("quote"), objArg)) - Case Else - ' Maybe have a bug here. - ' All unspecified type will return itself. - Set varRes = objArg - End Select - - Set ExpandHelper = NewExpandType(varRes, boolSplice) -End Function - -Function MDefMacro(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv).Copy() - CheckType varRet, TYPES.PROCEDURE - varRet.IsMacro = True - objEnv.Add objArgs.Item(1), varRet - Set MDefMacro = varRet -End Function -objNS.Add NewMalSym("defmacro!"), NewVbsProc("MDefMacro", True) - -Function IsMacroCall(objCode, objEnv) - Dim varRes - varRes = False - - ' VBS has no short-circuit evaluation. - If objCode.Type = TYPES.LIST Then - If objCode.Count > 0 Then - If objCode.Item(0).Type = TYPES.SYMBOL Then - Dim varValue - Set varValue = objEnv.Get(objCode.Item(0)) - If varValue.Type = TYPES.PROCEDURE Then - If varValue.IsMacro Then - varRes = True - End If - End If - End If - End If - End If - - IsMacroCall = varRes -End Function - -Function MacroExpand(ByVal objAST, ByVal objEnv) - Dim varRes - While IsMacroCall(objAST, objEnv) - Dim varMacro - Set varMacro = objEnv.Get(objAST.Item(0)) - Set objAST = varMacro.MacroApply(objAST, objEnv) - Wend - Set varRes = objAST - Set MacroExpand = varRes -End Function - -Function MMacroExpand(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - Set varRes = MacroExpand(objArgs.Item(1), objEnv) - Set MMacroExpand = varRes -End Function -objNS.Add NewMalSym("macroexpand"), NewVbsProc("MMacroExpand", True) - -Function MTry(objArgs, objEnv) - Dim varRes - - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MTry", "Need more arguments." - End If - - If objArgs.Count - 1 = 1 Then - Set varRes = EvalLater(objArgs.Item(1), objEnv) - Set MTry = varRes - Exit Function - End If - - CheckArgNum objArgs, 2 - CheckType objArgs.Item(2), TYPES.LIST - - Dim objTry, objCatch - Set objTry = objArgs.Item(1) - Set objCatch = objArgs.Item(2) - - CheckArgNum objCatch, 2 - CheckType objCatch.Item(0), TYPES.SYMBOL - CheckType objCatch.Item(1), TYPES.SYMBOL - If objCatch.Item(0).Value <> "catch*" Then - Err.Raise vbObjectError, _ - "MTry", "Unexpect argument(s)." - End If - - On Error Resume Next - Set varRes = Evaluate(objTry, objEnv) - If Err.Number <> 0 Then - Dim objException - - If Err.Source <> "MThrow" Then - Set objException = NewMalStr(Err.Description) - Else - Set objException = objExceptions.Item(Err.Description) - objExceptions.Remove Err.Description - End If - - Call Err.Clear() - On Error Goto 0 - - ' The code below may cause error too. - ' So we should clear err info & throw out any errors. - ' Use 'quote' to avoid eval objExp again. - Set varRes = Evaluate(NewMalList(Array( _ - NewMalSym("let*"), NewMalList(Array( _ - objCatch.Item(1), NewMalList(Array( _ - NewMalSym("quote"), objException)))), _ - objCatch.Item(2))), objEnv) - Else - On Error Goto 0 - End If - - Set MTry = varRes -End Function -objNS.Add NewMalSym("try*"), NewVbsProc("MTry", True) - -Call InitBuiltIn() -Call InitMacro() - -Call InitArgs() -Sub InitArgs() - Dim objArgs - Set objArgs = NewMalList(Array()) - - Dim i - For i = 1 To WScript.Arguments.Count - 1 - objArgs.Add NewMalStr(WScript.Arguments.Item(i)) - Next - - objNS.Add NewMalSym("*ARGV*"), objArgs - - If WScript.Arguments.Count > 0 Then - REP "(load-file """ + WScript.Arguments.Item(0) + """)" - WScript.Quit 0 - End If -End Sub - -Call REPL() -Sub REPL() - Dim strCode, strResult - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - If Err.Source = "MThrow" Then - 'WScript.StdErr.WriteLine Err.Source + ": " + _ - WScript.StdErr.WriteLine "Exception: " + _ - PrintMalType(objExceptions.Item(Err.Description), True) - objExceptions.Remove Err.Description - Else - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - End If - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(ByVal objCode, ByVal objEnv) - While True - If TypeName(objCode) = "Nothing" Then - Set Evaluate = Nothing - Exit Function - End If - - Set objCode = MacroExpand(objCode, objEnv) - - Dim varRet, objFirst - If objCode.Type = TYPES.LIST Then - If objCode.Count = 0 Then ' () - Set Evaluate = objCode - Exit Function - End If - - Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) - Else - Set varRet = EvaluateAST(objCode, objEnv) - End If - - If TypeName(varRet) = "TailCall" Then - ' NOTICE: If not specify 'ByVal', - ' Change of arguments will influence - ' the caller's variable! - Set objCode = varRet.objMalType - Set objEnv = varRet.objEnv - Else - Set Evaluate = varRet - Exit Function - End If - Wend -End Function - - -Function EvaluateAST(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) - Case TYPES.LIST - Err.Raise vbObjectError, _ - "EvaluateAST", "Unexpect type." - Case TYPES.VECTOR - Set varRet = NewMalVec(Array()) - For i = 0 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case TYPES.HASHMAP - Set varRet = NewMalMap(Array(), Array()) - For Each i In objCode.Keys() - varRet.Add i, Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Set varRet = objCode - End Select - Set EvaluateAST = varRet -End Function - -Function EvaluateRest(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.LIST - Set varRet = NewMalList(Array(NewMalNil())) - For i = 1 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Err.Raise vbObjectError, _ - "EvaluateRest", "Unexpected type." - End Select - Set EvaluateRest = varRet -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objNS)) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" +Include "Core.vbs" + +Class TailCall + Public objMalType + Public objEnv +End Class + +Function EvalLater(objMal, objEnv) + Dim varRes + Set varRes = New TailCall + Set varRes.objMalType = objMal + Set varRes.objEnv = objEnv + Set EvalLater = varRes +End Function + +Function MDef(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv) + objEnv.Add objArgs.Item(1), varRet + Set MDef = varRet +End Function +objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) + +Function MLet(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objBinds + Set objBinds = objArgs.Item(1) + CheckListOrVec objBinds + + If objBinds.Count Mod 2 <> 0 Then + Err.Raise vbObjectError, _ + "MLet", "Wrong argument count." + End If + + Dim objNewEnv + Set objNewEnv = NewEnv(objEnv) + Dim i, objSym + For i = 0 To objBinds.Count - 1 Step 2 + Set objSym = objBinds.Item(i) + CheckType objSym, TYPES.SYMBOL + objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) + Next + + Set varRet = EvalLater(objArgs.Item(2), objNewEnv) + Set MLet = varRet +End Function +objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) + +Function MDo(objArgs, objEnv) + Dim varRet, i + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MDo", "Need more arguments." + End If + For i = 1 To objArgs.Count - 2 + Call Evaluate(objArgs.Item(i), objEnv) + Next + Set varRet = EvalLater( _ + objArgs.Item(objArgs.Count - 1), _ + objEnv) + Set MDo = varRet +End Function +objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) + +Function MIf(objArgs, objEnv) + Dim varRet + If objArgs.Count - 1 <> 3 And _ + objArgs.Count - 1 <> 2 Then + Err.Raise vbObjectError, _ + "MIf", "Wrong number of arguments." + End If + + Dim objCond + Set objCond = Evaluate(objArgs.Item(1), objEnv) + Dim boolCond + If objCond.Type = TYPES.BOOLEAN Then + boolCond = objCond.Value + Else + boolCond = True + End If + boolCond = (boolCond And objCond.Type <> TYPES.NIL) + If boolCond Then + Set varRet = EvalLater(objArgs.Item(2), objEnv) + Else + If objArgs.Count - 1 = 3 Then + Set varRet = EvalLater(objArgs.Item(3), objEnv) + Else + Set varRet = NewMalNil() + End If + End If + Set MIf = varRet +End Function +objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) + +Function MFn(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objParams, objCode + Set objParams = objArgs.Item(1) + CheckListOrVec objParams + Set objCode = objArgs.Item(2) + + Dim i + For i = 0 To objParams.Count - 1 + CheckType objParams.Item(i), TYPES.SYMBOL + Next + Set varRet = NewMalProc(objParams, objCode, objEnv) + Set MFn = varRet +End Function +objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) + +Function MEval(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = Evaluate(objArgs.Item(1), objEnv) + Set varRes = EvalLater(varRes, objNS) + Set MEval = varRes +End Function +objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) + +Function MQuote(objArgs, objEnv) + CheckArgNum objArgs, 1 + Set MQuote = objArgs.Item(1) +End Function +objNS.Add NewMalSym("quote"), NewVbsProc("MQuote", True) + +Function MQuasiQuote(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = EvalLater( _ + MQuasiQuoteExpand(objArgs, objEnv), objEnv) + Set MQuasiQuote = varRes +End Function +objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) + +Function MQuasiQuoteExpand(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = ExpandHelper(objArgs.Item(1)) + If varRes.Splice Then + Err.Raise vbObjectError, _ + "MQuasiQuoteExpand", "Wrong return value type." + End If + Set varRes = varRes.Value + + Set MQuasiQuoteExpand = varRes +End Function +objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) + +Class ExpandType + Public Splice + Public Value +End Class + +Function NewExpandType(objValue, boolSplice) + Dim varRes + Set varRes = New ExpandType + Set varRes.Value = objValue + varRes.Splice = boolSplice + Set NewExpandType = varRes +End Function + +Function ExpandHelper(objArg) + Dim varRes, boolSplice + Dim varBuilder, varEType, i + boolSplice = False + Select Case objArg.Type + Case TYPES.LIST + Dim boolNormal + boolNormal = False + + ' Check for unquotes. + Select Case objArg.Count + Case 2 + ' Maybe have a bug here + ' like (unquote a b c) should be throw a error + If objArg.Item(0).Type = TYPES.SYMBOL Then + Select Case objArg.Item(0).Value + Case "unquote" + Set varRes = objArg.Item(1) + Case "splice-unquote" + Set varRes = objArg.Item(1) + boolSplice = True + Case Else + boolNormal = True + End Select + Else + boolNormal = True + End If + Case Else + boolNormal = True + End Select + + If boolNormal Then + Set varRes = NewMalList(Array()) + Set varBuilder = varRes + + For i = 0 To objArg.Count - 1 + Set varEType = ExpandHelper(objArg.Item(i)) + If varEType.Splice Then + varBuilder.Add NewMalSym("concat") + Else + varBuilder.Add NewMalSym("cons") + End If + varBuilder.Add varEType.Value + varBuilder.Add NewMalList(Array()) + Set varBuilder = varBuilder.Item(2) + Next + End If + Case TYPES.VECTOR + Set varRes = NewMalList(Array( _ + NewMalSym("vec"), NewMalList(Array()))) + + Set varBuilder = varRes.Item(1) + For i = 0 To objArg.Count - 1 + Set varEType = ExpandHelper(objArg.Item(i)) + If varEType.Splice Then + varBuilder.Add NewMalSym("concat") + Else + varBuilder.Add NewMalSym("cons") + End If + varBuilder.Add varEType.Value + varBuilder.Add NewMalList(Array()) + Set varBuilder = varBuilder.Item(2) + Next + Case TYPES.HASHMAP + ' Maybe have a bug here. + ' e.g. {"key" ~value} + Set varRes = NewMalList(Array( _ + NewMalSym("quote"), objArg)) + Case TYPES.SYMBOL + Set varRes = NewMalList(Array( _ + NewMalSym("quote"), objArg)) + Case Else + ' Maybe have a bug here. + ' All unspecified type will return itself. + Set varRes = objArg + End Select + + Set ExpandHelper = NewExpandType(varRes, boolSplice) +End Function + +Function MDefMacro(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv).Copy() + CheckType varRet, TYPES.PROCEDURE + varRet.IsMacro = True + objEnv.Add objArgs.Item(1), varRet + Set MDefMacro = varRet +End Function +objNS.Add NewMalSym("defmacro!"), NewVbsProc("MDefMacro", True) + +Function IsMacroCall(objCode, objEnv) + Dim varRes + varRes = False + + ' VBS has no short-circuit evaluation. + If objCode.Type = TYPES.LIST Then + If objCode.Count > 0 Then + If objCode.Item(0).Type = TYPES.SYMBOL Then + Dim varValue + Set varValue = objEnv.Get(objCode.Item(0)) + If varValue.Type = TYPES.PROCEDURE Then + If varValue.IsMacro Then + varRes = True + End If + End If + End If + End If + End If + + IsMacroCall = varRes +End Function + +Function MacroExpand(ByVal objAST, ByVal objEnv) + Dim varRes + While IsMacroCall(objAST, objEnv) + Dim varMacro + Set varMacro = objEnv.Get(objAST.Item(0)) + Set objAST = varMacro.MacroApply(objAST, objEnv) + Wend + Set varRes = objAST + Set MacroExpand = varRes +End Function + +Function MMacroExpand(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + Set varRes = MacroExpand(objArgs.Item(1), objEnv) + Set MMacroExpand = varRes +End Function +objNS.Add NewMalSym("macroexpand"), NewVbsProc("MMacroExpand", True) + +Function MTry(objArgs, objEnv) + Dim varRes + + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MTry", "Need more arguments." + End If + + If objArgs.Count - 1 = 1 Then + Set varRes = EvalLater(objArgs.Item(1), objEnv) + Set MTry = varRes + Exit Function + End If + + CheckArgNum objArgs, 2 + CheckType objArgs.Item(2), TYPES.LIST + + Dim objTry, objCatch + Set objTry = objArgs.Item(1) + Set objCatch = objArgs.Item(2) + + CheckArgNum objCatch, 2 + CheckType objCatch.Item(0), TYPES.SYMBOL + CheckType objCatch.Item(1), TYPES.SYMBOL + If objCatch.Item(0).Value <> "catch*" Then + Err.Raise vbObjectError, _ + "MTry", "Unexpect argument(s)." + End If + + On Error Resume Next + Set varRes = Evaluate(objTry, objEnv) + If Err.Number <> 0 Then + Dim objException + + If Err.Source <> "MThrow" Then + Set objException = NewMalStr(Err.Description) + Else + Set objException = objExceptions.Item(Err.Description) + objExceptions.Remove Err.Description + End If + + Call Err.Clear() + On Error Goto 0 + + ' The code below may cause error too. + ' So we should clear err info & throw out any errors. + ' Use 'quote' to avoid eval objExp again. + Set varRes = Evaluate(NewMalList(Array( _ + NewMalSym("let*"), NewMalList(Array( _ + objCatch.Item(1), NewMalList(Array( _ + NewMalSym("quote"), objException)))), _ + objCatch.Item(2))), objEnv) + Else + On Error Goto 0 + End If + + Set MTry = varRes +End Function +objNS.Add NewMalSym("try*"), NewVbsProc("MTry", True) + +Call InitBuiltIn() +Call InitMacro() + +Call InitArgs() +Sub InitArgs() + Dim objArgs + Set objArgs = NewMalList(Array()) + + Dim i + For i = 1 To WScript.Arguments.Count - 1 + objArgs.Add NewMalStr(WScript.Arguments.Item(i)) + Next + + objNS.Add NewMalSym("*ARGV*"), objArgs + + If WScript.Arguments.Count > 0 Then + REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 + End If +End Sub + +Call REPL() +Sub REPL() + Dim strCode, strResult + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + If Err.Source = "MThrow" Then + 'WScript.StdErr.WriteLine Err.Source + ": " + _ + WScript.StdErr.WriteLine "Exception: " + _ + PrintMalType(objExceptions.Item(Err.Description), True) + objExceptions.Remove Err.Description + Else + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + End If + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(ByVal objCode, ByVal objEnv) + While True + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + + Set objCode = MacroExpand(objCode, objEnv) + + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + If TypeName(varRet) = "TailCall" Then + ' NOTICE: If not specify 'ByVal', + ' Change of arguments will influence + ' the caller's variable! + Set objCode = varRet.objMalType + Set objEnv = varRet.objEnv + Else + Set Evaluate = varRet + Exit Function + End If + Wend +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objNS)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With End Sub \ No newline at end of file diff --git a/impls/vbs/stepA_mal.vbs b/impls/vbs/stepA_mal.vbs index d6bc3f3d5b..7199532cd0 100644 --- a/impls/vbs/stepA_mal.vbs +++ b/impls/vbs/stepA_mal.vbs @@ -1,519 +1,519 @@ -Option Explicit - -Include "Types.vbs" -Include "Reader.vbs" -Include "Printer.vbs" -Include "Env.vbs" -Include "Core.vbs" - -Class TailCall - Public objMalType - Public objEnv -End Class - -Function EvalLater(objMal, objEnv) - Dim varRes - Set varRes = New TailCall - Set varRes.objMalType = objMal - Set varRes.objEnv = objEnv - Set EvalLater = varRes -End Function - -Function MDef(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv) - objEnv.Add objArgs.Item(1), varRet - Set MDef = varRet -End Function -objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) - -Function MLet(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objBinds - Set objBinds = objArgs.Item(1) - CheckListOrVec objBinds - - If objBinds.Count Mod 2 <> 0 Then - Err.Raise vbObjectError, _ - "MLet", "Wrong argument count." - End If - - Dim objNewEnv - Set objNewEnv = NewEnv(objEnv) - Dim i, objSym - For i = 0 To objBinds.Count - 1 Step 2 - Set objSym = objBinds.Item(i) - CheckType objSym, TYPES.SYMBOL - objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) - Next - - Set varRet = EvalLater(objArgs.Item(2), objNewEnv) - Set MLet = varRet -End Function -objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) - -Function MDo(objArgs, objEnv) - Dim varRet, i - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MDo", "Need more arguments." - End If - For i = 1 To objArgs.Count - 2 - Call Evaluate(objArgs.Item(i), objEnv) - Next - Set varRet = EvalLater( _ - objArgs.Item(objArgs.Count - 1), _ - objEnv) - Set MDo = varRet -End Function -objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) - -Function MIf(objArgs, objEnv) - Dim varRet - If objArgs.Count - 1 <> 3 And _ - objArgs.Count - 1 <> 2 Then - Err.Raise vbObjectError, _ - "MIf", "Wrong number of arguments." - End If - - Dim objCond - Set objCond = Evaluate(objArgs.Item(1), objEnv) - Dim boolCond - If objCond.Type = TYPES.BOOLEAN Then - boolCond = objCond.Value - Else - boolCond = True - End If - boolCond = (boolCond And objCond.Type <> TYPES.NIL) - If boolCond Then - Set varRet = EvalLater(objArgs.Item(2), objEnv) - Else - If objArgs.Count - 1 = 3 Then - Set varRet = EvalLater(objArgs.Item(3), objEnv) - Else - Set varRet = NewMalNil() - End If - End If - Set MIf = varRet -End Function -objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) - -Function MFn(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - - Dim objParams, objCode - Set objParams = objArgs.Item(1) - CheckListOrVec objParams - Set objCode = objArgs.Item(2) - - Dim i - For i = 0 To objParams.Count - 1 - CheckType objParams.Item(i), TYPES.SYMBOL - Next - Set varRet = NewMalProc(objParams, objCode, objEnv) - Set MFn = varRet -End Function -objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) - -Function MEval(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = Evaluate(objArgs.Item(1), objEnv) - Set varRes = EvalLater(varRes, objNS) - Set MEval = varRes -End Function -objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) - -Function MQuote(objArgs, objEnv) - CheckArgNum objArgs, 1 - Set MQuote = objArgs.Item(1) -End Function -objNS.Add NewMalSym("quote"), NewVbsProc("MQuote", True) - -Function MQuasiQuote(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = EvalLater( _ - MQuasiQuoteExpand(objArgs, objEnv), objEnv) - Set MQuasiQuote = varRes -End Function -objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) - -Function MQuasiQuoteExpand(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - - Set varRes = ExpandHelper(objArgs.Item(1)) - If varRes.Splice Then - Err.Raise vbObjectError, _ - "MQuasiQuoteExpand", "Wrong return value type." - End If - Set varRes = varRes.Value - - Set MQuasiQuoteExpand = varRes -End Function -objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) - -Class ExpandType - Public Splice - Public Value -End Class - -Function NewExpandType(objValue, boolSplice) - Dim varRes - Set varRes = New ExpandType - Set varRes.Value = objValue - varRes.Splice = boolSplice - Set NewExpandType = varRes -End Function - -Function ExpandHelper(objArg) - Dim varRes, boolSplice - Dim varBuilder, varEType, i - boolSplice = False - Select Case objArg.Type - Case TYPES.LIST - Dim boolNormal - boolNormal = False - - ' Check for unquotes. - Select Case objArg.Count - Case 2 - ' Maybe have a bug here - ' like (unquote a b c) should be throw a error - If objArg.Item(0).Type = TYPES.SYMBOL Then - Select Case objArg.Item(0).Value - Case "unquote" - Set varRes = objArg.Item(1) - Case "splice-unquote" - Set varRes = objArg.Item(1) - boolSplice = True - Case Else - boolNormal = True - End Select - Else - boolNormal = True - End If - Case Else - boolNormal = True - End Select - - If boolNormal Then - Set varRes = NewMalList(Array()) - Set varBuilder = varRes - - For i = 0 To objArg.Count - 1 - Set varEType = ExpandHelper(objArg.Item(i)) - If varEType.Splice Then - varBuilder.Add NewMalSym("concat") - Else - varBuilder.Add NewMalSym("cons") - End If - varBuilder.Add varEType.Value - varBuilder.Add NewMalList(Array()) - Set varBuilder = varBuilder.Item(2) - Next - End If - Case TYPES.VECTOR - Set varRes = NewMalList(Array( _ - NewMalSym("vec"), NewMalList(Array()))) - - Set varBuilder = varRes.Item(1) - For i = 0 To objArg.Count - 1 - Set varEType = ExpandHelper(objArg.Item(i)) - If varEType.Splice Then - varBuilder.Add NewMalSym("concat") - Else - varBuilder.Add NewMalSym("cons") - End If - varBuilder.Add varEType.Value - varBuilder.Add NewMalList(Array()) - Set varBuilder = varBuilder.Item(2) - Next - Case TYPES.HASHMAP - ' Maybe have a bug here. - ' e.g. {"key" ~value} - Set varRes = NewMalList(Array( _ - NewMalSym("quote"), objArg)) - Case TYPES.SYMBOL - Set varRes = NewMalList(Array( _ - NewMalSym("quote"), objArg)) - Case Else - ' Maybe have a bug here. - ' All unspecified type will return itself. - Set varRes = objArg - End Select - - Set ExpandHelper = NewExpandType(varRes, boolSplice) -End Function - -Function MDefMacro(objArgs, objEnv) - Dim varRet - CheckArgNum objArgs, 2 - CheckType objArgs.Item(1), TYPES.SYMBOL - Set varRet = Evaluate(objArgs.Item(2), objEnv).Copy() - CheckType varRet, TYPES.PROCEDURE - varRet.IsMacro = True - objEnv.Add objArgs.Item(1), varRet - Set MDefMacro = varRet -End Function -objNS.Add NewMalSym("defmacro!"), NewVbsProc("MDefMacro", True) - -Function IsMacroCall(objCode, objEnv) - Dim varRes - varRes = False - - ' VBS has no short-circuit evaluation. - If objCode.Type = TYPES.LIST Then - If objCode.Count > 0 Then - If objCode.Item(0).Type = TYPES.SYMBOL Then - Dim varValue - Set varValue = objEnv.Get(objCode.Item(0)) - If varValue.Type = TYPES.PROCEDURE Then - If varValue.IsMacro Then - varRes = True - End If - End If - End If - End If - End If - - IsMacroCall = varRes -End Function - -Function MacroExpand(ByVal objAST, ByVal objEnv) - Dim varRes - While IsMacroCall(objAST, objEnv) - Dim varMacro - Set varMacro = objEnv.Get(objAST.Item(0)) - Set objAST = varMacro.MacroApply(objAST, objEnv) - Wend - Set varRes = objAST - Set MacroExpand = varRes -End Function - -Function MMacroExpand(objArgs, objEnv) - Dim varRes - CheckArgNum objArgs, 1 - Set varRes = MacroExpand(objArgs.Item(1), objEnv) - Set MMacroExpand = varRes -End Function -objNS.Add NewMalSym("macroexpand"), NewVbsProc("MMacroExpand", True) - -Function MTry(objArgs, objEnv) - Dim varRes - - If objArgs.Count - 1 < 1 Then - Err.Raise vbObjectError, _ - "MTry", "Need more arguments." - End If - - If objArgs.Count - 1 = 1 Then - Set varRes = EvalLater(objArgs.Item(1), objEnv) - Set MTry = varRes - Exit Function - End If - - CheckArgNum objArgs, 2 - CheckType objArgs.Item(2), TYPES.LIST - - Dim objTry, objCatch - Set objTry = objArgs.Item(1) - Set objCatch = objArgs.Item(2) - - CheckArgNum objCatch, 2 - CheckType objCatch.Item(0), TYPES.SYMBOL - CheckType objCatch.Item(1), TYPES.SYMBOL - If objCatch.Item(0).Value <> "catch*" Then - Err.Raise vbObjectError, _ - "MTry", "Unexpect argument(s)." - End If - - On Error Resume Next - Set varRes = Evaluate(objTry, objEnv) - If Err.Number <> 0 Then - Dim objException - - If Err.Source <> "MThrow" Then - Set objException = NewMalStr(Err.Description) - Else - Set objException = objExceptions.Item(Err.Description) - objExceptions.Remove Err.Description - End If - - Call Err.Clear() - On Error Goto 0 - - ' The code below may cause error too. - ' So we should clear err info & throw out any errors. - ' Use 'quote' to avoid eval objExp again. - Set varRes = Evaluate(NewMalList(Array( _ - NewMalSym("let*"), NewMalList(Array( _ - objCatch.Item(1), NewMalList(Array( _ - NewMalSym("quote"), objException)))), _ - objCatch.Item(2))), objEnv) - Else - On Error Goto 0 - End If - - Set MTry = varRes -End Function -objNS.Add NewMalSym("try*"), NewVbsProc("MTry", True) - -Call InitBuiltIn() -Call InitMacro() - -Call InitArgs() -Sub InitArgs() - Dim objArgs - Set objArgs = NewMalList(Array()) - - Dim i - For i = 1 To WScript.Arguments.Count - 1 - objArgs.Add NewMalStr(WScript.Arguments.Item(i)) - Next - - objNS.Add NewMalSym("*ARGV*"), objArgs - - If WScript.Arguments.Count > 0 Then - REP "(load-file """ + WScript.Arguments.Item(0) + """)" - WScript.Quit 0 - End If -End Sub - -Call REPL() -Sub REPL() - Dim strCode, strResult - REP "(println (str ""Mal [""*host-language*""]""))" - While True - WScript.StdOut.Write "user> " - - On Error Resume Next - strCode = WScript.StdIn.ReadLine() - If Err.Number <> 0 Then WScript.Quit 0 - On Error Goto 0 - - Dim strRes - On Error Resume Next - strRes = REP(strCode) - If Err.Number <> 0 Then - If Err.Source = "MThrow" Then - 'WScript.StdErr.WriteLine Err.Source + ": " + _ - WScript.StdErr.WriteLine "Exception: " + _ - PrintMalType(objExceptions.Item(Err.Description), True) - objExceptions.Remove Err.Description - Else - 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description - WScript.StdErr.WriteLine "Exception: " + Err.Description - End If - Else - If strRes <> "" Then - WScript.Echo strRes - End If - End If - On Error Goto 0 - Wend -End Sub - -Function Read(strCode) - Set Read = ReadString(strCode) -End Function - -Function Evaluate(ByVal objCode, ByVal objEnv) - While True - If TypeName(objCode) = "Nothing" Then - Set Evaluate = Nothing - Exit Function - End If - - Set objCode = MacroExpand(objCode, objEnv) - - Dim varRet, objFirst - If objCode.Type = TYPES.LIST Then - If objCode.Count = 0 Then ' () - Set Evaluate = objCode - Exit Function - End If - - Set objFirst = Evaluate(objCode.Item(0), objEnv) - Set varRet = objFirst.Apply(objCode, objEnv) - Else - Set varRet = EvaluateAST(objCode, objEnv) - End If - - If TypeName(varRet) = "TailCall" Then - ' NOTICE: If not specify 'ByVal', - ' Change of arguments will influence - ' the caller's variable! - Set objCode = varRet.objMalType - Set objEnv = varRet.objEnv - Else - Set Evaluate = varRet - Exit Function - End If - Wend -End Function - - -Function EvaluateAST(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.SYMBOL - Set varRet = objEnv.Get(objCode) - Case TYPES.LIST - Err.Raise vbObjectError, _ - "EvaluateAST", "Unexpect type." - Case TYPES.VECTOR - Set varRet = NewMalVec(Array()) - For i = 0 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case TYPES.HASHMAP - Set varRet = NewMalMap(Array(), Array()) - For Each i In objCode.Keys() - varRet.Add i, Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Set varRet = objCode - End Select - Set EvaluateAST = varRet -End Function - -Function EvaluateRest(objCode, objEnv) - Dim varRet, i - Select Case objCode.Type - Case TYPES.LIST - Set varRet = NewMalList(Array(NewMalNil())) - For i = 1 To objCode.Count() - 1 - varRet.Add Evaluate(objCode.Item(i), objEnv) - Next - Case Else - Err.Raise vbObjectError, _ - "EvaluateRest", "Unexpected type." - End Select - Set EvaluateRest = varRet -End Function - -Function Print(objCode) - Print = PrintMalType(objCode, True) -End Function - -Function REP(strCode) - REP = Print(Evaluate(Read(strCode), objNS)) -End Function - -Sub Include(strFileName) - With CreateObject("Scripting.FileSystemObject") - ExecuteGlobal .OpenTextFile( _ - .GetParentFolderName( _ - .GetFile(WScript.ScriptFullName)) & _ - "\" & strFileName).ReadAll - End With -End Sub +Option Explicit + +Include "Types.vbs" +Include "Reader.vbs" +Include "Printer.vbs" +Include "Env.vbs" +Include "Core.vbs" + +Class TailCall + Public objMalType + Public objEnv +End Class + +Function EvalLater(objMal, objEnv) + Dim varRes + Set varRes = New TailCall + Set varRes.objMalType = objMal + Set varRes.objEnv = objEnv + Set EvalLater = varRes +End Function + +Function MDef(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv) + objEnv.Add objArgs.Item(1), varRet + Set MDef = varRet +End Function +objNS.Add NewMalSym("def!"), NewVbsProc("MDef", True) + +Function MLet(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objBinds + Set objBinds = objArgs.Item(1) + CheckListOrVec objBinds + + If objBinds.Count Mod 2 <> 0 Then + Err.Raise vbObjectError, _ + "MLet", "Wrong argument count." + End If + + Dim objNewEnv + Set objNewEnv = NewEnv(objEnv) + Dim i, objSym + For i = 0 To objBinds.Count - 1 Step 2 + Set objSym = objBinds.Item(i) + CheckType objSym, TYPES.SYMBOL + objNewEnv.Add objSym, Evaluate(objBinds.Item(i + 1), objNewEnv) + Next + + Set varRet = EvalLater(objArgs.Item(2), objNewEnv) + Set MLet = varRet +End Function +objNS.Add NewMalSym("let*"), NewVbsProc("MLet", True) + +Function MDo(objArgs, objEnv) + Dim varRet, i + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MDo", "Need more arguments." + End If + For i = 1 To objArgs.Count - 2 + Call Evaluate(objArgs.Item(i), objEnv) + Next + Set varRet = EvalLater( _ + objArgs.Item(objArgs.Count - 1), _ + objEnv) + Set MDo = varRet +End Function +objNS.Add NewMalSym("do"), NewVbsProc("MDo", True) + +Function MIf(objArgs, objEnv) + Dim varRet + If objArgs.Count - 1 <> 3 And _ + objArgs.Count - 1 <> 2 Then + Err.Raise vbObjectError, _ + "MIf", "Wrong number of arguments." + End If + + Dim objCond + Set objCond = Evaluate(objArgs.Item(1), objEnv) + Dim boolCond + If objCond.Type = TYPES.BOOLEAN Then + boolCond = objCond.Value + Else + boolCond = True + End If + boolCond = (boolCond And objCond.Type <> TYPES.NIL) + If boolCond Then + Set varRet = EvalLater(objArgs.Item(2), objEnv) + Else + If objArgs.Count - 1 = 3 Then + Set varRet = EvalLater(objArgs.Item(3), objEnv) + Else + Set varRet = NewMalNil() + End If + End If + Set MIf = varRet +End Function +objNS.Add NewMalSym("if"), NewVbsProc("MIf", True) + +Function MFn(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + + Dim objParams, objCode + Set objParams = objArgs.Item(1) + CheckListOrVec objParams + Set objCode = objArgs.Item(2) + + Dim i + For i = 0 To objParams.Count - 1 + CheckType objParams.Item(i), TYPES.SYMBOL + Next + Set varRet = NewMalProc(objParams, objCode, objEnv) + Set MFn = varRet +End Function +objNS.Add NewMalSym("fn*"), NewVbsProc("MFn", True) + +Function MEval(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = Evaluate(objArgs.Item(1), objEnv) + Set varRes = EvalLater(varRes, objNS) + Set MEval = varRes +End Function +objNS.Add NewMalSym("eval"), NewVbsProc("MEval", True) + +Function MQuote(objArgs, objEnv) + CheckArgNum objArgs, 1 + Set MQuote = objArgs.Item(1) +End Function +objNS.Add NewMalSym("quote"), NewVbsProc("MQuote", True) + +Function MQuasiQuote(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = EvalLater( _ + MQuasiQuoteExpand(objArgs, objEnv), objEnv) + Set MQuasiQuote = varRes +End Function +objNS.Add NewMalSym("quasiquote"), NewVbsProc("MQuasiQuote", True) + +Function MQuasiQuoteExpand(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + + Set varRes = ExpandHelper(objArgs.Item(1)) + If varRes.Splice Then + Err.Raise vbObjectError, _ + "MQuasiQuoteExpand", "Wrong return value type." + End If + Set varRes = varRes.Value + + Set MQuasiQuoteExpand = varRes +End Function +objNS.Add NewMalSym("quasiquoteexpand"), NewVbsProc("MQuasiQuoteExpand", True) + +Class ExpandType + Public Splice + Public Value +End Class + +Function NewExpandType(objValue, boolSplice) + Dim varRes + Set varRes = New ExpandType + Set varRes.Value = objValue + varRes.Splice = boolSplice + Set NewExpandType = varRes +End Function + +Function ExpandHelper(objArg) + Dim varRes, boolSplice + Dim varBuilder, varEType, i + boolSplice = False + Select Case objArg.Type + Case TYPES.LIST + Dim boolNormal + boolNormal = False + + ' Check for unquotes. + Select Case objArg.Count + Case 2 + ' Maybe have a bug here + ' like (unquote a b c) should be throw a error + If objArg.Item(0).Type = TYPES.SYMBOL Then + Select Case objArg.Item(0).Value + Case "unquote" + Set varRes = objArg.Item(1) + Case "splice-unquote" + Set varRes = objArg.Item(1) + boolSplice = True + Case Else + boolNormal = True + End Select + Else + boolNormal = True + End If + Case Else + boolNormal = True + End Select + + If boolNormal Then + Set varRes = NewMalList(Array()) + Set varBuilder = varRes + + For i = 0 To objArg.Count - 1 + Set varEType = ExpandHelper(objArg.Item(i)) + If varEType.Splice Then + varBuilder.Add NewMalSym("concat") + Else + varBuilder.Add NewMalSym("cons") + End If + varBuilder.Add varEType.Value + varBuilder.Add NewMalList(Array()) + Set varBuilder = varBuilder.Item(2) + Next + End If + Case TYPES.VECTOR + Set varRes = NewMalList(Array( _ + NewMalSym("vec"), NewMalList(Array()))) + + Set varBuilder = varRes.Item(1) + For i = 0 To objArg.Count - 1 + Set varEType = ExpandHelper(objArg.Item(i)) + If varEType.Splice Then + varBuilder.Add NewMalSym("concat") + Else + varBuilder.Add NewMalSym("cons") + End If + varBuilder.Add varEType.Value + varBuilder.Add NewMalList(Array()) + Set varBuilder = varBuilder.Item(2) + Next + Case TYPES.HASHMAP + ' Maybe have a bug here. + ' e.g. {"key" ~value} + Set varRes = NewMalList(Array( _ + NewMalSym("quote"), objArg)) + Case TYPES.SYMBOL + Set varRes = NewMalList(Array( _ + NewMalSym("quote"), objArg)) + Case Else + ' Maybe have a bug here. + ' All unspecified type will return itself. + Set varRes = objArg + End Select + + Set ExpandHelper = NewExpandType(varRes, boolSplice) +End Function + +Function MDefMacro(objArgs, objEnv) + Dim varRet + CheckArgNum objArgs, 2 + CheckType objArgs.Item(1), TYPES.SYMBOL + Set varRet = Evaluate(objArgs.Item(2), objEnv).Copy() + CheckType varRet, TYPES.PROCEDURE + varRet.IsMacro = True + objEnv.Add objArgs.Item(1), varRet + Set MDefMacro = varRet +End Function +objNS.Add NewMalSym("defmacro!"), NewVbsProc("MDefMacro", True) + +Function IsMacroCall(objCode, objEnv) + Dim varRes + varRes = False + + ' VBS has no short-circuit evaluation. + If objCode.Type = TYPES.LIST Then + If objCode.Count > 0 Then + If objCode.Item(0).Type = TYPES.SYMBOL Then + Dim varValue + Set varValue = objEnv.Get(objCode.Item(0)) + If varValue.Type = TYPES.PROCEDURE Then + If varValue.IsMacro Then + varRes = True + End If + End If + End If + End If + End If + + IsMacroCall = varRes +End Function + +Function MacroExpand(ByVal objAST, ByVal objEnv) + Dim varRes + While IsMacroCall(objAST, objEnv) + Dim varMacro + Set varMacro = objEnv.Get(objAST.Item(0)) + Set objAST = varMacro.MacroApply(objAST, objEnv) + Wend + Set varRes = objAST + Set MacroExpand = varRes +End Function + +Function MMacroExpand(objArgs, objEnv) + Dim varRes + CheckArgNum objArgs, 1 + Set varRes = MacroExpand(objArgs.Item(1), objEnv) + Set MMacroExpand = varRes +End Function +objNS.Add NewMalSym("macroexpand"), NewVbsProc("MMacroExpand", True) + +Function MTry(objArgs, objEnv) + Dim varRes + + If objArgs.Count - 1 < 1 Then + Err.Raise vbObjectError, _ + "MTry", "Need more arguments." + End If + + If objArgs.Count - 1 = 1 Then + Set varRes = EvalLater(objArgs.Item(1), objEnv) + Set MTry = varRes + Exit Function + End If + + CheckArgNum objArgs, 2 + CheckType objArgs.Item(2), TYPES.LIST + + Dim objTry, objCatch + Set objTry = objArgs.Item(1) + Set objCatch = objArgs.Item(2) + + CheckArgNum objCatch, 2 + CheckType objCatch.Item(0), TYPES.SYMBOL + CheckType objCatch.Item(1), TYPES.SYMBOL + If objCatch.Item(0).Value <> "catch*" Then + Err.Raise vbObjectError, _ + "MTry", "Unexpect argument(s)." + End If + + On Error Resume Next + Set varRes = Evaluate(objTry, objEnv) + If Err.Number <> 0 Then + Dim objException + + If Err.Source <> "MThrow" Then + Set objException = NewMalStr(Err.Description) + Else + Set objException = objExceptions.Item(Err.Description) + objExceptions.Remove Err.Description + End If + + Call Err.Clear() + On Error Goto 0 + + ' The code below may cause error too. + ' So we should clear err info & throw out any errors. + ' Use 'quote' to avoid eval objExp again. + Set varRes = Evaluate(NewMalList(Array( _ + NewMalSym("let*"), NewMalList(Array( _ + objCatch.Item(1), NewMalList(Array( _ + NewMalSym("quote"), objException)))), _ + objCatch.Item(2))), objEnv) + Else + On Error Goto 0 + End If + + Set MTry = varRes +End Function +objNS.Add NewMalSym("try*"), NewVbsProc("MTry", True) + +Call InitBuiltIn() +Call InitMacro() + +Call InitArgs() +Sub InitArgs() + Dim objArgs + Set objArgs = NewMalList(Array()) + + Dim i + For i = 1 To WScript.Arguments.Count - 1 + objArgs.Add NewMalStr(WScript.Arguments.Item(i)) + Next + + objNS.Add NewMalSym("*ARGV*"), objArgs + + If WScript.Arguments.Count > 0 Then + REP "(load-file """ + WScript.Arguments.Item(0) + """)" + WScript.Quit 0 + End If +End Sub + +Call REPL() +Sub REPL() + Dim strCode, strResult + REP "(println (str ""Mal [""*host-language*""]""))" + While True + WScript.StdOut.Write "user> " + + On Error Resume Next + strCode = WScript.StdIn.ReadLine() + If Err.Number <> 0 Then WScript.Quit 0 + On Error Goto 0 + + Dim strRes + On Error Resume Next + strRes = REP(strCode) + If Err.Number <> 0 Then + If Err.Source = "MThrow" Then + 'WScript.StdErr.WriteLine Err.Source + ": " + _ + WScript.StdErr.WriteLine "Exception: " + _ + PrintMalType(objExceptions.Item(Err.Description), True) + objExceptions.Remove Err.Description + Else + 'WScript.StdErr.WriteLine Err.Source + ": " + Err.Description + WScript.StdErr.WriteLine "Exception: " + Err.Description + End If + Else + If strRes <> "" Then + WScript.Echo strRes + End If + End If + On Error Goto 0 + Wend +End Sub + +Function Read(strCode) + Set Read = ReadString(strCode) +End Function + +Function Evaluate(ByVal objCode, ByVal objEnv) + While True + If TypeName(objCode) = "Nothing" Then + Set Evaluate = Nothing + Exit Function + End If + + Set objCode = MacroExpand(objCode, objEnv) + + Dim varRet, objFirst + If objCode.Type = TYPES.LIST Then + If objCode.Count = 0 Then ' () + Set Evaluate = objCode + Exit Function + End If + + Set objFirst = Evaluate(objCode.Item(0), objEnv) + Set varRet = objFirst.Apply(objCode, objEnv) + Else + Set varRet = EvaluateAST(objCode, objEnv) + End If + + If TypeName(varRet) = "TailCall" Then + ' NOTICE: If not specify 'ByVal', + ' Change of arguments will influence + ' the caller's variable! + Set objCode = varRet.objMalType + Set objEnv = varRet.objEnv + Else + Set Evaluate = varRet + Exit Function + End If + Wend +End Function + + +Function EvaluateAST(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.SYMBOL + Set varRet = objEnv.Get(objCode) + Case TYPES.LIST + Err.Raise vbObjectError, _ + "EvaluateAST", "Unexpect type." + Case TYPES.VECTOR + Set varRet = NewMalVec(Array()) + For i = 0 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case TYPES.HASHMAP + Set varRet = NewMalMap(Array(), Array()) + For Each i In objCode.Keys() + varRet.Add i, Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Set varRet = objCode + End Select + Set EvaluateAST = varRet +End Function + +Function EvaluateRest(objCode, objEnv) + Dim varRet, i + Select Case objCode.Type + Case TYPES.LIST + Set varRet = NewMalList(Array(NewMalNil())) + For i = 1 To objCode.Count() - 1 + varRet.Add Evaluate(objCode.Item(i), objEnv) + Next + Case Else + Err.Raise vbObjectError, _ + "EvaluateRest", "Unexpected type." + End Select + Set EvaluateRest = varRet +End Function + +Function Print(objCode) + Print = PrintMalType(objCode, True) +End Function + +Function REP(strCode) + REP = Print(Evaluate(Read(strCode), objNS)) +End Function + +Sub Include(strFileName) + With CreateObject("Scripting.FileSystemObject") + ExecuteGlobal .OpenTextFile( _ + .GetParentFolderName( _ + .GetFile(WScript.ScriptFullName)) & _ + "\" & strFileName).ReadAll + End With +End Sub diff --git a/impls/vbs/tests/step4_if_fn_do.mal b/impls/vbs/tests/step4_if_fn_do.mal index 8697f6beec..548ce45f55 100644 --- a/impls/vbs/tests/step4_if_fn_do.mal +++ b/impls/vbs/tests/step4_if_fn_do.mal @@ -1,6 +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]) (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 index 4217ffb7ac..b9e0e1e5c0 100644 --- a/impls/vbs/tests/step9_try.mal +++ b/impls/vbs/tests/step9_try.mal @@ -1,4 +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)) +(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)) diff --git a/impls/vbs/types.vbs b/impls/vbs/types.vbs index 0c08c95e8f..66bae714c1 100644 --- a/impls/vbs/types.vbs +++ b/impls/vbs/types.vbs @@ -1,612 +1,612 @@ -Option Explicit - -Dim TYPES -Set TYPES = New MalTypes - -Class MalTypes - Public LIST, VECTOR, HASHMAP, [BOOLEAN], NIL - Public KEYWORD, [STRING], NUMBER, SYMBOL - Public PROCEDURE, ATOM - - Public [TypeName] - Private Sub Class_Initialize - [TypeName] = Array( _ - "LIST", "VECTOR", "HASHMAP", "BOOLEAN", _ - "NIL", "KEYWORD", "STRING", "NUMBER", _ - "SYMBOL", "PROCEDURE", "ATOM") - - Dim i - For i = 0 To UBound([TypeName]) - Execute "[" + [TypeName](i) + "] = " + CStr(i) - Next - End Sub -End Class - -Class MalType - Public [Type] - Public Value - - Private varMeta - Public Property Get MetaData() - If IsEmpty(varMeta) Then - Set MetaData = NewMalNil() - Else - Set MetaData = varMeta - End If - End Property - - Public Property Set MetaData(objMeta) - Set varMeta = objMeta - End Property - - Public Function Copy() - Set Copy = NewMalType([Type], Value) - End Function - - Public Function Init(lngType, varValue) - [Type] = lngType - Value = varValue - End Function -End Class - -Function NewMalType(lngType, varValue) - Dim varResult - Set varResult = New MalType - varResult.Init lngType, varValue - Set NewMalType = varResult -End Function - -Function NewMalBool(varValue) - Set NewMalBool = NewMalType(TYPES.BOOLEAN, varValue) -End Function - -Function NewMalNil() - Set NewMalNil = NewMalType(TYPES.NIL, Empty) -End Function - -Function NewMalKwd(varValue) - Set NewMalKwd = NewMalType(TYPES.KEYWORD, varValue) -End Function - -Function NewMalStr(varValue) - Set NewMalStr = NewMalType(TYPES.STRING, varValue) -End Function - -Function NewMalNum(varValue) - Set NewMalNum = NewMalType(TYPES.NUMBER, varValue) -End Function - -Function NewMalSym(varValue) - Set NewMalSym = NewMalType(TYPES.SYMBOL, varValue) -End Function - -Class MalAtom - Public [Type] - Public Value - - Private varMeta - Public Property Get MetaData() - If IsEmpty(varMeta) Then - Set MetaData = NewMalNil() - Else - Set MetaData = varMeta - End If - End Property - - Public Property Set MetaData(objMeta) - Set varMeta = objMeta - End Property - - Public Function Copy() - Set Copy = NewMalAtom(Value) - End Function - - Public Sub Reset(objMal) - Set Value = objMal - End Sub - - Private Sub Class_Initialize - [Type] = TYPES.ATOM - End Sub -End Class - -Function NewMalAtom(varValue) - Dim varRes - Set varRes = New MalAtom - varRes.Reset varValue - Set NewMalAtom = varRes -End Function - -Class MalList ' Extends MalType - Public [Type] - Public Value - - Private varMeta - Public Property Get MetaData() - If IsEmpty(varMeta) Then - Set MetaData = NewMalNil() - Else - Set MetaData = varMeta - End If - End Property - - Public Property Set MetaData(objMeta) - Set varMeta = objMeta - End Property - - Public Function Copy() - Set Copy = New MalList - Set Copy.Value = Value - End Function - - Private Sub Class_Initialize - [Type] = TYPES.LIST - Set Value = CreateObject("System.Collections.ArrayList") - End Sub - - Public Function Init(arrValues) - Dim i - For i = 0 To UBound(arrValues) - Add arrValues(i) - Next - End Function - - Public Function Add(objMalType) - Value.Add objMalType - End Function - - Public Property Get Item(i) - Set Item = Value.Item(i) - End Property - - Public Property Let Item(i, varValue) - Value.Item(i) = varValue - End Property - - Public Property Set Item(i, varValue) - Set Value.Item(i) = varValue - End Property - - Public Function Count() - Count = Value.Count - End Function -End Class - -Function NewMalList(arrValues) - Dim varResult - Set varResult = New MalList - varResult.Init arrValues - Set NewMalList = varResult -End Function - -Class MalVector ' Extends MalType - Public [Type] - Public Value - - Private varMeta - Public Property Get MetaData() - If IsEmpty(varMeta) Then - Set MetaData = NewMalNil() - Else - Set MetaData = varMeta - End If - End Property - - Public Property Set MetaData(objMeta) - Set varMeta = objMeta - End Property - - Public Function Copy() - Set Copy = New MalVector - Set Copy.Value = Value - End Function - - Private Sub Class_Initialize - [Type] = TYPES.VECTOR - Set Value = CreateObject("System.Collections.ArrayList") - End Sub - - Public Function Init(arrValues) - Dim i - For i = 0 To UBound(arrValues) - Add arrValues(i) - Next - End Function - - Public Function Add(objMalType) - Value.Add objMalType - End Function - - Public Property Get Item(i) - Set Item = Value.Item(i) - End Property - - Public Property Let Item(i, varValue) - Value.Item(i) = varValue - End Property - - Public Property Set Item(i, varValue) - Set Value.Item(i) = varValue - End Property - - Public Function Count() - Count = Value.Count - End Function -End Class - -Function NewMalVec(arrValues) - Dim varResult - Set varResult = New MalVector - varResult.Init arrValues - Set NewMalVec = varResult -End Function - -Class MalHashmap 'Extends MalType - Public [Type] - Public Value - - Private varMeta - Public Property Get MetaData() - If IsEmpty(varMeta) Then - Set MetaData = NewMalNil() - Else - Set MetaData = varMeta - End If - End Property - - Public Property Set MetaData(objMeta) - Set varMeta = objMeta - End Property - - Public Function Copy() - Set Copy = New MalHashmap - Set Copy.Value = Value - End Function - - - Private Sub Class_Initialize - [Type] = TYPES.HASHMAP - Set Value = CreateObject("Scripting.Dictionary") - End Sub - - Public Function Init(arrKeys, arrValues) - Dim i - For i = 0 To UBound(arrKeys) - Add arrKeys(i), arrValues(i) - Next - End Function - - Private Function M2S(objKey) - Dim varRes - Select Case objKey.Type - Case TYPES.STRING - varRes = "S" + objKey.Value - Case TYPES.KEYWORD - varRes = "K" + objKey.Value - Case Else - Err.Raise vbObjectError, _ - "MalHashmap", "Unexpect key type." - End Select - M2S = varRes - End Function - - Private Function S2M(strKey) - Dim varRes - Select Case Left(strKey, 1) - Case "S" - Set varRes = NewMalStr(Right(strKey, Len(strKey) - 1)) - Case "K" - Set varRes = NewMalKwd(Right(strKey, Len(strKey) - 1)) - Case Else - Err.Raise vbObjectError, _ - "MalHashmap", "Unexpect key type." - End Select - Set S2M = varRes - End Function - - Public Function Add(varKey, varValue) - If varKey.Type <> TYPES.STRING And _ - varKey.Type <> TYPES.KEYWORD Then - Err.Raise vbObjectError, _ - "MalHashmap", "Unexpect key type." - End If - - Set Value.Item(M2S(varKey)) = varValue - 'Value.Add M2S(varKey), varValue - End Function - - Public Property Get Keys() - Dim aKeys - aKeys = Value.Keys - Dim aRes() - ReDim aRes(UBound(aKeys)) - Dim i - For i = 0 To UBound(aRes) - Set aRes(i) = S2M(aKeys(i)) - Next - - Keys = aRes - End Property - - Public Function Count() - Count = Value.Count - End Function - - Public Property Get Item(i) - Set Item = Value.Item(M2S(i)) - End Property - - Public Function Exists(varKey) - If varKey.Type <> TYPES.STRING And _ - varKey.Type <> TYPES.KEYWORD Then - Err.Raise vbObjectError, _ - "MalHashmap", "Unexpect key type." - End If - Exists = Value.Exists(M2S(varKey)) - End Function - - Public Property Let Item(i, varValue) - Value.Item(M2S(i)) = varValue - End Property - - Public Property Set Item(i, varValue) - Set Value.Item(M2S(i)) = varValue - End Property -End Class - -Function NewMalMap(arrKeys, arrValues) - Dim varResult - Set varResult = New MalHashmap - varResult.Init arrKeys, arrValues - Set NewMalMap = varResult -End Function - -Class VbsProcedure 'Extends MalType - Public [Type] - Public Value - - Public IsMacro - Public boolSpec - Public MetaData - Private Sub Class_Initialize - [Type] = TYPES.PROCEDURE - IsMacro = False - Set MetaData = NewMalNil() - End Sub - - Public Property Get IsSpecial() - IsSpecial = boolSpec - End Property - - Public Function Init(objFunction, boolIsSpec) - Set Value = objFunction - boolSpec = boolIsSpec - End Function - - Public Function Apply(objArgs, objEnv) - Dim varResult - If boolSpec Then - Set varResult = Value(objArgs, objEnv) - Else - Set varResult = Value(EvaluateRest(objArgs, objEnv), objEnv) - End If - Set Apply = varResult - End Function - - Public Function ApplyWithoutEval(objArgs, objEnv) - Dim varResult - Set varResult = Value(objArgs, objEnv) - - Set ApplyWithoutEval = varResult - End Function - - Public Function Copy() - Dim varRes - Set varRes = New VbsProcedure - varRes.Type = [Type] - Set varRes.Value = Value - varRes.IsMacro = IsMacro - varRes.boolSpec = boolSpec - Set Copy = varRes - End Function -End Class - -Function NewVbsProc(strFnName, boolSpec) - Dim varResult - Set varResult = New VbsProcedure - varResult.Init GetRef(strFnName), boolSpec - Set NewVbsProc = varResult -End Function - -Class MalProcedure 'Extends MalType - Public [Type] - Public Value - - Public IsMacro - - Public Property Get IsSpecial() - IsSpecial = False - End Property - - Public MetaData - Private Sub Class_Initialize - [Type] = TYPES.PROCEDURE - IsMacro = False - Set MetaData = NewMalNil() - End Sub - - Public objParams, objCode, objSavedEnv - Public Function Init(objP, objC, objE) - Set objParams = objP - Set objCode = objC - Set objSavedEnv = objE - End Function - - Public Function Apply(objArgs, objEnv) - If IsMacro Then - Err.Raise vbObjectError, _ - "MalProcedureApply", "Not a procedure." - End If - - Dim varRet - Dim objNewEnv - Set objNewEnv = NewEnv(objSavedEnv) - Dim i - i = 0 - Dim objList - While i < objParams.Count - If objParams.Item(i).Value = "&" Then - If objParams.Count - 1 = i + 1 Then - Set objList = NewMalList(Array()) - objNewEnv.Add objParams.Item(i + 1), objList - While i + 1 < objArgs.Count - objList.Add Evaluate(objArgs.Item(i + 1), objEnv) - i = i + 1 - Wend - i = objParams.Count ' Break While - Else - Err.Raise vbObjectError, _ - "MalProcedureApply", "Invalid parameter(s)." - End If - Else - If i + 1 >= objArgs.Count Then - Err.Raise vbObjectError, _ - "MalProcedureApply", "Need more arguments." - End If - objNewEnv.Add objParams.Item(i), _ - Evaluate(objArgs.Item(i + 1), objEnv) - i = i + 1 - End If - Wend - - Set varRet = EvalLater(objCode, objNewEnv) - Set Apply = varRet - End Function - - Public Function MacroApply(objArgs, objEnv) - If Not IsMacro Then - Err.Raise vbObjectError, _ - "MalMacroApply", "Not a macro." - End If - - Dim varRet - Dim objNewEnv - Set objNewEnv = NewEnv(objSavedEnv) - Dim i - i = 0 - Dim objList - While i < objParams.Count - If objParams.Item(i).Value = "&" Then - If objParams.Count - 1 = i + 1 Then - Set objList = NewMalList(Array()) - - ' No evaluation - objNewEnv.Add objParams.Item(i + 1), objList - While i + 1 < objArgs.Count - objList.Add objArgs.Item(i + 1) - i = i + 1 - Wend - i = objParams.Count ' Break While - Else - Err.Raise vbObjectError, _ - "MalMacroApply", "Invalid parameter(s)." - End If - Else - If i + 1 >= objArgs.Count Then - Err.Raise vbObjectError, _ - "MalMacroApply", "Need more arguments." - End If - - ' No evaluation - objNewEnv.Add objParams.Item(i), _ - objArgs.Item(i + 1) - i = i + 1 - End If - Wend - - ' EvalLater -> Evaluate - Set varRet = Evaluate(objCode, objNewEnv) - Set MacroApply = varRet - End Function - - - Public Function ApplyWithoutEval(objArgs, objEnv) - Dim varRet - Dim objNewEnv - Set objNewEnv = NewEnv(objSavedEnv) - Dim i - i = 0 - Dim objList - While i < objParams.Count - If objParams.Item(i).Value = "&" Then - If objParams.Count - 1 = i + 1 Then - Set objList = NewMalList(Array()) - - ' No evaluation - objNewEnv.Add objParams.Item(i + 1), objList - While i + 1 < objArgs.Count - objList.Add objArgs.Item(i + 1) - i = i + 1 - Wend - i = objParams.Count ' Break While - Else - Err.Raise vbObjectError, _ - "MalMacroApply", "Invalid parameter(s)." - End If - Else - If i + 1 >= objArgs.Count Then - Err.Raise vbObjectError, _ - "MalMacroApply", "Need more arguments." - End If - - ' No evaluation - objNewEnv.Add objParams.Item(i), _ - objArgs.Item(i + 1) - i = i + 1 - End If - Wend - - ' EvalLater -> Evaluate - Set varRet = Evaluate(objCode, objNewEnv) - Set ApplyWithoutEval = varRet - End Function - - - Public Function Copy() - Dim varRes - Set varRes = New MalProcedure - varRes.Type = [Type] - varRes.Value = Value - varRes.IsMacro = IsMacro - Set varRes.objParams = objParams - Set varRes.objCode = objCode - Set varRes.objSavedEnv = objSavedEnv - Set Copy = varRes - End Function -End Class - -Function NewMalProc(objParams, objCode, objEnv) - Dim varRet - Set varRet = New MalProcedure - varRet.Init objParams, objCode, objEnv - Set NewMalProc = varRet -End Function - -Function NewMalMacro(objParams, objCode, objEnv) - Dim varRet - Set varRet = New MalProcedure - varRet.Init objParams, objCode, objEnv - varRet.IsMacro = True - Set NewMalProc = varRet -End Function - -Function SetMeta(objMal, objMeta) - Dim varRes - Set varRes = objMal.Copy - Set varRes.MetaData = objMeta - Set SetMeta = varRes -End Function - -Function GetMeta(objMal) - Set GetMeta = objMal.MetaData +Option Explicit + +Dim TYPES +Set TYPES = New MalTypes + +Class MalTypes + Public LIST, VECTOR, HASHMAP, [BOOLEAN], NIL + Public KEYWORD, [STRING], NUMBER, SYMBOL + Public PROCEDURE, ATOM + + Public [TypeName] + Private Sub Class_Initialize + [TypeName] = Array( _ + "LIST", "VECTOR", "HASHMAP", "BOOLEAN", _ + "NIL", "KEYWORD", "STRING", "NUMBER", _ + "SYMBOL", "PROCEDURE", "ATOM") + + Dim i + For i = 0 To UBound([TypeName]) + Execute "[" + [TypeName](i) + "] = " + CStr(i) + Next + End Sub +End Class + +Class MalType + Public [Type] + Public Value + + Private varMeta + Public Property Get MetaData() + If IsEmpty(varMeta) Then + Set MetaData = NewMalNil() + Else + Set MetaData = varMeta + End If + End Property + + Public Property Set MetaData(objMeta) + Set varMeta = objMeta + End Property + + Public Function Copy() + Set Copy = NewMalType([Type], Value) + End Function + + Public Function Init(lngType, varValue) + [Type] = lngType + Value = varValue + End Function +End Class + +Function NewMalType(lngType, varValue) + Dim varResult + Set varResult = New MalType + varResult.Init lngType, varValue + Set NewMalType = varResult +End Function + +Function NewMalBool(varValue) + Set NewMalBool = NewMalType(TYPES.BOOLEAN, varValue) +End Function + +Function NewMalNil() + Set NewMalNil = NewMalType(TYPES.NIL, Empty) +End Function + +Function NewMalKwd(varValue) + Set NewMalKwd = NewMalType(TYPES.KEYWORD, varValue) +End Function + +Function NewMalStr(varValue) + Set NewMalStr = NewMalType(TYPES.STRING, varValue) +End Function + +Function NewMalNum(varValue) + Set NewMalNum = NewMalType(TYPES.NUMBER, varValue) +End Function + +Function NewMalSym(varValue) + Set NewMalSym = NewMalType(TYPES.SYMBOL, varValue) +End Function + +Class MalAtom + Public [Type] + Public Value + + Private varMeta + Public Property Get MetaData() + If IsEmpty(varMeta) Then + Set MetaData = NewMalNil() + Else + Set MetaData = varMeta + End If + End Property + + Public Property Set MetaData(objMeta) + Set varMeta = objMeta + End Property + + Public Function Copy() + Set Copy = NewMalAtom(Value) + End Function + + Public Sub Reset(objMal) + Set Value = objMal + End Sub + + Private Sub Class_Initialize + [Type] = TYPES.ATOM + End Sub +End Class + +Function NewMalAtom(varValue) + Dim varRes + Set varRes = New MalAtom + varRes.Reset varValue + Set NewMalAtom = varRes +End Function + +Class MalList ' Extends MalType + Public [Type] + Public Value + + Private varMeta + Public Property Get MetaData() + If IsEmpty(varMeta) Then + Set MetaData = NewMalNil() + Else + Set MetaData = varMeta + End If + End Property + + Public Property Set MetaData(objMeta) + Set varMeta = objMeta + End Property + + Public Function Copy() + Set Copy = New MalList + Set Copy.Value = Value + End Function + + Private Sub Class_Initialize + [Type] = TYPES.LIST + Set Value = CreateObject("System.Collections.ArrayList") + End Sub + + Public Function Init(arrValues) + Dim i + For i = 0 To UBound(arrValues) + Add arrValues(i) + Next + End Function + + Public Function Add(objMalType) + Value.Add objMalType + End Function + + Public Property Get Item(i) + Set Item = Value.Item(i) + End Property + + Public Property Let Item(i, varValue) + Value.Item(i) = varValue + End Property + + Public Property Set Item(i, varValue) + Set Value.Item(i) = varValue + End Property + + Public Function Count() + Count = Value.Count + End Function +End Class + +Function NewMalList(arrValues) + Dim varResult + Set varResult = New MalList + varResult.Init arrValues + Set NewMalList = varResult +End Function + +Class MalVector ' Extends MalType + Public [Type] + Public Value + + Private varMeta + Public Property Get MetaData() + If IsEmpty(varMeta) Then + Set MetaData = NewMalNil() + Else + Set MetaData = varMeta + End If + End Property + + Public Property Set MetaData(objMeta) + Set varMeta = objMeta + End Property + + Public Function Copy() + Set Copy = New MalVector + Set Copy.Value = Value + End Function + + Private Sub Class_Initialize + [Type] = TYPES.VECTOR + Set Value = CreateObject("System.Collections.ArrayList") + End Sub + + Public Function Init(arrValues) + Dim i + For i = 0 To UBound(arrValues) + Add arrValues(i) + Next + End Function + + Public Function Add(objMalType) + Value.Add objMalType + End Function + + Public Property Get Item(i) + Set Item = Value.Item(i) + End Property + + Public Property Let Item(i, varValue) + Value.Item(i) = varValue + End Property + + Public Property Set Item(i, varValue) + Set Value.Item(i) = varValue + End Property + + Public Function Count() + Count = Value.Count + End Function +End Class + +Function NewMalVec(arrValues) + Dim varResult + Set varResult = New MalVector + varResult.Init arrValues + Set NewMalVec = varResult +End Function + +Class MalHashmap 'Extends MalType + Public [Type] + Public Value + + Private varMeta + Public Property Get MetaData() + If IsEmpty(varMeta) Then + Set MetaData = NewMalNil() + Else + Set MetaData = varMeta + End If + End Property + + Public Property Set MetaData(objMeta) + Set varMeta = objMeta + End Property + + Public Function Copy() + Set Copy = New MalHashmap + Set Copy.Value = Value + End Function + + + Private Sub Class_Initialize + [Type] = TYPES.HASHMAP + Set Value = CreateObject("Scripting.Dictionary") + End Sub + + Public Function Init(arrKeys, arrValues) + Dim i + For i = 0 To UBound(arrKeys) + Add arrKeys(i), arrValues(i) + Next + End Function + + Private Function M2S(objKey) + Dim varRes + Select Case objKey.Type + Case TYPES.STRING + varRes = "S" + objKey.Value + Case TYPES.KEYWORD + varRes = "K" + objKey.Value + Case Else + Err.Raise vbObjectError, _ + "MalHashmap", "Unexpect key type." + End Select + M2S = varRes + End Function + + Private Function S2M(strKey) + Dim varRes + Select Case Left(strKey, 1) + Case "S" + Set varRes = NewMalStr(Right(strKey, Len(strKey) - 1)) + Case "K" + Set varRes = NewMalKwd(Right(strKey, Len(strKey) - 1)) + Case Else + Err.Raise vbObjectError, _ + "MalHashmap", "Unexpect key type." + End Select + Set S2M = varRes + End Function + + Public Function Add(varKey, varValue) + If varKey.Type <> TYPES.STRING And _ + varKey.Type <> TYPES.KEYWORD Then + Err.Raise vbObjectError, _ + "MalHashmap", "Unexpect key type." + End If + + Set Value.Item(M2S(varKey)) = varValue + 'Value.Add M2S(varKey), varValue + End Function + + Public Property Get Keys() + Dim aKeys + aKeys = Value.Keys + Dim aRes() + ReDim aRes(UBound(aKeys)) + Dim i + For i = 0 To UBound(aRes) + Set aRes(i) = S2M(aKeys(i)) + Next + + Keys = aRes + End Property + + Public Function Count() + Count = Value.Count + End Function + + Public Property Get Item(i) + Set Item = Value.Item(M2S(i)) + End Property + + Public Function Exists(varKey) + If varKey.Type <> TYPES.STRING And _ + varKey.Type <> TYPES.KEYWORD Then + Err.Raise vbObjectError, _ + "MalHashmap", "Unexpect key type." + End If + Exists = Value.Exists(M2S(varKey)) + End Function + + Public Property Let Item(i, varValue) + Value.Item(M2S(i)) = varValue + End Property + + Public Property Set Item(i, varValue) + Set Value.Item(M2S(i)) = varValue + End Property +End Class + +Function NewMalMap(arrKeys, arrValues) + Dim varResult + Set varResult = New MalHashmap + varResult.Init arrKeys, arrValues + Set NewMalMap = varResult +End Function + +Class VbsProcedure 'Extends MalType + Public [Type] + Public Value + + Public IsMacro + Public boolSpec + Public MetaData + Private Sub Class_Initialize + [Type] = TYPES.PROCEDURE + IsMacro = False + Set MetaData = NewMalNil() + End Sub + + Public Property Get IsSpecial() + IsSpecial = boolSpec + End Property + + Public Function Init(objFunction, boolIsSpec) + Set Value = objFunction + boolSpec = boolIsSpec + End Function + + Public Function Apply(objArgs, objEnv) + Dim varResult + If boolSpec Then + Set varResult = Value(objArgs, objEnv) + Else + Set varResult = Value(EvaluateRest(objArgs, objEnv), objEnv) + End If + Set Apply = varResult + End Function + + Public Function ApplyWithoutEval(objArgs, objEnv) + Dim varResult + Set varResult = Value(objArgs, objEnv) + + Set ApplyWithoutEval = varResult + End Function + + Public Function Copy() + Dim varRes + Set varRes = New VbsProcedure + varRes.Type = [Type] + Set varRes.Value = Value + varRes.IsMacro = IsMacro + varRes.boolSpec = boolSpec + Set Copy = varRes + End Function +End Class + +Function NewVbsProc(strFnName, boolSpec) + Dim varResult + Set varResult = New VbsProcedure + varResult.Init GetRef(strFnName), boolSpec + Set NewVbsProc = varResult +End Function + +Class MalProcedure 'Extends MalType + Public [Type] + Public Value + + Public IsMacro + + Public Property Get IsSpecial() + IsSpecial = False + End Property + + Public MetaData + Private Sub Class_Initialize + [Type] = TYPES.PROCEDURE + IsMacro = False + Set MetaData = NewMalNil() + End Sub + + Public objParams, objCode, objSavedEnv + Public Function Init(objP, objC, objE) + Set objParams = objP + Set objCode = objC + Set objSavedEnv = objE + End Function + + Public Function Apply(objArgs, objEnv) + If IsMacro Then + Err.Raise vbObjectError, _ + "MalProcedureApply", "Not a procedure." + End If + + Dim varRet + Dim objNewEnv + Set objNewEnv = NewEnv(objSavedEnv) + Dim i + i = 0 + Dim objList + While i < objParams.Count + If objParams.Item(i).Value = "&" Then + If objParams.Count - 1 = i + 1 Then + Set objList = NewMalList(Array()) + objNewEnv.Add objParams.Item(i + 1), objList + While i + 1 < objArgs.Count + objList.Add Evaluate(objArgs.Item(i + 1), objEnv) + i = i + 1 + Wend + i = objParams.Count ' Break While + Else + Err.Raise vbObjectError, _ + "MalProcedureApply", "Invalid parameter(s)." + End If + Else + If i + 1 >= objArgs.Count Then + Err.Raise vbObjectError, _ + "MalProcedureApply", "Need more arguments." + End If + objNewEnv.Add objParams.Item(i), _ + Evaluate(objArgs.Item(i + 1), objEnv) + i = i + 1 + End If + Wend + + Set varRet = EvalLater(objCode, objNewEnv) + Set Apply = varRet + End Function + + Public Function MacroApply(objArgs, objEnv) + If Not IsMacro Then + Err.Raise vbObjectError, _ + "MalMacroApply", "Not a macro." + End If + + Dim varRet + Dim objNewEnv + Set objNewEnv = NewEnv(objSavedEnv) + Dim i + i = 0 + Dim objList + While i < objParams.Count + If objParams.Item(i).Value = "&" Then + If objParams.Count - 1 = i + 1 Then + Set objList = NewMalList(Array()) + + ' No evaluation + objNewEnv.Add objParams.Item(i + 1), objList + While i + 1 < objArgs.Count + objList.Add objArgs.Item(i + 1) + i = i + 1 + Wend + i = objParams.Count ' Break While + Else + Err.Raise vbObjectError, _ + "MalMacroApply", "Invalid parameter(s)." + End If + Else + If i + 1 >= objArgs.Count Then + Err.Raise vbObjectError, _ + "MalMacroApply", "Need more arguments." + End If + + ' No evaluation + objNewEnv.Add objParams.Item(i), _ + objArgs.Item(i + 1) + i = i + 1 + End If + Wend + + ' EvalLater -> Evaluate + Set varRet = Evaluate(objCode, objNewEnv) + Set MacroApply = varRet + End Function + + + Public Function ApplyWithoutEval(objArgs, objEnv) + Dim varRet + Dim objNewEnv + Set objNewEnv = NewEnv(objSavedEnv) + Dim i + i = 0 + Dim objList + While i < objParams.Count + If objParams.Item(i).Value = "&" Then + If objParams.Count - 1 = i + 1 Then + Set objList = NewMalList(Array()) + + ' No evaluation + objNewEnv.Add objParams.Item(i + 1), objList + While i + 1 < objArgs.Count + objList.Add objArgs.Item(i + 1) + i = i + 1 + Wend + i = objParams.Count ' Break While + Else + Err.Raise vbObjectError, _ + "MalMacroApply", "Invalid parameter(s)." + End If + Else + If i + 1 >= objArgs.Count Then + Err.Raise vbObjectError, _ + "MalMacroApply", "Need more arguments." + End If + + ' No evaluation + objNewEnv.Add objParams.Item(i), _ + objArgs.Item(i + 1) + i = i + 1 + End If + Wend + + ' EvalLater -> Evaluate + Set varRet = Evaluate(objCode, objNewEnv) + Set ApplyWithoutEval = varRet + End Function + + + Public Function Copy() + Dim varRes + Set varRes = New MalProcedure + varRes.Type = [Type] + varRes.Value = Value + varRes.IsMacro = IsMacro + Set varRes.objParams = objParams + Set varRes.objCode = objCode + Set varRes.objSavedEnv = objSavedEnv + Set Copy = varRes + End Function +End Class + +Function NewMalProc(objParams, objCode, objEnv) + Dim varRet + Set varRet = New MalProcedure + varRet.Init objParams, objCode, objEnv + Set NewMalProc = varRet +End Function + +Function NewMalMacro(objParams, objCode, objEnv) + Dim varRet + Set varRet = New MalProcedure + varRet.Init objParams, objCode, objEnv + varRet.IsMacro = True + Set NewMalProc = varRet +End Function + +Function SetMeta(objMal, objMeta) + Dim varRes + Set varRes = objMal.Copy + Set varRes.MetaData = objMeta + Set SetMeta = varRes +End Function + +Function GetMeta(objMal) + Set GetMeta = objMal.MetaData End Function \ No newline at end of file diff --git a/impls/vhdl/.gitignore b/impls/vhdl/.gitignore index 95000fd028..22489293b3 100644 --- a/impls/vhdl/.gitignore +++ b/impls/vhdl/.gitignore @@ -1 +1 @@ -work-obj93.cf +work-obj93.cf diff --git a/impls/vhdl/Dockerfile b/impls/vhdl/Dockerfile index 6b841c0d2c..3c4bfcd5a4 100644 --- a/impls/vhdl/Dockerfile +++ b/impls/vhdl/Dockerfile @@ -1,30 +1,30 @@ -FROM ubuntu:14.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install software-properties-common && \ - apt-add-repository -y ppa:pgavin/ghdl && \ - apt-get update -y - -RUN apt-get -y install ghdl - -ENV HOME /mal +FROM ubuntu:14.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install software-properties-common && \ + apt-add-repository -y ppa:pgavin/ghdl && \ + apt-get update -y + +RUN apt-get -y install ghdl + +ENV HOME /mal diff --git a/impls/vhdl/Makefile b/impls/vhdl/Makefile index e76b8e104a..8f5b0e3d6c 100644 --- a/impls/vhdl/Makefile +++ b/impls/vhdl/Makefile @@ -1,35 +1,35 @@ -SRCS = step0_repl.vhdl step1_read_print.vhdl step2_eval.vhdl step3_env.vhdl \ - step4_if_fn_do.vhdl step5_tco.vhdl step6_file.vhdl step7_quote.vhdl \ - step8_macros.vhdl step9_try.vhdl stepA_mal.vhdl -OBJS = $(SRCS:%.vhdl=%.o) -BINS = $(OBJS:%.o=%) -OTHER_SRCS = pkg_readline.vhdl types.vhdl printer.vhdl reader.vhdl env.vhdl core.vhdl -OTHER_OBJS = $(OTHER_SRCS:%.vhdl=%.o) - -##################### - -all: $(BINS) - -dist: mal - -mal: $(word $(words $(BINS)),$(BINS)) - cp $< $@ - -work-obj93.cf: $(OTHER_SRCS) - rm -f work-obj93.cf - ghdl -i $+ - -$(OTHER_OBJS): %.o: %.vhdl work-obj93.cf - ghdl -a -g $(@:%.o=%.vhdl) - -$(OBJS): %.o: %.vhdl $(OTHER_OBJS) - ghdl -a -g $(@:%.o=%.vhdl) - -$(patsubst %.o,%,$(filter step%,$(OBJS))): $(OTHER_OBJS) -$(BINS): %: %.o - ghdl -e -g $@ - # ghdl linker creates a lowercase executable; rename it to stepA_mal - if [ "$@" = "stepA_mal" ]; then mv stepa_mal $@; fi - -clean: - rm -f $(OBJS) $(BINS) $(OTHER_OBJS) work-obj93.cf mal +SRCS = step0_repl.vhdl step1_read_print.vhdl step2_eval.vhdl step3_env.vhdl \ + step4_if_fn_do.vhdl step5_tco.vhdl step6_file.vhdl step7_quote.vhdl \ + step8_macros.vhdl step9_try.vhdl stepA_mal.vhdl +OBJS = $(SRCS:%.vhdl=%.o) +BINS = $(OBJS:%.o=%) +OTHER_SRCS = pkg_readline.vhdl types.vhdl printer.vhdl reader.vhdl env.vhdl core.vhdl +OTHER_OBJS = $(OTHER_SRCS:%.vhdl=%.o) + +##################### + +all: $(BINS) + +dist: mal + +mal: $(word $(words $(BINS)),$(BINS)) + cp $< $@ + +work-obj93.cf: $(OTHER_SRCS) + rm -f work-obj93.cf + ghdl -i $+ + +$(OTHER_OBJS): %.o: %.vhdl work-obj93.cf + ghdl -a -g $(@:%.o=%.vhdl) + +$(OBJS): %.o: %.vhdl $(OTHER_OBJS) + ghdl -a -g $(@:%.o=%.vhdl) + +$(patsubst %.o,%,$(filter step%,$(OBJS))): $(OTHER_OBJS) +$(BINS): %: %.o + ghdl -e -g $@ + # ghdl linker creates a lowercase executable; rename it to stepA_mal + if [ "$@" = "stepA_mal" ]; then mv stepa_mal $@; fi + +clean: + rm -f $(OBJS) $(BINS) $(OTHER_OBJS) work-obj93.cf mal diff --git a/impls/vhdl/core.vhdl b/impls/vhdl/core.vhdl index 2b6523671a..56f8d577b8 100644 --- a/impls/vhdl/core.vhdl +++ b/impls/vhdl/core.vhdl @@ -1,686 +1,686 @@ -library STD; -use STD.textio.all; -library WORK; -use WORK.types.all; -use WORK.env.all; -use WORK.reader.all; -use WORK.printer.all; -use WORK.pkg_readline.all; - -package core is - procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - procedure define_core_functions(e: inout env_ptr); -end package core; - -package body core is - - procedure fn_equal(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable is_equal: boolean; - begin - equal_q(args.seq_val(0), args.seq_val(1), is_equal); - new_boolean(is_equal, result); - end procedure fn_equal; - - procedure fn_throw(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - err := args.seq_val(0); - end procedure fn_throw; - - procedure fn_nil_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_nil, result); - end procedure fn_nil_q; - - procedure fn_true_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_true, result); - end procedure fn_true_q; - - procedure fn_false_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_false, result); - end procedure fn_false_q; - - procedure fn_string_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_string, result); - end procedure fn_string_q; - - procedure fn_symbol(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_symbol(args.seq_val(0).string_val, result); - end procedure fn_symbol; - - procedure fn_symbol_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_symbol, result); - end procedure fn_symbol_q; - - procedure fn_keyword(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_keyword(args.seq_val(0).string_val, result); - end procedure fn_keyword; - - procedure fn_keyword_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_keyword, result); - end procedure fn_keyword_q; - - procedure fn_number_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_number, result); - end procedure fn_number_q; - - procedure fn_function_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean((args.seq_val(0).val_type = mal_fn and not args.seq_val(0).func_val.f_is_macro) or args.seq_val(0).val_type = mal_nativefn, result); - end procedure fn_function_q; - - procedure fn_macro_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_fn and args.seq_val(0).func_val.f_is_macro, result); - end procedure fn_macro_q; - - procedure fn_pr_str(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable s: line; - begin - pr_seq("", "", " ", args.seq_val, true, s); - new_string(s, result); - end procedure fn_pr_str; - - procedure fn_str(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable s: line; - begin - pr_seq("", "", "", args.seq_val, false, s); - new_string(s, result); - end procedure fn_str; - - procedure fn_prn(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable s: line; - begin - pr_seq("", "", " ", args.seq_val, true, s); - mal_printline(s.all); - new_nil(result); - end procedure fn_prn; - - procedure fn_println(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable s: line; - begin - pr_seq("", "", " ", args.seq_val, false, s); - mal_printline(s.all); - new_nil(result); - end procedure fn_println; - - procedure fn_read_string(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast: mal_val_ptr; - begin - read_str(args.seq_val(0).string_val.all, ast, err); - if ast = null then - new_nil(result); - else - result := ast; - end if; - end procedure fn_read_string; - - procedure fn_readline(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable input_line: line; - variable is_eof: boolean; - begin - mal_readline(args.seq_val(0).string_val.all, is_eof, input_line); - if is_eof then - new_nil(result); - else - new_string(input_line, result); - end if; - end procedure fn_readline; - - procedure fn_slurp(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - file f: text; - variable status: file_open_status; - variable save_content, content, one_line: line; - begin - file_open(status, f, external_name => args.seq_val(0).string_val.all, open_kind => read_mode); - if status = open_ok then - content := new string'(""); - while not endfile(f) loop - readline(f, one_line); - save_content := content; - content := new string'(save_content.all & one_line.all & LF); - deallocate(save_content); - end loop; - file_close(f); - new_string(content, result); - else - new_string("Error opening file", err); - end if; - end procedure fn_slurp; - - procedure fn_lt(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).number_val < args.seq_val(1).number_val, result); - end procedure fn_lt; - - procedure fn_lte(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).number_val <= args.seq_val(1).number_val, result); - end procedure fn_lte; - - procedure fn_gt(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).number_val > args.seq_val(1).number_val, result); - end procedure fn_gt; - - procedure fn_gte(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).number_val >= args.seq_val(1).number_val, result); - end procedure fn_gte; - - procedure fn_add(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_number(args.seq_val(0).number_val + args.seq_val(1).number_val, result); - end procedure fn_add; - - procedure fn_sub(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_number(args.seq_val(0).number_val - args.seq_val(1).number_val, result); - end procedure fn_sub; - - procedure fn_mul(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_number(args.seq_val(0).number_val * args.seq_val(1).number_val, result); - end procedure fn_mul; - - procedure fn_div(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_number(args.seq_val(0).number_val / args.seq_val(1).number_val, result); - end procedure fn_div; - - -- Define physical types (c_seconds64, c_microseconds64) because these are - -- represented as 64-bit words when passed to C functions - type c_seconds64 is range 0 to 1E16 - units - c_sec; - end units c_seconds64; - - type c_microseconds64 is range 0 to 1E6 - units - c_usec; - end units c_microseconds64; - - type c_timeval is record - tv_sec: c_seconds64; - tv_usec: c_microseconds64; - end record c_timeval; - - -- Leave enough room for two 64-bit words - type c_timezone is record - dummy_1: c_seconds64; - dummy_2: c_seconds64; - end record c_timezone; - - function gettimeofday(tv: c_timeval; tz: c_timezone) return integer; - attribute foreign of gettimeofday: function is "VHPIDIRECT gettimeofday"; - - function gettimeofday(tv: c_timeval; tz: c_timezone) return integer is - begin - assert false severity failure; - end function gettimeofday; - - -- Returns the number of milliseconds since last midnight UTC because a - -- standard VHDL integer is 32-bit and therefore cannot hold the number of - -- milliseconds since 1970-01-01. - procedure fn_time_ms(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable tv: c_timeval; - variable dummy: c_timezone; - variable rc: integer; - begin - rc := gettimeofday(tv, dummy); - new_number(((tv.tv_sec / 1 c_sec) mod 86400) * 1000 + (tv.tv_usec / 1000 c_usec), result); - end procedure fn_time_ms; - - procedure fn_list(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - result := args; - end procedure fn_list; - - procedure fn_list_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_list, result); - end procedure fn_list_q; - - procedure fn_vector(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - args.val_type := mal_vector; - result := args; - end procedure fn_vector; - - procedure fn_vector_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_vector, result); - end procedure fn_vector_q; - - procedure fn_hash_map(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - args.val_type := mal_hashmap; - result := args; - end procedure fn_hash_map; - - procedure fn_map_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(args.seq_val(0).val_type = mal_hashmap, result); - end procedure fn_map_q; - - procedure fn_assoc(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable new_hashmap: mal_val_ptr; - variable i: integer; - begin - hashmap_copy(args.seq_val(0), new_hashmap); - i := 1; - while i < args.seq_val'length loop - hashmap_put(new_hashmap, args.seq_val(i), args.seq_val(i + 1)); - i := i + 2; - end loop; - result := new_hashmap; - end procedure fn_assoc; - - procedure fn_dissoc(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable new_hashmap: mal_val_ptr; - variable i: integer; - begin - hashmap_copy(args.seq_val(0), new_hashmap); - for i in 1 to args.seq_val'high loop - hashmap_delete(new_hashmap, args.seq_val(i)); - end loop; - result := new_hashmap; - end procedure fn_dissoc; - - procedure fn_get(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - variable a1: mal_val_ptr := args.seq_val(1); - variable val: mal_val_ptr; - begin - if a0.val_type = mal_nil then - new_nil(result); - else - hashmap_get(a0, a1, val); - if val = null then - new_nil(result); - else - result := val; - end if; - end if; - end procedure fn_get; - - procedure fn_contains_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - variable a1: mal_val_ptr := args.seq_val(1); - variable found: boolean; - begin - hashmap_contains(a0, a1, found); - new_boolean(found, result); - end procedure fn_contains_q; - - procedure fn_keys(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - variable seq: mal_seq_ptr; - begin - seq := new mal_seq(0 to a0.seq_val'length / 2 - 1); - for i in seq'range loop - seq(i) := a0.seq_val(i * 2); - end loop; - new_seq_obj(mal_list, seq, result); - end procedure fn_keys; - - procedure fn_vals(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - variable seq: mal_seq_ptr; - begin - seq := new mal_seq(0 to a0.seq_val'length / 2 - 1); - for i in seq'range loop - seq(i) := a0.seq_val(i * 2 + 1); - end loop; - new_seq_obj(mal_list, seq, result); - end procedure fn_vals; - - procedure cons_helper(a0: inout mal_val_ptr; a1: inout mal_val_ptr; result: out mal_val_ptr) is - variable seq: mal_seq_ptr; - begin - seq := new mal_seq(0 to a1.seq_val'length); - seq(0) := a0; - seq(1 to seq'length - 1) := a1.seq_val(0 to a1.seq_val'length - 1); - new_seq_obj(mal_list, seq, result); - end procedure cons_helper; - - procedure fn_cons(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - variable a1: mal_val_ptr := args.seq_val(1); - variable seq: mal_seq_ptr; - begin - cons_helper(a0, a1, result); - end procedure fn_cons; - - procedure fn_sequential_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_boolean(is_sequential_type(args.seq_val(0).val_type), result); - end procedure fn_sequential_q; - - procedure fn_concat(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable seq: mal_seq_ptr; - variable i: integer; - begin - seq := new mal_seq(0 to -1); - for i in args.seq_val'range loop - seq := new mal_seq'(seq.all & args.seq_val(i).seq_val.all); - end loop; - new_seq_obj(mal_list, seq, result); - end procedure fn_concat; - - procedure fn_vec(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - if args.seq_val(0).val_type = mal_vector then - result := args.seq_val(0); - else - new_seq_obj(mal_vector, args.seq_val(0).seq_val, result); - end if; - end procedure fn_vec; - - procedure fn_nth(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable lst_seq: mal_seq_ptr := args.seq_val(0).seq_val; - variable index: integer := args.seq_val(1).number_val; - begin - if index >= lst_seq'length then - new_string("nth: index out of range", err); - else - result := lst_seq(index); - end if; - end procedure fn_nth; - - procedure fn_first(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - begin - if a0.val_type = mal_nil or a0.seq_val'length = 0 then - new_nil(result); - else - result := a0.seq_val(0); - end if; - end procedure fn_first; - - procedure fn_rest(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - variable seq: mal_seq_ptr; - variable new_list: mal_val_ptr; - begin - if a0.val_type = mal_nil or a0.seq_val'length = 0 then - seq := new mal_seq(0 to -1); - new_seq_obj(mal_list, seq, result); - else - seq_drop_prefix(a0, 1, new_list); - new_list.val_type := mal_list; - result := new_list; - end if; - end procedure fn_rest; - - procedure fn_empty_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable is_empty: boolean; - begin - case args.seq_val(0).val_type is - when mal_nil => new_boolean(true, result); - when mal_list | mal_vector => new_boolean(args.seq_val(0).seq_val'length = 0, result); - when others => new_string("empty?: invalid argument type", err); - end case; - end procedure fn_empty_q; - - procedure fn_count(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable count: integer; - begin - case args.seq_val(0).val_type is - when mal_nil => new_number(0, result); - when mal_list | mal_vector => new_number(args.seq_val(0).seq_val'length, result); - when others => new_string("count: invalid argument type", err); - end case; - end procedure fn_count; - - procedure fn_conj(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - variable r: mal_val_ptr; - variable seq: mal_seq_ptr; - begin - case a0.val_type is - when mal_list => - r := a0; - for i in 1 to args.seq_val'high loop - cons_helper(args.seq_val(i), r, r); - end loop; - result := r; - when mal_vector => - seq := new mal_seq(0 to a0.seq_val'length + args.seq_val'length - 2); - seq(0 to a0.seq_val'high) := a0.seq_val(a0.seq_val'range); - seq(a0.seq_val'high + 1 to seq'high) := args.seq_val(1 to args.seq_val'high); - new_seq_obj(mal_vector, seq, result); - when others => - new_string("conj requires list or vector", err); - end case; - end procedure fn_conj; - - procedure fn_seq(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - variable new_seq: mal_seq_ptr; - begin - case a0.val_type is - when mal_string => - if a0.string_val'length = 0 then - new_nil(result); - else - new_seq := new mal_seq(0 to a0.string_val'length - 1); - for i in new_seq'range loop - new_string("" & a0.string_val(i + 1), new_seq(i)); - end loop; - new_seq_obj(mal_list, new_seq, result); - end if; - when mal_list => - if a0.seq_val'length = 0 then - new_nil(result); - else - result := a0; - end if; - when mal_vector => - if a0.seq_val'length = 0 then - new_nil(result); - else - new_seq_obj(mal_list, a0.seq_val, result); - end if; - when mal_nil => - new_nil(result); - when others => - new_string("seq requires string or list or vector or nil", err); - end case; - end procedure fn_seq; - - procedure fn_meta(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable meta_val: mal_val_ptr; - begin - meta_val := args.seq_val(0).meta_val; - if meta_val = null then - new_nil(result); - else - result := meta_val; - end if; - end procedure fn_meta; - - procedure fn_with_meta(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - begin - result := new mal_val'(val_type => a0.val_type, number_val => a0.number_val, string_val => a0.string_val, seq_val => a0.seq_val, func_val => a0.func_val, meta_val => args.seq_val(1)); - end procedure fn_with_meta; - - procedure fn_atom(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - new_atom(args.seq_val(0), result); - end procedure fn_atom; - - procedure fn_atom_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - begin - new_boolean(a0.val_type = mal_atom, result); - end procedure fn_atom_q; - - procedure fn_deref(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - begin - result := a0.seq_val(0); - end procedure fn_deref; - - procedure fn_reset(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a0: mal_val_ptr := args.seq_val(0); - variable a1: mal_val_ptr := args.seq_val(1); - begin - a0.seq_val(0) := a1; - result := a1; - end procedure fn_reset; - - procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable f: line; - begin - if func_sym.val_type /= mal_nativefn then - new_string("not a native function!", err); - return; - end if; - f := func_sym.string_val; - if f.all = "=" then fn_equal(args, result, err); - elsif f.all = "throw" then fn_throw(args, result, err); - elsif f.all = "nil?" then fn_nil_q(args, result, err); - elsif f.all = "true?" then fn_true_q(args, result, err); - elsif f.all = "false?" then fn_false_q(args, result, err); - elsif f.all = "string?" then fn_string_q(args, result, err); - elsif f.all = "symbol" then fn_symbol(args, result, err); - elsif f.all = "symbol?" then fn_symbol_q(args, result, err); - elsif f.all = "keyword" then fn_keyword(args, result, err); - elsif f.all = "keyword?" then fn_keyword_q(args, result, err); - elsif f.all = "number?" then fn_number_q(args, result, err); - elsif f.all = "fn?" then fn_function_q(args, result, err); - elsif f.all = "macro?" then fn_macro_q(args, result, err); - elsif f.all = "pr-str" then fn_pr_str(args, result, err); - elsif f.all = "str" then fn_str(args, result, err); - elsif f.all = "prn" then fn_prn(args, result, err); - elsif f.all = "println" then fn_println(args, result, err); - elsif f.all = "read-string" then fn_read_string(args, result, err); - elsif f.all = "readline" then fn_readline(args, result, err); - elsif f.all = "slurp" then fn_slurp(args, result, err); - elsif f.all = "<" then fn_lt(args, result, err); - elsif f.all = "<=" then fn_lte(args, result, err); - elsif f.all = ">" then fn_gt(args, result, err); - elsif f.all = ">=" then fn_gte(args, result, err); - elsif f.all = "+" then fn_add(args, result, err); - elsif f.all = "-" then fn_sub(args, result, err); - elsif f.all = "*" then fn_mul(args, result, err); - elsif f.all = "/" then fn_div(args, result, err); - elsif f.all = "time-ms" then fn_time_ms(args, result, err); - elsif f.all = "list" then fn_list(args, result, err); - elsif f.all = "list?" then fn_list_q(args, result, err); - elsif f.all = "vector" then fn_vector(args, result, err); - elsif f.all = "vector?" then fn_vector_q(args, result, err); - elsif f.all = "hash-map" then fn_hash_map(args, result, err); - elsif f.all = "map?" then fn_map_q(args, result, err); - elsif f.all = "assoc" then fn_assoc(args, result, err); - elsif f.all = "dissoc" then fn_dissoc(args, result, err); - elsif f.all = "get" then fn_get(args, result, err); - elsif f.all = "contains?" then fn_contains_q(args, result, err); - elsif f.all = "keys" then fn_keys(args, result, err); - elsif f.all = "vals" then fn_vals(args, result, err); - elsif f.all = "sequential?" then fn_sequential_q(args, result, err); - elsif f.all = "cons" then fn_cons(args, result, err); - elsif f.all = "concat" then fn_concat(args, result, err); - elsif f.all = "vec" then fn_vec(args, result, err); - elsif f.all = "nth" then fn_nth(args, result, err); - elsif f.all = "first" then fn_first(args, result, err); - elsif f.all = "rest" then fn_rest(args, result, err); - elsif f.all = "empty?" then fn_empty_q(args, result, err); - elsif f.all = "count" then fn_count(args, result, err); - elsif f.all = "conj" then fn_conj(args, result, err); - elsif f.all = "seq" then fn_seq(args, result, err); - elsif f.all = "meta" then fn_meta(args, result, err); - elsif f.all = "with-meta" then fn_with_meta(args, result, err); - elsif f.all = "atom" then fn_atom(args, result, err); - elsif f.all = "atom?" then fn_atom_q(args, result, err); - elsif f.all = "deref" then fn_deref(args, result, err); - elsif f.all = "reset!" then fn_reset(args, result, err); - else - result := null; - end if; - end procedure eval_native_func; - - procedure define_core_function(e: inout env_ptr; func_name: in string) is - variable sym: mal_val_ptr; - variable fn: mal_val_ptr; - begin - new_symbol(func_name, sym); - new_nativefn(func_name, fn); - env_set(e, sym, fn); - end procedure define_core_function; - - procedure define_core_functions(e: inout env_ptr) is - begin - define_core_function(e, "="); - define_core_function(e, "throw"); - define_core_function(e, "nil?"); - define_core_function(e, "true?"); - define_core_function(e, "false?"); - define_core_function(e, "string?"); - define_core_function(e, "symbol"); - define_core_function(e, "symbol?"); - define_core_function(e, "keyword"); - define_core_function(e, "keyword?"); - define_core_function(e, "number?"); - define_core_function(e, "fn?"); - define_core_function(e, "macro?"); - define_core_function(e, "pr-str"); - define_core_function(e, "str"); - define_core_function(e, "prn"); - define_core_function(e, "println"); - define_core_function(e, "read-string"); - define_core_function(e, "readline"); - define_core_function(e, "slurp"); - define_core_function(e, "<"); - define_core_function(e, "<="); - define_core_function(e, ">"); - define_core_function(e, ">="); - define_core_function(e, "+"); - define_core_function(e, "-"); - define_core_function(e, "*"); - define_core_function(e, "/"); - define_core_function(e, "time-ms"); - define_core_function(e, "list"); - define_core_function(e, "list?"); - define_core_function(e, "vector"); - define_core_function(e, "vector?"); - define_core_function(e, "hash-map"); - define_core_function(e, "map?"); - define_core_function(e, "assoc"); - define_core_function(e, "dissoc"); - define_core_function(e, "get"); - define_core_function(e, "contains?"); - define_core_function(e, "keys"); - define_core_function(e, "vals"); - define_core_function(e, "sequential?"); - define_core_function(e, "cons"); - define_core_function(e, "concat"); - define_core_function(e, "vec"); - define_core_function(e, "nth"); - define_core_function(e, "first"); - define_core_function(e, "rest"); - define_core_function(e, "empty?"); - define_core_function(e, "count"); - define_core_function(e, "apply"); -- implemented in the stepN_XXX files - define_core_function(e, "map"); -- implemented in the stepN_XXX files - define_core_function(e, "conj"); - define_core_function(e, "seq"); - define_core_function(e, "meta"); - define_core_function(e, "with-meta"); - define_core_function(e, "atom"); - define_core_function(e, "atom?"); - define_core_function(e, "deref"); - define_core_function(e, "reset!"); - define_core_function(e, "swap!"); -- implemented in the stepN_XXX files - end procedure define_core_functions; - -end package body core; +library STD; +use STD.textio.all; +library WORK; +use WORK.types.all; +use WORK.env.all; +use WORK.reader.all; +use WORK.printer.all; +use WORK.pkg_readline.all; + +package core is + procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + procedure define_core_functions(e: inout env_ptr); +end package core; + +package body core is + + procedure fn_equal(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable is_equal: boolean; + begin + equal_q(args.seq_val(0), args.seq_val(1), is_equal); + new_boolean(is_equal, result); + end procedure fn_equal; + + procedure fn_throw(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + err := args.seq_val(0); + end procedure fn_throw; + + procedure fn_nil_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_nil, result); + end procedure fn_nil_q; + + procedure fn_true_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_true, result); + end procedure fn_true_q; + + procedure fn_false_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_false, result); + end procedure fn_false_q; + + procedure fn_string_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_string, result); + end procedure fn_string_q; + + procedure fn_symbol(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_symbol(args.seq_val(0).string_val, result); + end procedure fn_symbol; + + procedure fn_symbol_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_symbol, result); + end procedure fn_symbol_q; + + procedure fn_keyword(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_keyword(args.seq_val(0).string_val, result); + end procedure fn_keyword; + + procedure fn_keyword_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_keyword, result); + end procedure fn_keyword_q; + + procedure fn_number_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_number, result); + end procedure fn_number_q; + + procedure fn_function_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean((args.seq_val(0).val_type = mal_fn and not args.seq_val(0).func_val.f_is_macro) or args.seq_val(0).val_type = mal_nativefn, result); + end procedure fn_function_q; + + procedure fn_macro_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_fn and args.seq_val(0).func_val.f_is_macro, result); + end procedure fn_macro_q; + + procedure fn_pr_str(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable s: line; + begin + pr_seq("", "", " ", args.seq_val, true, s); + new_string(s, result); + end procedure fn_pr_str; + + procedure fn_str(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable s: line; + begin + pr_seq("", "", "", args.seq_val, false, s); + new_string(s, result); + end procedure fn_str; + + procedure fn_prn(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable s: line; + begin + pr_seq("", "", " ", args.seq_val, true, s); + mal_printline(s.all); + new_nil(result); + end procedure fn_prn; + + procedure fn_println(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable s: line; + begin + pr_seq("", "", " ", args.seq_val, false, s); + mal_printline(s.all); + new_nil(result); + end procedure fn_println; + + procedure fn_read_string(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast: mal_val_ptr; + begin + read_str(args.seq_val(0).string_val.all, ast, err); + if ast = null then + new_nil(result); + else + result := ast; + end if; + end procedure fn_read_string; + + procedure fn_readline(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable input_line: line; + variable is_eof: boolean; + begin + mal_readline(args.seq_val(0).string_val.all, is_eof, input_line); + if is_eof then + new_nil(result); + else + new_string(input_line, result); + end if; + end procedure fn_readline; + + procedure fn_slurp(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + file f: text; + variable status: file_open_status; + variable save_content, content, one_line: line; + begin + file_open(status, f, external_name => args.seq_val(0).string_val.all, open_kind => read_mode); + if status = open_ok then + content := new string'(""); + while not endfile(f) loop + readline(f, one_line); + save_content := content; + content := new string'(save_content.all & one_line.all & LF); + deallocate(save_content); + end loop; + file_close(f); + new_string(content, result); + else + new_string("Error opening file", err); + end if; + end procedure fn_slurp; + + procedure fn_lt(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).number_val < args.seq_val(1).number_val, result); + end procedure fn_lt; + + procedure fn_lte(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).number_val <= args.seq_val(1).number_val, result); + end procedure fn_lte; + + procedure fn_gt(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).number_val > args.seq_val(1).number_val, result); + end procedure fn_gt; + + procedure fn_gte(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).number_val >= args.seq_val(1).number_val, result); + end procedure fn_gte; + + procedure fn_add(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_number(args.seq_val(0).number_val + args.seq_val(1).number_val, result); + end procedure fn_add; + + procedure fn_sub(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_number(args.seq_val(0).number_val - args.seq_val(1).number_val, result); + end procedure fn_sub; + + procedure fn_mul(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_number(args.seq_val(0).number_val * args.seq_val(1).number_val, result); + end procedure fn_mul; + + procedure fn_div(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_number(args.seq_val(0).number_val / args.seq_val(1).number_val, result); + end procedure fn_div; + + -- Define physical types (c_seconds64, c_microseconds64) because these are + -- represented as 64-bit words when passed to C functions + type c_seconds64 is range 0 to 1E16 + units + c_sec; + end units c_seconds64; + + type c_microseconds64 is range 0 to 1E6 + units + c_usec; + end units c_microseconds64; + + type c_timeval is record + tv_sec: c_seconds64; + tv_usec: c_microseconds64; + end record c_timeval; + + -- Leave enough room for two 64-bit words + type c_timezone is record + dummy_1: c_seconds64; + dummy_2: c_seconds64; + end record c_timezone; + + function gettimeofday(tv: c_timeval; tz: c_timezone) return integer; + attribute foreign of gettimeofday: function is "VHPIDIRECT gettimeofday"; + + function gettimeofday(tv: c_timeval; tz: c_timezone) return integer is + begin + assert false severity failure; + end function gettimeofday; + + -- Returns the number of milliseconds since last midnight UTC because a + -- standard VHDL integer is 32-bit and therefore cannot hold the number of + -- milliseconds since 1970-01-01. + procedure fn_time_ms(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable tv: c_timeval; + variable dummy: c_timezone; + variable rc: integer; + begin + rc := gettimeofday(tv, dummy); + new_number(((tv.tv_sec / 1 c_sec) mod 86400) * 1000 + (tv.tv_usec / 1000 c_usec), result); + end procedure fn_time_ms; + + procedure fn_list(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + result := args; + end procedure fn_list; + + procedure fn_list_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_list, result); + end procedure fn_list_q; + + procedure fn_vector(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + args.val_type := mal_vector; + result := args; + end procedure fn_vector; + + procedure fn_vector_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_vector, result); + end procedure fn_vector_q; + + procedure fn_hash_map(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + args.val_type := mal_hashmap; + result := args; + end procedure fn_hash_map; + + procedure fn_map_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(args.seq_val(0).val_type = mal_hashmap, result); + end procedure fn_map_q; + + procedure fn_assoc(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable new_hashmap: mal_val_ptr; + variable i: integer; + begin + hashmap_copy(args.seq_val(0), new_hashmap); + i := 1; + while i < args.seq_val'length loop + hashmap_put(new_hashmap, args.seq_val(i), args.seq_val(i + 1)); + i := i + 2; + end loop; + result := new_hashmap; + end procedure fn_assoc; + + procedure fn_dissoc(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable new_hashmap: mal_val_ptr; + variable i: integer; + begin + hashmap_copy(args.seq_val(0), new_hashmap); + for i in 1 to args.seq_val'high loop + hashmap_delete(new_hashmap, args.seq_val(i)); + end loop; + result := new_hashmap; + end procedure fn_dissoc; + + procedure fn_get(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + variable a1: mal_val_ptr := args.seq_val(1); + variable val: mal_val_ptr; + begin + if a0.val_type = mal_nil then + new_nil(result); + else + hashmap_get(a0, a1, val); + if val = null then + new_nil(result); + else + result := val; + end if; + end if; + end procedure fn_get; + + procedure fn_contains_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + variable a1: mal_val_ptr := args.seq_val(1); + variable found: boolean; + begin + hashmap_contains(a0, a1, found); + new_boolean(found, result); + end procedure fn_contains_q; + + procedure fn_keys(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + variable seq: mal_seq_ptr; + begin + seq := new mal_seq(0 to a0.seq_val'length / 2 - 1); + for i in seq'range loop + seq(i) := a0.seq_val(i * 2); + end loop; + new_seq_obj(mal_list, seq, result); + end procedure fn_keys; + + procedure fn_vals(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + variable seq: mal_seq_ptr; + begin + seq := new mal_seq(0 to a0.seq_val'length / 2 - 1); + for i in seq'range loop + seq(i) := a0.seq_val(i * 2 + 1); + end loop; + new_seq_obj(mal_list, seq, result); + end procedure fn_vals; + + procedure cons_helper(a0: inout mal_val_ptr; a1: inout mal_val_ptr; result: out mal_val_ptr) is + variable seq: mal_seq_ptr; + begin + seq := new mal_seq(0 to a1.seq_val'length); + seq(0) := a0; + seq(1 to seq'length - 1) := a1.seq_val(0 to a1.seq_val'length - 1); + new_seq_obj(mal_list, seq, result); + end procedure cons_helper; + + procedure fn_cons(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + variable a1: mal_val_ptr := args.seq_val(1); + variable seq: mal_seq_ptr; + begin + cons_helper(a0, a1, result); + end procedure fn_cons; + + procedure fn_sequential_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_boolean(is_sequential_type(args.seq_val(0).val_type), result); + end procedure fn_sequential_q; + + procedure fn_concat(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable seq: mal_seq_ptr; + variable i: integer; + begin + seq := new mal_seq(0 to -1); + for i in args.seq_val'range loop + seq := new mal_seq'(seq.all & args.seq_val(i).seq_val.all); + end loop; + new_seq_obj(mal_list, seq, result); + end procedure fn_concat; + + procedure fn_vec(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + if args.seq_val(0).val_type = mal_vector then + result := args.seq_val(0); + else + new_seq_obj(mal_vector, args.seq_val(0).seq_val, result); + end if; + end procedure fn_vec; + + procedure fn_nth(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable lst_seq: mal_seq_ptr := args.seq_val(0).seq_val; + variable index: integer := args.seq_val(1).number_val; + begin + if index >= lst_seq'length then + new_string("nth: index out of range", err); + else + result := lst_seq(index); + end if; + end procedure fn_nth; + + procedure fn_first(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + begin + if a0.val_type = mal_nil or a0.seq_val'length = 0 then + new_nil(result); + else + result := a0.seq_val(0); + end if; + end procedure fn_first; + + procedure fn_rest(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + variable seq: mal_seq_ptr; + variable new_list: mal_val_ptr; + begin + if a0.val_type = mal_nil or a0.seq_val'length = 0 then + seq := new mal_seq(0 to -1); + new_seq_obj(mal_list, seq, result); + else + seq_drop_prefix(a0, 1, new_list); + new_list.val_type := mal_list; + result := new_list; + end if; + end procedure fn_rest; + + procedure fn_empty_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable is_empty: boolean; + begin + case args.seq_val(0).val_type is + when mal_nil => new_boolean(true, result); + when mal_list | mal_vector => new_boolean(args.seq_val(0).seq_val'length = 0, result); + when others => new_string("empty?: invalid argument type", err); + end case; + end procedure fn_empty_q; + + procedure fn_count(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable count: integer; + begin + case args.seq_val(0).val_type is + when mal_nil => new_number(0, result); + when mal_list | mal_vector => new_number(args.seq_val(0).seq_val'length, result); + when others => new_string("count: invalid argument type", err); + end case; + end procedure fn_count; + + procedure fn_conj(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + variable r: mal_val_ptr; + variable seq: mal_seq_ptr; + begin + case a0.val_type is + when mal_list => + r := a0; + for i in 1 to args.seq_val'high loop + cons_helper(args.seq_val(i), r, r); + end loop; + result := r; + when mal_vector => + seq := new mal_seq(0 to a0.seq_val'length + args.seq_val'length - 2); + seq(0 to a0.seq_val'high) := a0.seq_val(a0.seq_val'range); + seq(a0.seq_val'high + 1 to seq'high) := args.seq_val(1 to args.seq_val'high); + new_seq_obj(mal_vector, seq, result); + when others => + new_string("conj requires list or vector", err); + end case; + end procedure fn_conj; + + procedure fn_seq(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + variable new_seq: mal_seq_ptr; + begin + case a0.val_type is + when mal_string => + if a0.string_val'length = 0 then + new_nil(result); + else + new_seq := new mal_seq(0 to a0.string_val'length - 1); + for i in new_seq'range loop + new_string("" & a0.string_val(i + 1), new_seq(i)); + end loop; + new_seq_obj(mal_list, new_seq, result); + end if; + when mal_list => + if a0.seq_val'length = 0 then + new_nil(result); + else + result := a0; + end if; + when mal_vector => + if a0.seq_val'length = 0 then + new_nil(result); + else + new_seq_obj(mal_list, a0.seq_val, result); + end if; + when mal_nil => + new_nil(result); + when others => + new_string("seq requires string or list or vector or nil", err); + end case; + end procedure fn_seq; + + procedure fn_meta(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable meta_val: mal_val_ptr; + begin + meta_val := args.seq_val(0).meta_val; + if meta_val = null then + new_nil(result); + else + result := meta_val; + end if; + end procedure fn_meta; + + procedure fn_with_meta(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + begin + result := new mal_val'(val_type => a0.val_type, number_val => a0.number_val, string_val => a0.string_val, seq_val => a0.seq_val, func_val => a0.func_val, meta_val => args.seq_val(1)); + end procedure fn_with_meta; + + procedure fn_atom(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + new_atom(args.seq_val(0), result); + end procedure fn_atom; + + procedure fn_atom_q(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + begin + new_boolean(a0.val_type = mal_atom, result); + end procedure fn_atom_q; + + procedure fn_deref(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + begin + result := a0.seq_val(0); + end procedure fn_deref; + + procedure fn_reset(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a0: mal_val_ptr := args.seq_val(0); + variable a1: mal_val_ptr := args.seq_val(1); + begin + a0.seq_val(0) := a1; + result := a1; + end procedure fn_reset; + + procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable f: line; + begin + if func_sym.val_type /= mal_nativefn then + new_string("not a native function!", err); + return; + end if; + f := func_sym.string_val; + if f.all = "=" then fn_equal(args, result, err); + elsif f.all = "throw" then fn_throw(args, result, err); + elsif f.all = "nil?" then fn_nil_q(args, result, err); + elsif f.all = "true?" then fn_true_q(args, result, err); + elsif f.all = "false?" then fn_false_q(args, result, err); + elsif f.all = "string?" then fn_string_q(args, result, err); + elsif f.all = "symbol" then fn_symbol(args, result, err); + elsif f.all = "symbol?" then fn_symbol_q(args, result, err); + elsif f.all = "keyword" then fn_keyword(args, result, err); + elsif f.all = "keyword?" then fn_keyword_q(args, result, err); + elsif f.all = "number?" then fn_number_q(args, result, err); + elsif f.all = "fn?" then fn_function_q(args, result, err); + elsif f.all = "macro?" then fn_macro_q(args, result, err); + elsif f.all = "pr-str" then fn_pr_str(args, result, err); + elsif f.all = "str" then fn_str(args, result, err); + elsif f.all = "prn" then fn_prn(args, result, err); + elsif f.all = "println" then fn_println(args, result, err); + elsif f.all = "read-string" then fn_read_string(args, result, err); + elsif f.all = "readline" then fn_readline(args, result, err); + elsif f.all = "slurp" then fn_slurp(args, result, err); + elsif f.all = "<" then fn_lt(args, result, err); + elsif f.all = "<=" then fn_lte(args, result, err); + elsif f.all = ">" then fn_gt(args, result, err); + elsif f.all = ">=" then fn_gte(args, result, err); + elsif f.all = "+" then fn_add(args, result, err); + elsif f.all = "-" then fn_sub(args, result, err); + elsif f.all = "*" then fn_mul(args, result, err); + elsif f.all = "/" then fn_div(args, result, err); + elsif f.all = "time-ms" then fn_time_ms(args, result, err); + elsif f.all = "list" then fn_list(args, result, err); + elsif f.all = "list?" then fn_list_q(args, result, err); + elsif f.all = "vector" then fn_vector(args, result, err); + elsif f.all = "vector?" then fn_vector_q(args, result, err); + elsif f.all = "hash-map" then fn_hash_map(args, result, err); + elsif f.all = "map?" then fn_map_q(args, result, err); + elsif f.all = "assoc" then fn_assoc(args, result, err); + elsif f.all = "dissoc" then fn_dissoc(args, result, err); + elsif f.all = "get" then fn_get(args, result, err); + elsif f.all = "contains?" then fn_contains_q(args, result, err); + elsif f.all = "keys" then fn_keys(args, result, err); + elsif f.all = "vals" then fn_vals(args, result, err); + elsif f.all = "sequential?" then fn_sequential_q(args, result, err); + elsif f.all = "cons" then fn_cons(args, result, err); + elsif f.all = "concat" then fn_concat(args, result, err); + elsif f.all = "vec" then fn_vec(args, result, err); + elsif f.all = "nth" then fn_nth(args, result, err); + elsif f.all = "first" then fn_first(args, result, err); + elsif f.all = "rest" then fn_rest(args, result, err); + elsif f.all = "empty?" then fn_empty_q(args, result, err); + elsif f.all = "count" then fn_count(args, result, err); + elsif f.all = "conj" then fn_conj(args, result, err); + elsif f.all = "seq" then fn_seq(args, result, err); + elsif f.all = "meta" then fn_meta(args, result, err); + elsif f.all = "with-meta" then fn_with_meta(args, result, err); + elsif f.all = "atom" then fn_atom(args, result, err); + elsif f.all = "atom?" then fn_atom_q(args, result, err); + elsif f.all = "deref" then fn_deref(args, result, err); + elsif f.all = "reset!" then fn_reset(args, result, err); + else + result := null; + end if; + end procedure eval_native_func; + + procedure define_core_function(e: inout env_ptr; func_name: in string) is + variable sym: mal_val_ptr; + variable fn: mal_val_ptr; + begin + new_symbol(func_name, sym); + new_nativefn(func_name, fn); + env_set(e, sym, fn); + end procedure define_core_function; + + procedure define_core_functions(e: inout env_ptr) is + begin + define_core_function(e, "="); + define_core_function(e, "throw"); + define_core_function(e, "nil?"); + define_core_function(e, "true?"); + define_core_function(e, "false?"); + define_core_function(e, "string?"); + define_core_function(e, "symbol"); + define_core_function(e, "symbol?"); + define_core_function(e, "keyword"); + define_core_function(e, "keyword?"); + define_core_function(e, "number?"); + define_core_function(e, "fn?"); + define_core_function(e, "macro?"); + define_core_function(e, "pr-str"); + define_core_function(e, "str"); + define_core_function(e, "prn"); + define_core_function(e, "println"); + define_core_function(e, "read-string"); + define_core_function(e, "readline"); + define_core_function(e, "slurp"); + define_core_function(e, "<"); + define_core_function(e, "<="); + define_core_function(e, ">"); + define_core_function(e, ">="); + define_core_function(e, "+"); + define_core_function(e, "-"); + define_core_function(e, "*"); + define_core_function(e, "/"); + define_core_function(e, "time-ms"); + define_core_function(e, "list"); + define_core_function(e, "list?"); + define_core_function(e, "vector"); + define_core_function(e, "vector?"); + define_core_function(e, "hash-map"); + define_core_function(e, "map?"); + define_core_function(e, "assoc"); + define_core_function(e, "dissoc"); + define_core_function(e, "get"); + define_core_function(e, "contains?"); + define_core_function(e, "keys"); + define_core_function(e, "vals"); + define_core_function(e, "sequential?"); + define_core_function(e, "cons"); + define_core_function(e, "concat"); + define_core_function(e, "vec"); + define_core_function(e, "nth"); + define_core_function(e, "first"); + define_core_function(e, "rest"); + define_core_function(e, "empty?"); + define_core_function(e, "count"); + define_core_function(e, "apply"); -- implemented in the stepN_XXX files + define_core_function(e, "map"); -- implemented in the stepN_XXX files + define_core_function(e, "conj"); + define_core_function(e, "seq"); + define_core_function(e, "meta"); + define_core_function(e, "with-meta"); + define_core_function(e, "atom"); + define_core_function(e, "atom?"); + define_core_function(e, "deref"); + define_core_function(e, "reset!"); + define_core_function(e, "swap!"); -- implemented in the stepN_XXX files + end procedure define_core_functions; + +end package body core; diff --git a/impls/vhdl/env.vhdl b/impls/vhdl/env.vhdl index 1625a9aba6..67525618d0 100644 --- a/impls/vhdl/env.vhdl +++ b/impls/vhdl/env.vhdl @@ -1,72 +1,72 @@ -library STD; -use STD.textio.all; -library WORK; -use WORK.types.all; - -package env is - procedure new_env(e: out env_ptr; an_outer: inout env_ptr); - procedure new_env(e: out env_ptr; an_outer: inout env_ptr; binds: inout mal_val_ptr; exprs: inout mal_val_ptr); - procedure env_set(e: inout env_ptr; key: inout mal_val_ptr; val: inout mal_val_ptr); - procedure env_get(e: inout env_ptr; key: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); -end package env; - -package body env is - procedure new_env(e: out env_ptr; an_outer: inout env_ptr) is - variable null_list: mal_val_ptr; - begin - null_list := null; - new_env(e, an_outer, null_list, null_list); - end procedure new_env; - - procedure new_env(e: out env_ptr; an_outer: inout env_ptr; binds: inout mal_val_ptr; exprs: inout mal_val_ptr) is - variable the_data, more_exprs: mal_val_ptr; - variable i: integer; - begin - new_empty_hashmap(the_data); - if binds /= null then - for i in binds.seq_val'range loop - if binds.seq_val(i).string_val.all = "&" then - seq_drop_prefix(exprs, i, more_exprs); - hashmap_put(the_data, binds.seq_val(i + 1), more_exprs); - exit; - else - hashmap_put(the_data, binds.seq_val(i), exprs.seq_val(i)); - end if; - end loop; - end if; - e := new env_record'(outer => an_outer, data => the_data); - end procedure new_env; - - procedure env_set(e: inout env_ptr; key: inout mal_val_ptr; val: inout mal_val_ptr) is - begin - hashmap_put(e.data, key, val); - end procedure env_set; - - procedure env_find(e: inout env_ptr; key: inout mal_val_ptr; found_env: out env_ptr) is - variable found: boolean; - begin - hashmap_contains(e.data, key, found); - if found then - found_env := e; - else - if e.outer = null then - found_env := null; - else - env_find(e.outer, key, found_env); - end if; - end if; - end procedure env_find; - - procedure env_get(e: inout env_ptr; key: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable found_env: env_ptr; - begin - env_find(e, key, found_env); - if found_env = null then - new_string("'" & key.string_val.all & "' not found", err); - result := null; - return; - end if; - hashmap_get(found_env.data, key, result); - end procedure env_get; - -end package body env; +library STD; +use STD.textio.all; +library WORK; +use WORK.types.all; + +package env is + procedure new_env(e: out env_ptr; an_outer: inout env_ptr); + procedure new_env(e: out env_ptr; an_outer: inout env_ptr; binds: inout mal_val_ptr; exprs: inout mal_val_ptr); + procedure env_set(e: inout env_ptr; key: inout mal_val_ptr; val: inout mal_val_ptr); + procedure env_get(e: inout env_ptr; key: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); +end package env; + +package body env is + procedure new_env(e: out env_ptr; an_outer: inout env_ptr) is + variable null_list: mal_val_ptr; + begin + null_list := null; + new_env(e, an_outer, null_list, null_list); + end procedure new_env; + + procedure new_env(e: out env_ptr; an_outer: inout env_ptr; binds: inout mal_val_ptr; exprs: inout mal_val_ptr) is + variable the_data, more_exprs: mal_val_ptr; + variable i: integer; + begin + new_empty_hashmap(the_data); + if binds /= null then + for i in binds.seq_val'range loop + if binds.seq_val(i).string_val.all = "&" then + seq_drop_prefix(exprs, i, more_exprs); + hashmap_put(the_data, binds.seq_val(i + 1), more_exprs); + exit; + else + hashmap_put(the_data, binds.seq_val(i), exprs.seq_val(i)); + end if; + end loop; + end if; + e := new env_record'(outer => an_outer, data => the_data); + end procedure new_env; + + procedure env_set(e: inout env_ptr; key: inout mal_val_ptr; val: inout mal_val_ptr) is + begin + hashmap_put(e.data, key, val); + end procedure env_set; + + procedure env_find(e: inout env_ptr; key: inout mal_val_ptr; found_env: out env_ptr) is + variable found: boolean; + begin + hashmap_contains(e.data, key, found); + if found then + found_env := e; + else + if e.outer = null then + found_env := null; + else + env_find(e.outer, key, found_env); + end if; + end if; + end procedure env_find; + + procedure env_get(e: inout env_ptr; key: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable found_env: env_ptr; + begin + env_find(e, key, found_env); + if found_env = null then + new_string("'" & key.string_val.all & "' not found", err); + result := null; + return; + end if; + hashmap_get(found_env.data, key, result); + end procedure env_get; + +end package body env; diff --git a/impls/vhdl/pkg_readline.vhdl b/impls/vhdl/pkg_readline.vhdl index c06ff0bdf1..81dcf18765 100644 --- a/impls/vhdl/pkg_readline.vhdl +++ b/impls/vhdl/pkg_readline.vhdl @@ -1,36 +1,36 @@ -library STD; -use STD.textio.all; - -package pkg_readline is - procedure mal_printline(l: string); - procedure mal_readline(prompt: string; eof_detected: out boolean; l: inout line); -end package pkg_readline; - -package body pkg_readline is - type charfile is file of character; - file stdout_char: charfile open write_mode is "STD_OUTPUT"; - - procedure mal_printstr(l: string) is - begin - for i in l'range loop - write(stdout_char, l(i)); - end loop; - end procedure mal_printstr; - - procedure mal_printline(l: string) is - begin - mal_printstr(l); - write(stdout_char, LF); - end procedure mal_printline; - - procedure mal_readline(prompt: string; eof_detected: out boolean; l: inout line) is - begin - mal_printstr(prompt); - if endfile(input) then - eof_detected := true; - else - readline(input, l); - eof_detected := false; - end if; - end procedure mal_readline; -end package body pkg_readline; +library STD; +use STD.textio.all; + +package pkg_readline is + procedure mal_printline(l: string); + procedure mal_readline(prompt: string; eof_detected: out boolean; l: inout line); +end package pkg_readline; + +package body pkg_readline is + type charfile is file of character; + file stdout_char: charfile open write_mode is "STD_OUTPUT"; + + procedure mal_printstr(l: string) is + begin + for i in l'range loop + write(stdout_char, l(i)); + end loop; + end procedure mal_printstr; + + procedure mal_printline(l: string) is + begin + mal_printstr(l); + write(stdout_char, LF); + end procedure mal_printline; + + procedure mal_readline(prompt: string; eof_detected: out boolean; l: inout line) is + begin + mal_printstr(prompt); + if endfile(input) then + eof_detected := true; + else + readline(input, l); + eof_detected := false; + end if; + end procedure mal_readline; +end package body pkg_readline; diff --git a/impls/vhdl/printer.vhdl b/impls/vhdl/printer.vhdl index c3b3e63ada..4298cf0913 100644 --- a/impls/vhdl/printer.vhdl +++ b/impls/vhdl/printer.vhdl @@ -1,97 +1,97 @@ -library STD; -use STD.textio.all; -library WORK; -use WORK.types.all; - -package printer is - procedure pr_str(ast: inout mal_val_ptr; readable: in boolean; result: out line); - procedure pr_seq(start_ch: in string; end_ch: in string; delim: in string; a_seq: inout mal_seq_ptr; readable: in boolean; result: out line); -end package printer; - -package body printer is - - procedure pr_string(val: inout line; readable: in boolean; result: out line) is - variable s: line; - variable src_i, dst_i: integer; - begin - if readable then - s := new string(1 to val'length * 2); - dst_i := 0; - for src_i in val'range loop - dst_i := dst_i + 1; - case val(src_i) is - when LF => - s(dst_i) := '\'; - dst_i := dst_i + 1; - s(dst_i) := 'n'; - when '"' => - s(dst_i) := '\'; - dst_i := dst_i + 1; - s(dst_i) := '"'; - when '\' => - s(dst_i) := '\'; - dst_i := dst_i + 1; - s(dst_i) := '\'; - when others => - s(dst_i) := val(src_i); - end case; - end loop; - result := new string'("" & '"' & s(1 to dst_i) & '"'); - deallocate(s); - else - result := val; - end if; - end; - - procedure pr_str(ast: inout mal_val_ptr; readable: in boolean; result: out line) is - variable l: line; - begin - case ast.val_type is - when mal_nil => - result := new string'("nil"); - when mal_true => - result := new string'("true"); - when mal_false => - result := new string'("false"); - when mal_number => - write(l, ast.number_val); - result := l; - when mal_symbol => - result := ast.string_val; - when mal_string => - pr_string(ast.string_val, readable, result); - when mal_keyword => - result := new string'(":" & ast.string_val.all); - when mal_list => - pr_seq("(", ")", " ", ast.seq_val, readable, result); - when mal_vector => - pr_seq("[", "]", " ", ast.seq_val, readable, result); - when mal_hashmap => - pr_seq("{", "}", " ", ast.seq_val, readable, result); - when mal_atom => - pr_str(ast.seq_val(0), true, l); - result := new string'("(atom " & l.all & ")"); - when mal_nativefn => - result := new string'("#"); - when mal_fn => - result := new string'("#"); - end case; - end procedure pr_str; - - procedure pr_seq(start_ch: in string; end_ch: in string; delim: in string; a_seq: inout mal_seq_ptr; readable: in boolean; result: out line) is - variable s, element_s: line; - begin - s := new string'(start_ch); - for i in a_seq'range loop - pr_str(a_seq(i), readable, element_s); - if i = 0 then - s := new string'(s.all & element_s.all); - else - s := new string'(s.all & delim & element_s.all); - end if; - end loop; - s := new string'(s.all & end_ch); - result := s; - end procedure pr_seq; - -end package body printer; +library STD; +use STD.textio.all; +library WORK; +use WORK.types.all; + +package printer is + procedure pr_str(ast: inout mal_val_ptr; readable: in boolean; result: out line); + procedure pr_seq(start_ch: in string; end_ch: in string; delim: in string; a_seq: inout mal_seq_ptr; readable: in boolean; result: out line); +end package printer; + +package body printer is + + procedure pr_string(val: inout line; readable: in boolean; result: out line) is + variable s: line; + variable src_i, dst_i: integer; + begin + if readable then + s := new string(1 to val'length * 2); + dst_i := 0; + for src_i in val'range loop + dst_i := dst_i + 1; + case val(src_i) is + when LF => + s(dst_i) := '\'; + dst_i := dst_i + 1; + s(dst_i) := 'n'; + when '"' => + s(dst_i) := '\'; + dst_i := dst_i + 1; + s(dst_i) := '"'; + when '\' => + s(dst_i) := '\'; + dst_i := dst_i + 1; + s(dst_i) := '\'; + when others => + s(dst_i) := val(src_i); + end case; + end loop; + result := new string'("" & '"' & s(1 to dst_i) & '"'); + deallocate(s); + else + result := val; + end if; + end; + + procedure pr_str(ast: inout mal_val_ptr; readable: in boolean; result: out line) is + variable l: line; + begin + case ast.val_type is + when mal_nil => + result := new string'("nil"); + when mal_true => + result := new string'("true"); + when mal_false => + result := new string'("false"); + when mal_number => + write(l, ast.number_val); + result := l; + when mal_symbol => + result := ast.string_val; + when mal_string => + pr_string(ast.string_val, readable, result); + when mal_keyword => + result := new string'(":" & ast.string_val.all); + when mal_list => + pr_seq("(", ")", " ", ast.seq_val, readable, result); + when mal_vector => + pr_seq("[", "]", " ", ast.seq_val, readable, result); + when mal_hashmap => + pr_seq("{", "}", " ", ast.seq_val, readable, result); + when mal_atom => + pr_str(ast.seq_val(0), true, l); + result := new string'("(atom " & l.all & ")"); + when mal_nativefn => + result := new string'("#"); + when mal_fn => + result := new string'("#"); + end case; + end procedure pr_str; + + procedure pr_seq(start_ch: in string; end_ch: in string; delim: in string; a_seq: inout mal_seq_ptr; readable: in boolean; result: out line) is + variable s, element_s: line; + begin + s := new string'(start_ch); + for i in a_seq'range loop + pr_str(a_seq(i), readable, element_s); + if i = 0 then + s := new string'(s.all & element_s.all); + else + s := new string'(s.all & delim & element_s.all); + end if; + end loop; + s := new string'(s.all & end_ch); + result := s; + end procedure pr_seq; + +end package body printer; diff --git a/impls/vhdl/reader.vhdl b/impls/vhdl/reader.vhdl index f057fb7efb..3eff6f47b7 100644 --- a/impls/vhdl/reader.vhdl +++ b/impls/vhdl/reader.vhdl @@ -1,366 +1,366 @@ -library STD; -use STD.textio.all; -library WORK; -use WORK.types.all; - -package reader is - procedure read_str(s: in string; result: out mal_val_ptr; err: out mal_val_ptr); -end package reader; - -package body reader is - - type token_list is array(natural range <>) of line; - type token_list_ptr is access token_list; - - function is_eol_char(c: in character) return boolean is - begin - case c is - when LF | CR => return true; - when others => return false; - end case; - end function is_eol_char; - - function is_separator_char(c: in character) return boolean is - begin - case c is - when LF | CR | ' ' | '[' | ']' | '{' | '}' | '(' | ')' | - ''' | '"' | '`' | ',' | ';' => return true; - when others => return false; - end case; - end function is_separator_char; - - procedure next_token(str: in string; pos: in positive; token: inout line; next_start_pos: out positive; ok: out boolean) is - variable ch: character; - variable tmppos: positive; - begin - token := new string'(""); - if pos > str'length then - ok := false; - return; - end if; - - ch := str(pos); - - case ch is - when ' ' | ',' | LF | CR | HT => - next_start_pos := pos + 1; - token := new string'(""); - ok := true; - return; - - when '[' | ']' | '{' | '}' | '(' | ')' | ''' | '`' | '^' | '@' => - next_start_pos := pos + 1; - token := new string'("" & ch); - ok := true; - return; - - when '~' => - if str(pos + 1) = '@' then - next_start_pos := pos + 2; - token := new string'("~@"); - else - next_start_pos := pos + 1; - token := new string'("~"); - end if; - ok := true; - return; - - when ';' => - tmppos := pos + 1; - while tmppos <= str'length and not is_eol_char(str(tmppos)) loop - tmppos := tmppos + 1; - end loop; - next_start_pos := tmppos; - token := new string'(""); - ok := true; - return; - - when '"' => - tmppos := pos + 1; - while tmppos < str'length and str(tmppos) /= '"' loop - if str(tmppos) = '\' then - tmppos := tmppos + 2; - else - tmppos := tmppos + 1; - end if; - end loop; - if tmppos > str'length then - tmppos := tmppos - 1; -- unterminated string, will be caught in unescape_string_token - end if; - token := new string(1 to (tmppos - pos + 1)); - token(1 to (tmppos - pos + 1)) := str(pos to tmppos); - next_start_pos := tmppos + 1; - ok := true; - return; - - when others => - tmppos := pos; - while tmppos <= str'length and not is_separator_char(str(tmppos)) loop - tmppos := tmppos + 1; - end loop; - token := new string(1 to (tmppos - pos)); - token(1 to (tmppos - pos)) := str(pos to tmppos - 1); - next_start_pos := tmppos; - ok := true; - return; - - end case; - - ok := false; - end procedure next_token; - - function tokenize(str: in string) return token_list_ptr is - variable next_pos: positive := 1; - variable ok: boolean := true; - variable tokens: token_list_ptr; - variable t: line; - begin - while ok loop - next_token(str, next_pos, t, next_pos, ok); - if t'length > 0 then - if tokens = null then - tokens := new token_list(0 to 0); - tokens(0) := t; - else - tokens := new token_list'(tokens.all & t); - end if; - end if; - end loop; - return tokens; - end function tokenize; - - type reader_class is record - tokens: token_list_ptr; - pos: natural; - end record reader_class; - - procedure reader_new(r: inout reader_class; a_tokens: inout token_list_ptr) is - begin - r := (tokens => a_tokens, pos => 0); - end procedure reader_new; - - procedure reader_peek(r: inout reader_class; token: out line) is - begin - if r.pos < r.tokens'length then - token := r.tokens(r.pos); - else - token := null; - end if; - end procedure reader_peek; - - procedure reader_next(r: inout reader_class; token: out line) is - begin - reader_peek(r, token); - r.pos := r.pos + 1; - end procedure reader_next; - - -- Forward declaration - procedure read_form(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr); - - function is_digit(c: in character) return boolean is - begin - case c is - when '0' to '9' => return true; - when others => return false; - end case; - end function is_digit; - - function unescape_char(c: in character) return character is - begin - case c is - when 'n' => return LF; - when others => return c; - end case; - end function unescape_char; - - procedure unescape_string_token(token: inout line; result: out line) is - variable s: line; - variable src_i, dst_i: integer; - begin - s := new string(1 to token'length); - dst_i := 0; - src_i := 2; -- skip the initial quote - while src_i <= token'length - 1 loop - dst_i := dst_i + 1; - if token(src_i) = '\' then - s(dst_i) := unescape_char(token(src_i + 1)); - src_i := src_i + 2; - else - s(dst_i) := token(src_i); - src_i := src_i + 1; - end if; - end loop; - if src_i <= token'length then - result := new string'(s(1 to dst_i)); - else - result := null; - end if; - deallocate(s); - end procedure unescape_string_token; - - procedure read_atom(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr) is - variable token, s: line; - variable num: integer; - variable ch: character; - begin - reader_next(r, token); - if token.all = "nil" then - new_nil(result); - elsif token.all = "true" then - new_true(result); - elsif token.all = "false" then - new_false(result); - else - ch := token(1); - case ch is - when '-' => - if token'length > 1 and is_digit(token(2)) then - read(token, num); - new_number(num, result); - else - new_symbol(token, result); - end if; - when '0' to '9' => - read(token, num); - new_number(num, result); - when ':' => - s := new string(1 to token'length - 1); - s(1 to s'length) := token(2 to token'length); - new_keyword(s, result); - when '"' => - if token(token'length) /= '"' then - new_string("expected '""', got EOF", err); - result := null; - return; - end if; - unescape_string_token(token, s); - if s = null then - new_string("expected '""', got EOF", err); - result := null; - return; - end if; - new_string(s, result); - when others => - new_symbol(token, result); - end case; - end if; - end procedure read_atom; - - procedure read_sequence(list_type: in mal_type_tag; end_ch: in string; r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr) is - variable token: line; - variable element, sub_err: mal_val_ptr; - variable seq: mal_seq_ptr; - begin - reader_next(r, token); -- Consume the open paren - reader_peek(r, token); - seq := new mal_seq(0 to -1); - while token /= null and token.all /= end_ch loop - read_form(r, element, sub_err); - if sub_err /= null then - err := sub_err; - result := null; - return; - end if; - seq := new mal_seq'(seq.all & element); - reader_peek(r, token); - end loop; - if token = null then - new_string("expected '" & end_ch & "', got EOF", err); - result := null; - return; - end if; - reader_next(r, token); -- Consume the close paren - new_seq_obj(list_type, seq, result); - end procedure read_sequence; - - procedure reader_macro(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr; sym_name: in string) is - variable token, sym_line: line; - variable seq: mal_seq_ptr; - variable rest, rest_err: mal_val_ptr; - begin - reader_next(r, token); - seq := new mal_seq(0 to 1); - sym_line := new string'(sym_name); - new_symbol(sym_line, seq(0)); - read_form(r, rest, rest_err); - if rest_err /= null then - err := rest_err; - result := null; - return; - end if; - seq(1) := rest; - new_seq_obj(mal_list, seq, result); - end procedure reader_macro; - - procedure with_meta_reader_macro(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr) is - variable token, sym_line: line; - variable seq: mal_seq_ptr; - variable meta, rest, rest_err: mal_val_ptr; - begin - reader_next(r, token); - seq := new mal_seq(0 to 2); - sym_line := new string'("with-meta"); - new_symbol(sym_line, seq(0)); - read_form(r, meta, rest_err); - if rest_err /= null then - err := rest_err; - result := null; - return; - end if; - read_form(r, rest, rest_err); - if rest_err /= null then - err := rest_err; - result := null; - return; - end if; - seq(1) := rest; - seq(2) := meta; - new_seq_obj(mal_list, seq, result); - end procedure with_meta_reader_macro; - - procedure read_form(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr) is - variable token: line; - variable ch: character; - begin - reader_peek(r, token); - ch := token(1); - case ch is - when ''' => reader_macro(r, result, err, "quote"); - when '`' => reader_macro(r, result, err, "quasiquote"); - when '~' => - if token'length = 1 then - reader_macro(r, result, err, "unquote"); - else - if token(2) = '@' then - reader_macro(r, result, err, "splice-unquote"); - else - new_string("Unknown token", err); - end if; - end if; - when '^' => with_meta_reader_macro(r, result, err); - when '@' => reader_macro(r, result, err, "deref"); - when '(' => read_sequence(mal_list, ")", r, result, err); - when ')' => new_string("unexcepted ')'", err); - when '[' => read_sequence(mal_vector, "]", r, result, err); - when ']' => new_string("unexcepted ']'", err); - when '{' => read_sequence(mal_hashmap, "}", r, result, err); - when '}' => new_string("unexcepted '}'", err); - when others => read_atom(r, result, err); - end case; - end procedure read_form; - - procedure read_str(s: in string; result: out mal_val_ptr; err: out mal_val_ptr) is - variable tokens: token_list_ptr; - variable r: reader_class; - begin - tokens := tokenize(s); - if tokens = null or tokens'length = 0 then - result := null; - err := null; - return; - end if; - reader_new(r, tokens); - read_form(r, result, err); - end procedure read_str; - -end package body reader; +library STD; +use STD.textio.all; +library WORK; +use WORK.types.all; + +package reader is + procedure read_str(s: in string; result: out mal_val_ptr; err: out mal_val_ptr); +end package reader; + +package body reader is + + type token_list is array(natural range <>) of line; + type token_list_ptr is access token_list; + + function is_eol_char(c: in character) return boolean is + begin + case c is + when LF | CR => return true; + when others => return false; + end case; + end function is_eol_char; + + function is_separator_char(c: in character) return boolean is + begin + case c is + when LF | CR | ' ' | '[' | ']' | '{' | '}' | '(' | ')' | + ''' | '"' | '`' | ',' | ';' => return true; + when others => return false; + end case; + end function is_separator_char; + + procedure next_token(str: in string; pos: in positive; token: inout line; next_start_pos: out positive; ok: out boolean) is + variable ch: character; + variable tmppos: positive; + begin + token := new string'(""); + if pos > str'length then + ok := false; + return; + end if; + + ch := str(pos); + + case ch is + when ' ' | ',' | LF | CR | HT => + next_start_pos := pos + 1; + token := new string'(""); + ok := true; + return; + + when '[' | ']' | '{' | '}' | '(' | ')' | ''' | '`' | '^' | '@' => + next_start_pos := pos + 1; + token := new string'("" & ch); + ok := true; + return; + + when '~' => + if str(pos + 1) = '@' then + next_start_pos := pos + 2; + token := new string'("~@"); + else + next_start_pos := pos + 1; + token := new string'("~"); + end if; + ok := true; + return; + + when ';' => + tmppos := pos + 1; + while tmppos <= str'length and not is_eol_char(str(tmppos)) loop + tmppos := tmppos + 1; + end loop; + next_start_pos := tmppos; + token := new string'(""); + ok := true; + return; + + when '"' => + tmppos := pos + 1; + while tmppos < str'length and str(tmppos) /= '"' loop + if str(tmppos) = '\' then + tmppos := tmppos + 2; + else + tmppos := tmppos + 1; + end if; + end loop; + if tmppos > str'length then + tmppos := tmppos - 1; -- unterminated string, will be caught in unescape_string_token + end if; + token := new string(1 to (tmppos - pos + 1)); + token(1 to (tmppos - pos + 1)) := str(pos to tmppos); + next_start_pos := tmppos + 1; + ok := true; + return; + + when others => + tmppos := pos; + while tmppos <= str'length and not is_separator_char(str(tmppos)) loop + tmppos := tmppos + 1; + end loop; + token := new string(1 to (tmppos - pos)); + token(1 to (tmppos - pos)) := str(pos to tmppos - 1); + next_start_pos := tmppos; + ok := true; + return; + + end case; + + ok := false; + end procedure next_token; + + function tokenize(str: in string) return token_list_ptr is + variable next_pos: positive := 1; + variable ok: boolean := true; + variable tokens: token_list_ptr; + variable t: line; + begin + while ok loop + next_token(str, next_pos, t, next_pos, ok); + if t'length > 0 then + if tokens = null then + tokens := new token_list(0 to 0); + tokens(0) := t; + else + tokens := new token_list'(tokens.all & t); + end if; + end if; + end loop; + return tokens; + end function tokenize; + + type reader_class is record + tokens: token_list_ptr; + pos: natural; + end record reader_class; + + procedure reader_new(r: inout reader_class; a_tokens: inout token_list_ptr) is + begin + r := (tokens => a_tokens, pos => 0); + end procedure reader_new; + + procedure reader_peek(r: inout reader_class; token: out line) is + begin + if r.pos < r.tokens'length then + token := r.tokens(r.pos); + else + token := null; + end if; + end procedure reader_peek; + + procedure reader_next(r: inout reader_class; token: out line) is + begin + reader_peek(r, token); + r.pos := r.pos + 1; + end procedure reader_next; + + -- Forward declaration + procedure read_form(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr); + + function is_digit(c: in character) return boolean is + begin + case c is + when '0' to '9' => return true; + when others => return false; + end case; + end function is_digit; + + function unescape_char(c: in character) return character is + begin + case c is + when 'n' => return LF; + when others => return c; + end case; + end function unescape_char; + + procedure unescape_string_token(token: inout line; result: out line) is + variable s: line; + variable src_i, dst_i: integer; + begin + s := new string(1 to token'length); + dst_i := 0; + src_i := 2; -- skip the initial quote + while src_i <= token'length - 1 loop + dst_i := dst_i + 1; + if token(src_i) = '\' then + s(dst_i) := unescape_char(token(src_i + 1)); + src_i := src_i + 2; + else + s(dst_i) := token(src_i); + src_i := src_i + 1; + end if; + end loop; + if src_i <= token'length then + result := new string'(s(1 to dst_i)); + else + result := null; + end if; + deallocate(s); + end procedure unescape_string_token; + + procedure read_atom(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr) is + variable token, s: line; + variable num: integer; + variable ch: character; + begin + reader_next(r, token); + if token.all = "nil" then + new_nil(result); + elsif token.all = "true" then + new_true(result); + elsif token.all = "false" then + new_false(result); + else + ch := token(1); + case ch is + when '-' => + if token'length > 1 and is_digit(token(2)) then + read(token, num); + new_number(num, result); + else + new_symbol(token, result); + end if; + when '0' to '9' => + read(token, num); + new_number(num, result); + when ':' => + s := new string(1 to token'length - 1); + s(1 to s'length) := token(2 to token'length); + new_keyword(s, result); + when '"' => + if token(token'length) /= '"' then + new_string("expected '""', got EOF", err); + result := null; + return; + end if; + unescape_string_token(token, s); + if s = null then + new_string("expected '""', got EOF", err); + result := null; + return; + end if; + new_string(s, result); + when others => + new_symbol(token, result); + end case; + end if; + end procedure read_atom; + + procedure read_sequence(list_type: in mal_type_tag; end_ch: in string; r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr) is + variable token: line; + variable element, sub_err: mal_val_ptr; + variable seq: mal_seq_ptr; + begin + reader_next(r, token); -- Consume the open paren + reader_peek(r, token); + seq := new mal_seq(0 to -1); + while token /= null and token.all /= end_ch loop + read_form(r, element, sub_err); + if sub_err /= null then + err := sub_err; + result := null; + return; + end if; + seq := new mal_seq'(seq.all & element); + reader_peek(r, token); + end loop; + if token = null then + new_string("expected '" & end_ch & "', got EOF", err); + result := null; + return; + end if; + reader_next(r, token); -- Consume the close paren + new_seq_obj(list_type, seq, result); + end procedure read_sequence; + + procedure reader_macro(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr; sym_name: in string) is + variable token, sym_line: line; + variable seq: mal_seq_ptr; + variable rest, rest_err: mal_val_ptr; + begin + reader_next(r, token); + seq := new mal_seq(0 to 1); + sym_line := new string'(sym_name); + new_symbol(sym_line, seq(0)); + read_form(r, rest, rest_err); + if rest_err /= null then + err := rest_err; + result := null; + return; + end if; + seq(1) := rest; + new_seq_obj(mal_list, seq, result); + end procedure reader_macro; + + procedure with_meta_reader_macro(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr) is + variable token, sym_line: line; + variable seq: mal_seq_ptr; + variable meta, rest, rest_err: mal_val_ptr; + begin + reader_next(r, token); + seq := new mal_seq(0 to 2); + sym_line := new string'("with-meta"); + new_symbol(sym_line, seq(0)); + read_form(r, meta, rest_err); + if rest_err /= null then + err := rest_err; + result := null; + return; + end if; + read_form(r, rest, rest_err); + if rest_err /= null then + err := rest_err; + result := null; + return; + end if; + seq(1) := rest; + seq(2) := meta; + new_seq_obj(mal_list, seq, result); + end procedure with_meta_reader_macro; + + procedure read_form(r: inout reader_class; result: out mal_val_ptr; err: out mal_val_ptr) is + variable token: line; + variable ch: character; + begin + reader_peek(r, token); + ch := token(1); + case ch is + when ''' => reader_macro(r, result, err, "quote"); + when '`' => reader_macro(r, result, err, "quasiquote"); + when '~' => + if token'length = 1 then + reader_macro(r, result, err, "unquote"); + else + if token(2) = '@' then + reader_macro(r, result, err, "splice-unquote"); + else + new_string("Unknown token", err); + end if; + end if; + when '^' => with_meta_reader_macro(r, result, err); + when '@' => reader_macro(r, result, err, "deref"); + when '(' => read_sequence(mal_list, ")", r, result, err); + when ')' => new_string("unexcepted ')'", err); + when '[' => read_sequence(mal_vector, "]", r, result, err); + when ']' => new_string("unexcepted ']'", err); + when '{' => read_sequence(mal_hashmap, "}", r, result, err); + when '}' => new_string("unexcepted '}'", err); + when others => read_atom(r, result, err); + end case; + end procedure read_form; + + procedure read_str(s: in string; result: out mal_val_ptr; err: out mal_val_ptr) is + variable tokens: token_list_ptr; + variable r: reader_class; + begin + tokens := tokenize(s); + if tokens = null or tokens'length = 0 then + result := null; + err := null; + return; + end if; + reader_new(r, tokens); + read_form(r, result, err); + end procedure read_str; + +end package body reader; diff --git a/impls/vhdl/run b/impls/vhdl/run index 12de079d1f..92bbebb676 100755 --- a/impls/vhdl/run +++ b/impls/vhdl/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/run_vhdl.sh $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/run_vhdl.sh $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/vhdl/run_vhdl.sh b/impls/vhdl/run_vhdl.sh index b8e374a222..30cc0ea55a 100755 --- a/impls/vhdl/run_vhdl.sh +++ b/impls/vhdl/run_vhdl.sh @@ -1,21 +1,21 @@ -#!/bin/bash - -# ghdl doesn't allow passing command-line arguments to the VHDL program. To -# circumvent that, we write the command-line arguments as lines in -# vhdl_argv.tmp, and read the content of that file at the beginning of the VHDL -# program. - -cleanup() { - trap - TERM QUIT INT EXIT - rm -f vhdl_argv.tmp -} -trap "cleanup" TERM QUIT INT EXIT - -bin="$1" -shift - -for arg in "$@" ; do - echo "$arg" -done > vhdl_argv.tmp - -$bin +#!/bin/bash + +# ghdl doesn't allow passing command-line arguments to the VHDL program. To +# circumvent that, we write the command-line arguments as lines in +# vhdl_argv.tmp, and read the content of that file at the beginning of the VHDL +# program. + +cleanup() { + trap - TERM QUIT INT EXIT + rm -f vhdl_argv.tmp +} +trap "cleanup" TERM QUIT INT EXIT + +bin="$1" +shift + +for arg in "$@" ; do + echo "$arg" +done > vhdl_argv.tmp + +$bin diff --git a/impls/vhdl/step0_repl.vhdl b/impls/vhdl/step0_repl.vhdl index 5f82036f2e..18383a54fc 100644 --- a/impls/vhdl/step0_repl.vhdl +++ b/impls/vhdl/step0_repl.vhdl @@ -1,45 +1,45 @@ -entity step0_repl is -end entity step0_repl; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; - -architecture test of step0_repl is - function mal_READ(str: in string) return string is - begin - return str; - end function mal_READ; - - function EVAL(ast: in string; env: in string) return string is - begin - return ast; - end function EVAL; - - function mal_PRINT(exp: in string) return string is - begin - return exp; - end function mal_PRINT; - - function REP(str: in string) return string is - begin - return mal_PRINT(EVAL(mal_READ(str), "")); - end function REP; - - procedure repl is - variable is_eof: boolean; - variable input_line: line; - begin - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - mal_printline(REP(input_line.all)); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step0_repl is +end entity step0_repl; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; + +architecture test of step0_repl is + function mal_READ(str: in string) return string is + begin + return str; + end function mal_READ; + + function EVAL(ast: in string; env: in string) return string is + begin + return ast; + end function EVAL; + + function mal_PRINT(exp: in string) return string is + begin + return exp; + end function mal_PRINT; + + function REP(str: in string) return string is + begin + return mal_PRINT(EVAL(mal_READ(str), "")); + end function REP; + + procedure repl is + variable is_eof: boolean; + variable input_line: line; + begin + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + mal_printline(REP(input_line.all)); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/step1_read_print.vhdl b/impls/vhdl/step1_read_print.vhdl index 2736386cdb..1a5ac33852 100644 --- a/impls/vhdl/step1_read_print.vhdl +++ b/impls/vhdl/step1_read_print.vhdl @@ -1,70 +1,70 @@ -entity step1_read_print is -end entity step1_read_print; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; - -architecture test of step1_read_print is - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - procedure EVAL(ast: inout mal_val_ptr; env: in string; result: out mal_val_ptr) is - begin - result := ast; - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure REP(str: in string; result: out line; err: out mal_val_ptr) is - variable ast, eval_res, read_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, "", eval_res); - mal_PRINT(eval_res, result); - end procedure REP; - - procedure repl is - variable is_eof: boolean; - variable input_line, result: line; - variable err: mal_val_ptr; - begin - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step1_read_print is +end entity step1_read_print; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; + +architecture test of step1_read_print is + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + procedure EVAL(ast: inout mal_val_ptr; env: in string; result: out mal_val_ptr) is + begin + result := ast; + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure REP(str: in string; result: out line; err: out mal_val_ptr) is + variable ast, eval_res, read_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, "", eval_res); + mal_PRINT(eval_res, result); + end procedure REP; + + procedure repl is + variable is_eof: boolean; + variable input_line, result: line; + variable err: mal_val_ptr; + begin + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/step2_eval.vhdl b/impls/vhdl/step2_eval.vhdl index 0a643f4da6..b2eaf135be 100644 --- a/impls/vhdl/step2_eval.vhdl +++ b/impls/vhdl/step2_eval.vhdl @@ -1,167 +1,167 @@ -entity step2_eval is -end entity step2_eval; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; - -architecture test of step2_eval is - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - -- Forward declaration - procedure EVAL(ast: inout mal_val_ptr; env: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr) is - variable num_result: integer; - variable a: mal_seq_ptr; - begin - a := args.seq_val; - if func_sym.string_val.all = "+" then - new_number(a(0).number_val + a(1).number_val, result); - elsif func_sym.string_val.all = "-" then - new_number(a(0).number_val - a(1).number_val, result); - elsif func_sym.string_val.all = "*" then - new_number(a(0).number_val * a(1).number_val, result); - elsif func_sym.string_val.all = "/" then - new_number(a(0).number_val / a(1).number_val, result); - else - result := null; - end if; - end procedure eval_native_func; - - procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout mal_val_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is - variable eval_err: mal_val_ptr; - begin - result := new mal_seq(0 to ast_seq'length - 1); - for i in result'range loop - EVAL(ast_seq(i), env, result(i), eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - end loop; - end procedure eval_ast_seq; - - procedure eval_ast(ast: inout mal_val_ptr; env: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable key, val, eval_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - case ast.val_type is - when mal_symbol => - new_string(ast.string_val, key); - hashmap_get(env, key, val); - if val = null then - new_string("'" & ast.string_val.all & "' not found", err); - return; - end if; - result := val; - return; - when mal_list | mal_vector | mal_hashmap => - eval_ast_seq(ast.seq_val, env, new_seq, eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - new_seq_obj(ast.val_type, new_seq, result); - return; - when others => - result := ast; - return; - end case; - end procedure eval_ast; - - procedure EVAL(ast: inout mal_val_ptr; env: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable a, call_args, sub_err: mal_val_ptr; - begin - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - - if ast.seq_val'length = 0 then - result := ast; - return; - end if; - - eval_ast(ast, env, a, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - seq_drop_prefix(a, 1, call_args); - eval_native_func(a.seq_val(0), call_args, result); - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure REP(str: in string; env: inout mal_val_ptr; result: out line; err: out mal_val_ptr) is - variable ast, eval_res, read_err, eval_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, env, eval_res, eval_err); - if eval_err /= null then - err := eval_err; - result := null; - return; - end if; - mal_PRINT(eval_res, result); - end procedure REP; - - procedure repl is - variable is_eof: boolean; - variable input_line, result: line; - variable repl_seq: mal_seq_ptr; - variable repl_env, err: mal_val_ptr; - begin - repl_seq := new mal_seq(0 to 7); - new_string("+", repl_seq(0)); - new_nativefn("+", repl_seq(1)); - new_string("-", repl_seq(2)); - new_nativefn("-", repl_seq(3)); - new_string("*", repl_seq(4)); - new_nativefn("*", repl_seq(5)); - new_string("/", repl_seq(6)); - new_nativefn("/", repl_seq(7)); - new_seq_obj(mal_hashmap, repl_seq, repl_env); - - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, repl_env, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step2_eval is +end entity step2_eval; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; + +architecture test of step2_eval is + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + -- Forward declaration + procedure EVAL(ast: inout mal_val_ptr; env: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr) is + variable num_result: integer; + variable a: mal_seq_ptr; + begin + a := args.seq_val; + if func_sym.string_val.all = "+" then + new_number(a(0).number_val + a(1).number_val, result); + elsif func_sym.string_val.all = "-" then + new_number(a(0).number_val - a(1).number_val, result); + elsif func_sym.string_val.all = "*" then + new_number(a(0).number_val * a(1).number_val, result); + elsif func_sym.string_val.all = "/" then + new_number(a(0).number_val / a(1).number_val, result); + else + result := null; + end if; + end procedure eval_native_func; + + procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout mal_val_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is + variable eval_err: mal_val_ptr; + begin + result := new mal_seq(0 to ast_seq'length - 1); + for i in result'range loop + EVAL(ast_seq(i), env, result(i), eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + end loop; + end procedure eval_ast_seq; + + procedure eval_ast(ast: inout mal_val_ptr; env: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable key, val, eval_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + case ast.val_type is + when mal_symbol => + new_string(ast.string_val, key); + hashmap_get(env, key, val); + if val = null then + new_string("'" & ast.string_val.all & "' not found", err); + return; + end if; + result := val; + return; + when mal_list | mal_vector | mal_hashmap => + eval_ast_seq(ast.seq_val, env, new_seq, eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + new_seq_obj(ast.val_type, new_seq, result); + return; + when others => + result := ast; + return; + end case; + end procedure eval_ast; + + procedure EVAL(ast: inout mal_val_ptr; env: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable a, call_args, sub_err: mal_val_ptr; + begin + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + + if ast.seq_val'length = 0 then + result := ast; + return; + end if; + + eval_ast(ast, env, a, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + seq_drop_prefix(a, 1, call_args); + eval_native_func(a.seq_val(0), call_args, result); + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure REP(str: in string; env: inout mal_val_ptr; result: out line; err: out mal_val_ptr) is + variable ast, eval_res, read_err, eval_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, env, eval_res, eval_err); + if eval_err /= null then + err := eval_err; + result := null; + return; + end if; + mal_PRINT(eval_res, result); + end procedure REP; + + procedure repl is + variable is_eof: boolean; + variable input_line, result: line; + variable repl_seq: mal_seq_ptr; + variable repl_env, err: mal_val_ptr; + begin + repl_seq := new mal_seq(0 to 7); + new_string("+", repl_seq(0)); + new_nativefn("+", repl_seq(1)); + new_string("-", repl_seq(2)); + new_nativefn("-", repl_seq(3)); + new_string("*", repl_seq(4)); + new_nativefn("*", repl_seq(5)); + new_string("/", repl_seq(6)); + new_nativefn("/", repl_seq(7)); + new_seq_obj(mal_hashmap, repl_seq, repl_env); + + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, repl_env, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/step3_env.vhdl b/impls/vhdl/step3_env.vhdl index 3542ff1c82..03973c3ce6 100644 --- a/impls/vhdl/step3_env.vhdl +++ b/impls/vhdl/step3_env.vhdl @@ -1,200 +1,200 @@ -entity step3_env is -end entity step3_env; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; -use WORK.env.all; - -architecture test of step3_env is - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - -- Forward declaration - procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr) is - variable num_result: integer; - variable a: mal_seq_ptr; - begin - a := args.seq_val; - if func_sym.string_val.all = "+" then - new_number(a(0).number_val + a(1).number_val, result); - elsif func_sym.string_val.all = "-" then - new_number(a(0).number_val - a(1).number_val, result); - elsif func_sym.string_val.all = "*" then - new_number(a(0).number_val * a(1).number_val, result); - elsif func_sym.string_val.all = "/" then - new_number(a(0).number_val / a(1).number_val, result); - else - result := null; - end if; - end procedure eval_native_func; - - procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is - variable eval_err: mal_val_ptr; - begin - result := new mal_seq(0 to ast_seq'length - 1); - for i in result'range loop - EVAL(ast_seq(i), env, result(i), eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - end loop; - end procedure eval_ast_seq; - - procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable key, val, eval_err, env_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - case ast.val_type is - when mal_symbol => - env_get(env, ast, val, env_err); - if env_err /= null then - err := env_err; - return; - end if; - result := val; - return; - when mal_list | mal_vector | mal_hashmap => - eval_ast_seq(ast.seq_val, env, new_seq, eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - new_seq_obj(ast.val_type, new_seq, result); - return; - when others => - result := ast; - return; - end case; - end procedure eval_ast; - - procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable i: integer; - variable evaled_ast, a0, call_args, val, vars, sub_err: mal_val_ptr; - variable let_env: env_ptr; - begin - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - - if ast.seq_val'length = 0 then - result := ast; - return; - end if; - - a0 := ast.seq_val(0); - if a0.string_val.all = "def!" then - EVAL(ast.seq_val(2), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(env, ast.seq_val(1), val); - result := val; - elsif a0.string_val.all = "let*" then - vars := ast.seq_val(1); - new_env(let_env, env); - i := 0; - while i < vars.seq_val'length loop - EVAL(vars.seq_val(i + 1), let_env, val, sub_err); - if sub_err /= null then - err := sub_err; - deallocate(let_env); - return; - end if; - env_set(let_env, vars.seq_val(i), val); - i := i + 2; - end loop; - EVAL(ast.seq_val(2), let_env, result, err); - deallocate(let_env); - else - eval_ast(ast, env, evaled_ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - seq_drop_prefix(evaled_ast, 1, call_args); - eval_native_func(a0, call_args, result); - end if; - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is - variable ast, eval_res, read_err, eval_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, env, eval_res, eval_err); - if eval_err /= null then - err := eval_err; - result := null; - return; - end if; - mal_PRINT(eval_res, result); - end procedure REP; - - procedure repl is - variable is_eof: boolean; - variable input_line, result: line; - variable sym, fn, err: mal_val_ptr; - variable outer, repl_env: env_ptr; - begin - outer := null; - new_env(repl_env, outer); - new_symbol("+", sym); - new_nativefn("+", fn); - env_set(repl_env, sym, fn); - new_symbol("-", sym); - new_nativefn("-", fn); - env_set(repl_env, sym, fn); - new_symbol("*", sym); - new_nativefn("*", fn); - env_set(repl_env, sym, fn); - new_symbol("/", sym); - new_nativefn("/", fn); - env_set(repl_env, sym, fn); - - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, repl_env, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step3_env is +end entity step3_env; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; +use WORK.env.all; + +architecture test of step3_env is + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + -- Forward declaration + procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure eval_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr) is + variable num_result: integer; + variable a: mal_seq_ptr; + begin + a := args.seq_val; + if func_sym.string_val.all = "+" then + new_number(a(0).number_val + a(1).number_val, result); + elsif func_sym.string_val.all = "-" then + new_number(a(0).number_val - a(1).number_val, result); + elsif func_sym.string_val.all = "*" then + new_number(a(0).number_val * a(1).number_val, result); + elsif func_sym.string_val.all = "/" then + new_number(a(0).number_val / a(1).number_val, result); + else + result := null; + end if; + end procedure eval_native_func; + + procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is + variable eval_err: mal_val_ptr; + begin + result := new mal_seq(0 to ast_seq'length - 1); + for i in result'range loop + EVAL(ast_seq(i), env, result(i), eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + end loop; + end procedure eval_ast_seq; + + procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable key, val, eval_err, env_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + case ast.val_type is + when mal_symbol => + env_get(env, ast, val, env_err); + if env_err /= null then + err := env_err; + return; + end if; + result := val; + return; + when mal_list | mal_vector | mal_hashmap => + eval_ast_seq(ast.seq_val, env, new_seq, eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + new_seq_obj(ast.val_type, new_seq, result); + return; + when others => + result := ast; + return; + end case; + end procedure eval_ast; + + procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable i: integer; + variable evaled_ast, a0, call_args, val, vars, sub_err: mal_val_ptr; + variable let_env: env_ptr; + begin + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + + if ast.seq_val'length = 0 then + result := ast; + return; + end if; + + a0 := ast.seq_val(0); + if a0.string_val.all = "def!" then + EVAL(ast.seq_val(2), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(env, ast.seq_val(1), val); + result := val; + elsif a0.string_val.all = "let*" then + vars := ast.seq_val(1); + new_env(let_env, env); + i := 0; + while i < vars.seq_val'length loop + EVAL(vars.seq_val(i + 1), let_env, val, sub_err); + if sub_err /= null then + err := sub_err; + deallocate(let_env); + return; + end if; + env_set(let_env, vars.seq_val(i), val); + i := i + 2; + end loop; + EVAL(ast.seq_val(2), let_env, result, err); + deallocate(let_env); + else + eval_ast(ast, env, evaled_ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + seq_drop_prefix(evaled_ast, 1, call_args); + eval_native_func(a0, call_args, result); + end if; + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is + variable ast, eval_res, read_err, eval_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, env, eval_res, eval_err); + if eval_err /= null then + err := eval_err; + result := null; + return; + end if; + mal_PRINT(eval_res, result); + end procedure REP; + + procedure repl is + variable is_eof: boolean; + variable input_line, result: line; + variable sym, fn, err: mal_val_ptr; + variable outer, repl_env: env_ptr; + begin + outer := null; + new_env(repl_env, outer); + new_symbol("+", sym); + new_nativefn("+", fn); + env_set(repl_env, sym, fn); + new_symbol("-", sym); + new_nativefn("-", fn); + env_set(repl_env, sym, fn); + new_symbol("*", sym); + new_nativefn("*", fn); + env_set(repl_env, sym, fn); + new_symbol("/", sym); + new_nativefn("/", fn); + env_set(repl_env, sym, fn); + + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, repl_env, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/step4_if_fn_do.vhdl b/impls/vhdl/step4_if_fn_do.vhdl index d28101a6be..31c3c3c172 100644 --- a/impls/vhdl/step4_if_fn_do.vhdl +++ b/impls/vhdl/step4_if_fn_do.vhdl @@ -1,227 +1,227 @@ -entity step4_if_fn_do is -end entity step4_if_fn_do; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; -use WORK.env.all; -use WORK.core.all; - -architecture test of step4_if_fn_do is - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - -- Forward declaration - procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is - variable eval_err: mal_val_ptr; - begin - result := new mal_seq(0 to ast_seq'length - 1); - for i in result'range loop - EVAL(ast_seq(i), env, result(i), eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - end loop; - end procedure eval_ast_seq; - - procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable key, val, eval_err, env_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - case ast.val_type is - when mal_symbol => - env_get(env, ast, val, env_err); - if env_err /= null then - err := env_err; - return; - end if; - result := val; - return; - when mal_list | mal_vector | mal_hashmap => - eval_ast_seq(ast.seq_val, env, new_seq, eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - new_seq_obj(ast.val_type, new_seq, result); - return; - when others => - result := ast; - return; - end case; - end procedure eval_ast; - - procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable i: integer; - variable evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; - variable let_env, fn_env: env_ptr; - begin - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - - if ast.seq_val'length = 0 then - result := ast; - return; - end if; - - a0 := ast.seq_val(0); - if a0.val_type = mal_symbol then - if a0.string_val.all = "def!" then - EVAL(ast.seq_val(2), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "let*" then - vars := ast.seq_val(1); - new_env(let_env, env); - i := 0; - while i < vars.seq_val'length loop - EVAL(vars.seq_val(i + 1), let_env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(let_env, vars.seq_val(i), val); - i := i + 2; - end loop; - EVAL(ast.seq_val(2), let_env, result, err); - return; - - elsif a0.string_val.all = "do" then - for i in 1 to ast.seq_val'high loop - EVAL(ast.seq_val(i), env, result, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - end loop; - return; - - elsif a0.string_val.all = "if" then - EVAL(ast.seq_val(1), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if val.val_type = mal_nil or val.val_type = mal_false then - if ast.seq_val'length > 3 then - EVAL(ast.seq_val(3), env, result, err); - else - new_nil(result); - end if; - else - EVAL(ast.seq_val(2), env, result, err); - end if; - return; - - elsif a0.string_val.all = "fn*" then - new_fn(ast.seq_val(2), ast.seq_val(1), env, result); - return; - - end if; - end if; - - eval_ast(ast, env, evaled_ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - seq_drop_prefix(evaled_ast, 1, call_args); - fn := evaled_ast.seq_val(0); - case fn.val_type is - when mal_nativefn => - eval_native_func(fn, call_args, result, err); - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); - EVAL(fn.func_val.f_body, fn_env, result, err); - when others => - new_string("not a function", err); - end case; - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, read_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, env, result, err); - end procedure RE; - - procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is - variable eval_res, eval_err: mal_val_ptr; - begin - RE(str, env, eval_res, eval_err); - if eval_err /= null then - err := eval_err; - result := null; - return; - end if; - mal_PRINT(eval_res, result); - end procedure REP; - - procedure repl is - variable is_eof: boolean; - variable input_line, result: line; - variable dummy_val, err: mal_val_ptr; - variable outer, repl_env: env_ptr; - begin - outer := null; - new_env(repl_env, outer); - - -- core.EXT: defined using VHDL (see core.vhdl) - define_core_functions(repl_env); - - -- core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); - - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, repl_env, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step4_if_fn_do is +end entity step4_if_fn_do; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; +use WORK.env.all; +use WORK.core.all; + +architecture test of step4_if_fn_do is + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + -- Forward declaration + procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is + variable eval_err: mal_val_ptr; + begin + result := new mal_seq(0 to ast_seq'length - 1); + for i in result'range loop + EVAL(ast_seq(i), env, result(i), eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + end loop; + end procedure eval_ast_seq; + + procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable key, val, eval_err, env_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + case ast.val_type is + when mal_symbol => + env_get(env, ast, val, env_err); + if env_err /= null then + err := env_err; + return; + end if; + result := val; + return; + when mal_list | mal_vector | mal_hashmap => + eval_ast_seq(ast.seq_val, env, new_seq, eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + new_seq_obj(ast.val_type, new_seq, result); + return; + when others => + result := ast; + return; + end case; + end procedure eval_ast; + + procedure EVAL(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable i: integer; + variable evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; + variable let_env, fn_env: env_ptr; + begin + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + + if ast.seq_val'length = 0 then + result := ast; + return; + end if; + + a0 := ast.seq_val(0); + if a0.val_type = mal_symbol then + if a0.string_val.all = "def!" then + EVAL(ast.seq_val(2), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "let*" then + vars := ast.seq_val(1); + new_env(let_env, env); + i := 0; + while i < vars.seq_val'length loop + EVAL(vars.seq_val(i + 1), let_env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(let_env, vars.seq_val(i), val); + i := i + 2; + end loop; + EVAL(ast.seq_val(2), let_env, result, err); + return; + + elsif a0.string_val.all = "do" then + for i in 1 to ast.seq_val'high loop + EVAL(ast.seq_val(i), env, result, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + end loop; + return; + + elsif a0.string_val.all = "if" then + EVAL(ast.seq_val(1), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if val.val_type = mal_nil or val.val_type = mal_false then + if ast.seq_val'length > 3 then + EVAL(ast.seq_val(3), env, result, err); + else + new_nil(result); + end if; + else + EVAL(ast.seq_val(2), env, result, err); + end if; + return; + + elsif a0.string_val.all = "fn*" then + new_fn(ast.seq_val(2), ast.seq_val(1), env, result); + return; + + end if; + end if; + + eval_ast(ast, env, evaled_ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + seq_drop_prefix(evaled_ast, 1, call_args); + fn := evaled_ast.seq_val(0); + case fn.val_type is + when mal_nativefn => + eval_native_func(fn, call_args, result, err); + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); + EVAL(fn.func_val.f_body, fn_env, result, err); + when others => + new_string("not a function", err); + end case; + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, read_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, env, result, err); + end procedure RE; + + procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is + variable eval_res, eval_err: mal_val_ptr; + begin + RE(str, env, eval_res, eval_err); + if eval_err /= null then + err := eval_err; + result := null; + return; + end if; + mal_PRINT(eval_res, result); + end procedure REP; + + procedure repl is + variable is_eof: boolean; + variable input_line, result: line; + variable dummy_val, err: mal_val_ptr; + variable outer, repl_env: env_ptr; + begin + outer := null; + new_env(repl_env, outer); + + -- core.EXT: defined using VHDL (see core.vhdl) + define_core_functions(repl_env); + + -- core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); + + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, repl_env, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/step5_tco.vhdl b/impls/vhdl/step5_tco.vhdl index 6f8f030b6b..f4cb229f1a 100644 --- a/impls/vhdl/step5_tco.vhdl +++ b/impls/vhdl/step5_tco.vhdl @@ -1,238 +1,238 @@ -entity step5_tco is -end entity step5_tco; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; -use WORK.env.all; -use WORK.core.all; - -architecture test of step5_tco is - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - -- Forward declaration - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is - variable eval_err: mal_val_ptr; - begin - result := new mal_seq(0 to ast_seq'length - 1); - for i in result'range loop - EVAL(ast_seq(i), env, result(i), eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - end loop; - end procedure eval_ast_seq; - - procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable key, val, eval_err, env_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - case ast.val_type is - when mal_symbol => - env_get(env, ast, val, env_err); - if env_err /= null then - err := env_err; - return; - end if; - result := val; - return; - when mal_list | mal_vector | mal_hashmap => - eval_ast_seq(ast.seq_val, env, new_seq, eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - new_seq_obj(ast.val_type, new_seq, result); - return; - when others => - result := ast; - return; - end case; - end procedure eval_ast; - - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable i: integer; - variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; - variable env, let_env, fn_env: env_ptr; - begin - ast := in_ast; - env := in_env; - loop - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - - if ast.seq_val'length = 0 then - result := ast; - return; - end if; - - a0 := ast.seq_val(0); - if a0.val_type = mal_symbol then - if a0.string_val.all = "def!" then - EVAL(ast.seq_val(2), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "let*" then - vars := ast.seq_val(1); - new_env(let_env, env); - i := 0; - while i < vars.seq_val'length loop - EVAL(vars.seq_val(i + 1), let_env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(let_env, vars.seq_val(i), val); - i := i + 2; - end loop; - env := let_env; - ast := ast.seq_val(2); - next; -- TCO - - elsif a0.string_val.all = "do" then - for i in 1 to ast.seq_val'high - 1 loop - EVAL(ast.seq_val(i), env, result, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - end loop; - ast := ast.seq_val(ast.seq_val'high); - next; -- TCO - - elsif a0.string_val.all = "if" then - EVAL(ast.seq_val(1), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if val.val_type = mal_nil or val.val_type = mal_false then - if ast.seq_val'length > 3 then - ast := ast.seq_val(3); - else - new_nil(result); - return; - end if; - else - ast := ast.seq_val(2); - end if; - next; -- TCO - - elsif a0.string_val.all = "fn*" then - new_fn(ast.seq_val(2), ast.seq_val(1), env, result); - return; - - end if; - end if; - - eval_ast(ast, env, evaled_ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - seq_drop_prefix(evaled_ast, 1, call_args); - fn := evaled_ast.seq_val(0); - case fn.val_type is - when mal_nativefn => - eval_native_func(fn, call_args, result, err); - return; - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); - env := fn_env; - ast := fn.func_val.f_body; - next; -- TCO - when others => - new_string("not a function", err); - return; - end case; - end loop; - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, read_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, env, result, err); - end procedure RE; - - procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is - variable eval_res, eval_err: mal_val_ptr; - begin - RE(str, env, eval_res, eval_err); - if eval_err /= null then - err := eval_err; - result := null; - return; - end if; - mal_PRINT(eval_res, result); - end procedure REP; - - procedure repl is - variable is_eof: boolean; - variable input_line, result: line; - variable dummy_val, err: mal_val_ptr; - variable outer, repl_env: env_ptr; - begin - outer := null; - new_env(repl_env, outer); - - -- core.EXT: defined using VHDL (see core.vhdl) - define_core_functions(repl_env); - - -- core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); - - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, repl_env, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step5_tco is +end entity step5_tco; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; +use WORK.env.all; +use WORK.core.all; + +architecture test of step5_tco is + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + -- Forward declaration + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is + variable eval_err: mal_val_ptr; + begin + result := new mal_seq(0 to ast_seq'length - 1); + for i in result'range loop + EVAL(ast_seq(i), env, result(i), eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + end loop; + end procedure eval_ast_seq; + + procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable key, val, eval_err, env_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + case ast.val_type is + when mal_symbol => + env_get(env, ast, val, env_err); + if env_err /= null then + err := env_err; + return; + end if; + result := val; + return; + when mal_list | mal_vector | mal_hashmap => + eval_ast_seq(ast.seq_val, env, new_seq, eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + new_seq_obj(ast.val_type, new_seq, result); + return; + when others => + result := ast; + return; + end case; + end procedure eval_ast; + + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable i: integer; + variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; + variable env, let_env, fn_env: env_ptr; + begin + ast := in_ast; + env := in_env; + loop + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + + if ast.seq_val'length = 0 then + result := ast; + return; + end if; + + a0 := ast.seq_val(0); + if a0.val_type = mal_symbol then + if a0.string_val.all = "def!" then + EVAL(ast.seq_val(2), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "let*" then + vars := ast.seq_val(1); + new_env(let_env, env); + i := 0; + while i < vars.seq_val'length loop + EVAL(vars.seq_val(i + 1), let_env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(let_env, vars.seq_val(i), val); + i := i + 2; + end loop; + env := let_env; + ast := ast.seq_val(2); + next; -- TCO + + elsif a0.string_val.all = "do" then + for i in 1 to ast.seq_val'high - 1 loop + EVAL(ast.seq_val(i), env, result, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + end loop; + ast := ast.seq_val(ast.seq_val'high); + next; -- TCO + + elsif a0.string_val.all = "if" then + EVAL(ast.seq_val(1), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if val.val_type = mal_nil or val.val_type = mal_false then + if ast.seq_val'length > 3 then + ast := ast.seq_val(3); + else + new_nil(result); + return; + end if; + else + ast := ast.seq_val(2); + end if; + next; -- TCO + + elsif a0.string_val.all = "fn*" then + new_fn(ast.seq_val(2), ast.seq_val(1), env, result); + return; + + end if; + end if; + + eval_ast(ast, env, evaled_ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + seq_drop_prefix(evaled_ast, 1, call_args); + fn := evaled_ast.seq_val(0); + case fn.val_type is + when mal_nativefn => + eval_native_func(fn, call_args, result, err); + return; + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); + env := fn_env; + ast := fn.func_val.f_body; + next; -- TCO + when others => + new_string("not a function", err); + return; + end case; + end loop; + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, read_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, env, result, err); + end procedure RE; + + procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is + variable eval_res, eval_err: mal_val_ptr; + begin + RE(str, env, eval_res, eval_err); + if eval_err /= null then + err := eval_err; + result := null; + return; + end if; + mal_PRINT(eval_res, result); + end procedure REP; + + procedure repl is + variable is_eof: boolean; + variable input_line, result: line; + variable dummy_val, err: mal_val_ptr; + variable outer, repl_env: env_ptr; + begin + outer := null; + new_env(repl_env, outer); + + -- core.EXT: defined using VHDL (see core.vhdl) + define_core_functions(repl_env); + + -- core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); + + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, repl_env, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/step6_file.vhdl b/impls/vhdl/step6_file.vhdl index 2bcb3fbcec..b6dc788c41 100644 --- a/impls/vhdl/step6_file.vhdl +++ b/impls/vhdl/step6_file.vhdl @@ -1,332 +1,332 @@ -entity step6_file is -end entity step6_file; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; -use WORK.env.all; -use WORK.core.all; - -architecture test of step6_file is - - shared variable repl_env: env_ptr; - - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - -- Forward declaration - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - EVAL(args.seq_val(0), repl_env, result, err); - end procedure fn_eval; - - procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable atom: mal_val_ptr := args.seq_val(0); - variable fn: mal_val_ptr := args.seq_val(1); - variable call_args_seq: mal_seq_ptr; - variable call_args, eval_res, sub_err: mal_val_ptr; - begin - call_args_seq := new mal_seq(0 to args.seq_val'length - 2); - call_args_seq(0) := atom.seq_val(0); - call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); - new_seq_obj(mal_list, call_args_seq, call_args); - apply_func(fn, call_args, eval_res, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - atom.seq_val(0) := eval_res; - result := eval_res; - end procedure fn_swap; - - procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - if func_sym.string_val.all = "eval" then - fn_eval(args, result, err); - elsif func_sym.string_val.all = "swap!" then - fn_swap(args, result, err); - else - eval_native_func(func_sym, args, result, err); - end if; - end procedure apply_native_func; - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable fn_env: env_ptr; - begin - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, args, result, err); - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); - EVAL(fn.func_val.f_body, fn_env, result, err); - when others => - new_string("not a function", err); - return; - end case; - end procedure apply_func; - - procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is - variable eval_err: mal_val_ptr; - begin - result := new mal_seq(0 to ast_seq'length - 1); - for i in result'range loop - EVAL(ast_seq(i), env, result(i), eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - end loop; - end procedure eval_ast_seq; - - procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable key, val, eval_err, env_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - case ast.val_type is - when mal_symbol => - env_get(env, ast, val, env_err); - if env_err /= null then - err := env_err; - return; - end if; - result := val; - return; - when mal_list | mal_vector | mal_hashmap => - eval_ast_seq(ast.seq_val, env, new_seq, eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - new_seq_obj(ast.val_type, new_seq, result); - return; - when others => - result := ast; - return; - end case; - end procedure eval_ast; - - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable i: integer; - variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; - variable env, let_env, fn_env: env_ptr; - begin - ast := in_ast; - env := in_env; - loop - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - - if ast.seq_val'length = 0 then - result := ast; - return; - end if; - - a0 := ast.seq_val(0); - if a0.val_type = mal_symbol then - if a0.string_val.all = "def!" then - EVAL(ast.seq_val(2), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "let*" then - vars := ast.seq_val(1); - new_env(let_env, env); - i := 0; - while i < vars.seq_val'length loop - EVAL(vars.seq_val(i + 1), let_env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(let_env, vars.seq_val(i), val); - i := i + 2; - end loop; - env := let_env; - ast := ast.seq_val(2); - next; -- TCO - - elsif a0.string_val.all = "do" then - for i in 1 to ast.seq_val'high - 1 loop - EVAL(ast.seq_val(i), env, result, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - end loop; - ast := ast.seq_val(ast.seq_val'high); - next; -- TCO - - elsif a0.string_val.all = "if" then - EVAL(ast.seq_val(1), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if val.val_type = mal_nil or val.val_type = mal_false then - if ast.seq_val'length > 3 then - ast := ast.seq_val(3); - else - new_nil(result); - return; - end if; - else - ast := ast.seq_val(2); - end if; - next; -- TCO - - elsif a0.string_val.all = "fn*" then - new_fn(ast.seq_val(2), ast.seq_val(1), env, result); - return; - - end if; - end if; - - eval_ast(ast, env, evaled_ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - seq_drop_prefix(evaled_ast, 1, call_args); - fn := evaled_ast.seq_val(0); - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, call_args, result, err); - return; - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); - env := fn_env; - ast := fn.func_val.f_body; - next; -- TCO - when others => - new_string("not a function", err); - return; - end case; - end loop; - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, read_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, env, result, err); - end procedure RE; - - procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is - variable eval_res, eval_err: mal_val_ptr; - begin - RE(str, env, eval_res, eval_err); - if eval_err /= null then - err := eval_err; - result := null; - return; - end if; - mal_PRINT(eval_res, result); - end procedure REP; - - procedure set_argv(e: inout env_ptr; program_file: inout line) is - variable argv_var_name: string(1 to 6) := "*ARGV*"; - variable argv_sym, argv_list: mal_val_ptr; - file f: text; - variable status: file_open_status; - variable one_line: line; - variable seq: mal_seq_ptr; - variable element: mal_val_ptr; - begin - program_file := null; - seq := new mal_seq(0 to -1); - file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); - if status = open_ok then - if not endfile(f) then - readline(f, program_file); - while not endfile(f) loop - readline(f, one_line); - new_string(one_line.all, element); - seq := new mal_seq'(seq.all & element); - end loop; - end if; - file_close(f); - end if; - new_seq_obj(mal_list, seq, argv_list); - new_symbol(argv_var_name, argv_sym); - env_set(e, argv_sym, argv_list); - end procedure set_argv; - - procedure repl is - variable is_eof: boolean; - variable program_file, input_line, result: line; - variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; - variable outer: env_ptr; - variable eval_func_name: string(1 to 4) := "eval"; - begin - outer := null; - new_env(repl_env, outer); - - -- core.EXT: defined using VHDL (see core.vhdl) - define_core_functions(repl_env); - new_symbol(eval_func_name, eval_sym); - new_nativefn(eval_func_name, eval_fn); - env_set(repl_env, eval_sym, eval_fn); - set_argv(repl_env, program_file); - - -- core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); - RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); - - if program_file /= null then - REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); - return; - end if; - - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, repl_env, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step6_file is +end entity step6_file; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; +use WORK.env.all; +use WORK.core.all; + +architecture test of step6_file is + + shared variable repl_env: env_ptr; + + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + -- Forward declaration + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + EVAL(args.seq_val(0), repl_env, result, err); + end procedure fn_eval; + + procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable atom: mal_val_ptr := args.seq_val(0); + variable fn: mal_val_ptr := args.seq_val(1); + variable call_args_seq: mal_seq_ptr; + variable call_args, eval_res, sub_err: mal_val_ptr; + begin + call_args_seq := new mal_seq(0 to args.seq_val'length - 2); + call_args_seq(0) := atom.seq_val(0); + call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); + new_seq_obj(mal_list, call_args_seq, call_args); + apply_func(fn, call_args, eval_res, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + atom.seq_val(0) := eval_res; + result := eval_res; + end procedure fn_swap; + + procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + if func_sym.string_val.all = "eval" then + fn_eval(args, result, err); + elsif func_sym.string_val.all = "swap!" then + fn_swap(args, result, err); + else + eval_native_func(func_sym, args, result, err); + end if; + end procedure apply_native_func; + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable fn_env: env_ptr; + begin + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, args, result, err); + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); + EVAL(fn.func_val.f_body, fn_env, result, err); + when others => + new_string("not a function", err); + return; + end case; + end procedure apply_func; + + procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is + variable eval_err: mal_val_ptr; + begin + result := new mal_seq(0 to ast_seq'length - 1); + for i in result'range loop + EVAL(ast_seq(i), env, result(i), eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + end loop; + end procedure eval_ast_seq; + + procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable key, val, eval_err, env_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + case ast.val_type is + when mal_symbol => + env_get(env, ast, val, env_err); + if env_err /= null then + err := env_err; + return; + end if; + result := val; + return; + when mal_list | mal_vector | mal_hashmap => + eval_ast_seq(ast.seq_val, env, new_seq, eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + new_seq_obj(ast.val_type, new_seq, result); + return; + when others => + result := ast; + return; + end case; + end procedure eval_ast; + + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable i: integer; + variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; + variable env, let_env, fn_env: env_ptr; + begin + ast := in_ast; + env := in_env; + loop + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + + if ast.seq_val'length = 0 then + result := ast; + return; + end if; + + a0 := ast.seq_val(0); + if a0.val_type = mal_symbol then + if a0.string_val.all = "def!" then + EVAL(ast.seq_val(2), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "let*" then + vars := ast.seq_val(1); + new_env(let_env, env); + i := 0; + while i < vars.seq_val'length loop + EVAL(vars.seq_val(i + 1), let_env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(let_env, vars.seq_val(i), val); + i := i + 2; + end loop; + env := let_env; + ast := ast.seq_val(2); + next; -- TCO + + elsif a0.string_val.all = "do" then + for i in 1 to ast.seq_val'high - 1 loop + EVAL(ast.seq_val(i), env, result, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + end loop; + ast := ast.seq_val(ast.seq_val'high); + next; -- TCO + + elsif a0.string_val.all = "if" then + EVAL(ast.seq_val(1), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if val.val_type = mal_nil or val.val_type = mal_false then + if ast.seq_val'length > 3 then + ast := ast.seq_val(3); + else + new_nil(result); + return; + end if; + else + ast := ast.seq_val(2); + end if; + next; -- TCO + + elsif a0.string_val.all = "fn*" then + new_fn(ast.seq_val(2), ast.seq_val(1), env, result); + return; + + end if; + end if; + + eval_ast(ast, env, evaled_ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + seq_drop_prefix(evaled_ast, 1, call_args); + fn := evaled_ast.seq_val(0); + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, call_args, result, err); + return; + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); + env := fn_env; + ast := fn.func_val.f_body; + next; -- TCO + when others => + new_string("not a function", err); + return; + end case; + end loop; + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, read_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, env, result, err); + end procedure RE; + + procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is + variable eval_res, eval_err: mal_val_ptr; + begin + RE(str, env, eval_res, eval_err); + if eval_err /= null then + err := eval_err; + result := null; + return; + end if; + mal_PRINT(eval_res, result); + end procedure REP; + + procedure set_argv(e: inout env_ptr; program_file: inout line) is + variable argv_var_name: string(1 to 6) := "*ARGV*"; + variable argv_sym, argv_list: mal_val_ptr; + file f: text; + variable status: file_open_status; + variable one_line: line; + variable seq: mal_seq_ptr; + variable element: mal_val_ptr; + begin + program_file := null; + seq := new mal_seq(0 to -1); + file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); + if status = open_ok then + if not endfile(f) then + readline(f, program_file); + while not endfile(f) loop + readline(f, one_line); + new_string(one_line.all, element); + seq := new mal_seq'(seq.all & element); + end loop; + end if; + file_close(f); + end if; + new_seq_obj(mal_list, seq, argv_list); + new_symbol(argv_var_name, argv_sym); + env_set(e, argv_sym, argv_list); + end procedure set_argv; + + procedure repl is + variable is_eof: boolean; + variable program_file, input_line, result: line; + variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; + variable outer: env_ptr; + variable eval_func_name: string(1 to 4) := "eval"; + begin + outer := null; + new_env(repl_env, outer); + + -- core.EXT: defined using VHDL (see core.vhdl) + define_core_functions(repl_env); + new_symbol(eval_func_name, eval_sym); + new_nativefn(eval_func_name, eval_fn); + env_set(repl_env, eval_sym, eval_fn); + set_argv(repl_env, program_file); + + -- core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); + RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); + + if program_file /= null then + REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); + return; + end if; + + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, repl_env, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/step7_quote.vhdl b/impls/vhdl/step7_quote.vhdl index d24b29350d..1022cd3e86 100644 --- a/impls/vhdl/step7_quote.vhdl +++ b/impls/vhdl/step7_quote.vhdl @@ -1,416 +1,416 @@ -entity step7_quote is -end entity step7_quote; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; -use WORK.env.all; -use WORK.core.all; - -architecture test of step7_quote is - - shared variable repl_env: env_ptr; - - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - procedure starts_with(lst : inout mal_val_ptr; - sym : in string; - res : out boolean) is - begin - res := lst.seq_val.all'length = 2 - and lst.seq_val.all (lst.seq_val.all'low).val_type = mal_symbol - and lst.seq_val.all (lst.seq_val.all'low).string_val.all = sym; - end starts_with; - - -- Forward declaration - procedure quasiquote(ast: inout mal_val_ptr; - result: out mal_val_ptr); - - procedure qq_loop(elt : inout mal_val_ptr; - acc : inout mal_val_ptr) is - variable sw : boolean := elt.val_type = mal_list; - variable seq : mal_seq_ptr := new mal_seq(0 to 2); - begin - if sw then - starts_with(elt, "splice-unquote", sw); - end if; - if sw then - new_symbol("concat", seq(0)); - seq(1) := elt.seq_val(1); - else - new_symbol("cons", seq(0)); - quasiquote(elt, seq(1)); - end if; - seq(2) := acc; - new_seq_obj(mal_list, seq, acc); - end qq_loop; - - procedure qq_foldr (xs : inout mal_seq_ptr; - res : out mal_val_ptr) is - variable seq : mal_seq_ptr := new mal_seq(0 to -1); - variable acc : mal_val_ptr; - begin - new_seq_obj(mal_list, seq, acc); - for i in xs'reverse_range loop - qq_loop (xs(i), acc); - end loop; - res := acc; - end procedure qq_foldr; - - procedure quasiquote(ast: inout mal_val_ptr; - result: out mal_val_ptr) is - variable sw : boolean; - variable seq : mal_seq_ptr; - begin - case ast.val_type is - when mal_list => - starts_with(ast, "unquote", sw); - if sw then - result := ast.seq_val(1); - else - qq_foldr(ast.seq_val, result); - end if; - when mal_vector => - seq := new mal_seq(0 to 1); - new_symbol("vec", seq(0)); - qq_foldr(ast.seq_val, seq(1)); - new_seq_obj(mal_list, seq, result); - when mal_symbol | mal_hashmap => - seq := new mal_seq(0 to 1); - new_symbol("quote", seq(0)); - seq(1) := ast; - new_seq_obj(mal_list, seq, result); - when others => - result := ast; - end case; - end procedure quasiquote; - - -- Forward declaration - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - EVAL(args.seq_val(0), repl_env, result, err); - end procedure fn_eval; - - procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable atom: mal_val_ptr := args.seq_val(0); - variable fn: mal_val_ptr := args.seq_val(1); - variable call_args_seq: mal_seq_ptr; - variable call_args, eval_res, sub_err: mal_val_ptr; - begin - call_args_seq := new mal_seq(0 to args.seq_val'length - 2); - call_args_seq(0) := atom.seq_val(0); - call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); - new_seq_obj(mal_list, call_args_seq, call_args); - apply_func(fn, call_args, eval_res, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - atom.seq_val(0) := eval_res; - result := eval_res; - end procedure fn_swap; - - procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - if func_sym.string_val.all = "eval" then - fn_eval(args, result, err); - elsif func_sym.string_val.all = "swap!" then - fn_swap(args, result, err); - else - eval_native_func(func_sym, args, result, err); - end if; - end procedure apply_native_func; - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable fn_env: env_ptr; - begin - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, args, result, err); - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); - EVAL(fn.func_val.f_body, fn_env, result, err); - when others => - new_string("not a function", err); - return; - end case; - end procedure apply_func; - - procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is - variable eval_err: mal_val_ptr; - begin - result := new mal_seq(0 to ast_seq'length - 1); - for i in result'range loop - EVAL(ast_seq(i), env, result(i), eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - end loop; - end procedure eval_ast_seq; - - procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable key, val, eval_err, env_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - case ast.val_type is - when mal_symbol => - env_get(env, ast, val, env_err); - if env_err /= null then - err := env_err; - return; - end if; - result := val; - return; - when mal_list | mal_vector | mal_hashmap => - eval_ast_seq(ast.seq_val, env, new_seq, eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - new_seq_obj(ast.val_type, new_seq, result); - return; - when others => - result := ast; - return; - end case; - end procedure eval_ast; - - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable i: integer; - variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; - variable env, let_env, fn_env: env_ptr; - begin - ast := in_ast; - env := in_env; - loop - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - - if ast.seq_val'length = 0 then - result := ast; - return; - end if; - - a0 := ast.seq_val(0); - if a0.val_type = mal_symbol then - if a0.string_val.all = "def!" then - EVAL(ast.seq_val(2), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "let*" then - vars := ast.seq_val(1); - new_env(let_env, env); - i := 0; - while i < vars.seq_val'length loop - EVAL(vars.seq_val(i + 1), let_env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(let_env, vars.seq_val(i), val); - i := i + 2; - end loop; - env := let_env; - ast := ast.seq_val(2); - next; -- TCO - - elsif a0.string_val.all = "quote" then - result := ast.seq_val(1); - return; - - elsif a0.string_val.all = "quasiquoteexpand" then - quasiquote(ast.seq_val(1), result); - return; - - elsif a0.string_val.all = "quasiquote" then - quasiquote(ast.seq_val(1), ast); - next; -- TCO - - elsif a0.string_val.all = "do" then - for i in 1 to ast.seq_val'high - 1 loop - EVAL(ast.seq_val(i), env, result, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - end loop; - ast := ast.seq_val(ast.seq_val'high); - next; -- TCO - - elsif a0.string_val.all = "if" then - EVAL(ast.seq_val(1), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if val.val_type = mal_nil or val.val_type = mal_false then - if ast.seq_val'length > 3 then - ast := ast.seq_val(3); - else - new_nil(result); - return; - end if; - else - ast := ast.seq_val(2); - end if; - next; -- TCO - - elsif a0.string_val.all = "fn*" then - new_fn(ast.seq_val(2), ast.seq_val(1), env, result); - return; - - end if; - end if; - - eval_ast(ast, env, evaled_ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - seq_drop_prefix(evaled_ast, 1, call_args); - fn := evaled_ast.seq_val(0); - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, call_args, result, err); - return; - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); - env := fn_env; - ast := fn.func_val.f_body; - next; -- TCO - when others => - new_string("not a function", err); - return; - end case; - end loop; - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, read_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, env, result, err); - end procedure RE; - - procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is - variable eval_res, eval_err: mal_val_ptr; - begin - RE(str, env, eval_res, eval_err); - if eval_err /= null then - err := eval_err; - result := null; - return; - end if; - mal_PRINT(eval_res, result); - end procedure REP; - - procedure set_argv(e: inout env_ptr; program_file: inout line) is - variable argv_var_name: string(1 to 6) := "*ARGV*"; - variable argv_sym, argv_list: mal_val_ptr; - file f: text; - variable status: file_open_status; - variable one_line: line; - variable seq: mal_seq_ptr; - variable element: mal_val_ptr; - begin - program_file := null; - seq := new mal_seq(0 to -1); - file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); - if status = open_ok then - if not endfile(f) then - readline(f, program_file); - while not endfile(f) loop - readline(f, one_line); - new_string(one_line.all, element); - seq := new mal_seq'(seq.all & element); - end loop; - end if; - file_close(f); - end if; - new_seq_obj(mal_list, seq, argv_list); - new_symbol(argv_var_name, argv_sym); - env_set(e, argv_sym, argv_list); - end procedure set_argv; - - procedure repl is - variable is_eof: boolean; - variable program_file, input_line, result: line; - variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; - variable outer: env_ptr; - variable eval_func_name: string(1 to 4) := "eval"; - begin - outer := null; - new_env(repl_env, outer); - - -- core.EXT: defined using VHDL (see core.vhdl) - define_core_functions(repl_env); - new_symbol(eval_func_name, eval_sym); - new_nativefn(eval_func_name, eval_fn); - env_set(repl_env, eval_sym, eval_fn); - set_argv(repl_env, program_file); - - -- core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); - RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); - - if program_file /= null then - REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); - return; - end if; - - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, repl_env, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step7_quote is +end entity step7_quote; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; +use WORK.env.all; +use WORK.core.all; + +architecture test of step7_quote is + + shared variable repl_env: env_ptr; + + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + procedure starts_with(lst : inout mal_val_ptr; + sym : in string; + res : out boolean) is + begin + res := lst.seq_val.all'length = 2 + and lst.seq_val.all (lst.seq_val.all'low).val_type = mal_symbol + and lst.seq_val.all (lst.seq_val.all'low).string_val.all = sym; + end starts_with; + + -- Forward declaration + procedure quasiquote(ast: inout mal_val_ptr; + result: out mal_val_ptr); + + procedure qq_loop(elt : inout mal_val_ptr; + acc : inout mal_val_ptr) is + variable sw : boolean := elt.val_type = mal_list; + variable seq : mal_seq_ptr := new mal_seq(0 to 2); + begin + if sw then + starts_with(elt, "splice-unquote", sw); + end if; + if sw then + new_symbol("concat", seq(0)); + seq(1) := elt.seq_val(1); + else + new_symbol("cons", seq(0)); + quasiquote(elt, seq(1)); + end if; + seq(2) := acc; + new_seq_obj(mal_list, seq, acc); + end qq_loop; + + procedure qq_foldr (xs : inout mal_seq_ptr; + res : out mal_val_ptr) is + variable seq : mal_seq_ptr := new mal_seq(0 to -1); + variable acc : mal_val_ptr; + begin + new_seq_obj(mal_list, seq, acc); + for i in xs'reverse_range loop + qq_loop (xs(i), acc); + end loop; + res := acc; + end procedure qq_foldr; + + procedure quasiquote(ast: inout mal_val_ptr; + result: out mal_val_ptr) is + variable sw : boolean; + variable seq : mal_seq_ptr; + begin + case ast.val_type is + when mal_list => + starts_with(ast, "unquote", sw); + if sw then + result := ast.seq_val(1); + else + qq_foldr(ast.seq_val, result); + end if; + when mal_vector => + seq := new mal_seq(0 to 1); + new_symbol("vec", seq(0)); + qq_foldr(ast.seq_val, seq(1)); + new_seq_obj(mal_list, seq, result); + when mal_symbol | mal_hashmap => + seq := new mal_seq(0 to 1); + new_symbol("quote", seq(0)); + seq(1) := ast; + new_seq_obj(mal_list, seq, result); + when others => + result := ast; + end case; + end procedure quasiquote; + + -- Forward declaration + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + EVAL(args.seq_val(0), repl_env, result, err); + end procedure fn_eval; + + procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable atom: mal_val_ptr := args.seq_val(0); + variable fn: mal_val_ptr := args.seq_val(1); + variable call_args_seq: mal_seq_ptr; + variable call_args, eval_res, sub_err: mal_val_ptr; + begin + call_args_seq := new mal_seq(0 to args.seq_val'length - 2); + call_args_seq(0) := atom.seq_val(0); + call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); + new_seq_obj(mal_list, call_args_seq, call_args); + apply_func(fn, call_args, eval_res, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + atom.seq_val(0) := eval_res; + result := eval_res; + end procedure fn_swap; + + procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + if func_sym.string_val.all = "eval" then + fn_eval(args, result, err); + elsif func_sym.string_val.all = "swap!" then + fn_swap(args, result, err); + else + eval_native_func(func_sym, args, result, err); + end if; + end procedure apply_native_func; + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable fn_env: env_ptr; + begin + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, args, result, err); + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); + EVAL(fn.func_val.f_body, fn_env, result, err); + when others => + new_string("not a function", err); + return; + end case; + end procedure apply_func; + + procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is + variable eval_err: mal_val_ptr; + begin + result := new mal_seq(0 to ast_seq'length - 1); + for i in result'range loop + EVAL(ast_seq(i), env, result(i), eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + end loop; + end procedure eval_ast_seq; + + procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable key, val, eval_err, env_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + case ast.val_type is + when mal_symbol => + env_get(env, ast, val, env_err); + if env_err /= null then + err := env_err; + return; + end if; + result := val; + return; + when mal_list | mal_vector | mal_hashmap => + eval_ast_seq(ast.seq_val, env, new_seq, eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + new_seq_obj(ast.val_type, new_seq, result); + return; + when others => + result := ast; + return; + end case; + end procedure eval_ast; + + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable i: integer; + variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; + variable env, let_env, fn_env: env_ptr; + begin + ast := in_ast; + env := in_env; + loop + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + + if ast.seq_val'length = 0 then + result := ast; + return; + end if; + + a0 := ast.seq_val(0); + if a0.val_type = mal_symbol then + if a0.string_val.all = "def!" then + EVAL(ast.seq_val(2), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "let*" then + vars := ast.seq_val(1); + new_env(let_env, env); + i := 0; + while i < vars.seq_val'length loop + EVAL(vars.seq_val(i + 1), let_env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(let_env, vars.seq_val(i), val); + i := i + 2; + end loop; + env := let_env; + ast := ast.seq_val(2); + next; -- TCO + + elsif a0.string_val.all = "quote" then + result := ast.seq_val(1); + return; + + elsif a0.string_val.all = "quasiquoteexpand" then + quasiquote(ast.seq_val(1), result); + return; + + elsif a0.string_val.all = "quasiquote" then + quasiquote(ast.seq_val(1), ast); + next; -- TCO + + elsif a0.string_val.all = "do" then + for i in 1 to ast.seq_val'high - 1 loop + EVAL(ast.seq_val(i), env, result, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + end loop; + ast := ast.seq_val(ast.seq_val'high); + next; -- TCO + + elsif a0.string_val.all = "if" then + EVAL(ast.seq_val(1), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if val.val_type = mal_nil or val.val_type = mal_false then + if ast.seq_val'length > 3 then + ast := ast.seq_val(3); + else + new_nil(result); + return; + end if; + else + ast := ast.seq_val(2); + end if; + next; -- TCO + + elsif a0.string_val.all = "fn*" then + new_fn(ast.seq_val(2), ast.seq_val(1), env, result); + return; + + end if; + end if; + + eval_ast(ast, env, evaled_ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + seq_drop_prefix(evaled_ast, 1, call_args); + fn := evaled_ast.seq_val(0); + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, call_args, result, err); + return; + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); + env := fn_env; + ast := fn.func_val.f_body; + next; -- TCO + when others => + new_string("not a function", err); + return; + end case; + end loop; + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, read_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, env, result, err); + end procedure RE; + + procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is + variable eval_res, eval_err: mal_val_ptr; + begin + RE(str, env, eval_res, eval_err); + if eval_err /= null then + err := eval_err; + result := null; + return; + end if; + mal_PRINT(eval_res, result); + end procedure REP; + + procedure set_argv(e: inout env_ptr; program_file: inout line) is + variable argv_var_name: string(1 to 6) := "*ARGV*"; + variable argv_sym, argv_list: mal_val_ptr; + file f: text; + variable status: file_open_status; + variable one_line: line; + variable seq: mal_seq_ptr; + variable element: mal_val_ptr; + begin + program_file := null; + seq := new mal_seq(0 to -1); + file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); + if status = open_ok then + if not endfile(f) then + readline(f, program_file); + while not endfile(f) loop + readline(f, one_line); + new_string(one_line.all, element); + seq := new mal_seq'(seq.all & element); + end loop; + end if; + file_close(f); + end if; + new_seq_obj(mal_list, seq, argv_list); + new_symbol(argv_var_name, argv_sym); + env_set(e, argv_sym, argv_list); + end procedure set_argv; + + procedure repl is + variable is_eof: boolean; + variable program_file, input_line, result: line; + variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; + variable outer: env_ptr; + variable eval_func_name: string(1 to 4) := "eval"; + begin + outer := null; + new_env(repl_env, outer); + + -- core.EXT: defined using VHDL (see core.vhdl) + define_core_functions(repl_env); + new_symbol(eval_func_name, eval_sym); + new_nativefn(eval_func_name, eval_fn); + env_set(repl_env, eval_sym, eval_fn); + set_argv(repl_env, program_file); + + -- core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); + RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); + + if program_file /= null then + REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); + return; + end if; + + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, repl_env, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/step8_macros.vhdl b/impls/vhdl/step8_macros.vhdl index 8b799ad4d2..abdafab532 100644 --- a/impls/vhdl/step8_macros.vhdl +++ b/impls/vhdl/step8_macros.vhdl @@ -1,476 +1,476 @@ -entity step8_macros is -end entity step8_macros; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; -use WORK.env.all; -use WORK.core.all; - -architecture test of step8_macros is - - shared variable repl_env: env_ptr; - - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - procedure starts_with(lst : inout mal_val_ptr; - sym : in string; - res : out boolean) is - begin - res := lst.seq_val.all'length = 2 - and lst.seq_val.all (lst.seq_val.all'low).val_type = mal_symbol - and lst.seq_val.all (lst.seq_val.all'low).string_val.all = sym; - end starts_with; - - -- Forward declaration - procedure quasiquote(ast: inout mal_val_ptr; - result: out mal_val_ptr); - - procedure qq_loop(elt : inout mal_val_ptr; - acc : inout mal_val_ptr) is - variable sw : boolean := elt.val_type = mal_list; - variable seq : mal_seq_ptr := new mal_seq(0 to 2); - begin - if sw then - starts_with(elt, "splice-unquote", sw); - end if; - if sw then - new_symbol("concat", seq(0)); - seq(1) := elt.seq_val(1); - else - new_symbol("cons", seq(0)); - quasiquote(elt, seq(1)); - end if; - seq(2) := acc; - new_seq_obj(mal_list, seq, acc); - end qq_loop; - - procedure qq_foldr (xs : inout mal_seq_ptr; - res : out mal_val_ptr) is - variable seq : mal_seq_ptr := new mal_seq(0 to -1); - variable acc : mal_val_ptr; - begin - new_seq_obj(mal_list, seq, acc); - for i in xs'reverse_range loop - qq_loop (xs(i), acc); - end loop; - res := acc; - end procedure qq_foldr; - - procedure quasiquote(ast: inout mal_val_ptr; - result: out mal_val_ptr) is - variable sw : boolean; - variable seq : mal_seq_ptr; - begin - case ast.val_type is - when mal_list => - starts_with(ast, "unquote", sw); - if sw then - result := ast.seq_val(1); - else - qq_foldr(ast.seq_val, result); - end if; - when mal_vector => - seq := new mal_seq(0 to 1); - new_symbol("vec", seq(0)); - qq_foldr(ast.seq_val, seq(1)); - new_seq_obj(mal_list, seq, result); - when mal_symbol | mal_hashmap => - seq := new mal_seq(0 to 1); - new_symbol("quote", seq(0)); - seq(1) := ast; - new_seq_obj(mal_list, seq, result); - when others => - result := ast; - end case; - end procedure quasiquote; - - -- Forward declaration - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure is_macro_call(ast: inout mal_val_ptr; env: inout env_ptr; is_macro: out boolean) is - variable f, env_err: mal_val_ptr; - begin - is_macro := false; - if ast.val_type = mal_list and - ast.seq_val'length > 0 and - ast.seq_val(0).val_type = mal_symbol then - env_get(env, ast.seq_val(0), f, env_err); - if env_err = null and f /= null and - f.val_type = mal_fn and f.func_val.f_is_macro then - is_macro := true; - end if; - end if; - end procedure is_macro_call; - - procedure macroexpand(in_ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, macro_fn, call_args, macro_err: mal_val_ptr; - variable is_macro: boolean; - begin - ast := in_ast; - is_macro_call(ast, env, is_macro); - while is_macro loop - env_get(env, ast.seq_val(0), macro_fn, macro_err); - seq_drop_prefix(ast, 1, call_args); - apply_func(macro_fn, call_args, ast, macro_err); - if macro_err /= null then - err := macro_err; - return; - end if; - is_macro_call(ast, env, is_macro); - end loop; - result := ast; - end procedure macroexpand; - - procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - EVAL(args.seq_val(0), repl_env, result, err); - end procedure fn_eval; - - procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable atom: mal_val_ptr := args.seq_val(0); - variable fn: mal_val_ptr := args.seq_val(1); - variable call_args_seq: mal_seq_ptr; - variable call_args, eval_res, sub_err: mal_val_ptr; - begin - call_args_seq := new mal_seq(0 to args.seq_val'length - 2); - call_args_seq(0) := atom.seq_val(0); - call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); - new_seq_obj(mal_list, call_args_seq, call_args); - apply_func(fn, call_args, eval_res, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - atom.seq_val(0) := eval_res; - result := eval_res; - end procedure fn_swap; - - procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - if func_sym.string_val.all = "eval" then - fn_eval(args, result, err); - elsif func_sym.string_val.all = "swap!" then - fn_swap(args, result, err); - else - eval_native_func(func_sym, args, result, err); - end if; - end procedure apply_native_func; - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable fn_env: env_ptr; - begin - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, args, result, err); - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); - EVAL(fn.func_val.f_body, fn_env, result, err); - when others => - new_string("not a function", err); - return; - end case; - end procedure apply_func; - - procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is - variable eval_err: mal_val_ptr; - begin - result := new mal_seq(0 to ast_seq'length - 1); - for i in result'range loop - EVAL(ast_seq(i), env, result(i), eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - end loop; - end procedure eval_ast_seq; - - procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable key, val, eval_err, env_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - case ast.val_type is - when mal_symbol => - env_get(env, ast, val, env_err); - if env_err /= null then - err := env_err; - return; - end if; - result := val; - return; - when mal_list | mal_vector | mal_hashmap => - eval_ast_seq(ast.seq_val, env, new_seq, eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - new_seq_obj(ast.val_type, new_seq, result); - return; - when others => - result := ast; - return; - end case; - end procedure eval_ast; - - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable i: integer; - variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; - variable env, let_env, fn_env: env_ptr; - begin - ast := in_ast; - env := in_env; - loop - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - - macroexpand(ast, env, ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - if ast.seq_val'length = 0 then - result := ast; - return; - end if; - - a0 := ast.seq_val(0); - if a0.val_type = mal_symbol then - if a0.string_val.all = "def!" then - EVAL(ast.seq_val(2), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "let*" then - vars := ast.seq_val(1); - new_env(let_env, env); - i := 0; - while i < vars.seq_val'length loop - EVAL(vars.seq_val(i + 1), let_env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(let_env, vars.seq_val(i), val); - i := i + 2; - end loop; - env := let_env; - ast := ast.seq_val(2); - next; -- TCO - - elsif a0.string_val.all = "quote" then - result := ast.seq_val(1); - return; - - elsif a0.string_val.all = "quasiquoteexpand" then - quasiquote(ast.seq_val(1), result); - return; - - elsif a0.string_val.all = "quasiquote" then - quasiquote(ast.seq_val(1), ast); - next; -- TCO - - elsif a0.string_val.all = "defmacro!" then - EVAL(ast.seq_val(2), env, fn, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - new_fn(fn.func_val.f_body, fn.func_val.f_args, fn.func_val.f_env, val); - val.func_val.f_is_macro := true; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "macroexpand" then - macroexpand(ast.seq_val(1), env, result, err); - return; - - elsif a0.string_val.all = "do" then - for i in 1 to ast.seq_val'high - 1 loop - EVAL(ast.seq_val(i), env, result, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - end loop; - ast := ast.seq_val(ast.seq_val'high); - next; -- TCO - - elsif a0.string_val.all = "if" then - EVAL(ast.seq_val(1), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if val.val_type = mal_nil or val.val_type = mal_false then - if ast.seq_val'length > 3 then - ast := ast.seq_val(3); - else - new_nil(result); - return; - end if; - else - ast := ast.seq_val(2); - end if; - next; -- TCO - - elsif a0.string_val.all = "fn*" then - new_fn(ast.seq_val(2), ast.seq_val(1), env, result); - return; - - end if; - end if; - - eval_ast(ast, env, evaled_ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - seq_drop_prefix(evaled_ast, 1, call_args); - fn := evaled_ast.seq_val(0); - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, call_args, result, err); - return; - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); - env := fn_env; - ast := fn.func_val.f_body; - next; -- TCO - when others => - new_string("not a function", err); - return; - end case; - end loop; - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, read_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, env, result, err); - end procedure RE; - - procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is - variable eval_res, eval_err: mal_val_ptr; - begin - RE(str, env, eval_res, eval_err); - if eval_err /= null then - err := eval_err; - result := null; - return; - end if; - mal_PRINT(eval_res, result); - end procedure REP; - - procedure set_argv(e: inout env_ptr; program_file: inout line) is - variable argv_var_name: string(1 to 6) := "*ARGV*"; - variable argv_sym, argv_list: mal_val_ptr; - file f: text; - variable status: file_open_status; - variable one_line: line; - variable seq: mal_seq_ptr; - variable element: mal_val_ptr; - begin - program_file := null; - seq := new mal_seq(0 to -1); - file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); - if status = open_ok then - if not endfile(f) then - readline(f, program_file); - while not endfile(f) loop - readline(f, one_line); - new_string(one_line.all, element); - seq := new mal_seq'(seq.all & element); - end loop; - end if; - file_close(f); - end if; - new_seq_obj(mal_list, seq, argv_list); - new_symbol(argv_var_name, argv_sym); - env_set(e, argv_sym, argv_list); - end procedure set_argv; - - procedure repl is - variable is_eof: boolean; - variable program_file, input_line, result: line; - variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; - variable outer: env_ptr; - variable eval_func_name: string(1 to 4) := "eval"; - begin - outer := null; - new_env(repl_env, outer); - - -- core.EXT: defined using VHDL (see core.vhdl) - define_core_functions(repl_env); - new_symbol(eval_func_name, eval_sym); - new_nativefn(eval_func_name, eval_fn); - env_set(repl_env, eval_sym, eval_fn); - set_argv(repl_env, program_file); - - -- core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); - RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); - RE("(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)))))))", repl_env, dummy_val, err); - - if program_file /= null then - REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); - return; - end if; - - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, repl_env, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step8_macros is +end entity step8_macros; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; +use WORK.env.all; +use WORK.core.all; + +architecture test of step8_macros is + + shared variable repl_env: env_ptr; + + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + procedure starts_with(lst : inout mal_val_ptr; + sym : in string; + res : out boolean) is + begin + res := lst.seq_val.all'length = 2 + and lst.seq_val.all (lst.seq_val.all'low).val_type = mal_symbol + and lst.seq_val.all (lst.seq_val.all'low).string_val.all = sym; + end starts_with; + + -- Forward declaration + procedure quasiquote(ast: inout mal_val_ptr; + result: out mal_val_ptr); + + procedure qq_loop(elt : inout mal_val_ptr; + acc : inout mal_val_ptr) is + variable sw : boolean := elt.val_type = mal_list; + variable seq : mal_seq_ptr := new mal_seq(0 to 2); + begin + if sw then + starts_with(elt, "splice-unquote", sw); + end if; + if sw then + new_symbol("concat", seq(0)); + seq(1) := elt.seq_val(1); + else + new_symbol("cons", seq(0)); + quasiquote(elt, seq(1)); + end if; + seq(2) := acc; + new_seq_obj(mal_list, seq, acc); + end qq_loop; + + procedure qq_foldr (xs : inout mal_seq_ptr; + res : out mal_val_ptr) is + variable seq : mal_seq_ptr := new mal_seq(0 to -1); + variable acc : mal_val_ptr; + begin + new_seq_obj(mal_list, seq, acc); + for i in xs'reverse_range loop + qq_loop (xs(i), acc); + end loop; + res := acc; + end procedure qq_foldr; + + procedure quasiquote(ast: inout mal_val_ptr; + result: out mal_val_ptr) is + variable sw : boolean; + variable seq : mal_seq_ptr; + begin + case ast.val_type is + when mal_list => + starts_with(ast, "unquote", sw); + if sw then + result := ast.seq_val(1); + else + qq_foldr(ast.seq_val, result); + end if; + when mal_vector => + seq := new mal_seq(0 to 1); + new_symbol("vec", seq(0)); + qq_foldr(ast.seq_val, seq(1)); + new_seq_obj(mal_list, seq, result); + when mal_symbol | mal_hashmap => + seq := new mal_seq(0 to 1); + new_symbol("quote", seq(0)); + seq(1) := ast; + new_seq_obj(mal_list, seq, result); + when others => + result := ast; + end case; + end procedure quasiquote; + + -- Forward declaration + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure is_macro_call(ast: inout mal_val_ptr; env: inout env_ptr; is_macro: out boolean) is + variable f, env_err: mal_val_ptr; + begin + is_macro := false; + if ast.val_type = mal_list and + ast.seq_val'length > 0 and + ast.seq_val(0).val_type = mal_symbol then + env_get(env, ast.seq_val(0), f, env_err); + if env_err = null and f /= null and + f.val_type = mal_fn and f.func_val.f_is_macro then + is_macro := true; + end if; + end if; + end procedure is_macro_call; + + procedure macroexpand(in_ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, macro_fn, call_args, macro_err: mal_val_ptr; + variable is_macro: boolean; + begin + ast := in_ast; + is_macro_call(ast, env, is_macro); + while is_macro loop + env_get(env, ast.seq_val(0), macro_fn, macro_err); + seq_drop_prefix(ast, 1, call_args); + apply_func(macro_fn, call_args, ast, macro_err); + if macro_err /= null then + err := macro_err; + return; + end if; + is_macro_call(ast, env, is_macro); + end loop; + result := ast; + end procedure macroexpand; + + procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + EVAL(args.seq_val(0), repl_env, result, err); + end procedure fn_eval; + + procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable atom: mal_val_ptr := args.seq_val(0); + variable fn: mal_val_ptr := args.seq_val(1); + variable call_args_seq: mal_seq_ptr; + variable call_args, eval_res, sub_err: mal_val_ptr; + begin + call_args_seq := new mal_seq(0 to args.seq_val'length - 2); + call_args_seq(0) := atom.seq_val(0); + call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); + new_seq_obj(mal_list, call_args_seq, call_args); + apply_func(fn, call_args, eval_res, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + atom.seq_val(0) := eval_res; + result := eval_res; + end procedure fn_swap; + + procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + if func_sym.string_val.all = "eval" then + fn_eval(args, result, err); + elsif func_sym.string_val.all = "swap!" then + fn_swap(args, result, err); + else + eval_native_func(func_sym, args, result, err); + end if; + end procedure apply_native_func; + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable fn_env: env_ptr; + begin + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, args, result, err); + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); + EVAL(fn.func_val.f_body, fn_env, result, err); + when others => + new_string("not a function", err); + return; + end case; + end procedure apply_func; + + procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is + variable eval_err: mal_val_ptr; + begin + result := new mal_seq(0 to ast_seq'length - 1); + for i in result'range loop + EVAL(ast_seq(i), env, result(i), eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + end loop; + end procedure eval_ast_seq; + + procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable key, val, eval_err, env_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + case ast.val_type is + when mal_symbol => + env_get(env, ast, val, env_err); + if env_err /= null then + err := env_err; + return; + end if; + result := val; + return; + when mal_list | mal_vector | mal_hashmap => + eval_ast_seq(ast.seq_val, env, new_seq, eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + new_seq_obj(ast.val_type, new_seq, result); + return; + when others => + result := ast; + return; + end case; + end procedure eval_ast; + + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable i: integer; + variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; + variable env, let_env, fn_env: env_ptr; + begin + ast := in_ast; + env := in_env; + loop + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + + macroexpand(ast, env, ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + if ast.seq_val'length = 0 then + result := ast; + return; + end if; + + a0 := ast.seq_val(0); + if a0.val_type = mal_symbol then + if a0.string_val.all = "def!" then + EVAL(ast.seq_val(2), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "let*" then + vars := ast.seq_val(1); + new_env(let_env, env); + i := 0; + while i < vars.seq_val'length loop + EVAL(vars.seq_val(i + 1), let_env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(let_env, vars.seq_val(i), val); + i := i + 2; + end loop; + env := let_env; + ast := ast.seq_val(2); + next; -- TCO + + elsif a0.string_val.all = "quote" then + result := ast.seq_val(1); + return; + + elsif a0.string_val.all = "quasiquoteexpand" then + quasiquote(ast.seq_val(1), result); + return; + + elsif a0.string_val.all = "quasiquote" then + quasiquote(ast.seq_val(1), ast); + next; -- TCO + + elsif a0.string_val.all = "defmacro!" then + EVAL(ast.seq_val(2), env, fn, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + new_fn(fn.func_val.f_body, fn.func_val.f_args, fn.func_val.f_env, val); + val.func_val.f_is_macro := true; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "macroexpand" then + macroexpand(ast.seq_val(1), env, result, err); + return; + + elsif a0.string_val.all = "do" then + for i in 1 to ast.seq_val'high - 1 loop + EVAL(ast.seq_val(i), env, result, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + end loop; + ast := ast.seq_val(ast.seq_val'high); + next; -- TCO + + elsif a0.string_val.all = "if" then + EVAL(ast.seq_val(1), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if val.val_type = mal_nil or val.val_type = mal_false then + if ast.seq_val'length > 3 then + ast := ast.seq_val(3); + else + new_nil(result); + return; + end if; + else + ast := ast.seq_val(2); + end if; + next; -- TCO + + elsif a0.string_val.all = "fn*" then + new_fn(ast.seq_val(2), ast.seq_val(1), env, result); + return; + + end if; + end if; + + eval_ast(ast, env, evaled_ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + seq_drop_prefix(evaled_ast, 1, call_args); + fn := evaled_ast.seq_val(0); + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, call_args, result, err); + return; + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); + env := fn_env; + ast := fn.func_val.f_body; + next; -- TCO + when others => + new_string("not a function", err); + return; + end case; + end loop; + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, read_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, env, result, err); + end procedure RE; + + procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is + variable eval_res, eval_err: mal_val_ptr; + begin + RE(str, env, eval_res, eval_err); + if eval_err /= null then + err := eval_err; + result := null; + return; + end if; + mal_PRINT(eval_res, result); + end procedure REP; + + procedure set_argv(e: inout env_ptr; program_file: inout line) is + variable argv_var_name: string(1 to 6) := "*ARGV*"; + variable argv_sym, argv_list: mal_val_ptr; + file f: text; + variable status: file_open_status; + variable one_line: line; + variable seq: mal_seq_ptr; + variable element: mal_val_ptr; + begin + program_file := null; + seq := new mal_seq(0 to -1); + file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); + if status = open_ok then + if not endfile(f) then + readline(f, program_file); + while not endfile(f) loop + readline(f, one_line); + new_string(one_line.all, element); + seq := new mal_seq'(seq.all & element); + end loop; + end if; + file_close(f); + end if; + new_seq_obj(mal_list, seq, argv_list); + new_symbol(argv_var_name, argv_sym); + env_set(e, argv_sym, argv_list); + end procedure set_argv; + + procedure repl is + variable is_eof: boolean; + variable program_file, input_line, result: line; + variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; + variable outer: env_ptr; + variable eval_func_name: string(1 to 4) := "eval"; + begin + outer := null; + new_env(repl_env, outer); + + -- core.EXT: defined using VHDL (see core.vhdl) + define_core_functions(repl_env); + new_symbol(eval_func_name, eval_sym); + new_nativefn(eval_func_name, eval_fn); + env_set(repl_env, eval_sym, eval_fn); + set_argv(repl_env, program_file); + + -- core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); + RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); + RE("(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)))))))", repl_env, dummy_val, err); + + if program_file /= null then + REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); + return; + end if; + + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, repl_env, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/step9_try.vhdl b/impls/vhdl/step9_try.vhdl index 583acb729e..dd7ec9ff14 100644 --- a/impls/vhdl/step9_try.vhdl +++ b/impls/vhdl/step9_try.vhdl @@ -1,534 +1,534 @@ -entity step9_try is -end entity step9_try; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; -use WORK.env.all; -use WORK.core.all; - -architecture test of step9_try is - - shared variable repl_env: env_ptr; - - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - procedure starts_with(lst : inout mal_val_ptr; - sym : in string; - res : out boolean) is - begin - res := lst.seq_val.all'length = 2 - and lst.seq_val.all (lst.seq_val.all'low).val_type = mal_symbol - and lst.seq_val.all (lst.seq_val.all'low).string_val.all = sym; - end starts_with; - - -- Forward declaration - procedure quasiquote(ast: inout mal_val_ptr; - result: out mal_val_ptr); - - procedure qq_loop(elt : inout mal_val_ptr; - acc : inout mal_val_ptr) is - variable sw : boolean := elt.val_type = mal_list; - variable seq : mal_seq_ptr := new mal_seq(0 to 2); - begin - if sw then - starts_with(elt, "splice-unquote", sw); - end if; - if sw then - new_symbol("concat", seq(0)); - seq(1) := elt.seq_val(1); - else - new_symbol("cons", seq(0)); - quasiquote(elt, seq(1)); - end if; - seq(2) := acc; - new_seq_obj(mal_list, seq, acc); - end qq_loop; - - procedure qq_foldr (xs : inout mal_seq_ptr; - res : out mal_val_ptr) is - variable seq : mal_seq_ptr := new mal_seq(0 to -1); - variable acc : mal_val_ptr; - begin - new_seq_obj(mal_list, seq, acc); - for i in xs'reverse_range loop - qq_loop (xs(i), acc); - end loop; - res := acc; - end procedure qq_foldr; - - procedure quasiquote(ast: inout mal_val_ptr; - result: out mal_val_ptr) is - variable sw : boolean; - variable seq : mal_seq_ptr; - begin - case ast.val_type is - when mal_list => - starts_with(ast, "unquote", sw); - if sw then - result := ast.seq_val(1); - else - qq_foldr(ast.seq_val, result); - end if; - when mal_vector => - seq := new mal_seq(0 to 1); - new_symbol("vec", seq(0)); - qq_foldr(ast.seq_val, seq(1)); - new_seq_obj(mal_list, seq, result); - when mal_symbol | mal_hashmap => - seq := new mal_seq(0 to 1); - new_symbol("quote", seq(0)); - seq(1) := ast; - new_seq_obj(mal_list, seq, result); - when others => - result := ast; - end case; - end procedure quasiquote; - - -- Forward declaration - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure is_macro_call(ast: inout mal_val_ptr; env: inout env_ptr; is_macro: out boolean) is - variable f, env_err: mal_val_ptr; - begin - is_macro := false; - if ast.val_type = mal_list and - ast.seq_val'length > 0 and - ast.seq_val(0).val_type = mal_symbol then - env_get(env, ast.seq_val(0), f, env_err); - if env_err = null and f /= null and - f.val_type = mal_fn and f.func_val.f_is_macro then - is_macro := true; - end if; - end if; - end procedure is_macro_call; - - procedure macroexpand(in_ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, macro_fn, call_args, macro_err: mal_val_ptr; - variable is_macro: boolean; - begin - ast := in_ast; - is_macro_call(ast, env, is_macro); - while is_macro loop - env_get(env, ast.seq_val(0), macro_fn, macro_err); - seq_drop_prefix(ast, 1, call_args); - apply_func(macro_fn, call_args, ast, macro_err); - if macro_err /= null then - err := macro_err; - return; - end if; - is_macro_call(ast, env, is_macro); - end loop; - result := ast; - end procedure macroexpand; - - procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - EVAL(args.seq_val(0), repl_env, result, err); - end procedure fn_eval; - - procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable atom: mal_val_ptr := args.seq_val(0); - variable fn: mal_val_ptr := args.seq_val(1); - variable call_args_seq: mal_seq_ptr; - variable call_args, eval_res, sub_err: mal_val_ptr; - begin - call_args_seq := new mal_seq(0 to args.seq_val'length - 2); - call_args_seq(0) := atom.seq_val(0); - call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); - new_seq_obj(mal_list, call_args_seq, call_args); - apply_func(fn, call_args, eval_res, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - atom.seq_val(0) := eval_res; - result := eval_res; - end procedure fn_swap; - - procedure fn_apply(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable fn: mal_val_ptr := args.seq_val(0); - variable rest: mal_val_ptr; - variable mid_args_count, rest_args_count: integer; - variable call_args: mal_val_ptr; - variable call_args_seq: mal_seq_ptr; - begin - rest := args.seq_val(args.seq_val'high); - mid_args_count := args.seq_val'length - 2; - rest_args_count := rest.seq_val'length; - call_args_seq := new mal_seq(0 to mid_args_count + rest_args_count - 1); - call_args_seq(0 to mid_args_count - 1) := args.seq_val(1 to args.seq_val'length - 2); - call_args_seq(mid_args_count to call_args_seq'high) := rest.seq_val(rest.seq_val'range); - new_seq_obj(mal_list, call_args_seq, call_args); - apply_func(fn, call_args, result, err); - end procedure fn_apply; - - procedure fn_map(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable fn: mal_val_ptr := args.seq_val(0); - variable lst: mal_val_ptr := args.seq_val(1); - variable call_args, sub_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - new_seq := new mal_seq(lst.seq_val'range); -- (0 to lst.seq_val.length - 1); - for i in new_seq'range loop - new_one_element_list(lst.seq_val(i), call_args); - apply_func(fn, call_args, new_seq(i), sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - end loop; - new_seq_obj(mal_list, new_seq, result); - end procedure fn_map; - - procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - if func_sym.string_val.all = "eval" then - fn_eval(args, result, err); - elsif func_sym.string_val.all = "swap!" then - fn_swap(args, result, err); - elsif func_sym.string_val.all = "apply" then - fn_apply(args, result, err); - elsif func_sym.string_val.all = "map" then - fn_map(args, result, err); - else - eval_native_func(func_sym, args, result, err); - end if; - end procedure apply_native_func; - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable fn_env: env_ptr; - begin - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, args, result, err); - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); - EVAL(fn.func_val.f_body, fn_env, result, err); - when others => - new_string("not a function", err); - return; - end case; - end procedure apply_func; - - procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is - variable eval_err: mal_val_ptr; - begin - result := new mal_seq(0 to ast_seq'length - 1); - for i in result'range loop - EVAL(ast_seq(i), env, result(i), eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - end loop; - end procedure eval_ast_seq; - - procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable key, val, eval_err, env_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - case ast.val_type is - when mal_symbol => - env_get(env, ast, val, env_err); - if env_err /= null then - err := env_err; - return; - end if; - result := val; - return; - when mal_list | mal_vector | mal_hashmap => - eval_ast_seq(ast.seq_val, env, new_seq, eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - new_seq_obj(ast.val_type, new_seq, result); - return; - when others => - result := ast; - return; - end case; - end procedure eval_ast; - - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable i: integer; - variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; - variable env, let_env, catch_env, fn_env: env_ptr; - begin - ast := in_ast; - env := in_env; - loop - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - - macroexpand(ast, env, ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - if ast.seq_val'length = 0 then - result := ast; - return; - end if; - - a0 := ast.seq_val(0); - if a0.val_type = mal_symbol then - if a0.string_val.all = "def!" then - EVAL(ast.seq_val(2), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "let*" then - vars := ast.seq_val(1); - new_env(let_env, env); - i := 0; - while i < vars.seq_val'length loop - EVAL(vars.seq_val(i + 1), let_env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(let_env, vars.seq_val(i), val); - i := i + 2; - end loop; - env := let_env; - ast := ast.seq_val(2); - next; -- TCO - - elsif a0.string_val.all = "quote" then - result := ast.seq_val(1); - return; - - elsif a0.string_val.all = "quasiquoteexpand" then - quasiquote(ast.seq_val(1), result); - return; - - elsif a0.string_val.all = "quasiquote" then - quasiquote(ast.seq_val(1), ast); - next; -- TCO - - elsif a0.string_val.all = "defmacro!" then - EVAL(ast.seq_val(2), env, fn, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - new_fn(fn.func_val.f_body, fn.func_val.f_args, fn.func_val.f_env, val); - val.func_val.f_is_macro := true; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "macroexpand" then - macroexpand(ast.seq_val(1), env, result, err); - return; - - elsif a0.string_val.all = "try*" then - EVAL(ast.seq_val(1), env, result, sub_err); - if sub_err /= null then - if ast.seq_val'length > 2 and - ast.seq_val(2).val_type = mal_list and - ast.seq_val(2).seq_val(0).val_type = mal_symbol and - ast.seq_val(2).seq_val(0).string_val.all = "catch*" then - new_one_element_list(ast.seq_val(2).seq_val(1), vars); - new_one_element_list(sub_err, call_args); - new_env(catch_env, env, vars, call_args); - EVAL(ast.seq_val(2).seq_val(2), catch_env, result, err); - else - err := sub_err; - return; - end if; - end if; - return; - - elsif a0.string_val.all = "do" then - for i in 1 to ast.seq_val'high - 1 loop - EVAL(ast.seq_val(i), env, result, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - end loop; - ast := ast.seq_val(ast.seq_val'high); - next; -- TCO - - elsif a0.string_val.all = "if" then - EVAL(ast.seq_val(1), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if val.val_type = mal_nil or val.val_type = mal_false then - if ast.seq_val'length > 3 then - ast := ast.seq_val(3); - else - new_nil(result); - return; - end if; - else - ast := ast.seq_val(2); - end if; - next; -- TCO - - elsif a0.string_val.all = "fn*" then - new_fn(ast.seq_val(2), ast.seq_val(1), env, result); - return; - - end if; - end if; - - eval_ast(ast, env, evaled_ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - seq_drop_prefix(evaled_ast, 1, call_args); - fn := evaled_ast.seq_val(0); - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, call_args, result, err); - return; - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); - env := fn_env; - ast := fn.func_val.f_body; - next; -- TCO - when others => - new_string("not a function", err); - return; - end case; - end loop; - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, read_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, env, result, err); - end procedure RE; - - procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is - variable eval_res, eval_err: mal_val_ptr; - begin - RE(str, env, eval_res, eval_err); - if eval_err /= null then - err := eval_err; - result := null; - return; - end if; - mal_PRINT(eval_res, result); - end procedure REP; - - procedure set_argv(e: inout env_ptr; program_file: inout line) is - variable argv_var_name: string(1 to 6) := "*ARGV*"; - variable argv_sym, argv_list: mal_val_ptr; - file f: text; - variable status: file_open_status; - variable one_line: line; - variable seq: mal_seq_ptr; - variable element: mal_val_ptr; - begin - program_file := null; - seq := new mal_seq(0 to -1); - file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); - if status = open_ok then - if not endfile(f) then - readline(f, program_file); - while not endfile(f) loop - readline(f, one_line); - new_string(one_line.all, element); - seq := new mal_seq'(seq.all & element); - end loop; - end if; - file_close(f); - end if; - new_seq_obj(mal_list, seq, argv_list); - new_symbol(argv_var_name, argv_sym); - env_set(e, argv_sym, argv_list); - end procedure set_argv; - - procedure repl is - variable is_eof: boolean; - variable program_file, input_line, result: line; - variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; - variable outer: env_ptr; - variable eval_func_name: string(1 to 4) := "eval"; - begin - outer := null; - new_env(repl_env, outer); - - -- core.EXT: defined using VHDL (see core.vhdl) - define_core_functions(repl_env); - new_symbol(eval_func_name, eval_sym); - new_nativefn(eval_func_name, eval_fn); - env_set(repl_env, eval_sym, eval_fn); - set_argv(repl_env, program_file); - - -- core.mal: defined using the language itself - RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); - RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); - RE("(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)))))))", repl_env, dummy_val, err); - - if program_file /= null then - REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); - return; - end if; - - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, repl_env, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity step9_try is +end entity step9_try; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; +use WORK.env.all; +use WORK.core.all; + +architecture test of step9_try is + + shared variable repl_env: env_ptr; + + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + procedure starts_with(lst : inout mal_val_ptr; + sym : in string; + res : out boolean) is + begin + res := lst.seq_val.all'length = 2 + and lst.seq_val.all (lst.seq_val.all'low).val_type = mal_symbol + and lst.seq_val.all (lst.seq_val.all'low).string_val.all = sym; + end starts_with; + + -- Forward declaration + procedure quasiquote(ast: inout mal_val_ptr; + result: out mal_val_ptr); + + procedure qq_loop(elt : inout mal_val_ptr; + acc : inout mal_val_ptr) is + variable sw : boolean := elt.val_type = mal_list; + variable seq : mal_seq_ptr := new mal_seq(0 to 2); + begin + if sw then + starts_with(elt, "splice-unquote", sw); + end if; + if sw then + new_symbol("concat", seq(0)); + seq(1) := elt.seq_val(1); + else + new_symbol("cons", seq(0)); + quasiquote(elt, seq(1)); + end if; + seq(2) := acc; + new_seq_obj(mal_list, seq, acc); + end qq_loop; + + procedure qq_foldr (xs : inout mal_seq_ptr; + res : out mal_val_ptr) is + variable seq : mal_seq_ptr := new mal_seq(0 to -1); + variable acc : mal_val_ptr; + begin + new_seq_obj(mal_list, seq, acc); + for i in xs'reverse_range loop + qq_loop (xs(i), acc); + end loop; + res := acc; + end procedure qq_foldr; + + procedure quasiquote(ast: inout mal_val_ptr; + result: out mal_val_ptr) is + variable sw : boolean; + variable seq : mal_seq_ptr; + begin + case ast.val_type is + when mal_list => + starts_with(ast, "unquote", sw); + if sw then + result := ast.seq_val(1); + else + qq_foldr(ast.seq_val, result); + end if; + when mal_vector => + seq := new mal_seq(0 to 1); + new_symbol("vec", seq(0)); + qq_foldr(ast.seq_val, seq(1)); + new_seq_obj(mal_list, seq, result); + when mal_symbol | mal_hashmap => + seq := new mal_seq(0 to 1); + new_symbol("quote", seq(0)); + seq(1) := ast; + new_seq_obj(mal_list, seq, result); + when others => + result := ast; + end case; + end procedure quasiquote; + + -- Forward declaration + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure is_macro_call(ast: inout mal_val_ptr; env: inout env_ptr; is_macro: out boolean) is + variable f, env_err: mal_val_ptr; + begin + is_macro := false; + if ast.val_type = mal_list and + ast.seq_val'length > 0 and + ast.seq_val(0).val_type = mal_symbol then + env_get(env, ast.seq_val(0), f, env_err); + if env_err = null and f /= null and + f.val_type = mal_fn and f.func_val.f_is_macro then + is_macro := true; + end if; + end if; + end procedure is_macro_call; + + procedure macroexpand(in_ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, macro_fn, call_args, macro_err: mal_val_ptr; + variable is_macro: boolean; + begin + ast := in_ast; + is_macro_call(ast, env, is_macro); + while is_macro loop + env_get(env, ast.seq_val(0), macro_fn, macro_err); + seq_drop_prefix(ast, 1, call_args); + apply_func(macro_fn, call_args, ast, macro_err); + if macro_err /= null then + err := macro_err; + return; + end if; + is_macro_call(ast, env, is_macro); + end loop; + result := ast; + end procedure macroexpand; + + procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + EVAL(args.seq_val(0), repl_env, result, err); + end procedure fn_eval; + + procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable atom: mal_val_ptr := args.seq_val(0); + variable fn: mal_val_ptr := args.seq_val(1); + variable call_args_seq: mal_seq_ptr; + variable call_args, eval_res, sub_err: mal_val_ptr; + begin + call_args_seq := new mal_seq(0 to args.seq_val'length - 2); + call_args_seq(0) := atom.seq_val(0); + call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); + new_seq_obj(mal_list, call_args_seq, call_args); + apply_func(fn, call_args, eval_res, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + atom.seq_val(0) := eval_res; + result := eval_res; + end procedure fn_swap; + + procedure fn_apply(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable fn: mal_val_ptr := args.seq_val(0); + variable rest: mal_val_ptr; + variable mid_args_count, rest_args_count: integer; + variable call_args: mal_val_ptr; + variable call_args_seq: mal_seq_ptr; + begin + rest := args.seq_val(args.seq_val'high); + mid_args_count := args.seq_val'length - 2; + rest_args_count := rest.seq_val'length; + call_args_seq := new mal_seq(0 to mid_args_count + rest_args_count - 1); + call_args_seq(0 to mid_args_count - 1) := args.seq_val(1 to args.seq_val'length - 2); + call_args_seq(mid_args_count to call_args_seq'high) := rest.seq_val(rest.seq_val'range); + new_seq_obj(mal_list, call_args_seq, call_args); + apply_func(fn, call_args, result, err); + end procedure fn_apply; + + procedure fn_map(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable fn: mal_val_ptr := args.seq_val(0); + variable lst: mal_val_ptr := args.seq_val(1); + variable call_args, sub_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + new_seq := new mal_seq(lst.seq_val'range); -- (0 to lst.seq_val.length - 1); + for i in new_seq'range loop + new_one_element_list(lst.seq_val(i), call_args); + apply_func(fn, call_args, new_seq(i), sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + end loop; + new_seq_obj(mal_list, new_seq, result); + end procedure fn_map; + + procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + if func_sym.string_val.all = "eval" then + fn_eval(args, result, err); + elsif func_sym.string_val.all = "swap!" then + fn_swap(args, result, err); + elsif func_sym.string_val.all = "apply" then + fn_apply(args, result, err); + elsif func_sym.string_val.all = "map" then + fn_map(args, result, err); + else + eval_native_func(func_sym, args, result, err); + end if; + end procedure apply_native_func; + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable fn_env: env_ptr; + begin + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, args, result, err); + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); + EVAL(fn.func_val.f_body, fn_env, result, err); + when others => + new_string("not a function", err); + return; + end case; + end procedure apply_func; + + procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is + variable eval_err: mal_val_ptr; + begin + result := new mal_seq(0 to ast_seq'length - 1); + for i in result'range loop + EVAL(ast_seq(i), env, result(i), eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + end loop; + end procedure eval_ast_seq; + + procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable key, val, eval_err, env_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + case ast.val_type is + when mal_symbol => + env_get(env, ast, val, env_err); + if env_err /= null then + err := env_err; + return; + end if; + result := val; + return; + when mal_list | mal_vector | mal_hashmap => + eval_ast_seq(ast.seq_val, env, new_seq, eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + new_seq_obj(ast.val_type, new_seq, result); + return; + when others => + result := ast; + return; + end case; + end procedure eval_ast; + + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable i: integer; + variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; + variable env, let_env, catch_env, fn_env: env_ptr; + begin + ast := in_ast; + env := in_env; + loop + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + + macroexpand(ast, env, ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + if ast.seq_val'length = 0 then + result := ast; + return; + end if; + + a0 := ast.seq_val(0); + if a0.val_type = mal_symbol then + if a0.string_val.all = "def!" then + EVAL(ast.seq_val(2), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "let*" then + vars := ast.seq_val(1); + new_env(let_env, env); + i := 0; + while i < vars.seq_val'length loop + EVAL(vars.seq_val(i + 1), let_env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(let_env, vars.seq_val(i), val); + i := i + 2; + end loop; + env := let_env; + ast := ast.seq_val(2); + next; -- TCO + + elsif a0.string_val.all = "quote" then + result := ast.seq_val(1); + return; + + elsif a0.string_val.all = "quasiquoteexpand" then + quasiquote(ast.seq_val(1), result); + return; + + elsif a0.string_val.all = "quasiquote" then + quasiquote(ast.seq_val(1), ast); + next; -- TCO + + elsif a0.string_val.all = "defmacro!" then + EVAL(ast.seq_val(2), env, fn, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + new_fn(fn.func_val.f_body, fn.func_val.f_args, fn.func_val.f_env, val); + val.func_val.f_is_macro := true; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "macroexpand" then + macroexpand(ast.seq_val(1), env, result, err); + return; + + elsif a0.string_val.all = "try*" then + EVAL(ast.seq_val(1), env, result, sub_err); + if sub_err /= null then + if ast.seq_val'length > 2 and + ast.seq_val(2).val_type = mal_list and + ast.seq_val(2).seq_val(0).val_type = mal_symbol and + ast.seq_val(2).seq_val(0).string_val.all = "catch*" then + new_one_element_list(ast.seq_val(2).seq_val(1), vars); + new_one_element_list(sub_err, call_args); + new_env(catch_env, env, vars, call_args); + EVAL(ast.seq_val(2).seq_val(2), catch_env, result, err); + else + err := sub_err; + return; + end if; + end if; + return; + + elsif a0.string_val.all = "do" then + for i in 1 to ast.seq_val'high - 1 loop + EVAL(ast.seq_val(i), env, result, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + end loop; + ast := ast.seq_val(ast.seq_val'high); + next; -- TCO + + elsif a0.string_val.all = "if" then + EVAL(ast.seq_val(1), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if val.val_type = mal_nil or val.val_type = mal_false then + if ast.seq_val'length > 3 then + ast := ast.seq_val(3); + else + new_nil(result); + return; + end if; + else + ast := ast.seq_val(2); + end if; + next; -- TCO + + elsif a0.string_val.all = "fn*" then + new_fn(ast.seq_val(2), ast.seq_val(1), env, result); + return; + + end if; + end if; + + eval_ast(ast, env, evaled_ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + seq_drop_prefix(evaled_ast, 1, call_args); + fn := evaled_ast.seq_val(0); + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, call_args, result, err); + return; + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); + env := fn_env; + ast := fn.func_val.f_body; + next; -- TCO + when others => + new_string("not a function", err); + return; + end case; + end loop; + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, read_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, env, result, err); + end procedure RE; + + procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is + variable eval_res, eval_err: mal_val_ptr; + begin + RE(str, env, eval_res, eval_err); + if eval_err /= null then + err := eval_err; + result := null; + return; + end if; + mal_PRINT(eval_res, result); + end procedure REP; + + procedure set_argv(e: inout env_ptr; program_file: inout line) is + variable argv_var_name: string(1 to 6) := "*ARGV*"; + variable argv_sym, argv_list: mal_val_ptr; + file f: text; + variable status: file_open_status; + variable one_line: line; + variable seq: mal_seq_ptr; + variable element: mal_val_ptr; + begin + program_file := null; + seq := new mal_seq(0 to -1); + file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); + if status = open_ok then + if not endfile(f) then + readline(f, program_file); + while not endfile(f) loop + readline(f, one_line); + new_string(one_line.all, element); + seq := new mal_seq'(seq.all & element); + end loop; + end if; + file_close(f); + end if; + new_seq_obj(mal_list, seq, argv_list); + new_symbol(argv_var_name, argv_sym); + env_set(e, argv_sym, argv_list); + end procedure set_argv; + + procedure repl is + variable is_eof: boolean; + variable program_file, input_line, result: line; + variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; + variable outer: env_ptr; + variable eval_func_name: string(1 to 4) := "eval"; + begin + outer := null; + new_env(repl_env, outer); + + -- core.EXT: defined using VHDL (see core.vhdl) + define_core_functions(repl_env); + new_symbol(eval_func_name, eval_sym); + new_nativefn(eval_func_name, eval_fn); + env_set(repl_env, eval_sym, eval_fn); + set_argv(repl_env, program_file); + + -- core.mal: defined using the language itself + RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); + RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); + RE("(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)))))))", repl_env, dummy_val, err); + + if program_file /= null then + REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); + return; + end if; + + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, repl_env, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/stepA_mal.vhdl b/impls/vhdl/stepA_mal.vhdl index bcbaadcd29..b97f1bb6c0 100644 --- a/impls/vhdl/stepA_mal.vhdl +++ b/impls/vhdl/stepA_mal.vhdl @@ -1,536 +1,536 @@ -entity stepA_mal is -end entity stepA_mal; - -library STD; -use STD.textio.all; -library WORK; -use WORK.pkg_readline.all; -use WORK.types.all; -use WORK.printer.all; -use WORK.reader.all; -use WORK.env.all; -use WORK.core.all; - -architecture test of stepA_mal is - - shared variable repl_env: env_ptr; - - procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is - begin - read_str(str, ast, err); - end procedure mal_READ; - - procedure starts_with(lst : inout mal_val_ptr; - sym : in string; - res : out boolean) is - begin - res := lst.seq_val.all'length = 2 - and lst.seq_val.all (lst.seq_val.all'low).val_type = mal_symbol - and lst.seq_val.all (lst.seq_val.all'low).string_val.all = sym; - end starts_with; - - -- Forward declaration - procedure quasiquote(ast: inout mal_val_ptr; - result: out mal_val_ptr); - - procedure qq_loop(elt : inout mal_val_ptr; - acc : inout mal_val_ptr) is - variable sw : boolean := elt.val_type = mal_list; - variable seq : mal_seq_ptr := new mal_seq(0 to 2); - begin - if sw then - starts_with(elt, "splice-unquote", sw); - end if; - if sw then - new_symbol("concat", seq(0)); - seq(1) := elt.seq_val(1); - else - new_symbol("cons", seq(0)); - quasiquote(elt, seq(1)); - end if; - seq(2) := acc; - new_seq_obj(mal_list, seq, acc); - end qq_loop; - - procedure qq_foldr (xs : inout mal_seq_ptr; - res : out mal_val_ptr) is - variable seq : mal_seq_ptr := new mal_seq(0 to -1); - variable acc : mal_val_ptr; - begin - new_seq_obj(mal_list, seq, acc); - for i in xs'reverse_range loop - qq_loop (xs(i), acc); - end loop; - res := acc; - end procedure qq_foldr; - - procedure quasiquote(ast: inout mal_val_ptr; - result: out mal_val_ptr) is - variable sw : boolean; - variable seq : mal_seq_ptr; - begin - case ast.val_type is - when mal_list => - starts_with(ast, "unquote", sw); - if sw then - result := ast.seq_val(1); - else - qq_foldr(ast.seq_val, result); - end if; - when mal_vector => - seq := new mal_seq(0 to 1); - new_symbol("vec", seq(0)); - qq_foldr(ast.seq_val, seq(1)); - new_seq_obj(mal_list, seq, result); - when mal_symbol | mal_hashmap => - seq := new mal_seq(0 to 1); - new_symbol("quote", seq(0)); - seq(1) := ast; - new_seq_obj(mal_list, seq, result); - when others => - result := ast; - end case; - end procedure quasiquote; - - -- Forward declaration - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); - - procedure is_macro_call(ast: inout mal_val_ptr; env: inout env_ptr; is_macro: out boolean) is - variable f, env_err: mal_val_ptr; - begin - is_macro := false; - if ast.val_type = mal_list and - ast.seq_val'length > 0 and - ast.seq_val(0).val_type = mal_symbol then - env_get(env, ast.seq_val(0), f, env_err); - if env_err = null and f /= null and - f.val_type = mal_fn and f.func_val.f_is_macro then - is_macro := true; - end if; - end if; - end procedure is_macro_call; - - procedure macroexpand(in_ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, macro_fn, call_args, macro_err: mal_val_ptr; - variable is_macro: boolean; - begin - ast := in_ast; - is_macro_call(ast, env, is_macro); - while is_macro loop - env_get(env, ast.seq_val(0), macro_fn, macro_err); - seq_drop_prefix(ast, 1, call_args); - apply_func(macro_fn, call_args, ast, macro_err); - if macro_err /= null then - err := macro_err; - return; - end if; - is_macro_call(ast, env, is_macro); - end loop; - result := ast; - end procedure macroexpand; - - procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - EVAL(args.seq_val(0), repl_env, result, err); - end procedure fn_eval; - - procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable atom: mal_val_ptr := args.seq_val(0); - variable fn: mal_val_ptr := args.seq_val(1); - variable call_args_seq: mal_seq_ptr; - variable call_args, eval_res, sub_err: mal_val_ptr; - begin - call_args_seq := new mal_seq(0 to args.seq_val'length - 2); - call_args_seq(0) := atom.seq_val(0); - call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); - new_seq_obj(mal_list, call_args_seq, call_args); - apply_func(fn, call_args, eval_res, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - atom.seq_val(0) := eval_res; - result := eval_res; - end procedure fn_swap; - - procedure fn_apply(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable fn: mal_val_ptr := args.seq_val(0); - variable rest: mal_val_ptr; - variable mid_args_count, rest_args_count: integer; - variable call_args: mal_val_ptr; - variable call_args_seq: mal_seq_ptr; - begin - rest := args.seq_val(args.seq_val'high); - mid_args_count := args.seq_val'length - 2; - rest_args_count := rest.seq_val'length; - call_args_seq := new mal_seq(0 to mid_args_count + rest_args_count - 1); - call_args_seq(0 to mid_args_count - 1) := args.seq_val(1 to args.seq_val'length - 2); - call_args_seq(mid_args_count to call_args_seq'high) := rest.seq_val(rest.seq_val'range); - new_seq_obj(mal_list, call_args_seq, call_args); - apply_func(fn, call_args, result, err); - end procedure fn_apply; - - procedure fn_map(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable fn: mal_val_ptr := args.seq_val(0); - variable lst: mal_val_ptr := args.seq_val(1); - variable call_args, sub_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - new_seq := new mal_seq(lst.seq_val'range); -- (0 to lst.seq_val.length - 1); - for i in new_seq'range loop - new_one_element_list(lst.seq_val(i), call_args); - apply_func(fn, call_args, new_seq(i), sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - end loop; - new_seq_obj(mal_list, new_seq, result); - end procedure fn_map; - - procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - begin - if func_sym.string_val.all = "eval" then - fn_eval(args, result, err); - elsif func_sym.string_val.all = "swap!" then - fn_swap(args, result, err); - elsif func_sym.string_val.all = "apply" then - fn_apply(args, result, err); - elsif func_sym.string_val.all = "map" then - fn_map(args, result, err); - else - eval_native_func(func_sym, args, result, err); - end if; - end procedure apply_native_func; - - procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable fn_env: env_ptr; - begin - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, args, result, err); - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); - EVAL(fn.func_val.f_body, fn_env, result, err); - when others => - new_string("not a function", err); - return; - end case; - end procedure apply_func; - - procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is - variable eval_err: mal_val_ptr; - begin - result := new mal_seq(0 to ast_seq'length - 1); - for i in result'range loop - EVAL(ast_seq(i), env, result(i), eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - end loop; - end procedure eval_ast_seq; - - procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable key, val, eval_err, env_err: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable i: integer; - begin - case ast.val_type is - when mal_symbol => - env_get(env, ast, val, env_err); - if env_err /= null then - err := env_err; - return; - end if; - result := val; - return; - when mal_list | mal_vector | mal_hashmap => - eval_ast_seq(ast.seq_val, env, new_seq, eval_err); - if eval_err /= null then - err := eval_err; - return; - end if; - new_seq_obj(ast.val_type, new_seq, result); - return; - when others => - result := ast; - return; - end case; - end procedure eval_ast; - - procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable i: integer; - variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; - variable env, let_env, catch_env, fn_env: env_ptr; - begin - ast := in_ast; - env := in_env; - loop - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - - macroexpand(ast, env, ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if ast.val_type /= mal_list then - eval_ast(ast, env, result, err); - return; - end if; - if ast.seq_val'length = 0 then - result := ast; - return; - end if; - - a0 := ast.seq_val(0); - if a0.val_type = mal_symbol then - if a0.string_val.all = "def!" then - EVAL(ast.seq_val(2), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "let*" then - vars := ast.seq_val(1); - new_env(let_env, env); - i := 0; - while i < vars.seq_val'length loop - EVAL(vars.seq_val(i + 1), let_env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - env_set(let_env, vars.seq_val(i), val); - i := i + 2; - end loop; - env := let_env; - ast := ast.seq_val(2); - next; -- TCO - - elsif a0.string_val.all = "quote" then - result := ast.seq_val(1); - return; - - elsif a0.string_val.all = "quasiquoteexpand" then - quasiquote(ast.seq_val(1), result); - return; - - elsif a0.string_val.all = "quasiquote" then - quasiquote(ast.seq_val(1), ast); - next; -- TCO - - elsif a0.string_val.all = "defmacro!" then - EVAL(ast.seq_val(2), env, fn, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - new_fn(fn.func_val.f_body, fn.func_val.f_args, fn.func_val.f_env, val); - val.func_val.f_is_macro := true; - env_set(env, ast.seq_val(1), val); - result := val; - return; - - elsif a0.string_val.all = "macroexpand" then - macroexpand(ast.seq_val(1), env, result, err); - return; - - elsif a0.string_val.all = "try*" then - EVAL(ast.seq_val(1), env, result, sub_err); - if sub_err /= null then - if ast.seq_val'length > 2 and - ast.seq_val(2).val_type = mal_list and - ast.seq_val(2).seq_val(0).val_type = mal_symbol and - ast.seq_val(2).seq_val(0).string_val.all = "catch*" then - new_one_element_list(ast.seq_val(2).seq_val(1), vars); - new_one_element_list(sub_err, call_args); - new_env(catch_env, env, vars, call_args); - EVAL(ast.seq_val(2).seq_val(2), catch_env, result, err); - else - err := sub_err; - return; - end if; - end if; - return; - - elsif a0.string_val.all = "do" then - for i in 1 to ast.seq_val'high - 1 loop - EVAL(ast.seq_val(i), env, result, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - end loop; - ast := ast.seq_val(ast.seq_val'high); - next; -- TCO - - elsif a0.string_val.all = "if" then - EVAL(ast.seq_val(1), env, val, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - if val.val_type = mal_nil or val.val_type = mal_false then - if ast.seq_val'length > 3 then - ast := ast.seq_val(3); - else - new_nil(result); - return; - end if; - else - ast := ast.seq_val(2); - end if; - next; -- TCO - - elsif a0.string_val.all = "fn*" then - new_fn(ast.seq_val(2), ast.seq_val(1), env, result); - return; - - end if; - end if; - - eval_ast(ast, env, evaled_ast, sub_err); - if sub_err /= null then - err := sub_err; - return; - end if; - seq_drop_prefix(evaled_ast, 1, call_args); - fn := evaled_ast.seq_val(0); - case fn.val_type is - when mal_nativefn => - apply_native_func(fn, call_args, result, err); - return; - when mal_fn => - new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); - env := fn_env; - ast := fn.func_val.f_body; - next; -- TCO - when others => - new_string("not a function", err); - return; - end case; - end loop; - end procedure EVAL; - - procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is - begin - pr_str(exp, true, result); - end procedure mal_PRINT; - - procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is - variable ast, read_err: mal_val_ptr; - begin - mal_READ(str, ast, read_err); - if read_err /= null then - err := read_err; - result := null; - return; - end if; - if ast = null then - result := null; - return; - end if; - EVAL(ast, env, result, err); - end procedure RE; - - procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is - variable eval_res, eval_err: mal_val_ptr; - begin - RE(str, env, eval_res, eval_err); - if eval_err /= null then - err := eval_err; - result := null; - return; - end if; - mal_PRINT(eval_res, result); - end procedure REP; - - procedure set_argv(e: inout env_ptr; program_file: inout line) is - variable argv_var_name: string(1 to 6) := "*ARGV*"; - variable argv_sym, argv_list: mal_val_ptr; - file f: text; - variable status: file_open_status; - variable one_line: line; - variable seq: mal_seq_ptr; - variable element: mal_val_ptr; - begin - program_file := null; - seq := new mal_seq(0 to -1); - file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); - if status = open_ok then - if not endfile(f) then - readline(f, program_file); - while not endfile(f) loop - readline(f, one_line); - new_string(one_line.all, element); - seq := new mal_seq'(seq.all & element); - end loop; - end if; - file_close(f); - end if; - new_seq_obj(mal_list, seq, argv_list); - new_symbol(argv_var_name, argv_sym); - env_set(e, argv_sym, argv_list); - end procedure set_argv; - - procedure repl is - variable is_eof: boolean; - variable program_file, input_line, result: line; - variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; - variable outer: env_ptr; - variable eval_func_name: string(1 to 4) := "eval"; - begin - outer := null; - new_env(repl_env, outer); - - -- core.EXT: defined using VHDL (see core.vhdl) - define_core_functions(repl_env); - new_symbol(eval_func_name, eval_sym); - new_nativefn(eval_func_name, eval_fn); - env_set(repl_env, eval_sym, eval_fn); - set_argv(repl_env, program_file); - - -- core.mal: defined using the language itself - RE("(def! *host-language* " & '"' & "vhdl" & '"' & ")", repl_env, dummy_val, err); - RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); - RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); - RE("(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)))))))", repl_env, dummy_val, err); - - if program_file /= null then - REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); - return; - end if; - - RE("(println (str " & '"' & "Mal [" & '"' & " *host-language* " & '"' & "]" & '"' & "))", repl_env, dummy_val, err); - loop - mal_readline("user> ", is_eof, input_line); - exit when is_eof; - next when input_line'length = 0; - REP(input_line.all, repl_env, result, err); - if err /= null then - pr_str(err, false, result); - result := new string'("Error: " & result.all); - end if; - if result /= null then - mal_printline(result.all); - end if; - deallocate(result); - deallocate(err); - end loop; - mal_printline(""); - end procedure repl; - -begin - repl; -end architecture test; +entity stepA_mal is +end entity stepA_mal; + +library STD; +use STD.textio.all; +library WORK; +use WORK.pkg_readline.all; +use WORK.types.all; +use WORK.printer.all; +use WORK.reader.all; +use WORK.env.all; +use WORK.core.all; + +architecture test of stepA_mal is + + shared variable repl_env: env_ptr; + + procedure mal_READ(str: in string; ast: out mal_val_ptr; err: out mal_val_ptr) is + begin + read_str(str, ast, err); + end procedure mal_READ; + + procedure starts_with(lst : inout mal_val_ptr; + sym : in string; + res : out boolean) is + begin + res := lst.seq_val.all'length = 2 + and lst.seq_val.all (lst.seq_val.all'low).val_type = mal_symbol + and lst.seq_val.all (lst.seq_val.all'low).string_val.all = sym; + end starts_with; + + -- Forward declaration + procedure quasiquote(ast: inout mal_val_ptr; + result: out mal_val_ptr); + + procedure qq_loop(elt : inout mal_val_ptr; + acc : inout mal_val_ptr) is + variable sw : boolean := elt.val_type = mal_list; + variable seq : mal_seq_ptr := new mal_seq(0 to 2); + begin + if sw then + starts_with(elt, "splice-unquote", sw); + end if; + if sw then + new_symbol("concat", seq(0)); + seq(1) := elt.seq_val(1); + else + new_symbol("cons", seq(0)); + quasiquote(elt, seq(1)); + end if; + seq(2) := acc; + new_seq_obj(mal_list, seq, acc); + end qq_loop; + + procedure qq_foldr (xs : inout mal_seq_ptr; + res : out mal_val_ptr) is + variable seq : mal_seq_ptr := new mal_seq(0 to -1); + variable acc : mal_val_ptr; + begin + new_seq_obj(mal_list, seq, acc); + for i in xs'reverse_range loop + qq_loop (xs(i), acc); + end loop; + res := acc; + end procedure qq_foldr; + + procedure quasiquote(ast: inout mal_val_ptr; + result: out mal_val_ptr) is + variable sw : boolean; + variable seq : mal_seq_ptr; + begin + case ast.val_type is + when mal_list => + starts_with(ast, "unquote", sw); + if sw then + result := ast.seq_val(1); + else + qq_foldr(ast.seq_val, result); + end if; + when mal_vector => + seq := new mal_seq(0 to 1); + new_symbol("vec", seq(0)); + qq_foldr(ast.seq_val, seq(1)); + new_seq_obj(mal_list, seq, result); + when mal_symbol | mal_hashmap => + seq := new mal_seq(0 to 1); + new_symbol("quote", seq(0)); + seq(1) := ast; + new_seq_obj(mal_list, seq, result); + when others => + result := ast; + end case; + end procedure quasiquote; + + -- Forward declaration + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr); + + procedure is_macro_call(ast: inout mal_val_ptr; env: inout env_ptr; is_macro: out boolean) is + variable f, env_err: mal_val_ptr; + begin + is_macro := false; + if ast.val_type = mal_list and + ast.seq_val'length > 0 and + ast.seq_val(0).val_type = mal_symbol then + env_get(env, ast.seq_val(0), f, env_err); + if env_err = null and f /= null and + f.val_type = mal_fn and f.func_val.f_is_macro then + is_macro := true; + end if; + end if; + end procedure is_macro_call; + + procedure macroexpand(in_ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, macro_fn, call_args, macro_err: mal_val_ptr; + variable is_macro: boolean; + begin + ast := in_ast; + is_macro_call(ast, env, is_macro); + while is_macro loop + env_get(env, ast.seq_val(0), macro_fn, macro_err); + seq_drop_prefix(ast, 1, call_args); + apply_func(macro_fn, call_args, ast, macro_err); + if macro_err /= null then + err := macro_err; + return; + end if; + is_macro_call(ast, env, is_macro); + end loop; + result := ast; + end procedure macroexpand; + + procedure fn_eval(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + EVAL(args.seq_val(0), repl_env, result, err); + end procedure fn_eval; + + procedure fn_swap(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable atom: mal_val_ptr := args.seq_val(0); + variable fn: mal_val_ptr := args.seq_val(1); + variable call_args_seq: mal_seq_ptr; + variable call_args, eval_res, sub_err: mal_val_ptr; + begin + call_args_seq := new mal_seq(0 to args.seq_val'length - 2); + call_args_seq(0) := atom.seq_val(0); + call_args_seq(1 to call_args_seq'length - 1) := args.seq_val(2 to args.seq_val'length - 1); + new_seq_obj(mal_list, call_args_seq, call_args); + apply_func(fn, call_args, eval_res, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + atom.seq_val(0) := eval_res; + result := eval_res; + end procedure fn_swap; + + procedure fn_apply(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable fn: mal_val_ptr := args.seq_val(0); + variable rest: mal_val_ptr; + variable mid_args_count, rest_args_count: integer; + variable call_args: mal_val_ptr; + variable call_args_seq: mal_seq_ptr; + begin + rest := args.seq_val(args.seq_val'high); + mid_args_count := args.seq_val'length - 2; + rest_args_count := rest.seq_val'length; + call_args_seq := new mal_seq(0 to mid_args_count + rest_args_count - 1); + call_args_seq(0 to mid_args_count - 1) := args.seq_val(1 to args.seq_val'length - 2); + call_args_seq(mid_args_count to call_args_seq'high) := rest.seq_val(rest.seq_val'range); + new_seq_obj(mal_list, call_args_seq, call_args); + apply_func(fn, call_args, result, err); + end procedure fn_apply; + + procedure fn_map(args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable fn: mal_val_ptr := args.seq_val(0); + variable lst: mal_val_ptr := args.seq_val(1); + variable call_args, sub_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + new_seq := new mal_seq(lst.seq_val'range); -- (0 to lst.seq_val.length - 1); + for i in new_seq'range loop + new_one_element_list(lst.seq_val(i), call_args); + apply_func(fn, call_args, new_seq(i), sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + end loop; + new_seq_obj(mal_list, new_seq, result); + end procedure fn_map; + + procedure apply_native_func(func_sym: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + begin + if func_sym.string_val.all = "eval" then + fn_eval(args, result, err); + elsif func_sym.string_val.all = "swap!" then + fn_swap(args, result, err); + elsif func_sym.string_val.all = "apply" then + fn_apply(args, result, err); + elsif func_sym.string_val.all = "map" then + fn_map(args, result, err); + else + eval_native_func(func_sym, args, result, err); + end if; + end procedure apply_native_func; + + procedure apply_func(fn: inout mal_val_ptr; args: inout mal_val_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable fn_env: env_ptr; + begin + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, args, result, err); + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, args); + EVAL(fn.func_val.f_body, fn_env, result, err); + when others => + new_string("not a function", err); + return; + end case; + end procedure apply_func; + + procedure eval_ast_seq(ast_seq: inout mal_seq_ptr; env: inout env_ptr; result: inout mal_seq_ptr; err: out mal_val_ptr) is + variable eval_err: mal_val_ptr; + begin + result := new mal_seq(0 to ast_seq'length - 1); + for i in result'range loop + EVAL(ast_seq(i), env, result(i), eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + end loop; + end procedure eval_ast_seq; + + procedure eval_ast(ast: inout mal_val_ptr; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable key, val, eval_err, env_err: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable i: integer; + begin + case ast.val_type is + when mal_symbol => + env_get(env, ast, val, env_err); + if env_err /= null then + err := env_err; + return; + end if; + result := val; + return; + when mal_list | mal_vector | mal_hashmap => + eval_ast_seq(ast.seq_val, env, new_seq, eval_err); + if eval_err /= null then + err := eval_err; + return; + end if; + new_seq_obj(ast.val_type, new_seq, result); + return; + when others => + result := ast; + return; + end case; + end procedure eval_ast; + + procedure EVAL(in_ast: inout mal_val_ptr; in_env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable i: integer; + variable ast, evaled_ast, a0, call_args, val, vars, sub_err, fn: mal_val_ptr; + variable env, let_env, catch_env, fn_env: env_ptr; + begin + ast := in_ast; + env := in_env; + loop + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + + macroexpand(ast, env, ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if ast.val_type /= mal_list then + eval_ast(ast, env, result, err); + return; + end if; + if ast.seq_val'length = 0 then + result := ast; + return; + end if; + + a0 := ast.seq_val(0); + if a0.val_type = mal_symbol then + if a0.string_val.all = "def!" then + EVAL(ast.seq_val(2), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "let*" then + vars := ast.seq_val(1); + new_env(let_env, env); + i := 0; + while i < vars.seq_val'length loop + EVAL(vars.seq_val(i + 1), let_env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + env_set(let_env, vars.seq_val(i), val); + i := i + 2; + end loop; + env := let_env; + ast := ast.seq_val(2); + next; -- TCO + + elsif a0.string_val.all = "quote" then + result := ast.seq_val(1); + return; + + elsif a0.string_val.all = "quasiquoteexpand" then + quasiquote(ast.seq_val(1), result); + return; + + elsif a0.string_val.all = "quasiquote" then + quasiquote(ast.seq_val(1), ast); + next; -- TCO + + elsif a0.string_val.all = "defmacro!" then + EVAL(ast.seq_val(2), env, fn, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + new_fn(fn.func_val.f_body, fn.func_val.f_args, fn.func_val.f_env, val); + val.func_val.f_is_macro := true; + env_set(env, ast.seq_val(1), val); + result := val; + return; + + elsif a0.string_val.all = "macroexpand" then + macroexpand(ast.seq_val(1), env, result, err); + return; + + elsif a0.string_val.all = "try*" then + EVAL(ast.seq_val(1), env, result, sub_err); + if sub_err /= null then + if ast.seq_val'length > 2 and + ast.seq_val(2).val_type = mal_list and + ast.seq_val(2).seq_val(0).val_type = mal_symbol and + ast.seq_val(2).seq_val(0).string_val.all = "catch*" then + new_one_element_list(ast.seq_val(2).seq_val(1), vars); + new_one_element_list(sub_err, call_args); + new_env(catch_env, env, vars, call_args); + EVAL(ast.seq_val(2).seq_val(2), catch_env, result, err); + else + err := sub_err; + return; + end if; + end if; + return; + + elsif a0.string_val.all = "do" then + for i in 1 to ast.seq_val'high - 1 loop + EVAL(ast.seq_val(i), env, result, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + end loop; + ast := ast.seq_val(ast.seq_val'high); + next; -- TCO + + elsif a0.string_val.all = "if" then + EVAL(ast.seq_val(1), env, val, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + if val.val_type = mal_nil or val.val_type = mal_false then + if ast.seq_val'length > 3 then + ast := ast.seq_val(3); + else + new_nil(result); + return; + end if; + else + ast := ast.seq_val(2); + end if; + next; -- TCO + + elsif a0.string_val.all = "fn*" then + new_fn(ast.seq_val(2), ast.seq_val(1), env, result); + return; + + end if; + end if; + + eval_ast(ast, env, evaled_ast, sub_err); + if sub_err /= null then + err := sub_err; + return; + end if; + seq_drop_prefix(evaled_ast, 1, call_args); + fn := evaled_ast.seq_val(0); + case fn.val_type is + when mal_nativefn => + apply_native_func(fn, call_args, result, err); + return; + when mal_fn => + new_env(fn_env, fn.func_val.f_env, fn.func_val.f_args, call_args); + env := fn_env; + ast := fn.func_val.f_body; + next; -- TCO + when others => + new_string("not a function", err); + return; + end case; + end loop; + end procedure EVAL; + + procedure mal_PRINT(exp: inout mal_val_ptr; result: out line) is + begin + pr_str(exp, true, result); + end procedure mal_PRINT; + + procedure RE(str: in string; env: inout env_ptr; result: out mal_val_ptr; err: out mal_val_ptr) is + variable ast, read_err: mal_val_ptr; + begin + mal_READ(str, ast, read_err); + if read_err /= null then + err := read_err; + result := null; + return; + end if; + if ast = null then + result := null; + return; + end if; + EVAL(ast, env, result, err); + end procedure RE; + + procedure REP(str: in string; env: inout env_ptr; result: out line; err: out mal_val_ptr) is + variable eval_res, eval_err: mal_val_ptr; + begin + RE(str, env, eval_res, eval_err); + if eval_err /= null then + err := eval_err; + result := null; + return; + end if; + mal_PRINT(eval_res, result); + end procedure REP; + + procedure set_argv(e: inout env_ptr; program_file: inout line) is + variable argv_var_name: string(1 to 6) := "*ARGV*"; + variable argv_sym, argv_list: mal_val_ptr; + file f: text; + variable status: file_open_status; + variable one_line: line; + variable seq: mal_seq_ptr; + variable element: mal_val_ptr; + begin + program_file := null; + seq := new mal_seq(0 to -1); + file_open(status, f, external_name => "vhdl_argv.tmp", open_kind => read_mode); + if status = open_ok then + if not endfile(f) then + readline(f, program_file); + while not endfile(f) loop + readline(f, one_line); + new_string(one_line.all, element); + seq := new mal_seq'(seq.all & element); + end loop; + end if; + file_close(f); + end if; + new_seq_obj(mal_list, seq, argv_list); + new_symbol(argv_var_name, argv_sym); + env_set(e, argv_sym, argv_list); + end procedure set_argv; + + procedure repl is + variable is_eof: boolean; + variable program_file, input_line, result: line; + variable eval_sym, eval_fn, dummy_val, err: mal_val_ptr; + variable outer: env_ptr; + variable eval_func_name: string(1 to 4) := "eval"; + begin + outer := null; + new_env(repl_env, outer); + + -- core.EXT: defined using VHDL (see core.vhdl) + define_core_functions(repl_env); + new_symbol(eval_func_name, eval_sym); + new_nativefn(eval_func_name, eval_fn); + env_set(repl_env, eval_sym, eval_fn); + set_argv(repl_env, program_file); + + -- core.mal: defined using the language itself + RE("(def! *host-language* " & '"' & "vhdl" & '"' & ")", repl_env, dummy_val, err); + RE("(def! not (fn* (a) (if a false true)))", repl_env, dummy_val, err); + RE("(def! load-file (fn* (f) (eval (read-string (str " & '"' & "(do " & '"' & " (slurp f) " & '"' & "\nnil)" & '"' & ")))))", repl_env, dummy_val, err); + RE("(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)))))))", repl_env, dummy_val, err); + + if program_file /= null then + REP("(load-file " & '"' & program_file.all & '"' & ")", repl_env, result, err); + return; + end if; + + RE("(println (str " & '"' & "Mal [" & '"' & " *host-language* " & '"' & "]" & '"' & "))", repl_env, dummy_val, err); + loop + mal_readline("user> ", is_eof, input_line); + exit when is_eof; + next when input_line'length = 0; + REP(input_line.all, repl_env, result, err); + if err /= null then + pr_str(err, false, result); + result := new string'("Error: " & result.all); + end if; + if result /= null then + mal_printline(result.all); + end if; + deallocate(result); + deallocate(err); + end loop; + mal_printline(""); + end procedure repl; + +begin + repl; +end architecture test; diff --git a/impls/vhdl/types.vhdl b/impls/vhdl/types.vhdl index f481f64e77..58e28fb504 100644 --- a/impls/vhdl/types.vhdl +++ b/impls/vhdl/types.vhdl @@ -1,378 +1,378 @@ -library STD; -use STD.textio.all; - -package types is - - procedure debugline(l: inout line); - procedure debug(str: in string); - procedure debug(ch: in character); - procedure debug(i: in integer); - - type mal_type_tag is (mal_nil, mal_true, mal_false, mal_number, - mal_symbol, mal_string, mal_keyword, - mal_list, mal_vector, mal_hashmap, - mal_atom, mal_nativefn, mal_fn); - - -- Forward declarations - type mal_val; - type mal_seq; - type mal_func; - type env_record; - - type mal_val_ptr is access mal_val; - type mal_seq_ptr is access mal_seq; - type mal_func_ptr is access mal_func; - type env_ptr is access env_record; - - type mal_val is record - val_type: mal_type_tag; - number_val: integer; -- For types: number - string_val: line; -- For types: symbol, string, keyword, nativefn - seq_val: mal_seq_ptr; -- For types: list, vector, hashmap, atom - func_val: mal_func_ptr; -- For fn - meta_val: mal_val_ptr; - end record mal_val; - - type mal_seq is array (natural range <>) of mal_val_ptr; - - type mal_func is record - f_body: mal_val_ptr; - f_args: mal_val_ptr; - f_env: env_ptr; - f_is_macro: boolean; - end record mal_func; - - type env_record is record - outer: env_ptr; - data: mal_val_ptr; - end record env_record; - - procedure new_nil(obj: out mal_val_ptr); - procedure new_true(obj: out mal_val_ptr); - procedure new_false(obj: out mal_val_ptr); - procedure new_boolean(b: in boolean; obj: out mal_val_ptr); - procedure new_number(v: in integer; obj: out mal_val_ptr); - procedure new_symbol(name: in string; obj: out mal_val_ptr); - procedure new_symbol(name: inout line; obj: out mal_val_ptr); - procedure new_string(name: in string; obj: out mal_val_ptr); - procedure new_string(name: inout line; obj: out mal_val_ptr); - procedure new_keyword(name: in string; obj: out mal_val_ptr); - procedure new_keyword(name: inout line; obj: out mal_val_ptr); - procedure new_nativefn(name: in string; obj: out mal_val_ptr); - procedure new_fn(body_ast: inout mal_val_ptr; args: inout mal_val_ptr; env: inout env_ptr; obj: out mal_val_ptr); - procedure new_seq_obj(seq_type: in mal_type_tag; seq: inout mal_seq_ptr; obj: out mal_val_ptr); - procedure new_one_element_list(val: inout mal_val_ptr; obj: out mal_val_ptr); - procedure new_empty_hashmap(obj: out mal_val_ptr); - procedure new_atom(val: inout mal_val_ptr; obj: out mal_val_ptr); - - procedure hashmap_copy(hashmap: inout mal_val_ptr; obj: out mal_val_ptr); - procedure hashmap_get(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; val: out mal_val_ptr); - procedure hashmap_contains(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; ok: out boolean); - procedure hashmap_put(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; val: inout mal_val_ptr); - procedure hashmap_delete(hashmap: inout mal_val_ptr; key: inout mal_val_ptr); - procedure seq_drop_prefix(src: inout mal_val_ptr; prefix_length: in integer; result: out mal_val_ptr); - function is_sequential_type(t: in mal_type_tag) return boolean; - procedure equal_q(a: inout mal_val_ptr; b: inout mal_val_ptr; result: out boolean); -end package types; - -package body types is - - procedure debugline(l: inout line) is - variable l2: line; - begin - l2 := new string(1 to 7 + l'length); - l2(1 to l2'length) := "DEBUG: " & l.all; - writeline(output, l2); - end procedure debugline; - - procedure debug(str: in string) is - variable d: line; - begin - write(d, str); - debugline(d); - end procedure debug; - - procedure debug(ch: in character) is - variable d: line; - begin - write(d, ch); - debugline(d); - end procedure debug; - - procedure debug(i: in integer) is - variable d: line; - begin - write(d, i); - debugline(d); - end procedure debug; - - procedure new_nil(obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_nil, number_val => 0, string_val => null, seq_val => null, func_val => null, meta_val => null); - end procedure new_nil; - - procedure new_true(obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_true, number_val => 0, string_val => null, seq_val => null, func_val => null, meta_val => null); - end procedure new_true; - - procedure new_false(obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_false, number_val => 0, string_val => null, seq_val => null, func_val => null, meta_val => null); - end procedure new_false; - - procedure new_boolean(b: in boolean; obj: out mal_val_ptr) is - begin - if b then - new_true(obj); - else - new_false(obj); - end if; - end procedure new_boolean; - - procedure new_number(v: in integer; obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_number, number_val => v, string_val => null, seq_val => null, func_val => null, meta_val => null); - end procedure new_number; - - procedure new_symbol(name: in string; obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_symbol, number_val => 0, string_val => new string'(name), seq_val => null, func_val => null, meta_val => null); - end procedure new_symbol; - - procedure new_symbol(name: inout line; obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_symbol, number_val => 0, string_val => name, seq_val => null, func_val => null, meta_val => null); - end procedure new_symbol; - - procedure new_string(name: in string; obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_string, number_val => 0, string_val => new string'(name), seq_val => null, func_val => null, meta_val => null); - end procedure new_string; - - procedure new_string(name: inout line; obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_string, number_val => 0, string_val => name, seq_val => null, func_val => null, meta_val => null); - end procedure new_string; - - procedure new_keyword(name: in string; obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_keyword, number_val => 0, string_val => new string'(name), seq_val => null, func_val => null, meta_val => null); - end procedure new_keyword; - - procedure new_keyword(name: inout line; obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_keyword, number_val => 0, string_val => name, seq_val => null, func_val => null, meta_val => null); - end procedure new_keyword; - - procedure new_nativefn(name: in string; obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => mal_nativefn, number_val => 0, string_val => new string'(name), seq_val => null, func_val => null, meta_val => null); - end procedure new_nativefn; - - procedure new_fn(body_ast: inout mal_val_ptr; args: inout mal_val_ptr; env: inout env_ptr; obj: out mal_val_ptr) is - variable f: mal_func_ptr; - begin - f := new mal_func'(f_body => body_ast, f_args => args, f_env => env, f_is_macro => false); - obj := new mal_val'(val_type => mal_fn, number_val => 0, string_val => null, seq_val => null, func_val => f, meta_val => null); - end procedure new_fn; - - procedure new_seq_obj(seq_type: in mal_type_tag; seq: inout mal_seq_ptr; obj: out mal_val_ptr) is - begin - obj := new mal_val'(val_type => seq_type, number_val => 0, string_val => null, seq_val => seq, func_val => null, meta_val => null); - end procedure new_seq_obj; - - procedure new_one_element_list(val: inout mal_val_ptr; obj: out mal_val_ptr) is - variable seq: mal_seq_ptr; - begin - seq := new mal_seq(0 to 0); - seq(0) := val; - new_seq_obj(mal_list, seq, obj); - end procedure new_one_element_list; - - procedure new_empty_hashmap(obj: out mal_val_ptr) is - variable seq: mal_seq_ptr; - begin - seq := new mal_seq(0 to -1); - new_seq_obj(mal_hashmap, seq, obj); - end procedure new_empty_hashmap; - - procedure new_atom(val: inout mal_val_ptr; obj: out mal_val_ptr) is - variable atom_seq: mal_seq_ptr; - begin - atom_seq := new mal_seq(0 to 0); - atom_seq(0) := val; - new_seq_obj(mal_atom, atom_seq, obj); - end procedure new_atom; - - procedure hashmap_copy(hashmap: inout mal_val_ptr; obj: out mal_val_ptr) is - variable new_seq: mal_seq_ptr; - begin - new_seq := new mal_seq(hashmap.seq_val'range); - new_seq(new_seq'range) := hashmap.seq_val(hashmap.seq_val'range); - new_seq_obj(mal_hashmap, new_seq, obj); - end procedure hashmap_copy; - - procedure hashmap_get(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; val: out mal_val_ptr) is - variable i: natural; - variable curr_key: mal_val_ptr; - begin - i := 0; - while i < hashmap.seq_val'length loop - curr_key := hashmap.seq_val(i); - if key.val_type = curr_key.val_type and key.string_val.all = curr_key.string_val.all then - val := hashmap.seq_val(i + 1); - return; - end if; - i := i + 2; - end loop; - val := null; - end procedure hashmap_get; - - procedure hashmap_contains(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; ok: out boolean) is - variable val: mal_val_ptr; - begin - hashmap_get(hashmap, key, val); - if val = null then - ok := false; - else - ok := true; - end if; - end procedure hashmap_contains; - - procedure hashmap_put(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; val: inout mal_val_ptr) is - variable i: natural; - variable curr_key: mal_val_ptr; - variable new_seq: mal_seq_ptr; - begin - i := 0; - while i < hashmap.seq_val'length loop - curr_key := hashmap.seq_val(i); - if key.val_type = curr_key.val_type and key.string_val.all = curr_key.string_val.all then - hashmap.seq_val(i + 1) := val; - return; - end if; - i := i + 2; - end loop; - -- Not found so far, need to extend the seq - new_seq := new mal_seq(0 to hashmap.seq_val'length + 1); - for i in hashmap.seq_val'range loop - new_seq(i) := hashmap.seq_val(i); - end loop; - new_seq(new_seq'length - 2) := key; - new_seq(new_seq'length - 1) := val; - deallocate(hashmap.seq_val); - hashmap.seq_val := new_seq; - end procedure hashmap_put; - - procedure hashmap_delete(hashmap: inout mal_val_ptr; key: inout mal_val_ptr) is - variable i, dst_i: natural; - variable curr_key: mal_val_ptr; - variable new_seq: mal_seq_ptr; - variable found: boolean; - begin - hashmap_contains(hashmap, key, found); - if not found then - return; - end if; - i := 0; - dst_i := 0; - new_seq := new mal_seq(0 to hashmap.seq_val'high - 2); - while i < hashmap.seq_val'length loop - curr_key := hashmap.seq_val(i); - if key.val_type = curr_key.val_type and key.string_val.all = curr_key.string_val.all then - i := i + 2; - else - new_seq(dst_i to dst_i + 1) := hashmap.seq_val(i to i + 1); - dst_i := dst_i + 2; - i := i + 2; - end if; - end loop; - deallocate(hashmap.seq_val); - hashmap.seq_val := new_seq; - end procedure hashmap_delete; - - procedure seq_drop_prefix(src: inout mal_val_ptr; prefix_length: in integer; result: out mal_val_ptr) is - variable seq: mal_seq_ptr; - begin - seq := new mal_seq(0 to src.seq_val'length - 1 - prefix_length); - for i in seq'range loop - seq(i) := src.seq_val(i + prefix_length); - end loop; - new_seq_obj(src.val_type, seq, result); - end procedure seq_drop_prefix; - - function is_sequential_type(t: in mal_type_tag) return boolean is - begin - return t = mal_list or t = mal_vector; - end function is_sequential_type; - - procedure equal_seq_q(a: inout mal_val_ptr; b: inout mal_val_ptr; result: out boolean) is - variable i: integer; - variable is_element_equal: boolean; - begin - if a.seq_val'length = b.seq_val'length then - for i in a.seq_val'range loop - equal_q(a.seq_val(i), b.seq_val(i), is_element_equal); - if not is_element_equal then - result := false; - return; - end if; - end loop; - result := true; - else - result := false; - end if; - end procedure equal_seq_q; - - procedure equal_hashmap_q(a: inout mal_val_ptr; b: inout mal_val_ptr; result: out boolean) is - variable i: integer; - variable is_value_equal: boolean; - variable b_val: mal_val_ptr; - begin - if a.seq_val'length = b.seq_val'length then - i := 0; - while i < a.seq_val'length loop - hashmap_get(b, a.seq_val(i), b_val); - if b_val = null then - result := false; - return; - else - equal_q(a.seq_val(i + 1), b_val, is_value_equal); - if not is_value_equal then - result := false; - return; - end if; - end if; - i := i + 2; - end loop; - result := true; - else - result := false; - end if; - end procedure equal_hashmap_q; - - procedure equal_q(a: inout mal_val_ptr; b: inout mal_val_ptr; result: out boolean) is - begin - if is_sequential_type(a.val_type) and is_sequential_type(b.val_type) then - equal_seq_q(a, b, result); - elsif a.val_type = b.val_type then - case a.val_type is - when mal_nil | mal_true | mal_false => - result := true; - when mal_number => - result := a.number_val = b.number_val; - when mal_symbol | mal_string | mal_keyword => - result := a.string_val.all = b.string_val.all; - when mal_hashmap => - equal_hashmap_q(a, b, result); - when mal_atom => - equal_q(a.seq_val(0), b.seq_val(0), result); - when others => - result := false; - end case; - else - result := false; - end if; - end procedure equal_q; -end package body types; +library STD; +use STD.textio.all; + +package types is + + procedure debugline(l: inout line); + procedure debug(str: in string); + procedure debug(ch: in character); + procedure debug(i: in integer); + + type mal_type_tag is (mal_nil, mal_true, mal_false, mal_number, + mal_symbol, mal_string, mal_keyword, + mal_list, mal_vector, mal_hashmap, + mal_atom, mal_nativefn, mal_fn); + + -- Forward declarations + type mal_val; + type mal_seq; + type mal_func; + type env_record; + + type mal_val_ptr is access mal_val; + type mal_seq_ptr is access mal_seq; + type mal_func_ptr is access mal_func; + type env_ptr is access env_record; + + type mal_val is record + val_type: mal_type_tag; + number_val: integer; -- For types: number + string_val: line; -- For types: symbol, string, keyword, nativefn + seq_val: mal_seq_ptr; -- For types: list, vector, hashmap, atom + func_val: mal_func_ptr; -- For fn + meta_val: mal_val_ptr; + end record mal_val; + + type mal_seq is array (natural range <>) of mal_val_ptr; + + type mal_func is record + f_body: mal_val_ptr; + f_args: mal_val_ptr; + f_env: env_ptr; + f_is_macro: boolean; + end record mal_func; + + type env_record is record + outer: env_ptr; + data: mal_val_ptr; + end record env_record; + + procedure new_nil(obj: out mal_val_ptr); + procedure new_true(obj: out mal_val_ptr); + procedure new_false(obj: out mal_val_ptr); + procedure new_boolean(b: in boolean; obj: out mal_val_ptr); + procedure new_number(v: in integer; obj: out mal_val_ptr); + procedure new_symbol(name: in string; obj: out mal_val_ptr); + procedure new_symbol(name: inout line; obj: out mal_val_ptr); + procedure new_string(name: in string; obj: out mal_val_ptr); + procedure new_string(name: inout line; obj: out mal_val_ptr); + procedure new_keyword(name: in string; obj: out mal_val_ptr); + procedure new_keyword(name: inout line; obj: out mal_val_ptr); + procedure new_nativefn(name: in string; obj: out mal_val_ptr); + procedure new_fn(body_ast: inout mal_val_ptr; args: inout mal_val_ptr; env: inout env_ptr; obj: out mal_val_ptr); + procedure new_seq_obj(seq_type: in mal_type_tag; seq: inout mal_seq_ptr; obj: out mal_val_ptr); + procedure new_one_element_list(val: inout mal_val_ptr; obj: out mal_val_ptr); + procedure new_empty_hashmap(obj: out mal_val_ptr); + procedure new_atom(val: inout mal_val_ptr; obj: out mal_val_ptr); + + procedure hashmap_copy(hashmap: inout mal_val_ptr; obj: out mal_val_ptr); + procedure hashmap_get(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; val: out mal_val_ptr); + procedure hashmap_contains(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; ok: out boolean); + procedure hashmap_put(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; val: inout mal_val_ptr); + procedure hashmap_delete(hashmap: inout mal_val_ptr; key: inout mal_val_ptr); + procedure seq_drop_prefix(src: inout mal_val_ptr; prefix_length: in integer; result: out mal_val_ptr); + function is_sequential_type(t: in mal_type_tag) return boolean; + procedure equal_q(a: inout mal_val_ptr; b: inout mal_val_ptr; result: out boolean); +end package types; + +package body types is + + procedure debugline(l: inout line) is + variable l2: line; + begin + l2 := new string(1 to 7 + l'length); + l2(1 to l2'length) := "DEBUG: " & l.all; + writeline(output, l2); + end procedure debugline; + + procedure debug(str: in string) is + variable d: line; + begin + write(d, str); + debugline(d); + end procedure debug; + + procedure debug(ch: in character) is + variable d: line; + begin + write(d, ch); + debugline(d); + end procedure debug; + + procedure debug(i: in integer) is + variable d: line; + begin + write(d, i); + debugline(d); + end procedure debug; + + procedure new_nil(obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_nil, number_val => 0, string_val => null, seq_val => null, func_val => null, meta_val => null); + end procedure new_nil; + + procedure new_true(obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_true, number_val => 0, string_val => null, seq_val => null, func_val => null, meta_val => null); + end procedure new_true; + + procedure new_false(obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_false, number_val => 0, string_val => null, seq_val => null, func_val => null, meta_val => null); + end procedure new_false; + + procedure new_boolean(b: in boolean; obj: out mal_val_ptr) is + begin + if b then + new_true(obj); + else + new_false(obj); + end if; + end procedure new_boolean; + + procedure new_number(v: in integer; obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_number, number_val => v, string_val => null, seq_val => null, func_val => null, meta_val => null); + end procedure new_number; + + procedure new_symbol(name: in string; obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_symbol, number_val => 0, string_val => new string'(name), seq_val => null, func_val => null, meta_val => null); + end procedure new_symbol; + + procedure new_symbol(name: inout line; obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_symbol, number_val => 0, string_val => name, seq_val => null, func_val => null, meta_val => null); + end procedure new_symbol; + + procedure new_string(name: in string; obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_string, number_val => 0, string_val => new string'(name), seq_val => null, func_val => null, meta_val => null); + end procedure new_string; + + procedure new_string(name: inout line; obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_string, number_val => 0, string_val => name, seq_val => null, func_val => null, meta_val => null); + end procedure new_string; + + procedure new_keyword(name: in string; obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_keyword, number_val => 0, string_val => new string'(name), seq_val => null, func_val => null, meta_val => null); + end procedure new_keyword; + + procedure new_keyword(name: inout line; obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_keyword, number_val => 0, string_val => name, seq_val => null, func_val => null, meta_val => null); + end procedure new_keyword; + + procedure new_nativefn(name: in string; obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => mal_nativefn, number_val => 0, string_val => new string'(name), seq_val => null, func_val => null, meta_val => null); + end procedure new_nativefn; + + procedure new_fn(body_ast: inout mal_val_ptr; args: inout mal_val_ptr; env: inout env_ptr; obj: out mal_val_ptr) is + variable f: mal_func_ptr; + begin + f := new mal_func'(f_body => body_ast, f_args => args, f_env => env, f_is_macro => false); + obj := new mal_val'(val_type => mal_fn, number_val => 0, string_val => null, seq_val => null, func_val => f, meta_val => null); + end procedure new_fn; + + procedure new_seq_obj(seq_type: in mal_type_tag; seq: inout mal_seq_ptr; obj: out mal_val_ptr) is + begin + obj := new mal_val'(val_type => seq_type, number_val => 0, string_val => null, seq_val => seq, func_val => null, meta_val => null); + end procedure new_seq_obj; + + procedure new_one_element_list(val: inout mal_val_ptr; obj: out mal_val_ptr) is + variable seq: mal_seq_ptr; + begin + seq := new mal_seq(0 to 0); + seq(0) := val; + new_seq_obj(mal_list, seq, obj); + end procedure new_one_element_list; + + procedure new_empty_hashmap(obj: out mal_val_ptr) is + variable seq: mal_seq_ptr; + begin + seq := new mal_seq(0 to -1); + new_seq_obj(mal_hashmap, seq, obj); + end procedure new_empty_hashmap; + + procedure new_atom(val: inout mal_val_ptr; obj: out mal_val_ptr) is + variable atom_seq: mal_seq_ptr; + begin + atom_seq := new mal_seq(0 to 0); + atom_seq(0) := val; + new_seq_obj(mal_atom, atom_seq, obj); + end procedure new_atom; + + procedure hashmap_copy(hashmap: inout mal_val_ptr; obj: out mal_val_ptr) is + variable new_seq: mal_seq_ptr; + begin + new_seq := new mal_seq(hashmap.seq_val'range); + new_seq(new_seq'range) := hashmap.seq_val(hashmap.seq_val'range); + new_seq_obj(mal_hashmap, new_seq, obj); + end procedure hashmap_copy; + + procedure hashmap_get(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; val: out mal_val_ptr) is + variable i: natural; + variable curr_key: mal_val_ptr; + begin + i := 0; + while i < hashmap.seq_val'length loop + curr_key := hashmap.seq_val(i); + if key.val_type = curr_key.val_type and key.string_val.all = curr_key.string_val.all then + val := hashmap.seq_val(i + 1); + return; + end if; + i := i + 2; + end loop; + val := null; + end procedure hashmap_get; + + procedure hashmap_contains(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; ok: out boolean) is + variable val: mal_val_ptr; + begin + hashmap_get(hashmap, key, val); + if val = null then + ok := false; + else + ok := true; + end if; + end procedure hashmap_contains; + + procedure hashmap_put(hashmap: inout mal_val_ptr; key: inout mal_val_ptr; val: inout mal_val_ptr) is + variable i: natural; + variable curr_key: mal_val_ptr; + variable new_seq: mal_seq_ptr; + begin + i := 0; + while i < hashmap.seq_val'length loop + curr_key := hashmap.seq_val(i); + if key.val_type = curr_key.val_type and key.string_val.all = curr_key.string_val.all then + hashmap.seq_val(i + 1) := val; + return; + end if; + i := i + 2; + end loop; + -- Not found so far, need to extend the seq + new_seq := new mal_seq(0 to hashmap.seq_val'length + 1); + for i in hashmap.seq_val'range loop + new_seq(i) := hashmap.seq_val(i); + end loop; + new_seq(new_seq'length - 2) := key; + new_seq(new_seq'length - 1) := val; + deallocate(hashmap.seq_val); + hashmap.seq_val := new_seq; + end procedure hashmap_put; + + procedure hashmap_delete(hashmap: inout mal_val_ptr; key: inout mal_val_ptr) is + variable i, dst_i: natural; + variable curr_key: mal_val_ptr; + variable new_seq: mal_seq_ptr; + variable found: boolean; + begin + hashmap_contains(hashmap, key, found); + if not found then + return; + end if; + i := 0; + dst_i := 0; + new_seq := new mal_seq(0 to hashmap.seq_val'high - 2); + while i < hashmap.seq_val'length loop + curr_key := hashmap.seq_val(i); + if key.val_type = curr_key.val_type and key.string_val.all = curr_key.string_val.all then + i := i + 2; + else + new_seq(dst_i to dst_i + 1) := hashmap.seq_val(i to i + 1); + dst_i := dst_i + 2; + i := i + 2; + end if; + end loop; + deallocate(hashmap.seq_val); + hashmap.seq_val := new_seq; + end procedure hashmap_delete; + + procedure seq_drop_prefix(src: inout mal_val_ptr; prefix_length: in integer; result: out mal_val_ptr) is + variable seq: mal_seq_ptr; + begin + seq := new mal_seq(0 to src.seq_val'length - 1 - prefix_length); + for i in seq'range loop + seq(i) := src.seq_val(i + prefix_length); + end loop; + new_seq_obj(src.val_type, seq, result); + end procedure seq_drop_prefix; + + function is_sequential_type(t: in mal_type_tag) return boolean is + begin + return t = mal_list or t = mal_vector; + end function is_sequential_type; + + procedure equal_seq_q(a: inout mal_val_ptr; b: inout mal_val_ptr; result: out boolean) is + variable i: integer; + variable is_element_equal: boolean; + begin + if a.seq_val'length = b.seq_val'length then + for i in a.seq_val'range loop + equal_q(a.seq_val(i), b.seq_val(i), is_element_equal); + if not is_element_equal then + result := false; + return; + end if; + end loop; + result := true; + else + result := false; + end if; + end procedure equal_seq_q; + + procedure equal_hashmap_q(a: inout mal_val_ptr; b: inout mal_val_ptr; result: out boolean) is + variable i: integer; + variable is_value_equal: boolean; + variable b_val: mal_val_ptr; + begin + if a.seq_val'length = b.seq_val'length then + i := 0; + while i < a.seq_val'length loop + hashmap_get(b, a.seq_val(i), b_val); + if b_val = null then + result := false; + return; + else + equal_q(a.seq_val(i + 1), b_val, is_value_equal); + if not is_value_equal then + result := false; + return; + end if; + end if; + i := i + 2; + end loop; + result := true; + else + result := false; + end if; + end procedure equal_hashmap_q; + + procedure equal_q(a: inout mal_val_ptr; b: inout mal_val_ptr; result: out boolean) is + begin + if is_sequential_type(a.val_type) and is_sequential_type(b.val_type) then + equal_seq_q(a, b, result); + elsif a.val_type = b.val_type then + case a.val_type is + when mal_nil | mal_true | mal_false => + result := true; + when mal_number => + result := a.number_val = b.number_val; + when mal_symbol | mal_string | mal_keyword => + result := a.string_val.all = b.string_val.all; + when mal_hashmap => + equal_hashmap_q(a, b, result); + when mal_atom => + equal_q(a.seq_val(0), b.seq_val(0), result); + when others => + result := false; + end case; + else + result := false; + end if; + end procedure equal_q; +end package body types; diff --git a/impls/vimscript/.gitignore b/impls/vimscript/.gitignore index 925b4b450f..39acc59ec7 100644 --- a/impls/vimscript/.gitignore +++ b/impls/vimscript/.gitignore @@ -1,2 +1,2 @@ -/*.o -/*.so +/*.o +/*.so diff --git a/impls/vimscript/Dockerfile b/impls/vimscript/Dockerfile index 35345f57fd..9fb79ff067 100644 --- a/impls/vimscript/Dockerfile +++ b/impls/vimscript/Dockerfile @@ -1,34 +1,34 @@ -FROM ubuntu:vivid -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# To build the readline plugin -RUN apt-get -y install g++ - -# Vim 8.0 -RUN apt-get -y install bzip2 -RUN cd /tmp && curl -O ftp://ftp.vim.org/pub/vim/unix/vim-8.0.tar.bz2 \ - && tar xjf /tmp/vim-8.0.tar.bz2 \ - && cd vim80 && make && make install \ - && cd /tmp && rm -r /tmp/vim-8.0.tar.bz2 /tmp/vim80 - -ENV HOME /mal +FROM ubuntu:vivid +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# To build the readline plugin +RUN apt-get -y install g++ + +# Vim 8.0 +RUN apt-get -y install bzip2 +RUN cd /tmp && curl -O ftp://ftp.vim.org/pub/vim/unix/vim-8.0.tar.bz2 \ + && tar xjf /tmp/vim-8.0.tar.bz2 \ + && cd vim80 && make && make install \ + && cd /tmp && rm -r /tmp/vim-8.0.tar.bz2 /tmp/vim80 + +ENV HOME /mal diff --git a/impls/vimscript/Makefile b/impls/vimscript/Makefile index da5409c3bf..a52c1a9f02 100644 --- a/impls/vimscript/Makefile +++ b/impls/vimscript/Makefile @@ -1,30 +1,30 @@ -SOURCES_BASE = readline.vim types.vim reader.vim printer.vim -SOURCES_LISP = env.vim core.vim stepA_mal.vim -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -all: libvimextras.so - -dist: mal.vim mal - -mal.vim: $(SOURCES) - cat $+ | grep -v "^source " > $@ - -mal: mal.vim - echo "#!/bin/sh" > $@ - echo "\":\" ; rundir=\`dirname \$$0\`" >> $@ - echo "\":\" ; export LD_LIBRARY_PATH=\`readlink -f \$$rundir\`" >> $@ - echo "\":\" ; exec vim -i NONE -V1 -nNesS \"\$$0\" -- \"\$$@\" 2>/dev/null" >> $@ - cat $< >> $@ - chmod +x $@ - - -libvimextras.so: vimextras.o - $(CC) -g -shared -o $@ $< -lreadline - -vimextras.o: vimextras.c - $(CC) -g -fPIC -c $< -o $@ - -clean: - rm -f vimextras.o libvimextras.so mal.vim mal - -.PHONY: clean +SOURCES_BASE = readline.vim types.vim reader.vim printer.vim +SOURCES_LISP = env.vim core.vim stepA_mal.vim +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +all: libvimextras.so + +dist: mal.vim mal + +mal.vim: $(SOURCES) + cat $+ | grep -v "^source " > $@ + +mal: mal.vim + echo "#!/bin/sh" > $@ + echo "\":\" ; rundir=\`dirname \$$0\`" >> $@ + echo "\":\" ; export LD_LIBRARY_PATH=\`readlink -f \$$rundir\`" >> $@ + echo "\":\" ; exec vim -i NONE -V1 -nNesS \"\$$0\" -- \"\$$@\" 2>/dev/null" >> $@ + cat $< >> $@ + chmod +x $@ + + +libvimextras.so: vimextras.o + $(CC) -g -shared -o $@ $< -lreadline + +vimextras.o: vimextras.c + $(CC) -g -fPIC -c $< -o $@ + +clean: + rm -f vimextras.o libvimextras.so mal.vim mal + +.PHONY: clean diff --git a/impls/vimscript/core.vim b/impls/vimscript/core.vim index fc4cfa4eea..fce97780e5 100644 --- a/impls/vimscript/core.vim +++ b/impls/vimscript/core.vim @@ -1,235 +1,235 @@ -" core module - -function MalAssoc(args) - let hash = copy(a:args[0].val) - let new_elements = HashBuild(a:args[1:]) - call extend(hash, new_elements.val) - return HashNew(hash) -endfunction - -function MalDissoc(args) - let hash = copy(a:args[0].val) - for keyobj in a:args[1:] - let key = HashMakeKey(keyobj) - if has_key(hash, key) - call remove(hash, key) - endif - endfor - return HashNew(hash) -endfunction - -function MalGet(args) - if !HashQ(a:args[0]) - return g:MalNil - endif - let hash = a:args[0].val - let key = HashMakeKey(a:args[1]) - return get(hash, key, g:MalNil) -endfunction - -function MalContainsQ(args) - if !HashQ(a:args[0]) - return FalseNew() - endif - let hash = a:args[0].val - let key = HashMakeKey(a:args[1]) - return BoolNew(has_key(hash, key)) -endfunction - -function MalKeys(args) - let listobjs = [] - for keyname in keys(a:args[0].val) - let keyobj = HashParseKey(keyname) - call add(listobjs, keyobj) - endfor - return ListNew(listobjs) -endfunction - -function MalReadLine(args) - let [eof, line] = Readline(a:args[0].val) - return eof ? g:MalNil : StringNew(line) -endfunction - -function MalCons(args) - let items = copy(a:args[1].val) - call insert(items, a:args[0]) - return ListNew(items) -endfunction - -function MalConcat(args) - let res = [] - for list in a:args - let res = res + list.val - endfor - return ListNew(res) -endfunction - -function MalApply(args) - let funcobj = a:args[0] - let rest = a:args[1:] - if len(rest) == 0 - let funcargs = [] - elseif len(rest) == 1 - let funcargs = rest[-1].val - else - let funcargs = rest[:-2] + rest[-1].val - endif - if NativeFunctionQ(funcobj) - return NativeFuncInvoke(funcobj, ListNew(funcargs)) - elseif FunctionQ(funcobj) - return FuncInvoke(funcobj, ListNew(funcargs)) - else - throw "Not a function" - endif -endfunction - -function MalMap(args) - let funcobj = a:args[0] - let res = [] - for item in a:args[1].val - unlet! mappeditem - if NativeFunctionQ(funcobj) - let mappeditem = NativeFuncInvoke(funcobj, ListNew([item])) - elseif FunctionQ(funcobj) - let mappeditem = FuncInvoke(funcobj, ListNew([item])) - else - throw "Not a function" - endif - call add(res, mappeditem) - endfor - return ListNew(res) -endfunction - -function MalThrow(args) - unlet! g:MalExceptionObj - let g:MalExceptionObj = a:args[0] - throw "__MalException__" -endfunction - -function ConjList(list, elements) - let newlist = a:list - for e in a:elements - let newlist = MalCons([e, newlist]) - endfor - return newlist -endfunction - -function ConjVector(vector, elements) - let items = copy(a:vector.val) - for e in a:elements - call add(items, e) - endfor - return VectorNew(items) -endfunction - -function MalConj(args) - if ListQ(a:args[0]) - return ConjList(a:args[0], a:args[1:]) - elseif VectorQ(a:args[0]) - return ConjVector(a:args[0], a:args[1:]) - endif -endfunction - -function MalSeq(args) - let obj = a:args[0] - if EmptyQ(obj) - return g:MalNil - elseif ListQ(obj) - return obj - elseif VectorQ(obj) - return ListNew(obj.val) - elseif StringQ(obj) - return ListNew(map(split(obj.val, '\zs'), {_, c -> StringNew(c)})) - endif - throw "seq requires string or list or vector or nil" -endfunction - -function VimToMal(e) - if type(a:e) == type(0) - return IntegerNew(a:e) - elseif type(a:e) == type(0.0) - return FloatNew(a:e) - elseif type(a:e) == type("") - return StringNew(a:e) - elseif type(a:e) == type([]) - let res = [] - for v in a:e - call add(res, VimToMal(v)) - endfor - return ListNew(res) - elseif type(a:e) == type({}) - let res = {} - for [k,v] in items(a:e) - let keystring = HashMakeKey(StringNew(k)) - let res[keystring] = VimToMal(v) - endfor - return HashNew(res) - else - return g:MalNil - endif -endfunction - -let CoreNs = { - \ "=": NewNativeFnLambda({a -> BoolNew(EqualQ(a[0], a[1]))}), - \ "<": NewNativeFnLambda({a -> BoolNew(a[0].val < a[1].val)}), - \ "<=": NewNativeFnLambda({a -> BoolNew(a[0].val <= a[1].val)}), - \ ">": NewNativeFnLambda({a -> BoolNew(a[0].val > a[1].val)}), - \ ">=": NewNativeFnLambda({a -> BoolNew(a[0].val >= a[1].val)}), - \ "+": NewNativeFnLambda({a -> IntegerNew(a[0].val + a[1].val)}), - \ "-": NewNativeFnLambda({a -> IntegerNew(a[0].val - a[1].val)}), - \ "*": NewNativeFnLambda({a -> IntegerNew(a[0].val * a[1].val)}), - \ "/": NewNativeFnLambda({a -> IntegerNew(a[0].val / a[1].val)}), - \ "time-ms": NewNativeFnLambda({a -> IntegerNew(libcallnr("libvimextras.so", "vimtimems", 0))}), - \ "nil?": NewNativeFnLambda({a -> BoolNew(NilQ(a[0]))}), - \ "true?": NewNativeFnLambda({a -> BoolNew(TrueQ(a[0]))}), - \ "false?": NewNativeFnLambda({a -> BoolNew(FalseQ(a[0]))}), - \ "symbol": NewNativeFnLambda({a -> SymbolNew(a[0].val)}), - \ "symbol?": NewNativeFnLambda({a -> BoolNew(SymbolQ(a[0]))}), - \ "string?": NewNativeFnLambda({a -> BoolNew(StringQ(a[0]))}), - \ "keyword": NewNativeFnLambda({a -> KeywordNew(a[0].val)}), - \ "keyword?": NewNativeFnLambda({a -> BoolNew(KeywordQ(a[0]))}), - \ "number?": NewNativeFnLambda({a -> BoolNew(IntegerQ(a[0]))}), - \ "fn?": NewNativeFnLambda({a -> BoolNew(NativeFunctionQ(a[0]) || FunctionQ(a[0]))}), - \ "macro?": NewNativeFnLambda({a -> BoolNew(MacroQ(a[0]))}), - \ "list": NewNativeFnLambda({a -> ListNew(a)}), - \ "list?": NewNativeFnLambda({a -> BoolNew(ListQ(a[0]))}), - \ "vector": NewNativeFnLambda({a -> VectorNew(a)}), - \ "vector?": NewNativeFnLambda({a -> BoolNew(VectorQ(a[0]))}), - \ "sequential?": NewNativeFnLambda({a -> BoolNew(SequentialQ(a[0]))}), - \ "hash-map": NewNativeFnLambda({a -> HashBuild(a)}), - \ "map?": NewNativeFnLambda({a -> BoolNew(HashQ(a[0]))}), - \ "empty?": NewNativeFnLambda({a -> BoolNew(EmptyQ(a[0]))}), - \ "count": NewNativeFnLambda({a -> IntegerNew(ListCount(a[0]))}), - \ "assoc": NewNativeFn("MalAssoc"), - \ "dissoc": NewNativeFn("MalDissoc"), - \ "get": NewNativeFn("MalGet"), - \ "contains?": NewNativeFn("MalContainsQ"), - \ "keys": NewNativeFn("MalKeys"), - \ "vals": NewNativeFnLambda({a -> ListNew(values(a[0].val))}), - \ "pr-str": NewNativeFnLambda({a -> StringNew(join(map(copy(a), {_, e -> PrStr(e, 1)}), " "))}), - \ "str": NewNativeFnLambda({a -> StringNew(join(map(copy(a), {_, e -> PrStr(e, 0)}), ""))}), - \ "prn": NewNativeFnLambda({a -> [PrintLn(join(map(copy(a), {_, e -> PrStr(e, 1)}), " ")), g:MalNil][1]}), - \ "println": NewNativeFnLambda({a -> [PrintLn(join(map(copy(a), {_, e -> PrStr(e, 0)}), " ")), g:MalNil][1]}), - \ "read-string": NewNativeFnLambda({a -> ReadStr(a[0].val)}), - \ "readline": NewNativeFn("MalReadLine"), - \ "slurp": NewNativeFnLambda({a -> StringNew(join(readfile(a[0].val, "b"), "\n"))}), - \ "cons": NewNativeFn("MalCons"), - \ "concat": NewNativeFn("MalConcat"), - \ "vec": NewNativeFnLambda({a -> VectorNew(a[0].val)}), - \ "first": NewNativeFnLambda({a -> NilQ(a[0]) ? g:MalNil : ListFirst(a[0])}), - \ "nth": NewNativeFnLambda({a -> ListNth(a[0], a[1].val)}), - \ "rest": NewNativeFnLambda({a -> NilQ(a[0]) ? ListNew([]) : ListRest(a[0])}), - \ "apply": NewNativeFn("MalApply"), - \ "map": NewNativeFn("MalMap"), - \ "throw": NewNativeFn("MalThrow"), - \ "conj": NewNativeFn("MalConj"), - \ "seq": NewNativeFn("MalSeq"), - \ "meta": NewNativeFnLambda({a -> ObjMeta(a[0])}), - \ "with-meta": NewNativeFnLambda({a -> ObjNewWithMeta(a[0].type, copy(a[0].val), a[1])}), - \ "atom": NewNativeFnLambda({a -> AtomNew(a[0])}), - \ "atom?": NewNativeFnLambda({a -> BoolNew(AtomQ(a[0]))}), - \ "deref": NewNativeFnLambda({a -> a[0].val}), - \ "reset!": NewNativeFnLambda({a -> ObjSetValue(a[0], a[1])}), - \ "swap!": NewNativeFnLambda({a -> ObjSetValue(a[0], MalApply([a[1], ListNew([a[0].val] + a[2:])]))}), - \ "vim*": NewNativeFnLambda({a -> VimToMal(eval(a[0].val))}) - \ } +" core module + +function MalAssoc(args) + let hash = copy(a:args[0].val) + let new_elements = HashBuild(a:args[1:]) + call extend(hash, new_elements.val) + return HashNew(hash) +endfunction + +function MalDissoc(args) + let hash = copy(a:args[0].val) + for keyobj in a:args[1:] + let key = HashMakeKey(keyobj) + if has_key(hash, key) + call remove(hash, key) + endif + endfor + return HashNew(hash) +endfunction + +function MalGet(args) + if !HashQ(a:args[0]) + return g:MalNil + endif + let hash = a:args[0].val + let key = HashMakeKey(a:args[1]) + return get(hash, key, g:MalNil) +endfunction + +function MalContainsQ(args) + if !HashQ(a:args[0]) + return FalseNew() + endif + let hash = a:args[0].val + let key = HashMakeKey(a:args[1]) + return BoolNew(has_key(hash, key)) +endfunction + +function MalKeys(args) + let listobjs = [] + for keyname in keys(a:args[0].val) + let keyobj = HashParseKey(keyname) + call add(listobjs, keyobj) + endfor + return ListNew(listobjs) +endfunction + +function MalReadLine(args) + let [eof, line] = Readline(a:args[0].val) + return eof ? g:MalNil : StringNew(line) +endfunction + +function MalCons(args) + let items = copy(a:args[1].val) + call insert(items, a:args[0]) + return ListNew(items) +endfunction + +function MalConcat(args) + let res = [] + for list in a:args + let res = res + list.val + endfor + return ListNew(res) +endfunction + +function MalApply(args) + let funcobj = a:args[0] + let rest = a:args[1:] + if len(rest) == 0 + let funcargs = [] + elseif len(rest) == 1 + let funcargs = rest[-1].val + else + let funcargs = rest[:-2] + rest[-1].val + endif + if NativeFunctionQ(funcobj) + return NativeFuncInvoke(funcobj, ListNew(funcargs)) + elseif FunctionQ(funcobj) + return FuncInvoke(funcobj, ListNew(funcargs)) + else + throw "Not a function" + endif +endfunction + +function MalMap(args) + let funcobj = a:args[0] + let res = [] + for item in a:args[1].val + unlet! mappeditem + if NativeFunctionQ(funcobj) + let mappeditem = NativeFuncInvoke(funcobj, ListNew([item])) + elseif FunctionQ(funcobj) + let mappeditem = FuncInvoke(funcobj, ListNew([item])) + else + throw "Not a function" + endif + call add(res, mappeditem) + endfor + return ListNew(res) +endfunction + +function MalThrow(args) + unlet! g:MalExceptionObj + let g:MalExceptionObj = a:args[0] + throw "__MalException__" +endfunction + +function ConjList(list, elements) + let newlist = a:list + for e in a:elements + let newlist = MalCons([e, newlist]) + endfor + return newlist +endfunction + +function ConjVector(vector, elements) + let items = copy(a:vector.val) + for e in a:elements + call add(items, e) + endfor + return VectorNew(items) +endfunction + +function MalConj(args) + if ListQ(a:args[0]) + return ConjList(a:args[0], a:args[1:]) + elseif VectorQ(a:args[0]) + return ConjVector(a:args[0], a:args[1:]) + endif +endfunction + +function MalSeq(args) + let obj = a:args[0] + if EmptyQ(obj) + return g:MalNil + elseif ListQ(obj) + return obj + elseif VectorQ(obj) + return ListNew(obj.val) + elseif StringQ(obj) + return ListNew(map(split(obj.val, '\zs'), {_, c -> StringNew(c)})) + endif + throw "seq requires string or list or vector or nil" +endfunction + +function VimToMal(e) + if type(a:e) == type(0) + return IntegerNew(a:e) + elseif type(a:e) == type(0.0) + return FloatNew(a:e) + elseif type(a:e) == type("") + return StringNew(a:e) + elseif type(a:e) == type([]) + let res = [] + for v in a:e + call add(res, VimToMal(v)) + endfor + return ListNew(res) + elseif type(a:e) == type({}) + let res = {} + for [k,v] in items(a:e) + let keystring = HashMakeKey(StringNew(k)) + let res[keystring] = VimToMal(v) + endfor + return HashNew(res) + else + return g:MalNil + endif +endfunction + +let CoreNs = { + \ "=": NewNativeFnLambda({a -> BoolNew(EqualQ(a[0], a[1]))}), + \ "<": NewNativeFnLambda({a -> BoolNew(a[0].val < a[1].val)}), + \ "<=": NewNativeFnLambda({a -> BoolNew(a[0].val <= a[1].val)}), + \ ">": NewNativeFnLambda({a -> BoolNew(a[0].val > a[1].val)}), + \ ">=": NewNativeFnLambda({a -> BoolNew(a[0].val >= a[1].val)}), + \ "+": NewNativeFnLambda({a -> IntegerNew(a[0].val + a[1].val)}), + \ "-": NewNativeFnLambda({a -> IntegerNew(a[0].val - a[1].val)}), + \ "*": NewNativeFnLambda({a -> IntegerNew(a[0].val * a[1].val)}), + \ "/": NewNativeFnLambda({a -> IntegerNew(a[0].val / a[1].val)}), + \ "time-ms": NewNativeFnLambda({a -> IntegerNew(libcallnr("libvimextras.so", "vimtimems", 0))}), + \ "nil?": NewNativeFnLambda({a -> BoolNew(NilQ(a[0]))}), + \ "true?": NewNativeFnLambda({a -> BoolNew(TrueQ(a[0]))}), + \ "false?": NewNativeFnLambda({a -> BoolNew(FalseQ(a[0]))}), + \ "symbol": NewNativeFnLambda({a -> SymbolNew(a[0].val)}), + \ "symbol?": NewNativeFnLambda({a -> BoolNew(SymbolQ(a[0]))}), + \ "string?": NewNativeFnLambda({a -> BoolNew(StringQ(a[0]))}), + \ "keyword": NewNativeFnLambda({a -> KeywordNew(a[0].val)}), + \ "keyword?": NewNativeFnLambda({a -> BoolNew(KeywordQ(a[0]))}), + \ "number?": NewNativeFnLambda({a -> BoolNew(IntegerQ(a[0]))}), + \ "fn?": NewNativeFnLambda({a -> BoolNew(NativeFunctionQ(a[0]) || FunctionQ(a[0]))}), + \ "macro?": NewNativeFnLambda({a -> BoolNew(MacroQ(a[0]))}), + \ "list": NewNativeFnLambda({a -> ListNew(a)}), + \ "list?": NewNativeFnLambda({a -> BoolNew(ListQ(a[0]))}), + \ "vector": NewNativeFnLambda({a -> VectorNew(a)}), + \ "vector?": NewNativeFnLambda({a -> BoolNew(VectorQ(a[0]))}), + \ "sequential?": NewNativeFnLambda({a -> BoolNew(SequentialQ(a[0]))}), + \ "hash-map": NewNativeFnLambda({a -> HashBuild(a)}), + \ "map?": NewNativeFnLambda({a -> BoolNew(HashQ(a[0]))}), + \ "empty?": NewNativeFnLambda({a -> BoolNew(EmptyQ(a[0]))}), + \ "count": NewNativeFnLambda({a -> IntegerNew(ListCount(a[0]))}), + \ "assoc": NewNativeFn("MalAssoc"), + \ "dissoc": NewNativeFn("MalDissoc"), + \ "get": NewNativeFn("MalGet"), + \ "contains?": NewNativeFn("MalContainsQ"), + \ "keys": NewNativeFn("MalKeys"), + \ "vals": NewNativeFnLambda({a -> ListNew(values(a[0].val))}), + \ "pr-str": NewNativeFnLambda({a -> StringNew(join(map(copy(a), {_, e -> PrStr(e, 1)}), " "))}), + \ "str": NewNativeFnLambda({a -> StringNew(join(map(copy(a), {_, e -> PrStr(e, 0)}), ""))}), + \ "prn": NewNativeFnLambda({a -> [PrintLn(join(map(copy(a), {_, e -> PrStr(e, 1)}), " ")), g:MalNil][1]}), + \ "println": NewNativeFnLambda({a -> [PrintLn(join(map(copy(a), {_, e -> PrStr(e, 0)}), " ")), g:MalNil][1]}), + \ "read-string": NewNativeFnLambda({a -> ReadStr(a[0].val)}), + \ "readline": NewNativeFn("MalReadLine"), + \ "slurp": NewNativeFnLambda({a -> StringNew(join(readfile(a[0].val, "b"), "\n"))}), + \ "cons": NewNativeFn("MalCons"), + \ "concat": NewNativeFn("MalConcat"), + \ "vec": NewNativeFnLambda({a -> VectorNew(a[0].val)}), + \ "first": NewNativeFnLambda({a -> NilQ(a[0]) ? g:MalNil : ListFirst(a[0])}), + \ "nth": NewNativeFnLambda({a -> ListNth(a[0], a[1].val)}), + \ "rest": NewNativeFnLambda({a -> NilQ(a[0]) ? ListNew([]) : ListRest(a[0])}), + \ "apply": NewNativeFn("MalApply"), + \ "map": NewNativeFn("MalMap"), + \ "throw": NewNativeFn("MalThrow"), + \ "conj": NewNativeFn("MalConj"), + \ "seq": NewNativeFn("MalSeq"), + \ "meta": NewNativeFnLambda({a -> ObjMeta(a[0])}), + \ "with-meta": NewNativeFnLambda({a -> ObjNewWithMeta(a[0].type, copy(a[0].val), a[1])}), + \ "atom": NewNativeFnLambda({a -> AtomNew(a[0])}), + \ "atom?": NewNativeFnLambda({a -> BoolNew(AtomQ(a[0]))}), + \ "deref": NewNativeFnLambda({a -> a[0].val}), + \ "reset!": NewNativeFnLambda({a -> ObjSetValue(a[0], a[1])}), + \ "swap!": NewNativeFnLambda({a -> ObjSetValue(a[0], MalApply([a[1], ListNew([a[0].val] + a[2:])]))}), + \ "vim*": NewNativeFnLambda({a -> VimToMal(eval(a[0].val))}) + \ } diff --git a/impls/vimscript/env.vim b/impls/vimscript/env.vim index 3316e19356..cccf5f35c5 100644 --- a/impls/vimscript/env.vim +++ b/impls/vimscript/env.vim @@ -1,61 +1,61 @@ -" env module - -let Env = {} - -function NewEnv(outer) - let e = copy(g:Env) - let e.data = {} - let e.outer = a:outer - return e -endfunction - -function NewEnvWithBinds(outer, binds, exprs) - let env = NewEnv(a:outer) - let i = 0 - while i < ListCount(a:binds) - let varname = ListNth(a:binds, i).val - if varname == "&" - let restvarname = ListNth(a:binds, i + 1).val - let restvarvalues = ListDrop(a:exprs, i) - call env.set(restvarname, restvarvalues) - break - else - unlet! varvalue - let varvalue = ListNth(a:exprs, i) - call env.set(varname, varvalue) - endif - let i = i + 1 - endwhile - return env -endfunction - -function Env.find(key) dict - if has_key(self.data, a:key) - return self - elseif empty(self.outer) - return "" - else - return self.outer.find(a:key) - endif -endfunction - -function Env.set(key, value) dict - let self.data[a:key] = a:value - return a:value -endfunction - -function Env.get(key) dict - let env = self.find(a:key) - if empty(env) - throw "'" . a:key . "' not found" - endif - return env.data[a:key] -endfunction - -function Env.root() dict - let curr = self - while !empty(curr.outer) - let curr = curr.outer - endwhile - return curr -endfunction +" env module + +let Env = {} + +function NewEnv(outer) + let e = copy(g:Env) + let e.data = {} + let e.outer = a:outer + return e +endfunction + +function NewEnvWithBinds(outer, binds, exprs) + let env = NewEnv(a:outer) + let i = 0 + while i < ListCount(a:binds) + let varname = ListNth(a:binds, i).val + if varname == "&" + let restvarname = ListNth(a:binds, i + 1).val + let restvarvalues = ListDrop(a:exprs, i) + call env.set(restvarname, restvarvalues) + break + else + unlet! varvalue + let varvalue = ListNth(a:exprs, i) + call env.set(varname, varvalue) + endif + let i = i + 1 + endwhile + return env +endfunction + +function Env.find(key) dict + if has_key(self.data, a:key) + return self + elseif empty(self.outer) + return "" + else + return self.outer.find(a:key) + endif +endfunction + +function Env.set(key, value) dict + let self.data[a:key] = a:value + return a:value +endfunction + +function Env.get(key) dict + let env = self.find(a:key) + if empty(env) + throw "'" . a:key . "' not found" + endif + return env.data[a:key] +endfunction + +function Env.root() dict + let curr = self + while !empty(curr.outer) + let curr = curr.outer + endwhile + return curr +endfunction diff --git a/impls/vimscript/printer.vim b/impls/vimscript/printer.vim index 18d21b5597..8b38583358 100644 --- a/impls/vimscript/printer.vim +++ b/impls/vimscript/printer.vim @@ -1,60 +1,60 @@ -" printer module - -function PrStr(ast, readable) - let obj = a:ast - let r = a:readable - if ListQ(obj) - let ret = [] - for e in obj.val - call add(ret, PrStr(e, r)) - endfor - return "(" . join(ret, " ") . ")" - elseif VectorQ(obj) - let ret = [] - for e in obj.val - call add(ret, PrStr(e, r)) - endfor - return "[" . join(ret, " ") . "]" - elseif HashQ(obj) - let ret = [] - for [k, v] in items(obj.val) - let keyobj = HashParseKey(k) - call add(ret, PrStr(keyobj, r)) - call add(ret, PrStr(v, r)) - endfor - return "{" . join(ret, " ") . "}" - elseif MacroQ(obj) - let numargs = ListCount(obj.val.params) - return "" - elseif FunctionQ(obj) - let numargs = ListCount(obj.val.params) - return "" - elseif NativeFunctionQ(obj) - let funcname = obj.val.name - return "" - elseif AtomQ(obj) - return "(atom " . PrStr(obj.val, 1) . ")" - elseif KeywordQ(obj) - return ':' . obj.val - elseif StringQ(obj) - if r - let str = obj.val - let str = substitute(str, '\\', '\\\\', "g") - let str = substitute(str, '"', '\\"', "g") - let str = substitute(str, "\n", '\\n', "g") - return '"' . str . '"' - else - return obj.val - endif - elseif NilQ(obj) - return "nil" - elseif TrueQ(obj) - return "true" - elseif FalseQ(obj) - return "false" - elseif IntegerQ(obj) || FloatQ(obj) - return string(obj.val) - else - return obj.val - end -endfunction +" printer module + +function PrStr(ast, readable) + let obj = a:ast + let r = a:readable + if ListQ(obj) + let ret = [] + for e in obj.val + call add(ret, PrStr(e, r)) + endfor + return "(" . join(ret, " ") . ")" + elseif VectorQ(obj) + let ret = [] + for e in obj.val + call add(ret, PrStr(e, r)) + endfor + return "[" . join(ret, " ") . "]" + elseif HashQ(obj) + let ret = [] + for [k, v] in items(obj.val) + let keyobj = HashParseKey(k) + call add(ret, PrStr(keyobj, r)) + call add(ret, PrStr(v, r)) + endfor + return "{" . join(ret, " ") . "}" + elseif MacroQ(obj) + let numargs = ListCount(obj.val.params) + return "" + elseif FunctionQ(obj) + let numargs = ListCount(obj.val.params) + return "" + elseif NativeFunctionQ(obj) + let funcname = obj.val.name + return "" + elseif AtomQ(obj) + return "(atom " . PrStr(obj.val, 1) . ")" + elseif KeywordQ(obj) + return ':' . obj.val + elseif StringQ(obj) + if r + let str = obj.val + let str = substitute(str, '\\', '\\\\', "g") + let str = substitute(str, '"', '\\"', "g") + let str = substitute(str, "\n", '\\n', "g") + return '"' . str . '"' + else + return obj.val + endif + elseif NilQ(obj) + return "nil" + elseif TrueQ(obj) + return "true" + elseif FalseQ(obj) + return "false" + elseif IntegerQ(obj) || FloatQ(obj) + return string(obj.val) + else + return obj.val + end +endfunction diff --git a/impls/vimscript/reader.vim b/impls/vimscript/reader.vim index 5d86dec67c..7c21940274 100644 --- a/impls/vimscript/reader.vim +++ b/impls/vimscript/reader.vim @@ -1,165 +1,165 @@ -" reader module - -let Reader = {} - -function NewReader(tokens) - let r = copy(g:Reader) - let r.tokens = a:tokens - let r.pos = 0 - return r -endfunction - -function Reader.peek() dict - return self.tokens[self.pos] -endfunction - -function Reader.nexttoken() dict - let self.pos = self.pos + 1 - return self.tokens[self.pos - 1] -endfunction - -function Tokenize(str) - let tokenize_pat = "[[:blank:]\\n,]*" . - \ "\\(" . - \ "\\~@\\|" . - \ "[\\[\\]{}()'`~^@]\\|" . - \ "\"\\%(\\\\.\\|[^\\\\\"]\\)*\"\\|" . - \ "\"\\%(\\\\.\\|[^\\\\\"]\\)*\\|" . - \ ";[^\\n]*\\|" . - \ "[^[:blank:]\\n\\[\\]{}('\"`,;)]*" . - \ "\\)" - let tokens = [] - let pos = 0 - while 1 - let mat = matchlist(a:str, tokenize_pat, pos) - if len(mat) == 0 || mat[0] == "" - break - endif - if mat[1] != "" && mat[1][0] != ";" - call add(tokens, mat[1]) - endif - let pos = matchend(a:str, tokenize_pat, pos) - endwhile - return tokens -endfunction - -function UnescapeChar(seq) - if a:seq == '\"' - return '"' - elseif a:seq == '\n' - return "\n" - elseif a:seq == '\\' - return '\' - else - return a:seq - endif -endfunction - -function ParseString(token) - return substitute(a:token[1:-2], '\\.', '\=UnescapeChar(submatch(0))', "g") -endfunction - -function ReadAtom(rdr) - let token = a:rdr.nexttoken() - if token =~ "^-\\?[0-9]\\+$" - return IntegerNew(str2nr(token)) - elseif token =~ "^-\\?[0-9][0-9.]*$" - return FloatNew(str2float(token)) - elseif token =~ "^\"\\%(\\\\.\\|[^\\\\\"]\\)*\"$" - return StringNew(ParseString(token)) - elseif token =~ "^\".*$" - throw "expected '\"', got EOF" - elseif token =~ "^:" - return KeywordNew(token[1:-1]) - elseif token == "nil" - return g:MalNil - elseif token == "true" - return TrueNew() - elseif token == "false" - return FalseNew() - else - return SymbolNew(token) - endif -endfunction - -function ReadTokensList(rdr, start, last) - let elements = [] - let token = a:rdr.nexttoken() - if token != a:start - throw "expected '" . a:start . "'" - endif - let token = a:rdr.peek() - while token != a:last - call add(elements, ReadForm(a:rdr)) - try - let token = a:rdr.peek() - catch - throw "expected '" . a:last . "', got EOF" - endtry - endwhile - call a:rdr.nexttoken() - return elements -endfunction - -function ReadList(rdr) - let elements = ReadTokensList(a:rdr, "(", ")") - return ListNew(elements) -endfunction - -function ReadVector(rdr) - let elements = ReadTokensList(a:rdr, "[", "]") - return VectorNew(elements) -endfunction - -function ReadHash(rdr) - let elements = ReadTokensList(a:rdr, "{", "}") - return HashBuild(elements) -endfunction - -function ReadForm(rdr) - let token = a:rdr.peek() - if token == ";" - return "" - elseif token == "'" - call a:rdr.nexttoken() - return ListNew([SymbolNew("quote"), ReadForm(a:rdr)]) - elseif token == "`" - call a:rdr.nexttoken() - return ListNew([SymbolNew("quasiquote"), ReadForm(a:rdr)]) - elseif token == "~" - call a:rdr.nexttoken() - return ListNew([SymbolNew("unquote"), ReadForm(a:rdr)]) - elseif token == "~@" - call a:rdr.nexttoken() - return ListNew([SymbolNew("splice-unquote"), ReadForm(a:rdr)]) - elseif token == "^" - call a:rdr.nexttoken() - let meta = ReadForm(a:rdr) - return ListNew([SymbolNew("with-meta"), ReadForm(a:rdr), meta]) - elseif token == "@" - call a:rdr.nexttoken() - return ListNew([SymbolNew("deref"), ReadForm(a:rdr)]) - elseif token == "(" - return ReadList(a:rdr)") - elseif token == ")" - throw "unexpected ')'" - elseif token == "[" - return ReadVector(a:rdr) - elseif token == "]" - throw "unexpected ']'" - elseif token == "{" - return ReadHash(a:rdr) - elseif token == "}" - throw "unexpected '}'" - else - return ReadAtom(a:rdr) - endif -endfunction - -function ReadStr(str) - let tokens = Tokenize(a:str) - if empty(tokens) - return "" - endif - return ReadForm(NewReader(tokens)) -endfunction +" reader module + +let Reader = {} + +function NewReader(tokens) + let r = copy(g:Reader) + let r.tokens = a:tokens + let r.pos = 0 + return r +endfunction + +function Reader.peek() dict + return self.tokens[self.pos] +endfunction + +function Reader.nexttoken() dict + let self.pos = self.pos + 1 + return self.tokens[self.pos - 1] +endfunction + +function Tokenize(str) + let tokenize_pat = "[[:blank:]\\n,]*" . + \ "\\(" . + \ "\\~@\\|" . + \ "[\\[\\]{}()'`~^@]\\|" . + \ "\"\\%(\\\\.\\|[^\\\\\"]\\)*\"\\|" . + \ "\"\\%(\\\\.\\|[^\\\\\"]\\)*\\|" . + \ ";[^\\n]*\\|" . + \ "[^[:blank:]\\n\\[\\]{}('\"`,;)]*" . + \ "\\)" + let tokens = [] + let pos = 0 + while 1 + let mat = matchlist(a:str, tokenize_pat, pos) + if len(mat) == 0 || mat[0] == "" + break + endif + if mat[1] != "" && mat[1][0] != ";" + call add(tokens, mat[1]) + endif + let pos = matchend(a:str, tokenize_pat, pos) + endwhile + return tokens +endfunction + +function UnescapeChar(seq) + if a:seq == '\"' + return '"' + elseif a:seq == '\n' + return "\n" + elseif a:seq == '\\' + return '\' + else + return a:seq + endif +endfunction + +function ParseString(token) + return substitute(a:token[1:-2], '\\.', '\=UnescapeChar(submatch(0))', "g") +endfunction + +function ReadAtom(rdr) + let token = a:rdr.nexttoken() + if token =~ "^-\\?[0-9]\\+$" + return IntegerNew(str2nr(token)) + elseif token =~ "^-\\?[0-9][0-9.]*$" + return FloatNew(str2float(token)) + elseif token =~ "^\"\\%(\\\\.\\|[^\\\\\"]\\)*\"$" + return StringNew(ParseString(token)) + elseif token =~ "^\".*$" + throw "expected '\"', got EOF" + elseif token =~ "^:" + return KeywordNew(token[1:-1]) + elseif token == "nil" + return g:MalNil + elseif token == "true" + return TrueNew() + elseif token == "false" + return FalseNew() + else + return SymbolNew(token) + endif +endfunction + +function ReadTokensList(rdr, start, last) + let elements = [] + let token = a:rdr.nexttoken() + if token != a:start + throw "expected '" . a:start . "'" + endif + let token = a:rdr.peek() + while token != a:last + call add(elements, ReadForm(a:rdr)) + try + let token = a:rdr.peek() + catch + throw "expected '" . a:last . "', got EOF" + endtry + endwhile + call a:rdr.nexttoken() + return elements +endfunction + +function ReadList(rdr) + let elements = ReadTokensList(a:rdr, "(", ")") + return ListNew(elements) +endfunction + +function ReadVector(rdr) + let elements = ReadTokensList(a:rdr, "[", "]") + return VectorNew(elements) +endfunction + +function ReadHash(rdr) + let elements = ReadTokensList(a:rdr, "{", "}") + return HashBuild(elements) +endfunction + +function ReadForm(rdr) + let token = a:rdr.peek() + if token == ";" + return "" + elseif token == "'" + call a:rdr.nexttoken() + return ListNew([SymbolNew("quote"), ReadForm(a:rdr)]) + elseif token == "`" + call a:rdr.nexttoken() + return ListNew([SymbolNew("quasiquote"), ReadForm(a:rdr)]) + elseif token == "~" + call a:rdr.nexttoken() + return ListNew([SymbolNew("unquote"), ReadForm(a:rdr)]) + elseif token == "~@" + call a:rdr.nexttoken() + return ListNew([SymbolNew("splice-unquote"), ReadForm(a:rdr)]) + elseif token == "^" + call a:rdr.nexttoken() + let meta = ReadForm(a:rdr) + return ListNew([SymbolNew("with-meta"), ReadForm(a:rdr), meta]) + elseif token == "@" + call a:rdr.nexttoken() + return ListNew([SymbolNew("deref"), ReadForm(a:rdr)]) + elseif token == "(" + return ReadList(a:rdr)") + elseif token == ")" + throw "unexpected ')'" + elseif token == "[" + return ReadVector(a:rdr) + elseif token == "]" + throw "unexpected ']'" + elseif token == "{" + return ReadHash(a:rdr) + elseif token == "}" + throw "unexpected '}'" + else + return ReadAtom(a:rdr) + endif +endfunction + +function ReadStr(str) + let tokens = Tokenize(a:str) + if empty(tokens) + return "" + endif + return ReadForm(NewReader(tokens)) +endfunction diff --git a/impls/vimscript/readline.vim b/impls/vimscript/readline.vim index af4d57f596..687d5881ec 100644 --- a/impls/vimscript/readline.vim +++ b/impls/vimscript/readline.vim @@ -1,23 +1,23 @@ -function PrintLn(str) - let lines = split(a:str, "\n", 1) - call writefile(lines, "/dev/stdout", "a") -endfunction - -function s:buildlibvimreadline() - if !filereadable("libvimextras.so") - call system("make libvimextras.so") - endif -endfunction - -" Returns [is_eof, line_string] -function Readline(prompt) - " Use the vimreadline() function defined in vimextras.c and compiled - " into libvimextras.so - call s:buildlibvimreadline() - let res = libcall("libvimextras.so", "vimreadline", a:prompt) - if res[0] == "E" - return [1, ""] - else - return [0, res[1:]] - endif -endfunction +function PrintLn(str) + let lines = split(a:str, "\n", 1) + call writefile(lines, "/dev/stdout", "a") +endfunction + +function s:buildlibvimreadline() + if !filereadable("libvimextras.so") + call system("make libvimextras.so") + endif +endfunction + +" Returns [is_eof, line_string] +function Readline(prompt) + " Use the vimreadline() function defined in vimextras.c and compiled + " into libvimextras.so + call s:buildlibvimreadline() + let res = libcall("libvimextras.so", "vimreadline", a:prompt) + if res[0] == "E" + return [1, ""] + else + return [0, res[1:]] + endif +endfunction diff --git a/impls/vimscript/run b/impls/vimscript/run index 48e666b057..7db71e9da3 100755 --- a/impls/vimscript/run +++ b/impls/vimscript/run @@ -1,3 +1,3 @@ -#!/bin/bash -cd $(dirname $0) -exec ./run_vimscript.sh ./${STEP:-stepA_mal}.vim "${@}" +#!/bin/bash +cd $(dirname $0) +exec ./run_vimscript.sh ./${STEP:-stepA_mal}.vim "${@}" diff --git a/impls/vimscript/run_vimscript.sh b/impls/vimscript/run_vimscript.sh index cf263c8f7f..fd87117bcd 100755 --- a/impls/vimscript/run_vimscript.sh +++ b/impls/vimscript/run_vimscript.sh @@ -1,17 +1,17 @@ -#!/bin/sh - -# Run Vim in ex mode (-e) and run the given script ($1) on startup. Our scripts -# end with 'qall!' which causes actual Vim UI to never start up. -# -# Set environment variable DEBUG=1 to allow more verbose error output from Vim. -# -# See: http://vim.wikia.com/wiki/Vim_as_a_system_interpreter_for_vimscript - -rundir=`dirname $0` -export LD_LIBRARY_PATH=`readlink -f $rundir` -vimscriptfile="$1" -shift -if [ x$DEBUG = x ] ; then - exec 2> /dev/null -fi -exec vim -i NONE -V1 -nNesS $vimscriptfile -- "$@" | cat +#!/bin/sh + +# Run Vim in ex mode (-e) and run the given script ($1) on startup. Our scripts +# end with 'qall!' which causes actual Vim UI to never start up. +# +# Set environment variable DEBUG=1 to allow more verbose error output from Vim. +# +# See: http://vim.wikia.com/wiki/Vim_as_a_system_interpreter_for_vimscript + +rundir=`dirname $0` +export LD_LIBRARY_PATH=`readlink -f $rundir` +vimscriptfile="$1" +shift +if [ x$DEBUG = x ] ; then + exec 2> /dev/null +fi +exec vim -i NONE -V1 -nNesS $vimscriptfile -- "$@" | cat diff --git a/impls/vimscript/step0_repl.vim b/impls/vimscript/step0_repl.vim index 1fbcf32c62..8daeb3a3d2 100644 --- a/impls/vimscript/step0_repl.vim +++ b/impls/vimscript/step0_repl.vim @@ -1,29 +1,29 @@ -source readline.vim - -function READ(str) - return a:str -endfunction - -function EVAL(ast, env) - return a:ast -endfunction - -function PRINT(exp) - return a:exp -endfunction - -function REP(str) - return PRINT(EVAL(READ(a:str), {})) -endfunction - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - call PrintLn(REP(line)) -endwhile -qall! +source readline.vim + +function READ(str) + return a:str +endfunction + +function EVAL(ast, env) + return a:ast +endfunction + +function PRINT(exp) + return a:exp +endfunction + +function REP(str) + return PRINT(EVAL(READ(a:str), {})) +endfunction + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + call PrintLn(REP(line)) +endwhile +qall! diff --git a/impls/vimscript/step1_read_print.vim b/impls/vimscript/step1_read_print.vim index ca4bc1680c..2ed56b8fa9 100644 --- a/impls/vimscript/step1_read_print.vim +++ b/impls/vimscript/step1_read_print.vim @@ -1,36 +1,36 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim - -function READ(str) - return ReadStr(a:str) -endfunction - -function EVAL(ast, env) - return a:ast -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function REP(str) - return PRINT(EVAL(READ(a:str), {})) -endfunction - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line)) - catch - call PrintLn("Error: " . v:exception) - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim + +function READ(str) + return ReadStr(a:str) +endfunction + +function EVAL(ast, env) + return a:ast +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function REP(str) + return PRINT(EVAL(READ(a:str), {})) +endfunction + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line)) + catch + call PrintLn("Error: " . v:exception) + endtry +endwhile +qall! diff --git a/impls/vimscript/step2_eval.vim b/impls/vimscript/step2_eval.vim index 5b476d3492..8db11209e4 100644 --- a/impls/vimscript/step2_eval.vim +++ b/impls/vimscript/step2_eval.vim @@ -1,76 +1,76 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim - -function READ(str) - return ReadStr(a:str) -endfunction - -function EvalAst(ast, env) - if SymbolQ(a:ast) - let varname = a:ast.val - if !has_key(a:env, varname) - throw "'" . varname . "' not found" - end - return a:env[varname] - elseif ListQ(a:ast) - return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif VectorQ(a:ast) - return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif HashQ(a:ast) - let ret = {} - for [k,v] in items(a:ast.val) - let newval = EVAL(v, a:env) - let ret[k] = newval - endfor - return HashNew(ret) - else - return a:ast - end -endfunction - -function EVAL(ast, env) - if !ListQ(a:ast) - return EvalAst(a:ast, a:env) - end - if EmptyQ(a:ast) - return a:ast - endif - - " apply list - let el = EvalAst(a:ast, a:env) - - let Fn = el.val[0] - return Fn(el.val[1:-1]) -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function REP(str, env) - return PRINT(EVAL(READ(a:str), a:env)) -endfunction - -let repl_env = {} -let repl_env["+"] = {a -> IntegerNew(a[0].val + a[1].val)} -let repl_env["-"] = {a -> IntegerNew(a[0].val - a[1].val)} -let repl_env["*"] = {a -> IntegerNew(a[0].val * a[1].val)} -let repl_env["/"] = {a -> IntegerNew(a[0].val / a[1].val)} - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line, repl_env)) - catch - call PrintLn("ERROR: " . v:exception) - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim + +function READ(str) + return ReadStr(a:str) +endfunction + +function EvalAst(ast, env) + if SymbolQ(a:ast) + let varname = a:ast.val + if !has_key(a:env, varname) + throw "'" . varname . "' not found" + end + return a:env[varname] + elseif ListQ(a:ast) + return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif VectorQ(a:ast) + return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif HashQ(a:ast) + let ret = {} + for [k,v] in items(a:ast.val) + let newval = EVAL(v, a:env) + let ret[k] = newval + endfor + return HashNew(ret) + else + return a:ast + end +endfunction + +function EVAL(ast, env) + if !ListQ(a:ast) + return EvalAst(a:ast, a:env) + end + if EmptyQ(a:ast) + return a:ast + endif + + " apply list + let el = EvalAst(a:ast, a:env) + + let Fn = el.val[0] + return Fn(el.val[1:-1]) +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function REP(str, env) + return PRINT(EVAL(READ(a:str), a:env)) +endfunction + +let repl_env = {} +let repl_env["+"] = {a -> IntegerNew(a[0].val + a[1].val)} +let repl_env["-"] = {a -> IntegerNew(a[0].val - a[1].val)} +let repl_env["*"] = {a -> IntegerNew(a[0].val * a[1].val)} +let repl_env["/"] = {a -> IntegerNew(a[0].val / a[1].val)} + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line, repl_env)) + catch + call PrintLn("ERROR: " . v:exception) + endtry +endwhile +qall! diff --git a/impls/vimscript/step3_env.vim b/impls/vimscript/step3_env.vim index 813944dbc9..41b4a1212b 100644 --- a/impls/vimscript/step3_env.vim +++ b/impls/vimscript/step3_env.vim @@ -1,92 +1,92 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim -source env.vim - -function READ(str) - return ReadStr(a:str) -endfunction - -function EvalAst(ast, env) - if SymbolQ(a:ast) - let varname = a:ast.val - return a:env.get(varname) - elseif ListQ(a:ast) - return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif VectorQ(a:ast) - return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif HashQ(a:ast) - let ret = {} - for [k,v] in items(a:ast.val) - let newval = EVAL(v, a:env) - let ret[k] = newval - endfor - return HashNew(ret) - else - return a:ast - end -endfunction - -function EVAL(ast, env) - if !ListQ(a:ast) - return EvalAst(a:ast, a:env) - end - if EmptyQ(a:ast) - return a:ast - endif - - let first_symbol = a:ast.val[0].val - if first_symbol == "def!" - let a1 = a:ast.val[1] - let a2 = a:ast.val[2] - return a:env.set(a1.val, EVAL(a2, a:env)) - elseif first_symbol == "let*" - let a1 = a:ast.val[1] - let a2 = a:ast.val[2] - let let_env = NewEnv(a:env) - let let_binds = a1.val - let i = 0 - while i < len(let_binds) - call let_env.set(let_binds[i].val, EVAL(let_binds[i+1], let_env)) - let i = i + 2 - endwhile - return EVAL(a2, let_env) - else - " apply list - let el = EvalAst(a:ast, a:env) - let Fn = el.val[0] - return Fn(el.val[1:-1]) - endif - -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function REP(str, env) - return PRINT(EVAL(READ(a:str), a:env)) -endfunction - -let repl_env = NewEnv("") -call repl_env.set("+", {a -> IntegerNew(a[0].val + a[1].val)}) -call repl_env.set("-", {a -> IntegerNew(a[0].val - a[1].val)}) -call repl_env.set("*", {a -> IntegerNew(a[0].val * a[1].val)}) -call repl_env.set("/", {a -> IntegerNew(a[0].val / a[1].val)}) - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line, repl_env)) - catch - call PrintLn("Error: " . v:exception) - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim +source env.vim + +function READ(str) + return ReadStr(a:str) +endfunction + +function EvalAst(ast, env) + if SymbolQ(a:ast) + let varname = a:ast.val + return a:env.get(varname) + elseif ListQ(a:ast) + return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif VectorQ(a:ast) + return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif HashQ(a:ast) + let ret = {} + for [k,v] in items(a:ast.val) + let newval = EVAL(v, a:env) + let ret[k] = newval + endfor + return HashNew(ret) + else + return a:ast + end +endfunction + +function EVAL(ast, env) + if !ListQ(a:ast) + return EvalAst(a:ast, a:env) + end + if EmptyQ(a:ast) + return a:ast + endif + + let first_symbol = a:ast.val[0].val + if first_symbol == "def!" + let a1 = a:ast.val[1] + let a2 = a:ast.val[2] + return a:env.set(a1.val, EVAL(a2, a:env)) + elseif first_symbol == "let*" + let a1 = a:ast.val[1] + let a2 = a:ast.val[2] + let let_env = NewEnv(a:env) + let let_binds = a1.val + let i = 0 + while i < len(let_binds) + call let_env.set(let_binds[i].val, EVAL(let_binds[i+1], let_env)) + let i = i + 2 + endwhile + return EVAL(a2, let_env) + else + " apply list + let el = EvalAst(a:ast, a:env) + let Fn = el.val[0] + return Fn(el.val[1:-1]) + endif + +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function REP(str, env) + return PRINT(EVAL(READ(a:str), a:env)) +endfunction + +let repl_env = NewEnv("") +call repl_env.set("+", {a -> IntegerNew(a[0].val + a[1].val)}) +call repl_env.set("-", {a -> IntegerNew(a[0].val - a[1].val)}) +call repl_env.set("*", {a -> IntegerNew(a[0].val * a[1].val)}) +call repl_env.set("/", {a -> IntegerNew(a[0].val / a[1].val)}) + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line, repl_env)) + catch + call PrintLn("Error: " . v:exception) + endtry +endwhile +qall! diff --git a/impls/vimscript/step4_if_fn_do.vim b/impls/vimscript/step4_if_fn_do.vim index 60664469ad..a2f43c61bc 100644 --- a/impls/vimscript/step4_if_fn_do.vim +++ b/impls/vimscript/step4_if_fn_do.vim @@ -1,120 +1,120 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim -source env.vim -source core.vim - -function READ(str) - return ReadStr(a:str) -endfunction - -function EvalAst(ast, env) - if SymbolQ(a:ast) - let varname = a:ast.val - return a:env.get(varname) - elseif ListQ(a:ast) - return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif VectorQ(a:ast) - return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif HashQ(a:ast) - let ret = {} - for [k,v] in items(a:ast.val) - let newval = EVAL(v, a:env) - let ret[k] = newval - endfor - return HashNew(ret) - else - return a:ast - end -endfunction - -function EVAL(ast, env) - if !ListQ(a:ast) - return EvalAst(a:ast, a:env) - end - if EmptyQ(a:ast) - return a:ast - endif - - let first = ListFirst(a:ast) - let first_symbol = SymbolQ(first) ? first.val : "" - if first_symbol == "def!" - let a1 = a:ast.val[1] - let a2 = a:ast.val[2] - let ret = a:env.set(a1.val, EVAL(a2, a:env)) - return ret - elseif first_symbol == "let*" - let a1 = a:ast.val[1] - let a2 = a:ast.val[2] - let let_env = NewEnv(a:env) - let let_binds = a1.val - let i = 0 - while i < len(let_binds) - call let_env.set(let_binds[i].val, EVAL(let_binds[i+1], let_env)) - let i = i + 2 - endwhile - return EVAL(a2, let_env) - elseif first_symbol == "if" - let condvalue = EVAL(a:ast.val[1], a:env) - if FalseQ(condvalue) || NilQ(condvalue) - if len(a:ast.val) < 4 - return g:MalNil - else - return EVAL(a:ast.val[3], a:env) - endif - else - return EVAL(a:ast.val[2], a:env) - endif - elseif first_symbol == "do" - let el = EvalAst(ListRest(a:ast), a:env) - return el.val[-1] - elseif first_symbol == "fn*" - let fn = NewFn(ListNth(a:ast, 2), a:env, ListNth(a:ast, 1)) - return fn - else - " apply list - let el = EvalAst(a:ast, a:env) - let funcobj = ListFirst(el) - let args = ListRest(el) - if NativeFunctionQ(funcobj) - return NativeFuncInvoke(funcobj, args) - elseif FunctionQ(funcobj) - return FuncInvoke(funcobj, args) - else - throw "Not a function" - endif - endif -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function REP(str, env) - return PRINT(EVAL(READ(a:str), a:env)) -endfunction - -let repl_env = NewEnv("") - -for [k, Fn] in items(CoreNs) - call repl_env.set(k, Fn) -endfor - -call REP("(def! not (fn* (a) (if a false true)))", repl_env) - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line, repl_env)) - catch - call PrintLn("Error: " . v:exception) - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim +source env.vim +source core.vim + +function READ(str) + return ReadStr(a:str) +endfunction + +function EvalAst(ast, env) + if SymbolQ(a:ast) + let varname = a:ast.val + return a:env.get(varname) + elseif ListQ(a:ast) + return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif VectorQ(a:ast) + return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif HashQ(a:ast) + let ret = {} + for [k,v] in items(a:ast.val) + let newval = EVAL(v, a:env) + let ret[k] = newval + endfor + return HashNew(ret) + else + return a:ast + end +endfunction + +function EVAL(ast, env) + if !ListQ(a:ast) + return EvalAst(a:ast, a:env) + end + if EmptyQ(a:ast) + return a:ast + endif + + let first = ListFirst(a:ast) + let first_symbol = SymbolQ(first) ? first.val : "" + if first_symbol == "def!" + let a1 = a:ast.val[1] + let a2 = a:ast.val[2] + let ret = a:env.set(a1.val, EVAL(a2, a:env)) + return ret + elseif first_symbol == "let*" + let a1 = a:ast.val[1] + let a2 = a:ast.val[2] + let let_env = NewEnv(a:env) + let let_binds = a1.val + let i = 0 + while i < len(let_binds) + call let_env.set(let_binds[i].val, EVAL(let_binds[i+1], let_env)) + let i = i + 2 + endwhile + return EVAL(a2, let_env) + elseif first_symbol == "if" + let condvalue = EVAL(a:ast.val[1], a:env) + if FalseQ(condvalue) || NilQ(condvalue) + if len(a:ast.val) < 4 + return g:MalNil + else + return EVAL(a:ast.val[3], a:env) + endif + else + return EVAL(a:ast.val[2], a:env) + endif + elseif first_symbol == "do" + let el = EvalAst(ListRest(a:ast), a:env) + return el.val[-1] + elseif first_symbol == "fn*" + let fn = NewFn(ListNth(a:ast, 2), a:env, ListNth(a:ast, 1)) + return fn + else + " apply list + let el = EvalAst(a:ast, a:env) + let funcobj = ListFirst(el) + let args = ListRest(el) + if NativeFunctionQ(funcobj) + return NativeFuncInvoke(funcobj, args) + elseif FunctionQ(funcobj) + return FuncInvoke(funcobj, args) + else + throw "Not a function" + endif + endif +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function REP(str, env) + return PRINT(EVAL(READ(a:str), a:env)) +endfunction + +let repl_env = NewEnv("") + +for [k, Fn] in items(CoreNs) + call repl_env.set(k, Fn) +endfor + +call REP("(def! not (fn* (a) (if a false true)))", repl_env) + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line, repl_env)) + catch + call PrintLn("Error: " . v:exception) + endtry +endwhile +qall! diff --git a/impls/vimscript/step5_tco.vim b/impls/vimscript/step5_tco.vim index 87fd6271ed..2f8b02dec0 100644 --- a/impls/vimscript/step5_tco.vim +++ b/impls/vimscript/step5_tco.vim @@ -1,133 +1,133 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim -source env.vim -source core.vim - -function READ(str) - return ReadStr(a:str) -endfunction - -function EvalAst(ast, env) - if SymbolQ(a:ast) - let varname = a:ast.val - return a:env.get(varname) - elseif ListQ(a:ast) - return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif VectorQ(a:ast) - return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif HashQ(a:ast) - let ret = {} - for [k,v] in items(a:ast.val) - let newval = EVAL(v, a:env) - let ret[k] = newval - endfor - return HashNew(ret) - else - return a:ast - end -endfunction - -function EVAL(ast, env) - let ast = a:ast - let env = a:env - - while 1 - if !ListQ(ast) - return EvalAst(ast, env) - end - if EmptyQ(ast) - return ast - endif - - let first = ListFirst(ast) - let first_symbol = SymbolQ(first) ? first.val : "" - if first_symbol == "def!" - let a1 = ast.val[1] - let a2 = ast.val[2] - let ret = env.set(a1.val, EVAL(a2, env)) - return ret - elseif first_symbol == "let*" - let a1 = ast.val[1] - let a2 = ast.val[2] - let env = NewEnv(env) - let let_binds = a1.val - let i = 0 - while i < len(let_binds) - call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) - let i = i + 2 - endwhile - let ast = a2 - " TCO - elseif first_symbol == "if" - let condvalue = EVAL(ast.val[1], env) - if FalseQ(condvalue) || NilQ(condvalue) - if len(ast.val) < 4 - return g:MalNil - else - let ast = ast.val[3] - endif - else - let ast = ast.val[2] - endif - " TCO - elseif first_symbol == "do" - let astlist = ast.val - call EvalAst(ListNew(astlist[1:-2]), env) - let ast = astlist[-1] - " TCO - elseif first_symbol == "fn*" - let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) - return fn - else - " apply list - let el = EvalAst(ast, env) - let funcobj = ListFirst(el) - let args = ListRest(el) - if NativeFunctionQ(funcobj) - return NativeFuncInvoke(funcobj, args) - elseif FunctionQ(funcobj) - let fn = funcobj.val - let ast = fn.ast - let env = NewEnvWithBinds(fn.env, fn.params, args) - " TCO - else - throw "Not a function" - endif - endif - endwhile -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function REP(str, env) - return PRINT(EVAL(READ(a:str), a:env)) -endfunction - -set maxfuncdepth=10000 -let repl_env = NewEnv("") - -for [k, v] in items(CoreNs) - call repl_env.set(k, v) -endfor - -call REP("(def! not (fn* (a) (if a false true)))", repl_env) - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line, repl_env)) - catch - call PrintLn("Error: " . v:exception) - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim +source env.vim +source core.vim + +function READ(str) + return ReadStr(a:str) +endfunction + +function EvalAst(ast, env) + if SymbolQ(a:ast) + let varname = a:ast.val + return a:env.get(varname) + elseif ListQ(a:ast) + return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif VectorQ(a:ast) + return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif HashQ(a:ast) + let ret = {} + for [k,v] in items(a:ast.val) + let newval = EVAL(v, a:env) + let ret[k] = newval + endfor + return HashNew(ret) + else + return a:ast + end +endfunction + +function EVAL(ast, env) + let ast = a:ast + let env = a:env + + while 1 + if !ListQ(ast) + return EvalAst(ast, env) + end + if EmptyQ(ast) + return ast + endif + + let first = ListFirst(ast) + let first_symbol = SymbolQ(first) ? first.val : "" + if first_symbol == "def!" + let a1 = ast.val[1] + let a2 = ast.val[2] + let ret = env.set(a1.val, EVAL(a2, env)) + return ret + elseif first_symbol == "let*" + let a1 = ast.val[1] + let a2 = ast.val[2] + let env = NewEnv(env) + let let_binds = a1.val + let i = 0 + while i < len(let_binds) + call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) + let i = i + 2 + endwhile + let ast = a2 + " TCO + elseif first_symbol == "if" + let condvalue = EVAL(ast.val[1], env) + if FalseQ(condvalue) || NilQ(condvalue) + if len(ast.val) < 4 + return g:MalNil + else + let ast = ast.val[3] + endif + else + let ast = ast.val[2] + endif + " TCO + elseif first_symbol == "do" + let astlist = ast.val + call EvalAst(ListNew(astlist[1:-2]), env) + let ast = astlist[-1] + " TCO + elseif first_symbol == "fn*" + let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) + return fn + else + " apply list + let el = EvalAst(ast, env) + let funcobj = ListFirst(el) + let args = ListRest(el) + if NativeFunctionQ(funcobj) + return NativeFuncInvoke(funcobj, args) + elseif FunctionQ(funcobj) + let fn = funcobj.val + let ast = fn.ast + let env = NewEnvWithBinds(fn.env, fn.params, args) + " TCO + else + throw "Not a function" + endif + endif + endwhile +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function REP(str, env) + return PRINT(EVAL(READ(a:str), a:env)) +endfunction + +set maxfuncdepth=10000 +let repl_env = NewEnv("") + +for [k, v] in items(CoreNs) + call repl_env.set(k, v) +endfor + +call REP("(def! not (fn* (a) (if a false true)))", repl_env) + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line, repl_env)) + catch + call PrintLn("Error: " . v:exception) + endtry +endwhile +qall! diff --git a/impls/vimscript/step6_file.vim b/impls/vimscript/step6_file.vim index 8a5cfb589f..233da61632 100644 --- a/impls/vimscript/step6_file.vim +++ b/impls/vimscript/step6_file.vim @@ -1,153 +1,153 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim -source env.vim -source core.vim - -function READ(str) - return ReadStr(a:str) -endfunction - -function EvalAst(ast, env) - if SymbolQ(a:ast) - let varname = a:ast.val - return a:env.get(varname) - elseif ListQ(a:ast) - return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif VectorQ(a:ast) - return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif HashQ(a:ast) - let ret = {} - for [k,v] in items(a:ast.val) - let newval = EVAL(v, a:env) - let ret[k] = newval - endfor - return HashNew(ret) - else - return a:ast - end -endfunction - -function EVAL(ast, env) - let ast = a:ast - let env = a:env - - while 1 - if !ListQ(ast) - return EvalAst(ast, env) - end - if EmptyQ(ast) - return ast - endif - - let first = ListFirst(ast) - let first_symbol = SymbolQ(first) ? first.val : "" - if first_symbol == "def!" - let a1 = ast.val[1] - let a2 = ast.val[2] - let ret = env.set(a1.val, EVAL(a2, env)) - return ret - elseif first_symbol == "let*" - let a1 = ast.val[1] - let a2 = ast.val[2] - let env = NewEnv(env) - let let_binds = a1.val - let i = 0 - while i < len(let_binds) - call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) - let i = i + 2 - endwhile - let ast = a2 - " TCO - elseif first_symbol == "if" - let condvalue = EVAL(ast.val[1], env) - if FalseQ(condvalue) || NilQ(condvalue) - if len(ast.val) < 4 - return g:MalNil - else - let ast = ast.val[3] - endif - else - let ast = ast.val[2] - endif - " TCO - elseif first_symbol == "do" - let astlist = ast.val - call EvalAst(ListNew(astlist[1:-2]), env) - let ast = astlist[-1] - " TCO - elseif first_symbol == "fn*" - let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) - return fn - elseif first_symbol == "eval" - let ast = EVAL(ListNth(ast, 1), env) - let env = env.root() - " TCO - else - " apply list - let el = EvalAst(ast, env) - let funcobj = ListFirst(el) - let args = ListRest(el) - if NativeFunctionQ(funcobj) - return NativeFuncInvoke(funcobj, args) - elseif FunctionQ(funcobj) - let fn = funcobj.val - let ast = fn.ast - let env = NewEnvWithBinds(fn.env, fn.params, args) - " TCO - else - throw "Not a function" - endif - endif - endwhile -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function RE(str, env) - return EVAL(READ(a:str), a:env) -endfunction - -function REP(str, env) - return PRINT(EVAL(READ(a:str), a:env)) -endfunction - -function GetArgvList() - return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) -endfunction - -set maxfuncdepth=10000 -let repl_env = NewEnv("") - -for [k, v] in items(CoreNs) - call repl_env.set(k, v) -endfor - -call repl_env.set("*ARGV*", GetArgvList()) - -call RE("(def! not (fn* (a) (if a false true)))", repl_env) -call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - -if !empty(argv()) - call RE('(load-file "' . argv(0) . '")', repl_env) - qall! -endif - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line, repl_env)) - catch - call PrintLn("Error: " . v:exception) - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim +source env.vim +source core.vim + +function READ(str) + return ReadStr(a:str) +endfunction + +function EvalAst(ast, env) + if SymbolQ(a:ast) + let varname = a:ast.val + return a:env.get(varname) + elseif ListQ(a:ast) + return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif VectorQ(a:ast) + return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif HashQ(a:ast) + let ret = {} + for [k,v] in items(a:ast.val) + let newval = EVAL(v, a:env) + let ret[k] = newval + endfor + return HashNew(ret) + else + return a:ast + end +endfunction + +function EVAL(ast, env) + let ast = a:ast + let env = a:env + + while 1 + if !ListQ(ast) + return EvalAst(ast, env) + end + if EmptyQ(ast) + return ast + endif + + let first = ListFirst(ast) + let first_symbol = SymbolQ(first) ? first.val : "" + if first_symbol == "def!" + let a1 = ast.val[1] + let a2 = ast.val[2] + let ret = env.set(a1.val, EVAL(a2, env)) + return ret + elseif first_symbol == "let*" + let a1 = ast.val[1] + let a2 = ast.val[2] + let env = NewEnv(env) + let let_binds = a1.val + let i = 0 + while i < len(let_binds) + call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) + let i = i + 2 + endwhile + let ast = a2 + " TCO + elseif first_symbol == "if" + let condvalue = EVAL(ast.val[1], env) + if FalseQ(condvalue) || NilQ(condvalue) + if len(ast.val) < 4 + return g:MalNil + else + let ast = ast.val[3] + endif + else + let ast = ast.val[2] + endif + " TCO + elseif first_symbol == "do" + let astlist = ast.val + call EvalAst(ListNew(astlist[1:-2]), env) + let ast = astlist[-1] + " TCO + elseif first_symbol == "fn*" + let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) + return fn + elseif first_symbol == "eval" + let ast = EVAL(ListNth(ast, 1), env) + let env = env.root() + " TCO + else + " apply list + let el = EvalAst(ast, env) + let funcobj = ListFirst(el) + let args = ListRest(el) + if NativeFunctionQ(funcobj) + return NativeFuncInvoke(funcobj, args) + elseif FunctionQ(funcobj) + let fn = funcobj.val + let ast = fn.ast + let env = NewEnvWithBinds(fn.env, fn.params, args) + " TCO + else + throw "Not a function" + endif + endif + endwhile +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function RE(str, env) + return EVAL(READ(a:str), a:env) +endfunction + +function REP(str, env) + return PRINT(EVAL(READ(a:str), a:env)) +endfunction + +function GetArgvList() + return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) +endfunction + +set maxfuncdepth=10000 +let repl_env = NewEnv("") + +for [k, v] in items(CoreNs) + call repl_env.set(k, v) +endfor + +call repl_env.set("*ARGV*", GetArgvList()) + +call RE("(def! not (fn* (a) (if a false true)))", repl_env) +call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + +if !empty(argv()) + call RE('(load-file "' . argv(0) . '")', repl_env) + qall! +endif + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line, repl_env)) + catch + call PrintLn("Error: " . v:exception) + endtry +endwhile +qall! diff --git a/impls/vimscript/step7_quote.vim b/impls/vimscript/step7_quote.vim index 7cee83261f..2ab2e7b6bb 100644 --- a/impls/vimscript/step7_quote.vim +++ b/impls/vimscript/step7_quote.vim @@ -1,195 +1,195 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim -source env.vim -source core.vim - -function READ(str) - return ReadStr(a:str) -endfunction - -function StartsWith(ast, sym) - if EmptyQ(a:ast) - return 0 - endif - let fst = ListFirst(a:ast) - return SymbolQ(fst) && fst.val == a:sym -endfunction - -function QuasiquoteLoop(xs) - let revlist = reverse(copy(a:xs)) - let acc = ListNew([]) - for elt in revlist - if ListQ(elt) && StartsWith(elt, "splice-unquote") - let acc = ListNew([SymbolNew("concat"), ListNth(elt, 1), acc]) - else - let acc = ListNew([SymbolNew("cons"), Quasiquote(elt), acc]) - endif - endfor - return acc - endfunction - -function Quasiquote(ast) - if VectorQ(a:ast) - return ListNew([SymbolNew("vec"), QuasiquoteLoop(a:ast.val)]) - elseif SymbolQ(a:ast) || HashQ(a:ast) - return ListNew([SymbolNew("quote"), a:ast]) - elseif !ListQ(a:ast) - return a:ast - elseif StartsWith(a:ast, "unquote") - return ListNth(a:ast, 1) - else - return QuasiquoteLoop(a:ast.val) - endif -endfunction - -function EvalAst(ast, env) - if SymbolQ(a:ast) - let varname = a:ast.val - return a:env.get(varname) - elseif ListQ(a:ast) - return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif VectorQ(a:ast) - return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif HashQ(a:ast) - let ret = {} - for [k,v] in items(a:ast.val) - let newval = EVAL(v, a:env) - let ret[k] = newval - endfor - return HashNew(ret) - else - return a:ast - end -endfunction - -function EVAL(ast, env) - let ast = a:ast - let env = a:env - - while 1 - if !ListQ(ast) - return EvalAst(ast, env) - end - if EmptyQ(ast) - return ast - endif - - let first = ListFirst(ast) - let first_symbol = SymbolQ(first) ? first.val : "" - if first_symbol == "def!" - let a1 = ast.val[1] - let a2 = ast.val[2] - let ret = env.set(a1.val, EVAL(a2, env)) - return ret - elseif first_symbol == "let*" - let a1 = ast.val[1] - let a2 = ast.val[2] - let env = NewEnv(env) - let let_binds = a1.val - let i = 0 - while i < len(let_binds) - call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) - let i = i + 2 - endwhile - let ast = a2 - " TCO - elseif first_symbol == "quote" - return ListNth(ast, 1) - elseif first_symbol == "quasiquoteexpand" - return Quasiquote(ListNth(ast, 1)) - elseif first_symbol == "quasiquote" - let ast = Quasiquote(ListNth(ast, 1)) - " TCO - elseif first_symbol == "if" - let condvalue = EVAL(ast.val[1], env) - if FalseQ(condvalue) || NilQ(condvalue) - if len(ast.val) < 4 - return g:MalNil - else - let ast = ast.val[3] - endif - else - let ast = ast.val[2] - endif - " TCO - elseif first_symbol == "do" - let astlist = ast.val - call EvalAst(ListNew(astlist[1:-2]), env) - let ast = astlist[-1] - " TCO - elseif first_symbol == "fn*" - let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) - return fn - elseif first_symbol == "eval" - let ast = EVAL(ListNth(ast, 1), env) - let env = env.root() - " TCO - else - " apply list - let el = EvalAst(ast, env) - let funcobj = ListFirst(el) - let args = ListRest(el) - if NativeFunctionQ(funcobj) - return NativeFuncInvoke(funcobj, args) - elseif FunctionQ(funcobj) - let fn = funcobj.val - let ast = fn.ast - let env = NewEnvWithBinds(fn.env, fn.params, args) - " TCO - else - throw "Not a function" - endif - endif - endwhile -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function RE(str, env) - return EVAL(READ(a:str), a:env) -endfunction - -function REP(str, env) - return PRINT(EVAL(READ(a:str), a:env)) -endfunction - -function GetArgvList() - return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) -endfunction - -set maxfuncdepth=10000 -let repl_env = NewEnv("") - -for [k, v] in items(CoreNs) - call repl_env.set(k, v) -endfor - -call repl_env.set("*ARGV*", GetArgvList()) - -call RE("(def! not (fn* (a) (if a false true)))", repl_env) -call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) - -if !empty(argv()) - call RE('(load-file "' . argv(0) . '")', repl_env) - qall! -endif - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line, repl_env)) - catch - call PrintLn("Error: " . v:exception) - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim +source env.vim +source core.vim + +function READ(str) + return ReadStr(a:str) +endfunction + +function StartsWith(ast, sym) + if EmptyQ(a:ast) + return 0 + endif + let fst = ListFirst(a:ast) + return SymbolQ(fst) && fst.val == a:sym +endfunction + +function QuasiquoteLoop(xs) + let revlist = reverse(copy(a:xs)) + let acc = ListNew([]) + for elt in revlist + if ListQ(elt) && StartsWith(elt, "splice-unquote") + let acc = ListNew([SymbolNew("concat"), ListNth(elt, 1), acc]) + else + let acc = ListNew([SymbolNew("cons"), Quasiquote(elt), acc]) + endif + endfor + return acc + endfunction + +function Quasiquote(ast) + if VectorQ(a:ast) + return ListNew([SymbolNew("vec"), QuasiquoteLoop(a:ast.val)]) + elseif SymbolQ(a:ast) || HashQ(a:ast) + return ListNew([SymbolNew("quote"), a:ast]) + elseif !ListQ(a:ast) + return a:ast + elseif StartsWith(a:ast, "unquote") + return ListNth(a:ast, 1) + else + return QuasiquoteLoop(a:ast.val) + endif +endfunction + +function EvalAst(ast, env) + if SymbolQ(a:ast) + let varname = a:ast.val + return a:env.get(varname) + elseif ListQ(a:ast) + return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif VectorQ(a:ast) + return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif HashQ(a:ast) + let ret = {} + for [k,v] in items(a:ast.val) + let newval = EVAL(v, a:env) + let ret[k] = newval + endfor + return HashNew(ret) + else + return a:ast + end +endfunction + +function EVAL(ast, env) + let ast = a:ast + let env = a:env + + while 1 + if !ListQ(ast) + return EvalAst(ast, env) + end + if EmptyQ(ast) + return ast + endif + + let first = ListFirst(ast) + let first_symbol = SymbolQ(first) ? first.val : "" + if first_symbol == "def!" + let a1 = ast.val[1] + let a2 = ast.val[2] + let ret = env.set(a1.val, EVAL(a2, env)) + return ret + elseif first_symbol == "let*" + let a1 = ast.val[1] + let a2 = ast.val[2] + let env = NewEnv(env) + let let_binds = a1.val + let i = 0 + while i < len(let_binds) + call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) + let i = i + 2 + endwhile + let ast = a2 + " TCO + elseif first_symbol == "quote" + return ListNth(ast, 1) + elseif first_symbol == "quasiquoteexpand" + return Quasiquote(ListNth(ast, 1)) + elseif first_symbol == "quasiquote" + let ast = Quasiquote(ListNth(ast, 1)) + " TCO + elseif first_symbol == "if" + let condvalue = EVAL(ast.val[1], env) + if FalseQ(condvalue) || NilQ(condvalue) + if len(ast.val) < 4 + return g:MalNil + else + let ast = ast.val[3] + endif + else + let ast = ast.val[2] + endif + " TCO + elseif first_symbol == "do" + let astlist = ast.val + call EvalAst(ListNew(astlist[1:-2]), env) + let ast = astlist[-1] + " TCO + elseif first_symbol == "fn*" + let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) + return fn + elseif first_symbol == "eval" + let ast = EVAL(ListNth(ast, 1), env) + let env = env.root() + " TCO + else + " apply list + let el = EvalAst(ast, env) + let funcobj = ListFirst(el) + let args = ListRest(el) + if NativeFunctionQ(funcobj) + return NativeFuncInvoke(funcobj, args) + elseif FunctionQ(funcobj) + let fn = funcobj.val + let ast = fn.ast + let env = NewEnvWithBinds(fn.env, fn.params, args) + " TCO + else + throw "Not a function" + endif + endif + endwhile +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function RE(str, env) + return EVAL(READ(a:str), a:env) +endfunction + +function REP(str, env) + return PRINT(EVAL(READ(a:str), a:env)) +endfunction + +function GetArgvList() + return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) +endfunction + +set maxfuncdepth=10000 +let repl_env = NewEnv("") + +for [k, v] in items(CoreNs) + call repl_env.set(k, v) +endfor + +call repl_env.set("*ARGV*", GetArgvList()) + +call RE("(def! not (fn* (a) (if a false true)))", repl_env) +call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) + +if !empty(argv()) + call RE('(load-file "' . argv(0) . '")', repl_env) + qall! +endif + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line, repl_env)) + catch + call PrintLn("Error: " . v:exception) + endtry +endwhile +qall! diff --git a/impls/vimscript/step8_macros.vim b/impls/vimscript/step8_macros.vim index c2f23d43aa..755b196248 100644 --- a/impls/vimscript/step8_macros.vim +++ b/impls/vimscript/step8_macros.vim @@ -1,232 +1,232 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim -source env.vim -source core.vim - -function READ(str) - return ReadStr(a:str) -endfunction - -function StartsWith(ast, sym) - if EmptyQ(a:ast) - return 0 - endif - let fst = ListFirst(a:ast) - return SymbolQ(fst) && fst.val == a:sym -endfunction - -function QuasiquoteLoop(xs) - let revlist = reverse(copy(a:xs)) - let acc = ListNew([]) - for elt in revlist - if ListQ(elt) && StartsWith(elt, "splice-unquote") - let acc = ListNew([SymbolNew("concat"), ListNth(elt, 1), acc]) - else - let acc = ListNew([SymbolNew("cons"), Quasiquote(elt), acc]) - endif - endfor - return acc - endfunction - -function Quasiquote(ast) - if VectorQ(a:ast) - return ListNew([SymbolNew("vec"), QuasiquoteLoop(a:ast.val)]) - elseif SymbolQ(a:ast) || HashQ(a:ast) - return ListNew([SymbolNew("quote"), a:ast]) - elseif !ListQ(a:ast) - return a:ast - elseif StartsWith(a:ast, "unquote") - return ListNth(a:ast, 1) - else - return QuasiquoteLoop(a:ast.val) - endif -endfunction - -function IsMacroCall(ast, env) - if !ListQ(a:ast) - return 0 - endif - let a0 = ListFirst(a:ast) - if !SymbolQ(a0) - return 0 - endif - let macroname = a0.val - if empty(a:env.find(macroname)) - return 0 - endif - return MacroQ(a:env.get(macroname)) -endfunction - -function MacroExpand(ast, env) - let ast = a:ast - while IsMacroCall(ast, a:env) - let macroobj = a:env.get(ListFirst(ast).val) - let macroargs = ListRest(ast) - let ast = FuncInvoke(macroobj, macroargs) - endwhile - return ast -endfunction - -function EvalAst(ast, env) - if SymbolQ(a:ast) - let varname = a:ast.val - return a:env.get(varname) - elseif ListQ(a:ast) - return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif VectorQ(a:ast) - return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif HashQ(a:ast) - let ret = {} - for [k,v] in items(a:ast.val) - let newval = EVAL(v, a:env) - let ret[k] = newval - endfor - return HashNew(ret) - else - return a:ast - end -endfunction - -function EVAL(ast, env) - let ast = a:ast - let env = a:env - - while 1 - if !ListQ(ast) - return EvalAst(ast, env) - end - - let ast = MacroExpand(ast, env) - if !ListQ(ast) - return EvalAst(ast, env) - end - if EmptyQ(ast) - return ast - endif - - let first = ListFirst(ast) - let first_symbol = SymbolQ(first) ? first.val : "" - if first_symbol == "def!" - let a1 = ast.val[1] - let a2 = ast.val[2] - return env.set(a1.val, EVAL(a2, env)) - elseif first_symbol == "let*" - let a1 = ast.val[1] - let a2 = ast.val[2] - let env = NewEnv(env) - let let_binds = a1.val - let i = 0 - while i < len(let_binds) - call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) - let i = i + 2 - endwhile - let ast = a2 - " TCO - elseif first_symbol == "quote" - return ListNth(ast, 1) - elseif first_symbol == "quasiquoteexpand" - return Quasiquote(ListNth(ast, 1)) - elseif first_symbol == "quasiquote" - let ast = Quasiquote(ListNth(ast, 1)) - " TCO - elseif first_symbol == "defmacro!" - let a1 = ListNth(ast, 1) - let a2 = ListNth(ast, 2) - let macro = MarkAsMacro(EVAL(a2, env)) - return env.set(a1.val, macro) - elseif first_symbol == "macroexpand" - return MacroExpand(ListNth(ast, 1), env) - elseif first_symbol == "if" - let condvalue = EVAL(ast.val[1], env) - if FalseQ(condvalue) || NilQ(condvalue) - if len(ast.val) < 4 - return g:MalNil - else - let ast = ast.val[3] - endif - else - let ast = ast.val[2] - endif - " TCO - elseif first_symbol == "do" - let astlist = ast.val - call EvalAst(ListNew(astlist[1:-2]), env) - let ast = astlist[-1] - " TCO - elseif first_symbol == "fn*" - let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) - return fn - elseif first_symbol == "eval" - let ast = EVAL(ListNth(ast, 1), env) - let env = env.root() - " TCO - else - " apply list - let el = EvalAst(ast, env) - let funcobj = ListFirst(el) - let args = ListRest(el) - if NativeFunctionQ(funcobj) - return NativeFuncInvoke(funcobj, args) - elseif FunctionQ(funcobj) - let fn = funcobj.val - let ast = fn.ast - let env = NewEnvWithBinds(fn.env, fn.params, args) - " TCO - else - throw "Not a function" - endif - endif - endwhile -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function RE(str, env) - return EVAL(READ(a:str), a:env) -endfunction - -function REP(str, env) - return PRINT(EVAL(READ(a:str), a:env)) -endfunction - -function GetArgvList() - return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) -endfunction - -set maxfuncdepth=10000 -let repl_env = NewEnv("") - -for [k, v] in items(CoreNs) - call repl_env.set(k, v) -endfor - -call repl_env.set("*ARGV*", GetArgvList()) - -call RE("(def! not (fn* (a) (if a false true)))", repl_env) -call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) -call RE("(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)))))))", repl_env) - -if !empty(argv()) - call RE('(load-file "' . argv(0) . '")', repl_env) - qall! -endif - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line, repl_env)) - catch - call PrintLn("Error: " . v:exception) - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim +source env.vim +source core.vim + +function READ(str) + return ReadStr(a:str) +endfunction + +function StartsWith(ast, sym) + if EmptyQ(a:ast) + return 0 + endif + let fst = ListFirst(a:ast) + return SymbolQ(fst) && fst.val == a:sym +endfunction + +function QuasiquoteLoop(xs) + let revlist = reverse(copy(a:xs)) + let acc = ListNew([]) + for elt in revlist + if ListQ(elt) && StartsWith(elt, "splice-unquote") + let acc = ListNew([SymbolNew("concat"), ListNth(elt, 1), acc]) + else + let acc = ListNew([SymbolNew("cons"), Quasiquote(elt), acc]) + endif + endfor + return acc + endfunction + +function Quasiquote(ast) + if VectorQ(a:ast) + return ListNew([SymbolNew("vec"), QuasiquoteLoop(a:ast.val)]) + elseif SymbolQ(a:ast) || HashQ(a:ast) + return ListNew([SymbolNew("quote"), a:ast]) + elseif !ListQ(a:ast) + return a:ast + elseif StartsWith(a:ast, "unquote") + return ListNth(a:ast, 1) + else + return QuasiquoteLoop(a:ast.val) + endif +endfunction + +function IsMacroCall(ast, env) + if !ListQ(a:ast) + return 0 + endif + let a0 = ListFirst(a:ast) + if !SymbolQ(a0) + return 0 + endif + let macroname = a0.val + if empty(a:env.find(macroname)) + return 0 + endif + return MacroQ(a:env.get(macroname)) +endfunction + +function MacroExpand(ast, env) + let ast = a:ast + while IsMacroCall(ast, a:env) + let macroobj = a:env.get(ListFirst(ast).val) + let macroargs = ListRest(ast) + let ast = FuncInvoke(macroobj, macroargs) + endwhile + return ast +endfunction + +function EvalAst(ast, env) + if SymbolQ(a:ast) + let varname = a:ast.val + return a:env.get(varname) + elseif ListQ(a:ast) + return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif VectorQ(a:ast) + return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif HashQ(a:ast) + let ret = {} + for [k,v] in items(a:ast.val) + let newval = EVAL(v, a:env) + let ret[k] = newval + endfor + return HashNew(ret) + else + return a:ast + end +endfunction + +function EVAL(ast, env) + let ast = a:ast + let env = a:env + + while 1 + if !ListQ(ast) + return EvalAst(ast, env) + end + + let ast = MacroExpand(ast, env) + if !ListQ(ast) + return EvalAst(ast, env) + end + if EmptyQ(ast) + return ast + endif + + let first = ListFirst(ast) + let first_symbol = SymbolQ(first) ? first.val : "" + if first_symbol == "def!" + let a1 = ast.val[1] + let a2 = ast.val[2] + return env.set(a1.val, EVAL(a2, env)) + elseif first_symbol == "let*" + let a1 = ast.val[1] + let a2 = ast.val[2] + let env = NewEnv(env) + let let_binds = a1.val + let i = 0 + while i < len(let_binds) + call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) + let i = i + 2 + endwhile + let ast = a2 + " TCO + elseif first_symbol == "quote" + return ListNth(ast, 1) + elseif first_symbol == "quasiquoteexpand" + return Quasiquote(ListNth(ast, 1)) + elseif first_symbol == "quasiquote" + let ast = Quasiquote(ListNth(ast, 1)) + " TCO + elseif first_symbol == "defmacro!" + let a1 = ListNth(ast, 1) + let a2 = ListNth(ast, 2) + let macro = MarkAsMacro(EVAL(a2, env)) + return env.set(a1.val, macro) + elseif first_symbol == "macroexpand" + return MacroExpand(ListNth(ast, 1), env) + elseif first_symbol == "if" + let condvalue = EVAL(ast.val[1], env) + if FalseQ(condvalue) || NilQ(condvalue) + if len(ast.val) < 4 + return g:MalNil + else + let ast = ast.val[3] + endif + else + let ast = ast.val[2] + endif + " TCO + elseif first_symbol == "do" + let astlist = ast.val + call EvalAst(ListNew(astlist[1:-2]), env) + let ast = astlist[-1] + " TCO + elseif first_symbol == "fn*" + let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) + return fn + elseif first_symbol == "eval" + let ast = EVAL(ListNth(ast, 1), env) + let env = env.root() + " TCO + else + " apply list + let el = EvalAst(ast, env) + let funcobj = ListFirst(el) + let args = ListRest(el) + if NativeFunctionQ(funcobj) + return NativeFuncInvoke(funcobj, args) + elseif FunctionQ(funcobj) + let fn = funcobj.val + let ast = fn.ast + let env = NewEnvWithBinds(fn.env, fn.params, args) + " TCO + else + throw "Not a function" + endif + endif + endwhile +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function RE(str, env) + return EVAL(READ(a:str), a:env) +endfunction + +function REP(str, env) + return PRINT(EVAL(READ(a:str), a:env)) +endfunction + +function GetArgvList() + return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) +endfunction + +set maxfuncdepth=10000 +let repl_env = NewEnv("") + +for [k, v] in items(CoreNs) + call repl_env.set(k, v) +endfor + +call repl_env.set("*ARGV*", GetArgvList()) + +call RE("(def! not (fn* (a) (if a false true)))", repl_env) +call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) +call RE("(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)))))))", repl_env) + +if !empty(argv()) + call RE('(load-file "' . argv(0) . '")', repl_env) + qall! +endif + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line, repl_env)) + catch + call PrintLn("Error: " . v:exception) + endtry +endwhile +qall! diff --git a/impls/vimscript/step9_try.vim b/impls/vimscript/step9_try.vim index 46b30e99ae..8ff3f3897d 100644 --- a/impls/vimscript/step9_try.vim +++ b/impls/vimscript/step9_try.vim @@ -1,272 +1,272 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim -source env.vim -source core.vim - -let MalExceptionObj = "" - -function READ(str) - return ReadStr(a:str) -endfunction - -function StartsWith(ast, sym) - if EmptyQ(a:ast) - return 0 - endif - let fst = ListFirst(a:ast) - return SymbolQ(fst) && fst.val == a:sym -endfunction - -function QuasiquoteLoop(xs) - let revlist = reverse(copy(a:xs)) - let acc = ListNew([]) - for elt in revlist - if ListQ(elt) && StartsWith(elt, "splice-unquote") - let acc = ListNew([SymbolNew("concat"), ListNth(elt, 1), acc]) - else - let acc = ListNew([SymbolNew("cons"), Quasiquote(elt), acc]) - endif - endfor - return acc - endfunction - -function Quasiquote(ast) - if VectorQ(a:ast) - return ListNew([SymbolNew("vec"), QuasiquoteLoop(a:ast.val)]) - elseif SymbolQ(a:ast) || HashQ(a:ast) - return ListNew([SymbolNew("quote"), a:ast]) - elseif !ListQ(a:ast) - return a:ast - elseif StartsWith(a:ast, "unquote") - return ListNth(a:ast, 1) - else - return QuasiquoteLoop(a:ast.val) - endif -endfunction - -function IsMacroCall(ast, env) - if !ListQ(a:ast) - return 0 - endif - let a0 = ListFirst(a:ast) - if !SymbolQ(a0) - return 0 - endif - let macroname = a0.val - if empty(a:env.find(macroname)) - return 0 - endif - return MacroQ(a:env.get(macroname)) -endfunction - -function MacroExpand(ast, env) - let ast = a:ast - while IsMacroCall(ast, a:env) - let macroobj = a:env.get(ListFirst(ast).val) - let macroargs = ListRest(ast) - let ast = FuncInvoke(macroobj, macroargs) - endwhile - return ast -endfunction - -function EvalAst(ast, env) - if SymbolQ(a:ast) - let varname = a:ast.val - return a:env.get(varname) - elseif ListQ(a:ast) - return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif VectorQ(a:ast) - return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif HashQ(a:ast) - let ret = {} - for [k,v] in items(a:ast.val) - let newval = EVAL(v, a:env) - let ret[k] = newval - endfor - return HashNew(ret) - else - return a:ast - end -endfunction - -function GetCatchClause(ast) - if ListCount(a:ast) < 3 - return "" - end - let catch_clause = ListNth(a:ast, 2) - if ListFirst(catch_clause) == SymbolNew("catch*") - return catch_clause - else - return "" - end -endfunction - -function EVAL(ast, env) - let ast = a:ast - let env = a:env - - while 1 - if !ListQ(ast) - return EvalAst(ast, env) - end - - let ast = MacroExpand(ast, env) - if !ListQ(ast) - return EvalAst(ast, env) - end - if EmptyQ(ast) - return ast - endif - - let first = ListFirst(ast) - let first_symbol = SymbolQ(first) ? first.val : "" - if first_symbol == "def!" - let a1 = ast.val[1] - let a2 = ast.val[2] - return env.set(a1.val, EVAL(a2, env)) - elseif first_symbol == "let*" - let a1 = ast.val[1] - let a2 = ast.val[2] - let env = NewEnv(env) - let let_binds = a1.val - let i = 0 - while i < len(let_binds) - call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) - let i = i + 2 - endwhile - let ast = a2 - " TCO - elseif first_symbol == "quote" - return ListNth(ast, 1) - elseif first_symbol == "quasiquoteexpand" - return Quasiquote(ListNth(ast, 1)) - elseif first_symbol == "quasiquote" - let ast = Quasiquote(ListNth(ast, 1)) - " TCO - elseif first_symbol == "defmacro!" - let a1 = ListNth(ast, 1) - let a2 = ListNth(ast, 2) - let macro = MarkAsMacro(EVAL(a2, env)) - return env.set(a1.val, macro) - elseif first_symbol == "macroexpand" - return MacroExpand(ListNth(ast, 1), env) - elseif first_symbol == "if" - let condvalue = EVAL(ast.val[1], env) - if FalseQ(condvalue) || NilQ(condvalue) - if len(ast.val) < 4 - return g:MalNil - else - let ast = ast.val[3] - endif - else - let ast = ast.val[2] - endif - " TCO - elseif first_symbol == "try*" - try - return EVAL(ListNth(ast, 1), env) - catch - let catch_clause = GetCatchClause(ast) - if empty(catch_clause) - throw v:exception - endif - - let exc_var = ListNth(catch_clause, 1).val - if v:exception == "__MalException__" - let exc_value = g:MalExceptionObj - else - let exc_value = StringNew(v:exception) - endif - let catch_env = NewEnvWithBinds(env, ListNew([SymbolNew(exc_var)]), ListNew([exc_value])) - return EVAL(ListNth(catch_clause, 2), catch_env) - endtry - elseif first_symbol == "do" - let astlist = ast.val - call EvalAst(ListNew(astlist[1:-2]), env) - let ast = astlist[-1] - " TCO - elseif first_symbol == "fn*" - let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) - return fn - elseif first_symbol == "eval" - let ast = EVAL(ListNth(ast, 1), env) - let env = env.root() - " TCO - else - " apply list - let el = EvalAst(ast, env) - let funcobj = ListFirst(el) - let args = ListRest(el) - if NativeFunctionQ(funcobj) - return NativeFuncInvoke(funcobj, args) - elseif FunctionQ(funcobj) - let fn = funcobj.val - let ast = fn.ast - let env = NewEnvWithBinds(fn.env, fn.params, args) - " TCO - else - throw "Not a function" - endif - endif - endwhile -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function RE(str, env) - return EVAL(READ(a:str), a:env) -endfunction - -function REP(str, env) - return PRINT(EVAL(READ(a:str), a:env)) -endfunction - -function GetArgvList() - return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) -endfunction - -set maxfuncdepth=10000 -let repl_env = NewEnv("") - -for [k, v] in items(CoreNs) - call repl_env.set(k, v) -endfor - -call repl_env.set("*ARGV*", GetArgvList()) - -call RE("(def! not (fn* (a) (if a false true)))", repl_env) -call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) -call RE("(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)))))))", repl_env) - -if !empty(argv()) - try - call RE('(load-file "' . argv(0) . '")', repl_env) - catch - call PrintLn("Error: " . v:exception) - endtry - qall! -endif - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line, repl_env)) - catch - if v:exception == "__MalException__" - call PrintLn("Error: " . PrStr(g:MalExceptionObj, 1)) - else - call PrintLn("Error: " . v:exception) - end - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim +source env.vim +source core.vim + +let MalExceptionObj = "" + +function READ(str) + return ReadStr(a:str) +endfunction + +function StartsWith(ast, sym) + if EmptyQ(a:ast) + return 0 + endif + let fst = ListFirst(a:ast) + return SymbolQ(fst) && fst.val == a:sym +endfunction + +function QuasiquoteLoop(xs) + let revlist = reverse(copy(a:xs)) + let acc = ListNew([]) + for elt in revlist + if ListQ(elt) && StartsWith(elt, "splice-unquote") + let acc = ListNew([SymbolNew("concat"), ListNth(elt, 1), acc]) + else + let acc = ListNew([SymbolNew("cons"), Quasiquote(elt), acc]) + endif + endfor + return acc + endfunction + +function Quasiquote(ast) + if VectorQ(a:ast) + return ListNew([SymbolNew("vec"), QuasiquoteLoop(a:ast.val)]) + elseif SymbolQ(a:ast) || HashQ(a:ast) + return ListNew([SymbolNew("quote"), a:ast]) + elseif !ListQ(a:ast) + return a:ast + elseif StartsWith(a:ast, "unquote") + return ListNth(a:ast, 1) + else + return QuasiquoteLoop(a:ast.val) + endif +endfunction + +function IsMacroCall(ast, env) + if !ListQ(a:ast) + return 0 + endif + let a0 = ListFirst(a:ast) + if !SymbolQ(a0) + return 0 + endif + let macroname = a0.val + if empty(a:env.find(macroname)) + return 0 + endif + return MacroQ(a:env.get(macroname)) +endfunction + +function MacroExpand(ast, env) + let ast = a:ast + while IsMacroCall(ast, a:env) + let macroobj = a:env.get(ListFirst(ast).val) + let macroargs = ListRest(ast) + let ast = FuncInvoke(macroobj, macroargs) + endwhile + return ast +endfunction + +function EvalAst(ast, env) + if SymbolQ(a:ast) + let varname = a:ast.val + return a:env.get(varname) + elseif ListQ(a:ast) + return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif VectorQ(a:ast) + return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif HashQ(a:ast) + let ret = {} + for [k,v] in items(a:ast.val) + let newval = EVAL(v, a:env) + let ret[k] = newval + endfor + return HashNew(ret) + else + return a:ast + end +endfunction + +function GetCatchClause(ast) + if ListCount(a:ast) < 3 + return "" + end + let catch_clause = ListNth(a:ast, 2) + if ListFirst(catch_clause) == SymbolNew("catch*") + return catch_clause + else + return "" + end +endfunction + +function EVAL(ast, env) + let ast = a:ast + let env = a:env + + while 1 + if !ListQ(ast) + return EvalAst(ast, env) + end + + let ast = MacroExpand(ast, env) + if !ListQ(ast) + return EvalAst(ast, env) + end + if EmptyQ(ast) + return ast + endif + + let first = ListFirst(ast) + let first_symbol = SymbolQ(first) ? first.val : "" + if first_symbol == "def!" + let a1 = ast.val[1] + let a2 = ast.val[2] + return env.set(a1.val, EVAL(a2, env)) + elseif first_symbol == "let*" + let a1 = ast.val[1] + let a2 = ast.val[2] + let env = NewEnv(env) + let let_binds = a1.val + let i = 0 + while i < len(let_binds) + call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) + let i = i + 2 + endwhile + let ast = a2 + " TCO + elseif first_symbol == "quote" + return ListNth(ast, 1) + elseif first_symbol == "quasiquoteexpand" + return Quasiquote(ListNth(ast, 1)) + elseif first_symbol == "quasiquote" + let ast = Quasiquote(ListNth(ast, 1)) + " TCO + elseif first_symbol == "defmacro!" + let a1 = ListNth(ast, 1) + let a2 = ListNth(ast, 2) + let macro = MarkAsMacro(EVAL(a2, env)) + return env.set(a1.val, macro) + elseif first_symbol == "macroexpand" + return MacroExpand(ListNth(ast, 1), env) + elseif first_symbol == "if" + let condvalue = EVAL(ast.val[1], env) + if FalseQ(condvalue) || NilQ(condvalue) + if len(ast.val) < 4 + return g:MalNil + else + let ast = ast.val[3] + endif + else + let ast = ast.val[2] + endif + " TCO + elseif first_symbol == "try*" + try + return EVAL(ListNth(ast, 1), env) + catch + let catch_clause = GetCatchClause(ast) + if empty(catch_clause) + throw v:exception + endif + + let exc_var = ListNth(catch_clause, 1).val + if v:exception == "__MalException__" + let exc_value = g:MalExceptionObj + else + let exc_value = StringNew(v:exception) + endif + let catch_env = NewEnvWithBinds(env, ListNew([SymbolNew(exc_var)]), ListNew([exc_value])) + return EVAL(ListNth(catch_clause, 2), catch_env) + endtry + elseif first_symbol == "do" + let astlist = ast.val + call EvalAst(ListNew(astlist[1:-2]), env) + let ast = astlist[-1] + " TCO + elseif first_symbol == "fn*" + let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) + return fn + elseif first_symbol == "eval" + let ast = EVAL(ListNth(ast, 1), env) + let env = env.root() + " TCO + else + " apply list + let el = EvalAst(ast, env) + let funcobj = ListFirst(el) + let args = ListRest(el) + if NativeFunctionQ(funcobj) + return NativeFuncInvoke(funcobj, args) + elseif FunctionQ(funcobj) + let fn = funcobj.val + let ast = fn.ast + let env = NewEnvWithBinds(fn.env, fn.params, args) + " TCO + else + throw "Not a function" + endif + endif + endwhile +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function RE(str, env) + return EVAL(READ(a:str), a:env) +endfunction + +function REP(str, env) + return PRINT(EVAL(READ(a:str), a:env)) +endfunction + +function GetArgvList() + return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) +endfunction + +set maxfuncdepth=10000 +let repl_env = NewEnv("") + +for [k, v] in items(CoreNs) + call repl_env.set(k, v) +endfor + +call repl_env.set("*ARGV*", GetArgvList()) + +call RE("(def! not (fn* (a) (if a false true)))", repl_env) +call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) +call RE("(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)))))))", repl_env) + +if !empty(argv()) + try + call RE('(load-file "' . argv(0) . '")', repl_env) + catch + call PrintLn("Error: " . v:exception) + endtry + qall! +endif + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line, repl_env)) + catch + if v:exception == "__MalException__" + call PrintLn("Error: " . PrStr(g:MalExceptionObj, 1)) + else + call PrintLn("Error: " . v:exception) + end + endtry +endwhile +qall! diff --git a/impls/vimscript/stepA_mal.vim b/impls/vimscript/stepA_mal.vim index 2ca2a7ca22..09c47620c6 100644 --- a/impls/vimscript/stepA_mal.vim +++ b/impls/vimscript/stepA_mal.vim @@ -1,275 +1,275 @@ -source readline.vim -source types.vim -source reader.vim -source printer.vim -source env.vim -source core.vim - -let MalExceptionObj = "" - -function READ(str) - return ReadStr(a:str) -endfunction - -function StartsWith(ast, sym) - if EmptyQ(a:ast) - return 0 - endif - let fst = ListFirst(a:ast) - return SymbolQ(fst) && fst.val == a:sym -endfunction - -function QuasiquoteLoop(xs) - let revlist = reverse(copy(a:xs)) - let acc = ListNew([]) - for elt in revlist - if ListQ(elt) && StartsWith(elt, "splice-unquote") - let acc = ListNew([SymbolNew("concat"), ListNth(elt, 1), acc]) - else - let acc = ListNew([SymbolNew("cons"), Quasiquote(elt), acc]) - endif - endfor - return acc - endfunction - -function Quasiquote(ast) - if VectorQ(a:ast) - return ListNew([SymbolNew("vec"), QuasiquoteLoop(a:ast.val)]) - elseif SymbolQ(a:ast) || HashQ(a:ast) - return ListNew([SymbolNew("quote"), a:ast]) - elseif !ListQ(a:ast) - return a:ast - elseif StartsWith(a:ast, "unquote") - return ListNth(a:ast, 1) - else - return QuasiquoteLoop(a:ast.val) - endif -endfunction - -function IsMacroCall(ast, env) - if !ListQ(a:ast) - return 0 - endif - let a0 = ListFirst(a:ast) - if !SymbolQ(a0) - return 0 - endif - let macroname = a0.val - if empty(a:env.find(macroname)) - return 0 - endif - return MacroQ(a:env.get(macroname)) -endfunction - -function MacroExpand(ast, env) - let ast = a:ast - while IsMacroCall(ast, a:env) - let macroobj = a:env.get(ListFirst(ast).val) - let macroargs = ListRest(ast) - let ast = FuncInvoke(macroobj, macroargs) - endwhile - return ast -endfunction - -function EvalAst(ast, env) - if SymbolQ(a:ast) - let varname = a:ast.val - return a:env.get(varname) - elseif ListQ(a:ast) - return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif VectorQ(a:ast) - return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) - elseif HashQ(a:ast) - let ret = {} - for [k,v] in items(a:ast.val) - let newval = EVAL(v, a:env) - let ret[k] = newval - endfor - return HashNew(ret) - else - return a:ast - end -endfunction - -function GetCatchClause(ast) - if ListCount(a:ast) < 3 - return "" - end - let catch_clause = ListNth(a:ast, 2) - if ListFirst(catch_clause) == SymbolNew("catch*") - return catch_clause - else - return "" - end -endfunction - -function EVAL(ast, env) - let ast = a:ast - let env = a:env - - while 1 - if !ListQ(ast) - return EvalAst(ast, env) - end - - let ast = MacroExpand(ast, env) - if !ListQ(ast) - return EvalAst(ast, env) - end - if EmptyQ(ast) - return ast - endif - - let first = ListFirst(ast) - let first_symbol = SymbolQ(first) ? first.val : "" - if first_symbol == "def!" - let a1 = ast.val[1] - let a2 = ast.val[2] - return env.set(a1.val, EVAL(a2, env)) - elseif first_symbol == "let*" - let a1 = ast.val[1] - let a2 = ast.val[2] - let env = NewEnv(env) - let let_binds = a1.val - let i = 0 - while i < len(let_binds) - call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) - let i = i + 2 - endwhile - let ast = a2 - " TCO - elseif first_symbol == "quote" - return ListNth(ast, 1) - elseif first_symbol == "quasiquoteexpand" - return Quasiquote(ListNth(ast, 1)) - elseif first_symbol == "quasiquote" - let ast = Quasiquote(ListNth(ast, 1)) - " TCO - elseif first_symbol == "defmacro!" - let a1 = ListNth(ast, 1) - let a2 = ListNth(ast, 2) - let macro = MarkAsMacro(EVAL(a2, env)) - return env.set(a1.val, macro) - elseif first_symbol == "macroexpand" - return MacroExpand(ListNth(ast, 1), env) - elseif first_symbol == "if" - let condvalue = EVAL(ast.val[1], env) - if FalseQ(condvalue) || NilQ(condvalue) - if len(ast.val) < 4 - return g:MalNil - else - let ast = ast.val[3] - endif - else - let ast = ast.val[2] - endif - " TCO - elseif first_symbol == "try*" - try - return EVAL(ListNth(ast, 1), env) - catch - let catch_clause = GetCatchClause(ast) - if empty(catch_clause) - throw v:exception - endif - - let exc_var = ListNth(catch_clause, 1).val - if v:exception == "__MalException__" - let exc_value = g:MalExceptionObj - else - let exc_value = StringNew(v:exception) - endif - let catch_env = NewEnvWithBinds(env, ListNew([SymbolNew(exc_var)]), ListNew([exc_value])) - return EVAL(ListNth(catch_clause, 2), catch_env) - endtry - elseif first_symbol == "do" - let astlist = ast.val - call EvalAst(ListNew(astlist[1:-2]), env) - let ast = astlist[-1] - " TCO - elseif first_symbol == "fn*" - let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) - return fn - elseif first_symbol == "eval" - let ast = EVAL(ListNth(ast, 1), env) - let env = env.root() - " TCO - else - " apply list - let el = EvalAst(ast, env) - let funcobj = ListFirst(el) - let args = ListRest(el) - if NativeFunctionQ(funcobj) - return NativeFuncInvoke(funcobj, args) - elseif FunctionQ(funcobj) - let fn = funcobj.val - let ast = fn.ast - let env = NewEnvWithBinds(fn.env, fn.params, args) - " TCO - else - throw "Not a function" - endif - endif - endwhile -endfunction - -function PRINT(exp) - return PrStr(a:exp, 1) -endfunction - -function RE(str, env) - return EVAL(READ(a:str), a:env) -endfunction - -function REP(str, env) - return PRINT(EVAL(READ(a:str), a:env)) -endfunction - -function GetArgvList() - return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) -endfunction - -set maxfuncdepth=10000 -let repl_env = NewEnv("") - -for [k, v] in items(CoreNs) - call repl_env.set(k, v) -endfor - -call repl_env.set("*ARGV*", GetArgvList()) - -call RE("(def! *host-language* \"vimscript\")", repl_env) -call RE("(def! not (fn* (a) (if a false true)))", repl_env) -call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) -call RE("(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)))))))", repl_env) - -if !empty(argv()) - try - call RE('(load-file "' . argv(0) . '")', repl_env) - catch - call PrintLn("Error: " . v:exception) - endtry - qall! -endif - -call REP("(println (str \"Mal [\" *host-language* \"]\"))", repl_env) - -while 1 - let [eof, line] = Readline("user> ") - if eof - break - endif - if line == "" - continue - endif - try - call PrintLn(REP(line, repl_env)) - catch - if v:exception == "__MalException__" - call PrintLn("Error: " . PrStr(g:MalExceptionObj, 1)) - else - call PrintLn("Error: " . v:exception) - end - endtry -endwhile -qall! +source readline.vim +source types.vim +source reader.vim +source printer.vim +source env.vim +source core.vim + +let MalExceptionObj = "" + +function READ(str) + return ReadStr(a:str) +endfunction + +function StartsWith(ast, sym) + if EmptyQ(a:ast) + return 0 + endif + let fst = ListFirst(a:ast) + return SymbolQ(fst) && fst.val == a:sym +endfunction + +function QuasiquoteLoop(xs) + let revlist = reverse(copy(a:xs)) + let acc = ListNew([]) + for elt in revlist + if ListQ(elt) && StartsWith(elt, "splice-unquote") + let acc = ListNew([SymbolNew("concat"), ListNth(elt, 1), acc]) + else + let acc = ListNew([SymbolNew("cons"), Quasiquote(elt), acc]) + endif + endfor + return acc + endfunction + +function Quasiquote(ast) + if VectorQ(a:ast) + return ListNew([SymbolNew("vec"), QuasiquoteLoop(a:ast.val)]) + elseif SymbolQ(a:ast) || HashQ(a:ast) + return ListNew([SymbolNew("quote"), a:ast]) + elseif !ListQ(a:ast) + return a:ast + elseif StartsWith(a:ast, "unquote") + return ListNth(a:ast, 1) + else + return QuasiquoteLoop(a:ast.val) + endif +endfunction + +function IsMacroCall(ast, env) + if !ListQ(a:ast) + return 0 + endif + let a0 = ListFirst(a:ast) + if !SymbolQ(a0) + return 0 + endif + let macroname = a0.val + if empty(a:env.find(macroname)) + return 0 + endif + return MacroQ(a:env.get(macroname)) +endfunction + +function MacroExpand(ast, env) + let ast = a:ast + while IsMacroCall(ast, a:env) + let macroobj = a:env.get(ListFirst(ast).val) + let macroargs = ListRest(ast) + let ast = FuncInvoke(macroobj, macroargs) + endwhile + return ast +endfunction + +function EvalAst(ast, env) + if SymbolQ(a:ast) + let varname = a:ast.val + return a:env.get(varname) + elseif ListQ(a:ast) + return ListNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif VectorQ(a:ast) + return VectorNew(map(copy(a:ast.val), {_, e -> EVAL(e, a:env)})) + elseif HashQ(a:ast) + let ret = {} + for [k,v] in items(a:ast.val) + let newval = EVAL(v, a:env) + let ret[k] = newval + endfor + return HashNew(ret) + else + return a:ast + end +endfunction + +function GetCatchClause(ast) + if ListCount(a:ast) < 3 + return "" + end + let catch_clause = ListNth(a:ast, 2) + if ListFirst(catch_clause) == SymbolNew("catch*") + return catch_clause + else + return "" + end +endfunction + +function EVAL(ast, env) + let ast = a:ast + let env = a:env + + while 1 + if !ListQ(ast) + return EvalAst(ast, env) + end + + let ast = MacroExpand(ast, env) + if !ListQ(ast) + return EvalAst(ast, env) + end + if EmptyQ(ast) + return ast + endif + + let first = ListFirst(ast) + let first_symbol = SymbolQ(first) ? first.val : "" + if first_symbol == "def!" + let a1 = ast.val[1] + let a2 = ast.val[2] + return env.set(a1.val, EVAL(a2, env)) + elseif first_symbol == "let*" + let a1 = ast.val[1] + let a2 = ast.val[2] + let env = NewEnv(env) + let let_binds = a1.val + let i = 0 + while i < len(let_binds) + call env.set(let_binds[i].val, EVAL(let_binds[i+1], env)) + let i = i + 2 + endwhile + let ast = a2 + " TCO + elseif first_symbol == "quote" + return ListNth(ast, 1) + elseif first_symbol == "quasiquoteexpand" + return Quasiquote(ListNth(ast, 1)) + elseif first_symbol == "quasiquote" + let ast = Quasiquote(ListNth(ast, 1)) + " TCO + elseif first_symbol == "defmacro!" + let a1 = ListNth(ast, 1) + let a2 = ListNth(ast, 2) + let macro = MarkAsMacro(EVAL(a2, env)) + return env.set(a1.val, macro) + elseif first_symbol == "macroexpand" + return MacroExpand(ListNth(ast, 1), env) + elseif first_symbol == "if" + let condvalue = EVAL(ast.val[1], env) + if FalseQ(condvalue) || NilQ(condvalue) + if len(ast.val) < 4 + return g:MalNil + else + let ast = ast.val[3] + endif + else + let ast = ast.val[2] + endif + " TCO + elseif first_symbol == "try*" + try + return EVAL(ListNth(ast, 1), env) + catch + let catch_clause = GetCatchClause(ast) + if empty(catch_clause) + throw v:exception + endif + + let exc_var = ListNth(catch_clause, 1).val + if v:exception == "__MalException__" + let exc_value = g:MalExceptionObj + else + let exc_value = StringNew(v:exception) + endif + let catch_env = NewEnvWithBinds(env, ListNew([SymbolNew(exc_var)]), ListNew([exc_value])) + return EVAL(ListNth(catch_clause, 2), catch_env) + endtry + elseif first_symbol == "do" + let astlist = ast.val + call EvalAst(ListNew(astlist[1:-2]), env) + let ast = astlist[-1] + " TCO + elseif first_symbol == "fn*" + let fn = NewFn(ListNth(ast, 2), env, ListNth(ast, 1)) + return fn + elseif first_symbol == "eval" + let ast = EVAL(ListNth(ast, 1), env) + let env = env.root() + " TCO + else + " apply list + let el = EvalAst(ast, env) + let funcobj = ListFirst(el) + let args = ListRest(el) + if NativeFunctionQ(funcobj) + return NativeFuncInvoke(funcobj, args) + elseif FunctionQ(funcobj) + let fn = funcobj.val + let ast = fn.ast + let env = NewEnvWithBinds(fn.env, fn.params, args) + " TCO + else + throw "Not a function" + endif + endif + endwhile +endfunction + +function PRINT(exp) + return PrStr(a:exp, 1) +endfunction + +function RE(str, env) + return EVAL(READ(a:str), a:env) +endfunction + +function REP(str, env) + return PRINT(EVAL(READ(a:str), a:env)) +endfunction + +function GetArgvList() + return ListNew(map(copy(argv()[1:]), {_, arg -> StringNew(arg)})) +endfunction + +set maxfuncdepth=10000 +let repl_env = NewEnv("") + +for [k, v] in items(CoreNs) + call repl_env.set(k, v) +endfor + +call repl_env.set("*ARGV*", GetArgvList()) + +call RE("(def! *host-language* \"vimscript\")", repl_env) +call RE("(def! not (fn* (a) (if a false true)))", repl_env) +call RE("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))", repl_env) +call RE("(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)))))))", repl_env) + +if !empty(argv()) + try + call RE('(load-file "' . argv(0) . '")', repl_env) + catch + call PrintLn("Error: " . v:exception) + endtry + qall! +endif + +call REP("(println (str \"Mal [\" *host-language* \"]\"))", repl_env) + +while 1 + let [eof, line] = Readline("user> ") + if eof + break + endif + if line == "" + continue + endif + try + call PrintLn(REP(line, repl_env)) + catch + if v:exception == "__MalException__" + call PrintLn("Error: " . PrStr(g:MalExceptionObj, 1)) + else + call PrintLn("Error: " . v:exception) + end + endtry +endwhile +qall! diff --git a/impls/vimscript/tests/step5_tco.mal b/impls/vimscript/tests/step5_tco.mal index d20df25db7..0c8efae9bf 100644 --- a/impls/vimscript/tests/step5_tco.mal +++ b/impls/vimscript/tests/step5_tco.mal @@ -1,15 +1,15 @@ -;; Test recursive non-tail call function - -(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) - -(sum-to 10) -;=>55 - -;;; no try* yet, so test completion of side-effects -(def! res1 nil) -;=>nil -;;; For implementations without their own TCO this should fail and -;;; leave res1 unchanged -(def! res1 (sum-to 10000)) -res1 -;=>nil +;; Test recursive non-tail call function + +(def! sum-to (fn* (n) (if (= n 0) 0 (+ n (sum-to (- n 1)))))) + +(sum-to 10) +;=>55 + +;;; no try* yet, so test completion of side-effects +(def! res1 nil) +;=>nil +;;; For implementations without their own TCO this should fail and +;;; leave res1 unchanged +(def! res1 (sum-to 10000)) +res1 +;=>nil diff --git a/impls/vimscript/tests/stepA_mal.mal b/impls/vimscript/tests/stepA_mal.mal index da601484f9..3515d43a3d 100644 --- a/impls/vimscript/tests/stepA_mal.mal +++ b/impls/vimscript/tests/stepA_mal.mal @@ -1,41 +1,41 @@ -;; Testing basic Vim interop with (vim* "...") -;; - -(vim* "7") -;=>7 - -(vim* "'7'") -;=>"7" - -(vim* "[7,8,9]") -;=>(7 8 9) - -(vim* "{\"abc\": 789}") -;=>{"abc" 789} - -;; -;; Test Vim eval() expression support -;; - -(vim* "3 + 7 * 8") -;=>59 - -(vim* "join(['a','b','c'], '_')") -;=>"a_b_c" - -(vim* "split('d@@@@e@f@@g', '@\+')") -;=>("d" "e" "f" "g") - -(vim* "add([1,2,3], 4)") -;=>(1 2 3 4) - -;; -;; Test access to Vim predefined variables -;; - -;;; (vim* "v:progname") -;;; ;=>"vim" - -;; v:version is 800 for Vim 8.0 -(>= (vim* "v:version") 800) -;=>true +;; Testing basic Vim interop with (vim* "...") +;; + +(vim* "7") +;=>7 + +(vim* "'7'") +;=>"7" + +(vim* "[7,8,9]") +;=>(7 8 9) + +(vim* "{\"abc\": 789}") +;=>{"abc" 789} + +;; +;; Test Vim eval() expression support +;; + +(vim* "3 + 7 * 8") +;=>59 + +(vim* "join(['a','b','c'], '_')") +;=>"a_b_c" + +(vim* "split('d@@@@e@f@@g', '@\+')") +;=>("d" "e" "f" "g") + +(vim* "add([1,2,3], 4)") +;=>(1 2 3 4) + +;; +;; Test access to Vim predefined variables +;; + +;;; (vim* "v:progname") +;;; ;=>"vim" + +;; v:version is 800 for Vim 8.0 +(>= (vim* "v:version") 800) +;=>true diff --git a/impls/vimscript/types.vim b/impls/vimscript/types.vim index 111c41ff82..226972e60f 100644 --- a/impls/vimscript/types.vim +++ b/impls/vimscript/types.vim @@ -1,279 +1,279 @@ -" types module - -function ObjNewWithMeta(obj_type, obj_val, obj_meta) - return {"type": a:obj_type, "val": a:obj_val, "meta": a:obj_meta} -endfunction - -function ObjNew(obj_type, obj_val) - return {"type": a:obj_type, "val": a:obj_val} -endfunction - -function ObjHasMeta(obj) - return has_key(a:obj, "meta") -endfunction - -function ObjMeta(obj) - return ObjHasMeta(a:obj) ? a:obj["meta"] : g:MalNil -endfunction - -function ObjSetValue(obj, newval) - let a:obj["val"] = a:newval - return a:newval -endfunction - -function ObjSetMeta(obj, newmeta) - let a:obj["meta"] = a:newmeta - return a:newmeta -endfunction - -function SymbolQ(obj) - return a:obj.type == "symbol" -endfunction - -function StringQ(obj) - return a:obj.type == "string" -endfunction - -function KeywordQ(obj) - return a:obj.type == "keyword" -endfunction - -function AtomQ(obj) - return a:obj.type == "atom" -endfunction - -function NilQ(obj) - return a:obj.type == "nil" -endfunction - -function TrueQ(obj) - return a:obj.type == "true" -endfunction - -function FalseQ(obj) - return a:obj.type == "false" -endfunction - -function IntegerQ(obj) - return a:obj.type == "integer" -endfunction - -function FloatQ(obj) - return a:obj.type == "float" -endfunction - -function ListQ(obj) - return a:obj.type == "list" -endfunction - -function VectorQ(obj) - return a:obj.type == "vector" -endfunction - -function SequentialQ(obj) - return ListQ(a:obj) || VectorQ(a:obj) -endfunction - -function HashQ(obj) - return a:obj.type == "hash" -endfunction - -function FunctionQ(obj) - return a:obj.type == "function" && !a:obj.val.is_macro -endfunction - -function MacroQ(obj) - return a:obj.type == "function" && a:obj.val.is_macro -endfunction - -function NativeFunctionQ(obj) - return a:obj.type == "nativefunction" -endfunction - -function NilNew() - return ObjNew("nil", "") -endfunction - -function TrueNew() - return ObjNew("true", "") -endfunction - -function FalseNew() - return ObjNew("false", "") -endfunction - -function BoolNew(bool) - return a:bool ? g:MalTrue : g:MalFalse -endfunction - -function KeywordNew(val) - return ObjNew("keyword", a:val) -endfunction - -function AtomNew(val) - return ObjNewWithMeta("atom", a:val, g:MalNil) -endfunction - -function SymbolNew(val) - return ObjNew("symbol", a:val) -endfunction - -function StringNew(val) - return ObjNew("string", a:val) -endfunction - -function IntegerNew(val) - return ObjNew("integer", a:val) -endfunction - -function FloatNew(val) - return ObjNew("float", a:val) -endfunction - -function ListNew(val) - return ObjNewWithMeta("list", a:val, g:MalNil) -endfunction - -function VectorNew(val) - return ObjNewWithMeta("vector", a:val, g:MalNil) -endfunction - -function HashNew(val) - return ObjNewWithMeta("hash", a:val, g:MalNil) -endfunction - -function HashMakeKey(obj) - if !StringQ(a:obj) && !KeywordQ(a:obj) - throw "expected hash-map key string, got: " . a:obj.type); - endif - return a:obj.type . "#" . a:obj.val -endfunction - -function HashParseKey(str) - if a:str =~ "^string#" - return StringNew(a:str[7:]) - elseif a:str =~ "^keyword#" - return KeywordNew(a:str[8:]) - endif -endfunction - -function HashBuild(elements) - if (len(a:elements) % 2) != 0 - throw "Odd number of hash-map arguments" - endif - let i = 0 - let hash = {} - while i < len(a:elements) - let key = a:elements[i] - let val = a:elements[i + 1] - let keystring = HashMakeKey(key) - let hash[keystring] = val - let i = i + 2 - endwhile - return HashNew(hash) -endfunction - -function HashEqualQ(x, y) - if len(a:x.val) != len(a:y.val) - return 0 - endif - for k in keys(a:x.val) - let vx = a:x.val[k] - let vy = a:y.val[k] - if empty(vy) || !EqualQ(vx, vy) - return 0 - endif - endfor - return 1 -endfunction - -function SequentialEqualQ(x, y) - if len(a:x.val) != len(a:y.val) - return 0 - endif - let i = 0 - while i < len(a:x.val) - let ex = a:x.val[i] - let ey = a:y.val[i] - if !EqualQ(ex, ey) - return 0 - endif - let i = i +1 - endwhile - return 1 -endfunction - -function EqualQ(x, y) - if SequentialQ(a:x) && SequentialQ(a:y) - return SequentialEqualQ(a:x, a:y) - elseif HashQ(a:x) && HashQ(a:y) - return HashEqualQ(a:x, a:y) - elseif a:x.type != a:y.type - return 0 - else - return a:x.val == a:y.val - endif -endfunction - -function EmptyQ(list) - return empty(a:list.val) -endfunction - -function ListCount(list) - return len(a:list.val) -endfunction - -function ListNth(list, index) - if a:index >= len(a:list.val) - throw "nth: index out of range" - endif - return a:list.val[a:index] -endfunction - -function ListFirst(list) - return get(a:list.val, 0, g:MalNil) -endfunction - -function ListDrop(list, drop_elements) - return ListNew(a:list.val[a:drop_elements :]) -endfunction - -function ListRest(list) - return ListDrop(a:list, 1) -endfunction - -function FuncInvoke(funcobj, args) - let fn = a:funcobj.val - let funcenv = NewEnvWithBinds(fn.env, fn.params, a:args) - return EVAL(fn.ast, funcenv) -endfunction - -function NativeFuncInvoke(funcobj, argslist) - let fn = a:funcobj.val - return fn.Func(a:argslist.val) -endfunction - -function MarkAsMacro(funcobj) - let fn = a:funcobj.val - let mac = {"ast": fn.ast, "env": fn.env, "params": fn.params, "is_macro": 1} - return ObjNewWithMeta("function", mac, g:MalNil) -endfunction - -function NewFn(ast, env, params) - let fn = {"ast": a:ast, "env": a:env, "params": a:params, "is_macro": 0} - return ObjNewWithMeta("function", fn, g:MalNil) -endfunction - -function NewNativeFn(funcname) - let fn = {"Func": function(a:funcname), "name": a:funcname} - return ObjNewWithMeta("nativefunction", fn, g:MalNil) -endfunction - -function NewNativeFnLambda(lambdaexpr) - let fn = {"Func": a:lambdaexpr, "name": "inline"} - return ObjNewWithMeta("nativefunction", fn, g:MalNil) -endfunction - -let g:MalNil = NilNew() -let g:MalTrue = TrueNew() -let g:MalFalse = FalseNew() +" types module + +function ObjNewWithMeta(obj_type, obj_val, obj_meta) + return {"type": a:obj_type, "val": a:obj_val, "meta": a:obj_meta} +endfunction + +function ObjNew(obj_type, obj_val) + return {"type": a:obj_type, "val": a:obj_val} +endfunction + +function ObjHasMeta(obj) + return has_key(a:obj, "meta") +endfunction + +function ObjMeta(obj) + return ObjHasMeta(a:obj) ? a:obj["meta"] : g:MalNil +endfunction + +function ObjSetValue(obj, newval) + let a:obj["val"] = a:newval + return a:newval +endfunction + +function ObjSetMeta(obj, newmeta) + let a:obj["meta"] = a:newmeta + return a:newmeta +endfunction + +function SymbolQ(obj) + return a:obj.type == "symbol" +endfunction + +function StringQ(obj) + return a:obj.type == "string" +endfunction + +function KeywordQ(obj) + return a:obj.type == "keyword" +endfunction + +function AtomQ(obj) + return a:obj.type == "atom" +endfunction + +function NilQ(obj) + return a:obj.type == "nil" +endfunction + +function TrueQ(obj) + return a:obj.type == "true" +endfunction + +function FalseQ(obj) + return a:obj.type == "false" +endfunction + +function IntegerQ(obj) + return a:obj.type == "integer" +endfunction + +function FloatQ(obj) + return a:obj.type == "float" +endfunction + +function ListQ(obj) + return a:obj.type == "list" +endfunction + +function VectorQ(obj) + return a:obj.type == "vector" +endfunction + +function SequentialQ(obj) + return ListQ(a:obj) || VectorQ(a:obj) +endfunction + +function HashQ(obj) + return a:obj.type == "hash" +endfunction + +function FunctionQ(obj) + return a:obj.type == "function" && !a:obj.val.is_macro +endfunction + +function MacroQ(obj) + return a:obj.type == "function" && a:obj.val.is_macro +endfunction + +function NativeFunctionQ(obj) + return a:obj.type == "nativefunction" +endfunction + +function NilNew() + return ObjNew("nil", "") +endfunction + +function TrueNew() + return ObjNew("true", "") +endfunction + +function FalseNew() + return ObjNew("false", "") +endfunction + +function BoolNew(bool) + return a:bool ? g:MalTrue : g:MalFalse +endfunction + +function KeywordNew(val) + return ObjNew("keyword", a:val) +endfunction + +function AtomNew(val) + return ObjNewWithMeta("atom", a:val, g:MalNil) +endfunction + +function SymbolNew(val) + return ObjNew("symbol", a:val) +endfunction + +function StringNew(val) + return ObjNew("string", a:val) +endfunction + +function IntegerNew(val) + return ObjNew("integer", a:val) +endfunction + +function FloatNew(val) + return ObjNew("float", a:val) +endfunction + +function ListNew(val) + return ObjNewWithMeta("list", a:val, g:MalNil) +endfunction + +function VectorNew(val) + return ObjNewWithMeta("vector", a:val, g:MalNil) +endfunction + +function HashNew(val) + return ObjNewWithMeta("hash", a:val, g:MalNil) +endfunction + +function HashMakeKey(obj) + if !StringQ(a:obj) && !KeywordQ(a:obj) + throw "expected hash-map key string, got: " . a:obj.type); + endif + return a:obj.type . "#" . a:obj.val +endfunction + +function HashParseKey(str) + if a:str =~ "^string#" + return StringNew(a:str[7:]) + elseif a:str =~ "^keyword#" + return KeywordNew(a:str[8:]) + endif +endfunction + +function HashBuild(elements) + if (len(a:elements) % 2) != 0 + throw "Odd number of hash-map arguments" + endif + let i = 0 + let hash = {} + while i < len(a:elements) + let key = a:elements[i] + let val = a:elements[i + 1] + let keystring = HashMakeKey(key) + let hash[keystring] = val + let i = i + 2 + endwhile + return HashNew(hash) +endfunction + +function HashEqualQ(x, y) + if len(a:x.val) != len(a:y.val) + return 0 + endif + for k in keys(a:x.val) + let vx = a:x.val[k] + let vy = a:y.val[k] + if empty(vy) || !EqualQ(vx, vy) + return 0 + endif + endfor + return 1 +endfunction + +function SequentialEqualQ(x, y) + if len(a:x.val) != len(a:y.val) + return 0 + endif + let i = 0 + while i < len(a:x.val) + let ex = a:x.val[i] + let ey = a:y.val[i] + if !EqualQ(ex, ey) + return 0 + endif + let i = i +1 + endwhile + return 1 +endfunction + +function EqualQ(x, y) + if SequentialQ(a:x) && SequentialQ(a:y) + return SequentialEqualQ(a:x, a:y) + elseif HashQ(a:x) && HashQ(a:y) + return HashEqualQ(a:x, a:y) + elseif a:x.type != a:y.type + return 0 + else + return a:x.val == a:y.val + endif +endfunction + +function EmptyQ(list) + return empty(a:list.val) +endfunction + +function ListCount(list) + return len(a:list.val) +endfunction + +function ListNth(list, index) + if a:index >= len(a:list.val) + throw "nth: index out of range" + endif + return a:list.val[a:index] +endfunction + +function ListFirst(list) + return get(a:list.val, 0, g:MalNil) +endfunction + +function ListDrop(list, drop_elements) + return ListNew(a:list.val[a:drop_elements :]) +endfunction + +function ListRest(list) + return ListDrop(a:list, 1) +endfunction + +function FuncInvoke(funcobj, args) + let fn = a:funcobj.val + let funcenv = NewEnvWithBinds(fn.env, fn.params, a:args) + return EVAL(fn.ast, funcenv) +endfunction + +function NativeFuncInvoke(funcobj, argslist) + let fn = a:funcobj.val + return fn.Func(a:argslist.val) +endfunction + +function MarkAsMacro(funcobj) + let fn = a:funcobj.val + let mac = {"ast": fn.ast, "env": fn.env, "params": fn.params, "is_macro": 1} + return ObjNewWithMeta("function", mac, g:MalNil) +endfunction + +function NewFn(ast, env, params) + let fn = {"ast": a:ast, "env": a:env, "params": a:params, "is_macro": 0} + return ObjNewWithMeta("function", fn, g:MalNil) +endfunction + +function NewNativeFn(funcname) + let fn = {"Func": function(a:funcname), "name": a:funcname} + return ObjNewWithMeta("nativefunction", fn, g:MalNil) +endfunction + +function NewNativeFnLambda(lambdaexpr) + let fn = {"Func": a:lambdaexpr, "name": "inline"} + return ObjNewWithMeta("nativefunction", fn, g:MalNil) +endfunction + +let g:MalNil = NilNew() +let g:MalTrue = TrueNew() +let g:MalFalse = FalseNew() diff --git a/impls/vimscript/vimextras.c b/impls/vimscript/vimextras.c index 15d9d5ad9c..2f8764f03a 100644 --- a/impls/vimscript/vimextras.c +++ b/impls/vimscript/vimextras.c @@ -1,44 +1,44 @@ -#include -#include -#include -#include -#include - -/* - * Vim interface for the readline(3) function. - * - * Prints 'prompt' and reads a line from the input. If EOF is encountered, - * returns the string "E"; otherwise, returns the string "S" where - * is the line read from input. - * - * This function is not thread-safe. - */ -char* vimreadline(char* prompt) { - static char buf[1024]; - char* res = readline(prompt); - if (res) { - buf[0] = 'S'; - strncpy(buf + 1, res, sizeof(buf) - 1); - free(res); - } else { - buf[0] = 'E'; - buf[1] = '\0'; - } - return buf; -} - -#define UNIXTIME_BASE 1451606400 /* = Unix time of 2016-01-01 */ - -/* - * Returns the number of milliseconds since 2016-01-01 00:00:00 UTC. - * - * This date is chosen (instead of the standard 1970 epoch) so the number of - * milliseconds will not exceed a 32-bit integer, which is the limit for Vim - * number variables. - */ -int vimtimems(int dummy) { - struct timeval tv; - (void) dummy; /* unused */ - gettimeofday(&tv, NULL); - return (tv.tv_sec - UNIXTIME_BASE) * 1000 + (tv.tv_usec / 1000); -} +#include +#include +#include +#include +#include + +/* + * Vim interface for the readline(3) function. + * + * Prints 'prompt' and reads a line from the input. If EOF is encountered, + * returns the string "E"; otherwise, returns the string "S" where + * is the line read from input. + * + * This function is not thread-safe. + */ +char* vimreadline(char* prompt) { + static char buf[1024]; + char* res = readline(prompt); + if (res) { + buf[0] = 'S'; + strncpy(buf + 1, res, sizeof(buf) - 1); + free(res); + } else { + buf[0] = 'E'; + buf[1] = '\0'; + } + return buf; +} + +#define UNIXTIME_BASE 1451606400 /* = Unix time of 2016-01-01 */ + +/* + * Returns the number of milliseconds since 2016-01-01 00:00:00 UTC. + * + * This date is chosen (instead of the standard 1970 epoch) so the number of + * milliseconds will not exceed a 32-bit integer, which is the limit for Vim + * number variables. + */ +int vimtimems(int dummy) { + struct timeval tv; + (void) dummy; /* unused */ + gettimeofday(&tv, NULL); + return (tv.tv_sec - UNIXTIME_BASE) * 1000 + (tv.tv_usec / 1000); +} diff --git a/impls/wasm/Dockerfile b/impls/wasm/Dockerfile index 1bf83ce05e..51fdd518f4 100644 --- a/impls/wasm/Dockerfile +++ b/impls/wasm/Dockerfile @@ -1,198 +1,198 @@ -FROM ubuntu:18.04 as base -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -# -# node -# - -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs - -ENV NPM_CONFIG_CACHE /mal/.npm - -# -# wace build and runtime libs -# -RUN dpkg --add-architecture i386 && \ - apt-get -y update && \ - apt-get -y install \ - lib32gcc-8-dev libsdl2-dev:i386 libsdl2-image-dev:i386 \ - libedit-dev:i386 freeglut3-dev:i386 lib32gcc-7-dev \ - libreadline-dev:i386 - -# -# binaryen -# -RUN apt-get -y install git-core cmake - -RUN git clone https://github.com/WebAssembly/binaryen/ && \ - cd binaryen && \ - cmake . && make && \ - make install && \ - cd .. && \ - rm -r binaryen - -########################################################################### -FROM base as build_tools -########################################################################### - -# -# clang/LLVM and rust (for building wasmtime) -# -RUN apt-get -y install llvm-3.9-dev libclang-3.9-dev clang-3.9 -RUN apt-get -y install curl && \ - curl https://sh.rustup.rs -sSf > /tmp/rustup.sh && \ - sh /tmp/rustup.sh -y -ENV PATH $PATH:/root/.cargo/bin - -# -# pypy / rpython (for building warpy) -# - -# rpython deps -ENV DEBIAN_FRONTEND=noninteractive -RUN apt-get -y install libffi-dev pkg-config libz-dev \ - libbz2-dev libsqlite3-dev libncurses-dev libexpat1-dev \ - libssl-dev libgdbm-dev tcl-dev - -# install pypy, build and install pypy/rpython, remove prior pypy -RUN apt-get -y install software-properties-common && \ - add-apt-repository ppa:pypy && \ - apt-get -y update && \ - apt-get -y install pypy && \ - mkdir -p /opt/pypy && \ - curl -L https://bitbucket.org/pypy/pypy/downloads/pypy2-v6.0.0-src.tar.bz2 \ - | tar -xjf - -C /opt/pypy/ --strip-components=1 && \ - cd /opt/pypy && make && \ - chmod -R ugo+rw /opt/pypy/rpython/_cache && \ - ln -sf /opt/pypy/rpython/bin/rpython /usr/local/bin/rpython && \ - ln -sf /opt/pypy/pypy-c /usr/local/bin/pypy && \ - rm -rf /tmp/usession* && \ - ln -sf /opt/pypy/pypy/goal/pypy-c /usr/local/bin/pypy && \ - apt-get -y autoremove pypy - - -# -# wasi-sdk (C/C++ -> wasm+wasi) -# -RUN curl -LO https://github.com/CraneStation/wasi-sdk/releases/download/wasi-sdk-5/wasi-sdk_5.0_amd64.deb && \ - dpkg -i wasi-sdk_5.0_amd64.deb && \ - rm wasi-sdk_5.0_amd64.deb - -## -## Rust wasm support -## -#RUN rustup default nightly -#RUN rustup target add wasm32-unknown-wasi --toolchain nightly -##RUN cargo +nightly build --target wasm32-unknown-wasi -# -## TODO: Do this when we install rust instead -#RUN mv /root/.cargo /opt/cargo && mv /root/.rustup /opt/rustup -#RUN chmod -R a+r /opt/cargo && chmod -R a+rw /opt/rustup -#ENV CARGO_HOME /opt/cargo -#ENV RUSTUP_HOME /opt/rustup -#ENV PATH $PATH:/opt/cargo/bin - -########################################################################### -FROM build_tools as runtimes -########################################################################### - -# -# warpy -# -RUN git clone https://github.com/kanaka/warpy/ && \ - cd warpy && \ - make warpy-nojit && \ - cp warpy-nojit /usr/bin/warpy - -# -# wac/wace -# -RUN git clone https://github.com/kanaka/wac/ && \ - cd wac && \ - make USE_SDL= wac wax wace && \ - cp wac wax wace /usr/bin - -# -# wasmer -# - -RUN curl https://get.wasmer.io -sSfL | sh && \ - cp /root/.wasmer/bin/wasmer /usr/bin/wasmer && \ - cp /root/.wasmer/bin/wapm /usr/bin/wapm - -#RUN git clone --recursive https://github.com/wasmerio/wasmer && \ -# cd wasmer && \ -# cargo build --release && \ -# cp target/release/wasmer /usr/bin/ - -# -# lucet -# - -RUN git clone --recursive https://github.com/fastly/lucet && \ - cd lucet && \ - make install - -# -# wasmtime -# - -RUN curl -L https://github.com/CraneStation/wasmtime/releases/download/dev/wasmtime-dev-x86_64-linux.tar.xz | tar xvJf - && \ - cp wasmtime-dev-x86_64-linux/wasmtime /usr/bin/wasmtime && \ - cp wasmtime-dev-x86_64-linux/wasm2obj /usr/bin/wasm2obj - -#RUN git clone --recursive https://github.com/CraneStation/wasmtime && \ -# cd wasmtime && \ -# sed -i 's/c3994bf57b5d2f1f973b0e4e37bc385695aa4ed2/8ea7a983d8b1364e5f62d2adf0e74b3b8db1c9b3/' Cargo.toml && \ -# cargo build --release && \ -# cp target/release/wasmtime /usr/bin/ && \ -# cp target/release/wasm2obj /usr/bin/ - - -########################################################################### -FROM base as wasm -########################################################################### - -COPY --from=runtimes /usr/bin/wac /usr/bin/wac -COPY --from=runtimes /usr/bin/wax /usr/bin/wax -COPY --from=runtimes /usr/bin/wace /usr/bin/wace -COPY --from=runtimes /usr/bin/warpy /usr/bin/warpy -COPY --from=runtimes /usr/bin/wasmtime /usr/bin/wasmtime -COPY --from=runtimes /usr/bin/wasm2obj /usr/bin/wasm2obj - -RUN mkdir -p /opt/lucet/bin -COPY --from=runtimes /opt/lucet/ /opt/lucet -RUN ln -sf /opt/lucet/bin/lucetc-wasi /usr/bin/lucetc-wasi -RUN ln -sf /opt/lucet/bin/lucet-wasi /usr/bin/lucet-wasi - -COPY --from=runtimes /usr/bin/wasmer /usr/bin/wasmer -COPY --from=runtimes /usr/bin/wapm /usr/bin/wapm - +FROM ubuntu:18.04 as base +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +# +# node +# + +# For building node modules +RUN apt-get -y install g++ + +# Add nodesource apt repo config for 10.x stable +RUN apt-get -y install gnupg +RUN curl -sL https://deb.nodesource.com/setup_10.x | bash - + +# Install nodejs +RUN apt-get -y install nodejs + +ENV NPM_CONFIG_CACHE /mal/.npm + +# +# wace build and runtime libs +# +RUN dpkg --add-architecture i386 && \ + apt-get -y update && \ + apt-get -y install \ + lib32gcc-8-dev libsdl2-dev:i386 libsdl2-image-dev:i386 \ + libedit-dev:i386 freeglut3-dev:i386 lib32gcc-7-dev \ + libreadline-dev:i386 + +# +# binaryen +# +RUN apt-get -y install git-core cmake + +RUN git clone https://github.com/WebAssembly/binaryen/ && \ + cd binaryen && \ + cmake . && make && \ + make install && \ + cd .. && \ + rm -r binaryen + +########################################################################### +FROM base as build_tools +########################################################################### + +# +# clang/LLVM and rust (for building wasmtime) +# +RUN apt-get -y install llvm-3.9-dev libclang-3.9-dev clang-3.9 +RUN apt-get -y install curl && \ + curl https://sh.rustup.rs -sSf > /tmp/rustup.sh && \ + sh /tmp/rustup.sh -y +ENV PATH $PATH:/root/.cargo/bin + +# +# pypy / rpython (for building warpy) +# + +# rpython deps +ENV DEBIAN_FRONTEND=noninteractive +RUN apt-get -y install libffi-dev pkg-config libz-dev \ + libbz2-dev libsqlite3-dev libncurses-dev libexpat1-dev \ + libssl-dev libgdbm-dev tcl-dev + +# install pypy, build and install pypy/rpython, remove prior pypy +RUN apt-get -y install software-properties-common && \ + add-apt-repository ppa:pypy && \ + apt-get -y update && \ + apt-get -y install pypy && \ + mkdir -p /opt/pypy && \ + curl -L https://bitbucket.org/pypy/pypy/downloads/pypy2-v6.0.0-src.tar.bz2 \ + | tar -xjf - -C /opt/pypy/ --strip-components=1 && \ + cd /opt/pypy && make && \ + chmod -R ugo+rw /opt/pypy/rpython/_cache && \ + ln -sf /opt/pypy/rpython/bin/rpython /usr/local/bin/rpython && \ + ln -sf /opt/pypy/pypy-c /usr/local/bin/pypy && \ + rm -rf /tmp/usession* && \ + ln -sf /opt/pypy/pypy/goal/pypy-c /usr/local/bin/pypy && \ + apt-get -y autoremove pypy + + +# +# wasi-sdk (C/C++ -> wasm+wasi) +# +RUN curl -LO https://github.com/CraneStation/wasi-sdk/releases/download/wasi-sdk-5/wasi-sdk_5.0_amd64.deb && \ + dpkg -i wasi-sdk_5.0_amd64.deb && \ + rm wasi-sdk_5.0_amd64.deb + +## +## Rust wasm support +## +#RUN rustup default nightly +#RUN rustup target add wasm32-unknown-wasi --toolchain nightly +##RUN cargo +nightly build --target wasm32-unknown-wasi +# +## TODO: Do this when we install rust instead +#RUN mv /root/.cargo /opt/cargo && mv /root/.rustup /opt/rustup +#RUN chmod -R a+r /opt/cargo && chmod -R a+rw /opt/rustup +#ENV CARGO_HOME /opt/cargo +#ENV RUSTUP_HOME /opt/rustup +#ENV PATH $PATH:/opt/cargo/bin + +########################################################################### +FROM build_tools as runtimes +########################################################################### + +# +# warpy +# +RUN git clone https://github.com/kanaka/warpy/ && \ + cd warpy && \ + make warpy-nojit && \ + cp warpy-nojit /usr/bin/warpy + +# +# wac/wace +# +RUN git clone https://github.com/kanaka/wac/ && \ + cd wac && \ + make USE_SDL= wac wax wace && \ + cp wac wax wace /usr/bin + +# +# wasmer +# + +RUN curl https://get.wasmer.io -sSfL | sh && \ + cp /root/.wasmer/bin/wasmer /usr/bin/wasmer && \ + cp /root/.wasmer/bin/wapm /usr/bin/wapm + +#RUN git clone --recursive https://github.com/wasmerio/wasmer && \ +# cd wasmer && \ +# cargo build --release && \ +# cp target/release/wasmer /usr/bin/ + +# +# lucet +# + +RUN git clone --recursive https://github.com/fastly/lucet && \ + cd lucet && \ + make install + +# +# wasmtime +# + +RUN curl -L https://github.com/CraneStation/wasmtime/releases/download/dev/wasmtime-dev-x86_64-linux.tar.xz | tar xvJf - && \ + cp wasmtime-dev-x86_64-linux/wasmtime /usr/bin/wasmtime && \ + cp wasmtime-dev-x86_64-linux/wasm2obj /usr/bin/wasm2obj + +#RUN git clone --recursive https://github.com/CraneStation/wasmtime && \ +# cd wasmtime && \ +# sed -i 's/c3994bf57b5d2f1f973b0e4e37bc385695aa4ed2/8ea7a983d8b1364e5f62d2adf0e74b3b8db1c9b3/' Cargo.toml && \ +# cargo build --release && \ +# cp target/release/wasmtime /usr/bin/ && \ +# cp target/release/wasm2obj /usr/bin/ + + +########################################################################### +FROM base as wasm +########################################################################### + +COPY --from=runtimes /usr/bin/wac /usr/bin/wac +COPY --from=runtimes /usr/bin/wax /usr/bin/wax +COPY --from=runtimes /usr/bin/wace /usr/bin/wace +COPY --from=runtimes /usr/bin/warpy /usr/bin/warpy +COPY --from=runtimes /usr/bin/wasmtime /usr/bin/wasmtime +COPY --from=runtimes /usr/bin/wasm2obj /usr/bin/wasm2obj + +RUN mkdir -p /opt/lucet/bin +COPY --from=runtimes /opt/lucet/ /opt/lucet +RUN ln -sf /opt/lucet/bin/lucetc-wasi /usr/bin/lucetc-wasi +RUN ln -sf /opt/lucet/bin/lucet-wasi /usr/bin/lucet-wasi + +COPY --from=runtimes /usr/bin/wasmer /usr/bin/wasmer +COPY --from=runtimes /usr/bin/wapm /usr/bin/wapm + diff --git a/impls/wasm/Makefile b/impls/wasm/Makefile index 453605be43..3d5ea72348 100644 --- a/impls/wasm/Makefile +++ b/impls/wasm/Makefile @@ -1,47 +1,47 @@ -MODE ?= $(strip \ - $(if $(filter wace_libc,$(wasm_MODE)),\ - libc,\ - $(if $(filter direct node js wace_fooboot warpy,$(wasm_MODE)),\ - direct,\ - wasi))) - -EXT = $(if $(filter lucet,$(wasm_MODE)),.so,.wasm) - -WASM_AS ?= wasm-as -WAMP ?= node_modules/.bin/wamp -LUCETC ?= lucetc-wasi - -STEP0_DEPS = $(WAMP) platform_$(MODE).wam string.wam printf.wam -STEP1_DEPS = $(STEP0_DEPS) types.wam mem.wam debug.wam reader.wam printer.wam -STEP3_DEPS = $(STEP1_DEPS) env.wam -STEP4_DEPS = $(STEP3_DEPS) core.wam - -STEPS = step0_repl step1_read_print step2_eval step3_env \ - step4_if_fn_do step5_tco step6_file step7_quote \ - step8_macros step9_try stepA_mal - -all: $(foreach s,$(STEPS),$(s)$(EXT)) - -node_modules/.bin/wamp: - npm install - -%.wat: %.wam - $(WAMP) $(filter %.wam,$^) > $*.wat - -%.wasm: %.wat - $(WASM_AS) $< -o $@ - -# lucet object binaries -%.so: %.wasm - $(LUCETC) $< -o $@ - -step0_repl.wat: $(STEP0_DEPS) -step1_read_print.wat step2_eval.wat: $(STEP1_DEPS) -step3_env.wat: $(STEP3_DEPS) -step4_if_fn_do.wat step5_tco.wat step6_file.wat: $(STEP4_DEPS) -step7_quote.wat step8_macros.wat step9_try.wat stepA_mal.wat: $(STEP4_DEPS) - -.PHONY: clean - -clean: - rm -f *.wat *.wasm *.so +MODE ?= $(strip \ + $(if $(filter wace_libc,$(wasm_MODE)),\ + libc,\ + $(if $(filter direct node js wace_fooboot warpy,$(wasm_MODE)),\ + direct,\ + wasi))) + +EXT = $(if $(filter lucet,$(wasm_MODE)),.so,.wasm) + +WASM_AS ?= wasm-as +WAMP ?= node_modules/.bin/wamp +LUCETC ?= lucetc-wasi + +STEP0_DEPS = $(WAMP) platform_$(MODE).wam string.wam printf.wam +STEP1_DEPS = $(STEP0_DEPS) types.wam mem.wam debug.wam reader.wam printer.wam +STEP3_DEPS = $(STEP1_DEPS) env.wam +STEP4_DEPS = $(STEP3_DEPS) core.wam + +STEPS = step0_repl step1_read_print step2_eval step3_env \ + step4_if_fn_do step5_tco step6_file step7_quote \ + step8_macros step9_try stepA_mal + +all: $(foreach s,$(STEPS),$(s)$(EXT)) + +node_modules/.bin/wamp: + npm install + +%.wat: %.wam + $(WAMP) $(filter %.wam,$^) > $*.wat + +%.wasm: %.wat + $(WASM_AS) $< -o $@ + +# lucet object binaries +%.so: %.wasm + $(LUCETC) $< -o $@ + +step0_repl.wat: $(STEP0_DEPS) +step1_read_print.wat step2_eval.wat: $(STEP1_DEPS) +step3_env.wat: $(STEP3_DEPS) +step4_if_fn_do.wat step5_tco.wat step6_file.wat: $(STEP4_DEPS) +step7_quote.wat step8_macros.wat step9_try.wat stepA_mal.wat: $(STEP4_DEPS) + +.PHONY: clean + +clean: + rm -f *.wat *.wasm *.so diff --git a/impls/wasm/core.wam b/impls/wasm/core.wam index add993aa06..aff720dbd2 100644 --- a/impls/wasm/core.wam +++ b/impls/wasm/core.wam @@ -1,731 +1,731 @@ -(module $core - - - ;; it would be nice to have this in types.wam but it uses - ;; ENV_NEW_BINDS which is not available until step3 but types is - ;; used in step1 - - (func $APPLY (param $f i32) (param $args i32) (result i32) - (local $res i32 $env i32 $ftype i32 $a i32) - (local.set $f ($DEREF_META $f)) - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - ;; Must be kept in sync with EVAL's FUNCTION_T evaluation - (if (i32.eq ($VAL0 $f) 0) ;; eval - (then - (local.set $res ($EVAL ($MEM_VAL1_ptr $args) - (global.get $repl_env)))) - (else - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))))) - (else (if (OR (i32.eq $ftype (global.get $MALFUNC_T)) - (i32.eq $ftype (global.get $MACRO_T))) - (then - ;; create new environment using env and params stored in function - (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) - ($MEM_VAL1_ptr $f) $args)) - - ;; claim the AST before releasing the list containing it - (local.set $a ($MEM_VAL0_ptr $f)) - (drop ($INC_REF $a)) - - (local.set $res ($EVAL $a $env)) - - ($RELEASE $env) - ($RELEASE $a)) - (else - ($THROW_STR_1 "APPLY of non-function type: %d\n" $ftype) - (local.set $res 0))))) - $res - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; core functions - - (type $fnT (func (param i32) (result i32))) - - (func $equal_Q (param $args i32) (result i32) - ($TRUE_FALSE ($EQUAL_Q ($MEM_VAL1_ptr $args) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))))) - - (func $throw (param $args i32) (result i32) - (global.set $error_type 2) - (global.set $error_val ($INC_REF ($MEM_VAL1_ptr $args))) - 0 - ) - - (func $nil_Q (param $args i32) (result i32) - ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (global.get $NIL_T)))) - (func $true_Q (param $args i32) (result i32) - (LET $ast ($MEM_VAL1_ptr $args)) - ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (global.get $BOOLEAN_T)) - (i32.eq ($VAL0 $ast) 1))) - ) - (func $false_Q (param $args i32) (result i32) - (LET $ast ($MEM_VAL1_ptr $args)) - ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (global.get $BOOLEAN_T)) - (i32.eq ($VAL0 $ast) 0))) - ) - (func $number_Q (param $args i32) (result i32) - ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (global.get $INTEGER_T)))) - (func $string_Q (param $args i32) (result i32) - (LET $mv ($MEM_VAL1_ptr $args)) - ($TRUE_FALSE (AND (i32.eq ($TYPE $mv) (global.get $STRING_T)) - (i32.ne (i32.load8_u ($to_String $mv)) - (CHR "\x7f")))) - ) - - (func $keyword (param $args i32) (result i32) - (LET $str ($to_String ($MEM_VAL1_ptr $args))) - (if (result i32) (i32.eq (i32.load8_u $str) (CHR "\x7f")) - (then ($INC_REF ($MEM_VAL1_ptr $args))) - (else - (drop ($sprintf_1 (global.get $printf_buf) "\x7f%s" $str)) - ($STRING (global.get $STRING_T) (global.get $printf_buf)))) - ) - - (func $keyword_Q (param $args i32) (result i32) - (LET $ast ($MEM_VAL1_ptr $args)) - ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (global.get $STRING_T)) - (i32.eq (i32.load8_u ($to_String $ast)) - (CHR "\x7f")))) - ) - (func $fn_Q (param $args i32) (result i32) - (LET $type ($TYPE ($MEM_VAL1_ptr $args))) - ($TRUE_FALSE (OR (i32.eq $type (global.get $FUNCTION_T)) - (i32.eq $type (global.get $MALFUNC_T))))) - (func $macro_Q (param $args i32) (result i32) - ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (global.get $MACRO_T)))) - - (func $symbol (param $args i32) (result i32) - ($STRING (global.get $SYMBOL_T) ($to_String ($MEM_VAL1_ptr $args)))) - - (func $symbol_Q (param $args i32) (result i32) - ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (global.get $SYMBOL_T)))) - - (func $core_pr_str (param $args i32) (result i32) - ($pr_str_seq $args 1 " ")) - (func $str (param $args i32) (result i32) - ($pr_str_seq $args 0 "")) - (func $prn (param $args i32) (result i32) - (LET $res ($pr_str_seq $args 1 " ")) - ($printf_1 "%s\n" ($to_String $res)) - ($RELEASE $res) - ($INC_REF (global.get $NIL)) - ) - (func $println (param $args i32) (result i32) - (LET $res ($pr_str_seq $args 0 " ")) - ($printf_1 "%s\n" ($to_String $res)) - ($RELEASE $res) - ($INC_REF (global.get $NIL)) - ) - - (func $core_readline (param $args i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $mv 0) - (if (i32.eqz ($readline ($to_String ($MEM_VAL1_ptr $args)) $line)) - (return ($INC_REF (global.get $NIL)))) - (local.set $mv ($STRING (global.get $STRING_T) $line)) - $mv - ) - - (func $read_string (param $args i32) (result i32) - ($read_str ($to_String ($MEM_VAL1_ptr $args)))) - - (func $slurp (param $args i32) (result i32) - (LET $mv ($STRING_INIT (global.get $STRING_T)) - $size ($read_file ($to_String ($MEM_VAL1_ptr $args)) - ($to_String $mv))) - (if (i32.eqz $size) - (then - ($THROW_STR_1 "failed to read file '%s'" ($to_String ($MEM_VAL1_ptr $args))) - (return ($INC_REF (global.get $NIL))))) - (local.set $mv ($STRING_FINALIZE $mv $size)) - $mv - ) - - (func $lt (param $args i32) (result i32) - ($TRUE_FALSE - (i32.lt_s ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $lte (param $args i32) (result i32) - ($TRUE_FALSE - (i32.le_s ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $gt (param $args i32) (result i32) - ($TRUE_FALSE - (i32.gt_s ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $gte (param $args i32) (result i32) - ($TRUE_FALSE - (i32.ge_s ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $add (param $args i32) (result i32) - ($INTEGER - (i32.add ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $subtract (param $args i32) (result i32) - ($INTEGER - (i32.sub ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $multiply (param $args i32) (result i32) - ($INTEGER - (i32.mul ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $divide (param $args i32) (result i32) - ($INTEGER - (i32.div_s ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - - (func $time_ms (param $args i32) (result i32) - ($INTEGER ($get_time_ms))) - - ;;; - - (func $list (param $args i32) (result i32) - ($INC_REF $args)) - - (func $list_Q (param $args i32) (result i32) - ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) - (global.get $LIST_T)))) - - (func $vector (param $args i32) (result i32) - ($FORCE_SEQ_TYPE (global.get $VECTOR_T) $args)) - - (func $vector_Q (param $args i32) (result i32) - ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) - (global.get $VECTOR_T)))) - - (func $hash_map (param $args i32) (result i32) - (LET $type (global.get $HASHMAP_T) - $res ($MAP_LOOP_START $type) - $val2 0 - $val3 0 - $c 0 - ;; push MAP_LOOP stack - $ret $res - $current $res - $empty $res) - - ;; READ_SEQ_LOOP - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $args))) - - (local.set $val2 ($INC_REF ($MEM_VAL1_ptr $args))) - (local.set $val3 ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) - - ;; skip two - (local.set $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) - - ;; update the return sequence structure - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (br $loop) - ) - ) - - ;; MAP_LOOP_DONE - $ret - ) - - - (func $hash_map_Q (param $args i32) (result i32) - ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) - (global.get $HASHMAP_T)))) - - (func $assoc (param $args i32) (result i32) - (LET $hm ($MEM_VAL1_ptr $args) - $key 0) - (local.set $args ($MEM_VAL0_ptr $args)) - - (drop ($INC_REF $hm)) - (block $done - (loop $loop - (br_if $done (OR (i32.eqz ($VAL0 $args)) - (i32.eqz ($VAL0 ($MEM_VAL0_ptr $args))))) - (local.set $hm ($ASSOC1 $hm ($MEM_VAL1_ptr $args) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) - (local.set $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) - - (br $loop) - ) - ) - $hm - ) - - (func $get (param $args i32) (result i32) - (LET $hm ($MEM_VAL1_ptr $args) - $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) - (if (result i32) (i32.eq $hm (global.get $NIL)) - (then ($INC_REF (global.get $NIL))) - (else ($INC_REF (i32.wrap_i64 ($HASHMAP_GET $hm $key))))) - ) - - (func $contains_Q (param $args i32) (result i32) - (LET $hm ($MEM_VAL1_ptr $args) - $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) - ($TRUE_FALSE - (if (result i32) (i32.eq $hm (global.get $NIL)) - (then 0) - (else (i32.wrap_i64 - (i64.shr_u ($HASHMAP_GET $hm $key) (i64.const 32)))))) - ) - - (func $keys_or_vals (param $hm i32 $keys i32) (result i32) - (LET $res ($MAP_LOOP_START (global.get $LIST_T)) - $val2 0 - ;; MAP_LOOP stack - $ret $res - $current $res - $empty $res) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $hm))) - - (if $keys - (then (local.set $val2 ($INC_REF ($MEM_VAL1_ptr $hm)))) - (else (local.set $val2 ($INC_REF ($MEM_VAL2_ptr $hm))))) - - ;; next element - (local.set $hm ($MEM_VAL0_ptr $hm)) - - ;; update the return sequence structure - ;; do not release val2 since we are pulling it from the - ;; arguments and not creating it here - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE (global.get $LIST_T) - $empty $current $val2 0)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (br $loop) - ) - ) - - ;; MAP_LOOP_DONE - $ret - ) - - (func $keys (param $args i32) (result i32) - ($keys_or_vals ($MEM_VAL1_ptr $args) 1)) - - (func $vals (param $args i32) (result i32) - ($keys_or_vals ($MEM_VAL1_ptr $args) 0)) - - (func $sequential_Q (param $args i32) (result i32) - ($TRUE_FALSE (OR (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (global.get $LIST_T)) - (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) - (global.get $VECTOR_T))))) - - (func $cons (param $args i32) (result i32) - ($LIST ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)) ($MEM_VAL1_ptr $args))) - - (func $concat (param $args i32) (result i32) - (local $last_sl i64) - (LET $res ($INC_REF (global.get $EMPTY_LIST)) - $current $res - $sl 0 - $last 0 - $arg 0) - (block $done - (loop $loop - (br_if $done (i32.le_u $args (global.get $EMPTY_HASHMAP))) - (local.set $arg ($MEM_VAL1_ptr $args)) - ;; skip empty elements - (if (i32.le_s $arg (global.get $EMPTY_HASHMAP)) - (then - (local.set $args ($MEM_VAL0_ptr $args)) - (br $loop))) - (local.set $last_sl ($SLICE $arg 0 -1)) - (local.set $sl (i32.wrap_i64 $last_sl)) - (local.set $last (i32.wrap_i64 (i64.shr_u $last_sl (i64.const 32)))) - (if (i32.eq $res (global.get $EMPTY_LIST)) - (then - ;; if this is the first element, set the return to the slice - (local.set $res $sl)) - (else - ;; otherwise attach current to sliced - (i32.store ($VAL0_ptr $current) ($IDX $sl)))) - ;; update current to end of sliced list - (local.set $current $last) - ;; release empty since no longer part of the slice - ($RELEASE (global.get $EMPTY_LIST)) - - (local.set $args ($MEM_VAL0_ptr $args)) - (br $loop) - ) - ) - $res - ) - - (func $vec (param $args i32) (result i32) - ($FORCE_SEQ_TYPE (global.get $VECTOR_T) ($MEM_VAL1_ptr $args))) - - (func $nth (param $args i32) (result i32) - (LET $a ($MEM_VAL1_ptr $args) - $idx ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) - $i 0) - - (block $done - (loop $loop - (br_if $done (OR (i32.ge_s $i $idx) (i32.eqz ($VAL0 $a)))) - (local.set $i (i32.add $i 1)) - (local.set $a ($MEM_VAL0_ptr $a)) - (br $loop) - ) - ) - (if (i32.eq ($VAL0 $a) 0) - (then - ($THROW_STR_0 "nth: index out of range") - (return 0))) - - ($INC_REF ($MEM_VAL1_ptr $a)) - ) - - (func $first (param $args i32) (result i32) - (LET $res (global.get $NIL) - $a ($MEM_VAL1_ptr $args)) - (if (AND (i32.ne $a (global.get $NIL)) - (i32.ne ($VAL0 $a) 0)) - (local.set $res ($MEM_VAL1_ptr $a))) - ($INC_REF $res) - ) - - (func $rest (param $args i32) (result i32) - (LET $a ($MEM_VAL1_ptr $args)) - (if (i32.eq $a (global.get $NIL)) - (return ($INC_REF (global.get $EMPTY_LIST)))) - (if (i32.ne ($VAL0 $a) 0) - (local.set $a ($MEM_VAL0_ptr $a))) - ($FORCE_SEQ_TYPE (global.get $LIST_T) $a) - ) - - ;;; - - (func $empty_Q (param $args i32) (result i32) - ($TRUE_FALSE ($EMPTY_Q ($MEM_VAL1_ptr $args)))) - - (func $count (param $args i32) (result i32) - ($INTEGER ($COUNT ($MEM_VAL1_ptr $args)))) - - (func $apply (param $args i32) (result i32) - (local $last_sl i64) - (LET $f ($MEM_VAL1_ptr $args) - $f_args 0 - $rest_args ($MEM_VAL0_ptr $args) - $rest_count ($COUNT $rest_args) - $last 0 - $res 0) - - (if (i32.le_s $rest_count 1) - (then - ;; no intermediate args - (if (i32.ne ($TYPE ($MEM_VAL1_ptr $rest_args)) (global.get $LIST_T)) - (then - ;; not a list, so convert it first - (local.set $f_args ($FORCE_SEQ_TYPE (global.get $LIST_T) - ($MEM_VAL1_ptr $rest_args)))) - (else - ;; inc ref since we will release after APPLY - (local.set $f_args ($INC_REF ($MEM_VAL1_ptr $rest_args)))))) - (else - ;; 1 or more intermediate args - (local.set $last_sl ($SLICE $rest_args 0 (i32.sub $rest_count 1))) - (local.set $f_args (i32.wrap_i64 $last_sl)) - (local.set $last (i32.wrap_i64 (i64.shr_u $last_sl (i64.const 32)))) - ;; release the terminator of the new list (we skip over it) - ;; we already checked for an empty list above, so $last is - ;; a real non-empty list - ($RELEASE ($MEM_VAL0_ptr $last)) - ;; attach end of slice to final args element - (i32.store ($VAL0_ptr $last) ($IDX ($LAST $rest_args))) - )) - - (local.set $res ($APPLY $f $f_args)) - - ;; release new args - ($RELEASE $f_args) - $res - ) - - (func $map (param $args i32) (result i32) - (LET $f ($MEM_VAL1_ptr $args) - $rest_args ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)) - $f_args 0 - $res ($MAP_LOOP_START (global.get $LIST_T)) - ;; push MAP_LOOP stack - $ret $res - $current $res - $empty $res) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $rest_args))) - - ;; create argument list for apply - (local.set $f_args ($ALLOC (global.get $LIST_T) - (global.get $EMPTY_LIST) - ($MEM_VAL1_ptr $rest_args) - 0)) - - (local.set $res ($APPLY $f $f_args)) - ($RELEASE $f_args) - - ;; go to the next element - (local.set $rest_args ($MEM_VAL0_ptr $rest_args)) - - (if (global.get $error_type) - (then - ;; if error, release the unattached element - ($RELEASE $res) - (br $done))) - - ;; update the return sequence structure - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE (global.get $LIST_T) - $empty $current $res 0)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (br $loop) - ) - ) - - ;; MAP_LOOP_DONE - $ret - ) - - ;;; - - (func $with_meta (param $args i32) (result i32) - (LET $mv ($MEM_VAL1_ptr $args) - $meta ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) - ;; remove existing metadata first - ($ALLOC (global.get $METADATA_T) ($DEREF_META $mv) $meta 0) - ) - - (func $meta (param $args i32) (result i32) - (if (result i32) (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (global.get $METADATA_T)) - (then ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL1_ptr $args)))) - (else ($INC_REF (global.get $NIL))))) - - (func $atom (param $args i32) (result i32) - ($ALLOC_SCALAR (global.get $ATOM_T) ($VAL1 $args))) - - (func $atom_Q (param $args i32) (result i32) - ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (global.get $ATOM_T)))) - - (func $deref (param $args i32) (result i32) - ($INC_REF ($MEM_VAL0_ptr ($MEM_VAL1_ptr $args)))) - - (func $_reset_BANG (param $atom i32 $val i32) (result i32) - ;; release current value since we are about to overwrite it - ($RELEASE ($MEM_VAL0_ptr $atom)) - ;; inc ref by 2 for atom ownership and since we are returning it - (drop ($INC_REF ($INC_REF $val))) - ;; update the value - (i32.store ($VAL0_ptr $atom) ($IDX $val)) - $val - ) - - (func $reset_BANG (param $args i32) (result i32) - (LET $atom ($MEM_VAL1_ptr $args) - $val ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) - ($_reset_BANG $atom $val) - ) - - (func $swap_BANG (param $args i32) (result i32) - (LET $atom ($MEM_VAL1_ptr $args) - $f_args ($MEM_VAL0_ptr $args) - $rest_args ($MEM_VAL0_ptr $f_args) - ;; add atom value to front of the args list - $s_args ($LIST $rest_args ($MEM_VAL0_ptr $atom)) ;; cons - $f ($MEM_VAL1_ptr $f_args) - $res ($APPLY $f $s_args)) - ;; release args - ($RELEASE $s_args) - ;; use reset to update the value - (drop ($_reset_BANG $atom $res)) - ;; but decrease the ref cnt of return by 1 (not sure why) - ($RELEASE $res) - $res - ) - - ;;; - - (func $pr_memory_summary (param $args i32) (result i32) - ($PR_MEMORY_SUMMARY_SMALL) - ($INC_REF (global.get $NIL)) - ) - - (func $nop (param $args i32) (result i32) - ($INC_REF (global.get $NIL))) - - (table - funcref - (elem $nop ;; placeholder for eval which will use 0 - $equal_Q - $throw - $nil_Q - $true_Q - $false_Q - $number_Q - $string_Q - $symbol - $symbol_Q - $keyword - $keyword_Q - $fn_Q - $macro_Q - - ;; 14 - $core_pr_str - $str - $prn - $println - $core_readline - $read_string - $slurp - $lt - $lte - $gt - $gte - $add - $subtract - $multiply - $divide - $time_ms - - ;; 30 - $list - $list_Q - $vector - $vector_Q - $hash_map - $hash_map_Q - $assoc - $nop ;; $dissoc - $get - $contains_Q - $keys - $vals - - ;; 42 - $sequential_Q - $cons - $concat - $nth - $first - $rest - $empty_Q - $count - $apply - $map - $nop ;; $conj - $nop ;; $seq - - ;; 54 - $with_meta - $meta - $atom - $atom_Q - $deref - $reset_BANG - $swap_BANG - - $pr_memory_summary - $vec - ) - ) - - (func $add_core_ns (param $env i32) - ;;(drop ($ENV_SET_S $env "eval" ($FUNCTION 0))) - (drop ($ENV_SET_S $env "=" ($FUNCTION 1))) - (drop ($ENV_SET_S $env "throw" ($FUNCTION 2))) - (drop ($ENV_SET_S $env "nil?" ($FUNCTION 3))) - (drop ($ENV_SET_S $env "true?" ($FUNCTION 4))) - (drop ($ENV_SET_S $env "false?" ($FUNCTION 5))) - (drop ($ENV_SET_S $env "number?" ($FUNCTION 6))) - (drop ($ENV_SET_S $env "string?" ($FUNCTION 7))) - (drop ($ENV_SET_S $env "symbol" ($FUNCTION 8))) - (drop ($ENV_SET_S $env "symbol?" ($FUNCTION 9))) - (drop ($ENV_SET_S $env "keyword" ($FUNCTION 10))) - (drop ($ENV_SET_S $env "keyword?" ($FUNCTION 11))) - (drop ($ENV_SET_S $env "fn?" ($FUNCTION 12))) - (drop ($ENV_SET_S $env "macro?" ($FUNCTION 13))) - - (drop ($ENV_SET_S $env "pr-str" ($FUNCTION 14))) - (drop ($ENV_SET_S $env "str" ($FUNCTION 15))) - (drop ($ENV_SET_S $env "prn" ($FUNCTION 16))) - (drop ($ENV_SET_S $env "println" ($FUNCTION 17))) - (drop ($ENV_SET_S $env "readline" ($FUNCTION 18))) - (drop ($ENV_SET_S $env "read-string" ($FUNCTION 19))) - (drop ($ENV_SET_S $env "slurp" ($FUNCTION 20))) - (drop ($ENV_SET_S $env "<" ($FUNCTION 21))) - (drop ($ENV_SET_S $env "<=" ($FUNCTION 22))) - (drop ($ENV_SET_S $env ">" ($FUNCTION 23))) - (drop ($ENV_SET_S $env ">=" ($FUNCTION 24))) - (drop ($ENV_SET_S $env "+" ($FUNCTION 25))) - (drop ($ENV_SET_S $env "-" ($FUNCTION 26))) - (drop ($ENV_SET_S $env "*" ($FUNCTION 27))) - (drop ($ENV_SET_S $env "/" ($FUNCTION 28))) - (drop ($ENV_SET_S $env "time-ms" ($FUNCTION 29))) - - (drop ($ENV_SET_S $env "list" ($FUNCTION 30))) - (drop ($ENV_SET_S $env "list?" ($FUNCTION 31))) - (drop ($ENV_SET_S $env "vector" ($FUNCTION 32))) - (drop ($ENV_SET_S $env "vector?" ($FUNCTION 33))) - (drop ($ENV_SET_S $env "hash-map" ($FUNCTION 34))) - (drop ($ENV_SET_S $env "map?" ($FUNCTION 35))) - (drop ($ENV_SET_S $env "assoc" ($FUNCTION 36))) - (drop ($ENV_SET_S $env "dissoc" ($FUNCTION 37))) - (drop ($ENV_SET_S $env "get" ($FUNCTION 38))) - (drop ($ENV_SET_S $env "contains?" ($FUNCTION 39))) - (drop ($ENV_SET_S $env "keys" ($FUNCTION 40))) - (drop ($ENV_SET_S $env "vals" ($FUNCTION 41))) - - (drop ($ENV_SET_S $env "sequential?" ($FUNCTION 42))) - (drop ($ENV_SET_S $env "cons" ($FUNCTION 43))) - (drop ($ENV_SET_S $env "concat" ($FUNCTION 44))) - (drop ($ENV_SET_S $env "nth" ($FUNCTION 45))) - (drop ($ENV_SET_S $env "first" ($FUNCTION 46))) - (drop ($ENV_SET_S $env "rest" ($FUNCTION 47))) - (drop ($ENV_SET_S $env "empty?" ($FUNCTION 48))) - (drop ($ENV_SET_S $env "count" ($FUNCTION 49))) - (drop ($ENV_SET_S $env "apply" ($FUNCTION 50))) - (drop ($ENV_SET_S $env "map" ($FUNCTION 51))) - - (drop ($ENV_SET_S $env "conj" ($FUNCTION 52))) - (drop ($ENV_SET_S $env "seq" ($FUNCTION 53))) - - (drop ($ENV_SET_S $env "with-meta" ($FUNCTION 54))) - (drop ($ENV_SET_S $env "meta" ($FUNCTION 55))) - (drop ($ENV_SET_S $env "atom" ($FUNCTION 56))) - (drop ($ENV_SET_S $env "atom?" ($FUNCTION 57))) - (drop ($ENV_SET_S $env "deref" ($FUNCTION 58))) - (drop ($ENV_SET_S $env "reset!" ($FUNCTION 59))) - (drop ($ENV_SET_S $env "swap!" ($FUNCTION 60))) - - (drop ($ENV_SET_S $env "pr-memory-summary" ($FUNCTION 61))) - (drop ($ENV_SET_S $env "vec" ($FUNCTION 62))) - ) -) +(module $core + + + ;; it would be nice to have this in types.wam but it uses + ;; ENV_NEW_BINDS which is not available until step3 but types is + ;; used in step1 + + (func $APPLY (param $f i32) (param $args i32) (result i32) + (local $res i32 $env i32 $ftype i32 $a i32) + (local.set $f ($DEREF_META $f)) + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + ;; Must be kept in sync with EVAL's FUNCTION_T evaluation + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) + (else + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))))) + (else (if (OR (i32.eq $ftype (global.get $MALFUNC_T)) + (i32.eq $ftype (global.get $MACRO_T))) + (then + ;; create new environment using env and params stored in function + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; claim the AST before releasing the list containing it + (local.set $a ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $a)) + + (local.set $res ($EVAL $a $env)) + + ($RELEASE $env) + ($RELEASE $a)) + (else + ($THROW_STR_1 "APPLY of non-function type: %d\n" $ftype) + (local.set $res 0))))) + $res + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; core functions + + (type $fnT (func (param i32) (result i32))) + + (func $equal_Q (param $args i32) (result i32) + ($TRUE_FALSE ($EQUAL_Q ($MEM_VAL1_ptr $args) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))))) + + (func $throw (param $args i32) (result i32) + (global.set $error_type 2) + (global.set $error_val ($INC_REF ($MEM_VAL1_ptr $args))) + 0 + ) + + (func $nil_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (global.get $NIL_T)))) + (func $true_Q (param $args i32) (result i32) + (LET $ast ($MEM_VAL1_ptr $args)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (global.get $BOOLEAN_T)) + (i32.eq ($VAL0 $ast) 1))) + ) + (func $false_Q (param $args i32) (result i32) + (LET $ast ($MEM_VAL1_ptr $args)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (global.get $BOOLEAN_T)) + (i32.eq ($VAL0 $ast) 0))) + ) + (func $number_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (global.get $INTEGER_T)))) + (func $string_Q (param $args i32) (result i32) + (LET $mv ($MEM_VAL1_ptr $args)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $mv) (global.get $STRING_T)) + (i32.ne (i32.load8_u ($to_String $mv)) + (CHR "\x7f")))) + ) + + (func $keyword (param $args i32) (result i32) + (LET $str ($to_String ($MEM_VAL1_ptr $args))) + (if (result i32) (i32.eq (i32.load8_u $str) (CHR "\x7f")) + (then ($INC_REF ($MEM_VAL1_ptr $args))) + (else + (drop ($sprintf_1 (global.get $printf_buf) "\x7f%s" $str)) + ($STRING (global.get $STRING_T) (global.get $printf_buf)))) + ) + + (func $keyword_Q (param $args i32) (result i32) + (LET $ast ($MEM_VAL1_ptr $args)) + ($TRUE_FALSE (AND (i32.eq ($TYPE $ast) (global.get $STRING_T)) + (i32.eq (i32.load8_u ($to_String $ast)) + (CHR "\x7f")))) + ) + (func $fn_Q (param $args i32) (result i32) + (LET $type ($TYPE ($MEM_VAL1_ptr $args))) + ($TRUE_FALSE (OR (i32.eq $type (global.get $FUNCTION_T)) + (i32.eq $type (global.get $MALFUNC_T))))) + (func $macro_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (global.get $MACRO_T)))) + + (func $symbol (param $args i32) (result i32) + ($STRING (global.get $SYMBOL_T) ($to_String ($MEM_VAL1_ptr $args)))) + + (func $symbol_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (global.get $SYMBOL_T)))) + + (func $core_pr_str (param $args i32) (result i32) + ($pr_str_seq $args 1 " ")) + (func $str (param $args i32) (result i32) + ($pr_str_seq $args 0 "")) + (func $prn (param $args i32) (result i32) + (LET $res ($pr_str_seq $args 1 " ")) + ($printf_1 "%s\n" ($to_String $res)) + ($RELEASE $res) + ($INC_REF (global.get $NIL)) + ) + (func $println (param $args i32) (result i32) + (LET $res ($pr_str_seq $args 0 " ")) + ($printf_1 "%s\n" ($to_String $res)) + ($RELEASE $res) + ($INC_REF (global.get $NIL)) + ) + + (func $core_readline (param $args i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $mv 0) + (if (i32.eqz ($readline ($to_String ($MEM_VAL1_ptr $args)) $line)) + (return ($INC_REF (global.get $NIL)))) + (local.set $mv ($STRING (global.get $STRING_T) $line)) + $mv + ) + + (func $read_string (param $args i32) (result i32) + ($read_str ($to_String ($MEM_VAL1_ptr $args)))) + + (func $slurp (param $args i32) (result i32) + (LET $mv ($STRING_INIT (global.get $STRING_T)) + $size ($read_file ($to_String ($MEM_VAL1_ptr $args)) + ($to_String $mv))) + (if (i32.eqz $size) + (then + ($THROW_STR_1 "failed to read file '%s'" ($to_String ($MEM_VAL1_ptr $args))) + (return ($INC_REF (global.get $NIL))))) + (local.set $mv ($STRING_FINALIZE $mv $size)) + $mv + ) + + (func $lt (param $args i32) (result i32) + ($TRUE_FALSE + (i32.lt_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $lte (param $args i32) (result i32) + ($TRUE_FALSE + (i32.le_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $gt (param $args i32) (result i32) + ($TRUE_FALSE + (i32.gt_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $gte (param $args i32) (result i32) + ($TRUE_FALSE + (i32.ge_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $add (param $args i32) (result i32) + ($INTEGER + (i32.add ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $subtract (param $args i32) (result i32) + ($INTEGER + (i32.sub ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $multiply (param $args i32) (result i32) + ($INTEGER + (i32.mul ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $divide (param $args i32) (result i32) + ($INTEGER + (i32.div_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + + (func $time_ms (param $args i32) (result i32) + ($INTEGER ($get_time_ms))) + + ;;; + + (func $list (param $args i32) (result i32) + ($INC_REF $args)) + + (func $list_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) + (global.get $LIST_T)))) + + (func $vector (param $args i32) (result i32) + ($FORCE_SEQ_TYPE (global.get $VECTOR_T) $args)) + + (func $vector_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) + (global.get $VECTOR_T)))) + + (func $hash_map (param $args i32) (result i32) + (LET $type (global.get $HASHMAP_T) + $res ($MAP_LOOP_START $type) + $val2 0 + $val3 0 + $c 0 + ;; push MAP_LOOP stack + $ret $res + $current $res + $empty $res) + + ;; READ_SEQ_LOOP + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $args))) + + (local.set $val2 ($INC_REF ($MEM_VAL1_ptr $args))) + (local.set $val3 ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) + + ;; skip two + (local.set $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) + + ;; update the return sequence structure + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (br $loop) + ) + ) + + ;; MAP_LOOP_DONE + $ret + ) + + + (func $hash_map_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($DEREF_META ($MEM_VAL1_ptr $args))) + (global.get $HASHMAP_T)))) + + (func $assoc (param $args i32) (result i32) + (LET $hm ($MEM_VAL1_ptr $args) + $key 0) + (local.set $args ($MEM_VAL0_ptr $args)) + + (drop ($INC_REF $hm)) + (block $done + (loop $loop + (br_if $done (OR (i32.eqz ($VAL0 $args)) + (i32.eqz ($VAL0 ($MEM_VAL0_ptr $args))))) + (local.set $hm ($ASSOC1 $hm ($MEM_VAL1_ptr $args) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))) + (local.set $args ($MEM_VAL0_ptr ($MEM_VAL0_ptr $args))) + + (br $loop) + ) + ) + $hm + ) + + (func $get (param $args i32) (result i32) + (LET $hm ($MEM_VAL1_ptr $args) + $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + (if (result i32) (i32.eq $hm (global.get $NIL)) + (then ($INC_REF (global.get $NIL))) + (else ($INC_REF (i32.wrap_i64 ($HASHMAP_GET $hm $key))))) + ) + + (func $contains_Q (param $args i32) (result i32) + (LET $hm ($MEM_VAL1_ptr $args) + $key ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + ($TRUE_FALSE + (if (result i32) (i32.eq $hm (global.get $NIL)) + (then 0) + (else (i32.wrap_i64 + (i64.shr_u ($HASHMAP_GET $hm $key) (i64.const 32)))))) + ) + + (func $keys_or_vals (param $hm i32 $keys i32) (result i32) + (LET $res ($MAP_LOOP_START (global.get $LIST_T)) + $val2 0 + ;; MAP_LOOP stack + $ret $res + $current $res + $empty $res) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $hm))) + + (if $keys + (then (local.set $val2 ($INC_REF ($MEM_VAL1_ptr $hm)))) + (else (local.set $val2 ($INC_REF ($MEM_VAL2_ptr $hm))))) + + ;; next element + (local.set $hm ($MEM_VAL0_ptr $hm)) + + ;; update the return sequence structure + ;; do not release val2 since we are pulling it from the + ;; arguments and not creating it here + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE (global.get $LIST_T) + $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (br $loop) + ) + ) + + ;; MAP_LOOP_DONE + $ret + ) + + (func $keys (param $args i32) (result i32) + ($keys_or_vals ($MEM_VAL1_ptr $args) 1)) + + (func $vals (param $args i32) (result i32) + ($keys_or_vals ($MEM_VAL1_ptr $args) 0)) + + (func $sequential_Q (param $args i32) (result i32) + ($TRUE_FALSE (OR (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (global.get $LIST_T)) + (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) + (global.get $VECTOR_T))))) + + (func $cons (param $args i32) (result i32) + ($LIST ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)) ($MEM_VAL1_ptr $args))) + + (func $concat (param $args i32) (result i32) + (local $last_sl i64) + (LET $res ($INC_REF (global.get $EMPTY_LIST)) + $current $res + $sl 0 + $last 0 + $arg 0) + (block $done + (loop $loop + (br_if $done (i32.le_u $args (global.get $EMPTY_HASHMAP))) + (local.set $arg ($MEM_VAL1_ptr $args)) + ;; skip empty elements + (if (i32.le_s $arg (global.get $EMPTY_HASHMAP)) + (then + (local.set $args ($MEM_VAL0_ptr $args)) + (br $loop))) + (local.set $last_sl ($SLICE $arg 0 -1)) + (local.set $sl (i32.wrap_i64 $last_sl)) + (local.set $last (i32.wrap_i64 (i64.shr_u $last_sl (i64.const 32)))) + (if (i32.eq $res (global.get $EMPTY_LIST)) + (then + ;; if this is the first element, set the return to the slice + (local.set $res $sl)) + (else + ;; otherwise attach current to sliced + (i32.store ($VAL0_ptr $current) ($IDX $sl)))) + ;; update current to end of sliced list + (local.set $current $last) + ;; release empty since no longer part of the slice + ($RELEASE (global.get $EMPTY_LIST)) + + (local.set $args ($MEM_VAL0_ptr $args)) + (br $loop) + ) + ) + $res + ) + + (func $vec (param $args i32) (result i32) + ($FORCE_SEQ_TYPE (global.get $VECTOR_T) ($MEM_VAL1_ptr $args))) + + (func $nth (param $args i32) (result i32) + (LET $a ($MEM_VAL1_ptr $args) + $idx ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + $i 0) + + (block $done + (loop $loop + (br_if $done (OR (i32.ge_s $i $idx) (i32.eqz ($VAL0 $a)))) + (local.set $i (i32.add $i 1)) + (local.set $a ($MEM_VAL0_ptr $a)) + (br $loop) + ) + ) + (if (i32.eq ($VAL0 $a) 0) + (then + ($THROW_STR_0 "nth: index out of range") + (return 0))) + + ($INC_REF ($MEM_VAL1_ptr $a)) + ) + + (func $first (param $args i32) (result i32) + (LET $res (global.get $NIL) + $a ($MEM_VAL1_ptr $args)) + (if (AND (i32.ne $a (global.get $NIL)) + (i32.ne ($VAL0 $a) 0)) + (local.set $res ($MEM_VAL1_ptr $a))) + ($INC_REF $res) + ) + + (func $rest (param $args i32) (result i32) + (LET $a ($MEM_VAL1_ptr $args)) + (if (i32.eq $a (global.get $NIL)) + (return ($INC_REF (global.get $EMPTY_LIST)))) + (if (i32.ne ($VAL0 $a) 0) + (local.set $a ($MEM_VAL0_ptr $a))) + ($FORCE_SEQ_TYPE (global.get $LIST_T) $a) + ) + + ;;; + + (func $empty_Q (param $args i32) (result i32) + ($TRUE_FALSE ($EMPTY_Q ($MEM_VAL1_ptr $args)))) + + (func $count (param $args i32) (result i32) + ($INTEGER ($COUNT ($MEM_VAL1_ptr $args)))) + + (func $apply (param $args i32) (result i32) + (local $last_sl i64) + (LET $f ($MEM_VAL1_ptr $args) + $f_args 0 + $rest_args ($MEM_VAL0_ptr $args) + $rest_count ($COUNT $rest_args) + $last 0 + $res 0) + + (if (i32.le_s $rest_count 1) + (then + ;; no intermediate args + (if (i32.ne ($TYPE ($MEM_VAL1_ptr $rest_args)) (global.get $LIST_T)) + (then + ;; not a list, so convert it first + (local.set $f_args ($FORCE_SEQ_TYPE (global.get $LIST_T) + ($MEM_VAL1_ptr $rest_args)))) + (else + ;; inc ref since we will release after APPLY + (local.set $f_args ($INC_REF ($MEM_VAL1_ptr $rest_args)))))) + (else + ;; 1 or more intermediate args + (local.set $last_sl ($SLICE $rest_args 0 (i32.sub $rest_count 1))) + (local.set $f_args (i32.wrap_i64 $last_sl)) + (local.set $last (i32.wrap_i64 (i64.shr_u $last_sl (i64.const 32)))) + ;; release the terminator of the new list (we skip over it) + ;; we already checked for an empty list above, so $last is + ;; a real non-empty list + ($RELEASE ($MEM_VAL0_ptr $last)) + ;; attach end of slice to final args element + (i32.store ($VAL0_ptr $last) ($IDX ($LAST $rest_args))) + )) + + (local.set $res ($APPLY $f $f_args)) + + ;; release new args + ($RELEASE $f_args) + $res + ) + + (func $map (param $args i32) (result i32) + (LET $f ($MEM_VAL1_ptr $args) + $rest_args ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)) + $f_args 0 + $res ($MAP_LOOP_START (global.get $LIST_T)) + ;; push MAP_LOOP stack + $ret $res + $current $res + $empty $res) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $rest_args))) + + ;; create argument list for apply + (local.set $f_args ($ALLOC (global.get $LIST_T) + (global.get $EMPTY_LIST) + ($MEM_VAL1_ptr $rest_args) + 0)) + + (local.set $res ($APPLY $f $f_args)) + ($RELEASE $f_args) + + ;; go to the next element + (local.set $rest_args ($MEM_VAL0_ptr $rest_args)) + + (if (global.get $error_type) + (then + ;; if error, release the unattached element + ($RELEASE $res) + (br $done))) + + ;; update the return sequence structure + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE (global.get $LIST_T) + $empty $current $res 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (br $loop) + ) + ) + + ;; MAP_LOOP_DONE + $ret + ) + + ;;; + + (func $with_meta (param $args i32) (result i32) + (LET $mv ($MEM_VAL1_ptr $args) + $meta ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + ;; remove existing metadata first + ($ALLOC (global.get $METADATA_T) ($DEREF_META $mv) $meta 0) + ) + + (func $meta (param $args i32) (result i32) + (if (result i32) (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (global.get $METADATA_T)) + (then ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL1_ptr $args)))) + (else ($INC_REF (global.get $NIL))))) + + (func $atom (param $args i32) (result i32) + ($ALLOC_SCALAR (global.get $ATOM_T) ($VAL1 $args))) + + (func $atom_Q (param $args i32) (result i32) + ($TRUE_FALSE (i32.eq ($TYPE ($MEM_VAL1_ptr $args)) (global.get $ATOM_T)))) + + (func $deref (param $args i32) (result i32) + ($INC_REF ($MEM_VAL0_ptr ($MEM_VAL1_ptr $args)))) + + (func $_reset_BANG (param $atom i32 $val i32) (result i32) + ;; release current value since we are about to overwrite it + ($RELEASE ($MEM_VAL0_ptr $atom)) + ;; inc ref by 2 for atom ownership and since we are returning it + (drop ($INC_REF ($INC_REF $val))) + ;; update the value + (i32.store ($VAL0_ptr $atom) ($IDX $val)) + $val + ) + + (func $reset_BANG (param $args i32) (result i32) + (LET $atom ($MEM_VAL1_ptr $args) + $val ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args))) + ($_reset_BANG $atom $val) + ) + + (func $swap_BANG (param $args i32) (result i32) + (LET $atom ($MEM_VAL1_ptr $args) + $f_args ($MEM_VAL0_ptr $args) + $rest_args ($MEM_VAL0_ptr $f_args) + ;; add atom value to front of the args list + $s_args ($LIST $rest_args ($MEM_VAL0_ptr $atom)) ;; cons + $f ($MEM_VAL1_ptr $f_args) + $res ($APPLY $f $s_args)) + ;; release args + ($RELEASE $s_args) + ;; use reset to update the value + (drop ($_reset_BANG $atom $res)) + ;; but decrease the ref cnt of return by 1 (not sure why) + ($RELEASE $res) + $res + ) + + ;;; + + (func $pr_memory_summary (param $args i32) (result i32) + ($PR_MEMORY_SUMMARY_SMALL) + ($INC_REF (global.get $NIL)) + ) + + (func $nop (param $args i32) (result i32) + ($INC_REF (global.get $NIL))) + + (table + funcref + (elem $nop ;; placeholder for eval which will use 0 + $equal_Q + $throw + $nil_Q + $true_Q + $false_Q + $number_Q + $string_Q + $symbol + $symbol_Q + $keyword + $keyword_Q + $fn_Q + $macro_Q + + ;; 14 + $core_pr_str + $str + $prn + $println + $core_readline + $read_string + $slurp + $lt + $lte + $gt + $gte + $add + $subtract + $multiply + $divide + $time_ms + + ;; 30 + $list + $list_Q + $vector + $vector_Q + $hash_map + $hash_map_Q + $assoc + $nop ;; $dissoc + $get + $contains_Q + $keys + $vals + + ;; 42 + $sequential_Q + $cons + $concat + $nth + $first + $rest + $empty_Q + $count + $apply + $map + $nop ;; $conj + $nop ;; $seq + + ;; 54 + $with_meta + $meta + $atom + $atom_Q + $deref + $reset_BANG + $swap_BANG + + $pr_memory_summary + $vec + ) + ) + + (func $add_core_ns (param $env i32) + ;;(drop ($ENV_SET_S $env "eval" ($FUNCTION 0))) + (drop ($ENV_SET_S $env "=" ($FUNCTION 1))) + (drop ($ENV_SET_S $env "throw" ($FUNCTION 2))) + (drop ($ENV_SET_S $env "nil?" ($FUNCTION 3))) + (drop ($ENV_SET_S $env "true?" ($FUNCTION 4))) + (drop ($ENV_SET_S $env "false?" ($FUNCTION 5))) + (drop ($ENV_SET_S $env "number?" ($FUNCTION 6))) + (drop ($ENV_SET_S $env "string?" ($FUNCTION 7))) + (drop ($ENV_SET_S $env "symbol" ($FUNCTION 8))) + (drop ($ENV_SET_S $env "symbol?" ($FUNCTION 9))) + (drop ($ENV_SET_S $env "keyword" ($FUNCTION 10))) + (drop ($ENV_SET_S $env "keyword?" ($FUNCTION 11))) + (drop ($ENV_SET_S $env "fn?" ($FUNCTION 12))) + (drop ($ENV_SET_S $env "macro?" ($FUNCTION 13))) + + (drop ($ENV_SET_S $env "pr-str" ($FUNCTION 14))) + (drop ($ENV_SET_S $env "str" ($FUNCTION 15))) + (drop ($ENV_SET_S $env "prn" ($FUNCTION 16))) + (drop ($ENV_SET_S $env "println" ($FUNCTION 17))) + (drop ($ENV_SET_S $env "readline" ($FUNCTION 18))) + (drop ($ENV_SET_S $env "read-string" ($FUNCTION 19))) + (drop ($ENV_SET_S $env "slurp" ($FUNCTION 20))) + (drop ($ENV_SET_S $env "<" ($FUNCTION 21))) + (drop ($ENV_SET_S $env "<=" ($FUNCTION 22))) + (drop ($ENV_SET_S $env ">" ($FUNCTION 23))) + (drop ($ENV_SET_S $env ">=" ($FUNCTION 24))) + (drop ($ENV_SET_S $env "+" ($FUNCTION 25))) + (drop ($ENV_SET_S $env "-" ($FUNCTION 26))) + (drop ($ENV_SET_S $env "*" ($FUNCTION 27))) + (drop ($ENV_SET_S $env "/" ($FUNCTION 28))) + (drop ($ENV_SET_S $env "time-ms" ($FUNCTION 29))) + + (drop ($ENV_SET_S $env "list" ($FUNCTION 30))) + (drop ($ENV_SET_S $env "list?" ($FUNCTION 31))) + (drop ($ENV_SET_S $env "vector" ($FUNCTION 32))) + (drop ($ENV_SET_S $env "vector?" ($FUNCTION 33))) + (drop ($ENV_SET_S $env "hash-map" ($FUNCTION 34))) + (drop ($ENV_SET_S $env "map?" ($FUNCTION 35))) + (drop ($ENV_SET_S $env "assoc" ($FUNCTION 36))) + (drop ($ENV_SET_S $env "dissoc" ($FUNCTION 37))) + (drop ($ENV_SET_S $env "get" ($FUNCTION 38))) + (drop ($ENV_SET_S $env "contains?" ($FUNCTION 39))) + (drop ($ENV_SET_S $env "keys" ($FUNCTION 40))) + (drop ($ENV_SET_S $env "vals" ($FUNCTION 41))) + + (drop ($ENV_SET_S $env "sequential?" ($FUNCTION 42))) + (drop ($ENV_SET_S $env "cons" ($FUNCTION 43))) + (drop ($ENV_SET_S $env "concat" ($FUNCTION 44))) + (drop ($ENV_SET_S $env "nth" ($FUNCTION 45))) + (drop ($ENV_SET_S $env "first" ($FUNCTION 46))) + (drop ($ENV_SET_S $env "rest" ($FUNCTION 47))) + (drop ($ENV_SET_S $env "empty?" ($FUNCTION 48))) + (drop ($ENV_SET_S $env "count" ($FUNCTION 49))) + (drop ($ENV_SET_S $env "apply" ($FUNCTION 50))) + (drop ($ENV_SET_S $env "map" ($FUNCTION 51))) + + (drop ($ENV_SET_S $env "conj" ($FUNCTION 52))) + (drop ($ENV_SET_S $env "seq" ($FUNCTION 53))) + + (drop ($ENV_SET_S $env "with-meta" ($FUNCTION 54))) + (drop ($ENV_SET_S $env "meta" ($FUNCTION 55))) + (drop ($ENV_SET_S $env "atom" ($FUNCTION 56))) + (drop ($ENV_SET_S $env "atom?" ($FUNCTION 57))) + (drop ($ENV_SET_S $env "deref" ($FUNCTION 58))) + (drop ($ENV_SET_S $env "reset!" ($FUNCTION 59))) + (drop ($ENV_SET_S $env "swap!" ($FUNCTION 60))) + + (drop ($ENV_SET_S $env "pr-memory-summary" ($FUNCTION 61))) + (drop ($ENV_SET_S $env "vec" ($FUNCTION 62))) + ) +) diff --git a/impls/wasm/debug.wam b/impls/wasm/debug.wam index 66ad533a4a..5bb520231d 100644 --- a/impls/wasm/debug.wam +++ b/impls/wasm/debug.wam @@ -1,285 +1,285 @@ -(module $debug - - (func $checkpoint_user_memory - (global.set $mem_user_start (global.get $mem_unused_start)) - (global.set $string_mem_user_start (global.get $string_mem_next)) - ) - - (func $CHECK_FREE_LIST (result i32) - (LET $first (i32.add - (global.get $mem) - (i32.mul (global.get $mem_free_list) 4)) - $count 0) - - (block $done - (loop $loop - (br_if $done - (i32.ge_s $first - (i32.add (global.get $mem) - (i32.mul (global.get $mem_unused_start) - 4)))) - (local.set $count (i32.add $count ($MalVal_size $first))) - (local.set $first (i32.add (global.get $mem) (i32.mul 4 ($VAL0 $first)))) - (br $loop) - ) - ) - $count - ) - - (func $PR_MEMORY_SUMMARY_SMALL - (LET $free (i32.sub (global.get $MEM_SIZE) - (i32.mul (global.get $mem_unused_start) 4)) - $free_list_count ($CHECK_FREE_LIST) - $mv (global.get $NIL) - $mem_ref_count 0) - - (block $done - (loop $loop - (br_if $done (i32.ge_s $mv (i32.add - (global.get $mem) - (i32.mul (global.get $mem_unused_start) - 4)))) - (if (i32.ne ($TYPE $mv) (global.get $FREE_T)) - (local.set $mem_ref_count (i32.add $mem_ref_count - (i32.shr_u - (i32.load $mv) - 5)))) - (local.set $mv (i32.add $mv (i32.mul 4 ($MalVal_size $mv)))) - (br $loop) - ) - ) - - ($printf_3 "Free: %d, Values: %d (refs: %d), Emptys: " - $free - (i32.sub - (i32.sub (global.get $mem_unused_start) 1) - $free_list_count) - $mem_ref_count) - (local.set $mv (global.get $NIL)) - (block $done - (loop $loop - (br_if $done (i32.gt_s $mv (global.get $TRUE))) - ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) - (local.set $mv (i32.add $mv 8)) - (br $loop) - ) - ) - (local.set $mv (global.get $EMPTY_LIST)) - (block $done - (loop $loop - (br_if $done (i32.gt_s $mv (global.get $EMPTY_HASHMAP))) - ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) - (local.set $mv (i32.add $mv 12)) - (br $loop) - ) - ) - ($print "\n") - ) - - (func $PR_VALUE (param $fmt i32 $mv i32) - (LET $temp ($pr_str $mv 1)) - ($printf_1 $fmt ($to_String $temp)) - ($RELEASE $temp) - ) - - (func $PR_MEMORY_VALUE (param $idx i32) (result i32) - ;;; mv = mem + idx - (LET $mv ($MalVal_ptr $idx) - $type ($TYPE $mv) - $size ($MalVal_size $mv) - $val0 ($MalVal_val $idx 0)) - - ($printf_2 "%4d: type %2d" $idx $type) - - (if (i32.eq $type 15) - (then ($printf_1 ", size %2d" $size)) - (else ($printf_1 ", refs %2d" ($REFS $mv)))) - - (if (OR (i32.eq $type (global.get $STRING_T)) - (i32.eq $type (global.get $SYMBOL_T))) - ;; for strings/symbolx pointers, print hex values - (then ($printf_2 " [%4d|%3ds" ($MalVal_refcnt_type $idx) $val0)) - (else ($printf_2 " [%4d|%4d" ($MalVal_refcnt_type $idx) $val0))) - - (if (i32.eq $size 2) - (then - ($print "|----|----]")) - (else - ($printf_1 "|%4d" ($MalVal_val $idx 1)) - (if (i32.eq $size 3) - (then ($print "|----]")) - (else ($printf_1 "|%4d]" ($MalVal_val $idx 2)))))) - - ;;; printf(" >> ") - ($print " >> ") - - (block $done (block $unknown - (block (block (block (block (block (block (block (block - (block (block (block (block (block (block (block (block - (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 - $unknown $type)) - ;; 0: nil - ($print "nil") - (br $done)) - ;; 1: boolean - (if (i32.eq $val0 0) - ;; true - ($print "false") - ;; false - ($print "true")) - (br $done)) - ;; 2: integer - ($printf_1 "%d" $val0) - (br $done)) - ;; 3: float/ERROR - ($print " *** GOT FLOAT *** ") - (br $done)) - ;; 4: string/kw - ($printf_1 "'%s'" ($to_String $mv)) - (br $done)) - ;; 5: symbol - ($print ($to_String $mv)) - (br $done)) - ;; 6: list - (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) - (then - ($print "()")) - (else - ;;; printf("(... %d ...), next: %d\n", mv->val[1], mv->val[0]) - ($printf_2 "(... %d ...), next: %d" - ($MalVal_val $idx 1) - ($MalVal_val $idx 0)))) - (br $done)) - ;; 7: vector - (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) - (then - ($print "[]")) - (else - ;;; printf("[... %d ...], next: %d\n", mv->val[1], mv->val[0])val - ($printf_2 "[... %d ...], next: %d" - ($MalVal_val $idx 1) - ($MalVal_val $idx 0)))) - (br $done)) - ;; 8: hashmap - (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) - (then - ($print "{}")) - (else - ;;; printf("{... '%s'(%d) : %d ...}\n", - ;; to_String(mem + mv->val[1]), mv->val[1], mv->val[2]) - ($printf_3 "{... '%s'(%d) : %d ...}" - ($to_String ($MalVal_ptr ($MalVal_val $idx 1))) - ($MalVal_val $idx 1) - ($MalVal_val $idx 2)))) - (br $done)) - ;; 9: function - ($print "function") - (br $done)) - ;; 10: mal function - ($print "mal function") - (br $done)) - ;; 11: macro fn - ($print "macro fn") - (br $done)) - ;; 12: atom - ($print "atom") - (br $done)) - ;; 13: environment - ($print "environment") - (br $done)) - ;; 14: metadata - ($print "metadata") - (br $done)) - ;; 15: FREE - ($printf_1 "FREE next: 0x%x" $val0) - (if (i32.eq $idx (global.get $mem_free_list)) - ($print " (free start)")) - (if (i32.eq $val0 (global.get $mem_unused_start)) - ($print " (free end)")) - (br $done)) - ;; 16: unknown - ($print "unknown") - ) - - ($print "\n") - - (i32.add $size $idx) - ) - - (func $PR_STRINGS (param $start i32) - (LET $ms 0 - $idx 0) - ($printf_2 "String - showing %d -> %d:\n" - $start (i32.sub (global.get $string_mem_next) - (global.get $string_mem))) - (if (i32.le_s (i32.sub (global.get $string_mem_next) - (global.get $string_mem)) - $start) - (then ($print " ---\n")) - (else - (local.set $ms (global.get $string_mem)) - (block $done - (loop $loop - (br_if $done (i32.ge_u $ms (global.get $string_mem_next))) - (local.set $idx (i32.sub $ms (global.get $string_mem))) - (if (i32.ge_s $idx $start) - ($printf_4 "%4d: refs %2d, size %2d >> '%s'\n" - $idx - (i32.load16_u $ms) - (i32.load16_u (i32.add $ms 2)) - (i32.add $ms 4))) - - (local.set $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) - (br $loop) - ) - ))) - ) - - (func $PR_MEMORY (param $start i32 $end i32) - (LET $string_start 0 - $idx 0) - (if (i32.lt_s $start 0) - (then - (local.set $start (global.get $mem_user_start)) - (local.set $string_start (i32.sub (global.get $string_mem_user_start) - (global.get $string_mem))))) - (if (i32.lt_s $end 0) - (local.set $end (global.get $mem_unused_start))) - ;;; printf("Values - (mem) showing %d -> %d", start, end) - ;;; printf(" (unused start: %d, free list: %d):\n", - ;;; mem_unused_start, mem_free_list) - ($printf_4 "Values - (mem) showing 0x%x -> 0x%x (unused start: 0x%x, free list: 0x%x):\n" - $start - $end - (global.get $mem_unused_start) - (global.get $mem_free_list)) - - (if (i32.le_s $end $start) - (then - ($print " ---\n") - (local.set $end (global.get $mem_unused_start))) - (else - (local.set $idx $start) - ;;; while (idx < end) - (block $loopvals_exit - (loop $loopvals - (br_if $loopvals_exit (i32.ge_s $idx $end)) - (local.set $idx ($PR_MEMORY_VALUE $idx)) - (br $loopvals) - ) - ))) - ($PR_STRINGS $string_start) - ($PR_MEMORY_SUMMARY_SMALL) - ) - - (func $PR_MEMORY_RAW (param $start i32 $end i32) - (block $loop_exit - (loop $loop - (br_if $loop_exit (i32.ge_u $start $end)) - ($printf_2 "0x%x 0x%x\n" $start (i32.load $start)) - (local.set $start (i32.add 4 $start)) - (br $loop) - ) - ) - ) -) +(module $debug + + (func $checkpoint_user_memory + (global.set $mem_user_start (global.get $mem_unused_start)) + (global.set $string_mem_user_start (global.get $string_mem_next)) + ) + + (func $CHECK_FREE_LIST (result i32) + (LET $first (i32.add + (global.get $mem) + (i32.mul (global.get $mem_free_list) 4)) + $count 0) + + (block $done + (loop $loop + (br_if $done + (i32.ge_s $first + (i32.add (global.get $mem) + (i32.mul (global.get $mem_unused_start) + 4)))) + (local.set $count (i32.add $count ($MalVal_size $first))) + (local.set $first (i32.add (global.get $mem) (i32.mul 4 ($VAL0 $first)))) + (br $loop) + ) + ) + $count + ) + + (func $PR_MEMORY_SUMMARY_SMALL + (LET $free (i32.sub (global.get $MEM_SIZE) + (i32.mul (global.get $mem_unused_start) 4)) + $free_list_count ($CHECK_FREE_LIST) + $mv (global.get $NIL) + $mem_ref_count 0) + + (block $done + (loop $loop + (br_if $done (i32.ge_s $mv (i32.add + (global.get $mem) + (i32.mul (global.get $mem_unused_start) + 4)))) + (if (i32.ne ($TYPE $mv) (global.get $FREE_T)) + (local.set $mem_ref_count (i32.add $mem_ref_count + (i32.shr_u + (i32.load $mv) + 5)))) + (local.set $mv (i32.add $mv (i32.mul 4 ($MalVal_size $mv)))) + (br $loop) + ) + ) + + ($printf_3 "Free: %d, Values: %d (refs: %d), Emptys: " + $free + (i32.sub + (i32.sub (global.get $mem_unused_start) 1) + $free_list_count) + $mem_ref_count) + (local.set $mv (global.get $NIL)) + (block $done + (loop $loop + (br_if $done (i32.gt_s $mv (global.get $TRUE))) + ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) + (local.set $mv (i32.add $mv 8)) + (br $loop) + ) + ) + (local.set $mv (global.get $EMPTY_LIST)) + (block $done + (loop $loop + (br_if $done (i32.gt_s $mv (global.get $EMPTY_HASHMAP))) + ($printf_1 "%d," (i32.div_s (i32.load $mv) 32)) + (local.set $mv (i32.add $mv 12)) + (br $loop) + ) + ) + ($print "\n") + ) + + (func $PR_VALUE (param $fmt i32 $mv i32) + (LET $temp ($pr_str $mv 1)) + ($printf_1 $fmt ($to_String $temp)) + ($RELEASE $temp) + ) + + (func $PR_MEMORY_VALUE (param $idx i32) (result i32) + ;;; mv = mem + idx + (LET $mv ($MalVal_ptr $idx) + $type ($TYPE $mv) + $size ($MalVal_size $mv) + $val0 ($MalVal_val $idx 0)) + + ($printf_2 "%4d: type %2d" $idx $type) + + (if (i32.eq $type 15) + (then ($printf_1 ", size %2d" $size)) + (else ($printf_1 ", refs %2d" ($REFS $mv)))) + + (if (OR (i32.eq $type (global.get $STRING_T)) + (i32.eq $type (global.get $SYMBOL_T))) + ;; for strings/symbolx pointers, print hex values + (then ($printf_2 " [%4d|%3ds" ($MalVal_refcnt_type $idx) $val0)) + (else ($printf_2 " [%4d|%4d" ($MalVal_refcnt_type $idx) $val0))) + + (if (i32.eq $size 2) + (then + ($print "|----|----]")) + (else + ($printf_1 "|%4d" ($MalVal_val $idx 1)) + (if (i32.eq $size 3) + (then ($print "|----]")) + (else ($printf_1 "|%4d]" ($MalVal_val $idx 2)))))) + + ;;; printf(" >> ") + ($print " >> ") + + (block $done (block $unknown + (block (block (block (block (block (block (block (block + (block (block (block (block (block (block (block (block + (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + $unknown $type)) + ;; 0: nil + ($print "nil") + (br $done)) + ;; 1: boolean + (if (i32.eq $val0 0) + ;; true + ($print "false") + ;; false + ($print "true")) + (br $done)) + ;; 2: integer + ($printf_1 "%d" $val0) + (br $done)) + ;; 3: float/ERROR + ($print " *** GOT FLOAT *** ") + (br $done)) + ;; 4: string/kw + ($printf_1 "'%s'" ($to_String $mv)) + (br $done)) + ;; 5: symbol + ($print ($to_String $mv)) + (br $done)) + ;; 6: list + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) + (then + ($print "()")) + (else + ;;; printf("(... %d ...), next: %d\n", mv->val[1], mv->val[0]) + ($printf_2 "(... %d ...), next: %d" + ($MalVal_val $idx 1) + ($MalVal_val $idx 0)))) + (br $done)) + ;; 7: vector + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) + (then + ($print "[]")) + (else + ;;; printf("[... %d ...], next: %d\n", mv->val[1], mv->val[0])val + ($printf_2 "[... %d ...], next: %d" + ($MalVal_val $idx 1) + ($MalVal_val $idx 0)))) + (br $done)) + ;; 8: hashmap + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) + (then + ($print "{}")) + (else + ;;; printf("{... '%s'(%d) : %d ...}\n", + ;; to_String(mem + mv->val[1]), mv->val[1], mv->val[2]) + ($printf_3 "{... '%s'(%d) : %d ...}" + ($to_String ($MalVal_ptr ($MalVal_val $idx 1))) + ($MalVal_val $idx 1) + ($MalVal_val $idx 2)))) + (br $done)) + ;; 9: function + ($print "function") + (br $done)) + ;; 10: mal function + ($print "mal function") + (br $done)) + ;; 11: macro fn + ($print "macro fn") + (br $done)) + ;; 12: atom + ($print "atom") + (br $done)) + ;; 13: environment + ($print "environment") + (br $done)) + ;; 14: metadata + ($print "metadata") + (br $done)) + ;; 15: FREE + ($printf_1 "FREE next: 0x%x" $val0) + (if (i32.eq $idx (global.get $mem_free_list)) + ($print " (free start)")) + (if (i32.eq $val0 (global.get $mem_unused_start)) + ($print " (free end)")) + (br $done)) + ;; 16: unknown + ($print "unknown") + ) + + ($print "\n") + + (i32.add $size $idx) + ) + + (func $PR_STRINGS (param $start i32) + (LET $ms 0 + $idx 0) + ($printf_2 "String - showing %d -> %d:\n" + $start (i32.sub (global.get $string_mem_next) + (global.get $string_mem))) + (if (i32.le_s (i32.sub (global.get $string_mem_next) + (global.get $string_mem)) + $start) + (then ($print " ---\n")) + (else + (local.set $ms (global.get $string_mem)) + (block $done + (loop $loop + (br_if $done (i32.ge_u $ms (global.get $string_mem_next))) + (local.set $idx (i32.sub $ms (global.get $string_mem))) + (if (i32.ge_s $idx $start) + ($printf_4 "%4d: refs %2d, size %2d >> '%s'\n" + $idx + (i32.load16_u $ms) + (i32.load16_u (i32.add $ms 2)) + (i32.add $ms 4))) + + (local.set $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) + (br $loop) + ) + ))) + ) + + (func $PR_MEMORY (param $start i32 $end i32) + (LET $string_start 0 + $idx 0) + (if (i32.lt_s $start 0) + (then + (local.set $start (global.get $mem_user_start)) + (local.set $string_start (i32.sub (global.get $string_mem_user_start) + (global.get $string_mem))))) + (if (i32.lt_s $end 0) + (local.set $end (global.get $mem_unused_start))) + ;;; printf("Values - (mem) showing %d -> %d", start, end) + ;;; printf(" (unused start: %d, free list: %d):\n", + ;;; mem_unused_start, mem_free_list) + ($printf_4 "Values - (mem) showing 0x%x -> 0x%x (unused start: 0x%x, free list: 0x%x):\n" + $start + $end + (global.get $mem_unused_start) + (global.get $mem_free_list)) + + (if (i32.le_s $end $start) + (then + ($print " ---\n") + (local.set $end (global.get $mem_unused_start))) + (else + (local.set $idx $start) + ;;; while (idx < end) + (block $loopvals_exit + (loop $loopvals + (br_if $loopvals_exit (i32.ge_s $idx $end)) + (local.set $idx ($PR_MEMORY_VALUE $idx)) + (br $loopvals) + ) + ))) + ($PR_STRINGS $string_start) + ($PR_MEMORY_SUMMARY_SMALL) + ) + + (func $PR_MEMORY_RAW (param $start i32 $end i32) + (block $loop_exit + (loop $loop + (br_if $loop_exit (i32.ge_u $start $end)) + ($printf_2 "0x%x 0x%x\n" $start (i32.load $start)) + (local.set $start (i32.add 4 $start)) + (br $loop) + ) + ) + ) +) diff --git a/impls/wasm/env.wam b/impls/wasm/env.wam index cd10c76918..bcea8b8aa0 100644 --- a/impls/wasm/env.wam +++ b/impls/wasm/env.wam @@ -1,104 +1,104 @@ -(module $env - - (func $ENV_NEW (param $outer i32) (result i32) - (LET $data ($HASHMAP) ;; allocate the data hashmap - $env ($ALLOC (global.get $ENVIRONMENT_T) $data $outer 0)) - ;; environment takes ownership - ($RELEASE $data) - $env - ) - - (func $ENV_NEW_BINDS (param $outer i32 $binds i32 $exprs i32) (result i32) - (LET $env ($ENV_NEW $outer) - $key 0) - - ;; process bindings - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $binds))) - - ;; get/deref the key from binds - (local.set $key ($MEM_VAL1_ptr $binds)) - (if (i32.eqz ($strcmp "&" ($to_String $key))) - (then - ;; ENV_NEW_BIND_VARGS - ;; get/deref the key from the next element of binds - (local.set $binds ($MEM_VAL0_ptr $binds)) - (local.set $key ($MEM_VAL1_ptr $binds)) - ;; the value is the remaining list in exprs - (local.set $exprs ($FORCE_SEQ_TYPE (global.get $LIST_T) $exprs)) - ;; set the binding in the environment data - (drop ($ENV_SET $env $key $exprs)) - ;; list is owned by the environment - ($RELEASE $exprs) - (br $done)) - (else - ;; ENV_NEW_BIND_1x1 - ;; set the binding in the environment data - (drop ($ENV_SET $env $key ($MEM_VAL1_ptr $exprs))) - ;; go to next element of binds and exprs - (local.set $binds ($MEM_VAL0_ptr $binds)) - (local.set $exprs ($MEM_VAL0_ptr $exprs)))) - - (br $loop) - ) - ) - $env - ) - - (func $ENV_SET (param $env i32 $key i32 $value i32) (result i32) - (LET $data ($MEM_VAL0_ptr $env)) - (i32.store ($VAL0_ptr $env) ($IDX ($ASSOC1 $data $key $value))) - $value - ) - - (func $ENV_SET_S (param $env i32 $key i32 $value i32) (result i32) - (LET $data ($MEM_VAL0_ptr $env)) - (i32.store ($VAL0_ptr $env) ($IDX ($ASSOC1_S $data $key $value))) - $value - ) - - (func $ENV_FIND (param $env i32 $key i32) (result i64) - (local $found_res i64) - (LET $res 0 - $data 0) - - (block $done - (loop $loop - (local.set $data ($MEM_VAL0_ptr $env)) - (local.set $found_res ($HASHMAP_GET $data $key)) - ;;; if (found) - (if (i32.wrap_i64 (i64.shr_u $found_res (i64.const 32))) - (then - (local.set $res (i32.wrap_i64 $found_res)) - (br $done))) - (local.set $env ($MEM_VAL1_ptr $env)) - (if (i32.eq $env (global.get $NIL)) - (then - (local.set $env 0) - (br $done))) - (br $loop) - ) - ) - - ;; combine res/env as hi 32/low 32 of i64 - (i64.or - (i64.shl (i64.extend_i32_u $res) (i64.const 32)) - (i64.extend_i32_u $env)) - ) - - (func $ENV_GET (param $env i32 $key i32) (result i32) - (local $res_env i64) - (LET $res 0) - - (local.set $res_env ($ENV_FIND $env $key)) - (local.set $env (i32.wrap_i64 $res_env)) - (local.set $res (i32.wrap_i64 (i64.shr_u $res_env (i64.const 32)))) - - (if (i32.eqz $env) - (then - ($THROW_STR_1 "'%s' not found" ($to_String $key)) - (return $res))) - (return ($INC_REF $res)) - ) -) +(module $env + + (func $ENV_NEW (param $outer i32) (result i32) + (LET $data ($HASHMAP) ;; allocate the data hashmap + $env ($ALLOC (global.get $ENVIRONMENT_T) $data $outer 0)) + ;; environment takes ownership + ($RELEASE $data) + $env + ) + + (func $ENV_NEW_BINDS (param $outer i32 $binds i32 $exprs i32) (result i32) + (LET $env ($ENV_NEW $outer) + $key 0) + + ;; process bindings + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $binds))) + + ;; get/deref the key from binds + (local.set $key ($MEM_VAL1_ptr $binds)) + (if (i32.eqz ($strcmp "&" ($to_String $key))) + (then + ;; ENV_NEW_BIND_VARGS + ;; get/deref the key from the next element of binds + (local.set $binds ($MEM_VAL0_ptr $binds)) + (local.set $key ($MEM_VAL1_ptr $binds)) + ;; the value is the remaining list in exprs + (local.set $exprs ($FORCE_SEQ_TYPE (global.get $LIST_T) $exprs)) + ;; set the binding in the environment data + (drop ($ENV_SET $env $key $exprs)) + ;; list is owned by the environment + ($RELEASE $exprs) + (br $done)) + (else + ;; ENV_NEW_BIND_1x1 + ;; set the binding in the environment data + (drop ($ENV_SET $env $key ($MEM_VAL1_ptr $exprs))) + ;; go to next element of binds and exprs + (local.set $binds ($MEM_VAL0_ptr $binds)) + (local.set $exprs ($MEM_VAL0_ptr $exprs)))) + + (br $loop) + ) + ) + $env + ) + + (func $ENV_SET (param $env i32 $key i32 $value i32) (result i32) + (LET $data ($MEM_VAL0_ptr $env)) + (i32.store ($VAL0_ptr $env) ($IDX ($ASSOC1 $data $key $value))) + $value + ) + + (func $ENV_SET_S (param $env i32 $key i32 $value i32) (result i32) + (LET $data ($MEM_VAL0_ptr $env)) + (i32.store ($VAL0_ptr $env) ($IDX ($ASSOC1_S $data $key $value))) + $value + ) + + (func $ENV_FIND (param $env i32 $key i32) (result i64) + (local $found_res i64) + (LET $res 0 + $data 0) + + (block $done + (loop $loop + (local.set $data ($MEM_VAL0_ptr $env)) + (local.set $found_res ($HASHMAP_GET $data $key)) + ;;; if (found) + (if (i32.wrap_i64 (i64.shr_u $found_res (i64.const 32))) + (then + (local.set $res (i32.wrap_i64 $found_res)) + (br $done))) + (local.set $env ($MEM_VAL1_ptr $env)) + (if (i32.eq $env (global.get $NIL)) + (then + (local.set $env 0) + (br $done))) + (br $loop) + ) + ) + + ;; combine res/env as hi 32/low 32 of i64 + (i64.or + (i64.shl (i64.extend_i32_u $res) (i64.const 32)) + (i64.extend_i32_u $env)) + ) + + (func $ENV_GET (param $env i32 $key i32) (result i32) + (local $res_env i64) + (LET $res 0) + + (local.set $res_env ($ENV_FIND $env $key)) + (local.set $env (i32.wrap_i64 $res_env)) + (local.set $res (i32.wrap_i64 (i64.shr_u $res_env (i64.const 32)))) + + (if (i32.eqz $env) + (then + ($THROW_STR_1 "'%s' not found" ($to_String $key)) + (return $res))) + (return ($INC_REF $res)) + ) +) diff --git a/impls/wasm/mem.wam b/impls/wasm/mem.wam index 0eda0175ad..225d473fe8 100644 --- a/impls/wasm/mem.wam +++ b/impls/wasm/mem.wam @@ -1,465 +1,465 @@ -(module $mem - (global $MEM_SIZE i32 1048576) - (global $STRING_MEM_SIZE i32 1048576) - - (global $heap_start (mut i32) 0) - (global $heap_end (mut i32) 0) - - (global $mem (mut i32) 0) - (global $mem_unused_start (mut i32) 0) - (global $mem_free_list (mut i32) 0) - (global $mem_user_start (mut i32) 0) - - (global $string_mem (mut i32) 0) - (global $string_mem_next (mut i32) 0) - (global $string_mem_user_start (mut i32) 0) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; General type storage/pointer functions - - (func $VAL0_ptr (param $mv i32) (result i32) - (i32.add $mv 4)) - (func $VAL1_ptr (param $mv i32) (result i32) - (i32.add $mv 8)) - - (func $VAL0 (param $mv i32) (result i32) - (i32.load (i32.add $mv 4))) - (func $VAL1 (param $mv i32) (result i32) - (i32.load (i32.add $mv 8))) - - - (func $MEM_VAL0_ptr (param $mv i32) (result i32) - (i32.add (global.get $mem) - (i32.mul (i32.load (i32.add $mv 4)) 4))) - (func $MEM_VAL1_ptr (param $mv i32) (result i32) - (i32.add (global.get $mem) - (i32.mul (i32.load (i32.add $mv 8)) 4))) - (func $MEM_VAL2_ptr (param $mv i32) (result i32) - (i32.add (global.get $mem) - (i32.mul (i32.load (i32.add $mv 12)) 4))) - - ;; Returns the memory index mem of mv - ;; Will usually be used with a load or store by the caller - (func $IDX (param $mv i32) (result i32) - ;; MalVal memory 64 bit (2 * i32) aligned - (i32.div_u (i32.sub $mv (global.get $mem)) 4)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Returns the address of 'mem[mv_idx]' - (func $MalVal_ptr (param $mv_idx i32) (result i32) - ;; MalVal memory 64 bit (2 * i32) aligned - ;;; mem[mv_idx].refcnt_type - (i32.add (global.get $mem) (i32.mul $mv_idx 4))) - - ;; Returns the address of 'mem[mv_idx].refcnt_type' - (func $MalVal_refcnt_type (param $mv_idx i32) (result i32) - (i32.load ($MalVal_ptr $mv_idx))) - - (func $TYPE (param $mv i32) (result i32) - ;;; type = mv->refcnt_type & 31 - (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 - - (func $SET_TYPE (param $mv i32 $type i32) - ;;; type = mv->refcnt_type & 31 - ;;; mv->refcnt_type += - (mv->refcnt_type & 31) + type - (i32.store $mv (i32.or - (i32.and $type 0x1f) ;; 0x1f == 31 - (i32.and (i32.load $mv) 0xffffffe1))) - ) - - - (func $REFS (param $mv i32) (result i32) - ;;; type = mv->refcnt_type & 31 - (i32.shr_u (i32.load $mv) 5)) ;; / 32 - - ;; Returns the address of 'mem[mv_idx].val[val]' - ;; Will usually be used with a load or store by the caller - (func $MalVal_val_ptr (param $mv_idx i32 $val i32) (result i32) - (i32.add (i32.add ($MalVal_ptr $mv_idx) 4) - (i32.mul $val 4))) - - ;; Returns the value of 'mem[mv_idx].val[val]' - (func $MalVal_val (param $mv_idx i32 $val i32) (result i32) - (i32.load ($MalVal_val_ptr $mv_idx $val))) - - (func $MalType_size (param $type i32) (result i32) - ;;; if (type <= 5 || type == 9 || type == 12) - (if (result i32) (OR (i32.le_u $type 5) - (i32.eq $type 9) - (i32.eq $type 12)) - (then 2) - (else - ;;; else if (type == 8 || type == 10 || type == 11) - (if (result i32) (OR (i32.eq $type 8) - (i32.eq $type 10) - (i32.eq $type 11)) - (then 4) - (else 3))))) - - (func $MalVal_size (param $mv i32) (result i32) - (LET $type ($TYPE $mv)) - ;; if (type == FREE_T) - (if (result i32) (i32.eq $type (global.get $FREE_T)) - (then - ;;; return (mv->refcnt_type & 0xffe0)>>5 - (i32.shr_u (i32.and (i32.load $mv) 0xffe0) 5)) ;;; / 32 - (else - ;;; return MalType_size(type) - ($MalType_size $type)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; init_memory - - (func $init_memory - (LET $heap_size 0) - -;; ($print ">>> init_memory\n") - - ($init_printf_mem) - - ;; error_str string buffer - (global.set $error_str (STATIC_ARRAY 100)) - ;; reader token string buffer - (global.set $token_buf (STATIC_ARRAY 256)) - ;; printer string buffer - (global.set $printer_buf (STATIC_ARRAY 4096)) - - (local.set $heap_size (i32.add (global.get $MEM_SIZE) - (global.get $STRING_MEM_SIZE))) - (global.set $heap_start (i32.add (global.get $memoryBase) - (global.get $S_STRING_END))) - (global.set $heap_end (i32.add (global.get $heap_start) - $heap_size)) - - (global.set $mem (global.get $heap_start)) - (global.set $mem_unused_start 0) - (global.set $mem_free_list 0) - - (global.set $string_mem (i32.add (global.get $heap_start) - (global.get $MEM_SIZE))) - (global.set $string_mem_next (global.get $string_mem)) - - (global.set $mem_user_start (global.get $mem_unused_start)) - (global.set $string_mem_user_start (global.get $string_mem_next)) - - ;; Empty values - (global.set $NIL - ($ALLOC_SCALAR (global.get $NIL_T) 0)) - (global.set $FALSE - ($ALLOC_SCALAR (global.get $BOOLEAN_T) 0)) - (global.set $TRUE - ($ALLOC_SCALAR (global.get $BOOLEAN_T) 1)) - (global.set $EMPTY_LIST - ($ALLOC (global.get $LIST_T) - (global.get $NIL) (global.get $NIL) (global.get $NIL))) - (global.set $EMPTY_VECTOR - ($ALLOC (global.get $VECTOR_T) - (global.get $NIL) (global.get $NIL) (global.get $NIL))) - (global.set $EMPTY_HASHMAP - ($ALLOC (global.get $HASHMAP_T) - (global.get $NIL) (global.get $NIL) (global.get $NIL))) - -;; ($print "<<< init_memory\n") - - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; memory management - - (func $ALLOC_INTERNAL (param $type i32 - $val1 i32 $val2 i32 $val3 i32) (result i32) - (LET $prev (global.get $mem_free_list) - $res (global.get $mem_free_list) - $size ($MalType_size $type)) - - (block $loop_done - (loop $loop - ;; res == mem_unused_start - (if (i32.eq $res (global.get $mem_unused_start)) - (then - ;; ALLOC_UNUSED - ;;; if (res + size > MEM_SIZE) - (if (i32.gt_u (i32.add $res $size) (global.get $MEM_SIZE)) - ;; Out of memory, exit - ($fatal 7 "Out of mal memory!\n")) - ;;; if (mem_unused_start += size) - (global.set $mem_unused_start - (i32.add (global.get $mem_unused_start) $size)) - ;;; if (prev == res) - (if (i32.eq $prev $res) - (then - (global.set $mem_free_list (global.get $mem_unused_start))) - (else - ;;; mem[prev].val[0] = mem_unused_start - (i32.store - ($MalVal_val_ptr $prev 0) - (global.get $mem_unused_start)))) - (br $loop_done))) - ;; if (MalVal_size(mem+res) == size) - (if (i32.eq ($MalVal_size ($MalVal_ptr $res)) - $size) - (then - ;; ALLOC_MIDDLE - ;;; if (res == mem_free_list) - (if (i32.eq $res (global.get $mem_free_list)) - ;; set free pointer (mem_free_list) to next free - ;;; mem_free_list = mem[res].val[0]; - (global.set $mem_free_list ($MalVal_val $res 0))) - ;; if (res != mem_free_list) - (if (i32.ne $res (global.get $mem_free_list)) - ;; set previous free to next free - ;;; mem[prev].val[0] = mem[res].val[0] - (i32.store ($MalVal_val_ptr $prev 0) ($MalVal_val $res 0))) - (br $loop_done))) - ;;; prev = res - (local.set $prev $res) - ;;; res = mem[res].val[0] - (local.set $res ($MalVal_val $res 0)) - (br $loop) - ) - ) - ;; ALLOC_DONE - ;;; mem[res].refcnt_type = type + 32 - (i32.store ($MalVal_ptr $res) (i32.add $type 32)) - ;; set val to default val1 - ;;; mem[res].val[0] = val1 - (i32.store ($MalVal_val_ptr $res 0) $val1) - ;;; if (type > 5 && type != 9) - (if (AND (i32.gt_u $type 5) - (i32.ne $type 9)) - (then - ;; inc refcnt of referenced value - ;;; mem[val1].refcnt_type += 32 - (i32.store ($MalVal_ptr $val1) - (i32.add ($MalVal_refcnt_type $val1) 32)))) - ;;; if (size > 2) - (if (i32.gt_u $size 2) - (then - ;; inc refcnt of referenced value - ;;; mem[val2].refcnt_type += 32 - (i32.store ($MalVal_ptr $val2) - (i32.add ($MalVal_refcnt_type $val2) 32)) - ;;; mem[res].val[1] = val2 - (i32.store ($MalVal_val_ptr $res 1) $val2))) - ;;; if (size > 3) - (if (i32.gt_u $size 3) - (then - ;; inc refcnt of referenced value - ;;; mem[val3].refcnt_type += 32 - (i32.store ($MalVal_ptr $val3) - (i32.add ($MalVal_refcnt_type $val3) 32)) - ;;; mem[res].val[2] = val3 - (i32.store ($MalVal_val_ptr $res 2) $val3))) - - ;;; return mem + res - ($MalVal_ptr $res) - ) - - (func $ALLOC_SCALAR (param $type i32 $val1 i32) (result i32) - ($ALLOC_INTERNAL $type $val1 0 0) - ) - - (func $ALLOC (param $type i32 $val1 i32 $val2 i32 $val3 i32) (result i32) - ($ALLOC_INTERNAL $type ($IDX $val1) ($IDX $val2) ($IDX $val3)) - ) - - (func $RELEASE (param $mv i32) - (LET $idx 0 $type 0 $size 0) - - ;; Ignore NULLs - ;;; if (mv == NULL) { return; } - (if (i32.eqz $mv) (return)) - ;;; idx = mv - mem - (local.set $idx ($IDX $mv)) - ;;; type = mv->refcnt_type & 31 - (local.set $type (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 - ;;; size = MalType_size(type) - (local.set $size ($MalType_size $type)) - - ;; DEBUG - ;;; printf(">>> RELEASE idx: %d, type: %d, size: %d\n", idx, type, size) - - (if (i32.eq 0 $mv) - ($fatal 7 "RELEASE of NULL!\n")) - - (if (i32.eq (global.get $FREE_T) $type) - (then - ($printf_2 "RELEASE of already free mv: 0x%x, idx: 0x%x\n" $mv $idx) - ($fatal 1 ""))) - (if (i32.lt_u ($MalVal_refcnt_type $idx) 15) - (then - ($printf_2 "RELEASE of unowned mv: 0x%x, idx: 0x%x\n" $mv $idx) - ($fatal 1 ""))) - - ;; decrease reference count by one - (i32.store ($MalVal_ptr $idx) - (i32.sub ($MalVal_refcnt_type $idx) 32)) - - ;; nil, false, true, empty sequences - (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) - (then - (if (i32.lt_u ($MalVal_refcnt_type $idx) 32) - (then - ($printf_2 "RELEASE of unowned mv: 0x%x, idx: 0x%x\n" $mv $idx) - ($fatal 1 ""))) - (return))) - - ;; our reference count is not 0, so don't release - (if (i32.ge_u ($MalVal_refcnt_type $idx) 32) - (return)) - - (block $done - (block (block (block (block (block (block (block (block (block - (br_table 0 0 0 0 1 1 2 2 3 0 4 4 5 6 7 8 8 $type)) - ;; nil, boolean, integer, float - (br $done)) - ;; string, kw, symbol - ;; release string, then FREE reference - ($RELEASE_STRING (i32.add (global.get $string_mem) ($VAL0 $mv))) - (br $done)) - ;; list, vector - (if (i32.ne ($MalVal_val $idx 0) 0) - (then - ;; release next element and value - ($RELEASE ($MEM_VAL0_ptr $mv)) - ($RELEASE ($MEM_VAL1_ptr $mv)))) - (br $done)) - ;; hashmap - (if (i32.ne ($MalVal_val $idx 0) 0) - (then - ;; release next element, value, and key - ($RELEASE ($MEM_VAL0_ptr $mv)) - ($RELEASE ($MEM_VAL2_ptr $mv)) - ($RELEASE ($MEM_VAL1_ptr $mv)))) - (br $done)) - ;; mal / macro function - ;; release ast, params, and environment - ($RELEASE ($MEM_VAL2_ptr $mv)) - ($RELEASE ($MEM_VAL1_ptr $mv)) - ($RELEASE ($MEM_VAL0_ptr $mv)) - (br $done)) - ;; atom - ;; release contained/referred value - ($RELEASE ($MEM_VAL0_ptr $mv)) - (br $done)) - ;; env - ;; if outer is set then release outer - (if (i32.ne ($MalVal_val $idx 1) 0) - ($RELEASE ($MEM_VAL1_ptr $mv))) - ;; release the env data (hashmap) - ($RELEASE ($MEM_VAL0_ptr $mv)) - (br $done)) - ;; metadata - ;; release object and metdata object - ($RELEASE ($MEM_VAL0_ptr $mv)) - ($RELEASE ($MEM_VAL1_ptr $mv)) - (br $done)) - ;; default/unknown - ) - - ;; FREE, free the current element - - ;; set type(FREE/15) and size - ;;; mv->refcnt_type = size*32 + FREE_T - (i32.store $mv (i32.add (i32.mul $size 32) (global.get $FREE_T))) - (i32.store ($MalVal_val_ptr $idx 0) (global.get $mem_free_list)) - (global.set $mem_free_list $idx) - (if (i32.ge_u $size 3) (i32.store ($MalVal_val_ptr $idx 1) 0)) - (if (i32.eq $size 4) (i32.store ($MalVal_val_ptr $idx 2) 0)) - ) - - ;; find string in string memory or 0 if not found - (func $FIND_STRING (param $str i32) (result i32) - (LET $ms (global.get $string_mem)) - (block $done - (loop $loop - (br_if $done (i32.ge_s $ms (global.get $string_mem_next))) - (if (i32.eqz ($strcmp $str (i32.add $ms 4))) - (return $ms)) - - (local.set $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) - (br $loop) - ) - ) - 0 - ) - - ;; str is a NULL terminated string - ;; size is number of characters in the string not including the - ;; trailing NULL - (func $ALLOC_STRING (param $str i32 $size i32 $intern i32) (result i32) - (LET $ms 0) - - ;; search for matching string in string_mem - (if $intern - (then - (local.set $ms ($FIND_STRING $str)) - (if $ms - (then - ;;; ms->refcnt += 1 - (i32.store16 $ms (i32.add (i32.load16_u $ms) 1)) - (return $ms))))) - - ;; no existing matching string so create a new one - (local.set $ms (global.get $string_mem_next)) - (i32.store16 $ms 1) - ;;; ms->size = sizeof(MalString)+size+1 - (i32.store16 offset=2 $ms (i32.add (i32.add 4 $size) 1)) - ($memmove (i32.add $ms 4) $str (i32.add $size 1)) - ;;; string_mem_next = (void *)ms + ms->size - (global.set $string_mem_next - ;;(i32.add $ms (i32.load16_u (i32.add $ms 2)))) - (i32.add $ms (i32.load16_u offset=2 $ms))) - -;;($printf_2 "ALLOC_STRING 6 ms 0x%x, refs: %d\n" $ms (i32.load16_u $ms)) - $ms - ) - - (func $RELEASE_STRING (param $ms i32) - (LET $size 0 $next 0 $ms_idx 0 $idx 0 $type 0 $mv 0) - - (if (i32.le_s (i32.load16_u $ms) 0) - (then - ($printf_2 "Release of already free string: %d (0x%x)\n" - (i32.sub $ms (global.get $string_mem)) $ms) - ($fatal 1 ""))) - - ;;; size = ms->size - (local.set $size (i32.load16_u (i32.add $ms 2))) - ;;; *next = (void *)ms + size - (local.set $next (i32.add $ms $size)) - - ;;; ms->refcnt -= 1 - (i32.store16 $ms (i32.sub (i32.load16_u $ms) 1)) - - (if (i32.eqz (i32.load16_u $ms)) - (then - (if (i32.gt_s (global.get $string_mem_next) $next) - (then - ;; If no more references to this string then free it up by - ;; shifting up every string afterwards to fill the gap - ;; (splice). - ($memmove $ms $next (i32.sub (global.get $string_mem_next) - $next)) - - ;; Scan the mem values for string types after the freed - ;; string and shift their indexes by size - (local.set $ms_idx (i32.sub $ms (global.get $string_mem))) - (local.set $idx ($IDX (global.get $EMPTY_HASHMAP))) - (loop $loop - (local.set $mv ($MalVal_ptr $idx)) - (local.set $type ($TYPE $mv)) - (if (AND (i32.gt_s ($VAL0 $mv) $ms_idx) - (OR (i32.eq $type (global.get $STRING_T)) - (i32.eq $type (global.get $SYMBOL_T)))) - (i32.store ($VAL0_ptr $mv) (i32.sub ($VAL0 $mv) $size))) - (local.set $idx (i32.add $idx ($MalVal_size $mv))) - - (br_if $loop (i32.lt_s $idx (global.get $mem_unused_start))) - ))) - - (global.set $string_mem_next - (i32.sub (global.get $string_mem_next) $size)))) - ) -) +(module $mem + (global $MEM_SIZE i32 1048576) + (global $STRING_MEM_SIZE i32 1048576) + + (global $heap_start (mut i32) 0) + (global $heap_end (mut i32) 0) + + (global $mem (mut i32) 0) + (global $mem_unused_start (mut i32) 0) + (global $mem_free_list (mut i32) 0) + (global $mem_user_start (mut i32) 0) + + (global $string_mem (mut i32) 0) + (global $string_mem_next (mut i32) 0) + (global $string_mem_user_start (mut i32) 0) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; General type storage/pointer functions + + (func $VAL0_ptr (param $mv i32) (result i32) + (i32.add $mv 4)) + (func $VAL1_ptr (param $mv i32) (result i32) + (i32.add $mv 8)) + + (func $VAL0 (param $mv i32) (result i32) + (i32.load (i32.add $mv 4))) + (func $VAL1 (param $mv i32) (result i32) + (i32.load (i32.add $mv 8))) + + + (func $MEM_VAL0_ptr (param $mv i32) (result i32) + (i32.add (global.get $mem) + (i32.mul (i32.load (i32.add $mv 4)) 4))) + (func $MEM_VAL1_ptr (param $mv i32) (result i32) + (i32.add (global.get $mem) + (i32.mul (i32.load (i32.add $mv 8)) 4))) + (func $MEM_VAL2_ptr (param $mv i32) (result i32) + (i32.add (global.get $mem) + (i32.mul (i32.load (i32.add $mv 12)) 4))) + + ;; Returns the memory index mem of mv + ;; Will usually be used with a load or store by the caller + (func $IDX (param $mv i32) (result i32) + ;; MalVal memory 64 bit (2 * i32) aligned + (i32.div_u (i32.sub $mv (global.get $mem)) 4)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Returns the address of 'mem[mv_idx]' + (func $MalVal_ptr (param $mv_idx i32) (result i32) + ;; MalVal memory 64 bit (2 * i32) aligned + ;;; mem[mv_idx].refcnt_type + (i32.add (global.get $mem) (i32.mul $mv_idx 4))) + + ;; Returns the address of 'mem[mv_idx].refcnt_type' + (func $MalVal_refcnt_type (param $mv_idx i32) (result i32) + (i32.load ($MalVal_ptr $mv_idx))) + + (func $TYPE (param $mv i32) (result i32) + ;;; type = mv->refcnt_type & 31 + (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 + + (func $SET_TYPE (param $mv i32 $type i32) + ;;; type = mv->refcnt_type & 31 + ;;; mv->refcnt_type += - (mv->refcnt_type & 31) + type + (i32.store $mv (i32.or + (i32.and $type 0x1f) ;; 0x1f == 31 + (i32.and (i32.load $mv) 0xffffffe1))) + ) + + + (func $REFS (param $mv i32) (result i32) + ;;; type = mv->refcnt_type & 31 + (i32.shr_u (i32.load $mv) 5)) ;; / 32 + + ;; Returns the address of 'mem[mv_idx].val[val]' + ;; Will usually be used with a load or store by the caller + (func $MalVal_val_ptr (param $mv_idx i32 $val i32) (result i32) + (i32.add (i32.add ($MalVal_ptr $mv_idx) 4) + (i32.mul $val 4))) + + ;; Returns the value of 'mem[mv_idx].val[val]' + (func $MalVal_val (param $mv_idx i32 $val i32) (result i32) + (i32.load ($MalVal_val_ptr $mv_idx $val))) + + (func $MalType_size (param $type i32) (result i32) + ;;; if (type <= 5 || type == 9 || type == 12) + (if (result i32) (OR (i32.le_u $type 5) + (i32.eq $type 9) + (i32.eq $type 12)) + (then 2) + (else + ;;; else if (type == 8 || type == 10 || type == 11) + (if (result i32) (OR (i32.eq $type 8) + (i32.eq $type 10) + (i32.eq $type 11)) + (then 4) + (else 3))))) + + (func $MalVal_size (param $mv i32) (result i32) + (LET $type ($TYPE $mv)) + ;; if (type == FREE_T) + (if (result i32) (i32.eq $type (global.get $FREE_T)) + (then + ;;; return (mv->refcnt_type & 0xffe0)>>5 + (i32.shr_u (i32.and (i32.load $mv) 0xffe0) 5)) ;;; / 32 + (else + ;;; return MalType_size(type) + ($MalType_size $type)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; init_memory + + (func $init_memory + (LET $heap_size 0) + +;; ($print ">>> init_memory\n") + + ($init_printf_mem) + + ;; error_str string buffer + (global.set $error_str (STATIC_ARRAY 100)) + ;; reader token string buffer + (global.set $token_buf (STATIC_ARRAY 256)) + ;; printer string buffer + (global.set $printer_buf (STATIC_ARRAY 4096)) + + (local.set $heap_size (i32.add (global.get $MEM_SIZE) + (global.get $STRING_MEM_SIZE))) + (global.set $heap_start (i32.add (global.get $memoryBase) + (global.get $S_STRING_END))) + (global.set $heap_end (i32.add (global.get $heap_start) + $heap_size)) + + (global.set $mem (global.get $heap_start)) + (global.set $mem_unused_start 0) + (global.set $mem_free_list 0) + + (global.set $string_mem (i32.add (global.get $heap_start) + (global.get $MEM_SIZE))) + (global.set $string_mem_next (global.get $string_mem)) + + (global.set $mem_user_start (global.get $mem_unused_start)) + (global.set $string_mem_user_start (global.get $string_mem_next)) + + ;; Empty values + (global.set $NIL + ($ALLOC_SCALAR (global.get $NIL_T) 0)) + (global.set $FALSE + ($ALLOC_SCALAR (global.get $BOOLEAN_T) 0)) + (global.set $TRUE + ($ALLOC_SCALAR (global.get $BOOLEAN_T) 1)) + (global.set $EMPTY_LIST + ($ALLOC (global.get $LIST_T) + (global.get $NIL) (global.get $NIL) (global.get $NIL))) + (global.set $EMPTY_VECTOR + ($ALLOC (global.get $VECTOR_T) + (global.get $NIL) (global.get $NIL) (global.get $NIL))) + (global.set $EMPTY_HASHMAP + ($ALLOC (global.get $HASHMAP_T) + (global.get $NIL) (global.get $NIL) (global.get $NIL))) + +;; ($print "<<< init_memory\n") + + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; memory management + + (func $ALLOC_INTERNAL (param $type i32 + $val1 i32 $val2 i32 $val3 i32) (result i32) + (LET $prev (global.get $mem_free_list) + $res (global.get $mem_free_list) + $size ($MalType_size $type)) + + (block $loop_done + (loop $loop + ;; res == mem_unused_start + (if (i32.eq $res (global.get $mem_unused_start)) + (then + ;; ALLOC_UNUSED + ;;; if (res + size > MEM_SIZE) + (if (i32.gt_u (i32.add $res $size) (global.get $MEM_SIZE)) + ;; Out of memory, exit + ($fatal 7 "Out of mal memory!\n")) + ;;; if (mem_unused_start += size) + (global.set $mem_unused_start + (i32.add (global.get $mem_unused_start) $size)) + ;;; if (prev == res) + (if (i32.eq $prev $res) + (then + (global.set $mem_free_list (global.get $mem_unused_start))) + (else + ;;; mem[prev].val[0] = mem_unused_start + (i32.store + ($MalVal_val_ptr $prev 0) + (global.get $mem_unused_start)))) + (br $loop_done))) + ;; if (MalVal_size(mem+res) == size) + (if (i32.eq ($MalVal_size ($MalVal_ptr $res)) + $size) + (then + ;; ALLOC_MIDDLE + ;;; if (res == mem_free_list) + (if (i32.eq $res (global.get $mem_free_list)) + ;; set free pointer (mem_free_list) to next free + ;;; mem_free_list = mem[res].val[0]; + (global.set $mem_free_list ($MalVal_val $res 0))) + ;; if (res != mem_free_list) + (if (i32.ne $res (global.get $mem_free_list)) + ;; set previous free to next free + ;;; mem[prev].val[0] = mem[res].val[0] + (i32.store ($MalVal_val_ptr $prev 0) ($MalVal_val $res 0))) + (br $loop_done))) + ;;; prev = res + (local.set $prev $res) + ;;; res = mem[res].val[0] + (local.set $res ($MalVal_val $res 0)) + (br $loop) + ) + ) + ;; ALLOC_DONE + ;;; mem[res].refcnt_type = type + 32 + (i32.store ($MalVal_ptr $res) (i32.add $type 32)) + ;; set val to default val1 + ;;; mem[res].val[0] = val1 + (i32.store ($MalVal_val_ptr $res 0) $val1) + ;;; if (type > 5 && type != 9) + (if (AND (i32.gt_u $type 5) + (i32.ne $type 9)) + (then + ;; inc refcnt of referenced value + ;;; mem[val1].refcnt_type += 32 + (i32.store ($MalVal_ptr $val1) + (i32.add ($MalVal_refcnt_type $val1) 32)))) + ;;; if (size > 2) + (if (i32.gt_u $size 2) + (then + ;; inc refcnt of referenced value + ;;; mem[val2].refcnt_type += 32 + (i32.store ($MalVal_ptr $val2) + (i32.add ($MalVal_refcnt_type $val2) 32)) + ;;; mem[res].val[1] = val2 + (i32.store ($MalVal_val_ptr $res 1) $val2))) + ;;; if (size > 3) + (if (i32.gt_u $size 3) + (then + ;; inc refcnt of referenced value + ;;; mem[val3].refcnt_type += 32 + (i32.store ($MalVal_ptr $val3) + (i32.add ($MalVal_refcnt_type $val3) 32)) + ;;; mem[res].val[2] = val3 + (i32.store ($MalVal_val_ptr $res 2) $val3))) + + ;;; return mem + res + ($MalVal_ptr $res) + ) + + (func $ALLOC_SCALAR (param $type i32 $val1 i32) (result i32) + ($ALLOC_INTERNAL $type $val1 0 0) + ) + + (func $ALLOC (param $type i32 $val1 i32 $val2 i32 $val3 i32) (result i32) + ($ALLOC_INTERNAL $type ($IDX $val1) ($IDX $val2) ($IDX $val3)) + ) + + (func $RELEASE (param $mv i32) + (LET $idx 0 $type 0 $size 0) + + ;; Ignore NULLs + ;;; if (mv == NULL) { return; } + (if (i32.eqz $mv) (return)) + ;;; idx = mv - mem + (local.set $idx ($IDX $mv)) + ;;; type = mv->refcnt_type & 31 + (local.set $type (i32.and (i32.load $mv) 0x1f)) ;; 0x1f == 31 + ;;; size = MalType_size(type) + (local.set $size ($MalType_size $type)) + + ;; DEBUG + ;;; printf(">>> RELEASE idx: %d, type: %d, size: %d\n", idx, type, size) + + (if (i32.eq 0 $mv) + ($fatal 7 "RELEASE of NULL!\n")) + + (if (i32.eq (global.get $FREE_T) $type) + (then + ($printf_2 "RELEASE of already free mv: 0x%x, idx: 0x%x\n" $mv $idx) + ($fatal 1 ""))) + (if (i32.lt_u ($MalVal_refcnt_type $idx) 15) + (then + ($printf_2 "RELEASE of unowned mv: 0x%x, idx: 0x%x\n" $mv $idx) + ($fatal 1 ""))) + + ;; decrease reference count by one + (i32.store ($MalVal_ptr $idx) + (i32.sub ($MalVal_refcnt_type $idx) 32)) + + ;; nil, false, true, empty sequences + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) + (then + (if (i32.lt_u ($MalVal_refcnt_type $idx) 32) + (then + ($printf_2 "RELEASE of unowned mv: 0x%x, idx: 0x%x\n" $mv $idx) + ($fatal 1 ""))) + (return))) + + ;; our reference count is not 0, so don't release + (if (i32.ge_u ($MalVal_refcnt_type $idx) 32) + (return)) + + (block $done + (block (block (block (block (block (block (block (block (block + (br_table 0 0 0 0 1 1 2 2 3 0 4 4 5 6 7 8 8 $type)) + ;; nil, boolean, integer, float + (br $done)) + ;; string, kw, symbol + ;; release string, then FREE reference + ($RELEASE_STRING (i32.add (global.get $string_mem) ($VAL0 $mv))) + (br $done)) + ;; list, vector + (if (i32.ne ($MalVal_val $idx 0) 0) + (then + ;; release next element and value + ($RELEASE ($MEM_VAL0_ptr $mv)) + ($RELEASE ($MEM_VAL1_ptr $mv)))) + (br $done)) + ;; hashmap + (if (i32.ne ($MalVal_val $idx 0) 0) + (then + ;; release next element, value, and key + ($RELEASE ($MEM_VAL0_ptr $mv)) + ($RELEASE ($MEM_VAL2_ptr $mv)) + ($RELEASE ($MEM_VAL1_ptr $mv)))) + (br $done)) + ;; mal / macro function + ;; release ast, params, and environment + ($RELEASE ($MEM_VAL2_ptr $mv)) + ($RELEASE ($MEM_VAL1_ptr $mv)) + ($RELEASE ($MEM_VAL0_ptr $mv)) + (br $done)) + ;; atom + ;; release contained/referred value + ($RELEASE ($MEM_VAL0_ptr $mv)) + (br $done)) + ;; env + ;; if outer is set then release outer + (if (i32.ne ($MalVal_val $idx 1) 0) + ($RELEASE ($MEM_VAL1_ptr $mv))) + ;; release the env data (hashmap) + ($RELEASE ($MEM_VAL0_ptr $mv)) + (br $done)) + ;; metadata + ;; release object and metdata object + ($RELEASE ($MEM_VAL0_ptr $mv)) + ($RELEASE ($MEM_VAL1_ptr $mv)) + (br $done)) + ;; default/unknown + ) + + ;; FREE, free the current element + + ;; set type(FREE/15) and size + ;;; mv->refcnt_type = size*32 + FREE_T + (i32.store $mv (i32.add (i32.mul $size 32) (global.get $FREE_T))) + (i32.store ($MalVal_val_ptr $idx 0) (global.get $mem_free_list)) + (global.set $mem_free_list $idx) + (if (i32.ge_u $size 3) (i32.store ($MalVal_val_ptr $idx 1) 0)) + (if (i32.eq $size 4) (i32.store ($MalVal_val_ptr $idx 2) 0)) + ) + + ;; find string in string memory or 0 if not found + (func $FIND_STRING (param $str i32) (result i32) + (LET $ms (global.get $string_mem)) + (block $done + (loop $loop + (br_if $done (i32.ge_s $ms (global.get $string_mem_next))) + (if (i32.eqz ($strcmp $str (i32.add $ms 4))) + (return $ms)) + + (local.set $ms (i32.add $ms (i32.load16_u (i32.add $ms 2)))) + (br $loop) + ) + ) + 0 + ) + + ;; str is a NULL terminated string + ;; size is number of characters in the string not including the + ;; trailing NULL + (func $ALLOC_STRING (param $str i32 $size i32 $intern i32) (result i32) + (LET $ms 0) + + ;; search for matching string in string_mem + (if $intern + (then + (local.set $ms ($FIND_STRING $str)) + (if $ms + (then + ;;; ms->refcnt += 1 + (i32.store16 $ms (i32.add (i32.load16_u $ms) 1)) + (return $ms))))) + + ;; no existing matching string so create a new one + (local.set $ms (global.get $string_mem_next)) + (i32.store16 $ms 1) + ;;; ms->size = sizeof(MalString)+size+1 + (i32.store16 offset=2 $ms (i32.add (i32.add 4 $size) 1)) + ($memmove (i32.add $ms 4) $str (i32.add $size 1)) + ;;; string_mem_next = (void *)ms + ms->size + (global.set $string_mem_next + ;;(i32.add $ms (i32.load16_u (i32.add $ms 2)))) + (i32.add $ms (i32.load16_u offset=2 $ms))) + +;;($printf_2 "ALLOC_STRING 6 ms 0x%x, refs: %d\n" $ms (i32.load16_u $ms)) + $ms + ) + + (func $RELEASE_STRING (param $ms i32) + (LET $size 0 $next 0 $ms_idx 0 $idx 0 $type 0 $mv 0) + + (if (i32.le_s (i32.load16_u $ms) 0) + (then + ($printf_2 "Release of already free string: %d (0x%x)\n" + (i32.sub $ms (global.get $string_mem)) $ms) + ($fatal 1 ""))) + + ;;; size = ms->size + (local.set $size (i32.load16_u (i32.add $ms 2))) + ;;; *next = (void *)ms + size + (local.set $next (i32.add $ms $size)) + + ;;; ms->refcnt -= 1 + (i32.store16 $ms (i32.sub (i32.load16_u $ms) 1)) + + (if (i32.eqz (i32.load16_u $ms)) + (then + (if (i32.gt_s (global.get $string_mem_next) $next) + (then + ;; If no more references to this string then free it up by + ;; shifting up every string afterwards to fill the gap + ;; (splice). + ($memmove $ms $next (i32.sub (global.get $string_mem_next) + $next)) + + ;; Scan the mem values for string types after the freed + ;; string and shift their indexes by size + (local.set $ms_idx (i32.sub $ms (global.get $string_mem))) + (local.set $idx ($IDX (global.get $EMPTY_HASHMAP))) + (loop $loop + (local.set $mv ($MalVal_ptr $idx)) + (local.set $type ($TYPE $mv)) + (if (AND (i32.gt_s ($VAL0 $mv) $ms_idx) + (OR (i32.eq $type (global.get $STRING_T)) + (i32.eq $type (global.get $SYMBOL_T)))) + (i32.store ($VAL0_ptr $mv) (i32.sub ($VAL0 $mv) $size))) + (local.set $idx (i32.add $idx ($MalVal_size $mv))) + + (br_if $loop (i32.lt_s $idx (global.get $mem_unused_start))) + ))) + + (global.set $string_mem_next + (i32.sub (global.get $string_mem_next) $size)))) + ) +) diff --git a/impls/wasm/node_readline.js b/impls/wasm/node_readline.js index 6042eaa0af..9bfa296bb2 100644 --- a/impls/wasm/node_readline.js +++ b/impls/wasm/node_readline.js @@ -1,46 +1,46 @@ -// IMPORTANT: choose one -var RL_LIB = "libreadline"; // NOTE: libreadline is GPL -//var RL_LIB = "libedit"; - -var HISTORY_FILE = require('path').join(process.env.HOME, '.mal-history'); - -var rlwrap = {}; // namespace for this module in web context - -var ffi = require('ffi-napi'), - fs = require('fs'); - -var rllib = ffi.Library(RL_LIB, { - 'readline': [ 'string', [ 'string' ] ], - 'add_history': [ 'int', [ 'string' ] ]}); - -var rl_history_loaded = false; - -exports.readline = rlwrap.readline = function(prompt) { - prompt = typeof prompt !== 'undefined' ? prompt : "user> "; - - if (!rl_history_loaded) { - rl_history_loaded = true; - var lines = []; - if (fs.existsSync(HISTORY_FILE)) { - lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); - } - // Max of 2000 lines - lines = lines.slice(Math.max(lines.length - 2000, 0)); - for (var i=0; i "; + + if (!rl_history_loaded) { + rl_history_loaded = true; + var lines = []; + if (fs.existsSync(HISTORY_FILE)) { + lines = fs.readFileSync(HISTORY_FILE).toString().split("\n"); + } + // Max of 2000 lines + lines = lines.slice(Math.max(lines.length - 2000, 0)); + for (var i=0; i n 0) (+ n (abcdefg (- n 1))) 0))) - (if (i32.eq (CHR "\n") - (i32.load8_u (i32.add $buf (i32.sub (i32.load $nread_ptr) 1)) 0)) - (i32.store8 (i32.add $buf (i32.sub (i32.load $nread_ptr) 1)) 0)) - 1 - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $read_file (param $path i32 $buf i32) (result i32) - (LET $orig_path $path - $ret 0 - $prestat_ptr (STATIC_ARRAY 8 4) - $pr_type 0 - $pr_name_len 0 - $prepath (STATIC_ARRAY 1024) - $dirfd -1 - $fd 3 - $fd_ptr (STATIC_ARRAY 4 4) - $nread_ptr (STATIC_ARRAY 4 4) - $iovec (STATIC_ARRAY 8 8)) - - ;; Find the pre-opened dir fd with the same prefix as the our path - ;; following the algorithm at: - ;; https://github.com/CraneStation/wasi-sysroot/blob/1cc98f27f5ab8afdc033e16eac8799ee606eb769/libc-bottom-half/crt/crt1.c#L71 - ;; The matching dir fd is then used to open and read the path. - (block $loop_done - (loop $loop - ;; prestat the fd from 3 onward until EBADF is returned - (local.set $ret ($fd_prestat_get $fd $prestat_ptr)) - (if (i32.eq (global.get $WASI_EBADF) $ret) - (br $loop_done)) - (if (i32.ne (global.get $WASI_ESUCCESS) $ret) - (then - (local.set $fd (i32.add 1 $fd)) - (br $loop))) - ;;(br $loop_done)) - (local.set $pr_type (i32.load $prestat_ptr)) - (local.set $pr_name_len (i32.load offset=4 $prestat_ptr)) - ;; Read the pre-opened path name - (local.set $ret ($fd_prestat_dir_name $fd $prepath $pr_name_len)) - (if (i32.ne (global.get $WASI_ESUCCESS) $ret) - (br $loop_done)) - ;; if pr_name_len includes a null, exclude it from the compare - ;;($printf_2 "here1 pr_name_len: %d, char is %d\n" $pr_name_len (i32.load8_u (i32.add $prepath (i32.sub $pr_name_len 1)))) - (if (i32.eqz (i32.load8_u (i32.add $prepath (i32.sub $pr_name_len 1)))) - (then - (local.set $pr_name_len (i32.sub $pr_name_len 1)))) - ;; if it is a dir and the path prefix matches, use it - ;;($printf_5 "fd: %d, ret: %d, pr_type: %d, pr_name_len: %d, prepath: %s\n" - ;; $fd $ret $pr_type $pr_name_len $prepath) - (if (AND (i32.eq $pr_type (global.get $WASI_PREOPENTYPE_DIR)) - (i32.eqz ($strncmp $prepath $path $pr_name_len))) - (then - (local.set $path (i32.add $pr_name_len $path)) - (local.set $dirfd $fd) - (br $loop_done))) - (local.set $fd (i32.add 1 $fd)) - (br $loop) - ) - ) - - ;;($printf_3 "final dirfd: %d, adjusted path: %s (%d)\n" $dirfd $path ($strlen $path)) - - (if (i32.eq $dirfd -1) - (then - ($printf_1 "ERROR: could not find permission for '%s'\n" $orig_path) - (return 0))) - - (local.set $ret ($path_open $dirfd - 1 ;; dirflags (symlink follow) - $path - ($strlen $path) - 0 ;; o_flags - (global.get $WASI_RIGHT_FD_READ) - (global.get $WASI_RIGHT_FD_READ) - 0 ;; fs_flags - $fd_ptr)) - (if (i32.ne (global.get $WASI_ESUCCESS) $ret) - (then - ($printf_2 "ERROR: failed to open '%s', error %d\n" $orig_path $ret) - (return 0))) - - (i32.store $iovec $buf) - ;; TODO: use stat result instead of not hardcoded length - (i32.store offset=4 $iovec 16384) - (local.set $ret ($fd_read (i32.load $fd_ptr) $iovec 1 $nread_ptr)) - (if (i32.ne (global.get $WASI_ESUCCESS) $ret) - (then - ($printf_2 "ERROR: failed to read '%s', error %d\n" $orig_path $ret) - (return 0))) - - ;; Add null to string - (i32.store8 (i32.add $buf (i32.load $nread_ptr)) 0) - (i32.add 1 (i32.load $nread_ptr)) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $get_time_ms (result i32) - (LET $tv (STATIC_ARRAY 8 8)) - (drop (call $clock_time_get 0 (i64.const 0) $tv)) - (i32.wrap_i64 - ;; convert nanoseconds to milliseconds - (i64.div_u (i64.load $tv) (i64.const 1000000))) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Returns an i64 with argc in high 32 and argv in low 32. - ;; String memory is: argv + (argc * 4) - (func $get_argc_argv (result i64) - (LET $argc_ptr (STATIC_ARRAY 4 4) - $argv_size_ptr (STATIC_ARRAY 4 4) - $argc 0 - $argv (STATIC_ARRAY 1024 4)) - (drop ($args_sizes_get $argc_ptr $argv_size_ptr)) - (local.set $argc (i32.load $argc_ptr)) - (if (i32.gt_u (i32.add (i32.mul 4 $argc) - (i32.load $argv_size_ptr)) - 1024) - ($fatal 2 "Command line arguments memory exceeds 1024 bytes")) - (drop ($args_get $argv (i32.add $argv (i32.mul 4 $argc)))) - (i64.or (i64.shl (i64.extend_i32_u $argc) (i64.const 32)) - (i64.extend_i32_u $argv)) - ) - - (func $entry - (local $argc_argv i64) - ($init_memory) - (local.set $argc_argv ($get_argc_argv)) - ($proc_exit - ($main (i32.wrap_i64 (i64.shr_u $argc_argv (i64.const 32))) - (i32.wrap_i64 $argc_argv))) - ) - ;;(start $entry) - - (export "_start" (func $entry)) - -) +(module $platform_wasi + + (memory 256) + (export "memory" (memory 0)) + + (global $WASI_RIGHT_FD_READ i64 (i64.const 2)) + (global $WASI_ESUCCESS i32 0) + (global $WASI_EBADF i32 8) + (global $WASI_PREOPENTYPE_DIR i32 0) + + (import "wasi_unstable" "args_get" (func $args_get (param i32 i32) (result i32))) + (import "wasi_unstable" "args_sizes_get" (func $args_sizes_get (param i32 i32) (result i32))) + (import "wasi_unstable" "clock_time_get" (func $clock_time_get (param i32 i64 i32) (result i32))) + (import "wasi_unstable" "fd_prestat_get" (func $fd_prestat_get (param i32 i32) (result i32))) + (import "wasi_unstable" "fd_prestat_dir_name" (func $fd_prestat_dir_name (param i32 i32 i32) (result i32))) + (import "wasi_unstable" "fd_read" (func $fd_read (param i32 i32 i32 i32) (result i32))) + (import "wasi_unstable" "fd_write" (func $fd_write (param i32 i32 i32 i32) (result i32))) + (import "wasi_unstable" "path_open" (func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) (result i32))) + (import "wasi_unstable" "proc_exit" (func $proc_exit (param i32))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $fatal (param $code i32 $msg i32) + ($print $msg) + ($proc_exit $code) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $print (param $addr i32) + (LET $ret 0 + $nwritten_ptr (STATIC_ARRAY 4 4) + $iovec (STATIC_ARRAY 8 8)) + (i32.store $iovec $addr) + (i32.store offset=4 $iovec ($strlen $addr)) + (local.set $ret ($fd_write 1 $iovec 1 $nwritten_ptr)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $readline (param $prompt i32 $buf i32) (result i32) + (LET $ret 0 + $nread_ptr (STATIC_ARRAY 4 4) + $iovec (STATIC_ARRAY 8 8)) + ($print $prompt) + (i32.store $iovec $buf) + (i32.store offset=4 $iovec 200) ;; TODO: not hardcoded length + (local.set $ret ($fd_read 0 $iovec 1 $nread_ptr)) + (if (i32.le_s (i32.load $nread_ptr) 0) + (return 0)) + ;; Replace ending newline with NULL + ;; NOTE: oddly, there isn't always a newline so check first + ;; Specifically, this input chops too much: + ;; (abcd abcdefg (abc (n) (if (> n 0) (+ n (abcdefg (- n 1))) 0))) + (if (i32.eq (CHR "\n") + (i32.load8_u (i32.add $buf (i32.sub (i32.load $nread_ptr) 1)) 0)) + (i32.store8 (i32.add $buf (i32.sub (i32.load $nread_ptr) 1)) 0)) + 1 + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $read_file (param $path i32 $buf i32) (result i32) + (LET $orig_path $path + $ret 0 + $prestat_ptr (STATIC_ARRAY 8 4) + $pr_type 0 + $pr_name_len 0 + $prepath (STATIC_ARRAY 1024) + $dirfd -1 + $fd 3 + $fd_ptr (STATIC_ARRAY 4 4) + $nread_ptr (STATIC_ARRAY 4 4) + $iovec (STATIC_ARRAY 8 8)) + + ;; Find the pre-opened dir fd with the same prefix as the our path + ;; following the algorithm at: + ;; https://github.com/CraneStation/wasi-sysroot/blob/1cc98f27f5ab8afdc033e16eac8799ee606eb769/libc-bottom-half/crt/crt1.c#L71 + ;; The matching dir fd is then used to open and read the path. + (block $loop_done + (loop $loop + ;; prestat the fd from 3 onward until EBADF is returned + (local.set $ret ($fd_prestat_get $fd $prestat_ptr)) + (if (i32.eq (global.get $WASI_EBADF) $ret) + (br $loop_done)) + (if (i32.ne (global.get $WASI_ESUCCESS) $ret) + (then + (local.set $fd (i32.add 1 $fd)) + (br $loop))) + ;;(br $loop_done)) + (local.set $pr_type (i32.load $prestat_ptr)) + (local.set $pr_name_len (i32.load offset=4 $prestat_ptr)) + ;; Read the pre-opened path name + (local.set $ret ($fd_prestat_dir_name $fd $prepath $pr_name_len)) + (if (i32.ne (global.get $WASI_ESUCCESS) $ret) + (br $loop_done)) + ;; if pr_name_len includes a null, exclude it from the compare + ;;($printf_2 "here1 pr_name_len: %d, char is %d\n" $pr_name_len (i32.load8_u (i32.add $prepath (i32.sub $pr_name_len 1)))) + (if (i32.eqz (i32.load8_u (i32.add $prepath (i32.sub $pr_name_len 1)))) + (then + (local.set $pr_name_len (i32.sub $pr_name_len 1)))) + ;; if it is a dir and the path prefix matches, use it + ;;($printf_5 "fd: %d, ret: %d, pr_type: %d, pr_name_len: %d, prepath: %s\n" + ;; $fd $ret $pr_type $pr_name_len $prepath) + (if (AND (i32.eq $pr_type (global.get $WASI_PREOPENTYPE_DIR)) + (i32.eqz ($strncmp $prepath $path $pr_name_len))) + (then + (local.set $path (i32.add $pr_name_len $path)) + (local.set $dirfd $fd) + (br $loop_done))) + (local.set $fd (i32.add 1 $fd)) + (br $loop) + ) + ) + + ;;($printf_3 "final dirfd: %d, adjusted path: %s (%d)\n" $dirfd $path ($strlen $path)) + + (if (i32.eq $dirfd -1) + (then + ($printf_1 "ERROR: could not find permission for '%s'\n" $orig_path) + (return 0))) + + (local.set $ret ($path_open $dirfd + 1 ;; dirflags (symlink follow) + $path + ($strlen $path) + 0 ;; o_flags + (global.get $WASI_RIGHT_FD_READ) + (global.get $WASI_RIGHT_FD_READ) + 0 ;; fs_flags + $fd_ptr)) + (if (i32.ne (global.get $WASI_ESUCCESS) $ret) + (then + ($printf_2 "ERROR: failed to open '%s', error %d\n" $orig_path $ret) + (return 0))) + + (i32.store $iovec $buf) + ;; TODO: use stat result instead of not hardcoded length + (i32.store offset=4 $iovec 16384) + (local.set $ret ($fd_read (i32.load $fd_ptr) $iovec 1 $nread_ptr)) + (if (i32.ne (global.get $WASI_ESUCCESS) $ret) + (then + ($printf_2 "ERROR: failed to read '%s', error %d\n" $orig_path $ret) + (return 0))) + + ;; Add null to string + (i32.store8 (i32.add $buf (i32.load $nread_ptr)) 0) + (i32.add 1 (i32.load $nread_ptr)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $get_time_ms (result i32) + (LET $tv (STATIC_ARRAY 8 8)) + (drop (call $clock_time_get 0 (i64.const 0) $tv)) + (i32.wrap_i64 + ;; convert nanoseconds to milliseconds + (i64.div_u (i64.load $tv) (i64.const 1000000))) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Returns an i64 with argc in high 32 and argv in low 32. + ;; String memory is: argv + (argc * 4) + (func $get_argc_argv (result i64) + (LET $argc_ptr (STATIC_ARRAY 4 4) + $argv_size_ptr (STATIC_ARRAY 4 4) + $argc 0 + $argv (STATIC_ARRAY 1024 4)) + (drop ($args_sizes_get $argc_ptr $argv_size_ptr)) + (local.set $argc (i32.load $argc_ptr)) + (if (i32.gt_u (i32.add (i32.mul 4 $argc) + (i32.load $argv_size_ptr)) + 1024) + ($fatal 2 "Command line arguments memory exceeds 1024 bytes")) + (drop ($args_get $argv (i32.add $argv (i32.mul 4 $argc)))) + (i64.or (i64.shl (i64.extend_i32_u $argc) (i64.const 32)) + (i64.extend_i32_u $argv)) + ) + + (func $entry + (local $argc_argv i64) + ($init_memory) + (local.set $argc_argv ($get_argc_argv)) + ($proc_exit + ($main (i32.wrap_i64 (i64.shr_u $argc_argv (i64.const 32))) + (i32.wrap_i64 $argc_argv))) + ) + ;;(start $entry) + + (export "_start" (func $entry)) + +) diff --git a/impls/wasm/printer.wam b/impls/wasm/printer.wam index 65708e13b9..0612c37d17 100644 --- a/impls/wasm/printer.wam +++ b/impls/wasm/printer.wam @@ -1,182 +1,182 @@ -(module $printer - - (global $printer_buf (mut i32) 0) - - (func $pr_str_val (param $res i32 $mv i32 $print_readably i32) (result i32) - (LET $type ($TYPE $mv) - $val0 ($VAL0 $mv) - $sval 0) - - ;;; switch(type) - (block $done - (block $default - (block (block (block (block (block (block (block (block - (block (block (block (block (block (block (block (block - (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 $type)) - ;; 0: nil - ($memmove $res "nil" 4) - (local.set $res (i32.add 3 $res)) - (br $done)) - ;; 1: boolean - (if (i32.eq $val0 0) - (then - ;; false - ($memmove $res "false" 6) - (local.set $res (i32.add 5 $res))) - (else - ;; true - ($memmove $res "true" 5) - (local.set $res (i32.add 4 $res)))) - (br $done)) - ;; 2: integer - (local.set $res ($sprintf_1 $res "%d" $val0)) - (br $done)) - ;; 3: float/ERROR - (local.set $res ($sprintf_1 $res "%d" " *** GOT FLOAT *** ")) - (br $done)) - ;; 4: string/kw - (local.set $sval ($to_String $mv)) - (if (i32.eq (i32.load8_u $sval) (CHR "\x7f")) - (then - (local.set $res ($sprintf_1 $res ":%s" (i32.add $sval 1)))) - (else (if $print_readably - (then - ;; escape backslashes, quotes, and newlines - (local.set $res ($sprintf_1 $res "\"" 0)) - (local.set $res (i32.add $res ($REPLACE3 $res ($to_String $mv) - "\\" "\\\\" - "\"" "\\\"" - "\n" "\\n"))) - (local.set $res ($sprintf_1 $res "\"" 0))) - (else - (local.set $res ($sprintf_1 $res "%s" $sval)))))) - (br $done)) - ;; 5: symbol - (local.set $res ($sprintf_1 $res "%s" ($to_String $mv))) - (br $done)) - ;; 6: list, fallthrouogh - ) - ;; 7: vector, fallthrough - ) - ;; 8: hashmap - (local.set - $res ($sprintf_1 $res "%c" - (if (result i32) (i32.eq $type (global.get $LIST_T)) - (then (CHR "(")) - (else (if (result i32) (i32.eq $type (global.get $VECTOR_T)) - (then (CHR "[")) - (else (CHR "{"))))))) - ;; PR_SEQ_LOOP - ;;; while (VAL0(mv) != 0) - (block $done_seq - (loop $seq_loop - (br_if $done_seq (i32.eq ($VAL0 $mv) 0)) - ;;; res = pr_str_val(res, MEM_VAL1(mv), print_readably) - (local.set $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) - - ;; if this is a hash-map, print the next element - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - ;;; res += snprintf(res, 2, " ") - (local.set $res ($sprintf_1 $res " " 0)) - (local.set $res ($pr_str_val $res ($MEM_VAL2_ptr $mv) - $print_readably)))) - ;;; mv = MEM_VAL0(mv) - (local.set $mv ($MEM_VAL0_ptr $mv)) - ;;; if (VAL0(mv) != 0) - (if (i32.ne ($VAL0 $mv) 0) - ;;; res += snprintf(res, 2, " ") - (local.set $res ($sprintf_1 $res " " 0))) - (br $seq_loop) - ) - ) - - (local.set - $res ($sprintf_1 $res "%c" - (if (result i32) (i32.eq $type (global.get $LIST_T)) - (then (CHR ")")) - (else (if (result i32) (i32.eq $type (global.get $VECTOR_T)) - (then (CHR "]")) - (else (CHR "}"))))))) - (br $done)) - ;; 9: function - ($memmove $res "#" 10) - (local.set $res (i32.add 9 $res)) - (br $done)) - ;; 10: mal function - ($memmove $res "(fn* " 6) - (local.set $res (i32.add 5 $res)) - (local.set $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) - ($memmove $res " " 2) - (local.set $res (i32.add 1 $res)) - (local.set $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) - ($memmove $res ")" 2) - (local.set $res (i32.add 1 $res)) - (br $done)) - ;; 11: macro fn - ($memmove $res "#" 13) - (local.set $res (i32.add 12 $res)) - (br $done)) - ;; 12: atom - ($memmove $res "(atom " 7) - (local.set $res (i32.add 6 $res)) - (local.set $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) - ($memmove $res ")" 2) - (local.set $res (i32.add 1 $res)) - (br $done)) - ;; 13: environment - ($memmove $res "#" 11) - (local.set $res (i32.add 10 $res)) - (br $done)) - ;; 14: metadata - ;; recur on object itself - (local.set $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) - (br $done)) - ;; 15: FREE - ($memmove $res "#" 12) - (local.set $res (i32.add 11 $res)) - (br $done)) - ;; 16: default - ($memmove $res "#" 11) - (local.set $res (i32.add 10 $res)) - ) - - $res - ) - - (func $pr_str_internal (param $seq i32) (param $mv i32) - (param $print_readably i32) (param $sep i32) (result i32) - (LET $res ($STRING_INIT (global.get $STRING_T)) - $res_str ($to_String $res)) - - (if $seq - (then - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $mv))) - (local.set $res_str ($pr_str_val $res_str ($MEM_VAL1_ptr $mv) $print_readably)) - (local.set $mv ($MEM_VAL0_ptr $mv)) - (if (i32.ne ($VAL0 $mv) 0) - (local.set $res_str ($sprintf_1 $res_str "%s" $sep))) - (br $loop) - ) - )) - (else - (local.set $res_str ($pr_str_val $res_str $mv $print_readably)))) - - (local.set $res ($STRING_FINALIZE $res (i32.sub $res_str ($to_String $res)))) - - $res - ) - - (func $pr_str (param $mv i32 $print_readably i32) (result i32) - ($pr_str_internal 0 $mv $print_readably "") - ) - - (func $pr_str_seq (param $mv i32 $print_readably i32 $sep i32) (result i32) - ($pr_str_internal 1 $mv $print_readably $sep) - ) - - (export "pr_str" (func $pr_str)) - -) +(module $printer + + (global $printer_buf (mut i32) 0) + + (func $pr_str_val (param $res i32 $mv i32 $print_readably i32) (result i32) + (LET $type ($TYPE $mv) + $val0 ($VAL0 $mv) + $sval 0) + + ;;; switch(type) + (block $done + (block $default + (block (block (block (block (block (block (block (block + (block (block (block (block (block (block (block (block + (br_table 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 $type)) + ;; 0: nil + ($memmove $res "nil" 4) + (local.set $res (i32.add 3 $res)) + (br $done)) + ;; 1: boolean + (if (i32.eq $val0 0) + (then + ;; false + ($memmove $res "false" 6) + (local.set $res (i32.add 5 $res))) + (else + ;; true + ($memmove $res "true" 5) + (local.set $res (i32.add 4 $res)))) + (br $done)) + ;; 2: integer + (local.set $res ($sprintf_1 $res "%d" $val0)) + (br $done)) + ;; 3: float/ERROR + (local.set $res ($sprintf_1 $res "%d" " *** GOT FLOAT *** ")) + (br $done)) + ;; 4: string/kw + (local.set $sval ($to_String $mv)) + (if (i32.eq (i32.load8_u $sval) (CHR "\x7f")) + (then + (local.set $res ($sprintf_1 $res ":%s" (i32.add $sval 1)))) + (else (if $print_readably + (then + ;; escape backslashes, quotes, and newlines + (local.set $res ($sprintf_1 $res "\"" 0)) + (local.set $res (i32.add $res ($REPLACE3 $res ($to_String $mv) + "\\" "\\\\" + "\"" "\\\"" + "\n" "\\n"))) + (local.set $res ($sprintf_1 $res "\"" 0))) + (else + (local.set $res ($sprintf_1 $res "%s" $sval)))))) + (br $done)) + ;; 5: symbol + (local.set $res ($sprintf_1 $res "%s" ($to_String $mv))) + (br $done)) + ;; 6: list, fallthrouogh + ) + ;; 7: vector, fallthrough + ) + ;; 8: hashmap + (local.set + $res ($sprintf_1 $res "%c" + (if (result i32) (i32.eq $type (global.get $LIST_T)) + (then (CHR "(")) + (else (if (result i32) (i32.eq $type (global.get $VECTOR_T)) + (then (CHR "[")) + (else (CHR "{"))))))) + ;; PR_SEQ_LOOP + ;;; while (VAL0(mv) != 0) + (block $done_seq + (loop $seq_loop + (br_if $done_seq (i32.eq ($VAL0 $mv) 0)) + ;;; res = pr_str_val(res, MEM_VAL1(mv), print_readably) + (local.set $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) + + ;; if this is a hash-map, print the next element + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + ;;; res += snprintf(res, 2, " ") + (local.set $res ($sprintf_1 $res " " 0)) + (local.set $res ($pr_str_val $res ($MEM_VAL2_ptr $mv) + $print_readably)))) + ;;; mv = MEM_VAL0(mv) + (local.set $mv ($MEM_VAL0_ptr $mv)) + ;;; if (VAL0(mv) != 0) + (if (i32.ne ($VAL0 $mv) 0) + ;;; res += snprintf(res, 2, " ") + (local.set $res ($sprintf_1 $res " " 0))) + (br $seq_loop) + ) + ) + + (local.set + $res ($sprintf_1 $res "%c" + (if (result i32) (i32.eq $type (global.get $LIST_T)) + (then (CHR ")")) + (else (if (result i32) (i32.eq $type (global.get $VECTOR_T)) + (then (CHR "]")) + (else (CHR "}"))))))) + (br $done)) + ;; 9: function + ($memmove $res "#" 10) + (local.set $res (i32.add 9 $res)) + (br $done)) + ;; 10: mal function + ($memmove $res "(fn* " 6) + (local.set $res (i32.add 5 $res)) + (local.set $res ($pr_str_val $res ($MEM_VAL1_ptr $mv) $print_readably)) + ($memmove $res " " 2) + (local.set $res (i32.add 1 $res)) + (local.set $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) + ($memmove $res ")" 2) + (local.set $res (i32.add 1 $res)) + (br $done)) + ;; 11: macro fn + ($memmove $res "#" 13) + (local.set $res (i32.add 12 $res)) + (br $done)) + ;; 12: atom + ($memmove $res "(atom " 7) + (local.set $res (i32.add 6 $res)) + (local.set $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) + ($memmove $res ")" 2) + (local.set $res (i32.add 1 $res)) + (br $done)) + ;; 13: environment + ($memmove $res "#" 11) + (local.set $res (i32.add 10 $res)) + (br $done)) + ;; 14: metadata + ;; recur on object itself + (local.set $res ($pr_str_val $res ($MEM_VAL0_ptr $mv) $print_readably)) + (br $done)) + ;; 15: FREE + ($memmove $res "#" 12) + (local.set $res (i32.add 11 $res)) + (br $done)) + ;; 16: default + ($memmove $res "#" 11) + (local.set $res (i32.add 10 $res)) + ) + + $res + ) + + (func $pr_str_internal (param $seq i32) (param $mv i32) + (param $print_readably i32) (param $sep i32) (result i32) + (LET $res ($STRING_INIT (global.get $STRING_T)) + $res_str ($to_String $res)) + + (if $seq + (then + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $mv))) + (local.set $res_str ($pr_str_val $res_str ($MEM_VAL1_ptr $mv) $print_readably)) + (local.set $mv ($MEM_VAL0_ptr $mv)) + (if (i32.ne ($VAL0 $mv) 0) + (local.set $res_str ($sprintf_1 $res_str "%s" $sep))) + (br $loop) + ) + )) + (else + (local.set $res_str ($pr_str_val $res_str $mv $print_readably)))) + + (local.set $res ($STRING_FINALIZE $res (i32.sub $res_str ($to_String $res)))) + + $res + ) + + (func $pr_str (param $mv i32 $print_readably i32) (result i32) + ($pr_str_internal 0 $mv $print_readably "") + ) + + (func $pr_str_seq (param $mv i32 $print_readably i32 $sep i32) (result i32) + ($pr_str_internal 1 $mv $print_readably $sep) + ) + + (export "pr_str" (func $pr_str)) + +) diff --git a/impls/wasm/printf.wam b/impls/wasm/printf.wam index 7c5d730d0d..bba5807e94 100644 --- a/impls/wasm/printf.wam +++ b/impls/wasm/printf.wam @@ -1,226 +1,226 @@ -(module $printf - - (global $printf_buf (mut i32) 0) - - (func $init_printf_mem - ;; sprintf static buffer - (global.set $printf_buf (STATIC_ARRAY 256)) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $printf_1 (param $fmt i32) (param $v0 i32) - (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 0 0 0 0 0)) - ($print (global.get $printf_buf)) - ) - - (func $printf_2 (param $fmt i32 $v0 i32 $v1 i32) - (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 0 0 0 0)) - ($print (global.get $printf_buf)) - ) - - (func $printf_3 (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 0 0 0)) - ($print (global.get $printf_buf)) - ) - - (func $printf_4 (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (param $v3 i32) - (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 $v3 0 0)) - ($print (global.get $printf_buf)) - ) - - (func $printf_5 (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (param $v3 i32) (param $v4 i32) - (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 0)) - ($print (global.get $printf_buf)) - ) - - (func $printf_6 (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (param $v3 i32) (param $v4 i32) (param $v5 i32) - (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 $v5)) - ($print (global.get $printf_buf)) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (func $_sprintdigit (param $str i32) (param $num i32) (param $base i32) - (LET $n (i32.rem_u $num $base) - $ch (if (result i32) (i32.lt_u $n 10) 48 55)) - (i32.store8 $str (i32.add $n $ch)) - ) - - ;; TODO: add max buf length (i.e. snprintnum) - (func $_sprintnum (param $buf i32) (param $val i32) (param $radix i32) - (param $pad_cnt i32) (param $pad_char i32) (result i32) - (LET $pbuf $buf - $neg 0 $i 0 $j 0 $k 0 $len 0 $digit 0) - - (if (AND (i32.lt_s $val 0) (i32.eq $radix 10)) - (then - (local.set $neg 1) - (local.set $val (i32.sub 0 $val)))) - - ;; Calculate smallest to most significant digit - (loop $loop - (local.set $digit (i32.rem_u $val $radix)) - (i32.store8 $pbuf (if (result i32) (i32.lt_u $digit 10) - (i32.add (CHR "0") $digit) - (i32.sub (i32.add (CHR "A") $digit) 10))) - (local.set $pbuf (i32.add $pbuf 1)) - (local.set $val (i32.div_u $val $radix)) - (br_if $loop (i32.gt_u $val 0)) - ) - - (local.set $i (i32.sub $pbuf $buf)) - (block $done - (loop $loop - (br_if $done (i32.ge_u $i $pad_cnt)) - (i32.store8 $pbuf $pad_char) - (local.set $pbuf (i32.add $pbuf 1)) - (local.set $i (i32.add $i 1)) - (br $loop) - ) - ) - - (if $neg - (then - (i32.store8 $pbuf (CHR "-")) - (local.set $pbuf (i32.add $pbuf 1)))) - - (i32.store8 $pbuf (CHR "\x00")) - - ;; now reverse it - (local.set $len (i32.sub $pbuf $buf)) - (local.set $i 0) - (block $done - (loop $loop - (br_if $done (i32.ge_u $i (i32.div_u $len 2))) - - (local.set $j (i32.load8_u (i32.add $buf $i))) - (local.set $k (i32.add $buf (i32.sub (i32.sub $len $i) 1))) - (i32.store8 (i32.add $buf $i) (i32.load8_u $k)) - (i32.store8 $k $j) - (local.set $i (i32.add $i 1)) - (br $loop) - ) - ) - - (i32.add $buf $len) - ) - - ;; TODO: switch to snprint* (add buffer len) - (func $sprintf_1 (param $str i32) (param $fmt i32) - (param $v0 i32) (result i32) - ($sprintf_6 $str $fmt $v0 0 0 0 0 0) - ) - - (func $sprintf_6 (param $str i32) (param $fmt i32) - (param $v0 i32) (param $v1 i32) (param $v2 i32) - (param $v3 i32) (param $v4 i32) (param $v5 i32) - (result i32) - (LET $pstr $str - $vidx 0 $ch 0 $v 0 $len 0 $pad_cnt 0 $pad_char 0) - - (block $done - (loop $loop - (block $after_v - ;; set $v to the current parameter - (block (block (block (block (block (block - (br_table 0 1 2 3 4 5 0 $vidx)) - (; 0 ;) (local.set $v $v0) (br $after_v)) - (; 1 ;) (local.set $v $v1) (br $after_v)) - (; 2 ;) (local.set $v $v2) (br $after_v)) - (; 3 ;) (local.set $v $v3) (br $after_v)) - (; 4 ;) (local.set $v $v4) (br $after_v)) - (; 5 ;) (local.set $v $v5) (br $after_v) - ) - - ;;; while ((ch=*(fmt++))) - (local.set $ch (i32.load8_u $fmt)) - (local.set $fmt (i32.add 1 $fmt)) - (br_if $done (i32.eqz $ch)) - ;; TODO: check buffer length - - (if (i32.ne $ch (CHR "%")) - (then - ;; TODO: check buffer length - (i32.store8 $pstr $ch) - (local.set $pstr (i32.add 1 $pstr)) - (br $loop))) - - ;;; ch=*(fmt++) - (local.set $ch (i32.load8_u $fmt)) - (local.set $fmt (i32.add 1 $fmt)) - (br_if $done (i32.eqz $ch)) - - (local.set $pad_cnt 0) - (local.set $pad_char (CHR " ")) - (if (AND (i32.ge_s $ch (CHR "0")) (i32.le_s $ch (CHR "9"))) - (then - ;; padding requested - (if (i32.eq $ch (CHR "0")) - (then - ;; zero padding requested - (local.set $pad_char (CHR "0")) - ;;; ch=*(fmt++) - (local.set $ch (i32.load8_u $fmt)) - (local.set $fmt (i32.add 1 $fmt)) - (br_if $done (i32.eqz $ch)))) - (loop $loop - (local.set $pad_cnt (i32.mul $pad_cnt 10)) - (local.set $pad_cnt (i32.add $pad_cnt - (i32.sub $ch (CHR "0")))) - (local.set $ch (i32.load8_u $fmt)) - (local.set $fmt (i32.add 1 $fmt)) - (br_if $loop (AND (i32.ge_s $ch (CHR "0")) - (i32.le_s $ch (CHR "9")))) - ))) - - (if (i32.eq (CHR "d") $ch) - (then - (local.set $pstr ($_sprintnum $pstr $v 10 $pad_cnt $pad_char))) - (else (if (i32.eq (CHR "x") $ch) - (then - (local.set $pstr ($_sprintnum $pstr $v 16 $pad_cnt $pad_char))) - (else (if (i32.eq (CHR "s") $ch) - (then - (local.set $len ($strlen $v)) - (block $done - (loop $loop - (br_if $done (i32.le_s $pad_cnt $len)) - (i32.store8 $pstr (CHR " ")) - (local.set $pstr (i32.add $pstr 1)) - (local.set $pad_cnt (i32.sub $pad_cnt 1)) - (br $loop) - ) - ) - ($memmove $pstr $v $len) - (local.set $pstr (i32.add $pstr $len))) - (else (if (i32.eq (CHR "c") $ch) - (then - (i32.store8 $pstr $v) - (local.set $pstr (i32.add $pstr 1))) - (else (if (i32.eq (CHR "%") $ch) - (then - (i32.store8 $pstr (CHR "%")) - (local.set $pstr (i32.add $pstr 1)) - (br $loop)) ;; don't increase vidx - (else - ($printf_1 "Illegal format character: '%c'\n" $ch) - ($fatal 3 ""))))))))))) - - (local.set $vidx (i32.add 1 $vidx)) - (br $loop) - ) - ) - - (i32.store8 $pstr (CHR "\x00")) - $pstr - ) - -) +(module $printf + + (global $printf_buf (mut i32) 0) + + (func $init_printf_mem + ;; sprintf static buffer + (global.set $printf_buf (STATIC_ARRAY 256)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $printf_1 (param $fmt i32) (param $v0 i32) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 0 0 0 0 0)) + ($print (global.get $printf_buf)) + ) + + (func $printf_2 (param $fmt i32 $v0 i32 $v1 i32) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 0 0 0 0)) + ($print (global.get $printf_buf)) + ) + + (func $printf_3 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 0 0 0)) + ($print (global.get $printf_buf)) + ) + + (func $printf_4 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 $v3 0 0)) + ($print (global.get $printf_buf)) + ) + + (func $printf_5 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) (param $v4 i32) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 0)) + ($print (global.get $printf_buf)) + ) + + (func $printf_6 (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) (param $v4 i32) (param $v5 i32) + (drop ($sprintf_6 (global.get $printf_buf) $fmt $v0 $v1 $v2 $v3 $v4 $v5)) + ($print (global.get $printf_buf)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (func $_sprintdigit (param $str i32) (param $num i32) (param $base i32) + (LET $n (i32.rem_u $num $base) + $ch (if (result i32) (i32.lt_u $n 10) 48 55)) + (i32.store8 $str (i32.add $n $ch)) + ) + + ;; TODO: add max buf length (i.e. snprintnum) + (func $_sprintnum (param $buf i32) (param $val i32) (param $radix i32) + (param $pad_cnt i32) (param $pad_char i32) (result i32) + (LET $pbuf $buf + $neg 0 $i 0 $j 0 $k 0 $len 0 $digit 0) + + (if (AND (i32.lt_s $val 0) (i32.eq $radix 10)) + (then + (local.set $neg 1) + (local.set $val (i32.sub 0 $val)))) + + ;; Calculate smallest to most significant digit + (loop $loop + (local.set $digit (i32.rem_u $val $radix)) + (i32.store8 $pbuf (if (result i32) (i32.lt_u $digit 10) + (i32.add (CHR "0") $digit) + (i32.sub (i32.add (CHR "A") $digit) 10))) + (local.set $pbuf (i32.add $pbuf 1)) + (local.set $val (i32.div_u $val $radix)) + (br_if $loop (i32.gt_u $val 0)) + ) + + (local.set $i (i32.sub $pbuf $buf)) + (block $done + (loop $loop + (br_if $done (i32.ge_u $i $pad_cnt)) + (i32.store8 $pbuf $pad_char) + (local.set $pbuf (i32.add $pbuf 1)) + (local.set $i (i32.add $i 1)) + (br $loop) + ) + ) + + (if $neg + (then + (i32.store8 $pbuf (CHR "-")) + (local.set $pbuf (i32.add $pbuf 1)))) + + (i32.store8 $pbuf (CHR "\x00")) + + ;; now reverse it + (local.set $len (i32.sub $pbuf $buf)) + (local.set $i 0) + (block $done + (loop $loop + (br_if $done (i32.ge_u $i (i32.div_u $len 2))) + + (local.set $j (i32.load8_u (i32.add $buf $i))) + (local.set $k (i32.add $buf (i32.sub (i32.sub $len $i) 1))) + (i32.store8 (i32.add $buf $i) (i32.load8_u $k)) + (i32.store8 $k $j) + (local.set $i (i32.add $i 1)) + (br $loop) + ) + ) + + (i32.add $buf $len) + ) + + ;; TODO: switch to snprint* (add buffer len) + (func $sprintf_1 (param $str i32) (param $fmt i32) + (param $v0 i32) (result i32) + ($sprintf_6 $str $fmt $v0 0 0 0 0 0) + ) + + (func $sprintf_6 (param $str i32) (param $fmt i32) + (param $v0 i32) (param $v1 i32) (param $v2 i32) + (param $v3 i32) (param $v4 i32) (param $v5 i32) + (result i32) + (LET $pstr $str + $vidx 0 $ch 0 $v 0 $len 0 $pad_cnt 0 $pad_char 0) + + (block $done + (loop $loop + (block $after_v + ;; set $v to the current parameter + (block (block (block (block (block (block + (br_table 0 1 2 3 4 5 0 $vidx)) + (; 0 ;) (local.set $v $v0) (br $after_v)) + (; 1 ;) (local.set $v $v1) (br $after_v)) + (; 2 ;) (local.set $v $v2) (br $after_v)) + (; 3 ;) (local.set $v $v3) (br $after_v)) + (; 4 ;) (local.set $v $v4) (br $after_v)) + (; 5 ;) (local.set $v $v5) (br $after_v) + ) + + ;;; while ((ch=*(fmt++))) + (local.set $ch (i32.load8_u $fmt)) + (local.set $fmt (i32.add 1 $fmt)) + (br_if $done (i32.eqz $ch)) + ;; TODO: check buffer length + + (if (i32.ne $ch (CHR "%")) + (then + ;; TODO: check buffer length + (i32.store8 $pstr $ch) + (local.set $pstr (i32.add 1 $pstr)) + (br $loop))) + + ;;; ch=*(fmt++) + (local.set $ch (i32.load8_u $fmt)) + (local.set $fmt (i32.add 1 $fmt)) + (br_if $done (i32.eqz $ch)) + + (local.set $pad_cnt 0) + (local.set $pad_char (CHR " ")) + (if (AND (i32.ge_s $ch (CHR "0")) (i32.le_s $ch (CHR "9"))) + (then + ;; padding requested + (if (i32.eq $ch (CHR "0")) + (then + ;; zero padding requested + (local.set $pad_char (CHR "0")) + ;;; ch=*(fmt++) + (local.set $ch (i32.load8_u $fmt)) + (local.set $fmt (i32.add 1 $fmt)) + (br_if $done (i32.eqz $ch)))) + (loop $loop + (local.set $pad_cnt (i32.mul $pad_cnt 10)) + (local.set $pad_cnt (i32.add $pad_cnt + (i32.sub $ch (CHR "0")))) + (local.set $ch (i32.load8_u $fmt)) + (local.set $fmt (i32.add 1 $fmt)) + (br_if $loop (AND (i32.ge_s $ch (CHR "0")) + (i32.le_s $ch (CHR "9")))) + ))) + + (if (i32.eq (CHR "d") $ch) + (then + (local.set $pstr ($_sprintnum $pstr $v 10 $pad_cnt $pad_char))) + (else (if (i32.eq (CHR "x") $ch) + (then + (local.set $pstr ($_sprintnum $pstr $v 16 $pad_cnt $pad_char))) + (else (if (i32.eq (CHR "s") $ch) + (then + (local.set $len ($strlen $v)) + (block $done + (loop $loop + (br_if $done (i32.le_s $pad_cnt $len)) + (i32.store8 $pstr (CHR " ")) + (local.set $pstr (i32.add $pstr 1)) + (local.set $pad_cnt (i32.sub $pad_cnt 1)) + (br $loop) + ) + ) + ($memmove $pstr $v $len) + (local.set $pstr (i32.add $pstr $len))) + (else (if (i32.eq (CHR "c") $ch) + (then + (i32.store8 $pstr $v) + (local.set $pstr (i32.add $pstr 1))) + (else (if (i32.eq (CHR "%") $ch) + (then + (i32.store8 $pstr (CHR "%")) + (local.set $pstr (i32.add $pstr 1)) + (br $loop)) ;; don't increase vidx + (else + ($printf_1 "Illegal format character: '%c'\n" $ch) + ($fatal 3 ""))))))))))) + + (local.set $vidx (i32.add 1 $vidx)) + (br $loop) + ) + ) + + (i32.store8 $pstr (CHR "\x00")) + $pstr + ) + +) diff --git a/impls/wasm/reader.wam b/impls/wasm/reader.wam index ec2184cc7d..f869ca9c9d 100644 --- a/impls/wasm/reader.wam +++ b/impls/wasm/reader.wam @@ -1,323 +1,323 @@ -(module $reader - - ;; TODO: global warning - (global $token_buf (mut i32) 0) - (global $read_index (mut i32) 0) - - (func $skip_spaces (param $str i32) (result i32) - (LET $found 0 - $c (i32.load8_u (i32.add $str (global.get $read_index)))) - (block $done - (loop $loop - ;;; while (c == ' ' || c == ',' || c == '\n') - (br_if $done (AND (i32.ne $c (CHR " ")) - (i32.ne $c (CHR ",")) - (i32.ne $c (CHR "\n")))) - (local.set $found 1) - ;;; c=str[++(*index)] - (global.set $read_index (i32.add (global.get $read_index) 1)) - (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) - (br $loop) - ) - ) -;; ($debug ">>> skip_spaces:" $found) - $found - ) - - (func $skip_to_eol (param $str i32) (result i32) - (LET $found 0 - $c (i32.load8_u (i32.add $str (global.get $read_index)))) - (if (i32.eq $c (CHR ";")) - (then - (local.set $found 1) - (block $done - (loop $loop - ;;; c=str[++(*index)] - (global.set $read_index (i32.add (global.get $read_index) 1)) - (local.set $c (i32.load8_u (i32.add $str - (global.get $read_index)))) - ;;; while (c != '\0' && c != '\n') - (br_if $loop (AND (i32.ne $c (CHR "\x00")) - (i32.ne $c (CHR "\n")))) - ) - ))) -;; ($debug ">>> skip_to_eol:" $found) - $found - ) - - (func $skip_spaces_comments (param $str i32) - (loop $loop - ;; skip spaces - (br_if $loop ($skip_spaces $str)) - ;; skip comments - (br_if $loop ($skip_to_eol $str)) - ) - ) - - (func $read_token (param $str i32) (result i32) - (LET $token_index 0 - $isstring 0 - $instring 0 - $escaped 0 - $c 0) - - ($skip_spaces_comments $str) - - ;; read first character - ;;; c=str[++(*index)] - (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) - (global.set $read_index (i32.add (global.get $read_index) 1)) - ;; read first character - ;;; token[token_index++] = c - (i32.store8 (i32.add (global.get $token_buf) $token_index) $c) - (local.set $token_index (i32.add $token_index 1)) - ;; single/double character token - (if (OR (i32.eq $c (CHR "(")) - (i32.eq $c (CHR ")")) - (i32.eq $c (CHR "[")) - (i32.eq $c (CHR "]")) - (i32.eq $c (CHR "{")) - (i32.eq $c (CHR "}")) - (i32.eq $c (CHR "'")) - (i32.eq $c (CHR "`")) - (i32.eq $c (CHR "@")) - (AND (i32.eq $c (CHR "~")) - (i32.ne (i32.load8_u (i32.add $str (global.get $read_index))) - (CHR "@")))) - - (then - ;; continue - (nop)) - (else - ;;; if (c == '"') isstring = true - (local.set $isstring (i32.eq $c (CHR "\""))) - (local.set $instring $isstring) - (block $done - (loop $loop - ;; peek at next character - ;;; c = str[*index] - (local.set $c (i32.load8_u - (i32.add $str (global.get $read_index)))) - ;;; if (c == '\0') break - (br_if $done (i32.eq $c 0)) - ;;; if (!isstring) - (if (i32.eqz $isstring) - (then - ;; next character is token delimiter - (br_if $done (OR (i32.eq $c (CHR "(")) - (i32.eq $c (CHR ")")) - (i32.eq $c (CHR "[")) - (i32.eq $c (CHR "]")) - (i32.eq $c (CHR "{")) - (i32.eq $c (CHR "}")) - (i32.eq $c (CHR " ")) - (i32.eq $c (CHR ",")) - (i32.eq $c (CHR "\n")))))) - ;; read next character - ;;; token[token_index++] = str[(*index)++] - (i32.store8 (i32.add (global.get $token_buf) $token_index) - (i32.load8_u - (i32.add $str (global.get $read_index)))) - (local.set $token_index (i32.add $token_index 1)) - (global.set $read_index (i32.add (global.get $read_index) 1)) - ;;; if (token[0] == '~' && token[1] == '@') break - (br_if $done (AND (i32.eq (i32.load8_u - (i32.add (global.get $token_buf) 0)) - (CHR "~")) - (i32.eq (i32.load8_u - (i32.add (global.get $token_buf) 1)) - (CHR "@")))) - - ;;; if ((!isstring) || escaped) - (if (OR (i32.eqz $isstring) $escaped) - (then - (local.set $escaped 0) - (br $loop))) - (if (i32.eq $c (CHR "\\")) - (local.set $escaped 1)) - (if (i32.eq $c (CHR "\"")) - (then - (local.set $instring 0) - (br $done))) - (br $loop) - ) - ) - - (if (AND $isstring $instring) - (then - ($THROW_STR_0 "expected '\"', got EOF") - (return 0))))) - - ;;; token[token_index] = '\0' - (i32.store8 (i32.add (global.get $token_buf) $token_index) 0) - (global.get $token_buf) - ) - - (func $read_seq (param $str i32 $type i32 $end i32) (result i32) - (LET $res ($MAP_LOOP_START $type) - $val2 0 - $val3 0 - $c 0 - ;; MAP_LOOP stack - $ret $res - $empty $res - $current $res) - - ;; READ_SEQ_LOOP - (block $done - (loop $loop - ($skip_spaces_comments $str) - - ;; peek at next character - ;;; c = str[*index] - (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) - (if (i32.eq $c (CHR "\x00")) - (then - ($THROW_STR_0 "unexpected EOF") - (br $done))) - (if (i32.eq $c $end) - (then - ;; read next character - ;;; c = str[(*index)++] - (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) - (global.set $read_index (i32.add (global.get $read_index) 1)) - (br $done))) - - ;; value (or key for hash-maps) - (local.set $val2 ($read_form $str)) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $val2) - (br $done))) - - ;; if this is a hash-map, READ_FORM again - (if (i32.eq $type (global.get $HASHMAP_T)) - (local.set $val3 ($read_form $str))) - - ;; update the return sequence structure - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (br $loop) - ) - ) - - ;; MAP_LOOP_DONE - $ret - ) - - (func $read_macro (param $str i32 $sym i32 $with_meta i32) (result i32) - (LET $first ($STRING (global.get $SYMBOL_T) $sym) - $second ($read_form $str) - $third 0 - $res $second) - (if (global.get $error_type) (return $res)) - (if (i32.eqz $with_meta) - (then - (local.set $res ($LIST2 $first $second))) - (else - (local.set $third ($read_form $str)) - (local.set $res ($LIST3 $first $third $second)) - ;; release values, list has ownership - ($RELEASE $third))) - ;; release values, list has ownership - ($RELEASE $second) - ($RELEASE $first) - $res - ) - - (func $read_form (param $str i32) (result i32) - (LET $tok 0 $c0 0 $c1 0 $res 0 $slen 0) - - (if (global.get $error_type) (return 0)) - - (local.set $tok ($read_token $str)) - - (if (global.get $error_type) (return 0)) - ;;($printf_1 ">>> read_form 1: %s\n" $tok) - ;;; c0 = token[0] - (local.set $c0 (i32.load8_u $tok)) - (local.set $c1 (i32.load8_u (i32.add $tok 1))) - - (if (i32.eq $c0 0) - (then - (return ($INC_REF (global.get $NIL)))) - (else (if (OR (AND (i32.ge_u $c0 (CHR "0")) - (i32.le_u $c0 (CHR "9"))) - (AND (i32.eq $c0 (CHR "-")) - (i32.ge_u $c1 (CHR "0")) - (i32.le_u $c1 (CHR "9")))) - (then - (return ($INTEGER ($atoi $tok)))) - (else (if (i32.eq $c0 (CHR ":")) - (then - (i32.store8 $tok (CHR "\x7f")) - (return ($STRING (global.get $STRING_T) $tok))) - (else (if (i32.eq $c0 (CHR "\"")) - (then - (local.set $slen ($strlen (i32.add $tok 1))) - (if (i32.ne (i32.load8_u (i32.add $tok $slen)) (CHR "\"")) - (then - ($THROW_STR_0 "expected '\"', got EOF") - (return 0)) - (else - ;; unescape backslashes, quotes, and newlines - ;; remove the trailing quote - (i32.store8 (i32.add $tok $slen) (CHR "\x00")) - (local.set $tok (i32.add $tok 1)) - (drop ($REPLACE3 0 $tok - "\\\"" "\"" - "\\n" "\n" - "\\\\" "\\")) - (return ($STRING (global.get $STRING_T) $tok))))) - (else (if (i32.eqz ($strcmp "nil" $tok)) - (then (return ($INC_REF (global.get $NIL)))) - (else (if (i32.eqz ($strcmp "false" $tok)) - (then (return ($INC_REF (global.get $FALSE)))) - (else (if (i32.eqz ($strcmp "true" $tok)) - (then (return ($INC_REF (global.get $TRUE)))) - (else (if (i32.eqz ($strcmp "'" $tok)) - (then (return ($read_macro $str "quote" 0))) - (else (if (i32.eqz ($strcmp "`" $tok)) - (then (return ($read_macro $str "quasiquote" 0))) - (else (if (i32.eqz ($strcmp "~@" $tok)) - (then (return ($read_macro $str "splice-unquote" 0))) - (else (if (i32.eqz ($strcmp "~" $tok)) - (then (return ($read_macro $str "unquote" 0))) - (else (if (i32.eqz ($strcmp "^" $tok)) - (then (return ($read_macro $str "with-meta" 1))) - (else (if (i32.eqz ($strcmp "@" $tok)) - (then (return ($read_macro $str "deref" 0))) - (else (if (i32.eq $c0 (CHR "(")) - (then (return ($read_seq $str (global.get $LIST_T) (CHR ")")))) - (else (if (i32.eq $c0 (CHR "[")) - (then (return ($read_seq $str (global.get $VECTOR_T) (CHR "]")))) - (else (if (i32.eq $c0 (CHR "{")) - (then (return ($read_seq $str (global.get $HASHMAP_T) (CHR "}")))) - (else (if (OR (i32.eq $c0 (CHR ")")) - (i32.eq $c0 (CHR "]")) - (i32.eq $c0 (CHR "}"))) - (then - ($THROW_STR_1 "unexpected '%c'" $c0) - (return 0)) - (else - (return ($STRING (global.get $SYMBOL_T) $tok)))) - )))))))))))))))))))))))))))))))) - 0 ;; not reachable - ) - - (func $read_str (param $str i32) (result i32) - (global.set $read_index 0) - ($read_form $str) - ) - - (export "read_str" (func $read_str)) - -) +(module $reader + + ;; TODO: global warning + (global $token_buf (mut i32) 0) + (global $read_index (mut i32) 0) + + (func $skip_spaces (param $str i32) (result i32) + (LET $found 0 + $c (i32.load8_u (i32.add $str (global.get $read_index)))) + (block $done + (loop $loop + ;;; while (c == ' ' || c == ',' || c == '\n') + (br_if $done (AND (i32.ne $c (CHR " ")) + (i32.ne $c (CHR ",")) + (i32.ne $c (CHR "\n")))) + (local.set $found 1) + ;;; c=str[++(*index)] + (global.set $read_index (i32.add (global.get $read_index) 1)) + (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) + (br $loop) + ) + ) +;; ($debug ">>> skip_spaces:" $found) + $found + ) + + (func $skip_to_eol (param $str i32) (result i32) + (LET $found 0 + $c (i32.load8_u (i32.add $str (global.get $read_index)))) + (if (i32.eq $c (CHR ";")) + (then + (local.set $found 1) + (block $done + (loop $loop + ;;; c=str[++(*index)] + (global.set $read_index (i32.add (global.get $read_index) 1)) + (local.set $c (i32.load8_u (i32.add $str + (global.get $read_index)))) + ;;; while (c != '\0' && c != '\n') + (br_if $loop (AND (i32.ne $c (CHR "\x00")) + (i32.ne $c (CHR "\n")))) + ) + ))) +;; ($debug ">>> skip_to_eol:" $found) + $found + ) + + (func $skip_spaces_comments (param $str i32) + (loop $loop + ;; skip spaces + (br_if $loop ($skip_spaces $str)) + ;; skip comments + (br_if $loop ($skip_to_eol $str)) + ) + ) + + (func $read_token (param $str i32) (result i32) + (LET $token_index 0 + $isstring 0 + $instring 0 + $escaped 0 + $c 0) + + ($skip_spaces_comments $str) + + ;; read first character + ;;; c=str[++(*index)] + (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) + (global.set $read_index (i32.add (global.get $read_index) 1)) + ;; read first character + ;;; token[token_index++] = c + (i32.store8 (i32.add (global.get $token_buf) $token_index) $c) + (local.set $token_index (i32.add $token_index 1)) + ;; single/double character token + (if (OR (i32.eq $c (CHR "(")) + (i32.eq $c (CHR ")")) + (i32.eq $c (CHR "[")) + (i32.eq $c (CHR "]")) + (i32.eq $c (CHR "{")) + (i32.eq $c (CHR "}")) + (i32.eq $c (CHR "'")) + (i32.eq $c (CHR "`")) + (i32.eq $c (CHR "@")) + (AND (i32.eq $c (CHR "~")) + (i32.ne (i32.load8_u (i32.add $str (global.get $read_index))) + (CHR "@")))) + + (then + ;; continue + (nop)) + (else + ;;; if (c == '"') isstring = true + (local.set $isstring (i32.eq $c (CHR "\""))) + (local.set $instring $isstring) + (block $done + (loop $loop + ;; peek at next character + ;;; c = str[*index] + (local.set $c (i32.load8_u + (i32.add $str (global.get $read_index)))) + ;;; if (c == '\0') break + (br_if $done (i32.eq $c 0)) + ;;; if (!isstring) + (if (i32.eqz $isstring) + (then + ;; next character is token delimiter + (br_if $done (OR (i32.eq $c (CHR "(")) + (i32.eq $c (CHR ")")) + (i32.eq $c (CHR "[")) + (i32.eq $c (CHR "]")) + (i32.eq $c (CHR "{")) + (i32.eq $c (CHR "}")) + (i32.eq $c (CHR " ")) + (i32.eq $c (CHR ",")) + (i32.eq $c (CHR "\n")))))) + ;; read next character + ;;; token[token_index++] = str[(*index)++] + (i32.store8 (i32.add (global.get $token_buf) $token_index) + (i32.load8_u + (i32.add $str (global.get $read_index)))) + (local.set $token_index (i32.add $token_index 1)) + (global.set $read_index (i32.add (global.get $read_index) 1)) + ;;; if (token[0] == '~' && token[1] == '@') break + (br_if $done (AND (i32.eq (i32.load8_u + (i32.add (global.get $token_buf) 0)) + (CHR "~")) + (i32.eq (i32.load8_u + (i32.add (global.get $token_buf) 1)) + (CHR "@")))) + + ;;; if ((!isstring) || escaped) + (if (OR (i32.eqz $isstring) $escaped) + (then + (local.set $escaped 0) + (br $loop))) + (if (i32.eq $c (CHR "\\")) + (local.set $escaped 1)) + (if (i32.eq $c (CHR "\"")) + (then + (local.set $instring 0) + (br $done))) + (br $loop) + ) + ) + + (if (AND $isstring $instring) + (then + ($THROW_STR_0 "expected '\"', got EOF") + (return 0))))) + + ;;; token[token_index] = '\0' + (i32.store8 (i32.add (global.get $token_buf) $token_index) 0) + (global.get $token_buf) + ) + + (func $read_seq (param $str i32 $type i32 $end i32) (result i32) + (LET $res ($MAP_LOOP_START $type) + $val2 0 + $val3 0 + $c 0 + ;; MAP_LOOP stack + $ret $res + $empty $res + $current $res) + + ;; READ_SEQ_LOOP + (block $done + (loop $loop + ($skip_spaces_comments $str) + + ;; peek at next character + ;;; c = str[*index] + (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) + (if (i32.eq $c (CHR "\x00")) + (then + ($THROW_STR_0 "unexpected EOF") + (br $done))) + (if (i32.eq $c $end) + (then + ;; read next character + ;;; c = str[(*index)++] + (local.set $c (i32.load8_u (i32.add $str (global.get $read_index)))) + (global.set $read_index (i32.add (global.get $read_index) 1)) + (br $done))) + + ;; value (or key for hash-maps) + (local.set $val2 ($read_form $str)) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $val2) + (br $done))) + + ;; if this is a hash-map, READ_FORM again + (if (i32.eq $type (global.get $HASHMAP_T)) + (local.set $val3 ($read_form $str))) + + ;; update the return sequence structure + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (br $loop) + ) + ) + + ;; MAP_LOOP_DONE + $ret + ) + + (func $read_macro (param $str i32 $sym i32 $with_meta i32) (result i32) + (LET $first ($STRING (global.get $SYMBOL_T) $sym) + $second ($read_form $str) + $third 0 + $res $second) + (if (global.get $error_type) (return $res)) + (if (i32.eqz $with_meta) + (then + (local.set $res ($LIST2 $first $second))) + (else + (local.set $third ($read_form $str)) + (local.set $res ($LIST3 $first $third $second)) + ;; release values, list has ownership + ($RELEASE $third))) + ;; release values, list has ownership + ($RELEASE $second) + ($RELEASE $first) + $res + ) + + (func $read_form (param $str i32) (result i32) + (LET $tok 0 $c0 0 $c1 0 $res 0 $slen 0) + + (if (global.get $error_type) (return 0)) + + (local.set $tok ($read_token $str)) + + (if (global.get $error_type) (return 0)) + ;;($printf_1 ">>> read_form 1: %s\n" $tok) + ;;; c0 = token[0] + (local.set $c0 (i32.load8_u $tok)) + (local.set $c1 (i32.load8_u (i32.add $tok 1))) + + (if (i32.eq $c0 0) + (then + (return ($INC_REF (global.get $NIL)))) + (else (if (OR (AND (i32.ge_u $c0 (CHR "0")) + (i32.le_u $c0 (CHR "9"))) + (AND (i32.eq $c0 (CHR "-")) + (i32.ge_u $c1 (CHR "0")) + (i32.le_u $c1 (CHR "9")))) + (then + (return ($INTEGER ($atoi $tok)))) + (else (if (i32.eq $c0 (CHR ":")) + (then + (i32.store8 $tok (CHR "\x7f")) + (return ($STRING (global.get $STRING_T) $tok))) + (else (if (i32.eq $c0 (CHR "\"")) + (then + (local.set $slen ($strlen (i32.add $tok 1))) + (if (i32.ne (i32.load8_u (i32.add $tok $slen)) (CHR "\"")) + (then + ($THROW_STR_0 "expected '\"', got EOF") + (return 0)) + (else + ;; unescape backslashes, quotes, and newlines + ;; remove the trailing quote + (i32.store8 (i32.add $tok $slen) (CHR "\x00")) + (local.set $tok (i32.add $tok 1)) + (drop ($REPLACE3 0 $tok + "\\\"" "\"" + "\\n" "\n" + "\\\\" "\\")) + (return ($STRING (global.get $STRING_T) $tok))))) + (else (if (i32.eqz ($strcmp "nil" $tok)) + (then (return ($INC_REF (global.get $NIL)))) + (else (if (i32.eqz ($strcmp "false" $tok)) + (then (return ($INC_REF (global.get $FALSE)))) + (else (if (i32.eqz ($strcmp "true" $tok)) + (then (return ($INC_REF (global.get $TRUE)))) + (else (if (i32.eqz ($strcmp "'" $tok)) + (then (return ($read_macro $str "quote" 0))) + (else (if (i32.eqz ($strcmp "`" $tok)) + (then (return ($read_macro $str "quasiquote" 0))) + (else (if (i32.eqz ($strcmp "~@" $tok)) + (then (return ($read_macro $str "splice-unquote" 0))) + (else (if (i32.eqz ($strcmp "~" $tok)) + (then (return ($read_macro $str "unquote" 0))) + (else (if (i32.eqz ($strcmp "^" $tok)) + (then (return ($read_macro $str "with-meta" 1))) + (else (if (i32.eqz ($strcmp "@" $tok)) + (then (return ($read_macro $str "deref" 0))) + (else (if (i32.eq $c0 (CHR "(")) + (then (return ($read_seq $str (global.get $LIST_T) (CHR ")")))) + (else (if (i32.eq $c0 (CHR "[")) + (then (return ($read_seq $str (global.get $VECTOR_T) (CHR "]")))) + (else (if (i32.eq $c0 (CHR "{")) + (then (return ($read_seq $str (global.get $HASHMAP_T) (CHR "}")))) + (else (if (OR (i32.eq $c0 (CHR ")")) + (i32.eq $c0 (CHR "]")) + (i32.eq $c0 (CHR "}"))) + (then + ($THROW_STR_1 "unexpected '%c'" $c0) + (return 0)) + (else + (return ($STRING (global.get $SYMBOL_T) $tok)))) + )))))))))))))))))))))))))))))))) + 0 ;; not reachable + ) + + (func $read_str (param $str i32) (result i32) + (global.set $read_index 0) + ($read_form $str) + ) + + (export "read_str" (func $read_str)) + +) diff --git a/impls/wasm/run b/impls/wasm/run index 7fdf5272e4..273c41170e 100755 --- a/impls/wasm/run +++ b/impls/wasm/run @@ -1,20 +1,20 @@ -#!/bin/bash -STEP=${STEP:-stepA_mal} -case "${wasm_MODE}" in -wasmtime) - exec wasmtime --dir=./ --dir=../ --dir=/ $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; -lucet) - exec lucet-wasi --dir=./:./ --dir=../:../ --dir=/:/ $(dirname $0)/${STEP:-stepA_mal}.so -- "${@}" ;; -wasmer) - exec wasmer run --dir=./ --dir=../ --dir=/ $(dirname $0)/${STEP:-stepA_mal}.wasm -- "${@}" ;; -warpy) - exec warpy --argv --memory-pages 256 $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; -wax) - exec wax $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; -wace_libc) - exec wace $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; -wace_fooboot) - echo >&2 "wace_fooboot mode not yet supported" ;; -node|js|*) - exec ./run.js $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; -esac +#!/bin/bash +STEP=${STEP:-stepA_mal} +case "${wasm_MODE}" in +wasmtime) + exec wasmtime --dir=./ --dir=../ --dir=/ $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; +lucet) + exec lucet-wasi --dir=./:./ --dir=../:../ --dir=/:/ $(dirname $0)/${STEP:-stepA_mal}.so -- "${@}" ;; +wasmer) + exec wasmer run --dir=./ --dir=../ --dir=/ $(dirname $0)/${STEP:-stepA_mal}.wasm -- "${@}" ;; +warpy) + exec warpy --argv --memory-pages 256 $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; +wax) + exec wax $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; +wace_libc) + exec wace $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; +wace_fooboot) + echo >&2 "wace_fooboot mode not yet supported" ;; +node|js|*) + exec ./run.js $(dirname $0)/${STEP:-stepA_mal}.wasm "${@}" ;; +esac diff --git a/impls/wasm/run.js b/impls/wasm/run.js index 2deaa5e53c..e3bd6c2fb1 100755 --- a/impls/wasm/run.js +++ b/impls/wasm/run.js @@ -1,156 +1,156 @@ -#!/usr/bin/env node - -// Copyright Joel Martin -// License MIT - -const { promisify } = require('util') -const fs = require('fs') -const readFile = promisify(fs.readFile) -const assert = require('assert') -const { TextDecoder, TextEncoder } = require('text-encoding') -const node_readline = require('./node_readline.js') - -assert('WebAssembly' in global, 'WebAssembly not detected') - -// -// Memory interaction utilities -// - -// Convert node Buffer to Uint8Array -function toUint8Array(buf) { - let u = new Uint8Array(buf.length) - for (let i = 0; i < buf.length; ++i) { - u[i] = buf[i] - } - return u -} - -// Read null terminated string out of webassembly memory -function get_string(memory, addr) { - //console.warn("get_string:", addr) - let u8 = new Uint8Array(memory.buffer, addr) - let length = u8.findIndex(e => e == 0) - let bytes = new Uint8Array(memory.buffer, addr, length) - let str = new TextDecoder('utf8').decode(bytes) - return str -} - -// Write null terminated string into webassembly memory -function put_string(memory, addr, str, max_length) { - let buf8 = new Uint8Array(memory.buffer, addr) - - let bytes = new TextEncoder('utf8').encode(str) - if (max_length && bytes.length > max_length) { - bytes = bytes.slice(0, max_length) - } - - buf8.set(bytes, 0) - buf8[bytes.length] = 0 // null terminator - return bytes.length+1 -} - -// Put argv structure at beginning of memory -function marshal_argv(memory, offset, args) { - let view = new DataView(memory.buffer, offset) - let buf8 = new Uint8Array(memory.buffer, offset) - - let stringStart = (args.length + 1) * 4 - for (let i = 0; i < args.length; i++) { - let len = put_string(memory, stringStart, args[i]) - view.setUint32(i*4, stringStart, true) - stringStart = stringStart + len - } - view.setUint32(args.length*4, 0, true) - return offset + stringStart // start of free memory -} - -// Based on: -// https://gist.github.com/kripken/59c67556dc03bb6d57052fedef1e61ab - -// Loads a WebAssembly dynamic library, returns a promise. -async function loadWebAssembly(filename, args) { - // Fetch the file and compile it - const wasm_str = await readFile(filename) - const wasm_bin = toUint8Array(wasm_str) - const module = await WebAssembly.compile(wasm_bin) - let memory = new WebAssembly.Memory({ initial: 256 }) - // Core imports - function printline(addr, stream) { - console.log(get_string(memory, addr).replace(/\n$/, '')) - } - - // Returns addr on success and -1 on failure - // Truncates to max_length - function readline(prompt, addr, max_length) { - let line = node_readline.readline(get_string(memory, prompt)) - if (line === null) { return 0 } - put_string(memory, addr, line, max_length) - return 1 - } - - function read_file(path_addr, buf) { - let path = get_string(memory, path_addr) - let contents = fs.readFileSync(path, 'utf8') - return put_string(memory, buf, contents) - } - - function get_time_ms() { - // subtract 30 years to make sure it fits into i32 without - // wrapping or becoming negative - return (new Date()).getTime() - 0x38640900 - } - - // Marshal arguments - const memoryStart = 0 - let memoryBase = marshal_argv(memory, memoryStart, args) - memoryBase = memoryBase + (8 - (memoryBase % 8)) - - // Create the imports for the module, including the - // standard dynamic library imports - imports = {} - imports.env = {} - imports.env.exit = process.exit - imports.env.printline = printline - imports.env.readline = readline - imports.env.read_file = read_file - imports.env.get_time_ms = get_time_ms - - imports.env.stdout = 0 - imports.env.fputs = printline - - imports.env.memory = memory - imports.env.memoryBase = memoryBase - imports.env.table = new WebAssembly.Table({ initial: 0, element: 'anyfunc' }) - imports.env.tableBase = imports.env.tableBase || 0 - // Create the instance. - return [new WebAssembly.Instance(module, imports), args.length, 0] -} - -async function main() { - assert(process.argv.length >= 3, - 'Usage: ./run.js prog.wasm [ARGS...]') - - const wasm = process.argv[2] - const args = process.argv.slice(2) - const [instance, argc, argv] = await loadWebAssembly(wasm, args) - - let exports = instance.exports - assert(exports, 'no exports found') - assert('_main' in exports, '_main not found in wasm module exports') - if ('__post_instantiate' in exports) { - //console.warn('calling exports.__post_instantiate()') - exports['__post_instantiate']() - } - //console.warn(`calling exports._main(${argc}, ${argv})`) - let start = new Date() - let res = exports['_main'](argc, argv) - let end = new Date() - //console.warn('runtime: ' + (end-start) + 'ms') - process.exit(res) -} - -if (module.parent) { - module.exports.loadWebAssembly = loadWebAssembly -} else { - main() -} +#!/usr/bin/env node + +// Copyright Joel Martin +// License MIT + +const { promisify } = require('util') +const fs = require('fs') +const readFile = promisify(fs.readFile) +const assert = require('assert') +const { TextDecoder, TextEncoder } = require('text-encoding') +const node_readline = require('./node_readline.js') + +assert('WebAssembly' in global, 'WebAssembly not detected') + +// +// Memory interaction utilities +// + +// Convert node Buffer to Uint8Array +function toUint8Array(buf) { + let u = new Uint8Array(buf.length) + for (let i = 0; i < buf.length; ++i) { + u[i] = buf[i] + } + return u +} + +// Read null terminated string out of webassembly memory +function get_string(memory, addr) { + //console.warn("get_string:", addr) + let u8 = new Uint8Array(memory.buffer, addr) + let length = u8.findIndex(e => e == 0) + let bytes = new Uint8Array(memory.buffer, addr, length) + let str = new TextDecoder('utf8').decode(bytes) + return str +} + +// Write null terminated string into webassembly memory +function put_string(memory, addr, str, max_length) { + let buf8 = new Uint8Array(memory.buffer, addr) + + let bytes = new TextEncoder('utf8').encode(str) + if (max_length && bytes.length > max_length) { + bytes = bytes.slice(0, max_length) + } + + buf8.set(bytes, 0) + buf8[bytes.length] = 0 // null terminator + return bytes.length+1 +} + +// Put argv structure at beginning of memory +function marshal_argv(memory, offset, args) { + let view = new DataView(memory.buffer, offset) + let buf8 = new Uint8Array(memory.buffer, offset) + + let stringStart = (args.length + 1) * 4 + for (let i = 0; i < args.length; i++) { + let len = put_string(memory, stringStart, args[i]) + view.setUint32(i*4, stringStart, true) + stringStart = stringStart + len + } + view.setUint32(args.length*4, 0, true) + return offset + stringStart // start of free memory +} + +// Based on: +// https://gist.github.com/kripken/59c67556dc03bb6d57052fedef1e61ab + +// Loads a WebAssembly dynamic library, returns a promise. +async function loadWebAssembly(filename, args) { + // Fetch the file and compile it + const wasm_str = await readFile(filename) + const wasm_bin = toUint8Array(wasm_str) + const module = await WebAssembly.compile(wasm_bin) + let memory = new WebAssembly.Memory({ initial: 256 }) + // Core imports + function printline(addr, stream) { + console.log(get_string(memory, addr).replace(/\n$/, '')) + } + + // Returns addr on success and -1 on failure + // Truncates to max_length + function readline(prompt, addr, max_length) { + let line = node_readline.readline(get_string(memory, prompt)) + if (line === null) { return 0 } + put_string(memory, addr, line, max_length) + return 1 + } + + function read_file(path_addr, buf) { + let path = get_string(memory, path_addr) + let contents = fs.readFileSync(path, 'utf8') + return put_string(memory, buf, contents) + } + + function get_time_ms() { + // subtract 30 years to make sure it fits into i32 without + // wrapping or becoming negative + return (new Date()).getTime() - 0x38640900 + } + + // Marshal arguments + const memoryStart = 0 + let memoryBase = marshal_argv(memory, memoryStart, args) + memoryBase = memoryBase + (8 - (memoryBase % 8)) + + // Create the imports for the module, including the + // standard dynamic library imports + imports = {} + imports.env = {} + imports.env.exit = process.exit + imports.env.printline = printline + imports.env.readline = readline + imports.env.read_file = read_file + imports.env.get_time_ms = get_time_ms + + imports.env.stdout = 0 + imports.env.fputs = printline + + imports.env.memory = memory + imports.env.memoryBase = memoryBase + imports.env.table = new WebAssembly.Table({ initial: 0, element: 'anyfunc' }) + imports.env.tableBase = imports.env.tableBase || 0 + // Create the instance. + return [new WebAssembly.Instance(module, imports), args.length, 0] +} + +async function main() { + assert(process.argv.length >= 3, + 'Usage: ./run.js prog.wasm [ARGS...]') + + const wasm = process.argv[2] + const args = process.argv.slice(2) + const [instance, argc, argv] = await loadWebAssembly(wasm, args) + + let exports = instance.exports + assert(exports, 'no exports found') + assert('_main' in exports, '_main not found in wasm module exports') + if ('__post_instantiate' in exports) { + //console.warn('calling exports.__post_instantiate()') + exports['__post_instantiate']() + } + //console.warn(`calling exports._main(${argc}, ${argv})`) + let start = new Date() + let res = exports['_main'](argc, argv) + let end = new Date() + //console.warn('runtime: ' + (end-start) + 'ms') + process.exit(res) +} + +if (module.parent) { + module.exports.loadWebAssembly = loadWebAssembly +} else { + main() +} diff --git a/impls/wasm/step0_repl.wam b/impls/wasm/step0_repl.wam index 6814041b15..8506d5c3df 100644 --- a/impls/wasm/step0_repl.wam +++ b/impls/wasm/step0_repl.wam @@ -1,49 +1,49 @@ -(module $step0_repl - - ;; READ - (func $READ (param $str i32) (result i32) - $str - ) - - (func $EVAL (param $ast i32) (param $env i32) (result i32) - $ast - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - $ast - ) - - ;; REPL - (func $rep (param $line i32) (result i32) - ($PRINT ($EVAL ($READ $line) 0)) - ) - - (func $main (param $argc i32 $argv i32) (result i32) - ;; Constant location/value definitions - (LET $line (STATIC_ARRAY 201)) - - ;; DEBUG - ;;($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - ($printf_1 "%s\n" ($rep $line)) - (br $repl_loop) - ) - ) - - ($print "\n") - 0 - ) - - ;; init_memory is provided by mem.wam in later steps but we just - ;; printf in step0 so provide init_memory that just calls that - (func $init_memory - ($init_printf_mem) - ) -) - +(module $step0_repl + + ;; READ + (func $READ (param $str i32) (result i32) + $str + ) + + (func $EVAL (param $ast i32) (param $env i32) (result i32) + $ast + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + $ast + ) + + ;; REPL + (func $rep (param $line i32) (result i32) + ($PRINT ($EVAL ($READ $line) 0)) + ) + + (func $main (param $argc i32 $argv i32) (result i32) + ;; Constant location/value definitions + (LET $line (STATIC_ARRAY 201)) + + ;; DEBUG + ;;($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + ($printf_1 "%s\n" ($rep $line)) + (br $repl_loop) + ) + ) + + ($print "\n") + 0 + ) + + ;; init_memory is provided by mem.wam in later steps but we just + ;; printf in step0 so provide init_memory that just calls that + (func $init_memory + ($init_printf_mem) + ) +) + diff --git a/impls/wasm/step1_read_print.wam b/impls/wasm/step1_read_print.wam index 19e330d885..98f40f0598 100644 --- a/impls/wasm/step1_read_print.wam +++ b/impls/wasm/step1_read_print.wam @@ -1,81 +1,81 @@ -(module $step1_read_print - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - (func $EVAL (param $ast i32 $env i32) (result i32) - $ast - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv1 0 $mv2 0 $ms 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $mv2 ($EVAL $mv1 $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from MAL_READ - ($RELEASE $mv1) - $ms - ) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0) - - ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - -;; ($PR_MEMORY_RAW -;; (global.get $mem) (i32.add (global.get $mem) -;; (i32.mul (global.get $mem_unused_start) 4))) - - (drop ($STRING (global.get $STRING_T) "uvw")) - (drop ($STRING (global.get $STRING_T) "xyz")) - - ;;($PR_MEMORY -1 -1) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line 0)) - (if (global.get $error_type) - (then - ($printf_1 "Error: %s\n" (global.get $error_str)) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $step1_read_print + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL (param $ast i32 $env i32) (result i32) + $ast + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv1 0 $mv2 0 $ms 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $mv2 ($EVAL $mv1 $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0) + + ;; DEBUG +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + +;; ($PR_MEMORY_RAW +;; (global.get $mem) (i32.add (global.get $mem) +;; (i32.mul (global.get $mem_unused_start) 4))) + + (drop ($STRING (global.get $STRING_T) "uvw")) + (drop ($STRING (global.get $STRING_T) "xyz")) + + ;;($PR_MEMORY -1 -1) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line 0)) + (if (global.get $error_type) + (then + ($printf_1 "Error: %s\n" (global.get $error_str)) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/step2_eval.wam b/impls/wasm/step2_eval.wam index fdf161a8e3..a5ca57c2d7 100644 --- a/impls/wasm/step2_eval.wam +++ b/impls/wasm/step2_eval.wam @@ -1,233 +1,233 @@ -(module $step2_eval - - (global $repl_env (mut i32) (i32.const 0)) - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - (func $EVAL_AST (param $ast i32 $env i32) (result i32) - (local $res2 i64) - (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 - $ret 0 $empty 0 $current 0) - - (if (global.get $error_type) (return 0)) - (local.set $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (local.set $res2 ($HASHMAP_GET $env $ast)) - (local.set $res (i32.wrap_i64 $res2)) - (local.set $found (i32.wrap_i64 (i64.shr_u $res2 - (i64.const 32)))) - (if (i32.eqz $found) - ($THROW_STR_1 "'%s' not found" - ($to_String $ast))) - (local.set $res ($INC_REF $res)) - - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (local.set $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (br_if $done (i32.eq ($VAL0 $ast) 0)) - - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) - (else - (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (local.set $val2 $res) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $res) - (local.set $res 0) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $val3 $val2) - (local.set $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $val2)))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $ast ($MEM_VAL0_ptr $ast)) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (local.set $res $ret) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (local.set $res ($INC_REF $ast)) - ) - - $res - ) - - (type $fnT (func (param i32) (result i32))) - - (table funcref - (elem - $add $subtract $multiply $divide)) - - (func $EVAL (param $ast i32 $env i32) (result i32) - (LET $res 0 - $ftype 0 $f_args 0 $f 0 $args 0) - - (local.set $f_args 0) - (local.set $f 0) - (local.set $args 0) - - (if (global.get $error_type) (return 0)) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (return ($EVAL_AST $ast $env))) - - ;; APPLY_LIST - (if ($EMPTY_Q $ast) - (return ($INC_REF $ast))) - - ;; EVAL_INVOKE - (local.set $res ($EVAL_AST $ast $env)) - (local.set $f_args $res) - - ;; if error, return f/args for release by caller - (if (global.get $error_type) - (return $f_args)) - - (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest - (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))) - (else - ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (local.set $res 0))) - - ($RELEASE $f_args) - - $res - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv1 0 $mv2 0 $ms 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $mv2 ($EVAL $mv1 $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from MAL_READ and EVAL - ($RELEASE $mv2) - ($RELEASE $mv1) - $ms - ) - - (func $add (param $args i32) (result i32) - ($INTEGER - (i32.add ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $subtract (param $args i32) (result i32) - ($INTEGER - (i32.sub ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $multiply (param $args i32) (result i32) - ($INTEGER - (i32.mul ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $divide (param $args i32) (result i32) - ($INTEGER - (i32.div_s ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0) - - ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - - (global.set $repl_env ($HASHMAP)) - (local.set $repl_env (global.get $repl_env)) - - (local.set $repl_env ($ASSOC1_S $repl_env "+" ($FUNCTION 0))) - (local.set $repl_env ($ASSOC1_S $repl_env "-" ($FUNCTION 1))) - (local.set $repl_env ($ASSOC1_S $repl_env "*" ($FUNCTION 2))) - (local.set $repl_env ($ASSOC1_S $repl_env "/" ($FUNCTION 3))) - - ;;($PR_MEMORY -1 -1) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line $repl_env)) - (if (global.get $error_type) - (then - ($printf_1 "Error: %s\n" (global.get $error_str)) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $step2_eval + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32 $env i32) (result i32) + (local $res2 i64) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) + + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (local.set $res2 ($HASHMAP_GET $env $ast)) + (local.set $res (i32.wrap_i64 $res2)) + (local.set $found (i32.wrap_i64 (i64.shr_u $res2 + (i64.const 32)))) + (if (i32.eqz $found) + ($THROW_STR_1 "'%s' not found" + ($to_String $ast))) + (local.set $res ($INC_REF $res)) + + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (local.set $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (br_if $done (i32.eq ($VAL0 $ast) 0)) + + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $res) + (local.set $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (local.set $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (local.set $res ($INC_REF $ast)) + ) + + $res + ) + + (type $fnT (func (param i32) (result i32))) + + (table funcref + (elem + $add $subtract $multiply $divide)) + + (func $EVAL (param $ast i32 $env i32) (result i32) + (LET $res 0 + $ftype 0 $f_args 0 $f 0 $args 0) + + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) + + (if (global.get $error_type) (return 0)) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (return ($EVAL_AST $ast $env))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (return ($INC_REF $ast))) + + ;; EVAL_INVOKE + (local.set $res ($EVAL_AST $ast $env)) + (local.set $f_args $res) + + ;; if error, return f/args for release by caller + (if (global.get $error_type) + (return $f_args)) + + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value + + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (local.set $res 0))) + + ($RELEASE $f_args) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv1 0 $mv2 0 $ms 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $mv2 ($EVAL $mv1 $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from MAL_READ and EVAL + ($RELEASE $mv2) + ($RELEASE $mv1) + $ms + ) + + (func $add (param $args i32) (result i32) + ($INTEGER + (i32.add ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $subtract (param $args i32) (result i32) + ($INTEGER + (i32.sub ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $multiply (param $args i32) (result i32) + ($INTEGER + (i32.mul ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $divide (param $args i32) (result i32) + ($INTEGER + (i32.div_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0) + + ;; DEBUG +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + + (global.set $repl_env ($HASHMAP)) + (local.set $repl_env (global.get $repl_env)) + + (local.set $repl_env ($ASSOC1_S $repl_env "+" ($FUNCTION 0))) + (local.set $repl_env ($ASSOC1_S $repl_env "-" ($FUNCTION 1))) + (local.set $repl_env ($ASSOC1_S $repl_env "*" ($FUNCTION 2))) + (local.set $repl_env ($ASSOC1_S $repl_env "/" ($FUNCTION 3))) + + ;;($PR_MEMORY -1 -1) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) + (then + ($printf_1 "Error: %s\n" (global.get $error_str)) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/step3_env.wam b/impls/wasm/step3_env.wam index c756dff984..81a37dc9e9 100644 --- a/impls/wasm/step3_env.wam +++ b/impls/wasm/step3_env.wam @@ -1,281 +1,281 @@ -(module $step3_env - - (global $repl_env (mut i32) (i32.const 0)) - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - (func $EVAL_AST (param $ast i32 $env i32) (result i32) - (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 - $ret 0 $empty 0 $current 0) - - (if (global.get $error_type) (return 0)) - (local.set $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (local.set $res ($ENV_GET $env $ast)) - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (local.set $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (br_if $done (i32.eq ($VAL0 $ast) 0)) - - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) - (else - (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (local.set $val2 $res) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $res) - (local.set $res 0) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $val3 $val2) - (local.set $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $val2)))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $ast ($MEM_VAL0_ptr $ast)) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (local.set $res $ret) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (local.set $res ($INC_REF $ast)) - ) - - $res - ) - - (type $fnT (func (param i32) (result i32))) - - (table funcref - (elem - $add $subtract $multiply $divide)) - - (func $MAL_GET_A1 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) - (func $MAL_GET_A2 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (func $MAL_GET_A3 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - (func $EVAL (param $ast i32 $env i32) (result i32) - (LET $res 0 - $ftype 0 $f_args 0 $f 0 $args 0 - $a0 0 $a0sym 0 $a1 0 $a2 0 - $let_env 0) - - (local.set $f_args 0) - (local.set $f 0) - (local.set $args 0) - - (if (global.get $error_type) (return 0)) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (return ($EVAL_AST $ast $env))) - - ;; APPLY_LIST - (if ($EMPTY_Q $ast) - (return ($INC_REF $ast))) - - (local.set $a0 ($MEM_VAL1_ptr $ast)) - (local.set $a0sym "") - (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) - (local.set $a0sym ($to_String $a0))) - - (if (i32.eqz ($strcmp "def!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - (if (global.get $error_type) (return $res)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res))) - (else (if (i32.eqz ($strcmp "let*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - - ;; create new environment with outer as current environment - (local.set $let_env ($ENV_NEW $env)) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $a1))) - ;; eval current A1 odd element - (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) - $let_env)) - - (br_if $done (global.get $error_type)) - - ;; set key/value in the let environment - (local.set $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) - ;; release our use, ENV_SET took ownership - ($RELEASE $res) - - ;; skip to the next pair of a1 elements - (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) - (br $loop) - ) - ) - (local.set $res ($EVAL $a2 $let_env)) - ;; EVAL_RETURN - ($RELEASE $let_env)) - (else - ;; EVAL_INVOKE - (local.set $res ($EVAL_AST $ast $env)) - (local.set $f_args $res) - - ;; if error, return f/args for release by caller - (if (global.get $error_type) - (return $f_args)) - - (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest - (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))) - (else - ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (local.set $res 0))) - - ($RELEASE $f_args))))) - - $res - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv1 0 $mv2 0 $ms 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $mv2 ($EVAL $mv1 $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from MAL_READ and EVAL - ($RELEASE $mv2) - ($RELEASE $mv1) - $ms - ) - - (func $add (param $args i32) (result i32) - ($INTEGER - (i32.add ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $subtract (param $args i32) (result i32) - ($INTEGER - (i32.sub ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $multiply (param $args i32) (result i32) - ($INTEGER - (i32.mul ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $divide (param $args i32) (result i32) - ($INTEGER - (i32.div_s ($VAL0 ($MEM_VAL1_ptr $args)) - ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) - (func $pr_memory (param $args i32) (result i32) - ($PR_MEMORY -1 -1) - ($INC_REF (global.get $NIL))) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0) - - ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - - (global.set $repl_env ($ENV_NEW (global.get $NIL))) - (local.set $repl_env (global.get $repl_env)) - - (drop ($ENV_SET_S $repl_env "+" ($FUNCTION 0))) - (drop ($ENV_SET_S $repl_env "-" ($FUNCTION 1))) - (drop ($ENV_SET_S $repl_env "*" ($FUNCTION 2))) - (drop ($ENV_SET_S $repl_env "/" ($FUNCTION 3))) - - ;;($PR_MEMORY -1 -1) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line $repl_env)) - (if (global.get $error_type) - (then - ($printf_1 "Error: %s\n" (global.get $error_str)) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $step3_env + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32 $env i32) (result i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) + + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (local.set $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (local.set $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (br_if $done (i32.eq ($VAL0 $ast) 0)) + + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $res) + (local.set $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (local.set $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (local.set $res ($INC_REF $ast)) + ) + + $res + ) + + (type $fnT (func (param i32) (result i32))) + + (table funcref + (elem + $add $subtract $multiply $divide)) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $ast i32 $env i32) (result i32) + (LET $res 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0 + $let_env 0) + + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) + + (if (global.get $error_type) (return 0)) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (return ($EVAL_AST $ast $env))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (return ($INC_REF $ast))) + + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (if (global.get $error_type) (return $res)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res))) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (local.set $let_env ($ENV_NEW $env)) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $a1))) + ;; eval current A1 odd element + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) + $let_env)) + + (br_if $done (global.get $error_type)) + + ;; set key/value in the let environment + (local.set $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + (local.set $res ($EVAL $a2 $let_env)) + ;; EVAL_RETURN + ($RELEASE $let_env)) + (else + ;; EVAL_INVOKE + (local.set $res ($EVAL_AST $ast $env)) + (local.set $f_args $res) + + ;; if error, return f/args for release by caller + (if (global.get $error_type) + (return $f_args)) + + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value + + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (local.set $res 0))) + + ($RELEASE $f_args))))) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv1 0 $mv2 0 $ms 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $mv2 ($EVAL $mv1 $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from MAL_READ and EVAL + ($RELEASE $mv2) + ($RELEASE $mv1) + $ms + ) + + (func $add (param $args i32) (result i32) + ($INTEGER + (i32.add ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $subtract (param $args i32) (result i32) + ($INTEGER + (i32.sub ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $multiply (param $args i32) (result i32) + ($INTEGER + (i32.mul ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $divide (param $args i32) (result i32) + ($INTEGER + (i32.div_s ($VAL0 ($MEM_VAL1_ptr $args)) + ($VAL0 ($MEM_VAL1_ptr ($MEM_VAL0_ptr $args)))))) + (func $pr_memory (param $args i32) (result i32) + ($PR_MEMORY -1 -1) + ($INC_REF (global.get $NIL))) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0) + + ;; DEBUG +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) + + (drop ($ENV_SET_S $repl_env "+" ($FUNCTION 0))) + (drop ($ENV_SET_S $repl_env "-" ($FUNCTION 1))) + (drop ($ENV_SET_S $repl_env "*" ($FUNCTION 2))) + (drop ($ENV_SET_S $repl_env "/" ($FUNCTION 3))) + + ;;($PR_MEMORY -1 -1) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) + (then + ($printf_1 "Error: %s\n" (global.get $error_str)) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/step4_if_fn_do.wam b/impls/wasm/step4_if_fn_do.wam index c984bf57e4..df6c924ca6 100644 --- a/impls/wasm/step4_if_fn_do.wam +++ b/impls/wasm/step4_if_fn_do.wam @@ -1,325 +1,325 @@ -(module $step4_if_fn_do - - (global $repl_env (mut i32) (i32.const 0)) - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - (func $EVAL_AST (param $ast i32 $env i32) (result i32) - (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 - $ret 0 $empty 0 $current 0) - - (if (global.get $error_type) (return 0)) - (local.set $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (local.set $res ($ENV_GET $env $ast)) - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (local.set $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (br_if $done (i32.eq ($VAL0 $ast) 0)) - - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) - (else - (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (local.set $val2 $res) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $res) - (local.set $res 0) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $val3 $val2) - (local.set $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $val2)))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $ast ($MEM_VAL0_ptr $ast)) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (local.set $res $ret) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (local.set $res ($INC_REF $ast)) - ) - - $res - ) - - (func $MAL_GET_A1 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) - (func $MAL_GET_A2 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (func $MAL_GET_A3 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - (func $EVAL (param $ast i32 $env i32) (result i32) - (LET $res 0 $el 0 - $ftype 0 $f_args 0 $f 0 $args 0 - $a0 0 $a0sym 0 $a1 0 $a2 0 $a3 0 - $let_env 0 $fn_env 0 $a 0) - - (local.set $f_args 0) - (local.set $f 0) - (local.set $args 0) - - (if (global.get $error_type) (return 0)) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (return ($EVAL_AST $ast $env))) - - ;; APPLY_LIST - (if ($EMPTY_Q $ast) - (return ($INC_REF $ast))) - - (local.set $a0 ($MEM_VAL1_ptr $ast)) - (local.set $a0sym "") - (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) - (local.set $a0sym ($to_String $a0))) - - (if (i32.eqz ($strcmp "def!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - (if (global.get $error_type) (return $res)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res))) - (else (if (i32.eqz ($strcmp "let*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - - ;; create new environment with outer as current environment - (local.set $let_env ($ENV_NEW $env)) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $a1))) - ;; eval current A1 odd element - (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) - $let_env)) - - (br_if $done (global.get $error_type)) - - ;; set key/value in the let environment - (local.set $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) - ;; release our use, ENV_SET took ownership - ($RELEASE $res) - - ;; skip to the next pair of a1 elements - (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) - (br $loop) - ) - ) - (local.set $res ($EVAL $a2 $let_env)) - ;; EVAL_RETURN - ($RELEASE $let_env)) - (else (if (i32.eqz ($strcmp "do" $a0sym)) - (then - (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env)) - (local.set $res ($LAST $el)) - ($RELEASE $el)) - (else (if (i32.eqz ($strcmp "if" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $res ($EVAL $a1 $env)) - - (if (global.get $error_type) - (then (nop)) - (else (if (OR (i32.eq $res (global.get $NIL)) - (i32.eq $res (global.get $FALSE))) - (then - ($RELEASE $res) - ;; if no false case (A3), return nil - (if (i32.lt_u ($COUNT $ast) 4) - (then - (local.set $res ($INC_REF (global.get $NIL)))) - (else - (local.set $a3 ($MAL_GET_A3 $ast)) - (local.set $res ($EVAL $a3 $env))))) - (else - ($RELEASE $res) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env))))))) - (else (if (i32.eqz ($strcmp "fn*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($ALLOC (global.get $MALFUNC_T) $a2 $a1 $env))) - (else - ;; EVAL_INVOKE - (local.set $res ($EVAL_AST $ast $env)) - (local.set $f_args $res) - - ;; if error, return f/args for release by caller - (if (global.get $error_type) - (return $f_args)) - - (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest - (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))) - ;; release f/args - ($RELEASE $f_args)) - (else (if (i32.eq $ftype (global.get $MALFUNC_T)) - (then - (local.set $fn_env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) - ($MEM_VAL1_ptr $f) $args)) - - ;; claim the AST before releasing the list containing it - (local.set $a ($MEM_VAL0_ptr $f)) - (drop ($INC_REF $a)) - - ;; release f/args - ($RELEASE $f_args) - - (local.set $res ($EVAL $a $fn_env)) - ;; EVAL_RETURN - ($RELEASE $fn_env) - ($RELEASE $a)) - (else - ;; create new environment using env and params stored in function - ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (local.set $res 0) - ($RELEASE $f_args))))))))))))))) - - $res - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $RE (param $line i32 $env i32) (result i32) - (LET $mv1 0 $res 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $res ($EVAL $mv1 $env)) - ) - - ;; release memory from MAL_READ - ($RELEASE $mv1) - $res - ) - - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv2 0 $ms 0) - (block $done - (local.set $mv2 ($RE $line $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from RE - ($RELEASE $mv2) - $ms - ) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 $ms 0) - - ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - - (global.set $repl_env ($ENV_NEW (global.get $NIL))) - (local.set $repl_env (global.get $repl_env)) - - ;; core.EXT: defined in wasm - ($add_core_ns $repl_env) - - ($checkpoint_user_memory) - - ;; core.mal: defined using the language itself - ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) - - ;;($PR_MEMORY -1 -1) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line $repl_env)) - (if (global.get $error_type) - (then - (if (i32.eq 2 (global.get $error_type)) - (then - (local.set $ms ($pr_str (global.get $error_val) 1)) - ($printf_1 "Error: %s\n" ($to_String $ms)) - ($RELEASE $ms) - ($RELEASE (global.get $error_val))) - (else - ($printf_1 "Error: %s\n" (global.get $error_str)))) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $step4_if_fn_do + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32 $env i32) (result i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) + + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (local.set $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (local.set $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (br_if $done (i32.eq ($VAL0 $ast) 0)) + + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $res) + (local.set $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (local.set $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (local.set $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $ast i32 $env i32) (result i32) + (LET $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0 $a3 0 + $let_env 0 $fn_env 0 $a 0) + + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) + + (if (global.get $error_type) (return 0)) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (return ($EVAL_AST $ast $env))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (return ($INC_REF $ast))) + + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (if (global.get $error_type) (return $res)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res))) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (local.set $let_env ($ENV_NEW $env)) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $a1))) + ;; eval current A1 odd element + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) + $let_env)) + + (br_if $done (global.get $error_type)) + + ;; set key/value in the let environment + (local.set $res ($ENV_SET $let_env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + (local.set $res ($EVAL $a2 $let_env)) + ;; EVAL_RETURN + ($RELEASE $let_env)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env)) + (local.set $res ($LAST $el)) + ($RELEASE $el)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) + + (if (global.get $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (local.set $res ($INC_REF (global.get $NIL)))) + (else + (local.set $a3 ($MAL_GET_A3 $ast)) + (local.set $res ($EVAL $a3 $env))))) + (else + ($RELEASE $res) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env))))))) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($ALLOC (global.get $MALFUNC_T) $a2 $a1 $env))) + (else + ;; EVAL_INVOKE + (local.set $res ($EVAL_AST $ast $env)) + (local.set $f_args $res) + + ;; if error, return f/args for release by caller + (if (global.get $error_type) + (return $f_args)) + + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value + + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))) + ;; release f/args + ($RELEASE $f_args)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) + (then + (local.set $fn_env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; claim the AST before releasing the list containing it + (local.set $a ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $a)) + + ;; release f/args + ($RELEASE $f_args) + + (local.set $res ($EVAL $a $fn_env)) + ;; EVAL_RETURN + ($RELEASE $fn_env) + ($RELEASE $a)) + (else + ;; create new environment using env and params stored in function + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (local.set $res 0) + ($RELEASE $f_args))))))))))))))) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (LET $mv1 0 $res 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv2 0 $ms 0) + (block $done + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 $ms 0) + + ;; DEBUG +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + + ($checkpoint_user_memory) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + + ;;($PR_MEMORY -1 -1) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) + (then + (if (i32.eq 2 (global.get $error_type)) + (then + (local.set $ms ($pr_str (global.get $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (global.get $error_val))) + (else + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/step5_tco.wam b/impls/wasm/step5_tco.wam index 1268d46b54..f21bb84d58 100644 --- a/impls/wasm/step5_tco.wam +++ b/impls/wasm/step5_tco.wam @@ -1,374 +1,374 @@ -(module $step5_tco - - (global $repl_env (mut i32) (i32.const 0)) - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 - $ret 0 $empty 0 $current 0) - - (if (global.get $error_type) (return 0)) - (local.set $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (local.set $res ($ENV_GET $env $ast)) - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (local.set $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (br_if $done (i32.eq ($VAL0 $ast) 0)) - - (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) - (else - (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (local.set $val2 $res) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $res) - (local.set $res 0) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $val3 $val2) - (local.set $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $val2)))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $ast ($MEM_VAL0_ptr $ast)) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (local.set $res $ret) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (local.set $res ($INC_REF $ast)) - ) - - $res - ) - - (func $MAL_GET_A1 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) - (func $MAL_GET_A2 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (func $MAL_GET_A3 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (LET $ast $orig_ast - $env $orig_env - $prev_ast 0 $prev_env 0 $res 0 $el 0 - $ftype 0 $f_args 0 $f 0 $args 0 - $a0 0 $a0sym 0 $a1 0 $a2 0) - - (block $EVAL_return - (loop $TCO_loop - - (local.set $f_args 0) - (local.set $f 0) - (local.set $args 0) - - (if (global.get $error_type) - (then - (local.set $res 0) - (br $EVAL_return))) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (then - (local.set $res ($EVAL_AST $ast $env 0)) - (br $EVAL_return))) - - ;; APPLY_LIST - (if ($EMPTY_Q $ast) - (then - (local.set $res ($INC_REF $ast)) - (br $EVAL_return))) - - (local.set $a0 ($MEM_VAL1_ptr $ast)) - (local.set $a0sym "") - (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) - (local.set $a0sym ($to_String $a0))) - - (if (i32.eqz ($strcmp "def!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - (br_if $EVAL_return (global.get $error_type)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res)) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "let*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - - ;; create new environment with outer as current environment - (local.set $prev_env $env) ;; save env for later release - (local.set $env ($ENV_NEW $env)) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $a1))) - ;; eval current A1 odd element - (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - - (br_if $done (global.get $error_type)) - - ;; set key/value in the let environment - (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) - ;; release our use, ENV_SET took ownership - ($RELEASE $res) - - ;; skip to the next pair of a1 elements - (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) - (br $loop) - ) - ) - - ;; release previous environment if not the current EVAL env - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - (local.set $ast $a2) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "do" $a0sym)) - (then - ;; EVAL the rest through second to last - (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (local.set $ast ($LAST $ast)) - ($RELEASE $ast) ;; we already own it via ast - ($RELEASE $el) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "if" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $res ($EVAL $a1 $env)) - - (if (global.get $error_type) - (then (nop)) - (else (if (OR (i32.eq $res (global.get $NIL)) - (i32.eq $res (global.get $FALSE))) - (then - ($RELEASE $res) - ;; if no false case (A3), return nil - (if (i32.lt_u ($COUNT $ast) 4) - (then - (local.set $res ($INC_REF (global.get $NIL))) - (br $EVAL_return)) - (else - (local.set $ast ($MAL_GET_A3 $ast))))) - (else - ($RELEASE $res) - (local.set $ast ($MAL_GET_A2 $ast)))))) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "fn*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($MALFUNC $a2 $a1 $env)) - (br $EVAL_return)) - (else - ;; EVAL_INVOKE - (local.set $res ($EVAL_AST $ast $env 0)) - (local.set $f_args $res) - - ;; if error, return f/args for release by caller - (if (global.get $error_type) - (then - (local.set $res $f_args) - (br $EVAL_return))) - - (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest - (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))) - ;; release f/args - ($RELEASE $f_args) - (br $EVAL_return)) - (else (if (i32.eq $ftype (global.get $MALFUNC_T)) - (then - ;; save the current environment for release - (local.set $prev_env $env) - ;; create new environment using env and params stored in function - (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) - ($MEM_VAL1_ptr $f) $args)) - - ;; release previous environment if not the current EVAL env - ;; because our new env refers to it and we no longer need to - ;; track it (since we are TCO recurring) - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - ;; claim the AST before releasing the list containing it - (local.set $ast ($MEM_VAL0_ptr $f)) - (drop ($INC_REF $ast)) - - ;; if we have already been here via TCO, release previous - ;; ast - ;; PEND_A_LV - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - - ;; release f/args - ($RELEASE $f_args) - - (br $TCO_loop)) - (else - ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (local.set $res 0) - ($RELEASE $f_args) - (br $EVAL_return))))))))))))))) - - ) ;; end of TCO_loop - ) ;; end of EVAL_return - - ;; EVAL_RETURN - (if (i32.ne $env $orig_env) ($RELEASE $env)) - (if $prev_ast ($RELEASE $prev_ast)) - - $res - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $RE (param $line i32 $env i32) (result i32) - (LET $mv1 0 $res 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $res ($EVAL $mv1 $env)) - ) - - ;; release memory from MAL_READ - ($RELEASE $mv1) - $res - ) - - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv2 0 $ms 0) - (block $done - (local.set $mv2 ($RE $line $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from RE - ($RELEASE $mv2) - $ms - ) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 $ms 0) - - ;; DEBUG -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - - (global.set $repl_env ($ENV_NEW (global.get $NIL))) - (local.set $repl_env (global.get $repl_env)) - - ;; core.EXT: defined in wasm - ($add_core_ns $repl_env) - - ($checkpoint_user_memory) - - ;; core.mal: defined using the language itself - ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) - - ;;($PR_MEMORY -1 -1) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line $repl_env)) - (if (global.get $error_type) - (then - (if (i32.eq 2 (global.get $error_type)) - (then - (local.set $ms ($pr_str (global.get $error_val) 1)) - ($printf_1 "Error: %s\n" ($to_String $ms)) - ($RELEASE $ms) - ($RELEASE (global.get $error_val))) - (else - ($printf_1 "Error: %s\n" (global.get $error_str)))) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $step5_tco + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) + + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (local.set $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (local.set $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (br_if $done (i32.eq ($VAL0 $ast) 0)) + + (if $skiplast + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) + + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $res) + (local.set $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (local.set $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (local.set $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (LET $ast $orig_ast + $env $orig_env + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0) + + (block $EVAL_return + (loop $TCO_loop + + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) + + (if (global.get $error_type) + (then + (local.set $res 0) + (br $EVAL_return))) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (then + (local.set $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (then + (local.set $res ($INC_REF $ast)) + (br $EVAL_return))) + + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $a1))) + ;; eval current A1 odd element + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (br_if $done (global.get $error_type)) + + ;; set key/value in the let environment + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + (local.set $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) + + (if (global.get $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (local.set $res ($INC_REF (global.get $NIL))) + (br $EVAL_return)) + (else + (local.set $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (local.set $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) + + ;; if error, return f/args for release by caller + (if (global.get $error_type) + (then + (local.set $res $f_args) + (br $EVAL_return))) + + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value + + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) + (then + ;; save the current environment for release + (local.set $prev_env $env) + ;; create new environment using env and params stored in function + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (local.set $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (local.set $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (LET $mv1 0 $res 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv2 0 $ms 0) + (block $done + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 $ms 0) + + ;; DEBUG +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + + ($checkpoint_user_memory) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + + ;;($PR_MEMORY -1 -1) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) + (then + (if (i32.eq 2 (global.get $error_type)) + (then + (local.set $ms ($pr_str (global.get $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (global.get $error_val))) + (else + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/step6_file.wam b/impls/wasm/step6_file.wam index e6afbb4a90..9265fd79c9 100644 --- a/impls/wasm/step6_file.wam +++ b/impls/wasm/step6_file.wam @@ -1,430 +1,430 @@ -(module $step6_file - - (global $repl_env (mut i32) (i32.const 0)) - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 - $ret 0 $empty 0 $current 0) - - (if (global.get $error_type) (return 0)) - (local.set $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (local.set $res ($ENV_GET $env $ast)) - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (local.set $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (br_if $done (i32.eq ($VAL0 $ast) 0)) - - (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) - (else - (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (local.set $val2 $res) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $res) - (local.set $res 0) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $val3 $val2) - (local.set $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $val2)))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $ast ($MEM_VAL0_ptr $ast)) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (local.set $res $ret) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (local.set $res ($INC_REF $ast)) - ) - - $res - ) - - (func $MAL_GET_A1 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) - (func $MAL_GET_A2 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (func $MAL_GET_A3 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (LET $ast $orig_ast - $env $orig_env - $prev_ast 0 $prev_env 0 $res 0 $el 0 - $ftype 0 $f_args 0 $f 0 $args 0 - $a0 0 $a0sym 0 $a1 0 $a2 0) - - (block $EVAL_return - (loop $TCO_loop - - (local.set $f_args 0) - (local.set $f 0) - (local.set $args 0) - - (if (global.get $error_type) - (then - (local.set $res 0) - (br $EVAL_return))) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (then - (local.set $res ($EVAL_AST $ast $env 0)) - (br $EVAL_return))) - - ;; APPLY_LIST - (if ($EMPTY_Q $ast) - (then - (local.set $res ($INC_REF $ast)) - (br $EVAL_return))) - - (local.set $a0 ($MEM_VAL1_ptr $ast)) - (local.set $a0sym "") - (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) - (local.set $a0sym ($to_String $a0))) - - (if (i32.eqz ($strcmp "def!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - (br_if $EVAL_return (global.get $error_type)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res)) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "let*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - - ;; create new environment with outer as current environment - (local.set $prev_env $env) ;; save env for later release - (local.set $env ($ENV_NEW $env)) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $a1))) - ;; eval current A1 odd element - (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - - (br_if $done (global.get $error_type)) - - ;; set key/value in the let environment - (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) - ;; release our use, ENV_SET took ownership - ($RELEASE $res) - - ;; skip to the next pair of a1 elements - (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) - (br $loop) - ) - ) - - ;; release previous environment if not the current EVAL env - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - (local.set $ast $a2) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "do" $a0sym)) - (then - ;; EVAL the rest through second to last - (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (local.set $ast ($LAST $ast)) - ($RELEASE $ast) ;; we already own it via ast - ($RELEASE $el) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "if" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $res ($EVAL $a1 $env)) - - (if (global.get $error_type) - (then (nop)) - (else (if (OR (i32.eq $res (global.get $NIL)) - (i32.eq $res (global.get $FALSE))) - (then - ($RELEASE $res) - ;; if no false case (A3), return nil - (if (i32.lt_u ($COUNT $ast) 4) - (then - (local.set $res ($INC_REF (global.get $NIL))) - (br $EVAL_return)) - (else - (local.set $ast ($MAL_GET_A3 $ast))))) - (else - ($RELEASE $res) - (local.set $ast ($MAL_GET_A2 $ast)))))) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "fn*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($MALFUNC $a2 $a1 $env)) - (br $EVAL_return)) - (else - ;; EVAL_INVOKE - (local.set $res ($EVAL_AST $ast $env 0)) - (local.set $f_args $res) - - ;; if error, return f/args for release by caller - (if (global.get $error_type) - (then - (local.set $res $f_args) - (br $EVAL_return))) - - (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest - (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - (if (i32.eq ($VAL0 $f) 0) ;; eval - (then - (local.set $res ($EVAL ($MEM_VAL1_ptr $args) - (global.get $repl_env)))) - (else - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) - ;; release f/args - ($RELEASE $f_args) - (br $EVAL_return)) - (else (if (i32.eq $ftype (global.get $MALFUNC_T)) - (then - ;; save the current environment for release - (local.set $prev_env $env) - ;; create new environment using env and params stored in function - (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) - ($MEM_VAL1_ptr $f) $args)) - - ;; release previous environment if not the current EVAL env - ;; because our new env refers to it and we no longer need to - ;; track it (since we are TCO recurring) - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - ;; claim the AST before releasing the list containing it - (local.set $ast ($MEM_VAL0_ptr $f)) - (drop ($INC_REF $ast)) - - ;; if we have already been here via TCO, release previous - ;; ast - ;; PEND_A_LV - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - - ;; release f/args - ($RELEASE $f_args) - - (br $TCO_loop)) - (else - ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (local.set $res 0) - ($RELEASE $f_args) - (br $EVAL_return))))))))))))))) - - ) ;; end of TCO_loop - ) ;; end of EVAL_return - - ;; EVAL_RETURN - (if (i32.ne $env $orig_env) ($RELEASE $env)) - (if $prev_ast ($RELEASE $prev_ast)) - - $res - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $RE (param $line i32 $env i32) (result i32) - (LET $mv1 0 $res 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $res ($EVAL $mv1 $env)) - ) - - ;; release memory from MAL_READ - ($RELEASE $mv1) - $res - ) - - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv2 0 $ms 0) - (block $done - (local.set $mv2 ($RE $line $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from RE - ($RELEASE $mv2) - $ms - ) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 $ms 0 - ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $val2 0) - - ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - - (global.set $repl_env ($ENV_NEW (global.get $NIL))) - (local.set $repl_env (global.get $repl_env)) - - ;; core.EXT: defined in wasm - ($add_core_ns $repl_env) - (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) - - ($checkpoint_user_memory) - - ;; core.mal: defined using the language itself - ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) - ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) - - - ;; Command line arguments - (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) - ;; push MAP_LOP stack - ;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (local.set $i 2) - (block $done - (loop $loop - (br_if $done (i32.ge_u $i $argc)) - - (local.set $val2 ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv (i32.mul $i 4))))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE - (global.get $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $i (i32.add $i 1)) - (br $loop) - ) - ) - (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) - - - ;;($PR_MEMORY -1 -1) - - (if (i32.gt_u $argc 1) - (then - (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv 4))))) - ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (global.get $error_type) - (then - ($printf_1 "Error: %s\n" (global.get $error_str)) - (return 1)) - (else - (return 0))))) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line $repl_env)) - (if (global.get $error_type) - (then - (if (i32.eq 2 (global.get $error_type)) - (then - (local.set $ms ($pr_str (global.get $error_val) 1)) - ($printf_1 "Error: %s\n" ($to_String $ms)) - ($RELEASE $ms) - ($RELEASE (global.get $error_val))) - (else - ($printf_1 "Error: %s\n" (global.get $error_str)))) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $step6_file + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) + + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (local.set $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (local.set $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (br_if $done (i32.eq ($VAL0 $ast) 0)) + + (if $skiplast + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) + + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $res) + (local.set $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (local.set $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (local.set $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (LET $ast $orig_ast + $env $orig_env + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0) + + (block $EVAL_return + (loop $TCO_loop + + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) + + (if (global.get $error_type) + (then + (local.set $res 0) + (br $EVAL_return))) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (then + (local.set $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (then + (local.set $res ($INC_REF $ast)) + (br $EVAL_return))) + + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $a1))) + ;; eval current A1 odd element + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (br_if $done (global.get $error_type)) + + ;; set key/value in the let environment + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + (local.set $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) + + (if (global.get $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (local.set $res ($INC_REF (global.get $NIL))) + (br $EVAL_return)) + (else + (local.set $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (local.set $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) + + ;; if error, return f/args for release by caller + (if (global.get $error_type) + (then + (local.set $res $f_args) + (br $EVAL_return))) + + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value + + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) + (else + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) + (then + ;; save the current environment for release + (local.set $prev_env $env) + ;; create new environment using env and params stored in function + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (local.set $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (local.set $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (LET $mv1 0 $res 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv2 0 $ms 0) + (block $done + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 $ms 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $val2 0) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + ($checkpoint_user_memory) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) + + + ;; Command line arguments + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (local.set $i 2) + (block $done + (loop $loop + (br_if $done (i32.ge_u $i $argc)) + + (local.set $val2 ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv (i32.mul $i 4))))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (global.get $error_type) + (then + ($printf_1 "Error: %s\n" (global.get $error_str)) + (return 1)) + (else + (return 0))))) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) + (then + (if (i32.eq 2 (global.get $error_type)) + (then + (local.set $ms ($pr_str (global.get $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (global.get $error_val))) + (else + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/step7_quote.wam b/impls/wasm/step7_quote.wam index 0da34e3a44..948a0752e3 100644 --- a/impls/wasm/step7_quote.wam +++ b/impls/wasm/step7_quote.wam @@ -1,526 +1,526 @@ -(module $step7_quote - - (global $repl_env (mut i32) (i32.const 0)) - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - - - (func $QUASIQUOTE (param $ast i32) (result i32) - (LET $type ($TYPE $ast) $res 0 $sym 0 $second 0) - - ;; symbol or map -> ('quote ast) - (if (OR (i32.eq $type (global.get $SYMBOL_T)) - (i32.eq $type (global.get $HASHMAP_T))) - (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) - (local.set $res ($LIST2 $sym $ast)) - ($RELEASE $sym) - (return $res))) - - ;; [xs..] -> ('vec (processed like a list)) - (if (i32.eq $type (global.get $VECTOR_T)) (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "vec")) - (local.set $second ($qq_foldr $ast)) - (local.set $res ($LIST2 $sym $second)) - ($RELEASE $sym) - ($RELEASE $second) - (return $res))) - - ;; If ast is not affected by eval, return it unchanged. - (if (i32.ne $type (global.get $LIST_T)) (then - (return ($INC_REF $ast)))) - - ;; (unquote x) -> x - (local.set $second ($qq_unquote $ast "unquote")) - (if $second (then - (return ($INC_REF $second)))) - - ;; ast is a normal list, iterate on its elements - (return ($qq_foldr $ast))) - - ;; Helper for quasiquote. - ;; If the given list ast contains at least two elements and starts - ;; with the given symbol, return the second element. Else return 0. - (func $qq_unquote (param $ast i32) (param $sym i32) (result i32) - (LET $car 0 $cdr 0) - (if ($VAL0 $ast) (then - (local.set $car ($MEM_VAL1_ptr $ast)) - (if (i32.eq ($TYPE $car) (global.get $SYMBOL_T)) (then - (if (i32.eqz ($strcmp ($to_String $car) $sym)) (then - (local.set $cdr ($MEM_VAL0_ptr $ast)) - (if ($VAL0 $cdr) (then - (return ($MEM_VAL1_ptr $cdr)))))))))) - (return 0)) - - ;; Iteration on sequences for quasiquote (right reduce/fold). - (func $qq_foldr (param $xs i32) (result i32) - (if ($VAL0 $xs) (then - (return ($qq_loop ($MEM_VAL1_ptr $xs) ($qq_foldr ($MEM_VAL0_ptr $xs))))) - (else - (return ($INC_REF (global.get $EMPTY_LIST)))))) - - ;; Transition function for quasiquote right fold/reduce. - (func $qq_loop (param $elt i32) (param $acc i32) (result i32) - (LET $sym 0 $second 0 $res 0) - - ;; If elt is ('splice-unquote x) -> ('concat, x, acc) - (if (i32.eq ($TYPE $elt) (global.get $LIST_T)) (then - (local.set $second ($qq_unquote $elt "splice-unquote")) - (if $second (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) - (local.set $res ($LIST3 $sym $second $acc)) - ;; release inner quasiquoted since outer list takes ownership - ($RELEASE $sym) - (return $res))))) - - ;; normal elt -> ('cons, (quasiquoted x), acc) - (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) - (local.set $second ($QUASIQUOTE $elt)) - (local.set $res ($LIST3 $sym $second $acc)) - ;; release inner quasiquoted since outer list takes ownership - ($RELEASE $second) - ($RELEASE $sym) - (return $res)) - - - (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 - $ret 0 $empty 0 $current 0) - - (if (global.get $error_type) (return 0)) - (local.set $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (local.set $res ($ENV_GET $env $ast)) - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (local.set $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (br_if $done (i32.eq ($VAL0 $ast) 0)) - - (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) - (else - (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (local.set $val2 $res) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $res) - (local.set $res 0) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $val3 $val2) - (local.set $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $val2)))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $ast ($MEM_VAL0_ptr $ast)) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (local.set $res $ret) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (local.set $res ($INC_REF $ast)) - ) - - $res - ) - - (func $MAL_GET_A1 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) - (func $MAL_GET_A2 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (func $MAL_GET_A3 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (LET $ast $orig_ast - $env $orig_env - $prev_ast 0 $prev_env 0 $res 0 $el 0 - $ftype 0 $f_args 0 $f 0 $args 0 - $a0 0 $a0sym 0 $a1 0 $a2 0) - - (block $EVAL_return - (loop $TCO_loop - - (local.set $f_args 0) - (local.set $f 0) - (local.set $args 0) - - (if (global.get $error_type) - (then - (local.set $res 0) - (br $EVAL_return))) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (then - (local.set $res ($EVAL_AST $ast $env 0)) - (br $EVAL_return))) - - ;; APPLY_LIST - (if ($EMPTY_Q $ast) - (then - (local.set $res ($INC_REF $ast)) - (br $EVAL_return))) - - (local.set $a0 ($MEM_VAL1_ptr $ast)) - (local.set $a0sym "") - (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) - (local.set $a0sym ($to_String $a0))) - - (if (i32.eqz ($strcmp "def!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - (br_if $EVAL_return (global.get $error_type)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res)) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "let*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - - ;; create new environment with outer as current environment - (local.set $prev_env $env) ;; save env for later release - (local.set $env ($ENV_NEW $env)) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $a1))) - ;; eval current A1 odd element - (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - - (br_if $done (global.get $error_type)) - - ;; set key/value in the let environment - (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) - ;; release our use, ENV_SET took ownership - ($RELEASE $res) - - ;; skip to the next pair of a1 elements - (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) - (br $loop) - ) - ) - - ;; release previous environment if not the current EVAL env - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - (local.set $ast $a2) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "do" $a0sym)) - (then - ;; EVAL the rest through second to last - (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (local.set $ast ($LAST $ast)) - ($RELEASE $ast) ;; we already own it via ast - ($RELEASE $el) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "quote" $a0sym)) - (then - (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "quasiquoteexpand" $a0sym)) - (then - (local.set $res ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) - (then - (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - - ;; if we have already been here via TCO, release previous ast - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "if" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $res ($EVAL $a1 $env)) - - (if (global.get $error_type) - (then (nop)) - (else (if (OR (i32.eq $res (global.get $NIL)) - (i32.eq $res (global.get $FALSE))) - (then - ($RELEASE $res) - ;; if no false case (A3), return nil - (if (i32.lt_u ($COUNT $ast) 4) - (then - (local.set $res ($INC_REF (global.get $NIL))) - (br $EVAL_return)) - (else - (local.set $ast ($MAL_GET_A3 $ast))))) - (else - ($RELEASE $res) - (local.set $ast ($MAL_GET_A2 $ast)))))) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "fn*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($MALFUNC $a2 $a1 $env)) - (br $EVAL_return)) - (else - ;; EVAL_INVOKE - (local.set $res ($EVAL_AST $ast $env 0)) - (local.set $f_args $res) - - ;; if error, return f/args for release by caller - (if (global.get $error_type) - (then - (local.set $res $f_args) - (br $EVAL_return))) - - (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest - (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - (if (i32.eq ($VAL0 $f) 0) ;; eval - (then - (local.set $res ($EVAL ($MEM_VAL1_ptr $args) - (global.get $repl_env)))) - (else - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) - ;; release f/args - ($RELEASE $f_args) - (br $EVAL_return)) - (else (if (i32.eq $ftype (global.get $MALFUNC_T)) - (then - ;; save the current environment for release - (local.set $prev_env $env) - ;; create new environment using env and params stored in function - (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) - ($MEM_VAL1_ptr $f) $args)) - - ;; release previous environment if not the current EVAL env - ;; because our new env refers to it and we no longer need to - ;; track it (since we are TCO recurring) - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - ;; claim the AST before releasing the list containing it - (local.set $ast ($MEM_VAL0_ptr $f)) - (drop ($INC_REF $ast)) - - ;; if we have already been here via TCO, release previous - ;; ast - ;; PEND_A_LV - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - - ;; release f/args - ($RELEASE $f_args) - - (br $TCO_loop)) - (else - ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (local.set $res 0) - ($RELEASE $f_args) - (br $EVAL_return))))))))))))))))))))) - - ) ;; end of TCO_loop - ) ;; end of EVAL_return - - ;; EVAL_RETURN - (if (i32.ne $env $orig_env) ($RELEASE $env)) - (if $prev_ast ($RELEASE $prev_ast)) - - $res - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $RE (param $line i32 $env i32) (result i32) - (LET $mv1 0 $res 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $res ($EVAL $mv1 $env)) - ) - - ;; release memory from MAL_READ - ($RELEASE $mv1) - $res - ) - - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv2 0 $ms 0) - (block $done - (local.set $mv2 ($RE $line $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from RE - ($RELEASE $mv2) - $ms - ) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 $ms 0 - ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $val2 0) - - ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - - (global.set $repl_env ($ENV_NEW (global.get $NIL))) - (local.set $repl_env (global.get $repl_env)) - - ;; core.EXT: defined in wasm - ($add_core_ns $repl_env) - (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) - - ($checkpoint_user_memory) - - ;; core.mal: defined using the language itself - ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) - ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) - - - ;; Command line arguments - (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) - ;; push MAP_LOP stack - ;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (local.set $i 2) - (block $done - (loop $loop - (br_if $done (i32.ge_u $i $argc)) - - (local.set $val2 ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv (i32.mul $i 4))))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE - (global.get $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $i (i32.add $i 1)) - (br $loop) - ) - ) - (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) - - - ;;($PR_MEMORY -1 -1) - - (if (i32.gt_u $argc 1) - (then - (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv 4))))) - ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (global.get $error_type) - (then - ($printf_1 "Error: %s\n" (global.get $error_str)) - (return 1)) - (else - (return 0))))) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line $repl_env)) - (if (global.get $error_type) - (then - (if (i32.eq 2 (global.get $error_type)) - (then - (local.set $ms ($pr_str (global.get $error_val) 1)) - ($printf_1 "Error: %s\n" ($to_String $ms)) - ($RELEASE $ms) - ($RELEASE (global.get $error_val))) - (else - ($printf_1 "Error: %s\n" (global.get $error_str)))) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $step7_quote + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + + + (func $QUASIQUOTE (param $ast i32) (result i32) + (LET $type ($TYPE $ast) $res 0 $sym 0 $second 0) + + ;; symbol or map -> ('quote ast) + (if (OR (i32.eq $type (global.get $SYMBOL_T)) + (i32.eq $type (global.get $HASHMAP_T))) + (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) + (local.set $res ($LIST2 $sym $ast)) + ($RELEASE $sym) + (return $res))) + + ;; [xs..] -> ('vec (processed like a list)) + (if (i32.eq $type (global.get $VECTOR_T)) (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "vec")) + (local.set $second ($qq_foldr $ast)) + (local.set $res ($LIST2 $sym $second)) + ($RELEASE $sym) + ($RELEASE $second) + (return $res))) + + ;; If ast is not affected by eval, return it unchanged. + (if (i32.ne $type (global.get $LIST_T)) (then + (return ($INC_REF $ast)))) + + ;; (unquote x) -> x + (local.set $second ($qq_unquote $ast "unquote")) + (if $second (then + (return ($INC_REF $second)))) + + ;; ast is a normal list, iterate on its elements + (return ($qq_foldr $ast))) + + ;; Helper for quasiquote. + ;; If the given list ast contains at least two elements and starts + ;; with the given symbol, return the second element. Else return 0. + (func $qq_unquote (param $ast i32) (param $sym i32) (result i32) + (LET $car 0 $cdr 0) + (if ($VAL0 $ast) (then + (local.set $car ($MEM_VAL1_ptr $ast)) + (if (i32.eq ($TYPE $car) (global.get $SYMBOL_T)) (then + (if (i32.eqz ($strcmp ($to_String $car) $sym)) (then + (local.set $cdr ($MEM_VAL0_ptr $ast)) + (if ($VAL0 $cdr) (then + (return ($MEM_VAL1_ptr $cdr)))))))))) + (return 0)) + + ;; Iteration on sequences for quasiquote (right reduce/fold). + (func $qq_foldr (param $xs i32) (result i32) + (if ($VAL0 $xs) (then + (return ($qq_loop ($MEM_VAL1_ptr $xs) ($qq_foldr ($MEM_VAL0_ptr $xs))))) + (else + (return ($INC_REF (global.get $EMPTY_LIST)))))) + + ;; Transition function for quasiquote right fold/reduce. + (func $qq_loop (param $elt i32) (param $acc i32) (result i32) + (LET $sym 0 $second 0 $res 0) + + ;; If elt is ('splice-unquote x) -> ('concat, x, acc) + (if (i32.eq ($TYPE $elt) (global.get $LIST_T)) (then + (local.set $second ($qq_unquote $elt "splice-unquote")) + (if $second (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) + (local.set $res ($LIST3 $sym $second $acc)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $sym) + (return $res))))) + + ;; normal elt -> ('cons, (quasiquoted x), acc) + (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) + (local.set $second ($QUASIQUOTE $elt)) + (local.set $res ($LIST3 $sym $second $acc)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $second) + ($RELEASE $sym) + (return $res)) + + + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) + + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (local.set $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (local.set $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (br_if $done (i32.eq ($VAL0 $ast) 0)) + + (if $skiplast + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) + + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $res) + (local.set $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (local.set $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (local.set $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (LET $ast $orig_ast + $env $orig_env + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0) + + (block $EVAL_return + (loop $TCO_loop + + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) + + (if (global.get $error_type) + (then + (local.set $res 0) + (br $EVAL_return))) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (then + (local.set $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (if ($EMPTY_Q $ast) + (then + (local.set $res ($INC_REF $ast)) + (br $EVAL_return))) + + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $a1))) + ;; eval current A1 odd element + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (br_if $done (global.get $error_type)) + + ;; set key/value in the let environment + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + (local.set $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "quote" $a0sym)) + (then + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquoteexpand" $a0sym)) + (then + (local.set $res ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) + (then + (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + + ;; if we have already been here via TCO, release previous ast + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) + + (if (global.get $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (local.set $res ($INC_REF (global.get $NIL))) + (br $EVAL_return)) + (else + (local.set $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (local.set $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) + + ;; if error, return f/args for release by caller + (if (global.get $error_type) + (then + (local.set $res $f_args) + (br $EVAL_return))) + + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value + + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) + (else + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) + (then + ;; save the current environment for release + (local.set $prev_env $env) + ;; create new environment using env and params stored in function + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (local.set $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (local.set $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (LET $mv1 0 $res 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv2 0 $ms 0) + (block $done + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 $ms 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $val2 0) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + ($checkpoint_user_memory) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) + + + ;; Command line arguments + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (local.set $i 2) + (block $done + (loop $loop + (br_if $done (i32.ge_u $i $argc)) + + (local.set $val2 ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv (i32.mul $i 4))))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (global.get $error_type) + (then + ($printf_1 "Error: %s\n" (global.get $error_str)) + (return 1)) + (else + (return 0))))) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) + (then + (if (i32.eq 2 (global.get $error_type)) + (then + (local.set $ms ($pr_str (global.get $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (global.get $error_val))) + (else + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/step8_macros.wam b/impls/wasm/step8_macros.wam index 331e0d69b3..72a1345418 100644 --- a/impls/wasm/step8_macros.wam +++ b/impls/wasm/step8_macros.wam @@ -1,610 +1,610 @@ -(module $step8_macros - - (global $repl_env (mut i32) (i32.const 0)) - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - - - (func $QUASIQUOTE (param $ast i32) (result i32) - (LET $type ($TYPE $ast) $res 0 $sym 0 $second 0) - - ;; symbol or map -> ('quote ast) - (if (OR (i32.eq $type (global.get $SYMBOL_T)) - (i32.eq $type (global.get $HASHMAP_T))) - (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) - (local.set $res ($LIST2 $sym $ast)) - ($RELEASE $sym) - (return $res))) - - ;; [xs..] -> ('vec (processed like a list)) - (if (i32.eq $type (global.get $VECTOR_T)) (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "vec")) - (local.set $second ($qq_foldr $ast)) - (local.set $res ($LIST2 $sym $second)) - ($RELEASE $sym) - ($RELEASE $second) - (return $res))) - - ;; If ast is not affected by eval, return it unchanged. - (if (i32.ne $type (global.get $LIST_T)) (then - (return ($INC_REF $ast)))) - - ;; (unquote x) -> x - (local.set $second ($qq_unquote $ast "unquote")) - (if $second (then - (return ($INC_REF $second)))) - - ;; ast is a normal list, iterate on its elements - (return ($qq_foldr $ast))) - - ;; Helper for quasiquote. - ;; If the given list ast contains at least two elements and starts - ;; with the given symbol, return the second element. Else return 0. - (func $qq_unquote (param $ast i32) (param $sym i32) (result i32) - (LET $car 0 $cdr 0) - (if ($VAL0 $ast) (then - (local.set $car ($MEM_VAL1_ptr $ast)) - (if (i32.eq ($TYPE $car) (global.get $SYMBOL_T)) (then - (if (i32.eqz ($strcmp ($to_String $car) $sym)) (then - (local.set $cdr ($MEM_VAL0_ptr $ast)) - (if ($VAL0 $cdr) (then - (return ($MEM_VAL1_ptr $cdr)))))))))) - (return 0)) - - ;; Iteration on sequences for quasiquote (right reduce/fold). - (func $qq_foldr (param $xs i32) (result i32) - (if ($VAL0 $xs) (then - (return ($qq_loop ($MEM_VAL1_ptr $xs) ($qq_foldr ($MEM_VAL0_ptr $xs))))) - (else - (return ($INC_REF (global.get $EMPTY_LIST)))))) - - ;; Transition function for quasiquote right fold/reduce. - (func $qq_loop (param $elt i32) (param $acc i32) (result i32) - (LET $sym 0 $second 0 $res 0) - - ;; If elt is ('splice-unquote x) -> ('concat, x, acc) - (if (i32.eq ($TYPE $elt) (global.get $LIST_T)) (then - (local.set $second ($qq_unquote $elt "splice-unquote")) - (if $second (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) - (local.set $res ($LIST3 $sym $second $acc)) - ;; release inner quasiquoted since outer list takes ownership - ($RELEASE $sym) - (return $res))))) - - ;; normal elt -> ('cons, (quasiquoted x), acc) - (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) - (local.set $second ($QUASIQUOTE $elt)) - (local.set $res ($LIST3 $sym $second $acc)) - ;; release inner quasiquoted since outer list takes ownership - ($RELEASE $second) - ($RELEASE $sym) - (return $res)) - - - (global $mac_stack (mut i32) (i32.const 0)) - (global $mac_stack_top (mut i32) (i32.const -1)) - - (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) - (local $mac_env i64) - (LET $ast $orig_ast - $mac 0) - (global.set $mac_stack (STATIC_ARRAY 2048)) ;; 512 * 4, TODO: move to init - (block $done - (loop $loop - (br_if $done - (OR (i32.ne ($TYPE $ast) (global.get $LIST_T)) ;; a list - (i32.eqz ($VAL0 $ast)) ;; non-empty - (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol - (global.get $SYMBOL_T)))) - (local.set $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) - (local.set $mac (i32.wrap_i64 (i64.shr_u $mac_env (i64.const 32)))) - (br_if $done (OR (i32.eqz (i32.wrap_i64 $mac_env)) ;; defined in env - (i32.ne ($TYPE $mac) ;; a macro - (global.get $MACRO_T)))) - - (local.set $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) - ;; PEND_A_LV - ;; if ast is not the first ast that was passed in, then add it - ;; to the pending release list. - (if (i32.ne $ast $orig_ast) - (then - (global.set $mac_stack_top - (i32.add (global.get $mac_stack_top) 1)) - (if (i32.ge_s (i32.mul (global.get $mac_stack_top) 4) 2048) ;; 512 * 4 - ($fatal 7 "Exhausted mac_stack!\n")) - (i32.store (i32.add - (global.get $mac_stack) - (i32.mul (global.get $mac_stack_top) 4)) - $ast))) - (br_if $done (global.get $error_type)) - - (br $loop) - ) - ) - $ast - ) - - (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 - $ret 0 $empty 0 $current 0) - - (if (global.get $error_type) (return 0)) - (local.set $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (local.set $res ($ENV_GET $env $ast)) - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (local.set $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (br_if $done (i32.eq ($VAL0 $ast) 0)) - - (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) - (else - (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (local.set $val2 $res) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $res) - (local.set $res 0) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $val3 $val2) - (local.set $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $val2)))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $ast ($MEM_VAL0_ptr $ast)) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (local.set $res $ret) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (local.set $res ($INC_REF $ast)) - ) - - $res - ) - - (func $MAL_GET_A1 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) - (func $MAL_GET_A2 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (func $MAL_GET_A3 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (LET $ast $orig_ast - $env $orig_env - $orig_mac_stack_top (global.get $mac_stack_top) - $prev_ast 0 $prev_env 0 $res 0 $el 0 - $ftype 0 $f_args 0 $f 0 $args 0 - $a0 0 $a0sym 0 $a1 0 $a2 0) - - (block $EVAL_return - (loop $TCO_loop - - (local.set $f_args 0) - (local.set $f 0) - (local.set $args 0) - - (if (global.get $error_type) - (then - (local.set $res 0) - (br $EVAL_return))) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (then - (local.set $res ($EVAL_AST $ast $env 0)) - (br $EVAL_return))) - - ;; APPLY_LIST - (local.set $ast ($MACROEXPAND $ast $env)) - ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (then - (local.set $res ($EVAL_AST $ast $env 0)) - (br $EVAL_return))) - - (if ($EMPTY_Q $ast) - (then - (local.set $res ($INC_REF $ast)) - (br $EVAL_return))) - - (local.set $a0 ($MEM_VAL1_ptr $ast)) - (local.set $a0sym "") - (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) - (local.set $a0sym ($to_String $a0))) - - (if (i32.eqz ($strcmp "def!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - (br_if $EVAL_return (global.get $error_type)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res)) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "let*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - - ;; create new environment with outer as current environment - (local.set $prev_env $env) ;; save env for later release - (local.set $env ($ENV_NEW $env)) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $a1))) - ;; eval current A1 odd element - (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - - (br_if $done (global.get $error_type)) - - ;; set key/value in the let environment - (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) - ;; release our use, ENV_SET took ownership - ($RELEASE $res) - - ;; skip to the next pair of a1 elements - (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) - (br $loop) - ) - ) - - ;; release previous environment if not the current EVAL env - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - (local.set $ast $a2) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "do" $a0sym)) - (then - ;; EVAL the rest through second to last - (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (local.set $ast ($LAST $ast)) - ($RELEASE $ast) ;; we already own it via ast - ($RELEASE $el) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "quote" $a0sym)) - (then - (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "quasiquoteexpand" $a0sym)) - (then - (local.set $res ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) - (then - (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - - ;; if we have already been here via TCO, release previous ast - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - ($SET_TYPE $res (global.get $MACRO_T)) - (br_if $EVAL_return (global.get $error_type)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res)) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) - (then - ;; since we are returning it unevaluated, inc the ref cnt - (local.set $res ($INC_REF ($MACROEXPAND - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) - $env)))) - (else (if (i32.eqz ($strcmp "if" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $res ($EVAL $a1 $env)) - - (if (global.get $error_type) - (then (nop)) - (else (if (OR (i32.eq $res (global.get $NIL)) - (i32.eq $res (global.get $FALSE))) - (then - ($RELEASE $res) - ;; if no false case (A3), return nil - (if (i32.lt_u ($COUNT $ast) 4) - (then - (local.set $res ($INC_REF (global.get $NIL))) - (br $EVAL_return)) - (else - (local.set $ast ($MAL_GET_A3 $ast))))) - (else - ($RELEASE $res) - (local.set $ast ($MAL_GET_A2 $ast)))))) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "fn*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($MALFUNC $a2 $a1 $env)) - (br $EVAL_return)) - (else - ;; EVAL_INVOKE - (local.set $res ($EVAL_AST $ast $env 0)) - (local.set $f_args $res) - - ;; if error, return f/args for release by caller - (if (global.get $error_type) - (then - (local.set $res $f_args) - (br $EVAL_return))) - - (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest - (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - (if (i32.eq ($VAL0 $f) 0) ;; eval - (then - (local.set $res ($EVAL ($MEM_VAL1_ptr $args) - (global.get $repl_env)))) - (else - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) - ;; release f/args - ($RELEASE $f_args) - (br $EVAL_return)) - (else (if (i32.eq $ftype (global.get $MALFUNC_T)) - (then - ;; save the current environment for release - (local.set $prev_env $env) - ;; create new environment using env and params stored in function - (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) - ($MEM_VAL1_ptr $f) $args)) - - ;; release previous environment if not the current EVAL env - ;; because our new env refers to it and we no longer need to - ;; track it (since we are TCO recurring) - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - ;; claim the AST before releasing the list containing it - (local.set $ast ($MEM_VAL0_ptr $f)) - (drop ($INC_REF $ast)) - - ;; if we have already been here via TCO, release previous - ;; ast - ;; PEND_A_LV - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - - ;; release f/args - ($RELEASE $f_args) - - (br $TCO_loop)) - (else - ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (local.set $res 0) - ($RELEASE $f_args) - (br $EVAL_return))))))))))))))))))))))))) - - ) ;; end of TCO_loop - ) ;; end of EVAL_return - - ;; EVAL_RETURN - (if (i32.ne $env $orig_env) ($RELEASE $env)) - (if $prev_ast ($RELEASE $prev_ast)) - - ;; release memory from MACROEXPAND - ;; TODO: needs to happen here so self-hosting doesn't leak - (block $done - (loop $loop - (br_if $done (i32.le_s (global.get $mac_stack_top) $orig_mac_stack_top)) - ($RELEASE (i32.load (i32.add - (global.get $mac_stack) - (i32.mul (global.get $mac_stack_top) 4)))) - (global.set $mac_stack_top - (i32.sub (global.get $mac_stack_top) 1)) - (br $loop) - ) - ) - - $res - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $RE (param $line i32 $env i32) (result i32) - (LET $mv1 0 $res 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $res ($EVAL $mv1 $env)) - ) - - ;; release memory from MAL_READ - ($RELEASE $mv1) - $res - ) - - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv2 0 $ms 0) - (block $done - (local.set $mv2 ($RE $line $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from RE - ($RELEASE $mv2) - $ms - ) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 $ms 0 - ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $val2 0) - - ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - - (global.set $repl_env ($ENV_NEW (global.get $NIL))) - (local.set $repl_env (global.get $repl_env)) - - ;; core.EXT: defined in wasm - ($add_core_ns $repl_env) - (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) - - ($checkpoint_user_memory) - - ;; core.mal: defined using the language itself - ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) - ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) - ($RELEASE ($RE "(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)))))))" $repl_env)) - - - ;; Command line arguments - (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) - ;; push MAP_LOP stack - ;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (local.set $i 2) - (block $done - (loop $loop - (br_if $done (i32.ge_u $i $argc)) - - (local.set $val2 ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv (i32.mul $i 4))))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE - (global.get $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $i (i32.add $i 1)) - (br $loop) - ) - ) - (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) - - - ;;($PR_MEMORY -1 -1) - - (if (i32.gt_u $argc 1) - (then - (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv 4))))) - ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (global.get $error_type) - (then - ($printf_1 "Error: %s\n" (global.get $error_str)) - (return 1)) - (else - (return 0))))) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line $repl_env)) - (if (global.get $error_type) - (then - (if (i32.eq 2 (global.get $error_type)) - (then - (local.set $ms ($pr_str (global.get $error_val) 1)) - ($printf_1 "Error: %s\n" ($to_String $ms)) - ($RELEASE $ms) - ($RELEASE (global.get $error_val))) - (else - ($printf_1 "Error: %s\n" (global.get $error_str)))) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $step8_macros + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + + + (func $QUASIQUOTE (param $ast i32) (result i32) + (LET $type ($TYPE $ast) $res 0 $sym 0 $second 0) + + ;; symbol or map -> ('quote ast) + (if (OR (i32.eq $type (global.get $SYMBOL_T)) + (i32.eq $type (global.get $HASHMAP_T))) + (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) + (local.set $res ($LIST2 $sym $ast)) + ($RELEASE $sym) + (return $res))) + + ;; [xs..] -> ('vec (processed like a list)) + (if (i32.eq $type (global.get $VECTOR_T)) (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "vec")) + (local.set $second ($qq_foldr $ast)) + (local.set $res ($LIST2 $sym $second)) + ($RELEASE $sym) + ($RELEASE $second) + (return $res))) + + ;; If ast is not affected by eval, return it unchanged. + (if (i32.ne $type (global.get $LIST_T)) (then + (return ($INC_REF $ast)))) + + ;; (unquote x) -> x + (local.set $second ($qq_unquote $ast "unquote")) + (if $second (then + (return ($INC_REF $second)))) + + ;; ast is a normal list, iterate on its elements + (return ($qq_foldr $ast))) + + ;; Helper for quasiquote. + ;; If the given list ast contains at least two elements and starts + ;; with the given symbol, return the second element. Else return 0. + (func $qq_unquote (param $ast i32) (param $sym i32) (result i32) + (LET $car 0 $cdr 0) + (if ($VAL0 $ast) (then + (local.set $car ($MEM_VAL1_ptr $ast)) + (if (i32.eq ($TYPE $car) (global.get $SYMBOL_T)) (then + (if (i32.eqz ($strcmp ($to_String $car) $sym)) (then + (local.set $cdr ($MEM_VAL0_ptr $ast)) + (if ($VAL0 $cdr) (then + (return ($MEM_VAL1_ptr $cdr)))))))))) + (return 0)) + + ;; Iteration on sequences for quasiquote (right reduce/fold). + (func $qq_foldr (param $xs i32) (result i32) + (if ($VAL0 $xs) (then + (return ($qq_loop ($MEM_VAL1_ptr $xs) ($qq_foldr ($MEM_VAL0_ptr $xs))))) + (else + (return ($INC_REF (global.get $EMPTY_LIST)))))) + + ;; Transition function for quasiquote right fold/reduce. + (func $qq_loop (param $elt i32) (param $acc i32) (result i32) + (LET $sym 0 $second 0 $res 0) + + ;; If elt is ('splice-unquote x) -> ('concat, x, acc) + (if (i32.eq ($TYPE $elt) (global.get $LIST_T)) (then + (local.set $second ($qq_unquote $elt "splice-unquote")) + (if $second (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) + (local.set $res ($LIST3 $sym $second $acc)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $sym) + (return $res))))) + + ;; normal elt -> ('cons, (quasiquoted x), acc) + (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) + (local.set $second ($QUASIQUOTE $elt)) + (local.set $res ($LIST3 $sym $second $acc)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $second) + ($RELEASE $sym) + (return $res)) + + + (global $mac_stack (mut i32) (i32.const 0)) + (global $mac_stack_top (mut i32) (i32.const -1)) + + (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) + (local $mac_env i64) + (LET $ast $orig_ast + $mac 0) + (global.set $mac_stack (STATIC_ARRAY 2048)) ;; 512 * 4, TODO: move to init + (block $done + (loop $loop + (br_if $done + (OR (i32.ne ($TYPE $ast) (global.get $LIST_T)) ;; a list + (i32.eqz ($VAL0 $ast)) ;; non-empty + (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol + (global.get $SYMBOL_T)))) + (local.set $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) + (local.set $mac (i32.wrap_i64 (i64.shr_u $mac_env (i64.const 32)))) + (br_if $done (OR (i32.eqz (i32.wrap_i64 $mac_env)) ;; defined in env + (i32.ne ($TYPE $mac) ;; a macro + (global.get $MACRO_T)))) + + (local.set $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) + ;; PEND_A_LV + ;; if ast is not the first ast that was passed in, then add it + ;; to the pending release list. + (if (i32.ne $ast $orig_ast) + (then + (global.set $mac_stack_top + (i32.add (global.get $mac_stack_top) 1)) + (if (i32.ge_s (i32.mul (global.get $mac_stack_top) 4) 2048) ;; 512 * 4 + ($fatal 7 "Exhausted mac_stack!\n")) + (i32.store (i32.add + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)) + $ast))) + (br_if $done (global.get $error_type)) + + (br $loop) + ) + ) + $ast + ) + + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) + + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (local.set $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (local.set $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (br_if $done (i32.eq ($VAL0 $ast) 0)) + + (if $skiplast + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) + + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $res) + (local.set $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (local.set $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (local.set $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (LET $ast $orig_ast + $env $orig_env + $orig_mac_stack_top (global.get $mac_stack_top) + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0) + + (block $EVAL_return + (loop $TCO_loop + + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) + + (if (global.get $error_type) + (then + (local.set $res 0) + (br $EVAL_return))) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (then + (local.set $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (local.set $ast ($MACROEXPAND $ast $env)) + ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (then + (local.set $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + (if ($EMPTY_Q $ast) + (then + (local.set $res ($INC_REF $ast)) + (br $EVAL_return))) + + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $a1))) + ;; eval current A1 odd element + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (br_if $done (global.get $error_type)) + + ;; set key/value in the let environment + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + (local.set $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "quote" $a0sym)) + (then + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquoteexpand" $a0sym)) + (then + (local.set $res ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) + (then + (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + + ;; if we have already been here via TCO, release previous ast + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + ($SET_TYPE $res (global.get $MACRO_T)) + (br_if $EVAL_return (global.get $error_type)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) + (then + ;; since we are returning it unevaluated, inc the ref cnt + (local.set $res ($INC_REF ($MACROEXPAND + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) + $env)))) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) + + (if (global.get $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (local.set $res ($INC_REF (global.get $NIL))) + (br $EVAL_return)) + (else + (local.set $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (local.set $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) + + ;; if error, return f/args for release by caller + (if (global.get $error_type) + (then + (local.set $res $f_args) + (br $EVAL_return))) + + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value + + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) + (else + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) + (then + ;; save the current environment for release + (local.set $prev_env $env) + ;; create new environment using env and params stored in function + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (local.set $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (local.set $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + ;; release memory from MACROEXPAND + ;; TODO: needs to happen here so self-hosting doesn't leak + (block $done + (loop $loop + (br_if $done (i32.le_s (global.get $mac_stack_top) $orig_mac_stack_top)) + ($RELEASE (i32.load (i32.add + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)))) + (global.set $mac_stack_top + (i32.sub (global.get $mac_stack_top) 1)) + (br $loop) + ) + ) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (LET $mv1 0 $res 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv2 0 $ms 0) + (block $done + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 $ms 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $val2 0) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + ($checkpoint_user_memory) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) + ($RELEASE ($RE "(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)))))))" $repl_env)) + + + ;; Command line arguments + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (local.set $i 2) + (block $done + (loop $loop + (br_if $done (i32.ge_u $i $argc)) + + (local.set $val2 ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv (i32.mul $i 4))))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (global.get $error_type) + (then + ($printf_1 "Error: %s\n" (global.get $error_str)) + (return 1)) + (else + (return 0))))) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) + (then + (if (i32.eq 2 (global.get $error_type)) + (then + (local.set $ms ($pr_str (global.get $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (global.get $error_val))) + (else + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/step9_try.wam b/impls/wasm/step9_try.wam index 01569353a7..3ac6ea8275 100644 --- a/impls/wasm/step9_try.wam +++ b/impls/wasm/step9_try.wam @@ -1,657 +1,657 @@ -(module $step9_try - - (global $repl_env (mut i32) (i32.const 0)) - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - - - (func $QUASIQUOTE (param $ast i32) (result i32) - (LET $type ($TYPE $ast) $res 0 $sym 0 $second 0) - - ;; symbol or map -> ('quote ast) - (if (OR (i32.eq $type (global.get $SYMBOL_T)) - (i32.eq $type (global.get $HASHMAP_T))) - (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) - (local.set $res ($LIST2 $sym $ast)) - ($RELEASE $sym) - (return $res))) - - ;; [xs..] -> ('vec (processed like a list)) - (if (i32.eq $type (global.get $VECTOR_T)) (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "vec")) - (local.set $second ($qq_foldr $ast)) - (local.set $res ($LIST2 $sym $second)) - ($RELEASE $sym) - ($RELEASE $second) - (return $res))) - - ;; If ast is not affected by eval, return it unchanged. - (if (i32.ne $type (global.get $LIST_T)) (then - (return ($INC_REF $ast)))) - - ;; (unquote x) -> x - (local.set $second ($qq_unquote $ast "unquote")) - (if $second (then - (return ($INC_REF $second)))) - - ;; ast is a normal list, iterate on its elements - (return ($qq_foldr $ast))) - - ;; Helper for quasiquote. - ;; If the given list ast contains at least two elements and starts - ;; with the given symbol, return the second element. Else return 0. - (func $qq_unquote (param $ast i32) (param $sym i32) (result i32) - (LET $car 0 $cdr 0) - (if ($VAL0 $ast) (then - (local.set $car ($MEM_VAL1_ptr $ast)) - (if (i32.eq ($TYPE $car) (global.get $SYMBOL_T)) (then - (if (i32.eqz ($strcmp ($to_String $car) $sym)) (then - (local.set $cdr ($MEM_VAL0_ptr $ast)) - (if ($VAL0 $cdr) (then - (return ($MEM_VAL1_ptr $cdr)))))))))) - (return 0)) - - ;; Iteration on sequences for quasiquote (right reduce/fold). - (func $qq_foldr (param $xs i32) (result i32) - (if ($VAL0 $xs) (then - (return ($qq_loop ($MEM_VAL1_ptr $xs) ($qq_foldr ($MEM_VAL0_ptr $xs))))) - (else - (return ($INC_REF (global.get $EMPTY_LIST)))))) - - ;; Transition function for quasiquote right fold/reduce. - (func $qq_loop (param $elt i32) (param $acc i32) (result i32) - (LET $sym 0 $second 0 $res 0) - - ;; If elt is ('splice-unquote x) -> ('concat, x, acc) - (if (i32.eq ($TYPE $elt) (global.get $LIST_T)) (then - (local.set $second ($qq_unquote $elt "splice-unquote")) - (if $second (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) - (local.set $res ($LIST3 $sym $second $acc)) - ;; release inner quasiquoted since outer list takes ownership - ($RELEASE $sym) - (return $res))))) - - ;; normal elt -> ('cons, (quasiquoted x), acc) - (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) - (local.set $second ($QUASIQUOTE $elt)) - (local.set $res ($LIST3 $sym $second $acc)) - ;; release inner quasiquoted since outer list takes ownership - ($RELEASE $second) - ($RELEASE $sym) - (return $res)) - - - (global $mac_stack (mut i32) (i32.const 0)) - (global $mac_stack_top (mut i32) (i32.const -1)) - - (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) - (local $mac_env i64) - (LET $ast $orig_ast - $mac 0) - (global.set $mac_stack (STATIC_ARRAY 2048)) ;; 512 * 4, TODO: move to init - (block $done - (loop $loop - (br_if $done - (OR (i32.ne ($TYPE $ast) (global.get $LIST_T)) ;; a list - (i32.eqz ($VAL0 $ast)) ;; non-empty - (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol - (global.get $SYMBOL_T)))) - (local.set $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) - (local.set $mac (i32.wrap_i64 (i64.shr_u $mac_env (i64.const 32)))) - (br_if $done (OR (i32.eqz (i32.wrap_i64 $mac_env)) ;; defined in env - (i32.ne ($TYPE $mac) ;; a macro - (global.get $MACRO_T)))) - - (local.set $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) - ;; PEND_A_LV - ;; if ast is not the first ast that was passed in, then add it - ;; to the pending release list. - (if (i32.ne $ast $orig_ast) - (then - (global.set $mac_stack_top - (i32.add (global.get $mac_stack_top) 1)) - (if (i32.ge_s (i32.mul (global.get $mac_stack_top) 4) 2048) ;; 512 * 4 - ($fatal 7 "Exhausted mac_stack!\n")) - (i32.store (i32.add - (global.get $mac_stack) - (i32.mul (global.get $mac_stack_top) 4)) - $ast))) - (br_if $done (global.get $error_type)) - - (br $loop) - ) - ) - $ast - ) - - (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 - $ret 0 $empty 0 $current 0) - - (if (global.get $error_type) (return 0)) - (local.set $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (local.set $res ($ENV_GET $env $ast)) - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (local.set $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (br_if $done (i32.eq ($VAL0 $ast) 0)) - - (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) - (else - (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (local.set $val2 $res) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $res) - (local.set $res 0) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $val3 $val2) - (local.set $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $val2)))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $ast ($MEM_VAL0_ptr $ast)) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (local.set $res $ret) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (local.set $res ($INC_REF $ast)) - ) - - $res - ) - - (func $MAL_GET_A1 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) - (func $MAL_GET_A2 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (func $MAL_GET_A3 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (LET $ast $orig_ast - $env $orig_env - $orig_mac_stack_top (global.get $mac_stack_top) - $prev_ast 0 $prev_env 0 $res 0 $el 0 - $ftype 0 $f_args 0 $f 0 $args 0 - $a0 0 $a0sym 0 $a1 0 $a2 0 - $err 0) - - (block $EVAL_return - (loop $TCO_loop - - (local.set $f_args 0) - (local.set $f 0) - (local.set $args 0) - - (if (global.get $error_type) - (then - (local.set $res 0) - (br $EVAL_return))) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (then - (local.set $res ($EVAL_AST $ast $env 0)) - (br $EVAL_return))) - - ;; APPLY_LIST - (local.set $ast ($MACROEXPAND $ast $env)) - ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (then - (local.set $res ($EVAL_AST $ast $env 0)) - (br $EVAL_return))) - - (if ($EMPTY_Q $ast) - (then - (local.set $res ($INC_REF $ast)) - (br $EVAL_return))) - - (local.set $a0 ($MEM_VAL1_ptr $ast)) - (local.set $a0sym "") - (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) - (local.set $a0sym ($to_String $a0))) - - (if (i32.eqz ($strcmp "def!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - (br_if $EVAL_return (global.get $error_type)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res)) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "let*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - - ;; create new environment with outer as current environment - (local.set $prev_env $env) ;; save env for later release - (local.set $env ($ENV_NEW $env)) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $a1))) - ;; eval current A1 odd element - (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - - (br_if $done (global.get $error_type)) - - ;; set key/value in the let environment - (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) - ;; release our use, ENV_SET took ownership - ($RELEASE $res) - - ;; skip to the next pair of a1 elements - (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) - (br $loop) - ) - ) - - ;; release previous environment if not the current EVAL env - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - (local.set $ast $a2) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "do" $a0sym)) - (then - ;; EVAL the rest through second to last - (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (local.set $ast ($LAST $ast)) - ($RELEASE $ast) ;; we already own it via ast - ($RELEASE $el) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "quote" $a0sym)) - (then - (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "quasiquoteexpand" $a0sym)) - (then - (local.set $res ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) - (then - (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - - ;; if we have already been here via TCO, release previous ast - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - ($SET_TYPE $res (global.get $MACRO_T)) - (br_if $EVAL_return (global.get $error_type)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res)) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) - (then - ;; since we are returning it unevaluated, inc the ref cnt - (local.set $res ($INC_REF ($MACROEXPAND - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) - $env)))) - (else (if (i32.eqz ($strcmp "try*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $res ($EVAL $a1 $env)) - - ;; if there is no error, return - (br_if $EVAL_return (i32.eqz (global.get $error_type))) - ;; if there is an error and res is set, we need to free it - ($RELEASE $res) - ;; if there is no catch block then return - (br_if $EVAL_return - (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - ;; save the current environment for release - (local.set $prev_env $env) - ;; create environment for the catch block eval - (local.set $env ($ENV_NEW $env)) - - ;; set a1 and a2 from the catch block - (local.set $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) - (local.set $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) - - ;; create object for string errors - (if (i32.eq (global.get $error_type) 1) - (then - (local.set $err ($STRING (global.get $STRING_T) - (global.get $error_str)))) - (else - (local.set $err (global.get $error_val)))) - ;; bind the catch symbol to the error object - (drop ($ENV_SET $env $a1 $err)) - ;; release our use, env took ownership - ($RELEASE $err) - - ;; unset error for catch eval - (global.set $error_type 0) - (i32.store (global.get $error_str) (CHR "\x00")) - - ;; release previous environment if not the current EVAL env - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - (local.set $ast $a2) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "if" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $res ($EVAL $a1 $env)) - - (if (global.get $error_type) - (then (nop)) - (else (if (OR (i32.eq $res (global.get $NIL)) - (i32.eq $res (global.get $FALSE))) - (then - ($RELEASE $res) - ;; if no false case (A3), return nil - (if (i32.lt_u ($COUNT $ast) 4) - (then - (local.set $res ($INC_REF (global.get $NIL))) - (br $EVAL_return)) - (else - (local.set $ast ($MAL_GET_A3 $ast))))) - (else - ($RELEASE $res) - (local.set $ast ($MAL_GET_A2 $ast)))))) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "fn*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($MALFUNC $a2 $a1 $env)) - (br $EVAL_return)) - (else - ;; EVAL_INVOKE - (local.set $res ($EVAL_AST $ast $env 0)) - (local.set $f_args $res) - - ;; if error, return f/args for release by caller - (if (global.get $error_type) - (then - (local.set $res $f_args) - (br $EVAL_return))) - - (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest - (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value - - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - (if (i32.eq ($VAL0 $f) 0) ;; eval - (then - (local.set $res ($EVAL ($MEM_VAL1_ptr $args) - (global.get $repl_env)))) - (else - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) - ;; release f/args - ($RELEASE $f_args) - (br $EVAL_return)) - (else (if (i32.eq $ftype (global.get $MALFUNC_T)) - (then - ;; save the current environment for release - (local.set $prev_env $env) - ;; create new environment using env and params stored in function - (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) - ($MEM_VAL1_ptr $f) $args)) - - ;; release previous environment if not the current EVAL env - ;; because our new env refers to it and we no longer need to - ;; track it (since we are TCO recurring) - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - ;; claim the AST before releasing the list containing it - (local.set $ast ($MEM_VAL0_ptr $f)) - (drop ($INC_REF $ast)) - - ;; if we have already been here via TCO, release previous - ;; ast - ;; PEND_A_LV - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - - ;; release f/args - ($RELEASE $f_args) - - (br $TCO_loop)) - (else - ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (local.set $res 0) - ($RELEASE $f_args) - (br $EVAL_return))))))))))))))))))))))))))) - - ) ;; end of TCO_loop - ) ;; end of EVAL_return - - ;; EVAL_RETURN - (if (i32.ne $env $orig_env) ($RELEASE $env)) - (if $prev_ast ($RELEASE $prev_ast)) - - ;; release memory from MACROEXPAND - ;; TODO: needs to happen here so self-hosting doesn't leak - (block $done - (loop $loop - (br_if $done (i32.le_s (global.get $mac_stack_top) $orig_mac_stack_top)) - ($RELEASE (i32.load (i32.add - (global.get $mac_stack) - (i32.mul (global.get $mac_stack_top) 4)))) - (global.set $mac_stack_top - (i32.sub (global.get $mac_stack_top) 1)) - (br $loop) - ) - ) - - $res - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $RE (param $line i32 $env i32) (result i32) - (LET $mv1 0 $res 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $res ($EVAL $mv1 $env)) - ) - - ;; release memory from MAL_READ - ($RELEASE $mv1) - $res - ) - - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv2 0 $ms 0) - (block $done - (local.set $mv2 ($RE $line $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from RE - ($RELEASE $mv2) - $ms - ) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 $ms 0 - ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $val2 0) - - ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - - (global.set $repl_env ($ENV_NEW (global.get $NIL))) - (local.set $repl_env (global.get $repl_env)) - - ;; core.EXT: defined in wasm - ($add_core_ns $repl_env) - (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) - - ($checkpoint_user_memory) - - ;; core.mal: defined using the language itself - ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) - ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) - ($RELEASE ($RE "(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)))))))" $repl_env)) - - - ;; Command line arguments - (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) - ;; push MAP_LOP stack - ;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (local.set $i 2) - (block $done - (loop $loop - (br_if $done (i32.ge_u $i $argc)) - - (local.set $val2 ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv (i32.mul $i 4))))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE - (global.get $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $i (i32.add $i 1)) - (br $loop) - ) - ) - (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) - - - ;;($PR_MEMORY -1 -1) - - (if (i32.gt_u $argc 1) - (then - (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv 4))))) - ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (global.get $error_type) - (then - ($printf_1 "Error: %s\n" (global.get $error_str)) - (return 1)) - (else - (return 0))))) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line $repl_env)) - (if (global.get $error_type) - (then - (if (i32.eq 2 (global.get $error_type)) - (then - (local.set $ms ($pr_str (global.get $error_val) 1)) - ($printf_1 "Error: %s\n" ($to_String $ms)) - ($RELEASE $ms) - ($RELEASE (global.get $error_val))) - (else - ($printf_1 "Error: %s\n" (global.get $error_str)))) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $step9_try + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + + + (func $QUASIQUOTE (param $ast i32) (result i32) + (LET $type ($TYPE $ast) $res 0 $sym 0 $second 0) + + ;; symbol or map -> ('quote ast) + (if (OR (i32.eq $type (global.get $SYMBOL_T)) + (i32.eq $type (global.get $HASHMAP_T))) + (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) + (local.set $res ($LIST2 $sym $ast)) + ($RELEASE $sym) + (return $res))) + + ;; [xs..] -> ('vec (processed like a list)) + (if (i32.eq $type (global.get $VECTOR_T)) (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "vec")) + (local.set $second ($qq_foldr $ast)) + (local.set $res ($LIST2 $sym $second)) + ($RELEASE $sym) + ($RELEASE $second) + (return $res))) + + ;; If ast is not affected by eval, return it unchanged. + (if (i32.ne $type (global.get $LIST_T)) (then + (return ($INC_REF $ast)))) + + ;; (unquote x) -> x + (local.set $second ($qq_unquote $ast "unquote")) + (if $second (then + (return ($INC_REF $second)))) + + ;; ast is a normal list, iterate on its elements + (return ($qq_foldr $ast))) + + ;; Helper for quasiquote. + ;; If the given list ast contains at least two elements and starts + ;; with the given symbol, return the second element. Else return 0. + (func $qq_unquote (param $ast i32) (param $sym i32) (result i32) + (LET $car 0 $cdr 0) + (if ($VAL0 $ast) (then + (local.set $car ($MEM_VAL1_ptr $ast)) + (if (i32.eq ($TYPE $car) (global.get $SYMBOL_T)) (then + (if (i32.eqz ($strcmp ($to_String $car) $sym)) (then + (local.set $cdr ($MEM_VAL0_ptr $ast)) + (if ($VAL0 $cdr) (then + (return ($MEM_VAL1_ptr $cdr)))))))))) + (return 0)) + + ;; Iteration on sequences for quasiquote (right reduce/fold). + (func $qq_foldr (param $xs i32) (result i32) + (if ($VAL0 $xs) (then + (return ($qq_loop ($MEM_VAL1_ptr $xs) ($qq_foldr ($MEM_VAL0_ptr $xs))))) + (else + (return ($INC_REF (global.get $EMPTY_LIST)))))) + + ;; Transition function for quasiquote right fold/reduce. + (func $qq_loop (param $elt i32) (param $acc i32) (result i32) + (LET $sym 0 $second 0 $res 0) + + ;; If elt is ('splice-unquote x) -> ('concat, x, acc) + (if (i32.eq ($TYPE $elt) (global.get $LIST_T)) (then + (local.set $second ($qq_unquote $elt "splice-unquote")) + (if $second (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) + (local.set $res ($LIST3 $sym $second $acc)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $sym) + (return $res))))) + + ;; normal elt -> ('cons, (quasiquoted x), acc) + (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) + (local.set $second ($QUASIQUOTE $elt)) + (local.set $res ($LIST3 $sym $second $acc)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $second) + ($RELEASE $sym) + (return $res)) + + + (global $mac_stack (mut i32) (i32.const 0)) + (global $mac_stack_top (mut i32) (i32.const -1)) + + (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) + (local $mac_env i64) + (LET $ast $orig_ast + $mac 0) + (global.set $mac_stack (STATIC_ARRAY 2048)) ;; 512 * 4, TODO: move to init + (block $done + (loop $loop + (br_if $done + (OR (i32.ne ($TYPE $ast) (global.get $LIST_T)) ;; a list + (i32.eqz ($VAL0 $ast)) ;; non-empty + (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol + (global.get $SYMBOL_T)))) + (local.set $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) + (local.set $mac (i32.wrap_i64 (i64.shr_u $mac_env (i64.const 32)))) + (br_if $done (OR (i32.eqz (i32.wrap_i64 $mac_env)) ;; defined in env + (i32.ne ($TYPE $mac) ;; a macro + (global.get $MACRO_T)))) + + (local.set $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) + ;; PEND_A_LV + ;; if ast is not the first ast that was passed in, then add it + ;; to the pending release list. + (if (i32.ne $ast $orig_ast) + (then + (global.set $mac_stack_top + (i32.add (global.get $mac_stack_top) 1)) + (if (i32.ge_s (i32.mul (global.get $mac_stack_top) 4) 2048) ;; 512 * 4 + ($fatal 7 "Exhausted mac_stack!\n")) + (i32.store (i32.add + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)) + $ast))) + (br_if $done (global.get $error_type)) + + (br $loop) + ) + ) + $ast + ) + + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) + + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (local.set $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (local.set $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (br_if $done (i32.eq ($VAL0 $ast) 0)) + + (if $skiplast + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) + + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $res) + (local.set $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (local.set $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (local.set $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (LET $ast $orig_ast + $env $orig_env + $orig_mac_stack_top (global.get $mac_stack_top) + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0 + $err 0) + + (block $EVAL_return + (loop $TCO_loop + + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) + + (if (global.get $error_type) + (then + (local.set $res 0) + (br $EVAL_return))) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (then + (local.set $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (local.set $ast ($MACROEXPAND $ast $env)) + ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (then + (local.set $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + (if ($EMPTY_Q $ast) + (then + (local.set $res ($INC_REF $ast)) + (br $EVAL_return))) + + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $a1))) + ;; eval current A1 odd element + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (br_if $done (global.get $error_type)) + + ;; set key/value in the let environment + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + (local.set $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "quote" $a0sym)) + (then + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquoteexpand" $a0sym)) + (then + (local.set $res ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) + (then + (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + + ;; if we have already been here via TCO, release previous ast + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + ($SET_TYPE $res (global.get $MACRO_T)) + (br_if $EVAL_return (global.get $error_type)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) + (then + ;; since we are returning it unevaluated, inc the ref cnt + (local.set $res ($INC_REF ($MACROEXPAND + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) + $env)))) + (else (if (i32.eqz ($strcmp "try*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) + + ;; if there is no error, return + (br_if $EVAL_return (i32.eqz (global.get $error_type))) + ;; if there is an error and res is set, we need to free it + ($RELEASE $res) + ;; if there is no catch block then return + (br_if $EVAL_return + (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + ;; save the current environment for release + (local.set $prev_env $env) + ;; create environment for the catch block eval + (local.set $env ($ENV_NEW $env)) + + ;; set a1 and a2 from the catch block + (local.set $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) + (local.set $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) + + ;; create object for string errors + (if (i32.eq (global.get $error_type) 1) + (then + (local.set $err ($STRING (global.get $STRING_T) + (global.get $error_str)))) + (else + (local.set $err (global.get $error_val)))) + ;; bind the catch symbol to the error object + (drop ($ENV_SET $env $a1 $err)) + ;; release our use, env took ownership + ($RELEASE $err) + + ;; unset error for catch eval + (global.set $error_type 0) + (i32.store (global.get $error_str) (CHR "\x00")) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + (local.set $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) + + (if (global.get $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (local.set $res ($INC_REF (global.get $NIL))) + (br $EVAL_return)) + (else + (local.set $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (local.set $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) + + ;; if error, return f/args for release by caller + (if (global.get $error_type) + (then + (local.set $res $f_args) + (br $EVAL_return))) + + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value + + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) + (else + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) + (then + ;; save the current environment for release + (local.set $prev_env $env) + ;; create new environment using env and params stored in function + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (local.set $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (local.set $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + ;; release memory from MACROEXPAND + ;; TODO: needs to happen here so self-hosting doesn't leak + (block $done + (loop $loop + (br_if $done (i32.le_s (global.get $mac_stack_top) $orig_mac_stack_top)) + ($RELEASE (i32.load (i32.add + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)))) + (global.set $mac_stack_top + (i32.sub (global.get $mac_stack_top) 1)) + (br $loop) + ) + ) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (LET $mv1 0 $res 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv2 0 $ms 0) + (block $done + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 $ms 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $val2 0) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + ($checkpoint_user_memory) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) + ($RELEASE ($RE "(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)))))))" $repl_env)) + + + ;; Command line arguments + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (local.set $i 2) + (block $done + (loop $loop + (br_if $done (i32.ge_u $i $argc)) + + (local.set $val2 ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv (i32.mul $i 4))))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (global.get $error_type) + (then + ($printf_1 "Error: %s\n" (global.get $error_str)) + (return 1)) + (else + (return 0))))) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) + (then + (if (i32.eq 2 (global.get $error_type)) + (then + (local.set $ms ($pr_str (global.get $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (global.get $error_val))) + (else + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/stepA_mal.wam b/impls/wasm/stepA_mal.wam index 1bb0d86d1c..62b0f4cec2 100644 --- a/impls/wasm/stepA_mal.wam +++ b/impls/wasm/stepA_mal.wam @@ -1,659 +1,659 @@ -(module $stepA_mal - - (global $repl_env (mut i32) (i32.const 0)) - - ;; READ - (func $READ (param $str i32) (result i32) - ($read_str $str) - ) - - ;; EVAL - - - (func $QUASIQUOTE (param $ast i32) (result i32) - (LET $type ($TYPE $ast) $res 0 $sym 0 $second 0) - - ;; symbol or map -> ('quote ast) - (if (OR (i32.eq $type (global.get $SYMBOL_T)) - (i32.eq $type (global.get $HASHMAP_T))) - (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) - (local.set $res ($LIST2 $sym $ast)) - ($RELEASE $sym) - (return $res))) - - ;; [xs..] -> ('vec (processed like a list)) - (if (i32.eq $type (global.get $VECTOR_T)) (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "vec")) - (local.set $second ($qq_foldr $ast)) - (local.set $res ($LIST2 $sym $second)) - ($RELEASE $sym) - ($RELEASE $second) - (return $res))) - - ;; If ast is not affected by eval, return it unchanged. - (if (i32.ne $type (global.get $LIST_T)) (then - (return ($INC_REF $ast)))) - - ;; (unquote x) -> x - (local.set $second ($qq_unquote $ast "unquote")) - (if $second (then - (return ($INC_REF $second)))) - - ;; ast is a normal list, iterate on its elements - (return ($qq_foldr $ast))) - - ;; Helper for quasiquote. - ;; If the given list ast contains at least two elements and starts - ;; with the given symbol, return the second element. Else return 0. - (func $qq_unquote (param $ast i32) (param $sym i32) (result i32) - (LET $car 0 $cdr 0) - (if ($VAL0 $ast) (then - (local.set $car ($MEM_VAL1_ptr $ast)) - (if (i32.eq ($TYPE $car) (global.get $SYMBOL_T)) (then - (if (i32.eqz ($strcmp ($to_String $car) $sym)) (then - (local.set $cdr ($MEM_VAL0_ptr $ast)) - (if ($VAL0 $cdr) (then - (return ($MEM_VAL1_ptr $cdr)))))))))) - (return 0)) - - ;; Iteration on sequences for quasiquote (right reduce/fold). - (func $qq_foldr (param $xs i32) (result i32) - (if ($VAL0 $xs) (then - (return ($qq_loop ($MEM_VAL1_ptr $xs) ($qq_foldr ($MEM_VAL0_ptr $xs))))) - (else - (return ($INC_REF (global.get $EMPTY_LIST)))))) - - ;; Transition function for quasiquote right fold/reduce. - (func $qq_loop (param $elt i32) (param $acc i32) (result i32) - (LET $sym 0 $second 0 $res 0) - - ;; If elt is ('splice-unquote x) -> ('concat, x, acc) - (if (i32.eq ($TYPE $elt) (global.get $LIST_T)) (then - (local.set $second ($qq_unquote $elt "splice-unquote")) - (if $second (then - (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) - (local.set $res ($LIST3 $sym $second $acc)) - ;; release inner quasiquoted since outer list takes ownership - ($RELEASE $sym) - (return $res))))) - - ;; normal elt -> ('cons, (quasiquoted x), acc) - (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) - (local.set $second ($QUASIQUOTE $elt)) - (local.set $res ($LIST3 $sym $second $acc)) - ;; release inner quasiquoted since outer list takes ownership - ($RELEASE $second) - ($RELEASE $sym) - (return $res)) - - - (global $mac_stack (mut i32) (i32.const 0)) - (global $mac_stack_top (mut i32) (i32.const -1)) - - (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) - (local $mac_env i64) - (LET $ast $orig_ast - $mac 0) - (global.set $mac_stack (STATIC_ARRAY 2048)) ;; 512 * 4, TODO: move to init - (block $done - (loop $loop - (br_if $done - (OR (i32.ne ($TYPE $ast) (global.get $LIST_T)) ;; a list - (i32.eqz ($VAL0 $ast)) ;; non-empty - (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol - (global.get $SYMBOL_T)))) - (local.set $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) - (local.set $mac (i32.wrap_i64 (i64.shr_u $mac_env (i64.const 32)))) - (br_if $done (OR (i32.eqz (i32.wrap_i64 $mac_env)) ;; defined in env - (i32.ne ($TYPE $mac) ;; a macro - (global.get $MACRO_T)))) - - (local.set $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) - ;; PEND_A_LV - ;; if ast is not the first ast that was passed in, then add it - ;; to the pending release list. - (if (i32.ne $ast $orig_ast) - (then - (global.set $mac_stack_top - (i32.add (global.get $mac_stack_top) 1)) - (if (i32.ge_s (i32.mul (global.get $mac_stack_top) 4) 2048) ;; 512 * 4 - ($fatal 7 "Exhausted mac_stack!\n")) - (i32.store (i32.add - (global.get $mac_stack) - (i32.mul (global.get $mac_stack_top) 4)) - $ast))) - (br_if $done (global.get $error_type)) - - (br $loop) - ) - ) - $ast - ) - - (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) - (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 - $ret 0 $empty 0 $current 0) - - (if (global.get $error_type) (return 0)) - (local.set $type ($TYPE $ast)) - - ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) - - ;;; switch(type) - (block $done - (block $default (block (block - (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) - ;; symbol - ;; found/res returned as hi 32/lo 32 of i64 - (local.set $res ($ENV_GET $env $ast)) - (br $done)) - ;; list, vector, hashmap - ;; MAP_LOOP_START - (local.set $res ($MAP_LOOP_START $type)) - ;; push MAP_LOOP stack - ;;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (block $done - (loop $loop - ;; check if we are done evaluating the source sequence - (br_if $done (i32.eq ($VAL0 $ast) 0)) - - (if $skiplast - (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) - - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) - (else - (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) - (local.set $val2 $res) - - ;; if error, release the unattached element - (if (global.get $error_type) - (then - ($RELEASE $res) - (local.set $res 0) - (br $done))) - - ;; for hash-maps, copy the key (inc ref since we are going - ;; to release it below) - (if (i32.eq $type (global.get $HASHMAP_T)) - (then - (local.set $val3 $val2) - (local.set $val2 ($MEM_VAL1_ptr $ast)) - (drop ($INC_REF $val2)))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $ast ($MEM_VAL0_ptr $ast)) - - (br $loop) - ) - ) - ;; MAP_LOOP_DONE - (local.set $res $ret) - ;; EVAL_AST_RETURN: nothing to do - (br $done)) - ;; default - (local.set $res ($INC_REF $ast)) - ) - - $res - ) - - (func $MAL_GET_A1 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) - (func $MAL_GET_A2 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) - (func $MAL_GET_A3 (param $ast i32) (result i32) - ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) - (LET $ast $orig_ast - $env $orig_env - $orig_mac_stack_top (global.get $mac_stack_top) - $prev_ast 0 $prev_env 0 $res 0 $el 0 - $ftype 0 $f_args 0 $f 0 $args 0 - $a0 0 $a0sym 0 $a1 0 $a2 0 - $err 0) - - (block $EVAL_return - (loop $TCO_loop - - (local.set $f_args 0) - (local.set $f 0) - (local.set $args 0) - - (if (global.get $error_type) - (then - (local.set $res 0) - (br $EVAL_return))) - - ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (then - (local.set $res ($EVAL_AST $ast $env 0)) - (br $EVAL_return))) - - ;; APPLY_LIST - (local.set $ast ($MACROEXPAND $ast $env)) - ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) - - (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) - (then - (local.set $res ($EVAL_AST $ast $env 0)) - (br $EVAL_return))) - - (if ($EMPTY_Q $ast) - (then - (local.set $res ($INC_REF $ast)) - (br $EVAL_return))) - - (local.set $a0 ($MEM_VAL1_ptr $ast)) - (local.set $a0sym "") - (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) - (local.set $a0sym ($to_String $a0))) - - (if (i32.eqz ($strcmp "def!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - (br_if $EVAL_return (global.get $error_type)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res)) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "let*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - - ;; create new environment with outer as current environment - (local.set $prev_env $env) ;; save env for later release - (local.set $env ($ENV_NEW $env)) - - (block $done - (loop $loop - (br_if $done (i32.eqz ($VAL0 $a1))) - ;; eval current A1 odd element - (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) - - (br_if $done (global.get $error_type)) - - ;; set key/value in the let environment - (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) - ;; release our use, ENV_SET took ownership - ($RELEASE $res) - - ;; skip to the next pair of a1 elements - (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) - (br $loop) - ) - ) - - ;; release previous environment if not the current EVAL env - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - (local.set $ast $a2) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "do" $a0sym)) - (then - ;; EVAL the rest through second to last - (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) - (local.set $ast ($LAST $ast)) - ($RELEASE $ast) ;; we already own it via ast - ($RELEASE $el) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "quote" $a0sym)) - (then - (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "quasiquoteexpand" $a0sym)) - (then - (local.set $res ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) - (then - (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) - - ;; if we have already been here via TCO, release previous ast - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($EVAL $a2 $env)) - ($SET_TYPE $res (global.get $MACRO_T)) - (br_if $EVAL_return (global.get $error_type)) - - ;; set a1 in env to a2 - (local.set $res ($ENV_SET $env $a1 $res)) - (br $EVAL_return)) - (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) - (then - ;; since we are returning it unevaluated, inc the ref cnt - (local.set $res ($INC_REF ($MACROEXPAND - ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) - $env)))) - (else (if (i32.eqz ($strcmp "try*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $res ($EVAL $a1 $env)) - - ;; if there is no error, return - (br_if $EVAL_return (i32.eqz (global.get $error_type))) - ;; if there is an error and res is set, we need to free it - ($RELEASE $res) - ;; if there is no catch block then return - (br_if $EVAL_return - (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) - - ;; save the current environment for release - (local.set $prev_env $env) - ;; create environment for the catch block eval - (local.set $env ($ENV_NEW $env)) - - ;; set a1 and a2 from the catch block - (local.set $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) - (local.set $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) - - ;; create object for string errors - (if (i32.eq (global.get $error_type) 1) - (then - (local.set $err ($STRING (global.get $STRING_T) - (global.get $error_str)))) - (else - (local.set $err (global.get $error_val)))) - ;; bind the catch symbol to the error object - (drop ($ENV_SET $env $a1 $err)) - ;; release our use, env took ownership - ($RELEASE $err) - - ;; unset error for catch eval - (global.set $error_type 0) - (i32.store (global.get $error_str) (CHR "\x00")) - - ;; release previous environment if not the current EVAL env - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - (local.set $ast $a2) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "if" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $res ($EVAL $a1 $env)) - - (if (global.get $error_type) - (then (nop)) - (else (if (OR (i32.eq $res (global.get $NIL)) - (i32.eq $res (global.get $FALSE))) - (then - ($RELEASE $res) - ;; if no false case (A3), return nil - (if (i32.lt_u ($COUNT $ast) 4) - (then - (local.set $res ($INC_REF (global.get $NIL))) - (br $EVAL_return)) - (else - (local.set $ast ($MAL_GET_A3 $ast))))) - (else - ($RELEASE $res) - (local.set $ast ($MAL_GET_A2 $ast)))))) - (br $TCO_loop)) - (else (if (i32.eqz ($strcmp "fn*" $a0sym)) - (then - (local.set $a1 ($MAL_GET_A1 $ast)) - (local.set $a2 ($MAL_GET_A2 $ast)) - (local.set $res ($MALFUNC $a2 $a1 $env)) - (br $EVAL_return)) - (else - ;; EVAL_INVOKE - (local.set $res ($EVAL_AST $ast $env 0)) - (local.set $f_args $res) - - ;; if error, return f/args for release by caller - (if (global.get $error_type) - (then - (local.set $res $f_args) - (br $EVAL_return))) - - (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest - (local.set $f ($DEREF_META ($MEM_VAL1_ptr $f_args))) ;; value - - (local.set $ftype ($TYPE $f)) - (if (i32.eq $ftype (global.get $FUNCTION_T)) - (then - (if (i32.eq ($VAL0 $f) 0) ;; eval - (then - (local.set $res ($EVAL ($MEM_VAL1_ptr $args) - (global.get $repl_env)))) - (else - (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) - ;; release f/args - ($RELEASE $f_args) - (br $EVAL_return)) - (else (if (i32.eq $ftype (global.get $MALFUNC_T)) - (then - ;; save the current environment for release - (local.set $prev_env $env) - ;; create new environment using env and params stored in function - (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) - ($MEM_VAL1_ptr $f) $args)) - - ;; release previous environment if not the current EVAL env - ;; because our new env refers to it and we no longer need to - ;; track it (since we are TCO recurring) - (if (i32.ne $prev_env $orig_env) - (then - ($RELEASE $prev_env) - (local.set $prev_env 0))) - - ;; claim the AST before releasing the list containing it - (local.set $ast ($MEM_VAL0_ptr $f)) - (drop ($INC_REF $ast)) - - ;; if we have already been here via TCO, release previous - ;; ast - ;; PEND_A_LV - (if $prev_ast ($RELEASE $prev_ast)) - (local.set $prev_ast $ast) - - ;; release f/args - ($RELEASE $f_args) - - (br $TCO_loop)) - (else - ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) - (local.set $res 0) - ($RELEASE $f_args) - (br $EVAL_return))))))))))))))))))))))))))) - - ) ;; end of TCO_loop - ) ;; end of EVAL_return - - ;; EVAL_RETURN - (if (i32.ne $env $orig_env) ($RELEASE $env)) - (if $prev_ast ($RELEASE $prev_ast)) - - ;; release memory from MACROEXPAND - ;; TODO: needs to happen here so self-hosting doesn't leak - (block $done - (loop $loop - (br_if $done (i32.le_s (global.get $mac_stack_top) $orig_mac_stack_top)) - ($RELEASE (i32.load (i32.add - (global.get $mac_stack) - (i32.mul (global.get $mac_stack_top) 4)))) - (global.set $mac_stack_top - (i32.sub (global.get $mac_stack_top) 1)) - (br $loop) - ) - ) - - $res - ) - - ;; PRINT - (func $PRINT (param $ast i32) (result i32) - ($pr_str $ast 1) - ) - - ;; REPL - (func $RE (param $line i32 $env i32) (result i32) - (LET $mv1 0 $res 0) - (block $done - (local.set $mv1 ($READ $line)) - (br_if $done (global.get $error_type)) - - (local.set $res ($EVAL $mv1 $env)) - ) - - ;; release memory from MAL_READ - ($RELEASE $mv1) - $res - ) - - (func $REP (param $line i32 $env i32) (result i32) - (LET $mv2 0 $ms 0) - (block $done - (local.set $mv2 ($RE $line $env)) - (br_if $done (global.get $error_type)) - -;; ($PR_MEMORY -1 -1) - (local.set $ms ($PRINT $mv2)) - ) - - ;; release memory from RE - ($RELEASE $mv2) - $ms - ) - - (func $main (param $argc i32 $argv i32) (result i32) - (LET $line (STATIC_ARRAY 201) - $res 0 $repl_env 0 $ms 0 - ;; argument processing - $i 0 $ret 0 $empty 0 $current 0 $val2 0) - - ;; DEBUG -;; ($printf_1 "argc: 0x%x\n" $argc) -;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) -;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) -;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) -;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) -;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) - - (global.set $repl_env ($ENV_NEW (global.get $NIL))) - (local.set $repl_env (global.get $repl_env)) - - ;; core.EXT: defined in wasm - ($add_core_ns $repl_env) - (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) - - ($checkpoint_user_memory) - - ;; core.mal: defined using the language itself - ($RELEASE ($RE "(def! *host-language* \"WebAssembly\")" $repl_env)) - ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) - ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) - ($RELEASE ($RE "(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)))))))" $repl_env)) - - ;; Command line arguments - (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) - ;; push MAP_LOP stack - ;; empty = current = ret = res - (local.set $ret $res) - (local.set $current $res) - (local.set $empty $res) - - (local.set $i 2) - (block $done - (loop $loop - (br_if $done (i32.ge_u $i $argc)) - - (local.set $val2 ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv (i32.mul $i 4))))) - - ;; MAP_LOOP_UPDATE - (local.set $res ($MAP_LOOP_UPDATE - (global.get $LIST_T) $empty $current $val2 0)) - (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) - ;; if first element, set return to new element - (local.set $ret $res)) - ;; update current to point to new element - (local.set $current $res) - - (local.set $i (i32.add $i 1)) - (br $loop) - ) - ) - (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) - - - ;;($PR_MEMORY -1 -1) - - (if (i32.gt_u $argc 1) - (then - (drop ($ENV_SET_S $repl_env - "*FILE*" ($STRING (global.get $STRING_T) - (i32.load (i32.add $argv 4))))) - ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) - (if (global.get $error_type) - (then - ($printf_1 "Error: %s\n" (global.get $error_str)) - (return 1)) - (else - (return 0))))) - - ($RELEASE ($RE "(println (str \"Mal [\" *host-language* \"]\"))" $repl_env)) - - ;; Start REPL - (block $repl_done - (loop $repl_loop - (br_if $repl_done (i32.eqz ($readline "user> " $line))) - (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) - (local.set $res ($REP $line $repl_env)) - (if (global.get $error_type) - (then - (if (i32.eq 2 (global.get $error_type)) - (then - (local.set $ms ($pr_str (global.get $error_val) 1)) - ($printf_1 "Error: %s\n" ($to_String $ms)) - ($RELEASE $ms) - ($RELEASE (global.get $error_val))) - (else - ($printf_1 "Error: %s\n" (global.get $error_str)))) - (global.set $error_type 0)) - (else - ($printf_1 "%s\n" ($to_String $res)))) - ($RELEASE $res) - ;;($PR_MEMORY_SUMMARY_SMALL) - (br $repl_loop) - ) - ) - - ($print "\n") - ;;($PR_MEMORY -1 -1) - 0 - ) - -) - +(module $stepA_mal + + (global $repl_env (mut i32) (i32.const 0)) + + ;; READ + (func $READ (param $str i32) (result i32) + ($read_str $str) + ) + + ;; EVAL + + + (func $QUASIQUOTE (param $ast i32) (result i32) + (LET $type ($TYPE $ast) $res 0 $sym 0 $second 0) + + ;; symbol or map -> ('quote ast) + (if (OR (i32.eq $type (global.get $SYMBOL_T)) + (i32.eq $type (global.get $HASHMAP_T))) + (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "quote")) + (local.set $res ($LIST2 $sym $ast)) + ($RELEASE $sym) + (return $res))) + + ;; [xs..] -> ('vec (processed like a list)) + (if (i32.eq $type (global.get $VECTOR_T)) (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "vec")) + (local.set $second ($qq_foldr $ast)) + (local.set $res ($LIST2 $sym $second)) + ($RELEASE $sym) + ($RELEASE $second) + (return $res))) + + ;; If ast is not affected by eval, return it unchanged. + (if (i32.ne $type (global.get $LIST_T)) (then + (return ($INC_REF $ast)))) + + ;; (unquote x) -> x + (local.set $second ($qq_unquote $ast "unquote")) + (if $second (then + (return ($INC_REF $second)))) + + ;; ast is a normal list, iterate on its elements + (return ($qq_foldr $ast))) + + ;; Helper for quasiquote. + ;; If the given list ast contains at least two elements and starts + ;; with the given symbol, return the second element. Else return 0. + (func $qq_unquote (param $ast i32) (param $sym i32) (result i32) + (LET $car 0 $cdr 0) + (if ($VAL0 $ast) (then + (local.set $car ($MEM_VAL1_ptr $ast)) + (if (i32.eq ($TYPE $car) (global.get $SYMBOL_T)) (then + (if (i32.eqz ($strcmp ($to_String $car) $sym)) (then + (local.set $cdr ($MEM_VAL0_ptr $ast)) + (if ($VAL0 $cdr) (then + (return ($MEM_VAL1_ptr $cdr)))))))))) + (return 0)) + + ;; Iteration on sequences for quasiquote (right reduce/fold). + (func $qq_foldr (param $xs i32) (result i32) + (if ($VAL0 $xs) (then + (return ($qq_loop ($MEM_VAL1_ptr $xs) ($qq_foldr ($MEM_VAL0_ptr $xs))))) + (else + (return ($INC_REF (global.get $EMPTY_LIST)))))) + + ;; Transition function for quasiquote right fold/reduce. + (func $qq_loop (param $elt i32) (param $acc i32) (result i32) + (LET $sym 0 $second 0 $res 0) + + ;; If elt is ('splice-unquote x) -> ('concat, x, acc) + (if (i32.eq ($TYPE $elt) (global.get $LIST_T)) (then + (local.set $second ($qq_unquote $elt "splice-unquote")) + (if $second (then + (local.set $sym ($STRING (global.get $SYMBOL_T) "concat")) + (local.set $res ($LIST3 $sym $second $acc)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $sym) + (return $res))))) + + ;; normal elt -> ('cons, (quasiquoted x), acc) + (local.set $sym ($STRING (global.get $SYMBOL_T) "cons")) + (local.set $second ($QUASIQUOTE $elt)) + (local.set $res ($LIST3 $sym $second $acc)) + ;; release inner quasiquoted since outer list takes ownership + ($RELEASE $second) + ($RELEASE $sym) + (return $res)) + + + (global $mac_stack (mut i32) (i32.const 0)) + (global $mac_stack_top (mut i32) (i32.const -1)) + + (func $MACROEXPAND (param $orig_ast i32 $env i32) (result i32) + (local $mac_env i64) + (LET $ast $orig_ast + $mac 0) + (global.set $mac_stack (STATIC_ARRAY 2048)) ;; 512 * 4, TODO: move to init + (block $done + (loop $loop + (br_if $done + (OR (i32.ne ($TYPE $ast) (global.get $LIST_T)) ;; a list + (i32.eqz ($VAL0 $ast)) ;; non-empty + (i32.ne ($TYPE ($MEM_VAL1_ptr $ast)) ;; leading symbol + (global.get $SYMBOL_T)))) + (local.set $mac_env ($ENV_FIND $env ($MEM_VAL1_ptr $ast))) + (local.set $mac (i32.wrap_i64 (i64.shr_u $mac_env (i64.const 32)))) + (br_if $done (OR (i32.eqz (i32.wrap_i64 $mac_env)) ;; defined in env + (i32.ne ($TYPE $mac) ;; a macro + (global.get $MACRO_T)))) + + (local.set $ast ($APPLY $mac ($MEM_VAL0_ptr $ast))) + ;; PEND_A_LV + ;; if ast is not the first ast that was passed in, then add it + ;; to the pending release list. + (if (i32.ne $ast $orig_ast) + (then + (global.set $mac_stack_top + (i32.add (global.get $mac_stack_top) 1)) + (if (i32.ge_s (i32.mul (global.get $mac_stack_top) 4) 2048) ;; 512 * 4 + ($fatal 7 "Exhausted mac_stack!\n")) + (i32.store (i32.add + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)) + $ast))) + (br_if $done (global.get $error_type)) + + (br $loop) + ) + ) + $ast + ) + + (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32) + (LET $res 0 $val2 0 $val3 0 $type 0 $found 0 + $ret 0 $empty 0 $current 0) + + (if (global.get $error_type) (return 0)) + (local.set $type ($TYPE $ast)) + + ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast) + + ;;; switch(type) + (block $done + (block $default (block (block + (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type)) + ;; symbol + ;; found/res returned as hi 32/lo 32 of i64 + (local.set $res ($ENV_GET $env $ast)) + (br $done)) + ;; list, vector, hashmap + ;; MAP_LOOP_START + (local.set $res ($MAP_LOOP_START $type)) + ;; push MAP_LOOP stack + ;;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (block $done + (loop $loop + ;; check if we are done evaluating the source sequence + (br_if $done (i32.eq ($VAL0 $ast) 0)) + + (if $skiplast + (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast))))) + + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env))) + (else + (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env)))) + (local.set $val2 $res) + + ;; if error, release the unattached element + (if (global.get $error_type) + (then + ($RELEASE $res) + (local.set $res 0) + (br $done))) + + ;; for hash-maps, copy the key (inc ref since we are going + ;; to release it below) + (if (i32.eq $type (global.get $HASHMAP_T)) + (then + (local.set $val3 $val2) + (local.set $val2 ($MEM_VAL1_ptr $ast)) + (drop ($INC_REF $val2)))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $ast ($MEM_VAL0_ptr $ast)) + + (br $loop) + ) + ) + ;; MAP_LOOP_DONE + (local.set $res $ret) + ;; EVAL_AST_RETURN: nothing to do + (br $done)) + ;; default + (local.set $res ($INC_REF $ast)) + ) + + $res + ) + + (func $MAL_GET_A1 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))) + (func $MAL_GET_A2 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))) + (func $MAL_GET_A3 (param $ast i32) (result i32) + ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32) + (LET $ast $orig_ast + $env $orig_env + $orig_mac_stack_top (global.get $mac_stack_top) + $prev_ast 0 $prev_env 0 $res 0 $el 0 + $ftype 0 $f_args 0 $f 0 $args 0 + $a0 0 $a0sym 0 $a1 0 $a2 0 + $err 0) + + (block $EVAL_return + (loop $TCO_loop + + (local.set $f_args 0) + (local.set $f 0) + (local.set $args 0) + + (if (global.get $error_type) + (then + (local.set $res 0) + (br $EVAL_return))) + + ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (then + (local.set $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + ;; APPLY_LIST + (local.set $ast ($MACROEXPAND $ast $env)) + ;;($PR_VALUE ">>> >>> EVAL ast: '%s'\n" $ast) + + (if (i32.ne ($TYPE $ast) (global.get $LIST_T)) + (then + (local.set $res ($EVAL_AST $ast $env 0)) + (br $EVAL_return))) + + (if ($EMPTY_Q $ast) + (then + (local.set $res ($INC_REF $ast)) + (br $EVAL_return))) + + (local.set $a0 ($MEM_VAL1_ptr $ast)) + (local.set $a0sym "") + (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T)) + (local.set $a0sym ($to_String $a0))) + + (if (i32.eqz ($strcmp "def!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + (br_if $EVAL_return (global.get $error_type)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "let*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + + ;; create new environment with outer as current environment + (local.set $prev_env $env) ;; save env for later release + (local.set $env ($ENV_NEW $env)) + + (block $done + (loop $loop + (br_if $done (i32.eqz ($VAL0 $a1))) + ;; eval current A1 odd element + (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env)) + + (br_if $done (global.get $error_type)) + + ;; set key/value in the let environment + (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res)) + ;; release our use, ENV_SET took ownership + ($RELEASE $res) + + ;; skip to the next pair of a1 elements + (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1))) + (br $loop) + ) + ) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + (local.set $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "do" $a0sym)) + (then + ;; EVAL the rest through second to last + (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1)) + (local.set $ast ($LAST $ast)) + ($RELEASE $ast) ;; we already own it via ast + ($RELEASE $el) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "quote" $a0sym)) + (then + (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquoteexpand" $a0sym)) + (then + (local.set $res ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "quasiquote" $a0sym)) + (then + (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))) + + ;; if we have already been here via TCO, release previous ast + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "defmacro!" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($EVAL $a2 $env)) + ($SET_TYPE $res (global.get $MACRO_T)) + (br_if $EVAL_return (global.get $error_type)) + + ;; set a1 in env to a2 + (local.set $res ($ENV_SET $env $a1 $res)) + (br $EVAL_return)) + (else (if (i32.eqz ($strcmp "macroexpand" $a0sym)) + (then + ;; since we are returning it unevaluated, inc the ref cnt + (local.set $res ($INC_REF ($MACROEXPAND + ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)) + $env)))) + (else (if (i32.eqz ($strcmp "try*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) + + ;; if there is no error, return + (br_if $EVAL_return (i32.eqz (global.get $error_type))) + ;; if there is an error and res is set, we need to free it + ($RELEASE $res) + ;; if there is no catch block then return + (br_if $EVAL_return + (i32.eqz ($VAL0 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))) + + ;; save the current environment for release + (local.set $prev_env $env) + ;; create environment for the catch block eval + (local.set $env ($ENV_NEW $env)) + + ;; set a1 and a2 from the catch block + (local.set $a1 ($MAL_GET_A1 ($MAL_GET_A2 $ast))) + (local.set $a2 ($MAL_GET_A2 ($MAL_GET_A2 $ast))) + + ;; create object for string errors + (if (i32.eq (global.get $error_type) 1) + (then + (local.set $err ($STRING (global.get $STRING_T) + (global.get $error_str)))) + (else + (local.set $err (global.get $error_val)))) + ;; bind the catch symbol to the error object + (drop ($ENV_SET $env $a1 $err)) + ;; release our use, env took ownership + ($RELEASE $err) + + ;; unset error for catch eval + (global.set $error_type 0) + (i32.store (global.get $error_str) (CHR "\x00")) + + ;; release previous environment if not the current EVAL env + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + (local.set $ast $a2) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "if" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $res ($EVAL $a1 $env)) + + (if (global.get $error_type) + (then (nop)) + (else (if (OR (i32.eq $res (global.get $NIL)) + (i32.eq $res (global.get $FALSE))) + (then + ($RELEASE $res) + ;; if no false case (A3), return nil + (if (i32.lt_u ($COUNT $ast) 4) + (then + (local.set $res ($INC_REF (global.get $NIL))) + (br $EVAL_return)) + (else + (local.set $ast ($MAL_GET_A3 $ast))))) + (else + ($RELEASE $res) + (local.set $ast ($MAL_GET_A2 $ast)))))) + (br $TCO_loop)) + (else (if (i32.eqz ($strcmp "fn*" $a0sym)) + (then + (local.set $a1 ($MAL_GET_A1 $ast)) + (local.set $a2 ($MAL_GET_A2 $ast)) + (local.set $res ($MALFUNC $a2 $a1 $env)) + (br $EVAL_return)) + (else + ;; EVAL_INVOKE + (local.set $res ($EVAL_AST $ast $env 0)) + (local.set $f_args $res) + + ;; if error, return f/args for release by caller + (if (global.get $error_type) + (then + (local.set $res $f_args) + (br $EVAL_return))) + + (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest + (local.set $f ($DEREF_META ($MEM_VAL1_ptr $f_args))) ;; value + + (local.set $ftype ($TYPE $f)) + (if (i32.eq $ftype (global.get $FUNCTION_T)) + (then + (if (i32.eq ($VAL0 $f) 0) ;; eval + (then + (local.set $res ($EVAL ($MEM_VAL1_ptr $args) + (global.get $repl_env)))) + (else + (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f))))) + ;; release f/args + ($RELEASE $f_args) + (br $EVAL_return)) + (else (if (i32.eq $ftype (global.get $MALFUNC_T)) + (then + ;; save the current environment for release + (local.set $prev_env $env) + ;; create new environment using env and params stored in function + (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f) + ($MEM_VAL1_ptr $f) $args)) + + ;; release previous environment if not the current EVAL env + ;; because our new env refers to it and we no longer need to + ;; track it (since we are TCO recurring) + (if (i32.ne $prev_env $orig_env) + (then + ($RELEASE $prev_env) + (local.set $prev_env 0))) + + ;; claim the AST before releasing the list containing it + (local.set $ast ($MEM_VAL0_ptr $f)) + (drop ($INC_REF $ast)) + + ;; if we have already been here via TCO, release previous + ;; ast + ;; PEND_A_LV + (if $prev_ast ($RELEASE $prev_ast)) + (local.set $prev_ast $ast) + + ;; release f/args + ($RELEASE $f_args) + + (br $TCO_loop)) + (else + ($THROW_STR_1 "apply of non-function type: %d\n" $ftype) + (local.set $res 0) + ($RELEASE $f_args) + (br $EVAL_return))))))))))))))))))))))))))) + + ) ;; end of TCO_loop + ) ;; end of EVAL_return + + ;; EVAL_RETURN + (if (i32.ne $env $orig_env) ($RELEASE $env)) + (if $prev_ast ($RELEASE $prev_ast)) + + ;; release memory from MACROEXPAND + ;; TODO: needs to happen here so self-hosting doesn't leak + (block $done + (loop $loop + (br_if $done (i32.le_s (global.get $mac_stack_top) $orig_mac_stack_top)) + ($RELEASE (i32.load (i32.add + (global.get $mac_stack) + (i32.mul (global.get $mac_stack_top) 4)))) + (global.set $mac_stack_top + (i32.sub (global.get $mac_stack_top) 1)) + (br $loop) + ) + ) + + $res + ) + + ;; PRINT + (func $PRINT (param $ast i32) (result i32) + ($pr_str $ast 1) + ) + + ;; REPL + (func $RE (param $line i32 $env i32) (result i32) + (LET $mv1 0 $res 0) + (block $done + (local.set $mv1 ($READ $line)) + (br_if $done (global.get $error_type)) + + (local.set $res ($EVAL $mv1 $env)) + ) + + ;; release memory from MAL_READ + ($RELEASE $mv1) + $res + ) + + (func $REP (param $line i32 $env i32) (result i32) + (LET $mv2 0 $ms 0) + (block $done + (local.set $mv2 ($RE $line $env)) + (br_if $done (global.get $error_type)) + +;; ($PR_MEMORY -1 -1) + (local.set $ms ($PRINT $mv2)) + ) + + ;; release memory from RE + ($RELEASE $mv2) + $ms + ) + + (func $main (param $argc i32 $argv i32) (result i32) + (LET $line (STATIC_ARRAY 201) + $res 0 $repl_env 0 $ms 0 + ;; argument processing + $i 0 $ret 0 $empty 0 $current 0 $val2 0) + + ;; DEBUG +;; ($printf_1 "argc: 0x%x\n" $argc) +;; ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase)) +;; ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start)) +;; ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end)) +;; ($printf_1 "mem: 0x%x\n" (global.get $mem)) +;; ($printf_1 "string_mem: %d\n" (global.get $string_mem)) + + (global.set $repl_env ($ENV_NEW (global.get $NIL))) + (local.set $repl_env (global.get $repl_env)) + + ;; core.EXT: defined in wasm + ($add_core_ns $repl_env) + (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0))) + + ($checkpoint_user_memory) + + ;; core.mal: defined using the language itself + ($RELEASE ($RE "(def! *host-language* \"WebAssembly\")" $repl_env)) + ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env)) + ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env)) + ($RELEASE ($RE "(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)))))))" $repl_env)) + + ;; Command line arguments + (local.set $res ($MAP_LOOP_START (global.get $LIST_T))) + ;; push MAP_LOP stack + ;; empty = current = ret = res + (local.set $ret $res) + (local.set $current $res) + (local.set $empty $res) + + (local.set $i 2) + (block $done + (loop $loop + (br_if $done (i32.ge_u $i $argc)) + + (local.set $val2 ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv (i32.mul $i 4))))) + + ;; MAP_LOOP_UPDATE + (local.set $res ($MAP_LOOP_UPDATE + (global.get $LIST_T) $empty $current $val2 0)) + (if (i32.le_u $current (global.get $EMPTY_HASHMAP)) + ;; if first element, set return to new element + (local.set $ret $res)) + ;; update current to point to new element + (local.set $current $res) + + (local.set $i (i32.add $i 1)) + (br $loop) + ) + ) + (drop ($ENV_SET_S $repl_env "*ARGV*" $ret)) + + + ;;($PR_MEMORY -1 -1) + + (if (i32.gt_u $argc 1) + (then + (drop ($ENV_SET_S $repl_env + "*FILE*" ($STRING (global.get $STRING_T) + (i32.load (i32.add $argv 4))))) + ($RELEASE ($RE "(load-file *FILE*)" $repl_env)) + (if (global.get $error_type) + (then + ($printf_1 "Error: %s\n" (global.get $error_str)) + (return 1)) + (else + (return 0))))) + + ($RELEASE ($RE "(println (str \"Mal [\" *host-language* \"]\"))" $repl_env)) + + ;; Start REPL + (block $repl_done + (loop $repl_loop + (br_if $repl_done (i32.eqz ($readline "user> " $line))) + (br_if $repl_loop (i32.eq (i32.load8_u $line) 0)) + (local.set $res ($REP $line $repl_env)) + (if (global.get $error_type) + (then + (if (i32.eq 2 (global.get $error_type)) + (then + (local.set $ms ($pr_str (global.get $error_val) 1)) + ($printf_1 "Error: %s\n" ($to_String $ms)) + ($RELEASE $ms) + ($RELEASE (global.get $error_val))) + (else + ($printf_1 "Error: %s\n" (global.get $error_str)))) + (global.set $error_type 0)) + (else + ($printf_1 "%s\n" ($to_String $res)))) + ($RELEASE $res) + ;;($PR_MEMORY_SUMMARY_SMALL) + (br $repl_loop) + ) + ) + + ($print "\n") + ;;($PR_MEMORY -1 -1) + 0 + ) + +) + diff --git a/impls/wasm/string.wam b/impls/wasm/string.wam index 25b6ed094d..34e28ad051 100644 --- a/impls/wasm/string.wam +++ b/impls/wasm/string.wam @@ -1,215 +1,215 @@ -(module $string - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Copy len bytes from src to dst - ;; Returns len - (func $memmove (param $dst i32 $src i32 $len i32) - (LET $idx 0) - (loop $copy - (i32.store8 (i32.add $idx $dst) - (i32.load8_u (i32.add $idx $src))) - (local.set $idx (i32.add 1 $idx)) - (br_if $copy (i32.lt_u $idx $len)) - ) - ) - - (func $strlen (param $str i32) (result i32) - (LET $cur $str) - (loop $count - (if (i32.ne 0 (i32.load8_u $cur)) - (then - (local.set $cur (i32.add $cur 1)) - (br $count))) - ) - (i32.sub $cur $str) - ) - - ;; Based on https://stackoverflow.com/a/25705264/471795 - ;; This could be made much more efficient - (func $strstr (param $haystack i32 $needle i32) (result i32) - (LET $i 0 - $needle_len ($strlen $needle) - $len ($strlen $haystack)) - - (if (i32.eq $needle_len 0) (return $haystack)) - - (local.set $i 0) - (block $done - (loop $loop - (if (i32.gt_s $i (i32.sub $len $needle_len)) (br $done)) - - (if (AND (i32.eq (i32.load8_u $haystack) - (i32.load8_u $needle)) - (i32.eqz ($strncmp $haystack $needle $needle_len))) - (return $haystack)) - (local.set $haystack (i32.add $haystack 1)) - (local.set $i (i32.add $i 1)) - (br $loop) - ) - ) - 0 - ) - - (func $atoi (param $str i32) (result i32) - (LET $acc 0 - $i 0 - $neg 0 - $ch 0) - (block $done - (loop $loop - (local.set $ch (i32.load8_u (i32.add $str $i))) - (if (AND (i32.ne $ch (CHR "-")) - (OR (i32.lt_u $ch (CHR "0")) - (i32.gt_u $ch (CHR "9")))) - (br $done)) - (local.set $i (i32.add $i 1)) - (if (i32.eq $ch (CHR "-")) - (then - (local.set $neg 1)) - (else - (local.set $acc (i32.add (i32.mul $acc 10) - (i32.sub $ch (CHR "0")))))) - (br $loop) - ) - ) - (if (result i32) $neg - (then (i32.sub 0 $acc)) - (else $acc)) - ) - - (func $strcmp (param $s1 i32 $s2 i32) (result i32) - (block $done - (loop $loop - (if (OR (i32.eqz (i32.load8_u $s1)) (i32.eqz (i32.load8_u $s2))) - (br $done)) - (if (i32.ne (i32.load8_u $s1) (i32.load8_u $s2)) - (br $done)) - (local.set $s1 (i32.add $s1 1)) - (local.set $s2 (i32.add $s2 1)) - (br $loop) - ) - ) - (if (result i32) (i32.eq (i32.load8_u $s1) (i32.load8_u $s2)) - (then 0) - (else - (if (result i32) (i32.lt_u (i32.load8_u $s1) (i32.load8_u $s2)) - (then -1) - (else 1)))) - ) - - (func $strncmp (param $s1 i32 $s2 i32 $len i32) (result i32) - (LET $i 0) - (if (i32.eq $len 0) (return 0)) - (block $done - (loop $loop - (if (i32.ge_u $i $len) (br $done)) - (if (i32.eqz (i32.load8_u (i32.add $i $s1))) (br $done)) - (if (i32.ne (i32.load8_u (i32.add $i $s1)) - (i32.load8_u (i32.add $i $s2))) (br $done)) - (local.set $i (i32.add $i 1)) - (br $loop) - ) - ) - (if (OR (i32.eq $i $len) - (i32.eq (i32.load8_u (i32.add $i $s1)) - (i32.load8_u (i32.add $i $s2)))) - (return 0)) - (if (result i32) (i32.lt_u (i32.load8_u (i32.add $i $s1)) - (i32.load8_u (i32.add $i $s2))) - (then -1) - (else 1)) - ) - - ;; Writes new string to grass with all needles in haystack replaced. - ;; If the length of replace is equal to of less than needle then - ;; grass can be NULL. - ;; Returns length of grass. - (func $REPLACE3 (param $grass i32 $haystack i32 - $needle0 i32 $replace0 i32 - $needle1 i32 $replace1 i32 - $needle2 i32 $replace2 i32) (result i32) - (LET $haystack_len ($strlen $haystack) - $src_str $haystack - $dst_str $grass - $s 0 $found_tmp 0 $found 0 - $needle 0 $replace 0 $needle_len 0 $replace_len 0 - $replace_s 0 $replace_len_s 0 $needle_len_s 0) - - ;; in-place - (if (i32.eqz $grass) - (then - ;; check that we aren't expanding in place - (local.set $s 0) - (block $done - (loop $loop - (if (i32.ge_u $s 3) (br $done)) - (local.set $needle (if (result i32) (i32.eq $s 0) $needle0 - (if (result i32) (i32.eq $s 1) $needle1 - $needle2))) - (local.set $replace (if (result i32) (i32.eq $s 0) $replace0 - (if (result i32) (i32.eq $s 1) $replace1 - $replace2))) - (local.set $needle_len ($strlen $needle)) - (local.set $replace_len ($strlen $replace)) - (if (i32.gt_u $replace_len $needle_len) - ($fatal 7 "REPLACE: invalid expanding in-place call\n")) - (local.set $s (i32.add $s 1)) - (br $loop) - ) - ) - (local.set $grass $haystack) - (local.set $dst_str $grass))) - - (block $done1 - (loop $loop1 - (if (i32.ge_s (i32.sub $src_str $haystack) $haystack_len) - (br $done1)) - - ;; Find the earliest match - (local.set $found 0) - (local.set $s 0) - (block $done2 - (loop $loop2 - (if (i32.ge_u $s 3) (br $done2)) - (local.set $needle (if (result i32) (i32.eq $s 0) $needle0 - (if (result i32) (i32.eq $s 1) $needle1 - $needle2))) - (local.set $replace (if (result i32) (i32.eq $s 0) $replace0 - (if (result i32) (i32.eq $s 1) $replace1 - $replace2))) - (local.set $s (i32.add $s 1)) - (local.set $found_tmp ($strstr $src_str $needle)) - (if (i32.eqz $found_tmp) (br $loop2)) - (if (OR (i32.eqz $found) (i32.lt_s $found_tmp $found)) - (then - (local.set $found $found_tmp) - (local.set $needle_len_s ($strlen $needle)) - (local.set $replace_s $replace) - (local.set $replace_len_s ($strlen $replace)))) - (br $loop2) - ) - ) - (if (i32.eqz $found) (br $done1)) - ;; copy before the match - ($memmove $dst_str $src_str (i32.add (i32.sub $found $src_str) 1)) - (local.set $dst_str (i32.add $dst_str (i32.sub $found $src_str))) - ;; add the replace string - ($memmove $dst_str $replace_s (i32.add $replace_len_s 1)) - (local.set $dst_str (i32.add $dst_str $replace_len_s)) - ;; Move to after the match - (local.set $src_str (i32.add $found $needle_len_s)) - (br $loop1) - ) - ) - - ;; Copy the left-over - ($memmove $dst_str $src_str ($strlen $src_str)) - (local.set $dst_str (i32.add $dst_str ($strlen $src_str))) - (i32.store8 $dst_str (CHR "\x00")) - - (i32.sub $dst_str $grass) - ) - -) - +(module $string + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Copy len bytes from src to dst + ;; Returns len + (func $memmove (param $dst i32 $src i32 $len i32) + (LET $idx 0) + (loop $copy + (i32.store8 (i32.add $idx $dst) + (i32.load8_u (i32.add $idx $src))) + (local.set $idx (i32.add 1 $idx)) + (br_if $copy (i32.lt_u $idx $len)) + ) + ) + + (func $strlen (param $str i32) (result i32) + (LET $cur $str) + (loop $count + (if (i32.ne 0 (i32.load8_u $cur)) + (then + (local.set $cur (i32.add $cur 1)) + (br $count))) + ) + (i32.sub $cur $str) + ) + + ;; Based on https://stackoverflow.com/a/25705264/471795 + ;; This could be made much more efficient + (func $strstr (param $haystack i32 $needle i32) (result i32) + (LET $i 0 + $needle_len ($strlen $needle) + $len ($strlen $haystack)) + + (if (i32.eq $needle_len 0) (return $haystack)) + + (local.set $i 0) + (block $done + (loop $loop + (if (i32.gt_s $i (i32.sub $len $needle_len)) (br $done)) + + (if (AND (i32.eq (i32.load8_u $haystack) + (i32.load8_u $needle)) + (i32.eqz ($strncmp $haystack $needle $needle_len))) + (return $haystack)) + (local.set $haystack (i32.add $haystack 1)) + (local.set $i (i32.add $i 1)) + (br $loop) + ) + ) + 0 + ) + + (func $atoi (param $str i32) (result i32) + (LET $acc 0 + $i 0 + $neg 0 + $ch 0) + (block $done + (loop $loop + (local.set $ch (i32.load8_u (i32.add $str $i))) + (if (AND (i32.ne $ch (CHR "-")) + (OR (i32.lt_u $ch (CHR "0")) + (i32.gt_u $ch (CHR "9")))) + (br $done)) + (local.set $i (i32.add $i 1)) + (if (i32.eq $ch (CHR "-")) + (then + (local.set $neg 1)) + (else + (local.set $acc (i32.add (i32.mul $acc 10) + (i32.sub $ch (CHR "0")))))) + (br $loop) + ) + ) + (if (result i32) $neg + (then (i32.sub 0 $acc)) + (else $acc)) + ) + + (func $strcmp (param $s1 i32 $s2 i32) (result i32) + (block $done + (loop $loop + (if (OR (i32.eqz (i32.load8_u $s1)) (i32.eqz (i32.load8_u $s2))) + (br $done)) + (if (i32.ne (i32.load8_u $s1) (i32.load8_u $s2)) + (br $done)) + (local.set $s1 (i32.add $s1 1)) + (local.set $s2 (i32.add $s2 1)) + (br $loop) + ) + ) + (if (result i32) (i32.eq (i32.load8_u $s1) (i32.load8_u $s2)) + (then 0) + (else + (if (result i32) (i32.lt_u (i32.load8_u $s1) (i32.load8_u $s2)) + (then -1) + (else 1)))) + ) + + (func $strncmp (param $s1 i32 $s2 i32 $len i32) (result i32) + (LET $i 0) + (if (i32.eq $len 0) (return 0)) + (block $done + (loop $loop + (if (i32.ge_u $i $len) (br $done)) + (if (i32.eqz (i32.load8_u (i32.add $i $s1))) (br $done)) + (if (i32.ne (i32.load8_u (i32.add $i $s1)) + (i32.load8_u (i32.add $i $s2))) (br $done)) + (local.set $i (i32.add $i 1)) + (br $loop) + ) + ) + (if (OR (i32.eq $i $len) + (i32.eq (i32.load8_u (i32.add $i $s1)) + (i32.load8_u (i32.add $i $s2)))) + (return 0)) + (if (result i32) (i32.lt_u (i32.load8_u (i32.add $i $s1)) + (i32.load8_u (i32.add $i $s2))) + (then -1) + (else 1)) + ) + + ;; Writes new string to grass with all needles in haystack replaced. + ;; If the length of replace is equal to of less than needle then + ;; grass can be NULL. + ;; Returns length of grass. + (func $REPLACE3 (param $grass i32 $haystack i32 + $needle0 i32 $replace0 i32 + $needle1 i32 $replace1 i32 + $needle2 i32 $replace2 i32) (result i32) + (LET $haystack_len ($strlen $haystack) + $src_str $haystack + $dst_str $grass + $s 0 $found_tmp 0 $found 0 + $needle 0 $replace 0 $needle_len 0 $replace_len 0 + $replace_s 0 $replace_len_s 0 $needle_len_s 0) + + ;; in-place + (if (i32.eqz $grass) + (then + ;; check that we aren't expanding in place + (local.set $s 0) + (block $done + (loop $loop + (if (i32.ge_u $s 3) (br $done)) + (local.set $needle (if (result i32) (i32.eq $s 0) $needle0 + (if (result i32) (i32.eq $s 1) $needle1 + $needle2))) + (local.set $replace (if (result i32) (i32.eq $s 0) $replace0 + (if (result i32) (i32.eq $s 1) $replace1 + $replace2))) + (local.set $needle_len ($strlen $needle)) + (local.set $replace_len ($strlen $replace)) + (if (i32.gt_u $replace_len $needle_len) + ($fatal 7 "REPLACE: invalid expanding in-place call\n")) + (local.set $s (i32.add $s 1)) + (br $loop) + ) + ) + (local.set $grass $haystack) + (local.set $dst_str $grass))) + + (block $done1 + (loop $loop1 + (if (i32.ge_s (i32.sub $src_str $haystack) $haystack_len) + (br $done1)) + + ;; Find the earliest match + (local.set $found 0) + (local.set $s 0) + (block $done2 + (loop $loop2 + (if (i32.ge_u $s 3) (br $done2)) + (local.set $needle (if (result i32) (i32.eq $s 0) $needle0 + (if (result i32) (i32.eq $s 1) $needle1 + $needle2))) + (local.set $replace (if (result i32) (i32.eq $s 0) $replace0 + (if (result i32) (i32.eq $s 1) $replace1 + $replace2))) + (local.set $s (i32.add $s 1)) + (local.set $found_tmp ($strstr $src_str $needle)) + (if (i32.eqz $found_tmp) (br $loop2)) + (if (OR (i32.eqz $found) (i32.lt_s $found_tmp $found)) + (then + (local.set $found $found_tmp) + (local.set $needle_len_s ($strlen $needle)) + (local.set $replace_s $replace) + (local.set $replace_len_s ($strlen $replace)))) + (br $loop2) + ) + ) + (if (i32.eqz $found) (br $done1)) + ;; copy before the match + ($memmove $dst_str $src_str (i32.add (i32.sub $found $src_str) 1)) + (local.set $dst_str (i32.add $dst_str (i32.sub $found $src_str))) + ;; add the replace string + ($memmove $dst_str $replace_s (i32.add $replace_len_s 1)) + (local.set $dst_str (i32.add $dst_str $replace_len_s)) + ;; Move to after the match + (local.set $src_str (i32.add $found $needle_len_s)) + (br $loop1) + ) + ) + + ;; Copy the left-over + ($memmove $dst_str $src_str ($strlen $src_str)) + (local.set $dst_str (i32.add $dst_str ($strlen $src_str))) + (i32.store8 $dst_str (CHR "\x00")) + + (i32.sub $dst_str $grass) + ) + +) + diff --git a/impls/wasm/types.wam b/impls/wasm/types.wam index 280fc0eb7a..7b2a613bb8 100644 --- a/impls/wasm/types.wam +++ b/impls/wasm/types.wam @@ -1,417 +1,417 @@ -;; Mal value memory layout -;; type words -;; ---------- ---------- -;; nil ref/ 0 | 0 | | -;; false ref/ 1 | 0 | | -;; true ref/ 1 | 1 | | -;; integer ref/ 2 | int | | -;; float ref/ 3 | ??? | | -;; string/kw ref/ 4 | string ptr | | -;; symbol ref/ 5 | string ptr | | -;; list ref/ 6 | next mem idx | val mem idx | -;; vector ref/ 7 | next mem idx | val mem idx | -;; hashmap ref/ 8 | next mem idx | key mem idx | val mem idx -;; function ref/ 9 | fn idx | | -;; mal function ref/10 | body mem idx | param mem idx | env mem idx -;; macro fn ref/11 | body mem idx | param mem idx | env mem idx -;; atom ref/12 | val mem idx | | -;; environment ref/13 | hmap mem idx | outer mem idx | -;; metadata ref/14 | obj mem idx | meta mem idx | -;; FREE sz/15 | next mem idx | | - -(module $types - - (global $NIL_T i32 0) - (global $BOOLEAN_T i32 1) - (global $INTEGER_T i32 2) - (global $FLOAT_T i32 3) - (global $STRING_T i32 4) - (global $SYMBOL_T i32 5) - (global $LIST_T i32 6) - (global $VECTOR_T i32 7) - (global $HASHMAP_T i32 8) - (global $FUNCTION_T i32 9) - (global $MALFUNC_T i32 10) - (global $MACRO_T i32 11) - (global $ATOM_T i32 12) - (global $ENVIRONMENT_T i32 13) - (global $METADATA_T i32 14) - (global $FREE_T i32 15) - - (global $error_type (mut i32) 0) - (global $error_val (mut i32) 0) - ;; Index into static string memory (static.wast) - (global $error_str (mut i32) 0) - - (global $NIL (mut i32) 0) - (global $FALSE (mut i32) 0) - (global $TRUE (mut i32) 0) - (global $EMPTY_LIST (mut i32) 0) - (global $EMPTY_VECTOR (mut i32) 0) - (global $EMPTY_HASHMAP (mut i32) 0) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; General functions - - (func $INC_REF (param $mv i32) (result i32) - (i32.store $mv (i32.add (i32.load $mv) 32)) - $mv - ) - - (func $TRUE_FALSE (param $val i32) (result i32) - ($INC_REF (if (result i32) $val (global.get $TRUE) (global.get $FALSE))) - ) - - (func $THROW_STR_0 (param $fmt i32) - (drop ($sprintf_1 (global.get $error_str) $fmt "")) - (global.set $error_type 1) - ) - - (func $THROW_STR_1 (param $fmt i32) (param $v0 i32) - (drop ($sprintf_1 (global.get $error_str) $fmt $v0)) - (global.set $error_type 1) - ) - - (func $EQUAL_Q (param $a i32 $b i32) (result i32) - (LET $ta ($TYPE $a) - $tb ($TYPE $b)) - - (if (AND (OR (i32.eq $ta (global.get $LIST_T)) - (i32.eq $ta (global.get $VECTOR_T))) - (OR (i32.eq $tb (global.get $LIST_T)) - (i32.eq $tb (global.get $VECTOR_T)))) - (then - ;; EQUAL_Q_SEQ - (block $done - (loop $loop - (if (OR (i32.eq ($VAL0 $a) 0) (i32.eq ($VAL0 $b) 0)) - (br $done)) - (if ($EQUAL_Q ($MEM_VAL1_ptr $a) ($MEM_VAL1_ptr $b)) - (then - (local.set $a ($MEM_VAL0_ptr $a)) - (local.set $b ($MEM_VAL0_ptr $b))) - (else - (return 0))) - (br $loop) - ) - ) - (return (AND (i32.eq ($VAL0 $a) 0) (i32.eq ($VAL0 $b) 0)))) - (else (if (AND (i32.eq $ta (global.get $HASHMAP_T)) - (i32.eq $tb (global.get $HASHMAP_T))) - ;; EQUAL_Q_HM - (then (return 1)) - ;; TODO: remove this once strings are interned - (else (if (OR (AND (i32.eq $ta (global.get $STRING_T)) - (i32.eq $tb (global.get $STRING_T))) - (AND (i32.eq $ta (global.get $SYMBOL_T)) - (i32.eq $tb (global.get $SYMBOL_T)))) - (then (return (i32.eqz ($strcmp ($to_String $a) ($to_String $b))))) - (else - (return (AND (i32.eq $ta $tb) - (i32.eq ($VAL0 $a) ($VAL0 $b)))))))))) - 0 ;; not reachable - ) - - (func $DEREF_META (param $mv i32) (result i32) - (loop $loop - (if (i32.eq ($TYPE $mv) (global.get $METADATA_T)) - (then - (local.set $mv ($MEM_VAL0_ptr $mv)) - (br $loop))) - ) - $mv - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; string functions - - (func $to_MalString (param $mv i32) (result i32) - ;; TODO: assert mv is a string/keyword/symbol - (i32.add (global.get $string_mem) ($VAL0 $mv)) - ) - - (func $to_String (param $mv i32) (result i32) - ;; skip string refcnt and size - (i32.add 4 ($to_MalString $mv)) - ) - - ;; Duplicate regular character array string into a Mal string and - ;; return the MalVal pointer - (func $STRING (param $type i32 $str i32) (result i32) - (LET $ms ($ALLOC_STRING $str ($strlen $str) 1)) - ($ALLOC_SCALAR $type (i32.sub $ms (global.get $string_mem))) - ) - - ;; Find first duplicate (internet) of mv. If one is found, free up - ;; mv and return the interned version. If no duplicate is found, - ;; return NULL. - (func $INTERN_STRING (param $mv i32) (result i32) - (LET $res 0 - $ms ($to_MalString $mv) - $existing_ms ($FIND_STRING (i32.add $ms 4)) - $tmp 0) - (if (AND $existing_ms (i32.lt_s $existing_ms $ms)) - (then - (local.set $tmp $mv) - (local.set $res ($ALLOC_SCALAR (global.get $STRING_T) - (i32.sub $existing_ms - (global.get $string_mem)))) - (i32.store16 $existing_ms (i32.add (i32.load16_u $existing_ms) 1)) - ($RELEASE $tmp))) - $res - ) - - (func $STRING_INIT (param $type i32) (result i32) - (LET $ms ($ALLOC_STRING "" 0 0)) - ($ALLOC_SCALAR $type (i32.sub $ms (global.get $string_mem))) - ) - - (func $STRING_FINALIZE (param $mv i32 $size i32) (result i32) - ;; Check if the new string can be interned. - (LET $tmp ($INTERN_STRING $mv) - $ms ($to_MalString $mv)) - (if $tmp - (then - (local.set $mv $tmp)) - (else - ;;; ms->size = sizeof(MalString) + size + 1 - (i32.store16 (i32.add $ms 2) - (i32.add (i32.add 4 $size) 1)) - ;;; string_mem_next = (void *)ms + ms->size - (global.set $string_mem_next - (i32.add $ms (i32.load16_u (i32.add $ms 2)))))) - $mv - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; numeric functions - - (func $INTEGER (param $val i32) (result i32) - ($ALLOC_SCALAR (global.get $INTEGER_T) $val) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; sequence functions - - (func $MAP_LOOP_START (param $type i32) (result i32) - (LET $res (if (result i32) (i32.eq $type (global.get $LIST_T)) - (then (global.get $EMPTY_LIST)) - (else (if (result i32) (i32.eq $type (global.get $VECTOR_T)) - (then (global.get $EMPTY_VECTOR)) - (else (if (result i32) (i32.eq $type (global.get $HASHMAP_T)) - (then (global.get $EMPTY_HASHMAP)) - (else - ($THROW_STR_1 "read_seq invalid type %d" $type) - 0))))))) - - ($INC_REF $res) - ) - - (func $MAP_LOOP_UPDATE (param $type i32) (param $empty i32) - (param $current i32) (param $val2 i32) (param $val3 i32) - (result i32) - (LET $res ($ALLOC $type $empty $val2 $val3)) - - ;; sequence took ownership - ($RELEASE $empty) - ($RELEASE $val2) - (if (i32.eq $type (global.get $HASHMAP_T)) - ($RELEASE $val3)) - (if (i32.gt_u $current (global.get $EMPTY_HASHMAP)) - ;; if not first element, set current next to point to new element - (i32.store ($VAL0_ptr $current) ($IDX $res))) - - $res - ) - - (func $FORCE_SEQ_TYPE (param $type i32) (param $mv i32) (result i32) - (LET $res 0) - ;; if it's already the right type, inc ref cnt and return it - (if (i32.eq $type ($TYPE $mv)) (return ($INC_REF $mv))) - ;; if it's empty, return the sequence match - (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) - (return ($MAP_LOOP_START $type))) - ;; otherwise, copy first element to turn it into correct type - ($ALLOC $type ($MEM_VAL0_ptr $mv) ($MEM_VAL1_ptr $mv) 0) - ) - - (func $LIST (param $seq i32 $first i32) (result i32) - ($ALLOC (global.get $LIST_T) $seq $first 0) - ) - - (func $LIST2 (param $first i32 $second i32) (result i32) - ;; last element is empty list - (LET $tmp ($LIST (global.get $EMPTY_LIST) $second) - $res ($LIST $tmp $first)) - ($RELEASE $tmp) ;; new list takes ownership of previous - $res - ) - - (func $LIST3 (param $first i32 $second i32 $third i32) (result i32) - (LET $tmp ($LIST2 $second $third) - $res ($LIST $tmp $first)) - ($RELEASE $tmp) ;; new list takes ownership of previous - $res - ) - - (func $LIST_Q (param $mv i32) (result i32) - (i32.eq ($TYPE $mv) (global.get $LIST_T)) - ) - - (func $EMPTY_Q (param $mv i32) (result i32) - (i32.eq ($VAL0 $mv) 0) - ) - - (func $COUNT (param $mv i32) (result i32) - (LET $cnt 0) - (block $done - (loop $loop - (if (i32.eq ($VAL0 $mv) 0) (br $done)) - (local.set $cnt (i32.add $cnt 1)) - (local.set $mv ($MEM_VAL0_ptr $mv)) - (br $loop) - ) - ) - $cnt - ) - - (func $LAST (param $mv i32) (result i32) - (LET $cur 0) - ;; TODO: check that actually a list/vector - (if (i32.eq ($VAL0 $mv) 0) - ;; empty seq, return nil - (return ($INC_REF (global.get $NIL)))) - (block $done - (loop $loop - ;; end, return previous value - (if (i32.eq ($VAL0 $mv) 0) (br $done)) - ;; current becomes previous entry - (local.set $cur $mv) - ;; next entry - (local.set $mv ($MEM_VAL0_ptr $mv)) - (br $loop) - ) - ) - ($INC_REF ($MEM_VAL1_ptr $cur)) - ) - - ;; make a copy of sequence seq from index start to end - ;; set last to last element of slice before the empty - ;; set after to element following slice (or original) - (func $SLICE (param $seq i32) (param $start i32) (param $end i32) - (result i64) - (LET $idx 0 - $res ($INC_REF (global.get $EMPTY_LIST)) - $last 0 - $tmp $res) - ;; advance seq to start - (block $done - (loop $loop - (if (OR (i32.ge_s $idx $start) - (i32.eqz ($VAL0 $seq))) - (br $done)) - (local.set $seq ($MEM_VAL0_ptr $seq)) - (local.set $idx (i32.add $idx 1)) - (br $loop) - ) - ) - (block $done - (loop $loop - ;; if current position is at end, then return or if we reached - ;; end seq, then return - (if (OR (AND (i32.ne $end -1) - (i32.ge_s $idx $end)) - (i32.eqz ($VAL0 $seq))) - (then - (local.set $res $tmp) - (br $done))) - ;; allocate new list element with copied value - (local.set $res ($LIST (global.get $EMPTY_LIST) - ($MEM_VAL1_ptr $seq))) - ;; sequence took ownership - ($RELEASE (global.get $EMPTY_LIST)) - (if (i32.eqz $last) - (then - ;; if first element, set return value to new element - (local.set $tmp $res)) - (else - ;; if not the first element, set return value to new element - (i32.store ($VAL0_ptr $last) ($IDX $res)))) - (local.set $last $res) ;; update last list element - ;; advance to next element of seq - (local.set $seq ($MEM_VAL0_ptr $seq)) - (local.set $idx (i32.add $idx 1)) - (br $loop) - ) - ) - - ;; combine last/res as hi 32/low 32 of i64 - (i64.or - (i64.shl (i64.extend_i32_u $last) (i64.const 32)) - (i64.extend_i32_u $res)) - ) - - (func $HASHMAP (result i32) - ;; just point to static empty hash-map - ($INC_REF (global.get $EMPTY_HASHMAP)) - ) - - (func $ASSOC1 (param $hm i32 $k i32 $v i32) (result i32) - (LET $res ($ALLOC (global.get $HASHMAP_T) $hm $k $v)) - ;; we took ownership of previous release - ($RELEASE $hm) - $res - ) - - (func $ASSOC1_S (param $hm i32 $k i32 $v i32) (result i32) - (LET $kmv ($STRING (global.get $STRING_T) $k) - $res ($ASSOC1 $hm $kmv $v)) - ;; map took ownership of key - ($RELEASE $kmv) - $res - ) - - (func $HASHMAP_GET (param $hm i32) (param $key_mv i32) (result i64) - (LET $key ($to_String $key_mv) - $found 0 - $res 0 - $test_key_mv 0) - - (block $done - (loop $loop - ;;; if (VAL0(hm) == 0) - (if (i32.eq ($VAL0 $hm) 0) - (then - (local.set $res (global.get $NIL)) - (br $done))) - ;;; test_key_mv = MEM_VAL1(hm) - (local.set $test_key_mv ($MEM_VAL1_ptr $hm)) - ;;; if (strcmp(key, to_String(test_key_mv)) == 0) - (if (i32.eq ($strcmp $key ($to_String $test_key_mv)) 0) - (then - (local.set $found 1) - (local.set $res ($MEM_VAL2_ptr $hm)) - (br $done))) - (local.set $hm ($MEM_VAL0_ptr $hm)) - - (br $loop) - ) - ) - - ;; combine found/res as hi 32/low 32 of i64 - (i64.or (i64.shl (i64.extend_i32_u $found) (i64.const 32)) - (i64.extend_i32_u $res)) - ) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; function functions - - (func $FUNCTION (param $index i32) (result i32) - ($ALLOC_SCALAR (global.get $FUNCTION_T) $index) - ) - - (func $MALFUNC (param $ast i32 $params i32 $env i32) (result i32) - ($ALLOC (global.get $MALFUNC_T) $ast $params $env) - ) - -) +;; Mal value memory layout +;; type words +;; ---------- ---------- +;; nil ref/ 0 | 0 | | +;; false ref/ 1 | 0 | | +;; true ref/ 1 | 1 | | +;; integer ref/ 2 | int | | +;; float ref/ 3 | ??? | | +;; string/kw ref/ 4 | string ptr | | +;; symbol ref/ 5 | string ptr | | +;; list ref/ 6 | next mem idx | val mem idx | +;; vector ref/ 7 | next mem idx | val mem idx | +;; hashmap ref/ 8 | next mem idx | key mem idx | val mem idx +;; function ref/ 9 | fn idx | | +;; mal function ref/10 | body mem idx | param mem idx | env mem idx +;; macro fn ref/11 | body mem idx | param mem idx | env mem idx +;; atom ref/12 | val mem idx | | +;; environment ref/13 | hmap mem idx | outer mem idx | +;; metadata ref/14 | obj mem idx | meta mem idx | +;; FREE sz/15 | next mem idx | | + +(module $types + + (global $NIL_T i32 0) + (global $BOOLEAN_T i32 1) + (global $INTEGER_T i32 2) + (global $FLOAT_T i32 3) + (global $STRING_T i32 4) + (global $SYMBOL_T i32 5) + (global $LIST_T i32 6) + (global $VECTOR_T i32 7) + (global $HASHMAP_T i32 8) + (global $FUNCTION_T i32 9) + (global $MALFUNC_T i32 10) + (global $MACRO_T i32 11) + (global $ATOM_T i32 12) + (global $ENVIRONMENT_T i32 13) + (global $METADATA_T i32 14) + (global $FREE_T i32 15) + + (global $error_type (mut i32) 0) + (global $error_val (mut i32) 0) + ;; Index into static string memory (static.wast) + (global $error_str (mut i32) 0) + + (global $NIL (mut i32) 0) + (global $FALSE (mut i32) 0) + (global $TRUE (mut i32) 0) + (global $EMPTY_LIST (mut i32) 0) + (global $EMPTY_VECTOR (mut i32) 0) + (global $EMPTY_HASHMAP (mut i32) 0) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; General functions + + (func $INC_REF (param $mv i32) (result i32) + (i32.store $mv (i32.add (i32.load $mv) 32)) + $mv + ) + + (func $TRUE_FALSE (param $val i32) (result i32) + ($INC_REF (if (result i32) $val (global.get $TRUE) (global.get $FALSE))) + ) + + (func $THROW_STR_0 (param $fmt i32) + (drop ($sprintf_1 (global.get $error_str) $fmt "")) + (global.set $error_type 1) + ) + + (func $THROW_STR_1 (param $fmt i32) (param $v0 i32) + (drop ($sprintf_1 (global.get $error_str) $fmt $v0)) + (global.set $error_type 1) + ) + + (func $EQUAL_Q (param $a i32 $b i32) (result i32) + (LET $ta ($TYPE $a) + $tb ($TYPE $b)) + + (if (AND (OR (i32.eq $ta (global.get $LIST_T)) + (i32.eq $ta (global.get $VECTOR_T))) + (OR (i32.eq $tb (global.get $LIST_T)) + (i32.eq $tb (global.get $VECTOR_T)))) + (then + ;; EQUAL_Q_SEQ + (block $done + (loop $loop + (if (OR (i32.eq ($VAL0 $a) 0) (i32.eq ($VAL0 $b) 0)) + (br $done)) + (if ($EQUAL_Q ($MEM_VAL1_ptr $a) ($MEM_VAL1_ptr $b)) + (then + (local.set $a ($MEM_VAL0_ptr $a)) + (local.set $b ($MEM_VAL0_ptr $b))) + (else + (return 0))) + (br $loop) + ) + ) + (return (AND (i32.eq ($VAL0 $a) 0) (i32.eq ($VAL0 $b) 0)))) + (else (if (AND (i32.eq $ta (global.get $HASHMAP_T)) + (i32.eq $tb (global.get $HASHMAP_T))) + ;; EQUAL_Q_HM + (then (return 1)) + ;; TODO: remove this once strings are interned + (else (if (OR (AND (i32.eq $ta (global.get $STRING_T)) + (i32.eq $tb (global.get $STRING_T))) + (AND (i32.eq $ta (global.get $SYMBOL_T)) + (i32.eq $tb (global.get $SYMBOL_T)))) + (then (return (i32.eqz ($strcmp ($to_String $a) ($to_String $b))))) + (else + (return (AND (i32.eq $ta $tb) + (i32.eq ($VAL0 $a) ($VAL0 $b)))))))))) + 0 ;; not reachable + ) + + (func $DEREF_META (param $mv i32) (result i32) + (loop $loop + (if (i32.eq ($TYPE $mv) (global.get $METADATA_T)) + (then + (local.set $mv ($MEM_VAL0_ptr $mv)) + (br $loop))) + ) + $mv + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; string functions + + (func $to_MalString (param $mv i32) (result i32) + ;; TODO: assert mv is a string/keyword/symbol + (i32.add (global.get $string_mem) ($VAL0 $mv)) + ) + + (func $to_String (param $mv i32) (result i32) + ;; skip string refcnt and size + (i32.add 4 ($to_MalString $mv)) + ) + + ;; Duplicate regular character array string into a Mal string and + ;; return the MalVal pointer + (func $STRING (param $type i32 $str i32) (result i32) + (LET $ms ($ALLOC_STRING $str ($strlen $str) 1)) + ($ALLOC_SCALAR $type (i32.sub $ms (global.get $string_mem))) + ) + + ;; Find first duplicate (internet) of mv. If one is found, free up + ;; mv and return the interned version. If no duplicate is found, + ;; return NULL. + (func $INTERN_STRING (param $mv i32) (result i32) + (LET $res 0 + $ms ($to_MalString $mv) + $existing_ms ($FIND_STRING (i32.add $ms 4)) + $tmp 0) + (if (AND $existing_ms (i32.lt_s $existing_ms $ms)) + (then + (local.set $tmp $mv) + (local.set $res ($ALLOC_SCALAR (global.get $STRING_T) + (i32.sub $existing_ms + (global.get $string_mem)))) + (i32.store16 $existing_ms (i32.add (i32.load16_u $existing_ms) 1)) + ($RELEASE $tmp))) + $res + ) + + (func $STRING_INIT (param $type i32) (result i32) + (LET $ms ($ALLOC_STRING "" 0 0)) + ($ALLOC_SCALAR $type (i32.sub $ms (global.get $string_mem))) + ) + + (func $STRING_FINALIZE (param $mv i32 $size i32) (result i32) + ;; Check if the new string can be interned. + (LET $tmp ($INTERN_STRING $mv) + $ms ($to_MalString $mv)) + (if $tmp + (then + (local.set $mv $tmp)) + (else + ;;; ms->size = sizeof(MalString) + size + 1 + (i32.store16 (i32.add $ms 2) + (i32.add (i32.add 4 $size) 1)) + ;;; string_mem_next = (void *)ms + ms->size + (global.set $string_mem_next + (i32.add $ms (i32.load16_u (i32.add $ms 2)))))) + $mv + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; numeric functions + + (func $INTEGER (param $val i32) (result i32) + ($ALLOC_SCALAR (global.get $INTEGER_T) $val) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; sequence functions + + (func $MAP_LOOP_START (param $type i32) (result i32) + (LET $res (if (result i32) (i32.eq $type (global.get $LIST_T)) + (then (global.get $EMPTY_LIST)) + (else (if (result i32) (i32.eq $type (global.get $VECTOR_T)) + (then (global.get $EMPTY_VECTOR)) + (else (if (result i32) (i32.eq $type (global.get $HASHMAP_T)) + (then (global.get $EMPTY_HASHMAP)) + (else + ($THROW_STR_1 "read_seq invalid type %d" $type) + 0))))))) + + ($INC_REF $res) + ) + + (func $MAP_LOOP_UPDATE (param $type i32) (param $empty i32) + (param $current i32) (param $val2 i32) (param $val3 i32) + (result i32) + (LET $res ($ALLOC $type $empty $val2 $val3)) + + ;; sequence took ownership + ($RELEASE $empty) + ($RELEASE $val2) + (if (i32.eq $type (global.get $HASHMAP_T)) + ($RELEASE $val3)) + (if (i32.gt_u $current (global.get $EMPTY_HASHMAP)) + ;; if not first element, set current next to point to new element + (i32.store ($VAL0_ptr $current) ($IDX $res))) + + $res + ) + + (func $FORCE_SEQ_TYPE (param $type i32) (param $mv i32) (result i32) + (LET $res 0) + ;; if it's already the right type, inc ref cnt and return it + (if (i32.eq $type ($TYPE $mv)) (return ($INC_REF $mv))) + ;; if it's empty, return the sequence match + (if (i32.le_u $mv (global.get $EMPTY_HASHMAP)) + (return ($MAP_LOOP_START $type))) + ;; otherwise, copy first element to turn it into correct type + ($ALLOC $type ($MEM_VAL0_ptr $mv) ($MEM_VAL1_ptr $mv) 0) + ) + + (func $LIST (param $seq i32 $first i32) (result i32) + ($ALLOC (global.get $LIST_T) $seq $first 0) + ) + + (func $LIST2 (param $first i32 $second i32) (result i32) + ;; last element is empty list + (LET $tmp ($LIST (global.get $EMPTY_LIST) $second) + $res ($LIST $tmp $first)) + ($RELEASE $tmp) ;; new list takes ownership of previous + $res + ) + + (func $LIST3 (param $first i32 $second i32 $third i32) (result i32) + (LET $tmp ($LIST2 $second $third) + $res ($LIST $tmp $first)) + ($RELEASE $tmp) ;; new list takes ownership of previous + $res + ) + + (func $LIST_Q (param $mv i32) (result i32) + (i32.eq ($TYPE $mv) (global.get $LIST_T)) + ) + + (func $EMPTY_Q (param $mv i32) (result i32) + (i32.eq ($VAL0 $mv) 0) + ) + + (func $COUNT (param $mv i32) (result i32) + (LET $cnt 0) + (block $done + (loop $loop + (if (i32.eq ($VAL0 $mv) 0) (br $done)) + (local.set $cnt (i32.add $cnt 1)) + (local.set $mv ($MEM_VAL0_ptr $mv)) + (br $loop) + ) + ) + $cnt + ) + + (func $LAST (param $mv i32) (result i32) + (LET $cur 0) + ;; TODO: check that actually a list/vector + (if (i32.eq ($VAL0 $mv) 0) + ;; empty seq, return nil + (return ($INC_REF (global.get $NIL)))) + (block $done + (loop $loop + ;; end, return previous value + (if (i32.eq ($VAL0 $mv) 0) (br $done)) + ;; current becomes previous entry + (local.set $cur $mv) + ;; next entry + (local.set $mv ($MEM_VAL0_ptr $mv)) + (br $loop) + ) + ) + ($INC_REF ($MEM_VAL1_ptr $cur)) + ) + + ;; make a copy of sequence seq from index start to end + ;; set last to last element of slice before the empty + ;; set after to element following slice (or original) + (func $SLICE (param $seq i32) (param $start i32) (param $end i32) + (result i64) + (LET $idx 0 + $res ($INC_REF (global.get $EMPTY_LIST)) + $last 0 + $tmp $res) + ;; advance seq to start + (block $done + (loop $loop + (if (OR (i32.ge_s $idx $start) + (i32.eqz ($VAL0 $seq))) + (br $done)) + (local.set $seq ($MEM_VAL0_ptr $seq)) + (local.set $idx (i32.add $idx 1)) + (br $loop) + ) + ) + (block $done + (loop $loop + ;; if current position is at end, then return or if we reached + ;; end seq, then return + (if (OR (AND (i32.ne $end -1) + (i32.ge_s $idx $end)) + (i32.eqz ($VAL0 $seq))) + (then + (local.set $res $tmp) + (br $done))) + ;; allocate new list element with copied value + (local.set $res ($LIST (global.get $EMPTY_LIST) + ($MEM_VAL1_ptr $seq))) + ;; sequence took ownership + ($RELEASE (global.get $EMPTY_LIST)) + (if (i32.eqz $last) + (then + ;; if first element, set return value to new element + (local.set $tmp $res)) + (else + ;; if not the first element, set return value to new element + (i32.store ($VAL0_ptr $last) ($IDX $res)))) + (local.set $last $res) ;; update last list element + ;; advance to next element of seq + (local.set $seq ($MEM_VAL0_ptr $seq)) + (local.set $idx (i32.add $idx 1)) + (br $loop) + ) + ) + + ;; combine last/res as hi 32/low 32 of i64 + (i64.or + (i64.shl (i64.extend_i32_u $last) (i64.const 32)) + (i64.extend_i32_u $res)) + ) + + (func $HASHMAP (result i32) + ;; just point to static empty hash-map + ($INC_REF (global.get $EMPTY_HASHMAP)) + ) + + (func $ASSOC1 (param $hm i32 $k i32 $v i32) (result i32) + (LET $res ($ALLOC (global.get $HASHMAP_T) $hm $k $v)) + ;; we took ownership of previous release + ($RELEASE $hm) + $res + ) + + (func $ASSOC1_S (param $hm i32 $k i32 $v i32) (result i32) + (LET $kmv ($STRING (global.get $STRING_T) $k) + $res ($ASSOC1 $hm $kmv $v)) + ;; map took ownership of key + ($RELEASE $kmv) + $res + ) + + (func $HASHMAP_GET (param $hm i32) (param $key_mv i32) (result i64) + (LET $key ($to_String $key_mv) + $found 0 + $res 0 + $test_key_mv 0) + + (block $done + (loop $loop + ;;; if (VAL0(hm) == 0) + (if (i32.eq ($VAL0 $hm) 0) + (then + (local.set $res (global.get $NIL)) + (br $done))) + ;;; test_key_mv = MEM_VAL1(hm) + (local.set $test_key_mv ($MEM_VAL1_ptr $hm)) + ;;; if (strcmp(key, to_String(test_key_mv)) == 0) + (if (i32.eq ($strcmp $key ($to_String $test_key_mv)) 0) + (then + (local.set $found 1) + (local.set $res ($MEM_VAL2_ptr $hm)) + (br $done))) + (local.set $hm ($MEM_VAL0_ptr $hm)) + + (br $loop) + ) + ) + + ;; combine found/res as hi 32/low 32 of i64 + (i64.or (i64.shl (i64.extend_i32_u $found) (i64.const 32)) + (i64.extend_i32_u $res)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; function functions + + (func $FUNCTION (param $index i32) (result i32) + ($ALLOC_SCALAR (global.get $FUNCTION_T) $index) + ) + + (func $MALFUNC (param $ast i32 $params i32 $env i32) (result i32) + ($ALLOC (global.get $MALFUNC_T) $ast $params $env) + ) + +) diff --git a/impls/wren/Dockerfile b/impls/wren/Dockerfile index a2d5a9869d..6c556c13d8 100644 --- a/impls/wren/Dockerfile +++ b/impls/wren/Dockerfile @@ -1,33 +1,33 @@ -FROM ubuntu:18.04 -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install g++ -RUN apt-get -y install git - -COPY wren-add-gettimeofday.patch /tmp/ -RUN cd /tmp && git clone --depth=1 https://github.com/wren-lang/wren.git \ - && cd wren \ - && patch -p1 < /tmp/wren-add-gettimeofday.patch \ - && make \ - && cp ./wren /usr/local/bin/ \ - && cd /tmp && rm -rf wren +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install g++ +RUN apt-get -y install git + +COPY wren-add-gettimeofday.patch /tmp/ +RUN cd /tmp && git clone --depth=1 https://github.com/wren-lang/wren.git \ + && cd wren \ + && patch -p1 < /tmp/wren-add-gettimeofday.patch \ + && make \ + && cp ./wren /usr/local/bin/ \ + && cd /tmp && rm -rf wren diff --git a/impls/wren/Makefile b/impls/wren/Makefile index 5a9fe99bf1..438dc202b8 100644 --- a/impls/wren/Makefile +++ b/impls/wren/Makefile @@ -1,19 +1,19 @@ -SOURCES = types.wren env.wren printer.wren reader.wren readline.wren interop.wren core.wren stepA_mal.wren - -all: - true - -dist: mal - -mal.wren: $(SOURCES) - cat $+ | grep -v '^import "./' > $@ - -mal: mal.wren - echo "#!/usr/bin/env wren" > $@ - cat $< >> $@ - chmod +x $@ - -.PHONY: clean - -clean: - rm -f mal.wren mal +SOURCES = types.wren env.wren printer.wren reader.wren readline.wren interop.wren core.wren stepA_mal.wren + +all: + true + +dist: mal + +mal.wren: $(SOURCES) + cat $+ | grep -v '^import "./' > $@ + +mal: mal.wren + echo "#!/usr/bin/env wren" > $@ + cat $< >> $@ + chmod +x $@ + +.PHONY: clean + +clean: + rm -f mal.wren mal diff --git a/impls/wren/README.md b/impls/wren/README.md index fafcd275db..9ca9d523e7 100644 --- a/impls/wren/README.md +++ b/impls/wren/README.md @@ -1,15 +1,15 @@ -# Wren implementation - -### Adding a time function - -Since Wren doesn't have a time function, we add a `System.gettimeofday` -function which returns a float with the number of seconds since epoch (with -fractions of seconds). - -This is done by applying the patch in `wren-add-gettimeofday.path` to Wren's -source code before compiling it (see `Dockerfile`). - -### Wren interop - -See examples in `tests/stepA_mal.mal` for usage of `wren-eval` to evaluate Wren -expressions inside a Mal program. +# Wren implementation + +### Adding a time function + +Since Wren doesn't have a time function, we add a `System.gettimeofday` +function which returns a float with the number of seconds since epoch (with +fractions of seconds). + +This is done by applying the patch in `wren-add-gettimeofday.path` to Wren's +source code before compiling it (see `Dockerfile`). + +### Wren interop + +See examples in `tests/stepA_mal.mal` for usage of `wren-eval` to evaluate Wren +expressions inside a Mal program. diff --git a/impls/wren/core.wren b/impls/wren/core.wren index 5a681ac4ff..406b90ea2e 100644 --- a/impls/wren/core.wren +++ b/impls/wren/core.wren @@ -1,106 +1,106 @@ -import "io" for File -import "./reader" for MalReader -import "./readline" for Readline -import "./printer" for Printer -import "./types" for MalVal, MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn, MalAtom, MalException -import "./interop" for Interop - -class Core { - static fn(func) { MalNativeFn.new(func) } - static ns { - return { - "=": fn { |a| a[0] == a[1] }, - "throw": fn { |a| - MalException.set(a[0]) - Fiber.abort("___MalException___") - }, - - "nil?": fn { |a| a[0] == null }, - "true?": fn { |a| a[0] == true }, - "false?": fn { |a| a[0] == false }, - "string?": fn { |a| a[0] is String && !MalVal.isKeyword(a[0]) }, - "symbol": fn { |a| a[0] is MalSymbol ? a[0] : MalSymbol.new(a[0]) }, - "symbol?": fn { |a| a[0] is MalSymbol }, - "keyword": fn { |a| MalVal.isKeyword(a[0]) ? a[0] : MalVal.newKeyword(a[0]) }, - "keyword?": fn { |a| MalVal.isKeyword(a[0]) }, - "number?": fn { |a| a[0] is Num }, - "fn?": fn { |a| a[0] is MalNativeFn || (a[0] is MalFn && !a[0].isMacro) }, - "macro?": fn { |a| a[0] is MalFn && a[0].isMacro }, - - "pr-str": fn { |a| a.map { |e| Printer.pr_str(e, true) }.join(" ") }, - "str": fn { |a| a.map { |e| Printer.pr_str(e, false) }.join() }, - "prn": fn { |a| - System.print(a.map { |e| Printer.pr_str(e, true) }.join(" ")) - return null - }, - "println": fn { |a| - System.print(a.map { |e| Printer.pr_str(e, false) }.join(" ")) - return null - }, - "read-string": fn { |a| MalReader.read_str(a[0]) }, - "readline": fn { |a| Readline.readLine(a[0]) }, - "slurp": fn { |a| File.read(a[0]) }, - - "<": fn { |a| a[0] < a[1] }, - "<=": fn { |a| a[0] <= a[1] }, - ">": fn { |a| a[0] > a[1] }, - ">=": fn { |a| a[0] >= a[1] }, - "+": fn { |a| a[0] + a[1] }, - "-": fn { |a| a[0] - a[1] }, - "*": fn { |a| a[0] * a[1] }, - "/": fn { |a| a[0] / a[1] }, - "time-ms": fn { |a| (System.gettimeofday * 1000).floor }, - - "list": fn { |a| MalList.new(a) }, - "list?": fn { |a| a[0] is MalList }, - "vector": fn { |a| MalVector.new(a) }, - "vector?": fn { |a| a[0] is MalVector }, - "hash-map": fn { |a| MalMap.fromList(a) }, - "map?": fn { |a| a[0] is MalMap }, - "assoc": fn { |a| a[0].assoc(a[1...a.count]) }, - "dissoc": fn { |a| a[0].dissoc(a[1...a.count]) }, - "get": fn { |a| a[0] == null ? null : a[0].data[a[1]] }, - "contains?": fn { |a| a[0].data.containsKey(a[1]) }, - "keys": fn { |a| MalList.new(a[0].data.keys.toList) }, - "vals": fn { |a| MalList.new(a[0].data.values.toList) }, - - "sequential?": fn { |a| a[0] is MalSequential }, - "cons": fn { |a| MalList.new([a[0]] + a[1].elements) }, - "concat": fn { |a| MalList.new(a.reduce([]) { |acc,e| acc + e.elements }) }, - "vec": fn { |a| MalVector.new(a[0].elements) }, - "nth": fn { |a| a[1] < a[0].count ? a[0][a[1]] : Fiber.abort("nth: index out of range") }, - "first": fn { |a| a[0] == null ? null : a[0].first }, - "rest": fn { |a| a[0] == null ? MalList.new([]) : a[0].rest }, - "empty?": fn { |a| a[0].isEmpty }, - "count": fn { |a| a[0] == null ? 0 : a[0].count }, - "apply": fn { |a| a[0].call(a[1...(a.count - 1)] + a[-1].elements) }, - "map": fn { |a| MalList.new(a[1].elements.map { |e| a[0].call([e]) }.toList) }, - - "conj": fn { |a| - if (a[0] is MalList) return MalList.new(a[-1..1] + a[0].elements) - if (a[0] is MalVector) return MalVector.new(a[0].elements + a[1..-1]) - }, - "seq": fn { |a| - if (a[0] == null) return null - if (a[0].count == 0) return null - if (a[0] is String) return MalList.new(a[0].toList) - if (a[0] is MalVector) return MalList.new(a[0].elements) - return a[0] - }, - - "meta": fn { |a| a[0].meta }, - "with-meta": fn { |a| - var x = a[0].clone() - x.meta = a[1] - return x - }, - "atom": fn { |a| MalAtom.new(a[0]) }, - "atom?": fn { |a| a[0] is MalAtom }, - "deref": fn { |a| a[0].value }, - "reset!": fn { |a| a[0].value = a[1] }, - "swap!": fn { |a| a[0].value = a[1].call([a[0].value] + a[2..-1]) }, - - "wren-eval": fn { |a| Interop.wren_eval(a[0]) } - } - } -} +import "io" for File +import "./reader" for MalReader +import "./readline" for Readline +import "./printer" for Printer +import "./types" for MalVal, MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn, MalAtom, MalException +import "./interop" for Interop + +class Core { + static fn(func) { MalNativeFn.new(func) } + static ns { + return { + "=": fn { |a| a[0] == a[1] }, + "throw": fn { |a| + MalException.set(a[0]) + Fiber.abort("___MalException___") + }, + + "nil?": fn { |a| a[0] == null }, + "true?": fn { |a| a[0] == true }, + "false?": fn { |a| a[0] == false }, + "string?": fn { |a| a[0] is String && !MalVal.isKeyword(a[0]) }, + "symbol": fn { |a| a[0] is MalSymbol ? a[0] : MalSymbol.new(a[0]) }, + "symbol?": fn { |a| a[0] is MalSymbol }, + "keyword": fn { |a| MalVal.isKeyword(a[0]) ? a[0] : MalVal.newKeyword(a[0]) }, + "keyword?": fn { |a| MalVal.isKeyword(a[0]) }, + "number?": fn { |a| a[0] is Num }, + "fn?": fn { |a| a[0] is MalNativeFn || (a[0] is MalFn && !a[0].isMacro) }, + "macro?": fn { |a| a[0] is MalFn && a[0].isMacro }, + + "pr-str": fn { |a| a.map { |e| Printer.pr_str(e, true) }.join(" ") }, + "str": fn { |a| a.map { |e| Printer.pr_str(e, false) }.join() }, + "prn": fn { |a| + System.print(a.map { |e| Printer.pr_str(e, true) }.join(" ")) + return null + }, + "println": fn { |a| + System.print(a.map { |e| Printer.pr_str(e, false) }.join(" ")) + return null + }, + "read-string": fn { |a| MalReader.read_str(a[0]) }, + "readline": fn { |a| Readline.readLine(a[0]) }, + "slurp": fn { |a| File.read(a[0]) }, + + "<": fn { |a| a[0] < a[1] }, + "<=": fn { |a| a[0] <= a[1] }, + ">": fn { |a| a[0] > a[1] }, + ">=": fn { |a| a[0] >= a[1] }, + "+": fn { |a| a[0] + a[1] }, + "-": fn { |a| a[0] - a[1] }, + "*": fn { |a| a[0] * a[1] }, + "/": fn { |a| a[0] / a[1] }, + "time-ms": fn { |a| (System.gettimeofday * 1000).floor }, + + "list": fn { |a| MalList.new(a) }, + "list?": fn { |a| a[0] is MalList }, + "vector": fn { |a| MalVector.new(a) }, + "vector?": fn { |a| a[0] is MalVector }, + "hash-map": fn { |a| MalMap.fromList(a) }, + "map?": fn { |a| a[0] is MalMap }, + "assoc": fn { |a| a[0].assoc(a[1...a.count]) }, + "dissoc": fn { |a| a[0].dissoc(a[1...a.count]) }, + "get": fn { |a| a[0] == null ? null : a[0].data[a[1]] }, + "contains?": fn { |a| a[0].data.containsKey(a[1]) }, + "keys": fn { |a| MalList.new(a[0].data.keys.toList) }, + "vals": fn { |a| MalList.new(a[0].data.values.toList) }, + + "sequential?": fn { |a| a[0] is MalSequential }, + "cons": fn { |a| MalList.new([a[0]] + a[1].elements) }, + "concat": fn { |a| MalList.new(a.reduce([]) { |acc,e| acc + e.elements }) }, + "vec": fn { |a| MalVector.new(a[0].elements) }, + "nth": fn { |a| a[1] < a[0].count ? a[0][a[1]] : Fiber.abort("nth: index out of range") }, + "first": fn { |a| a[0] == null ? null : a[0].first }, + "rest": fn { |a| a[0] == null ? MalList.new([]) : a[0].rest }, + "empty?": fn { |a| a[0].isEmpty }, + "count": fn { |a| a[0] == null ? 0 : a[0].count }, + "apply": fn { |a| a[0].call(a[1...(a.count - 1)] + a[-1].elements) }, + "map": fn { |a| MalList.new(a[1].elements.map { |e| a[0].call([e]) }.toList) }, + + "conj": fn { |a| + if (a[0] is MalList) return MalList.new(a[-1..1] + a[0].elements) + if (a[0] is MalVector) return MalVector.new(a[0].elements + a[1..-1]) + }, + "seq": fn { |a| + if (a[0] == null) return null + if (a[0].count == 0) return null + if (a[0] is String) return MalList.new(a[0].toList) + if (a[0] is MalVector) return MalList.new(a[0].elements) + return a[0] + }, + + "meta": fn { |a| a[0].meta }, + "with-meta": fn { |a| + var x = a[0].clone() + x.meta = a[1] + return x + }, + "atom": fn { |a| MalAtom.new(a[0]) }, + "atom?": fn { |a| a[0] is MalAtom }, + "deref": fn { |a| a[0].value }, + "reset!": fn { |a| a[0].value = a[1] }, + "swap!": fn { |a| a[0].value = a[1].call([a[0].value] + a[2..-1]) }, + + "wren-eval": fn { |a| Interop.wren_eval(a[0]) } + } + } +} diff --git a/impls/wren/env.wren b/impls/wren/env.wren index 90af7a3384..073f2b43a2 100644 --- a/impls/wren/env.wren +++ b/impls/wren/env.wren @@ -1,40 +1,40 @@ -import "./types" for MalList - -class Env { - construct new() { - _outer = null - _data = {} - } - construct new(outer) { - _outer = outer - _data = {} - } - construct new(outer, binds, exprs) { - _outer = outer - _data = {} - for (i in 0...binds.count) { - if (binds[i].value == "&") { - _data[binds[i + 1].value] = MalList.new(exprs[i..-1]) - break - } else { - _data[binds[i].value] = exprs[i] - } - } - } - - set(k, v) { _data[k] = v } - - find(k) { - if (_data.containsKey(k)) return this - if (_outer) return _outer.find(k) - return null - } - - get(k) { - var foundEnv = find(k) - if (!foundEnv) Fiber.abort("'%(k)' not found") - return foundEnv.getValue(k) - } - - getValue(k) { _data[k] } -} +import "./types" for MalList + +class Env { + construct new() { + _outer = null + _data = {} + } + construct new(outer) { + _outer = outer + _data = {} + } + construct new(outer, binds, exprs) { + _outer = outer + _data = {} + for (i in 0...binds.count) { + if (binds[i].value == "&") { + _data[binds[i + 1].value] = MalList.new(exprs[i..-1]) + break + } else { + _data[binds[i].value] = exprs[i] + } + } + } + + set(k, v) { _data[k] = v } + + find(k) { + if (_data.containsKey(k)) return this + if (_outer) return _outer.find(k) + return null + } + + get(k) { + var foundEnv = find(k) + if (!foundEnv) Fiber.abort("'%(k)' not found") + return foundEnv.getValue(k) + } + + getValue(k) { _data[k] } +} diff --git a/impls/wren/interop.wren b/impls/wren/interop.wren index d61b65498b..e771a34847 100644 --- a/impls/wren/interop.wren +++ b/impls/wren/interop.wren @@ -1,23 +1,23 @@ -import "meta" for Meta -import "./types" for MalList, MalMap - -class Interop { - static wren_eval(str) { - var f = Meta.compileExpression(str) - return f == null ? null : wren2mal(f.call()) - } - - static wren2mal(v) { - if (v == null || v == true || v == false) return v - if (v is Num || v is String) return v - if (v is Map) { - var m = {} - for (e in v) { - m[wren2mal(e.key)] = wren2mal(e.value) - } - return MalMap.new(m) - } - if (v is Sequence) return MalList.new(v.map { |e| wren2mal(e) }.toList) - return null - } -} +import "meta" for Meta +import "./types" for MalList, MalMap + +class Interop { + static wren_eval(str) { + var f = Meta.compileExpression(str) + return f == null ? null : wren2mal(f.call()) + } + + static wren2mal(v) { + if (v == null || v == true || v == false) return v + if (v is Num || v is String) return v + if (v is Map) { + var m = {} + for (e in v) { + m[wren2mal(e.key)] = wren2mal(e.value) + } + return MalMap.new(m) + } + if (v is Sequence) return MalList.new(v.map { |e| wren2mal(e) }.toList) + return null + } +} diff --git a/impls/wren/printer.wren b/impls/wren/printer.wren index 8dd60877b1..c021d120d7 100644 --- a/impls/wren/printer.wren +++ b/impls/wren/printer.wren @@ -1,30 +1,30 @@ -import "./types" for MalVal, MalList, MalVector, MalMap, MalNativeFn, MalFn, MalAtom - -class Printer { - static joinElements(elements, print_readably) { - return elements.map { |e| pr_str(e, print_readably) }.join(" ") - } - - static joinMapElements(data, print_readably) { - return data.map { |e| pr_str(e.key, print_readably) + " " + pr_str(e.value, print_readably) }.join(" ") - } - - static escape(s) { - return "\"" + s.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n") + "\"" - } - - static pr_str(obj) { pr_str(obj, true) } - - static pr_str(obj, print_readably) { - if (obj == null) return "nil" - if (obj is MalList) return "(%(joinElements(obj.elements, print_readably)))" - if (obj is MalVector) return "[%(joinElements(obj.elements, print_readably))]" - if (obj is MalMap) return "{%(joinMapElements(obj.data, print_readably))}" - if (obj is MalNativeFn) return "#" - if (obj is MalFn) return "#" - if (obj is MalAtom) return "(atom %(pr_str(obj.value, print_readably)))" - if (MalVal.isKeyword(obj)) return ":%(obj[1..-1])" - if (obj is String) return print_readably ? escape(obj) : obj - return obj.toString - } -} +import "./types" for MalVal, MalList, MalVector, MalMap, MalNativeFn, MalFn, MalAtom + +class Printer { + static joinElements(elements, print_readably) { + return elements.map { |e| pr_str(e, print_readably) }.join(" ") + } + + static joinMapElements(data, print_readably) { + return data.map { |e| pr_str(e.key, print_readably) + " " + pr_str(e.value, print_readably) }.join(" ") + } + + static escape(s) { + return "\"" + s.replace("\\", "\\\\").replace("\"", "\\\"").replace("\n", "\\n") + "\"" + } + + static pr_str(obj) { pr_str(obj, true) } + + static pr_str(obj, print_readably) { + if (obj == null) return "nil" + if (obj is MalList) return "(%(joinElements(obj.elements, print_readably)))" + if (obj is MalVector) return "[%(joinElements(obj.elements, print_readably))]" + if (obj is MalMap) return "{%(joinMapElements(obj.data, print_readably))}" + if (obj is MalNativeFn) return "#" + if (obj is MalFn) return "#" + if (obj is MalAtom) return "(atom %(pr_str(obj.value, print_readably)))" + if (MalVal.isKeyword(obj)) return ":%(obj[1..-1])" + if (obj is String) return print_readably ? escape(obj) : obj + return obj.toString + } +} diff --git a/impls/wren/reader.wren b/impls/wren/reader.wren index 2442cf9fd9..3fcb834b8f 100644 --- a/impls/wren/reader.wren +++ b/impls/wren/reader.wren @@ -1,170 +1,170 @@ -import "./types" for MalVal, MalSymbol, MalList, MalVector, MalMap - -class Tokenizer { - construct new(s) { - _s = s - } - - tokenize() { - _pos = 0 - var tokens = [] - while (true) { - var token = nextToken() - if (token == null) break - if (token.count > 0) tokens.add(token) - } - return tokens - } - - static eolChars { "\r\n" } - static whitespace { " ,\r\n\t" } - static delimiters { "[]{}()'`^@" } - static separators { Tokenizer.whitespace + "[]{}()'\"`,;" } - - nextToken() { - if (isEOF()) return null - var ch = curr - if (Tokenizer.whitespace.contains(ch)) { - advance() - return "" - } - if (Tokenizer.delimiters.contains(ch)) { - advance() - return ch - } - if (ch == "~") { - advance() - if (!isEOF() && curr == "@") { - advance() - return "~@" - } else { - return "~" - } - } - if (ch == ";") { - advance() - while (!isEOF() && !Tokenizer.eolChars.contains(curr)) advance() - return "" - } - if (ch == "\"") { - var s = ch - advance() - while (!isEOF() && curr != "\"") { - if (curr == "\\") { - s = s + curr - advance() - if (isEOF()) Fiber.abort("expected '\"', got EOF 111") - } - s = s + curr - advance() - } - if (isEOF()) Fiber.abort("expected '\"', got EOF 222") - s = s + curr - advance() - return s - } - var token = ch - advance() - while (!isEOF() && !Tokenizer.separators.contains(curr)) { - token = token + curr - advance() - } - return token - } - - curr { _s[_pos] } - isEOF() { _pos >= _s.count } - advance() { _pos = _pos + 1 } -} - -class Reader { - construct new(tokens) { - _tokens = tokens - _pos = 0 - } - - next() { - if (_pos >= _tokens.count) return null - var token = _tokens[_pos] - _pos = _pos + 1 - return token - } - - peek() { - if (_pos >= _tokens.count) return null - return _tokens[_pos] - } -} - -class MalReader { - static parse_str(token) { - if (token.count <= 2) return "" - return token[1..-2].replace("\\\\", "\u029e").replace("\\\"", "\"").replace("\\n", "\n").replace("\u029e", "\\") - } - - static is_all_digits(s) { - if (s.count == 0) return false - return s.all { |c| c.bytes[0] >= 0x30 && c.bytes[0] <= 0x39 } - } - - static is_number(token) { - return token.startsWith("-") ? is_all_digits(token[1..-1]) : is_all_digits(token) - } - - static read_atom(rdr) { - var token = rdr.next() - if (is_number(token)) return Num.fromString(token) - if (token.startsWith("\"")) return parse_str(token) - if (token.startsWith(":")) return MalVal.newKeyword(token[1..-1]) - if (token == "nil") return null - if (token == "true") return true - if (token == "false") return false - return MalSymbol.new(token) - } - - static read_seq(rdr, start, end) { - var token = rdr.next() - if (token != start) Fiber.abort("expected '%(start)'") - var elements = [] - token = rdr.peek() - while (token != end) { - if (!token) Fiber.abort("expected '%(end)', got EOF") - elements.add(read_form(rdr)) - token = rdr.peek() - } - rdr.next() - return elements - } - - static reader_macro(rdr, sym) { - rdr.next() - return MalList.new([MalSymbol.new(sym), read_form(rdr)]) - } - - static read_form(rdr) { - var token = rdr.peek() - if (token == "'") return reader_macro(rdr, "quote") - if (token == "`") return reader_macro(rdr, "quasiquote") - if (token == "~") return reader_macro(rdr, "unquote") - if (token == "~@") return reader_macro(rdr, "splice-unquote") - if (token == "^") { - rdr.next() - var meta = read_form(rdr) - return MalList.new([MalSymbol.new("with-meta"), read_form(rdr), meta]) - } - if (token == "@") return reader_macro(rdr, "deref") - if (token == "(") return MalList.new(read_seq(rdr, "(", ")")) - if (token == ")") Fiber.abort("unexpected ')'") - if (token == "[") return MalVector.new(read_seq(rdr, "[", "]")) - if (token == "]") Fiber.abort("unexpected ']'") - if (token == "{") return MalMap.fromList(read_seq(rdr, "{", "}")) - if (token == "}") Fiber.abort("unexpected '}'") - return read_atom(rdr) - } - - static read_str(s) { - var tokens = Tokenizer.new(s).tokenize() - if (tokens.count == 0) return null - return read_form(Reader.new(tokens)) - } -} +import "./types" for MalVal, MalSymbol, MalList, MalVector, MalMap + +class Tokenizer { + construct new(s) { + _s = s + } + + tokenize() { + _pos = 0 + var tokens = [] + while (true) { + var token = nextToken() + if (token == null) break + if (token.count > 0) tokens.add(token) + } + return tokens + } + + static eolChars { "\r\n" } + static whitespace { " ,\r\n\t" } + static delimiters { "[]{}()'`^@" } + static separators { Tokenizer.whitespace + "[]{}()'\"`,;" } + + nextToken() { + if (isEOF()) return null + var ch = curr + if (Tokenizer.whitespace.contains(ch)) { + advance() + return "" + } + if (Tokenizer.delimiters.contains(ch)) { + advance() + return ch + } + if (ch == "~") { + advance() + if (!isEOF() && curr == "@") { + advance() + return "~@" + } else { + return "~" + } + } + if (ch == ";") { + advance() + while (!isEOF() && !Tokenizer.eolChars.contains(curr)) advance() + return "" + } + if (ch == "\"") { + var s = ch + advance() + while (!isEOF() && curr != "\"") { + if (curr == "\\") { + s = s + curr + advance() + if (isEOF()) Fiber.abort("expected '\"', got EOF 111") + } + s = s + curr + advance() + } + if (isEOF()) Fiber.abort("expected '\"', got EOF 222") + s = s + curr + advance() + return s + } + var token = ch + advance() + while (!isEOF() && !Tokenizer.separators.contains(curr)) { + token = token + curr + advance() + } + return token + } + + curr { _s[_pos] } + isEOF() { _pos >= _s.count } + advance() { _pos = _pos + 1 } +} + +class Reader { + construct new(tokens) { + _tokens = tokens + _pos = 0 + } + + next() { + if (_pos >= _tokens.count) return null + var token = _tokens[_pos] + _pos = _pos + 1 + return token + } + + peek() { + if (_pos >= _tokens.count) return null + return _tokens[_pos] + } +} + +class MalReader { + static parse_str(token) { + if (token.count <= 2) return "" + return token[1..-2].replace("\\\\", "\u029e").replace("\\\"", "\"").replace("\\n", "\n").replace("\u029e", "\\") + } + + static is_all_digits(s) { + if (s.count == 0) return false + return s.all { |c| c.bytes[0] >= 0x30 && c.bytes[0] <= 0x39 } + } + + static is_number(token) { + return token.startsWith("-") ? is_all_digits(token[1..-1]) : is_all_digits(token) + } + + static read_atom(rdr) { + var token = rdr.next() + if (is_number(token)) return Num.fromString(token) + if (token.startsWith("\"")) return parse_str(token) + if (token.startsWith(":")) return MalVal.newKeyword(token[1..-1]) + if (token == "nil") return null + if (token == "true") return true + if (token == "false") return false + return MalSymbol.new(token) + } + + static read_seq(rdr, start, end) { + var token = rdr.next() + if (token != start) Fiber.abort("expected '%(start)'") + var elements = [] + token = rdr.peek() + while (token != end) { + if (!token) Fiber.abort("expected '%(end)', got EOF") + elements.add(read_form(rdr)) + token = rdr.peek() + } + rdr.next() + return elements + } + + static reader_macro(rdr, sym) { + rdr.next() + return MalList.new([MalSymbol.new(sym), read_form(rdr)]) + } + + static read_form(rdr) { + var token = rdr.peek() + if (token == "'") return reader_macro(rdr, "quote") + if (token == "`") return reader_macro(rdr, "quasiquote") + if (token == "~") return reader_macro(rdr, "unquote") + if (token == "~@") return reader_macro(rdr, "splice-unquote") + if (token == "^") { + rdr.next() + var meta = read_form(rdr) + return MalList.new([MalSymbol.new("with-meta"), read_form(rdr), meta]) + } + if (token == "@") return reader_macro(rdr, "deref") + if (token == "(") return MalList.new(read_seq(rdr, "(", ")")) + if (token == ")") Fiber.abort("unexpected ')'") + if (token == "[") return MalVector.new(read_seq(rdr, "[", "]")) + if (token == "]") Fiber.abort("unexpected ']'") + if (token == "{") return MalMap.fromList(read_seq(rdr, "{", "}")) + if (token == "}") Fiber.abort("unexpected '}'") + return read_atom(rdr) + } + + static read_str(s) { + var tokens = Tokenizer.new(s).tokenize() + if (tokens.count == 0) return null + return read_form(Reader.new(tokens)) + } +} diff --git a/impls/wren/readline.wren b/impls/wren/readline.wren index 071a7927ba..a85bd000cd 100644 --- a/impls/wren/readline.wren +++ b/impls/wren/readline.wren @@ -1,14 +1,14 @@ -import "io" for Stdin, Stdout - -class Readline { - static readLine(prompt) { - var line = null - var fiber = Fiber.new { - System.write(prompt) - Stdout.flush() - line = Stdin.readLine() - } - var error = fiber.try() - return error ? null : line - } -} +import "io" for Stdin, Stdout + +class Readline { + static readLine(prompt) { + var line = null + var fiber = Fiber.new { + System.write(prompt) + Stdout.flush() + line = Stdin.readLine() + } + var error = fiber.try() + return error ? null : line + } +} diff --git a/impls/wren/run b/impls/wren/run index 9a2c7e10b4..aea778aee8 100755 --- a/impls/wren/run +++ b/impls/wren/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec wren $(dirname $0)/${STEP:-stepA_mal}.wren "${@}" +#!/bin/bash +exec wren $(dirname $0)/${STEP:-stepA_mal}.wren "${@}" diff --git a/impls/wren/step0_repl.wren b/impls/wren/step0_repl.wren index d40ef6a4d4..e86ff69f88 100644 --- a/impls/wren/step0_repl.wren +++ b/impls/wren/step0_repl.wren @@ -1,30 +1,30 @@ -import "./readline" for Readline - -class Mal { - static read(str) { - return str - } - - static eval(ast, env) { - return ast - } - - static print(ast) { - return ast - } - - static rep(str) { - return print(eval(read(str), null)) - } - - static main() { - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") System.print(rep(line)) - } - System.print() - } -} - -Mal.main() +import "./readline" for Readline + +class Mal { + static read(str) { + return str + } + + static eval(ast, env) { + return ast + } + + static print(ast) { + return ast + } + + static rep(str) { + return print(eval(read(str), null)) + } + + static main() { + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") System.print(rep(line)) + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/step1_read_print.wren b/impls/wren/step1_read_print.wren index 783a322b06..eef6f75843 100644 --- a/impls/wren/step1_read_print.wren +++ b/impls/wren/step1_read_print.wren @@ -1,36 +1,36 @@ -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static eval(ast, env) { - return ast - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), null)) - } - - static main() { - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - if (fiber.error) System.print("Error: %(fiber.error)") - } - } - System.print() - } -} - -Mal.main() +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static eval(ast, env) { + return ast + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), null)) + } + + static main() { + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + if (fiber.error) System.print("Error: %(fiber.error)") + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/step2_eval.wren b/impls/wren/step2_eval.wren index 47d5ec8240..dbe8d8dc47 100644 --- a/impls/wren/step2_eval.wren +++ b/impls/wren/step2_eval.wren @@ -1,66 +1,66 @@ -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer -import "./types" for MalSymbol, MalList, MalVector, MalMap - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static eval_ast(ast, env) { - if (ast is MalSymbol) { - if (!env.containsKey(ast.value)) Fiber.abort("'%(ast.value)' not found") - return env[ast.value] - } else if (ast is MalList) { - return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalVector) { - return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalMap) { - var m = {} - for (e in ast.data) { - m[e.key] = eval(e.value, env) - } - return MalMap.new(m) - } else { - return ast - } - } - - static eval(ast, env) { - if (!(ast is MalList)) return eval_ast(ast, env) - if (ast.isEmpty) return ast - var evaled_ast = eval_ast(ast, env) - var f = evaled_ast[0] - return f.call(evaled_ast[1..-1]) - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), __repl_env)) - } - - static main() { - __repl_env = { - "+": Fn.new { |a| a[0] + a[1] }, - "-": Fn.new { |a| a[0] - a[1] }, - "*": Fn.new { |a| a[0] * a[1] }, - "/": Fn.new { |a| a[0] / a[1] } - } - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - if (fiber.error) System.print("Error: %(fiber.error)") - } - } - System.print() - } -} - -Mal.main() +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer +import "./types" for MalSymbol, MalList, MalVector, MalMap + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static eval_ast(ast, env) { + if (ast is MalSymbol) { + if (!env.containsKey(ast.value)) Fiber.abort("'%(ast.value)' not found") + return env[ast.value] + } else if (ast is MalList) { + return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalVector) { + return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalMap) { + var m = {} + for (e in ast.data) { + m[e.key] = eval(e.value, env) + } + return MalMap.new(m) + } else { + return ast + } + } + + static eval(ast, env) { + if (!(ast is MalList)) return eval_ast(ast, env) + if (ast.isEmpty) return ast + var evaled_ast = eval_ast(ast, env) + var f = evaled_ast[0] + return f.call(evaled_ast[1..-1]) + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), __repl_env)) + } + + static main() { + __repl_env = { + "+": Fn.new { |a| a[0] + a[1] }, + "-": Fn.new { |a| a[0] - a[1] }, + "*": Fn.new { |a| a[0] * a[1] }, + "/": Fn.new { |a| a[0] / a[1] } + } + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + if (fiber.error) System.print("Error: %(fiber.error)") + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/step3_env.wren b/impls/wren/step3_env.wren index 5cd44d9207..61b79ca977 100644 --- a/impls/wren/step3_env.wren +++ b/impls/wren/step3_env.wren @@ -1,78 +1,78 @@ -import "./env" for Env -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer -import "./types" for MalSymbol, MalList, MalVector, MalMap - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static eval_ast(ast, env) { - if (ast is MalSymbol) { - return env.get(ast.value) - } else if (ast is MalList) { - return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalVector) { - return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalMap) { - var m = {} - for (e in ast.data) { - m[e.key] = eval(e.value, env) - } - return MalMap.new(m) - } else { - return ast - } - } - - static eval(ast, env) { - if (!(ast is MalList)) return eval_ast(ast, env) - if (ast.isEmpty) return ast - if (ast[0] is MalSymbol) { - if (ast[0].value == "def!") { - return env.set(ast[1].value, eval(ast[2], env)) - } else if (ast[0].value == "let*") { - var letEnv = Env.new(env) - var i = 0 - while (i < ast[1].count) { - letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) - i = i + 2 - } - return eval(ast[2], letEnv) - } - } - var evaled_ast = eval_ast(ast, env) - var f = evaled_ast[0] - return f.call(evaled_ast[1..-1]) - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), __repl_env)) - } - - static main() { - __repl_env = Env.new() - __repl_env.set("+", Fn.new { |a| a[0] + a[1] }) - __repl_env.set("-", Fn.new { |a| a[0] - a[1] }) - __repl_env.set("*", Fn.new { |a| a[0] * a[1] }) - __repl_env.set("/", Fn.new { |a| a[0] / a[1] }) - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - if (fiber.error) System.print("Error: %(fiber.error)") - } - } - System.print() - } -} - -Mal.main() +import "./env" for Env +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer +import "./types" for MalSymbol, MalList, MalVector, MalMap + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static eval_ast(ast, env) { + if (ast is MalSymbol) { + return env.get(ast.value) + } else if (ast is MalList) { + return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalVector) { + return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalMap) { + var m = {} + for (e in ast.data) { + m[e.key] = eval(e.value, env) + } + return MalMap.new(m) + } else { + return ast + } + } + + static eval(ast, env) { + if (!(ast is MalList)) return eval_ast(ast, env) + if (ast.isEmpty) return ast + if (ast[0] is MalSymbol) { + if (ast[0].value == "def!") { + return env.set(ast[1].value, eval(ast[2], env)) + } else if (ast[0].value == "let*") { + var letEnv = Env.new(env) + var i = 0 + while (i < ast[1].count) { + letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) + i = i + 2 + } + return eval(ast[2], letEnv) + } + } + var evaled_ast = eval_ast(ast, env) + var f = evaled_ast[0] + return f.call(evaled_ast[1..-1]) + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), __repl_env)) + } + + static main() { + __repl_env = Env.new() + __repl_env.set("+", Fn.new { |a| a[0] + a[1] }) + __repl_env.set("-", Fn.new { |a| a[0] - a[1] }) + __repl_env.set("*", Fn.new { |a| a[0] * a[1] }) + __repl_env.set("/", Fn.new { |a| a[0] / a[1] }) + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + if (fiber.error) System.print("Error: %(fiber.error)") + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/step4_if_fn_do.wren b/impls/wren/step4_if_fn_do.wren index 0399464200..98a4527869 100644 --- a/impls/wren/step4_if_fn_do.wren +++ b/impls/wren/step4_if_fn_do.wren @@ -1,90 +1,90 @@ -import "./env" for Env -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer -import "./types" for MalSymbol, MalList, MalVector, MalMap -import "./core" for Core - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static eval_ast(ast, env) { - if (ast is MalSymbol) { - return env.get(ast.value) - } else if (ast is MalList) { - return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalVector) { - return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalMap) { - var m = {} - for (e in ast.data) { - m[e.key] = eval(e.value, env) - } - return MalMap.new(m) - } else { - return ast - } - } - - static eval(ast, env) { - if (!(ast is MalList)) return eval_ast(ast, env) - if (ast.isEmpty) return ast - if (ast[0] is MalSymbol) { - if (ast[0].value == "def!") { - return env.set(ast[1].value, eval(ast[2], env)) - } else if (ast[0].value == "let*") { - var letEnv = Env.new(env) - var i = 0 - while (i < ast[1].count) { - letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) - i = i + 2 - } - return eval(ast[2], letEnv) - } else if (ast[0].value == "do") { - return eval_ast(ast.rest, env)[-1] - } else if (ast[0].value == "if") { - var condval = eval(ast[1], env) - if (condval) { - return eval(ast[2], env) - } else { - return ast.count > 3 ? eval(ast[3], env) : null - } - } else if (ast[0].value == "fn*") { - return Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) } - } - } - var evaled_ast = eval_ast(ast, env) - var f = evaled_ast[0] - return f.call(evaled_ast[1..-1]) - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), __repl_env)) - } - - static main() { - __repl_env = Env.new() - // core.wren: defined in wren - for (e in Core.ns) { __repl_env.set(e.key, e.value) } - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - if (fiber.error) System.print("Error: %(fiber.error)") - } - } - System.print() - } -} - -Mal.main() +import "./env" for Env +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer +import "./types" for MalSymbol, MalList, MalVector, MalMap +import "./core" for Core + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static eval_ast(ast, env) { + if (ast is MalSymbol) { + return env.get(ast.value) + } else if (ast is MalList) { + return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalVector) { + return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalMap) { + var m = {} + for (e in ast.data) { + m[e.key] = eval(e.value, env) + } + return MalMap.new(m) + } else { + return ast + } + } + + static eval(ast, env) { + if (!(ast is MalList)) return eval_ast(ast, env) + if (ast.isEmpty) return ast + if (ast[0] is MalSymbol) { + if (ast[0].value == "def!") { + return env.set(ast[1].value, eval(ast[2], env)) + } else if (ast[0].value == "let*") { + var letEnv = Env.new(env) + var i = 0 + while (i < ast[1].count) { + letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) + i = i + 2 + } + return eval(ast[2], letEnv) + } else if (ast[0].value == "do") { + return eval_ast(ast.rest, env)[-1] + } else if (ast[0].value == "if") { + var condval = eval(ast[1], env) + if (condval) { + return eval(ast[2], env) + } else { + return ast.count > 3 ? eval(ast[3], env) : null + } + } else if (ast[0].value == "fn*") { + return Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) } + } + } + var evaled_ast = eval_ast(ast, env) + var f = evaled_ast[0] + return f.call(evaled_ast[1..-1]) + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), __repl_env)) + } + + static main() { + __repl_env = Env.new() + // core.wren: defined in wren + for (e in Core.ns) { __repl_env.set(e.key, e.value) } + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + if (fiber.error) System.print("Error: %(fiber.error)") + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/step5_tco.wren b/impls/wren/step5_tco.wren index f52f0e2f20..5a739ceb68 100644 --- a/impls/wren/step5_tco.wren +++ b/impls/wren/step5_tco.wren @@ -1,112 +1,112 @@ -import "./env" for Env -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer -import "./types" for MalSymbol, MalList, MalVector, MalMap, MalNativeFn, MalFn -import "./core" for Core - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static eval_ast(ast, env) { - if (ast is MalSymbol) { - return env.get(ast.value) - } else if (ast is MalList) { - return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalVector) { - return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalMap) { - var m = {} - for (e in ast.data) { - m[e.key] = eval(e.value, env) - } - return MalMap.new(m) - } else { - return ast - } - } - - static eval(ast, env) { - while (true) { - var tco = false - if (!(ast is MalList)) return eval_ast(ast, env) - if (ast.isEmpty) return ast - if (ast[0] is MalSymbol) { - if (ast[0].value == "def!") { - return env.set(ast[1].value, eval(ast[2], env)) - } else if (ast[0].value == "let*") { - var letEnv = Env.new(env) - var i = 0 - while (i < ast[1].count) { - letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) - i = i + 2 - } - ast = ast[2] - env = letEnv - tco = true - } else if (ast[0].value == "do") { - for (i in 1...(ast.count - 1)) { - eval(ast[i], env) - } - ast = ast[-1] - tco = true - } else if (ast[0].value == "if") { - var condval = eval(ast[1], env) - if (condval) { - ast = ast[2] - } else { - if (ast.count <= 3) return null - ast = ast[3] - } - tco = true - } else if (ast[0].value == "fn*") { - return MalFn.new(ast[2], ast[1].elements, env, - Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) - } - } - if (!tco) { - var evaled_ast = eval_ast(ast, env) - var f = evaled_ast[0] - if (f is MalNativeFn) { - return f.call(evaled_ast[1..-1]) - } else if (f is MalFn) { - ast = f.ast - env = Env.new(f.env, f.params, evaled_ast[1..-1]) - tco = true - } else { - Fiber.abort("unknown function type") - } - } - } - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), __repl_env)) - } - - static main() { - __repl_env = Env.new() - // core.wren: defined in wren - for (e in Core.ns) { __repl_env.set(e.key, e.value) } - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - if (fiber.error) System.print("Error: %(fiber.error)") - } - } - System.print() - } -} - -Mal.main() +import "./env" for Env +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer +import "./types" for MalSymbol, MalList, MalVector, MalMap, MalNativeFn, MalFn +import "./core" for Core + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static eval_ast(ast, env) { + if (ast is MalSymbol) { + return env.get(ast.value) + } else if (ast is MalList) { + return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalVector) { + return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalMap) { + var m = {} + for (e in ast.data) { + m[e.key] = eval(e.value, env) + } + return MalMap.new(m) + } else { + return ast + } + } + + static eval(ast, env) { + while (true) { + var tco = false + if (!(ast is MalList)) return eval_ast(ast, env) + if (ast.isEmpty) return ast + if (ast[0] is MalSymbol) { + if (ast[0].value == "def!") { + return env.set(ast[1].value, eval(ast[2], env)) + } else if (ast[0].value == "let*") { + var letEnv = Env.new(env) + var i = 0 + while (i < ast[1].count) { + letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) + i = i + 2 + } + ast = ast[2] + env = letEnv + tco = true + } else if (ast[0].value == "do") { + for (i in 1...(ast.count - 1)) { + eval(ast[i], env) + } + ast = ast[-1] + tco = true + } else if (ast[0].value == "if") { + var condval = eval(ast[1], env) + if (condval) { + ast = ast[2] + } else { + if (ast.count <= 3) return null + ast = ast[3] + } + tco = true + } else if (ast[0].value == "fn*") { + return MalFn.new(ast[2], ast[1].elements, env, + Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) + } + } + if (!tco) { + var evaled_ast = eval_ast(ast, env) + var f = evaled_ast[0] + if (f is MalNativeFn) { + return f.call(evaled_ast[1..-1]) + } else if (f is MalFn) { + ast = f.ast + env = Env.new(f.env, f.params, evaled_ast[1..-1]) + tco = true + } else { + Fiber.abort("unknown function type") + } + } + } + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), __repl_env)) + } + + static main() { + __repl_env = Env.new() + // core.wren: defined in wren + for (e in Core.ns) { __repl_env.set(e.key, e.value) } + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + if (fiber.error) System.print("Error: %(fiber.error)") + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/step6_file.wren b/impls/wren/step6_file.wren index 81a87eb792..c5c80288c1 100644 --- a/impls/wren/step6_file.wren +++ b/impls/wren/step6_file.wren @@ -1,122 +1,122 @@ -import "os" for Process -import "./env" for Env -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer -import "./types" for MalSymbol, MalList, MalVector, MalMap, MalNativeFn, MalFn -import "./core" for Core - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static eval_ast(ast, env) { - if (ast is MalSymbol) { - return env.get(ast.value) - } else if (ast is MalList) { - return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalVector) { - return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalMap) { - var m = {} - for (e in ast.data) { - m[e.key] = eval(e.value, env) - } - return MalMap.new(m) - } else { - return ast - } - } - - static eval(ast, env) { - while (true) { - var tco = false - if (!(ast is MalList)) return eval_ast(ast, env) - if (ast.isEmpty) return ast - if (ast[0] is MalSymbol) { - if (ast[0].value == "def!") { - return env.set(ast[1].value, eval(ast[2], env)) - } else if (ast[0].value == "let*") { - var letEnv = Env.new(env) - var i = 0 - while (i < ast[1].count) { - letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) - i = i + 2 - } - ast = ast[2] - env = letEnv - tco = true - } else if (ast[0].value == "do") { - for (i in 1...(ast.count - 1)) { - eval(ast[i], env) - } - ast = ast[-1] - tco = true - } else if (ast[0].value == "if") { - var condval = eval(ast[1], env) - if (condval) { - ast = ast[2] - } else { - if (ast.count <= 3) return null - ast = ast[3] - } - tco = true - } else if (ast[0].value == "fn*") { - return MalFn.new(ast[2], ast[1].elements, env, - Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) - } - } - if (!tco) { - var evaled_ast = eval_ast(ast, env) - var f = evaled_ast[0] - if (f is MalNativeFn) { - return f.call(evaled_ast[1..-1]) - } else if (f is MalFn) { - ast = f.ast - env = Env.new(f.env, f.params, evaled_ast[1..-1]) - tco = true - } else { - Fiber.abort("unknown function type") - } - } - } - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), __repl_env)) - } - - static main() { - __repl_env = Env.new() - // core.wren: defined in wren - for (e in Core.ns) { __repl_env.set(e.key, e.value) } - __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) - __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - - if (Process.arguments.count > 0) { - rep("(load-file \"%(Process.arguments[0])\")") - return - } - - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - if (fiber.error) System.print("Error: %(fiber.error)") - } - } - System.print() - } -} - -Mal.main() +import "os" for Process +import "./env" for Env +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer +import "./types" for MalSymbol, MalList, MalVector, MalMap, MalNativeFn, MalFn +import "./core" for Core + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static eval_ast(ast, env) { + if (ast is MalSymbol) { + return env.get(ast.value) + } else if (ast is MalList) { + return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalVector) { + return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalMap) { + var m = {} + for (e in ast.data) { + m[e.key] = eval(e.value, env) + } + return MalMap.new(m) + } else { + return ast + } + } + + static eval(ast, env) { + while (true) { + var tco = false + if (!(ast is MalList)) return eval_ast(ast, env) + if (ast.isEmpty) return ast + if (ast[0] is MalSymbol) { + if (ast[0].value == "def!") { + return env.set(ast[1].value, eval(ast[2], env)) + } else if (ast[0].value == "let*") { + var letEnv = Env.new(env) + var i = 0 + while (i < ast[1].count) { + letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) + i = i + 2 + } + ast = ast[2] + env = letEnv + tco = true + } else if (ast[0].value == "do") { + for (i in 1...(ast.count - 1)) { + eval(ast[i], env) + } + ast = ast[-1] + tco = true + } else if (ast[0].value == "if") { + var condval = eval(ast[1], env) + if (condval) { + ast = ast[2] + } else { + if (ast.count <= 3) return null + ast = ast[3] + } + tco = true + } else if (ast[0].value == "fn*") { + return MalFn.new(ast[2], ast[1].elements, env, + Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) + } + } + if (!tco) { + var evaled_ast = eval_ast(ast, env) + var f = evaled_ast[0] + if (f is MalNativeFn) { + return f.call(evaled_ast[1..-1]) + } else if (f is MalFn) { + ast = f.ast + env = Env.new(f.env, f.params, evaled_ast[1..-1]) + tco = true + } else { + Fiber.abort("unknown function type") + } + } + } + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), __repl_env)) + } + + static main() { + __repl_env = Env.new() + // core.wren: defined in wren + for (e in Core.ns) { __repl_env.set(e.key, e.value) } + __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) + __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + + if (Process.arguments.count > 0) { + rep("(load-file \"%(Process.arguments[0])\")") + return + } + + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + if (fiber.error) System.print("Error: %(fiber.error)") + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/step7_quote.wren b/impls/wren/step7_quote.wren index 985c18cc9d..a0a70ea2a8 100644 --- a/impls/wren/step7_quote.wren +++ b/impls/wren/step7_quote.wren @@ -1,163 +1,163 @@ -import "os" for Process -import "./env" for Env -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer -import "./types" for MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn -import "./core" for Core - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static qq_loop(elt, acc) { - if (elt is MalList && elt.count == 2 && elt[0] is MalSymbol && elt[0].value == "splice-unquote") { - return MalList.new([MalSymbol.new("concat"), elt[1], acc]) - } else { - return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) - } - } - - static qq_foldr(ast) { - var acc = MalList.new([]) - var i = ast.count - 1 - while (0 <= i) { - acc = qq_loop(ast[i], acc) - i = i - 1 - } - return acc - } - - static quasiquote(ast) { - if (ast is MalList) { - if (ast.count == 2 && ast[0] is MalSymbol && ast[0].value == "unquote") { - return ast[1] - } else { - return qq_foldr(ast) - } - } else if (ast is MalVector) { - return MalList.new([MalSymbol.new("vec"), qq_foldr(ast)]) - } else if (ast is MalSymbol || ast is MalMap) { - return MalList.new([MalSymbol.new("quote"), ast]) - } else { - return ast - } - } - - static eval_ast(ast, env) { - if (ast is MalSymbol) { - return env.get(ast.value) - } else if (ast is MalList) { - return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalVector) { - return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalMap) { - var m = {} - for (e in ast.data) { - m[e.key] = eval(e.value, env) - } - return MalMap.new(m) - } else { - return ast - } - } - - static eval(ast, env) { - while (true) { - var tco = false - if (!(ast is MalList)) return eval_ast(ast, env) - if (ast.isEmpty) return ast - if (ast[0] is MalSymbol) { - if (ast[0].value == "def!") { - return env.set(ast[1].value, eval(ast[2], env)) - } else if (ast[0].value == "let*") { - var letEnv = Env.new(env) - var i = 0 - while (i < ast[1].count) { - letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) - i = i + 2 - } - ast = ast[2] - env = letEnv - tco = true - } else if (ast[0].value == "quote") { - return ast[1] - } else if (ast[0].value == "quasiquoteexpand") { - return quasiquote(ast[1]) - } else if (ast[0].value == "quasiquote") { - ast = quasiquote(ast[1]) - tco = true - } else if (ast[0].value == "do") { - for (i in 1...(ast.count - 1)) { - eval(ast[i], env) - } - ast = ast[-1] - tco = true - } else if (ast[0].value == "if") { - var condval = eval(ast[1], env) - if (condval) { - ast = ast[2] - } else { - if (ast.count <= 3) return null - ast = ast[3] - } - tco = true - } else if (ast[0].value == "fn*") { - return MalFn.new(ast[2], ast[1].elements, env, - Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) - } - } - if (!tco) { - var evaled_ast = eval_ast(ast, env) - var f = evaled_ast[0] - if (f is MalNativeFn) { - return f.call(evaled_ast[1..-1]) - } else if (f is MalFn) { - ast = f.ast - env = Env.new(f.env, f.params, evaled_ast[1..-1]) - tco = true - } else { - Fiber.abort("unknown function type") - } - } - } - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), __repl_env)) - } - - static main() { - __repl_env = Env.new() - // core.wren: defined in wren - for (e in Core.ns) { __repl_env.set(e.key, e.value) } - __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) - __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - - if (Process.arguments.count > 0) { - rep("(load-file \"%(Process.arguments[0])\")") - return - } - - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - if (fiber.error) System.print("Error: %(fiber.error)") - } - } - System.print() - } -} - -Mal.main() +import "os" for Process +import "./env" for Env +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer +import "./types" for MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn +import "./core" for Core + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static qq_loop(elt, acc) { + if (elt is MalList && elt.count == 2 && elt[0] is MalSymbol && elt[0].value == "splice-unquote") { + return MalList.new([MalSymbol.new("concat"), elt[1], acc]) + } else { + return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) + } + } + + static qq_foldr(ast) { + var acc = MalList.new([]) + var i = ast.count - 1 + while (0 <= i) { + acc = qq_loop(ast[i], acc) + i = i - 1 + } + return acc + } + + static quasiquote(ast) { + if (ast is MalList) { + if (ast.count == 2 && ast[0] is MalSymbol && ast[0].value == "unquote") { + return ast[1] + } else { + return qq_foldr(ast) + } + } else if (ast is MalVector) { + return MalList.new([MalSymbol.new("vec"), qq_foldr(ast)]) + } else if (ast is MalSymbol || ast is MalMap) { + return MalList.new([MalSymbol.new("quote"), ast]) + } else { + return ast + } + } + + static eval_ast(ast, env) { + if (ast is MalSymbol) { + return env.get(ast.value) + } else if (ast is MalList) { + return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalVector) { + return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalMap) { + var m = {} + for (e in ast.data) { + m[e.key] = eval(e.value, env) + } + return MalMap.new(m) + } else { + return ast + } + } + + static eval(ast, env) { + while (true) { + var tco = false + if (!(ast is MalList)) return eval_ast(ast, env) + if (ast.isEmpty) return ast + if (ast[0] is MalSymbol) { + if (ast[0].value == "def!") { + return env.set(ast[1].value, eval(ast[2], env)) + } else if (ast[0].value == "let*") { + var letEnv = Env.new(env) + var i = 0 + while (i < ast[1].count) { + letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) + i = i + 2 + } + ast = ast[2] + env = letEnv + tco = true + } else if (ast[0].value == "quote") { + return ast[1] + } else if (ast[0].value == "quasiquoteexpand") { + return quasiquote(ast[1]) + } else if (ast[0].value == "quasiquote") { + ast = quasiquote(ast[1]) + tco = true + } else if (ast[0].value == "do") { + for (i in 1...(ast.count - 1)) { + eval(ast[i], env) + } + ast = ast[-1] + tco = true + } else if (ast[0].value == "if") { + var condval = eval(ast[1], env) + if (condval) { + ast = ast[2] + } else { + if (ast.count <= 3) return null + ast = ast[3] + } + tco = true + } else if (ast[0].value == "fn*") { + return MalFn.new(ast[2], ast[1].elements, env, + Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) + } + } + if (!tco) { + var evaled_ast = eval_ast(ast, env) + var f = evaled_ast[0] + if (f is MalNativeFn) { + return f.call(evaled_ast[1..-1]) + } else if (f is MalFn) { + ast = f.ast + env = Env.new(f.env, f.params, evaled_ast[1..-1]) + tco = true + } else { + Fiber.abort("unknown function type") + } + } + } + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), __repl_env)) + } + + static main() { + __repl_env = Env.new() + // core.wren: defined in wren + for (e in Core.ns) { __repl_env.set(e.key, e.value) } + __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) + __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + + if (Process.arguments.count > 0) { + rep("(load-file \"%(Process.arguments[0])\")") + return + } + + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + if (fiber.error) System.print("Error: %(fiber.error)") + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/step8_macros.wren b/impls/wren/step8_macros.wren index f45ed967f9..61a2591d8b 100644 --- a/impls/wren/step8_macros.wren +++ b/impls/wren/step8_macros.wren @@ -1,187 +1,187 @@ -import "os" for Process -import "./env" for Env -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer -import "./types" for MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn -import "./core" for Core - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static qq_loop(elt, acc) { - if (elt is MalList && elt.count == 2 && elt[0] is MalSymbol && elt[0].value == "splice-unquote") { - return MalList.new([MalSymbol.new("concat"), elt[1], acc]) - } else { - return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) - } - } - - static qq_foldr(ast) { - var acc = MalList.new([]) - var i = ast.count - 1 - while (0 <= i) { - acc = qq_loop(ast[i], acc) - i = i - 1 - } - return acc - } - - static quasiquote(ast) { - if (ast is MalList) { - if (ast.count == 2 && ast[0] is MalSymbol && ast[0].value == "unquote") { - return ast[1] - } else { - return qq_foldr(ast) - } - } else if (ast is MalVector) { - return MalList.new([MalSymbol.new("vec"), qq_foldr(ast)]) - } else if (ast is MalSymbol || ast is MalMap) { - return MalList.new([MalSymbol.new("quote"), ast]) - } else { - return ast - } - } - - static isMacro(ast, env) { - return (ast is MalList && - !ast.isEmpty && - ast[0] is MalSymbol && - env.find(ast[0].value) && - env.get(ast[0].value) is MalFn && - env.get(ast[0].value).isMacro) - } - - static macroexpand(ast, env) { - while (isMacro(ast, env)) { - var macro = env.get(ast[0].value) - ast = macro.call(ast.elements[1..-1]) - } - return ast - } - - static eval_ast(ast, env) { - if (ast is MalSymbol) { - return env.get(ast.value) - } else if (ast is MalList) { - return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalVector) { - return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalMap) { - var m = {} - for (e in ast.data) { - m[e.key] = eval(e.value, env) - } - return MalMap.new(m) - } else { - return ast - } - } - - static eval(ast, env) { - while (true) { - var tco = false - if (!(ast is MalList)) return eval_ast(ast, env) - ast = macroexpand(ast, env) - if (!(ast is MalList)) return eval_ast(ast, env) - if (ast.isEmpty) return ast - if (ast[0] is MalSymbol) { - if (ast[0].value == "def!") { - return env.set(ast[1].value, eval(ast[2], env)) - } else if (ast[0].value == "let*") { - var letEnv = Env.new(env) - var i = 0 - while (i < ast[1].count) { - letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) - i = i + 2 - } - ast = ast[2] - env = letEnv - tco = true - } else if (ast[0].value == "quote") { - return ast[1] - } else if (ast[0].value == "quasiquoteexpand") { - return quasiquote(ast[1]) - } else if (ast[0].value == "quasiquote") { - ast = quasiquote(ast[1]) - tco = true - } else if (ast[0].value == "defmacro!") { - return env.set(ast[1].value, eval(ast[2], env).makeMacro()) - } else if (ast[0].value == "macroexpand") { - return macroexpand(ast[1], env) - } else if (ast[0].value == "do") { - for (i in 1...(ast.count - 1)) { - eval(ast[i], env) - } - ast = ast[-1] - tco = true - } else if (ast[0].value == "if") { - var condval = eval(ast[1], env) - if (condval) { - ast = ast[2] - } else { - if (ast.count <= 3) return null - ast = ast[3] - } - tco = true - } else if (ast[0].value == "fn*") { - return MalFn.new(ast[2], ast[1].elements, env, - Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) - } - } - if (!tco) { - var evaled_ast = eval_ast(ast, env) - var f = evaled_ast[0] - if (f is MalNativeFn) { - return f.call(evaled_ast[1..-1]) - } else if (f is MalFn) { - ast = f.ast - env = Env.new(f.env, f.params, evaled_ast[1..-1]) - tco = true - } else { - Fiber.abort("unknown function type") - } - } - } - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), __repl_env)) - } - - static main() { - __repl_env = Env.new() - // core.wren: defined in wren - for (e in Core.ns) { __repl_env.set(e.key, e.value) } - __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) - __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - 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)))))))") - - if (Process.arguments.count > 0) { - rep("(load-file \"%(Process.arguments[0])\")") - return - } - - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - if (fiber.error) System.print("Error: %(fiber.error)") - } - } - System.print() - } -} - -Mal.main() +import "os" for Process +import "./env" for Env +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer +import "./types" for MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn +import "./core" for Core + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static qq_loop(elt, acc) { + if (elt is MalList && elt.count == 2 && elt[0] is MalSymbol && elt[0].value == "splice-unquote") { + return MalList.new([MalSymbol.new("concat"), elt[1], acc]) + } else { + return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) + } + } + + static qq_foldr(ast) { + var acc = MalList.new([]) + var i = ast.count - 1 + while (0 <= i) { + acc = qq_loop(ast[i], acc) + i = i - 1 + } + return acc + } + + static quasiquote(ast) { + if (ast is MalList) { + if (ast.count == 2 && ast[0] is MalSymbol && ast[0].value == "unquote") { + return ast[1] + } else { + return qq_foldr(ast) + } + } else if (ast is MalVector) { + return MalList.new([MalSymbol.new("vec"), qq_foldr(ast)]) + } else if (ast is MalSymbol || ast is MalMap) { + return MalList.new([MalSymbol.new("quote"), ast]) + } else { + return ast + } + } + + static isMacro(ast, env) { + return (ast is MalList && + !ast.isEmpty && + ast[0] is MalSymbol && + env.find(ast[0].value) && + env.get(ast[0].value) is MalFn && + env.get(ast[0].value).isMacro) + } + + static macroexpand(ast, env) { + while (isMacro(ast, env)) { + var macro = env.get(ast[0].value) + ast = macro.call(ast.elements[1..-1]) + } + return ast + } + + static eval_ast(ast, env) { + if (ast is MalSymbol) { + return env.get(ast.value) + } else if (ast is MalList) { + return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalVector) { + return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalMap) { + var m = {} + for (e in ast.data) { + m[e.key] = eval(e.value, env) + } + return MalMap.new(m) + } else { + return ast + } + } + + static eval(ast, env) { + while (true) { + var tco = false + if (!(ast is MalList)) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (!(ast is MalList)) return eval_ast(ast, env) + if (ast.isEmpty) return ast + if (ast[0] is MalSymbol) { + if (ast[0].value == "def!") { + return env.set(ast[1].value, eval(ast[2], env)) + } else if (ast[0].value == "let*") { + var letEnv = Env.new(env) + var i = 0 + while (i < ast[1].count) { + letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) + i = i + 2 + } + ast = ast[2] + env = letEnv + tco = true + } else if (ast[0].value == "quote") { + return ast[1] + } else if (ast[0].value == "quasiquoteexpand") { + return quasiquote(ast[1]) + } else if (ast[0].value == "quasiquote") { + ast = quasiquote(ast[1]) + tco = true + } else if (ast[0].value == "defmacro!") { + return env.set(ast[1].value, eval(ast[2], env).makeMacro()) + } else if (ast[0].value == "macroexpand") { + return macroexpand(ast[1], env) + } else if (ast[0].value == "do") { + for (i in 1...(ast.count - 1)) { + eval(ast[i], env) + } + ast = ast[-1] + tco = true + } else if (ast[0].value == "if") { + var condval = eval(ast[1], env) + if (condval) { + ast = ast[2] + } else { + if (ast.count <= 3) return null + ast = ast[3] + } + tco = true + } else if (ast[0].value == "fn*") { + return MalFn.new(ast[2], ast[1].elements, env, + Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) + } + } + if (!tco) { + var evaled_ast = eval_ast(ast, env) + var f = evaled_ast[0] + if (f is MalNativeFn) { + return f.call(evaled_ast[1..-1]) + } else if (f is MalFn) { + ast = f.ast + env = Env.new(f.env, f.params, evaled_ast[1..-1]) + tco = true + } else { + Fiber.abort("unknown function type") + } + } + } + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), __repl_env)) + } + + static main() { + __repl_env = Env.new() + // core.wren: defined in wren + for (e in Core.ns) { __repl_env.set(e.key, e.value) } + __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) + __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + 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)))))))") + + if (Process.arguments.count > 0) { + rep("(load-file \"%(Process.arguments[0])\")") + return + } + + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + if (fiber.error) System.print("Error: %(fiber.error)") + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/step9_try.wren b/impls/wren/step9_try.wren index d891cb36eb..c6b216d689 100644 --- a/impls/wren/step9_try.wren +++ b/impls/wren/step9_try.wren @@ -1,208 +1,208 @@ -import "os" for Process -import "./env" for Env -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer -import "./types" for MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn, MalException -import "./core" for Core - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static qq_loop(elt, acc) { - if (elt is MalList && elt.count == 2 && elt[0] is MalSymbol && elt[0].value == "splice-unquote") { - return MalList.new([MalSymbol.new("concat"), elt[1], acc]) - } else { - return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) - } - } - - static qq_foldr(ast) { - var acc = MalList.new([]) - var i = ast.count - 1 - while (0 <= i) { - acc = qq_loop(ast[i], acc) - i = i - 1 - } - return acc - } - - static quasiquote(ast) { - if (ast is MalList) { - if (ast.count == 2 && ast[0] is MalSymbol && ast[0].value == "unquote") { - return ast[1] - } else { - return qq_foldr(ast) - } - } else if (ast is MalVector) { - return MalList.new([MalSymbol.new("vec"), qq_foldr(ast)]) - } else if (ast is MalSymbol || ast is MalMap) { - return MalList.new([MalSymbol.new("quote"), ast]) - } else { - return ast - } - } - - static isMacro(ast, env) { - return (ast is MalList && - !ast.isEmpty && - ast[0] is MalSymbol && - env.find(ast[0].value) && - env.get(ast[0].value) is MalFn && - env.get(ast[0].value).isMacro) - } - - static macroexpand(ast, env) { - while (isMacro(ast, env)) { - var macro = env.get(ast[0].value) - ast = macro.call(ast.elements[1..-1]) - } - return ast - } - - static eval_ast(ast, env) { - if (ast is MalSymbol) { - return env.get(ast.value) - } else if (ast is MalList) { - return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalVector) { - return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalMap) { - var m = {} - for (e in ast.data) { - m[e.key] = eval(e.value, env) - } - return MalMap.new(m) - } else { - return ast - } - } - - static eval(ast, env) { - while (true) { - var tco = false - if (!(ast is MalList)) return eval_ast(ast, env) - ast = macroexpand(ast, env) - if (!(ast is MalList)) return eval_ast(ast, env) - if (ast.isEmpty) return ast - if (ast[0] is MalSymbol) { - if (ast[0].value == "def!") { - return env.set(ast[1].value, eval(ast[2], env)) - } else if (ast[0].value == "let*") { - var letEnv = Env.new(env) - var i = 0 - while (i < ast[1].count) { - letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) - i = i + 2 - } - ast = ast[2] - env = letEnv - tco = true - } else if (ast[0].value == "quote") { - return ast[1] - } else if (ast[0].value == "quasiquoteexpand") { - return quasiquote(ast[1]) - } else if (ast[0].value == "quasiquote") { - ast = quasiquote(ast[1]) - tco = true - } else if (ast[0].value == "defmacro!") { - return env.set(ast[1].value, eval(ast[2], env).makeMacro()) - } else if (ast[0].value == "macroexpand") { - return macroexpand(ast[1], env) - } else if (ast[0].value == "try*") { - if (ast.count > 2 && ast[2][0] is MalSymbol && ast[2][0].value == "catch*") { - var fiber = Fiber.new { eval(ast[1], env) } - var result = fiber.try() - var error = fiber.error - if (!error) return result - if (error == "___MalException___") { - error = MalException.value - MalException.set(null) - } - return eval(ast[2][2], Env.new(env, [ast[2][1]], [error])) - } else { - return eval(ast[1], env) - } - } else if (ast[0].value == "do") { - for (i in 1...(ast.count - 1)) { - eval(ast[i], env) - } - ast = ast[-1] - tco = true - } else if (ast[0].value == "if") { - var condval = eval(ast[1], env) - if (condval) { - ast = ast[2] - } else { - if (ast.count <= 3) return null - ast = ast[3] - } - tco = true - } else if (ast[0].value == "fn*") { - return MalFn.new(ast[2], ast[1].elements, env, - Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) - } - } - if (!tco) { - var evaled_ast = eval_ast(ast, env) - var f = evaled_ast[0] - if (f is MalNativeFn) { - return f.call(evaled_ast[1..-1]) - } else if (f is MalFn) { - ast = f.ast - env = Env.new(f.env, f.params, evaled_ast[1..-1]) - tco = true - } else { - Fiber.abort("unknown function type") - } - } - } - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), __repl_env)) - } - - static main() { - __repl_env = Env.new() - // core.wren: defined in wren - for (e in Core.ns) { __repl_env.set(e.key, e.value) } - __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) - __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) - // core.mal: defined using the language itself - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - 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)))))))") - - if (Process.arguments.count > 0) { - rep("(load-file \"%(Process.arguments[0])\")") - return - } - - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - var error = fiber.error - if (error) { - if (error == "___MalException___") { - error = Printer.pr_str(MalException.value, false) - MalException.set(null) - } - System.print("Error: %(error)") - } - } - } - System.print() - } -} - -Mal.main() +import "os" for Process +import "./env" for Env +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer +import "./types" for MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn, MalException +import "./core" for Core + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static qq_loop(elt, acc) { + if (elt is MalList && elt.count == 2 && elt[0] is MalSymbol && elt[0].value == "splice-unquote") { + return MalList.new([MalSymbol.new("concat"), elt[1], acc]) + } else { + return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) + } + } + + static qq_foldr(ast) { + var acc = MalList.new([]) + var i = ast.count - 1 + while (0 <= i) { + acc = qq_loop(ast[i], acc) + i = i - 1 + } + return acc + } + + static quasiquote(ast) { + if (ast is MalList) { + if (ast.count == 2 && ast[0] is MalSymbol && ast[0].value == "unquote") { + return ast[1] + } else { + return qq_foldr(ast) + } + } else if (ast is MalVector) { + return MalList.new([MalSymbol.new("vec"), qq_foldr(ast)]) + } else if (ast is MalSymbol || ast is MalMap) { + return MalList.new([MalSymbol.new("quote"), ast]) + } else { + return ast + } + } + + static isMacro(ast, env) { + return (ast is MalList && + !ast.isEmpty && + ast[0] is MalSymbol && + env.find(ast[0].value) && + env.get(ast[0].value) is MalFn && + env.get(ast[0].value).isMacro) + } + + static macroexpand(ast, env) { + while (isMacro(ast, env)) { + var macro = env.get(ast[0].value) + ast = macro.call(ast.elements[1..-1]) + } + return ast + } + + static eval_ast(ast, env) { + if (ast is MalSymbol) { + return env.get(ast.value) + } else if (ast is MalList) { + return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalVector) { + return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalMap) { + var m = {} + for (e in ast.data) { + m[e.key] = eval(e.value, env) + } + return MalMap.new(m) + } else { + return ast + } + } + + static eval(ast, env) { + while (true) { + var tco = false + if (!(ast is MalList)) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (!(ast is MalList)) return eval_ast(ast, env) + if (ast.isEmpty) return ast + if (ast[0] is MalSymbol) { + if (ast[0].value == "def!") { + return env.set(ast[1].value, eval(ast[2], env)) + } else if (ast[0].value == "let*") { + var letEnv = Env.new(env) + var i = 0 + while (i < ast[1].count) { + letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) + i = i + 2 + } + ast = ast[2] + env = letEnv + tco = true + } else if (ast[0].value == "quote") { + return ast[1] + } else if (ast[0].value == "quasiquoteexpand") { + return quasiquote(ast[1]) + } else if (ast[0].value == "quasiquote") { + ast = quasiquote(ast[1]) + tco = true + } else if (ast[0].value == "defmacro!") { + return env.set(ast[1].value, eval(ast[2], env).makeMacro()) + } else if (ast[0].value == "macroexpand") { + return macroexpand(ast[1], env) + } else if (ast[0].value == "try*") { + if (ast.count > 2 && ast[2][0] is MalSymbol && ast[2][0].value == "catch*") { + var fiber = Fiber.new { eval(ast[1], env) } + var result = fiber.try() + var error = fiber.error + if (!error) return result + if (error == "___MalException___") { + error = MalException.value + MalException.set(null) + } + return eval(ast[2][2], Env.new(env, [ast[2][1]], [error])) + } else { + return eval(ast[1], env) + } + } else if (ast[0].value == "do") { + for (i in 1...(ast.count - 1)) { + eval(ast[i], env) + } + ast = ast[-1] + tco = true + } else if (ast[0].value == "if") { + var condval = eval(ast[1], env) + if (condval) { + ast = ast[2] + } else { + if (ast.count <= 3) return null + ast = ast[3] + } + tco = true + } else if (ast[0].value == "fn*") { + return MalFn.new(ast[2], ast[1].elements, env, + Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) + } + } + if (!tco) { + var evaled_ast = eval_ast(ast, env) + var f = evaled_ast[0] + if (f is MalNativeFn) { + return f.call(evaled_ast[1..-1]) + } else if (f is MalFn) { + ast = f.ast + env = Env.new(f.env, f.params, evaled_ast[1..-1]) + tco = true + } else { + Fiber.abort("unknown function type") + } + } + } + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), __repl_env)) + } + + static main() { + __repl_env = Env.new() + // core.wren: defined in wren + for (e in Core.ns) { __repl_env.set(e.key, e.value) } + __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) + __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) + // core.mal: defined using the language itself + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + 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)))))))") + + if (Process.arguments.count > 0) { + rep("(load-file \"%(Process.arguments[0])\")") + return + } + + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + var error = fiber.error + if (error) { + if (error == "___MalException___") { + error = Printer.pr_str(MalException.value, false) + MalException.set(null) + } + System.print("Error: %(error)") + } + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/stepA_mal.wren b/impls/wren/stepA_mal.wren index aa2f130543..c2d72910b1 100644 --- a/impls/wren/stepA_mal.wren +++ b/impls/wren/stepA_mal.wren @@ -1,210 +1,210 @@ -import "os" for Process -import "./env" for Env -import "./readline" for Readline -import "./reader" for MalReader -import "./printer" for Printer -import "./types" for MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn, MalException -import "./core" for Core - -class Mal { - static read(str) { - return MalReader.read_str(str) - } - - static qq_loop(elt, acc) { - if (elt is MalList && elt.count == 2 && elt[0] is MalSymbol && elt[0].value == "splice-unquote") { - return MalList.new([MalSymbol.new("concat"), elt[1], acc]) - } else { - return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) - } - } - - static qq_foldr(ast) { - var acc = MalList.new([]) - var i = ast.count - 1 - while (0 <= i) { - acc = qq_loop(ast[i], acc) - i = i - 1 - } - return acc - } - - static quasiquote(ast) { - if (ast is MalList) { - if (ast.count == 2 && ast[0] is MalSymbol && ast[0].value == "unquote") { - return ast[1] - } else { - return qq_foldr(ast) - } - } else if (ast is MalVector) { - return MalList.new([MalSymbol.new("vec"), qq_foldr(ast)]) - } else if (ast is MalSymbol || ast is MalMap) { - return MalList.new([MalSymbol.new("quote"), ast]) - } else { - return ast - } - } - - static isMacro(ast, env) { - return (ast is MalList && - !ast.isEmpty && - ast[0] is MalSymbol && - env.find(ast[0].value) && - env.get(ast[0].value) is MalFn && - env.get(ast[0].value).isMacro) - } - - static macroexpand(ast, env) { - while (isMacro(ast, env)) { - var macro = env.get(ast[0].value) - ast = macro.call(ast.elements[1..-1]) - } - return ast - } - - static eval_ast(ast, env) { - if (ast is MalSymbol) { - return env.get(ast.value) - } else if (ast is MalList) { - return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalVector) { - return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) - } else if (ast is MalMap) { - var m = {} - for (e in ast.data) { - m[e.key] = eval(e.value, env) - } - return MalMap.new(m) - } else { - return ast - } - } - - static eval(ast, env) { - while (true) { - var tco = false - if (!(ast is MalList)) return eval_ast(ast, env) - ast = macroexpand(ast, env) - if (!(ast is MalList)) return eval_ast(ast, env) - if (ast.isEmpty) return ast - if (ast[0] is MalSymbol) { - if (ast[0].value == "def!") { - return env.set(ast[1].value, eval(ast[2], env)) - } else if (ast[0].value == "let*") { - var letEnv = Env.new(env) - var i = 0 - while (i < ast[1].count) { - letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) - i = i + 2 - } - ast = ast[2] - env = letEnv - tco = true - } else if (ast[0].value == "quote") { - return ast[1] - } else if (ast[0].value == "quasiquoteexpand") { - return quasiquote(ast[1]) - } else if (ast[0].value == "quasiquote") { - ast = quasiquote(ast[1]) - tco = true - } else if (ast[0].value == "defmacro!") { - return env.set(ast[1].value, eval(ast[2], env).makeMacro()) - } else if (ast[0].value == "macroexpand") { - return macroexpand(ast[1], env) - } else if (ast[0].value == "try*") { - if (ast.count > 2 && ast[2][0] is MalSymbol && ast[2][0].value == "catch*") { - var fiber = Fiber.new { eval(ast[1], env) } - var result = fiber.try() - var error = fiber.error - if (!error) return result - if (error == "___MalException___") { - error = MalException.value - MalException.set(null) - } - return eval(ast[2][2], Env.new(env, [ast[2][1]], [error])) - } else { - return eval(ast[1], env) - } - } else if (ast[0].value == "do") { - for (i in 1...(ast.count - 1)) { - eval(ast[i], env) - } - ast = ast[-1] - tco = true - } else if (ast[0].value == "if") { - var condval = eval(ast[1], env) - if (condval) { - ast = ast[2] - } else { - if (ast.count <= 3) return null - ast = ast[3] - } - tco = true - } else if (ast[0].value == "fn*") { - return MalFn.new(ast[2], ast[1].elements, env, - Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) - } - } - if (!tco) { - var evaled_ast = eval_ast(ast, env) - var f = evaled_ast[0] - if (f is MalNativeFn) { - return f.call(evaled_ast[1..-1]) - } else if (f is MalFn) { - ast = f.ast - env = Env.new(f.env, f.params, evaled_ast[1..-1]) - tco = true - } else { - Fiber.abort("unknown function type") - } - } - } - } - - static print(ast) { - return Printer.pr_str(ast) - } - - static rep(str) { - return print(eval(read(str), __repl_env)) - } - - static main() { - __repl_env = Env.new() - // core.wren: defined in wren - for (e in Core.ns) { __repl_env.set(e.key, e.value) } - __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) - __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) - // core.mal: defined using the language itself - rep("(def! *host-language* \"wren\")") - rep("(def! not (fn* (a) (if a false true)))") - rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - 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)))))))") - - if (Process.arguments.count > 0) { - rep("(load-file \"%(Process.arguments[0])\")") - return - } - - rep("(println (str \"Mal [\" *host-language* \"]\"))") - while (true) { - var line = Readline.readLine("user> ") - if (line == null) break - if (line != "") { - var fiber = Fiber.new { System.print(rep(line)) } - fiber.try() - var error = fiber.error - if (error) { - if (error == "___MalException___") { - error = Printer.pr_str(MalException.value, false) - MalException.set(null) - } - System.print("Error: %(error)") - } - } - } - System.print() - } -} - -Mal.main() +import "os" for Process +import "./env" for Env +import "./readline" for Readline +import "./reader" for MalReader +import "./printer" for Printer +import "./types" for MalSymbol, MalSequential, MalList, MalVector, MalMap, MalNativeFn, MalFn, MalException +import "./core" for Core + +class Mal { + static read(str) { + return MalReader.read_str(str) + } + + static qq_loop(elt, acc) { + if (elt is MalList && elt.count == 2 && elt[0] is MalSymbol && elt[0].value == "splice-unquote") { + return MalList.new([MalSymbol.new("concat"), elt[1], acc]) + } else { + return MalList.new([MalSymbol.new("cons"), quasiquote(elt), acc]) + } + } + + static qq_foldr(ast) { + var acc = MalList.new([]) + var i = ast.count - 1 + while (0 <= i) { + acc = qq_loop(ast[i], acc) + i = i - 1 + } + return acc + } + + static quasiquote(ast) { + if (ast is MalList) { + if (ast.count == 2 && ast[0] is MalSymbol && ast[0].value == "unquote") { + return ast[1] + } else { + return qq_foldr(ast) + } + } else if (ast is MalVector) { + return MalList.new([MalSymbol.new("vec"), qq_foldr(ast)]) + } else if (ast is MalSymbol || ast is MalMap) { + return MalList.new([MalSymbol.new("quote"), ast]) + } else { + return ast + } + } + + static isMacro(ast, env) { + return (ast is MalList && + !ast.isEmpty && + ast[0] is MalSymbol && + env.find(ast[0].value) && + env.get(ast[0].value) is MalFn && + env.get(ast[0].value).isMacro) + } + + static macroexpand(ast, env) { + while (isMacro(ast, env)) { + var macro = env.get(ast[0].value) + ast = macro.call(ast.elements[1..-1]) + } + return ast + } + + static eval_ast(ast, env) { + if (ast is MalSymbol) { + return env.get(ast.value) + } else if (ast is MalList) { + return MalList.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalVector) { + return MalVector.new(ast.elements.map { |e| eval(e, env) }.toList) + } else if (ast is MalMap) { + var m = {} + for (e in ast.data) { + m[e.key] = eval(e.value, env) + } + return MalMap.new(m) + } else { + return ast + } + } + + static eval(ast, env) { + while (true) { + var tco = false + if (!(ast is MalList)) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (!(ast is MalList)) return eval_ast(ast, env) + if (ast.isEmpty) return ast + if (ast[0] is MalSymbol) { + if (ast[0].value == "def!") { + return env.set(ast[1].value, eval(ast[2], env)) + } else if (ast[0].value == "let*") { + var letEnv = Env.new(env) + var i = 0 + while (i < ast[1].count) { + letEnv.set(ast[1][i].value, eval(ast[1][i + 1], letEnv)) + i = i + 2 + } + ast = ast[2] + env = letEnv + tco = true + } else if (ast[0].value == "quote") { + return ast[1] + } else if (ast[0].value == "quasiquoteexpand") { + return quasiquote(ast[1]) + } else if (ast[0].value == "quasiquote") { + ast = quasiquote(ast[1]) + tco = true + } else if (ast[0].value == "defmacro!") { + return env.set(ast[1].value, eval(ast[2], env).makeMacro()) + } else if (ast[0].value == "macroexpand") { + return macroexpand(ast[1], env) + } else if (ast[0].value == "try*") { + if (ast.count > 2 && ast[2][0] is MalSymbol && ast[2][0].value == "catch*") { + var fiber = Fiber.new { eval(ast[1], env) } + var result = fiber.try() + var error = fiber.error + if (!error) return result + if (error == "___MalException___") { + error = MalException.value + MalException.set(null) + } + return eval(ast[2][2], Env.new(env, [ast[2][1]], [error])) + } else { + return eval(ast[1], env) + } + } else if (ast[0].value == "do") { + for (i in 1...(ast.count - 1)) { + eval(ast[i], env) + } + ast = ast[-1] + tco = true + } else if (ast[0].value == "if") { + var condval = eval(ast[1], env) + if (condval) { + ast = ast[2] + } else { + if (ast.count <= 3) return null + ast = ast[3] + } + tco = true + } else if (ast[0].value == "fn*") { + return MalFn.new(ast[2], ast[1].elements, env, + Fn.new { |a| eval(ast[2], Env.new(env, ast[1].elements, a)) }) + } + } + if (!tco) { + var evaled_ast = eval_ast(ast, env) + var f = evaled_ast[0] + if (f is MalNativeFn) { + return f.call(evaled_ast[1..-1]) + } else if (f is MalFn) { + ast = f.ast + env = Env.new(f.env, f.params, evaled_ast[1..-1]) + tco = true + } else { + Fiber.abort("unknown function type") + } + } + } + } + + static print(ast) { + return Printer.pr_str(ast) + } + + static rep(str) { + return print(eval(read(str), __repl_env)) + } + + static main() { + __repl_env = Env.new() + // core.wren: defined in wren + for (e in Core.ns) { __repl_env.set(e.key, e.value) } + __repl_env.set("eval", MalNativeFn.new { |a| eval(a[0], __repl_env) }) + __repl_env.set("*ARGV*", MalList.new(Process.arguments.count > 0 ? Process.arguments[1..-1] : [])) + // core.mal: defined using the language itself + rep("(def! *host-language* \"wren\")") + rep("(def! not (fn* (a) (if a false true)))") + rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + 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)))))))") + + if (Process.arguments.count > 0) { + rep("(load-file \"%(Process.arguments[0])\")") + return + } + + rep("(println (str \"Mal [\" *host-language* \"]\"))") + while (true) { + var line = Readline.readLine("user> ") + if (line == null) break + if (line != "") { + var fiber = Fiber.new { System.print(rep(line)) } + fiber.try() + var error = fiber.error + if (error) { + if (error == "___MalException___") { + error = Printer.pr_str(MalException.value, false) + MalException.set(null) + } + System.print("Error: %(error)") + } + } + } + System.print() + } +} + +Mal.main() diff --git a/impls/wren/tests/step5_tco.mal b/impls/wren/tests/step5_tco.mal index 2d44ede154..f77adb83df 100644 --- a/impls/wren/tests/step5_tco.mal +++ b/impls/wren/tests/step5_tco.mal @@ -1,2 +1,2 @@ -;; Wren: skipping non-TCO recursion -;; Reason: completes up to 1,000,000 (with extended timeout) +;; Wren: skipping non-TCO recursion +;; Reason: completes up to 1,000,000 (with extended timeout) diff --git a/impls/wren/tests/stepA_mal.mal b/impls/wren/tests/stepA_mal.mal index 5fe0c55cb7..62ab068f72 100644 --- a/impls/wren/tests/stepA_mal.mal +++ b/impls/wren/tests/stepA_mal.mal @@ -1,34 +1,34 @@ -;; Testing basic Wren interop - -;;; wren-eval evaluates the given string as an expression. - -(wren-eval "7") -;=>7 - -(wren-eval "0x41") -;=>65 - -(wren-eval "\"7\"") -;=>"7" - -(wren-eval "[ 7,8,9 ]") -;=>(7 8 9) - -(wren-eval "{ \"abc\": 789 }") -;=>{"abc" 789} - -(wren-eval "System.print(\"hello\")") -;/hello -;=>"hello" - -(wren-eval "[\"a\", \"b\", \"c\"].map { |x| \"X%(x)Y\" }.join(\" \")") -;=>"XaY XbY XcY" - -(wren-eval "[1,2,3].map { |x| 1 + x }") -;=>(2 3 4) - -(wren-eval "[null, (1 == 1), (1 == 2)]") -;=>(nil true false) - -(wren-eval "Fiber.abort(\"AAA\" + \"BBB\")") -;/Error: AAABBB +;; Testing basic Wren interop + +;;; wren-eval evaluates the given string as an expression. + +(wren-eval "7") +;=>7 + +(wren-eval "0x41") +;=>65 + +(wren-eval "\"7\"") +;=>"7" + +(wren-eval "[ 7,8,9 ]") +;=>(7 8 9) + +(wren-eval "{ \"abc\": 789 }") +;=>{"abc" 789} + +(wren-eval "System.print(\"hello\")") +;/hello +;=>"hello" + +(wren-eval "[\"a\", \"b\", \"c\"].map { |x| \"X%(x)Y\" }.join(\" \")") +;=>"XaY XbY XcY" + +(wren-eval "[1,2,3].map { |x| 1 + x }") +;=>(2 3 4) + +(wren-eval "[null, (1 == 1), (1 == 2)]") +;=>(nil true false) + +(wren-eval "Fiber.abort(\"AAA\" + \"BBB\")") +;/Error: AAABBB diff --git a/impls/wren/types.wren b/impls/wren/types.wren index 826d63553e..ae015acbf8 100644 --- a/impls/wren/types.wren +++ b/impls/wren/types.wren @@ -1,130 +1,130 @@ -class MalVal { - static newKeyword(value) { "\u029e%(value)" } - static isKeyword(obj) { obj is String && obj.count > 0 && obj[0] == "\u029e" } - meta { _meta } - meta=(value) { _meta = value } -} - -class MalSymbol is MalVal { - construct new(value) { _value = value } - value { _value } - toString { _value } - ==(other) { other is MalSymbol && other.value == _value } - !=(other) { !(this == other) } -} - -class MalSequential is MalVal { - construct new(elements) { _elements = elements } - elements { _elements } - [index] { _elements[index] } - isEmpty { _elements.count == 0 } - count { _elements.count } - first { isEmpty ? null : _elements[0] } - rest { MalList.new(isEmpty ? [] : elements[1..-1]) } - ==(other) { - if (!(other is MalSequential)) return false - if (other.count != count) return false - for (i in 0...count) { - if (other[i] != this[i]) return false - } - return true - } - !=(other) { !(this == other) } -} - -class MalList is MalSequential { - construct new(elements) { super(elements) } - clone() { MalList.new(elements) } -} - -class MalVector is MalSequential { - construct new(elements) { super(elements) } - clone() { MalVector.new(elements) } -} - -class MalMap is MalVal { - construct new(data) { _data = data } - construct fromList(elements) { - _data = {} - var i = 0 - while (i < elements.count) { - _data[elements[i]] = elements[i + 1] - i = i + 2 - } - } - clone() { MalMap.new(_data) } - data { _data } - assoc(pairsList) { - var newData = {} - for (e in _data) { - newData[e.key] = e.value - } - var i = 0 - while (i < pairsList.count) { - newData[pairsList[i]] = pairsList[i + 1] - i = i + 2 - } - return MalMap.new(newData) - } - dissoc(keysList) { - var newData = {} - for (e in _data) { - newData[e.key] = e.value - } - for (k in keysList) { - newData.remove(k) - } - return MalMap.new(newData) - } - ==(other) { - if (!(other is MalMap)) return false - if (other.data.count != data.count) return false - for (e in _data) { - if (other.data[e.key] != e.value) return false - } - return true - } - !=(other) { !(this == other) } -} - -class MalNativeFn is MalVal { - construct new(fn) { _fn = fn } - call(args) { _fn.call(args) } - clone() { MalNativeFn.new(_fn) } -} - -class MalFn is MalVal { - construct new(ast, params, env, fn) { - _ast = ast - _params = params - _env = env - _fn = fn - _isMacro = false - } - construct new(ast, params, env, fn, isMacro) { - _ast = ast - _params = params - _env = env - _fn = fn - _isMacro = isMacro - } - ast { _ast } - params { _params } - env { _env } - isMacro { _isMacro } - clone() { MalFn.new(_ast, _params, _env, _fn, _isMacro) } - makeMacro() { MalFn.new(_ast, _params, _env, _fn, true) } - call(args) { _fn.call(args) } -} - -class MalAtom is MalVal { - construct new(value) { _value = value } - value { _value } - value=(other) { _value = other } - clone() { MalAtom.new(value) } -} - -class MalException { - static value { __exception } - static set(exception) { __exception = exception } -} +class MalVal { + static newKeyword(value) { "\u029e%(value)" } + static isKeyword(obj) { obj is String && obj.count > 0 && obj[0] == "\u029e" } + meta { _meta } + meta=(value) { _meta = value } +} + +class MalSymbol is MalVal { + construct new(value) { _value = value } + value { _value } + toString { _value } + ==(other) { other is MalSymbol && other.value == _value } + !=(other) { !(this == other) } +} + +class MalSequential is MalVal { + construct new(elements) { _elements = elements } + elements { _elements } + [index] { _elements[index] } + isEmpty { _elements.count == 0 } + count { _elements.count } + first { isEmpty ? null : _elements[0] } + rest { MalList.new(isEmpty ? [] : elements[1..-1]) } + ==(other) { + if (!(other is MalSequential)) return false + if (other.count != count) return false + for (i in 0...count) { + if (other[i] != this[i]) return false + } + return true + } + !=(other) { !(this == other) } +} + +class MalList is MalSequential { + construct new(elements) { super(elements) } + clone() { MalList.new(elements) } +} + +class MalVector is MalSequential { + construct new(elements) { super(elements) } + clone() { MalVector.new(elements) } +} + +class MalMap is MalVal { + construct new(data) { _data = data } + construct fromList(elements) { + _data = {} + var i = 0 + while (i < elements.count) { + _data[elements[i]] = elements[i + 1] + i = i + 2 + } + } + clone() { MalMap.new(_data) } + data { _data } + assoc(pairsList) { + var newData = {} + for (e in _data) { + newData[e.key] = e.value + } + var i = 0 + while (i < pairsList.count) { + newData[pairsList[i]] = pairsList[i + 1] + i = i + 2 + } + return MalMap.new(newData) + } + dissoc(keysList) { + var newData = {} + for (e in _data) { + newData[e.key] = e.value + } + for (k in keysList) { + newData.remove(k) + } + return MalMap.new(newData) + } + ==(other) { + if (!(other is MalMap)) return false + if (other.data.count != data.count) return false + for (e in _data) { + if (other.data[e.key] != e.value) return false + } + return true + } + !=(other) { !(this == other) } +} + +class MalNativeFn is MalVal { + construct new(fn) { _fn = fn } + call(args) { _fn.call(args) } + clone() { MalNativeFn.new(_fn) } +} + +class MalFn is MalVal { + construct new(ast, params, env, fn) { + _ast = ast + _params = params + _env = env + _fn = fn + _isMacro = false + } + construct new(ast, params, env, fn, isMacro) { + _ast = ast + _params = params + _env = env + _fn = fn + _isMacro = isMacro + } + ast { _ast } + params { _params } + env { _env } + isMacro { _isMacro } + clone() { MalFn.new(_ast, _params, _env, _fn, _isMacro) } + makeMacro() { MalFn.new(_ast, _params, _env, _fn, true) } + call(args) { _fn.call(args) } +} + +class MalAtom is MalVal { + construct new(value) { _value = value } + value { _value } + value=(other) { _value = other } + clone() { MalAtom.new(value) } +} + +class MalException { + static value { __exception } + static set(exception) { __exception = exception } +} diff --git a/impls/wren/wren-add-gettimeofday.patch b/impls/wren/wren-add-gettimeofday.patch index 7db29ed59e..533b705948 100644 --- a/impls/wren/wren-add-gettimeofday.patch +++ b/impls/wren/wren-add-gettimeofday.patch @@ -1,34 +1,34 @@ -diff --git a/src/vm/wren_core.c b/src/vm/wren_core.c -index 34a13c8b..3c4e6ab8 100644 ---- a/src/vm/wren_core.c -+++ b/src/vm/wren_core.c -@@ -4,6 +4,7 @@ - #include - #include - #include -+#include - - #include "wren_common.h" - #include "wren_core.h" -@@ -1121,6 +1122,13 @@ DEF_PRIMITIVE(string_toString) - RETURN_VAL(args[0]); - } - -+DEF_PRIMITIVE(system_gettimeofday) -+{ -+ struct timeval tv; -+ gettimeofday(&tv, NULL); -+ RETURN_NUM((double)tv.tv_sec + (double)tv.tv_usec/1000000.0); -+} -+ - DEF_PRIMITIVE(system_clock) - { - RETURN_NUM((double)clock() / CLOCKS_PER_SEC); -@@ -1374,6 +1382,7 @@ void wrenInitializeCore(WrenVM* vm) - PRIMITIVE(vm->rangeClass, "toString", range_toString); - - ObjClass* systemClass = AS_CLASS(wrenFindVariable(vm, coreModule, "System")); -+ PRIMITIVE(systemClass->obj.classObj, "gettimeofday", system_gettimeofday); - PRIMITIVE(systemClass->obj.classObj, "clock", system_clock); - PRIMITIVE(systemClass->obj.classObj, "gc()", system_gc); - PRIMITIVE(systemClass->obj.classObj, "writeString_(_)", system_writeString); +diff --git a/src/vm/wren_core.c b/src/vm/wren_core.c +index 34a13c8b..3c4e6ab8 100644 +--- a/src/vm/wren_core.c ++++ b/src/vm/wren_core.c +@@ -4,6 +4,7 @@ + #include + #include + #include ++#include + + #include "wren_common.h" + #include "wren_core.h" +@@ -1121,6 +1122,13 @@ DEF_PRIMITIVE(string_toString) + RETURN_VAL(args[0]); + } + ++DEF_PRIMITIVE(system_gettimeofday) ++{ ++ struct timeval tv; ++ gettimeofday(&tv, NULL); ++ RETURN_NUM((double)tv.tv_sec + (double)tv.tv_usec/1000000.0); ++} ++ + DEF_PRIMITIVE(system_clock) + { + RETURN_NUM((double)clock() / CLOCKS_PER_SEC); +@@ -1374,6 +1382,7 @@ void wrenInitializeCore(WrenVM* vm) + PRIMITIVE(vm->rangeClass, "toString", range_toString); + + ObjClass* systemClass = AS_CLASS(wrenFindVariable(vm, coreModule, "System")); ++ PRIMITIVE(systemClass->obj.classObj, "gettimeofday", system_gettimeofday); + PRIMITIVE(systemClass->obj.classObj, "clock", system_clock); + PRIMITIVE(systemClass->obj.classObj, "gc()", system_gc); + PRIMITIVE(systemClass->obj.classObj, "writeString_(_)", system_writeString); diff --git a/impls/xslt/Dockerfile b/impls/xslt/Dockerfile index 4e94d7a62a..62a59eb89a 100644 --- a/impls/xslt/Dockerfile +++ b/impls/xslt/Dockerfile @@ -1,33 +1,33 @@ -FROM ubuntu:bionic -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev libpcre3-dev - -RUN mkdir -p /mal -WORKDIR /mal - -######################################################### -# Specific implementation requirements -######################################################### - -RUN apt-get -y install python3.8 openjdk-8-jre -RUN update-alternatives --install /usr/bin/python python /usr/bin/python3.8 10 - -RUN curl https://repo1.maven.org/maven2/net/sf/saxon/Saxon-HE/9.9.1-6/Saxon-HE-9.9.1-6.jar -O - -RUN mv Saxon-HE-9.9.1-6.jar /bin/Saxon-HE-9.9.1-6.jar - -RUN echo -n "#!/bin/sh\njava -Xmx2G -cp /bin/Saxon-HE-9.9.1-6.jar net.sf.saxon.Transform \"\$@\"" > /usr/bin/saxon && chmod +x /usr/bin/saxon - - +FROM ubuntu:bionic +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev libpcre3-dev + +RUN mkdir -p /mal +WORKDIR /mal + +######################################################### +# Specific implementation requirements +######################################################### + +RUN apt-get -y install python3.8 openjdk-8-jre +RUN update-alternatives --install /usr/bin/python python /usr/bin/python3.8 10 + +RUN curl https://repo1.maven.org/maven2/net/sf/saxon/Saxon-HE/9.9.1-6/Saxon-HE-9.9.1-6.jar -O + +RUN mv Saxon-HE-9.9.1-6.jar /bin/Saxon-HE-9.9.1-6.jar + +RUN echo -n "#!/bin/sh\njava -Xmx2G -cp /bin/Saxon-HE-9.9.1-6.jar net.sf.saxon.Transform \"\$@\"" > /usr/bin/saxon && chmod +x /usr/bin/saxon + + diff --git a/impls/xslt/Makefile b/impls/xslt/Makefile index de1acb51a5..936e5ba808 100644 --- a/impls/xslt/Makefile +++ b/impls/xslt/Makefile @@ -1,7 +1,7 @@ -.DEFAULT: - echo - -.PHONY: clean - -all: - echo "hello there general kenobi" +.DEFAULT: + echo + +.PHONY: clean + +all: + echo "hello there general kenobi" diff --git a/impls/xslt/core.xslt b/impls/xslt/core.xslt index 9615db9944..4bc134e3d0 100644 --- a/impls/xslt/core.xslt +++ b/impls/xslt/core.xslt @@ -1,802 +1,802 @@ - - - - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - - false - - - - false - - - false - - - - false - - - - false - - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - - false - - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - false - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + + false + + + + false + + + false + + + + false + + + + false + + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + + false + + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + false + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/env.xslt b/impls/xslt/env.xslt index 4b91ad1967..5aced6306e 100644 --- a/impls/xslt/env.xslt +++ b/impls/xslt/env.xslt @@ -1,219 +1,219 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/harness.py b/impls/xslt/harness.py index 72bf8d8835..bf3be72988 100644 --- a/impls/xslt/harness.py +++ b/impls/xslt/harness.py @@ -1,153 +1,153 @@ -import time -import os -import readline -import sys -import xml.etree.ElementTree as ET -from threading import Thread -from threading import Lock -from collections import deque - -fname = sys.argv[1] -args = sys.argv[2:] -tree = ET.Element('mal') - -if len(args) > 0: - args0 = args[0] - ET.SubElement(tree, 'argv') - for a in tree.iter('mal'): - for a in a.iter('argv'): - for arg in args[1:]: - ET.SubElement(a, 'arg').text = arg - ET.SubElement(tree, 'no_repl') - -tree = ET.ElementTree(tree) -stdout = sys.stdout - -try: - readline.read_history_file('.xslt_mal_history') -except: - pass - -HALT = False -THE_PID = None -init_t = time.time() * 1000 -readline_queue = deque() -os.system('rm -rf xsl_error.xml') -os.system('mkfifo xsl_error.xml') - -def setup_request_file(): - os.system('rm -rf xsl_input-string') - os.system('mkfifo xsl_input-string') - - -def get_one(fd): - s = b"" - while True: - x = os.read(fd, 1) - if x == b'\n': - break - if x == b'': - break - s += x - if s == "": - return None - return s.decode('utf-8') - - -def serve_one_request(res): - global HALT - if len(res) == 0: - return - try: - xtree = ET.fromstring("" + res.strip('\x00') + "") - # stdout.write(xtree.attrib['kind']) - for req in xtree: - if req.attrib['kind'] == 'readline': - x = None - if len(readline_queue) > 0: - x = readline_queue.popleft() - else: - x = input(req.attrib['value']) - with open('xsl_input-string', 'w') as fx: - fx.write(x) - # stdout.write(' = ' + x) - elif req.attrib['kind'] == 'halt': - HALT = True - elif req.attrib['kind'] == 'display': - stdout.write(req.attrib['value'] + '\n') - elif req.attrib['kind'] == 'time': - x = time.time() * 1000 - init_t - # stdout.write(' = ' + str(int(x))) - with open('xsl_input-string', 'w') as fx: - fx.write(str(int(x))) - # stdout.write('\n') - elif req.attrib['kind'] == 'xpath-eval': - xpath = req.attrib['value'] - with open('xsl-eval.xslt', 'w') as f: - f.write(f'') - with open('xsl-null.xml', 'w') as f: - f.write(req.attrib['context']) - - if os.system(f'saxon -xsl:xsl-eval.xslt -s:xsl-null.xml > xsl-eval_output.xml'): - x = '' - else: - with open('xsl-eval_output.xml', 'r') as f: - x = f.read() - with open('xsl_input-string', 'w') as fx: - fx.write(x) - else: - stdout.write("UNKNOWN REQUEST " + req.attrib['kind']) - # stdout.write('\n') - except Exception as e: - # if str(e) != 'no element found: line 1, column 0': - # f.seek(0) - # print(e, list(x for x in f.read())) - return - # with open('xsl_error.xml', 'w') as f: - # f.write('') - -def transform(do_print=True): - global tree, HALT, THE_PID - - tree.write('xslt_input.xml') - setup_request_file() - pid = os.fork() - if pid == 0: - os.system(f'saxon -xsl:"{fname}" -s:xslt_input.xml -TP:perf.html > xslt_output.xml 2> xsl_error.xml') - HALT = True - else: - THE_PID = pid - fd = os.open('xsl_error.xml', os.O_RDONLY | os.O_CLOEXEC) - while True: - try: - if HALT: - os.kill(THE_PID, 9) - raise KeyboardInterrupt() - cmd = get_one(fd) - if cmd: - serve_one_request(cmd) - except KeyboardInterrupt: - exit() - except Exception as e: - print("Harness error:", e) - tree = ET.parse('xslt_output.xml') - if do_print: - stdout = '' - for a in tree.iter('mal'): - for a in a.iter('stdout'): - stdout = a - print(stdout.text) - stdout.clear() - del stdout - - -if len(args) > 0: - readline_queue.append(f'(do (load-file "{args0}") (xslt-halt))') - transform(do_print=False) -else: - if fname == 'stepA_mal.xslt': - readline_queue.append('(println (str "Mal [" *host-language* "]"))') - transform(do_print=False) - else: - transform() - readline.write_history_file('.xslt_mal_history') +import time +import os +import readline +import sys +import xml.etree.ElementTree as ET +from threading import Thread +from threading import Lock +from collections import deque + +fname = sys.argv[1] +args = sys.argv[2:] +tree = ET.Element('mal') + +if len(args) > 0: + args0 = args[0] + ET.SubElement(tree, 'argv') + for a in tree.iter('mal'): + for a in a.iter('argv'): + for arg in args[1:]: + ET.SubElement(a, 'arg').text = arg + ET.SubElement(tree, 'no_repl') + +tree = ET.ElementTree(tree) +stdout = sys.stdout + +try: + readline.read_history_file('.xslt_mal_history') +except: + pass + +HALT = False +THE_PID = None +init_t = time.time() * 1000 +readline_queue = deque() +os.system('rm -rf xsl_error.xml') +os.system('mkfifo xsl_error.xml') + +def setup_request_file(): + os.system('rm -rf xsl_input-string') + os.system('mkfifo xsl_input-string') + + +def get_one(fd): + s = b"" + while True: + x = os.read(fd, 1) + if x == b'\n': + break + if x == b'': + break + s += x + if s == "": + return None + return s.decode('utf-8') + + +def serve_one_request(res): + global HALT + if len(res) == 0: + return + try: + xtree = ET.fromstring("" + res.strip('\x00') + "") + # stdout.write(xtree.attrib['kind']) + for req in xtree: + if req.attrib['kind'] == 'readline': + x = None + if len(readline_queue) > 0: + x = readline_queue.popleft() + else: + x = input(req.attrib['value']) + with open('xsl_input-string', 'w') as fx: + fx.write(x) + # stdout.write(' = ' + x) + elif req.attrib['kind'] == 'halt': + HALT = True + elif req.attrib['kind'] == 'display': + stdout.write(req.attrib['value'] + '\n') + elif req.attrib['kind'] == 'time': + x = time.time() * 1000 - init_t + # stdout.write(' = ' + str(int(x))) + with open('xsl_input-string', 'w') as fx: + fx.write(str(int(x))) + # stdout.write('\n') + elif req.attrib['kind'] == 'xpath-eval': + xpath = req.attrib['value'] + with open('xsl-eval.xslt', 'w') as f: + f.write(f'') + with open('xsl-null.xml', 'w') as f: + f.write(req.attrib['context']) + + if os.system(f'saxon -xsl:xsl-eval.xslt -s:xsl-null.xml > xsl-eval_output.xml'): + x = '' + else: + with open('xsl-eval_output.xml', 'r') as f: + x = f.read() + with open('xsl_input-string', 'w') as fx: + fx.write(x) + else: + stdout.write("UNKNOWN REQUEST " + req.attrib['kind']) + # stdout.write('\n') + except Exception as e: + # if str(e) != 'no element found: line 1, column 0': + # f.seek(0) + # print(e, list(x for x in f.read())) + return + # with open('xsl_error.xml', 'w') as f: + # f.write('') + +def transform(do_print=True): + global tree, HALT, THE_PID + + tree.write('xslt_input.xml') + setup_request_file() + pid = os.fork() + if pid == 0: + os.system(f'saxon -xsl:"{fname}" -s:xslt_input.xml -TP:perf.html > xslt_output.xml 2> xsl_error.xml') + HALT = True + else: + THE_PID = pid + fd = os.open('xsl_error.xml', os.O_RDONLY | os.O_CLOEXEC) + while True: + try: + if HALT: + os.kill(THE_PID, 9) + raise KeyboardInterrupt() + cmd = get_one(fd) + if cmd: + serve_one_request(cmd) + except KeyboardInterrupt: + exit() + except Exception as e: + print("Harness error:", e) + tree = ET.parse('xslt_output.xml') + if do_print: + stdout = '' + for a in tree.iter('mal'): + for a in a.iter('stdout'): + stdout = a + print(stdout.text) + stdout.clear() + del stdout + + +if len(args) > 0: + readline_queue.append(f'(do (load-file "{args0}") (xslt-halt))') + transform(do_print=False) +else: + if fname == 'stepA_mal.xslt': + readline_queue.append('(println (str "Mal [" *host-language* "]"))') + transform(do_print=False) + else: + transform() + readline.write_history_file('.xslt_mal_history') diff --git a/impls/xslt/printer.xslt b/impls/xslt/printer.xslt index 32bc61d0b9..cb1117e072 100644 --- a/impls/xslt/printer.xslt +++ b/impls/xslt/printer.xslt @@ -1,197 +1,197 @@ - - - - - - - - - - - - - - true - - - false - - - nil - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ? - ? - - - - - - ? - ? - - - - - - - - - - - - - - - - - - - - - - - Unknown - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + true + + + false + + + nil + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ? + ? + + + + + + ? + ? + + + + + + + + + + + + + + + + + + + + + + + Unknown + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/reader.xslt b/impls/xslt/reader.xslt index ef34d2f6a2..e38f7ceb5e 100644 --- a/impls/xslt/reader.xslt +++ b/impls/xslt/reader.xslt @@ -1,517 +1,517 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Odd number of values to hash - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - EOF while reading list - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Odd number of values to hash + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + EOF while reading list + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/readline.xslt b/impls/xslt/readline.xslt index 91a87db748..51faaffae6 100644 --- a/impls/xslt/readline.xslt +++ b/impls/xslt/readline.xslt @@ -1,12 +1,12 @@ - - - - - - - - - - - - + + + + + + + + + + + + diff --git a/impls/xslt/run b/impls/xslt/run index 41f549b5bd..bc0b80e953 100755 --- a/impls/xslt/run +++ b/impls/xslt/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec python harness.py $(dirname $0)/${STEP:-stepA_mal}.xslt "${@}" +#!/bin/bash +exec python harness.py $(dirname $0)/${STEP:-stepA_mal}.xslt "${@}" diff --git a/impls/xslt/step0_repl.inc.xslt b/impls/xslt/step0_repl.inc.xslt index 58463a458d..563fcff409 100644 --- a/impls/xslt/step0_repl.inc.xslt +++ b/impls/xslt/step0_repl.inc.xslt @@ -1,47 +1,47 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step0_repl.xslt b/impls/xslt/step0_repl.xslt index 0fdfe15d6b..02f8d0a53f 100644 --- a/impls/xslt/step0_repl.xslt +++ b/impls/xslt/step0_repl.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step1_read_print.inc.xslt b/impls/xslt/step1_read_print.inc.xslt index ab6ca8d4d9..2d2dc7854c 100644 --- a/impls/xslt/step1_read_print.inc.xslt +++ b/impls/xslt/step1_read_print.inc.xslt @@ -1,74 +1,74 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step1_read_print.xslt b/impls/xslt/step1_read_print.xslt index a520f96574..f6bf2ab042 100644 --- a/impls/xslt/step1_read_print.xslt +++ b/impls/xslt/step1_read_print.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step2_eval.inc.xslt b/impls/xslt/step2_eval.inc.xslt index 3edcf10f48..1113fd209e 100644 --- a/impls/xslt/step2_eval.inc.xslt +++ b/impls/xslt/step2_eval.inc.xslt @@ -1,257 +1,257 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Invalid function - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Invalid function + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step2_eval.xslt b/impls/xslt/step2_eval.xslt index f607c472ae..14ae0a5f24 100644 --- a/impls/xslt/step2_eval.xslt +++ b/impls/xslt/step2_eval.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step3_env.inc.xslt b/impls/xslt/step3_env.inc.xslt index fb98265cc2..89e157b7ef 100644 --- a/impls/xslt/step3_env.inc.xslt +++ b/impls/xslt/step3_env.inc.xslt @@ -1,377 +1,377 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step3_env.xslt b/impls/xslt/step3_env.xslt index 192daefb34..552e474fda 100644 --- a/impls/xslt/step3_env.xslt +++ b/impls/xslt/step3_env.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step4_if_fn_do.inc.xslt b/impls/xslt/step4_if_fn_do.inc.xslt index 538f93e243..83a0bc5bd1 100644 --- a/impls/xslt/step4_if_fn_do.inc.xslt +++ b/impls/xslt/step4_if_fn_do.inc.xslt @@ -1,523 +1,523 @@ - - - - - - - - - - - - - - - - - - - - (def! not (fn* (a) (if a false true))) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + (def! not (fn* (a) (if a false true))) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step4_if_fn_do.xslt b/impls/xslt/step4_if_fn_do.xslt index bf141dec1c..1f4b28481c 100644 --- a/impls/xslt/step4_if_fn_do.xslt +++ b/impls/xslt/step4_if_fn_do.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step6_file.inc.xslt b/impls/xslt/step6_file.inc.xslt index eb1ddfde68..ba15f6f781 100644 --- a/impls/xslt/step6_file.inc.xslt +++ b/impls/xslt/step6_file.inc.xslt @@ -1,648 +1,648 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step6_file.xslt b/impls/xslt/step6_file.xslt index a9a5cc0a6d..48264fa8ca 100644 --- a/impls/xslt/step6_file.xslt +++ b/impls/xslt/step6_file.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step7_quote.inc.xslt b/impls/xslt/step7_quote.inc.xslt index 33938af07b..0043543276 100644 --- a/impls/xslt/step7_quote.inc.xslt +++ b/impls/xslt/step7_quote.inc.xslt @@ -1,806 +1,806 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step7_quote.xslt b/impls/xslt/step7_quote.xslt index 6881af8e8d..4df5be3d24 100644 --- a/impls/xslt/step7_quote.xslt +++ b/impls/xslt/step7_quote.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step8_macros.inc.xslt b/impls/xslt/step8_macros.inc.xslt index 9bd639537c..16f36d563e 100644 --- a/impls/xslt/step8_macros.inc.xslt +++ b/impls/xslt/step8_macros.inc.xslt @@ -1,932 +1,932 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) (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)))))))) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - true - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - false - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) (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)))))))) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + false + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step8_macros.xslt b/impls/xslt/step8_macros.xslt index c422c6b8a1..4d44687f36 100644 --- a/impls/xslt/step8_macros.xslt +++ b/impls/xslt/step8_macros.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step9_try.inc.xslt b/impls/xslt/step9_try.inc.xslt index 9ce8dff582..4b73421d9d 100644 --- a/impls/xslt/step9_try.inc.xslt +++ b/impls/xslt/step9_try.inc.xslt @@ -1,1102 +1,1102 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) (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)))))))) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - true - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - false - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) (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)))))))) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + false + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/step9_try.xslt b/impls/xslt/step9_try.xslt index 9e9c2190a1..dcc9015dfc 100644 --- a/impls/xslt/step9_try.xslt +++ b/impls/xslt/step9_try.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/stepA_mal.inc.xslt b/impls/xslt/stepA_mal.inc.xslt index bb54b497ef..d4fe389489 100644 --- a/impls/xslt/stepA_mal.inc.xslt +++ b/impls/xslt/stepA_mal.inc.xslt @@ -1,1124 +1,1124 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) (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))))))) (def! *host-language* "XSLT")) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - true - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - false - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + (do (def! not (fn* (a) (if a false true))) (def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) (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))))))) (def! *host-language* "XSLT")) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + false + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/stepA_mal.xslt b/impls/xslt/stepA_mal.xslt index 25a86656e1..471f376802 100644 --- a/impls/xslt/stepA_mal.xslt +++ b/impls/xslt/stepA_mal.xslt @@ -1,45 +1,45 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/impls/xslt/test.xslt b/impls/xslt/test.xslt index 00f63d6ec7..3072ad3402 100644 --- a/impls/xslt/test.xslt +++ b/impls/xslt/test.xslt @@ -1,6 +1,6 @@ - - - - - - + + + + + + diff --git a/impls/yorick/Dockerfile b/impls/yorick/Dockerfile index 8a3f0037f3..f19090476c 100644 --- a/impls/yorick/Dockerfile +++ b/impls/yorick/Dockerfile @@ -1,26 +1,26 @@ -FROM ubuntu:xenial -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install yorick yorick-yeti yorick-yeti-regex - -ENV HOME /mal +FROM ubuntu:xenial +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install yorick yorick-yeti yorick-yeti-regex + +ENV HOME /mal diff --git a/impls/yorick/Makefile b/impls/yorick/Makefile index 04f60c4e65..a2a7837b22 100644 --- a/impls/yorick/Makefile +++ b/impls/yorick/Makefile @@ -1,17 +1,17 @@ -SOURCES_BASE = hash.i types.i reader.i printer.i -SOURCES_LISP = env.i core.i stepA_mal.i -SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) - -.PHONY: all dist clean - -all: dist - -dist: mal - -mal: $(SOURCES) - echo "#!/usr/bin/yorick -batch" > $@ - cat $+ | grep -v "^require," >> $@ - chmod +x $@ - -clean: - rm -f mal +SOURCES_BASE = hash.i types.i reader.i printer.i +SOURCES_LISP = env.i core.i stepA_mal.i +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +.PHONY: all dist clean + +all: dist + +dist: mal + +mal: $(SOURCES) + echo "#!/usr/bin/yorick -batch" > $@ + cat $+ | grep -v "^require," >> $@ + chmod +x $@ + +clean: + rm -f mal diff --git a/impls/yorick/core.i b/impls/yorick/core.i index bd3d246462..6e21946f47 100644 --- a/impls/yorick/core.i +++ b/impls/yorick/core.i @@ -1,384 +1,384 @@ -require, "types.i" - -func mal_equal(a) { return new_boolean(equal(*a(1), *a(2))); } -func mal_throw(a) { return MalError(obj=a(1)); } - -func mal_nil_q(a) { return new_boolean(structof(*a(1)) == MalNil); } -func mal_true_q(a) { return new_boolean(structof(*a(1)) == MalTrue); } -func mal_false_q(a) { return new_boolean(structof(*a(1)) == MalFalse); } -func mal_string_q(a) { return new_boolean(structof(*a(1)) == MalString); } -func mal_symbol(a) { return MalSymbol(val=a(1)->val); } -func mal_symbol_q(a) { return new_boolean(structof(*a(1)) == MalSymbol); } -func mal_keyword(a) { return MalKeyword(val=a(1)->val); } -func mal_keyword_q(a) { return new_boolean(structof(*a(1)) == MalKeyword); } -func mal_number_q(a) { return new_boolean(structof(*a(1)) == MalNumber); } -func mal_fn_q(a) -{ - if (structof(*a(1)) == MalNativeFunction) return MAL_TRUE; - return new_boolean(structof(*a(1)) == MalFunction && !a(1)->macro); -} -func mal_macro_q(a) { return new_boolean(structof(*a(1)) == MalFunction && a(1)->macro); } - -func string_helper(a, delimiter, readable) -{ - res = "" - for (i = 1; i <= numberof(a); ++i) { - if (i > 1) res += delimiter - res += pr_str(*a(i), readable) - } - return res -} - -func mal_pr_str(a) { return MalString(val=string_helper(a, " ", 1)); } -func mal_str(a) { return MalString(val=string_helper(a, "", 0)); } -func mal_prn(a) { write, format="%s\n", string_helper(a, " ", 1); return MAL_NIL; } -func mal_println(a) { write, format="%s\n", string_helper(a, " ", 0); return MAL_NIL; } -func mal_read_string(a) { return read_str(a(1)->val); } - -func mal_readline(a) -{ - extern stdin_file - stdin_file = open("/dev/stdin", "r") - write, format="%s", a(1)->val - line = rdline(stdin_file, prompt="") - return line ? MalString(val=line) : MAL_NIL -} - -func mal_slurp(a) -{ - f = open(a(1)->val) - lines = rdfile(f) - close, f - s = "" - for (i = 1; i <= numberof(lines); ++i) { - s += (lines(i) + "\n") - } - return MalString(val=s) -} - -func mal_lt(a) { return new_boolean(a(1)->val < a(2)->val); } -func mal_lte(a) { return new_boolean(a(1)->val <= a(2)->val); } -func mal_gt(a) { return new_boolean(a(1)->val > a(2)->val); } -func mal_gte(a) { return new_boolean(a(1)->val >= a(2)->val); } - -func mal_add(a) { return MalNumber(val=(a(1)->val + a(2)->val)); } -func mal_sub(a) { return MalNumber(val=(a(1)->val - a(2)->val)); } -func mal_mul(a) { return MalNumber(val=(a(1)->val * a(2)->val)); } -func mal_div(a) { return MalNumber(val=(a(1)->val / a(2)->val)); } - -func mal_time_ms(a) -{ - elapsed = array(double, 3) - timer, elapsed - return MalNumber(val=floor(elapsed(3) * 1000)) -} - -func mal_list(a) { return MalList(val=&a); } -func mal_list_q(a) { return new_boolean(structof(*a(1)) == MalList); } -func mal_vector(a) { return MalVector(val=&a); } -func mal_vector_q(a) { return new_boolean(structof(*a(1)) == MalVector); } -func mal_hash_map(a) { return array_to_hashmap(a); } -func mal_map_q(a) { return new_boolean(structof(*a(1)) == MalHashmap); } - -func mal_assoc(a) { - h = *(a(1)->val) - k1 = *h.keys - v1 = *h.vals - new_h = Hash(keys=&k1, vals=&v1) - for (i = 2; i <= numberof(a); i += 2) { - hash_set, new_h, hashmap_obj_to_key(*a(i)), *a(i + 1) - } - return MalHashmap(val=&new_h); -} - -func mal_dissoc(a) { - h = *(a(1)->val) - k1 = *h.keys - v1 = *h.vals - new_h = Hash(keys=&k1, vals=&v1) - for (i = 2; i <= numberof(a); ++i) { - hash_delete, new_h, hashmap_obj_to_key(*a(i)) - } - return MalHashmap(val=&new_h); -} - -func mal_get(a) { - if (structof(*a(1)) == MalNil) return MAL_NIL - h = *(a(1)->val) - key_obj = *a(2) - val = hash_get(h, hashmap_obj_to_key(key_obj)) - return is_void(val) ? MAL_NIL : val -} - -func mal_contains_q(a) { - if (structof(*a(1)) == MalNil) return MAL_FALSE - h = *(a(1)->val) - key_obj = *a(2) - return hash_has_key(h, hashmap_obj_to_key(key_obj)) ? MAL_TRUE : MAL_FALSE -} - -func mal_keys(a) { - keys_strs = *(a(1)->val->keys) - if (numberof(keys_strs) == 0) return MalList(val=&[]) - res = array(pointer, numberof(keys_strs)) - for (i = 1; i <= numberof(keys_strs); ++i) { - res(i) = &hashmap_key_to_obj(keys_strs(i)) - } - return MalList(val=&res); -} - -func mal_vals(a) { return MalList(val=a(1)->val->vals); } - -func mal_sequential_q(a) { return new_boolean(structof(*a(1)) == MalList || structof(*a(1)) == MalVector); } - -func mal_cons(a) -{ - a2_len = count(*a(2)) - seq = array(pointer, a2_len + 1) - seq(1) = a(1) - if (a2_len > 0) { - seq(2:) = *(a(2)->val) - } - return MalList(val=&seq) -} - -func mal_concat(a) -{ - seq = [] - for (i = 1; i <= numberof(a); ++i) { - grow, seq, *(a(i)->val) - } - return MalList(val=&seq) -} - -func mal_vec(a) -{ - if (numberof(a) == 1) { - type = structof(*a(1)) - if (type == MalVector) return *(a(1)) - if (type == MalList) return MalVector(val=a(1)->val) - } - return MalError(message="vec: requires a sequence") -} - -func mal_nth(a) -{ - index = a(2)->val - if (index >= count(*a(1))) return MalError(message="nth: index out of range") - return *((*(a(1)->val))(index + 1)) -} - -func mal_first(a) -{ - if (structof(*a(1)) == MalNil || count(*a(1)) == 0) return MAL_NIL - return *((*(a(1)->val))(1)) -} - -func mal_rest(a) -{ - if (structof(*a(1)) == MalNil) return MalList(val=&[]) - return rest(*a(1)) -} - -func mal_empty_q(a) { return new_boolean((structof(*a(1)) == MalNil ? 1 : count(*a(1)) == 0)); } -func mal_count(a) { return MalNumber(val=(structof(*a(1)) == MalNil ? 0 : count(*a(1)))); } - -func call_func(fn, args) -{ - if (structof(fn) == MalNativeFunction) { - return call_core_fn(fn.val, args) - } else if (structof(fn) == MalFunction) { - fn_env = env_new(fn.env, binds=*fn.binds, exprs=args) - return EVAL(*fn.ast, fn_env) - } else { - return MalError(message="Unknown function type") - } -} - -func mal_apply(a) { - mid_args = numberof(a) > 2 ? a(2:-1) : [] - return call_func(*a(1), grow(mid_args, *(a(0)->val))) -} - -func mal_map(a) { - fn = *a(1) - seq = *(a(2)->val) - if (numberof(seq) == 0) return MalList(val=&[]) - new_seq = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - new_val = call_func(fn, [seq(i)]) - if (structof(new_val) == MalError) return new_val - new_seq(i) = &new_val - } - return MalList(val=&new_seq) -} - -func mal_conj(a) -{ - obj = *a(1) - type = structof(obj) - if (type == MalList) { - res = obj - for (i = 2; i <= numberof(a); ++i) { - res = mal_cons([a(i), &res]) - } - return res - } else if (type == MalVector) { - seq = *obj.val - grow, seq, a(2:) - return MalVector(val=&seq) - } else { - return MalError(message="conj requires list or vector") - } -} - -func mal_seq(a) -{ - obj = *a(1) - type = structof(obj) - if (type == MalString) { - len = strlen(obj.val) - if (len == 0) return MAL_NIL - seq = array(pointer, len) - for (i = 1; i <= len; ++i) { - seq(i) = &MalString(val=strpart(obj.val, i:i)) - } - return MalList(val=&seq) - } else if (type == MalList) { - return count(obj) == 0 ? MAL_NIL : obj - } else if (type == MalVector) { - return count(obj) == 0 ? MAL_NIL : MalList(val=obj.val) - } else if (type == MalNil) { - return MAL_NIL - } else { - return MalError(message="seq requires string or list or vector or nil") - } -} - -func mal_meta(a) -{ - meta_obj = *(a(1)->meta) - return is_void(meta_obj) ? MAL_NIL : meta_obj -} - -func mal_with_meta(a) -{ - new_obj = *a(1) - new_obj.meta = a(2) - return new_obj -} - -func mal_atom(a) { return MalAtom(val=&MalAtomVal(val=a(1))); } -func mal_atom_q(a) { return new_boolean(structof(*a(1)) == MalAtom); } -func mal_deref(a) { return *(a(1)->val->val); } -func mal_reset_bang(a) { a(1)->val->val = a(2); return *(a(1)->val->val); } -func mal_swap_bang(a) -{ - old_val = mal_deref([a(1)]) - args = array(pointer, numberof(a) - 1) - args(1) = &old_val - if (numberof(a) > 2) args(2:) = a(3:) - new_val = call_func(*a(2), args) - if (structof(new_val) == MalError) return new_val - return mal_reset_bang([a(1), &new_val]) -} - -func mal_eval(a) { return EVAL(*a(1), repl_env); } - -func yorick_to_mal(e) -{ - if (is_void(e)) return MAL_NIL - if (is_scalar(e)) { - if (is_numerical(e)) return MalNumber(val=e) - else if (is_string(e)) return MalString(val=e) - else return MalString(val=totxt(e)) - } else { - seq = array(pointer, numberof(e)) - for (i = 1; i <= numberof(e); ++i) { - seq(i) = &yorick_to_mal(e(i)) - } - return MalList(val=&seq) - } -} - -func mal_yorick_eval(a) { return yorick_to_mal(exec(a(1)->val)); } - -core_ns = h_new() - -h_set, core_ns, "=", mal_equal -h_set, core_ns, "throw", mal_throw - -h_set, core_ns, "nil?", mal_nil_q -h_set, core_ns, "true?", mal_true_q -h_set, core_ns, "false?", mal_false_q -h_set, core_ns, "string?", mal_string_q -h_set, core_ns, "symbol", mal_symbol -h_set, core_ns, "symbol?", mal_symbol_q -h_set, core_ns, "keyword", mal_keyword -h_set, core_ns, "keyword?", mal_keyword_q -h_set, core_ns, "number?", mal_number_q -h_set, core_ns, "fn?", mal_fn_q -h_set, core_ns, "macro?", mal_macro_q - -h_set, core_ns, "pr-str", mal_pr_str -h_set, core_ns, "str", mal_str -h_set, core_ns, "prn", mal_prn -h_set, core_ns, "println", mal_println -h_set, core_ns, "read-string", mal_read_string -h_set, core_ns, "readline", mal_readline -h_set, core_ns, "slurp", mal_slurp - -h_set, core_ns, "<", mal_lt -h_set, core_ns, "<=", mal_lte -h_set, core_ns, ">", mal_gt -h_set, core_ns, ">=", mal_gte -h_set, core_ns, "+", mal_add -h_set, core_ns, "-", mal_sub -h_set, core_ns, "*", mal_mul -h_set, core_ns, "/", mal_div -h_set, core_ns, "time-ms", mal_time_ms - -h_set, core_ns, "list", mal_list -h_set, core_ns, "list?", mal_list_q -h_set, core_ns, "vector", mal_vector -h_set, core_ns, "vector?", mal_vector_q -h_set, core_ns, "hash-map", mal_hash_map -h_set, core_ns, "map?", mal_map_q -h_set, core_ns, "assoc", mal_assoc -h_set, core_ns, "dissoc", mal_dissoc -h_set, core_ns, "get", mal_get -h_set, core_ns, "contains?", mal_contains_q -h_set, core_ns, "keys", mal_keys -h_set, core_ns, "vals", mal_vals - -h_set, core_ns, "sequential?", mal_sequential_q -h_set, core_ns, "cons", mal_cons -h_set, core_ns, "concat", mal_concat -h_set, core_ns, "vec", mal_vec -h_set, core_ns, "nth", mal_nth -h_set, core_ns, "first", mal_first -h_set, core_ns, "rest", mal_rest -h_set, core_ns, "empty?", mal_empty_q -h_set, core_ns, "count", mal_count -h_set, core_ns, "apply", mal_apply -h_set, core_ns, "map", mal_map - -h_set, core_ns, "conj", mal_conj -h_set, core_ns, "seq", mal_seq - -h_set, core_ns, "meta", mal_meta -h_set, core_ns, "with-meta", mal_with_meta -h_set, core_ns, "atom", mal_atom -h_set, core_ns, "atom?", mal_atom_q -h_set, core_ns, "deref", mal_deref -h_set, core_ns, "reset!", mal_reset_bang -h_set, core_ns, "swap!", mal_swap_bang - -h_set, core_ns, "eval", mal_eval -h_set, core_ns, "yorick-eval", mal_yorick_eval - -func call_core_fn(name, args_list) -{ - f = h_get(core_ns, name) - return f(args_list) -} +require, "types.i" + +func mal_equal(a) { return new_boolean(equal(*a(1), *a(2))); } +func mal_throw(a) { return MalError(obj=a(1)); } + +func mal_nil_q(a) { return new_boolean(structof(*a(1)) == MalNil); } +func mal_true_q(a) { return new_boolean(structof(*a(1)) == MalTrue); } +func mal_false_q(a) { return new_boolean(structof(*a(1)) == MalFalse); } +func mal_string_q(a) { return new_boolean(structof(*a(1)) == MalString); } +func mal_symbol(a) { return MalSymbol(val=a(1)->val); } +func mal_symbol_q(a) { return new_boolean(structof(*a(1)) == MalSymbol); } +func mal_keyword(a) { return MalKeyword(val=a(1)->val); } +func mal_keyword_q(a) { return new_boolean(structof(*a(1)) == MalKeyword); } +func mal_number_q(a) { return new_boolean(structof(*a(1)) == MalNumber); } +func mal_fn_q(a) +{ + if (structof(*a(1)) == MalNativeFunction) return MAL_TRUE; + return new_boolean(structof(*a(1)) == MalFunction && !a(1)->macro); +} +func mal_macro_q(a) { return new_boolean(structof(*a(1)) == MalFunction && a(1)->macro); } + +func string_helper(a, delimiter, readable) +{ + res = "" + for (i = 1; i <= numberof(a); ++i) { + if (i > 1) res += delimiter + res += pr_str(*a(i), readable) + } + return res +} + +func mal_pr_str(a) { return MalString(val=string_helper(a, " ", 1)); } +func mal_str(a) { return MalString(val=string_helper(a, "", 0)); } +func mal_prn(a) { write, format="%s\n", string_helper(a, " ", 1); return MAL_NIL; } +func mal_println(a) { write, format="%s\n", string_helper(a, " ", 0); return MAL_NIL; } +func mal_read_string(a) { return read_str(a(1)->val); } + +func mal_readline(a) +{ + extern stdin_file + stdin_file = open("/dev/stdin", "r") + write, format="%s", a(1)->val + line = rdline(stdin_file, prompt="") + return line ? MalString(val=line) : MAL_NIL +} + +func mal_slurp(a) +{ + f = open(a(1)->val) + lines = rdfile(f) + close, f + s = "" + for (i = 1; i <= numberof(lines); ++i) { + s += (lines(i) + "\n") + } + return MalString(val=s) +} + +func mal_lt(a) { return new_boolean(a(1)->val < a(2)->val); } +func mal_lte(a) { return new_boolean(a(1)->val <= a(2)->val); } +func mal_gt(a) { return new_boolean(a(1)->val > a(2)->val); } +func mal_gte(a) { return new_boolean(a(1)->val >= a(2)->val); } + +func mal_add(a) { return MalNumber(val=(a(1)->val + a(2)->val)); } +func mal_sub(a) { return MalNumber(val=(a(1)->val - a(2)->val)); } +func mal_mul(a) { return MalNumber(val=(a(1)->val * a(2)->val)); } +func mal_div(a) { return MalNumber(val=(a(1)->val / a(2)->val)); } + +func mal_time_ms(a) +{ + elapsed = array(double, 3) + timer, elapsed + return MalNumber(val=floor(elapsed(3) * 1000)) +} + +func mal_list(a) { return MalList(val=&a); } +func mal_list_q(a) { return new_boolean(structof(*a(1)) == MalList); } +func mal_vector(a) { return MalVector(val=&a); } +func mal_vector_q(a) { return new_boolean(structof(*a(1)) == MalVector); } +func mal_hash_map(a) { return array_to_hashmap(a); } +func mal_map_q(a) { return new_boolean(structof(*a(1)) == MalHashmap); } + +func mal_assoc(a) { + h = *(a(1)->val) + k1 = *h.keys + v1 = *h.vals + new_h = Hash(keys=&k1, vals=&v1) + for (i = 2; i <= numberof(a); i += 2) { + hash_set, new_h, hashmap_obj_to_key(*a(i)), *a(i + 1) + } + return MalHashmap(val=&new_h); +} + +func mal_dissoc(a) { + h = *(a(1)->val) + k1 = *h.keys + v1 = *h.vals + new_h = Hash(keys=&k1, vals=&v1) + for (i = 2; i <= numberof(a); ++i) { + hash_delete, new_h, hashmap_obj_to_key(*a(i)) + } + return MalHashmap(val=&new_h); +} + +func mal_get(a) { + if (structof(*a(1)) == MalNil) return MAL_NIL + h = *(a(1)->val) + key_obj = *a(2) + val = hash_get(h, hashmap_obj_to_key(key_obj)) + return is_void(val) ? MAL_NIL : val +} + +func mal_contains_q(a) { + if (structof(*a(1)) == MalNil) return MAL_FALSE + h = *(a(1)->val) + key_obj = *a(2) + return hash_has_key(h, hashmap_obj_to_key(key_obj)) ? MAL_TRUE : MAL_FALSE +} + +func mal_keys(a) { + keys_strs = *(a(1)->val->keys) + if (numberof(keys_strs) == 0) return MalList(val=&[]) + res = array(pointer, numberof(keys_strs)) + for (i = 1; i <= numberof(keys_strs); ++i) { + res(i) = &hashmap_key_to_obj(keys_strs(i)) + } + return MalList(val=&res); +} + +func mal_vals(a) { return MalList(val=a(1)->val->vals); } + +func mal_sequential_q(a) { return new_boolean(structof(*a(1)) == MalList || structof(*a(1)) == MalVector); } + +func mal_cons(a) +{ + a2_len = count(*a(2)) + seq = array(pointer, a2_len + 1) + seq(1) = a(1) + if (a2_len > 0) { + seq(2:) = *(a(2)->val) + } + return MalList(val=&seq) +} + +func mal_concat(a) +{ + seq = [] + for (i = 1; i <= numberof(a); ++i) { + grow, seq, *(a(i)->val) + } + return MalList(val=&seq) +} + +func mal_vec(a) +{ + if (numberof(a) == 1) { + type = structof(*a(1)) + if (type == MalVector) return *(a(1)) + if (type == MalList) return MalVector(val=a(1)->val) + } + return MalError(message="vec: requires a sequence") +} + +func mal_nth(a) +{ + index = a(2)->val + if (index >= count(*a(1))) return MalError(message="nth: index out of range") + return *((*(a(1)->val))(index + 1)) +} + +func mal_first(a) +{ + if (structof(*a(1)) == MalNil || count(*a(1)) == 0) return MAL_NIL + return *((*(a(1)->val))(1)) +} + +func mal_rest(a) +{ + if (structof(*a(1)) == MalNil) return MalList(val=&[]) + return rest(*a(1)) +} + +func mal_empty_q(a) { return new_boolean((structof(*a(1)) == MalNil ? 1 : count(*a(1)) == 0)); } +func mal_count(a) { return MalNumber(val=(structof(*a(1)) == MalNil ? 0 : count(*a(1)))); } + +func call_func(fn, args) +{ + if (structof(fn) == MalNativeFunction) { + return call_core_fn(fn.val, args) + } else if (structof(fn) == MalFunction) { + fn_env = env_new(fn.env, binds=*fn.binds, exprs=args) + return EVAL(*fn.ast, fn_env) + } else { + return MalError(message="Unknown function type") + } +} + +func mal_apply(a) { + mid_args = numberof(a) > 2 ? a(2:-1) : [] + return call_func(*a(1), grow(mid_args, *(a(0)->val))) +} + +func mal_map(a) { + fn = *a(1) + seq = *(a(2)->val) + if (numberof(seq) == 0) return MalList(val=&[]) + new_seq = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + new_val = call_func(fn, [seq(i)]) + if (structof(new_val) == MalError) return new_val + new_seq(i) = &new_val + } + return MalList(val=&new_seq) +} + +func mal_conj(a) +{ + obj = *a(1) + type = structof(obj) + if (type == MalList) { + res = obj + for (i = 2; i <= numberof(a); ++i) { + res = mal_cons([a(i), &res]) + } + return res + } else if (type == MalVector) { + seq = *obj.val + grow, seq, a(2:) + return MalVector(val=&seq) + } else { + return MalError(message="conj requires list or vector") + } +} + +func mal_seq(a) +{ + obj = *a(1) + type = structof(obj) + if (type == MalString) { + len = strlen(obj.val) + if (len == 0) return MAL_NIL + seq = array(pointer, len) + for (i = 1; i <= len; ++i) { + seq(i) = &MalString(val=strpart(obj.val, i:i)) + } + return MalList(val=&seq) + } else if (type == MalList) { + return count(obj) == 0 ? MAL_NIL : obj + } else if (type == MalVector) { + return count(obj) == 0 ? MAL_NIL : MalList(val=obj.val) + } else if (type == MalNil) { + return MAL_NIL + } else { + return MalError(message="seq requires string or list or vector or nil") + } +} + +func mal_meta(a) +{ + meta_obj = *(a(1)->meta) + return is_void(meta_obj) ? MAL_NIL : meta_obj +} + +func mal_with_meta(a) +{ + new_obj = *a(1) + new_obj.meta = a(2) + return new_obj +} + +func mal_atom(a) { return MalAtom(val=&MalAtomVal(val=a(1))); } +func mal_atom_q(a) { return new_boolean(structof(*a(1)) == MalAtom); } +func mal_deref(a) { return *(a(1)->val->val); } +func mal_reset_bang(a) { a(1)->val->val = a(2); return *(a(1)->val->val); } +func mal_swap_bang(a) +{ + old_val = mal_deref([a(1)]) + args = array(pointer, numberof(a) - 1) + args(1) = &old_val + if (numberof(a) > 2) args(2:) = a(3:) + new_val = call_func(*a(2), args) + if (structof(new_val) == MalError) return new_val + return mal_reset_bang([a(1), &new_val]) +} + +func mal_eval(a) { return EVAL(*a(1), repl_env); } + +func yorick_to_mal(e) +{ + if (is_void(e)) return MAL_NIL + if (is_scalar(e)) { + if (is_numerical(e)) return MalNumber(val=e) + else if (is_string(e)) return MalString(val=e) + else return MalString(val=totxt(e)) + } else { + seq = array(pointer, numberof(e)) + for (i = 1; i <= numberof(e); ++i) { + seq(i) = &yorick_to_mal(e(i)) + } + return MalList(val=&seq) + } +} + +func mal_yorick_eval(a) { return yorick_to_mal(exec(a(1)->val)); } + +core_ns = h_new() + +h_set, core_ns, "=", mal_equal +h_set, core_ns, "throw", mal_throw + +h_set, core_ns, "nil?", mal_nil_q +h_set, core_ns, "true?", mal_true_q +h_set, core_ns, "false?", mal_false_q +h_set, core_ns, "string?", mal_string_q +h_set, core_ns, "symbol", mal_symbol +h_set, core_ns, "symbol?", mal_symbol_q +h_set, core_ns, "keyword", mal_keyword +h_set, core_ns, "keyword?", mal_keyword_q +h_set, core_ns, "number?", mal_number_q +h_set, core_ns, "fn?", mal_fn_q +h_set, core_ns, "macro?", mal_macro_q + +h_set, core_ns, "pr-str", mal_pr_str +h_set, core_ns, "str", mal_str +h_set, core_ns, "prn", mal_prn +h_set, core_ns, "println", mal_println +h_set, core_ns, "read-string", mal_read_string +h_set, core_ns, "readline", mal_readline +h_set, core_ns, "slurp", mal_slurp + +h_set, core_ns, "<", mal_lt +h_set, core_ns, "<=", mal_lte +h_set, core_ns, ">", mal_gt +h_set, core_ns, ">=", mal_gte +h_set, core_ns, "+", mal_add +h_set, core_ns, "-", mal_sub +h_set, core_ns, "*", mal_mul +h_set, core_ns, "/", mal_div +h_set, core_ns, "time-ms", mal_time_ms + +h_set, core_ns, "list", mal_list +h_set, core_ns, "list?", mal_list_q +h_set, core_ns, "vector", mal_vector +h_set, core_ns, "vector?", mal_vector_q +h_set, core_ns, "hash-map", mal_hash_map +h_set, core_ns, "map?", mal_map_q +h_set, core_ns, "assoc", mal_assoc +h_set, core_ns, "dissoc", mal_dissoc +h_set, core_ns, "get", mal_get +h_set, core_ns, "contains?", mal_contains_q +h_set, core_ns, "keys", mal_keys +h_set, core_ns, "vals", mal_vals + +h_set, core_ns, "sequential?", mal_sequential_q +h_set, core_ns, "cons", mal_cons +h_set, core_ns, "concat", mal_concat +h_set, core_ns, "vec", mal_vec +h_set, core_ns, "nth", mal_nth +h_set, core_ns, "first", mal_first +h_set, core_ns, "rest", mal_rest +h_set, core_ns, "empty?", mal_empty_q +h_set, core_ns, "count", mal_count +h_set, core_ns, "apply", mal_apply +h_set, core_ns, "map", mal_map + +h_set, core_ns, "conj", mal_conj +h_set, core_ns, "seq", mal_seq + +h_set, core_ns, "meta", mal_meta +h_set, core_ns, "with-meta", mal_with_meta +h_set, core_ns, "atom", mal_atom +h_set, core_ns, "atom?", mal_atom_q +h_set, core_ns, "deref", mal_deref +h_set, core_ns, "reset!", mal_reset_bang +h_set, core_ns, "swap!", mal_swap_bang + +h_set, core_ns, "eval", mal_eval +h_set, core_ns, "yorick-eval", mal_yorick_eval + +func call_core_fn(name, args_list) +{ + f = h_get(core_ns, name) + return f(args_list) +} diff --git a/impls/yorick/env.i b/impls/yorick/env.i index d1e8a9cdc0..9556416ade 100644 --- a/impls/yorick/env.i +++ b/impls/yorick/env.i @@ -1,44 +1,44 @@ -require, "hash.i" -require, "types.i" - -struct Env { - pointer outer - Hash data -} - -func env_new(outer_ptr, binds=, exprs=) -{ - env = Env(outer=outer_ptr, data=hash_new()) - for (i = 1; i <= numberof(binds); ++i) { - if (binds(i)->val == "&") { - rest_args = numberof(exprs) >= i ? exprs(i:) : [] - env_set, env, binds(i + 1)->val, MalList(val=&rest_args) - break - } else { - env_set, env, binds(i)->val, *exprs(i) - } - } - return env -} - -func env_find(env, key) -{ - if (hash_has_key(env.data, key)) return env - if (is_void(*env.outer)) return nil - return env_find(*env.outer, key) -} - -func env_get(env, key) -{ - found_env = env_find(env, key) - if (is_void(found_env)) return MalError(message=("'" + key + "' not found")) - return hash_get(found_env.data, key) -} - -func env_set(&env, key, val) -{ - d = env.data - hash_set, d, key, val - env.data = d - return val -} +require, "hash.i" +require, "types.i" + +struct Env { + pointer outer + Hash data +} + +func env_new(outer_ptr, binds=, exprs=) +{ + env = Env(outer=outer_ptr, data=hash_new()) + for (i = 1; i <= numberof(binds); ++i) { + if (binds(i)->val == "&") { + rest_args = numberof(exprs) >= i ? exprs(i:) : [] + env_set, env, binds(i + 1)->val, MalList(val=&rest_args) + break + } else { + env_set, env, binds(i)->val, *exprs(i) + } + } + return env +} + +func env_find(env, key) +{ + if (hash_has_key(env.data, key)) return env + if (is_void(*env.outer)) return nil + return env_find(*env.outer, key) +} + +func env_get(env, key) +{ + found_env = env_find(env, key) + if (is_void(found_env)) return MalError(message=("'" + key + "' not found")) + return hash_get(found_env.data, key) +} + +func env_set(&env, key, val) +{ + d = env.data + hash_set, d, key, val + env.data = d + return val +} diff --git a/impls/yorick/hash.i b/impls/yorick/hash.i index 250e4c72dc..f40b0e7f94 100644 --- a/impls/yorick/hash.i +++ b/impls/yorick/hash.i @@ -1,79 +1,79 @@ -// Implement our old naive O(n) map because Yeti's hash table (h_new()) cannot -// be used inside arrays and structs (we can't get a pointer to hash table). -// This prevents saving pointer to environment in MalFunction for example. - -struct Hash { - pointer keys - pointer vals -} - -func hash_new(void) -{ - return Hash(keys=&[], vals=&[]) -} - -func hash_get(h, key) -{ - for (i = 1; i <= numberof(*h.keys); ++i) { - if ((*h.keys)(i) == key) return *((*h.vals)(i)) - } - return nil -} - -func hash_has_key(h, key) -{ - for (i = 1; i <= numberof(*h.keys); ++i) { - if ((*h.keys)(i) == key) return 1 - } - return 0 -} - -func hash_set(&h, key, val) -{ - if (is_void(*h.keys)) { - h.keys = &[key] - h.vals = &[&val] - return - } - for (i = 1; i <= numberof(*h.keys); ++i) { - if ((*h.keys)(i) == key) { - (*h.vals)(i) = &val - return - } - } - tmp = *h.keys - grow, tmp, [key] - h.keys = &tmp - tmp = *h.vals - grow, tmp, [&val] - h.vals = &tmp -} - -func hash_delete(&h, key) -{ - if (is_void(*h.keys) || numberof(*h.keys) == 0) return - k = *h.keys - v = *h.vals - if (numberof(k) == 1) { - if (k(1) == key) { - h.keys = &[] - h.vals = &[] - return - } - } - for (i = 1; i <= numberof(k); ++i) { - if (k(i) == key) { - if (i == 1) { - h.keys = &(k(i+1:)) - h.vals = &(v(i+1:)) - } else if (i == numberof(k)) { - h.keys = &(k(1:i-1)) - h.vals = &(v(1:i-1)) - } else { - h.keys = &grow(k(1:i-1), k(i+1:)) - h.vals = &grow(v(1:i-1), v(i+1:)) - } - return - } - } -} +// Implement our old naive O(n) map because Yeti's hash table (h_new()) cannot +// be used inside arrays and structs (we can't get a pointer to hash table). +// This prevents saving pointer to environment in MalFunction for example. + +struct Hash { + pointer keys + pointer vals +} + +func hash_new(void) +{ + return Hash(keys=&[], vals=&[]) +} + +func hash_get(h, key) +{ + for (i = 1; i <= numberof(*h.keys); ++i) { + if ((*h.keys)(i) == key) return *((*h.vals)(i)) + } + return nil +} + +func hash_has_key(h, key) +{ + for (i = 1; i <= numberof(*h.keys); ++i) { + if ((*h.keys)(i) == key) return 1 + } + return 0 +} + +func hash_set(&h, key, val) +{ + if (is_void(*h.keys)) { + h.keys = &[key] + h.vals = &[&val] + return + } + for (i = 1; i <= numberof(*h.keys); ++i) { + if ((*h.keys)(i) == key) { + (*h.vals)(i) = &val + return + } + } + tmp = *h.keys + grow, tmp, [key] + h.keys = &tmp + tmp = *h.vals + grow, tmp, [&val] + h.vals = &tmp +} + +func hash_delete(&h, key) +{ + if (is_void(*h.keys) || numberof(*h.keys) == 0) return + k = *h.keys + v = *h.vals + if (numberof(k) == 1) { + if (k(1) == key) { + h.keys = &[] + h.vals = &[] + return + } + } + for (i = 1; i <= numberof(k); ++i) { + if (k(i) == key) { + if (i == 1) { + h.keys = &(k(i+1:)) + h.vals = &(v(i+1:)) + } else if (i == numberof(k)) { + h.keys = &(k(1:i-1)) + h.vals = &(v(1:i-1)) + } else { + h.keys = &grow(k(1:i-1), k(i+1:)) + h.vals = &grow(v(1:i-1), v(i+1:)) + } + return + } + } +} diff --git a/impls/yorick/printer.i b/impls/yorick/printer.i index acefd17c26..64dfbcfad9 100644 --- a/impls/yorick/printer.i +++ b/impls/yorick/printer.i @@ -1,50 +1,50 @@ -require, "types.i" - -func format_seq(val, start_char, end_char, readable) -{ - seq = *val - res = "" - for (i = 1; i <= numberof(seq); ++i) { - if (i > 1) res += " " - res += pr_str(*seq(i), readable) - } - return start_char + res + end_char -} - -func format_hashmap(h, readable) -{ - res = "" - for (i = 1; i <= numberof(*h.keys); ++i) { - if (i > 1) res += " " - key = hashmap_key_to_obj((*h.keys)(i)) - res += pr_str(key, readable) + " " + pr_str(*((*h.vals)(i)), readable) - } - return "{" + res + "}" -} - -func escape(s) -{ - s1 = streplaceall(s, "\\", "\\\\") - s2 = streplaceall(s1, "\"", "\\\"") - s3 = streplaceall(s2, "\n", "\\n") - return "\"" + s3 + "\"" -} - -func pr_str(ast, readable) -{ - type = structof(ast) - if (type == MalNil) return "nil" - else if (type == MalTrue) return "true" - else if (type == MalFalse) return "false" - else if (type == MalNumber) return totxt(ast.val) - else if (type == MalSymbol) return ast.val - else if (type == MalString) return readable ? escape(ast.val) : ast.val - else if (type == MalKeyword) return ":" + ast.val - else if (type == MalList) return format_seq(ast.val, "(", ")", readable) - else if (type == MalVector) return format_seq(ast.val, "[", "]", readable) - else if (type == MalHashmap) return format_hashmap(*ast.val, readable) - else if (type == MalAtom) return "(atom " + pr_str(*(ast.val->val), readable) + ")" - else if (type == MalNativeFunction) return "#" - else if (type == MalFunction) return "#" - else MalError(message=("Unknown type " + totxt(type))) -} +require, "types.i" + +func format_seq(val, start_char, end_char, readable) +{ + seq = *val + res = "" + for (i = 1; i <= numberof(seq); ++i) { + if (i > 1) res += " " + res += pr_str(*seq(i), readable) + } + return start_char + res + end_char +} + +func format_hashmap(h, readable) +{ + res = "" + for (i = 1; i <= numberof(*h.keys); ++i) { + if (i > 1) res += " " + key = hashmap_key_to_obj((*h.keys)(i)) + res += pr_str(key, readable) + " " + pr_str(*((*h.vals)(i)), readable) + } + return "{" + res + "}" +} + +func escape(s) +{ + s1 = streplaceall(s, "\\", "\\\\") + s2 = streplaceall(s1, "\"", "\\\"") + s3 = streplaceall(s2, "\n", "\\n") + return "\"" + s3 + "\"" +} + +func pr_str(ast, readable) +{ + type = structof(ast) + if (type == MalNil) return "nil" + else if (type == MalTrue) return "true" + else if (type == MalFalse) return "false" + else if (type == MalNumber) return totxt(ast.val) + else if (type == MalSymbol) return ast.val + else if (type == MalString) return readable ? escape(ast.val) : ast.val + else if (type == MalKeyword) return ":" + ast.val + else if (type == MalList) return format_seq(ast.val, "(", ")", readable) + else if (type == MalVector) return format_seq(ast.val, "[", "]", readable) + else if (type == MalHashmap) return format_hashmap(*ast.val, readable) + else if (type == MalAtom) return "(atom " + pr_str(*(ast.val->val), readable) + ")" + else if (type == MalNativeFunction) return "#" + else if (type == MalFunction) return "#" + else MalError(message=("Unknown type " + totxt(type))) +} diff --git a/impls/yorick/reader.i b/impls/yorick/reader.i index 92adfd0fab..6dda51ea6a 100644 --- a/impls/yorick/reader.i +++ b/impls/yorick/reader.i @@ -1,159 +1,159 @@ -#include "yeti_regex.i" -require, "types.i" - -TOKENIZER_REGEXP = regcomp("[[:space:],]*(~@|[][{}()'`~@]|\"([\\].|[^\\\"])*\"?|;[^\n]*|[^][[:space:]{}()'\"`~@,;]*)") - -func tokenize(str) -{ - match0 = "" - match1 = "" - pos = 1 - tokens = [] - while (1) { - m = regmatch(TOKENIZER_REGEXP, str, match0, match1, start=pos, indices=1) - if (m == 0) break - b = match1(1) - e = match1(2) - 1 - if (e < b) { - pos = match1(2) + 1 - continue - } - token = strpart(str, b:e) - pos = match1(2) - if (strpart(token, 1:1) == ";") continue - grow, tokens, [token] - } - return tokens -} - -struct Reader { - pointer tokens - int pos -} - -func reader_peek(rdr) -{ - if (rdr.pos > numberof(*rdr.tokens)) return string(0) - return (*rdr.tokens)(rdr.pos) -} - -func reader_next(rdr) -{ - token = reader_peek(rdr) - rdr.pos += 1 - return token -} - -NUMBER_REGEXP = regcomp("^-?[0-9]+$") -STR_REGEXP = regcomp("^\"([\\].|[^\\\"])*\"$") -STR_BAD_REGEXP = regcomp("^\".*$") - -func unescape(s) -{ - s = strpart(s, 2:-1) // remove surrounding quotes - s = streplaceall(s, "\\\\", "\x01") - s = streplaceall(s, "\\n", "\n") - s = streplaceall(s, "\\\"", "\"") - return streplaceall(s, "\x01", "\\") -} - -func read_atom(rdr) -{ - token = reader_next(rdr) - if (token == "nil") return MAL_NIL - else if (token == "true") return MAL_TRUE - else if (token == "false") return MAL_FALSE - else if (regmatch(NUMBER_REGEXP, token)) return MalNumber(val=tonum(token)) - else if (regmatch(STR_REGEXP, token)) return MalString(val=unescape(token)) - else if (regmatch(STR_BAD_REGEXP, token)) return MalError(message=("expected '\"', got EOF")) - else if (strpart(token, 1:1) == ":") return MalKeyword(val=strpart(token, 2:)) - else return MalSymbol(val=token) -} - -func read_seq(rdr, start_char, end_char) -{ - token = reader_next(rdr) - if (token != start_char) { - return MalError(message=("expected '" + start_char + "', got EOF")) - } - - elements = [] - token = reader_peek(rdr) - while (token != end_char) { - if (token == string(0)) { - return MalError(message=("expected '" + end_char + "', got EOF")) - } - e = read_form(rdr) - if (structof(e) == MalError) return e - grow, elements, [&e] - token = reader_peek(rdr) - } - token = reader_next(rdr) - return elements -} - -func read_list(rdr) -{ - seq = read_seq(rdr, "(", ")") - if (structof(seq) == MalError) return seq - return MalList(val=&seq) -} - -func read_vector(rdr) -{ - seq = read_seq(rdr, "[", "]") - if (structof(seq) == MalError) return seq - return MalVector(val=&seq) -} - -func read_hashmap(rdr) -{ - seq = read_seq(rdr, "{", "}") - if (structof(seq) == MalError) return seq - return array_to_hashmap(seq) -} - -func reader_macro(rdr, symbol_name) -{ - shortcut = reader_next(rdr) - form = read_form(rdr) - if (structof(form) == MalError) return form - seq = [&MalSymbol(val=symbol_name), &form] - return MalList(val=&seq) -} - -func reader_with_meta_macro(rdr) -{ - shortcut = reader_next(rdr) - meta = read_form(rdr) - if (structof(meta) == MalError) return meta - form = read_form(rdr) - if (structof(form) == MalError) return form - seq = [&MalSymbol(val="with-meta"), &form, &meta] - return MalList(val=&seq) -} - -func read_form(rdr) -{ - token = reader_peek(rdr) - if (token == "'") return reader_macro(rdr, "quote") - else if (token == "`") return reader_macro(rdr, "quasiquote") - else if (token == "~") return reader_macro(rdr, "unquote") - else if (token == "~@") return reader_macro(rdr, "splice-unquote") - else if (token == "@") return reader_macro(rdr, "deref") - else if (token == "^") return reader_with_meta_macro(rdr) - else if (token == "(") return read_list(rdr) - else if (token == ")") return MalError(message="unexpected ')'") - else if (token == "[") return read_vector(rdr) - else if (token == "]") return MalError(message="unexpected ']'") - else if (token == "{") return read_hashmap(rdr) - else if (token == "}") return MalError(message="unexpected '}'") - else return read_atom(rdr) -} - -func read_str(str) -{ - tokens = tokenize(str) - rdr = Reader(tokens=&tokens, pos=1) - return read_form(rdr) -} +#include "yeti_regex.i" +require, "types.i" + +TOKENIZER_REGEXP = regcomp("[[:space:],]*(~@|[][{}()'`~@]|\"([\\].|[^\\\"])*\"?|;[^\n]*|[^][[:space:]{}()'\"`~@,;]*)") + +func tokenize(str) +{ + match0 = "" + match1 = "" + pos = 1 + tokens = [] + while (1) { + m = regmatch(TOKENIZER_REGEXP, str, match0, match1, start=pos, indices=1) + if (m == 0) break + b = match1(1) + e = match1(2) - 1 + if (e < b) { + pos = match1(2) + 1 + continue + } + token = strpart(str, b:e) + pos = match1(2) + if (strpart(token, 1:1) == ";") continue + grow, tokens, [token] + } + return tokens +} + +struct Reader { + pointer tokens + int pos +} + +func reader_peek(rdr) +{ + if (rdr.pos > numberof(*rdr.tokens)) return string(0) + return (*rdr.tokens)(rdr.pos) +} + +func reader_next(rdr) +{ + token = reader_peek(rdr) + rdr.pos += 1 + return token +} + +NUMBER_REGEXP = regcomp("^-?[0-9]+$") +STR_REGEXP = regcomp("^\"([\\].|[^\\\"])*\"$") +STR_BAD_REGEXP = regcomp("^\".*$") + +func unescape(s) +{ + s = strpart(s, 2:-1) // remove surrounding quotes + s = streplaceall(s, "\\\\", "\x01") + s = streplaceall(s, "\\n", "\n") + s = streplaceall(s, "\\\"", "\"") + return streplaceall(s, "\x01", "\\") +} + +func read_atom(rdr) +{ + token = reader_next(rdr) + if (token == "nil") return MAL_NIL + else if (token == "true") return MAL_TRUE + else if (token == "false") return MAL_FALSE + else if (regmatch(NUMBER_REGEXP, token)) return MalNumber(val=tonum(token)) + else if (regmatch(STR_REGEXP, token)) return MalString(val=unescape(token)) + else if (regmatch(STR_BAD_REGEXP, token)) return MalError(message=("expected '\"', got EOF")) + else if (strpart(token, 1:1) == ":") return MalKeyword(val=strpart(token, 2:)) + else return MalSymbol(val=token) +} + +func read_seq(rdr, start_char, end_char) +{ + token = reader_next(rdr) + if (token != start_char) { + return MalError(message=("expected '" + start_char + "', got EOF")) + } + + elements = [] + token = reader_peek(rdr) + while (token != end_char) { + if (token == string(0)) { + return MalError(message=("expected '" + end_char + "', got EOF")) + } + e = read_form(rdr) + if (structof(e) == MalError) return e + grow, elements, [&e] + token = reader_peek(rdr) + } + token = reader_next(rdr) + return elements +} + +func read_list(rdr) +{ + seq = read_seq(rdr, "(", ")") + if (structof(seq) == MalError) return seq + return MalList(val=&seq) +} + +func read_vector(rdr) +{ + seq = read_seq(rdr, "[", "]") + if (structof(seq) == MalError) return seq + return MalVector(val=&seq) +} + +func read_hashmap(rdr) +{ + seq = read_seq(rdr, "{", "}") + if (structof(seq) == MalError) return seq + return array_to_hashmap(seq) +} + +func reader_macro(rdr, symbol_name) +{ + shortcut = reader_next(rdr) + form = read_form(rdr) + if (structof(form) == MalError) return form + seq = [&MalSymbol(val=symbol_name), &form] + return MalList(val=&seq) +} + +func reader_with_meta_macro(rdr) +{ + shortcut = reader_next(rdr) + meta = read_form(rdr) + if (structof(meta) == MalError) return meta + form = read_form(rdr) + if (structof(form) == MalError) return form + seq = [&MalSymbol(val="with-meta"), &form, &meta] + return MalList(val=&seq) +} + +func read_form(rdr) +{ + token = reader_peek(rdr) + if (token == "'") return reader_macro(rdr, "quote") + else if (token == "`") return reader_macro(rdr, "quasiquote") + else if (token == "~") return reader_macro(rdr, "unquote") + else if (token == "~@") return reader_macro(rdr, "splice-unquote") + else if (token == "@") return reader_macro(rdr, "deref") + else if (token == "^") return reader_with_meta_macro(rdr) + else if (token == "(") return read_list(rdr) + else if (token == ")") return MalError(message="unexpected ')'") + else if (token == "[") return read_vector(rdr) + else if (token == "]") return MalError(message="unexpected ']'") + else if (token == "{") return read_hashmap(rdr) + else if (token == "}") return MalError(message="unexpected '}'") + else return read_atom(rdr) +} + +func read_str(str) +{ + tokens = tokenize(str) + rdr = Reader(tokens=&tokens, pos=1) + return read_form(rdr) +} diff --git a/impls/yorick/run b/impls/yorick/run index c54589bb04..8ecc78de92 100755 --- a/impls/yorick/run +++ b/impls/yorick/run @@ -1,3 +1,3 @@ -#!/bin/bash -export YORICK_MAL_PATH="$(dirname $0)" -exec yorick -batch "$YORICK_MAL_PATH/${STEP:-stepA_mal}.i" "${@}" +#!/bin/bash +export YORICK_MAL_PATH="$(dirname $0)" +exec yorick -batch "$YORICK_MAL_PATH/${STEP:-stepA_mal}.i" "${@}" diff --git a/impls/yorick/step0_repl.i b/impls/yorick/step0_repl.i index 6a7fa25016..b6fd51ce6a 100644 --- a/impls/yorick/step0_repl.i +++ b/impls/yorick/step0_repl.i @@ -1,33 +1,33 @@ -func READ(str) -{ - return str -} - -func EVAL(exp, env) -{ - return exp -} - -func PRINT(exp) -{ - return exp -} - -func REP(str) -{ - return PRINT(EVAL(READ(str), "")) -} - -func main(void) -{ - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) write, format="%s\n", REP(line) - } - write, "" -} - -main; +func READ(str) +{ + return str +} + +func EVAL(exp, env) +{ + return exp +} + +func PRINT(exp) +{ + return exp +} + +func REP(str) +{ + return PRINT(EVAL(READ(str), "")) +} + +func main(void) +{ + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) write, format="%s\n", REP(line) + } + write, "" +} + +main; diff --git a/impls/yorick/step1_read_print.i b/impls/yorick/step1_read_print.i index 8a97cb8cf1..57b0f2d2ef 100644 --- a/impls/yorick/step1_read_print.i +++ b/impls/yorick/step1_read_print.i @@ -1,43 +1,43 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" - -func READ(str) -{ - return read_str(str) -} - -func EVAL(exp, env) -{ - if (structof(exp) == MalError) return exp - return exp -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func REP(str) -{ - return PRINT(EVAL(READ(str), "")) -} - -func main(void) -{ - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line) - if (structof(result) == MalError) write, format="Error: %s\n", result.message - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" + +func READ(str) +{ + return read_str(str) +} + +func EVAL(exp, env) +{ + if (structof(exp) == MalError) return exp + return exp +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func REP(str) +{ + return PRINT(EVAL(READ(str), "")) +} + +func main(void) +{ + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/step2_eval.i b/impls/yorick/step2_eval.i index 4b9cb6861f..3171a4566b 100644 --- a/impls/yorick/step2_eval.i +++ b/impls/yorick/step2_eval.i @@ -1,96 +1,96 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" -require, "core.i" - -func READ(str) -{ - return read_str(str) -} - -func eval_ast(ast, env) -{ - type = structof(ast) - if (type == MalSymbol) { - val = h_get(env, ast.val) - if (is_void(val)) return MalError(message=("'" + ast.val + "' not found")) - return val - } else if (type == MalList) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalList(val=&res) - } else if (type == MalVector) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalVector(val=&res) - } else if (type == MalHashmap) { - h = *(ast.val) - if (numberof(*h.keys) == 0) return ast - res = hash_new() - for (i = 1; i <= numberof(*h.keys); ++i) { - new_val = EVAL(*((*h.vals)(i)), env) - if (structof(new_val) == MalError) return new_val - hash_set, res, (*h.keys)(i), new_val - } - return MalHashmap(val=&res) - } else return ast -} - -func EVAL(ast, env) -{ - if (structof(ast) == MalError) return ast - if (structof(ast) != MalList) return eval_ast(ast, env) - if (numberof(*ast.val) == 0) return ast - el = eval_ast(ast, env) - if (structof(el) == MalError) return el - seq = *el.val - args = (numberof(seq) > 1) ? seq(2:) : [] - return call_core_fn(seq(1)->val, args) -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func REP(str, env) -{ - return PRINT(EVAL(READ(str), env)) -} - -func main(void) -{ - repl_env = h_new() - h_set, repl_env, "+", MalNativeFunction(val="+") - h_set, repl_env, "-", MalNativeFunction(val="-") - h_set, repl_env, "*", MalNativeFunction(val="*") - h_set, repl_env, "/", MalNativeFunction(val="/") - - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line, repl_env) - if (structof(result) == MalError) write, format="Error: %s\n", result.message - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + val = h_get(env, ast.val) + if (is_void(val)) return MalError(message=("'" + ast.val + "' not found")) + return val + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, (*h.keys)(i), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + if (numberof(*ast.val) == 0) return ast + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func main(void) +{ + repl_env = h_new() + h_set, repl_env, "+", MalNativeFunction(val="+") + h_set, repl_env, "-", MalNativeFunction(val="-") + h_set, repl_env, "*", MalNativeFunction(val="*") + h_set, repl_env, "/", MalNativeFunction(val="/") + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/step3_env.i b/impls/yorick/step3_env.i index cf56f84c37..5d2a5867b5 100644 --- a/impls/yorick/step3_env.i +++ b/impls/yorick/step3_env.i @@ -1,113 +1,113 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" -require, "core.i" -require, "env.i" - -func READ(str) -{ - return read_str(str) -} - -func eval_ast(ast, env) -{ - type = structof(ast) - if (type == MalSymbol) { - return env_get(env, ast.val) - } else if (type == MalList) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalList(val=&res) - } else if (type == MalVector) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalVector(val=&res) - } else if (type == MalHashmap) { - h = *(ast.val) - if (numberof(*h.keys) == 0) return ast - res = hash_new() - for (i = 1; i <= numberof(*h.keys); ++i) { - new_val = EVAL(*((*h.vals)(i)), env) - if (structof(new_val) == MalError) return new_val - hash_set, res, (*h.keys)(i), new_val - } - return MalHashmap(val=&res) - } else return ast -} - -func EVAL(ast, env) -{ - if (structof(ast) == MalError) return ast - if (structof(ast) != MalList) return eval_ast(ast, env) - lst = *ast.val - if (numberof(lst) == 0) return ast - a1 = lst(1)->val - if (a1 == "def!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "let*") { - let_env = env_new(&env) - args_lst = *(lst(2)->val) - for (i = 1; i <= numberof(args_lst); i += 2) { - var_name = args_lst(i)->val - var_value = EVAL(*args_lst(i + 1), let_env) - if (structof(var_value) == MalError) return var_value - env_set, let_env, var_name, var_value - } - return EVAL(*lst(3), let_env) - } else { - el = eval_ast(ast, env) - if (structof(el) == MalError) return el - seq = *el.val - args = (numberof(seq) > 1) ? seq(2:) : [] - return call_core_fn(seq(1)->val, args) - } -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func REP(str, env) -{ - return PRINT(EVAL(READ(str), env)) -} - -func main(void) -{ - repl_env = env_new(pointer(0)) - env_set, repl_env, "+", MalNativeFunction(val="+") - env_set, repl_env, "-", MalNativeFunction(val="-") - env_set, repl_env, "*", MalNativeFunction(val="*") - env_set, repl_env, "/", MalNativeFunction(val="/") - - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line, repl_env) - if (structof(result) == MalError) write, format="Error: %s\n", result.message - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, (*h.keys)(i), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + return EVAL(*lst(3), let_env) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func main(void) +{ + repl_env = env_new(pointer(0)) + env_set, repl_env, "+", MalNativeFunction(val="+") + env_set, repl_env, "-", MalNativeFunction(val="-") + env_set, repl_env, "*", MalNativeFunction(val="*") + env_set, repl_env, "/", MalNativeFunction(val="/") + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/step4_if_fn_do.i b/impls/yorick/step4_if_fn_do.i index 8c20c070d9..0720e012f6 100644 --- a/impls/yorick/step4_if_fn_do.i +++ b/impls/yorick/step4_if_fn_do.i @@ -1,153 +1,153 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" -require, "core.i" -require, "env.i" - -func READ(str) -{ - return read_str(str) -} - -func eval_ast(ast, env) -{ - type = structof(ast) - if (type == MalSymbol) { - return env_get(env, ast.val) - } else if (type == MalList) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalList(val=&res) - } else if (type == MalVector) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalVector(val=&res) - } else if (type == MalHashmap) { - h = *(ast.val) - if (numberof(*h.keys) == 0) return ast - res = hash_new() - for (i = 1; i <= numberof(*h.keys); ++i) { - new_val = EVAL(*((*h.vals)(i)), env) - if (structof(new_val) == MalError) return new_val - hash_set, res, (*h.keys)(i), new_val - } - return MalHashmap(val=&res) - } else return ast -} - -func EVAL(ast, env) -{ - if (structof(ast) == MalError) return ast - if (structof(ast) != MalList) return eval_ast(ast, env) - lst = *ast.val - if (numberof(lst) == 0) return ast - a1 = lst(1)->val - if (a1 == "def!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "let*") { - let_env = env_new(&env) - args_lst = *(lst(2)->val) - for (i = 1; i <= numberof(args_lst); i += 2) { - var_name = args_lst(i)->val - var_value = EVAL(*args_lst(i + 1), let_env) - if (structof(var_value) == MalError) return var_value - env_set, let_env, var_name, var_value - } - return EVAL(*lst(3), let_env) - } else if (a1 == "do") { - ret = nil - for (i = 2; i <= numberof(lst); ++i) { - ret = EVAL(*lst(i), env) - if (structof(ret) == MalError) return ret - } - return ret - } else if (a1 == "if") { - cond_val = EVAL(*lst(2), env) - if (structof(cond_val) == MalError) return cond_val - if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { - if (numberof(lst) > 3) { - return EVAL(*lst(4), env) - } else { - return MAL_NIL - } - } else { - return EVAL(*lst(3), env) - } - } else if (a1 == "fn*") { - return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) - } else { - el = eval_ast(ast, env) - if (structof(el) == MalError) return el - seq = *el.val - if (structof(*seq(1)) == MalNativeFunction) { - args = (numberof(seq) > 1) ? seq(2:) : [] - return call_core_fn(seq(1)->val, args) - } else if (structof(*seq(1)) == MalFunction) { - fn = *seq(1) - exprs = numberof(seq) > 1 ? seq(2:) : [] - fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) - return EVAL(*fn.ast, fn_env) - } else { - return MalError(message="Unknown function type") - } - } -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func RE(str, env) -{ - return EVAL(READ(str), env) -} - -func REP(str, env) -{ - return PRINT(EVAL(READ(str), env)) -} - -func main(void) -{ - repl_env = env_new(pointer(0)) - - // core.i: defined using Yorick - core_symbols = h_keys(core_ns) - for (i = 1; i <= numberof(core_symbols); ++i) { - env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) - } - - // core.mal: defined using the language itself - RE, "(def! not (fn* (a) (if a false true)))", repl_env - - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line, repl_env) - if (structof(result) == MalError) write, format="Error: %s\n", result.message - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, (*h.keys)(i), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + return EVAL(*lst(3), let_env) + } else if (a1 == "do") { + ret = nil + for (i = 2; i <= numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + return ret + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + return EVAL(*lst(4), env) + } else { + return MAL_NIL + } + } else { + return EVAL(*lst(3), env) + } + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + return EVAL(*fn.ast, fn_env) + } else { + return MalError(message="Unknown function type") + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func main(void) +{ + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/step5_tco.i b/impls/yorick/step5_tco.i index 159d95640c..50e0655faa 100644 --- a/impls/yorick/step5_tco.i +++ b/impls/yorick/step5_tco.i @@ -1,160 +1,160 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" -require, "core.i" -require, "env.i" - -func READ(str) -{ - return read_str(str) -} - -func eval_ast(ast, env) -{ - type = structof(ast) - if (type == MalSymbol) { - return env_get(env, ast.val) - } else if (type == MalList) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalList(val=&res) - } else if (type == MalVector) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalVector(val=&res) - } else if (type == MalHashmap) { - h = *(ast.val) - if (numberof(*h.keys) == 0) return ast - res = hash_new() - for (i = 1; i <= numberof(*h.keys); ++i) { - new_val = EVAL(*((*h.vals)(i)), env) - if (structof(new_val) == MalError) return new_val - hash_set, res, (*h.keys)(i), new_val - } - return MalHashmap(val=&res) - } else return ast -} - -func EVAL(ast, env) -{ - while (1) { - if (structof(ast) == MalError) return ast - if (structof(ast) != MalList) return eval_ast(ast, env) - lst = *ast.val - if (numberof(lst) == 0) return ast - a1 = lst(1)->val - if (a1 == "def!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "let*") { - let_env = env_new(&env) - args_lst = *(lst(2)->val) - for (i = 1; i <= numberof(args_lst); i += 2) { - var_name = args_lst(i)->val - var_value = EVAL(*args_lst(i + 1), let_env) - if (structof(var_value) == MalError) return var_value - env_set, let_env, var_name, var_value - } - ast = *lst(3) - env = let_env - // TCO - } else if (a1 == "do") { - for (i = 2; i < numberof(lst); ++i) { - ret = EVAL(*lst(i), env) - if (structof(ret) == MalError) return ret - } - ast = *lst(numberof(lst)) - // TCO - } else if (a1 == "if") { - cond_val = EVAL(*lst(2), env) - if (structof(cond_val) == MalError) return cond_val - if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { - if (numberof(lst) > 3) { - ast = *lst(4) - } else { - return MAL_NIL - } - } else { - ast = *lst(3) - } - // TCO - } else if (a1 == "fn*") { - return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) - } else { - el = eval_ast(ast, env) - if (structof(el) == MalError) return el - seq = *el.val - if (structof(*seq(1)) == MalNativeFunction) { - args = (numberof(seq) > 1) ? seq(2:) : [] - return call_core_fn(seq(1)->val, args) - } else if (structof(*seq(1)) == MalFunction) { - fn = *seq(1) - exprs = numberof(seq) > 1 ? seq(2:) : [] - fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) - ast = *fn.ast - env = fn_env - // TCO - } else { - return MalError(message="Unknown function type") - } - } - } -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func RE(str, env) -{ - return EVAL(READ(str), env) -} - -func REP(str, env) -{ - return PRINT(EVAL(READ(str), env)) -} - -func main(void) -{ - repl_env = env_new(pointer(0)) - - // core.i: defined using Yorick - core_symbols = h_keys(core_ns) - for (i = 1; i <= numberof(core_symbols); ++i) { - env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) - } - - // core.mal: defined using the language itself - RE, "(def! not (fn* (a) (if a false true)))", repl_env - - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line, repl_env) - if (structof(result) == MalError) write, format="Error: %s\n", result.message - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, (*h.keys)(i), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func main(void) +{ + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/step6_file.i b/impls/yorick/step6_file.i index 3ae3a8dabd..9d25088d1f 100644 --- a/impls/yorick/step6_file.i +++ b/impls/yorick/step6_file.i @@ -1,188 +1,188 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" -require, "core.i" -require, "env.i" - -func READ(str) -{ - return read_str(str) -} - -func eval_ast(ast, env) -{ - type = structof(ast) - if (type == MalSymbol) { - return env_get(env, ast.val) - } else if (type == MalList) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalList(val=&res) - } else if (type == MalVector) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalVector(val=&res) - } else if (type == MalHashmap) { - h = *(ast.val) - if (numberof(*h.keys) == 0) return ast - res = hash_new() - for (i = 1; i <= numberof(*h.keys); ++i) { - new_val = EVAL(*((*h.vals)(i)), env) - if (structof(new_val) == MalError) return new_val - hash_set, res, (*h.keys)(i), new_val - } - return MalHashmap(val=&res) - } else return ast -} - -func EVAL(ast, env) -{ - while (1) { - if (structof(ast) == MalError) return ast - if (structof(ast) != MalList) return eval_ast(ast, env) - lst = *ast.val - if (numberof(lst) == 0) return ast - a1 = lst(1)->val - if (a1 == "def!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "let*") { - let_env = env_new(&env) - args_lst = *(lst(2)->val) - for (i = 1; i <= numberof(args_lst); i += 2) { - var_name = args_lst(i)->val - var_value = EVAL(*args_lst(i + 1), let_env) - if (structof(var_value) == MalError) return var_value - env_set, let_env, var_name, var_value - } - ast = *lst(3) - env = let_env - // TCO - } else if (a1 == "do") { - for (i = 2; i < numberof(lst); ++i) { - ret = EVAL(*lst(i), env) - if (structof(ret) == MalError) return ret - } - ast = *lst(numberof(lst)) - // TCO - } else if (a1 == "if") { - cond_val = EVAL(*lst(2), env) - if (structof(cond_val) == MalError) return cond_val - if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { - if (numberof(lst) > 3) { - ast = *lst(4) - } else { - return MAL_NIL - } - } else { - ast = *lst(3) - } - // TCO - } else if (a1 == "fn*") { - return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) - } else { - el = eval_ast(ast, env) - if (structof(el) == MalError) return el - seq = *el.val - if (structof(*seq(1)) == MalNativeFunction) { - args = (numberof(seq) > 1) ? seq(2:) : [] - return call_core_fn(seq(1)->val, args) - } else if (structof(*seq(1)) == MalFunction) { - fn = *seq(1) - exprs = numberof(seq) > 1 ? seq(2:) : [] - fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) - ast = *fn.ast - env = fn_env - // TCO - } else { - return MalError(message="Unknown function type") - } - } - } -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func RE(str, env) -{ - return EVAL(READ(str), env) -} - -func REP(str, env) -{ - return PRINT(EVAL(READ(str), env)) -} - -func get_command_line(void) -// Force quiet mode (-q) to prevent Yorick from printing its banner -{ - argv = get_argv() - return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] -} - -func prepare_argv_list(args) -{ - if (numberof(args) <= 1) return MalList(val=&[]) - str_lst = array(pointer, numberof(args) - 1) - for (i = 2; i <= numberof(args); ++i) { - str_lst(i - 1) = &MalString(val=args(i)) - } - return MalList(val=&str_lst) -} - -repl_env = nil - -func main(void) -{ - extern repl_env - repl_env = env_new(pointer(0)) - - // core.i: defined using Yorick - core_symbols = h_keys(core_ns) - for (i = 1; i <= numberof(core_symbols); ++i) { - env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) - } - command_line_args = process_argv() - env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) - - // core.mal: defined using the language itself - RE, "(def! not (fn* (a) (if a false true)))", repl_env - RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env - - if (numberof(command_line_args) > 0) { - RE, "(load-file \"" + command_line_args(1) + "\")", repl_env - return 0 - } - - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line, repl_env) - if (structof(result) == MalError) write, format="Error: %s\n", result.message - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, (*h.keys)(i), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil + +func main(void) +{ + extern repl_env + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/step7_quote.i b/impls/yorick/step7_quote.i index 273aa0efe4..d9a3b173c4 100644 --- a/impls/yorick/step7_quote.i +++ b/impls/yorick/step7_quote.i @@ -1,232 +1,232 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" -require, "core.i" -require, "env.i" - -func READ(str) -{ - return read_str(str) -} - -func starts_with(seq, sym) -{ - return numberof(seq) == 2 && structof(*seq(1)) == MalSymbol && seq(1)->val == sym -} - -func quasiquote_loop(seq) -{ - acc = MalList(val=&[]) - for (i=numberof(seq); 0val - if (a1 == "def!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "let*") { - let_env = env_new(&env) - args_lst = *(lst(2)->val) - for (i = 1; i <= numberof(args_lst); i += 2) { - var_name = args_lst(i)->val - var_value = EVAL(*args_lst(i + 1), let_env) - if (structof(var_value) == MalError) return var_value - env_set, let_env, var_name, var_value - } - ast = *lst(3) - env = let_env - // TCO - } else if (a1 == "quote") { - return *lst(2) - } else if (a1 == "quasiquoteexpand") { - return quasiquote(*lst(2)) - } else if (a1 == "quasiquote") { - ast = quasiquote(*lst(2)) // TCO - } else if (a1 == "do") { - for (i = 2; i < numberof(lst); ++i) { - ret = EVAL(*lst(i), env) - if (structof(ret) == MalError) return ret - } - ast = *lst(numberof(lst)) - // TCO - } else if (a1 == "if") { - cond_val = EVAL(*lst(2), env) - if (structof(cond_val) == MalError) return cond_val - if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { - if (numberof(lst) > 3) { - ast = *lst(4) - } else { - return MAL_NIL - } - } else { - ast = *lst(3) - } - // TCO - } else if (a1 == "fn*") { - return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) - } else { - el = eval_ast(ast, env) - if (structof(el) == MalError) return el - seq = *el.val - if (structof(*seq(1)) == MalNativeFunction) { - args = (numberof(seq) > 1) ? seq(2:) : [] - return call_core_fn(seq(1)->val, args) - } else if (structof(*seq(1)) == MalFunction) { - fn = *seq(1) - exprs = numberof(seq) > 1 ? seq(2:) : [] - fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) - ast = *fn.ast - env = fn_env - // TCO - } else { - return MalError(message="Unknown function type") - } - } - } -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func RE(str, env) -{ - return EVAL(READ(str), env) -} - -func REP(str, env) -{ - return PRINT(EVAL(READ(str), env)) -} - -func get_command_line(void) -// Force quiet mode (-q) to prevent Yorick from printing its banner -{ - argv = get_argv() - return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] -} - -func prepare_argv_list(args) -{ - if (numberof(args) <= 1) return MalList(val=&[]) - str_lst = array(pointer, numberof(args) - 1) - for (i = 2; i <= numberof(args); ++i) { - str_lst(i - 1) = &MalString(val=args(i)) - } - return MalList(val=&str_lst) -} - -repl_env = nil - -func main(void) -{ - extern repl_env - repl_env = env_new(pointer(0)) - - // core.i: defined using Yorick - core_symbols = h_keys(core_ns) - for (i = 1; i <= numberof(core_symbols); ++i) { - env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) - } - command_line_args = process_argv() - env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) - - // core.mal: defined using the language itself - RE, "(def! not (fn* (a) (if a false true)))", repl_env - RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env - - if (numberof(command_line_args) > 0) { - RE, "(load-file \"" + command_line_args(1) + "\")", repl_env - return 0 - } - - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line, repl_env) - if (structof(result) == MalError) write, format="Error: %s\n", result.message - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func starts_with(seq, sym) +{ + return numberof(seq) == 2 && structof(*seq(1)) == MalSymbol && seq(1)->val == sym +} + +func quasiquote_loop(seq) +{ + acc = MalList(val=&[]) + for (i=numberof(seq); 0val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "quote") { + return *lst(2) + } else if (a1 == "quasiquoteexpand") { + return quasiquote(*lst(2)) + } else if (a1 == "quasiquote") { + ast = quasiquote(*lst(2)) // TCO + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3)) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil + +func main(void) +{ + extern repl_env + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/step8_macros.i b/impls/yorick/step8_macros.i index a52a0d3b6b..d7e77e7ccd 100644 --- a/impls/yorick/step8_macros.i +++ b/impls/yorick/step8_macros.i @@ -1,267 +1,267 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" -require, "core.i" -require, "env.i" - -func READ(str) -{ - return read_str(str) -} - -func starts_with(seq, sym) -{ - return numberof(seq) == 2 && structof(*seq(1)) == MalSymbol && seq(1)->val == sym -} - -func quasiquote_loop(seq) -{ - acc = MalList(val=&[]) - for (i=numberof(seq); 0val - macro_obj = env_get(env, macro_name) - macro_args = *rest(ast).val - fn_env = env_new(macro_obj.env, binds=*macro_obj.binds, exprs=macro_args) - ast = EVAL(*macro_obj.ast, fn_env) - } - return ast -} - -func eval_ast(ast, env) -{ - type = structof(ast) - if (type == MalSymbol) { - return env_get(env, ast.val) - } else if (type == MalList) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalList(val=&res) - } else if (type == MalVector) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalVector(val=&res) - } else if (type == MalHashmap) { - h = *(ast.val) - if (numberof(*h.keys) == 0) return ast - res = hash_new() - for (i = 1; i <= numberof(*h.keys); ++i) { - new_val = EVAL(*((*h.vals)(i)), env) - if (structof(new_val) == MalError) return new_val - hash_set, res, (*h.keys)(i), new_val - } - return MalHashmap(val=&res) - } else return ast -} - -func EVAL(ast, env) -{ - while (1) { - if (structof(ast) == MalError) return ast - if (structof(ast) != MalList) return eval_ast(ast, env) - ast = macroexpand(ast, env) - if (structof(ast) != MalList) return eval_ast(ast, env) - lst = *ast.val - if (numberof(lst) == 0) return ast - a1 = lst(1)->val - if (a1 == "def!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "let*") { - let_env = env_new(&env) - args_lst = *(lst(2)->val) - for (i = 1; i <= numberof(args_lst); i += 2) { - var_name = args_lst(i)->val - var_value = EVAL(*args_lst(i + 1), let_env) - if (structof(var_value) == MalError) return var_value - env_set, let_env, var_name, var_value - } - ast = *lst(3) - env = let_env - // TCO - } else if (a1 == "quote") { - return *lst(2) - } else if (a1 == "quasiquoteexpand") { - return quasiquote(*lst(2)) - } else if (a1 == "quasiquote") { - ast = quasiquote(*lst(2)) // TCO - } else if (a1 == "defmacro!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - new_value.macro = 1 - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "macroexpand") { - return macroexpand(*lst(2), env) - } else if (a1 == "do") { - for (i = 2; i < numberof(lst); ++i) { - ret = EVAL(*lst(i), env) - if (structof(ret) == MalError) return ret - } - ast = *lst(numberof(lst)) - // TCO - } else if (a1 == "if") { - cond_val = EVAL(*lst(2), env) - if (structof(cond_val) == MalError) return cond_val - if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { - if (numberof(lst) > 3) { - ast = *lst(4) - } else { - return MAL_NIL - } - } else { - ast = *lst(3) - } - // TCO - } else if (a1 == "fn*") { - return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3), macro=0) - } else { - el = eval_ast(ast, env) - if (structof(el) == MalError) return el - seq = *el.val - if (structof(*seq(1)) == MalNativeFunction) { - args = (numberof(seq) > 1) ? seq(2:) : [] - return call_core_fn(seq(1)->val, args) - } else if (structof(*seq(1)) == MalFunction) { - fn = *seq(1) - exprs = numberof(seq) > 1 ? seq(2:) : [] - fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) - ast = *fn.ast - env = fn_env - // TCO - } else { - return MalError(message="Unknown function type") - } - } - } -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func RE(str, env) -{ - return EVAL(READ(str), env) -} - -func REP(str, env) -{ - return PRINT(EVAL(READ(str), env)) -} - -func get_command_line(void) -// Force quiet mode (-q) to prevent Yorick from printing its banner -{ - argv = get_argv() - return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] -} - -func prepare_argv_list(args) -{ - if (numberof(args) <= 1) return MalList(val=&[]) - str_lst = array(pointer, numberof(args) - 1) - for (i = 2; i <= numberof(args); ++i) { - str_lst(i - 1) = &MalString(val=args(i)) - } - return MalList(val=&str_lst) -} - -repl_env = nil - -func main(void) -{ - extern repl_env - repl_env = env_new(pointer(0)) - - // core.i: defined using Yorick - core_symbols = h_keys(core_ns) - for (i = 1; i <= numberof(core_symbols); ++i) { - env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) - } - command_line_args = process_argv() - env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) - - // core.mal: defined using the language itself - RE, "(def! not (fn* (a) (if a false true)))", repl_env - RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env - RE, "(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)))))))", repl_env - - if (numberof(command_line_args) > 0) { - RE, "(load-file \"" + command_line_args(1) + "\")", repl_env - return 0 - } - - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line, repl_env) - if (structof(result) == MalError) write, format="Error: %s\n", result.message - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func starts_with(seq, sym) +{ + return numberof(seq) == 2 && structof(*seq(1)) == MalSymbol && seq(1)->val == sym +} + +func quasiquote_loop(seq) +{ + acc = MalList(val=&[]) + for (i=numberof(seq); 0val + macro_obj = env_get(env, macro_name) + macro_args = *rest(ast).val + fn_env = env_new(macro_obj.env, binds=*macro_obj.binds, exprs=macro_args) + ast = EVAL(*macro_obj.ast, fn_env) + } + return ast +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, (*h.keys)(i), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "quote") { + return *lst(2) + } else if (a1 == "quasiquoteexpand") { + return quasiquote(*lst(2)) + } else if (a1 == "quasiquote") { + ast = quasiquote(*lst(2)) // TCO + } else if (a1 == "defmacro!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + new_value.macro = 1 + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "macroexpand") { + return macroexpand(*lst(2), env) + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3), macro=0) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil + +func main(void) +{ + extern repl_env + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env + RE, "(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)))))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) write, format="Error: %s\n", result.message + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/step9_try.i b/impls/yorick/step9_try.i index 6d46571ddc..aee719dbe8 100644 --- a/impls/yorick/step9_try.i +++ b/impls/yorick/step9_try.i @@ -1,288 +1,288 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" -require, "core.i" -require, "env.i" - -func READ(str) -{ - return read_str(str) -} - -func starts_with(seq, sym) -{ - return numberof(seq) == 2 && structof(*seq(1)) == MalSymbol && seq(1)->val == sym -} - -func quasiquote_loop(seq) -{ - acc = MalList(val=&[]) - for (i=numberof(seq); 0val - macro_obj = env_get(env, macro_name) - macro_args = *rest(ast).val - fn_env = env_new(macro_obj.env, binds=*macro_obj.binds, exprs=macro_args) - ast = EVAL(*macro_obj.ast, fn_env) - } - return ast -} - -func eval_ast(ast, env) -{ - type = structof(ast) - if (type == MalSymbol) { - return env_get(env, ast.val) - } else if (type == MalList) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalList(val=&res) - } else if (type == MalVector) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalVector(val=&res) - } else if (type == MalHashmap) { - h = *(ast.val) - if (numberof(*h.keys) == 0) return ast - res = hash_new() - for (i = 1; i <= numberof(*h.keys); ++i) { - new_val = EVAL(*((*h.vals)(i)), env) - if (structof(new_val) == MalError) return new_val - hash_set, res, (*h.keys)(i), new_val - } - return MalHashmap(val=&res) - } else return ast -} - -func EVAL(ast, env) -{ - while (1) { - if (structof(ast) == MalError) return ast - if (structof(ast) != MalList) return eval_ast(ast, env) - ast = macroexpand(ast, env) - if (structof(ast) != MalList) return eval_ast(ast, env) - lst = *ast.val - if (numberof(lst) == 0) return ast - a1 = lst(1)->val - if (a1 == "def!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "let*") { - let_env = env_new(&env) - args_lst = *(lst(2)->val) - for (i = 1; i <= numberof(args_lst); i += 2) { - var_name = args_lst(i)->val - var_value = EVAL(*args_lst(i + 1), let_env) - if (structof(var_value) == MalError) return var_value - env_set, let_env, var_name, var_value - } - ast = *lst(3) - env = let_env - // TCO - } else if (a1 == "quote") { - return *lst(2) - } else if (a1 == "quasiquoteexpand") { - return quasiquote(*lst(2)) - } else if (a1 == "quasiquote") { - ast = quasiquote(*lst(2)) // TCO - } else if (a1 == "defmacro!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - new_value.macro = 1 - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "macroexpand") { - return macroexpand(*lst(2), env) - } else if (a1 == "try*") { - ret = EVAL(*lst(2), env) - if (structof(ret) == MalError && numberof(lst) > 2) { - exc = *ret.obj - if (is_void(exc)) { - exc = MalString(val=ret.message) - } - catch_lst = *(lst(3)->val) - catch_env = env_new(&env) - env_set, catch_env, catch_lst(2)->val, exc - return EVAL(*catch_lst(3), catch_env) - } else { - return ret - } - } else if (a1 == "do") { - for (i = 2; i < numberof(lst); ++i) { - ret = EVAL(*lst(i), env) - if (structof(ret) == MalError) return ret - } - ast = *lst(numberof(lst)) - // TCO - } else if (a1 == "if") { - cond_val = EVAL(*lst(2), env) - if (structof(cond_val) == MalError) return cond_val - if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { - if (numberof(lst) > 3) { - ast = *lst(4) - } else { - return MAL_NIL - } - } else { - ast = *lst(3) - } - // TCO - } else if (a1 == "fn*") { - return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3), macro=0) - } else { - el = eval_ast(ast, env) - if (structof(el) == MalError) return el - seq = *el.val - if (structof(*seq(1)) == MalNativeFunction) { - args = (numberof(seq) > 1) ? seq(2:) : [] - return call_core_fn(seq(1)->val, args) - } else if (structof(*seq(1)) == MalFunction) { - fn = *seq(1) - exprs = numberof(seq) > 1 ? seq(2:) : [] - fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) - ast = *fn.ast - env = fn_env - // TCO - } else { - return MalError(message="Unknown function type") - } - } - } -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func RE(str, env) -{ - return EVAL(READ(str), env) -} - -func REP(str, env) -{ - return PRINT(EVAL(READ(str), env)) -} - -func get_command_line(void) -// Force quiet mode (-q) to prevent Yorick from printing its banner -{ - argv = get_argv() - return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] -} - -func prepare_argv_list(args) -{ - if (numberof(args) <= 1) return MalList(val=&[]) - str_lst = array(pointer, numberof(args) - 1) - for (i = 2; i <= numberof(args); ++i) { - str_lst(i - 1) = &MalString(val=args(i)) - } - return MalList(val=&str_lst) -} - -repl_env = nil - -func main(void) -{ - extern repl_env - repl_env = env_new(pointer(0)) - - // core.i: defined using Yorick - core_symbols = h_keys(core_ns) - for (i = 1; i <= numberof(core_symbols); ++i) { - env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) - } - command_line_args = process_argv() - env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) - - // core.mal: defined using the language itself - RE, "(def! not (fn* (a) (if a false true)))", repl_env - RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env - RE, "(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)))))))", repl_env - - if (numberof(command_line_args) > 0) { - RE, "(load-file \"" + command_line_args(1) + "\")", repl_env - return 0 - } - - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line, repl_env) - if (structof(result) == MalError) { - exc = *result.obj - if (is_void(exc)) { - write, format="Error: %s\n", result.message - } else { - write, format="Error: %s\n", pr_str(exc, 1) - } - } - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func starts_with(seq, sym) +{ + return numberof(seq) == 2 && structof(*seq(1)) == MalSymbol && seq(1)->val == sym +} + +func quasiquote_loop(seq) +{ + acc = MalList(val=&[]) + for (i=numberof(seq); 0val + macro_obj = env_get(env, macro_name) + macro_args = *rest(ast).val + fn_env = env_new(macro_obj.env, binds=*macro_obj.binds, exprs=macro_args) + ast = EVAL(*macro_obj.ast, fn_env) + } + return ast +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, (*h.keys)(i), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "quote") { + return *lst(2) + } else if (a1 == "quasiquoteexpand") { + return quasiquote(*lst(2)) + } else if (a1 == "quasiquote") { + ast = quasiquote(*lst(2)) // TCO + } else if (a1 == "defmacro!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + new_value.macro = 1 + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "macroexpand") { + return macroexpand(*lst(2), env) + } else if (a1 == "try*") { + ret = EVAL(*lst(2), env) + if (structof(ret) == MalError && numberof(lst) > 2) { + exc = *ret.obj + if (is_void(exc)) { + exc = MalString(val=ret.message) + } + catch_lst = *(lst(3)->val) + catch_env = env_new(&env) + env_set, catch_env, catch_lst(2)->val, exc + return EVAL(*catch_lst(3), catch_env) + } else { + return ret + } + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3), macro=0) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil + +func main(void) +{ + extern repl_env + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env + RE, "(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)))))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) { + exc = *result.obj + if (is_void(exc)) { + write, format="Error: %s\n", result.message + } else { + write, format="Error: %s\n", pr_str(exc, 1) + } + } + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/stepA_mal.i b/impls/yorick/stepA_mal.i index fe90a24892..9c7a044055 100644 --- a/impls/yorick/stepA_mal.i +++ b/impls/yorick/stepA_mal.i @@ -1,290 +1,290 @@ -set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() -require, "reader.i" -require, "printer.i" -require, "core.i" -require, "env.i" - -func READ(str) -{ - return read_str(str) -} - -func starts_with(seq, sym) -{ - return numberof(seq) == 2 && structof(*seq(1)) == MalSymbol && seq(1)->val == sym -} - -func quasiquote_loop(seq) -{ - acc = MalList(val=&[]) - for (i=numberof(seq); 0val - macro_obj = env_get(env, macro_name) - macro_args = *rest(ast).val - fn_env = env_new(macro_obj.env, binds=*macro_obj.binds, exprs=macro_args) - ast = EVAL(*macro_obj.ast, fn_env) - } - return ast -} - -func eval_ast(ast, env) -{ - type = structof(ast) - if (type == MalSymbol) { - return env_get(env, ast.val) - } else if (type == MalList) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalList(val=&res) - } else if (type == MalVector) { - seq = *(ast.val) - if (numberof(seq) == 0) return ast - res = array(pointer, numberof(seq)) - for (i = 1; i <= numberof(seq); ++i) { - e = EVAL(*seq(i), env) - if (structof(e) == MalError) return e - res(i) = &e - } - return MalVector(val=&res) - } else if (type == MalHashmap) { - h = *(ast.val) - if (numberof(*h.keys) == 0) return ast - res = hash_new() - for (i = 1; i <= numberof(*h.keys); ++i) { - new_val = EVAL(*((*h.vals)(i)), env) - if (structof(new_val) == MalError) return new_val - hash_set, res, (*h.keys)(i), new_val - } - return MalHashmap(val=&res) - } else return ast -} - -func EVAL(ast, env) -{ - while (1) { - if (structof(ast) == MalError) return ast - if (structof(ast) != MalList) return eval_ast(ast, env) - ast = macroexpand(ast, env) - if (structof(ast) != MalList) return eval_ast(ast, env) - lst = *ast.val - if (numberof(lst) == 0) return ast - a1 = lst(1)->val - if (a1 == "def!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "let*") { - let_env = env_new(&env) - args_lst = *(lst(2)->val) - for (i = 1; i <= numberof(args_lst); i += 2) { - var_name = args_lst(i)->val - var_value = EVAL(*args_lst(i + 1), let_env) - if (structof(var_value) == MalError) return var_value - env_set, let_env, var_name, var_value - } - ast = *lst(3) - env = let_env - // TCO - } else if (a1 == "quote") { - return *lst(2) - } else if (a1 == "quasiquoteexpand") { - return quasiquote(*lst(2)) - } else if (a1 == "quasiquote") { - ast = quasiquote(*lst(2)) // TCO - } else if (a1 == "defmacro!") { - new_value = EVAL(*lst(3), env) - if (structof(new_value) == MalError) return new_value - new_value.macro = 1 - return env_set(env, lst(2)->val, new_value) - } else if (a1 == "macroexpand") { - return macroexpand(*lst(2), env) - } else if (a1 == "try*") { - ret = EVAL(*lst(2), env) - if (structof(ret) == MalError && numberof(lst) > 2) { - exc = *ret.obj - if (is_void(exc)) { - exc = MalString(val=ret.message) - } - catch_lst = *(lst(3)->val) - catch_env = env_new(&env) - env_set, catch_env, catch_lst(2)->val, exc - return EVAL(*catch_lst(3), catch_env) - } else { - return ret - } - } else if (a1 == "do") { - for (i = 2; i < numberof(lst); ++i) { - ret = EVAL(*lst(i), env) - if (structof(ret) == MalError) return ret - } - ast = *lst(numberof(lst)) - // TCO - } else if (a1 == "if") { - cond_val = EVAL(*lst(2), env) - if (structof(cond_val) == MalError) return cond_val - if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { - if (numberof(lst) > 3) { - ast = *lst(4) - } else { - return MAL_NIL - } - } else { - ast = *lst(3) - } - // TCO - } else if (a1 == "fn*") { - return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3), macro=0) - } else { - el = eval_ast(ast, env) - if (structof(el) == MalError) return el - seq = *el.val - if (structof(*seq(1)) == MalNativeFunction) { - args = (numberof(seq) > 1) ? seq(2:) : [] - return call_core_fn(seq(1)->val, args) - } else if (structof(*seq(1)) == MalFunction) { - fn = *seq(1) - exprs = numberof(seq) > 1 ? seq(2:) : [] - fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) - ast = *fn.ast - env = fn_env - // TCO - } else { - return MalError(message="Unknown function type") - } - } - } -} - -func PRINT(exp) -{ - if (structof(exp) == MalError) return exp - return pr_str(exp, 1) -} - -func RE(str, env) -{ - return EVAL(READ(str), env) -} - -func REP(str, env) -{ - return PRINT(EVAL(READ(str), env)) -} - -func get_command_line(void) -// Force quiet mode (-q) to prevent Yorick from printing its banner -{ - argv = get_argv() - return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] -} - -func prepare_argv_list(args) -{ - if (numberof(args) <= 1) return MalList(val=&[]) - str_lst = array(pointer, numberof(args) - 1) - for (i = 2; i <= numberof(args); ++i) { - str_lst(i - 1) = &MalString(val=args(i)) - } - return MalList(val=&str_lst) -} - -repl_env = nil - -func main(void) -{ - extern repl_env - repl_env = env_new(pointer(0)) - - // core.i: defined using Yorick - core_symbols = h_keys(core_ns) - for (i = 1; i <= numberof(core_symbols); ++i) { - env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) - } - command_line_args = process_argv() - env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) - - // core.mal: defined using the language itself - RE, "(def! *host-language* \"yorick\")", repl_env - RE, "(def! not (fn* (a) (if a false true)))", repl_env - RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env - RE, "(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)))))))", repl_env - - if (numberof(command_line_args) > 0) { - RE, "(load-file \"" + command_line_args(1) + "\")", repl_env - return 0 - } - - RE, "(println (str \"Mal [\" *host-language* \"]\"))", repl_env - stdin_file = open("/dev/stdin", "r") - while (1) { - write, format="%s", "user> " - line = rdline(stdin_file, prompt="") - if (!line) break - if (strlen(line) > 0) { - result = REP(line, repl_env) - if (structof(result) == MalError) { - exc = *result.obj - if (is_void(exc)) { - write, format="Error: %s\n", result.message - } else { - write, format="Error: %s\n", pr_str(exc, 1) - } - } - else write, format="%s\n", result - } - } - write, "" -} - -main; +set_path, get_env("YORICK_MAL_PATH") + ":" + get_path() +require, "reader.i" +require, "printer.i" +require, "core.i" +require, "env.i" + +func READ(str) +{ + return read_str(str) +} + +func starts_with(seq, sym) +{ + return numberof(seq) == 2 && structof(*seq(1)) == MalSymbol && seq(1)->val == sym +} + +func quasiquote_loop(seq) +{ + acc = MalList(val=&[]) + for (i=numberof(seq); 0val + macro_obj = env_get(env, macro_name) + macro_args = *rest(ast).val + fn_env = env_new(macro_obj.env, binds=*macro_obj.binds, exprs=macro_args) + ast = EVAL(*macro_obj.ast, fn_env) + } + return ast +} + +func eval_ast(ast, env) +{ + type = structof(ast) + if (type == MalSymbol) { + return env_get(env, ast.val) + } else if (type == MalList) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalList(val=&res) + } else if (type == MalVector) { + seq = *(ast.val) + if (numberof(seq) == 0) return ast + res = array(pointer, numberof(seq)) + for (i = 1; i <= numberof(seq); ++i) { + e = EVAL(*seq(i), env) + if (structof(e) == MalError) return e + res(i) = &e + } + return MalVector(val=&res) + } else if (type == MalHashmap) { + h = *(ast.val) + if (numberof(*h.keys) == 0) return ast + res = hash_new() + for (i = 1; i <= numberof(*h.keys); ++i) { + new_val = EVAL(*((*h.vals)(i)), env) + if (structof(new_val) == MalError) return new_val + hash_set, res, (*h.keys)(i), new_val + } + return MalHashmap(val=&res) + } else return ast +} + +func EVAL(ast, env) +{ + while (1) { + if (structof(ast) == MalError) return ast + if (structof(ast) != MalList) return eval_ast(ast, env) + ast = macroexpand(ast, env) + if (structof(ast) != MalList) return eval_ast(ast, env) + lst = *ast.val + if (numberof(lst) == 0) return ast + a1 = lst(1)->val + if (a1 == "def!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "let*") { + let_env = env_new(&env) + args_lst = *(lst(2)->val) + for (i = 1; i <= numberof(args_lst); i += 2) { + var_name = args_lst(i)->val + var_value = EVAL(*args_lst(i + 1), let_env) + if (structof(var_value) == MalError) return var_value + env_set, let_env, var_name, var_value + } + ast = *lst(3) + env = let_env + // TCO + } else if (a1 == "quote") { + return *lst(2) + } else if (a1 == "quasiquoteexpand") { + return quasiquote(*lst(2)) + } else if (a1 == "quasiquote") { + ast = quasiquote(*lst(2)) // TCO + } else if (a1 == "defmacro!") { + new_value = EVAL(*lst(3), env) + if (structof(new_value) == MalError) return new_value + new_value.macro = 1 + return env_set(env, lst(2)->val, new_value) + } else if (a1 == "macroexpand") { + return macroexpand(*lst(2), env) + } else if (a1 == "try*") { + ret = EVAL(*lst(2), env) + if (structof(ret) == MalError && numberof(lst) > 2) { + exc = *ret.obj + if (is_void(exc)) { + exc = MalString(val=ret.message) + } + catch_lst = *(lst(3)->val) + catch_env = env_new(&env) + env_set, catch_env, catch_lst(2)->val, exc + return EVAL(*catch_lst(3), catch_env) + } else { + return ret + } + } else if (a1 == "do") { + for (i = 2; i < numberof(lst); ++i) { + ret = EVAL(*lst(i), env) + if (structof(ret) == MalError) return ret + } + ast = *lst(numberof(lst)) + // TCO + } else if (a1 == "if") { + cond_val = EVAL(*lst(2), env) + if (structof(cond_val) == MalError) return cond_val + if ((structof(cond_val) == MalNil) || (structof(cond_val) == MalFalse)) { + if (numberof(lst) > 3) { + ast = *lst(4) + } else { + return MAL_NIL + } + } else { + ast = *lst(3) + } + // TCO + } else if (a1 == "fn*") { + return MalFunction(env=&env, binds=lst(2)->val, ast=lst(3), macro=0) + } else { + el = eval_ast(ast, env) + if (structof(el) == MalError) return el + seq = *el.val + if (structof(*seq(1)) == MalNativeFunction) { + args = (numberof(seq) > 1) ? seq(2:) : [] + return call_core_fn(seq(1)->val, args) + } else if (structof(*seq(1)) == MalFunction) { + fn = *seq(1) + exprs = numberof(seq) > 1 ? seq(2:) : [] + fn_env = env_new(fn.env, binds=*fn.binds, exprs=exprs) + ast = *fn.ast + env = fn_env + // TCO + } else { + return MalError(message="Unknown function type") + } + } + } +} + +func PRINT(exp) +{ + if (structof(exp) == MalError) return exp + return pr_str(exp, 1) +} + +func RE(str, env) +{ + return EVAL(READ(str), env) +} + +func REP(str, env) +{ + return PRINT(EVAL(READ(str), env)) +} + +func get_command_line(void) +// Force quiet mode (-q) to prevent Yorick from printing its banner +{ + argv = get_argv() + return numberof(argv) > 1 ? grow([argv(1), "-q"], argv(2:)) : [argv(1), "-q"] +} + +func prepare_argv_list(args) +{ + if (numberof(args) <= 1) return MalList(val=&[]) + str_lst = array(pointer, numberof(args) - 1) + for (i = 2; i <= numberof(args); ++i) { + str_lst(i - 1) = &MalString(val=args(i)) + } + return MalList(val=&str_lst) +} + +repl_env = nil + +func main(void) +{ + extern repl_env + repl_env = env_new(pointer(0)) + + // core.i: defined using Yorick + core_symbols = h_keys(core_ns) + for (i = 1; i <= numberof(core_symbols); ++i) { + env_set, repl_env, core_symbols(i), MalNativeFunction(val=core_symbols(i)) + } + command_line_args = process_argv() + env_set, repl_env, "*ARGV*", prepare_argv_list(command_line_args) + + // core.mal: defined using the language itself + RE, "(def! *host-language* \"yorick\")", repl_env + RE, "(def! not (fn* (a) (if a false true)))", repl_env + RE, "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))", repl_env + RE, "(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)))))))", repl_env + + if (numberof(command_line_args) > 0) { + RE, "(load-file \"" + command_line_args(1) + "\")", repl_env + return 0 + } + + RE, "(println (str \"Mal [\" *host-language* \"]\"))", repl_env + stdin_file = open("/dev/stdin", "r") + while (1) { + write, format="%s", "user> " + line = rdline(stdin_file, prompt="") + if (!line) break + if (strlen(line) > 0) { + result = REP(line, repl_env) + if (structof(result) == MalError) { + exc = *result.obj + if (is_void(exc)) { + write, format="Error: %s\n", result.message + } else { + write, format="Error: %s\n", pr_str(exc, 1) + } + } + else write, format="%s\n", result + } + } + write, "" +} + +main; diff --git a/impls/yorick/tests/stepA_mal.mal b/impls/yorick/tests/stepA_mal.mal index 76bc44ea18..a6635641a1 100644 --- a/impls/yorick/tests/stepA_mal.mal +++ b/impls/yorick/tests/stepA_mal.mal @@ -1,33 +1,33 @@ -;; Testing basic Yorick interop - -(yorick-eval "7") -;=>7 - -(yorick-eval "\"7\" + \"89\"") -;=>"789" - -(yorick-eval "123 == 123") -;=>1 - -(yorick-eval "123 == 456") -;=>0 - -(yorick-eval "[7, 8, 9]") -;=>(7 8 9) - -(yorick-eval "write, format=\"%s-%d\\x0A\", \"hello\", 1234; return nil;") -;/hello-1234 -;=>nil - -(yorick-eval "extern my_global_var; my_global_var = 8; return nil;") -(yorick-eval "my_global_var") -;=>8 - -(yorick-eval "a = [7, 8, 9]; return a + 10;") -;=>(17 18 19) - -(yorick-eval "[\"ab\", \"cd\", \"ef\"] + [\"X\", \"Y\", \"Z\"]") -;=>("abX" "cdY" "efZ") - -(yorick-eval "strpart(\"ABCDEFGHIJ\", 4:7)") -;=>"DEFG" +;; Testing basic Yorick interop + +(yorick-eval "7") +;=>7 + +(yorick-eval "\"7\" + \"89\"") +;=>"789" + +(yorick-eval "123 == 123") +;=>1 + +(yorick-eval "123 == 456") +;=>0 + +(yorick-eval "[7, 8, 9]") +;=>(7 8 9) + +(yorick-eval "write, format=\"%s-%d\\x0A\", \"hello\", 1234; return nil;") +;/hello-1234 +;=>nil + +(yorick-eval "extern my_global_var; my_global_var = 8; return nil;") +(yorick-eval "my_global_var") +;=>8 + +(yorick-eval "a = [7, 8, 9]; return a + 10;") +;=>(17 18 19) + +(yorick-eval "[\"ab\", \"cd\", \"ef\"] + [\"X\", \"Y\", \"Z\"]") +;=>("abX" "cdY" "efZ") + +(yorick-eval "strpart(\"ABCDEFGHIJ\", 4:7)") +;=>"DEFG" diff --git a/impls/yorick/types.i b/impls/yorick/types.i index a171e31dd1..8b8f3c947c 100644 --- a/impls/yorick/types.i +++ b/impls/yorick/types.i @@ -1,166 +1,166 @@ -require, "hash.i" - -struct MalError { - string message - pointer obj -} - -struct MalNil { - int val -} - -MAL_NIL = MalNil() - -struct MalTrue { - int val -} - -MAL_TRUE = MalTrue() - -struct MalFalse { - int val -} - -MAL_FALSE = MalFalse() - -struct MalNumber { - int val -} - -func new_number(s) -{ - return MalNumber(val=atoi(s)) -} - -struct MalSymbol { - string val - pointer meta -} - -struct MalString { - string val - pointer meta -} - -struct MalKeyword { - string val - pointer meta -} - -struct MalList { - pointer val - pointer meta -} - -struct MalVector { - pointer val - pointer meta -} - -func count(obj) { return numberof(*obj.val); } - -func rest(obj) { - seq = count(obj) <= 1 ? [] : ((*obj.val)(2:)) - return MalList(val=&seq) -} - -struct MalHashmap { - pointer val - pointer meta -} - -func hashmap_obj_to_key(obj) { - if (structof(obj) == MalString) return "str:" + obj.val - else if (structof(obj) == MalSymbol) return "sym:" + obj.val - else if (structof(obj) == MalKeyword) return "key:" + obj.val - else error, "Unsupported obj type for hash key" -} - -func hashmap_key_to_obj(key) { - type_str = strpart(key, 1:4) - val = strpart(key, 5:) - if (type_str == "str:") return MalString(val=val) - else if (type_str == "sym:") return MalSymbol(val=val) - else if (type_str == "key:") return MalKeyword(val=val) - else error, "Unsupported key type" -} - -func array_to_hashmap(seq) -{ - if (numberof(seq) % 2 != 0) return MalError(message="Odd number of elements in hashmap") - h = hash_new() - for (i = 1; i <= numberof(seq); i += 2) { - hash_set, h, hashmap_obj_to_key(*seq(i)), *seq(i + 1) - } - return MalHashmap(val=&h) -} - -struct MalNativeFunction { - string val - pointer meta -} - -struct MalFunction { - pointer env - pointer binds - pointer ast - int macro - pointer meta -} - -struct MalAtom { - pointer val - pointer meta -} - -func is_macro(obj) { return (structof(obj) == MalFunction && obj.macro); } - -struct MalAtomVal { - pointer val -} - -func new_boolean(b) { - if (b) return MAL_TRUE - return MAL_FALSE -} - -func equal_seq(seq_a, seq_b) { - if (numberof(seq_a) != numberof(seq_b)) return 0 - for (i = 1; i <= numberof(seq_a); ++i) { - if (!equal(*seq_a(i), *seq_b(i))) return 0 - } - return 1 -} - -func equal_hash(hm_a, hm_b) { - if (numberof(*hm_a.keys) != numberof(*hm_b.keys)) return 0 - for (i = 1; i <= numberof(*hm_a.keys); ++i) { - key_a = (*hm_a.keys)(i) - val_a = *((*hm_a.vals)(i)) - val_b = hash_get(hm_b, key_a) - if (is_void(val_b) || !equal(val_a, val_b)) return 0 - } - return 1 -} - -func equal(a, b) { - ta = structof(a) - tb = structof(b) - if (ta == MalNil) return tb == MalNil - else if (ta == MalTrue) return tb == MalTrue - else if (ta == MalFalse) return tb == MalFalse - else if (ta == MalNumber) return tb == MalNumber && a.val == b.val - else if (ta == MalSymbol) return tb == MalSymbol && a.val == b.val - else if (ta == MalString) return tb == MalString && a.val == b.val - else if (ta == MalKeyword) return tb == MalKeyword && a.val == b.val - else if (ta == MalList || ta == MalVector) { - return (tb == MalList || tb == MalVector) && equal_seq(*(a.val), *(b.val)) - } - else if (ta == MalHashmap) return tb == MalHashmap && equal_hash(*a.val, *b.val) - else return 0 -} - -func streplaceall(s, pattern, subst) -{ - return streplace(s, strfind(pattern, s, n=999), subst) -} +require, "hash.i" + +struct MalError { + string message + pointer obj +} + +struct MalNil { + int val +} + +MAL_NIL = MalNil() + +struct MalTrue { + int val +} + +MAL_TRUE = MalTrue() + +struct MalFalse { + int val +} + +MAL_FALSE = MalFalse() + +struct MalNumber { + int val +} + +func new_number(s) +{ + return MalNumber(val=atoi(s)) +} + +struct MalSymbol { + string val + pointer meta +} + +struct MalString { + string val + pointer meta +} + +struct MalKeyword { + string val + pointer meta +} + +struct MalList { + pointer val + pointer meta +} + +struct MalVector { + pointer val + pointer meta +} + +func count(obj) { return numberof(*obj.val); } + +func rest(obj) { + seq = count(obj) <= 1 ? [] : ((*obj.val)(2:)) + return MalList(val=&seq) +} + +struct MalHashmap { + pointer val + pointer meta +} + +func hashmap_obj_to_key(obj) { + if (structof(obj) == MalString) return "str:" + obj.val + else if (structof(obj) == MalSymbol) return "sym:" + obj.val + else if (structof(obj) == MalKeyword) return "key:" + obj.val + else error, "Unsupported obj type for hash key" +} + +func hashmap_key_to_obj(key) { + type_str = strpart(key, 1:4) + val = strpart(key, 5:) + if (type_str == "str:") return MalString(val=val) + else if (type_str == "sym:") return MalSymbol(val=val) + else if (type_str == "key:") return MalKeyword(val=val) + else error, "Unsupported key type" +} + +func array_to_hashmap(seq) +{ + if (numberof(seq) % 2 != 0) return MalError(message="Odd number of elements in hashmap") + h = hash_new() + for (i = 1; i <= numberof(seq); i += 2) { + hash_set, h, hashmap_obj_to_key(*seq(i)), *seq(i + 1) + } + return MalHashmap(val=&h) +} + +struct MalNativeFunction { + string val + pointer meta +} + +struct MalFunction { + pointer env + pointer binds + pointer ast + int macro + pointer meta +} + +struct MalAtom { + pointer val + pointer meta +} + +func is_macro(obj) { return (structof(obj) == MalFunction && obj.macro); } + +struct MalAtomVal { + pointer val +} + +func new_boolean(b) { + if (b) return MAL_TRUE + return MAL_FALSE +} + +func equal_seq(seq_a, seq_b) { + if (numberof(seq_a) != numberof(seq_b)) return 0 + for (i = 1; i <= numberof(seq_a); ++i) { + if (!equal(*seq_a(i), *seq_b(i))) return 0 + } + return 1 +} + +func equal_hash(hm_a, hm_b) { + if (numberof(*hm_a.keys) != numberof(*hm_b.keys)) return 0 + for (i = 1; i <= numberof(*hm_a.keys); ++i) { + key_a = (*hm_a.keys)(i) + val_a = *((*hm_a.vals)(i)) + val_b = hash_get(hm_b, key_a) + if (is_void(val_b) || !equal(val_a, val_b)) return 0 + } + return 1 +} + +func equal(a, b) { + ta = structof(a) + tb = structof(b) + if (ta == MalNil) return tb == MalNil + else if (ta == MalTrue) return tb == MalTrue + else if (ta == MalFalse) return tb == MalFalse + else if (ta == MalNumber) return tb == MalNumber && a.val == b.val + else if (ta == MalSymbol) return tb == MalSymbol && a.val == b.val + else if (ta == MalString) return tb == MalString && a.val == b.val + else if (ta == MalKeyword) return tb == MalKeyword && a.val == b.val + else if (ta == MalList || ta == MalVector) { + return (tb == MalList || tb == MalVector) && equal_seq(*(a.val), *(b.val)) + } + else if (ta == MalHashmap) return tb == MalHashmap && equal_hash(*a.val, *b.val) + else return 0 +} + +func streplaceall(s, pattern, subst) +{ + return streplace(s, strfind(pattern, s, n=999), subst) +} diff --git a/impls/zig/Dockerfile b/impls/zig/Dockerfile index 2e70fa9bd9..38b7abdbd7 100644 --- a/impls/zig/Dockerfile +++ b/impls/zig/Dockerfile @@ -1,33 +1,33 @@ -FROM ubuntu:bionic -MAINTAINER Joel Martin - -########################################################## -# General requirements for testing or common across many -# implementations -########################################################## - -RUN apt-get -y update - -# Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev libpcre3-dev - -RUN mkdir -p /mal -WORKDIR /mal - -########################################################## -# Specific implementation requirements -########################################################## - -RUN apt-get -y install gcc gdc ldc gpg wget - -RUN wget https://ziglang.org/download/0.5.0/zig-linux-x86_64-0.5.0.tar.xz && \ - echo `pwd` && \ - tar -xf zig-linux-x86_64-0.5.0.tar.xz && \ - cp -r zig-linux-x86_64-0.5.0 /usr/local/bin && \ - ln -sf /usr/local/bin/zig-linux-x86_64-0.5.0/zig /usr/local/bin/zig && \ - chmod +x /usr/local/bin/zig - -ENV HOME /mal +FROM ubuntu:bionic +MAINTAINER Joel Martin + +########################################################## +# General requirements for testing or common across many +# implementations +########################################################## + +RUN apt-get -y update + +# Required for running tests +RUN apt-get -y install make python + +# Some typical implementation and test requirements +RUN apt-get -y install curl libreadline-dev libedit-dev libpcre3-dev + +RUN mkdir -p /mal +WORKDIR /mal + +########################################################## +# Specific implementation requirements +########################################################## + +RUN apt-get -y install gcc gdc ldc gpg wget + +RUN wget https://ziglang.org/download/0.5.0/zig-linux-x86_64-0.5.0.tar.xz && \ + echo `pwd` && \ + tar -xf zig-linux-x86_64-0.5.0.tar.xz && \ + cp -r zig-linux-x86_64-0.5.0 /usr/local/bin && \ + ln -sf /usr/local/bin/zig-linux-x86_64-0.5.0/zig /usr/local/bin/zig && \ + chmod +x /usr/local/bin/zig + +ENV HOME /mal diff --git a/impls/zig/Makefile b/impls/zig/Makefile index acf99b11d8..eb6f1c8050 100644 --- a/impls/zig/Makefile +++ b/impls/zig/Makefile @@ -1,16 +1,16 @@ - -STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal - -all: $(STEPS) - -dist: mal - - -%: %.zig - zig build -Drelease-fast=true - ln -sf zig-cache/bin/$* . - -.PHONY: clean - -clean: - rm -f $(STEPS) + +STEPS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal + +all: $(STEPS) + +dist: mal + + +%: %.zig + zig build -Drelease-fast=true + ln -sf zig-cache/bin/$* . + +.PHONY: clean + +clean: + rm -f $(STEPS) diff --git a/impls/zig/build.zig b/impls/zig/build.zig index 4154e1c471..2d235f209d 100644 --- a/impls/zig/build.zig +++ b/impls/zig/build.zig @@ -1,35 +1,35 @@ -const LibExeObjStep = @import("std").build.LibExeObjStep; -const Builder = @import("std").build.Builder; -const builtin = @import("builtin"); - -const warn = @import("std").debug.warn; - -pub fn build(b: *Builder) void { - const mode = b.standardReleaseOptions(); - - const exes = [_] *LibExeObjStep { - b.addExecutable("step0_repl", "step0_repl.zig"), - b.addExecutable("step1_read_print", "step1_read_print.zig"), - b.addExecutable("step2_eval", "step2_eval.zig"), - b.addExecutable("step3_env", "step3_env.zig"), - b.addExecutable("step4_if_fn_do", "step4_if_fn_do.zig"), - b.addExecutable("step5_tco", "step5_tco.zig"), - b.addExecutable("step6_file", "step6_file.zig"), - b.addExecutable("step7_quote", "step7_quote.zig"), - b.addExecutable("step8_macros", "step8_macros.zig"), - b.addExecutable("step9_try", "step9_try.zig"), - b.addExecutable("stepA_mal", "stepA_mal.zig"), - }; - - for(exes) |exe| { - exe.setBuildMode(mode); - exe.linkSystemLibrary("c"); - exe.linkSystemLibrary("pcre"); - exe.linkSystemLibrary("readline"); - const run_cmd = exe.run(); - const step = b.step(exe.name, exe.name); - step.dependOn(&run_cmd.step); - b.default_step.dependOn(&exe.step); - b.installArtifact(exe); - } -} +const LibExeObjStep = @import("std").build.LibExeObjStep; +const Builder = @import("std").build.Builder; +const builtin = @import("builtin"); + +const warn = @import("std").debug.warn; + +pub fn build(b: *Builder) void { + const mode = b.standardReleaseOptions(); + + const exes = [_] *LibExeObjStep { + b.addExecutable("step0_repl", "step0_repl.zig"), + b.addExecutable("step1_read_print", "step1_read_print.zig"), + b.addExecutable("step2_eval", "step2_eval.zig"), + b.addExecutable("step3_env", "step3_env.zig"), + b.addExecutable("step4_if_fn_do", "step4_if_fn_do.zig"), + b.addExecutable("step5_tco", "step5_tco.zig"), + b.addExecutable("step6_file", "step6_file.zig"), + b.addExecutable("step7_quote", "step7_quote.zig"), + b.addExecutable("step8_macros", "step8_macros.zig"), + b.addExecutable("step9_try", "step9_try.zig"), + b.addExecutable("stepA_mal", "stepA_mal.zig"), + }; + + for(exes) |exe| { + exe.setBuildMode(mode); + exe.linkSystemLibrary("c"); + exe.linkSystemLibrary("pcre"); + exe.linkSystemLibrary("readline"); + const run_cmd = exe.run(); + const step = b.step(exe.name, exe.name); + step.dependOn(&run_cmd.step); + b.default_step.dependOn(&exe.step); + b.installArtifact(exe); + } +} diff --git a/impls/zig/core.zig b/impls/zig/core.zig index 6e8ccd521c..1d0647ebac 100644 --- a/impls/zig/core.zig +++ b/impls/zig/core.zig @@ -1,854 +1,854 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const AllocatorType = @import("std").mem.Allocator; -var Allocator: *AllocatorType = undefined; - -pub fn set_allocator(alloc: *AllocatorType) void { - Allocator = alloc; -} - -const Env = @import("env.zig").Env; -const MalData = @import("types.zig").MalData; -const MalType = @import("types.zig").MalType; -const MalTypeValue = @import("types.zig").MalTypeValue; -const printer = @import("printer.zig"); -const reader = @import("reader.zig"); -const getline_prompt = @import("readline.zig").getline_prompt; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; - -const MalError = @import("error.zig").MalError; - -const hmap = @import("hmap.zig"); - -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const MalHashMap = @import("hmap.zig").MalHashMap; -const linked_list = @import("linked_list.zig"); -const apply_function = @import("types.zig").apply_function; - -const safeAdd = @import("std").math.add; -const safeSub = @import("std").math.sub; -const safeMul = @import("std").math.mul; -const safeDivFloor = @import("std").math.divFloor; - -fn int_plus(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeAdd(i64, x, y) catch return MalError.Overflow; - return MalType.new_int(Allocator, res); -} - -fn int_minus(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeSub(i64, x, y) catch return MalError.Overflow; - return MalType.new_int(Allocator, res); -} - -fn int_mult(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeMul(i64, x, y) catch return MalError.Overflow; - return MalType.new_int(Allocator, res); -} - -fn int_div(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeDivFloor(i64, x, y) catch |err| switch(err) { - error.DivisionByZero => return MalError.DivisionByZero, - else => return MalError.Overflow, - }; - return MalType.new_int(Allocator, res); -} - -fn int_lt(a1: *MalType, a2: *MalType) MalError!*MalType { - return MalType.new_bool(Allocator, (try a1.as_int()) < (try a2.as_int())); -} - -fn int_leq(a1: *MalType, a2: *MalType) MalError!*MalType { - return MalType.new_bool(Allocator, (try a1.as_int()) <= (try a2.as_int())); -} - -fn int_gt(a1: *MalType, a2: *MalType) MalError!*MalType { - return MalType.new_bool(Allocator, (try a1.as_int()) > (try a2.as_int())); -} - -fn int_geq(a1: *MalType, a2: *MalType) MalError!*MalType { - return MalType.new_bool(Allocator, (try a1.as_int()) >= (try a2.as_int())); -} - -fn _linked_list_equality(l1: MalLinkedList, l2: MalLinkedList) MalError!bool { - if(l1.count() != l2.count()) { - return false; - } - var it1 = l1.iterator(); - var it2 = l2.iterator(); - while(true) { - const m1 = it1.next() orelse return (it2.next() == null); - const m2 = it2.next() orelse return false; - const el_cmp = try equality(m1, m2); - if(MalTypeValue(el_cmp.data) == MalTypeValue.False) { - el_cmp.delete(Allocator); - return false; - } - el_cmp.delete(Allocator); - } - return true; -} - -fn _hashmap_equality(h1: MalHashMap, h2: MalHashMap) MalError!bool { - if(h1.count() != h2.count()) { - return false; - } - - var iterator = h1.iterator(); - var optional_pair = iterator.next(); - while(optional_pair) |pair| { - const optional_val = h2.getValue(pair.key); - if(optional_val) |val| { - const el_cmp = try equality(pair.value, val); - if(MalTypeValue(el_cmp.data) == MalTypeValue.False) { - el_cmp.delete(Allocator); - return false; - } - el_cmp.delete(Allocator); - } - else { - return false; - } - optional_pair = iterator.next(); - } - return true; -} - -// TODO: make _equality -> bool -fn equality(a1: *MalType, a2: *MalType) MalError!*MalType { - const a1_is_sequential = (MalTypeValue(a1.data) == MalTypeValue.List) or - (MalTypeValue(a1.data) == MalTypeValue.Vector); - const a2_is_sequential = (MalTypeValue(a2.data) == MalTypeValue.List) or - (MalTypeValue(a2.data) == MalTypeValue.Vector); - - if(a1_is_sequential and a2_is_sequential) { - const l1 = (try a1.sequence_linked_list()).*; - const l2 = (try a2.sequence_linked_list()).*; - return MalType.new_bool(Allocator, try _linked_list_equality(l1, l2)); - } - - if(MalTypeValue(a1.data) != MalTypeValue(a2.data)) { - return MalType.new_bool(Allocator, false); - } - - switch(a1.data) { - .True, .False, .Nil => { - return MalType.new_bool(Allocator, true); - }, - .Int => |v1| { - return MalType.new_bool(Allocator, v1 == a2.data.Int); - }, - .List => |l1| { - const l2 = a2.data.List; - return MalType.new_bool(Allocator, try _linked_list_equality(l1, l2)); - }, - .Vector => |v1| { - const v2 = a2.data.Vector; - return MalType.new_bool(Allocator, try _linked_list_equality(v1, v2)); - }, - .String => |s1| { - const s2 = a2.data.String; - return MalType.new_bool(Allocator, string_eql(s1, s2)); - }, - .Generic => |v1| { - const v2 = a2.data.Generic; - return MalType.new_bool(Allocator, string_eql(v1, v2)); - }, - .Keyword => |k1| { - const k2 = a2.data.Keyword; - return MalType.new_bool(Allocator, string_eql(k1, k2)); - }, - .HashMap => |h1| { - const h2 = a2.data.HashMap; - return MalType.new_bool(Allocator, try _hashmap_equality(h1,h2)); - }, - // TODO: implement more types - else => return MalType.new_bool(Allocator, false), - } -} - -fn list(args: MalLinkedList) MalError!*MalType { - var new_mal = try MalType.new_list_empty(Allocator); - new_mal.data = MalData{.List = try linked_list.deepcopy(Allocator, args)}; - return new_mal; -} - -fn vector(args: MalLinkedList) MalError!*MalType { - var new_mal = try MalType.new_list_empty(Allocator); - new_mal.data = MalData{.Vector = try linked_list.deepcopy(Allocator, args)}; - return new_mal; -} - -fn map(args: MalLinkedList) MalError!*MalType { - if(args.count() < 2) return MalError.ArgError; - const func_mal = args.at(0); - var args_mal = args.at(1); - var new_ll = MalLinkedList.init(Allocator); - var to_map_ll = try args_mal.sequence_linked_list(); - - var iterator = to_map_ll.iterator(); - while(iterator.next()) |mal| { - var args_ll = MalLinkedList.init(Allocator); - // TODO: can be more efficient than this - try linked_list.append_mal(Allocator, &args_ll, try func_mal.copy(Allocator)); - try linked_list.append_mal(Allocator, &args_ll, try mal.copy(Allocator)); - const new_mal = try apply_function(Allocator, args_ll); - linked_list.destroy(Allocator, &args_ll, false); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - const new_list = try MalType.new_nil(Allocator); - new_list.data = MalData{.List = new_ll}; - return new_list; -} - -fn is_list(a1: *MalType) MalError!*MalType { - return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.List); -} - -fn is_vector(a1: *MalType) MalError!*MalType { - return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.Vector); -} - -pub fn is_string(a1: *MalType) MalError!*MalType { - return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.String); -} - -pub fn is_number(a1: *MalType) MalError!*MalType { - return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.Int); -} - -pub fn is_fn(a1: *MalType) MalError!*MalType { - const is_function = switch(a1.data) { - .Fn0 => true, - .Fn1 => true, - .Fn2 => true, - .Fn3 => true, - .Fn4 => true, - .FVar => true, - .Func => |func_data| !func_data.is_macro, - else => false, - }; - return MalType.new_bool(Allocator, is_function); -} - -pub fn is_macro(a1: *MalType) MalError!*MalType { - const is_func_and_macro = switch(a1.data) { - .Func => |data| data.is_macro, - else => false, - }; - return MalType.new_bool(Allocator, is_func_and_macro); -} - -fn empty(a1: *MalType) MalError!*MalType { - return switch(a1.data) { - .List => |l| MalType.new_bool(Allocator, l.len == 0), - .Vector => |v| MalType.new_bool(Allocator, v.len == 0), - else => MalType.new_bool(Allocator, false), - }; -} - -fn prn(args: MalLinkedList) MalError!*MalType { - const s = try printer.print_mal_to_string(args, true, true); - const stdout_file = std.io.getStdOut() catch return MalError.SystemError; - stdout_file.write(s) catch return MalError.SystemError; - stdout_file.write("\n") catch return MalError.SystemError; - Allocator.free(s); - const mal = try MalType.new_nil(Allocator); - return mal; -} - -fn println(args: MalLinkedList) MalError!*MalType { - const s = try printer.print_mal_to_string(args, false, true); - const stdout_file = std.io.getStdOut() catch return MalError.SystemError; - stdout_file.write(s) catch return MalError.SystemError; - stdout_file.write("\n") catch return MalError.SystemError; - Allocator.free(s); - const mal = try MalType.new_nil(Allocator); - return mal; -} - -fn str(args: MalLinkedList) MalError!*MalType { - if(args.count() == 0) { - const s: []u8 = ""; - return MalType.new_string(Allocator, s); - } - const s = try printer.print_mal_to_string(args, false, false); - return MalType.new_string(Allocator, s); -} - -fn pr_str(args: MalLinkedList) MalError!*MalType { - if(args.count() == 0) { - const s: []u8 = ""; - return MalType.new_string(Allocator, s); - } - const s = try printer.print_mal_to_string(args, true, true); - return MalType.new_string(Allocator, s); -} - -fn slurp(a1: *MalType) MalError!*MalType { - switch(a1.data) { - .String => |path| { - const file_contents = std.io.readFileAlloc(Allocator, path) - catch |err| return MalError.SystemError; // TODO: change this error - defer Allocator.free(file_contents); - return MalType.new_string(Allocator, file_contents); - }, - else => { - return MalError.TypeError; - }, - } - return unreachable; -} - -fn atom(a1: *MalType) MalError!*MalType { - return MalType.new_atom(Allocator, a1); -} - -fn is_atom(a1: *MalType) MalError!*MalType { - return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.Atom); -} - -fn deref(a1: *MalType) MalError!*MalType { - return switch(a1.data) { - .Atom => |atom_val| atom_val.*.copy(Allocator), - else => MalError.TypeError, - }; -} - -fn atom_reset(a1: *MalType, a2: *MalType) MalError!*MalType { - switch(a1.data) { - .Atom => |*atom_val| { - var new_target = try a2.copy(Allocator); - atom_val.*.*.delete(Allocator); - atom_val.*.* = new_target; - return new_target.copy(Allocator); - }, - else => return MalError.TypeError, - } -} - -fn atom_swap(args: MalLinkedList) MalError!*MalType { - const args_arr = args.toSlice(); - const n = args.len; - if(n < 2) return MalError.ArgError; - var new_args = MalLinkedList.init(Allocator); - defer linked_list.destroy(Allocator, &new_args, false); - try linked_list.append_mal(Allocator, &new_args, try args_arr[1].copy(Allocator)); - try linked_list.append_mal(Allocator, &new_args, try deref(args_arr[0])); - var i: usize = 2; - while(i < n) { - try linked_list.append_mal(Allocator, &new_args, try args_arr[i].copy(Allocator)); - i += 1; - } - const return_mal = try apply_function(Allocator, new_args); - const new_mal = atom_reset(args_arr[0], return_mal); - return_mal.delete(Allocator); - return new_mal; -} - -pub fn vec(a1: *const MalType) MalError!*MalType { - const ll = switch(a1.data) { - .List => |l| l, - .Vector => |v| v, - else => return MalError.TypeError, - }; - const copy = try linked_list.deepcopy(Allocator, ll); - return MalType.new_vector(Allocator, copy); -} - -pub fn cons(a1: *const MalType, a2: *const MalType) MalError!*MalType { - // TODO: do we need this for vectors? - const old_ll = try a2.const_sequence_linked_list(); - var new_ll = try linked_list.deepcopy(Allocator, old_ll); - var new_list = try MalType.new_nil(Allocator); - new_list.data = MalData{.List = new_ll}; - errdefer new_list.delete(Allocator); - var new_mal = try a1.copy(Allocator); - errdefer new_mal.delete(Allocator); - try linked_list.prepend_mal(Allocator, &new_list.data.List, new_mal); - return new_list; -} - -pub fn concat(args: MalLinkedList) MalError!*MalType { - // First we make a new array with shallow copies - var new_ll = MalLinkedList.init(Allocator); - errdefer linked_list.destroy(Allocator, &new_ll, false); - var iterator = args.iterator(); - while(iterator.next()) |mal| { - const mal_seq = try mal.sequence_linked_list(); - new_ll.appendSlice(mal_seq.toSlice()) catch return MalError.SystemError; - } - - // Now we turn the shallow copies into deep copies - const new_arr = new_ll.toSlice(); - var i: usize = 0; - while(i < new_arr.len) { - new_arr[i] = try new_arr[i].copy(Allocator); - i += 1; - } - - // Wrap the list in a MalType, return - var new_mal = try MalType.new_nil(Allocator); - new_mal.data = MalData{.List = new_ll}; - return new_mal; -} - -pub fn rest(a1: *const MalType) MalError!*MalType { - var old_list = switch(a1.data) { - .List => |l| l, - .Vector => |v| v, - .Nil => return MalType.new_list_empty(Allocator), - else => return MalError.TypeError, - }; - var new_list = try linked_list.deepcopy(Allocator, old_list); - errdefer linked_list.destroy(Allocator, &new_list, false); - - if(new_list.count() > 0) { - const mal = try linked_list.pop_first(Allocator, &new_list); - mal.delete(Allocator); - } - var new_mal = try MalType.new_nil(Allocator); - new_mal.data = MalData{.List = new_list}; - return new_mal; -} - -pub fn _nth(mal_list: *const MalType, pos: i64) MalError!*MalType { - // TODO: vectors? - const l = try mal_list.const_sequence_linked_list(); - if(pos < 0 or pos >= @intCast(i64,l.count())) { - return MalError.OutOfBounds; - } - return l.at(@intCast(usize,pos)); -} - -pub fn nth(a1: *const MalType, a2: *const MalType) MalError!*MalType { - return switch(a2.data) { - .Int => |pos| (try _nth(a1, pos)).copy(Allocator), - else => MalError.TypeError, - }; -} - -pub fn first(a1: *const MalType) MalError!*MalType { - var l = switch(a1.data) { - .List => |l| l, - .Vector => |v| v, - .Nil => return MalType.new_nil(Allocator), - else => return MalError.TypeError, - }; - if(l.count() == 0) return MalType.new_nil(Allocator); - return l.at(0).copy(Allocator); -} - -fn check_type(mal: *const MalType, value_type: MalTypeValue) MalError!*MalType { - // TODO: use this everywhere - // TODO: do this more generically - return MalType.new_bool(Allocator, MalTypeValue(mal.data) == value_type); -} - -pub fn is_nil(a1: *const MalType) MalError!*MalType { - return check_type(a1, MalTypeValue.Nil); -} - -pub fn is_true(a1: *const MalType) MalError!*MalType { - return check_type(a1, MalTypeValue.True); -} - -pub fn is_false(a1: *const MalType) MalError!*MalType { - return check_type(a1, MalTypeValue.False); -} - -pub fn is_symbol(a1: *const MalType) MalError!*MalType { - return check_type(a1, MalTypeValue.Generic); -} - -pub fn is_keyword(a1: *const MalType) MalError!*MalType { - return check_type(a1, MalTypeValue.Keyword); -} - -pub fn is_map(a1: *const MalType) MalError!*MalType { - return check_type(a1, MalTypeValue.HashMap); -} - -pub fn is_sequential(a1: *const MalType) MalError!*MalType { - const res = (MalTypeValue(a1.data) == MalTypeValue.Vector) or - (MalTypeValue(a1.data) == MalTypeValue.List); - return MalType.new_bool(Allocator, res); -} - -pub fn symbol(a1: *const MalType) MalError!*MalType { - const string = switch(a1.data) { - .String => |s| s, - else => return MalError.TypeError, - }; - return MalType.new_generic(Allocator, string); -} - -pub fn hash_map(args: MalLinkedList) MalError!*MalType { - const new_mal = try MalType.new_hashmap(Allocator); - const args_arr = args.toSlice(); - const n = args_arr.len; - if((n%2) != 0) return MalError.ArgError; - var i: usize = 0; - - while(2*i+1 < n) { - const this_key = switch(args_arr[2*i].data) { - .String => |s| s, - .Keyword => |kwd| kwd, - else => return MalError.ArgError, - }; - const this_key_cpy = string_copy(Allocator, this_key) catch return MalError.SystemError; - const this_val_cpy = try args_arr[2*i+1].copy(Allocator); - try new_mal.hashmap_insert(this_key_cpy, this_val_cpy); - i += 1; - } - return new_mal; -} - -pub fn hash_map_assoc(args: MalLinkedList) MalError!*MalType { - const args_arr = args.toSlice(); - if(args_arr.len < 1) return MalError.ArgError; - const new_mal = try MalType.new_nil(Allocator); - errdefer new_mal.delete(Allocator); - const base_hmap = switch(args_arr[0].data) { - .HashMap => |hm| hm, - else => return MalError.TypeError, - }; - const hmap_cpy = hmap.deepcopy(Allocator, base_hmap) catch return MalError.SystemError; - new_mal.data = MalData {.HashMap = hmap_cpy}; - - const assoc_arr = args_arr[1..args_arr.len]; - if((assoc_arr.len % 2) != 0) return MalError.ArgError; - var i: usize = 0; - while(2*i+1 < assoc_arr.len) { - const this_key = switch(assoc_arr[2*i].data) { - .String => |s| s, - .Keyword => |kwd| kwd, - else => return MalError.ArgError, - }; - const this_key_cpy = string_copy(Allocator, this_key) catch return MalError.SystemError; - const this_val_cpy = try assoc_arr[2*i+1].copy(Allocator); - try new_mal.hashmap_insert(this_key_cpy, this_val_cpy); - i += 1; - } - return new_mal; -} - -pub fn hash_map_dissoc(args: MalLinkedList) MalError!*MalType { - const args_arr = args.toSlice(); - if(args_arr.len < 1) return MalError.ArgError; - const new_mal = try MalType.new_nil(Allocator); - errdefer new_mal.delete(Allocator); - const base_hmap = switch(args_arr[0].data) { - .HashMap => |hm| hm, - else => return MalError.TypeError, - }; - const hmap_cpy = hmap.deepcopy(Allocator, base_hmap) catch return MalError.SystemError; - new_mal.data = MalData {.HashMap = hmap_cpy}; - - var i: usize = 1; - while(i < args_arr.len) { - const this_key = switch(args_arr[i].data) { - .String => |s| s, - .Keyword => |kwd| kwd, - else => return MalError.ArgError, - }; - try new_mal.hashmap_remove(this_key); - i += 1; - } - return new_mal; -} - -pub fn hash_map_get(a1: *MalType, a2: *MalType) MalError!*MalType { - const key = switch(a2.data) { - .String => |s| s, - .Keyword => |kwd| kwd, - else => return MalError.TypeError, - }; - const optional_val = try a1.hashmap_get(key); - if(optional_val) |val| { - return val.copy(Allocator); - } - else return MalType.new_nil(Allocator); -} - -pub fn hash_map_contains(a1: *MalType, a2: *MalType) MalError!*MalType { - const key = switch(a2.data) { - .String => |s| s, - .Keyword => |kwd| kwd, - else => return MalError.TypeError, - }; - const contains_bool = try a1.hashmap_contains(key); - return MalType.new_bool(Allocator, contains_bool); -} - -pub fn hash_map_keys(a1: *MalType) MalError!*MalType { - const hm = switch(a1.data) { - .HashMap => |h| h, - else => return MalError.TypeError, - }; - var new_ll = MalLinkedList.init(Allocator); - errdefer linked_list.destroy(Allocator, &new_ll, false); - var iterator = hm.iterator(); - var optional_pair = iterator.next(); - - while(true) { - const pair = optional_pair orelse break; - const key = string_copy(Allocator, pair.key) catch return MalError.SystemError; - - var key_mal: *MalType = undefined; - if(key.len > 1 and key[0] == 255) { - key_mal = try MalType.new_keyword(Allocator, key[1..key.len]); - } else { - key_mal = try MalType.new_string(Allocator, key); - } - try linked_list.append_mal(Allocator, &new_ll, key_mal); - optional_pair = iterator.next(); - } - var new_mal = try MalType.new_nil(Allocator); - new_mal.data = MalData{.List = new_ll}; - return new_mal; -} - -pub fn hash_map_vals(a1: *MalType) MalError!*MalType { - const hm = switch(a1.data) { - .HashMap => |h| h, - else => return MalError.TypeError, - }; - var new_ll = MalLinkedList.init(Allocator); - errdefer linked_list.destroy(Allocator, &new_ll, false); - var iterator = hm.iterator(); - var optional_pair = iterator.next(); - - while(true) { - const pair = optional_pair orelse break; - const val = try pair.value.copy(Allocator); - try linked_list.append_mal(Allocator, &new_ll, val); - optional_pair = iterator.next(); - } - var new_mal = try MalType.new_nil(Allocator); - new_mal.data = MalData{.List = new_ll}; - return new_mal; -} - -pub fn sequence_length(a1: *MalType) MalError!*MalType { - const len = switch(a1.data) { - .List => |l| l.count(), - .Vector => |v| v.count(), - .String => |s| s.len, - .Nil => 0, - else => return MalError.TypeError, - }; - return MalType.new_int(Allocator, @intCast(i64,len)); -} - -pub fn keyword(a1: *MalType) MalError!*MalType { - const kwd = switch(a1.data) { - .String => |s| s, - .Keyword => |k| return a1.copy(Allocator), - else => return MalError.TypeError, - }; - return MalType.new_keyword(Allocator, kwd); -} - -pub fn readline(a1: *MalType) MalError!*MalType { - const prompt = try a1.as_string(); - const optional_read_line = getline_prompt(Allocator, prompt) - catch return MalError.SystemError; - if(optional_read_line) |read_line| { - return MalType.new_string(Allocator, read_line); - } - const mal = try MalType.new_nil(Allocator); - return MalType.new_nil(Allocator); -} - -pub fn time_ms() MalError!*MalType { - const itime: i64 = @intCast(i64, std.time.milliTimestamp()); - return MalType.new_int(Allocator, itime); -} - -pub fn meta(a1: *MalType) MalError!*MalType { - if(a1.meta) |mal_meta| { - return mal_meta.copy(Allocator); - } - return MalType.new_nil(Allocator); -} - -pub fn with_meta(a1: *MalType, a2: *MalType) MalError!*MalType { - var new_mal = try a1.copy(Allocator); - if(new_mal.meta) |mal_meta| { - mal_meta.delete(Allocator); - } - new_mal.meta = try a2.copy(Allocator); - return new_mal; -} - -pub fn seq(a1: *MalType) MalError!*MalType { - switch(a1.data) { - .List => |l| { - if(l.count() == 0) return MalType.new_nil(Allocator); - return a1.copy(Allocator); - }, - .Vector => |v| { - if(v.count() == 0) return MalType.new_nil(Allocator); - const mal_copy = try a1.copy(Allocator); - const ll = mal_copy.data.Vector; - mal_copy.data = MalData{.List = ll}; - return mal_copy; - }, - .String => |s| { - if(s.len == 0) return MalType.new_nil(Allocator); - const new_list = try MalType.new_list_empty(Allocator); - for(s) |letter| { - const new_char = try MalType.new_string(Allocator, [_]u8 {letter}); - try new_list.sequence_append(Allocator, new_char); - } - return new_list; - }, - .Nil => { - return MalType.new_nil(Allocator); - }, - else => { - return MalError.TypeError; - } - } - return MalType.new_nil(Allocator); -} - -pub fn conj(args: MalLinkedList) MalError!*MalType { - var iterator = args.iterator(); - const container = iterator.next() orelse return MalError.ArgError; - const append = switch(container.data) { - .List => false, - .Vector => true, - else => return MalError.ArgError, - }; - - var return_mal = try container.copy(Allocator); - while(iterator.next()) |mal| { - const mal_copy = try mal.copy(Allocator); - if(append) { - try return_mal.sequence_append(Allocator, mal_copy); - } else { - try return_mal.sequence_prepend(Allocator, mal_copy); - } - } - return return_mal; -} - -fn read_string(a1: *MalType) MalError!*MalType { - const str_to_eval = try a1.as_string(); - var read = try reader.read_str(str_to_eval); - return (try reader.read_form(&read)) orelse return MalType.new_nil(Allocator); -} - -pub fn do_apply(args: MalLinkedList) MalError!*MalType { - // TODO: not always safe to delete new_ll here - if(args.count() == 0) return MalError.ArgError; - var args_copy = args; - const list_node = args_copy.pop(); - const list_ll = try list_node.sequence_linked_list(); - var new_ll = try linked_list.deepcopy(Allocator, list_ll.*); - defer linked_list.destroy(Allocator, &new_ll, false); - var optional_node = args_copy.popOrNull(); - while(optional_node) |node| { - try linked_list.prepend_mal(Allocator, &new_ll, try node.copy(Allocator)); - optional_node = args_copy.popOrNull(); - } - var return_mal = apply_function(Allocator, new_ll); - return return_mal; -} - -pub const CorePairType = enum { - Fn0, - Fn1, - Fn2, - Fn3, - Fn4, - FVar, -}; - -pub const CorePairData = union(CorePairType) { - Fn0: *const fn() MalError!*MalType, - Fn1: *const fn(a1: *MalType) MalError!*MalType, - Fn2: *const fn(a1: *MalType, a2: *MalType) MalError!*MalType, - Fn3: *const fn(a1: *MalType, a2: *MalType, a3: *MalType) MalError!*MalType, - Fn4: *const fn(a1: *MalType, a2: *MalType, a3: *MalType, a4: *MalType) MalError!*MalType, - FVar: *const fn(args: MalLinkedList) MalError!*MalType, -}; - -pub const CorePair = struct { - name: []const u8, - func: CorePairData, -}; - -pub const core_namespace = [_] CorePair { - CorePair { .name = "+", .func = CorePairData {.Fn2 = &int_plus} }, - CorePair { .name = "-", .func = CorePairData {.Fn2 = &int_minus} }, - CorePair { .name = "*", .func = CorePairData {.Fn2 = &int_mult} }, - CorePair { .name = "/", .func = CorePairData {.Fn2 = &int_div} }, - CorePair { .name = "<", .func = CorePairData {.Fn2 = &int_lt} }, - CorePair { .name = "<=", .func = CorePairData {.Fn2 = &int_leq} }, - CorePair { .name = ">", .func = CorePairData {.Fn2 = &int_gt} }, - CorePair { .name = ">=", .func = CorePairData {.Fn2 = &int_geq} }, - CorePair { .name = "=", .func = CorePairData {.Fn2 = &equality} }, - CorePair { .name = "list?", .func = CorePairData {.Fn1 = &is_list} }, - CorePair { .name = "vector?", .func = CorePairData {.Fn1 = &is_vector} }, - CorePair { .name = "count", .func = CorePairData {.Fn1 = &sequence_length} }, - CorePair { .name = "list", .func = CorePairData {.FVar = &list} }, - CorePair { .name = "vector", .func = CorePairData {.FVar = &vector} }, - CorePair { .name = "map", .func = CorePairData {.FVar = &map} }, - CorePair { .name = "empty?", .func = CorePairData {.Fn1 = &empty} }, - CorePair { .name = "prn", .func = CorePairData {.FVar = &prn} }, - CorePair { .name = "println", .func = CorePairData {.FVar = &println} }, - CorePair { .name = "pr-str", .func = CorePairData {.FVar = &pr_str} }, - CorePair { .name = "str", .func = CorePairData {.FVar = &str} }, - CorePair { .name = "slurp", .func = CorePairData {.Fn1 = &slurp} }, - CorePair { .name = "atom", .func = CorePairData {.Fn1 = &atom} }, - CorePair { .name = "atom?", .func = CorePairData {.Fn1 = &is_atom} }, - CorePair { .name = "deref", .func = CorePairData {.Fn1 = &deref} }, - CorePair { .name = "reset!", .func = CorePairData {.Fn2 = &atom_reset} }, - CorePair { .name = "swap!", .func = CorePairData {.FVar = &atom_swap} }, - CorePair { .name = "vec", .func = CorePairData {.Fn1 = &vec} }, - CorePair { .name = "cons", .func = CorePairData {.Fn2 = &cons} }, - CorePair { .name = "concat", .func = CorePairData {.FVar = &concat} }, - CorePair { .name = "rest", .func = CorePairData {.Fn1 = &rest } }, - CorePair { .name = "nth", .func = CorePairData {.Fn2 = &nth } }, - CorePair { .name = "first", .func = CorePairData {.Fn1 = &first } }, - CorePair { .name = "nil?", .func = CorePairData {.Fn1 = &is_nil } }, - CorePair { .name = "true?", .func = CorePairData {.Fn1 = &is_true } }, - CorePair { .name = "false?", .func = CorePairData {.Fn1 = &is_false } }, - CorePair { .name = "symbol", .func = CorePairData {.Fn1 = &symbol } }, - CorePair { .name = "symbol?", .func = CorePairData {.Fn1 = &is_symbol } }, - CorePair { .name = "keyword?", .func = CorePairData {.Fn1 = &is_keyword } }, - CorePair { .name = "map?", .func = CorePairData {.Fn1 = &is_map } }, - CorePair { .name = "sequential?", .func = CorePairData {.Fn1 = &is_sequential } }, - CorePair { .name = "apply", .func = CorePairData {.FVar = &do_apply } }, - CorePair { .name = "hash-map", .func = CorePairData {.FVar = &hash_map } }, - CorePair { .name = "assoc", .func = CorePairData {.FVar = &hash_map_assoc } }, - CorePair { .name = "dissoc", .func = CorePairData {.FVar = &hash_map_dissoc } }, - CorePair { .name = "get", .func = CorePairData {.Fn2 = &hash_map_get } }, - CorePair { .name = "contains?", .func = CorePairData {.Fn2 = &hash_map_contains } }, - CorePair { .name = "keys", .func = CorePairData {.Fn1 = &hash_map_keys } }, - CorePair { .name = "vals", .func = CorePairData {.Fn1 = &hash_map_vals } }, - CorePair { .name = "keyword", .func = CorePairData {.Fn1 = &keyword } }, - CorePair { .name = "read-string", .func = CorePairData {.Fn1 = &read_string } }, - CorePair { .name = "readline", .func = CorePairData {.Fn1 = &readline } }, - CorePair { .name = "time-ms", .func = CorePairData {.Fn0 = &time_ms } }, - CorePair { .name = "meta", .func = CorePairData {.Fn1 = &meta } }, - CorePair { .name = "with-meta", .func = CorePairData {.Fn2 = &with_meta } }, - CorePair { .name = "fn?", .func = CorePairData {.Fn1 = &is_fn } }, - CorePair { .name = "string?", .func = CorePairData {.Fn1 = &is_string } }, - CorePair { .name = "number?", .func = CorePairData {.Fn1 = &is_number } }, - CorePair { .name = "macro?", .func = CorePairData {.Fn1 = &is_macro } }, - CorePair { .name = "seq", .func = CorePairData {.Fn1 = &seq } }, - CorePair { .name = "conj", .func = CorePairData {.FVar = &conj } }, -}; +const std = @import("std"); +const warn = @import("std").debug.warn; + +const AllocatorType = @import("std").mem.Allocator; +var Allocator: *AllocatorType = undefined; + +pub fn set_allocator(alloc: *AllocatorType) void { + Allocator = alloc; +} + +const Env = @import("env.zig").Env; +const MalData = @import("types.zig").MalData; +const MalType = @import("types.zig").MalType; +const MalTypeValue = @import("types.zig").MalTypeValue; +const printer = @import("printer.zig"); +const reader = @import("reader.zig"); +const getline_prompt = @import("readline.zig").getline_prompt; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; + +const MalError = @import("error.zig").MalError; + +const hmap = @import("hmap.zig"); + +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const MalHashMap = @import("hmap.zig").MalHashMap; +const linked_list = @import("linked_list.zig"); +const apply_function = @import("types.zig").apply_function; + +const safeAdd = @import("std").math.add; +const safeSub = @import("std").math.sub; +const safeMul = @import("std").math.mul; +const safeDivFloor = @import("std").math.divFloor; + +fn int_plus(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeAdd(i64, x, y) catch return MalError.Overflow; + return MalType.new_int(Allocator, res); +} + +fn int_minus(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeSub(i64, x, y) catch return MalError.Overflow; + return MalType.new_int(Allocator, res); +} + +fn int_mult(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeMul(i64, x, y) catch return MalError.Overflow; + return MalType.new_int(Allocator, res); +} + +fn int_div(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeDivFloor(i64, x, y) catch |err| switch(err) { + error.DivisionByZero => return MalError.DivisionByZero, + else => return MalError.Overflow, + }; + return MalType.new_int(Allocator, res); +} + +fn int_lt(a1: *MalType, a2: *MalType) MalError!*MalType { + return MalType.new_bool(Allocator, (try a1.as_int()) < (try a2.as_int())); +} + +fn int_leq(a1: *MalType, a2: *MalType) MalError!*MalType { + return MalType.new_bool(Allocator, (try a1.as_int()) <= (try a2.as_int())); +} + +fn int_gt(a1: *MalType, a2: *MalType) MalError!*MalType { + return MalType.new_bool(Allocator, (try a1.as_int()) > (try a2.as_int())); +} + +fn int_geq(a1: *MalType, a2: *MalType) MalError!*MalType { + return MalType.new_bool(Allocator, (try a1.as_int()) >= (try a2.as_int())); +} + +fn _linked_list_equality(l1: MalLinkedList, l2: MalLinkedList) MalError!bool { + if(l1.count() != l2.count()) { + return false; + } + var it1 = l1.iterator(); + var it2 = l2.iterator(); + while(true) { + const m1 = it1.next() orelse return (it2.next() == null); + const m2 = it2.next() orelse return false; + const el_cmp = try equality(m1, m2); + if(MalTypeValue(el_cmp.data) == MalTypeValue.False) { + el_cmp.delete(Allocator); + return false; + } + el_cmp.delete(Allocator); + } + return true; +} + +fn _hashmap_equality(h1: MalHashMap, h2: MalHashMap) MalError!bool { + if(h1.count() != h2.count()) { + return false; + } + + var iterator = h1.iterator(); + var optional_pair = iterator.next(); + while(optional_pair) |pair| { + const optional_val = h2.getValue(pair.key); + if(optional_val) |val| { + const el_cmp = try equality(pair.value, val); + if(MalTypeValue(el_cmp.data) == MalTypeValue.False) { + el_cmp.delete(Allocator); + return false; + } + el_cmp.delete(Allocator); + } + else { + return false; + } + optional_pair = iterator.next(); + } + return true; +} + +// TODO: make _equality -> bool +fn equality(a1: *MalType, a2: *MalType) MalError!*MalType { + const a1_is_sequential = (MalTypeValue(a1.data) == MalTypeValue.List) or + (MalTypeValue(a1.data) == MalTypeValue.Vector); + const a2_is_sequential = (MalTypeValue(a2.data) == MalTypeValue.List) or + (MalTypeValue(a2.data) == MalTypeValue.Vector); + + if(a1_is_sequential and a2_is_sequential) { + const l1 = (try a1.sequence_linked_list()).*; + const l2 = (try a2.sequence_linked_list()).*; + return MalType.new_bool(Allocator, try _linked_list_equality(l1, l2)); + } + + if(MalTypeValue(a1.data) != MalTypeValue(a2.data)) { + return MalType.new_bool(Allocator, false); + } + + switch(a1.data) { + .True, .False, .Nil => { + return MalType.new_bool(Allocator, true); + }, + .Int => |v1| { + return MalType.new_bool(Allocator, v1 == a2.data.Int); + }, + .List => |l1| { + const l2 = a2.data.List; + return MalType.new_bool(Allocator, try _linked_list_equality(l1, l2)); + }, + .Vector => |v1| { + const v2 = a2.data.Vector; + return MalType.new_bool(Allocator, try _linked_list_equality(v1, v2)); + }, + .String => |s1| { + const s2 = a2.data.String; + return MalType.new_bool(Allocator, string_eql(s1, s2)); + }, + .Generic => |v1| { + const v2 = a2.data.Generic; + return MalType.new_bool(Allocator, string_eql(v1, v2)); + }, + .Keyword => |k1| { + const k2 = a2.data.Keyword; + return MalType.new_bool(Allocator, string_eql(k1, k2)); + }, + .HashMap => |h1| { + const h2 = a2.data.HashMap; + return MalType.new_bool(Allocator, try _hashmap_equality(h1,h2)); + }, + // TODO: implement more types + else => return MalType.new_bool(Allocator, false), + } +} + +fn list(args: MalLinkedList) MalError!*MalType { + var new_mal = try MalType.new_list_empty(Allocator); + new_mal.data = MalData{.List = try linked_list.deepcopy(Allocator, args)}; + return new_mal; +} + +fn vector(args: MalLinkedList) MalError!*MalType { + var new_mal = try MalType.new_list_empty(Allocator); + new_mal.data = MalData{.Vector = try linked_list.deepcopy(Allocator, args)}; + return new_mal; +} + +fn map(args: MalLinkedList) MalError!*MalType { + if(args.count() < 2) return MalError.ArgError; + const func_mal = args.at(0); + var args_mal = args.at(1); + var new_ll = MalLinkedList.init(Allocator); + var to_map_ll = try args_mal.sequence_linked_list(); + + var iterator = to_map_ll.iterator(); + while(iterator.next()) |mal| { + var args_ll = MalLinkedList.init(Allocator); + // TODO: can be more efficient than this + try linked_list.append_mal(Allocator, &args_ll, try func_mal.copy(Allocator)); + try linked_list.append_mal(Allocator, &args_ll, try mal.copy(Allocator)); + const new_mal = try apply_function(Allocator, args_ll); + linked_list.destroy(Allocator, &args_ll, false); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + const new_list = try MalType.new_nil(Allocator); + new_list.data = MalData{.List = new_ll}; + return new_list; +} + +fn is_list(a1: *MalType) MalError!*MalType { + return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.List); +} + +fn is_vector(a1: *MalType) MalError!*MalType { + return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.Vector); +} + +pub fn is_string(a1: *MalType) MalError!*MalType { + return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.String); +} + +pub fn is_number(a1: *MalType) MalError!*MalType { + return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.Int); +} + +pub fn is_fn(a1: *MalType) MalError!*MalType { + const is_function = switch(a1.data) { + .Fn0 => true, + .Fn1 => true, + .Fn2 => true, + .Fn3 => true, + .Fn4 => true, + .FVar => true, + .Func => |func_data| !func_data.is_macro, + else => false, + }; + return MalType.new_bool(Allocator, is_function); +} + +pub fn is_macro(a1: *MalType) MalError!*MalType { + const is_func_and_macro = switch(a1.data) { + .Func => |data| data.is_macro, + else => false, + }; + return MalType.new_bool(Allocator, is_func_and_macro); +} + +fn empty(a1: *MalType) MalError!*MalType { + return switch(a1.data) { + .List => |l| MalType.new_bool(Allocator, l.len == 0), + .Vector => |v| MalType.new_bool(Allocator, v.len == 0), + else => MalType.new_bool(Allocator, false), + }; +} + +fn prn(args: MalLinkedList) MalError!*MalType { + const s = try printer.print_mal_to_string(args, true, true); + const stdout_file = std.io.getStdOut() catch return MalError.SystemError; + stdout_file.write(s) catch return MalError.SystemError; + stdout_file.write("\n") catch return MalError.SystemError; + Allocator.free(s); + const mal = try MalType.new_nil(Allocator); + return mal; +} + +fn println(args: MalLinkedList) MalError!*MalType { + const s = try printer.print_mal_to_string(args, false, true); + const stdout_file = std.io.getStdOut() catch return MalError.SystemError; + stdout_file.write(s) catch return MalError.SystemError; + stdout_file.write("\n") catch return MalError.SystemError; + Allocator.free(s); + const mal = try MalType.new_nil(Allocator); + return mal; +} + +fn str(args: MalLinkedList) MalError!*MalType { + if(args.count() == 0) { + const s: []u8 = ""; + return MalType.new_string(Allocator, s); + } + const s = try printer.print_mal_to_string(args, false, false); + return MalType.new_string(Allocator, s); +} + +fn pr_str(args: MalLinkedList) MalError!*MalType { + if(args.count() == 0) { + const s: []u8 = ""; + return MalType.new_string(Allocator, s); + } + const s = try printer.print_mal_to_string(args, true, true); + return MalType.new_string(Allocator, s); +} + +fn slurp(a1: *MalType) MalError!*MalType { + switch(a1.data) { + .String => |path| { + const file_contents = std.io.readFileAlloc(Allocator, path) + catch |err| return MalError.SystemError; // TODO: change this error + defer Allocator.free(file_contents); + return MalType.new_string(Allocator, file_contents); + }, + else => { + return MalError.TypeError; + }, + } + return unreachable; +} + +fn atom(a1: *MalType) MalError!*MalType { + return MalType.new_atom(Allocator, a1); +} + +fn is_atom(a1: *MalType) MalError!*MalType { + return MalType.new_bool(Allocator, MalTypeValue(a1.data) == MalTypeValue.Atom); +} + +fn deref(a1: *MalType) MalError!*MalType { + return switch(a1.data) { + .Atom => |atom_val| atom_val.*.copy(Allocator), + else => MalError.TypeError, + }; +} + +fn atom_reset(a1: *MalType, a2: *MalType) MalError!*MalType { + switch(a1.data) { + .Atom => |*atom_val| { + var new_target = try a2.copy(Allocator); + atom_val.*.*.delete(Allocator); + atom_val.*.* = new_target; + return new_target.copy(Allocator); + }, + else => return MalError.TypeError, + } +} + +fn atom_swap(args: MalLinkedList) MalError!*MalType { + const args_arr = args.toSlice(); + const n = args.len; + if(n < 2) return MalError.ArgError; + var new_args = MalLinkedList.init(Allocator); + defer linked_list.destroy(Allocator, &new_args, false); + try linked_list.append_mal(Allocator, &new_args, try args_arr[1].copy(Allocator)); + try linked_list.append_mal(Allocator, &new_args, try deref(args_arr[0])); + var i: usize = 2; + while(i < n) { + try linked_list.append_mal(Allocator, &new_args, try args_arr[i].copy(Allocator)); + i += 1; + } + const return_mal = try apply_function(Allocator, new_args); + const new_mal = atom_reset(args_arr[0], return_mal); + return_mal.delete(Allocator); + return new_mal; +} + +pub fn vec(a1: *const MalType) MalError!*MalType { + const ll = switch(a1.data) { + .List => |l| l, + .Vector => |v| v, + else => return MalError.TypeError, + }; + const copy = try linked_list.deepcopy(Allocator, ll); + return MalType.new_vector(Allocator, copy); +} + +pub fn cons(a1: *const MalType, a2: *const MalType) MalError!*MalType { + // TODO: do we need this for vectors? + const old_ll = try a2.const_sequence_linked_list(); + var new_ll = try linked_list.deepcopy(Allocator, old_ll); + var new_list = try MalType.new_nil(Allocator); + new_list.data = MalData{.List = new_ll}; + errdefer new_list.delete(Allocator); + var new_mal = try a1.copy(Allocator); + errdefer new_mal.delete(Allocator); + try linked_list.prepend_mal(Allocator, &new_list.data.List, new_mal); + return new_list; +} + +pub fn concat(args: MalLinkedList) MalError!*MalType { + // First we make a new array with shallow copies + var new_ll = MalLinkedList.init(Allocator); + errdefer linked_list.destroy(Allocator, &new_ll, false); + var iterator = args.iterator(); + while(iterator.next()) |mal| { + const mal_seq = try mal.sequence_linked_list(); + new_ll.appendSlice(mal_seq.toSlice()) catch return MalError.SystemError; + } + + // Now we turn the shallow copies into deep copies + const new_arr = new_ll.toSlice(); + var i: usize = 0; + while(i < new_arr.len) { + new_arr[i] = try new_arr[i].copy(Allocator); + i += 1; + } + + // Wrap the list in a MalType, return + var new_mal = try MalType.new_nil(Allocator); + new_mal.data = MalData{.List = new_ll}; + return new_mal; +} + +pub fn rest(a1: *const MalType) MalError!*MalType { + var old_list = switch(a1.data) { + .List => |l| l, + .Vector => |v| v, + .Nil => return MalType.new_list_empty(Allocator), + else => return MalError.TypeError, + }; + var new_list = try linked_list.deepcopy(Allocator, old_list); + errdefer linked_list.destroy(Allocator, &new_list, false); + + if(new_list.count() > 0) { + const mal = try linked_list.pop_first(Allocator, &new_list); + mal.delete(Allocator); + } + var new_mal = try MalType.new_nil(Allocator); + new_mal.data = MalData{.List = new_list}; + return new_mal; +} + +pub fn _nth(mal_list: *const MalType, pos: i64) MalError!*MalType { + // TODO: vectors? + const l = try mal_list.const_sequence_linked_list(); + if(pos < 0 or pos >= @intCast(i64,l.count())) { + return MalError.OutOfBounds; + } + return l.at(@intCast(usize,pos)); +} + +pub fn nth(a1: *const MalType, a2: *const MalType) MalError!*MalType { + return switch(a2.data) { + .Int => |pos| (try _nth(a1, pos)).copy(Allocator), + else => MalError.TypeError, + }; +} + +pub fn first(a1: *const MalType) MalError!*MalType { + var l = switch(a1.data) { + .List => |l| l, + .Vector => |v| v, + .Nil => return MalType.new_nil(Allocator), + else => return MalError.TypeError, + }; + if(l.count() == 0) return MalType.new_nil(Allocator); + return l.at(0).copy(Allocator); +} + +fn check_type(mal: *const MalType, value_type: MalTypeValue) MalError!*MalType { + // TODO: use this everywhere + // TODO: do this more generically + return MalType.new_bool(Allocator, MalTypeValue(mal.data) == value_type); +} + +pub fn is_nil(a1: *const MalType) MalError!*MalType { + return check_type(a1, MalTypeValue.Nil); +} + +pub fn is_true(a1: *const MalType) MalError!*MalType { + return check_type(a1, MalTypeValue.True); +} + +pub fn is_false(a1: *const MalType) MalError!*MalType { + return check_type(a1, MalTypeValue.False); +} + +pub fn is_symbol(a1: *const MalType) MalError!*MalType { + return check_type(a1, MalTypeValue.Generic); +} + +pub fn is_keyword(a1: *const MalType) MalError!*MalType { + return check_type(a1, MalTypeValue.Keyword); +} + +pub fn is_map(a1: *const MalType) MalError!*MalType { + return check_type(a1, MalTypeValue.HashMap); +} + +pub fn is_sequential(a1: *const MalType) MalError!*MalType { + const res = (MalTypeValue(a1.data) == MalTypeValue.Vector) or + (MalTypeValue(a1.data) == MalTypeValue.List); + return MalType.new_bool(Allocator, res); +} + +pub fn symbol(a1: *const MalType) MalError!*MalType { + const string = switch(a1.data) { + .String => |s| s, + else => return MalError.TypeError, + }; + return MalType.new_generic(Allocator, string); +} + +pub fn hash_map(args: MalLinkedList) MalError!*MalType { + const new_mal = try MalType.new_hashmap(Allocator); + const args_arr = args.toSlice(); + const n = args_arr.len; + if((n%2) != 0) return MalError.ArgError; + var i: usize = 0; + + while(2*i+1 < n) { + const this_key = switch(args_arr[2*i].data) { + .String => |s| s, + .Keyword => |kwd| kwd, + else => return MalError.ArgError, + }; + const this_key_cpy = string_copy(Allocator, this_key) catch return MalError.SystemError; + const this_val_cpy = try args_arr[2*i+1].copy(Allocator); + try new_mal.hashmap_insert(this_key_cpy, this_val_cpy); + i += 1; + } + return new_mal; +} + +pub fn hash_map_assoc(args: MalLinkedList) MalError!*MalType { + const args_arr = args.toSlice(); + if(args_arr.len < 1) return MalError.ArgError; + const new_mal = try MalType.new_nil(Allocator); + errdefer new_mal.delete(Allocator); + const base_hmap = switch(args_arr[0].data) { + .HashMap => |hm| hm, + else => return MalError.TypeError, + }; + const hmap_cpy = hmap.deepcopy(Allocator, base_hmap) catch return MalError.SystemError; + new_mal.data = MalData {.HashMap = hmap_cpy}; + + const assoc_arr = args_arr[1..args_arr.len]; + if((assoc_arr.len % 2) != 0) return MalError.ArgError; + var i: usize = 0; + while(2*i+1 < assoc_arr.len) { + const this_key = switch(assoc_arr[2*i].data) { + .String => |s| s, + .Keyword => |kwd| kwd, + else => return MalError.ArgError, + }; + const this_key_cpy = string_copy(Allocator, this_key) catch return MalError.SystemError; + const this_val_cpy = try assoc_arr[2*i+1].copy(Allocator); + try new_mal.hashmap_insert(this_key_cpy, this_val_cpy); + i += 1; + } + return new_mal; +} + +pub fn hash_map_dissoc(args: MalLinkedList) MalError!*MalType { + const args_arr = args.toSlice(); + if(args_arr.len < 1) return MalError.ArgError; + const new_mal = try MalType.new_nil(Allocator); + errdefer new_mal.delete(Allocator); + const base_hmap = switch(args_arr[0].data) { + .HashMap => |hm| hm, + else => return MalError.TypeError, + }; + const hmap_cpy = hmap.deepcopy(Allocator, base_hmap) catch return MalError.SystemError; + new_mal.data = MalData {.HashMap = hmap_cpy}; + + var i: usize = 1; + while(i < args_arr.len) { + const this_key = switch(args_arr[i].data) { + .String => |s| s, + .Keyword => |kwd| kwd, + else => return MalError.ArgError, + }; + try new_mal.hashmap_remove(this_key); + i += 1; + } + return new_mal; +} + +pub fn hash_map_get(a1: *MalType, a2: *MalType) MalError!*MalType { + const key = switch(a2.data) { + .String => |s| s, + .Keyword => |kwd| kwd, + else => return MalError.TypeError, + }; + const optional_val = try a1.hashmap_get(key); + if(optional_val) |val| { + return val.copy(Allocator); + } + else return MalType.new_nil(Allocator); +} + +pub fn hash_map_contains(a1: *MalType, a2: *MalType) MalError!*MalType { + const key = switch(a2.data) { + .String => |s| s, + .Keyword => |kwd| kwd, + else => return MalError.TypeError, + }; + const contains_bool = try a1.hashmap_contains(key); + return MalType.new_bool(Allocator, contains_bool); +} + +pub fn hash_map_keys(a1: *MalType) MalError!*MalType { + const hm = switch(a1.data) { + .HashMap => |h| h, + else => return MalError.TypeError, + }; + var new_ll = MalLinkedList.init(Allocator); + errdefer linked_list.destroy(Allocator, &new_ll, false); + var iterator = hm.iterator(); + var optional_pair = iterator.next(); + + while(true) { + const pair = optional_pair orelse break; + const key = string_copy(Allocator, pair.key) catch return MalError.SystemError; + + var key_mal: *MalType = undefined; + if(key.len > 1 and key[0] == 255) { + key_mal = try MalType.new_keyword(Allocator, key[1..key.len]); + } else { + key_mal = try MalType.new_string(Allocator, key); + } + try linked_list.append_mal(Allocator, &new_ll, key_mal); + optional_pair = iterator.next(); + } + var new_mal = try MalType.new_nil(Allocator); + new_mal.data = MalData{.List = new_ll}; + return new_mal; +} + +pub fn hash_map_vals(a1: *MalType) MalError!*MalType { + const hm = switch(a1.data) { + .HashMap => |h| h, + else => return MalError.TypeError, + }; + var new_ll = MalLinkedList.init(Allocator); + errdefer linked_list.destroy(Allocator, &new_ll, false); + var iterator = hm.iterator(); + var optional_pair = iterator.next(); + + while(true) { + const pair = optional_pair orelse break; + const val = try pair.value.copy(Allocator); + try linked_list.append_mal(Allocator, &new_ll, val); + optional_pair = iterator.next(); + } + var new_mal = try MalType.new_nil(Allocator); + new_mal.data = MalData{.List = new_ll}; + return new_mal; +} + +pub fn sequence_length(a1: *MalType) MalError!*MalType { + const len = switch(a1.data) { + .List => |l| l.count(), + .Vector => |v| v.count(), + .String => |s| s.len, + .Nil => 0, + else => return MalError.TypeError, + }; + return MalType.new_int(Allocator, @intCast(i64,len)); +} + +pub fn keyword(a1: *MalType) MalError!*MalType { + const kwd = switch(a1.data) { + .String => |s| s, + .Keyword => |k| return a1.copy(Allocator), + else => return MalError.TypeError, + }; + return MalType.new_keyword(Allocator, kwd); +} + +pub fn readline(a1: *MalType) MalError!*MalType { + const prompt = try a1.as_string(); + const optional_read_line = getline_prompt(Allocator, prompt) + catch return MalError.SystemError; + if(optional_read_line) |read_line| { + return MalType.new_string(Allocator, read_line); + } + const mal = try MalType.new_nil(Allocator); + return MalType.new_nil(Allocator); +} + +pub fn time_ms() MalError!*MalType { + const itime: i64 = @intCast(i64, std.time.milliTimestamp()); + return MalType.new_int(Allocator, itime); +} + +pub fn meta(a1: *MalType) MalError!*MalType { + if(a1.meta) |mal_meta| { + return mal_meta.copy(Allocator); + } + return MalType.new_nil(Allocator); +} + +pub fn with_meta(a1: *MalType, a2: *MalType) MalError!*MalType { + var new_mal = try a1.copy(Allocator); + if(new_mal.meta) |mal_meta| { + mal_meta.delete(Allocator); + } + new_mal.meta = try a2.copy(Allocator); + return new_mal; +} + +pub fn seq(a1: *MalType) MalError!*MalType { + switch(a1.data) { + .List => |l| { + if(l.count() == 0) return MalType.new_nil(Allocator); + return a1.copy(Allocator); + }, + .Vector => |v| { + if(v.count() == 0) return MalType.new_nil(Allocator); + const mal_copy = try a1.copy(Allocator); + const ll = mal_copy.data.Vector; + mal_copy.data = MalData{.List = ll}; + return mal_copy; + }, + .String => |s| { + if(s.len == 0) return MalType.new_nil(Allocator); + const new_list = try MalType.new_list_empty(Allocator); + for(s) |letter| { + const new_char = try MalType.new_string(Allocator, [_]u8 {letter}); + try new_list.sequence_append(Allocator, new_char); + } + return new_list; + }, + .Nil => { + return MalType.new_nil(Allocator); + }, + else => { + return MalError.TypeError; + } + } + return MalType.new_nil(Allocator); +} + +pub fn conj(args: MalLinkedList) MalError!*MalType { + var iterator = args.iterator(); + const container = iterator.next() orelse return MalError.ArgError; + const append = switch(container.data) { + .List => false, + .Vector => true, + else => return MalError.ArgError, + }; + + var return_mal = try container.copy(Allocator); + while(iterator.next()) |mal| { + const mal_copy = try mal.copy(Allocator); + if(append) { + try return_mal.sequence_append(Allocator, mal_copy); + } else { + try return_mal.sequence_prepend(Allocator, mal_copy); + } + } + return return_mal; +} + +fn read_string(a1: *MalType) MalError!*MalType { + const str_to_eval = try a1.as_string(); + var read = try reader.read_str(str_to_eval); + return (try reader.read_form(&read)) orelse return MalType.new_nil(Allocator); +} + +pub fn do_apply(args: MalLinkedList) MalError!*MalType { + // TODO: not always safe to delete new_ll here + if(args.count() == 0) return MalError.ArgError; + var args_copy = args; + const list_node = args_copy.pop(); + const list_ll = try list_node.sequence_linked_list(); + var new_ll = try linked_list.deepcopy(Allocator, list_ll.*); + defer linked_list.destroy(Allocator, &new_ll, false); + var optional_node = args_copy.popOrNull(); + while(optional_node) |node| { + try linked_list.prepend_mal(Allocator, &new_ll, try node.copy(Allocator)); + optional_node = args_copy.popOrNull(); + } + var return_mal = apply_function(Allocator, new_ll); + return return_mal; +} + +pub const CorePairType = enum { + Fn0, + Fn1, + Fn2, + Fn3, + Fn4, + FVar, +}; + +pub const CorePairData = union(CorePairType) { + Fn0: *const fn() MalError!*MalType, + Fn1: *const fn(a1: *MalType) MalError!*MalType, + Fn2: *const fn(a1: *MalType, a2: *MalType) MalError!*MalType, + Fn3: *const fn(a1: *MalType, a2: *MalType, a3: *MalType) MalError!*MalType, + Fn4: *const fn(a1: *MalType, a2: *MalType, a3: *MalType, a4: *MalType) MalError!*MalType, + FVar: *const fn(args: MalLinkedList) MalError!*MalType, +}; + +pub const CorePair = struct { + name: []const u8, + func: CorePairData, +}; + +pub const core_namespace = [_] CorePair { + CorePair { .name = "+", .func = CorePairData {.Fn2 = &int_plus} }, + CorePair { .name = "-", .func = CorePairData {.Fn2 = &int_minus} }, + CorePair { .name = "*", .func = CorePairData {.Fn2 = &int_mult} }, + CorePair { .name = "/", .func = CorePairData {.Fn2 = &int_div} }, + CorePair { .name = "<", .func = CorePairData {.Fn2 = &int_lt} }, + CorePair { .name = "<=", .func = CorePairData {.Fn2 = &int_leq} }, + CorePair { .name = ">", .func = CorePairData {.Fn2 = &int_gt} }, + CorePair { .name = ">=", .func = CorePairData {.Fn2 = &int_geq} }, + CorePair { .name = "=", .func = CorePairData {.Fn2 = &equality} }, + CorePair { .name = "list?", .func = CorePairData {.Fn1 = &is_list} }, + CorePair { .name = "vector?", .func = CorePairData {.Fn1 = &is_vector} }, + CorePair { .name = "count", .func = CorePairData {.Fn1 = &sequence_length} }, + CorePair { .name = "list", .func = CorePairData {.FVar = &list} }, + CorePair { .name = "vector", .func = CorePairData {.FVar = &vector} }, + CorePair { .name = "map", .func = CorePairData {.FVar = &map} }, + CorePair { .name = "empty?", .func = CorePairData {.Fn1 = &empty} }, + CorePair { .name = "prn", .func = CorePairData {.FVar = &prn} }, + CorePair { .name = "println", .func = CorePairData {.FVar = &println} }, + CorePair { .name = "pr-str", .func = CorePairData {.FVar = &pr_str} }, + CorePair { .name = "str", .func = CorePairData {.FVar = &str} }, + CorePair { .name = "slurp", .func = CorePairData {.Fn1 = &slurp} }, + CorePair { .name = "atom", .func = CorePairData {.Fn1 = &atom} }, + CorePair { .name = "atom?", .func = CorePairData {.Fn1 = &is_atom} }, + CorePair { .name = "deref", .func = CorePairData {.Fn1 = &deref} }, + CorePair { .name = "reset!", .func = CorePairData {.Fn2 = &atom_reset} }, + CorePair { .name = "swap!", .func = CorePairData {.FVar = &atom_swap} }, + CorePair { .name = "vec", .func = CorePairData {.Fn1 = &vec} }, + CorePair { .name = "cons", .func = CorePairData {.Fn2 = &cons} }, + CorePair { .name = "concat", .func = CorePairData {.FVar = &concat} }, + CorePair { .name = "rest", .func = CorePairData {.Fn1 = &rest } }, + CorePair { .name = "nth", .func = CorePairData {.Fn2 = &nth } }, + CorePair { .name = "first", .func = CorePairData {.Fn1 = &first } }, + CorePair { .name = "nil?", .func = CorePairData {.Fn1 = &is_nil } }, + CorePair { .name = "true?", .func = CorePairData {.Fn1 = &is_true } }, + CorePair { .name = "false?", .func = CorePairData {.Fn1 = &is_false } }, + CorePair { .name = "symbol", .func = CorePairData {.Fn1 = &symbol } }, + CorePair { .name = "symbol?", .func = CorePairData {.Fn1 = &is_symbol } }, + CorePair { .name = "keyword?", .func = CorePairData {.Fn1 = &is_keyword } }, + CorePair { .name = "map?", .func = CorePairData {.Fn1 = &is_map } }, + CorePair { .name = "sequential?", .func = CorePairData {.Fn1 = &is_sequential } }, + CorePair { .name = "apply", .func = CorePairData {.FVar = &do_apply } }, + CorePair { .name = "hash-map", .func = CorePairData {.FVar = &hash_map } }, + CorePair { .name = "assoc", .func = CorePairData {.FVar = &hash_map_assoc } }, + CorePair { .name = "dissoc", .func = CorePairData {.FVar = &hash_map_dissoc } }, + CorePair { .name = "get", .func = CorePairData {.Fn2 = &hash_map_get } }, + CorePair { .name = "contains?", .func = CorePairData {.Fn2 = &hash_map_contains } }, + CorePair { .name = "keys", .func = CorePairData {.Fn1 = &hash_map_keys } }, + CorePair { .name = "vals", .func = CorePairData {.Fn1 = &hash_map_vals } }, + CorePair { .name = "keyword", .func = CorePairData {.Fn1 = &keyword } }, + CorePair { .name = "read-string", .func = CorePairData {.Fn1 = &read_string } }, + CorePair { .name = "readline", .func = CorePairData {.Fn1 = &readline } }, + CorePair { .name = "time-ms", .func = CorePairData {.Fn0 = &time_ms } }, + CorePair { .name = "meta", .func = CorePairData {.Fn1 = &meta } }, + CorePair { .name = "with-meta", .func = CorePairData {.Fn2 = &with_meta } }, + CorePair { .name = "fn?", .func = CorePairData {.Fn1 = &is_fn } }, + CorePair { .name = "string?", .func = CorePairData {.Fn1 = &is_string } }, + CorePair { .name = "number?", .func = CorePairData {.Fn1 = &is_number } }, + CorePair { .name = "macro?", .func = CorePairData {.Fn1 = &is_macro } }, + CorePair { .name = "seq", .func = CorePairData {.Fn1 = &seq } }, + CorePair { .name = "conj", .func = CorePairData {.FVar = &conj } }, +}; diff --git a/impls/zig/env.zig b/impls/zig/env.zig index 18d1f15724..ed3604ae90 100644 --- a/impls/zig/env.zig +++ b/impls/zig/env.zig @@ -1,160 +1,160 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; -const Allocator = @import("std").mem.Allocator; - -const string_copy = @import("utils.zig").string_copy; -const string_eql = @import("utils.zig").string_eql; -const MalType = @import("types.zig").MalType; -const MalTypeValue = @import("types.zig").MalTypeValue; -const MalHashMap = @import("hmap.zig").MalHashMap; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const MalError = @import("error.zig").MalError; -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); - -pub const Env = struct { - outer: ?**Env, - data: *MalHashMap, - allocator: *Allocator, - refcount: *i32, - - pub fn new(allocator: *Allocator, optional_outer: ?*Env) MalError!*Env { - const env = allocator.create(Env) catch return MalError.SystemError; - env.refcount = allocator.create(i32) catch return MalError.SystemError; - env.refcount.* = 1; - if(optional_outer) |outer| { - const env_ptr = allocator.create(*Env) catch return MalError.SystemError; - env_ptr.* = try outer.copy(allocator); - env.outer = env_ptr; - } else { - env.outer = null; - } - env.data = allocator.create(MalHashMap) catch return MalError.SystemError; - env.data.* = MalHashMap.init(allocator); - env.allocator = allocator; - return env; - } - - pub fn copy(env: *Env, allocator: *Allocator) MalError!*Env { - const new_env = allocator.create(Env) catch return MalError.SystemError; - new_env.refcount = env.refcount; - env.refcount.* += 1; - new_env.outer = env.outer; - new_env.data = env.data; - new_env.allocator = allocator; - return new_env; - } - - pub fn delete(env: *Env) void { - env.refcount.* -= 1; - if(env.refcount.* <= 0) { - if(env.outer) |*outer| { - outer.*.*.delete(); - env.allocator.destroy(env.outer.?); - } - //env.print_keys(); - hash_map.destroy(env.allocator, env.data.*, false); - env.allocator.destroy(env.refcount); - env.allocator.destroy(env.data); - } - env.allocator.destroy(env); - } - - pub fn set(env: *Env, key: []const u8, value: *MalType) MalError!void { - const optional_prev_mal = env.data.getValue(key); - if(optional_prev_mal) |prev_mal| { - prev_mal.delete(env.allocator); - } - //warn("Setting {}\n", key); - const key_copy = string_copy(env.allocator, key) catch return MalError.SystemError; - _ = env.data.put(key_copy, value) catch return MalError.SystemError; - } - - pub fn root_set(env: *Env, key: []const u8, value: *MalType) MalError!void { - var root_env = env; - while(true) { - const outer_ptr = root_env.outer orelse break; - root_env = outer_ptr.*; - } - try root_env.set(key, value); - } - - pub fn find(env: *const Env, key: []const u8) bool { - const optional_mal = env.data.getValue(key); - if(optional_mal) |mal| { - return true; - } - if(env.outer) |outer| { - return outer.*.find(key); - } - return false; - } - - pub fn get(env: *const Env, key: []const u8) MalError!*MalType { - const optional_mal = env.data.getValue(key); - if(optional_mal) |mal| { - //warn("Got for key '{}': {} (me: {})\n", key, mal, @ptrToInt(env)); - return mal; - } - if(env.outer) |outer| { - return outer.*.get(key); - } - return MalError.EnvLookupError; - } - - pub fn set_list(env: *Env, names: MalLinkedList, vals: MalLinkedList) MalError!void { - var name_arr = names.toSlice(); - var vals_arr = vals.toSlice(); - var i: usize = 0; - - while(i < name_arr.len) { - const key = try name_arr[i].as_symbol(); - if(!string_eql(key, "&")) { - try env.set(key, vals_arr[i]); - i += 1; - continue; - } - - // Here we deal with variadic binding - if(i+1 >= name_arr.len) return MalError.OutOfBounds; - const var_key = try name_arr[i+1].as_symbol(); - var new_ll = MalLinkedList.init(env.allocator); - new_ll.appendSlice(vals_arr[i..vals_arr.len]) catch return MalError.SystemError; - const new_mal = try MalType.new_list(env.allocator, new_ll); - try env.set(var_key, new_mal); - return; - } - } - - pub fn set_slice(env: *Env, name_arr: []*MalType, vals_arr: []*MalType) MalError!void { - var i: usize = 0; - - while(i < name_arr.len) { - const key = try name_arr[i].as_symbol(); - if(!string_eql(key, "&")) { - try env.set(key, vals_arr[i]); - i += 1; - continue; - } - - // Here we deal with variadic binding - if(i+1 >= name_arr.len) return MalError.OutOfBounds; - const var_key = try name_arr[i+1].as_symbol(); - var new_ll = MalLinkedList.init(env.allocator); - new_ll.appendSlice(vals_arr[i..vals_arr.len]) catch return MalError.SystemError; - const new_mal = try MalType.new_list(env.allocator, new_ll); - try env.set(var_key, new_mal); - return; - } - } - - pub fn print_keys(env: *Env) void { - var it = env.data.iterator(); - var optional_pair = it.next(); - while(optional_pair) |pair| { - warn("{},",pair.key); - optional_pair = it.next(); - } - warn("\n"); - } -}; +const std = @import("std"); +const warn = @import("std").debug.warn; +const Allocator = @import("std").mem.Allocator; + +const string_copy = @import("utils.zig").string_copy; +const string_eql = @import("utils.zig").string_eql; +const MalType = @import("types.zig").MalType; +const MalTypeValue = @import("types.zig").MalTypeValue; +const MalHashMap = @import("hmap.zig").MalHashMap; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const MalError = @import("error.zig").MalError; +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); + +pub const Env = struct { + outer: ?**Env, + data: *MalHashMap, + allocator: *Allocator, + refcount: *i32, + + pub fn new(allocator: *Allocator, optional_outer: ?*Env) MalError!*Env { + const env = allocator.create(Env) catch return MalError.SystemError; + env.refcount = allocator.create(i32) catch return MalError.SystemError; + env.refcount.* = 1; + if(optional_outer) |outer| { + const env_ptr = allocator.create(*Env) catch return MalError.SystemError; + env_ptr.* = try outer.copy(allocator); + env.outer = env_ptr; + } else { + env.outer = null; + } + env.data = allocator.create(MalHashMap) catch return MalError.SystemError; + env.data.* = MalHashMap.init(allocator); + env.allocator = allocator; + return env; + } + + pub fn copy(env: *Env, allocator: *Allocator) MalError!*Env { + const new_env = allocator.create(Env) catch return MalError.SystemError; + new_env.refcount = env.refcount; + env.refcount.* += 1; + new_env.outer = env.outer; + new_env.data = env.data; + new_env.allocator = allocator; + return new_env; + } + + pub fn delete(env: *Env) void { + env.refcount.* -= 1; + if(env.refcount.* <= 0) { + if(env.outer) |*outer| { + outer.*.*.delete(); + env.allocator.destroy(env.outer.?); + } + //env.print_keys(); + hash_map.destroy(env.allocator, env.data.*, false); + env.allocator.destroy(env.refcount); + env.allocator.destroy(env.data); + } + env.allocator.destroy(env); + } + + pub fn set(env: *Env, key: []const u8, value: *MalType) MalError!void { + const optional_prev_mal = env.data.getValue(key); + if(optional_prev_mal) |prev_mal| { + prev_mal.delete(env.allocator); + } + //warn("Setting {}\n", key); + const key_copy = string_copy(env.allocator, key) catch return MalError.SystemError; + _ = env.data.put(key_copy, value) catch return MalError.SystemError; + } + + pub fn root_set(env: *Env, key: []const u8, value: *MalType) MalError!void { + var root_env = env; + while(true) { + const outer_ptr = root_env.outer orelse break; + root_env = outer_ptr.*; + } + try root_env.set(key, value); + } + + pub fn find(env: *const Env, key: []const u8) bool { + const optional_mal = env.data.getValue(key); + if(optional_mal) |mal| { + return true; + } + if(env.outer) |outer| { + return outer.*.find(key); + } + return false; + } + + pub fn get(env: *const Env, key: []const u8) MalError!*MalType { + const optional_mal = env.data.getValue(key); + if(optional_mal) |mal| { + //warn("Got for key '{}': {} (me: {})\n", key, mal, @ptrToInt(env)); + return mal; + } + if(env.outer) |outer| { + return outer.*.get(key); + } + return MalError.EnvLookupError; + } + + pub fn set_list(env: *Env, names: MalLinkedList, vals: MalLinkedList) MalError!void { + var name_arr = names.toSlice(); + var vals_arr = vals.toSlice(); + var i: usize = 0; + + while(i < name_arr.len) { + const key = try name_arr[i].as_symbol(); + if(!string_eql(key, "&")) { + try env.set(key, vals_arr[i]); + i += 1; + continue; + } + + // Here we deal with variadic binding + if(i+1 >= name_arr.len) return MalError.OutOfBounds; + const var_key = try name_arr[i+1].as_symbol(); + var new_ll = MalLinkedList.init(env.allocator); + new_ll.appendSlice(vals_arr[i..vals_arr.len]) catch return MalError.SystemError; + const new_mal = try MalType.new_list(env.allocator, new_ll); + try env.set(var_key, new_mal); + return; + } + } + + pub fn set_slice(env: *Env, name_arr: []*MalType, vals_arr: []*MalType) MalError!void { + var i: usize = 0; + + while(i < name_arr.len) { + const key = try name_arr[i].as_symbol(); + if(!string_eql(key, "&")) { + try env.set(key, vals_arr[i]); + i += 1; + continue; + } + + // Here we deal with variadic binding + if(i+1 >= name_arr.len) return MalError.OutOfBounds; + const var_key = try name_arr[i+1].as_symbol(); + var new_ll = MalLinkedList.init(env.allocator); + new_ll.appendSlice(vals_arr[i..vals_arr.len]) catch return MalError.SystemError; + const new_mal = try MalType.new_list(env.allocator, new_ll); + try env.set(var_key, new_mal); + return; + } + } + + pub fn print_keys(env: *Env) void { + var it = env.data.iterator(); + var optional_pair = it.next(); + while(optional_pair) |pair| { + warn("{},",pair.key); + optional_pair = it.next(); + } + warn("\n"); + } +}; diff --git a/impls/zig/error.zig b/impls/zig/error.zig index f300ef86fa..fbb3dbd140 100644 --- a/impls/zig/error.zig +++ b/impls/zig/error.zig @@ -1,20 +1,20 @@ -pub const MalError = error { - SystemError, - EnvLookupError, - ApplyError, - EvalError, - KeyError, - ThrownError, - TypeError, - ArgError, - ReaderUnmatchedParen, - ReaderUnmatchedString, - ReaderBadHashmap, - OutOfBounds, - Overflow, - DivisionByZero, -}; - -pub fn error_string_repr(mal_error: MalError) []const u8 { - return @errorName(mal_error); -} +pub const MalError = error { + SystemError, + EnvLookupError, + ApplyError, + EvalError, + KeyError, + ThrownError, + TypeError, + ArgError, + ReaderUnmatchedParen, + ReaderUnmatchedString, + ReaderBadHashmap, + OutOfBounds, + Overflow, + DivisionByZero, +}; + +pub fn error_string_repr(mal_error: MalError) []const u8 { + return @errorName(mal_error); +} diff --git a/impls/zig/hmap.zig b/impls/zig/hmap.zig index 0765526c98..1770761dfc 100644 --- a/impls/zig/hmap.zig +++ b/impls/zig/hmap.zig @@ -1,58 +1,58 @@ -const warn = @import("std").debug.warn; -const Allocator = @import("std").mem.Allocator; - -const hash_map = @import("std").hash_map; -const MalType = @import("types.zig").MalType; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; -const MalError = @import("error.zig").MalError; - -fn bad_hash(str: []const u8) u32 { - var hash: u64 = 1; - const m: u32 = (1<<31); - const a: u32 = 1103515245; - const c: u32 = 12345; - - var i: usize = 0; - const n = str.len; - while(i < n) { - hash = (hash + str[i]) % m; - hash = (a * hash) % m; - hash = (c + hash) % m; - i += 1; - } - const res: u32 = @intCast(u32, hash % m); - return res; -} - -pub const MalHashMap = hash_map.HashMap([]const u8, *MalType, bad_hash, string_eql); - -pub fn deepcopy(allocator: *Allocator, hashmap: MalHashMap) MalError!MalHashMap { - var hmap_cpy = MalHashMap.init(allocator); - var iterator = hashmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = string_copy(allocator, pair.key) catch return MalError.SystemError; - const val = try pair.value.copy(allocator); - _ = hmap_cpy.put(key, val) catch return MalError.SystemError; - optional_pair = iterator.next(); - } - return hmap_cpy; -} - -pub fn destroy(allocator: *Allocator, hashmap: MalHashMap, shallow: bool) void { - var iterator = hashmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - //warn(" deleting {} {}\n", pair.key, pair.value); - if(!shallow) { - allocator.free(pair.key); - pair.value.delete(allocator); - } - optional_pair = iterator.next(); - } - hashmap.deinit(); -} - +const warn = @import("std").debug.warn; +const Allocator = @import("std").mem.Allocator; + +const hash_map = @import("std").hash_map; +const MalType = @import("types.zig").MalType; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; +const MalError = @import("error.zig").MalError; + +fn bad_hash(str: []const u8) u32 { + var hash: u64 = 1; + const m: u32 = (1<<31); + const a: u32 = 1103515245; + const c: u32 = 12345; + + var i: usize = 0; + const n = str.len; + while(i < n) { + hash = (hash + str[i]) % m; + hash = (a * hash) % m; + hash = (c + hash) % m; + i += 1; + } + const res: u32 = @intCast(u32, hash % m); + return res; +} + +pub const MalHashMap = hash_map.HashMap([]const u8, *MalType, bad_hash, string_eql); + +pub fn deepcopy(allocator: *Allocator, hashmap: MalHashMap) MalError!MalHashMap { + var hmap_cpy = MalHashMap.init(allocator); + var iterator = hashmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = string_copy(allocator, pair.key) catch return MalError.SystemError; + const val = try pair.value.copy(allocator); + _ = hmap_cpy.put(key, val) catch return MalError.SystemError; + optional_pair = iterator.next(); + } + return hmap_cpy; +} + +pub fn destroy(allocator: *Allocator, hashmap: MalHashMap, shallow: bool) void { + var iterator = hashmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + //warn(" deleting {} {}\n", pair.key, pair.value); + if(!shallow) { + allocator.free(pair.key); + pair.value.delete(allocator); + } + optional_pair = iterator.next(); + } + hashmap.deinit(); +} + diff --git a/impls/zig/linked_list.zig b/impls/zig/linked_list.zig index e50c0a72a3..5a069f9d8a 100644 --- a/impls/zig/linked_list.zig +++ b/impls/zig/linked_list.zig @@ -1,58 +1,58 @@ -const Allocator = @import("std").mem.Allocator; - -const TailQueue = @import("std").TailQueue; -const ArrayList = @import("std").ArrayList; -const MalType = @import("types.zig").MalType; -const MalError = @import("error.zig").MalError; - -pub const MalLinkedList = ArrayList(*MalType); - -pub fn deepcopy(allocator: *Allocator, ll: MalLinkedList) MalError!MalLinkedList { - var new_ll = MalLinkedList.init(allocator); - const ll_slice = ll.toSlice(); - var i: usize = 0; - while(i < ll_slice.len) { - const new_mal = try ll_slice[i].copy(allocator); - new_ll.append(new_mal) catch return MalError.SystemError; - i += 1; - } - - return new_ll; -} - -pub fn destroy(allocator: *Allocator, ll: *MalLinkedList, shallow: bool) void { - if(!shallow) { - const ll_slice = ll.toSlice(); - var i: usize = 0; - while(i < ll_slice.len) { - ll_slice[i].delete(allocator); - i += 1; - } - } - ll.deinit(); -} - -// TODO: deprecate -pub fn append_mal(allocator: *Allocator, ll: *MalLinkedList, mal: *MalType) MalError!void { - ll.append(mal) catch return MalError.SystemError; -} - -// TODO: deprecate -pub fn prepend_mal(allocator: *Allocator, ll: *MalLinkedList, mal: *MalType) MalError!void { - ll.insert(0, mal) catch return MalError.SystemError; -} - -pub fn pop_first(allocator: *Allocator, ll: *MalLinkedList) MalError!*MalType { - if(ll.count() == 0) { - return MalError.OutOfBounds; - } - return ll.orderedRemove(0); -} - -pub fn first(ll: *const MalLinkedList) ?*MalType { - if(ll.count() == 0) { - return null; - } - return ll.at(0); -} - +const Allocator = @import("std").mem.Allocator; + +const TailQueue = @import("std").TailQueue; +const ArrayList = @import("std").ArrayList; +const MalType = @import("types.zig").MalType; +const MalError = @import("error.zig").MalError; + +pub const MalLinkedList = ArrayList(*MalType); + +pub fn deepcopy(allocator: *Allocator, ll: MalLinkedList) MalError!MalLinkedList { + var new_ll = MalLinkedList.init(allocator); + const ll_slice = ll.toSlice(); + var i: usize = 0; + while(i < ll_slice.len) { + const new_mal = try ll_slice[i].copy(allocator); + new_ll.append(new_mal) catch return MalError.SystemError; + i += 1; + } + + return new_ll; +} + +pub fn destroy(allocator: *Allocator, ll: *MalLinkedList, shallow: bool) void { + if(!shallow) { + const ll_slice = ll.toSlice(); + var i: usize = 0; + while(i < ll_slice.len) { + ll_slice[i].delete(allocator); + i += 1; + } + } + ll.deinit(); +} + +// TODO: deprecate +pub fn append_mal(allocator: *Allocator, ll: *MalLinkedList, mal: *MalType) MalError!void { + ll.append(mal) catch return MalError.SystemError; +} + +// TODO: deprecate +pub fn prepend_mal(allocator: *Allocator, ll: *MalLinkedList, mal: *MalType) MalError!void { + ll.insert(0, mal) catch return MalError.SystemError; +} + +pub fn pop_first(allocator: *Allocator, ll: *MalLinkedList) MalError!*MalType { + if(ll.count() == 0) { + return MalError.OutOfBounds; + } + return ll.orderedRemove(0); +} + +pub fn first(ll: *const MalLinkedList) ?*MalType { + if(ll.count() == 0) { + return null; + } + return ll.at(0); +} + diff --git a/impls/zig/logging_alloc.zig b/impls/zig/logging_alloc.zig index 7917421087..cf52b8d242 100644 --- a/impls/zig/logging_alloc.zig +++ b/impls/zig/logging_alloc.zig @@ -1,35 +1,35 @@ -const std = @import("std"); -const Allocator = std.mem.Allocator; -const warn = @import("std").debug.warn; - -pub const LoggingAllocator = struct { - allocator: Allocator, - parent_allocator: *Allocator, - - const Self = @This(); - - pub fn init(parent_allocator: *Allocator) Self { - return Self { - .allocator = Allocator{ - .reallocFn = realloc, - .shrinkFn = shrink, - }, - .parent_allocator = parent_allocator, - }; - } - - fn realloc(allocator: *Allocator, old_mem: []u8, old_align: u29, new_size: usize, new_align: u29) ![]u8 { - warn("mem new {} {} {}\n", old_mem.len, new_size, @intCast(i64,new_size) - @intCast(i64, old_mem.len)); - const self = @fieldParentPtr(Self, "allocator", allocator); - const result = self.parent_allocator.reallocFn(self.parent_allocator, old_mem, old_align, new_size, new_align); - return result; - } - - fn shrink(allocator: *Allocator, old_mem: []u8, old_align: u29, new_size: usize, new_align: u29) []u8 { - warn("mem del {} {} {}\n", old_mem.len, new_size, @intCast(i64,new_size) - @intCast(i64,old_mem.len)); - warn("deleted: {}\n", old_mem); - const self = @fieldParentPtr(Self, "allocator", allocator); - const result = self.parent_allocator.shrinkFn(self.parent_allocator, old_mem, old_align, new_size, new_align); - return result; - } -}; +const std = @import("std"); +const Allocator = std.mem.Allocator; +const warn = @import("std").debug.warn; + +pub const LoggingAllocator = struct { + allocator: Allocator, + parent_allocator: *Allocator, + + const Self = @This(); + + pub fn init(parent_allocator: *Allocator) Self { + return Self { + .allocator = Allocator{ + .reallocFn = realloc, + .shrinkFn = shrink, + }, + .parent_allocator = parent_allocator, + }; + } + + fn realloc(allocator: *Allocator, old_mem: []u8, old_align: u29, new_size: usize, new_align: u29) ![]u8 { + warn("mem new {} {} {}\n", old_mem.len, new_size, @intCast(i64,new_size) - @intCast(i64, old_mem.len)); + const self = @fieldParentPtr(Self, "allocator", allocator); + const result = self.parent_allocator.reallocFn(self.parent_allocator, old_mem, old_align, new_size, new_align); + return result; + } + + fn shrink(allocator: *Allocator, old_mem: []u8, old_align: u29, new_size: usize, new_align: u29) []u8 { + warn("mem del {} {} {}\n", old_mem.len, new_size, @intCast(i64,new_size) - @intCast(i64,old_mem.len)); + warn("deleted: {}\n", old_mem); + const self = @fieldParentPtr(Self, "allocator", allocator); + const result = self.parent_allocator.shrinkFn(self.parent_allocator, old_mem, old_align, new_size, new_align); + return result; + } +}; diff --git a/impls/zig/printer.zig b/impls/zig/printer.zig index 633aac8e4e..ff8fd74108 100644 --- a/impls/zig/printer.zig +++ b/impls/zig/printer.zig @@ -1,231 +1,231 @@ -const io = @import("std").io; -const fmt = @import("std").fmt; -const warn = @import("std").debug.warn; -const mem = @import("std").mem; -const math = @import("std").math; - -const Allocator = @import("std").heap.c_allocator; - -const MalType = @import("types.zig").MalType; -const MalTypeValue = @import("types.zig").MalTypeValue; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const MalError = @import("error.zig").MalError; - -const ResizeBuffer = struct { - buffer: ?[]u8, - pos: usize, - len: usize, -}; - -// TODO fix emacs highlighting, remove this -const backslash = - \\\ -; - -fn appendToBuffer(resize_buffer: *ResizeBuffer, buffer: []const u8) MalError!void { - const n: usize = buffer.len; - - if(n + resize_buffer.pos > resize_buffer.len or resize_buffer.buffer == null) { - const new_len = math.max(math.max(2*resize_buffer.len, 10), n+resize_buffer.pos); - var bigger_buffer: [] u8 = Allocator.alloc(u8, new_len) catch return MalError.SystemError; - if(resize_buffer.buffer) |old_buffer| { - var i: usize = 0; - while(i < resize_buffer.len) { - bigger_buffer[i] = old_buffer[i]; - i += 1; - } - Allocator.free(old_buffer); - } - resize_buffer.buffer = bigger_buffer; - resize_buffer.len = new_len; - } - - if(resize_buffer.buffer) |n_buffer| { - var i: usize = 0; - while(i < n) { - n_buffer[resize_buffer.pos] = buffer[i]; - i += 1; - resize_buffer.pos += 1; - } - } -} - -fn print_mal_to_buffer(mal: *const MalType, readable: bool) MalError!ResizeBuffer { - var rb = ResizeBuffer{ - .buffer = null, - .pos = 0, - .len = 0, - }; - - try print_to_buffer(mal, &rb, readable); - return rb; -} - -pub fn print_str(optional_mal: ?*const MalType) MalError![] const u8 { - const stdout_file = io.getStdOut() catch return MalError.SystemError; - if(optional_mal == null) { - var return_string: [] u8 = Allocator.alloc(u8, 3) catch return MalError.SystemError; - return_string[0] = 'E'; //TODO: memcpy - return_string[1] = 'O'; - return_string[2] = 'F'; - return return_string; // TODO: is this right? - //stdout_file.write("EOF\n") catch return MalError.SystemError; - } - const mal = optional_mal orelse return ""; - var rb = try print_mal_to_buffer(mal, true); - - if(rb.buffer) |buffer| { - //stdout_file.write(buffer[0..rb.pos]) catch return MalError.SystemError; - //stdout_file.write("\n") catch return MalError.SystemError; - var return_string: [] u8 = Allocator.alloc(u8, rb.pos) catch return MalError.SystemError; - var i: usize = 0; // TODO: replace with memcpy (and elsewhere) - while(i < rb.pos) { - return_string[i] = buffer[i]; - i += 1; - } - Allocator.free(buffer); - return return_string; - } - return MalError.SystemError; -} - -pub fn print_mal_to_string(args: MalLinkedList, readable: bool, sep: bool) MalError![] u8 { - // TODO: handle empty string - var rb = ResizeBuffer{ - .buffer = null, - .pos = 0, - .len = 0, - }; - - var iterator = args.iterator(); - var first: bool = true; - while(iterator.next()) |node| { - if(!first and sep) { - try appendToBuffer(&rb, " "); - } - try print_to_buffer(node, &rb, readable); - first = false; - } - - // TODO: is this the right exception? - if(rb.buffer) |buffer| { - const len = rb.pos; - var return_string: [] u8 = Allocator.alloc(u8, len) catch return MalError.SystemError; - var i: usize = 0; - while(i < len) { - return_string[i] = buffer[i]; - i += 1; - } - Allocator.free(buffer); - return return_string; - } - const s: []u8 = ""; - return s; -} - -fn print_to_buffer(mal: *const MalType, rb: *ResizeBuffer, readable: bool) MalError!void { - switch(mal.data) { - .String => |string| { - if(readable) { - try appendToBuffer(rb, "\""); - } - // TODO: optimize this - var i: usize = 0; - var n: usize = string.len; - while(i < n){ - const this_char = string[i]; - if(readable and (this_char == '"' or this_char==92)) { - try appendToBuffer(rb, backslash); - } - if(readable and (this_char == '\n')) { - try appendToBuffer(rb, "\\n"); - } - else { - try appendToBuffer(rb, string[i..i+1]); - } - i += 1; - } - if(readable) { - try appendToBuffer(rb, "\""); - } - }, - .Keyword => |kwd| { - try appendToBuffer(rb, ":"); - try appendToBuffer(rb, kwd[1..kwd.len]); - }, - .Int => |val| { - try fmt.format(rb, MalError, appendToBuffer, "{0}", val); - }, - .Nil => { - try appendToBuffer(rb, "nil"); - }, - .True => { - try appendToBuffer(rb, "true"); - }, - .False => { - try appendToBuffer(rb, "false"); - }, - .List => |l| { - try appendToBuffer(rb, "("); - var iterator = l.iterator(); - var first_iteration = true; - while(iterator.next()) |next_mal| { - if(!first_iteration) { - try appendToBuffer(rb, " "); - } - try print_to_buffer(next_mal, rb, readable); - first_iteration = false; - } - try appendToBuffer(rb, ")"); - }, - .Vector => |v| { - try appendToBuffer(rb, "["); - var iterator = v.iterator(); - var first_iteration = true; - while(iterator.next()) |next_mal| { - if(!first_iteration) { - try appendToBuffer(rb, " "); - } - try print_to_buffer(next_mal, rb, readable); - first_iteration = false; - } - try appendToBuffer(rb, "]"); - }, - .Atom => |atom_value| { - try appendToBuffer(rb, "(atom "); - try print_to_buffer(atom_value.*, rb, readable); - try appendToBuffer(rb, ")"); - }, - .Func, .Fn0, .Fn1, .Fn2, .Fn3, .Fn4, .FVar => { - try appendToBuffer(rb, "#"); - }, - .Generic => |value| { - try appendToBuffer(rb, value); - }, - .HashMap => |h| { - try appendToBuffer(rb, "{"); - var iterator = h.iterator(); - var first = true; - while(true) { - const optional_pair = iterator.next(); - const pair = optional_pair orelse break; - if(!first) { - try appendToBuffer(rb, " "); - } - if(pair.key.len > 1 and pair.key[0] == 255) { - try appendToBuffer(rb, ":"); - try appendToBuffer(rb, pair.key[1..pair.key.len]); - } - else { - try appendToBuffer(rb, "\""); - try appendToBuffer(rb, pair.key); - try appendToBuffer(rb, "\""); - } - try appendToBuffer(rb, " "); - try print_to_buffer(pair.value, rb, readable); - first = false; - } - try appendToBuffer(rb, "}"); - }, - } -} +const io = @import("std").io; +const fmt = @import("std").fmt; +const warn = @import("std").debug.warn; +const mem = @import("std").mem; +const math = @import("std").math; + +const Allocator = @import("std").heap.c_allocator; + +const MalType = @import("types.zig").MalType; +const MalTypeValue = @import("types.zig").MalTypeValue; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const MalError = @import("error.zig").MalError; + +const ResizeBuffer = struct { + buffer: ?[]u8, + pos: usize, + len: usize, +}; + +// TODO fix emacs highlighting, remove this +const backslash = + \\\ +; + +fn appendToBuffer(resize_buffer: *ResizeBuffer, buffer: []const u8) MalError!void { + const n: usize = buffer.len; + + if(n + resize_buffer.pos > resize_buffer.len or resize_buffer.buffer == null) { + const new_len = math.max(math.max(2*resize_buffer.len, 10), n+resize_buffer.pos); + var bigger_buffer: [] u8 = Allocator.alloc(u8, new_len) catch return MalError.SystemError; + if(resize_buffer.buffer) |old_buffer| { + var i: usize = 0; + while(i < resize_buffer.len) { + bigger_buffer[i] = old_buffer[i]; + i += 1; + } + Allocator.free(old_buffer); + } + resize_buffer.buffer = bigger_buffer; + resize_buffer.len = new_len; + } + + if(resize_buffer.buffer) |n_buffer| { + var i: usize = 0; + while(i < n) { + n_buffer[resize_buffer.pos] = buffer[i]; + i += 1; + resize_buffer.pos += 1; + } + } +} + +fn print_mal_to_buffer(mal: *const MalType, readable: bool) MalError!ResizeBuffer { + var rb = ResizeBuffer{ + .buffer = null, + .pos = 0, + .len = 0, + }; + + try print_to_buffer(mal, &rb, readable); + return rb; +} + +pub fn print_str(optional_mal: ?*const MalType) MalError![] const u8 { + const stdout_file = io.getStdOut() catch return MalError.SystemError; + if(optional_mal == null) { + var return_string: [] u8 = Allocator.alloc(u8, 3) catch return MalError.SystemError; + return_string[0] = 'E'; //TODO: memcpy + return_string[1] = 'O'; + return_string[2] = 'F'; + return return_string; // TODO: is this right? + //stdout_file.write("EOF\n") catch return MalError.SystemError; + } + const mal = optional_mal orelse return ""; + var rb = try print_mal_to_buffer(mal, true); + + if(rb.buffer) |buffer| { + //stdout_file.write(buffer[0..rb.pos]) catch return MalError.SystemError; + //stdout_file.write("\n") catch return MalError.SystemError; + var return_string: [] u8 = Allocator.alloc(u8, rb.pos) catch return MalError.SystemError; + var i: usize = 0; // TODO: replace with memcpy (and elsewhere) + while(i < rb.pos) { + return_string[i] = buffer[i]; + i += 1; + } + Allocator.free(buffer); + return return_string; + } + return MalError.SystemError; +} + +pub fn print_mal_to_string(args: MalLinkedList, readable: bool, sep: bool) MalError![] u8 { + // TODO: handle empty string + var rb = ResizeBuffer{ + .buffer = null, + .pos = 0, + .len = 0, + }; + + var iterator = args.iterator(); + var first: bool = true; + while(iterator.next()) |node| { + if(!first and sep) { + try appendToBuffer(&rb, " "); + } + try print_to_buffer(node, &rb, readable); + first = false; + } + + // TODO: is this the right exception? + if(rb.buffer) |buffer| { + const len = rb.pos; + var return_string: [] u8 = Allocator.alloc(u8, len) catch return MalError.SystemError; + var i: usize = 0; + while(i < len) { + return_string[i] = buffer[i]; + i += 1; + } + Allocator.free(buffer); + return return_string; + } + const s: []u8 = ""; + return s; +} + +fn print_to_buffer(mal: *const MalType, rb: *ResizeBuffer, readable: bool) MalError!void { + switch(mal.data) { + .String => |string| { + if(readable) { + try appendToBuffer(rb, "\""); + } + // TODO: optimize this + var i: usize = 0; + var n: usize = string.len; + while(i < n){ + const this_char = string[i]; + if(readable and (this_char == '"' or this_char==92)) { + try appendToBuffer(rb, backslash); + } + if(readable and (this_char == '\n')) { + try appendToBuffer(rb, "\\n"); + } + else { + try appendToBuffer(rb, string[i..i+1]); + } + i += 1; + } + if(readable) { + try appendToBuffer(rb, "\""); + } + }, + .Keyword => |kwd| { + try appendToBuffer(rb, ":"); + try appendToBuffer(rb, kwd[1..kwd.len]); + }, + .Int => |val| { + try fmt.format(rb, MalError, appendToBuffer, "{0}", val); + }, + .Nil => { + try appendToBuffer(rb, "nil"); + }, + .True => { + try appendToBuffer(rb, "true"); + }, + .False => { + try appendToBuffer(rb, "false"); + }, + .List => |l| { + try appendToBuffer(rb, "("); + var iterator = l.iterator(); + var first_iteration = true; + while(iterator.next()) |next_mal| { + if(!first_iteration) { + try appendToBuffer(rb, " "); + } + try print_to_buffer(next_mal, rb, readable); + first_iteration = false; + } + try appendToBuffer(rb, ")"); + }, + .Vector => |v| { + try appendToBuffer(rb, "["); + var iterator = v.iterator(); + var first_iteration = true; + while(iterator.next()) |next_mal| { + if(!first_iteration) { + try appendToBuffer(rb, " "); + } + try print_to_buffer(next_mal, rb, readable); + first_iteration = false; + } + try appendToBuffer(rb, "]"); + }, + .Atom => |atom_value| { + try appendToBuffer(rb, "(atom "); + try print_to_buffer(atom_value.*, rb, readable); + try appendToBuffer(rb, ")"); + }, + .Func, .Fn0, .Fn1, .Fn2, .Fn3, .Fn4, .FVar => { + try appendToBuffer(rb, "#"); + }, + .Generic => |value| { + try appendToBuffer(rb, value); + }, + .HashMap => |h| { + try appendToBuffer(rb, "{"); + var iterator = h.iterator(); + var first = true; + while(true) { + const optional_pair = iterator.next(); + const pair = optional_pair orelse break; + if(!first) { + try appendToBuffer(rb, " "); + } + if(pair.key.len > 1 and pair.key[0] == 255) { + try appendToBuffer(rb, ":"); + try appendToBuffer(rb, pair.key[1..pair.key.len]); + } + else { + try appendToBuffer(rb, "\""); + try appendToBuffer(rb, pair.key); + try appendToBuffer(rb, "\""); + } + try appendToBuffer(rb, " "); + try print_to_buffer(pair.value, rb, readable); + first = false; + } + try appendToBuffer(rb, "}"); + }, + } +} diff --git a/impls/zig/reader.zig b/impls/zig/reader.zig index c9c7d779dd..5e344c5da4 100644 --- a/impls/zig/reader.zig +++ b/impls/zig/reader.zig @@ -1,341 +1,341 @@ -const fmt = @import("std").fmt; -const warn = @import("std").debug.warn; - -pub const pcre = @cImport({ - @cInclude("pcre.h"); -}); - -const MalType = @import("types.zig").MalType; -const MalData = @import("types.zig").MalData; -const MalTypeValue = @import("types.zig").MalTypeValue; -const MalError = @import("error.zig").MalError; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const printer = @import("printer.zig"); - -const Allocator = @import("std").heap.c_allocator; -const string_eql = @import("utils.zig").string_eql; -const linked_list = @import("linked_list.zig"); - -const match: [*]const u8 = - c\\[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*) -; -var error_msg: [*c]const u8 = undefined; -var erroroffset: c_int = 0; -var re: ?*pcre.pcre = null; - -const Reader = struct { - position: u32, - string: [] const u8, - tokens: [] usize, - - pub fn init(string: [] const u8, tokens: [] usize) Reader { - return Reader { - .position = 0, - .string = string, - .tokens = tokens, - }; - } - - pub fn next(self: *Reader) []const u8 { - const this_token = self.peek(); - self.position += 1; - return this_token; - } - - pub fn peek(self: *Reader) []const u8 { - while(!self.eol()) { - const start = self.tokens[2*self.position]; - const end = self.tokens[2*self.position+1]; - if(self.string[start] == ';') { - self.position += 1; - continue; - } - return self.string[start..end]; - } - return ""; - } - - pub fn eol(self: *Reader) bool { - return (2 * self.position >= self.tokens.len); - } -}; - -const AliasPair = struct { - name: []const u8, - value: []const u8, - count: u8, -}; - -const alias_pairs = [_] AliasPair { - AliasPair {.name="@", .value="deref", .count=1}, - AliasPair {.name="\'", .value="quote", .count=1}, - AliasPair {.name="`", .value="quasiquote", .count=1}, - AliasPair {.name="~", .value="unquote", .count=1}, - AliasPair {.name="~@", .value="splice-unquote", .count=1}, - AliasPair {.name="^", .value="with-meta", .count=2}, -}; - -pub fn read_form(reader: *Reader) MalError!?*MalType { - if(reader.eol()) { - return null; - } - const token = reader.peek(); - if(token.len == 0) { - return MalType.new_nil(Allocator); - } - if(token[0] == '(') { - return try read_list(reader); - } - else if(token[0] == '[') { - return try read_vector(reader); - } - else if(token[0] == ':') { - const keyword = reader.next(); - return MalType.new_keyword(Allocator, keyword[1..keyword.len]); - } - else if(token[0] == '{') { - return try read_hashmap(reader); - } - - for(alias_pairs) |pair| { - const name = pair.name; - const value = pair.value; - const count = pair.count; - if(!string_eql(token, name)) { - continue; - } - var new_ll = MalLinkedList.init(Allocator); - const new_generic = try MalType.new_generic(Allocator, value); - const tmp = reader.next(); - var num_read: u8 = 0; - while(num_read < count) { - const next_read = (try read_form(reader)) orelse return MalError.ArgError; - try linked_list.prepend_mal(Allocator, &new_ll, next_read); - num_read += 1; - } - try linked_list.prepend_mal(Allocator, &new_ll, new_generic); - const new_list = try MalType.new_nil(Allocator); - new_list.data = MalData {.List = new_ll}; - return new_list; - } - - return try read_atom(reader); -} - -pub fn read_list(reader: *Reader) MalError!*MalType { - const first_token = reader.next(); - var new_ll = MalLinkedList.init(Allocator); - const mal_list: *MalType = try MalType.new_nil(Allocator); - - while(!reader.eol()) { - var next_token = reader.peek(); - - if(next_token.len == 0) { - return MalError.ReaderUnmatchedParen; - } - if(next_token[0] == ')') { - const right_paren = reader.next(); - mal_list.data = MalData{.List = new_ll}; - return mal_list; - } - const mal = (try read_form(reader)) orelse return MalError.ArgError; - try linked_list.append_mal(Allocator, &new_ll, mal); - } - return MalError.ReaderUnmatchedParen; -} - -pub fn read_vector(reader: *Reader) MalError!*MalType { - const first_token = reader.next(); - var new_ll = MalLinkedList.init(Allocator); - const mal_list: *MalType = try MalType.new_nil(Allocator); - - while(!reader.eol()) { - var next_token = reader.peek(); - - if(next_token.len == 0) { - return MalError.ReaderUnmatchedParen; - } - if(next_token[0] == ']') { - const right_paren = reader.next(); - mal_list.data = MalData{.Vector = new_ll}; - return mal_list; - } - const mal = (try read_form(reader)) orelse return MalError.ArgError; - try linked_list.append_mal(Allocator, &new_ll, mal); - } - return MalError.ReaderUnmatchedParen; -} - - -pub fn read_hashmap(reader: *Reader) MalError!*MalType { - const first_token = reader.next(); - const new_hashmap = try MalType.new_hashmap(Allocator); - while(!reader.eol()) { - var next_token = reader.peek(); - - if(next_token.len == 0) { - return MalError.ReaderUnmatchedParen; - } - if(next_token[0] == '}') { - const right_paren = reader.next(); - return new_hashmap; - } - const mal = (try read_form(reader)) orelse return MalError.ArgError; - const key = switch(mal.data) { - .String => |s| s, - .Keyword => |kwd| kwd, - else => return MalError.TypeError, - }; - if(next_token.len == 0 or next_token[0] == '}') { - return MalError.ReaderBadHashmap; - } - const val = (try read_form(reader)) orelse return MalError.ArgError; - try new_hashmap.hashmap_insert(key, val); - } - return MalError.ReaderUnmatchedParen; -} - -fn char_is_int(c: u8) bool { - return (c >= '0' and c <= '9'); -} - -fn token_is_int(token: []const u8) bool { - if(char_is_int(token[0])) - return true; - if(token.len >= 2 and token[0] == '-' and char_is_int(token[1])) - return true; - return false; -} - -pub fn read_atom(reader: *Reader) MalError!*MalType { - const token = reader.next(); - - if(token_is_int(token)) { - var mal_atom = try MalType.new_nil(Allocator); - try read_atom_int(mal_atom, token); - return mal_atom; - } - else if(string_eql(token, "nil")) { - return MalType.new_nil(Allocator); - } - else if(string_eql(token, "true")) { - return MalType.new_bool(Allocator, true); - } - else if(string_eql(token, "false")) { - return MalType.new_bool(Allocator, false); - } - else if(token[0] == '"') { - var mal_atom = try MalType.new_nil(Allocator); - try read_atom_string(mal_atom, token); - return mal_atom; - } - else { - var mal_atom = try MalType.new_generic(Allocator, token); - return mal_atom; - } -} - -fn read_atom_int(mal_atom: *MalType, token: []const u8) MalError!void { - // TODO: extract int type from union - mal_atom.data = MalData {.Int = fmt.parseInt(i32, token, 10) - catch |err| return MalError.SystemError }; -} - -fn read_atom_string(mal_atom: *MalType, token: []const u8) MalError!void { - const n = token.len; - if(token[0] != '"' or token[n-1] != '"' or n <= 1) { - return MalError.ReaderUnmatchedString; - } - - if(n <= 2) { - // We get here when the token is an empty string. - // We encode this as MalTypeValue.String, with null .string_value - var string = Allocator.alloc(u8, 0) catch return MalError.SystemError; - mal_atom.data = MalData {.String = string}; - return; - } - - var tmp_buffer = Allocator.alloc(u8, n-2) catch return MalError.SystemError; - defer Allocator.free(tmp_buffer); - var i: usize = 1; - var j: usize = 0; - const escape_char: u8 = '\\'; //TODO: remove this comment required by bad emacs config ' - while(i < n-1) { - if(token[i] != escape_char) { - tmp_buffer[j] = token[i]; - j += 1; - i += 1; - } - else { - if(i==n-2) { - return MalError.ReaderUnmatchedString; - } - if(token[i+1] == 'n') { - tmp_buffer[j] = '\n'; - } else { - tmp_buffer[j] = token[i+1]; - } - j += 1; - i += 2; - } - } - - var string = Allocator.alloc(u8, j) catch return MalError.SystemError; - i = 0; - while(i < j) { - string[i] = tmp_buffer[i]; - i += 1; - } - - mal_atom.data = MalData {.String = string}; -} - -pub fn read_str(string: [] const u8) MalError!Reader { - if(re == null) { - re = pcre.pcre_compile(&match[0], 0, &error_msg, &erroroffset, 0); - } - const tokens = try tokenize(re, string); - return Reader.init(string, tokens); -} - -// Allocates an array of matches. Caller is becomes owner of memory. -pub fn tokenize(regex: ?*pcre.pcre, string: [] const u8) MalError![] usize { - // TODO: pass in allocator - const buffer_size: usize = 3 * string.len + 10; - var indices: [] c_int = Allocator.alloc(c_int, buffer_size) - catch return MalError.SystemError; - defer Allocator.free(indices); - var match_buffer: [] usize = Allocator.alloc(usize, buffer_size) - catch return MalError.SystemError; - defer Allocator.free(match_buffer); - var current_match: usize = 0; - var start_pos: c_int = 0; - - var rc: c_int = 0; - var start_match: usize = 0; - var end_match: usize = 0; - const subject_size: c_int = @intCast(c_int, string.len); - - while(start_pos < subject_size) { - rc = pcre.pcre_exec(regex, 0, &string[0], subject_size, start_pos, 0, - &indices[0], @intCast(c_int,buffer_size)); - if(rc <= 0) - break; - start_pos = indices[1]; - start_match = @intCast(usize, indices[2]); - end_match = @intCast(usize, indices[3]); - match_buffer[current_match] = start_match; - match_buffer[current_match+1] = end_match; - current_match += 2; - } - - var matches: [] usize = Allocator.alloc(usize, current_match) - catch return MalError.SystemError; - var i: usize = 0; - while(i < current_match) { - matches[i] = match_buffer[i]; - i += 1; - } - - return matches; -} +const fmt = @import("std").fmt; +const warn = @import("std").debug.warn; + +pub const pcre = @cImport({ + @cInclude("pcre.h"); +}); + +const MalType = @import("types.zig").MalType; +const MalData = @import("types.zig").MalData; +const MalTypeValue = @import("types.zig").MalTypeValue; +const MalError = @import("error.zig").MalError; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const printer = @import("printer.zig"); + +const Allocator = @import("std").heap.c_allocator; +const string_eql = @import("utils.zig").string_eql; +const linked_list = @import("linked_list.zig"); + +const match: [*]const u8 = + c\\[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*) +; +var error_msg: [*c]const u8 = undefined; +var erroroffset: c_int = 0; +var re: ?*pcre.pcre = null; + +const Reader = struct { + position: u32, + string: [] const u8, + tokens: [] usize, + + pub fn init(string: [] const u8, tokens: [] usize) Reader { + return Reader { + .position = 0, + .string = string, + .tokens = tokens, + }; + } + + pub fn next(self: *Reader) []const u8 { + const this_token = self.peek(); + self.position += 1; + return this_token; + } + + pub fn peek(self: *Reader) []const u8 { + while(!self.eol()) { + const start = self.tokens[2*self.position]; + const end = self.tokens[2*self.position+1]; + if(self.string[start] == ';') { + self.position += 1; + continue; + } + return self.string[start..end]; + } + return ""; + } + + pub fn eol(self: *Reader) bool { + return (2 * self.position >= self.tokens.len); + } +}; + +const AliasPair = struct { + name: []const u8, + value: []const u8, + count: u8, +}; + +const alias_pairs = [_] AliasPair { + AliasPair {.name="@", .value="deref", .count=1}, + AliasPair {.name="\'", .value="quote", .count=1}, + AliasPair {.name="`", .value="quasiquote", .count=1}, + AliasPair {.name="~", .value="unquote", .count=1}, + AliasPair {.name="~@", .value="splice-unquote", .count=1}, + AliasPair {.name="^", .value="with-meta", .count=2}, +}; + +pub fn read_form(reader: *Reader) MalError!?*MalType { + if(reader.eol()) { + return null; + } + const token = reader.peek(); + if(token.len == 0) { + return MalType.new_nil(Allocator); + } + if(token[0] == '(') { + return try read_list(reader); + } + else if(token[0] == '[') { + return try read_vector(reader); + } + else if(token[0] == ':') { + const keyword = reader.next(); + return MalType.new_keyword(Allocator, keyword[1..keyword.len]); + } + else if(token[0] == '{') { + return try read_hashmap(reader); + } + + for(alias_pairs) |pair| { + const name = pair.name; + const value = pair.value; + const count = pair.count; + if(!string_eql(token, name)) { + continue; + } + var new_ll = MalLinkedList.init(Allocator); + const new_generic = try MalType.new_generic(Allocator, value); + const tmp = reader.next(); + var num_read: u8 = 0; + while(num_read < count) { + const next_read = (try read_form(reader)) orelse return MalError.ArgError; + try linked_list.prepend_mal(Allocator, &new_ll, next_read); + num_read += 1; + } + try linked_list.prepend_mal(Allocator, &new_ll, new_generic); + const new_list = try MalType.new_nil(Allocator); + new_list.data = MalData {.List = new_ll}; + return new_list; + } + + return try read_atom(reader); +} + +pub fn read_list(reader: *Reader) MalError!*MalType { + const first_token = reader.next(); + var new_ll = MalLinkedList.init(Allocator); + const mal_list: *MalType = try MalType.new_nil(Allocator); + + while(!reader.eol()) { + var next_token = reader.peek(); + + if(next_token.len == 0) { + return MalError.ReaderUnmatchedParen; + } + if(next_token[0] == ')') { + const right_paren = reader.next(); + mal_list.data = MalData{.List = new_ll}; + return mal_list; + } + const mal = (try read_form(reader)) orelse return MalError.ArgError; + try linked_list.append_mal(Allocator, &new_ll, mal); + } + return MalError.ReaderUnmatchedParen; +} + +pub fn read_vector(reader: *Reader) MalError!*MalType { + const first_token = reader.next(); + var new_ll = MalLinkedList.init(Allocator); + const mal_list: *MalType = try MalType.new_nil(Allocator); + + while(!reader.eol()) { + var next_token = reader.peek(); + + if(next_token.len == 0) { + return MalError.ReaderUnmatchedParen; + } + if(next_token[0] == ']') { + const right_paren = reader.next(); + mal_list.data = MalData{.Vector = new_ll}; + return mal_list; + } + const mal = (try read_form(reader)) orelse return MalError.ArgError; + try linked_list.append_mal(Allocator, &new_ll, mal); + } + return MalError.ReaderUnmatchedParen; +} + + +pub fn read_hashmap(reader: *Reader) MalError!*MalType { + const first_token = reader.next(); + const new_hashmap = try MalType.new_hashmap(Allocator); + while(!reader.eol()) { + var next_token = reader.peek(); + + if(next_token.len == 0) { + return MalError.ReaderUnmatchedParen; + } + if(next_token[0] == '}') { + const right_paren = reader.next(); + return new_hashmap; + } + const mal = (try read_form(reader)) orelse return MalError.ArgError; + const key = switch(mal.data) { + .String => |s| s, + .Keyword => |kwd| kwd, + else => return MalError.TypeError, + }; + if(next_token.len == 0 or next_token[0] == '}') { + return MalError.ReaderBadHashmap; + } + const val = (try read_form(reader)) orelse return MalError.ArgError; + try new_hashmap.hashmap_insert(key, val); + } + return MalError.ReaderUnmatchedParen; +} + +fn char_is_int(c: u8) bool { + return (c >= '0' and c <= '9'); +} + +fn token_is_int(token: []const u8) bool { + if(char_is_int(token[0])) + return true; + if(token.len >= 2 and token[0] == '-' and char_is_int(token[1])) + return true; + return false; +} + +pub fn read_atom(reader: *Reader) MalError!*MalType { + const token = reader.next(); + + if(token_is_int(token)) { + var mal_atom = try MalType.new_nil(Allocator); + try read_atom_int(mal_atom, token); + return mal_atom; + } + else if(string_eql(token, "nil")) { + return MalType.new_nil(Allocator); + } + else if(string_eql(token, "true")) { + return MalType.new_bool(Allocator, true); + } + else if(string_eql(token, "false")) { + return MalType.new_bool(Allocator, false); + } + else if(token[0] == '"') { + var mal_atom = try MalType.new_nil(Allocator); + try read_atom_string(mal_atom, token); + return mal_atom; + } + else { + var mal_atom = try MalType.new_generic(Allocator, token); + return mal_atom; + } +} + +fn read_atom_int(mal_atom: *MalType, token: []const u8) MalError!void { + // TODO: extract int type from union + mal_atom.data = MalData {.Int = fmt.parseInt(i32, token, 10) + catch |err| return MalError.SystemError }; +} + +fn read_atom_string(mal_atom: *MalType, token: []const u8) MalError!void { + const n = token.len; + if(token[0] != '"' or token[n-1] != '"' or n <= 1) { + return MalError.ReaderUnmatchedString; + } + + if(n <= 2) { + // We get here when the token is an empty string. + // We encode this as MalTypeValue.String, with null .string_value + var string = Allocator.alloc(u8, 0) catch return MalError.SystemError; + mal_atom.data = MalData {.String = string}; + return; + } + + var tmp_buffer = Allocator.alloc(u8, n-2) catch return MalError.SystemError; + defer Allocator.free(tmp_buffer); + var i: usize = 1; + var j: usize = 0; + const escape_char: u8 = '\\'; //TODO: remove this comment required by bad emacs config ' + while(i < n-1) { + if(token[i] != escape_char) { + tmp_buffer[j] = token[i]; + j += 1; + i += 1; + } + else { + if(i==n-2) { + return MalError.ReaderUnmatchedString; + } + if(token[i+1] == 'n') { + tmp_buffer[j] = '\n'; + } else { + tmp_buffer[j] = token[i+1]; + } + j += 1; + i += 2; + } + } + + var string = Allocator.alloc(u8, j) catch return MalError.SystemError; + i = 0; + while(i < j) { + string[i] = tmp_buffer[i]; + i += 1; + } + + mal_atom.data = MalData {.String = string}; +} + +pub fn read_str(string: [] const u8) MalError!Reader { + if(re == null) { + re = pcre.pcre_compile(&match[0], 0, &error_msg, &erroroffset, 0); + } + const tokens = try tokenize(re, string); + return Reader.init(string, tokens); +} + +// Allocates an array of matches. Caller is becomes owner of memory. +pub fn tokenize(regex: ?*pcre.pcre, string: [] const u8) MalError![] usize { + // TODO: pass in allocator + const buffer_size: usize = 3 * string.len + 10; + var indices: [] c_int = Allocator.alloc(c_int, buffer_size) + catch return MalError.SystemError; + defer Allocator.free(indices); + var match_buffer: [] usize = Allocator.alloc(usize, buffer_size) + catch return MalError.SystemError; + defer Allocator.free(match_buffer); + var current_match: usize = 0; + var start_pos: c_int = 0; + + var rc: c_int = 0; + var start_match: usize = 0; + var end_match: usize = 0; + const subject_size: c_int = @intCast(c_int, string.len); + + while(start_pos < subject_size) { + rc = pcre.pcre_exec(regex, 0, &string[0], subject_size, start_pos, 0, + &indices[0], @intCast(c_int,buffer_size)); + if(rc <= 0) + break; + start_pos = indices[1]; + start_match = @intCast(usize, indices[2]); + end_match = @intCast(usize, indices[3]); + match_buffer[current_match] = start_match; + match_buffer[current_match+1] = end_match; + current_match += 2; + } + + var matches: [] usize = Allocator.alloc(usize, current_match) + catch return MalError.SystemError; + var i: usize = 0; + while(i < current_match) { + matches[i] = match_buffer[i]; + i += 1; + } + + return matches; +} diff --git a/impls/zig/readline.zig b/impls/zig/readline.zig index ed15d83f83..9dcf892e93 100644 --- a/impls/zig/readline.zig +++ b/impls/zig/readline.zig @@ -1,50 +1,50 @@ -const Allocator = @import("std").mem.Allocator; -const readline = @cImport( - @cInclude("readline/readline.h")); -const rl_hist = @cImport( - @cInclude("readline/history.h")); -const free = @import("std").c.free; -const addNullByte = @import("std").cstr.addNullByte; - -const warn = @import("std").debug.warn; - -pub fn slice_from_cstr(allocator: *Allocator, str: [*]const u8) ![]u8{ - var length: usize = 0; - while(true) { - if(str[length] == 0) - break; - length += 1; - } - // TODO: check for 0-length - const slice = try allocator.alloc(u8, length); - var i: usize = 0; - while(i < length) { - slice[i] = str[i]; - i += 1; - } - return slice; -} - -pub fn getline(allocator: *Allocator) !?[] u8 { - var input: ?[*] u8 = readline.readline(c"user> "); - if(input) |actual| { - const aslice = try slice_from_cstr(allocator, actual); - rl_hist.add_history(actual); - free(actual); - return aslice; - } - return null; -} - -pub fn getline_prompt(allocator: *Allocator, prompt: []const u8) !?[] u8 { - const null_terminated_prompt = try addNullByte(allocator, prompt); - var input: ?[*] u8 = readline.readline(&null_terminated_prompt[0]); - allocator.free(null_terminated_prompt); - if(input) |actual| { - const aslice = try slice_from_cstr(allocator, actual); - rl_hist.add_history(actual); - free(actual); - return aslice; - } - return null; -} +const Allocator = @import("std").mem.Allocator; +const readline = @cImport( + @cInclude("readline/readline.h")); +const rl_hist = @cImport( + @cInclude("readline/history.h")); +const free = @import("std").c.free; +const addNullByte = @import("std").cstr.addNullByte; + +const warn = @import("std").debug.warn; + +pub fn slice_from_cstr(allocator: *Allocator, str: [*]const u8) ![]u8{ + var length: usize = 0; + while(true) { + if(str[length] == 0) + break; + length += 1; + } + // TODO: check for 0-length + const slice = try allocator.alloc(u8, length); + var i: usize = 0; + while(i < length) { + slice[i] = str[i]; + i += 1; + } + return slice; +} + +pub fn getline(allocator: *Allocator) !?[] u8 { + var input: ?[*] u8 = readline.readline(c"user> "); + if(input) |actual| { + const aslice = try slice_from_cstr(allocator, actual); + rl_hist.add_history(actual); + free(actual); + return aslice; + } + return null; +} + +pub fn getline_prompt(allocator: *Allocator, prompt: []const u8) !?[] u8 { + const null_terminated_prompt = try addNullByte(allocator, prompt); + var input: ?[*] u8 = readline.readline(&null_terminated_prompt[0]); + allocator.free(null_terminated_prompt); + if(input) |actual| { + const aslice = try slice_from_cstr(allocator, actual); + rl_hist.add_history(actual); + free(actual); + return aslice; + } + return null; +} diff --git a/impls/zig/run b/impls/zig/run index 8ba68a5484..1e247fd04f 100755 --- a/impls/zig/run +++ b/impls/zig/run @@ -1,2 +1,2 @@ -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" diff --git a/impls/zig/step0_repl.zig b/impls/zig/step0_repl.zig index 265db0ff67..60b79dc7aa 100644 --- a/impls/zig/step0_repl.zig +++ b/impls/zig/step0_repl.zig @@ -1,36 +1,36 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const getline = @import("readline.zig").getline; - -const Allocator = @import("std").heap.c_allocator; - -fn READ(a: [] u8) [] u8 { - return a; -} - -fn EVAL(a: [] u8) [] u8 { - return a; -} - -fn PRINT(a: [] u8) [] u8 { - return a; -} - -fn rep(input: [] u8) [] u8 { - var read_input = READ(input); - var eval_input = EVAL(read_input); - var print_input = PRINT(eval_input); - return print_input; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - while(true) { - var line = (try getline(Allocator)) orelse break; - var output = rep(line); - try stdout_file.write(output); - Allocator.free(output); - try stdout_file.write("\n"); - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const getline = @import("readline.zig").getline; + +const Allocator = @import("std").heap.c_allocator; + +fn READ(a: [] u8) [] u8 { + return a; +} + +fn EVAL(a: [] u8) [] u8 { + return a; +} + +fn PRINT(a: [] u8) [] u8 { + return a; +} + +fn rep(input: [] u8) [] u8 { + var read_input = READ(input); + var eval_input = EVAL(read_input); + var print_input = PRINT(eval_input); + return print_input; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + while(true) { + var line = (try getline(Allocator)) orelse break; + var output = rep(line); + try stdout_file.write(output); + Allocator.free(output); + try stdout_file.write("\n"); + } +} diff --git a/impls/zig/step1_read_print.zig b/impls/zig/step1_read_print.zig index 0b0793d073..b5a12b53fb 100644 --- a/impls/zig/step1_read_print.zig +++ b/impls/zig/step1_read_print.zig @@ -1,46 +1,46 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const pcre = reader.pcre; -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; - -const Allocator = @import("std").heap.c_allocator; - -const MalType = @import("types.zig").MalType; - -fn READ(a: [] u8) !?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(a: ?*MalType) ?*MalType { - return a; -} - -fn PRINT(optional_mal: ?*MalType) ![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(input: [] u8) ![] u8 { - var read_input = READ(input) catch null; - var eval_input = EVAL(read_input); - var print_input = PRINT(eval_input); - if(eval_input) |mal| { - mal.delete(Allocator); - } - return print_input; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - while(true) { - var line = (try getline(Allocator)) orelse break; - var output = try rep(line); - try stdout_file.write(output); - Allocator.free(output); - try stdout_file.write("\n"); - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const pcre = reader.pcre; +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; + +const Allocator = @import("std").heap.c_allocator; + +const MalType = @import("types.zig").MalType; + +fn READ(a: [] u8) !?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(a: ?*MalType) ?*MalType { + return a; +} + +fn PRINT(optional_mal: ?*MalType) ![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(input: [] u8) ![] u8 { + var read_input = READ(input) catch null; + var eval_input = EVAL(read_input); + var print_input = PRINT(eval_input); + if(eval_input) |mal| { + mal.delete(Allocator); + } + return print_input; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + while(true) { + var line = (try getline(Allocator)) orelse break; + var output = try rep(line); + try stdout_file.write(output); + Allocator.free(output); + try stdout_file.write("\n"); + } +} diff --git a/impls/zig/step2_eval.zig b/impls/zig/step2_eval.zig index e71d3d37ba..8501210cf3 100644 --- a/impls/zig/step2_eval.zig +++ b/impls/zig/step2_eval.zig @@ -1,196 +1,196 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const pcre = reader.pcre; -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const apply_function = @import("types.zig").apply_function; -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); - -const Allocator = @import("std").heap.c_allocator; - -const MalType = @import("types.zig").MalType; -const MalData = @import("types.zig").MalData; -const MalError = @import("error.zig").MalError; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const MalHashMap = hash_map.MalHashMap; - -var repl_environment: *MalHashMap = undefined; - -fn READ(a: [] u8) MalError!?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(mal: *MalType) MalError!*MalType { - switch(mal.data) { - .List => |ll| { - if(ll.len == 0) { - return mal; - } - var new_list = try eval_ast(mal); - return apply_function(Allocator, (try new_list.sequence_linked_list()).*); - }, - else => { - return eval_ast(mal); - }, - } -} - -fn PRINT(optional_mal: ?*MalType) MalError![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(input: [] u8) MalError!?[] u8 { - var read_input = (try READ(input)) orelse return null; - var eval_input = try EVAL(read_input); - var print_input = try PRINT(eval_input); - eval_input.delete(Allocator); - return print_input; -} - -fn lookup(symbol: []const u8, do_warn: bool) MalError!*MalType { - var optional_mal = repl_environment.getValue(symbol); - if(optional_mal) |mal| { - return mal.copy(Allocator); - } - if(do_warn) { - const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; - const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; - defer Allocator.free(s1); - defer Allocator.free(s2); - warn("'{}' not found.\n", symbol); - } - return MalError.KeyError; -} - -fn eval_ast(mal: *MalType) MalError!*MalType { - switch(mal.data) { - .Generic => |symbol| { - defer mal.delete(Allocator); - return lookup(symbol, true); - }, - .List => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_list(Allocator, new_ll); - return ret_mal; - }, - .Vector => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_vector(Allocator, new_ll); - return ret_mal; - }, - .HashMap => |hmap| { - var new_hashmap = try MalType.new_hashmap(Allocator); - var iterator = hmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = pair.key; - const value = pair.value; - const evaled_value = try EVAL(value); - try new_hashmap.hashmap_insert(key, evaled_value); - optional_pair = iterator.next(); - } - hash_map.destroy(Allocator, hmap, true); - mal.shallow_destroy(Allocator); - return new_hashmap; - }, - else => { - return mal; - } - } -} - -const safeAdd = @import("std").math.add; -const safeSub = @import("std").math.sub; -const safeMul = @import("std").math.mul; -const safeDivFloor = @import("std").math.divFloor; - -fn int_plus(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeAdd(i64, x, y) catch return MalError.Overflow; - return MalType.new_int(Allocator, res); -} - -fn int_minus(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeSub(i64, x, y) catch return MalError.Overflow; - return MalType.new_int(Allocator, res); -} - -fn int_mult(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeMul(i64, x, y) catch return MalError.Overflow; - return MalType.new_int(Allocator, res); -} - -fn int_div(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeDivFloor(i64, x, y) catch |err| switch(err) { - error.DivisionByZero => return MalError.DivisionByZero, - else => return MalError.Overflow, - }; - return MalType.new_int(Allocator, res); -} - -fn make_environment() MalError!void { - repl_environment = Allocator.create(MalHashMap) catch return MalError.SystemError; - repl_environment.* = MalHashMap.init(Allocator); - - const plus_mal = try MalType.new_nil(Allocator); - plus_mal.data = MalData{.Fn2 = &int_plus}; - _ = repl_environment.put("+", plus_mal) catch return MalError.SystemError; - const minus_mal = try MalType.new_nil(Allocator); - minus_mal.data = MalData{.Fn2 = &int_minus}; - _ = repl_environment.put("-", minus_mal) catch return MalError.SystemError; - const mult_mal = try MalType.new_nil(Allocator); - mult_mal.data = MalData{.Fn2 = &int_mult}; - _ = repl_environment.put("*", mult_mal) catch return MalError.SystemError; - const div_mal = try MalType.new_nil(Allocator); - div_mal.data = MalData{.Fn2 = &int_div}; - _ = repl_environment.put("/", div_mal) catch return MalError.SystemError; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - try make_environment(); - while(true) { - var line = (try getline(Allocator)) orelse break; - var optional_output = rep(line) catch |err| { - if(err == MalError.KeyError) { - continue; - } else { - return err; - } - }; - if(optional_output) |output| { - try stdout_file.write(output); - Allocator.free(output); - try stdout_file.write("\n"); - } - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const pcre = reader.pcre; +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const apply_function = @import("types.zig").apply_function; +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); + +const Allocator = @import("std").heap.c_allocator; + +const MalType = @import("types.zig").MalType; +const MalData = @import("types.zig").MalData; +const MalError = @import("error.zig").MalError; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const MalHashMap = hash_map.MalHashMap; + +var repl_environment: *MalHashMap = undefined; + +fn READ(a: [] u8) MalError!?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(mal: *MalType) MalError!*MalType { + switch(mal.data) { + .List => |ll| { + if(ll.len == 0) { + return mal; + } + var new_list = try eval_ast(mal); + return apply_function(Allocator, (try new_list.sequence_linked_list()).*); + }, + else => { + return eval_ast(mal); + }, + } +} + +fn PRINT(optional_mal: ?*MalType) MalError![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(input: [] u8) MalError!?[] u8 { + var read_input = (try READ(input)) orelse return null; + var eval_input = try EVAL(read_input); + var print_input = try PRINT(eval_input); + eval_input.delete(Allocator); + return print_input; +} + +fn lookup(symbol: []const u8, do_warn: bool) MalError!*MalType { + var optional_mal = repl_environment.getValue(symbol); + if(optional_mal) |mal| { + return mal.copy(Allocator); + } + if(do_warn) { + const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; + const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; + defer Allocator.free(s1); + defer Allocator.free(s2); + warn("'{}' not found.\n", symbol); + } + return MalError.KeyError; +} + +fn eval_ast(mal: *MalType) MalError!*MalType { + switch(mal.data) { + .Generic => |symbol| { + defer mal.delete(Allocator); + return lookup(symbol, true); + }, + .List => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_list(Allocator, new_ll); + return ret_mal; + }, + .Vector => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_vector(Allocator, new_ll); + return ret_mal; + }, + .HashMap => |hmap| { + var new_hashmap = try MalType.new_hashmap(Allocator); + var iterator = hmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = pair.key; + const value = pair.value; + const evaled_value = try EVAL(value); + try new_hashmap.hashmap_insert(key, evaled_value); + optional_pair = iterator.next(); + } + hash_map.destroy(Allocator, hmap, true); + mal.shallow_destroy(Allocator); + return new_hashmap; + }, + else => { + return mal; + } + } +} + +const safeAdd = @import("std").math.add; +const safeSub = @import("std").math.sub; +const safeMul = @import("std").math.mul; +const safeDivFloor = @import("std").math.divFloor; + +fn int_plus(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeAdd(i64, x, y) catch return MalError.Overflow; + return MalType.new_int(Allocator, res); +} + +fn int_minus(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeSub(i64, x, y) catch return MalError.Overflow; + return MalType.new_int(Allocator, res); +} + +fn int_mult(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeMul(i64, x, y) catch return MalError.Overflow; + return MalType.new_int(Allocator, res); +} + +fn int_div(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeDivFloor(i64, x, y) catch |err| switch(err) { + error.DivisionByZero => return MalError.DivisionByZero, + else => return MalError.Overflow, + }; + return MalType.new_int(Allocator, res); +} + +fn make_environment() MalError!void { + repl_environment = Allocator.create(MalHashMap) catch return MalError.SystemError; + repl_environment.* = MalHashMap.init(Allocator); + + const plus_mal = try MalType.new_nil(Allocator); + plus_mal.data = MalData{.Fn2 = &int_plus}; + _ = repl_environment.put("+", plus_mal) catch return MalError.SystemError; + const minus_mal = try MalType.new_nil(Allocator); + minus_mal.data = MalData{.Fn2 = &int_minus}; + _ = repl_environment.put("-", minus_mal) catch return MalError.SystemError; + const mult_mal = try MalType.new_nil(Allocator); + mult_mal.data = MalData{.Fn2 = &int_mult}; + _ = repl_environment.put("*", mult_mal) catch return MalError.SystemError; + const div_mal = try MalType.new_nil(Allocator); + div_mal.data = MalData{.Fn2 = &int_div}; + _ = repl_environment.put("/", div_mal) catch return MalError.SystemError; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + try make_environment(); + while(true) { + var line = (try getline(Allocator)) orelse break; + var optional_output = rep(line) catch |err| { + if(err == MalError.KeyError) { + continue; + } else { + return err; + } + }; + if(optional_output) |output| { + try stdout_file.write(output); + Allocator.free(output); + try stdout_file.write("\n"); + } + } +} diff --git a/impls/zig/step3_env.zig b/impls/zig/step3_env.zig index 3d65470601..72a8b22ae0 100644 --- a/impls/zig/step3_env.zig +++ b/impls/zig/step3_env.zig @@ -1,254 +1,254 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const pcre = reader.pcre; -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const apply_function = @import("types.zig").apply_function; -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); - -const Allocator = @import("std").heap.c_allocator; - -const MalType = @import("types.zig").MalType; -const MalData = @import("types.zig").MalData; -const MalError = @import("error.zig").MalError; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const Env = @import("env.zig").Env; - -var repl_environment: *Env = undefined; - -fn READ(a: [] u8) MalError!?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(mal: *MalType, env: *Env) MalError!*MalType { - switch(mal.data) { - .List => |ll| { - if(ll.len == 0) { - return mal; - } - var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; - var symbol = switch(first_mal.data) { - .Generic => |symbol| symbol, - else => "", - }; - if(string_eql(symbol, "def!")) { - return EVAL_def(mal, env); - } - else if(string_eql(symbol, "let*")) { - return EVAL_let(mal, env); - } - else { - var new_list = try eval_ast(mal, env); - return apply_function(Allocator, (try new_list.sequence_linked_list()).*); - } - }, - else => { - return eval_ast(mal, env); - }, - } -} - -fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { - const first_arg = try mal.sequence_nth(1); - const second_arg = try mal.sequence_nth(2); - const second_arg_copy = try second_arg.copy(Allocator); - const symbol_name = try first_arg.as_symbol(); - const new_value = try EVAL(second_arg_copy, env); - try env.set(symbol_name, new_value); - mal.delete(Allocator); - return new_value.copy(Allocator); -} - -fn EVAL_let(mal: *MalType, env: *Env) MalError!*MalType { - const binding_arg = try mal.sequence_nth(1); - const eval_arg = try mal.sequence_nth(2); - const eval_arg_copy = try eval_arg.copy(Allocator); - const new_env = try Env.new(Allocator, env); - defer new_env.delete(); - var binding_ll = switch(binding_arg.data) { - .List => |l| l, - .Vector => |v| v, - else => return MalError.TypeError, - }; - var iterator = binding_ll.iterator(); - var optional_node = iterator.next(); - while(optional_node) |node| { - const key_mal = node; - const key = try key_mal.as_symbol(); - const val_mal = iterator.next() orelse return MalError.ArgError; - const evaled_mal = try EVAL(val_mal, new_env); - try new_env.set(key, evaled_mal); - optional_node = iterator.next(); - key_mal.delete(Allocator); - } - - linked_list.destroy(Allocator, &binding_ll, true); - binding_arg.data = MalData{.Nil=undefined}; - mal.delete(Allocator); - - // We use eval_arg_copy, since we just deleted eval_arg above - return EVAL(eval_arg_copy, new_env); -} - -fn PRINT(optional_mal: ?*MalType) MalError![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(environment: *Env, input: [] u8) MalError!?[] u8 { - var read_input = (try READ(input)) orelse return null; - var eval_input = try EVAL(read_input, environment); - var print_input = try PRINT(eval_input); - eval_input.delete(Allocator); - return print_input; -} - -fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { - var mal = environment.get(symbol) catch |err| { - if(do_warn) { - const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; - const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; - defer Allocator.free(s1); - defer Allocator.free(s2); - warn("'{}' not found.\n", symbol); - } - return MalError.KeyError; - }; - var new_mal = try mal.copy(Allocator); - return new_mal; -} - -fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { - switch(mal.data) { - .Generic => |symbol| { - defer mal.delete(Allocator); - return lookup(env, symbol, true); - }, - .List => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_list(Allocator, new_ll); - return ret_mal; - }, - .Vector => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_vector(Allocator, new_ll); - return ret_mal; - }, - .HashMap => |hmap| { - var new_hashmap = try MalType.new_hashmap(Allocator); - var iterator = hmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = pair.key; - const value = pair.value; - const evaled_value = try EVAL(value, try env.copy(Allocator)); - try new_hashmap.hashmap_insert(key, evaled_value); - optional_pair = iterator.next(); - } - hash_map.destroy(Allocator, hmap, true); - mal.shallow_destroy(Allocator); - return new_hashmap; - }, - else => { - return mal; - } - } -} - -const safeAdd = @import("std").math.add; -const safeSub = @import("std").math.sub; -const safeMul = @import("std").math.mul; -const safeDivFloor = @import("std").math.divFloor; - -fn int_plus(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeAdd(i64, x, y) catch return MalError.Overflow; - return MalType.new_int(Allocator, res); -} - -fn int_minus(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeSub(i64, x, y) catch return MalError.Overflow; - return MalType.new_int(Allocator, res); -} - -fn int_mult(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeMul(i64, x, y) catch return MalError.Overflow; - return MalType.new_int(Allocator, res); -} - -fn int_div(a1: *MalType, a2: *MalType) MalError!*MalType { - const x = try a1.as_int(); - const y = try a2.as_int(); - const res = safeDivFloor(i64, x, y) catch |err| switch(err) { - error.DivisionByZero => return MalError.DivisionByZero, - else => return MalError.Overflow, - }; - return MalType.new_int(Allocator, res); -} - -fn make_environment() MalError!*Env { - repl_environment = try Env.new(Allocator, null); - var environment = repl_environment; - - const plus_mal = try MalType.new_nil(Allocator); - plus_mal.data = MalData{.Fn2 = &int_plus}; - try environment.set("+", plus_mal); - const minus_mal = try MalType.new_nil(Allocator); - minus_mal.data = MalData{.Fn2 = &int_minus}; - try environment.set("-", minus_mal); - const mult_mal = try MalType.new_nil(Allocator); - mult_mal.data = MalData{.Fn2 = &int_mult}; - try environment.set("*", mult_mal); - const div_mal = try MalType.new_nil(Allocator); - div_mal.data = MalData{.Fn2 = &int_div}; - try environment.set("/", div_mal); - - return environment; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - var environment = try make_environment(); - while(true) { - var line = (try getline(Allocator)) orelse break; - var optional_output = rep(environment, line) catch |err| { - if(err == MalError.KeyError) { - continue; - } else { - return err; - } - }; - if(optional_output) |output| { - try stdout_file.write(output); - Allocator.free(output); - try stdout_file.write("\n"); - } - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const pcre = reader.pcre; +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const apply_function = @import("types.zig").apply_function; +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); + +const Allocator = @import("std").heap.c_allocator; + +const MalType = @import("types.zig").MalType; +const MalData = @import("types.zig").MalData; +const MalError = @import("error.zig").MalError; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const Env = @import("env.zig").Env; + +var repl_environment: *Env = undefined; + +fn READ(a: [] u8) MalError!?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(mal: *MalType, env: *Env) MalError!*MalType { + switch(mal.data) { + .List => |ll| { + if(ll.len == 0) { + return mal; + } + var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; + var symbol = switch(first_mal.data) { + .Generic => |symbol| symbol, + else => "", + }; + if(string_eql(symbol, "def!")) { + return EVAL_def(mal, env); + } + else if(string_eql(symbol, "let*")) { + return EVAL_let(mal, env); + } + else { + var new_list = try eval_ast(mal, env); + return apply_function(Allocator, (try new_list.sequence_linked_list()).*); + } + }, + else => { + return eval_ast(mal, env); + }, + } +} + +fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { + const first_arg = try mal.sequence_nth(1); + const second_arg = try mal.sequence_nth(2); + const second_arg_copy = try second_arg.copy(Allocator); + const symbol_name = try first_arg.as_symbol(); + const new_value = try EVAL(second_arg_copy, env); + try env.set(symbol_name, new_value); + mal.delete(Allocator); + return new_value.copy(Allocator); +} + +fn EVAL_let(mal: *MalType, env: *Env) MalError!*MalType { + const binding_arg = try mal.sequence_nth(1); + const eval_arg = try mal.sequence_nth(2); + const eval_arg_copy = try eval_arg.copy(Allocator); + const new_env = try Env.new(Allocator, env); + defer new_env.delete(); + var binding_ll = switch(binding_arg.data) { + .List => |l| l, + .Vector => |v| v, + else => return MalError.TypeError, + }; + var iterator = binding_ll.iterator(); + var optional_node = iterator.next(); + while(optional_node) |node| { + const key_mal = node; + const key = try key_mal.as_symbol(); + const val_mal = iterator.next() orelse return MalError.ArgError; + const evaled_mal = try EVAL(val_mal, new_env); + try new_env.set(key, evaled_mal); + optional_node = iterator.next(); + key_mal.delete(Allocator); + } + + linked_list.destroy(Allocator, &binding_ll, true); + binding_arg.data = MalData{.Nil=undefined}; + mal.delete(Allocator); + + // We use eval_arg_copy, since we just deleted eval_arg above + return EVAL(eval_arg_copy, new_env); +} + +fn PRINT(optional_mal: ?*MalType) MalError![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(environment: *Env, input: [] u8) MalError!?[] u8 { + var read_input = (try READ(input)) orelse return null; + var eval_input = try EVAL(read_input, environment); + var print_input = try PRINT(eval_input); + eval_input.delete(Allocator); + return print_input; +} + +fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { + var mal = environment.get(symbol) catch |err| { + if(do_warn) { + const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; + const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; + defer Allocator.free(s1); + defer Allocator.free(s2); + warn("'{}' not found.\n", symbol); + } + return MalError.KeyError; + }; + var new_mal = try mal.copy(Allocator); + return new_mal; +} + +fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { + switch(mal.data) { + .Generic => |symbol| { + defer mal.delete(Allocator); + return lookup(env, symbol, true); + }, + .List => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_list(Allocator, new_ll); + return ret_mal; + }, + .Vector => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_vector(Allocator, new_ll); + return ret_mal; + }, + .HashMap => |hmap| { + var new_hashmap = try MalType.new_hashmap(Allocator); + var iterator = hmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = pair.key; + const value = pair.value; + const evaled_value = try EVAL(value, try env.copy(Allocator)); + try new_hashmap.hashmap_insert(key, evaled_value); + optional_pair = iterator.next(); + } + hash_map.destroy(Allocator, hmap, true); + mal.shallow_destroy(Allocator); + return new_hashmap; + }, + else => { + return mal; + } + } +} + +const safeAdd = @import("std").math.add; +const safeSub = @import("std").math.sub; +const safeMul = @import("std").math.mul; +const safeDivFloor = @import("std").math.divFloor; + +fn int_plus(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeAdd(i64, x, y) catch return MalError.Overflow; + return MalType.new_int(Allocator, res); +} + +fn int_minus(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeSub(i64, x, y) catch return MalError.Overflow; + return MalType.new_int(Allocator, res); +} + +fn int_mult(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeMul(i64, x, y) catch return MalError.Overflow; + return MalType.new_int(Allocator, res); +} + +fn int_div(a1: *MalType, a2: *MalType) MalError!*MalType { + const x = try a1.as_int(); + const y = try a2.as_int(); + const res = safeDivFloor(i64, x, y) catch |err| switch(err) { + error.DivisionByZero => return MalError.DivisionByZero, + else => return MalError.Overflow, + }; + return MalType.new_int(Allocator, res); +} + +fn make_environment() MalError!*Env { + repl_environment = try Env.new(Allocator, null); + var environment = repl_environment; + + const plus_mal = try MalType.new_nil(Allocator); + plus_mal.data = MalData{.Fn2 = &int_plus}; + try environment.set("+", plus_mal); + const minus_mal = try MalType.new_nil(Allocator); + minus_mal.data = MalData{.Fn2 = &int_minus}; + try environment.set("-", minus_mal); + const mult_mal = try MalType.new_nil(Allocator); + mult_mal.data = MalData{.Fn2 = &int_mult}; + try environment.set("*", mult_mal); + const div_mal = try MalType.new_nil(Allocator); + div_mal.data = MalData{.Fn2 = &int_div}; + try environment.set("/", div_mal); + + return environment; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + var environment = try make_environment(); + while(true) { + var line = (try getline(Allocator)) orelse break; + var optional_output = rep(environment, line) catch |err| { + if(err == MalError.KeyError) { + continue; + } else { + return err; + } + }; + if(optional_output) |output| { + try stdout_file.write(output); + Allocator.free(output); + try stdout_file.write("\n"); + } + } +} diff --git a/impls/zig/step4_if_fn_do.zig b/impls/zig/step4_if_fn_do.zig index cc4cb24542..a18fa9d9dc 100644 --- a/impls/zig/step4_if_fn_do.zig +++ b/impls/zig/step4_if_fn_do.zig @@ -1,287 +1,287 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const pcre = reader.pcre; -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const apply_function = @import("types.zig").apply_function; -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); -const core = @import("core.zig"); - -const Allocator = @import("std").heap.c_allocator; - -const MalType = @import("types.zig").MalType; -const MalData = @import("types.zig").MalData; -const MalError = @import("error.zig").MalError; -const MalFuncData = @import("types.zig").MalFuncData; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const Env = @import("env.zig").Env; - -var repl_environment: *Env = undefined; - -fn READ(a: []const u8) MalError!?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(mal: *MalType, env: *Env) MalError!*MalType { - switch(mal.data) { - .List => |ll| { - if(ll.len == 0) { - return mal; - } - var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; - var symbol = switch(first_mal.data) { - .Generic => |symbol| symbol, - else => "", - }; - if(string_eql(symbol, "def!")) { - return EVAL_def(mal, env); - } - else if(string_eql(symbol, "let*")) { - return EVAL_let(mal, env); - } - else if(string_eql(symbol, "do")) { - return EVAL_do(mal, env); - } - else if(string_eql(symbol, "if")) { - return EVAL_if(mal, env); - } - else if(string_eql(symbol, "fn*")) { - return EVAL_fn(mal, env); - } - else { - var new_list = try eval_ast(mal, env); - return apply_function(Allocator, (try new_list.sequence_linked_list()).*); - } - }, - else => { - return eval_ast(mal, env); - }, - } -} - -fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { - const first_arg = try mal.sequence_nth(1); - const second_arg = try mal.sequence_nth(2); - const second_arg_copy = try second_arg.copy(Allocator); - const symbol_name = try first_arg.as_symbol(); - const new_value = try EVAL(second_arg_copy, env); - try env.set(symbol_name, new_value); - mal.delete(Allocator); - return new_value.copy(Allocator); -} - -fn EVAL_let(mal: *MalType, env: *Env) MalError!*MalType { - const binding_arg = try mal.sequence_nth(1); - const eval_arg = try mal.sequence_nth(2); - const eval_arg_copy = try eval_arg.copy(Allocator); - const new_env = try Env.new(Allocator, env); - defer new_env.delete(); - var binding_ll = switch(binding_arg.data) { - .List => |l| l, - .Vector => |v| v, - else => return MalError.TypeError, - }; - var iterator = binding_ll.iterator(); - var optional_node = iterator.next(); - while(optional_node) |node| { - const key_mal = node; - const key = try key_mal.as_symbol(); - const val_mal = iterator.next() orelse return MalError.ArgError; - const evaled_mal = try EVAL(val_mal, new_env); - try new_env.set(key, evaled_mal); - optional_node = iterator.next(); - key_mal.delete(Allocator); - } - - linked_list.destroy(Allocator, &binding_ll, true); - binding_arg.data = MalData{.Nil=undefined}; - mal.delete(Allocator); - - // We use eval_arg_copy, since we just deleted eval_arg above - return EVAL(eval_arg_copy, new_env); -} - -fn EVAL_do(mal: *MalType, env: *Env) MalError!*MalType { - var ll = &mal.data.List; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var evaled_mal = try eval_ast(mal, env); - var last_mal = try evaled_mal.sequence_pop_last(Allocator); - evaled_mal.delete(Allocator); - return last_mal; -} - -fn EVAL_if(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - const first_arg = try mal.sequence_nth(1); - const first_arg_copy = try first_arg.copy(Allocator); - const evaled = try EVAL(first_arg_copy, env); - const is_true = switch(evaled.data) { - .False => false, - .Nil => false, - else => true, - }; - if(is_true) { - const second_arg = try mal.sequence_nth(2); - const second_arg_copy = try second_arg.copy(Allocator); - return EVAL(second_arg_copy, env); - } - if((try mal.sequence_length()) < 4) { - return MalType.new_nil(Allocator); - } - const third_arg = try mal.sequence_nth(3); - const third_arg_copy = try third_arg.copy(Allocator); - return EVAL(third_arg_copy, env); -} - -fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); - const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); - const func_data = MalFuncData { - .arg_list = arg_mal, - .body = body_mal, - .environment = env, - .is_macro = false, - .eval_func = &EVAL, - }; - const new_func = try MalType.new_nil(Allocator); - new_func.data = MalData{.Func = func_data}; - return new_func; -} - -fn PRINT(optional_mal: ?*MalType) MalError![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { - var read_input = (try READ(input)) orelse return null; - var eval_input = try EVAL(read_input, try environment.copy(Allocator)); - var print_input = try PRINT(eval_input); - eval_input.delete(Allocator); - return print_input; -} - -fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { - var mal = environment.get(symbol) catch |err| { - if(do_warn) { - const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; - const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; - defer Allocator.free(s1); - defer Allocator.free(s2); - warn("'{}' not found.\n", symbol); - } - return MalError.KeyError; - }; - var new_mal = try mal.copy(Allocator); - return new_mal; -} - -fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { - switch(mal.data) { - .Generic => |symbol| { - defer mal.delete(Allocator); - return lookup(env, symbol, true); - }, - .List => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_list(Allocator, new_ll); - return ret_mal; - }, - .Vector => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_vector(Allocator, new_ll); - return ret_mal; - }, - .HashMap => |hmap| { - var new_hashmap = try MalType.new_hashmap(Allocator); - var iterator = hmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = pair.key; - const value = pair.value; - const evaled_value = try EVAL(value, try env.copy(Allocator)); - try new_hashmap.hashmap_insert(key, evaled_value); - optional_pair = iterator.next(); - } - hash_map.destroy(Allocator, hmap, true); - mal.shallow_destroy(Allocator); - return new_hashmap; - }, - else => { - return mal; - } - } -} - -fn make_environment() MalError!*Env { - repl_environment = try Env.new(Allocator, null); - var environment = try repl_environment.copy(Allocator); - - for(core.core_namespace) |pair| { - const name = pair.name; - const func_mal: *MalType = try MalType.new_nil(Allocator); - func_mal.data = switch(pair.func) { - core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, - core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, - core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, - core.CorePairType.FVar => |func| MalData{.FVar = func}, - else => return MalError.TypeError, - }; - try environment.set(name, func_mal); - } - - const def_not_string: [] const u8 = - \\(def! not (fn* (a) (if a false true))) - ; - var optional_output = try rep(environment, def_not_string); - if(optional_output) |output| { - Allocator.free(output); - } - - return environment; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - core.set_allocator(Allocator); - var environment = try make_environment(); - while(true) { - var line = (try getline(Allocator)) orelse break; - var optional_output = rep(environment, line) catch |err| { - if(err == MalError.KeyError) { - continue; - } else { - return err; - } - }; - if(optional_output) |output| { - try stdout_file.write(output); - Allocator.free(output); - Allocator.free(line); - try stdout_file.write("\n"); - } - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const pcre = reader.pcre; +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const apply_function = @import("types.zig").apply_function; +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); +const core = @import("core.zig"); + +const Allocator = @import("std").heap.c_allocator; + +const MalType = @import("types.zig").MalType; +const MalData = @import("types.zig").MalData; +const MalError = @import("error.zig").MalError; +const MalFuncData = @import("types.zig").MalFuncData; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const Env = @import("env.zig").Env; + +var repl_environment: *Env = undefined; + +fn READ(a: []const u8) MalError!?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(mal: *MalType, env: *Env) MalError!*MalType { + switch(mal.data) { + .List => |ll| { + if(ll.len == 0) { + return mal; + } + var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; + var symbol = switch(first_mal.data) { + .Generic => |symbol| symbol, + else => "", + }; + if(string_eql(symbol, "def!")) { + return EVAL_def(mal, env); + } + else if(string_eql(symbol, "let*")) { + return EVAL_let(mal, env); + } + else if(string_eql(symbol, "do")) { + return EVAL_do(mal, env); + } + else if(string_eql(symbol, "if")) { + return EVAL_if(mal, env); + } + else if(string_eql(symbol, "fn*")) { + return EVAL_fn(mal, env); + } + else { + var new_list = try eval_ast(mal, env); + return apply_function(Allocator, (try new_list.sequence_linked_list()).*); + } + }, + else => { + return eval_ast(mal, env); + }, + } +} + +fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { + const first_arg = try mal.sequence_nth(1); + const second_arg = try mal.sequence_nth(2); + const second_arg_copy = try second_arg.copy(Allocator); + const symbol_name = try first_arg.as_symbol(); + const new_value = try EVAL(second_arg_copy, env); + try env.set(symbol_name, new_value); + mal.delete(Allocator); + return new_value.copy(Allocator); +} + +fn EVAL_let(mal: *MalType, env: *Env) MalError!*MalType { + const binding_arg = try mal.sequence_nth(1); + const eval_arg = try mal.sequence_nth(2); + const eval_arg_copy = try eval_arg.copy(Allocator); + const new_env = try Env.new(Allocator, env); + defer new_env.delete(); + var binding_ll = switch(binding_arg.data) { + .List => |l| l, + .Vector => |v| v, + else => return MalError.TypeError, + }; + var iterator = binding_ll.iterator(); + var optional_node = iterator.next(); + while(optional_node) |node| { + const key_mal = node; + const key = try key_mal.as_symbol(); + const val_mal = iterator.next() orelse return MalError.ArgError; + const evaled_mal = try EVAL(val_mal, new_env); + try new_env.set(key, evaled_mal); + optional_node = iterator.next(); + key_mal.delete(Allocator); + } + + linked_list.destroy(Allocator, &binding_ll, true); + binding_arg.data = MalData{.Nil=undefined}; + mal.delete(Allocator); + + // We use eval_arg_copy, since we just deleted eval_arg above + return EVAL(eval_arg_copy, new_env); +} + +fn EVAL_do(mal: *MalType, env: *Env) MalError!*MalType { + var ll = &mal.data.List; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var evaled_mal = try eval_ast(mal, env); + var last_mal = try evaled_mal.sequence_pop_last(Allocator); + evaled_mal.delete(Allocator); + return last_mal; +} + +fn EVAL_if(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + const first_arg = try mal.sequence_nth(1); + const first_arg_copy = try first_arg.copy(Allocator); + const evaled = try EVAL(first_arg_copy, env); + const is_true = switch(evaled.data) { + .False => false, + .Nil => false, + else => true, + }; + if(is_true) { + const second_arg = try mal.sequence_nth(2); + const second_arg_copy = try second_arg.copy(Allocator); + return EVAL(second_arg_copy, env); + } + if((try mal.sequence_length()) < 4) { + return MalType.new_nil(Allocator); + } + const third_arg = try mal.sequence_nth(3); + const third_arg_copy = try third_arg.copy(Allocator); + return EVAL(third_arg_copy, env); +} + +fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); + const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); + const func_data = MalFuncData { + .arg_list = arg_mal, + .body = body_mal, + .environment = env, + .is_macro = false, + .eval_func = &EVAL, + }; + const new_func = try MalType.new_nil(Allocator); + new_func.data = MalData{.Func = func_data}; + return new_func; +} + +fn PRINT(optional_mal: ?*MalType) MalError![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { + var read_input = (try READ(input)) orelse return null; + var eval_input = try EVAL(read_input, try environment.copy(Allocator)); + var print_input = try PRINT(eval_input); + eval_input.delete(Allocator); + return print_input; +} + +fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { + var mal = environment.get(symbol) catch |err| { + if(do_warn) { + const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; + const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; + defer Allocator.free(s1); + defer Allocator.free(s2); + warn("'{}' not found.\n", symbol); + } + return MalError.KeyError; + }; + var new_mal = try mal.copy(Allocator); + return new_mal; +} + +fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { + switch(mal.data) { + .Generic => |symbol| { + defer mal.delete(Allocator); + return lookup(env, symbol, true); + }, + .List => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_list(Allocator, new_ll); + return ret_mal; + }, + .Vector => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_vector(Allocator, new_ll); + return ret_mal; + }, + .HashMap => |hmap| { + var new_hashmap = try MalType.new_hashmap(Allocator); + var iterator = hmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = pair.key; + const value = pair.value; + const evaled_value = try EVAL(value, try env.copy(Allocator)); + try new_hashmap.hashmap_insert(key, evaled_value); + optional_pair = iterator.next(); + } + hash_map.destroy(Allocator, hmap, true); + mal.shallow_destroy(Allocator); + return new_hashmap; + }, + else => { + return mal; + } + } +} + +fn make_environment() MalError!*Env { + repl_environment = try Env.new(Allocator, null); + var environment = try repl_environment.copy(Allocator); + + for(core.core_namespace) |pair| { + const name = pair.name; + const func_mal: *MalType = try MalType.new_nil(Allocator); + func_mal.data = switch(pair.func) { + core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, + core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, + core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, + core.CorePairType.FVar => |func| MalData{.FVar = func}, + else => return MalError.TypeError, + }; + try environment.set(name, func_mal); + } + + const def_not_string: [] const u8 = + \\(def! not (fn* (a) (if a false true))) + ; + var optional_output = try rep(environment, def_not_string); + if(optional_output) |output| { + Allocator.free(output); + } + + return environment; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + core.set_allocator(Allocator); + var environment = try make_environment(); + while(true) { + var line = (try getline(Allocator)) orelse break; + var optional_output = rep(environment, line) catch |err| { + if(err == MalError.KeyError) { + continue; + } else { + return err; + } + }; + if(optional_output) |output| { + try stdout_file.write(output); + Allocator.free(output); + Allocator.free(line); + try stdout_file.write("\n"); + } + } +} diff --git a/impls/zig/step5_tco.zig b/impls/zig/step5_tco.zig index 0bece1b341..ce5d7cb53d 100644 --- a/impls/zig/step5_tco.zig +++ b/impls/zig/step5_tco.zig @@ -1,302 +1,302 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const pcre = reader.pcre; -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const apply_function = @import("types.zig").apply_function; -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); -const core = @import("core.zig"); - -const Allocator = @import("std").heap.c_allocator; - -const MalType = @import("types.zig").MalType; -const MalData = @import("types.zig").MalData; -const MalError = @import("error.zig").MalError; -const MalFuncData = @import("types.zig").MalFuncData; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const Env = @import("env.zig").Env; - -var repl_environment: *Env = undefined; - -fn READ(a: []const u8) MalError!?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { - var mal = mal_arg; - var env = env_arg; - while(true) { - switch(mal.data) { - .List => |ll| { - if(ll.len == 0) { - return mal; - } - var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; - var symbol = switch(first_mal.data) { - .Generic => |symbol| symbol, - else => "", - }; - if(string_eql(symbol, "def!")) { - return EVAL_def(mal, env); - } - else if(string_eql(symbol, "let*")) { - try EVAL_let(&mal, &env); - continue; - } - else if(string_eql(symbol, "do")) { - try EVAL_do(&mal, &env); - continue; - } - else if(string_eql(symbol, "if")) { - try EVAL_if(&mal, &env); - continue; - } - else if(string_eql(symbol, "fn*")) { - return EVAL_fn(mal, env); - } - else { - var new_list = try eval_ast(mal, env); - return apply_function(Allocator, (try new_list.sequence_linked_list()).*); - } - }, - else => { - return eval_ast(mal, env); - }, - } - } -} - -fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { - const first_arg = try mal.sequence_nth(1); - const second_arg = try mal.sequence_nth(2); - const second_arg_copy = try second_arg.copy(Allocator); - const symbol_name = try first_arg.as_symbol(); - const new_value = try EVAL(second_arg_copy, env); - try env.set(symbol_name, new_value); - mal.delete(Allocator); - return new_value.copy(Allocator); -} - -fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - const mal = mal_ptr.*; - const env = env_ptr.*; - const binding_arg = try mal.sequence_nth(1); - const eval_arg = try mal.sequence_nth(2); - const eval_arg_copy = try eval_arg.copy(Allocator); - const new_env = try Env.new(Allocator, env); - var binding_ll = switch(binding_arg.data) { - .List => |l| l, - .Vector => |v| v, - else => return MalError.TypeError, - }; - var iterator = binding_ll.iterator(); - var optional_node = iterator.next(); - while(optional_node) |node| { - const key_mal = node; - const key = try key_mal.as_symbol(); - const val_mal = iterator.next() orelse return MalError.ArgError; - const evaled_mal = try EVAL(val_mal, new_env); - try new_env.set(key, evaled_mal); - optional_node = iterator.next(); - key_mal.delete(Allocator); - } - - linked_list.destroy(Allocator, &binding_ll, true); - binding_arg.data = MalData{.Nil=undefined}; - mal.delete(Allocator); - - // We use eval_arg_copy, since we just deleted eval_arg above - mal_ptr.* = eval_arg_copy; - env_ptr.* = new_env; -} - -fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - var ll = &mal.data.List; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var last_mal = try mal.sequence_pop_last(Allocator); - var evaled_mal = try eval_ast(mal, env); - evaled_mal.delete(Allocator); - - mal_ptr.* = last_mal; -} - -fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - defer mal.delete(Allocator); - const first_arg = try mal.sequence_nth(1); - const first_arg_copy = try first_arg.copy(Allocator); - const evaled = try EVAL(first_arg_copy, env); - const is_true = switch(evaled.data) { - .False => false, - .Nil => false, - else => true, - }; - if(is_true) { - const second_arg = try mal.sequence_nth(2); - mal_ptr.* = try second_arg.copy(Allocator); - return; - } - if((try mal.sequence_length()) < 4) { - mal_ptr.* = try MalType.new_nil(Allocator); - return; - } - const third_arg = try mal.sequence_nth(3); - const third_arg_copy = try third_arg.copy(Allocator); - mal_ptr.* = third_arg_copy; -} - -fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); - const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); - const func_data = MalFuncData { - .arg_list = arg_mal, - .body = body_mal, - .environment = env, - .is_macro = false, - .eval_func = &EVAL, - }; - const new_func = try MalType.new_nil(Allocator); - new_func.data = MalData{.Func = func_data}; - return new_func; -} - -fn PRINT(optional_mal: ?*MalType) MalError![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { - var read_input = (try READ(input)) orelse return null; - var eval_input = try EVAL(read_input, environment); - var print_input = try PRINT(eval_input); - eval_input.delete(Allocator); - return print_input; -} - -fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { - var mal = environment.get(symbol) catch |err| { - if(do_warn) { - const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; - const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; - defer Allocator.free(s1); - defer Allocator.free(s2); - warn("'{}' not found.\n", symbol); - } - return MalError.KeyError; - }; - var new_mal = try mal.copy(Allocator); - return new_mal; -} - -fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { - switch(mal.data) { - .Generic => |symbol| { - defer mal.delete(Allocator); - return lookup(env, symbol, true); - }, - .List => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_list(Allocator, new_ll); - return ret_mal; - }, - .Vector => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_vector(Allocator, new_ll); - return ret_mal; - }, - .HashMap => |hmap| { - var new_hashmap = try MalType.new_hashmap(Allocator); - var iterator = hmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = pair.key; - const value = pair.value; - const evaled_value = try EVAL(value, try env.copy(Allocator)); - try new_hashmap.hashmap_insert(key, evaled_value); - optional_pair = iterator.next(); - } - hash_map.destroy(Allocator, hmap, true); - mal.shallow_destroy(Allocator); - return new_hashmap; - }, - else => { - return mal; - } - } -} - -fn make_environment() MalError!*Env { - repl_environment = try Env.new(Allocator, null); - var environment = repl_environment; - - for(core.core_namespace) |pair| { - const name = pair.name; - const func_mal: *MalType = try MalType.new_nil(Allocator); - func_mal.data = switch(pair.func) { - core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, - core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, - core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, - core.CorePairType.FVar => |func| MalData{.FVar = func}, - else => return MalError.TypeError, - }; - try environment.set(name, func_mal); - } - - const def_not_string: [] const u8 = - \\(def! not (fn* (a) (if a false true))) - ; - var optional_output = try rep(environment, def_not_string); - if(optional_output) |output| { - Allocator.free(output); - } - - return environment; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - core.set_allocator(Allocator); - var environment = try make_environment(); - while(true) { - var line = (try getline(Allocator)) orelse break; - var optional_output = rep(environment, line) catch |err| { - if(err == MalError.KeyError) { - continue; - } else { - return err; - } - }; - if(optional_output) |output| { - try stdout_file.write(output); - Allocator.free(output); - Allocator.free(line); - try stdout_file.write("\n"); - } - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const pcre = reader.pcre; +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const apply_function = @import("types.zig").apply_function; +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); +const core = @import("core.zig"); + +const Allocator = @import("std").heap.c_allocator; + +const MalType = @import("types.zig").MalType; +const MalData = @import("types.zig").MalData; +const MalError = @import("error.zig").MalError; +const MalFuncData = @import("types.zig").MalFuncData; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const Env = @import("env.zig").Env; + +var repl_environment: *Env = undefined; + +fn READ(a: []const u8) MalError!?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { + var mal = mal_arg; + var env = env_arg; + while(true) { + switch(mal.data) { + .List => |ll| { + if(ll.len == 0) { + return mal; + } + var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; + var symbol = switch(first_mal.data) { + .Generic => |symbol| symbol, + else => "", + }; + if(string_eql(symbol, "def!")) { + return EVAL_def(mal, env); + } + else if(string_eql(symbol, "let*")) { + try EVAL_let(&mal, &env); + continue; + } + else if(string_eql(symbol, "do")) { + try EVAL_do(&mal, &env); + continue; + } + else if(string_eql(symbol, "if")) { + try EVAL_if(&mal, &env); + continue; + } + else if(string_eql(symbol, "fn*")) { + return EVAL_fn(mal, env); + } + else { + var new_list = try eval_ast(mal, env); + return apply_function(Allocator, (try new_list.sequence_linked_list()).*); + } + }, + else => { + return eval_ast(mal, env); + }, + } + } +} + +fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { + const first_arg = try mal.sequence_nth(1); + const second_arg = try mal.sequence_nth(2); + const second_arg_copy = try second_arg.copy(Allocator); + const symbol_name = try first_arg.as_symbol(); + const new_value = try EVAL(second_arg_copy, env); + try env.set(symbol_name, new_value); + mal.delete(Allocator); + return new_value.copy(Allocator); +} + +fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + const mal = mal_ptr.*; + const env = env_ptr.*; + const binding_arg = try mal.sequence_nth(1); + const eval_arg = try mal.sequence_nth(2); + const eval_arg_copy = try eval_arg.copy(Allocator); + const new_env = try Env.new(Allocator, env); + var binding_ll = switch(binding_arg.data) { + .List => |l| l, + .Vector => |v| v, + else => return MalError.TypeError, + }; + var iterator = binding_ll.iterator(); + var optional_node = iterator.next(); + while(optional_node) |node| { + const key_mal = node; + const key = try key_mal.as_symbol(); + const val_mal = iterator.next() orelse return MalError.ArgError; + const evaled_mal = try EVAL(val_mal, new_env); + try new_env.set(key, evaled_mal); + optional_node = iterator.next(); + key_mal.delete(Allocator); + } + + linked_list.destroy(Allocator, &binding_ll, true); + binding_arg.data = MalData{.Nil=undefined}; + mal.delete(Allocator); + + // We use eval_arg_copy, since we just deleted eval_arg above + mal_ptr.* = eval_arg_copy; + env_ptr.* = new_env; +} + +fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + var ll = &mal.data.List; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var last_mal = try mal.sequence_pop_last(Allocator); + var evaled_mal = try eval_ast(mal, env); + evaled_mal.delete(Allocator); + + mal_ptr.* = last_mal; +} + +fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + defer mal.delete(Allocator); + const first_arg = try mal.sequence_nth(1); + const first_arg_copy = try first_arg.copy(Allocator); + const evaled = try EVAL(first_arg_copy, env); + const is_true = switch(evaled.data) { + .False => false, + .Nil => false, + else => true, + }; + if(is_true) { + const second_arg = try mal.sequence_nth(2); + mal_ptr.* = try second_arg.copy(Allocator); + return; + } + if((try mal.sequence_length()) < 4) { + mal_ptr.* = try MalType.new_nil(Allocator); + return; + } + const third_arg = try mal.sequence_nth(3); + const third_arg_copy = try third_arg.copy(Allocator); + mal_ptr.* = third_arg_copy; +} + +fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); + const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); + const func_data = MalFuncData { + .arg_list = arg_mal, + .body = body_mal, + .environment = env, + .is_macro = false, + .eval_func = &EVAL, + }; + const new_func = try MalType.new_nil(Allocator); + new_func.data = MalData{.Func = func_data}; + return new_func; +} + +fn PRINT(optional_mal: ?*MalType) MalError![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { + var read_input = (try READ(input)) orelse return null; + var eval_input = try EVAL(read_input, environment); + var print_input = try PRINT(eval_input); + eval_input.delete(Allocator); + return print_input; +} + +fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { + var mal = environment.get(symbol) catch |err| { + if(do_warn) { + const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; + const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; + defer Allocator.free(s1); + defer Allocator.free(s2); + warn("'{}' not found.\n", symbol); + } + return MalError.KeyError; + }; + var new_mal = try mal.copy(Allocator); + return new_mal; +} + +fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { + switch(mal.data) { + .Generic => |symbol| { + defer mal.delete(Allocator); + return lookup(env, symbol, true); + }, + .List => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_list(Allocator, new_ll); + return ret_mal; + }, + .Vector => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_vector(Allocator, new_ll); + return ret_mal; + }, + .HashMap => |hmap| { + var new_hashmap = try MalType.new_hashmap(Allocator); + var iterator = hmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = pair.key; + const value = pair.value; + const evaled_value = try EVAL(value, try env.copy(Allocator)); + try new_hashmap.hashmap_insert(key, evaled_value); + optional_pair = iterator.next(); + } + hash_map.destroy(Allocator, hmap, true); + mal.shallow_destroy(Allocator); + return new_hashmap; + }, + else => { + return mal; + } + } +} + +fn make_environment() MalError!*Env { + repl_environment = try Env.new(Allocator, null); + var environment = repl_environment; + + for(core.core_namespace) |pair| { + const name = pair.name; + const func_mal: *MalType = try MalType.new_nil(Allocator); + func_mal.data = switch(pair.func) { + core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, + core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, + core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, + core.CorePairType.FVar => |func| MalData{.FVar = func}, + else => return MalError.TypeError, + }; + try environment.set(name, func_mal); + } + + const def_not_string: [] const u8 = + \\(def! not (fn* (a) (if a false true))) + ; + var optional_output = try rep(environment, def_not_string); + if(optional_output) |output| { + Allocator.free(output); + } + + return environment; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + core.set_allocator(Allocator); + var environment = try make_environment(); + while(true) { + var line = (try getline(Allocator)) orelse break; + var optional_output = rep(environment, line) catch |err| { + if(err == MalError.KeyError) { + continue; + } else { + return err; + } + }; + if(optional_output) |output| { + try stdout_file.write(output); + Allocator.free(output); + Allocator.free(line); + try stdout_file.write("\n"); + } + } +} diff --git a/impls/zig/step6_file.zig b/impls/zig/step6_file.zig index ca897bd160..2cbc16db30 100644 --- a/impls/zig/step6_file.zig +++ b/impls/zig/step6_file.zig @@ -1,371 +1,371 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const pcre = reader.pcre; -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const apply_function = @import("types.zig").apply_function; -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); -const core = @import("core.zig"); - -const Allocator = @import("std").heap.c_allocator; - -const MalType = @import("types.zig").MalType; -const MalTypeValue = @import("types.zig").MalTypeValue; -const MalData = @import("types.zig").MalData; -const MalError = @import("error.zig").MalError; -const MalFuncData = @import("types.zig").MalFuncData; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const Env = @import("env.zig").Env; - -var repl_environment: *Env = undefined; - -fn READ(a: []const u8) MalError!?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { - var mal = mal_arg; - var env = env_arg; - while(true) { - switch(mal.data) { - .List => |ll| { - if(ll.len == 0) { - return mal; - } - var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; - var symbol = switch(first_mal.data) { - .Generic => |symbol| symbol, - else => "", - }; - if(string_eql(symbol, "def!")) { - return EVAL_def(mal, env); - } - else if(string_eql(symbol, "let*")) { - try EVAL_let(&mal, &env); - continue; - } - else if(string_eql(symbol, "do")) { - try EVAL_do(&mal, &env); - continue; - } - else if(string_eql(symbol, "if")) { - try EVAL_if(&mal, &env); - continue; - } - else if(string_eql(symbol, "fn*")) { - return EVAL_fn(mal, env); - } - else { - var new_list = try eval_ast(mal, try env.copy(Allocator)); - - if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { - try do_user_func(try new_list.sequence_linked_list(), &mal, &env); - new_list.shallow_destroy(Allocator); - continue; - } - const res = try apply_function(Allocator, (try new_list.sequence_linked_list()).*); - new_list.delete(Allocator); - env.delete(); - return res; - } - }, - else => { - return eval_ast(mal, env); - }, - } - } -} - -fn eval(a1: *MalType) MalError!*MalType { - return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); -} - -fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { - const first_arg = try mal.sequence_nth(1); - const second_arg = try mal.sequence_nth(2); - const second_arg_copy = try second_arg.copy(Allocator); - const symbol_name = try first_arg.as_symbol(); - const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); - try env.set(symbol_name, new_value); - mal.delete(Allocator); - env.delete(); - return new_value.copy(Allocator); -} - -fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - //TODO: make faster - const mal = mal_ptr.*; - const env = env_ptr.*; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - const binding_arg = try mal.sequence_pop_first(Allocator); - const eval_arg = try mal.sequence_pop_first(Allocator); - const new_env = try Env.new(Allocator, env); - var binding_ll = switch(binding_arg.data) { - .List => |l| l, - .Vector => |v| v, - else => return MalError.TypeError, - }; - var iterator = binding_ll.iterator(); - var optional_node = iterator.next(); - while(optional_node) |node| { - const key_mal = node; - const key = try key_mal.as_symbol(); - const val_mal = iterator.next() orelse return MalError.ArgError; - const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); - try new_env.set(key, evaled_mal); - optional_node = iterator.next(); - key_mal.delete(Allocator); - } - - linked_list.destroy(Allocator, &binding_ll, true); - binding_arg.data = MalData{.Nil=undefined}; - binding_arg.delete(Allocator); - mal.delete(Allocator); - - // We use eval_arg_copy, since we just deleted eval_arg above - mal_ptr.* = eval_arg; - env.delete(); - env_ptr.* = new_env; -} - -fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - var ll = &mal.data.List; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var last_mal = try mal.sequence_pop_last(Allocator); - var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); - evaled_mal.delete(Allocator); - mal_ptr.* = last_mal; -} - -fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - defer mal.delete(Allocator); - const first_arg = try mal.sequence_nth(1); - const first_arg_copy = try first_arg.copy(Allocator); - const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); - const is_true = switch(evaled.data) { - .False => false, - .Nil => false, - else => true, - }; - evaled.delete(Allocator); - if(is_true) { - const second_arg = try mal.sequence_nth(2); - mal_ptr.* = try second_arg.copy(Allocator); - return; - } - if((try mal.sequence_length()) < 4) { - mal_ptr.* = try MalType.new_nil(Allocator); - return; - } - const third_arg = try mal.sequence_nth(3); - const third_arg_copy = try third_arg.copy(Allocator); - mal_ptr.* = third_arg_copy; -} - -fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); - const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); - const func_data = MalFuncData { - .arg_list = arg_mal, - .body = body_mal, - .environment = env, - .is_macro = false, - .eval_func = &EVAL, - }; - const new_func = try MalType.new_nil(Allocator); - new_func.data = MalData{.Func = func_data}; - return new_func; -} - -fn PRINT(optional_mal: ?*MalType) MalError![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { - var read_input = (try READ(input)) orelse return null; - var eval_input = try EVAL(read_input, try environment.copy(Allocator)); - var print_input = try PRINT(eval_input); - eval_input.delete(Allocator); - return print_input; -} - -fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { - var mal = environment.get(symbol) catch |err| { - if(do_warn) { - const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; - const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; - defer Allocator.free(s1); - defer Allocator.free(s2); - warn("'{}' not found.\n", symbol); - } - return MalError.KeyError; - }; - var new_mal = try mal.copy(Allocator); - return new_mal; -} - -fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { - defer env.delete(); - switch(mal.data) { - .Generic => |symbol| { - defer mal.delete(Allocator); - return lookup(env, symbol, true); - }, - .List => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_list(Allocator, new_ll); - return ret_mal; - }, - .Vector => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_vector(Allocator, new_ll); - return ret_mal; - }, - .HashMap => |hmap| { - var new_hashmap = try MalType.new_hashmap(Allocator); - var iterator = hmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = pair.key; - const value = pair.value; - const evaled_value = try EVAL(value, try env.copy(Allocator)); - try new_hashmap.hashmap_insert(key, evaled_value); - optional_pair = iterator.next(); - } - hash_map.destroy(Allocator, hmap, true); - mal.shallow_destroy(Allocator); - return new_hashmap; - }, - else => { - return mal; - } - } -} - -fn make_environment() MalError!*Env { - repl_environment = try Env.new(Allocator, null); - var environment = try repl_environment.copy(Allocator); - - for(core.core_namespace) |pair| { - const name = pair.name; - const func_mal: *MalType = try MalType.new_nil(Allocator); - func_mal.data = switch(pair.func) { - core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, - core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, - core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, - core.CorePairType.FVar => |func| MalData{.FVar = func}, - else => return MalError.TypeError, - }; - try environment.set(name, func_mal); - } - - const eval_mal = try MalType.new_nil(Allocator); - eval_mal.data = MalData{.Fn1 = &eval}; - try environment.set("eval", eval_mal); - - const def_not_string: [] const u8 = - \\(def! not (fn* (a) (if a false true))) - ; - var optional_output = try rep(environment, def_not_string); - if(optional_output) |output| { - Allocator.free(output); - } - - const load_file_string: [] const u8 = - \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - ; - optional_output = try rep(environment, load_file_string); - if(optional_output) |output| { - Allocator.free(output); - } - - return environment; -} - -fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { - const mal_func = try linked_list.pop_first(Allocator, args); - const env = env_ptr.*; - // First check if it is a user-defined Mal function - if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { - const func_data = mal_func.data.Func; - const args_ll = try func_data.arg_list.sequence_linked_list(); - const func_env = func_data.environment; - var new_env = try Env.new(Allocator, func_env); - func_env.delete(); - try new_env.set_list(args_ll.*, args.*); - linked_list.destroy(Allocator, args, true); - func_data.arg_list.delete(Allocator); - mal_func.shallow_destroy(Allocator); - mal_ptr.* = func_data.body; - env.delete(); - env_ptr.* = new_env; - return; - } - return MalError.TypeError; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - core.set_allocator(Allocator); - var environment = try make_environment(); - - const args = try std.process.argsAlloc(Allocator); - var arg_list = try MalType.new_list_empty(Allocator); - for(args) |arg,i| { - if(i < 2) continue; - const new_mal = try MalType.new_string(Allocator, arg); - try arg_list.sequence_append(Allocator, new_mal); - } - try environment.set("*ARGV*", arg_list); - - if(args.len > 1) { - const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); - var output = try rep(environment, run_cmd); - return; - } - - while(true) { - var line = (try getline(Allocator)) orelse break; - var optional_output = rep(environment, line) catch |err| { - if(err == MalError.KeyError) { - continue; - } else { - return err; - } - }; - if(optional_output) |output| { - try stdout_file.write(output); - Allocator.free(output); - Allocator.free(line); - try stdout_file.write("\n"); - } - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const pcre = reader.pcre; +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const apply_function = @import("types.zig").apply_function; +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); +const core = @import("core.zig"); + +const Allocator = @import("std").heap.c_allocator; + +const MalType = @import("types.zig").MalType; +const MalTypeValue = @import("types.zig").MalTypeValue; +const MalData = @import("types.zig").MalData; +const MalError = @import("error.zig").MalError; +const MalFuncData = @import("types.zig").MalFuncData; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const Env = @import("env.zig").Env; + +var repl_environment: *Env = undefined; + +fn READ(a: []const u8) MalError!?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { + var mal = mal_arg; + var env = env_arg; + while(true) { + switch(mal.data) { + .List => |ll| { + if(ll.len == 0) { + return mal; + } + var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; + var symbol = switch(first_mal.data) { + .Generic => |symbol| symbol, + else => "", + }; + if(string_eql(symbol, "def!")) { + return EVAL_def(mal, env); + } + else if(string_eql(symbol, "let*")) { + try EVAL_let(&mal, &env); + continue; + } + else if(string_eql(symbol, "do")) { + try EVAL_do(&mal, &env); + continue; + } + else if(string_eql(symbol, "if")) { + try EVAL_if(&mal, &env); + continue; + } + else if(string_eql(symbol, "fn*")) { + return EVAL_fn(mal, env); + } + else { + var new_list = try eval_ast(mal, try env.copy(Allocator)); + + if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { + try do_user_func(try new_list.sequence_linked_list(), &mal, &env); + new_list.shallow_destroy(Allocator); + continue; + } + const res = try apply_function(Allocator, (try new_list.sequence_linked_list()).*); + new_list.delete(Allocator); + env.delete(); + return res; + } + }, + else => { + return eval_ast(mal, env); + }, + } + } +} + +fn eval(a1: *MalType) MalError!*MalType { + return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); +} + +fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { + const first_arg = try mal.sequence_nth(1); + const second_arg = try mal.sequence_nth(2); + const second_arg_copy = try second_arg.copy(Allocator); + const symbol_name = try first_arg.as_symbol(); + const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); + try env.set(symbol_name, new_value); + mal.delete(Allocator); + env.delete(); + return new_value.copy(Allocator); +} + +fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + //TODO: make faster + const mal = mal_ptr.*; + const env = env_ptr.*; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + const binding_arg = try mal.sequence_pop_first(Allocator); + const eval_arg = try mal.sequence_pop_first(Allocator); + const new_env = try Env.new(Allocator, env); + var binding_ll = switch(binding_arg.data) { + .List => |l| l, + .Vector => |v| v, + else => return MalError.TypeError, + }; + var iterator = binding_ll.iterator(); + var optional_node = iterator.next(); + while(optional_node) |node| { + const key_mal = node; + const key = try key_mal.as_symbol(); + const val_mal = iterator.next() orelse return MalError.ArgError; + const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); + try new_env.set(key, evaled_mal); + optional_node = iterator.next(); + key_mal.delete(Allocator); + } + + linked_list.destroy(Allocator, &binding_ll, true); + binding_arg.data = MalData{.Nil=undefined}; + binding_arg.delete(Allocator); + mal.delete(Allocator); + + // We use eval_arg_copy, since we just deleted eval_arg above + mal_ptr.* = eval_arg; + env.delete(); + env_ptr.* = new_env; +} + +fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + var ll = &mal.data.List; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var last_mal = try mal.sequence_pop_last(Allocator); + var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); + evaled_mal.delete(Allocator); + mal_ptr.* = last_mal; +} + +fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + defer mal.delete(Allocator); + const first_arg = try mal.sequence_nth(1); + const first_arg_copy = try first_arg.copy(Allocator); + const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); + const is_true = switch(evaled.data) { + .False => false, + .Nil => false, + else => true, + }; + evaled.delete(Allocator); + if(is_true) { + const second_arg = try mal.sequence_nth(2); + mal_ptr.* = try second_arg.copy(Allocator); + return; + } + if((try mal.sequence_length()) < 4) { + mal_ptr.* = try MalType.new_nil(Allocator); + return; + } + const third_arg = try mal.sequence_nth(3); + const third_arg_copy = try third_arg.copy(Allocator); + mal_ptr.* = third_arg_copy; +} + +fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); + const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); + const func_data = MalFuncData { + .arg_list = arg_mal, + .body = body_mal, + .environment = env, + .is_macro = false, + .eval_func = &EVAL, + }; + const new_func = try MalType.new_nil(Allocator); + new_func.data = MalData{.Func = func_data}; + return new_func; +} + +fn PRINT(optional_mal: ?*MalType) MalError![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { + var read_input = (try READ(input)) orelse return null; + var eval_input = try EVAL(read_input, try environment.copy(Allocator)); + var print_input = try PRINT(eval_input); + eval_input.delete(Allocator); + return print_input; +} + +fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { + var mal = environment.get(symbol) catch |err| { + if(do_warn) { + const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; + const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; + defer Allocator.free(s1); + defer Allocator.free(s2); + warn("'{}' not found.\n", symbol); + } + return MalError.KeyError; + }; + var new_mal = try mal.copy(Allocator); + return new_mal; +} + +fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { + defer env.delete(); + switch(mal.data) { + .Generic => |symbol| { + defer mal.delete(Allocator); + return lookup(env, symbol, true); + }, + .List => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_list(Allocator, new_ll); + return ret_mal; + }, + .Vector => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_vector(Allocator, new_ll); + return ret_mal; + }, + .HashMap => |hmap| { + var new_hashmap = try MalType.new_hashmap(Allocator); + var iterator = hmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = pair.key; + const value = pair.value; + const evaled_value = try EVAL(value, try env.copy(Allocator)); + try new_hashmap.hashmap_insert(key, evaled_value); + optional_pair = iterator.next(); + } + hash_map.destroy(Allocator, hmap, true); + mal.shallow_destroy(Allocator); + return new_hashmap; + }, + else => { + return mal; + } + } +} + +fn make_environment() MalError!*Env { + repl_environment = try Env.new(Allocator, null); + var environment = try repl_environment.copy(Allocator); + + for(core.core_namespace) |pair| { + const name = pair.name; + const func_mal: *MalType = try MalType.new_nil(Allocator); + func_mal.data = switch(pair.func) { + core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, + core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, + core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, + core.CorePairType.FVar => |func| MalData{.FVar = func}, + else => return MalError.TypeError, + }; + try environment.set(name, func_mal); + } + + const eval_mal = try MalType.new_nil(Allocator); + eval_mal.data = MalData{.Fn1 = &eval}; + try environment.set("eval", eval_mal); + + const def_not_string: [] const u8 = + \\(def! not (fn* (a) (if a false true))) + ; + var optional_output = try rep(environment, def_not_string); + if(optional_output) |output| { + Allocator.free(output); + } + + const load_file_string: [] const u8 = + \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + ; + optional_output = try rep(environment, load_file_string); + if(optional_output) |output| { + Allocator.free(output); + } + + return environment; +} + +fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { + const mal_func = try linked_list.pop_first(Allocator, args); + const env = env_ptr.*; + // First check if it is a user-defined Mal function + if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { + const func_data = mal_func.data.Func; + const args_ll = try func_data.arg_list.sequence_linked_list(); + const func_env = func_data.environment; + var new_env = try Env.new(Allocator, func_env); + func_env.delete(); + try new_env.set_list(args_ll.*, args.*); + linked_list.destroy(Allocator, args, true); + func_data.arg_list.delete(Allocator); + mal_func.shallow_destroy(Allocator); + mal_ptr.* = func_data.body; + env.delete(); + env_ptr.* = new_env; + return; + } + return MalError.TypeError; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + core.set_allocator(Allocator); + var environment = try make_environment(); + + const args = try std.process.argsAlloc(Allocator); + var arg_list = try MalType.new_list_empty(Allocator); + for(args) |arg,i| { + if(i < 2) continue; + const new_mal = try MalType.new_string(Allocator, arg); + try arg_list.sequence_append(Allocator, new_mal); + } + try environment.set("*ARGV*", arg_list); + + if(args.len > 1) { + const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); + var output = try rep(environment, run_cmd); + return; + } + + while(true) { + var line = (try getline(Allocator)) orelse break; + var optional_output = rep(environment, line) catch |err| { + if(err == MalError.KeyError) { + continue; + } else { + return err; + } + }; + if(optional_output) |output| { + try stdout_file.write(output); + Allocator.free(output); + Allocator.free(line); + try stdout_file.write("\n"); + } + } +} diff --git a/impls/zig/step7_quote.zig b/impls/zig/step7_quote.zig index 0b26ed2583..092be9fe91 100644 --- a/impls/zig/step7_quote.zig +++ b/impls/zig/step7_quote.zig @@ -1,456 +1,456 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const pcre = reader.pcre; -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const apply_function = @import("types.zig").apply_function; -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); -const core = @import("core.zig"); - -const Allocator = @import("std").heap.c_allocator; - -const MalType = @import("types.zig").MalType; -const MalTypeValue = @import("types.zig").MalTypeValue; -const MalData = @import("types.zig").MalData; -const MalError = @import("error.zig").MalError; -const MalFuncData = @import("types.zig").MalFuncData; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const Env = @import("env.zig").Env; - -var repl_environment: *Env = undefined; - -fn READ(a: []const u8) MalError!?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { - var mal = mal_arg; - var env = env_arg; - while(true) { - switch(mal.data) { - .List => |ll| { - if(ll.len == 0) { - return mal; - } - var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; - var symbol = switch(first_mal.data) { - .Generic => |symbol| symbol, - else => "", - }; - if(string_eql(symbol, "def!")) { - return EVAL_def(mal, env); - } - else if(string_eql(symbol, "let*")) { - try EVAL_let(&mal, &env); - continue; - } - else if(string_eql(symbol, "do")) { - try EVAL_do(&mal, &env); - continue; - } - else if(string_eql(symbol, "if")) { - try EVAL_if(&mal, &env); - continue; - } - else if(string_eql(symbol, "fn*")) { - return EVAL_fn(mal, env); - } - else if(string_eql(symbol, "quote")) { - return EVAL_quote(mal, env); - } - else if(string_eql(symbol, "quasiquoteexpand")) { - env.delete(); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - mal.delete(Allocator); - return try quasiquote(second); - } - else if(string_eql(symbol, "quasiquote")) { - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - mal.delete(Allocator); - mal = try quasiquote(second); - continue; - } - else { - var new_list = try eval_ast(mal, try env.copy(Allocator)); - - if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { - try do_user_func(try new_list.sequence_linked_list(), &mal, &env); - new_list.shallow_destroy(Allocator); - continue; - } - const res = try apply_function(Allocator, (try new_list.sequence_linked_list()).*); - new_list.delete(Allocator); - env.delete(); - return res; - } - }, - else => { - return eval_ast(mal, env); - }, - } - } -} - -fn eval(a1: *MalType) MalError!*MalType { - return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); -} - -fn starts_with(ast: *MalType, sym: []const u8) bool { - const ll = switch(ast.data) { - .List => |l| l, - else => return false, - }; - if(ll.count() < 2) { - return false; - } - const ss = switch(ll.at(0).data) { - .Generic => |s| s, - else => return false, - }; - return string_eql(ss, sym); -} - -fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { - const first_arg = try mal.sequence_nth(1); - const second_arg = try mal.sequence_nth(2); - const second_arg_copy = try second_arg.copy(Allocator); - const symbol_name = try first_arg.as_symbol(); - const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); - try env.set(symbol_name, new_value); - mal.delete(Allocator); - env.delete(); - return new_value.copy(Allocator); -} - -fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - //TODO: make faster - const mal = mal_ptr.*; - const env = env_ptr.*; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - const binding_arg = try mal.sequence_pop_first(Allocator); - const eval_arg = try mal.sequence_pop_first(Allocator); - const new_env = try Env.new(Allocator, env); - var binding_ll = switch(binding_arg.data) { - .List => |l| l, - .Vector => |v| v, - else => return MalError.TypeError, - }; - var iterator = binding_ll.iterator(); - var optional_node = iterator.next(); - while(optional_node) |node| { - const key_mal = node; - const key = try key_mal.as_symbol(); - const val_mal = iterator.next() orelse return MalError.ArgError; - const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); - try new_env.set(key, evaled_mal); - optional_node = iterator.next(); - key_mal.delete(Allocator); - } - - linked_list.destroy(Allocator, &binding_ll, true); - binding_arg.data = MalData{.Nil=undefined}; - binding_arg.delete(Allocator); - mal.delete(Allocator); - - // We use eval_arg_copy, since we just deleted eval_arg above - mal_ptr.* = eval_arg; - env.delete(); - env_ptr.* = new_env; -} - -fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - var ll = &mal.data.List; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var last_mal = try mal.sequence_pop_last(Allocator); - var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); - evaled_mal.delete(Allocator); - mal_ptr.* = last_mal; -} - -fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - defer mal.delete(Allocator); - const first_arg = try mal.sequence_nth(1); - const first_arg_copy = try first_arg.copy(Allocator); - const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); - const is_true = switch(evaled.data) { - .False => false, - .Nil => false, - else => true, - }; - evaled.delete(Allocator); - if(is_true) { - const second_arg = try mal.sequence_nth(2); - mal_ptr.* = try second_arg.copy(Allocator); - return; - } - if((try mal.sequence_length()) < 4) { - mal_ptr.* = try MalType.new_nil(Allocator); - return; - } - const third_arg = try mal.sequence_nth(3); - const third_arg_copy = try third_arg.copy(Allocator); - mal_ptr.* = third_arg_copy; -} - -fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); - const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); - const func_data = MalFuncData { - .arg_list = arg_mal, - .body = body_mal, - .environment = env, - .is_macro = false, - .eval_func = &EVAL, - }; - const new_func = try MalType.new_nil(Allocator); - new_func.data = MalData{.Func = func_data}; - return new_func; -} - -fn EVAL_quote(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - defer env.delete(); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - return try mal.sequence_pop_first(Allocator); -} - -fn quasiquote(ast: *MalType) MalError!*MalType { - const kind = MalTypeValue(ast.data); - if(kind == MalTypeValue.Generic or kind == MalTypeValue.HashMap) { - const new_list = try MalType.new_list_empty(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "quote")); - try new_list.sequence_append(Allocator, ast); - return new_list; - } - - if(kind != MalTypeValue.List and kind != MalTypeValue.Vector) { - return ast; - } - - defer ast.delete(Allocator); - - if(starts_with(ast, "unquote")) { - (try ast.sequence_pop_first(Allocator)).delete(Allocator); - return ast.sequence_pop_first(Allocator); - } - - var result = try MalType.new_list_empty(Allocator); - while(0 < (try ast.sequence_length())) { - var elt = try ast.sequence_pop_last(Allocator); - const new_list = try MalType.new_list_empty(Allocator); - if(starts_with(elt, "splice-unquote")) { - (try elt.sequence_pop_first(Allocator)).delete(Allocator); - defer elt.delete(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "concat")); - try new_list.sequence_append(Allocator, try elt.sequence_pop_first(Allocator)); - } else { - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "cons")); - try new_list.sequence_append(Allocator, try quasiquote(elt)); - } - try new_list.sequence_append(Allocator, result); - result = new_list; - } - - if(kind == MalTypeValue.Vector) { - const new_list = try MalType.new_list_empty(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "vec")); - try new_list.sequence_append(Allocator, result); - result = new_list; - } - return result; -} - -fn PRINT(optional_mal: ?*MalType) MalError![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { - var read_input = (try READ(input)) orelse return null; - var eval_input = try EVAL(read_input, try environment.copy(Allocator)); - var print_input = try PRINT(eval_input); - eval_input.delete(Allocator); - return print_input; -} - -fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { - var mal = environment.get(symbol) catch |err| { - if(do_warn) { - const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; - const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; - defer Allocator.free(s1); - defer Allocator.free(s2); - warn("'{}' not found.\n", symbol); - } - return MalError.KeyError; - }; - var new_mal = try mal.copy(Allocator); - return new_mal; -} - -fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { - defer env.delete(); - switch(mal.data) { - .Generic => |symbol| { - defer mal.delete(Allocator); - return lookup(env, symbol, true); - }, - .List => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_list(Allocator, new_ll); - return ret_mal; - }, - .Vector => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_vector(Allocator, new_ll); - return ret_mal; - }, - .HashMap => |hmap| { - var new_hashmap = try MalType.new_hashmap(Allocator); - var iterator = hmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = pair.key; - const value = pair.value; - const evaled_value = try EVAL(value, try env.copy(Allocator)); - try new_hashmap.hashmap_insert(key, evaled_value); - optional_pair = iterator.next(); - } - hash_map.destroy(Allocator, hmap, true); - mal.shallow_destroy(Allocator); - return new_hashmap; - }, - else => { - return mal; - } - } -} - -fn make_environment() MalError!*Env { - repl_environment = try Env.new(Allocator, null); - var environment = try repl_environment.copy(Allocator); - - for(core.core_namespace) |pair| { - const name = pair.name; - const func_mal: *MalType = try MalType.new_nil(Allocator); - func_mal.data = switch(pair.func) { - core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, - core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, - core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, - core.CorePairType.FVar => |func| MalData{.FVar = func}, - else => return MalError.TypeError, - }; - try environment.set(name, func_mal); - } - - const eval_mal = try MalType.new_nil(Allocator); - eval_mal.data = MalData{.Fn1 = &eval}; - try environment.set("eval", eval_mal); - - const def_not_string: [] const u8 = - \\(def! not (fn* (a) (if a false true))) - ; - var optional_output = try rep(environment, def_not_string); - if(optional_output) |output| { - Allocator.free(output); - } - - const load_file_string: [] const u8 = - \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - ; - optional_output = try rep(environment, load_file_string); - if(optional_output) |output| { - Allocator.free(output); - } - - return environment; -} - -fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { - const mal_func = try linked_list.pop_first(Allocator, args); - const env = env_ptr.*; - // First check if it is a user-defined Mal function - if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { - const func_data = mal_func.data.Func; - const args_ll = try func_data.arg_list.sequence_linked_list(); - const func_env = func_data.environment; - var new_env = try Env.new(Allocator, func_env); - func_env.delete(); - try new_env.set_list(args_ll.*, args.*); - linked_list.destroy(Allocator, args, true); - func_data.arg_list.delete(Allocator); - mal_func.shallow_destroy(Allocator); - mal_ptr.* = func_data.body; - env.delete(); - env_ptr.* = new_env; - return; - } - return MalError.TypeError; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - core.set_allocator(Allocator); - var environment = try make_environment(); - - const args = try std.process.argsAlloc(Allocator); - var arg_list = try MalType.new_list_empty(Allocator); - for(args) |arg,i| { - if(i < 2) continue; - const new_mal = try MalType.new_string(Allocator, arg); - try arg_list.sequence_append(Allocator, new_mal); - } - try environment.set("*ARGV*", arg_list); - - if(args.len > 1) { - const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); - var output = try rep(environment, run_cmd); - return; - } - - while(true) { - var line = (try getline(Allocator)) orelse break; - var optional_output = rep(environment, line) catch |err| { - if(err == MalError.KeyError) { - continue; - } else { - return err; - } - }; - if(optional_output) |output| { - try stdout_file.write(output); - Allocator.free(output); - Allocator.free(line); - try stdout_file.write("\n"); - } - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const pcre = reader.pcre; +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const apply_function = @import("types.zig").apply_function; +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); +const core = @import("core.zig"); + +const Allocator = @import("std").heap.c_allocator; + +const MalType = @import("types.zig").MalType; +const MalTypeValue = @import("types.zig").MalTypeValue; +const MalData = @import("types.zig").MalData; +const MalError = @import("error.zig").MalError; +const MalFuncData = @import("types.zig").MalFuncData; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const Env = @import("env.zig").Env; + +var repl_environment: *Env = undefined; + +fn READ(a: []const u8) MalError!?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { + var mal = mal_arg; + var env = env_arg; + while(true) { + switch(mal.data) { + .List => |ll| { + if(ll.len == 0) { + return mal; + } + var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; + var symbol = switch(first_mal.data) { + .Generic => |symbol| symbol, + else => "", + }; + if(string_eql(symbol, "def!")) { + return EVAL_def(mal, env); + } + else if(string_eql(symbol, "let*")) { + try EVAL_let(&mal, &env); + continue; + } + else if(string_eql(symbol, "do")) { + try EVAL_do(&mal, &env); + continue; + } + else if(string_eql(symbol, "if")) { + try EVAL_if(&mal, &env); + continue; + } + else if(string_eql(symbol, "fn*")) { + return EVAL_fn(mal, env); + } + else if(string_eql(symbol, "quote")) { + return EVAL_quote(mal, env); + } + else if(string_eql(symbol, "quasiquoteexpand")) { + env.delete(); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + mal.delete(Allocator); + return try quasiquote(second); + } + else if(string_eql(symbol, "quasiquote")) { + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + mal.delete(Allocator); + mal = try quasiquote(second); + continue; + } + else { + var new_list = try eval_ast(mal, try env.copy(Allocator)); + + if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { + try do_user_func(try new_list.sequence_linked_list(), &mal, &env); + new_list.shallow_destroy(Allocator); + continue; + } + const res = try apply_function(Allocator, (try new_list.sequence_linked_list()).*); + new_list.delete(Allocator); + env.delete(); + return res; + } + }, + else => { + return eval_ast(mal, env); + }, + } + } +} + +fn eval(a1: *MalType) MalError!*MalType { + return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); +} + +fn starts_with(ast: *MalType, sym: []const u8) bool { + const ll = switch(ast.data) { + .List => |l| l, + else => return false, + }; + if(ll.count() < 2) { + return false; + } + const ss = switch(ll.at(0).data) { + .Generic => |s| s, + else => return false, + }; + return string_eql(ss, sym); +} + +fn EVAL_def(mal: *MalType, env: *Env) MalError!*MalType { + const first_arg = try mal.sequence_nth(1); + const second_arg = try mal.sequence_nth(2); + const second_arg_copy = try second_arg.copy(Allocator); + const symbol_name = try first_arg.as_symbol(); + const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); + try env.set(symbol_name, new_value); + mal.delete(Allocator); + env.delete(); + return new_value.copy(Allocator); +} + +fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + //TODO: make faster + const mal = mal_ptr.*; + const env = env_ptr.*; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + const binding_arg = try mal.sequence_pop_first(Allocator); + const eval_arg = try mal.sequence_pop_first(Allocator); + const new_env = try Env.new(Allocator, env); + var binding_ll = switch(binding_arg.data) { + .List => |l| l, + .Vector => |v| v, + else => return MalError.TypeError, + }; + var iterator = binding_ll.iterator(); + var optional_node = iterator.next(); + while(optional_node) |node| { + const key_mal = node; + const key = try key_mal.as_symbol(); + const val_mal = iterator.next() orelse return MalError.ArgError; + const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); + try new_env.set(key, evaled_mal); + optional_node = iterator.next(); + key_mal.delete(Allocator); + } + + linked_list.destroy(Allocator, &binding_ll, true); + binding_arg.data = MalData{.Nil=undefined}; + binding_arg.delete(Allocator); + mal.delete(Allocator); + + // We use eval_arg_copy, since we just deleted eval_arg above + mal_ptr.* = eval_arg; + env.delete(); + env_ptr.* = new_env; +} + +fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + var ll = &mal.data.List; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var last_mal = try mal.sequence_pop_last(Allocator); + var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); + evaled_mal.delete(Allocator); + mal_ptr.* = last_mal; +} + +fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + defer mal.delete(Allocator); + const first_arg = try mal.sequence_nth(1); + const first_arg_copy = try first_arg.copy(Allocator); + const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); + const is_true = switch(evaled.data) { + .False => false, + .Nil => false, + else => true, + }; + evaled.delete(Allocator); + if(is_true) { + const second_arg = try mal.sequence_nth(2); + mal_ptr.* = try second_arg.copy(Allocator); + return; + } + if((try mal.sequence_length()) < 4) { + mal_ptr.* = try MalType.new_nil(Allocator); + return; + } + const third_arg = try mal.sequence_nth(3); + const third_arg_copy = try third_arg.copy(Allocator); + mal_ptr.* = third_arg_copy; +} + +fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); + const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); + const func_data = MalFuncData { + .arg_list = arg_mal, + .body = body_mal, + .environment = env, + .is_macro = false, + .eval_func = &EVAL, + }; + const new_func = try MalType.new_nil(Allocator); + new_func.data = MalData{.Func = func_data}; + return new_func; +} + +fn EVAL_quote(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + defer env.delete(); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + return try mal.sequence_pop_first(Allocator); +} + +fn quasiquote(ast: *MalType) MalError!*MalType { + const kind = MalTypeValue(ast.data); + if(kind == MalTypeValue.Generic or kind == MalTypeValue.HashMap) { + const new_list = try MalType.new_list_empty(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "quote")); + try new_list.sequence_append(Allocator, ast); + return new_list; + } + + if(kind != MalTypeValue.List and kind != MalTypeValue.Vector) { + return ast; + } + + defer ast.delete(Allocator); + + if(starts_with(ast, "unquote")) { + (try ast.sequence_pop_first(Allocator)).delete(Allocator); + return ast.sequence_pop_first(Allocator); + } + + var result = try MalType.new_list_empty(Allocator); + while(0 < (try ast.sequence_length())) { + var elt = try ast.sequence_pop_last(Allocator); + const new_list = try MalType.new_list_empty(Allocator); + if(starts_with(elt, "splice-unquote")) { + (try elt.sequence_pop_first(Allocator)).delete(Allocator); + defer elt.delete(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "concat")); + try new_list.sequence_append(Allocator, try elt.sequence_pop_first(Allocator)); + } else { + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "cons")); + try new_list.sequence_append(Allocator, try quasiquote(elt)); + } + try new_list.sequence_append(Allocator, result); + result = new_list; + } + + if(kind == MalTypeValue.Vector) { + const new_list = try MalType.new_list_empty(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "vec")); + try new_list.sequence_append(Allocator, result); + result = new_list; + } + return result; +} + +fn PRINT(optional_mal: ?*MalType) MalError![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { + var read_input = (try READ(input)) orelse return null; + var eval_input = try EVAL(read_input, try environment.copy(Allocator)); + var print_input = try PRINT(eval_input); + eval_input.delete(Allocator); + return print_input; +} + +fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { + var mal = environment.get(symbol) catch |err| { + if(do_warn) { + const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; + const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; + defer Allocator.free(s1); + defer Allocator.free(s2); + warn("'{}' not found.\n", symbol); + } + return MalError.KeyError; + }; + var new_mal = try mal.copy(Allocator); + return new_mal; +} + +fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { + defer env.delete(); + switch(mal.data) { + .Generic => |symbol| { + defer mal.delete(Allocator); + return lookup(env, symbol, true); + }, + .List => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_list(Allocator, new_ll); + return ret_mal; + }, + .Vector => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_vector(Allocator, new_ll); + return ret_mal; + }, + .HashMap => |hmap| { + var new_hashmap = try MalType.new_hashmap(Allocator); + var iterator = hmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = pair.key; + const value = pair.value; + const evaled_value = try EVAL(value, try env.copy(Allocator)); + try new_hashmap.hashmap_insert(key, evaled_value); + optional_pair = iterator.next(); + } + hash_map.destroy(Allocator, hmap, true); + mal.shallow_destroy(Allocator); + return new_hashmap; + }, + else => { + return mal; + } + } +} + +fn make_environment() MalError!*Env { + repl_environment = try Env.new(Allocator, null); + var environment = try repl_environment.copy(Allocator); + + for(core.core_namespace) |pair| { + const name = pair.name; + const func_mal: *MalType = try MalType.new_nil(Allocator); + func_mal.data = switch(pair.func) { + core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, + core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, + core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, + core.CorePairType.FVar => |func| MalData{.FVar = func}, + else => return MalError.TypeError, + }; + try environment.set(name, func_mal); + } + + const eval_mal = try MalType.new_nil(Allocator); + eval_mal.data = MalData{.Fn1 = &eval}; + try environment.set("eval", eval_mal); + + const def_not_string: [] const u8 = + \\(def! not (fn* (a) (if a false true))) + ; + var optional_output = try rep(environment, def_not_string); + if(optional_output) |output| { + Allocator.free(output); + } + + const load_file_string: [] const u8 = + \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + ; + optional_output = try rep(environment, load_file_string); + if(optional_output) |output| { + Allocator.free(output); + } + + return environment; +} + +fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { + const mal_func = try linked_list.pop_first(Allocator, args); + const env = env_ptr.*; + // First check if it is a user-defined Mal function + if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { + const func_data = mal_func.data.Func; + const args_ll = try func_data.arg_list.sequence_linked_list(); + const func_env = func_data.environment; + var new_env = try Env.new(Allocator, func_env); + func_env.delete(); + try new_env.set_list(args_ll.*, args.*); + linked_list.destroy(Allocator, args, true); + func_data.arg_list.delete(Allocator); + mal_func.shallow_destroy(Allocator); + mal_ptr.* = func_data.body; + env.delete(); + env_ptr.* = new_env; + return; + } + return MalError.TypeError; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + core.set_allocator(Allocator); + var environment = try make_environment(); + + const args = try std.process.argsAlloc(Allocator); + var arg_list = try MalType.new_list_empty(Allocator); + for(args) |arg,i| { + if(i < 2) continue; + const new_mal = try MalType.new_string(Allocator, arg); + try arg_list.sequence_append(Allocator, new_mal); + } + try environment.set("*ARGV*", arg_list); + + if(args.len > 1) { + const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); + var output = try rep(environment, run_cmd); + return; + } + + while(true) { + var line = (try getline(Allocator)) orelse break; + var optional_output = rep(environment, line) catch |err| { + if(err == MalError.KeyError) { + continue; + } else { + return err; + } + }; + if(optional_output) |output| { + try stdout_file.write(output); + Allocator.free(output); + Allocator.free(line); + try stdout_file.write("\n"); + } + } +} diff --git a/impls/zig/step8_macros.zig b/impls/zig/step8_macros.zig index 4559db7d3d..f20cae5177 100644 --- a/impls/zig/step8_macros.zig +++ b/impls/zig/step8_macros.zig @@ -1,535 +1,535 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const pcre = reader.pcre; -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const apply_function = @import("types.zig").apply_function; -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); -const core = @import("core.zig"); - -const Allocator = @import("std").heap.c_allocator; - -const MalType = @import("types.zig").MalType; -const MalTypeValue = @import("types.zig").MalTypeValue; -const MalData = @import("types.zig").MalData; -const MalError = @import("error.zig").MalError; -const MalFuncData = @import("types.zig").MalFuncData; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const Env = @import("env.zig").Env; - -var repl_environment: *Env = undefined; - -fn READ(a: []const u8) MalError!?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { - var mal = mal_arg; - var env = env_arg; - while(true) { - mal = try macroexpand(mal, env); - switch(mal.data) { - .List => |ll| { - if(ll.len == 0) { - return mal; - } - var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; - var symbol = switch(first_mal.data) { - .Generic => |symbol| symbol, - else => "", - }; - if(string_eql(symbol, "def!")) { - return EVAL_def(mal, env, false); - } - else if(string_eql(symbol, "defmacro!")) { - return EVAL_def(mal, env, true); - } - else if(string_eql(symbol, "let*")) { - try EVAL_let(&mal, &env); - continue; - } - else if(string_eql(symbol, "do")) { - try EVAL_do(&mal, &env); - continue; - } - else if(string_eql(symbol, "if")) { - try EVAL_if(&mal, &env); - continue; - } - else if(string_eql(symbol, "fn*")) { - return EVAL_fn(mal, env); - } - else if(string_eql(symbol, "quote")) { - return EVAL_quote(mal, env); - } - else if(string_eql(symbol, "quasiquoteexpand")) { - env.delete(); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - mal.delete(Allocator); - return try quasiquote(second); - } - else if(string_eql(symbol, "quasiquote")) { - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - mal.delete(Allocator); - mal = try quasiquote(second); - continue; - } - else if(string_eql(symbol, "macroexpand")) { - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - const expanded = macroexpand(second, env); - env.delete(); - return expanded; - } - else { - var new_list = try eval_ast(mal, try env.copy(Allocator)); - - if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { - try do_user_func(try new_list.sequence_linked_list(), &mal, &env); - new_list.shallow_destroy(Allocator); - continue; - } - const res = try apply_function(Allocator, (try new_list.sequence_linked_list()).*); - new_list.delete(Allocator); - env.delete(); - return res; - } - }, - else => { - return eval_ast(mal, env); - }, - } - } -} - -fn eval(a1: *MalType) MalError!*MalType { - return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); -} - -fn starts_with(ast: *MalType, sym: []const u8) bool { - const ll = switch(ast.data) { - .List => |l| l, - else => return false, - }; - if(ll.count() < 2) { - return false; - } - const ss = switch(ll.at(0).data) { - .Generic => |s| s, - else => return false, - }; - return string_eql(ss, sym); -} - -fn is_macro_call(mal: *MalType, env: *Env) ?*MalType { - const ll = switch(mal.data) { - .List => |l| l, - else => return null, - }; - const first_node = linked_list.first(&ll) orelse return null; - const symbol = switch(first_node.data) { - .Generic => |s| s, - else => return null, - }; - const val = lookup(env, symbol, false) catch return null; - const is_macro = switch(val.data) { - .Func => |f| f.is_macro, - else => false, - }; - if(is_macro) { - return val; - } - val.delete(Allocator); - return null; -} - -fn macroexpand(mal: *MalType, env: *Env) MalError!*MalType { - var cur_mal = mal; - var optional_macro = is_macro_call(cur_mal, env); - while(optional_macro) |macro| { - var new_list = (try cur_mal.sequence_linked_list()).*; - - if(new_list.count() > 0) { - const first = try linked_list.pop_first(Allocator, &new_list); - first.delete(Allocator); - } - try linked_list.prepend_mal(Allocator, &new_list, macro); - var new_mal = try apply_function(Allocator, new_list); - linked_list.destroy(Allocator, &new_list, false); - cur_mal.shallow_destroy(Allocator); - cur_mal = new_mal; - optional_macro = is_macro_call(cur_mal, env); - } - return cur_mal; -} - -fn EVAL_def(mal: *MalType, env: *Env, macro: bool) MalError!*MalType { - const first_arg = try mal.sequence_nth(1); - const second_arg = try mal.sequence_nth(2); - const second_arg_copy = try second_arg.copy(Allocator); - const symbol_name = try first_arg.as_symbol(); - const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); - if(macro) { - var func_data = switch(new_value.data) { - .Func => |*f| f, - else => return MalError.TypeError, - }; - func_data.*.is_macro = true; - } - try env.set(symbol_name, new_value); - mal.delete(Allocator); - env.delete(); - return new_value.copy(Allocator); -} - -fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - //TODO: make faster - const mal = mal_ptr.*; - const env = env_ptr.*; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - const binding_arg = try mal.sequence_pop_first(Allocator); - const eval_arg = try mal.sequence_pop_first(Allocator); - const new_env = try Env.new(Allocator, env); - var binding_ll = switch(binding_arg.data) { - .List => |l| l, - .Vector => |v| v, - else => return MalError.TypeError, - }; - var iterator = binding_ll.iterator(); - var optional_node = iterator.next(); - while(optional_node) |node| { - const key_mal = node; - const key = try key_mal.as_symbol(); - const val_mal = iterator.next() orelse return MalError.ArgError; - const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); - try new_env.set(key, evaled_mal); - optional_node = iterator.next(); - key_mal.delete(Allocator); - } - - linked_list.destroy(Allocator, &binding_ll, true); - binding_arg.data = MalData{.Nil=undefined}; - binding_arg.delete(Allocator); - mal.delete(Allocator); - - // We use eval_arg_copy, since we just deleted eval_arg above - mal_ptr.* = eval_arg; - env.delete(); - env_ptr.* = new_env; -} - -fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - var ll = &mal.data.List; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var last_mal = try mal.sequence_pop_last(Allocator); - var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); - evaled_mal.delete(Allocator); - mal_ptr.* = last_mal; -} - -fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - defer mal.delete(Allocator); - const first_arg = try mal.sequence_nth(1); - const first_arg_copy = try first_arg.copy(Allocator); - const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); - const is_true = switch(evaled.data) { - .False => false, - .Nil => false, - else => true, - }; - evaled.delete(Allocator); - if(is_true) { - const second_arg = try mal.sequence_nth(2); - mal_ptr.* = try second_arg.copy(Allocator); - return; - } - if((try mal.sequence_length()) < 4) { - mal_ptr.* = try MalType.new_nil(Allocator); - return; - } - const third_arg = try mal.sequence_nth(3); - const third_arg_copy = try third_arg.copy(Allocator); - mal_ptr.* = third_arg_copy; -} - -fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); - const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); - const func_data = MalFuncData { - .arg_list = arg_mal, - .body = body_mal, - .environment = env, - .is_macro = false, - .eval_func = &EVAL, - }; - const new_func = try MalType.new_nil(Allocator); - new_func.data = MalData{.Func = func_data}; - return new_func; -} - -fn EVAL_quote(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - defer env.delete(); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - return try mal.sequence_pop_first(Allocator); -} - -fn quasiquote(ast: *MalType) MalError!*MalType { - const kind = MalTypeValue(ast.data); - if(kind == MalTypeValue.Generic or kind == MalTypeValue.HashMap) { - const new_list = try MalType.new_list_empty(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "quote")); - try new_list.sequence_append(Allocator, ast); - return new_list; - } - - if(kind != MalTypeValue.List and kind != MalTypeValue.Vector) { - return ast; - } - - defer ast.delete(Allocator); - - if(starts_with(ast, "unquote")) { - (try ast.sequence_pop_first(Allocator)).delete(Allocator); - return ast.sequence_pop_first(Allocator); - } - - var result = try MalType.new_list_empty(Allocator); - while(0 < (try ast.sequence_length())) { - var elt = try ast.sequence_pop_last(Allocator); - const new_list = try MalType.new_list_empty(Allocator); - if(starts_with(elt, "splice-unquote")) { - (try elt.sequence_pop_first(Allocator)).delete(Allocator); - defer elt.delete(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "concat")); - try new_list.sequence_append(Allocator, try elt.sequence_pop_first(Allocator)); - } else { - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "cons")); - try new_list.sequence_append(Allocator, try quasiquote(elt)); - } - try new_list.sequence_append(Allocator, result); - result = new_list; - } - - if(kind == MalTypeValue.Vector) { - const new_list = try MalType.new_list_empty(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "vec")); - try new_list.sequence_append(Allocator, result); - result = new_list; - } - return result; -} - -fn PRINT(optional_mal: ?*MalType) MalError![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { - var read_input = (try READ(input)) orelse return null; - var eval_input = try EVAL(read_input, try environment.copy(Allocator)); - var print_input = try PRINT(eval_input); - eval_input.delete(Allocator); - return print_input; -} - -fn rep_and_print_errors(environment: *Env, input: [] const u8) ?[]u8 { - return rep(environment, input) catch |err| { - switch(err) { - MalError.KeyError => { }, - MalError.OutOfBounds => { - warn("Error: out of bounds\n"); - }, - MalError.ReaderUnmatchedParen => { - warn("Error: expected closing paren, got EOF\n"); - }, - else => { - warn("Unhandled error\n"); - }, - } - return null; - }; -} - - -fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { - var mal = environment.get(symbol) catch |err| { - if(do_warn) { - const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; - const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; - defer Allocator.free(s1); - defer Allocator.free(s2); - warn("'{}' not found.\n", symbol); - } - return MalError.KeyError; - }; - var new_mal = try mal.copy(Allocator); - return new_mal; -} - -fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { - defer env.delete(); - switch(mal.data) { - .Generic => |symbol| { - defer mal.delete(Allocator); - return lookup(env, symbol, true); - }, - .List => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_list(Allocator, new_ll); - return ret_mal; - }, - .Vector => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_vector(Allocator, new_ll); - return ret_mal; - }, - .HashMap => |hmap| { - var new_hashmap = try MalType.new_hashmap(Allocator); - var iterator = hmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = pair.key; - const value = pair.value; - const evaled_value = try EVAL(value, try env.copy(Allocator)); - try new_hashmap.hashmap_insert(key, evaled_value); - optional_pair = iterator.next(); - } - hash_map.destroy(Allocator, hmap, true); - mal.shallow_destroy(Allocator); - return new_hashmap; - }, - else => { - return mal; - } - } -} - -fn make_environment() MalError!*Env { - repl_environment = try Env.new(Allocator, null); - var environment = try repl_environment.copy(Allocator); - - for(core.core_namespace) |pair| { - const name = pair.name; - const func_mal: *MalType = try MalType.new_nil(Allocator); - func_mal.data = switch(pair.func) { - core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, - core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, - core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, - core.CorePairType.FVar => |func| MalData{.FVar = func}, - else => return MalError.TypeError, - }; - try environment.set(name, func_mal); - } - - const eval_mal = try MalType.new_nil(Allocator); - eval_mal.data = MalData{.Fn1 = &eval}; - try environment.set("eval", eval_mal); - - const def_not_string: [] const u8 = - \\(def! not (fn* (a) (if a false true))) - ; - var optional_output = try rep(environment, def_not_string); - if(optional_output) |output| { - Allocator.free(output); - } - - const load_file_string: [] const u8 = - \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - ; - optional_output = try rep(environment, load_file_string); - if(optional_output) |output| { - Allocator.free(output); - } - - const def_cond_macro_string: [] const u8 = - \\(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))))))) - ; - optional_output = try rep(environment, def_cond_macro_string); - if(optional_output) |output| { - Allocator.free(output); - } - - return environment; -} - -fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { - const mal_func = try linked_list.pop_first(Allocator, args); - const env = env_ptr.*; - // First check if it is a user-defined Mal function - if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { - const func_data = mal_func.data.Func; - const args_ll = try func_data.arg_list.sequence_linked_list(); - const func_env = func_data.environment; - var new_env = try Env.new(Allocator, func_env); - func_env.delete(); - try new_env.set_list(args_ll.*, args.*); - linked_list.destroy(Allocator, args, true); - func_data.arg_list.delete(Allocator); - mal_func.shallow_destroy(Allocator); - mal_ptr.* = func_data.body; - env.delete(); - env_ptr.* = new_env; - return; - } - return MalError.TypeError; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - core.set_allocator(Allocator); - var environment = try make_environment(); - - const args = try std.process.argsAlloc(Allocator); - var arg_list = try MalType.new_list_empty(Allocator); - for(args) |arg,i| { - if(i < 2) continue; - const new_mal = try MalType.new_string(Allocator, arg); - try arg_list.sequence_append(Allocator, new_mal); - } - try environment.set("*ARGV*", arg_list); - - if(args.len > 1) { - const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); - var output = rep_and_print_errors(environment, run_cmd); - return; - } - - while(true) { - var line = (try getline(Allocator)) orelse break; - var output = rep_and_print_errors(environment, line) orelse continue; - try stdout_file.write(output); - Allocator.free(output); - Allocator.free(line); - try stdout_file.write("\n"); - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const pcre = reader.pcre; +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const apply_function = @import("types.zig").apply_function; +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); +const core = @import("core.zig"); + +const Allocator = @import("std").heap.c_allocator; + +const MalType = @import("types.zig").MalType; +const MalTypeValue = @import("types.zig").MalTypeValue; +const MalData = @import("types.zig").MalData; +const MalError = @import("error.zig").MalError; +const MalFuncData = @import("types.zig").MalFuncData; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const Env = @import("env.zig").Env; + +var repl_environment: *Env = undefined; + +fn READ(a: []const u8) MalError!?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { + var mal = mal_arg; + var env = env_arg; + while(true) { + mal = try macroexpand(mal, env); + switch(mal.data) { + .List => |ll| { + if(ll.len == 0) { + return mal; + } + var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; + var symbol = switch(first_mal.data) { + .Generic => |symbol| symbol, + else => "", + }; + if(string_eql(symbol, "def!")) { + return EVAL_def(mal, env, false); + } + else if(string_eql(symbol, "defmacro!")) { + return EVAL_def(mal, env, true); + } + else if(string_eql(symbol, "let*")) { + try EVAL_let(&mal, &env); + continue; + } + else if(string_eql(symbol, "do")) { + try EVAL_do(&mal, &env); + continue; + } + else if(string_eql(symbol, "if")) { + try EVAL_if(&mal, &env); + continue; + } + else if(string_eql(symbol, "fn*")) { + return EVAL_fn(mal, env); + } + else if(string_eql(symbol, "quote")) { + return EVAL_quote(mal, env); + } + else if(string_eql(symbol, "quasiquoteexpand")) { + env.delete(); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + mal.delete(Allocator); + return try quasiquote(second); + } + else if(string_eql(symbol, "quasiquote")) { + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + mal.delete(Allocator); + mal = try quasiquote(second); + continue; + } + else if(string_eql(symbol, "macroexpand")) { + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + const expanded = macroexpand(second, env); + env.delete(); + return expanded; + } + else { + var new_list = try eval_ast(mal, try env.copy(Allocator)); + + if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { + try do_user_func(try new_list.sequence_linked_list(), &mal, &env); + new_list.shallow_destroy(Allocator); + continue; + } + const res = try apply_function(Allocator, (try new_list.sequence_linked_list()).*); + new_list.delete(Allocator); + env.delete(); + return res; + } + }, + else => { + return eval_ast(mal, env); + }, + } + } +} + +fn eval(a1: *MalType) MalError!*MalType { + return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); +} + +fn starts_with(ast: *MalType, sym: []const u8) bool { + const ll = switch(ast.data) { + .List => |l| l, + else => return false, + }; + if(ll.count() < 2) { + return false; + } + const ss = switch(ll.at(0).data) { + .Generic => |s| s, + else => return false, + }; + return string_eql(ss, sym); +} + +fn is_macro_call(mal: *MalType, env: *Env) ?*MalType { + const ll = switch(mal.data) { + .List => |l| l, + else => return null, + }; + const first_node = linked_list.first(&ll) orelse return null; + const symbol = switch(first_node.data) { + .Generic => |s| s, + else => return null, + }; + const val = lookup(env, symbol, false) catch return null; + const is_macro = switch(val.data) { + .Func => |f| f.is_macro, + else => false, + }; + if(is_macro) { + return val; + } + val.delete(Allocator); + return null; +} + +fn macroexpand(mal: *MalType, env: *Env) MalError!*MalType { + var cur_mal = mal; + var optional_macro = is_macro_call(cur_mal, env); + while(optional_macro) |macro| { + var new_list = (try cur_mal.sequence_linked_list()).*; + + if(new_list.count() > 0) { + const first = try linked_list.pop_first(Allocator, &new_list); + first.delete(Allocator); + } + try linked_list.prepend_mal(Allocator, &new_list, macro); + var new_mal = try apply_function(Allocator, new_list); + linked_list.destroy(Allocator, &new_list, false); + cur_mal.shallow_destroy(Allocator); + cur_mal = new_mal; + optional_macro = is_macro_call(cur_mal, env); + } + return cur_mal; +} + +fn EVAL_def(mal: *MalType, env: *Env, macro: bool) MalError!*MalType { + const first_arg = try mal.sequence_nth(1); + const second_arg = try mal.sequence_nth(2); + const second_arg_copy = try second_arg.copy(Allocator); + const symbol_name = try first_arg.as_symbol(); + const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); + if(macro) { + var func_data = switch(new_value.data) { + .Func => |*f| f, + else => return MalError.TypeError, + }; + func_data.*.is_macro = true; + } + try env.set(symbol_name, new_value); + mal.delete(Allocator); + env.delete(); + return new_value.copy(Allocator); +} + +fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + //TODO: make faster + const mal = mal_ptr.*; + const env = env_ptr.*; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + const binding_arg = try mal.sequence_pop_first(Allocator); + const eval_arg = try mal.sequence_pop_first(Allocator); + const new_env = try Env.new(Allocator, env); + var binding_ll = switch(binding_arg.data) { + .List => |l| l, + .Vector => |v| v, + else => return MalError.TypeError, + }; + var iterator = binding_ll.iterator(); + var optional_node = iterator.next(); + while(optional_node) |node| { + const key_mal = node; + const key = try key_mal.as_symbol(); + const val_mal = iterator.next() orelse return MalError.ArgError; + const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); + try new_env.set(key, evaled_mal); + optional_node = iterator.next(); + key_mal.delete(Allocator); + } + + linked_list.destroy(Allocator, &binding_ll, true); + binding_arg.data = MalData{.Nil=undefined}; + binding_arg.delete(Allocator); + mal.delete(Allocator); + + // We use eval_arg_copy, since we just deleted eval_arg above + mal_ptr.* = eval_arg; + env.delete(); + env_ptr.* = new_env; +} + +fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + var ll = &mal.data.List; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var last_mal = try mal.sequence_pop_last(Allocator); + var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); + evaled_mal.delete(Allocator); + mal_ptr.* = last_mal; +} + +fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + defer mal.delete(Allocator); + const first_arg = try mal.sequence_nth(1); + const first_arg_copy = try first_arg.copy(Allocator); + const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); + const is_true = switch(evaled.data) { + .False => false, + .Nil => false, + else => true, + }; + evaled.delete(Allocator); + if(is_true) { + const second_arg = try mal.sequence_nth(2); + mal_ptr.* = try second_arg.copy(Allocator); + return; + } + if((try mal.sequence_length()) < 4) { + mal_ptr.* = try MalType.new_nil(Allocator); + return; + } + const third_arg = try mal.sequence_nth(3); + const third_arg_copy = try third_arg.copy(Allocator); + mal_ptr.* = third_arg_copy; +} + +fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); + const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); + const func_data = MalFuncData { + .arg_list = arg_mal, + .body = body_mal, + .environment = env, + .is_macro = false, + .eval_func = &EVAL, + }; + const new_func = try MalType.new_nil(Allocator); + new_func.data = MalData{.Func = func_data}; + return new_func; +} + +fn EVAL_quote(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + defer env.delete(); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + return try mal.sequence_pop_first(Allocator); +} + +fn quasiquote(ast: *MalType) MalError!*MalType { + const kind = MalTypeValue(ast.data); + if(kind == MalTypeValue.Generic or kind == MalTypeValue.HashMap) { + const new_list = try MalType.new_list_empty(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "quote")); + try new_list.sequence_append(Allocator, ast); + return new_list; + } + + if(kind != MalTypeValue.List and kind != MalTypeValue.Vector) { + return ast; + } + + defer ast.delete(Allocator); + + if(starts_with(ast, "unquote")) { + (try ast.sequence_pop_first(Allocator)).delete(Allocator); + return ast.sequence_pop_first(Allocator); + } + + var result = try MalType.new_list_empty(Allocator); + while(0 < (try ast.sequence_length())) { + var elt = try ast.sequence_pop_last(Allocator); + const new_list = try MalType.new_list_empty(Allocator); + if(starts_with(elt, "splice-unquote")) { + (try elt.sequence_pop_first(Allocator)).delete(Allocator); + defer elt.delete(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "concat")); + try new_list.sequence_append(Allocator, try elt.sequence_pop_first(Allocator)); + } else { + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "cons")); + try new_list.sequence_append(Allocator, try quasiquote(elt)); + } + try new_list.sequence_append(Allocator, result); + result = new_list; + } + + if(kind == MalTypeValue.Vector) { + const new_list = try MalType.new_list_empty(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "vec")); + try new_list.sequence_append(Allocator, result); + result = new_list; + } + return result; +} + +fn PRINT(optional_mal: ?*MalType) MalError![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { + var read_input = (try READ(input)) orelse return null; + var eval_input = try EVAL(read_input, try environment.copy(Allocator)); + var print_input = try PRINT(eval_input); + eval_input.delete(Allocator); + return print_input; +} + +fn rep_and_print_errors(environment: *Env, input: [] const u8) ?[]u8 { + return rep(environment, input) catch |err| { + switch(err) { + MalError.KeyError => { }, + MalError.OutOfBounds => { + warn("Error: out of bounds\n"); + }, + MalError.ReaderUnmatchedParen => { + warn("Error: expected closing paren, got EOF\n"); + }, + else => { + warn("Unhandled error\n"); + }, + } + return null; + }; +} + + +fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { + var mal = environment.get(symbol) catch |err| { + if(do_warn) { + const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; + const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; + defer Allocator.free(s1); + defer Allocator.free(s2); + warn("'{}' not found.\n", symbol); + } + return MalError.KeyError; + }; + var new_mal = try mal.copy(Allocator); + return new_mal; +} + +fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { + defer env.delete(); + switch(mal.data) { + .Generic => |symbol| { + defer mal.delete(Allocator); + return lookup(env, symbol, true); + }, + .List => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_list(Allocator, new_ll); + return ret_mal; + }, + .Vector => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_vector(Allocator, new_ll); + return ret_mal; + }, + .HashMap => |hmap| { + var new_hashmap = try MalType.new_hashmap(Allocator); + var iterator = hmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = pair.key; + const value = pair.value; + const evaled_value = try EVAL(value, try env.copy(Allocator)); + try new_hashmap.hashmap_insert(key, evaled_value); + optional_pair = iterator.next(); + } + hash_map.destroy(Allocator, hmap, true); + mal.shallow_destroy(Allocator); + return new_hashmap; + }, + else => { + return mal; + } + } +} + +fn make_environment() MalError!*Env { + repl_environment = try Env.new(Allocator, null); + var environment = try repl_environment.copy(Allocator); + + for(core.core_namespace) |pair| { + const name = pair.name; + const func_mal: *MalType = try MalType.new_nil(Allocator); + func_mal.data = switch(pair.func) { + core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, + core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, + core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, + core.CorePairType.FVar => |func| MalData{.FVar = func}, + else => return MalError.TypeError, + }; + try environment.set(name, func_mal); + } + + const eval_mal = try MalType.new_nil(Allocator); + eval_mal.data = MalData{.Fn1 = &eval}; + try environment.set("eval", eval_mal); + + const def_not_string: [] const u8 = + \\(def! not (fn* (a) (if a false true))) + ; + var optional_output = try rep(environment, def_not_string); + if(optional_output) |output| { + Allocator.free(output); + } + + const load_file_string: [] const u8 = + \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + ; + optional_output = try rep(environment, load_file_string); + if(optional_output) |output| { + Allocator.free(output); + } + + const def_cond_macro_string: [] const u8 = + \\(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))))))) + ; + optional_output = try rep(environment, def_cond_macro_string); + if(optional_output) |output| { + Allocator.free(output); + } + + return environment; +} + +fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { + const mal_func = try linked_list.pop_first(Allocator, args); + const env = env_ptr.*; + // First check if it is a user-defined Mal function + if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { + const func_data = mal_func.data.Func; + const args_ll = try func_data.arg_list.sequence_linked_list(); + const func_env = func_data.environment; + var new_env = try Env.new(Allocator, func_env); + func_env.delete(); + try new_env.set_list(args_ll.*, args.*); + linked_list.destroy(Allocator, args, true); + func_data.arg_list.delete(Allocator); + mal_func.shallow_destroy(Allocator); + mal_ptr.* = func_data.body; + env.delete(); + env_ptr.* = new_env; + return; + } + return MalError.TypeError; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + core.set_allocator(Allocator); + var environment = try make_environment(); + + const args = try std.process.argsAlloc(Allocator); + var arg_list = try MalType.new_list_empty(Allocator); + for(args) |arg,i| { + if(i < 2) continue; + const new_mal = try MalType.new_string(Allocator, arg); + try arg_list.sequence_append(Allocator, new_mal); + } + try environment.set("*ARGV*", arg_list); + + if(args.len > 1) { + const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); + var output = rep_and_print_errors(environment, run_cmd); + return; + } + + while(true) { + var line = (try getline(Allocator)) orelse break; + var output = rep_and_print_errors(environment, line) orelse continue; + try stdout_file.write(output); + Allocator.free(output); + Allocator.free(line); + try stdout_file.write("\n"); + } +} diff --git a/impls/zig/step9_try.zig b/impls/zig/step9_try.zig index d56146577e..39e90f3f4f 100644 --- a/impls/zig/step9_try.zig +++ b/impls/zig/step9_try.zig @@ -1,612 +1,612 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const apply_function_unsafe = @import("types.zig").apply_function; //hack -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); -const core = @import("core.zig"); -const error_string_repr = @import("error.zig").error_string_repr; - -const CAllocator = @import("std").heap.c_allocator; -const AllocatorType = @import("std").mem.Allocator; -pub var Allocator: *AllocatorType = undefined; - -const MalType = @import("types.zig").MalType; -const MalTypeValue = @import("types.zig").MalTypeValue; -const MalData = @import("types.zig").MalData; -const MalError = @import("error.zig").MalError; -const MalFuncData = @import("types.zig").MalFuncData; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const Env = @import("env.zig").Env; - -var repl_environment: *Env = undefined; - -fn READ(a: []const u8) MalError!?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { - var mal = mal_arg; - var env = env_arg; - while(true) { - mal = try macroexpand(mal, env); - switch(mal.data) { - .List => |ll| { - if(ll.len == 0) { - env.delete(); - return mal; - } - var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; - var symbol = switch(first_mal.data) { - .Generic => |symbol| symbol, - else => "", - }; - if(string_eql(symbol, "def!")) { - return EVAL_def(mal, env, false); - } - else if(string_eql(symbol, "defmacro!")) { - return EVAL_def(mal, env, true); - } - else if(string_eql(symbol, "let*")) { - try EVAL_let(&mal, &env); - continue; - } - else if(string_eql(symbol, "do")) { - try EVAL_do(&mal, &env); - continue; - } - else if(string_eql(symbol, "if")) { - try EVAL_if(&mal, &env); - continue; - } - else if(string_eql(symbol, "fn*")) { - return EVAL_fn(mal, env); - } - else if(string_eql(symbol, "quote")) { - return EVAL_quote(mal, env); - } - else if(string_eql(symbol, "quasiquoteexpand")) { - env.delete(); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - mal.delete(Allocator); - return try quasiquote(second); - } - else if(string_eql(symbol, "quasiquote")) { - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - mal.delete(Allocator); - mal = try quasiquote(second); - continue; - } - else if(string_eql(symbol, "macroexpand")) { - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - const expanded = macroexpand(second, env); - env.delete(); - return expanded; - } - else if(string_eql(symbol, "try*")) { - return EVAL_try(mal, env); - } - else { - var new_list = try eval_ast(mal, try env.copy(Allocator)); - - if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { - try do_user_func(try new_list.sequence_linked_list(), &mal, &env); - new_list.shallow_destroy(Allocator); - continue; - } - const res = try apply_function((try new_list.sequence_linked_list()).*); - new_list.delete(Allocator); - env.delete(); - return res; - } - }, - else => { - return eval_ast(mal, env); - }, - } - } -} - -fn eval(a1: *MalType) MalError!*MalType { - return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); -} - -fn starts_with(ast: *MalType, sym: []const u8) bool { - const ll = switch(ast.data) { - .List => |l| l, - else => return false, - }; - if(ll.count() < 2) { - return false; - } - const ss = switch(ll.at(0).data) { - .Generic => |s| s, - else => return false, - }; - return string_eql(ss, sym); -} - -fn is_macro_call(mal: *MalType, env: *Env) ?*MalType { - const ll = switch(mal.data) { - .List => |l| l, - else => return null, - }; - const first_node = linked_list.first(&ll) orelse return null; - const symbol = switch(first_node.data) { - .Generic => |s| s, - else => return null, - }; - const val = lookup(env, symbol, false) catch return null; - const is_macro = switch(val.data) { - .Func => |f| f.is_macro, - else => false, - }; - if(is_macro) { - return val; - } - val.delete(Allocator); - return null; -} - -fn macroexpand(mal: *MalType, env: *Env) MalError!*MalType { - var cur_mal = mal; - var optional_macro = is_macro_call(cur_mal, env); - while(optional_macro) |macro| { - var new_list = (try cur_mal.sequence_linked_list()).*; - - if(new_list.count() > 0) { - const first = try linked_list.pop_first(Allocator, &new_list); - first.delete(Allocator); - } - try linked_list.prepend_mal(Allocator, &new_list, macro); - var new_mal = try apply_function_unsafe(Allocator, new_list); - linked_list.destroy(Allocator, &new_list, false); - cur_mal.shallow_destroy(Allocator); - cur_mal = new_mal; - optional_macro = is_macro_call(cur_mal, env); - } - return cur_mal; -} - -fn EVAL_def(mal: *MalType, env: *Env, macro: bool) MalError!*MalType { - const first_arg = try mal.sequence_nth(1); - const second_arg = try mal.sequence_nth(2); - const second_arg_copy = try second_arg.copy(Allocator); - const symbol_name = try first_arg.as_symbol(); - const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); - if(macro) { - var func_data = switch(new_value.data) { - .Func => |*f| f, - else => return MalError.TypeError, - }; - func_data.*.is_macro = true; - } - try env.set(symbol_name, new_value); - mal.delete(Allocator); - env.delete(); - return new_value.copy(Allocator); -} - -fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - //TODO: make faster - const mal = mal_ptr.*; - const env = env_ptr.*; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - const binding_arg = try mal.sequence_pop_first(Allocator); - const eval_arg = try mal.sequence_pop_first(Allocator); - const new_env = try Env.new(Allocator, env); - var binding_ll = switch(binding_arg.data) { - .List => |l| l, - .Vector => |v| v, - else => return MalError.TypeError, - }; - var iterator = binding_ll.iterator(); - var optional_node = iterator.next(); - while(optional_node) |node| { - const key_mal = node; - const key = try key_mal.as_symbol(); - const val_mal = iterator.next() orelse return MalError.ArgError; - const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); - try new_env.set(key, evaled_mal); - optional_node = iterator.next(); - key_mal.delete(Allocator); - } - - linked_list.destroy(Allocator, &binding_ll, true); - binding_arg.data = MalData{.Nil=undefined}; - binding_arg.delete(Allocator); - mal.delete(Allocator); - - // We use eval_arg_copy, since we just deleted eval_arg above - mal_ptr.* = eval_arg; - env.delete(); - env_ptr.* = new_env; -} - -fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - var ll = &mal.data.List; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var last_mal = try mal.sequence_pop_last(Allocator); - var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); - evaled_mal.delete(Allocator); - mal_ptr.* = last_mal; -} - -fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - defer mal.delete(Allocator); - const first_arg = try mal.sequence_nth(1); - const first_arg_copy = try first_arg.copy(Allocator); - const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); - const is_true = switch(evaled.data) { - .False => false, - .Nil => false, - else => true, - }; - evaled.delete(Allocator); - if(is_true) { - const second_arg = try mal.sequence_nth(2); - mal_ptr.* = try second_arg.copy(Allocator); - return; - } - if((try mal.sequence_length()) < 4) { - mal_ptr.* = try MalType.new_nil(Allocator); - return; - } - const third_arg = try mal.sequence_nth(3); - const third_arg_copy = try third_arg.copy(Allocator); - mal_ptr.* = third_arg_copy; -} - -fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); - const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); - const func_data = MalFuncData { - .arg_list = arg_mal, - .body = body_mal, - .environment = env, - .is_macro = false, - .eval_func = &EVAL, - }; - const new_func = try MalType.new_nil(Allocator); - new_func.data = MalData{.Func = func_data}; - return new_func; -} - -fn EVAL_quote(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - defer env.delete(); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - return try mal.sequence_pop_first(Allocator); -} - -fn EVAL_try(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var mal_to_try = try mal.sequence_pop_first(Allocator); - if(0 == try mal.sequence_length()) { - return EVAL(mal_to_try, env); - } - var catch_mal = try mal.sequence_pop_first(Allocator); - - const evaled_mal = EVAL(mal_to_try, try env.copy(Allocator)) catch |err| { - switch(err) { - MalError.ThrownError => { - }, - else => { - const error_mal = try MalType.new_string(Allocator, error_string_repr(err)); - try env.set("__error", error_mal); - } - } - // TODO: check that first element of catch is "catch*" - (try catch_mal.sequence_pop_first(Allocator)).delete(Allocator); - const err_symbol = try catch_mal.sequence_pop_first(Allocator); - const err_body =try catch_mal.sequence_pop_first(Allocator); - catch_mal.delete(Allocator); - - const err_val = try lookup(env, "__error", false); - var new_env = try Env.new(Allocator, env); - try new_env.set(try err_symbol.as_symbol(), err_val); - err_symbol.delete(Allocator); - const result = EVAL(err_body, try new_env.copy(Allocator)); - new_env.delete(); - env.delete(); - return result; - }; - env.delete(); - return evaled_mal; -} - -fn quasiquote(ast: *MalType) MalError!*MalType { - const kind = MalTypeValue(ast.data); - if(kind == MalTypeValue.Generic or kind == MalTypeValue.HashMap) { - const new_list = try MalType.new_list_empty(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "quote")); - try new_list.sequence_append(Allocator, ast); - return new_list; - } - - if(kind != MalTypeValue.List and kind != MalTypeValue.Vector) { - return ast; - } - - defer ast.delete(Allocator); - - if(starts_with(ast, "unquote")) { - (try ast.sequence_pop_first(Allocator)).delete(Allocator); - return ast.sequence_pop_first(Allocator); - } - - var result = try MalType.new_list_empty(Allocator); - while(0 < (try ast.sequence_length())) { - var elt = try ast.sequence_pop_last(Allocator); - const new_list = try MalType.new_list_empty(Allocator); - if(starts_with(elt, "splice-unquote")) { - (try elt.sequence_pop_first(Allocator)).delete(Allocator); - defer elt.delete(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "concat")); - try new_list.sequence_append(Allocator, try elt.sequence_pop_first(Allocator)); - } else { - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "cons")); - try new_list.sequence_append(Allocator, try quasiquote(elt)); - } - try new_list.sequence_append(Allocator, result); - result = new_list; - } - - if(kind == MalTypeValue.Vector) { - const new_list = try MalType.new_list_empty(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "vec")); - try new_list.sequence_append(Allocator, result); - result = new_list; - } - return result; -} - -fn PRINT(optional_mal: ?*MalType) MalError![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { - var read_input = (try READ(input)) orelse return null; - var eval_input = try EVAL(read_input, try environment.copy(Allocator)); - var print_input = try PRINT(eval_input); - eval_input.delete(Allocator); - return print_input; -} - -fn rep_and_print_errors(environment: *Env, input: [] const u8) ?[]u8 { - return rep(environment, input) catch |err| { - switch(err) { - MalError.KeyError => { }, - MalError.OutOfBounds => { - warn("Error: out of bounds\n"); - }, - MalError.ThrownError => { - warn("Thrown error: "); - const error_mal = lookup(environment, "__error", false) - catch {warn("\n"); return null;}; - const warning = PRINT(error_mal) - catch {warn("\n"); return null;}; - warn("{}\n", warning); - error_mal.delete(Allocator); - Allocator.free(warning); - }, - MalError.ReaderUnmatchedParen => { - warn("Error: expected closing paren, got EOF\n"); - }, - else => { - warn("Error: {}\n", error_string_repr(err)); - }, - } - return null; - }; -} - -fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { - var mal = environment.get(symbol) catch |err| { - if(do_warn) { - const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; - const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; - defer Allocator.free(s1); - defer Allocator.free(s2); - _ = try throw(try MalType.new_string(Allocator, s2)); - } - return MalError.KeyError; - }; - var new_mal = try mal.copy(Allocator); - return new_mal; -} - -fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { - defer env.delete(); - switch(mal.data) { - .Generic => |symbol| { - defer mal.delete(Allocator); - return lookup(env, symbol, true); - }, - .List => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_list(Allocator, new_ll); - return ret_mal; - }, - .Vector => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_vector(Allocator, new_ll); - return ret_mal; - }, - .HashMap => |hmap| { - var new_hashmap = try MalType.new_hashmap(Allocator); - var iterator = hmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = pair.key; - const value = pair.value; - const evaled_value = try EVAL(value, try env.copy(Allocator)); - try new_hashmap.hashmap_insert(key, evaled_value); - optional_pair = iterator.next(); - } - hash_map.destroy(Allocator, hmap, true); - mal.shallow_destroy(Allocator); - return new_hashmap; - }, - else => { - return mal; - } - } -} - -fn throw(a1: *MalType) MalError!*MalType { - const error_mal = try a1.copy(Allocator); - try repl_environment.set("__error", error_mal); - return MalError.ThrownError; -} - -fn make_environment() MalError!*Env { - repl_environment = try Env.new(Allocator, null); - var environment = try repl_environment.copy(Allocator); - - for(core.core_namespace) |pair| { - const name = pair.name; - const func_mal: *MalType = try MalType.new_nil(Allocator); - func_mal.data = switch(pair.func) { - core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, - core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, - core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, - core.CorePairType.FVar => |func| MalData{.FVar = func}, - else => return MalError.TypeError, - }; - try environment.set(name, func_mal); - } - - const eval_mal = try MalType.new_nil(Allocator); - eval_mal.data = MalData{.Fn1 = &eval}; - try environment.set("eval", eval_mal); - - const throw_mal = try MalType.new_nil(Allocator); - throw_mal.data = MalData{.Fn1 = &throw}; - try environment.set("throw", throw_mal); - - const def_not_string: [] const u8 = - \\(def! not (fn* (a) (if a false true))) - ; - var optional_output = try rep(environment, def_not_string); - if(optional_output) |output| { - Allocator.free(output); - } - - const load_file_string: [] const u8 = - \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - ; - optional_output = try rep(environment, load_file_string); - if(optional_output) |output| { - Allocator.free(output); - } - - const def_cond_macro_string: [] const u8 = - \\(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))))))) - ; - optional_output = try rep(environment, def_cond_macro_string); - if(optional_output) |output| { - Allocator.free(output); - } - - return environment; -} - -fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { - const mal_func = try linked_list.pop_first(Allocator, args); - const env = env_ptr.*; - // First check if it is a user-defined Mal function - if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { - const func_data = mal_func.data.Func; - const args_ll = try func_data.arg_list.sequence_linked_list(); - const func_env = func_data.environment; - var new_env = try Env.new(Allocator, func_env); - func_env.delete(); - try new_env.set_list(args_ll.*, args.*); - linked_list.destroy(Allocator, args, true); - func_data.arg_list.delete(Allocator); - mal_func.shallow_destroy(Allocator); - mal_ptr.* = func_data.body; - env.delete(); - env_ptr.* = new_env; - return; - } - return MalError.TypeError; -} - -fn apply_function(args: MalLinkedList) MalError!*MalType { - - const return_mal = apply_function_unsafe(Allocator, args) catch |err| { - if(err == MalError.ReaderUnmatchedParen) { - warn("Error: expected closing paren, got EOF\n"); - } else if(err == MalError.ReaderUnmatchedString) { - warn("Error: expected closing string, got EOF\n"); - } - return err; - }; - return return_mal; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - Allocator = CAllocator; - core.set_allocator(Allocator); - - var environment = try make_environment(); - - const args = try std.process.argsAlloc(Allocator); - var arg_list = try MalType.new_list_empty(Allocator); - for(args) |arg,i| { - if(i < 2) continue; - const new_mal = try MalType.new_string(Allocator, arg); - try arg_list.sequence_append(Allocator, new_mal); - } - try environment.set("*ARGV*", arg_list); - - if(args.len > 1) { - const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); - var output = rep_and_print_errors(environment, run_cmd); - return; - } - - while(true) { - var line = (try getline(Allocator)) orelse break; - var output = rep_and_print_errors(environment, line) orelse continue; - try stdout_file.write(output); - Allocator.free(output); - Allocator.free(line); - try stdout_file.write("\n"); - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const apply_function_unsafe = @import("types.zig").apply_function; //hack +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); +const core = @import("core.zig"); +const error_string_repr = @import("error.zig").error_string_repr; + +const CAllocator = @import("std").heap.c_allocator; +const AllocatorType = @import("std").mem.Allocator; +pub var Allocator: *AllocatorType = undefined; + +const MalType = @import("types.zig").MalType; +const MalTypeValue = @import("types.zig").MalTypeValue; +const MalData = @import("types.zig").MalData; +const MalError = @import("error.zig").MalError; +const MalFuncData = @import("types.zig").MalFuncData; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const Env = @import("env.zig").Env; + +var repl_environment: *Env = undefined; + +fn READ(a: []const u8) MalError!?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { + var mal = mal_arg; + var env = env_arg; + while(true) { + mal = try macroexpand(mal, env); + switch(mal.data) { + .List => |ll| { + if(ll.len == 0) { + env.delete(); + return mal; + } + var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; + var symbol = switch(first_mal.data) { + .Generic => |symbol| symbol, + else => "", + }; + if(string_eql(symbol, "def!")) { + return EVAL_def(mal, env, false); + } + else if(string_eql(symbol, "defmacro!")) { + return EVAL_def(mal, env, true); + } + else if(string_eql(symbol, "let*")) { + try EVAL_let(&mal, &env); + continue; + } + else if(string_eql(symbol, "do")) { + try EVAL_do(&mal, &env); + continue; + } + else if(string_eql(symbol, "if")) { + try EVAL_if(&mal, &env); + continue; + } + else if(string_eql(symbol, "fn*")) { + return EVAL_fn(mal, env); + } + else if(string_eql(symbol, "quote")) { + return EVAL_quote(mal, env); + } + else if(string_eql(symbol, "quasiquoteexpand")) { + env.delete(); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + mal.delete(Allocator); + return try quasiquote(second); + } + else if(string_eql(symbol, "quasiquote")) { + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + mal.delete(Allocator); + mal = try quasiquote(second); + continue; + } + else if(string_eql(symbol, "macroexpand")) { + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + const expanded = macroexpand(second, env); + env.delete(); + return expanded; + } + else if(string_eql(symbol, "try*")) { + return EVAL_try(mal, env); + } + else { + var new_list = try eval_ast(mal, try env.copy(Allocator)); + + if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { + try do_user_func(try new_list.sequence_linked_list(), &mal, &env); + new_list.shallow_destroy(Allocator); + continue; + } + const res = try apply_function((try new_list.sequence_linked_list()).*); + new_list.delete(Allocator); + env.delete(); + return res; + } + }, + else => { + return eval_ast(mal, env); + }, + } + } +} + +fn eval(a1: *MalType) MalError!*MalType { + return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); +} + +fn starts_with(ast: *MalType, sym: []const u8) bool { + const ll = switch(ast.data) { + .List => |l| l, + else => return false, + }; + if(ll.count() < 2) { + return false; + } + const ss = switch(ll.at(0).data) { + .Generic => |s| s, + else => return false, + }; + return string_eql(ss, sym); +} + +fn is_macro_call(mal: *MalType, env: *Env) ?*MalType { + const ll = switch(mal.data) { + .List => |l| l, + else => return null, + }; + const first_node = linked_list.first(&ll) orelse return null; + const symbol = switch(first_node.data) { + .Generic => |s| s, + else => return null, + }; + const val = lookup(env, symbol, false) catch return null; + const is_macro = switch(val.data) { + .Func => |f| f.is_macro, + else => false, + }; + if(is_macro) { + return val; + } + val.delete(Allocator); + return null; +} + +fn macroexpand(mal: *MalType, env: *Env) MalError!*MalType { + var cur_mal = mal; + var optional_macro = is_macro_call(cur_mal, env); + while(optional_macro) |macro| { + var new_list = (try cur_mal.sequence_linked_list()).*; + + if(new_list.count() > 0) { + const first = try linked_list.pop_first(Allocator, &new_list); + first.delete(Allocator); + } + try linked_list.prepend_mal(Allocator, &new_list, macro); + var new_mal = try apply_function_unsafe(Allocator, new_list); + linked_list.destroy(Allocator, &new_list, false); + cur_mal.shallow_destroy(Allocator); + cur_mal = new_mal; + optional_macro = is_macro_call(cur_mal, env); + } + return cur_mal; +} + +fn EVAL_def(mal: *MalType, env: *Env, macro: bool) MalError!*MalType { + const first_arg = try mal.sequence_nth(1); + const second_arg = try mal.sequence_nth(2); + const second_arg_copy = try second_arg.copy(Allocator); + const symbol_name = try first_arg.as_symbol(); + const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); + if(macro) { + var func_data = switch(new_value.data) { + .Func => |*f| f, + else => return MalError.TypeError, + }; + func_data.*.is_macro = true; + } + try env.set(symbol_name, new_value); + mal.delete(Allocator); + env.delete(); + return new_value.copy(Allocator); +} + +fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + //TODO: make faster + const mal = mal_ptr.*; + const env = env_ptr.*; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + const binding_arg = try mal.sequence_pop_first(Allocator); + const eval_arg = try mal.sequence_pop_first(Allocator); + const new_env = try Env.new(Allocator, env); + var binding_ll = switch(binding_arg.data) { + .List => |l| l, + .Vector => |v| v, + else => return MalError.TypeError, + }; + var iterator = binding_ll.iterator(); + var optional_node = iterator.next(); + while(optional_node) |node| { + const key_mal = node; + const key = try key_mal.as_symbol(); + const val_mal = iterator.next() orelse return MalError.ArgError; + const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); + try new_env.set(key, evaled_mal); + optional_node = iterator.next(); + key_mal.delete(Allocator); + } + + linked_list.destroy(Allocator, &binding_ll, true); + binding_arg.data = MalData{.Nil=undefined}; + binding_arg.delete(Allocator); + mal.delete(Allocator); + + // We use eval_arg_copy, since we just deleted eval_arg above + mal_ptr.* = eval_arg; + env.delete(); + env_ptr.* = new_env; +} + +fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + var ll = &mal.data.List; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var last_mal = try mal.sequence_pop_last(Allocator); + var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); + evaled_mal.delete(Allocator); + mal_ptr.* = last_mal; +} + +fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + defer mal.delete(Allocator); + const first_arg = try mal.sequence_nth(1); + const first_arg_copy = try first_arg.copy(Allocator); + const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); + const is_true = switch(evaled.data) { + .False => false, + .Nil => false, + else => true, + }; + evaled.delete(Allocator); + if(is_true) { + const second_arg = try mal.sequence_nth(2); + mal_ptr.* = try second_arg.copy(Allocator); + return; + } + if((try mal.sequence_length()) < 4) { + mal_ptr.* = try MalType.new_nil(Allocator); + return; + } + const third_arg = try mal.sequence_nth(3); + const third_arg_copy = try third_arg.copy(Allocator); + mal_ptr.* = third_arg_copy; +} + +fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); + const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); + const func_data = MalFuncData { + .arg_list = arg_mal, + .body = body_mal, + .environment = env, + .is_macro = false, + .eval_func = &EVAL, + }; + const new_func = try MalType.new_nil(Allocator); + new_func.data = MalData{.Func = func_data}; + return new_func; +} + +fn EVAL_quote(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + defer env.delete(); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + return try mal.sequence_pop_first(Allocator); +} + +fn EVAL_try(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var mal_to_try = try mal.sequence_pop_first(Allocator); + if(0 == try mal.sequence_length()) { + return EVAL(mal_to_try, env); + } + var catch_mal = try mal.sequence_pop_first(Allocator); + + const evaled_mal = EVAL(mal_to_try, try env.copy(Allocator)) catch |err| { + switch(err) { + MalError.ThrownError => { + }, + else => { + const error_mal = try MalType.new_string(Allocator, error_string_repr(err)); + try env.set("__error", error_mal); + } + } + // TODO: check that first element of catch is "catch*" + (try catch_mal.sequence_pop_first(Allocator)).delete(Allocator); + const err_symbol = try catch_mal.sequence_pop_first(Allocator); + const err_body =try catch_mal.sequence_pop_first(Allocator); + catch_mal.delete(Allocator); + + const err_val = try lookup(env, "__error", false); + var new_env = try Env.new(Allocator, env); + try new_env.set(try err_symbol.as_symbol(), err_val); + err_symbol.delete(Allocator); + const result = EVAL(err_body, try new_env.copy(Allocator)); + new_env.delete(); + env.delete(); + return result; + }; + env.delete(); + return evaled_mal; +} + +fn quasiquote(ast: *MalType) MalError!*MalType { + const kind = MalTypeValue(ast.data); + if(kind == MalTypeValue.Generic or kind == MalTypeValue.HashMap) { + const new_list = try MalType.new_list_empty(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "quote")); + try new_list.sequence_append(Allocator, ast); + return new_list; + } + + if(kind != MalTypeValue.List and kind != MalTypeValue.Vector) { + return ast; + } + + defer ast.delete(Allocator); + + if(starts_with(ast, "unquote")) { + (try ast.sequence_pop_first(Allocator)).delete(Allocator); + return ast.sequence_pop_first(Allocator); + } + + var result = try MalType.new_list_empty(Allocator); + while(0 < (try ast.sequence_length())) { + var elt = try ast.sequence_pop_last(Allocator); + const new_list = try MalType.new_list_empty(Allocator); + if(starts_with(elt, "splice-unquote")) { + (try elt.sequence_pop_first(Allocator)).delete(Allocator); + defer elt.delete(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "concat")); + try new_list.sequence_append(Allocator, try elt.sequence_pop_first(Allocator)); + } else { + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "cons")); + try new_list.sequence_append(Allocator, try quasiquote(elt)); + } + try new_list.sequence_append(Allocator, result); + result = new_list; + } + + if(kind == MalTypeValue.Vector) { + const new_list = try MalType.new_list_empty(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "vec")); + try new_list.sequence_append(Allocator, result); + result = new_list; + } + return result; +} + +fn PRINT(optional_mal: ?*MalType) MalError![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { + var read_input = (try READ(input)) orelse return null; + var eval_input = try EVAL(read_input, try environment.copy(Allocator)); + var print_input = try PRINT(eval_input); + eval_input.delete(Allocator); + return print_input; +} + +fn rep_and_print_errors(environment: *Env, input: [] const u8) ?[]u8 { + return rep(environment, input) catch |err| { + switch(err) { + MalError.KeyError => { }, + MalError.OutOfBounds => { + warn("Error: out of bounds\n"); + }, + MalError.ThrownError => { + warn("Thrown error: "); + const error_mal = lookup(environment, "__error", false) + catch {warn("\n"); return null;}; + const warning = PRINT(error_mal) + catch {warn("\n"); return null;}; + warn("{}\n", warning); + error_mal.delete(Allocator); + Allocator.free(warning); + }, + MalError.ReaderUnmatchedParen => { + warn("Error: expected closing paren, got EOF\n"); + }, + else => { + warn("Error: {}\n", error_string_repr(err)); + }, + } + return null; + }; +} + +fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { + var mal = environment.get(symbol) catch |err| { + if(do_warn) { + const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; + const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; + defer Allocator.free(s1); + defer Allocator.free(s2); + _ = try throw(try MalType.new_string(Allocator, s2)); + } + return MalError.KeyError; + }; + var new_mal = try mal.copy(Allocator); + return new_mal; +} + +fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { + defer env.delete(); + switch(mal.data) { + .Generic => |symbol| { + defer mal.delete(Allocator); + return lookup(env, symbol, true); + }, + .List => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_list(Allocator, new_ll); + return ret_mal; + }, + .Vector => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_vector(Allocator, new_ll); + return ret_mal; + }, + .HashMap => |hmap| { + var new_hashmap = try MalType.new_hashmap(Allocator); + var iterator = hmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = pair.key; + const value = pair.value; + const evaled_value = try EVAL(value, try env.copy(Allocator)); + try new_hashmap.hashmap_insert(key, evaled_value); + optional_pair = iterator.next(); + } + hash_map.destroy(Allocator, hmap, true); + mal.shallow_destroy(Allocator); + return new_hashmap; + }, + else => { + return mal; + } + } +} + +fn throw(a1: *MalType) MalError!*MalType { + const error_mal = try a1.copy(Allocator); + try repl_environment.set("__error", error_mal); + return MalError.ThrownError; +} + +fn make_environment() MalError!*Env { + repl_environment = try Env.new(Allocator, null); + var environment = try repl_environment.copy(Allocator); + + for(core.core_namespace) |pair| { + const name = pair.name; + const func_mal: *MalType = try MalType.new_nil(Allocator); + func_mal.data = switch(pair.func) { + core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, + core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, + core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, + core.CorePairType.FVar => |func| MalData{.FVar = func}, + else => return MalError.TypeError, + }; + try environment.set(name, func_mal); + } + + const eval_mal = try MalType.new_nil(Allocator); + eval_mal.data = MalData{.Fn1 = &eval}; + try environment.set("eval", eval_mal); + + const throw_mal = try MalType.new_nil(Allocator); + throw_mal.data = MalData{.Fn1 = &throw}; + try environment.set("throw", throw_mal); + + const def_not_string: [] const u8 = + \\(def! not (fn* (a) (if a false true))) + ; + var optional_output = try rep(environment, def_not_string); + if(optional_output) |output| { + Allocator.free(output); + } + + const load_file_string: [] const u8 = + \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + ; + optional_output = try rep(environment, load_file_string); + if(optional_output) |output| { + Allocator.free(output); + } + + const def_cond_macro_string: [] const u8 = + \\(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))))))) + ; + optional_output = try rep(environment, def_cond_macro_string); + if(optional_output) |output| { + Allocator.free(output); + } + + return environment; +} + +fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { + const mal_func = try linked_list.pop_first(Allocator, args); + const env = env_ptr.*; + // First check if it is a user-defined Mal function + if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { + const func_data = mal_func.data.Func; + const args_ll = try func_data.arg_list.sequence_linked_list(); + const func_env = func_data.environment; + var new_env = try Env.new(Allocator, func_env); + func_env.delete(); + try new_env.set_list(args_ll.*, args.*); + linked_list.destroy(Allocator, args, true); + func_data.arg_list.delete(Allocator); + mal_func.shallow_destroy(Allocator); + mal_ptr.* = func_data.body; + env.delete(); + env_ptr.* = new_env; + return; + } + return MalError.TypeError; +} + +fn apply_function(args: MalLinkedList) MalError!*MalType { + + const return_mal = apply_function_unsafe(Allocator, args) catch |err| { + if(err == MalError.ReaderUnmatchedParen) { + warn("Error: expected closing paren, got EOF\n"); + } else if(err == MalError.ReaderUnmatchedString) { + warn("Error: expected closing string, got EOF\n"); + } + return err; + }; + return return_mal; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + Allocator = CAllocator; + core.set_allocator(Allocator); + + var environment = try make_environment(); + + const args = try std.process.argsAlloc(Allocator); + var arg_list = try MalType.new_list_empty(Allocator); + for(args) |arg,i| { + if(i < 2) continue; + const new_mal = try MalType.new_string(Allocator, arg); + try arg_list.sequence_append(Allocator, new_mal); + } + try environment.set("*ARGV*", arg_list); + + if(args.len > 1) { + const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); + var output = rep_and_print_errors(environment, run_cmd); + return; + } + + while(true) { + var line = (try getline(Allocator)) orelse break; + var output = rep_and_print_errors(environment, line) orelse continue; + try stdout_file.write(output); + Allocator.free(output); + Allocator.free(line); + try stdout_file.write("\n"); + } +} diff --git a/impls/zig/stepA_mal.zig b/impls/zig/stepA_mal.zig index ff8e74fde3..f6a577193c 100644 --- a/impls/zig/stepA_mal.zig +++ b/impls/zig/stepA_mal.zig @@ -1,628 +1,628 @@ -const std = @import("std"); -const warn = @import("std").debug.warn; - -const reader = @import("reader.zig"); -const printer = @import("printer.zig"); -const getline = @import("readline.zig").getline; -const string_eql = @import("utils.zig").string_eql; -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const apply_function_unsafe = @import("types.zig").apply_function; -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); -const core = @import("core.zig"); -const error_string_repr = @import("error.zig").error_string_repr; - -const CAllocator = @import("std").heap.c_allocator; -const AllocatorType = @import("std").mem.Allocator; -pub var Allocator: *AllocatorType = undefined; - -const MalType = @import("types.zig").MalType; -const MalTypeValue = @import("types.zig").MalTypeValue; -const MalData = @import("types.zig").MalData; -const MalError = @import("error.zig").MalError; -const MalFuncData = @import("types.zig").MalFuncData; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; -const Env = @import("env.zig").Env; - -var repl_environment: *Env = undefined; - -fn READ(a: []const u8) MalError!?*MalType { - var read = try reader.read_str(a); - var optional_mal = reader.read_form(&read); - return optional_mal; -} - -fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { - var mal = mal_arg; - var env = env_arg; - while(true) { - mal = try macroexpand(mal, env); - switch(mal.data) { - .List => |ll| { - if(ll.len == 0) { - env.delete(); - return mal; - } - var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; - var symbol = switch(first_mal.data) { - .Generic => |symbol| symbol, - else => "", - }; - if(string_eql(symbol, "def!")) { - return EVAL_def(mal, env, false); - } - else if(string_eql(symbol, "defmacro!")) { - return EVAL_def(mal, env, true); - } - else if(string_eql(symbol, "let*")) { - try EVAL_let(&mal, &env); - continue; - } - else if(string_eql(symbol, "do")) { - try EVAL_do(&mal, &env); - continue; - } - else if(string_eql(symbol, "if")) { - try EVAL_if(&mal, &env); - continue; - } - else if(string_eql(symbol, "fn*")) { - return EVAL_fn(mal, env); - } - else if(string_eql(symbol, "quote")) { - return EVAL_quote(mal, env); - } - else if(string_eql(symbol, "quasiquoteexpand")) { - env.delete(); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - mal.delete(Allocator); - return try quasiquote(second); - } - else if(string_eql(symbol, "quasiquote")) { - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - mal.delete(Allocator); - mal = try quasiquote(second); - continue; - } - else if(string_eql(symbol, "macroexpand")) { - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var second = try mal.sequence_pop_first(Allocator); - const expanded = macroexpand(second, env); - env.delete(); - return expanded; - } - else if(string_eql(symbol, "try*")) { - return EVAL_try(mal, env); - } - else { - var new_list = try eval_ast(mal, try env.copy(Allocator)); - - if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { - try do_user_func(try new_list.sequence_linked_list(), &mal, &env); - new_list.shallow_destroy(Allocator); - continue; - } - const res = try apply_function((try new_list.sequence_linked_list()).*); - new_list.delete(Allocator); - env.delete(); - return res; - } - }, - else => { - return eval_ast(mal, env); - }, - } - } -} - -fn eval(a1: *MalType) MalError!*MalType { - return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); -} - -fn starts_with(ast: *MalType, sym: []const u8) bool { - const ll = switch(ast.data) { - .List => |l| l, - else => return false, - }; - if(ll.count() < 2) { - return false; - } - const ss = switch(ll.at(0).data) { - .Generic => |s| s, - else => return false, - }; - return string_eql(ss, sym); -} - -fn is_macro_call(mal: *MalType, env: *Env) ?*MalType { - const ll = switch(mal.data) { - .List => |l| l, - else => return null, - }; - const first_node = linked_list.first(&ll) orelse return null; - const symbol = switch(first_node.data) { - .Generic => |s| s, - else => return null, - }; - const val = lookup(env, symbol, false) catch return null; - const is_macro = switch(val.data) { - .Func => |f| f.is_macro, - else => false, - }; - if(is_macro) { - return val; - } - val.delete(Allocator); - return null; -} - -fn macroexpand(mal: *MalType, env: *Env) MalError!*MalType { - var cur_mal = mal; - var optional_macro = is_macro_call(cur_mal, env); - while(optional_macro) |macro| { - var new_list = (try cur_mal.sequence_linked_list()).*; - - if(new_list.count() > 0) { - const first = try linked_list.pop_first(Allocator, &new_list); - first.delete(Allocator); - } - try linked_list.prepend_mal(Allocator, &new_list, macro); - var new_mal = try apply_function_unsafe(Allocator, new_list); - linked_list.destroy(Allocator, &new_list, false); - cur_mal.shallow_destroy(Allocator); - cur_mal = new_mal; - optional_macro = is_macro_call(cur_mal, env); - } - return cur_mal; -} - -fn EVAL_def(mal: *MalType, env: *Env, macro: bool) MalError!*MalType { - const first_arg = try mal.sequence_nth(1); - const second_arg = try mal.sequence_nth(2); - const second_arg_copy = try second_arg.copy(Allocator); - const symbol_name = try first_arg.as_symbol(); - const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); - if(macro) { - var func_data = switch(new_value.data) { - .Func => |*f| f, - else => return MalError.TypeError, - }; - func_data.*.is_macro = true; - } - try env.set(symbol_name, new_value); - mal.delete(Allocator); - env.delete(); - return new_value.copy(Allocator); -} - -fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - //TODO: make faster - const mal = mal_ptr.*; - const env = env_ptr.*; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - const binding_arg = try mal.sequence_pop_first(Allocator); - const eval_arg = try mal.sequence_pop_first(Allocator); - const new_env = try Env.new(Allocator, env); - var binding_ll = switch(binding_arg.data) { - .List => |l| l, - .Vector => |v| v, - else => return MalError.TypeError, - }; - var iterator = binding_ll.iterator(); - var optional_node = iterator.next(); - while(optional_node) |node| { - const key_mal = node; - const key = try key_mal.as_symbol(); - const val_mal = iterator.next() orelse return MalError.ArgError; - const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); - try new_env.set(key, evaled_mal); - optional_node = iterator.next(); - key_mal.delete(Allocator); - } - - linked_list.destroy(Allocator, &binding_ll, true); - binding_arg.data = MalData{.Nil=undefined}; - binding_arg.delete(Allocator); - mal.delete(Allocator); - - // We use eval_arg_copy, since we just deleted eval_arg above - mal_ptr.* = eval_arg; - env.delete(); - env_ptr.* = new_env; -} - -fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - var ll = &mal.data.List; - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var last_mal = try mal.sequence_pop_last(Allocator); - var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); - evaled_mal.delete(Allocator); - mal_ptr.* = last_mal; -} - -fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { - var mal = mal_ptr.*; - var env = env_ptr.*; - defer mal.delete(Allocator); - const first_arg = try mal.sequence_nth(1); - const first_arg_copy = try first_arg.copy(Allocator); - const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); - const is_true = switch(evaled.data) { - .False => false, - .Nil => false, - else => true, - }; - evaled.delete(Allocator); - if(is_true) { - const second_arg = try mal.sequence_nth(2); - mal_ptr.* = try second_arg.copy(Allocator); - return; - } - if((try mal.sequence_length()) < 4) { - mal_ptr.* = try MalType.new_nil(Allocator); - return; - } - const third_arg = try mal.sequence_nth(3); - const third_arg_copy = try third_arg.copy(Allocator); - mal_ptr.* = third_arg_copy; -} - -fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); - const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); - const func_data = MalFuncData { - .arg_list = arg_mal, - .body = body_mal, - .environment = env, - .is_macro = false, - .eval_func = &EVAL, - }; - const new_func = try MalType.new_nil(Allocator); - new_func.data = MalData{.Func = func_data}; - return new_func; -} - -fn EVAL_quote(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - defer env.delete(); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - return try mal.sequence_pop_first(Allocator); -} - -fn EVAL_try(mal: *MalType, env: *Env) MalError!*MalType { - defer mal.delete(Allocator); - (try mal.sequence_pop_first(Allocator)).delete(Allocator); - var mal_to_try = try mal.sequence_pop_first(Allocator); - if(0 == try mal.sequence_length()) { - return EVAL(mal_to_try, env); - } - var catch_mal = try mal.sequence_pop_first(Allocator); - - const evaled_mal = EVAL(mal_to_try, try env.copy(Allocator)) catch |err| { - switch(err) { - MalError.ThrownError => { - }, - else => { - const error_mal = try MalType.new_string(Allocator, error_string_repr(err)); - try env.set("__error", error_mal); - } - } - // TODO: check that first element of catch is "catch*" - (try catch_mal.sequence_pop_first(Allocator)).delete(Allocator); - const err_symbol = try catch_mal.sequence_pop_first(Allocator); - const err_body =try catch_mal.sequence_pop_first(Allocator); - catch_mal.delete(Allocator); - - const err_val = try lookup(env, "__error", false); - var new_env = try Env.new(Allocator, env); - try new_env.set(try err_symbol.as_symbol(), err_val); - err_symbol.delete(Allocator); - const result = EVAL(err_body, try new_env.copy(Allocator)); - new_env.delete(); - env.delete(); - return result; - }; - env.delete(); - return evaled_mal; -} - -fn quasiquote(ast: *MalType) MalError!*MalType { - const kind = MalTypeValue(ast.data); - if(kind == MalTypeValue.Generic or kind == MalTypeValue.HashMap) { - const new_list = try MalType.new_list_empty(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "quote")); - try new_list.sequence_append(Allocator, ast); - return new_list; - } - - if(kind != MalTypeValue.List and kind != MalTypeValue.Vector) { - return ast; - } - - defer ast.delete(Allocator); - - if(starts_with(ast, "unquote")) { - (try ast.sequence_pop_first(Allocator)).delete(Allocator); - return ast.sequence_pop_first(Allocator); - } - - var result = try MalType.new_list_empty(Allocator); - while(0 < (try ast.sequence_length())) { - var elt = try ast.sequence_pop_last(Allocator); - const new_list = try MalType.new_list_empty(Allocator); - if(starts_with(elt, "splice-unquote")) { - (try elt.sequence_pop_first(Allocator)).delete(Allocator); - defer elt.delete(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "concat")); - try new_list.sequence_append(Allocator, try elt.sequence_pop_first(Allocator)); - } else { - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "cons")); - try new_list.sequence_append(Allocator, try quasiquote(elt)); - } - try new_list.sequence_append(Allocator, result); - result = new_list; - } - - if(kind == MalTypeValue.Vector) { - const new_list = try MalType.new_list_empty(Allocator); - try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "vec")); - try new_list.sequence_append(Allocator, result); - result = new_list; - } - return result; -} - -fn PRINT(optional_mal: ?*MalType) MalError![] u8 { - return printer.print_str(optional_mal); -} - -fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { - var read_input = (try READ(input)) orelse return null; - var eval_input = try EVAL(read_input, try environment.copy(Allocator)); - var print_input = try PRINT(eval_input); - eval_input.delete(Allocator); - return print_input; -} - -fn rep_and_print_errors(environment: *Env, input: [] const u8) ?[]u8 { - return rep(environment, input) catch |err| { - switch(err) { - MalError.KeyError => { }, - MalError.OutOfBounds => { - warn("Error: out of bounds\n"); - }, - MalError.ThrownError => { - warn("Thrown error: "); - const error_mal = lookup(environment, "__error", false) - catch {warn("\n"); return null;}; - const warning = PRINT(error_mal) - catch {warn("\n"); return null;}; - warn("{}\n", warning); - error_mal.delete(Allocator); - Allocator.free(warning); - }, - MalError.ReaderUnmatchedParen => { - warn("Error: expected closing paren, got EOF\n"); - }, - else => { - warn("Error: {}\n", error_string_repr(err)); - }, - } - return null; - }; -} - -fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { - var mal = environment.get(symbol) catch |err| { - if(do_warn) { - const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; - const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; - defer Allocator.free(s1); - defer Allocator.free(s2); - _ = try throw(try MalType.new_string(Allocator, s2)); - } - return MalError.KeyError; - }; - var new_mal = try mal.copy(Allocator); - return new_mal; -} - -fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { - defer env.delete(); - switch(mal.data) { - .Generic => |symbol| { - defer mal.delete(Allocator); - return lookup(env, symbol, true); - }, - .List => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_list(Allocator, new_ll); - return ret_mal; - }, - .Vector => |*ll| { - var new_ll = MalLinkedList.init(Allocator); - var iterator = ll.iterator(); - while(iterator.next()) |next_mal| { - const new_mal = try EVAL(next_mal, try env.copy(Allocator)); - try linked_list.append_mal(Allocator, &new_ll, new_mal); - } - linked_list.destroy(Allocator, ll, true); - mal.shallow_destroy(Allocator); - const ret_mal = MalType.new_vector(Allocator, new_ll); - return ret_mal; - }, - .HashMap => |hmap| { - var new_hashmap = try MalType.new_hashmap(Allocator); - var iterator = hmap.iterator(); - var optional_pair = iterator.next(); - while(true) { - const pair = optional_pair orelse break; - const key = pair.key; - const value = pair.value; - const evaled_value = try EVAL(value, try env.copy(Allocator)); - try new_hashmap.hashmap_insert(key, evaled_value); - optional_pair = iterator.next(); - } - hash_map.destroy(Allocator, hmap, true); - mal.shallow_destroy(Allocator); - return new_hashmap; - }, - else => { - return mal; - } - } -} - -fn throw(a1: *MalType) MalError!*MalType { - const error_mal = try a1.copy(Allocator); - try repl_environment.set("__error", error_mal); - return MalError.ThrownError; -} - -fn make_environment() MalError!*Env { - repl_environment = try Env.new(Allocator, null); - var environment = try repl_environment.copy(Allocator); - - for(core.core_namespace) |pair| { - const name = pair.name; - const func_mal: *MalType = try MalType.new_nil(Allocator); - func_mal.data = switch(pair.func) { - core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, - core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, - core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, - core.CorePairType.Fn3 => |func| MalData{.Fn3 = func}, - core.CorePairType.Fn4 => |func| MalData{.Fn4 = func}, - core.CorePairType.FVar => |func| MalData{.FVar = func}, - else => return MalError.TypeError, - }; - try environment.set(name, func_mal); - } - - const eval_mal = try MalType.new_nil(Allocator); - eval_mal.data = MalData{.Fn1 = &eval}; - try environment.set("eval", eval_mal); - - const throw_mal = try MalType.new_nil(Allocator); - throw_mal.data = MalData{.Fn1 = &throw}; - try environment.set("throw", throw_mal); - - const def_not_string: [] const u8 = - \\(def! not (fn* (a) (if a false true))) - ; - var optional_output = try rep(environment, def_not_string); - if(optional_output) |output| { - Allocator.free(output); - } - - const load_file_string: [] const u8 = - \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) - ; - optional_output = try rep(environment, load_file_string); - if(optional_output) |output| { - Allocator.free(output); - } - - const def_cond_macro_string: [] const u8 = - \\(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))))))) - ; - optional_output = try rep(environment, def_cond_macro_string); - if(optional_output) |output| { - Allocator.free(output); - } - - try environment.set("*host-language*", try MalType.new_string(Allocator, "Zig")); - - return environment; -} - -fn do_print_header(environment: *Env) MalError!void { - const welcome_msg_cmd: [] const u8 = - \\(println (str "Mal [" *host-language* "]")) - ; - var optional_output = try rep(environment, welcome_msg_cmd); - if(optional_output) |output| { - Allocator.free(output); - } -} - -fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { - const mal_func = try linked_list.pop_first(Allocator, args); - const env = env_ptr.*; - // First check if it is a user-defined Mal function - if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { - const func_data = mal_func.data.Func; - const args_ll = try func_data.arg_list.sequence_linked_list(); - const func_env = func_data.environment; - var new_env = try Env.new(Allocator, func_env); - func_env.delete(); - try new_env.set_list(args_ll.*, args.*); - linked_list.destroy(Allocator, args, true); - func_data.arg_list.delete(Allocator); - mal_func.shallow_destroy(Allocator); - mal_ptr.* = func_data.body; - env.delete(); - env_ptr.* = new_env; - return; - } - return MalError.TypeError; -} - -fn apply_function(args: MalLinkedList) MalError!*MalType { - - const return_mal = apply_function_unsafe(Allocator, args) catch |err| { - if(err == MalError.ReaderUnmatchedParen) { - warn("Error: expected closing paren, got EOF\n"); - } else if(err == MalError.ReaderUnmatchedString) { - warn("Error: expected closing string, got EOF\n"); - } - return err; - }; - return return_mal; -} - -pub fn main() !void { - const stdout_file = try std.io.getStdOut(); - Allocator = CAllocator; - core.set_allocator(Allocator); - - var environment = try make_environment(); - - const args = try std.process.argsAlloc(Allocator); - var arg_list = try MalType.new_list_empty(Allocator); - for(args) |arg,i| { - if(i < 2) continue; - const new_mal = try MalType.new_string(Allocator, arg); - try arg_list.sequence_append(Allocator, new_mal); - } - try environment.set("*ARGV*", arg_list); - - if(args.len > 1) { - const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); - var output = rep_and_print_errors(environment, run_cmd); - return; - } - - try do_print_header(repl_environment); - - while(true) { - var line = (try getline(Allocator)) orelse break; - var output = rep_and_print_errors(environment, line) orelse continue; - try stdout_file.write(output); - Allocator.free(output); - Allocator.free(line); - try stdout_file.write("\n"); - } -} +const std = @import("std"); +const warn = @import("std").debug.warn; + +const reader = @import("reader.zig"); +const printer = @import("printer.zig"); +const getline = @import("readline.zig").getline; +const string_eql = @import("utils.zig").string_eql; +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const apply_function_unsafe = @import("types.zig").apply_function; +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); +const core = @import("core.zig"); +const error_string_repr = @import("error.zig").error_string_repr; + +const CAllocator = @import("std").heap.c_allocator; +const AllocatorType = @import("std").mem.Allocator; +pub var Allocator: *AllocatorType = undefined; + +const MalType = @import("types.zig").MalType; +const MalTypeValue = @import("types.zig").MalTypeValue; +const MalData = @import("types.zig").MalData; +const MalError = @import("error.zig").MalError; +const MalFuncData = @import("types.zig").MalFuncData; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; +const Env = @import("env.zig").Env; + +var repl_environment: *Env = undefined; + +fn READ(a: []const u8) MalError!?*MalType { + var read = try reader.read_str(a); + var optional_mal = reader.read_form(&read); + return optional_mal; +} + +fn EVAL(mal_arg: *MalType, env_arg: *Env) MalError!*MalType { + var mal = mal_arg; + var env = env_arg; + while(true) { + mal = try macroexpand(mal, env); + switch(mal.data) { + .List => |ll| { + if(ll.len == 0) { + env.delete(); + return mal; + } + var first_mal = linked_list.first(&ll) orelse return MalError.ArgError; + var symbol = switch(first_mal.data) { + .Generic => |symbol| symbol, + else => "", + }; + if(string_eql(symbol, "def!")) { + return EVAL_def(mal, env, false); + } + else if(string_eql(symbol, "defmacro!")) { + return EVAL_def(mal, env, true); + } + else if(string_eql(symbol, "let*")) { + try EVAL_let(&mal, &env); + continue; + } + else if(string_eql(symbol, "do")) { + try EVAL_do(&mal, &env); + continue; + } + else if(string_eql(symbol, "if")) { + try EVAL_if(&mal, &env); + continue; + } + else if(string_eql(symbol, "fn*")) { + return EVAL_fn(mal, env); + } + else if(string_eql(symbol, "quote")) { + return EVAL_quote(mal, env); + } + else if(string_eql(symbol, "quasiquoteexpand")) { + env.delete(); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + mal.delete(Allocator); + return try quasiquote(second); + } + else if(string_eql(symbol, "quasiquote")) { + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + mal.delete(Allocator); + mal = try quasiquote(second); + continue; + } + else if(string_eql(symbol, "macroexpand")) { + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var second = try mal.sequence_pop_first(Allocator); + const expanded = macroexpand(second, env); + env.delete(); + return expanded; + } + else if(string_eql(symbol, "try*")) { + return EVAL_try(mal, env); + } + else { + var new_list = try eval_ast(mal, try env.copy(Allocator)); + + if(MalTypeValue((try new_list.sequence_nth(0)).data) == MalTypeValue.Func) { + try do_user_func(try new_list.sequence_linked_list(), &mal, &env); + new_list.shallow_destroy(Allocator); + continue; + } + const res = try apply_function((try new_list.sequence_linked_list()).*); + new_list.delete(Allocator); + env.delete(); + return res; + } + }, + else => { + return eval_ast(mal, env); + }, + } + } +} + +fn eval(a1: *MalType) MalError!*MalType { + return EVAL(try a1.copy(Allocator), try repl_environment.copy(Allocator)); +} + +fn starts_with(ast: *MalType, sym: []const u8) bool { + const ll = switch(ast.data) { + .List => |l| l, + else => return false, + }; + if(ll.count() < 2) { + return false; + } + const ss = switch(ll.at(0).data) { + .Generic => |s| s, + else => return false, + }; + return string_eql(ss, sym); +} + +fn is_macro_call(mal: *MalType, env: *Env) ?*MalType { + const ll = switch(mal.data) { + .List => |l| l, + else => return null, + }; + const first_node = linked_list.first(&ll) orelse return null; + const symbol = switch(first_node.data) { + .Generic => |s| s, + else => return null, + }; + const val = lookup(env, symbol, false) catch return null; + const is_macro = switch(val.data) { + .Func => |f| f.is_macro, + else => false, + }; + if(is_macro) { + return val; + } + val.delete(Allocator); + return null; +} + +fn macroexpand(mal: *MalType, env: *Env) MalError!*MalType { + var cur_mal = mal; + var optional_macro = is_macro_call(cur_mal, env); + while(optional_macro) |macro| { + var new_list = (try cur_mal.sequence_linked_list()).*; + + if(new_list.count() > 0) { + const first = try linked_list.pop_first(Allocator, &new_list); + first.delete(Allocator); + } + try linked_list.prepend_mal(Allocator, &new_list, macro); + var new_mal = try apply_function_unsafe(Allocator, new_list); + linked_list.destroy(Allocator, &new_list, false); + cur_mal.shallow_destroy(Allocator); + cur_mal = new_mal; + optional_macro = is_macro_call(cur_mal, env); + } + return cur_mal; +} + +fn EVAL_def(mal: *MalType, env: *Env, macro: bool) MalError!*MalType { + const first_arg = try mal.sequence_nth(1); + const second_arg = try mal.sequence_nth(2); + const second_arg_copy = try second_arg.copy(Allocator); + const symbol_name = try first_arg.as_symbol(); + const new_value = try EVAL(second_arg_copy, try env.copy(Allocator)); + if(macro) { + var func_data = switch(new_value.data) { + .Func => |*f| f, + else => return MalError.TypeError, + }; + func_data.*.is_macro = true; + } + try env.set(symbol_name, new_value); + mal.delete(Allocator); + env.delete(); + return new_value.copy(Allocator); +} + +fn EVAL_let(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + //TODO: make faster + const mal = mal_ptr.*; + const env = env_ptr.*; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + const binding_arg = try mal.sequence_pop_first(Allocator); + const eval_arg = try mal.sequence_pop_first(Allocator); + const new_env = try Env.new(Allocator, env); + var binding_ll = switch(binding_arg.data) { + .List => |l| l, + .Vector => |v| v, + else => return MalError.TypeError, + }; + var iterator = binding_ll.iterator(); + var optional_node = iterator.next(); + while(optional_node) |node| { + const key_mal = node; + const key = try key_mal.as_symbol(); + const val_mal = iterator.next() orelse return MalError.ArgError; + const evaled_mal = try EVAL(val_mal, try new_env.copy(Allocator)); + try new_env.set(key, evaled_mal); + optional_node = iterator.next(); + key_mal.delete(Allocator); + } + + linked_list.destroy(Allocator, &binding_ll, true); + binding_arg.data = MalData{.Nil=undefined}; + binding_arg.delete(Allocator); + mal.delete(Allocator); + + // We use eval_arg_copy, since we just deleted eval_arg above + mal_ptr.* = eval_arg; + env.delete(); + env_ptr.* = new_env; +} + +fn EVAL_do(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + var ll = &mal.data.List; + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var last_mal = try mal.sequence_pop_last(Allocator); + var evaled_mal = try eval_ast(mal, try env.copy(Allocator)); + evaled_mal.delete(Allocator); + mal_ptr.* = last_mal; +} + +fn EVAL_if(mal_ptr: **MalType, env_ptr: **Env) MalError!void { + var mal = mal_ptr.*; + var env = env_ptr.*; + defer mal.delete(Allocator); + const first_arg = try mal.sequence_nth(1); + const first_arg_copy = try first_arg.copy(Allocator); + const evaled = try EVAL(first_arg_copy, try env.copy(Allocator)); + const is_true = switch(evaled.data) { + .False => false, + .Nil => false, + else => true, + }; + evaled.delete(Allocator); + if(is_true) { + const second_arg = try mal.sequence_nth(2); + mal_ptr.* = try second_arg.copy(Allocator); + return; + } + if((try mal.sequence_length()) < 4) { + mal_ptr.* = try MalType.new_nil(Allocator); + return; + } + const third_arg = try mal.sequence_nth(3); + const third_arg_copy = try third_arg.copy(Allocator); + mal_ptr.* = third_arg_copy; +} + +fn EVAL_fn(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + const arg_mal = try (try mal.sequence_nth(1)).copy(Allocator); + const body_mal = try (try mal.sequence_nth(2)).copy(Allocator); + const func_data = MalFuncData { + .arg_list = arg_mal, + .body = body_mal, + .environment = env, + .is_macro = false, + .eval_func = &EVAL, + }; + const new_func = try MalType.new_nil(Allocator); + new_func.data = MalData{.Func = func_data}; + return new_func; +} + +fn EVAL_quote(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + defer env.delete(); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + return try mal.sequence_pop_first(Allocator); +} + +fn EVAL_try(mal: *MalType, env: *Env) MalError!*MalType { + defer mal.delete(Allocator); + (try mal.sequence_pop_first(Allocator)).delete(Allocator); + var mal_to_try = try mal.sequence_pop_first(Allocator); + if(0 == try mal.sequence_length()) { + return EVAL(mal_to_try, env); + } + var catch_mal = try mal.sequence_pop_first(Allocator); + + const evaled_mal = EVAL(mal_to_try, try env.copy(Allocator)) catch |err| { + switch(err) { + MalError.ThrownError => { + }, + else => { + const error_mal = try MalType.new_string(Allocator, error_string_repr(err)); + try env.set("__error", error_mal); + } + } + // TODO: check that first element of catch is "catch*" + (try catch_mal.sequence_pop_first(Allocator)).delete(Allocator); + const err_symbol = try catch_mal.sequence_pop_first(Allocator); + const err_body =try catch_mal.sequence_pop_first(Allocator); + catch_mal.delete(Allocator); + + const err_val = try lookup(env, "__error", false); + var new_env = try Env.new(Allocator, env); + try new_env.set(try err_symbol.as_symbol(), err_val); + err_symbol.delete(Allocator); + const result = EVAL(err_body, try new_env.copy(Allocator)); + new_env.delete(); + env.delete(); + return result; + }; + env.delete(); + return evaled_mal; +} + +fn quasiquote(ast: *MalType) MalError!*MalType { + const kind = MalTypeValue(ast.data); + if(kind == MalTypeValue.Generic or kind == MalTypeValue.HashMap) { + const new_list = try MalType.new_list_empty(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "quote")); + try new_list.sequence_append(Allocator, ast); + return new_list; + } + + if(kind != MalTypeValue.List and kind != MalTypeValue.Vector) { + return ast; + } + + defer ast.delete(Allocator); + + if(starts_with(ast, "unquote")) { + (try ast.sequence_pop_first(Allocator)).delete(Allocator); + return ast.sequence_pop_first(Allocator); + } + + var result = try MalType.new_list_empty(Allocator); + while(0 < (try ast.sequence_length())) { + var elt = try ast.sequence_pop_last(Allocator); + const new_list = try MalType.new_list_empty(Allocator); + if(starts_with(elt, "splice-unquote")) { + (try elt.sequence_pop_first(Allocator)).delete(Allocator); + defer elt.delete(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "concat")); + try new_list.sequence_append(Allocator, try elt.sequence_pop_first(Allocator)); + } else { + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "cons")); + try new_list.sequence_append(Allocator, try quasiquote(elt)); + } + try new_list.sequence_append(Allocator, result); + result = new_list; + } + + if(kind == MalTypeValue.Vector) { + const new_list = try MalType.new_list_empty(Allocator); + try new_list.sequence_append(Allocator, try MalType.new_generic(Allocator, "vec")); + try new_list.sequence_append(Allocator, result); + result = new_list; + } + return result; +} + +fn PRINT(optional_mal: ?*MalType) MalError![] u8 { + return printer.print_str(optional_mal); +} + +fn rep(environment: *Env, input: [] const u8) MalError!?[] u8 { + var read_input = (try READ(input)) orelse return null; + var eval_input = try EVAL(read_input, try environment.copy(Allocator)); + var print_input = try PRINT(eval_input); + eval_input.delete(Allocator); + return print_input; +} + +fn rep_and_print_errors(environment: *Env, input: [] const u8) ?[]u8 { + return rep(environment, input) catch |err| { + switch(err) { + MalError.KeyError => { }, + MalError.OutOfBounds => { + warn("Error: out of bounds\n"); + }, + MalError.ThrownError => { + warn("Thrown error: "); + const error_mal = lookup(environment, "__error", false) + catch {warn("\n"); return null;}; + const warning = PRINT(error_mal) + catch {warn("\n"); return null;}; + warn("{}\n", warning); + error_mal.delete(Allocator); + Allocator.free(warning); + }, + MalError.ReaderUnmatchedParen => { + warn("Error: expected closing paren, got EOF\n"); + }, + else => { + warn("Error: {}\n", error_string_repr(err)); + }, + } + return null; + }; +} + +fn lookup(environment: *Env, symbol: []const u8, do_warn: bool) MalError!*MalType { + var mal = environment.get(symbol) catch |err| { + if(do_warn) { + const s1 = string_concat(Allocator, "'", symbol) catch return MalError.SystemError; + const s2 = string_concat(Allocator, s1, "' not found") catch return MalError.SystemError; + defer Allocator.free(s1); + defer Allocator.free(s2); + _ = try throw(try MalType.new_string(Allocator, s2)); + } + return MalError.KeyError; + }; + var new_mal = try mal.copy(Allocator); + return new_mal; +} + +fn eval_ast(mal: *MalType, env: *Env) MalError!*MalType { + defer env.delete(); + switch(mal.data) { + .Generic => |symbol| { + defer mal.delete(Allocator); + return lookup(env, symbol, true); + }, + .List => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_list(Allocator, new_ll); + return ret_mal; + }, + .Vector => |*ll| { + var new_ll = MalLinkedList.init(Allocator); + var iterator = ll.iterator(); + while(iterator.next()) |next_mal| { + const new_mal = try EVAL(next_mal, try env.copy(Allocator)); + try linked_list.append_mal(Allocator, &new_ll, new_mal); + } + linked_list.destroy(Allocator, ll, true); + mal.shallow_destroy(Allocator); + const ret_mal = MalType.new_vector(Allocator, new_ll); + return ret_mal; + }, + .HashMap => |hmap| { + var new_hashmap = try MalType.new_hashmap(Allocator); + var iterator = hmap.iterator(); + var optional_pair = iterator.next(); + while(true) { + const pair = optional_pair orelse break; + const key = pair.key; + const value = pair.value; + const evaled_value = try EVAL(value, try env.copy(Allocator)); + try new_hashmap.hashmap_insert(key, evaled_value); + optional_pair = iterator.next(); + } + hash_map.destroy(Allocator, hmap, true); + mal.shallow_destroy(Allocator); + return new_hashmap; + }, + else => { + return mal; + } + } +} + +fn throw(a1: *MalType) MalError!*MalType { + const error_mal = try a1.copy(Allocator); + try repl_environment.set("__error", error_mal); + return MalError.ThrownError; +} + +fn make_environment() MalError!*Env { + repl_environment = try Env.new(Allocator, null); + var environment = try repl_environment.copy(Allocator); + + for(core.core_namespace) |pair| { + const name = pair.name; + const func_mal: *MalType = try MalType.new_nil(Allocator); + func_mal.data = switch(pair.func) { + core.CorePairType.Fn0 => |func| MalData{.Fn0 = func}, + core.CorePairType.Fn1 => |func| MalData{.Fn1 = func}, + core.CorePairType.Fn2 => |func| MalData{.Fn2 = func}, + core.CorePairType.Fn3 => |func| MalData{.Fn3 = func}, + core.CorePairType.Fn4 => |func| MalData{.Fn4 = func}, + core.CorePairType.FVar => |func| MalData{.FVar = func}, + else => return MalError.TypeError, + }; + try environment.set(name, func_mal); + } + + const eval_mal = try MalType.new_nil(Allocator); + eval_mal.data = MalData{.Fn1 = &eval}; + try environment.set("eval", eval_mal); + + const throw_mal = try MalType.new_nil(Allocator); + throw_mal.data = MalData{.Fn1 = &throw}; + try environment.set("throw", throw_mal); + + const def_not_string: [] const u8 = + \\(def! not (fn* (a) (if a false true))) + ; + var optional_output = try rep(environment, def_not_string); + if(optional_output) |output| { + Allocator.free(output); + } + + const load_file_string: [] const u8 = + \\(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)"))))) + ; + optional_output = try rep(environment, load_file_string); + if(optional_output) |output| { + Allocator.free(output); + } + + const def_cond_macro_string: [] const u8 = + \\(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))))))) + ; + optional_output = try rep(environment, def_cond_macro_string); + if(optional_output) |output| { + Allocator.free(output); + } + + try environment.set("*host-language*", try MalType.new_string(Allocator, "Zig")); + + return environment; +} + +fn do_print_header(environment: *Env) MalError!void { + const welcome_msg_cmd: [] const u8 = + \\(println (str "Mal [" *host-language* "]")) + ; + var optional_output = try rep(environment, welcome_msg_cmd); + if(optional_output) |output| { + Allocator.free(output); + } +} + +fn do_user_func(args: *MalLinkedList, mal_ptr: **MalType, env_ptr: **Env) MalError!void { + const mal_func = try linked_list.pop_first(Allocator, args); + const env = env_ptr.*; + // First check if it is a user-defined Mal function + if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { + const func_data = mal_func.data.Func; + const args_ll = try func_data.arg_list.sequence_linked_list(); + const func_env = func_data.environment; + var new_env = try Env.new(Allocator, func_env); + func_env.delete(); + try new_env.set_list(args_ll.*, args.*); + linked_list.destroy(Allocator, args, true); + func_data.arg_list.delete(Allocator); + mal_func.shallow_destroy(Allocator); + mal_ptr.* = func_data.body; + env.delete(); + env_ptr.* = new_env; + return; + } + return MalError.TypeError; +} + +fn apply_function(args: MalLinkedList) MalError!*MalType { + + const return_mal = apply_function_unsafe(Allocator, args) catch |err| { + if(err == MalError.ReaderUnmatchedParen) { + warn("Error: expected closing paren, got EOF\n"); + } else if(err == MalError.ReaderUnmatchedString) { + warn("Error: expected closing string, got EOF\n"); + } + return err; + }; + return return_mal; +} + +pub fn main() !void { + const stdout_file = try std.io.getStdOut(); + Allocator = CAllocator; + core.set_allocator(Allocator); + + var environment = try make_environment(); + + const args = try std.process.argsAlloc(Allocator); + var arg_list = try MalType.new_list_empty(Allocator); + for(args) |arg,i| { + if(i < 2) continue; + const new_mal = try MalType.new_string(Allocator, arg); + try arg_list.sequence_append(Allocator, new_mal); + } + try environment.set("*ARGV*", arg_list); + + if(args.len > 1) { + const run_cmd = try string_concat(Allocator, try string_concat(Allocator, "(load-file \"", args[1]), "\")"); + var output = rep_and_print_errors(environment, run_cmd); + return; + } + + try do_print_header(repl_environment); + + while(true) { + var line = (try getline(Allocator)) orelse break; + var output = rep_and_print_errors(environment, line) orelse continue; + try stdout_file.write(output); + Allocator.free(output); + Allocator.free(line); + try stdout_file.write("\n"); + } +} diff --git a/impls/zig/types.zig b/impls/zig/types.zig index 468b4c2251..362c61ec13 100644 --- a/impls/zig/types.zig +++ b/impls/zig/types.zig @@ -1,471 +1,471 @@ -const string_copy = @import("utils.zig").string_copy; -const string_concat = @import("utils.zig").string_concat; -const Allocator = @import("std").mem.Allocator; -const warn = @import("std").debug.warn; -const Env = @import("env.zig").Env; -const MalError = @import("error.zig").MalError; -const MalHashMap = @import("hmap.zig").MalHashMap; -const MalLinkedList = @import("linked_list.zig").MalLinkedList; - -const linked_list = @import("linked_list.zig"); -const hash_map = @import("hmap.zig"); - -pub const MalTypeValue = enum { - List, - Vector, - Generic, - Int, - String, - Keyword, - Nil, - True, - False, - Fn0, - Fn1, - Fn2, - Fn3, - Fn4, - FVar, - Func, - Atom, - HashMap, -}; - -pub const MalFuncData = struct { - arg_list: *MalType, - body: *MalType, - environment: *Env, - eval_func: ?(*const fn(o_mal: *MalType, env: *Env) MalError!*MalType), - is_macro: bool, -}; - -pub const MalData = union(MalTypeValue) { - List: MalLinkedList, - Vector: MalLinkedList, - Generic: []const u8, - Int: i64, - String: []const u8, - Keyword: []const u8, - Nil: void, - True: void, - False: void, - Fn0: *const fn () MalError!*MalType, - Fn1: *const fn (a1: *MalType) MalError!*MalType, - Fn2: *const fn (a1: *MalType, a2: *MalType) MalError!*MalType, - Fn3: *const fn (a1: *MalType, a2: *MalType, a3: *MalType) MalError!*MalType, - Fn4: *const fn (a1: *MalType, a2: *MalType, a3: *MalType, a4: *MalType) MalError!*MalType, - FVar: *const fn (args: MalLinkedList) MalError!*MalType, - Func: MalFuncData, - Atom: **MalType, - HashMap: MalHashMap, -}; - -pub const MalType = struct { - reference_count: *i32, - data: MalData, - meta: ?*MalType, - - pub fn new_nil(allocator: *Allocator) MalError!*MalType { - const mal: *MalType = allocator.create(MalType) - catch return MalError.SystemError; - errdefer allocator.destroy(mal); - mal.reference_count = allocator.create(i32) - catch return MalError.SystemError; - mal.reference_count.* = 1; - mal.data = MalData { .Nil = undefined }; - mal.meta = null; - return mal; - } - - pub fn new_generic(allocator: *Allocator, value: [] const u8) MalError!*MalType { - // TODO: should we free on errors? - const mal: *MalType = try MalType.new_nil(allocator); - errdefer mal.delete(allocator); - const value_copy = string_copy(allocator, value) - catch return MalError.SystemError; - errdefer allocator.destroy(value_copy); - mal.data = MalData { .Generic = value_copy }; - return mal; - } - - pub fn new_string(allocator: *Allocator, value: [] const u8) MalError!*MalType { - const mal = try MalType.new_nil(allocator); - const string_cpy = string_copy(allocator, value) catch return MalError.SystemError; - mal.data = MalData { .String = string_cpy }; - return mal; - } - - pub fn new_keyword(allocator: *Allocator, value: [] const u8) MalError!*MalType { - const mal = try MalType.new_nil(allocator); - const kwd_prefix: [] const u8 = [_]u8 {255}; - const kwd_cpy = string_concat(allocator, kwd_prefix, value) - catch return MalError.SystemError; - mal.data = MalData { .Keyword = kwd_cpy }; - return mal; - } - - pub fn new_int(allocator: *Allocator, value: i64) MalError!*MalType { - const mal = try MalType.new_nil(allocator); - mal.data = MalData { .Int = value }; - return mal; - } - - pub fn new_bool(allocator: *Allocator, b: bool) MalError!*MalType { - const mal = try MalType.new_nil(allocator); - if(b) { - mal.data = MalData { .True = undefined }; - } - else { - mal.data = MalData { .False = undefined }; - } - return mal; - } - - pub fn new_list_empty(allocator: *Allocator) MalError!*MalType { - const mal = try MalType.new_nil(allocator); - mal.data = MalData {.List = MalLinkedList.init(allocator)}; - return mal; - } - - pub fn new_vector_empty(allocator: *Allocator) MalError!*MalType { - const mal = try MalType.new_nil(allocator); - mal.data = MalData {.Vector = MalLinkedList.init(allocator)}; - return mal; - } - - pub fn new_list(allocator: *Allocator, ll: MalLinkedList) MalError!*MalType { - const mal = try MalType.new_nil(allocator); - mal.data = MalData {.List = ll}; - return mal; - } - - pub fn new_vector(allocator: *Allocator, ll: MalLinkedList) MalError!*MalType { - const mal = try MalType.new_nil(allocator); - mal.data = MalData {.Vector = ll}; - return mal; - } - - pub fn new_atom(allocator: *Allocator, mal: *MalType) MalError!*MalType { - const new_mal = try MalType.new_nil(allocator); - errdefer new_mal.delete(allocator); - const atom_value = allocator.create(*MalType) catch return MalError.SystemError; - atom_value.* = try mal.copy(allocator); - new_mal.data = MalData { .Atom = atom_value }; - return new_mal; - } - - pub fn new_hashmap(allocator: *Allocator) MalError!*MalType { - const new_mal = try MalType.new_nil(allocator); - errdefer new_mal.delete(allocator); - const hmap = MalHashMap.init(allocator); - new_mal.data = MalData {.HashMap = hmap}; - return new_mal; - } - - pub fn hashmap_insert(mal: *MalType, key: []const u8, value: *MalType) MalError!void { - switch(mal.data) { - .HashMap => |*hmap| { - _ = hmap.*.put(key, value) catch return MalError.SystemError; - }, - else => return MalError.TypeError, - } - } - - pub fn hashmap_remove(mal: *MalType, key: []const u8) MalError!void { - switch(mal.data) { - .HashMap => |*hmap| { - _ = hmap.*.remove(key); - }, - else => return MalError.TypeError, - } - } - - pub fn hashmap_get(mal: *MalType, key: []const u8) MalError!?*MalType { - // TODO: should we copy the data here, or downstream? - switch(mal.data) { - .HashMap => |hmap| { - return hmap.getValue(key); - }, - .Nil => { - return null; - }, - else => return MalError.TypeError, - } - } - - pub fn hashmap_contains(mal: *MalType, key: []const u8) MalError!bool { - // TODO: should we copy the data here, or downstream? - return switch(mal.data) { - .HashMap => |hmap| (hmap.getValue(key) != null), - else => MalError.TypeError, - }; - } - - pub fn sequence_linked_list(mal: *MalType) MalError!*MalLinkedList { - return switch(mal.data) { - .List => |*l| l, - .Vector => |*v| v, - else => MalError.TypeError, - }; - } - - pub fn const_sequence_linked_list(mal: *const MalType) MalError!MalLinkedList { - return switch(mal.data) { - .List => |l| l, - .Vector => |v| v, - else => MalError.TypeError, - }; - } - - pub fn sequence_append(mal: *MalType, allocator: *Allocator, new_el: *MalType) MalError!void { - var ll = try mal.sequence_linked_list(); - try linked_list.append_mal(allocator, ll, new_el); - } - - pub fn sequence_prepend(mal: *MalType, allocator: *Allocator, new_el: *MalType) MalError!void { - var ll = try mal.sequence_linked_list(); - try linked_list.prepend_mal(allocator, ll, new_el); - } - - pub fn sequence_pop_first(mal: *MalType, allocator: *Allocator) MalError!*MalType { - var ll = try mal.sequence_linked_list(); - return linked_list.pop_first(allocator, ll); - } - - pub fn sequence_pop_last(mal: *MalType, allocator: *Allocator) MalError!*MalType { - var ll = try mal.sequence_linked_list(); - if(ll.count() == 0) { - return MalError.OutOfBounds; - } - return ll.pop(); - } - - pub fn sequence_length(mal: *MalType) MalError!i64 { - return switch(mal.data) { - .List => |l| @intCast(i64, l.count()), - .Vector => |v| @intCast(i64, v.count()), - else => MalError.TypeError, - }; - } - - pub fn sequence_nth(mal: *MalType, pos: u32) MalError!*MalType { - var ll = try mal.sequence_linked_list(); - if(ll.count() <= pos) { - return MalError.OutOfBounds; - } - return ll.at(pos); - } - - pub fn as_int(mal: *const MalType) MalError!i64 { - return switch(mal.data) { - .Int => |val| val, - else => MalError.TypeError, - }; - } - - pub fn as_symbol(mal: *const MalType) MalError![]const u8 { - return switch(mal.data) { - .Generic => |val| val, - else => MalError.TypeError, - }; - } - - pub fn as_string(mal: *const MalType) MalError![]const u8 { - return switch(mal.data) { - .String => |s| s, - else => MalError.TypeError, - }; - } - - pub fn shallow_destroy(mal: *MalType, allocator: *Allocator) void { - mal.reference_count.* -= 1; - if(mal.meta) |mal_meta| { - mal_meta.delete(allocator); - } - if(mal.reference_count.* <= 0) { - allocator.destroy(mal.reference_count); - } - allocator.destroy(mal); - } - - pub fn delete(mal: *MalType, allocator: *Allocator) void { - const ref_count = mal.reference_count.*; - switch(mal.data) { - .List => |*l| { - linked_list.destroy(allocator, l, false); - }, - .Vector => |*v| { - linked_list.destroy(allocator, v, false); - }, - .String => |string| { - allocator.free(string); - }, - .Generic => |string| { - allocator.free(string); - }, - .Keyword => |string| { - allocator.free(string); - }, - .Atom => |atom| { - if(ref_count <= 1) - atom.*.delete(allocator); - }, - .HashMap => |hm| { - hash_map.destroy(allocator, hm, false); - }, - .Func => |func_data| { - func_data.arg_list.delete(allocator); - func_data.body.delete(allocator); - func_data.environment.delete(); - }, - else => {}, - } - mal.shallow_destroy(allocator); - } - - pub fn get_num_args(mal: *const MalType) i8 { - return switch(mal.data) { - .Fn0 => 0, - .Fn1 => 1, - .Fn2 => 2, - .Fn3 => 3, - .Fn4 => 4, - .FVar => -1, - else => -2, - }; - } - - pub fn copy(mal: *const MalType, allocator: *Allocator) MalError!*MalType { - var new_mal = allocator.create(MalType) - catch |err| return MalError.SystemError; - - new_mal.reference_count = mal.reference_count; - mal.reference_count.* += 1; - new_mal.data = MalData {.Nil=undefined}; - - if(mal.meta) |mal_meta| { - new_mal.meta = try mal_meta.copy(allocator); - } else { - new_mal.meta = null; - } - - switch(mal.data) { - .Generic => |val| { - const cpy_val = string_copy(allocator, val) - catch return MalError.SystemError; - new_mal.data = MalData { .Generic = cpy_val }; - }, - .Int => |val| { - new_mal.data = MalData { .Int = val }; - }, - .Fn0 => |f0| { - new_mal.data = MalData { .Fn0 = f0 }; - }, - .Fn1 => |f1| { - new_mal.data = MalData { .Fn1 = f1 }; - }, - .Fn2 => |f2| { - new_mal.data = MalData { .Fn2 = f2 }; - }, - .Fn3 => |f3| { - new_mal.data = MalData { .Fn3 = f3 }; - }, - .Fn4 => |f4| { - new_mal.data = MalData { .Fn4 = f4 }; - }, - .FVar => |f| { - new_mal.data = MalData { .FVar = f }; - }, - .String => |string| { - const string_cpy = string_copy(allocator, string) - catch return MalError.SystemError; - new_mal.data = MalData { .String = string_cpy }; - }, - .Keyword => |kwd| { - const kwd_cpy = string_copy(allocator, kwd) - catch return MalError.SystemError; - new_mal.data = MalData { .Keyword = kwd_cpy }; - }, - .List => |l| { - new_mal.data = MalData { .List = try linked_list.deepcopy(allocator, l) }; - }, - .Vector => |v| { - new_mal.data = MalData { .Vector = try linked_list.deepcopy(allocator, v) }; - }, - .Func => |func_data| { - const al = try func_data.arg_list.copy(allocator); - const b = try func_data.body.copy(allocator); - const new_func_data = MalFuncData { - .arg_list = al, - .body = b, - .environment = try func_data.environment.copy(allocator), - .eval_func = func_data.eval_func, - .is_macro = func_data.is_macro, - }; - new_mal.data = MalData { .Func = new_func_data }; - }, - .Atom => |atom| { - new_mal.data = MalData { .Atom = atom }; - }, - .HashMap => |h| { - new_mal.data = MalData {.HashMap = try hash_map.deepcopy(allocator, h)}; - }, - else => { - new_mal.data = mal.data; - }, - } - return new_mal; - } -}; - -pub fn apply_function(allocator: *Allocator, args: MalLinkedList) MalError!*MalType { - // TODO: this should take a MLL pointer - var args_copy = try linked_list.deepcopy(allocator, args); //TODO: could be more efficient - var args_arr = args_copy.toSlice(); - const mal_func = args_arr[0]; - - // First check if it is a user-defined Mal function - if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { - const func_data = mal_func.data.Func; - const args_ll = try func_data.arg_list.sequence_linked_list(); - const func_env = func_data.environment; - const eval_func = func_data.eval_func orelse return MalError.TypeError; - var new_env = try Env.new(allocator, func_env); - // TODO: make sure that set_list checks that first_arg and first_arg_value have same len - try new_env.set_slice(args_ll.toSlice(), args_arr[1..args_arr.len]); - - linked_list.destroy(allocator, &args_copy, true); - const new_body = try func_data.body.copy(allocator); - mal_func.delete(allocator); - return eval_func.*(new_body, new_env); - } - - // Otherwise, it is a built-in Zig function - // TODO: safety? - const n = mal_func.get_num_args(); - - if(n <= -2) { - return MalError.ArgError; - } - - if(n == -1) { - // Variable arg function - (try linked_list.pop_first(allocator, &args_copy)).delete(allocator); - defer linked_list.destroy(allocator, &args_copy, false); - return (mal_func.data.FVar.*)(args_copy); - } - - var arg = args_arr[1..args_arr.len]; - - // TODO: replace this - const ret = switch(n) { - 0 => (mal_func.data.Fn0.*)(), - 1 => (mal_func.data.Fn1.*)(arg[0]), - 2 => (mal_func.data.Fn2.*)(arg[0], arg[1]), - 3 => (mal_func.data.Fn3.*)(arg[0], arg[1], arg[2]), - 4 => (mal_func.data.Fn4.*)(arg[0], arg[1], arg[2], arg[3]), - else => MalError.ArgError, - }; - linked_list.destroy(allocator, &args_copy, false); - return ret; -} +const string_copy = @import("utils.zig").string_copy; +const string_concat = @import("utils.zig").string_concat; +const Allocator = @import("std").mem.Allocator; +const warn = @import("std").debug.warn; +const Env = @import("env.zig").Env; +const MalError = @import("error.zig").MalError; +const MalHashMap = @import("hmap.zig").MalHashMap; +const MalLinkedList = @import("linked_list.zig").MalLinkedList; + +const linked_list = @import("linked_list.zig"); +const hash_map = @import("hmap.zig"); + +pub const MalTypeValue = enum { + List, + Vector, + Generic, + Int, + String, + Keyword, + Nil, + True, + False, + Fn0, + Fn1, + Fn2, + Fn3, + Fn4, + FVar, + Func, + Atom, + HashMap, +}; + +pub const MalFuncData = struct { + arg_list: *MalType, + body: *MalType, + environment: *Env, + eval_func: ?(*const fn(o_mal: *MalType, env: *Env) MalError!*MalType), + is_macro: bool, +}; + +pub const MalData = union(MalTypeValue) { + List: MalLinkedList, + Vector: MalLinkedList, + Generic: []const u8, + Int: i64, + String: []const u8, + Keyword: []const u8, + Nil: void, + True: void, + False: void, + Fn0: *const fn () MalError!*MalType, + Fn1: *const fn (a1: *MalType) MalError!*MalType, + Fn2: *const fn (a1: *MalType, a2: *MalType) MalError!*MalType, + Fn3: *const fn (a1: *MalType, a2: *MalType, a3: *MalType) MalError!*MalType, + Fn4: *const fn (a1: *MalType, a2: *MalType, a3: *MalType, a4: *MalType) MalError!*MalType, + FVar: *const fn (args: MalLinkedList) MalError!*MalType, + Func: MalFuncData, + Atom: **MalType, + HashMap: MalHashMap, +}; + +pub const MalType = struct { + reference_count: *i32, + data: MalData, + meta: ?*MalType, + + pub fn new_nil(allocator: *Allocator) MalError!*MalType { + const mal: *MalType = allocator.create(MalType) + catch return MalError.SystemError; + errdefer allocator.destroy(mal); + mal.reference_count = allocator.create(i32) + catch return MalError.SystemError; + mal.reference_count.* = 1; + mal.data = MalData { .Nil = undefined }; + mal.meta = null; + return mal; + } + + pub fn new_generic(allocator: *Allocator, value: [] const u8) MalError!*MalType { + // TODO: should we free on errors? + const mal: *MalType = try MalType.new_nil(allocator); + errdefer mal.delete(allocator); + const value_copy = string_copy(allocator, value) + catch return MalError.SystemError; + errdefer allocator.destroy(value_copy); + mal.data = MalData { .Generic = value_copy }; + return mal; + } + + pub fn new_string(allocator: *Allocator, value: [] const u8) MalError!*MalType { + const mal = try MalType.new_nil(allocator); + const string_cpy = string_copy(allocator, value) catch return MalError.SystemError; + mal.data = MalData { .String = string_cpy }; + return mal; + } + + pub fn new_keyword(allocator: *Allocator, value: [] const u8) MalError!*MalType { + const mal = try MalType.new_nil(allocator); + const kwd_prefix: [] const u8 = [_]u8 {255}; + const kwd_cpy = string_concat(allocator, kwd_prefix, value) + catch return MalError.SystemError; + mal.data = MalData { .Keyword = kwd_cpy }; + return mal; + } + + pub fn new_int(allocator: *Allocator, value: i64) MalError!*MalType { + const mal = try MalType.new_nil(allocator); + mal.data = MalData { .Int = value }; + return mal; + } + + pub fn new_bool(allocator: *Allocator, b: bool) MalError!*MalType { + const mal = try MalType.new_nil(allocator); + if(b) { + mal.data = MalData { .True = undefined }; + } + else { + mal.data = MalData { .False = undefined }; + } + return mal; + } + + pub fn new_list_empty(allocator: *Allocator) MalError!*MalType { + const mal = try MalType.new_nil(allocator); + mal.data = MalData {.List = MalLinkedList.init(allocator)}; + return mal; + } + + pub fn new_vector_empty(allocator: *Allocator) MalError!*MalType { + const mal = try MalType.new_nil(allocator); + mal.data = MalData {.Vector = MalLinkedList.init(allocator)}; + return mal; + } + + pub fn new_list(allocator: *Allocator, ll: MalLinkedList) MalError!*MalType { + const mal = try MalType.new_nil(allocator); + mal.data = MalData {.List = ll}; + return mal; + } + + pub fn new_vector(allocator: *Allocator, ll: MalLinkedList) MalError!*MalType { + const mal = try MalType.new_nil(allocator); + mal.data = MalData {.Vector = ll}; + return mal; + } + + pub fn new_atom(allocator: *Allocator, mal: *MalType) MalError!*MalType { + const new_mal = try MalType.new_nil(allocator); + errdefer new_mal.delete(allocator); + const atom_value = allocator.create(*MalType) catch return MalError.SystemError; + atom_value.* = try mal.copy(allocator); + new_mal.data = MalData { .Atom = atom_value }; + return new_mal; + } + + pub fn new_hashmap(allocator: *Allocator) MalError!*MalType { + const new_mal = try MalType.new_nil(allocator); + errdefer new_mal.delete(allocator); + const hmap = MalHashMap.init(allocator); + new_mal.data = MalData {.HashMap = hmap}; + return new_mal; + } + + pub fn hashmap_insert(mal: *MalType, key: []const u8, value: *MalType) MalError!void { + switch(mal.data) { + .HashMap => |*hmap| { + _ = hmap.*.put(key, value) catch return MalError.SystemError; + }, + else => return MalError.TypeError, + } + } + + pub fn hashmap_remove(mal: *MalType, key: []const u8) MalError!void { + switch(mal.data) { + .HashMap => |*hmap| { + _ = hmap.*.remove(key); + }, + else => return MalError.TypeError, + } + } + + pub fn hashmap_get(mal: *MalType, key: []const u8) MalError!?*MalType { + // TODO: should we copy the data here, or downstream? + switch(mal.data) { + .HashMap => |hmap| { + return hmap.getValue(key); + }, + .Nil => { + return null; + }, + else => return MalError.TypeError, + } + } + + pub fn hashmap_contains(mal: *MalType, key: []const u8) MalError!bool { + // TODO: should we copy the data here, or downstream? + return switch(mal.data) { + .HashMap => |hmap| (hmap.getValue(key) != null), + else => MalError.TypeError, + }; + } + + pub fn sequence_linked_list(mal: *MalType) MalError!*MalLinkedList { + return switch(mal.data) { + .List => |*l| l, + .Vector => |*v| v, + else => MalError.TypeError, + }; + } + + pub fn const_sequence_linked_list(mal: *const MalType) MalError!MalLinkedList { + return switch(mal.data) { + .List => |l| l, + .Vector => |v| v, + else => MalError.TypeError, + }; + } + + pub fn sequence_append(mal: *MalType, allocator: *Allocator, new_el: *MalType) MalError!void { + var ll = try mal.sequence_linked_list(); + try linked_list.append_mal(allocator, ll, new_el); + } + + pub fn sequence_prepend(mal: *MalType, allocator: *Allocator, new_el: *MalType) MalError!void { + var ll = try mal.sequence_linked_list(); + try linked_list.prepend_mal(allocator, ll, new_el); + } + + pub fn sequence_pop_first(mal: *MalType, allocator: *Allocator) MalError!*MalType { + var ll = try mal.sequence_linked_list(); + return linked_list.pop_first(allocator, ll); + } + + pub fn sequence_pop_last(mal: *MalType, allocator: *Allocator) MalError!*MalType { + var ll = try mal.sequence_linked_list(); + if(ll.count() == 0) { + return MalError.OutOfBounds; + } + return ll.pop(); + } + + pub fn sequence_length(mal: *MalType) MalError!i64 { + return switch(mal.data) { + .List => |l| @intCast(i64, l.count()), + .Vector => |v| @intCast(i64, v.count()), + else => MalError.TypeError, + }; + } + + pub fn sequence_nth(mal: *MalType, pos: u32) MalError!*MalType { + var ll = try mal.sequence_linked_list(); + if(ll.count() <= pos) { + return MalError.OutOfBounds; + } + return ll.at(pos); + } + + pub fn as_int(mal: *const MalType) MalError!i64 { + return switch(mal.data) { + .Int => |val| val, + else => MalError.TypeError, + }; + } + + pub fn as_symbol(mal: *const MalType) MalError![]const u8 { + return switch(mal.data) { + .Generic => |val| val, + else => MalError.TypeError, + }; + } + + pub fn as_string(mal: *const MalType) MalError![]const u8 { + return switch(mal.data) { + .String => |s| s, + else => MalError.TypeError, + }; + } + + pub fn shallow_destroy(mal: *MalType, allocator: *Allocator) void { + mal.reference_count.* -= 1; + if(mal.meta) |mal_meta| { + mal_meta.delete(allocator); + } + if(mal.reference_count.* <= 0) { + allocator.destroy(mal.reference_count); + } + allocator.destroy(mal); + } + + pub fn delete(mal: *MalType, allocator: *Allocator) void { + const ref_count = mal.reference_count.*; + switch(mal.data) { + .List => |*l| { + linked_list.destroy(allocator, l, false); + }, + .Vector => |*v| { + linked_list.destroy(allocator, v, false); + }, + .String => |string| { + allocator.free(string); + }, + .Generic => |string| { + allocator.free(string); + }, + .Keyword => |string| { + allocator.free(string); + }, + .Atom => |atom| { + if(ref_count <= 1) + atom.*.delete(allocator); + }, + .HashMap => |hm| { + hash_map.destroy(allocator, hm, false); + }, + .Func => |func_data| { + func_data.arg_list.delete(allocator); + func_data.body.delete(allocator); + func_data.environment.delete(); + }, + else => {}, + } + mal.shallow_destroy(allocator); + } + + pub fn get_num_args(mal: *const MalType) i8 { + return switch(mal.data) { + .Fn0 => 0, + .Fn1 => 1, + .Fn2 => 2, + .Fn3 => 3, + .Fn4 => 4, + .FVar => -1, + else => -2, + }; + } + + pub fn copy(mal: *const MalType, allocator: *Allocator) MalError!*MalType { + var new_mal = allocator.create(MalType) + catch |err| return MalError.SystemError; + + new_mal.reference_count = mal.reference_count; + mal.reference_count.* += 1; + new_mal.data = MalData {.Nil=undefined}; + + if(mal.meta) |mal_meta| { + new_mal.meta = try mal_meta.copy(allocator); + } else { + new_mal.meta = null; + } + + switch(mal.data) { + .Generic => |val| { + const cpy_val = string_copy(allocator, val) + catch return MalError.SystemError; + new_mal.data = MalData { .Generic = cpy_val }; + }, + .Int => |val| { + new_mal.data = MalData { .Int = val }; + }, + .Fn0 => |f0| { + new_mal.data = MalData { .Fn0 = f0 }; + }, + .Fn1 => |f1| { + new_mal.data = MalData { .Fn1 = f1 }; + }, + .Fn2 => |f2| { + new_mal.data = MalData { .Fn2 = f2 }; + }, + .Fn3 => |f3| { + new_mal.data = MalData { .Fn3 = f3 }; + }, + .Fn4 => |f4| { + new_mal.data = MalData { .Fn4 = f4 }; + }, + .FVar => |f| { + new_mal.data = MalData { .FVar = f }; + }, + .String => |string| { + const string_cpy = string_copy(allocator, string) + catch return MalError.SystemError; + new_mal.data = MalData { .String = string_cpy }; + }, + .Keyword => |kwd| { + const kwd_cpy = string_copy(allocator, kwd) + catch return MalError.SystemError; + new_mal.data = MalData { .Keyword = kwd_cpy }; + }, + .List => |l| { + new_mal.data = MalData { .List = try linked_list.deepcopy(allocator, l) }; + }, + .Vector => |v| { + new_mal.data = MalData { .Vector = try linked_list.deepcopy(allocator, v) }; + }, + .Func => |func_data| { + const al = try func_data.arg_list.copy(allocator); + const b = try func_data.body.copy(allocator); + const new_func_data = MalFuncData { + .arg_list = al, + .body = b, + .environment = try func_data.environment.copy(allocator), + .eval_func = func_data.eval_func, + .is_macro = func_data.is_macro, + }; + new_mal.data = MalData { .Func = new_func_data }; + }, + .Atom => |atom| { + new_mal.data = MalData { .Atom = atom }; + }, + .HashMap => |h| { + new_mal.data = MalData {.HashMap = try hash_map.deepcopy(allocator, h)}; + }, + else => { + new_mal.data = mal.data; + }, + } + return new_mal; + } +}; + +pub fn apply_function(allocator: *Allocator, args: MalLinkedList) MalError!*MalType { + // TODO: this should take a MLL pointer + var args_copy = try linked_list.deepcopy(allocator, args); //TODO: could be more efficient + var args_arr = args_copy.toSlice(); + const mal_func = args_arr[0]; + + // First check if it is a user-defined Mal function + if(MalTypeValue(mal_func.data) == MalTypeValue.Func) { + const func_data = mal_func.data.Func; + const args_ll = try func_data.arg_list.sequence_linked_list(); + const func_env = func_data.environment; + const eval_func = func_data.eval_func orelse return MalError.TypeError; + var new_env = try Env.new(allocator, func_env); + // TODO: make sure that set_list checks that first_arg and first_arg_value have same len + try new_env.set_slice(args_ll.toSlice(), args_arr[1..args_arr.len]); + + linked_list.destroy(allocator, &args_copy, true); + const new_body = try func_data.body.copy(allocator); + mal_func.delete(allocator); + return eval_func.*(new_body, new_env); + } + + // Otherwise, it is a built-in Zig function + // TODO: safety? + const n = mal_func.get_num_args(); + + if(n <= -2) { + return MalError.ArgError; + } + + if(n == -1) { + // Variable arg function + (try linked_list.pop_first(allocator, &args_copy)).delete(allocator); + defer linked_list.destroy(allocator, &args_copy, false); + return (mal_func.data.FVar.*)(args_copy); + } + + var arg = args_arr[1..args_arr.len]; + + // TODO: replace this + const ret = switch(n) { + 0 => (mal_func.data.Fn0.*)(), + 1 => (mal_func.data.Fn1.*)(arg[0]), + 2 => (mal_func.data.Fn2.*)(arg[0], arg[1]), + 3 => (mal_func.data.Fn3.*)(arg[0], arg[1], arg[2]), + 4 => (mal_func.data.Fn4.*)(arg[0], arg[1], arg[2], arg[3]), + else => MalError.ArgError, + }; + linked_list.destroy(allocator, &args_copy, false); + return ret; +} diff --git a/impls/zig/utils.zig b/impls/zig/utils.zig index d9d0890768..9d15706dda 100644 --- a/impls/zig/utils.zig +++ b/impls/zig/utils.zig @@ -1,48 +1,48 @@ -const warn = @import("std").debug.warn; - -const Allocator = @import("std").mem.Allocator; - -pub fn string_eql(a: []const u8, b: []const u8) bool { - if(a.len != b.len) { - return false; - } - const n = a.len; - var i: usize = 0; - while(i < n) { - if(a[i] != b[i]) { - return false; - } - i += 1; - } - return true; -} - -pub fn string_copy(allocator: *Allocator, str: []const u8) ![]const u8 { - const copy = try allocator.alloc(u8, str.len); - var i: usize = 0; - while(i < str.len) { - copy[i] = str[i]; - i += 1; - } - return copy; -} - -pub fn string_concat(allocator: *Allocator, s1: []const u8, s2: []const u8) ![] const u8 { - const n: usize = s1.len + s2.len; - var i: usize = 0; - var pos: usize = 0; - const copy = try allocator.alloc(u8, n); - while(i < s1.len) { - copy[pos] = s1[i]; - pos += 1; - i += 1; - } - i = 0; - while(i < s2.len) { - copy[pos] = s2[i]; - pos += 1; - i += 1; - } - return copy; -} - +const warn = @import("std").debug.warn; + +const Allocator = @import("std").mem.Allocator; + +pub fn string_eql(a: []const u8, b: []const u8) bool { + if(a.len != b.len) { + return false; + } + const n = a.len; + var i: usize = 0; + while(i < n) { + if(a[i] != b[i]) { + return false; + } + i += 1; + } + return true; +} + +pub fn string_copy(allocator: *Allocator, str: []const u8) ![]const u8 { + const copy = try allocator.alloc(u8, str.len); + var i: usize = 0; + while(i < str.len) { + copy[i] = str[i]; + i += 1; + } + return copy; +} + +pub fn string_concat(allocator: *Allocator, s1: []const u8, s2: []const u8) ![] const u8 { + const n: usize = s1.len + s2.len; + var i: usize = 0; + var pos: usize = 0; + const copy = try allocator.alloc(u8, n); + while(i < s1.len) { + copy[pos] = s1[i]; + pos += 1; + i += 1; + } + i = 0; + while(i < s2.len) { + copy[pos] = s2[i]; + pos += 1; + i += 1; + } + return copy; +} + diff --git a/process/guide.md b/process/guide.md index e0f18b1208..6c2a18eb24 100644 --- a/process/guide.md +++ b/process/guide.md @@ -1,1748 +1,1748 @@ -# The Make-A-Lisp Process - -So you want to write a Lisp interpreter? Welcome! - -The goal of the Make-A-Lisp project is to make it easy to write your -own Lisp interpreter without sacrificing those many "Aha!" moments -that come from ascending the McCarthy mountain. When you reach the peak -of this particular mountain, you will have an interpreter for the mal -Lisp language that is powerful enough to be self-hosting, meaning it -will be able to run a mal interpreter written in mal itself. - -So jump right in (er ... start the climb)! - -- [Pick a language](#pick-a-language) -- [Getting started](#getting-started) -- [General hints](#general-hints) -- [The Make-A-Lisp Process](#the-make-a-lisp-process-1) - - [Step 0: The REPL](#step-0-the-repl) - - [Step 1: Read and Print](#step-1-read-and-print) - - [Step 2: Eval](#step-2-eval) - - [Step 3: Environments](#step-3-environments) - - [Step 4: If Fn Do](#step-4-if-fn-do) - - [Step 5: Tail call optimization](#step-5-tail-call-optimization) - - [Step 6: Files, Mutation, and Evil](#step-6-files-mutation-and-evil) - - [Step 7: Quoting](#step-7-quoting) - - [Step 8: Macros](#step-8-macros) - - [Step 9: Try](#step-9-try) - - [Step A: Metadata, Self-hosting and Interop](#step-a-metadata-self-hosting-and-interop) - - -## Pick a language - -You might already have a language in mind that you want to use. -Technically speaking, mal can be implemented in any sufficiently -complete programming language (i.e. Turing complete), however, there -are a few language features that can make the task MUCH easier. Here -are some of them in rough order of importance: - -* A sequential compound data structure (e.g. arrays, lists, - vectors, etc) -* An associative compound data structure (e.g. a dictionary, - hash-map, associative array, etc) -* Function references (first class functions, function pointers, - etc) -* Real exception handling (try/catch, raise, throw, etc) -* Variable argument functions (variadic, var args, splats, apply, etc) -* Function closures -* PCRE regular expressions - -In addition, the following will make your task especially easy: - -* Dynamic typing / boxed types (specifically, the ability to store - different data types in the sequential and associative structures - and the language keeps track of the type for you) -* Compound data types support arbitrary runtime "hidden" data - (metadata, metatables, dynamic fields attributes) - -Here are some examples of languages that have all of the above -features: JavaScript, Ruby, Python, Lua, R, Clojure. - -Michael Fogus has some great blog posts on interesting but less well -known languages and many of the languages on his lists do not yet have -any mal implementations: -* http://blog.fogus.me/2011/08/14/perlis-languages/ -* http://blog.fogus.me/2011/10/18/programming-language-development-the-past-5-years/ - -Many of the most popular languages already have Mal implementations. -However, this should not discourage you from creating your own -implementation in a language that already has one. However, if you go -this route, I suggest you avoid referring to the existing -implementations (i.e. "cheating") to maximize your learning experience -instead of just borrowing mine. On the other hand, if your goal is to -add new implementations to mal as efficiently as possible, then you -SHOULD find the most similar target language implementation and refer -to it frequently. - -If you want a list of programming languages with an -approximate measure of popularity try the [RedMonk Programming -Language -Rankings](https://redmonk.com/sogrady/2019/03/20/language-rankings-1-19/) -or the [GitHut 2.0 Project](https://madnight.github.io/githut). - - -## Getting started - -* Install your chosen language interpreter/compiler, language package - manager and build tools (if applicable) - -* Fork the mal repository on github and then clone your forked - repository: -``` -git clone git@github.com:YOUR_NAME/mal.git -cd mal -``` - -* Make a new directory for your implementation. For example, if your -language is called "quux": -``` -mkdir impls/quux -``` - -* Modify the top level Makefile.impls to allow the tests to be run against - your implementation. For example, if your language is named "quux" - and uses "qx" as the file extension, then make the following - 3 modifications to Makefile.impls: -``` -IMPLS = ... quux ... -... -quux_STEP_TO_PROG = impls/quux/$($(1)).qx -``` - -* Add a "run" script to your implementation directory that listens to - the "STEP" environment variable for the implementation step to run - and defaults to "stepA_mal". Make sure the run script has the - executable file permission set (or else the test runner might fail with a - permission denied error message). The following are examples of "run" - scripts for a compiled language and an interpreted language (where - the interpreter is named "quux"): - -``` -#!/bin/bash -exec $(dirname $0)/${STEP:-stepA_mal} "${@}" -``` - -``` -#!/bin/bash -exec quux $(dirname $0)/${STEP:-stepA_mal}.qx "${@}" -``` - -This allows you to run tests against your implementation like this: -``` -make "test^quux^stepX" -``` - -If your implementation language is a compiled language, then you -should also add a Makefile at the top level of your implementation -directory. This Makefile will define how to build the files pointed to -by the quux_STEP_TO_PROG macro. The top-level Makefile will attempt to -build those targets before running tests. If it is a scripting -language/uncompiled, then no Makefile is necessary because -quux_STEP_TO_PROG will point to a source file that already exists and -does not need to be compiled/built. - - -## General hints - -Stackoverflow and Google are your best friends. Modern polyglot -developers do not memorize dozens of programming languages. Instead, -they learn the peculiar terminology used with each language and then -use this to search for their answers. - -Here are some other resources where multiple languages are -compared/described: -* http://learnxinyminutes.com/ -* http://hyperpolyglot.org/ -* http://rosettacode.org/ -* http://rigaux.org/language-study/syntax-across-languages/ - -Do not let yourself be bogged down by specific problems. While the -make-a-lisp process is structured as a series of steps, the reality is -that building a lisp interpreter is more like a branching tree. If you -get stuck on tail call optimization, or hash-maps, move on to other -things. You will often have a stroke of inspiration for a problem as -you work through other functionality. I have tried to structure this -guide and the tests to make clear which things can be deferred until -later. - -An aside on deferrable/optional bits: when you run the tests for -a given step, the last tests are often marked with an "optional" -header. This indicates that these are tests for functionality that is -not critical to finish a basic mal implementation. Many of the steps -in this process guide have a "Deferrable" section, however, it is not -quite the same meaning. Those sections include the functionality that -is marked as optional in the tests, but they also include -functionality that becomes mandatory at a later step. In other words, -this is a "make your own Lisp adventure". - -Use test driven development. Each step of the make-a-lisp process has -a bunch of tests associated with it and there is an easy script to run -all the tests for a specific step in the process. Pick a failing test, -fix it, repeat until all the tests for that step pass. - -## Reference Code - -The `process` directory contains abbreviated pseudocode and -architecture diagrams for each step of the make-a-lisp process. Use -a textual diff/comparison tool to compare the previous pseudocode step -with the one you are working on. The architecture diagram images have -changes from the previous step highlighted in red. There is also -a concise -[cheatsheet](http://kanaka.github.io/mal/cheatsheet.html) that -summarizes the key changes at each step. - -If you get completely stuck and are feeling like giving up, then you -should "cheat" by referring to the same step or functionality in -an existing implementation language. You are here to learn, not to take -a test, so do not feel bad about it. Okay, you should feel a little -bit bad about it. - - -## The Make-A-Lisp Process - -Feel free to follow the guide as literally or as loosely as you -like. You are here to learn; wandering off the beaten path may be the -way you learn best. However, each step builds on the previous steps, -so if you are new to Lisp or new to your implementation language then -you may want to stick more closely to the guide your first time -through to avoid frustration at later steps. - -In the steps that follow the name of the target language is "quux" and -the file extension for that language is "qx". - - - - -### Step 0: The REPL - -![step0_repl architecture](step0_repl.png) - -This step is basically just creating a skeleton of your interpreter. - -* Create a `step0_repl.qx` file in `impls/quux/`. - -* Add the 4 trivial functions `READ`, `EVAL`, `PRINT`, and `rep` - (read-eval-print). `READ`, `EVAL`, and `PRINT` are basically just - stubs that return their first parameter (a string if your target - language is a statically typed) and `rep` calls them in order - passing the return to the input of the next. - -* Add a main loop that repeatedly prints a prompt (needs to be - "user> " for later tests to pass), gets a line of input from the - user, calls `rep` with that line of input, and then prints out the - result from `rep`. It should also exit when you send it an EOF - (often Ctrl-D). - -* If you are using a compiled (ahead-of-time rather than just-in-time) - language, then create a Makefile (or appropriate project definition - file) in your directory. - -It is time to run your first tests. This will check that your program -does input and output in a way that can be captured by the test -harness. Go to the top level and run the following: -``` -make "test^quux^step0" -``` - -Add and then commit your new `step0_repl.qx` and `Makefile` to git. - -Congratulations! You have just completed the first step of the -make-a-lisp process. - - -#### Optional: - -* Add full line editing and command history support to your - interpreter REPL. Many languages have a library/module that provide - line editing support. Another option if your language supports it is - to use an FFI (foreign function interface) to load and call directly - into GNU readline, editline, or linenoise library. Add line - editing interface code to `readline.qx` - - - - -### Step 1: Read and Print - -![step1_read_print architecture](step1_read_print.png) - -In this step, your interpreter will "read" the string from the user -and parse it into an internal tree data structure (an abstract syntax -tree) and then take that data structure and "print" it back to -a string. - -In non-lisp languages, this step (called "lexing and parsing") can be -one of the most complicated parts of the compiler/interpreter. In -Lisp, the data structure that you want in memory is basically -represented directly in the code that the programmer writes -(homoiconicity). - -For example, if the string is "(+ 2 (* 3 4))" then the read function -will process this into a tree structure that looks like this: -``` - List - / | \ - / | \ - / | \ - Sym:+ Int:2 List - / | \ - / | \ - / | \ - Sym:* Int:3 Int:4 -``` - -Each left paren and its matching right paren (lisp "sexpr") becomes -a node in the tree and everything else becomes a leaf in the tree. - -If you can find code for an implementation of a JSON encoder/decoder -in your target language then you can probably just borrow and modify -that and be 75% of the way done with this step. - -The rest of this section is going to assume that you are not starting -from an existing JSON encoder/decoder, but that you do have access to -a Perl compatible regular expressions (PCRE) module/library. You can -certainly implement the reader using simple string operations, but it -is more involved. The `make`, `ps` (postscript) and Haskell -implementations have examples of a reader/parser without using regular -expression support. - -* Copy `step0_repl.qx` to `step1_read_print.qx`. - -* Add a `reader.qx` file to hold functions related to the reader. - -* If the target language has objects types (OOP), then the next step - is to create a simple stateful Reader object in `reader.qx`. This - object will store the tokens and a position. The Reader object will - have two methods: `next` and `peek`. `next` returns the token at - the current position and increments the position. `peek` just - returns the token at the current position. - -* Add a function `read_str` in `reader.qx`. This function - will call `tokenize` and then create a new Reader object instance - with the tokens. Then it will call `read_form` with the Reader - instance. - -* Add a function `tokenize` in `reader.qx`. This function will take - a single string and return an array/list - of all the tokens (strings) in it. The following regular expression - (PCRE) will match all mal tokens. -``` -[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*) -``` -* For each match captured within the parenthesis starting at char 6 of the - regular expression a new token will be created. - - * `[\s,]*`: Matches any number of whitespaces or commas. This is not captured - so it will be ignored and not tokenized. - - * `~@`: Captures the special two-characters `~@` (tokenized). - - * ```[\[\]{}()'`~^@]```: Captures any special single character, one of - ```[]{}()'`~^@``` (tokenized). - - * `"(?:\\.|[^\\"])*"?`: Starts capturing at a double-quote and stops at the - next double-quote unless it was preceded by a backslash in which case it - includes it until the next double-quote (tokenized). It will also - match unbalanced strings (no ending double-quote) which should be - reported as an error. - - * `;.*`: Captures any sequence of characters starting with `;` (tokenized). - - * ```[^\s\[\]{}('"`,;)]*```: Captures a sequence of zero or more non special - characters (e.g. symbols, numbers, "true", "false", and "nil") and is sort - of the inverse of the one above that captures special characters (tokenized). - -* Add the function `read_form` to `reader.qx`. This function - will peek at the first token in the Reader object and switch on the - first character of that token. If the character is a left paren then - `read_list` is called with the Reader object. Otherwise, `read_atom` - is called with the Reader Object. The return value from `read_form` - is a mal data type. If your target language is statically typed then - you will need some way for `read_form` to return a variant or - subclass type. For example, if your language is object oriented, - then you can define a top level MalType (in `types.qx`) that all - your mal data types inherit from. The MalList type (which also - inherits from MalType) will contain a list/array of other MalTypes. - If your language is dynamically typed then you can likely just - return a plain list/array of other mal types. - -* Add the function `read_list` to `reader.qx`. This function will - repeatedly call `read_form` with the Reader object until it - encounters a ')' token (if it reach EOF before reading a ')' then - that is an error). It accumulates the results into a List type. If - your language does not have a sequential data type that can hold mal - type values you may need to implement one (in `types.qx`). Note - that `read_list` repeatedly calls `read_form` rather than - `read_atom`. This mutually recursive definition between `read_list` - and `read_form` is what allows lists to contain lists. - -* Add the function `read_atom` to `reader.qx`. This function will - look at the contents of the token and return the appropriate scalar - (simple/single) data type value. Initially, you can just implement - numbers (integers) and symbols. This will allow you to proceed - through the next couple of steps before you will need to implement - the other fundamental mal types: nil, true, false, and string. The - remaining scalar mal type, keyword does not - need to be implemented until step A (but can be implemented at any - point between this step and that). BTW, symbols types are just an - object that contains a single string name value (some languages have - symbol types already). - -* Add a file `printer.qx`. This file will contain a single function - `pr_str` which does the opposite of `read_str`: take a mal data - structure and return a string representation of it. But `pr_str` is - much simpler and is basically just a switch statement on the type of - the input object: - - * symbol: return the string name of the symbol - * number: return the number as a string - * list: iterate through each element of the list calling `pr_str` on - it, then join the results with a space separator, and surround the - final result with parens - -* Change the `READ` function in `step1_read_print.qx` to call - `reader.read_str` and the `PRINT` function to call `printer.pr_str`. - `EVAL` continues to simply return its input but the type is now - a mal data type. - -You now have enough hooked up to begin testing your code. You can -manually try some simple inputs: - * `123` -> `123` - * ` 123 ` -> `123` - * `abc` -> `abc` - * ` abc ` -> `abc` - * `(123 456)` -> `(123 456)` - * `( 123 456 789 ) ` -> `(123 456 789)` - * `( + 2 (* 3 4) ) ` -> `(+ 2 (* 3 4))` - -To verify that your code is doing more than just eliminating extra -spaces (and not failing), you can instrument your `reader.qx` functions. - -Once you have gotten past those simple manual tests, it is time to run -the full suite of step 1 tests. Go to the top level and run the -following: -``` -make "test^quux^step1" -``` - -Fix any test failures related to symbols, numbers and lists. - -Depending on the functionality of your target language, it is likely -that you have now just completed one of the most difficult steps. It -is down hill from here. The remaining steps will probably be easier -and each step will give progressively more bang for the buck. - -#### Deferrable: - - -* Add support for the other basic data type to your reader and printer - functions: string, nil, true, and false. Nil, true, and false - become mandatory at step 4, strings at step 6. When a string is read, - the following transformations are - applied: a backslash followed by a doublequote is translated into - a plain doublequote character, a backslash followed by "n" is - translated into a newline, and a backslash followed by another - backslash is translated into a single backslash. To properly print - a string (for step 4 string functions), the `pr_str` function needs - another parameter called `print_readably`. When `print_readably` is - true, doublequotes, newlines, and backslashes are translated into - their printed representations (the reverse of the reader). The - `PRINT` function in the main program should call `pr_str` with - print_readably set to true. - -* Add error checking to your reader functions to make sure parens - are properly matched. Catch and print these errors in your main - loop. If your language does not have try/catch style bubble up - exception handling, then you will need to add explicit error - handling to your code to catch and pass on errors without crashing. - -* Add support for reader macros which are forms that are - transformed into other forms during the read phase. Refer to - `tests/step1_read_print.mal` for the form that these macros should - take (they are just simple transformations of the token stream). - -* Add support for the other mal types: keyword, vector, hash-map. - * keyword: a keyword is a token that begins with a colon. A keyword - can just be stored as a string with special unicode prefix like - 0x29E (or char 0xff/127 if the target language does not have good - unicode support) and the printer translates strings with that - prefix back to the keyword representation. This makes it easy to - use keywords as hash map keys in most languages. You can also - store keywords as a unique data type, but you will need to make - sure they can be used as hash map keys (which may involve doing - a similar prefixed translation anyways). - * vector: a vector can be implemented with same underlying - type as a list as long as there is some mechanism to keep track of - the difference. - Vector literals are similar to lists, but use bracket as - delimiters instead of parenthesis. - For example, `[]` constructs an empty vector and `[1 "a"]` a - vector with two elements. - You can use the same reader function for both - lists and vectors by adding parameters for the starting and ending - tokens. - * hash-map: a hash-map is an associative data structure that maps - strings to other mal values. If you implement keywords as prefixed - strings, then you only need a native associative data structure - which supports string keys. Clojure allows any value to be a hash - map key, but the base functionality in mal is to support strings - and keyword keys. - Hash-map literals are constructed with braces delimiters. - For example, - `{}` constructs an empty map, - `{"a" 1 :b "whatever"}` associates the `a` key to an integer value - and the `:b` key to a string value. - Because of the representation of hash-maps as - an alternating sequence of keys and values, you can probably use - the same reader function for hash-maps as lists and vectors with - parameters to indicate the starting and ending tokens. The odd - tokens are then used for keys with the corresponding even tokens - as the values. - -* Add comment support to your reader. The tokenizer should ignore - tokens that start with ";". Your `read_str` function will need to - properly handle when the tokenizer returns no values. The simplest - way to do this is to return `nil` mal value. A cleaner option (that - does not print `nil` at the prompt is to throw a special exception - that causes the main loop to simply continue at the beginning of the - loop without calling `rep`. - - - - -### Step 2: Eval - -![step2_eval architecture](step2_eval.png) - -In step 1 your mal interpreter was basically just a way to validate -input and eliminate extraneous white space. In this step you will turn -your interpreter into a simple number calculator by adding -functionality to the evaluator (`EVAL`). - -Compare the pseudocode for step 1 and step 2 to get a basic idea of -the changes that will be made during this step: -``` -diff -urp ../process/step1_read_print.txt ../process/step2_eval.txt -``` - -* Copy `step1_read_print.qx` to `step2_eval.qx`. - -* Define a simple initial REPL environment. This environment is an - associative structure that maps symbols (or symbol names) to - numeric functions. For example, in python this would look something - like this: -``` -repl_env = {'+': lambda a,b: a+b, - '-': lambda a,b: a-b, - '*': lambda a,b: a*b, - '/': lambda a,b: int(a/b)} -``` - -* Modify the `rep` function to pass the REPL environment as the second - parameter for the `EVAL` call. - -* Create a new function `eval_ast` which takes `ast` (mal data type) - and an associative structure (the environment from above). - `eval_ast` switches on the type of `ast` as follows: - - * symbol: lookup the symbol in the environment structure and return - the value or raise an error if no value is found - * list: return a new list that is the result of calling `EVAL` on - each of the members of the list - * otherwise just return the original `ast` value - -* Modify `EVAL` to check if the first parameter `ast` is a list. - * `ast` is not a list: then return the result of calling `eval_ast` - on it. - * `ast` is a empty list: return ast unchanged. - * `ast` is a list: call `eval_ast` to get a new evaluated list. Take - the first item of the evaluated list and call it as function using - the rest of the evaluated list as its arguments. - -If your target language does not have full variable length argument -support (e.g. variadic, vararg, splats, apply) then you will need to -pass the full list of arguments as a single parameter and split apart -the individual values inside of every mal function. This is annoying, -but workable. - -The process of taking a list and invoking or executing it to return -something new is known in Lisp as the "apply" phase. - -Try some simple expressions: - - * `(+ 2 3)` -> `5` - * `(+ 2 (* 3 4))` -> `14` - -The most likely challenge you will encounter is how to properly call -a function references using an arguments list. - -Now go to the top level, run the step 2 tests and fix the errors. -``` -make "test^quux^step2" -``` - -You now have a simple prefix notation calculator! - -#### Deferrable: - -* `eval_ast` should evaluate elements of vectors and hash-maps. Add the - following cases in `eval_ast`: - * If `ast` is a vector: return a new vector that is the result of calling - `EVAL` on each of the members of the vector. - * If `ast` is a hash-map: return a new hash-map which consists of key-value - pairs where the key is a key from the hash-map and the value is the result - of calling `EVAL` on the corresponding value. - Depending on the implementation of maps, it may be convenient to - also call `EVAL` on keys. The result is the same because keys are - not affected by evaluation. - - - - -### Step 3: Environments - -![step3_env architecture](step3_env.png) - -In step 2 you were already introduced to REPL environment (`repl_env`) -where the basic numeric functions were stored and looked up. In this -step you will add the ability to create new environments (`let*`) and -modify existing environments (`def!`). - -A Lisp environment is an associative data structure that maps symbols (the -keys) to values. But Lisp environments have an additional important -function: they can refer to another environment (the outer -environment). During environment lookups, if the current environment -does not have the symbol, the lookup continues in the outer -environment, and continues this way until the symbol is either found, -or the outer environment is `nil` (the outermost environment in the -chain). - -Compare the pseudocode for step 2 and step 3 to get a basic idea of -the changes that will be made during this step: -``` -diff -urp ../process/step2_eval.txt ../process/step3_env.txt -``` - -* Copy `step2_eval.qx` to `step3_env.qx`. - -* Create `env.qx` to hold the environment definition. - -* Define an `Env` object that is instantiated with a single `outer` - parameter and starts with an empty associative data structure - property `data`. - -* Define three methods for the Env object: - * set: takes a symbol key and a mal value and adds to the `data` - structure - * find: takes a symbol key and if the current environment contains - that key then return the environment. If no key is found and outer - is not `nil` then call find (recurse) on the outer environment. - * get: takes a symbol key and uses the `find` method to locate the - environment with the key, then returns the matching value. If no - key is found up the outer chain, then throws/raises a "not found" - error. - -* Update `step3_env.qx` to use the new `Env` type to create the - repl_env (with a `nil` outer value) and use the `set` method to add - the numeric functions. - -* Modify `eval_ast` to call the `get` method on the `env` parameter. - -* Modify the apply section of `EVAL` to switch on the first element of - the list: - * symbol "def!": call the set method of the current environment - (second parameter of `EVAL` called `env`) using the unevaluated - first parameter (second list element) as the symbol key and the - evaluated second parameter as the value. - * symbol "let\*": create a new environment using the current - environment as the outer value and then use the first parameter as - a list of new bindings in the "let\*" environment. Take the second - element of the binding list, call `EVAL` using the new "let\*" - environment as the evaluation environment, then call `set` on the - "let\*" environment using the first binding list element as the key - and the evaluated second element as the value. This is repeated - for each odd/even pair in the binding list. Note in particular, - the bindings earlier in the list can be referred to by later - bindings. Finally, the second parameter (third element) of the - original `let*` form is evaluated using the new "let\*" environment - and the result is returned as the result of the `let*` (the new - let environment is discarded upon completion). - * otherwise: call `eval_ast` on the list and apply the first element - to the rest as before. - -`def!` and `let*` are Lisp "specials" (or "special atoms") which means -that they are language level features and more specifically that the -rest of the list elements (arguments) may be evaluated differently (or -not at all) unlike the default apply case where all elements of the -list are evaluated before the first element is invoked. Lists which -contain a "special" as the first element are known as "special forms". -They are special because they follow special evaluation rules. - -Try some simple environment tests: - - * `(def! a 6)` -> `6` - * `a` -> `6` - * `(def! b (+ a 2))` -> `8` - * `(+ a b)` -> `14` - * `(let* (c 2) c)` -> `2` - -Now go to the top level, run the step 3 tests and fix the errors. -``` -make "test^quux^step3" -``` - -Your mal implementation is still basically just a numeric calculator -with save/restore capability. But you have set the foundation for step -4 where it will begin to feel like a real programming language. - - -An aside on mutation and typing: - -The "!" suffix on symbols is used to indicate that this symbol refers -to a function that mutates something else. In this case, the `def!` -symbol indicates a special form that will mutate the current -environment. Many (maybe even most) of runtime problems that are -encountered in software engineering are a result of mutation. By -clearly marking code where mutation may occur, you can more easily -track down the likely cause of runtime problems when they do occur. - -Another cause of runtime errors is type errors, where a value of one -type is unexpectedly treated by the program as a different and -incompatible type. Statically typed languages try to make the -programmer solve all type problems before the program is allowed to -run. Most Lisp variants tend to be dynamically typed (types of values -are checked when they are actually used at runtime). - -As an aside-aside: The great debate between static and dynamic typing -can be understood by following the money. Advocates of strict static -typing use words like "correctness" and "safety" and thus get -government and academic funding. Advocates of dynamic typing use words -like "agile" and "time-to-market" and thus get venture capital and -commercial funding. - - - - -### Step 4: If Fn Do - -![step4_if_fn_do architecture](step4_if_fn_do.png) - -In step 3 you added environments and the special forms for -manipulating environments. In this step you will add 3 new special -forms (`if`, `fn*` and `do`) and add several more core functions to -the default REPL environment. Our new architecture will look like -this: - -The `fn*` special form is how new user-defined functions are created. -In some Lisps, this special form is named "lambda". - -Compare the pseudocode for step 3 and step 4 to get a basic idea of -the changes that will be made during this step: -``` -diff -urp ../process/step3_env.txt ../process/step4_if_fn_do.txt -``` - -* Copy `step3_env.qx` to `step4_if_fn_do.qx`. - -* If you have not implemented reader and printer support (and data - types) for `nil`, `true` and `false`, you will need to do so for - this step. - -* Update the constructor/initializer for environments to take two new - parameters: `binds` and `exprs`. Bind (`set`) each element (symbol) - of the binds list to the respective element of the `exprs` list. - -* Add support to `printer.qx` to print function values. A string - literal like "#\" is sufficient. - -* Add the following special forms to `EVAL`: - - * `do`: Evaluate all the elements of the list using `eval_ast` - and return the final evaluated element. - * `if`: Evaluate the first parameter (second element). If the result - (condition) is anything other than `nil` or `false`, then evaluate - the second parameter (third element of the list) and return the - result. Otherwise, evaluate the third parameter (fourth element) - and return the result. If condition is false and there is no third - parameter, then just return `nil`. - * `fn*`: Return a new function closure. The body of that closure - does the following: - * Create a new environment using `env` (closed over from outer - scope) as the `outer` parameter, the first parameter (second - list element of `ast` from the outer scope) as the `binds` - parameter, and the parameters to the closure as the `exprs` - parameter. - * Call `EVAL` on the second parameter (third list element of `ast` - from outer scope), using the new environment. Use the result as - the return value of the closure. - -If your target language does not support closures, then you will need -to implement `fn*` using some sort of structure or object that stores -the values being closed over: the first and second elements of the -`ast` list (function parameter list and function body) and the current -environment `env`. In this case, your native functions will need to be -wrapped in the same way. You will probably also need a method/function -that invokes your function object/structure for the default case of -the apply section of `EVAL`. - -Try out the basic functionality you have implemented: - - * `(fn* (a) a)` -> `#` - * `( (fn* (a) a) 7)` -> `7` - * `( (fn* (a) (+ a 1)) 10)` -> `11` - * `( (fn* (a b) (+ a b)) 2 3)` -> `5` - -* Add a new file `core.qx` and define an associative data structure - `ns` (namespace) that maps symbols to functions. Move the numeric - function definitions into this structure. - -* Modify `step4_if_fn_do.qx` to iterate through the `core.ns` - structure and add (`set`) each symbol/function mapping to the - REPL environment (`repl_env`). - -* Add the following functions to `core.ns`: - * `prn`: call `pr_str` on the first parameter with `print_readably` - set to true, prints the result to the screen and then return - `nil`. Note that the full version of `prn` is a deferrable below. - * `list`: take the parameters and return them as a list. - * `list?`: return true if the first parameter is a list, false - otherwise. - * `empty?`: treat the first parameter as a list and return true if - the list is empty and false if it contains any elements. - * `count`: treat the first parameter as a list and return the number - of elements that it contains. - * `=`: compare the first two parameters and return true if they are - the same type and contain the same value. In the case of equal - length lists, each element of the list should be compared for - equality and if they are the same return true, otherwise false. - * `<`, `<=`, `>`, and `>=`: treat the first two parameters as - numbers and do the corresponding numeric comparison, returning - either true or false. - -Now go to the top level, run the step 4 tests. There are a lot of -tests in step 4 but all of the non-optional tests that do not involve -strings should be able to pass now. - -``` -make "test^quux^step4" -``` - -Your mal implementation is already beginning to look like a real -language. You have flow control, conditionals, user-defined functions -with lexical scope, side-effects (if you implement the string -functions), etc. However, our little interpreter has not quite reached -Lisp-ness yet. The next several steps will take your implementation -from a neat toy to a full featured language. - -#### Deferrable: - -* Implement Clojure-style variadic function parameters. Modify the - constructor/initializer for environments, so that if a "&" symbol is - encountered in the `binds` list, the next symbol in the `binds` list - after the "&" is bound to the rest of the `exprs` list that has not - been bound yet. - -* Define a `not` function using mal itself. In `step4_if_fn_do.qx` - call the `rep` function with this string: - "(def! not (fn* (a) (if a false true)))". - -* Implement the strings functions in `core.qx`. To implement these - functions, you will need to implement the string support in the - reader and printer (deferrable section of step 1). Each of the string - functions takes multiple mal values, prints them (`pr_str`) and - joins them together into a new string. - * `pr-str`: calls `pr_str` on each argument with `print_readably` - set to true, joins the results with " " and returns the new - string. - * `str`: calls `pr_str` on each argument with `print_readably` set - to false, concatenates the results together ("" separator), and - returns the new string. - * `prn`: calls `pr_str` on each argument with `print_readably` set - to true, joins the results with " ", prints the string to the - screen and then returns `nil`. - * `println`: calls `pr_str` on each argument with `print_readably` set - to false, joins the results with " ", prints the string to the - screen and then returns `nil`. - - - - -### Step 5: Tail call optimization - -![step5_tco architecture](step5_tco.png) - -In step 4 you added special forms `do`, `if` and `fn*` and you defined -some core functions. In this step you will add a Lisp feature called -tail call optimization (TCO). Also called "tail recursion" or -sometimes just "tail calls". - -Several of the special forms that you have defined in `EVAL` end up -calling back into `EVAL`. For those forms that call `EVAL` as the last -thing that they do before returning (tail call) you will just loop back -to the beginning of eval rather than calling it again. The advantage -of this approach is that it avoids adding more frames to the call -stack. This is especially important in Lisp languages because they tend -to prefer using recursion instead of iteration for control structures. -(Though some Lisps, such as Common Lisp, have iteration.) However, with -tail call optimization, recursion can be made as stack efficient as -iteration. - -Compare the pseudocode for step 4 and step 5 to get a basic idea of -the changes that will be made during this step: -``` -diff -urp ../process/step4_if_fn_do.txt ../process/step5_tco.txt -``` - -* Copy `step4_if_fn_do.qx` to `step5_tco.qx`. - -* Add a loop (e.g. while true) around all code in `EVAL`. - -* Modify each of the following form cases to add tail call recursion - support: - * `let*`: remove the final `EVAL` call on the second `ast` argument - (third list element). Set `env` (i.e. the local variable passed in - as second parameter of `EVAL`) to the new let environment. Set - `ast` (i.e. the local variable passed in as first parameter of - `EVAL`) to be the second `ast` argument. Continue at the beginning - of the loop (no return). - * `do`: change the `eval_ast` call to evaluate all the parameters - except for the last (2nd list element up to but not including - last). Set `ast` to the last element of `ast`. Continue - at the beginning of the loop (`env` stays unchanged). - * `if`: the condition continues to be evaluated, however, rather - than evaluating the true or false branch, `ast` is set to the - unevaluated value of the chosen branch. Continue at the beginning - of the loop (`env` is unchanged). - -* The return value from the `fn*` special form will now become an - object/structure with attributes that allow the default invoke case - of `EVAL` to do TCO on mal functions. Those attributes are: - * `ast`: the second `ast` argument (third list element) representing - the body of the function. - * `params`: the first `ast` argument (second list element) - representing the parameter names of the function. - * `env`: the current value of the `env` parameter of `EVAL`. - * `fn`: the original function value (i.e. what was return by `fn*` - in step 4). Note that this is deferrable until step 9 when it is - required for the `map` and `apply` core functions). You will also - need it in step 6 if you choose to not to defer atoms/`swap!` from - that step. - -* The default "apply"/invoke case of `EVAL` must now be changed to - account for the new object/structure returned by the `fn*` form. - Continue to call `eval_ast` on `ast`. The first element of the - result of `eval_ast` is `f` and the remaining elements are in `args`. - Switch on the type of `f`: - * regular function (not one defined by `fn*`): apply/invoke it as - before (in step 4). - * a `fn*` value: set `ast` to the `ast` attribute of `f`. Generate - a new environment using the `env` and `params` attributes of `f` - as the `outer` and `binds` arguments and `args` as the `exprs` - argument. Set `env` to the new environment. Continue at the - beginning of the loop. - -Run some manual tests from previous steps to make sure you have not -broken anything by adding TCO. - -Now go to the top level, run the step 5 tests. - -``` -make "test^quux^step5" -``` - -Look at the step 5 test file `tests/step5_tco.mal`. The `sum-to` -function cannot be tail call optimized because it does something after -the recursive call (`sum-to` calls itself and then does the addition). -Lispers say that the `sum-to` is not in tail position. The `sum2` -function however, calls itself from tail position. In other words, the -recursive call to `sum2` is the last action that `sum2` does. Calling -`sum-to` with a large value will cause a stack overflow exception in -most target languages (some have super-special tricks they use to -avoid stack overflows). - -Congratulations, your mal implementation already has a feature (TCO) -that most mainstream languages lack. - - - - -### Step 6: Files, Mutation, and Evil - -![step6_file architecture](step6_file.png) - -In step 5 you added tail call optimization. In this step you will add -some string and file operations and give your implementation a touch -of evil ... er, eval. And as long as your language supports function -closures, this step will be quite simple. However, to complete this -step, you must implement string type support, so if you have been -holding off on that you will need to go back and do so. - -Compare the pseudocode for step 5 and step 6 to get a basic idea of -the changes that will be made during this step: -``` -diff -urp ../process/step5_tco.txt ../process/step6_file.txt -``` - -* Copy `step5_tco.qx` to `step6_file.qx`. - -* Add two new string functions to the core namespaces: - * `read-string`: this function just exposes the `read_str` function - from the reader. If your mal string type is not the same as your - target language (e.g. statically typed language) then your - `read-string` function will need to unbox (extract) the raw string - from the mal string type in order to call `read_str`. - * `slurp`: this function takes a file name (string) and returns the - contents of the file as a string. Once again, if your mal string - type wraps a raw target language string, then you will need to - unmarshall (extract) the string parameter to get the raw file name - string and marshall (wrap) the result back to a mal string type. - -* In your main program, add a new symbol "eval" to your REPL - environment. The value of this new entry is a function that takes - a single argument `ast`. The closure calls your `EVAL` function - using the `ast` as the first argument and the REPL environment - (closed over from outside) as the second argument. The result of - the `EVAL` call is returned. This simple but powerful addition - allows your program to treat mal data as a mal program. For example, - you can now do this: -``` -(def! mal-prog (list + 1 2)) -(eval mal-prog) -``` - -* Define a `load-file` function using mal itself. In your main - program call the `rep` function with this string: - "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))". - -Try out `load-file`: - * `(load-file "../tests/incA.mal")` -> `9` - * `(inc4 3)` -> `7` - -The `load-file` function does the following: - * Call `slurp` to read in a file by name. Surround the contents with - "(do ...)" so that the whole file will be treated as a single - program AST (abstract syntax tree). Add a new line in case the files - ends with a comment. The `nil` ensures a short and predictable result, - instead of what happens to be the last function defined in the loaded file. - * Call `read-string` on the string returned from `slurp`. This uses - the reader to read/convert the file contents into mal data/AST. - * Call `eval` (the one in the REPL environment) on the AST returned - from `read-string` to "run" it. - -Besides adding file and eval support, we'll add support for the atom data type -in this step. An atom is the Mal way to represent *state*; it is -heavily inspired by [Clojure's atoms](http://clojure.org/state). An atom holds -a reference to a single Mal value of any type; it supports reading that Mal value -and *modifying* the reference to point to another Mal value. Note that this is -the only Mal data type that is mutable (but the Mal values it refers to are -still immutable; immutability is explained in greater detail in step 7). -You'll need to add 5 functions to the core namespace to support atoms: - - * `atom`: Takes a Mal value and returns a new atom which points to that Mal value. - * `atom?`: Takes an argument and returns `true` if the argument is an atom. - * `deref`: Takes an atom argument and returns the Mal value referenced by this atom. - * `reset!`: Takes an atom and a Mal value; the atom is modified to refer to - the given Mal value. The Mal value is returned. - * `swap!`: Takes an atom, a function, and zero or more function arguments. The - atom's value is modified to the result of applying the function with the atom's - value as the first argument and the optionally given function arguments as - the rest of the arguments. The new atom's value is returned. (Side note: Mal is - single-threaded, but in concurrent languages like Clojure, `swap!` promises - atomic update: `(swap! myatom (fn* [x] (+ 1 x)))` will always increase the - `myatom` counter by one and will not suffer from missing updates when the - atom is updated from multiple threads.) - -Optionally, you can add a reader macro `@` which will serve as a short form for -`deref`, so that `@a` is equivalent to `(deref a)`. In order to do that, modify -the conditional in reader `read_form` function and add a case which deals with -the `@` token: if the token is `@` (at sign) then return a new list that -contains the symbol `deref` and the result of reading the next form -(`read_form`). - -Now go to the top level, run the step 6 tests. The optional tests will -need support from the reader for comments, vectors, hash-maps and the `@` -reader macro: -``` -make "test^quux^step6" -``` - -Congratulations, you now have a full-fledged scripting language that -can run other mal programs. The `slurp` function loads a file as -a string, the `read-string` function calls the mal reader to turn that -string into data, and the `eval` function takes data and evaluates it -as a normal mal program. However, it is important to note that the -`eval` function is not just for running external programs. Because mal -programs are regular mal data structures, you can dynamically generate -or manipulate those data structures before calling `eval` on them. -This isomorphism (same shape) between data and programs is known as -"homoiconicity". Lisp languages are homoiconic and this property -distinguishes them from most other programming languages. - -Your mal implementation is quite powerful already but the set of -functions that are available (from `core.qx`) is fairly limited. The -bulk of the functions you will add are described in step 9 and step A, -but you will begin to flesh them out over the next few steps to -support quoting (step 7) and macros (step 8). - - -#### Deferrable: - -* Add the ability to run another mal program from the command line. - Prior to the REPL loop, check if your mal implementation is called - with command line arguments. If so, treat the first argument as - a filename and use `rep` to call `load-file` on that filename, and - finally exit/terminate execution. - -* Add the rest of the command line arguments to your REPL environment - so that programs that are run with `load-file` have access to their - calling environment. Add a new "\*ARGV\*" (symbol) entry to your REPL - environment. The value of this entry should be the rest of the - command line arguments as a mal list value. - - - - -### Step 7: Quoting - -![step7_quote architecture](step7_quote.png) - -In step 7 you will add the special forms `quote` and `quasiquote` and -add supporting core functions `cons` and `concat`. The two quote forms -add a powerful abstraction for manipulating mal code itself -(meta-programming). - -The `quote` special form indicates to the evaluator (`EVAL`) that the -parameter should not be evaluated (yet). At first glance, this might -not seem particularly useful but an example of what this enables is the -ability for a mal program to refer to a symbol itself rather than the -value that it evaluates to. Likewise with lists. For example, consider -the following: - -* `(prn abc)`: this will lookup the symbol `abc` in the current - evaluation environment and print it. This will result in error if - `abc` is not defined. -* `(prn (quote abc))`: this will print "abc" (prints the symbol - itself). This will work regardless of whether `abc` is defined in - the current environment. -* `(prn (1 2 3))`: this will result in an error because `1` is not - a function and cannot be applied to the arguments `(2 3)`. -* `(prn (quote (1 2 3)))`: this will print "(1 2 3)". -* `(def! l (quote (1 2 3)))`: list quoting allows us to define lists - directly in the code (list literal). Another way of doing this is - with the list function: `(def! l (list 1 2 3))`. - -The second special quoting form is `quasiquote`. This allows a quoted -list to have internal elements of the list that are temporarily -unquoted (normal evaluation). There are two special forms that only -mean something within a quasiquoted list: `unquote` and -`splice-unquote`. These are perhaps best explained with some examples: - -* `(def! lst (quote (b c)))` -> `(b c)` -* `(quasiquote (a lst d))` -> `(a lst d)` -* `(quasiquote (a (unquote lst) d))` -> `(a (b c) d)` -* `(quasiquote (a (splice-unquote lst) d))` -> `(a b c d)` - -The `unquote` form turns evaluation back on for its argument and the -result of evaluation is put in place into the quasiquoted list. The -`splice-unquote` also turns evaluation back on for its argument, but -the evaluated value must be a list which is then "spliced" into the -quasiquoted list. The true power of the quasiquote form will be -manifest when it is used together with macros (in the next step). - -Compare the pseudocode for step 6 and step 7 to get a basic idea of -the changes that will be made during this step: -``` -diff -urp ../process/step6_file.txt ../process/step7_quote.txt -``` - -* Copy `step6_file.qx` to `step7_quote.qx`. - -* Before implementing the quoting forms, you will need to implement - some supporting functions in the core namespace: - * `cons`: this function takes a list as its second - parameter and returns a new list that has the first argument - prepended to it. - * `concat`: this functions takes 0 or more lists as - parameters and returns a new list that is a concatenation of all - the list parameters. - -An aside on immutability: note that neither cons or concat mutate -their original list arguments. Any references to them (i.e. other -lists that they may be "contained" in) will still refer to the -original unchanged value. Mal, like Clojure, is a language which uses -immutable data structures. I encourage you to read about the power and -importance of immutability as implemented in Clojure (from which -Mal borrows most of its syntax and feature-set). - -* Add the `quote` special form. This form just returns its argument - (the second list element of `ast`). - -* Add the `quasiquote` function. - The `quasiquote` function takes a parameter `ast` and has the - following conditional. - - If `ast` is a list starting with the "unquote" symbol, return its - second element. - - If `ast` is a list failing previous test, the result will be a - list populated by the following process. - - The result is initially an empty list. - Iterate over each element `elt` of `ast` in reverse order: - - If `elt` is a list starting with the "splice-unquote" symbol, - replace the current result with a list containing: - the "concat" symbol, - the second element of `elt`, - then the previous result. - - Else replace the current result with a list containing: - the "cons" symbol, - the result of calling `quasiquote` with `elt` as argument, - then the previous result. - - This process can also be described recursively: - - If `ast` is empty return it unchanged. else let `elt` be its - first element. - - If `elt` is a list starting with the "splice-unquote" symbol, - return a list containing: - the "concat" symbol, - the second element of `elt`, - then the result of processing the rest of `ast`. - - Else return a list containing: - the "cons" symbol, - the result of calling `quasiquote` with `elt` as argument, - then the result of processing the rest of `ast`. - - If `ast` is a map or a symbol, return a list containing: - the "quote" symbol, - then `ast`. - - Else return `ast` unchanged. - Such forms are not affected by evaluation, so you may quote them - as in the previous case if implementation is easier. - -* Optionally, add a the `quasiquoteexpand` special form. - This form calls the `quasiquote` function using the first `ast` - argument (second list element) and returns the result. - It has no other practical purpose than testing your implementation - of the `quasiquote` internal function. - -* Add the `quasiquote` special form. - This form does the same than `quasiquoteexpand`, - but evaluates the result in the current environment before returning it, - either by recursively calling `EVAL` with the result and `env`, - or by assigning `ast` with the result and continuing execution at - the top of the loop (TCO). - -Now go to the top level, run the step 7 tests: -``` -make "test^quux^step7" -``` - -Quoting is one of the more mundane functions available in mal, but do -not let that discourage you. Your mal implementation is almost -complete, and quoting sets the stage for the next very exciting step: -macros. - - -#### Deferrable - -* The full names for the quoting forms are fairly verbose. Most Lisp - languages have a short-hand syntax and Mal is no exception. These - short-hand syntaxes are known as reader macros because they allow us - to manipulate mal code during the reader phase. Macros that run - during the eval phase are just called "macros" and are described in - the next section. Expand the conditional with reader `read_form` - function to add the following four cases: - * token is "'" (single quote): return a new list that contains the - symbol "quote" and the result of reading the next form - (`read_form`). - * token is "\`" (back-tick): return a new list that contains the - symbol "quasiquote" and the result of reading the next form - (`read_form`). - * token is "~" (tilde): return a new list that contains the - symbol "unquote" and the result of reading the next form - (`read_form`). - * token is "~@" (tilde + at sign): return a new list that contains - the symbol "splice-unquote" and the result of reading the next - form (`read_form`). - -* Add support for quoting of vectors. `cons` - should also accept a vector as the second argument. The return value - is a list regardless. `concat` should support concatenation of - lists, vectors, or a mix of both. The result is always a list. - - Implement a core function `vec` turning a list into a vector with - the same elements. If provided a vector, `vec` should return it - unchanged. - - In the `quasiquote` function, when `ast` is a vector, - return a list containing: - the "vec" symbol, - then the result of processing `ast` as if it were a list not - starting with `unquote`. - - - -### Step 8: Macros - -![step8_macros architecture](step8_macros.png) - -Your mal implementation is now ready for one of the most lispy and -exciting of all programming concepts: macros. In the previous step, -quoting enabled some simple manipulation data structures and therefore -manipulation of mal code (because the `eval` function from step -6 turns mal data into code). In this step you will be able to mark mal -functions as macros which can manipulate mal code before it is -evaluated. In other words, macros are user-defined special forms. Or -to look at it another way, macros allow mal programs to redefine -the mal language itself. - -Compare the pseudocode for step 7 and step 8 to get a basic idea of -the changes that will be made during this step: -``` -diff -urp ../process/step7_quote.txt ../process/step8_macros.txt -``` - -* Copy `step7_quote.qx` to `step8_macros.qx`. - - -You might think that the infinite power of macros would require some -sort of complex mechanism, but the implementation is actually fairly -simple. - -* Add a new attribute `is_macro` to mal function types. This should - default to false. - -* Add a new special form `defmacro!`. This is very similar to the - `def!` form, but before the evaluated value (mal function) is set in - the environment, the `is_macro` attribute should be set to true. - -* Add a `is_macro_call` function: This function takes arguments `ast` - and `env`. It returns true if `ast` is a list that contains a symbol - as the first element and that symbol refers to a function in the - `env` environment and that function has the `is_macro` attribute set - to true. Otherwise, it returns false. - -* Add a `macroexpand` function: This function takes arguments `ast` - and `env`. It calls `is_macro_call` with `ast` and `env` and loops - while that condition is true. Inside the loop, the first element of - the `ast` list (a symbol), is looked up in the environment to get - the macro function. This macro function is then called/applied with - the rest of the `ast` elements (2nd through the last) as arguments. - The return value of the macro call becomes the new value of `ast`. - When the loop completes because `ast` no longer represents a macro - call, the current value of `ast` is returned. - -* In the evaluator (`EVAL`) before the special forms switch (apply - section), perform macro expansion by calling the `macroexpand` - function with the current value of `ast` and `env`. Set `ast` to the - result of that call. If the new value of `ast` is no longer a list - after macro expansion, then return the result of calling `eval_ast` - on it, otherwise continue with the rest of the apply section - (special forms switch). - -* Add a new special form condition for `macroexpand`. Call the - `macroexpand` function using the first `ast` argument (second list - element) and `env`. Return the result. This special form allows - a mal program to do explicit macro expansion without applying the - result (which can be useful for debugging macro expansion). - -Now go to the top level, run the step 8 tests: -``` -make "test^quux^step8" -``` - -There is a reasonably good chance that the macro tests will not pass -the first time. Although the implementation of macros is fairly -simple, debugging runtime bugs with macros can be fairly tricky. If -you do run into subtle problems that are difficult to solve, let me -recommend a couple of approaches: - -* Use the macroexpand special form to eliminate one of the layers of - indirection (to expand but skip evaluate). This will often reveal - the source of the issue. -* Add a debug print statement to the top of your main `eval` function - (inside the TCO loop) to print the current value of `ast` (hint use - `pr_str` to get easier to debug output). Pull up the step8 - implementation from another language and uncomment its `eval` - function (yes, I give you permission to violate the rule this once). - Run the two side-by-side. The first difference is likely to point to - the bug. - -Congratulations! You now have a Lisp interpreter with a super power -that most non-Lisp languages can only dream of (I have it on good -authority that languages dream when you are not using them). If you -are not already familiar with Lisp macros, I suggest the following -exercise: write a recursive macro that handles postfixed mal code -(with the function as the last parameter instead of the first). Or -not. I have not actually done so myself, but I have heard it is an -interesting exercise. - -In the next step you will add try/catch style exception handling to -your implementation in addition to some new core functions. After -step9 you will be very close to having a fully self-hosting mal -implementation. Let us continue! - - -#### Deferrable - -* Add the following new core functions which are frequently used in - macro functions: - * `nth`: this function takes a list (or vector) and a number (index) - as arguments, returns the element of the list at the given index. - If the index is out of range, this function raises an exception. - * `first`: this function takes a list (or vector) as its argument - and return the first element. If the list (or vector) is empty or - is `nil` then `nil` is returned. - * `rest`: this function takes a list (or vector) as its argument and - returns a new list containing all the elements except the first. If - the list (or vector) is empty or is `nil` then `()` (empty list) - is returned. - -* In the main program, call the `rep` function with the following - string argument to define a new control structure. -``` -"(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)))))))" -``` - * Note that `cond` calls the `throw` function when `cond` is - called with an odd number of args. The `throw` function is - implemented in the next step, but it will still serve it's - purpose here by causing an undefined symbol error. - - - - -### Step 9: Try - -![step9_try architecture](step9_try.png) - -In this step you will implement the final mal special form for -error/exception handling: `try*/catch*`. You will also add several core -functions to your implementation. In particular, you will enhance the -functional programming pedigree of your implementation by adding the -`apply` and `map` core functions. - -Compare the pseudocode for step 8 and step 9 to get a basic idea of -the changes that will be made during this step: -``` -diff -urp ../process/step8_macros.txt ../process/step9_try.txt -``` - -* Copy `step8_macros.qx` to `step9_try.qx`. - -* Add the `try*/catch*` special form to the EVAL function. The - try catch form looks like this: `(try* A (catch* B C))`. The form - `A` is evaluated, if it throws an exception, then form `C` is - evaluated with a new environment that binds the symbol `B` to the - value of the exception that was thrown. - * If your target language has built-in try/catch style exception - handling then you are already 90% of the way done. Add a - (native language) try/catch block that evaluates `A` within - the try block and catches all exceptions. If an exception is - caught, then translate it to a mal type/value. For native - exceptions this is either the message string or a mal hash-map - that contains the message string and other attributes of the - exception. When a regular mal type/value is used as an - exception, you will probably need to store it within a native - exception type in order to be able to convey/transport it using - the native try/catch mechanism. Then you will extract the mal - type/value from the native exception. Create a new mal environment - that binds `B` to the value of the exception. Finally, evaluate `C` - using that new environment. - * If your target language does not have built-in try/catch style - exception handling then you have some extra work to do. One of the - most straightforward approaches is to create a a global error - variable that stores the thrown mal type/value. The complication - is that there are a bunch of places where you must check to see if - the global error state is set and return without proceeding. The - rule of thumb is that this check should happen at the top of your - EVAL function and also right after any call to EVAL (and after any - function call that might happen to call EVAL further down the - chain). Yes, it is ugly, but you were warned in the section on - picking a language. - -* Add the `throw` core function. - * If your language supports try/catch style exception handling, then - this function takes a mal type/value and throws/raises it as an - exception. In order to do this, you may need to create a custom - exception object that wraps a mal value/type. - * If your language does not support try/catch style exception - handling, then set the global error state to the mal type/value. - -* Add the `apply` and `map` core functions. In step 5, if you did not - add the original function (`fn`) to the structure returned from - `fn*`, then you will need to do so now. - * `apply`: takes at least two arguments. The first argument is - a function and the last argument is a list (or vector). The - arguments between the function and the last argument (if there are - any) are concatenated with the final argument to create the - arguments that are used to call the function. The apply - function allows a function to be called with arguments that are - contained in a list (or vector). In other words, `(apply F A B [C - D])` is equivalent to `(F A B C D)`. - * `map`: takes a function and a list (or vector) and evaluates the - function against every element of the list (or vector) one at - a time and returns the results as a list. - -* Add some type predicates core functions. In Lisp, predicates are - functions that return true/false (or true value/nil) and typically - end in "?" or "p". - * `nil?`: takes a single argument and returns true (mal true value) - if the argument is nil (mal nil value). - * `true?`: takes a single argument and returns true (mal true value) - if the argument is a true value (mal true value). - * `false?`: takes a single argument and returns true (mal true - value) if the argument is a false value (mal false value). - * `symbol?`: takes a single argument and returns true (mal true - value) if the argument is a symbol (mal symbol value). - -Now go to the top level, run the step 9 tests: -``` -make "test^quux^step9" -``` - -Your mal implementation is now essentially a fully featured Lisp -interpreter. But if you stop now you will miss one of the most -satisfying and enlightening aspects of creating a mal implementation: -self-hosting. - -#### Deferrable - -* Add the following new core functions: - * `symbol`: takes a string and returns a new symbol with the string - as its name. - * `keyword`: takes a string and returns a keyword with the same name - (usually just be prepending the special keyword - unicode symbol). This function should also detect if the argument - is already a keyword and just return it. - * `keyword?`: takes a single argument and returns true (mal true - value) if the argument is a keyword, otherwise returns false (mal - false value). - * `vector`: takes a variable number of arguments and returns - a vector containing those arguments. - * `vector?`: takes a single argument and returns true (mal true - value) if the argument is a vector, otherwise returns false (mal - false value). - * `sequential?`: takes a single argument and returns true (mal true - value) if it is a list or a vector, otherwise returns false (mal - false value). - * `hash-map`: takes a variable but even number of arguments and - returns a new mal hash-map value with keys from the odd arguments - and values from the even arguments respectively. This is basically - the functional form of the `{}` reader literal syntax. - * `map?`: takes a single argument and returns true (mal true - value) if the argument is a hash-map, otherwise returns false (mal - false value). - * `assoc`: takes a hash-map as the first argument and the remaining - arguments are odd/even key/value pairs to "associate" (merge) into - the hash-map. Note that the original hash-map is unchanged - (remember, mal values are immutable), and a new hash-map - containing the old hash-maps key/values plus the merged key/value - arguments is returned. - * `dissoc`: takes a hash-map and a list of keys to remove from the - hash-map. Again, note that the original hash-map is unchanged and - a new hash-map with the keys removed is returned. Key arguments - that do not exist in the hash-map are ignored. - * `get`: takes a hash-map and a key and returns the value of looking - up that key in the hash-map. If the key is not found in the - hash-map then nil is returned. - * `contains?`: takes a hash-map and a key and returns true (mal true - value) if the key exists in the hash-map and false (mal false - value) otherwise. - * `keys`: takes a hash-map and returns a list (mal list value) of - all the keys in the hash-map. - * `vals`: takes a hash-map and returns a list (mal list value) of - all the values in the hash-map. - - - - -### Step A: Metadata, Self-hosting and Interop - -![stepA_mal architecture](stepA_mal.png) - -You have reached the final step of your mal implementation. This step -is kind of a catchall for things that did not fit into other steps. -But most importantly, the changes you make in this step will unlock -the magical power known as "self-hosting". You might have noticed -that one of the languages that mal is implemented in is "mal". Any mal -implementation that is complete enough can run the mal implementation -of mal. You might need to pull out your hammock and ponder this for -a while if you have never built a compiler or interpreter before. Look -at the step source files for the mal implementation of mal (it is not -cheating now that you have reached step A). - -If you deferred the implementation of keywords, vectors and hash-maps, -now is the time to go back and implement them if you want your -implementation to self-host. - -Compare the pseudocode for step 9 and step A to get a basic idea of -the changes that will be made during this step: -``` -diff -urp ../process/step9_try.txt ../process/stepA_mal.txt -``` - -* Copy `step9_try.qx` to `stepA_mal.qx`. - -* Add the `readline` core function. This functions takes a - string that is used to prompt the user for input. The line of text - entered by the user is returned as a string. If the user sends an - end-of-file (usually Ctrl-D), then nil is returned. - -* Add a new "\*host-language\*" (symbol) entry to your REPL - environment. The value of this entry should be a mal string - containing the name of the current implementation. - -* When the REPL starts up (as opposed to when it is called with - a script and/or arguments), call the `rep` function with this string - to print a startup header: - "(println (str \"Mal [\" \*host-language\* \"]\"))". - -* Ensure that the REPL environment contains definitions for `time-ms`, - `meta`, `with-meta`, `fn?` - `string?`, `number?`, `seq`, and `conj`. It doesn't really matter - what they do at this stage: they just need to be defined. Making - them functions that raise a "not implemented" exception would be - fine. - -Now go to the top level, run the step A tests: -``` -make "test^quux^stepA" -``` - -Once you have passed all the non-optional step A tests, it is time to -try self-hosting. Run your step A implementation as normal, but use -the file argument mode you added in step 6 to run a each of the step -from the mal implementation: -``` -./stepA_mal.qx ../mal/step1_read_print.mal -./stepA_mal.qx ../mal/step2_eval.mal -... -./stepA_mal.qx ../mal/step9_try.mal -./stepA_mal.qx ../mal/stepA_mal.mal -``` - -There is a very good chance that you will encounter an error at some -point while trying to run the mal in mal implementation steps above. -Debugging failures that happen while self-hosting is MUCH more -difficult and mind bending. One of the best approaches I have -personally found is to add prn statements to the mal implementation -step (not your own implementation of mal) that is causing problems. - -Another approach I have frequently used is to pull out the code from -the mal implementation that is causing the problem and simplify it -step by step until you have a simple piece of mal code that still -reproduces the problem. Once the reproducer is simple enough you will -probably know where in your own implementation that problem is likely -to be. Please add your simple reproducer as a test case so that future -implementers will fix similar issues in their code before they get to -self-hosting when it is much more difficult to track down and fix. - -Once you can manually run all the self-hosted steps, it is time to run -all the tests in self-hosted mode: -``` -make MAL_IMPL=quux "test^mal" -``` - -When you run into problems (which you almost certainly will), use the -same process described above to debug them. - -Congratulations!!! When all the tests pass, you should pause for -a moment and consider what you have accomplished. You have implemented -a Lisp interpreter that is powerful and complete enough to run a large -mal program which is itself an implementation of the mal language. You -might even be asking if you can continue the "inception" by using your -implementation to run a mal implementation which itself runs the mal -implementation. - - -#### Optional additions - -* Add meta-data support to composite data types (lists, vectors - and hash-maps), and to functions (native or not), by adding a new - metadata attribute that refers to another mal value/type - (nil by default). Add the following metadata related core functions - (and remove any stub versions): - * `meta`: this takes a single mal function/list/vector/hash-map argument - and returns the value of the metadata attribute. - * `with-meta`: this function takes two arguments. The first argument - is a mal function/list/vector/hash-map and the second argument is - another mal value/type to set as metadata. A copy of the mal function is - returned that has its `meta` attribute set to the second argument. - Note that it is important that the environment and macro attribute - of mal function are retained when it is copied. - * Add a reader-macro that expands the token "^" to - return a new list that contains the symbol "with-meta" and the - result of reading the next next form (2nd argument) (`read_form`) and the - next form (1st argument) in that order - (metadata comes first with the ^ macro and the function second). - * If you implemented as `defmacro!` to mutate an existing function - without copying it, you can now use the function copying mechanism - used for metadata to make functions immutable even in the - defmacro! case... - -* Add the following new core functions (and remove any stub versions): - * `time-ms`: takes no arguments and returns the number of - milliseconds since epoch (00:00:00 UTC January 1, 1970), or, if - not possible, since another point in time (`time-ms` is usually - used relatively to measure time durations). After `time-ms` is - implemented, you can run the performance micro-benchmarks by - running `make perf^quux`. - * `conj`: takes a collection and one or more elements as arguments - and returns a new collection which includes the original - collection and the new elements. If the collection is a list, a - new list is returned with the elements inserted at the start of - the given list in opposite order; if the collection is a vector, a - new vector is returned with the elements added to the end of the - given vector. - * `string?`: returns true if the parameter is a string. - * `number?`: returns true if the parameter is a number. - * `fn?`: returns true if the parameter is a function (internal or - user-defined). - * `macro?`: returns true if the parameter is a macro. - * `seq`: takes a list, vector, string, or nil. If an empty list, - empty vector, or empty string ("") is passed in then nil is - returned. Otherwise, a list is returned unchanged, a vector is - converted into a list, and a string is converted to a list that - containing the original string split into single character - strings. -* For interop with the target language, add this core function: - * `quux-eval`: takes a string, evaluates it in the target language, - and returns the result converted to the relevant Mal type. You may - also add other interop functions as you see fit; Clojure, for - example, has a function called `.` which allows calling Java - methods. If the target language is a static language, consider - using FFI or some language-specific reflection mechanism, if - available. The tests for `quux-eval` and any other interop - function should be added in `impls/quux/tests/stepA_mal.mal` (see - the [tests for `lua-eval`](../impls/lua/tests/stepA_mal.mal) as an - example). - -### Next Steps - -* Join the #mal IRC channel. It's fairly quiet but there are bursts of - interesting conversation related to mal, Lisps, esoteric programming - languages, etc. -* If you have created an implementation for a new target language (or - a unique and interesting variant of an existing implementation), - consider sending a pull request to add it into the main mal - repository. The [FAQ](../docs/FAQ.md#will-you-add-my-new-implementation) - describes general requirements for getting an implementation merged - into the main repository. -* Take your interpreter implementation and have it emit source code in - the target language rather than immediately evaluating it. In other - words, create a compiler. -* Pick a new target language and implement mal in it. Pick a language - that is very different from any that you already know. -* Use your mal implementation to implement a real world project. Many - of these will force you to address interop. Some ideas: - * Web server (with mal as CGI language for extra points) - * An IRC/Slack chat bot - * An editor (GUI or curses) with mal as a scripting/extension - language. - * An AI player for a game like Chess or Go. -* Implement a feature in your mal implementation that is not covered - by this guide. Some ideas: - * Namespaces - * Multi-threading support - * Errors with line numbers and/or stack traces. - * Lazy sequences - * Clojure-style protocols - * Full call/cc (call-with-current-continuation) support - * Explicit TCO (i.e. `recur`) with tail-position error checking +# The Make-A-Lisp Process + +So you want to write a Lisp interpreter? Welcome! + +The goal of the Make-A-Lisp project is to make it easy to write your +own Lisp interpreter without sacrificing those many "Aha!" moments +that come from ascending the McCarthy mountain. When you reach the peak +of this particular mountain, you will have an interpreter for the mal +Lisp language that is powerful enough to be self-hosting, meaning it +will be able to run a mal interpreter written in mal itself. + +So jump right in (er ... start the climb)! + +- [Pick a language](#pick-a-language) +- [Getting started](#getting-started) +- [General hints](#general-hints) +- [The Make-A-Lisp Process](#the-make-a-lisp-process-1) + - [Step 0: The REPL](#step-0-the-repl) + - [Step 1: Read and Print](#step-1-read-and-print) + - [Step 2: Eval](#step-2-eval) + - [Step 3: Environments](#step-3-environments) + - [Step 4: If Fn Do](#step-4-if-fn-do) + - [Step 5: Tail call optimization](#step-5-tail-call-optimization) + - [Step 6: Files, Mutation, and Evil](#step-6-files-mutation-and-evil) + - [Step 7: Quoting](#step-7-quoting) + - [Step 8: Macros](#step-8-macros) + - [Step 9: Try](#step-9-try) + - [Step A: Metadata, Self-hosting and Interop](#step-a-metadata-self-hosting-and-interop) + + +## Pick a language + +You might already have a language in mind that you want to use. +Technically speaking, mal can be implemented in any sufficiently +complete programming language (i.e. Turing complete), however, there +are a few language features that can make the task MUCH easier. Here +are some of them in rough order of importance: + +* A sequential compound data structure (e.g. arrays, lists, + vectors, etc) +* An associative compound data structure (e.g. a dictionary, + hash-map, associative array, etc) +* Function references (first class functions, function pointers, + etc) +* Real exception handling (try/catch, raise, throw, etc) +* Variable argument functions (variadic, var args, splats, apply, etc) +* Function closures +* PCRE regular expressions + +In addition, the following will make your task especially easy: + +* Dynamic typing / boxed types (specifically, the ability to store + different data types in the sequential and associative structures + and the language keeps track of the type for you) +* Compound data types support arbitrary runtime "hidden" data + (metadata, metatables, dynamic fields attributes) + +Here are some examples of languages that have all of the above +features: JavaScript, Ruby, Python, Lua, R, Clojure. + +Michael Fogus has some great blog posts on interesting but less well +known languages and many of the languages on his lists do not yet have +any mal implementations: +* http://blog.fogus.me/2011/08/14/perlis-languages/ +* http://blog.fogus.me/2011/10/18/programming-language-development-the-past-5-years/ + +Many of the most popular languages already have Mal implementations. +However, this should not discourage you from creating your own +implementation in a language that already has one. However, if you go +this route, I suggest you avoid referring to the existing +implementations (i.e. "cheating") to maximize your learning experience +instead of just borrowing mine. On the other hand, if your goal is to +add new implementations to mal as efficiently as possible, then you +SHOULD find the most similar target language implementation and refer +to it frequently. + +If you want a list of programming languages with an +approximate measure of popularity try the [RedMonk Programming +Language +Rankings](https://redmonk.com/sogrady/2019/03/20/language-rankings-1-19/) +or the [GitHut 2.0 Project](https://madnight.github.io/githut). + + +## Getting started + +* Install your chosen language interpreter/compiler, language package + manager and build tools (if applicable) + +* Fork the mal repository on github and then clone your forked + repository: +``` +git clone git@github.com:YOUR_NAME/mal.git +cd mal +``` + +* Make a new directory for your implementation. For example, if your +language is called "quux": +``` +mkdir impls/quux +``` + +* Modify the top level Makefile.impls to allow the tests to be run against + your implementation. For example, if your language is named "quux" + and uses "qx" as the file extension, then make the following + 3 modifications to Makefile.impls: +``` +IMPLS = ... quux ... +... +quux_STEP_TO_PROG = impls/quux/$($(1)).qx +``` + +* Add a "run" script to your implementation directory that listens to + the "STEP" environment variable for the implementation step to run + and defaults to "stepA_mal". Make sure the run script has the + executable file permission set (or else the test runner might fail with a + permission denied error message). The following are examples of "run" + scripts for a compiled language and an interpreted language (where + the interpreter is named "quux"): + +``` +#!/bin/bash +exec $(dirname $0)/${STEP:-stepA_mal} "${@}" +``` + +``` +#!/bin/bash +exec quux $(dirname $0)/${STEP:-stepA_mal}.qx "${@}" +``` + +This allows you to run tests against your implementation like this: +``` +make "test^quux^stepX" +``` + +If your implementation language is a compiled language, then you +should also add a Makefile at the top level of your implementation +directory. This Makefile will define how to build the files pointed to +by the quux_STEP_TO_PROG macro. The top-level Makefile will attempt to +build those targets before running tests. If it is a scripting +language/uncompiled, then no Makefile is necessary because +quux_STEP_TO_PROG will point to a source file that already exists and +does not need to be compiled/built. + + +## General hints + +Stackoverflow and Google are your best friends. Modern polyglot +developers do not memorize dozens of programming languages. Instead, +they learn the peculiar terminology used with each language and then +use this to search for their answers. + +Here are some other resources where multiple languages are +compared/described: +* http://learnxinyminutes.com/ +* http://hyperpolyglot.org/ +* http://rosettacode.org/ +* http://rigaux.org/language-study/syntax-across-languages/ + +Do not let yourself be bogged down by specific problems. While the +make-a-lisp process is structured as a series of steps, the reality is +that building a lisp interpreter is more like a branching tree. If you +get stuck on tail call optimization, or hash-maps, move on to other +things. You will often have a stroke of inspiration for a problem as +you work through other functionality. I have tried to structure this +guide and the tests to make clear which things can be deferred until +later. + +An aside on deferrable/optional bits: when you run the tests for +a given step, the last tests are often marked with an "optional" +header. This indicates that these are tests for functionality that is +not critical to finish a basic mal implementation. Many of the steps +in this process guide have a "Deferrable" section, however, it is not +quite the same meaning. Those sections include the functionality that +is marked as optional in the tests, but they also include +functionality that becomes mandatory at a later step. In other words, +this is a "make your own Lisp adventure". + +Use test driven development. Each step of the make-a-lisp process has +a bunch of tests associated with it and there is an easy script to run +all the tests for a specific step in the process. Pick a failing test, +fix it, repeat until all the tests for that step pass. + +## Reference Code + +The `process` directory contains abbreviated pseudocode and +architecture diagrams for each step of the make-a-lisp process. Use +a textual diff/comparison tool to compare the previous pseudocode step +with the one you are working on. The architecture diagram images have +changes from the previous step highlighted in red. There is also +a concise +[cheatsheet](http://kanaka.github.io/mal/cheatsheet.html) that +summarizes the key changes at each step. + +If you get completely stuck and are feeling like giving up, then you +should "cheat" by referring to the same step or functionality in +an existing implementation language. You are here to learn, not to take +a test, so do not feel bad about it. Okay, you should feel a little +bit bad about it. + + +## The Make-A-Lisp Process + +Feel free to follow the guide as literally or as loosely as you +like. You are here to learn; wandering off the beaten path may be the +way you learn best. However, each step builds on the previous steps, +so if you are new to Lisp or new to your implementation language then +you may want to stick more closely to the guide your first time +through to avoid frustration at later steps. + +In the steps that follow the name of the target language is "quux" and +the file extension for that language is "qx". + + + + +### Step 0: The REPL + +![step0_repl architecture](step0_repl.png) + +This step is basically just creating a skeleton of your interpreter. + +* Create a `step0_repl.qx` file in `impls/quux/`. + +* Add the 4 trivial functions `READ`, `EVAL`, `PRINT`, and `rep` + (read-eval-print). `READ`, `EVAL`, and `PRINT` are basically just + stubs that return their first parameter (a string if your target + language is a statically typed) and `rep` calls them in order + passing the return to the input of the next. + +* Add a main loop that repeatedly prints a prompt (needs to be + "user> " for later tests to pass), gets a line of input from the + user, calls `rep` with that line of input, and then prints out the + result from `rep`. It should also exit when you send it an EOF + (often Ctrl-D). + +* If you are using a compiled (ahead-of-time rather than just-in-time) + language, then create a Makefile (or appropriate project definition + file) in your directory. + +It is time to run your first tests. This will check that your program +does input and output in a way that can be captured by the test +harness. Go to the top level and run the following: +``` +make "test^quux^step0" +``` + +Add and then commit your new `step0_repl.qx` and `Makefile` to git. + +Congratulations! You have just completed the first step of the +make-a-lisp process. + + +#### Optional: + +* Add full line editing and command history support to your + interpreter REPL. Many languages have a library/module that provide + line editing support. Another option if your language supports it is + to use an FFI (foreign function interface) to load and call directly + into GNU readline, editline, or linenoise library. Add line + editing interface code to `readline.qx` + + + + +### Step 1: Read and Print + +![step1_read_print architecture](step1_read_print.png) + +In this step, your interpreter will "read" the string from the user +and parse it into an internal tree data structure (an abstract syntax +tree) and then take that data structure and "print" it back to +a string. + +In non-lisp languages, this step (called "lexing and parsing") can be +one of the most complicated parts of the compiler/interpreter. In +Lisp, the data structure that you want in memory is basically +represented directly in the code that the programmer writes +(homoiconicity). + +For example, if the string is "(+ 2 (* 3 4))" then the read function +will process this into a tree structure that looks like this: +``` + List + / | \ + / | \ + / | \ + Sym:+ Int:2 List + / | \ + / | \ + / | \ + Sym:* Int:3 Int:4 +``` + +Each left paren and its matching right paren (lisp "sexpr") becomes +a node in the tree and everything else becomes a leaf in the tree. + +If you can find code for an implementation of a JSON encoder/decoder +in your target language then you can probably just borrow and modify +that and be 75% of the way done with this step. + +The rest of this section is going to assume that you are not starting +from an existing JSON encoder/decoder, but that you do have access to +a Perl compatible regular expressions (PCRE) module/library. You can +certainly implement the reader using simple string operations, but it +is more involved. The `make`, `ps` (postscript) and Haskell +implementations have examples of a reader/parser without using regular +expression support. + +* Copy `step0_repl.qx` to `step1_read_print.qx`. + +* Add a `reader.qx` file to hold functions related to the reader. + +* If the target language has objects types (OOP), then the next step + is to create a simple stateful Reader object in `reader.qx`. This + object will store the tokens and a position. The Reader object will + have two methods: `next` and `peek`. `next` returns the token at + the current position and increments the position. `peek` just + returns the token at the current position. + +* Add a function `read_str` in `reader.qx`. This function + will call `tokenize` and then create a new Reader object instance + with the tokens. Then it will call `read_form` with the Reader + instance. + +* Add a function `tokenize` in `reader.qx`. This function will take + a single string and return an array/list + of all the tokens (strings) in it. The following regular expression + (PCRE) will match all mal tokens. +``` +[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"?|;.*|[^\s\[\]{}('"`,;)]*) +``` +* For each match captured within the parenthesis starting at char 6 of the + regular expression a new token will be created. + + * `[\s,]*`: Matches any number of whitespaces or commas. This is not captured + so it will be ignored and not tokenized. + + * `~@`: Captures the special two-characters `~@` (tokenized). + + * ```[\[\]{}()'`~^@]```: Captures any special single character, one of + ```[]{}()'`~^@``` (tokenized). + + * `"(?:\\.|[^\\"])*"?`: Starts capturing at a double-quote and stops at the + next double-quote unless it was preceded by a backslash in which case it + includes it until the next double-quote (tokenized). It will also + match unbalanced strings (no ending double-quote) which should be + reported as an error. + + * `;.*`: Captures any sequence of characters starting with `;` (tokenized). + + * ```[^\s\[\]{}('"`,;)]*```: Captures a sequence of zero or more non special + characters (e.g. symbols, numbers, "true", "false", and "nil") and is sort + of the inverse of the one above that captures special characters (tokenized). + +* Add the function `read_form` to `reader.qx`. This function + will peek at the first token in the Reader object and switch on the + first character of that token. If the character is a left paren then + `read_list` is called with the Reader object. Otherwise, `read_atom` + is called with the Reader Object. The return value from `read_form` + is a mal data type. If your target language is statically typed then + you will need some way for `read_form` to return a variant or + subclass type. For example, if your language is object oriented, + then you can define a top level MalType (in `types.qx`) that all + your mal data types inherit from. The MalList type (which also + inherits from MalType) will contain a list/array of other MalTypes. + If your language is dynamically typed then you can likely just + return a plain list/array of other mal types. + +* Add the function `read_list` to `reader.qx`. This function will + repeatedly call `read_form` with the Reader object until it + encounters a ')' token (if it reach EOF before reading a ')' then + that is an error). It accumulates the results into a List type. If + your language does not have a sequential data type that can hold mal + type values you may need to implement one (in `types.qx`). Note + that `read_list` repeatedly calls `read_form` rather than + `read_atom`. This mutually recursive definition between `read_list` + and `read_form` is what allows lists to contain lists. + +* Add the function `read_atom` to `reader.qx`. This function will + look at the contents of the token and return the appropriate scalar + (simple/single) data type value. Initially, you can just implement + numbers (integers) and symbols. This will allow you to proceed + through the next couple of steps before you will need to implement + the other fundamental mal types: nil, true, false, and string. The + remaining scalar mal type, keyword does not + need to be implemented until step A (but can be implemented at any + point between this step and that). BTW, symbols types are just an + object that contains a single string name value (some languages have + symbol types already). + +* Add a file `printer.qx`. This file will contain a single function + `pr_str` which does the opposite of `read_str`: take a mal data + structure and return a string representation of it. But `pr_str` is + much simpler and is basically just a switch statement on the type of + the input object: + + * symbol: return the string name of the symbol + * number: return the number as a string + * list: iterate through each element of the list calling `pr_str` on + it, then join the results with a space separator, and surround the + final result with parens + +* Change the `READ` function in `step1_read_print.qx` to call + `reader.read_str` and the `PRINT` function to call `printer.pr_str`. + `EVAL` continues to simply return its input but the type is now + a mal data type. + +You now have enough hooked up to begin testing your code. You can +manually try some simple inputs: + * `123` -> `123` + * ` 123 ` -> `123` + * `abc` -> `abc` + * ` abc ` -> `abc` + * `(123 456)` -> `(123 456)` + * `( 123 456 789 ) ` -> `(123 456 789)` + * `( + 2 (* 3 4) ) ` -> `(+ 2 (* 3 4))` + +To verify that your code is doing more than just eliminating extra +spaces (and not failing), you can instrument your `reader.qx` functions. + +Once you have gotten past those simple manual tests, it is time to run +the full suite of step 1 tests. Go to the top level and run the +following: +``` +make "test^quux^step1" +``` + +Fix any test failures related to symbols, numbers and lists. + +Depending on the functionality of your target language, it is likely +that you have now just completed one of the most difficult steps. It +is down hill from here. The remaining steps will probably be easier +and each step will give progressively more bang for the buck. + +#### Deferrable: + + +* Add support for the other basic data type to your reader and printer + functions: string, nil, true, and false. Nil, true, and false + become mandatory at step 4, strings at step 6. When a string is read, + the following transformations are + applied: a backslash followed by a doublequote is translated into + a plain doublequote character, a backslash followed by "n" is + translated into a newline, and a backslash followed by another + backslash is translated into a single backslash. To properly print + a string (for step 4 string functions), the `pr_str` function needs + another parameter called `print_readably`. When `print_readably` is + true, doublequotes, newlines, and backslashes are translated into + their printed representations (the reverse of the reader). The + `PRINT` function in the main program should call `pr_str` with + print_readably set to true. + +* Add error checking to your reader functions to make sure parens + are properly matched. Catch and print these errors in your main + loop. If your language does not have try/catch style bubble up + exception handling, then you will need to add explicit error + handling to your code to catch and pass on errors without crashing. + +* Add support for reader macros which are forms that are + transformed into other forms during the read phase. Refer to + `tests/step1_read_print.mal` for the form that these macros should + take (they are just simple transformations of the token stream). + +* Add support for the other mal types: keyword, vector, hash-map. + * keyword: a keyword is a token that begins with a colon. A keyword + can just be stored as a string with special unicode prefix like + 0x29E (or char 0xff/127 if the target language does not have good + unicode support) and the printer translates strings with that + prefix back to the keyword representation. This makes it easy to + use keywords as hash map keys in most languages. You can also + store keywords as a unique data type, but you will need to make + sure they can be used as hash map keys (which may involve doing + a similar prefixed translation anyways). + * vector: a vector can be implemented with same underlying + type as a list as long as there is some mechanism to keep track of + the difference. + Vector literals are similar to lists, but use bracket as + delimiters instead of parenthesis. + For example, `[]` constructs an empty vector and `[1 "a"]` a + vector with two elements. + You can use the same reader function for both + lists and vectors by adding parameters for the starting and ending + tokens. + * hash-map: a hash-map is an associative data structure that maps + strings to other mal values. If you implement keywords as prefixed + strings, then you only need a native associative data structure + which supports string keys. Clojure allows any value to be a hash + map key, but the base functionality in mal is to support strings + and keyword keys. + Hash-map literals are constructed with braces delimiters. + For example, + `{}` constructs an empty map, + `{"a" 1 :b "whatever"}` associates the `a` key to an integer value + and the `:b` key to a string value. + Because of the representation of hash-maps as + an alternating sequence of keys and values, you can probably use + the same reader function for hash-maps as lists and vectors with + parameters to indicate the starting and ending tokens. The odd + tokens are then used for keys with the corresponding even tokens + as the values. + +* Add comment support to your reader. The tokenizer should ignore + tokens that start with ";". Your `read_str` function will need to + properly handle when the tokenizer returns no values. The simplest + way to do this is to return `nil` mal value. A cleaner option (that + does not print `nil` at the prompt is to throw a special exception + that causes the main loop to simply continue at the beginning of the + loop without calling `rep`. + + + + +### Step 2: Eval + +![step2_eval architecture](step2_eval.png) + +In step 1 your mal interpreter was basically just a way to validate +input and eliminate extraneous white space. In this step you will turn +your interpreter into a simple number calculator by adding +functionality to the evaluator (`EVAL`). + +Compare the pseudocode for step 1 and step 2 to get a basic idea of +the changes that will be made during this step: +``` +diff -urp ../process/step1_read_print.txt ../process/step2_eval.txt +``` + +* Copy `step1_read_print.qx` to `step2_eval.qx`. + +* Define a simple initial REPL environment. This environment is an + associative structure that maps symbols (or symbol names) to + numeric functions. For example, in python this would look something + like this: +``` +repl_env = {'+': lambda a,b: a+b, + '-': lambda a,b: a-b, + '*': lambda a,b: a*b, + '/': lambda a,b: int(a/b)} +``` + +* Modify the `rep` function to pass the REPL environment as the second + parameter for the `EVAL` call. + +* Create a new function `eval_ast` which takes `ast` (mal data type) + and an associative structure (the environment from above). + `eval_ast` switches on the type of `ast` as follows: + + * symbol: lookup the symbol in the environment structure and return + the value or raise an error if no value is found + * list: return a new list that is the result of calling `EVAL` on + each of the members of the list + * otherwise just return the original `ast` value + +* Modify `EVAL` to check if the first parameter `ast` is a list. + * `ast` is not a list: then return the result of calling `eval_ast` + on it. + * `ast` is a empty list: return ast unchanged. + * `ast` is a list: call `eval_ast` to get a new evaluated list. Take + the first item of the evaluated list and call it as function using + the rest of the evaluated list as its arguments. + +If your target language does not have full variable length argument +support (e.g. variadic, vararg, splats, apply) then you will need to +pass the full list of arguments as a single parameter and split apart +the individual values inside of every mal function. This is annoying, +but workable. + +The process of taking a list and invoking or executing it to return +something new is known in Lisp as the "apply" phase. + +Try some simple expressions: + + * `(+ 2 3)` -> `5` + * `(+ 2 (* 3 4))` -> `14` + +The most likely challenge you will encounter is how to properly call +a function references using an arguments list. + +Now go to the top level, run the step 2 tests and fix the errors. +``` +make "test^quux^step2" +``` + +You now have a simple prefix notation calculator! + +#### Deferrable: + +* `eval_ast` should evaluate elements of vectors and hash-maps. Add the + following cases in `eval_ast`: + * If `ast` is a vector: return a new vector that is the result of calling + `EVAL` on each of the members of the vector. + * If `ast` is a hash-map: return a new hash-map which consists of key-value + pairs where the key is a key from the hash-map and the value is the result + of calling `EVAL` on the corresponding value. + Depending on the implementation of maps, it may be convenient to + also call `EVAL` on keys. The result is the same because keys are + not affected by evaluation. + + + + +### Step 3: Environments + +![step3_env architecture](step3_env.png) + +In step 2 you were already introduced to REPL environment (`repl_env`) +where the basic numeric functions were stored and looked up. In this +step you will add the ability to create new environments (`let*`) and +modify existing environments (`def!`). + +A Lisp environment is an associative data structure that maps symbols (the +keys) to values. But Lisp environments have an additional important +function: they can refer to another environment (the outer +environment). During environment lookups, if the current environment +does not have the symbol, the lookup continues in the outer +environment, and continues this way until the symbol is either found, +or the outer environment is `nil` (the outermost environment in the +chain). + +Compare the pseudocode for step 2 and step 3 to get a basic idea of +the changes that will be made during this step: +``` +diff -urp ../process/step2_eval.txt ../process/step3_env.txt +``` + +* Copy `step2_eval.qx` to `step3_env.qx`. + +* Create `env.qx` to hold the environment definition. + +* Define an `Env` object that is instantiated with a single `outer` + parameter and starts with an empty associative data structure + property `data`. + +* Define three methods for the Env object: + * set: takes a symbol key and a mal value and adds to the `data` + structure + * find: takes a symbol key and if the current environment contains + that key then return the environment. If no key is found and outer + is not `nil` then call find (recurse) on the outer environment. + * get: takes a symbol key and uses the `find` method to locate the + environment with the key, then returns the matching value. If no + key is found up the outer chain, then throws/raises a "not found" + error. + +* Update `step3_env.qx` to use the new `Env` type to create the + repl_env (with a `nil` outer value) and use the `set` method to add + the numeric functions. + +* Modify `eval_ast` to call the `get` method on the `env` parameter. + +* Modify the apply section of `EVAL` to switch on the first element of + the list: + * symbol "def!": call the set method of the current environment + (second parameter of `EVAL` called `env`) using the unevaluated + first parameter (second list element) as the symbol key and the + evaluated second parameter as the value. + * symbol "let\*": create a new environment using the current + environment as the outer value and then use the first parameter as + a list of new bindings in the "let\*" environment. Take the second + element of the binding list, call `EVAL` using the new "let\*" + environment as the evaluation environment, then call `set` on the + "let\*" environment using the first binding list element as the key + and the evaluated second element as the value. This is repeated + for each odd/even pair in the binding list. Note in particular, + the bindings earlier in the list can be referred to by later + bindings. Finally, the second parameter (third element) of the + original `let*` form is evaluated using the new "let\*" environment + and the result is returned as the result of the `let*` (the new + let environment is discarded upon completion). + * otherwise: call `eval_ast` on the list and apply the first element + to the rest as before. + +`def!` and `let*` are Lisp "specials" (or "special atoms") which means +that they are language level features and more specifically that the +rest of the list elements (arguments) may be evaluated differently (or +not at all) unlike the default apply case where all elements of the +list are evaluated before the first element is invoked. Lists which +contain a "special" as the first element are known as "special forms". +They are special because they follow special evaluation rules. + +Try some simple environment tests: + + * `(def! a 6)` -> `6` + * `a` -> `6` + * `(def! b (+ a 2))` -> `8` + * `(+ a b)` -> `14` + * `(let* (c 2) c)` -> `2` + +Now go to the top level, run the step 3 tests and fix the errors. +``` +make "test^quux^step3" +``` + +Your mal implementation is still basically just a numeric calculator +with save/restore capability. But you have set the foundation for step +4 where it will begin to feel like a real programming language. + + +An aside on mutation and typing: + +The "!" suffix on symbols is used to indicate that this symbol refers +to a function that mutates something else. In this case, the `def!` +symbol indicates a special form that will mutate the current +environment. Many (maybe even most) of runtime problems that are +encountered in software engineering are a result of mutation. By +clearly marking code where mutation may occur, you can more easily +track down the likely cause of runtime problems when they do occur. + +Another cause of runtime errors is type errors, where a value of one +type is unexpectedly treated by the program as a different and +incompatible type. Statically typed languages try to make the +programmer solve all type problems before the program is allowed to +run. Most Lisp variants tend to be dynamically typed (types of values +are checked when they are actually used at runtime). + +As an aside-aside: The great debate between static and dynamic typing +can be understood by following the money. Advocates of strict static +typing use words like "correctness" and "safety" and thus get +government and academic funding. Advocates of dynamic typing use words +like "agile" and "time-to-market" and thus get venture capital and +commercial funding. + + + + +### Step 4: If Fn Do + +![step4_if_fn_do architecture](step4_if_fn_do.png) + +In step 3 you added environments and the special forms for +manipulating environments. In this step you will add 3 new special +forms (`if`, `fn*` and `do`) and add several more core functions to +the default REPL environment. Our new architecture will look like +this: + +The `fn*` special form is how new user-defined functions are created. +In some Lisps, this special form is named "lambda". + +Compare the pseudocode for step 3 and step 4 to get a basic idea of +the changes that will be made during this step: +``` +diff -urp ../process/step3_env.txt ../process/step4_if_fn_do.txt +``` + +* Copy `step3_env.qx` to `step4_if_fn_do.qx`. + +* If you have not implemented reader and printer support (and data + types) for `nil`, `true` and `false`, you will need to do so for + this step. + +* Update the constructor/initializer for environments to take two new + parameters: `binds` and `exprs`. Bind (`set`) each element (symbol) + of the binds list to the respective element of the `exprs` list. + +* Add support to `printer.qx` to print function values. A string + literal like "#\" is sufficient. + +* Add the following special forms to `EVAL`: + + * `do`: Evaluate all the elements of the list using `eval_ast` + and return the final evaluated element. + * `if`: Evaluate the first parameter (second element). If the result + (condition) is anything other than `nil` or `false`, then evaluate + the second parameter (third element of the list) and return the + result. Otherwise, evaluate the third parameter (fourth element) + and return the result. If condition is false and there is no third + parameter, then just return `nil`. + * `fn*`: Return a new function closure. The body of that closure + does the following: + * Create a new environment using `env` (closed over from outer + scope) as the `outer` parameter, the first parameter (second + list element of `ast` from the outer scope) as the `binds` + parameter, and the parameters to the closure as the `exprs` + parameter. + * Call `EVAL` on the second parameter (third list element of `ast` + from outer scope), using the new environment. Use the result as + the return value of the closure. + +If your target language does not support closures, then you will need +to implement `fn*` using some sort of structure or object that stores +the values being closed over: the first and second elements of the +`ast` list (function parameter list and function body) and the current +environment `env`. In this case, your native functions will need to be +wrapped in the same way. You will probably also need a method/function +that invokes your function object/structure for the default case of +the apply section of `EVAL`. + +Try out the basic functionality you have implemented: + + * `(fn* (a) a)` -> `#` + * `( (fn* (a) a) 7)` -> `7` + * `( (fn* (a) (+ a 1)) 10)` -> `11` + * `( (fn* (a b) (+ a b)) 2 3)` -> `5` + +* Add a new file `core.qx` and define an associative data structure + `ns` (namespace) that maps symbols to functions. Move the numeric + function definitions into this structure. + +* Modify `step4_if_fn_do.qx` to iterate through the `core.ns` + structure and add (`set`) each symbol/function mapping to the + REPL environment (`repl_env`). + +* Add the following functions to `core.ns`: + * `prn`: call `pr_str` on the first parameter with `print_readably` + set to true, prints the result to the screen and then return + `nil`. Note that the full version of `prn` is a deferrable below. + * `list`: take the parameters and return them as a list. + * `list?`: return true if the first parameter is a list, false + otherwise. + * `empty?`: treat the first parameter as a list and return true if + the list is empty and false if it contains any elements. + * `count`: treat the first parameter as a list and return the number + of elements that it contains. + * `=`: compare the first two parameters and return true if they are + the same type and contain the same value. In the case of equal + length lists, each element of the list should be compared for + equality and if they are the same return true, otherwise false. + * `<`, `<=`, `>`, and `>=`: treat the first two parameters as + numbers and do the corresponding numeric comparison, returning + either true or false. + +Now go to the top level, run the step 4 tests. There are a lot of +tests in step 4 but all of the non-optional tests that do not involve +strings should be able to pass now. + +``` +make "test^quux^step4" +``` + +Your mal implementation is already beginning to look like a real +language. You have flow control, conditionals, user-defined functions +with lexical scope, side-effects (if you implement the string +functions), etc. However, our little interpreter has not quite reached +Lisp-ness yet. The next several steps will take your implementation +from a neat toy to a full featured language. + +#### Deferrable: + +* Implement Clojure-style variadic function parameters. Modify the + constructor/initializer for environments, so that if a "&" symbol is + encountered in the `binds` list, the next symbol in the `binds` list + after the "&" is bound to the rest of the `exprs` list that has not + been bound yet. + +* Define a `not` function using mal itself. In `step4_if_fn_do.qx` + call the `rep` function with this string: + "(def! not (fn* (a) (if a false true)))". + +* Implement the strings functions in `core.qx`. To implement these + functions, you will need to implement the string support in the + reader and printer (deferrable section of step 1). Each of the string + functions takes multiple mal values, prints them (`pr_str`) and + joins them together into a new string. + * `pr-str`: calls `pr_str` on each argument with `print_readably` + set to true, joins the results with " " and returns the new + string. + * `str`: calls `pr_str` on each argument with `print_readably` set + to false, concatenates the results together ("" separator), and + returns the new string. + * `prn`: calls `pr_str` on each argument with `print_readably` set + to true, joins the results with " ", prints the string to the + screen and then returns `nil`. + * `println`: calls `pr_str` on each argument with `print_readably` set + to false, joins the results with " ", prints the string to the + screen and then returns `nil`. + + + + +### Step 5: Tail call optimization + +![step5_tco architecture](step5_tco.png) + +In step 4 you added special forms `do`, `if` and `fn*` and you defined +some core functions. In this step you will add a Lisp feature called +tail call optimization (TCO). Also called "tail recursion" or +sometimes just "tail calls". + +Several of the special forms that you have defined in `EVAL` end up +calling back into `EVAL`. For those forms that call `EVAL` as the last +thing that they do before returning (tail call) you will just loop back +to the beginning of eval rather than calling it again. The advantage +of this approach is that it avoids adding more frames to the call +stack. This is especially important in Lisp languages because they tend +to prefer using recursion instead of iteration for control structures. +(Though some Lisps, such as Common Lisp, have iteration.) However, with +tail call optimization, recursion can be made as stack efficient as +iteration. + +Compare the pseudocode for step 4 and step 5 to get a basic idea of +the changes that will be made during this step: +``` +diff -urp ../process/step4_if_fn_do.txt ../process/step5_tco.txt +``` + +* Copy `step4_if_fn_do.qx` to `step5_tco.qx`. + +* Add a loop (e.g. while true) around all code in `EVAL`. + +* Modify each of the following form cases to add tail call recursion + support: + * `let*`: remove the final `EVAL` call on the second `ast` argument + (third list element). Set `env` (i.e. the local variable passed in + as second parameter of `EVAL`) to the new let environment. Set + `ast` (i.e. the local variable passed in as first parameter of + `EVAL`) to be the second `ast` argument. Continue at the beginning + of the loop (no return). + * `do`: change the `eval_ast` call to evaluate all the parameters + except for the last (2nd list element up to but not including + last). Set `ast` to the last element of `ast`. Continue + at the beginning of the loop (`env` stays unchanged). + * `if`: the condition continues to be evaluated, however, rather + than evaluating the true or false branch, `ast` is set to the + unevaluated value of the chosen branch. Continue at the beginning + of the loop (`env` is unchanged). + +* The return value from the `fn*` special form will now become an + object/structure with attributes that allow the default invoke case + of `EVAL` to do TCO on mal functions. Those attributes are: + * `ast`: the second `ast` argument (third list element) representing + the body of the function. + * `params`: the first `ast` argument (second list element) + representing the parameter names of the function. + * `env`: the current value of the `env` parameter of `EVAL`. + * `fn`: the original function value (i.e. what was return by `fn*` + in step 4). Note that this is deferrable until step 9 when it is + required for the `map` and `apply` core functions). You will also + need it in step 6 if you choose to not to defer atoms/`swap!` from + that step. + +* The default "apply"/invoke case of `EVAL` must now be changed to + account for the new object/structure returned by the `fn*` form. + Continue to call `eval_ast` on `ast`. The first element of the + result of `eval_ast` is `f` and the remaining elements are in `args`. + Switch on the type of `f`: + * regular function (not one defined by `fn*`): apply/invoke it as + before (in step 4). + * a `fn*` value: set `ast` to the `ast` attribute of `f`. Generate + a new environment using the `env` and `params` attributes of `f` + as the `outer` and `binds` arguments and `args` as the `exprs` + argument. Set `env` to the new environment. Continue at the + beginning of the loop. + +Run some manual tests from previous steps to make sure you have not +broken anything by adding TCO. + +Now go to the top level, run the step 5 tests. + +``` +make "test^quux^step5" +``` + +Look at the step 5 test file `tests/step5_tco.mal`. The `sum-to` +function cannot be tail call optimized because it does something after +the recursive call (`sum-to` calls itself and then does the addition). +Lispers say that the `sum-to` is not in tail position. The `sum2` +function however, calls itself from tail position. In other words, the +recursive call to `sum2` is the last action that `sum2` does. Calling +`sum-to` with a large value will cause a stack overflow exception in +most target languages (some have super-special tricks they use to +avoid stack overflows). + +Congratulations, your mal implementation already has a feature (TCO) +that most mainstream languages lack. + + + + +### Step 6: Files, Mutation, and Evil + +![step6_file architecture](step6_file.png) + +In step 5 you added tail call optimization. In this step you will add +some string and file operations and give your implementation a touch +of evil ... er, eval. And as long as your language supports function +closures, this step will be quite simple. However, to complete this +step, you must implement string type support, so if you have been +holding off on that you will need to go back and do so. + +Compare the pseudocode for step 5 and step 6 to get a basic idea of +the changes that will be made during this step: +``` +diff -urp ../process/step5_tco.txt ../process/step6_file.txt +``` + +* Copy `step5_tco.qx` to `step6_file.qx`. + +* Add two new string functions to the core namespaces: + * `read-string`: this function just exposes the `read_str` function + from the reader. If your mal string type is not the same as your + target language (e.g. statically typed language) then your + `read-string` function will need to unbox (extract) the raw string + from the mal string type in order to call `read_str`. + * `slurp`: this function takes a file name (string) and returns the + contents of the file as a string. Once again, if your mal string + type wraps a raw target language string, then you will need to + unmarshall (extract) the string parameter to get the raw file name + string and marshall (wrap) the result back to a mal string type. + +* In your main program, add a new symbol "eval" to your REPL + environment. The value of this new entry is a function that takes + a single argument `ast`. The closure calls your `EVAL` function + using the `ast` as the first argument and the REPL environment + (closed over from outside) as the second argument. The result of + the `EVAL` call is returned. This simple but powerful addition + allows your program to treat mal data as a mal program. For example, + you can now do this: +``` +(def! mal-prog (list + 1 2)) +(eval mal-prog) +``` + +* Define a `load-file` function using mal itself. In your main + program call the `rep` function with this string: + "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))". + +Try out `load-file`: + * `(load-file "../tests/incA.mal")` -> `9` + * `(inc4 3)` -> `7` + +The `load-file` function does the following: + * Call `slurp` to read in a file by name. Surround the contents with + "(do ...)" so that the whole file will be treated as a single + program AST (abstract syntax tree). Add a new line in case the files + ends with a comment. The `nil` ensures a short and predictable result, + instead of what happens to be the last function defined in the loaded file. + * Call `read-string` on the string returned from `slurp`. This uses + the reader to read/convert the file contents into mal data/AST. + * Call `eval` (the one in the REPL environment) on the AST returned + from `read-string` to "run" it. + +Besides adding file and eval support, we'll add support for the atom data type +in this step. An atom is the Mal way to represent *state*; it is +heavily inspired by [Clojure's atoms](http://clojure.org/state). An atom holds +a reference to a single Mal value of any type; it supports reading that Mal value +and *modifying* the reference to point to another Mal value. Note that this is +the only Mal data type that is mutable (but the Mal values it refers to are +still immutable; immutability is explained in greater detail in step 7). +You'll need to add 5 functions to the core namespace to support atoms: + + * `atom`: Takes a Mal value and returns a new atom which points to that Mal value. + * `atom?`: Takes an argument and returns `true` if the argument is an atom. + * `deref`: Takes an atom argument and returns the Mal value referenced by this atom. + * `reset!`: Takes an atom and a Mal value; the atom is modified to refer to + the given Mal value. The Mal value is returned. + * `swap!`: Takes an atom, a function, and zero or more function arguments. The + atom's value is modified to the result of applying the function with the atom's + value as the first argument and the optionally given function arguments as + the rest of the arguments. The new atom's value is returned. (Side note: Mal is + single-threaded, but in concurrent languages like Clojure, `swap!` promises + atomic update: `(swap! myatom (fn* [x] (+ 1 x)))` will always increase the + `myatom` counter by one and will not suffer from missing updates when the + atom is updated from multiple threads.) + +Optionally, you can add a reader macro `@` which will serve as a short form for +`deref`, so that `@a` is equivalent to `(deref a)`. In order to do that, modify +the conditional in reader `read_form` function and add a case which deals with +the `@` token: if the token is `@` (at sign) then return a new list that +contains the symbol `deref` and the result of reading the next form +(`read_form`). + +Now go to the top level, run the step 6 tests. The optional tests will +need support from the reader for comments, vectors, hash-maps and the `@` +reader macro: +``` +make "test^quux^step6" +``` + +Congratulations, you now have a full-fledged scripting language that +can run other mal programs. The `slurp` function loads a file as +a string, the `read-string` function calls the mal reader to turn that +string into data, and the `eval` function takes data and evaluates it +as a normal mal program. However, it is important to note that the +`eval` function is not just for running external programs. Because mal +programs are regular mal data structures, you can dynamically generate +or manipulate those data structures before calling `eval` on them. +This isomorphism (same shape) between data and programs is known as +"homoiconicity". Lisp languages are homoiconic and this property +distinguishes them from most other programming languages. + +Your mal implementation is quite powerful already but the set of +functions that are available (from `core.qx`) is fairly limited. The +bulk of the functions you will add are described in step 9 and step A, +but you will begin to flesh them out over the next few steps to +support quoting (step 7) and macros (step 8). + + +#### Deferrable: + +* Add the ability to run another mal program from the command line. + Prior to the REPL loop, check if your mal implementation is called + with command line arguments. If so, treat the first argument as + a filename and use `rep` to call `load-file` on that filename, and + finally exit/terminate execution. + +* Add the rest of the command line arguments to your REPL environment + so that programs that are run with `load-file` have access to their + calling environment. Add a new "\*ARGV\*" (symbol) entry to your REPL + environment. The value of this entry should be the rest of the + command line arguments as a mal list value. + + + + +### Step 7: Quoting + +![step7_quote architecture](step7_quote.png) + +In step 7 you will add the special forms `quote` and `quasiquote` and +add supporting core functions `cons` and `concat`. The two quote forms +add a powerful abstraction for manipulating mal code itself +(meta-programming). + +The `quote` special form indicates to the evaluator (`EVAL`) that the +parameter should not be evaluated (yet). At first glance, this might +not seem particularly useful but an example of what this enables is the +ability for a mal program to refer to a symbol itself rather than the +value that it evaluates to. Likewise with lists. For example, consider +the following: + +* `(prn abc)`: this will lookup the symbol `abc` in the current + evaluation environment and print it. This will result in error if + `abc` is not defined. +* `(prn (quote abc))`: this will print "abc" (prints the symbol + itself). This will work regardless of whether `abc` is defined in + the current environment. +* `(prn (1 2 3))`: this will result in an error because `1` is not + a function and cannot be applied to the arguments `(2 3)`. +* `(prn (quote (1 2 3)))`: this will print "(1 2 3)". +* `(def! l (quote (1 2 3)))`: list quoting allows us to define lists + directly in the code (list literal). Another way of doing this is + with the list function: `(def! l (list 1 2 3))`. + +The second special quoting form is `quasiquote`. This allows a quoted +list to have internal elements of the list that are temporarily +unquoted (normal evaluation). There are two special forms that only +mean something within a quasiquoted list: `unquote` and +`splice-unquote`. These are perhaps best explained with some examples: + +* `(def! lst (quote (b c)))` -> `(b c)` +* `(quasiquote (a lst d))` -> `(a lst d)` +* `(quasiquote (a (unquote lst) d))` -> `(a (b c) d)` +* `(quasiquote (a (splice-unquote lst) d))` -> `(a b c d)` + +The `unquote` form turns evaluation back on for its argument and the +result of evaluation is put in place into the quasiquoted list. The +`splice-unquote` also turns evaluation back on for its argument, but +the evaluated value must be a list which is then "spliced" into the +quasiquoted list. The true power of the quasiquote form will be +manifest when it is used together with macros (in the next step). + +Compare the pseudocode for step 6 and step 7 to get a basic idea of +the changes that will be made during this step: +``` +diff -urp ../process/step6_file.txt ../process/step7_quote.txt +``` + +* Copy `step6_file.qx` to `step7_quote.qx`. + +* Before implementing the quoting forms, you will need to implement + some supporting functions in the core namespace: + * `cons`: this function takes a list as its second + parameter and returns a new list that has the first argument + prepended to it. + * `concat`: this functions takes 0 or more lists as + parameters and returns a new list that is a concatenation of all + the list parameters. + +An aside on immutability: note that neither cons or concat mutate +their original list arguments. Any references to them (i.e. other +lists that they may be "contained" in) will still refer to the +original unchanged value. Mal, like Clojure, is a language which uses +immutable data structures. I encourage you to read about the power and +importance of immutability as implemented in Clojure (from which +Mal borrows most of its syntax and feature-set). + +* Add the `quote` special form. This form just returns its argument + (the second list element of `ast`). + +* Add the `quasiquote` function. + The `quasiquote` function takes a parameter `ast` and has the + following conditional. + - If `ast` is a list starting with the "unquote" symbol, return its + second element. + - If `ast` is a list failing previous test, the result will be a + list populated by the following process. + + The result is initially an empty list. + Iterate over each element `elt` of `ast` in reverse order: + - If `elt` is a list starting with the "splice-unquote" symbol, + replace the current result with a list containing: + the "concat" symbol, + the second element of `elt`, + then the previous result. + - Else replace the current result with a list containing: + the "cons" symbol, + the result of calling `quasiquote` with `elt` as argument, + then the previous result. + + This process can also be described recursively: + - If `ast` is empty return it unchanged. else let `elt` be its + first element. + - If `elt` is a list starting with the "splice-unquote" symbol, + return a list containing: + the "concat" symbol, + the second element of `elt`, + then the result of processing the rest of `ast`. + - Else return a list containing: + the "cons" symbol, + the result of calling `quasiquote` with `elt` as argument, + then the result of processing the rest of `ast`. + - If `ast` is a map or a symbol, return a list containing: + the "quote" symbol, + then `ast`. + - Else return `ast` unchanged. + Such forms are not affected by evaluation, so you may quote them + as in the previous case if implementation is easier. + +* Optionally, add a the `quasiquoteexpand` special form. + This form calls the `quasiquote` function using the first `ast` + argument (second list element) and returns the result. + It has no other practical purpose than testing your implementation + of the `quasiquote` internal function. + +* Add the `quasiquote` special form. + This form does the same than `quasiquoteexpand`, + but evaluates the result in the current environment before returning it, + either by recursively calling `EVAL` with the result and `env`, + or by assigning `ast` with the result and continuing execution at + the top of the loop (TCO). + +Now go to the top level, run the step 7 tests: +``` +make "test^quux^step7" +``` + +Quoting is one of the more mundane functions available in mal, but do +not let that discourage you. Your mal implementation is almost +complete, and quoting sets the stage for the next very exciting step: +macros. + + +#### Deferrable + +* The full names for the quoting forms are fairly verbose. Most Lisp + languages have a short-hand syntax and Mal is no exception. These + short-hand syntaxes are known as reader macros because they allow us + to manipulate mal code during the reader phase. Macros that run + during the eval phase are just called "macros" and are described in + the next section. Expand the conditional with reader `read_form` + function to add the following four cases: + * token is "'" (single quote): return a new list that contains the + symbol "quote" and the result of reading the next form + (`read_form`). + * token is "\`" (back-tick): return a new list that contains the + symbol "quasiquote" and the result of reading the next form + (`read_form`). + * token is "~" (tilde): return a new list that contains the + symbol "unquote" and the result of reading the next form + (`read_form`). + * token is "~@" (tilde + at sign): return a new list that contains + the symbol "splice-unquote" and the result of reading the next + form (`read_form`). + +* Add support for quoting of vectors. `cons` + should also accept a vector as the second argument. The return value + is a list regardless. `concat` should support concatenation of + lists, vectors, or a mix of both. The result is always a list. + + Implement a core function `vec` turning a list into a vector with + the same elements. If provided a vector, `vec` should return it + unchanged. + + In the `quasiquote` function, when `ast` is a vector, + return a list containing: + the "vec" symbol, + then the result of processing `ast` as if it were a list not + starting with `unquote`. + + + +### Step 8: Macros + +![step8_macros architecture](step8_macros.png) + +Your mal implementation is now ready for one of the most lispy and +exciting of all programming concepts: macros. In the previous step, +quoting enabled some simple manipulation data structures and therefore +manipulation of mal code (because the `eval` function from step +6 turns mal data into code). In this step you will be able to mark mal +functions as macros which can manipulate mal code before it is +evaluated. In other words, macros are user-defined special forms. Or +to look at it another way, macros allow mal programs to redefine +the mal language itself. + +Compare the pseudocode for step 7 and step 8 to get a basic idea of +the changes that will be made during this step: +``` +diff -urp ../process/step7_quote.txt ../process/step8_macros.txt +``` + +* Copy `step7_quote.qx` to `step8_macros.qx`. + + +You might think that the infinite power of macros would require some +sort of complex mechanism, but the implementation is actually fairly +simple. + +* Add a new attribute `is_macro` to mal function types. This should + default to false. + +* Add a new special form `defmacro!`. This is very similar to the + `def!` form, but before the evaluated value (mal function) is set in + the environment, the `is_macro` attribute should be set to true. + +* Add a `is_macro_call` function: This function takes arguments `ast` + and `env`. It returns true if `ast` is a list that contains a symbol + as the first element and that symbol refers to a function in the + `env` environment and that function has the `is_macro` attribute set + to true. Otherwise, it returns false. + +* Add a `macroexpand` function: This function takes arguments `ast` + and `env`. It calls `is_macro_call` with `ast` and `env` and loops + while that condition is true. Inside the loop, the first element of + the `ast` list (a symbol), is looked up in the environment to get + the macro function. This macro function is then called/applied with + the rest of the `ast` elements (2nd through the last) as arguments. + The return value of the macro call becomes the new value of `ast`. + When the loop completes because `ast` no longer represents a macro + call, the current value of `ast` is returned. + +* In the evaluator (`EVAL`) before the special forms switch (apply + section), perform macro expansion by calling the `macroexpand` + function with the current value of `ast` and `env`. Set `ast` to the + result of that call. If the new value of `ast` is no longer a list + after macro expansion, then return the result of calling `eval_ast` + on it, otherwise continue with the rest of the apply section + (special forms switch). + +* Add a new special form condition for `macroexpand`. Call the + `macroexpand` function using the first `ast` argument (second list + element) and `env`. Return the result. This special form allows + a mal program to do explicit macro expansion without applying the + result (which can be useful for debugging macro expansion). + +Now go to the top level, run the step 8 tests: +``` +make "test^quux^step8" +``` + +There is a reasonably good chance that the macro tests will not pass +the first time. Although the implementation of macros is fairly +simple, debugging runtime bugs with macros can be fairly tricky. If +you do run into subtle problems that are difficult to solve, let me +recommend a couple of approaches: + +* Use the macroexpand special form to eliminate one of the layers of + indirection (to expand but skip evaluate). This will often reveal + the source of the issue. +* Add a debug print statement to the top of your main `eval` function + (inside the TCO loop) to print the current value of `ast` (hint use + `pr_str` to get easier to debug output). Pull up the step8 + implementation from another language and uncomment its `eval` + function (yes, I give you permission to violate the rule this once). + Run the two side-by-side. The first difference is likely to point to + the bug. + +Congratulations! You now have a Lisp interpreter with a super power +that most non-Lisp languages can only dream of (I have it on good +authority that languages dream when you are not using them). If you +are not already familiar with Lisp macros, I suggest the following +exercise: write a recursive macro that handles postfixed mal code +(with the function as the last parameter instead of the first). Or +not. I have not actually done so myself, but I have heard it is an +interesting exercise. + +In the next step you will add try/catch style exception handling to +your implementation in addition to some new core functions. After +step9 you will be very close to having a fully self-hosting mal +implementation. Let us continue! + + +#### Deferrable + +* Add the following new core functions which are frequently used in + macro functions: + * `nth`: this function takes a list (or vector) and a number (index) + as arguments, returns the element of the list at the given index. + If the index is out of range, this function raises an exception. + * `first`: this function takes a list (or vector) as its argument + and return the first element. If the list (or vector) is empty or + is `nil` then `nil` is returned. + * `rest`: this function takes a list (or vector) as its argument and + returns a new list containing all the elements except the first. If + the list (or vector) is empty or is `nil` then `()` (empty list) + is returned. + +* In the main program, call the `rep` function with the following + string argument to define a new control structure. +``` +"(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)))))))" +``` + * Note that `cond` calls the `throw` function when `cond` is + called with an odd number of args. The `throw` function is + implemented in the next step, but it will still serve it's + purpose here by causing an undefined symbol error. + + + + +### Step 9: Try + +![step9_try architecture](step9_try.png) + +In this step you will implement the final mal special form for +error/exception handling: `try*/catch*`. You will also add several core +functions to your implementation. In particular, you will enhance the +functional programming pedigree of your implementation by adding the +`apply` and `map` core functions. + +Compare the pseudocode for step 8 and step 9 to get a basic idea of +the changes that will be made during this step: +``` +diff -urp ../process/step8_macros.txt ../process/step9_try.txt +``` + +* Copy `step8_macros.qx` to `step9_try.qx`. + +* Add the `try*/catch*` special form to the EVAL function. The + try catch form looks like this: `(try* A (catch* B C))`. The form + `A` is evaluated, if it throws an exception, then form `C` is + evaluated with a new environment that binds the symbol `B` to the + value of the exception that was thrown. + * If your target language has built-in try/catch style exception + handling then you are already 90% of the way done. Add a + (native language) try/catch block that evaluates `A` within + the try block and catches all exceptions. If an exception is + caught, then translate it to a mal type/value. For native + exceptions this is either the message string or a mal hash-map + that contains the message string and other attributes of the + exception. When a regular mal type/value is used as an + exception, you will probably need to store it within a native + exception type in order to be able to convey/transport it using + the native try/catch mechanism. Then you will extract the mal + type/value from the native exception. Create a new mal environment + that binds `B` to the value of the exception. Finally, evaluate `C` + using that new environment. + * If your target language does not have built-in try/catch style + exception handling then you have some extra work to do. One of the + most straightforward approaches is to create a a global error + variable that stores the thrown mal type/value. The complication + is that there are a bunch of places where you must check to see if + the global error state is set and return without proceeding. The + rule of thumb is that this check should happen at the top of your + EVAL function and also right after any call to EVAL (and after any + function call that might happen to call EVAL further down the + chain). Yes, it is ugly, but you were warned in the section on + picking a language. + +* Add the `throw` core function. + * If your language supports try/catch style exception handling, then + this function takes a mal type/value and throws/raises it as an + exception. In order to do this, you may need to create a custom + exception object that wraps a mal value/type. + * If your language does not support try/catch style exception + handling, then set the global error state to the mal type/value. + +* Add the `apply` and `map` core functions. In step 5, if you did not + add the original function (`fn`) to the structure returned from + `fn*`, then you will need to do so now. + * `apply`: takes at least two arguments. The first argument is + a function and the last argument is a list (or vector). The + arguments between the function and the last argument (if there are + any) are concatenated with the final argument to create the + arguments that are used to call the function. The apply + function allows a function to be called with arguments that are + contained in a list (or vector). In other words, `(apply F A B [C + D])` is equivalent to `(F A B C D)`. + * `map`: takes a function and a list (or vector) and evaluates the + function against every element of the list (or vector) one at + a time and returns the results as a list. + +* Add some type predicates core functions. In Lisp, predicates are + functions that return true/false (or true value/nil) and typically + end in "?" or "p". + * `nil?`: takes a single argument and returns true (mal true value) + if the argument is nil (mal nil value). + * `true?`: takes a single argument and returns true (mal true value) + if the argument is a true value (mal true value). + * `false?`: takes a single argument and returns true (mal true + value) if the argument is a false value (mal false value). + * `symbol?`: takes a single argument and returns true (mal true + value) if the argument is a symbol (mal symbol value). + +Now go to the top level, run the step 9 tests: +``` +make "test^quux^step9" +``` + +Your mal implementation is now essentially a fully featured Lisp +interpreter. But if you stop now you will miss one of the most +satisfying and enlightening aspects of creating a mal implementation: +self-hosting. + +#### Deferrable + +* Add the following new core functions: + * `symbol`: takes a string and returns a new symbol with the string + as its name. + * `keyword`: takes a string and returns a keyword with the same name + (usually just be prepending the special keyword + unicode symbol). This function should also detect if the argument + is already a keyword and just return it. + * `keyword?`: takes a single argument and returns true (mal true + value) if the argument is a keyword, otherwise returns false (mal + false value). + * `vector`: takes a variable number of arguments and returns + a vector containing those arguments. + * `vector?`: takes a single argument and returns true (mal true + value) if the argument is a vector, otherwise returns false (mal + false value). + * `sequential?`: takes a single argument and returns true (mal true + value) if it is a list or a vector, otherwise returns false (mal + false value). + * `hash-map`: takes a variable but even number of arguments and + returns a new mal hash-map value with keys from the odd arguments + and values from the even arguments respectively. This is basically + the functional form of the `{}` reader literal syntax. + * `map?`: takes a single argument and returns true (mal true + value) if the argument is a hash-map, otherwise returns false (mal + false value). + * `assoc`: takes a hash-map as the first argument and the remaining + arguments are odd/even key/value pairs to "associate" (merge) into + the hash-map. Note that the original hash-map is unchanged + (remember, mal values are immutable), and a new hash-map + containing the old hash-maps key/values plus the merged key/value + arguments is returned. + * `dissoc`: takes a hash-map and a list of keys to remove from the + hash-map. Again, note that the original hash-map is unchanged and + a new hash-map with the keys removed is returned. Key arguments + that do not exist in the hash-map are ignored. + * `get`: takes a hash-map and a key and returns the value of looking + up that key in the hash-map. If the key is not found in the + hash-map then nil is returned. + * `contains?`: takes a hash-map and a key and returns true (mal true + value) if the key exists in the hash-map and false (mal false + value) otherwise. + * `keys`: takes a hash-map and returns a list (mal list value) of + all the keys in the hash-map. + * `vals`: takes a hash-map and returns a list (mal list value) of + all the values in the hash-map. + + + + +### Step A: Metadata, Self-hosting and Interop + +![stepA_mal architecture](stepA_mal.png) + +You have reached the final step of your mal implementation. This step +is kind of a catchall for things that did not fit into other steps. +But most importantly, the changes you make in this step will unlock +the magical power known as "self-hosting". You might have noticed +that one of the languages that mal is implemented in is "mal". Any mal +implementation that is complete enough can run the mal implementation +of mal. You might need to pull out your hammock and ponder this for +a while if you have never built a compiler or interpreter before. Look +at the step source files for the mal implementation of mal (it is not +cheating now that you have reached step A). + +If you deferred the implementation of keywords, vectors and hash-maps, +now is the time to go back and implement them if you want your +implementation to self-host. + +Compare the pseudocode for step 9 and step A to get a basic idea of +the changes that will be made during this step: +``` +diff -urp ../process/step9_try.txt ../process/stepA_mal.txt +``` + +* Copy `step9_try.qx` to `stepA_mal.qx`. + +* Add the `readline` core function. This functions takes a + string that is used to prompt the user for input. The line of text + entered by the user is returned as a string. If the user sends an + end-of-file (usually Ctrl-D), then nil is returned. + +* Add a new "\*host-language\*" (symbol) entry to your REPL + environment. The value of this entry should be a mal string + containing the name of the current implementation. + +* When the REPL starts up (as opposed to when it is called with + a script and/or arguments), call the `rep` function with this string + to print a startup header: + "(println (str \"Mal [\" \*host-language\* \"]\"))". + +* Ensure that the REPL environment contains definitions for `time-ms`, + `meta`, `with-meta`, `fn?` + `string?`, `number?`, `seq`, and `conj`. It doesn't really matter + what they do at this stage: they just need to be defined. Making + them functions that raise a "not implemented" exception would be + fine. + +Now go to the top level, run the step A tests: +``` +make "test^quux^stepA" +``` + +Once you have passed all the non-optional step A tests, it is time to +try self-hosting. Run your step A implementation as normal, but use +the file argument mode you added in step 6 to run a each of the step +from the mal implementation: +``` +./stepA_mal.qx ../mal/step1_read_print.mal +./stepA_mal.qx ../mal/step2_eval.mal +... +./stepA_mal.qx ../mal/step9_try.mal +./stepA_mal.qx ../mal/stepA_mal.mal +``` + +There is a very good chance that you will encounter an error at some +point while trying to run the mal in mal implementation steps above. +Debugging failures that happen while self-hosting is MUCH more +difficult and mind bending. One of the best approaches I have +personally found is to add prn statements to the mal implementation +step (not your own implementation of mal) that is causing problems. + +Another approach I have frequently used is to pull out the code from +the mal implementation that is causing the problem and simplify it +step by step until you have a simple piece of mal code that still +reproduces the problem. Once the reproducer is simple enough you will +probably know where in your own implementation that problem is likely +to be. Please add your simple reproducer as a test case so that future +implementers will fix similar issues in their code before they get to +self-hosting when it is much more difficult to track down and fix. + +Once you can manually run all the self-hosted steps, it is time to run +all the tests in self-hosted mode: +``` +make MAL_IMPL=quux "test^mal" +``` + +When you run into problems (which you almost certainly will), use the +same process described above to debug them. + +Congratulations!!! When all the tests pass, you should pause for +a moment and consider what you have accomplished. You have implemented +a Lisp interpreter that is powerful and complete enough to run a large +mal program which is itself an implementation of the mal language. You +might even be asking if you can continue the "inception" by using your +implementation to run a mal implementation which itself runs the mal +implementation. + + +#### Optional additions + +* Add meta-data support to composite data types (lists, vectors + and hash-maps), and to functions (native or not), by adding a new + metadata attribute that refers to another mal value/type + (nil by default). Add the following metadata related core functions + (and remove any stub versions): + * `meta`: this takes a single mal function/list/vector/hash-map argument + and returns the value of the metadata attribute. + * `with-meta`: this function takes two arguments. The first argument + is a mal function/list/vector/hash-map and the second argument is + another mal value/type to set as metadata. A copy of the mal function is + returned that has its `meta` attribute set to the second argument. + Note that it is important that the environment and macro attribute + of mal function are retained when it is copied. + * Add a reader-macro that expands the token "^" to + return a new list that contains the symbol "with-meta" and the + result of reading the next next form (2nd argument) (`read_form`) and the + next form (1st argument) in that order + (metadata comes first with the ^ macro and the function second). + * If you implemented as `defmacro!` to mutate an existing function + without copying it, you can now use the function copying mechanism + used for metadata to make functions immutable even in the + defmacro! case... + +* Add the following new core functions (and remove any stub versions): + * `time-ms`: takes no arguments and returns the number of + milliseconds since epoch (00:00:00 UTC January 1, 1970), or, if + not possible, since another point in time (`time-ms` is usually + used relatively to measure time durations). After `time-ms` is + implemented, you can run the performance micro-benchmarks by + running `make perf^quux`. + * `conj`: takes a collection and one or more elements as arguments + and returns a new collection which includes the original + collection and the new elements. If the collection is a list, a + new list is returned with the elements inserted at the start of + the given list in opposite order; if the collection is a vector, a + new vector is returned with the elements added to the end of the + given vector. + * `string?`: returns true if the parameter is a string. + * `number?`: returns true if the parameter is a number. + * `fn?`: returns true if the parameter is a function (internal or + user-defined). + * `macro?`: returns true if the parameter is a macro. + * `seq`: takes a list, vector, string, or nil. If an empty list, + empty vector, or empty string ("") is passed in then nil is + returned. Otherwise, a list is returned unchanged, a vector is + converted into a list, and a string is converted to a list that + containing the original string split into single character + strings. +* For interop with the target language, add this core function: + * `quux-eval`: takes a string, evaluates it in the target language, + and returns the result converted to the relevant Mal type. You may + also add other interop functions as you see fit; Clojure, for + example, has a function called `.` which allows calling Java + methods. If the target language is a static language, consider + using FFI or some language-specific reflection mechanism, if + available. The tests for `quux-eval` and any other interop + function should be added in `impls/quux/tests/stepA_mal.mal` (see + the [tests for `lua-eval`](../impls/lua/tests/stepA_mal.mal) as an + example). + +### Next Steps + +* Join the #mal IRC channel. It's fairly quiet but there are bursts of + interesting conversation related to mal, Lisps, esoteric programming + languages, etc. +* If you have created an implementation for a new target language (or + a unique and interesting variant of an existing implementation), + consider sending a pull request to add it into the main mal + repository. The [FAQ](../docs/FAQ.md#will-you-add-my-new-implementation) + describes general requirements for getting an implementation merged + into the main repository. +* Take your interpreter implementation and have it emit source code in + the target language rather than immediately evaluating it. In other + words, create a compiler. +* Pick a new target language and implement mal in it. Pick a language + that is very different from any that you already know. +* Use your mal implementation to implement a real world project. Many + of these will force you to address interop. Some ideas: + * Web server (with mal as CGI language for extra points) + * An IRC/Slack chat bot + * An editor (GUI or curses) with mal as a scripting/extension + language. + * An AI player for a game like Chess or Go. +* Implement a feature in your mal implementation that is not covered + by this guide. Some ideas: + * Namespaces + * Multi-threading support + * Errors with line numbers and/or stack traces. + * Lazy sequences + * Clojure-style protocols + * Full call/cc (call-with-current-continuation) support + * Explicit TCO (i.e. `recur`) with tail-position error checking diff --git a/process/step0_repl.txt b/process/step0_repl.txt index c3c6aa08f8..4cd9ec0e04 100644 --- a/process/step0_repl.txt +++ b/process/step0_repl.txt @@ -1,11 +1,11 @@ ---- step0_repl ---------------------------------- -READ(str): return str - -EVAL(ast,env): return ast - -PRINT(exp): return exp - -rep(str): return PRINT(EVAL(READ(str),"")) - -main loop: println(rep(readline("user> "))) - +--- step0_repl ---------------------------------- +READ(str): return str + +EVAL(ast,env): return ast + +PRINT(exp): return exp + +rep(str): return PRINT(EVAL(READ(str),"")) + +main loop: println(rep(readline("user> "))) + diff --git a/process/step1_read_print.txt b/process/step1_read_print.txt index 3a0fd7c693..74ee27b0a3 100644 --- a/process/step1_read_print.txt +++ b/process/step1_read_print.txt @@ -1,14 +1,14 @@ ---- step1_read_print ---------------------------- -import reader, printer - -READ(str): return reader.read_str(str) - -EVAL(ast,env): return ast - -PRINT(exp): return printer.pr_str(exp) - -rep(str): return PRINT(EVAL(READ(str),"")) - -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) +--- step1_read_print ---------------------------- +import reader, printer + +READ(str): return reader.read_str(str) + +EVAL(ast,env): return ast + +PRINT(exp): return printer.pr_str(exp) + +rep(str): return PRINT(EVAL(READ(str),"")) + +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) diff --git a/process/step2_eval.txt b/process/step2_eval.txt index 9cd2e08c32..908cbfe437 100644 --- a/process/step2_eval.txt +++ b/process/step2_eval.txt @@ -1,26 +1,26 @@ ---- step2_eval ---------------------------------- -import types, reader, printer - -READ(str): return reader.read_str(str) - -eval_ast(ast,env): - switch type(ast): - symbol: return lookup(env, ast) OR raise "'" + ast + "' not found" - list,vector: return ast.map((x) -> EVAL(x,env)) - hash: return ast.map((k,v) -> list(k, EVAL(v,env))) - _default_: return ast - -EVAL(ast,env): - if not list?(ast): return eval_ast(ast, env) - if empty?(ast): return ast - f, args = eval_ast(ast, env) - return apply(f, args) - -PRINT(exp): return printer.pr_str(exp) - -repl_env = {'+: add_fn, ...} -rep(str): return PRINT(EVAL(READ(str),repl_env)) - -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) +--- step2_eval ---------------------------------- +import types, reader, printer + +READ(str): return reader.read_str(str) + +eval_ast(ast,env): + switch type(ast): + symbol: return lookup(env, ast) OR raise "'" + ast + "' not found" + list,vector: return ast.map((x) -> EVAL(x,env)) + hash: return ast.map((k,v) -> list(k, EVAL(v,env))) + _default_: return ast + +EVAL(ast,env): + if not list?(ast): return eval_ast(ast, env) + if empty?(ast): return ast + f, args = eval_ast(ast, env) + return apply(f, args) + +PRINT(exp): return printer.pr_str(exp) + +repl_env = {'+: add_fn, ...} +rep(str): return PRINT(EVAL(READ(str),repl_env)) + +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) diff --git a/process/step3_env.txt b/process/step3_env.txt index 0210efccf8..08bd13f5a9 100644 --- a/process/step3_env.txt +++ b/process/step3_env.txt @@ -1,39 +1,39 @@ ---- step3_env ----------------------------------- -import types, reader, printer, env - -READ(str): return reader.read_str(str) - -eval_ast(ast,env): - switch type(ast): - symbol: return env.get(ast) - list,vector: return ast.map((x) -> EVAL(x,env)) - hash: return ast.map((k,v) -> list(k, EVAL(v,env))) - _default_: return ast - -EVAL(ast,env): - if not list?(ast): return eval_ast(ast, env) - if empty?(ast): return ast - switch ast[0]: - 'def!: return env.set(ast[1], EVAL(ast[2], env)) - 'let*: let_env = ...; return EVAL(ast[2], let_env) - _default_: f, args = eval_ast(ast, env) - return apply(f, args) - -PRINT(exp): return printer.pr_str(exp) - -repl_env = new Env() -rep(str): return PRINT(EVAL(READ(str),repl_env)) - -repl_env.set('+, add_fn) - ... - -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) - ---- env module ---------------------------------- -class Env (outer=null) - data = hash_map() - set(k,v): return data.set(k,v) - find(k): return data.has(k) ? this : (if outer ? find(outer) : null) - get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" +--- step3_env ----------------------------------- +import types, reader, printer, env + +READ(str): return reader.read_str(str) + +eval_ast(ast,env): + switch type(ast): + symbol: return env.get(ast) + list,vector: return ast.map((x) -> EVAL(x,env)) + hash: return ast.map((k,v) -> list(k, EVAL(v,env))) + _default_: return ast + +EVAL(ast,env): + if not list?(ast): return eval_ast(ast, env) + if empty?(ast): return ast + switch ast[0]: + 'def!: return env.set(ast[1], EVAL(ast[2], env)) + 'let*: let_env = ...; return EVAL(ast[2], let_env) + _default_: f, args = eval_ast(ast, env) + return apply(f, args) + +PRINT(exp): return printer.pr_str(exp) + +repl_env = new Env() +rep(str): return PRINT(EVAL(READ(str),repl_env)) + +repl_env.set('+, add_fn) + ... + +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) + +--- env module ---------------------------------- +class Env (outer=null) + data = hash_map() + set(k,v): return data.set(k,v) + find(k): return data.has(k) ? this : (if outer ? find(outer) : null) + get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" diff --git a/process/step4_if_fn_do.txt b/process/step4_if_fn_do.txt index f92e141c60..75676d47df 100644 --- a/process/step4_if_fn_do.txt +++ b/process/step4_if_fn_do.txt @@ -1,71 +1,71 @@ ---- step4_if_fn_do ------------------------------ -import types, reader, printer, env, core - -READ(str): return reader.read_str(str) - -eval_ast(ast,env): - switch type(ast): - symbol: return env.get(ast) - list,vector: return ast.map((x) -> EVAL(x,env)) - hash: return ast.map((k,v) -> list(k, EVAL(v,env))) - _default_: return ast - -EVAL(ast,env): - if not list?(ast): return eval_ast(ast, env) - if empty?(ast): return ast - switch ast[0]: - 'def!: return env.set(ast[1], EVAL(ast[2], env)) - 'let*: let_env = ...; return EVAL(ast[2], let_env) - 'do: return eval_ast(rest(ast), env)[-1] - 'if: return EVAL(EVAL(ast[1], env) ? ast[2] : ast[3], env) - 'fn*: return (...a) -> EVAL(ast[2], new Env(env, ast[1], a)) - _default_: f, args = eval_ast(ast, env) - return apply(f, args) - -PRINT(exp): return printer.pr_str(exp) - -repl_env = new Env() -rep(str): return PRINT(EVAL(READ(str),repl_env)) - -;; core.EXT: defined using the host language. -core.ns.map((k,v) -> (repl_env.set(k, v))) - -;; core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))") - -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) - ---- env module ---------------------------------- -class Env (outer=null,binds=[],exprs=[]) - data = hash_map() - foreach b, i in binds: - if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break - else: data[binds[i]] = exprs[i] - set(k,v): return data.set(k,v) - find(k): return data.has(k) ? this : (if outer ? find(outer) : null) - get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" - ---- core module --------------------------------- -ns = {'=: equal?, - - 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), - 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), - 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), - 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), - - '<: lt, - '<=: lte, - '>: gt, - '>=: gte, - '+: add, - '-: sub, - '*: mult, - '/: div, - - 'list: list, - 'list?: list?, - - 'empty?: empty?, - 'count: count} +--- step4_if_fn_do ------------------------------ +import types, reader, printer, env, core + +READ(str): return reader.read_str(str) + +eval_ast(ast,env): + switch type(ast): + symbol: return env.get(ast) + list,vector: return ast.map((x) -> EVAL(x,env)) + hash: return ast.map((k,v) -> list(k, EVAL(v,env))) + _default_: return ast + +EVAL(ast,env): + if not list?(ast): return eval_ast(ast, env) + if empty?(ast): return ast + switch ast[0]: + 'def!: return env.set(ast[1], EVAL(ast[2], env)) + 'let*: let_env = ...; return EVAL(ast[2], let_env) + 'do: return eval_ast(rest(ast), env)[-1] + 'if: return EVAL(EVAL(ast[1], env) ? ast[2] : ast[3], env) + 'fn*: return (...a) -> EVAL(ast[2], new Env(env, ast[1], a)) + _default_: f, args = eval_ast(ast, env) + return apply(f, args) + +PRINT(exp): return printer.pr_str(exp) + +repl_env = new Env() +rep(str): return PRINT(EVAL(READ(str),repl_env)) + +;; core.EXT: defined using the host language. +core.ns.map((k,v) -> (repl_env.set(k, v))) + +;; core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))") + +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) + +--- env module ---------------------------------- +class Env (outer=null,binds=[],exprs=[]) + data = hash_map() + foreach b, i in binds: + if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break + else: data[binds[i]] = exprs[i] + set(k,v): return data.set(k,v) + find(k): return data.has(k) ? this : (if outer ? find(outer) : null) + get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" + +--- core module --------------------------------- +ns = {'=: equal?, + + 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), + 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), + 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), + 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), + + '<: lt, + '<=: lte, + '>: gt, + '>=: gte, + '+: add, + '-: sub, + '*: mult, + '/: div, + + 'list: list, + 'list?: list?, + + 'empty?: empty?, + 'count: count} diff --git a/process/step5_tco.txt b/process/step5_tco.txt index cb1d4125b4..707a9dbb07 100644 --- a/process/step5_tco.txt +++ b/process/step5_tco.txt @@ -1,73 +1,73 @@ ---- step5_tco ----------------------------------- -import types, reader, printer, env, core - -READ(str): return reader.read_str(str) - -eval_ast(ast,env): - switch type(ast): - symbol: return env.get(ast) - list,vector: return ast.map((x) -> EVAL(x,env)) - hash: return ast.map((k,v) -> list(k, EVAL(v,env))) - _default_: return ast - -EVAL(ast,env): - while true: - if not list?(ast): return eval_ast(ast, env) - if empty?(ast): return ast - switch ast[0]: - 'def!: return env.set(ast[1], EVAL(ast[2], env)) - 'let*: env = ...; ast = ast[2] // TCO - 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO - 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO - 'fn*: return new MalFunc(...) - _default_: f, args = eval_ast(ast, env) - if malfunc?(f): ast = f.fn; env = ... // TCO - else: return apply(f, args) - -PRINT(exp): return printer.pr_str(exp) - -repl_env = new Env() -rep(str): return PRINT(EVAL(READ(str),repl_env)) - -;; core.EXT: defined using the host language. -core.ns.map((k,v) -> (repl_env.set(k, v))) - -;; core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))") - -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) - ---- env module ---------------------------------- -class Env (outer=null,binds=[],exprs=[]) - data = hash_map() - foreach b, i in binds: - if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break - else: data[binds[i]] = exprs[i] - set(k,v): return data.set(k,v) - find(k): return data.has(k) ? this : (if outer ? find(outer) : null) - get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" - ---- core module --------------------------------- -ns = {'=: equal?, - - 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), - 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), - 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), - 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), - - '<: lt, - '<=: lte, - '>: gt, - '>=: gte, - '+: add, - '-: sub, - '*: mult, - '/: div, - - 'list: list, - 'list?: list?, - - 'empty?: empty?, - 'count: count} +--- step5_tco ----------------------------------- +import types, reader, printer, env, core + +READ(str): return reader.read_str(str) + +eval_ast(ast,env): + switch type(ast): + symbol: return env.get(ast) + list,vector: return ast.map((x) -> EVAL(x,env)) + hash: return ast.map((k,v) -> list(k, EVAL(v,env))) + _default_: return ast + +EVAL(ast,env): + while true: + if not list?(ast): return eval_ast(ast, env) + if empty?(ast): return ast + switch ast[0]: + 'def!: return env.set(ast[1], EVAL(ast[2], env)) + 'let*: env = ...; ast = ast[2] // TCO + 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO + 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO + 'fn*: return new MalFunc(...) + _default_: f, args = eval_ast(ast, env) + if malfunc?(f): ast = f.fn; env = ... // TCO + else: return apply(f, args) + +PRINT(exp): return printer.pr_str(exp) + +repl_env = new Env() +rep(str): return PRINT(EVAL(READ(str),repl_env)) + +;; core.EXT: defined using the host language. +core.ns.map((k,v) -> (repl_env.set(k, v))) + +;; core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))") + +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) + +--- env module ---------------------------------- +class Env (outer=null,binds=[],exprs=[]) + data = hash_map() + foreach b, i in binds: + if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break + else: data[binds[i]] = exprs[i] + set(k,v): return data.set(k,v) + find(k): return data.has(k) ? this : (if outer ? find(outer) : null) + get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" + +--- core module --------------------------------- +ns = {'=: equal?, + + 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), + 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), + 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), + 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), + + '<: lt, + '<=: lte, + '>: gt, + '>=: gte, + '+: add, + '-: sub, + '*: mult, + '/: div, + + 'list: list, + 'list?: list?, + + 'empty?: empty?, + 'count: count} diff --git a/process/step6_file.txt b/process/step6_file.txt index ca4f7061ac..0b6db200d4 100644 --- a/process/step6_file.txt +++ b/process/step6_file.txt @@ -1,86 +1,86 @@ ---- step6_file ---------------------------------- -import types, reader, printer, env, core - -READ(str): return reader.read_str(str) - -eval_ast(ast,env): - switch type(ast): - symbol: return env.get(ast) - list,vector: return ast.map((x) -> EVAL(x,env)) - hash: return ast.map((k,v) -> list(k, EVAL(v,env))) - _default_: return ast - -EVAL(ast,env): - while true: - if not list?(ast): return eval_ast(ast, env) - if empty?(ast): return ast - switch ast[0]: - 'def!: return env.set(ast[1], EVAL(ast[2], env)) - 'let*: env = ...; ast = ast[2] // TCO - 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO - 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO - 'fn*: return new MalFunc(...) - _default_: f, args = eval_ast(ast, env) - if malfunc?(f): ast = f.fn; env = ... // TCO - else: return apply(f, args) - -PRINT(exp): return printer.pr_str(exp) - -repl_env = new Env() -rep(str): return PRINT(EVAL(READ(str),repl_env)) - -;; core.EXT: defined using the host language. -core.ns.map((k,v) -> (repl_env.set(k, v))) -repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) -repl_env.set('*ARGV*, cmdline_args[1..]) - -;; core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 - -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) - ---- env module ---------------------------------- -class Env (outer=null,binds=[],exprs=[]) - data = hash_map() - foreach b, i in binds: - if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break - else: data[binds[i]] = exprs[i] - set(k,v): return data.set(k,v) - find(k): return data.has(k) ? this : (if outer ? find(outer) : null) - get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" - ---- core module --------------------------------- -ns = {'=: equal?, - - 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), - 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), - 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), - 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), - 'read-string: read_str, - 'slurp read-file, - - '<: lt, - '<=: lte, - '>: gt, - '>=: gte, - '+: add, - '-: sub, - '*: mult, - '/: div, - - 'list: list, - 'list?: list?, - - 'empty?: empty?, - 'count: count, - - 'atom: (a) -> new Atom(a[0]), - 'atom?: (a) -> type(a[0]) == "atom", - 'deref: (a) -> a[0].val, - 'reset!: (a) -> a[0].val = a[1], - 'swap!: swap!} +--- step6_file ---------------------------------- +import types, reader, printer, env, core + +READ(str): return reader.read_str(str) + +eval_ast(ast,env): + switch type(ast): + symbol: return env.get(ast) + list,vector: return ast.map((x) -> EVAL(x,env)) + hash: return ast.map((k,v) -> list(k, EVAL(v,env))) + _default_: return ast + +EVAL(ast,env): + while true: + if not list?(ast): return eval_ast(ast, env) + if empty?(ast): return ast + switch ast[0]: + 'def!: return env.set(ast[1], EVAL(ast[2], env)) + 'let*: env = ...; ast = ast[2] // TCO + 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO + 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO + 'fn*: return new MalFunc(...) + _default_: f, args = eval_ast(ast, env) + if malfunc?(f): ast = f.fn; env = ... // TCO + else: return apply(f, args) + +PRINT(exp): return printer.pr_str(exp) + +repl_env = new Env() +rep(str): return PRINT(EVAL(READ(str),repl_env)) + +;; core.EXT: defined using the host language. +core.ns.map((k,v) -> (repl_env.set(k, v))) +repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) +repl_env.set('*ARGV*, cmdline_args[1..]) + +;; core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 + +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) + +--- env module ---------------------------------- +class Env (outer=null,binds=[],exprs=[]) + data = hash_map() + foreach b, i in binds: + if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break + else: data[binds[i]] = exprs[i] + set(k,v): return data.set(k,v) + find(k): return data.has(k) ? this : (if outer ? find(outer) : null) + get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" + +--- core module --------------------------------- +ns = {'=: equal?, + + 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), + 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), + 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), + 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), + 'read-string: read_str, + 'slurp read-file, + + '<: lt, + '<=: lte, + '>: gt, + '>=: gte, + '+: add, + '-: sub, + '*: mult, + '/: div, + + 'list: list, + 'list?: list?, + + 'empty?: empty?, + 'count: count, + + 'atom: (a) -> new Atom(a[0]), + 'atom?: (a) -> type(a[0]) == "atom", + 'deref: (a) -> a[0].val, + 'reset!: (a) -> a[0].val = a[1], + 'swap!: swap!} diff --git a/process/step7_quote.txt b/process/step7_quote.txt index fb29c98bb3..790fb2f823 100644 --- a/process/step7_quote.txt +++ b/process/step7_quote.txt @@ -1,93 +1,93 @@ ---- step7_quote --------------------------------- -import types, reader, printer, env, core - -READ(str): return reader.read_str(str) - -quasiquote(ast): return ... // quasiquote - -eval_ast(ast,env): - switch type(ast): - symbol: return env.get(ast) - list,vector: return ast.map((x) -> EVAL(x,env)) - hash: return ast.map((k,v) -> list(k, EVAL(v,env))) - _default_: return ast - -EVAL(ast,env): - while true: - if not list?(ast): return eval_ast(ast, env) - if empty?(ast): return ast - switch ast[0]: - 'def!: return env.set(ast[1], EVAL(ast[2], env)) - 'let*: env = ...; ast = ast[2] // TCO - 'quote: return ast[1] - 'quasiquote: ast = quasiquote(ast[1]) // TCO - 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO - 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO - 'fn*: return new MalFunc(...) - _default_: f, args = eval_ast(ast, env) - if malfunc?(f): ast = f.fn; env = ... // TCO - else: return apply(f, args) - -PRINT(exp): return printer.pr_str(exp) - -repl_env = new Env() -rep(str): return PRINT(EVAL(READ(str),repl_env)) - -;; core.EXT: defined using the host language. -core.ns.map((k,v) -> (repl_env.set(k, v))) -repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) -repl_env.set('*ARGV*, cmdline_args[1..]) - -;; core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") - -if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 - -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) - ---- env module ---------------------------------- -class Env (outer=null,binds=[],exprs=[]) - data = hash_map() - foreach b, i in binds: - if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break - else: data[binds[i]] = exprs[i] - set(k,v): return data.set(k,v) - find(k): return data.has(k) ? this : (if outer ? find(outer) : null) - get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" - ---- core module --------------------------------- -ns = {'=: equal?, - - 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), - 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), - 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), - 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), - 'read-string: read_str, - 'slurp read-file, - - '<: lt, - '<=: lte, - '>: gt, - '>=: gte, - '+: add, - '-: sub, - '*: mult, - '/: div, - - 'list: list, - 'list?: list?, - - 'cons: (a) -> concat([a[0]], a[1]), - 'concat: (a) -> reduce(concat, [], a), - 'vec: (l) -> l converted to vector, - 'empty?: empty?, - 'count: count, - - 'atom: (a) -> new Atom(a[0]), - 'atom?: (a) -> type(a[0]) == "atom", - 'deref: (a) -> a[0].val, - 'reset!: (a) -> a[0].val = a[1], - 'swap!: swap!} +--- step7_quote --------------------------------- +import types, reader, printer, env, core + +READ(str): return reader.read_str(str) + +quasiquote(ast): return ... // quasiquote + +eval_ast(ast,env): + switch type(ast): + symbol: return env.get(ast) + list,vector: return ast.map((x) -> EVAL(x,env)) + hash: return ast.map((k,v) -> list(k, EVAL(v,env))) + _default_: return ast + +EVAL(ast,env): + while true: + if not list?(ast): return eval_ast(ast, env) + if empty?(ast): return ast + switch ast[0]: + 'def!: return env.set(ast[1], EVAL(ast[2], env)) + 'let*: env = ...; ast = ast[2] // TCO + 'quote: return ast[1] + 'quasiquote: ast = quasiquote(ast[1]) // TCO + 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO + 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO + 'fn*: return new MalFunc(...) + _default_: f, args = eval_ast(ast, env) + if malfunc?(f): ast = f.fn; env = ... // TCO + else: return apply(f, args) + +PRINT(exp): return printer.pr_str(exp) + +repl_env = new Env() +rep(str): return PRINT(EVAL(READ(str),repl_env)) + +;; core.EXT: defined using the host language. +core.ns.map((k,v) -> (repl_env.set(k, v))) +repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) +repl_env.set('*ARGV*, cmdline_args[1..]) + +;; core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") + +if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 + +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) + +--- env module ---------------------------------- +class Env (outer=null,binds=[],exprs=[]) + data = hash_map() + foreach b, i in binds: + if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break + else: data[binds[i]] = exprs[i] + set(k,v): return data.set(k,v) + find(k): return data.has(k) ? this : (if outer ? find(outer) : null) + get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" + +--- core module --------------------------------- +ns = {'=: equal?, + + 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), + 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), + 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), + 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), + 'read-string: read_str, + 'slurp read-file, + + '<: lt, + '<=: lte, + '>: gt, + '>=: gte, + '+: add, + '-: sub, + '*: mult, + '/: div, + + 'list: list, + 'list?: list?, + + 'cons: (a) -> concat([a[0]], a[1]), + 'concat: (a) -> reduce(concat, [], a), + 'vec: (l) -> l converted to vector, + 'empty?: empty?, + 'count: count, + + 'atom: (a) -> new Atom(a[0]), + 'atom?: (a) -> type(a[0]) == "atom", + 'deref: (a) -> a[0].val, + 'reset!: (a) -> a[0].val = a[1], + 'swap!: swap!} diff --git a/process/step8_macros.txt b/process/step8_macros.txt index 52f01e33f6..285d5a9ec9 100644 --- a/process/step8_macros.txt +++ b/process/step8_macros.txt @@ -1,106 +1,106 @@ ---- step8_macros -------------------------------- -import types, reader, printer, env, core - -READ(str): return reader.read_str(str) - -quasiquote(ast): return ... // quasiquote - -macro?(ast, env): return ... // true if macro call -macroexpand(ast, env): return ... // recursive macro expansion - -eval_ast(ast,env): - switch type(ast): - symbol: return env.get(ast) - list,vector: return ast.map((x) -> EVAL(x,env)) - hash: return ast.map((k,v) -> list(k, EVAL(v,env))) - _default_: return ast - -EVAL(ast,env): - while true: - if not list?(ast): return eval_ast(ast, env) - - ast = macroexpand(ast, env) - if not list?(ast): return eval_ast(ast, env) - if empty?(ast): return ast - - switch ast[0]: - 'def!: return env.set(ast[1], EVAL(ast[2], env)) - 'let*: env = ...; ast = ast[2] // TCO - 'quote: return ast[1] - 'quasiquote: ast = quasiquote(ast[1]) // TCO - 'defmacro!: return ... // like def!, but set macro property - 'macroexpand: return macroexpand(ast[1], env) - 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO - 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO - 'fn*: return new MalFunc(...) - _default_: f, args = eval_ast(ast, env) - if malfunc?(f): ast = f.fn; env = ... // TCO - else: return apply(f, args) - -PRINT(exp): return printer.pr_str(exp) - -repl_env = new Env() -rep(str): return PRINT(EVAL(READ(str),repl_env)) - -;; core.EXT: defined using the host language. -core.ns.map((k,v) -> (repl_env.set(k, v))) -repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) -repl_env.set('*ARGV*, cmdline_args[1..]) - -;; core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))"); - -if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 - -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) - ---- env module ---------------------------------- -class Env (outer=null,binds=[],exprs=[]) - data = hash_map() - foreach b, i in binds: - if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break - else: data[binds[i]] = exprs[i] - set(k,v): return data.set(k,v) - find(k): return data.has(k) ? this : (if outer ? find(outer) : null) - get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" - ---- core module --------------------------------- -ns = {'=: equal?, - - 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), - 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), - 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), - 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), - 'read-string: read_str, - 'slurp read-file, - - '<: lt, - '<=: lte, - '>: gt, - '>=: gte, - '+: add, - '-: sub, - '*: mult, - '/: div, - - 'list: list, - 'list?: list?, - - 'cons: (a) -> concat([a[0]], a[1]), - 'concat: (a) -> reduce(concat, [], a), - 'vec: (l) -> l converted to vector, - 'nth: (a) -> a[0][a[1]] OR raise "nth: index out of range", - 'first: (a) -> a[0][0] OR nil, - 'rest: (a) -> a[0][1..] OR list(), - 'empty?: empty?, - 'count: count, - - 'atom: (a) -> new Atom(a[0]), - 'atom?: (a) -> type(a[0]) == "atom", - 'deref: (a) -> a[0].val, - 'reset!: (a) -> a[0].val = a[1], - 'swap!: swap!} +--- step8_macros -------------------------------- +import types, reader, printer, env, core + +READ(str): return reader.read_str(str) + +quasiquote(ast): return ... // quasiquote + +macro?(ast, env): return ... // true if macro call +macroexpand(ast, env): return ... // recursive macro expansion + +eval_ast(ast,env): + switch type(ast): + symbol: return env.get(ast) + list,vector: return ast.map((x) -> EVAL(x,env)) + hash: return ast.map((k,v) -> list(k, EVAL(v,env))) + _default_: return ast + +EVAL(ast,env): + while true: + if not list?(ast): return eval_ast(ast, env) + + ast = macroexpand(ast, env) + if not list?(ast): return eval_ast(ast, env) + if empty?(ast): return ast + + switch ast[0]: + 'def!: return env.set(ast[1], EVAL(ast[2], env)) + 'let*: env = ...; ast = ast[2] // TCO + 'quote: return ast[1] + 'quasiquote: ast = quasiquote(ast[1]) // TCO + 'defmacro!: return ... // like def!, but set macro property + 'macroexpand: return macroexpand(ast[1], env) + 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO + 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO + 'fn*: return new MalFunc(...) + _default_: f, args = eval_ast(ast, env) + if malfunc?(f): ast = f.fn; env = ... // TCO + else: return apply(f, args) + +PRINT(exp): return printer.pr_str(exp) + +repl_env = new Env() +rep(str): return PRINT(EVAL(READ(str),repl_env)) + +;; core.EXT: defined using the host language. +core.ns.map((k,v) -> (repl_env.set(k, v))) +repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) +repl_env.set('*ARGV*, cmdline_args[1..]) + +;; core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))"); + +if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 + +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) + +--- env module ---------------------------------- +class Env (outer=null,binds=[],exprs=[]) + data = hash_map() + foreach b, i in binds: + if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break + else: data[binds[i]] = exprs[i] + set(k,v): return data.set(k,v) + find(k): return data.has(k) ? this : (if outer ? find(outer) : null) + get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" + +--- core module --------------------------------- +ns = {'=: equal?, + + 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), + 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), + 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), + 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), + 'read-string: read_str, + 'slurp read-file, + + '<: lt, + '<=: lte, + '>: gt, + '>=: gte, + '+: add, + '-: sub, + '*: mult, + '/: div, + + 'list: list, + 'list?: list?, + + 'cons: (a) -> concat([a[0]], a[1]), + 'concat: (a) -> reduce(concat, [], a), + 'vec: (l) -> l converted to vector, + 'nth: (a) -> a[0][a[1]] OR raise "nth: index out of range", + 'first: (a) -> a[0][0] OR nil, + 'rest: (a) -> a[0][1..] OR list(), + 'empty?: empty?, + 'count: count, + + 'atom: (a) -> new Atom(a[0]), + 'atom?: (a) -> type(a[0]) == "atom", + 'deref: (a) -> a[0].val, + 'reset!: (a) -> a[0].val = a[1], + 'swap!: swap!} diff --git a/process/step9_try.txt b/process/step9_try.txt index 35217b98ee..308f8ed4dc 100644 --- a/process/step9_try.txt +++ b/process/step9_try.txt @@ -1,129 +1,129 @@ ---- step9_try ----------------------------------- -import types, reader, printer, env, core - -READ(str): return reader.read_str(str) - -quasiquote(ast): return ... // quasiquote - -macro?(ast, env): return ... // true if macro call -macroexpand(ast, env): return ... // recursive macro expansion - -eval_ast(ast,env): - switch type(ast): - symbol: return env.get(ast) - list,vector: return ast.map((x) -> EVAL(x,env)) - hash: return ast.map((k,v) -> list(k, EVAL(v,env))) - _default_: return ast - -EVAL(ast,env): - while true: - if not list?(ast): return eval_ast(ast, env) - - ast = macroexpand(ast, env) - if not list?(ast): return eval_ast(ast, env) - if empty?(ast): return ast - - switch ast[0]: - 'def!: return env.set(ast[1], EVAL(ast[2], env)) - 'let*: env = ...; ast = ast[2] // TCO - 'quote: return ast[1] - 'quasiquote: ast = quasiquote(ast[1]) // TCO - 'defmacro!: return ... // like def!, but set macro property - 'macroexpand: return macroexpand(ast[1], env) - 'try*: return ... // try/catch native and malval exceptions - 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO - 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO - 'fn*: return new MalFunc(...) - _default_: f, args = eval_ast(ast, env) - if malfunc?(f): ast = f.fn; env = ... // TCO - else: return apply(f, args) - -PRINT(exp): return printer.pr_str(exp) - -repl_env = new Env() -rep(str): return PRINT(EVAL(READ(str),repl_env)) - -;; core.EXT: defined using the host language. -core.ns.map((k,v) -> (repl_env.set(k, v))) -repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) -repl_env.set('*ARGV*, cmdline_args[1..]) - -;; core.mal: defined using the language itself -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))"); - -if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 - -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) - ---- env module ---------------------------------- -class Env (outer=null,binds=[],exprs=[]) - data = hash_map() - foreach b, i in binds: - if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break - else: data[binds[i]] = exprs[i] - set(k,v): return data.set(k,v) - find(k): return data.has(k) ? this : (if outer ? find(outer) : null) - get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" - ---- core module --------------------------------- -ns = {'=: equal?, - 'throw: throw, - - 'nil?: nil?, - 'true?: true?, - 'false?: false?, - 'symbol: symbol, - 'symbol?: symbol?, - 'keyword: keyword, - 'keyword?: keyword?, - - 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), - 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), - 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), - 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), - 'read-string: read_str, - 'slurp read-file, - - '<: lt, - '<=: lte, - '>: gt, - '>=: gte, - '+: add, - '-: sub, - '*: mult, - '/: div, - - 'list: list, - 'list?: list?, - 'vector: vector, - 'vector?: vector?, - 'hash-map: hash_map, - 'map?: hash_map?, - 'assoc: assoc, - 'dissoc: dissoc, - 'get: get, - 'contains?: contains?, - 'keys: keys, - 'vals: vals, - - 'sequential? sequential?, - 'cons: (a) -> concat([a[0]], a[1]), - 'concat: (a) -> reduce(concat, [], a), - 'vec: (l) -> l converted to vector, - 'nth: (a) -> a[0][a[1]] OR raise "nth: index out of range", - 'first: (a) -> a[0][0] OR nil, - 'rest: (a) -> a[0][1..] OR list(), - 'empty?: empty?, - 'count: count, - 'apply: apply, - 'map: map, - - 'atom: (a) -> new Atom(a[0]), - 'atom?: (a) -> type(a[0]) == "atom", - 'deref: (a) -> a[0].val, - 'reset!: (a) -> a[0].val = a[1], - 'swap!: swap!} +--- step9_try ----------------------------------- +import types, reader, printer, env, core + +READ(str): return reader.read_str(str) + +quasiquote(ast): return ... // quasiquote + +macro?(ast, env): return ... // true if macro call +macroexpand(ast, env): return ... // recursive macro expansion + +eval_ast(ast,env): + switch type(ast): + symbol: return env.get(ast) + list,vector: return ast.map((x) -> EVAL(x,env)) + hash: return ast.map((k,v) -> list(k, EVAL(v,env))) + _default_: return ast + +EVAL(ast,env): + while true: + if not list?(ast): return eval_ast(ast, env) + + ast = macroexpand(ast, env) + if not list?(ast): return eval_ast(ast, env) + if empty?(ast): return ast + + switch ast[0]: + 'def!: return env.set(ast[1], EVAL(ast[2], env)) + 'let*: env = ...; ast = ast[2] // TCO + 'quote: return ast[1] + 'quasiquote: ast = quasiquote(ast[1]) // TCO + 'defmacro!: return ... // like def!, but set macro property + 'macroexpand: return macroexpand(ast[1], env) + 'try*: return ... // try/catch native and malval exceptions + 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO + 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO + 'fn*: return new MalFunc(...) + _default_: f, args = eval_ast(ast, env) + if malfunc?(f): ast = f.fn; env = ... // TCO + else: return apply(f, args) + +PRINT(exp): return printer.pr_str(exp) + +repl_env = new Env() +rep(str): return PRINT(EVAL(READ(str),repl_env)) + +;; core.EXT: defined using the host language. +core.ns.map((k,v) -> (repl_env.set(k, v))) +repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) +repl_env.set('*ARGV*, cmdline_args[1..]) + +;; core.mal: defined using the language itself +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))"); + +if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 + +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) + +--- env module ---------------------------------- +class Env (outer=null,binds=[],exprs=[]) + data = hash_map() + foreach b, i in binds: + if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break + else: data[binds[i]] = exprs[i] + set(k,v): return data.set(k,v) + find(k): return data.has(k) ? this : (if outer ? find(outer) : null) + get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" + +--- core module --------------------------------- +ns = {'=: equal?, + 'throw: throw, + + 'nil?: nil?, + 'true?: true?, + 'false?: false?, + 'symbol: symbol, + 'symbol?: symbol?, + 'keyword: keyword, + 'keyword?: keyword?, + + 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), + 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), + 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), + 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), + 'read-string: read_str, + 'slurp read-file, + + '<: lt, + '<=: lte, + '>: gt, + '>=: gte, + '+: add, + '-: sub, + '*: mult, + '/: div, + + 'list: list, + 'list?: list?, + 'vector: vector, + 'vector?: vector?, + 'hash-map: hash_map, + 'map?: hash_map?, + 'assoc: assoc, + 'dissoc: dissoc, + 'get: get, + 'contains?: contains?, + 'keys: keys, + 'vals: vals, + + 'sequential? sequential?, + 'cons: (a) -> concat([a[0]], a[1]), + 'concat: (a) -> reduce(concat, [], a), + 'vec: (l) -> l converted to vector, + 'nth: (a) -> a[0][a[1]] OR raise "nth: index out of range", + 'first: (a) -> a[0][0] OR nil, + 'rest: (a) -> a[0][1..] OR list(), + 'empty?: empty?, + 'count: count, + 'apply: apply, + 'map: map, + + 'atom: (a) -> new Atom(a[0]), + 'atom?: (a) -> type(a[0]) == "atom", + 'deref: (a) -> a[0].val, + 'reset!: (a) -> a[0].val = a[1], + 'swap!: swap!} diff --git a/process/stepA_mal.txt b/process/stepA_mal.txt index 1ea14698f8..fb0c11facd 100644 --- a/process/stepA_mal.txt +++ b/process/stepA_mal.txt @@ -1,142 +1,142 @@ ---- stepA_mal ------------------------------- -import types, reader, printer, env, core - -READ(str): return reader.read_str(str) - -quasiquote(ast): return ... // quasiquote - -macro?(ast, env): return ... // true if macro call -macroexpand(ast, env): return ... // recursive macro expansion - -eval_ast(ast,env): - switch type(ast): - symbol: return env.get(ast) - list,vector: return ast.map((x) -> EVAL(x,env)) - hash: return ast.map((k,v) -> list(k, EVAL(v,env))) - _default_: return ast - -EVAL(ast,env): - while true: - if not list?(ast): return eval_ast(ast, env) - - ast = macroexpand(ast, env) - if not list?(ast): return eval_ast(ast, env) - if empty?(ast): return ast - - switch ast[0]: - 'def!: return env.set(ast[1], EVAL(ast[2], env)) - 'let*: env = ...; ast = ast[2] // TCO - 'quote: return ast[1] - 'quasiquote: ast = quasiquote(ast[1]) // TCO - 'defmacro!: return ... // like def!, but set macro property - 'macroexpand: return macroexpand(ast[1], env) - 'try*: return ... // try/catch native and malval exceptions - 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO - 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO - 'fn*: return new MalFunc(...) - _default_: f, args = eval_ast(ast, env) - if malfunc?(f): ast = f.fn; env = ... // TCO - else: return apply(f, args) - -PRINT(exp): return printer.pr_str(exp) - -repl_env = new Env() -rep(str): return PRINT(EVAL(READ(str),repl_env)) - -;; core.EXT: defined using the host language. -core.ns.map((k,v) -> (repl_env.set(k, v))) -repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) -repl_env.set('*ARGV*, cmdline_args[1..]) - -;; core.mal: defined using the language itself -rep("(def! *host-language* \"...\")") -rep("(def! not (fn* (a) (if a false true)))") -rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") -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)))))))"); - -if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 - -rep("(println (str \"Mal [\" *host-language* \"]\"))") -main loop: - try: println(rep(readline("user> "))) - catch e: println("Error: ", e) - ---- env module ---------------------------------- -class Env (outer=null,binds=[],exprs=[]) - data = hash_map() - foreach b, i in binds: - if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break - else: data[binds[i]] = exprs[i] - set(k,v): return data.set(k,v) - find(k): return data.has(k) ? this : (if outer ? find(outer) : null) - get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" - ---- core module --------------------------------- -ns = {'=: equal?, - 'throw: throw, - - 'nil?: nil?, - 'true?: true?, - 'false?: false?, - 'string?: string?, - 'symbol: symbol, - 'symbol?: symbol?, - 'keyword: keyword, - 'keyword?: keyword?, - 'number?: number?, - 'fn?: fn?, - 'macro?: macro?, - - 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), - 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), - 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), - 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), - 'read-string: read_str, - 'readline: readline, - 'slurp read-file, - - '<: lt, - '<=: lte, - '>: gt, - '>=: gte, - '+: add, - '-: sub, - '*: mult, - '/: div, - 'time-ms cur-epoch-millis, - - 'list: list, - 'list?: list?, - 'vector: vector, - 'vector?: vector?, - 'hash-map: hash_map, - 'map?: hash_map?, - 'assoc: assoc, - 'dissoc: dissoc, - 'get: get, - 'contains?: contains?, - 'keys: keys, - 'vals: vals, - - 'sequential? sequential?, - 'cons: (a) -> concat([a[0]], a[1]), - 'concat: (a) -> reduce(concat, [], a), - 'vec: (l) -> l converted to vector, - 'nth: (a) -> a[0][a[1]] OR raise "nth: index out of range", - 'first: (a) -> a[0][0] OR nil, - 'rest: (a) -> a[0][1..] OR list(), - 'empty?: empty?, - 'count: count, - 'apply: apply, - 'map: map, - - 'conj: conj, - 'seq: seq, - - 'meta: (a) -> a[0].meta, - 'with-meta: (a) -> a[0].with_meta(a[1]), - 'atom: (a) -> new Atom(a[0]), - 'atom?: (a) -> type(a[0]) == "atom", - 'deref: (a) -> a[0].val, - 'reset!: (a) -> a[0].val = a[1], - 'swap!: swap!} +--- stepA_mal ------------------------------- +import types, reader, printer, env, core + +READ(str): return reader.read_str(str) + +quasiquote(ast): return ... // quasiquote + +macro?(ast, env): return ... // true if macro call +macroexpand(ast, env): return ... // recursive macro expansion + +eval_ast(ast,env): + switch type(ast): + symbol: return env.get(ast) + list,vector: return ast.map((x) -> EVAL(x,env)) + hash: return ast.map((k,v) -> list(k, EVAL(v,env))) + _default_: return ast + +EVAL(ast,env): + while true: + if not list?(ast): return eval_ast(ast, env) + + ast = macroexpand(ast, env) + if not list?(ast): return eval_ast(ast, env) + if empty?(ast): return ast + + switch ast[0]: + 'def!: return env.set(ast[1], EVAL(ast[2], env)) + 'let*: env = ...; ast = ast[2] // TCO + 'quote: return ast[1] + 'quasiquote: ast = quasiquote(ast[1]) // TCO + 'defmacro!: return ... // like def!, but set macro property + 'macroexpand: return macroexpand(ast[1], env) + 'try*: return ... // try/catch native and malval exceptions + 'do: ast = eval_ast(ast[1..-1], env)[-1] // TCO + 'if: EVAL(ast[1], env) ? ast = ast[2] : ast = ast[3] // TCO + 'fn*: return new MalFunc(...) + _default_: f, args = eval_ast(ast, env) + if malfunc?(f): ast = f.fn; env = ... // TCO + else: return apply(f, args) + +PRINT(exp): return printer.pr_str(exp) + +repl_env = new Env() +rep(str): return PRINT(EVAL(READ(str),repl_env)) + +;; core.EXT: defined using the host language. +core.ns.map((k,v) -> (repl_env.set(k, v))) +repl_env.set('eval, (ast) -> EVAL(ast, repl-env)) +repl_env.set('*ARGV*, cmdline_args[1..]) + +;; core.mal: defined using the language itself +rep("(def! *host-language* \"...\")") +rep("(def! not (fn* (a) (if a false true)))") +rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") +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)))))))"); + +if cmdline_args: rep("(load-file \"" + args[0] + "\")"); exit 0 + +rep("(println (str \"Mal [\" *host-language* \"]\"))") +main loop: + try: println(rep(readline("user> "))) + catch e: println("Error: ", e) + +--- env module ---------------------------------- +class Env (outer=null,binds=[],exprs=[]) + data = hash_map() + foreach b, i in binds: + if binds[i] == '&: data[binds[i+1]] = exprs.drop(i); break + else: data[binds[i]] = exprs[i] + set(k,v): return data.set(k,v) + find(k): return data.has(k) ? this : (if outer ? find(outer) : null) + get(k): return data.find(k).get(k) OR raise "'" + k + "' not found" + +--- core module --------------------------------- +ns = {'=: equal?, + 'throw: throw, + + 'nil?: nil?, + 'true?: true?, + 'false?: false?, + 'string?: string?, + 'symbol: symbol, + 'symbol?: symbol?, + 'keyword: keyword, + 'keyword?: keyword?, + 'number?: number?, + 'fn?: fn?, + 'macro?: macro?, + + 'pr-str: (a) -> a.map(|s| pr_str(e,true)).join(" ")), + 'str: (a) -> a.map(|s| pr_str(e,false)).join("")), + 'prn: (a) -> println(a.map(|s| pr_str(e,true)).join(" ")), + 'println: (a) -> println(a.map(|s| pr_str(e,false)).join(" ")), + 'read-string: read_str, + 'readline: readline, + 'slurp read-file, + + '<: lt, + '<=: lte, + '>: gt, + '>=: gte, + '+: add, + '-: sub, + '*: mult, + '/: div, + 'time-ms cur-epoch-millis, + + 'list: list, + 'list?: list?, + 'vector: vector, + 'vector?: vector?, + 'hash-map: hash_map, + 'map?: hash_map?, + 'assoc: assoc, + 'dissoc: dissoc, + 'get: get, + 'contains?: contains?, + 'keys: keys, + 'vals: vals, + + 'sequential? sequential?, + 'cons: (a) -> concat([a[0]], a[1]), + 'concat: (a) -> reduce(concat, [], a), + 'vec: (l) -> l converted to vector, + 'nth: (a) -> a[0][a[1]] OR raise "nth: index out of range", + 'first: (a) -> a[0][0] OR nil, + 'rest: (a) -> a[0][1..] OR list(), + 'empty?: empty?, + 'count: count, + 'apply: apply, + 'map: map, + + 'conj: conj, + 'seq: seq, + + 'meta: (a) -> a[0].meta, + 'with-meta: (a) -> a[0].with_meta(a[1]), + 'atom: (a) -> new Atom(a[0]), + 'atom?: (a) -> type(a[0]) == "atom", + 'deref: (a) -> a[0].val, + 'reset!: (a) -> a[0].val = a[1], + 'swap!: swap!} diff --git a/runtest.cmd b/runtest.cmd new file mode 100644 index 0000000000..c93b4cf524 --- /dev/null +++ b/runtest.cmd @@ -0,0 +1,22 @@ +@echo off +pushd "%~dp0" +rem goto p +for %%a in ( + step0_repl + step1_read_print + step2_eval + step3_env + step4_if_fn_do + step5_tco + step6_file + step7_quote + step8_macros + step9_try + stepA_mal +) do ( + echo @pushd "%%~dp0" ^& @cscript -nologo %%a.vbs > .\impls\vbs\run_%%a.cmd + python runtest.py --rundir "impls\vbs" --test-timeout 1800 --deferrable --optional --no-pty "..\tests\%%a.mal" "run_%%a.cmd" + del .\impls\vbs\run_%%a.cmd + rem pause +) +exit diff --git a/runtest.log b/runtest.log new file mode 100644 index 0000000000..a277ff95f2 --- /dev/null +++ b/runtest.log @@ -0,0 +1,1212 @@ +Testing basic string +TEST: 'abcABC123' -> ['',abcABC123] -> SUCCESS +Testing string containing spaces +TEST: 'hello mal world' -> ['',hello mal world] -> SUCCESS +Testing string containing symbols +TEST: '[]{}"\'* ;:()' -> ['',[]{}"'* ;:()] -> SUCCESS +Test long string +TEST: 'hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"\'* ;:() []{}"\'* ;:() []{}"\'*)' -> ['',hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*)] -> SUCCESS +Non alphanumeric characters +TEST: '!' -> ['',!] -> SUCCESS +TEST: '&' -> ['',&] -> SUCCESS +TEST: '+' -> ['',+] -> SUCCESS +TEST: ',' -> ['',,] -> SUCCESS +TEST: '-' -> ['',-] -> SUCCESS +TEST: '/' -> ['',/] -> SUCCESS +TEST: '<' -> ['',<] -> SUCCESS +TEST: '=' -> ['',=] -> SUCCESS +TEST: '>' -> ['',>] -> SUCCESS +TEST: '?' -> ['',?] -> SUCCESS +TEST: '@' -> ['',@] -> SUCCESS +TEST: '^' -> ['',^] -> SUCCESS +TEST: '_' -> ['',_] -> SUCCESS +TEST: '`' -> ['',`] -> SUCCESS +TEST: '~' -> ['',~] -> SUCCESS +------- Optional Functionality -------------- +------- (Not needed for self-hosting) ------- +Non alphanumeric characters +TEST: '#' -> ['',#] -> SUCCESS +TEST: '$' -> ['',$] -> SUCCESS +TEST: '%' -> ['',%] -> SUCCESS +TEST: '.' -> ['',.] -> SUCCESS +TEST: '|' -> ['',|] -> SUCCESS + +TEST RESULTS (for ..\tests\step0_repl.mal): + 0: soft failing tests + 0: failing tests + 24: passing tests + 24: total tests + +Testing read of numbers +TEST: '1' -> ['',1] -> SUCCESS +TEST: '7' -> ['',7] -> SUCCESS +TEST: ' 7 ' -> ['',7] -> SUCCESS +TEST: '-123' -> ['',-123] -> SUCCESS +Testing read of symbols +TEST: '+' -> ['',+] -> SUCCESS +TEST: 'abc' -> ['',abc] -> SUCCESS +TEST: ' abc ' -> ['',abc] -> SUCCESS +TEST: 'abc5' -> ['',abc5] -> SUCCESS +TEST: 'abc-def' -> ['',abc-def] -> SUCCESS +Testing non-numbers starting with a dash. +TEST: '-' -> ['',-] -> SUCCESS +TEST: '-abc' -> ['',-abc] -> SUCCESS +TEST: '->>' -> ['',->>] -> SUCCESS +Testing read of lists +TEST: '(+ 1 2)' -> ['',(+ 1 2)] -> SUCCESS +TEST: '()' -> ['',()] -> SUCCESS +TEST: '( )' -> ['',()] -> SUCCESS +TEST: '(nil)' -> ['',(nil)] -> SUCCESS +TEST: '((3 4))' -> ['',((3 4))] -> SUCCESS +TEST: '(+ 1 (+ 2 3))' -> ['',(+ 1 (+ 2 3))] -> SUCCESS +TEST: ' ( + 1 (+ 2 3 ) ) ' -> ['',(+ 1 (+ 2 3))] -> SUCCESS +TEST: '(* 1 2)' -> ['',(* 1 2)] -> SUCCESS +TEST: '(** 1 2)' -> ['',(** 1 2)] -> SUCCESS +TEST: '(* -3 6)' -> ['',(* -3 6)] -> SUCCESS +TEST: '(()())' -> ['',(() ())] -> SUCCESS +Test commas as whitespace +TEST: '(1 2, 3,,,,),,' -> ['',(1 2 3)] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing read of nil/true/false +TEST: 'nil' -> ['',nil] -> SUCCESS +TEST: 'true' -> ['',true] -> SUCCESS +TEST: 'false' -> ['',false] -> SUCCESS +Testing read of strings +TEST: '"abc"' -> ['',"abc"] -> SUCCESS +TEST: ' "abc" ' -> ['',"abc"] -> SUCCESS +TEST: '"abc (with parens)"' -> ['',"abc (with parens)"] -> SUCCESS +TEST: '"abc\\"def"' -> ['',"abc\"def"] -> SUCCESS +TEST: '""' -> ['',""] -> SUCCESS +TEST: '"\\\\"' -> ['',"\\"] -> SUCCESS +TEST: '"\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"' -> ['',"\\\\\\\\\\\\\\\\\\"] -> SUCCESS +TEST: '"&"' -> ['',"&"] -> SUCCESS +TEST: '"\'"' -> ['',"'"] -> SUCCESS +TEST: '"("' -> ['',"("] -> SUCCESS +TEST: '")"' -> ['',")"] -> SUCCESS +TEST: '"*"' -> ['',"*"] -> SUCCESS +TEST: '"+"' -> ['',"+"] -> SUCCESS +TEST: '","' -> ['',","] -> SUCCESS +TEST: '"-"' -> ['',"-"] -> SUCCESS +TEST: '"/"' -> ['',"/"] -> SUCCESS +TEST: '":"' -> ['',":"] -> SUCCESS +TEST: '";"' -> ['',";"] -> SUCCESS +TEST: '"<"' -> ['',"<"] -> SUCCESS +TEST: '"="' -> ['',"="] -> SUCCESS +TEST: '">"' -> ['',">"] -> SUCCESS +TEST: '"?"' -> ['',"?"] -> SUCCESS +TEST: '"@"' -> ['',"@"] -> SUCCESS +TEST: '"["' -> ['',"["] -> SUCCESS +TEST: '"]"' -> ['',"]"] -> SUCCESS +TEST: '"^"' -> ['',"^"] -> SUCCESS +TEST: '"_"' -> ['',"_"] -> SUCCESS +TEST: '"`"' -> ['',"`"] -> SUCCESS +TEST: '"{"' -> ['',"{"] -> SUCCESS +TEST: '"}"' -> ['',"}"] -> SUCCESS +TEST: '"~"' -> ['',"~"] -> SUCCESS +TEST: '"!"' -> ['',"!"] -> SUCCESS +Testing reader errors +TEST: '(1 2' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '[1 2' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '"abc' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '"' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '"\\"' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '"\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '(1 "abc' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '(1 "abc"' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +Testing read of quoting +TEST: "'1" -> ['',(quote 1)] -> SUCCESS +TEST: "'(1 2 3)" -> ['',(quote (1 2 3))] -> SUCCESS +TEST: '`1' -> ['',(quasiquote 1)] -> SUCCESS +TEST: '`(1 2 3)' -> ['',(quasiquote (1 2 3))] -> SUCCESS +TEST: '~1' -> ['',(unquote 1)] -> SUCCESS +TEST: '~(1 2 3)' -> ['',(unquote (1 2 3))] -> SUCCESS +TEST: '`(1 ~a 3)' -> ['',(quasiquote (1 (unquote a) 3))] -> SUCCESS +TEST: '~@(1 2 3)' -> ['',(splice-unquote (1 2 3))] -> SUCCESS +Testing keywords +TEST: ':kw' -> ['',:kw] -> SUCCESS +TEST: '(:kw1 :kw2 :kw3)' -> ['',(:kw1 :kw2 :kw3)] -> SUCCESS +Testing read of vectors +TEST: '[+ 1 2]' -> ['',[+ 1 2]] -> SUCCESS +TEST: '[]' -> ['',[]] -> SUCCESS +TEST: '[ ]' -> ['',[]] -> SUCCESS +TEST: '[[3 4]]' -> ['',[[3 4]]] -> SUCCESS +TEST: '[+ 1 [+ 2 3]]' -> ['',[+ 1 [+ 2 3]]] -> SUCCESS +TEST: ' [ + 1 [+ 2 3 ] ] ' -> ['',[+ 1 [+ 2 3]]] -> SUCCESS +TEST: '([])' -> ['',([])] -> SUCCESS +Testing read of hash maps +TEST: '{}' -> ['',{}] -> SUCCESS +TEST: '{ }' -> ['',{}] -> SUCCESS +TEST: '{"abc" 1}' -> ['',{"abc" 1}] -> SUCCESS +TEST: '{"a" {"b" 2}}' -> ['',{"a" {"b" 2}}] -> SUCCESS +TEST: '{"a" {"b" {"c" 3}}}' -> ['',{"a" {"b" {"c" 3}}}] -> SUCCESS +TEST: '{ "a" {"b" { "cde" 3 } }}' -> ['',{"a" {"b" {"cde" 3}}}] -> SUCCESS +TEST: '{"a1" 1 "a2" 2 "a3" 3}' -> ['{"a([1-3])" \\1 "a(?!\\1)([1-3])" \\2 "a(?!\\1)(?!\\2)([1-3])" \\3}',] -> SUCCESS +TEST: '{ :a {:b { :cde 3 } }}' -> ['',{:a {:b {:cde 3}}}] -> SUCCESS +TEST: '{"1" 1}' -> ['',{"1" 1}] -> SUCCESS +TEST: '({})' -> ['',({})] -> SUCCESS +Testing read of comments +TEST: ' ;; whole line comment (not an exception)' -> ['',] -> SUCCESS (result ignored) +TEST: '1 ; comment after expression' -> ['',1] -> SUCCESS +TEST: '1; comment after expression' -> ['',1] -> SUCCESS +Testing read of @/deref +TEST: '@a' -> ['',(deref a)] -> SUCCESS + +-------- Optional Functionality -------- +Testing read of ^/metadata +TEST: '^{"a" 1} [1 2 3]' -> ['',(with-meta [1 2 3] {"a" 1})] -> SUCCESS +Non alphanumerice characters in strings +TEST: '"\\n"' -> ['',"\n"] -> SUCCESS +TEST: '"#"' -> ['',"#"] -> SUCCESS +TEST: '"$"' -> ['',"$"] -> SUCCESS +TEST: '"%"' -> ['',"%"] -> SUCCESS +TEST: '"."' -> ['',"."] -> SUCCESS +TEST: '"\\\\"' -> ['',"\\"] -> SUCCESS +TEST: '"|"' -> ['',"|"] -> SUCCESS +Non alphanumeric characters in comments +TEST: '1;!' -> ['',1] -> SUCCESS +TEST: '1;"' -> ['',1] -> SUCCESS +TEST: '1;#' -> ['',1] -> SUCCESS +TEST: '1;$' -> ['',1] -> SUCCESS +TEST: '1;%' -> ['',1] -> SUCCESS +TEST: "1;'" -> ['',1] -> SUCCESS +TEST: '1;\\' -> ['',1] -> SUCCESS +TEST: '1;\\\\' -> ['',1] -> SUCCESS +TEST: '1;\\\\\\' -> ['',1] -> SUCCESS +TEST: '1;`' -> ['',1] -> SUCCESS +TEST: '1; &()*+,-./:;<=>?@[]^_{|}~' -> ['',1] -> SUCCESS + +TEST RESULTS (for ..\tests\step1_read_print.mal): + 0: soft failing tests + 0: failing tests + 117: passing tests + 117: total tests + +Testing evaluation of arithmetic operations +TEST: '(+ 1 2)' -> ['',3] -> SUCCESS +TEST: '(+ 5 (* 2 3))' -> ['',11] -> SUCCESS +TEST: '(- (+ 5 (* 2 3)) 3)' -> ['',8] -> SUCCESS +TEST: '(/ (- (+ 5 (* 2 3)) 3) 4)' -> ['',2] -> SUCCESS +TEST: '(/ (- (+ 515 (* 87 311)) 302) 27)' -> ['',1010] -> SUCCESS +TEST: '(* -3 6)' -> ['',-18] -> SUCCESS +TEST: '(/ (- (+ 515 (* -87 311)) 296) 27)' -> ['',-994] -> SUCCESS +TEST: '(abc 1 2 3)' -> ['.+',] -> SUCCESS +Testing empty list +TEST: '()' -> ['',()] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing evaluation within collection literals +TEST: '[1 2 (+ 1 2)]' -> ['',[1 2 3]] -> SUCCESS +TEST: '{"a" (+ 7 8)}' -> ['',{"a" 15}] -> SUCCESS +TEST: '{:a (+ 7 8)}' -> ['',{:a 15}] -> SUCCESS +Check that evaluation hasn't broken empty collections +TEST: '[]' -> ['',[]] -> SUCCESS +TEST: '{}' -> ['',{}] -> SUCCESS + +TEST RESULTS (for ..\tests\step2_eval.mal): + 0: soft failing tests + 0: failing tests + 14: passing tests + 14: total tests + +Testing REPL_ENV +TEST: '(+ 1 2)' -> ['',3] -> SUCCESS +TEST: '(/ (- (+ 5 (* 2 3)) 3) 4)' -> ['',2] -> SUCCESS +Testing def! +TEST: '(def! x 3)' -> ['',3] -> SUCCESS +TEST: 'x' -> ['',3] -> SUCCESS +TEST: '(def! x 4)' -> ['',4] -> SUCCESS +TEST: 'x' -> ['',4] -> SUCCESS +TEST: '(def! y (+ 1 7))' -> ['',8] -> SUCCESS +TEST: 'y' -> ['',8] -> SUCCESS +Verifying symbols are case-sensitive +TEST: '(def! mynum 111)' -> ['',111] -> SUCCESS +TEST: '(def! MYNUM 222)' -> ['',222] -> SUCCESS +TEST: 'mynum' -> ['',111] -> SUCCESS +TEST: 'MYNUM' -> ['',222] -> SUCCESS +Check env lookup non-fatal error +TEST: '(abc 1 2 3)' -> [".*\\'?abc\\'? not found.*",] -> SUCCESS +Check that error aborts def! +TEST: '(def! w 123)' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! w (abc))' -> ['',] -> SUCCESS (result ignored) +TEST: 'w' -> ['',123] -> SUCCESS +Testing let* +TEST: '(let* (z 9) z)' -> ['',9] -> SUCCESS +TEST: '(let* (x 9) x)' -> ['',9] -> SUCCESS +TEST: 'x' -> ['',4] -> SUCCESS +TEST: '(let* (z (+ 2 3)) (+ 1 z))' -> ['',6] -> SUCCESS +TEST: '(let* (p (+ 2 3) q (+ 2 p)) (+ p q))' -> ['',12] -> SUCCESS +TEST: '(def! y (let* (z 7) z))' -> ['',] -> SUCCESS (result ignored) +TEST: 'y' -> ['',7] -> SUCCESS +Testing outer environment +TEST: '(def! a 4)' -> ['',4] -> SUCCESS +TEST: '(let* (q 9) q)' -> ['',9] -> SUCCESS +TEST: '(let* (q 9) a)' -> ['',4] -> SUCCESS +TEST: '(let* (z 2) (let* (q 9) a))' -> ['',4] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing let* with vector bindings +TEST: '(let* [z 9] z)' -> ['',9] -> SUCCESS +TEST: '(let* [p (+ 2 3) q (+ 2 p)] (+ p q))' -> ['',12] -> SUCCESS +Testing vector evaluation +TEST: '(let* (a 5 b 6) [3 4 a [b 7] 8])' -> ['',[3 4 5 [6 7] 8]] -> SUCCESS + +-------- Optional Functionality -------- +Check that last assignment takes priority +TEST: '(let* (x 2 x 3) x)' -> ['',3] -> SUCCESS + +TEST RESULTS (for ..\tests\step3_env.mal): + 0: soft failing tests + 0: failing tests + 31: passing tests + 31: total tests + +----------------------------------------------------- +Testing list functions +TEST: '(list)' -> ['',()] -> SUCCESS +TEST: '(list? (list))' -> ['',true] -> SUCCESS +TEST: '(empty? (list))' -> ['',true] -> SUCCESS +TEST: '(empty? (list 1))' -> ['',false] -> SUCCESS +TEST: '(list 1 2 3)' -> ['',(1 2 3)] -> SUCCESS +TEST: '(count (list 1 2 3))' -> ['',3] -> SUCCESS +TEST: '(count (list))' -> ['',0] -> SUCCESS +TEST: '(count nil)' -> ['',0] -> SUCCESS +TEST: '(if (> (count (list 1 2 3)) 3) 89 78)' -> ['',78] -> SUCCESS +TEST: '(if (>= (count (list 1 2 3)) 3) 89 78)' -> ['',89] -> SUCCESS +Testing if form +TEST: '(if true 7 8)' -> ['',7] -> SUCCESS +TEST: '(if false 7 8)' -> ['',8] -> SUCCESS +TEST: '(if false 7 false)' -> ['',false] -> SUCCESS +TEST: '(if true (+ 1 7) (+ 1 8))' -> ['',8] -> SUCCESS +TEST: '(if false (+ 1 7) (+ 1 8))' -> ['',9] -> SUCCESS +TEST: '(if nil 7 8)' -> ['',8] -> SUCCESS +TEST: '(if 0 7 8)' -> ['',7] -> SUCCESS +TEST: '(if (list) 7 8)' -> ['',7] -> SUCCESS +TEST: '(if (list 1 2 3) 7 8)' -> ['',7] -> SUCCESS +TEST: '(= (list) nil)' -> ['',false] -> SUCCESS +Testing 1-way if form +TEST: '(if false (+ 1 7))' -> ['',nil] -> SUCCESS +TEST: '(if nil 8)' -> ['',nil] -> SUCCESS +TEST: '(if nil 8 7)' -> ['',7] -> SUCCESS +TEST: '(if true (+ 1 7))' -> ['',8] -> SUCCESS +Testing basic conditionals +TEST: '(= 2 1)' -> ['',false] -> SUCCESS +TEST: '(= 1 1)' -> ['',true] -> SUCCESS +TEST: '(= 1 2)' -> ['',false] -> SUCCESS +TEST: '(= 1 (+ 1 1))' -> ['',false] -> SUCCESS +TEST: '(= 2 (+ 1 1))' -> ['',true] -> SUCCESS +TEST: '(= nil 1)' -> ['',false] -> SUCCESS +TEST: '(= nil nil)' -> ['',true] -> SUCCESS +TEST: '(> 2 1)' -> ['',true] -> SUCCESS +TEST: '(> 1 1)' -> ['',false] -> SUCCESS +TEST: '(> 1 2)' -> ['',false] -> SUCCESS +TEST: '(>= 2 1)' -> ['',true] -> SUCCESS +TEST: '(>= 1 1)' -> ['',true] -> SUCCESS +TEST: '(>= 1 2)' -> ['',false] -> SUCCESS +TEST: '(< 2 1)' -> ['',false] -> SUCCESS +TEST: '(< 1 1)' -> ['',false] -> SUCCESS +TEST: '(< 1 2)' -> ['',true] -> SUCCESS +TEST: '(<= 2 1)' -> ['',false] -> SUCCESS +TEST: '(<= 1 1)' -> ['',true] -> SUCCESS +TEST: '(<= 1 2)' -> ['',true] -> SUCCESS +Testing equality +TEST: '(= 1 1)' -> ['',true] -> SUCCESS +TEST: '(= 0 0)' -> ['',true] -> SUCCESS +TEST: '(= 1 0)' -> ['',false] -> SUCCESS +TEST: '(= true true)' -> ['',true] -> SUCCESS +TEST: '(= false false)' -> ['',true] -> SUCCESS +TEST: '(= nil nil)' -> ['',true] -> SUCCESS +TEST: '(= (list) (list))' -> ['',true] -> SUCCESS +TEST: '(= (list) ())' -> ['',true] -> SUCCESS +TEST: '(= (list 1 2) (list 1 2))' -> ['',true] -> SUCCESS +TEST: '(= (list 1) (list))' -> ['',false] -> SUCCESS +TEST: '(= (list) (list 1))' -> ['',false] -> SUCCESS +TEST: '(= 0 (list))' -> ['',false] -> SUCCESS +TEST: '(= (list) 0)' -> ['',false] -> SUCCESS +TEST: '(= (list nil) (list))' -> ['',false] -> SUCCESS +Testing builtin and user defined functions +TEST: '(+ 1 2)' -> ['',3] -> SUCCESS +TEST: '( (fn* (a b) (+ b a)) 3 4)' -> ['',7] -> SUCCESS +TEST: '( (fn* () 4) )' -> ['',4] -> SUCCESS +TEST: '( (fn* (f x) (f x)) (fn* (a) (+ 1 a)) 7)' -> ['',8] -> SUCCESS +Testing closures +TEST: '( ( (fn* (a) (fn* (b) (+ a b))) 5) 7)' -> ['',12] -> SUCCESS +TEST: '(def! gen-plus5 (fn* () (fn* (b) (+ 5 b))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! plus5 (gen-plus5))' -> ['',] -> SUCCESS (result ignored) +TEST: '(plus5 7)' -> ['',12] -> SUCCESS +TEST: '(def! gen-plusX (fn* (x) (fn* (b) (+ x b))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! plus7 (gen-plusX 7))' -> ['',] -> SUCCESS (result ignored) +TEST: '(plus7 8)' -> ['',15] -> SUCCESS +Testing do form +TEST: '(do (prn 101))' -> ['101\n',nil] -> SUCCESS +TEST: '(do (prn 102) 7)' -> ['102\n',7] -> SUCCESS +TEST: '(do (prn 101) (prn 102) (+ 1 2))' -> ['101\n102\n',3] -> SUCCESS +TEST: '(do (def! a 6) 7 (+ a 8))' -> ['',14] -> SUCCESS +TEST: 'a' -> ['',6] -> SUCCESS +Testing special form case-sensitivity +TEST: '(def! DO (fn* (a) 7))' -> ['',] -> SUCCESS (result ignored) +TEST: '(DO 3)' -> ['',7] -> SUCCESS +Testing recursive sumdown function +TEST: '(def! sumdown (fn* (N) (if (> N 0) (+ N (sumdown (- N 1))) 0)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(sumdown 1)' -> ['',1] -> SUCCESS +TEST: '(sumdown 2)' -> ['',3] -> SUCCESS +TEST: '(sumdown 6)' -> ['',21] -> SUCCESS +Testing recursive fibonacci function +TEST: '(def! fib (fn* (N) (if (= N 0) 1 (if (= N 1) 1 (+ (fib (- N 1)) (fib (- N 2)))))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(fib 1)' -> ['',1] -> SUCCESS +TEST: '(fib 2)' -> ['',2] -> SUCCESS +TEST: '(fib 4)' -> ['',5] -> SUCCESS +Testing recursive function in environment. +TEST: '(let* (f (fn* () x) x 3) (f))' -> ['',3] -> SUCCESS +TEST: '(let* (cst (fn* (n) (if (= n 0) nil (cst (- n 1))))) (cst 1))' -> ['',nil] -> SUCCESS +TEST: '(let* (f (fn* (n) (if (= n 0) 0 (g (- n 1)))) g (fn* (n) (f n))) (f 2))' -> ['',0] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing if on strings +TEST: '(if "" 7 8)' -> ['',7] -> SUCCESS +Testing string equality +TEST: '(= "" "")' -> ['',true] -> SUCCESS +TEST: '(= "abc" "abc")' -> ['',true] -> SUCCESS +TEST: '(= "abc" "")' -> ['',false] -> SUCCESS +TEST: '(= "" "abc")' -> ['',false] -> SUCCESS +TEST: '(= "abc" "def")' -> ['',false] -> SUCCESS +TEST: '(= "abc" "ABC")' -> ['',false] -> SUCCESS +TEST: '(= (list) "")' -> ['',false] -> SUCCESS +TEST: '(= "" (list))' -> ['',false] -> SUCCESS +Testing variable length arguments +TEST: '( (fn* (& more) (count more)) 1 2 3)' -> ['',3] -> SUCCESS +TEST: '( (fn* (& more) (list? more)) 1 2 3)' -> ['',true] -> SUCCESS +TEST: '( (fn* (& more) (count more)) 1)' -> ['',1] -> SUCCESS +TEST: '( (fn* (& more) (count more)) )' -> ['',0] -> SUCCESS +TEST: '( (fn* (& more) (list? more)) )' -> ['',true] -> SUCCESS +TEST: '( (fn* (a & more) (count more)) 1 2 3)' -> ['',2] -> SUCCESS +TEST: '( (fn* (a & more) (count more)) 1)' -> ['',0] -> SUCCESS +TEST: '( (fn* (a & more) (list? more)) 1)' -> ['',true] -> SUCCESS +Testing language defined not function +TEST: '(not false)' -> ['',true] -> SUCCESS +TEST: '(not nil)' -> ['',true] -> SUCCESS +TEST: '(not true)' -> ['',false] -> SUCCESS +TEST: '(not "a")' -> ['',false] -> SUCCESS +TEST: '(not 0)' -> ['',false] -> SUCCESS +----------------------------------------------------- +Testing string quoting +TEST: '""' -> ['',""] -> SUCCESS +TEST: '"abc"' -> ['',"abc"] -> SUCCESS +TEST: '"abc def"' -> ['',"abc def"] -> SUCCESS +TEST: '"\\""' -> ['',"\""] -> SUCCESS +TEST: '"abc\\ndef\\nghi"' -> ['',"abc\ndef\nghi"] -> SUCCESS +TEST: '"abc\\\\def\\\\ghi"' -> ['',"abc\\def\\ghi"] -> SUCCESS +TEST: '"\\\\n"' -> ['',"\\n"] -> SUCCESS +Testing pr-str +TEST: '(pr-str)' -> ['',""] -> SUCCESS +TEST: '(pr-str "")' -> ['',"\"\""] -> SUCCESS +TEST: '(pr-str "abc")' -> ['',"\"abc\""] -> SUCCESS +TEST: '(pr-str "abc def" "ghi jkl")' -> ['',"\"abc def\" \"ghi jkl\""] -> SUCCESS +TEST: '(pr-str "\\"")' -> ['',"\"\\\"\""] -> SUCCESS +TEST: '(pr-str (list 1 2 "abc" "\\"") "def")' -> ['',"(1 2 \"abc\" \"\\\"\") \"def\""] -> SUCCESS +TEST: '(pr-str "abc\\ndef\\nghi")' -> ['',"\"abc\\ndef\\nghi\""] -> SUCCESS +TEST: '(pr-str "abc\\\\def\\\\ghi")' -> ['',"\"abc\\\\def\\\\ghi\""] -> SUCCESS +TEST: '(pr-str (list))' -> ['',"()"] -> SUCCESS +Testing str +TEST: '(str)' -> ['',""] -> SUCCESS +TEST: '(str "")' -> ['',""] -> SUCCESS +TEST: '(str "abc")' -> ['',"abc"] -> SUCCESS +TEST: '(str "\\"")' -> ['',"\""] -> SUCCESS +TEST: '(str 1 "abc" 3)' -> ['',"1abc3"] -> SUCCESS +TEST: '(str "abc def" "ghi jkl")' -> ['',"abc defghi jkl"] -> SUCCESS +TEST: '(str "abc\\ndef\\nghi")' -> ['',"abc\ndef\nghi"] -> SUCCESS +TEST: '(str "abc\\\\def\\\\ghi")' -> ['',"abc\\def\\ghi"] -> SUCCESS +TEST: '(str (list 1 2 "abc" "\\"") "def")' -> ['',"(1 2 abc \")def"] -> SUCCESS +TEST: '(str (list))' -> ['',"()"] -> SUCCESS +Testing prn +TEST: '(prn)' -> ['\n',nil] -> SUCCESS +TEST: '(prn "")' -> ['""\n',nil] -> SUCCESS +TEST: '(prn "abc")' -> ['"abc"\n',nil] -> SUCCESS +TEST: '(prn "abc def" "ghi jkl")' -> ['"abc def" "ghi jkl"',] -> SUCCESS +TEST: '(prn "\\"")' -> ['"\\\\""\n',nil] -> SUCCESS +TEST: '(prn "abc\\ndef\\nghi")' -> ['"abc\\\\ndef\\\\nghi"\n',nil] -> SUCCESS +TEST: '(prn "abc\\\\def\\\\ghi")' -> ['"abc\\\\\\\\def\\\\\\\\ghi"',] -> SUCCESS +TEST: 'nil' -> ['',] -> SUCCESS (result ignored) +TEST: '(prn (list 1 2 "abc" "\\"") "def")' -> ['\\(1 2 "abc" "\\\\""\\) "def"\n',nil] -> SUCCESS +Testing println +TEST: '(println)' -> ['\n',nil] -> SUCCESS +TEST: '(println "")' -> ['\n',nil] -> SUCCESS +TEST: '(println "abc")' -> ['abc\n',nil] -> SUCCESS +TEST: '(println "abc def" "ghi jkl")' -> ['abc def ghi jkl',] -> SUCCESS +TEST: '(println "\\"")' -> ['"\n',nil] -> SUCCESS +TEST: '(println "abc\\ndef\\nghi")' -> ['abc\ndef\nghi\n',nil] -> SUCCESS +TEST: '(println "abc\\\\def\\\\ghi")' -> ['abc\\\\def\\\\ghi\n',nil] -> SUCCESS +TEST: '(println (list 1 2 "abc" "\\"") "def")' -> ['\\(1 2 abc "\\) def\n',nil] -> SUCCESS +Testing keywords +TEST: '(= :abc :abc)' -> ['',true] -> SUCCESS +TEST: '(= :abc :def)' -> ['',false] -> SUCCESS +TEST: '(= :abc ":abc")' -> ['',false] -> SUCCESS +TEST: '(= (list :abc) (list :abc))' -> ['',true] -> SUCCESS +Testing vector truthiness +TEST: '(if [] 7 8)' -> ['',7] -> SUCCESS +Testing vector printing +TEST: '(pr-str [1 2 "abc" "\\""] "def")' -> ['',"[1 2 \"abc\" \"\\\"\"] \"def\""] -> SUCCESS +TEST: '(pr-str [])' -> ['',"[]"] -> SUCCESS +TEST: '(str [1 2 "abc" "\\""] "def")' -> ['',"[1 2 abc \"]def"] -> SUCCESS +TEST: '(str [])' -> ['',"[]"] -> SUCCESS +Testing vector functions +TEST: '(count [1 2 3])' -> ['',3] -> SUCCESS +TEST: '(empty? [1 2 3])' -> ['',false] -> SUCCESS +TEST: '(empty? [])' -> ['',true] -> SUCCESS +TEST: '(list? [4 5 6])' -> ['',false] -> SUCCESS +Testing vector equality +TEST: '(= [] (list))' -> ['',true] -> SUCCESS +TEST: '(= [7 8] [7 8])' -> ['',true] -> SUCCESS +TEST: '(= [:abc] [:abc])' -> ['',true] -> SUCCESS +TEST: '(= (list 1 2) [1 2])' -> ['',true] -> SUCCESS +TEST: '(= (list 1) [])' -> ['',false] -> SUCCESS +TEST: '(= [] [1])' -> ['',false] -> SUCCESS +TEST: '(= 0 [])' -> ['',false] -> SUCCESS +TEST: '(= [] 0)' -> ['',false] -> SUCCESS +TEST: '(= [] "")' -> ['',false] -> SUCCESS +TEST: '(= "" [])' -> ['',false] -> SUCCESS +Testing vector parameter lists +TEST: '( (fn* [] 4) )' -> ['',4] -> SUCCESS +TEST: '( (fn* [f x] (f x)) (fn* [a] (+ 1 a)) 7)' -> ['',8] -> SUCCESS +Nested vector/list equality +TEST: '(= [(list)] (list []))' -> ['',true] -> SUCCESS +TEST: '(= [1 2 (list 3 4 [5 6])] (list 1 2 [3 4 (list 5 6)]))' -> ['',true] -> SUCCESS + +TEST RESULTS (for ..\tests\step4_if_fn_do.mal): + 0: soft failing tests + 0: failing tests + 178: passing tests + 178: total tests + +Testing recursive tail-call function +TEST: '(def! sum2 (fn* (n acc) (if (= n 0) acc (sum2 (- n 1) (+ n acc)))))' -> ['',] -> SUCCESS (result ignored) +TODO: test let*, and do for TCO +TEST: '(sum2 10 0)' -> ['',55] -> SUCCESS +TEST: '(def! res2 nil)' -> ['',nil] -> SUCCESS +TEST: '(def! res2 (sum2 10000 0))' -> ['',] -> SUCCESS (result ignored) +TEST: 'res2' -> ['',50005000] -> SUCCESS +Test mutually recursive tail-call functions +TEST: '(def! foo (fn* (n) (if (= n 0) 0 (bar (- n 1)))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! bar (fn* (n) (if (= n 0) 0 (foo (- n 1)))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(foo 10000)' -> ['',0] -> SUCCESS + +TEST RESULTS (for ..\tests\step5_tco.mal): + 0: soft failing tests + 0: failing tests + 8: passing tests + 8: total tests + + +Testing that (do (do)) not broken by TCO +TEST: '(do (do 1 2))' -> ['',2] -> SUCCESS + +Testing read-string, eval and slurp +TEST: '(read-string "(1 2 (3 4) nil)")' -> ['',(1 2 (3 4) nil)] -> SUCCESS +TEST: '(= nil (read-string "nil"))' -> ['',true] -> SUCCESS +TEST: '(read-string "(+ 2 3)")' -> ['',(+ 2 3)] -> SUCCESS +TEST: '(read-string "\\"\\n\\"")' -> ['',"\n"] -> SUCCESS +TEST: '(read-string "7 ;; comment")' -> ['',7] -> SUCCESS +TEST: '(read-string ";; comment")' -> ['',] -> SUCCESS (result ignored) +TEST: '(eval (read-string "(+ 2 3)"))' -> ['',5] -> SUCCESS +TEST: '(slurp "../tests/test.txt")' -> ['',"A line of text\n"] -> SUCCESS +TEST: '(slurp "../tests/test.txt")' -> ['',"A line of text\n"] -> SUCCESS +Testing load-file +TEST: '(load-file "../tests/inc.mal")' -> ['',nil] -> SUCCESS +TEST: '(inc1 7)' -> ['',8] -> SUCCESS +TEST: '(inc2 7)' -> ['',9] -> SUCCESS +TEST: '(inc3 9)' -> ['',12] -> SUCCESS + +Testing atoms +TEST: '(def! inc3 (fn* (a) (+ 3 a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! a (atom 2))' -> ['',(atom 2)] -> SUCCESS +TEST: '(atom? a)' -> ['',true] -> SUCCESS +TEST: '(atom? 1)' -> ['',false] -> SUCCESS +TEST: '(deref a)' -> ['',2] -> SUCCESS +TEST: '(reset! a 3)' -> ['',3] -> SUCCESS +TEST: '(deref a)' -> ['',3] -> SUCCESS +TEST: '(swap! a inc3)' -> ['',6] -> SUCCESS +TEST: '(deref a)' -> ['',6] -> SUCCESS +TEST: '(swap! a (fn* (a) a))' -> ['',6] -> SUCCESS +TEST: '(swap! a (fn* (a) (* 2 a)))' -> ['',12] -> SUCCESS +TEST: '(swap! a (fn* (a b) (* a b)) 10)' -> ['',120] -> SUCCESS +TEST: '(swap! a + 3)' -> ['',123] -> SUCCESS +Testing swap!/closure interaction +TEST: '(def! inc-it (fn* (a) (+ 1 a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! atm (atom 7))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! f (fn* () (swap! atm inc-it)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(f)' -> ['',8] -> SUCCESS +TEST: '(f)' -> ['',9] -> SUCCESS +Testing whether closures can retain atoms +TEST: '(def! g (let* (atm (atom 0)) (fn* () (deref atm))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! atm (atom 1))' -> ['',] -> SUCCESS (result ignored) +TEST: '(g)' -> ['',0] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing reading of large files +TEST: '(load-file "../tests/computations.mal")' -> ['',nil] -> SUCCESS +TEST: '(sumdown 2)' -> ['',3] -> SUCCESS +TEST: '(fib 2)' -> ['',1] -> SUCCESS +Testing `@` reader macro (short for `deref`) +TEST: '(def! atm (atom 9))' -> ['',] -> SUCCESS (result ignored) +TEST: '@atm' -> ['',9] -> SUCCESS +Testing that vector params not broken by TCO +TEST: '(def! g (fn* [] 78))' -> ['',] -> SUCCESS (result ignored) +TEST: '(g)' -> ['',78] -> SUCCESS +TEST: '(def! g (fn* [a] (+ a 78)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(g 3)' -> ['',81] -> SUCCESS + +Testing that *ARGV* exists and is an empty list +TEST: '(list? *ARGV*)' -> ['',true] -> SUCCESS +TEST: '*ARGV*' -> ['',()] -> SUCCESS + +Testing that eval sets aa in root scope, and that it is found in nested scope +TEST: '(let* (b 12) (do (eval (read-string "(def! aa 7)")) aa ))' -> ['',7] -> SUCCESS + +-------- Optional Functionality -------- +Testing comments in a file +TEST: '(load-file "../tests/incB.mal")' -> ['',nil] -> SUCCESS +TEST: '(inc4 7)' -> ['',11] -> SUCCESS +TEST: '(inc5 7)' -> ['',12] -> SUCCESS +Testing map literal across multiple lines in a file +TEST: '(load-file "../tests/incC.mal")' -> ['',nil] -> SUCCESS +TEST: 'mymap' -> ['',{"a" 1}] -> SUCCESS +Checking that eval does not use local environments. +TEST: '(def! a 1)' -> ['',1] -> SUCCESS +TEST: '(let* (a 2) (eval (read-string "a")))' -> ['',1] -> SUCCESS +Non alphanumeric characters in comments in read-string +TEST: '(read-string "1;!")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\\"")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;#")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;$")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;%")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\'")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\\\\")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\\\\\\\\")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\\\\\\\\\\\\")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;`")' -> ['',1] -> SUCCESS +TEST: '(read-string "1; &()*+,-./:;<=>?@[]^_{|}~")' -> ['',1] -> SUCCESS + +TEST RESULTS (for ..\tests\step6_file.mal): + 0: soft failing tests + 0: failing tests + 65: passing tests + 65: total tests + +Testing cons function +TEST: '(cons 1 (list))' -> ['',(1)] -> SUCCESS +TEST: '(cons 1 (list 2))' -> ['',(1 2)] -> SUCCESS +TEST: '(cons 1 (list 2 3))' -> ['',(1 2 3)] -> SUCCESS +TEST: '(cons (list 1) (list 2 3))' -> ['',((1) 2 3)] -> SUCCESS +TEST: '(def! a (list 2 3))' -> ['',] -> SUCCESS (result ignored) +TEST: '(cons 1 a)' -> ['',(1 2 3)] -> SUCCESS +TEST: 'a' -> ['',(2 3)] -> SUCCESS +Testing concat function +TEST: '(concat)' -> ['',()] -> SUCCESS +TEST: '(concat (list 1 2))' -> ['',(1 2)] -> SUCCESS +TEST: '(concat (list 1 2) (list 3 4))' -> ['',(1 2 3 4)] -> SUCCESS +TEST: '(concat (list 1 2) (list 3 4) (list 5 6))' -> ['',(1 2 3 4 5 6)] -> SUCCESS +TEST: '(concat (concat))' -> ['',()] -> SUCCESS +TEST: '(concat (list) (list))' -> ['',()] -> SUCCESS +TEST: '(= () (concat))' -> ['',true] -> SUCCESS +TEST: '(def! a (list 1 2))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! b (list 3 4))' -> ['',] -> SUCCESS (result ignored) +TEST: '(concat a b (list 5 6))' -> ['',(1 2 3 4 5 6)] -> SUCCESS +TEST: 'a' -> ['',(1 2)] -> SUCCESS +TEST: 'b' -> ['',(3 4)] -> SUCCESS +Testing regular quote +TEST: '(quote 7)' -> ['',7] -> SUCCESS +TEST: '(quote (1 2 3))' -> ['',(1 2 3)] -> SUCCESS +TEST: '(quote (1 2 (3 4)))' -> ['',(1 2 (3 4))] -> SUCCESS +Testing simple quasiquote +TEST: '(quasiquote nil)' -> ['',nil] -> SUCCESS +TEST: '(quasiquote 7)' -> ['',7] -> SUCCESS +TEST: '(quasiquote a)' -> ['',a] -> SUCCESS +TEST: '(quasiquote {"a" b})' -> ['',{"a" b}] -> SUCCESS +Testing quasiquote with lists +TEST: '(quasiquote ())' -> ['',()] -> SUCCESS +TEST: '(quasiquote (1 2 3))' -> ['',(1 2 3)] -> SUCCESS +TEST: '(quasiquote (a))' -> ['',(a)] -> SUCCESS +TEST: '(quasiquote (1 2 (3 4)))' -> ['',(1 2 (3 4))] -> SUCCESS +TEST: '(quasiquote (nil))' -> ['',(nil)] -> SUCCESS +TEST: '(quasiquote (1 ()))' -> ['',(1 ())] -> SUCCESS +TEST: '(quasiquote (() 1))' -> ['',(() 1)] -> SUCCESS +TEST: '(quasiquote (1 () 2))' -> ['',(1 () 2)] -> SUCCESS +TEST: '(quasiquote (()))' -> ['',(())] -> SUCCESS +(quasiquote (f () g (h) i (j k) l)) +=>(f () g (h) i (j k) l) +Testing unquote +TEST: '(quasiquote (unquote 7))' -> ['',7] -> SUCCESS +TEST: '(def! a 8)' -> ['',8] -> SUCCESS +TEST: '(quasiquote a)' -> ['',a] -> SUCCESS +TEST: '(quasiquote (unquote a))' -> ['',8] -> SUCCESS +TEST: '(quasiquote (1 a 3))' -> ['',(1 a 3)] -> SUCCESS +TEST: '(quasiquote (1 (unquote a) 3))' -> ['',(1 8 3)] -> SUCCESS +TEST: '(def! b (quote (1 "b" "d")))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '(quasiquote (1 b 3))' -> ['',(1 b 3)] -> SUCCESS +TEST: '(quasiquote (1 (unquote b) 3))' -> ['',(1 (1 "b" "d") 3)] -> SUCCESS +TEST: '(quasiquote ((unquote 1) (unquote 2)))' -> ['',(1 2)] -> SUCCESS +Quasiquote and environments +TEST: '(let* (x 0) (quasiquote (unquote x)))' -> ['',0] -> SUCCESS +Testing splice-unquote +TEST: '(def! c (quote (1 "b" "d")))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '(quasiquote (1 c 3))' -> ['',(1 c 3)] -> SUCCESS +TEST: '(quasiquote (1 (splice-unquote c) 3))' -> ['',(1 1 "b" "d" 3)] -> SUCCESS +TEST: '(quasiquote (1 (splice-unquote c)))' -> ['',(1 1 "b" "d")] -> SUCCESS +TEST: '(quasiquote ((splice-unquote c) 2))' -> ['',(1 "b" "d" 2)] -> SUCCESS +TEST: '(quasiquote ((splice-unquote c) (splice-unquote c)))' -> ['',(1 "b" "d" 1 "b" "d")] -> SUCCESS +Testing symbol equality +TEST: '(= (quote abc) (quote abc))' -> ['',true] -> SUCCESS +TEST: '(= (quote abc) (quote abcd))' -> ['',false] -> SUCCESS +TEST: '(= (quote abc) "abc")' -> ['',false] -> SUCCESS +TEST: '(= "abc" (quote abc))' -> ['',false] -> SUCCESS +TEST: '(= "abc" (str (quote abc)))' -> ['',true] -> SUCCESS +TEST: '(= (quote abc) nil)' -> ['',false] -> SUCCESS +TEST: '(= nil (quote abc))' -> ['',false] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing ' (quote) reader macro +TEST: "'7" -> ['',7] -> SUCCESS +TEST: "'(1 2 3)" -> ['',(1 2 3)] -> SUCCESS +TEST: "'(1 2 (3 4))" -> ['',(1 2 (3 4))] -> SUCCESS +Testing cons and concat with vectors +TEST: '(cons 1 [])' -> ['',(1)] -> SUCCESS +TEST: '(cons [1] [2 3])' -> ['',([1] 2 3)] -> SUCCESS +TEST: '(cons 1 [2 3])' -> ['',(1 2 3)] -> SUCCESS +TEST: '(concat [1 2] (list 3 4) [5 6])' -> ['',(1 2 3 4 5 6)] -> SUCCESS +TEST: '(concat [1 2])' -> ['',(1 2)] -> SUCCESS + +-------- Optional Functionality -------- +Testing ` (quasiquote) reader macro +TEST: '`7' -> ['',7] -> SUCCESS +TEST: '`(1 2 3)' -> ['',(1 2 3)] -> SUCCESS +TEST: '`(1 2 (3 4))' -> ['',(1 2 (3 4))] -> SUCCESS +TEST: '`(nil)' -> ['',(nil)] -> SUCCESS +Testing ~ (unquote) reader macro +TEST: '`~7' -> ['',7] -> SUCCESS +TEST: '(def! a 8)' -> ['',8] -> SUCCESS +TEST: '`(1 ~a 3)' -> ['',(1 8 3)] -> SUCCESS +TEST: '(def! b \'(1 "b" "d"))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '`(1 b 3)' -> ['',(1 b 3)] -> SUCCESS +TEST: '`(1 ~b 3)' -> ['',(1 (1 "b" "d") 3)] -> SUCCESS +Testing ~@ (splice-unquote) reader macro +TEST: '(def! c \'(1 "b" "d"))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '`(1 c 3)' -> ['',(1 c 3)] -> SUCCESS +TEST: '`(1 ~@c 3)' -> ['',(1 1 "b" "d" 3)] -> SUCCESS +Testing vec function +TEST: '(vec (list))' -> ['',[]] -> SUCCESS +TEST: '(vec (list 1))' -> ['',[1]] -> SUCCESS +TEST: '(vec (list 1 2))' -> ['',[1 2]] -> SUCCESS +TEST: '(vec [])' -> ['',[]] -> SUCCESS +TEST: '(vec [1 2])' -> ['',[1 2]] -> SUCCESS +Testing that vec does not mutate the original list +TEST: '(def! a (list 1 2))' -> ['',] -> SUCCESS (result ignored) +TEST: '(vec a)' -> ['',[1 2]] -> SUCCESS +TEST: 'a' -> ['',(1 2)] -> SUCCESS +Test quine +TEST: '((fn* (q) (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* (q) (quasiquote ((unquote q) (quote (unquote q)))))))' -> ['',((fn* (q) (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* (q) (quasiquote ((unquote q) (quote (unquote q)))))))] -> SUCCESS +Testing quasiquote with vectors +TEST: '(quasiquote [])' -> ['',[]] -> SUCCESS +TEST: '(quasiquote [[]])' -> ['',[[]]] -> SUCCESS +TEST: '(quasiquote [()])' -> ['',[()]] -> SUCCESS +TEST: '(quasiquote ([]))' -> ['',([])] -> SUCCESS +TEST: '(def! a 8)' -> ['',8] -> SUCCESS +TEST: '`[1 a 3]' -> ['',[1 a 3]] -> SUCCESS +TEST: '(quasiquote [a [] b [c] d [e f] g])' -> ['',[a [] b [c] d [e f] g]] -> SUCCESS +Testing unquote with vectors +TEST: '`[~a]' -> ['',[8]] -> SUCCESS +TEST: '`[(~a)]' -> ['',[(8)]] -> SUCCESS +TEST: '`([~a])' -> ['',([8])] -> SUCCESS +TEST: '`[a ~a a]' -> ['',[a 8 a]] -> SUCCESS +TEST: '`([a ~a a])' -> ['',([a 8 a])] -> SUCCESS +TEST: '`[(a ~a a)]' -> ['',[(a 8 a)]] -> SUCCESS +Testing splice-unquote with vectors +TEST: '(def! c \'(1 "b" "d"))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '`[~@c]' -> ['',[1 "b" "d"]] -> SUCCESS +TEST: '`[(~@c)]' -> ['',[(1 "b" "d")]] -> SUCCESS +TEST: '`([~@c])' -> ['',([1 "b" "d"])] -> SUCCESS +TEST: '`[1 ~@c 3]' -> ['',[1 1 "b" "d" 3]] -> SUCCESS +TEST: '`([1 ~@c 3])' -> ['',([1 1 "b" "d" 3])] -> SUCCESS +TEST: '`[(1 ~@c 3)]' -> ['',[(1 1 "b" "d" 3)]] -> SUCCESS +Misplaced unquote or splice-unquote +TEST: '`(0 unquote)' -> ['',(0 unquote)] -> SUCCESS +TEST: '`(0 splice-unquote)' -> ['',(0 splice-unquote)] -> SUCCESS +TEST: '`[unquote 0]' -> ['',[unquote 0]] -> SUCCESS +TEST: '`[splice-unquote 0]' -> ['',[splice-unquote 0]] -> SUCCESS +Debugging quasiquote +TEST: '(quasiquoteexpand nil)' -> ['',nil] -> SUCCESS +TEST: '(quasiquoteexpand 7)' -> ['',7] -> SUCCESS +TEST: '(quasiquoteexpand a)' -> ['',(quote a)] -> SUCCESS +TEST: '(quasiquoteexpand {"a" b})' -> ['',(quote {"a" b})] -> SUCCESS +TEST: '(quasiquoteexpand ())' -> ['',()] -> SUCCESS +TEST: '(quasiquoteexpand (1 2 3))' -> ['',(cons 1 (cons 2 (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (a))' -> ['',(cons (quote a) ())] -> SUCCESS +TEST: '(quasiquoteexpand (1 2 (3 4)))' -> ['',(cons 1 (cons 2 (cons (cons 3 (cons 4 ())) ())))] -> SUCCESS +TEST: '(quasiquoteexpand (nil))' -> ['',(cons nil ())] -> SUCCESS +TEST: '(quasiquoteexpand (1 ()))' -> ['',(cons 1 (cons () ()))] -> SUCCESS +TEST: '(quasiquoteexpand (() 1))' -> ['',(cons () (cons 1 ()))] -> SUCCESS +TEST: '(quasiquoteexpand (1 () 2))' -> ['',(cons 1 (cons () (cons 2 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (()))' -> ['',(cons () ())] -> SUCCESS +TEST: '(quasiquoteexpand (f () g (h) i (j k) l))' -> ['',(cons (quote f) (cons () (cons (quote g) (cons (cons (quote h) ()) (cons (quote i) (cons (cons (quote j) (cons (quote k) ())) (cons (quote l) ())))))))] -> SUCCESS +TEST: '(quasiquoteexpand (unquote 7))' -> ['',7] -> SUCCESS +TEST: '(quasiquoteexpand a)' -> ['',(quote a)] -> SUCCESS +TEST: '(quasiquoteexpand (unquote a))' -> ['',a] -> SUCCESS +TEST: '(quasiquoteexpand (1 a 3))' -> ['',(cons 1 (cons (quote a) (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 (unquote a) 3))' -> ['',(cons 1 (cons a (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 b 3))' -> ['',(cons 1 (cons (quote b) (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 (unquote b) 3))' -> ['',(cons 1 (cons b (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand ((unquote 1) (unquote 2)))' -> ['',(cons 1 (cons 2 ()))] -> SUCCESS +TEST: '(quasiquoteexpand (a (splice-unquote (b c)) d))' -> ['',(cons (quote a) (concat (b c) (cons (quote d) ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 c 3))' -> ['',(cons 1 (cons (quote c) (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 (splice-unquote c) 3))' -> ['',(cons 1 (concat c (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 (splice-unquote c)))' -> ['',(cons 1 (concat c ()))] -> SUCCESS +TEST: '(quasiquoteexpand ((splice-unquote c) 2))' -> ['',(concat c (cons 2 ()))] -> SUCCESS +TEST: '(quasiquoteexpand ((splice-unquote c) (splice-unquote c)))' -> ['',(concat c (concat c ()))] -> SUCCESS +TEST: '(quasiquoteexpand [])' -> ['',(vec ())] -> SUCCESS +TEST: '(quasiquoteexpand [[]])' -> ['',(vec (cons (vec ()) ()))] -> SUCCESS +TEST: '(quasiquoteexpand [()])' -> ['',(vec (cons () ()))] -> SUCCESS +TEST: '(quasiquoteexpand ([]))' -> ['',(cons (vec ()) ())] -> SUCCESS +TEST: '(quasiquoteexpand [1 a 3])' -> ['',(vec (cons 1 (cons (quote a) (cons 3 ()))))] -> SUCCESS +TEST: '(quasiquoteexpand [a [] b [c] d [e f] g])' -> ['',(vec (cons (quote a) (cons (vec ()) (cons (quote b) (cons (vec (cons (quote c) ())) (cons (quote d) (cons (vec (cons (quote e) (cons (quote f) ()))) (cons (quote g) ()))))))))] -> SUCCESS + +TEST RESULTS (for ..\tests\step7_quote.mal): + 0: soft failing tests + 0: failing tests + 147: passing tests + 147: total tests + +Testing trivial macros +TEST: '(defmacro! one (fn* () 1))' -> ['',] -> SUCCESS (result ignored) +TEST: '(one)' -> ['',1] -> SUCCESS +TEST: '(defmacro! two (fn* () 2))' -> ['',] -> SUCCESS (result ignored) +TEST: '(two)' -> ['',2] -> SUCCESS +Testing unless macros +TEST: '(defmacro! unless (fn* (pred a b) `(if ~pred ~b ~a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(unless false 7 8)' -> ['',7] -> SUCCESS +TEST: '(unless true 7 8)' -> ['',8] -> SUCCESS +TEST: "(defmacro! unless2 (fn* (pred a b) (list 'if (list 'not pred) a b)))" -> ['',] -> SUCCESS (result ignored) +TEST: '(unless2 false 7 8)' -> ['',7] -> SUCCESS +TEST: '(unless2 true 7 8)' -> ['',8] -> SUCCESS +Testing macroexpand +TEST: '(macroexpand (one))' -> ['',1] -> SUCCESS +TEST: '(macroexpand (unless PRED A B))' -> ['',(if PRED B A)] -> SUCCESS +TEST: '(macroexpand (unless2 PRED A B))' -> ['',(if (not PRED) A B)] -> SUCCESS +TEST: '(macroexpand (unless2 2 3 4))' -> ['',(if (not 2) 3 4)] -> SUCCESS +Testing evaluation of macro result +TEST: '(defmacro! identity (fn* (x) x))' -> ['',] -> SUCCESS (result ignored) +TEST: '(let* (a 123) (macroexpand (identity a)))' -> ['',a] -> SUCCESS +TEST: '(let* (a 123) (identity a))' -> ['',123] -> SUCCESS +Test that macros do not break empty list +TEST: '()' -> ['',()] -> SUCCESS +Test that macros do not break quasiquote +TEST: '`(1)' -> ['',(1)] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing non-macro function +TEST: '(not (= 1 1))' -> ['',false] -> SUCCESS +TEST: '(not (= 1 2))' -> ['',true] -> SUCCESS +Testing nth, first and rest functions +TEST: '(nth (list 1) 0)' -> ['',1] -> SUCCESS +TEST: '(nth (list 1 2) 1)' -> ['',2] -> SUCCESS +TEST: '(nth (list 1 2 nil) 2)' -> ['',nil] -> SUCCESS +TEST: '(def! x "x")' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! x (nth (list 1 2) 2))' -> ['',] -> SUCCESS (result ignored) +TEST: 'x' -> ['',"x"] -> SUCCESS +TEST: '(first (list))' -> ['',nil] -> SUCCESS +TEST: '(first (list 6))' -> ['',6] -> SUCCESS +TEST: '(first (list 7 8 9))' -> ['',7] -> SUCCESS +TEST: '(rest (list))' -> ['',()] -> SUCCESS +TEST: '(rest (list 6))' -> ['',()] -> SUCCESS +TEST: '(rest (list 7 8 9))' -> ['',(8 9)] -> SUCCESS +Testing cond macro +TEST: '(macroexpand (cond))' -> ['',nil] -> SUCCESS +TEST: '(cond)' -> ['',nil] -> SUCCESS +TEST: '(macroexpand (cond X Y))' -> ['',(if X Y (cond))] -> SUCCESS +TEST: '(cond true 7)' -> ['',7] -> SUCCESS +TEST: '(cond false 7)' -> ['',nil] -> SUCCESS +TEST: '(macroexpand (cond X Y Z T))' -> ['',(if X Y (cond Z T))] -> SUCCESS +TEST: '(cond true 7 true 8)' -> ['',7] -> SUCCESS +TEST: '(cond false 7 true 8)' -> ['',8] -> SUCCESS +TEST: '(cond false 7 false 8 "else" 9)' -> ['',9] -> SUCCESS +TEST: '(cond false 7 (= 2 2) 8 "else" 9)' -> ['',8] -> SUCCESS +TEST: '(cond false 7 false 8 false 9)' -> ['',nil] -> SUCCESS +Testing EVAL in let* +TEST: '(let* (x (cond false "no" true "yes")) x)' -> ['',"yes"] -> SUCCESS +Testing nth, first, rest with vectors +TEST: '(nth [1] 0)' -> ['',1] -> SUCCESS +TEST: '(nth [1 2] 1)' -> ['',2] -> SUCCESS +TEST: '(nth [1 2 nil] 2)' -> ['',nil] -> SUCCESS +TEST: '(def! x "x")' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! x (nth [1 2] 2))' -> ['',] -> SUCCESS (result ignored) +TEST: 'x' -> ['',"x"] -> SUCCESS +TEST: '(first [])' -> ['',nil] -> SUCCESS +TEST: '(first nil)' -> ['',nil] -> SUCCESS +TEST: '(first [10])' -> ['',10] -> SUCCESS +TEST: '(first [10 11 12])' -> ['',10] -> SUCCESS +TEST: '(rest [])' -> ['',()] -> SUCCESS +TEST: '(rest nil)' -> ['',()] -> SUCCESS +TEST: '(rest [10])' -> ['',()] -> SUCCESS +TEST: '(rest [10 11 12])' -> ['',(11 12)] -> SUCCESS +TEST: '(rest (cons 10 [11 12]))' -> ['',(11 12)] -> SUCCESS +Testing EVAL in vector let* +TEST: '(let* [x (cond false "no" true "yes")] x)' -> ['',"yes"] -> SUCCESS + +------- Optional Functionality -------------- +------- (Not needed for self-hosting) ------- +Test that macros use closures +TEST: '(def! x 2)' -> ['',] -> SUCCESS (result ignored) +TEST: '(defmacro! a (fn* [] x))' -> ['',] -> SUCCESS (result ignored) +TEST: '(a)' -> ['',2] -> SUCCESS +TEST: '(let* (x 3) (a))' -> ['',2] -> SUCCESS + +TEST RESULTS (for ..\tests\step8_macros.mal): + 0: soft failing tests + 0: failing tests + 65: passing tests + 65: total tests + + +Testing throw +TEST: '(throw "err1")' -> ['.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*err1.*',] -> SUCCESS + +Testing try*/catch* +TEST: '(try* 123 (catch* e 456))' -> ['',123] -> SUCCESS +TEST: '(try* abc (catch* exc (prn "exc is:" exc)))' -> ['"exc is:" "\'abc\' not found"\n',nil] -> SUCCESS +TEST: '(try* (abc 1 2) (catch* exc (prn "exc is:" exc)))' -> ['"exc is:" "\'abc\' not found"\n',nil] -> SUCCESS +Make sure error from core can be caught +TEST: '(try* (nth () 1) (catch* exc (prn "exc is:" exc)))' -> ['"exc is:".*(length|range|[Bb]ounds|beyond).*\n',nil] -> SUCCESS +TEST: '(try* (throw "my exception") (catch* exc (do (prn "exc:" exc) 7)))' -> ['"exc:" "my exception"\n',7] -> SUCCESS +Test that exception handlers get restored correctly +TEST: '(try* (do (try* "t1" (catch* e "c1")) (throw "e1")) (catch* e "c2"))' -> ['',"c2"] -> SUCCESS +TEST: '(try* (try* (throw "e1") (catch* e (throw "e2"))) (catch* e "c2"))' -> ['',"c2"] -> SUCCESS +TEST: '(try* (map throw (list "my err")) (catch* exc exc))' -> ['',"my err"] -> SUCCESS + +Testing builtin functions +TEST: "(symbol? 'abc)" -> ['',true] -> SUCCESS +TEST: '(symbol? "abc")' -> ['',false] -> SUCCESS +TEST: '(nil? nil)' -> ['',true] -> SUCCESS +TEST: '(nil? true)' -> ['',false] -> SUCCESS +TEST: '(true? true)' -> ['',true] -> SUCCESS +TEST: '(true? false)' -> ['',false] -> SUCCESS +TEST: '(true? true?)' -> ['',false] -> SUCCESS +TEST: '(false? false)' -> ['',true] -> SUCCESS +TEST: '(false? true)' -> ['',false] -> SUCCESS +Testing apply function with core functions +TEST: '(apply + (list 2 3))' -> ['',5] -> SUCCESS +TEST: '(apply + 4 (list 5))' -> ['',9] -> SUCCESS +TEST: '(apply prn (list 1 2 "3" (list)))' -> ['1 2 "3" \\(\\)\n',nil] -> SUCCESS +TEST: '(apply prn 1 2 (list "3" (list)))' -> ['1 2 "3" \\(\\)\n',nil] -> SUCCESS +TEST: '(apply list (list))' -> ['',()] -> SUCCESS +TEST: '(apply symbol? (list (quote two)))' -> ['',true] -> SUCCESS +Testing apply function with user functions +TEST: '(apply (fn* (a b) (+ a b)) (list 2 3))' -> ['',5] -> SUCCESS +TEST: '(apply (fn* (a b) (+ a b)) 4 (list 5))' -> ['',9] -> SUCCESS +Testing map function +TEST: '(def! nums (list 1 2 3))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! double (fn* (a) (* 2 a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(double 3)' -> ['',6] -> SUCCESS +TEST: '(map double nums) ' -> ['',(2 4 6)] -> SUCCESS +TEST: '(map (fn* (x) (symbol? x)) (list 1 (quote two) "three"))' -> ['',(false true false)] -> SUCCESS +TEST: '(= () (map str ()))' -> ['',true] -> SUCCESS + +------- Deferrable Functionality ---------- +------- (Needed for self-hosting) ------- +Testing symbol and keyword functions +TEST: '(symbol? :abc)' -> ['',false] -> SUCCESS +TEST: "(symbol? 'abc)" -> ['',true] -> SUCCESS +TEST: '(symbol? "abc")' -> ['',false] -> SUCCESS +TEST: '(symbol? (symbol "abc"))' -> ['',true] -> SUCCESS +TEST: '(keyword? :abc)' -> ['',true] -> SUCCESS +TEST: "(keyword? 'abc)" -> ['',false] -> SUCCESS +TEST: '(keyword? "abc")' -> ['',false] -> SUCCESS +TEST: '(keyword? "")' -> ['',false] -> SUCCESS +TEST: '(keyword? (keyword "abc"))' -> ['',true] -> SUCCESS +TEST: '(symbol "abc")' -> ['',abc] -> SUCCESS +TEST: '(keyword "abc")' -> ['',:abc] -> SUCCESS +Testing sequential? function +TEST: '(sequential? (list 1 2 3))' -> ['',true] -> SUCCESS +TEST: '(sequential? [15])' -> ['',true] -> SUCCESS +TEST: '(sequential? sequential?)' -> ['',false] -> SUCCESS +TEST: '(sequential? nil)' -> ['',false] -> SUCCESS +TEST: '(sequential? "abc")' -> ['',false] -> SUCCESS +Testing apply function with core functions and arguments in vector +TEST: '(apply + 4 [5])' -> ['',9] -> SUCCESS +TEST: '(apply prn 1 2 ["3" 4])' -> ['1 2 "3" 4\n',nil] -> SUCCESS +TEST: '(apply list [])' -> ['',()] -> SUCCESS +Testing apply function with user functions and arguments in vector +TEST: '(apply (fn* (a b) (+ a b)) [2 3])' -> ['',5] -> SUCCESS +TEST: '(apply (fn* (a b) (+ a b)) 4 [5])' -> ['',9] -> SUCCESS +Testing map function with vectors +TEST: '(map (fn* (a) (* 2 a)) [1 2 3])' -> ['',(2 4 6)] -> SUCCESS +TEST: '(map (fn* [& args] (list? args)) [1 2])' -> ['',(true true)] -> SUCCESS +Testing vector functions +TEST: '(vector? [10 11])' -> ['',true] -> SUCCESS +TEST: "(vector? '(12 13))" -> ['',false] -> SUCCESS +TEST: '(vector 3 4 5)' -> ['',[3 4 5]] -> SUCCESS +TEST: '(= [] (vector))' -> ['',true] -> SUCCESS +TEST: '(map? {})' -> ['',true] -> SUCCESS +TEST: "(map? '())" -> ['',false] -> SUCCESS +TEST: '(map? [])' -> ['',false] -> SUCCESS +TEST: "(map? 'abc)" -> ['',false] -> SUCCESS +TEST: '(map? :abc)' -> ['',false] -> SUCCESS + +Testing hash-maps +TEST: '(hash-map "a" 1)' -> ['',{"a" 1}] -> SUCCESS +TEST: '{"a" 1}' -> ['',{"a" 1}] -> SUCCESS +TEST: '(assoc {} "a" 1)' -> ['',{"a" 1}] -> SUCCESS +TEST: '(get (assoc (assoc {"a" 1 } "b" 2) "c" 3) "a")' -> ['',1] -> SUCCESS +TEST: '(def! hm1 (hash-map))' -> ['',{}] -> SUCCESS +TEST: '(map? hm1)' -> ['',true] -> SUCCESS +TEST: '(map? 1)' -> ['',false] -> SUCCESS +TEST: '(map? "abc")' -> ['',false] -> SUCCESS +TEST: '(get nil "a")' -> ['',nil] -> SUCCESS +TEST: '(get hm1 "a")' -> ['',nil] -> SUCCESS +TEST: '(contains? hm1 "a")' -> ['',false] -> SUCCESS +TEST: '(def! hm2 (assoc hm1 "a" 1))' -> ['',{"a" 1}] -> SUCCESS +TEST: '(get hm1 "a")' -> ['',nil] -> SUCCESS +TEST: '(contains? hm1 "a")' -> ['',false] -> SUCCESS +TEST: '(get hm2 "a")' -> ['',1] -> SUCCESS +TEST: '(contains? hm2 "a")' -> ['',true] -> SUCCESS +TEST: '(keys hm1)' -> ['',()] -> SUCCESS +TEST: '(= () (keys hm1))' -> ['',true] -> SUCCESS +TEST: '(keys hm2)' -> ['',("a")] -> SUCCESS +TEST: '(keys {"1" 1})' -> ['',("1")] -> SUCCESS +TEST: '(vals hm1)' -> ['',()] -> SUCCESS +TEST: '(= () (vals hm1))' -> ['',true] -> SUCCESS +TEST: '(vals hm2)' -> ['',(1)] -> SUCCESS +TEST: '(count (keys (assoc hm2 "b" 2 "c" 3)))' -> ['',3] -> SUCCESS +Testing keywords as hash-map keys +TEST: '(get {:abc 123} :abc)' -> ['',123] -> SUCCESS +TEST: '(contains? {:abc 123} :abc)' -> ['',true] -> SUCCESS +TEST: '(contains? {:abcd 123} :abc)' -> ['',false] -> SUCCESS +TEST: '(assoc {} :bcd 234)' -> ['',{:bcd 234}] -> SUCCESS +TEST: '(keyword? (nth (keys {:abc 123 :def 456}) 0))' -> ['',true] -> SUCCESS +TEST: '(keyword? (nth (vals {"a" :abc "b" :def}) 0))' -> ['',true] -> SUCCESS +Testing whether assoc updates properly +TEST: '(def! hm4 (assoc {:a 1 :b 2} :a 3 :c 1))' -> ['',] -> SUCCESS (result ignored) +TEST: '(get hm4 :a)' -> ['',3] -> SUCCESS +TEST: '(get hm4 :b)' -> ['',2] -> SUCCESS +TEST: '(get hm4 :c)' -> ['',1] -> SUCCESS +Testing nil as hash-map values +TEST: '(contains? {:abc nil} :abc)' -> ['',true] -> SUCCESS +TEST: '(assoc {} :bcd nil)' -> ['',{:bcd nil}] -> SUCCESS + +Additional str and pr-str tests +TEST: '(str "A" {:abc "val"} "Z")' -> ['',"A{:abc val}Z"] -> SUCCESS +TEST: '(str true "." false "." nil "." :keyw "." \'symb)' -> ['',"true.false.nil.:keyw.symb"] -> SUCCESS +TEST: '(pr-str "A" {:abc "val"} "Z")' -> ['',"\"A\" {:abc \"val\"} \"Z\""] -> SUCCESS +TEST: '(pr-str true "." false "." nil "." :keyw "." \'symb)' -> ['',"true \".\" false \".\" nil \".\" :keyw \".\" symb"] -> SUCCESS +TEST: '(def! s (str {:abc "val1" :def "val2"}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(cond (= s "{:abc val1 :def val2}") true (= s "{:def val2 :abc val1}") true)' -> ['',true] -> SUCCESS +TEST: '(def! p (pr-str {:abc "val1" :def "val2"}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(cond (= p "{:abc \\"val1\\" :def \\"val2\\"}") true (= p "{:def \\"val2\\" :abc \\"val1\\"}") true)' -> ['',true] -> SUCCESS + +Test extra function arguments as Mal List (bypassing TCO with apply) +TEST: '(apply (fn* (& more) (list? more)) [1 2 3])' -> ['',true] -> SUCCESS +TEST: '(apply (fn* (& more) (list? more)) [])' -> ['',true] -> SUCCESS +TEST: '(apply (fn* (a & more) (list? more)) [1])' -> ['',true] -> SUCCESS + +------- Optional Functionality -------------- +------- (Not needed for self-hosting) ------- +Testing throwing a hash-map +TEST: '(throw {:msg "err2"})' -> ['.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*msg.*err2.*',] -> SUCCESS + +Testing try* without catch* +TEST: '(try* xyz)' -> [".*\\'?xyz\\'? not found.*",] -> SUCCESS + +Testing throwing non-strings +TEST: '(try* (throw (list 1 2 3)) (catch* exc (do (prn "err:" exc) 7)))' -> ['"err:" \\(1 2 3\\)\n',7] -> SUCCESS + +Testing dissoc +TEST: '(def! hm3 (assoc hm2 "b" 2))' -> ['',] -> SUCCESS (result ignored) +TEST: '(count (keys hm3))' -> ['',2] -> SUCCESS +TEST: '(count (vals hm3))' -> ['',2] -> SUCCESS +TEST: '(dissoc hm3 "a")' -> ['',{"b" 2}] -> SUCCESS +TEST: '(dissoc hm3 "a" "b")' -> ['',{}] -> SUCCESS +TEST: '(dissoc hm3 "a" "b" "c")' -> ['',{}] -> SUCCESS +TEST: '(count (keys hm3))' -> ['',2] -> SUCCESS +TEST: '(dissoc {:cde 345 :fgh 456} :cde)' -> ['',{:fgh 456}] -> SUCCESS +TEST: '(dissoc {:cde nil :fgh 456} :cde)' -> ['',{:fgh 456}] -> SUCCESS + +Testing equality of hash-maps +TEST: '(= {} {})' -> ['',true] -> SUCCESS +TEST: '(= {} (hash-map))' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b 22} (hash-map :b 22 :a 11))' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b [22 33]} (hash-map :b [22 33] :a 11))' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b {:c 33}} (hash-map :b {:c 33} :a 11))' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b 22} (hash-map :b 23 :a 11))' -> ['',false] -> SUCCESS +TEST: '(= {:a 11 :b 22} (hash-map :a 11))' -> ['',false] -> SUCCESS +TEST: '(= {:a [11 22]} {:a (list 11 22)})' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b 22} (list :a 11 :b 22))' -> ['',false] -> SUCCESS +TEST: '(= {} [])' -> ['',false] -> SUCCESS +TEST: '(= [] {})' -> ['',false] -> SUCCESS +TEST: '(keyword :abc)' -> ['',:abc] -> SUCCESS +TEST: '(keyword? (first (keys {":abc" 123 ":def" 456})))' -> ['',false] -> SUCCESS +Testing that hashmaps don't alter function ast +TEST: '(def! bar (fn* [a] {:foo (get a :foo)}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(bar {:foo (fn* [x] x)})' -> ['',] -> SUCCESS (result ignored) +TEST: '(bar {:foo 3})' -> ['',] -> SUCCESS (result ignored) +shouldn't give an error + +TEST RESULTS (for ..\tests\step9_try.mal): + 0: soft failing tests + 0: failing tests + 139: passing tests + 139: total tests + +Started with: +Mal [VBScript] + + +Testing readline +TEST: '(readline "mal-user> ")' -> ['',] -> SUCCESS (result ignored) +TEST: '"hello"' -> ['',"\"hello\""] -> SUCCESS + +Testing *host-language* +TEST: '(= "something bogus" *host-language*)' -> ['',false] -> SUCCESS + +------- Deferrable Functionality ---------- +------- (Needed for self-hosting) ------- + + +Testing hash-map evaluation and atoms (i.e. an env) +TEST: '(def! e (atom {"+" +}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(swap! e assoc "-" -)' -> ['',] -> SUCCESS (result ignored) +TEST: '( (get @e "+") 7 8)' -> ['',15] -> SUCCESS +TEST: '( (get @e "-") 11 8)' -> ['',3] -> SUCCESS +TEST: '(swap! e assoc "foo" (list))' -> ['',] -> SUCCESS (result ignored) +TEST: '(get @e "foo")' -> ['',()] -> SUCCESS +TEST: '(swap! e assoc "bar" \'(1 2 3))' -> ['',] -> SUCCESS (result ignored) +TEST: '(get @e "bar")' -> ['',(1 2 3)] -> SUCCESS +Testing for presence of optional functions +TEST: '(do (list time-ms string? number? seq conj meta with-meta fn?) nil)' -> ['',nil] -> SUCCESS +TEST: "(map symbol? '(nil false true))" -> ['',(false false false)] -> SUCCESS +------------------------------------------------------------------ + +------- Optional Functionality -------------- +------- (Not needed for self-hosting) ------- +Testing metadata on functions + +Testing metadata on mal functions +TEST: '(meta (fn* (a) a))' -> ['',nil] -> SUCCESS +TEST: '(meta (with-meta (fn* (a) a) {"b" 1}))' -> ['',{"b" 1}] -> SUCCESS +TEST: '(meta (with-meta (fn* (a) a) "abc"))' -> ['',"abc"] -> SUCCESS +TEST: '(def! l-wm (with-meta (fn* (a) a) {"b" 2}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(meta l-wm)' -> ['',{"b" 2}] -> SUCCESS +TEST: '(meta (with-meta l-wm {"new_meta" 123}))' -> ['',{"new_meta" 123}] -> SUCCESS +TEST: '(meta l-wm)' -> ['',{"b" 2}] -> SUCCESS +TEST: '(def! f-wm (with-meta (fn* [a] (+ 1 a)) {"abc" 1}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(meta f-wm)' -> ['',{"abc" 1}] -> SUCCESS +TEST: '(meta (with-meta f-wm {"new_meta" 123}))' -> ['',{"new_meta" 123}] -> SUCCESS +TEST: '(meta f-wm)' -> ['',{"abc" 1}] -> SUCCESS +TEST: '(def! f-wm2 ^{"abc" 1} (fn* [a] (+ 1 a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(meta f-wm2)' -> ['',{"abc" 1}] -> SUCCESS +Meta of native functions should return nil (not fail) +TEST: '(meta +)' -> ['',nil] -> SUCCESS + +Make sure closures and metadata co-exist +TEST: '(def! gen-plusX (fn* (x) (with-meta (fn* (b) (+ x b)) {"meta" 1})))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! plus7 (gen-plusX 7))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! plus8 (gen-plusX 8))' -> ['',] -> SUCCESS (result ignored) +TEST: '(plus7 8)' -> ['',15] -> SUCCESS +TEST: '(meta plus7)' -> ['',{"meta" 1}] -> SUCCESS +TEST: '(meta plus8)' -> ['',{"meta" 1}] -> SUCCESS +TEST: '(meta (with-meta plus7 {"meta" 2}))' -> ['',{"meta" 2}] -> SUCCESS +TEST: '(meta plus8)' -> ['',{"meta" 1}] -> SUCCESS + +Testing string? function +TEST: '(string? "")' -> ['',true] -> SUCCESS +TEST: "(string? 'abc)" -> ['',false] -> SUCCESS +TEST: '(string? "abc")' -> ['',true] -> SUCCESS +TEST: '(string? :abc)' -> ['',false] -> SUCCESS +TEST: '(string? (keyword "abc"))' -> ['',false] -> SUCCESS +TEST: '(string? 234)' -> ['',false] -> SUCCESS +TEST: '(string? nil)' -> ['',false] -> SUCCESS +Testing number? function +TEST: '(number? 123)' -> ['',true] -> SUCCESS +TEST: '(number? -1)' -> ['',true] -> SUCCESS +TEST: '(number? nil)' -> ['',false] -> SUCCESS +TEST: '(number? false)' -> ['',false] -> SUCCESS +TEST: '(number? "123")' -> ['',false] -> SUCCESS +TEST: '(def! add1 (fn* (x) (+ x 1)))' -> ['',] -> SUCCESS (result ignored) +Testing fn? function +TEST: '(fn? +)' -> ['',true] -> SUCCESS +TEST: '(fn? add1)' -> ['',true] -> SUCCESS +TEST: '(fn? cond)' -> ['',false] -> SUCCESS +TEST: '(fn? "+")' -> ['',false] -> SUCCESS +TEST: '(fn? :+)' -> ['',false] -> SUCCESS +TEST: '(fn? ^{"ismacro" true} (fn* () 0))' -> ['',true] -> SUCCESS +Testing macro? function +TEST: '(macro? cond)' -> ['',true] -> SUCCESS +TEST: '(macro? +)' -> ['',false] -> SUCCESS +TEST: '(macro? add1)' -> ['',false] -> SUCCESS +TEST: '(macro? "+")' -> ['',false] -> SUCCESS +TEST: '(macro? :+)' -> ['',false] -> SUCCESS +TEST: '(macro? {})' -> ['',false] -> SUCCESS + +Testing conj function +TEST: '(conj (list) 1)' -> ['',(1)] -> SUCCESS +TEST: '(conj (list 1) 2)' -> ['',(2 1)] -> SUCCESS +TEST: '(conj (list 2 3) 4)' -> ['',(4 2 3)] -> SUCCESS +TEST: '(conj (list 2 3) 4 5 6)' -> ['',(6 5 4 2 3)] -> SUCCESS +TEST: '(conj (list 1) (list 2 3))' -> ['',((2 3) 1)] -> SUCCESS +TEST: '(conj [] 1)' -> ['',[1]] -> SUCCESS +TEST: '(conj [1] 2)' -> ['',[1 2]] -> SUCCESS +TEST: '(conj [2 3] 4)' -> ['',[2 3 4]] -> SUCCESS +TEST: '(conj [2 3] 4 5 6)' -> ['',[2 3 4 5 6]] -> SUCCESS +TEST: '(conj [1] [2 3])' -> ['',[1 [2 3]]] -> SUCCESS + +Testing seq function +TEST: '(seq "abc")' -> ['',("a" "b" "c")] -> SUCCESS +TEST: '(apply str (seq "this is a test"))' -> ['',"this is a test"] -> SUCCESS +TEST: "(seq '(2 3 4))" -> ['',(2 3 4)] -> SUCCESS +TEST: '(seq [2 3 4])' -> ['',(2 3 4)] -> SUCCESS +TEST: '(seq "")' -> ['',nil] -> SUCCESS +TEST: "(seq '())" -> ['',nil] -> SUCCESS +TEST: '(seq [])' -> ['',nil] -> SUCCESS +TEST: '(seq nil)' -> ['',nil] -> SUCCESS + +Testing metadata on collections +TEST: '(meta [1 2 3])' -> ['',nil] -> SUCCESS +TEST: '(with-meta [1 2 3] {"a" 1})' -> ['',[1 2 3]] -> SUCCESS +TEST: '(meta (with-meta [1 2 3] {"a" 1}))' -> ['',{"a" 1}] -> SUCCESS +TEST: '(vector? (with-meta [1 2 3] {"a" 1}))' -> ['',true] -> SUCCESS +TEST: '(meta (with-meta [1 2 3] "abc"))' -> ['',"abc"] -> SUCCESS +TEST: '(with-meta [] "abc")' -> ['',[]] -> SUCCESS +TEST: '(meta (with-meta (list 1 2 3) {"a" 1}))' -> ['',{"a" 1}] -> SUCCESS +TEST: '(list? (with-meta (list 1 2 3) {"a" 1}))' -> ['',true] -> SUCCESS +TEST: '(with-meta (list) {"a" 1})' -> ['',()] -> SUCCESS +TEST: '(empty? (with-meta (list) {"a" 1}))' -> ['',true] -> SUCCESS +TEST: '(meta (with-meta {"abc" 123} {"a" 1}))' -> ['',{"a" 1}] -> SUCCESS +TEST: '(map? (with-meta {"abc" 123} {"a" 1}))' -> ['',true] -> SUCCESS +TEST: '(with-meta {} {"a" 1})' -> ['',{}] -> SUCCESS +TEST: '(def! l-wm (with-meta [4 5 6] {"b" 2}))' -> ['',[4 5 6]] -> SUCCESS +TEST: '(meta l-wm)' -> ['',{"b" 2}] -> SUCCESS +TEST: '(meta (with-meta l-wm {"new_meta" 123}))' -> ['',{"new_meta" 123}] -> SUCCESS +TEST: '(meta l-wm)' -> ['',{"b" 2}] -> SUCCESS + +Testing metadata on builtin functions +TEST: '(meta +)' -> ['',nil] -> SUCCESS +TEST: '(def! f-wm3 ^{"def" 2} +)' -> ['',] -> SUCCESS (result ignored) +TEST: '(meta f-wm3)' -> ['',{"def" 2}] -> SUCCESS +TEST: '(meta +)' -> ['',nil] -> SUCCESS +Loading sumdown from computations.mal +TEST: '(load-file "../tests/computations.mal")' -> ['',nil] -> SUCCESS + +Testing time-ms function +TEST: '(def! start-time (time-ms))' -> ['',] -> SUCCESS (result ignored) +TEST: '(= start-time 0)' -> ['',false] -> SUCCESS +TEST: '(sumdown 10) ; Waste some time' -> ['',55] -> SUCCESS +TEST: '(> (time-ms) start-time)' -> ['',true] -> SUCCESS + +Test that defining a macro does not mutate an existing function. +TEST: '(def! f (fn* [x] (number? x)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(defmacro! m f)' -> ['',] -> SUCCESS (result ignored) +TEST: '(f (+ 1 1))' -> ['',true] -> SUCCESS +TEST: '(m (+ 1 1))' -> ['',false] -> SUCCESS + +TEST RESULTS (for ..\tests\stepA_mal.mal): + 0: soft failing tests + 0: failing tests + 108: passing tests + 108: total tests + diff --git a/runtest.py b/runtest.py index 2d32e85aae..8b47a96789 100755 --- a/runtest.py +++ b/runtest.py @@ -1,18 +1,22 @@ #!/usr/bin/env python - from __future__ import print_function import os, sys, re import argparse, time import signal, atexit - from subprocess import Popen, STDOUT, PIPE -from select import select - -# Pseudo-TTY and terminal manipulation -import pty, array, fcntl, termios IS_PY_3 = sys.version_info[0] == 3 +if os.name == 'posix': + from select import select +else: + if IS_PY_3: + import threading, queue + from subprocess import TimeoutExpired + else: + import threading + import Queue as queue + debug_file = None log_file = None @@ -83,81 +87,164 @@ def __init__(self, args, no_pty=False, line_break="\n"): env['TERM'] = 'dumb' env['INPUTRC'] = '/dev/null' env['PERL_RL'] = 'false' - if no_pty: - self.p = Popen(args, bufsize=0, - stdin=PIPE, stdout=PIPE, stderr=STDOUT, - preexec_fn=os.setsid, - env=env) - self.stdin = self.p.stdin - self.stdout = self.p.stdout + if os.name == 'posix': + if no_pty: + self.p = Popen(args, bufsize=0, + stdin=PIPE, stdout=PIPE, stderr=STDOUT, + preexec_fn=os.setsid, + env=env) + self.stdin = self.p.stdin + self.stdout = self.p.stdout + else: + # Pseudo-TTY and terminal manipulation + import pty, array, fcntl, termios + + # provide tty to get 'interactive' readline to work + master, slave = pty.openpty() + + # Set terminal size large so that readline will not send + # ANSI/VT escape codes when the lines are long. + buf = array.array('h', [100, 200, 0, 0]) + fcntl.ioctl(master, termios.TIOCSWINSZ, buf, True) + + self.p = Popen(args, bufsize=0, + stdin=slave, stdout=slave, stderr=STDOUT, + preexec_fn=os.setsid, + env=env) + # Now close slave so that we will get an exception from + # read when the child exits early + # http://stackoverflow.com/questions/11165521 + os.close(slave) + self.stdin = os.fdopen(master, 'r+b', 0) + self.stdout = self.stdin + elif os.name == 'nt': + if no_pty: + from subprocess import CREATE_NEW_PROCESS_GROUP + self.p = Popen(args, bufsize=0, + stdin=PIPE, stdout=PIPE, stderr=STDOUT, + creationflags=CREATE_NEW_PROCESS_GROUP, + env=env) + self.stdin = self.p.stdin + self.stdout = self.p.stdout + else: + raise ValueError('pty not supported on os.name="{}"'.format(os.name)) else: - # provide tty to get 'interactive' readline to work - master, slave = pty.openpty() - - # Set terminal size large so that readline will not send - # ANSI/VT escape codes when the lines are long. - buf = array.array('h', [100, 200, 0, 0]) - fcntl.ioctl(master, termios.TIOCSWINSZ, buf, True) - - self.p = Popen(args, bufsize=0, - stdin=slave, stdout=slave, stderr=STDOUT, - preexec_fn=os.setsid, - env=env) - # Now close slave so that we will get an exception from - # read when the child exits early - # http://stackoverflow.com/questions/11165521 - os.close(slave) - self.stdin = os.fdopen(master, 'r+b', 0) - self.stdout = self.stdin + if no_pty: + self.p = Popen(args, bufsize=0, + stdin=PIPE, stdout=PIPE, stderr=STDOUT, + env=env) + self.stdin = self.p.stdin + self.stdout = self.p.stdout + else: + raise ValueError('pty not supported on os.name="{}"'.format(os.name)) #print "started" self.buf = "" self.last_prompt = "" - self.line_break = line_break - def read_to_prompt(self, prompts, timeout): + if os.name == 'posix': + self.q = None + self.t = None + else: + self.q = queue.Queue() + self.t = threading.Thread(target=self._reader, args=()) + self.t.daemon = True + self.t.start() + + def _reader(self): + try: + f = self.stdout + ok = True + while ok: + try: + new_data = f.read(1) + if len(new_data) == 0: # EOF + ok = False + except Exception as e: + # catch the read exception and send it to queue + ok = False + new_data = e + self.q.put(new_data) + except: + pass + + def read_to_prompt(self, prompts, timeout, search_prefix=''): end_time = time.time() + timeout - while time.time() < end_time: - [outs,_,_] = select([self.stdout], [], [], 1) - if self.stdout in outs: + while True: + current_timeout = max(end_time - time.time(), 0.) + if current_timeout == 0.: + break + if os.name == 'posix': + [outs,_,_] = select([self.stdout], [], [], 1) + if self.stdout not in outs: + continue new_data = self.stdout.read(1) - new_data = new_data.decode("utf-8") if IS_PY_3 else new_data - #print("new_data: '%s'" % new_data) - debug(new_data) - # Perform newline cleanup - self.buf += new_data.replace("\r", "") - for prompt in prompts: - regexp = re.compile(prompt) - match = regexp.search(self.buf) - if match: - end = match.end() - buf = self.buf[0:match.start()] - self.buf = self.buf[end:] - self.last_prompt = prompt - return buf + else: + try: + new_data = self.q.get(timeout=current_timeout) + except queue.Empty: + break + if isinstance(new_data, Exception): + raise new_data + if len(new_data) == 0: # EOF + break + new_data = new_data.decode("utf-8") if IS_PY_3 else new_data + #print("new_data: '%s'" % new_data) + debug(new_data) + # Perform newline cleanup + self.buf += new_data.replace("\r", "") + for prompt in prompts: + regexp = re.compile(prompt) + match = regexp.search(search_prefix + self.buf) + if match: + start = match.start() - len(search_prefix) + end = match.end() - len(search_prefix) + buf = self.buf[0:start] + self.buf = self.buf[end:] + self.last_prompt = prompt + return buf + # MAYBE we should distinguish EOF from TIMEOUT, + # return None for both cases currently return None def writeline(self, str): def _to_bytes(s): return bytes(s, "utf-8") if IS_PY_3 else s - - self.stdin.write(_to_bytes(str.replace('\r', '\x16\r') + self.line_break)) + if os.name == 'posix': + self.stdin.write(_to_bytes(str.replace('\r', '\x16\r') + self.line_break)) + else: + self.stdin.write(_to_bytes(str + self.line_break)) def cleanup(self): #print "cleaning up" if self.p: try: - os.killpg(self.p.pid, signal.SIGTERM) + if os.name == 'posix': + os.killpg(self.p.pid, signal.SIGTERM) + elif os.name == 'nt': + self.p.send_signal(signal.CTRL_BREAK_EVENT) + else: + self.p.terminate() + if IS_PY_3: + try: + self.p.communicate(timeout=1.0) + except TimeoutExpired: + self.p.kill() except OSError: pass self.p = None + self.stdin = None + self.stdout = None class TestReader: def __init__(self, test_file): self.line_num = 0 f = open(test_file, newline='') if IS_PY_3 else open(test_file) - self.data = f.read().split('\n') + + # See: https://github.com/kanaka/mal/pull/640 + self.data = f.read().replace('\r\n', '\n').replace('\r', '\n').split('\n') + self.soft = False self.deferrable = False self.optional = False @@ -267,6 +354,14 @@ def assert_prompt(runner, prompts, timeout): class TestTimeout(Exception): pass +def has_any_match(expects, res): + success = False + for expect in expects: + success = re.search(expect, res, re.S) + if success: + break + return success + while t.next(): if args.deferrable == False and t.deferrable: log(t.deferrable) @@ -287,23 +382,25 @@ class TestTimeout(Exception): # The repeated form is to get around an occasional OS X issue # where the form is repeated. # https://github.com/kanaka/mal/issues/30 - expects = [".*%s%s%s" % (sep, t.out, re.escape(t.ret)), - ".*%s.*%s%s%s" % (sep, sep, t.out, re.escape(t.ret))] + expects = ["%s%s" % (t.out, re.escape(t.ret)), # for Windows, WSL + ".*%s%s%s" % (sep, t.out, re.escape(t.ret)), # for Linux, OS X + ".*%s.*%s%s%s" % (sep, sep, t.out, re.escape(t.ret))] # for OS X r.writeline(t.form) try: test_cnt += 1 + # Search with prepending prefix '\n' for avoiding hangs on Windows res = r.read_to_prompt(['\r\n[^\s()<>]+> ', '\n[^\s()<>]+> '], - timeout=args.test_timeout) + timeout=args.test_timeout, search_prefix='\n') #print "%s,%s,%s" % (idx, repr(p.before), repr(p.after)) + if (res == None): log(" -> TIMEOUT (line %d)" % t.line_num) raise TestTimeout("TIMEOUT (line %d)" % t.line_num) elif (t.ret == "" and t.out == ""): log(" -> SUCCESS (result ignored)") pass_cnt += 1 - elif (re.search(expects[0], res, re.S) or - re.search(expects[1], res, re.S)): + elif has_any_match(expects, res): log(" -> SUCCESS") pass_cnt += 1 else: diff --git a/test-nt.log b/test-nt.log new file mode 100644 index 0000000000000000000000000000000000000000..416fd1c64c95571dec6b2162de1ea9cea218d371 GIT binary patch literal 118266 zcmd^|dzT%>k>Km^J!ii|)3%{`v_O(&fv`Xruy=M1cno+vZUj>6g^XTS3nL8DN8jD} zRdgsat0J>1>(*_-%<0qJ_f};^M#eiMBeVYB|NX4H(H(VK@3IYyBw3IDReH@5s-6>GiI( zyCeUCSg=c5lhmy=SyR`bu<=SG2C8q)FC@4PHDG;JPh>c_&> zdvYI*dLaD1D&M{pZr|wb#WlHet-tzE?pzbTb3Kyq7XnFsq1tn9gI)}tf3e~DSA*wY zZFv5*;Q7}Yp5G6i-*0&S_2Bu}8=n7d@ceHZp1&A8f3e~DcY^2NX?XtK;Q4nOp1%}4 zf2ra5FN5d5YUK>h3Q#S+}> zwcfAZmNwt__QanZe!|=2*RbkXnn&{FJ+UD-#AoxnBVGm{PK1JgzbVgsEm!a`8W+4g z>I>*=S*>3LRQpAhYPr?=W$^qj8=n7F@cgeDo<9{lf2!g6AA{$AtUjMc5dfr#@+ek=xcd>yW}ebmdZYDV5pX_800jPPnN;fw*P z$EzO7)!2WY4mfeT%86VO&j-(+Z+ITcpFgJlIQnmav|pS<*qvHD@|jS`wST9Vl$4G~ zVts0n_NH-w&V|Ml(Cc-~(>aw&vOcAsH;1Xv&IO#dJM;0=C-!?ge6tAA?$_bw9Alnv zPwaRu@j3^+D*QCd&ioB;^0i3aRr$T%>*Cj96I7p4YHk``?F($?xMLpJo%#rKT;7qH zaRiC$bvQYthBgBGrq*&yfxYfkq0wpiJrm9v^ZRuy($U0oP_DMX*eT%D28CR}odP7g z*MilaWHNTd(!X4Qnci=KYn)J;pOHS!7W*i*o!=kUV^4m8#1Ar{*X)X7pjU~P_|gAk zDRns+Vm}|Fy*`6clSMKdcE1g7`ecOtD_P%du$cuT5x*(O1ATjo7TD+uzfqoHufGEi zxnGB>_CYgbcl+4rNN^%X!CI1y(a6IxWs#jwy1yn*oRz$t{=D4(kLanbRf21{(NiAN z?@JFKh_}Ak$28;z4n=!!$kmp4gN~qX7ghIPm$5&TDC$P{dLIvxX}b~l3T-_et6r~- zF^{OMw=pEUGanW)sp30^=J)FG>NLV{ScW&s&+Hz1z}>)e`Mo*@sozj5<4@}M@#wt8 zeAxC3I^!_{GLOf+CwzZdGO6Xh>d&>~@rBG@c8?>aTEA(lmR@3*yA!q|s)Vv^GX39uD8H>wE&0f zEpT2dz~Ooeoc#hEuD8H>y#R;nEpRRr;BdVK&f5hzTyKH%+X5V}x4^krfW!3`IPVnT zaJ>c2y9GF0Z-H~E0Eg=>a1IJ^xZVQiasdw4Ti|?IfW!3`IA0auaJ>c2l>!{Dx4`+K z0Eg=>aGn(4aJ>c2(*hi>x4?O!0Eg>!IB{f1rg2B&rHArEjy;MB_l{?2c`S8G=2&}@ z+5JQ!`5*g;i%h-dG0BuZkSP3-++lU#u#aq6HDu-fxWa)TzX86d#U5Hc zgHzYw0L}o#QpX zpZvL&@jNYz2fwgh>-G8meoxk3fkf_6Kas)KPh`>~4%DBh z_nnV(xa#sx88?+pr5NcTS$Vk};FjO7W0G0}YTL#mjOD&LnFi3mdyWI=NS6Gva+FC!uw)P||?D3O~ zwry^!^uHi@L+c;J%N_Qgj58OGIb&RbqI3A75DgyxmBULpV*Dscf#09c>Ak+@J+^*W zpv|lwy9ih#WkrYzv*BC;*?C)jbmf%FeC7sPL&m54dDe`mT%p>GYzCQ=$I^y6HLHq@ zMpB{%@Q5^yBu2Z_L%l8a^z^`0@+4z?kzw#1Vs=&5J6ZRAc#PG9W60F4QEQWH3G&%e zId=Ml`mFo1OR}nqO@TT$1KL~?u8haImplXC>JkOT$7|S|)x9bg>tp*;#)h1-a4bVsqBkqn zE%1IU;KlVCoGH1AcbS+}<@PX=D{NS_1EtjtMs#Y05!IBp!ieh1TVX`Cm>FQsn&2U&G_(nWhc>V2lRb6M5?>Eo(>JlIzf6KSo{qvuq?e_AB# zywGSzFqx|0_qJ^n{5NEWBUM}9%3q5BElZ96)7oYA>$=O9{gFg4-afKbUV#}`@-nY6 zog44h%WKpW);VdfHJKVK#C3?!p#?JaeP#HX-yCb>n@xSZ-uE%5C#~Zh_jhK){!Yu@ zQ={IS{SJt;LMK)bG>7{}UvEtmc3!TG`#;_9Vtu0ti@eTs43m8lo6<2I*S!g_9dD(cw1~ujXJrt z(fkV$f%bt+y(#o9^Q+fGsBN8yk=FI zRnz8B?D>6pjw}ODxFiyl4mlOs`!(|X%d)tslq~c5XT;YVm7dpLz0(bQ^{j21r)L-A zpJWf?SMvX3IiVn>o7omy3s}QvZ{O?X_LIEIO_?7>WBf;bM9{ z@3Fm4sDD!PV#nL&!aIG0VpUnp!iaRP_kVARmx*M?P>j|XKl5a z{^vTAR;tCb*E(JBd^>%dkm7G=r;Ou{Hkjlbpa$o{?)6nl(-hL25_#gcJf|@0>q}eYCIj82CV)HCp{fY4vnZDs8mVk~n27?asj#+Xl?j z{ci-*Xs`rgyb84$mM)p=#%e~{Y4}SiVv@f$?+mW~UyFxCPs|--Y?sggh-EojCKU#A zO-XxaLd%woeSIxcJfY~CqyKG{@5{IZ%(XdhFypZ=;SqI=HJM*J_Vqchn3g#|Z}hoG zy3y~2#`BbOOY4sWh(w2Pg#K*aIP&<=aEu`?;~_8&7yq=Dr3Jdro@E)AE(=~-4?bO+nvX#(6;>r3nP1(`n1G-67?028Wcdj5ezfOkRLlE9 zqf>sZ3q6HgvK-5Ccj!JVTW>VE%{`Rd9cKv>_v_nDm{}F6=Q%-C&!s`9+BGZl59rnbJs<)iR8*TH*K-kujyj@ zb%(}yw0fOAr>qod6j#S2kB6gvG`bnfAbp+b_qWnlo7Il`v6zN+Ya63QR%TK8KIE{E zImf8Ya~Vc?HICL3sKkK-7PFMIr%ro5t)rdaQx#l!Jiw_*)c@ZWtf;ay`KeXNmS<}| z?hoXQ#N2177daX2(%$0=$|)Jk>4OKj*858;gsC%OFE?+jf!E*lGB#WfkG!f=X83d( z>wGM73Dq=zuIq^(%N1spTt|BNzBj^wYwQ-|E;_)EJ~x(iG_53Kz-jk-!!gAfytZ9- zLzrtsmP45F`wq?s1xxgaEN>(uH-(4P{@xS4y4LF#x|K)LbvaQ8@WbPrp?q9C=D5lS z*%_A|yQdaW?;$_H12;b95)Kw~nm%|aGpp0@eDwBKuDo3u8><@R20jdIz{jQODN z((E1QZLx=BSE%8ix7S0A{qmfXQN>0PVZI4;g9~*u_E~=fX&?HY<+c0p%pBIIBtx6f z3HeET*@O>yx;9^ZI7Fhw@q9Xk0ocY?ujpQJ~!IXP7sh*<-H; z^gB>X*NWEIIXR7m)wNK)*@DFq?a#ex8$}}SPQ{w}+buN^sPD~b z&pf(~{<_v0&kNh4!JHQDm_!uWgc~siWsbzr^*o;Bc81*qSQUIR`Lyv00=qeNcV!;o zM)MzUs})JunQ@di56@h446;UuYeO}RBDl-^gW*ebv8G=$xSOn24`a^leUIkbc^qix zi|dZ>u}tB$#}dTV`W!!%9*^)MNEU~*!{aDy29R_tVBS zbW@61UnQGUreyue&3WnY8NZEJX<-&-4tAxdH^tB;AkOc>)#>*n<`%1LtMpDh-Zq_4 zNHzPk6rOUdq>1q>4Z1!!H|wKJQjgt;9Sl zI(&Bc)Fv1~S&tt0T-PqeC4I)9*c6YFuGVELf6B05f{W|)x>nuzhYY`bY|EC(kz=@? z)zOvwQiMbvJ&*k0J(=D1l>n<5h%}jNYd}_7k0r*ne7#;;wb^i(daky9T;@~FPO1ep zE4m&9=35UNJ5LOs((k6Z>tYA&dC|iVL&bCWv|Tl9+jylqlj~Cr0$H&3Y5~(Tw-%e( zGsf&Os?o{gT<)v>ej(NZIaG?bX>=Y7F$OXYk7RanuQ-467VBCmhs$Wj)?_mo&7qep zmV4Ue);8*C%K8i`Y2M2+DXhDaVX(PhO@2$(D#y#@XV`O_{G|CLoiFFT7(L;gTLh0@ zhP_*RZ*6VY=e}7L$BQdwV@jCmQ_(Z)VYnR|Vlt(E37cV~m>*l@_G0=Sg1Xa|b9-4= z=BKy*=GyKQai4iRCBjvc$2v20I9VzXi@y(-N z&cFPGDTTl~DmqNdxRzdPCOGGKlb!rEOxzEF$*rO%vP@$77M!uC#Fv1pd&r1>yUF`^ z@T_Ku@VIwVW-w%$@J;6r!=V;8!doY`>efYOE zdvW^M%mW{9au{=Q>4@^aw4b<#xpI=rqVh$lMJ-80r{$2TaV%M)ra%L+t{&qAaNR1!$=pEtXe^g40~Pc zf#9w8ZGX)sI~G6gqbbh6Wmjq%b-kX%ck`{GYoEUD#J?LyBYjz_>t;dnXjFHp(jR*f z)k`SFjK^k$Xk)EYO!YZNu-u-fbKPZUYW`Zz)Fh()N`CLjUv|JepVKvY$JLuNPuKLe z_0u&!JC;0+qj&ne)^O(!C!?}^dS7N})FXz;Q!K!(kytd%U6iQlo&ONj+g@?q%QiBXeaX3)sWc5Dj*k`5Zma28r8dFY3f2|)8 zxe4aZzB6&B`>cCko=Tn zvBoj|rkqGeY@;0aa_$%p`(Nr+d1D;CE0ukZjw|i&^rySg!xGJiJ(<&wy@yCjt{F9r z&>a|uqC2d^>V76-Av(F zBoSNudX000FS^c~EiDJ5iJlY5$_h;Un1-#xx%j}C7d z(NUE5{0`fc@QEbSpp%(qgk#Dt@l+|)c<0cvTp+Z;LX%mFv8_ie!z>`MILGW!$6OnF z#}$)ps}<8&w!u5<&&hu93`djKh+9*qx#T)LjcFUaA*N$}QY{)w+1ma1TfED9J7rUb z(o!FtpE}1mbjZ@7=o3*oGo^@E^k1JRO<|z6sRVmU%5o3pqkCN}aeD5Xo-BdKCg;q% zr1Wjdkv(zirBb>tZHK2jz!5AP*yD}L94c8di-p=EDaQ@_bhpRBEY(S!p=h)fSddpx#_Z8ps_dg*EaPRWe= zXnix4TR64SW_$DXW8y3uSJdm;7OylzcvB*oQeVik%5<(TE(xzlj^xkXAG*KvXBd+i z(Kps136?G8ihd)PYVV)Z%nCcpBCWCYVrF+~9}%V6=Xoi_u~tmIv#(AO&wA*j9-{Yq%VE9+A_*0I(2L9)o4UxIc$sajNjS1qH*N4UxALqB~-e4$6`3yueeMCz>j+#Bu^Il?$QODzB zp@Ghq?uayfE!4Ot(nVDnyOplV=&towZQjpym$H%_u(&&41B@scx5O%(mKB~C3M&fr zF%4;3??YFx;tczm{rutt#`4P(=;K!>(8m{&d)Pilbk_mvmr*pdChx5$`+xF1o?OpY zPJo`A;zo4&iewO9lZc0P$qQmHc<0nR-McaiWxn&JREYf0{U~1K=^~s`d$p`au3&&(PLne!XTj_FhzNXdP};ch~~I zwt5C8MDn%y+t90&#sMUqBSu!mt58^HTGpS_Okm$FpeOX(l~lI!rn7(md2qnn8)#oC9&n)Qw-B5;xR3e7Q-OrmC1VCi`}h{ zHqRiYxaYEH(DJKiML*bkP{Tl1+-Y?ZnB@3b?fe}4Y#-NVc%~FA(Pgt9EDxmF3jY?5 zv8}I*y&YG`(<5omGUeHloL44c(Kt$y1B7jzCDA=!**VuJNDS^m243v z>v439dmL%#KDN1$X^gYyyAEZh5=l+oqAoQ#_u?ME>$8iT=x%->Uj2-pF1^)sD%&4v z&X~@*hD6lJThysB)}g3Jtv(q`B^3Zu+A^<)NDJ#@o3F3)Fi;IESqZzl1~nP0%1C*H zdVh`HfTXjaxHrGQMsGGYoh`;a=55yKwMNZpO70!M^(432@JQ>ApdY#OJ<0R(`F8*L z@ACJX{`(#It1I&4R$88lW=5>NVOQ!NI?~eoNwxJ62ip9%M|DI~ykl={2imHhVyn45 z|FI|3OleA780+~O<524ht;k7 z|M%}f?2E2xEkSAha6I#2=IB)fyjhLvLNG4zdpHu_$rg{KUU@gn+wvw)BEV~c&;Ed3 z5#FvD*Ph|4cKoNL8Q@me3~RB5{HblKQIZwZX+0U+mGyLFE{?HGsRobnTPHH69zwsQo{ zDh;nket$_`@8Zag)O)^OuzSn)64iS5lii}RF7MCbw$OI1{_OnunA@?GuFY4QYmT*f z`6w0U`V_?rj_c_@5Usi?zYpaHdDYz5?|TpGdt>}Plbo57|3ot*=#laTpJA0N!#e7r zcjkRX=lhscb5RHKo&B8i=R!bGYietGM7TM${C?dgc~&BaoaQxZJ*4gGJ>}LcQF>Z|W3r+QU=tO-G?H zN2Pjmp7tEdXJ)OudAc!o zhAX3+=dX+_PsM)f45Y-5&2uYM`Kk2eF>oA*#4X#T0PALXk+&n>419#QgaA@P?k5yO(%l_m}YIl6b;8bfhDf#CFbTRKYF?Y=cLG!-x&Z zx3=yfW63A-m_OnOZh3`7Ba6+UmsdpG?=I=36m>17iDMHgHUxgN(d(K2I97#`a9_)v1tbV@Wd(L}!SQ<6iXM z=DqA4&$6Rl>|RSRxy4)~I#vs(vGL^~PRZ}L;9BA?eZfVITn{9s;4^zw4|*SRv;Tgp z$ea1k*RjoYWoUoqYsnSCo7qK7J=Un}c%;$_ti2u@vN^VS+=c6HFp)IHuq20IIW=D# z;t3ygR#h51Etpktzl8?in?o<*o%Ya*Kh;n^f-=3mk7>H+GF6++?8u21?1`mnO=A%D zsIV6?^7yXz*QEVP&t;GvW*f0Yj%OKd+*XMPewhd3KBjq*%d6^uj-n(@<6hde0vJjy z=2~Tnjr-E}t$H%-uQs+)pU~2BYM*wW%jx9rcTn%sKo-?P<-OMV7WX>EzmG&aRDakj zu4fqxZ8ZAA2?yo%*0C;K5ev$h**UD3YEiouN@-6u{L1~-pK8J4U@%tdGh(^SX`=1g zda7Yv?sxjB8WyZx9m*JQ9nU*&33sE|V=N1CY{*$9oLr-IFqTUl`(nLQ!)#84aNgTm z75u}QSl&xK*HvoR9FI2ZjxDeHjwK(y83x1l>tdsIrem&Z*jSZed$M1VRHl<%W5~Zcno^?5+t$$jd%4Soh z#-i;ElWkDfMjPpY(*-`HbmJ+*YJKV`^wZME6nzYjA*Px!+7`Xanczb$S`MWmnhLIp~Nu-S}EAMlB<@1S5#yRSeAKZL@Tpo#OY(R#gT;c0d zHMS|K6oGRtvD=Lm6q})>C>Bdb0~JyWx_#_zWjvDX6q7pLb=N@Je*2h@C3b4>LRpHS z!pUJj#vD%%217}z?QbZLCiSXoTSb-7`fPQtubCj1#i&a4y(ztOUzKaI)t@=koLBj? z^u~Sj3u})bJs|(MM7wiL?Ja-K$CJ>RI_IW#H8`%RJunVImz1kNjq$`@JH@j+7L}s4 zWoXXsg6RmmMD=ZI|2)j+w5oF@8e4vC8=NVv>88~;^t-M+9LP!!s|B$Kw%UwTUWfR& zy;~bI>}VTisr6kK8(S-m>ExEFM4ff9$=8HqoFd+(w&tj}mo4$@`m%>VU%nEZ(mLfp zeN5?7=u_@BaxXcKEYqh;eVT7oD^Y`Q@j?nI;#-c@jR~x6ey;u3M`$y1YwQ1O5}Ri7 zmz`sHUd}OeK0Tk43{T5Gfb%m?GW51>CmFKW>9(vd-OoY8#~HnK=N1 zcIA7%D{gyyVno~K6n(70tGtrO?M9lvi}WjQiS08>7HNE&Ei3nt%j}=z4ICfJ8|rtu z_vH6?y=IQ}(zMxI|E_>jT+=3%YS7=9@#HE&mko?9Jk z!q>8&Uf*s*)hQO%YMwMo=gM%`S3GM_XlShM_R-mao&+?OfHrRzL)R!>`x*Bz6+x%9 zp;&RP!_DzmKVY>Q+TXaR_9`&7)Gr8iIV)*b{_ci)QsO6cZl6cxz1GHzRW8Zenm9cU zY=csx)XUh);LmOgHB^3`f3Z(%=T!`y_X@;4w7v7U1YKt^`rh!!g0{_LT$`upGwn5U zy@?=~X|oRWDcZ0{O&MTF$l3-v`e1DTf^o|= zG{)1JA>MIr|JxdSieEhPIrb*EfFH`6I^XO5D5GQFF(+y3nU0Yaw0ltIaZjIEK6d-L z`>wQbY21~0C_NMN*!*+MId4_hg?tQAR7;HOeyU~9l|_ZDc7a9djrVm7a~Vrv5@qph zJWE;@!RpE!lIjvbEH|dG-=BNhdmceP@3_@Q3I%_j(Q0YMy`3{@9H~#Q!|@a@^k&~s z1X=IYvJJTwjNzgMtPYb=S*H)z`4XL%$D?H$FNay9@1{_vsY_1A=-(F4Ih`#gB&&r) zu(s|{;c6s1Ej{Pfe(15%U9@xk*TF{q3)@5fbZlMc`LA)FYp2`n?6ov&7D3nu6#mxbD|2n_9q&zzuI(jdkYkLjUA?61iCNVNu$wp@TF3Lc|vMI`OTqUUrx8k1sQ&&qE) zR>nBw)v)y!5+U!&?-$b2B7pW-Il|F;N^$+E;OG@Hj@_76*xA;sUrLFgMfbkolJ9)L zu2BOY@e3SG@9LVnOtUmMMAoTYvphqir}!Pp2pAa}M+S%Qdd2Cz9qpTo$yyqk)7m1R zAqAr-*7IxkBtp0=QAMh;%#)a5mUs7-WB@1{S@X_n;%rWUW=70a<~4O}h^W66juEc| z%PZc=T5*N>J(!iNKi9@B#fTi*I1+5D^f5l=V>Lc7%5e{S{g{y(s*Oq`jA(1UrL-i6 z2`z_~L35kjaZN!IVk?2I*C?CpacN#czhwEyCVS+R$2l$Ix!B{Q_}ke0%}<-yE~uC1 zwb!UK1!4r5?E89Icgu~Y97RX;+&Z!?-}kotq3GaT8=Jx+uDc-cbfz(uPv`MmUjA2^ z%M7WMYZW@8R4eJnJg=H(I&*$b@usy0I5X~{HqUJ5KJ`80K2ln(A!DUp;Klaf4@b5g z8A#hLj8lK0;@YKOIPydHWEH6J!J*Oz*seu)hg`DZ?fe{KY%|LBakiK=;@&*G)r;r)$a?aT ztSajs(FgK5^7X@38b33}xW3y@H$N?sF;@#;5;-DbQn*h7Db4TChf5xn6GZMy9In#3 ztr6_?^$_F<^FH%$={R)k6Wu?STlwSTH&TNiTK{O*VJ>QUyGJ$9&E_j*gBx! zE!1{R)1D&SH?ugg+|AR2;R>;1yH33Begz9=^%=VQV{#W!qiTnlF|-acfC9k z&0#)p)X!z7`&q_;Tr%;wxxVE6s?~`onCexV#Qs;IWI7J$SeA%3+fkB+dLK)4T(fA* zL(8_Kb@lLKFHstekKsp>v^nN+jrZO&j&lRN##c1bnByf+%>zB~4&ygAEe66MoNYz0L7W*wWg z4mdSHZ0e`E}#8;Cq9PiS^hqhk*6H|Rw}5j%N5=MjlNMMbYK3`vQ$f($1!B7 za(kgXKnkJ#q5M7bO#d_!aG{@}V67q!lKUBfiHITBz?>JGQTYp@#d}i0IOG#ol;(Uw{`mj5{_iH( z8f~1O+vkJge(HFXX@88#t{d;uYtE}2hVj3R67D_lH>}R8j-_&LRM$Cxc}A$E++ZI9 zeln80l3pzH9%}oDS~S-T&bxt5s;{#+!?1iJZHYCU-$N+FC)7U?De+EWYy>l)97;55 z>!CFI$SOD|*mHIhUki`xLH$1T^BPcA=I-`0J3DvY)|rXp{SKO9D|5t&mqYztBI)a3wtalyWh=Fo zV}(2oD<^-BXBU{n`ra|S0zHSh|Hu;hlNzT{S$#{MW#=%v#LVC1k@&j1ytPl??|r7< z`%MLZ&8DX|!A6aS=#FaBU9voAdb&F?rh`5CSRnjspnpUOuk;r4CCQU(3+x@=qW#mf z-d%*h?ZLMZQHjn8uNo`p)p)MrW6yUudNqK~OUY;HdN;NzrHk#d<+|+@wVg925A%1= zB0bs~O0m{%H4%LGT{HE4vk{k>t=MW`#7p!%{q3hWK84aS(MAtdhRKV z7o{zuH@>8DRmRF%$6VYT6J}l-o#1c5!*I-FCu{Svw2AEGc68BZj44l2x~)$YD6n1y zo!K?5RV-P{Wn8pOs;-?Xg~%X9+(GKNcez1cbNIUUmY)A;J7qaUfTq zDLTUmQu_31#h05gC) z!gJ&JEs1WZN7j{`^xP`=obr0v8F_EX8F@PMd_Je+QM>(?NEqw4c@{5UqvF&(Z(Dy4 z;iobpq#Ow3zb%)br~X+M@j!ayv^=y4%5(PQ9g!@ftI{^tQ)Kz7z{I9=hGj~BI}2>s z1`C2V-w`isdqv(6tm65|nzFn5Y*hE9w>$$xc7{{p(l&gnuZTo6d8L z9X(i(_^iH*{phLoy(?|7eU>dblxysE;)L!UdD_kajUY$*H_r<(iedKf1Hojo_xo&j z-!(W#)F0*uu@IU$$lvK@>%e#!=#FRMy$YwK{VDm(eV)B1PscfO&&udY2?j|$=c_%( zUhVB-#F;hanw7Wj1mg$Y3q8(YZ}}wjYQM*2e+w3RI5UQZ<|!`;_2?Z+upUr;6Qu6l zoF8>Zy)Z_4(a87BaI9^0A$6K+WPnzBOdUr+>vDQXUBe@ivDT{7`iM0OVZ`K#)BNZ2 z7`I^)kK1#zQ&p6?KZBY?gJg-hgZ^LZKr1>2M6 z!!-xbsW6;K`LNH)>&{?3Bk^AMcX>j61@Wl)b70{=xJGpNZm$uVlZxo1cS`c9*3~OD zeCH6@e&1tvUpySxA`h1Pa-ZX?X3d7`}cpXb@( z7I&B&X+0tG#GGq9$5LsJ{BQ|^Mt&toLw{mWu(CGaVeJD;ujdbqqqsJyMsm|$B3+96 zRzI(+0b1K0>6ot=wCyZgj@7PEhP(j&Fv7_1&((ZrhVYMzTTt0YT z!94k}OpET<$7icfE4@sLq0&jqi;bZ~qa3$oe2BHjdj4t2jA6AtJ;rjw>d2RU_A#e& z>H|uW6X93l&ZaiSXcF(>L3eZfOL$;eK6)0nX`Fdao+U!mOxHNZBm(o?n4YEmNb&@F zroKgD#AJ37zP`aBp2@nMd^PkK(;ijFFg{g&_@)t^SCfOXK0U%&pI#*!c5U5KflwiEWIJk+6#m?t?ggtw>hoh$Iqa8ygJHfZ}2<{DvR)3@G5BR=0_ zJC1=$vbId-#~AU>J)P+fdBDtj`!q@^6VLTqa|*_5=6)(s&~{AONG?j$uEz}4PmKS1 z{ltF8dPlZ~eU;<0sO3*#^h)V`EQgtNTQ2Q-dadV+=1BYS z8J&$pIJL?(WCU zC0X>N`#7U9mPR%=qR6FHvyZ5*2}kxYYVG>OK$30&K06v17_N5j}wQ^s-0 zW^gY^{JTE3I*TKkC+l}jW+$w>dRF+!KpKg=d9QDT$vl4KQs%vqqn=|C^CxP2oQF?t zRdVQSQap!Tlj~)2lEYtH3Ulb|%3=AT-Ldz+xb%#7Z9x0Wdmz#3fPFa1nBqz3;Z#i_O4OEY%!_H{s z{yM!V&v{=%L@C85m7V3i>M0I3g3E;-iN3r|y|>8L*c$L0OJi-*+0vK_cDfU@DqYF4 zogppSk?zUV`5Ri{7-&TktK7r_E%N50 zTZT)7O^$C1Ht9LUTD!i4J`qmKqIs*enMa${5=S`r{T7%%!8cQlfaHe_$-$b=7A3?wAlo!B~*%J#P(lK*>l>p=&ol0t@eZXEW+TR zpP?~R(l@F>6^#qaYeM-mEqJ-47+xiwI}Xd>$D_4ge_FK`hSg@YXo+^(--AqS;@pcf zS?$q|%c<2?oE1sbETY~cUPlsl3i-;Cbj;0C5A${A;T@k6S91JPJU;1u-+d++|Gs;# z`!_kO$1(;~b}^ds{hJhYFAlqU`1w$35jeS#w=n6R9o2 zgG8Xnl;v<+f8R!tc&8^nJu#=n`J`3k$drB7it>0?oyz6saw^pOA`PF)&oceED9^>%ki{Rz zG|O_&LwPveuMzBYZ%gn0A(Q|ExN7^S$So*U#u%IvT`SQbk{7Fi9H&TlZI$ge9k1|G zb9EAOr3Y*TOE}^^ZbCppJVY~61v#V z3T;2kGH5OL)R-JfiK0j{zvk&a@BZA|7ah~5at2-Q2|w&U5E>db@Wb|zrhbv@9&5Ol zVjh+6CrLe{#tD~a()0QI)mG}5w5VqCH|O7wHYPE1DPrxHNmy!2m+ixTudkFxZq2(7 zb>mFGOB$-T1uQje__8%3O_hZ literal 0 HcmV?d00001 diff --git a/test-posix.log b/test-posix.log new file mode 100644 index 0000000000..11e4d1797b --- /dev/null +++ b/test-posix.log @@ -0,0 +1,1224 @@ +Testing basic string +TEST: 'abcABC123' -> ['',abcABC123] -> SUCCESS +Testing string containing spaces +TEST: 'hello mal world' -> ['',hello mal world] -> SUCCESS +Testing string containing symbols +TEST: '[]{}"\'* ;:()' -> ['',[]{}"'* ;:()] -> SUCCESS +Test long string +TEST: 'hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"\'* ;:() []{}"\'* ;:() []{}"\'*)' -> ['',hello world abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789 (;:() []{}"'* ;:() []{}"'* ;:() []{}"'*)] -> SUCCESS +Non alphanumeric characters +TEST: '!' -> ['',!] -> SUCCESS +TEST: '&' -> ['',&] -> SUCCESS +TEST: '+' -> ['',+] -> SUCCESS +TEST: ',' -> ['',,] -> SUCCESS +TEST: '-' -> ['',-] -> SUCCESS +TEST: '/' -> ['',/] -> SUCCESS +TEST: '<' -> ['',<] -> SUCCESS +TEST: '=' -> ['',=] -> SUCCESS +TEST: '>' -> ['',>] -> SUCCESS +TEST: '?' -> ['',?] -> SUCCESS +TEST: '@' -> ['',@] -> SUCCESS +TEST: '^' -> ['',^] -> SUCCESS +TEST: '_' -> ['',_] -> SUCCESS +TEST: '`' -> ['',`] -> SUCCESS +TEST: '~' -> ['',~] -> SUCCESS +------- Optional Functionality -------------- +------- (Not needed for self-hosting) ------- +Non alphanumeric characters +TEST: '#' -> ['',#] -> SUCCESS +TEST: '$' -> ['',$] -> SUCCESS +TEST: '%' -> ['',%] -> SUCCESS +TEST: '.' -> ['',.] -> SUCCESS +TEST: '|' -> ['',|] -> SUCCESS + +TEST RESULTS (for ../tests/step0_repl.mal): + 0: soft failing tests + 0: failing tests + 24: passing tests + 24: total tests + +Testing read of numbers +TEST: '1' -> ['',1] -> SUCCESS +TEST: '7' -> ['',7] -> SUCCESS +TEST: ' 7 ' -> ['',7] -> SUCCESS +TEST: '-123' -> ['',-123] -> SUCCESS +Testing read of symbols +TEST: '+' -> ['',+] -> SUCCESS +TEST: 'abc' -> ['',abc] -> SUCCESS +TEST: ' abc ' -> ['',abc] -> SUCCESS +TEST: 'abc5' -> ['',abc5] -> SUCCESS +TEST: 'abc-def' -> ['',abc-def] -> SUCCESS +Testing non-numbers starting with a dash. +TEST: '-' -> ['',-] -> SUCCESS +TEST: '-abc' -> ['',-abc] -> SUCCESS +TEST: '->>' -> ['',->>] -> SUCCESS +Testing read of lists +TEST: '(+ 1 2)' -> ['',(+ 1 2)] -> SUCCESS +TEST: '()' -> ['',()] -> SUCCESS +TEST: '( )' -> ['',()] -> SUCCESS +TEST: '(nil)' -> ['',(nil)] -> SUCCESS +TEST: '((3 4))' -> ['',((3 4))] -> SUCCESS +TEST: '(+ 1 (+ 2 3))' -> ['',(+ 1 (+ 2 3))] -> SUCCESS +TEST: ' ( + 1 (+ 2 3 ) ) ' -> ['',(+ 1 (+ 2 3))] -> SUCCESS +TEST: '(* 1 2)' -> ['',(* 1 2)] -> SUCCESS +TEST: '(** 1 2)' -> ['',(** 1 2)] -> SUCCESS +TEST: '(* -3 6)' -> ['',(* -3 6)] -> SUCCESS +TEST: '(()())' -> ['',(() ())] -> SUCCESS +Test commas as whitespace +TEST: '(1 2, 3,,,,),,' -> ['',(1 2 3)] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing read of nil/true/false +TEST: 'nil' -> ['',nil] -> SUCCESS +TEST: 'true' -> ['',true] -> SUCCESS +TEST: 'false' -> ['',false] -> SUCCESS +Testing read of strings +TEST: '"abc"' -> ['',"abc"] -> SUCCESS +TEST: ' "abc" ' -> ['',"abc"] -> SUCCESS +TEST: '"abc (with parens)"' -> ['',"abc (with parens)"] -> SUCCESS +TEST: '"abc\\"def"' -> ['',"abc\"def"] -> SUCCESS +TEST: '""' -> ['',""] -> SUCCESS +TEST: '"\\\\"' -> ['',"\\"] -> SUCCESS +TEST: '"\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"' -> ['',"\\\\\\\\\\\\\\\\\\"] -> SUCCESS +TEST: '"&"' -> ['',"&"] -> SUCCESS +TEST: '"\'"' -> ['',"'"] -> SUCCESS +TEST: '"("' -> ['',"("] -> SUCCESS +TEST: '")"' -> ['',")"] -> SUCCESS +TEST: '"*"' -> ['',"*"] -> SUCCESS +TEST: '"+"' -> ['',"+"] -> SUCCESS +TEST: '","' -> ['',","] -> SUCCESS +TEST: '"-"' -> ['',"-"] -> SUCCESS +TEST: '"/"' -> ['',"/"] -> SUCCESS +TEST: '":"' -> ['',":"] -> SUCCESS +TEST: '";"' -> ['',";"] -> SUCCESS +TEST: '"<"' -> ['',"<"] -> SUCCESS +TEST: '"="' -> ['',"="] -> SUCCESS +TEST: '">"' -> ['',">"] -> SUCCESS +TEST: '"?"' -> ['',"?"] -> SUCCESS +TEST: '"@"' -> ['',"@"] -> SUCCESS +TEST: '"["' -> ['',"["] -> SUCCESS +TEST: '"]"' -> ['',"]"] -> SUCCESS +TEST: '"^"' -> ['',"^"] -> SUCCESS +TEST: '"_"' -> ['',"_"] -> SUCCESS +TEST: '"`"' -> ['',"`"] -> SUCCESS +TEST: '"{"' -> ['',"{"] -> SUCCESS +TEST: '"}"' -> ['',"}"] -> SUCCESS +TEST: '"~"' -> ['',"~"] -> SUCCESS +TEST: '"!"' -> ['',"!"] -> SUCCESS +Testing reader errors +TEST: '(1 2' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '[1 2' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '"abc' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '"' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '"\\"' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '"\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '(1 "abc' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +TEST: '(1 "abc"' -> ['.*(EOF|end of input|unbalanced).*',] -> SUCCESS +Testing read of quoting +TEST: "'1" -> ['',(quote 1)] -> SUCCESS +TEST: "'(1 2 3)" -> ['',(quote (1 2 3))] -> SUCCESS +TEST: '`1' -> ['',(quasiquote 1)] -> SUCCESS +TEST: '`(1 2 3)' -> ['',(quasiquote (1 2 3))] -> SUCCESS +TEST: '~1' -> ['',(unquote 1)] -> SUCCESS +TEST: '~(1 2 3)' -> ['',(unquote (1 2 3))] -> SUCCESS +TEST: '`(1 ~a 3)' -> ['',(quasiquote (1 (unquote a) 3))] -> SUCCESS +TEST: '~@(1 2 3)' -> ['',(splice-unquote (1 2 3))] -> SUCCESS +Testing keywords +TEST: ':kw' -> ['',:kw] -> SUCCESS +TEST: '(:kw1 :kw2 :kw3)' -> ['',(:kw1 :kw2 :kw3)] -> SUCCESS +Testing read of vectors +TEST: '[+ 1 2]' -> ['',[+ 1 2]] -> SUCCESS +TEST: '[]' -> ['',[]] -> SUCCESS +TEST: '[ ]' -> ['',[]] -> SUCCESS +TEST: '[[3 4]]' -> ['',[[3 4]]] -> SUCCESS +TEST: '[+ 1 [+ 2 3]]' -> ['',[+ 1 [+ 2 3]]] -> SUCCESS +TEST: ' [ + 1 [+ 2 3 ] ] ' -> ['',[+ 1 [+ 2 3]]] -> SUCCESS +TEST: '([])' -> ['',([])] -> SUCCESS +Testing read of hash maps +TEST: '{}' -> ['',{}] -> SUCCESS +TEST: '{ }' -> ['',{}] -> SUCCESS +TEST: '{"abc" 1}' -> ['',{"abc" 1}] -> SUCCESS +TEST: '{"a" {"b" 2}}' -> ['',{"a" {"b" 2}}] -> SUCCESS +TEST: '{"a" {"b" {"c" 3}}}' -> ['',{"a" {"b" {"c" 3}}}] -> SUCCESS +TEST: '{ "a" {"b" { "cde" 3 } }}' -> ['',{"a" {"b" {"cde" 3}}}] -> SUCCESS +TEST: '{"a1" 1 "a2" 2 "a3" 3}' -> ['{"a([1-3])" \\1 "a(?!\\1)([1-3])" \\2 "a(?!\\1)(?!\\2)([1-3])" \\3}',] -> SUCCESS +TEST: '{ :a {:b { :cde 3 } }}' -> ['',{:a {:b {:cde 3}}}] -> SUCCESS +TEST: '{"1" 1}' -> ['',{"1" 1}] -> SUCCESS +TEST: '({})' -> ['',({})] -> SUCCESS +Testing read of comments +TEST: ' ;; whole line comment (not an exception)' -> ['',] -> SUCCESS (result ignored) +TEST: '1 ; comment after expression' -> ['',1] -> SUCCESS +TEST: '1; comment after expression' -> ['',1] -> SUCCESS +Testing read of @/deref +TEST: '@a' -> ['',(deref a)] -> SUCCESS + +-------- Optional Functionality -------- +Testing read of ^/metadata +TEST: '^{"a" 1} [1 2 3]' -> ['',(with-meta [1 2 3] {"a" 1})] -> SUCCESS +Non alphanumerice characters in strings +TEST: '"\\n"' -> ['',"\n"] -> SUCCESS +TEST: '"#"' -> ['',"#"] -> SUCCESS +TEST: '"$"' -> ['',"$"] -> SUCCESS +TEST: '"%"' -> ['',"%"] -> SUCCESS +TEST: '"."' -> ['',"."] -> SUCCESS +TEST: '"\\\\"' -> ['',"\\"] -> SUCCESS +TEST: '"|"' -> ['',"|"] -> SUCCESS +Non alphanumeric characters in comments +TEST: '1;!' -> ['',1] -> SUCCESS +TEST: '1;"' -> ['',1] -> SUCCESS +TEST: '1;#' -> ['',1] -> SUCCESS +TEST: '1;$' -> ['',1] -> SUCCESS +TEST: '1;%' -> ['',1] -> SUCCESS +TEST: "1;'" -> ['',1] -> SUCCESS +TEST: '1;\\' -> ['',1] -> SUCCESS +TEST: '1;\\\\' -> ['',1] -> SUCCESS +TEST: '1;\\\\\\' -> ['',1] -> SUCCESS +TEST: '1;`' -> ['',1] -> SUCCESS +TEST: '1; &()*+,-./:;<=>?@[]^_{|}~' -> ['',1] -> SUCCESS + +TEST RESULTS (for ../tests/step1_read_print.mal): + 0: soft failing tests + 0: failing tests + 117: passing tests + 117: total tests + +Testing evaluation of arithmetic operations +TEST: '(+ 1 2)' -> ['',3] -> SUCCESS +TEST: '(+ 5 (* 2 3))' -> ['',11] -> SUCCESS +TEST: '(- (+ 5 (* 2 3)) 3)' -> ['',8] -> SUCCESS +TEST: '(/ (- (+ 5 (* 2 3)) 3) 4)' -> ['',2] -> SUCCESS +TEST: '(/ (- (+ 515 (* 87 311)) 302) 27)' -> ['',1010] -> SUCCESS +TEST: '(* -3 6)' -> ['',-18] -> SUCCESS +TEST: '(/ (- (+ 515 (* -87 311)) 296) 27)' -> ['',-994] -> SUCCESS +TEST: '(abc 1 2 3)' -> ['.+',] -> SUCCESS +Testing empty list +TEST: '()' -> ['',()] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing evaluation within collection literals +TEST: '[1 2 (+ 1 2)]' -> ['',[1 2 3]] -> SUCCESS +TEST: '{"a" (+ 7 8)}' -> ['',{"a" 15}] -> SUCCESS +TEST: '{:a (+ 7 8)}' -> ['',{:a 15}] -> SUCCESS +Check that evaluation hasn't broken empty collections +TEST: '[]' -> ['',[]] -> SUCCESS +TEST: '{}' -> ['',{}] -> SUCCESS + +TEST RESULTS (for ../tests/step2_eval.mal): + 0: soft failing tests + 0: failing tests + 14: passing tests + 14: total tests + +Testing REPL_ENV +TEST: '(+ 1 2)' -> ['',3] -> SUCCESS +TEST: '(/ (- (+ 5 (* 2 3)) 3) 4)' -> ['',2] -> SUCCESS +Testing def! +TEST: '(def! x 3)' -> ['',3] -> SUCCESS +TEST: 'x' -> ['',3] -> SUCCESS +TEST: '(def! x 4)' -> ['',4] -> SUCCESS +TEST: 'x' -> ['',4] -> SUCCESS +TEST: '(def! y (+ 1 7))' -> ['',8] -> SUCCESS +TEST: 'y' -> ['',8] -> SUCCESS +Verifying symbols are case-sensitive +TEST: '(def! mynum 111)' -> ['',111] -> SUCCESS +TEST: '(def! MYNUM 222)' -> ['',222] -> SUCCESS +TEST: 'mynum' -> ['',111] -> SUCCESS +TEST: 'MYNUM' -> ['',222] -> SUCCESS +Check env lookup non-fatal error +TEST: '(abc 1 2 3)' -> [".*\\'?abc\\'? not found.*",] -> SUCCESS +Check that error aborts def! +TEST: '(def! w 123)' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! w (abc))' -> ['',] -> SUCCESS (result ignored) +TEST: 'w' -> ['',123] -> SUCCESS +Testing let* +TEST: '(let* (z 9) z)' -> ['',9] -> SUCCESS +TEST: '(let* (x 9) x)' -> ['',9] -> SUCCESS +TEST: 'x' -> ['',4] -> SUCCESS +TEST: '(let* (z (+ 2 3)) (+ 1 z))' -> ['',6] -> SUCCESS +TEST: '(let* (p (+ 2 3) q (+ 2 p)) (+ p q))' -> ['',12] -> SUCCESS +TEST: '(def! y (let* (z 7) z))' -> ['',] -> SUCCESS (result ignored) +TEST: 'y' -> ['',7] -> SUCCESS +Testing outer environment +TEST: '(def! a 4)' -> ['',4] -> SUCCESS +TEST: '(let* (q 9) q)' -> ['',9] -> SUCCESS +TEST: '(let* (q 9) a)' -> ['',4] -> SUCCESS +TEST: '(let* (z 2) (let* (q 9) a))' -> ['',4] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing let* with vector bindings +TEST: '(let* [z 9] z)' -> ['',9] -> SUCCESS +TEST: '(let* [p (+ 2 3) q (+ 2 p)] (+ p q))' -> ['',12] -> SUCCESS +Testing vector evaluation +TEST: '(let* (a 5 b 6) [3 4 a [b 7] 8])' -> ['',[3 4 5 [6 7] 8]] -> SUCCESS + +-------- Optional Functionality -------- +Check that last assignment takes priority +TEST: '(let* (x 2 x 3) x)' -> ['',3] -> SUCCESS + +TEST RESULTS (for ../tests/step3_env.mal): + 0: soft failing tests + 0: failing tests + 31: passing tests + 31: total tests + +----------------------------------------------------- +Testing list functions +TEST: '(list)' -> ['',()] -> SUCCESS +TEST: '(list? (list))' -> ['',true] -> SUCCESS +TEST: '(empty? (list))' -> ['',true] -> SUCCESS +TEST: '(empty? (list 1))' -> ['',false] -> SUCCESS +TEST: '(list 1 2 3)' -> ['',(1 2 3)] -> SUCCESS +TEST: '(count (list 1 2 3))' -> ['',3] -> SUCCESS +TEST: '(count (list))' -> ['',0] -> SUCCESS +TEST: '(count nil)' -> ['',0] -> SUCCESS +TEST: '(if (> (count (list 1 2 3)) 3) 89 78)' -> ['',78] -> SUCCESS +TEST: '(if (>= (count (list 1 2 3)) 3) 89 78)' -> ['',89] -> SUCCESS +Testing if form +TEST: '(if true 7 8)' -> ['',7] -> SUCCESS +TEST: '(if false 7 8)' -> ['',8] -> SUCCESS +TEST: '(if false 7 false)' -> ['',false] -> SUCCESS +TEST: '(if true (+ 1 7) (+ 1 8))' -> ['',8] -> SUCCESS +TEST: '(if false (+ 1 7) (+ 1 8))' -> ['',9] -> SUCCESS +TEST: '(if nil 7 8)' -> ['',8] -> SUCCESS +TEST: '(if 0 7 8)' -> ['',7] -> SUCCESS +TEST: '(if (list) 7 8)' -> ['',7] -> SUCCESS +TEST: '(if (list 1 2 3) 7 8)' -> ['',7] -> SUCCESS +TEST: '(= (list) nil)' -> ['',false] -> SUCCESS +Testing 1-way if form +TEST: '(if false (+ 1 7))' -> ['',nil] -> SUCCESS +TEST: '(if nil 8)' -> ['',nil] -> SUCCESS +TEST: '(if nil 8 7)' -> ['',7] -> SUCCESS +TEST: '(if true (+ 1 7))' -> ['',8] -> SUCCESS +Testing basic conditionals +TEST: '(= 2 1)' -> ['',false] -> SUCCESS +TEST: '(= 1 1)' -> ['',true] -> SUCCESS +TEST: '(= 1 2)' -> ['',false] -> SUCCESS +TEST: '(= 1 (+ 1 1))' -> ['',false] -> SUCCESS +TEST: '(= 2 (+ 1 1))' -> ['',true] -> SUCCESS +TEST: '(= nil 1)' -> ['',false] -> SUCCESS +TEST: '(= nil nil)' -> ['',true] -> SUCCESS +TEST: '(> 2 1)' -> ['',true] -> SUCCESS +TEST: '(> 1 1)' -> ['',false] -> SUCCESS +TEST: '(> 1 2)' -> ['',false] -> SUCCESS +TEST: '(>= 2 1)' -> ['',true] -> SUCCESS +TEST: '(>= 1 1)' -> ['',true] -> SUCCESS +TEST: '(>= 1 2)' -> ['',false] -> SUCCESS +TEST: '(< 2 1)' -> ['',false] -> SUCCESS +TEST: '(< 1 1)' -> ['',false] -> SUCCESS +TEST: '(< 1 2)' -> ['',true] -> SUCCESS +TEST: '(<= 2 1)' -> ['',false] -> SUCCESS +TEST: '(<= 1 1)' -> ['',true] -> SUCCESS +TEST: '(<= 1 2)' -> ['',true] -> SUCCESS +Testing equality +TEST: '(= 1 1)' -> ['',true] -> SUCCESS +TEST: '(= 0 0)' -> ['',true] -> SUCCESS +TEST: '(= 1 0)' -> ['',false] -> SUCCESS +TEST: '(= true true)' -> ['',true] -> SUCCESS +TEST: '(= false false)' -> ['',true] -> SUCCESS +TEST: '(= nil nil)' -> ['',true] -> SUCCESS +TEST: '(= (list) (list))' -> ['',true] -> SUCCESS +TEST: '(= (list) ())' -> ['',true] -> SUCCESS +TEST: '(= (list 1 2) (list 1 2))' -> ['',true] -> SUCCESS +TEST: '(= (list 1) (list))' -> ['',false] -> SUCCESS +TEST: '(= (list) (list 1))' -> ['',false] -> SUCCESS +TEST: '(= 0 (list))' -> ['',false] -> SUCCESS +TEST: '(= (list) 0)' -> ['',false] -> SUCCESS +TEST: '(= (list nil) (list))' -> ['',false] -> SUCCESS +Testing builtin and user defined functions +TEST: '(+ 1 2)' -> ['',3] -> SUCCESS +TEST: '( (fn* (a b) (+ b a)) 3 4)' -> ['',7] -> SUCCESS +TEST: '( (fn* () 4) )' -> ['',4] -> SUCCESS +TEST: '( (fn* (f x) (f x)) (fn* (a) (+ 1 a)) 7)' -> ['',8] -> SUCCESS +Testing closures +TEST: '( ( (fn* (a) (fn* (b) (+ a b))) 5) 7)' -> ['',12] -> SUCCESS +TEST: '(def! gen-plus5 (fn* () (fn* (b) (+ 5 b))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! plus5 (gen-plus5))' -> ['',] -> SUCCESS (result ignored) +TEST: '(plus5 7)' -> ['',12] -> SUCCESS +TEST: '(def! gen-plusX (fn* (x) (fn* (b) (+ x b))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! plus7 (gen-plusX 7))' -> ['',] -> SUCCESS (result ignored) +TEST: '(plus7 8)' -> ['',15] -> SUCCESS +Testing do form +TEST: '(do (prn 101))' -> ['101\n',nil] -> SUCCESS +TEST: '(do (prn 102) 7)' -> ['102\n',7] -> SUCCESS +TEST: '(do (prn 101) (prn 102) (+ 1 2))' -> ['101\n102\n',3] -> SUCCESS +TEST: '(do (def! a 6) 7 (+ a 8))' -> ['',14] -> SUCCESS +TEST: 'a' -> ['',6] -> SUCCESS +Testing special form case-sensitivity +TEST: '(def! DO (fn* (a) 7))' -> ['',] -> SUCCESS (result ignored) +TEST: '(DO 3)' -> ['',7] -> SUCCESS +Testing recursive sumdown function +TEST: '(def! sumdown (fn* (N) (if (> N 0) (+ N (sumdown (- N 1))) 0)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(sumdown 1)' -> ['',1] -> SUCCESS +TEST: '(sumdown 2)' -> ['',3] -> SUCCESS +TEST: '(sumdown 6)' -> ['',21] -> SUCCESS +Testing recursive fibonacci function +TEST: '(def! fib (fn* (N) (if (= N 0) 1 (if (= N 1) 1 (+ (fib (- N 1)) (fib (- N 2)))))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(fib 1)' -> ['',1] -> SUCCESS +TEST: '(fib 2)' -> ['',2] -> SUCCESS +TEST: '(fib 4)' -> ['',5] -> SUCCESS +Testing recursive function in environment. +TEST: '(let* (f (fn* () x) x 3) (f))' -> ['',3] -> SUCCESS +TEST: '(let* (cst (fn* (n) (if (= n 0) nil (cst (- n 1))))) (cst 1))' -> ['',nil] -> SUCCESS +TEST: '(let* (f (fn* (n) (if (= n 0) 0 (g (- n 1)))) g (fn* (n) (f n))) (f 2))' -> ['',0] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing if on strings +TEST: '(if "" 7 8)' -> ['',7] -> SUCCESS +Testing string equality +TEST: '(= "" "")' -> ['',true] -> SUCCESS +TEST: '(= "abc" "abc")' -> ['',true] -> SUCCESS +TEST: '(= "abc" "")' -> ['',false] -> SUCCESS +TEST: '(= "" "abc")' -> ['',false] -> SUCCESS +TEST: '(= "abc" "def")' -> ['',false] -> SUCCESS +TEST: '(= "abc" "ABC")' -> ['',false] -> SUCCESS +TEST: '(= (list) "")' -> ['',false] -> SUCCESS +TEST: '(= "" (list))' -> ['',false] -> SUCCESS +Testing variable length arguments +TEST: '( (fn* (& more) (count more)) 1 2 3)' -> ['',3] -> SUCCESS +TEST: '( (fn* (& more) (list? more)) 1 2 3)' -> ['',true] -> SUCCESS +TEST: '( (fn* (& more) (count more)) 1)' -> ['',1] -> SUCCESS +TEST: '( (fn* (& more) (count more)) )' -> ['',0] -> SUCCESS +TEST: '( (fn* (& more) (list? more)) )' -> ['',true] -> SUCCESS +TEST: '( (fn* (a & more) (count more)) 1 2 3)' -> ['',2] -> SUCCESS +TEST: '( (fn* (a & more) (count more)) 1)' -> ['',0] -> SUCCESS +TEST: '( (fn* (a & more) (list? more)) 1)' -> ['',true] -> SUCCESS +Testing language defined not function +TEST: '(not false)' -> ['',true] -> SUCCESS +TEST: '(not nil)' -> ['',true] -> SUCCESS +TEST: '(not true)' -> ['',false] -> SUCCESS +TEST: '(not "a")' -> ['',false] -> SUCCESS +TEST: '(not 0)' -> ['',false] -> SUCCESS +----------------------------------------------------- +Testing string quoting +TEST: '""' -> ['',""] -> SUCCESS +TEST: '"abc"' -> ['',"abc"] -> SUCCESS +TEST: '"abc def"' -> ['',"abc def"] -> SUCCESS +TEST: '"\\""' -> ['',"\""] -> SUCCESS +TEST: '"abc\\ndef\\nghi"' -> ['',"abc\ndef\nghi"] -> SUCCESS +TEST: '"abc\\\\def\\\\ghi"' -> ['',"abc\\def\\ghi"] -> SUCCESS +TEST: '"\\\\n"' -> ['',"\\n"] -> SUCCESS +Testing pr-str +TEST: '(pr-str)' -> ['',""] -> SUCCESS +TEST: '(pr-str "")' -> ['',"\"\""] -> SUCCESS +TEST: '(pr-str "abc")' -> ['',"\"abc\""] -> SUCCESS +TEST: '(pr-str "abc def" "ghi jkl")' -> ['',"\"abc def\" \"ghi jkl\""] -> SUCCESS +TEST: '(pr-str "\\"")' -> ['',"\"\\\"\""] -> SUCCESS +TEST: '(pr-str (list 1 2 "abc" "\\"") "def")' -> ['',"(1 2 \"abc\" \"\\\"\") \"def\""] -> SUCCESS +TEST: '(pr-str "abc\\ndef\\nghi")' -> ['',"\"abc\\ndef\\nghi\""] -> SUCCESS +TEST: '(pr-str "abc\\\\def\\\\ghi")' -> ['',"\"abc\\\\def\\\\ghi\""] -> SUCCESS +TEST: '(pr-str (list))' -> ['',"()"] -> SUCCESS +Testing str +TEST: '(str)' -> ['',""] -> SUCCESS +TEST: '(str "")' -> ['',""] -> SUCCESS +TEST: '(str "abc")' -> ['',"abc"] -> SUCCESS +TEST: '(str "\\"")' -> ['',"\""] -> SUCCESS +TEST: '(str 1 "abc" 3)' -> ['',"1abc3"] -> SUCCESS +TEST: '(str "abc def" "ghi jkl")' -> ['',"abc defghi jkl"] -> SUCCESS +TEST: '(str "abc\\ndef\\nghi")' -> ['',"abc\ndef\nghi"] -> SUCCESS +TEST: '(str "abc\\\\def\\\\ghi")' -> ['',"abc\\def\\ghi"] -> SUCCESS +TEST: '(str (list 1 2 "abc" "\\"") "def")' -> ['',"(1 2 abc \")def"] -> SUCCESS +TEST: '(str (list))' -> ['',"()"] -> SUCCESS +Testing prn +TEST: '(prn)' -> ['\n',nil] -> SUCCESS +TEST: '(prn "")' -> ['""\n',nil] -> SUCCESS +TEST: '(prn "abc")' -> ['"abc"\n',nil] -> SUCCESS +TEST: '(prn "abc def" "ghi jkl")' -> ['"abc def" "ghi jkl"',] -> SUCCESS +TEST: '(prn "\\"")' -> ['"\\\\""\n',nil] -> SUCCESS +TEST: '(prn "abc\\ndef\\nghi")' -> ['"abc\\\\ndef\\\\nghi"\n',nil] -> SUCCESS +TEST: '(prn "abc\\\\def\\\\ghi")' -> ['"abc\\\\\\\\def\\\\\\\\ghi"',] -> SUCCESS +TEST: 'nil' -> ['',] -> SUCCESS (result ignored) +TEST: '(prn (list 1 2 "abc" "\\"") "def")' -> ['\\(1 2 "abc" "\\\\""\\) "def"\n',nil] -> SUCCESS +Testing println +TEST: '(println)' -> ['\n',nil] -> SUCCESS +TEST: '(println "")' -> ['\n',nil] -> SUCCESS +TEST: '(println "abc")' -> ['abc\n',nil] -> SUCCESS +TEST: '(println "abc def" "ghi jkl")' -> ['abc def ghi jkl',] -> SUCCESS +TEST: '(println "\\"")' -> ['"\n',nil] -> SUCCESS +TEST: '(println "abc\\ndef\\nghi")' -> ['abc\ndef\nghi\n',nil] -> SUCCESS +TEST: '(println "abc\\\\def\\\\ghi")' -> ['abc\\\\def\\\\ghi\n',nil] -> SUCCESS +TEST: '(println (list 1 2 "abc" "\\"") "def")' -> ['\\(1 2 abc "\\) def\n',nil] -> SUCCESS +Testing keywords +TEST: '(= :abc :abc)' -> ['',true] -> SUCCESS +TEST: '(= :abc :def)' -> ['',false] -> SUCCESS +TEST: '(= :abc ":abc")' -> ['',false] -> SUCCESS +TEST: '(= (list :abc) (list :abc))' -> ['',true] -> SUCCESS +Testing vector truthiness +TEST: '(if [] 7 8)' -> ['',7] -> SUCCESS +Testing vector printing +TEST: '(pr-str [1 2 "abc" "\\""] "def")' -> ['',"[1 2 \"abc\" \"\\\"\"] \"def\""] -> SUCCESS +TEST: '(pr-str [])' -> ['',"[]"] -> SUCCESS +TEST: '(str [1 2 "abc" "\\""] "def")' -> ['',"[1 2 abc \"]def"] -> SUCCESS +TEST: '(str [])' -> ['',"[]"] -> SUCCESS +Testing vector functions +TEST: '(count [1 2 3])' -> ['',3] -> SUCCESS +TEST: '(empty? [1 2 3])' -> ['',false] -> SUCCESS +TEST: '(empty? [])' -> ['',true] -> SUCCESS +TEST: '(list? [4 5 6])' -> ['',false] -> SUCCESS +Testing vector equality +TEST: '(= [] (list))' -> ['',true] -> SUCCESS +TEST: '(= [7 8] [7 8])' -> ['',true] -> SUCCESS +TEST: '(= [:abc] [:abc])' -> ['',true] -> SUCCESS +TEST: '(= (list 1 2) [1 2])' -> ['',true] -> SUCCESS +TEST: '(= (list 1) [])' -> ['',false] -> SUCCESS +TEST: '(= [] [1])' -> ['',false] -> SUCCESS +TEST: '(= 0 [])' -> ['',false] -> SUCCESS +TEST: '(= [] 0)' -> ['',false] -> SUCCESS +TEST: '(= [] "")' -> ['',false] -> SUCCESS +TEST: '(= "" [])' -> ['',false] -> SUCCESS +Testing vector parameter lists +TEST: '( (fn* [] 4) )' -> ['',4] -> SUCCESS +TEST: '( (fn* [f x] (f x)) (fn* [a] (+ 1 a)) 7)' -> ['',8] -> SUCCESS +Nested vector/list equality +TEST: '(= [(list)] (list []))' -> ['',true] -> SUCCESS +TEST: '(= [1 2 (list 3 4 [5 6])] (list 1 2 [3 4 (list 5 6)]))' -> ['',true] -> SUCCESS + +TEST RESULTS (for ../tests/step4_if_fn_do.mal): + 0: soft failing tests + 0: failing tests + 178: passing tests + 178: total tests + +Testing recursive tail-call function +TEST: '(def! sum2 (fn* (n acc) (if (= n 0) acc (sum2 (- n 1) (+ n acc)))))' -> ['',] -> SUCCESS (result ignored) +TODO: test let*, and do for TCO +TEST: '(sum2 10 0)' -> ['',55] -> SUCCESS +TEST: '(def! res2 nil)' -> ['',nil] -> SUCCESS +TEST: '(def! res2 (sum2 10000 0))' -> ['',] -> SUCCESS (result ignored) +TEST: 'res2' -> ['',50005000] -> SUCCESS +Test mutually recursive tail-call functions +TEST: '(def! foo (fn* (n) (if (= n 0) 0 (bar (- n 1)))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! bar (fn* (n) (if (= n 0) 0 (foo (- n 1)))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(foo 10000)' -> ['',0] -> SUCCESS + +TEST RESULTS (for ../tests/step5_tco.mal): + 0: soft failing tests + 0: failing tests + 8: passing tests + 8: total tests + + +Testing that (do (do)) not broken by TCO +TEST: '(do (do 1 2))' -> ['',2] -> SUCCESS + +Testing read-string, eval and slurp +TEST: '(read-string "(1 2 (3 4) nil)")' -> ['',(1 2 (3 4) nil)] -> SUCCESS +TEST: '(= nil (read-string "nil"))' -> ['',true] -> SUCCESS +TEST: '(read-string "(+ 2 3)")' -> ['',(+ 2 3)] -> SUCCESS +TEST: '(read-string "\\"\\n\\"")' -> ['',"\n"] -> SUCCESS +TEST: '(read-string "7 ;; comment")' -> ['',7] -> SUCCESS +TEST: '(read-string ";; comment")' -> ['',] -> SUCCESS (result ignored) +TEST: '(eval (read-string "(+ 2 3)"))' -> ['',5] -> SUCCESS +TEST: '(slurp "../tests/test.txt")' -> ['',"A line of text\n"] -> SUCCESS +TEST: '(slurp "../tests/test.txt")' -> ['',"A line of text\n"] -> SUCCESS +Testing load-file +TEST: '(load-file "../tests/inc.mal")' -> ['',nil] -> SUCCESS +TEST: '(inc1 7)' -> ['',8] -> SUCCESS +TEST: '(inc2 7)' -> ['',9] -> SUCCESS +TEST: '(inc3 9)' -> ['',12] -> SUCCESS + +Testing atoms +TEST: '(def! inc3 (fn* (a) (+ 3 a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! a (atom 2))' -> ['',(atom 2)] -> SUCCESS +TEST: '(atom? a)' -> ['',true] -> SUCCESS +TEST: '(atom? 1)' -> ['',false] -> SUCCESS +TEST: '(deref a)' -> ['',2] -> SUCCESS +TEST: '(reset! a 3)' -> ['',3] -> SUCCESS +TEST: '(deref a)' -> ['',3] -> SUCCESS +TEST: '(swap! a inc3)' -> ['',6] -> SUCCESS +TEST: '(deref a)' -> ['',6] -> SUCCESS +TEST: '(swap! a (fn* (a) a))' -> ['',6] -> SUCCESS +TEST: '(swap! a (fn* (a) (* 2 a)))' -> ['',12] -> SUCCESS +TEST: '(swap! a (fn* (a b) (* a b)) 10)' -> ['',120] -> SUCCESS +TEST: '(swap! a + 3)' -> ['',123] -> SUCCESS +Testing swap!/closure interaction +TEST: '(def! inc-it (fn* (a) (+ 1 a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! atm (atom 7))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! f (fn* () (swap! atm inc-it)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(f)' -> ['',8] -> SUCCESS +TEST: '(f)' -> ['',9] -> SUCCESS +Testing whether closures can retain atoms +TEST: '(def! g (let* (atm (atom 0)) (fn* () (deref atm))))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! atm (atom 1))' -> ['',] -> SUCCESS (result ignored) +TEST: '(g)' -> ['',0] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing reading of large files +TEST: '(load-file "../tests/computations.mal")' -> ['',nil] -> SUCCESS +TEST: '(sumdown 2)' -> ['',3] -> SUCCESS +TEST: '(fib 2)' -> ['',1] -> SUCCESS +Testing `@` reader macro (short for `deref`) +TEST: '(def! atm (atom 9))' -> ['',] -> SUCCESS (result ignored) +TEST: '@atm' -> ['',9] -> SUCCESS +Testing that vector params not broken by TCO +TEST: '(def! g (fn* [] 78))' -> ['',] -> SUCCESS (result ignored) +TEST: '(g)' -> ['',78] -> SUCCESS +TEST: '(def! g (fn* [a] (+ a 78)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(g 3)' -> ['',81] -> SUCCESS + +Testing that *ARGV* exists and is an empty list +TEST: '(list? *ARGV*)' -> ['',true] -> SUCCESS +TEST: '*ARGV*' -> ['',()] -> SUCCESS + +Testing that eval sets aa in root scope, and that it is found in nested scope +TEST: '(let* (b 12) (do (eval (read-string "(def! aa 7)")) aa ))' -> ['',7] -> SUCCESS + +-------- Optional Functionality -------- +Testing comments in a file +TEST: '(load-file "../tests/incB.mal")' -> ['',nil] -> SUCCESS +TEST: '(inc4 7)' -> ['',11] -> SUCCESS +TEST: '(inc5 7)' -> ['',12] -> SUCCESS +Testing map literal across multiple lines in a file +TEST: '(load-file "../tests/incC.mal")' -> ['',nil] -> SUCCESS +TEST: 'mymap' -> ['',{"a" 1}] -> SUCCESS +Checking that eval does not use local environments. +TEST: '(def! a 1)' -> ['',1] -> SUCCESS +TEST: '(let* (a 2) (eval (read-string "a")))' -> ['',1] -> SUCCESS +Non alphanumeric characters in comments in read-string +TEST: '(read-string "1;!")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\\"")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;#")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;$")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;%")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\'")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\\\\")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\\\\\\\\")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;\\\\\\\\\\\\")' -> ['',1] -> SUCCESS +TEST: '(read-string "1;`")' -> ['',1] -> SUCCESS +TEST: '(read-string "1; &()*+,-./:;<=>?@[]^_{|}~")' -> ['',1] -> SUCCESS + +TEST RESULTS (for ../tests/step6_file.mal): + 0: soft failing tests + 0: failing tests + 65: passing tests + 65: total tests + +Testing cons function +TEST: '(cons 1 (list))' -> ['',(1)] -> SUCCESS +TEST: '(cons 1 (list 2))' -> ['',(1 2)] -> SUCCESS +TEST: '(cons 1 (list 2 3))' -> ['',(1 2 3)] -> SUCCESS +TEST: '(cons (list 1) (list 2 3))' -> ['',((1) 2 3)] -> SUCCESS +TEST: '(def! a (list 2 3))' -> ['',] -> SUCCESS (result ignored) +TEST: '(cons 1 a)' -> ['',(1 2 3)] -> SUCCESS +TEST: 'a' -> ['',(2 3)] -> SUCCESS +Testing concat function +TEST: '(concat)' -> ['',()] -> SUCCESS +TEST: '(concat (list 1 2))' -> ['',(1 2)] -> SUCCESS +TEST: '(concat (list 1 2) (list 3 4))' -> ['',(1 2 3 4)] -> SUCCESS +TEST: '(concat (list 1 2) (list 3 4) (list 5 6))' -> ['',(1 2 3 4 5 6)] -> SUCCESS +TEST: '(concat (concat))' -> ['',()] -> SUCCESS +TEST: '(concat (list) (list))' -> ['',()] -> SUCCESS +TEST: '(= () (concat))' -> ['',true] -> SUCCESS +TEST: '(def! a (list 1 2))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! b (list 3 4))' -> ['',] -> SUCCESS (result ignored) +TEST: '(concat a b (list 5 6))' -> ['',(1 2 3 4 5 6)] -> SUCCESS +TEST: 'a' -> ['',(1 2)] -> SUCCESS +TEST: 'b' -> ['',(3 4)] -> SUCCESS +Testing regular quote +TEST: '(quote 7)' -> ['',7] -> SUCCESS +TEST: '(quote (1 2 3))' -> ['',(1 2 3)] -> SUCCESS +TEST: '(quote (1 2 (3 4)))' -> ['',(1 2 (3 4))] -> SUCCESS +Testing simple quasiquote +TEST: '(quasiquote nil)' -> ['',nil] -> SUCCESS +TEST: '(quasiquote 7)' -> ['',7] -> SUCCESS +TEST: '(quasiquote a)' -> ['',a] -> SUCCESS +TEST: '(quasiquote {"a" b})' -> ['',{"a" b}] -> SUCCESS +Testing quasiquote with lists +TEST: '(quasiquote ())' -> ['',()] -> SUCCESS +TEST: '(quasiquote (1 2 3))' -> ['',(1 2 3)] -> SUCCESS +TEST: '(quasiquote (a))' -> ['',(a)] -> SUCCESS +TEST: '(quasiquote (1 2 (3 4)))' -> ['',(1 2 (3 4))] -> SUCCESS +TEST: '(quasiquote (nil))' -> ['',(nil)] -> SUCCESS +TEST: '(quasiquote (1 ()))' -> ['',(1 ())] -> SUCCESS +TEST: '(quasiquote (() 1))' -> ['',(() 1)] -> SUCCESS +TEST: '(quasiquote (1 () 2))' -> ['',(1 () 2)] -> SUCCESS +TEST: '(quasiquote (()))' -> ['',(())] -> SUCCESS +(quasiquote (f () g (h) i (j k) l)) +=>(f () g (h) i (j k) l) +Testing unquote +TEST: '(quasiquote (unquote 7))' -> ['',7] -> SUCCESS +TEST: '(def! a 8)' -> ['',8] -> SUCCESS +TEST: '(quasiquote a)' -> ['',a] -> SUCCESS +TEST: '(quasiquote (unquote a))' -> ['',8] -> SUCCESS +TEST: '(quasiquote (1 a 3))' -> ['',(1 a 3)] -> SUCCESS +TEST: '(quasiquote (1 (unquote a) 3))' -> ['',(1 8 3)] -> SUCCESS +TEST: '(def! b (quote (1 "b" "d")))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '(quasiquote (1 b 3))' -> ['',(1 b 3)] -> SUCCESS +TEST: '(quasiquote (1 (unquote b) 3))' -> ['',(1 (1 "b" "d") 3)] -> SUCCESS +TEST: '(quasiquote ((unquote 1) (unquote 2)))' -> ['',(1 2)] -> SUCCESS +Quasiquote and environments +TEST: '(let* (x 0) (quasiquote (unquote x)))' -> ['',0] -> SUCCESS +Testing splice-unquote +TEST: '(def! c (quote (1 "b" "d")))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '(quasiquote (1 c 3))' -> ['',(1 c 3)] -> SUCCESS +TEST: '(quasiquote (1 (splice-unquote c) 3))' -> ['',(1 1 "b" "d" 3)] -> SUCCESS +TEST: '(quasiquote (1 (splice-unquote c)))' -> ['',(1 1 "b" "d")] -> SUCCESS +TEST: '(quasiquote ((splice-unquote c) 2))' -> ['',(1 "b" "d" 2)] -> SUCCESS +TEST: '(quasiquote ((splice-unquote c) (splice-unquote c)))' -> ['',(1 "b" "d" 1 "b" "d")] -> SUCCESS +Testing symbol equality +TEST: '(= (quote abc) (quote abc))' -> ['',true] -> SUCCESS +TEST: '(= (quote abc) (quote abcd))' -> ['',false] -> SUCCESS +TEST: '(= (quote abc) "abc")' -> ['',false] -> SUCCESS +TEST: '(= "abc" (quote abc))' -> ['',false] -> SUCCESS +TEST: '(= "abc" (str (quote abc)))' -> ['',true] -> SUCCESS +TEST: '(= (quote abc) nil)' -> ['',false] -> SUCCESS +TEST: '(= nil (quote abc))' -> ['',false] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing ' (quote) reader macro +TEST: "'7" -> ['',7] -> SUCCESS +TEST: "'(1 2 3)" -> ['',(1 2 3)] -> SUCCESS +TEST: "'(1 2 (3 4))" -> ['',(1 2 (3 4))] -> SUCCESS +Testing cons and concat with vectors +TEST: '(cons 1 [])' -> ['',(1)] -> SUCCESS +TEST: '(cons [1] [2 3])' -> ['',([1] 2 3)] -> SUCCESS +TEST: '(cons 1 [2 3])' -> ['',(1 2 3)] -> SUCCESS +TEST: '(concat [1 2] (list 3 4) [5 6])' -> ['',(1 2 3 4 5 6)] -> SUCCESS +TEST: '(concat [1 2])' -> ['',(1 2)] -> SUCCESS + +-------- Optional Functionality -------- +Testing ` (quasiquote) reader macro +TEST: '`7' -> ['',7] -> SUCCESS +TEST: '`(1 2 3)' -> ['',(1 2 3)] -> SUCCESS +TEST: '`(1 2 (3 4))' -> ['',(1 2 (3 4))] -> SUCCESS +TEST: '`(nil)' -> ['',(nil)] -> SUCCESS +Testing ~ (unquote) reader macro +TEST: '`~7' -> ['',7] -> SUCCESS +TEST: '(def! a 8)' -> ['',8] -> SUCCESS +TEST: '`(1 ~a 3)' -> ['',(1 8 3)] -> SUCCESS +TEST: '(def! b \'(1 "b" "d"))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '`(1 b 3)' -> ['',(1 b 3)] -> SUCCESS +TEST: '`(1 ~b 3)' -> ['',(1 (1 "b" "d") 3)] -> SUCCESS +Testing ~@ (splice-unquote) reader macro +TEST: '(def! c \'(1 "b" "d"))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '`(1 c 3)' -> ['',(1 c 3)] -> SUCCESS +TEST: '`(1 ~@c 3)' -> ['',(1 1 "b" "d" 3)] -> SUCCESS +Testing vec function +TEST: '(vec (list))' -> ['',[]] -> SUCCESS +TEST: '(vec (list 1))' -> ['',[1]] -> SUCCESS +TEST: '(vec (list 1 2))' -> ['',[1 2]] -> SUCCESS +TEST: '(vec [])' -> ['',[]] -> SUCCESS +TEST: '(vec [1 2])' -> ['',[1 2]] -> SUCCESS +Testing that vec does not mutate the original list +TEST: '(def! a (list 1 2))' -> ['',] -> SUCCESS (result ignored) +TEST: '(vec a)' -> ['',[1 2]] -> SUCCESS +TEST: 'a' -> ['',(1 2)] -> SUCCESS +Test quine +TEST: '((fn* (q) (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* (q) (quasiquote ((unquote q) (quote (unquote q)))))))' -> ['',((fn* (q) (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* (q) (quasiquote ((unquote q) (quote (unquote q)))))))] -> SUCCESS +Testing quasiquote with vectors +TEST: '(quasiquote [])' -> ['',[]] -> SUCCESS +TEST: '(quasiquote [[]])' -> ['',[[]]] -> SUCCESS +TEST: '(quasiquote [()])' -> ['',[()]] -> SUCCESS +TEST: '(quasiquote ([]))' -> ['',([])] -> SUCCESS +TEST: '(def! a 8)' -> ['',8] -> SUCCESS +TEST: '`[1 a 3]' -> ['',[1 a 3]] -> SUCCESS +TEST: '(quasiquote [a [] b [c] d [e f] g])' -> ['',[a [] b [c] d [e f] g]] -> SUCCESS +Testing unquote with vectors +TEST: '`[~a]' -> ['',[8]] -> SUCCESS +TEST: '`[(~a)]' -> ['',[(8)]] -> SUCCESS +TEST: '`([~a])' -> ['',([8])] -> SUCCESS +TEST: '`[a ~a a]' -> ['',[a 8 a]] -> SUCCESS +TEST: '`([a ~a a])' -> ['',([a 8 a])] -> SUCCESS +TEST: '`[(a ~a a)]' -> ['',[(a 8 a)]] -> SUCCESS +Testing splice-unquote with vectors +TEST: '(def! c \'(1 "b" "d"))' -> ['',(1 "b" "d")] -> SUCCESS +TEST: '`[~@c]' -> ['',[1 "b" "d"]] -> SUCCESS +TEST: '`[(~@c)]' -> ['',[(1 "b" "d")]] -> SUCCESS +TEST: '`([~@c])' -> ['',([1 "b" "d"])] -> SUCCESS +TEST: '`[1 ~@c 3]' -> ['',[1 1 "b" "d" 3]] -> SUCCESS +TEST: '`([1 ~@c 3])' -> ['',([1 1 "b" "d" 3])] -> SUCCESS +TEST: '`[(1 ~@c 3)]' -> ['',[(1 1 "b" "d" 3)]] -> SUCCESS +Misplaced unquote or splice-unquote +TEST: '`(0 unquote)' -> ['',(0 unquote)] -> SUCCESS +TEST: '`(0 splice-unquote)' -> ['',(0 splice-unquote)] -> SUCCESS +TEST: '`[unquote 0]' -> ['',[unquote 0]] -> SUCCESS +TEST: '`[splice-unquote 0]' -> ['',[splice-unquote 0]] -> SUCCESS +Debugging quasiquote +TEST: '(quasiquoteexpand nil)' -> ['',nil] -> SUCCESS +TEST: '(quasiquoteexpand 7)' -> ['',7] -> SUCCESS +TEST: '(quasiquoteexpand a)' -> ['',(quote a)] -> SUCCESS +TEST: '(quasiquoteexpand {"a" b})' -> ['',(quote {"a" b})] -> SUCCESS +TEST: '(quasiquoteexpand ())' -> ['',()] -> SUCCESS +TEST: '(quasiquoteexpand (1 2 3))' -> ['',(cons 1 (cons 2 (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (a))' -> ['',(cons (quote a) ())] -> SUCCESS +TEST: '(quasiquoteexpand (1 2 (3 4)))' -> ['',(cons 1 (cons 2 (cons (cons 3 (cons 4 ())) ())))] -> SUCCESS +TEST: '(quasiquoteexpand (nil))' -> ['',(cons nil ())] -> SUCCESS +TEST: '(quasiquoteexpand (1 ()))' -> ['',(cons 1 (cons () ()))] -> SUCCESS +TEST: '(quasiquoteexpand (() 1))' -> ['',(cons () (cons 1 ()))] -> SUCCESS +TEST: '(quasiquoteexpand (1 () 2))' -> ['',(cons 1 (cons () (cons 2 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (()))' -> ['',(cons () ())] -> SUCCESS +TEST: '(quasiquoteexpand (f () g (h) i (j k) l))' -> ['',(cons (quote f) (cons () (cons (quote g) (cons (cons (quote h) ()) (cons (quote i) (cons (cons (quote j) (cons (quote k) ())) (cons (quote l) ())))))))] -> SUCCESS +TEST: '(quasiquoteexpand (unquote 7))' -> ['',7] -> SUCCESS +TEST: '(quasiquoteexpand a)' -> ['',(quote a)] -> SUCCESS +TEST: '(quasiquoteexpand (unquote a))' -> ['',a] -> SUCCESS +TEST: '(quasiquoteexpand (1 a 3))' -> ['',(cons 1 (cons (quote a) (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 (unquote a) 3))' -> ['',(cons 1 (cons a (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 b 3))' -> ['',(cons 1 (cons (quote b) (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 (unquote b) 3))' -> ['',(cons 1 (cons b (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand ((unquote 1) (unquote 2)))' -> ['',(cons 1 (cons 2 ()))] -> SUCCESS +TEST: '(quasiquoteexpand (a (splice-unquote (b c)) d))' -> ['',(cons (quote a) (concat (b c) (cons (quote d) ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 c 3))' -> ['',(cons 1 (cons (quote c) (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 (splice-unquote c) 3))' -> ['',(cons 1 (concat c (cons 3 ())))] -> SUCCESS +TEST: '(quasiquoteexpand (1 (splice-unquote c)))' -> ['',(cons 1 (concat c ()))] -> SUCCESS +TEST: '(quasiquoteexpand ((splice-unquote c) 2))' -> ['',(concat c (cons 2 ()))] -> SUCCESS +TEST: '(quasiquoteexpand ((splice-unquote c) (splice-unquote c)))' -> ['',(concat c (concat c ()))] -> SUCCESS +TEST: '(quasiquoteexpand [])' -> ['',(vec ())] -> SUCCESS +TEST: '(quasiquoteexpand [[]])' -> ['',(vec (cons (vec ()) ()))] -> SUCCESS +TEST: '(quasiquoteexpand [()])' -> ['',(vec (cons () ()))] -> SUCCESS +TEST: '(quasiquoteexpand ([]))' -> ['',(cons (vec ()) ())] -> SUCCESS +TEST: '(quasiquoteexpand [1 a 3])' -> ['',(vec (cons 1 (cons (quote a) (cons 3 ()))))] -> SUCCESS +TEST: '(quasiquoteexpand [a [] b [c] d [e f] g])' -> ['',(vec (cons (quote a) (cons (vec ()) (cons (quote b) (cons (vec (cons (quote c) ())) (cons (quote d) (cons (vec (cons (quote e) (cons (quote f) ()))) (cons (quote g) ()))))))))] -> SUCCESS + +TEST RESULTS (for ../tests/step7_quote.mal): + 0: soft failing tests + 0: failing tests + 147: passing tests + 147: total tests + +Testing trivial macros +TEST: '(defmacro! one (fn* () 1))' -> ['',] -> SUCCESS (result ignored) +TEST: '(one)' -> ['',1] -> SUCCESS +TEST: '(defmacro! two (fn* () 2))' -> ['',] -> SUCCESS (result ignored) +TEST: '(two)' -> ['',2] -> SUCCESS +Testing unless macros +TEST: '(defmacro! unless (fn* (pred a b) `(if ~pred ~b ~a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(unless false 7 8)' -> ['',7] -> SUCCESS +TEST: '(unless true 7 8)' -> ['',8] -> SUCCESS +TEST: "(defmacro! unless2 (fn* (pred a b) (list 'if (list 'not pred) a b)))" -> ['',] -> SUCCESS (result ignored) +TEST: '(unless2 false 7 8)' -> ['',7] -> SUCCESS +TEST: '(unless2 true 7 8)' -> ['',8] -> SUCCESS +Testing macroexpand +TEST: '(macroexpand (one))' -> ['',1] -> SUCCESS +TEST: '(macroexpand (unless PRED A B))' -> ['',(if PRED B A)] -> SUCCESS +TEST: '(macroexpand (unless2 PRED A B))' -> ['',(if (not PRED) A B)] -> SUCCESS +TEST: '(macroexpand (unless2 2 3 4))' -> ['',(if (not 2) 3 4)] -> SUCCESS +Testing evaluation of macro result +TEST: '(defmacro! identity (fn* (x) x))' -> ['',] -> SUCCESS (result ignored) +TEST: '(let* (a 123) (macroexpand (identity a)))' -> ['',a] -> SUCCESS +TEST: '(let* (a 123) (identity a))' -> ['',123] -> SUCCESS +Test that macros do not break empty list +TEST: '()' -> ['',()] -> SUCCESS +Test that macros do not break quasiquote +TEST: '`(1)' -> ['',(1)] -> SUCCESS + +-------- Deferrable Functionality -------- +Testing non-macro function +TEST: '(not (= 1 1))' -> ['',false] -> SUCCESS +TEST: '(not (= 1 2))' -> ['',true] -> SUCCESS +Testing nth, first and rest functions +TEST: '(nth (list 1) 0)' -> ['',1] -> SUCCESS +TEST: '(nth (list 1 2) 1)' -> ['',2] -> SUCCESS +TEST: '(nth (list 1 2 nil) 2)' -> ['',nil] -> SUCCESS +TEST: '(def! x "x")' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! x (nth (list 1 2) 2))' -> ['',] -> SUCCESS (result ignored) +TEST: 'x' -> ['',"x"] -> SUCCESS +TEST: '(first (list))' -> ['',nil] -> SUCCESS +TEST: '(first (list 6))' -> ['',6] -> SUCCESS +TEST: '(first (list 7 8 9))' -> ['',7] -> SUCCESS +TEST: '(rest (list))' -> ['',()] -> SUCCESS +TEST: '(rest (list 6))' -> ['',()] -> SUCCESS +TEST: '(rest (list 7 8 9))' -> ['',(8 9)] -> SUCCESS +Testing cond macro +TEST: '(macroexpand (cond))' -> ['',nil] -> SUCCESS +TEST: '(cond)' -> ['',nil] -> SUCCESS +TEST: '(macroexpand (cond X Y))' -> ['',(if X Y (cond))] -> SUCCESS +TEST: '(cond true 7)' -> ['',7] -> SUCCESS +TEST: '(cond false 7)' -> ['',nil] -> SUCCESS +TEST: '(macroexpand (cond X Y Z T))' -> ['',(if X Y (cond Z T))] -> SUCCESS +TEST: '(cond true 7 true 8)' -> ['',7] -> SUCCESS +TEST: '(cond false 7 true 8)' -> ['',8] -> SUCCESS +TEST: '(cond false 7 false 8 "else" 9)' -> ['',9] -> SUCCESS +TEST: '(cond false 7 (= 2 2) 8 "else" 9)' -> ['',8] -> SUCCESS +TEST: '(cond false 7 false 8 false 9)' -> ['',nil] -> SUCCESS +Testing EVAL in let* +TEST: '(let* (x (cond false "no" true "yes")) x)' -> ['',"yes"] -> SUCCESS +Testing nth, first, rest with vectors +TEST: '(nth [1] 0)' -> ['',1] -> SUCCESS +TEST: '(nth [1 2] 1)' -> ['',2] -> SUCCESS +TEST: '(nth [1 2 nil] 2)' -> ['',nil] -> SUCCESS +TEST: '(def! x "x")' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! x (nth [1 2] 2))' -> ['',] -> SUCCESS (result ignored) +TEST: 'x' -> ['',"x"] -> SUCCESS +TEST: '(first [])' -> ['',nil] -> SUCCESS +TEST: '(first nil)' -> ['',nil] -> SUCCESS +TEST: '(first [10])' -> ['',10] -> SUCCESS +TEST: '(first [10 11 12])' -> ['',10] -> SUCCESS +TEST: '(rest [])' -> ['',()] -> SUCCESS +TEST: '(rest nil)' -> ['',()] -> SUCCESS +TEST: '(rest [10])' -> ['',()] -> SUCCESS +TEST: '(rest [10 11 12])' -> ['',(11 12)] -> SUCCESS +TEST: '(rest (cons 10 [11 12]))' -> ['',(11 12)] -> SUCCESS +Testing EVAL in vector let* +TEST: '(let* [x (cond false "no" true "yes")] x)' -> ['',"yes"] -> SUCCESS + +------- Optional Functionality -------------- +------- (Not needed for self-hosting) ------- +Test that macros use closures +TEST: '(def! x 2)' -> ['',] -> SUCCESS (result ignored) +TEST: '(defmacro! a (fn* [] x))' -> ['',] -> SUCCESS (result ignored) +TEST: '(a)' -> ['',2] -> SUCCESS +TEST: '(let* (x 3) (a))' -> ['',2] -> SUCCESS + +TEST RESULTS (for ../tests/step8_macros.mal): + 0: soft failing tests + 0: failing tests + 65: passing tests + 65: total tests + + +Testing throw +TEST: '(throw "err1")' -> ['.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*err1.*',] -> SUCCESS + +Testing try*/catch* +TEST: '(try* 123 (catch* e 456))' -> ['',123] -> SUCCESS +TEST: '(try* abc (catch* exc (prn "exc is:" exc)))' -> ['"exc is:" "\'abc\' not found"\n',nil] -> SUCCESS +TEST: '(try* (abc 1 2) (catch* exc (prn "exc is:" exc)))' -> ['"exc is:" "\'abc\' not found"\n',nil] -> SUCCESS +Make sure error from core can be caught +TEST: '(try* (nth () 1) (catch* exc (prn "exc is:" exc)))' -> ['"exc is:".*(length|range|[Bb]ounds|beyond).*\n',nil] -> SUCCESS +TEST: '(try* (throw "my exception") (catch* exc (do (prn "exc:" exc) 7)))' -> ['"exc:" "my exception"\n',7] -> SUCCESS +Test that exception handlers get restored correctly +TEST: '(try* (do (try* "t1" (catch* e "c1")) (throw "e1")) (catch* e "c2"))' -> ['',"c2"] -> SUCCESS +TEST: '(try* (try* (throw "e1") (catch* e (throw "e2"))) (catch* e "c2"))' -> ['',"c2"] -> SUCCESS +TEST: '(try* (map throw (list "my err")) (catch* exc exc))' -> ['',"my err"] -> SUCCESS + +Testing builtin functions +TEST: "(symbol? 'abc)" -> ['',true] -> SUCCESS +TEST: '(symbol? "abc")' -> ['',false] -> SUCCESS +TEST: '(nil? nil)' -> ['',true] -> SUCCESS +TEST: '(nil? true)' -> ['',false] -> SUCCESS +TEST: '(true? true)' -> ['',true] -> SUCCESS +TEST: '(true? false)' -> ['',false] -> SUCCESS +TEST: '(true? true?)' -> ['',false] -> SUCCESS +TEST: '(false? false)' -> ['',true] -> SUCCESS +TEST: '(false? true)' -> ['',false] -> SUCCESS +Testing apply function with core functions +TEST: '(apply + (list 2 3))' -> ['',5] -> SUCCESS +TEST: '(apply + 4 (list 5))' -> ['',9] -> SUCCESS +TEST: '(apply prn (list 1 2 "3" (list)))' -> ['1 2 "3" \\(\\)\n',nil] -> SUCCESS +TEST: '(apply prn 1 2 (list "3" (list)))' -> ['1 2 "3" \\(\\)\n',nil] -> SUCCESS +TEST: '(apply list (list))' -> ['',()] -> SUCCESS +TEST: '(apply symbol? (list (quote two)))' -> ['',true] -> SUCCESS +Testing apply function with user functions +TEST: '(apply (fn* (a b) (+ a b)) (list 2 3))' -> ['',5] -> SUCCESS +TEST: '(apply (fn* (a b) (+ a b)) 4 (list 5))' -> ['',9] -> SUCCESS +Testing map function +TEST: '(def! nums (list 1 2 3))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! double (fn* (a) (* 2 a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(double 3)' -> ['',6] -> SUCCESS +TEST: '(map double nums) ' -> ['',(2 4 6)] -> SUCCESS +TEST: '(map (fn* (x) (symbol? x)) (list 1 (quote two) "three"))' -> ['',(false true false)] -> SUCCESS +TEST: '(= () (map str ()))' -> ['',true] -> SUCCESS + +------- Deferrable Functionality ---------- +------- (Needed for self-hosting) ------- +Testing symbol and keyword functions +TEST: '(symbol? :abc)' -> ['',false] -> SUCCESS +TEST: "(symbol? 'abc)" -> ['',true] -> SUCCESS +TEST: '(symbol? "abc")' -> ['',false] -> SUCCESS +TEST: '(symbol? (symbol "abc"))' -> ['',true] -> SUCCESS +TEST: '(keyword? :abc)' -> ['',true] -> SUCCESS +TEST: "(keyword? 'abc)" -> ['',false] -> SUCCESS +TEST: '(keyword? "abc")' -> ['',false] -> SUCCESS +TEST: '(keyword? "")' -> ['',false] -> SUCCESS +TEST: '(keyword? (keyword "abc"))' -> ['',true] -> SUCCESS +TEST: '(symbol "abc")' -> ['',abc] -> SUCCESS +TEST: '(keyword "abc")' -> ['',:abc] -> SUCCESS +Testing sequential? function +TEST: '(sequential? (list 1 2 3))' -> ['',true] -> SUCCESS +TEST: '(sequential? [15])' -> ['',true] -> SUCCESS +TEST: '(sequential? sequential?)' -> ['',false] -> SUCCESS +TEST: '(sequential? nil)' -> ['',false] -> SUCCESS +TEST: '(sequential? "abc")' -> ['',false] -> SUCCESS +Testing apply function with core functions and arguments in vector +TEST: '(apply + 4 [5])' -> ['',9] -> SUCCESS +TEST: '(apply prn 1 2 ["3" 4])' -> ['1 2 "3" 4\n',nil] -> SUCCESS +TEST: '(apply list [])' -> ['',()] -> SUCCESS +Testing apply function with user functions and arguments in vector +TEST: '(apply (fn* (a b) (+ a b)) [2 3])' -> ['',5] -> SUCCESS +TEST: '(apply (fn* (a b) (+ a b)) 4 [5])' -> ['',9] -> SUCCESS +Testing map function with vectors +TEST: '(map (fn* (a) (* 2 a)) [1 2 3])' -> ['',(2 4 6)] -> SUCCESS +TEST: '(map (fn* [& args] (list? args)) [1 2])' -> ['',(true true)] -> SUCCESS +Testing vector functions +TEST: '(vector? [10 11])' -> ['',true] -> SUCCESS +TEST: "(vector? '(12 13))" -> ['',false] -> SUCCESS +TEST: '(vector 3 4 5)' -> ['',[3 4 5]] -> SUCCESS +TEST: '(= [] (vector))' -> ['',true] -> SUCCESS +TEST: '(map? {})' -> ['',true] -> SUCCESS +TEST: "(map? '())" -> ['',false] -> SUCCESS +TEST: '(map? [])' -> ['',false] -> SUCCESS +TEST: "(map? 'abc)" -> ['',false] -> SUCCESS +TEST: '(map? :abc)' -> ['',false] -> SUCCESS + +Testing hash-maps +TEST: '(hash-map "a" 1)' -> ['',{"a" 1}] -> SUCCESS +TEST: '{"a" 1}' -> ['',{"a" 1}] -> SUCCESS +TEST: '(assoc {} "a" 1)' -> ['',{"a" 1}] -> SUCCESS +TEST: '(get (assoc (assoc {"a" 1 } "b" 2) "c" 3) "a")' -> ['',1] -> SUCCESS +TEST: '(def! hm1 (hash-map))' -> ['',{}] -> SUCCESS +TEST: '(map? hm1)' -> ['',true] -> SUCCESS +TEST: '(map? 1)' -> ['',false] -> SUCCESS +TEST: '(map? "abc")' -> ['',false] -> SUCCESS +TEST: '(get nil "a")' -> ['',nil] -> SUCCESS +TEST: '(get hm1 "a")' -> ['',nil] -> SUCCESS +TEST: '(contains? hm1 "a")' -> ['',false] -> SUCCESS +TEST: '(def! hm2 (assoc hm1 "a" 1))' -> ['',{"a" 1}] -> SUCCESS +TEST: '(get hm1 "a")' -> ['',nil] -> SUCCESS +TEST: '(contains? hm1 "a")' -> ['',false] -> SUCCESS +TEST: '(get hm2 "a")' -> ['',1] -> SUCCESS +TEST: '(contains? hm2 "a")' -> ['',true] -> SUCCESS +TEST: '(keys hm1)' -> ['',()] -> SUCCESS +TEST: '(= () (keys hm1))' -> ['',true] -> SUCCESS +TEST: '(keys hm2)' -> ['',("a")] -> SUCCESS +TEST: '(keys {"1" 1})' -> ['',("1")] -> SUCCESS +TEST: '(vals hm1)' -> ['',()] -> SUCCESS +TEST: '(= () (vals hm1))' -> ['',true] -> SUCCESS +TEST: '(vals hm2)' -> ['',(1)] -> SUCCESS +TEST: '(count (keys (assoc hm2 "b" 2 "c" 3)))' -> ['',3] -> SUCCESS +Testing keywords as hash-map keys +TEST: '(get {:abc 123} :abc)' -> ['',123] -> SUCCESS +TEST: '(contains? {:abc 123} :abc)' -> ['',true] -> SUCCESS +TEST: '(contains? {:abcd 123} :abc)' -> ['',false] -> SUCCESS +TEST: '(assoc {} :bcd 234)' -> ['',{:bcd 234}] -> SUCCESS +TEST: '(keyword? (nth (keys {:abc 123 :def 456}) 0))' -> ['',true] -> SUCCESS +TEST: '(keyword? (nth (vals {"a" :abc "b" :def}) 0))' -> ['',true] -> SUCCESS +Testing whether assoc updates properly +TEST: '(def! hm4 (assoc {:a 1 :b 2} :a 3 :c 1))' -> ['',] -> SUCCESS (result ignored) +TEST: '(get hm4 :a)' -> ['',3] -> SUCCESS +TEST: '(get hm4 :b)' -> ['',2] -> SUCCESS +TEST: '(get hm4 :c)' -> ['',1] -> SUCCESS +Testing nil as hash-map values +TEST: '(contains? {:abc nil} :abc)' -> ['',true] -> SUCCESS +TEST: '(assoc {} :bcd nil)' -> ['',{:bcd nil}] -> SUCCESS + +Additional str and pr-str tests +TEST: '(str "A" {:abc "val"} "Z")' -> ['',"A{:abc val}Z"] -> SUCCESS +TEST: '(str true "." false "." nil "." :keyw "." \'symb)' -> ['',"true.false.nil.:keyw.symb"] -> SUCCESS +TEST: '(pr-str "A" {:abc "val"} "Z")' -> ['',"\"A\" {:abc \"val\"} \"Z\""] -> SUCCESS +TEST: '(pr-str true "." false "." nil "." :keyw "." \'symb)' -> ['',"true \".\" false \".\" nil \".\" :keyw \".\" symb"] -> SUCCESS +TEST: '(def! s (str {:abc "val1" :def "val2"}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(cond (= s "{:abc val1 :def val2}") true (= s "{:def val2 :abc val1}") true)' -> ['',true] -> SUCCESS +TEST: '(def! p (pr-str {:abc "val1" :def "val2"}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(cond (= p "{:abc \\"val1\\" :def \\"val2\\"}") true (= p "{:def \\"val2\\" :abc \\"val1\\"}") true)' -> ['',true] -> SUCCESS + +Test extra function arguments as Mal List (bypassing TCO with apply) +TEST: '(apply (fn* (& more) (list? more)) [1 2 3])' -> ['',true] -> SUCCESS +TEST: '(apply (fn* (& more) (list? more)) [])' -> ['',true] -> SUCCESS +TEST: '(apply (fn* (a & more) (list? more)) [1])' -> ['',true] -> SUCCESS + +------- Optional Functionality -------------- +------- (Not needed for self-hosting) ------- +Testing throwing a hash-map +TEST: '(throw {:msg "err2"})' -> ['.*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*msg.*err2.*',] -> SUCCESS + +Testing try* without catch* +TEST: '(try* xyz)' -> [".*\\'?xyz\\'? not found.*",] -> SUCCESS + +Testing throwing non-strings +TEST: '(try* (throw (list 1 2 3)) (catch* exc (do (prn "err:" exc) 7)))' -> ['"err:" \\(1 2 3\\)\n',7] -> SUCCESS + +Testing dissoc +TEST: '(def! hm3 (assoc hm2 "b" 2))' -> ['',] -> SUCCESS (result ignored) +TEST: '(count (keys hm3))' -> ['',2] -> SUCCESS +TEST: '(count (vals hm3))' -> ['',2] -> SUCCESS +TEST: '(dissoc hm3 "a")' -> ['',{"b" 2}] -> SUCCESS +TEST: '(dissoc hm3 "a" "b")' -> ['',{}] -> SUCCESS +TEST: '(dissoc hm3 "a" "b" "c")' -> ['',{}] -> SUCCESS +TEST: '(count (keys hm3))' -> ['',2] -> SUCCESS +TEST: '(dissoc {:cde 345 :fgh 456} :cde)' -> ['',{:fgh 456}] -> SUCCESS +TEST: '(dissoc {:cde nil :fgh 456} :cde)' -> ['',{:fgh 456}] -> SUCCESS + +Testing equality of hash-maps +TEST: '(= {} {})' -> ['',true] -> SUCCESS +TEST: '(= {} (hash-map))' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b 22} (hash-map :b 22 :a 11))' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b [22 33]} (hash-map :b [22 33] :a 11))' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b {:c 33}} (hash-map :b {:c 33} :a 11))' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b 22} (hash-map :b 23 :a 11))' -> ['',false] -> SUCCESS +TEST: '(= {:a 11 :b 22} (hash-map :a 11))' -> ['',false] -> SUCCESS +TEST: '(= {:a [11 22]} {:a (list 11 22)})' -> ['',true] -> SUCCESS +TEST: '(= {:a 11 :b 22} (list :a 11 :b 22))' -> ['',false] -> SUCCESS +TEST: '(= {} [])' -> ['',false] -> SUCCESS +TEST: '(= [] {})' -> ['',false] -> SUCCESS +TEST: '(keyword :abc)' -> ['',:abc] -> SUCCESS +TEST: '(keyword? (first (keys {":abc" 123 ":def" 456})))' -> ['',false] -> SUCCESS +Testing that hashmaps don't alter function ast +TEST: '(def! bar (fn* [a] {:foo (get a :foo)}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(bar {:foo (fn* [x] x)})' -> ['',] -> SUCCESS (result ignored) +TEST: '(bar {:foo 3})' -> ['',] -> SUCCESS (result ignored) +shouldn't give an error + +TEST RESULTS (for ../tests/step9_try.mal): + 0: soft failing tests + 0: failing tests + 139: passing tests + 139: total tests + +Started with: +Mal [powershell] + + +Testing readline +TEST: '(readline "mal-user> ")' -> ['',] -> SUCCESS (result ignored) +TEST: '"hello"' -> ['',"\"hello\""] -> SUCCESS + +Testing *host-language* +TEST: '(= "something bogus" *host-language*)' -> ['',false] -> SUCCESS + +------- Deferrable Functionality ---------- +------- (Needed for self-hosting) ------- + + +Testing hash-map evaluation and atoms (i.e. an env) +TEST: '(def! e (atom {"+" +}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(swap! e assoc "-" -)' -> ['',] -> SUCCESS (result ignored) +TEST: '( (get @e "+") 7 8)' -> ['',15] -> SUCCESS +TEST: '( (get @e "-") 11 8)' -> ['',3] -> SUCCESS +TEST: '(swap! e assoc "foo" (list))' -> ['',] -> SUCCESS (result ignored) +TEST: '(get @e "foo")' -> ['',()] -> SUCCESS +TEST: '(swap! e assoc "bar" \'(1 2 3))' -> ['',] -> SUCCESS (result ignored) +TEST: '(get @e "bar")' -> ['',(1 2 3)] -> SUCCESS +Testing for presence of optional functions +TEST: '(do (list time-ms string? number? seq conj meta with-meta fn?) nil)' -> ['',nil] -> SUCCESS +TEST: "(map symbol? '(nil false true))" -> ['',(false false false)] -> SUCCESS +------------------------------------------------------------------ + +------- Optional Functionality -------------- +------- (Not needed for self-hosting) ------- +Testing metadata on functions + +Testing metadata on mal functions +TEST: '(meta (fn* (a) a))' -> ['',nil] -> SUCCESS +TEST: '(meta (with-meta (fn* (a) a) {"b" 1}))' -> ['',{"b" 1}] -> SUCCESS +TEST: '(meta (with-meta (fn* (a) a) "abc"))' -> ['',"abc"] -> SUCCESS +TEST: '(def! l-wm (with-meta (fn* (a) a) {"b" 2}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(meta l-wm)' -> ['',{"b" 2}] -> SUCCESS +TEST: '(meta (with-meta l-wm {"new_meta" 123}))' -> ['',{"new_meta" 123}] -> SUCCESS +TEST: '(meta l-wm)' -> ['',{"b" 2}] -> SUCCESS +TEST: '(def! f-wm (with-meta (fn* [a] (+ 1 a)) {"abc" 1}))' -> ['',] -> SUCCESS (result ignored) +TEST: '(meta f-wm)' -> ['',{"abc" 1}] -> SUCCESS +TEST: '(meta (with-meta f-wm {"new_meta" 123}))' -> ['',{"new_meta" 123}] -> SUCCESS +TEST: '(meta f-wm)' -> ['',{"abc" 1}] -> SUCCESS +TEST: '(def! f-wm2 ^{"abc" 1} (fn* [a] (+ 1 a)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(meta f-wm2)' -> ['',{"abc" 1}] -> SUCCESS +Meta of native functions should return nil (not fail) +TEST: '(meta +)' -> ['',nil] -> SUCCESS + +Make sure closures and metadata co-exist +TEST: '(def! gen-plusX (fn* (x) (with-meta (fn* (b) (+ x b)) {"meta" 1})))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! plus7 (gen-plusX 7))' -> ['',] -> SUCCESS (result ignored) +TEST: '(def! plus8 (gen-plusX 8))' -> ['',] -> SUCCESS (result ignored) +TEST: '(plus7 8)' -> ['',15] -> SUCCESS +TEST: '(meta plus7)' -> ['',{"meta" 1}] -> SUCCESS +TEST: '(meta plus8)' -> ['',{"meta" 1}] -> SUCCESS +TEST: '(meta (with-meta plus7 {"meta" 2}))' -> ['',{"meta" 2}] -> SUCCESS +TEST: '(meta plus8)' -> ['',{"meta" 1}] -> SUCCESS + +Testing string? function +TEST: '(string? "")' -> ['',true] -> SUCCESS +TEST: "(string? 'abc)" -> ['',false] -> SUCCESS +TEST: '(string? "abc")' -> ['',true] -> SUCCESS +TEST: '(string? :abc)' -> ['',false] -> SUCCESS +TEST: '(string? (keyword "abc"))' -> ['',false] -> SUCCESS +TEST: '(string? 234)' -> ['',false] -> SUCCESS +TEST: '(string? nil)' -> ['',false] -> SUCCESS +Testing number? function +TEST: '(number? 123)' -> ['',true] -> SUCCESS +TEST: '(number? -1)' -> ['',true] -> SUCCESS +TEST: '(number? nil)' -> ['',false] -> SUCCESS +TEST: '(number? false)' -> ['',false] -> SUCCESS +TEST: '(number? "123")' -> ['',false] -> SUCCESS +TEST: '(def! add1 (fn* (x) (+ x 1)))' -> ['',] -> SUCCESS (result ignored) +Testing fn? function +TEST: '(fn? +)' -> ['',true] -> SUCCESS +TEST: '(fn? add1)' -> ['',true] -> SUCCESS +TEST: '(fn? cond)' -> ['',false] -> SUCCESS +TEST: '(fn? "+")' -> ['',false] -> SUCCESS +TEST: '(fn? :+)' -> ['',false] -> SUCCESS +TEST: '(fn? ^{"ismacro" true} (fn* () 0))' -> ['',true] -> SUCCESS +Testing macro? function +TEST: '(macro? cond)' -> ['',true] -> SUCCESS +TEST: '(macro? +)' -> ['',false] -> SUCCESS +TEST: '(macro? add1)' -> ['',false] -> SUCCESS +TEST: '(macro? "+")' -> ['',false] -> SUCCESS +TEST: '(macro? :+)' -> ['',false] -> SUCCESS +TEST: '(macro? {})' -> ['',false] -> SUCCESS + +Testing conj function +TEST: '(conj (list) 1)' -> ['',(1)] -> SUCCESS +TEST: '(conj (list 1) 2)' -> ['',(2 1)] -> SUCCESS +TEST: '(conj (list 2 3) 4)' -> ['',(4 2 3)] -> SUCCESS +TEST: '(conj (list 2 3) 4 5 6)' -> ['',(6 5 4 2 3)] -> SUCCESS +TEST: '(conj (list 1) (list 2 3))' -> ['',((2 3) 1)] -> SUCCESS +TEST: '(conj [] 1)' -> ['',[1]] -> SUCCESS +TEST: '(conj [1] 2)' -> ['',[1 2]] -> SUCCESS +TEST: '(conj [2 3] 4)' -> ['',[2 3 4]] -> SUCCESS +TEST: '(conj [2 3] 4 5 6)' -> ['',[2 3 4 5 6]] -> SUCCESS +TEST: '(conj [1] [2 3])' -> ['',[1 [2 3]]] -> SUCCESS + +Testing seq function +TEST: '(seq "abc")' -> ['',("a" "b" "c")] -> SUCCESS +TEST: '(apply str (seq "this is a test"))' -> ['',"this is a test"] -> SUCCESS +TEST: "(seq '(2 3 4))" -> ['',(2 3 4)] -> SUCCESS +TEST: '(seq [2 3 4])' -> ['',(2 3 4)] -> SUCCESS +TEST: '(seq "")' -> ['',nil] -> SUCCESS +TEST: "(seq '())" -> ['',nil] -> SUCCESS +TEST: '(seq [])' -> ['',nil] -> SUCCESS +TEST: '(seq nil)' -> ['',nil] -> SUCCESS + +Testing metadata on collections +TEST: '(meta [1 2 3])' -> ['',nil] -> SUCCESS +TEST: '(with-meta [1 2 3] {"a" 1})' -> ['',[1 2 3]] -> SUCCESS +TEST: '(meta (with-meta [1 2 3] {"a" 1}))' -> ['',{"a" 1}] -> SUCCESS +TEST: '(vector? (with-meta [1 2 3] {"a" 1}))' -> ['',true] -> SUCCESS +TEST: '(meta (with-meta [1 2 3] "abc"))' -> ['',"abc"] -> SUCCESS +TEST: '(with-meta [] "abc")' -> ['',[]] -> SUCCESS +TEST: '(meta (with-meta (list 1 2 3) {"a" 1}))' -> ['',{"a" 1}] -> SUCCESS +TEST: '(list? (with-meta (list 1 2 3) {"a" 1}))' -> ['',true] -> SUCCESS +TEST: '(with-meta (list) {"a" 1})' -> ['',()] -> SUCCESS +TEST: '(empty? (with-meta (list) {"a" 1}))' -> ['',true] -> SUCCESS +TEST: '(meta (with-meta {"abc" 123} {"a" 1}))' -> ['',{"a" 1}] -> SUCCESS +TEST: '(map? (with-meta {"abc" 123} {"a" 1}))' -> ['',true] -> SUCCESS +TEST: '(with-meta {} {"a" 1})' -> ['',{}] -> SUCCESS +TEST: '(def! l-wm (with-meta [4 5 6] {"b" 2}))' -> ['',[4 5 6]] -> SUCCESS +TEST: '(meta l-wm)' -> ['',{"b" 2}] -> SUCCESS +TEST: '(meta (with-meta l-wm {"new_meta" 123}))' -> ['',{"new_meta" 123}] -> SUCCESS +TEST: '(meta l-wm)' -> ['',{"b" 2}] -> SUCCESS + +Testing metadata on builtin functions +TEST: '(meta +)' -> ['',nil] -> SUCCESS +TEST: '(def! f-wm3 ^{"def" 2} +)' -> ['',] -> SUCCESS (result ignored) +TEST: '(meta f-wm3)' -> ['',{"def" 2}] -> SOFT FAIL (line 275): + Expected : '\\{"def"\\ 2\\}' + Got : "Exception: 'f-wm3' not found" +TEST: '(meta +)' -> ['',nil] -> SUCCESS +Loading sumdown from computations.mal +TEST: '(load-file "../tests/computations.mal")' -> ['',nil] -> SUCCESS + +Testing time-ms function +TEST: '(def! start-time (time-ms))' -> ['',] -> SUCCESS (result ignored) +TEST: '(= start-time 0)' -> ['',false] -> SUCCESS +TEST: '(sumdown 10) ; Waste some time' -> ['',55] -> SUCCESS +TEST: '(> (time-ms) start-time)' -> ['',true] -> SUCCESS + +Test that defining a macro does not mutate an existing function. +TEST: '(def! f (fn* [x] (number? x)))' -> ['',] -> SUCCESS (result ignored) +TEST: '(defmacro! m f)' -> ['',] -> SUCCESS (result ignored) +TEST: '(f (+ 1 1))' -> ['',true] -> SOFT FAIL (line 298): + Expected : 'true' + Got : 'false' +TEST: '(m (+ 1 1))' -> ['',false] -> SUCCESS + +FAILURES: +SOFT FAILED TEST (line 275): (meta f-wm3) -> ['',{"def" 2}]: + Expected : '\\{"def"\\ 2\\}' + Got : "Exception: 'f-wm3' not found" +SOFT FAILED TEST (line 298): (f (+ 1 1)) -> ['',true]: + Expected : 'true' + Got : 'false' + +TEST RESULTS (for ../tests/stepA_mal.mal): + 2: soft failing tests + 0: failing tests + 106: passing tests + 108: total tests + diff --git "a/\346\226\260\345\273\272\346\226\207\346\234\254\346\226\207\346\241\243.txt" "b/\346\226\260\345\273\272\346\226\207\346\234\254\346\226\207\346\241\243.txt" new file mode 100644 index 0000000000..39943bb949 --- /dev/null +++ "b/\346\226\260\345\273\272\346\226\207\346\234\254\346\226\207\346\241\243.txt" @@ -0,0 +1,21 @@ +Testing evaluation of arithmetic operations +TEST: '(+ 1 2)' -> ['',3] -> SUCCESS +TEST: '(+ 5 (* 2 3))' -> ['',11] -> SUCCESS +TEST: '(- (+ 5 (* 2 3)) 3)' -> ['',8] -> SUCCESS +TEST: '(/ (- (+ 5 (* 2 3)) 3) 4)' -> ['',2] -> SUCCESS +TEST: '(/ (- (+ 515 (* 87 311)) 302) 27)' -> ['',1010] -> SUCCESS +TEST: '(* -3 6)' -> ['',-18] -> SUCCESS +TEST: '(/ (- (+ 515 (* -87 311)) 296) 27)' -> ['',-994] -> SUCCESS +TEST: '(abc 1 2 3)' -> ['.+',] +Exception: UnicodeDecodeError('utf-8', b'\xb9', 0, 1, 'invalid start byte') +Output before exception: +Exception: + +user> (abc 1 2 3) +Exception: 管道元素中的“&”后面的表达式生成无效的对象。该表达式必须生成命令名称、脚本块或 CommandInfo 对象。 +user> + + + + +